diff --git a/README.txt b/README.txt new file mode 100644 index 00000000..61a039cd --- /dev/null +++ b/README.txt @@ -0,0 +1,30 @@ +See documentation in 'doc' directory for more information. + +BRANCHES + +The repository contains these main branches: + +* master : stable branch +* +* +* + +RUNNING + +Make sure you source either env.sh (for sh shells) +or env.csh (for csh shells) to set up environment +variables for building. Then, + +cd wrfv2_fire +./configure # select an option for building +./compile em_fire &> compile.log + +This will take a while. Make sure that compile.log contains +no errors. ("grep Error compile.log" shouldn't return anything). +Finally, run the code with: + +cd test/em_fire +./run_me_first.csh +./wrf.exe + + diff --git a/env.csh b/env.csh new file mode 100644 index 00000000..b08b93df --- /dev/null +++ b/env.csh @@ -0,0 +1,6 @@ +setenv NETCDF /home/grads/jbeezley/wrf-libs/netcdf +setenv JASPERLIB /home/grads/jbeezley/wrf-libs/jasper/lib +setenv JASPERINC /home/grads/jbeezley/wrf-libs/jasper/include +setenv NCARG /home/grads/jbeezley/wrf-libs/ncarg +setenv NCARG $NCARG_ROOT +source /opt/intel/fce/9.1.036/bin/ifortvars.csh diff --git a/env.sh b/env.sh new file mode 100644 index 00000000..e176570e --- /dev/null +++ b/env.sh @@ -0,0 +1,7 @@ +export NETCDF=/opt/wrf-libs/netcdf +export JASPERLIB=/opt/wrf-libs/jasper/lib +export JASPERINC=/opt/wrf-libs/jasper/include +export NCARG=/opt/wrf-libs/ncarg +export NCARG_ROOT=$NCARG +source /opt/intel/fce/9.1.036/bin/ifortvars.sh +ulimit -s unlimited diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile new file mode 100644 index 00000000..8860f98e --- /dev/null +++ b/wrfv2_fire/Makefile @@ -0,0 +1,371 @@ +# Top level Makefile for wrf system + +LN = ln -s +MAKE = make -i -r +MV = /bin/mv +RM = /bin/rm -f + +deflt : + @ echo Please compile the code using ./compile + +include ./configure.wrf + +EM_MODULE_DIR = -I../dyn_em +EM_MODULES = $(EM_MODULE_DIR) + + +#### 3.d. add macros to specify the modules for this core + +#EXP_MODULE_DIR = -I../dyn_exp +#EXP_MODULES = $(EXP_MODULE_DIR) + + +NMM_MODULE_DIR = -I../dyn_nmm +NMM_MODULES = $(NMM_MODULE_DIR) + +ALL_MODULES = \ + $(EM_MODULE_DIR) \ + $(NMM_MODULES) \ + $(EXP_MODULES) \ + $(INCLUDE_MODULES) + +configcheck: + @if [ "$(A2DCASE)" -a "$(DMPARALLEL)" ] ; then \ + echo "------------------------------------------------------------------------------" ; \ + echo "WRF CONFIGURATION ERROR " ; \ + echo "The $(A2DCASE) case cannot be used on distributed memory parallel systems." ; \ + echo "Only 3D WRF cases will run on these systems." ; \ + echo "Please chose a different case or rerun configure and chose a different option." ; \ + echo "------------------------------------------------------------------------------" ; \ + exit 2 ; \ + fi + +framework_only : configcheck + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" ext + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" toolsdir + /bin/rm -f main/libwrflib.a + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" framework + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" shared + +wrf : framework_only + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" physics + if [ $(WRF_CHEM) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" chemics ; fi + if [ $(WRF_EM_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" em_core ; fi + if [ $(WRF_NMM_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" nmm_core ; fi + if [ $(WRF_EXP_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" exp_core ; fi + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf ) + ( cd run ; /bin/rm -f wrf.exe ; ln -s ../main/wrf.exe . ) + if [ $(ESMF_COUPLING) -eq 1 ] ; then \ + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf_ESMFApp ) ; \ + fi + +### 3.a. rules to build the framework and then the experimental core + +exp_wrf : configcheck + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" ext + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" toolsdir + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" framework + $(MAKE) MODULE_DIRS="$(ALL_MODULES)" shared + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=exp exp_wrf ) + + +nmm_wrf : wrf + + +# Eulerian mass coordinate initializations + +em_fire : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=fire em_ideal ) + ( cd test/em_fire ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_fire ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_fire ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_fire ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_fire ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_fire/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_fire/input_sounding . ) + +em_quarter_ss : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=quarter_ss em_ideal ) + ( cd test/em_quarter_ss ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_quarter_ss ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_quarter_ss ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_quarter_ss ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_quarter_ss ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_quarter_ss/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_quarter_ss/input_sounding . ) + +em_squall2d_x : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_x em_ideal ) + ( cd test/em_squall2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_squall2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_squall2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_squall2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_squall2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_squall2d_x/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_x/input_sounding . ) + +em_squall2d_y : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_y em_ideal ) + ( cd test/em_squall2d_y ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_squall2d_y ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_squall2d_y ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_squall2d_y ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_squall2d_y ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_squall2d_y/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_y/input_sounding . ) + +em_b_wave : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=b_wave em_ideal ) + ( cd test/em_b_wave ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_b_wave ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_b_wave ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_b_wave ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_b_wave ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_b_wave/namelist.input . ) + ( cd run ; /bin/rm -f input_jet ; ln -s ../test/em_b_wave/input_jet . ) + +convert_em : framework_only + if [ $(WRF_CONVERT) -eq 1 ] ; then \ + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" convert_em ) ; \ + fi + +#TBH: For now, link wrf.exe, wrf_ESMFApp.exe, and wrf_SST_ESMF.exe into +#TBH: test/em_esmf_exp when ESMF_COUPLING is set. Either wrf.exe or +#TBH: wrf_ESMFApp.exe can be used for stand-alone testing in this case. +#TBH: wrf_SST_ESMF.exe is a coupled application. Note that single make +#TBH: target $(SOLVER)_wrf_ESMFApp builds both wrf_ESMFApp.exe and +#TBH: wrf_SST_ESMF.exe. +#TBH: Is this a clear violation of the DRY principle? Oh yeah, you bet. +em_real : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_real ) + ( cd test/em_real ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + if [ $(ESMF_COUPLING) -eq 1 ] ; then \ + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_wrf_ESMFApp ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f wrf_ESMFApp.exe ; ln -s ../../main/wrf_ESMFApp.exe . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f wrf_SST_ESMF.exe ; ln -s ../../main/wrf_SST_ESMF.exe . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f real.exe ; ln -s ../../main/real.exe . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f ETAMPNEW_DATA RRTM_DATA ; \ + ln -sf ../../run/ETAMPNEW_DATA . ; \ + ln -sf ../../run/RRTM_DATA . ; \ + ln -sf ../../run/CAM_ABS_DATA . ; \ + ln -sf ../../run/CAM_AEROPT_DATA . ; \ + ln -sf ../../run/ozone.formatted . ; \ + ln -sf ../../run/ozone_lat.formatted . ; \ + ln -sf ../../run/ozone_plev.formatted . ; \ + if [ $(RWORDSIZE) -eq 8 ] ; then \ + ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ + ln -sf ../../run/RRTM_DATA_DBL RRTM_DATA ; \ + fi ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f GENPARM.TBL ; ln -s ../../run/GENPARM.TBL . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f LANDUSE.TBL ; ln -s ../../run/LANDUSE.TBL . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f SOILPARM.TBL ; ln -s ../../run/SOILPARM.TBL . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f urban_param.tbl ; ln -s ../../run/urban_param.tbl . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f VEGPARM.TBL ; ln -s ../../run/VEGPARM.TBL . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f tr49t67 ; ln -s ../../run/tr49t67 . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f tr49t85 ; ln -s ../../run/tr49t85 . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f tr67t85 ; ln -s ../../run/tr67t85 . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) ; \ + ( cd test/em_esmf_exp ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) ; \ + fi + ( cd test/em_real ; /bin/rm -f real.exe ; ln -s ../../main/real.exe . ) + ( cd test/em_real ; /bin/rm -f ndown.exe ; ln -s ../../main/ndown.exe . ) + ( cd test/em_real ; /bin/rm -f nup.exe ; ln -s ../../main/nup.exe . ) + ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_real ; /bin/rm -f ETAMPNEW_DATA RRTM_DATA ; \ + ln -sf ../../run/ETAMPNEW_DATA . ; \ + ln -sf ../../run/RRTM_DATA . ; \ + ln -sf ../../run/CAM_ABS_DATA . ; \ + ln -sf ../../run/CAM_AEROPT_DATA . ; \ + ln -sf ../../run/ozone.formatted . ; \ + ln -sf ../../run/ozone_lat.formatted . ; \ + ln -sf ../../run/ozone_plev.formatted . ; \ + if [ $(RWORDSIZE) -eq 8 ] ; then \ + ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ + ln -sf ../../run/RRTM_DATA_DBL RRTM_DATA ; \ + fi ) + ( cd test/em_real ; /bin/rm -f GENPARM.TBL ; ln -s ../../run/GENPARM.TBL . ) + ( cd test/em_real ; /bin/rm -f LANDUSE.TBL ; ln -s ../../run/LANDUSE.TBL . ) + ( cd test/em_real ; /bin/rm -f SOILPARM.TBL ; ln -s ../../run/SOILPARM.TBL . ) + ( cd test/em_real ; /bin/rm -f urban_param.tbl ; ln -s ../../run/urban_param.tbl . ) + ( cd test/em_real ; /bin/rm -f VEGPARM.TBL ; ln -s ../../run/VEGPARM.TBL . ) + ( cd test/em_real ; /bin/rm -f tr49t67 ; ln -s ../../run/tr49t67 . ) + ( cd test/em_real ; /bin/rm -f tr49t85 ; ln -s ../../run/tr49t85 . ) + ( cd test/em_real ; /bin/rm -f tr67t85 ; ln -s ../../run/tr67t85 . ) + ( cd test/em_real ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_real ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f real.exe ; ln -s ../main/real.exe . ) + ( cd run ; /bin/rm -f ndown.exe ; ln -s ../main/ndown.exe . ) + ( cd run ; /bin/rm -f nup.exe ; ln -s ../main/nup.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + + +em_hill2d_x : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=hill2d_x em_ideal ) + ( cd test/em_hill2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_hill2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_hill2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_hill2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_hill2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_hill2d_x/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_hill2d_x/input_sounding . ) + +em_grav2d_x : wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=grav2d_x em_ideal ) + ( cd test/em_grav2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/em_grav2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) + ( cd test/em_grav2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/em_grav2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/em_grav2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_grav2d_x/namelist.input . ) + ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_grav2d_x/input_sounding . ) + +#### anthropogenic emissions converter + +emi_conv : wrf + @ echo '--------------------------------------' + ( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_emiss ) + ( cd test/em_real ; /bin/rm -f convert_emiss.exe ; ln -s ../../chem/convert_emiss.exe . ) + ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + +#### biogenic emissions converter + +bio_conv : wrf + @ echo '--------------------------------------' + ( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_bioemiss ) + ( cd test/em_real ; /bin/rm -f convert_bioemiss.exe ; ln -s ../../chem/convert_bioemiss.exe . ) + ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + +#### nmm converter + +nmm_real : nmm_wrf + @ echo '--------------------------------------' + ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=nmm IDEAL_CASE=real real_nmm ) + ( cd test/nmm_real ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) + ( cd test/nmm_real ; /bin/rm -f real_nmm.exe ; ln -s ../../main/real_nmm.exe . ) + ( cd test/nmm_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) + ( cd test/nmm_real ; /bin/rm -f ETAMPNEW_DATA RRTM_DATA ; \ + ln -sf ../../run/ETAMPNEW_DATA . ; \ + ln -sf ../../run/RRTM_DATA . ; \ + if [ $(RWORDSIZE) -eq 8 ] ; then \ + ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ + ln -sf ../../run/RRTM_DATA_DBL RRTM_DATA ; \ + fi ) + ( cd test/nmm_real ; /bin/rm -f GENPARM.TBL ; ln -s ../../run/GENPARM.TBL . ) + ( cd test/nmm_real ; /bin/rm -f LANDUSE.TBL ; ln -s ../../run/LANDUSE.TBL . ) + ( cd test/nmm_real ; /bin/rm -f SOILPARM.TBL ; ln -s ../../run/SOILPARM.TBL . ) + ( cd test/nmm_real ; /bin/rm -f VEGPARM.TBL ; ln -s ../../run/VEGPARM.TBL . ) + ( cd test/nmm_real ; /bin/rm -f tr49t67 ; ln -s ../../run/tr49t67 . ) + ( cd test/nmm_real ; /bin/rm -f tr49t85 ; ln -s ../../run/tr49t85 . ) + ( cd test/nmm_real ; /bin/rm -f tr67t85 ; ln -s ../../run/tr67t85 . ) + ( cd test/nmm_real ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) + ( cd test/nmm_real ; /bin/rm -f grib2map.txt ; ln -s ../../run/grib2map.txt . ) + ( cd run ; /bin/rm -f real_nmm.exe ; ln -s ../main/real_nmm.exe . ) + ( cd run ; if test -f namelist.input ; then \ + /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/rm -f namelist.input ; ln -s ../test/nmm_real/namelist.input . ) + + + +# semi-Lagrangian initializations + + +ext : + @ echo '--------------------------------------' + ( cd frame ; $(MAKE) externals ) + +framework : + @ echo '--------------------------------------' + ( cd frame ; $(MAKE) framework; \ + cd ../external/io_netcdf ; make NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" ESMF_MOD_DEPENDENCE="../$(ESMF_MOD_DEPENDENCE)" diffwrf; \ + cd ../io_int ; $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" ESMF_MOD_DEPENDENCE="../$(ESMF_MOD_DEPENDENCE)" diffwrf ; cd ../../frame ) + +shared : + @ echo '--------------------------------------' + ( cd share ; $(MAKE) ) + +chemics : + @ echo '--------------------------------------' + ( cd chem ; $(MAKE) ) + +physics : + @ echo '--------------------------------------' + ( cd phys ; $(MAKE) ) + +em_core : + @ echo '--------------------------------------' + ( cd dyn_em ; $(MAKE) ) + +# rule used by configure to test if this will compile with MPI 2 calls MPI_Comm_f2c and _c2f +mpi2_test : + @ cd tools ; /bin/rm -f mpi2_test ; $(CC) -c mpi2_test.c ; cd .. + +# rule used by configure to test if fseeko and fseeko64 are supported (for share/landread.c to work right) +fseek_test : + @ cd tools ; /bin/rm -f fseeko_test ; $(SCC) -DTEST_FSEEKO -o fseeko_test fseek_test.c ; cd .. + @ cd tools ; /bin/rm -f fseeko64_test ; $(SCC) -DTEST_FSEEKO64 -o fseeko64_test fseek_test.c ; cd .. + +### 3.b. sub-rule to build the expimental core + +# uncomment the two lines after exp_core for EXP +exp_core : + @ echo '--------------------------------------' + ( cd dyn_exp ; $(MAKE) ) + +# uncomment the two lines after nmm_core for NMM +nmm_core : + @ echo '--------------------------------------' + ( cd dyn_nmm ; $(MAKE) ) + +toolsdir : + @ echo '--------------------------------------' + ( cd tools ; $(MAKE) CC="$(CC_TOOLS)" ) + +# Use this target to build stand-alone tests of esmf_time_f90. +# Only touches external/esmf_time_f90/. +esmf_time_f90_only : + @ echo '--------------------------------------' + ( cd external/esmf_time_f90 ; $(MAKE) FC="$(FC) $(FCFLAGS)" CPP="$(CPP) -DTIME_F90_ONLY" tests ) + +clean : + @ echo 'Use the clean script' + +# DO NOT DELETE diff --git a/wrfv2_fire/README b/wrfv2_fire/README new file mode 100644 index 00000000..cc320007 --- /dev/null +++ b/wrfv2_fire/README @@ -0,0 +1,219 @@ +WRF Model Version 2.2 (December 2006) +http://www.mmm.ucar.edu/wrf/users/ + +------------------------ +WRF PUBLIC DOMAIN NOTICE +------------------------ + +WRF was developed at the National Center for Atmospheric Research +(NCAR) which is operated by the University Corporation for +Atmospheric Research (UCAR). NCAR and UCAR make no proprietary +claims, either statutory or otherwise, to this version and +release of WRF and consider WRF to be in the public domain for +use by any person or entity for any purpose without any fee or +charge. UCAR requests that any WRF user include this notice on +any partial or full copies of WRF. WRF is provided on an "AS +IS" basis and any warranties, either express or implied, +including but not limited to implied warranties of +non-infringement, originality, merchantability and fitness for a +particular purpose, are disclaimed. In no event shall +UCAR be liable for any damages, whatsoever, whether direct, +indirect, consequential or special, that arise out of or in +connection with the access, use or performance of WRF, including +infringement actions. + + +====================================== +This is the main directory for the WRF Version 2 source code release. +====================================== + +V2.2 Release Notes: +------------------ + +- For directions on compiling WRF, see below or Users Web page. +- For more information on WRF V2.2 release, visit WRF Users home page + http://www.mmm.ucar.edu/wrf/users/ +- WRF V2.2 works with both WPS (new WRF Preprocessing System) and SI. + Please see User' Guide for WPS. +- WRF V2.2 executable works with wrfinput/wrfbdy produced by previous version, + but pre-V2.2 WRF will NOT work with V2.2 wrfinput/wrfbdy files. +- WRF V2.2's namelist has new additions. Edit with caution. + +For questions, send mail to wrfhelp@ucar.edu + +====================================== + +V2.1 Release Notes: +------------------ + +- For directions on compiling WRF, see below or Users Web page. +- For more information on WRF V2.1 release, visit WRF Users home page + http://www.mmm.ucar.edu/wrf/users/ +- Use WRFSI 2.0.3 or 2.1 (http://wrfsi.noaa.gov) for real-data preparation. +- Must rerun real.exe to generate new wrfbdy_d01/wrfinput_d01 for wrf.exe. +- WRF V2.1's namelist has some changes from 2.0.3.1. Edit with caution. +- Need to have gribmap.txt in your run directory. + +====================================== + +V2 update history: + +- V2.0.1: May 21, 2004 +- V2.0.2: June 3, 2004 +- V2.0.3: Nov 12, 2004 + V2.0.3.1: Dec 3, 2004 +- V2.1: August 4, 2005 +- V2.1.1: Nov 8, 2005 +- V2.1.2: Jan 27, 2006 +- V2.2: Dec 21, 2006 + +====================================== + +How to compile and run? +----------------------- + +- In WRFV2 directory, type 'configure' - this will create a configure.wrf + file that has appropriate compile options for the supported computers. + + Note: WRF requires netCDF library. If your netCDF library is installed in + some odd directory, set environment variable NETCDF before you type + 'configure'. For example, + + setenv NETCDF /usr/local/lib32/r4i4 + +- Type 'compile case_name' where you can find the case_names by simply typing + compile. The following are available: + + compile em_b_wave + compile em_hill2d_x + compile em_grav2d_x + compile em_quarter_ss + compile em_real + compile em_squall2d_x + compile em_squall2d_y + +- If sucessfully, this will create either real.exe or ideal.exe and wrf.exe + in directory main/, and the appropriate executables will be linked into + the test directoires under test/case_name, or run/. + +- cd to the appropriate test or run direcotry to run ideal/real/wrf. + +- If it is one of the idealized cases (b_wave, hill2d_x, grav2d_x, quarter_ss, + squall2d_x or squall2d_y), cd the the appropriate directory, type + + ideal.exe + + to produce wrfinput_d01 file for wrf model. Then type + + wrf.exe + + to run. + +- If it is real-data case (real), place files from SI (wrf_real_input_em.*) + in the appropriate directory, type + + real.exe + + to produce wrfbdy_d01 and wrfinput_d01. Then type + + wrf.exe + + to run. + +- If you use mpich, type + + mpirun -np number-of-processors wrf.exe + +- For information on how to make nested runs, visit + http://www.mmm.ucar.edu/wrf/users/ + + +====================================== + +What is in WRF V2? + +- Advanced Research WRF (ARW) solver: Eulerian mass, hydrostatic and non-hydrostatic + * Arakawa C-grid staggering + * Runge-Kutta 2nd and 3rd order timestep options + * scalar-conserving flux form for prognostic variables + * 2nd to 6th order advection options (horizontal and vertical) + * time-split small step for acoustic modes + * small step horizontally explicit, vertically implicit + * divergence damping option and vertical time off-centering + * external-mode filtering option for mass model + * hydrostatic option via namelist option + * positive-definite advection for moisture, scalar, tke and chemical tracers (since 2.2) + +- Two-way nesting: + * multiple domains and multiple nest levels + * supports integer nest grid ratio + * feedback option for both odd and even nest grid ratios (since 2.0.3) + * smoothing options + +- One-way nesting (since 2.0.2) + +- Moving nest (since 2.1) + * Specified move. + * Automatic move using a mid-level vortex-following algorithm. + +- Physics options: + * microphysics (Kessler/ WRF Single Moment 3, 5 and 6 class / Lin et al./ + Eta Ferrier / Thompson [a new version in 2.2]) + * cumulus parameterization (Kain-Fritsch with shallow convection / + Betts-Miller-Janjic / Grell-Devenyi ensemble) + * planetary boundary layer (Yosei University (S. Korea) / Mellor-Yamada-Janjic) + * surface layer (similarity theory MM5 / Eta) + * slab soil model (5-layer thermal diffusion / Noah land-surface model (4-level) / + RUC LSM (6-level) ) + * Urban canopy model (works with Noah LSM) (since 2.2) + * longwave radiation (RRTM, CAM) + * shortwave radiation (simple MM5 scheme / Goddard / CAM) + * sub-grid turbulence (constant K diffusion/ 2-D Smagorinsky/ predicted TKE / + 2-D, 6th order diffusion) + * land-use categories determine surface properties + * three-dimensional analysis nudging (since 2.2) + * observation nudging (since 2.2) + +- Software + + * Hierarchical software architecture that insulates scientific code + (Model Layer) from computer architecture (Driver Layer) + * Multi-level parallelism supporting shared-memory (OpenMP), distributed-memory (MPI), + and hybrid share/distributed modes of execution + * Active data registry: defines and manages model state fields, I/O, + nesting, configuration, and numerous other aspects of WRF through a single file, + called the Registry + * Two-way nesting: + Easy to extend: forcing and feedback of new fields specified by + editing a single table in the Registry + Efficient: 5-8% overhead on 64 processes of IBM + Moving nests. + * Enhanced I/O options: + NetCDF and Parallel HDF5 formats + Five auxiliary history output streams separately controllable through the namelist + Output file names and time-stamps specifiable through namelist + Special output stream for 3DVAR + * Efficient execution on a range of computing platforms: + IBM SP systems, (e.g. NCAR "bluesky" Power4-based system) + HP/Compaq Alpha/OSF workstation, SMP, and MPP systems (e.g. Pittsburgh + Supercomputing Center TCS) + SGI Origin and Altix + Linux/Intel + IA64 MPP (HP Superdome, SGI Altix, NCSA Teragrid systems) + IA64 SMP + Pentium 3/4 SMP and SMP clusters (NOAA/FSL iJet system) + PGI and Intel compilers supported + Alpha Linux (NOAA/FSL Jet system) + Sun Solaris (single threaded and SMP) + Cray X1, X1e (vector), X1D (Opteron) + Mac G5, xlf compiler (no DM-parallel yet) + HP-UX + Other ports under development: + NEC SX/6 + Fujitsu VPP 5000 + * RSL_LITE: optional new communication layer, scalable to very + large domains, support nesting. + * ESMF Time Management, including exact arithmetic for fractional + time steps (no drift). + * ESMF integration - WRF can be run as an ESMF component. + * Improved documentation, both on-line (web based browsing tools) and in-line diff --git a/wrfv2_fire/README.NMM b/wrfv2_fire/README.NMM new file mode 100644 index 00000000..40cb0755 --- /dev/null +++ b/wrfv2_fire/README.NMM @@ -0,0 +1,202 @@ + +WRF-NMM Model Version 2 (June 2005) + +---------------------------- +WRF-NMM PUBLIC DOMAIN NOTICE +---------------------------- + +WRF-NMM was developed at National Centers for +Environmental Prediction (NCEP), which is part of +NOAA's National Weather Service. As a government +entity, NCEP makes no proprietary claims, either +statutory or otherwise, to this version and release of +WRF-NMM and consider WRF-NMM to be in the public +domain for use by any person or entity for any purpose +without any fee or charge. NCEP requests that any WRF +user include this notice on any partial or full copies +of WRF-NMM. WRF-NMM is provided on an "AS IS" basis +and any warranties, either express or implied, +including but not limited to implied warranties of +non-infringement, originality, merchantability and +fitness for a particular purpose, are disclaimed. In +no event shall NOAA, NWS or NCEP be liable for any +damages, whatsoever, whether direct, indirect, +consequential or special, that arise out of or in +connection with the access, use or performance of +WRF-NMM, including infringement actions. + +================================================ + +V2 Release Notes: +----------------- + +This is the main directory for the WRF Version 2 source code release. + +- For directions on compiling WRF for NMM, see below or the WRF-NMM Users' Web page. +- If you have used WRF software before, you must re-run WRF-SI/NMM + (set namelist variable OUTPUT_FILE_TYPE = 'WRF') preferably using + the recent WRF-NMM SI release). +- Read the README.namelist file in the run/ directory (or on the WRF-NMM Users' page), + and make changes carefully. + +For questions, send mail to wrfhelp@ucar.edu + +====================================== + +The ./compile script at the top level has been updated to all for easy +selection of NMM and ARW cores of WRF at compile time. + + - Specify your WRF-NMM option by setting the appropriate environment variable: + + setenv WRF_NMM_CORE 1 + + - The Registry files for NMM and ARW are not integrated + yet. There are separate versions: + + Registry/Registry.NMM <-- for NMM + Registry/Registry.EM <-- for ARW (formerly known as Eulerian Mass) + + +How to configure, compile and run? +---------------------------------- + +- In WRFV2 directory, type: + + configure + + this will create a configure.wrf file that has appropriate compile + options for the supported computers. Edit your configure.wrf file as needed. + + Note: WRF requires netCDF library. If your netCDF library is installed in + some odd directory, set environment variable NETCDF before you type + 'configure'. For example: + + setenv NETCDF /usr/local/lib32/r4i4 + +- Type: + compile nmm_real + +- If sucessful, this command will create nmm_real.exe and wrf.exe + in directory main/, and the appropriate executables will be linked into + the test directories under test/nmm_real, or run/. + +- cd to the appropriate test or run direcotry to run "nmm_real.exe" and "wrf.exe". + +- Place files from WRF-NMM SI (wrf_real_input_nm.*) + in the appropriate directory, type + + real_nmm.exe + + to produce wrfbdy_d01 and wrfinput_d01. Then type + + wrf.exe + + to run. + +- If you use mpich, type + + mpirun -np number-of-processors wrf.exe + +============================================================================= + +What is in WRF-NMM V2.1? + +* Dynamics: + + - The WRF-NMM model is a fully compressible, non-hydrostatic model with a + hydrostatic option. + + - The terrain following hybrid pressure sigma vertical coordinate is used. + + - The grid staggering is the Arakawa E-grid. + + - The same time step is used for all terms. + + - Time stepping: + - Horizontally propagating fast-waves: Forward-backward scheme + - Veryically propagating sound waves: Implicit scheme + + - Advection (time): + T,U,V: + - Horizontal: The Adams-Bashforth scheme + - Vertical: The Crank-Nicholson scheme + TKE, water species: Forward, flux-corrected (called every two timesteps). + + - Advection (space): + T,U,V: + - Horizontal: Energy and enstrophy conserving, + quadratic conservative,second order + + - Vertical: Quadratic conservative,second order TKE, + + - Water species: Upstream, flux-corrected, positive definite, conservative + + - Horizontal diffusion: Forward, second order "Smagorinsky-type" + + - Vertical Diffusion: + See "Free atmosphere turbulence above surface layer" section + in "Physics" section given in below. + +* Physics: + + - Explicit Microphysics: Ferrier (Used operationally at NCEP.) + + - Cumulus parameterizations: Betts-Miller-Janjic, (Used operationally at NCEP.) + Kain-Fritsch with shallow convection + + - Free atmosphere turbulence above surface layer: Mellor-Yamada-Janjic (Used operationally at NCEP.) + + - Planetary boundary layer: Mellor-Yamada-Janjic (Used operationally at NCEP.) + + - Surface layer: Similarity theory scheme with viscous sublayers + over both solid surfaces and water points (Janjic). + - Radiation: + - Longwave radiation: GFDL Scheme (Fels-Schwarzkopf) (Used operationally at NCEP.) + - Shortwave radiation: GFDL-scheme (Lacis-Hansen) (Used operationally at NCEP.) + + - Gravity wave drag: none + + +* WRF Software: + + - Hierarchical software architecture that insulates scientific code + (Model Layer) from computer architecture (Driver Layer) + - Multi-level parallelism supporting shared-memory (OpenMP), distributed-memory (MPI), + and hybrid share/distributed modes of execution + - Active data registry: defines and manages model state fields, I/O, + configuration, and numerous other aspects of WRF through a single file, + called the Registry + - Enhanced I/O options: + NetCDF and Parallel HDF5 formats + Five auxiliary history output streams separately controllable through the namelist + Output file names and time-stamps specifiable through namelist + + - Testing: Various regression tests are performed on HP/Compaq systems at + NCAR/MMM whenever a change is introduced into WRF cores. + + - Efficient execution on a range of computing platforms: + IBM SP systems, (e.g. NCAR "bluesky" and NCEP's "blue", Power4-based system) + HP/Compaq Alpha/OSF workstation, SMP, and MPP systems (e.g. Pittsburgh + Supercomputing Center TCS) + SGI Origin and Altix + Linux/Intel + IA64 MPP (HP Superdome, SGI Altix, NCSA Teragrid systems) + IA64 SMP + Pentium 3/4 SMP and SMP clusters (NOAA/FSL iJet system) + PGI and Intel compilers supported + Alpha Linux (NOAA/FSL Jet system) + Sun Solaris (single threaded and SMP) + Cray X1 + HP-UX + Other ports under development: + NEC SX/6 + Fujitsu VPP 5000 + - RSL_LITE: optional new communication layer, scalable to very + large domains (limited to single domain in 2.0) + - ESMF Time Management, including exact arithmetic for fractional + time steps (no drift); model start, stop, run length and I/O frequencies are + now specified as times and time intervals in 2.0 + - Improved documentation, both on-line (web based browsing tools) and in-line + +-------------------------------------------------------------------------- + diff --git a/wrfv2_fire/README_test_cases b/wrfv2_fire/README_test_cases new file mode 100644 index 00000000..7fa636b1 --- /dev/null +++ b/wrfv2_fire/README_test_cases @@ -0,0 +1,84 @@ +WRFV2 (Weather Research and Forecast) model. + +Contents: + +A) Directions for running a test case. +B) List of available test cases + +--------------------------------------- + +(A) Directions for running a test case + +A suite of tests for the WRF model ARW (Advanced Research WRF) core +can be found in the directory "test". Each subdirectory in /test +contains the necessary data (except for the real data case) and +input files to run the test specific to that directory. +To run specific test, builld the WRF model +and the necessary initialization routine by typing + +-> compile "test_name" + +in the top directory (the directory containing this README file). +For example, to build the executables for the 2D (x,z) squall line +example for Eulerian mass coordinate model, you would type the command +"compile em_squall2d_x". + +after a successful build, go the the specific test directory: + +-> cd test/"test_name" + +run the initialization code + +-> ideal.exe + +and then run the simulation + +-> wrf.exe + +--------------------------------------- + +(B) Available Test Cases + +The available test cases are + +1) squall2d_x (test/em_squall2d_x) + + 2D squall line (x,z) using Kessler microphysics + and a fixed 300 m^2/s viscosity. periodicity + condition used in y so that 3D model produces + 2D simulation. v velocity should be zero and there + should be no variation in y in the results. + +2) squall2d_y (test/em_squall2d_y) + + Same as squall2d_x, except with (x) rotated to (y). + u velocity should be zero and there + should be no variation in x in the results. + +3) 3D quarter-circle shear supercell simulation + (test/em_quarter_ss). + + Left and right moving supercells are produced. + See the README.quarter_ss file in the test directory + for more information. + +4) 2D flow over a bell-shaped hill (x,z) (test/em_hill2d_x) + + 10 km half-width, 2 km grid-length, 100 m high hill, + 10 m/s flow, N=0.01/s, 30 km high domain, 80 levels, + open radiative boundaries, absorbing upper boundary. + Case is in linear hydrostatic regime, so vertical tilted + waves with ~6km vertical wavelength. + +5) 3D baroclinic waves (test/em_b_wave) + + Baroclinically unstable jet u(y,z) on an + f-plane. Symmetric north and south, periodic east and west + boundaries. 100 km grid size 16 km top with 4 km damping layer. + 41x81 points in (x,y), 64 layers. + +6) 2D gravity current (test/em_grav2d_x) + + Test case is described in Straka et al, + INT J NUMER METH FL 17 (1): 1-22 JUL 15 1993. + See the README.grav2d_x file in the test directory. diff --git a/wrfv2_fire/Registry/Registry.CONVERT b/wrfv2_fire/Registry/Registry.CONVERT new file mode 100644 index 00000000..c1e11957 --- /dev/null +++ b/wrfv2_fire/Registry/Registry.CONVERT @@ -0,0 +1,556 @@ +# Registry file, EM_CONVERT +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +# +dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec e 3 namelist=ensdim z ensemble dimension +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year + + +################################################################################ +################################################################################ +################################################################################ + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# table entries are of the form +#
+# + +# +# Variables from WPS +# +state real u_gc igj dyn_em 1 X i1 "UU" "x-wind component" "m s-1" +state real v_gc igj dyn_em 1 Y i1 "VV" "y-wind component" "m s-1" +state real t_gc igj dyn_em 1 - i1 "TT" "temperature" "K" +state real rh_gc igj dyn_em 1 - i1 "RH" "relative humidity" "%" +state real ght_gc igj dyn_em 1 - i1 "GHT" "geopotential height" "m" +state real p_gc igj dyn_em 1 - i1 "P" "pressure" "Pa" +state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" +state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" +state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" +state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" +state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real pslv_gc ij dyn_em 1 - i1 "PMSL" "sea level pressure" "Pa" +state real greenfrac imj dyn_em 1 - i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m imj dyn_em 1 - i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real pd_gc igj dyn_em 1 - - "PD" "dry pressure" "Pa" +state real qv_gc igj dyn_em 1 - i1 "QV" "mixing ratio" "kg kg-1" +state real intq_gc ij dyn_em 1 - - "INTQ" "integrated mixing ratio" "Pa" +state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" +#state real qr_gc igj dyn_em 1 - i1 "QR" "rain water mixing ratio" "kg kg-1" +#state real qc_gc igj dyn_em 1 - i1 "QC" "cloud water mixing ratio" "kg kg-1" +#state real qs_gc igj dyn_em 1 - i1 "QS" "snow mixing ratio" "kg kg-1" +#state real qi_gc igj dyn_em 1 - i1 "QI" "cloud ice mixing ratio" "kg kg-1" +#state real qg_gc igj dyn_em 1 - i1 "QG" "graupel mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# +# Variables for Eulerian mass coordinate dynamics +# + +# Velocities +# +# U Vel +state real u ikj dyn_em 1 X ih "U" "x-wind component" "m s-1" +# +# V Vel +state real v ikj dyn_em 1 Y ih "V" "y-wind component" "m s-1" +# +# Vertical Vel +state real w ikj dyn_em 1 Z ih "W" "z-wind component" "m s-1" +# Geopotential +state real ph ikj dyn_em 1 Z ih "PH" "perturbation geopotential" "m2 s-2" +state real phb ikj dyn_em 1 Z ih "PHB" "base-state geopotential" "m2 s-2" +# Potential Temperature +state real t ikj dyn_em 1 - ih "T" "perturbation potential temperature (theta-t0)" "K" +# Mass +state real mu ij dyn_em 1 - ih "MU" "perturbation dry air mass in column" "Pa" +state real mub ij dyn_em 1 - ih "MUB" "base state dry air mass in column" "Pa" +# Pressure and Density +state real p ikj dyn_em 1 - ih "p" "perturbation pressure" "Pa" +state real pb ikj dyn_em 1 - ih "pb" "BASE STATE PRESSURE " "Pa" +# 2m and 10m output diagnostics +state real Q2 ij misc 1 - ih "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - ih "T2" "TEMP at 2 M" "K" +state real TH2 ij misc 1 - ih "TH2" "POT TEMP at 2 M" "K" +state real PSFC ij misc 1 - ih "PSFC" "SFC PRESSURE" "Pa" +state real U10 ij misc 1 - ih "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - ih "V10" "V at 10 M" "m s-1" + +# Scalar (4D) arrays +# Moist Scalars +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjftb moist 1 - - - +state real qv ikjftb moist 1 - ih "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjftb moist 1 - ih "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjftb moist 1 - ih "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjftb moist 1 - ih "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjftb moist 1 - ih "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjftb moist 1 - ih "QGRAUP" "Graupel mixing ratio" "kg kg-1" + +state real - ikjftb chem 1 - - - + +state real - ikjftb scalar 1 - - - +state real qni ikjftb scalar 1 - ih "QNICE" "Ice Number concentration" "# kg(-1)" + + +state real ht ij misc 1 - ih "HGT" "Terrain Height" "m" +state real TSK ij misc 1 - ih "TSK" "SURFACE SKIN TEMPERATURE" "K" + +# from the metadata? Otherwise it's a field? +state real p_top - misc - - ih "p_top" "PRESSURE TOP OF THE MODEL" "Pa" + +state real RAINC ij misc 1 - ih "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" +state real RAINNC ij misc 1 - ih "RAINNC" "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" "mm" +state real SNOWC ij misc 1 - ih "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" +rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" +rconfig character rsmas_data_path namelist,time_control 1 "." - "rsmas_data_path" "" "" + +include registry.io_boilerplate +include registry.io_boilerplate_EM + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" + +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer num_metgrid_levels namelist,domains 1 27 irh "num_metgrid_levels" "" "" +rconfig integer interp_type namelist,domains 1 1 irh "interp_type" "" "" +rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. irh "lowest_lev_from_sfc" "" "" +rconfig integer lagrange_order namelist,domains 1 1 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer force_sfc_in_vinterp namelist,domains 1 0 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" +rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 rh "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 rh "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig integer blend_width namelist,domains 1 5 h "blend_width" "width of cg fg terrain blended zone" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer max_vortex_speed namelist,domains max_domains 40 - "" "" "meters per second" +rconfig integer corral_dist namelist,domains max_domains 8 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real max_dz namelist,domains 1 1000. + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer co2tf namelist,physics 1 0 - "GFDL radiation co2 flag" "" "" + + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 2 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0.01 h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 0 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 5 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 1000. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical mix_full_fields namelist,dynamics max_domains .false. irh "mix_full_field" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +#------------------------------------------------------------------------------------------------------------------------------------------- +# a few entries that need to be in the registry for stuff in share to compile, but that you probably do not want converted + + +# State for derived time quantities. +state real xtime - - - - - "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +# Mask for moving nest interpolations +state integer imask_nostag ij misc 1 - +state integer imask_xstag ij misc 1 X +state integer imask_ystag ij misc 1 Y +state integer imask_xystag ij misc 1 XY + +state real sm000010 ij misc 1 - i1 "SM000010" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010040 ij misc 1 - i1 "SM010040 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm040100 ij misc 1 - i1 "SM040100 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100200 ij misc 1 - i1 "SM100200 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010200 ij misc 1 - i1 "SM010200" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm000 ij misc 1 - i1 "SOILM000" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm005 ij misc 1 - i1 "SOILM005" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm020 ij misc 1 - i1 "SOILM020" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm040 ij misc 1 - i1 "SOILM040" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm160 ij misc 1 - i1 "SOILM160" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm300 ij misc 1 - i1 "SOILM300" "LAYER SOIL MOISTURE" "m3 m-3" +state real sw000010 ij misc 1 - i1 "SW000010" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010040 ij misc 1 - i1 "SW010040" "LAYER SOIL LIQUID" "m3 m-3" +state real sw040100 ij misc 1 - i1 "SW040100" "LAYER SOIL LIQUID" "m3 m-3" +state real sw100200 ij misc 1 - i1 "SW100200" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010200 ij misc 1 - i1 "SW010200" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw000 ij misc 1 - i1 "SOILW000" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw005 ij misc 1 - i1 "SOILW005" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw020 ij misc 1 - i1 "SOILW020" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw040 ij misc 1 - i1 "SOILW040" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw160 ij misc 1 - i1 "SOILW160" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw300 ij misc 1 - i1 "SOILW300" "LAYER SOIL LIQUID" "m3 m-3" +state real st000010 ij misc 1 - i1 "ST000010" "LAYER SOIL TEMPERATURE" "K" +state real st010040 ij misc 1 - i1 "ST010040" "LAYER SOIL TEMPERATURE" "K" +state real st040100 ij misc 1 - i1 "ST040100" "LAYER SOIL TEMPERATURE" "K" +state real st100200 ij misc 1 - i1 "ST100200" "LAYER SOIL TEMPERATURE" "K" +state real st010200 ij misc 1 - i1 "ST010200" "LAYER SOIL TEMPERATURE" "K" +state real soilt000 ij misc 1 - i1 "SOILT000" "LAYER SOIL TEMPERATURE" "K" +state real soilt005 ij misc 1 - i1 "SOILT005" "LAYER SOIL TEMPERATURE" "K" +state real soilt020 ij misc 1 - i1 "SOILT020" "LAYER SOIL TEMPERATURE" "K" +state real soilt040 ij misc 1 - i1 "SOILT040" "LAYER SOIL TEMPERATURE" "K" +state real soilt160 ij misc 1 - i1 "SOILT160" "LAYER SOIL TEMPERATURE" "K" +state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" +state real landmask ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" +state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real shdmax ij misc 1 - - "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - - "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real snoalb ij misc 1 - - "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" +state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" +state real landusef iuj misc 1 Z i12 "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i12 "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i1 "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" + +state real lat_ll_t - dyn_em - - - "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - - "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - - "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - - "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - - "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - - "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - - "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - - "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - - "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - - "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - - "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - - "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - - "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - - "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - - "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - - "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - - "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - - "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - - "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - - "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - - "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - - "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - - "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - - "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - - "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - - "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - - "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - - "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - - "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - - "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - - "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - - "lon_lr_d" "longitude lower right, massless point" "degrees" + + + + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# Package Declarations +# + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_em dyn_opt==2 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package rrtmscheme ra_lw_physics==1 - - +package gfdllwscheme ra_lw_physics==99 - moist:qv,qc,qr,qi + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM new file mode 100644 index 00000000..7fe709b1 --- /dev/null +++ b/wrfv2_fire/Registry/Registry.EM @@ -0,0 +1,1449 @@ +# Registry file, EM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +# Available characters for dimspec: 0123456789@%+=|?.!&[{}] + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec e 3 namelist=ensdim z ensemble dimension +dimspec z - namelist=max_obs c max_obs +dimspec h - namelist=nobs_err_flds c nobs_err_flds +dimspec r - namelist=nobs_ndg_vars c nobs_ndg_vars +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec q 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev +dimspec v - constant=1 z one + + +################################################################################ +################################################################################ +################################################################################ + +#state real floob ikjb dyn_em 1 - +#state real floob_x ikjx dyn_em 1 - +#state real floob_y ikjy dyn_em 1 - +#xpose FLOOB dyn_em floob,floob_x,floob_y + +#state real xxx ijk misc 2 - h6ud +#halo HALO_FLOOB dyn_em 4:xxx_2 + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# table entries are of the form +#
+# + +# It is required that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# this next 1 is for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" + +# +# Variables from WPS +# +state real u_gc igj dyn_em 1 XZ i1 "UU" "x-wind component" "m s-1" +state real v_gc igj dyn_em 1 YZ i1 "VV" "y-wind component" "m s-1" +state real t_gc igj dyn_em 1 Z i1 "TT" "temperature" "K" +state real rh_gc igj dyn_em 1 Z i1 "RH" "relative humidity" "%" +state real ght_gc igj dyn_em 1 Z i1 "GHT" "geopotential height" "m" +state real p_gc igj dyn_em 1 Z i1 "PRES" "pressure" "Pa" +state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" +state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" +state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" +state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" +state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real pslv_gc ij dyn_em 1 - i1 "PMSL" "sea level pressure" "Pa" +state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" +state real psfc_gc ij dyn_em 1 - - "PSFC_GC" "surface pressure" "Pa" +state real intq_gc ij dyn_em 1 - - "INTQ" "integrated mixing ratio" "Pa" +state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" +state real qv_gc igj dyn_em 1 Z i1 "QV" "mixing ratio" "kg kg-1" +#state real qr_gc igj dyn_em 1 Z i1 "QR" "rain water mixing ratio" "kg kg-1" +#state real qc_gc igj dyn_em 1 Z i1 "QC" "cloud water mixing ratio" "kg kg-1" +#state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" +#state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" +#state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# +# Variables for Eulerian mass coordinate dynamics + +# Velocities +# +# U Vel +state real u ikjb dyn_em 2 X \ + i01rhusdf=(bdy_interp:dt) "U" "x-wind component" "m s-1" +state real ru ikj dyn_em 1 X - "MU_U" "mu-coupled u" "Pa m s-1" +state real ru_m ikj dyn_em 1 X - "ru_m" "" "" +state real ru_tend ikj dyn_em 1 X - "ru_tend" "" "" +i1 real ru_tendf ikj dyn_em 1 X +state real u_save ikj dyn_em 1 X - "u_save" +# +# V Vel +state real v ikjb dyn_em 2 Y \ + i01rhusdf=(bdy_interp:dt) "V" "y-wind component" "m s-1" +state real rv ikj dyn_em 1 Y - "MU_V" "mu-coupled v" "Pa m s-1" +state real rv_m ikj dyn_em 1 Y - "rv_m" +state real rv_tend ikj dyn_em 1 Y - "rv_tend" +i1 real rv_tendf ikj dyn_em 1 Y +state real v_save ikj dyn_em 1 Y - "v_save" +# +# Vertical Vel +state real w ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "w" "z-wind component" "m s-1" +state real ww ikj dyn_em 1 Z r "ww" "mu-coupled eta-dot" "Pa s-1" +state real rw ikj dyn_em 1 Z - "rw" "mu-coupled w" "Pa m s-1" +i1 real ww1 ikj dyn_em 1 Z +state real ww_m ikj dyn_em 1 Z r "ww_m" "time-avg mu-coupled eta-dot" "Pa s-1" +i1 real wwp ikj dyn_em 1 Z +i1 real rw_tend ikj dyn_em 1 Z +i1 real rw_tendf ikj dyn_em 1 Z +i1 real w_save ikj dyn_em 1 Z + +# Geopotential +state real ph ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "ph" "perturbation geopotential" "m2 s-2" +state real phb ikj dyn_em 1 Z irhdus "phb" "base-state geopotential" "m2 s-2" +state real phb_fine ikj dyn_em 1 Z - "phb_fine" "for nesting, temp holding interpolated coarse grid phb" "m2 s-2" +state real ph0 ikj dyn_em 1 Z r "ph0" "initial geopotential" "m2 s-2" +state real php ikj dyn_em 1 Z r "php" "geopotential" "m2 s-2" +i1 real ph_tend ikj dyn_em 1 Z +i1 real ph_tendf ikj dyn_em 1 Z +i1 real ph_save ikj dyn_em 1 Z + +# Potential Temperature +state real t ikjb dyn_em 2 - \ + i01rhusdf=(bdy_interp:dt) "t" "perturbation potential temperature (theta-t0)" "K" + +state real t_init ikj dyn_em 1 - ir "t_init" "initial potential temperature" "K" +i1 real t_tend ikj dyn_em 1 - +i1 real t_tendf ikj dyn_em 1 - +state real tp ikj dyn_em 2 - +i1 real t_2save ikj dyn_em 1 - +state real t_save ikj dyn_em 1 - "t_save" +# + + +# Mass +state real mu ijb dyn_em 2 - \ + irhusdf=(bdy_interp:dt) "mu" "perturbation dry air mass in column" "Pa" +state real mub ij dyn_em 1 - irhdus "mub" "base state dry air mass in column" "Pa" +state real mub_fine ij dyn_em 1 - - "mub_fine" "nest temp, holds interpolated coarse grid mub" "Pa" +state real mu0 ij dyn_em 1 - i01rdu "mu0" "initial dry mass in column" "Pa" +state real mudf ij dyn_em 1 - - "mudf" "" "" +state real muu ij dyn_em 1 - "muu" +i1 real muus ij dyn_em 1 - +state real muv ij dyn_em 1 - "muv" +i1 real muvs ij dyn_em 1 - +state real mut ij dyn_em 1 - "mut" +state real muts ij dyn_em 1 - "muts" +i1 real muave ij dyn_em 1 - +i1 real mu_save ij dyn_em 1 - +i1 real mu_tend ij dyn_em 1 - +i1 real mu_tendf ij dyn_em 1 - + +#diagnostic for looking at nest position in output. A mungy version of terrain height. +state real nest_pos ij misc 1 - rhu=(mark_domain) "NEST_POS" +state real nest_mask ij misc 1 - ru=(mark_domain) "NEST_MASK" "LOCATION OF NEST IF ANY" +state real ht_coarse ij misc 1 - r - "STORAGE FOR LOW-RES TERRAIN" + + +# TKE +state real tke ikj dyn_em 2 - r "tke" "TURBULENCE KINETIC ENERGY" "m2 s-2" +i1 real tke_tend ikj dyn_em 1 - + +# Pressure and Density +state real p ikj dyn_em 1 - rh "p" "perturbation pressure" "Pa" +state real al ikj dyn_em 1 - r "al" "inverse perturbation density" "m3 kg-1" +state real alt ikj dyn_em 1 - r "alt" "inverse density" "m3 kg-1" +state real alb ikj dyn_em 1 - rdus "alb" "inverse base density" "m3 kg-1" +state real zx ikj dyn_em 1 X - " " " " " " +state real zy ikj dyn_em 1 Y - " " " " " " +state real rdz ikj dyn_em 1 Z - " " " " " " +state real rdzw ikj dyn_em 1 Z - " " " " " " +state real pb ikj dyn_em 1 - rhdus "pb" "BASE STATE PRESSURE " "Pa" + +# +# Other dyn +# +i1 real advect_tend ikj dyn_em 1 - +i1 real alpha ikj dyn_em 1 - +i1 real a ikj dyn_em 1 - +i1 real gamma ikj dyn_em 1 - +i1 real c2a ikj dyn_em 1 - - +i1 real rho ikj dyn_em 1 - - +i1 real phm ikj dyn_em 1 - - +i1 real cqu ikj dyn_em 1 - - +i1 real cqv ikj dyn_em 1 - - +i1 real cqw ikj dyn_em 1 - - +i1 real pm1 ikj dyn_em 1 - - +state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" +state real potevp ij dyn_em 1 - h "potevp" "whatever" +state real snopcx ij dyn_em 1 - h "snopcx" "whatever" +state real soiltb ij dyn_em 1 - h "soiltb" "whatever" +state real fnm k dyn_em 1 - irh "fnm" "upper weight for vertical stretching" "" +state real fnp k dyn_em 1 - irh "fnp" "lower weight for vertical stretching" "" +state real rdnw k dyn_em 1 - irh "rdnw" "inverse d(eta) values between full (w) levels" "" +state real rdn k dyn_em 1 - irh "rdn" "inverse d(eta) values between half (mass) levels" "" +state real dnw k dyn_em 1 - irh "dnw" "d(eta) values between full (w) levels" "" +state real dn k dyn_em 1 - irh "dn " "d(eta) values between half (mass) levels" "" +state real znu k dyn_em 1 - irh "znu" "eta values on half (mass) levels" "" +state real znw k dyn_em 1 Z i01rh "znw" "eta values on full (w) levels" "" +state real t_base k dyn_em 1 - ir "t_base" "BASE STATET T IN IDEALIZED CASES" "K" +state real z ikj dyn_em 1 - - " " " " " " +i1 real mu_3d ikj dyn_em 1 - +i1 real z_at_w ikj dyn_em 1 Z +state real cfn - misc - - irh "cfn" "extrapolation constant" "" +state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" +state integer step_number - misc - - ir "step_number" "" + +# 2m and 10m output diagnostics +state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" +state real TH2 ij misc 1 - irhd "TH2" "POT TEMP at 2 M" "K" +state real PSFC ij misc 1 - i01rh "PSFC" "SFC PRESSURE" "Pa" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real U10 ij misc 1 - irh01d "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - irh01d "V10" "V at 10 M" "m s-1" + +# these next 4 are for observational nudging +state real uratx ij misc 1 - ir "URATX" "Ratio of U over U10 on mass points " "dimensionless" +state real vratx ij misc 1 - ir "VRATX" "Ratio of V over V10 on mass points " "dimensionless" +state real tratx ij misc 1 - ir "TRATX" "Ratio of T over TH2 on mass points " "dimensionless" +state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" + +# Other +state real rdx - misc - - irh "rdx" "INVERSE X GRID LENGTH" "" +state real rdy - misc - - irh "rdy" "INVERSE Y GRID LENGTH" "" +state real dts - misc - - ir "dts" "SMALL TIMESTEP" "" +state real dtseps - misc - - ir "dtseps" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real resm - misc - - irh "resm" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real zetatop - misc - - irh "zetatop" "ZETA AT MODEL TOP" "" +state real cf1 - misc - - irh "cf1" "2nd order extrapolation constant" "" +state real cf2 - misc - - irh "cf2" "2nd order extrapolation constant" "" +state real cf3 - misc - - irh "cf3" "2nd order extrapolation constant" "" +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - rh "itimestep" "" "" +state real xtime - - - - rh "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +# Mask for moving nest interpolations +state integer imask_nostag ij misc 1 - +state integer imask_xstag ij misc 1 X +state integer imask_ystag ij misc 1 Y +state integer imask_xystag ij misc 1 XY +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# Scalar (4D) arrays + +# Moist Scalars +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjftb moist 1 - - - +state real qv ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" + +# Chem Scalars +state real - ikjftb chem 1 - - - + +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qndrop ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" +state real qni ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "CWM" "Total condensate mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# Arrays for Specified LBCs (lbc arrays REMOVED; Boundary arrays are now specified with the state array; see above, 20050413 JM ) + +state real fcx w misc - - ir "fcx" "RELAXATION TERM FOR BOUNDARY ZONE" "" +state real gcx w misc - - ir "gcx" "2ND RELAXATION TERM FOR BOUNDARY ZONE" "" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" + +#------------------------------------------------------------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------------------------------------------------------------------- +# Physics Related State Varibles + +#------------------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#------------------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010040 ij misc 1 - i1 "SM010040 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm040100 ij misc 1 - i1 "SM040100 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100200 ij misc 1 - i1 "SM100200 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010200 ij misc 1 - i1 "SM010200" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm000 ij misc 1 - i1 "SOILM000" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm005 ij misc 1 - i1 "SOILM005" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm020 ij misc 1 - i1 "SOILM020" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm040 ij misc 1 - i1 "SOILM040" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm160 ij misc 1 - i1 "SOILM160" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm300 ij misc 1 - i1 "SOILM300" "LAYER SOIL MOISTURE" "m3 m-3" +state real sw000010 ij misc 1 - i1 "SW000010" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010040 ij misc 1 - i1 "SW010040" "LAYER SOIL LIQUID" "m3 m-3" +state real sw040100 ij misc 1 - i1 "SW040100" "LAYER SOIL LIQUID" "m3 m-3" +state real sw100200 ij misc 1 - i1 "SW100200" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010200 ij misc 1 - i1 "SW010200" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw000 ij misc 1 - i1 "SOILW000" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw005 ij misc 1 - i1 "SOILW005" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw020 ij misc 1 - i1 "SOILW020" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw040 ij misc 1 - i1 "SOILW040" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw160 ij misc 1 - i1 "SOILW160" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw300 ij misc 1 - i1 "SOILW300" "LAYER SOIL LIQUID" "m3 m-3" +state real st000010 ij misc 1 - i1 "ST000010" "LAYER SOIL TEMPERATURE" "K" +state real st010040 ij misc 1 - i1 "ST010040" "LAYER SOIL TEMPERATURE" "K" +state real st040100 ij misc 1 - i1 "ST040100" "LAYER SOIL TEMPERATURE" "K" +state real st100200 ij misc 1 - i1 "ST100200" "LAYER SOIL TEMPERATURE" "K" +state real st010200 ij misc 1 - i1 "ST010200" "LAYER SOIL TEMPERATURE" "K" +state real soilt000 ij misc 1 - i1 "SOILT000" "LAYER SOIL TEMPERATURE" "K" +state real soilt005 ij misc 1 - i1 "SOILT005" "LAYER SOIL TEMPERATURE" "K" +state real soilt020 ij misc 1 - i1 "SOILT020" "LAYER SOIL TEMPERATURE" "K" +state real soilt040 ij misc 1 - i1 "SOILT040" "LAYER SOIL TEMPERATURE" "K" +state real soilt160 ij misc 1 - i1 "SOILT160" "LAYER SOIL TEMPERATURE" "K" +state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" +state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" +state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real shdmax ij misc 1 - i012r "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - i012r "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" +state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" +state real landusef iuj misc 1 Z i12 "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i12 "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i1 "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" + +#--------------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#--------------------------------------------------------------------------------------------------------------------------------------- + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim +state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" +state real ZS l misc - Z irh "ZS" "DEPTHS OF CENTERS OF SOIL LAYERS" "m" +state real DZS l misc - Z irh "DZS" "THICKNESSES OF SOIL LAYERS" "m" + +# urban model variables +state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" +state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" +state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" + +# lsm State Variables + +state real SMOIS ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" +state real SH2O ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" +state real XICE ij misc 1 - i012rhd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "XICE" "SEA ICE FLAG" "" +state real SMSTAV ij misc 1 - rd=(interp_mask_land_field:lu_index) "SMSTAV" "MOISTURE AVAILABILITY" "" +state real SMSTOT ij misc 1 - r "SMSTOT" "TOTAL SOIL MOISTURE" "m3 m-3" + +state real SFCRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "SFROFF" "SURFACE RUNOFF" "mm" +state real UDRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "UDROFF" "UNDERGROUND RUNOFF" "mm" +state integer IVGTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "IVGTYP" "DOMINANT VEGETATION CATEGORY" "" +state integer ISLTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" +state real VEGFRA ij misc 1 - i0125rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - r "SFCEVP" "SURFACE EVAPORATION" "kg m-2" +state real GRDFLX ij misc 1 - rh "GRDFLX" "GROUND HEAT FLUX" "W m-2" +state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" + +state real ACSNOW ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real SNOW ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real CANWAT ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" +state real SST ij misc 1 - i0125rhd=(interp_mask_water_field:lu_index) "SST" "SEA SURFACE TEMPERATURE" "K" +state integer IFNDSNOWH - misc 1 - i "FNDSNOWH" "SNOWH_LOGICAL" +state integer IFNDSOILW - misc 1 - i "FNDSOILW" "SOILW_LOGICAL" + +# urban state variables +state real TR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" +state real TG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" +state real TC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" +state real QC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" +state real UC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" +state real XXXR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" +state real XXXB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" +state real XXXG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" +state real XXXC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" +state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" +state real RN_URB2D ij misc 1 - r "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" +state real TS_URB2D ij misc 1 - r "TS_URB" "SKIN TEMPERATURE" "K" +state real FRC_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "FRC_URB" "URBAN FRACTION" "dimensionless" +state integer UTYPE_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "UTYPE_URB" "URBAN TYPE" "dimensionless" + + +# urban variables from radiation model +state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" +state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" + + +# RUC LSM +state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# MRF PBL variables +i1 real PSIM ij misc 1 - - "PSIM" "SIMILARITY FUNCTION FOR MOMENTUM" "" +i1 real PSIH ij misc 1 - - "PSIH" "SIMILARITY FUNCTION FOR HEAT" "" +i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" +i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" +i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" + +# MYJ PBL variables +state real tke_myj ikj misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS " +state real CT ij misc 1 - r "CT" "COUNTERGRADIENT TERM" "K" +state real THZ0 ij misc 1 - r "THZ0" "POTENTIAL TEMPERATURE AT ZNT" "K" +state real Z0 ij misc 1 - r "Z0" "Background ROUGHNESS LENGTH" "m" +state real QZ0 ij misc 1 - r "QZ0" "SPECIFIC HUMIDITY AT ZNT" "kg kg-1" +state real UZ0 ij misc 1 - r "UZ0" "U WIND COMPONENT AT ZNT" "m s-1" +state real VZ0 ij misc 1 - r "VZ0" "V WIND COMPONENT AT ZNT" "m s-1" +state real QSFC ij misc 1 - r "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - r "AKHS" "SFC EXCH COEFF FOR HEAT" "m s-1" +state real AKMS ij misc 1 - r "AKMS" "SFC EXCH COEFF FOR MOMENTUM" "m s-1" +state integer KPBL ij misc 1 - r "KPBL" "LEVEL OF PBL TOP" "" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real PSHLTR ij misc 1 - - "PSHLTR" "SHELTER PRESSURE FROM MYJ" "Pa" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" + +# gfdl (eta) radiation State Variables +state real HTOP ij misc 1 - r "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - r "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - r "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - r "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real CUTOP ij misc 1 - r "CUTOP" "TOP OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state real CUBOT ij misc 1 - r "CUBOT" "BOT OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state REAL CUPPT ij misc 1 - r "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINC LAST CALL TO THE RADIATION" "" +state real rswtoa ij misc 1 - i +state real rlwtoa ij misc 1 - i +state real czmean ij misc 1 - i +state real cfracl ij misc 1 - i +state real cfracm ij misc 1 - i +state real cfrach ij misc 1 - i +state real acfrst ij misc 1 - i +state integer ncfrst ij misc 1 - i +state real acfrcv ij misc 1 - i +state integer ncfrcv ij misc 1 - i + +# cam radiation variables +state real - iqjf ozmixm 1 - - - +state real mth01 iqjf ozmixm 1 - - - +state real mth02 iqjf ozmixm 1 - - - +state real mth03 iqjf ozmixm 1 - - - +state real mth04 iqjf ozmixm 1 - - - +state real mth05 iqjf ozmixm 1 - - - +state real mth06 iqjf ozmixm 1 - - - +state real mth07 iqjf ozmixm 1 - - - +state real mth08 iqjf ozmixm 1 - - - +state real mth09 iqjf ozmixm 1 - - - +state real mth10 iqjf ozmixm 1 - - - +state real mth11 iqjf ozmixm 1 - - - +state real mth12 iqjf ozmixm 1 - - - +state real pin q misc 1 - - "PIN" "PRESSURE LEVEL OF OZONE MIXING RATIO" "millibar" +state real m_ps ij misc 2 - - "m_ps" "PS from MATCH on WRF grids" +state real - idjf aerosolc 2 - - - +state real SUL idjf aerosolc 2 - - "SUL" "SUL aerosol concentration" +state real SSLT idjf aerosolc 2 - - "SSLT" "SSLT aerosol concentration" +state real DUST1 idjf aerosolc 2 - - "DUST1" "DUST1 aerosol concentration" +state real DUST2 idjf aerosolc 2 - - "DUST2" "DUST2 aerosol concentration" +state real DUST3 idjf aerosolc 2 - - "DUST3" "DUST3 aerosol concentration" +state real DUST4 idjf aerosolc 2 - - "DUST4" "DUST4 aerosol concentration" +state real OCPHO idjf aerosolc 2 - - "OCPHO" "OCPHO aerosol concentration" +state real BCPHO idjf aerosolc 2 - - "BCPHO" "BCPHO aerosol concentration" +state real OCPHI idjf aerosolc 2 - - "OCPHI" "OCPHI aerosol concentration" +state real BCPHI idjf aerosolc 2 - - "BCPHI" "BCPHI aerosol concentration" +state real BG idjf aerosolc 2 - - "BG" "BG aerosol concentration" +state real VOLC idjf aerosolc 2 - - "VOLC" "VOLC aerosol concentration" +state real m_hybi d misc 1 - - "m_hybi" "MATCH hybi" + +# new eta microphpysics State Variables +state real F_ICE_PHY ikj misc 1 - rdu "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - rdu "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - rdu "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real qndropsource ikj misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" + +# Other Misc State Variables +state real h_diabatic ikj misc 1 - r "h_diabatic" "PREVIOUS TIMESTEP CONDENSATIONAL HEATING" "" +state real msft ij misc 1 - i012rhdu=(copy_fcnm) "MAPFAC_M" "Map scale factor on mass grid" "" +state real msfu ij misc 1 X i012rhdu=(copy_fcnm) "MAPFAC_U" "Map scale factor on u-grid" "" +state real msfv ij misc 1 Y i012rhdu=(copy_fcnm) "MAPFAC_V" "Map scale factor on v-grid" "" +state real f ij misc 1 - i012rhdu=(copy_fcnm) "f" "Coriolis sine latitude term" "s-1" +state real e ij misc 1 - i012rhdu=(copy_fcnm) "e" "Coriolis cosine latitude term" "s-1" +state real sina ij misc 1 - i012rhdu=(copy_fcnm) "SINALPHA" "Local sine of map rotation" "" +state real cosa ij misc 1 - i012rhdu=(copy_fcnm) "COSALPHA" "Local cosine of map rotation" "" +state real ht ij misc 1 - i012rhdus "HGT" "Terrain Height" "m" +state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" +state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" +state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" + +state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" +state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" +state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" +state real v_base k misc 1 - ir "v_base" "BASE STATE Y WIND IN IDEALIZED CASES" "" +state real qv_base k misc 1 - ir "qv_base" "BASE STATE QV IN IDEALIZED CASES" "" +state real z_base k misc 1 - ir "z_base" "BASE STATE HEIGHT IN IDEALIZED CASES" "" +state real u_frame - misc 1 - ir "u_frame" "FRAME X WIND" "m s-1" +state real v_frame - misc 1 - ir "v_frame" "FRAME Y WIND" "m s-1" +# p_top appears as metadata between SI and real but as a state variable in real and WRF +# since it is a scalar and a constant, it makes sense to have it as metadata -- there +# are, however, probably post-processing programs that expect to see it as an I/O record +# another problem: share/input_wrf tries to read this as metadata (fine for real reading +# SI, but with model reading real output, it generates a warning when debug is > 0 in +# namelist and causes repeated questions from users. A third problem is the potential +# collision between a metadata name and a field record in the I/O data +# resolve this how? Have the real program throw a switch to tell the code to get it +# from the metadata? Otherwise it's a field? +state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state real lat_ll_t - dyn_em - - irh "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - irh "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - irh "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - irh "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - irh "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - irh "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - irh "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - irh "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - irh "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - irh "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - irh "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - irh "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - irh "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - irh "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - irh "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - irh "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - irh "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - irh "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - irh "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - irh "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - irh "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - irh "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - irh "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - irh "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - irh "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - irh "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - irh "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - irh "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - irh "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - irh "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - irh "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - irh "lon_lr_d" "longitude lower right, massless point" "degrees" + +# Other physics variables + +state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME" "Pa K s-1" +state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQICUTEN ikj misc 1 - r "RQICUTEN" "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real W0AVG ikj misc 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" + +state real RAINC ij misc 1 - rhdu "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" +state real RAINNC ij misc 1 - rhdu "RAINNC" "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" "mm" +state real RAINCV ij misc 1 - r "RAINCV" "TIME-STEP CUMULUS PRECIPITATION" "mm" +state real RAINNCV ij misc 1 - r "RAINNCV" "TIME-STEP NONCONVECTIVE PRECIPITATION" "mm" +state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" +state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" +state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" +state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" +state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY" "mm hour-1" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE" "mm hour-1" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K s-1" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg s-1" + +state integer STEPCU - misc 1 - r "STEPCU" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS" "" + +state real RTHRATEN ikj misc 1 - rd "RTHRATEN" "COUPLED THETA TENDENCY DUE TO RADIATION" "Pa K s-1" +state real RTHRATENLW ikj misc 1 - r "RTHRATLW" "COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION" "Pa K s-1" +state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "Pa K s-1" +state real CLDFRA ikj misc 1 - r "CLDFRA" "CLOUD FRACTION" "" + +state real SWDOWN ij misc 1 - rhd "SWDOWN" "DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" + +# upward and downward clearsky and total diagnostic fluxes for CAM radiation +#state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" + +state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" +state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" +state real OLR ij misc 1 - rh "OLR" "TOA OUTGOING LONG WAVE" "W m-2" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real ALBEDO ij misc 1 - rh "ALBEDO" "ALBEDO" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "" +state real EMISS ij misc 1 - r "EMISS" "SURFACE EMISSIVITY" "" + +state real CLDEFI ij misc 1 - r "CLDEFI" "precipitation efficiency in BMJ SCHEME" "" +state integer STEPRA - misc 1 - r "STEPRA" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS" "" + +state real RUBLTEN ikj misc 1 - r "RUBLTEN" "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RVBLTEN ikj misc 1 - r "RVBLTEN" "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION" "Pa K s-1" +state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" + +# State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because they are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - r +state integer landuse_lucats - misc - - r +state integer landuse_luseas - misc - - r +state integer landuse_isn - misc - - r +state real lu_state p misc - - r + +i1 real th_phy ikj misc 1 - +i1 real pi_phy ikj misc 1 - +i1 real p_phy ikj misc 1 - +i1 real t_phy ikj misc 1 - +i1 real u_phy ikj misc 1 - +i1 real v_phy ikj misc 1 - +i1 real dz8w ikj misc 1 Z +i1 real p8w ikj misc 1 Z +i1 real t8w ikj misc 1 Z +i1 real rho_phy ikj misc 1 - +i1 logical CU_ACT_FLAG ij misc 1 - + + +state real TMN ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" +state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real UST ij misc 1 - rh "UST" "U* IN SIMILARITY THEORY" "m s-1" +i1 real HOL ij misc 1 - - "HOL" "PBL HEIGHT OVER MONIN-OBUKHOV LENGTH" "" +state real RMOL ij misc 1 - r "RMOL" "1./Monin Ob. Length" "" +state real MOL ij misc 1 - r "MOL" "T* IN SIMILARITY THEORY" "K" +state real PBLH ij misc 1 - rh "PBLH" "PBL HEIGHT" "m" +state real CAPG ij misc 1 - r "CAPG" "HEAT CAPACITY FOR SOIL" "J K-1 m-3" +state real THC ij misc 1 - r "THC" "THERMAL INERTIA" "Cal cm-1 K-1 s-0.5" +state real HFX ij misc 1 - rh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX ij misc 1 - rh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real LH ij misc 1 - rh "LH" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +i1 real REGIME ij misc 1 - +state real SNOWC ij misc 1 - irhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" + +state real tkesfcf ij misc 1 - r "tkesfcf" "TKE AT THE SURFACE" "m2 s-2" + +state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" +state real taucldi ikj misc 1 - r "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" +state real taucldc ikj misc 1 - r "TAUCLDC" "CLOUD OPTICAL THICKNESS FOR WATER" "" + +state real defor11 ikj misc 1 - r "defor11" "DEFORMATION 11" "s-1" +state real defor22 ikj misc 1 - r "defor22" "DEFORMATION 22" "s-1" +state real defor12 ikj misc 1 - r "defor12" "DEFORMATION 12" "s-1" +state real defor33 ikj misc 1 z r "defor33" "DEFORMATION 33" "s-1" +state real defor13 ikj misc 1 z r "defor13" "DEFORMATION 13" "s-1" +state real defor23 ikj misc 1 z r "defor23" "DEFORMATION 23" "s-1" +state real xkmv ikj misc 1 - r "xkmv" "VERTICAL EDDY VISCOSITY" "m2 s-1" +state real xkmh ikj misc 1 - r "xkmh" "HORIZONTAL EDDY VISCOSITY" "m2 s-1" +state real xkmhd ikj misc 1 - r "xkmhd" "HORIZONTAL EDDY DIFFUSIVITY" "m2 s-1" +state real xkhv ikj misc 1 - r "xkhv" "VERTICAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real xkhh ikj misc 1 - r "xkhh" "HORIZONTAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real div ikj misc 1 - r "div" "DIVERGENCE" "s-1" +state real BN2 ikj misc 1 - r "BN2" "BRUNT-VAISALA FREQUENCY" "s-2" +state logical warm_rain - misc 1 - - "warm_rain" "WARM_RAIN_LOGICAL" +state logical adv_moist_cond - misc 1 - - "adv_moist_cond" "ADVECT MOIST CONDENSATES LOGICAL" + +## FDDA variables + +state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" +state real - ikjf fdda3d 1 - - - +state real U_NDG_NEW ikjf fdda3d 1 X igr "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_NEW ikjf fdda3d 1 Y igr "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_NEW ikjf fdda3d 1 - igr "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_NEW ikjf fdda3d 1 - igr "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_NEW ikjf fdda3d 1 Z igr "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real U_NDG_OLD ikjf fdda3d 1 X igr "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_OLD ikjf fdda3d 1 Y igr "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_OLD ikjf fdda3d 1 - igr "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_OLD ikjf fdda3d 1 - igr "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_OLD ikjf fdda3d 1 Z igr "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real - ivjf fdda2d 1 Z - - +state real MU_NDG_NEW ivjf fdda2d 1 Z igr "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state real MU_NDG_OLD ivjf fdda2d 1 Z igr "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" + + +# flag for nest movement +state logical moved - misc 1 - - + +# special cam radiation restart arrays +state real abstot ikcj misc 1 Z - "" "" " " +state real absnxt ikaj misc 1 - - "" "" " " +state real emstot ikj misc 1 Z - "" "" " " + +# model diagnostics +state real dpsdt ij misc 1 - - "dpsdt" "surface pressure tendency" "Pa/sec" +state real dmudt ij misc 1 - - "dmudt" "mu tendency" "Pa/sec" +state real pk1m ij misc 1 - - "pk1m" "surface pressure at previous step" "Pa" +state real mu_2m ij misc 1 - - "mu_2m" "mu_2 at previous step" "Pa" + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" +rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" +rconfig character rsmas_data_path namelist,time_control 1 "." - "rsmas_data_path" "" "" + +include registry.io_boilerplate + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" + +rconfig integer diag_print namelist,time_control 1 0 - "print out time series of model diagnostics" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer num_metgrid_levels namelist,domains 1 27 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig integer interp_type namelist,domains 1 1 irh "interp_type" "1=interp in pressure, 2=interp in LOG pressure" "" +rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" +rconfig integer t_extrap_type namelist,domains 1 1 irh "t_extrap_type" "1= use 2 lowest levels, 2=constant, 3 = 6.5 K/km" "" +rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. irh "lowest_lev_from_sfc" "" "" +rconfig integer lagrange_order namelist,domains 1 1 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer force_sfc_in_vinterp namelist,domains 1 1 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" +rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "afcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" +rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 rh "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 rh "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig integer blend_width namelist,domains 1 5 h "blend_width" "width of cg fg terrain blended zone" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer max_vortex_speed namelist,domains max_domains 40 - "" "" "meters per second" +rconfig integer corral_dist namelist,domains max_domains 8 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real max_dz namelist,domains 1 1000. + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig real naer namelist,physics max_domains 1e9 rh "NAER" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer num_months namelist,physics 1 12 irh "num_months" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" +rconfig integer co2tf namelist,physics 1 1 - "co2tf" "GFDL radiation co2 flag" "" +rconfig integer ra_call_offset namelist,physics 1 0 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +#FDDA namelist parameters +rconfig real FGDT namelist,fdda max_domains 0 h "FGDT" "" "" +rconfig integer grid_fdda namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real guv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gt namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gq namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real dtramp_min namelist,fdda 1 0 h "grid_fdda" "" "" +rconfig integer if_ramping namelist,fdda 1 0 h "grid_fdda" "" "" + +#Observational Nudging +rconfig integer obs_nudge_opt namelist,fdda max_domains 0 rh "obs_nudge_opt" "Obs-nudging flag for domain" "" +rconfig integer max_obs namelist,fdda 1 0 h "max_obs" "Maximum number of observations" "" +rconfig integer nobs_ndg_vars namelist,fdda 1 5 h "num_ndg_vars" "Number of nudging variables" "" +rconfig integer nobs_err_flds namelist,fdda 1 9 h "num_err_flds" "Number of error fields" "" +rconfig real fdda_start namelist,fdda max_domains 0 rh "fdda_start" "Nudging start time for domain" "min" +rconfig real fdda_end namelist,fdda max_domains 0 rh "fdda_end" "Nudging end time for domain" "min" +rconfig integer obs_nudge_wind namelist,fdda max_domains 0 rh "obs_nudge_wind" "Wind-nudging flag for domain" "" +rconfig real obs_coef_wind namelist,fdda max_domains 0 rh "obs_coef_wind" "Wind-nudging coeficient for domain" "s-1" +rconfig integer obs_nudge_temp namelist,fdda max_domains 0 rh "obs_nudge_temp" "Temperature-nudging flag for domain" "" +rconfig real obs_coef_temp namelist,fdda max_domains 0 rh "obs_coef_temp" "Temperature-nudging coef for domain" "s-1" +rconfig integer obs_nudge_mois namelist,fdda max_domains 0 rh "obs_nudge_mois" "Moisture-nudging flag for domain" "" +rconfig real obs_coef_mois namelist,fdda max_domains 0 rh "obs_coef_mois" "Moisture-nudging coef for domain" "s-1" +rconfig integer obs_nudge_pstr namelist,fdda max_domains 0 rh "obs_nudge_pstr" "Not used" "" +rconfig real obs_coef_pstr namelist,fdda max_domains 0 rh "obs_coef_pstr" "Not used" "" +rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" +rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" +rconfig real obs_twindo namelist,fdda 1 0 h "obs_twindo" "Half-period time window for nudging" "min" +rconfig integer obs_npfi namelist,fdda 1 0 h "obs_npfi" "Freq in cg timesteps for diag print" "" +rconfig integer obs_ionf namelist,fdda 1 0 h "obs_ionf" "Freq in cg timesteps for obs input and error calc" "" +rconfig integer obs_idynin namelist,fdda 1 0 h "obs_idynin" "Flag for dynamic initialization" "" +rconfig real obs_dtramp namelist,fdda 1 0 h "obs_dtramp" "Time period for ramping (idynin)" "min" +rconfig logical obs_ipf_in4dob namelist,fdda 1 .false. h "obs_ipf_in4dob" "Print obs input diagnostics" "min" +rconfig logical obs_ipf_errob namelist,fdda 1 .false. h "obs_ipf_errob" "Print obs error diagnostics" "min" +rconfig logical obs_ipf_nudob namelist,fdda 1 .false. h "obs_ipf_nudob" "Print obs nudge diagnostics" "min" + + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 2 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real diff_6th_factor namelist,dynamics max_domains 0.12 h "diff_6th_factor" "factor that controls rate of 6th-order numerical diffusion" +rconfig integer diff_6th_opt namelist,dynamics max_domains 0 irh "diff_6th_opt" "switch for 6th-order numerical diffusion" +rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0.01 h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 0 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 5 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical pd_moist namelist,dynamics max_domains .false. rh "pd_moist" "positive-definite RK3 transport switch" "" +rconfig logical pd_chem namelist,dynamics max_domains .false. rh "pd_chem" "positive-definite RK3 transport switch" "" +rconfig logical pd_scalar namelist,dynamics max_domains .false. rh "pd_scalar" "positive-definite RK3 transport switch" "" +rconfig logical pd_tke namelist,dynamics max_domains .false. rh "pd_tke" "positive-definite RK3 transport switch" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 1000. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "dimensionless" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "K m s-1" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical mix_full_fields namelist,dynamics max_domains .false. irh "mix_full_field" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# Package Declarations +# + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_em dyn_opt==2 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qi,qs,qg;scalar:qt +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package noprogn progn==0 - - +package progndrop progn==1 - scalar:qndrop + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +#--------------------------------------------------------------------------------------------------------------------------------------- +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# Halo Update Communications + +halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 +halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb +halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb +halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msft,msfu,msfv,f,e,sina,cosa,ht,potevp,snopcx,soiltb +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb +halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut +halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 +halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten +halo HALO_EM_FDDA dyn_em 4:rundgdten,rvndgdten +halo HALO_EM_PHYS_DIFFUSION dyn_em 4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,xkmhd,xkhv,xkhh,tke_1,tke_2 +halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 +halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 +halo HALO_EM_TKE_A dyn_em 4:ph_2,phb +halo HALO_EM_TKE_B dyn_em 4:z,rdz,rdzw,zx,zy +halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw +halo HALO_EM_TKE_D dyn_em 8:defor11,defor22,defor33,defor12,defor13,defor23,div +halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkmhd,xkhv,xkhh,BN2,moist +halo HALO_EM_TKE_3 dyn_em 24:tke_1,tke_2 +halo HALO_EM_TKE_5 dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_7 dyn_em 80:tke_1,tke_2 +halo HALO_EM_TKE_F dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_OLD_E_5 dyn_em 48:tke_1 +halo HALO_EM_TKE_OLD_E_7 dyn_em 80:tke_1 +halo HALO_EM_B dyn_em 4:ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend +halo HALO_EM_C dyn_em 4:u_2,v_2 +halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf +halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_MOIST_E_3 dyn_em 24:moist +halo HALO_EM_MOIST_E_5 dyn_em 48:moist +halo HALO_EM_MOIST_E_7 dyn_em 80:moist +halo HALO_EM_CHEM_E_3 dyn_em 24:chem +halo HALO_EM_CHEM_E_5 dyn_em 48:chem +halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar +halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar +halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar + +halo HALO_EM_MOIST_OLD_E_3 dyn_em 24:moist_old +halo HALO_EM_MOIST_OLD_E_5 dyn_em 48:moist_old +halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old +halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old +halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old +halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old +halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old +halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old + +halo HALO_EM_FEEDBACK dyn_em 48:ht + +halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 +period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 +halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar +period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar + +# For moving nests +halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 +halo em_shift_halo_x dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 + +# For observational nudging +halo HALO_OBS_NUDGE dyn_em 24:pb,p,uratx,vratx,tratx + +# Periodic Boundary Communications + +period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,t_init,phb,ph0,php,pb,al,alt,alb,mu_1,mu_2,mub,mu0,ht,msft,msfu,msfv,sina,cosa,e,f +period PERIOD_BDY_EM_MOIST dyn_em 3:moist +period PERIOD_BDY_EM_CHEM dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR dyn_em 3:scalar +period PERIOD_BDY_EM_MOIST2 dyn_em 3:moist +period PERIOD_BDY_EM_CHEM2 dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR2 dyn_em 3:scalar +period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al +period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy +period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,xkmh,xkmhd,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2 +period PERIOD_BDY_EM_FDDA_BC dyn_em 2:rundgdten,rvndgdten +period PERIOD_BDY_EM_B dyn_em 2:ru_tend,rv_tend,ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +period PERIOD_BDY_EM_B3 dyn_em 2:ph_2,al,p,mu_2,muts,mudf +period PERIOD_BDY_EM_B2 dyn_em 2:ru_tend,rv_tend +period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfv,muu,msfu +period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 +period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 + +# +#swap SWAP_ETAMP_NEW dyn_em 1:dz8w,p_phy,pi_phy,rho,th_phy,moist,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,RAINNC,RAINNCV,SR,LOWLYR +#swap SWAP_WSM3 dyn_em 1:th_phy,moist,w_2,rho,pi_phy,p_phy,dz8w,rainnc,rainncv +#cycle CYCLE_TEST dyn_em 1:xlong + +## + +# FDDA (Observational-nudging) Variables +typedef fdob_type integer domain_tot # total number of domains to apply obs-nudging +typedef fdob_type integer domain_init # domain initialization flag +typedef fdob_type integer IEODI # end of obs data flag for current model step +typedef fdob_type integer IWTSIG # flag for nudging on pressure surfaces +typedef fdob_type integer NSTAT # number of obs stations used to nudge current model step +typedef fdob_type integer KTAUR # restart model step +typedef fdob_type integer SN_MAXCG # coarse domain grid dimension in south-north coordinate +typedef fdob_type integer WE_MAXCG # coarse domain grid dimension in west-east coordinate +typedef fdob_type integer SN_END # ending north-south grid index +typedef fdob_type integer LEVIDN(max_domains) # level of nest +typedef fdob_type real DS_CG # coarse domain grid size +typedef fdob_type real WINDOW # time window half-period for nudging (in minutes) +typedef fdob_type real RTLAST # time in hours of last obs used in current model step +typedef fdob_type real DATEND # time in minutes after which data are asuumed to have ended +typedef fdob_type real RINFMN # minimum radius of influence +typedef fdob_type real RINFMX # maximum radius of influence +typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small +typedef fdob_type real DCON # 1/DPSMX +typedef fdob_type real DPSMX # max pres change (cb) allowed within infl range of surf obs +typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization +typedef fdob_type real XN # cone factor for Lambert projection + +# table entries are of the form +#
+#Grid variables +typedef fdob_type real varobs rz - 1 - - "varobs" "observational values in each variable" +typedef fdob_type real errf hz - 1 - - "errf" "errors between model and obs values" +typedef fdob_type real timeob z - 1 - - "timeob" "model times for each observation" "hours" +typedef fdob_type real nlevs_ob z - 1 - - "nlevs_ob" "numbers of levels in sounding obs" +typedef fdob_type real lev_in_ob z - 1 - - "lev_in_ob" "level in sounding-type obs" +typedef fdob_type real plfo z - 1 - - "plfo" "index for type of obs-platform" +typedef fdob_type real elevob z - 1 - - "elevob" "elevation of observation" "meters" +typedef fdob_type real rio z - 1 - - "rio" "west-east grid coordinate" +typedef fdob_type real rjo z - 1 - - "rjo" "south-north grid coordinate" +typedef fdob_type real rko z - 1 - - "rko" "vertical grid coordinate" + +state fdob_type fdob - - +## + +# +# ---------------------------------------- +# begin fire variables and configuration +# ---------------------------------------- +# +# declare fire package and choose which fire scheme +# +# +# name> namelist choice> state vars> +# +package fire_cawfe fire==1 - - + +# fire dimensions on fire grid +# +#
+dimspec n - constant=2 c fire_index_dim +dimspec o - constant=4 c fire_particle_dim + +# fire variables on fire grid +# +#
+state integer nfuel_cat *i*j fire 1 - - +state integer nfl *i*j fire 1 - - +state integer nfl_t *i*j fire 1 - - +state integer nfl_c *i*j fire 1 - - +state integer ncod *i*j fire 1 - - +state real fg *i*j fire 1 - - +state real fc *i*j fire 1 - - +state real r_0 *i*j fire 1 - - +state real bbb *i*j fire 1 - - +state real betafl *i*j fire 1 - - +state real phiwc *i*j fire 1 - - +state real area *i*j fire 1 - - +state real area2 *i*j fire 1 - - +state real zf *i*j fire 1 - - +state real zsf *i*j fire 1 - - +state real tign_g *i*j fire 1 - - +state real tign_c *i*j fire 1 - - +state real tign_crt *i*j fire 1 - - +# +state integer in1 *i*jn fire 1 - h +state integer in2 *i*jn fire 1 - h +state integer ixb *i*jo fire 1 - h +state integer iyb *i*jo fire 1 - h +state integer icn *i*jo fire 1 - h +state real xfg *i*jo fire 1 - h +state real yfg *i*jo fire 1 - h +state real xcd *i*jo fire 1 - h +state real ycd *i*jo fire 1 - h +state real xcn *i*jo fire 1 - h +state real ycn *i*jo fire 1 - h +state real sprdx *i*jo fire 1 - h +state real sprdy *i*jo fire 1 - h + +# fire variables on atm grid +# +state real rthfrten ikj fire 1 - h +state real rqvfrten ikj fire 1 - h +state real grnhfx ij fire 1 - h +state real grnqfx ij fire 1 - h +state real canhfx ij fire 1 - h +state real canqfx ij fire 1 - h + +# +# fire configure namelist variables +# +#
+rconfig integer ifire namelist,fire 1 0 +rconfig real fire_lat_init namelist,fire 1 0. - "fire_lat_init" "latitude to start fire" "degrees" +rconfig real fire_lon_init namelist,fire 1 0. - "fire_lon_init" "longitude to start fire" "degrees" +rconfig real fire_ign_time namelist,fire 1 0. - "fire_ign_time" "time when fire should be ignited" "min" +rconfig integer fire_shape namelist,fire 1 0 - "fire_shape" "fire shape" "" +rconfig integer fire_sprd_mdl namelist,fire 1 1 - "fire_sprd_mdl" "which spread rate formula: if 0, Macarthur; if 1, BEHAVE" "" +rconfig real fire_crwn_hgt namelist,fire 1 15. - "fire_crwn_hgt" "height that heat from crown fire is released" "m" +rconfig real fire_ext_grnd namelist,fire 1 50. - "fire_ext_grnd" "extinction depth of sfc fire heat" "m" +rconfig real fire_ext_crwn namelist,fire 1 50. - "fire_ext_crwn" "extinction depth of crown fire heat" "m" +rconfig integer fire_fuel_read namelist,fire 1 0 - "fire_fuel_read" "fuel categories are set by: if 0, uniform; if 1, user-presc; if 2, read from file" "" +rconfig integer fire_fuel_cat namelist,fire 1 1 - "fire_fuel_cat" "fuel category if ifuelread=0" "" + +# +# ---------------------------------------- +# end fire variables and configuration +# ---------------------------------------- +# diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM new file mode 100644 index 00000000..5f47e473 --- /dev/null +++ b/wrfv2_fire/Registry/Registry.EM_CHEM @@ -0,0 +1,1370 @@ +# Registry file, EM_CHEM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +# Available characters for dimspec: 0123456789@%+=|?.!&[{}] + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec e 3 namelist=ensdim z ensemble dimension +dimspec z - namelist=max_obs c max_obs +dimspec h - namelist=nobs_err_flds c nobs_err_flds +dimspec r - namelist=nobs_ndg_vars c nobs_ndg_vars +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec o 3 namelist=ne_area z emissions dimension +dimspec + 2 namelist=kemit z emissions_zdim +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec q 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev +dimspec v - constant=1 z one + + + +################################################################################ +################################################################################ +################################################################################ + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# table entries are of the form +#
+# + +# It is required that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# this next 1 is for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" + +# +# Variables from WPS +# + +state real u_gc igj dyn_em 1 XZ i1 "UU" "x-wind component" "m s-1" +state real v_gc igj dyn_em 1 YZ i1 "VV" "y-wind component" "m s-1" +state real t_gc igj dyn_em 1 Z i1 "TT" "temperature" "K" +state real rh_gc igj dyn_em 1 Z i1 "RH" "relative humidity" "%" +state real ght_gc igj dyn_em 1 Z i1 "GHT" "geopotential height" "m" +state real p_gc igj dyn_em 1 Z i1 "PRES" "pressure" "Pa" +state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" +state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" +state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" +state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" +state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real pslv_gc ij dyn_em 1 - i1 "PMSL" "sea level pressure" "Pa" +state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" +state real psfc_gc ij dyn_em 1 - - "PSFC_GC" "surface pressure" "Pa" +state real intq_gc ij dyn_em 1 - - "INTQ" "integrated mixing ratio" "Pa" +state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" +state real qv_gc igj dyn_em 1 Z i1 "QV" "mixing ratio" "kg kg-1" +#state real qr_gc igj dyn_em 1 Z i1 "QR" "rain water mixing ratio" "kg kg-1" +#state real qc_gc igj dyn_em 1 Z i1 "QC" "cloud water mixing ratio" "kg kg-1" +#state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" +#state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" +#state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# +# Variables for Eulerian mass coordinate dynamics +# + +# Velocities +# +# U Vel +state real u ikjb dyn_em 2 X \ + i01rhusdf=(bdy_interp:dt) "U" "x-wind component" "m s-1" +state real ru ikj dyn_em 1 X - "MU_U" "mu-coupled u" "Pa m s-1" +state real ru_m ikj dyn_em 1 X - "ru_m" "" "" +state real ru_tend ikj dyn_em 1 X - "ru_tend" "" "" +i1 real ru_tendf ikj dyn_em 1 X +state real u_save ikj dyn_em 1 X - "u_save" +# +# V Vel +state real v ikjb dyn_em 2 Y \ + i01rhusdf=(bdy_interp:dt) "V" "y-wind component" "m s-1" +state real rv ikj dyn_em 1 Y - "MU_V" "mu-coupled v" "Pa m s-1" +state real rv_m ikj dyn_em 1 Y - "rv_m" +state real rv_tend ikj dyn_em 1 Y - "rv_tend" +i1 real rv_tendf ikj dyn_em 1 Y +state real v_save ikj dyn_em 1 Y - "v_save" +# +# Vertical Vel +state real w ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "w" "z-wind component" "m s-1" +state real ww ikj dyn_em 1 Z r "ww" "mu-coupled eta-dot" "Pa s-1" +state real rw ikj dyn_em 1 Z - "rw" "mu-coupled w" "Pa m s-1" +i1 real ww1 ikj dyn_em 1 Z +state real ww_m ikj dyn_em 1 Z r "ww_m" "time-avg mu-coupled eta-dot" "Pa s-1" +i1 real wwp ikj dyn_em 1 Z +i1 real rw_tend ikj dyn_em 1 Z +i1 real rw_tendf ikj dyn_em 1 Z +i1 real w_save ikj dyn_em 1 Z + +# Geopotential +state real ph ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "ph" "perturbation geopotential" "m2 s-2" +state real phb ikj dyn_em 1 Z irhdus "phb" "base-state geopotential" "m2 s-2" +state real phb_fine ikj dyn_em 1 Z - "phb_fine" "for nesting, temp holding interpolated coarse grid phb" "m2 s-2" +state real ph0 ikj dyn_em 1 Z r "ph0" "initial geopotential" "m2 s-2" +state real php ikj dyn_em 1 Z r "php" "geopotential" "m2 s-2" +i1 real ph_tend ikj dyn_em 1 Z +i1 real ph_tendf ikj dyn_em 1 Z +i1 real ph_save ikj dyn_em 1 Z + +# Potential Temperature +state real t ikjb dyn_em 2 - \ + i01rhusdf=(bdy_interp:dt) "t" "perturbation potential temperature (theta-t0)" "K" + +state real t_init ikj dyn_em 1 - ir "t_init" "initial potential temperature" "K" +i1 real t_tend ikj dyn_em 1 - +i1 real t_tendf ikj dyn_em 1 - +state real tp ikj dyn_em 2 - +i1 real t_2save ikj dyn_em 1 - +state real t_save ikj dyn_em 1 - "t_save" +# + + +# Mass +state real mu ijb dyn_em 2 - \ + irhusdf=(bdy_interp:dt) "mu" "perturbation dry air mass in column" "Pa" +state real mub ij dyn_em 1 - irhdus "mub" "base state dry air mass in column" "Pa" +state real mub_fine ij dyn_em 1 - - "mub_fine" "nest temp, holds interpolated coarse grid mub" "Pa" +state real mu0 ij dyn_em 1 - i01rdu "mu0" "initial dry mass in column" "Pa" +state real mudf ij dyn_em 1 - - "mudf" "" "" +state real muu ij dyn_em 1 - "muu" +i1 real muus ij dyn_em 1 - +state real muv ij dyn_em 1 - "muv" +i1 real muvs ij dyn_em 1 - +state real mut ij dyn_em 1 - "mut" +state real muts ij dyn_em 1 - "muts" +i1 real muave ij dyn_em 1 - +i1 real mu_save ij dyn_em 1 - +i1 real mu_tend ij dyn_em 1 - +i1 real mu_tendf ij dyn_em 1 - + +#diagnostic for looking at nest position in output. A mungy version of terrain height. +state real nest_pos ij misc 1 - rhu=(mark_domain) "NEST_POS" +state real nest_mask ij misc 1 - ru=(mark_domain) "NEST_MASK" "LOCATION OF NEST IF ANY" +state real ht_coarse ij misc 1 - r - "STORAGE FOR LOW-RES TERRAIN" + + +# TKE +state real tke ikj dyn_em 2 - r "tke" "TURBULENCE KINETIC ENERGY" "m2 s-2" +i1 real tke_tend ikj dyn_em 1 - + +# Pressure and Density +state real p ikj dyn_em 1 - rh "p" "perturbation pressure" "Pa" +state real al ikj dyn_em 1 - r "al" "inverse perturbation density" "m3 kg-1" +state real alt ikj dyn_em 1 - rh "alt" "inverse density" "m3 kg-1" +state real alb ikj dyn_em 1 - rdus "alb" "inverse base density" "m3 kg-1" +state real zx ikj dyn_em 1 X - " " " " " " +state real zy ikj dyn_em 1 Y - " " " " " " +state real rdz ikj dyn_em 1 Z - " " " " " " +state real rdzw ikj dyn_em 1 Z - " " " " " " +state real pb ikj dyn_em 1 - rhdus "pb" "BASE STATE PRESSURE " "Pa" + +# +# Other dyn +# +i1 real advect_tend ikj dyn_em 1 - +i1 real alpha ikj dyn_em 1 - +i1 real a ikj dyn_em 1 - +i1 real gamma ikj dyn_em 1 - +i1 real c2a ikj dyn_em 1 - - +i1 real rho ikj dyn_em 1 - - +i1 real phm ikj dyn_em 1 - - +i1 real cqu ikj dyn_em 1 - - +i1 real cqv ikj dyn_em 1 - - +i1 real cqw ikj dyn_em 1 - - +i1 real pm1 ikj dyn_em 1 - - +state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" +state real potevp ij dyn_em 1 - h "potevp" "whatever" +state real snopcx ij dyn_em 1 - h "snopcx" "whatever" +state real soiltb ij dyn_em 1 - h "soiltb" "whatever" +state real fnm k dyn_em 1 - irh "fnm" "upper weight for vertical stretching" "" +state real fnp k dyn_em 1 - irh "fnp" "lower weight for vertical stretching" "" +state real rdnw k dyn_em 1 - irh "rdnw" "inverse d(eta) values between full (w) levels" "" +state real rdn k dyn_em 1 - irh "rdn" "inverse d(eta) values between half (mass) levels" "" +state real dnw k dyn_em 1 - irh "dnw" "d(eta) values between full (w) levels" "" +state real dn k dyn_em 1 - irh "dn " "d(eta) values between half (mass) levels" "" +state real znu k dyn_em 1 - irh "znu" "eta values on half (mass) levels" "" +state real znw k dyn_em 1 Z i01rh "znw" "eta values on full (w) levels" "" +state real t_base k dyn_em 1 - ir "t_base" "BASE STATE T IN IDEALIZED CASES" "K" +state real z ikj dyn_em 1 - - " " " " " " +i1 real mu_3d ikj dyn_em 1 - +i1 real z_at_w ikj dyn_em 1 Z +state real cfn - misc - - irh "cfn" "extrapolation constant" "" +state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" +state integer step_number - misc - - ir "step_number" "" + +# 2m and 10m output diagnostics +state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" +state real TH2 ij misc 1 - irhd "TH2" "POT TEMP at 2 M" "K" +state real PSFC ij misc 1 - i01rh "PSFC" "SFC PRESSURE" "Pa" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real U10 ij misc 1 - irh01d "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - irh01d "V10" "V at 10 M" "m s-1" + +# these next 4 are for observational nudging +state real uratx ij misc 1 - ir "URATX" "Ratio of U over U10 on mass points " "dimensionless" +state real vratx ij misc 1 - ir "VRATX" "Ratio of V over V10 on mass points " "dimensionless" +state real tratx ij misc 1 - ir "TRATX" "Ratio of T over TH2 on mass points " "dimensionless" +state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" + +# Other +state real rdx - misc - - irh "rdx" "INVERSE X GRID LENGTH" "" +state real rdy - misc - - irh "rdy" "INVERSE Y GRID LENGTH" "" +state real dts - misc - - ir "dts" "SMALL TIMESTEP" "" +state real dtseps - misc - - ir "dtseps" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real resm - misc - - irh "resm" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real zetatop - misc - - irh "zetatop" "ZETA AT MODEL TOP" "" +state real cf1 - misc - - irh "cf1" "2nd order extrapolation constant" "" +state real cf2 - misc - - irh "cf2" "2nd order extrapolation constant" "" +state real cf3 - misc - - irh "cf3" "2nd order extrapolation constant" "" +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - rh "itimestep" "" "" +state real xtime - - - - rh "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +# Mask for moving nest interpolations +state integer imask_nostag ij misc 1 - +state integer imask_xstag ij misc 1 X +state integer imask_ystag ij misc 1 Y +state integer imask_xystag ij misc 1 XY +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# Scalar (4D) arrays + +# Moist Scalars +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjftb moist 1 - - - +state real qv ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" + + +include registry.chem + +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qni ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNICE" "Ice Number concentration" "# kg-1" +state real qndrop ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" +state real qt ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "CWM" "Total condensate mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# Arrays for Specified LBCs (lbc arrays REMOVED; Boundary arrays are now specified with the state array; see above, 20050413 JM ) + +state real fcx w misc - - ir "fcx" "RELAXATION TERM FOR BOUNDARY ZONE" "" +state real gcx w misc - - ir "gcx" "2ND RELAXATION TERM FOR BOUNDARY ZONE" "" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" + +#------------------------------------------------------------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------------------------------------------------------------------- +# Physics Related State Varibles + +#------------------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#------------------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010040 ij misc 1 - i1 "SM010040 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm040100 ij misc 1 - i1 "SM040100 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100200 ij misc 1 - i1 "SM100200 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010200 ij misc 1 - i1 "SM010200" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm000 ij misc 1 - i1 "SOILM000" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm005 ij misc 1 - i1 "SOILM005" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm020 ij misc 1 - i1 "SOILM020" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm040 ij misc 1 - i1 "SOILM040" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm160 ij misc 1 - i1 "SOILM160" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm300 ij misc 1 - i1 "SOILM300" "LAYER SOIL MOISTURE" "m3 m-3" +state real sw000010 ij misc 1 - i1 "SW000010" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010040 ij misc 1 - i1 "SW010040" "LAYER SOIL LIQUID" "m3 m-3" +state real sw040100 ij misc 1 - i1 "SW040100" "LAYER SOIL LIQUID" "m3 m-3" +state real sw100200 ij misc 1 - i1 "SW100200" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010200 ij misc 1 - i1 "SW010200" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw000 ij misc 1 - i1 "SOILW000" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw005 ij misc 1 - i1 "SOILW005" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw020 ij misc 1 - i1 "SOILW020" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw040 ij misc 1 - i1 "SOILW040" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw160 ij misc 1 - i1 "SOILW160" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw300 ij misc 1 - i1 "SOILW300" "LAYER SOIL LIQUID" "m3 m-3" +state real st000010 ij misc 1 - i1 "ST000010" "LAYER SOIL TEMPERATURE" "K" +state real st010040 ij misc 1 - i1 "ST010040" "LAYER SOIL TEMPERATURE" "K" +state real st040100 ij misc 1 - i1 "ST040100" "LAYER SOIL TEMPERATURE" "K" +state real st100200 ij misc 1 - i1 "ST100200" "LAYER SOIL TEMPERATURE" "K" +state real st010200 ij misc 1 - i1 "ST010200" "LAYER SOIL TEMPERATURE" "K" +state real soilt000 ij misc 1 - i1 "SOILT000" "LAYER SOIL TEMPERATURE" "K" +state real soilt005 ij misc 1 - i1 "SOILT005" "LAYER SOIL TEMPERATURE" "K" +state real soilt020 ij misc 1 - i1 "SOILT020" "LAYER SOIL TEMPERATURE" "K" +state real soilt040 ij misc 1 - i1 "SOILT040" "LAYER SOIL TEMPERATURE" "K" +state real soilt160 ij misc 1 - i1 "SOILT160" "LAYER SOIL TEMPERATURE" "K" +state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" +state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" +state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real shdmax ij misc 1 - i012r "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - i012r "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" +state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" +state real landusef iuj misc 1 Z i12 "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i12 "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i1 "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" + +#--------------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#--------------------------------------------------------------------------------------------------------------------------------------- + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim +state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" +state real ZS l misc - Z irh "ZS" "DEPTHS OF CENTERS OF SOIL LAYERS" "m" +state real DZS l misc - Z irh "DZS" "THICKNESSES OF SOIL LAYERS" "m" + +# urban model variables +state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" +state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" +state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" + +# lsm State Variables + +state real SMOIS ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" +state real SH2O ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" +state real XICE ij misc 1 - i012rhd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "XICE" "SEA ICE FLAG" "" +state real SMSTAV ij misc 1 - rd=(interp_mask_land_field:lu_index) "SMSTAV" "MOISTURE AVAILABILITY" "" +state real SMSTOT ij misc 1 - r "SMSTOT" "TOTAL SOIL MOISTURE" "m3 m-3" + +state real SFCRUNOFF ij misc 1 - rd=(interp_mask_land_field:lu_index) "SFROFF" "SURFACE RUNOFF" "mm" +state real UDRUNOFF ij misc 1 - rd=(interp_mask_land_field:lu_index) "UDROFF" "UNDERGROUND RUNOFF" "mm" +state integer IVGTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "IVGTYP" "DOMINANT VEGETATION CATEGORY" "" +state integer ISLTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" +state real VEGFRA ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - r "SFCEVP" "SURFACE EVAPORATION" "kg m-2" +state real GRDFLX ij misc 1 - r "GRDFLX" "GROUND HEAT FLUX" "W m-2" +state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" + +state real ACSNOW ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real SNOW ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real CANWAT ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" +state real SST ij misc 1 - i012rhd=(interp_mask_water_field:lu_index) "SST" "SEA SURFACE TEMPERATURE" "K" +state integer IFNDSNOWH - misc 1 - i "FNDSNOWH" "SNOWH_LOGICAL" +state integer IFNDSOILW - misc 1 - i "FNDSOILW" "SOILW_LOGICAL" + +# urban state variables +state real TR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" +state real TG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" +state real TC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" +state real QC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" +state real UC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" +state real XXXR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" +state real XXXB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" +state real XXXG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" +state real XXXC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" +state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" +state real RN_URB2D ij misc 1 - r "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" +state real TS_URB2D ij misc 1 - r "TS_URB" "SKIN TEMPERATURE" "K" +state real FRC_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "FRC_URB" "URBAN FRACTION" "dimensionless" +state integer UTYPE_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "UTYPE_URB" "URBAN TYPE" "dimensionless" +# +# +# urban variables from radiation model +state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" +state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" + +# RUC LSM +state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# MRF PBL variables***25Aug 2002***** +i1 real PSIM ij misc 1 - - "PSIM" "SIMILARITY FUNCTION FOR MOMENTUM" "" +i1 real PSIH ij misc 1 - - "PSIH" "SIMILARITY FUNCTION FOR HEAT" "" +i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" +i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" +i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" + +# MYJ PBL variables +state real tke_myj ikj misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS " +state real CT ij misc 1 - r "CT" "COUNTERGRADIENT TERM" "K" +state real THZ0 ij misc 1 - r "THZ0" "POTENTIAL TEMPERATURE AT ZNT" "K" +state real Z0 ij misc 1 - r "Z0" "Background ROUGHNESS LENGTH" "m" +state real QZ0 ij misc 1 - r "QZ0" "SPECIFIC HUMIDITY AT ZNT" "kg kg-1" +state real UZ0 ij misc 1 - r "UZ0" "U WIND COMPONENT AT ZNT" "m s-1" +state real VZ0 ij misc 1 - r "VZ0" "V WIND COMPONENT AT ZNT" "m s-1" +state real QSFC ij misc 1 - r "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - r "AKHS" "SFC EXCH COEFF FOR HEAT" "m s-1" +state real AKMS ij misc 1 - r "AKMS" "SFC EXCH COEFF FOR MOMENTUM" "m s-1" +state integer KPBL ij misc 1 - r "KPBL" "LEVEL OF PBL TOP" "" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real PSHLTR ij misc 1 - - "PSHLTR" "SHELTER PRESSURE FROM MYJ" "Pa" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" + +# gfdl (eta) radiation State Variables +state real HTOP ij misc 1 - r "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - r "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - r "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - r "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real CUTOP ij misc 1 - r "CUTOP" "TOP OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state real CUBOT ij misc 1 - r "CUBOT" "BOT OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state REAL CUPPT ij misc 1 - r "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINC LAST CALL TO THE RADIATION" "" +state real rswtoa ij misc 1 - i +state real rlwtoa ij misc 1 - i +state real czmean ij misc 1 - i +state real cfracl ij misc 1 - i +state real cfracm ij misc 1 - i +state real cfrach ij misc 1 - i +state real acfrst ij misc 1 - i +state integer ncfrst ij misc 1 - i +state real acfrcv ij misc 1 - i +state integer ncfrcv ij misc 1 - i + +# cam radiation variables +state real - iqjf ozmixm 1 - - - +state real mth01 iqjf ozmixm 1 - - - +state real mth02 iqjf ozmixm 1 - - - +state real mth03 iqjf ozmixm 1 - - - +state real mth04 iqjf ozmixm 1 - - - +state real mth05 iqjf ozmixm 1 - - - +state real mth06 iqjf ozmixm 1 - - - +state real mth07 iqjf ozmixm 1 - - - +state real mth08 iqjf ozmixm 1 - - - +state real mth09 iqjf ozmixm 1 - - - +state real mth10 iqjf ozmixm 1 - - - +state real mth11 iqjf ozmixm 1 - - - +state real mth12 iqjf ozmixm 1 - - - +state real pin q misc 1 - - "PIN" "PRESSURE LEVEL OF OZONE MIXING RATIO" "millibar" +state real m_ps ij misc 2 - - "m_ps" "PS from MATCH on WRF grids" +state real - idjf aerosolc 2 - - - +state real SUL idjf aerosolc 2 - - "SUL" "SUL aerosol concentration" +state real SSLT idjf aerosolc 2 - - "SSLT" "SSLT aerosol concentration" +state real DUST1 idjf aerosolc 2 - - "DUST1" "DUST1 aerosol concentration" +state real DUST2 idjf aerosolc 2 - - "DUST2" "DUST2 aerosol concentration" +state real DUST3 idjf aerosolc 2 - - "DUST3" "DUST3 aerosol concentration" +state real DUST4 idjf aerosolc 2 - - "DUST4" "DUST4 aerosol concentration" +state real OCPHO idjf aerosolc 2 - - "OCPHO" "OCPHO aerosol concentration" +state real BCPHO idjf aerosolc 2 - - "BCPHO" "BCPHO aerosol concentration" +state real OCPHI idjf aerosolc 2 - - "OCPHI" "OCPHI aerosol concentration" +state real BCPHI idjf aerosolc 2 - - "BCPHI" "BCPHI aerosol concentration" +state real BG idjf aerosolc 2 - - "BG" "BG aerosol concentration" +state real VOLC idjf aerosolc 2 - - "VOLC" "VOLC aerosol concentration" +state real m_hybi d misc 1 - - "m_hybi" "MATCH hybi" + + +# new eta microphpysics State Variables +state real F_ICE_PHY ikj misc 1 - rdu "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - rdu "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - rdu "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" + +state real ccn1 ikj misc 1 - h "ccn1" "CCN concentration at S=0.02%" "#/cm3" +state real ccn2 ikj misc 1 - h "ccn2" "CCN concentration at S=0.05%" "#/cm3" +state real ccn3 ikj misc 1 - h "ccn3" "CCN concentration at S=0.1%" "#/cm3" +state real ccn4 ikj misc 1 - h "ccn4" "CCN concentration at S=0.2%" "#/cm3" +state real ccn5 ikj misc 1 - h "ccn5" "CCN concentration at S=0.5%" "#/cm3" +state real ccn6 ikj misc 1 - h "ccn6" "CCN concentration at S=1.0%" "#/cm3" +state real qndropsource ikj misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" +# cloud water fractional removal rate needed for wet scavenging +state real qlsink ikj misc 1 - rduh "qlsink" "CLOUD WATER SINK" "/S" +state real precr ikj misc 1 - rduh "precr" "RAIN PRECIPITATION RATE" "KG/M2/S" +state real preci ikj misc 1 - rduh "preci" "ICE PRECIPITATION RATE" "KG/M2/S" +state real precs ikj misc 1 - rduh "precs" "SNOW PRECIPITATION RATE" "KG/M2/S" +state real precg ikj misc 1 - rduh "precg" "GRAUPEL PRECIPITATION RATE" "KG/M2/S" + +# Other Misc State Variables +state real h_diabatic ikj misc 1 - r "h_diabatic" "PREVIOUS TIMESTEP CONDENSATIONAL HEATING" "" +state real msft ij misc 1 - i012rhdu=(copy_fcnm) "MAPFAC_M" "Map scale factor on mass grid" "" +state real msfu ij misc 1 X i012rhdu=(copy_fcnm) "MAPFAC_U" "Map scale factor on u-grid" "" +state real msfv ij misc 1 Y i012rhdu=(copy_fcnm) "MAPFAC_V" "Map scale factor on v-grid" "" +state real f ij misc 1 - i012rhdu=(copy_fcnm) "f" "Coriolis sine latitude term" "s-1" +state real e ij misc 1 - i012rhdu=(copy_fcnm) "e" "Coriolis cosine latitude term" "s-1" +state real sina ij misc 1 - i012rhdu=(copy_fcnm) "SINALPHA" "Local sine of map rotation" "" +state real cosa ij misc 1 - i012rhdu=(copy_fcnm) "COSALPHA" "Local cosine of map rotation" "" +state real ht ij misc 1 - i012rhdus "HGT" "Terrain Height" "m" +state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" +state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" +state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" + +state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" +state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" +state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" +state real v_base k misc 1 - ir "v_base" "BASE STATE Y WIND IN IDEALIZED CASES" "" +state real qv_base k misc 1 - ir "qv_base" "BASE STATE QV IN IDEALIZED CASES" "" +state real z_base k misc 1 - ir "z_base" "BASE STATE HEIGHT IN IDEALIZED CASES" "" +state real u_frame - misc 1 - ir "u_frame" "FRAME X WIND" "m s-1" +state real v_frame - misc 1 - ir "v_frame" "FRAME Y WIND" "m s-1" +# p_top appears as metadata between SI and real but as a state variable in real and WRF +# since it is a scalar and a constant, it makes sense to have it as metadata -- there +# are, however, probably post-processing programs that expect to see it as an I/O record +# another problem: share/input_wrf tries to read this as metadata (fine for real reading +# SI, but with model reading real output, it generates a warning when debug is > 0 in +# namelist and causes repeated questions from users. A third problem is the potential +# collision between a metadata name and a field record in the I/O data +# resolve this how? Have the real program throw a switch to tell the code to get it +# from the metadata? Otherwise it's a field? +state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state real lat_ll_t - dyn_em - - irh "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - irh "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - irh "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - irh "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - irh "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - irh "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - irh "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - irh "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - irh "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - irh "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - irh "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - irh "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - irh "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - irh "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - irh "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - irh "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - irh "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - irh "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - irh "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - irh "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - irh "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - irh "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - irh "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - irh "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - irh "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - irh "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - irh "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - irh "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - irh "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - irh "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - irh "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - irh "lon_lr_d" "longitude lower right, massless point" "degrees" + +# Other physics variables + +state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME" "Pa K s-1" +state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQICUTEN ikj misc 1 - r "RQICUTEN" "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real W0AVG ikj misc 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" + +state real RAINC ij misc 1 - rhdu "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" +state real RAINNC ij misc 1 - rhdu "RAINNC" "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" "mm" +state real RAINCV ij misc 1 - rh "RAINCV" "TIME-STEP CUMULUS PRECIPITATION" "mm" +state real RAINNCV ij misc 1 - r "RAINNCV" "TIME-STEP NONCONVECTIVE PRECIPITATION" "mm" +state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" +state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" +state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" +state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" +state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" +state real apr_gr ij misc 1 - rh "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" +state real apr_w ij misc 1 - rh "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" +state real apr_mc ij misc 1 - rh "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" +state real apr_st ij misc 1 - rh "APR_ST" "PRECIP FROM CLOSURE STABILITY" "mm hour-1" +state real apr_as ij misc 1 - rh "APR_AS" "PRECIP FROM CLOSURE AS-TYPE" "mm hour-1" +state real apr_capma ij misc 1 - rh "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" +state real apr_capme ij misc 1 - rh "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" +state real apr_capmi ij misc 1 - rh "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" +state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" +# +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K s-1" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg s-1" + +state integer STEPCU - misc 1 - r "STEPCU" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS" "" + +state real RTHRATEN ikj misc 1 - r "RTHRATEN" "COUPLED THETA TENDENCY DUE TO RADIATION" "Pa K s-1" +state real RTHRATENLW ikj misc 1 - r "RTHRATLW" "COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION" "Pa K s-1" +state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "Pa K s-1" +state real CLDFRA ikj misc 1 - rh "CLDFRA" "CLOUD FRACTION" "" + +state real SWDOWN ij misc 1 - rh "SWDOWN" "DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GSW ij misc 1 - rh "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW ij misc 1 - rh "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" + +# upward and downward clearsky and total diagnostic fluxes for CAM radiation +#state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" + +state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" +state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" +state real OLR ij misc 1 - rh "OLR" "TOA OUTGOING LONG WAVE" "W m-2" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real ALBEDO ij misc 1 - rh "ALBEDO" "ALBEDO" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "" +state real EMISS ij misc 1 - r "EMISS" "SURFACE EMISSIVITY" "" + +state real CLDEFI ij misc 1 - r "CLDEFI" "precipitation efficiency in BMJ SCHEME" "" +state integer STEPRA - misc 1 - r "STEPRA" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS" "" + +state real RUBLTEN ikj misc 1 - r "RUBLTEN" "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RVBLTEN ikj misc 1 - r "RVBLTEN" "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION" "Pa K s-1" +state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" + +# State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because they are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - r +state integer landuse_lucats - misc - - r +state integer landuse_luseas - misc - - r +state integer landuse_isn - misc - - r +state real lu_state p misc - - r + +i1 real th_phy ikj misc 1 - +i1 real pi_phy ikj misc 1 - +i1 real p_phy ikj misc 1 - +i1 real t_phy ikj misc 1 - +i1 real u_phy ikj misc 1 - +i1 real v_phy ikj misc 1 - +i1 real dz8w ikj misc 1 Z +i1 real p8w ikj misc 1 Z +i1 real t8w ikj misc 1 Z +i1 real rho_phy ikj misc 1 - +i1 logical CU_ACT_FLAG ij misc 1 - + + +state real TMN ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" +state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real UST ij misc 1 - r "UST" "U* IN SIMILARITY THEORY" "m s-1" +i1 real HOL ij misc 1 - - "HOL" "PBL HEIGHT OVER MONIN-OBUKHOV LENGTH" "" +state real RMOL ij misc 1 - r "RMOL" "1./Monin Ob. Length" "" +state real MOL ij misc 1 - r "MOL" "T* IN SIMILARITY THEORY" "K" +state real PBLH ij misc 1 - rh "PBLH" "PBL HEIGHT" "m" +state real CAPG ij misc 1 - r "CAPG" "HEAT CAPACITY FOR SOIL" "J K-1 m-3" +state real THC ij misc 1 - r "THC" "THERMAL INERTIA" "Cal cm-1 K-1 s-0.5" +state real HFX ij misc 1 - rh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX ij misc 1 - rh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real LH ij misc 1 - rh "LH" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +i1 real REGIME ij misc 1 - +state real SNOWC ij misc 1 - ird=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" + +state real tkesfcf ij misc 1 - r "tkesfcf" "TKE AT THE SURFACE" "m2 s-2" + +state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" +state real taucldi ikj misc 1 - rh "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" +state real taucldc ikj misc 1 - rh "TAUCLDC" "CLOUD OPTICAL THICKNESS FOR WATER" "" + +state real defor11 ikj misc 1 - r "defor11" "DEFORMATION 11" "s-1" +state real defor22 ikj misc 1 - r "defor22" "DEFORMATION 22" "s-1" +state real defor12 ikj misc 1 - r "defor12" "DEFORMATION 12" "s-1" +state real defor33 ikj misc 1 z r "defor33" "DEFORMATION 33" "s-1" +state real defor13 ikj misc 1 z r "defor13" "DEFORMATION 13" "s-1" +state real defor23 ikj misc 1 z r "defor23" "DEFORMATION 23" "s-1" +state real xkmv ikj misc 1 - r "xkmv" "VERTICAL EDDY VISCOSITY" "m2 s-1" +state real xkmh ikj misc 1 - r "xkmh" "HORIZONTAL EDDY VISCOSITY" "m2 s-1" +state real xkmhd ikj misc 1 - r "xkmhd" "HORIZONTAL EDDY DIFFUSIVITY" "m2 s-1" +state real xkhv ikj misc 1 - r "xkhv" "VERTICAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real xkhh ikj misc 1 - r "xkhh" "HORIZONTAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real div ikj misc 1 - r "div" "DIVERGENCE" "s-1" +state real BN2 ikj misc 1 - r "BN2" "BRUNT-VAISALA FREQUENCY" "s-2" +state logical warm_rain - misc 1 - - "warm_rain" "WARM_RAIN_LOGICAL" +state logical adv_moist_cond - misc 1 - - "adv_moist_cond" "ADVECT MOIST CONDENSATES LOGICAL" + +## FDDA variables + +state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" +state real - ikjf fdda3d 1 - - - +state real U_NDG_NEW ikjf fdda3d 1 X i4r "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_NEW ikjf fdda3d 1 Y i4r "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_NEW ikjf fdda3d 1 - i4r "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_NEW ikjf fdda3d 1 - i4r "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_NEW ikjf fdda3d 1 Z i4r "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real U_NDG_OLD ikjf fdda3d 1 X i4r "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_OLD ikjf fdda3d 1 Y i4r "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_OLD ikjf fdda3d 1 - i4r "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_OLD ikjf fdda3d 1 - i4r "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_OLD ikjf fdda3d 1 Z i4r "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real - ivjf fdda2d 1 Z - - +state real MU_NDG_NEW ivjf fdda2d 1 Z i4r "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state real MU_NDG_OLD ivjf fdda2d 1 Z i4r "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" + +# flag for nest movement +state logical moved - misc 1 - - + +# special cam radiation restart arrays +state real abstot ikcj misc 1 Z - "" "" " " +state real absnxt ikaj misc 1 - - "" "" " " +state real emstot ikj misc 1 Z - "" "" " " + +# model diagnostics +state real dpsdt ij misc 1 - - "dpsdt" "surface pressure tendency" "Pa/sec" +state real dmudt ij misc 1 - - "dmudt" "mu tendency" "Pa/sec" +state real pk1m ij misc 1 - - "pk1m" "surface pressure at previous step" "Pa" +state real mu_2m ij misc 1 - - "mu_2m" "mu_2 at previous step" "Pa" +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" +rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" +rconfig character rsmas_data_path namelist,time_control 1 "." - "rsmas_data_path" "" "" + +include registry.io_boilerplate + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" + +rconfig integer diag_print namelist,time_control 1 0 - "print out time series of model diagnostics" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer num_metgrid_levels namelist,domains 1 27 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig integer interp_type namelist,domains 1 1 irh "interp_type" "" "" +rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" +rconfig integer t_extrap_type namelist,domains 1 1 irh "t_extrap_type" "1= use 2 lowest levels, 2=constant, 3 = 6.5 K/km" "" +rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. irh "lowest_lev_from_sfc" "" "" +rconfig integer lagrange_order namelist,domains 1 1 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer force_sfc_in_vinterp namelist,domains 1 1 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" +rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "afcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" +rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 rh "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 rh "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig integer blend_width namelist,domains 1 5 h "blend_width" "width of cg fg terrain blended zone" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer max_vortex_speed namelist,domains max_domains 40 - "" "" "meters per second" +rconfig integer corral_dist namelist,domains max_domains 8 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real max_dz namelist,domains 1 1000. + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig real naer namelist,physics max_domains 1e9 rh "NAER" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer num_months namelist,physics 1 12 irh "num_months" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" +rconfig integer co2tf namelist,physics 1 1 - "co2tf" "GFDL radiation co2 flag" "" +rconfig integer ra_call_offset namelist,physics 1 0 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +#FDDA namelist parameters +rconfig real FGDT namelist,fdda max_domains 0 h "FGDT" "" "" +rconfig integer grid_fdda namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real guv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gt namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gq namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real dtramp_min namelist,fdda 1 0 h "grid_fdda" "" "" +rconfig integer if_ramping namelist,fdda 1 0 h "grid_fdda" "" "" + +#Observational Nudging +rconfig integer obs_nudge_opt namelist,fdda max_domains 0 rh "obs_nudge_opt" "Obs-nudging flag for domain" "" +rconfig integer max_obs namelist,fdda 1 0 h "max_obs" "Maximum number of observations" "" +rconfig integer nobs_ndg_vars namelist,fdda 1 5 h "num_ndg_vars" "Number of nudging variables" "" +rconfig integer nobs_err_flds namelist,fdda 1 9 h "num_err_flds" "Number of error fields" "" +rconfig real fdda_start namelist,fdda max_domains 0 rh "fdda_start" "Nudging start time for domain" "min" +rconfig real fdda_end namelist,fdda max_domains 0 rh "fdda_end" "Nudging end time for domain" "min" +rconfig integer obs_nudge_wind namelist,fdda max_domains 0 rh "obs_nudge_wind" "Wind-nudging flag for domain" "" +rconfig real obs_coef_wind namelist,fdda max_domains 0 rh "obs_coef_wind" "Wind-nudging coeficient for domain" "s-1" +rconfig integer obs_nudge_temp namelist,fdda max_domains 0 rh "obs_nudge_temp" "Temperature-nudging flag for domain" "" +rconfig real obs_coef_temp namelist,fdda max_domains 0 rh "obs_coef_temp" "Temperature-nudging coef for domain" "s-1" +rconfig integer obs_nudge_mois namelist,fdda max_domains 0 rh "obs_nudge_mois" "Moisture-nudging flag for domain" "" +rconfig real obs_coef_mois namelist,fdda max_domains 0 rh "obs_coef_mois" "Moisture-nudging coef for domain" "s-1" +rconfig integer obs_nudge_pstr namelist,fdda max_domains 0 rh "obs_nudge_pstr" "Not used" "" +rconfig real obs_coef_pstr namelist,fdda max_domains 0 rh "obs_coef_pstr" "Not used" "" +rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" +rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" +rconfig real obs_twindo namelist,fdda 1 0 h "obs_twindo" "Half-period time window for nudging" "min" +rconfig integer obs_npfi namelist,fdda 1 0 h "obs_npfi" "Freq in cg timesteps for diag print" "" +rconfig integer obs_ionf namelist,fdda 1 0 h "obs_ionf" "Freq in cg timesteps for obs input and error calc" "" +rconfig integer obs_idynin namelist,fdda 1 0 h "obs_idynin" "Flag for dynamic initialization" "" +rconfig real obs_dtramp namelist,fdda 1 0 h "obs_dtramp" "Time period for ramping (idynin)" "min" +rconfig logical obs_ipf_in4dob namelist,fdda 1 .false. h "obs_ipf_in4dob" "Print obs input diagnostics" "min" +rconfig logical obs_ipf_errob namelist,fdda 1 .false. h "obs_ipf_errob" "Print obs error diagnostics" "min" +rconfig logical obs_ipf_nudob namelist,fdda 1 .false. h "obs_ipf_nudob" "Print obs nudge diagnostics" "min" + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 2 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real diff_6th_factor namelist,dynamics max_domains 0.12 h "diff_6th_factor" "factor that controls rate of 6th-order numerical diffusion" +rconfig integer diff_6th_opt namelist,dynamics max_domains 0 irh "diff_6th_opt" "switch for 6th-order numerical diffusion" +rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0.01 h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 0 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 5 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical pd_moist namelist,dynamics max_domains .false. rh "pd_moist" "positive-definite RK3 transport switch" "" +rconfig logical pd_chem namelist,dynamics max_domains .false. rh "pd_chem" "positive-definite RK3 transport switch" "" +rconfig logical pd_scalar namelist,dynamics max_domains .false. rh "pd_scalar" "positive-definite RK3 transport switch" "" +rconfig logical pd_tke namelist,dynamics max_domains .false. rh "pd_tke" "positive-definite RK3 transport switch" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 1000. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "dimensionless" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "K m s-1" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical mix_full_fields namelist,dynamics max_domains .false. irh "mix_full_field" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" +# +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig real emifrq derived max_domains 0 - "emifrq" "chem emissions input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# Package Declarations +# + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_em dyn_opt==2 - - + +# chemistry packages deinfed in include file !!!! +# +package noprogn progn==0 - - +package progndrop progn==1 - scalar:qndrop +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qi,qs,qg;scalar:qt +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +#--------------------------------------------------------------------------------------------------------------------------------------- +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# Halo Update Communications + +halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 +halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb +halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb +halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msft,msfu,msfv,f,e,sina,cosa,ht,potevp,snopcx,soiltb +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb +halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut +halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 +halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten +halo HALO_EM_FDDA dyn_em 4:rundgdten,rvndgdten +halo HALO_EM_PHYS_DIFFUSION dyn_em 4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,xkmhd,xkhv,xkhh,tke_1,tke_2 +halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 +halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 +halo HALO_EM_TKE_A dyn_em 4:ph_2,phb +halo HALO_EM_TKE_B dyn_em 4:z,rdz,rdzw,zx,zy +halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw +halo HALO_EM_TKE_D dyn_em 8:defor11,defor22,defor33,defor12,defor13,defor23,div +halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkmhd,xkhv,xkhh,BN2,moist +halo HALO_EM_TKE_3 dyn_em 24:tke_1,tke_2 +halo HALO_EM_TKE_5 dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_7 dyn_em 80:tke_1,tke_2 +halo HALO_EM_TKE_F dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_OLD_E_5 dyn_em 48:tke_1 +halo HALO_EM_TKE_OLD_E_7 dyn_em 80:tke_1 +halo HALO_EM_B dyn_em 4:ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend +halo HALO_EM_C dyn_em 4:u_2,v_2 +halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf +halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_MOIST_E_3 dyn_em 24:moist +halo HALO_EM_MOIST_E_5 dyn_em 48:moist +halo HALO_EM_MOIST_E_7 dyn_em 80:moist +halo HALO_EM_CHEM_E_3 dyn_em 24:chem +halo HALO_EM_CHEM_E_5 dyn_em 48:chem +halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar +halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar +halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar + +halo HALO_EM_MOIST_OLD_E_3 dyn_em 24:moist_old +halo HALO_EM_MOIST_OLD_E_5 dyn_em 48:moist_old +halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old +halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old +halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old +halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old +halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old +halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old + +halo HALO_EM_FEEDBACK dyn_em 48:ht + +halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 +period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 +halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar +period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar + +# For moving nests +halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 +halo em_shift_halo_x dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 + +# For observational nudging +halo HALO_OBS_NUDGE dyn_em 24:pb,p,uratx,vratx,tratx + +# Periodic Boundary Communications + +period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,t_init,phb,ph0,php,pb,al,alt,alb,mu_1,mu_2,mub,mu0,ht,msft,msfu,msfv,sina,cosa,e,f +period PERIOD_BDY_EM_MOIST dyn_em 3:moist +period PERIOD_BDY_EM_CHEM dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR dyn_em 3:scalar +period PERIOD_BDY_EM_MOIST2 dyn_em 3:moist +period PERIOD_BDY_EM_CHEM2 dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR2 dyn_em 3:scalar +period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al +period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy +period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,xkmh,xkmhd,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2 +period PERIOD_BDY_EM_FDDA_BC dyn_em 2:rundgdten,rvndgdten +period PERIOD_BDY_EM_B dyn_em 2:ru_tend,rv_tend,ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +period PERIOD_BDY_EM_B3 dyn_em 2:ph_2,al,p,mu_2,muts,mudf +period PERIOD_BDY_EM_B2 dyn_em 2:ru_tend,rv_tend +period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfv,muu,msfu +period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 +period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 + +## + +# FDDA (Observational-nudging) Variables +typedef fdob_type integer domain_tot # total number of domains to apply obs-nudging +typedef fdob_type integer domain_init # domain initialization flag +typedef fdob_type integer IEODI # end of obs data flag for current model step +typedef fdob_type integer IWTSIG # flag for nudging on pressure surfaces +typedef fdob_type integer NSTAT # number of obs stations used to nudge current model step +typedef fdob_type integer KTAUR # restart model step +typedef fdob_type integer SN_MAXCG # coarse domain grid dimension in south-north coordinate +typedef fdob_type integer WE_MAXCG # coarse domain grid dimension in west-east coordinate +typedef fdob_type integer SN_END # ending north-south grid index +typedef fdob_type integer LEVIDN(max_domains) # level of nest +typedef fdob_type real DS_CG # coarse domain grid size +typedef fdob_type real WINDOW # time window half-period for nudging (in minutes) +typedef fdob_type real RTLAST # time in hours of last obs used in current model step +typedef fdob_type real DATEND # time in minutes after which data are asuumed to have ended +typedef fdob_type real RINFMN # minimum radius of influence +typedef fdob_type real RINFMX # maximum radius of influence +typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small +typedef fdob_type real DCON # 1/DPSMX +typedef fdob_type real DPSMX # max pres change (cb) allowed within infl range of surf obs +typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization +typedef fdob_type real XN # cone factor for Lambert projection + +# table entries are of the form +#
+#Grid variables +typedef fdob_type real varobs rz - 1 - - "varobs" "observational values in each variable" +typedef fdob_type real errf hz - 1 - - "errf" "errors between model and obs values" +typedef fdob_type real timeob z - 1 - - "timeob" "model times for each observation" "hours" +typedef fdob_type real nlevs_ob z - 1 - - "nlevs_ob" "numbers of levels in sounding obs" +typedef fdob_type real lev_in_ob z - 1 - - "lev_in_ob" "level in sounding-type obs" +typedef fdob_type real plfo z - 1 - - "plfo" "index for type of obs-platform" +typedef fdob_type real elevob z - 1 - - "elevob" "elevation of observation" "meters" +typedef fdob_type real rio z - 1 - - "rio" "west-east grid coordinate" +typedef fdob_type real rjo z - 1 - - "rjo" "south-north grid coordinate" +typedef fdob_type real rko z - 1 - - "rko" "vertical grid coordinate" + +state fdob_type fdob - - +## diff --git a/wrfv2_fire/Registry/Registry.EM_SST b/wrfv2_fire/Registry/Registry.EM_SST new file mode 100644 index 00000000..8b24590e --- /dev/null +++ b/wrfv2_fire/Registry/Registry.EM_SST @@ -0,0 +1,1371 @@ +# Registry file, EM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +# Available characters for dimspec: 0123456789@%+=|?.!&[{}] + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec e 3 namelist=ensdim z ensemble dimension +dimspec z - namelist=max_obs c max_obs +dimspec h - namelist=nobs_err_flds c nobs_err_flds +dimspec r - namelist=nobs_ndg_vars c nobs_ndg_vars +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec q 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev +dimspec v - constant=1 z one + + +################################################################################ +################################################################################ +################################################################################ + +#state real floob ikjb dyn_em 1 - +#state real floob_x ikjx dyn_em 1 - +#state real floob_y ikjy dyn_em 1 - +#xpose FLOOB dyn_em floob,floob_x,floob_y + +#state real xxx ijk misc 2 - h6ud +#halo HALO_FLOOB dyn_em 4:xxx_2 + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# table entries are of the form +#
+# + +# It is required that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# this next 1 is for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" + +# +# Variables from WPS +# +state real u_gc igj dyn_em 1 XZ i1 "UU" "x-wind component" "m s-1" +state real v_gc igj dyn_em 1 YZ i1 "VV" "y-wind component" "m s-1" +state real t_gc igj dyn_em 1 Z i1 "TT" "temperature" "K" +state real rh_gc igj dyn_em 1 Z i1 "RH" "relative humidity" "%" +state real ght_gc igj dyn_em 1 Z i1 "GHT" "geopotential height" "m" +state real p_gc igj dyn_em 1 Z i1 "PRES" "pressure" "Pa" +state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" +state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" +state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" +state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" +state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real pslv_gc ij dyn_em 1 - i1 "PMSL" "sea level pressure" "Pa" +state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" +state real psfc_gc ij dyn_em 1 - - "PSFC_GC" "surface pressure" "Pa" +state real intq_gc ij dyn_em 1 - - "INTQ" "integrated mixing ratio" "Pa" +state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" +state real qv_gc igj dyn_em 1 Z i1 "QV" "mixing ratio" "kg kg-1" +#state real qr_gc igj dyn_em 1 Z i1 "QR" "rain water mixing ratio" "kg kg-1" +#state real qc_gc igj dyn_em 1 Z i1 "QC" "cloud water mixing ratio" "kg kg-1" +#state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" +#state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" +#state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# +# Variables for Eulerian mass coordinate dynamics +# + + +# Velocities +# +# U Vel +state real u ikjb dyn_em 2 X \ + i01rhusdf=(bdy_interp:dt) "U" "x-wind component" "m s-1" +state real ru ikj dyn_em 1 X - "MU_U" "mu-coupled u" "Pa m s-1" +state real ru_m ikj dyn_em 1 X - "ru_m" "" "" +state real ru_tend ikj dyn_em 1 X - "ru_tend" "" "" +i1 real ru_tendf ikj dyn_em 1 X +state real u_save ikj dyn_em 1 X - "u_save" +# +# V Vel +state real v ikjb dyn_em 2 Y \ + i01rhusdf=(bdy_interp:dt) "V" "y-wind component" "m s-1" +state real rv ikj dyn_em 1 Y - "MU_V" "mu-coupled v" "Pa m s-1" +state real rv_m ikj dyn_em 1 Y - "rv_m" +state real rv_tend ikj dyn_em 1 Y - "rv_tend" +i1 real rv_tendf ikj dyn_em 1 Y +state real v_save ikj dyn_em 1 Y - "v_save" +# +# Vertical Vel +state real w ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "w" "z-wind component" "m s-1" +state real ww ikj dyn_em 1 Z r "ww" "mu-coupled eta-dot" "Pa s-1" +state real rw ikj dyn_em 1 Z - "rw" "mu-coupled w" "Pa m s-1" +i1 real ww1 ikj dyn_em 1 Z +state real ww_m ikj dyn_em 1 Z r "ww_m" "time-avg mu-coupled eta-dot" "Pa s-1" +i1 real wwp ikj dyn_em 1 Z +i1 real rw_tend ikj dyn_em 1 Z +i1 real rw_tendf ikj dyn_em 1 Z +i1 real w_save ikj dyn_em 1 Z + +# Geopotential +state real ph ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "ph" "perturbation geopotential" "m2 s-2" +state real phb ikj dyn_em 1 Z irhdus "phb" "base-state geopotential" "m2 s-2" +state real phb_fine ikj dyn_em 1 Z - "phb_fine" "for nesting, temp holding interpolated coarse grid phb" "m2 s-2" +state real ph0 ikj dyn_em 1 Z r "ph0" "initial geopotential" "m2 s-2" +state real php ikj dyn_em 1 Z r "php" "geopotential" "m2 s-2" +i1 real ph_tend ikj dyn_em 1 Z +i1 real ph_tendf ikj dyn_em 1 Z +i1 real ph_save ikj dyn_em 1 Z + +# Potential Temperature +state real t ikjb dyn_em 2 - \ + i01rhusdf=(bdy_interp:dt) "t" "perturbation potential temperature (theta-t0)" "K" + +state real t_init ikj dyn_em 1 - ir "t_init" "initial potential temperature" "K" +i1 real t_tend ikj dyn_em 1 - +i1 real t_tendf ikj dyn_em 1 - +state real tp ikj dyn_em 2 - +i1 real t_2save ikj dyn_em 1 - +state real t_save ikj dyn_em 1 - "t_save" +# + + +# Mass +state real mu ijb dyn_em 2 - \ + irhusdf=(bdy_interp:dt) "mu" "perturbation dry air mass in column" "Pa" +state real mub ij dyn_em 1 - irhdus "mub" "base state dry air mass in column" "Pa" +state real mub_fine ij dyn_em 1 - - "mub_fine" "nest temp, holds interpolated coarse grid mub" "Pa" +state real mu0 ij dyn_em 1 - i01rdu "mu0" "initial dry mass in column" "Pa" +state real mudf ij dyn_em 1 - - "mudf" "" "" +state real muu ij dyn_em 1 - "muu" +i1 real muus ij dyn_em 1 - +state real muv ij dyn_em 1 - "muv" +i1 real muvs ij dyn_em 1 - +state real mut ij dyn_em 1 - "mut" +state real muts ij dyn_em 1 - "muts" +i1 real muave ij dyn_em 1 - +i1 real mu_save ij dyn_em 1 - +i1 real mu_tend ij dyn_em 1 - +i1 real mu_tendf ij dyn_em 1 - + +#diagnostic for looking at nest position in output. A mungy version of terrain height. +state real nest_pos ij misc 1 - rhu=(mark_domain) "NEST_POS" +state real nest_mask ij misc 1 - ru=(mark_domain) "NEST_MASK" "LOCATION OF NEST IF ANY" +state real ht_coarse ij misc 1 - r - "STORAGE FOR LOW-RES TERRAIN" + + +# TKE +state real tke ikj dyn_em 2 - r "tke" "TURBULENCE KINETIC ENERGY" "m2 s-2" +i1 real tke_tend ikj dyn_em 1 - + +# Pressure and Density +state real p ikj dyn_em 1 - rh "p" "perturbation pressure" "Pa" +state real al ikj dyn_em 1 - r "al" "inverse perturbation density" "m3 kg-1" +state real alt ikj dyn_em 1 - r "alt" "inverse density" "m3 kg-1" +state real alb ikj dyn_em 1 - rdus "alb" "inverse base density" "m3 kg-1" +state real zx ikj dyn_em 1 X - " " " " " " +state real zy ikj dyn_em 1 Y - " " " " " " +state real rdz ikj dyn_em 1 Z - " " " " " " +state real rdzw ikj dyn_em 1 Z - " " " " " " +state real pb ikj dyn_em 1 - rhdus "pb" "BASE STATE PRESSURE " "Pa" + +# +# Other dyn +# +i1 real advect_tend ikj dyn_em 1 - +i1 real alpha ikj dyn_em 1 - +i1 real a ikj dyn_em 1 - +i1 real gamma ikj dyn_em 1 - +i1 real c2a ikj dyn_em 1 - - +i1 real rho ikj dyn_em 1 - - +i1 real phm ikj dyn_em 1 - - +i1 real cqu ikj dyn_em 1 - - +i1 real cqv ikj dyn_em 1 - - +i1 real cqw ikj dyn_em 1 - - +i1 real pm1 ikj dyn_em 1 - - +state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" +state real potevp ij dyn_em 1 - h "potevp" "whatever" +state real snopcx ij dyn_em 1 - h "snopcx" "whatever" +state real soiltb ij dyn_em 1 - h "soiltb" "whatever" +state real fnm k dyn_em 1 - irh "fnm" "upper weight for vertical stretching" "" +state real fnp k dyn_em 1 - irh "fnp" "lower weight for vertical stretching" "" +state real rdnw k dyn_em 1 - irh "rdnw" "inverse d(eta) values between full (w) levels" "" +state real rdn k dyn_em 1 - irh "rdn" "inverse d(eta) values between half (mass) levels" "" +state real dnw k dyn_em 1 - irh "dnw" "d(eta) values between full (w) levels" "" +state real dn k dyn_em 1 - irh "dn " "d(eta) values between half (mass) levels" "" +state real znu k dyn_em 1 - irh "znu" "eta values on half (mass) levels" "" +state real znw k dyn_em 1 Z i01rh "znw" "eta values on full (w) levels" "" +state real t_base k dyn_em 1 - ir "t_base" "BASE STATET T IN IDEALIZED CASES" "K" +state real z ikj dyn_em 1 - - " " " " " " +i1 real mu_3d ikj dyn_em 1 - +i1 real z_at_w ikj dyn_em 1 Z +state real cfn - misc - - irh "cfn" "extrapolation constant" "" +state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" +state integer step_number - misc - - ir "step_number" "" + +# 2m and 10m output diagnostics +state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" +state real TH2 ij misc 1 - irhd "TH2" "POT TEMP at 2 M" "K" +state real PSFC ij misc 1 - i01rh "PSFC" "SFC PRESSURE" "Pa" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real U10 ij misc 1 - irh01d "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - irh01d "V10" "V at 10 M" "m s-1" + +# these next 4 are for observational nudging +state real uratx ij misc 1 - ir "URATX" "Ratio of U over U10 on mass points " "dimensionless" +state real vratx ij misc 1 - ir "VRATX" "Ratio of V over V10 on mass points " "dimensionless" +state real tratx ij misc 1 - ir "TRATX" "Ratio of T over TH2 on mass points " "dimensionless" +state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" + +# Other +state real rdx - misc - - irh "rdx" "INVERSE X GRID LENGTH" "" +state real rdy - misc - - irh "rdy" "INVERSE Y GRID LENGTH" "" +state real dts - misc - - ir "dts" "SMALL TIMESTEP" "" +state real dtseps - misc - - ir "dtseps" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real resm - misc - - irh "resm" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real zetatop - misc - - irh "zetatop" "ZETA AT MODEL TOP" "" +state real cf1 - misc - - irh "cf1" "2nd order extrapolation constant" "" +state real cf2 - misc - - irh "cf2" "2nd order extrapolation constant" "" +state real cf3 - misc - - irh "cf3" "2nd order extrapolation constant" "" +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - rh "itimestep" "" "" +state real xtime - - - - rh "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +# Mask for moving nest interpolations +state integer imask_nostag ij misc 1 - +state integer imask_xstag ij misc 1 X +state integer imask_ystag ij misc 1 Y +state integer imask_xystag ij misc 1 XY +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# Scalar (4D) arrays + +# Moist Scalars +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjftb moist 1 - - - +state real qv ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" + +# Chem Scalars +state real - ikjftb chem 1 - - - + +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qndrop ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" +state real qni ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "CWM" "Total condensate mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# Arrays for Specified LBCs (lbc arrays REMOVED; Boundary arrays are now specified with the state array; see above, 20050413 JM ) + +state real fcx w misc - - ir "fcx" "RELAXATION TERM FOR BOUNDARY ZONE" "" +state real gcx w misc - - ir "gcx" "2ND RELAXATION TERM FOR BOUNDARY ZONE" "" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" + +#------------------------------------------------------------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------------------------------------------------------------------- +# Physics Related State Varibles + +#------------------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#------------------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010040 ij misc 1 - i1 "SM010040 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm040100 ij misc 1 - i1 "SM040100 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100200 ij misc 1 - i1 "SM100200 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010200 ij misc 1 - i1 "SM010200" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm000 ij misc 1 - i1 "SOILM000" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm005 ij misc 1 - i1 "SOILM005" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm020 ij misc 1 - i1 "SOILM020" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm040 ij misc 1 - i1 "SOILM040" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm160 ij misc 1 - i1 "SOILM160" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm300 ij misc 1 - i1 "SOILM300" "LAYER SOIL MOISTURE" "m3 m-3" +state real sw000010 ij misc 1 - i1 "SW000010" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010040 ij misc 1 - i1 "SW010040" "LAYER SOIL LIQUID" "m3 m-3" +state real sw040100 ij misc 1 - i1 "SW040100" "LAYER SOIL LIQUID" "m3 m-3" +state real sw100200 ij misc 1 - i1 "SW100200" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010200 ij misc 1 - i1 "SW010200" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw000 ij misc 1 - i1 "SOILW000" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw005 ij misc 1 - i1 "SOILW005" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw020 ij misc 1 - i1 "SOILW020" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw040 ij misc 1 - i1 "SOILW040" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw160 ij misc 1 - i1 "SOILW160" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw300 ij misc 1 - i1 "SOILW300" "LAYER SOIL LIQUID" "m3 m-3" +state real st000010 ij misc 1 - i1 "ST000010" "LAYER SOIL TEMPERATURE" "K" +state real st010040 ij misc 1 - i1 "ST010040" "LAYER SOIL TEMPERATURE" "K" +state real st040100 ij misc 1 - i1 "ST040100" "LAYER SOIL TEMPERATURE" "K" +state real st100200 ij misc 1 - i1 "ST100200" "LAYER SOIL TEMPERATURE" "K" +state real st010200 ij misc 1 - i1 "ST010200" "LAYER SOIL TEMPERATURE" "K" +state real soilt000 ij misc 1 - i1 "SOILT000" "LAYER SOIL TEMPERATURE" "K" +state real soilt005 ij misc 1 - i1 "SOILT005" "LAYER SOIL TEMPERATURE" "K" +state real soilt020 ij misc 1 - i1 "SOILT020" "LAYER SOIL TEMPERATURE" "K" +state real soilt040 ij misc 1 - i1 "SOILT040" "LAYER SOIL TEMPERATURE" "K" +state real soilt160 ij misc 1 - i1 "SOILT160" "LAYER SOIL TEMPERATURE" "K" +state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" +# Couple landmask via auxinput5 and auxhist5 for ESMF testing with a "dummy" +# ocean model that reads SSTs from a file. Note that the auxhist part is +# only for self-test -- the dummy ocean model does not read this field. +state real landmask ij misc 1 - i0125rh05d=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" +state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real shdmax ij misc 1 - i012r "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - i012r "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" +state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" +state real landusef iuj misc 1 Z i12 "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i12 "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i1 "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" + +#--------------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#--------------------------------------------------------------------------------------------------------------------------------------- + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim +state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" +state real ZS l misc - Z irh "ZS" "DEPTHS OF CENTERS OF SOIL LAYERS" "m" +state real DZS l misc - Z irh "DZS" "THICKNESSES OF SOIL LAYERS" "m" + +# urban model variables +state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" +state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" +state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" + +# lsm State Variables + +state real SMOIS ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" +state real SH2O ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" +state real XICE ij misc 1 - i012rhd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "XICE" "SEA ICE FLAG" "" +state real SMSTAV ij misc 1 - rd=(interp_mask_land_field:lu_index) "SMSTAV" "MOISTURE AVAILABILITY" "" +state real SMSTOT ij misc 1 - r "SMSTOT" "TOTAL SOIL MOISTURE" "m3 m-3" + +state real SFCRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "SFROFF" "SURFACE RUNOFF" "mm" +state real UDRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "UDROFF" "UNDERGROUND RUNOFF" "mm" +state integer IVGTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "IVGTYP" "DOMINANT VEGETATION CATEGORY" "" +state integer ISLTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" +state real VEGFRA ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - r "SFCEVP" "SURFACE EVAPORATION" "kg m-2" +state real GRDFLX ij misc 1 - rh "GRDFLX" "GROUND HEAT FLUX" "W m-2" +state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" + +state real ACSNOW ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real SNOW ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real CANWAT ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" +# Couple SST via auxinput5 and auxhist5 for ESMF testing with a "dummy" +# ocean model that reads SSTs from a file. Note that the auxhist part is only +# for self-test -- the dummy ocean model does not read this field. +state real SST ij misc 1 - i0125rh05d=(interp_mask_water_field:lu_index) "SST" "SEA SURFACE TEMPERATURE" "K" +state integer IFNDSNOWH - misc 1 - i "FNDSNOWH" "SNOWH_LOGICAL" +state integer IFNDSOILW - misc 1 - i "FNDSOILW" "SOILW_LOGICAL" + +# urban state variables +state real TR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" +state real TG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" +state real TC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" +state real QC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" +state real UC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" +state real XXXR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" +state real XXXB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" +state real XXXG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" +state real XXXC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" +state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" +state real RN_URB2D ij misc 1 - r "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" +state real TS_URB2D ij misc 1 - r "TS_URB" "SKIN TEMPERATURE" "K" +state real FRC_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "FRC_URB" "URBAN FRACTION" "dimensionless" +state integer UTYPE_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "UTYPE_URB" "URBAN TYPE" "dimensionless" + + +# urban variables from radiation model +state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" +state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" + + +# RUC LSM +state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# MRF PBL variables +i1 real PSIM ij misc 1 - - "PSIM" "SIMILARITY FUNCTION FOR MOMENTUM" "" +i1 real PSIH ij misc 1 - - "PSIH" "SIMILARITY FUNCTION FOR HEAT" "" +i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" +i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" +i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" + +# MYJ PBL variables +state real tke_myj ikj misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS " +state real CT ij misc 1 - r "CT" "COUNTERGRADIENT TERM" "K" +state real THZ0 ij misc 1 - r "THZ0" "POTENTIAL TEMPERATURE AT ZNT" "K" +state real Z0 ij misc 1 - r "Z0" "Background ROUGHNESS LENGTH" "m" +state real QZ0 ij misc 1 - r "QZ0" "SPECIFIC HUMIDITY AT ZNT" "kg kg-1" +state real UZ0 ij misc 1 - r "UZ0" "U WIND COMPONENT AT ZNT" "m s-1" +state real VZ0 ij misc 1 - r "VZ0" "V WIND COMPONENT AT ZNT" "m s-1" +state real QSFC ij misc 1 - r "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - r "AKHS" "SFC EXCH COEFF FOR HEAT" "m s-1" +state real AKMS ij misc 1 - r "AKMS" "SFC EXCH COEFF FOR MOMENTUM" "m s-1" +state integer KPBL ij misc 1 - r "KPBL" "LEVEL OF PBL TOP" "" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real PSHLTR ij misc 1 - - "PSHLTR" "SHELTER PRESSURE FROM MYJ" "Pa" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" + +# gfdl (eta) radiation State Variables +state real HTOP ij misc 1 - r "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - r "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - r "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - r "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real CUTOP ij misc 1 - r "CUTOP" "TOP OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state real CUBOT ij misc 1 - r "CUBOT" "BOT OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state REAL CUPPT ij misc 1 - r "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINC LAST CALL TO THE RADIATION" "" +state real rswtoa ij misc 1 - i +state real rlwtoa ij misc 1 - i +state real czmean ij misc 1 - i +state real cfracl ij misc 1 - i +state real cfracm ij misc 1 - i +state real cfrach ij misc 1 - i +state real acfrst ij misc 1 - i +state integer ncfrst ij misc 1 - i +state real acfrcv ij misc 1 - i +state integer ncfrcv ij misc 1 - i + +# cam radiation variables +state real - iqjf ozmixm 1 - - - +state real mth01 iqjf ozmixm 1 - - - +state real mth02 iqjf ozmixm 1 - - - +state real mth03 iqjf ozmixm 1 - - - +state real mth04 iqjf ozmixm 1 - - - +state real mth05 iqjf ozmixm 1 - - - +state real mth06 iqjf ozmixm 1 - - - +state real mth07 iqjf ozmixm 1 - - - +state real mth08 iqjf ozmixm 1 - - - +state real mth09 iqjf ozmixm 1 - - - +state real mth10 iqjf ozmixm 1 - - - +state real mth11 iqjf ozmixm 1 - - - +state real mth12 iqjf ozmixm 1 - - - +state real pin q misc 1 - - "PIN" "PRESSURE LEVEL OF OZONE MIXING RATIO" "millibar" +state real m_ps ij misc 2 - - "m_ps" "PS from MATCH on WRF grids" +state real - idjf aerosolc 2 - - - +state real SUL idjf aerosolc 2 - - "SUL" "SUL aerosol concentration" +state real SSLT idjf aerosolc 2 - - "SSLT" "SSLT aerosol concentration" +state real DUST1 idjf aerosolc 2 - - "DUST1" "DUST1 aerosol concentration" +state real DUST2 idjf aerosolc 2 - - "DUST2" "DUST2 aerosol concentration" +state real DUST3 idjf aerosolc 2 - - "DUST3" "DUST3 aerosol concentration" +state real DUST4 idjf aerosolc 2 - - "DUST4" "DUST4 aerosol concentration" +state real OCPHO idjf aerosolc 2 - - "OCPHO" "OCPHO aerosol concentration" +state real BCPHO idjf aerosolc 2 - - "BCPHO" "BCPHO aerosol concentration" +state real OCPHI idjf aerosolc 2 - - "OCPHI" "OCPHI aerosol concentration" +state real BCPHI idjf aerosolc 2 - - "BCPHI" "BCPHI aerosol concentration" +state real BG idjf aerosolc 2 - - "BG" "BG aerosol concentration" +state real VOLC idjf aerosolc 2 - - "VOLC" "VOLC aerosol concentration" +state real m_hybi d misc 1 - - "m_hybi" "MATCH hybi" + +# new eta microphpysics State Variables +state real F_ICE_PHY ikj misc 1 - rdu "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - rdu "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - rdu "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real qndropsource ikj misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" + +# Other Misc State Variables +state real h_diabatic ikj misc 1 - r "h_diabatic" "PREVIOUS TIMESTEP CONDENSATIONAL HEATING" "" +state real msft ij misc 1 - i012rhdu=(copy_fcnm) "MAPFAC_M" "Map scale factor on mass grid" "" +state real msfu ij misc 1 X i012rhdu=(copy_fcnm) "MAPFAC_U" "Map scale factor on u-grid" "" +state real msfv ij misc 1 Y i012rhdu=(copy_fcnm) "MAPFAC_V" "Map scale factor on v-grid" "" +state real f ij misc 1 - i012rhdu=(copy_fcnm) "f" "Coriolis sine latitude term" "s-1" +state real e ij misc 1 - i012rhdu=(copy_fcnm) "e" "Coriolis cosine latitude term" "s-1" +state real sina ij misc 1 - i012rhdu=(copy_fcnm) "SINALPHA" "Local sine of map rotation" "" +state real cosa ij misc 1 - i012rhdu=(copy_fcnm) "COSALPHA" "Local cosine of map rotation" "" +state real ht ij misc 1 - i012rhdus "HGT" "Terrain Height" "m" +state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" +state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" +state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" + +state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" +state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" +state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" +state real v_base k misc 1 - ir "v_base" "BASE STATE Y WIND IN IDEALIZED CASES" "" +state real qv_base k misc 1 - ir "qv_base" "BASE STATE QV IN IDEALIZED CASES" "" +state real z_base k misc 1 - ir "z_base" "BASE STATE HEIGHT IN IDEALIZED CASES" "" +state real u_frame - misc 1 - ir "u_frame" "FRAME X WIND" "m s-1" +state real v_frame - misc 1 - ir "v_frame" "FRAME Y WIND" "m s-1" +# p_top appears as metadata between SI and real but as a state variable in real and WRF +# since it is a scalar and a constant, it makes sense to have it as metadata -- there +# are, however, probably post-processing programs that expect to see it as an I/O record +# another problem: share/input_wrf tries to read this as metadata (fine for real reading +# SI, but with model reading real output, it generates a warning when debug is > 0 in +# namelist and causes repeated questions from users. A third problem is the potential +# collision between a metadata name and a field record in the I/O data +# resolve this how? Have the real program throw a switch to tell the code to get it +# from the metadata? Otherwise it's a field? +state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state real lat_ll_t - dyn_em - - irh "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - irh "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - irh "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - irh "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - irh "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - irh "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - irh "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - irh "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - irh "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - irh "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - irh "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - irh "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - irh "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - irh "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - irh "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - irh "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - irh "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - irh "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - irh "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - irh "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - irh "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - irh "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - irh "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - irh "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - irh "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - irh "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - irh "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - irh "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - irh "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - irh "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - irh "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - irh "lon_lr_d" "longitude lower right, massless point" "degrees" + +# Other physics variables + +state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME" "Pa K s-1" +state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQICUTEN ikj misc 1 - r "RQICUTEN" "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real W0AVG ikj misc 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" + +state real RAINC ij misc 1 - rhdu "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" +state real RAINNC ij misc 1 - rhdu "RAINNC" "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" "mm" +state real RAINCV ij misc 1 - r "RAINCV" "TIME-STEP CUMULUS PRECIPITATION" "mm" +state real RAINNCV ij misc 1 - r "RAINNCV" "TIME-STEP NONCONVECTIVE PRECIPITATION" "mm" +state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" +state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" +state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" +state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" +state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY" "mm hour-1" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE" "mm hour-1" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K s-1" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg s-1" + +state integer STEPCU - misc 1 - r "STEPCU" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS" "" + +state real RTHRATEN ikj misc 1 - rd "RTHRATEN" "COUPLED THETA TENDENCY DUE TO RADIATION" "Pa K s-1" +state real RTHRATENLW ikj misc 1 - r "RTHRATLW" "COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION" "Pa K s-1" +state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "Pa K s-1" +state real CLDFRA ikj misc 1 - r "CLDFRA" "CLOUD FRACTION" "" + +state real SWDOWN ij misc 1 - rhd "SWDOWN" "DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" + +# upward and downward clearsky and total diagnostic fluxes for CAM radiation +#state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" + +state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" +state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" +state real OLR ij misc 1 - rh "OLR" "TOA OUTGOING LONG WAVE" "W m-2" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real ALBEDO ij misc 1 - rh "ALBEDO" "ALBEDO" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "" +state real EMISS ij misc 1 - r "EMISS" "SURFACE EMISSIVITY" "" + +state real CLDEFI ij misc 1 - r "CLDEFI" "precipitation efficiency in BMJ SCHEME" "" +state integer STEPRA - misc 1 - r "STEPRA" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS" "" + +state real RUBLTEN ikj misc 1 - r "RUBLTEN" "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RVBLTEN ikj misc 1 - r "RVBLTEN" "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION" "Pa K s-1" +state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" + +# State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because they are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - r +state integer landuse_lucats - misc - - r +state integer landuse_luseas - misc - - r +state integer landuse_isn - misc - - r +state real lu_state p misc - - r + +i1 real th_phy ikj misc 1 - +i1 real pi_phy ikj misc 1 - +i1 real p_phy ikj misc 1 - +i1 real t_phy ikj misc 1 - +i1 real u_phy ikj misc 1 - +i1 real v_phy ikj misc 1 - +i1 real dz8w ikj misc 1 Z +i1 real p8w ikj misc 1 Z +i1 real t8w ikj misc 1 Z +i1 real rho_phy ikj misc 1 - +i1 logical CU_ACT_FLAG ij misc 1 - + + +state real TMN ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" +state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real UST ij misc 1 - rh "UST" "U* IN SIMILARITY THEORY" "m s-1" +i1 real HOL ij misc 1 - - "HOL" "PBL HEIGHT OVER MONIN-OBUKHOV LENGTH" "" +state real RMOL ij misc 1 - r "RMOL" "1./Monin Ob. Length" "" +state real MOL ij misc 1 - r "MOL" "T* IN SIMILARITY THEORY" "K" +state real PBLH ij misc 1 - rh "PBLH" "PBL HEIGHT" "m" +state real CAPG ij misc 1 - r "CAPG" "HEAT CAPACITY FOR SOIL" "J K-1 m-3" +state real THC ij misc 1 - r "THC" "THERMAL INERTIA" "Cal cm-1 K-1 s-0.5" +state real HFX ij misc 1 - rh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX ij misc 1 - rh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real LH ij misc 1 - rh "LH" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +i1 real REGIME ij misc 1 - +state real SNOWC ij misc 1 - irhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" + +state real tkesfcf ij misc 1 - r "tkesfcf" "TKE AT THE SURFACE" "m2 s-2" + +state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" +state real taucldi ikj misc 1 - r "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" +state real taucldc ikj misc 1 - r "TAUCLDC" "CLOUD OPTICAL THICKNESS FOR WATER" "" + +state real defor11 ikj misc 1 - r "defor11" "DEFORMATION 11" "s-1" +state real defor22 ikj misc 1 - r "defor22" "DEFORMATION 22" "s-1" +state real defor12 ikj misc 1 - r "defor12" "DEFORMATION 12" "s-1" +state real defor33 ikj misc 1 z r "defor33" "DEFORMATION 33" "s-1" +state real defor13 ikj misc 1 z r "defor13" "DEFORMATION 13" "s-1" +state real defor23 ikj misc 1 z r "defor23" "DEFORMATION 23" "s-1" +state real xkmv ikj misc 1 - r "xkmv" "VERTICAL EDDY VISCOSITY" "m2 s-1" +state real xkmh ikj misc 1 - r "xkmh" "HORIZONTAL EDDY VISCOSITY" "m2 s-1" +state real xkmhd ikj misc 1 - r "xkmhd" "HORIZONTAL EDDY DIFFUSIVITY" "m2 s-1" +state real xkhv ikj misc 1 - r "xkhv" "VERTICAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real xkhh ikj misc 1 - r "xkhh" "HORIZONTAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real div ikj misc 1 - r "div" "DIVERGENCE" "s-1" +state real BN2 ikj misc 1 - r "BN2" "BRUNT-VAISALA FREQUENCY" "s-2" +state logical warm_rain - misc 1 - - "warm_rain" "WARM_RAIN_LOGICAL" +state logical adv_moist_cond - misc 1 - - "adv_moist_cond" "ADVECT MOIST CONDENSATES LOGICAL" + +## FDDA variables + +state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" +state real - ikjf fdda3d 1 - - - +state real U_NDG_NEW ikjf fdda3d 1 X igr "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_NEW ikjf fdda3d 1 Y igr "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_NEW ikjf fdda3d 1 - igr "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_NEW ikjf fdda3d 1 - igr "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_NEW ikjf fdda3d 1 Z igr "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real U_NDG_OLD ikjf fdda3d 1 X igr "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_OLD ikjf fdda3d 1 Y igr "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_OLD ikjf fdda3d 1 - igr "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_OLD ikjf fdda3d 1 - igr "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_OLD ikjf fdda3d 1 Z igr "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real - ivjf fdda2d 1 Z - - +state real MU_NDG_NEW ivjf fdda2d 1 Z igr "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state real MU_NDG_OLD ivjf fdda2d 1 Z igr "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" + + +# flag for nest movement +state logical moved - misc 1 - - + +# special cam radiation restart arrays +state real abstot ikcj misc 1 Z - "" "" " " +state real absnxt ikaj misc 1 - - "" "" " " +state real emstot ikj misc 1 Z - "" "" " " + +# model diagnostics +state real dpsdt ij misc 1 - - "dpsdt" "surface pressure tendency" "Pa/sec" +state real dmudt ij misc 1 - - "dmudt" "mu tendency" "Pa/sec" +state real pk1m ij misc 1 - - "pk1m" "surface pressure at previous step" "Pa" +state real mu_2m ij misc 1 - - "mu_2m" "mu_2 at previous step" "Pa" + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" +rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" +rconfig character rsmas_data_path namelist,time_control 1 "." - "rsmas_data_path" "" "" + +include registry.io_boilerplate + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" + +rconfig integer diag_print namelist,time_control 1 0 - "print out time series of model diagnostics" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer num_metgrid_levels namelist,domains 1 27 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig integer interp_type namelist,domains 1 1 irh "interp_type" "1=interp in pressure, 2=interp in LOG pressure" "" +rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" +rconfig integer t_extrap_type namelist,domains 1 1 irh "t_extrap_type" "1= use 2 lowest levels, 2=constant, 3 = 6.5 K/km" "" +rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. irh "lowest_lev_from_sfc" "" "" +rconfig integer lagrange_order namelist,domains 1 1 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer force_sfc_in_vinterp namelist,domains 1 1 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" +rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "afcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" +rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 rh "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 rh "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig integer blend_width namelist,domains 1 5 h "blend_width" "width of cg fg terrain blended zone" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer max_vortex_speed namelist,domains max_domains 40 - "" "" "meters per second" +rconfig integer corral_dist namelist,domains max_domains 8 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real max_dz namelist,domains 1 1000. + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig real naer namelist,physics max_domains 1e9 rh "NAER" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer num_months namelist,physics 1 12 irh "num_months" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" +rconfig integer co2tf namelist,physics 1 1 - "co2tf" "GFDL radiation co2 flag" "" +rconfig integer ra_call_offset namelist,physics 1 0 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +#FDDA namelist parameters +rconfig real FGDT namelist,fdda max_domains 0 h "FGDT" "" "" +rconfig integer grid_fdda namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real guv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gt namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gq namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real dtramp_min namelist,fdda 1 0 h "grid_fdda" "" "" +rconfig integer if_ramping namelist,fdda 1 0 h "grid_fdda" "" "" + +#Observational Nudging +rconfig integer obs_nudge_opt namelist,fdda max_domains 0 rh "obs_nudge_opt" "Obs-nudging flag for domain" "" +rconfig integer max_obs namelist,fdda 1 0 h "max_obs" "Maximum number of observations" "" +rconfig integer nobs_ndg_vars namelist,fdda 1 5 h "num_ndg_vars" "Number of nudging variables" "" +rconfig integer nobs_err_flds namelist,fdda 1 9 h "num_err_flds" "Number of error fields" "" +rconfig real fdda_start namelist,fdda max_domains 0 rh "fdda_start" "Nudging start time for domain" "min" +rconfig real fdda_end namelist,fdda max_domains 0 rh "fdda_end" "Nudging end time for domain" "min" +rconfig integer obs_nudge_wind namelist,fdda max_domains 0 rh "obs_nudge_wind" "Wind-nudging flag for domain" "" +rconfig real obs_coef_wind namelist,fdda max_domains 0 rh "obs_coef_wind" "Wind-nudging coeficient for domain" "s-1" +rconfig integer obs_nudge_temp namelist,fdda max_domains 0 rh "obs_nudge_temp" "Temperature-nudging flag for domain" "" +rconfig real obs_coef_temp namelist,fdda max_domains 0 rh "obs_coef_temp" "Temperature-nudging coef for domain" "s-1" +rconfig integer obs_nudge_mois namelist,fdda max_domains 0 rh "obs_nudge_mois" "Moisture-nudging flag for domain" "" +rconfig real obs_coef_mois namelist,fdda max_domains 0 rh "obs_coef_mois" "Moisture-nudging coef for domain" "s-1" +rconfig integer obs_nudge_pstr namelist,fdda max_domains 0 rh "obs_nudge_pstr" "Not used" "" +rconfig real obs_coef_pstr namelist,fdda max_domains 0 rh "obs_coef_pstr" "Not used" "" +rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" +rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" +rconfig real obs_twindo namelist,fdda 1 0 h "obs_twindo" "Half-period time window for nudging" "min" +rconfig integer obs_npfi namelist,fdda 1 0 h "obs_npfi" "Freq in cg timesteps for diag print" "" +rconfig integer obs_ionf namelist,fdda 1 0 h "obs_ionf" "Freq in cg timesteps for obs input and error calc" "" +rconfig integer obs_idynin namelist,fdda 1 0 h "obs_idynin" "Flag for dynamic initialization" "" +rconfig real obs_dtramp namelist,fdda 1 0 h "obs_dtramp" "Time period for ramping (idynin)" "min" +rconfig logical obs_ipf_in4dob namelist,fdda 1 .false. h "obs_ipf_in4dob" "Print obs input diagnostics" "min" +rconfig logical obs_ipf_errob namelist,fdda 1 .false. h "obs_ipf_errob" "Print obs error diagnostics" "min" +rconfig logical obs_ipf_nudob namelist,fdda 1 .false. h "obs_ipf_nudob" "Print obs nudge diagnostics" "min" + + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 2 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real diff_6th_factor namelist,dynamics max_domains 0.12 h "diff_6th_factor" "factor that controls rate of 6th-order numerical diffusion" +rconfig integer diff_6th_opt namelist,dynamics max_domains 0 irh "diff_6th_opt" "switch for 6th-order numerical diffusion" +rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0.01 h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 0 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 5 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical pd_moist namelist,dynamics max_domains .false. rh "pd_moist" "positive-definite RK3 transport switch" "" +rconfig logical pd_chem namelist,dynamics max_domains .false. rh "pd_chem" "positive-definite RK3 transport switch" "" +rconfig logical pd_scalar namelist,dynamics max_domains .false. rh "pd_scalar" "positive-definite RK3 transport switch" "" +rconfig logical pd_tke namelist,dynamics max_domains .false. rh "pd_tke" "positive-definite RK3 transport switch" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 1000. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "dimensionless" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "K m s-1" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical mix_full_fields namelist,dynamics max_domains .false. irh "mix_full_field" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# Package Declarations +# + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_em dyn_opt==2 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qi,qs,qg;scalar:qt +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package noprogn progn==0 - - +package progndrop progn==1 - scalar:qndrop + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +#--------------------------------------------------------------------------------------------------------------------------------------- +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# Halo Update Communications + +halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 +halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb +halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb +halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msft,msfu,msfv,f,e,sina,cosa,ht,potevp,snopcx,soiltb +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb +halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut +halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 +halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten +halo HALO_EM_FDDA dyn_em 4:rundgdten,rvndgdten +halo HALO_EM_PHYS_DIFFUSION dyn_em 4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,xkmhd,xkhv,xkhh,tke_1,tke_2 +halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 +halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 +halo HALO_EM_TKE_A dyn_em 4:ph_2,phb +halo HALO_EM_TKE_B dyn_em 4:z,rdz,rdzw,zx,zy +halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw +halo HALO_EM_TKE_D dyn_em 8:defor11,defor22,defor33,defor12,defor13,defor23,div +halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkmhd,xkhv,xkhh,BN2,moist +halo HALO_EM_TKE_3 dyn_em 24:tke_1,tke_2 +halo HALO_EM_TKE_5 dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_7 dyn_em 80:tke_1,tke_2 +halo HALO_EM_TKE_F dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_OLD_E_5 dyn_em 48:tke_1 +halo HALO_EM_TKE_OLD_E_7 dyn_em 80:tke_1 +halo HALO_EM_B dyn_em 4:ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend +halo HALO_EM_C dyn_em 4:u_2,v_2 +halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf +halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_MOIST_E_3 dyn_em 24:moist +halo HALO_EM_MOIST_E_5 dyn_em 48:moist +halo HALO_EM_MOIST_E_7 dyn_em 80:moist +halo HALO_EM_CHEM_E_3 dyn_em 24:chem +halo HALO_EM_CHEM_E_5 dyn_em 48:chem +halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar +halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar +halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar + +halo HALO_EM_MOIST_OLD_E_3 dyn_em 24:moist_old +halo HALO_EM_MOIST_OLD_E_5 dyn_em 48:moist_old +halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old +halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old +halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old +halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old +halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old +halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old + +halo HALO_EM_FEEDBACK dyn_em 48:ht + +halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 +period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 +halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar +period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar + +# For moving nests +halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 +halo em_shift_halo_x dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 + +# For observational nudging +halo HALO_OBS_NUDGE dyn_em 24:pb,p,uratx,vratx,tratx + +# Periodic Boundary Communications + +period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,t_init,phb,ph0,php,pb,al,alt,alb,mu_1,mu_2,mub,mu0,ht,msft,msfu,msfv,sina,cosa,e,f +period PERIOD_BDY_EM_MOIST dyn_em 3:moist +period PERIOD_BDY_EM_CHEM dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR dyn_em 3:scalar +period PERIOD_BDY_EM_MOIST2 dyn_em 3:moist +period PERIOD_BDY_EM_CHEM2 dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR2 dyn_em 3:scalar +period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al +period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy +period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,xkmh,xkmhd,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2 +period PERIOD_BDY_EM_FDDA_BC dyn_em 2:rundgdten,rvndgdten +period PERIOD_BDY_EM_B dyn_em 2:ru_tend,rv_tend,ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +period PERIOD_BDY_EM_B3 dyn_em 2:ph_2,al,p,mu_2,muts,mudf +period PERIOD_BDY_EM_B2 dyn_em 2:ru_tend,rv_tend +period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfv,muu,msfu +period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 +period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 + +# +#swap SWAP_ETAMP_NEW dyn_em 1:dz8w,p_phy,pi_phy,rho,th_phy,moist,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,RAINNC,RAINNCV,SR,LOWLYR +#swap SWAP_WSM3 dyn_em 1:th_phy,moist,w_2,rho,pi_phy,p_phy,dz8w,rainnc,rainncv +#cycle CYCLE_TEST dyn_em 1:xlong + +## + +# FDDA (Observational-nudging) Variables +typedef fdob_type integer domain_tot # total number of domains to apply obs-nudging +typedef fdob_type integer domain_init # domain initialization flag +typedef fdob_type integer IEODI # end of obs data flag for current model step +typedef fdob_type integer IWTSIG # flag for nudging on pressure surfaces +typedef fdob_type integer NSTAT # number of obs stations used to nudge current model step +typedef fdob_type integer KTAUR # restart model step +typedef fdob_type integer SN_MAXCG # coarse domain grid dimension in south-north coordinate +typedef fdob_type integer WE_MAXCG # coarse domain grid dimension in west-east coordinate +typedef fdob_type integer SN_END # ending north-south grid index +typedef fdob_type integer LEVIDN(max_domains) # level of nest +typedef fdob_type real DS_CG # coarse domain grid size +typedef fdob_type real WINDOW # time window half-period for nudging (in minutes) +typedef fdob_type real RTLAST # time in hours of last obs used in current model step +typedef fdob_type real DATEND # time in minutes after which data are asuumed to have ended +typedef fdob_type real RINFMN # minimum radius of influence +typedef fdob_type real RINFMX # maximum radius of influence +typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small +typedef fdob_type real DCON # 1/DPSMX +typedef fdob_type real DPSMX # max pres change (cb) allowed within infl range of surf obs +typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization +typedef fdob_type real XN # cone factor for Lambert projection + +# table entries are of the form +#
+#Grid variables +typedef fdob_type real varobs rz - 1 - - "varobs" "observational values in each variable" +typedef fdob_type real errf hz - 1 - - "errf" "errors between model and obs values" +typedef fdob_type real timeob z - 1 - - "timeob" "model times for each observation" "hours" +typedef fdob_type real nlevs_ob z - 1 - - "nlevs_ob" "numbers of levels in sounding obs" +typedef fdob_type real lev_in_ob z - 1 - - "lev_in_ob" "level in sounding-type obs" +typedef fdob_type real plfo z - 1 - - "plfo" "index for type of obs-platform" +typedef fdob_type real elevob z - 1 - - "elevob" "elevation of observation" "meters" +typedef fdob_type real rio z - 1 - - "rio" "west-east grid coordinate" +typedef fdob_type real rjo z - 1 - - "rjo" "south-north grid coordinate" +typedef fdob_type real rko z - 1 - - "rko" "vertical grid coordinate" + +state fdob_type fdob - - +## diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM new file mode 100644 index 00000000..81e36e3d --- /dev/null +++ b/wrfv2_fire/Registry/Registry.NMM @@ -0,0 +1,1057 @@ +# Registry file NMM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec e 3 namelist=ensdim z gd ensemble dimension +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec o 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev + + +#### 7. Edit the Registry file and create the state data assocaited with this +#### solver. Single entry: +state real x ikj dyn_exp 2 - ih "TOYVAR" +#### + +################################################################################ +################################################################################ +################################################################################ + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# It is reauired that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" +################################################################################ +################################################################################ + +################################ +## WPS-specific Variables +################################ + +state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" +state real p_gc_xzy igj dyn_nmm 1 Z - "PRES1" "pressure" "Pa" # for RSL_LITE halo_exchange +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" + +state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" +state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" +state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" +state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" +state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" +state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" +state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" +state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" +state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" +state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" +state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" +state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" +state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" +state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" + +############################################################## +# Variables for nmm dynamics +# +# module_BC +# +# pdb is only 2d but registry doesn't support 2d bdy arrays right now... +#definitions for NMM slab arrays +dimspec q - constant=2600 c # a little crude right now +dimspec v - constant=1 c # a little crude right now + +# +# module_LOOPS +# +state integer lmh ij dyn_nmm 1 - irh "LMH" "Lowest model layer at mass points from domain top" "" +state integer lmv ij dyn_nmm 1 - irh "LMV" "Lowest model layer at velocity points from domain top" "" +# +# module_MASKS +# +state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" +state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" +state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" +state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" +state real sm ij dyn_nmm 1 - i01rh "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 - irh "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" +state real htm ikj dyn_nmm 1 - rh "HTM" "Height mask; =1 at all mass points above ground" "" +state real vtm ikj dyn_nmm 1 - rh "VTM" "Velocity mask; =1 at all velocity points above ground" "" +# +# module_VRBLS +# +state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" +state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" +state real pd ijb dyn_nmm 1 - i01rh "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" +state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" +state real t ikjb dyn_nmm 1 - i01rh "T" "Sensible temperature" "K" +state real q ikjb dyn_nmm 1 - i01rh "Q" "Specific humidity" "kg kg-1" +state real u ikjb dyn_nmm 1 - i01rh "U" "U component of wind" "m s-1" +state real v ikjb dyn_nmm 1 - i01rh "V" "V component of wind" "m s-1" +state real told ikj dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" +state real uold ikj dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" +state real vold ikj dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" +# +# module_DYNAM +# +state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" +state real wpdar ij dyn_nmm 1 - ir +state real cpgfu ij dyn_nmm 1 - ir +state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" +state real fcp ij dyn_nmm 1 - ir +state real fdiv ij dyn_nmm 1 - ir +state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" +state real fad ij dyn_nmm 1 - ir +state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" +state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" +state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" +state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" +state real aeta k dyn_nmm 1 - i01r +state real f4q2 k dyn_nmm 1 - ir +state real etax k dyn_nmm 1 - i01r +state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" +state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" +state real eta1 k dyn_nmm 1 - i01rh "ETA1" "Interface sigma value in pressure domain" "" +state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" +state real eta2 k dyn_nmm 1 - i01rh "ETA2" "Interface sigma value in sigma domain" "" +state real em q dyn_nmm 1 - ir +state real emt q dyn_nmm 1 - ir +state real adt ikj dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" +state real adu ikj dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" +state real adv ikj dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +state real em_loc q dyn_nmm 1 - r +state real emt_loc q dyn_nmm 1 - r +state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" +state real cpgfv - dyn_nmm - - ir +state real en - dyn_nmm - - ir +state real ent - dyn_nmm - - ir +state real f4d - dyn_nmm - - ir +state real f4q - dyn_nmm - - ir +state real ef4t - dyn_nmm - - ir +state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" +state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" +state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" +state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" +# +# module_CONTIN +# +state real pdsl ij dyn_nmm 1 - - "PDSL" "Sigma-domain pressure at sigma=1" "Pa" +state real pdslo ij dyn_nmm 1 - - "PDSLO" "PDSL from previous timestep" "Pa" +state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" +state real div ikj dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" +state real few ikj dyn_nmm 1 - - "FEW" "Integrated east-west mass flux" "Pa m2 s-1" +state real fne ikj dyn_nmm 1 - - "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" +state real fns ikj dyn_nmm 1 - - "FNS" "Integrated north-south mass flux" "Pa m2 s-1" +state real fse ikj dyn_nmm 1 - - "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +state real omgalf ikj dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" +state real petdt ikj dyn_nmm 1 - - "PETDT" "Vertical mass flux" "Pa s-1" +state real rtop ikj dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" +# +# module_PVRBLS +# +state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" +state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" +state real ustar ij dyn_nmm 1 - irh "USTAR" "Friction velocity" "m s-1" +state real z0 ij dyn_nmm 1 - i01rh "Z0" "Roughness height" "m" +state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" +state real ths ij dyn_nmm 1 - irh "THS" "Surface potential temperature" "K" +state real mavail ij dyn_nmm 1 - i +state real qsh ij dyn_nmm 1 - irh "QS" "Surface specific humidity" "kg kg-1" +state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" +state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" +state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" +state real aprec ij dyn_nmm 1 - rh +state real acprec ij dyn_nmm 1 - rh "ACPREC" "Accumulated total precipitation" "m" +state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" +state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" +state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" +state real accliq ij dyn_nmm 1 - r +state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water snow amount" "m" +state real si ij dyn_nmm 1 - irh "SI" "Snow depth" "m" +state real cldefi ij dyn_nmm 1 - rh "CLDEFI" "Convective cloud efficiency" "" +state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" +state real rf ij dyn_nmm 1 - r +state real th10 ij dyn_nmm 1 - irh "TH10" "10-m potential temperature" "K" +state real q10 ij dyn_nmm 1 - irh "Q10" "10-m specific humidity" "kg kg-1" +state real pshltr ij dyn_nmm 1 - irh "PSHLTR" "2-m pressure" "Pa" +state real tshltr ij dyn_nmm 1 - irh "TSHLTR" "2-m sensible temperature" "K" +state real qshltr ij dyn_nmm 1 - irh "QSHLTR" "2-m specific humidity" "kg kg-1" +state real q2 ikjb dyn_nmm 1 - irh "Q2" "2 * Turbulence kinetic energy" "m2 s-2" +state real t_adj ikj dyn_nmm 1 - r "T_ADJ" "T change due to precip in phys step" "K" +state real t_old ikj dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" +state real zero_3d ikj dyn_nmm 1 - r +state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" +state real AKHS_OUT ij dyn_nmm 1 - h "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" +state real AKMS_OUT ij dyn_nmm 1 - h "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" +# +# module_PHYS +# +state real albase ij dyn_nmm 1 - i01rh "ALBASE" "Base albedo" "" +state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" +state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" +state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" +state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" +state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" +state real epsr ij dyn_nmm 1 - ir "EPSR" "Radiative emissivity" "" +state real gffc ij dyn_nmm 1 - ir +state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" +state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" +state real NMM_TSK ij dyn_nmm 1 - i01r "TSK" "Skin temperature" "K" +state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" +state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" +state real mxsnal ij dyn_nmm 1 - i01rh "MXSNAL" "Maximum deep snow albedo" "" +state real radin ij dyn_nmm 1 - r +state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" +state real sigt4 ij dyn_nmm 1 - rh "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" +state real tg ij dyn_nmm 1 - i01rh "TGROUND" "Deep ground soil temperature" "K" +state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" +state integer lvl ij dyn_nmm 1 - ir +# +# module_CLDWTR.F +# +state real cwm ikjb dyn_nmm 1 - rh "CWM" "Total condensate" "kg kg-1" +state real f_ice ikj dyn_nmm 1 - rh "F_ICE" "Frozen fraction of CWM" "" +state real f_rain ikj dyn_nmm 1 - rh "F_RAIN" "Rain fraction of liquid part of CWM" "" +state real f_rimef ikj dyn_nmm 1 - rh "F_RIMEF" "Rime factor" "" +state real cldfra ikj dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" +state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" +state real cfrach ij dyn_nmm 1 - rh "CFRACH" "High cloud fraction" "" +state real cfracl ij dyn_nmm 1 - rh "CFRACL" "Low cloud fraction" "" +state real cfracm ij dyn_nmm 1 - rh "CFRACM" "Middle cloud fraction" "" +state logical micro_start - dyn_nmm - - - +# +# module_SOIL.F +# +state integer islope ij dyn_nmm 1 - i01rh +state real dzsoil k dyn_nmm 1 - ir "DZSOIL" "Thickness of soil layers" "m" +state real rtdpth k dyn_nmm 1 - i01r +state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Thickness of soil layers" "m" +state real cmc ij dyn_nmm 1 - i01rh "CMC" "Canopy moisture" "m" +state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" +state real pctsno ij dyn_nmm 1 - irh +state real soiltb ij dyn_nmm 1 - i01rh "SOILTB" "Deep ground soil temperature" "K" +state real vegfrc ij dyn_nmm 1 - i01rh "VEGFRC" "Vegetation fraction" "" +state real shdmin ij dyn_nmm 1 - - +state real shdmax ij dyn_nmm 1 - - +state real sh2o ilj dyn_nmm 1 Z irh "SH2O" "Unfrozen soil moisture volume fraction" "" +state real smc ilj dyn_nmm 1 Z irh "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irh "STC" "Soil temperature" "K" +# +# module_NHYDRO.F +# +state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" +state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" +state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" +state real dwdt ikj dyn_nmm 1 - r "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" +state real pdwdt ikj dyn_nmm 1 - r +state real pint ikj dyn_nmm 1 Z rh "PINT" "Model layer interface pressure" "Pa" +state real w ikj dyn_nmm 1 Z rh "W" "Vertical velocity" "m s-1" +state real z ikj dyn_nmm 1 Z - "Z" "Distance from ground" "m" +# +# module_ACCUM.F +# +state real acfrcv ij dyn_nmm 1 - h "ACFRCV" "Accum convective cloud fraction" "" +state real acfrst ij dyn_nmm 1 - h "ACFRST" "Accum stratiform cloud fraction" "" +state real ssroff ij dyn_nmm 1 - h "SSROFF" "Surface runoff" "mm" +state real bgroff ij dyn_nmm 1 - h "BGROFF" "Subsurface runoff" "mm" +state real rlwin ij dyn_nmm 1 - rh "RLWIN" "Downward longwave at surface" "W m-2" +state real rlwout ij dyn_nmm 1 - - +state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" +state real alwin ij dyn_nmm 1 - h "ALWIN" "Accum LW down at surface" "W m-2" +state real alwout ij dyn_nmm 1 - h "ALWOUT" "Accum RADOT (see above)" "W m-2" +state real alwtoa ij dyn_nmm 1 - h "ALWTOA" "Accum RLWTOA" "W m-2" +state real rswin ij dyn_nmm 1 - rh "RSWIN" "Downward shortwave at surface" "W m-2" +state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" +state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" +state real rswtoa ij dyn_nmm 1 - - "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +state real aswin ij dyn_nmm 1 - h "ASWIN" "Accum SW down at surface" "W m-2" +state real aswout ij dyn_nmm 1 - h "ASWOUT" "Accum RSWOUT" "W m-2" +state real aswtoa ij dyn_nmm 1 - h "ASWTOA" "Accum RSWTOA" "W m-2" +state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" +state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" +state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" +state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" +state real sfcuvx ij dyn_nmm 1 - rh +state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" +state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" +state real tlmin ij dyn_nmm 1 - h +state real tlmax ij dyn_nmm 1 - h +state real rlwtt ikj dyn_nmm 1 - rh "RLWTT" "Longwave temperature tendency" "K s-1" +state real rswtt ikj dyn_nmm 1 - rh "RSWTT" "Shortwave temperature tendency" "K s-1" +state real tcucn ikj dyn_nmm 1 - h "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ikj dyn_nmm 1 - h "TRAIN" "Accum stratiform temp tendency" "K s-1" +state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" +state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" +state integer nphs0 - dyn_nmm - - rh +state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" +state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" +state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" +state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" +state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" +state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" +state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" +state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" +state real aratim - dyn_nmm - - ir +state real acutim - dyn_nmm - - irh +state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" +state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" +state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" +state real aphtim - dyn_nmm - - irh +# +# module_INDX.F +# +state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" +state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" +state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" +state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" +state integer irad i dyn_nmm 1 - - +#definitions for NMM east-west orientation on E grid +state integer iheg q dyn_nmm 1 - - +state integer ihwg q dyn_nmm 1 - - +state integer iveg q dyn_nmm 1 - - +state integer ivwg q dyn_nmm 1 - - +dimspec r - constant=2000 c # a little crude right now +state integer iradg r dyn_nmm 1 - - +dimspec z - constant=(-3:3) c +dimspec n - constant=(0:6) c +state integer indx3_wrk zqn dyn_nmm 1 - - "INDX3_WRK" "Array of 3rd (J) indices for local arrays" "" +state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" +state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" +state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" +state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" +state integer iup_h ij dyn_nmm 1 - - +state integer iup_v ij dyn_nmm 1 - - +state integer iup_adh ij dyn_nmm 1 - - +state integer iup_adv ij dyn_nmm 1 - - +state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" + +# +# table entries are of the form +#
+# +# Mask for moving nest interpolations +state integer imask_nostag ij misc - +state integer imask_xstag ij misc X +state integer imask_ystag ij misc Y +state integer imask_xystag ij misc XY +# +#--------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#--------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" +state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" +state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" +state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" +state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" +state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" +state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" +state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" +state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" +state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" +state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" +state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" +state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" +state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" +state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" +state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" +state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" +state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" +state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" +state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" +state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" +state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" +state real st000010 ij misc 1 - i1 "ST000010" "description" "units" +state real st010040 ij misc 1 - i1 "ST010040" "description" "units" +state real st040100 ij misc 1 - i1 "ST040100" "description" "units" +state real st100200 ij misc 1 - i1 "ST100200" "description" "units" +state real st010200 ij misc 1 - i1 "ST010200" "description" "units" +state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" +state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" +state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" +state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" +state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" +state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" +state real landmask ij misc 1 - i01rh "LANDMASK" "description" "units" +state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" +state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" +state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" +state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" +state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" +state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" +state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" +state real toposoil ij misc 1 - i1 "SOILHGT" "description" "units" +state real landusef iuj misc 1 Z - "" "description" "units" +state real soilctop isj misc 1 Z - "" "description" "units" +state real soilcbot isj misc 1 Z - "" "description" "units" + +#------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#------------------------------------------------------------------------------------------------------------------------------- + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + + +# Moist Scalars - both height and mass coordinate models +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjft moist 1 - - - +state real qv ikjft moist 1 - r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjft moist 1 - r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjft moist 1 - r "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjft moist 1 - r "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjft moist 1 - r "QGRAUP" "Graupel mixing ratio" "kg kg-1" +# +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qni ikjftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +## Chem Scalars - both height and mass coordinate models +# +state real - ikjft chem 1 - - - + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# specified LBC arrays, first, Eulerian height coordinate model + + +# specified LBC arrays, next, Eulerian mass coordinate model + + +# specified LBC variables shared between the mass and height coordinate models + + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim + + +# 2m and 10m output diagnostics + + +# lsm State Variables + +state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" +state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" + + +# MYJ PBL variables + + +# gfdl (eta) radiation State Variables + +# eta microphpysics State Variables + + +# new eta microphpysics State Variables + +# some mass-coordinate-model-specific variables + + + + + + +# was em_only + +################################################################# +# Physics Variables (em core) + + + +################################################################# +# Physics Variables (eh core) ; should be same as em + + + + +################################################################# +# variables added for CHEMISTRY compatibility with ARW core - kludge +################################################################# +state real GSW ij misc 1 - - "" "" +state real XLAT ij misc 1 - - "" "" +state real XLONG ij misc 1 - - "" "" +state real XLAND ij misc 1 - - "" "" +state real RAINCV ij misc 1 - - "" "" + +################################################################# +# other misc variables (all cores) +################################################################# + +# added for surface_driver +state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" +state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" +state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" +state real U10 ij misc 1 - irh "U10" "U at 10 M" " " +state real V10 ij misc 1 - irh "V10" "V at 10 M" " " +state real XICE ij misc 1 - i01r "XICE" "SEA ICE" "" +state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" +state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" +state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" +state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" +state integer IVGTYP ij misc 1 - irh "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 - irh "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i01rh "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" +state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" +state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" +state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "" +state real RMOL ij misc 1 - ir "RMOL" "" "" +state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" +state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" +state real SST ij misc 1 - i01rh "SST" "SEA SURFACE TEMPERATURE" "K" +state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" +state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" + +state real tke_myj ikj misc 1 - rh "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - h "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - rh "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" +state real THZ0 ij misc 1 - irh "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" +state real QZ0 ij misc 1 - irh "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" +state real UZ0 ij misc 1 - irh "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real VZ0 ij misc 1 - irh "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +# added as state for HALO_NMM_MG2, mep +state real psfc_out ij dyn_nmm 1 - - +# added as state for HALO_NMM_TURBL, jm +state real UZ0h ij misc 1 - - +state real VZ0h ij misc 1 - - +state real dudt ikj misc 1 - - +state real dvdt ikj misc 1 - - + +state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" +state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" +state real HTOP ij misc 1 - irh "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - irh "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - ir "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - ir "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" +state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" +state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" +state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" +state REAL CUPPT ij misc 1 - rh "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" +state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a +state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" + +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K/sec" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg/sec" +state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index) "SNOWH" "PHYSICAL SNOW DEPTH" "" +state real RHOSN ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# added state for etampnew microphysics (needed for restarts) +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - - +state integer landuse_lucats - misc - - - +state integer landuse_luseas - misc - - - +state integer landuse_isn - misc - - - +state real lu_state p misc - - - + + +################################################################# +# + +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - h "itimestep" "" "" +state real xtime - - - - h "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" + +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" + +include registry.io_boilerplate +#include registry.io_boilerplate_NMM + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" +rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +# WPS related +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real ptsgm namelist,domains 1 42000. +rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" + + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" + + +# nmm variables +rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" +rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" +rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" +rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" +rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" +rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" +rconfig real tprec namelist,physics max_domains 3. irh "tprec" "number of hours in bucket for total precipitation" +rconfig real theat namelist,physics max_domains 6. irh "theat" "number of hours in bucket for gridscale and convective heating rates" +rconfig real tclod namelist,physics max_domains 6. irh "tclod" "number of hours in bucket for cloud amounts" +rconfig real trdsw namelist,physics max_domains 6. irh "trdsw" "number of hours in bucket for short wave fluxes" +rconfig real trdlw namelist,physics max_domains 6. irh "trdlw" "number of hours in bucket for long wave fluxes" +rconfig real tsrfc namelist,physics max_domains 6. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" +rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" +rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" +rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" +rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 1 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" +rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 100. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_nmm dyn_opt==4 - - + + +#### 9. Edit the Registry file to set up '5' as the value of the +**** namelist variable dyn_opt that means to select our exp dyncore. +package dyn_exp dyn_opt==5 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qs +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - - +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - - +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package nmmlsmscheme sf_surface_physics==99 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# NMM communications + +#halo HALO_NMM_INIT_1 dyn_nmm 120:LMH,LMV,HBM2 +halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 +halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 +halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE,HTM +halo HALO_NMM_INIT_4 dyn_nmm 120:VTM,DX_NMM,WPDAR +halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP +halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F +halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT +halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG +halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE +#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP +halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV +#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC +halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC +halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES +halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U +halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2 +halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN +halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar +halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG +halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN +halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH +halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT +halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 +halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR +halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO +halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF +halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB +halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT +halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN +halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 +halo HALO_NMM_INIT_28 dyn_nmm 120:SR +halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ +halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW +halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF +halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX +halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP +halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT +halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT +halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC +halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO +halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT +halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD + +halo HALO_NMM_A dyn_nmm 24:pd,t,u,v,q,cwm,dwdt,div;24:pint +halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar +halo HALO_NMM_B dyn_nmm 24:div +halo HALO_NMM_C dyn_nmm 8:u,v +halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_E dyn_nmm 24:petdt +halo HALO_NMM_F dyn_nmm 24:t,u,v +halo HALO_NMM_F1 dyn_nmm 80:pdslo +halo HALO_NMM_G dyn_nmm 24:u,v;24:z +halo HALO_NMM_H dyn_nmm 24:w,lmh +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar +halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm +halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_K dyn_nmm 8:q2;24:t,u,v,q,w,z +halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 +halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_MG dyn_nmm 8:ht_gc +halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out +halo HALO_NMM_MG3 dyn_nmm 8:p_gc_xzy + +halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 +halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt + diff --git a/wrfv2_fire/Registry/Registry.NMM_CHEM b/wrfv2_fire/Registry/Registry.NMM_CHEM new file mode 100755 index 00000000..b8cc24fb --- /dev/null +++ b/wrfv2_fire/Registry/Registry.NMM_CHEM @@ -0,0 +1,1072 @@ +# Registry file NMM_CHEM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec e 3 namelist=ensdim z gd ensemble dimension +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec o 3 namelist=ne_area z emissions dimension +dimspec + 2 namelist=kemit z emissions_zdim +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec d 2 namelist=paerlev z paerlev + + +#### 7. Edit the Registry file and create the state data assocaited with this +#### solver. Single entry: +state real x ikj dyn_exp 2 - ih "TOYVAR" +#### + +################################################################################ +################################################################################ +################################################################################ + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# It is reauired that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" +################################################################################ +################################################################################ + +################################ +## WPS-specific Variables +################################ + +state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" +state real p_gc_xzy igj dyn_nmm 1 Z - "PRES1" "pressure" "Pa" # for RSL_LITE halo_exch +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" +state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" +state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" +state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" +state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" +state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" +state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" +state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" +state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" +state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" +state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" +state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" +state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" +state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" + + +# Variables for nmm dynamics +# +# module_BC +# +# pdb is only 2d but registry doesn't support 2d bdy arrays right now... +#definitions for NMM slab arrays +dimspec q - constant=2600 c # a little crude right now +dimspec v - constant=1 c # a little crude right now + +# +# module_LOOPS +# +state integer lmh ij dyn_nmm 1 - irh "LMH" "Lowest model layer at mass points from domain top" "" +state integer lmv ij dyn_nmm 1 - irh "LMV" "Lowest model layer at velocity points from domain top" "" +# +# module_MASKS +# +state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" +state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" +state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" +state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" +state real sm ij dyn_nmm 1 - i01rh "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 - irh "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" +state real htm ikj dyn_nmm 1 - rh "HTM" "Height mask; =1 at all mass points above ground" "" +state real vtm ikj dyn_nmm 1 - rh "VTM" "Velocity mask; =1 at all velocity points above ground" "" +# +# module_VRBLS +# +state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" +state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" +state real pd ijb dyn_nmm 1 - i01rh "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" +state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" +state real t ikjb dyn_nmm 1 - i01rh "T" "Sensible temperature" "K" +state real q ikjb dyn_nmm 1 - i01rh "Q" "Specific humidity" "kg kg-1" +state real u ikjb dyn_nmm 1 - i01rh "U" "U component of wind" "m s-1" +state real v ikjb dyn_nmm 1 - i01rh "V" "V component of wind" "m s-1" +state real told ikj dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" +state real uold ikj dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" +state real vold ikj dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" +# +# module_DYNAM +# +state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" +state real wpdar ij dyn_nmm 1 - ir +state real cpgfu ij dyn_nmm 1 - ir +state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" +state real fcp ij dyn_nmm 1 - ir +state real fdiv ij dyn_nmm 1 - ir +state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" +state real fad ij dyn_nmm 1 - ir +state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" +state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" +state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" +state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" +state real aeta k dyn_nmm 1 - i01r +state real f4q2 k dyn_nmm 1 - ir +state real etax k dyn_nmm 1 - i01r +state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" +state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" +state real eta1 k dyn_nmm 1 - i01rh "ETA1" "Interface sigma value in pressure domain" "" +state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" +state real eta2 k dyn_nmm 1 - i01rh "ETA2" "Interface sigma value in sigma domain" "" +state real em q dyn_nmm 1 - ir +state real emt q dyn_nmm 1 - ir +state real adt ikj dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" +state real adu ikj dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" +state real adv ikj dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +state real em_loc q dyn_nmm 1 - r +state real emt_loc q dyn_nmm 1 - r +state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" +state real cpgfv - dyn_nmm - - ir +state real en - dyn_nmm - - ir +state real ent - dyn_nmm - - ir +state real f4d - dyn_nmm - - ir +state real f4q - dyn_nmm - - ir +state real ef4t - dyn_nmm - - ir +state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" +state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" +state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" +state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" +# +# module_CONTIN +# +state real pdsl ij dyn_nmm 1 - - "PDSL" "Sigma-domain pressure at sigma=1" "Pa" +state real pdslo ij dyn_nmm 1 - - "PDSLO" "PDSL from previous timestep" "Pa" +state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" +state real div ikj dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" +state real few ikj dyn_nmm 1 - - "FEW" "Integrated east-west mass flux" "Pa m2 s-1" +state real fne ikj dyn_nmm 1 - - "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" +state real fns ikj dyn_nmm 1 - - "FNS" "Integrated north-south mass flux" "Pa m2 s-1" +state real fse ikj dyn_nmm 1 - - "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +state real omgalf ikj dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" +state real petdt ikj dyn_nmm 1 - - "PETDT" "Vertical mass flux" "Pa s-1" +state real rtop ikj dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" +# +# module_PVRBLS +# +state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" +state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" +state real ustar ij dyn_nmm 1 - irh "USTAR" "Friction velocity" "m s-1" +state real z0 ij dyn_nmm 1 - i01rh "Z0" "Roughness height" "m" +state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" +state real ths ij dyn_nmm 1 - irh "THS" "Surface potential temperature" "K" +state real mavail ij dyn_nmm 1 - irh +state real qsh ij dyn_nmm 1 - irh "QS" "Surface specific humidity" "kg kg-1" +state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" +state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" +state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" +state real aprec ij dyn_nmm 1 - rh +state real acprec ij dyn_nmm 1 - rh "ACPREC" "Accumulated total precipitation" "m" +state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" +state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" +state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" +state real accliq ij dyn_nmm 1 - r +state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water snow amount" "m" +state real si ij dyn_nmm 1 - irh "SI" "Snow depth" "m" +state real cldefi ij dyn_nmm 1 - rh "CLDEFI" "Convective cloud efficiency" "" +state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" +state real rf ij dyn_nmm 1 - r +state real th10 ij dyn_nmm 1 - irh "TH10" "10-m potential temperature" "K" +state real q10 ij dyn_nmm 1 - irh "Q10" "10-m specific humidity" "kg kg-1" +state real pshltr ij dyn_nmm 1 - irh "PSHLTR" "2-m pressure" "Pa" +state real tshltr ij dyn_nmm 1 - irh "TSHLTR" "2-m sensible temperature" "K" +state real qshltr ij dyn_nmm 1 - irh "QSHLTR" "2-m specific humidity" "kg kg-1" +state real q2 ikjb dyn_nmm 1 - irh "Q2" "2 * Turbulence kinetic energy" "m2 s-2" +state real t_adj ikj dyn_nmm 1 - r "T_ADJ" "T change due to precip in phys step" "K" +state real t_old ikj dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" +state real zero_3d ikj dyn_nmm 1 - r +state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" +state real AKHS_OUT ij dyn_nmm 1 - h "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" +state real AKMS_OUT ij dyn_nmm 1 - h "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" +# +# module_PHYS +# +state real albase ij dyn_nmm 1 - i01rh "ALBASE" "Base albedo" "" +state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" +state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" +state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" +state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" +state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" +state real epsr ij dyn_nmm 1 - ir "EPSR" "Radiative emissivity" "" +state real gffc ij dyn_nmm 1 - ir +state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" +state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" +state real NMM_TSK ij dyn_nmm 1 - i01r "TSK" "Skin temperature" "K" +state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" +state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" +state real mxsnal ij dyn_nmm 1 - i01rh "MXSNAL" "Maximum deep snow albedo" "" +state real radin ij dyn_nmm 1 - r +state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" +state real sigt4 ij dyn_nmm 1 - rh "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" +state real tg ij dyn_nmm 1 - i01rh "TGROUND" "Deep ground soil temperature" "K" +state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" +state integer lvl ij dyn_nmm 1 - ir +# +# module_CLDWTR.F +# +state real cwm ikjb dyn_nmm 1 - rh "CWM" "Total condensate" "kg kg-1" +state real f_ice ikj dyn_nmm 1 - rh "F_ICE" "Frozen fraction of CWM" "" +state real f_rain ikj dyn_nmm 1 - rh "F_RAIN" "Rain fraction of liquid part of CWM" "" +state real f_rimef ikj dyn_nmm 1 - rh "F_RIMEF" "Rime factor" "" +state real cldfra ikj misc 1 - rh "CLDFRA" "Cloud fraction" "" +state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" +state real cfrach ij dyn_nmm 1 - rh "CFRACH" "High cloud fraction" "" +state real cfracl ij dyn_nmm 1 - rh "CFRACL" "Low cloud fraction" "" +state real cfracm ij dyn_nmm 1 - rh "CFRACM" "Middle cloud fraction" "" +state logical micro_start - dyn_nmm - - - +# +# module_SOIL.F +# +state integer islope ij dyn_nmm 1 - i01rh +state real dzsoil k dyn_nmm 1 - ir "DZSOIL" "Thickness of soil layers" "m" +state real rtdpth k dyn_nmm 1 - i01r +state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Thickness of soil layers" "m" +state real cmc ij dyn_nmm 1 - i01rh "CMC" "Canopy moisture" "m" +state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" +state real pctsno ij dyn_nmm 1 - irh +state real soiltb ij dyn_nmm 1 - i01rh "SOILTB" "Deep ground soil temperature" "K" +state real vegfrc ij dyn_nmm 1 - i01rh "VEGFRC" "Vegetation fraction" "" +state real shdmin ij dyn_nmm 1 - - +state real shdmax ij dyn_nmm 1 - - +state real sh2o ilj dyn_nmm 1 Z irh "SH2O" "Unfrozen soil moisture volume fraction" "" +state real smc ilj dyn_nmm 1 Z irh "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irh "STC" "Soil temperature" "K" +# +# module_NHYDRO.F +# +state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" +state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" +state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" +state real dwdt ikj dyn_nmm 1 - r "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" +state real pdwdt ikj dyn_nmm 1 - r +state real pint ikj dyn_nmm 1 Z rh "PINT" "Model layer interface pressure" "Pa" +state real w ikj dyn_nmm 1 Z rh "W" "Vertical velocity" "m s-1" +state real z ikj dyn_nmm 1 Z - "Z" "Distance from ground" "m" +# +# module_ACCUM.F +# +state real acfrcv ij dyn_nmm 1 - h "ACFRCV" "Accum convective cloud fraction" "" +state real acfrst ij dyn_nmm 1 - h "ACFRST" "Accum stratiform cloud fraction" "" +state real ssroff ij dyn_nmm 1 - h "SSROFF" "Surface runoff" "mm" +state real bgroff ij dyn_nmm 1 - h "BGROFF" "Subsurface runoff" "mm" +state real rlwin ij dyn_nmm 1 - rh "RLWIN" "Downward longwave at surface" "W m-2" +state real rlwout ij dyn_nmm 1 - - +state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" +state real alwin ij dyn_nmm 1 - h "ALWIN" "Accum LW down at surface" "W m-2" +state real alwout ij dyn_nmm 1 - h "ALWOUT" "Accum RADOT (see above)" "W m-2" +state real alwtoa ij dyn_nmm 1 - h "ALWTOA" "Accum RLWTOA" "W m-2" +state real rswin ij dyn_nmm 1 - rh "RSWIN" "Downward shortwave at surface" "W m-2" +state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" +state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" +state real rswtoa ij dyn_nmm 1 - - "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +state real aswin ij dyn_nmm 1 - h "ASWIN" "Accum SW down at surface" "W m-2" +state real aswout ij dyn_nmm 1 - h "ASWOUT" "Accum RSWOUT" "W m-2" +state real aswtoa ij dyn_nmm 1 - h "ASWTOA" "Accum RSWTOA" "W m-2" +state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" +state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" +state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" +state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" +state real sfcuvx ij dyn_nmm 1 - rh +state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" +state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" +state real tlmin ij dyn_nmm 1 - h +state real tlmax ij dyn_nmm 1 - h +state real rlwtt ikj dyn_nmm 1 - rh "RLWTT" "Longwave temperature tendency" "K s-1" +state real rswtt ikj dyn_nmm 1 - rh "RSWTT" "Shortwave temperature tendency" "K s-1" +state real tcucn ikj dyn_nmm 1 - h "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ikj dyn_nmm 1 - h "TRAIN" "Accum stratiform temp tendency" "K s-1" +state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" +state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" +state integer nphs0 - dyn_nmm - - rh +state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" +state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" +state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" +state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" +state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" +state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" +state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" +state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" +state real aratim - dyn_nmm - - ir +state real acutim - dyn_nmm - - irh +state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" +state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" +state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" +state real aphtim - dyn_nmm - - irh +# +# module_INDX.F +# +state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" +state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" +state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" +state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" +state integer irad i dyn_nmm 1 - - +#definitions for NMM east-west orientation on E grid +state integer iheg q dyn_nmm 1 - - +state integer ihwg q dyn_nmm 1 - - +state integer iveg q dyn_nmm 1 - - +state integer ivwg q dyn_nmm 1 - - +dimspec r - constant=2000 c # a little crude right now +state integer iradg r dyn_nmm 1 - - +dimspec z - constant=(-3:3) c +dimspec n - constant=(0:6) c +state integer indx3_wrk zqn dyn_nmm 1 - - "INDX3_WRK" "Array of 3rd (J) indices for local arrays" "" +state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" +state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" +state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" +state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" +state integer iup_h ij dyn_nmm 1 - - +state integer iup_v ij dyn_nmm 1 - - +state integer iup_adh ij dyn_nmm 1 - - +state integer iup_adv ij dyn_nmm 1 - - +state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" + +# +# table entries are of the form +#
+# +# Mask for moving nest interpolations +state integer imask_nostag ij misc - +state integer imask_xstag ij misc X +state integer imask_ystag ij misc Y +state integer imask_xystag ij misc XY +#--------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#--------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" +state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" +state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" +state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" +state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" +state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" +state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" +state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" +state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" +state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" +state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" +state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" +state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" +state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" +state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" +state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" +state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" +state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" +state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" +state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" +state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" +state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" +state real st000010 ij misc 1 - i1 "ST000010" "description" "units" +state real st010040 ij misc 1 - i1 "ST010040" "description" "units" +state real st040100 ij misc 1 - i1 "ST040100" "description" "units" +state real st100200 ij misc 1 - i1 "ST100200" "description" "units" +state real st010200 ij misc 1 - i1 "ST010200" "description" "units" +state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" +state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" +state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" +state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" +state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" +state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" +state real landmask ij misc 1 - i01rh "LANDMASK" "description" "units" +state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" +state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" +state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" +state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" +state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" +state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" +state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" +state real toposoil ij misc 1 - i1 "SOILHGT" "description" "units" +state real landusef iuj misc 1 Z - "LANDUSEF" "description" "units" +state real soilctop isj misc 1 Z - "SOILCTOP" "description" "units" +state real soilcbot isj misc 1 Z - "SOILCBOT" "description" "units" + +#------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#------------------------------------------------------------------------------------------------------------------------------ +# + + +# Moist Scalars - both height and mass coordinate models +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjft moist 1 - - - +state real qv ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjft moist 1 - i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +# +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qni ikjftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" +state real qndrop ikjftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# specified LBC arrays, first, Eulerian height coordinate model + + +# specified LBC arrays, next, Eulerian mass coordinate model + + +# specified LBC variables shared between the mass and height coordinate models + + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim + + +# 2m and 10m output diagnostics + + +# lsm State Variables + +state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" +state real TSLB ilj - 1 Z rh "TSLB" "SOIL TEMPERATURE" "" + + +# MYJ PBL variables + + +# gfdl (eta) radiation State Variables + +# eta microphpysics State Variables + + +# new eta microphpysics State Variables + +# some mass-coordinate-model-specific variables + + + + + + +# was em_only + +################################################################# +# Physics Variables (em core) + + + +################################################################# +# Physics Variables (eh core) ; should be same as em + + + + +################################################################# +# variables added for CHEMISTRY compatibility with ARW core - kludge +################################################################# +state real GSW ij misc 1 - - "" "" +state real XLAT ij misc 1 - - "" "" +state real XLONG ij misc 1 - - "" "" +state real XLAND ij misc 1 - - "" "" +state real TSK ij misc 1 - - "" "" +state real UST ij misc 1 - - "" "" +state real RAINCV ij misc 1 - - "" "" + +################################################################# +# other misc variables (all cores) +################################################################# + +# added for surface_driver +state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" +state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" +state real T2 ij misc 1 - irh "T2" "TEMP at 2 M" "" +state real U10 ij misc 1 - irh "U10" "U at 10 M" " " +state real V10 ij misc 1 - irh "V10" "V at 10 M" " " +state real XICE ij misc 1 - i01r "XICE" "SEA ICE" "" +state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" +state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" +state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" +state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" +state integer IVGTYP ij misc 1 - irh "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 - irh "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i01rh "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" +state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" +state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" +state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "" +state real RMOL ij misc 1 - irh "RMOL" "" "" +state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" +state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" +state real SST ij misc 1 - i01rh "SST" "SEA SURFACE TEMPERATURE" "K" +state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" +state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" + +state real tke_myj ikj misc 1 - rh "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - h "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - rh "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" +state real THZ0 ij misc 1 - irh "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" +state real QZ0 ij misc 1 - irh "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" +state real UZ0 ij misc 1 - irh "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real VZ0 ij misc 1 - irh "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +# added as state for HALO_NMM_MG2, mep +state real psfc_out ij dyn_nmm 1 - - +# added as state for HALO_NMM_TURBL, jm +state real UZ0h ij misc 1 - - +state real VZ0h ij misc 1 - - +state real dudt ikj misc 1 - - +state real dvdt ikj misc 1 - - + +state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" +state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +state real HTOP ij misc 1 - irh "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - irh "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - irh "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - irh "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" +state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" +state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" +state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" +state REAL CUPPT ij misc 1 - rh "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" +state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a +state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real ccn1 ikj misc 1 - h "ccn1" "CCN concentration at S=0.02%" "#/cm3" +state real ccn2 ikj misc 1 - h "ccn2" "CCN concentration at S=0.05%" "#/cm3" +state real ccn3 ikj misc 1 - h "ccn3" "CCN concentration at S=0.1%" "#/cm3" +state real ccn4 ikj misc 1 - h "ccn4" "CCN concentration at S=0.2%" "#/cm3" +state real ccn5 ikj misc 1 - h "ccn5" "CCN concentration at S=0.5%" "#/cm3" +state real ccn6 ikj misc 1 - h "ccn6" "CCN concentration at S=1.0%" "#/cm3" +state real qndropsource ikj misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" +# cloud water fractional removal rate needed for wet scavenging +state real qlsink ikj misc 1 - rduh "qlsink" "CLOUD WATER SINK" "/S" +state real precr ikj misc 1 - rduh "precr" "RAIN PRECIPITATION RATE" "KG/M2/S" +state real preci ikj misc 1 - rduh "preci" "ICE PRECIPITATION RATE" "KG/M2/S" +state real precs ikj misc 1 - rduh "precs" "SNOW PRECIPITATION RATE" "KG/M2/S" +state real precg ikj misc 1 - rduh "precg" "GRAUPEL PRECIPITATION RATE" "KG/M2/S" + +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real GD_CLOUD ikj misc 1 - rh "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" +state real GD_CLOUD2 ikj misc 1 - rh "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" +# time averaged stuff +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K/sec" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg/sec" +state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index) "SNOWH" "PHYSICAL SNOW DEPTH" "" +state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# added state for etampnew microphysics (needed for restarts) +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - - +state integer landuse_lucats - misc - - - +state integer landuse_luseas - misc - - - +state integer landuse_isn - misc - - - +state real lu_state p misc - - - + + +################################################################# +# + +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - h "itimestep" "" "" +state real xtime - - - - h "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year" "" + +# input file descriptor for lbcs on parent domain + had2chem_tim=had2chem_tim+timef()-btimx +state integer lbc_fid - - - - - "lbc_fid" "" "" + +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 5, WHAT INPUT STREAM IS FINE GRID IC FROM" "" + +include registry.io_boilerplate +include registry.chem + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" +rconfig real tstart namelist,time_control max_domains 0 rh "tstart" "forecast hour at the start of the NMM integration" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +# WPS related +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real ptsgm namelist,domains 1 42000. +rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" + +# nmm variables +rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" +rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" +rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" +rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" +rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" +rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" +rconfig real tprec namelist,physics max_domains 3. rh "tprec" "number of hours in bucket for total precipitation" +rconfig real theat namelist,physics max_domains 6. rh "theat" "number of hours in bucket for gridscale and convective heating rates" +rconfig real tclod namelist,physics max_domains 6. rh "tclod" "number of hours in bucket for cloud amounts" +rconfig real trdsw namelist,physics max_domains 6. rh "trdsw" "number of hours in bucket for short wave fluxes" +rconfig real trdlw namelist,physics max_domains 6. rh "trdlw" "number of hours in bucket for long wave fluxes" +rconfig real tsrfc namelist,physics max_domains 6. rh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" +rconfig logical pcpflg namelist,physics max_domains .false. rh "pcpflg" "logical switch that turns on/off the precipitation assimilation" +rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" +rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" +rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 1 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" +rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 100. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig real emifrq derived max_domains 0 - "emifrq" "chem emissions input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_nmm dyn_opt==4 - - + + +#### 9. Edit the Registry file to set up '5' as the value of the +**** namelist variable dyn_opt that means to select our exp dyncore. +package dyn_exp dyn_opt==5 - - + + +package noprogn progn==0 - - +package progndrop progn==1 - scalar:qndrop +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qi,qs,qg +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - - +package gfdllwscheme ra_lw_physics==99 - moist:qv,qc,qr,qi + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - - +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package nmmlsmscheme sf_surface_physics==99 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# NMM communications + +#halo HALO_NMM_INIT_1 dyn_nmm 120:LMH,LMV,HBM2 +halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 +halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 +halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE,HTM +halo HALO_NMM_INIT_4 dyn_nmm 120:VTM,DX_NMM,WPDAR +halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP +halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F +halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT +halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG +halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE +#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP +halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV +#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC +halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC +halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES +halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U +halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2,CHEM +halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN +halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar +halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG +halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN +halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH +halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT +halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 +halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR +halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO +halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF +halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB +halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT +halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN +halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 +halo HALO_NMM_INIT_28 dyn_nmm 120:SR +halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ +halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW +halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF +halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX +halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP +halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT +halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT +halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC +halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO +halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT +halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD + +halo HALO_NMM_A dyn_nmm 24:pd,t,u,v,q,cwm,dwdt,div;24:pint +halo HALO_NMM_A_2 dyn_nmm 24:CHEM +halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar +halo HALO_NMM_B dyn_nmm 24:div +halo HALO_NMM_C dyn_nmm 8:u,v +halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_E dyn_nmm 24:petdt +halo HALO_NMM_F dyn_nmm 24:t,u,v +halo HALO_NMM_F1 dyn_nmm 80:pdslo +halo HALO_NMM_G dyn_nmm 24:u,v;24:z +halo HALO_NMM_H dyn_nmm 24:w,lmh +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_I_2 dyn_nmm 48:CHEM +halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar +halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm +halo HALO_NMM_J_2 dyn_nmm 8:CHEM +halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_K dyn_nmm 8:q2;24:t,u,v,q,w,z +halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 +halo HALO_NMM_L_2 dyn_nmm 8:CHEM +halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_MG dyn_nmm 8:ht_gc +halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out +halo HALO_NMM_MG3 dyn_nmm 8:p_gc_xzy + +halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 +halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt + diff --git a/wrfv2_fire/Registry/Registry.NMM_NEST b/wrfv2_fire/Registry/Registry.NMM_NEST new file mode 100644 index 00000000..0ccfa4ed --- /dev/null +++ b/wrfv2_fire/Registry/Registry.NMM_NEST @@ -0,0 +1,1132 @@ +# Registry file NMM_NEST +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec e 3 namelist=ensdim z gd ensemble dimension +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec o 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev + + +#### 7. Edit the Registry file and create the state data assocaited with this +#### solver. Single entry: +state real x ikj dyn_exp 2 - ih "TOYVAR" +#### + +################################################################################ +################################################################################ +################################################################################ + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# It is reauired that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" +################################################################################ +################################################################################ + +################################ +## WPS-specific Variables +################################ + +state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" +state real p_gc_xzy igj dyn_nmm 1 Z - "PRES1" "pressure" "Pa" # for RSL_LITE halo_exchange +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" + +state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" +state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" +state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" +state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" +state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" +state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" +state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" +state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" +state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" +state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" +state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" +state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" +state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" +state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" + +############################################################## +# Variables for nmm dynamics +# +# module_BC +# +# pdb is only 2d but registry doesn't support 2d bdy arrays right now... +#definitions for NMM slab arrays +dimspec q - constant=2600 c # a little crude right now +dimspec v - constant=1 c # a little crude right now + +# The following arrays were added to avoid using _b and _bt arrays for nesting. +# This is gopal' doing: + +state real pdnest_b ij dyn_nmm 1 - - +state real pdnest_bt ij dyn_nmm 1 - - +state real tnest_b ikj dyn_nmm 1 - - +state real tnest_bt ikj dyn_nmm 1 - - +state real qnest_b ikj dyn_nmm 1 - - +state real qnest_bt ikj dyn_nmm 1 - - +state real unest_b ikj dyn_nmm 1 - - +state real unest_bt ikj dyn_nmm 1 - - +state real vnest_b ikj dyn_nmm 1 - - +state real vnest_bt ikj dyn_nmm 1 - - +state real q2nest_b ikj dyn_nmm 1 - - +state real q2nest_bt ikj dyn_nmm 1 - - +state real cwmnest_b ikj dyn_nmm 1 - - +state real cwmnest_bt ikj dyn_nmm 1 - - + +# +# For the moving nest. This is gopal's doing +# + +state real pdyn ij dyn_nmm 1 - r "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" +state real mslp ij dyn_nmm 1 - r "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" +state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" +state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state logical mvnest - dyn_nmm 1 - rm "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" +# flag for nest movement +state logical moved - misc 1 - - + +# Location of the SOUTH-WEST nested pointed in terms of parent grid + +state integer IIH ij dyn_nmm 1 - - +state integer JJH ij dyn_nmm 1 - - +state integer IIV ij dyn_nmm 1 - - +state integer JJV ij dyn_nmm 1 - - + +# Bi-linear weights + +state real HBWGT1 ij dyn_nmm 1 - - +state real HBWGT2 ij dyn_nmm 1 - - +state real HBWGT3 ij dyn_nmm 1 - - +state real HBWGT4 ij dyn_nmm 1 - - +state real VBWGT1 ij dyn_nmm 1 - - +state real VBWGT2 ij dyn_nmm 1 - - +state real VBWGT3 ij dyn_nmm 1 - - +state real VBWGT4 ij dyn_nmm 1 - - + +# +state real HLON ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) +state real HLAT ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) +state real VLON ij dyn_nmm 1 - - +state real VLAT ij dyn_nmm 1 - - + +# +rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" +rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" + +state real PSTD k dyn_nmm 1 Z - +state integer KZMAX - dyn_nmm - - r +state real Z3D ikj dyn_nmm 1 Z rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Z3D" "HEIGHT ARRAY FIELD VALID FOR PARENT ONLY" +state real T3D ikj dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS" +state real Q3D ikj dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS" +state real HRES_FIS ij dyn_nmm 1 - r "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" + + +# +# module_LOOPS +# +state integer lmh ij dyn_nmm 1 - irh "LMH" "Lowest model layer at mass points from domain top" "" +state integer lmv ij dyn_nmm 1 - irh "LMV" "Lowest model layer at velocity points from domain top" "" +# +# module_MASKS +# +state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" +state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" +state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" +state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" +state real sm ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 - irh "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" +state real htm ikj dyn_nmm 1 - rh "HTM" "Height mask; =1 at all mass points above ground" "" +state real vtm ikj dyn_nmm 1 - rh "VTM" "Velocity mask; =1 at all velocity points above ground" "" +# +# module_VRBLS +# +state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" +state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" +state real pd ijb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_mass_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX)f=(nmm_bdymass_hinterp:dt,pdnest_b,pdnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX) "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" +state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" +#state real q ikjb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:dt,qnest_b,qnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q" "Specific humidity" "kg kg-1" +#state real t ikjb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_p2hyb_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,Q,HRES_FIS,PD,PSTD,PDTOP,PT,ETA1,ETA2,DETA1,DETA2)f=(nmm_bdy_p2hyb:dt,tnest_b,tnest_bt,Z3D,qnest_b,HRES_FIS,pdnest_b,PSTD,PDTOP,PT,ETA1,ETA2,DETA1,DETA2) "T" "Sensible temperature" "K" +state real t ikjb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,tnest_b,tnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "T" "Sensible temperature" "K" +state real q ikjb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,qnest_b,qnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "Q" "Specific humidity" "kg kg-1" +state real u ikjb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:dt,unest_b,unest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "U" "U component of wind" "m s-1" +state real v ikjb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:dt,vnest_b,vnest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "V" "V component of wind" "m s-1" +state real told ikj dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" +state real uold ikj dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" +state real vold ikj dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" +# +# module_DYNAM +# +state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" +state real wpdar ij dyn_nmm 1 - ir +state real cpgfu ij dyn_nmm 1 - ir +state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" +state real fcp ij dyn_nmm 1 - ir +state real fdiv ij dyn_nmm 1 - ir +state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" +state real fad ij dyn_nmm 1 - ir +state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" +state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" +state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" +state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" +state real aeta k dyn_nmm 1 - i01r +state real f4q2 k dyn_nmm 1 - ir +state real etax k dyn_nmm 1 - i01r +state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" +state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" +state real eta1 k dyn_nmm 1 - i01rh "ETA1" "Interface sigma value in pressure domain" "" +state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" +state real eta2 k dyn_nmm 1 - i01rh "ETA2" "Interface sigma value in sigma domain" "" +state real em q dyn_nmm 1 - ir +state real emt q dyn_nmm 1 - ir +state real adt ikj dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" +state real adu ikj dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" +state real adv ikj dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +state real em_loc q dyn_nmm 1 - r +state real emt_loc q dyn_nmm 1 - r +state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" +state real cpgfv - dyn_nmm - - ir +state real en - dyn_nmm - - ir +state real ent - dyn_nmm - - ir +state real f4d - dyn_nmm - - ir +state real f4q - dyn_nmm - - ir +state real ef4t - dyn_nmm - - ir +state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" +state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" +state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" +state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" +# +# module_CONTIN +# +state real pdsl ij dyn_nmm 1 - - "PDSL" "Sigma-domain pressure at sigma=1" "Pa" +state real pdslo ij dyn_nmm 1 - - "PDSLO" "PDSL from previous timestep" "Pa" +state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" +state real div ikj dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" +state real few ikj dyn_nmm 1 - - "FEW" "Integrated east-west mass flux" "Pa m2 s-1" +state real fne ikj dyn_nmm 1 - - "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" +state real fns ikj dyn_nmm 1 - - "FNS" "Integrated north-south mass flux" "Pa m2 s-1" +state real fse ikj dyn_nmm 1 - - "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +state real omgalf ikj dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" +state real petdt ikj dyn_nmm 1 - - "PETDT" "Vertical mass flux" "Pa s-1" +state real rtop ikj dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" +# +# module_PVRBLS +# +state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" +state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" +state real ustar ij dyn_nmm 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "USTAR" "Friction velocity" "m s-1" +state real z0 ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Z0" "Roughness height" "m" +state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" +state real ths ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THS" "Surface potential temperature" "K" +state real mavail ij dyn_nmm 1 - i +state real qsh ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QS" "Surface specific humidity" "kg kg-1" +state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" +state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" +state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" +state real aprec ij dyn_nmm 1 - rh +state real acprec ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ACPREC" "Accumulated total precipitation" "m" +state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" +state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" +state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" +state real accliq ij dyn_nmm 1 - r +state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water snow amount" "m" +state real si ij dyn_nmm 1 - irh "SI" "Snow depth" "m" +state real cldefi ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CLDEFI" "Convective cloud efficiency" "" +state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" +state real rf ij dyn_nmm 1 - r +state real th10 ij dyn_nmm 1 - irh "TH10" "10-m potential temperature" "K" +state real q10 ij dyn_nmm 1 - irh "Q10" "10-m specific humidity" "kg kg-1" +state real pshltr ij dyn_nmm 1 - irh "PSHLTR" "2-m pressure" "Pa" +state real tshltr ij dyn_nmm 1 - irh "TSHLTR" "2-m sensible temperature" "K" +state real qshltr ij dyn_nmm 1 - irh "QSHLTR" "2-m specific humidity" "kg kg-1" +state real q2 ikjb dyn_nmm 1 - irhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:dt,q2nest_b,q2nest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" +state real t_adj ikj dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "T_ADJ" "T change due to precip in phys step" "K" +state real t_old ikj dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" +state real zero_3d ikj dyn_nmm 1 - r +state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" +state real AKHS_OUT ij dyn_nmm 1 - h "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" +state real AKMS_OUT ij dyn_nmm 1 - h "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" +# +# module_PHYS +# +state real albase ij dyn_nmm 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBASE" "Base albedo" "" +state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" +state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" +state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" +state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" +state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" +state real epsr ij dyn_nmm 1 - ir "EPSR" "Radiative emissivity" "" +state real gffc ij dyn_nmm 1 - ir +state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" +state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" +state real NMM_TSK ij dyn_nmm 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TSK" "Skin temperature" "K" +state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" +state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" +state real mxsnal ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "MXSNAL" "Maximum deep snow albedo" "" +state real radin ij dyn_nmm 1 - r +state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" +state real sigt4 ij dyn_nmm 1 - rh "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" +state real tg ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TGROUND" "Deep ground soil temperature" "K" +state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" +state integer lvl ij dyn_nmm 1 - ir +# +# module_CLDWTR.F +# +state real cwm ikjb dyn_nmm 1 - rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:dt,cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CWM" "Total condensate" "kg kg-1" +state real f_ice ikj dyn_nmm 1 - rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_ICE" "Frozen fraction of CWM" "" +state real f_rain ikj dyn_nmm 1 - rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RAIN" "Rain fraction of liquid part of CWM" "" +state real f_rimef ikj dyn_nmm 1 - rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RIMEF" "Rime factor" "" +state real cldfra ikj dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" +state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" +state real cfrach ij dyn_nmm 1 - rh "CFRACH" "High cloud fraction" "" +state real cfracl ij dyn_nmm 1 - rh "CFRACL" "Low cloud fraction" "" +state real cfracm ij dyn_nmm 1 - rh "CFRACM" "Middle cloud fraction" "" +state logical micro_start - dyn_nmm - - - +# +# module_SOIL.F +# +state integer islope ij dyn_nmm 1 - i01rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLOPE" +state real dzsoil k dyn_nmm 1 - ir "DZSOIL" "Thickness of soil layers" "m" +state real rtdpth k dyn_nmm 1 - i01r +state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Thickness of soil layers" "m" +state real cmc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CMC" "Canopy moisture" "m" +state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" +state real pctsno ij dyn_nmm 1 - irh +state real soiltb ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SOILTB" "Deep ground soil temperature" "K" +state real vegfrc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRC" "Vegetation fraction" "" +state real shdmin ij dyn_nmm 1 - - +state real shdmax ij dyn_nmm 1 - - +state real sh2o ilj dyn_nmm 1 Z irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SH2O" "Unfrozen soil moisture volume fraction" "" +state real smc ilj dyn_nmm 1 Z irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "STC" "Soil temperature" "K" +# +# module_NHYDRO.F +# +state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" +state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" +state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" +state real dwdt ikj dyn_nmm 1 - rd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" +state real pdwdt ikj dyn_nmm 1 - r +state real pint ikj dyn_nmm 1 Z rh "PINT" "Model layer interface pressure" "Pa" +state real w ikj dyn_nmm 1 Z rh "W" "Vertical velocity" "m s-1" +state real z ikj dyn_nmm 1 Z - "Z" "Distance from ground" "m" +# +# module_ACCUM.F +# +state real acfrcv ij dyn_nmm 1 - h "ACFRCV" "Accum convective cloud fraction" "" +state real acfrst ij dyn_nmm 1 - h "ACFRST" "Accum stratiform cloud fraction" "" +state real ssroff ij dyn_nmm 1 - h "SSROFF" "Surface runoff" "mm" +state real bgroff ij dyn_nmm 1 - h "BGROFF" "Subsurface runoff" "mm" +state real rlwin ij dyn_nmm 1 - rh "RLWIN" "Downward longwave at surface" "W m-2" +state real rlwout ij dyn_nmm 1 - - +state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" +state real alwin ij dyn_nmm 1 - h "ALWIN" "Accum LW down at surface" "W m-2" +state real alwout ij dyn_nmm 1 - h "ALWOUT" "Accum RADOT (see above)" "W m-2" +state real alwtoa ij dyn_nmm 1 - h "ALWTOA" "Accum RLWTOA" "W m-2" +state real rswin ij dyn_nmm 1 - rh "RSWIN" "Downward shortwave at surface" "W m-2" +state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" +state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" +state real rswtoa ij dyn_nmm 1 - - "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +state real aswin ij dyn_nmm 1 - h "ASWIN" "Accum SW down at surface" "W m-2" +state real aswout ij dyn_nmm 1 - h "ASWOUT" "Accum RSWOUT" "W m-2" +state real aswtoa ij dyn_nmm 1 - h "ASWTOA" "Accum RSWTOA" "W m-2" +state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" +state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" +state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" +state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" +state real sfcuvx ij dyn_nmm 1 - rh +state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" +state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" +state real tlmin ij dyn_nmm 1 - h +state real tlmax ij dyn_nmm 1 - h +state real rlwtt ikj dyn_nmm 1 - rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWTT" "Longwave temperature tendency" "K s-1" +state real rswtt ikj dyn_nmm 1 - rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWTT" "Shortwave temperature tendency" "K s-1" +state real tcucn ikj dyn_nmm 1 - h "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ikj dyn_nmm 1 - h "TRAIN" "Accum stratiform temp tendency" "K s-1" +state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" +state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" +state integer nphs0 - dyn_nmm - - rh +state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" +state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" +state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" +state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" +state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" +state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" +state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" +state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" +state real aratim - dyn_nmm - - ir +state real acutim - dyn_nmm - - irh +state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" +state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" +state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" +state real aphtim - dyn_nmm - - irh +# +# module_INDX.F +# +state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" +state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" +state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" +state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" +state integer irad i dyn_nmm 1 - - +#definitions for NMM east-west orientation on E grid +state integer iheg q dyn_nmm 1 - - +state integer ihwg q dyn_nmm 1 - - +state integer iveg q dyn_nmm 1 - - +state integer ivwg q dyn_nmm 1 - - +dimspec r - constant=2000 c # a little crude right now +state integer iradg r dyn_nmm 1 - - +dimspec z - constant=(-3:3) c +dimspec n - constant=(0:6) c +state integer indx3_wrk zqn dyn_nmm 1 - - "INDX3_WRK" "Array of 3rd (J) indices for local arrays" "" +state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" +state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" +state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" +state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" +state integer iup_h ij dyn_nmm 1 - - +state integer iup_v ij dyn_nmm 1 - - +state integer iup_adh ij dyn_nmm 1 - - +state integer iup_adv ij dyn_nmm 1 - - +state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" + +# +# table entries are of the form +#
+# +# Mask for moving nest interpolations +state integer imask_nostag ij misc - +state integer imask_xstag ij misc X +state integer imask_ystag ij misc Y +state integer imask_xystag ij misc XY +# +#--------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#--------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" +state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" +state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" +state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" +state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" +state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" +state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" +state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" +state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" +state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" +state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" +state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" +state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" +state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" +state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" +state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" +state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" +state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" +state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" +state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" +state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" +state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" +state real st000010 ij misc 1 - i1 "ST000010" "description" "units" +state real st010040 ij misc 1 - i1 "ST010040" "description" "units" +state real st040100 ij misc 1 - i1 "ST040100" "description" "units" +state real st100200 ij misc 1 - i1 "ST100200" "description" "units" +state real st010200 ij misc 1 - i1 "ST010200" "description" "units" +state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" +state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" +state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" +state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" +state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" +state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" +state real landmask ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "LANDMASK" "description" "units" +state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" +state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" +state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" +state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" +state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" +state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" +state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" +state real toposoil ij misc 1 - i1d=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TOPOSOIL" "description" "units" +state real landusef iuj misc 1 Z - "" "description" "units" +state real soilctop isj misc 1 Z - "" "description" "units" +state real soilcbot isj misc 1 Z - "" "description" "units" + +#------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#------------------------------------------------------------------------------------------------------------------------------- + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + + +# Moist Scalars - both height and mass coordinate models +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjft moist 1 - - - +state real qv ikjft moist 1 - r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjft moist 1 - r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjft moist 1 - r "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjft moist 1 - r "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjft moist 1 - r "QGRAUP" "Graupel mixing ratio" "kg kg-1" +# +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qni ikjftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +## Chem Scalars - both height and mass coordinate models +# +state real - ikjft chem 1 - - - + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# specified LBC arrays, first, Eulerian height coordinate model + + +# specified LBC arrays, next, Eulerian mass coordinate model + + +# specified LBC variables shared between the mass and height coordinate models + + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim + + +# 2m and 10m output diagnostics + + +# lsm State Variables + +state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" +state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" + + +# MYJ PBL variables + + +# gfdl (eta) radiation State Variables + +# eta microphpysics State Variables + + +# new eta microphpysics State Variables + +# some mass-coordinate-model-specific variables + + + + + + +# was em_only + +################################################################# +# Physics Variables (em core) + + + +################################################################# +# Physics Variables (eh core) ; should be same as em + + + + +################################################################# +# variables added for CHEMISTRY compatibility with ARW core - kludge +################################################################# +state real GSW ij misc 1 - - "" "" +state real XLAT ij misc 1 - - "" "" +state real XLONG ij misc 1 - - "" "" +state real XLAND ij misc 1 - - "" "" +state real RAINCV ij misc 1 - - "" "" + +################################################################# +# other misc variables (all cores) +################################################################# + +# added for surface_driver +state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" +state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" +state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" +state real U10 ij misc 1 - irh "U10" "U at 10 M" " " +state real V10 ij misc 1 - irh "V10" "V at 10 M" " " +state real XICE ij misc 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "XICE" "SEA ICE" "" +state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" +state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" +state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" +state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" +state integer IVGTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" +state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" +state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" +state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "" +state real RMOL ij misc 1 - ir "RMOL" "" "" +state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" +state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" +state real SST ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SST" "SEA SURFACE TEMPERATURE" "K" +state real WEASD ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" +state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" + +state real tke_myj ikj misc 1 - rh "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - h "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - rh "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" +state real THZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" +state real QZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" +state real UZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real VZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +# added as state for HALO_NMM_MG2, mep +state real psfc_out ij dyn_nmm 1 - - +# added as state for HALO_NMM_TURBL, jm +state real UZ0h ij misc 1 - - +state real VZ0h ij misc 1 - - +state real dudt ikj misc 1 - - +state real dvdt ikj misc 1 - - + +state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" +state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" +state real HTOP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" +state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" +state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" +state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" +state REAL CUPPT ij misc 1 - rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" +state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a +state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" + +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K/sec" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg/sec" +state real SNOWH ij misc 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWH" "PHYSICAL SNOW DEPTH" "" +state real RHOSN ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# added state for etampnew microphysics (needed for restarts) +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - - +state integer landuse_lucats - misc - - - +state integer landuse_luseas - misc - - - +state integer landuse_isn - misc - - - +state real lu_state p misc - - - + + +################################################################# +# + +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - h "itimestep" "" "" +state real xtime - - - - h "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" + +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 5, WHAT INPUT STREAM IS FINE GRID IC FROM" "" + +include registry.io_boilerplate +include registry.io_boilerplate_NMM + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" +rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 0 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +# WPS related +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real ptsgm namelist,domains 1 42000. +rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" + + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" + + +# nmm variables +rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" +rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" +rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" +rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" +rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" +rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" +rconfig real tprec namelist,physics max_domains 3. irh "tprec" "number of hours in bucket for total precipitation" +rconfig real theat namelist,physics max_domains 6. irh "theat" "number of hours in bucket for gridscale and convective heating rates" +rconfig real tclod namelist,physics max_domains 6. irh "tclod" "number of hours in bucket for cloud amounts" +rconfig real trdsw namelist,physics max_domains 6. irh "trdsw" "number of hours in bucket for short wave fluxes" +rconfig real trdlw namelist,physics max_domains 6. irh "trdlw" "number of hours in bucket for long wave fluxes" +rconfig real tsrfc namelist,physics max_domains 6. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" +rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" +rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" +rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" +rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 1 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" +rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 100. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_nmm dyn_opt==4 - - + + +#### 9. Edit the Registry file to set up '5' as the value of the +**** namelist variable dyn_opt that means to select our exp dyncore. +package dyn_exp dyn_opt==5 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qs +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - - +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - - +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package nmmlsmscheme sf_surface_physics==99 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# NMM communications + +#halo HALO_NMM_INIT_1 dyn_nmm 120:LMH,LMV,HBM2 +halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 +halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 +halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE,HTM +halo HALO_NMM_INIT_4 dyn_nmm 120:VTM,DX_NMM,WPDAR +halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP +halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F +halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT +halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG +halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE +#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP +halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV +#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC +halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC +halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES +halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U +halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2 +halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN +halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar +halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG +halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN +halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH +halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT +halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 +halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR +halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO +halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF +halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB +halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT +halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN +halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 +halo HALO_NMM_INIT_28 dyn_nmm 120:SR +halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ +halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW +halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF +halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX +halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP +halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT +halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT +halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC +halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO +halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT +halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD + +halo HALO_NMM_A dyn_nmm 24:pd,t,u,v,q,cwm,dwdt,div;24:pint +halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar +halo HALO_NMM_B dyn_nmm 24:div +halo HALO_NMM_C dyn_nmm 8:u,v +halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_E dyn_nmm 24:petdt +halo HALO_NMM_F dyn_nmm 24:t,u,v +halo HALO_NMM_F1 dyn_nmm 80:pdslo +halo HALO_NMM_G dyn_nmm 24:u,v;24:z +halo HALO_NMM_H dyn_nmm 24:w,lmh +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar +halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm +halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_K dyn_nmm 8:q2;24:t,u,v,q,w,z +halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 +halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_MG dyn_nmm 8:ht_gc +halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out +halo HALO_NMM_MG3 dyn_nmm 8:p_gc_xzy + +halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 +halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt + +# following halos added for nesting purpose (gopal's doing): + +halo HALO_NMM_ZZ dyn_nmm 8:pdnest_b,unest_b,vnest_b,tnest_b,qnest_b,cwmnest_b,q2nest_b,pdnest_bt,unest_bt,vnest_bt,tnest_bt,qnest_bt,cwmnest_bt,q2nest_bt +halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws +halo HALO_NMM_INTERP_DOWN1 dyn_nmm 120:sm,fis,t,u,v,q,q2,z3d,q3d,t3d,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef +halo HALO_NMM_FORCE_DOWN1 dyn_nmm 120:t,u,v,q,q2,cwm,z3d,q3d,t3d #,qv,qc,qr,qi,qs,qg +halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4 + diff --git a/wrfv2_fire/Registry/Registry.backup b/wrfv2_fire/Registry/Registry.backup new file mode 100644 index 00000000..a5ab04ca --- /dev/null +++ b/wrfv2_fire/Registry/Registry.backup @@ -0,0 +1,1450 @@ +## WARNING: this file is autogenerated from Registry/Registry.EM. Changes may be lost +# Registry file, EM +# +# At the present time this file is managed manually and edited by hand. +# +################################################################################ +# Dimension specifications +# +# This section of the Registry file is used to specify the dimensions +# that will be used to define arrays. Dim is the one-letter name of the +# dimension. How defined can either be "standard_domain", which means +# that the dimension (1) is one of the three spatial dimensions and (2) +# it will be set using the standard namelist mechanism and domain data +# structure dimension fields (e.g. sd31,ed31,sd32...). +# +# Order refers to which of the three sets of just-mentioned internal +# dimension variables the dimension is referred to by in the driver. +# That is, is it the first, second, or third dimension. The registry +# infers the mapping of its internal dimensions according to the +# combination of Order and Coord-axis that are specified in this table. +# Note that it is all right to more than one dimension name for, say, the +# x dimension. However, the Order and Coord-axis relationship must be +# consistent throughout. +# +# Note: these entries do not enforce storage order on a particular field. +# That is determined by the dimension strings for each field. But it does +# relate the dimspec to the internal data structures that the driver uses +# to maintain the three physical domain dimensions. +# +# "How defined" can also specify the name of a namelist variable from which +# the definition for the dimension will come; this is specified as +# "namelist=". The namelist variable must have been +# defined as an integer and with only one entry in the rconfig table. Or +# a constant can be specified. The coordinate axis for the dimension is +# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is +# the descriptive name of the dimension that will be included in the +# metadata in data sets. Note that the b, f, and t modifiers that appear +# as the last characters of dimension strings used # in state and # i1 +# registry definitions are not dimensions and do not need to be declared +# here. +# + +# Available characters for dimspec: 0123456789@%+=|?.!&[{}] + +#
+dimspec i 1 standard_domain x west_east +dimspec j 3 standard_domain y south_north +dimspec k 2 standard_domain z bottom_top +dimspec l 2 namelist=num_soil_layers z soil_layers +dimspec u 2 namelist=num_land_cat z land_cat +dimspec s 2 namelist=num_soil_cat z soil_cat +dimspec p - constant=7501 c microphysics_rstrt_state +dimspec w - namelist=spec_bdy_width c spec_bdy_width +dimspec e 3 namelist=ensdim z ensemble dimension +dimspec z - namelist=max_obs c max_obs +dimspec h - namelist=nobs_err_flds c nobs_err_flds +dimspec r - namelist=nobs_ndg_vars c nobs_ndg_vars +dimspec g 2 namelist=num_metgrid_levels z num_metgrid_levels +dimspec m 2 constant=12 z months_per_year +dimspec a - namelist=cam_abs_dim1 c cam_abs_dim1 +dimspec c - namelist=cam_abs_dim2 z cam_abs_dim2 +dimspec q 2 namelist=levsiz z levsiz +dimspec d 2 namelist=paerlev z paerlev +dimspec v - constant=1 z one + + +################################################################################ +################################################################################ +################################################################################ + +#state real floob ikjb dyn_em 1 - +#state real floob_x ikjx dyn_em 1 - +#state real floob_y ikjy dyn_em 1 - +#xpose FLOOB dyn_em floob,floob_x,floob_y + +#state real xxx ijk misc 2 - h6ud +#halo HALO_FLOOB dyn_em 4:xxx_2 + +# Lines that start with the word 'state' form a table that is +# used by the script use_registry to generate module_state_descript.F +# and other files. Also see documentation in use_registry. +# +# table entries are of the form +#
+# + +# It is required that LU_INDEX appears before any variable that is +# interpolated with a mask, as lu_index supplies that mask. +# this next 1 is for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" + +# +# Variables from WPS +# +state real u_gc igj dyn_em 1 XZ i1 "UU" "x-wind component" "m s-1" +state real v_gc igj dyn_em 1 YZ i1 "VV" "y-wind component" "m s-1" +state real t_gc igj dyn_em 1 Z i1 "TT" "temperature" "K" +state real rh_gc igj dyn_em 1 Z i1 "RH" "relative humidity" "%" +state real ght_gc igj dyn_em 1 Z i1 "GHT" "geopotential height" "m" +state real p_gc igj dyn_em 1 Z i1 "PRES" "pressure" "Pa" +state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" +state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" +state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" +state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" +state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" +state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" +state real pslv_gc ij dyn_em 1 - i1 "PMSL" "sea level pressure" "Pa" +state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" +state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" +state real psfc_gc ij dyn_em 1 - - "PSFC_GC" "surface pressure" "Pa" +state real intq_gc ij dyn_em 1 - - "INTQ" "integrated mixing ratio" "Pa" +state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" +state real qv_gc igj dyn_em 1 Z i1 "QV" "mixing ratio" "kg kg-1" +#state real qr_gc igj dyn_em 1 Z i1 "QR" "rain water mixing ratio" "kg kg-1" +#state real qc_gc igj dyn_em 1 Z i1 "QC" "cloud water mixing ratio" "kg kg-1" +#state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" +#state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" +#state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# +# Variables for Eulerian mass coordinate dynamics + +# Velocities +# +# U Vel +state real u ikjb dyn_em 2 X \ + i01rhusdf=(bdy_interp:dt) "U" "x-wind component" "m s-1" +state real ru ikj dyn_em 1 X - "MU_U" "mu-coupled u" "Pa m s-1" +state real ru_m ikj dyn_em 1 X - "ru_m" "" "" +state real ru_tend ikj dyn_em 1 X - "ru_tend" "" "" +i1 real ru_tendf ikj dyn_em 1 X +state real u_save ikj dyn_em 1 X - "u_save" +# +# V Vel +state real v ikjb dyn_em 2 Y \ + i01rhusdf=(bdy_interp:dt) "V" "y-wind component" "m s-1" +state real rv ikj dyn_em 1 Y - "MU_V" "mu-coupled v" "Pa m s-1" +state real rv_m ikj dyn_em 1 Y - "rv_m" +state real rv_tend ikj dyn_em 1 Y - "rv_tend" +i1 real rv_tendf ikj dyn_em 1 Y +state real v_save ikj dyn_em 1 Y - "v_save" +# +# Vertical Vel +state real w ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "w" "z-wind component" "m s-1" +state real ww ikj dyn_em 1 Z r "ww" "mu-coupled eta-dot" "Pa s-1" +state real rw ikj dyn_em 1 Z - "rw" "mu-coupled w" "Pa m s-1" +i1 real ww1 ikj dyn_em 1 Z +state real ww_m ikj dyn_em 1 Z r "ww_m" "time-avg mu-coupled eta-dot" "Pa s-1" +i1 real wwp ikj dyn_em 1 Z +i1 real rw_tend ikj dyn_em 1 Z +i1 real rw_tendf ikj dyn_em 1 Z +i1 real w_save ikj dyn_em 1 Z + +# Geopotential +state real ph ikjb dyn_em 2 Z \ + irhusdf=(bdy_interp:dt) "ph" "perturbation geopotential" "m2 s-2" +state real phb ikj dyn_em 1 Z irhdus "phb" "base-state geopotential" "m2 s-2" +state real phb_fine ikj dyn_em 1 Z - "phb_fine" "for nesting, temp holding interpolated coarse grid phb" "m2 s-2" +state real ph0 ikj dyn_em 1 Z r "ph0" "initial geopotential" "m2 s-2" +state real php ikj dyn_em 1 Z r "php" "geopotential" "m2 s-2" +i1 real ph_tend ikj dyn_em 1 Z +i1 real ph_tendf ikj dyn_em 1 Z +i1 real ph_save ikj dyn_em 1 Z + +# Potential Temperature +state real t ikjb dyn_em 2 - \ + i01rhusdf=(bdy_interp:dt) "t" "perturbation potential temperature (theta-t0)" "K" + +state real t_init ikj dyn_em 1 - ir "t_init" "initial potential temperature" "K" +i1 real t_tend ikj dyn_em 1 - +i1 real t_tendf ikj dyn_em 1 - +state real tp ikj dyn_em 2 - +i1 real t_2save ikj dyn_em 1 - +state real t_save ikj dyn_em 1 - "t_save" +# + + +# Mass +state real mu ijb dyn_em 2 - \ + irhusdf=(bdy_interp:dt) "mu" "perturbation dry air mass in column" "Pa" +state real mub ij dyn_em 1 - irhdus "mub" "base state dry air mass in column" "Pa" +state real mub_fine ij dyn_em 1 - - "mub_fine" "nest temp, holds interpolated coarse grid mub" "Pa" +state real mu0 ij dyn_em 1 - i01rdu "mu0" "initial dry mass in column" "Pa" +state real mudf ij dyn_em 1 - - "mudf" "" "" +state real muu ij dyn_em 1 - "muu" +i1 real muus ij dyn_em 1 - +state real muv ij dyn_em 1 - "muv" +i1 real muvs ij dyn_em 1 - +state real mut ij dyn_em 1 - "mut" +state real muts ij dyn_em 1 - "muts" +i1 real muave ij dyn_em 1 - +i1 real mu_save ij dyn_em 1 - +i1 real mu_tend ij dyn_em 1 - +i1 real mu_tendf ij dyn_em 1 - + +#diagnostic for looking at nest position in output. A mungy version of terrain height. +state real nest_pos ij misc 1 - rhu=(mark_domain) "NEST_POS" +state real nest_mask ij misc 1 - ru=(mark_domain) "NEST_MASK" "LOCATION OF NEST IF ANY" +state real ht_coarse ij misc 1 - r - "STORAGE FOR LOW-RES TERRAIN" + + +# TKE +state real tke ikj dyn_em 2 - r "tke" "TURBULENCE KINETIC ENERGY" "m2 s-2" +i1 real tke_tend ikj dyn_em 1 - + +# Pressure and Density +state real p ikj dyn_em 1 - rh "p" "perturbation pressure" "Pa" +state real al ikj dyn_em 1 - r "al" "inverse perturbation density" "m3 kg-1" +state real alt ikj dyn_em 1 - r "alt" "inverse density" "m3 kg-1" +state real alb ikj dyn_em 1 - rdus "alb" "inverse base density" "m3 kg-1" +state real zx ikj dyn_em 1 X - " " " " " " +state real zy ikj dyn_em 1 Y - " " " " " " +state real rdz ikj dyn_em 1 Z - " " " " " " +state real rdzw ikj dyn_em 1 Z - " " " " " " +state real pb ikj dyn_em 1 - rhdus "pb" "BASE STATE PRESSURE " "Pa" + +# +# Other dyn +# +i1 real advect_tend ikj dyn_em 1 - +i1 real alpha ikj dyn_em 1 - +i1 real a ikj dyn_em 1 - +i1 real gamma ikj dyn_em 1 - +i1 real c2a ikj dyn_em 1 - - +i1 real rho ikj dyn_em 1 - - +i1 real phm ikj dyn_em 1 - - +i1 real cqu ikj dyn_em 1 - - +i1 real cqv ikj dyn_em 1 - - +i1 real cqw ikj dyn_em 1 - - +i1 real pm1 ikj dyn_em 1 - - +state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" +state real potevp ij dyn_em 1 - h "potevp" "whatever" +state real snopcx ij dyn_em 1 - h "snopcx" "whatever" +state real soiltb ij dyn_em 1 - h "soiltb" "whatever" +state real fnm k dyn_em 1 - irh "fnm" "upper weight for vertical stretching" "" +state real fnp k dyn_em 1 - irh "fnp" "lower weight for vertical stretching" "" +state real rdnw k dyn_em 1 - irh "rdnw" "inverse d(eta) values between full (w) levels" "" +state real rdn k dyn_em 1 - irh "rdn" "inverse d(eta) values between half (mass) levels" "" +state real dnw k dyn_em 1 - irh "dnw" "d(eta) values between full (w) levels" "" +state real dn k dyn_em 1 - irh "dn " "d(eta) values between half (mass) levels" "" +state real znu k dyn_em 1 - irh "znu" "eta values on half (mass) levels" "" +state real znw k dyn_em 1 Z i01rh "znw" "eta values on full (w) levels" "" +state real t_base k dyn_em 1 - ir "t_base" "BASE STATET T IN IDEALIZED CASES" "K" +state real z ikj dyn_em 1 - - " " " " " " +i1 real mu_3d ikj dyn_em 1 - +i1 real z_at_w ikj dyn_em 1 Z +state real cfn - misc - - irh "cfn" "extrapolation constant" "" +state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" +state integer step_number - misc - - ir "step_number" "" + +# 2m and 10m output diagnostics +state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" +state real TH2 ij misc 1 - irhd "TH2" "POT TEMP at 2 M" "K" +state real PSFC ij misc 1 - i01rh "PSFC" "SFC PRESSURE" "Pa" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real U10 ij misc 1 - irh01d "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - irh01d "V10" "V at 10 M" "m s-1" + +# these next 4 are for observational nudging +state real uratx ij misc 1 - ir "URATX" "Ratio of U over U10 on mass points " "dimensionless" +state real vratx ij misc 1 - ir "VRATX" "Ratio of V over V10 on mass points " "dimensionless" +state real tratx ij misc 1 - ir "TRATX" "Ratio of T over TH2 on mass points " "dimensionless" +state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" + +# Other +state real rdx - misc - - irh "rdx" "INVERSE X GRID LENGTH" "" +state real rdy - misc - - irh "rdy" "INVERSE Y GRID LENGTH" "" +state real dts - misc - - ir "dts" "SMALL TIMESTEP" "" +state real dtseps - misc - - ir "dtseps" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real resm - misc - - irh "resm" "TIME WEIGHT CONSTANT FOR SMALL STEPS" "" +state real zetatop - misc - - irh "zetatop" "ZETA AT MODEL TOP" "" +state real cf1 - misc - - irh "cf1" "2nd order extrapolation constant" "" +state real cf2 - misc - - irh "cf2" "2nd order extrapolation constant" "" +state real cf3 - misc - - irh "cf3" "2nd order extrapolation constant" "" +state integer number_at_same_level - - - - - "number_at_same_level" "" "" + +# State for derived time quantities. +state integer itimestep - - - - rh "itimestep" "" "" +state real xtime - - - - rh "xtime" "minutes since simulation start" "" +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + + +# input file descriptor for lbcs on parent domain +state integer lbc_fid - - - - - "lbc_fid" "" "" +# indicates if tiling has been computed +state logical tiled - - - - - "tiled" "" "" +# indicates if patches have been computed +state logical patched - - - - - "patched" "" "" +# indicates whether to read input from file or generate +#state logical input_from_file - - - - - "input_from_file" "" "" + +# Mask for moving nest interpolations +state integer imask_nostag ij misc 1 - +state integer imask_xstag ij misc 1 X +state integer imask_ystag ij misc 1 Y +state integer imask_xystag ij misc 1 XY +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# Scalar (4D) arrays + +# Moist Scalars +# +# The first line ensures that there will be identifiers named moist and +# moist_tend even if there are not any moist scalars (so the essentially +# dry code will will still link properly) +# +state real - ikjftb moist 1 - - - +state real qv ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ikjftb moist 1 - \ + i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" + +# Chem Scalars +state real - ikjftb chem 1 - - - + +# Other Scalars +state real - ikjftb scalar 1 - - - +state real qndrop ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" +state real qni ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 - \ + i01rhusdf=(bdy_interp:dt) "CWM" "Total condensate mixing ratio" "kg kg-1" + +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- + +# Arrays for Specified LBCs (lbc arrays REMOVED; Boundary arrays are now specified with the state array; see above, 20050413 JM ) + +state real fcx w misc - - ir "fcx" "RELAXATION TERM FOR BOUNDARY ZONE" "" +state real gcx w misc - - ir "gcx" "2ND RELAXATION TERM FOR BOUNDARY ZONE" "" +state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" + +#------------------------------------------------------------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------------------------------------------------------------------- +# Physics Related State Varibles + +#------------------------------------------------------------------------------------------------------------------------------------------- +# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes +#------------------------------------------------------------------------------------------------------------------------------------------- + +state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" +state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" +state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" +state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" +state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" +state real sm000010 ij misc 1 - i1 "SM000010" "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010040 ij misc 1 - i1 "SM010040 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm040100 ij misc 1 - i1 "SM040100 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm100200 ij misc 1 - i1 "SM100200 " "LAYER SOIL MOISTURE" "m3 m-3" +state real sm010200 ij misc 1 - i1 "SM010200" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm000 ij misc 1 - i1 "SOILM000" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm005 ij misc 1 - i1 "SOILM005" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm020 ij misc 1 - i1 "SOILM020" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm040 ij misc 1 - i1 "SOILM040" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm160 ij misc 1 - i1 "SOILM160" "LAYER SOIL MOISTURE" "m3 m-3" +state real soilm300 ij misc 1 - i1 "SOILM300" "LAYER SOIL MOISTURE" "m3 m-3" +state real sw000010 ij misc 1 - i1 "SW000010" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010040 ij misc 1 - i1 "SW010040" "LAYER SOIL LIQUID" "m3 m-3" +state real sw040100 ij misc 1 - i1 "SW040100" "LAYER SOIL LIQUID" "m3 m-3" +state real sw100200 ij misc 1 - i1 "SW100200" "LAYER SOIL LIQUID" "m3 m-3" +state real sw010200 ij misc 1 - i1 "SW010200" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw000 ij misc 1 - i1 "SOILW000" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw005 ij misc 1 - i1 "SOILW005" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw020 ij misc 1 - i1 "SOILW020" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw040 ij misc 1 - i1 "SOILW040" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw160 ij misc 1 - i1 "SOILW160" "LAYER SOIL LIQUID" "m3 m-3" +state real soilw300 ij misc 1 - i1 "SOILW300" "LAYER SOIL LIQUID" "m3 m-3" +state real st000010 ij misc 1 - i1 "ST000010" "LAYER SOIL TEMPERATURE" "K" +state real st010040 ij misc 1 - i1 "ST010040" "LAYER SOIL TEMPERATURE" "K" +state real st040100 ij misc 1 - i1 "ST040100" "LAYER SOIL TEMPERATURE" "K" +state real st100200 ij misc 1 - i1 "ST100200" "LAYER SOIL TEMPERATURE" "K" +state real st010200 ij misc 1 - i1 "ST010200" "LAYER SOIL TEMPERATURE" "K" +state real soilt000 ij misc 1 - i1 "SOILT000" "LAYER SOIL TEMPERATURE" "K" +state real soilt005 ij misc 1 - i1 "SOILT005" "LAYER SOIL TEMPERATURE" "K" +state real soilt020 ij misc 1 - i1 "SOILT020" "LAYER SOIL TEMPERATURE" "K" +state real soilt040 ij misc 1 - i1 "SOILT040" "LAYER SOIL TEMPERATURE" "K" +state real soilt160 ij misc 1 - i1 "SOILT160" "LAYER SOIL TEMPERATURE" "K" +state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" +state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" +state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real shdmax ij misc 1 - i012r "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - i012r "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" +state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" +state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" +state real landusef iuj misc 1 Z i12 "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i12 "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i1 "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" +state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" + +#--------------------------------------------------------------------------------------------------------------------------------------- +# SI - end variables from netCDF format from Standard Initialization +#--------------------------------------------------------------------------------------------------------------------------------------- + +# soil model variables (Note that they are marked as staggered in the vertical dimension +# because they are "fully dimensioned" -- they use every element in that dim +state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" +state real ZS l misc - Z irh "ZS" "DEPTHS OF CENTERS OF SOIL LAYERS" "m" +state real DZS l misc - Z irh "DZS" "THICKNESSES OF SOIL LAYERS" "m" + +# urban model variables +state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" +state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" +state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" + +# lsm State Variables + +state real SMOIS ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" +state real SH2O ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" +state real XICE ij misc 1 - i012rhd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "XICE" "SEA ICE FLAG" "" +state real SMSTAV ij misc 1 - rd=(interp_mask_land_field:lu_index) "SMSTAV" "MOISTURE AVAILABILITY" "" +state real SMSTOT ij misc 1 - r "SMSTOT" "TOTAL SOIL MOISTURE" "m3 m-3" + +state real SFCRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "SFROFF" "SURFACE RUNOFF" "mm" +state real UDRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "UDROFF" "UNDERGROUND RUNOFF" "mm" +state integer IVGTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "IVGTYP" "DOMINANT VEGETATION CATEGORY" "" +state integer ISLTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" +state real VEGFRA ij misc 1 - i0125rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - r "SFCEVP" "SURFACE EVAPORATION" "kg m-2" +state real GRDFLX ij misc 1 - rh "GRDFLX" "GROUND HEAT FLUX" "W m-2" +state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" + +state real ACSNOW ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real SNOW ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real CANWAT ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" +state real SST ij misc 1 - i0125rhd=(interp_mask_water_field:lu_index) "SST" "SEA SURFACE TEMPERATURE" "K" +state integer IFNDSNOWH - misc 1 - i "FNDSNOWH" "SNOWH_LOGICAL" +state integer IFNDSOILW - misc 1 - i "FNDSOILW" "SOILW_LOGICAL" + +# urban state variables +state real TR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" +state real TG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" +state real TC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" +state real QC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" +state real UC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" +state real XXXR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" +state real XXXB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" +state real XXXG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" +state real XXXC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" +state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" +state real RN_URB2D ij misc 1 - r "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" +state real TS_URB2D ij misc 1 - r "TS_URB" "SKIN TEMPERATURE" "K" +state real FRC_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "FRC_URB" "URBAN FRACTION" "dimensionless" +state integer UTYPE_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "UTYPE_URB" "URBAN TYPE" "dimensionless" + + +# urban variables from radiation model +state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" +state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" + + +# RUC LSM +state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" +state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" + +# MRF PBL variables +i1 real PSIM ij misc 1 - - "PSIM" "SIMILARITY FUNCTION FOR MOMENTUM" "" +i1 real PSIH ij misc 1 - - "PSIH" "SIMILARITY FUNCTION FOR HEAT" "" +i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" +i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" +i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" + +# MYJ PBL variables +state real tke_myj ikj misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" +state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS " +state real CT ij misc 1 - r "CT" "COUNTERGRADIENT TERM" "K" +state real THZ0 ij misc 1 - r "THZ0" "POTENTIAL TEMPERATURE AT ZNT" "K" +state real Z0 ij misc 1 - r "Z0" "Background ROUGHNESS LENGTH" "m" +state real QZ0 ij misc 1 - r "QZ0" "SPECIFIC HUMIDITY AT ZNT" "kg kg-1" +state real UZ0 ij misc 1 - r "UZ0" "U WIND COMPONENT AT ZNT" "m s-1" +state real VZ0 ij misc 1 - r "VZ0" "V WIND COMPONENT AT ZNT" "m s-1" +state real QSFC ij misc 1 - r "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" +state real AKHS ij misc 1 - r "AKHS" "SFC EXCH COEFF FOR HEAT" "m s-1" +state real AKMS ij misc 1 - r "AKMS" "SFC EXCH COEFF FOR MOMENTUM" "m s-1" +state integer KPBL ij misc 1 - r "KPBL" "LEVEL OF PBL TOP" "" +i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" +i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real PSHLTR ij misc 1 - - "PSHLTR" "SHELTER PRESSURE FROM MYJ" "Pa" +i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" +i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" + +# gfdl (eta) radiation State Variables +state real HTOP ij misc 1 - r "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - r "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - r "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - r "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real CUTOP ij misc 1 - r "CUTOP" "TOP OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state real CUBOT ij misc 1 - r "CUBOT" "BOT OF CONVECTION LEVEL FROM CUMULUS PAR" "" +state REAL CUPPT ij misc 1 - r "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINC LAST CALL TO THE RADIATION" "" +state real rswtoa ij misc 1 - i +state real rlwtoa ij misc 1 - i +state real czmean ij misc 1 - i +state real cfracl ij misc 1 - i +state real cfracm ij misc 1 - i +state real cfrach ij misc 1 - i +state real acfrst ij misc 1 - i +state integer ncfrst ij misc 1 - i +state real acfrcv ij misc 1 - i +state integer ncfrcv ij misc 1 - i + +# cam radiation variables +state real - iqjf ozmixm 1 - - - +state real mth01 iqjf ozmixm 1 - - - +state real mth02 iqjf ozmixm 1 - - - +state real mth03 iqjf ozmixm 1 - - - +state real mth04 iqjf ozmixm 1 - - - +state real mth05 iqjf ozmixm 1 - - - +state real mth06 iqjf ozmixm 1 - - - +state real mth07 iqjf ozmixm 1 - - - +state real mth08 iqjf ozmixm 1 - - - +state real mth09 iqjf ozmixm 1 - - - +state real mth10 iqjf ozmixm 1 - - - +state real mth11 iqjf ozmixm 1 - - - +state real mth12 iqjf ozmixm 1 - - - +state real pin q misc 1 - - "PIN" "PRESSURE LEVEL OF OZONE MIXING RATIO" "millibar" +state real m_ps ij misc 2 - - "m_ps" "PS from MATCH on WRF grids" +state real - idjf aerosolc 2 - - - +state real SUL idjf aerosolc 2 - - "SUL" "SUL aerosol concentration" +state real SSLT idjf aerosolc 2 - - "SSLT" "SSLT aerosol concentration" +state real DUST1 idjf aerosolc 2 - - "DUST1" "DUST1 aerosol concentration" +state real DUST2 idjf aerosolc 2 - - "DUST2" "DUST2 aerosol concentration" +state real DUST3 idjf aerosolc 2 - - "DUST3" "DUST3 aerosol concentration" +state real DUST4 idjf aerosolc 2 - - "DUST4" "DUST4 aerosol concentration" +state real OCPHO idjf aerosolc 2 - - "OCPHO" "OCPHO aerosol concentration" +state real BCPHO idjf aerosolc 2 - - "BCPHO" "BCPHO aerosol concentration" +state real OCPHI idjf aerosolc 2 - - "OCPHI" "OCPHI aerosol concentration" +state real BCPHI idjf aerosolc 2 - - "BCPHI" "BCPHI aerosol concentration" +state real BG idjf aerosolc 2 - - "BG" "BG aerosol concentration" +state real VOLC idjf aerosolc 2 - - "VOLC" "VOLC aerosol concentration" +state real m_hybi d misc 1 - - "m_hybi" "MATCH hybi" + +# new eta microphpysics State Variables +state real F_ICE_PHY ikj misc 1 - rdu "F_ICE_PHY" "FRACTION OF ICE" "" +state real F_RAIN_PHY ikj misc 1 - rdu "F_RAIN_PHY" "FRACTION OF RAIN " "" +state real F_RIMEF_PHY ikj misc 1 - rdu "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" +state real qndropsource ikj misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" + +# Other Misc State Variables +state real h_diabatic ikj misc 1 - r "h_diabatic" "PREVIOUS TIMESTEP CONDENSATIONAL HEATING" "" +state real msft ij misc 1 - i012rhdu=(copy_fcnm) "MAPFAC_M" "Map scale factor on mass grid" "" +state real msfu ij misc 1 X i012rhdu=(copy_fcnm) "MAPFAC_U" "Map scale factor on u-grid" "" +state real msfv ij misc 1 Y i012rhdu=(copy_fcnm) "MAPFAC_V" "Map scale factor on v-grid" "" +state real f ij misc 1 - i012rhdu=(copy_fcnm) "f" "Coriolis sine latitude term" "s-1" +state real e ij misc 1 - i012rhdu=(copy_fcnm) "e" "Coriolis cosine latitude term" "s-1" +state real sina ij misc 1 - i012rhdu=(copy_fcnm) "SINALPHA" "Local sine of map rotation" "" +state real cosa ij misc 1 - i012rhdu=(copy_fcnm) "COSALPHA" "Local cosine of map rotation" "" +state real ht ij misc 1 - i012rhdus "HGT" "Terrain Height" "m" +state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" +state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" +state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" + +state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" +state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" +state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" +state real v_base k misc 1 - ir "v_base" "BASE STATE Y WIND IN IDEALIZED CASES" "" +state real qv_base k misc 1 - ir "qv_base" "BASE STATE QV IN IDEALIZED CASES" "" +state real z_base k misc 1 - ir "z_base" "BASE STATE HEIGHT IN IDEALIZED CASES" "" +state real u_frame - misc 1 - ir "u_frame" "FRAME X WIND" "m s-1" +state real v_frame - misc 1 - ir "v_frame" "FRAME Y WIND" "m s-1" +# p_top appears as metadata between SI and real but as a state variable in real and WRF +# since it is a scalar and a constant, it makes sense to have it as metadata -- there +# are, however, probably post-processing programs that expect to see it as an I/O record +# another problem: share/input_wrf tries to read this as metadata (fine for real reading +# SI, but with model reading real output, it generates a warning when debug is > 0 in +# namelist and causes repeated questions from users. A third problem is the potential +# collision between a metadata name and a field record in the I/O data +# resolve this how? Have the real program throw a switch to tell the code to get it +# from the metadata? Otherwise it's a field? +state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state real lat_ll_t - dyn_em - - irh "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - irh "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - irh "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - irh "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - irh "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - irh "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - irh "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - irh "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - irh "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - irh "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - irh "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - irh "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - irh "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - irh "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - irh "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - irh "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - irh "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - irh "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - irh "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - irh "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - irh "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - irh "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - irh "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - irh "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - irh "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - irh "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - irh "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - irh "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - irh "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - irh "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - irh "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - irh "lon_lr_d" "longitude lower right, massless point" "degrees" + +# Other physics variables + +state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME" "Pa K s-1" +state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RQICUTEN ikj misc 1 - r "RQICUTEN" "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real W0AVG ikj misc 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" + +state real RAINC ij misc 1 - rhdu "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" +state real RAINNC ij misc 1 - rhdu "RAINNC" "ACCUMULATED TOTAL GRID SCALE PRECIPITATION" "mm" +state real RAINCV ij misc 1 - r "RAINCV" "TIME-STEP CUMULUS PRECIPITATION" "mm" +state real RAINNCV ij misc 1 - r "RAINNCV" "TIME-STEP NONCONVECTIVE PRECIPITATION" "mm" +state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" +state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" +state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" +state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" +state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" +state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" +state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" +state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" +state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" +state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY" "mm hour-1" +state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE" "mm hour-1" +state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" +state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" +state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" +state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K s-1" +state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg s-1" + +state integer STEPCU - misc 1 - r "STEPCU" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS" "" + +state real RTHRATEN ikj misc 1 - rd "RTHRATEN" "COUPLED THETA TENDENCY DUE TO RADIATION" "Pa K s-1" +state real RTHRATENLW ikj misc 1 - r "RTHRATLW" "COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION" "Pa K s-1" +state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "Pa K s-1" +state real CLDFRA ikj misc 1 - r "CLDFRA" "CLOUD FRACTION" "" + +state real SWDOWN ij misc 1 - rhd "SWDOWN" "DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" + +# upward and downward clearsky and total diagnostic fluxes for CAM radiation +#state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +#state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +#state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +#state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +#state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" + +state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" +state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" +state real OLR ij misc 1 - rh "OLR" "TOA OUTGOING LONG WAVE" "W m-2" + +# these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling +# with wave model, only if compiled with -DMCELIO, JM 2003/05/29 +state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real ALBEDO ij misc 1 - rh "ALBEDO" "ALBEDO" +state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "" +state real EMISS ij misc 1 - r "EMISS" "SURFACE EMISSIVITY" "" + +state real CLDEFI ij misc 1 - r "CLDEFI" "precipitation efficiency in BMJ SCHEME" "" +state integer STEPRA - misc 1 - r "STEPRA" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS" "" + +state real RUBLTEN ikj misc 1 - r "RUBLTEN" "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RVBLTEN ikj misc 1 - r "RVBLTEN" "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" +state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION" "Pa K s-1" +state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" +state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" + +# State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. +state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" +state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" +state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" + +# State variables for landuse_init, Must be declared state because they are read in and needed for restarts. Had been SAVE vars in +# landuse_init (phys/module_physics_init.F) +state integer landuse_isice - misc - - r +state integer landuse_lucats - misc - - r +state integer landuse_luseas - misc - - r +state integer landuse_isn - misc - - r +state real lu_state p misc - - r + +i1 real th_phy ikj misc 1 - +i1 real pi_phy ikj misc 1 - +i1 real p_phy ikj misc 1 - +i1 real t_phy ikj misc 1 - +i1 real u_phy ikj misc 1 - +i1 real v_phy ikj misc 1 - +i1 real dz8w ikj misc 1 Z +i1 real p8w ikj misc 1 Z +i1 real t8w ikj misc 1 Z +i1 real rho_phy ikj misc 1 - +i1 logical CU_ACT_FLAG ij misc 1 - + + +state real TMN ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" +state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real UST ij misc 1 - rh "UST" "U* IN SIMILARITY THEORY" "m s-1" +i1 real HOL ij misc 1 - - "HOL" "PBL HEIGHT OVER MONIN-OBUKHOV LENGTH" "" +state real RMOL ij misc 1 - r "RMOL" "1./Monin Ob. Length" "" +state real MOL ij misc 1 - r "MOL" "T* IN SIMILARITY THEORY" "K" +state real PBLH ij misc 1 - rh "PBLH" "PBL HEIGHT" "m" +state real CAPG ij misc 1 - r "CAPG" "HEAT CAPACITY FOR SOIL" "J K-1 m-3" +state real THC ij misc 1 - r "THC" "THERMAL INERTIA" "Cal cm-1 K-1 s-0.5" +state real HFX ij misc 1 - rh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX ij misc 1 - rh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real LH ij misc 1 - rh "LH" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" +state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" +state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" +state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" +i1 real REGIME ij misc 1 - +state real SNOWC ij misc 1 - irhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" + +state real tkesfcf ij misc 1 - r "tkesfcf" "TKE AT THE SURFACE" "m2 s-2" + +state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" +state real taucldi ikj misc 1 - r "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" +state real taucldc ikj misc 1 - r "TAUCLDC" "CLOUD OPTICAL THICKNESS FOR WATER" "" + +state real defor11 ikj misc 1 - r "defor11" "DEFORMATION 11" "s-1" +state real defor22 ikj misc 1 - r "defor22" "DEFORMATION 22" "s-1" +state real defor12 ikj misc 1 - r "defor12" "DEFORMATION 12" "s-1" +state real defor33 ikj misc 1 z r "defor33" "DEFORMATION 33" "s-1" +state real defor13 ikj misc 1 z r "defor13" "DEFORMATION 13" "s-1" +state real defor23 ikj misc 1 z r "defor23" "DEFORMATION 23" "s-1" +state real xkmv ikj misc 1 - r "xkmv" "VERTICAL EDDY VISCOSITY" "m2 s-1" +state real xkmh ikj misc 1 - r "xkmh" "HORIZONTAL EDDY VISCOSITY" "m2 s-1" +state real xkmhd ikj misc 1 - r "xkmhd" "HORIZONTAL EDDY DIFFUSIVITY" "m2 s-1" +state real xkhv ikj misc 1 - r "xkhv" "VERTICAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real xkhh ikj misc 1 - r "xkhh" "HORIZONTAL EDDY DIFFUSIVITY OF HEAT" "m2 s-1" +state real div ikj misc 1 - r "div" "DIVERGENCE" "s-1" +state real BN2 ikj misc 1 - r "BN2" "BRUNT-VAISALA FREQUENCY" "s-2" +state logical warm_rain - misc 1 - - "warm_rain" "WARM_RAIN_LOGICAL" +state logical adv_moist_cond - misc 1 - - "adv_moist_cond" "ADVECT MOIST CONDENSATES LOGICAL" + +## FDDA variables + +state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" +state real - ikjf fdda3d 1 - - - +state real U_NDG_NEW ikjf fdda3d 1 X igr "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_NEW ikjf fdda3d 1 Y igr "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_NEW ikjf fdda3d 1 - igr "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_NEW ikjf fdda3d 1 - igr "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_NEW ikjf fdda3d 1 Z igr "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real U_NDG_OLD ikjf fdda3d 1 X igr "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_OLD ikjf fdda3d 1 Y igr "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_OLD ikjf fdda3d 1 - igr "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_OLD ikjf fdda3d 1 - igr "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_OLD ikjf fdda3d 1 Z igr "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real - ivjf fdda2d 1 Z - - +state real MU_NDG_NEW ivjf fdda2d 1 Z igr "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state real MU_NDG_OLD ivjf fdda2d 1 Z igr "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" + + +# flag for nest movement +state logical moved - misc 1 - - + +# special cam radiation restart arrays +state real abstot ikcj misc 1 Z - "" "" " " +state real absnxt ikaj misc 1 - - "" "" " " +state real emstot ikj misc 1 Z - "" "" " " + +# model diagnostics +state real dpsdt ij misc 1 - - "dpsdt" "surface pressure tendency" "Pa/sec" +state real dmudt ij misc 1 - - "dmudt" "mu tendency" "Pa/sec" +state real pk1m ij misc 1 - - "pk1m" "surface pressure at previous step" "Pa" +state real mu_2m ij misc 1 - - "mu_2m" "mu_2 at previous step" "Pa" + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# + +###### +# +# Variables that are set at run-time to control configuration (namelist-settable) +# +#
+ + +# Time Control +rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" +rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" +rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" +rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" +rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" +rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" +rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" +rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" +rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" +rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" +rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" +rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" +rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" +rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" +rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" +rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" +rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" +rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" +rconfig character rsmas_data_path namelist,time_control 1 "." - "rsmas_data_path" "" "" + +include registry.io_boilerplate + +rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" +rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" +rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" +rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" +rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" +rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" +rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" +rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" +rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" + +rconfig integer diag_print namelist,time_control 1 0 - "print out time series of model diagnostics" +rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" + +# Domains +rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer num_metgrid_levels namelist,domains 1 27 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig integer interp_type namelist,domains 1 1 irh "interp_type" "1=interp in pressure, 2=interp in LOG pressure" "" +rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" +rconfig integer t_extrap_type namelist,domains 1 1 irh "t_extrap_type" "1= use 2 lowest levels, 2=constant, 3 = 6.5 K/km" "" +rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. irh "lowest_lev_from_sfc" "" "" +rconfig integer lagrange_order namelist,domains 1 1 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer force_sfc_in_vinterp namelist,domains 1 1 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" +rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "afcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" +rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" +rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 rh "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 rh "j_parent_start" "" "" +rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" +rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" +rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" +rconfig integer blend_width namelist,domains 1 5 h "blend_width" "width of cg fg terrain blended zone" "" +rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" +rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" +rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" +rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" +rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" +rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" +rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" +rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" +rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" +rconfig integer irand namelist,domains 1 0 - "irand" "" "" +rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer max_vortex_speed namelist,domains max_domains 40 - "" "" "meters per second" +rconfig integer corral_dist namelist,domains max_domains 8 +rconfig integer move_id namelist,domains max_moves 0 +rconfig integer move_interval namelist,domains max_moves 999999999 +rconfig integer move_cd_x namelist,domains max_moves 0 +rconfig integer move_cd_y namelist,domains max_moves 0 +rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" +rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" +rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" +rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" +rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" +rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" +rconfig real eta_levels namelist,domains max_eta -1. +rconfig real max_dz namelist,domains 1 1000. + +# Physics +rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" +rconfig real naer namelist,physics max_domains 1e9 rh "NAER" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" +rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" +rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer IFSNOW namelist,physics 1 0 irh "IFSNOW" "" "" +rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" +rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" +rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" +rconfig integer num_months namelist,physics 1 12 irh "num_months" "" "" +rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" +rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" +rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" +rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" +rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" +rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" +rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" +rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" +rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer ucmcall namelist,physics 1 0 h "ucmcall" "activate urban model 0=no, 1=yes" "" +rconfig integer co2tf namelist,physics 1 1 - "co2tf" "GFDL radiation co2 flag" "" +rconfig integer ra_call_offset namelist,physics 1 0 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" +rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" +rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" +rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" +rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" +rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" + +#FDDA namelist parameters +rconfig real FGDT namelist,fdda max_domains 0 h "FGDT" "" "" +rconfig integer grid_fdda namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_no_pbl_nudging_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_uv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_t namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer if_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig integer k_zfac_q namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real guv namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gt namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real gq namelist,fdda max_domains 0 rh "grid_fdda" "" "" +rconfig real dtramp_min namelist,fdda 1 0 h "grid_fdda" "" "" +rconfig integer if_ramping namelist,fdda 1 0 h "grid_fdda" "" "" + +#Observational Nudging +rconfig integer obs_nudge_opt namelist,fdda max_domains 0 rh "obs_nudge_opt" "Obs-nudging flag for domain" "" +rconfig integer max_obs namelist,fdda 1 0 h "max_obs" "Maximum number of observations" "" +rconfig integer nobs_ndg_vars namelist,fdda 1 5 h "num_ndg_vars" "Number of nudging variables" "" +rconfig integer nobs_err_flds namelist,fdda 1 9 h "num_err_flds" "Number of error fields" "" +rconfig real fdda_start namelist,fdda max_domains 0 rh "fdda_start" "Nudging start time for domain" "min" +rconfig real fdda_end namelist,fdda max_domains 0 rh "fdda_end" "Nudging end time for domain" "min" +rconfig integer obs_nudge_wind namelist,fdda max_domains 0 rh "obs_nudge_wind" "Wind-nudging flag for domain" "" +rconfig real obs_coef_wind namelist,fdda max_domains 0 rh "obs_coef_wind" "Wind-nudging coeficient for domain" "s-1" +rconfig integer obs_nudge_temp namelist,fdda max_domains 0 rh "obs_nudge_temp" "Temperature-nudging flag for domain" "" +rconfig real obs_coef_temp namelist,fdda max_domains 0 rh "obs_coef_temp" "Temperature-nudging coef for domain" "s-1" +rconfig integer obs_nudge_mois namelist,fdda max_domains 0 rh "obs_nudge_mois" "Moisture-nudging flag for domain" "" +rconfig real obs_coef_mois namelist,fdda max_domains 0 rh "obs_coef_mois" "Moisture-nudging coef for domain" "s-1" +rconfig integer obs_nudge_pstr namelist,fdda max_domains 0 rh "obs_nudge_pstr" "Not used" "" +rconfig real obs_coef_pstr namelist,fdda max_domains 0 rh "obs_coef_pstr" "Not used" "" +rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" +rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" +rconfig real obs_twindo namelist,fdda 1 0 h "obs_twindo" "Half-period time window for nudging" "min" +rconfig integer obs_npfi namelist,fdda 1 0 h "obs_npfi" "Freq in cg timesteps for diag print" "" +rconfig integer obs_ionf namelist,fdda 1 0 h "obs_ionf" "Freq in cg timesteps for obs input and error calc" "" +rconfig integer obs_idynin namelist,fdda 1 0 h "obs_idynin" "Flag for dynamic initialization" "" +rconfig real obs_dtramp namelist,fdda 1 0 h "obs_dtramp" "Time period for ramping (idynin)" "min" +rconfig logical obs_ipf_in4dob namelist,fdda 1 .false. h "obs_ipf_in4dob" "Print obs input diagnostics" "min" +rconfig logical obs_ipf_errob namelist,fdda 1 .false. h "obs_ipf_errob" "Print obs error diagnostics" "min" +rconfig logical obs_ipf_nudob namelist,fdda 1 .false. h "obs_ipf_nudob" "Print obs nudge diagnostics" "min" + + +# Dynamics +# dynamics option (see package definitions, below) +rconfig integer dyn_opt namelist,dynamics 1 2 irh "dyn_opt" "" "" +rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" +rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" +# diff_opt 1=old diffusion, 2=new +rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +# km_opt 1=old coefs, 2=tke, 3=Smagorinksy +rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" +rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" +rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" +rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" +rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" +rconfig real diff_6th_factor namelist,dynamics max_domains 0.12 h "diff_6th_factor" "factor that controls rate of 6th-order numerical diffusion" +rconfig integer diff_6th_opt namelist,dynamics max_domains 0 irh "diff_6th_opt" "switch for 6th-order numerical diffusion" +rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" +rconfig real emdiv namelist,dynamics max_domains 0.01 h "emdiv" "" "" +rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" +rconfig integer time_step_sound namelist,dynamics max_domains 0 h "time_step_sound" "" "" +rconfig integer h_mom_adv_order namelist,dynamics max_domains 5 rh "h_mom_adv_order" "" "" +rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" +rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" +rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" +rconfig logical pd_moist namelist,dynamics max_domains .false. rh "pd_moist" "positive-definite RK3 transport switch" "" +rconfig logical pd_chem namelist,dynamics max_domains .false. rh "pd_chem" "positive-definite RK3 transport switch" "" +rconfig logical pd_scalar namelist,dynamics max_domains .false. rh "pd_scalar" "positive-definite RK3 transport switch" "" +rconfig logical pd_tke namelist,dynamics max_domains .false. rh "pd_tke" "positive-definite RK3 transport switch" "" +rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" +rconfig real mix_cr_len namelist,dynamics max_domains 200. h "mix_cr_len" "" "" +rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" +rconfig real kh_tke_upper_bound namelist,dynamics max_domains 1000. h "kh_tke_upper_bound" "" "" +rconfig real kv_tke_upper_bound namelist,dynamics max_domains 1000. h "kv_tke_upper_bound" "" "" +rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "dimensionless" +rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "K m s-1" +rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical mix_full_fields namelist,dynamics max_domains .false. irh "mix_full_field" "" "" +rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" +rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" +rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" + + +# Bdy_control +rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" +rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" +rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" +rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" +rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" +rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" +rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" +rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" +rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" +rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" +rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" +rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" +rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" +rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" +rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" +rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" + +rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" +rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" +rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" +rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" + +# NAMELIST DERIVED +rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" +rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" +rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" +rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" +rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" +rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" +rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" +rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" +rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" +rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" +rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" +rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" + +# +# Single dummy declaration to define a nodyn dyn option +state integer nodyn_dummy - dyn_nodyn - - - "" "" "" + + +# +#--------------------------------------------------------------------------------------------------------------------------------------- +# Package Declarations +# + +#key package associated package associated 4d scalars +# name namelist choice state vars + +package dyn_nodyn dyn_opt==0 - - +package dyn_em dyn_opt==2 - - + +#package passivec1 chem_opt==0 - +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs +package etampnew mp_physics==5 - moist:qv,qc,qr,qi,qs,qg;scalar:qt +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package ncepcloud3 mp_physics==98 - moist:qv,qc,qr +package ncepcloud5 mp_physics==99 - moist:qv,qc,qr,qi,qs +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni + +package noprogn progn==0 - - +package progndrop progn==1 - scalar:qndrop + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - - +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - - +package gfssfcscheme sf_sfclay_physics==3 - - +package slabscheme sf_surface_physics==1 - - +package lsmscheme sf_surface_physics==2 - - +package ruclsmscheme sf_surface_physics==3 - - +package ysuscheme bl_pbl_physics==1 - - +package myjpblscheme bl_pbl_physics==2 - - +package gfsscheme bl_pbl_physics==3 - - +package mrfscheme bl_pbl_physics==99 - - + +package kfetascheme cu_physics==1 - - +package bmjscheme cu_physics==2 - - +package gdscheme cu_physics==3 - - +package sasscheme cu_physics==4 - - +package kfscheme cu_physics==99 - - + +package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new + +# only need to specify these once; not for every io_form* variable +package io_intio io_form_restart==1 - - +package io_netcdf io_form_restart==2 - - +# Placeholders for additional packages (we can go beyond zzz +# but that will entail modifying frame/module_io.F and frame/md_calls.m4) +# Please note these are placeholders; HDF has not been implemented yet. +package io_hdf io_form_restart==3 - - +package io_phdf5 io_form_restart==4 - - +package io_grib1 io_form_restart==5 - - +package io_mcel io_form_restart==6 - - +package io_esmf io_form_restart==7 - - +package io_yyy io_form_restart==8 - - +package io_zzz io_form_restart==9 - - +package io_grib2 io_form_restart==10 - - +package io_pnetcdf io_form_restart==11 - - + +#--------------------------------------------------------------------------------------------------------------------------------------- +## communications + +### 8. Edit the Registry file and create a halo-exchange for x_1. + +# Halo Update Communications + +halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 +halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb +halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb +halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msft,msfu,msfv,f,e,sina,cosa,ht,potevp,snopcx,soiltb +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb +halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut +halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 +halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten +halo HALO_EM_FDDA dyn_em 4:rundgdten,rvndgdten +halo HALO_EM_PHYS_DIFFUSION dyn_em 4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,xkmhd,xkhv,xkhh,tke_1,tke_2 +halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 +halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 +halo HALO_EM_TKE_A dyn_em 4:ph_2,phb +halo HALO_EM_TKE_B dyn_em 4:z,rdz,rdzw,zx,zy +halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw +halo HALO_EM_TKE_D dyn_em 8:defor11,defor22,defor33,defor12,defor13,defor23,div +halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkmhd,xkhv,xkhh,BN2,moist +halo HALO_EM_TKE_3 dyn_em 24:tke_1,tke_2 +halo HALO_EM_TKE_5 dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_7 dyn_em 80:tke_1,tke_2 +halo HALO_EM_TKE_F dyn_em 48:tke_1,tke_2 +halo HALO_EM_TKE_OLD_E_5 dyn_em 48:tke_1 +halo HALO_EM_TKE_OLD_E_7 dyn_em 80:tke_1 +halo HALO_EM_B dyn_em 4:ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend +halo HALO_EM_C dyn_em 4:u_2,v_2 +halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf +halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 +halo HALO_EM_MOIST_E_3 dyn_em 24:moist +halo HALO_EM_MOIST_E_5 dyn_em 48:moist +halo HALO_EM_MOIST_E_7 dyn_em 80:moist +halo HALO_EM_CHEM_E_3 dyn_em 24:chem +halo HALO_EM_CHEM_E_5 dyn_em 48:chem +halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar +halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar +halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar + +halo HALO_EM_MOIST_OLD_E_3 dyn_em 24:moist_old +halo HALO_EM_MOIST_OLD_E_5 dyn_em 48:moist_old +halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old +halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old +halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old +halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old +halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old +halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old + +halo HALO_EM_FEEDBACK dyn_em 48:ht + +halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 +period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 +halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar +period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ + moist,chem,scalar + +# For moving nests +halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 +halo em_shift_halo_x dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 + +# For observational nudging +halo HALO_OBS_NUDGE dyn_em 24:pb,p,uratx,vratx,tratx + +# Periodic Boundary Communications + +period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,t_init,phb,ph0,php,pb,al,alt,alb,mu_1,mu_2,mub,mu0,ht,msft,msfu,msfv,sina,cosa,e,f +period PERIOD_BDY_EM_MOIST dyn_em 3:moist +period PERIOD_BDY_EM_CHEM dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR dyn_em 3:scalar +period PERIOD_BDY_EM_MOIST2 dyn_em 3:moist +period PERIOD_BDY_EM_CHEM2 dyn_em 3:chem +period PERIOD_BDY_EM_SCALAR2 dyn_em 3:scalar +period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al +period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy +period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,xkmh,xkmhd,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2 +period PERIOD_BDY_EM_FDDA_BC dyn_em 2:rundgdten,rvndgdten +period PERIOD_BDY_EM_B dyn_em 2:ru_tend,rv_tend,ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb +period PERIOD_BDY_EM_B3 dyn_em 2:ph_2,al,p,mu_2,muts,mudf +period PERIOD_BDY_EM_B2 dyn_em 2:ru_tend,rv_tend +period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfv,muu,msfu +period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 +period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 + +# +#swap SWAP_ETAMP_NEW dyn_em 1:dz8w,p_phy,pi_phy,rho,th_phy,moist,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,RAINNC,RAINNCV,SR,LOWLYR +#swap SWAP_WSM3 dyn_em 1:th_phy,moist,w_2,rho,pi_phy,p_phy,dz8w,rainnc,rainncv +#cycle CYCLE_TEST dyn_em 1:xlong + +## + +# FDDA (Observational-nudging) Variables +typedef fdob_type integer domain_tot # total number of domains to apply obs-nudging +typedef fdob_type integer domain_init # domain initialization flag +typedef fdob_type integer IEODI # end of obs data flag for current model step +typedef fdob_type integer IWTSIG # flag for nudging on pressure surfaces +typedef fdob_type integer NSTAT # number of obs stations used to nudge current model step +typedef fdob_type integer KTAUR # restart model step +typedef fdob_type integer SN_MAXCG # coarse domain grid dimension in south-north coordinate +typedef fdob_type integer WE_MAXCG # coarse domain grid dimension in west-east coordinate +typedef fdob_type integer SN_END # ending north-south grid index +typedef fdob_type integer LEVIDN(max_domains) # level of nest +typedef fdob_type real DS_CG # coarse domain grid size +typedef fdob_type real WINDOW # time window half-period for nudging (in minutes) +typedef fdob_type real RTLAST # time in hours of last obs used in current model step +typedef fdob_type real DATEND # time in minutes after which data are asuumed to have ended +typedef fdob_type real RINFMN # minimum radius of influence +typedef fdob_type real RINFMX # maximum radius of influence +typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small +typedef fdob_type real DCON # 1/DPSMX +typedef fdob_type real DPSMX # max pres change (cb) allowed within infl range of surf obs +typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization +typedef fdob_type real XN # cone factor for Lambert projection + +# table entries are of the form +#
+#Grid variables +typedef fdob_type real varobs rz - 1 - - "varobs" "observational values in each variable" +typedef fdob_type real errf hz - 1 - - "errf" "errors between model and obs values" +typedef fdob_type real timeob z - 1 - - "timeob" "model times for each observation" "hours" +typedef fdob_type real nlevs_ob z - 1 - - "nlevs_ob" "numbers of levels in sounding obs" +typedef fdob_type real lev_in_ob z - 1 - - "lev_in_ob" "level in sounding-type obs" +typedef fdob_type real plfo z - 1 - - "plfo" "index for type of obs-platform" +typedef fdob_type real elevob z - 1 - - "elevob" "elevation of observation" "meters" +typedef fdob_type real rio z - 1 - - "rio" "west-east grid coordinate" +typedef fdob_type real rjo z - 1 - - "rjo" "south-north grid coordinate" +typedef fdob_type real rko z - 1 - - "rko" "vertical grid coordinate" + +state fdob_type fdob - - +## + +# +# ---------------------------------------- +# begin fire variables and configuration +# ---------------------------------------- +# +# declare fire package and choose which fire scheme +# +# +# name> namelist choice> state vars> +# +package fire_cawfe fire==1 - - + +# fire dimensions on fire grid +# +#
+dimspec n - constant=2 c fire_index_dim +dimspec o - constant=4 c fire_particle_dim + +# fire variables on fire grid +# +#
+state integer nfuel_cat *i*j fire 1 - - +state integer nfl *i*j fire 1 - - +state integer nfl_t *i*j fire 1 - - +state integer nfl_c *i*j fire 1 - - +state integer ncod *i*j fire 1 - - +state real fg *i*j fire 1 - - +state real fc *i*j fire 1 - - +state real r_0 *i*j fire 1 - - +state real bbb *i*j fire 1 - - +state real betafl *i*j fire 1 - - +state real phiwc *i*j fire 1 - - +state real area *i*j fire 1 - - +state real area2 *i*j fire 1 - - +state real zf *i*j fire 1 - - +state real zsf *i*j fire 1 - - +state real tign_g *i*j fire 1 - - +state real tign_c *i*j fire 1 - - +state real tign_crt *i*j fire 1 - - +# +state integer in1 *i*jn fire 1 - h +state integer in2 *i*jn fire 1 - h +state integer ixb *i*jo fire 1 - h +state integer iyb *i*jo fire 1 - h +state integer icn *i*jo fire 1 - h +state real xfg *i*jo fire 1 - h +state real yfg *i*jo fire 1 - h +state real xcd *i*jo fire 1 - h +state real ycd *i*jo fire 1 - h +state real xcn *i*jo fire 1 - h +state real ycn *i*jo fire 1 - h +state real sprdx *i*jo fire 1 - h +state real sprdy *i*jo fire 1 - h + +# fire variables on atm grid +# +state real rthfrten ij fire 1 - h +state real rqvfrten ij fire 1 - h +state real grnhfx ij fire 1 - h +state real grnqfx ij fire 1 - h +state real canhfx ij fire 1 - h +state real canqfx ij fire 1 - h + +# +# fire configure namelist variables +# +#
+rconfig integer ifire namelist,fire 1 0 +rconfig real fire_lat_init namelist,fire 1 0. - "fire_lat_init" "latitude to start fire" "degrees" +rconfig real fire_lon_init namelist,fire 1 0. - "fire_lon_init" "longitude to start fire" "degrees" +rconfig real fire_ign_time namelist,fire 1 0. - "fire_ign_time" "time when fire should be ignited" "min" +rconfig integer fire_shape namelist,fire 1 0 - "fire_shape" "fire shape" "" +rconfig integer fire_sprd_mdl namelist,fire 1 1 - "fire_sprd_mdl" "which spread rate formula: if 0, Macarthur; if 1, BEHAVE" "" +rconfig real fire_crwn_hgt namelist,fire 1 15. - "fire_crwn_hgt" "height that heat from crown fire is released" "m" +rconfig real fire_ext_grnd namelist,fire 1 50. - "fire_ext_grnd" "extinction depth of sfc fire heat" "m" +rconfig real fire_ext_crwn namelist,fire 1 50. - "fire_ext_crwn" "extinction depth of crown fire heat" "m" +rconfig integer fire_fuel_read namelist,fire 1 0 - "fire_fuel_read" "fuel categories are set by: if 0, uniform; if 1, user-presc; if 2, read from file" "" +rconfig integer fire_fuel_cat namelist,fire 1 1 - "fire_fuel_cat" "fuel category if ifuelread=0" "" + +# +# ---------------------------------------- +# end fire variables and configuration +# ---------------------------------------- +# diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem new file mode 100644 index 00000000..87637e2c --- /dev/null +++ b/wrfv2_fire/Registry/registry.chem @@ -0,0 +1,670 @@ + +state integer emissframes - - - - - "emissframes" "" "" +#----------------------------------------------------------------------------------------------------------------------------------------------------------------- +# Chemistry Variables (all shared at this point) +# emissions first +state real e_iso i+j misc 1 Z i5h "E_ISO" "Isoprene EMISSIONS (Anth. for RADM/RACM, Anth+Bio for CBMZ)" "mol km^-2 hr^-1" +state real e_so2 i+j misc 1 Z i5h "E_SO2" "EMISSIONS" "mol km^-2 hr^-1" +state real e_no i+j misc 1 Z i5 "E_NO" "EMISSIONS" "mol km^-2 hr^-1" +state real e_co i+j misc 1 Z i5h "E_CO" "EMISSIONS" "mol km^-2 hr^-1" +state real e_eth i+j misc 1 Z i5 "E_ETH" "EMISSIONS" "mol km^-2 hr^-1" +state real e_hc3 i+j misc 1 Z i5 "E_HC3" "EMISSIONS" "mol km^-2 hr^-1" +state real e_hc5 i+j misc 1 Z i5 "E_HC5" "EMISSIONS" "mol km^-2 hr^-1" +state real e_hc8 i+j misc 1 Z i5 "E_HC8" "EMISSIONS" "mol km^-2 hr^-1" +state real e_xyl i+j misc 1 Z i5 "E_XYL" "EMISSIONS" "mol km^-2 hr^-1" +state real e_ol2 i+j misc 1 Z i5 "E_OL2" "EMISSIONS" "mol km^-2 hr^-1" +state real e_olt i+j misc 1 Z i5 "E_OLT" "EMISSIONS" "mol km^-2 hr^-1" +state real e_oli i+j misc 1 Z i5 "E_OLI" "EMISSIONS" "mol km^-2 hr^-1" +state real e_tol i+j misc 1 Z i5 "E_TOL" "EMISSIONS" "mol km^-2 hr^-1" +state real e_csl i+j misc 1 Z i5 "E_CSL" "EMISSIONS" "mol km^-2 hr^-1" +state real e_hcho i+j misc 1 Z i5 "E_HCHO" "EMISSIONS" "mol km^-2 hr^-1" +state real e_ald i+j misc 1 Z i5 "E_ALD" "EMISSIONS" "mol km^-2 hr^-1" +state real e_ket i+j misc 1 Z i5 "E_KET" "EMISSIONS" "mol km^-2 hr^-1" +state real e_ora2 i+j misc 1 Z i5 "E_ORA2" "EMISSIONS" "mol km^-2 hr^-1" +state real e_nh3 i+j misc 1 Z i5 "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" +state real e_pm25 i+j misc 1 Z i5 "E_PM25" "EMISSIONS" "mol km^-2 hr^-1" +state real e_pm10 i+j misc 1 Z i5 "E_PM10" "EMISSIONS" "mol km^-2 hr^-1" +state real e_pm25i i+j misc 1 Z i5 "E_PM25I" "EMISSION RATE OF UNIDEN. PM2.5 MASS" "ug/m3 m/s" +state real e_pm25j i+j misc 1 Z i5 "E_PM25J" "EMISSION RATE OF J-MODE UNIDEN. PM2.5 MASS" "ug/m3 m/s" +state real e_eci i+j misc 1 Z i5 "E_ECI" "EMISSION RATE OF I-MODE EC" "ug/m3 m/s" +state real e_ecj i+j misc 1 Z i5 "E_ECJ" "EMISSION RATE OF J-MODE EC" "ug/m3 m/s" +state real e_orgi i+j misc 1 Z i5 "E_ORGI" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_orgj i+j misc 1 Z i5 "E_ORGJ" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" +state real e_so4i i+j misc 1 Z i5 "E_SO4I" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_so4j i+j misc 1 Z i5 "E_SO4J" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" +state real e_no3i i+j misc 1 Z i5 "E_NO3I" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_no3j i+j misc 1 Z i5 "E_NO3J" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" + +# Additional CBMZ and MOSAIC emission variables... +state real e_no2 i+j misc 1 Z i5 "E_NO2" "EMISSIONS NO2" "mol km^-2 hr^-1" +state real e_ch3oh i+j misc 1 Z i5 "E_CH3OH" "EMISSIONS CH3OH" "mol km^-2 hr^-1" +state real e_c2h5oh i+j misc 1 Z i5 "E_C2H5OH" "EMISSIONS C2H5OH" "mol km^-2 hr^-1" +state real e_so4c i+j misc 1 Z i5 "E_SO4C" "EMISSIONS COARSE SO4 AER" "ug/m3 m/s" +state real e_no3c i+j misc 1 Z i5 "E_NO3C" "EMISSIONS COARSE NO3 AER" "ug/m3 m/s" +state real e_orgc i+j misc 1 Z i5 "E_ORGC" "EMISSIONS COARSE ORG AER" "ug/m3 m/s" +state real e_ecc i+j misc 1 Z i5 "E_ECC" "EMISSIONS COARSE EC AER" "ug/m3 m/s" + +state real e_bio ijo misc 1 - - "E_BIO" "EMISSIONS" "ppm m/min" +state real sebio_iso ij misc 1 - i04 "sebio_iso" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_oli ij misc 1 - i04 "sebio_oli" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_api ij misc 1 - i04 "sebio_api" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_lim ij misc 1 - i04 "sebio_lim" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_xyl ij misc 1 - i04 "sebio_xyl" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_hc3 ij misc 1 - i04 "sebio_hc3" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_ete ij misc 1 - i04 "sebio_ete" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_olt ij misc 1 - i04 "sebio_olt" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_ket ij misc 1 - i04 "sebio_ket" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_ald ij misc 1 - i04 "sebio_ald" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_hcho ij misc 1 - i04 "sebio_hcho" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_eth ij misc 1 - i04 "sebio_eth" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_ora2 ij misc 1 - i04 "sebio_ora2" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_co ij misc 1 - i04 "sebio_co" "Reference biog emiss" "mol km^-2 hr^-1" +state real sebio_nr ij misc 1 - i04 "sebio_nr" "Reference biog emiss" "mol km^-2 hr^-1" +state real noag_grow ij misc 1 - i04 "noag_grow" "Reference biog emiss" "mol km^-2 hr^-1" +state real noag_nongrow ij misc 1 - i04 "noag_nongrow" "Reference biog emiss" "mol km^-2 hr^-1" +state real nononag ij misc 1 - i04 "nononag" "Reference biog emiss" "mol km^-2 hr^-1" +state real slai ij misc 1 - i04 "slai" "Leaf area index isop" "" +state real ebio_iso ij misc 1 - h "EBIO_ISO" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_oli ij misc 1 - - "ebio_oli" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_api ij misc 1 - - "ebio_api" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_lim ij misc 1 - - "ebio_lim" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_xyl ij misc 1 - - "ebio_xyl" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_hc3 ij misc 1 - - "ebio_hc3" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ete ij misc 1 - - "ebio_ete" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_olt ij misc 1 - - "ebio_olt" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ket ij misc 1 - - "ebio_ket" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ald ij misc 1 - - "ebio_ald" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_hcho ij misc 1 - - "ebio_hcho" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_eth ij misc 1 - - "ebio_eth" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ora2 ij misc 1 - - "ebio_ora2" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_co ij misc 1 - - "ebio_co" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_nr ij misc 1 - - "ebio_nr" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_no ij misc 1 - - "ebio_no" "Actual biog emiss" "mol km^-2 hr^-1" +# +# following used for output to look at all kinds of stuff +state real dep_vel_o3 ij misc 1 - - "DEP_VEL" "deposition velocities for o3" "?" +state real cu_co_ten ikj misc 1 - - "CU_CO_TEN" "CONV. TRANSPORT FOR CO" "?" +# aerosol stuff +state real aerwrf ikj misc 1 - r "AERWRF" "STANDARD AEROSOL PROFILE" "?" + +state real pm2_5_dry ikj misc 1 - hr "PM2_5_DRY" "pm2.5 aerosol dry mass" "ug m^-3" +state real pm2_5_dry_ec ikj misc 1 - r "PM2_5_EC_DRY" "dry ec aerosol mass" "ug m^-3" +state real pm2_5_water ikj misc 1 - r "PM2_5_WATER" "pm2.5 aerosol liquid water content" "ug m^-3" +state real pm10 ikj misc 1 - h "pm10 " "pm10 dry mass" "ug m^-3" +state real uvrad ij misc 1 - - "uv_rad " "uvb net-radiation" "W m^-2" + +# photolysis rates +state real ph_o31d ikj misc 1 - r "PHOTR2" "O31D Photolysis Rate" "min{-1}" +state real ph_o33p ikj misc 1 - r "PHOTR3" "O33P Photolysis Rate" "min{-1}" +state real ph_no2 ikj misc 1 - rh "PHOTR4" "NO2 Photolysis Rate" "min{-1}" +state real ph_no3o2 ikj misc 1 - r "PHOTR5" "NO3O2 Photolysis Rate" "min{-1}" +state real ph_no3o ikj misc 1 - r "PHOTR6" "NO3O Photolysis Rate" "min{-1}" +state real ph_hno2 ikj misc 1 - r "PHOTR7" "HNO2 Photolysis Rate" "min{-1}" +state real ph_hno3 ikj misc 1 - r "PHOTR8" "HNO3 Photolysis Rate" "min{-1}" +state real ph_hno4 ikj misc 1 - r "PHOTR9" "HNO4 Photolysis Rate" "min{-1}" +state real ph_h2o2 ikj misc 1 - r "PHOTR10" "H2O2 Photolysis Rate" "min{-1}" +state real ph_ch2or ikj misc 1 - r "PHOTR11" "CH2OR Photolysis Rate" "min{-1}" +state real ph_ch2om ikj misc 1 - r "PHOTR12" "CH2OM Photolysis Rate" "min{-1}" +state real ph_ch3cho ikj misc 1 - r "PHOTR13" "CH3CHO Photolysis Rate" "min{-1}" +state real ph_ch3coch3 ikj misc 1 - r "PHOTR14" "CH3COCH3 Photolysis Rate" "min{-1}" +state real ph_ch3coc2h5 ikj misc 1 - r "PHOTR15" "CH3COC2H5 Photolysis Rate" "min{-1}" +state real ph_hcocho ikj misc 1 - r "PHOTR16" "HCOCHO Photolysis Rate" "min{-1}" +state real ph_ch3cocho ikj misc 1 - r "PHOTR17" "CH3COCHO Photolysis Rate" "min{-1}" +state real ph_hcochest ikj misc 1 - r "PHOTR18" "HCOCHEST Photolysis Rate" "min{-1}" +state real ph_ch3o2h ikj misc 1 - r "PHOTR19" "CH3O2H Photolysis Rate" "min{-1}" +state real ph_ch3coo2h ikj misc 1 - r "PHOTR20" "CH3COO2H Photolysis Rate" "min{-1}" +state real ph_ch3ono2 ikj misc 1 - r "PHOTR21" "CH3ONO2 Photolysis Rate" "min{-1}" +state real ph_hcochob ikj misc 1 - r "PHOTR22" "HCOCHOB Photolysis Rate" "min{-1}" +state real ph_macr ikj misc 1 - r "PHOTR1" "MACR Photolysis Rate" "min{-1}" +state real ph_n2o5 ikj misc 1 - r "PHOTR23" "N2O5 Photolysis Rate" "min{-1}" +state real ph_o2 ikj misc 1 - r "PHOTR24" "O2 Photolysis Rate" "min{-1}" +# Aerosol optical properties from Mie code +state real tauaer1 ikj misc 1 - r "TAUAER1" "bin 1 layer optical thickness" "?" +state real tauaer2 ikj misc 1 - r "TAUAER2" "bin 2 layer optical thickness" "?" +state real tauaer3 ikj misc 1 - r "TAUAER3" "bin 3 layer optical thickness" "?" +state real tauaer4 ikj misc 1 - r "TAUAER4" "bin 4 layer optical thickness" "?" +state real gaer1 ikj misc 1 - r "GAER1" "bin 1 layer assymetry parameter" "?" +state real gaer2 ikj misc 1 - r "GAER2" "bin 2 layer assymetry parameter" "?" +state real gaer3 ikj misc 1 - r "GAER3" "bin 3 layer assymetry parameter" "?" +state real gaer4 ikj misc 1 - r "GAER4" "bin 4 layer assymetry parameter" "?" +state real waer1 ikj misc 1 - r "WAER1" "bin 1 layer single-scattering albedo" "?" +state real waer2 ikj misc 1 - r "WAER2" "bin 2 layer single-scattering albedo" "?" +state real waer3 ikj misc 1 - r "WAER3" "bin 3 layer single-scattering albedo" "?" +state real waer4 ikj misc 1 - r "WAER4" "bin 4 layer single-scattering albedo" "?" + +# non-transported aerosol variables +state real h2oaj ikj misc 1 - r "h2oaj" "Aerosol water conc. Acc.mode" "?" +state real h2oai ikj misc 1 - r "h2oai" "Aerosol water conc. Aitken mode" "?" +state real nu3 ikj misc 1 - r "nu3" "3rd moment Aitken mode" "?" +state real ac3 ikj misc 1 - r "ac3" "3rd moment Acc. mode" "?" +state real cor3 ikj misc 1 - r "cor3" "3rd moment coarse mode" "?" +state real asulf ikj misc 1 - r "asulf" "sulfuric acid vapor deposition" "?" +state real ahno3 ikj misc 1 - r "ahno3" "nitric acid vapor deposition" "?" +state real anh3 ikj misc 1 - r "anh3" "amonia gas concentration" "?" +state real cvaro1 ikj misc 1 - r "cvaro1" "cond.vapor from aromatics" "?" +state real cvaro2 ikj misc 1 - r "cvaro2" "cond.vapor from aromatics" "?" +state real cvalk1 ikj misc 1 - r "cvalk1" "cond.vapor from alkanes" "?" +state real cvole1 ikj misc 1 - r "cvole1" "cond.vapor from olefines" "?" +state real cvapi1 ikj misc 1 - r "cvapi1" "cond.vapor from biogenics" "?" +state real cvapi2 ikj misc 1 - r "cvapi2" "cond.vapor from biogenics" "?" +state real cvlim1 ikj misc 1 - r "cvlim1" "cond.vapor from biogenics" "?" +state real cvlim2 ikj misc 1 - r "cvlim2" "cond.vapor from biogenics" "?" +# non-transported radical species for RACM +state real addt ikj misc 1 - r "addt" "Radicals" "ppm" +state real addx ikj misc 1 - r "addx" "Radicals" "ppm" +state real addc ikj misc 1 - r "addc" "Radicals" "ppm" +state real etep ikj misc 1 - r "etep" "Radicals" "ppm" +state real oltp ikj misc 1 - r "oltp" "Radicals" "ppm" +state real olip ikj misc 1 - r "olip" "Radicals" "ppm" +state real cslp ikj misc 1 - r "cslp" "Radicals" "ppm" +state real limp ikj misc 1 - r "limp" "Radicals" "ppm" +state real hc5p ikj misc 1 - r "hc5p" "Radicals" "ppm" +state real hc8p ikj misc 1 - r "hc8p" "Radicals" "ppm" +state real tolp ikj misc 1 - r "tolp" "Radicals" "ppm" +state real xylp ikj misc 1 - r "xylp" "Radicals" "ppm" +state real apip ikj misc 1 - r "apip" "Radicals" "ppm" +state real isop ikj misc 1 - r "isop" "Radicals" "ppm" +state real hc3p ikj misc 1 - r "hc3p" "Radicals" "ppm" +state real ethp ikj misc 1 - r "ethp" "Radicals" "ppm" +state real o3p ikj misc 1 - r "o3p" "Radicals" "ppm" +state real tco3 ikj misc 1 - r "tco3" "Radicals" "ppm" +state real mo2 ikj misc 1 - r "mo2" "Radicals" "ppm" +state real o1d ikj misc 1 - r "o1d" "Radicals" "ppm" +state real olnn ikj misc 1 - r "olnn" "Radicals" "ppm" +state real olnd ikj misc 1 - r "olnd" "Radicals" "ppm" +state real rpho ikj misc 1 - r "rpho" "Radicals" "ppm" +state real xo2 ikj misc 1 - r "xo2" "Radicals" "ppm" +state real ketp ikj misc 1 - r "ketp" "Radicals" "ppm" +#cms++ radicals from RADM2-KPP, RACM-MIM +state real xno2 ikj misc 1 - r "xno2" "Radicals" "ppm" +state real ol2p ikj misc 1 - r "ol2p" "Radicals" "ppm" +state real oln ikj misc 1 - r "oln" "Radicals" "ppm" +state real macp ikj misc 1 - r "macp" "Radicals" "ppm" +# Chem Scalars +state real - ikjftb chem 1 - - - +state real so2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so2" "SO2 concentration" "ppmv" +state real sulf ikjftb chem 1 - irhusdf=(bdy_interp:dt) "sulf" "SULF concentration" "ppmv" +state real no2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no2" "NO2 concentration" "ppmv" +state real no ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no" "NO concentration" "ppmv" +state real o3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "o3" "O3 concentration" "ppmv" +state real hno3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hno3" "HNO3 concentration" "ppmv" +state real h2o2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "h2o2" "H2O2 concentration" "ppmv" +state real ald ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ald" "ALD concentration" "ppmv" +state real hcho ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hcho" "HCHO concentration" "ppmv" +state real op1 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "op1" "OP1 concentration" "ppmv" +state real op2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "op2" "OP2 concentration" "ppmv" +state real paa ikjftb chem 1 - irhusdf=(bdy_interp:dt) "paa" "PAA concentration" "ppmv" +state real ora1 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ora1" "ORA1 concentration" "ppmv" +state real ora2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ora2" "ORA2 concentration" "ppmv" +state real nh3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh3" "NH3 concentration" "ppmv" +state real n2o5 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "n2o5" "N2O5 concentration" "ppmv" +state real no3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3" "NO3 concentration" "ppmv" +state real pan ikjftb chem 1 - irhusdf=(bdy_interp:dt) "pan" "PAN concentration" "ppmv" +state real hc3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hc3" "HC3 concentration" "ppmv" +state real hc5 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hc5" "HC5 concentration" "ppmv" +state real hc8 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hc8" "HC8 concentration" "ppmv" +state real eth ikjftb chem 1 - irhusdf=(bdy_interp:dt) "eth" "ETH concentration" "ppmv" +state real co ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co" "CO concentration" "ppmv" +state real ol2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ol2" "OL2 concentration" "ppmv" +state real olt ikjftb chem 1 - irhusdf=(bdy_interp:dt) "olt" "OLT concentration" "ppmv" +state real oli ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oli" "OLI concentration" "ppmv" +state real tol ikjftb chem 1 - irhusdf=(bdy_interp:dt) "tol" "TOL concentration" "ppmv" +state real xyl ikjftb chem 1 - irhusdf=(bdy_interp:dt) "xyl" "XYL concentration" "ppmv" +state real aco3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "aco3" "ACO3 concentration" "ppmv" +state real tpan ikjftb chem 1 - irhusdf=(bdy_interp:dt) "tpan" "TPAN concentration" "ppmv" +state real hono ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hono" "HONO concentration" "ppmv" +state real hno4 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hno4" "HNO4 concentration" "ppmv" +state real ket ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ket" "KET concentration" "ppmv" +state real gly ikjftb chem 1 - irhusdf=(bdy_interp:dt) "gly" "GLY concentration" "ppmv" +state real mgly ikjftb chem 1 - irhusdf=(bdy_interp:dt) "mgly" "MGLY concentration" "ppmv" +state real dcb ikjftb chem 1 - irhusdf=(bdy_interp:dt) "dcb" "DCB concentration" "ppmv" +state real onit ikjftb chem 1 - irhusdf=(bdy_interp:dt) "onit" "ONIT concentration" "ppmv" +state real csl ikjftb chem 1 - irhusdf=(bdy_interp:dt) "csl" "CSL concentration" "ppmv" +state real iso ikjftb chem 1 - irhusdf=(bdy_interp:dt) "iso" "ISO concentration" "ppmv" +state real ho ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ho" "HO concentration" "ppmv" +state real ho2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ho2" "HO2 concentration" "ppmv" + +#RACM has a few more variables to those of RADM2 (ETE is equivilant to OL2 from RADM2) + +state real ete ikjftb chem 1 - irusdf=(bdy_interp:dt) "ete" "ETE concentration" "ppmv" +state real co2 ikjftb chem 1 - irusdf=(bdy_interp:dt) "co2" "CO2 concentration" "ppmv" +state real ch4 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ch4" "CH4 concentration" "ppmv" +state real udd ikjftb chem 1 - irusdf=(bdy_interp:dt) "udd" "UDD concentration" "ppmv" +state real hket ikjftb chem 1 - irusdf=(bdy_interp:dt) "hket" "HKET concentration" "ppmv" +state real api ikjftb chem 1 - irusdf=(bdy_interp:dt) "api" "API concentration" "ppmv" +state real lim ikjftb chem 1 - irusdf=(bdy_interp:dt) "lim" "LIM concentration" "ppmv" +state real dien ikjftb chem 1 - irusdf=(bdy_interp:dt) "dien" "DIEN concentration" "ppmv" +state real macr ikjftb chem 1 - irusdf=(bdy_interp:dt) "macr" "MACR concentration" "ppmv" + +#Additional CBMZ gas variables inside the chem array... + +state real hcl ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hcl" "HCL concentration" "ppmv" +state real ch3o2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3o2" "CH3O2 concentration" "ppmv" +state real ethp ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ethp" "ETHP concentration" "ppmv" +state real ch3oh ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3oh" "CH3OH concentration" "ppmv" +state real c2h5oh ikjftb chem 1 - irhusdf=(bdy_interp:dt) "c2h5oh" "C2H5OH concentration" "ppmv" +state real par ikjftb chem 1 - irhusdf=(bdy_interp:dt) "par" "PAR concentration" "ppmv" +state real to2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "to2" "TO2 concentration" "ppmv" +state real cro ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cro" "CRO concentration" "ppmv" +state real open ikjftb chem 1 - irhusdf=(bdy_interp:dt) "open" "OPEN concentration" "ppmv" +state real op3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "op3" "OP3 concentration" "ppmv" +state real c2o3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "c2o3" "C2O3 concentration" "ppmv" +state real ro2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ro2" "RO2 concentration" "ppmv" +state real ano2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ano2" "ANO2 concentration" "ppmv" +state real nap ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nap" "NAP concentration" "ppmv" +state real xo2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "xo2" "XO2 concentration" "ppmv" +state real xpar ikjftb chem 1 - irhusdf=(bdy_interp:dt) "xpar" "XPAR concentration" "ppmv" +state real isoprd ikjftb chem 1 - irhusdf=(bdy_interp:dt) "isoprd" "ISOPRD concentration" "ppmv" +state real isopp ikjftb chem 1 - irhusdf=(bdy_interp:dt) "isopp" "ISOPP concentration" "ppmv" +state real isopn ikjftb chem 1 - irhusdf=(bdy_interp:dt) "isopn" "ISOPN concentration" "ppmv" +state real isopo2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "isopo2" "ISOPO2 concentration" "ppmv" +state real dms ikjftb chem 1 - irhusdf=(bdy_interp:dt) "dms" "DMS concentration" "ppmv" +state real msa ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa" "MSA concentration" "ppmv" +state real dmso ikjftb chem 1 - irhusdf=(bdy_interp:dt) "dmso" "DMSO concentration" "ppmv" +state real dmso2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "dmso2" "DMSO2 concentration" "ppmv" +state real ch3so2h ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3so2h" "CH3SO2H concentration" "ppmv" +state real ch3sch2oo ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3sch2oo" "CH3SCH2OO concentration" "ppmv" +state real ch3so2 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3so2" "CH3SO2 concentration" "ppmv" +state real ch3so3 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3so3" "CH3SO3 concentration" "ppmv" +state real ch3so2oo ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3so2oo" "CH3SO2OO concentration" "ppmv" +state real ch3so2ch2oo ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ch3so2ch2oo" "CH3SO2CH2OO concentration" "ppmv" +state real mtf ikjftb chem 1 - irhusdf=(bdy_interp:dt) "mtf" "MTF concentration" "ppmv" + +#Aerosol variables inside the chem array... + +state real so4aj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4aj" "Sulfate conc. Acc. mode" "ug/kg-dryair" +state real so4ai ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4ai" "Sulfate conc. Aitken mode" "ug/kg-dryair" +state real nh4aj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4aj" "Ammonium conc. Acc. mode" "ug/kg-dryair" +state real nh4ai ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4ai" "Ammonium conc. Aitken mode" "ug/kg-dryair" +state real no3aj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3aj" "Nitrate conc. Acc. mode" "ug/kg-dryair" +state real no3ai ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3ai" "Nitrate conc. Aitken mode" "ug/kg-dryair" +state real orgaro1j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro1j" "SOA Anth. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgaro1i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro1i" "SOA Anth. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgaro2j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro2j" "SOA Anth. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgaro2i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro2i" "SOA Anth. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgalk1j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgalk1j" "SOA Anth. org. conc. from alkanes and others except aromatics Acc. mode" "ug/kg-dryair" +state real orgalk1i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgalk1i" "SOA Anth. org. conc. from alkanes and others except aromatics Aitken mode" "ug/kg-dryair" +state real orgole1j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgole1j" "SOA Anth. org. conc. from alkenes and others except aromatics Acc. mode" "ug/kg-dryair" +state real orgole1i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgole1i" "SOA Anth. org. conc. from alkenes and others except aromatics Aitken mode" "ug/kg-dryair" +state real orgba1j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba1j" "SOA Biog. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgba1i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba1i" "SOA Biog. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgba2j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba2j" "SOA Biog. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgba2i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba2i" "SOA Biog. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgba3j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba3j" "SOA Biog. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgba3i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba3i" "SOA Biog. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgba4j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba4j" "SOA Biog. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgba4i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba4i" "SOA Biog. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real orgpaj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgpaj" "Prim. anth. org. conc. from aromatics Acc. mode" "ug/kg-dryair" +state real orgpai ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgpai" "Prim. anth. org. conc. from aromatics Aitken mode" "ug/kg-dryair" +state real ecj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ecj" "Elemental carbon Acc. mode" "ug/kg-dryair" +state real eci ikjftb chem 1 - irhusdf=(bdy_interp:dt) "eci" "Elemental carbon Aitken mode" "ug/kg-dryair" +state real p25j ikjftb chem 1 - irhusdf=(bdy_interp:dt) "p25j" "Primary PM2.5 Acc. mode" "ug/kg-dryair" +state real p25i ikjftb chem 1 - irhusdf=(bdy_interp:dt) "p25i" "Primary PM2.5 Aitken mode" "ug/kg-dryair" +state real antha ikjftb chem 1 - irhusdf=(bdy_interp:dt) "antha" "Coarse anthropogenic aerosols" "ug/kg-dryair" +state real seas ikjftb chem 1 - irhusdf=(bdy_interp:dt) "seas" "Coarse marine aerosols" "ug/kg-dryair" +state real soila ikjftb chem 1 - irhusdf=(bdy_interp:dt) "soila" "Coarse soil-derived aerosols" "ug/kg-dryair" +state real nu0 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nu0" "Aitken mode number" "#/kg-dryair" +state real ac0 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ac0" "Accumulation mode number" "#/kg-dryair" +state real corn ikjftb chem 1 - irhusdf=(bdy_interp:dt) "corn" "Coarse mode number" "#/kg-dryair" +#cloud-phase aerosol +state real so4cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4cwj" "Sulfate conc. Acc. mode in cloud" "ug/kg-dryair" +state real so4cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4cwi" "Sulfate conc. Aitken mode in cloud" "ug/kg-dryair" +state real nh4cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4cwj" "Ammonium conc. Acc. mode in cloud" "ug/kg-dryair" +state real nh4cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4cwi" "Ammonium conc. Aitken mode in cloud" "ug/kg-dryair" +state real no3cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3cwj" "Nitrate conc. Acc. mode in cloud" "ug/kg-dryair" +state real no3cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3cwi" "Nitrate conc. Aitken mode in cloud" "ug/kg-dryair" +state real orgaro1cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro1cwj" "SOA Anth. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgaro1cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro1cwi" "SOA Anth. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgaro2cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro2cwj" "SOA Anth. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgaro2cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgaro2cwi" "SOA Anth. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgalk1cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgalk1cwj" "SOA Anth. org. conc. from alkanes and others except aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgalk1cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgalk1cwi" "SOA Anth. org. conc. from alkanes and others except aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgole1cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgole1cwj" "SOA Anth. org. conc. from alkenes and others except aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgole1cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgole1cwi" "SOA Anth. org. conc. from alkenes and others except aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgba1cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba1cwj" "SOA Biog. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgba1cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba1cwi" "SOA Biog. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgba2cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba2cwj" "SOA Biog. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgba2cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba2cwi" "SOA Biog. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgba3cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba3cwj" "SOA Biog. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgba3cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba3cwi" "SOA Biog. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgba4cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba4cwj" "SOA Biog. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgba4cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgba4cwi" "SOA Biog. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real orgpacwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgpacwj" "Prim. anth. org. conc. from aromatics Acc. mode in cloud" "ug/kg-dryair" +state real orgpacwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "orgpacwi" "Prim. anth. org. conc. from aromatics Aitken mode in cloud" "ug/kg-dryair" +state real eccwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "eccwj" "Elemental carbon Acc. mode in cloud" "ug/kg-dryair" +state real eccwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "eccwi" "Elemental carbon Aitken mode in cloud" "ug/kg-dryair" +state real p25cwj ikjftb chem 1 - irhusdf=(bdy_interp:dt) "p25cwj" "Primary PM2.5 Acc. mode in cloud" "ug/kg-dryair" +state real p25cwi ikjftb chem 1 - irhusdf=(bdy_interp:dt) "p25cwi" "Primary PM2.5 Aitken mode in cloud" "ug/kg-dryair" +state real anthcw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "anthcw" "Coarse anthropogenic aerosols in cloud" "ug/kg-dryair" +state real seascw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "seascw" "Coarse marine aerosols in cloud" "ug/kg-dryair" +state real soilcw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "soilcw" "Coarse soil-derived aerosols in cloud" "ug/kg-dryair" +state real nu0cw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nu0cw" "Aitken mode number in cloud" "#/kg-dryair" +state real ac0cw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ac0cw" "Accumulation mode number in cloud" "#/kg-dryair" +state real corncw ikjftb chem 1 - irhusdf=(bdy_interp:dt) "corncw" "Coarse mode number in cloud" "#/kg-dryair" +#cms++ additional species from RACM-MIM (Geiger et al., Atmos. Env., 2003) +state real hace ikjftb chem 1 - irusdf=(bdy_interp:dt) "hace" "HACE concentration" "ppm" +state real ishp ikjftb chem 1 - irusdf=(bdy_interp:dt) "ishp" "ISHP concentration" "ppm" +state real ison ikjftb chem 1 - irusdf=(bdy_interp:dt) "ison" "ISON concentration" "ppm" +state real mahp ikjftb chem 1 - irusdf=(bdy_interp:dt) "mahp" "MAHP concentration" "ppm" +state real mpan ikjftb chem 1 - irusdf=(bdy_interp:dt) "mpan" "MPAN concentration" "ppm" +state real nald ikjftb chem 1 - irusdf=(bdy_interp:dt) "nald" "NALD concentration" "ppm" +#cms-- note: ison is probably quite soluble +#Additional MOSAIC aerosol variables inside the chem array... + +state real so4_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a01" "Sulfate, aerosol bin 01" "ug/kg-dryair" +state real no3_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a01" "Nitrate, aerosol bin 01" "ug/kg-dryair" +state real cl_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a01" "Chloride, aerosol bin 01" "ug/kg-dryair" +state real msa_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a01" "MSA, aerosol bin 01" "ug/kg-dryair" +state real co3_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a01" "Carbonate, aerosol bin 01" "ug/kg-dryair" +state real nh4_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a01" "Ammonium, aerosol bin 01" "ug/kg-dryair" +state real na_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a01" "Sodium, aerosol bin 01" "ug/kg-dryair" +state real ca_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a01" "Calcium, aerosol bin 01" "ug/kg-dryair" +state real oin_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a01" "Other inorganics, aerosol bin 01" "ug/kg-dryair" +state real oc_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a01" "Organic carbon, aerosol bin 01" "ug/kg-dryair" +state real bc_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a01" "Black carbon, aerosol bin 01" "ug/kg-dryair" +state real hysw_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a01" "Hysteresis water, aerosol bin 01" "ug/kg-dryair" +state real water_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a01" "Water, aerosol bin 01" "ug/kg-dryair" +state real num_a01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a01" "Number, aerosol bin 01" "#/kg-dryair" +state real so4_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a02" "Sulfate, aerosol bin 02" "ug/kg-dryair" +state real no3_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a02" "Nitrate, aerosol bin 02" "ug/kg-dryair" +state real cl_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a02" "Chloride, aerosol bin 02" "ug/kg-dryair" +state real msa_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a02" "MSA, aerosol bin 02" "ug/kg-dryair" +state real co3_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a02" "Carbonate, aerosol bin 02" "ug/kg-dryair" +state real nh4_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a02" "Ammonium, aerosol bin 02" "ug/kg-dryair" +state real na_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a02" "Sodium, aerosol bin 02" "ug/kg-dryair" +state real ca_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a02" "Calcium, aerosol bin 02" "ug/kg-dryair" +state real oin_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a02" "Other inorganics, aerosol bin 02" "ug/kg-dryair" +state real oc_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a02" "Organic carbon, aerosol bin 02" "ug/kg-dryair" +state real bc_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a02" "Black carbon, aerosol bin 02" "ug/kg-dryair" +state real hysw_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a02" "Hysteresis water, aerosol bin 02" "ug/kg-dryair" +state real water_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a02" "Water, aerosol bin 02" "ug/kg-dryair" +state real num_a02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a02" "Number, aerosol bin 02" "#/kg-dryair" +state real so4_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a03" "Sulfate, aerosol bin 03" "ug/kg-dryair" +state real no3_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a03" "Nitrate, aerosol bin 03" "ug/kg-dryair" +state real cl_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a03" "Chloride, aerosol bin 03" "ug/kg-dryair" +state real msa_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a03" "MSA, aerosol bin 03" "ug/kg-dryair" +state real co3_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a03" "Carbonate, aerosol bin 03" "ug/kg-dryair" +state real nh4_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a03" "Ammonium, aerosol bin 03" "ug/kg-dryair" +state real na_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a03" "Sodium, aerosol bin 03" "ug/kg-dryair" +state real ca_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a03" "Calcium, aerosol bin 03" "ug/kg-dryair" +state real oin_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a03" "Other inorganics, aerosol bin 03" "ug/kg-dryair" +state real oc_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a03" "Organic carbon, aerosol bin 03" "ug/kg-dryair" +state real bc_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a03" "Black carbon, aerosol bin 03" "ug/kg-dryair" +state real hysw_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a03" "Hysteresis water, aerosol bin 03" "ug/kg-dryair" +state real water_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a03" "Water, aerosol bin 03" "ug/kg-dryair" +state real num_a03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a03" "Number, aerosol bin 03" "#/kg-dryair" +state real so4_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a04" "Sulfate, aerosol bin 04" "ug/kg-dryair" +state real no3_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a04" "Nitrate, aerosol bin 04" "ug/kg-dryair" +state real cl_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a04" "Chloride, aerosol bin 04" "ug/kg-dryair" +state real msa_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a04" "MSA, aerosol bin 04" "ug/kg-dryair" +state real co3_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a04" "Carbonate, aerosol bin 04" "ug/kg-dryair" +state real nh4_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a04" "Ammonium, aerosol bin 04" "ug/kg-dryair" +state real na_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a04" "Sodium, aerosol bin 04" "ug/kg-dryair" +state real ca_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a04" "Calcium, aerosol bin 04" "ug/kg-dryair" +state real oin_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a04" "Other inorganics, aerosol bin 04" "ug/kg-dryair" +state real oc_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a04" "Organic carbon, aerosol bin 04" "ug/kg-dryair" +state real bc_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a04" "Black carbon, aerosol bin 04" "ug/kg-dryair" +state real hysw_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a04" "Hysteresis water, aerosol bin 04" "ug/kg-dryair" +state real water_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a04" "Water, aerosol bin 04" "ug/kg-dryair" +state real num_a04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a04" "Number, aerosol bin 04" "#/kg-dryair" +state real so4_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a05" "Sulfate, aerosol bin 05" "ug/kg-dryair" +state real no3_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a05" "Nitrate, aerosol bin 05" "ug/kg-dryair" +state real cl_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a05" "Chloride, aerosol bin 05" "ug/kg-dryair" +state real msa_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a05" "MSA, aerosol bin 05" "ug/kg-dryair" +state real co3_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a05" "Carbonate, aerosol bin 05" "ug/kg-dryair" +state real nh4_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a05" "Ammonium, aerosol bin 05" "ug/kg-dryair" +state real na_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a05" "Sodium, aerosol bin 05" "ug/kg-dryair" +state real ca_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a05" "Calcium, aerosol bin 05" "ug/kg-dryair" +state real oin_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a05" "Other inorganics, aerosol bin 05" "ug/kg-dryair" +state real oc_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a05" "Organic carbon, aerosol bin 05" "ug/kg-dryair" +state real bc_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a05" "Black carbon, aerosol bin 05" "ug/kg-dryair" +state real hysw_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a05" "Hysteresis water, aerosol bin 05" "ug/kg-dryair" +state real water_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a05" "Water, aerosol bin 05" "ug/kg-dryair" +state real num_a05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a05" "Number, aerosol bin 05" "#/kg-dryair" +state real so4_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a06" "Sulfate, aerosol bin 06" "ug/kg-dryair" +state real no3_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a06" "Nitrate, aerosol bin 06" "ug/kg-dryair" +state real cl_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a06" "Chloride, aerosol bin 06" "ug/kg-dryair" +state real msa_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a06" "MSA, aerosol bin 06" "ug/kg-dryair" +state real co3_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a06" "Carbonate, aerosol bin 06" "ug/kg-dryair" +state real nh4_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a06" "Ammonium, aerosol bin 06" "ug/kg-dryair" +state real na_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a06" "Sodium, aerosol bin 06" "ug/kg-dryair" +state real ca_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a06" "Calcium, aerosol bin 06" "ug/kg-dryair" +state real oin_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a06" "Other inorganics, aerosol bin 06" "ug/kg-dryair" +state real oc_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a06" "Organic carbon, aerosol bin 06" "ug/kg-dryair" +state real bc_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a06" "Black carbon, aerosol bin 06" "ug/kg-dryair" +state real hysw_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a06" "Hysteresis water, aerosol bin 06" "ug/kg-dryair" +state real water_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a06" "Water, aerosol bin 06" "ug/kg-dryair" +state real num_a06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a06" "Number, aerosol bin 06" "#/kg-dryair" +state real so4_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a07" "Sulfate, aerosol bin 07" "ug/kg-dryair" +state real no3_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a07" "Nitrate, aerosol bin 07" "ug/kg-dryair" +state real cl_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a07" "Chloride, aerosol bin 07" "ug/kg-dryair" +state real msa_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a07" "MSA, aerosol bin 07" "ug/kg-dryair" +state real co3_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a07" "Carbonate, aerosol bin 07" "ug/kg-dryair" +state real nh4_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a07" "Ammonium, aerosol bin 07" "ug/kg-dryair" +state real na_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a07" "Sodium, aerosol bin 07" "ug/kg-dryair" +state real ca_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a07" "Calcium, aerosol bin 07" "ug/kg-dryair" +state real oin_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a07" "Other inorganics, aerosol bin 07" "ug/kg-dryair" +state real oc_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a07" "Organic carbon, aerosol bin 07" "ug/kg-dryair" +state real bc_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a07" "Black carbon, aerosol bin 07" "ug/kg-dryair" +state real hysw_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a07" "Hysteresis water, aerosol bin 07" "ug/kg-dryair" +state real water_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a07" "Water, aerosol bin 07" "ug/kg-dryair" +state real num_a07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a07" "Number, aerosol bin 07" "#/kg-dryair" +state real so4_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a08" "Sulfate, aerosol bin 08" "ug/kg-dryair" +state real no3_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_a08" "Nitrate, aerosol bin 08" "ug/kg-dryair" +state real cl_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_a08" "Chloride, aerosol bin 08" "ug/kg-dryair" +state real msa_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_a08" "MSA, aerosol bin 08" "ug/kg-dryair" +state real co3_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_a08" "Carbonate, aerosol bin 08" "ug/kg-dryair" +state real nh4_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_a08" "Ammonium, aerosol bin 08" "ug/kg-dryair" +state real na_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_a08" "Sodium, aerosol bin 08" "ug/kg-dryair" +state real ca_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_a08" "Calcium, aerosol bin 08" "ug/kg-dryair" +state real oin_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_a08" "Other inorganics, aerosol bin 08" "ug/kg-dryair" +state real oc_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_a08" "Organic carbon, aerosol bin 08" "ug/kg-dryair" +state real bc_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_a08" "Black carbon, aerosol bin 08" "ug/kg-dryair" +state real hysw_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "hysw_a08" "Hysteresis water, aerosol bin 08" "ug/kg-dryair" +state real water_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "water_a08" "Water, aerosol bin 08" "ug/kg-dryair" +state real num_a08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_a08" "Number, aerosol bin 08" "#/kg-dryair" +# Aerosol in cloud water phase +state real so4_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw01" "Sulfate, aerosol in cloud bin 01" "ug/kg-dryair" +state real no3_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw01" "Nitrate, aerosol in cloud bin 01" "ug/kg-dryair" +state real cl_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw01" "Chloride, aerosol in cloud bin 01" "ug/kg-dryair" +state real msa_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw01" "MSA, aerosol in cloud bin 01" "ug/kg-dryair" +state real co3_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw01" "Carbonate, aerosol in cloud bin 01" "ug/kg-dryair" +state real nh4_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw01" "Ammonium, aerosol in cloud bin 01" "ug/kg-dryair" +state real na_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw01" "Sodium, aerosol in cloud bin 01" "ug/kg-dryair" +state real ca_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw01" "Calcium, aerosol in cloud bin 01" "ug/kg-dryair" +state real oin_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw01" "Other inorganics, aerosol in cloud bin 01" "ug/kg-dryair" +state real oc_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw01" "Organic carbon, aerosol in cloud bin 01" "ug/kg-dryair" +state real bc_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw01" "Black carbon, aerosol in cloud bin 01" "ug/kg-dryair" +state real num_cw01 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw01" "Number, aerosol in cloud bin 01" "#/kg-dryair" +state real so4_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw02" "Sulfate, aerosol in cloud bin 02" "ug/kg-dryair" +state real no3_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw02" "Nitrate, aerosol in cloud bin 02" "ug/kg-dryair" +state real cl_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw02" "Chloride, aerosol in cloud bin 02" "ug/kg-dryair" +state real msa_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw02" "MSA, aerosol in cloud bin 02" "ug/kg-dryair" +state real co3_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw02" "Carbonate, aerosol in cloud bin 02" "ug/kg-dryair" +state real nh4_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw02" "Ammonium, aerosol in cloud bin 02" "ug/kg-dryair" +state real na_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw02" "Sodium, aerosol in cloud bin 02" "ug/kg-dryair" +state real ca_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw02" "Calcium, aerosol in cloud bin 02" "ug/kg-dryair" +state real oin_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw02" "Other inorganics, aerosol in cloud bin 02" "ug/kg-dryair" +state real oc_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw02" "Organic carbon, aerosol in cloud bin 02" "ug/kg-dryair" +state real bc_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw02" "Black carbon, aerosol in cloud bin 02" "ug/kg-dryair" +state real num_cw02 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw02" "Number, aerosol in cloud bin 02" "#/kg-dryair" +state real so4_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw03" "Sulfate, aerosol in cloud bin 03" "ug/kg-dryair" +state real no3_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw03" "Nitrate, aerosol in cloud bin 03" "ug/kg-dryair" +state real cl_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw03" "Chloride, aerosol in cloud bin 03" "ug/kg-dryair" +state real msa_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw03" "MSA, aerosol in cloud bin 03" "ug/kg-dryair" +state real co3_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw03" "Carbonate, aerosol in cloud bin 03" "ug/kg-dryair" +state real nh4_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw03" "Ammonium, aerosol in cloud bin 03" "ug/kg-dryair" +state real na_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw03" "Sodium, aerosol in cloud bin 03" "ug/kg-dryair" +state real ca_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw03" "Calcium, aerosol in cloud bin 03" "ug/kg-dryair" +state real oin_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw03" "Other inorganics, aerosol in cloud bin 03" "ug/kg-dryair" +state real oc_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw03" "Organic carbon, aerosol in cloud bin 03" "ug/kg-dryair" +state real bc_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw03" "Black carbon, aerosol in cloud bin 03" "ug/kg-dryair" +state real num_cw03 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw03" "Number, aerosol in cloud bin 03" "#/kg-dryair" +state real so4_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw04" "Sulfate, aerosol in cloud bin 04" "ug/kg-dryair" +state real no3_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw04" "Nitrate, aerosol in cloud bin 04" "ug/kg-dryair" +state real cl_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw04" "Chloride, aerosol in cloud bin 04" "ug/kg-dryair" +state real msa_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw04" "MSA, aerosol in cloud bin 04" "ug/kg-dryair" +state real co3_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw04" "Carbonate, aerosol in cloud bin 04" "ug/kg-dryair" +state real nh4_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw04" "Ammonium, aerosol in cloud bin 04" "ug/kg-dryair" +state real na_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw04" "Sodium, aerosol in cloud bin 04" "ug/kg-dryair" +state real ca_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw04" "Calcium, aerosol in cloud bin 04" "ug/kg-dryair" +state real oin_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw04" "Other inorganics, aerosol in cloud bin 04" "ug/kg-dryair" +state real oc_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw04" "Organic carbon, aerosol in cloud bin 04" "ug/kg-dryair" +state real bc_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw04" "Black carbon, aerosol in cloud bin 04" "ug/kg-dryair" +state real num_cw04 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw04" "Number, aerosol in cloud bin 04" "#/kg-dryair" +state real so4_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw05" "Sulfate, aerosol in cloud bin 05" "ug/kg-dryair" +state real no3_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw05" "Nitrate, aerosol in cloud bin 05" "ug/kg-dryair" +state real cl_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw05" "Chloride, aerosol in cloud bin 05" "ug/kg-dryair" +state real msa_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw05" "MSA, aerosol in cloud bin 05" "ug/kg-dryair" +state real co3_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw05" "Carbonate, aerosol in cloud bin 05" "ug/kg-dryair" +state real nh4_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw05" "Ammonium, aerosol in cloud bin 05" "ug/kg-dryair" +state real na_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw05" "Sodium, aerosol in cloud bin 05" "ug/kg-dryair" +state real ca_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw05" "Calcium, aerosol in cloud bin 05" "ug/kg-dryair" +state real oin_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw05" "Other inorganics, aerosol in cloud bin 05" "ug/kg-dryair" +state real oc_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw05" "Organic carbon, aerosol in cloud bin 05" "ug/kg-dryair" +state real bc_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw05" "Black carbon, aerosol in cloud bin 05" "ug/kg-dryair" +state real num_cw05 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw05" "Number, aerosol in cloud bin 05" "#/kg-dryair" +state real so4_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw06" "Sulfate, aerosol in cloud bin 06" "ug/kg-dryair" +state real no3_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw06" "Nitrate, aerosol in cloud bin 06" "ug/kg-dryair" +state real cl_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw06" "Chloride, aerosol in cloud bin 06" "ug/kg-dryair" +state real msa_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw06" "MSA, aerosol in cloud bin 06" "ug/kg-dryair" +state real co3_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw06" "Carbonate, aerosol in cloud bin 06" "ug/kg-dryair" +state real nh4_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw06" "Ammonium, aerosol in cloud bin 06" "ug/kg-dryair" +state real na_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw06" "Sodium, aerosol in cloud bin 06" "ug/kg-dryair" +state real ca_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw06" "Calcium, aerosol in cloud bin 06" "ug/kg-dryair" +state real oin_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw06" "Other inorganics, aerosol in cloud bin 06" "ug/kg-dryair" +state real oc_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw06" "Organic carbon, aerosol in cloud bin 06" "ug/kg-dryair" +state real bc_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw06" "Black carbon, aerosol in cloud bin 06" "ug/kg-dryair" +state real num_cw06 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw06" "Number, aerosol in cloud bin 06" "#/kg-dryair" +state real so4_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw07" "Sulfate, aerosol in cloud bin 07" "ug/kg-dryair" +state real no3_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw07" "Nitrate, aerosol in cloud bin 07" "ug/kg-dryair" +state real cl_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw07" "Chloride, aerosol in cloud bin 07" "ug/kg-dryair" +state real msa_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw07" "MSA, aerosol in cloud bin 07" "ug/kg-dryair" +state real co3_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw07" "Carbonate, aerosol in cloud bin 07" "ug/kg-dryair" +state real nh4_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw07" "Ammonium, aerosol in cloud bin 07" "ug/kg-dryair" +state real na_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw07" "Sodium, aerosol in cloud bin 07" "ug/kg-dryair" +state real ca_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw07" "Calcium, aerosol in cloud bin 07" "ug/kg-dryair" +state real oin_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw07" "Other inorganics, aerosol in cloud bin 07" "ug/kg-dryair" +state real oc_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw07" "Organic carbon, aerosol in cloud bin 07" "ug/kg-dryair" +state real bc_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw07" "Black carbon, aerosol in cloud bin 07" "ug/kg-dryair" +state real num_cw07 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw07" "Number, aerosol in cloud bin 07" "#/kg-dryair" +state real so4_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_cw08" "Sulfate, aerosol in cloud bin 08" "ug/kg-dryair" +state real no3_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "no3_cw08" "Nitrate, aerosol in cloud bin 08" "ug/kg-dryair" +state real cl_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "cl_cw08" "Chloride, aerosol in cloud bin 08" "ug/kg-dryair" +state real msa_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "msa_cw08" "MSA, aerosol in cloud bin 08" "ug/kg-dryair" +state real co3_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "co3_cw08" "Carbonate, aerosol in cloud bin 08" "ug/kg-dryair" +state real nh4_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_cw08" "Ammonium, aerosol in cloud bin 08" "ug/kg-dryair" +state real na_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "na_cw08" "Sodium, aerosol in cloud bin 08" "ug/kg-dryair" +state real ca_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "ca_cw08" "Calcium, aerosol in cloud bin 08" "ug/kg-dryair" +state real oin_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oin_cw08" "Other inorganics, aerosol in cloud bin 08" "ug/kg-dryair" +state real oc_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "oc_cw08" "Organic carbon, aerosol in cloud bin 08" "ug/kg-dryair" +state real bc_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "bc_cw08" "Black carbon, aerosol in cloud bin 08" "ug/kg-dryair" +state real num_cw08 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_cw08" "Number, aerosol in cloud bin 08" "#/kg-dryair" + + +# time averaged stuff +state real RAINCV_A ij misc 1 - r "RAINCV_A" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" +state real RAINCV_B ij misc 1 - rh "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" +state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" +state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real GD_CLOUD_B ikj misc 1 - rh "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" +state real GD_CLOUD2_B ikj misc 1 - rh "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real cldfra_old ikj misc 1 - rh "CLDFRA_OLD" "old time level cldfra" "" +state integer STEPBIOE - misc 1 - r "STEPBIOE" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN BIOGENIC EMIS CALLS" "NA" +state integer STEPPHOT - misc 1 - r "STEPPHOT" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PHOTOLYSIS CALLS" "NA" +state integer STEPCHEM - misc 1 - r "STEPCHEM" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CHEM MECH CALLS" "NA" + +# +rconfig character emi_inname namelist,chem 1 "wrfchemi_d_" - "name of chem emissions infile" "" "" +rconfig character emi_outname namelist,chem 1 "wrfchemi_d_" - "name of chem emissions outfile" "" "" +rconfig character input_chem_inname namelist,chem 1 "wrf_chem_input_d_" - "name of chem infile" "" "" +rconfig character input_chem_outname namelist,chem 1 "wrf_chem_input_d_" - "name of chem outfile" "" "" +rconfig integer frames_per_emissfile namelist,chem 1 12 h "frames_per_emissfile" "" "" +rconfig integer io_style_emissions namelist,chem 1 1 - "io_style_emissions" "" "" +rconfig integer io_form_emissions namelist,chem 1 2 h "io_form_emissions" "" "" +rconfig real BIOEMDT namelist,chem max_domains 0 h "BIOEMDT" "" "" +rconfig real PHOTDT namelist,chem max_domains 0 h "PHOTDT" "" "" +rconfig real CHEMDT namelist,chem max_domains 0 h "CHEMDT" "" "" +rconfig integer ne_area namelist,chem 1 41 irh "ne_area" "" "" +rconfig integer kemit namelist,chem 1 9 irh "kemit" "" "" +# Default chemistry settings are: passive/prescribed aerosols (chem_opt=0) +# gas and aerosol calculations turned on (gaschem_onoff=1 and aerchem_onoff=1), these can be turned off for debugging, etc. +# wet scavenging and cloud chemistry turned off (wetscav_onoff=0 and cldchem_onoff=0) since these only work with a subset of chemistry options +# vertical mixing turned on (vertmix_onoff=1) since this is done via the dry deposition routine and works with all chem options +rconfig integer chem_conv_tr namelist,chem max_domains 1 rh "chem_conv_opt" "" "" +rconfig integer chem_opt namelist,chem max_domains 0 rh "chem_opt" "" "" +rconfig integer gaschem_onoff namelist,chem max_domains 1 rh "gaschem_onoff" "" "" +rconfig integer aerchem_onoff namelist,chem max_domains 1 rh "aerchem_onoff" "" "" +rconfig integer wetscav_onoff namelist,chem max_domains 0 rh "wetscav_onoff" "" "" +rconfig integer cldchem_onoff namelist,chem max_domains 0 rh "cldchem_onoff" "" "" +rconfig integer vertmix_onoff namelist,chem max_domains 1 rh "vertmix_onoff" "" "" +rconfig integer chem_in_opt namelist,chem max_domains 0 rh "chem_in_opt" "" "" +rconfig integer phot_opt namelist,chem max_domains 0 rh "phot_opt" "" "" +rconfig integer drydep_opt namelist,chem max_domains 0 rh "drydep_opt" "" "" +rconfig integer bio_emiss_opt namelist,chem max_domains 0 rh "bio_emiss_opt" "" "" +rconfig integer emiss_inpt_opt namelist,chem max_domains 1 rh "emiss_inpt_opt" "" "" +rconfig integer gas_bc_opt namelist,chem max_domains 1 rh "gas_bc_opt" "" "" +rconfig integer gas_ic_opt namelist,chem max_domains 1 rh "gas_ic_opt" "" "" +rconfig integer aer_bc_opt namelist,chem max_domains 1 rh "aer_bc_opt" "" "" +rconfig integer aer_ic_opt namelist,chem max_domains 1 rh "aer_ic_opt" "" "" +rconfig logical have_bcs_chem namelist,chem max_domains .false. rh "have_bcs_chem" "" "" +rconfig integer aer_ra_feedback namelist,chem max_domains 0 rh "aer_ra_feedback" "" "" + +# CHEMISTRY PACKAGE DEFINITIONS +# +package prescribe_aerosol chem_opt==0 - - +package radm2 chem_opt==1 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2 +package radm2sorg chem_opt==2 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn +package racm chem_opt==3 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2 +package racmsorg chem_opt==4 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn +package cbmz chem_opt==5 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,dms,msa,dmso,dmso2,ch3so2h,ch3sch2oo,ch3so2,ch3so3,ch3so2oo,ch3so2ch2oo,mtf +package cbmz_bb chem_opt==6 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2 +package cbmz_mosaic_4bin chem_opt==7 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04 +package cbmz_mosaic_8bin chem_opt==8 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08 +package cbmz_mosaic_4bin_aq chem_opt==9 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 +package cbmz_mosaic_8bin_aq chem_opt==10 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,num_cw08 +package radm2sorg_aq chem_opt==11 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package racmsorg_aq chem_opt==12 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package chem_tracer chem_opt==13 - chem:so2,no,ald,hcho,ora2,co + + +#cms++ +package radm2_kpp chem_opt==101 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,ho,ho2 + +package racm_mim_kpp chem_opt==102 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,hace,ishp,ison,mahp,mpan,nald,ho,ho2 + +package racm_kpp chem_opt==103 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2 + +package racmsorg_kpp chem_opt==104 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn + +package radm2sorg_kpp chem_opt==105 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn + + + +#cms-- + +package photmad phot_opt==1 - - +package photfastj phot_opt==2 - - +package wesely drydep_opt==1 - - +package gunther1 bio_emiss_opt==1 - - +package beis311 bio_emiss_opt==2 - - + +# emiss_inpt_default = radm2-sorgam emissions in "standard(=grell)" wrf-chem +# emiss_inpt_pnnl_cm = cbmz-mosaic emissions in "PNNL" format +# emiss_inpt_pnnl_rs = radm2-sorgam emissions in "PNNL" format (same as default except isoprene added) +package emiss_inpt_default emiss_inpt_opt==1 - - +package emiss_inpt_pnnl_cm emiss_inpt_opt==101 - - +package emiss_inpt_pnnl_rs emiss_inpt_opt==102 - - + +# gas/aer_bc/ic_default = bc/ic in "standard(=grell)" wrf-chem for radm2-sorgam species, +# and first-cut implementation for cbmz-mosaic species +# gas/aer_bc/ic_pnnl = bc/ic for PNNL simulations +package gas_bc_default gas_bc_opt==1 - - +package gas_bc_pnnl gas_bc_opt==101 - - +package gas_ic_default gas_ic_opt==1 - - +package gas_ic_pnnl gas_ic_opt==101 - - +package aer_bc_default aer_bc_opt==1 - - +package aer_bc_pnnl aer_bc_opt==101 - - +package aer_ic_default aer_ic_opt==1 - - +package aer_ic_pnnl aer_ic_opt==101 - - + diff --git a/wrfv2_fire/Registry/registry.io_boilerplate b/wrfv2_fire/Registry/registry.io_boilerplate new file mode 100644 index 00000000..4ea53870 --- /dev/null +++ b/wrfv2_fire/Registry/registry.io_boilerplate @@ -0,0 +1,658 @@ + +# registry.io_boilerplate +# +# Included by registry program +# +# Contains a number of standard state variables associated with I/O +# +# + +# Output file descriptor for a domain +state integer oid - - - - - "oid" "" "" +state integer auxhist1_oid - - - - - "auxhist1_oid" "" "" +state integer auxhist2_oid - - - - - "auxhist2_oid" "" "" +state integer auxhist3_oid - - - - - "auxhist3_oid" "" "" +state integer auxhist4_oid - - - - - "auxhist4_oid" "" "" +state integer auxhist5_oid - - - - - "auxhist5_oid" "" "" +state integer auxhist6_oid - - - - - "auxhist6_oid" "" "" +state integer auxhist7_oid - - - - - "auxhist7_oid" "" "" +state integer auxhist8_oid - - - - - "auxhist8_oid" "" "" +state integer auxhist9_oid - - - - - "auxhist9_oid" "" "" +state integer auxhist10_oid - - - - - "auxhist10_oid" "" "" +state integer auxhist11_oid - - - - - "auxhist11_oid" "" "" + +state integer auxinput1_oid - - - - - "auxinput1_oid" "" "" +state integer auxinput2_oid - - - - - "auxinput2_oid" "" "" +state integer auxinput3_oid - - - - - "auxinput3_oid" "" "" +state integer auxinput4_oid - - - - - "auxinput4_oid" "" "" +state integer auxinput5_oid - - - - - "auxinput5_oid" "" "" +state integer auxinput6_oid - - - - - "auxinput6_oid" "" "" +state integer auxinput7_oid - - - - - "auxinput7_oid" "" "" +state integer auxinput8_oid - - - - - "auxinput8_oid" "" "" +state integer auxinput9_oid - - - - - "auxinput9_oid" "" "" +state integer auxinput10_oid - - - - - "auxinput10_oid" "" "" +state integer auxinput11_oid - - - - - "auxinput11_oid" "" "" + +rconfig integer history_interval namelist,time_control max_domains 0 h "history_interval" "" "MINUTES" +rconfig integer frames_per_outfile namelist,time_control max_domains 10 h "frames_per_outfile" "" "" +rconfig integer frames_per_auxhist1 namelist,time_control max_domains 10 h "frames_per_auxhist1" "" "" +rconfig integer frames_per_auxhist2 namelist,time_control max_domains 10 h "frames_per_auxhist2" "" "" +rconfig integer frames_per_auxhist3 namelist,time_control max_domains 10 h "frames_per_auxhist3" "" "" +rconfig integer frames_per_auxhist4 namelist,time_control max_domains 10 h "frames_per_auxhist4" "" "" +rconfig integer frames_per_auxhist5 namelist,time_control max_domains 10 h "frames_per_auxhist5" "" "" +rconfig integer frames_per_auxhist6 namelist,time_control max_domains 10 h "frames_per_auxhist6" "" "" +rconfig integer frames_per_auxhist7 namelist,time_control max_domains 10 h "frames_per_auxhist7" "" "" +rconfig integer frames_per_auxhist8 namelist,time_control max_domains 10 h "frames_per_auxhist8" "" "" +rconfig integer frames_per_auxhist9 namelist,time_control max_domains 10 h "frames_per_auxhist9" "" "" +rconfig integer frames_per_auxhist10 namelist,time_control max_domains 10 h "frames_per_auxhist10" "" "" +rconfig integer frames_per_auxhist11 namelist,time_control max_domains 10 h "frames_per_auxhist11" "" "" +rconfig logical restart namelist,time_control 1 .false. h "restart" "" "" +rconfig integer restart_interval namelist,time_control 1 0 h "restart_interval" "" "MINUTES" +rconfig integer io_form_input namelist,time_control 1 2 h "io_form_input" "" "" +rconfig integer io_form_history namelist,time_control 1 2 h "io_form_history" "" "" +rconfig integer io_form_restart namelist,time_control 1 2 h "io_form_restart" "" "" +rconfig integer io_form_boundary namelist,time_control 1 2 h "io_form_boundary" "" "" +rconfig integer debug_level namelist,time_control 1 0 - "debug_level" "" "" +rconfig logical self_test_domain namelist,time_control 1 .false. - "self_test_domain" "" "" + + +rconfig character history_outname namelist,time_control 1 "wrfout_d_" - "name of history outfile" "" "" +rconfig character auxhist1_outname namelist,time_control 1 "auxhist1_d_" - "name of auxhist1 outfile" "" "" +rconfig character auxhist2_outname namelist,time_control 1 "auxhist2_d_" - "name of auxhist2 outfile" "" "" +rconfig character auxhist3_outname namelist,time_control 1 "auxhist3_d_" - "name of auxhist3 outfile" "" "" +rconfig character auxhist4_outname namelist,time_control 1 "auxhist4_d_" - "name of auxhist4 outfile" "" "" +rconfig character auxhist5_outname namelist,time_control 1 "auxhist5_d_" - "name of auxhist5 outfile" "" "" +rconfig character auxhist6_outname namelist,time_control 1 "auxhist6_d_" - "name of auxhist6 outfile" "" "" +rconfig character auxhist7_outname namelist,time_control 1 "auxhist7_d_" - "name of auxhist7 outfile" "" "" +rconfig character auxhist8_outname namelist,time_control 1 "auxhist8_d_" - "name of auxhist8 outfile" "" "" +rconfig character auxhist9_outname namelist,time_control 1 "auxhist9_d_" - "name of auxhist9 outfile" "" "" +rconfig character auxhist10_outname namelist,time_control 1 "auxhist10_d_" - "name of auxhist10 outfile" "" "" +rconfig character auxhist11_outname namelist,time_control 1 "auxhist11_d_" - "name of auxhist11 outfile" "" "" + +rconfig character history_inname namelist,time_control 1 "wrfhist_d_" - "name of history infile" "" "" +rconfig character auxhist1_inname namelist,time_control 1 "auxhist1_d_" - "name of auxhist1 infile" "" "" +rconfig character auxhist2_inname namelist,time_control 1 "auxhist2_d_" - "name of auxhist2 infile" "" "" +rconfig character auxhist3_inname namelist,time_control 1 "auxhist3_d_" - "name of auxhist3 infile" "" "" +rconfig character auxhist4_inname namelist,time_control 1 "auxhist4_d_" - "name of auxhist4 infile" "" "" +rconfig character auxhist5_inname namelist,time_control 1 "auxhist5_d_" - "name of auxhist5 infile" "" "" +rconfig character auxhist6_inname namelist,time_control 1 "auxhist6_d_" - "name of auxhist6 infile" "" "" +rconfig character auxhist7_inname namelist,time_control 1 "auxhist7_d_" - "name of auxhist7 infile" "" "" +rconfig character auxhist8_inname namelist,time_control 1 "auxhist8_d_" - "name of auxhist8 infile" "" "" +rconfig character auxhist9_inname namelist,time_control 1 "auxhist9_d_" - "name of auxhist9 infile" "" "" +rconfig character auxhist10_inname namelist,time_control 1 "auxhist10_d_" - "name of auxhist10 infile" "" "" +rconfig character auxhist11_inname namelist,time_control 1 "auxhist11_d_" - "name of auxhist11 infile" "" "" + +rconfig character auxinput1_outname namelist,time_control 1 "auxinput1_d_" - "name of auxinput1 outfile" "" "" +rconfig character auxinput2_outname namelist,time_control 1 "auxinput2_d_" - "name of auxinput2 outfile" "" "" +rconfig character auxinput3_outname namelist,time_control 1 "auxinput3_d_" - "name of auxinput3 outfile" "" "" +rconfig character auxinput4_outname namelist,time_control 1 "auxinput4_d_" - "name of auxinput4 outfile" "" "" +rconfig character auxinput5_outname namelist,time_control 1 "auxinput5_d_" - "name of auxinput5 outfile" "" "" +rconfig character auxinput6_outname namelist,time_control 1 "auxinput6_d_" - "name of auxinput6 outfile" "" "" +rconfig character auxinput7_outname namelist,time_control 1 "auxinput7_d_" - "name of auxinput7 outfile" "" "" +rconfig character auxinput8_outname namelist,time_control 1 "auxinput8_d_" - "name of auxinput8 outfile" "" "" +rconfig character auxinput9_outname namelist,time_control 1 "auxinput9_d_" - "name of auxinput9 outfile" "" "" +rconfig character auxinput10_outname namelist,time_control 1 "auxinput10_d_" - "name of auxinput10 outfile" "" "" +rconfig character auxinput11_outname namelist,time_control 1 "auxinput11_d_" - "name of auxinput11 outfile" "" "" + +ifdef EM_CORE=1 +rconfig character auxinput1_inname namelist,time_control 1 "met_em.d." - "name of auxinput1 infile" "" "" +endif +ifdef NMM_CORE=1 +rconfig character auxinput1_inname namelist,time_control 1 "met_nm.d." - "name of auxinput1 infile" "" "" +endif + +rconfig character auxinput2_inname namelist,time_control 1 "auxinput2_d" - "name of auxinput2 infile" "" "" +rconfig character auxinput3_inname namelist,time_control 1 "auxinput3_d" - "name of auxinput3 infile" "" "" +rconfig character auxinput4_inname namelist,time_control 1 "auxinput4_d" - "name of auxinput4 infile" "" "" +rconfig character auxinput5_inname namelist,time_control 1 "auxinput5_d" - "name of auxinput5 infile" "" "" +rconfig character auxinput6_inname namelist,time_control 1 "auxinput6_d" - "name of auxinput6 infile" "" "" +rconfig character auxinput7_inname namelist,time_control 1 "auxinput7_d" - "name of auxinput7 infile" "" "" +rconfig character auxinput8_inname namelist,time_control 1 "auxinput8_d" - "name of auxinput8 infile" "" "" +rconfig character auxinput9_inname namelist,time_control 1 "auxinput9_d" - "name of auxinput9 infile" "" "" +rconfig character gfdda_inname namelist,fdda 1 "gfdda_d" - "name of gfdda infile" "" "" +rconfig character auxinput11_inname namelist,time_control 1 "auxinput11_d" - "name of auxinput11 infile" "" "" + +rconfig integer history_interval_mo namelist,time_control max_domains 0 h "history_interval_mo" "" "MONTHS" +rconfig integer history_interval_d namelist,time_control max_domains 0 h "history_interval_d" "" "DAYS" +rconfig integer history_interval_h namelist,time_control max_domains 0 h "history_interval_h" "" "HOURS" +rconfig integer history_interval_m namelist,time_control max_domains 0 h "history_interval_m" "" "MINUTES" +rconfig integer history_interval_s namelist,time_control max_domains 0 h "history_interval_s" "" "SECONDS" + +rconfig integer inputout_interval_mo namelist,time_control max_domains 0 h "inputout_interval_mo" "" "MONTHS" +rconfig integer inputout_interval_d namelist,time_control max_domains 0 h "inputout_interval_d" "" "DAYS" +rconfig integer inputout_interval_h namelist,time_control max_domains 0 h "inputout_interval_h" "" "HOURS" +rconfig integer inputout_interval_m namelist,time_control max_domains 0 h "inputout_interval_m" "" "MINUTES" +rconfig integer inputout_interval_s namelist,time_control max_domains 0 h "inputout_interval_s" "" "SECONDS" +rconfig integer inputout_interval namelist,time_control max_domains 0 h "inputout_interval" "" "MINUTES" + +rconfig integer auxhist1_interval_mo namelist,time_control max_domains 0 h "auxhist1_interval_mo" "" "MONTHS" +rconfig integer auxhist1_interval_d namelist,time_control max_domains 0 h "auxhist1_interval_d" "" "DAYS" +rconfig integer auxhist1_interval_h namelist,time_control max_domains 0 h "auxhist1_interval_h" "" "HOURS" +rconfig integer auxhist1_interval_m namelist,time_control max_domains 0 h "auxhist1_interval_m" "" "MINUTES" +rconfig integer auxhist1_interval_s namelist,time_control max_domains 0 h "auxhist1_interval_s" "" "SECONDS" +rconfig integer auxhist1_interval namelist,time_control max_domains 0 h "auxhist1_interval" "" "MINUTES" + +rconfig integer auxhist2_interval_mo namelist,time_control max_domains 0 h "auxhist2_interval_mo" "" "MONTHS" +rconfig integer auxhist2_interval_d namelist,time_control max_domains 0 h "auxhist2_interval_d" "" "DAYS" +rconfig integer auxhist2_interval_h namelist,time_control max_domains 0 h "auxhist2_interval_h" "" "HOURS" +rconfig integer auxhist2_interval_m namelist,time_control max_domains 0 h "auxhist2_interval_m" "" "MINUTES" +rconfig integer auxhist2_interval_s namelist,time_control max_domains 0 h "auxhist2_interval_s" "" "SECONDS" +rconfig integer auxhist2_interval namelist,time_control max_domains 0 h "auxhist2_interval" "" "MINUTES" + +rconfig integer auxhist3_interval_mo namelist,time_control max_domains 0 h "auxhist3_interval_mo" "" "MONTHS" +rconfig integer auxhist3_interval_d namelist,time_control max_domains 0 h "auxhist3_interval_d" "" "DAYS" +rconfig integer auxhist3_interval_h namelist,time_control max_domains 0 h "auxhist3_interval_h" "" "HOURS" +rconfig integer auxhist3_interval_m namelist,time_control max_domains 0 h "auxhist3_interval_m" "" "MINUTES" +rconfig integer auxhist3_interval_s namelist,time_control max_domains 0 h "auxhist3_interval_s" "" "SECONDS" +rconfig integer auxhist3_interval namelist,time_control max_domains 0 h "auxhist3_interval" "" "MINUTES" + +rconfig integer auxhist4_interval_mo namelist,time_control max_domains 0 h "auxhist4_interval_mo" "" "MONTHS" +rconfig integer auxhist4_interval_d namelist,time_control max_domains 0 h "auxhist4_interval_d" "" "DAYS" +rconfig integer auxhist4_interval_h namelist,time_control max_domains 0 h "auxhist4_interval_h" "" "HOURS" +rconfig integer auxhist4_interval_m namelist,time_control max_domains 0 h "auxhist4_interval_m" "" "MINUTES" +rconfig integer auxhist4_interval_s namelist,time_control max_domains 0 h "auxhist4_interval_s" "" "SECONDS" +rconfig integer auxhist4_interval namelist,time_control max_domains 0 h "auxhist4_interval" "" "MINUTES" + +rconfig integer auxhist5_interval_mo namelist,time_control max_domains 0 h "auxhist5_interval_mo" "" "MONTHS" +rconfig integer auxhist5_interval_d namelist,time_control max_domains 0 h "auxhist5_interval_d" "" "DAYS" +rconfig integer auxhist5_interval_h namelist,time_control max_domains 0 h "auxhist5_interval_h" "" "HOURS" +rconfig integer auxhist5_interval_m namelist,time_control max_domains 0 h "auxhist5_interval_m" "" "MINUTES" +rconfig integer auxhist5_interval_s namelist,time_control max_domains 0 h "auxhist5_interval_s" "" "SECONDS" +rconfig integer auxhist5_interval namelist,time_control max_domains 0 h "auxhist5_interval" "" "MINUTES" + +rconfig integer auxhist6_interval_mo namelist,time_control max_domains 0 h "auxhist6_interval_mo" "" "MONTHS" +rconfig integer auxhist6_interval_d namelist,time_control max_domains 0 h "auxhist6_interval_d" "" "DAYS" +rconfig integer auxhist6_interval_h namelist,time_control max_domains 0 h "auxhist6_interval_h" "" "HOURS" +rconfig integer auxhist6_interval_m namelist,time_control max_domains 0 h "auxhist6_interval_m" "" "MINUTES" +rconfig integer auxhist6_interval_s namelist,time_control max_domains 0 h "auxhist6_interval_s" "" "SECONDS" +rconfig integer auxhist6_interval namelist,time_control max_domains 0 h "auxhist6_interval" "" "MINUTES" + +rconfig integer auxhist7_interval_mo namelist,time_control max_domains 0 h "auxhist7_interval_mo" "" "MONTHS" +rconfig integer auxhist7_interval_d namelist,time_control max_domains 0 h "auxhist7_interval_d" "" "DAYS" +rconfig integer auxhist7_interval_h namelist,time_control max_domains 0 h "auxhist7_interval_h" "" "HOURS" +rconfig integer auxhist7_interval_m namelist,time_control max_domains 0 h "auxhist7_interval_m" "" "MINUTES" +rconfig integer auxhist7_interval_s namelist,time_control max_domains 0 h "auxhist7_interval_s" "" "SECONDS" +rconfig integer auxhist7_interval namelist,time_control max_domains 0 h "auxhist7_interval" "" "MINUTES" + +rconfig integer auxhist8_interval_mo namelist,time_control max_domains 0 h "auxhist8_interval_mo" "" "MONTHS" +rconfig integer auxhist8_interval_d namelist,time_control max_domains 0 h "auxhist8_interval_d" "" "DAYS" +rconfig integer auxhist8_interval_h namelist,time_control max_domains 0 h "auxhist8_interval_h" "" "HOURS" +rconfig integer auxhist8_interval_m namelist,time_control max_domains 0 h "auxhist8_interval_m" "" "MINUTES" +rconfig integer auxhist8_interval_s namelist,time_control max_domains 0 h "auxhist8_interval_s" "" "SECONDS" +rconfig integer auxhist8_interval namelist,time_control max_domains 0 h "auxhist8_interval" "" "MINUTES" + +rconfig integer auxhist9_interval_mo namelist,time_control max_domains 0 h "auxhist9_interval_mo" "" "MONTHS" +rconfig integer auxhist9_interval_d namelist,time_control max_domains 0 h "auxhist9_interval_d" "" "DAYS" +rconfig integer auxhist9_interval_h namelist,time_control max_domains 0 h "auxhist9_interval_h" "" "HOURS" +rconfig integer auxhist9_interval_m namelist,time_control max_domains 0 h "auxhist9_interval_m" "" "MINUTES" +rconfig integer auxhist9_interval_s namelist,time_control max_domains 0 h "auxhist9_interval_s" "" "SECONDS" +rconfig integer auxhist9_interval namelist,time_control max_domains 0 h "auxhist9_interval" "" "MINUTES" + +rconfig integer auxhist10_interval_mo namelist,time_control max_domains 0 h "auxhist10_interval_mo" "" "MONTHS" +rconfig integer auxhist10_interval_d namelist,time_control max_domains 0 h "auxhist10_interval_d" "" "DAYS" +rconfig integer auxhist10_interval_h namelist,time_control max_domains 0 h "auxhist10_interval_h" "" "HOURS" +rconfig integer auxhist10_interval_m namelist,time_control max_domains 0 h "auxhist10_interval_m" "" "MINUTES" +rconfig integer auxhist10_interval_s namelist,time_control max_domains 0 h "auxhist10_interval_s" "" "SECONDS" +rconfig integer auxhist10_interval namelist,time_control max_domains 0 h "auxhist10_interval" "" "MINUTES" + +rconfig integer auxhist11_interval_mo namelist,time_control max_domains 0 h "auxhist11_interval_mo" "" "MONTHS" +rconfig integer auxhist11_interval_d namelist,time_control max_domains 0 h "auxhist11_interval_d" "" "DAYS" +rconfig integer auxhist11_interval_h namelist,time_control max_domains 0 h "auxhist11_interval_h" "" "HOURS" +rconfig integer auxhist11_interval_m namelist,time_control max_domains 0 h "auxhist11_interval_m" "" "MINUTES" +rconfig integer auxhist11_interval_s namelist,time_control max_domains 0 h "auxhist11_interval_s" "" "SECONDS" +rconfig integer auxhist11_interval namelist,time_control max_domains 0 h "auxhist11_interval" "" "MINUTES" + +rconfig integer auxinput1_interval_mo namelist,time_control max_domains 0 h "auxinput1_interval_mo" "" "MONTHS" +rconfig integer auxinput1_interval_d namelist,time_control max_domains 0 h "auxinput1_interval_d" "" "DAYS" +rconfig integer auxinput1_interval_h namelist,time_control max_domains 0 h "auxinput1_interval_h" "" "HOURS" +rconfig integer auxinput1_interval_m namelist,time_control max_domains 0 h "auxinput1_interval_m" "" "MINUTES" +rconfig integer auxinput1_interval_s namelist,time_control max_domains 0 h "auxinput1_interval_s" "" "SECONDS" +rconfig integer auxinput1_interval namelist,time_control max_domains 0 h "auxinput1_interval" "" "MINUTES" + +rconfig integer auxinput2_interval_mo namelist,time_control max_domains 0 h "auxinput2_interval_mo" "" "MONTHS" +rconfig integer auxinput2_interval_d namelist,time_control max_domains 0 h "auxinput2_interval_d" "" "DAYS" +rconfig integer auxinput2_interval_h namelist,time_control max_domains 0 h "auxinput2_interval_h" "" "HOURS" +rconfig integer auxinput2_interval_m namelist,time_control max_domains 0 h "auxinput2_interval_m" "" "MINUTES" +rconfig integer auxinput2_interval_s namelist,time_control max_domains 0 h "auxinput2_interval_s" "" "SECONDS" +rconfig integer auxinput2_interval namelist,time_control max_domains 0 h "auxinput2_interval" "" "MINUTES" + +rconfig integer auxinput3_interval_mo namelist,time_control max_domains 0 h "auxinput3_interval_mo" "" "MONTHS" +rconfig integer auxinput3_interval_d namelist,time_control max_domains 0 h "auxinput3_interval_d" "" "DAYS" +rconfig integer auxinput3_interval_h namelist,time_control max_domains 0 h "auxinput3_interval_h" "" "HOURS" +rconfig integer auxinput3_interval_m namelist,time_control max_domains 0 h "auxinput3_interval_m" "" "MINUTES" +rconfig integer auxinput3_interval_s namelist,time_control max_domains 0 h "auxinput3_interval_s" "" "SECONDS" +rconfig integer auxinput3_interval namelist,time_control max_domains 0 h "auxinput3_interval" "" "MINUTES" + +rconfig integer auxinput4_interval_mo namelist,time_control max_domains 0 h "auxinput4_interval_mo" "" "MONTHS" +rconfig integer auxinput4_interval_d namelist,time_control max_domains 0 h "auxinput4_interval_d" "" "DAYS" +rconfig integer auxinput4_interval_h namelist,time_control max_domains 0 h "auxinput4_interval_h" "" "HOURS" +rconfig integer auxinput4_interval_m namelist,time_control max_domains 0 h "auxinput4_interval_m" "" "MINUTES" +rconfig integer auxinput4_interval_s namelist,time_control max_domains 0 h "auxinput4_interval_s" "" "SECONDS" +rconfig integer auxinput4_interval namelist,time_control max_domains 0 h "auxinput4_interval" "" "MINUTES" + +rconfig integer auxinput5_interval_mo namelist,time_control max_domains 0 h "auxinput5_interval_mo" "" "MONTHS" +rconfig integer auxinput5_interval_d namelist,time_control max_domains 0 h "auxinput5_interval_d" "" "DAYS" +rconfig integer auxinput5_interval_h namelist,time_control max_domains 0 h "auxinput5_interval_h" "" "HOURS" +rconfig integer auxinput5_interval_m namelist,time_control max_domains 0 h "auxinput5_interval_m" "" "MINUTES" +rconfig integer auxinput5_interval_s namelist,time_control max_domains 0 h "auxinput5_interval_s" "" "SECONDS" +rconfig integer auxinput5_interval namelist,time_control max_domains 0 h "auxinput5_interval" "" "MINUTES" + +rconfig integer auxinput6_interval_mo namelist,time_control max_domains 0 h "auxinput6_interval_mo" "" "MONTHS" +rconfig integer auxinput6_interval_d namelist,time_control max_domains 0 h "auxinput6_interval_d" "" "DAYS" +rconfig integer auxinput6_interval_h namelist,time_control max_domains 0 h "auxinput6_interval_h" "" "HOURS" +rconfig integer auxinput6_interval_m namelist,time_control max_domains 0 h "auxinput6_interval_m" "" "MINUTES" +rconfig integer auxinput6_interval_s namelist,time_control max_domains 0 h "auxinput6_interval_s" "" "SECONDS" +rconfig integer auxinput6_interval namelist,time_control max_domains 0 h "auxinput6_interval" "" "MINUTES" + +rconfig integer auxinput7_interval_mo namelist,time_control max_domains 0 h "auxinput7_interval_mo" "" "MONTHS" +rconfig integer auxinput7_interval_d namelist,time_control max_domains 0 h "auxinput7_interval_d" "" "DAYS" +rconfig integer auxinput7_interval_h namelist,time_control max_domains 0 h "auxinput7_interval_h" "" "HOURS" +rconfig integer auxinput7_interval_m namelist,time_control max_domains 0 h "auxinput7_interval_m" "" "MINUTES" +rconfig integer auxinput7_interval_s namelist,time_control max_domains 0 h "auxinput7_interval_s" "" "SECONDS" +rconfig integer auxinput7_interval namelist,time_control max_domains 0 h "auxinput7_interval" "" "MINUTES" + +rconfig integer auxinput8_interval_mo namelist,time_control max_domains 0 h "auxinput8_interval_mo" "" "MONTHS" +rconfig integer auxinput8_interval_d namelist,time_control max_domains 0 h "auxinput8_interval_d" "" "DAYS" +rconfig integer auxinput8_interval_h namelist,time_control max_domains 0 h "auxinput8_interval_h" "" "HOURS" +rconfig integer auxinput8_interval_m namelist,time_control max_domains 0 h "auxinput8_interval_m" "" "MINUTES" +rconfig integer auxinput8_interval_s namelist,time_control max_domains 0 h "auxinput8_interval_s" "" "SECONDS" +rconfig integer auxinput8_interval namelist,time_control max_domains 0 h "auxinput8_interval" "" "MINUTES" + +rconfig integer auxinput9_interval_mo namelist,time_control max_domains 0 h "auxinput9_interval_mo" "" "MONTHS" +rconfig integer auxinput9_interval_d namelist,time_control max_domains 0 h "auxinput9_interval_d" "" "DAYS" +rconfig integer auxinput9_interval_h namelist,time_control max_domains 0 h "auxinput9_interval_h" "" "HOURS" +rconfig integer auxinput9_interval_m namelist,time_control max_domains 0 h "auxinput9_interval_m" "" "MINUTES" +rconfig integer auxinput9_interval_s namelist,time_control max_domains 0 h "auxinput9_interval_s" "" "SECONDS" +rconfig integer auxinput9_interval namelist,time_control max_domains 0 h "auxinput9_interval" "" "MINUTES" + +rconfig integer gfdda_interval_mo namelist,fdda max_domains 0 h "gfdda_interval_mo" "" "MONTHS" +rconfig integer gfdda_interval_d namelist,fdda max_domains 0 h "gfdda_interval_d" "" "DAYS" +rconfig integer gfdda_interval_h namelist,fdda max_domains 0 h "gfdda_interval_h" "" "HOURS" +rconfig integer gfdda_interval_m namelist,fdda max_domains 0 h "gfdda_interval_m" "" "MINUTES" +rconfig integer gfdda_interval_s namelist,fdda max_domains 0 h "gfdda_interval_s" "" "SECONDS" +rconfig integer gfdda_interval namelist,fdda max_domains 0 h "gfdda_interval" "" "MINUTES" + +rconfig integer auxinput11_interval_mo namelist,time_control max_domains 0 h "auxinput11_interval_mo" "" "MONTHS" +rconfig integer auxinput11_interval_d namelist,time_control max_domains 0 h "auxinput11_interval_d" "" "DAYS" +rconfig integer auxinput11_interval_h namelist,time_control max_domains 0 h "auxinput11_interval_h" "" "HOURS" +rconfig integer auxinput11_interval_m namelist,time_control max_domains 0 h "auxinput11_interval_m" "" "MINUTES" +rconfig integer auxinput11_interval_s namelist,time_control max_domains 0 h "auxinput11_interval_s" "" "SECONDS" +rconfig integer auxinput11_interval namelist,time_control max_domains 0 h "auxinput11_interval" "" "MINUTES" + + +rconfig integer restart_interval_mo namelist,time_control 1 0 h "restart_interval_mo" "" "MONTHS" +rconfig integer restart_interval_d namelist,time_control 1 0 h "restart_interval_d" "" "DAYS" +rconfig integer restart_interval_h namelist,time_control 1 0 h "restart_interval_h" "" "HOURS" +rconfig integer restart_interval_m namelist,time_control 1 0 h "restart_interval_m" "" "MINUTES" +rconfig integer restart_interval_s namelist,time_control 1 0 h "restart_interval_s" "" "SECONDS" + + +rconfig integer history_begin_y namelist,time_control max_domains 0 h "history_begin_y" "" "YEARS from start of run" +rconfig integer history_begin_mo namelist,time_control max_domains 0 h "history_begin_mo" "" "MONTHS from start of run" +rconfig integer history_begin_d namelist,time_control max_domains 0 h "history_begin_d" "" "DAYS from start of run" +rconfig integer history_begin_h namelist,time_control max_domains 0 h "history_begin_h" "" "HOURS from start of run" +rconfig integer history_begin_m namelist,time_control max_domains 0 h "history_begin_m" "" "MINUTES from start of run" +rconfig integer history_begin_s namelist,time_control max_domains 0 h "history_begin_s" "" "SECONDS from start of run" + +rconfig integer inputout_begin_y namelist,time_control max_domains 0 h "inputout_begin_y" "" "YEARS from start of run" +rconfig integer inputout_begin_mo namelist,time_control max_domains 0 h "inputout_begin_mo" "" "MONTHS from start of run" +rconfig integer inputout_begin_d namelist,time_control max_domains 0 h "inputout_begin_d" "" "DAYS from start of run" +rconfig integer inputout_begin_h namelist,time_control max_domains 0 h "inputout_begin_h" "" "HOURS from start of run" +rconfig integer inputout_begin_m namelist,time_control max_domains 0 h "inputout_begin_m" "" "MINUTES from start of run" +rconfig integer inputout_begin_s namelist,time_control max_domains 0 h "inputout_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist1_begin_y namelist,time_control max_domains 0 h "auxhist1_begin_y" "" "YEARS from start of run" +rconfig integer auxhist1_begin_mo namelist,time_control max_domains 0 h "auxhist1_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist1_begin_d namelist,time_control max_domains 0 h "auxhist1_begin_d" "" "DAYS from start of run" +rconfig integer auxhist1_begin_h namelist,time_control max_domains 0 h "auxhist1_begin_h" "" "HOURS from start of run" +rconfig integer auxhist1_begin_m namelist,time_control max_domains 0 h "auxhist1_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist1_begin_s namelist,time_control max_domains 0 h "auxhist1_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist2_begin_y namelist,time_control max_domains 0 h "auxhist2_begin_y" "" "YEARS from start of run" +rconfig integer auxhist2_begin_mo namelist,time_control max_domains 0 h "auxhist2_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist2_begin_d namelist,time_control max_domains 0 h "auxhist2_begin_d" "" "DAYS from start of run" +rconfig integer auxhist2_begin_h namelist,time_control max_domains 0 h "auxhist2_begin_h" "" "HOURS from start of run" +rconfig integer auxhist2_begin_m namelist,time_control max_domains 0 h "auxhist2_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist2_begin_s namelist,time_control max_domains 0 h "auxhist2_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist3_begin_y namelist,time_control max_domains 0 h "auxhist3_begin_y" "" "YEARS from start of run" +rconfig integer auxhist3_begin_mo namelist,time_control max_domains 0 h "auxhist3_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist3_begin_d namelist,time_control max_domains 0 h "auxhist3_begin_d" "" "DAYS from start of run" +rconfig integer auxhist3_begin_h namelist,time_control max_domains 0 h "auxhist3_begin_h" "" "HOURS from start of run" +rconfig integer auxhist3_begin_m namelist,time_control max_domains 0 h "auxhist3_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist3_begin_s namelist,time_control max_domains 0 h "auxhist3_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist4_begin_y namelist,time_control max_domains 0 h "auxhist4_begin_y" "" "YEARS from start of run" +rconfig integer auxhist4_begin_mo namelist,time_control max_domains 0 h "auxhist4_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist4_begin_d namelist,time_control max_domains 0 h "auxhist4_begin_d" "" "DAYS from start of run" +rconfig integer auxhist4_begin_h namelist,time_control max_domains 0 h "auxhist4_begin_h" "" "HOURS from start of run" +rconfig integer auxhist4_begin_m namelist,time_control max_domains 0 h "auxhist4_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist4_begin_s namelist,time_control max_domains 0 h "auxhist4_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist5_begin_y namelist,time_control max_domains 0 h "auxhist5_begin_y" "" "YEARS from start of run" +rconfig integer auxhist5_begin_mo namelist,time_control max_domains 0 h "auxhist5_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist5_begin_d namelist,time_control max_domains 0 h "auxhist5_begin_d" "" "DAYS from start of run" +rconfig integer auxhist5_begin_h namelist,time_control max_domains 0 h "auxhist5_begin_h" "" "HOURS from start of run" +rconfig integer auxhist5_begin_m namelist,time_control max_domains 0 h "auxhist5_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist5_begin_s namelist,time_control max_domains 0 h "auxhist5_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist6_begin_y namelist,time_control max_domains 0 h "auxhist6_begin_y" "" "YEARS from start of run" +rconfig integer auxhist6_begin_mo namelist,time_control max_domains 0 h "auxhist6_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist6_begin_d namelist,time_control max_domains 0 h "auxhist6_begin_d" "" "DAYS from start of run" +rconfig integer auxhist6_begin_h namelist,time_control max_domains 0 h "auxhist6_begin_h" "" "HOURS from start of run" +rconfig integer auxhist6_begin_m namelist,time_control max_domains 0 h "auxhist6_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist6_begin_s namelist,time_control max_domains 0 h "auxhist6_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist7_begin_y namelist,time_control max_domains 0 h "auxhist7_begin_y" "" "YEARS from start of run" +rconfig integer auxhist7_begin_mo namelist,time_control max_domains 0 h "auxhist7_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist7_begin_d namelist,time_control max_domains 0 h "auxhist7_begin_d" "" "DAYS from start of run" +rconfig integer auxhist7_begin_h namelist,time_control max_domains 0 h "auxhist7_begin_h" "" "HOURS from start of run" +rconfig integer auxhist7_begin_m namelist,time_control max_domains 0 h "auxhist7_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist7_begin_s namelist,time_control max_domains 0 h "auxhist7_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist8_begin_y namelist,time_control max_domains 0 h "auxhist8_begin_y" "" "YEARS from start of run" +rconfig integer auxhist8_begin_mo namelist,time_control max_domains 0 h "auxhist8_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist8_begin_d namelist,time_control max_domains 0 h "auxhist8_begin_d" "" "DAYS from start of run" +rconfig integer auxhist8_begin_h namelist,time_control max_domains 0 h "auxhist8_begin_h" "" "HOURS from start of run" +rconfig integer auxhist8_begin_m namelist,time_control max_domains 0 h "auxhist8_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist8_begin_s namelist,time_control max_domains 0 h "auxhist8_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist9_begin_y namelist,time_control max_domains 0 h "auxhist9_begin_y" "" "YEARS from start of run" +rconfig integer auxhist9_begin_mo namelist,time_control max_domains 0 h "auxhist9_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist9_begin_d namelist,time_control max_domains 0 h "auxhist9_begin_d" "" "DAYS from start of run" +rconfig integer auxhist9_begin_h namelist,time_control max_domains 0 h "auxhist9_begin_h" "" "HOURS from start of run" +rconfig integer auxhist9_begin_m namelist,time_control max_domains 0 h "auxhist9_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist9_begin_s namelist,time_control max_domains 0 h "auxhist9_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist10_begin_y namelist,time_control max_domains 0 h "auxhist10_begin_y" "" "YEARS from start of run" +rconfig integer auxhist10_begin_mo namelist,time_control max_domains 0 h "auxhist10_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist10_begin_d namelist,time_control max_domains 0 h "auxhist10_begin_d" "" "DAYS from start of run" +rconfig integer auxhist10_begin_h namelist,time_control max_domains 0 h "auxhist10_begin_h" "" "HOURS from start of run" +rconfig integer auxhist10_begin_m namelist,time_control max_domains 0 h "auxhist10_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist10_begin_s namelist,time_control max_domains 0 h "auxhist10_begin_s" "" "SECONDS from start of run" + +rconfig integer auxhist11_begin_y namelist,time_control max_domains 0 h "auxhist11_begin_y" "" "YEARS from start of run" +rconfig integer auxhist11_begin_mo namelist,time_control max_domains 0 h "auxhist11_begin_mo" "" "MONTHS from start of run" +rconfig integer auxhist11_begin_d namelist,time_control max_domains 0 h "auxhist11_begin_d" "" "DAYS from start of run" +rconfig integer auxhist11_begin_h namelist,time_control max_domains 0 h "auxhist11_begin_h" "" "HOURS from start of run" +rconfig integer auxhist11_begin_m namelist,time_control max_domains 0 h "auxhist11_begin_m" "" "MINUTES from start of run" +rconfig integer auxhist11_begin_s namelist,time_control max_domains 0 h "auxhist11_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput1_begin_y namelist,time_control max_domains 0 h "auxinput1_begin_y" "" "YEARS from start of run" +rconfig integer auxinput1_begin_mo namelist,time_control max_domains 0 h "auxinput1_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput1_begin_d namelist,time_control max_domains 0 h "auxinput1_begin_d" "" "DAYS from start of run" +rconfig integer auxinput1_begin_h namelist,time_control max_domains 0 h "auxinput1_begin_h" "" "HOURS from start of run" +rconfig integer auxinput1_begin_m namelist,time_control max_domains 0 h "auxinput1_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput1_begin_s namelist,time_control max_domains 0 h "auxinput1_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput2_begin_y namelist,time_control max_domains 0 h "auxinput2_begin_y" "" "YEARS from start of run" +rconfig integer auxinput2_begin_mo namelist,time_control max_domains 0 h "auxinput2_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput2_begin_d namelist,time_control max_domains 0 h "auxinput2_begin_d" "" "DAYS from start of run" +rconfig integer auxinput2_begin_h namelist,time_control max_domains 0 h "auxinput2_begin_h" "" "HOURS from start of run" +rconfig integer auxinput2_begin_m namelist,time_control max_domains 0 h "auxinput2_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput2_begin_s namelist,time_control max_domains 0 h "auxinput2_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput3_begin_y namelist,time_control max_domains 0 h "auxinput3_begin_y" "" "YEARS from start of run" +rconfig integer auxinput3_begin_mo namelist,time_control max_domains 0 h "auxinput3_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput3_begin_d namelist,time_control max_domains 0 h "auxinput3_begin_d" "" "DAYS from start of run" +rconfig integer auxinput3_begin_h namelist,time_control max_domains 0 h "auxinput3_begin_h" "" "HOURS from start of run" +rconfig integer auxinput3_begin_m namelist,time_control max_domains 0 h "auxinput3_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput3_begin_s namelist,time_control max_domains 0 h "auxinput3_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput4_begin_y namelist,time_control max_domains 0 h "auxinput4_begin_y" "" "YEARS from start of run" +rconfig integer auxinput4_begin_mo namelist,time_control max_domains 0 h "auxinput4_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput4_begin_d namelist,time_control max_domains 0 h "auxinput4_begin_d" "" "DAYS from start of run" +rconfig integer auxinput4_begin_h namelist,time_control max_domains 0 h "auxinput4_begin_h" "" "HOURS from start of run" +rconfig integer auxinput4_begin_m namelist,time_control max_domains 0 h "auxinput4_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput4_begin_s namelist,time_control max_domains 0 h "auxinput4_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput5_begin_y namelist,time_control max_domains 0 h "auxinput5_begin_y" "" "YEARS from start of run" +rconfig integer auxinput5_begin_mo namelist,time_control max_domains 0 h "auxinput5_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput5_begin_d namelist,time_control max_domains 0 h "auxinput5_begin_d" "" "DAYS from start of run" +rconfig integer auxinput5_begin_h namelist,time_control max_domains 0 h "auxinput5_begin_h" "" "HOURS from start of run" +rconfig integer auxinput5_begin_m namelist,time_control max_domains 0 h "auxinput5_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput5_begin_s namelist,time_control max_domains 0 h "auxinput5_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput6_begin_y namelist,time_control max_domains 0 h "auxinput6_begin_y" "" "YEARS from start of run" +rconfig integer auxinput6_begin_mo namelist,time_control max_domains 0 h "auxinput6_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput6_begin_d namelist,time_control max_domains 0 h "auxinput6_begin_d" "" "DAYS from start of run" +rconfig integer auxinput6_begin_h namelist,time_control max_domains 0 h "auxinput6_begin_h" "" "HOURS from start of run" +rconfig integer auxinput6_begin_m namelist,time_control max_domains 0 h "auxinput6_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput6_begin_s namelist,time_control max_domains 0 h "auxinput6_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput7_begin_y namelist,time_control max_domains 0 h "auxinput7_begin_y" "" "YEARS from start of run" +rconfig integer auxinput7_begin_mo namelist,time_control max_domains 0 h "auxinput7_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput7_begin_d namelist,time_control max_domains 0 h "auxinput7_begin_d" "" "DAYS from start of run" +rconfig integer auxinput7_begin_h namelist,time_control max_domains 0 h "auxinput7_begin_h" "" "HOURS from start of run" +rconfig integer auxinput7_begin_m namelist,time_control max_domains 0 h "auxinput7_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput7_begin_s namelist,time_control max_domains 0 h "auxinput7_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput8_begin_y namelist,time_control max_domains 0 h "auxinput8_begin_y" "" "YEARS from start of run" +rconfig integer auxinput8_begin_mo namelist,time_control max_domains 0 h "auxinput8_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput8_begin_d namelist,time_control max_domains 0 h "auxinput8_begin_d" "" "DAYS from start of run" +rconfig integer auxinput8_begin_h namelist,time_control max_domains 0 h "auxinput8_begin_h" "" "HOURS from start of run" +rconfig integer auxinput8_begin_m namelist,time_control max_domains 0 h "auxinput8_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput8_begin_s namelist,time_control max_domains 0 h "auxinput8_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput9_begin_y namelist,time_control max_domains 0 h "auxinput9_begin_y" "" "YEARS from start of run" +rconfig integer auxinput9_begin_mo namelist,time_control max_domains 0 h "auxinput9_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput9_begin_d namelist,time_control max_domains 0 h "auxinput9_begin_d" "" "DAYS from start of run" +rconfig integer auxinput9_begin_h namelist,time_control max_domains 0 h "auxinput9_begin_h" "" "HOURS from start of run" +rconfig integer auxinput9_begin_m namelist,time_control max_domains 0 h "auxinput9_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput9_begin_s namelist,time_control max_domains 0 h "auxinput9_begin_s" "" "SECONDS from start of run" + +rconfig integer gfdda_begin_y namelist,fdda max_domains 0 h "gfdda_begin_y" "" "YEARS from start of run" +rconfig integer gfdda_begin_mo namelist,fdda max_domains 0 h "gfdda_begin_mo" "" "MONTHS from start of run" +rconfig integer gfdda_begin_d namelist,fdda max_domains 0 h "gfdda_begin_d" "" "DAYS from start of run" +rconfig integer gfdda_begin_h namelist,fdda max_domains 0 h "gfdda_begin_h" "" "HOURS from start of run" +rconfig integer gfdda_begin_m namelist,fdda max_domains 0 h "gfdda_begin_m" "" "MINUTES from start of run" +rconfig integer gfdda_begin_s namelist,fdda max_domains 0 h "gfdda_begin_s" "" "SECONDS from start of run" + +rconfig integer auxinput11_begin_y namelist,time_control max_domains 0 h "auxinput11_begin_y" "" "YEARS from start of run" +rconfig integer auxinput11_begin_mo namelist,time_control max_domains 0 h "auxinput11_begin_mo" "" "MONTHS from start of run" +rconfig integer auxinput11_begin_d namelist,time_control max_domains 0 h "auxinput11_begin_d" "" "DAYS from start of run" +rconfig integer auxinput11_begin_h namelist,time_control max_domains 0 h "auxinput11_begin_h" "" "HOURS from start of run" +rconfig integer auxinput11_begin_m namelist,time_control max_domains 0 h "auxinput11_begin_m" "" "MINUTES from start of run" +rconfig integer auxinput11_begin_s namelist,time_control max_domains 0 h "auxinput11_begin_s" "" "SECONDS from start of run" + +rconfig integer restart_begin_y namelist,time_control 1 0 h "restart_begin_y" "" "YEARS from start of run" +rconfig integer restart_begin_mo namelist,time_control 1 0 h "restart_begin_mo" "" "MONTHS from start of run" +rconfig integer restart_begin_d namelist,time_control 1 0 h "restart_begin_d" "" "DAYS from start of run" +rconfig integer restart_begin_h namelist,time_control 1 0 h "restart_begin_h" "" "HOURS from start of run" +rconfig integer restart_begin_m namelist,time_control 1 0 h "restart_begin_m" "" "MINUTES from start of run" +rconfig integer restart_begin_s namelist,time_control 1 0 h "restart_begin_s" "" "SECONDS from start of run" + +rconfig integer history_end_y namelist,time_control max_domains 0 h "history_end_y" "" "YEARS from start of run" +rconfig integer history_end_mo namelist,time_control max_domains 0 h "history_end_mo" "" "MONTHS from start of run" +rconfig integer history_end_d namelist,time_control max_domains 0 h "history_end_d" "" "DAYS from start of run" +rconfig integer history_end_h namelist,time_control max_domains 0 h "history_end_h" "" "HOURS from start of run" +rconfig integer history_end_m namelist,time_control max_domains 0 h "history_end_m" "" "MINUTES from start of run" +rconfig integer history_end_s namelist,time_control max_domains 0 h "history_end_s" "" "SECONDS from start of run" + +rconfig integer inputout_end_y namelist,time_control max_domains 0 h "inputout_end_y" "" "YEARS from start of run" +rconfig integer inputout_end_mo namelist,time_control max_domains 0 h "inputout_end_mo" "" "MONTHS from start of run" +rconfig integer inputout_end_d namelist,time_control max_domains 0 h "inputout_end_d" "" "DAYS from start of run" +rconfig integer inputout_end_h namelist,time_control max_domains 0 h "inputout_end_h" "" "HOURS from start of run" +rconfig integer inputout_end_m namelist,time_control max_domains 0 h "inputout_end_m" "" "MINUTES from start of run" +rconfig integer inputout_end_s namelist,time_control max_domains 0 h "inputout_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist1_end_y namelist,time_control max_domains 0 h "auxhist1_end_y" "" "YEARS from start of run" +rconfig integer auxhist1_end_mo namelist,time_control max_domains 0 h "auxhist1_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist1_end_d namelist,time_control max_domains 0 h "auxhist1_end_d" "" "DAYS from start of run" +rconfig integer auxhist1_end_h namelist,time_control max_domains 0 h "auxhist1_end_h" "" "HOURS from start of run" +rconfig integer auxhist1_end_m namelist,time_control max_domains 0 h "auxhist1_end_m" "" "MINUTES from start of run" +rconfig integer auxhist1_end_s namelist,time_control max_domains 0 h "auxhist1_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist2_end_y namelist,time_control max_domains 0 h "auxhist2_end_y" "" "YEARS from start of run" +rconfig integer auxhist2_end_mo namelist,time_control max_domains 0 h "auxhist2_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist2_end_d namelist,time_control max_domains 0 h "auxhist2_end_d" "" "DAYS from start of run" +rconfig integer auxhist2_end_h namelist,time_control max_domains 0 h "auxhist2_end_h" "" "HOURS from start of run" +rconfig integer auxhist2_end_m namelist,time_control max_domains 0 h "auxhist2_end_m" "" "MINUTES from start of run" +rconfig integer auxhist2_end_s namelist,time_control max_domains 0 h "auxhist2_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist3_end_y namelist,time_control max_domains 0 h "auxhist3_end_y" "" "YEARS from start of run" +rconfig integer auxhist3_end_mo namelist,time_control max_domains 0 h "auxhist3_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist3_end_d namelist,time_control max_domains 0 h "auxhist3_end_d" "" "DAYS from start of run" +rconfig integer auxhist3_end_h namelist,time_control max_domains 0 h "auxhist3_end_h" "" "HOURS from start of run" +rconfig integer auxhist3_end_m namelist,time_control max_domains 0 h "auxhist3_end_m" "" "MINUTES from start of run" +rconfig integer auxhist3_end_s namelist,time_control max_domains 0 h "auxhist3_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist4_end_y namelist,time_control max_domains 0 h "auxhist4_end_y" "" "YEARS from start of run" +rconfig integer auxhist4_end_mo namelist,time_control max_domains 0 h "auxhist4_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist4_end_d namelist,time_control max_domains 0 h "auxhist4_end_d" "" "DAYS from start of run" +rconfig integer auxhist4_end_h namelist,time_control max_domains 0 h "auxhist4_end_h" "" "HOURS from start of run" +rconfig integer auxhist4_end_m namelist,time_control max_domains 0 h "auxhist4_end_m" "" "MINUTES from start of run" +rconfig integer auxhist4_end_s namelist,time_control max_domains 0 h "auxhist4_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist5_end_y namelist,time_control max_domains 0 h "auxhist5_end_y" "" "YEARS from start of run" +rconfig integer auxhist5_end_mo namelist,time_control max_domains 0 h "auxhist5_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist5_end_d namelist,time_control max_domains 0 h "auxhist5_end_d" "" "DAYS from start of run" +rconfig integer auxhist5_end_h namelist,time_control max_domains 0 h "auxhist5_end_h" "" "HOURS from start of run" +rconfig integer auxhist5_end_m namelist,time_control max_domains 0 h "auxhist5_end_m" "" "MINUTES from start of run" +rconfig integer auxhist5_end_s namelist,time_control max_domains 0 h "auxhist5_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist6_end_y namelist,time_control max_domains 0 h "auxhist6_end_y" "" "YEARS from start of run" +rconfig integer auxhist6_end_mo namelist,time_control max_domains 0 h "auxhist6_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist6_end_d namelist,time_control max_domains 0 h "auxhist6_end_d" "" "DAYS from start of run" +rconfig integer auxhist6_end_h namelist,time_control max_domains 0 h "auxhist6_end_h" "" "HOURS from start of run" +rconfig integer auxhist6_end_m namelist,time_control max_domains 0 h "auxhist6_end_m" "" "MINUTES from start of run" +rconfig integer auxhist6_end_s namelist,time_control max_domains 0 h "auxhist6_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist7_end_y namelist,time_control max_domains 0 h "auxhist7_end_y" "" "YEARS from start of run" +rconfig integer auxhist7_end_mo namelist,time_control max_domains 0 h "auxhist7_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist7_end_d namelist,time_control max_domains 0 h "auxhist7_end_d" "" "DAYS from start of run" +rconfig integer auxhist7_end_h namelist,time_control max_domains 0 h "auxhist7_end_h" "" "HOURS from start of run" +rconfig integer auxhist7_end_m namelist,time_control max_domains 0 h "auxhist7_end_m" "" "MINUTES from start of run" +rconfig integer auxhist7_end_s namelist,time_control max_domains 0 h "auxhist7_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist8_end_y namelist,time_control max_domains 0 h "auxhist8_end_y" "" "YEARS from start of run" +rconfig integer auxhist8_end_mo namelist,time_control max_domains 0 h "auxhist8_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist8_end_d namelist,time_control max_domains 0 h "auxhist8_end_d" "" "DAYS from start of run" +rconfig integer auxhist8_end_h namelist,time_control max_domains 0 h "auxhist8_end_h" "" "HOURS from start of run" +rconfig integer auxhist8_end_m namelist,time_control max_domains 0 h "auxhist8_end_m" "" "MINUTES from start of run" +rconfig integer auxhist8_end_s namelist,time_control max_domains 0 h "auxhist8_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist9_end_y namelist,time_control max_domains 0 h "auxhist9_end_y" "" "YEARS from start of run" +rconfig integer auxhist9_end_mo namelist,time_control max_domains 0 h "auxhist9_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist9_end_d namelist,time_control max_domains 0 h "auxhist9_end_d" "" "DAYS from start of run" +rconfig integer auxhist9_end_h namelist,time_control max_domains 0 h "auxhist9_end_h" "" "HOURS from start of run" +rconfig integer auxhist9_end_m namelist,time_control max_domains 0 h "auxhist9_end_m" "" "MINUTES from start of run" +rconfig integer auxhist9_end_s namelist,time_control max_domains 0 h "auxhist9_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist10_end_y namelist,time_control max_domains 0 h "auxhist10_end_y" "" "YEARS from start of run" +rconfig integer auxhist10_end_mo namelist,time_control max_domains 0 h "auxhist10_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist10_end_d namelist,time_control max_domains 0 h "auxhist10_end_d" "" "DAYS from start of run" +rconfig integer auxhist10_end_h namelist,time_control max_domains 0 h "auxhist10_end_h" "" "HOURS from start of run" +rconfig integer auxhist10_end_m namelist,time_control max_domains 0 h "auxhist10_end_m" "" "MINUTES from start of run" +rconfig integer auxhist10_end_s namelist,time_control max_domains 0 h "auxhist10_end_s" "" "SECONDS from start of run" + +rconfig integer auxhist11_end_y namelist,time_control max_domains 0 h "auxhist11_end_y" "" "YEARS from start of run" +rconfig integer auxhist11_end_mo namelist,time_control max_domains 0 h "auxhist11_end_mo" "" "MONTHS from start of run" +rconfig integer auxhist11_end_d namelist,time_control max_domains 0 h "auxhist11_end_d" "" "DAYS from start of run" +rconfig integer auxhist11_end_h namelist,time_control max_domains 0 h "auxhist11_end_h" "" "HOURS from start of run" +rconfig integer auxhist11_end_m namelist,time_control max_domains 0 h "auxhist11_end_m" "" "MINUTES from start of run" +rconfig integer auxhist11_end_s namelist,time_control max_domains 0 h "auxhist11_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput1_end_y namelist,time_control max_domains 0 h "auxinput1_end_y" "" "YEARS from start of run" +rconfig integer auxinput1_end_mo namelist,time_control max_domains 0 h "auxinput1_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput1_end_d namelist,time_control max_domains 0 h "auxinput1_end_d" "" "DAYS from start of run" +rconfig integer auxinput1_end_h namelist,time_control max_domains 0 h "auxinput1_end_h" "" "HOURS from start of run" +rconfig integer auxinput1_end_m namelist,time_control max_domains 0 h "auxinput1_end_m" "" "MINUTES from start of run" +rconfig integer auxinput1_end_s namelist,time_control max_domains 0 h "auxinput1_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput2_end_y namelist,time_control max_domains 0 h "auxinput2_end_y" "" "YEARS from start of run" +rconfig integer auxinput2_end_mo namelist,time_control max_domains 0 h "auxinput2_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput2_end_d namelist,time_control max_domains 0 h "auxinput2_end_d" "" "DAYS from start of run" +rconfig integer auxinput2_end_h namelist,time_control max_domains 0 h "auxinput2_end_h" "" "HOURS from start of run" +rconfig integer auxinput2_end_m namelist,time_control max_domains 0 h "auxinput2_end_m" "" "MINUTES from start of run" +rconfig integer auxinput2_end_s namelist,time_control max_domains 0 h "auxinput2_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput3_end_y namelist,time_control max_domains 0 h "auxinput3_end_y" "" "YEARS from start of run" +rconfig integer auxinput3_end_mo namelist,time_control max_domains 0 h "auxinput3_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput3_end_d namelist,time_control max_domains 0 h "auxinput3_end_d" "" "DAYS from start of run" +rconfig integer auxinput3_end_h namelist,time_control max_domains 0 h "auxinput3_end_h" "" "HOURS from start of run" +rconfig integer auxinput3_end_m namelist,time_control max_domains 0 h "auxinput3_end_m" "" "MINUTES from start of run" +rconfig integer auxinput3_end_s namelist,time_control max_domains 0 h "auxinput3_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput4_end_y namelist,time_control max_domains 0 h "auxinput4_end_y" "" "YEARS from start of run" +rconfig integer auxinput4_end_mo namelist,time_control max_domains 0 h "auxinput4_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput4_end_d namelist,time_control max_domains 0 h "auxinput4_end_d" "" "DAYS from start of run" +rconfig integer auxinput4_end_h namelist,time_control max_domains 0 h "auxinput4_end_h" "" "HOURS from start of run" +rconfig integer auxinput4_end_m namelist,time_control max_domains 0 h "auxinput4_end_m" "" "MINUTES from start of run" +rconfig integer auxinput4_end_s namelist,time_control max_domains 0 h "auxinput4_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput5_end_y namelist,time_control max_domains 0 h "auxinput5_end_y" "" "YEARS from start of run" +rconfig integer auxinput5_end_mo namelist,time_control max_domains 0 h "auxinput5_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput5_end_d namelist,time_control max_domains 0 h "auxinput5_end_d" "" "DAYS from start of run" +rconfig integer auxinput5_end_h namelist,time_control max_domains 0 h "auxinput5_end_h" "" "HOURS from start of run" +rconfig integer auxinput5_end_m namelist,time_control max_domains 0 h "auxinput5_end_m" "" "MINUTES from start of run" +rconfig integer auxinput5_end_s namelist,time_control max_domains 0 h "auxinput5_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput6_end_y namelist,time_control max_domains 0 h "auxinput6_end_y" "" "YEARS from start of run" +rconfig integer auxinput6_end_mo namelist,time_control max_domains 0 h "auxinput6_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput6_end_d namelist,time_control max_domains 0 h "auxinput6_end_d" "" "DAYS from start of run" +rconfig integer auxinput6_end_h namelist,time_control max_domains 0 h "auxinput6_end_h" "" "HOURS from start of run" +rconfig integer auxinput6_end_m namelist,time_control max_domains 0 h "auxinput6_end_m" "" "MINUTES from start of run" +rconfig integer auxinput6_end_s namelist,time_control max_domains 0 h "auxinput6_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput7_end_y namelist,time_control max_domains 0 h "auxinput7_end_y" "" "YEARS from start of run" +rconfig integer auxinput7_end_mo namelist,time_control max_domains 0 h "auxinput7_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput7_end_d namelist,time_control max_domains 0 h "auxinput7_end_d" "" "DAYS from start of run" +rconfig integer auxinput7_end_h namelist,time_control max_domains 0 h "auxinput7_end_h" "" "HOURS from start of run" +rconfig integer auxinput7_end_m namelist,time_control max_domains 0 h "auxinput7_end_m" "" "MINUTES from start of run" +rconfig integer auxinput7_end_s namelist,time_control max_domains 0 h "auxinput7_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput8_end_y namelist,time_control max_domains 0 h "auxinput8_end_y" "" "YEARS from start of run" +rconfig integer auxinput8_end_mo namelist,time_control max_domains 0 h "auxinput8_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput8_end_d namelist,time_control max_domains 0 h "auxinput8_end_d" "" "DAYS from start of run" +rconfig integer auxinput8_end_h namelist,time_control max_domains 0 h "auxinput8_end_h" "" "HOURS from start of run" +rconfig integer auxinput8_end_m namelist,time_control max_domains 0 h "auxinput8_end_m" "" "MINUTES from start of run" +rconfig integer auxinput8_end_s namelist,time_control max_domains 0 h "auxinput8_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput9_end_y namelist,time_control max_domains 0 h "auxinput9_end_y" "" "YEARS from start of run" +rconfig integer auxinput9_end_mo namelist,time_control max_domains 0 h "auxinput9_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput9_end_d namelist,time_control max_domains 0 h "auxinput9_end_d" "" "DAYS from start of run" +rconfig integer auxinput9_end_h namelist,time_control max_domains 0 h "auxinput9_end_h" "" "HOURS from start of run" +rconfig integer auxinput9_end_m namelist,time_control max_domains 0 h "auxinput9_end_m" "" "MINUTES from start of run" +rconfig integer auxinput9_end_s namelist,time_control max_domains 0 h "auxinput9_end_s" "" "SECONDS from start of run" + +rconfig integer gfdda_end_y namelist,fdda max_domains 0 h "gfdda_end_y" "" "YEARS from start of run" +rconfig integer gfdda_end_mo namelist,fdda max_domains 0 h "gfdda_end_mo" "" "MONTHS from start of run" +rconfig integer gfdda_end_d namelist,fdda max_domains 0 h "gfdda_end_d" "" "DAYS from start of run" +rconfig integer gfdda_end_h namelist,fdda max_domains 0 h "gfdda_end_h" "" "HOURS from start of run" +rconfig integer gfdda_end_m namelist,fdda max_domains 0 h "gfdda_end_m" "" "MINUTES from start of run" +rconfig integer gfdda_end_s namelist,fdda max_domains 0 h "gfdda_end_s" "" "SECONDS from start of run" + +rconfig integer auxinput11_end_y namelist,time_control max_domains 0 h "auxinput11_end_y" "" "YEARS from start of run" +rconfig integer auxinput11_end_mo namelist,time_control max_domains 0 h "auxinput11_end_mo" "" "MONTHS from start of run" +rconfig integer auxinput11_end_d namelist,time_control max_domains 0 h "auxinput11_end_d" "" "DAYS from start of run" +rconfig integer auxinput11_end_h namelist,time_control max_domains 0 h "auxinput11_end_h" "" "HOURS from start of run" +rconfig integer auxinput11_end_m namelist,time_control max_domains 0 h "auxinput11_end_m" "" "MINUTES from start of run" +rconfig integer auxinput11_end_s namelist,time_control max_domains 0 h "auxinput11_end_s" "" "SECONDS from start of run" + +rconfig integer io_form_auxinput1 namelist,time_control 1 2 h "io_form_auxinput1" "" "" +rconfig integer io_form_auxinput2 namelist,time_control 1 2 h "io_form_auxinput2" "" "" +rconfig integer io_form_auxinput3 namelist,time_control 1 2 h "io_form_auxinput3" "" "" +rconfig integer io_form_auxinput4 namelist,time_control 1 2 h "io_form_auxinput4" "" "" +rconfig integer io_form_auxinput5 namelist,time_control 1 2 h "io_form_auxinput5" "" "" +rconfig integer io_form_auxinput6 namelist,time_control 1 2 h "io_form_auxinput6" "" "" +rconfig integer io_form_auxinput7 namelist,time_control 1 2 h "io_form_auxinput7" "" "" +rconfig integer io_form_auxinput8 namelist,time_control 1 2 h "io_form_auxinput8" "" "" +rconfig integer io_form_auxinput9 namelist,time_control 1 2 h "io_form_auxinput9" "" "" +rconfig integer io_form_gfdda namelist,fdda 1 2 h "io_form_gfdda" "" "" +rconfig integer io_form_auxinput11 namelist,time_control 1 2 h "io_form_auxinput11" "" "" +rconfig integer io_form_auxhist1 namelist,time_control 1 2 h "io_form_auxhist1" "" "" +rconfig integer io_form_auxhist2 namelist,time_control 1 2 h "io_form_auxhist2" "" "" +rconfig integer io_form_auxhist3 namelist,time_control 1 2 h "io_form_auxhist3" "" "" +rconfig integer io_form_auxhist4 namelist,time_control 1 2 h "io_form_auxhist4" "" "" +rconfig integer io_form_auxhist5 namelist,time_control 1 2 h "io_form_auxhist5" "" "" +rconfig integer io_form_auxhist6 namelist,time_control 1 2 h "io_form_auxhist6" "" "" +rconfig integer io_form_auxhist7 namelist,time_control 1 2 h "io_form_auxhist7" "" "" +rconfig integer io_form_auxhist8 namelist,time_control 1 2 h "io_form_auxhist8" "" "" +rconfig integer io_form_auxhist9 namelist,time_control 1 2 h "io_form_auxhist9" "" "" +rconfig integer io_form_auxhist10 namelist,time_control 1 2 h "io_form_auxhist10" "" "" +rconfig integer io_form_auxhist11 namelist,time_control 1 2 h "io_form_auxhist11" "" "" + +rconfig integer sr_x namelist,domains max_domains 0 +rconfig integer sr_y namelist,domains max_domains 0 + diff --git a/wrfv2_fire/arch/Config.pl b/wrfv2_fire/arch/Config.pl new file mode 100644 index 00000000..bb56cf75 --- /dev/null +++ b/wrfv2_fire/arch/Config.pl @@ -0,0 +1,320 @@ +#!/usr/bin/perl +# +# Configuration script for WRF prototype code +# +# Be sure to run as ./configure (to avoid getting a system configure command by mistake) +# + +$sw_perl_path = perl ; +$sw_netcdf_path = "" ; +$sw_pnetcdf_path = "" ; +$sw_phdf5_path=""; +$sw_jasperlib_path=""; +$sw_jasperinc_path=""; +$sw_esmflib_path=""; +$sw_esmfinc_path=""; +$sw_ldflags=""; +$sw_compileflags=""; +$WRFCHEM = 0 ; +$sw_os = "ARCH" ; # ARCH will match any +$sw_mach = "ARCH" ; # ARCH will match any + +while ( substr( $ARGV[0], 0, 1 ) eq "-" ) + { + if ( substr( $ARGV[0], 1, 5 ) eq "perl=" ) + { + $sw_perl_path = substr( $ARGV[0], 6 ) ; + } + if ( substr( $ARGV[0], 1, 7 ) eq "netcdf=" ) + { + $sw_netcdf_path = substr( $ARGV[0], 8 ) ; + } + if ( substr( $ARGV[0], 1, 8 ) eq "pnetcdf=" ) + { + $sw_pnetcdf_path = substr( $ARGV[0], 9 ) ; + } + if ( substr( $ARGV[0], 1, 6 ) eq "phdf5=" ) + { + $sw_phdf5_path = substr( $ARGV[0], 7 ) ; + } + if ( substr( $ARGV[0], 1, 3 ) eq "os=" ) + { + $sw_os = substr( $ARGV[0], 4 ) ; + } + if ( substr( $ARGV[0], 1, 5 ) eq "mach=" ) + { + $sw_mach = substr( $ARGV[0], 6 ) ; + } + if ( substr( $ARGV[0], 1, 8 ) eq "ldflags=" ) + { + $sw_ldflags = substr( $ARGV[0], 9 ) ; +# multiple options separated by spaces are passed in from sh script +# separated by ! instead. Replace with spaces here. + $sw_ldflags =~ s/!/ /g ; + } + if ( substr( $ARGV[0], 1, 13 ) eq "compileflags=" ) + { + $sw_compileflags = substr( $ARGV[0], 14 ) ; + $sw_compileflags =~ s/!/ /g ; +# look for each known option + $where_index = index ( $sw_compileflags , "-DWRF_CHEM" ) ; + if ( $where_index eq -1 ) + { + $WRFCHEM = 0 ; + } + else + { + $WRFCHEM = 1 ; + } + } + shift @ARGV ; + } + +# The jasper library is required to build Grib2 I/O. User must set +# environment variables JASPERLIB and JASPERINC to paths to library and +# include files to enable this feature prior to running configure. + if ( $ENV{JASPERLIB} && $ENV{JASPERINC} ) + { + printf "Configuring to use jasper library to build Grib2 I/O...\n" ; + printf(" \$JASPERLIB = %s\n",$ENV{JASPERLIB}); + printf(" \$JASPERINC = %s\n",$ENV{JASPERINC}); + $sw_jasperlib_path = $ENV{JASPERLIB}; + $sw_jasperinc_path = $ENV{JASPERINC}; + } + else + { + printf "\$JASPERLIB or \$JASPERINC not found in environment, configuring to build without grib2 I/O...\n" ; + } + +# A separately-installed ESMF library is required to build the ESMF +# implementation of WRF IOAPI in external/io_esmf. This is needed +# to couple WRF with other ESMF components. User must set environment +# variables ESMFLIB and ESMFINC to paths ESMF to library and include +# files to enable this feature prior to running configure. + if ( $ENV{ESMFLIB} && $ENV{ESMFINC} ) + { + printf "Configuring to use ESMF library to build WRF...\n" ; + printf "WARNING-WARNING-WARNING-WARNING-WARNING-WARNING-WARNING-WARNING\n" ; + printf "WARNING: THIS IS AN EXPERIMENTAL CONFIGURATION\n" ; + printf "WARNING: IT DOES NOT WORK WITH NESTING\n" ; + printf "WARNING-WARNING-WARNING-WARNING-WARNING-WARNING-WARNING-WARNING\n" ; + printf(" \$ESMFLIB = %s\n",$ENV{ESMFLIB}); + printf(" \$ESMFINC = %s\n",$ENV{ESMFINC}); + $sw_esmflib_path = $ENV{ESMFLIB}; + $sw_esmfinc_path = $ENV{ESMFINC}; + } + +# parse the configure.wrf file + +$validresponse = 0 ; + +# Display the choices to the user and get selection +until ( $validresponse ) { + printf "------------------------------------------------------------------------\n" ; + printf "Please select from among the following supported platforms.\n\n" ; + + $opt = 1 ; + open CONFIGURE_DEFAULTS, "< ./arch/configure.defaults" + or die "Cannot open ./arch/configure.defaults for reading" ; + while ( ) + { + if ( substr( $_, 0, 5 ) eq "#ARCH" && ( index( $_, $sw_os ) >= 0 ) && ( index( $_, $sw_mach ) >= 0 ) ) + { + $optstr[$opt] = substr($_,6) ; + $optstr[$opt] =~ s/^[ ]*// ; + if ( substr( $optstr[$opt], 0,4 ) ne "NULL" ) + { + printf " %2d. %s",$opt,$optstr[$opt] ; + $opt++ ; + } + } + } + close CONFIGURE_DEFAULTS ; + + $opt -- ; + + printf "\nEnter selection [%d-%d] : ",1,$opt ; + $response = ; + + if ( $response == -1 ) { exit ; } + + if ( $response >= 1 && $response <= $opt ) + { $validresponse = 1 ; } + else + { printf("\nInvalid response (%d)\n",$response);} +} +printf "------------------------------------------------------------------------\n" ; + +$optchoice = $response ; + +open CONFIGURE_DEFAULTS, "< ./arch/configure.defaults" + or die "Cannot open ./arch/configure.defaults for reading" ; +$latchon = 0 ; +while ( ) +{ + if ( substr( $_, 0, 5 ) eq "#ARCH" && $latchon == 1 ) + { + $latchon = 0 ; + } + if ( $latchon == 1 ) + { + $_ =~ s/CONFIGURE_PERL_PATH/$sw_perl_path/g ; + $_ =~ s/CONFIGURE_NETCDF_PATH/$sw_netcdf_path/g ; + $_ =~ s/CONFIGURE_PNETCDF_PATH/$sw_pnetcdf_path/g ; + $_ =~ s/CONFIGURE_PHDF5_PATH/$sw_phdf5_path/g ; + $_ =~ s/CONFIGURE_LDFLAGS/$sw_ldflags/g ; + $_ =~ s/CONFIGURE_COMPILEFLAGS/$sw_compileflags/g ; + if ( $sw_netcdf_path ) + { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ; + $_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ; + $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L../external/io_netcdf -lwrfio_nf -L$sw_netcdf_path/lib -lnetcdf: ; + } + else + { $_ =~ s/CONFIGURE_WRFIO_NF//g ; + $_ =~ s:CONFIGURE_NETCDF_FLAG::g ; + $_ =~ s:CONFIGURE_NETCDF_LIB_PATH::g ; + } + + if ( $sw_pnetcdf_path ) + { $_ =~ s/CONFIGURE_WRFIO_PNF/wrfio_pnf/g ; + $_ =~ s:CONFIGURE_PNETCDF_FLAG:-DPNETCDF: ; + $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:-L../external/io_pnetcdf -lwrfio_pnf -L$sw_pnetcdf_path/lib -lpnetcdf: ; + } + else + { $_ =~ s/CONFIGURE_WRFIO_PNF//g ; + $_ =~ s:CONFIGURE_PNETCDF_FLAG::g ; + $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH::g ; + } + + if ( $sw_phdf5_path ) + + { $_ =~ s/CONFIGURE_WRFIO_PHDF5/wrfio_phdf5/g ; + $_ =~ s:CONFIGURE_PHDF5_FLAG:-DPHDF5: ; + $_ =~ s:CONFIGURE_PHDF5_LIB_PATH:-L../external/io_phdf5 -lwrfio_phdf5 -L$sw_phdf5_path/lib -lhdf5_fortran -lhdf5 -lm -lz -L$sw_phdf5_path/lib -lsz: ; + } + else + { $_ =~ s/CONFIGURE_WRFIO_PHDF5//g ; + $_ =~ s:CONFIGURE_PHDF5_FLAG::g ; + $_ =~ s:CONFIGURE_PHDF5_LIB_PATH::g ; + } + + if ( $sw_jasperlib_path && $sw_jasperinc_path ) + { $_ =~ s/CONFIGURE_WRFIO_GRIB2/wrfio_grib2/g ; + $_ =~ s:CONFIGURE_GRIB2_FLAG:-DGRIB2:g ; + $_ =~ s:CONFIGURE_GRIB2_INC:-I$sw_jasperinc_path:g ; + $_ =~ s:CONFIGURE_GRIB2_LIB:-L../external/io_grib2 -lio_grib2 -L$sw_jasperlib_path -ljasper:g ; + } + else + { $_ =~ s/CONFIGURE_WRFIO_GRIB2//g ; + $_ =~ s:CONFIGURE_GRIB2_FLAG::g ; + $_ =~ s:CONFIGURE_GRIB2_INC::g ; + $_ =~ s:CONFIGURE_GRIB2_LIB::g ; + } + + + # ESMF substitutions in configure.defaults + if ( $sw_esmflib_path && $sw_esmfinc_path ) + { + $_ =~ s:ESMFIOLIB:-L$sw_esmflib_path -lesmf -L../external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ; + $_ =~ s:ESMFIOEXTLIB:-L$sw_esmflib_path -lesmf -L../../external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ; + } + else + { + $_ =~ s:ESMFIOLIB:-L../external/esmf_time_f90 -lesmf_time:g ; + $_ =~ s:ESMFIOEXTLIB:-L../../external/esmf_time_f90 -lesmf_time:g ; + } + + @machopts = ( @machopts, $_ ) ; + if ( substr( $_, 0, 10 ) eq "ENVCOMPDEF" ) + { + @machopts = ( @machopts, "WRF_CHEM\t=\t$WRFCHEM \n" ) ; + } + } + if ( substr( $_, 0, 5 ) eq "#ARCH" && $latchon == 0 ) + { + $x=substr($_,6) ; + $x=~s/^[ ]*// ; + if ( $x eq $optstr[$optchoice] ) + { + $latchon = 1 ; + } + } +} +close CONFIGURE_DEFAULTS ; + +#printf "------------------------------------------------------------------------\n" ; +#foreach $f ( @machopts ) +#{ +# if ( substr( $f , 0 , 8 ) eq "external" ) { last ; } +# print $f ; +#} +#printf "------------------------------------------------------------------------\n" ; +#printf "\nYou have chosen: %s",$optstr[$optchoice] ; +#printf "Listed above are the default options for this platform.\n" ; +#printf "Settings are written to the file configure.wrf here in the top-level\n" ; +#printf "directory. If you wish to change settings, please edit that file.\n" ; +#printf "If you wish to change the default options, edit the file:\n\n" ; +#printf " arch/configure.defaults\n" ; +#printf "\n" ; + +open CONFIGURE_WRF, "> configure.wrf" or die "cannot append configure.wrf" ; +open ARCH_PREAMBLE, "< arch/preamble" or die "cannot open arch/preamble" ; +my @preamble; +# apply substitutions to the preamble... +while ( ) + { + # ESMF substitutions in preamble + if ( $sw_esmflib_path && $sw_esmfinc_path ) + { + $_ =~ s/ESMFCOUPLING/1/g ; + $_ =~ s:ESMFMODDEPENDENCE:../external/io_esmf/module_utility.o:g ; + $_ =~ s:ESMFMODINC:-I$sw_esmfinc_path -I../main:g ; + $_ =~ s:ESMFIOINC:-I../external/io_esmf:g ; + $_ =~ s:ESMFIODEFS:-DESMFIO:g ; + $_ =~ s:ESMFTARGET:wrfio_esmf:g ; + } + else + { + $_ =~ s/ESMFCOUPLING/0/g ; + $_ =~ s:ESMFMODDEPENDENCE:../external/esmf_time_f90/module_utility.o:g ; + $_ =~ s:ESMFMODINC::g ; + $_ =~ s:ESMFIOINC:-I../external/esmf_time_f90:g ; + $_ =~ s:ESMFIODEFS::g ; + $_ =~ s:ESMFTARGET:esmf_time:g ; + } + @preamble = ( @preamble, $_ ) ; + } +close ARCH_PREAMBLE ; +print CONFIGURE_WRF @preamble ; +close ARCH_PREAMBLE ; +printf CONFIGURE_WRF "# Settings for %s", $optstr[$optchoice] ; +print CONFIGURE_WRF @machopts ; +open ARCH_POSTAMBLE, "< arch/postamble" or die "cannot open arch/postamble" ; +while ( ) { print CONFIGURE_WRF } ; +close ARCH_POSTAMBLE ; +close CONFIGURE_WRF ; + +# Die if attempting to configure with both RSL_LITE and a separately-installed ESMF library +if ( $sw_esmflib_path && $sw_esmfinc_path ) + { + my $RSL_LITE_plus_ESMF = ""; + open CONFIGURE_WRF, "< configure.wrf" or die "cannot open configure.wrf for reading" ; + while ( ) + { + if ( $_ =~ /DRSL_LITE/ ) + { + $RSL_LITE_plus_ESMF = "TRUE"; + } + } + close CONFIGURE_WRF ; + if ( $RSL_LITE_plus_ESMF ) + { + unlink("configure.wrf") ; + die "\nCONFIGURATION FAILED: cannot use a separately-installed ESMF library with RSL_LITE. Please reconfigure to use RSL instead.\n\n" ; + } + } + +printf "Configuration successful. To build the model type compile . \n" ; +printf "------------------------------------------------------------------------\n" ; + + diff --git a/wrfv2_fire/arch/configure.defaults b/wrfv2_fire/arch/configure.defaults new file mode 100644 index 00000000..a0fa2354 --- /dev/null +++ b/wrfv2_fire/arch/configure.defaults @@ -0,0 +1,10629 @@ +########################################################### +#ARCH SGI 32 bit machine IRIX + +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCDEBUG = # -g +FCBASEOPTS = -freeform -I. -w +FCFLAGS = $(FCBASEOPTS) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) -freeform -I." RANLIB="$(RANLIB)" CPP="$(CPP)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_configure.o : module_configure.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + + +########################################################### +#ARCH SGI 32 bit machine, sycamore IRIX + +FC = f90 +SFC = $(FC) +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCDEBUG = # -g +FCBASEOPTS = -freeform -I. -w +FCFLAGS = -freeform -I. -w +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../frame -I../share -I../phys -I../chem \ + -I../external/esmf_time_f90 -I../inc +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_configure.o : module_configure.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI 64 bit machine IRIX64 (single-threaded, no nesting) + +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +CFLAGS = -64 -DLANDREAD_STUB -DNCARIBM_NOC99 +FCOPTIM = -O3 +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCDEBUG = # -g +FCBASEOPTS = -freeform -I. -64 -cpp -OPT:Olimit=5269 $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +PROMOTION = -r$(RWORDSIZE) -i4 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DINTIO -DLIMIT_ARGS -DLANDREAD_STUB +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -64 -OPT:Olimit=5269 CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_configure.o : module_configure.F + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -freeform -I. -64 -cpp -OPT:Olimit=5269 -w $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI O2K IRIX + +FC = f90 -n32 -mips4 -w +SFC = $(FC) +LD = f90 -n32 -mips4 -w +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -n32 -mips4 +FCDEBUG = # -g +FCBASEOPTS = -freeform -I. -w +FCFLAGS = -freeform -I. -O3 -OPT:roundoff=3:IEEE_arithmetic=3 -OPT:fold_arith_limit=2001 +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../frame -I../share \ + -I../phys -I../chem -I../inc -I../external/esmf_time_f90 +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +AR = ar ru +M4 = m4 -B14000 +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -C -P $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_configure.o : module_configure.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI 64 bit machine IRIX64 (OpenMP, no nesting) + +OMP = -mp +OMPCPP = -D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -64 -DLANDREAD_STUB -DNCARIBM_NOC99 +FCOPTIM = -O3 +FCDEBUG = # -g +FCBASEOPTS = -freeform -I. -64 -cpp -OPT:Olimit=5269 $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DINTIO -DLIMIT_ARGS -DLANDREAD_STUB +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH $(OMP) \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -64 -OPT:Olimit=5269 CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_configure.o : module_configure.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI O2K DM IRIX64 DM-Parallel (RSL, SGI-MPI, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# + +DMPARALLEL = 1 +MAX_PROC = 1024 +OMP = #-mp +OMPCPP = #-D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -w -64 -mips4 -DWRF_RSL_IO -DMAXDOM_MAKE=$(MAX_DOMAINS) \ + -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL -DDM_PARALLEL -DLANDREAD_STUB -DNCARIBM_NOC99 +FCDEBUG = # -g +FCOPTIM = -O3 -OPT:roundoff=3:IEEE_arithmetic=3 +FCBASEOPTS = -freeform -I. -64 -mips4 -w $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DINTIO -DGRIB1 CONFIGURE_GRIB2_FLAG -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 \ + -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DLANDREAD_STUB +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../frame -I../external/esmf_time_f90 \ + -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl -lmpi \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -64 $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the SGI Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) \ + LEARN_BCAST=-DLEARN_BCAST o2k ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_configure.o : module_configure.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Sun SunOS (single-threaded, no nesting) +# +FC = f95 +SFC = $(FC) +LD = f95 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -xtypemap=real:$(RSIZEBITS),integer:32 +CFLAGS = -DNCARIBM_NOC99 +FCOPTIM = -O2 # -O4 -xlibmopt +FCDEBUG = #-g +FCBASEOPTS = -fnonstd -free -xpp=cpp $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem \ + -M../external/io_netcdf -M../external/io_int -M../external/esmf_time_f90 \ + -M../frame -M../share -M../phys -M../inc -M../chem \ + -M../dyn_em +ARCHFLAGS = $(COREDEFS) -DINTIO -DGRIB1 CONFIGURE_GRIB2_FLAG -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +#CPP = /opt/SUNWspro/bin/fpp +CPP = /usr/ccs/lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Sun Fortran compiler complains about long source lines, #### +#### usually due to cpp translating __FILE__ to a full pathname. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCBASEOPTS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c $(FCBASEOPTS) -I. $(PROMOTION) $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +wrf_bdyin.o : wrf_bdyin.F +wrf_bdyout.o : wrf_bdyout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_restartin.o : wrf_restartin.F +wrf_restartout.o : wrf_restartout.F +module_configure.o : module_configure.F + +module_configure.o \ +shift_domain_em.o \ +wrf_bdyin.o wrf_bdyout.o \ +wrf_histin.o wrf_histout.o \ +wrf_inputin.o wrf_inputout.o \ +wrf_restartin.o wrf_restartout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o mediation_interp_domain.o \ +mediation_force_domain.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Sun SunOS (single-threaded, nesting using RSL and no MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DM_PARALLEL = 1 +OMP = +OMPCPP = +FC = f95 +SFC = $(FC) +LD = f95 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DSTUBMPI +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -xtypemap=real:$(RSIZEBITS),integer:32 +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL -DNCARIBM_NOC99 +FCOPTIM = -O2 # -O4 -xlibmopt +FCDEBUG = # -g +FCBASEOPTS = -fnonstd -free -xpp=cpp $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem \ + -M../external/io_netcdf -M../external/io_int -M../external/esmf_time_f90 \ + -M../frame -M../share -M../phys -M../inc -M../chem \ + -M../dyn_em +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/ccs/lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Sun Fortran compiler complains about long source lines, #### +#### usually due to cpp translating __FILE__ to a full pathname. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a gen_comms.c wrfio_int module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCBASEOPTS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-w -DSUN -DSTUBS -O' FC="$(FC) $(PROMOTION)" FFLAGS='-w -O' \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +wrf_bdyin.o : wrf_bdyin.F +wrf_bdyout.o : wrf_bdyout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_restartin.o : wrf_restartin.F +wrf_restartout.o : wrf_restartout.F +module_configure.o : module_configure.F + +module_configure.o \ +wrf_bdyin.o wrf_bdyout.o \ +wrf_histin.o wrf_histout.o \ +wrf_inputin.o wrf_inputout.o \ +wrf_restartin.o wrf_restartout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Sun SunOS SM (OpenMP, no nesting) +# +OMP = -mp=openmp -explicitpar -stackvar +OMPCPP = -D_OPENMP +FC = f95 +SFC = $(FC) +LD = f95 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -xtypemap=real:$(RSIZEBITS),integer:32 +CFLAGS = -DNCARIBM_NOC99 +FCOPTIM = -O3 -xlibmopt +FCDEBUG = #-g +FCBASEOPTS = -fnonstd -free -xpp=cpp $(FCDEBUG) $(OMP) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem \ + -M../external/io_netcdf -M../external/io_int -M../external/esmf_time_f90 \ + -M../frame -M../share -M../phys -M../inc -M../chem \ + -M../dyn_em +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +#CPP = /opt/SUNWspro/bin/fpp +CPP = /usr/ccs/lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Sun Fortran compiler complains about long source lines, #### +#### usually due to cpp translating __FILE__ to a full pathname. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCBASEOPTS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c $(FCBASEOPTS) -I. $(PROMOTION) $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Sun SunOS SM (OpenMP, nesting using RSL and no MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DM_PARALLEL = 1 +OMP = -mp=openmp -explicitpar -stackvar +OMPCPP = -D_OPENMP +FC = f95 +SFC = $(FC) +LD = f95 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DSTUBMPI +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -xtypemap=real:$(RSIZEBITS),integer:32 +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL -DNCARIBM_NOC99 +FCOPTIM = -O3 -xlibmopt +FCDEBUG = # -g +FCBASEOPTS = -fnonstd -free -xpp=cpp $(FCDEBUG) -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem \ + -M../external/io_netcdf -M../external/io_int -M../external/esmf_time_f90 \ + -M../frame -M../share -M../phys -M../inc -M../chem \ + -M../dyn_em +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/ccs/lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Sun Fortran compiler complains about long source lines, #### +#### usually due to cpp translating __FILE__ to a full pathname. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a gen_comms.c wrfio_int module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -cpp -free" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" FC="$(SFC) $(PROMOTION) $(FCBASEOPTS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-w -DSUN -DSTUBS -O' FC="$(FC) $(PROMOTION)" FFLAGS='-w -O' \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH AIX (single-threaded, no nesting) +# +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +CC = cc_r +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -qspill=20000 $(FCDEBUG) -qmaxmem=32767 -w #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFIXED = -qfixed +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90=F +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time + +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F +solve_interface.o : solve_interface.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F +module_integrate.o : module_integrate.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +# to prevent having to call our service representative +mediation_feedback_domain.o \ +mediation_force_domain.o start_domain.o module_integrate.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX SM (OpenMP, no nesting) +# +OMP = -qsmp=noauto:noopt +OMPCPP = -D_OPENMP +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +CC = cc_r +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv -lxlsmp \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +module_sm.o : module_sm.F +module_tiles.o : module_tiles.F +solve_em.o : solve_em.F +solve_exp.o : solve_exp.F +convert_nmm.o : convert_nmm.F + +module_sm.o module_tiles.o solve_em.o solve_exp.o convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $(OMPCPP) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(OMP) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +# Compiled WITHOUT ANY SMP, needed Mar 2005 +module_domain.o : module_domain.F + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +# compile these without high optimization to speed compile +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F +solve_interface.o : solve_interface.F +module_integrate.o : module_integrate.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_interface.o \ +shift_domain_em.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + + + +########################################################### +#ARCH AIX DM-Parallel (RSL_LITE, IBM-MPI, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpxlf90_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -I../external/RSL_LITE -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_pnetcdf \ + -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PNETCDF_FLAG \ + -DTRIEDNTRUE -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DNMM_NEST=$(WRF_NMM_NEST) +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH \ + -L../external/RSL_LITE -lrsl_lite -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +PNETCDFPATH = CONFIGURE_PNETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_pnf : + ( cd ../external/io_pnetcdf ; make NETCDFPATH=CONFIGURE_PNETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CFLAGS="$(CFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX DM-Parallel (RSL, IBM-MPI, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpxlf90_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFIXED = -qfixed +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/io_pnetcdf $(ESMF_IO_INC) \ + -I../frame -I../share -I../phys -I../chem -I../inc $(ESMF_MOD_INC) +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PNETCDF_FLAG \ + -DTRIEDNTRUE -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV $(ESMF_IO_DEFS) +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH \ + -L../external/RSL/RSL -lrsl -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o $(ESMF_IO_LIB) +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +PNETCDFPATH = CONFIGURE_PNETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F $(ESMF_TARGET) + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_pnf : + ( cd ../external/io_pnetcdf ; make NETCDFPATH=CONFIGURE_PNETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F +start_domain_nmm.o : start_domain_nmm.F +couple_or_uncouple_em.o : couple_or_uncouple_em.F +nest_init_utils.o : nest_init_utils.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +start_domain_nmm.o \ +couple_or_uncouple_em.o \ +nest_init_utils.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX DM-Parallel (RSL, IBM-MPI, allows nesting )(PARALLEL HDF5) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpxlf90_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=-1 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_phdf5 -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PHDF5_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PHDF5_LIB_PATH -L../external/RSL/RSL -lrsl -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 CONFIGURE_WRFIO_PHDF5 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_phdf5 : + ( cd ../external/io_phdf5 ; make PHDF5PATH=CONFIGURE_PHDF5_PATH FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qfree=F90 -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX DM-Parallel (RSL_LITE, IBM-MPI, Allows nesting )(PARALLEL HDF5) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpxlf90_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -I../external/RSL_LITE -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=-1 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_phdf5 -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PHDF5_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PHDF5_LIB_PATH -L../external/RSL_LITE -lrsl_lite -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 CONFIGURE_WRFIO_PHDF5 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_phdf5 : + ( cd ../external/io_phdf5 ; make PHDF5PATH=CONFIGURE_PHDF5_PATH FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qfree=F90 -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX DM-Parallel/SM-Parallel (not recommended) (RSL, IBM-MPI, OpenMP, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +OMP = -qsmp=noauto:noopt +OMPCPP = -D_OPENMP +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpxlf90_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl -lxlsmp -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc +MAX_PROC = 1024 + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 ) + +# compile these without high optimization to speed compile +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +convert_nmm.o \ +module_configure.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +mediation_integrate.o \ +mediation_interp_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +# to prevent having to call our service representative +mediation_feedback_domain.o \ +mediation_force_domain.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +# Compiled WITHOUT ANY SMP, needed Mar 2005 +module_domain.o : module_domain.F + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX DM-Parallel (RSL, IBM-MPI, MCEL) May 2003, EXPERIMENTAL +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = mpxlf90_r +LD = mpCC_r +CC = mpcc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +MCELHOME = /home/bluesky/bettenc/disttest +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../../inc -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DMCELIO -DLIMIT_ARGS \ + -DNO_NAMELIST_PRINT -DNATIVE_MASSV +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/RSL/RSL -lrsl -lmass -lmassv -lxlsmp \ + -L../external/io_mcel -lwrfio_mcel \ +-L$(MCELHOME)/MCELSystem/MCEL -lMCEL \ +-L$(MCELHOME)/lib -lomniORB4 \ +-lomnithread -lomniDynamic4 -lnetcdf_c++ -lnetcdf -lxlf90 -lxlopt \ + -lxlf -lxlomp_ser -lm -lc -lpthread \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int wrfio_mcel gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( cat ../tools/gen_comms_warning ../external/RSL/gen_comms.c > ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( cat module_dm_warning ../external/RSL/module_dm.F > module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +wrfio_mcel : + ( cd ../external/io_mcel ; \ + make CC="$(CC)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -I../../inc -I../io_netcdf -I../../frame -I../../share \ + -I$(MCELHOME)/MCELSystem/MCEL -qfree=f90" all ) + + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX (single-threaded, nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = xlf90_r +LD = xlf90_r +CC = cc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DSTUBMPI -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DSTUBMPI +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-DSTUBS -O -DNOUNDERSCORE' FC="$(FC) $(PROMOTION)" FFLAGS='-O -qfixed' \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F +couple_or_uncouple_em.o : couple_or_uncouple_em.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_force_domain.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_feedback_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +couple_or_uncouple_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH AIX (OpenMP, nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +OMP = -qsmp=noauto:noopt +OMPCPP = -D_OPENMP +DMPARALLEL = 1 +SFC = xlf90_r +SCC = cc_r +FC = xlf90_r +LD = xlf90_r +CC = cc_r +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DSTUBMPI -DNCARIBM_NOC99 +FCOPTIM = -O2 -qarch=auto +#FCOPTIM = -O3 -qhot +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = -lC +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DSTUBMPI +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-DSTUBS -O -DNOUNDERSCORE' FC="$(FC) $(PROMOTION)" FFLAGS='-O -qfixed' \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +start_domain.o : start_domain.F +convert_nmm.o : convert_nmm.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +solve_em.o : solve_em.F +solve_nmm.o : solve_nmm.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +start_domain.o \ +solve_interface.o \ +shift_domain_em.o \ +solve_em.o \ +solve_nmm.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $(OMPCPP) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(OMP) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +# Compiled WITHOUT ANY SMP, needed Mar 2005 +module_domain.o : module_domain.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +module_initialize_real.o : module_initialize_real.F + +module_domain.o \ +module_dm.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90 + +########################################################### +#ARCH Linux ppc64 BG (Blue Gene, RSL_LITE, IBM-MPI) +# +# from sheeba +BGL_SYS = /bgl/BlueLight/ppcfloor/bglsys +MPI_INC = -I$(BGL_SYS)/include +MPI_LIB = -L$(BGL_SYS)/lib -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts +TRACE_LIB = -L/contrib/bgl/mpi_trace -lmpitrace_c + +SFC = blrts_xlf90 +SCC = blrts_xlc +DMPARALLEL = 1 +FC = $(SFC) +LD = $(FC) +CC = $(SCC) + +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC) -I../external/RSL_LITE -DLANDREAD_STUB +FCOPTIM = -O2 -qarch=440 +FCDEBUG = # -qnoopt -qfullpath -qarch=440 + +FCBASEOPTS = -qspill=20000 $(FCDEBUG) -qmaxmem=64000 $(MPI_INC) -w #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) + +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_pnetcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc + +ARCHFLAGS = $(COREDEFS) -DDM_PARALLEL -DRSL_LITE -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG CONFIGURE_PNETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DLANDREAD_STUB + +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH \ + -L../external/RSL_LITE -lrsl_lite -L/bgl/local/lib -lmass -lmassv \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + $(TRACE_LIB) $(MPI_LIB) + +LDFLAGS = -Wl,--allow-multiple-definition -qstatic +ENVCOMPDEFS = +WRF_CHEM = 0 +CPP = /opt/ibmcmp/xlf/9.1/exe/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DF90_STANDALONE -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +#### this is a hand installed version of m4 on frost.ucar.edu +#### a copy is available at http://www.mmm.ucar.edu/wrf/WG2/BG/m4 +M4 = /home/janicec/m4 -B 12000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +PNETCDFPATH = CONFIGURE_PNETCDF_PATH +CC_TOOLS = cc +WRF_CONVERT = 0 + +externals : wrf_ioapi_includes ../external/RSL_LITE/librsl_lite.a CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF wrfio_int module_dm.F esmf_time gen_comms.c + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_pnf : + ( cd ../external/io_pnetcdf ; make NETCDFPATH=CONFIGURE_PNETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(MPI_INC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CFLAGS="$(CFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c -qfree=f90 -qspillsize=32767 -I. $(PROMOTION) $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +wrf_bdyout.o : wrf_bdyout.F +wrf_bdyin.o : wrf_bdyin.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F +solve_em.o : solve_em.F +start_em.o : start_em.F + +wrf_bdyout.o wrf_bdyin.o \ +wrf_restartout.o wrf_restartin.o wrf_inputin.o wrf_inputout.o wrf_histin.o wrf_histout.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +mediation_integrate.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_em.o \ +start_em.o \ +shift_domain_em.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +# to prevent having to call our service representative +mediation_feedback_domain.o \ +mediation_force_domain.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -qnoopt $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha (single-threaded, no nesting) +# +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) $(OMP) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha (single-threaded, nesting using RSL without MPI ) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DM_PARALLEL = 1 +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DSTUBMPI +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) $(OMP) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a gen_comms.c wrfio_int module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-DSTUBS -DSWAPBYTES -O' FC="$(FC) $(PROMOTION)" FFLAGS='-O -convert big_endian' \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha SM (OpenMP, no nesting) +# +OMP = -omp +OMPCPP = -D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCREAL8OMP = -align records -align dcommons -granularity quadword +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) $(FCREAL8OMP) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) $(FCREAL8OMP) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) $(OMP) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha SM-Parallel (OpenMP, nesting using RSL without MPI ) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DM_PARALLEL = 1 +OMP = -omp +OMPCPP = -D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DSTUBMPI +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCREAL8OMP = -align records -align dcommons -granularity quadword +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) $(FCREAL8OMP) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) $(FCREAL8OMP) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) $(OMP) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a gen_comms.c wrfio_int module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS='-DSTUBS -DSWAPBYTES -O' FC="$(FC) $(PROMOTION)" FFLAGS="-O -convert big_endian $(FCREAL8OMP)" \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel (RSL_LITE, MPICH, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DDM_PARALLEL -DRSL_LITE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL_LITE +FCOPTIM = -fast -O4 +FCDEBUG = #-g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL_LITE -lrsl_lite \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F +module_IGWAVE_ADJUST.o : module_IGWAVE_ADJUST.F + +nest_init_utils.o module_optional_si_input.o module_IGWAVE_ADJUST.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +start_domain_nmm.o : start_domain_nmm.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o start_domain_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel (RSL, MPICH, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST alpha ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F +start_em.o : start_em.F +start_domain_nmm.o : start_domain_nmm.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o start_em.o start_domain_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel/SM-Parallel (RSL, MPICH, OpenMP, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +OMP = -omp +OMPCPP = -D_OPENMP +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCREAL8OMP = -align records -align dcommons -granularity quadword +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) $(FCREAL8OMP) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) $(FCREAL8OMP) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCREAL8OMP)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST alpha ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel/SM-Parallel (RSL, DECMPI, OpenMP, allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +OMP = -omp +OMPCPP = -D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCREAL8OMP = -align records -align dcommons -granularity quadword +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) $(FCREAL8OMP) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) $(FCREAL8OMP) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl -lmpi \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCREAL8OMP) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC=cc FC="$(SFC) $(PROMOTION) $(FCREAL8OMP)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST alpha ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel (RSL, MPICH, MCEL EXPERIMENTAL) +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 -f90=cxx +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL -DRSL -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DMCELIO +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry + +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ +-L../external/io_mcel -lwrfio_mcel \ +-L/users/bettenc/MCELSystem/MCEL -lMCEL \ +-L/users/bettenc/lib -lOB -lJTC -lrt -lpthread \ +-lfor -lm -lnetcdf_c++ -lnetcdf -lpthread -lc -L/users/michalak/mpich/lib -lfmpich -lmpichfsup \ +/usr/lib/cmplrs/fortrtl/libUfor.a -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -pthread -ieee -ptr /users/bettenc/ptr -L/users/bettenc/MCELSystem/MCEL -lMCEL -L/users/bettenc/lib -lOB -lJTC -lrt -lpthread -lfor -lm -lnetcdf_c++ -lnetcdf -lpthread -lc CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a wrfio_mcel gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +wrfio_mcel : + ( cd ../external/io_mcel ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -I../io_netcdf -I../../frame -I../../share \ + -I/users/bettenc/MCELSystem/MCEL -convert big_endian -automatic -cpp -free" all ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST alpha ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F + +nest_init_utils.o module_optional_si_input.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM/SM (BUILD FOR AUTODOC ONLY -- DO NOT USE TO COMPILE CODE) +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = echo # mpif90 +SFC = echo # mpif90 +LD = echo # mpif90 +CC = echo # mpicc +SCC = echo # cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) -DAUTODOC_BUILD CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \ + -DDM_PARALLEL="'DM_PARALLEL'" -DRSL="'RSL'" \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DMOVE_NESTS +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST alpha ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Compaq OSF1 alpha DM-Parallel (RSL_LITE, MPICH, allows nesting, UNOPT shift_domain) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DDM_PARALLEL -DRSL_LITE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS -DFLOATSAFE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -real_size $(RSIZEBITS) -integer_size `expr 4 \* 8` +CFLAGS = $(ARCHFLAGS) -I../external/RSL_LITE +FCOPTIM = -fast -O4 +FCDEBUG = #-g +FCDEBUG_ESMF = # -O0 +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS_ESMF = -w -convert big_endian -automatic -cpp -free -I. -arch host $(FCDEBUG_ESMF) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +FCFLAGS_ESMF = $(FCOPTIM) $(FCBASEOPTS_ESMF) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/RSL_LITE -lrsl_lite \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1024 +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make IO_GRIB_SHARE_DIR="$(WRF_SRC_ROOT_DIR)/external/io_grib_share/" CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -convert big_endian -automatic -cpp -free -w " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) ) + +nest_init_utils.o : nest_init_utils.F +module_optional_si_input.o : module_optional_si_input.F +module_IGWAVE_ADJUST.o : module_IGWAVE_ADJUST.F + +nest_init_utils.o module_optional_si_input.o module_IGWAVE_ADJUST.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) -w -convert big_endian -automatic -cpp -free -I. -arch host $(MODULE_DIRS) $*.f90 + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +start_domain_nmm.o : start_domain_nmm.F +module_configure.o : module_configure.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +shift_domain_em.o : shift_domain_em.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +shift_domain_em.o \ +module_initialize_real.o start_domain.o start_domain_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -O0 $*.f90 + +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +mediation_wrfmain.o : mediation_wrfmain.F +solve_em.o : solve_em.F + +mediation_integrate.o module_dm.o mediation_wrfmain.o solve_em.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS_ESMF) $(MODULE_DIRS) -O0 $*.f90 + +########################################################### +#ARCH Alpha Linux alpha DM (single-threaded, no nesting) +# +FC = fort +SFC = $(FC) +LD = fort +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DF2CSTYLE +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCBASENOINL = -convert big_endian -O1 -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. \ + -arch host $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -traditional $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; \ + cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASENOINL) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Alpha Linux alpha SM (DOES NOT WORK ON JET! No nesting) +# +FC = fort +SFC = $(FC) +LD = fort +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DF2CSTYLE +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCBASENOINL = -convert big_endian -O1 -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. \ + -arch host $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -traditional -C -P `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + /bin/cp module_dm_warning module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASENOINL) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Alpha Linux alpha DM-Parallel (RSL, MPICH, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO -DF2CSTYLE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) \ + -I../external/RSL/RSL +FCOPTIM = -fast -O4 +FCDEBUG = # -g +FCBASENOINL = -convert big_endian -O1 -automatic -cpp -free -I. -arch host $(FCDEBUG) +FCBASEOPTS = -w -convert big_endian -automatic -cpp -free -I. \ + -arch host $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/io_int -lwrfio_int -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -automatic -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DDEC_ALPHA -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -traditional -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \ + TRADFLAG="-traditional" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" FC="$(FC) $(PROMOTION)" \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) \ + UNDERSCORE=-DF2CSTYLE LEARN_BCAST=-DLEARN_BCAST alpha ) + +# compile these without high optimization to speed compile +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASENOINL) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH VPP UNIX_System_V F300 5000 +# +FC = frt +SFC = $(FC) +LD = frt +CC = vcc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +FCFLAGS = -Free -X9 -Am +FCFLAGS = -Free -X9 -Sw -Wv,-Of,-te,-ilfunc,-noalias,-m3,-P255 -Oe,-P -Kfast -Am +FCDEBUG = # -g +FCBASEOPTS = $(FCFLAGS) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DLIMIT_ARGS +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +LDFLAGS = -Wl,-P -J CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +LDFLAGS = -J CONFIGURE_LDFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -Free -X9" archive ) + +########################################################### +#ARCH Cray +# +FC = f90 +SFC = $(FC) +CC = cc +SCC = $(CC) +NATIVE_RWORDSIZE = 8 +RWORDSIZE = $(NATIVE_RWORDSIZE) +# does this PROMOTION flag work on Cray? +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +FCFLAGS = -f free -N 255 -I. +FCDEBUG = # -g +FCBASEOPTS = $(FCFLAGS) +ARCHFLAGS = $(COREDEFS) -DCRAY CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DIWORDSIZE=8 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=8 \ + -DLIMIT_ARGS +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /opt/ctl/bin/cpp +POUND_DEF = -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +#LIB = CONFIGURE_NETCDF_LIB_PATH +LIB = ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCFLAGS)" archive ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c -O 0 $(PROMOTION) $(FCFLAGS) $*.f90 + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler (Single-threaded, no nesting) +# +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +SFC = $(FC) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +#FCBASEOPTS = -w -byteswapio -Mfree -Mipa=fast,inline,safe $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) -byteswapio CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler (single threaded, allows nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSTUBMPI +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL $(ARCHFLAGS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS='-DSTUBS' FC="$(FC) $(PROMOTION)" FFLAGS='-byteswapio' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler SM-Parallel (OpenMP, no nesting) +# +OMP = -mp +OMPCPP = -D_OPENMP +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +SFC = $(FC) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = $(OMPCPP) -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler SM-Parallel (OpenMP, allows nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +OMP = -mp +OMPCPP = -D_OPENMP +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSTUBMPI +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL $(ARCHFLAGS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(OMPCPP) -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS='-DSTUBS' FC="$(FC) $(PROMOTION)" FFLAGS='-byteswapio' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler DM-Parallel (RSL, MPICH, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=pgf90 +LD = mpif90 -f90=pgf90 +CC = mpicc -cc=gcc +SCC = gcc +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" FC="$(FC) $(PROMOTION) -byteswapio" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH PC Linux i486 i586 i686, PGI compiler DM-Parallel (RSL_LITE, MPICH, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=pgf90 +LD = mpif90 -f90=pgf90 +CC = mpicc -cc=gcc +SCC = gcc +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE +#FCOPTIM = -fastsse +FCOPTIM = -O2 # -fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +#Options for Debian Sarge systems +#FCBASEOPTS = -w -byteswapio -Mfree -Mipa=fast,inline,safe $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNMM_NEST=$(WRF_NMM_NEST) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" FC="$(FC) $(FCFLAGS) $(PROMOTION) -byteswapio" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +#PGI fi + +########################################################### +#ARCH Intel Itanium2 ia64 madison Linux DM-Parallel (e.g. mpp2 at PNNL), efc71 compiler (RSL, MPICH, nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +MAX_PROC = 2000 +FC = mpif90 +LD = mpif90 +CC = mpicc +SCC = cc +SFC = efc +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO -w \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL -size_lp64 \ + -I/usr/lib/mpi/mpi_intel/include +FCOPTIM = -O2 -ftz +FCDEBUG = #-g +FCBASEOPTS = $(FCDEBUG) -w -FR -I$(INCLUDE) -w -cm +FCNOOPTS = -O0 $(FCDEBUG) -FR -I$(INCLUDE) -w -cm +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) -size_lp64 +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \ + -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = ../main -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc \ + -I/usr/lib/mpi/mpi_intel/include +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) -LCONFIGURE_NETCDF_PATH/lib -lnetcdf \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/RSL/RSL -lrsl ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time -lmpifarg -lmpi -lelan -lintrins -lPEPCF90 \ + -limf -lguide -lunwind -lpthread -L/opt/mlib/lib/linux -lveclib8 +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional -C -P +POUND_DEF = -DNO_RRTM_PHYSICS \ + -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) $(ARCHFLAGS) $(COREDEFS) $(OMPCPP) \ + -I../external/RSL/RSL -C -EP `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = ecc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC='mpicc -w -I. '\ + FC="$(FC) $(PROMOTION) -cm -w " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCNOOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Intel Itanium2 ia64 Linux (eg. Jacaranda), ifort compiler (RSL, no-MPI, allows nesting) +# +# On Jacaranda, setenv NETCDF /jacaranda/users/michalak/netcdf-3.5.1 +# Built this netcdf by first setenv FC efc and CPPFLAGS '-DNDEBUG -DpgiFortran' +# before typing configure and make and make install 20040506. JM +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +MAX_PROC = 1 +# for multithreading, uncomment the following +#OMP = -openmp +#OMPCPP = -DOPEN_MP +FC = ifort +LD = ifort +CC = cc +SCC = $(CC) +SFC = ifort +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO -cm -w \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL -size_lp64 +FCOPTIM = -O2 -ftz +FCDEBUG = #-g +FCBASEOPTS = $(FCDEBUG) -w -FR -I$(INCLUDE) -cm -convert big_endian -mp +FCNOOPTS = -O0 $(FCDEBUG) -FR -I$(INCLUDE) -w -cm +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) -size_lp64 +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \ + -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS -DSTUBMPI +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = ../main -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) -LCONFIGURE_NETCDF_PATH/lib -lnetcdf \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/RSL/RSL -lrsl ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional -C -P +POUND_DEF = -DNO_RRTM_PHYSICS \ + -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) $(ARCHFLAGS) $(COREDEFS) $(OMPCPP) \ + -I../external/RSL/RSL -C `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS="-DSTUBS -O" \ + FC="$(FC) $(PROMOTION)" FCFLAGS="$(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +mediation_integrate.o : mediation_integrate.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +mediation_feedback_domain.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCNOOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux x86_64 (IA64 and Opteron), PGI compiler 5.2 or higher (Single-threaded, no nesting) +# Note that for 5.1.x comment out -Mpia=fast +# +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +SFC = $(FC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DLANDREAD_STUB +FCOPTIM = -fastsse #-Mipa=fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS -DLANDREAD_STUB +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux x86_64 (IA64 and Opteron), PGI 5.2 or higher, DM-Parallel (RSL, MPICH, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# Note that for 5.1.x comment out -Mpia=fast +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 +LD = mpif90 +CC = mpicc +SCC = gcc +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL \ + -DLANDREAD_STUB +FCOPTIM = -fastsse #-Mipa=fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DLANDREAD_STUB +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" FC="$(FC) $(PROMOTION) -byteswapio" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux x86_64 (IA64 and Opteron), PGI 5.2 or higher DM-Parallel (RSL_LITE, MPICH, Allows nesting, No periodic LBCs) +# Note that for 5.1.x comment out -Mpia=fast +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 +LD = mpif90 +CC = mpicc +SCC = gcc +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE \ + -DLANDREAD_STUB +FCOPTIM = -fastsse #-Mipa=fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DLANDREAD_STUB -DNMM_NEST=$(WRF_NMM_NEST) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -byteswapio" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### + +#ARCH PC Linux x86_64 (IA64 and Opteron), PGI compiler 5.2 or higher (Single-threaded, RSL, Allows nesting) +# Note that for 5.1.x comment out -Mpia=fast +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = pgf90 +LD = pgf90 +CC = gcc +SCC = $(CC) +SFC = pgf90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCOPTIM = -fastsse # -Mipa=fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSTUBMPI +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DLANDREADSTUB -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL $(ARCHFLAGS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS='-DSTUBS' FC="$(FC) $(PROMOTION)" FFLAGS='-byteswapio' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +# if [ ! -e $@ ] ; then \ +# sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi + +########################################################### +#ARCH Intel Itanium2 ia64 madison Linux (e.g. mpp2 at PNNL) , efc71 compiler DM-Parallel (RSL_LITE, MPICH, Allows nesting ) +# Notes for running on PNNL cluster: +# +# 1. source /home/oehmen/.mycshrc +# 2. source /home/mscf/intel7.1/compiler70/ia64/bin/efcvars.csh +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 2000 +FC = mpif90 +LD = mpif90 +CC = mpicc +SCC = gcc +SFC = efc +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -w -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) \ + -I../external/RSL_LITE -size_lp64 -I/usr/lib/mpi/mpi_intel/include +FCOPTIM = -O2 -ftz +FCDEBUG = #-g +FCBASEOPTS = $(FCDEBUG) -w -FR -I$(INCLUDE) -cm +FCNOOPTS = -O0 $(FCDEBUG) -FR -I$(INCLUDE) -w -cm +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) -size_lp64 +ARCHFLAGS = $(COREDEFS) -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \ + -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = ../main -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem \ + -I/usr/lib/mpi/mpi_intel/include +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) -LCONFIGURE_NETCDF_PATH/lib -lnetcdf -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time \ + -lmpifarg -lmpi -lelan -lintrins -lPEPCF90 -limf -lguide -lunwind -lpthread -L/opt/mlib/lib/linux -lveclib8 +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \ + -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) $(ARCHFLAGS) $(COREDEFS) $(OMPCPP) -I$(INCLUDE) \ + -I../external/RSL_LITE -C -EP `cat ../inc/dm_comm_cpp_flags` $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = ecc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC='mpicc -w -I.' \ + FC="$(FC) $(PROMOTION) $(FCFLAGS) -cm -w " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCNOOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH titan.ncsa.uiuc.edu specific Intel Itanium2 ia64 mckinley Linux, efc compiler DM-Parallel (RSL, VMI, allows nesting) +# +# Consider 'setenv F_UFMTENDIAN big' in your run scripts for big-endian output +# Note hard-coded paths to Mark Straka's accounts and ecc6 libs +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +#OMP = -openmp +#OMPCPP = -D_OPENMP +INCLUDE = ../external/io_netcdf/ +MAX_PROC = 256 +FC = efc -I.. -I/usr/local/vmi/mpich/include +LD = efc +CC = ecc -I. -I/usr/local/vmi/mpich/include +SCC = $(CC) +SFC = efc +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -DWRF_RSL_IO \ +-DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL -size_lp64 +FCOPTIM = -O3 -ftz +FCDEBUG = #-g +FCBASEOPTS = $(FCDEBUG) -w -FR -I$(INCLUDE) -I. -cm +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) -size_lp64 +ARCHFLAGS = $(COREDEFS) -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ +-DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \ +-DGRIB1 CONFIGURE_GRIB2_FLAG +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ +-I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -Vaxlib -L../external/io_netcdf -lwrfio_nf $(OMP) -L/u/ncsa/straka/AUGUST.test/WRFV1/netcdfintel7/lib -lnetcdf -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ +-L../external/io_int -lwrfio_int \ +../frame/module_internal_header_util.o ../frame/pack_utils.o -L/usr/local/vmi/mpich/lib/ecc6 -lmpich -lfmpich -lvmi -ldl -lpthread -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -traditional -I$(LIBINCLUDE) -C -P $(COREDEFS) $(ARCHFLAGS) $(OMPCPP) -I$(INCLUDE) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = ecc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time io_grib1 + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Vaxlib -I../.. $(FCFLAGS) -w" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="efc -Vaxlib -I/usr/local/vmi/mpich/include $(FCDEBUG) $(FCFLAGS) -w" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +#../external/RSL/RSL/librsl.a : +# ( cd ../external/RSL/RSL ; \ +# make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) \ +# LEARN_BCAST=-DLEARN_BCAST o2k ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC='ecc -Vaxlib -I. -cm -w -I/usr/local/vmi/mpich/include '\ + FC="$(SFC) $(PROMOTION) -cm -w -Vaxlib -I../../.. " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH titan.ncsa.uiuc.edu specific Intel Itanium2 ia64 mckinley Linux, efc compiler DM-Parallel (RSL_LITE, VMI, allows nesting) +# +# Consider 'setenv F_UFMTENDIAN big' in your run scripts for big-endian output +# Note hard-coded paths to Mark Straka's accounts and ecc6 libs +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +INCLUDE = ../external/io_netcdf/ +MAX_PROC = 256 +FC = efc -I.. -I/usr/local/vmi/mpich/include +LD = efc +CC = ecc -I. -I/usr/local/vmi/mpich/include +SCC = $(CC) +SFC = efc +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL -I../external/RSL_LITE \ +-DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -size_lp64 +FCOPTIM = -O3 -ftz +FCDEBUG = #-g +FCBASEOPTS = $(FCDEBUG) -w -FR -I$(INCLUDE) -I. -cm +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) -size_lp64 +ARCHFLAGS = $(COREDEFS) -DRSL_LITE -DDM_PARALLEL \ +-DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \ +-DGRIB1 CONFIGURE_GRIB2_FLAG +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ +-I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = -Vaxlib -L../external/io_netcdf -lwrfio_nf $(OMP) -L/u/ncsa/straka/AUGUST.test/WRFV1/netcdfintel7/lib -lnetcdf -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ +-L../external/io_int -lwrfio_int \ +../frame/module_internal_header_util.o ../frame/pack_utils.o -L/usr/local/vmi/mpich/lib/ecc6 -lmpich -lfmpich -lvmi -ldl -lpthread -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -traditional -I$(LIBINCLUDE) -C -P $(COREDEFS) $(ARCHFLAGS) $(OMPCPP) -I$(INCLUDE) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = ecc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Vaxlib -I../.. $(FCFLAGS) -w" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) -Vaxlib -I/usr/local/vmi/mpich/include $(FCDEBUG) $(FCFLAGS) -w" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -Vaxlib -I/usr/local/vmi/mpich/include $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" RANLIB="$(RANLIB)" FC="$(SFC) $(PROMOTION) -Vaxlib -I/usr/local/vmi/mpich/include $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" RANLIB="$(RANLIB)" FC="$(SFC) $(PROMOTION) -Vaxlib -I/usr/local/vmi/mpich/include $(FCDEBUG) $(FCFLAGS) -w" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC='ecc -Vaxlib -I. -cm -w -I/usr/local/vmi/mpich/include' \ + FC="$(FC) $(PROMOTION) $(FCFLAGS) -cm -w -Vaxlib -I../../.. " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort compiler (single-threaded, no nesting) +# +OMP = +OMPCPP = +FC = ifort +CC = gcc +SCC = $(CC) +SFC = $(FC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +FCDEBUG = # -g +FCBASEOPTS = -w -FR -cm -I. -Vaxlib -convert big_endian -mp +FCOPTIM = -O2 +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +CFLAGS = -w +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DLIMIT_ARGS -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG +LD = $(FC) +LDFLAGS = $(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = $(OMPCPP) $(COREDEFS) -DNONSTANDARD_SYSTEM \ + -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share +AR = ar ru +M4 = m4 -B14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -FR -I. -w" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +wrf_bdyin.o : wrf_bdyin.F +wrf_bdyout.o : wrf_bdyout.F +wrf_histin.o : wrf_histin.F +wrf_histout.o : wrf_histout.F +wrf_inputin.o : wrf_inputin.F +wrf_inputout.o : wrf_inputout.F +wrf_restartin.o : wrf_restartin.F +wrf_restartout.o : wrf_restartout.F + +wrf_bdyin.o wrf_bdyout.o \ +wrf_histin.o wrf_histout.o \ +wrf_inputin.o wrf_inputout.o \ +wrf_restartin.o wrf_restartout.o \ +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort compiler (single threaded, allows nesting using RSL without MPI) +# +# Note: if you use ifort 8.0, please remove option -xW (for vectorization). This option +# has been identified to produce wrong results occationally. +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +OMP = +OMPCPP = +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = ifort +LD = ifort +CC = gcc +SCC = $(CC) +SFC = ifort +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +FCOPTIM = -O3 # -xW +FCDEBUG = #-g +FCBASEOPTS = -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSTUBMPI \ +CFLAGS = -w -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL $(ARCHFLAGS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(OMPCPP) $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) -DGRIB1 CONFIGURE_GRIB2_FLAG +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = gcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" \ + CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" CFLAGS="-DSTUBS $(CFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort compiler (OpenMP) +# +# Note: if you use ifort 8.0, please remove option -xW (for vectorization). This option +# has been identified to produce wrong results occationally. +# +OMP = -openmp -fpp -auto +OMPCPP = -D_OPENMP +FC = ifort +LD = ifort +CC = gcc +SCC = $(CC) +SFC = $(FC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +CFLAGS = +FCOPTIM = -O3 # -xW +FCDEBUG = #-g +FCBASEOPTS = -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) $(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = $(OMPCPP) $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) -DGRIB1 CONFIGURE_GRIB2_FLAG +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort compiler SM-Parallel (OpenMP, allows nesting using RSL without MPI) +# +# Note: if you use ifort 8.0, please remove option -xW (for vectorization). This option +# has been identified to produce wrong results occationally. +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +OMP = -openmp -fpp -auto +OMPCPP = -D_OPENMP +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = ifort +LD = ifort +CC = gcc +SCC = $(CC) +SFC = ifort +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +FCOPTIM = -O3 # -xW +FCDEBUG = #-g +FCBASEOPTS = -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSTUBMPI +CFLAGS = -w -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL $(ARCHFLAGS) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_int -lwrfio_int -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time $(OMP) +LDFLAGS = $(FCOPTIM) -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(OMPCPP) $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) -DGRIB1 CONFIGURE_GRIB2_FLAG +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = gcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" CFLAGS="-DSTUBS $(CFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort+icc compiler DM-Parallel (RSL, MPICH, allows nesting) +# +# Note: if you use ifort 8.0, please remove option -xW (for vectorization). This option +# has been identified to produce wrong results occationally. +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=ifort +LD = mpif90 -f90=ifort +CC = mpicc -cc=icc +SCC = gcc +SFC = ifort +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +FCOPTIM = -O3 # -xW +FCDEBUG = #-g +FCBASEOPTS = -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DMPI \ + -DLIMIT_ARGS +CFLAGS = -w -DDM_PARALLEL -DWRF_RSL_IO $(ARCHFLAGS) \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) -DGRIB1 CONFIGURE_GRIB2_FLAG +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = gcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### +#ARCH AMD x86_64 Intel xeon i686 ia32 Xeon Linux, ifort+gcc compiler DM-Parallel (RSL, MPICH, allows nesting) +# +# Note: if you use ifort 8.0, please remove option -xW (for vectorization). This option +# has been identified to produce wrong results occationally. +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=ifort +LD = mpif90 -f90=ifort +CC = mpicc -cc=gcc +SCC = gcc +SFC = ifort +RWORDSIZE = $(NATIVE_RWORDSIZE) +RSIZEBITS = `expr $(RWORDSIZE) \* 8` +PROMOTION = -real_size $(RSIZEBITS) +FCOPTIM = -O3 # -xW +FCDEBUG = #-g +FCBASEOPTS = -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DMPI \ + -DLIMIT_ARGS +CFLAGS = -w -DDM_PARALLEL -DWRF_RSL_IO $(ARCHFLAGS) \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) -convert big_endian CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -traditional +POUND_DEF = -DNO_RRTM_PHYSICS $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) -DGRIB1 CONFIGURE_GRIB2_FLAG +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = gcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" FIXED="-fixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST linux ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_initialize_real.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +module_dm.o : module_dm.F +module_configure.o : module_configure.F + +module_configure.o \ +module_dm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -g -O0 $*.f90 + +########################################################### + +#ARCH NEC SUPER-UX SX-6 (serial) + +#***** some sx f90 compiler options*********** +# -V : version # of f90 command to stderr +#-EP : activate cpp preprocessor to perform conditional compiling: output as i.[filename] +#-Ep: activate cpp preprocessor to perfomr conditional compiling + #****However, cpp also activated by using .F or .F90 suffixes... +# -Wf: specifies option string of the f90/sx detailed options +#-g: debug info generated in object file for dbx symbolic debugging +# -ew : all numbers size=8bytes +#-eW: 4 bytes +# -float0: default and only -float(number) option for sx6 +# -USX: unname the prev. defined reserved symbol SX of the preprocessor + # -U overrides -D, so '-USX -D$(RUNTIMESYSTEM)' might be redundant +# -p: object file in execution format corresp. to 'prof' command be generated +# -f4: input source program is described in F90 standard free format +# -w: only syntax diagnostic messages at the fatal level are output +# -C: specifies compile mode +# ssafe: only safe optimization in scalar mode (minimize side effects of +# opt. no loop unrolling, etc +# -init : init stack and heap areas +# -L fmtlist summary stdout: formatted list, transformation lists, summary list are output to stdout + +RUNTIME_SYSTEM = sx +MPP_TARGET = $(RUNTIME_SYSTEM) +FC = f90 +SFC = $(FC) +CC = cc +SCC = $(CC) +LD = $(FC) +NATIVE_RWORDSIZE = 8 +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DIWORDSIZE=8 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=8 -DLIMIT_ARGS -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) + ##for DM compilation -DDM_PARALLEL -DRSL +# note: -ew already does this for SX6, see comments above +PROMOTION = +CFLAGS = $(ARCHFLAGS) +#CFLAGS = $(ARCHFLAGS) -DMPI -Dvpp -I../external/RSL/RSL + +FCFLAGS = -w -Ep -C ssafe \ + -sx6 -USX -ew -D$(RUNTIME_SYSTEM) -I$(LIBINCLUDE) -I../inc -f4 + # -Wf"-init stack=zero heap=zero" + # -Wf"-L transform fmtlist summary stdout" -g +FCDEBUG = # -g +FCBASEOPTS = $(FCFLAGS) -w + +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int \ + -I../external/esmf_time_f90 -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf -L/usr/local/netcdf/current/lib -lnetcdf -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + # -L../external/RSL/RSL -lrsl \ + -L../external/esmf_time_f90 -lesmf_time \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o + +#-lmpi for 4byte storage, -lmpiw for 8 byte storage +#LDOPTIONS = -lmpiw -ew +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) $(ARCHFLAGS) +#CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) -DSYSTEM_CALL_OK -DMPI -Dvpp + +MAX_PROC = 8 +MAKE = make -i -r +AWK = awk +SED = sed +CAT = cat +CUT = cut +EXPAND = expand +AR = ar ru +M4 = m4 -B14000 +RANLIB = ar ru +NETCDFPATH = /usr/local/netcdf/current +CC_TOOLS = $(CC) +ARCH_OBJS = milliclock.o +ASSUME_HOMOGENEOUS_ENVIRONMENT = 1 +FLIC_MACROS = LMvpp.m4 -B 14000 +VECTOR = 1 + + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int esmf_time module_dm.F + ( /sbin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F: + ( /sbin/cp module_dm_warning module_dm.F ; \ + cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=/usr/local/netcdf/current FC="$(FC) $(PROMOTION) $(FCFLAGS)" ) + + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCFLAGS)" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ;\ + make FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) $(CPPFLAGS) -I../../inc " ) + +#sx : uses makefile.sx in the directory +#../external/RSL/RSL/librsl.a : +# (cd ../external/RSL/RSL ; \ +# make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sx ) +# +#!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI Altix, Intel Itanium2 ia64 Linux, ifort DM-Parallel (RSL, SGI MPI, allows nesting) +# +# 'setenv F_UFMTENDIAN big' in run scripts not necessary +# since -convert big_endian is in FCBASEOPTS +# Change MPI_HOME if SGI's MPI is not in the default directories +# +# Process pinning should be used -- set the environment +# variable MPI_DSM_DISTRIBUTE on a dedicated system, when +# running through the cpuset command, or when using a batch +# scheduler that has dynamic cpuset support enabled. In +# other cases, if specific processors are known to be free, +# the environment variable MPI_DSM_CPULIST may be used +# (details in 'man mpi'). +# +# Adding -mP3OPT_ecg_lra_switch=T to the compiler options for +# modules/routines that take a long time to compile but do not +# significantly contribute to the total runtime performance is +# appropriate. Temporary suggestion for 2.1.1, Nov 2005. +# +# Contributed settings from Gerardo Cisneros, SGI +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +# +DMPARALLEL = 1 +INCLUDE = ../external/io_netcdf/ +MAX_DOMAINS = 7 +MAX_PROC = 1024 +MPI_HOME = /usr +FC = ifort -I.. +LD = ifort +CC = icc -I. +SCC = icc -I. +CC_TOOLS = cc +SFC = ifort +CFLAGS = -w -O3 -unroll0 -ip -tpp2 -c -ftz -no-gcc -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL +FCOPTIM = -O3 -unroll0 +FCDEBUG = # -g +FCBASEOPTS = -w -ip -tpp2 -ftz -FR -convert big_endian $(FCDEBUG) \ + -fno-alias -fno-fnalias -align all -IPF_fp_relaxed \ + -I$(INCLUDE) -I. +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 \ + -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DSGIALTIX +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + CONFIGURE_NETCDF_LIB_PATH \ + -L../external/RSL/RSL -lrsl \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L$(MPI_HOME)/lib -lmpi -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -O3 -ip $(OMP) CONFIGURE_LDFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P -traditional $(COREDEFS) $(ARCHFLAGS) $(OMPCPP) \ + -I$(INCLUDE) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags` \ + $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH + +externals : CONFIGURE_WRFIO_NF ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" \ + FC="$(FC) -I../.. $(FCFLAGS)" \ + TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../../inc ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../io_phdf5 ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../io_quilt ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)"\ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)"\ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)"\ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" FIXED="-fixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make IDIR="-I$(MPI_HOME)/include" \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) \ + LEARN_BCAST=-DLEARN_BCAST altix ) + +# compile these without high optimization to speed compile +module_configure.o : module_configure.F +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +wrf_auxinput1out.o : wrf_auxinput1out.F +wrf_histout.o : wrf_histout.F +wrf_restartout.o : wrf_restartout.F +wrf_inputin.o : wrf_inputin.F +wrf_auxinput1in.o : wrf_auxinput1in.F +wrf_histin.o : wrf_histin.F +wrf_restartin.o : wrf_restartin.F +module_initialize_real.o: module_initialize_real.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_force_domain.o : mediation_force_domain.F + +module_configure.o \ +mediation_integrate.o mediation_interp_domain.o mediation_feedback_domain.o \ +wrf_auxinput1out.o wrf_histout.o wrf_restartout.o wrf_inputin.o \ +wrf_auxinput1in.o wrf_histin.o wrf_restartin.o module_initialize_real.o \ +module_domain.o module_dm.o module_io_wrf.o start_domain.o solve_interface.o \ +shift_domain_em.o \ +mediation_force_domain.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCBASEOPTS) -O0 $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH SGI Altix, Intel Itanium2 ia64 Linux, ifort DM-Parallel (RSL_LITE, VMI, SGI MPI, Allows nesting) +# +# 'setenv F_UFMTENDIAN big' in run scripts not necessary +# since -convert big_endian is in FCBASEOPTS +# Change MPI_HOME if SGI's MPI is not in the default directories +# +# Process pinning should be used -- set the environment +# variable MPI_DSM_DISTRIBUTE on a dedicated system, when +# running through the cpuset command, or when using a batch +# scheduler that has dynamic cpuset support enabled. In +# other cases, if specific processors are known to be free, +# the environment variable MPI_DSM_CPULIST may be used +# (details in 'man mpi'). +# +# Adding -mP3OPT_ecg_lra_switch=T to the compiler options for +# modules/routines that take a long time to compile but do not +# significantly contribute to the total runtime performance is +# appropriate. Temporary suggestion for 2.1.1, Nov 2005. +# +# Contributed settings from Gerardo Cisneros, SGI +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +INCLUDE = ../external/io_netcdf/ +MAX_PROC = 1024 +MPI_HOME = /usr +FC = ifort -I.. +LD = ifort +CC = icc -I. +SCC = icc -I. +CC_TOOLS = cc +SFC = ifort +CFLAGS = -w -O3 -unroll0 -ip -tpp2 -c -ftz -DDM_PARALLEL -I../external/RSL_LITE \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +FCOPTIM = -O3 -unroll0 +FCDEBUG = # -g +FCBASEOPTS = -w -ip -tpp2 -ftz -FR -convert big_endian $(FCDEBUG) \ + -fno-alias -fno-fnalias -align all -IPF_fp_relaxed \ + -I$(INCLUDE) -I. +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF -DSGIALTIX +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) \ + CONFIGURE_NETCDF_LIB_PATH \ + -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L$(MPI_HOME)/lib -lmpi -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -O3 -ip $(OMP) CONFIGURE_LDFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P -traditional $(COREDEFS) $(ARCHFLAGS) $(OMPCPP) \ + -I$(INCLUDE) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` \ + $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH + +externals : CONFIGURE_WRFIO_NF ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I../.. $(FCFLAGS)" \ + TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../../inc ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../io_phdf5 ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../io_quilt ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" FIXED="-fixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC='icc -I. -w -O3 -DMPI2_SUPPORT -I$(MPI_HOME)/include '\ + FC='ifort -w -O3 -I../../.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) ) + +# compile these without high optimization to speed compile +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +wrf_auxinput1out.o : wrf_auxinput1out.F +wrf_histout.o : wrf_histout.F +wrf_restartout.o : wrf_restartout.F +wrf_inputin.o : wrf_inputin.F +wrf_auxinput1in.o : wrf_auxinput1in.F +wrf_histin.o : wrf_histin.F +wrf_restartin.o : wrf_restartin.F +module_initialize_real.o: module_initialize_real.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_wrf.o : module_io_wrf.F +module_dm.o : module_dm.F +module_domain.o : module_domain.F +start_domain.o : start_domain.F +mediation_force_domain.o : mediation_force_domain.F +module_configure.o : module_configure.F + +mediation_integrate.o mediation_interp_domain.o mediation_feedback_domain.o \ +module_configure.o \ +wrf_auxinput1out.o wrf_histout.o wrf_restartout.o wrf_inputin.o \ +wrf_auxinput1in.o wrf_histin.o wrf_restartin.o module_initialize_real.o \ +module_domain.o module_dm.o module_io_wrf.o start_domain.o solve_interface.o \ +shift_domain_em.o \ +mediation_force_domain.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCBASEOPTS) -O0 $(MODULE_DIRS) $*.f90 + + +########################################################### +#ARCH SGI Altix, Intel Itanium2 ia64 Linux, ifort compiler (OpenMP, no nesting) +# +# 'setenv F_UFMTENDIAN big' in run scripts not necessary +# since -convert big_endian is in FCBASEOPTS +# +# Adding -mP3OPT_ecg_lra_switch=T to the compiler options for +# modules/routines that take a long time to compile but do not +# significantly contribute to the total runtime performance is +# appropriate. Temporary suggestion for 2.1.1, Nov 2005. +# +# Contributed settings from Gerardo Cisneros, SGI +# Set up only for idealized experiments +# +OMP = -openmp +OMPCPP = -D_OPENMP +INCLUDE = ../external/io_netcdf/ +FC = ifort -I.. +LD = ifort +CC = icc -I. +SCC = icc -I. +CC_TOOLS = cc +SFC = ifort +CFLAGS = -w -O3 -unroll0 -ip -tpp2 -c -ftz +FCOPTIM = -O3 -unroll0 +FCDEBUG = # -g +FCBASEOPTS = -w -ip -tpp2 -ftz -FR -convert big_endian $(FCDEBUG) \ + -fno-alias -fno-fnalias -align all -IPF_fp_relaxed \ + -I$(INCLUDE) -I. +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF -DSGIALTIX +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf $(OMP) \ + CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -O3 -ip $(OMP) CONFIGURE_LDFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P -traditional $(COREDEFS) $(ARCHFLAGS) $(OMPCPP) \ + -I$(INCLUDE) -C -P `cat ../inc/dm_comm_cpp_flags` \ + $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH + +externals : CONFIGURE_WRFIO_NF wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; \ + cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I../.. $(FCFLAGS)" \ + TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../../inc ) +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc ; \ +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../io_phdf5 ; \ +# /bin/cp wrf_io_flags.h ../io_quilt ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" FIXED="-fixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +wrf_auxinput1out.o : wrf_auxinput1out.F +wrf_histout.o : wrf_histout.F +wrf_restartout.o : wrf_restartout.F +wrf_inputin.o : wrf_inputin.F +wrf_auxinput1in.o : wrf_auxinput1in.F +wrf_histin.o : wrf_histin.F +wrf_restartin.o : wrf_restartin.F +module_initialize_real.o: module_initialize_real.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_dm.o : module_dm.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +start_domain.o : start_domain.F +mediation_force_domain.o : mediation_force_domain.F +module_configure.o : module_configure.F +module_bl_mrf.o: module_bl_mrf.F + +mediation_integrate.o mediation_interp_domain.o mediation_feedback_domain.o \ +module_configure.o \ +wrf_auxinput1out.o wrf_histout.o wrf_restartout.o wrf_inputin.o \ +wrf_auxinput1in.o wrf_histin.o wrf_restartin.o module_initialize_real.o \ +module_domain.o module_dm.o module_io_wrf.o start_domain.o solve_interface.o \ +shift_domain_em.o module_bl_mrf.o \ +mediation_force_domain.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCBASEOPTS) -O0 $(MODULE_DIRS) $*.f90 + + +########################################################### +#ARCH SGI Altix, Intel Itanium2 ia64 Linux, ifort compiler (Single-processor, no nesting) +# +# 'setenv F_UFMTENDIAN big' in run scripts not necessary +# since -convert big_endian is in FCBASEOPTS +# +# Adding -mP3OPT_ecg_lra_switch=T to the compiler options for +# modules/routines that take a long time to compile but do not +# significantly contribute to the total runtime performance is +# appropriate. Temporary suggestion for 2.1.1, Nov 2005. +# +# Contributed settings from Gerardo Cisneros, SGI +# +INCLUDE = ../external/io_netcdf/ +FC = ifort -I.. +LD = ifort +CC = icc -I. +SCC = icc -I. +CC_TOOLS = cc +SFC = ifort +CFLAGS = -w -O3 -unroll0 -ip -tpp2 -c -ftz +FCOPTIM = -O3 -unroll0 +FCDEBUG = # -g +FCBASEOPTS = -w -ip -tpp2 -ftz -FR -convert big_endian $(FCDEBUG) \ + -fno-alias -fno-fnalias -align all -IPF_fp_relaxed \ + -I$(INCLUDE) -I. +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF -DSGIALTIX +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = -L../external/io_netcdf -lwrfio_nf \ + CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -O3 -ip CONFIGURE_LDFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P -traditional $(COREDEFS) $(ARCHFLAGS) \ + -I$(INCLUDE) -C -P `cat ../inc/dm_comm_cpp_flags` \ + $(POUND_DEF) $(COREDEFS) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH + +externals : CONFIGURE_WRFIO_NF wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; \ + cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I../.. $(FCFLAGS)" \ + TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \ + /bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h ../../inc ) +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc ; \ +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../io_phdf5 ; \ +# /bin/cp wrf_io_flags.h ../io_quilt ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \ + FC="ifort -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" FIXED="-fixed" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +mediation_integrate.o : mediation_integrate.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +wrf_auxinput1out.o : wrf_auxinput1out.F +wrf_histout.o : wrf_histout.F +wrf_restartout.o : wrf_restartout.F +wrf_inputin.o : wrf_inputin.F +wrf_auxinput1in.o : wrf_auxinput1in.F +wrf_histin.o : wrf_histin.F +wrf_restartin.o : wrf_restartin.F +module_initialize_real.o: module_initialize_real.F +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_dm.o : module_dm.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +start_domain.o : start_domain.F +mediation_force_domain.o : mediation_force_domain.F +module_configure.o : module_configure.F + +mediation_integrate.o mediation_interp_domain.o mediation_feedback_domain.o \ +module_configure.o \ +wrf_auxinput1out.o wrf_histout.o wrf_restartout.o wrf_inputin.o \ +wrf_auxinput1in.o wrf_histin.o wrf_restartin.o module_initialize_real.o \ +module_domain.o module_dm.o module_io_wrf.o start_domain.o solve_interface.o \ +shift_domain_em.o \ +mediation_force_domain.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCBASEOPTS) -O0 $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH UNICOS/mp machine crayx1 (RSL_LITE, MPI, MSP mode) +# +# Cray X1 (RSL_LITE, MPI, MSP mode) +# For CSD mode set numtiles=4 in &domains section +# in namelist.input for best MSP efficiency. +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = ftn +SFC = $(FC) +LD = ftn +CC = cc +SCC = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script converts !$OMP directives to !csd$ directives #### +SED_FTN = sed -f ../arch/cray_csd.sed + +## Use these for X1 cross compiler to build Registry +##X1_CROSS_COMP = "gcc" +##X1_CROSS_CFLG = "" +## Use these for X1 native (trigger) compiler +X1_CROSS_COMP = "cc" +X1_CROSS_CFLG = "-hcommand" +CC_TOOLS = $(X1_CROSS_COMP) $(X1_CROSS_CFLG) + +RWORDSIZE = $(NATIVE_RWORDSIZE) +FCDEBUG = # -g +FCBASEOPTS = -f free -N 255 -I. -x omp -dy +FCFLAGS_LOWOPT = $(FCBASEOPTS) -O1 +FCFLAGS = $(FCBASEOPTS) -Ofp3 -O3 -Ogen_private_callee +#if using 64bit precision +#PROMOTION = -sreal64 -dp -sinteger32 +CFLAGS = -I../external/RSL_LITE -DMAXDOM_MAKE=$(MAX_DOMAINS) \ + -DMAXPROC_MAKE=$(MAX_PROC) -DDM_PARALLEL -UCRAY -DLANDREAD_STUB -Dcrayx1 + +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../inc \ + -p./ -p../external/io_netcdf -p../external/io_int -p../frame \ + -p../frame -p../share -p../phys -p../chem \ + -p../dyn_em -p ../external/esmf_time_f90 +ARCHFLAGS = $(COREDEFS) -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \ + -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \ + -DLIMIT_ARGS -Dcrayx1 + +PERL = perl +REGISTRY = Registry + +LIB = -L../external/io_netcdf -lwrfio_nf CONFIGURE_NETCDF_LIB_PATH \ + -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time -lmalloc + +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +LDFLAGS = + +CPP = cpp -C -P -Dcrayx1 +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) # -DNO_NAMELIST_PRINT +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE `cat ../inc/dm_comm_cpp_flags` $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) + +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP) -Dcrayx1" FC="$(FC) $(PROMOTION) -f free -N 255 " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) -f free -N 255" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP) -Dcrayx1" FC="$(FC) $(PROMOTION) -f free -N 255" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC) -UCRAY" CPP="$(CPP) -Dcrayx1" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) -f free -N 255" archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC) -UCRAY" CPP="$(CPP) CONFIGURE_GRIB2_INC -Dcrayx1" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) -f free -N 255" archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) -f free -N 255" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CFLAGS="$(CFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" \ + MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F +solve_em.o : solve_em.F +solve_interface.o : solve_interface.F +wrf_restartout.o : wrf_restartout.F +wrf_restartin.o : wrf_restartin.F +input_wrf.o : input_wrf.F +output_wrf.o : output_wrf.F + +module_io_mm5.o module_si_io.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o start_domain.o \ +mediation_interp_domain.o \ +mediation_force_domain.o \ +module_configure.o solve_em.o \ +input_wrf.o output_wrf.o \ +solve_interface.o wrf_restartout.o wrf_restartin.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS_LOWOPT) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX PA8600 32bit (single-threaded, no nesting) +# +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DS2.0a -DNOUNDERSCORE +FCOPTIM = +O3 +DA2.0N +DS2.0a +Odataprefetch +Olibcalls +DO11.0EP9806 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DS2.0a +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX PA8600 32bit (single-threaded, nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DWRF_RSL_IO -DRSL -DINTIO -DLIMIT_ARGS \ + -DDM_PARALLEL -DFLOATSAFE -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DSTUBMPI +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DS2.0a -DNOUNDERSCORE -I../external/RSL/RSL +FCOPTIM = +O3 +DA2.0N +DS2.0a +Odataprefetch +Olibcalls +DO11.0EP9806 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DS2.0a +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL/ -lrsl -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +MAX_PROC = 1 +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL/RSL/librsl.a gen_comms.c wrfio_int module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" CFLAGS=" -DSTUBS +O3 " FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST stub ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX Itanium2 (single-threaded, no nesting) +# +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DSitanium2 -DNOUNDERSCORE +FCOPTIM = +O3 +Odataprefetch +Olibcalls +DO11.23 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DSitanium2 +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX Itanium2 (single-threaded, nesting using RSL without MPI) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +OMP = +OMPCPP = +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DWRF_RSL_IO -DRSL -DINTIO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DSTUBMPI +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DSitanium2 -DNOUNDERSCORE -I../external/RSL/RSL +FCOPTIM = +O3 +DSitanium2 +Odataprefetch +Olibcalls +DO11.23 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DSitanium2 +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX PA8600 32bit (openmp, no nesting) +# +OMP = +Oopenmp +OMPCPP = -D_OPENMP +FC = f90 +SFC = $(FC) +LD = f90 +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DS2.0a -DNOUNDERSCORE +FCOPTIM = +O3 +DA2.0N +DS2.0a +Odataprefetch +Olibcalls +DO11.0EP9806 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DS2.0a $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX PA8600 DM-Parallel (RSL, MPICH, nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DDM_PARALLEL -DRSL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DS2.0a -DNOUNDERSCORE -I../external/RSL/RSL +FCOPTIM = +O3 +DA2.0N +DS2.0a +Odataprefetch +Olibcalls +DO11.0EP9806 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DS2.0a +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST hp ) + + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH HP-UX Itanium2 DM-Parallel (RSL, MPICH, nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +OMP = +OMPCPP = +FC = mpif90 +SFC = f90 +LD = mpif90 +CC = mpicc +SCC = cc +RWORDSIZE = $(NATIVE_RWORDSIZE) +ARCHFLAGS = $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO -DLIMIT_ARGS -DFLOATSAFE \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DDM_PARALLEL -DRSL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = $(ARCHFLAGS) +DSitanium2 -DNOUNDERSCORE -I../external/RSL/RSL +FCOPTIM = +O3 +Odataprefetch +Olibcalls +DO11.23 +noppu \ + +save +fastallocatable +Ofltacc +extend_source +source=free +FPD +FCDEBUG = # -g +FCBASEOPTS = +U77 +source=free -I. +DSitanium2 +noppu +Onoopenmp $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) $(OMP) +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/io_int -lwrfio_int -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCOPTIM) $(OMP) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B14000 +RANLIB = echo +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int ../external/RSL/RSL/librsl.a gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; \ + cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) " ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \ + FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \ + FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I../../inc " archive ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; \ + make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST hp ) + + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +mediation_integrate.o : mediation_integrate.F +start_domain.o : start_domain.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_configure.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o mediation_integrate.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Darwin (single-threaded, no nesting) +# +# Using -qfloat=nomaf option can result in identical results with +# non-optimized and optimized results (suggested by Fovell of UCLA) +# One may turn on by uncommenting it in FCOPTIM line +# +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +#CC = cc_r +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DLANDREAD_STUB -I /usr/include/sys -DMACOS +FCOPTIM = #-O3 -qarch=auto #-qfloat=nomaf +FCDEBUG = #-qnoopt -qfullpath +FCBASEOPTS = -qsave $(FCDEBUG) -qmaxmem=32767 -qspillsize=32767 -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DLANDREAD_STUB -DMAC_KLUDGE +# -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DMACOS +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +#LIB = CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time + +LDFLAGS = -Wl,-stack_size,10000000,-stack_addr,0xc0000000 CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +#CPP = /opt/ibmcmp/xlf/8.1/exe/cpp -C -P +CPP = /usr/bin/cpp -C -P -xassembler-with-cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c -qfree=f90 -qspillsize=32767 -I. $(PROMOTION) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +# compile these without high optimization to speed compile +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +solve_em.o : solve_em.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +shift_domain_em.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_em.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +########################################################### +#ARCH Darwin (OpenMP, no nesting) +# +# Using -qfloat=nomaf option can result in identical results with +# non-optimized and optimized results (suggested by Fovell of UCLA) +# One may turn on by uncommenting it in FCOPTIM line +# +OMP = -qsmp=noauto +OMPCPP = -D_OPENMP +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +CC = cc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DLANDREAD_STUB -I /usr/include/sys -DMACOS +FCOPTIM = -O2 -qarch=auto -qunroll=yes #-qfloat=nomaf +FCDEBUG = # -qnoopt -qfullpath +FCBASEOPTS = -w -qsave $(FCDEBUG) -qmaxmem=32767 -qspillsize=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DLANDREAD_STUB -DMACOS -DMAC_KLUDGE +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -lxlsmp \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(OMP) -Wl,-stack_size,10000000,-stack_addr,0xc0000000 CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /usr/bin/cpp -C -P -xassembler-with-cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(OMPCPP) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + + +module_configure.o : module_configure.F +module_domain.o : module_domain.F +module_sm.o : module_sm.F +module_tiles.o : module_tiles.F +solve_em.o : solve_em.F +solve_exp.o : solve_exp.F +convert_nmm.o : convert_nmm.F + +module_configure.o module_sm.o module_tiles.o solve_em.o solve_exp.o convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $(OMPCPP) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c -g $(PROMOTION) $(OMP) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt -qnohot $*.f90 + +module_domain.o : + $(RM) $@ + $(SED_FTN) $*.F90 > $*.b + $(CPP) -I../inc $(CPPFLAGS) $(OMPCPP) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt -qnohot $*.f90 + +########################################################### +#ARCH Darwin (single-threaded, no nesting, USES: gcc-3.3, xlf cpp, SystemStubs) +# +# Using -qfloat=nomaf option can result in identical results with +# non-optimized and optimized results (suggested by Fovell of UCLA) +# One may turn on by uncommenting it in FCOPTIM line +# +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +#CC = cc_r +CC = gcc-3.3 +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DLANDREAD_STUB -I /usr/include/sys -DMACOS +FCOPTIM = #-O3 -qarch=auto #-qfloat=nomaf +FCDEBUG = #-qnoopt -qfullpath +FCBASEOPTS = -qsave $(FCDEBUG) -qmaxmem=32767 -qspillsize=32767 -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DLANDREAD_STUB -DMAC_KLUDGE +# -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DMACOS +PERL = CONFIGURE_PERL_PATH +REGISTRY = Registry +#LIB = CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time + +LDFLAGS = -Wl,-stack_size,10000000,-stack_addr,0xc0000000 CONFIGURE_LDFLAGS -L/usr/lib -lSystemStubs +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /opt/ibmcmp/xlf/8.1/exe/cpp -C -P +#CPP = /usr/bin/cpp -C -P -xassembler-with-cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c -qfree=f90 -qspillsize=32767 -I. $(PROMOTION) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +# compile these without high optimization to speed compile +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +solve_em.o : solve_em.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +shift_domain_em.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_em.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +########################################################### +#ARCH PC Linux x86_64 (IA64 and Opteron), PathScale 2.1 or higher (Single-threaded, no nesting) +# +FC = pathf90 +LD = pathf90 +CC = pathcc +SCC = $(CC) +NATIVE_RWORDSIZE= 4 +RWORDSIZE = $(NATIVE_RWORDSIZE) +SFC = $(FC) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = +FCOPTIM = -O3 -OPT:Ofast:Olimit=5000 +FCDEBUG = #-g +FCBASEOPTS = -w -byteswapio -freeform -fno-second-underscore $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) -byteswapio CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w -fno-second-underscore" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" archive ) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_fddaobs_rtfdda.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux x86_64 (IA64 and Opteron), PathScale 2.1 or higher DM-Parallel (RSL_LITE, PathScale MPICH, No periodic LBCs) +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=pathf90 +LD = mpif90 -f90=pathf90 +CC = mpicc -cc=pathcc +SCC = pathcc +SFC = pathf90 +NATIVE_RWORDSIZE= 4 +RWORDSIZE = $(NATIVE_RWORDSIZE) +CFLAGS = -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE +FCOPTIM = -O3 -OPT:Ofast:Olimit=5000 +FCDEBUG = #-g +FCBASEOPTS = -w -byteswapio -freeform -fno-second-underscore $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +EXTRAMODULES = +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = -byteswapio +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = pathcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +#io_flags: +# ( cd ../external/io_netcdf ; make flags_only ; \ +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc ; \ +# /bin/cp wrf_io_flags.h wrf_status_codes.h ../io_phdf5 ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC)" TRADFLAG="-traditional" \ + FFLAGS='$(FCFLAGS) -I../../inc -ICONFIGURE_NETCDF_PATH/include -w -fno-second-underscore' RANLIB=$(RANLIB) ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" TRADFLAG="-traditional" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" archive ) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(CC)" CPP="$(CPP)" FC="$(SFC) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" RANLIB=$(RANLIB) archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" FC="$(SFC) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" RM="$(RM)" RANLIB=$(RANLIB) archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" CPP="$(CPP)" FC="$(SFC) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" RANLIB=$(RANLIB) all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(FCDEBUG) $(FCBASEOPTS) " CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" FC='mpif90 $(FCFLAGS) -byteswapio' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F +module_configure.o : module_configure.F + +solve_interface.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_fddaobs_rtfdda.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH Cray XT3 Catamount/Linux x86_64 (Opteron), PGI 5.2 or higher DM-Parallel (RSL_LITE, MPICH, Allows nesting, Periodic in X only ) +# Note that for 5.1.x comment out -Mpia=fast +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = ftn +LD = ftn +CC = gcc -DMPI2_SUPPORT +SCC = gcc +SFC = mpif90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -r$(RWORDSIZE) -i4 +CFLAGS = -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE \ + -DLANDREAD_STUB -DXT3_Catamount -I$(MPICH_DIR)/include +FCOPTIM = -O3 -fastsse #-Mipa=fast +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -w -byteswapio -Mfree $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DLANDREAD_STUB -DNO_NAMELIST_PRINT -DXT3_Catamount +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../inc -I../chem +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o \ + -L../external/esmf_time_f90 -lesmf_time +# add this to LIB to use XT3 iobuf library after loading iobuf module, also requires +# properly built netCDF library that includes iobuf +# $(IOBUF_POST_LINK_OPTS) +LDFLAGS = -byteswapio CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = gcc + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -byteswapio" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +solve_em.o : solve_em.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +solve_em.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH NEC SX-8, NEC SX cross compiler DM-Parallel (RSL, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = sxmpif90 +LD = sxmpif90 +CC = sxmpic++ +SCC = sxmpic++ +SFC = sxmpif90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = +CFLAGS = -DNCARIBM_NOC99 -DDM_PARALLEL -DWRF_RSL_IO \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL/RSL +FCOPTIM = +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -f4 -Wf,-P i $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 -DINTIO -DWRF_RSL_IO -DRSL -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl \ + -L../external/io_grib1 -lio_grib1 \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time -L$(SX_BASE_CPLUS)/lib -lcpp +LDFLAGS = $(FCFLAGS) -Wl,-h nodefs CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) -DNEC +AR_BASE = sxar +AR = $(AR_BASE) ru +M4 = m4 -B 14000 +RANLIB = sxar rs +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 ../external/RSL/RSL/librsl.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" AR="$(AR_BASE)" ) + +../external/RSL/RSL/librsl.a : + ( cd ../external/RSL/RSL ; make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sx ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +# if [ ! -e $@ ] ; then \ +# sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi + +########################################################### +#ARCH NEC SX-8, NEC SX cross compiler DM-Parallel (RSL_LITE, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = sxmpif90 +LD = sxmpif90 +CC = sxmpic++ +SCC = sxmpic++ +SFC = sxmpif90 +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = +CFLAGS = -DNCARIBM_NOC99 -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE +FCOPTIM = +FCDEBUG = #-g +#FCBASEOPTS = -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG) +FCBASEOPTS = -f4 -Wf,-P i $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -I../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time -L$(SX_BASE_CPLUS)/lib -lcpp +LDFLAGS = $(FCFLAGS) -Wl,-h nodefs CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) -DNEC +AR_BASE = sxar +AR = $(AR_BASE) ru +M4 = m4 -B 14000 +RANLIB = sxar rs +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib1 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" AR="$(AR_BASE)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST AR="$(AR_BASE)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 +# if [ ! -e $@ ] ; then \ +# sleep 10 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 30 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi +# if [ ! -e $@ ] ; then \ +# sleep 300 ; $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 ; \ +# fi + + +########################################################### +#ARCH CYGWIN_NT-5.1 Cygwin i486 i586 i686, g95 compiler (Single-threaded, no nesting) +# +FC = g95 +LD = g95 +CC = gcc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +SFC = $(FC) +# g95 does not like -r8. if you want -r8, just add it to PROMOTION below +#PROMOTION = -r$(RWORDSIZE) -i4 +PROMOTION = -i4 +CFLAGS = +FCOPTIM = -O2 +FCDEBUG = #-g +FCBASEOPTS = -Wno=101,139,155,158 -fno-second-underscore -fendian=big -ffree-form $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS -DG95 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -fmod=../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = cpp -C -P -traditional +POUND_DEF = $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux i486 i586 i686, g95 compiler (Single-threaded, no nesting) +# +FC = g95 +LD = g95 +CC = gcc +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +SFC = $(FC) +# g95 does not like -r4. if you want promotion to -r8 add it to PROMOTION below +#PROMOTION = -r$(RWORDSIZE) -i4 +PROMOTION = -i4 +CFLAGS = +FCOPTIM = -O2 # -fast +FCDEBUG = #-g -O0 +FCBASEOPTS = -Wno=101,139,155,158 -fno-second-underscore -fendian=big -ffree-form $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \ + -DLIMIT_ARGS -DG95 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -fmod=../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = $(CC) + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive ) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" \ + TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +solve_interface.o \ +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +mediation_integrate.o \ +module_configure.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +########################################################### +#ARCH PC Linux i486 i586 i686, g95 compiler DM-Parallel (RSL_LITE, MPICH, Allows nesting) +# +# Notes: for experimental implementation of moving nests, add -DMOVE_NESTS to ARCHFLAGS +# for experimental implementation of vortex tracking nests, add -DMOVE_NESTS -DVORTEX_CENTER to ARCHFLAGS +# +DMPARALLEL = 1 +MAX_PROC = 1024 +FC = mpif90 -f90=g95 +LD = mpif90 -f90=g95 +CC = mpicc -cc=gcc +SCC = gcc +SFC = g95 +RWORDSIZE = $(NATIVE_RWORDSIZE) +# g95 does not like -r4. if you want promotion to -r8 add it to PROMOTION below +#PROMOTION = -r$(RWORDSIZE) -i4 +PROMOTION = -i4 +CFLAGS = -DDM_PARALLEL \ + -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I../external/RSL_LITE +FCOPTIM = -O2 # -fast +FCDEBUG = #-g -O0 +FCBASEOPTS = -Wno=101,139,155,158 -fno-second-underscore -fendian=big -ffree-form $(FCDEBUG) # -Mlfs +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +ARCHFLAGS = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL \ + -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \ + -DLIMIT_ARGS -DNMM_NEST=$(WRF_NMM_NEST) -DG95 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = ESMFIOLIB +ESMF_IO_LIB_EXT = ESMFIOEXTLIB +INCLUDE_MODULES = -fmod=../main -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../external -I../frame -I../share -I../phys -I../chem -I../inc +PERL = perl +REGISTRY = Registry +LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite \ + -L../external/io_grib1 -lio_grib1 \ + CONFIGURE_GRIB2_LIB \ + -L../external/io_grib_share -lio_grib_share \ + -L../external/io_int -lwrfio_int \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time +LDFLAGS = $(FCFLAGS) CONFIGURE_LDFLAGS +ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS +CPP = /lib/cpp -C -P -traditional +POUND_DEF = -DNO_RRTM_PHYSICS -traditional $(COREDEFS) -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL_LITE -C -P `cat ../inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = CONFIGURE_NETCDF_PATH +CC_TOOLS = cc + +#### Override default sed command and script for Fortran source files #### +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### because the Fortran compiler complains about long source lines. #### +SED_FTN = sed -f ../arch/no_file_line.sed + +externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 ../external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time + +gen_comms.c : ../external/RSL_LITE/gen_comms.c + ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; \ + cat ../external/RSL_LITE/gen_comms.c >> ../tools/gen_comms.c ) + +module_dm.F : ../external/RSL_LITE/module_dm.F + ( /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL_LITE/module_dm.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; \ + make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-Mfixed" archive) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" all ) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +../external/RSL_LITE/librsl_lite.a : + ( cd ../external/RSL_LITE ; make CC="$(CC)" FC="$(FC) $(FCFLAGS) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST ) + +# compile these without high optimization to speed compile +solve_interface.o : solve_interface.F +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_fire.o : module_initialize_fire.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +mediation_integrate.o : mediation_integrate.F +module_configure.o : module_configure.F + +shift_domain_em.o \ +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_configure.o \ +mediation_integrate.o \ +module_initialize_real.o module_dm.o start_domain.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90 + +################################################################## +#ARCH NULL diff --git a/wrfv2_fire/arch/cray_csd.sed b/wrfv2_fire/arch/cray_csd.sed new file mode 100644 index 00000000..48edd860 --- /dev/null +++ b/wrfv2_fire/arch/cray_csd.sed @@ -0,0 +1,12 @@ +#### This sed script converts !$OMP directives to Cray !csd$ directives #### +# +# get rid of single quotes after comments +# WARNING: This will break if a quoted string is followed by a comment that has +# a single quote. +/\!.*'/s/'//g +# Automatically add cpp __LINE__ and __FILE__ to calls to wrf_error_fatal(). +s/[Cc][Aa][Ll][Ll] *[Ww][Rr][Ff]_[Ee][Rr][Rr][Oo][Rr]_[Ff][Aa][Tt][Aa][Ll] *(/CALL wrf_error_fatal3 ( __FILE__ , __LINE__ , / +# convert !$OMP directives to Cray !csd$ directives +/\!\$[Oo][Mm][Pp]/s/\!\$[Oo][Mm][Pp]/\!csd\$/ +/\!csd\$.*[Pp][Rr][Ii][Vv][Aa][Tt][Ee]/a\ +!csd$& schedule(static,1) diff --git a/wrfv2_fire/arch/no_file_line.sed b/wrfv2_fire/arch/no_file_line.sed new file mode 100644 index 00000000..8d3bd836 --- /dev/null +++ b/wrfv2_fire/arch/no_file_line.sed @@ -0,0 +1,10 @@ +#### This sed script does not pass __FILE__ and __LINE__ to wrf_error_fatal() #### +#### Use this when the Fortran compiler complains about long source lines, #### +#### usually due to cpp translating __FILE__ to a full pathname. #### +# +# get rid of single quotes after comments +# WARNING: This will break if a quoted string is followed by a comment that has +# a single quote. +/\!.*'/s/'//g +# DO NOT Automatically add cpp __LINE__ and __FILE__ to calls to wrf_error_fatal(). +# s/[Cc][Aa][Ll][Ll] *[Ww][Rr][Ff]_[Ee][Rr][Rr][Oo][Rr]_[Ff][Aa][Tt][Aa][Ll] *(/& __FILE__ , __LINE__ , / diff --git a/wrfv2_fire/arch/postamble b/wrfv2_fire/arch/postamble new file mode 100644 index 00000000..ff9134d9 --- /dev/null +++ b/wrfv2_fire/arch/postamble @@ -0,0 +1,59 @@ + +# These sub-directory builds are identical across all architectures +wrfio_esmf : + ( cd ../external/io_esmf ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " ) + + +# +# Macros, these should be generic for all machines + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + +# There is probably no reason to modify these rules + +wrf_ioapi_includes : + ( cd ../external/ioapi_share ; \ + $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" ) + +.F.i: + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $@ + mv $*.i $(DEVTOP)/pick/$*.f90 + cp $*.F $(DEVTOP)/pick + +.F.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi + +.F.f90: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $@ + $(RM) $*.b + +.f90.o: + $(RM) $@ + $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi + +.c.o: + $(RM) $@ + $(CC) -c $(CFLAGS) $*.c + diff --git a/wrfv2_fire/arch/preamble b/wrfv2_fire/arch/preamble new file mode 100644 index 00000000..5339ee55 --- /dev/null +++ b/wrfv2_fire/arch/preamble @@ -0,0 +1,79 @@ +# configure.wrf +# +# This file was automatically generated by the configure script in the +# top level directory. You may make changes to the settings in this +# file but be aware they will be overwritten each time you run configure. +# Ordinarily, it is necessary to run configure once, when the code is +# first installed. +# +# To permanently change options, change the settings for your platform +# in the file arch/configure.defaults then rerun configure. +# +SHELL = /bin/sh +DEVTOP = `pwd` +LIBINCLUDE = . +.SUFFIXES: .F .i .o .f90 .c + +#### Get core settings from environment (set in compile script) +#### Note to add a core, this has to be added to. + +COREDEFS = -DEM_CORE=$(WRF_EM_CORE) \ + -DNMM_CORE=$(WRF_NMM_CORE) -DNMM_MAX_DIM=2600 \ + -DCOAMPS_CORE=$(WRF_COAMPS_CORE) \ + -DEXP_CORE=$(WRF_EXP_CORE) + +#### Single location for defining total number of domains. You need +#### at least 1 + 2*(number of total nests). For example, 1 coarse +#### grid + three fine grids = 1 + 2(3) = 7, so MAX_DOMAINS=7. + +MAX_DOMAINS = 21 + +#### DM buffer length for the configuration flags. + +CONFIG_BUF_LEN = 16384 + + +############################################################################## +#### The settings in this section are defaults that may be overridden by the +#### architecture-specific settings in the next section. +############################################################################## + +############################################################################## +#### NOTE: Do not modify these default values here. To override these +#### values, make changes after "Architecture specific settings". +############################################################################## + +#### Native size (in bytes) of Fortran REAL data type on this architecture #### +#### Note: to change real wordsize (for example, to promote REALs from +#### 4-byte to 8-byte), modify the definition of RWORDSIZE in the +#### section following "Architecture specific settings". Do not +#### change NATIVE_RWORDSIZE as is it architecture-specific. +NATIVE_RWORDSIZE = 4 + +#### Default sed command and script for Fortran source files #### +SED_FTN = sed -f ../arch/standard.sed + +# Hack to work around $(PWD) not changing during OSF1 build. +# $(IO_GRIB_SHARE_DIR) is reset during the OSF1 build only. +IO_GRIB_SHARE_DIR = + +#### ESMF switches #### +#### These are set up by Config.pl #### +# switch to use separately installed ESMF library for coupling: 1==true +ESMF_COUPLING = ESMFCOUPLING +# select dependences on module_utility.o +ESMF_MOD_DEPENDENCE = ESMFMODDEPENDENCE +# select -I options for separately installed ESMF library, if present +ESMF_MOD_INC = ESMFMODINC +# select -I options for external/io_esmf vs. external/esmf_time_f90 +ESMF_IO_INC = ESMFIOINC +# select cpp token for external/io_esmf vs. external/esmf_time_f90 +ESMF_IO_DEFS = ESMFIODEFS +# select build target for external/io_esmf vs. external/esmf_time_f90 +ESMF_TARGET = ESMFTARGET + +############################################################################## + + +#### Architecture specific settings #### + diff --git a/wrfv2_fire/arch/standard.sed b/wrfv2_fire/arch/standard.sed new file mode 100644 index 00000000..60624ea5 --- /dev/null +++ b/wrfv2_fire/arch/standard.sed @@ -0,0 +1,8 @@ +#### Standard sed script #### +# +# get rid of single quotes after comments +# WARNING: This will break if a quoted string is followed by a comment that has +# a single quote. +/\!.*'/s/'//g +# Automatically add cpp __LINE__ and __FILE__ to calls to wrf_error_fatal(). +s/[Cc][Aa][Ll][Ll] *[Ww][Rr][Ff]_[Ee][Rr][Rr][Oo][Rr]_[Ff][Aa][Tt][Aa][Ll] *(/CALL wrf_error_fatal3 ( __FILE__ , __LINE__ , / diff --git a/wrfv2_fire/changes-to-make-in-wrf.patton b/wrfv2_fire/changes-to-make-in-wrf.patton new file mode 100644 index 00000000..58b00435 --- /dev/null +++ b/wrfv2_fire/changes-to-make-in-wrf.patton @@ -0,0 +1,23 @@ +1) to make separate em_fire test case: + + add em_fire to Makefile in WRF root + create dyn_em/module_initialize_fire.F (following quarter_ss) + modify dyn_em/Makefile to compile module_initialize_fire.F (following quarter_ss) + create test/em_fire directory + create test/em_fire/input_sounding + create test/em_fire/namelist.input + +2) Added complete fire package/section to Registry/Registry.EM +3) Copied module_fire_driver.F to phys/module_fire_driver.F +4) Copied module_fr_cawfe.F to phys/module_fr_cawfe.F +5) Added module_fr_cawfe.o and module_fire_driver.o to phys/Makefile + +6) Added fire namelist variables to namelist.input (&fire) +7) namelist variables sr_x and sr_y in &domain define the refinement + +8) Modified dyn_em/solve_em.F so that the fire tendencies propagate + into sr. update_phy_tend + (note that we skip calling 'calculate_phy_tend' because we take care of + multiplying by mu in the fire module) +9) Modified phys/module_physics_addtendc.F so that the fire tendencies + are added into heat and moisture tendencies diff --git a/wrfv2_fire/chem/KPP/clean_kpp b/wrfv2_fire/chem/KPP/clean_kpp new file mode 100755 index 00000000..e05c34ad --- /dev/null +++ b/wrfv2_fire/chem/KPP/clean_kpp @@ -0,0 +1,59 @@ +#!/bin/csh -f + + +if ( -e configure.kpp ) then +rm -f configure.kpp +endif +echo "# DO NOT EDIT! Placeholder for automatically generated file" >& configure.kpp + +# remove the traces of KPP +if (-e ../Makefile_org ) then +cp -f ../Makefile_org ../Makefile +rm -f ../Makfile_org +endif + + + +# remove automatically genereated files in chem directory +rm -f ../*kpp* + +#kpp +set k_dirs = ( kpp/* ) +foreach kdir ( $k_dirs ) +echo $kdir +( cd $kdir; make clean ) +( cd $kdir; rm -f Makefile.defs ) +end + +# remove links in util/wkc +( cd util/wkc; linker.csh unlink ) + + + + + +#coupler +( cd util/wkc; make clean ) + + + +# mechanisms +set m_dirs = ( mechanisms/* ) + +foreach mdir ( $m_dirs ) +echo $mdir + +( cd $mdir; /bin/rm -f *.f90 *.map Makefil* *~ core.* ) + +end + +rm -f ../../Registry_tmp.*_wk* + +#./documentation/latex/clean + + +# configure file +rm -f configure.kpp + + +exit 0 diff --git a/wrfv2_fire/chem/KPP/compile_wkc b/wrfv2_fire/chem/KPP/compile_wkc new file mode 100755 index 00000000..3324636d --- /dev/null +++ b/wrfv2_fire/chem/KPP/compile_wkc @@ -0,0 +1,177 @@ +#!/bin/csh -f + + +echo "====================================================" +echo starting compile_wkc + +setenv WKC_DIRNAME KPP + +setenv WRFC_ROOT `pwd` +setenv WKC_HOME ${WRFC_ROOT}/chem/${WKC_DIRNAME} + + + +# KPP_HOME: environment variable needed by KPP +# note: this is not plain KPP +setenv KPP_HOME ${WKC_HOME}/kpp/kpp-2.1 +setenv WKC_KPP ${KPP_HOME}/bin/kpp + + +#write Makefile_kpp.defs +rm -f ${WKC_HOME}/configure.kpp +${WKC_HOME}/configure_kpp + +# ...and link it +rm -f ${KPP_HOME}/Makefile.defs +ln -s ${WKC_HOME}/configure.kpp ${KPP_HOME}/Makefile.defs + + +# some preliminaries +if (! -e chem/Makefile_org ) then +cp chem/Makefile chem/Makefile_org +endif + +if ( ! -e chem/module_wkppc_constants.F ) then +ln -s ${WKC_DIRNAME}/module_wkppc_constants.F chem +endif + + +#compile kpp +echo compile kpp +cd $KPP_HOME; make; cd $WRFC_ROOT + +echo "-----------------------------------------" + + +( cd $WKC_HOME/util/wkc; linker.csh link ) + +#compile the coupler +echo compile the coupler +cd $WKC_HOME/util/wkc; make -i -r + +echo "-----------------------------------------" + +# if Registry was edited touch run_wkc +echo check if Registry was touched +cd $WKC_HOME/util; make + +echo "-----------------------------------------" +echo "Run kpp for mechanisms in chem/KPP/mechanisms" + + + +# run make (-> kpp) in each subdir + +cd $WKC_HOME +set kpp_files = ( mechanisms/*/*.kpp ) + + +foreach file ( $kpp_files ) + +echo "=========================================================" + +set kdir = `echo $file:h` +set kfile = `echo $file:t` +echo $kdir + + if (! -e $kdir/Makefile ) then + rm -f $kdir/Makefile + echo ln -s ../../util/Makefile_kpp $kdir/Makefile + ln -s ../../util/Makefile_kpp $kdir/Makefile + endif + + + set model = `echo $kfile | sed 's/.kpp//g'` + + +# if necessary, create a few .inc files in chem/KPP/inc +# which can be used to add code in the automatically +# generated files module_kpp_xxx_interface.f + set inc_list = "u l b a ibu ib ia e" + + foreach inam ( $inc_list ) + if (! -e inc/kpp_mechd_${inam}_${model}.inc ) then + echo ! > inc/kpp_mechd_${inam}_${model}.inc + endif + end + + if (! -e inc/extra_args_to_update_rconst_${model}.inc ) then + echo ! > inc/extra_args_to_update_rconst_${model}.inc + endif + + + if (! -e inc/extra_args_update_rconst_${model}.inc ) then + echo ! > inc/extra_args_update_rconst_${model}.inc + endif + + if (! -e inc/extra_decls_update_rconst_${model}.inc ) then + echo ! > inc/extra_decls_update_rconst_${model}.inc + endif + + + cd $kdir + echo model $model + make MODEL=$model KPP=$WKC_KPP WRFC_ROOT=$WRFC_ROOT + + + cd $WKC_HOME + +end + +echo "=========================================================" + +################################################### + +# link .inc files in chem/KPP/inc +set kincfiles = ( inc/*.inc ) + +foreach kincfile ( $kincfiles ) + + if ( ! -e ${WRFC_ROOT}/${kincfile} ) then + echo ln -s ../chem/${WKC_DIRNAME}/${kincfile} ${WRFC_ROOT}/inc + ln -s ../chem/${WKC_DIRNAME}/${kincfile} ${WRFC_ROOT}/inc + endif +end + + + +################################################### + +## run the coupler +if ( -e util/run_wkc ) then + echo " " + echo "RUN WRF-Chem KPP coupler ---------------------------" + + cd $WRFC_ROOT + + chem/KPP/util/wkc/registry_kpp Registry/Registry.EM_CHEM + + cd $WKC_HOME + + + rm -f util/run_wkc + + + if ( $status ) then + + echo "ERROR on exit KPP coupler" + + else + + + echo " back from KPP coupler: check generated code in chem directory" + + endif + +else + +echo " not running the WRF-Chem KPP coupler" + +endif + + + +echo end of compile_wkc +echo "=========================================================" + +exit 0 diff --git a/wrfv2_fire/chem/KPP/configure_kpp b/wrfv2_fire/chem/KPP/configure_kpp new file mode 100755 index 00000000..dce3126a --- /dev/null +++ b/wrfv2_fire/chem/KPP/configure_kpp @@ -0,0 +1,145 @@ +#!/bin/sh + +# much of the nice documentation for some of the options was taken from +# KPP's Makefile.defs. To give a little credit let's +cat chem/KPP/documentation/wkc_kpp.txt + + +# The name of your lexical analizer. KPP requires FLEX to be used. +# FLEX is a public domain lexical analizer and you can download it from +# http://www.gnu.org/software/flex/ or any other mirror site. If flex +# directory is not included in your path use the complete pathname. + +FLEX="flex" + + +# +# +# The complete pathname of the FLEX library (libfl.a). +# On many systems this is: /usr/local/util/lib/flex +# on other systems, the path can be a bit strange +# FLEX_LIB_DIR=/afs/ipp-garching.mpg.de/rs_aix53/soft/gnu/lib +# the default is FLEX_LIB_DIR="/usr/lib" + + +# Look for flex lib dirctory +# if FLEX_LIB_DIR environment variable is not set then check in /usr/lib + +if test -z "$FLEX_LIB_DIR" ; then + for p in /usr/lib + do + if test -d $p ; then + FLEX_LIB_DIR=$p + break + fi + done +# fi + +# if FLEX_LIB_DIR environment variable is not set then check in /usr/lib64 + +# if test -z "$FLEX_LIB_DIR" ; then + for p in /usr/lib64 + do + if test -d $p ; then + FLEX_LIB_DIR=$p + break + fi + done +fi + +# Platform independent C compiler flags. By default "-O" is used which +# turns on optimisation. If you are experiencing problems you may try +# "-g" to include debuging informations. + +CC_FLAGS="-O" + + + +export FLEX +export FLEX_LIB_DIR +export CC_FLAGS + +echo "------------------------------------------" +echo " configure_kpp, settings:" + +# see if we can find libfl.a +if test -e "${FLEX_LIB_DIR}/libfl.a" ; then +echo location of flex library: ${FLEX_LIB_DIR}/libfl.a + +else + echo No libfl.a in ${FLEX_LIB_DIR} + echo ' check if FLEX_LIB_DIR environment variable is set correctly' + echo ' (FLEX_LIB_DIR should be the complete pathname of the FLEX library libfl.a)' + echo ' OR: Enter full path to flex library on your system' + read FLEX_LIB_DIR + if test ! -e ${FLEX_LIB_DIR}/libfl.a ; then + echo PROBLEM: libfl.a NOT FOUND IN ${FLEX_LIB_DIR} + read FLEX_LIB_DIR + fi + +fi + + + +# get SCC from configure.wrf + +PCC=`grep -e CC ./configure.wrf | grep -v make | grep -e "=" | grep -v SCC | grep -v TOOLS` +PSCC=`grep -e SCC ./configure.wrf | grep -v make | grep -e "="` + + +##PSCC="SCC = cc" + +export PCC +export PSCC + + +echo $PCC +echo $PSCC +echo writing chem/${WKC_DIRNAME}/configure.kpp +pwd +echo "-----------------------------------------" + + + +cat <chem/${WKC_DIRNAME}/configure.kpp +# +# This file was automatically written by the configure_kpp script +# MANUAL CHANGES WILL BE LOST ! +# +# this file is in parts based on the original Makefile.defs from KPP + + + +$PCC +$PSCC + + +YACC=yacc -d + + +# The name of your lexical analizer. KPP requires FLEX to be used. +# FLEX is a public domain lexical analizer and you can download it from +# http://www.gnu.org/software/flex/ or any other mirror site. If flex +# directory is not included in your path use the complete pathname. + + +FLEX=$FLEX + + +# The complete pathname of the FLEX library (libfl.a). +# On many systems this is: /usr/local/util/lib/flex +FLEX_LIB_DIR = $FLEX_LIB_DIR + + + + + + +CC_FLAGS=$CC_FLAGS + +############################################################################## + +END1 + +exit + diff --git a/wrfv2_fire/chem/KPP/documentation/gpl/gpl_kpp.txt b/wrfv2_fire/chem/KPP/documentation/gpl/gpl_kpp.txt new file mode 100755 index 00000000..2f3669ea --- /dev/null +++ b/wrfv2_fire/chem/KPP/documentation/gpl/gpl_kpp.txt @@ -0,0 +1,313 @@ +****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free + Software Foundation (http://www.gnu.org/copyleft/gpl.html); either + version 2 of the License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + A copy of the GNU General Public License could be found below; you + could also consult http://www.gnu.org/copyleft/gpl.html or write to the + Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +****************************************************************************** + + + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/wrfv2_fire/chem/KPP/documentation/gpl/gpl_wkc.txt b/wrfv2_fire/chem/KPP/documentation/gpl/gpl_wkc.txt new file mode 100755 index 00000000..31c98f8e --- /dev/null +++ b/wrfv2_fire/chem/KPP/documentation/gpl/gpl_wkc.txt @@ -0,0 +1,316 @@ +****************************************************************************** + + WRF-Chem to KPP coupler (WKC) + (Note that neither WRF-Chem nor KPP are parts of WKC) + + + Copyright (C) 2006 Marc Salzmann + + WKC is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + WKC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Marc Salzmann + Max Planck Institute for Chemistry + Department of Atmospheric Chemistry + Postfach 3060 + 55020 Mainz, Germany + e-mail: salzmann@mpch-mainz.mpg.de + www.mpch-mainz.mpg.de/~salzmann/my_home/index.html + + +****************************************************************************** + + + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm.inc b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_radm2.inc b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_radm2.inc new file mode 100644 index 00000000..102089e1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_to_update_rconst_radm2.inc @@ -0,0 +1,4 @@ +! +rc_n2o5, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm.inc b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_radm2.inc b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_radm2.inc new file mode 100644 index 00000000..a6226b7f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_args_update_rconst_radm2.inc @@ -0,0 +1,3 @@ +! +rc_n2o5, & +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm.inc b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_radm2.inc b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_radm2.inc new file mode 100644 index 00000000..0b08c167 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/extra_decls_update_rconst_radm2.inc @@ -0,0 +1,2 @@ +! + REAL(KIND=dp) :: rc_n2o5 diff --git a/wrfv2_fire/chem/KPP/inc/fixed_args_kpp_interf.inc b/wrfv2_fire/chem/KPP/inc/fixed_args_kpp_interf.inc new file mode 100644 index 00000000..a649210a --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/fixed_args_kpp_interf.inc @@ -0,0 +1,3 @@ + chem, id, dtstepc,config_flags, & + p_phy,t_phy,rho_phy,moist, & + vdrog3, ldrog, & diff --git a/wrfv2_fire/chem/KPP/inc/fixed_decl_kpp_interf.inc b/wrfv2_fire/chem/KPP/inc/fixed_decl_kpp_interf.inc new file mode 100644 index 00000000..a4374cff --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/fixed_decl_kpp_interf.inc @@ -0,0 +1,29 @@ + INTEGER, INTENT(IN ) :: id + + REAL, INTENT(IN ) :: dtstepc + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + p_phy, & + t_phy, & + rho_phy + + +! needed for aerosols + + INTEGER, INTENT ( IN ) :: ldrog + + REAL, INTENT(INOUT) :: & + vdrog3(ims:ime,kms:kme-0,jms:jme,ldrog) diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_a_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_b_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_e_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racmsorg.inc new file mode 100644 index 00000000..b74d2647 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_racmsorg.inc @@ -0,0 +1,46 @@ +! +! +! corrupted from RS +! + + if(p_nu0.gt.1)then + rxylho = RCONST(74) !ARR(7.30e-12,-355.0,t_phy(i,k,j)))) + rtolho = RCONST(73) !ARR(1.81e-12,-355.0,t_phy(i,k,j)))) + rcslho = RCONST(75) !ARR(6.00e-11,0.0,t_phy(i,k,j)))) + rcslno3 = RCONST(97) !ARR(2.20e-11,0.0,t_phy(i,k,j)))) + rhc8ho = RCONST(65) !ARR(1.64e-11,125.0,t_phy(i,k,j)))) + roliho = RCONST(68) !ARR(1.33e-11,-500.0,t_phy(i,k,j)))) + rolino3 = RCONST(100) !ARR(8.64e-13,-450.0,t_phy(i,k,j)))) + rolio3 = RCONST(108) !ARR(4.40e-15,845.0,t_phy(i,k,j)))) + roltho = RCONST(67) !ARR(5.72e-12,-500.0,t_phy(i,k,j)))) + roltno3 = RCONST(99) !ARR(1.79e-13,450.0,t_phy(i,k,j)))) + rolto3 = RCONST(107) !ARR(4.33e-15,1800.0,t_phy(i,k,j)))) + rapiho = RCONST(71) !ARR(1.21e-11,-444.0,t_phy(i,k,j)))) + rapino3 = RCONST(103) !ARR(1.19e-12,-490.0,t_phy(i,k,j)))) + rapio3 = RCONST(111) !ARR(1.01e-15,736.0,t_phy(i,k,j)))) !! 732!! + rlimho = RCONST(72) !ARR(1.71e-10,0.0,t_phy(i,k,j)))) + rlimno3 = RCONST(104) !ARR(1.22e-11,0.0,t_phy(i,k,j)))) + rlimo3 = RCONST(112) !ARR(2.00e-16,0.0,t_phy(i,k,j)))) + PRDROG(PXYL) = rxylho * var(ind_xyl)*var(ind_ho) + PRDROG(PTOL) = rtolho * var(ind_tol)*var(ind_ho) + PRDROG(PCSL1) = rcslho * var(ind_csl)*var(ind_ho) + PRDROG(PCSL2) = 0.50_dp * rcslno3* var(ind_csl)*var(ind_no3) + PRDROG(PHC8) = rhc8ho * var(ind_hc8)*var(ind_ho) + PRDROG(POLI1) = roliho * var(ind_oli)*var(ind_ho) + PRDROG(POLI2) = rolino3 * var(ind_oli)*var(ind_no3) + PRDROG(POLI3) = rolio3 * var(ind_oli)*var(ind_o3) + PRDROG(POLT1) = roltho * var(ind_olt)*var(ind_ho) + PRDROG(POLT2) = roltno3 * var(ind_olt)*var(ind_no3) + PRDROG(POLT3) = rolto3 * var(ind_olt)*var(ind_o3) + PRDROG(PAPI1) = rapiho * var(ind_api)*var(ind_ho) + PRDROG(PAPI2) = rapino3 * var(ind_api)*var(ind_no3) + PRDROG(PAPI3) = rapio3 * var(ind_api)*var(ind_o3) + PRDROG(PLIM1) = rlimho * var(ind_lim)*var(ind_ho) + PRDROG(PLIM2) = rlimno3 * var(ind_lim)*var(ind_no3) + PRDROG(PLIM3) = rlimo3 * var(ind_lim)*var(ind_o3) + DO n = 1, LDROG + VDROG3( i,k,j, n ) = oconv * PRDROG( n ) * DTSTEPC + VDROG3( i,k,j,n ) = MAX( 0., VDROG3( i,k,j, n ) ) + ENDDO + endif + diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ia_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ib_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racmsorg.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_racmsorg.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_radm2.inc new file mode 100644 index 00000000..da5f1676 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_ibu_radm2.inc @@ -0,0 +1,14 @@ +! +! calculate rate constant for n2o5 + water in RADM2 + + es = 1000.*0.6112*exp(17.67*(t_phy(i,k,j)-273.15)/(t_phy(i,k,j)- 29.65)) + qvs = es / ( p_phy(i,k,j) - es ) + + + rh = moist(i,k,j,P_QV) / qvs + rh = MIN ( MAX ( rh, 0.), 1.) + + + rc_n2o5 = REAL(1.0 / ( 3.6E4 * EXP( -( rh / 0.28 ) ** 2.8 ) + 300.0 ), KIND=dp) + + diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racmsorg.inc new file mode 100644 index 00000000..aad75370 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_racmsorg.inc @@ -0,0 +1,7 @@ + + REAL(KIND=dp) :: rxylho,rtolho,rcslho,rcslno3,rhc8ho,roliho,rolino3, & + rolio3,roltho,roltno3,rolto3,rapiho,rapino3,rapio3, & + rlimho,rlimno3,rlimo3 + + REAL(KIND=dp) , DIMENSION(ldrog) :: PRDROG + diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_radm2.inc new file mode 100644 index 00000000..11dca58b --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_l_radm2.inc @@ -0,0 +1,3 @@ +! + REAL :: es, qvs, rh + REAL( KIND = dp ) :: rc_n2o5 diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm_mim.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm_mim.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racm_mim.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racmsorg.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racmsorg.inc new file mode 100644 index 00000000..97631e39 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_racmsorg.inc @@ -0,0 +1,2 @@ +! + USE module_data_sorgam, ONLY : PXYL, PTOL, PCSL1, PCSL2, PHC8, POLI1, POLI2, POLI3, POLT1, POLT2, POLT3, PAPI1, PAPI2, PAPI3, PLIM1, PLIM2, PLIM3 diff --git a/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_radm2.inc b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_radm2.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/kpp_mechd_u_radm2.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/Makefile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/Makefile new file mode 100755 index 00000000..51b47d19 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/Makefile @@ -0,0 +1,53 @@ +######################################################################################## +# +# KPP - The Kinetic PreProcessor +# Builds simulation code for chemical kinetic systems +# +# Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu +# Copyright (C) 1997-2004 Adrian Sandu +# +# KPP is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the +# License, or (at your option) any later version. +# +# KPP is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along +## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or +# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +# Adrian Sandu +# Computer Science Department +# Virginia Polytechnic Institute and State University +# Blacksburg, VA 24060 +# E-mail: sandu@cs.vt.edu +# +# +# this file was modified and is is part of a slightly modified KPP version. +# Modifications by M. Salzmann, MPI for Chemistry, Mainz, Germany +# +# +####################################################################################### + +#include Makefile.defs + + +all: setup kpp + +setup: + @./cflags.guess $(SCC) + +kpp: + @cd src;make;cd .. + +clean: + @cd src;make clean;cd .. + @rm -f *~ */*~ + +distclean: clean + @rm -f bin/kpp diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/bin/kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/bin/kpp new file mode 100755 index 00000000..0320642b Binary files /dev/null and b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/bin/kpp differ diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags new file mode 100644 index 00000000..8d1c8b69 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags @@ -0,0 +1 @@ + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags.guess b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags.guess new file mode 100755 index 00000000..9b0af15f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags.guess @@ -0,0 +1,39 @@ +#!/bin/sh +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +CC=cc +if [ x$1 != x ]; then CC=$1; fi + +exec 5>./cflags + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}:${CC}" in + + *:HP-UX:*:*:cc*) # For HP-UX workstations + echo " -Aa -D_HPUX_SOURCE " 1>&5; exit 0 ;; + + *:AIX:*:*:cc*) # For machines running AIX + echo " -Aa " 1>&5; exit 0 ;; + + *:IRIX:*:*:cc*) # For machines running IRIX + echo " " 1>&5; exit 0 ;; + + *:IRIX64:*:*:cc*) # For machines running IRIX64 + echo " " 1>&5; exit 0 ;; + + *:Linux:*:*:cc*) # For Linux machines + echo " " 1>&5; exit 0 ;; + + *:SunOS:*:*:cc*) # For SUN machines + echo " Please use gcc compiler on SUN machines."; exit 1 ;; + + *:*:*:*:gcc*) # this is the default case, for gcc + echo " " 1>&5; exit 0 ;; + + *:*:*:*:*) # this is the default case + echo " " 1>&5; exit 0 ;; +esac diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.c new file mode 100755 index 00000000..5d446d8a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.c @@ -0,0 +1,56 @@ +void main() +{ +KPP_REAL dval[NSPEC]; +FILE * fp; +int i; + +/* ---- TIME VARIABLES ------------------ */ + + RTOLS = 1e-6; + TSTART = 3600*12; + TEND = TSTART + 3600*24*5; + DT = 3600.; + TEMP = 236.21; + + Initialize(); + + for( i = 0; i < NVAR; i++ ) { + RTOL[i] = RTOLS; + ATOL[i] = 1; + } + STEPMIN = 0.01; + STEPMAX = 900; + +/* ********** TIME LOOP **************************** */ + + InitSaveData(); + + printf("\n%7s %7s ", "done[%]", "Time[h]"); + for( i = 0; i < NMONITOR; i++ ) + printf( "%8s ", SPC_NAMES[MONITOR[i]] ); + for( i = 0; i < NMASS; i++ ) + printf( "(%6s) ", SMASS[i] ); + + TIME = TSTART; + while (TIME <= TEND) { + GetMass( C, dval ); + printf("\n%6.1f%% %7.2f ", (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600 ); + for( i = 0; i < NMONITOR; i++ ) + printf( "%8.2e ", C[ MONITOR[i] ]/CFACTOR ); + for( i = 0; i < NMASS; i++ ) + printf( "%8.2e ", dval[i]/CFACTOR ); + + SaveData(); + + Update_SUN(); + Update_RCONST(); + + INTEGRATE( DT ); + } + +/* *********** END TIME LOOP *********************** */ + + printf("\n"); + CloseSaveData(); + GenerateMatlab(""); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.f new file mode 100755 index 00000000..c6b97d40 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/exact.f @@ -0,0 +1,67 @@ + PROGRAM driver + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + KPP_REAL DVAL(NSPEC) + INTEGER i + +C ---- TIME VARIABLES ------------------ + + TSTART = 0 + TEND = TSTART + 600 + DT = 60. + TEMP = 298 + + STEPMIN = 0.01 + STEPMAX = 900 + + RTOLS = 1e-8 + do i=1,NVAR + RTOL(i) = RTOLS + ATOL(i) = 1e-3 + end do + + CALL Initialize() + +C ********** TIME LOOP ************************* + + CALL InitSaveData() + + write(6,990) (SPC_NAMES[MONITOR(i)], i=1,NMONITOR), + * (SMASS(i), i=1,NMASS ) +990 FORMAT('done[%] Time[h] ',20(4X,A6)) + + TIME = TSTART + do while (TIME .lt. TEND) + + CALL GetMass( C, DVAL ) + write(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) +991 FORMAT(F6.1,'% ',F7.2,3X,20(E10.4,2X)) + + CALL SaveData() + + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE( TIME, TIME+DT ) + + end do + + CALL GetMass( C, DVAL ) + write(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +C *********** END TIME LOOP ******** + + CALL CloseSaveData() + CALL GenerateMatlab(' ') + + STOP + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.c new file mode 100755 index 00000000..44a9d4eb --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.c @@ -0,0 +1,63 @@ +int InitSaveData(); +void Initialize(); +int SaveData(); +int CloseSaveData(); +int GenerateMatlab( char * prefix ); +void GetMass( double CL[], double Mass[] ); +void INTEGRATE( double TIN, double TOUT ); + +int main() +{ +KPP_REAL dval[NSPEC]; +int i; + +/* ---- TIME VARIABLES ------------------ */ + + RTOLS = 1e-3; + TSTART = 3600*12; + TEND = TSTART + 3600*24*5; + DT = 3600.; + TEMP = 236.21; + + Initialize(); + + for( i = 0; i < NVAR; i++ ) { + RTOL[i] = RTOLS; + ATOL[i] = 1.0; + } + STEPMIN = 0.01; + STEPMAX = 900; + +/* ********** TIME LOOP **************************** */ + + InitSaveData(); + + printf("\n%7s %7s ", "done[%]", "Time[h]"); + for( i = 0; i < NMONITOR; i++ ) + printf( "%8s ", SPC_NAMES[MONITOR[i]] ); + for( i = 0; i < NMASS; i++ ) + printf( "(%6s) ", SMASS[i] ); + + TIME = TSTART; + while (TIME <= TEND) { + GetMass( C, dval ); + printf("\n%6.1f%% %7.2f ", (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600 ); + for( i = 0; i < NMONITOR; i++ ) + printf( "%9.3e ", C[ MONITOR[i] ]/CFACTOR ); + for( i = 0; i < NMASS; i++ ) + printf( "%9.3e ", dval[i]/CFACTOR ); + + SaveData(); + + INTEGRATE( TIME , TIME+DT ); + TIME += DT; + } + +/* *********** END TIME LOOP *********************** */ + + printf("\n"); + CloseSaveData(); + + return 0; /*didnt return anything initially */ + +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f new file mode 100755 index 00000000..ca0d8cc6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f @@ -0,0 +1,72 @@ + PROGRAM driver + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + KPP_REAL DVAL(NSPEC) + INTEGER i + +C ---- TIME VARIABLES ------------------ + + TSTART = 0 + TEND = TSTART + 600 + DT = 60. + TEMP = 298 + + STEPMIN = 0.01 + STEPMAX = 900 + + RTOLS = 1e-3 + DO i=1,NVAR + RTOL(i) = RTOLS + ATOL(i) = 1 + END DO + + CALL Initialize() + +C ********** TIME LOOP ************************* + + CALL InitSaveData() + + WRITE(6,990) (SPC_NAMES(MONITOR(i)), i=1,NMONITOR), + * (SMASS(i), i=1,NMASS ) +990 FORMAT('DOne[%] Time[h] ',20(4X,A6)) + + TIME = TSTART + DO WHILE (TIME .lt. TEND) + + CALL GetMass( C, DVAL ) + WRITE(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) +991 FORMAT(F6.1,'% ',F7.2,3X,20(E10.4,2X)) + + CALL SaveData() + + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE( TIME, TIME+DT ) + + END DO + + CALL GetMass( C, DVAL ) + WRITE(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +C *********** END TIME LOOP ******** + + CALL CloseSaveData() + + open(75, file='reference.data') + do i=1,KPP_NVAR + write(75,75) VAR(i) + end do +75 FORMAT(100(E24.14,1X)) + + STOP + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f90 new file mode 100755 index 00000000..cda21d08 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.f90 @@ -0,0 +1,57 @@ +PROGRAM KPP_ROOT_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + KPP_REAL :: T, DVAL(NSPEC) + KPP_REAL :: RSTATE(20) + INTEGER :: i + +!~~~> TIME VARIABLES + + STEPMIN = 0.0d0 + STEPMAX = 0.0d0 + + DO i=1,NVAR + RTOL(i) = 1.0d-4 + ATOL(i) = 1.0d-3 + END DO + + CALL Initialize() + CALL InitSaveData() + +!~~~> Time loop + T = TSTART +kron: DO WHILE (T < TEND) + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + ( TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR ), & + ( TRIM(SMASS(i)), DVAL(i)/CFACTOR, i=1,NMASS ) + TIME = T + CALL SaveData() + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE( TIN = T, TOUT = T+DT, RSTATUS_U = RSTATE, & + ICNTRL_U = (/ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) + T = RSTATE(1) + + END DO kron +!~~~> End Time loop + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + ( TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR ), & + ( TRIM(SMASS(i)), DVAL(i)/CFACTOR, i=1,NMASS ) + TIME = T + CALL SaveData() + CALL CloseSaveData() + +990 FORMAT('Done[%]. Time ',20(4X,A12)) +991 FORMAT(F6.1,'%. T=',E9.3,2X,200(A,'=',E11.4,'; ')) + +END PROGRAM KPP_ROOT_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.m new file mode 100755 index 00000000..9a388663 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general.m @@ -0,0 +1,83 @@ + + TSTART = 0; + TEND = TSTART + 600; + DT = 60.; + TEMP = 298; + + RTOLS = 1.0e-6; + ATOLS = 1.0e-3; + + KPP_ROOT_Initialize; + + Options = odeset('AbsTol',ATOLS,'RelTol',RTOLS,'Jacobian',@KPP_ROOT_Jac_Chem); + +% ********** TIME LOOP ************************* + + C(1:KPP_NVAR) = VAR(1:KPP_NVAR); + C((KPP_NVAR+1):KPP_NSPEC) = FIX(1:KPP_NFIX); + DVAL = KPP_ROOT_GetMass( C ); + if ( ~isempty(SMASS) ) + fprintf('Initial Mass = %10.4e\n', DVAL(1:NMASS)/CFACTOR); + end + +% KPP_ROOT_InitializeSaveData; + +% disp(['Done[%] Time[h] ',SPC_NAMES(MONITOR(1:NMONITOR))]) + + TIME = TSTART; + + Tspan = linspace( TSTART, TEND, 100 ); + + [T, Y] = ode15s(@KPP_ROOT_Fun_Chem, Tspan, VAR, Options); + + VAR(1:KPP_NVAR) = Y(length(T),1:KPP_NVAR)'; + Y = [Y, ones(length(T),1)*FIX(:)']; + + C(1:KPP_NVAR) = VAR(1:KPP_NVAR); + C((NVAR+1):NSPEC) = FIX(1:NFIX); + DVAL = KPP_ROOT_GetMass( C ); + + fprintf('done %6.1f, %7.2h hours', (TIME-TSTART)/(TEND-TSTART), TIME/3600.); + disp( Y(:,MONITOR(1:NMONITOR))/CFACTOR ); + if ( ~isempty(SMASS) ) + fprintf('Final Mass = %10.4e\n', DVAL(1:NMASS)/CFACTOR); + end + + for i = 1:NMONITOR + figure; plot( (T)/3600, Y(:,MONITOR(i))/CFACTOR ); + title( SPC_NAMES( MONITOR(i),:) ,'FontSize',12); + set(gca,'XLim',[TSTART,TEND]/3600,'FontSize',12); + xlabel('Time [ h ]','FontSize',12); + ylabel('Concentration','FontSize',12); + end + +% KPP_ROOT_FUNC_SaveData; +% KPP_ROOT_FUNC_CloseSaveData; + +return + + +% function P = KPP_ROOT_Fun_Chem(T, Y) +% +% global TIME FIX RCONST +% +% Told = TIME; +% TIME = T; +% KPP_ROOT_Update_SUN; +% KPP_ROOT_Update_RCONST; +% P = KPP_ROOT_Fun( Y, FIX, RCONST ); +% TIME = Told; +% return +% +% +% function J = KPP_ROOT_Jac_Chem(T, Y) +% +% global TIME FIX RCONST ; +% +% Told = TIME; +% TIME = T; +% KPP_ROOT_Update_SUN; +% KPP_ROOT_Update_RCONST; +% J = KPP_ROOT_Jac_SP( Y, FIX, RCONST ); +% TIME = Told +% return diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_adj.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_adj.f90 new file mode 100755 index 00000000..52b7f45a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_adj.f90 @@ -0,0 +1,90 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Driver for the Adjoint (ADJ) model +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +PROGRAM KPP_ROOT_ADJ_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + KPP_REAL :: T, DVAL(NSPEC) + INTEGER :: i, j, ind_1 = 1, ind_2 = 2 + ! INTEGER :: ind_1 = ind_NO2, ind_2 = ind_O3 + +! --- Number of functional for which sensitivities are computed +! --- Note: this value is set for sensitivities w.r.t. all initial values +! --- it may have to be changed for other applications + INTEGER NADJ + PARAMETER (NADJ = 2) + KPP_REAL Y_ADJ(NVAR,NADJ) + +! ---- TIME VARIABLES ------------------ + + STEPMIN = 0.0d0 + STEPMAX = 0.0d0 + + DO i=1,NVAR + RTOL(i) = 1.0d-4 + ATOL(i) = 1.0d-3 + END DO + + CALL Initialize() + +!~~~> Note: the initial values below are adjoint values at the final time + Y_ADJ(1:NVAR,1:NADJ) = 0.0d0 + Y_ADJ(ind_1,1) = 1.0d0 + Y_ADJ(ind_2,2) = 1.0d0 + +! ~~~~~~~~~ BEGIN TIME LOOP ~~~~~~~~~~ + + CALL InitSaveData() + + T = TSTART + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR), & + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + + CALL INTEGRATE_ADJ( NADJ, VAR, Y_ADJ, T, TEND ) + + + CALL GetMass( C, DVAL ) + WRITE(6,991) (TEND-TSTART)/(TEND-TSTART)*100, TEND, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR), & + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +! ~~~~~~~~~ END TIME LOOP ~~~~~~~~~~ + + OPEN(20, FILE='KPP_ROOT_ADJ_results.m') + WRITE(6,*) '**************************************************' + WRITE(6,*) ' Concentrations and Sensitivities at final time ' + WRITE(6,*) ' were written in the file KPP_ROOT_ADJ_results.m' + WRITE(6,*) '**************************************************' + DO j=1,NADJ + WRITE(20,993) ( Y_ADJ(i,j), i=1,NVAR ) + END DO + + WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_1)), & + Y_ADJ(ind_1,1) + WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_2)), & + Y_ADJ(ind_2,2) + WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_1)), & + Y_ADJ(ind_1,2) + WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_2)), & + Y_ADJ(ind_2,1) + + CALL CloseSaveData() + + 991 FORMAT(F6.1,'%. T=',E10.3,3X,20(A,'=',E10.4,';',1X)) + 993 FORMAT(1000(E24.16,2X)) + 995 FORMAT('ADJ: d[',A,'](tf)/d[',A,'](t0)=',E14.7) + +END PROGRAM KPP_ROOT_ADJ_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_complete.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_complete.f90 new file mode 100755 index 00000000..a95d8c7d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_complete.f90 @@ -0,0 +1,114 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Driver for the tangent linear model +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +PROGRAM KPP_ROOT_ADJ_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + KPP_REAL :: T, DVAL(NSPEC) + INTEGER :: i, j, ind_1 = ind_NO2, ind_2 = ind_O3 + +! --- Number of functional for which sensitivities are computed +! --- Note: this value is set for sensitivities w.r.t. all initial values +! --- it may have to be changed for other applications + INTEGER NADJ + PARAMETER (NADJ = 2) + KPP_REAL Y_ADJ(NVAR,NADJ) + REAL(kind=dble_p) R1(NVAR), R2(NVAR), V1, V2 + +! ---- TIME VARIABLES ------------------ + + STEPMIN = 0.0d0 + STEPMAX = 0.0d0 + + CALL SRAND(89) + RTOLS = 1.0d-3 + DO i=1,NVAR + RTOL(i) = RTOLS + ATOL(i) = 1.0d-2 + R1(i) = 10*(RAND()-0.5d0) + R2(i) = 10*(RAND()-0.5d0) + END DO + + CALL Initialize() +! --- Note: the initial values below are adjoint values at the final time + Y_ADJ(1:NVAR,1) = R1(1:NVAR) + Y_ADJ(1:NVAR,2) = R2(1:NVAR) + +! ********** T LOOP ************************* + + CALL InitSaveData() + + WRITE(6,990) (SPC_NAMES(MONITOR(i)), i=1,NMONITOR) +990 FORMAT('DOne[%] Time[h] ',20(4X,A12)) + + T = TSTART + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T/3600., & + (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), & + (DVAL(i)/CFACTOR, i=1,NMASS) +991 FORMAT(F6.1,'% ',F7.2,3X,20(E10.4,2X)) + + CALL SaveData() + + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE_ADJ( NADJ, Y_ADJ, T, TEND ) + + V1 = 0.0d0 + V2 = 0.0d0 + DO i=1,NVAR + V1 = V1 + Y_ADJ(i,1)*R2(i) + V2 = V2 + Y_ADJ(i,2)*R1(i) + END DO + + PRINT*,'**************************************************' + WRITE(6,887) V1 + WRITE(6,888) V2 + WRITE(6,889) ABS(V1-V2)/MAX(ABS(V1),ABS(V2)) +887 FORMAT('u.M''*M''.v = ',E24.14 ) +888 FORMAT('v.M''*M''.u = ',E24.14 ) +889 FORMAT('RelativeErr=',E10.3 ) + PRINT*,'**************************************************' + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T/3600., & + (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), & + (DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +! *********** END TIME LOOP ******** + OPEN(20, FILE='KPP_ROOT_ADJ_results.m') + WRITE(6,*) '**************************************************' + WRITE(6,*) ' Concentrations and Sensitivities at final time ' + WRITE(6,*) ' were written in the file KPP_ROOT_ADJ_results.m' + WRITE(6,*) '**************************************************' + DO j=1,NADJ + WRITE(20,993) ( Y_ADJ(i,j), i=1,NVAR ) + END DO + 993 FORMAT(1000(E24.16,2X)) + + PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_1)),'](tf) / d[', & + TRIM(SPC_NAMES(ind_1)),'](t0)=', Y_ADJ(ind_1,1) + PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_2)),'](tf) / d[', & + TRIM(SPC_NAMES(ind_2)),'](t0)=', Y_ADJ(ind_2,2) + PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_1)),'](tf) / d[', & + TRIM(SPC_NAMES(ind_2)),'](t0)=', Y_ADJ(ind_1,2) + PRINT*,'ADJ: d[',TRIM(SPC_NAMES(ind_2)),'](tf) / d[', & + TRIM(SPC_NAMES(ind_1)),'](t0)=', Y_ADJ(ind_2,1) + + PRINT*,'TLM: d[NO2](tf) / d[NO2](t0)= 1.714961808143527E-002' + PRINT*,'TLM: d[ O3](tf) / d[ O3](t0)= -4.447774183920545E-003' + PRINT*,'TLM: d[NO2](tf) / d[ O3](t0)= 0.897512294491540' + PRINT*,'TLM: d[ O3](tf) / d[NO2](t0)= -5.543729901774693E-005' + + + CALL CloseSaveData() + +END PROGRAM KPP_ROOT_ADJ_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_ddm_ic.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_ddm_ic.f new file mode 100755 index 00000000..91b64e59 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_ddm_ic.f @@ -0,0 +1,117 @@ +C --- Driver for computing sensitivity coefficients w.r.t. all initial values + PROGRAM driver + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C --- Number of sensitivity coefficients to compute +C --- Note: this value is set for sensitivities w.r.t. all initial values +C --- it may have to be changed for other applications + INTEGER NSENSIT + PARAMETER (NSENSIT = NVAR) + + KPP_REAL DVAL(NSPEC) + KPP_REAL Y(NVAR*(NSENSIT+1)) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER i + +C --- The type of sensitivity coefficients to compute +C --- DDMTYPE = 0 : sensitivities w.r.t. initial values +C --- DDMTYPE = 1 : sensitivities w.r.t. parameters + DDMTYPE = 0 + +C ---- TIME VARIABLES ------------------ + + TSTART = 0 + TEND = TSTART + 600 + DT = 60. + TEMP = 298 + + STEPMIN = 0.01 + STEPMAX = 900 + + PRINT*,'Please provide: RTOL = , ATOL = ' + READ*,RTOLS, ATOLS + do i=1,NVAR + RTOL(i) = RTOLS + ATOL(i) = ATOLS + end do + +C ********** TIME LOOP ************************* + + CALL Initialize() + +C -- Initialize Concentrations and Sensitivities + DO i=1,NVAR + Y(i) = VAR(i) + END DO + +C --- Note: the initial values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + Y(i+NVAR*j) = 0.0D0 + END DO + Y(j+NVAR*j) = 1.0D0 + END DO + + CALL InitSaveData() + + WRITE(6,990) (SPC_NAMES(MONITOR(i)), i=1,NMONITOR), + * (SMASS(i), i=1,NMASS ) +990 FORMAT('done[%] Time[h] ',20(4X,A6)) + + TIME = TSTART + DO WHILE (TIME .lt. TEND) + + CALL GetMass( C, DVAL ) + WRITE(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) +991 FORMAT(F6.1,'% ',F7.2,3X,20(E10.4,2X)) + + CALL SaveData() + + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE( NSENSIT, Y, TIME, TIME+DT ) + + DO i=1,NVAR + VAR(i) = Y(i) + END DO + + END DO + + CALL GetMass( C, DVAL ) + WRITE(6,991) (TIME-TSTART)/(TEND-TSTART)*100, TIME/3600., + * (C(MONITOR(i))/CFACTOR, i=1,NMONITOR), + * (DVAL(i)/CFACTOR, i=1,NMASS) + +C DO i=1,NSENSIT +C WRITE(6,992) i, ( Y(NVAR*i+j), j=1,NVAR ) +C END DO +C 992 FORMAT('SEN(',I3,') = ',1000(E10.4,2X)) + + CALL SaveData() + +C *********** END TIME LOOP ******** + OPEN(20, FILE='KPP_ROOT_results.m') + WRITE(6,*) '**************************************************' + WRITE(6,*) '* Concentrations and Sensitivities at final time *' + WRITE(6,*) '* were written in the file KPP_ROOT_results.m *' + WRITE(6,*) '**************************************************' + DO i=0,NSENSIT + WRITE(20,993) ( Y(NVAR*i+j), j=1,NVAR ) + END DO + 993 FORMAT(1000(E24.16,2X)) + + CALL CloseSaveData() + + STOP + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_soa.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_soa.f90 new file mode 100755 index 00000000..60f5eb8a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_soa.f90 @@ -0,0 +1,115 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Driver for the Second Order Adjoint (SOA) model +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +PROGRAM KPP_ROOT_SOA_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + KPP_REAL :: T, DVAL(NSPEC) + INTEGER :: i, j, ind_1 = 1, ind_2 = 2 + ! INTEGER :: ind_1 = ind_NO2, ind_2 = ind_O3 + +!~~~> Number of second order adjoints +! i.e., number of vectors U_i s.t. SOA_i = Hess*U_i +! 1 <= i <= NSOA + + INTEGER, PARAMETER :: NSOA = 2 + + KPP_REAL :: Y_tlm(NVAR,NSOA) + KPP_REAL :: Y_adj(NVAR) + KPP_REAL :: Y_soa(NVAR,NSOA) + + STEPMIN = 0.0d0 + STEPMAX = 0.0d0 + + DO i=1,NVAR + RTOL(i) = 1.0d-4 + ATOL(i) = 1.0d-3 + END DO + + CALL Initialize() +!~~~> Tangent linear variable values at the initial time + Y_tlm(1:NVAR,1:NSOA) = 0.0d0 + Y_tlm(ind_1,1) = 1.0d0 + Y_tlm(ind_2,2) = 1.0d0 +!~~~> Adjoint values at the final time + Y_adj(1:NVAR) = 0.0d0 + Y_adj(ind_1) = 1.0d0 +!~~~> 2nd order adjoint values at the final time + Y_soa(1:NVAR,1:NSOA) = 0.0d0 + Y_soa(ind_1,1) = 1.0d0 + Y_soa(ind_2,2) = 1.0d0 + +!~~~~~~~~~~~ Time LOOP ~~~~~~~~~~~~~ + + CALL InitSaveData() + + T = TSTART + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR),& + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + + CALL Update_SUN() + CALL Update_RCONST() + + CALL INTEGRATE_SOA(NSOA, VAR, Y_tlm, Y_adj, Y_soa, T, TEND) + + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR),& + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +!~~~~~~~~~~~ END Time LOOP ~~~~~~~~~~~~~ + + WRITE(6,*) '**************************************************' + WRITE(6,*) ' Results were written in the files' + WRITE(6,*) ' KPP_ROOT_[TLM|ADJ|SOA].m' + WRITE(6,*) '**************************************************' + + PRINT 995,TRIM(SPC_NAMES(ind_1)), & + TRIM(SPC_NAMES(ind_1)), & + Y_tlm(ind_1,1), Y_adj(ind_1) + PRINT 995,TRIM(SPC_NAMES(ind_1)), & + TRIM(SPC_NAMES(ind_2)), & + Y_tlm(ind_1,2), Y_adj(ind_2) + + DO j=1,NSOA + PRINT 997, j,(TRIM(SPC_NAMES(i)),Y_soa(i,j),i=1,NVAR) + END DO + + OPEN(53,FILE='KPP_ROOT_TLM.m') + DO j=1, NSOA + WRITE(53,993), (Y_tlm(i,j),i=1,NVAR) + END DO + CLOSE(53) + + OPEN(54,FILE='KPP_ROOT_ADJ.m') + WRITE(54,993), (Y_adj(i),i=1,NVAR) + CLOSE(54) + + OPEN(55,FILE='KPP_ROOT_SOA.m') + DO j=1, NSOA + WRITE(55,993), (Y_soa(i,j),i=1,NVAR) + END DO + CLOSE(55) + + 991 FORMAT(F6.1,'%. T=',E10.3,3X,20(A,'=',E10.4,';',1X)) + 993 FORMAT(1000(E24.16,2X)) + 995 FORMAT('d[',A,'](tf)/d[',A,'](t0). TLM=',E14.7,' ADJ=',E14.7) + 997 FORMAT('2nd ADJ (',I3,'): ',200(A,'=',E10.3,'; ')) + + CALL CloseSaveData() + +END PROGRAM KPP_ROOT_SOA_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.c new file mode 100755 index 00000000..64f826b8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.c @@ -0,0 +1,64 @@ +int InitSaveData(); +int SaveData(); +int CloseSaveData(); +int GenerateMatlab( char * prefix ); +void GetMass( double CL[], double Mass[] ); +void INTEGRATE( double TIN, double TOUT ); +void Gillespie(int Nssa, double Volume, double* T, int NmlcV[], int NmlcF[]); +void Update_RCONST(); + +/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ +int main() +/* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ +{ +/*~~~> Output results file */ + FILE* fpDat; +/*~~~> No of molecules */ + int NmlcV[NVAR], NmlcF[NFIX]; +/*~~~> No of reaction events per output step */ + int Nevents; +/*~~~> Local variables */ + int i; + double T; + + Initialize(); + + fpDat = fopen("KPP_ROOT_stochastic.dat", "w"); + + /* Translate initial values from conc. to molecules */ + /* Volume = 100.0; */ + Nevents = 20; + for( i = 0; i < NVAR; i++ ) + NmlcV[i] = (int)(Volume*VAR[i]); + for( i = 0; i < NFIX; i++ ) + NmlcF[i] = (int)(Volume*FIX[i]); + +/*~~~> Begin Time Loop ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ + T = TSTART; + while (T <= TEND) { + printf("\n%6.1f%% %10.4f ", (T-TSTART)/(TEND-TSTART)*100, T ); + for( i = 0; i < NVAR; i++ ) + printf( "%s=%d ", SPC_NAMES[i], NmlcV[i] ); + + fprintf(fpDat,"\n%g ", T ); + for( i = 0; i < NVAR; i++ ) + fprintf(fpDat,"%d ", NmlcV[i]); + + Gillespie( Nevents, Volume, &T , NmlcV, NmlcF ); + + } /* while (T <= TEND) */ +/*~~~> End Time Loop ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ + + fprintf(fpDat,"\n%g ", T ); + for( i = 0; i < NVAR; i++ ) + fprintf(fpDat,"%d ", NmlcV[i]); + fprintf(fpDat,"\n"); + fclose(fpDat); + + printf("\n"); + + return 0; + +} +/*~~~> End of MAIN function ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.f90 new file mode 100755 index 00000000..b7c93614 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_stochastic.f90 @@ -0,0 +1,63 @@ +PROGRAM KPP_ROOT_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + IMPLICIT NONE + +!~~~> No. of Stochastic events per simulation snaphot + INTEGER :: Nevents +!~~~> No. of Stochastic tau-steps simulation snaphot + INTEGER :: Nsteps +!~~~> No. of Molecules + INTEGER :: NmlcV(NVAR), NmlcF(NFIX) +!~~~> Random numbers + REAL :: r1, r2 +!~~~> Local variables + INTEGER :: i + KPP_REAL :: T, Tau, SCT(NREACT) + +!~~~~> Initialize and prescribe volume and no. of events + CALL Initialize() +! Volume = 1000.0d0 + Nevents = 5000 + Nsteps = 10 + Tau = (TEND-TSTART)/100.0 +!~~~~~~~~~~~~~~~~ + +!~~~> Translate initial values from conc. to NmlcVules + NmlcV(1:NVAR) = INT(Volume*VAR(1:NVAR)) + NmlcF(1:NFIX) = INT(Volume*FIX(1:NFIX)) +!~~~> Compute the stochastic reaction rates + CALL Update_RCONST() + CALL StochasticRates( RCONST, Volume, SCT ) + +!~~~> Save initial data + OPEN(10, file='KPP_ROOT_stochastic.dat') + WRITE(10,992) T, (NmlcV(i),i=1,NVAR) + +!~~~> TIME loop starts + T = TSTART +kron: DO WHILE (T < TEND) + + WRITE(6,991) T,(SPC_NAMES(i),NmlcV(i), i=1,NVAR) + +!~~~> Choose here one of the following time-stepping routines + CALL Gillespie(Nevents, T, SCT, NmlcV, NmlcF) +! CALL TauLeap(Nsteps, Tau, T, SCT, NmlcV, NmlcF) + + WRITE(10,992) T, (NmlcV(i),i=1,NVAR) + + END DO kron +!~~~> TIME loop ends + + WRITE(6,991) T,(SPC_NAMES(i), NmlcV(i), i=1,NVAR) + + CLOSE(10) + +991 FORMAT('T=',F12.3,20(A,'=',I5,'; ')) +992 FORMAT(E24.14,200(1X,I12)) + + +END PROGRAM KPP_ROOT_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_tlm.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_tlm.f90 new file mode 100755 index 00000000..ca45be21 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/general_tlm.f90 @@ -0,0 +1,100 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Driver for the tangent linear model (TLM) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +PROGRAM KPP_ROOT_TLM_Driver + + USE KPP_ROOT_Model + USE KPP_ROOT_Initialize, ONLY: Initialize + + KPP_REAL :: T, DVAL(NSPEC) + INTEGER :: i, j, ind_1 = 1, ind_2 = 2 + ! INTEGER :: ind_1 = ind_NO2, ind_2 = ind_O3 + +! --- Number of sensitivity coefficients to compute +! --- Note: this value is set for sensitivities w.r.t. all initial values +! --- it may have to be changed for other applications + INTEGER NTLM + PARAMETER (NTLM = 2) + KPP_REAL Y_TLM(NVAR,NTLM) + +! ---- TIME VARIABLES ------------------ + + STEPMIN = 0.0d0 + STEPMAX = 0.0d0 + + DO i=1,NVAR + RTOL(i) = 1.0d-4 + ATOL(i) = 1.0d-2 + END DO + + CALL Initialize() +!~~~> Note: the initial values below are for sensitivities +! w.r.t. initial values; +! they have to be changed for other applications + DO j=1,NTLM + DO i=1,NVAR + Y_TLM(i,j) = 0.0d0 + END DO + END DO + Y_TLM(ind_1,1) = 1.0d0 + Y_TLM(ind_2,2) = 1.0d0 + +! ~~~~~~~~~ BEGIN TIME LOOP ~~~~~~~~~~ + + CALL InitSaveData() + + T = TSTART + +kron: DO WHILE (T < TEND) + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR),& + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + + CALL INTEGRATE_TLM( NTLM, VAR, Y_TLM, T, T+DT ) + + T = T+DT + + END DO kron + + CALL GetMass( C, DVAL ) + WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T, & + (TRIM(SPC_NAMES(MONITOR(i))), & + C(MONITOR(i))/CFACTOR, i=1,NMONITOR), & + (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS) + + CALL SaveData() + +! ~~~~~~~~~ END TIME LOOP ~~~~~~~~~~ + + OPEN(20, FILE='KPP_ROOT_TLM_results.m') + WRITE(6,*) '**************************************************' + WRITE(6,*) ' Concentrations and Sensitivities at final time ' + WRITE(6,*) ' were written in the file KPP_ROOT_TLM_results.m' + WRITE(6,*) '**************************************************' + DO j=1,NTLM + WRITE(20,993) ( Y_TLM(i,j), i=1,NVAR ) + END DO + + CALL CloseSaveData() + + WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_1)), & + Y_TLM(ind_1,1) + WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_2)), & + Y_TLM(ind_2,2) + WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_2)), & + Y_TLM(ind_2,1) + WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_1)), & + Y_TLM(ind_1,2) + + 991 FORMAT(F6.1,'%. T=',E10.3,3X,20(A,'=',E10.4,';',1X)) + 993 FORMAT(1000(E24.16,2X)) + 995 FORMAT('TLM: d[',A,'](tf)/d[',A,'](t0)=',E14.7) + +END PROGRAM KPP_ROOT_TLM_Driver + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.c new file mode 100755 index 00000000..d2ed3653 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.c @@ -0,0 +1,52 @@ +void INTEGRATE( double TIN, double TOUT ); + +void main() +{ +KPP_REAL rtols; +KPP_REAL Tstart, Tend, DT; +FILE * fp; +int i; + +/* ---- TIME VARIABLES ------------------ */ + + rtols = 1e-3; + for( i = 0; i < NVAR; i++ ) { + RTOL[i] = rtols; + ATOL[i] = 1E-18; + } + + Initialize(); + + fp = fopen("Extrapd.m", "w"); + fprintf( fp, "ed=[\n"); + + Tstart = 3600*12; + Tend = Tstart + 3600*24*5; + STEPMIN = 0.001; + STEPMAX = 900; + DT = 3600.; + TEMP = 236.21; + +/* -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- */ +/* ********** TIME LOOP **************************** */ + + TIME = Tstart; + while (TIME <= Tend) { + + printf("\nMonitor: "); + for( i = 0; i < NMONITOR; i++ ) + printf( "%12.8g ", C[ MONITOR[i] ]/CFACTOR ); + + fprintf( fp, "\n%6.1f ", (TIME-Tstart)/3600.0 ); + for( i = 0; i < NLOOKAT; i++ ) + fprintf( fp, "%24.16e ", C[ LOOKAT[i] ]/CFACTOR ); + + INTEGRATE( DT ); + } + +/* *********** END TIME LOOP *********************** */ + + fprintf(fp, "\n];"); + fclose( fp ); + printf("\n"); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.f new file mode 100755 index 00000000..4f9cbb0f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/main.f @@ -0,0 +1,53 @@ + PROGRAM driver + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + INTEGER i + +C ---- TIME VARIABLES ------------------ + + RTOLS = 1e-3 + do i=1,NVAR + RTOL(i) = RTOLS + ATOL(i) = 1E-18 + end do + + CALL Initialize() + + open(10, file='Extrapd.m') + write(10,*) 'ed=[' + + TSTART = 3600*12 + TEND = TSTART + 3600*24*5 + STEPMIN = 0.01 + STEPMAX = 900 + DT = 3600. + TEMP = 236.21 + +C -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- +C ********** TIME LOOP ************************* + TIME = TSTART + do while (TIME .le. TEND) + + write(6,991) (C(MONITOR(i))/CFACTOR, i=1,NMONITOR) + + write(10,992) (TIME-TSTART)/3600.D0, + * (C(LOOKAT(i))/CFACTOR, i=1,NLOOKAT) + + call Update_SUN() + call Update_RCONST() + + call INTEGRATE( TIME, TIME+DT ) + + end do +C *********** END TIME LOOP ******** + + write(10,*) '];' + close(10) + STOP + +991 FORMAT('Monitor:',10(1X,E12.6)) +992 FORMAT(F6.1,100(1X,D24.16)) + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.c new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.f new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/drv/none.f90 new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/Makefile_caca b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/Makefile_caca new file mode 100755 index 00000000..c8195e2d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/Makefile_caca @@ -0,0 +1,103 @@ +# Set here the desired C compiler and its optimization options +CC = gcc +COPT = -O -Wall + +# To create Matlab gateway routines +# Note: use $(CC) as the mex C compiler +MEX = mex + +HEADERS = caca_Global.h caca_Parameters.h caca_Sparse.h + +SPSRC = caca_JacobianSP.c \ + caca_HessianSP.c \ + caca_StoichiomSP.c + +SPOBJ = caca_JacobianSP.o \ + caca_HessianSP.o \ + caca_StoichiomSP.o + + +SRC = caca_Main.c caca_Integrator.c \ + caca_Function.c caca_Initialize.c \ + caca_Jacobian.c caca_LinearAlgebra.c\ + caca_Rates.c caca_Hessian.c \ + caca_Stoichiom.c caca_Util.c \ + caca_Monitor.c + +OBJ = caca_Main.o caca_Integrator.o \ + caca_Function.o caca_Initialize.o \ + caca_Jacobian.o caca_LinearAlgebra.o\ + caca_Rates.o caca_Hessian.o \ + caca_Stoichiom.o caca_Util.o \ + caca_Monitor.o + +STOCHSRC = caca_Stochastic.c +STOCHOBJ = caca_Stochastic.o + +all: exe + +exe: $(HEADERS) $(SPOBJ) $(OBJ) + $(CC) $(COPT) $(SPOBJ) $(OBJ) -lm -o caca.exe + +stochastic:$(HEADERS) $(SPOBJ) $(OBJ) $(STOCHOBJ) + $(CC) $(COPT) $(SPOBJ) $(OBJ) $(STOCHOBJ) -lm \ + -o caca_stochastic.exe + +mex: $(HEADERS) $(SPOBJ) $(OBJ) + $(MEX) CC#$(CC) -O caca_mex_Fun.c -lm $(SPOBJ) $(OBJ) + $(MEX) CC#$(CC) -O caca_mex_Jac_SP.c -lm $(SPOBJ) $(OBJ) + $(MEX) CC#$(CC) -O caca_mex_Hessian.c -lm $(SPOBJ) $(OBJ) + + +clean: + rm -f $(SPOBJ) $(OBJ) caca.exe caca_*.mexglx caca*.dat + +distclean: + rm -f $(SPOBJ) $(OBJ) caca.exe caca*.dat \ + caca_*.c caca_*.h caca_*.map caca_*.mexglx + +caca_Monitor.o: caca_Monitor.c $(HEADERS) + $(CC) $(COPT) -c $< + +caca_JacobianSP.o: caca_JacobianSP.c $(HEADERS) + $(CC) $(COPT) -c $< + +caca_HessianSP.o: caca_HessianSP.c $(HEADERS) + $(CC) $(COPT) -c $< + +caca_StoichiomSP.o: caca_StoichiomSP.c $(HEADERS) + $(CC) $(COPT) -c $< + +caca_Main.o: caca_Main.c caca_Initialize.o $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Integrator.o: caca_Integrator.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Initialize.o: caca_Initialize.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Function.o: caca_Function.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Stochastic.o: caca_Stochastic.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Jacobian.o: caca_Jacobian.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_LinearAlgebra.o: caca_LinearAlgebra.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Rates.o: caca_Rates.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Hessian.o: caca_Hessian.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Stoichiom.o: caca_Stoichiom.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + +caca_Util.o: caca_Util.c $(HEADERS) $(SPOBJ) + $(CC) $(COPT) -c $< + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi.kpp new file mode 100755 index 00000000..9d17b03d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR radau5 +#LANGUAGE Fortran77 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi90.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi90.kpp new file mode 100755 index 00000000..9a6b0ee6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimi90.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock +#LANGUAGE Fortran90 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimiadj.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimiadj.kpp new file mode 100755 index 00000000..2eb60c91 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimiadj.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock_symmetric +#LANGUAGE Fortran90 +#DRIVER general_complete +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimic.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimic.kpp new file mode 100755 index 00000000..c43ead1d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimic.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock +#LANGUAGE C +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimim.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimim.kpp new file mode 100755 index 00000000..cbddbe9b --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimim.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR none +#LANGUAGE Matlab +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimitlm.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimitlm.kpp new file mode 100755 index 00000000..4488094f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/mimitlm.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock_tlm +#LANGUAGE Fortran90 +#DRIVER general_tlm +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/radau90.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/radau90.kpp new file mode 100755 index 00000000..48a727af --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/radau90.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR radau5 +#LANGUAGE Fortran90 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/readme b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/readme new file mode 100755 index 00000000..7840d10c --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/readme @@ -0,0 +1,19 @@ +{To specify a KPP model build a *.kpp file with the following lines:} + +{Choose any model defined in $KPP_HOME/models} +#MODEL small_strato + +{Choose any integrator defined in $KPP_HOME/int} +#INTEGRATOR none + +{Choose the output language in which KPP will generate the model} +#LANGUAGE [ Fortran77 | Fortran90 | C | Matlab ] + +{Choose any driver file defined in $KPP_HOME/drv} +#DRIVER general + +{Hessian} +#HESSIAN [ ON | OFF ] + +{Stoichiometric matrix} +#STOICMAT [ ON | OFF ] diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/reference.data b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/reference.data new file mode 100755 index 00000000..b1b74882 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/reference.data @@ -0,0 +1,5 @@ + 0.14114622553923E+03 + 0.94756372630086E+09 + 0.76158432350214E+12 + 0.91333772527588E+09 + 0.18316224272450E+09 diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/rosenbrock90.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/rosenbrock90.kpp new file mode 100755 index 00000000..9a6b0ee6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/rosenbrock90.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock +#LANGUAGE Fortran90 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_c.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_c.kpp new file mode 100755 index 00000000..c43ead1d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_c.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock +#LANGUAGE C +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f77.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f77.kpp new file mode 100755 index 00000000..ce241c4d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f77.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR kpp_ros4 +#LANGUAGE Fortran77 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f90.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f90.kpp new file mode 100755 index 00000000..9a6b0ee6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_f90.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR rosenbrock +#LANGUAGE Fortran90 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_m.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_m.kpp new file mode 100755 index 00000000..cbddbe9b --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/saprc_m.kpp @@ -0,0 +1,6 @@ +#MODEL saprc99 +#INTEGRATOR none +#LANGUAGE Matlab +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_c.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_c.kpp new file mode 100755 index 00000000..c2e0fa04 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_c.kpp @@ -0,0 +1,6 @@ +#MODEL small_strato +#INTEGRATOR rosenbrock +#LANGUAGE C +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f77.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f77.kpp new file mode 100755 index 00000000..42f55857 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f77.kpp @@ -0,0 +1,6 @@ +#MODEL small_strato +#INTEGRATOR rosenbrock +#LANGUAGE Fortran77 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f90.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f90.kpp new file mode 100755 index 00000000..a7d99e19 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_f90.kpp @@ -0,0 +1,6 @@ +#MODEL small_strato +#INTEGRATOR rosenbrock +#LANGUAGE Fortran90 +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_m.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_m.kpp new file mode 100755 index 00000000..88ed8d0f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/examples/small_m.kpp @@ -0,0 +1,6 @@ +#MODEL small_strato +#INTEGRATOR none +#LANGUAGE Matlab +#DRIVER general +#HESSIAN on +#STOICMAT on diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/gpl/gpl.txt b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/gpl/gpl.txt new file mode 100755 index 00000000..2f3669ea --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/gpl/gpl.txt @@ -0,0 +1,313 @@ +****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free + Software Foundation (http://www.gnu.org/copyleft/gpl.html); either + version 2 of the License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + A copy of the GNU General Public License could be found below; you + could also consult http://www.gnu.org/copyleft/gpl.html or write to the + Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +****************************************************************************** + + + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.def new file mode 100755 index 00000000..16dee74d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_seulex + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.f90 new file mode 100755 index 00000000..74059588 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/kpp_seulex.f90 @@ -0,0 +1,1169 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! SEULEX - Stiff extrapolation method based on linearly implicit Euler ! +! By default the code employs the KPP sparse linear algebra routines ! +! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! + +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision, ONLY: dp + USE KPP_ROOT_Jacobian, ONLY: NVAR, LU_NONZERO, LU_DIAG +!! USE KPP_ROOT_LinearAlgebra + + IMPLICIT NONE + PUBLIC + SAVE + + ! variables from the former COMMON block /CONRA5/ are now here: + INTEGER :: NN, NN2, NN3, NN4 + KPP_REAL :: TSOL, HSOL + + ! Statistics + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + + ! Method parameters + + ! mz_rs_20050717: TODO: use strings of IERR_NAMES for error messages + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-4:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -4 + 'Step size too small ', & ! -3 + 'More than Max_no_steps steps are needed ', & ! -2 + 'Insufficient storage for work or iwork ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_INTEGRATE( TIN, TOUT, & + FIX, VAR, RCONST, ATOL, RTOL, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters, ONLY: nvar +!! USE KPP_ROOT_Global, ONLY: atol,rtol,var + + IMPLICIT NONE + + KPP_REAL, INTENT(INOUT), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(INOUT), DIMENSION(NVAR) :: VAR + KPP_REAL, INTENT(IN), DIMENSION(NSPEC) :: ATOL, RTOL + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + + KPP_REAL :: TIN ! TIN - Start Time + KPP_REAL :: TOUT ! TOUT - End Time + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + INTEGER :: Ncolumns, Ncolumns2, NRDENS + PARAMETER (Ncolumns=12,Ncolumns2=2+Ncolumns*(Ncolumns+3)/2,NRDENS=NVAR) + + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + INTEGER :: IERR + INTEGER, SAVE :: Ntotal = 0 + KPP_REAL, SAVE :: H + + H = 0.0_dp + + ICNTRL(1:20) = 0 + RCNTRL(1:20) = 0._dp + ICNTRL(10)=0 !~~~> OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + + ! if optional parameters are given, and if they are >0, + ! they overwrite the default settings + IF (PRESENT(ICNTRL_U)) ICNTRL(:) = ICNTRL_U(:) + IF (PRESENT(RCNTRL_U)) RCNTRL(:) = RCNTRL_U(:) + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~----- + + + CALL ATMSEULEX(NVAR,TIN,TOUT,VAR,H,RTOL,ATOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + Ntotal = Ntotal + Nstp +!!$ PRINT*,'NSTEPS=',Nstp,' (',Ntotal,') T=',TIN + + + Nfun = Nfun + ISTATUS(1) + Njac = Njac + ISTATUS(2) + Nstp = Nstp + ISTATUS(3) + Nacc = Nacc + ISTATUS(4) + Nrej = Nrej + ISTATUS(5) + Ndec = Ndec + ISTATUS(6) + Nsol = Nsol + ISTATUS(7) + + ! if optional parameters are given for output + ! use them to store information in them + IF (PRESENT(ISTATUS_U)) THEN + ISTATUS_U(:) = 0 + ISTATUS_U(1) = Nfun ! function calls + ISTATUS_U(2) = Njac ! jacobian calls + ISTATUS_U(3) = Nstp ! steps + ISTATUS_U(4) = Nacc ! accepted steps + ISTATUS_U(5) = Nrej ! rejected steps (except at the beginning) + ISTATUS_U(6) = Ndec ! LU decompositions + ISTATUS_U(7) = Nsol ! forward/backward substitutions + ENDIF + IF (PRESENT(RSTATUS_U)) THEN + RSTATUS_U(:) = 0. + RSTATUS_U(1) = TOUT ! final time + ENDIF + IF (PRESENT(IERR_U)) IERR_U = IERR + +! mz_rs_20050716: IERR is returned to the user who then decides what to do +! about it, i.e. either stop the run or ignore it. +!!$ IF (IERR < 0) THEN +!!$ PRINT *,'SEULEX: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' +!!$ STOP +!!$ ENDIF + + END SUBROUTINE KPP_ROOT_ INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ATMSEULEX( N,Tinitial,Tfinal,Y,H,RelTol,AbsTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +! SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(T,Y). +! THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE +! LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL +! AND ORDER SELECTION). +! +! AUTHORS: E. HAIRER AND G. WANNER +! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +! CH-1211 GENEVE 24, SWITZERLAND +! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +! INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN +! +! THIS CODE IS PART OF THE BOOK: +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, +! SPRINGER-VERLAG (1991) +! +! VERSION OF SEPTEMBER 30, 1995 +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! INPUT PARAMETERS +! ---------------- +! N DIMENSION OF THE SYSTEM +! +! T INITIAL T-VALUE +! +! Y(N) INITIAL VALUES FOR Y +! +! Tend FINAL T-VALUE (Tend-T MAY BE POSITIVE OR NEGATIVE) +! +! H INITIAL STEP SIZE GUESS; +! FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, +! H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. +! THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY +! ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6 +! +! RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY +! CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. +! +! JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +! THE PARTIAL DERIVATIVES OF F(T,Y) WITH RESPECT TO Y +! +! SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE +! NUMERICAL SOLUTION DURING INTEGRATION. +! IF IOUT>=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. +! SUPPLY A DUMMY SUBROUTINE IF IOUT=0. +! IT MUST HAVE THE FORM +! SUBROUTINE SOLOUT (NR,TOLD,T,Y,RC,LRC,IC,LIC,N, +! RPAR,IPAR,IRTRN) +! KPP_REAL T,Y(N),RC(LRC),IC(LIC) +! .... +! SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH +! GRID-POINT "T" (THEREBY THE INITIAL VALUE IS +! THE FIRST GRID-POINT). +! "TOLD" IS THE PRECEEDING GRID-POINT. +! "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN +! IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM. +! DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)! +! +! ----- CONTINUOUS OUTPUT (IF IOUT=2): ----- +! DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION +! FOR THE INTERVAL [TOLD,T] IS AVAILABLE THROUGH +! THE KPP_REAL FUNCTION +! >>> CONTEX(I,S,RC,LRC,IC,LIC) <<< +! WHICH PROVIDES AN APPROXIMATION TO THE I-TH +! COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE +! S SHOULD LIE IN THE INTERVAL [TOLD,T]. +! +! IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: +! IOUT=0: SUBROUTINE IS NEVER CALLED +! IOUT=1: SUBROUTINE IS USED FOR OUTPUT +! IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! SOPHISTICATED SETTING OF PARAMETERS +! ----------------------------------- +! SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT CNTRL +! WELL. THEY MAY BE DEFINED BY SETTING CNTRL(1),..,CNTRL(13) +! AS WELL AS ICNTRL(1),..,ICNTRL(4) DIFFERENT FROM ZERO. +! FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: +! +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +!~~~> +! ICNTRL(1) = 1: F = F(y) Independent of T (autonomous) +! = 0: F = F(t,y) Depends on T (non-autonomous) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> not used +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0 the default value of 100000 is used +! +! ICNTRL(11) THE MAXIMUM NUMBER OF COLUMNS IN THE EXTRAPOLATION +! TABLE. THE DEFAULT VALUE (FOR ICNTRL(3)=0) IS 12. +! IF ICNTRL(3).NE.0 THEN ICNTRL(3) SHOULD BE >= 3. +! +! ICNTRL(12) SWITCH FOR THE STEP SIZE SEQUENCE +! IF ICNTRL(4) == 1 THEN 1,2,3,4,6,8,12,16,24,32,48,... +! IF ICNTRL(4) == 2 THEN 2,3,4,6,8,12,16,24,32,48,64,... +! IF ICNTRL(4) == 3 THEN 1,2,3,4,5,6,7,8,9,10,... +! IF ICNTRL(4) == 4 THEN 2,3,4,5,6,7,8,9,10,11,... +! THE DEFAULT VALUE (FOR ICNTRL(4)=0) IS ICNTRL(4)=2. +! +! ICNTRL(13) PARAMETER "LAMBDA" OF DENSE OUTPUT; POSSIBLE VALUES +! ARE 0 AND 1; DEFAULT ICNTRL(5)=0. +! +! ICNTRL(14) = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT +! IS REQUIRED +! +! ICNTRL(21),...,ICNTRL(NRDENS+20) INDICATE THE COMPONENTS, FOR WHICH +! DENSE OUTPUT IS REQUIRED +! +!~~~> Real parameters +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller +! than ThetaMin the Jacobian is not recomputed; +! (default=0.001). Increase cntrl(3), to 0.01 say, when +! Jacobian evaluations are costly. for small systems it +! should be smaller. +! RCNTRL(9) -> not used +! RCNTRL(10,11) -> FAC1,FAC2 (parameters for step size selection) +! RCNTRL(12,13) -> FAC3,FAC4 (parameters for order selection) +! RCNTRL(14,15) -> FacSafe1, FacSafe2 +! Safety factors for step size prediction +! HNEW=H*FacSafe2*(FacSafe1*TOL/ERR)**(1/(J-1)) +! RCNTRL(16:19) -> WorkFcn, WorkJac, WorkDec, WorkSol +! estimated computational work +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! OUTPUT PARAMETERS +! ----------------- +! T T-VALUE WHERE THE SOLUTION IS COMPUTED +! (AFTER SUCCESSFUL RETURN T=Tend) +! +! Y(N) SOLUTION AT T +! +! H PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! DECLARATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: N, IERR, ITOL, Max_no_steps, Ncolumns, Nsequence, Lambda, & + NRDENS, i, Ncolumns2, NRD, IOUT + KPP_REAL :: Y(NVAR),AbsTol(*),RelTol(*) + KPP_REAL :: Tinitial, Tfinal, Roundoff, Hmin, Hmax, & + FacMin, FacMax, FAC1, FAC2, FAC3, FAC4, FacSafe1, & + FacSafe2, H, Hstart,WorkFcn,WorkJac, WorkDec, WorkSol,& + WorkRow, FacRej, FacSafe, ThetaMin, T + LOGICAL :: AUTNMS + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SETTING THE PARAMETERS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Nfun=0 + Njac=0 + Nstp=0 + Nacc=0 + Nrej=0 + Ndec=0 + Nsol=0 + + IERR = 0 + + IF (ICNTRL(1) == 0) THEN + AUTNMS = .FALSE. + ELSE + AUTNMS = .TRUE. + END IF + +!~~~> For Scalar tolerances (ICNTRL(1)/=0) the code uses AbsTol(1) and RelTol(1) +!~~~> For Vector tolerances (ICNTRL(1)==0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + ITOL = 1 + ELSE + ITOL = 0 + END IF + +!~~~> Max_no_steps: the maximum number of time steps admitted + IF (ICNTRL(4) == 0) THEN + Max_no_steps = 100000 + ELSEIF (ICNTRL(4) > 0) THEN + Max_no_steps=ICNTRL(4) + ELSE + PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) + CALL SEULEX_ErrorMsg(-1,Tinitial,ZERO,IERR); + END IF + +!~~~> IOUT = use (or not) the output routine + IOUT = ICNTRL(10) + IF ( IOUT<0 .OR. IOUT>2 ) THEN + PRINT * ,'User-selected ICNTRL(10)=',ICNTRL(10) + IOUT = 0 + END IF + +!~~~> Ncolumns: maximum number of columns in the extrapolation + IF (ICNTRL(11)==0) THEN + Ncolumns=12 + ELSEIF (ICNTRL(11) > 2) THEN + Ncolumns=ICNTRL(11) + ELSE + PRINT * ,'User-selected ICNTRL(11)=',ICNTRL(11) + CALL SEULEX_ErrorMsg(-2,Tinitial,ZERO,IERR); + END IF + +!~~~> Nsequence: choice of step size sequence + IF (ICNTRL(12)==0) THEN + Nsequence = 2 + ELSEIF ( (ICNTRL(12)>0).AND.(ICNTRL(12)<5) ) THEN + Nsequence = ICNTRL(4) + ELSE + PRINT * ,'User-selected ICNTRL(12)=',ICNTRL(12) + CALL SEULEX_ErrorMsg(-3,Tinitial,ZERO,IERR) + END IF + +!~~~> LAMBDA: parameter for dense output + LAMBDA = ICNTRL(13) + IF ( LAMBDA < 0 .OR. LAMBDA >= 2 ) THEN + PRINT * ,'User-selected ICNTRL(13)=',ICNTRL(13) + CALL SEULEX_ErrorMsg(-4,Tinitial,ZERO,IERR) + END IF + +!~~~>- NRDENS: number of dense output components + NRDENS=ICNTRL(14) + IF ( (NRDENS < 0) .OR. (NRDENS > N) ) THEN + PRINT * ,'User-selected ICNTRL(14)=',ICNTRL(14) + CALL SEULEX_ErrorMsg(-5,Tinitial,ZERO,IERR) + END IF + + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tfinal-Tinitial) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,Roundoff) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + + +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 10.0_dp + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> ThetaMin: DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; +! INCREASE WORK(3), TO 0.01 SAY, WHEN JACOBIAN EVALUATIONS +! ARE COSTLY. FOR SMALL SYSTEMS WORK(3) SHOULD BE SMALLER. + IF(RCNTRL(8) == 0.D0)THEN + ThetaMin = 1.0d-3 + ELSE + ThetaMin = RCNTRL(8) + END IF + +!~~~> FAC1,FAC2: PARAMETERS FOR STEP SIZE SELECTION +! THE NEW STEP SIZE FOR THE J-TH DIAGONAL ENTRY IS +! CHOSEN SUBJECT TO THE RESTRICTION +! FACMIN/WORK(5) <= HNEW(J)/HOLD <= 1/FACMIN +! WHERE FACMIN=WORK(4)**(1/(J-1)) + IF(RCNTRL(10) == 0.D0)THEN + FAC1=0.1D0 + ELSE + FAC1=RCNTRL(10) + END IF + IF(RCNTRL(11) == 0.D0)THEN + FAC2=4.0D0 + ELSE + FAC2=RCNTRL(11) + END IF +!~~~> FAC3, FAC4: PARAMETERS FOR THE ORDER SELECTION +! ORDER IS DECREASED IF W(K-1) <= W(K)*WORK(6) +! ORDER IS INCREASED IF W(K) <= W(K-1)*WORK(7) + IF(RCNTRL(12) == 0.D0)THEN + FAC3=0.7D0 + ELSE + FAC3=RCNTRL(12) + END IF + IF(RCNTRL(13) == 0.D0)THEN + FAC4=0.9D0 + ELSE + FAC4=RCNTRL(13) + END IF +!~~~>- FacSafe1, FacSafe2: safety factors for step size prediction +! HNEW=H*WORK(9)*(WORK(8)*TOL/ERR)**(1/(J-1)) + IF(RCNTRL(14) == 0.D0)THEN + FacSafe1=0.6D0 + ELSE + FacSafe1=RCNTRL(14) + END IF + IF(RCNTRL(15) == 0.D0)THEN + FacSafe2=0.93D0 + ELSE + FacSafe2=RCNTRL(15) + END IF + +!~~~> WorkFcn: estimated computational work for a calls to FCN + IF(RCNTRL(16) == 0.D0)THEN + WorkFcn=1.D0 + ELSE + WorkFcn=RCNTRL(16) + END IF +!~~~> WorkJac: estimated computational work for calls to JAC + IF(RCNTRL(17) == 0.D0)THEN + WorkJac=5.D0 + ELSE + WorkJac=RCNTRL(17) + END IF +!~~~> WorkDec: estimated computational work for calls to DEC + IF(RCNTRL(18) == 0.D0)THEN + WorkDec=1.D0 + ELSE + WorkDec=RCNTRL(18) + END IF +!~~~> WorkSol: estimated computational work for calls to SOL + IF(RCNTRL(19) == 0.D0)THEN + WorkSol=1.D0 + ELSE + WorkSol=RCNTRL(19) + END IF + WorkRow=WorkFcn+WorkSol + +!~~~> Check if tolerances are reasonable + IF (ITOL == 0) THEN + IF (AbsTol(1) <= 0.D0.OR.RelTol(1) <= 10.D0*Roundoff) THEN + PRINT * , ' Scalar AbsTol = ',AbsTol(1) + PRINT * , ' Scalar RelTol = ',RelTol(1) + CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) + END IF + ELSE + DO i=1,N + IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) + END IF + END DO + END IF + + IF (IERR < 0) RETURN + +!~~~>---- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- + Ncolumns2=(Ncolumns*(Ncolumns+1))/2 + NRD=MAX(1,NRDENS) + + T = Tinitial +!~~~> CALL TO CORE INTEGRATOR + CALL SEULEX_Integrator(N,T,Tfinal,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL, & + IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & + FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & + WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) + + ISTATUS(1)=Nfun + ISTATUS(2)=Njac + ISTATUS(3)=Nstp + ISTATUS(4)=Nacc + ISTATUS(5)=Nrej + ISTATUS(6)=Ndec + ISTATUS(7)=Nsol + + END SUBROUTINE KPP_ROOT_ATMSEULEX + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_SEULEX_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from SEULEX due to the following error:' + + SELECT CASE (Code) + CASE (-1) + PRINT * , '--> Improper value for maximal no of steps' + CASE (-2) + PRINT * , '--> Improper value for maximum no of columns in extrapolation' + CASE (-3) + PRINT * , '--> Improper value for step size sequence' + CASE (-4) + PRINT * , '--> Improper value for Lambda (must be 0/1)' + CASE (-5) + PRINT * , '--> Improper number of dense output components' + CASE (-6) + PRINT * , '--> Improper parameters for second order equations' + CASE (-7) + PRINT * , '--> Hmin/Hmax/Hstart must be positive' + CASE (-8) + PRINT * , '--> FacMin/FacMax/FacRej must be positive' + CASE (-9) + PRINT * , '--> Improper tolerance values' + CASE (-10) + PRINT * , '--> No of steps exceeds maximum bound' + CASE (-11) + PRINT * , '--> Step size too small: T + 10*H = T', & + ' or H < Roundoff' + CASE (-12) + PRINT * , '--> Matrix is repeatedly singular' + CASE DEFAULT + PRINT *, 'Unknown Error code: ', Code + END SELECT + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE KPP_ROOT_SEULEX_ErrorMsg + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_SEULEX_Integrator(N,T,Tend,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL,& + IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & + FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & + WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! CORE INTEGRATOR FOR SEULEX +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! DECLARATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + USE KPP_ROOT_Jacobian + IMPLICIT KPP_REAL (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + INTEGER :: N, Ncolumns, Ncolumns2, K, KC, KRIGHT, KLR, KK, KRN,& + KOPT, NRD + KPP_REAL :: Y(NVAR),DY(NVAR),FX(NVAR),YHH(NVAR) + KPP_REAL :: DYH(NVAR), DEL(NVAR), WH(NVAR) + KPP_REAL :: SCAL(NVAR), HH(Ncolumns), W(Ncolumns), A(Ncolumns) +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO) +#endif + KPP_REAL Table(Ncolumns,N) + INTEGER IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) + KPP_REAL RelTol(*),AbsTol(*) + KPP_REAL FSAFE(Ncolumns2,NRD),FACUL(Ncolumns),E(N,N),DENS((Ncolumns+2)*NRD) + LOGICAL REJECT,LAST,ATOV,CALJAC,CALHES,AUTNMS + + KPP_REAL TOLDD,HHH,NNRD + COMMON /COSEU/TOLDD,HHH,NNRD,KRIGHT + +!~~~> COMPUTE COEFFICIENTS FOR DENSE OUTPUT + IF (IOUT == 2) THEN + NNRD=NRD +!~~~> COMPUTE THE FACTORIALS -------- + FACUL(1)=1.D0 + DO i=1,Ncolumns-1 + FACUL(i+1)=i*FACUL(i) + END DO + END IF + +!~~~> DEFINE THE STEP SIZE SEQUENCE + IF (Nsequence == 1) THEN + NJ(1)=1 + NJ(2)=2 + NJ(3)=3 + DO I=4,Ncolumns + NJ(i)=2*NJ(I-2) + END DO + END IF + IF (Nsequence == 2) THEN + NJ(1)=2 + NJ(2)=3 + DO I=3,Ncolumns + NJ(i)=2*NJ(I-2) + END DO + END IF + DO i=1,Ncolumns + IF (Nsequence == 3) NJ(i)=I + IF (Nsequence == 4) NJ(i)=I+1 + END DO + A(1)=WorkJac+NJ(1)*WorkRow+WorkDec + DO I=2,Ncolumns + A(i)=A(i-1)+(NJ(i)-1)*WorkRow+WorkDec + END DO + K=MAX0(3,MIN0(Ncolumns-2,INT(-DLOG10(RelTol(1)+AbsTol(1))*.6D0+1.5D0))) + + ! T = Tinitial + HmaxN = MIN(ABS(Hmax),ABS(Tend-T)) + IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 + H=MIN(ABS(H),HmaxN) + Theta=2*ABS(ThetaMin) + ERR=0.D0 + W(1)=1.D30 + DO i=1,N + IF (ITOL == 0) THEN + SCAL(i)=AbsTol(1)+RelTol(1)*DABS(Y(i)) + ELSE + SCAL(i)=AbsTol(i)+RelTol(i)*DABS(Y(i)) + END IF + END DO + CALJAC=.FALSE. + REJECT=.FALSE. + LAST=.FALSE. + 10 CONTINUE + IF (REJECT) Theta=2*ABS(ThetaMin) + ATOV=.FALSE. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> IS Tend REACHED IN THE NEXT STEP? +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + H1=Tend-T + IF (H1 <= Roundoff) GO TO 110 + HOPT=H + H=MIN(H,H1,HmaxN) + IF (H >= H1-Roundoff) LAST=.TRUE. + IF (AUTNMS) THEN + CALL FUN_CHEM(T,Y,DY) + END IF + IF (Theta > ThetaMin.AND..NOT.CALJAC) THEN +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! COMPUTATION OF THE JACOBIAN +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + CALL JAC_CHEM(T,Y,FJAC) + CALJAC=.TRUE. + CALHES=.FALSE. + END IF +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> THE FIRST AND LAST STEP +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (Nstp == 0.OR.LAST) THEN + IPT=0 + Nstp=Nstp+1 + DO J=1,K + KC=J + CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns, & + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,FAC, & + FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol, & + ERROLD,IPHES,ICOMP,AUTNMS,REJECT, & + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + IF (J > 1 .AND. ERR <= 1.d0) GOTO 60 + END DO + GO TO 55 + END IF +!~~~> BASIC INTEGRATION STEP + 30 CONTINUE + IPT=0 + Nstp=Nstp+1 + IF (Nstp >= Max_no_steps) GOTO 120 + KC=K-1 + DO J=1,KC + CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + END DO +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> CONVERGENCE MONITOR +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (K == 2.OR.REJECT) GO TO 50 + IF (ERR <= 1.D0) GO TO 60 + IF (ERR > DBLE(NJ(K+1)*NJ(K))*4.D0) GO TO 100 + 50 CALL SEUL(K,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + KC=K + IF (ERR <= 1.D0) GO TO 60 +!~~~> HOPE FOR CONVERGENCE IN LINE K+1 + 55 IF (ERR > DBLE(NJ(K+1))*2.D0) GO TO 100 + KC=K+1 + CALL SEUL(KC,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + IF (ERR > 1.D0) GO TO 100 + !Adi IF ((ERR > 1.D0).and.(H.gt.Hmin)) GO TO 100 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STEP IS ACCEPTED +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 60 TOLD=T + T=T+H + IF (IOUT == 2) THEN + KRIGHT=KC + DO i=1,NRD + DENS(i)=Y(ICOMP(i)) + END DO + END IF + DO i=1,N + T1I=Table(1,I) + IF (ITOL == 0) THEN + SCAL(i)=AbsTol(1)+RelTol(1)*DABS(T1I) + ELSE + SCAL(i)=AbsTol(i)+RelTol(i)*DABS(T1I) + END IF + Y(i)=T1I + END DO + Nacc=Nacc+1 + CALJAC=.FALSE. + IF (IOUT == 2) THEN + TOLDD=TOLD + HHH=H + DO i=1,NRD + DENS(NRD+I)=Y(ICOMP(i)) + END DO + DO KLR=1,KRIGHT-1 +!~~~> COMPUTE DIFFERENCES + IF (KLR >= 2) THEN + DO KK=KLR,KC + LBEG=((KK+1)*KK)/2 + LEND=LBEG-KK+2 + DO L=LBEG,LEND,-1 + DO i=1,NRD + FSAFE(L,I)=FSAFE(L,I)-FSAFE(L-1,I) + END DO + END DO + END DO + END IF +!~~~> COMPUTE DERIVATIVES AT RIGHT END ---- + DO KK=KLR+LAMBDA,KC + FACNJ=NJ(KK) + FACNJ=FACNJ**KLR/FACUL(KLR+1) + IPT=((KK+1)*KK)/2 + DO I=1,NRD + KRN=(KK-LAMBDA+1)*NRD + DENS(KRN+I)=FSAFE(IPT,I)*FACNJ + END DO + END DO + DO J=KLR+LAMBDA+1,KC + DBLENJ=NJ(J) + DO L=J,KLR+LAMBDA+1,-1 + FACTOR=DBLENJ/NJ(L-1)-1.D0 + DO i=1,NRD + KRN=(L-LAMBDA+1)*NRD+I + DENS(KRN-NRD)=DENS(KRN)+(DENS(KRN)-DENS(KRN-NRD))/FACTOR + END DO + END DO + END DO + END DO +!~~~> COMPUTE THE COEFFICIENTS OF THE INTERPOLATION POLYNOMIAL + DO IN=1,NRD + DO J=1,KRIGHT + II=NRD*J+IN + DENS(II)=DENS(II)-DENS(II-NRD) + END DO + END DO + END IF +!~~~> COMPUTE OPTIMAL ORDER + IF (KC == 2) THEN + KOPT=3 + IF (REJECT) KOPT=2 + GO TO 80 + END IF + IF (KC <= K) THEN + KOPT=KC + IF (W(KC-1) < W(KC)*FAC3) KOPT=KC-1 + IF (W(KC) < W(KC-1)*FAC4) KOPT=MIN0(KC+1,Ncolumns-1) + ELSE + KOPT=KC-1 + IF (KC > 3.AND.W(KC-2) < W(KC-1)*FAC3) KOPT=KC-2 + IF (W(KC) < W(KOPT)*FAC4) KOPT=MIN0(KC,Ncolumns-1) + END IF +!~~~> AFTER A REJECTED STEP + 80 IF (REJECT) THEN + K=MIN0(KOPT,KC) + H=MIN(H,HH(K)) + REJECT=.FALSE. + GO TO 10 + END IF +!~~~> COMPUTE STEP SIZE FOR NEXT STEP + IF (KOPT <= KC) THEN + H=HH(KOPT) + ELSE + IF (KC < K.AND.W(KC) < W(KC-1)*FAC4) THEN + H=HH(KC)*A(KOPT+1)/A(KC) + ELSE + H=HH(KC)*A(KOPT)/A(KC) + END IF + END IF + K=KOPT + !Adi H = MAX(H, Hmin) + GO TO 10 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STEP IS REJECTED +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 100 K=MIN0(K,KC) + IF (K > 2.AND.W(K-1) < W(K)*FAC3) K=K-1 + Nrej=Nrej+1 + H=HH(K) + LAST=.FALSE. + REJECT=.TRUE. + IF (CALJAC) GOTO 30 + GO TO 10 +!~~~> SOLUTION EXIT + 110 CONTINUE + H=HOPT + IERR=1 + RETURN +!~~~> FAIL EXIT + 120 WRITE (6,979) T,H + 979 FORMAT(' EXIT OF SEULEX AT T=',D14.7,' H=',D14.7) + IERR=-1 + RETURN + + + END SUBROUTINE KPP_ROOT_SEULEX_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_SEUL(JJ,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,& + H,Ncolumns,HmaxN,Table,SCAL,NJ,HH,W,A,YH,DYH,DEL,WH,ERR,FacSafe1, & + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP, & + AUTNMS,REJECT,ATOV,FSAFE,Ncolumns2,NRD,IOUT, & + IPT,CALHES) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> THIS SUBROUTINE COMPUTES THE J-TH LINE OF THE +!~~~> EXTRAPOLATION TABLE AND PROVIDES AN ESTIMATE +!~~~> OF THE OPTIMAL STEP SIZE + USE KPP_ROOT_Parameters + USE KPP_ROOT_Jacobian + IMPLICIT KPP_REAL (A-H,O-Z) + IMPLICIT INTEGER (I-N) + INTEGER :: Ncolumns, Ncolumns2, N, NRD + KPP_REAL :: Y(NVAR),YH(NVAR),DY(NVAR),FX(NVAR),DYH(NVAR) + KPP_REAL :: DEL(NVAR),WH(NVAR),SCAL(NVAR),HH(Ncolumns),W(Ncolumns),A(Ncolumns) +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR), E(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO), E(LU_NONZERO) +#endif + KPP_REAL :: Table(Ncolumns,NVAR) + KPP_REAL :: FSAFE(Ncolumns2,NRD) + INTEGER :: IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) + LOGICAL ATOV,REJECT,AUTNMS,CALHES + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! COMPUTE THE MATRIX E AND ITS DECOMPOSITION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + HJ=H/NJ(JJ) + HJI=1.D0/HJ +#ifdef FULL_ALGEBRA + DO j=1,N + DO i=1,N + E(i,j)=-FJAC(i,j) + END DO + E(j,j)=E(j,j)+HJI + END DO + CALL DGETRF(N,N,E,N,IP,ISING) +#else + DO i=1,LU_NONZERO + E(i)=-FJAC(i) + END DO + DO j=1,N + E(LU_DIAG(j))=E(LU_DIAG(j))+HJI + END DO + CALL KppDecomp (E,ISING) +#endif + Ndec=Ndec+1 + IF (ISING.NE.0) GOTO 79 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STARTING PROCEDURE +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (.NOT.AUTNMS) THEN + CALL FUN_CHEM(T+HJ,Y,DY) + END IF + DO i=1,N + YH(i)=Y(i) + DEL(i)=DY(i) + END DO +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) +#else + CALL KppSolve (E,DEL) +#endif + Nsol=Nsol+1 + M=NJ(JJ) + IF (IOUT == 2.AND.M == JJ) THEN + IPT=IPT+1 + DO i=1,NRD + FSAFE(IPT,I)=DEL(ICOMP(i)) + END DO + END IF +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> SEMI-IMPLICIT EULER METHOD +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (M > 1) THEN + DO MM=1,M-1 + DO i=1,N + YH(i)=YH(i)+DEL(i) + END DO + IF (AUTNMS) THEN + CALL FUN_CHEM(T+HJ*MM,YH,DYH) + ELSE + CALL FUN_CHEM(T+HJ*(MM+1),YH,DYH) + END IF + + IF (MM == 1.AND.JJ <= 2) THEN +!~~~> STABILITY CHECK + DEL1=0.D0 + DO i=1,N + DEL1=DEL1+(DEL(i)/SCAL(i))**2 + END DO + DEL1=SQRT(DEL1) + IF (.NOT.AUTNMS) THEN + CALL FUN_CHEM(T+HJ,YH,WH) + + DO i=1,N + DEL(i)=WH(i)-DEL(i)*HJI + END DO + ELSE + DO i=1,N + DEL(i)=DYH(i)-DEL(i)*HJI + END DO + END IF +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) +#else + CALL KppSolve (E,DEL) +#endif + Nsol=Nsol+1 + DEL2=0.D0 + DO i=1,N + DEL2=DEL2+(DEL(i)/SCAL(i))**2 + END DO + DEL2=SQRT(DEL2) + Theta=DEL2/MAX(1.D0,DEL1) + IF (Theta > 1.D0) GOTO 79 + END IF +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DYH,N,ISING) +#else + CALL KppSolve (E,DYH) +#endif + Nsol=Nsol+1 + DO i=1,N + DEL(i)=DYH(i) + END DO + IF (IOUT == 2.AND.MM >= M-JJ) THEN + IPT=IPT+1 + DO i=1,NRD + FSAFE(IPT,i)=DEL(ICOMP(i)) + END DO + END IF + END DO + END IF + DO i=1,N + Table(JJ,I)=YH(i)+DEL(i) + END DO +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> POLYNOMIAL EXTRAPOLATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (JJ == 1) RETURN + DO L=JJ,2,-1 + FAC=(DBLE(NJ(JJ))/DBLE(NJ(L-1)))-1.D0 + DO i=1,N + Table(L-1,I)=Table(L,I)+(Table(L,I)-Table(L-1,I))/FAC + END DO + END DO + ERR=0.D0 + DO i=1,N + ERR=ERR+MIN(ABS((Table(1,I)-Table(2,I)))/SCAL(i),1.D15)**2 + END DO + IF (ERR >= 1.D30) GOTO 79 + ERR=SQRT(ERR/DBLE(N)) + IF (JJ > 2.AND.ERR >= ERROLD) GOTO 79 + ERROLD=MAX(4*ERR,1.D0) +!~~~> COMPUTE OPTIMAL STEP SIZES + EXPO=1.D0/JJ + FACMIN=FAC1**EXPO + FAC=MIN(FAC2/FACMIN,MAX(FACMIN,(ERR/FacSafe1)**EXPO/FacSafe2)) + FAC=1.D0/FAC + HH(JJ)=MIN(H*FAC,HmaxN) + W(JJ)=A(JJ)/HH(JJ) + RETURN + 79 ATOV=.TRUE. + H=H*0.5D0 + REJECT=.TRUE. + RETURN + END SUBROUTINE KPP_ROOT_SEUL + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_FUN_CHEM( T, V, FCT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Function, ONLY: Fun + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), FCT(NVAR) + KPP_REAL :: T, TOLD + + !TOLD = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = TOLD + CALL Fun(V, FIX, RCONST, FCT) + Nfun=Nfun+1 + + END SUBROUTINE KPP_ROOT_FUN_CHEM + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_JAC_CHEM ( T, V, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian, ONLY: Jac_SP + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), T, TOLD +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) + INTEGER :: i,j +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif + + !TOLD = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = TOLD + +#ifdef FULL_ALGEBRA + CALL Jac_SP(V, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0D0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP(V, FIX, RCONST, Jcb) +#endif + Njac=Njac+1 + + END SUBROUTINE KPP_ROOT_JAC_CHEM + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.def new file mode 100755 index 00000000..dc8a5528 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros2w + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.f90 new file mode 100755 index 00000000..99ed0897 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros2w.f90 @@ -0,0 +1,1348 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Precision + USE KPP_ROOT_JacobianSP + + IMPLICIT NONE + + + + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Selected Rosenbrock method not implemented ', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE KPP_ROOT_INTEGRATE( TIN, TOUT, & + FIX, VAR, RCONST, ATOL, RTOL, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global + IMPLICIT NONE + KPP_REAL, INTENT(INOUT), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(INOUT), DIMENSION(NVAR) :: VAR + KPP_REAL, INTENT(IN), DIMENSION(NSPEC) :: ATOL, RTOL + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + KPP_REAL :: STEPMIN + + + INTEGER :: N_stp, N_acc, N_rej, N_sng + SAVE N_stp, N_acc, N_rej, N_sng + INTEGER :: i, IERR + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL KPP_ROOT_Rosenbrock(VAR, FIX, RCONST, TIN,TOUT, & + ATOL,RTOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output they to return information +!!$ IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) +!!$ IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) +!!$ IF (PRESENT(IERR_U)) IERR_U = IERR + +END SUBROUTINE KPP_ROOT_INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_Rosenbrock(Y, FIX, RCONST, Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dFun/dY +!- ICNTRL(1:20) = integer inputs parameters +!- RCNTRL(1:20) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- ISTATUS(1:20) -> integer output parameters +!- RSTATUS(1:20) -> real output parameters +!- IERR -> job status upon return +! success (positive value) or +! failure (negative value) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0) the default value of 100000 is used +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:20) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_LinearAlgebra + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: Tstart,Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(20) + KPP_REAL, INTENT(IN) :: RCNTRL(20) + INTEGER, INTENT(INOUT) :: ISTATUS(20) + KPP_REAL, INTENT(INOUT) :: RSTATUS(20) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + + +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. +!!$ Autonomous = .NOT.(ICNTRL(1) == 0) + Autonomous=.FALSE. + + + + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) +!!$ IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR +!!$ ELSE +!!$ VectorTol = .FALSE. +!!$ UplimTol = 1 +!!$ END IF + +!~~~> The particular Rosenbrock method chosen +!!$ IF (ICNTRL(3) == 0) THEN +!!$ Method = 4 +!!$ ELSEIF ( (ICNTRL(3) >= 1).AND.(ICNTRL(3) <= 5) ) THEN +!!$ Method = ICNTRL(3) +!!$ ELSE +!!$ PRINT * , 'User-selected Rosenbrock method: ICNTRL(3)=', Method +!!$ CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF + +!~~~> The maximum number of steps admitted +!!$ IF (ICNTRL(4) == 0) THEN + Max_no_steps = 10000 +!!$ ELSEIF (ICNTRL(4) > 0) THEN +!!$ Max_no_steps=ICNTRL(4) +!!$ ELSE +!!$ PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-1,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = KPP_ROOT_WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) +!!$ IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO +!!$ ELSEIF (RCNTRL(1) > ZERO) THEN +!!$ Hmin = RCNTRL(1) +!!$ ELSE +!!$ PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Upper bound on the step size: (positive value) +!!$ IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) +!!$ ELSEIF (RCNTRL(2) > ZERO) THEN +!!$ Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) +!!$ ELSE +!!$ PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Starting step size: (positive value) +!!$ IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) +!!$ ELSEIF (RCNTRL(3) > ZERO) THEN +!!$ Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) +!!$ ELSE +!!$ PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax +!!$ IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp +!!$ ELSEIF (RCNTRL(4) > ZERO) THEN +!!$ FacMin = RCNTRL(4) +!!$ ELSE +!!$ PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$ IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0_dp +!!$ ELSEIF (RCNTRL(5) > ZERO) THEN +!!$ FacMax = RCNTRL(5) +!!$ ELSE +!!$ PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections +!!$ IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp +!!$ ELSEIF (RCNTRL(6) > ZERO) THEN +!!$ FacRej = RCNTRL(6) +!!$ ELSE +!!$ PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> FacSafe: Safety Factor in the computation of new step size +!!$ IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp +!!$ ELSEIF (RCNTRL(7) > ZERO) THEN +!!$ FacSafe = RCNTRL(7) +!!$ ELSE +!!$ PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Check if tolerances are reasonable +!!$ DO i=1,UplimTol +!!$ IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.0_dp*Roundoff) & +!!$ .OR. (RelTol(i) >= 1.0_dp) ) THEN +!!$ PRINT * , ' AbsTol(',i,') = ',AbsTol(i) +!!$ PRINT * , ' RelTol(',i,') = ',RelTol(i) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-5,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$ END DO + + +!~~~> Initialize the particular Rosenbrock method +!!$ SELECT CASE (Method) +!!$ CASE (1) + CALL KPP_ROOT_Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (2) +!!$ CALL KPP_ROOT_Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (3) +!!$ CALL KPP_ROOT_Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (4) +!!$ CALL KPP_ROOT_Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (5) +!!$ CALL KPP_ROOT_Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE DEFAULT +!!$ PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method +!!$ CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END SELECT + +!~~~> CALL Rosenbrock method + CALL KPP_ROOT_ros_Integrator(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR, & +! Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng,& +!~~~> + RCONST, FIX & +) + + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS ! SUBROUTINES internal to Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Precision + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from Rosenbrock due to the following error:' + IF ((Code>=-8).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE KPP_ROOT_ros_ErrorMsg + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Integrator (Y, Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR, & +!~~~> Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng, & +!~~~> + RCONST, FIX & + ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The Rosenbrock method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER, INTENT(INOUT) :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) +#ifdef FULL_ALGEBRA + KPP_REAL :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) +#else + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) +#endif + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL KPP_ROOT_ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1_dp*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL KPP_ROOT_ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL KPP_ROOT_FunTemplate(T,Y,Fcn0, RCONST, FIX, Nfun) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) + END IF + +!~~~> Compute the Jacobian at current time + CALL KPP_ROOT_JacTemplate(T,Y,Jac0, FIX, Njac, RCONST) + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL KPP_ROOT_ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular, Ndec, Nsng ) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL KPP_ROOT_ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Fcn0,1,Fcn,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL KPP_ROOT_WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL KPP_ROOT_FunTemplate(Tau,Ynew,Fcn, RCONST, FIX, Nfun) + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL KPP_ROOT_WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL KPP_ROOT_WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL KPP_ROOT_WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL KPP_ROOT_ros_Solve(Ghimj, Pivot, K(ioffset+1), Nsol) + + END DO Stage + + +!~~~> Compute the new solution + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL KPP_ROOT_WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL KPP_ROOT_WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE KPP_ROOT_ros_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0_dp + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + KPP_ROOT_ros_ErrorNorm = Err + + END FUNCTION KPP_ROOT_ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) + KPP_REAL, INTENT(IN) :: RCONST(NREACT), FIX(NFIX) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> InOut args + INTEGER, INTENT(INOUT) ::Nfun +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0_dp, DeltaMin = 1.0E-6_dp + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL KPP_ROOT_FunTemplate(T+Delta,Y,dFdT, RCONST, FIX, Nfun) + CALL KPP_ROOT_WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL KPP_ROOT_WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE KPP_ROOT_ros_FunTimeDeriv + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular, Ndec, Nsng ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) +#else + KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) +#endif + KPP_REAL, INTENT(IN) :: gam + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(OUT) :: Ghimj(NVAR,NVAR) +#else + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) +#endif + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails + INTEGER, INTENT(INOUT) :: Ndec, Nsng +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*gam) - Jac0 +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL KPP_ROOT_WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL KPP_ROOT_ros_Decomp( Ghimj, Pivot, ising, Ndec ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE KPP_ROOT_ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Decomp( A, Pivot, ising, Ndec ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + INTEGER, INTENT(INOUT) :: Ndec + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) +#else + CALL KPP_ROOT_KppDecomp ( A, ising ) + Pivot(1) = 1 +#endif + Ndec = Ndec + 1 + + END SUBROUTINE KPP_ROOT_ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Solve( A, Pivot, b, Nsol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~~> InOut args + INTEGER, INTENT(INOUT) :: nsol +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KPP_ROOT_KppSolve( A, b ) +#endif + + Nsol = Nsol+1 + + END SUBROUTINE KPP_ROOT_ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + g = 1.0_dp + 1.0_dp/SQRT(2.0_dp) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.0_dp)/g + ros_C(1) = (-2.0_dp)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.0_dp)/(2.0_dp*g) + ros_M(2)= (1.0_dp)/(2.0_dp*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.0_dp/(2.0_dp*g) + ros_E(2) = 1.0_dp/(2.0_dp*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 1.0_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE KPP_ROOT_Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.0_dp + ros_A(2)= 1.0_dp + ros_A(3)= 0.0_dp + + ros_C(1) = -0.10156171083877702091975600115545E+01_dp + ros_C(2) = 0.40759956452537699824805835358067E+01_dp + ros_C(3) = 0.92076794298330791242156818474003E+01_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1E+01_dp + ros_M(2) = 0.61697947043828245592553615689730E+01_dp + ros_M(3) = -0.42772256543218573326238373806514E+00_dp +! E_i = Coefficients for error estimator + ros_E(1) = 0.5E+00_dp + ros_E(2) = -0.29079558716805469821718236208017E+01_dp + ros_E(3) = 0.22354069897811569627360909276199E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0E+00_dp + ros_Alpha(2)= 0.43586652150845899941601945119356E+00_dp + ros_Alpha(3)= 0.43586652150845899941601945119356E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356E+00_dp + ros_Gamma(2)= 0.24291996454816804366592249683314E+00_dp + ros_Gamma(3)= 0.21851380027664058511513169485832E+01_dp + + END SUBROUTINE KPP_ROOT_Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(4), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(6), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(4), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000E+01_dp + ros_A(2) = 0.1867943637803922E+01_dp + ros_A(3) = 0.2344449711399156E+00_dp + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0_dp + + ros_C(1) =-0.7137615036412310E+01_dp + ros_C(2) = 0.2580708087951457E+01_dp + ros_C(3) = 0.6515950076447975E+00_dp + ros_C(4) =-0.2137148994382534E+01_dp + ros_C(5) =-0.3214669691237626E+00_dp + ros_C(6) =-0.6949742501781779E+00_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735E+01_dp + ros_M(2) = 0.2870493262186792E+00_dp + ros_M(3) = 0.4353179431840180E+00_dp + ros_M(4) = 0.1093502252409163E+01_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155E+00_dp + ros_E(2) =-0.7276199124938920E-01_dp + ros_E(3) =-0.1082196201495311E+00_dp + ros_E(4) =-0.1093502252409163E+01_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 0.1145640000000000E+01_dp + ros_Alpha(3) = 0.6552168638155900E+00_dp + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000E+00_dp + ros_Gamma(2) =-0.1769193891319233E+01_dp + ros_Gamma(3) = 0.7592633437920482E+00_dp + ros_Gamma(4) =-0.1049021087100450E+00_dp + + END SUBROUTINE KPP_ROOT_Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0E+00_dp + ros_A(2) = 2.0E+00_dp + ros_A(3) = 0.0E+00_dp + ros_A(4) = 2.0E+00_dp + ros_A(5) = 0.0E+00_dp + ros_A(6) = 1.0E+00_dp + + ros_C(1) = 4.0E+00_dp + ros_C(2) = 1.0E+00_dp + ros_C(3) =-1.0E+00_dp + ros_C(4) = 1.0E+00_dp + ros_C(5) =-1.0E+00_dp + ros_C(6) =-(8.0E+00_dp/3.0E+00_dp) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0E+00_dp + ros_M(2) = 0.0E+00_dp + ros_M(3) = 1.0E+00_dp + ros_M(4) = 1.0E+00_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 1.0E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0E+00_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0E+00_dp + ros_Alpha(2) = 0.0E+00_dp + ros_Alpha(3) = 1.0E+00_dp + ros_Alpha(4) = 1.0E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5E+00_dp + ros_Gamma(2) = 1.5E+00_dp + ros_Gamma(3) = 0.0E+00_dp + ros_Gamma(4) = 0.0E+00_dp + + END SUBROUTINE KPP_ROOT_Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000_dp + ros_Alpha(2) = 0.386_dp + ros_Alpha(3) = 0.210_dp + ros_Alpha(4) = 0.630_dp + ros_Alpha(5) = 1.000_dp + ros_Alpha(6) = 1.000_dp + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000E+00_dp + ros_Gamma(2) =-0.1043000000000000E+00_dp + ros_Gamma(3) = 0.1035000000000000E+00_dp + ros_Gamma(4) =-0.3620000000000023E-01_dp + ros_Gamma(5) = 0.0_dp + ros_Gamma(6) = 0.0_dp + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000E+01_dp + ros_A(2) = 0.9466785280815826E+00_dp + ros_A(3) = 0.2557011698983284E+00_dp + ros_A(4) = 0.3314825187068521E+01_dp + ros_A(5) = 0.2896124015972201E+01_dp + ros_A(6) = 0.9986419139977817E+00_dp + ros_A(7) = 0.1221224509226641E+01_dp + ros_A(8) = 0.6019134481288629E+01_dp + ros_A(9) = 0.1253708332932087E+02_dp + ros_A(10) =-0.6878860361058950E+00_dp + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0E+00_dp + + ros_C(1) =-0.5668800000000000E+01_dp + ros_C(2) =-0.2430093356833875E+01_dp + ros_C(3) =-0.2063599157091915E+00_dp + ros_C(4) =-0.1073529058151375E+00_dp + ros_C(5) =-0.9594562251023355E+01_dp + ros_C(6) =-0.2047028614809616E+02_dp + ros_C(7) = 0.7496443313967647E+01_dp + ros_C(8) =-0.1024680431464352E+02_dp + ros_C(9) =-0.3399990352819905E+02_dp + ros_C(10) = 0.1170890893206160E+02_dp + ros_C(11) = 0.8083246795921522E+01_dp + ros_C(12) =-0.7981132988064893E+01_dp + ros_C(13) =-0.3152159432874371E+02_dp + ros_C(14) = 0.1631930543123136E+02_dp + ros_C(15) =-0.6058818238834054E+01_dp + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0E+00_dp + ros_M(6) = 1.0E+00_dp + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 0.0E+00_dp + ros_E(5) = 0.0E+00_dp + ros_E(6) = 1.0E+00_dp + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp + + END SUBROUTINE KPP_ROOT_Rodas4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of the set of internal Rosenbrock subroutines +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END SUBROUTINE KPP_ROOT_Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_FunTemplate( T, Y, Ydot, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global +!! USE KPP_ROOT_Function +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: RCONST(NREACT) + KPP_REAL :: FIX(NFIX) +!~~~> Output variables + KPP_REAL :: Ydot(NVAR) + INTEGER :: Nfun + + +!~~~> Local variables +!! KPP_REAL :: Told + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() + CALL KPP_ROOT_Fun( Y, FIX, RCONST, Ydot ) +!! TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE KPP_ROOT_FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_JacTemplate( T, Y, Jcb, FIX, Njac, RCONST ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + !!USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian +!! USE KPP_ROOT_LinearAlgebra +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: FIX(NFIX) + KPP_REAL :: RCONST(NREACT) + + INTEGER :: Njac + +!~~~> Output variables +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif +!~~~> Local variables + KPP_REAL :: Told +#ifdef FULL_ALGEBRA + INTEGER :: i, j +#endif + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_Jac_SP(Y, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL KPP_ROOT_Jac_SP( Y, FIX, RCONST, Jcb ) +#endif +!! TIME = Told + + Njac = Njac+1 + +END SUBROUTINE KPP_ROOT_JacTemplate + +!!!END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.def new file mode 100755 index 00000000..6e7fcd34 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros3w + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.f90 new file mode 100755 index 00000000..47927698 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/TEMP/ros3w.f90 @@ -0,0 +1,1348 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Precision + USE KPP_ROOT_JacobianSP + + IMPLICIT NONE + + + + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Selected Rosenbrock method not implemented ', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE KPP_ROOT_INTEGRATE( TIN, TOUT, & + FIX, VAR, RCONST, ATOL, RTOL, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global + IMPLICIT NONE + KPP_REAL, INTENT(INOUT), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(INOUT), DIMENSION(NVAR) :: VAR + KPP_REAL, INTENT(IN), DIMENSION(NSPEC) :: ATOL, RTOL + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + KPP_REAL :: STEPMIN + + + INTEGER :: N_stp, N_acc, N_rej, N_sng + SAVE N_stp, N_acc, N_rej, N_sng + INTEGER :: i, IERR + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL KPP_ROOT_Rosenbrock(VAR, FIX, RCONST, TIN,TOUT, & + ATOL,RTOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output they to return information +!!$ IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) +!!$ IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) +!!$ IF (PRESENT(IERR_U)) IERR_U = IERR + +END SUBROUTINE KPP_ROOT_INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_Rosenbrock(Y, FIX, RCONST, Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dFun/dY +!- ICNTRL(1:20) = integer inputs parameters +!- RCNTRL(1:20) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- ISTATUS(1:20) -> integer output parameters +!- RSTATUS(1:20) -> real output parameters +!- IERR -> job status upon return +! success (positive value) or +! failure (negative value) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0) the default value of 100000 is used +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:20) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_LinearAlgebra + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: Tstart,Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(20) + KPP_REAL, INTENT(IN) :: RCNTRL(20) + INTEGER, INTENT(INOUT) :: ISTATUS(20) + KPP_REAL, INTENT(INOUT) :: RSTATUS(20) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + + +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. +!!$ Autonomous = .NOT.(ICNTRL(1) == 0) + Autonomous=.FALSE. + + + + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) +!!$ IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR +!!$ ELSE +!!$ VectorTol = .FALSE. +!!$ UplimTol = 1 +!!$ END IF + +!~~~> The particular Rosenbrock method chosen +!!$ IF (ICNTRL(3) == 0) THEN +!!$ Method = 4 +!!$ ELSEIF ( (ICNTRL(3) >= 1).AND.(ICNTRL(3) <= 5) ) THEN +!!$ Method = ICNTRL(3) +!!$ ELSE +!!$ PRINT * , 'User-selected Rosenbrock method: ICNTRL(3)=', Method +!!$ CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF + +!~~~> The maximum number of steps admitted +!!$ IF (ICNTRL(4) == 0) THEN + Max_no_steps = 10000 +!!$ ELSEIF (ICNTRL(4) > 0) THEN +!!$ Max_no_steps=ICNTRL(4) +!!$ ELSE +!!$ PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-1,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = KPP_ROOT_WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) +!!$ IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO +!!$ ELSEIF (RCNTRL(1) > ZERO) THEN +!!$ Hmin = RCNTRL(1) +!!$ ELSE +!!$ PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Upper bound on the step size: (positive value) +!!$ IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) +!!$ ELSEIF (RCNTRL(2) > ZERO) THEN +!!$ Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) +!!$ ELSE +!!$ PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Starting step size: (positive value) +!!$ IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) +!!$ ELSEIF (RCNTRL(3) > ZERO) THEN +!!$ Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) +!!$ ELSE +!!$ PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax +!!$ IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp +!!$ ELSEIF (RCNTRL(4) > ZERO) THEN +!!$ FacMin = RCNTRL(4) +!!$ ELSE +!!$ PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$ IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0_dp +!!$ ELSEIF (RCNTRL(5) > ZERO) THEN +!!$ FacMax = RCNTRL(5) +!!$ ELSE +!!$ PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections +!!$ IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp +!!$ ELSEIF (RCNTRL(6) > ZERO) THEN +!!$ FacRej = RCNTRL(6) +!!$ ELSE +!!$ PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!~~~> FacSafe: Safety Factor in the computation of new step size +!!$ IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp +!!$ ELSEIF (RCNTRL(7) > ZERO) THEN +!!$ FacSafe = RCNTRL(7) +!!$ ELSE +!!$ PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$!~~~> Check if tolerances are reasonable +!!$ DO i=1,UplimTol +!!$ IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.0_dp*Roundoff) & +!!$ .OR. (RelTol(i) >= 1.0_dp) ) THEN +!!$ PRINT * , ' AbsTol(',i,') = ',AbsTol(i) +!!$ PRINT * , ' RelTol(',i,') = ',RelTol(i) +!!$ CALL KPP_ROOT_ros_ErrorMsg(-5,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END IF +!!$ END DO + + +!~~~> Initialize the particular Rosenbrock method +!!$ SELECT CASE (Method) +!!$ CASE (1) +!!$ CALL KPP_ROOT_Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (2) + CALL KPP_ROOT_Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (3) +!!$ CALL KPP_ROOT_Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (4) +!!$ CALL KPP_ROOT_Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE (5) +!!$ CALL KPP_ROOT_Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & +!!$ ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) +!!$ CASE DEFAULT +!!$ PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method +!!$ CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) +!!$ RETURN +!!$ END SELECT + +!~~~> CALL Rosenbrock method + CALL KPP_ROOT_ros_Integrator(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR, & +! Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng,& +!~~~> + RCONST, FIX & +) + + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS ! SUBROUTINES internal to Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Precision + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from Rosenbrock due to the following error:' + IF ((Code>=-8).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE KPP_ROOT_ros_ErrorMsg + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Integrator (Y, Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR, & +!~~~> Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng, & +!~~~> + RCONST, FIX & + ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The Rosenbrock method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER, INTENT(INOUT) :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) +#ifdef FULL_ALGEBRA + KPP_REAL :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) +#else + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) +#endif + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL KPP_ROOT_ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1_dp*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL KPP_ROOT_ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL KPP_ROOT_FunTemplate(T,Y,Fcn0, RCONST, FIX, Nfun) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) + END IF + +!~~~> Compute the Jacobian at current time + CALL KPP_ROOT_JacTemplate(T,Y,Jac0, FIX, Njac, RCONST) + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL KPP_ROOT_ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular, Ndec, Nsng ) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL KPP_ROOT_ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Fcn0,1,Fcn,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL KPP_ROOT_WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL KPP_ROOT_FunTemplate(Tau,Ynew,Fcn, RCONST, FIX, Nfun) + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL KPP_ROOT_WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL KPP_ROOT_WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL KPP_ROOT_WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL KPP_ROOT_ros_Solve(Ghimj, Pivot, K(ioffset+1), Nsol) + + END DO Stage + + +!~~~> Compute the new solution + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL KPP_ROOT_WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL KPP_ROOT_WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE KPP_ROOT_ros_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0_dp + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + KPP_ROOT_ros_ErrorNorm = Err + + END FUNCTION KPP_ROOT_ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) + KPP_REAL, INTENT(IN) :: RCONST(NREACT), FIX(NFIX) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> InOut args + INTEGER, INTENT(INOUT) ::Nfun +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0_dp, DeltaMin = 1.0E-6_dp + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL KPP_ROOT_FunTemplate(T+Delta,Y,dFdT, RCONST, FIX, Nfun) + CALL KPP_ROOT_WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL KPP_ROOT_WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE KPP_ROOT_ros_FunTimeDeriv + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular, Ndec, Nsng ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) +#else + KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) +#endif + KPP_REAL, INTENT(IN) :: gam + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(OUT) :: Ghimj(NVAR,NVAR) +#else + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) +#endif + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails + INTEGER, INTENT(INOUT) :: Ndec, Nsng +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*gam) - Jac0 +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL KPP_ROOT_WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL KPP_ROOT_ros_Decomp( Ghimj, Pivot, ising, Ndec ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE KPP_ROOT_ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Decomp( A, Pivot, ising, Ndec ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + INTEGER, INTENT(INOUT) :: Ndec + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) +#else + CALL KPP_ROOT_KppDecomp ( A, ising ) + Pivot(1) = 1 +#endif + Ndec = Ndec + 1 + + END SUBROUTINE KPP_ROOT_ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Solve( A, Pivot, b, Nsol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~~> InOut args + INTEGER, INTENT(INOUT) :: nsol +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KPP_ROOT_KppSolve( A, b ) +#endif + + Nsol = Nsol+1 + + END SUBROUTINE KPP_ROOT_ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + g = 1.0_dp + 1.0_dp/SQRT(2.0_dp) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.0_dp)/g + ros_C(1) = (-2.0_dp)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.0_dp)/(2.0_dp*g) + ros_M(2)= (1.0_dp)/(2.0_dp*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.0_dp/(2.0_dp*g) + ros_E(2) = 1.0_dp/(2.0_dp*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 1.0_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE KPP_ROOT_Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.0_dp + ros_A(2)= 1.0_dp + ros_A(3)= 0.0_dp + + ros_C(1) = -0.10156171083877702091975600115545E+01_dp + ros_C(2) = 0.40759956452537699824805835358067E+01_dp + ros_C(3) = 0.92076794298330791242156818474003E+01_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1E+01_dp + ros_M(2) = 0.61697947043828245592553615689730E+01_dp + ros_M(3) = -0.42772256543218573326238373806514E+00_dp +! E_i = Coefficients for error estimator + ros_E(1) = 0.5E+00_dp + ros_E(2) = -0.29079558716805469821718236208017E+01_dp + ros_E(3) = 0.22354069897811569627360909276199E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0E+00_dp + ros_Alpha(2)= 0.43586652150845899941601945119356E+00_dp + ros_Alpha(3)= 0.43586652150845899941601945119356E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356E+00_dp + ros_Gamma(2)= 0.24291996454816804366592249683314E+00_dp + ros_Gamma(3)= 0.21851380027664058511513169485832E+01_dp + + END SUBROUTINE KPP_ROOT_Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(4), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(6), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(4), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000E+01_dp + ros_A(2) = 0.1867943637803922E+01_dp + ros_A(3) = 0.2344449711399156E+00_dp + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0_dp + + ros_C(1) =-0.7137615036412310E+01_dp + ros_C(2) = 0.2580708087951457E+01_dp + ros_C(3) = 0.6515950076447975E+00_dp + ros_C(4) =-0.2137148994382534E+01_dp + ros_C(5) =-0.3214669691237626E+00_dp + ros_C(6) =-0.6949742501781779E+00_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735E+01_dp + ros_M(2) = 0.2870493262186792E+00_dp + ros_M(3) = 0.4353179431840180E+00_dp + ros_M(4) = 0.1093502252409163E+01_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155E+00_dp + ros_E(2) =-0.7276199124938920E-01_dp + ros_E(3) =-0.1082196201495311E+00_dp + ros_E(4) =-0.1093502252409163E+01_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 0.1145640000000000E+01_dp + ros_Alpha(3) = 0.6552168638155900E+00_dp + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000E+00_dp + ros_Gamma(2) =-0.1769193891319233E+01_dp + ros_Gamma(3) = 0.7592633437920482E+00_dp + ros_Gamma(4) =-0.1049021087100450E+00_dp + + END SUBROUTINE KPP_ROOT_Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0E+00_dp + ros_A(2) = 2.0E+00_dp + ros_A(3) = 0.0E+00_dp + ros_A(4) = 2.0E+00_dp + ros_A(5) = 0.0E+00_dp + ros_A(6) = 1.0E+00_dp + + ros_C(1) = 4.0E+00_dp + ros_C(2) = 1.0E+00_dp + ros_C(3) =-1.0E+00_dp + ros_C(4) = 1.0E+00_dp + ros_C(5) =-1.0E+00_dp + ros_C(6) =-(8.0E+00_dp/3.0E+00_dp) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0E+00_dp + ros_M(2) = 0.0E+00_dp + ros_M(3) = 1.0E+00_dp + ros_M(4) = 1.0E+00_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 1.0E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0E+00_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0E+00_dp + ros_Alpha(2) = 0.0E+00_dp + ros_Alpha(3) = 1.0E+00_dp + ros_Alpha(4) = 1.0E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5E+00_dp + ros_Gamma(2) = 1.5E+00_dp + ros_Gamma(3) = 0.0E+00_dp + ros_Gamma(4) = 0.0E+00_dp + + END SUBROUTINE KPP_ROOT_Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000_dp + ros_Alpha(2) = 0.386_dp + ros_Alpha(3) = 0.210_dp + ros_Alpha(4) = 0.630_dp + ros_Alpha(5) = 1.000_dp + ros_Alpha(6) = 1.000_dp + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000E+00_dp + ros_Gamma(2) =-0.1043000000000000E+00_dp + ros_Gamma(3) = 0.1035000000000000E+00_dp + ros_Gamma(4) =-0.3620000000000023E-01_dp + ros_Gamma(5) = 0.0_dp + ros_Gamma(6) = 0.0_dp + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000E+01_dp + ros_A(2) = 0.9466785280815826E+00_dp + ros_A(3) = 0.2557011698983284E+00_dp + ros_A(4) = 0.3314825187068521E+01_dp + ros_A(5) = 0.2896124015972201E+01_dp + ros_A(6) = 0.9986419139977817E+00_dp + ros_A(7) = 0.1221224509226641E+01_dp + ros_A(8) = 0.6019134481288629E+01_dp + ros_A(9) = 0.1253708332932087E+02_dp + ros_A(10) =-0.6878860361058950E+00_dp + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0E+00_dp + + ros_C(1) =-0.5668800000000000E+01_dp + ros_C(2) =-0.2430093356833875E+01_dp + ros_C(3) =-0.2063599157091915E+00_dp + ros_C(4) =-0.1073529058151375E+00_dp + ros_C(5) =-0.9594562251023355E+01_dp + ros_C(6) =-0.2047028614809616E+02_dp + ros_C(7) = 0.7496443313967647E+01_dp + ros_C(8) =-0.1024680431464352E+02_dp + ros_C(9) =-0.3399990352819905E+02_dp + ros_C(10) = 0.1170890893206160E+02_dp + ros_C(11) = 0.8083246795921522E+01_dp + ros_C(12) =-0.7981132988064893E+01_dp + ros_C(13) =-0.3152159432874371E+02_dp + ros_C(14) = 0.1631930543123136E+02_dp + ros_C(15) =-0.6058818238834054E+01_dp + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0E+00_dp + ros_M(6) = 1.0E+00_dp + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 0.0E+00_dp + ros_E(5) = 0.0E+00_dp + ros_E(6) = 1.0E+00_dp + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp + + END SUBROUTINE KPP_ROOT_Rodas4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of the set of internal Rosenbrock subroutines +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END SUBROUTINE KPP_ROOT_Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_FunTemplate( T, Y, Ydot, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global +!! USE KPP_ROOT_Function +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: RCONST(NREACT) + KPP_REAL :: FIX(NFIX) +!~~~> Output variables + KPP_REAL :: Ydot(NVAR) + INTEGER :: Nfun + + +!~~~> Local variables +!! KPP_REAL :: Told + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() + CALL KPP_ROOT_Fun( Y, FIX, RCONST, Ydot ) +!! TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE KPP_ROOT_FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_JacTemplate( T, Y, Jcb, FIX, Njac, RCONST ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + !!USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian +!! USE KPP_ROOT_LinearAlgebra +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: FIX(NFIX) + KPP_REAL :: RCONST(NREACT) + + INTEGER :: Njac + +!~~~> Output variables +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif +!~~~> Local variables + KPP_REAL :: Told +#ifdef FULL_ALGEBRA + INTEGER :: i, j +#endif + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_Jac_SP(Y, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL KPP_ROOT_Jac_SP( Y, FIX, RCONST, Jcb ) +#endif +!! TIME = Told + + Njac = Njac+1 + +END SUBROUTINE KPP_ROOT_JacTemplate + +!!!END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.def new file mode 100755 index 00000000..81a16c52 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE rosenbrock + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.f90 new file mode 100755 index 00000000..a3457cf8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/WRF_conform/rosenbrock.f90 @@ -0,0 +1,1348 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Precision + USE KPP_ROOT_JacobianSP + + IMPLICIT NONE + + + + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Selected Rosenbrock method not implemented ', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE KPP_ROOT_INTEGRATE( TIN, TOUT, & + FIX, VAR, RCONST, ATOL, RTOL, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global + IMPLICIT NONE + KPP_REAL, INTENT(INOUT), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(INOUT), DIMENSION(NVAR) :: VAR + KPP_REAL, INTENT(IN), DIMENSION(NSPEC) :: ATOL, RTOL + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + KPP_REAL :: STEPMIN + + + INTEGER :: N_stp, N_acc, N_rej, N_sng + SAVE N_stp, N_acc, N_rej, N_sng + INTEGER :: i, IERR + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL KPP_ROOT_Rosenbrock(VAR, FIX, RCONST, TIN,TOUT, & + ATOL,RTOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output they to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) + IF (PRESENT(IERR_U)) IERR_U = IERR + +END SUBROUTINE KPP_ROOT_INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_Rosenbrock(Y, FIX, RCONST, Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dFun/dY +!- ICNTRL(1:20) = integer inputs parameters +!- RCNTRL(1:20) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- ISTATUS(1:20) -> integer output parameters +!- RSTATUS(1:20) -> real output parameters +!- IERR -> job status upon return +! success (positive value) or +! failure (negative value) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0) the default value of 100000 is used +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:20) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_LinearAlgebra + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + KPP_REAL, INTENT(IN) :: Tstart,Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(20) + KPP_REAL, INTENT(IN) :: RCNTRL(20) + INTEGER, INTENT(INOUT) :: ISTATUS(20) + KPP_REAL, INTENT(INOUT) :: RSTATUS(20) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + + +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(ICNTRL(1) == 0) + + + + + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> The particular Rosenbrock method chosen + IF (ICNTRL(3) == 0) THEN + Method = 4 + ELSEIF ( (ICNTRL(3) >= 1).AND.(ICNTRL(3) <= 5) ) THEN + Method = ICNTRL(3) + ELSE + PRINT * , 'User-selected Rosenbrock method: ICNTRL(3)=', Method + CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The maximum number of steps admitted + IF (ICNTRL(4) == 0) THEN + Max_no_steps = 100000 + ELSEIF (ICNTRL(4) > 0) THEN + Max_no_steps=ICNTRL(4) + ELSE + PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) + CALL KPP_ROOT_ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = KPP_ROOT_WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) + CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) + CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL KPP_ROOT_ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0_dp + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL KPP_ROOT_ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.0_dp*Roundoff) & + .OR. (RelTol(i) >= 1.0_dp) ) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL KPP_ROOT_ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Initialize the particular Rosenbrock method + SELECT CASE (Method) + CASE (1) + CALL KPP_ROOT_Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (2) + CALL KPP_ROOT_Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (3) + CALL KPP_ROOT_Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (4) + CALL KPP_ROOT_Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (5) + CALL KPP_ROOT_Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method + CALL KPP_ROOT_ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + +!~~~> CALL Rosenbrock method + CALL KPP_ROOT_ros_Integrator(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR, & +! Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng,& +!~~~> + RCONST, FIX & +) + + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS ! SUBROUTINES internal to Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Precision + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from Rosenbrock due to the following error:' + IF ((Code>=-8).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE KPP_ROOT_ros_ErrorMsg + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Integrator (Y, Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR, & +!~~~> Statistics on the work performed by the Rosenbrock method + Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng, & +!~~~> + RCONST, FIX & + ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The Rosenbrock method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NFIX) :: FIX +!~~~> Input + KPP_REAL, INTENT(IN), DIMENSION(NREACT) :: RCONST + +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER, INTENT(INOUT) :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) +#ifdef FULL_ALGEBRA + KPP_REAL :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) +#else + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) +#endif + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL KPP_ROOT_ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1_dp*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL KPP_ROOT_ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL KPP_ROOT_FunTemplate(T,Y,Fcn0, RCONST, FIX, Nfun) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) + END IF + +!~~~> Compute the Jacobian at current time + CALL KPP_ROOT_JacTemplate(T,Y,Jac0, FIX, Njac, RCONST) + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL KPP_ROOT_ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular, Ndec, Nsng ) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL KPP_ROOT_ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Fcn0,1,Fcn,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL KPP_ROOT_WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL KPP_ROOT_FunTemplate(Tau,Ynew,Fcn, RCONST, FIX, Nfun) + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL KPP_ROOT_WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL KPP_ROOT_WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL KPP_ROOT_WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL KPP_ROOT_ros_Solve(Ghimj, Pivot, K(ioffset+1), Nsol) + + END DO Stage + + +!~~~> Compute the new solution + CALL KPP_ROOT_WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL KPP_ROOT_WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL KPP_ROOT_WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL KPP_ROOT_WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE KPP_ROOT_ros_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION KPP_ROOT_ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0_dp + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + KPP_ROOT_ros_ErrorNorm = Err + + END FUNCTION KPP_ROOT_ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_FunTimeDeriv ( T, Roundoff, Y, & + Fcn0, dFdT, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) + KPP_REAL, INTENT(IN) :: RCONST(NREACT), FIX(NFIX) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> InOut args + INTEGER, INTENT(INOUT) ::Nfun +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0_dp, DeltaMin = 1.0E-6_dp + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL KPP_ROOT_FunTemplate(T+Delta,Y,dFdT, RCONST, FIX, Nfun) + CALL KPP_ROOT_WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL KPP_ROOT_WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE KPP_ROOT_ros_FunTimeDeriv + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular, Ndec, Nsng ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) +#else + KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) +#endif + KPP_REAL, INTENT(IN) :: gam + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(OUT) :: Ghimj(NVAR,NVAR) +#else + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) +#endif + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails + INTEGER, INTENT(INOUT) :: Ndec, Nsng +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*gam) - Jac0 +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL KPP_ROOT_WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL KPP_ROOT_WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL KPP_ROOT_ros_Decomp( Ghimj, Pivot, ising, Ndec ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE KPP_ROOT_ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Decomp( A, Pivot, ising, Ndec ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + INTEGER, INTENT(INOUT) :: Ndec + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) +#else + CALL KPP_ROOT_KppDecomp ( A, ising ) + Pivot(1) = 1 +#endif + Ndec = Ndec + 1 + + END SUBROUTINE KPP_ROOT_ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_ros_Solve( A, Pivot, b, Nsol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~~> InOut args + INTEGER, INTENT(INOUT) :: nsol +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + + +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KPP_ROOT_KppSolve( A, b ) +#endif + + Nsol = Nsol+1 + + END SUBROUTINE KPP_ROOT_ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + g = 1.0_dp + 1.0_dp/SQRT(2.0_dp) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.0_dp)/g + ros_C(1) = (-2.0_dp)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.0_dp)/(2.0_dp*g) + ros_M(2)= (1.0_dp)/(2.0_dp*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.0_dp/(2.0_dp*g) + ros_E(2) = 1.0_dp/(2.0_dp*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 1.0_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE KPP_ROOT_Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.0_dp + ros_A(2)= 1.0_dp + ros_A(3)= 0.0_dp + + ros_C(1) = -0.10156171083877702091975600115545E+01_dp + ros_C(2) = 0.40759956452537699824805835358067E+01_dp + ros_C(3) = 0.92076794298330791242156818474003E+01_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1E+01_dp + ros_M(2) = 0.61697947043828245592553615689730E+01_dp + ros_M(3) = -0.42772256543218573326238373806514E+00_dp +! E_i = Coefficients for error estimator + ros_E(1) = 0.5E+00_dp + ros_E(2) = -0.29079558716805469821718236208017E+01_dp + ros_E(3) = 0.22354069897811569627360909276199E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0E+00_dp + ros_Alpha(2)= 0.43586652150845899941601945119356E+00_dp + ros_Alpha(3)= 0.43586652150845899941601945119356E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356E+00_dp + ros_Gamma(2)= 0.24291996454816804366592249683314E+00_dp + ros_Gamma(3)= 0.21851380027664058511513169485832E+01_dp + + END SUBROUTINE KPP_ROOT_Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(4), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(6), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(4), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000E+01_dp + ros_A(2) = 0.1867943637803922E+01_dp + ros_A(3) = 0.2344449711399156E+00_dp + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0_dp + + ros_C(1) =-0.7137615036412310E+01_dp + ros_C(2) = 0.2580708087951457E+01_dp + ros_C(3) = 0.6515950076447975E+00_dp + ros_C(4) =-0.2137148994382534E+01_dp + ros_C(5) =-0.3214669691237626E+00_dp + ros_C(6) =-0.6949742501781779E+00_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735E+01_dp + ros_M(2) = 0.2870493262186792E+00_dp + ros_M(3) = 0.4353179431840180E+00_dp + ros_M(4) = 0.1093502252409163E+01_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155E+00_dp + ros_E(2) =-0.7276199124938920E-01_dp + ros_E(3) =-0.1082196201495311E+00_dp + ros_E(4) =-0.1093502252409163E+01_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 0.1145640000000000E+01_dp + ros_Alpha(3) = 0.6552168638155900E+00_dp + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000E+00_dp + ros_Gamma(2) =-0.1769193891319233E+01_dp + ros_Gamma(3) = 0.7592633437920482E+00_dp + ros_Gamma(4) =-0.1049021087100450E+00_dp + + END SUBROUTINE KPP_ROOT_Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0E+00_dp + ros_A(2) = 2.0E+00_dp + ros_A(3) = 0.0E+00_dp + ros_A(4) = 2.0E+00_dp + ros_A(5) = 0.0E+00_dp + ros_A(6) = 1.0E+00_dp + + ros_C(1) = 4.0E+00_dp + ros_C(2) = 1.0E+00_dp + ros_C(3) =-1.0E+00_dp + ros_C(4) = 1.0E+00_dp + ros_C(5) =-1.0E+00_dp + ros_C(6) =-(8.0E+00_dp/3.0E+00_dp) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0E+00_dp + ros_M(2) = 0.0E+00_dp + ros_M(3) = 1.0E+00_dp + ros_M(4) = 1.0E+00_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 1.0E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0E+00_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0E+00_dp + ros_Alpha(2) = 0.0E+00_dp + ros_Alpha(3) = 1.0E+00_dp + ros_Alpha(4) = 1.0E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5E+00_dp + ros_Gamma(2) = 1.5E+00_dp + ros_Gamma(3) = 0.0E+00_dp + ros_Gamma(4) = 0.0E+00_dp + + END SUBROUTINE KPP_ROOT_Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KPP_ROOT_Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name +!cms DOUBLE PRECISION g + KPP_REAL :: g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000_dp + ros_Alpha(2) = 0.386_dp + ros_Alpha(3) = 0.210_dp + ros_Alpha(4) = 0.630_dp + ros_Alpha(5) = 1.000_dp + ros_Alpha(6) = 1.000_dp + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000E+00_dp + ros_Gamma(2) =-0.1043000000000000E+00_dp + ros_Gamma(3) = 0.1035000000000000E+00_dp + ros_Gamma(4) =-0.3620000000000023E-01_dp + ros_Gamma(5) = 0.0_dp + ros_Gamma(6) = 0.0_dp + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000E+01_dp + ros_A(2) = 0.9466785280815826E+00_dp + ros_A(3) = 0.2557011698983284E+00_dp + ros_A(4) = 0.3314825187068521E+01_dp + ros_A(5) = 0.2896124015972201E+01_dp + ros_A(6) = 0.9986419139977817E+00_dp + ros_A(7) = 0.1221224509226641E+01_dp + ros_A(8) = 0.6019134481288629E+01_dp + ros_A(9) = 0.1253708332932087E+02_dp + ros_A(10) =-0.6878860361058950E+00_dp + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0E+00_dp + + ros_C(1) =-0.5668800000000000E+01_dp + ros_C(2) =-0.2430093356833875E+01_dp + ros_C(3) =-0.2063599157091915E+00_dp + ros_C(4) =-0.1073529058151375E+00_dp + ros_C(5) =-0.9594562251023355E+01_dp + ros_C(6) =-0.2047028614809616E+02_dp + ros_C(7) = 0.7496443313967647E+01_dp + ros_C(8) =-0.1024680431464352E+02_dp + ros_C(9) =-0.3399990352819905E+02_dp + ros_C(10) = 0.1170890893206160E+02_dp + ros_C(11) = 0.8083246795921522E+01_dp + ros_C(12) =-0.7981132988064893E+01_dp + ros_C(13) =-0.3152159432874371E+02_dp + ros_C(14) = 0.1631930543123136E+02_dp + ros_C(15) =-0.6058818238834054E+01_dp + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0E+00_dp + ros_M(6) = 1.0E+00_dp + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 0.0E+00_dp + ros_E(5) = 0.0E+00_dp + ros_E(6) = 1.0E+00_dp + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp + + END SUBROUTINE KPP_ROOT_Rodas4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of the set of internal Rosenbrock subroutines +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END SUBROUTINE KPP_ROOT_Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_FunTemplate( T, Y, Ydot, RCONST, FIX, Nfun ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters +!! USE KPP_ROOT_Global +!! USE KPP_ROOT_Function +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: RCONST(NREACT) + KPP_REAL :: FIX(NFIX) +!~~~> Output variables + KPP_REAL :: Ydot(NVAR) + INTEGER :: Nfun + + +!~~~> Local variables +!! KPP_REAL :: Told + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() + CALL KPP_ROOT_Fun( Y, FIX, RCONST, Ydot ) +!! TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE KPP_ROOT_FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_JacTemplate( T, Y, Jcb, FIX, Njac, RCONST ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + !!USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian +!! USE KPP_ROOT_LinearAlgebra +!! USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) + KPP_REAL :: FIX(NFIX) + KPP_REAL :: RCONST(NREACT) + + INTEGER :: Njac + +!~~~> Output variables +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif +!~~~> Local variables + KPP_REAL :: Told +#ifdef FULL_ALGEBRA + INTEGER :: i, j +#endif + +!! Told = TIME +!! TIME = T +!! CALL Update_SUN() +!! CALL Update_RCONST() +#ifdef FULL_ALGEBRA + CALL KPP_ROOT_Jac_SP(Y, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL KPP_ROOT_Jac_SP( Y, FIX, RCONST, Jcb ) +#endif +!! TIME = Told + + Njac = Njac+1 + +END SUBROUTINE KPP_ROOT_JacTemplate + +!!!END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.def new file mode 100755 index 00000000..d5dade33 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.def @@ -0,0 +1,19 @@ + +#FUNCTION AGGREGATE +#JACOBIAN FULL +#DOUBLE ON +#INTFILE atm_lsodes + +#INLINE F77_GLOBAL + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=1.D-12 + STEPMAX=3600. + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.f new file mode 100755 index 00000000..9602b277 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_lsodes.f @@ -0,0 +1,5474 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + + PARAMETER ( LRW=20+3*1500+16*NVAR ) + PARAMETER ( LIW=60 ) + EXTERNAL FUNC_CHEM, JAC_CHEM + + KPP_REAL RWORK(LRW) + INTEGER IWORK(LIW) + + STEPCUT = 0. + MAXORD = 5 + IBEGIN = 1 + ITOL=4 + +C ---- NORMAL COMPUTATION --- + ITASK=1 + ISTATE=1 +C ---- USE OPTIONAL INPUT --- + IOPT=1 + + IWORK(5) = MAXORD ! MAX ORD + IWORK(6) = 20000 + IWORK(7) = 0 + RWORK(6) = STEPMAX ! STEP MAX + RWORK(7) = STEPMIN ! STEP MIN + RWORK(5) = STEPMIN ! INITIAL STEP + +C ----- SIGNAL FOR STIFF CASE, FULL JACOBIAN, INTERN (22) or SUPPLIED (21) + MF = 121 + + CALL atmlsodes (FUNC_CHEM, NVAR, VAR, TIN, TOUT, ITOL, RTOL, ATOL, + ! ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, + ! JAC_CHEM, MF) + + IF (ISTATE.LT.0) THEN + print *,'LSODES: Unsucessfull exit at T=', + & TIN,' (ISTATE=',ISTATE,')' + ENDIF + + RETURN + END + + subroutine atmlsodes (f, neq, y, t, tout, itol, RelTol, AbsTol, + 1 itask, istate, iopt, rwork, lrw, iwork, liw, jac, mf) + external f, jac + integer neq, itol, itask, istate, iopt, lrw, iwork, liw, mf + KPP_REAL y, t, tout, RelTol, AbsTol, rwork + dimension neq(1), y(1), RelTol(1), AbsTol(1), + 1 rwork(lrw), iwork(liw) +c----------------------------------------------------------------------- +c this is the march 30, 1987 version of +c lsodes.. livermore solver for ordinary differential equations +c with general sparse jacobian matrices. +c this version is in KPP_REAL. +c +c lsodes solves the initial value problem for stiff or nonstiff +c systems of first order ode-s, +c dy/dt = f(t,y) , or, in component form, +c dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(neq)) (i = 1,...,neq). +c lsodes is a variant of the lsode package, and is intended for +c problems in which the jacobian matrix df/dy has an arbitrary +c sparse structure (when the problem is stiff). +c +c authors.. alan c. hindmarsh, +c computing and mathematics research division, l-316 +c lawrence livermore national laboratory +c livermore, ca 94550. +c +c and andrew h. sherman +c j. s. nolen and associates +c houston, tx 77084 +c----------------------------------------------------------------------- +c references.. +c 1. alan c. hindmarsh, odepack, a systematized collection of ode +c solvers, in scientific computing, r. s. stepleman et al. (eds.), +c north-holland, amsterdam, 1983, pp. 55-64. +c +c 2. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, +c yale sparse matrix package.. i. the symmetric codes, +c int. j. num. meth. eng., 18 (1982), pp. 1145-1151. +c +c 3. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, +c yale sparse matrix package.. ii. the nonsymmetric codes, +c research report no. 114, dept. of computer sciences, yale +c university, 1977. +c----------------------------------------------------------------------- +c summary of usage. +c +c communication between the user and the lsodes package, for normal +c situations, is summarized here. this summary describes only a subset +c of the full set of options available. see the full description for +c details, including optional communication, nonstandard options, +c and instructions for special situations. see also the example +c problem (with program and output) following this summary. +c +c a. first provide a subroutine of the form.. +c subroutine f (neq, t, y, ydot) +c dimension y(neq), ydot(neq) +c which supplies the vector function f by loading ydot(i) with f(i). +c +c b. next determine (or guess) whether or not the problem is stiff. +c stiffness occurs when the jacobian matrix df/dy has an eigenvalue +c whose real part is negative and large in magnitude, compared to the +c reciprocal of the t span of interest. if the problem is nonstiff, +c use a method flag mf = 10. if it is stiff, there are two standard +c for the method flag, mf = 121 and mf = 222. in both cases, lsodes +c requires the jacobian matrix in some form, and it treats this matrix +c in general sparse form, with sparsity structure determined internally. +c (for options where the user supplies the sparsity structure, see +c the full description of mf below.) +c +c c. if the problem is stiff, you are encouraged to supply the jacobian +c directly (mf = 121), but if this is not feasible, lsodes will +c compute it internally by difference quotients (mf = 222). +c if you are supplying the jacobian, provide a subroutine of the form.. +c subroutine jac (neq, t, y, j, ian, jan, pdj) +c dimension y(1), ian(1), jan(1), pdj(1) +c here neq, t, y, and j are input arguments, and the jac routine is to +c load the array pdj (of length neq) with the j-th column of df/dy. +c i.e., load pdj(i) with df(i)/dy(j) for all relevant values of i. +c the arguments ian and jan should be ignored for normal situations. +c lsodes will CALL the jac routine with j = 1,2,...,neq. +c only nonzero elements need be loaded. usually, a crude approximation +c to df/dy, possibly with fewer nonzero elements, will suffice. +c +c d. write a main program which calls subroutine lsodes once for +c each point at which answers are desired. this should also provide +c for possible use of logical unit 6 for output of error messages +c by lsodes. on the first CALL to lsodes, supply arguments as follows.. +c f = name of subroutine for right-hand side vector f. +c this name must be declared external in calling program. +c neq = number of first order ode-s. +c y = array of initial values, of length neq. +c t = the initial value of the independent variable. +c tout = first point where output is desired (.ne. t). +c itol = 1 or 2 according as AbsTol (below) is a scalar or array. +c RelTol = relative tolerance parameter (scalar). +c AbsTol = absolute tolerance parameter (scalar or array). +c the estimated local error in y(i) will be controlled so as +c to be roughly less (in magnitude) than +c ewt(i) = RelTol*abs(y(i)) + AbsTol if itol = 1, or +c ewt(i) = RelTol*abs(y(i)) + AbsTol(i) if itol = 2. +c thus the local error test passes if, in each component, +c either the absolute error is less than AbsTol (or AbsTol(i)), +c or the relative error is less than RelTol. +c use RelTol = 0.0 for pure absolute error control, and +c use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative error +c control. caution.. actual (global) errors may exceed these +c local tolerances, so choose them conservatively. +c itask = 1 for normal computation of output values of y at t = tout. +c istate = integer flag (input and output). set istate = 1. +c iopt = 0 to indicate no optional inputs used. +c rwork = real work array of length at least.. +c 20 + 16*neq for mf = 10, +c 20 + (2 + 1./lenrat)*nnz + (11 + 9./lenrat)*neq +c for mf = 121 or 222, +c where.. +c nnz = the number of nonzero elements in the sparse +c jacobian (if this is unknown, use an estimate), and +c lenrat = the real to integer wordlength ratio (usually 1 in +c single precision and 2 in KPP_REAL). +c in any case, the required size of rwork cannot generally +c be predicted in advance if mf = 121 or 222, and the value +c above is a rough estimate of a crude lower bound. some +c experimentation with this size may be necessary. +c (when known, the correct required length is an optional +c output, available in iwork(17).) +c lrw = declared length of rwork (in user-s dimension). +c iwork = integer work array of length at least 30. +c liw = declared length of iwork (in user-s dimension). +c jac = name of subroutine for jacobian matrix (mf = 121). +c if used, this name must be declared external in calling +c program. if not used, pass a dummy name. +c mf = method flag. standard values are.. +c 10 for nonstiff (adams) method, no jacobian used. +c 121 for stiff (bdf) method, user-supplied sparse jacobian. +c 222 for stiff method, internally generated sparse jacobian. +c note that the main program must declare arrays y, rwork, iwork, +c and possibly AbsTol. +c +c e. the output from the first CALL (or any call) is.. +c y = array of computed values of y(t) vector. +c t = corresponding value of independent variable (normally tout). +c istate = 2 if lsodes was successful, negative otherwise. +c -1 means excess work done on this CALL (perhaps wrong mf). +c -2 means excess accuracy requested (tolerances too small). +c -3 means illegal input detected (see printed message). +c -4 means repeated error test failures (check all inputs). +c -5 means repeated convergence failures (perhaps bad jacobian +c supplied or wrong choice of mf or tolerances). +c -6 means error weight became zero during problem. (solution +c component i vanished, and AbsTol or AbsTol(i) = 0.) +c -7 means a fatal error return flag came from the sparse +c solver cdrv by way of prjs or slss. should never happen. +c a return with istate = -1, -4, or -5 may result from using +c an inappropriate sparsity structure, one that is quite +c different from the initial structure. consider calling +c lsodes again with istate = 3 to force the structure to be +c reevaluated. see the full description of istate below. +c +c f. to continue the integration after a successful return, simply +c reset tout and CALL lsodes again. no other parameters need be reset. +c +c----------------------------------------------------------------------- +c example problem. +c +c the following is a simple example problem, with the coding +c needed for its solution by lsodes. the problem is from chemical +c kinetics, and consists of the following 12 rate equations.. +c dy1/dt = -rk1*y1 +c dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 +c - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 +c dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 +c + rk11*rk14*y4 + rk12*rk14*y6 +c dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 +c dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 +c dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 +c dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 +c dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 +c dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 +c dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 +c + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 +c - rk6*y10 - rk9*y10 +c dy11/dt = rk10*y8 +c dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 +c - rk15*y2*y12 - rk17*y10*y12 +c +c with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, +c rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, +c rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, +c rk15 = rk17 = 100.0. +c +c the t interval is from 0 to 1000, and the initial conditions +c are y1 = 1, y2 = y3 = ... = y12 = 0. the problem is stiff. +c +c the following coding solves this problem with lsodes, using mf = 121 +c and printing results at t = .1, 1., 10., 100., 1000. it uses +c itol = 1 and mixed relative/absolute tolerance controls. +c during the run and at the end, statistical quantities of interest +c are printed (see optional outputs in the full description below). +c +c external fex, jex +c KPP_REAL AbsTol, RelTol, rwork, t, tout, y +c dimension y(12), rwork(500), iwork(30) +c data lrw/500/, liw/30/ +c neq = 12 +c do 10 i = 1,neq +c 10 y(i) = 0.0d0 +c y(1) = 1.0d0 +c t = 0.0d0 +c tout = 0.1d0 +c itol = 1 +c RelTol = 1.0d-4 +c AbsTol = 1.0d-6 +c itask = 1 +c istate = 1 +c iopt = 0 +c mf = 121 +c do 40 iout = 1,5 +c CALL lsodes (fex, neq, y, t, tout, itol, RelTol, AbsTol, +c 1 itask, istate, iopt, rwork, lrw, iwork, liw, jex, mf) +c write(6,30)t,iwork(11),rwork(11),(y(i),i=1,neq) +c 30 format(//7h at t =,e11.3,4x, +c 1 12h no. steps =,i5,4x,12h last step =,e11.3/ +c 2 13h y array = ,4e14.5/13x,4e14.5/13x,4e14.5) +c if (istate .lt. 0) go to 80 +c tout = tout*10.0d0 +c 40 continue +c lenrw = iwork(17) +c leniw = iwork(18) +c nst = iwork(11) +c nfe = iwork(12) +c nje = iwork(13) +c nlu = iwork(21) +c nnz = iwork(19) +c nnzlu = iwork(25) + iwork(26) + neq +c write (6,70) lenrw,leniw,nst,nfe,nje,nlu,nnz,nnzlu +c 70 format(//22h required rwork size =,i4,15h iwork size =,i4/ +c 1 12h no. steps =,i4,12h no. f-s =,i4,12h no. j-s =,i4, +c 2 13h no. lu-s =,i4/23h no. of nonzeros in j =,i5, +c 3 26h no. of nonzeros in lu =,i5) +c stop +c 80 write(6,90)istate +c 90 format(///22h error halt.. istate =,i3) +c stop +c end +c +c subroutine fex (neq, t, y, ydot) +c KPP_REAL t, y, ydot +c KPP_REAL rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, +c 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 +c dimension y(12), ydot(12) +c data rk1/0.1d0/, rk2/10.0d0/, rk3/50.0d0/, rk4/2.5d0/, rk5/0.1d0/, +c 1 rk6/10.0d0/, rk7/50.0d0/, rk8/2.5d0/, rk9/50.0d0/, rk10/5.0d0/, +c 2 rk11/50.0d0/, rk12/50.0d0/, rk13/50.0d0/, rk14/30.0d0/, +c 3 rk15/100.0d0/, rk16/2.5d0/, rk17/100.0d0/, rk18/2.5d0/, +c 4 rk19/50.0d0/, rk20/50.0d0/ +c ydot(1) = -rk1*y(1) +c ydot(2) = rk1*y(1) + rk11*rk14*y(4) + rk19*rk14*y(5) +c 1 - rk3*y(2)*y(3) - rk15*y(2)*y(12) - rk2*y(2) +c ydot(3) = rk2*y(2) - rk5*y(3) - rk3*y(2)*y(3) - rk7*y(10)*y(3) +c 1 + rk11*rk14*y(4) + rk12*rk14*y(6) +c ydot(4) = rk3*y(2)*y(3) - rk11*rk14*y(4) - rk4*y(4) +c ydot(5) = rk15*y(2)*y(12) - rk19*rk14*y(5) - rk16*y(5) +c ydot(6) = rk7*y(10)*y(3) - rk12*rk14*y(6) - rk8*y(6) +c ydot(7) = rk17*y(10)*y(12) - rk20*rk14*y(7) - rk18*y(7) +c ydot(8) = rk9*y(10) - rk13*rk14*y(8) - rk10*y(8) +c ydot(9) = rk4*y(4) + rk16*y(5) + rk8*y(6) + rk18*y(7) +c ydot(10) = rk5*y(3) + rk12*rk14*y(6) + rk20*rk14*y(7) +c 1 + rk13*rk14*y(8) - rk7*y(10)*y(3) - rk17*y(10)*y(12) +c 2 - rk6*y(10) - rk9*y(10) +c ydot(11) = rk10*y(8) +c ydot(12) = rk6*y(10) + rk19*rk14*y(5) + rk20*rk14*y(7) +c 1 - rk15*y(2)*y(12) - rk17*y(10)*y(12) +c return +c end +c +c subroutine jex (neq, t, y, j, ia, ja, pdj) +c KPP_REAL t, y, pdj +c KPP_REAL rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, +c 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 +c dimension y(1), ia(1), ja(1), pdj(1) +c data rk1/0.1d0/, rk2/10.0d0/, rk3/50.0d0/, rk4/2.5d0/, rk5/0.1d0/, +c 1 rk6/10.0d0/, rk7/50.0d0/, rk8/2.5d0/, rk9/50.0d0/, rk10/5.0d0/, +c 2 rk11/50.0d0/, rk12/50.0d0/, rk13/50.0d0/, rk14/30.0d0/, +c 3 rk15/100.0d0/, rk16/2.5d0/, rk17/100.0d0/, rk18/2.5d0/, +c 4 rk19/50.0d0/, rk20/50.0d0/ +c go to (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), j +c 1 pdj(1) = -rk1 +c pdj(2) = rk1 +c return +c 2 pdj(2) = -rk3*y(3) - rk15*y(12) - rk2 +c pdj(3) = rk2 - rk3*y(3) +c pdj(4) = rk3*y(3) +c pdj(5) = rk15*y(12) +c pdj(12) = -rk15*y(12) +c return +c 3 pdj(2) = -rk3*y(2) +c pdj(3) = -rk5 - rk3*y(2) - rk7*y(10) +c pdj(4) = rk3*y(2) +c pdj(6) = rk7*y(10) +c pdj(10) = rk5 - rk7*y(10) +c return +c 4 pdj(2) = rk11*rk14 +c pdj(3) = rk11*rk14 +c pdj(4) = -rk11*rk14 - rk4 +c pdj(9) = rk4 +c return +c 5 pdj(2) = rk19*rk14 +c pdj(5) = -rk19*rk14 - rk16 +c pdj(9) = rk16 +c pdj(12) = rk19*rk14 +c return +c 6 pdj(3) = rk12*rk14 +c pdj(6) = -rk12*rk14 - rk8 +c pdj(9) = rk8 +c pdj(10) = rk12*rk14 +c return +c 7 pdj(7) = -rk20*rk14 - rk18 +c pdj(9) = rk18 +c pdj(10) = rk20*rk14 +c pdj(12) = rk20*rk14 +c return +c 8 pdj(8) = -rk13*rk14 - rk10 +c pdj(10) = rk13*rk14 +c pdj(11) = rk10 +c 9 return +c 10 pdj(3) = -rk7*y(3) +c pdj(6) = rk7*y(3) +c pdj(7) = rk17*y(12) +c pdj(8) = rk9 +c pdj(10) = -rk7*y(3) - rk17*y(12) - rk6 - rk9 +c pdj(12) = rk6 - rk17*y(12) +c 11 return +c 12 pdj(2) = -rk15*y(2) +c pdj(5) = rk15*y(2) +c pdj(7) = rk17*y(10) +c pdj(10) = -rk17*y(10) +c pdj(12) = -rk15*y(2) - rk17*y(10) +c return +c end +c +c the output of this program (on a cray-1 in single precision) +c is as follows.. +c +c +c at t = 1.000e-01 no. steps = 12 last step = 1.515e-02 +c y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 +c 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 +c 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 +c +c +c at t = 1.000e+00 no. steps = 33 last step = 7.880e-02 +c y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 +c 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 +c 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 +c +c +c at t = 1.000e+01 no. steps = 48 last step = 1.239e+00 +c y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 +c 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 +c 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 +c +c +c at t = 1.000e+02 no. steps = 91 last step = 3.764e+00 +c y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 +c 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 +c 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 +c +c +c at t = 1.000e+03 no. steps = 111 last step = 4.156e+02 +c y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 +c -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 +c 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 +c +c +c required rwork size = 442 iwork size = 30 +c no. steps = 111 no. f-s = 142 no. j-s = 2 no. lu-s = 20 +c no. of nonzeros in j = 44 no. of nonzeros in lu = 50 +c----------------------------------------------------------------------- +c full description of user interface to lsodes. +c +c the user interface to lsodes consists of the following parts. +c +c i. the CALL sequence to subroutine lsodes, which is a driver +c routine for the solver. this includes descriptions of both +c the CALL sequence arguments and of user-supplied routines. +c following these descriptions is a description of +c optional inputs available through the CALL sequence, and then +c a description of optional outputs (in the work arrays). +c +c ii. descriptions of other routines in the lsodes package that may be +c (optionally) called by the user. these provide the ability to +c alter error message handling, save and restore the internal +c common, and obtain specified derivatives of the solution y(t). +c +c iii. descriptions of common blocks to be declared in overlay +c or similar environments, or to be saved when doing an interrupt +c of the problem and continued solution later. +c +c iv. description of two routines in the lsodes package, either of +c which the user may replace with his own version, if desired. +c these relate to the measurement of errors. +c +c----------------------------------------------------------------------- +c part i. CALL sequence. +c +c the CALL sequence parameters used for input only are +c f, neq, tout, itol, RelTol, AbsTol, itask, iopt, lrw, liw, jac, mf, +c and those used for both input and output are +c y, t, istate. +c the work arrays rwork and iwork are also used for conditional and +c optional inputs and optional outputs. (the term output here refers +c to the return from subroutine lsodes to the user-s calling program.) +c +c the legality of input parameters will be thoroughly checked on the +c initial CALL for the problem, but not checked thereafter unless a +c change in input parameters is flagged by istate = 3 on input. +c +c the descriptions of the CALL arguments are as follows. +c +c f = the name of the user-supplied subroutine defining the +c ode system. the system must be put in the first-order +c form dy/dt = f(t,y), where f is a vector-valued function +c of the scalar t and the vector y. subroutine f is to +c compute the function f. it is to have the form +c subroutine f (neq, t, y, ydot) +c dimension y(1), ydot(1) +c where neq, t, and y are input, and the array ydot = f(t,y) +c is output. y and ydot are arrays of length neq. +c (in the dimension statement above, 1 is a dummy +c dimension.. it can be replaced by any value.) +c subroutine f should not alter y(1),...,y(neq). +c f must be declared external in the calling program. +c +c subroutine f may access user-defined quantities in +c neq(2),... and/or in y(neq(1)+1),... if neq is an array +c (dimensioned in f) and/or y has length exceeding neq(1). +c see the descriptions of neq and y below. +c +c if quantities computed in the f routine are needed +c externally to lsodes, an extra CALL to f should be made +c for this purpose, for consistent and accurate results. +c if only the derivative dy/dt is needed, use intdy instead. +c +c neq = the size of the ode system (number of first order +c ordinary differential equations). used only for input. +c neq may be decreased, but not increased, during the problem. +c if neq is decreased (with istate = 3 on input), the +c remaining components of y should be left undisturbed, if +c these are to be accessed in f and/or jac. +c +c normally, neq is a scalar, and it is generally referred to +c as a scalar in this user interface description. however, +c neq may be an array, with neq(1) set to the system size. +c (the lsodes package accesses only neq(1).) in either case, +c this parameter is passed as the neq argument in all calls +c to f and jac. hence, if it is an array, locations +c neq(2),... may be used to store other integer data and pass +c it to f and/or jac. subroutines f and/or jac must include +c neq in a dimension statement in that case. +c +c y = a real array for the vector of dependent variables, of +c length neq or more. used for both input and output on the +c first CALL (istate = 1), and only for output on other calls. +c on the first call, y must contain the vector of initial +c values. on output, y contains the computed solution vector, +c evaluated at t. if desired, the y array may be used +c for other purposes between calls to the solver. +c +c this array is passed as the y argument in all calls to +c f and jac. hence its length may exceed neq, and locations +c y(neq+1),... may be used to store other real data and +c pass it to f and/or jac. (the lsodes package accesses only +c y(1),...,y(neq).) +c +c t = the independent variable. on input, t is used only on the +c first call, as the initial point of the integration. +c on output, after each call, t is the value at which a +c computed solution y is evaluated (usually the same as tout). +c on an error return, t is the farthest point reached. +c +c tout = the next value of t at which a computed solution is desired. +c used only for input. +c +c when starting the problem (istate = 1), tout may be equal +c to t for one call, then should .ne. t for the next call. +c for the initial t, an input value of tout .ne. t is used +c in order to determine the direction of the integration +c (i.e. the algebraic sign of the step sizes) and the rough +c scale of the problem. integration in either direction +c (forward or backward in t) is permitted. +c +c if itask = 2 or 5 (one-step modes), tout is ignored after +c the first CALL (i.e. the first CALL with tout .ne. t). +c otherwise, tout is required on every call. +c +c if itask = 1, 3, or 4, the values of tout need not be +c monotone, but a value of tout which backs up is limited +c to the current internal t interval, whose endpoints are +c tcur - hu and tcur (see optional outputs, below, for +c tcur and hu). +c +c itol = an indicator for the type of error control. see +c description below under AbsTol. used only for input. +c +c RelTol = a relative error tolerance parameter, either a scalar or +c an array of length neq. see description below under AbsTol. +c input only. +c +c AbsTol = an absolute error tolerance parameter, either a scalar or +c an array of length neq. input only. +c +c the input parameters itol, RelTol, and AbsTol determine +c the error control performed by the solver. the solver will +c control the vector e = (e(i)) of estimated local errors +c in y, according to an inequality of the form +c rms-norm of ( e(i)/ewt(i) ) .le. 1, +c where ewt(i) = RelTol(i)*abs(y(i)) + AbsTol(i), +c and the rms-norm (root-mean-square norm) here is +c rms-norm(v) = sqrt(sum v(i)**2 / neq). here ewt = (ewt(i)) +c is a vector of weights which must always be positive, and +c the values of RelTol and AbsTol should all be non-negative. +c the following table gives the types (scalar/array) of +c RelTol and AbsTol, and the corresponding form of ewt(i). +c +c itol RelTol AbsTol ewt(i) +c 1 scalar scalar RelTol*abs(y(i)) + AbsTol +c 2 scalar array RelTol*abs(y(i)) + AbsTol(i) +c 3 array scalar RelTol(i)*abs(y(i)) + AbsTol +c 4 array array RelTol(i)*abs(y(i)) + AbsTol(i) +c +c when either of these parameters is a scalar, it need not +c be dimensioned in the user-s calling program. +c +c if none of the above choices (with itol, RelTol, and AbsTol +c fixed throughout the problem) is suitable, more general +c error controls can be obtained by substituting +c user-supplied routines for the setting of ewt and/or for +c the norm calculation. see part iv below. +c +c if global errors are to be estimated by making a repeated +c run on the same problem with smaller tolerances, then all +c components of RelTol and AbsTol (i.e. of ewt) should be scaled +c down uniformly. +c +c itask = an index specifying the task to be performed. +c input only. itask has the following values and meanings. +c 1 means normal computation of output values of y(t) at +c t = tout (by overshooting and interpolating). +c 2 means take one step only and return. +c 3 means stop at the first internal mesh point at or +c beyond t = tout and return. +c 4 means normal computation of output values of y(t) at +c t = tout but without overshooting t = tcrit. +c tcrit must be input as rwork(1). tcrit may be equal to +c or beyond tout, but not behind it in the direction of +c integration. this option is useful if the problem +c has a singularity at or beyond t = tcrit. +c 5 means take one step, without passing tcrit, and return. +c tcrit must be input as rwork(1). +c +c note.. if itask = 4 or 5 and the solver reaches tcrit +c (within roundoff), it will return t = tcrit (exactly) to +c indicate this (unless itask = 4 and tout comes before tcrit, +c in which case answers at t = tout are returned first). +c +c istate = an index used for input and output to specify the +c the state of the calculation. +c +c on input, the values of istate are as follows. +c 1 means this is the first CALL for the problem +c (initializations will be done). see note below. +c 2 means this is not the first call, and the calculation +c is to continue normally, with no change in any input +c parameters except possibly tout and itask. +c (if itol, RelTol, and/or AbsTol are changed between calls +c with istate = 2, the new values will be used but not +c tested for legality.) +c 3 means this is not the first call, and the +c calculation is to continue normally, but with +c a change in input parameters other than +c tout and itask. changes are allowed in +c neq, itol, RelTol, AbsTol, iopt, lrw, liw, mf, +c the conditional inputs ia and ja, +c and any of the optional inputs except h0. +c in particular, if miter = 1 or 2, a CALL with istate = 3 +c will cause the sparsity structure of the problem to be +c recomputed (or reread from ia and ja if moss = 0). +c note.. a preliminary CALL with tout = t is not counted +c as a first CALL here, as no initialization or checking of +c input is done. (such a CALL is sometimes useful for the +c purpose of outputting the initial conditions.) +c thus the first CALL for which tout .ne. t requires +c istate = 1 on input. +c +c on output, istate has the following values and meanings. +c 1 means nothing was done, as tout was equal to t with +c istate = 1 on input. (however, an internal counter was +c set to detect and prevent repeated calls of this type.) +c 2 means the integration was performed successfully. +c -1 means an excessive amount of work (more than mxstep +c steps) was done on this call, before completing the +c requested task, but the integration was otherwise +c successful as far as t. (mxstep is an optional input +c and is normally 500.) to continue, the user may +c simply reset istate to a value .gt. 1 and CALL again +c (the excess work step counter will be reset to 0). +c in addition, the user may increase mxstep to avoid +c this error return (see below on optional inputs). +c -2 means too much accuracy was requested for the precision +c of the machine being used. this was detected before +c completing the requested task, but the integration +c was successful as far as t. to continue, the tolerance +c parameters must be reset, and istate must be set +c to 3. the optional output tolsf may be used for this +c purpose. (note.. if this condition is detected before +c taking any steps, then an illegal input return +c (istate = -3) occurs instead.) +c -3 means illegal input was detected, before taking any +c integration steps. see written message for details. +c note.. if the solver detects an infinite loop of calls +c to the solver with illegal input, it will cause +c the run to stop. +c -4 means there were repeated error test failures on +c one attempted step, before completing the requested +c task, but the integration was successful as far as t. +c the problem may have a singularity, or the input +c may be inappropriate. +c -5 means there were repeated convergence test failures on +c one attempted step, before completing the requested +c task, but the integration was successful as far as t. +c this may be caused by an inaccurate jacobian matrix, +c if one is being used. +c -6 means ewt(i) became zero for some i during the +c integration. pure relative error control (AbsTol(i)=0.0) +c was requested on a variable which has now vanished. +c the integration was successful as far as t. +c -7 means a fatal error return flag came from the sparse +c solver cdrv by way of prjs or slss (numerical +c factorization or backsolve). this should never happen. +c the integration was successful as far as t. +c +c note.. an error return with istate = -1, -4, or -5 and with +c miter = 1 or 2 may mean that the sparsity structure of the +c problem has changed significantly since it was last +c determined (or input). in that case, one can attempt to +c complete the integration by setting istate = 3 on the next +c call, so that a new structure determination is done. +c +c note.. since the normal output value of istate is 2, +c it does not need to be reset for normal continuation. +c also, since a negative input value of istate will be +c regarded as illegal, a negative output value requires the +c user to change it, and possibly other inputs, before +c calling the solver again. +c +c iopt = an integer flag to specify whether or not any optional +c inputs are being used on this call. input only. +c the optional inputs are listed separately below. +c iopt = 0 means no optional inputs are being used. +c default values will be used in all cases. +c iopt = 1 means one or more optional inputs are being used. +c +c rwork = a work array used for a mixture of real (KPP_REAL) +c and integer work space. +c the length of rwork (in real words) must be at least +c 20 + nyh*(maxord + 1) + 3*neq + lwm where +c nyh = the initial value of neq, +c maxord = 12 (if meth = 1) or 5 (if meth = 2) (unless a +c smaller value is given as an optional input), +c lwm = 0 if miter = 0, +c lwm = 2*nnz + 2*neq + (nnz+9*neq)/lenrat if miter = 1, +c lwm = 2*nnz + 2*neq + (nnz+10*neq)/lenrat if miter = 2, +c lwm = neq + 2 if miter = 3. +c in the above formulas, +c nnz = number of nonzero elements in the jacobian matrix. +c lenrat = the real to integer wordlength ratio (usually 1 in +c single precision and 2 in KPP_REAL). +c (see the mf description for meth and miter.) +c thus if maxord has its default value and neq is constant, +c the minimum length of rwork is.. +c 20 + 16*neq for mf = 10, +c 20 + 16*neq + lwm for mf = 11, 111, 211, 12, 112, 212, +c 22 + 17*neq for mf = 13, +c 20 + 9*neq for mf = 20, +c 20 + 9*neq + lwm for mf = 21, 121, 221, 22, 122, 222, +c 22 + 10*neq for mf = 23. +c if miter = 1 or 2, the above formula for lwm is only a +c crude lower bound. the required length of rwork cannot +c be readily predicted in general, as it depends on the +c sparsity structure of the problem. some experimentation +c may be necessary. +c +c the first 20 words of rwork are reserved for conditional +c and optional inputs and optional outputs. +c +c the following word in rwork is a conditional input.. +c rwork(1) = tcrit = critical value of t which the solver +c is not to overshoot. required if itask is +c 4 or 5, and ignored otherwise. (see itask.) +c +c lrw = the length of the array rwork, as declared by the user. +c (this will be checked by the solver.) +c +c iwork = an integer work array. the length of iwork must be at least +c 31 + neq + nnz if moss = 0 and miter = 1 or 2, or +c 30 otherwise. +c (nnz is the number of nonzero elements in df/dy.) +c +c in lsodes, iwork is used only for conditional and +c optional inputs and optional outputs. +c +c the following two blocks of words in iwork are conditional +c inputs, required if moss = 0 and miter = 1 or 2, but not +c otherwise (see the description of mf for moss). +c iwork(30+j) = ia(j) (j=1,...,neq+1) +c iwork(31+neq+k) = ja(k) (k=1,...,nnz) +c the two arrays ia and ja describe the sparsity structure +c to be assumed for the jacobian matrix. ja contains the row +c indices where nonzero elements occur, reading in columnwise +c order, and ia contains the starting locations in ja of the +c descriptions of columns 1,...,neq, in that order, with +c ia(1) = 1. thus, for each column index j = 1,...,neq, the +c values of the row index i in column j where a nonzero +c element may occur are given by +c i = ja(k), where ia(j) .le. k .lt. ia(j+1). +c if nnz is the total number of nonzero locations assumed, +c then the length of the ja array is nnz, and ia(neq+1) must +c be nnz + 1. duplicate entries are not allowed. +c +c liw = the length of the array iwork, as declared by the user. +c (this will be checked by the solver.) +c +c note.. the work arrays must not be altered between calls to lsodes +c for the same problem, except possibly for the conditional and +c optional inputs, and except for the last 3*neq words of rwork. +c the latter space is used for internal scratch space, and so is +c available for use by the user outside lsodes between calls, if +c desired (but not for use by f or jac). +c +c jac = name of user-supplied routine (miter = 1 or moss = 1) to +c compute the jacobian matrix, df/dy, as a function of +c the scalar t and the vector y. it is to have the form +c subroutine jac (neq, t, y, j, ian, jan, pdj) +c dimension y(1), ian(1), jan(1), pdj(1) +c where neq, t, y, j, ian, and jan are input, and the array +c pdj, of length neq, is to be loaded with column j +c of the jacobian on output. thus df(i)/dy(j) is to be +c loaded into pdj(i) for all relevant values of i. +c here t and y have the same meaning as in subroutine f, +c and j is a column index (1 to neq). ian and jan are +c undefined in calls to jac for structure determination +c (moss = 1). otherwise, ian and jan are structure +c descriptors, as defined under optional outputs below, and +c so can be used to determine the relevant row indices i, if +c desired. (in the dimension statement above, 1 is a +c dummy dimension.. it can be replaced by any value.) +c jac need not provide df/dy exactly. a crude +c approximation (possibly with greater sparsity) will do. +c in any case, pdj is preset to zero by the solver, +c so that only the nonzero elements need be loaded by jac. +c calls to jac are made with j = 1,...,neq, in that order, and +c each such set of calls is preceded by a CALL to f with the +c same arguments neq, t, and y. thus to gain some efficiency, +c intermediate quantities shared by both calculations may be +c saved in a user common block by f and not recomputed by jac, +c if desired. jac must not alter its input arguments. +c jac must be declared external in the calling program. +c subroutine jac may access user-defined quantities in +c neq(2),... and y(neq(1)+1),... if neq is an array +c (dimensioned in jac) and y has length exceeding neq(1). +c see the descriptions of neq and y above. +c +c mf = the method flag. used only for input. +c mf has three decimal digits-- moss, meth, miter-- +c mf = 100*moss + 10*meth + miter. +c moss indicates the method to be used to obtain the sparsity +c structure of the jacobian matrix if miter = 1 or 2.. +c moss = 0 means the user has supplied ia and ja +c (see descriptions under iwork above). +c moss = 1 means the user has supplied jac (see below) +c and the structure will be obtained from neq +c initial calls to jac. +c moss = 2 means the structure will be obtained from neq+1 +c initial calls to f. +c meth indicates the basic linear multistep method.. +c meth = 1 means the implicit adams method. +c meth = 2 means the method based on backward +c differentiation formulas (bdf-s). +c miter indicates the corrector iteration method.. +c miter = 0 means functional iteration (no jacobian matrix +c is involved). +c miter = 1 means chord iteration with a user-supplied +c sparse jacobian, given by subroutine jac. +c miter = 2 means chord iteration with an internally +c generated (difference quotient) sparse jacobian +c (using ngp extra calls to f per df/dy value, +c where ngp is an optional output described below.) +c miter = 3 means chord iteration with an internally +c generated diagonal jacobian approximation. +c (using 1 extra CALL to f per df/dy evaluation). +c if miter = 1 or moss = 1, the user must supply a subroutine +c jac (the name is arbitrary) as described above under jac. +c otherwise, a dummy argument can be used. +c +c the standard choices for mf are.. +c mf = 10 for a nonstiff problem, +c mf = 21 or 22 for a stiff problem with ia/ja supplied +c (21 if jac is supplied, 22 if not), +c mf = 121 for a stiff problem with jac supplied, +c but not ia/ja, +c mf = 222 for a stiff problem with neither ia/ja nor +c jac supplied. +c the sparseness structure can be changed during the +c problem by making a CALL to lsodes with istate = 3. +c----------------------------------------------------------------------- +c optional inputs. +c +c the following is a list of the optional inputs provided for in the +c CALL sequence. (see also part ii.) for each such input variable, +c this table lists its name as used in this documentation, its +c location in the CALL sequence, its meaning, and the default value. +c the use of any of these inputs requires iopt = 1, and in that +c case all of these inputs are examined. a value of zero for any +c of these optional inputs will cause the default value to be used. +c thus to use a subset of the optional inputs, simply preload +c locations 5 to 10 in rwork and iwork to 0.0 and 0 respectively, and +c then set those of interest to nonzero values. +c +c name location meaning and default value +c +c h0 rwork(5) the step size to be attempted on the first step. +c the default value is determined by the solver. +c +c hmax rwork(6) the maximum absolute step size allowed. +c the default value is infinite. +c +c hmin rwork(7) the minimum absolute step size allowed. +c the default value is 0. (this lower bound is not +c enforced on the final step before reaching tcrit +c when itask = 4 or 5.) +c +c seth rwork(8) the element threshhold for sparsity determination +c when moss = 1 or 2. if the absolute value of +c an estimated jacobian element is .le. seth, it +c will be assumed to be absent in the structure. +c the default value of seth is 0. +c +c maxord iwork(5) the maximum order to be allowed. the default +c value is 12 if meth = 1, and 5 if meth = 2. +c if maxord exceeds the default value, it will +c be reduced to the default value. +c if maxord is changed during the problem, it may +c cause the current order to be reduced. +c +c mxstep iwork(6) maximum number of (internally defined) steps +c allowed during one CALL to the solver. +c the default value is 500. +c +c mxhnil iwork(7) maximum number of messages printed (per problem) +c warning that t + h = t on a step (h = step size). +c this must be positive to result in a non-default +c value. the default value is 10. +c----------------------------------------------------------------------- +c optional outputs. +c +c as optional additional output from lsodes, the variables listed +c below are quantities related to the performance of lsodes +c which are available to the user. these are communicated by way of +c the work arrays, but also have internal mnemonic names as shown. +c except where stated otherwise, all of these outputs are defined +c on any successful return from lsodes, and on any return with +c istate = -1, -2, -4, -5, or -6. on an illegal input return +c (istate = -3), they will be unchanged from their existing values +c (if any), except possibly for tolsf, lenrw, and leniw. +c on any error return, outputs relevant to the error will be defined, +c as noted below. +c +c name location meaning +c +c hu rwork(11) the step size in t last used (successfully). +c +c hcur rwork(12) the step size to be attempted on the next step. +c +c tcur rwork(13) the current value of the independent variable +c which the solver has actually reached, i.e. the +c current internal mesh point in t. on output, tcur +c will always be at least as far as the argument +c t, but may be farther (if interpolation was done). +c +c tolsf rwork(14) a tolerance scale factor, greater than 1.0, +c computed when a request for too much accuracy was +c detected (istate = -3 if detected at the start of +c the problem, istate = -2 otherwise). if itol is +c left unaltered but RelTol and AbsTol are uniformly +c scaled up by a factor of tolsf for the next call, +c then the solver is deemed likely to succeed. +c (the user may also ignore tolsf and alter the +c tolerance parameters in any other way appropriate.) +c +c nst iwork(11) the number of steps taken for the problem so far. +c +c nfe iwork(12) the number of f evaluations for the problem so far, +c excluding those for structure determination +c (moss = 2). +c +c nje iwork(13) the number of jacobian evaluations for the problem +c so far, excluding those for structure determination +c (moss = 1). +c +c nqu iwork(14) the method order last used (successfully). +c +c nqcur iwork(15) the order to be attempted on the next step. +c +c imxer iwork(16) the index of the component of largest magnitude in +c the weighted local error vector ( e(i)/ewt(i) ), +c on an error return with istate = -4 or -5. +c +c lenrw iwork(17) the length of rwork actually required. +c this is defined on normal returns and on an illegal +c input return for insufficient storage. +c +c leniw iwork(18) the length of iwork actually required. +c this is defined on normal returns and on an illegal +c input return for insufficient storage. +c +c nnz iwork(19) the number of nonzero elements in the jacobian +c matrix, including the diagonal (miter = 1 or 2). +c (this may differ from that given by ia(neq+1)-1 +c if moss = 0, because of added diagonal entries.) +c +c ngp iwork(20) the number of groups of column indices, used in +c difference quotient jacobian aproximations if +c miter = 2. this is also the number of extra f +c evaluations needed for each jacobian evaluation. +c +c nlu iwork(21) the number of sparse lu decompositions for the +c problem so far. +c +c lyh iwork(22) the base address in rwork of the history array yh, +c described below in this list. +c +c ipian iwork(23) the base address of the structure descriptor array +c ian, described below in this list. +c +c ipjan iwork(24) the base address of the structure descriptor array +c jan, described below in this list. +c +c nzl iwork(25) the number of nonzero elements in the strict lower +c triangle of the lu factorization used in the chord +c iteration (miter = 1 or 2). +c +c nzu iwork(26) the number of nonzero elements in the strict upper +c triangle of the lu factorization used in the chord +c iteration (miter = 1 or 2). +c the total number of nonzeros in the factorization +c is therefore nzl + nzu + neq. +c +c the following four arrays are segments of the rwork array which +c may also be of interest to the user as optional outputs. +c for each array, the table below gives its internal name, +c its base address, and its description. +c for yh and acor, the base addresses are in rwork (a real array). +c the integer arrays ian and jan are to be obtained by declaring an +c integer array iwk and identifying iwk(1) with rwork(21), using either +c an equivalence statement or a subroutine call. then the base +c addresses ipian (of ian) and ipjan (of jan) in iwk are to be obtained +c as optional outputs iwork(23) and iwork(24), respectively. +c thus ian(1) is iwk(ipian), etc. +c +c name base address description +c +c ian ipian (in iwk) structure descriptor array of size neq + 1. +c jan ipjan (in iwk) structure descriptor array of size nnz. +c (see above) ian and jan together describe the sparsity +c structure of the jacobian matrix, as used by +c lsodes when miter = 1 or 2. +c jan contains the row indices of the nonzero +c locations, reading in columnwise order, and +c ian contains the starting locations in jan of +c the descriptions of columns 1,...,neq, in +c that order, with ian(1) = 1. thus for each +c j = 1,...,neq, the row indices i of the +c nonzero locations in column j are +c i = jan(k), ian(j) .le. k .lt. ian(j+1). +c note that ian(neq+1) = nnz + 1. +c (if moss = 0, ian/jan may differ from the +c input ia/ja because of a different ordering +c in each column, and added diagonal entries.) +c +c yh lyh the nordsieck history array, of size nyh by +c (optional (nqcur + 1), where nyh is the initial value +c output) of neq. for j = 0,1,...,nqcur, column j+1 +c of yh contains hcur**j/factorial(j) times +c the j-th derivative of the interpolating +c polynomial currently representing the solution, +c evaluated at t = tcur. the base address lyh +c is another optional output, listed above. +c +c acor lenrw-neq+1 array of size neq used for the accumulated +c corrections on each step, scaled on output +c to represent the estimated local error in y +c on the last step. this is the vector e in +c the description of the error control. it is +c defined only on a successful return from +c lsodes. +c +c----------------------------------------------------------------------- +c part ii. other routines callable. +c +c the following are optional calls which the user may make to +c gain additional capabilities in conjunction with lsodes. +c (the routines xsetun and xsetf are designed to conform to the +c slatec error handling package.) +c +c form of CALL function +c CALL xsetun(lun) set the logical unit number, lun, for +c output of messages from lsodes, if +c the default is not desired. +c the default value of lun is 6. +c +c CALL xsetf(mflag) set a flag to control the printing of +c messages by lsodes. +c mflag = 0 means do not print. (danger.. +c this risks losing valuable information.) +c mflag = 1 means print (the default). +c +c either of the above calls may be made at +c any time and will take effect immediately. +c +c CALL srcms(rsav,isav,job) saves and restores the contents of +c the internal common blocks used by +c lsodes (see part iii below). +c rsav must be a real array of length 224 +c or more, and isav must be an integer +c array of length 75 or more. +c job=1 means save common into rsav/isav. +c job=2 means restore common from rsav/isav. +c srcms is useful if one is +c interrupting a run and restarting +c later, or alternating between two or +c more problems solved with lsodes. +c +c CALL intdy(,,,,,) provide derivatives of y, of various +c (see below) orders, at a specified point t, if +c desired. it may be called only after +c a successful return from lsodes. +c +c the detailed instructions for using intdy are as follows. +c the form of the CALL is.. +c +c lyh = iwork(22) +c CALL intdy (t, k, rwork(lyh), nyh, dky, iflag) +c +c the input parameters are.. +c +c t = value of independent variable where answers are desired +c (normally the same as the t last returned by lsodes). +c for valid results, t must lie between tcur - hu and tcur. +c (see optional outputs for tcur and hu.) +c k = integer order of the derivative desired. k must satisfy +c 0 .le. k .le. nqcur, where nqcur is the current order +c (see optional outputs). the capability corresponding +c to k = 0, i.e. computing y(t), is already provided +c by lsodes directly. since nqcur .ge. 1, the first +c derivative dy/dt is always available with intdy. +c lyh = the base address of the history array yh, obtained +c as an optional output as shown above. +c nyh = column length of yh, equal to the initial value of neq. +c +c the output parameters are.. +c +c dky = a real array of length neq containing the computed value +c of the k-th derivative of y(t). +c iflag = integer flag, returned as 0 if k and t were legal, +c -1 if k was illegal, and -2 if t was illegal. +c on an error return, a message is also written. +c----------------------------------------------------------------------- +c part iii. common blocks. +c +c if lsodes is to be used in an overlay situation, the user +c must declare, in the primary overlay, the variables in.. +c (1) the CALL sequence to lsodes, +c (2) the three internal common blocks +c /ls0001/ of length 257 (218 KPP_REAL words +c followed by 39 integer words), +c /lss001/ of length 40 ( 6 KPP_REAL words +c followed by 34 integer words), +c /eh0001/ of length 2 (integer words). +c +c if lsodes is used on a system in which the contents of internal +c common blocks are not preserved between calls, the user should +c declare the above three common blocks in his main program to insure +c that their contents are preserved. +c +c if the solution of a given problem by lsodes is to be interrupted +c and then later continued, such as when restarting an interrupted run +c or alternating between two or more problems, the user should save, +c following the return from the last lsodes CALL prior to the +c interruption, the contents of the CALL sequence variables and the +c internal common blocks, and later restore these values before the +c next lsodes CALL for that problem. to save and restore the common +c blocks, use subroutine srcms (see part ii above). +c +c----------------------------------------------------------------------- +c part iv. optionally replaceable solver routines. +c +c below are descriptions of two routines in the lsodes package which +c relate to the measurement of errors. either routine can be +c replaced by a user-supplied version, if desired. however, since such +c a replacement may have a major impact on performance, it should be +c done only when absolutely necessary, and only with great caution. +c (note.. the means by which the package version of a routine is +c superseded by the user-s version may be system-dependent.) +c +c (a) ewset. +c the following subroutine is called just before each internal +c integration step, and sets the array of error weights, ewt, as +c described under itol/RelTol/AbsTol above.. +c subroutine ewset (neq, itol, RelTol, AbsTol, ycur, ewt) +c where neq, itol, RelTol, and AbsTol are as in the lsodes CALL sequence, +c ycur contains the current dependent variable vector, and +c ewt is the array of weights set by ewset. +c +c if the user supplies this subroutine, it must return in ewt(i) +c (i = 1,...,neq) a positive quantity suitable for comparing errors +c in y(i) to. the ewt array returned by ewset is passed to the +c vnorm routine (see below), and also used by lsodes in the computation +c of the optional output imxer, the diagonal jacobian approximation, +c and the increments for difference quotient jacobians. +c +c in the user-supplied version of ewset, it may be desirable to use +c the current values of derivatives of y. derivatives up to order nq +c are available from the history array yh, described above under +c optional outputs. in ewset, yh is identical to the ycur array, +c extended to nq + 1 columns with a column length of nyh and scale +c factors of h**j/factorial(j). on the first CALL for the problem, +c given by nst = 0, nq is 1 and h is temporarily set to 1.0. +c the quantities nq, nyh, h, and nst can be obtained by including +c in ewset the statements.. +c KPP_REAL h, rls +c common /ls0001/ rls(218),ils(39) +c nq = ils(35) +c nyh = ils(14) +c nst = ils(36) +c h = rls(212) +c thus, for example, the current value of dy/dt can be obtained as +c ycur(nyh+i)/h (i=1,...,neq) (and the division by h is +c unnecessary when nst = 0). +c +c (b) vnorm. +c the following is a real function routine which computes the weighted +c root-mean-square norm of a vector v.. +c d = vnorm (n, v, w) +c where.. +c n = the length of the vector, +c v = real array of length n containing the vector, +c w = real array of length n containing weights, +c d = sqrt( (1/n) * sum(v(i)*w(i))**2 ). +c vnorm is called with n = neq and with w(i) = 1.0/ewt(i), where +c ewt is as set by subroutine ewset. +c +c if the user supplies this function, it should return a non-negative +c value of vnorm suitable for use in the error control in lsodes. +c none of the arguments should be altered by vnorm. +c for example, a user-supplied vnorm routine might.. +c -substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +c -ignore some components of v in the norm, with the effect of +c suppressing the error control on those components of y. +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c other routines in the lsodes package. +c +c in addition to subroutine lsodes, the lsodes package includes the +c following subroutines and function routines.. +c iprep acts as an iterface between lsodes and prep, and also does +c adjusting of work space pointers and work arrays. +c prep is called by iprep to compute sparsity and do sparse matrix +c preprocessing if miter = 1 or 2. +c jgroup is called by prep to compute groups of jacobian column +c indices for use when miter = 2. +c adjlr adjusts the length of required sparse matrix work space. +c it is called by prep. +c cntnzu is called by prep and counts the nonzero elements in the +c strict upper triangle of j + j-transpose, where j = df/dy. +c intdy computes an interpolated value of the y vector at t = tout. +c stode is the core integrator, which does one step of the +c integration and the associated error control. +c cfode sets all method coefficients and test constants. +c prjs computes and preprocesses the jacobian matrix j = df/dy +c and the newton iteration matrix p = i - h*l0*j. +c slss manages solution of linear system in chord iteration. +c ewset sets the error weight vector ewt before each step. +c vnorm computes the weighted r.m.s. norm of a vector. +c srcms is a user-callable routine to save and restore +c the contents of the internal common blocks. +c odrv constructs a reordering of the rows and columns of +c a matrix by the minimum degree algorithm. odrv is a +c driver routine which calls subroutines md, mdi, mdm, +c mdp, mdu, and sro. see ref. 2 for details. (the odrv +c module has been modified since ref. 2, however.) +c cdrv performs reordering, symbolic factorization, numerical +c factorization, or linear system solution operations, +c depending on a path argument ipath. cdrv is a +c driver routine which calls subroutines nroc, nsfc, +c nnfc, nnsc, and nntc. see ref. 3 for details. +c lsodes uses cdrv to solve linear systems in which the +c coefficient matrix is p = i - con*j, where i is the +c identity, con is a scalar, and j is an approximation to +c the jacobian df/dy. because cdrv deals with rowwise +c sparsity descriptions, cdrv works with p-transpose, not p. +c d1mach computes the unit roundoff in a machine-independent manner. +c xerrwv, xsetun, and xsetf handle the printing of all error +c messages and warnings. xerrwv is machine-dependent. +c note.. vnorm and d1mach are function routines. +c all the others are subroutines. +c +c the intrinsic and external routines used by lsodes are.. +c dabs, DMAX1, dmin1, dfloat, max0, min0, mod, DSIGN, DSQRT, and write. +c +c a block data subprogram is also included with the package, +c for loading some of the variables in internal common. +c +c----------------------------------------------------------------------- +c the following card is for optimized compilation on lll compilers. +clll. optimize +c----------------------------------------------------------------------- + external prjs, slss + integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, + 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns + integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 1 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, i1, i2, iflag, imax, imul, imxer, ipflag, ipgo, irem, + 1 j, kgo, lenrat, lenyht, leniw, lenrw, lf0, lia, lja, + 2 lrtem, lwtem, lyhd, lyhn, mf1, mord, mxhnl0, mxstp0, ncolm + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth + KPP_REAL AbsToli, ayi, big, ewti, h0, hmax, hmx, rh, RelToli, + 1 tcrit, tdist, tnext, tol, tolsf, tp, size, sum, w0, + 2 d1mach, vnorm + dimension mord(2) + logical ihit +c----------------------------------------------------------------------- +c the following two internal common blocks contain +c (a) variables which are local to any subroutine but whose values must +c be preserved between calls to the routine (own variables), and +c (b) variables which are communicated between subroutines. +c the structure of each block is as follows.. all real variables are +c listed first, followed by all integers. within each type, the +c variables are grouped with those local to subroutine lsodes first, +c then those local to subroutine stode or subroutine prjs +c (no other routines have own variables), and finally those used +c for communication. the block ls0001 is declared in subroutines +c lsodes, iprep, prep, intdy, stode, prjs, and slss. the block lss001 +c is declared in subroutines lsodes, iprep, prep, prjs, and slss. +c groups of variables are replaced by dummy arrays in the common +c declarations in routines where those variables are not used. +c----------------------------------------------------------------------- + common /ls0001/ rowns(209), + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, + 3 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +c + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, + 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu +c + data mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/ +c----------------------------------------------------------------------- +c in the data statement below, set lenrat equal to the ratio of +c the wordlength for a real number to that for an integer. usually, +c lenrat = 1 for single precision and 2 for KPP_REAL. if the +c true ratio is not an integer, use the next smaller integer (.ge. 1). +c----------------------------------------------------------------------- + data lenrat/2/ +c----------------------------------------------------------------------- +c block a. +c this code block is executed on every call. +c it tests istate and itask for legality and branches appropriately. +c if istate .gt. 1 but the flag init shows that initialization has +c not yet been done, an error return occurs. +c if istate = 1 and tout = t, jump to block g and return immediately. +c----------------------------------------------------------------------- + if (istate .lt. 1 .or. istate .gt. 3) go to 601 + if (itask .lt. 1 .or. itask .gt. 5) go to 602 + if (istate .eq. 1) go to 10 + if (init .eq. 0) go to 603 + if (istate .eq. 2) go to 200 + go to 20 + 10 init = 0 + if (tout .eq. t) go to 430 + 20 ntrep = 0 +c----------------------------------------------------------------------- +c block b. +c the next code block is executed for the initial CALL (istate = 1), +c or for a continuation CALL with parameter changes (istate = 3). +c it contains checking of all inputs and various initializations. +c if istate = 1, the final setting of work space pointers, the matrix +c preprocessing, and other initializations are done in block c. +c +c first check legality of the non-optional inputs neq, itol, iopt, +c mf, ml, and mu. +c----------------------------------------------------------------------- + if (neq(1) .le. 0) go to 604 + if (istate .eq. 1) go to 25 + if (neq(1) .gt. n) go to 605 + 25 n = neq(1) + if (itol .lt. 1 .or. itol .gt. 4) go to 606 + if (iopt .lt. 0 .or. iopt .gt. 1) go to 607 + moss = mf/100 + mf1 = mf - 100*moss + meth = mf1/10 + miter = mf1 - 10*meth + if (moss .lt. 0 .or. moss .gt. 2) go to 608 + if (meth .lt. 1 .or. meth .gt. 2) go to 608 + if (miter .lt. 0 .or. miter .gt. 3) go to 608 + if (miter .eq. 0 .or. miter .eq. 3) moss = 0 +c next process and check the optional inputs. -------------------------- + if (iopt .eq. 1) go to 40 + maxord = mord(meth) + mxstep = mxstp0 + mxhnil = mxhnl0 + if (istate .eq. 1) h0 = 0.0d0 + hmxi = 0.0d0 + hmin = 0.0d0 + seth = 0.0d0 + go to 60 + 40 maxord = iwork(5) + if (maxord .lt. 0) go to 611 + if (maxord .eq. 0) maxord = 100 + maxord = min0(maxord,mord(meth)) + mxstep = iwork(6) + if (mxstep .lt. 0) go to 612 + if (mxstep .eq. 0) mxstep = mxstp0 + mxhnil = iwork(7) + if (mxhnil .lt. 0) go to 613 + if (mxhnil .eq. 0) mxhnil = mxhnl0 + if (istate .ne. 1) go to 50 + h0 = rwork(5) + if ((tout - t)*h0 .lt. 0.0d0) go to 614 + 50 hmax = rwork(6) + if (hmax .lt. 0.0d0) go to 615 + hmxi = 0.0d0 + if (hmax .gt. 0.0d0) hmxi = 1.0d0/hmax + hmin = rwork(7) + if (hmin .lt. 0.0d0) go to 616 + seth = rwork(8) + if (seth .lt. 0.0d0) go to 609 +c check RelTol and AbsTol for legality. ------------------------------------ + 60 RelToli = RelTol(1) + AbsToli = AbsTol(1) + do 65 i = 1,n + if (itol .ge. 3) RelToli = RelTol(i) + if (itol .eq. 2 .or. itol .eq. 4) AbsToli = AbsTol(i) + if (RelToli .lt. 0.0d0) go to 619 + if (AbsToli .lt. 0.0d0) go to 620 + 65 continue +c----------------------------------------------------------------------- +c compute required work array lengths, as far as possible, and test +c these against lrw and liw. then set tentative pointers for work +c arrays. pointers to rwork/iwork segments are named by prefixing l to +c the name of the segment. e.g., the segment yh starts at rwork(lyh). +c segments of rwork (in order) are denoted wm, yh, savf, ewt, acor. +c if miter = 1 or 2, the required length of the matrix work space wm +c is not yet known, and so a crude minimum value is used for the +c initial tests of lrw and liw, and yh is temporarily stored as far +c to the right in rwork as possible, to leave the maximum amount +c of space for wm for matrix preprocessing. thus if miter = 1 or 2 +c and moss .ne. 2, some of the segments of rwork are temporarily +c omitted, as they are not needed in the preprocessing. these +c omitted segments are.. acor if istate = 1, ewt and acor if istate = 3 +c and moss = 1, and savf, ewt, and acor if istate = 3 and moss = 0. +c----------------------------------------------------------------------- + lrat = lenrat + if (istate .eq. 1) nyh = n + lwmin = 0 + if (miter .eq. 1) lwmin = 4*n + 10*n/lrat + if (miter .eq. 2) lwmin = 4*n + 11*n/lrat + if (miter .eq. 3) lwmin = n + 2 + lenyh = (maxord+1)*nyh + lrest = lenyh + 3*n + lenrw = 20 + lwmin + lrest + iwork(17) = lenrw + leniw = 30 + if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) + 1 leniw = leniw + n + 1 + iwork(18) = leniw + if (lenrw .gt. lrw) go to 617 + if (leniw .gt. liw) go to 618 + lia = 31 + if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) + 1 leniw = leniw + iwork(lia+n) - 1 + iwork(18) = leniw + if (leniw .gt. liw) go to 618 + lja = lia + n + 1 + lia = min0(lia,liw) + lja = min0(lja,liw) + lwm = 21 + if (istate .eq. 1) nq = 1 + ncolm = min0(nq+1,maxord+2) + lenyhm = ncolm*nyh + lenyht = lenyh + if (miter .eq. 1 .or. miter .eq. 2) lenyht = lenyhm + imul = 2 + if (istate .eq. 3) imul = moss + if (moss .eq. 2) imul = 3 + lrtem = lenyht + imul*n + lwtem = lwmin + if (miter .eq. 1 .or. miter .eq. 2) lwtem = lrw - 20 - lrtem + lenwk = lwtem + lyhn = lwm + lwtem + lsavf = lyhn + lenyht + lewt = lsavf + n + lacor = lewt + n + istatc = istate + if (istate .eq. 1) go to 100 +c----------------------------------------------------------------------- +c istate = 3. move yh to its new location. +c note that only the part of yh needed for the next step, namely +c min(nq+1,maxord+2) columns, is actually moved. +c a temporary error weight array ewt is loaded if moss = 2. +c sparse matrix processing is done in iprep/prep if miter = 1 or 2. +c if maxord was reduced below nq, then the pointers are finally set +c so that savf is identical to yh(*,maxord+2). +c----------------------------------------------------------------------- + lyhd = lyh - lyhn + imax = lyhn - 1 + lenyhm +c move yh. branch for move right, no move, or move left. -------------- + if (lyhd) 70,80,74 + 70 do 72 i = lyhn,imax + j = imax + lyhn - i + 72 rwork(j) = rwork(j+lyhd) + go to 80 + 74 do 76 i = lyhn,imax + 76 rwork(i) = rwork(i+lyhd) + 80 lyh = lyhn + iwork(22) = lyh + if (miter .eq. 0 .or. miter .eq. 3) go to 92 + if (moss .ne. 2) go to 85 +c temporarily load ewt if miter = 1 or 2 and moss = 2. ----------------- + CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) + do 82 i = 1,n + if (rwork(i+lewt-1) .le. 0.0d0) go to 621 + 82 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) + 85 continue +c iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- + lsavf = min0(lsavf,lrw) + lewt = min0(lewt,lrw) + lacor = min0(lacor,lrw) + CALL iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac) + lenrw = lwm - 1 + lenwk + lrest + iwork(17) = lenrw + if (ipflag .ne. -1) iwork(23) = ipian + if (ipflag .ne. -1) iwork(24) = ipjan + ipgo = -ipflag + 1 + go to (90, 628, 629, 630, 631, 632, 633), ipgo + 90 iwork(22) = lyh + if (lenrw .gt. lrw) go to 617 +c set flag to signal parameter changes to stode. ----------------------- + 92 jstart = -1 + if (n .eq. nyh) go to 200 +c neq was reduced. zero part of yh to avoid undefined references. ----- + i1 = lyh + l*nyh + i2 = lyh + (maxord + 1)*nyh - 1 + if (i1 .gt. i2) go to 200 + do 95 i = i1,i2 + 95 rwork(i) = 0.0d0 + go to 200 +c----------------------------------------------------------------------- +c block c. +c the next block is for the initial CALL only (istate = 1). +c it contains all remaining initializations, the initial CALL to f, +c the sparse matrix preprocessing (miter = 1 or 2), and the +c calculation of the initial step size. +c the error weights in ewt are inverted after being loaded. +c----------------------------------------------------------------------- + 100 continue + lyh = lyhn + iwork(22) = lyh + tn = t + nst = 0 + h = 1.0d0 + nnz = 0 + ngp = 0 + nzl = 0 + nzu = 0 +c load the initial value vector in yh. --------------------------------- + do 105 i = 1,n + 105 rwork(i+lyh-1) = y(i) +c initial CALL to f. (lf0 points to yh(*,2).) ------------------------- + lf0 = lyh + nyh + CALL f (neq, t, y, rwork(lf0)) + nfe = 1 +c load and invert the ewt array. (h is temporarily set to 1.0.) ------- + CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) + do 110 i = 1,n + if (rwork(i+lewt-1) .le. 0.0d0) go to 621 + 110 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) + if (miter .eq. 0 .or. miter .eq. 3) go to 120 +c iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- + lacor = min0(lacor,lrw) + CALL iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac) + lenrw = lwm - 1 + lenwk + lrest + iwork(17) = lenrw + if (ipflag .ne. -1) iwork(23) = ipian + if (ipflag .ne. -1) iwork(24) = ipjan + ipgo = -ipflag + 1 + go to (115, 628, 629, 630, 631, 632, 633), ipgo + 115 iwork(22) = lyh + if (lenrw .gt. lrw) go to 617 +c check tcrit for legality (itask = 4 or 5). --------------------------- + 120 continue + if (itask .ne. 4 .and. itask .ne. 5) go to 125 + tcrit = rwork(1) + if ((tcrit - tout)*(tout - t) .lt. 0.0d0) go to 625 + if (h0 .ne. 0.0d0 .and. (t + h0 - tcrit)*h0 .gt. 0.0d0) + 1 h0 = tcrit - t +c initialize all remaining parameters. --------------------------------- + 125 uround = d1mach(4) + jstart = 0 + if (miter .ne. 0) rwork(lwm) = DSQRT(uround) + msbj = 50 + nslj = 0 + ccmxj = 0.2d0 + psmall = 1000.0d0*uround + rbig = 0.01d0/psmall + nhnil = 0 + nje = 0 + nlu = 0 + nslast = 0 + hu = 0.0d0 + nqu = 0 + ccmax = 0.3d0 + maxcor = 3 + msbp = 20 + mxncf = 10 +c----------------------------------------------------------------------- +c the coding below computes the step size, h0, to be attempted on the +c first step, unless the user has supplied a value for this. +c first check that tout - t differs significantly from zero. +c a scalar tolerance quantity tol is computed, as max(RelTol(i)) +c if this is positive, or max(AbsTol(i)/abs(y(i))) otherwise, adjusted +c so as to be between 100*uround and 1.0e-3. +c then the computed value h0 is given by.. +c neq +c h0**2 = tol / ( w0**-2 + (1/neq) * sum ( f(i)/ywt(i) )**2 ) +c 1 +c where w0 = max ( abs(t), abs(tout) ), +c f(i) = i-th component of initial value of f, +c ywt(i) = ewt(i)/tol (a weight for y(i)). +c the sign of h0 is inferred from the initial values of tout and t. +c----------------------------------------------------------------------- + lf0 = lyh + nyh + if (h0 .ne. 0.0d0) go to 180 + tdist = dabs(tout - t) + w0 = DMAX1(dabs(t),dabs(tout)) + if (tdist .lt. 2.0d0*uround*w0) go to 622 + tol = RelTol(1) + if (itol .le. 2) go to 140 + do 130 i = 1,n + 130 tol = DMAX1(tol,RelTol(i)) + 140 if (tol .gt. 0.0d0) go to 160 + AbsToli = AbsTol(1) + do 150 i = 1,n + if (itol .eq. 2 .or. itol .eq. 4) AbsToli = AbsTol(i) + ayi = dabs(y(i)) + if (ayi .ne. 0.0d0) tol = DMAX1(tol,AbsToli/ayi) + 150 continue + 160 tol = DMAX1(tol,100.0d0*uround) + tol = dmin1(tol,0.001d0) + sum = vnorm (n, rwork(lf0), rwork(lewt)) + sum = 1.0d0/(tol*w0*w0) + tol*sum**2 + h0 = 1.0d0/DSQRT(sum) + h0 = dmin1(h0,tdist) + h0 = DSIGN(h0,tout-t) +c adjust h0 if necessary to meet hmax bound. --------------------------- + 180 rh = dabs(h0)*hmxi + if (rh .gt. 1.0d0) h0 = h0/rh +c load h with h0 and scale yh(*,2) by h0. ------------------------------ + h = h0 + do 190 i = 1,n + 190 rwork(i+lf0-1) = h0*rwork(i+lf0-1) + go to 270 +c----------------------------------------------------------------------- +c block d. +c the next code block is for continuation calls only (istate = 2 or 3) +c and is to check stop conditions before taking a step. +c----------------------------------------------------------------------- + 200 nslast = nst + go to (210, 250, 220, 230, 240), itask + 210 if ((tn - tout)*h .lt. 0.0d0) go to 250 + CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 220 tp = tn - hu*(1.0d0 + 100.0d0*uround) + if ((tp - tout)*h .gt. 0.0d0) go to 623 + if ((tn - tout)*h .lt. 0.0d0) go to 250 + go to 400 + 230 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. 0.0d0) go to 624 + if ((tcrit - tout)*h .lt. 0.0d0) go to 625 + if ((tn - tout)*h .lt. 0.0d0) go to 245 + CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 240 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. 0.0d0) go to 624 + 245 hmx = dabs(tn) + dabs(h) + ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx + if (ihit) go to 400 + tnext = tn + h*(1.0d0 + 4.0d0*uround) + if ((tnext - tcrit)*h .le. 0.0d0) go to 250 + h = (tcrit - tn)*(1.0d0 - 4.0d0*uround) + if (istate .eq. 2) jstart = -2 +c----------------------------------------------------------------------- +c block e. +c the next block is normally executed for all calls and contains +c the CALL to the one-step core integrator stode. +c +c this is a looping point for the integration steps. +c +c first check for too many steps being taken, update ewt (if not at +c start of problem), check for too much accuracy being requested, and +c check for h below the roundoff level in t. +c----------------------------------------------------------------------- + 250 continue + if ((nst-nslast) .ge. mxstep) go to 500 + CALL ewset (n, itol, RelTol, AbsTol, rwork(lyh), rwork(lewt)) + do 260 i = 1,n + if (rwork(i+lewt-1) .le. 0.0d0) go to 510 + 260 rwork(i+lewt-1) = 1.0d0/rwork(i+lewt-1) + 270 tolsf = uround*vnorm (n, rwork(lyh), rwork(lewt)) + if (tolsf .le. 1.0d0) go to 280 + tolsf = tolsf*2.0d0 + if (nst .eq. 0) go to 626 + go to 520 + 280 if ((tn + h) .ne. tn) go to 290 + nhnil = nhnil + 1 + if (nhnil .gt. mxhnil) go to 290 + CALL xerrwv(50hlsodes-- warning..internal t (=r1) and h (=r2) are, + 1 50, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h such that in the machine, t + h = t on the next step , + 1 60, 101, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h (h = step size). solver will continue anyway, + 1 50, 101, 0, 0, 0, 0, 2, tn, h) + if (nhnil .lt. mxhnil) go to 290 + CALL xerrwv(50hlsodes-- above warning has been issued i1 times. , + 1 50, 102, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h it will not be issued again for this problem, + 1 50, 102, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0) + 290 continue +c----------------------------------------------------------------------- +c CALL stode(neq,y,yh,nyh,yh,ewt,savf,acor,wm,wm,f,jac,prjs,slss) +c----------------------------------------------------------------------- + CALL stode (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), + 1 rwork(lsavf), rwork(lacor), rwork(lwm), rwork(lwm), + 2 f, jac, prjs, slss) + kgo = 1 - kflag + go to (300, 530, 540, 550), kgo +c----------------------------------------------------------------------- +c block f. +c the following block handles the case of a successful return from the +c core integrator (kflag = 0). test for stop conditions. +c----------------------------------------------------------------------- + 300 init = 1 + go to (310, 400, 330, 340, 350), itask +c itask = 1. if tout has been reached, interpolate. ------------------- + 310 if ((tn - tout)*h .lt. 0.0d0) go to 250 + CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 +c itask = 3. jump to exit if tout was reached. ------------------------ + 330 if ((tn - tout)*h .ge. 0.0d0) go to 400 + go to 250 +c itask = 4. see if tout or tcrit was reached. adjust h if necessary. + 340 if ((tn - tout)*h .lt. 0.0d0) go to 345 + CALL intdy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 + 345 hmx = dabs(tn) + dabs(h) + ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx + if (ihit) go to 400 + tnext = tn + h*(1.0d0 + 4.0d0*uround) + if ((tnext - tcrit)*h .le. 0.0d0) go to 250 + h = (tcrit - tn)*(1.0d0 - 4.0d0*uround) + jstart = -2 + go to 250 +c itask = 5. see if tcrit was reached and jump to exit. --------------- + 350 hmx = dabs(tn) + dabs(h) + ihit = dabs(tn - tcrit) .le. 100.0d0*uround*hmx +c----------------------------------------------------------------------- +c block g. +c the following block handles all successful returns from lsodes. +c if itask .ne. 1, y is loaded from yh and t is set accordingly. +c istate is set to 2, the illegal input counter is zeroed, and the +c optional outputs are loaded into the work arrays before returning. +c if istate = 1 and tout = t, there is a return with no action taken, +c except that if this has happened repeatedly, the run is terminated. +c----------------------------------------------------------------------- + 400 do 410 i = 1,n + 410 y(i) = rwork(i+lyh-1) + t = tn + if (itask .ne. 4 .and. itask .ne. 5) go to 420 + if (ihit) t = tcrit + 420 istate = 2 + illin = 0 + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nnz + iwork(20) = ngp + iwork(21) = nlu + iwork(25) = nzl + iwork(26) = nzu + return +c + 430 ntrep = ntrep + 1 + if (ntrep .lt. 5) return + CALL xerrwv( + 1 60hlsodes-- repeated calls with istate = 1 and tout = t (=r1) , + 1 60, 301, 0, 0, 0, 0, 1, t, 0.0d0) + go to 800 +c----------------------------------------------------------------------- +c block h. +c the following block handles all unsuccessful returns other than +c those for illegal input. first the error message routine is called. +c if there was an error test or convergence test failure, imxer is set. +c then y is loaded from yh, t is set to tn, and the illegal input +c counter illin is set to 0. the optional outputs are loaded into +c the work arrays before returning. +c----------------------------------------------------------------------- +c the maximum number of steps was taken before reaching tout. ---------- + 500 CALL xerrwv(50hlsodes-- at current t (=r1), mxstep (=i1) steps , + 1 50, 201, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h taken on this CALL before reaching tout , + 1 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0d0) + istate = -1 + go to 580 +c ewt(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 ewti = rwork(lewt+i-1) + CALL xerrwv(50hlsodes-- at t (=r1), ewt(i1) has become r2 .le. 0., + 1 50, 202, 0, 1, i, 0, 2, tn, ewti) + istate = -6 + go to 580 +c too much accuracy requested for machine precision. ------------------- + 520 CALL xerrwv(50hlsodes-- at t (=r1), too much accuracy requested , + 1 50, 203, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h for precision of machine.. see tolsf (=r2) , + 1 50, 203, 0, 0, 0, 0, 2, tn, tolsf) + rwork(14) = tolsf + istate = -2 + go to 580 +c kflag = -1. error test failed repeatedly or with abs(h) = hmin. ----- + 530 CALL xerrwv(50hlsodes-- at t(=r1) and step size h(=r2), the error, + 1 50, 204, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h test failed repeatedly or with abs(h) = hmin, + 1 50, 204, 0, 0, 0, 0, 2, tn, h) + istate = -4 + go to 560 +c kflag = -2. convergence failed repeatedly or with abs(h) = hmin. ---- + 540 CALL xerrwv(50hlsodes-- at t (=r1) and step size h (=r2), the , + 1 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h corrector convergence failed repeatedly , + 1 50, 205, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(30h or with abs(h) = hmin , + 1 30, 205, 0, 0, 0, 0, 2, tn, h) + istate = -5 + go to 560 +c kflag = -3. fatal error flag returned by prjs or slss (cdrv). ------- + 550 CALL xerrwv(50hlsodes-- at t (=r1) and step size h (=r2), a fatal, + 1 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(50h error flag was returned by cdrv (by way of , + 1 50, 207, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv(30h subroutine prjs or slss), + 1 30, 207, 0, 0, 0, 0, 2, tn, h) + istate = -7 + go to 580 +c compute imxer if relevant. ------------------------------------------- + 560 big = 0.0d0 + imxer = 1 + do 570 i = 1,n + size = dabs(rwork(i+lacor-1)*rwork(i+lewt-1)) + if (big .ge. size) go to 570 + big = size + imxer = i + 570 continue + iwork(16) = imxer +c set y vector, t, illin, and optional outputs. ------------------------ + 580 do 590 i = 1,n + 590 y(i) = rwork(i+lyh-1) + t = tn + illin = 0 + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nnz + iwork(20) = ngp + iwork(21) = nlu + iwork(25) = nzl + iwork(26) = nzu + return +c----------------------------------------------------------------------- +c block i. +c the following block handles all error returns due to illegal input +c (istate = -3), as detected before calling the core integrator. +c first the error message routine is called. then if there have been +c 5 consecutive such returns just before this CALL to the solver, +c the run is halted. +c----------------------------------------------------------------------- + 601 CALL xerrwv(30hlsodes-- istate (=i1) illegal , + 1 30, 1, 0, 1, istate, 0, 0, 0.0d0, 0.0d0) + go to 700 + 602 CALL xerrwv(30hlsodes-- itask (=i1) illegal , + 1 30, 2, 0, 1, itask, 0, 0, 0.0d0, 0.0d0) + go to 700 + 603 CALL xerrwv(50hlsodes-- istate .gt. 1 but lsodes not initialized , + 1 50, 3, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + go to 700 + 604 CALL xerrwv(30hlsodes-- neq (=i1) .lt. 1 , + 1 30, 4, 0, 1, neq(1), 0, 0, 0.0d0, 0.0d0) + go to 700 + 605 CALL xerrwv(50hlsodes-- istate = 3 and neq increased (i1 to i2) , + 1 50, 5, 0, 2, n, neq(1), 0, 0.0d0, 0.0d0) + go to 700 + 606 CALL xerrwv(30hlsodes-- itol (=i1) illegal , + 1 30, 6, 0, 1, itol, 0, 0, 0.0d0, 0.0d0) + go to 700 + 607 CALL xerrwv(30hlsodes-- iopt (=i1) illegal , + 1 30, 7, 0, 1, iopt, 0, 0, 0.0d0, 0.0d0) + go to 700 + 608 CALL xerrwv(30hlsodes-- mf (=i1) illegal , + 1 30, 8, 0, 1, mf, 0, 0, 0.0d0, 0.0d0) + go to 700 + 609 CALL xerrwv(30hlsodes-- seth (=r1) .lt. 0.0 , + 1 30, 9, 0, 0, 0, 0, 1, seth, 0.0d0) + go to 700 + 611 CALL xerrwv(30hlsodes-- maxord (=i1) .lt. 0 , + 1 30, 11, 0, 1, maxord, 0, 0, 0.0d0, 0.0d0) + go to 700 + 612 CALL xerrwv(30hlsodes-- mxstep (=i1) .lt. 0 , + 1 30, 12, 0, 1, mxstep, 0, 0, 0.0d0, 0.0d0) + go to 700 + 613 CALL xerrwv(30hlsodes-- mxhnil (=i1) .lt. 0 , + 1 30, 13, 0, 1, mxhnil, 0, 0, 0.0d0, 0.0d0) + go to 700 + 614 CALL xerrwv(40hlsodes-- tout (=r1) behind t (=r2) , + 1 40, 14, 0, 0, 0, 0, 2, tout, t) + CALL xerrwv(50h integration direction is given by h0 (=r1) , + 1 50, 14, 0, 0, 0, 0, 1, h0, 0.0d0) + go to 700 + 615 CALL xerrwv(30hlsodes-- hmax (=r1) .lt. 0.0 , + 1 30, 15, 0, 0, 0, 0, 1, hmax, 0.0d0) + go to 700 + 616 CALL xerrwv(30hlsodes-- hmin (=r1) .lt. 0.0 , + 1 30, 16, 0, 0, 0, 0, 1, hmin, 0.0d0) + go to 700 + 617 CALL xerrwv(50hlsodes-- rwork length is insufficient to proceed. , + 1 50, 17, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), + 1 60, 17, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) + go to 700 + 618 CALL xerrwv(50hlsodes-- iwork length is insufficient to proceed. , + 1 50, 18, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. leniw (=i1), exceeds liw (=i2), + 1 60, 18, 0, 2, leniw, liw, 0, 0.0d0, 0.0d0) + go to 700 + 619 CALL xerrwv(40hlsodes-- RelTol(i1) is r1 .lt. 0.0 , + 1 40, 19, 0, 1, i, 0, 1, RelToli, 0.0d0) + go to 700 + 620 CALL xerrwv(40hlsodes-- AbsTol(i1) is r1 .lt. 0.0 , + 1 40, 20, 0, 1, i, 0, 1, AbsToli, 0.0d0) + go to 700 + 621 ewti = rwork(lewt+i-1) + CALL xerrwv(40hlsodes-- ewt(i1) is r1 .le. 0.0 , + 1 40, 21, 0, 1, i, 0, 1, ewti, 0.0d0) + go to 700 + 622 CALL xerrwv( + 1 60hlsodes-- tout (=r1) too close to t(=r2) to start integration, + 1 60, 22, 0, 0, 0, 0, 2, tout, t) + go to 700 + 623 CALL xerrwv( + 1 60hlsodes-- itask = i1 and tout (=r1) behind tcur - hu (= r2) , + 1 60, 23, 0, 1, itask, 0, 2, tout, tp) + go to 700 + 624 CALL xerrwv( + 1 60hlsodes-- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) , + 1 60, 24, 0, 0, 0, 0, 2, tcrit, tn) + go to 700 + 625 CALL xerrwv( + 1 60hlsodes-- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) , + 1 60, 25, 0, 0, 0, 0, 2, tcrit, tout) + go to 700 + 626 CALL xerrwv(50hlsodes-- at start of problem, too much accuracy , + 1 50, 26, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h requested for precision of machine.. see tolsf (=r1) , + 1 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0d0) + rwork(14) = tolsf + go to 700 + 627 CALL xerrwv(50hlsodes-- trouble from intdy. itask = i1, tout = r1, + 1 50, 27, 0, 1, itask, 0, 1, tout, 0.0d0) + go to 700 + 628 CALL xerrwv( + 1 60hlsodes-- rwork length insufficient (for subroutine prep). , + 1 60, 28, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), + 1 60, 28, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) + go to 700 + 629 CALL xerrwv( + 1 60hlsodes-- rwork length insufficient (for subroutine jgroup). , + 1 60, 29, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), + 1 60, 29, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) + go to 700 + 630 CALL xerrwv( + 1 60hlsodes-- rwork length insufficient (for subroutine odrv). , + 1 60, 30, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), + 1 60, 30, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) + go to 700 + 631 CALL xerrwv( + 1 60hlsodes-- error from odrv in yale sparse matrix package , + 1 60, 31, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + imul = (iys - 1)/n + irem = iys - imul*n + CALL xerrwv( + 1 60h at t (=r1), odrv returned error flag = i1*neq + i2. , + 1 60, 31, 0, 2, imul, irem, 1, tn, 0.0d0) + go to 700 + 632 CALL xerrwv( + 1 60hlsodes-- rwork length insufficient (for subroutine cdrv). , + 1 60, 32, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + CALL xerrwv( + 1 60h length needed is .ge. lenrw (=i1), exceeds lrw (=i2), + 1 60, 32, 0, 2, lenrw, lrw, 0, 0.0d0, 0.0d0) + go to 700 + 633 CALL xerrwv( + 1 60hlsodes-- error from cdrv in yale sparse matrix package , + 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + imul = (iys - 1)/n + irem = iys - imul*n + CALL xerrwv( + 1 60h at t (=r1), cdrv returned error flag = i1*neq + i2. , + 1 60, 33, 0, 2, imul, irem, 1, tn, 0.0d0) + if (imul .eq. 2) CALL xerrwv( + 1 60h duplicate entry in sparsity structure descriptors , + 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) + if (imul .eq. 3 .or. imul .eq. 6) CALL xerrwv( + 1 60h insufficient storage for nsfc (called by cdrv) , + 1 60, 33, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) +c + 700 if (illin .eq. 5) go to 710 + illin = illin + 1 + istate = -3 + return + 710 CALL xerrwv(50hlsodes-- repeated occurrences of illegal input , + 1 50, 302, 0, 0, 0, 0, 0, 0.0d0, 0.0d0) +c + 800 CALL xerrwv(50hlsodes-- run aborted.. apparent infinite loop , + 1 50, 303, 2, 0, 0, 0, 0, 0.0d0, 0.0d0) + return +c----------------------- end of subroutine lsodes ---------------------- + end + subroutine iprep (neq, y, rwork, ia, ja, ipflag, f, jac) +clll. optimize + external f, jac + integer neq, ia, ja, ipflag + integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, + 1 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns + integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 1 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, imax, lewtn, lyhd, lyhn + KPP_REAL y, rwork + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL rlss + dimension neq(1), y(1), rwork(1), ia(1), ja(1) + common /ls0001/ rowns(209), + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 2 illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, + 3 mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ rlss(6), + 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu +c----------------------------------------------------------------------- +c this routine serves as an interface between the driver and +c subroutine prep. it is called only if miter is 1 or 2. +c tasks performed here are.. +c * CALL prep, +c * reset the required wm segment length lenwk, +c * move yh back to its final location (following wm in rwork), +c * reset pointers for yh, savf, ewt, and acor, and +c * move ewt to its new position if istate = 1. +c ipflag is an output error indication flag. ipflag = 0 if there was +c no trouble, and ipflag is the value of the prep error flag ipper +c if there was trouble in subroutine prep. +c----------------------------------------------------------------------- + ipflag = 0 +c CALL prep to do matrix preprocessing operations. --------------------- +c CALL prep (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt), +c 1 rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac) + CALL prep (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt), + 1 rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac) + lenwk = max0(lreq,lwmin) + if (ipflag .lt. 0) return +c if prep was successful, move yh to end of required space for wm. ----- + lyhn = lwm + lenwk + if (lyhn .gt. lyh) return + lyhd = lyh - lyhn + if (lyhd .eq. 0) go to 20 + imax = lyhn - 1 + lenyhm + do 10 i = lyhn,imax + 10 rwork(i) = rwork(i+lyhd) + lyh = lyhn +c reset pointers for savf, ewt, and acor. ------------------------------ + 20 lsavf = lyh + lenyh + lewtn = lsavf + n + lacor = lewtn + n + if (istatc .eq. 3) go to 40 +c if istate = 1, move ewt (left) to its new position. ------------------ + if (lewtn .gt. lewt) return + do 30 i = 1,n + 30 rwork(i+lewtn-1) = rwork(i+lewt-1) + 40 lewt = lewtn + return +c----------------------- end of subroutine iprep ----------------------- + end + subroutine slss (wk, iwk, x, tem) +clll. optimize + integer iwk + integer iownd, iowns, + 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i + KPP_REAL wk, x, tem + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL rlss + KPP_REAL di, hl0, phl0, r + dimension wk(*), iwk(*), x(*), tem(*) + common /ls0001/ rowns(209), + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 3 iownd(14), iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ rlss(6), + 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu +c----------------------------------------------------------------------- +c this routine manages the solution of the linear system arising from +c a chord iteration. it is called if miter .ne. 0. +c if miter is 1 or 2, it calls cdrv to accomplish this. +c if miter = 3 it updates the coefficient h*el0 in the diagonal +c matrix, and then computes the solution. +c communication with slss uses the following variables.. +c wk = real work space containing the inverse diagonal matrix if +c miter = 3 and the lu decomposition of the matrix otherwise. +c storage of matrix elements starts at wk(3). +c wk also contains the following matrix-related data.. +c wk(1) = sqrt(uround) (not used here), +c wk(2) = hl0, the previous value of h*el0, used if miter = 3. +c iwk = integer work space for matrix-related data, assumed to +c be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) +c are assumed to have identical locations. +c x = the right-hand side vector on input, and the solution vector +c on output, of length n. +c tem = vector of work space of length n, not used in this version. +c iersl = output flag (in common). +c iersl = 0 if no trouble occurred. +c iersl = -1 if cdrv returned an error flag (miter = 1 or 2). +c this should never occur and is considered fatal. +c iersl = 1 if a singular matrix arose with miter = 3. +c this routine also uses other variables in common. +c----------------------------------------------------------------------- + iersl = 0 + go to (100, 100, 300), miter + 100 CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), + 1 wk(ipa),x,x,nsp,iwk(ipisp),wk(iprsp),iesp,4,iersl) + if (iersl .ne. 0) iersl = -1 + return +c + 300 phl0 = wk(2) + hl0 = h*el0 + wk(2) = hl0 + if (hl0 .eq. phl0) go to 330 + r = hl0/phl0 + do 320 i = 1,n + di = 1.0d0 - r*(1.0d0 - 1.0d0/wk(i+2)) + if (dabs(di) .eq. 0.0d0) go to 390 + 320 wk(i+2) = 1.0d0/di + 330 do 340 i = 1,n + 340 x(i) = wk(i+2)*x(i) + return + 390 iersl = 1 + return +c +c----------------------- end of subroutine slss ------------------------ + end + subroutine intdy (t, k, yh, nyh, dky, iflag) +clll. optimize + integer k, nyh, iflag + integer iownd, iowns, + 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer i, ic, j, jb, jb2, jj, jj1, jp1 + KPP_REAL t, yh, dky + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL c, r, s, tp + dimension yh(nyh,1), dky(1) + common /ls0001/ rowns(209), + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 3 iownd(14), iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +c----------------------------------------------------------------------- +c intdy computes interpolated values of the k-th derivative of the +c dependent variable vector y, and stores it in dky. this routine +c is called within the package with k = 0 and t = tout, but may +c also be called by the user for any k up to the current order. +c (see detailed instructions in the usage documentation.) +c----------------------------------------------------------------------- +c the computed values in dky are gotten by interpolation using the +c nordsieck history array yh. this array corresponds uniquely to a +c vector-valued polynomial of degree nqcur or less, and dky is set +c to the k-th derivative of this polynomial at t. +c the formula for dky is.. +c q +c dky(i) = sum c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1) +c j=k +c where c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur. +c the quantities nq = nqcur, l = nq+1, n = neq, tn, and h are +c communicated by common. the above sum is done in reverse order. +c iflag is returned negative if either k or t is out of bounds. +c----------------------------------------------------------------------- + iflag = 0 + if (k .lt. 0 .or. k .gt. nq) go to 80 + tp = tn - hu - 100.0d0*uround*(tn + hu) + if ((t-tp)*(t-tn) .gt. 0.0d0) go to 90 +c + s = (t - tn)/h + ic = 1 + if (k .eq. 0) go to 15 + jj1 = l - k + do 10 jj = jj1,nq + 10 ic = ic*jj + 15 c = dfloat(ic) + do 20 i = 1,n + 20 dky(i) = c*yh(i,l) + if (k .eq. nq) go to 55 + jb2 = nq - k + do 50 jb = 1,jb2 + j = nq - jb + jp1 = j + 1 + ic = 1 + if (k .eq. 0) go to 35 + jj1 = jp1 - k + do 30 jj = jj1,j + 30 ic = ic*jj + 35 c = dfloat(ic) + do 40 i = 1,n + 40 dky(i) = c*yh(i,jp1) + s*dky(i) + 50 continue + if (k .eq. 0) return + 55 r = h**(-k) + do 60 i = 1,n + 60 dky(i) = r*dky(i) + return +c + 80 CALL xerrwv(30hintdy-- k (=i1) illegal , + 1 30, 51, 0, 1, k, 0, 0, 0.0d0, 0.0d0) + iflag = -1 + return + 90 CALL xerrwv(30hintdy-- t (=r1) illegal , + 1 30, 52, 0, 0, 0, 0, 1, t, 0.0d0) + CALL xerrwv( + 1 60h t not in interval tcur - hu (= r1) to tcur (=r2) , + 1 60, 52, 0, 0, 0, 0, 2, tp, tn) + iflag = -2 + return +c----------------------- end of subroutine intdy ----------------------- + end + subroutine prjs (neq,y,yh,nyh,ewt,ftem,savf,wk,iwk,f,jac) +clll. optimize + external f,jac + integer neq, nyh, iwk + integer iownd, iowns, + 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, imul, j, jj, jok, jmax, jmin, k, kmax, kmin, ng + KPP_REAL JJJ(n,n) + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth + KPP_REAL con, di, fac, hl0, pij, r, r0, rcon, rcont, + 1 srur, vnorm + dimension neq(*), iwk(*) + KPP_REAL y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), wk(*) + common /ls0001/ rowns(209), + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 3 iownd(14), iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, + 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu +c----------------------------------------------------------------------- +c prjs is called to compute and process the matrix +c p = i - h*el(1)*j , where j is an approximation to the jacobian. +c j is computed by columns, either by the user-supplied routine jac +c if miter = 1, or by finite differencing if miter = 2. +c if miter = 3, a diagonal approximation to j is used. +c if miter = 1 or 2, and if the existing value of the jacobian +c (as contained in p) is considered acceptable, then a new value of +c p is reconstructed from the old value. in any case, when miter +c is 1 or 2, the p matrix is subjected to lu decomposition in cdrv. +c p and its lu decomposition are stored (separately) in wk. +c +c in addition to variables described previously, communication +c with prjs uses the following.. +c y = array containing predicted values on entry. +c ftem = work array of length n (acor in stode). +c savf = array containing f evaluated at predicted y. +c wk = real work space for matrices. on output it contains the +c inverse diagonal matrix if miter = 3, and p and its sparse +c lu decomposition if miter is 1 or 2. +c storage of matrix elements starts at wk(3). +c wk also contains the following matrix-related data.. +c wk(1) = sqrt(uround), used in numerical jacobian increments. +c wk(2) = h*el0, saved for later use if miter = 3. +c iwk = integer work space for matrix-related data, assumed to +c be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) +c are assumed to have identical locations. +c el0 = el(1) (input). +c ierpj = output error flag (in common). +c = 0 if no error. +c = 1 if zero pivot found in cdrv. +c = 2 if a singular matrix arose with miter = 3. +c = -1 if insufficient storage for cdrv (should not occur here). +c = -2 if other error found in cdrv (should not occur here). +c jcur = output flag = 1 to indicate that the jacobian matrix +c (or approximation) is now current. +c this routine also uses other variables in common. +c----------------------------------------------------------------------- + hl0 = h*el0 + con = -hl0 + if (miter .eq. 3) go to 300 +c see whether j should be reevaluated (jok = 0) or not (jok = 1). ------ + jok = 1 + if (nst .eq. 0 .or. nst .ge. nslj+msbj) jok = 0 + if (icf .eq. 1 .and. dabs(rc - 1.0d0) .lt. ccmxj) jok = 0 + if (icf .eq. 2) jok = 0 + if (jok .eq. 1) go to 250 +c +c miter = 1 or 2, and the jacobian is to be reevaluated. --------------- + 20 jcur = 1 + nje = nje + 1 + nslj = nst + iplost = 0 + conmin = dabs(con) + go to (100, 200), miter +c +c if miter = 1, call jac_chem, multiply by scalar, and add identity. -------- + 100 continue + kmin = iwk(ipian) + call jac_chem (neq, tn, y, JJJ, j, iwk(ipian), iwk(ipjan)) + do 130 j = 1, n + kmax = iwk(ipian+j) - 1 + do 110 i = 1,n + 110 ftem(i) = 0.0d0 +C call jac_chem (neq, tn, y, ftem, j, iwk(ipian), iwk(ipjan)) + do k=1,n + ftem(k) = JJJ(k,j) + end do + do 120 k = kmin, kmax + i = iwk(ibjan+k) + wk(iba+k) = ftem(i)*con + if (i .eq. j) wk(iba+k) = wk(iba+k) + 1.0d0 + 120 continue + kmin = kmax + 1 + 130 continue + go to 290 +c +c if miter = 2, make ngp calls to f to approximate j and p. ------------ + 200 continue + fac = vnorm(n, savf, ewt) + r0 = 1000.0d0 * dabs(h) * uround * dfloat(n) * fac + if (r0 .eq. 0.0d0) r0 = 1.0d0 + srur = wk(1) + jmin = iwk(ipigp) + do 240 ng = 1,ngp + jmax = iwk(ipigp+ng) - 1 + do 210 j = jmin,jmax + jj = iwk(ibjgp+j) + r = DMAX1(srur*dabs(y(jj)),r0/ewt(jj)) + 210 y(jj) = y(jj) + r + CALL f (neq, tn, y, ftem) + do 230 j = jmin,jmax + jj = iwk(ibjgp+j) + y(jj) = yh(jj,1) + r = DMAX1(srur*dabs(y(jj)),r0/ewt(jj)) + fac = -hl0/r + kmin =iwk(ibian+jj) + kmax =iwk(ibian+jj+1) - 1 + do 220 k = kmin,kmax + i = iwk(ibjan+k) + wk(iba+k) = (ftem(i) - savf(i))*fac + if (i .eq. jj) wk(iba+k) = wk(iba+k) + 1.0d0 + 220 continue + 230 continue + jmin = jmax + 1 + 240 continue + nfe = nfe + ngp + go to 290 +c +c if jok = 1, reconstruct new p from old p. ---------------------------- + 250 jcur = 0 + rcon = con/con0 + rcont = dabs(con)/conmin + if (rcont .gt. rbig .and. iplost .eq. 1) go to 20 + kmin = iwk(ipian) + do 275 j = 1,n + kmax = iwk(ipian+j) - 1 + do 270 k = kmin,kmax + i = iwk(ibjan+k) + pij = wk(iba+k) + if (i .ne. j) go to 260 + pij = pij - 1.0d0 + if (dabs(pij) .ge. psmall) go to 260 + iplost = 1 + conmin = dmin1(dabs(con0),conmin) + 260 pij = pij*rcon + if (i .eq. j) pij = pij + 1.0d0 + wk(iba+k) = pij + 270 continue + kmin = kmax + 1 + 275 continue +c +c do numerical factorization of p matrix. ------------------------------ + 290 nlu = nlu + 1 + con0 = con + ierpj = 0 + do 295 i = 1,n + 295 ftem(i) = 0.0d0 + CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), + 1 wk(ipa),ftem,ftem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys) + if (iys .eq. 0) return + imul = (iys - 1)/n + ierpj = -2 + if (imul .eq. 8) ierpj = 1 + if (imul .eq. 10) ierpj = -1 + return +c +c if miter = 3, construct a diagonal approximation to j and p. --------- + 300 continue + jcur = 1 + nje = nje + 1 + wk(2) = hl0 + ierpj = 0 + r = el0*0.1d0 + do 310 i = 1,n + 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) + CALL f (neq, tn, y, wk(3)) + nfe = nfe + 1 + do 320 i = 1,n + r0 = h*savf(i) - yh(i,2) + di = 0.1d0*r0 - h*(wk(i+2) - savf(i)) + wk(i+2) = 1.0d0 + if (dabs(r0) .lt. uround/ewt(i)) go to 320 + if (dabs(di) .eq. 0.0d0) go to 330 + wk(i+2) = 0.1d0*r0/di + 320 continue + return + 330 ierpj = 2 + return +c----------------------- end of subroutine prjs ------------------------ + end + subroutine stode (neq, y, yh, nyh, yh1, ewt, savf, acor, + 1 wm, iwm, f, jac, pjac, slvs) +clll. optimize + external f, jac, pjac, slvs + integer neq, nyh, iwm + integer iownd, ialth, ipup, lmax, meo, nqnyh, nslp, + 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer i, i1, iredo, iret, j, jb, m, ncf, newq + KPP_REAL y, yh, yh1, ewt, savf, acor, wm + KPP_REAL conit, crate, el, elco, hold, rmax, tesco, + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup, + 1 r, rh, rhdn, rhsm, rhup, told, vnorm + dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), + 1 acor(*), wm(*), iwm(*) + common /ls0001/ conit, crate, el(13), elco(13,12), + 1 hold, rmax, tesco(3,12), + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, iownd(14), + 3 ialth, ipup, lmax, meo, nqnyh, nslp, + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +c----------------------------------------------------------------------- +c stode performs one step of the integration of an initial value +c problem for a system of ordinary differential equations. +c note.. stode is independent of the value of the iteration method +c indicator miter, when this is .ne. 0, and hence is independent +c of the type of chord method used, or the jacobian structure. +c communication with stode is done with the following variables.. +c +c neq = integer array containing problem size in neq(1), and +c passed as the neq argument in all calls to f and jac. +c y = an array of length .ge. n used as the y argument in +c all calls to f and jac. +c yh = an nyh by lmax array containing the dependent variables +c and their approximate scaled derivatives, where +c lmax = maxord + 1. yh(i,j+1) contains the approximate +c j-th derivative of y(i), scaled by h**j/factorial(j) +c (j = 0,1,...,nq). on entry for the first step, the first +c two columns of yh must be set from the initial values. +c nyh = a constant integer .ge. n, the first dimension of yh. +c yh1 = a one-dimensional array occupying the same space as yh. +c ewt = an array of length n containing multiplicative weights +c for local error measurements. local errors in y(i) are +c compared to 1.0/ewt(i) in various error tests. +c savf = an array of working storage, of length n. +c also used for input of yh(*,maxord+2) when jstart = -1 +c and maxord .lt. the current order nq. +c acor = a work array of length n, used for the accumulated +c corrections. on a successful return, acor(i) contains +c the estimated one-step local error in y(i). +c wm,iwm = real and integer work arrays associated with matrix +c operations in chord iteration (miter .ne. 0). +c pjac = name of routine to evaluate and preprocess jacobian matrix +c and p = i - h*el0*jac, if a chord method is being used. +c slvs = name of routine to solve linear system in chord iteration. +c ccmax = maximum relative change in h*el0 before pjac is called. +c h = the step size to be attempted on the next step. +c h is altered by the error control algorithm during the +c problem. h can be either positive or negative, but its +c sign must remain constant throughout the problem. +c hmin = the minimum absolute value of the step size h to be used. +c hmxi = inverse of the maximum absolute value of h to be used. +c hmxi = 0.0 is allowed and corresponds to an infinite hmax. +c hmin and hmxi may be changed at any time, but will not +c take effect until the next change of h is considered. +c tn = the independent variable. tn is updated on each step taken. +c jstart = an integer used for input only, with the following +c values and meanings.. +c 0 perform the first step. +c .gt.0 take a new step continuing from the last. +c -1 take the next step with a new value of h, maxord, +c n, meth, miter, and/or matrix parameters. +c -2 take the next step with a new value of h, +c but with other inputs unchanged. +c on return, jstart is set to 1 to facilitate continuation. +c kflag = a completion code with the following meanings.. +c 0 the step was succesful. +c -1 the requested error could not be achieved. +c -2 corrector convergence could not be achieved. +c -3 fatal error in pjac or slvs. +c a return with kflag = -1 or -2 means either +c abs(h) = hmin or 10 consecutive failures occurred. +c on a return with kflag negative, the values of tn and +c the yh array are as of the beginning of the last +c step, and h is the last step size attempted. +c maxord = the maximum order of integration method to be allowed. +c maxcor = the maximum number of corrector iterations allowed. +c msbp = maximum number of steps between pjac calls (miter .gt. 0). +c mxncf = maximum number of convergence failures allowed. +c meth/miter = the method flags. see description in driver. +c n = the number of first-order differential equations. +c----------------------------------------------------------------------- + kflag = 0 + told = tn + ncf = 0 + ierpj = 0 + iersl = 0 + jcur = 0 + icf = 0 + delp = 0.0d0 + if (jstart .gt. 0) go to 200 + if (jstart .eq. -1) go to 100 + if (jstart .eq. -2) go to 160 +c----------------------------------------------------------------------- +c on the first call, the order is set to 1, and other variables are +c initialized. rmax is the maximum ratio by which h can be increased +c in a single step. it is initially 1.e4 to compensate for the small +c initial h, but then is normally equal to 10. if a failure +c occurs (in corrector convergence or error test), rmax is set at 2 +c for the next increase. +c----------------------------------------------------------------------- + lmax = maxord + 1 + nq = 1 + l = 2 + ialth = 2 + rmax = 10000.0d0 + rc = 0.0d0 + el0 = 1.0d0 + crate = 0.7d0 + hold = h + meo = meth + nslp = 0 + ipup = miter + iret = 3 + go to 140 +c----------------------------------------------------------------------- +c the following block handles preliminaries needed when jstart = -1. +c ipup is set to miter to force a matrix update. +c if an order increase is about to be considered (ialth = 1), +c ialth is reset to 2 to postpone consideration one more step. +c if the caller has changed meth, cfode is called to reset +c the coefficients of the method. +c if the caller has changed maxord to a value less than the current +c order nq, nq is reduced to maxord, and a new h chosen accordingly. +c if h is to be changed, yh must be rescaled. +c if h or meth is being changed, ialth is reset to l = nq + 1 +c to prevent further changes in h for that many steps. +c----------------------------------------------------------------------- + 100 ipup = miter + lmax = maxord + 1 + if (ialth .eq. 1) ialth = 2 + if (meth .eq. meo) go to 110 + CALL cfode (meth, elco, tesco) + meo = meth + if (nq .gt. maxord) go to 120 + ialth = l + iret = 1 + go to 150 + 110 if (nq .le. maxord) go to 160 + 120 nq = maxord + l = lmax + do 125 i = 1,l + 125 el(i) = elco(i,nq) + nqnyh = nq*nyh + rc = rc*el(1)/el0 + el0 = el(1) + conit = 0.5d0/dfloat(nq+2) + ddn = vnorm (n, savf, ewt)/tesco(1,l) + exdn = 1.0d0/dfloat(l) + rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0) + rh = dmin1(rhdn,1.0d0) + iredo = 3 + if (h .eq. hold) go to 170 + rh = dmin1(rh,dabs(h/hold)) + h = hold + go to 175 +c----------------------------------------------------------------------- +c cfode is called to get all the integration coefficients for the +c current meth. then the el vector and related constants are reset +c whenever the order nq is changed, or at the start of the problem. +c----------------------------------------------------------------------- + 140 CALL cfode (meth, elco, tesco) + 150 do 155 i = 1,l + 155 el(i) = elco(i,nq) + nqnyh = nq*nyh + rc = rc*el(1)/el0 + el0 = el(1) + conit = 0.5d0/dfloat(nq+2) + go to (160, 170, 200), iret +c----------------------------------------------------------------------- +c if h is being changed, the h ratio rh is checked against +c rmax, hmin, and hmxi, and the yh array rescaled. ialth is set to +c l = nq + 1 to prevent a change of h for that many steps, unless +c forced by a convergence or error test failure. +c----------------------------------------------------------------------- + 160 if (h .eq. hold) go to 200 + rh = h/hold + h = hold + iredo = 3 + go to 175 + 170 rh = DMAX1(rh,hmin/dabs(h)) + 175 rh = dmin1(rh,rmax) + rh = rh/DMAX1(1.0d0,dabs(h)*hmxi*rh) + r = 1.0d0 + do 180 j = 2,l + r = r*rh + do 180 i = 1,n + 180 yh(i,j) = yh(i,j)*r + h = h*rh + rc = rc*rh + ialth = l + if (iredo .eq. 0) go to 690 +c----------------------------------------------------------------------- +c this section computes the predicted values by effectively +c multiplying the yh array by the pascal triangle matrix. +c rc is the ratio of new to old values of the coefficient h*el(1). +c when rc differs from 1 by more than ccmax, ipup is set to miter +c to force pjac to be called, if a jacobian is involved. +c in any case, pjac is called at least every msbp steps. +c----------------------------------------------------------------------- + 200 if (dabs(rc-1.0d0) .gt. ccmax) ipup = miter + if (nst .ge. nslp+msbp) ipup = miter + tn = tn + h + i1 = nqnyh + 1 + do 215 jb = 1,nq + i1 = i1 - nyh +cdir$ ivdep + do 210 i = i1,nqnyh + 210 yh1(i) = yh1(i) + yh1(i+nyh) + 215 continue +c----------------------------------------------------------------------- +c up to maxcor corrector iterations are taken. a convergence test is +c made on the r.m.s. norm of each correction, weighted by the error +c weight vector ewt. the sum of the corrections is accumulated in the +c vector acor(i). the yh array is not altered in the corrector loop. +c----------------------------------------------------------------------- + 220 m = 0 + do 230 i = 1,n + 230 y(i) = yh(i,1) + CALL f (neq, tn, y, savf) + nfe = nfe + 1 + if (ipup .le. 0) go to 250 +c----------------------------------------------------------------------- +c if indicated, the matrix p = i - h*el(1)*j is reevaluated and +c preprocessed before starting the corrector iteration. ipup is set +c to 0 as an indicator that this has been done. +c----------------------------------------------------------------------- + CALL pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac) + ipup = 0 + rc = 1.0d0 + nslp = nst + crate = 0.7d0 + if (ierpj .ne. 0) go to 430 + 250 do 260 i = 1,n + 260 acor(i) = 0.0d0 + 270 if (miter .ne. 0) go to 350 +c----------------------------------------------------------------------- +c in the case of functional iteration, update y directly from +c the result of the last function evaluation. +c----------------------------------------------------------------------- + do 290 i = 1,n + savf(i) = h*savf(i) - yh(i,2) + 290 y(i) = savf(i) - acor(i) + del = vnorm (n, y, ewt) + do 300 i = 1,n + y(i) = yh(i,1) + el(1)*savf(i) + 300 acor(i) = savf(i) + go to 400 +c----------------------------------------------------------------------- +c in the case of the chord method, compute the corrector error, +c and solve the linear system with that as right-hand side and +c p as coefficient matrix. +c----------------------------------------------------------------------- + 350 do 360 i = 1,n + 360 y(i) = h*savf(i) - (yh(i,2) + acor(i)) + CALL slvs (wm, iwm, y, savf) + if (iersl .lt. 0) go to 430 + if (iersl .gt. 0) go to 410 + del = vnorm (n, y, ewt) + do 380 i = 1,n + acor(i) = acor(i) + y(i) + 380 y(i) = yh(i,1) + el(1)*acor(i) +c----------------------------------------------------------------------- +c test for convergence. if m.gt.0, an estimate of the convergence +c rate constant is stored in crate, and this is used in the test. +c----------------------------------------------------------------------- + 400 if (m .ne. 0) crate = DMAX1(0.2d0*crate,del/delp) + dcon = del*dmin1(1.0d0,1.5d0*crate)/(tesco(2,nq)*conit) + if (dcon .le. 1.0d0) go to 450 + m = m + 1 + if (m .eq. maxcor) go to 410 + if (m .ge. 2 .and. del .gt. 2.0d0*delp) go to 410 + delp = del + CALL f (neq, tn, y, savf) + nfe = nfe + 1 + go to 270 +c----------------------------------------------------------------------- +c the corrector iteration failed to converge. +c if miter .ne. 0 and the jacobian is out of date, pjac is called for +c the next try. otherwise the yh array is retracted to its values +c before prediction, and h is reduced, if possible. if h cannot be +c reduced or mxncf failures have occurred, exit with kflag = -2. +c----------------------------------------------------------------------- + 410 if (miter .eq. 0 .or. jcur .eq. 1) go to 430 + icf = 1 + ipup = miter + go to 220 + 430 icf = 2 + ncf = ncf + 1 + rmax = 2.0d0 + tn = told + i1 = nqnyh + 1 + do 445 jb = 1,nq + i1 = i1 - nyh +cdir$ ivdep + do 440 i = i1,nqnyh + 440 yh1(i) = yh1(i) - yh1(i+nyh) + 445 continue + if (ierpj .lt. 0 .or. iersl .lt. 0) go to 680 + if (dabs(h) .le. hmin*1.00001d0) go to 670 + if (ncf .eq. mxncf) go to 670 + rh = 0.25d0 + ipup = miter + iredo = 1 + go to 170 +c----------------------------------------------------------------------- +c the corrector has converged. jcur is set to 0 +c to signal that the jacobian involved may need updating later. +c the local error test is made and control passes to statement 500 +c if it fails. +c----------------------------------------------------------------------- + 450 jcur = 0 + if (m .eq. 0) dsm = del/tesco(2,nq) + if (m .gt. 0) dsm = vnorm (n, acor, ewt)/tesco(2,nq) + if (dsm .gt. 1.0d0) go to 500 +c----------------------------------------------------------------------- +c after a successful step, update the yh array. +c consider changing h if ialth = 1. otherwise decrease ialth by 1. +c if ialth is then 1 and nq .lt. maxord, then acor is saved for +c use in a possible order increase on the next step. +c if a change in h is considered, an increase or decrease in order +c by one is considered also. a change in h is made only if it is by a +c factor of at least 1.1. if not, ialth is set to 3 to prevent +c testing for that many steps. +c----------------------------------------------------------------------- + kflag = 0 + iredo = 0 + nst = nst + 1 + hu = h + nqu = nq + do 470 j = 1,l + do 470 i = 1,n + 470 yh(i,j) = yh(i,j) + el(j)*acor(i) + ialth = ialth - 1 + if (ialth .eq. 0) go to 520 + if (ialth .gt. 1) go to 700 + if (l .eq. lmax) go to 700 + do 490 i = 1,n + 490 yh(i,lmax) = acor(i) + go to 700 +c----------------------------------------------------------------------- +c the error test failed. kflag keeps track of multiple failures. +c restore tn and the yh array to their previous values, and prepare +c to try the step again. compute the optimum step size for this or +c one lower order. after 2 or more failures, h is forced to decrease +c by a factor of 0.2 or less. +c----------------------------------------------------------------------- + 500 kflag = kflag - 1 + tn = told + i1 = nqnyh + 1 + do 515 jb = 1,nq + i1 = i1 - nyh +cdir$ ivdep + do 510 i = i1,nqnyh + 510 yh1(i) = yh1(i) - yh1(i+nyh) + 515 continue + rmax = 2.0d0 + if (dabs(h) .le. hmin*1.00001d0) go to 660 + if (kflag .le. -3) go to 640 + iredo = 2 + rhup = 0.0d0 + go to 540 +c----------------------------------------------------------------------- +c regardless of the success or failure of the step, factors +c rhdn, rhsm, and rhup are computed, by which h could be multiplied +c at order nq - 1, order nq, or order nq + 1, respectively. +c in the case of failure, rhup = 0.0 to avoid an order increase. +c the largest of these is determined and the new order chosen +c accordingly. if the order is to be increased, we compute one +c additional scaled derivative. +c----------------------------------------------------------------------- + 520 rhup = 0.0d0 + if (l .eq. lmax) go to 540 + do 530 i = 1,n + 530 savf(i) = acor(i) - yh(i,lmax) + dup = vnorm (n, savf, ewt)/tesco(3,nq) + exup = 1.0d0/dfloat(l+1) + rhup = 1.0d0/(1.4d0*dup**exup + 0.0000014d0) + 540 exsm = 1.0d0/dfloat(l) + rhsm = 1.0d0/(1.2d0*dsm**exsm + 0.0000012d0) + rhdn = 0.0d0 + if (nq .eq. 1) go to 560 + ddn = vnorm (n, yh(1,l), ewt)/tesco(1,nq) + exdn = 1.0d0/dfloat(nq) + rhdn = 1.0d0/(1.3d0*ddn**exdn + 0.0000013d0) + 560 if (rhsm .ge. rhup) go to 570 + if (rhup .gt. rhdn) go to 590 + go to 580 + 570 if (rhsm .lt. rhdn) go to 580 + newq = nq + rh = rhsm + go to 620 + 580 newq = nq - 1 + rh = rhdn + if (kflag .lt. 0 .and. rh .gt. 1.0d0) rh = 1.0d0 + go to 620 + 590 newq = l + rh = rhup + if (rh .lt. 1.1d0) go to 610 + r = el(l)/dfloat(l) + do 600 i = 1,n + 600 yh(i,newq+1) = acor(i)*r + go to 630 + 610 ialth = 3 + go to 700 + 620 if ((kflag .eq. 0) .and. (rh .lt. 1.1d0)) go to 610 + if (kflag .le. -2) rh = dmin1(rh,0.2d0) +c----------------------------------------------------------------------- +c if there is a change of order, reset nq, l, and the coefficients. +c in any case h is reset according to rh and the yh array is rescaled. +c then exit from 690 if the step was ok, or redo the step otherwise. +c----------------------------------------------------------------------- + if (newq .eq. nq) go to 170 + 630 nq = newq + l = nq + 1 + iret = 2 + go to 150 +c----------------------------------------------------------------------- +c control reaches this section if 3 or more failures have occured. +c if 10 failures have occurred, exit with kflag = -1. +c it is assumed that the derivatives that have accumulated in the +c yh array have errors of the wrong order. hence the first +c derivative is recomputed, and the order is set to 1. then +c h is reduced by a factor of 10, and the step is retried, +c until it succeeds or h reaches hmin. +c----------------------------------------------------------------------- + 640 if (kflag .eq. -10) go to 660 + rh = 0.1d0 + rh = DMAX1(hmin/dabs(h),rh) + h = h*rh + do 645 i = 1,n + 645 y(i) = yh(i,1) + CALL f (neq, tn, y, savf) + nfe = nfe + 1 + do 650 i = 1,n + 650 yh(i,2) = h*savf(i) + ipup = miter + ialth = 5 + if (nq .eq. 1) go to 200 + nq = 1 + l = 2 + iret = 3 + go to 150 +c----------------------------------------------------------------------- +c all returns are made through this section. h is saved in hold +c to allow the caller to change h on the next step. +c----------------------------------------------------------------------- + 660 kflag = -1 + go to 720 + 670 kflag = -2 + go to 720 + 680 kflag = -3 + go to 720 + 690 rmax = 10.0d0 + 700 r = 1.0d0/tesco(2,nqu) + do 710 i = 1,n + 710 acor(i) = acor(i)*r + 720 hold = h + jstart = 1 + return +c----------------------- end of subroutine stode ----------------------- + end + subroutine xerrwv (msg, nmes, nerr, level, ni, i1, i2, nr, r1, r2) + integer msg, nmes, nerr, level, ni, i1, i2, nr, + 1 i, lun, lunit, mesflg, ncpw, nch, nwds + KPP_REAL r1, r2 + dimension msg(nmes) +c----------------------------------------------------------------------- +c subroutines xerrwv, xsetf, and xsetun, as given here, constitute +c a simplified version of the slatec error handling package. +c written by a. c. hindmarsh at llnl. version of march 30, 1987. +c this version is in KPP_REAL. +c +c all arguments are input arguments. +c +c msg = the message (hollerith literal or integer array). +c nmes = the length of msg (number of characters). +c nerr = the error number (not used). +c level = the error level.. +c 0 or 1 means recoverable (control returns to caller). +c 2 means fatal (run is aborted--see note below). +c ni = number of integers (0, 1, or 2) to be printed with message. +c i1,i2 = integers to be printed, depending on ni. +c nr = number of reals (0, 1, or 2) to be printed with message. +c r1,r2 = reals to be printed, depending on nr. +c +c note.. this routine is machine-dependent and specialized for use +c in limited context, in the following ways.. +c 1. the number of hollerith characters stored per word, denoted +c by ncpw below, is a data-loaded constant. +c 2. the value of nmes is assumed to be at most 60. +c (multi-line messages are generated by repeated calls.) +c 3. if level = 2, control passes to the statement stop +c to abort the run. this statement may be machine-dependent. +c 4. r1 and r2 are assumed to be in KPP_REAL and are printed +c in d21.13 format. +c 5. the common block /eh0001/ below is data-loaded (a machine- +c dependent feature) with default values. +c this block is needed for proper retention of parameters used by +c this routine which the user can reset by calling xsetf or xsetun. +c the variables in this block are as follows.. +c mesflg = print control flag.. +c 1 means print all messages (the default). +c 0 means no printing. +c lunit = logical unit number for messages. +c the default is 6 (machine-dependent). +c----------------------------------------------------------------------- +c the following are instructions for installing this routine +c in different machine environments. +c +c to change the default output unit, change the data statement +c in the block data subprogram below. +c +c for a different number of characters per word, change the +c data statement setting ncpw below, and format 10. alternatives for +c various computers are shown in comment cards. +c +c for a different run-abort command, change the statement following +c statement 100 at the end. +c----------------------------------------------------------------------- + common /eh0001/ mesflg, lunit +c----------------------------------------------------------------------- +c the following data-loaded value of ncpw is valid for the cdc-6600 +c and cdc-7600 computers. +c data ncpw/10/ +c the following is valid for the cray-1 computer. +c data ncpw/8/ +c the following is valid for the burroughs 6700 and 7800 computers. +c data ncpw/6/ +c the following is valid for the pdp-10 computer. +c data ncpw/5/ +c the following is valid for the vax computer with 4 bytes per integer, +c and for the ibm-360, ibm-370, ibm-303x, and ibm-43xx computers. + data ncpw/4/ +c the following is valid for the pdp-11, or vax with 2-byte integers. +c data ncpw/2/ +c----------------------------------------------------------------------- + if (mesflg .eq. 0) go to 100 +c get logical unit number. --------------------------------------------- + lun = lunit +c get number of words in message. -------------------------------------- + nch = min0(nmes,60) + nwds = nch/ncpw + if (nch .ne. nwds*ncpw) nwds = nwds + 1 +c write the message. --------------------------------------------------- + write (lun, 10) (msg(i),i=1,nwds) +c----------------------------------------------------------------------- +c the following format statement is to have the form +c 10 format(1x,mmann) +c where nn = ncpw and mm is the smallest integer .ge. 60/ncpw. +c the following is valid for ncpw = 10. +c 10 format(1x,6a10) +c the following is valid for ncpw = 8. +c 10 format(1x,8a8) +c the following is valid for ncpw = 6. +c 10 format(1x,10a6) +c the following is valid for ncpw = 5. +c 10 format(1x,12a5) +c the following is valid for ncpw = 4. + 10 format(1x,15a4) +c the following is valid for ncpw = 2. +c 10 format(1x,30a2) +c----------------------------------------------------------------------- + if (ni .eq. 1) write (lun, 20) i1 + 20 format(6x,23hin above message, i1 =,i10) + if (ni .eq. 2) write (lun, 30) i1,i2 + 30 format(6x,23hin above message, i1 =,i10,3x,4hi2 =,i10) + if (nr .eq. 1) write (lun, 40) r1 + 40 format(6x,23hin above message, r1 =,d21.13) + if (nr .eq. 2) write (lun, 50) r1,r2 + 50 format(6x,15hin above, r1 =,d21.13,3x,4hr2 =,d21.13) +c abort the run if level = 2. ------------------------------------------ + 100 if (level .ne. 2) return + stop +c----------------------- end of subroutine xerrwv ---------------------- + end + KPP_REAL function vnorm (n, v, w) +clll. optimize +c----------------------------------------------------------------------- +c this function routine computes the weighted root-mean-square norm +c of the vector of length n contained in the array v, with weights +c contained in the array w of length n.. +c vnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 ) +c----------------------------------------------------------------------- + integer n, i + KPP_REAL v, w, sum + dimension v(n), w(n) + sum = 0.0d0 + do 10 i = 1,n + 10 sum = sum + (v(i)*w(i))**2 + vnorm = DSQRT(sum/dfloat(n)) + return +c----------------------- end of function vnorm ------------------------- + end + subroutine ewset (n, itol, RelTol, AbsTol, ycur, ewt) +clll. optimize +c----------------------------------------------------------------------- +c this subroutine sets the error weight vector ewt according to +c ewt(i) = RelTol(i)*abs(ycur(i)) + AbsTol(i), i = 1,...,n, +c with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, +c depending on the value of itol. +c----------------------------------------------------------------------- + integer n, itol + integer i + KPP_REAL RelTol, AbsTol, ycur, ewt + dimension RelTol(1), AbsTol(1), ycur(n), ewt(n) +c + go to (10, 20, 30, 40), itol + 10 continue + do 15 i = 1,n + 15 ewt(i) = RelTol(1)*dabs(ycur(i)) + AbsTol(1) + return + 20 continue + do 25 i = 1,n + 25 ewt(i) = RelTol(1)*dabs(ycur(i)) + AbsTol(i) + return + 30 continue + do 35 i = 1,n + 35 ewt(i) = RelTol(i)*dabs(ycur(i)) + AbsTol(1) + return + 40 continue + do 45 i = 1,n + 45 ewt(i) = RelTol(i)*dabs(ycur(i)) + AbsTol(i) + return +c----------------------- end of subroutine ewset ----------------------- + end + subroutine cfode (meth, elco, tesco) +clll. optimize + integer meth + integer i, ib, nq, nqm1, nqp1 + KPP_REAL elco, tesco + KPP_REAL agamq, fnq, fnqm1, pc, pint, ragq, + 1 rqfac, rq1fac, tsign, xpin + dimension elco(13,12), tesco(3,12) +c----------------------------------------------------------------------- +c cfode is called by the integrator routine to set coefficients +c needed there. the coefficients for the current method, as +c given by the value of meth, are set for all orders and saved. +c the maximum order assumed here is 12 if meth = 1 and 5 if meth = 2. +c (a smaller value of the maximum order is also allowed.) +c cfode is called once at the beginning of the problem, +c and is not called again unless and until meth is changed. +c +c the elco array contains the basic method coefficients. +c the coefficients el(i), 1 .le. i .le. nq+1, for the method of +c order nq are stored in elco(i,nq). they are given by a genetrating +c polynomial, i.e., +c l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. +c for the implicit adams methods, l(x) is given by +c dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. +c for the bdf methods, l(x) is given by +c l(x) = (x+1)*(x+2)* ... *(x+nq)/k, +c where k = factorial(nq)*(1 + 1/2 + ... + 1/nq). +c +c the tesco array contains test constants used for the +c local error test and the selection of step size and/or order. +c at order nq, tesco(k,nq) is used for the selection of step +c size at order nq - 1 if k = 1, at order nq if k = 2, and at order +c nq + 1 if k = 3. +c----------------------------------------------------------------------- + dimension pc(12) +c + go to (100, 200), meth +c + 100 elco(1,1) = 1.0d0 + elco(2,1) = 1.0d0 + tesco(1,1) = 0.0d0 + tesco(2,1) = 2.0d0 + tesco(1,2) = 1.0d0 + tesco(3,12) = 0.0d0 + pc(1) = 1.0d0 + rqfac = 1.0d0 + do 140 nq = 2,12 +c----------------------------------------------------------------------- +c the pc array will contain the coefficients of the polynomial +c p(x) = (x+1)*(x+2)*...*(x+nq-1). +c initially, p(x) = 1. +c----------------------------------------------------------------------- + rq1fac = rqfac + rqfac = rqfac/dfloat(nq) + nqm1 = nq - 1 + fnqm1 = dfloat(nqm1) + nqp1 = nq + 1 +c form coefficients of p(x)*(x+nq-1). ---------------------------------- + pc(nq) = 0.0d0 + do 110 ib = 1,nqm1 + i = nqp1 - ib + 110 pc(i) = pc(i-1) + fnqm1*pc(i) + pc(1) = fnqm1*pc(1) +c compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- + pint = pc(1) + xpin = pc(1)/2.0d0 + tsign = 1.0d0 + do 120 i = 2,nq + tsign = -tsign + pint = pint + tsign*pc(i)/dfloat(i) + 120 xpin = xpin + tsign*pc(i)/dfloat(i+1) +c store coefficients in elco and tesco. -------------------------------- + elco(1,nq) = pint*rq1fac + elco(2,nq) = 1.0d0 + do 130 i = 2,nq + 130 elco(i+1,nq) = rq1fac*pc(i)/dfloat(i) + agamq = rqfac*xpin + ragq = 1.0d0/agamq + tesco(2,nq) = ragq + if (nq .lt. 12) tesco(1,nqp1) = ragq*rqfac/dfloat(nqp1) + tesco(3,nqm1) = ragq + 140 continue + return +c + 200 pc(1) = 1.0d0 + rq1fac = 1.0d0 + do 230 nq = 1,5 +c----------------------------------------------------------------------- +c the pc array will contain the coefficients of the polynomial +c p(x) = (x+1)*(x+2)*...*(x+nq). +c initially, p(x) = 1. +c----------------------------------------------------------------------- + fnq = dfloat(nq) + nqp1 = nq + 1 +c form coefficients of p(x)*(x+nq). ------------------------------------ + pc(nqp1) = 0.0d0 + do 210 ib = 1,nq + i = nq + 2 - ib + 210 pc(i) = pc(i-1) + fnq*pc(i) + pc(1) = fnq*pc(1) +c store coefficients in elco and tesco. -------------------------------- + do 220 i = 1,nqp1 + 220 elco(i,nq) = pc(i)/pc(2) + elco(2,nq) = 1.0d0 + tesco(1,nq) = rq1fac + tesco(2,nq) = dfloat(nqp1)/elco(1,nq) + tesco(3,nq) = dfloat(nq+2)/elco(1,nq) + rq1fac = rq1fac/fnq + 230 continue + return +c----------------------- end of subroutine cfode ----------------------- + end + subroutine cdrv + * (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) +clll. optimize +c*** subroutine cdrv +c*** driver for subroutines for solving sparse nonsymmetric systems of +c linear equations (compressed pointer storage) +c +c +c parameters +c class abbreviations are-- +c n - integer variable +c f - real variable +c v - supplies a value to the driver +c r - returns a result from the driver +c i - used internally by the driver +c a - array +c +c class - parameter +c ------+---------- +c - +c the nonzero entries of the coefficient matrix m are stored +c row-by-row in the array a. to identify the individual nonzero +c entries in each row, we need to know in which column each entry +c lies. the column indices which correspond to the nonzero entries +c of m are stored in the array ja. i.e., if a(k) = m(i,j), then +c ja(k) = j. in addition, we need to know where each row starts and +c how long it is. the index positions in ja and a where the rows of +c m begin are stored in the array ia. i.e., if m(i,j) is the first +c nonzero entry (stored) in the i-th row and a(k) = m(i,j), then +c ia(i) = k. moreover, the index in ja and a of the first location +c following the last element in the last row is stored in ia(n+1). +c thus, the number of entries in the i-th row is given by +c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored +c consecutively in +c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +c and the corresponding column indices are stored consecutively in +c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +c for example, the 5 by 5 matrix +c ( 1. 0. 2. 0. 0.) +c ( 0. 3. 0. 0. 0.) +c m = ( 0. 4. 5. 6. 0.) +c ( 0. 0. 0. 7. 0.) +c ( 0. 0. 0. 8. 9.) +c would be stored as +c - 1 2 3 4 5 6 7 8 9 +c ---+-------------------------- +c ia - 1 3 4 7 8 10 +c ja - 1 3 2 2 3 4 4 4 5 +c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . +c +c nv - n - number of variables/equations. +c fva - a - nonzero entries of the coefficient matrix m, stored +c - by rows. +c - size = number of nonzero entries in m. +c nva - ia - pointers to delimit the rows in a. +c - size = n+1. +c nva - ja - column numbers corresponding to the elements of a. +c - size = size of a. +c fva - b - right-hand side b. b and z can the same array. +c - size = n. +c fra - z - solution x. b and z can be the same array. +c - size = n. +c +c the rows and columns of the original matrix m can be +c reordered (e.g., to reduce fillin or ensure numerical stability) +c before calling the driver. if no reordering is done, then set +c r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned +c in the original order. +c if the columns have been reordered (i.e., c(i).ne.i for some +c i), then the driver will CALL a subroutine (nroc) which rearranges +c each row of ja and a, leaving the rows in the original order, but +c placing the elements of each row in increasing order with respect +c to the new ordering. if path.ne.1, then nroc is assumed to have +c been called already. +c +c nva - r - ordering of the rows of m. +c - size = n. +c nva - c - ordering of the columns of m. +c - size = n. +c nva - ic - inverse of the ordering of the columns of m. i.e., +c - ic(c(i)) = i for i=1,...,n. +c - size = n. +c +c the solution of the system of linear equations is divided into +c three stages -- +c nsfc -- the matrix m is processed symbolically to determine where +c fillin will occur during the numeric factorization. +c nnfc -- the matrix m is factored numerically into the product ldu +c of a unit lower triangular matrix l, a diagonal matrix +c d, and a unit upper triangular matrix u, and the system +c mx = b is solved. +c nnsc -- the linear system mx = b is solved using the ldu +c or factorization from nnfc. +c nntc -- the transposed linear system mt x = b is solved using +c the ldu factorization from nnf. +c for several systems whose coefficient matrices have the same +c nonzero structure, nsfc need be done only once (for the first +c system). then nnfc is done once for each additional system. for +c several systems with the same coefficient matrix, nsfc and nnfc +c need be done only once (for the first system). then nnsc or nntc +c is done once for each additional right-hand side. +c +c nv - path - path specification. values and their meanings are -- +c - 1 perform nroc, nsfc, and nnfc. +c - 2 perform nnfc only (nsfc is assumed to have been +c - done in a manner compatible with the storage +c - allocation used in the driver). +c - 3 perform nnsc only (nsfc and nnfc are assumed to +c - have been done in a manner compatible with the +c - storage allocation used in the driver). +c - 4 perform nntc only (nsfc and nnfc are assumed to +c - have been done in a manner compatible with the +c - storage allocation used in the driver). +c - 5 perform nroc and nsfc. +c +c various errors are detected by the driver and the individual +c subroutines. +c +c nr - flag - error flag. values and their meanings are -- +c - 0 no errors detected +c - n+k null row in a -- row = k +c - 2n+k duplicate entry in a -- row = k +c - 3n+k insufficient storage in nsfc -- row = k +c - 4n+1 insufficient storage in nnfc +c - 5n+k null pivot -- row = k +c - 6n+k insufficient storage in nsfc -- row = k +c - 7n+1 insufficient storage in nnfc +c - 8n+k zero pivot -- row = k +c - 10n+1 insufficient storage in cdrv +c - 11n+1 illegal path specification +c +c working storage is needed for the factored form of the matrix +c m plus various temporary vectors. the arrays isp and rsp should be +c equivalenced. integer storage is allocated from the beginning of +c isp and real storage from the end of rsp. +c +c nv - nsp - declared dimension of rsp. nsp generally must +c - be larger than 8n+2 + 2k (where k = (number of +c - nonzero entries in m)). +c nvira - isp - integer working storage divided up into various arrays +c - needed by the subroutines. isp and rsp should be +c - equivalenced. +c - size = lratio*nsp. +c fvira - rsp - real working storage divided up into various arrays +c - needed by the subroutines. isp and rsp should be +c - equivalenced. +c - size = nsp. +c nr - esp - if sufficient storage was available to perform the +c - symbolic factorization (nsfc), then esp is set to +c - the amount of excess storage provided (negative if +c - insufficient storage was available to perform the +c - numeric factorization (nnfc)). +c +c +c conversion to KPP_REAL +c +c to convert these routines for KPP_REAL arrays.. +c (1) use the KPP_REAL declarations in place of the real +c declarations in each subprogram, as given in comment cards. +c (2) change the data-loaded value of the integer lratio +c in subroutine cdrv, as indicated below. +c (3) change e0 to d0 in the constants in statement number 10 +c in subroutine nnfc and the line following that. +c + integer r(1), c(1), ic(1), ia(1), ja(1), isp(1), esp, path, + * flag, d, u, q, row, tmp, ar, umax + KPP_REAL a(1), b(1), z(1), rsp(1) +c +c set lratio equal to the ratio between the length of floating point +c and integer array data. e. g., lratio = 1 for (real, integer), +c lratio = 2 for (KPP_REAL, integer) +c + data lratio/2/ +c + if (path.lt.1 .or. 5.lt.path) go to 111 +c******initialize and divide up temporary storage ******************* + il = 1 + ijl = il + (n+1) + iu = ijl + n + iju = iu + (n+1) + irl = iju + n + jrl = irl + n + jl = jrl + n +c +c ****** reorder a if necessary, CALL nsfc if flag is set *********** + if ((path-1) * (path-5) .ne. 0) go to 5 + max = (lratio*nsp + 1 - jl) - (n+1) - 5*n + jlmax = max/2 + q = jl + jlmax + ira = q + (n+1) + jra = ira + n + irac = jra + n + iru = irac + n + jru = iru + n + jutmp = jru + n + jumax = lratio*nsp + 1 - jutmp + esp = max/lratio + if (jlmax.le.0 .or. jumax.le.0) go to 110 +c + do 1 i=1,n + if (c(i).ne.i) go to 2 + 1 continue + go to 3 + 2 ar = nsp + 1 - n + CALL nroc + * (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) + if (flag.ne.0) go to 100 +c + 3 CALL nsfc + * (n, r, ic, ia,ja, + * jlmax, isp(il), isp(jl), isp(ijl), + * jumax, isp(iu), isp(jutmp), isp(iju), + * isp(q), isp(ira), isp(jra), isp(irac), + * isp(irl), isp(jrl), isp(iru), isp(jru), flag) + if(flag .ne. 0) go to 100 +c ****** move ju next to jl ***************************************** + jlmax = isp(ijl+n-1) + ju = jl + jlmax + jumax = isp(iju+n-1) + if (jumax.le.0) go to 5 + do 4 j=1,jumax + 4 isp(ju+j-1) = isp(jutmp+j-1) +c +c ****** CALL remaining subroutines ********************************* + 5 jlmax = isp(ijl+n-1) + ju = jl + jlmax + jumax = isp(iju+n-1) + l = (ju + jumax - 2 + lratio) / lratio + 1 + lmax = isp(il+n) - 1 + d = l + lmax + u = d + n + row = nsp + 1 - n + tmp = row - n + umax = tmp - u + esp = umax - (isp(iu+n) - 1) +c + if ((path-1) * (path-2) .ne. 0) go to 6 + if (umax.lt.0) go to 110 + CALL nnfc + * (n, r, c, ic, ia, ja, a, z, b, + * lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), + * umax, isp(iu), isp(ju), isp(iju), rsp(u), + * rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) + if(flag .ne. 0) go to 100 +c + 6 if ((path-3) .ne. 0) go to 7 + CALL nnsc + * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), + * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), + * z, b, rsp(tmp)) +c + 7 if ((path-4) .ne. 0) go to 8 + CALL nntc + * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), + * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), + * z, b, rsp(tmp)) + 8 return +c +c ** error.. error detected in nroc, nsfc, nnfc, or nnsc + 100 return +c ** error.. insufficient storage + 110 flag = 10*n + 1 + return +c ** error.. illegal path specification + 111 flag = 11*n + 1 + return + end + subroutine prep (neq, y, yh, savf, ewt, ftem, ia, ja, + 1 wk, iwk, ipper, f, jac) +clll. optimize + external f,jac + integer neq(*), ia(*), ja(*), iwk(*), ipper + integer iownd, iowns, + 1 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 2 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 1 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 2 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 3 nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, jfound, k, + 1 knew, kmax, kmin, ldif, lenigp, liwk, maxg, np1, nzsut + KPP_REAL y(*), yh(*), savf(*), ewt(*), ftem(*), wk(*) + KPP_REAL rowns, + 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + KPP_REAL con0, conmin, ccmxj, psmall, rbig, seth + KPP_REAL dq, dyj, erwt, fac, yj, JJJ(n,n) + common /ls0001/ rowns(209), + 2 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, + 3 iownd(14), iowns(6), + 4 icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, + 5 maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, + 1 iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, + 2 ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, + 3 lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, + 4 nslj, ngp, nlu, nnz, nsp, nzl, nzu +c----------------------------------------------------------------------- +c this routine performs preprocessing related to the sparse linear +c systems that must be solved if miter = 1 or 2. +c the operations that are performed here are.. +c * compute sparseness structure of jacobian according to moss, +c * compute grouping of column indices (miter = 2), +c * compute a new ordering of rows and columns of the matrix, +c * reorder ja corresponding to the new ordering, +c * perform a symbolic lu factorization of the matrix, and +c * set pointers for segments of the iwk/wk array. +c in addition to variables described previously, prep uses the +c following for communication.. +c yh = the history array. only the first column, containing the +c current y vector, is used. used only if moss .ne. 0. +c savf = a work array of length neq, used only if moss .ne. 0. +c ewt = array of length neq containing (inverted) error weights. +c used only if moss = 2 or if istate = moss = 1. +c ftem = a work array of length neq, identical to acor in the driver, +c used only if moss = 2. +c wk = a real work array of length lenwk, identical to wm in +c the driver. +c iwk = integer work array, assumed to occupy the same space as wk. +c lenwk = the length of the work arrays wk and iwk. +c istatc = a copy of the driver input argument istate (= 1 on the +c first call, = 3 on a continuation call). +c iys = flag value from odrv or cdrv. +c ipper = output error flag with the following values and meanings.. +c 0 no error. +c -1 insufficient storage for internal structure pointers. +c -2 insufficient storage for jgroup. +c -3 insufficient storage for odrv. +c -4 other error flag from odrv (should never occur). +c -5 insufficient storage for cdrv. +c -6 other error flag from cdrv. +c----------------------------------------------------------------------- + ibian = lrat*2 + ipian = ibian + 1 + np1 = n + 1 + ipjan = ipian + np1 + ibjan = ipjan - 1 + liwk = lenwk*lrat + if (ipjan+n-1 .gt. liwk) go to 210 + if (moss .eq. 0) go to 30 +c + if (istatc .eq. 3) go to 20 +c istate = 1 and moss .ne. 0. perturb y for structure determination. -- + do 10 i = 1,n + erwt = 1.0d0/ewt(i) + fac = 1.0d0 + 1.0d0/(dfloat(i)+1.0d0) + y(i) = y(i) + fac*DSIGN(erwt,y(i)) + 10 continue + go to (70, 100), moss +c + 20 continue +c istate = 3 and moss .ne. 0. load y from yh(*,1). -------------------- + do 25 i = 1,n + 25 y(i) = yh(i) + go to (70, 100), moss +c +c moss = 0. process user-s ia,ja. add diagonal entries if necessary. - + 30 knew = ipjan + kmin = ia(1) + iwk(ipian) = 1 + do 60 j = 1,n + jfound = 0 + kmax = ia(j+1) - 1 + if (kmin .gt. kmax) go to 45 + do 40 k = kmin,kmax + i = ja(k) + if (i .eq. j) jfound = 1 + if (knew .gt. liwk) go to 210 + iwk(knew) = i + knew = knew + 1 + 40 continue + if (jfound .eq. 1) go to 50 + 45 if (knew .gt. liwk) go to 210 + iwk(knew) = j + knew = knew + 1 + 50 iwk(ipian+j) = knew + 1 - ipjan + kmin = kmax + 1 + 60 continue + go to 140 +c +c moss = 1. compute structure from user-supplied jacobian routine jac. + 70 continue +c a dummy CALL to f allows user to create temporaries for use in jac. -- + CALL f (neq, tn, y, savf) + k = ipjan + iwk(ipian) = 1 + call jac_chem (neq, tn, y, JJJ, j, iwk(ipian), iwk(ipjan)) + do 90 j = 1,n + if (k .gt. liwk) go to 210 + iwk(k) = j + k = k + 1 + do 75 i = 1,n + 75 savf(i) = 0.0d0 +C call jac_chem (neq, tn, y, j, iwk(ipian), iwk(ipjan), savf) + do i=1,n + savf(i) = JJJ(i,j) + end do + do 80 i = 1,n + if (dabs(savf(i)) .le. seth) go to 80 + if (i .eq. j) go to 80 + if (k .gt. liwk) go to 210 + iwk(k) = i + k = k + 1 + 80 continue + iwk(ipian+j) = k + 1 - ipjan + 90 continue + go to 140 +c +c moss = 2. compute structure from results of n + 1 calls to f. ------- + 100 k = ipjan + iwk(ipian) = 1 + CALL f (neq, tn, y, savf) + do 120 j = 1,n + if (k .gt. liwk) go to 210 + iwk(k) = j + k = k + 1 + yj = y(j) + erwt = 1.0d0/ewt(j) + dyj = DSIGN(erwt,yj) + y(j) = yj + dyj + CALL f (neq, tn, y, ftem) + y(j) = yj + do 110 i = 1,n + dq = (ftem(i) - savf(i))/dyj + if (dabs(dq) .le. seth) go to 110 + if (i .eq. j) go to 110 + if (k .gt. liwk) go to 210 + iwk(k) = i + k = k + 1 + 110 continue + iwk(ipian+j) = k + 1 - ipjan + 120 continue +c + 140 continue + if (moss .eq. 0 .or. istatc .ne. 1) go to 150 +c if istate = 1 and moss .ne. 0, restore y from yh. -------------------- + do 145 i = 1,n + 145 y(i) = yh(i) + 150 nnz = iwk(ipian+n) - 1 + lenigp = 0 + ipigp = ipjan + nnz + if (miter .ne. 2) go to 160 +c +c compute grouping of column indices (miter = 2). ---------------------- + maxg = np1 + ipjgp = ipjan + nnz + ibjgp = ipjgp - 1 + ipigp = ipjgp + n + iptt1 = ipigp + np1 + iptt2 = iptt1 + n + lreq = iptt2 + n - 1 + if (lreq .gt. liwk) go to 220 + CALL jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp), + 1 iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier) + if (ier .ne. 0) go to 220 + lenigp = ngp + 1 +c +c compute new ordering of rows/columns of jacobian. -------------------- + 160 ipr = ipigp + lenigp + ipc = ipr + ipic = ipc + n + ipisp = ipic + n + iprsp = (ipisp - 2)/lrat + 2 + iesp = lenwk + 1 - iprsp + if (iesp .lt. 0) go to 230 + ibr = ipr - 1 + do 170 i = 1,n + 170 iwk(ibr+i) = i + nsp = liwk + 1 - ipisp + CALL odrv (n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic), + 1 nsp, iwk(ipisp), 1, iys) + if (iys .eq. 11*n+1) go to 240 + if (iys .ne. 0) go to 230 +c +c reorder jan and do symbolic lu factorization of matrix. -------------- + ipa = lenwk + 1 - nnz + nsp = ipa - iprsp + lreq = max0(12*n/lrat, 6*n/lrat+2*n+nnz) + 3 + lreq = lreq + iprsp - 1 + nnz + if (lreq .gt. lenwk) go to 250 + iba = ipa - 1 + do 180 i = 1,nnz + 180 wk(iba+i) = 0.0d0 + ipisp = lrat*(iprsp - 1) + 1 + CALL cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), + 1 wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys) + lreq = lenwk - iesp + if (iys .eq. 10*n+1) go to 250 + if (iys .ne. 0) go to 260 + ipil = ipisp + ipiu = ipil + 2*n + 1 + nzu = iwk(ipil+n) - iwk(ipil) + nzl = iwk(ipiu+n) - iwk(ipiu) + if (lrat .gt. 1) go to 190 + CALL adjlr (n, iwk(ipisp), ldif) + lreq = lreq + ldif + 190 continue + if (lrat .eq. 2 .and. nnz .eq. n) lreq = lreq + 1 + nsp = nsp + lreq - lenwk + ipa = lreq + 1 - nnz + iba = ipa - 1 + ipper = 0 + return +c + 210 ipper = -1 + lreq = 2 + (2*n + 1)/lrat + lreq = max0(lenwk+1,lreq) + return +c + 220 ipper = -2 + lreq = (lreq - 1)/lrat + 1 + return +c + 230 ipper = -3 + CALL cntnzu (n, iwk(ipian), iwk(ipjan), nzsut) + lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1 + return +c + 240 ipper = -4 + return +c + 250 ipper = -5 + return +c + 260 ipper = -6 + lreq = lenwk + return +c----------------------- end of subroutine prep ------------------------ + end + subroutine cntnzu (n, ia, ja, nzsut) + integer n, ia, ja, nzsut + dimension ia(1), ja(1) +c----------------------------------------------------------------------- +c this routine counts the number of nonzero elements in the strict +c upper triangle of the matrix m + m(transpose), where the sparsity +c structure of m is given by pointer arrays ia and ja. +c this is needed to compute the storage requirements for the +c sparse matrix reordering operation in odrv. +c----------------------------------------------------------------------- + integer ii, jj, j, jmin, jmax, k, kmin, kmax, num +c + num = 0 + do 50 ii = 1,n + jmin = ia(ii) + jmax = ia(ii+1) - 1 + if (jmin .gt. jmax) go to 50 + do 40 j = jmin,jmax + if (ja(j) - ii) 10, 40, 30 + 10 jj =ja(j) + kmin = ia(jj) + kmax = ia(jj+1) - 1 + if (kmin .gt. kmax) go to 30 + do 20 k = kmin,kmax + if (ja(k) .eq. ii) go to 40 + 20 continue + 30 num = num + 1 + 40 continue + 50 continue + nzsut = num + return +c----------------------- end of subroutine cntnzu ---------------------- + end + subroutine nntc + * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) +clll. optimize +c*** subroutine nntc +c*** numeric solution of the transpose of a sparse nonsymmetric system +c of linear equations given lu-factorization (compressed pointer +c storage) +c +c +c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b +c output variables.. z +c +c parameters used internally.. +c fia - tmp - temporary vector which gets result of solving ut y = b +c - size = n. +c +c internal variables.. +c jmin, jmax - indices of the first and last positions in a row of +c u or l to be used. +c + integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) + KPP_REAL l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum +c +c ****** set tmp to reordered b ************************************* + do 1 k=1,n + 1 tmp(k) = b(c(k)) +c ****** solve ut y = b by forward substitution ******************* + do 3 k=1,n + jmin = iu(k) + jmax = iu(k+1) - 1 + tmpk = -tmp(k) + if (jmin .gt. jmax) go to 3 + mu = iju(k) - jmin + do 2 j=jmin,jmax + 2 tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) + 3 continue +c ****** solve lt x = y by back substitution ********************** + k = n + do 6 i=1,n + sum = -tmp(k) + jmin = il(k) + jmax = il(k+1) - 1 + if (jmin .gt. jmax) go to 5 + ml = ijl(k) - jmin + do 4 j=jmin,jmax + 4 sum = sum + l(j) * tmp(jl(ml+j)) + 5 tmp(k) = -sum * d(k) + z(r(k)) = tmp(k) + k = k - 1 + 6 continue + return + end + subroutine nnsc + * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) +clll. optimize +c*** subroutine nnsc +c*** numerical solution of sparse nonsymmetric system of linear +c equations given ldu-factorization (compressed pointer storage) +c +c +c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b +c output variables.. z +c +c parameters used internally.. +c fia - tmp - temporary vector which gets result of solving ly = b. +c - size = n. +c +c internal variables.. +c jmin, jmax - indices of the first and last positions in a row of +c u or l to be used. +c + integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) + KPP_REAL l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum +c +c ****** set tmp to reordered b ************************************* + do 1 k=1,n + 1 tmp(k) = b(r(k)) +c ****** solve ly = b by forward substitution ********************* + do 3 k=1,n + jmin = il(k) + jmax = il(k+1) - 1 + tmpk = -d(k) * tmp(k) + tmp(k) = -tmpk + if (jmin .gt. jmax) go to 3 + ml = ijl(k) - jmin + do 2 j=jmin,jmax + 2 tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) + 3 continue +c ****** solve ux = y by back substitution ************************ + k = n + do 6 i=1,n + sum = -tmp(k) + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 5 + mu = iju(k) - jmin + do 4 j=jmin,jmax + 4 sum = sum + u(j) * tmp(ju(mu+j)) + 5 tmp(k) = -sum + z(c(k)) = -sum + k = k - 1 + 6 continue + return + end + subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) +clll. optimize +c +c ---------------------------------------------------------------- +c +c yale sparse matrix package - nonsymmetric codes +c solving the system of equations mx = b +c +c i. calling sequences +c the coefficient matrix can be processed by an ordering routine +c (e.g., to reduce fillin or ensure numerical stability) before using +c the remaining subroutines. if no reordering is done, then set +c r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine +c is used, then nroc should be used to reorder the coefficient matrix +c the calling sequence is -- +c ( (matrix ordering)) +c (nroc (matrix reordering)) +c nsfc (symbolic factorization to determine where fillin will +c occur during numeric factorization) +c nnfc (numeric factorization into product ldu of unit lower +c triangular matrix l, diagonal matrix d, and unit +c upper triangular matrix u, and solution of linear +c system) +c nnsc (solution of linear system for additional right-hand +c side using ldu factorization from nnfc) +c (if only one system of equations is to be solved, then the +c subroutine trk should be used.) +c +c ii. storage of sparse matrices +c the nonzero entries of the coefficient matrix m are stored +c row-by-row in the array a. to identify the individual nonzero +c entries in each row, we need to know in which column each entry +c lies. the column indices which correspond to the nonzero entries +c of m are stored in the array ja. i.e., if a(k) = m(i,j), then +c ja(k) = j. in addition, we need to know where each row starts and +c how long it is. the index positions in ja and a where the rows of +c m begin are stored in the array ia. i.e., if m(i,j) is the first +c (leftmost) entry in the i-th row and a(k) = m(i,j), then +c ia(i) = k. moreover, the index in ja and a of the first location +c following the last element in the last row is stored in ia(n+1). +c thus, the number of entries in the i-th row is given by +c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored +c consecutively in +c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +c and the corresponding column indices are stored consecutively in +c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +c for example, the 5 by 5 matrix +c ( 1. 0. 2. 0. 0.) +c ( 0. 3. 0. 0. 0.) +c m = ( 0. 4. 5. 6. 0.) +c ( 0. 0. 0. 7. 0.) +c ( 0. 0. 0. 8. 9.) +c would be stored as +c - 1 2 3 4 5 6 7 8 9 +c ---+-------------------------- +c ia - 1 3 4 7 8 10 +c ja - 1 3 2 2 3 4 4 4 5 +c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . +c +c the strict upper (lower) triangular portion of the matrix +c u (l) is stored in a similar fashion using the arrays iu, ju, u +c (il, jl, l) except that an additional array iju (ijl) is used to +c compress storage of ju (jl) by allowing some sequences of column +c (row) indices to used for more than one row (column) (n.b., l is +c stored by columns). iju(k) (ijl(k)) points to the starting +c location in ju (jl) of entries for the kth row (column). +c compression in ju (jl) occurs in two ways. first, if a row +c (column) i was merged into the current row (column) k, and the +c number of elements merged in from (the tail portion of) row +c (column) i is the same as the final length of row (column) k, then +c the kth row (column) and the tail of row (column) i are identical +c and iju(k) (ijl(k)) points to the start of the tail. second, if +c some tail portion of the (k-1)st row (column) is identical to the +c head of the kth row (column), then iju(k) (ijl(k)) points to the +c start of that tail portion. for example, the nonzero structure of +c the strict upper triangular part of the matrix +c d 0 x x x +c 0 d 0 x x +c 0 0 d x 0 +c 0 0 0 d x +c 0 0 0 0 d +c would be represented as +c - 1 2 3 4 5 6 +c ----+------------ +c iu - 1 4 6 7 8 8 +c ju - 3 4 5 4 +c iju - 1 2 4 3 . +c the diagonal entries of l and u are assumed to be equal to one and +c are not stored. the array d contains the reciprocals of the +c diagonal entries of the matrix d. +c +c iii. additional storage savings +c in nsfc, r and ic can be the same array in the calling +c sequence if no reordering of the coefficient matrix has been done. +c in nnfc, r, c, and ic can all be the same array if no +c reordering has been done. if only the rows have been reordered, +c then c and ic can be the same array. if the row and column +c orderings are the same, then r and c can be the same array. z and +c row can be the same array. +c in nnsc or nntc, r and c can be the same array if no +c reordering has been done or if the row and column orderings are the +c same. z and b can be the same array. however, then b will be +c destroyed. +c +c iv. parameters +c following is a list of parameters to the programs. names are +c uniform among the various subroutines. class abbreviations are -- +c n - integer variable +c f - real variable +c v - supplies a value to a subroutine +c r - returns a result from a subroutine +c i - used internally by a subroutine +c a - array +c +c class - parameter +c ------+---------- +c fva - a - nonzero entries of the coefficient matrix m, stored +c - by rows. +c - size = number of nonzero entries in m. +c fva - b - right-hand side b. +c - size = n. +c nva - c - ordering of the columns of m. +c - size = n. +c fvra - d - reciprocals of the diagonal entries of the matrix d. +c - size = n. +c nr - flag - error flag. values and their meanings are -- +c - 0 no errors detected +c - n+k null row in a -- row = k +c - 2n+k duplicate entry in a -- row = k +c - 3n+k insufficient storage for jl -- row = k +c - 4n+1 insufficient storage for l +c - 5n+k null pivot -- row = k +c - 6n+k insufficient storage for ju -- row = k +c - 7n+1 insufficient storage for u +c - 8n+k zero pivot -- row = k +c nva - ia - pointers to delimit the rows of a. +c - size = n+1. +c nvra - ijl - pointers to the first element in each column in jl, +c - used to compress storage in jl. +c - size = n. +c nvra - iju - pointers to the first element in each row in ju, used +c - to compress storage in ju. +c - size = n. +c nvra - il - pointers to delimit the columns of l. +c - size = n+1. +c nvra - iu - pointers to delimit the rows of u. +c - size = n+1. +c nva - ja - column numbers corresponding to the elements of a. +c - size = size of a. +c nvra - jl - row numbers corresponding to the elements of l. +c - size = jlmax. +c nv - jlmax - declared dimension of jl. jlmax must be larger than +c - the number of nonzeros in the strict lower triangle +c - of m plus fillin minus compression. +c nvra - ju - column numbers corresponding to the elements of u. +c - size = jumax. +c nv - jumax - declared dimension of ju. jumax must be larger than +c - the number of nonzeros in the strict upper triangle +c - of m plus fillin minus compression. +c fvra - l - nonzero entries in the strict lower triangular portion +c - of the matrix l, stored by columns. +c - size = lmax. +c nv - lmax - declared dimension of l. lmax must be larger than +c - the number of nonzeros in the strict lower triangle +c - of m plus fillin (il(n+1)-1 after nsfc). +c nv - n - number of variables/equations. +c nva - r - ordering of the rows of m. +c - size = n. +c fvra - u - nonzero entries in the strict upper triangular portion +c - of the matrix u, stored by rows. +c - size = umax. +c nv - umax - declared dimension of u. umax must be larger than +c - the number of nonzeros in the strict upper triangle +c - of m plus fillin (iu(n+1)-1 after nsfc). +c fra - z - solution x. +c - size = n. +c +c ---------------------------------------------------------------- +c +c*** subroutine nroc +c*** reorders rows of a, leaving row order unchanged +c +c +c input parameters.. n, ic, ia, ja, a +c output parameters.. ja, a, flag +c +c parameters used internally.. +c nia - p - at the kth step, p is a linked list of the reordered +c - column indices of the kth row of a. p(n+1) points +c - to the first entry in the list. +c - size = n+1. +c nia - jar - at the kth step,jar contains the elements of the +c - reordered column indices of a. +c - size = n. +c fia - ar - at the kth step, ar contains the elements of the +c - reordered row of a. +c - size = n. +c + integer ic(1), ia(1), ja(1), jar(1), p(1), flag + KPP_REAL a(1), ar(1) +c +c ****** for each nonempty row ******************************* + do 5 k=1,n + jmin = ia(k) + jmax = ia(k+1) - 1 + if(jmin .gt. jmax) go to 5 + p(n+1) = n + 1 +c ****** insert each element in the list ********************* + do 3 j=jmin,jmax + newj = ic(ja(j)) + i = n + 1 + 1 if(p(i) .ge. newj) go to 2 + i = p(i) + go to 1 + 2 if(p(i) .eq. newj) go to 102 + p(newj) = p(i) + p(i) = newj + jar(newj) = ja(j) + ar(newj) = a(j) + 3 continue +c ****** replace old row in ja and a ************************* + i = n + 1 + do 4 j=jmin,jmax + i = p(i) + ja(j) = jar(i) + 4 a(j) = ar(i) + 5 continue + flag = 0 + return +c +c ** error.. duplicate entry in a + 102 flag = n + k + return + end + subroutine adjlr (n, isp, ldif) + integer n, isp, ldif + dimension isp(1) +c----------------------------------------------------------------------- +c this routine computes an adjustment, ldif, to the required +c integer storage space in iwk (sparse matrix work space). +c it is called only if the word length ratio is lrat = 1. +c this is to account for the possibility that the symbolic lu phase +c may require more storage than the numerical lu and solution phases. +c----------------------------------------------------------------------- + integer ip, jlmax, jumax, lnfc, lsfc, nzlu +c + ip = 2*n + 1 +c get jlmax = ijl(n) and jumax = iju(n) (sizes of jl and ju). ---------- + jlmax = isp(ip) + jumax = isp(ip+ip) +c nzlu = (size of l) + (size of u) = (il(n+1)-il(1)) + (iu(n+1)-iu(1)). + nzlu = isp(n+1) - isp(1) + isp(ip+n+1) - isp(ip+1) + lsfc = 12*n + 3 + 2*max0(jlmax,jumax) + lnfc = 9*n + 2 + jlmax + jumax + nzlu + ldif = max0(0, lsfc - lnfc) + return +c----------------------- end of subroutine adjlr ----------------------- + end + subroutine odrv + * (n, ia,ja,a, p,ip, nsp,isp, path, flag) +clll. optimize +c 5/2/83 +c*********************************************************************** +c odrv -- driver for sparse matrix reordering routines +c*********************************************************************** +c +c description +c +c odrv finds a minimum degree ordering of the rows and columns +c of a matrix m stored in (ia,ja,a) format (see below). for the +c reordered matrix, the work and storage required to perform +c gaussian elimination is (usually) significantly less. +c +c note.. odrv and its subordinate routines have been modified to +c compute orderings for general matrices, not necessarily having any +c symmetry. the miminum degree ordering is computed for the +c structure of the symmetric matrix m + m-transpose. +c modifications to the original odrv module have been made in +c the coding in subroutine mdi, and in the initial comments in +c subroutines odrv and md. +c +c if only the nonzero entries in the upper triangle of m are being +c stored, then odrv symmetrically reorders (ia,ja,a), (optionally) +c with the diagonal entries placed first in each row. this is to +c ensure that if m(i,j) will be in the upper triangle of m with +c respect to the new ordering, then m(i,j) is stored in row i (and +c thus m(j,i) is not stored), whereas if m(i,j) will be in the +c strict lower triangle of m, then m(j,i) is stored in row j (and +c thus m(i,j) is not stored). +c +c +c storage of sparse matrices +c +c the nonzero entries of the matrix m are stored row-by-row in the +c array a. to identify the individual nonzero entries in each row, +c we need to know in which column each entry lies. these column +c indices are stored in the array ja. i.e., if a(k) = m(i,j), then +c ja(k) = j. to identify the individual rows, we need to know where +c each row starts. these row pointers are stored in the array ia. +c i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row +c and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to +c the first location following the last element in the last row. +c thus, the number of entries in the i-th row is ia(i+1) - ia(i), +c the nonzero entries in the i-th row are stored consecutively in +c +c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +c +c and the corresponding column indices are stored consecutively in +c +c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +c +c since the coefficient matrix is symmetric, only the nonzero entries +c in the upper triangle need be stored. for example, the matrix +c +c ( 1 0 2 3 0 ) +c ( 0 4 0 0 0 ) +c m = ( 2 0 5 6 0 ) +c ( 3 0 6 7 8 ) +c ( 0 0 0 8 9 ) +c +c could be stored as +c +c - 1 2 3 4 5 6 7 8 9 10 11 12 13 +c ---+-------------------------------------- +c ia - 1 4 5 8 12 14 +c ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 +c a - 1 2 3 4 2 5 6 3 6 7 8 8 9 +c +c or (symmetrically) as +c +c - 1 2 3 4 5 6 7 8 9 +c ---+-------------------------- +c ia - 1 4 5 7 9 10 +c ja - 1 3 4 2 3 4 4 5 5 +c a - 1 2 3 4 5 6 7 8 9 . +c +c +c parameters +c +c n - order of the matrix +c +c ia - integer one-dimensional array containing pointers to delimit +c rows in ja and a. dimension = n+1 +c +c ja - integer one-dimensional array containing the column indices +c corresponding to the elements of a. dimension = number of +c nonzero entries in (the upper triangle of) m +c +c a - real one-dimensional array containing the nonzero entries in +c (the upper triangle of) m, stored by rows. dimension = +c number of nonzero entries in (the upper triangle of) m +c +c p - integer one-dimensional array used to return the permutation +c of the rows and columns of m corresponding to the minimum +c degree ordering. dimension = n +c +c ip - integer one-dimensional array used to return the inverse of +c the permutation returned in p. dimension = n +c +c nsp - declared dimension of the one-dimensional array isp. nsp +c must be at least 3n+4k, where k is the number of nonzeroes +c in the strict upper triangle of m +c +c isp - integer one-dimensional array used for working storage. +c dimension = nsp +c +c path - integer path specification. values and their meanings are - +c 1 find minimum degree ordering only +c 2 find minimum degree ordering and reorder symmetrically +c stored matrix (used when only the nonzero entries in +c the upper triangle of m are being stored) +c 3 reorder symmetrically stored matrix as specified by +c input permutation (used when an ordering has already +c been determined and only the nonzero entries in the +c upper triangle of m are being stored) +c 4 same as 2 but put diagonal entries at start of each row +c 5 same as 3 but put diagonal entries at start of each row +c +c flag - integer error flag. values and their meanings are - +c 0 no errors detected +c 9n+k insufficient storage in md +c 10n+1 insufficient storage in odrv +c 11n+1 illegal path specification +c +c +c conversion from real to KPP_REAL +c +c change the real declarations in odrv and sro to KPP_REAL +c declarations. +c +c----------------------------------------------------------------------- +c + integer ia(1), ja(1), p(1), ip(1), isp(1), path, flag, + * v, l, head, tmp, q + KPP_REAL a(1) + logical dflag +c +c----initialize error flag and validate path specification + flag = 0 + if (path.lt.1 .or. 5.lt.path) go to 111 +c +c----allocate storage and find minimum degree ordering + if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 + max = (nsp-n)/2 + v = 1 + l = v + max + head = l + max + next = head + n + if (max.lt.n) go to 110 +c + CALL md + * (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) + if (flag.ne.0) go to 100 +c +c----allocate storage and symmetrically reorder matrix + 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 + tmp = (nsp+1) - n + q = tmp - (ia(n+1)-1) + if (q.lt.1) go to 110 +c + dflag = path.eq.4 .or. path.eq.5 + CALL sro + * (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) +c + 2 return +c +c ** error -- error detected in md + 100 return +c ** error -- insufficient storage + 110 flag = 10*n + 1 + return +c ** error -- illegal path specified + 111 flag = 11*n + 1 + return + end + subroutine nnfc + * (n, r,c,ic, ia,ja,a, z, b, + * lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, + * row, tmp, irl,jrl, flag) +clll. optimize +c*** subroutine nnfc +c*** numerical ldu-factorization of sparse nonsymmetric matrix and +c solution of system of linear equations (compressed pointer +c storage) +c +c +c input variables.. n, r, c, ic, ia, ja, a, b, +c il, jl, ijl, lmax, iu, ju, iju, umax +c output variables.. z, l, d, u, flag +c +c parameters used internally.. +c nia - irl, - vectors used to find the rows of l. at the kth step +c nia - jrl of the factorization, jrl(k) points to the head +c - of a linked list in jrl of column indices j +c - such j .lt. k and l(k,j) is nonzero. zero +c - indicates the end of the list. irl(j) (j.lt.k) +c - points to the smallest i such that i .ge. k and +c - l(i,j) is nonzero. +c - size of each = n. +c fia - row - holds intermediate values in calculation of u and l. +c - size = n. +c fia - tmp - holds new right-hand side b* for solution of the +c - equation ux = b*. +c - size = n. +c +c internal variables.. +c jmin, jmax - indices of the first and last positions in a row to +c be examined. +c sum - used in calculating tmp. +c + integer rk,umax + integer r(1), c(1), ic(1), ia(1), ja(1), il(1), jl(1), ijl(1) + integer iu(1), ju(1), iju(1), irl(1), jrl(1), flag + KPP_REAL a(1), l(1), d(1), u(1), z(1), b(1), row(1) + KPP_REAL tmp(1), lki, sum, dk +c +c ****** initialize pointers and test storage *********************** + if(il(n+1)-1 .gt. lmax) go to 104 + if(iu(n+1)-1 .gt. umax) go to 107 + do 1 k=1,n + irl(k) = il(k) + jrl(k) = 0 + 1 continue +c +c ****** for each row *********************************************** + do 19 k=1,n +c ****** reverse jrl and zero row where kth row of l will fill in *** + row(k) = 0 + i1 = 0 + if (jrl(k) .eq. 0) go to 3 + i = jrl(k) + 2 i2 = jrl(i) + jrl(i) = i1 + i1 = i + row(i) = 0 + i = i2 + if (i .ne. 0) go to 2 +c ****** set row to zero where u will fill in *********************** + 3 jmin = iju(k) + jmax = jmin + iu(k+1) - iu(k) - 1 + if (jmin .gt. jmax) go to 5 + do 4 j=jmin,jmax + 4 row(ju(j)) = 0 +c ****** place kth row of a in row ********************************** + 5 rk = r(k) + jmin = ia(rk) + jmax = ia(rk+1) - 1 + do 6 j=jmin,jmax + row(ic(ja(j))) = a(j) + 6 continue +c ****** initialize sum, and link through jrl *********************** + sum = b(rk) + i = i1 + if (i .eq. 0) go to 10 +c ****** assign the kth row of l and adjust row, sum **************** + 7 lki = -row(i) +c ****** if l is not required, then comment out the following line ** + l(irl(i)) = -lki + sum = sum + lki * tmp(i) + jmin = iu(i) + jmax = iu(i+1) - 1 + if (jmin .gt. jmax) go to 9 + mu = iju(i) - jmin + do 8 j=jmin,jmax + 8 row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) + 9 i = jrl(i) + if (i .ne. 0) go to 7 +c +c ****** assign kth row of u and diagonal d, set tmp(k) ************* + 10 if (row(k) .eq. 0.0d0) go to 108 + dk = 1.0d0 / row(k) + d(k) = dk + tmp(k) = sum * dk + if (k .eq. n) go to 19 + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 12 + mu = iju(k) - jmin + do 11 j=jmin,jmax + 11 u(j) = row(ju(mu+j)) * dk + 12 continue +c +c ****** update irl and jrl, keeping jrl in decreasing order ******** + i = i1 + if (i .eq. 0) go to 18 + 14 irl(i) = irl(i) + 1 + i1 = jrl(i) + if (irl(i) .ge. il(i+1)) go to 17 + ijlb = irl(i) - il(i) + ijl(i) + j = jl(ijlb) + 15 if (i .gt. jrl(j)) go to 16 + j = jrl(j) + go to 15 + 16 jrl(i) = jrl(j) + jrl(j) = i + 17 i = i1 + if (i .ne. 0) go to 14 + 18 if (irl(k) .ge. il(k+1)) go to 19 + j = jl(ijl(k)) + jrl(k) = jrl(j) + jrl(j) = k + 19 continue +c +c ****** solve ux = tmp by back substitution ********************** + k = n + do 22 i=1,n + sum = tmp(k) + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 21 + mu = iju(k) - jmin + do 20 j=jmin,jmax + 20 sum = sum - u(j) * tmp(ju(mu+j)) + 21 tmp(k) = sum + z(c(k)) = sum + 22 k = k-1 + flag = 0 + return +c +c ** error.. insufficient storage for l + 104 flag = 4*n + 1 + return +c ** error.. insufficient storage for u + 107 flag = 7*n + 1 + return +c ** error.. zero pivot + 108 flag = 8*n + k + return + end + subroutine jgroup (n,ia,ja,maxg,ngrp,igp,jgp,incl,jdone,ier) +clll. optimize + integer n, ia, ja, maxg, ngrp, igp, jgp, incl, jdone, ier + dimension ia(1), ja(1), igp(1), jgp(n), incl(n), jdone(n) +c----------------------------------------------------------------------- +c this subroutine constructs groupings of the column indices of +c the jacobian matrix, used in the numerical evaluation of the +c jacobian by finite differences. +c +c input.. +c n = the order of the matrix. +c ia,ja = sparse structure descriptors of the matrix by rows. +c maxg = length of available storate in the igp array. +c +c output.. +c ngrp = number of groups. +c jgp = array of length n containing the column indices by groups. +c igp = pointer array of length ngrp + 1 to the locations in jgp +c of the beginning of each group. +c ier = error indicator. ier = 0 if no error occurred, or 1 if +c maxg was insufficient. +c +c incl and jdone are working arrays of length n. +c----------------------------------------------------------------------- + integer i, j, k, kmin, kmax, ncol, ng +c + ier = 0 + do 10 j = 1,n + 10 jdone(j) = 0 + ncol = 1 + do 60 ng = 1,maxg + igp(ng) = ncol + do 20 i = 1,n + 20 incl(i) = 0 + do 50 j = 1,n +c reject column j if it is already in a group.-------------------------- + if (jdone(j) .eq. 1) go to 50 + kmin = ia(j) + kmax = ia(j+1) - 1 + do 30 k = kmin,kmax +c reject column j if it overlaps any column already in this group.------ + i = ja(k) + if (incl(i) .eq. 1) go to 50 + 30 continue +c accept column j into group ng.---------------------------------------- + jgp(ncol) = j + ncol = ncol + 1 + jdone(j) = 1 + do 40 k = kmin,kmax + i = ja(k) + 40 incl(i) = 1 + 50 continue +c stop if this group is empty (grouping is complete).------------------- + if (ncol .eq. igp(ng)) go to 70 + 60 continue +c error return if not all columns were chosen (maxg too small).--------- + if (ncol .le. n) go to 80 + ng = maxg + 70 ngrp = ng - 1 + return + 80 ier = 1 + return +c----------------------- end of subroutine jgroup ---------------------- + end + subroutine nsfc + * (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, + * q, ira,jra, irac, irl,jrl, iru,jru, flag) +clll. optimize +c*** subroutine nsfc +c*** symbolic ldu-factorization of nonsymmetric sparse matrix +c (compressed pointer storage) +c +c +c input variables.. n, r, ic, ia, ja, jlmax, jumax. +c output variables.. il, jl, ijl, iu, ju, iju, flag. +c +c parameters used internally.. +c nia - q - suppose m* is the result of reordering m. if +c - processing of the ith row of m* (hence the ith +c - row of u) is being done, q(j) is initially +c - nonzero if m*(i,j) is nonzero (j.ge.i). since +c - values need not be stored, each entry points to the +c - next nonzero and q(n+1) points to the first. n+1 +c - indicates the end of the list. for example, if n=9 +c - and the 5th row of m* is +c - 0 x x 0 x 0 0 x 0 +c - then q will initially be +c - a a a a 8 a a 10 5 (a - arbitrary). +c - as the algorithm proceeds, other elements of q +c - are inserted in the list because of fillin. +c - q is used in an analogous manner to compute the +c - ith column of l. +c - size = n+1. +c nia - ira, - vectors used to find the columns of m. at the kth +c nia - jra, step of the factorization, irac(k) points to the +c nia - irac head of a linked list in jra of row indices i +c - such that i .ge. k and m(i,k) is nonzero. zero +c - indicates the end of the list. ira(i) (i.ge.k) +c - points to the smallest j such that j .ge. k and +c - m(i,j) is nonzero. +c - size of each = n. +c nia - irl, - vectors used to find the rows of l. at the kth step +c nia - jrl of the factorization, jrl(k) points to the head +c - of a linked list in jrl of column indices j +c - such j .lt. k and l(k,j) is nonzero. zero +c - indicates the end of the list. irl(j) (j.lt.k) +c - points to the smallest i such that i .ge. k and +c - l(i,j) is nonzero. +c - size of each = n. +c nia - iru, - vectors used in a manner analogous to irl and jrl +c nia - jru to find the columns of u. +c - size of each = n. +c +c internal variables.. +c jlptr - points to the last position used in jl. +c juptr - points to the last position used in ju. +c jmin,jmax - are the indices in a or u of the first and last +c elements to be examined in a given row. +c for example, jmin=ia(k), jmax=ia(k+1)-1. +c + integer cend, qm, rend, rk, vj + integer ia(1), ja(1), ira(1), jra(1), il(1), jl(1), ijl(1) + integer iu(1), ju(1), iju(1), irl(1), jrl(1), iru(1), jru(1) + integer r(1), ic(1), q(1), irac(1), flag +c +c ****** initialize pointers **************************************** + np1 = n + 1 + jlmin = 1 + jlptr = 0 + il(1) = 1 + jumin = 1 + juptr = 0 + iu(1) = 1 + do 1 k=1,n + irac(k) = 0 + jra(k) = 0 + jrl(k) = 0 + 1 jru(k) = 0 +c ****** initialize column pointers for a *************************** + do 2 k=1,n + rk = r(k) + iak = ia(rk) + if (iak .ge. ia(rk+1)) go to 101 + jaiak = ic(ja(iak)) + if (jaiak .gt. k) go to 105 + jra(k) = irac(jaiak) + irac(jaiak) = k + 2 ira(k) = iak +c +c ****** for each column of l and row of u ************************** + do 41 k=1,n +c +c ****** initialize q for computing kth column of l ***************** + q(np1) = np1 + luk = -1 +c ****** by filling in kth column of a ****************************** + vj = irac(k) + if (vj .eq. 0) go to 5 + 3 qm = np1 + 4 m = qm + qm = q(m) + if (qm .lt. vj) go to 4 + if (qm .eq. vj) go to 102 + luk = luk + 1 + q(m) = vj + q(vj) = qm + vj = jra(vj) + if (vj .ne. 0) go to 3 +c ****** link through jru ******************************************* + 5 lastid = 0 + lasti = 0 + ijl(k) = jlptr + i = k + 6 i = jru(i) + if (i .eq. 0) go to 10 + qm = np1 + jmin = irl(i) + jmax = ijl(i) + il(i+1) - il(i) - 1 + long = jmax - jmin + if (long .lt. 0) go to 6 + jtmp = jl(jmin) + if (jtmp .ne. k) long = long + 1 + if (jtmp .eq. k) r(i) = -r(i) + if (lastid .ge. long) go to 7 + lasti = i + lastid = long +c ****** and merge the corresponding columns into the kth column **** + 7 do 9 j=jmin,jmax + vj = jl(j) + 8 m = qm + qm = q(m) + if (qm .lt. vj) go to 8 + if (qm .eq. vj) go to 9 + luk = luk + 1 + q(m) = vj + q(vj) = qm + qm = vj + 9 continue + go to 6 +c ****** lasti is the longest column merged into the kth ************ +c ****** see if it equals the entire kth column ********************* + 10 qm = q(np1) + if (qm .ne. k) go to 105 + if (luk .eq. 0) go to 17 + if (lastid .ne. luk) go to 11 +c ****** if so, jl can be compressed ******************************** + irll = irl(lasti) + ijl(k) = irll + 1 + if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 + go to 17 +c ****** if not, see if kth column can overlap the previous one ***** + 11 if (jlmin .gt. jlptr) go to 15 + qm = q(qm) + do 12 j=jlmin,jlptr + if (jl(j) - qm) 12, 13, 15 + 12 continue + go to 15 + 13 ijl(k) = j + do 14 i=j,jlptr + if (jl(i) .ne. qm) go to 15 + qm = q(qm) + if (qm .gt. n) go to 17 + 14 continue + jlptr = j - 1 +c ****** move column indices from q to jl, update vectors *********** + 15 jlmin = jlptr + 1 + ijl(k) = jlmin + if (luk .eq. 0) go to 17 + jlptr = jlptr + luk + if (jlptr .gt. jlmax) go to 103 + qm = q(np1) + do 16 j=jlmin,jlptr + qm = q(qm) + 16 jl(j) = qm + 17 irl(k) = ijl(k) + il(k+1) = il(k) + luk +c +c ****** initialize q for computing kth row of u ******************** + q(np1) = np1 + luk = -1 +c ****** by filling in kth row of reordered a *********************** + rk = r(k) + jmin = ira(k) + jmax = ia(rk+1) - 1 + if (jmin .gt. jmax) go to 20 + do 19 j=jmin,jmax + vj = ic(ja(j)) + qm = np1 + 18 m = qm + qm = q(m) + if (qm .lt. vj) go to 18 + if (qm .eq. vj) go to 102 + luk = luk + 1 + q(m) = vj + q(vj) = qm + 19 continue +c ****** link through jrl, ****************************************** + 20 lastid = 0 + lasti = 0 + iju(k) = juptr + i = k + i1 = jrl(k) + 21 i = i1 + if (i .eq. 0) go to 26 + i1 = jrl(i) + qm = np1 + jmin = iru(i) + jmax = iju(i) + iu(i+1) - iu(i) - 1 + long = jmax - jmin + if (long .lt. 0) go to 21 + jtmp = ju(jmin) + if (jtmp .eq. k) go to 22 +c ****** update irl and jrl, ***************************************** + long = long + 1 + cend = ijl(i) + il(i+1) - il(i) + irl(i) = irl(i) + 1 + if (irl(i) .ge. cend) go to 22 + j = jl(irl(i)) + jrl(i) = jrl(j) + jrl(j) = i + 22 if (lastid .ge. long) go to 23 + lasti = i + lastid = long +c ****** and merge the corresponding rows into the kth row ********** + 23 do 25 j=jmin,jmax + vj = ju(j) + 24 m = qm + qm = q(m) + if (qm .lt. vj) go to 24 + if (qm .eq. vj) go to 25 + luk = luk + 1 + q(m) = vj + q(vj) = qm + qm = vj + 25 continue + go to 21 +c ****** update jrl(k) and irl(k) *********************************** + 26 if (il(k+1) .le. il(k)) go to 27 + j = jl(irl(k)) + jrl(k) = jrl(j) + jrl(j) = k +c ****** lasti is the longest row merged into the kth *************** +c ****** see if it equals the entire kth row ************************ + 27 qm = q(np1) + if (qm .ne. k) go to 105 + if (luk .eq. 0) go to 34 + if (lastid .ne. luk) go to 28 +c ****** if so, ju can be compressed ******************************** + irul = iru(lasti) + iju(k) = irul + 1 + if (ju(irul) .ne. k) iju(k) = iju(k) - 1 + go to 34 +c ****** if not, see if kth row can overlap the previous one ******** + 28 if (jumin .gt. juptr) go to 32 + qm = q(qm) + do 29 j=jumin,juptr + if (ju(j) - qm) 29, 30, 32 + 29 continue + go to 32 + 30 iju(k) = j + do 31 i=j,juptr + if (ju(i) .ne. qm) go to 32 + qm = q(qm) + if (qm .gt. n) go to 34 + 31 continue + juptr = j - 1 +c ****** move row indices from q to ju, update vectors ************** + 32 jumin = juptr + 1 + iju(k) = jumin + if (luk .eq. 0) go to 34 + juptr = juptr + luk + if (juptr .gt. jumax) go to 106 + qm = q(np1) + do 33 j=jumin,juptr + qm = q(qm) + 33 ju(j) = qm + 34 iru(k) = iju(k) + iu(k+1) = iu(k) + luk +c +c ****** update iru, jru ******************************************** + i = k + 35 i1 = jru(i) + if (r(i) .lt. 0) go to 36 + rend = iju(i) + iu(i+1) - iu(i) + if (iru(i) .ge. rend) go to 37 + j = ju(iru(i)) + jru(i) = jru(j) + jru(j) = i + go to 37 + 36 r(i) = -r(i) + 37 i = i1 + if (i .eq. 0) go to 38 + iru(i) = iru(i) + 1 + go to 35 +c +c ****** update ira, jra, irac ************************************** + 38 i = irac(k) + if (i .eq. 0) go to 41 + 39 i1 = jra(i) + ira(i) = ira(i) + 1 + if (ira(i) .ge. ia(r(i)+1)) go to 40 + irai = ira(i) + jairai = ic(ja(irai)) + if (jairai .gt. i) go to 40 + jra(i) = irac(jairai) + irac(jairai) = i + 40 i = i1 + if (i .ne. 0) go to 39 + 41 continue +c + ijl(n) = jlptr + iju(n) = juptr + flag = 0 + return +c +c ** error.. null row in a + 101 flag = n + rk + return +c ** error.. duplicate entry in a + 102 flag = 2*n + rk + return +c ** error.. insufficient storage for jl + 103 flag = 3*n + k + return +c ** error.. null pivot + 105 flag = 5*n + k + return +c ** error.. insufficient storage for ju + 106 flag = 6*n + k + return + end + subroutine sro + * (n, ip, ia,ja,a, q, r, dflag) +clll. optimize +c*********************************************************************** +c sro -- symmetric reordering of sparse symmetric matrix +c*********************************************************************** +c +c description +c +c the nonzero entries of the matrix m are assumed to be stored +c symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) +c are stored if i ne j). +c +c sro does not rearrange the order of the rows, but does move +c nonzeroes from one row to another to ensure that if m(i,j) will be +c in the upper triangle of m with respect to the new ordering, then +c m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas +c if m(i,j) will be in the strict lower triangle of m, then m(j,i) is +c stored in row j (and thus m(i,j) is not stored). +c +c +c additional parameters +c +c q - integer one-dimensional work array. dimension = n +c +c r - integer one-dimensional work array. dimension = number of +c nonzero entries in the upper triangle of m +c +c dflag - logical variable. if dflag = .true., then store nonzero +c diagonal elements at the beginning of the row +c +c----------------------------------------------------------------------- +c + integer ip(1), ia(1), ja(1), q(1), r(1) + KPP_REAL a(1), ak + logical dflag +c +c +c--phase 1 -- find row in which to store each nonzero +c----initialize count of nonzeroes to be stored in each row + do 1 i=1,n + 1 q(i) = 0 +c +c----for each nonzero element a(j) + do 3 i=1,n + jmin = ia(i) + jmax = ia(i+1) - 1 + if (jmin.gt.jmax) go to 3 + do 2 j=jmin,jmax +c +c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... + k = ja(j) + if (ip(k).lt.ip(i)) ja(j) = i + if (ip(k).ge.ip(i)) k = i + r(j) = k +c +c--------... and increment count of nonzeroes (=q(r(j)) in that row + 2 q(k) = q(k) + 1 + 3 continue +c +c +c--phase 2 -- find new ia and permutation to apply to (ja,a) +c----determine pointers to delimit rows in permuted (ja,a) + do 4 i=1,n + ia(i+1) = ia(i) + q(i) + 4 q(i) = ia(i+1) +c +c----determine where each (ja(j),a(j)) is stored in permuted (ja,a) +c----for each nonzero element (in reverse order) + ilast = 0 + jmin = ia(1) + jmax = ia(n+1) - 1 + j = jmax + do 6 jdummy=jmin,jmax + i = r(j) + if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 +c +c------if dflag, then put diagonal nonzero at beginning of row + r(j) = ia(i) + ilast = i + go to 6 +c +c------put (off-diagonal) nonzero in last unused location in row + 5 q(i) = q(i) - 1 + r(j) = q(i) +c + 6 j = j-1 +c +c +c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) + do 8 j=jmin,jmax + 7 if (r(j).eq.j) go to 8 + k = r(j) + r(j) = r(k) + r(k) = k + jak = ja(k) + ja(k) = ja(j) + ja(j) = jak + ak = a(k) + a(k) = a(j) + a(j) = ak + go to 7 + 8 continue +c + return + end + subroutine md + * (n, ia,ja, max, v,l, head,last,next, mark, flag) +clll. optimize +c*********************************************************************** +c md -- minimum degree algorithm (based on element model) +c*********************************************************************** +c +c description +c +c md finds a minimum degree ordering of the rows and columns of a +c general sparse matrix m stored in (ia,ja,a) format. +c when the structure of m is nonsymmetric, the ordering is that +c obtained for the symmetric matrix m + m-transpose. +c +c +c additional parameters +c +c max - declared dimension of the one-dimensional arrays v and l. +c max must be at least n+2k, where k is the number of +c nonzeroes in the strict upper triangle of m + m-transpose +c +c v - integer one-dimensional work array. dimension = max +c +c l - integer one-dimensional work array. dimension = max +c +c head - integer one-dimensional work array. dimension = n +c +c last - integer one-dimensional array used to return the permutation +c of the rows and columns of m corresponding to the minimum +c degree ordering. dimension = n +c +c next - integer one-dimensional array used to return the inverse of +c the permutation returned in last. dimension = n +c +c mark - integer one-dimensional work array (may be the same as v). +c dimension = n +c +c flag - integer error flag. values and their meanings are - +c 0 no errors detected +c 9n+k insufficient storage in md +c +c +c definitions of internal parameters +c +c ---------+--------------------------------------------------------- +c v(s) - value field of list entry +c ---------+--------------------------------------------------------- +c l(s) - link field of list entry (0 =) end of list) +c ---------+--------------------------------------------------------- +c l(vi) - pointer to element list of uneliminated vertex vi +c ---------+--------------------------------------------------------- +c l(ej) - pointer to boundary list of active element ej +c ---------+--------------------------------------------------------- +c head(d) - vj =) vj head of d-list d +c - 0 =) no vertex in d-list d +c +c +c - vi uneliminated vertex +c - vi in ek - vi not in ek +c ---------+-----------------------------+--------------------------- +c next(vi) - undefined but nonnegative - vj =) vj next in d-list +c - - 0 =) vi tail of d-list +c ---------+-----------------------------+--------------------------- +c last(vi) - (not set until mdp) - -d =) vi head of d-list d +c --vk =) compute degree - vj =) vj last in d-list +c - ej =) vi prototype of ej - 0 =) vi not in any d-list +c - 0 =) do not compute degree - +c ---------+-----------------------------+--------------------------- +c mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) +c +c +c - vi eliminated vertex +c - ei active element - otherwise +c ---------+-----------------------------+--------------------------- +c next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex +c - to be eliminated - to be eliminated +c ---------+-----------------------------+--------------------------- +c last(vi) - m =) size of ei = m - undefined +c ---------+-----------------------------+--------------------------- +c mark(vi) - -m =) overlap count of ei - undefined +c - with ek = m - +c - otherwise nonnegative tag - +c - .lt. mark(vk) - +c +c----------------------------------------------------------------------- +c + integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), + * mark(1), flag, tag, dmin, vk,ek, tail + equivalence (vk,ek) +c +c----initialization + tag = 0 + CALL mdi + * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) + if (flag.ne.0) return +c + k = 0 + dmin = 1 +c +c----while k .lt. n do + 1 if (k.ge.n) go to 4 +c +c------search for vertex of minimum degree + 2 if (head(dmin).gt.0) go to 3 + dmin = dmin + 1 + go to 2 +c +c------remove vertex vk of minimum degree from degree list + 3 vk = head(dmin) + head(dmin) = next(vk) + if (head(dmin).gt.0) last(head(dmin)) = -dmin +c +c------number vertex vk, adjust tag, and tag vk + k = k+1 + next(vk) = -k + last(ek) = dmin - 1 + tag = tag + last(ek) + mark(vk) = tag +c +c------form element ek from uneliminated neighbors of vk + CALL mdm + * (vk,tail, v,l, last,next, mark) +c +c------purge inactive elements and do mass elimination + CALL mdp + * (k,ek,tail, v,l, head,last,next, mark) +c +c------update degrees of uneliminated vertices in ek + CALL mdu + * (ek,dmin, v,l, head,last,next, mark) +c + go to 1 +c +c----generate inverse permutation from permutation + 4 do 5 k=1,n + next(k) = -next(k) + 5 last(next(k)) = k +c + return + end + subroutine mdi + * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) +clll. optimize +c*********************************************************************** +c mdi -- initialization +c*********************************************************************** + integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), + * mark(1), tag, flag, sfs, vi,dvi, vj +c +c----initialize degrees, element lists, and degree lists + do 1 vi=1,n + mark(vi) = 1 + l(vi) = 0 + 1 head(vi) = 0 + sfs = n+1 +c +c----create nonzero structure +c----for each nonzero entry a(vi,vj) + do 6 vi=1,n + jmin = ia(vi) + jmax = ia(vi+1) - 1 + if (jmin.gt.jmax) go to 6 + do 5 j=jmin,jmax + vj = ja(j) + if (vj-vi) 2, 5, 4 +c +c------if a(vi,vj) is in strict lower triangle +c------check for previous occurrence of a(vj,vi) + 2 lvk = vi + kmax = mark(vi) - 1 + if (kmax .eq. 0) go to 4 + do 3 k=1,kmax + lvk = l(lvk) + if (v(lvk).eq.vj) go to 5 + 3 continue +c----for unentered entries a(vi,vj) + 4 if (sfs.ge.max) go to 101 +c +c------enter vj in element list for vi + mark(vi) = mark(vi) + 1 + v(sfs) = vj + l(sfs) = l(vi) + l(vi) = sfs + sfs = sfs+1 +c +c------enter vi in element list for vj + mark(vj) = mark(vj) + 1 + v(sfs) = vi + l(sfs) = l(vj) + l(vj) = sfs + sfs = sfs+1 + 5 continue + 6 continue +c +c----create degree lists and initialize mark vector + do 7 vi=1,n + dvi = mark(vi) + next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + nextvi = next(vi) + if (nextvi.gt.0) last(nextvi) = vi + 7 mark(vi) = tag +c + return +c +c ** error- insufficient storage + 101 flag = 9*n + vi + return + end + subroutine mdm + * (vk,tail, v,l, last,next, mark) +clll. optimize +c*********************************************************************** +c mdm -- form element from uneliminated neighbors of vk +c*********************************************************************** + integer vk, tail, v(1), l(1), last(1), next(1), mark(1), + * tag, s,ls,vs,es, b,lb,vb, blp,blpmax + equivalence (vs, es) +c +c----initialize tag and list of uneliminated neighbors + tag = mark(vk) + tail = vk +c +c----for each vertex/element vs/es in element list of vk + ls = l(vk) + 1 s = ls + if (s.eq.0) go to 5 + ls = l(s) + vs = v(s) + if (next(vs).lt.0) go to 2 +c +c------if vs is uneliminated vertex, then tag and append to list of +c------uneliminated neighbors + mark(vs) = tag + l(tail) = s + tail = s + go to 4 +c +c------if es is active element, then ... +c--------for each vertex vb in boundary list of element es + 2 lb = l(es) + blpmax = last(es) + do 3 blp=1,blpmax + b = lb + lb = l(b) + vb = v(b) +c +c----------if vb is untagged vertex, then tag and append to list of +c----------uneliminated neighbors + if (mark(vb).ge.tag) go to 3 + mark(vb) = tag + l(tail) = b + tail = b + 3 continue +c +c--------mark es inactive + mark(es) = tag +c + 4 go to 1 +c +c----terminate list of uneliminated neighbors + 5 l(tail) = 0 +c + return + end + subroutine mdp + * (k,ek,tail, v,l, head,last,next, mark) +clll. optimize +c*********************************************************************** +c mdp -- purge inactive elements and do mass elimination +c*********************************************************************** + integer ek, tail, v(1), l(1), head(1), last(1), next(1), + * mark(1), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax +c +c----initialize tag + tag = mark(ek) +c +c----for each vertex vi in ek + li = ek + ilpmax = last(ek) + if (ilpmax.le.0) go to 12 + do 11 ilp=1,ilpmax + i = li + li = l(i) + vi = v(li) +c +c------remove vi from degree list + if (last(vi).eq.0) go to 3 + if (last(vi).gt.0) go to 1 + head(-last(vi)) = next(vi) + go to 2 + 1 next(last(vi)) = next(vi) + 2 if (next(vi).gt.0) last(next(vi)) = last(vi) +c +c------remove inactive items from element list of vi + 3 ls = vi + 4 s = ls + ls = l(s) + if (ls.eq.0) go to 6 + es = v(ls) + if (mark(es).lt.tag) go to 5 + free = ls + l(s) = l(ls) + ls = s + 5 go to 4 +c +c------if vi is interior vertex, then remove from list and eliminate + 6 lvi = l(vi) + if (lvi.ne.0) go to 7 + l(i) = l(li) + li = i +c + k = k+1 + next(vi) = -k + last(ek) = last(ek) - 1 + go to 11 +c +c------else ... +c--------classify vertex vi + 7 if (l(lvi).ne.0) go to 9 + evi = v(lvi) + if (next(evi).ge.0) go to 9 + if (mark(evi).lt.0) go to 8 +c +c----------if vi is prototype vertex, then mark as such, initialize +c----------overlap count for corresponding element, and move vi to end +c----------of boundary list + last(vi) = evi + mark(evi) = -1 + l(tail) = li + tail = li + l(i) = l(li) + li = i + go to 10 +c +c----------else if vi is duplicate vertex, then mark as such and adjust +c----------overlap count for corresponding element + 8 last(vi) = 0 + mark(evi) = mark(evi) - 1 + go to 10 +c +c----------else mark vi to compute degree + 9 last(vi) = -ek +c +c--------insert ek in element list of vi + 10 v(free) = ek + l(free) = l(vi) + l(vi) = free + 11 continue +c +c----terminate boundary list + 12 l(tail) = 0 +c + return + end + subroutine mdu + * (ek,dmin, v,l, head,last,next, mark) +clll. optimize +c*********************************************************************** +c mdu -- update degrees of uneliminated vertices in ek +c*********************************************************************** + integer ek, dmin, v(1), l(1), head(1), last(1), next(1), + * mark(1), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, + * blp,blpmax + equivalence (vs, es) +c +c----initialize tag + tag = mark(ek) - last(ek) +c +c----for each vertex vi in ek + i = ek + ilpmax = last(ek) + if (ilpmax.le.0) go to 11 + do 10 ilp=1,ilpmax + i = l(i) + vi = v(i) + if (last(vi)) 1, 10, 8 +c +c------if vi neither prototype nor duplicate vertex, then merge elements +c------to compute degree + 1 tag = tag + 1 + dvi = last(ek) +c +c--------for each vertex/element vs/es in element list of vi + s = l(vi) + 2 s = l(s) + if (s.eq.0) go to 9 + vs = v(s) + if (next(vs).lt.0) go to 3 +c +c----------if vs is uneliminated vertex, then tag and adjust degree + mark(vs) = tag + dvi = dvi + 1 + go to 5 +c +c----------if es is active element, then expand +c------------check for outmatched vertex + 3 if (mark(es).lt.0) go to 6 +c +c------------for each vertex vb in es + b = es + blpmax = last(es) + do 4 blp=1,blpmax + b = l(b) + vb = v(b) +c +c--------------if vb is untagged, then tag and adjust degree + if (mark(vb).ge.tag) go to 4 + mark(vb) = tag + dvi = dvi + 1 + 4 continue +c + 5 go to 2 +c +c------else if vi is outmatched vertex, then adjust overlaps but do not +c------compute degree + 6 last(vi) = 0 + mark(es) = mark(es) - 1 + 7 s = l(s) + if (s.eq.0) go to 10 + es = v(s) + if (mark(es).lt.0) mark(es) = mark(es) - 1 + go to 7 +c +c------else if vi is prototype vertex, then calculate degree by +c------inclusion/exclusion and reset overlap count + 8 evi = last(vi) + dvi = last(ek) + last(evi) + mark(evi) + mark(evi) = 0 +c +c------insert vi in appropriate degree list + 9 next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + if (next(vi).gt.0) last(next(vi)) = vi + if (dvi.lt.dmin) dmin = dvi +c + 10 continue +c + 11 return + end + KPP_REAL FUNCTION D1MACH (IDUM) + INTEGER IDUM +C----------------------------------------------------------------------- +C This routine computes the unit roundoff of the machine. +C This is defined as the smallest positive machine number +C u such that 1.0 + u .ne. 1.0 +C +C Subroutines/functions called by D1MACH.. None +C----------------------------------------------------------------------- + KPP_REAL U, COMP + U = 1.0D0 + 10 U = U*0.5D0 + COMP = 1.0D0 + U + IF (COMP .NE. 1.0D0) GO TO 10 + D1MACH = U*2.0D0 + RETURN +C----------------------- End of Function D1MACH ------------------------ + END + + SUBROUTINE FUNC_CHEM (N, T, V, FCT) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + KPP_REAL V(NVAR), FCT(NVAR) + KPP_REAL T,TOLD + INTEGER N + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + CALL Fun(V, FIX, RCONST, FCT) + RETURN + END + + SUBROUTINE JAC_CHEM (N, T, V, JV, j, ian, jan) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + KPP_REAL V(NVAR), JV(NVAR,NVAR) + KPP_REAL T,TOLD + INTEGER N, j, ian(1), jan(1), ii, jj + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + + DO ii=1,NVAR + DO jj=1,NVAR + JV(ii,jj) = 0.D0 + END DO + END DO + call Jac(V, FIX, RCONST, JV) + + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.def new file mode 100755 index 00000000..193022c3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.def @@ -0,0 +1,42 @@ + +#FUNCTION AGGREGATE +#JACOBIAN FULL +#DOUBLE ON +#INTFILE atm_odessa_ddm + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + + +#INLINE C_GLOBAL +extern int Autonomous; +extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT +int Autonomous; +double STEPSTART; +#ENDINLINE + + + +#INLINE C_INIT + STEPMIN=0.0001; + STEPMAX=3600.0; + Autonomous = 0; + STEPSTART=STEPMIN; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.f new file mode 100755 index 00000000..55bfd2e7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_odessa_ddm.f @@ -0,0 +1,4398 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + REAL*8 TIN +C TOUT - End Time + REAL*8 TOUT +C Concentrations and Sensitivities + REAL*8 Y(NVAR,NSENSIT+1), PARAMS(NSENSIT) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + INTEGER i + + INTEGER LIW, LRW +C PARAMETER (LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) +C PARAMETER (LIW = 21 + NVAR + NSENSIT) +C REAL*8 RWORK(LRW) +C INTEGER IWORK(LIW) +C Note: the following dynamic allocation is not standard F77 and may not work on +C some systems. Declare LRW, LIW parameters as above with some upper bound +C used for NSENSIT + REAL*8 RWORK(22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) + INTEGER IWORK(21 + NVAR + NSENSIT) + + INTEGER IOPT(3), NEQ(2) + + EXTERNAL FUNC_CHEM,JAC,DFUNC_CHEMDPAR + + MF = 21 ! --- BDF plus user-supplied Jacobian + + LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR + LIW = 21 + NVAR + NSENSIT + + NEQ(1) = NVAR ! --- No. of Variables + NEQ(2) = NSENSIT ! --- No of parameters + + ITOL=1 ! --- 1=Scalar Tolerances; 4 = VECTOR TOLERANCES + ITASK=1 ! --- Normal Output + ISTATE=1 + IOPT(1)=1 ! --- 0= No optional parameters, 1=Optional parameters + IOPT(2)=1 ! --- 1=Perform sensitivity analysis; 0 if not + IOPT(3)=0 ! --- DFUNC_CHEMDPAR supplied by the user; + ! --- 0 if finite differences are to be used +C --- Set optional parameters + DO 10 i=1,LRW + RWORK(i) = 0.0D0 + 10 CONTINUE + DO 20 i=1,LIW + IWORK(i) = 0 + 20 CONTINUE + + RWORK(5) = STEPMIN ! THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. + RWORK(6) = STEPMAX ! THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. + RWORK(7) = 0.0D0 ! THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. + IWORK(6) = 5000 ! MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS + + CALL ODESSA( FUNC_CHEM,DFUNC_CHEMDPAR,NEQ,Y,PARAMS,TIN,TOUT, + & ITOL,RTOL,ATOL, + 1 ITASK,ISTATE,IOPT,RWORK,LRW,IWORK,LIW, + & JAC,MF) + + IF (ISTATE.LT.0) THEN + print *,'ODESSA: Unsucessfull exit at T=', + & TIN,' (ISTATE=',ISTATE,')' + ENDIF + + RETURN + END + + + + SUBROUTINE FUNC_CHEM (N, T, V, PARAMS, FCT) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + DIMENSION V(NVAR), PARAMS(*), FCT(NVAR) + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + CALL Fun(V, FIX, RCONST, FCT) + RETURN + END + + SUBROUTINE DFUNC_CHEMDPAR (N, T, V, PARAMS, DFCT, JPAR) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + DIMENSION V(NVAR), PARAMS(*), DFCT(NVAR) + INTEGER JPAR, i +C This setting is required for sensitivities w.r.t. initial conditions + DO i=1,NVAR + DFCT(i) = 0.d0 + END DO + RETURN + END + + SUBROUTINE JAC (N, T, V, PARAMS, ML, MU, JV, NROWPD) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL*8 V(NVAR), PARAMS(*), JV(NVAR,NVAR) + INTEGER ML, MU, NROWPD + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + DO i=1,NVAR + DO j=1,NVAR + JV(i,j) = 0.D0 + END DO + END DO + CALL Jac(V, FIX, RCONST, JV) + RETURN + END +! + +C ALGORITHM 658, COLLECTED ALGORITHMS FROM ACM. +C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, +C VOL. 14, NO. 1, P.61. +C----------------------------------------------------------------------- +C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. +C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS. +C +C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF +C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. +C THIS VERSION IS IN DOUBLE PRECISION. +C +C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. +C DY(I)/DP, FOR A SINGLE PARAMETER, OR, +C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, +C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. +C DY/DT = F(Y,T;P). +C----------------------------------------------------------------------- +C REFERENCES... +C +C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND +C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY +C DIFFERENTIAL EQUATIONS. SUBMITTED TO ACM TRANS. MATH. SOFTWARE, +C (1985). +C +C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY DIFFERENTIA +C EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS SENSITIVITY ANALYSIS. +C SUBMITTED TO ACM TRANS. MATH. SOFTWARE, (1985). +C +C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE +C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, +C VOL. 15, NO. 4 (1980), PP. 10-11. +C----------------------------------------------------------------------- +C PROBLEM STATEMENT.. +C +C THE ODESSA MODIFICATION OF THE LSODE PACKAGE PROVIDES THE OPTION TO +C CALCULATE FIRST-ORDER SENSITIVITY COEFFICIENTS FOR A SYSTEM OF STIFF +C OR NON-STIFF EXPLICIT ORDINARY DIFFERENTIAL EQUATIONS OF THE GENERAL +C FORM : +C +C DY/DT = F(Y,T;P) (1) +C +C WHERE Y IS AN N-DIMENSIONAL DEPENDENT VARIABLE VECTOR, T IS THE +C INDEPENDENT INTEGRATION VARIABLE, AND P IS AN NPAR-DIMENSIONAL +C CONSTANT VECTOR. THE GOVERNING EQUATIONS FOR THE FIRST-ORDER +C SENSITIVITY COEFFICIENTS ARE GIVEN BY : +C +C S'(T) = J(T)*S(T) + DF/DP (2) +C +C WHERE +C +C S(T) = DY(T)/DP (= SENSITIVITY FUNCTIONS) +C S'(T) = D(DY(T)/DP)/DT +C J(T) = DF(Y,T;P)/DY(T) (= JACOBIAN MATRIX) +C AND DF/DP = DF(Y,T;P)/DP (= INHOMOGENEITY MATRIX) +C +C SOLUTION OF EQUATIONS (1) AND (2) PROCEEDS SIMULTANEOUSLY VIA AN +C EXTENSION OF THE LSODE PACKAGE AS DESCRIBED IN [1]. +C---------------------------------------------------------------------- +C ACKNOWLEDGEMENT : THE FOLLOWING ODESSA PACKAGE DOCUMENTATION IS A +C MODIFICATION OF THE LSODE DOCUMENTATION WHICH +C ACCOMPANIES THE LSODE PACKAGE CODE. +C---------------------------------------------------------------------- +C SUMMARY OF USAGE. +C +C COMMUNICATION BETWEEN THE USER AND THE ODESSA PACKAGE, FOR NORMAL +C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET +C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR +C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, +C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE +C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. +C +C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE F (N, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, PAR, YDOT +C DIMENSION Y(N), YDOT(N), PAR(NPAR) +C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). +C N IS THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS IN THE +C ABOVE MODEL. NPAR IS THE NUMBER OF MODEL PARAMETERS FOR WHICH +C VECTOR SENSITIVITY FUNCTIONS ARE DESIRED. YOU ARE ALSO ENCOURAGED +C TO PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE DF (N, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(N), PAR(NPAR), DFDP(N) +C GO TO (1,...,NPAR) JPAR +C 1 DFDP(1) = DF(1)/DP(1) +C . +C DFDP(I) = DF(I)/DP(1) +C . +C DFDP(N) = DF(N)/DP(1) +C RETURN +C 2 DFDP(1) = DF(1)/DP(2) +C . +C DFDP(I) = DF(I)/DP(2) +C . +C DFDP(N) = DF(N)/DP(2) +C RETURN +C . . +C . . +C RETURN +C NPAR DFDP(1) = DF(1)/DP(NPAR) +C . +C DFDP(I) = DF(I)/DP(NPAR) +C . +C DFDP(N) = DF(N)/DP(NPAR) +C RETURN +C END +C ONLY NONZERO ELEMENTS NEED BE LOADED. IF THIS IS NOT FEASIBLE, +C ODESSA WILL GENERATE THIS MATRIX INTERNALLY BY DIFFERENCE QUOTIENTS. +C +C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. +C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE +C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE +C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, +C USE METH = 10. IF IT IS STIFF, USE METH = 20. THE USER IS REQUIRED +C TO INPUT THE METHOD FLAG MF = 10*METH + MITER. THERE ARE FOUR +C STANDARD CHOICES FOR MITER WHEN A SENSITIVITY ANALYSIS IS DESIRED, +C AND ODESSA REQUIRES THE JACOBIAN MATRIX IN SOME FORM. +C THIS MATRIX IS REGARDED EITHER AS FULL (MITER = 1 OR 2), +C OR BANDED (MITER = 4 OR 5). IN THE BANDED CASE, ODESSA REQUIRES TWO +C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE +C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN +C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH +C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. +C +C C. YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN DIRECTLY (MF = 11, 14, +C 21, OR 24), BUT IF THIS IS NOT FEASIBLE, ODESSA WILL COMPUTE IT +C INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 12, 15, 22, OR 25). IF YOU +C ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) +C DOUBLE PRECISION T, Y, PAR, PD +C DIMENSION Y(N), PD(NROWPD,N), PAR(NPAR) +C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. +C FOR A FULL JACOBIAN (MF = 11, OR 21), LOAD PD(I,J) WITH DF(I)/DY(J), +C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE +C ML AND MU ARGUMENTS IN THIS CASE.) +C FOR A BANDED JACOBIAN (MF = 14, OR 24), LOAD PD(I-J+MU+1,J) WITH +C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF +C PD FROM THE TOP DOWN. +C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. +C +C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE ODESSA ONCE FOR +C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE +C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES BY +C ODESSA. ON THE FIRST CALL TO ODESSA, SUPPLY ARGUMENTS AS FOLLOWS.. +C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F (MODEL). +C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. +C DF = NAME OF SUBROUTINE FOR INHOMOGENEITY MATRIX DF/DP. +C IF USED (IDF = 1), THIS NAME MUST BE DECLARED EXTERNAL IN +C CALLING PROGRAM. IF NOT USED (IDF = 0), PASS A DUMMY NAME. +C N = NUMBER OF FIRST ORDER ODE-S IN MODEL; LOAD INTO NEQ(1). +C NPAR = NUMBER OF MODEL PARAMETERS OF INTEREST; LOAD INTO NEQ(2). +C Y = AN (N) BY (NPAR+1) REAL ARRAY OF INITIAL VALUES.. +C Y(I,1) , I = 1,N , CONTAIN THE STATE, OR MODEL, DEPENDENT +C VARIABLES, +C Y(I,J) , J = 2,NPAR , CONTAIN THE DEPENDENT SENSITIVITY +C COEFFICIENTS. +C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING MODEL PARAMETERS +C OF INTEREST. +C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. +C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). +C ITOL = 1, 2, 3, OR 4 ACCORDING AS RTOL, ATOL (BELOW) ARE SCALARS +C OR ARRAYS. +C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) +C ARRAY). +C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) +C ARRAY). +C THE ESTIMATED LOCAL ERROR IN Y(I,J) WILL BE CONTROLLED SO AS +C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN +C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL IF ITOL = 1, +C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL(I,J) IF ITOL = 2, +C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL IF ITOL = 3, OR +C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL(I,J) IF ITOL = 4. +C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, +C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I,J)), +C OR THE RELATIVE ERROR IS LESS THAN RTOL (OR RTOL(I,J)). +C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND +C USE ATOL = 0.0 FOR PURE RELATIVE ERROR CONTROL. +C CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE LOCAL +C TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. +C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. +C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. +C IOPT = 0, TO INDICATE NO OPTIONAL INPUTS FOR INTEGRATION; +C LOAD INTO IOPT(1). +C ISOPT = 1, TO INDICATE SENSITIVITY ANALYSIS, = 0, TO INDICATE +C NO SENSITIVITY ANALYSIS; LOAD INTO IOPT(2). +C IDF = 1, IF SUBROUTINE DF (ABOVE) IS SUPPLIED BY THE USER, +C = 0, OTHERWISE; LOAD INTO IOPT(3). +C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. +C 22 + 16*N + N**2 FOR MF = 11 OR 12, +C 22 + 17*N + (2*ML + MU)*N FOR MF = 14 OR 15, +C 22 + 9*N + N**2 FOR MF = 21 OR 22, +C 22 + 10*N + (2*ML + MU)*N FOR MF = 24 OR 25, +C IF ISOPT = 0, OR.. +C 22 + 15*(NPAR+1)*N + N**2 + N FOR MF = 11 OR 12, +C 24 + 15*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 14 OR 15, +C 22 + 8*(NPAR+1)*N + N**2 + N FOR MF = 21 OR 22, +C 24 + 8*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 24 OR 25, +C IF ISOPT = 1. +C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION STATEMENT). +C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. +C 20 + N IF ISOPT = 0, +C 21 + N + NPAR IF ISOPT = 1. +C IF MITER = 4 OR 5, INPUT IN IWORK(1),IWORK(2) THE LOWER +C AND UPPER HALF-BANDWIDTHS ML,MU (EXCLUDING MAIN DIAGONAL). +C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION STATEMENT). +C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX. +C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING +C PROGRAM. IF NOT USED, PASS A DUMMY NAME. +C MF = METHOD FLAG. STANDARD VALUES FOR ISOPT = 0 ARE.. +C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. +C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. +C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. +C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. +C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. +C IF ISOPT = 1, MF = 10 IS ILLEGAL AND CAN BE REPLACED BY.. +C 11 FOR NONSTIFF METHOD, USER-SUPPLIED FULL JACOBIAN. +C 12 FOR NONSTIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. +C 14 FOR NONSTIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. +C 15 FOR NONSTIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. +C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, AND +C POSSIBLY ATOL AND RTOL, AS WELL AS NEQ, IOPT, AND PAR IF ISOPT = 1. +C +C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. +C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. +C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). +C ISTATE = 2 IF ODESSA WAS SUCCESSFUL, NEGATIVE OTHERWISE. +C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). +C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). +C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). +C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). +C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN +C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). +C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION +C COMPONENT I,J VANISHED, AND ATOL OR ATOL(I,J) = 0.0) +C +C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY +C RESET TOUT AND CALL ODESSA AGAIN. NO OTHER PARAMETERS NEED BE RESET. +C---------------------------------------------------------------------- +C EXAMPLE PROBLEM. +C +C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING +C NEEDED FOR ITS SOLUTION BY ODESSA. THE PROBLEM IS FROM CHEMICAL +C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. +C DY1/DT = -PAR(1)*Y1 + PAR(2)*Y2*Y3 ; PAR(1) = .04, PAR(2) = 1.E4 +C DY2/DT = PAR(1)*Y1 - PAR(2)*Y2*Y3 - PAR(3)*Y2**2 ; PAR(3) = 3.E7 +C DY3/DT = PAR(3)*Y2**2 +C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS +C Y1 = 1.0, Y2 = Y3 = 0, AND S(I,J) = 0, I = 1,3, J = 1,3. +C THE PROBLEM IS STIFF. +C +C THE FOLLOWING CODING KppSolveS THIS PROBLEM WITH ODESSA, USING +C MF = 21 AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. +C IT USES ITOL = 4 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3, +C BECAUSE Y2 HAS MUCH SMALLER VALUES. LESS STRINGENT TOLERANCES +C ARE ASSIGNED FOR THE SENSITIVITIES TO ACHIEVE GREATER EFFICIENCY. +C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE +C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). +C +C DOUBLE PRECISION ATOL, RWORK, RTOL, T, TOUT, Y, PAR +C EXTERNAL FEX, JEX, DFEX +C DIMENSION Y(3,4), PAR(3), ATOL(3,4), RTOL(3,4), RWORK(130), +C 1 IWORK(27), NEQ(2), IOPT(3) +C N = 3 +C NPAR = 3 +C NEQ(1) = N +C NEQ(2) = NPAR +C NSV = NPAR+1 +C DO 10 I = 1,N +C DO 10 J = 1,NSV +C 10 Y(I,J) = 0.0D0 +C Y(1,1) = 1.0D0 +C PAR(1) = 0.04D0 +C PAR(2) = 1.0D4 +C PAR(3) = 3.0D7 +C T = 0.D0 +C TOUT = .4D0 +C ITOL = 4 +C ATOL(1,1) = 1.D-6 +C ATOL(2,1) = 1.D-10 +C ATOL(3,1) = 1.D-6 +C DO 20 I = 1,N +C RTOL(I,1) = 1.D-4 +C DO 15 J = 2,NSV +C RTOL(I,J) = 1.D-3 +C 15 ATOL(I,J) = 1.D2 * ATOL(I,1) +C 20 CONTINUE +C ITASK = 1 +C ISTATE = 1 +C IOPT(1) = 0 +C IOPT(2) = 1 +C IOPT(3) = 1 +C LRW = 130 +C LIW = 27 +C MF = 21 +C DO 60 IOUT = 1,12 +C CALL ODESSA(FEX,DFEX,NEQ,Y,PAR,T,TOUT,ITOL,RTOL,ATOL, +C 1 ITASK,ISTATE, IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) +C WRITE(6,30)T,Y(1,1),Y(2,1),Y(3,1) +C 30 FORMAT(1X,7H AT T =,E12.4,6H Y =,3E14.6) +C DO 50 J = 2,NSV +C JPAR = J-1 +C WRITE(6,40)JPAR,Y(1,J),Y(2,J),Y(3,J) +C 40 FORMAT(20X,2HS(,I1,3H) =,3E14.6) +C 50 CONTINUE +C IF (ISTATE .LT. 0) GO TO 80 +C 60 TOUT = TOUT*10.D0 +C WRITE(6,70)IWORK(11),IWORK(12),IWORK(13),IWORK(19) +C 70 FORMAT(1X,/,12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =, +C 1 I4,12H NO. DF-S =,I4) +C STOP +C 80 WRITE(6,90)ISTATE +C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, YDOT, PAR +C DIMENSION Y(3), YDOT(3), PAR(3) +C YDOT(1) = -PAR(1)*Y(1) + PAR(2)*Y(2)*Y(3) +C YDOT(3) = PAR(3)*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, PAR, ML, MU, PD, NRPD) +C DOUBLE PRECISION PD, T, Y, PAR +C DIMENSION Y(3), PD(NRPD,3), PAR(3) +C PD(1,1) = -PAR(1) +C PD(1,2) = PAR(2)*Y(3) +C PD(1,3) = PAR(2)*Y(2) +C PD(2,1) = PAR(1) +C PD(2,3) = -PD(1,3) +C PD(3,2) = 2.D0*PAR(3)*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C SUBROUTINE DFEX (NEQ, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(3), PAR(3), DFDP(3) +C GO TO (1,2,3), JPAR +C 1 DFDP(1) = -Y(1) +C DFDP(2) = Y(1) +C RETURN +C 2 DFDP(1) = Y(2)*Y(3) +C DFDP(2) = -Y(2)*Y(3) +C RETURN +C 3 DFDP(2) = -Y(2)*Y(2) +C DFDP(3) = Y(2)*Y(2) +C RETURN +C END +C +C THE OUTPUT OF THIS PROGRAM (ON A DATA GENERAL MV-8000 IN +C DOUBLE PRECISION IS AS FOLLOWS: +C +C AT T = .4000E+00 Y = .985173E+00 .338641E-04 .147930E-01 +C S(1) = -.355914E+00 .390261E-03 .355524E+00 +C S(2) = .955150E-07 -.213065E-09 -.953019E-07 +C S(3) = -.158466E-10 -.529012E-12 .163756E-10 +C AT T = .4000E+01 Y = .905516E+00 .224044E-04 .944615E-01 +C S(1) = -.187621E+01 .179197E-03 .187603E+01 +C S(2) = .296093E-05 -.583104E-09 -.296034E-05 +C S(3) = -.493267E-09 -.276246E-12 .493544E-09 +C AT T = .4000E+02 Y = .715848E+00 .918628E-05 .284143E+00 +C S(1) = -.424730E+01 .459360E-04 .424726E+01 +C S(2) = .137294E-04 -.235815E-09 -.137291E-04 +C S(3) = -.228818E-08 -.113803E-12 .228829E-08 +C AT T = .4000E+03 Y = .450526E+00 .322299E-05 .549471E+00 +C S(1) = -.595837E+01 .354310E-05 .595836E+01 +C S(2) = .227380E-04 -.226041E-10 -.227380E-04 +C S(3) = -.378971E-08 -.499501E-13 .378976E-08 +C AT T = .4000E+04 Y = .183185E+00 .894131E-06 .816814E+00 +C S(1) = -.475006E+01 -.599504E-05 .475007E+01 +C S(2) = .188089E-04 .231330E-10 -.188089E-04 +C S(3) = -.313478E-08 -.187575E-13 .313480E-08 +C AT T = .4000E+05 Y = .389733E-01 .162133E-06 .961027E+00 +C S(1) = -.157477E+01 -.276199E-05 .157477E+01 +C S(2) = .628668E-05 .110026E-10 -.628670E-05 +C S(3) = -.104776E-08 -.453588E-14 .104776E-08 +C AT T = .4000E+06 Y = .493609E-02 .198411E-07 .995064E+00 +C S(1) = -.236244E+00 -.458262E-06 .236244E+00 +C S(2) = .944669E-06 .183193E-11 -.944671E-06 +C S(3) = -.157441E-09 -.635990E-15 .157442E-09 +C AT T = .4000E+07 Y = .516087E-03 .206540E-08 .999484E+00 +C S(1) = -.256277E-01 -.509808E-07 .256278E-01 +C S(2) = .102506E-06 .203905E-12 -.102506E-06 +C S(3) = -.170825E-10 -.684002E-16 .170826E-10 +C AT T = .4000E+08 Y = .519314E-04 .207736E-09 .999948E+00 +C S(1) = -.259316E-02 -.518029E-08 .259316E-02 +C S(2) = .103726E-07 .207209E-13 -.103726E-07 +C S(3) = -.172845E-11 -.691450E-17 .172845E-11 +C AT T = .4000E+09 Y = .544710E-05 .217885E-10 .999995E+00 +C S(1) = -.271637E-03 -.541849E-09 .271638E-03 +C S(2) = .108655E-08 .216739E-14 -.108655E-08 +C S(3) = -.180902E-12 -.723615E-18 .180902E-12 +C AT T = .4000E+10 Y = .446748E-06 .178699E-11 .100000E+01 +C S(1) = -.322322E-04 -.842541E-10 .322323E-04 +C S(2) = .128929E-09 .337016E-15 -.128929E-09 +C S(3) = -.209715E-13 -.838859E-19 .209715E-13 +C AT T = .4000E+11 Y = -.363960E-07 -.145584E-12 .100000E+01 +C S(1) = -.164109E-06 -.429604E-11 .164113E-06 +C S(2) = .656436E-12 .171842E-16 -.656451E-12 +C S(3) = -.689361E-15 -.275745E-20 .689363E-15 +C +C NO. STEPS = 340 NO. F-S = 412 NO. J-S = 343 NO. DF-S =1023 +C---------------------------------------------------------------------- +C FULL DESCRIPTION OF USER INTERFACE TO ODESSA. +C +C THE USER INTERFACE TO ODESSA CONSISTS OF THE FOLLOWING PARTS. +C +C I. THE CALL SEQUENCE TO SUBROUTINE ODESSA, WHICH IS A DRIVER +C ROUTINE FOR THE KppSolveR. THIS INCLUDES DESCRIPTIONS OF BOTH +C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. +C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF +C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN +C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). +C +C II. DESCRIPTIONS OF OTHER ROUTINES IN THE ODESSA PACKAGE THAT MAY +C BE (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY +C TO ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL +C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). +C +C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY +C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT +C OF THE PROBLEM AND CONTINUED SOLUTION LATER. +C +C IV. DESCRIPTION OF TWO SUBROUTINES IN THE ODESSA PACKAGE, EITHER OF +C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. +C THESE RELATE TO THE MEASUREMENT OF ERRORS. +C +C V. GENERAL REMARKS WHICH HIGHLIGHT DIFFERENCES BETWEEN THE LSODE +C PACKAGE AND THE ODESSA PACKAGE. +C---------------------------------------------------------------------- +C PART I. CALL SEQUENCE. +C +C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE.. +C F, DF, NEQ, PAR, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, +C JAC, MF, +C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE +C Y, T, ISTATE. +C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS +C TO THE RETURN FROM SUBROUTINE ODESSA TO THE USER-S CALLING PROGRAM.) +C +C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE +C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A +C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. +C +C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. +C +C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE +C ODE MODEL. THIS SYSTEM MUST BE PUT IN THE FIRST-ORDER +C FORM DY/DT = F(Y,T;P), WHERE F IS A VECTOR-VALUED FUNCTION +C OF THE SCALAR T AND VECTORS Y, AND PAR. SUBROUTINE F IS TO +C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM.. +C SUBROUTINE F (NEQ, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, PAR, YDOT +C DIMENSION Y(1), PAR(1), YDOT(1) +C WHERE NEQ, T, Y, AND PAR ARE INPUT, AND YDOT = F(Y,T;P) +C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH N (= NEQ(1)). +C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY +C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C F SHOULD NOT ALTER ARRAY Y, OR PAR(1),...,PAR(NPAR). +C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C +C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN F) AND PAR HAS LENGTH EXCEEDING NPAR. +C SEE THE DESCRIPTIONS OF NEQ AND PAR BELOW. +C +C DF = THE NAME OF THE USER-SUPPLIED ROUTINE (IDF = 1) TO COMPUTE +C THE INHOMOGENEITY MATRIX, DF/DP, AS A FUNCTION OF THE SCALAR +C T, AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM +C SUBROUTINE DF (NEQ, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(1), PAR(1), DFDP(1) +C GO TO (1,2,...,NPAR) JPAR +C 1 DFDP(1) = DF(1)/DP(1) +C . +C DFDP(I) = DF(I)/DP(1) +C . +C DFDP(N) = DF(N)/DP(1) +C RETURN +C 2 DFDP(1) = DF(1)/DP(2) +C . +C DFDP(I) = DF(I)/DP(2) +C . +C DFDP(N) = DF(N)/DP(2) +C . +C RETURN +C . . +C . . +C NPAR DFDP(1) = DF(1)/DP(NPAR) +C . +C DFDP(I) = DF(I)/DP(NPAR) +C . +C DFDP(N) = DF(N)/DP(NPAR) +C RETURN +C END +C WHERE NEQ, T, Y, PAR, AND JPAR ARE INPUT AND THE VECTOR +C DFDP(*,JPAR) IS TO BE LOADED WITH THE PARTIAL DERIVATIVES +C DF(Y,T;PAR)/DP(JPAR) ON OUTPUT. ONLY NONZERO ELEMENTS NEED +C BE LOADED. T, Y, AND PAR HAVE THE SAME MEANING AS IN +C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY +C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE). +C +C DFDP(*,JPAR) IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY +C THE NONZERO ELEMENTS NEED BE LOADED BY DF. SUBROUTINE DF +C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM IF USED. +C IF IDF = 0 (OR ISOPT = 0), A DUMMY ARGUMENT CAN BE USED. +C +C SUBROUTINE DF MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN DF) AND PAR HAS A LENGTH EXCEEDING NPAR. +C SEE THE DESCRIPTIONS OF NEQ AND PAR (BELOW). +C +C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER ORDINARY +C DIFFERENTIAL EQUATIONS (N) IN THE MODEL). USED ONLY FOR +C INPUT. NEQ MAY NOT BE CHANGED DURING THE PROBLEM. +C +C FOR ISOPT = 0, NEQ IS NORMALLY A SCALAR. HOWEVER, NEQ MAY +C BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE (N), IN WHICH +C CASE THE ODESSA PACKAGE ACCESSES ONLY NEQ(1). HOWEVER, +C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS +C TO F, DF, AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS +C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS +C IT TO F, DF, AND/OR JAC. FOR ISOPT = 1, NPAR MUST BE LOADED +C INTO NEQ(2), AND IS NOT ALLOWED TO CHANGE DURING THE PROBLEM. +C IN THESE CASES, SUBROUTINES F, DF, AND/OR JAC MUST INCLUDE +C NEQ IN A DIMENSION STATEMENT. +C +C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF +C DIMENSION (N) BY (NPAR+1). USED FOR BOTH INPUT AND +C OUTPUT ON THE FIRST CALL (ISTATE = 1), AND ONLY FOR +C OUTPUT ON OTHER CALLS. ON THE FIRST CALL, Y MUST CONTAIN +C THE VECTORS OF INITIAL VALUES. ON OUTPUT, Y CONTAINS THE +C COMPUTED SOLUTION VECTORS, EVALUATED AT T. +C +C PAR = A REAL ARRAY FOR THE VECTOR OF CONSTANT MODEL PARAMETERS +C OF INTEREST IN THE SENSITIVITY ANALYSIS, OF LENGTH NPAR +C OR MORE. PAR IS PASSED AS AN ARGUMENT IN ALL CALLS TO F, +C DF, AND JAC. HENCE LOCATIONS PAR(NPAR+1),... MAY BE USED +C TO STORE OTHER REAL DATA AND PASS IT TO F, DF, AND/OR JAC. +C LOCATIONS PAR(1),...,PAR(NPAR) ARE USED AS INPUT ONLY, +C AND MUST NOT BE CHANGED DURING THE PROBLEM. +C +C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE +C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. +C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A +C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). +C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. +C +C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. +C USED ONLY FOR INPUT. +C +C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL +C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. +C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED +C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION +C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH +C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION +C (FORWARD OR BACKWARD IN T) IS PERMITTED. +C +C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER +C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). +C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. +C +C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE +C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED +C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE +C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR +C TCUR AND HU). +C +C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE +C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. +C +C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF SPACE (N) BY (NPAR+1). SEE DESCRIPTION BELOW +C UNDER ATOL. INPUT ONLY. +C +C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF SPACE (N) BY (NPAR+1). INPUT ONLY. +C +C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE +C THE ERROR CONTROL PERFORMED BY THE KppSolveR. THE KppSolveR WILL +C CONTROL THE VECTOR E = (E(I,J)) OF ESTIMATED LOCAL ERRORS +C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM +C RMS-NORM OF ( E(I,J)/EWT(I,J) ) .LE. 1, +C WHERE EWT(I,J) = RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J), +C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS +C RMS-NORM(V) = SQRT ( (1/N) * SUM (V(I,J)**2) ); I =1,...,N. +C HERE EWT = (EWT(I,J)) IS A VECTOR OF WEIGHTS WHICH MUST +C ALWAYS BE POSITIVE, AND THE VALUES OF RTOL AND ATOL SHOULD +C ALL BE NON-NEGATIVE. THE FOLLOWING TABLE GIVES THE TYPES +C (SCALAR/ARRAY) OF RTOL AND ATOL, AND THE CORRESPONDING FORM +C OF EWT(I,J). +C +C ITOL RTOL ATOL EWT(I,J) +C 1 SCALAR SCALAR RTOL*ABS(Y(I,J)) + ATOL +C 2 SCALAR ARRAY RTOL*ABS(Y(I,J)) + ATOL(I,J) +C 3 ARRAY SCALAR RTOL(I,J)*ABS(Y(I,J)) + ATOL +C 4 ARRAY ARRAY RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J) +C +C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT +C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. +C +C THE TOTAL NUMBER OF ERROR TEST FAILURES DUE TO THE SENSITIVITY +C ANALYSIS, AND WHICH REQUIRE AN INTEGRATION STEP TO BE +C REPEATED, ARE ACCUMULATED IN THE LAST NPAR+1 LOCATIONS OF THE +C INTEGER WORK ARRAY IWORK (SEE OPTIONAL OUTPUTS BELOW). +C THIS INFORMATION MAY BE OF VALUE IN DETERMINING APPROPRIATE +C ERROR TOLERANCES TO BE APPLIED TO THE SENSITIVITY FUNCTIONS. +C +C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL +C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL +C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING +C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR +C THE NORM CALCULATION. SEE PART IV BELOW. +C +C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED +C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL +C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED +C DOWN UNIFORMLY. +C +C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. +C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). +C 2 MEANS TAKE ONE STEP ONLY AND RETURN. +C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR +C BEYOND T = TOUT AND RETURN. +C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. +C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO +C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF +C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM +C HAS A SINGULARITY AT OR BEYOND T = TCRIT. +C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. +C TCRIT MUST BE INPUT AS RWORK(1). +C +C NOTE.. IF ITASK = 4 OR 5 AND THE KppSolveR REACHES TCRIT +C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO +C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, +C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). +C +C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE +C THE STATE OF THE CALCULATION. +C +C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. +C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM +C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. +C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION +C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT +C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. +C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS +C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT +C TESTED FOR LEGALITY.) +C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE +C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH +C A CHANGE IN INPUT PARAMETERS OTHER THAN +C TOUT AND ITASK. CHANGES ARE ALLOWED IN +C ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, +C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. +C (SEE IWORK DESCRIPTION FOR ML AND MU.) +C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED +C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF +C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE +C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) +C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES +C ISTATE = 1 ON INPUT. +C +C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH +C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS +C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) +C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. +C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP +C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE +C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE +C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT +C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY +C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN +C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). +C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID +C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). +C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION +C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE +C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION +C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE +C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET +C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS +C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE +C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN +C (ISTATE = -3) OCCURS INSTEAD.) +C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY +C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. +C NOTE.. IF THE KppSolveR DETECTS AN INFINITE LOOP OF CALLS +C TO THE KppSolveR WITH ILLEGAL INPUT, IT WILL CAUSE +C THE RUN TO STOP. +C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT +C MAY BE INAPPROPRIATE. +C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, +C IF ONE IS BEING USED. +C -6 MEANS EWT(I,J) BECAME ZERO FOR SOME I,J DURING THE +C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I,J)=0.0) +C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. +C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C +C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, +C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. +C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE +C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE +C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE +C CALLING THE KppSolveR AGAIN. +C +C IOPT = AN INTEGER ARRAY FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL +C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. +C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. +C IOPT(1) = 0 MEANS NO OPTIONAL INPUTS FOR THE KppSolveR WILL BE +C USED. DEFAULT VALUES WILL BE USED IN ALL CASES. +C = 1 MEANS ONE OR MORE OPTIONAL INPUTS FOR THE +C KppSolveR ARE BEING USED. +C NOTE : IOPT(1) IS INDEPENDENT OF ISOPT AND IDF. +C IOPT(2) = 0 MEANS NO SENSITIVITY ANALYSIS WILL BE PERFORMED. +C = 1 MEANS A SENSITIVITY ANALYSIS WILL BE PERFORMED. +C NOTE : IOPT(2) IS RENAMED TO ISOPT IN ODESSA. +C = 0 MEANS DF/DP WILL BE CALCULATED BY FINITE +C DIFFERENCE WITHIN ODESSA. +C IOPT(3) = 1 MEANS DF/DP WILL BE CALCULATED BY A USER-SUPPLIED +C ROUTINE. +C NOTE : IOPT(3) IS RENAMED TO IDF IN ODESSA. +C IF IDF = 1, THE USER MUST SUPPLY A +C SUBROUTINE DF (THE NAME IS ARBITRARY) AS +C DESCRIBED BELOW UNDER DF. FOR IDF = 0, +C A DUMMY ARGUMENT CAN BE USED. +C +C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). +C FOR ISOPT = 0, THE LENGTH OF RWORK MUST BE AT LEAST.. +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM +C FOR ISOPT = 1, THE LENGTH OF RWORK MUST BE AT LEAST.. +C 20 + NYH*(MAXORD + 1) + 2*NYH + LWM + N +C WHERE.. +C NYH = THE TOTAL NUMBER OF DEPENDENT VARIABLES; +C (= N IF ISOPT = 0, AND N*(NPAR+1) IF ISOPT = 1). +C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A +C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), +C LWM = 0 IF MITER = 0, +C LWM = N**2 + 2 IF MITER IS 1 OR 2, +C LWM = N + 2 IF MITER = 3, AND +C LWM = (2*ML+MU+1)*N + 2 IF MITER IS 4 OR 5. +C (SEE THE MF DESCRIPTION FOR METH AND MITER.) +C +C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL +C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. +C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE KppSolveR +C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS +C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) +C +C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE KppSolveR.) +C +C IWORK = AN INTEGER WORK ARRAY. THE LENGTH MUST BE AT LEAST.. +C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR +C 20 + N OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). +C FOR ISOPT = 0, OR.. +C 21 + N + NPAR +C FOR ISOPT = 1. +C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. +C IWORK(1) = ML THESE ARE THE LOWER AND UPPER +C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE +C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. +C THE BAND IS DEFINED BY THE MATRIX LOCATIONS +C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU +C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. +C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND +C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE +C THE BAND PARAMETERS FOR A MATRIX TO WHICH +C DF/DY IS ONLY APPROXIMATELY EQUAL. +* +C +C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE KppSolveR.) +C +C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO ODESSA +C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND +C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 2*NYH + N WORDS OF RWORK. +C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS +C AVAILABLE FOR USE BY THE USER OUTSIDE ODESSA BETWEEN CALLS, IF +C DESIRED (BUT NOT FOR USE BY F, DF, OR JAC). +C +C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO +C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF THE +C SCALAR T AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM +C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) +C DOUBLE PRECISION T, Y, PAR, PD +C DIMENSION Y(1), PAR(1), PD(NROWPD,1) +C WHERE NEQ, T, Y, PAR, ML, MU, AND NROWPD ARE INPUT AND THE +C ARRAY PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS +C OF THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST +C DIMENSION OF NROWPD. T, Y, AND PAR HAVE THE SAME MEANING AS +C IN SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A +C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE +C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN +C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). +C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS +C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE +C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS +C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). +C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). +C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH +C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED +C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY ODESSA. +C PD IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY THE +C NONZERO ELEMENTS NEED BE LOADED BY JAC. EACH CALL TO JAC IS +C PRECEDED BY A CALL TO F WITH THE SAME ARGUMENTS NEQ, T, Y, +C AND PAR. THUS TO GAIN SOME EFFICIENCY, INTERMEDIATE +C QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE SAVED IN A +C USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, IF +C DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. +C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),.... SEE THE DESCRIPTIONS OF +C NEQ (ABOVE) AND PAR (BELOW). +C +C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF +C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. +C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. +C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. +C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. +* +C METH = 2 MEANS THE METHOD BASED ON BACKWARD +C DIFFERENTIATION FORMULAS (BDF-S). +C MITER INDICATES THE CORRECTOR ITERATION METHOD.. +C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX +C IS INVOLVED). +C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C FULL (NEQ BY NEQ) JACOBIAN. +C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN +C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). +C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED DIAGONAL JACOBIAN APPROXIMATION. +C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). +C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C BANDED JACOBIAN. +C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA +C CALLS TO F PER DF/DY EVALUATION). +C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC +C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. +C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. +C +C IF A SENSITIVITY ANLYSIS IS DESIRED (ISOPT = 1), MITER = 0 +C AND 3 ARE DISALLOWED. IN THESE CASES, THE USER IS RECOMMENDED +C TO SUPPLY AN ANALYTICAL JACOBIAN (MITER = 1 OR 4) AND AN +C ANALYTICAL INHOMOGENEITY MATRIX (IDF = 1). +C---------------------------------------------------------------------- +C OPTIONAL INPUTS. +C +C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE +C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, +C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS +C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. +C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT(1) = 1, AND IN THAT +C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY +C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. +C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD +C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND +C THEN SET THOSE OF INTEREST TO NONZERO VALUES. +C +C NAME LOCATION MEANING AND DEFAULT VALUE +C +C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. +C THE DEFAULT VALUE IS DETERMINED BY THE KppSolveR. +C +C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS INFINITE. +C +C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT +C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT +C WHEN ITASK = 4 OR 5.) +C +C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT +C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. +C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL +C BE REDUCED TO THE DEFAULT VALUE. +C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY +C CAUSE THE CURRENT ORDER TO BE REDUCED. +C +C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS +C ALLOWED DURING ONE CALL TO THE KppSolveR. +C THE DEFAULT VALUE IS 500. +C +C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) +C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). +C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT +C VALUE. THE DEFAULT VALUE IS 10. +C---------------------------------------------------------------------- +C OPTIONAL OUTPUTS. +C +C AS OPTIONAL ADDITIONAL OUTPUT FROM ODESSA, THE VARIABLES LISTED +C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF ODESSA +C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF +C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. +C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED +C ON ANY SUCCESSFUL RETURN FROM ODESSA, AND ON ANY RETURN WITH +C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN +C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES +C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. +C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, +C AS NOTED BELOW. +C +C NAME LOCATION MEANING +C +C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). +C +C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C +C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE +C WHICH THE KppSolveR HAS ACTUALLY REACHED, I.E. THE +C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR +C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT +C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). +C +C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, +C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS +C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF +C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS +C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY +C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, +C THEN THE KppSolveR IS DEEMED LIKELY TO SUCCEED. +C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE +C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) +C +C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. +C +C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. +C +C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX +C LU DECOMPOSITIONS IF ISOPT = 0) FOR THE PROBLEM SO +C FAR. IF ISOPT = 1, THE NUMBER OF LU DECOMPOSITIONS +C IS EQUAL TO NJE - NSPE (SEE BELOW). +C +C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). +C +C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. +C +C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN +C THE WEIGHTED LOCAL ERROR VECTOR (E(I,J)/EWT(I,J)), +C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. +C +C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C NDFE IWORK(19) THE NUMBER OF DF/DP (VECTOR) EVALUATIONS. +C +C NSPE IWORK(20) THE NUMBER OF CALLS TO SUBROUTINE SPRIME. EACH CALL +C TO SPRIME REQUIRES A JACOBIAN EVALUATION, BUT NOT +C AN LU DECOMPOSITION. +C +C THE FOLLOWING ARRAYS ARE SEGMENTS OF THE RWORK AND IWORK ARRAYS +C WHICH MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. +C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, ITS BASE +C ADDRESS IN RWORK OR IWORK, AND ITS DESCRIPTION. +C +C NAME BASE ADDRESS DESCRIPTION +C +C YH 21 IN RWORK THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY +C (NQCUR + 1). FOR J = 0,1,...,NQCUR, COLUMN J+1 +C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES +C THE J-TH DERIVATIVE OF THE INTERPOLATING +C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, +C EVALUATED AT T = TCUR. +C +C ACOR LENRW-NYH+1 ARRAY OF SIZE NYH USED FOR THE ACCUMULATED +C IN RWORK CORRECTIONS ON EACH STEP, SCALED ON OUTPUT +C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y +C ON THE LAST STEP. THIS IS THE VECTOR E IN +C THE DESCRIPTION OF THE ERROR CONTROL. +C IT IS DEFINED ONLY ON A SUCCESSFUL RETURN +C FROM ODESSA. +C NRS LENIW-NPAR ARRAY OF SIZE NPAR+1, USED TO STORE THE +C IN IWORK ACCUMULATED NUMBER OF REPEATED STEPS DUE TO +C THE SENSITIVITY ANALYSIS.. +C NRS(1) = TOTAL NUMBER OF REPEATED STEPS, +C NRS(2),... = NUMBER OF REPEATED STEPS DUE TO +C MODEL PARAMETER 1,... +C +C---------------------------------------------------------------------- +C PART II. OTHER ROUTINES CALLABLE. +C +C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO +C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH ODESSA. +C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE +C SLATEC ERROR HANDLING PACKAGE.) +C +C FORM OF CALL FUNCTION +C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR +C OUTPUT OF MESSAGES FROM ODESSA, IF +C THE DEFAULT IS NOT DESIRED. +C THE DEFAULT VALUE OF LUN IS 6. +C +C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF +C MESSAGES BY ODESSA.. +C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. +C THIS RISKS LOSING VALUABLE INFORMATION.) +C MFLAG = 1 MEANS PRINT (THE DEFAULT). +C +C EITHER OF THE ABOVE CALLS MAY BE MADE AT +C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. +C +C CALL SVCOM (RSAV, ISAV) STORE IN RSAV AND ISAV THE CONTENTS +C OF THE INTERNAL COMMON BLOCKS USED BY +C ODESSA (SEE PART III BELOW). +C RSAV MUST BE A REAL ARRAY OF LENGTH 222 +C OR MORE, AND ISAV MUST BE AN INTEGER +C ARRAY OF LENGTH 54 OR MORE. +C +C CALL RSCOM (RSAV, ISAV) RESTORE, FROM RSAV AND ISAV, THE CONTENTS +C OF THE INTERNAL COMMON BLOCKS USED BY +C ODESSA. PRESUMES A PRIOR CALL TO SVCOM +C WITH THE SAME ARGUMENTS. +C +C SVCOM AND RSCOM ARE USEFUL IF +C INTERRUPTING A RUN AND RESTARTING +C LATER, OR ALTERNATING BETWEEN TWO OR +C MORE PROBLEMS KppSolveD WITH ODESSA. +C +C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS +C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF +C DESIRED. IT MAY BE CALLED ONLY AFTER +C A SUCCESSFUL RETURN FROM ODESSA. +C +C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. +C THE FORM OF THE CALL IS.. +C +C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C THE INPUT PARAMETERS ARE.. +C +C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED +C (NORMALLY THE SAME AS THE T LAST RETURNED BY ODESSA). +C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. +C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) +C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY +C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER +C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING +C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED +C BY ODESSA DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST +C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. +C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. +C NYH = COLUMN LENGTH OF YH, EQUAL TO THE TOTAL NUMBER OF +C DEPENDENT VARIABLES. IF ISOPT = 0, NYH = N. IF ISOPT = 1, +C NYH = N * (NPAR + 1). +C +C THE OUTPUT PARAMETERS ARE.. +C +C DKY = A REAL ARRAY OF LENGTH NYH CONTAINING THE COMPUTED VALUE +C OF THE K-TH DERIVATIVE OF Y(T). +C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, +C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. +C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. +C---------------------------------------------------------------------- +C PART III. COMMON BLOCKS. +C +C IF ODESSA IS TO BE USED IN AN OVERLAY SITUATION, THE USER +C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. +C (1) THE CALL SEQUENCE TO ODESSA, +C (2) THE THREE INTERNAL COMMON BLOCKS +C /ODE001/ OF LENGTH 258 (219 DOUBLE PRECISION WORDS +C FOLLOWED BY 39 INTEGER WORDS), +C /ODE002/ OF LENGTH 14 (3 DOUBLE PRECISION WORDS FOLLOWED +C BY 11 INTEGER WORDS), +C /EH0001/ OF LENGTH 2 (INTEGER WORDS). +C +C IF ODESSA IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL +C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD +C DECLARE THE ABOVE THREE COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE +C THAT THEIR CONTENTS ARE PRESERVED. +C +C IF THE SOLUTION OF A GIVEN PROBLEM BY ODESSA IS TO BE INTERRUPTED +C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN +C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, +C FOLLOWING THE RETURN FROM THE LAST ODESSA CALL PRIOR TO THE +C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE +C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE +C NEXT ODESSA CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON +C BLOCKS, USE SUBROUTINES SVCOM AND RSCOM (SEE PART II ABOVE). +C +C---------------------------------------------------------------------- +C PART IV. OPTIONALLY REPLACEABLE KppSolveR ROUTINES. +C +C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE ODESSA PACKAGE WHICH +C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE +C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH +C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE +C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. +C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS +C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) +C +C (A) EWSET. +C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL +C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS +C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. +C SUBROUTINE EWSET (NYH, ITOL, RTOL, ATOL, YCUR, EWT) +C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE ODESSA CALL SEQUENCE, +C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND +C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. +C +C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) +C (I = 1,...,NYH) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS +C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE +C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY ODESSA IN THE COMPUTATION +C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, +C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. +C +C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE +C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ +C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER +C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, +C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE +C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, +C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. +C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING +C IN EWSET THE STATEMENTS.. +C DOUBLE PRECISION H, RLS +C COMMON /ODE001/ RLS(219),ILS(39) +C NQ = ILS(35) +C NYH = ILS(14) +C NST = ILS(36) +C H = RLS(213) +C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS +C YCUR(NYH+I)/H (I=1,...,N) (AND THE DIVISION BY H IS +C UNNECESSARY WHEN NST = 0). +C +C (B) VNORM. +C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED +C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. +C D = VNORM (LV, V, W) +C WHERE.. +C LV = THE LENGTH OF THE VECTOR, +C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, +C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, +C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). +C VNORM IS CALLED WITH LV = N AND WITH W(I) = 1.0/EWT(I), WHERE +C EWT IS AS SET BY SUBROUTINE EWSET. +C +C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE +C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN ODESSA. +C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. +C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. +C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR +C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF +C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. +C---------------------------------------------------------------------- +C OTHER ROUTINES IN THE ODESSA PACKAGE. +C +C IN ADDITION TO SUBROUTINE ODESSA, THE ODESSA PACKAGE INCLUDES THE +C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. +C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. +C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE +C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. +C STESA MANAGES THE SOLUTION OF THE SENSITIVITY FUNCTIONS. +C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. +C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY +C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. +C IT IS ALSO CALLED BY SPRIME (WITH JOPT = 1) TO JUST +C COMPUTE THE JACOBIAN MATRIX. +C PREPDF COMPUTES THE INHOMOGENEITY MATRIX DF/DP. +C SPRIME DEFINES THE SYSTEM OF SENSITIVITY EQUATIONS. +C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. +C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. +C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. +C SVCOM AND RSCOM ARE USER-CALLABLE ROUTINES TO SAVE AND RESTORE, +C RESPECTIVELY, THE CONTENTS OF THE INTERNAL COMMON BLOCKS. +C DGEFA AND DGESL ARE ROUTINES FROM LINPACK FOR SOLVING FULL +C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. +C DGBFA AND DGBSL ARE ROUTINES FROM LINPACK FOR SOLVING BANDED +C LINEAR SYSTEMS. +C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES +C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. +C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. +C XERR, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR +C MESSAGES AND WARNINGS. +C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. +C ALL THE OTHERS ARE SUBROUTINES. +C +C THE FORTRAN GENERIC INTRINSIC FUNCTIONS USED BY ODESSA ARE.. +C ABS, MAX, MIN, REAL, MOD, SIGN, SQRT, AND WRITE +C +C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, +C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. +C +C---------------------------------------------------------------------- +C PART V. GENERAL REMARKS +C +C THIS SECTION HIGHLIGHTS THE BASIC DIFFERENCES BETWEEN THE ORIGINAL +C LSODE PACKAGE AND THE ODESSA MODIFICATION. THIS IS PROVIDED AS A +C SERVICE TO EXPERIENCED LSODE USERS TO EXPEDITE FAMILIARIZATION WITH +C ODESSA. +C +C (A). ORIGINAL SUBROUTINES AND FUNCTIONS. +C +C OF THE ORIGINAL 22 SUBROUTINES AND FUNCTIONS USED IN THE LSODE +C PACKAGE, ALL ARE USED BY ODESSA, WITH THE FOLLOWING HAVING BEEN +C MODIFIED.. +C +C LSODE THE ORIGINAL DRIVER SUBROUTINE FOR THE LSODE PACKAGE IS +C EXTENSIVELY MODIFIED AND RENAMED ODESSA, WHICH NOW +C CONTAINS A CALL TO SPRIME TO ESTABLISH INITIAL CONDITIONS +C FOR THE SENSITIVITY CALCULATIONS. +C +C STODE THE ONE STEP INTEGRATOR IS SLIGHTLY MODIFIED AND RETAINS +C ITS ORIGINAL NAME. IT NOW CONTAINS THE CALL TO STESA, +C AND ALSO CALLS SPRIME IF KFLAG .LE. -3. +C +C PREPJ ALSO NAMED PREPJ IN ODESSA IS SLIGHTLY MODIFIED TO ALLOW +C FOR THE CALCULATION OF JACOBIAN WITH NO PREPROCESSING +C (JOPT = 1). +C +C (B). NEW SUBROUTINES. +C +C IN ADDITION TO THE CHANGES NOTED ABOVE, THREE NEW SUBROUTINES +C HAVE BEEN INTRODUCED (SEE STESA, SPRIME, AND PREPDF AS DESCRIBED +C IN PART IV. ABOVE). +C +C (C). COMMON BLOCKS. +C +C /LS0001/ RETAINS THE SAME LENGTH AND IS RENAMED /ODE001/; +C HOWEVER THE REAL ARRAY ROWNS(209) IS SHORTENED TO A +C LENGTH OF (173) REAL WORDS, ALLOWING THE REMOVAL OF +C TESCO(3,12) WHICH IS NOW PASSED FROM STODE TO STESA. +C IN ADDITION, THE INTEGER ARRAY IOWNS(6) IS SHORTENED +C TO A LENGTH OF (4) INTEGER WORDS, ALLOWING THE REMOVAL +C OF IALTH AND LMAX WHICH ARE NOW PASSED FROM STODE TO +C STESA. +C +C /ODE002/ ADDED COMMON BLOCK FOR VARIABLES IMPORTANT TO +C SENSITIVITY ANALYSIS (SEE PART III. ABOVE). A BLOCK +C DATA PROGRAM IS NOT REQUIRED FOR THIS COMMON BLOCK. +C +C SVCOM,RSCOM THESE TWO SUBROUTINES ARE MODIFIED TO HANDLE +C COMMON BLOCK /ODE002/ AS WELL. +C +C (D). OPTIONAL INPUTS. +C +C THE FULL SET OF OPTIONAL INPUTS AVAILABLE IN LSODE IS ALSO +C AVAILABLE IN ODESSA, WITH THE EXCEPTION THAT THE NUMBER OF ODE'S +C IN THE MODEL (NEQ(1)), MAY NOT BE CHANGED DURING THE PROBLEM. +C IN ODESSA, NYH NOW REFERS TO THE TOTAL NUMBER OF FIRST-ORDER +C ODE'S (MODEL AND SENSITIVITY EQUATIONS) WHICH IS EQUAL TO +C NEQ(1) IF ISOPT = 0, OR NEQ(1)*(NEQ(2)+1) IF ISOPT = 1. +C NEQ(1), NEQ(2), AND NYH ARE NOT ALLOWED TO CHANGE DURING +C THE COURSE OF AN INTEGRATION. +C +C (E). OPTIONAL OUTPUTS. +C +C THE FULL SET OF OPTIONAL OUTPUTS AVAILABLE IN LSODE IS ALSO +C AVAILABLE IN ODESSA. IN ADDITION, IWORK(19) AND IWORK(20) ARE +C LOADED WITH NDFE AND NSPE, RESPECTIVELY, UPON OUTPUT. THE TOTAL +C NUMBER OF LU DECOMPOSITIONS OF THE PROCESSED JACOBIAN IS EQUAL +C TO NJE - NSPE. +C----------------------------------------------------------------------- + SUBROUTINE ODESSA (F, DF, NEQ, Y, PAR, T, TOUT, ITOL, RTOL, ATOL, + 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL IHIT + EXTERNAL F, DF, JAC, PREPJ, SOLSY, PREPDF + DIMENSION NEQ(*), Y(*), PAR(*), RTOL(*), ATOL(*), IOPT(*), + 1 RWORK(LRW), IWORK(LIW), MORD(2) +C----------------------------------------------------------------------- +C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. +C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS. +C +C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF +C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. +C THIS VERSION IS IN DOUBLE PRECISION. +C +C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. +C DY(I)/DP, FOR A SINGLE PARAMETER, OR, +C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, +C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. +C DY(T)/DT = F(Y,T;P). +C----------------------------------------------------------------------- +C REFERENCES... +C +C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND +C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY +C DIFFERENTIAL EQUATIONS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE, +C (1985). +C +C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY +C DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE. +C (1985). +C +C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE +C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, +C VOL. 15, NO. 4 (1980), PP. 10-11. +C----------------------------------------------------------------------- +C THE FOLLOWING INTERNAL COMMON BLOCKS CONTAIN +C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST +C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND +C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. +C THE STRUCTURE OF THE BLOCKS ARE AS FOLLOWS.. ALL REAL VARIABLES ARE +C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE +C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE ODESSA FIRST, +C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED +C FOR COMMUNICATION. THE BLOCKS ARE DECLARED IN SUBROUTINES ODESSA +C INTDY, STODE, STESA, PREPJ, PREPDF, AND SOLSY. GROUPS OF VARIABLES +C ARE REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES +C WHERE THOSE VARIABLES ARE NOT USED. +C----------------------------------------------------------------------- + COMMON /ODE001/ TRET, ROWNS(173), + 1 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS(4), + 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, + 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 NPAR, LDFDP, LNRS, + 2 ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS + PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) + DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ +C----------------------------------------------------------------------- +C BLOCK A. +C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. +C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPIATELY. +C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS +C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. +C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. +C----------------------------------------------------------------------- + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .EQ. 0) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) GO TO 430 + 20 NTREP = 0 +C----------------------------------------------------------------------- +C BLOCK B. +C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), +C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). +C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. +C +C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, +C MF, ML, AND MU. +C----------------------------------------------------------------------- + IF (NEQ(1) .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ(1) .NE. N) GO TO 605 + 25 N = NEQ(1) + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + DO 26 I = 1,3 + 26 IF (IOPT(I) .LT. 0 .OR. IOPT(I) .GT. 1) GO TO 607 + ISOPT = IOPT(2) + IDF = IOPT(3) + NYH = N + NSV = 1 + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 IF (ISOPT .EQ. 0) GO TO 32 +C CHECK LEGALITY OF THE NON-OPTIONAL INPUTS ISOPT, NPAR. +C COMPUTE NUMBER OF SOLUTION VECTORS AND TOTAL NUMBER OF EQUATIONS. + IF (NEQ(2) .LE. 0) GO TO 628 + IF (ISTATE .EQ. 1) GO TO 31 + IF (NEQ(2) .NE. NPAR) GO TO 629 + 31 NPAR = NEQ(2) + NSV = NPAR + 1 + NYH = NSV * N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 630 +C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- + 32 IF (IOPT(1) .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = ZERO + HMXI = ZERO + HMIN = ZERO + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. ZERO) GO TO 615 + HMXI = ZERO + IF (HMAX .GT. ZERO) HMXI = ONE/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. ZERO) GO TO 616 +C----------------------------------------------------------------------- +C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. +C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO +C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). +C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. +C WORK SPACE FOR DFDP IS CONTAINED IN ACOR. +C----------------------------------------------------------------------- + 60 LYH = 21 + LWM = LYH + (MAXORD + 1)*NYH + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 + IF (MITER .EQ. 3) LENWM = N + 2 + IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 + LEWT = LWM + LENWM + LSAVF = LEWT + NYH + LACOR = LSAVF + N + LDFDP = LACOR + N + LENRW = LACOR + NYH - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 20 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 + LNRS = LENIW + LIWM + IF (ISOPT .EQ. 1) LENIW = LNRS + NPAR + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 70 I = 1,NYH + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + IF (RTOLI .LT. ZERO) GO TO 619 + IF (ATOLI .LT. ZERO) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- + DO 80 I = 1,N + 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) +C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + GO TO 200 +C----------------------------------------------------------------------- +C BLOCK C. +C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). +C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, +C THE INITIAL CALL TO SPRIME IF ISOPT = 1, +C AND THE CALCULATION OF THE INITIAL STEP SIZE. +C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. +C----------------------------------------------------------------------- + 100 UROUND = D1MACH(4) + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 + IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) + 1 H0 = TCRIT - T + 105 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + NHNIL = 0 + NST = 0 + NJE = 0 + NSLAST = 0 + HU = ZERO + NQU = 0 + CCMAX = 0.3D0 + MAXCOR = 3 + IF (ISOPT .EQ. 1) MAXCOR = 4 + MSBP = 20 + MXNCF = 10 +C INITIAL CALL TO F. (LF0 POINTS TO YH(1,2) AND LOADS IN VALUES). + LF0 = LYH + NYH + CALL F (NEQ, T, Y, PAR, RWORK(LF0)) + NFE = 1 + DUPS = ZERO + DSMS = ZERO + DDNS = ZERO + NDFE = 0 + NSPE = 0 + IF (ISOPT .EQ. 0) GO TO 114 +C INITIALIZE COUNTS FOR REPEATED STEPS DUE TO SENSITIVITY ANALYSIS. + DO 110 J = 1,NSV + 110 IWORK(J + LNRS - 1) = 0 +C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- + 114 DO 115 I = 1,NYH + 115 RWORK(I+LYH-1) = Y(I) +C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO ONE.) ------- + NQ = 1 + H = ONE + CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,NYH + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 + 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + IF (ISOPT .EQ. 0) GO TO 125 +C CALL SPRIME TO LOAD FIRST-ORDER SENSITIVITY DERIVATIVES INTO +C REMAINING YH(*,2) POSITIONS. + CALL SPRIME (NEQ, Y, RWORK(LYH), NYH, N, NSV, RWORK(LWM), + 1 IWORK(LIWM), RWORK(LEWT), RWORK(LF0), RWORK(LACOR), + 2 RWORK(LDFDP), PAR, F, JAC, DF, PREPJ, PREPDF) + IF (IERSP .EQ. -1) GO TO 631 + IF (IERSP .EQ. -2) GO TO 632 +C----------------------------------------------------------------------- +C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE +C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. +C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. +C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) +C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED +C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. ONLY THE ORIGINAL +C SOLUTION VECTOR IS CONSIDERED IN THIS CALCULATION (ISOPT = 0 OR 1). +C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. +C NEQ +C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) +C 1 +C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), +C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, +C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). +C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. +C----------------------------------------------------------------------- + 125 IF (H0 .NE. ZERO) GO TO 180 + TDIST = ABS(TOUT - T) + W0 = MAX(ABS(T),ABS(TOUT)) + IF (TDIST .LT. TWO*UROUND*W0) GO TO 622 + TOL = RTOL(1) + IF (ITOL .LE. 2) GO TO 140 + DO 130 I = 1,N + 130 TOL = MAX(TOL,RTOL(I)) + 140 IF (TOL .GT. ZERO) GO TO 160 + ATOLI = ATOL(1) + DO 150 I = 1,N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + AYI = ABS(Y(I)) + IF (AYI .NE. ZERO) TOL = MAX(TOL,ATOLI/AYI) + 150 CONTINUE + 160 TOL = MAX(TOL,100.0D0*UROUND) + TOL = MIN(TOL,0.001D0) + SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) + SUM = ONE/(TOL*W0*W0) + TOL*SUM**2 + H0 = ONE/SQRT(SUM) + H0 = MIN(H0,TDIST) + H0 = SIGN(H0,TOUT-T) +C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. ONE) H0 = H0/RH +C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ + H = H0 + DO 190 I = 1,NYH + 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) + GO TO 270 +C----------------------------------------------------------------------- +C BLOCK D. +C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) +C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. +C----------------------------------------------------------------------- + 200 NSLAST = NST + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(ONE + 100.0D0*UROUND) + IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + IF (ISTATE .EQ. 2) JSTART = -2 +C----------------------------------------------------------------------- +C BLOCK E. +C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS +C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. +C +C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. +C +C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT +C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND +C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. +C TOLSF IS CALCULATED CONSIDERING ALL SOLUTION VECTORS. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,NYH + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 + 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*VNORM (NYH, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. ONE) GO TO 280 + TOLSF = TOLSF*2.0D0 + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF (ADDX(TN,H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + CALL XERR ('ODESSA - WARNING..INTERNAL T (=R1) AND H (=R2) ARE', + 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP', + 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('(H = STEP SIZE). KppSolveR WILL CONTINUE ANYWAY', + 1 101, 1, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + CALL XERR ('ODESSA - ABOVE WARNING HAS BEEN ISSUED I1 TIMES.', + 1 102, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', + 1 102, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL STODE(NEQ,Y,YH,NYH,YH,WM,IWM,EWT,SAVF,ACOR,PAR,NRS, +C 1 F,JAC,DF,PREPJ,PREPDF,SOLSY) +C----------------------------------------------------------------------- + CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LWM), + 1 IWORK(LIWM), RWORK(LEWT), RWORK(LSAVF), RWORK(LACOR), + 2 PAR, IWORK(LNRS), F, JAC, DF, PREPJ, PREPDF, SOLSY) + KGO = 1 - KFLAG + GO TO (300, 530, 540, 633), KGO +C----------------------------------------------------------------------- +C BLOCK F. +C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE +C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. +C----------------------------------------------------------------------- + 300 INIT = 1 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- + 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ + 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 + GO TO 250 +C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. + 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + JSTART = -2 + GO TO 250 +C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX +C----------------------------------------------------------------------- +C BLOCK G. +C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM ODESSA. +C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. +C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE +C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. +C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, +C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. +C----------------------------------------------------------------------- + 400 DO 410 I = 1,NYH + 410 Y(I) = RWORK(I+LYH-1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IF (ISOPT .EQ. 0) RETURN + IWORK(19) = NDFE + IWORK(20) = NSPE + RETURN + 430 NTREP = NTREP + 1 + IF (NTREP .LT. 5) RETURN + CALL XERR ('ODESSA -- REPEATED CALLS WITH ISTATE = 1 AND + 1TOUT = T (=R1)', 301, 1, 0, 0, 0, 1, T, ZERO) + GO TO 800 +C----------------------------------------------------------------------- +C BLOCK H. +C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN +C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. +C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. +C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT +C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO +C THE WORK ARRAYS BEFORE RETURNING. +C----------------------------------------------------------------------- +C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- + 500 CALL XERR ('ODESSA - AT CURRENT T (=R1), MXSTEP (=I1) STEPS', + 1 201, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('TAKEN ON THIS CALL BEFORE REACHING TOUT', + 1 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) + ISTATE = -1 + GO TO 580 +C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + CALL XERR ('ODESSA - AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', + 1 202, 1, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- + 520 CALL XERR ('ODESSA - AT T (=R1), TOO MUCH ACCURACY REQUESTED', + 1 203, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('FOR PRECISION OF MACHINE.. SEE TOLSF (=R2)', + 1 203, 1, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- + 530 CALL XERR ('ODESSA - AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', + 1 204, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', + 1 204, 1, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- + 540 CALL XERR ('ODESSA - AT T (=R1) AND STEP SIZE H (=R2), THE', + 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('CORRECTOR CONVERGENCE FAILED REPEATEDLY', + 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('OR WITH ABS(H) = HMIN', + 1 205, 1, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C COMPUTE IMXER IF RELEVANT. ------------------------------------------- + 560 BIG = ZERO + IMXER = 1 + DO 570 I = 1,NYH + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ + 580 DO 590 I = 1,NYH + 590 Y(I) = RWORK(I+LYH-1) + T = TN + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IF (ISOPT .EQ. 0) RETURN + IWORK(19) = NDFE + IWORK(20) = NSPE + RETURN +C----------------------------------------------------------------------- +C BLOCK I. +C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT +C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. +C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN +C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE KppSolveR, +C THE RUN IS HALTED. +C----------------------------------------------------------------------- + 601 CALL XERR ('ODESSA - ISTATE (=I1) ILLEGAL', + 1 1, 1, 1, ISTATE, 0, 0, ZERO,ZERO) + GO TO 700 + 602 CALL XERR ('ODESSA - ITASK (=I1) ILLEGAL', + 1 2, 1, 1, ITASK, 0, 0, ZERO,ZERO) + GO TO 700 + 603 CALL XERR ('ODESSA - ISTATE .GT. 1 BUT ODESSA NOT INITIALIZED', + 1 3, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 604 CALL XERR ('ODESSA - NEQ (=I1) .LT. 1', + 1 4, 1, 1, NEQ(1), 0, 0, ZERO,ZERO) + GO TO 700 + 605 CALL XERR ('ODESSA - ISTATE = 3 AND NEQ CHANGED. (I1 TO I2)', + 1 5, 1, 2, N, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 606 CALL XERR ('ODESSA - ITOL (=I1) ILLEGAL', + 1 6, 1, 1, ITOL, 0, 0, ZERO,ZERO) + GO TO 700 + 607 CALL XERR ('ODESSA - IOPT (=I1) ILLEGAL', + 1 7, 1, 1, IOPT, 0, 0, ZERO,ZERO) + GO TO 700 + 608 CALL XERR('ODESSA - MF (=I1) ILLEGAL', + 1 8, 1, 1, MF, 0, 0, ZERO,ZERO) + GO TO 700 + 609 CALL XERR('ODESSA - ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 9, 1, 2, ML, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 610 CALL XERR('ODESSA - MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 10, 1, 2, MU, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 611 CALL XERR('ODESSA - MAXORD (=I1) .LT. 0', + 1 11, 1, 1, MAXORD, 0, 0, ZERO,ZERO) + GO TO 700 + 612 CALL XERR('ODESSA - MXSTEP (=I1) .LT. 0', + 1 12, 1, 1, MXSTEP, 0, 0, ZERO,ZERO) + GO TO 700 + 613 CALL XERR('ODESSA - MXHNIL (=I1) .LT. 0', + 1 13, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) + GO TO 700 + 614 CALL XERR('ODESSA - TOUT (=R1) BEHIND T (=R2)', + 1 14, 1, 0, 0, 0, 2, TOUT, T) + CALL XERR('INTEGRATION DIRECTION IS GIVEN BY H0 (=R1)', + 1 14, 1, 0, 0, 0, 1, H0, ZERO) + GO TO 700 + 615 CALL XERR('ODESSA - HMAX (=R1) .LT. 0.0', + 1 15, 1, 0, 0, 0, 1, HMAX, ZERO) + GO TO 700 + 616 CALL XERR('ODESSA - HMIN (=R1) .LT. 0.0', + 1 16, 1, 0, 0, 0, 1, HMIN, ZERO) + GO TO 700 + 617 CALL XERR('ODESSA - RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS + 1 LRW (=I2)', 17, 1, 2, LENRW, LRW, 0, ZERO,ZERO) + GO TO 700 + 618 CALL XERR('ODESSA - IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS + 1 LIW (=I2)', 18, 1, 2, LENIW, LIW, 0, ZERO,ZERO) + GO TO 700 + 619 CALL XERR('ODESSA - RTOL(I1) IS R1 .LT. 0.0', + 1 19, 1, 1, I, 0, 1, RTOLI, ZREO) + GO TO 700 + 620 CALL XERR('ODESSA - ATOL(I1) IS R1 .LT. 0.0', + 1 20, 1, 1, I, 0, 1, ATOLI, ZERO) + GO TO 700 +* + 621 EWTI = RWORK(LEWT+I-1) + CALL XERR('ODESSA - EWT(I1) IS R1 .LE. 0.0', + 1 21, 1, 1, I, 0, 1, EWTI, ZERO) + GO TO 700 + 622 CALL XERR('ODESSA - TOUT (=R1) TOO CLOSE TO T(=R2) TO START + 1 INTEGRATION', 22, 1, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CALL XERR('ODESSA - ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU + 1 (= R2)', 23, 1, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR + 1 (=R2)', 24, 1, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT + 1 (=R2)', 25, 1, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 CALL XERR('ODESSA - AT START OF PROBLEM, TOO MUCH ACCURACY', + 1 26, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR('REQUESTED FOR PRECISION OF MACHINE. SEE TOLSF (=R1)', + 1 26, 1, 0, 0, 0, 1, TOLSF, ZERO) + RWORK(14) = TOLSF + GO TO 700 + 627 CALL XERR('ODESSA - TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', + 1 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) + GO TO 700 +C ERROR STATEMENTS ASSOCIATED WITH SENSITIVITY ANALYSIS. + 628 CALL XERR('ODESSA - NPAR (=I1) .LT. 1', + 1 28, 1, 1, NPAR, 0, 0, ZERO,ZERO) + GO TO 700 + 629 CALL XERR('ODESSA - ISTATE = 3 AND NPAR CHANGED (I1 TO I2)', + 1 29, 1, 2, NP, NPAR, 0, ZERO,ZERO) + GO TO 700 + 630 CALL XERR('ODESSA - MITER (=I1) ILLEGAL', + 1 30, 1, 1, MITER, 0, 0, ZERO,ZERO) + GO TO 700 + 631 CALL XERR('ODESSA - TROUBLE IN SPRIME (IERPJ)', + 1 31, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 632 CALL XERR('ODESSA - TROUBLE IN SPRIME (MITER)', + 1 32, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 633 CALL XERR('ODESSA - FATAL ERROR IN STODE (KFLAG = -3)', + 1 33, 2, 0, 0, 0, 0, ZERO,ZERO) + GO TO 801 +C + 700 IF (ILLIN .EQ. 5) GO TO 710 + ILLIN = ILLIN + 1 + ISTATE = -3 + RETURN + 710 CALL XERR('ODESSA - REPEATED OCCURRENCES OF ILLEGAL INPUT', + 1 302, 1, 0, 0, 0, 0, ZERO,ZERO) +C + 800 CALL XERR('ODESSA - RUN ABORTED.. APPARENT INFINITE LOOP', + 1 303, 2, 0, 0, 0, 0, ZERO,ZERO) + RETURN + 801 CALL XERR('ODESSA - RUN ABORTED', + 1 304, 2, 0, 0, 0, 0, ZERO,ZERO) + RETURN +C-------------------- END OF SUBROUTINE ODESSA ------------------------- + END + DOUBLE PRECISION FUNCTION ADDX(A,B) + DOUBLE PRECISION A,B +C +C THIS FUNCTION IS NECESSARY TO FORCE OPTIMIZING COMPILERS TO +C EXECUTE AND STORE A SUM, FOR SUCCESSFUL EXECUTION OF THE +C TEST A + B = B. +C + ADDX = A + B + RETURN +C-------------------- END OF FUNCTION SUM ------------------------------ + END + SUBROUTINE SPRIME (NEQ, Y, YH, NYH, NROW, NCOL, WM, IWM, + 1 EWT, SAVF, FTEM, DFDP, PAR, F, JAC, DF, PJAC, PDF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION NEQ(*), Y(*), YH(NROW,NCOL,*), WM(*), IWM(*), + 1 EWT(*), SAVF(*), FTEM(*), DFDP(NROW,*), PAR(*) + EXTERNAL F, JAC, DF, PJAC, PDF + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 RDUM1(37),EL0, H, RDUM2(6), + 2 IOWND1(14), IOWNS(4), + 3 IDUM1(3), IERPJ, IDUM2(6), + 4 MITER, IDUM3(4), N, IDUM4(5) + COMMON /ODE002/ RDUM3(3), + 1 IOWND2(3), IDUM5, NSV, IDUM6, NSPE, IDUM7, IERSP, JOPT, IDUM8 +C----------------------------------------------------------------------- +C SPRIME IS CALLED BY ODESSA TO INITIALIZE THE YH ARRAY. IT IS ALSO +C CALLED BY STODE TO REEVALUATE FIRST ORDER DERIVATIVES WHEN KFLAG +C .LE. -3. SPRIME COMPUTES THE FIRST DERIVATIVES OF THE SENSITIVITY +C COEFFICIENTS WITH RESPECT TO THE INDEPENDENT VARIABLE T... +C +C SPRIME = D(DY/DP)/DT = JAC*DY/DP + DF/DP +C WHERE JAC = JACOBIAN MATRIX +C DY/DP = SENSITIVITY MATRIX +C DF/DP = INHOMOGENEITY MATRIX +C THIS ROUTINE USES THE COMMON VARIABLES EL0, H, IERPJ, MITER, N, +C NSV, NSPE, IERSP, JOPT +C----------------------------------------------------------------------- +C CALL PREPJ WITH JOPT = 1. +C IF MITER = 2 OR 5, EL0 IS TEMPORARILY SET TO -1.0 AND H IS +C TEMPORARILY SET TO 1.0D0. +C----------------------------------------------------------------------- + NSPE = NSPE + 1 + JOPT = 1 + IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 10 + HTEMP = H + ETEMP = EL0 + H = ONE + EL0 = -ONE + 10 CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, + 1 PAR, F, JAC, JOPT) + IF (IERPJ .NE. 0) GO TO 300 + JOPT = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 20 + H = HTEMP + EL0 = ETEMP +C----------------------------------------------------------------------- +C CALL PREPDF AND LOAD DFDP(*,JPAR). +C----------------------------------------------------------------------- + 20 DO 30 J = 2,NSV + JPAR = J - 1 + CALL PDF (NEQ, Y, WM, SAVF, FTEM, DFDP(1,JPAR), PAR, + 1 F, DF, JPAR) + 30 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE JAC*DY/DP AND STORE RESULTS IN YH(*,*,2). +C----------------------------------------------------------------------- + GO TO (40,40,310,100,100) MITER +C THE JACOBIAN IS FULL.------------------------------------------------ +C FOR EACH ROW OF THE JACOBIAN.. + 40 DO 70 IROW = 1,N +C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. + DO 60 J = 2,NSV + SUM = ZERO +C TAKE THE VECTOR DOT PRODUCT.. + DO 50 I = 1,N + IPD = IROW + N*(I-1) + 2 + SUM = SUM + WM(IPD)*YH(I,J,1) + 50 CONTINUE + YH(IROW,J,2) = SUM + 60 CONTINUE + 70 CONTINUE + GO TO 200 +C THE JACOBIAN IS BANDED.----------------------------------------------- + 100 ML = IWM(1) + MU = IWM(2) + ICOUNT = 1 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + NMU = N - MU + ML1 = ML + 1 +C FOR EACH ROW OF THE JACOBIAN.. + DO 160 IROW = 1,N + IF (IROW .GT. ML1) GO TO 110 + IPD = MBAND + IROW + 1 + IYH = 1 + LBAND = MU + IROW + GO TO 120 + 110 ICOUNT = ICOUNT + 1 + IPD = ICOUNT*MEBAND + 2 + IYH = IYH + 1 + LBAND = LBAND - 1 + IF (IROW .LE. NMU) LBAND = MBAND +C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. + 120 DO 150 J = 2,NSV + SUM = ZERO + I1 = IPD + I2 = IYH +C TAKE THE VECTOR DOT PRODUCT. + DO 140 I = 1,LBAND + SUM = SUM + WM(I1)*YH(I2,J,1) + I1 = I1 + MEBAND - 1 + I2 = I2 + 1 + 140 CONTINUE + YH(IROW,J,2) = SUM + 150 CONTINUE + 160 CONTINUE +C----------------------------------------------------------------------- +C ADD THE INHOMOGENEITY TERM, I.E., ADD DFDP(*,JPAR) TO YH(*,JPAR+1,2). +C----------------------------------------------------------------------- + 200 DO 220 J = 2,NSV + JPAR = J - 1 + DO 210 I = 1,N + YH(I,J,2) = YH(I,J,2) + DFDP(I,JPAR) + 210 CONTINUE + 220 CONTINUE + RETURN +C----------------------------------------------------------------------- +C ERROR RETURNS. +C----------------------------------------------------------------------- + 300 IERSP = -1 + RETURN + 310 IERSP = -2 + RETURN +C------------------------END OF SUBROUTINE SPRIME----------------------- + END + SUBROUTINE PREPJ (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, + 1 PAR, F, JAC, JOPT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION NEQ(*), Y(*), YH(NYH,*), WM(*), IWM(*), EWT(*), + 1 SAVF(*), FTEM(*), PAR(*) + EXTERNAL F, JAC + PARAMETER (ZERO=0.0D0,ONE=1.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(37), EL0, H, RDUM2(4), TN, UROUND, + 3 IOWND(14), IOWNS(4), + 4 IDUM1(3), IERPJ, IDUM2, JCUR, IDUM3(4), + 5 MITER, IDUM4(4), N, IDUM5(2), NFE, NJE, IDUM6 +C----------------------------------------------------------------------- +C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX +C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. +C IF ISOPT = 1, PREPJ IS ALSO CALLED BY SPRIME WITH JOPT = 1. +C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF +C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. +C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. +C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN +C SUBJECTED TO LU DECOMPOSITION (JOPT = 0) IN PREPARATION FOR LATER +C SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS +C DONE BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH PREPJ USES THE FOLLOWING.. +C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. +C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). +C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. +C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE +C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION +C OF P IF MITER IS 1, 2 , 4, OR 5. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. +C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C EL0 = EL(1) (INPUT). +C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF +C P MATRIX FOUND TO BE SINGULAR. +C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX +C (OR APPROXIMATION) IS NOW CURRENT. +C JOPT = INPUT JACOBIAN OPTION, = 1 IF JAC IS DESIRED ONLY. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, +C IERPJ, JCUR, MITER, N, NFE, AND NJE. +C----------------------------------------------------------------------- + NJE = NJE + 1 + IERPJ = 0 + JCUR = 1 + HL0 = H*EL0 + GO TO (100, 200, 300, 400, 500), MITER +C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- + 100 LENP = N*N + DO 110 I = 1,LENP + 110 WM(I+2) = ZERO + CALL JAC (NEQ, TN, Y, PAR, 0, 0, WM(3), N) + IF (JOPT .EQ. 1) RETURN + CON = -HL0 + DO 120 I = 1,LENP + 120 WM(I+2) = WM(I+2)*CON + GO TO 240 +C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- + 200 FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = -HL0/R + CALL F (NEQ, TN, Y, PAR, FTEM) + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + 230 CONTINUE + NFE = NFE + N + IF (JOPT .EQ. 1) RETURN +C ADD IDENTITY MATRIX. ------------------------------------------------- + 240 J = 3 + DO 250 I = 1,N + WM(J) = WM(J) + ONE + 250 J = J + (N + 1) +C DO LU DECOMPOSITION ON P. -------------------------------------------- + CALL DGEFA (WM(3), N, N, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- + 300 WM(2) = HL0 + R = EL0*0.1D0 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + CALL F (NEQ, TN, Y, PAR, WM(3)) + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = 1.0D0 + IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (ABS(DI) .EQ. ZERO) GO TO 330 + WM(I+2) = 0.1D0*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN +C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- + 400 ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N + DO 410 I = 1,LENP + 410 WM(I+2) = ZERO + CALL JAC (NEQ, TN, Y, PAR, ML, MU, WM(ML3), MEBAND) + IF (JOPT .EQ. 1) RETURN + CON = -HL0 + DO 420 I = 1,LENP + 420 WM(I+2) = WM(I+2)*CON + GO TO 570 +C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- + 500 ML = IWM(1) + MU = IWM(2) + MBAND = ML + MU + 1 + MBA = MIN(MBAND,N) + MEBAND = MBAND + ML + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0/EWT(I)) + 530 Y(I) = Y(I) + R + CALL F (NEQ, TN, Y, PAR, FTEM) + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) + FAC = -HL0/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA + IF (JOPT .EQ. 1) RETURN +C ADD IDENTITY MATRIX. ------------------------------------------------- + 570 II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + ONE + 580 II = II + MEBAND +C DO LU DECOMPOSITION OF P. -------------------------------------------- + CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C----------------------- END OF SUBROUTINE PREPJ ----------------------- + END + SUBROUTINE PREPDF (NEQ, Y, SRUR, SAVF, FTEM, DFDP, PAR, + 1 F, DF, JPAR) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, DF + DIMENSION NEQ(*), Y(*), SAVF(*), FTEM(*), DFDP(*), PAR(*) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 RDUM1(43), TN, RDUM2, + 2 IOWND1(14), IOWNS(4), + 3 IDUM1(10), MITER, IDUM2(4), N, IDUM3(2), NFE, IDUM4(2) + COMMON /ODE002/ RDUM3(3), + 1 IOWND2(3), IDUM5(2), NDFE, IDUM6, IDF, IDUM7(3) +C----------------------------------------------------------------------- +C PREPDF IS CALLED BY SPRIME AND STESA TO COMPUTE THE INHOMOGENEITY +C VECTORS DF(I)/DP(JPAR). HERE DF/DP IS COMPUTED BY THE USER-SUPPLIED +C ROUTINE DF IF IDF = 1, OR BY FINITE DIFFERENCING IF IDF = 0. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION WITH +C PREPDF USES THE FOLLOWING.. +C Y = REAL ARRAY OF LENGTH NYH CONTAINING DEPENDENT VARIABLES. +C PREPDF USES ONLY THE FIRST N ENTRIES OF Y(*). +C SRUR = SQRT(UROUND) (= WM(1)). +C SAVF = REAL ARRAY OF LENGTH N CONTAINING DERIVATIVES DY/DT. +C FTEM = REAL ARRAY OF LENGTH N USED TO TEMPORARILY STORE DY/DT FOR +C NUMERICAL DIFFERENTIATION. +C DFDP = REAL ARRAY OF LENGTH N USED TO STORE DF(I)/DP(JPAR), I = 1,N. +C PAR = REAL ARRAY OF LENGTH NPAR CONTAINING EQUATION PARAMETERS +C OF INTEREST. +C JPAR = INPUT PARAMETER, 2 .LE. JPAR .LE. NSV, DESIGNATING THE +C APPROPRIATE SOLUTION VECTOR CORRESPONDING TO PAR(JPAR). +C THIS ROUTINE ALSO USES THE COMMON VARIABLES TN, MITER, N, NFE, NDFE, +C AND IDF. +C----------------------------------------------------------------------- + NDFE = NDFE + 1 + IDF1 = IDF + 1 + GO TO (100, 200), IDF1 +C IDF = 0, CALL F TO APPROXIMATE DFDP. --------------------------------- + 100 RPAR = PAR(JPAR) + R = MAX(SRUR*ABS(RPAR),SRUR) + PAR(JPAR) = RPAR + R + FAC = 1.0D0/R + CALL F (NEQ, TN, Y, PAR, FTEM) + DO 110 I = 1,N + 110 DFDP(I) = (FTEM(I) - SAVF(I))*FAC + PAR(JPAR) = RPAR + NFE = NFE + 1 + RETURN +C IDF = 1, CALL USER SUPPLIED DF. -------------------------------------- + 200 DO 210 I = 1,N + 210 DFDP(I) = 0.0D0 + CALL DF (NEQ, TN, Y, PAR, DFDP, JPAR) + RETURN +C -------------------- END OF SUBROUTINE PREPDF ------------------------ + END + SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION YH(NYH,1), DKY(1) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(38),H, RDUM2(2), HU, RDUM3, TN, UROUND, + 3 IOWND(14), IOWNS(4), + 4 IDUM1(8), L, IDUM2, + 5 IDUM3(5), N, NQ, IDUM4(4) +C----------------------------------------------------------------------- +C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE +C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE +C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY +C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. +C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) +C----------------------------------------------------------------------- +C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE +C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A +C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET +C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. +C THE FORMULA FOR DKY IS.. +C Q +C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) +C J=K +C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. +C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE +C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. +C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. +C----------------------------------------------------------------------- + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TP = TN - HU*(1.0D0 + 100.0D0*UROUND) + IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1,NQ + 10 IC = IC*JJ + 15 C = REAL(IC) + DO 20 I = 1,NYH + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1,JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1,J + 30 IC = IC*JJ + 35 C = REAL(IC) + DO 40 I = 1,NYH + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + DO 60 I = 1,NYH + 60 DKY(I) = R*DKY(I) + RETURN +C + 80 CALL XERR('INTDY-- K (=I1) ILLEGAL', + 1 51, 1, 1, K, 0, 0, ZERO,ZERO) + IFLAG = -1 + RETURN + 90 CALL XERR ('INTDY-- T (=R1) ILLEGAL', + 1 52, 1, 0, 0, 0, 1, T, ZERO) + CALL XERR('T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', + 1 52, 1, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- END OF SUBROUTINE INTDY ----------------------- + END + SUBROUTINE STESA (NEQ, Y, NROW, NCOL, YH, WM, IWM, EWT, SAVF, + 1 ACOR, PAR, NRS, F, JAC, DF, PJAC, PDF, KppSolve) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, JAC, DF, PJAC, PDF, KppSolve + DIMENSION NEQ(*), Y(NROW,*), YH(NROW,NCOL,*), WM(*), IWM(*), + 1 EWT(NROW,*), SAVF(*), ACOR(NROW,*), PAR(*), NRS(*) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 TESCO(3,12), RDUM1, EL0, H, RDUM2(4), TN, RDUM3, + 2 IOWND1(14), IOWNS(4), + 3 IALTH, LMAX, IDUM1, IERPJ, IERSL, JCUR, IDUM2, KFLAG, L, IDUM3, + 4 MITER, IDUM4(4), N, NQ, IDUM5, NFE, IDUM6(2) + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 IOWND2(3), IDUM7, NSV, IDUM8(2), IDF, IDUM9, JOPT, KFLAGS +C----------------------------------------------------------------------- +C STESA IS CALLED BY STODE TO PERFORM AN EXPLICIT CALCULATION FOR THE +C FIRST-ORDER SENSITIVITY COEFFICIENTS DY(I)/DP(J), I = 1,N; J = 1,NPAR. +C +C IN ADDITION TO THE VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH STESA USES THE FOLLOWING.. +C Y = AN NROW (=N) BY NCOL (=NSV) REAL ARRAY CONTAINING THE +C CORRECTED DEPENDENT VARIABLES ON OUTPUT.. +C Y(I,1) , I = 1,N = STATE VARIABLES (INPUT); +C Y(I,J) , I = 1,N , J = 2,NSV , +C = SENSITIVITY COEFFICIENTS, DY(I)/DP(J). +C YH = AN N BY NSV BY LMAX REAL ARRAY CONTAINING THE PREDICTED +C DEPENDENT VARIABLES AND THEIR APPROXIMATE SCALED DERIVATIVES. +C SAVF = A REAL ARRAY OF LENGTH N USED TO STORE FIRST DERIVATIVES +C OF DEPENDENT VARIABLES IF MITER = 2 OR 5. +C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING THE EQUATION +C PARAMETERS OF INTEREST. +C NRS = AN INTEGER ARRAY OF LENGTH NPAR + 1 CONTAINING THE NUMBER +C OF REPEATED STEPS (KFLAGS .LT. 0) DUE TO THE SENSITIVITY +C CALCULATIONS.. +C NRS(1) = TOTAL NUMBER OF REPEATED STEPS +C NRS(I) , I = 2,NPAR = NUMBER OF REPEATED STEPS DUE +C TO PARAMETER I. +C NSV = NUMBER OF SOLUTION VECTORS = NPAR + 1. +C KFLAGS = LOCAL ERROR TEST FLAG, = 0 IF TEST PASSES, .LT. 0 IF TEST +C FAILS, AND STEP NEEDS TO BE REPEATED. ERROR TEST IS APPLIED +C TO EACH SOLUTION VECTOR INDEPENDENTLY. +C DUPS, DSMS, DDNS = REAL SCALARS USED FOR COMPUTING RHUP, RHSM, RHDN, +C ON RETURN TO STODE (IALTH .EQ. 1). +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, IALTH, LMAX, +C IERPJ, IERSL, JCUR, KFLAG, L, MITER, N, NQ, NFE, AND JOPT. +C----------------------------------------------------------------------- + DUPS = ZERO + DSMS = ZERO + DDNS = ZERO + HL0 = H*EL0 + EL0I = ONE/EL0 + TI2 = ONE/TESCO(2,NQ) + TI3 = ONE/TESCO(3,NQ) +C IF MITER = 2 OR 5 (OR IDF = 0), SUPPLY DERIVATIVES AT CORRECTED +C Y(*,1) VALUES FOR NUMERICAL DIFFERENTIATION IN PJAC AND/OR PDF. + IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. IDF .EQ. 0) GO TO 10 + GO TO 15 + 10 CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 +C IF JCUR = 0, UPDATE THE JACOBIAN MATRIX. +C IF MITER = 5, LOAD CORRECTED Y(*,1) VALUES INTO Y(*,2). + 15 IF (JCUR .EQ. 1) GO TO 30 + IF (MITER .NE. 5) GO TO 25 + DO 20 I = 1,N + 20 Y(I,2) = Y(I,1) + 25 CALL PJAC (NEQ, Y, Y(1,2), N, WM, IWM, EWT, SAVF, ACOR(1,2), + 1 PAR, F, JAC, JOPT) + IF (IERPJ .NE. 0) RETURN +C----------------------------------------------------------------------- +C THIS IS A LOOPING POINT FOR THE SENSITIVITY CALCULATIONS. +C----------------------------------------------------------------------- +C FOR EACH PARAMETER PAR(*), A SENSITIVITY SOLUTION VECTOR IS COMPUTED +C USING THE SAME STEP SIZE (H) AND ORDER (NQ) AS IN STODE. +C A LOCAL ERROR TEST IS APPLIED INDEPENDENTLY TO EACH SOLUTION VECTOR. +C----------------------------------------------------------------------- + 30 DO 100 J = 2,NSV + JPAR = J - 1 +C EVALUATE INHOMOGENEITY TERM, TEMPORARILY LOAD INTO Y(*,JPAR+1). ------ + CALL PDF(NEQ, Y, WM, SAVF, ACOR(1,J), Y(1,J), PAR, + 1 F, DF, JPAR) +C----------------------------------------------------------------------- +C LOAD RHS OF SENSITIVITY SOLUTION (CORRECTOR) EQUATION.. +C +C RHS = DY/DP - EL(1)*H*D(DY/DP)/DT + EL(1)*H*DF/DP +C +C----------------------------------------------------------------------- + DO 40 I = 1,N + 40 Y(I,J) = YH(I,J,1) - EL0*YH(I,J,2) + HL0*Y(I,J) +C----------------------------------------------------------------------- +C KppSolve CORRECTOR EQUATION: THE SOLUTIONS ARE LOCATED IN Y(*,JPAR+1). +C THE EXPLICIT FORMULA IS.. +C +C (I - EL(1)*H*JAC) * DY/DP(CORRECTED) = RHS +C +C----------------------------------------------------------------------- + CALL KppSolve (WM, IWM, Y(1,J), DUM) + IF (IERSL .NE. 0) RETURN +C ESTIMATE LOCAL TRUNCATION ERROR. ------------------------------------- + DO 50 I = 1,N + 50 ACOR(I,J) = (Y(I,J) - YH(I,J,1))*EL0I + ERR = VNORM(N, ACOR(1,J), EWT(1,J))*TI2 + IF (ERR .GT. ONE) GO TO 200 +C----------------------------------------------------------------------- +C LOCAL ERROR TEST PASSED. SET KFLAGS TO 0 TO INDICATE THIS. +C IF IALTH = 1, COMPUTE DSMS, DDNS, AND DUPS (IF L .LT. LMAX). +C----------------------------------------------------------------------- + KFLAGS = 0 + IF (IALTH .GT. 1) GO TO 100 + IF (L .EQ. LMAX) GO TO 70 + DO 60 I= 1,N + 60 Y(I,J) = ACOR(I,J) - YH(I,J,LMAX) + DUPS = MAX(DUPS,VNORM(N,Y(1,J),EWT(1,J))*TI3) + 70 DSMS = MAX(DSMS,ERR) + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C THIS SECTION IS REACHED IF THE ERROR TOLERANCE FOR SENSITIVITY +C SOLUTION VECTOR JPAR HAS BEEN VIOLATED. KFLAGS IS MADE NEGATIVE TO +C INDICATE THIS. IF KFLAGS = -1, SET KFLAG EQUAL TO ZERO SO THAT KFLAG +C IS SET TO -1 ON RETURN TO STODE BEFORE REPEATING THE STEP. +C INCREMENT NRS(1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO ALL +C SENSITIVITY SOLUTION VECTORS) BY ONE. +C INCREMENT NRS(JPAR+1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO +C SOLUTION VECTOR JPAR+1) BY ONE. +C LOAD DSMS FOR RH CALCULATION IN STODE. +C----------------------------------------------------------------------- + 200 KFLAGS = KFLAGS - 1 + IF (KFLAGS .EQ. -1) KFLAG = 0 + NRS(1) = NRS(1) + 1 + NRS(J) = NRS(J) + 1 + DSMS = ERR + RETURN +C------------------------ END OF SUBROUTINE STESA ---------------------- + END + SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, WM, IWM, EWT, SAVF, ACOR, + 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, JAC, DF, PJAC, PDF, SLVS + DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), WM(*), IWM(*), EWT(*), + 1 SAVF(*), ACOR(*), PAR(*), NRS(*) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, + 1 CONIT, CRATE, EL(13), ELCO(13,12), HOLD, RMAX, + 2 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 3 IOWND1(14), IPUP, MEO, NQNYH, NSLP, + 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, + 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 IOWND2(3), ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS +C----------------------------------------------------------------------- +C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE +C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. +C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD +C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT +C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. +C FOR ISOPT = 1, STODE CALLS STESA FOR SENSITIVITY CALCULATIONS. +C VARIABLES USED FOR COMMUNICATION WITH STESA ARE DESCRIBED IN STESA. +C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. +C +C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND +C NUMBER OF PARAMETERS TO BE CONSIDERED IN THE SENSITIVITY +C ANALYSIS NEQ(2) (FOR ISOPT = 1), AND PASSED AS THE +C NEQ ARGUMENT IN ALL CALLS TO F, JAC, AND DF. +C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN +C ALL CALLS TO F, JAC, AND DF. +C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES +C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE +C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE +C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) +C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST +C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. +C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. +C THE TOTAL NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS.. +C NYH = N, ISOPT = 0, +C NYH = N * (NPAR + 1), ISOPT = 1 +C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. +C EWT = AN ARRAY OF LENGTH NYH CONTAINING MULTIPLICATIVE WEIGHTS +C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE +C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. +C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. +C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 +C AND MAXORD .LT. THE CURRENT ORDER NQ. +C ACOR = A WORK ARRAY OF LENGTH NYH, USED FOR THE ACCUMULATED +C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS +C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). +C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX +C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). +C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX +C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. +C IF ISOPT = 1, PJAC CAN BE CALLED TO CALCULATE JAC BY +C SETTING JOPT = 1. +C SLVS = NAME OF ROUTINE TO KppSolve LINEAR SYSTEM IN CHORD ITERATION. +C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. +C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE +C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS +C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. +C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. +C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. +C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. +C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT +C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. +C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. +C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING +C VALUES AND MEANINGS.. +C 0 PERFORM THE FIRST STEP. +C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. +C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, +C N, METH, OR MITER. +C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, +C BUT WITH OTHER INPUTS UNCHANGED. +C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. +C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. +C 0 THE STEP WAS SUCCESFUL. +C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. +C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. +C -3 FATAL ERROR IN PJAC, OR SLVS, (OR STESA). +C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER +C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. +C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND +C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST +C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. +C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. +C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. +C (= 3, IF ISOPT = 0) +C (= 4, IF ISOPT = 1) +C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). +C IF ISOPT = 1, PJAC IS CALLED AT LEAST ONCE EVERY STEP. +C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. +C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. +C N = THE NUMBER OF FIRST-ORDER MODEL DIFFERENTIAL EQUATIONS. +C----------------------------------------------------------------------- + KFLAG = 0 + KFLAGS = 0 + TOLD = TN + NCF = 0 + IERPJ = 0 + IERSL = 0 + JCUR = 0 + ICF = 0 + IF (JSTART .GT. 0) GO TO 200 + IF (JSTART .EQ. -1) GO TO 100 + IF (JSTART .EQ. -2) GO TO 160 +C----------------------------------------------------------------------- +C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE +C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED +C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL +C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE +C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 +C FOR THE NEXT INCREASE. +C THESE COMPUTATIONS CONSIDER ONLY THE ORIGINAL SOLUTION VECTOR. +C THE SENSITIVITY SOLUTION VECTORS ARE CONSIDERED IN STESA (ISOPT = 1). +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0D0 + RC = ZERO + EL0 = ONE + CRATE = 0.7D0 + DELP = ZERO + HOLD = H + MEO = METH + NSLP = 0 + IPUP = MITER + IRET = 3 + GO TO 140 +C----------------------------------------------------------------------- +C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. +C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. +C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), +C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. +C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET +C THE COEFFICIENTS OF THE METHOD. +C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT +C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. +C IF H IS TO BE CHANGED, YH MUST BE RESCALED. +C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 +C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + 100 IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 110 + CALL CFODE (METH, ELCO, TESCO) + MEO = METH + IF (NQ .GT. MAXORD) GO TO 120 + IALTH = L + IRET = 1 + GO TO 150 + 110 IF (NQ .LE. MAXORD) GO TO 160 + 120 NQ = MAXORD + L = LMAX + DO 125 I = 1,L + 125 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/REAL(NQ+2) + DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) + EXDN = ONE/REAL(L) + RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) + RH = MIN(RHDN,ONE) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 170 + RH = MIN(RH,ABS(H/HOLD)) + H = HOLD + GO TO 175 +C----------------------------------------------------------------------- +C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE +C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET +C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. +C----------------------------------------------------------------------- + 140 CALL CFODE (METH, ELCO, TESCO) + 150 DO 155 I = 1,L + 155 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/REAL(NQ+2) + GO TO (160, 170, 200), IRET +C----------------------------------------------------------------------- +C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST +C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO +C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS +C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. +C----------------------------------------------------------------------- + 160 IF (H .EQ. HOLD) GO TO 200 + RH = H/HOLD + H = HOLD + IREDO = 3 + GO TO 175 + 170 RH = MAX(RH,HMIN/ABS(H)) + 175 RH = MIN(RH,RMAX) + RH = RH/MAX(ONE,ABS(H)*HMXI*RH) + R = ONE + DO 180 J = 2,L + R = R*RH + DO 180 I = 1,NYH + 180 YH(I,J) = YH(I,J)*R + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .EQ. 0) GO TO 690 +C----------------------------------------------------------------------- +C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY +C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. +C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). +C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER +C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. +C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS FOR ISOPT = 0, +C AND AT LEAST ONCE EVERY STEP FOR ISOPT = 1. +C----------------------------------------------------------------------- + 200 IF (ABS(RC-ONE) .GT. CCMAX) IPUP = MITER + IF (NST .GE. NSLP+MSBP) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 215 JB = 1,NQ + I1 = I1 - NYH + DO 210 I = I1,NQNYH + 210 YH1(I) = YH1(I) + YH1(I+NYH) + 215 CONTINUE +C----------------------------------------------------------------------- +C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. (= 3, FOR ISOPT = 0; +C = 4, FOR ISOPT = 1). A CONVERGENCE TEST IS MADE ON THE R.M.S. NORM +C OF EACH CORRECTION, WEIGHTED BY THE ERROR WEIGHT VECTOR EWT. THE SUM +C OF THE CORRECTIONS IS ACCUMULATED IN THE VECTOR ACOR(I), I = 1,N. +C (ACOR(I), I = N+1,NYH IS LOADED IN SUBROUTINE STESA (ISOPT = 1).) +C THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. +C----------------------------------------------------------------------- + 220 M = 0 + DO 230 I = 1,N + 230 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND +C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET +C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. +C----------------------------------------------------------------------- + IPUP = 0 + RC = ONE + NSLP = NST + CRATE = 0.7D0 + CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, ACOR, PAR, + 1 F, JAC, JOPT) + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = ZERO + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM +C THE RESULT OF THE LAST FUNCTION EVALUATION. +C (IF ISOPT = 1, FUNCTIONAL ITERATION IS NOT ALLOWED.) +C----------------------------------------------------------------------- + DO 290 I = 1,N + SAVF(I) = H*SAVF(I) - YH(I,2) + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = VNORM (N, Y, EWT) + DO 300 I = 1,N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + 300 ACOR(I) = SAVF(I) + GO TO 400 +C----------------------------------------------------------------------- +C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, +C AND KppSolve THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND +C P AS COEFFICIENT MATRIX. +C----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) + CALL SLVS (WM, IWM, Y, SAVF) + IF (IERSL .LT. 0) GO TO 430 + IF (IERSL .GT. 0) GO TO 410 + DEL = VNORM (N, Y, EWT) + DO 380 I = 1,N + ACOR(I) = ACOR(I) + Y(I) + 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) +C----------------------------------------------------------------------- +C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE +C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) + DCON = DEL*MIN(ONE,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) + IF (DCON .LE. ONE) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 + DELP = DEL + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + GO TO 270 +C----------------------------------------------------------------------- +C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES. +C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR +C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES +C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE +C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. +C----------------------------------------------------------------------- + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 + 430 ICF = 2 + NCF = NCF + 1 + RMAX = 2.0D0 + TN = TOLD + I1 = NQNYH + 1 + DO 445 JB = 1,NQ + I1 = I1 - NYH + DO 440 I = I1,NQNYH + 440 YH1(I) = YH1(I) - YH1(I+NYH) + 445 CONTINUE + IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + RH = 0.25D0 + IPUP = MITER + IREDO = 1 + GO TO 170 +C----------------------------------------------------------------------- +C THE CORRECTOR HAS CONVERGED. +C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 +C IF IT FAILS. OTHERWISE, STESA IS CALLED (ISOPT = 1) TO PERFORM +C SENSITIVITY CALCULATIONS AT CURRENT STEP SIZE AND ORDER. +C----------------------------------------------------------------------- + 450 CONTINUE + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) + IF (DSM .GT. ONE) GO TO 500 +C + IF (ISOPT .EQ. 0) GO TO 460 +C----------------------------------------------------------------------- +C CALL STESA TO PERFORM EXPLICIT SENSITIVITY ANALYSIS. +C IF THE LOCAL ERROR TEST FAILS (WITHIN STESA) FOR ANY SOLUTION VECTOR, +C KFLAGS IS SET .LT. 0 AND CONTROL PASSES TO STATEMENT 500 UPON RETURN. +C IN EITHER CASE, JCUR IS SET TO ZERO TO SIGNAL THAT THE JACOBIAN MAY +C NEED UPDATING LATER. +C----------------------------------------------------------------------- + CALL STESA (NEQ, Y, N, NSV, YH, WM, IWM, EWT, SAVF, ACOR, + 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) + IF (IERPJ .NE. 0 .OR. IERSL .NE. 0) GO TO 680 + IF (KFLAGS .LT. 0) GO TO 500 +C----------------------------------------------------------------------- +C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. +C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. +C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR +C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. +C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER +C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A +C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT +C TESTING FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + 460 JCUR = 0 + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 J = 1,L + DO 470 I = 1,NYH + 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) + IALTH = IALTH - 1 + IF (IALTH .EQ. 0) GO TO 520 + IF (IALTH .GT. 1) GO TO 700 + IF (L .EQ. LMAX) GO TO 700 + DO 490 I = 1,NYH + 490 YH(I,LMAX) = ACOR(I) + GO TO 700 +C----------------------------------------------------------------------- +C THE ERROR TEST FAILED IN EITHER STODE OR STESA. +C KFLAG KEEPS TRACK OF MULTIPLE FAILURES. +C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE +C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR +C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE +C BY A FACTOR OF 0.2 OR LESS. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + JCUR = 0 + TN = TOLD + I1 = NQNYH + 1 + DO 515 JB = 1,NQ + I1 = I1 - NYH + DO 510 I = I1,NQNYH + 510 YH1(I) = YH1(I) - YH1(I+NYH) + 515 CONTINUE + RMAX = 2.0D0 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 + IF (KFLAG .LE. -3) GO TO 640 + IREDO = 2 + RHUP = ZERO + GO TO 540 +C----------------------------------------------------------------------- +* +C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS +C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED +C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. +C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. +C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN +C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE +C ADDITIONAL SCALED DERIVATIVE. +C FOR ISOPT = 1, DUPS AND DSMS ARE LOADED WITH THE LARGEST RMS-NORMS +C OBTAINED BY CONSIDERING SEPARATELY THE SENSITIVITY SOLUTION VECTORS. +C----------------------------------------------------------------------- + 520 RHUP = ZERO + IF (L .EQ. LMAX) GO TO 540 + DO 530 I = 1,N + 530 SAVF(I) = ACOR(I) - YH(I,LMAX) + DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) + DUP = MAX(DUP,DUPS) + EXUP = ONE/REAL(L+1) + RHUP = ONE/(1.4D0*DUP**EXUP + 0.0000014D0) + 540 EXSM = ONE/REAL(L) + DSM = MAX(DSM,DSMS) + RHSM = ONE/(1.2D0*DSM**EXSM + 0.0000012D0) + RHDN = ZERO + IF (NQ .EQ. 1) GO TO 560 + JPOINT = 1 + DO 550 J = 1,NSV + DDN = VNORM (N, YH(JPOINT,L), EWT(JPOINT))/TESCO(1,NQ) + DDNS = MAX(DDNS,DDN) + JPOINT = JPOINT + N + 550 CONTINUE + DDN = DDNS + DDNS = ZERO + EXDN = ONE/REAL(NQ) + RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) + 560 IF (RHSM .GE. RHUP) GO TO 570 + IF (RHUP .GT. RHDN) GO TO 590 + GO TO 580 + 570 IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + GO TO 620 + 580 NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. ONE) RH = ONE + GO TO 620 + 590 NEWQ = L + RH = RHUP + IF (RH .LT. 1.1D0) GO TO 610 + R = EL(L)/REAL(L) + DO 600 I = 1,NYH + 600 YH(I,NEWQ+1) = ACOR(I)*R + GO TO 630 + 610 IALTH = 3 + GO TO 700 + 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) +C----------------------------------------------------------------------- +C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. +C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. +C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. +C----------------------------------------------------------------------- + IF (NEWQ .EQ. NQ) GO TO 170 + 630 NQ = NEWQ + L = NQ + 1 + IRET = 2 + GO TO 150 +C----------------------------------------------------------------------- +C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. +C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. +C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE +C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST +C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN +C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, +C UNTIL IT SUCCEEDS OR H REACHES HMIN. +C----------------------------------------------------------------------- + 640 IF (KFLAG .EQ. -10) GO TO 660 + RH = 0.1D0 + RH = MAX(HMIN/ABS(H),RH) + H = H*RH + DO 645 I = 1,NYH + 645 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + IF (ISOPT .EQ. 0) GO TO 649 + CALL SPRIME (NEQ, Y, YH, NYH, N, NSV, WM, IWM, EWT, SAVF, ACOR, + 1 ACOR(N+1), PAR, F, JAC, DF, PJAC, PDF) + IF (IERSP .LT. 0) GO TO 680 + DO 646 I = N+1,NYH + 646 YH(I,2) = H*YH(I,2) + 649 DO 650 I = 1,N + 650 YH(I,2) = H*SAVF(I) + IPUP = MITER + IALTH = 5 + IF (NQ .EQ. 1) GO TO 200 + NQ = 1 + L = 2 + IRET = 3 + GO TO 150 +C----------------------------------------------------------------------- +C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD +C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 KFLAG = -3 + GO TO 720 + 690 RMAX = 10.0D0 + 700 R = ONE/TESCO(2,NQU) + DO 710 I = 1,NYH + 710 ACOR(I) = ACOR(I)*R + 720 HOLD = H + JSTART = 1 + RETURN +C----------------------- END OF SUBROUTINE STODE ----------------------- + END + SUBROUTINE CFODE (METH, ELCO, TESCO) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION ELCO(13,12), TESCO(3,12) +C----------------------------------------------------------------------- +C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS +C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS +C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. +C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. +C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) +C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, +C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. +C +C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. +C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF +C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING +C POLYNOMIAL, I.E., +C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. +C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY +C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. +C FOR THE BDF METHODS, L(X) IS GIVEN BY +C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, +C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). +C +C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE +C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. +C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP +C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER +C NQ + 1 IF K = 3. +C----------------------------------------------------------------------- + DIMENSION PC(12) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) +C + GO TO (100, 200), METH +C + 100 ELCO(1,1) = ONE + ELCO(2,1) = ONE + TESCO(1,1) = ZERO + TESCO(2,1) = 2.0D0 + TESCO(1,2) = ONE + TESCO(3,12) = ZERO + PC(1) = ONE + RQFAC = ONE + DO 140 NQ = 2,12 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ-1). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + RQ1FAC = RQFAC + RQFAC = RQFAC/REAL(NQ) + NQM1 = NQ - 1 + FNQM1 = REAL(NQM1) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- + PC(NQ) = ZERO + DO 110 IB = 1,NQM1 + I = NQP1 - IB + 110 PC(I) = PC(I-1) + FNQM1*PC(I) + PC(1) = FNQM1*PC(1) +C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0D0 + TSIGN = ONE + DO 120 I = 2,NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/REAL(I) + 120 XPIN = XPIN + TSIGN*PC(I)/REAL(I+1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = ONE + DO 130 I = 2,NQ + 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/REAL(I) + AGAMQ = RQFAC*XPIN + RAGQ = ONE/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/REAL(NQP1) + TESCO(3,NQM1) = RAGQ + 140 CONTINUE + RETURN +C + 200 PC(1) = ONE + RQ1FAC = ONE + DO 230 NQ = 1,5 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + FNQ = REAL(NQ) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ + PC(NQP1) = ZERO + DO 210 IB = 1,NQ + I = NQ + 2 - IB + 210 PC(I) = PC(I-1) + FNQ*PC(I) + PC(1) = FNQ*PC(1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + DO 220 I = 1,NQP1 + 220 ELCO(I,NQ) = PC(I)/PC(2) + ELCO(2,NQ) = ONE + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = REAL(NQP1)/ELCO(1,NQ) + TESCO(3,NQ) = REAL(NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 230 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE CFODE ----------------------- + END + SUBROUTINE SOLSY (WM, IWM, X, TEM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION WM(*), IWM(*), X(*), TEM(*) + PARAMETER (ZERO=0.0D0,ONE=1.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(37), EL0, H, RDUM2(6), + 3 IOWND(14), IOWNS(4), + 4 IDUM1(4), IERSL, IDUM2(5), + 5 MITER, IDUM3(4), N, IDUM4(5) +C----------------------------------------------------------------------- +C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM +C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. +C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. +C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL +C MATRIX, AND THEN COMPUTES THE SOLUTION. +C IF MITER IS 4 OR 5, IT CALLS DGBSL. +C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. +C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF +C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND) (NOT USED HERE), +C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR +C ON OUTPUT, OF LENGTH N. +C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. +C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. +C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. +C----------------------------------------------------------------------- + IERSL = 0 + GO TO (100, 100, 300, 400, 400), MITER + 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) + RETURN +C + 300 PHL0 = WM(2) + HL0 = H*EL0 + WM(2) = HL0 + IF (HL0 .EQ. PHL0) GO TO 330 + R = HL0/PHL0 + DO 320 I = 1,N + DI = ONE - R*(ONE - ONE/WM(I+2)) + IF (ABS(DI) .EQ. ZERO) GO TO 390 + 320 WM(I+2) = ONE/DI + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) + RETURN +C----------------------- END OF SUBROUTINE SOLSY ----------------------- + END + SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) +C----------------------------------------------------------------------- +C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO +C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, +C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, +C DEPENDING ON THE VALUE OF ITOL. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 10 I = 1,N + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + EWT(I) = RTOLI*ABS(YCUR(I)) + ATOLI + 10 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE EWSET ----------------------- + END + DOUBLE PRECISION FUNCTION VNORM (N, V, W) +C----------------------------------------------------------------------- +C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM +C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS +C CONTAINED IN THE ARRAY W OF LENGTH N.. +C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) +C PROTECTION FOR UNDERFLOW/OVERFLOW IS ACCOMPLISHED USING TWO +C CONSTANTS WHICH ARE HOPEFULLY APPLICABLE FOR ALL MACHINES. +C THESE ARE: +C CUTLO = maximum of SQRT(U/EPS) over all known machines +C CUTHI = minimum of SQRT(Z) over all known machines +C WHERE +C EPS = smallest number s.t. EPS + 1 .GT. 1 +C U = smallest positive number (underflow limit) +C Z = largest number (overflow limit) +C +C DETAILS OF THE ALGORITHM AND OF VALUES OF CUTLO AND CUTHI ARE +C FOUND IN THE BLAS ROUTINE SNRM2 (SEE ALSO ALGORITHM 539, TRANS. +C MATH. SOFTWARE, VOL. 5 NO. 3, 1979, 308-323. +C FOR SINGLE PRECISION, THE FOLLOWING VALUES SHOULD BE UNIVERSAL: +C DATA CUTLO,CUTHI /4.441E-16,1.304E19/ +C FOR DOUBLE PRECISION, USE +C DATA CUTLO,CUTHI /8.232D-11,1.304D19/ +C +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER NEXT,I,J,N + DIMENSION V(N),W(N) + DATA CUTLO,CUTHI /8.232D-11,1.304D19/ + DATA ZERO,ONE/0.0D0,1.0D0/ +C BLAS ALGORITHM + NEXT = 1 + SUM = ZERO + I = 1 +20 SX = V(I)*W(I) + GO TO (30,40,70,80),NEXT +30 IF (ABS(SX).GT.CUTLO) GO TO 110 + NEXT = 2 + XMAX = ZERO +40 IF (SX.EQ.ZERO) GO TO 130 + IF (ABS(SX).GT.CUTLO) GO TO 110 + NEXT = 3 + GO TO 60 +50 I=J + NEXT = 4 + SUM = (SUM/SX)/SX +60 XMAX = ABS(SX) + GO TO 90 +70 IF(ABS(SX).GT.CUTLO) GO TO 100 +80 IF(ABS(SX).LE.XMAX) GO TO 90 + SUM = ONE + SUM * (XMAX/SX)**2 + XMAX = ABS(SX) + GO TO 130 +90 SUM = SUM + (SX/XMAX)**2 + GO TO 130 +100 SUM = (SUM*XMAX)*XMAX +110 HITEST = CUTHI/REAL(N) + DO 120 J = I,N + SX = V(J)*W(J) + IF(ABS(SX).GE.HITEST) GO TO 50 + SUM = SUM + SX**2 +120 CONTINUE + VNORM = SQRT(SUM) + GO TO 140 +130 CONTINUE + I = I + 1 + IF (I.LE.N) GO TO 20 + VNORM = XMAX * SQRT(SUM) +140 CONTINUE + RETURN +C----------------------- END OF FUNCTION VNORM ------------------------- + END + SUBROUTINE SVCOM (RSAV, ISAV) +C----------------------------------------------------------------------- +C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS +C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSA +C PACKAGE. +C RSAV = REAL ARRAY OF LENGTH 222 OR MORE. +C ISAV = INTEGER ARRAY OF LENGTH 52 OR MORE. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RSAV(*), ISAV(*) + COMMON /ODE001/ RODE1(219), IODE1(39) + COMMON /ODE002/ RODE2(3), IODE2(11) + COMMON /EH0001/ IEH(2) + DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ +C + DO 10 I = 1,LRODE1 + 10 RSAV(I) = RODE1(I) + DO 20 I = 1,LRODE2 + J = LRODE1 + I + 20 RSAV(J) = RODE2(I) + DO 30 I = 1,LIODE1 + 30 ISAV(I) = IODE1(I) + DO 40 I = 1,LIODE2 + J = LIODE1 + I + 40 ISAV(J) = IODE2(I) + ISAV(LIODE1+LIODE2+1) = IEH(1) + ISAV(LIODE1+LIODE2+2) = IEH(2) + RETURN +C----------------------- END OF SUBROUTINE SVCOM ----------------------- + END + SUBROUTINE RSCOM (RSAV, ISAV) +C----------------------------------------------------------------------- +C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS +C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSSA +C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS +C OF SUBROUTINE SVCOM OR THE EQUIVALENT. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RSAV(*), ISAV(*) + COMMON /ODE001/ RODE1(219), IODE1(39) + COMMON /ODE002/ RODE2(3), IODE2(11) + COMMON /EH0001/ IEH(2) + DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ +C + DO 10 I = 1,LRODE1 + 10 RODE1(I) = RSAV(I) + DO 20 I = 1,LRODE2 + J = LRODE1 + I + 20 RODE2(I) = RSAV(J) + DO 30 I = 1,LIODE1 + 30 IODE1(I) = ISAV(I) + DO 40 I = 1,LODE2 + J = LIODE1 + I + 40 IODE2(I) = ISAV(J) + IEH(1) = ISAV(LIODE1+LIODE2+1) + IEH(2) = ISAV(LIODE1+LIODE2+2) + RETURN +C----------------------- END OF SUBROUTINE RSCOM ----------------------- + END + SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) + INTEGER LDA,N,IPVT(*),INFO + DOUBLE PRECISION A(LDA,*) +C +C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. +C +C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED +C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. +C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . +C +C ON ENTRY +C +C A DOUBLE PRECISION(LDA, N) +C THE MATRIX TO BE FACTORED. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C +C N INTEGER +C THE ORDER OF THE MATRIX A . +C +C ON RETURN +C +C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS +C WHICH WERE USED TO OBTAIN IT. +C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE +C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER +C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. +C +C IPVT INTEGER(N) +C AN INTEGER VECTOR OF PIVOT INDICES. +C +C INFO INTEGER +C = 0 NORMAL VALUE. +C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR +C CONDITION FOR THIS SUBROUTINE, BUT IT DOES +C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO +C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE +C INDICATION OF SINGULARITY. +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DSCAL,IDAMAX +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +C +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +C +C FIND L = PIVOT INDEX +C + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) + INTEGER LDA,N,IPVT(*),JOB + DOUBLE PRECISION A(LDA,*),B(*) +C +C DGESL KppSolveS THE DOUBLE PRECISION SYSTEM +C A * X = B OR TRANS(A) * X = B +C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. +C +C ON ENTRY +C +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT FROM DGECO OR DGEFA. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C +C N INTEGER +C THE ORDER OF THE MATRIX A . +C +C IPVT INTEGER(N) +C THE PIVOT VECTOR FROM DGECO OR DGEFA. +C +C B DOUBLE PRECISION(N) +C THE RIGHT HAND SIDE VECTOR. +C +C JOB INTEGER +C = 0 TO KppSolve A*X = B , +C = NONZERO TO KppSolve TRANS(A)*X = B WHERE +C TRANS(A) IS THE TRANSPOSE. +C +C ON RETURN +C +C B THE SOLUTION VECTOR X . +C +C ERROR CONDITION +C +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A +C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY +C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER +C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE +C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 +C OR DGEFA HAS SET INFO .EQ. 0 . +C +C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX +C WITH P COLUMNS +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND IS TOO SMALL) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DDOT +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , KppSolve A * X = B +C FIRST KppSolve L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW KppSolve U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, KppSolve TRANS(A) * X = B +C FIRST KppSolve TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW KppSolve TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) + INTEGER LDA,N,ML,MU,IPVT(*),INFO + DOUBLE PRECISION ABD(LDA,*) +C +C DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION. +C +C DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED +C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. +C +C ON ENTRY +C +C ABD DOUBLE PRECISION(LDA, N) +C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS +C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND +C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS +C ML+1 THROUGH 2*ML+MU+1 OF ABD . +C SEE THE COMMENTS BELOW FOR DETAILS. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY ABD . +C LDA MUST BE .GE. 2*ML + MU + 1 . +C +C N INTEGER +C THE ORDER OF THE ORIGINAL MATRIX. +C +C ML INTEGER +C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. +C 0 .LE. ML .LT. N . +C +C MU INTEGER +C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. +C 0 .LE. MU .LT. N . +C MORE EFFICIENT IF ML .LE. MU . +C ON RETURN +C +C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND +C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. +C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE +C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER +C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. +C +C IPVT INTEGER(N) +C AN INTEGER VECTOR OF PIVOT INDICES. +C +C INFO INTEGER +C = 0 NORMAL VALUE. +C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR +C CONDITION FOR THIS SUBROUTINE, BUT IT DOES +C INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF +C CALLED. USE RCOND IN DGBCO FOR A RELIABLE +C INDICATION OF SINGULARITY. +C +C BAND STORAGE +C +C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT +C WILL SET UP THE INPUT. +C +C ML = (BAND WIDTH BELOW THE DIAGONAL) +C MU = (BAND WIDTH ABOVE THE DIAGONAL) +C M = ML + MU + 1 +C DO 20 J = 1, N +C I1 = MAX0(1, J-MU) +C I2 = MIN0(N, J+ML) +C DO 10 I = I1, I2 +C K = I - J + M +C ABD(K,J) = A(I,J) +C 10 CONTINUE +C 20 CONTINUE +C +C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . +C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR +C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. +C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . +C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE +C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DSCAL,IDAMAX +C FORTRAN MAX0,MIN0 +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION T + INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 +C +C + M = ML + MU + 1 + INFO = 0 +C +C ZERO INITIAL FILL-IN COLUMNS +C + J0 = MU + 2 + J1 = MIN0(N,M) - 1 + IF (J1 .LT. J0) GO TO 30 + DO 20 JZ = J0, J1 + I0 = M + 1 - JZ + DO 10 I = I0, ML + ABD(I,JZ) = 0.0D0 + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + JZ = J1 + JU = 0 +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 130 + DO 120 K = 1, NM1 + KP1 = K + 1 +C +C ZERO NEXT FILL-IN COLUMN +C + JZ = JZ + 1 + IF (JZ .GT. N) GO TO 50 + IF (ML .LT. 1) GO TO 50 + DO 40 I = 1, ML + ABD(I,JZ) = 0.0D0 + 40 CONTINUE + 50 CONTINUE +C +C FIND L = PIVOT INDEX +C + LM = MIN0(ML,N-K) + L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 + IPVT(K) = L + K - M +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. M) GO TO 60 + T = ABD(L,K) + ABD(L,K) = ABD(M,K) + ABD(M,K) = T + 60 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/ABD(M,K) + CALL DSCAL(LM,T,ABD(M+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + JU = MIN0(MAX0(JU,MU+IPVT(K)),N) + MM = M + IF (JU .LT. KP1) GO TO 90 + DO 80 J = KP1, JU + L = L - 1 + MM = MM - 1 + T = ABD(L,J) + IF (L .EQ. MM) GO TO 70 + ABD(L,J) = ABD(MM,J) + ABD(MM,J) = T + 70 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) + 80 CONTINUE + 90 CONTINUE + GO TO 110 + 100 CONTINUE + INFO = K + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + IPVT(N) = N + IF (ABD(M,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) + INTEGER LDA,N,ML,MU,IPVT(*),JOB + DOUBLE PRECISION ABD(LDA,*),B(*) +C +C DGBSL KppSolveS THE DOUBLE PRECISION BAND SYSTEM +C A * X = B OR TRANS(A) * X = B +C USING THE FACTORS COMPUTED BY DGBCO OR DGBFA. +C +C ON ENTRY +C +C ABD DOUBLE PRECISION(LDA, N) +C THE OUTPUT FROM DGBCO OR DGBFA. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY ABD . +C +C N INTEGER +C THE ORDER OF THE ORIGINAL MATRIX. +C +C ML INTEGER +C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. +C +C MU INTEGER +C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. +C +C IPVT INTEGER(N) +C THE PIVOT VECTOR FROM DGBCO OR DGBFA. +C +C B DOUBLE PRECISION(N) +C THE RIGHT HAND SIDE VECTOR. +C +C JOB INTEGER +C = 0 TO KppSolve A*X = B , +C = NONZERO TO KppSolve TRANS(A)*X = B , WHERE +C TRANS(A) IS THE TRANSPOSE. +C +C ON RETURN +C +C B THE SOLUTION VECTOR X . +C +C ERROR CONDITION +C +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A +C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY +C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER +C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE +C CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0 +C OR DGBFA HAS SET INFO .EQ. 0 . +C +C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX +C WITH P COLUMNS +C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) +C IF (RCOND IS TOO SMALL) GO TO ... +C DO 10 J = 1, P +C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DDOT +C FORTRAN MIN0 +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,LA,LB,LM,M,NM1 +C + M = MU + ML + 1 + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , KppSolve A * X = B +C FIRST KppSolve L*Y = B +C + IF (ML .EQ. 0) GO TO 30 + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + LM = MIN0(ML,N-K) + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW KppSolve U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/ABD(M,K) + LM = MIN0(K,M) - 1 + LA = M - LM + LB = K - LM + T = -B(K) + CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, KppSolve TRANS(A) * X = B +C FIRST KppSolve TRANS(U)*Y = B +C + DO 60 K = 1, N + LM = MIN0(K,M) - 1 + LA = M - LM + LB = K - LM + T = DDOT(LM,ABD(LA,K),1,B(LB),1) + B(K) = (B(K) - T)/ABD(M,K) + 60 CONTINUE +C +C NOW KppSolve TRANS(L)*X = Y +C + IF (ML .EQ. 0) GO TO 90 + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + LM = MIN0(ML,N-K) + B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C +C CONSTANT TIMES A VECTOR PLUS A VECTOR. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DY(*),DA + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + IF(N.LE.0)RETURN + IF (DA .EQ. 0.0D0) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + END + SUBROUTINE DSCAL(N,DA,DX,INCX) +C +C SCALES A VECTOR BY A CONSTANT. +C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DA,DX(*) + INTEGER I,INCX,M,MP1,N,NINCX +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +* +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +C +C FORMS THE DOT PRODUCT OF TWO VECTORS. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DY(*),DTEMP + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + RETURN + END + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C +C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DMAX + INTEGER I,INCX,IX,N +C + IDAMAX = 0 + IF( N .LT. 1 ) RETURN + IDAMAX = 1 + IF(N.EQ.1)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF(DABS(DX(IX)).LE.DMAX) GO TO 5 + IDAMAX = I + DMAX = DABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + IF(DABS(DX(I)).LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = DABS(DX(I)) + 30 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION D1MACH (IDUM) + INTEGER IDUM +C----------------------------------------------------------------------- +C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE +C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER +C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). +C----------------------------------------------------------------------- + DOUBLE PRECISION U, COMP + U = 1.0D0 + 10 U = U*0.5D0 + COMP = 1.0D0 + U + IF (COMP .NE. 1.0D0) GO TO 10 + D1MACH = U*2.0D0 + RETURN +C----------------------- END OF FUNCTION D1MACH ------------------------ + END + SUBROUTINE XERR (MSG, NERR, IERT, NI, I1, I2, NR, R1, R2) + INTEGER NERR, IERT, NI, I1, I2, NR, + 1 LUN, LUNIT, MESFLG + DOUBLE PRECISION R1, R2 + CHARACTER*(*) MSG +C------------------------------------------------------------------- +C +C ALL ARGUMENTS ARE INPUT ARGUMENTS. +C +C MSG = THE MESSAGE (CHARACTER VARIABLE) +C NERR = THE ERROR NUMBER (NOT USED). +C IERT = THE ERROR TYPE.. +C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). +C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). +C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. +C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. +C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. +C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. +C +C NOTES: +C 1. THE DIMENSION OF MSG IS ASSUMED TO BE AT MOST 60. +C (MULTI-LINE MESSAGES ARE GENERATED BY REPEATED CALLS.) +C 2. IF IERT = 2, CONTROL PASSES TO THE STATEMENT STOP +C TO ABORT THE RUN. THIS STATEMENT MAY BE MACHINE-DEPENDENT. +C 3. R1 AND R2 ARE ASSUMED TO BE IN DOUBLE PRECISION AND ARE PRINTED +C IN D21.13 FORMAT. +C 4. THE COMMON BLOCK /EH0001/ BELOW IS DATA-LOADED (A MACHINE- +C DEPENDENT FEATURE) WITH DEFAULT VALUES. +C THIS BLOCK IS NEEDED FOR PROPER RETENTION OF PARAMETERS USED BY +C THIS ROUTINE WHICH THE USER CAN RESET BY CALLING XSETF OR XSETUN. +C THE VARIABLES IN THIS BLOCK ARE AS FOLLOWS.. +C MESFLG = PRINT CONTROL FLAG.. +C 1 MEANS PRINT ALL MESSAGES (THE DEFAULT). +C 0 MEANS NO PRINTING. +C LUNIT = LOGICAL UNIT NUMBER FOR MESSAGES. +C THE DEFAULT IS 6 (MACHINE-DEPENDENT). +C 5. TO CHANGE THE DEFAULT OUTPUT UNIT, CHANGE THE DATA STATEMENT +C IN THE BLOCK DATA SUBPROGRAM BELOW. +C +C FOR A DIFFERENT RUN-ABORT COMMAND, CHANGE THE STATEMENT FOLLOWING +C STATEMENT 100 AT THE END. +C----------------------------------------------------------------------- + COMMON /EH0001/ MESFLG, LUNIT + IF (MESFLG .EQ. 0) GO TO 100 +C GET LOGICAL UNIT NUMBER. --------------------------------------------- + LUN = LUNIT +C WRITE THE MESSAGE. --------------------------------------------------- + WRITE (LUN, 10) MSG + 10 FORMAT(1X,A) +C----------------------------------------------------------------------- + IF (NI .EQ. 1) WRITE (LUN, 20) I1 + 20 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10) + IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2 + 30 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10,3X,'I2 = ',I10) + IF (NR .EQ. 1) WRITE (LUN, 40) R1 + 40 FORMAT(6X,'IN ABOVE MESSAGE, R1 = ',D21.13) + IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2 + 50 FORMAT(6X,'IN ABOVE, R1 = ',D21.13,3X,'R2 = ',D21.13) +C ABORT THE RUN IF IERT = 2. ------------------------------------------- + 100 IF (IERT .NE. 2) RETURN + STOP +C----------------------- END OF SUBROUTINE XERR ---------------------- + END + SUBROUTINE XSETF (MFLAG) +C +C THIS ROUTINE RESETS THE PRINT CONTROL FLAG MFLAG. +C + INTEGER MFLAG, MESFLG, LUNIT + COMMON /EH0001/ MESFLG, LUNIT +C + IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) MESFLG = MFLAG + RETURN +C----------------------- END OF SUBROUTINE XSETF ----------------------- + END + SUBROUTINE XSETUN (LUN) +C +C THIS ROUTINE RESETS THE LOGICAL UNIT NUMBER FOR MESSAGES. +C + INTEGER LUN, MESFLG, LUNIT + COMMON /EH0001/ MESFLG, LUNIT +C + IF (LUN .GT. 0) LUNIT = LUN + RETURN +C----------------------- END OF SUBROUTINE XSETUN ---------------------- + END + BLOCK DATA +C----------------------------------------------------------------------- +C THIS DATA SUBPROGRAM LOADS VARIABLES INTO THE INTERNAL COMMON +C BLOCKS USED BY ODESSA AND ITS VARIANTS. THE VARIABLES ARE +C DEFINED AS FOLLOWS.. +C ILLIN = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE +C WAS CALLED WITH ILLEGAL INPUT. THE RUN IS STOPPED WHEN +C ILLIN REACHES 5. +C NTREP = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE +C WAS CALLED WITH ISTATE = 1 AND TOUT = T. THE RUN IS +C STOPPED WHEN NTREP REACHES 5. +C MESFLG = FLAG TO CONTROL PRINTING OF ERROR MESSAGES. 1 MEANS PRINT, +C 0 MEANS NO PRINTING. +C LUNIT = DEFAULT VALUE OF LOGICAL UNIT NUMBER FOR PRINTING OF ERROR +C MESSAGES. +C----------------------------------------------------------------------- + INTEGER ILLIN, IDUMA, NTREP, IDUMB, IOWNS, ICOMM, MESFLG, LUNIT + DOUBLE PRECISION ROWND, ROWNS, RCOMM + COMMON /ODE001/ ROWND, ROWNS(173), RCOMM(45), + 1 ILLIN, IDUMA(10), NTREP, IDUMB(2), IOWNS(4), ICOMM(21) + COMMON /EH0001/ MESFLG, LUNIT + DATA ILLIN/0/, NTREP/0/ + DATA MESFLG/1/, LUNIT/6/ +C +C------------------------ END OF BLOCK DATA ---------------------------- + END +C----------------------------------------------------------------------- +C INSTRUCTIONS FOR INSTALLING THE ODESSA PACKAGE. (see @ below.) +C +C ODESSA is an enhanced version of the widely disseminated ODE solver +C LSODE, and as such retains the same properties regarding portability. +C The notes below, adapted from the installation instructions for LSODE, +C are intended to facilitate the installation of the ODESSA package in +C the user's software library. +C +C 1. Both a single and a double precision version of ODESSA are +C provided in this release. It is expected that most users will +C utilize the double precision version, except in the case of +C extended word-length computers. Most routines used by ODESSA +C are named the same regardless of whether they are single or +C double precision. The exceptions are the LINPAK and BLAS +C routines that follow the LINPAK/BLAS naming conventions, i.e. +C D--- for a double precision routine, and S--- for a single +C precision routine. Thus, care should be taken if both single +C and double precision versions are stored in the same library. +C +C 2. Several routines in ODESSA have the same names as the LSODE +C routines from which they were derived, although they contain +C different code. These are: INTDY, STODE, PREPJ, SVCOM, and +C RSCOM. If ODESSA is added to a subroutine library of which +C LSODE is already a member, these routine names must be changed +C in one of the two programs. Also see the note regarding BLOCK +C DATA subroutines below. +C +C 3. In many cases, ODESSA uses unaltered LSODE routines and +C common library routines that may already reside on your system. +C The installation of ODESSA should be done so that identical routines +C are shared rather than kept as duplicate copies. +C a. Normally, the user calls only subroutine ODESSA, but for optional +C capabilities the user may also CALL XSETUN, XSETF, SVCOM, RSCOM, +C or INTDY, as described in Part II of the Full Description in the +C User Documentation (ODESSA.DOC, see below). Except for INTDY, +C none of these are called from within the package. +C b. Two routines, EWSET and VNORM, are optionally replaceable by the +C user if the package version is unsuitable. Hence, the install- +C ation of the package should be done so that the user's version +C for either routine overrides the package version. +C c. The function routine D1MACH is provided to compute the unit +C roundoff of the machine and precision in use, in a manner com- +C patible with machine parameter routines developed at Bell Lab- +C oratories. If such a routine has already been installed on +C your system, the version supplied here may be discarded. +C d. Linear algebraic systems are solved with routines from the +C LINPACK collection, in conjunction with routines from the Basic +C Linear Algebra module collection (BLAS). In double precision, +C the names are DGEFA, DGESL, DGBFA, and DGBSL (from LINPACK), and +C DAXPY, DSCAL, IDAMAX, and DDOT (from BLAS). If these routines +C have already been installed on your system, copies supplied with +C ODESSA may be discarded. The single precision versions of these +C routines are used in the single precision version. +C +C 4. There are four integer variables, in the two labeled COMMON +C blocks /ODE001/ and /EH0001/, which need to be loaded with DATA +C statements. They can vary during execution, and are in common to +C assure their retention between calls. This is legal in ANSI Fortran +C only if done in a BLOCK DATA subprogram, and this package has a +C BLOCK DATA for this purpose. However, BLOCK DATA subprograms can be +C difficult to install in libraries, and many compilers allow such DATA +C statements in subroutines. If your system allows this, the location +C of the DATA statements are just after the initial type and common +C declarations in subroutines ODESSA and XERR. In ODESSA, ILLIN and +C NTREP are DATA-loaded as 0. In XERR, MESFLG is loaded as 1 and +C LUNIT is loaded as the appropriate default logical unit number. +C +C 5. The ODESSA package contains subscript expressions which may not +C be accepted by some compilers. Subscripts of the form I + J, I - J, +C etc., occur in various routines. If any of these forms are +C unacceptable to your compiler, an extra line of code setting the +C subscript to a dummy integer value should be added for each subscipt. +C +C 6. User documentation is provided in a two-level structure +C to accommmodate both the casual and serious user. The novice or +C casual user should need to read only the Summary of Usage and the +C Example Problem located at the beginning of the documentation. More +C experienced users, requiring the full set of available options, +C should read the Full Description which follows the Example Problem. +C +C 7. The user documentation may need corrections in the following ways: +C a. If subroutine names have been changed to avoid conflicts between +C the LSODE and ODESSA packages, the corresponding name changes +C should be made in the documentation. +C b. In the Summary of Usage, and in the description of XSETUN under +C Part II of the Full Description, the default logical unit number +C should be corrected if it is not 6. +C c. In the Summary of Usage, users should be instructed to execute +C CALL XSETF(1) before the first CALL to ODESSA, if this is neces- +C sary for proper error message handling. (see note 2(e) above.) +C d. In the description of the subroutines DF and JAC in the Summary +C of Usage and in Part I of the Full Description, it is stated +C that dummy names may be passed if these two routines are not user +C supplied. Your system may require the user to supply a dummy +C subroutine instead. +C e. The ODESSA package treats the arguments NEQ, RTOL, and ATOL as +C arrays (possibly of length 1), while the usage documentation +C states that these arguments may be either arrays or scalars. +C If your system does not allow such a mismatch, then the +C documentation should be changed to reflect this. +C 8. A demonstration program is provided with the package for +C verification. +C +C +C Jorge R. Leis and Mark A. Kramer +C Department of Chemical Engineering +C Massachusetts Institute of Technology +C Cambridge, Massachusetts 02139 +C U.S.A. +C +C Current address of J.R. Leis (Jan. 1988): +C +C Shell Development Company +C Westhollow Research Center +C Houston, TX +C +C @ Adapted from 'Instructions for Installing LSODE', written by +C Alan C. Hindmarsh, Mathematics & Statistics Division, L-316, +C Lawrence Livermore National Laboratory, Livermore, CA. 94550 diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.def new file mode 100755 index 00000000..7b3bb1a9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.def @@ -0,0 +1,19 @@ + +#FUNCTION AGGREGATE +#JACOBIAN FULL +#DOUBLE ON +#INTFILE atm_radau5 + +#INLINE F77_GLOBAL + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.f new file mode 100755 index 00000000..2b3a6042 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/atm_radau5.f @@ -0,0 +1,4572 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT, H + SAVE H + DATA H /0.0d0/ + INTEGER Nfun, Njac, Nstp, Nacc, Nrej, Ndec, Nsol + SAVE Nstp, Nacc, Nrej + DATA Nstp /0/ + DATA Nacc /0/ + DATA Nrej /0/ + INTEGER i + + PARAMETER (LWORK=5*NVAR*NVAR+12*NVAR+20,LIWORK=3*NVAR+20) + PARAMETER (LRCONT=4*NVAR+4) + + KPP_REAL WORK(LWORK), RPAR(1) + INTEGER IWORK(LIWORK), IPAR(1) + COMMON /CONT/ ICONT(4),RCONT(LRCONT) + EXTERNAL FUNC_CHEM,JAC_CHEM,SOLOUT + + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + MLMAS=NVAR ! --- JACOBIAN IS A FULL MATRIX + MUMAS=NVAR ! --- JACOBIAN IS A FULL MATRIX + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + + IWORK(3) = 8 ! Max no. of Newton iterations + IWORK(4) = 0 ! Starting values for Newton are interpolated (0) or zero (1) + IWORK(8) = 2 ! Gustaffson (1) or classic(2) controller + WORK(2) = 0.9 ! Safety factor + + CALL RADAU5(NVAR,FUNC_CHEM,TIN,VAR,TOUT,H, + & RTOL,ATOL,ITOL, + & JAC_CHEM ,IJAC,MLJAC,MUJAC, + & FUNC_CHEM ,IMAS,MLMAS,MUMAS, + & SOLOUT,IOUT, + & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) + + + Nfun = Nfun + IWORK(14) + Njac = Njac + IWORK(15) + Nstp = Nstp + IWORK(16) + Nacc = Nacc + IWORK(17) + Nrej = Nrej + IWORK(18) + Ndec = Ndec + IWORK(19) + Nsol = Nsol + IWORK(20) + + print("('Nstep=',I5,' Nacc=',I6,' Nrej=',I6)"),Nstp, Nacc, Nrej + + IF (IDID.LT.0) THEN + print *,'RADAU: Unsucessfull exit at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + RETURN + END + + + SUBROUTINE RADAU5(N,FCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC,MLJAC,MUJAC, + & MAS ,IMAS,MLMAS,MUMAS, + & SOLOUT,IOUT, + & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) +C ---------------------------------------------------------- +C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS +C M*Y'=F(X,Y). +C THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I) +C OR EXPLICIT (M=I). +C THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) +C OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. +C C.F. SECTION IV.8 +C +C AUTHORS: E. HAIRER AND G. WANNER +C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +C CH-1211 GENEVE 24, SWITZERLAND +C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +C +C THIS CODE IS PART OF THE BOOK: +C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, +C SPRINGER-VERLAG (1991) +C +C VERSION OF SEPTEMBER 30, 1995 +C +C INPUT PARAMETERS +C ---------------- +C N DIMENSION OF THE SYSTEM +C +C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE +C VALUE OF F(X,Y): +C SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR) +C KPP_REAL X,Y(N),F(N) +C F(1)=... ETC. +C RPAR, IPAR (SEE BELOW) +C +C X INITIAL X-VALUE +C +C Y(N) INITIAL VALUES FOR Y +C +C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) +C +C H INITIAL STEP SIZE GUESS; +C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, +C H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. +C THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS +C QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). +C +C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY +C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. +C +C ITOL SWITCH FOR RelTol AND AbsTol: +C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. +C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF +C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol +C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. +C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW +C RelTol(I)*ABS(Y(I))+AbsTol(I). +C +C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y +C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY +C A DUMMY SUBROUTINE IN THE CASE IJAC=0). +C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM +C SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR) +C KPP_REAL X,Y(N),DFY(LDFY,N) +C DFY(1,1)= ... +C LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS +C FURNISHED BY THE CALLING PROGRAM. +C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO +C BE FULL AND THE PARTIAL DERIVATIVES ARE +C STORED IN DFY AS +C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) +C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND +C THE PARTIAL DERIVATIVES ARE STORED +C DIAGONAL-WISE AS +C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). +C +C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: +C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE +C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. +C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. +C +C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: +C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C +C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLJAC=N. +C +C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- +C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - +C +C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- +C MATRIX M. +C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY +C MATRIX AND NEEDS NOT TO BE DEFINED; +C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. +C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM +C SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR) +C KPP_REAL AM(LMAS,N) +C AM(1,1)= .... +C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED +C AS FULL MATRIX LIKE +C AM(I,J) = M(I,J) +C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED +C DIAGONAL-WISE AS +C AM(I-J+MUMAS+1,J) = M(I,J). +C +C IMAS GIVES INFORMATION ON THE MASS-MATRIX: +C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY +C MATRIX, MAS IS NEVER CALLED. +C IMAS=1: MASS-MATRIX IS SUPPLIED. +C +C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: +C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C MLMAS IS SUPPOSED TO BE .LE. MLJAC. +C +C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLMAS=N. +C MUMAS IS SUPPOSED TO BE .LE. MUJAC. +C +C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE +C NUMERICAL SOLUTION DURING INTEGRATION. +C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. +C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. +C IT MUST HAVE THE FORM +C SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N, +C RPAR,IPAR,IRTRN) +C KPP_REAL X,Y(N),CONT(LRC) +C .... +C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH +C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS +C THE FIRST GRID-POINT). +C "XOLD" IS THE PRECEEDING GRID-POINT. +C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN +C IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM. +C +C ----- CONTINUOUS OUTPUT: ----- +C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION +C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH +C THE FUNCTION +C >>> CONTR5(I,S,CONT,LRC) <<< +C WHICH PROVIDES AN APPROXIMATION TO THE I-TH +C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE +C S SHOULD LIE IN THE INTERVAL [XOLD,X]. +C DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE +C DENSE OUTPUT FUNCTION IS USED. +C +C IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT: +C IOUT=0: SUBROUTINE IS NEVER CALLED +C IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT. +C +C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". +C WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS +C FOR THE CODE. FOR STANDARD USE OF THE CODE +C WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE +C CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE. +C WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE +C FOR ALL VECTORS AND MATRICES. +C "LWORK" MUST BE AT LEAST +C N*(LJAC+LMAS+3*LE+12)+20 +C WHERE +C LJAC=N IF MLJAC=N (FULL JACOBIAN) +C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST +C N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20 +C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE +C NUMBER N CAN BE REPLACED BY N-M1. +C +C LWORK DECLARED LENGTH OF ARRAY "WORK". +C +C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". +C IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS +C FOR THE CODE. FOR STANDARD USE, SET IWORK(1),.., +C IWORK(20) TO ZERO BEFORE CALLING. +C IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA. +C "LIWORK" MUST BE AT LEAST 3*N+20. +C +C LIWORK DECLARED LENGTH OF ARRAY "IWORK". +C +C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH +C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING +C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. +C +C ---------------------------------------------------------------------- +C +C SOPHISTICATED SETTING OF PARAMETERS +C ----------------------------------- +C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK +C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),... +C AS WELL AS IWORK(1),... DIFFERENT FROM ZERO. +C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: +C +C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN +C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY +C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. +C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC 1. +C THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT +C THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER. +C IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE +C MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2. +C +C IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR +C ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM. +C DEFAULT IWORK(5)=N. +C +C IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0. +C +C IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0. +C +C IWORK(8) SWITCH FOR STEP SIZE STRATEGY +C IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON) +C IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL +C THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1. +C THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS; +C FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES +C OFTEN SLIGHTLY FASTER RUNS +C +C IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT +C Y(I)' = Y(I+M2) FOR I=1,...,M1, +C WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME +C CAN BE ACHIEVED BY SETTING THE FOLLOWING TWO PARAMETERS. E.G., +C FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE +C VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2. +C FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: +C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE +C JACOBIAN HAVE TO BE STORED +C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL +C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) +C FOR I=1,N-M1 AND J=1,N. +C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) +C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) +C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. +C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL +C 0<=MLJAC= x) { + m = i+1; + break; + } + + /* Update T with time to next reaction */ + *T = *T - log(r2)/A[NREACT-1]; + + /* Update state vector after reaction m */ + MoleculeChange( m, NmlcV ); + + } /* for event */ + +} /* Gillespie */ diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.def new file mode 100755 index 00000000..f6b2a1a3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.def @@ -0,0 +1,10 @@ + +#FUNCTION aggregate +#JACOBIAN SPARSE_LU_ROW +#DOUBLE on +#STOCHASTIC on +#INTFILE gillespie + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.f90 new file mode 100755 index 00000000..025c905d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/gillespie.f90 @@ -0,0 +1,86 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Parameters, ONLY : NVAR, NFIX, NREACT + USE KPP_ROOT_Global, ONLY : TIME, RCONST, Volume + USE KPP_ROOT_Stoichiom + USE KPP_ROOT_Stochastic + USE KPP_ROOT_Rates + IMPLICIT NONE + +CONTAINS + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Gillespie(Nevents, T, SCT, NmlcV, NmlcF) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Gillespie stochastic integration +! INPUT: +! Nevents = no. of individual reaction events to be simulated +! SCT = stochastic rate constants +! T = time +! NmlcV, NmlcF = no. of molecules for variable and fixed species +! OUTPUT: +! T = updated time (after Nevents reactions) +! NmlcV = updated no. of molecules for variable species +! +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + KPP_REAL:: T + INTEGER :: Nevents + INTEGER :: NmlcV(NVAR), NmlcF(NFIX) + INTEGER :: i, m, issa + REAL :: r1, r2 + KPP_REAL :: A(NREACT), SCT(NREACT), x + + DO issa = 1, Nevents + + ! Uniformly distributed random numbers + CALL RANDOM_NUMBER(r1) + CALL RANDOM_NUMBER(r2) + ! Avoid log of zero + r2 = MAX(r2,1.e-14) + + ! Propensity vector + CALL Propensity ( NmlcV, NmlcF, SCT, A ) + ! Cumulative sum of propensities + DO i = 2, NREACT + A(i) = A(i-1)+A(i); + END DO + + ! Index of next reaction + x = r1*A(NREACT) + DO i = 1, NREACT + IF (A(i)>=x) THEN + m = i; + EXIT + END IF + END DO + + ! Update time with time to next reaction + T = T - LOG(r2)/A(NREACT); + + ! Update state vector + CALL MoleculeChange( m, NmlcV ) + + END DO + + CONTAINS + + SUBROUTINE PropensityTemplate( T, NmlcV, NmlcF, Prop ) + KPP_REAL, INTENT(IN) :: T + INTEGER, INTENT(IN) :: NmlcV(NVAR), NmlcF(NFIX) + KPP_REAL, INTENT(OUT) :: Prop(NREACT) + KPP_REAL :: Tsave, SCT(NREACT) + ! Update the stochastic reaction rates, which may be time dependent + Tsave = TIME + TIME = T + CALL Update_RCONST() + CALL StochasticRates( RCONST, Volume, SCT ) + CALL Propensity ( NmlcV, NmlcF, SCT, Prop ) + TIME = Tsave + END SUBROUTINE PropensityTemplate + + END SUBROUTINE Gillespie + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.def new file mode 100755 index 00000000..12804bc1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.def @@ -0,0 +1,14 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_dvode + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.f new file mode 100755 index 00000000..e1205430 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_dvode.f @@ -0,0 +1,3850 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + + PARAMETER (LRW=2*NVAR*NVAR+9*NVAR+25,LIW=NVAR+35) + PARAMETER (LRCONT=4*NVAR+4+10) + COMMON /CONT/ICONT(4),RCONT(LRCONT) + COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL + COMMON /VERWER/ IVERWER, IBEGIN, STEPCUT + EXTERNAL VODE_FSPLIT_VAR, VODE_Jac_SP + + KPP_REAL RWORK(LRW) + INTEGER IWORK(LIW) + + STEPCUT = 0. + MAXORD = 5 + IBEGIN = 1 + ITOL=4 + +C ---- NORMAL COMPUTATION --- + ITASK=1 + ISTATE=1 +C ---- USE OPTIONAL INPUT --- + IOPT=1 + IWORK(5) = MAXORD ! MAX ORD + IWORK(6) = 20000 + IWORK(7) = 0 + RWORK(6) = STEPMAX ! STEP MAX + RWORK(7) = STEPMIN ! STEP MIN + RWORK(5) = STEPMIN ! INITIAL STEP + +C ----- SIGNAL FOR STIFF CASE, FULL JACOBIAN, INTERN (22) or SUPPLIED (21) + MF = 21 + + CALL DVODE (VODE_FSPLIT_VAR, NVAR, VAR, TIN, TOUT, ITOL, + * RTOL, ATOL, ITASK, + * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, + * VODE_Jac_SP, MF, RPAR, IPAR) + + IF (ISTATE.LT.0) THEN + print *,'ATMDVODE: Unsucessfull exit at T=', + & TIN,' (ISTATE=',ISTATE,')' + ENDIF + + RETURN + END + + +C -- This version has JAC sparse, FCN aggregate -- + + SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, + 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, + 2 RPAR, IPAR) + + KPP_REAL Y, T, TOUT, RelTol, AbsTol, RWORK, RPAR + INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, + 1 MF, IPAR + DIMENSION Y(*), RelTol(*), AbsTol(*), RWORK(LRW), IWORK(LIW), + 1 RPAR(*), IPAR(*) +C----------------------------------------------------------------------- +C DVODE.. Variable-coefficient Ordinary Differential Equation solver, +C with fixed-leading coefficient implementation. +C This version is in KPP_REAL. +C +C DVODE solves the initial value problem for stiff or nonstiff +C systems of first order ODEs, +C dy/dt = f(t,y) , or, in component form, +C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). +C DVODE is a package based on the EPISODE and EPISODEB packages, and +C on the ODEPACK user interface standard, with minor modifications. +C----------------------------------------------------------------------- +C Revision History (YYMMDD) +C 890615 Date Written +C 890922 Added interrupt/restart ability, minor changes throughout. +C 910228 Minor revisions in line format, prologue, etc. +C 920227 Modifications by D. Pang: +C (1) Applied subgennam to get generic intrinsic names. +C (2) Changed intrinsic names to generic in comments. +C (3) Added *DECK lines before each routine. +C 920721 Names of routines and labeled Common blocks changed, so as +C to be unique in combined single/KPP_REAL code (ACH). +C 920722 Minor revisions to prologue (ACH). +C 920831 Conversion to KPP_REAL done (ACH). +C----------------------------------------------------------------------- +C References.. +C +C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable +C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), +C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. +C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the +C Numerical Solution of Ordinary Differential Equations," +C ACM Trans. Math. Software, 1 (1975), pp. 71-96. +C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package +C for the Integration of Systems of Ordinary Differential +C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. +C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental +C Package for the Integration of Systems of Ordinary Differential +C Equations with Banded Jacobians," LLNL Report UCID-30132, April +C 1976. +C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE +C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., +C North-Holland, Amsterdam, 1983, pp. 55-64. +C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation +C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM +C Trans. Math. Software, 6 (1980), pp. 295-318. +C----------------------------------------------------------------------- +C Authors.. +C +C Peter N. Brown and Alan C. Hindmarsh +C Computing and Mathematics Research Division, L-316 +C Lawrence Livermore National Laboratory +C Livermore, CA 94550 +C and +C George D. Byrne +C Exxon Research and Engineering Co. +C Clinton Township +C Route 22 East +C Annandale, NJ 08801 +C----------------------------------------------------------------------- +C Summary of usage. +C +C Communication between the user and the DVODE package, for normal +C situations, is summarized here. This summary describes only a subset +C of the full set of options available. See the full description for +C details, including optional communication, nonstandard options, +C and instructions for special situations. See also the example +C problem (with program and output) following this summary. +C +C A. First provide a subroutine of the form.. +C +C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) +C KPP_REAL T, Y, YDOT, RPAR +C DIMENSION Y(NEQ), YDOT(NEQ) +C +C which supplies the vector function f by loading YDOT(i) with f(i). +C +C B. Next determine (or guess) whether or not the problem is stiff. +C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue +C whose real part is negative and large in magnitude, compared to the +C reciprocal of the t span of interest. If the problem is nonstiff, +C use a method flag MF = 10. If it is stiff, there are four standard +C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian +C matrix in some form. In these cases (MF .gt. 0), DVODE will use a +C saved copy of the Jacobian matrix. If this is undesirable because of +C storage limitations, set MF to the corresponding negative value +C (-21, -22, -24, -25). (See full description of MF below.) +C The Jacobian matrix is regarded either as full (MF = 21 or 22), +C or banded (MF = 24 or 25). In the banded case, DVODE requires two +C half-bandwidth parameters ML and MU. These are, respectively, the +C widths of the lower and upper parts of the band, excluding the main +C diagonal. Thus the band consists of the locations (i,j) with +C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. +C +C C. If the problem is stiff, you are encouraged to supply the Jacobian +C directly (MF = 21 or 24), but if this is not feasible, DVODE will +C compute it internally by difference quotients (MF = 22 or 25). +C If you are supplying the Jacobian, provide a subroutine of the form.. +C +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) +C KPP_REAL T, Y, PD, RPAR +C DIMENSION Y(NEQ), PD(NROWPD,NEQ) +C +C which supplies df/dy by loading PD as follows.. +C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), +C the partial derivative of f(i) with respect to y(j). (Ignore the +C ML and MU arguments in this case.) +C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with +C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of +C PD from the top down. +C In either case, only nonzero elements need be loaded. +C +C D. Write a main program which calls subroutine DVODE once for +C each point at which answers are desired. This should also provide +C for possible use of logical unit 6 for output of error messages +C by DVODE. On the first CALL to DVODE, supply arguments as follows.. +C F = Name of subroutine for right-hand side vector f. +C This name must be declared external in calling program. +C NEQ = Number of first order ODE-s. +C Y = Array of initial values, of length NEQ. +C T = The initial value of the independent variable. +C TOUT = First point where output is desired (.ne. T). +C ITOL = 1 or 2 according as AbsTol (below) is a scalar or array. +C RelTol = Relative tolerance parameter (scalar). +C AbsTol = Absolute tolerance parameter (scalar or array). +C The estimated local error in Y(i) will be controlled so as +C to be roughly less (in magnitude) than +C EWT(i) = RelTol*abs(Y(i)) + AbsTol if ITOL = 1, or +C EWT(i) = RelTol*abs(Y(i)) + AbsTol(i) if ITOL = 2. +C Thus the local error test passes if, in each component, +C either the absolute error is less than AbsTol (or AbsTol(i)), +C or the relative error is less than RelTol. +C Use RelTol = 0.0 for pure absolute error control, and +C use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative error +C control. Caution.. Actual (global) errors may exceed these +C local tolerances, so choose them conservatively. +C ITASK = 1 for normal computation of output values of Y at t = TOUT. +C ISTATE = Integer flag (input and output). Set ISTATE = 1. +C IOPT = 0 to indicate no optional input used. +C RWORK = Real work array of length at least.. +C 20 + 16*NEQ for MF = 10, +C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, +C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. +C LRW = Declared length of RWORK (in user's DIMENSION statement). +C IWORK = Integer work array of length at least.. +C 30 for MF = 10, +C 30 + NEQ for MF = 21, 22, 24, or 25. +C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower +C and upper half-bandwidths ML,MU. +C LIW = Declared length of IWORK (in user's DIMENSION). +C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). +C If used, this name must be declared external in calling +C program. If not used, pass a dummy name. +C MF = Method flag. Standard values are.. +C 10 for nonstiff (Adams) method, no Jacobian used. +C 21 for stiff (BDF) method, user-supplied full Jacobian. +C 22 for stiff method, internally generated full Jacobian. +C 24 for stiff method, user-supplied banded Jacobian. +C 25 for stiff method, internally generated banded Jacobian. +C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. +C Note that the main program must declare arrays Y, RWORK, IWORK, +C and possibly AbsTol, RPAR, and IPAR. +C +C E. The output from the first CALL (or any call) is.. +C Y = Array of computed values of y(t) vector. +C T = Corresponding value of independent variable (normally TOUT). +C ISTATE = 2 if DVODE was successful, negative otherwise. +C -1 means excess work done on this call. (Perhaps wrong MF.) +C -2 means excess accuracy requested. (Tolerances too small.) +C -3 means illegal input detected. (See printed message.) +C -4 means repeated error test failures. (Check all input.) +C -5 means repeated convergence failures. (Perhaps bad +C Jacobian supplied or wrong choice of MF or tolerances.) +C -6 means error weight became zero during problem. (Solution +C component i vanished, and AbsTol or AbsTol(i) = 0.) +C +C F. To continue the integration after a successful return, simply +C reset TOUT and CALL DVODE again. No other parameters need be reset. +C +C----------------------------------------------------------------------- +C EXAMPLE PROBLEM +C +C The following is a simple example problem, with the coding +C needed for its solution by DVODE. The problem is from chemical +C kinetics, and consists of the following three rate equations.. +C dy1/dt = -.04*y1 + 1.e4*y2*y3 +C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 +C dy3/dt = 3.e7*y2**2 +C on the interval from t = 0.0 to t = 4.e10, with initial conditions +C y1 = 1.0, y2 = y3 = 0. The problem is stiff. +C +C The following coding solves this problem with DVODE, using MF = 21 +C and printing results at t = .4, 4., ..., 4.e10. It uses +C ITOL = 2 and AbsTol much smaller for y2 than y1 or y3 because +C y2 has much smaller values. +C At the end of the run, statistical quantities of interest are +C printed. (See optional output in the full description below.) +C To generate Fortran source code, replace C in column 1 with a blank +C in the coding below. +C +C EXTERNAL FEX, JEX +C KPP_REAL AbsTol, RPAR, RelTol, RWORK, T, TOUT, Y +C DIMENSION Y(3), AbsTol(3), RWORK(67), IWORK(33) +C NEQ = 3 +C Y(1) = 1.0D0 +C Y(2) = 0.0D0 +C Y(3) = 0.0D0 +C T = 0.0D0 +C TOUT = 0.4D0 +C ITOL = 2 +C RelTol = 1.D-4 +C AbsTol(1) = 1.D-8 +C AbsTol(2) = 1.D-14 +C AbsTol(3) = 1.D-6 +C ITASK = 1 +C ISTATE = 1 +C IOPT = 0 +C LRW = 67 +C LIW = 33 +C MF = 21 +C DO 40 IOUT = 1,12 +C CALL DVODE(FEX,NEQ,Y,T,TOUT,ITOL,RelTol,AbsTol,ITASK,ISTATE, +C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) +C WRITE(6,20)T,Y(1),Y(2),Y(3) +C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) +C IF (ISTATE .LT. 0) GO TO 80 +C 40 TOUT = TOUT*10. +C WRITE(6,60) IWORK(11),IWORK(12),IWORK(13),IWORK(19), +C 1 IWORK(20),IWORK(21),IWORK(22) +C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4, +C 1 ' No. J-s =',I4,' No. LU-s =',I4/ +C 2 ' No. nonlinear iterations =',I4/ +C 3 ' No. nonlinear convergence failures =',I4/ +C 4 ' No. error test failures =',I4/) +C STOP +C 80 WRITE(6,90)ISTATE +C 90 FORMAT(///' Error halt.. ISTATE =',I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) +C KPP_REAL RPAR, T, Y, YDOT +C DIMENSION Y(NEQ), YDOT(NEQ) +C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) +C YDOT(3) = 3.D7*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) +C KPP_REAL PD, RPAR, T, Y +C DIMENSION Y(NEQ), PD(NRPD,NEQ) +C PD(1,1) = -.04D0 +C PD(1,2) = 1.D4*Y(3) +C PD(1,3) = 1.D4*Y(2) +C PD(2,1) = .04D0 +C PD(2,3) = -PD(1,3) +C PD(3,2) = 6.D7*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C The following output was obtained from the above program on a +C Cray-1 computer with the CFT compiler. +C +C At t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 +C At t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 +C At t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 +C At t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 +C At t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 +C At t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 +C At t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 +C At t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 +C At t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 +C At t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 +C At t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 +C At t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 +C +C No. steps = 595 No. f-s = 832 No. J-s = 13 No. LU-s = 112 +C No. nonlinear iterations = 831 +C No. nonlinear convergence failures = 0 +C No. error test failures = 22 +C----------------------------------------------------------------------- +C Full description of user interface to DVODE. +C +C The user interface to DVODE consists of the following parts. +C +C i. The CALL sequence to subroutine DVODE, which is a driver +C routine for the solver. This includes descriptions of both +C the CALL sequence arguments and of user-supplied routines. +C Following these descriptions is +C * a description of optional input available through the +C CALL sequence, +C * a description of optional output (in the work arrays), and +C * instructions for interrupting and restarting a solution. +C +C ii. Descriptions of other routines in the DVODE package that may be +C (optionally) called by the user. These provide the ability to +C alter error message handling, save and restore the internal +C COMMON, and obtain specified derivatives of the solution y(t). +C +C iii. Descriptions of COMMON blocks to be declared in overlay +C or similar environments. +C +C iv. Description of two routines in the DVODE package, either of +C which the user may replace with his own version, if desired. +C these relate to the measurement of errors. +C +C----------------------------------------------------------------------- +C Part i. Call Sequence. +C +C The CALL sequence parameters used for input only are +C F, NEQ, TOUT, ITOL, RelTol, AbsTol, ITASK, IOPT, LRW, LIW, JAC, MF, +C and those used for both input and output are +C Y, T, ISTATE. +C The work arrays RWORK and IWORK are also used for conditional and +C optional input and optional output. (The term output here refers +C to the return from subroutine DVODE to the user's calling program.) +C +C The legality of input parameters will be thoroughly checked on the +C initial CALL for the problem, but not checked thereafter unless a +C change in input parameters is flagged by ISTATE = 3 in the input. +C +C The descriptions of the CALL arguments are as follows. +C +C F = The name of the user-supplied subroutine defining the +C ODE system. The system must be put in the first-order +C form dy/dt = f(t,y), where f is a vector-valued function +C of the scalar t and the vector y. Subroutine F is to +C compute the function f. It is to have the form +C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) +C KPP_REAL T, Y, YDOT, RPAR +C DIMENSION Y(NEQ), YDOT(NEQ) +C where NEQ, T, and Y are input, and the array YDOT = f(t,y) +C is output. Y and YDOT are arrays of length NEQ. +C (In the DIMENSION statement above, NEQ can be replaced by +C * to make Y and YDOT assumed size arrays.) +C Subroutine F should not alter Y(1),...,Y(NEQ). +C F must be declared EXTERNAL in the calling program. +C +C Subroutine F may access user-defined real and integer +C work arrays RPAR and IPAR, which are to be dimensioned +C in the main program. +C +C If quantities computed in the F routine are needed +C externally to DVODE, an extra CALL to F should be made +C for this purpose, for consistent and accurate results. +C If only the derivative dy/dt is needed, use DVINDY instead. +C +C NEQ = The size of the ODE system (number of first order +C ordinary differential equations). Used only for input. +C NEQ may not be increased during the problem, but +C can be decreased (with ISTATE = 3 in the input). +C +C Y = A real array for the vector of dependent variables, of +C length NEQ or more. Used for both input and output on the +C first CALL (ISTATE = 1), and only for output on other calls. +C On the first call, Y must contain the vector of initial +C values. In the output, Y contains the computed solution +C evaluated at T. If desired, the Y array may be used +C for other purposes between calls to the solver. +C +C This array is passed as the Y argument in all calls to +C F and JAC. +C +C T = The independent variable. In the input, T is used only on +C the first call, as the initial point of the integration. +C In the output, after each call, T is the value at which a +C computed solution Y is evaluated (usually the same as TOUT). +C On an error return, T is the farthest point reached. +C +C TOUT = The next value of t at which a computed solution is desired. +C Used only for input. +C +C When starting the problem (ISTATE = 1), TOUT may be equal +C to T for one call, then should .ne. T for the next call. +C For the initial T, an input value of TOUT .ne. T is used +C in order to determine the direction of the integration +C (i.e. the algebraic sign of the step sizes) and the rough +C scale of the problem. Integration in either direction +C (forward or backward in t) is permitted. +C +C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after +C the first CALL (i.e. the first CALL with TOUT .ne. T). +C Otherwise, TOUT is required on every call. +C +C If ITASK = 1, 3, or 4, the values of TOUT need not be +C monotone, but a value of TOUT which backs up is limited +C to the current internal t interval, whose endpoints are +C TCUR - HU and TCUR. (See optional output, below, for +C TCUR and HU.) +C +C ITOL = An indicator for the type of error control. See +C description below under AbsTol. Used only for input. +C +C RelTol = A relative error tolerance parameter, either a scalar or +C an array of length NEQ. See description below under AbsTol. +C Input only. +C +C AbsTol = An absolute error tolerance parameter, either a scalar or +C an array of length NEQ. Input only. +C +C The input parameters ITOL, RelTol, and AbsTol determine +C the error control performed by the solver. The solver will +C control the vector e = (e(i)) of estimated local errors +C in Y, according to an inequality of the form +C rms-norm of ( e(i)/EWT(i) ) .le. 1, +C where EWT(i) = RelTol(i)*abs(Y(i)) + AbsTol(i), +C and the rms-norm (root-mean-square norm) here is +C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) +C is a vector of weights which must always be positive, and +C the values of RelTol and AbsTol should all be non-negative. +C The following table gives the types (scalar/array) of +C RelTol and AbsTol, and the corresponding form of EWT(i). +C +C ITOL RelTol AbsTol EWT(i) +C 1 scalar scalar RelTol*ABS(Y(i)) + AbsTol +C 2 scalar array RelTol*ABS(Y(i)) + AbsTol(i) +C 3 array scalar RelTol(i)*ABS(Y(i)) + AbsTol +C 4 array array RelTol(i)*ABS(Y(i)) + AbsTol(i) +C +C When either of these parameters is a scalar, it need not +C be dimensioned in the user's calling program. +C +C If none of the above choices (with ITOL, RelTol, and AbsTol +C fixed throughout the problem) is suitable, more general +C error controls can be obtained by substituting +C user-supplied routines for the setting of EWT and/or for +C the norm calculation. See Part iv below. +C +C If global errors are to be estimated by making a repeated +C run on the same problem with smaller tolerances, then all +C components of RelTol and AbsTol (i.e. of EWT) should be scaled +C down uniformly. +C +C ITASK = An index specifying the task to be performed. +C Input only. ITASK has the following values and meanings. +C 1 means normal computation of output values of y(t) at +C t = TOUT (by overshooting and interpolating). +C 2 means take one step only and return. +C 3 means stop at the first internal mesh point at or +C beyond t = TOUT and return. +C 4 means normal computation of output values of y(t) at +C t = TOUT but without overshooting t = TCRIT. +C TCRIT must be input as RWORK(1). TCRIT may be equal to +C or beyond TOUT, but not behind it in the direction of +C integration. This option is useful if the problem +C has a singularity at or beyond t = TCRIT. +C 5 means take one step, without passing TCRIT, and return. +C TCRIT must be input as RWORK(1). +C +C Note.. If ITASK = 4 or 5 and the solver reaches TCRIT +C (within roundoff), it will return T = TCRIT (exactly) to +C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, +C in which case answers at T = TOUT are returned first). +C +C ISTATE = an index used for input and output to specify the +C the state of the calculation. +C +C In the input, the values of ISTATE are as follows. +C 1 means this is the first CALL for the problem +C (initializations will be done). See note below. +C 2 means this is not the first call, and the calculation +C is to continue normally, with no change in any input +C parameters except possibly TOUT and ITASK. +C (If ITOL, RelTol, and/or AbsTol are changed between calls +C with ISTATE = 2, the new values will be used but not +C tested for legality.) +C 3 means this is not the first call, and the +C calculation is to continue normally, but with +C a change in input parameters other than +C TOUT and ITASK. Changes are allowed in +C NEQ, ITOL, RelTol, AbsTol, IOPT, LRW, LIW, MF, ML, MU, +C and any of the optional input except H0. +C (See IWORK description for ML and MU.) +C Note.. A preliminary CALL with TOUT = T is not counted +C as a first CALL here, as no initialization or checking of +C input is done. (Such a CALL is sometimes useful to include +C the initial conditions in the output.) +C Thus the first CALL for which TOUT .ne. T requires +C ISTATE = 1 in the input. +C +C In the output, ISTATE has the following values and meanings. +C 1 means nothing was done, as TOUT was equal to T with +C ISTATE = 1 in the input. +C 2 means the integration was performed successfully. +C -1 means an excessive amount of work (more than MXSTEP +C steps) was done on this call, before completing the +C requested task, but the integration was otherwise +C successful as far as T. (MXSTEP is an optional input +C and is normally 500.) To continue, the user may +C simply reset ISTATE to a value .gt. 1 and CALL again. +C (The excess work step counter will be reset to 0.) +C In addition, the user may increase MXSTEP to avoid +C this error return. (See optional input below.) +C -2 means too much accuracy was requested for the precision +C of the machine being used. This was detected before +C completing the requested task, but the integration +C was successful as far as T. To continue, the tolerance +C parameters must be reset, and ISTATE must be set +C to 3. The optional output TOLSF may be used for this +C purpose. (Note.. If this condition is detected before +C taking any steps, then an illegal input return +C (ISTATE = -3) occurs instead.) +C -3 means illegal input was detected, before taking any +C integration steps. See written message for details. +C Note.. If the solver detects an infinite loop of calls +C to the solver with illegal input, it will cause +C the run to stop. +C -4 means there were repeated error test failures on +C one attempted step, before completing the requested +C task, but the integration was successful as far as T. +C The problem may have a singularity, or the input +C may be inappropriate. +C -5 means there were repeated convergence test failures on +C one attempted step, before completing the requested +C task, but the integration was successful as far as T. +C This may be caused by an inaccurate Jacobian matrix, +C if one is being used. +C -6 means EWT(i) became zero for some i during the +C integration. Pure relative error control (AbsTol(i)=0.0) +C was requested on a variable which has now vanished. +C The integration was successful as far as T. +C +C Note.. Since the normal output value of ISTATE is 2, +C it does not need to be reset for normal continuation. +C Also, since a negative input value of ISTATE will be +C regarded as illegal, a negative output value requires the +C user to change it, and possibly other input, before +C calling the solver again. +C +C IOPT = An integer flag to specify whether or not any optional +C input is being used on this call. Input only. +C The optional input is listed separately below. +C IOPT = 0 means no optional input is being used. +C Default values will be used in all cases. +C IOPT = 1 means optional input is being used. +C +C RWORK = A real working array (KPP_REAL). +C The length of RWORK must be at least +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where +C NYH = the initial value of NEQ, +C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a +C smaller value is given as an optional input), +C LWM = length of work space for matrix-related data.. +C LWM = 0 if MITER = 0, +C LWM = 2*NEQ**2 + 2 if MITER = 1 or 2, and MF.gt.0, +C LWM = NEQ**2 + 2 if MITER = 1 or 2, and MF.lt.0, +C LWM = NEQ + 2 if MITER = 3, +C LWM = (3*ML+2*MU+2)*NEQ + 2 if MITER = 4 or 5, and MF.gt.0, +C LWM = (2*ML+MU+1)*NEQ + 2 if MITER = 4 or 5, and MF.lt.0. +C (See the MF description for METH and MITER.) +C Thus if MAXORD has its default value and NEQ is constant, +C this length is.. +C 20 + 16*NEQ for MF = 10, +C 22 + 16*NEQ + 2*NEQ**2 for MF = 11 or 12, +C 22 + 16*NEQ + NEQ**2 for MF = -11 or -12, +C 22 + 17*NEQ for MF = 13, +C 22 + 18*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, +C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, +C 20 + 9*NEQ for MF = 20, +C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, +C 22 + 9*NEQ + NEQ**2 for MF = -21 or -22, +C 22 + 10*NEQ for MF = 23, +C 22 + 11*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. +C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. +C The first 20 words of RWORK are reserved for conditional +C and optional input and optional output. +C +C The following word in RWORK is a conditional input.. +C RWORK(1) = TCRIT = critical value of t which the solver +C is not to overshoot. Required if ITASK is +C 4 or 5, and ignored otherwise. (See ITASK.) +C +C LRW = The length of the array RWORK, as declared by the user. +C (This will be checked by the solver.) +C +C IWORK = An integer work array. The length of IWORK must be at least +C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or +C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). +C The first 30 words of IWORK are reserved for conditional and +C optional input and optional output. +C +C The following 2 words in IWORK are conditional input.. +C IWORK(1) = ML These are the lower and upper +C IWORK(2) = MU half-bandwidths, respectively, of the +C banded Jacobian, excluding the main diagonal. +C The band is defined by the matrix locations +C (i,j) with i-ML .le. j .le. i+MU. ML and MU +C must satisfy 0 .le. ML,MU .le. NEQ-1. +C These are required if MITER is 4 or 5, and +C ignored otherwise. ML and MU may in fact be +C the band parameters for a matrix to which +C df/dy is only approximately equal. +C +C LIW = the length of the array IWORK, as declared by the user. +C (This will be checked by the solver.) +C +C Note.. The work arrays must not be altered between calls to DVODE +C for the same problem, except possibly for the conditional and +C optional input, and except for the last 3*NEQ words of RWORK. +C The latter space is used for internal scratch space, and so is +C available for use by the user outside DVODE between calls, if +C desired (but not for use by F or JAC). +C +C JAC = The name of the user-supplied routine (MITER = 1 or 4) to +C compute the Jacobian matrix, df/dy, as a function of +C the scalar t and the vector y. It is to have the form +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, +C RPAR, IPAR) +C KPP_REAL T, Y, PD, RPAR +C DIMENSION Y(NEQ), PD(NROWPD, NEQ) +C where NEQ, T, Y, ML, MU, and NROWPD are input and the array +C PD is to be loaded with partial derivatives (elements of the +C Jacobian matrix) in the output. PD must be given a first +C dimension of NROWPD. T and Y have the same meaning as in +C Subroutine F. (In the DIMENSION statement above, NEQ can +C be replaced by * to make Y and PD assumed size arrays.) +C In the full matrix case (MITER = 1), ML and MU are +C ignored, and the Jacobian is to be loaded into PD in +C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). +C In the band matrix case (MITER = 4), the elements +C within the band are to be loaded into PD in columnwise +C manner, with diagonal lines of df/dy loaded into the rows +C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). +C ML and MU are the half-bandwidth parameters. (See IWORK). +C The locations in PD in the two triangular areas which +C correspond to nonexistent matrix elements can be ignored +C or loaded arbitrarily, as they are overwritten by DVODE. +C JAC need not provide df/dy exactly. A crude +C approximation (possibly with a smaller bandwidth) will do. +C In either case, PD is preset to zero by the solver, +C so that only the nonzero elements need be loaded by JAC. +C Each CALL to JAC is preceded by a CALL to F with the same +C arguments NEQ, T, and Y. Thus to gain some efficiency, +C intermediate quantities shared by both calculations may be +C saved in a user COMMON block by F and not recomputed by JAC, +C if desired. Also, JAC may alter the Y array, if desired. +C JAC must be declared external in the calling program. +C Subroutine JAC may access user-defined real and integer +C work arrays, RPAR and IPAR, whose dimensions are set by the +C user in the main program. +C +C MF = The method flag. Used only for input. The legal values of +C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, +C -11, -12, -14, -15, -21, -22, -24, -25. +C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). +C JSV = SIGN(MF) indicates the Jacobian-saving strategy.. +C JSV = 1 means a copy of the Jacobian is saved for reuse +C in the corrector iteration algorithm. +C JSV = -1 means a copy of the Jacobian is not saved +C (valid only for MITER = 1, 2, 4, or 5). +C METH indicates the basic linear multistep method.. +C METH = 1 means the implicit Adams method. +C METH = 2 means the method based on backward +C differentiation formulas (BDF-s). +C MITER indicates the corrector iteration method.. +C MITER = 0 means functional iteration (no Jacobian matrix +C is involved). +C MITER = 1 means chord iteration with a user-supplied +C full (NEQ by NEQ) Jacobian. +C MITER = 2 means chord iteration with an internally +C generated (difference quotient) full Jacobian +C (using NEQ extra calls to F per df/dy value). +C MITER = 3 means chord iteration with an internally +C generated diagonal Jacobian approximation +C (using 1 extra CALL to F per df/dy evaluation). +C MITER = 4 means chord iteration with a user-supplied +C banded Jacobian. +C MITER = 5 means chord iteration with an internally +C generated banded Jacobian (using ML+MU+1 extra +C calls to F per df/dy evaluation). +C If MITER = 1 or 4, the user must supply a subroutine JAC +C (the name is arbitrary) as described above under JAC. +C For other values of MITER, a dummy argument can be used. +C +C RPAR User-specified array used to communicate real parameters +C to user-supplied subroutines. If RPAR is a vector, then +C it must be dimensioned in the user's main program. If it +C is unused or it is a scalar, then it need not be +C dimensioned. +C +C IPAR User-specified array used to communicate integer parameter +C to user-supplied subroutines. The comments on dimensioning +C RPAR apply to IPAR. +C----------------------------------------------------------------------- +C Optional Input. +C +C The following is a list of the optional input provided for in the +C CALL sequence. (See also Part ii.) For each such input variable, +C this table lists its name as used in this documentation, its +C location in the CALL sequence, its meaning, and the default value. +C The use of any of this input requires IOPT = 1, and in that +C case all of this input is examined. A value of zero for any +C of these optional input variables will cause the default value to be +C used. Thus to use a subset of the optional input, simply preload +C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and +C then set those of interest to nonzero values. +C +C NAME LOCATION MEANING AND DEFAULT VALUE +C +C H0 RWORK(5) The step size to be attempted on the first step. +C The default value is determined by the solver. +C +C HMAX RWORK(6) The maximum absolute step size allowed. +C The default value is infinite. +C +C HMIN RWORK(7) The minimum absolute step size allowed. +C The default value is 0. (This lower bound is not +C enforced on the final step before reaching TCRIT +C when ITASK = 4 or 5.) +C +C MAXORD IWORK(5) The maximum order to be allowed. The default +C value is 12 if METH = 1, and 5 if METH = 2. +C If MAXORD exceeds the default value, it will +C be reduced to the default value. +C If MAXORD is changed during the problem, it may +C cause the current order to be reduced. +C +C MXSTEP IWORK(6) Maximum number of (internally defined) steps +C allowed during one CALL to the solver. +C The default value is 500. +C +C MXHNIL IWORK(7) Maximum number of messages printed (per problem) +C warning that T + H = T on a step (H = step size). +C This must be positive to result in a non-default +C value. The default value is 10. +C +C----------------------------------------------------------------------- +C Optional Output. +C +C As optional additional output from DVODE, the variables listed +C below are quantities related to the performance of DVODE +C which are available to the user. These are communicated by way of +C the work arrays, but also have internal mnemonic names as shown. +C Except where stated otherwise, all of this output is defined +C on any successful return from DVODE, and on any return with +C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return +C (ISTATE = -3), they will be unchanged from their existing values +C (if any), except possibly for TOLSF, LENRW, and LENIW. +C On any error return, output relevant to the error will be defined, +C as noted below. +C +C NAME LOCATION MEANING +C +C HU RWORK(11) The step size in t last used (successfully). +C +C HCUR RWORK(12) The step size to be attempted on the next step. +C +C TCUR RWORK(13) The current value of the independent variable +C which the solver has actually reached, i.e. the +C current internal mesh point in t. In the output, +C TCUR will always be at least as far from the +C initial value of t as the current argument T, +C but may be farther (if interpolation was done). +C +C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, +C computed when a request for too much accuracy was +C detected (ISTATE = -3 if detected at the start of +C the problem, ISTATE = -2 otherwise). If ITOL is +C left unaltered but RelTol and AbsTol are uniformly +C scaled up by a factor of TOLSF for the next call, +C then the solver is deemed likely to succeed. +C (The user may also ignore TOLSF and alter the +C tolerance parameters in any other way appropriate.) +C +C NST IWORK(11) The number of steps taken for the problem so far. +C +C NFE IWORK(12) The number of f evaluations for the problem so far. +C +C NJE IWORK(13) The number of Jacobian evaluations so far. +C +C NQU IWORK(14) The method order last used (successfully). +C +C NQCUR IWORK(15) The order to be attempted on the next step. +C +C IMXER IWORK(16) The index of the component of largest magnitude in +C the weighted local error vector ( e(i)/EWT(i) ), +C on an error return with ISTATE = -4 or -5. +C +C LENRW IWORK(17) The length of RWORK actually required. +C This is defined on normal returns and on an illegal +C input return for insufficient storage. +C +C LENIW IWORK(18) The length of IWORK actually required. +C This is defined on normal returns and on an illegal +C input return for insufficient storage. +C +C NLU IWORK(19) The number of matrix LU decompositions so far. +C +C NNI IWORK(20) The number of nonlinear (Newton) iterations so far. +C +C NCFN IWORK(21) The number of convergence failures of the nonlinear +C solver so far. +C +C NETF IWORK(22) The number of error test failures of the integrator +C so far. +C +C The following two arrays are segments of the RWORK array which +C may also be of interest to the user as optional output. +C For each array, the table below gives its internal name, +C its base address in RWORK, and its description. +C +C NAME BASE ADDRESS DESCRIPTION +C +C YH 21 The Nordsieck history array, of size NYH by +C (NQCUR + 1), where NYH is the initial value +C of NEQ. For j = 0,1,...,NQCUR, column j+1 +C of YH contains HCUR**j/factorial(j) times +C the j-th derivative of the interpolating +C polynomial currently representing the +C solution, evaluated at t = TCUR. +C +C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated +C corrections on each step, scaled in the output +C to represent the estimated local error in Y +C on the last step. This is the vector e in +C the description of the error control. It is +C defined only on a successful return from DVODE. +C +C----------------------------------------------------------------------- +C Interrupting and Restarting +C +C If the integration of a given problem by DVODE is to be +C interrupted and then later continued, such as when restarting +C an interrupted run or alternating between two or more ODE problems, +C the user should save, following the return from the last DVODE call +C prior to the interruption, the contents of the CALL sequence +C variables and internal COMMON blocks, and later restore these +C values before the next DVODE CALL for that problem. To save +C and restore the COMMON blocks, use subroutine DVSRCO, as +C described below in part ii. +C +C In addition, if non-default values for either LUN or MFLAG are +C desired, an extra CALL to XSETUN and/or XSETF should be made just +C before continuing the integration. See Part ii below for details. +C +C----------------------------------------------------------------------- +C Part ii. Other Routines Callable. +C +C The following are optional calls which the user may make to +C gain additional capabilities in conjunction with DVODE. +C (The routines XSETUN and XSETF are designed to conform to the +C SLATEC error handling package.) +C +C FORM OF CALL FUNCTION +C CALL XSETUN(LUN) Set the logical unit number, LUN, for +C output of messages from DVODE, if +C the default is not desired. +C The default value of LUN is 6. +C +C CALL XSETF(MFLAG) Set a flag to control the printing of +C messages by DVODE. +C MFLAG = 0 means do not print. (Danger.. +C This risks losing valuable information.) +C MFLAG = 1 means print (the default). +C +C Either of the above calls may be made at +C any time and will take effect immediately. +C +C CALL DVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of +C the internal COMMON blocks used by +C DVODE. (See Part iii below.) +C RSAV must be a real array of length 49 +C or more, and ISAV must be an integer +C array of length 40 or more. +C JOB=1 means save COMMON into RSAV/ISAV. +C JOB=2 means restore COMMON from RSAV/ISAV. +C DVSRCO is useful if one is +C interrupting a run and restarting +C later, or alternating between two or +C more problems solved with DVODE. +C +C CALL DVINDY(,,,,,) Provide derivatives of y, of various +C (See below.) orders, at a specified point T, if +C desired. It may be called only after +C a successful return from DVODE. +C +C The detailed instructions for using DVINDY are as follows. +C The form of the CALL is.. +C +C CALL DVINDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C The input parameters are.. +C +C T = Value of independent variable where answers are desired +C (normally the same as the T last returned by DVODE). +C For valid results, T must lie between TCUR - HU and TCUR. +C (See optional output for TCUR and HU.) +C K = Integer order of the derivative desired. K must satisfy +C 0 .le. K .le. NQCUR, where NQCUR is the current order +C (see optional output). The capability corresponding +C to K = 0, i.e. computing y(T), is already provided +C by DVODE directly. Since NQCUR .ge. 1, the first +C derivative dy/dt is always available with DVINDY. +C RWORK(21) = The base address of the history array YH. +C NYH = Column length of YH, equal to the initial value of NEQ. +C +C The output parameters are.. +C +C DKY = A real array of length NEQ containing the computed value +C of the K-th derivative of y(t). +C IFLAG = Integer flag, returned as 0 if K and T were legal, +C -1 if K was illegal, and -2 if T was illegal. +C On an error return, a message is also written. +C----------------------------------------------------------------------- +C Part iii. COMMON Blocks. +C If DVODE is to be used in an overlay situation, the user +C must declare, in the primary overlay, the variables in.. +C (1) the CALL sequence to DVODE, +C (2) the two internal COMMON blocks +C /DVOD01/ of length 81 (48 KPP_REAL words +C followed by 33 integer words), +C /DVOD02/ of length 9 (1 KPP_REAL word +C followed by 8 integer words), +C +C If DVODE is used on a system in which the contents of internal +C COMMON blocks are not preserved between calls, the user should +C declare the above two COMMON blocks in his main program to insure +C that their contents are preserved. +C +C----------------------------------------------------------------------- +C Part iv. Optionally Replaceable Solver Routines. +C +C Below are descriptions of two routines in the DVODE package which +C relate to the measurement of errors. Either routine can be +C replaced by a user-supplied version, if desired. However, since such +C a replacement may have a major impact on performance, it should be +C done only when absolutely necessary, and only with great caution. +C (Note.. The means by which the package version of a routine is +C superseded by the user's version may be system-dependent.) +C +C (a) DEWSET. +C The following subroutine is called just before each internal +C integration step, and sets the array of error weights, EWT, as +C described under ITOL/RelTol/AbsTol above.. +C SUBROUTINE DEWSET (NEQ, ITOL, RelTol, AbsTol, YCUR, EWT) +C where NEQ, ITOL, RelTol, and AbsTol are as in the DVODE CALL sequence, +C YCUR contains the current dependent variable vector, and +C EWT is the array of weights set by DEWSET. +C +C If the user supplies this subroutine, it must return in EWT(i) +C (i = 1,...,NEQ) a positive quantity suitable for comparison with +C errors in Y(i). The EWT array returned by DEWSET is passed to the +C DVNORM routine (See below.), and also used by DVODE in the computation +C of the optional output IMXER, the diagonal Jacobian approximation, +C and the increments for difference quotient Jacobians. +C +C In the user-supplied version of DEWSET, it may be desirable to use +C the current values of derivatives of y. Derivatives up to order NQ +C are available from the history array YH, described above under +C Optional Output. In DEWSET, YH is identical to the YCUR array, +C extended to NQ + 1 columns with a column length of NYH and scale +C factors of h**j/factorial(j). On the first CALL for the problem, +C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. +C NYH is the initial value of NEQ. The quantities NQ, H, and NST +C can be obtained by including in DEWSET the statements.. +C KPP_REAL RVOD, H, HU +C COMMON /DVOD01/ RVOD(48), IVOD(33) +C COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C NQ = IVOD(28) +C H = RVOD(21) +C Thus, for example, the current value of dy/dt can be obtained as +C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is +C unnecessary when NST = 0). +C +C (b) DVNORM. +C The following is a real function routine which computes the weighted +C root-mean-square norm of a vector v.. +C D = DVNORM (N, V, W) +C where.. +C N = the length of the vector, +C V = real array of length N containing the vector, +C W = real array of length N containing weights, +C D = sqrt( (1/N) * sum(V(i)*W(i))**2 ). +C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where +C EWT is as set by subroutine DEWSET. +C +C If the user supplies this function, it should return a non-negative +C value of DVNORM suitable for use in the error control in DVODE. +C None of the arguments should be altered by DVNORM. +C For example, a user-supplied DVNORM routine might.. +C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or +C -ignore some components of V in the norm, with the effect of +C suppressing the error control on those components of Y. +C----------------------------------------------------------------------- +C Other Routines in the DVODE Package. +C +C In addition to subroutine DVODE, the DVODE package includes the +C following subroutines and function routines.. +C DVHIN computes an approximate step size for the initial step. +C DVINDY computes an interpolated value of the y vector at t = TOUT. +C DVSTEP is the core integrator, which does one step of the +C integration and the associated error control. +C DVSET sets all method coefficients and test constants. +C DVNLSD solves the underlying nonlinear system -- the corrector. +C DVJAC computes and preprocesses the Jacobian matrix J = df/dy +C and the Newton iteration matrix P = I - (h/l1)*J. +C DVSOL manages solution of linear system in chord iteration. +C DVJUST adjusts the history array on a change of order. +C DEWSET sets the error weight vector EWT before each step. +C DVNORM computes the weighted r.m.s. norm of a vector. +C DVSRCO is a user-callable routines to save and restore +C the contents of the internal COMMON blocks. +C DACOPY is a routine to copy one two-dimensional array to another. +C DGEFA and DGESL are routines from LINPACK for solving full +C systems of linear algebraic equations. +C DGBFA and DGBSL are routines from LINPACK for solving banded +C linear systems. +C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). +C D1MACH sets the unit roundoff of the machine. +C XERRWD, XSETUN, XSETF, LUNSAV, and MFLGSV handle the printing of all +C error messages and warnings. XERRWD is machine-dependent. +C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. +C All the others are subroutines. +C +C The intrinsic and external routines used by the DVODE package are.. +C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. +C +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + KPP_REAL HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + EXTERNAL DVNLSD, F, JAC + LOGICAL IHIT + KPP_REAL AbsTolI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, + 1 PT2, RH, RelTolI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO + INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, + 1 LENWM, LF0, MBAND, ML, MORD, MU, MXHNL0, MXSTP0, NITER, NSLAST + CHARACTER*80 MSG +C +C Type declaration for function subroutines called --------------------- +C + KPP_REAL D1MACH, DVNORM +C + DIMENSION MORD(2) +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to DVODE. +C----------------------------------------------------------------------- + SAVE MORD, MXHNL0, MXSTP0 + SAVE ZERO, ONE, TWO, FOUR, PT2, HUN +C----------------------------------------------------------------------- +C The following internal COMMON blocks contain variables which are +C communicated between subroutines in the DVODE package, or which are +C to be saved between calls to DVODE. +C In each block, real variables precede integers. +C The block /DVOD01/ appears in subroutines DVODE, DVINDY, DVSTEP, +C DVSET, DVNLSD, DVJAC, DVSOL, DVJUST and DVSRCO. +C The block /DVOD02/ appears in subroutines DVODE, DVINDY, DVSTEP, +C DVNLSD, DVJAC, and DVSRCO. +C +C The variables stored in the internal COMMON blocks are as follows.. +C +C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. +C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) +C CONP = The saved value of TQ(5). +C CRATE = Estimated corrector convergence rate constant. +C DRC = Relative change in H*RL1 since last DVJAC call. +C EL = Real array of integration coefficients. See DVSET. +C ETA = Saved tentative ratio of new to old H. +C ETAMAX = Saved maximum value of ETA to be allowed. +C H = The step size. +C HMIN = The minimum absolute value of the step size H to be used. +C HMXI = Inverse of the maximum absolute value of H to be used. +C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. +C HNEW = The step size to be attempted on the next step. +C HSCAL = Stepsize in scaling of YH array. +C PRL1 = The saved value of RL1. +C RC = Ratio of current H*RL1 to value on last DVJAC call. +C RL1 = The reciprocal of the coefficient EL(1). +C TAU = Real vector of past NQ step sizes, length 13. +C TQ = A real vector of length 5 in which DVSET stores constants +C used for the convergence test, the error test, and the +C selection of H at a new order. +C TN = The independent variable, updated on each step taken. +C UROUND = The machine unit roundoff. The smallest positive real number +C such that 1.0 + UROUND .ne. 1.0 +C ICF = Integer flag for convergence failure in DVNLSD.. +C 0 means no failures. +C 1 means convergence failure with out of date Jacobian +C (recoverable error). +C 2 means convergence failure with current Jacobian or +C singular matrix (unrecoverable error). +C INIT = Saved integer flag indicating whether initialization of the +C problem has been done (INIT = 1) or not. +C IPUP = Saved flag to signal updating of Newton matrix. +C JCUR = Output flag from DVJAC showing Jacobian status.. +C JCUR = 0 means J is not current. +C JCUR = 1 means J is current. +C JSTART = Integer flag used as input to DVSTEP.. +C 0 means perform the first step. +C 1 means take a new step continuing from the last. +C -1 means take the next step with a new value of MAXORD, +C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. +C On return, DVSTEP sets JSTART = 1. +C JSV = Integer flag for Jacobian saving, = sign(MF). +C KFLAG = A completion code from DVSTEP with the following meanings.. +C 0 the step was succesful. +C -1 the requested error could not be achieved. +C -2 corrector convergence could not be achieved. +C -3, -4 fatal error in VNLS (can not occur here). +C KUTH = Input flag to DVSTEP showing whether H was reduced by the +C driver. KUTH = 1 if H was reduced, = 0 otherwise. +C L = Integer variable, NQ + 1, current order plus one. +C LMAX = MAXORD + 1 (used for dimensioning). +C LOCJS = A pointer to the saved Jacobian, whose storage starts at +C WM(LOCJS), if JSV = 1. +C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers +C to segments of RWORK and IWORK. +C MAXORD = The maximum order of integration method to be allowed. +C METH/MITER = The method flags. See MF. +C MSBJ = The maximum number of steps between J evaluations, = 50. +C MXHNIL = Saved value of optional input MXHNIL. +C MXSTEP = Saved value of optional input MXSTEP. +C N = The number of first-order ODEs, = NEQ. +C NEWH = Saved integer to flag change of H. +C NEWQ = The method order to be used on the next step. +C NHNIL = Saved counter for occurrences of T + H = T. +C NQ = Integer variable, the current integration method order. +C NQNYH = Saved value of NQ*NYH. +C NQWAIT = A counter controlling the frequency of order changes. +C An order change is about to be considered if NQWAIT = 1. +C NSLJ = The number of steps taken as of the last Jacobian update. +C NSLP = Saved value of NST as of last Newton matrix update. +C NYH = Saved value of the initial value of NEQ. +C HU = The step size in t last used. +C NCFN = Number of nonlinear convergence failures so far. +C NETF = The number of error test failures of the integrator so far. +C NFE = The number of f evaluations for the problem so far. +C NJE = The number of Jacobian evaluations so far. +C NLU = The number of matrix LU decompositions so far. +C NNI = Number of nonlinear iterations so far. +C NQU = The method order last used. +C NST = The number of steps taken for the problem so far. +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + + DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ + DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, + 1 PT2 /0.2D0/, HUN /100.0D0/ +C----------------------------------------------------------------------- +C Block A. +C This code block is executed on every call. +C It tests ISTATE and ITASK for legality and branches appropriately. +C If ISTATE .gt. 1 but the flag INIT shows that initialization has +C not yet been done, an error return occurs. +C If ISTATE = 1 and TOUT = T, return immediately. +C----------------------------------------------------------------------- + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .NE. 1) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) RETURN +C----------------------------------------------------------------------- +C Block B. +C The next code block is executed for the initial CALL (ISTATE = 1), +C or for a continuation CALL with parameter changes (ISTATE = 3). +C It contains checking of all input and various initializations. +C +C First check legality of the non-optional input NEQ, ITOL, IOPT, +C MF, ML, and MU. +C----------------------------------------------------------------------- + 20 IF (NEQ .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ .GT. N) GO TO 605 + 25 N = NEQ + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 + JSV = SIGN(1,MF) + MF = ABS(MF) + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 CONTINUE +C Next process and check the optional input. --------------------------- + IF (IOPT .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = ZERO + HMXI = ZERO + HMIN = ZERO + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. ZERO) GO TO 615 + HMXI = ZERO + IF (HMAX .GT. ZERO) HMXI = ONE/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. ZERO) GO TO 616 +C----------------------------------------------------------------------- +C Set work array pointers and check lengths LRW and LIW. +C Pointers to segments of RWORK and IWORK are named by prefixing L to +C the name of the segment. E.g., the segment YH starts at RWORK(LYH). +C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. +C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). +C----------------------------------------------------------------------- + 60 LYH = 21 + IF (ISTATE .EQ. 1) NYH = N + LWM = LYH + (MAXORD + 1)*NYH + JCO = MAX(0,JSV) + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN + LENWM = 2 + (1 + JCO)*N*N + LOCJS = N*N + 3 + ENDIF + IF (MITER .EQ. 3) LENWM = 2 + N + IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN + MBAND = ML + MU + 1 + LENP = (MBAND + ML)*N + LENJ = MBAND*N + LENWM = 2 + LENP + JCO*LENJ + LOCJS = LENP + 3 + ENDIF + LEWT = LWM + LENWM + LSAVF = LEWT + N + LACOR = LSAVF + N + LENRW = LACOR + N - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 30 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C Check RelTol and AbsTol for legality. ------------------------------------ + RelTolI = RelTol(1) + AbsTolI = AbsTol(1) + DO 70 I = 1,N + IF (ITOL .GE. 3) RelTolI = RelTol(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) + IF (RelTolI .LT. ZERO) GO TO 619 + IF (AbsTolI .LT. ZERO) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- + CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) +C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) +C----------------------------------------------------------------------- +C Block C. +C The next block is for the initial CALL only (ISTATE = 1). +C It contains all remaining initializations, the initial CALL to F, +C and the calculation of the initial step size. +C The error weights in EWT are inverted after being loaded. +C----------------------------------------------------------------------- + 100 UROUND = D1MACH(4) + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 + IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) + 1 H0 = TCRIT - T + 110 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + CCMXJ = PT2 + MSBJ = 50 + NHNIL = 0 + NST = 0 + NJE = 0 + NNI = 0 + NCFN = 0 + NETF = 0 + NLU = 0 + NSLJ = 0 + NSLAST = 0 + HU = ZERO + NQU = 0 +C Initial CALL to F. (LF0 points to YH(*,2).) ------------------------- + LF0 = LYH + NYH + CALL F (N, T, Y, RWORK(LF0)) + NFE = 1 +C Load the initial value vector in YH. --------------------------------- + CALL DCOPY (N, Y, 1, RWORK(LYH), 1) +C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- + NQ = 1 + H = ONE + CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,N + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 + 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + IF (H0 .NE. ZERO) GO TO 180 +C Call DVHIN to set initial step size H0 to be attempted. -------------- + CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, + 1 UROUND, RWORK(LEWT), ITOL, AbsTol, Y, RWORK(LACOR), H0, + 2 NITER, IER) + NFE = NFE + NITER + IF (IER .NE. 0) GO TO 622 +C Adjust H0 if necessary to meet HMAX bound. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. ONE) H0 = H0/RH +C Load H with H0 and scale YH(*,2) by H0. ------------------------------ + H = H0 + CALL DSCAL (N, H0, RWORK(LF0), 1) + GO TO 270 +C----------------------------------------------------------------------- +C Block D. +C The next code block is for continuation calls only (ISTATE = 2 or 3) +C and is to check stop conditions before taking a step. +C----------------------------------------------------------------------- + 200 NSLAST = NST + KUTH = 0 + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(ONE + HUN*UROUND) + IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + HNEW*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + KUTH = 1 +C----------------------------------------------------------------------- +C Block E. +C The next block is normally executed for all calls and contains +C the CALL to the one-step core integrator DVSTEP. +C +C This is a looping point for the integration steps. +C +C First check for too many steps being taken, update EWT (if not at +C start of problem), check for too much accuracy being requested, and +C check for H below the roundoff level in T. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,N + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 + 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. ONE) GO TO 280 + TOLSF = TOLSF*TWO + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF ((TN + H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + MSG = 'DVODE-- Warning..internal T (=R1) and H (=R2) are' + CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG=' such that in the machine, T + H = T on the next step ' + CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' (H = step size). solver will continue anyway' + CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + MSG = 'DVODE-- Above warning has been issued I1 times. ' + CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' it will not be issued again for this problem' + CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, +C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) +C----------------------------------------------------------------------- + CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), + 1 RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), + 2 F, JAC, F, DVNLSD, RPAR, IPAR) + KGO = 1 - KFLAG +C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. +C KFLAG .eq. 0, -1, -2 + GO TO (300, 530, 540), KGO +C----------------------------------------------------------------------- +C Block F. +C The following block handles the case of a successful return from the +C core integrator (KFLAG = 0). Test for stop conditions. +C----------------------------------------------------------------------- + 300 INIT = 1 + KUTH = 0 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. If TOUT has been reached, interpolate. ------------------- + 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ + 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 + GO TO 250 +C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. + 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + HNEW*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + KUTH = 1 + GO TO 250 +C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX +C----------------------------------------------------------------------- +C Block G. +C The following block handles all successful returns from DVODE. +C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. +C ISTATE is set to 2, and the optional output is loaded into the work +C arrays before returning. +C----------------------------------------------------------------------- + 400 CONTINUE + CALL DCOPY (N, RWORK(LYH), 1, Y, 1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + RWORK(11) = HU + RWORK(12) = HNEW + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NEWQ + IWORK(19) = NLU + IWORK(20) = NNI + IWORK(21) = NCFN + IWORK(22) = NETF + RETURN +C----------------------------------------------------------------------- +C Block H. +C The following block handles all unsuccessful returns other than +C those for illegal input. First the error message routine is called. +C if there was an error test or convergence test failure, IMXER is set. +C Then Y is loaded from YH, T is set to TN, and the illegal input +C The optional output is loaded into the work arrays before returning. +C----------------------------------------------------------------------- +C The maximum number of steps was taken before reaching TOUT. ---------- + 500 MSG = 'DVODE-- At current T (=R1), MXSTEP (=I1) steps ' + CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' taken on this CALL before reaching TOUT ' + CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) + ISTATE = -1 + GO TO 580 +C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + MSG = 'DVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' + CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C Too much accuracy requested for machine precision. ------------------- + 520 MSG = 'DVODE-- At T (=R1), too much accuracy requested ' + CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' for precision of machine.. see TOLSF (=R2) ' + CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- + 530 MSG = 'DVODE-- At T(=R1) and step size H(=R2), the error' + CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' test failed repeatedly or with abs(H) = HMIN' + CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- + 540 MSG = 'DVODE-- At T (=R1) and step size H (=R2), the ' + CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' corrector convergence failed repeatedly ' + CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' or with abs(H) = HMIN ' + CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C Compute IMXER if relevant. ------------------------------------------- + 560 BIG = ZERO + IMXER = 1 + DO 570 I = 1,N + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C Set Y vector, T, and optional output. -------------------------------- + 580 CONTINUE + CALL DCOPY (N, RWORK(LYH), 1, Y, 1) + T = TN + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IWORK(19) = NLU + IWORK(20) = NNI + IWORK(21) = NCFN + IWORK(22) = NETF + RETURN +C----------------------------------------------------------------------- +C Block I. +C The following block handles all error returns due to illegal input +C (ISTATE = -3), as detected before calling the core integrator. +C First the error message routine is called. If the illegal input +C is a negative ISTATE, the run is aborted (apparent infinite loop). +C----------------------------------------------------------------------- + 601 MSG = 'DVODE-- ISTATE (=I1) illegal ' + CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) + IF (ISTATE .LT. 0) GO TO 800 + GO TO 700 + 602 MSG = 'DVODE-- ITASK (=I1) illegal ' + CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) + GO TO 700 + 603 MSG='DVODE-- ISTATE (=I1) .gt. 1 but DVODE not initialized ' + CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) + GO TO 700 + 604 MSG = 'DVODE-- NEQ (=I1) .lt. 1 ' + CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) + GO TO 700 + 605 MSG = 'DVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' + CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) + GO TO 700 + 606 MSG = 'DVODE-- ITOL (=I1) illegal ' + CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) + GO TO 700 + 607 MSG = 'DVODE-- IOPT (=I1) illegal ' + CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) + GO TO 700 + 608 MSG = 'DVODE-- MF (=I1) illegal ' + CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) + GO TO 700 + 609 MSG = 'DVODE-- ML (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' + CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) + GO TO 700 + 610 MSG = 'DVODE-- MU (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' + CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) + GO TO 700 + 611 MSG = 'DVODE-- MAXORD (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) + GO TO 700 + 612 MSG = 'DVODE-- MXSTEP (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) + GO TO 700 + 613 MSG = 'DVODE-- MXHNIL (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) + GO TO 700 + 614 MSG = 'DVODE-- TOUT (=R1) behind T (=R2) ' + CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) + MSG = ' integration direction is given by H0 (=R1) ' + CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) + GO TO 700 + 615 MSG = 'DVODE-- HMAX (=R1) .lt. 0.0 ' + CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) + GO TO 700 + 616 MSG = 'DVODE-- HMIN (=R1) .lt. 0.0 ' + CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) + GO TO 700 + 617 CONTINUE + MSG='DVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' + CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) + GO TO 700 + 618 CONTINUE + MSG='DVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' + CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) + GO TO 700 + 619 MSG = 'DVODE-- RelTol(I1) is R1 .lt. 0.0 ' + CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RelTolI, ZERO) + GO TO 700 + 620 MSG = 'DVODE-- AbsTol(I1) is R1 .lt. 0.0 ' + CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, AbsTolI, ZERO) + GO TO 700 + 621 EWTI = RWORK(LEWT+I-1) + MSG = 'DVODE-- EWT(I1) is R1 .le. 0.0 ' + CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) + GO TO 700 + 622 CONTINUE + MSG='DVODE-- TOUT (=R1) too close to T(=R2) to start integration' + CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CONTINUE + MSG='DVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' + CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CONTINUE + MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' + CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CONTINUE + MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' + CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 MSG = 'DVODE-- At start of problem, too much accuracy ' + CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG=' requested for precision of machine.. see TOLSF (=R1) ' + CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) + RWORK(14) = TOLSF + GO TO 700 + 627 MSG='DVODE-- Trouble from DVINDY. ITASK = I1, TOUT = R1. ' + CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) +C + 700 CONTINUE + ISTATE = -3 + RETURN +C + 800 MSG = 'DVODE-- Run aborted.. apparent infinite loop ' + CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) + RETURN +C----------------------- End of Subroutine DVODE ----------------------- + END +*DECK DVHIN + SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, + 1 EWT, ITOL, AbsTol, Y, TEMP, H0, NITER, IER) + EXTERNAL F + KPP_REAL T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, AbsTol, Y, + 1 TEMP, H0 + INTEGER N, IPAR, ITOL, NITER, IER + DIMENSION Y0(*), YDOT(*), EWT(*), AbsTol(*), Y(*), + 1 TEMP(*), RPAR(*), IPAR(*) +C----------------------------------------------------------------------- +C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, +C EWT, ITOL, AbsTol, Y, TEMP +C Call sequence output -- H0, NITER, IER +C COMMON block variables accessed -- None +C +C Subroutines called by DVHIN.. F +C Function routines called by DVHIN.. DVNORM +C----------------------------------------------------------------------- +C This routine computes the step size, H0, to be attempted on the +C first step, when the user has not supplied a value for this. +C +C First we check that TOUT - T0 differs significantly from zero. Then +C an iteration is done to approximate the initial second derivative +C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. +C A bias factor of 1/2 is applied to the resulting h. +C The sign of H0 is inferred from the initial values of TOUT and T0. +C +C Communication with DVHIN is done with the following variables.. +C +C N = Size of ODE system, input. +C T0 = Initial value of independent variable, input. +C Y0 = Vector of initial conditions, input. +C YDOT = Vector of initial first derivatives, input. +C F = Name of subroutine for right-hand side f(t,y), input. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C TOUT = First output value of independent variable +C UROUND = Machine unit roundoff +C EWT, ITOL, AbsTol = Error weights and tolerance parameters +C as described in the driver routine, input. +C Y, TEMP = Work arrays of length N. +C H0 = Step size to be attempted, output. +C NITER = Number of iterations (and of f evaluations) to compute H0, +C output. +C IER = The error flag, returned with the value +C IER = 0 if no trouble occurred, or +C IER = -1 if TOUT and T0 are considered too close to proceed. +C----------------------------------------------------------------------- +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL AFI, AbsTolI, DELYI, HALF, HG, HLB, HNEW, HRAT, + 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM + INTEGER I, ITER + +C +C Type declaration for function subroutines called --------------------- +C + KPP_REAL DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE HALF, HUN, PT1, TWO + DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ +C + NITER = 0 + TDIST = ABS(TOUT - T0) + TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) + IF (TDIST .LT. TWO*TROUND) GO TO 100 +C +C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- + HLB = HUN*TROUND +C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - + HUB = PT1*TDIST + AbsTolI = AbsTol(1) + DO 10 I = 1, N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) + DELYI = PT1*ABS(Y0(I)) + AbsTolI + AFI = ABS(YDOT(I)) + IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI + 10 CONTINUE +C +C Set initial guess for h as geometric mean of upper and lower bounds. - + ITER = 0 + HG = SQRT(HLB*HUB) +C If the bounds have crossed, exit with the mean value. ---------------- + IF (HUB .LT. HLB) THEN + H0 = HG + GO TO 90 + ENDIF +C +C Looping point for iteration. ----------------------------------------- + 50 CONTINUE +C Estimate the second derivative as a difference quotient in f. -------- + T1 = T0 + HG + DO 60 I = 1, N + 60 Y(I) = Y0(I) + HG*YDOT(I) + CALL F (N, T1, Y, TEMP) + DO 70 I = 1, N + 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG + YDDNRM = DVNORM (N, TEMP, EWT) +C Get the corresponding new value of h. -------------------------------- + IF (YDDNRM*HUB*HUB .GT. TWO) THEN + HNEW = SQRT(TWO/YDDNRM) + ELSE + HNEW = SQRT(HG*HUB) + ENDIF + ITER = ITER + 1 +C----------------------------------------------------------------------- +C Test the stopping conditions. +C Stop if the new and previous h values differ by a factor of .lt. 2. +C Stop if four iterations have been done. Also, stop with previous h +C if HNEW/HG .gt. 2 after first iteration, as this probably means that +C the second derivative value is bad because of cancellation error. +C----------------------------------------------------------------------- + IF (ITER .GE. 4) GO TO 80 + HRAT = HNEW/HG +C AICI + IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 + IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN + HNEW = HG + GO TO 80 + ENDIF + HG = HNEW + GO TO 50 +C +C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- + 80 H0 = HNEW*HALF + IF (H0 .LT. HLB) H0 = HLB + IF (H0 .GT. HUB) H0 = HUB + 90 H0 = SIGN(H0, TOUT - T0) + NITER = ITER + IER = 0 + RETURN +C Error return for TOUT - T0 too small. -------------------------------- + 100 IER = -1 + RETURN +C----------------------- End of Subroutine DVHIN ----------------------- + END +*DECK DVINDY + SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) + KPP_REAL T, YH, DKY + INTEGER K, LDYH, IFLAG + DIMENSION YH(LDYH,*), DKY(*) +C----------------------------------------------------------------------- +C Call sequence input -- T, K, YH, LDYH +C Call sequence output -- DKY, IFLAG +C COMMON block variables accessed.. +C /DVOD01/ -- H, TN, UROUND, L, N, NQ +C /DVOD02/ -- HU +C +C Subroutines called by DVINDY.. DSCAL, XERRWD +C Function routines called by DVINDY.. None +C----------------------------------------------------------------------- +C DVINDY computes interpolated values of the K-th derivative of the +C dependent variable vector y, and stores it in DKY. This routine +C is called within the package with K = 0 and T = TOUT, but may +C also be called by the user for any K up to the current order. +C (See detailed instructions in the usage documentation.) +C----------------------------------------------------------------------- +C The computed values in DKY are gotten by interpolation using the +C Nordsieck history array YH. This array corresponds uniquely to a +C vector-valued polynomial of degree NQCUR or less, and DKY is set +C to the K-th derivative of this polynomial at T. +C The formula for DKY is.. +C q +C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) +C j=K +C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. +C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are +C communicated by COMMON. The above sum is done in reverse order. +C IFLAG is returned negative if either K or T is out of bounds. +C +C Discussion above and comments in driver explain all variables. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + KPP_REAL HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL C, HUN, R, S, TFUZZ, TN1, TP, ZERO + INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 + CHARACTER*80 MSG +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE HUN, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA HUN /100.0D0/, ZERO /0.0D0/ +C + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TFUZZ = HUN*UROUND*(TN + HU) + TP = TN - HU - TFUZZ + TN1 = TN + TFUZZ + IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1, NQ + 10 IC = IC*JJ + 15 C = REAL(IC) + DO 20 I = 1, N + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1, JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1, J + 30 IC = IC*JJ + 35 C = REAL(IC) + DO 40 I = 1, N + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + CALL DSCAL (N, R, DKY, 1) + RETURN +C + 80 MSG = 'DVINDY-- K (=I1) illegal ' + CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) + IFLAG = -1 + RETURN + 90 MSG = 'DVINDY-- T (=R1) illegal ' + CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) + MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' + CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- End of Subroutine DVINDY ---------------------- + END +*DECK DVSTEP + SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, + 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) + EXTERNAL F, JAC, PSOL, VNLS + KPP_REAL Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR + INTEGER LDYH, IWM, IPAR + DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), + 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) + +C----------------------------------------------------------------------- +C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, +C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR +C Call sequence output -- YH, ACOR, WM, IWM +C COMMON block variables accessed.. +C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), +C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, +C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT +C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST +C +C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, +C DVJUST, VNLS, DVSET +C Function routines called by DVSTEP.. DVNORM +C----------------------------------------------------------------------- +C DVSTEP performs one step of the integration of an initial value +C problem for a system of ordinary differential equations. +C DVSTEP calls subroutine VNLS for the solution of the nonlinear system +C arising in the time step. Thus it is independent of the problem +C Jacobian structure and the type of nonlinear system solution method. +C DVSTEP returns a completion flag KFLAG (in COMMON). +C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 +C consecutive failures occurred. On a return with KFLAG negative, +C the values of TN and the YH array are as of the beginning of the last +C step, and H is the last step size attempted. +C +C Communication with DVSTEP is done with the following variables.. +C +C Y = An array of length N used for the dependent variable vector. +C YH = An LDYH by LMAX array containing the dependent variables +C and their approximate scaled derivatives, where +C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate +C j-th derivative of y(i), scaled by H**j/factorial(j) +C (j = 0,1,...,NQ). On entry for the first step, the first +C two columns of YH must be set from the initial values. +C LDYH = A constant integer .ge. N, the first dimension of YH. +C N is the number of ODEs in the system. +C YH1 = A one-dimensional array occupying the same space as YH. +C EWT = An array of length N containing multiplicative weights +C for local error measurements. Local errors in y(i) are +C compared to 1.0/EWT(i) in various error tests. +C SAVF = An array of working storage, of length N. +C also used for input of YH(*,MAXORD+2) when JSTART = -1 +C and MAXORD .lt. the current order NQ. +C VSAV = A work array of length N passed to subroutine VNLS. +C ACOR = A work array of length N, used for the accumulated +C corrections. On a successful return, ACOR(i) contains +C the estimated one-step local error in y(i). +C WM,IWM = Real and integer work arrays associated with matrix +C operations in VNLS. +C F = Dummy name for the user supplied subroutine for f. +C JAC = Dummy name for the user supplied Jacobian subroutine. +C PSOL = Dummy name for the subroutine passed to VNLS, for +C possible use there. +C VNLS = Dummy name for the nonlinear system solving subroutine, +C whose real name is dependent on the method used. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + KPP_REAL HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, + 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, + 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, + 3 R, THRESH, TOLD, ZERO + INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG +C +C Type declaration for function subroutines called --------------------- +C + KPP_REAL DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ADDON, BIAS1, BIAS2, BIAS3, + 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, + 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA KFC/-3/, KFH/-7/, MXNCF/10/ + DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, + 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, + 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D1/, + 3 ETAMX3 /10.0D1/, ONEPSM /1.00001D0/, THRESH /1.5D0/ + + DATA ONE/1.0D0/, ZERO/0.0D0/ +C + ETAQ = ETAMX1 + ETAQM1 = ETAMX1 + ETAQP1 = ETAMX1 + KFLAG = 0 + TOLD = TN + NCF = 0 + JCUR = 0 + NFLAG = 0 + IF (JSTART .GT. 0) GO TO 20 + IF (JSTART .EQ. -1) GO TO 100 +C----------------------------------------------------------------------- +C On the first call, the order is set to 1, and other variables are +C initialized. ETAMAX is the maximum ratio by which H can be increased +C in a single step. It is normally 1.5, but is larger during the +C first 10 steps to compensate for the small initial H. If a failure +C occurs (in corrector convergence or error test), ETAMAX is set to 1 +C for the next increase. +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + NQNYH = NQ*LDYH + TAU(1) = H + PRL1 = ONE + RC = ZERO + ETAMAX = ETAMX1 + NQWAIT = 2 + HSCAL = H + GO TO 200 +C----------------------------------------------------------------------- +C Take preliminary actions on a normal continuation step (JSTART.GT.0). +C If the driver changed H, then ETA must be reset and NEWH set to 1. +C If a change of order was dictated on the previous step, then +C it is done here and appropriate adjustments in the history are made. +C On an order decrease, the history array is adjusted by DVJUST. +C On an order increase, the history array is augmented by a column. +C On a change of step size H, the history array YH is rescaled. +C----------------------------------------------------------------------- + 20 CONTINUE + IF (KUTH .EQ. 1) THEN + ETA = MIN(ETA,H/HSCAL) + NEWH = 1 + ENDIF + 50 IF (NEWH .EQ. 0) GO TO 200 + IF (NEWQ .EQ. NQ) GO TO 150 + IF (NEWQ .LT. NQ) THEN + CALL DVJUST (YH, LDYH, -1) + NQ = NEWQ + L = NQ + 1 + NQWAIT = L + GO TO 150 + ENDIF + IF (NEWQ .GT. NQ) THEN + CALL DVJUST (YH, LDYH, 1) + NQ = NEWQ + L = NQ + 1 + NQWAIT = L + GO TO 150 + ENDIF +C----------------------------------------------------------------------- +C The following block handles preliminaries needed when JSTART = -1. +C If N was reduced, zero out part of YH to avoid undefined references. +C If MAXORD was reduced to a value less than the tentative order NEWQ, +C then NQ is set to MAXORD, and a new H ratio ETA is chosen. +C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. +C In any case, NQWAIT is reset to L = NQ + 1 to prevent further +C changes in order for that many steps. +C The new H ratio ETA is limited by the input H if KUTH = 1, +C by HMIN if KUTH = 0, and by HMXI in any case. +C Finally, the history array YH is rescaled. +C----------------------------------------------------------------------- + 100 CONTINUE + LMAX = MAXORD + 1 + IF (N .EQ. LDYH) GO TO 120 + I1 = 1 + (NEWQ + 1)*LDYH + I2 = (MAXORD + 1)*LDYH + IF (I1 .GT. I2) GO TO 120 + DO 110 I = I1, I2 + 110 YH1(I) = ZERO + 120 IF (NEWQ .LE. MAXORD) GO TO 140 + FLOTL = REAL(LMAX) + IF (MAXORD .LT. NQ-1) THEN + DDN = DVNORM (N, SAVF, EWT)/TQ(1) + ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) + ENDIF + IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ + IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN + ETA = ETAQM1 + CALL DVJUST (YH, LDYH, -1) + ENDIF + IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN + DDN = DVNORM (N, SAVF, EWT)/TQ(1) + ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) + CALL DVJUST (YH, LDYH, -1) + ENDIF + ETA = MIN(ETA,ONE) + NQ = MAXORD + L = LMAX + 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) + IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) + ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) + NEWH = 1 + NQWAIT = L + IF (NEWQ .LE. MAXORD) GO TO 50 +C Rescale the history array for a change in H by a factor of ETA. ------ + 150 R = ONE + DO 180 J = 2, L + R = R*ETA + CALL DSCAL (N, R, YH(1,J), 1 ) + 180 CONTINUE + H = HSCAL*ETA + HSCAL = H + RC = RC*ETA + NQNYH = NQ*LDYH +C----------------------------------------------------------------------- +C This section computes the predicted values by effectively +C multiplying the YH array by the Pascal triangle matrix. +C DVSET is called to calculate all integration coefficients. +C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. +C----------------------------------------------------------------------- + 200 TN = TN + H + I1 = NQNYH + 1 + DO 220 JB = 1, NQ + I1 = I1 - LDYH + DO 210 I = I1, NQNYH + 210 YH1(I) = YH1(I) + YH1(I+LDYH) + 220 CONTINUE + CALL DVSET + RL1 = ONE/EL(2) + RC = RC*(RL1/PRL1) + PRL1 = RL1 +C +C Call the nonlinear system solver. ------------------------------------ +C + CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, + 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) +C + IF ((NFLAG .EQ. 0).OR.(H.LE.1.2*HMIN)) GO TO 450 +C----------------------------------------------------------------------- +C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). +C The YH array is retracted to its values before prediction. +C The step size H is reduced and the step is retried, if possible. +C Otherwise, an error exit is taken. +C----------------------------------------------------------------------- + NCF = NCF + 1 + NCFN = NCFN + 1 + ETAMAX = ONE + TN = TOLD + I1 = NQNYH + 1 + DO 430 JB = 1, NQ + I1 = I1 - LDYH + DO 420 I = I1, NQNYH + 420 YH1(I) = YH1(I) - YH1(I+LDYH) + 430 CONTINUE + IF (NFLAG .LT. -1) GO TO 680 + IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + ETA = ETACF + ETA = MAX(ETA,HMIN/ABS(H)) + NFLAG = -1 + GO TO 150 +C----------------------------------------------------------------------- +C The corrector has converged (NFLAG = 0). The local error test is +C made and control passes to statement 500 if it fails. +C----------------------------------------------------------------------- + 450 CONTINUE + DSM = ACNRM/TQ(2) + IF ( (DSM .GT. ONE).and.(H.GT.HMIN) ) GO TO 500 +C----------------------------------------------------------------------- +C After a successful step, update the YH and TAU arrays and decrement +C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved +C for use in a possible order increase on the next step. +C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. +C----------------------------------------------------------------------- + KFLAG = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 IBACK = 1, NQ + I = L - IBACK + 470 TAU(I+1) = TAU(I) + TAU(1) = H + DO 480 J = 1, L + CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) + 480 CONTINUE + NQWAIT = NQWAIT - 1 + IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 + CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) + CONP = TQ(5) + 490 IF (ETAMAX .NE. ONE) GO TO 560 + IF (NQWAIT .LT. 2) NQWAIT = 2 + NEWQ = NQ + NEWH = 0 + ETA = ONE + HNEW = H + GO TO 690 +C----------------------------------------------------------------------- +C The error test failed. KFLAG keeps track of multiple failures. +C Restore TN and the YH array to their previous values, and prepare +C to try the step again. Compute the optimum step size for the +C same order. After repeated failures, H is forced to decrease +C more rapidly. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + NETF = NETF + 1 + NFLAG = -2 + TN = TOLD + I1 = NQNYH + 1 + DO 520 JB = 1, NQ + I1 = I1 - LDYH + DO 510 I = I1, NQNYH + 510 YH1(I) = YH1(I) - YH1(I+LDYH) + 520 CONTINUE + IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 + ETAMAX = ONE + IF (KFLAG .LE. KFC) GO TO 530 +C Compute ratio of new H to current H at the current order. ------------ + FLOTL = REAL(L) + ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) + ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) + IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF + GO TO 150 +C----------------------------------------------------------------------- +C Control reaches this section if 3 or more consecutive failures +C have occurred. It is assumed that the elements of the YH array +C have accumulated errors of the wrong order. The order is reduced +C by one, if possible. Then H is reduced by a factor of 0.1 and +C the step is retried. After a total of 7 consecutive failures, +C an exit is taken with KFLAG = -1. +C----------------------------------------------------------------------- + 530 IF (KFLAG .EQ. KFH) GO TO 660 + IF (NQ .EQ. 1) GO TO 540 + ETA = MAX(ETAMIN,HMIN/ABS(H)) + CALL DVJUST (YH, LDYH, -1) + L = NQ + NQ = NQ - 1 + NQWAIT = L + GO TO 150 + 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) + H = H*ETA + HSCAL = H + TAU(1) = H + CALL F (N, TN, Y, SAVF) + NFE = NFE + 1 + DO 550 I = 1, N + 550 YH(I,2) = H*SAVF(I) + NQWAIT = 10 + GO TO 200 +C----------------------------------------------------------------------- +C If NQWAIT = 0, an increase or decrease in order by one is considered. +C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could +C be multiplied at order q, q-1, or q+1, respectively. +C The largest of these is determined, and the new order and +C step size set accordingly. +C A change of H or NQ is made only if H increases by at least a +C factor of THRESH. If an order change is considered and rejected, +C then NQWAIT is set to 2 (reconsider it after 2 steps). +C----------------------------------------------------------------------- +C Compute ratio of new H to current H at the current order. ------------ + 560 FLOTL = REAL(L) + ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) + IF (NQWAIT .NE. 0) GO TO 600 + NQWAIT = 2 + ETAQM1 = ZERO + IF (NQ .EQ. 1) GO TO 570 +C Compute ratio of new H to current H at the current order less one. --- + DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) + ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) + 570 ETAQP1 = ZERO + IF (L .EQ. LMAX) GO TO 580 +C Compute ratio of new H to current H at current order plus one. ------- + CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L + DO 575 I = 1, N + 575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) + DUP = DVNORM (N, SAVF, EWT)/TQ(3) + ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) + 580 IF (ETAQ .GE. ETAQP1) GO TO 590 + IF (ETAQP1 .GT. ETAQM1) GO TO 620 + GO TO 610 + 590 IF (ETAQ .LT. ETAQM1) GO TO 610 + 600 ETA = ETAQ + NEWQ = NQ + GO TO 630 + 610 ETA = ETAQM1 + NEWQ = NQ - 1 + GO TO 630 + 620 ETA = ETAQP1 + NEWQ = NQ + 1 + CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) +C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- + 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 + ETA = MIN(ETA,ETAMAX) + ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) + NEWH = 1 + HNEW = H*ETA + GO TO 690 + 640 NEWQ = NQ + NEWH = 0 + ETA = ONE + HNEW = H + GO TO 690 +C----------------------------------------------------------------------- +C All returns are made through this section. +C On a successful return, ETAMAX is reset and ACOR is scaled. +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 IF (NFLAG .EQ. -2) KFLAG = -3 + IF (NFLAG .EQ. -3) KFLAG = -4 + GO TO 720 + 690 ETAMAX = ETAMX3 + IF (NST .LE. 10) ETAMAX = ETAMX2 + 700 R = ONE/TQ(2) + CALL DSCAL (N, R, ACOR, 1) + 720 JSTART = 1 + RETURN +C----------------------- End of Subroutine DVSTEP ---------------------- + END +*DECK DVSET + SUBROUTINE DVSET +C----------------------------------------------------------------------- +C Call sequence communication.. None +C COMMON block variables accessed.. +C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), +C METH, NQ, NQWAIT +C +C Subroutines called by DVSET.. None +C Function routines called by DVSET.. None +C----------------------------------------------------------------------- +C DVSET is called by DVSTEP and sets coefficients for use there. +C +C For each order NQ, the coefficients in EL are calculated by use of +C the generating polynomial lambda(x), with coefficients EL(i). +C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). +C For the backward differentiation formulas, +C NQ-1 +C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . +C i = 1 +C For the Adams formulas, +C NQ-1 +C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , +C i = 1 +C lambda(-1) = 0, lambda(0) = 1, +C where c is a normalization constant. +C In both cases, xi(i) is defined by +C H*xi(i) = t sub n - t sub (n-i) +C = H + TAU(1) + TAU(2) + ... TAU(i-1). +C +C +C In addition to variables described previously, communication +C with DVSET uses the following.. +C TAU = A vector of length 13 containing the past NQ values +C of H. +C EL = A vector of length 13 in which vset stores the +C coefficients for the corrector formula. +C TQ = A vector of length 5 in which vset stores constants +C used for the convergence test, the error test, and the +C selection of H at a new order. +C METH = The basic method indicator. +C NQ = The current order. +C L = NQ + 1, the length of the vector stored in EL, and +C the number of columns of the YH array being used. +C NQWAIT = A counter controlling the frequency of order changes. +C An order change is about to be considered if NQWAIT = 1. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, + 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, + 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO + INTEGER I, IBACK, J, JP1, NQM1, NQM2 +C + DIMENSION EM(13) +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE CORTES, ONE, SIX, TWO, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA CORTES /0.1D0/ + DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ +C + FLOTL = REAL(L) + NQM1 = NQ - 1 + NQM2 = NQ - 2 + GO TO (100, 200), METH +C +C Set coefficients for Adams methods. ---------------------------------- + 100 IF (NQ .NE. 1) GO TO 110 + EL(1) = ONE + EL(2) = ONE + TQ(1) = ONE + TQ(2) = TWO + TQ(3) = SIX*TQ(2) + TQ(5) = ONE + GO TO 300 + 110 HSUM = H + EM(1) = ONE + FLOTNQ = FLOTL - ONE + DO 115 I = 2, L + 115 EM(I) = ZERO + DO 150 J = 1, NQM1 + IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 + S = ONE + CSUM = ZERO + DO 120 I = 1, NQM1 + CSUM = CSUM + S*EM(I)/REAL(I+1) + 120 S = -S + TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) + 130 RXI = H/HSUM + DO 140 IBACK = 1, J + I = (J + 2) - IBACK + 140 EM(I) = EM(I) + EM(I-1)*RXI + HSUM = HSUM + TAU(J) + 150 CONTINUE +C Compute integral from -1 to 0 of polynomial and of x times it. ------- + S = ONE + EM0 = ZERO + CSUM = ZERO + DO 160 I = 1, NQ + FLOTI = REAL(I) + EM0 = EM0 + S*EM(I)/FLOTI + CSUM = CSUM + S*EM(I)/(FLOTI+ONE) + 160 S = -S +C In EL, form coefficients of normalized integrated polynomial. -------- + S = ONE/EM0 + EL(1) = ONE + DO 170 I = 1, NQ + 170 EL(I+1) = S*EM(I)/REAL(I) + XI = HSUM/H + TQ(2) = XI*EM0/CSUM + TQ(5) = XI/EL(L) + IF (NQWAIT .NE. 1) GO TO 300 +C For higher order control constant, multiply polynomial by 1+x/xi(q). - + RXI = ONE/XI + DO 180 IBACK = 1, NQ + I = (L + 1) - IBACK + 180 EM(I) = EM(I) + EM(I-1)*RXI +C Compute integral of polynomial. -------------------------------------- + S = ONE + CSUM = ZERO + DO 190 I = 1, L + CSUM = CSUM + S*EM(I)/REAL(I+1) + 190 S = -S + TQ(3) = FLOTL*EM0/CSUM + GO TO 300 +C +C Set coefficients for BDF methods. ------------------------------------ + 200 DO 210 I = 3, L + 210 EL(I) = ZERO + EL(1) = ONE + EL(2) = ONE + ALPH0 = -ONE + AHATN0 = -ONE + HSUM = H + RXI = ONE + RXIS = ONE + IF (NQ .EQ. 1) GO TO 240 + DO 230 J = 1, NQM2 +C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ + HSUM = HSUM + TAU(J) + RXI = H/HSUM + JP1 = J + 1 + ALPH0 = ALPH0 - ONE/REAL(JP1) + DO 220 IBACK = 1, JP1 + I = (J + 3) - IBACK + 220 EL(I) = EL(I) + EL(I-1)*RXI + 230 CONTINUE + ALPH0 = ALPH0 - ONE/REAL(NQ) + RXIS = -EL(2) - ALPH0 + HSUM = HSUM + TAU(NQM1) + RXI = H/HSUM + AHATN0 = -EL(2) - RXI + DO 235 IBACK = 1, NQ + I = (NQ + 2) - IBACK + 235 EL(I) = EL(I) + EL(I-1)*RXIS + 240 T1 = ONE - AHATN0 + ALPH0 + T2 = ONE + REAL(NQ)*T1 + TQ(2) = ABS(ALPH0*T2/T1) + TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) + IF (NQWAIT .NE. 1) GO TO 300 + CNQM1 = RXIS/EL(L) + T3 = ALPH0 + ONE/REAL(NQ) + T4 = AHATN0 + RXI + ELP = T3/(ONE - T4 + T3) + TQ(1) = ABS(ELP/CNQM1) + HSUM = HSUM + TAU(NQ) + RXI = H/HSUM + T5 = ALPH0 - ONE/REAL(NQ+1) + T6 = AHATN0 - RXI + ELP = T2/(ONE - T6 + T5) + TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) + 300 TQ(4) = CORTES*TQ(2) + RETURN +C----------------------- End of Subroutine DVSET ----------------------- + END +*DECK DVJUST + SUBROUTINE DVJUST (YH, LDYH, IORD) + KPP_REAL YH + INTEGER LDYH, IORD + DIMENSION YH(LDYH,*) +C----------------------------------------------------------------------- +C Call sequence input -- YH, LDYH, IORD +C Call sequence output -- YH +C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N +C COMMON block variables accessed.. +C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, +C +C Subroutines called by DVJUST.. DAXPY +C Function routines called by DVJUST.. None +C----------------------------------------------------------------------- +C This subroutine adjusts the YH array on reduction of order, +C and also when the order is increased for the stiff option (METH = 2). +C Communication with DVJUST uses the following.. +C IORD = An integer flag used when METH = 2 to indicate an order +C increase (IORD = +1) or an order decrease (IORD = -1). +C HSCAL = Step size H used in scaling of Nordsieck array YH. +C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) +C See References 1 and 2 for details. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO + INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ONE, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA ONE /1.0D0/, ZERO /0.0D0/ +C + IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN + NQM1 = NQ - 1 + NQM2 = NQ - 2 + GO TO (100, 200), METH +C----------------------------------------------------------------------- +C Nonstiff option... +C Check to see if the order is being increased or decreased. +C----------------------------------------------------------------------- + 100 CONTINUE + IF (IORD .EQ. 1) GO TO 180 +C Order decrease. ------------------------------------------------------ + DO 110 J = 1, LMAX + 110 EL(J) = ZERO + EL(2) = ONE + HSUM = ZERO + DO 130 J = 1, NQM2 +C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- + HSUM = HSUM + TAU(J) + XI = HSUM/HSCAL + JP1 = J + 1 + DO 120 IBACK = 1, JP1 + I = (J + 3) - IBACK + 120 EL(I) = EL(I)*XI + EL(I-1) + 130 CONTINUE +C Construct coefficients of integrated polynomial. --------------------- + DO 140 J = 2, NQM1 + 140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) +C Subtract correction terms from YH array. ----------------------------- + DO 170 J = 3, NQ + DO 160 I = 1, N + 160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) + 170 CONTINUE + RETURN +C Order increase. ------------------------------------------------------ +C Zero out next column in YH array. ------------------------------------ + 180 CONTINUE + LP1 = L + 1 + DO 190 I = 1, N + 190 YH(I,LP1) = ZERO + RETURN +C----------------------------------------------------------------------- +C Stiff option... +C Check to see if the order is being increased or decreased. +C----------------------------------------------------------------------- + 200 CONTINUE + IF (IORD .EQ. 1) GO TO 300 +C Order decrease. ------------------------------------------------------ + DO 210 J = 1, LMAX + 210 EL(J) = ZERO + EL(3) = ONE + HSUM = ZERO + DO 230 J = 1,NQM2 +C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + HSUM = HSUM + TAU(J) + XI = HSUM/HSCAL + JP1 = J + 1 + DO 220 IBACK = 1, JP1 + I = (J + 4) - IBACK + 220 EL(I) = EL(I)*XI + EL(I-1) + 230 CONTINUE +C Subtract correction terms from YH array. ----------------------------- + DO 250 J = 3,NQ + DO 240 I = 1, N + 240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) + 250 CONTINUE + RETURN +C Order increase. ------------------------------------------------------ + 300 DO 310 J = 1, LMAX + 310 EL(J) = ZERO + EL(3) = ONE + ALPH0 = -ONE + ALPH1 = ONE + PROD = ONE + XIOLD = ONE + HSUM = HSCAL + IF (NQ .EQ. 1) GO TO 340 + DO 330 J = 1, NQM1 +C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + JP1 = J + 1 + HSUM = HSUM + TAU(JP1) + XI = HSUM/HSCAL + PROD = PROD*XI + ALPH0 = ALPH0 - ONE/REAL(JP1) + ALPH1 = ALPH1 + ONE/XI + DO 320 IBACK = 1, JP1 + I = (J + 4) - IBACK + 320 EL(I) = EL(I)*XIOLD + EL(I-1) + XIOLD = XI + 330 CONTINUE + 340 CONTINUE + T1 = (-ALPH0 - ALPH1)/PROD +C Load column L + 1 in YH array. --------------------------------------- + LP1 = L + 1 + DO 350 I = 1, N + 350 YH(I,LP1) = T1*YH(I,LMAX) +C Add correction terms to YH array. ------------------------------------ + NQP1 = NQ + 1 + DO 370 J = 3, NQP1 + CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) + 370 CONTINUE + RETURN +C----------------------- End of Subroutine DVJUST ---------------------- + END +*DECK DVNLSD + SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, + 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) + EXTERNAL F, JAC, PDUM + KPP_REAL Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR + INTEGER LDYH, IWM, NFLAG, IPAR + DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), + 1 IWM(*), WM(*), RPAR(*), IPAR(*) + +C----------------------------------------------------------------------- +C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, +C F, JAC, NFLAG, RPAR, IPAR +C Call sequence output -- YH, ACOR, WM, IWM, NFLAG +C COMMON block variables accessed.. +C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, +C JCUR, METH, MITER, N, NSLP +C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL +C Function routines called by DVNLSD.. DVNORM +C----------------------------------------------------------------------- +C Subroutine DVNLSD is a nonlinear system solver, which uses functional +C iteration or a chord (modified Newton) method. For the chord method +C direct linear algebraic system solvers are used. Subroutine DVNLSD +C then handles the corrector phase of this integration package. +C +C Communication with DVNLSD is done with the following variables. (For +C more details, please see the comments in the driver subroutine.) +C +C Y = The dependent variable, a vector of length N, input. +C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input +C and output. On input, it contains predicted values. +C LDYH = A constant .ge. N, the first dimension of YH, input. +C VSAV = Unused work array. +C SAVF = A work array of length N. +C EWT = An error weight vector of length N, input. +C ACOR = A work array of length N, used for the accumulated +C corrections to the predicted y vector. +C WM,IWM = Real and integer work arrays associated with matrix +C operations in chord iteration (MITER .ne. 0). +C F = Dummy name for user supplied routine for f. +C JAC = Dummy name for user supplied Jacobian routine. +C PDUM = Unused dummy subroutine name. Included for uniformity +C over collection of integrators. +C NFLAG = Input/output flag, with values and meanings as follows.. +C INPUT +C 0 first CALL for this time step. +C -1 convergence failure in previous CALL to DVNLSD. +C -2 error test failure in DVSTEP. +C OUTPUT +C 0 successful completion of nonlinear solver. +C -1 convergence failure or singular matrix. +C -2 unrecoverable error in matrix preprocessing +C (cannot occur here). +C -3 unrecoverable error in solution (cannot occur +C here). +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C +C IPUP = Own variable flag with values and meanings as follows.. +C 0, do not update the Newton matrix. +C MITER .ne. 0, update Newton matrix, because it is the +C initial step, order was changed, the error +C test failed, or an update is indicated by +C the scalar RC or step counter NST. +C +C For more details, see comments in driver subroutine. +C----------------------------------------------------------------------- +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + KPP_REAL HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, + 1 RDIV, TWO, ZERO + INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP +C +C Type declaration for function subroutines called --------------------- +C + KPP_REAL DVNORM, STEPCUT +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + COMMON /VERWER/ IVERWER, IBEGIN, STEPCUT + DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, + 1 RDIV /2.0D0/ + DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ +C----------------------------------------------------------------------- +C On the first step, on a change of method order, or after a +C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER +C to force a Jacobian update when MITER .ne. 0. +C----------------------------------------------------------------------- + if ( (h.lt.stepcut).and.(IBEGIN.eq.1) ) then +c if (h.lt.stepcut) then + iverwer = 1 + else + ibegin = 0 + iverwer = 0 + end if + IF (JSTART .EQ. 0) NSLP = 0 + IF (NFLAG .EQ. 0) ICF = 0 + IF (NFLAG .EQ. -2) IPUP = MITER + IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER +C If this is functional iteration, set CRATE .eq. 1 and drop to 220 + IF (MITER .EQ. 0) THEN + CRATE = ONE + GO TO 220 + ENDIF +C----------------------------------------------------------------------- +C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. +C When RC differs from 1 by more than CCMAX, IPUP is set to MITER +C to force DVJAC to be called, if a Jacobian is involved. +C In any case, DVJAC is called at least every MSBP steps. +C----------------------------------------------------------------------- + DRC = ABS(RC-ONE) + IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER +C----------------------------------------------------------------------- +C Up to MAXCOR corrector iterations are taken. A convergence test is +C made on the r.m.s. norm of each correction, weighted by the error +C weight vector EWT. The sum of the corrections is accumulated in the +C vector ACOR(i). The YH array is not altered in the corrector loop. +C----------------------------------------------------------------------- + 220 M = 0 + DELP = ZERO + CALL DCOPY (N, YH(1,1), 1, Y, 1 ) + CALL F (N, TN, Y, SAVF) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C If indicated, the matrix P = I - h*rl1*J is reevaluated and +C preprocessed before starting the corrector iteration. IPUP is set +C to 0 as an indicator that this has been done. +C----------------------------------------------------------------------- + IF (IVERWER.EQ.0) THEN + CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, + 1 RPAR, IPAR) + ELSE + IERPJ = 0 + END IF + IPUP = 0 + RC = ONE + DRC = ZERO + CRATE = ONE + NSLP = NST +C If matrix is singular, take error return to force cut in step size. -- + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = ZERO +C This is a looping point for the corrector iteration. ----------------- + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C In the case of functional iteration, update Y directly from +C the result of the last function evaluation. +C----------------------------------------------------------------------- + DO 280 I = 1,N + 280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) + DO 290 I = 1,N + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = DVNORM (N, Y, EWT) + DO 300 I = 1,N + 300 Y(I) = YH(I,1) + SAVF(I) + CALL DCOPY (N, SAVF, 1, ACOR, 1) + GO TO 400 +C----------------------------------------------------------------------- +C In the case of the chord method, compute the corrector error, +C and solve the linear system with that as right-hand side and +C P as coefficient matrix. The correction is scaled by the factor +C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. +C----------------------------------------------------------------------- + 350 continue + if (IVERWER.EQ.1) then + CRATE = 1 + DO I = 1,N + Y(I) = SAVF(I) - ACOR(I) + end do + DEL = DVNORM (N, Y, EWT) + DO I = 1,N + Y(I) = YH(I,1) + SAVF(I) + end do + CALL DCOPY (N, SAVF, 1, ACOR, 1) + GO TO 400 + end if + DO 360 I = 1,N + 360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) + CALL DVSOL (WM, IWM, Y, IERSL) + NNI = NNI + 1 + IF (IERSL .GT. 0) GO TO 410 + IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN + CSCALE = TWO/(ONE + RC) + CALL DSCAL (N, CSCALE, Y, 1) + ENDIF + DEL = DVNORM (N, Y, EWT) + CALL DAXPY (N, ONE, Y, 1, ACOR, 1) + DO 380 I = 1,N + 380 Y(I) = YH(I,1) + ACOR(I) +C----------------------------------------------------------------------- +C Test for convergence. If M .gt. 0, an estimate of the convergence +C rate constant is stored in CRATE, and this is used in the test. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) + DCON = DEL*MIN(ONE,CRATE)/TQ(4) + IF (DCON .LE. ONE) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 + DELP = DEL + CALL F (N, TN, Y, SAVF) + NFE = NFE + 1 + GO TO 270 +C + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 +C + 430 CONTINUE + NFLAG = -1 + ICF = 2 + IPUP = MITER + RETURN +C +C Return for successful step. ------------------------------------------ + 450 NFLAG = 0 + JCUR = 0 + ICF = 0 + IF (M .EQ. 0) ACNRM = DEL + IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) + RETURN +C----------------------- End of Subroutine DVNLSD ---------------------- + END + +*DECK DVJAC + SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, FUN, JAC, + 1 IERPJ, RPAR, IPAR) +C IMPLICIT KPP_REAL (A-H, O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + EXTERNAL FUN, JAC + KPP_REAL Y, YH, EWT, FTEM, SAVF, WM, RPAR + INTEGER LDYH, IWM, IERPJ, IPAR + DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), + 1 WM(*), IWM(*), RPAR(*), IPAR(*) + +C----------------------------------------------------------------------- +C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, +C FUN, JAC, RPAR, IPAR +C Call sequence output -- WM, IWM, IERPJ +C COMMON block variables accessed.. +C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, +C MSBJ, NSLJ +C /DVOD02/ NFE, NST, NJE, NLU +C +C Subroutines called by DVJAC.. FUN, JAC, DACOPY, DCOPY, DGBFA, DGEFA, +C DSCAL +C Function routines called by DVJAC.. DVNORM +C----------------------------------------------------------------------- +C DVJAC is called by DVSTEP to compute and process the matrix +C P = I - h*rl1*J , where J is an approximation to the Jacobian. +C Here J is computed by the user-supplied routine JAC if +C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. +C If MITER = 3, a diagonal approximation to J is used. +C If JSV = -1, J is computed from scratch in all cases. +C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is +C considered acceptable, then P is constructed from the saved J. +C J is stored in wm and replaced by P. If MITER .ne. 3, P is then +C subjected to LU decomposition in preparation for later solution +C of linear systems with P as coefficient matrix. This is done +C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. +C +C Communication with DVJAC is done with the following variables. (For +C more details, please see the comments in the driver subroutine.) +C Y = Vector containing predicted values on entry. +C YH = The Nordsieck array, an LDYH by LMAX array, input. +C LDYH = A constant .ge. N, the first dimension of YH, input. +C EWT = An error weight vector of length N. +C SAVF = Array containing f evaluated at predicted y, input. +C WM = Real work space for matrices. In the output, it containS +C the inverse diagonal matrix if MITER = 3 and the LU +C decomposition of P if MITER is 1, 2 , 4, or 5. +C Storage of matrix elements starts at WM(3). +C Storage of the saved Jacobian starts at WM(LOCJS). +C WM also contains the following matrix-related data.. +C WM(1) = SQRT(UROUND), used in numerical Jacobian step. +C WM(2) = H*RL1, saved for later use if MITER = 3. +C IWM = Integer work space containing pivot information, +C starting at IWM(31), if MITER is 1, 2, 4, or 5. +C IWM also contains band parameters ML = IWM(1) and +C MU = IWM(2) if MITER is 4 or 5. +C FUN = Dummy name for the user supplied subroutine for f. +C JAC = Dummy name for the user supplied Jacobian subroutine. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C RL1 = 1/EL(2) (input). +C IERPJ = Output error flag, = 0 if no trouble, 1 if the P +C matrix is found to be singular. +C JCUR = Output flag to indicate whether the Jacobian matrix +C (or approximation) is now current. +C JCUR = 0 means J is not current. +C JCUR = 1 means J is current. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + KPP_REAL HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + KPP_REAL CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, + 1 YI, YJ, YJJ, ZERO + INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, + 1 MEB1, MEBAND, ML, ML3, MU, NP1 +C +C Type declaration for function subroutines called --------------------- +C + KPP_REAL DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this subroutine. +C----------------------------------------------------------------------- + SAVE ONE, PT1, THOU, ZERO +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ +C + IER = 0 + IERPJ = 0 + HRL1 = H*RL1 +C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- + JOK = JSV + IF (JSV .EQ. 1) THEN + IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 + IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 + IF (ICF .EQ. 2) JOK = -1 + ENDIF +C End of setting JOK. -------------------------------------------------- +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN +C If JOK = -1 and MITER = 1, CALL JAC to evaluate Jacobian. ------------ + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + LENP = LU_NONZERO + DO 110 I = 1,LENP + 110 WM(I+2) = ZERO + +c CALL Update_SUN(TN) +c CALL Update_RCONST() + CALL JAC (N, TN, Y, WM(3)) + IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) + ENDIF +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN +C If MITER = 2, make N calls to FUN to approximate the Jacobian. --------- + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + FAC = DVNORM (N, SAVF, EWT) + R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = ONE/R + CALL FUN (N, TN, Y, FTEM) + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + 230 CONTINUE + NFE = NFE + N + LENP = LU_NONZERO + IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) + ENDIF +C + IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN + JCUR = 0 + LENP = LU_NONZERO + CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) + ENDIF +C + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN +C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- + CON = -HRL1 + CALL DSCAL (LENP, CON, WM(3), 1) + J = 3 + NP1 = N + 1 + DO 250 I = 1,N + WM(2+LU_DIAG(i)) = WM(2+LU_DIAG(i)) + ONE + 250 CONTINUE + NLU = NLU + 1 +C CALL DGEFA (WM(3), N, N, IWM(31), IER) + CALL KppDecomp ( WM(3), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN + ENDIF +C End of code block for MITER = 1 or 2. -------------------------------- +C + IF (MITER .EQ. 3) THEN +C If MITER = 3, construct a diagonal approximation to J and P. --------- + NJE = NJE + 1 + JCUR = 1 + WM(2) = HRL1 + R = RL1*PT1 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + CALL FUN (N, TN, Y, WM(3)) + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = ONE + IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (ABS(DI) .EQ. ZERO) GO TO 330 + WM(I+2) = PT1*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN + ENDIF +C End of code block for MITER = 3. ------------------------------------- +C +C Set constants for MITER = 4 or 5. ------------------------------------ + ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN +C If JOK = -1 and MITER = 4, CALL JAC to evaluate Jacobian. ------------ + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + DO 410 I = 1,LENP + 410 WM(I+2) = ZERO + +c CALL Update_SUN(TN) +c CALL Update_RCONST() + CALL JAC (N, TN, Y, WM(ML3)) + IF (JSV .EQ. 1) + 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) + ENDIF +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN +C If MITER = 5, make N calls to FUN to approximate the Jacobian. --------- + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + MBA = MIN(MBAND,N) + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = DVNORM (N, SAVF, EWT) + R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0/EWT(I)) + 530 Y(I) = Y(I) + R + CALL FUN (N, TN, Y, FTEM) + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) + FAC = ONE/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA + IF (JSV .EQ. 1) + 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) + ENDIF +C + IF (JOK .EQ. 1) THEN + JCUR = 0 + CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) + ENDIF +C +C Multiply Jacobian by scalar, add identity, and do LU decomposition. + CON = -HRL1 + CALL DSCAL (LENP, CON, WM(3), 1 ) + II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + ONE + 580 II = II + MEBAND + NLU = NLU + 1 +C CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C End of code block for MITER = 4 or 5. -------------------------------- +C +C----------------------- End of Subroutine DVJAC ----------------------- + END +*DECK DACOPY + SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) + KPP_REAL A, B + INTEGER NROW, NCOL, NROWA, NROWB + DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) +C----------------------------------------------------------------------- +C Call sequence input -- NROW, NCOL, A, NROWA, NROWB +C Call sequence output -- B +C COMMON block variables accessed -- None +C +C Subroutines called by DACOPY.. DCOPY +C Function routines called by DACOPY.. None +C----------------------------------------------------------------------- +C This routine copies one rectangular array, A, to another, B, +C where A and B may have different row dimensions, NROWA and NROWB. +C The data copied consists of NROW rows and NCOL columns. +C----------------------------------------------------------------------- + INTEGER IC +C + DO 20 IC = 1,NCOL + CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) + 20 CONTINUE +C + RETURN +C----------------------- End of Subroutine DACOPY ---------------------- + END +*DECK DVSOL + SUBROUTINE DVSOL (WM, IWM, X, IERSL) + KPP_REAL WM, X + INTEGER IWM, IERSL + DIMENSION WM(*), IWM(*), X(*) +C----------------------------------------------------------------------- +C Call sequence input -- WM, IWM, X +C Call sequence output -- X, IERSL +C COMMON block variables accessed.. +C /DVOD01/ -- H, RL1, MITER, N +C +C Subroutines called by DVSOL.. DGESL, DGBSL +C Function routines called by DVSOL.. None +C----------------------------------------------------------------------- +C This routine manages the solution of the linear system arising from +C a chord iteration. It is called if MITER .ne. 0. +C If MITER is 1 or 2, it calls DGESL to accomplish this. +C If MITER = 3 it updates the coefficient H*RL1 in the diagonal +C matrix, and then computes the solution. +C If MITER is 4 or 5, it calls DGBSL. +C Communication with DVSOL uses the following variables.. +C WM = Real work space containing the inverse diagonal matrix if +C MITER = 3 and the LU decomposition of the matrix otherwise. +C Storage of matrix elements starts at WM(3). +C WM also contains the following matrix-related data.. +C WM(1) = SQRT(UROUND) (not used here), +C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. +C IWM = Integer work space containing pivot information, starting at +C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band +C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +C X = The right-hand side vector on input, and the solution vector +C on output, of length N. +C IERSL = Output flag. IERSL = 0 if no trouble occurred. +C IERSL = 1 if a singular matrix arose with MITER = 3. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + KPP_REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + INTEGER I, MEBAND, ML, MU + KPP_REAL DI, HRL1, ONE, PHRL1, R, ZERO +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ONE, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA ONE /1.0D0/, ZERO /0.0D0/ +C + IERSL = 0 + GO TO (100, 100, 300, 400, 400), MITER +C 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) + 100 CALL KppSolve (WM(3), X) + RETURN +C + 300 PHRL1 = WM(2) + HRL1 = H*RL1 + WM(2) = HRL1 + IF (HRL1 .EQ. PHRL1) GO TO 330 + R = HRL1/PHRL1 + DO 320 I = 1,N + DI = ONE - R*(ONE - ONE/WM(I+2)) + IF (ABS(DI) .EQ. ZERO) GO TO 390 + 320 WM(I+2) = ONE/DI +C + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL KppSolve (WM(3), X) + RETURN +C----------------------- End of Subroutine DVSOL ----------------------- + END +*DECK DVSRCO + SUBROUTINE DVSRCO (RSAV, ISAV, JOB) + KPP_REAL RSAV + INTEGER ISAV, JOB + DIMENSION RSAV(*), ISAV(*) +C----------------------------------------------------------------------- +C Call sequence input -- RSAV, ISAV, JOB +C Call sequence output -- RSAV, ISAV +C COMMON block variables accessed -- All of /DVOD01/ and /DVOD02/ +C +C Subroutines/functions called by DVSRCO.. None +C----------------------------------------------------------------------- +C This routine saves or restores (depending on JOB) the contents of the +C COMMON blocks DVOD01 and DVOD02, which are used internally by DVODE. +C +C RSAV = real array of length 49 or more. +C ISAV = integer array of length 41 or more. +C JOB = flag indicating to save or restore the COMMON blocks.. +C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). +C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). +C A CALL with JOB = 2 presumes a prior CALL with JOB = 1. +C----------------------------------------------------------------------- + KPP_REAL RVOD1, RVOD2 + INTEGER IVOD1, IVOD2 + INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE LENRV1, LENIV1, LENRV2, LENIV2 +C + COMMON /DVOD01/ RVOD1(48), IVOD1(33) + COMMON /DVOD02/ RVOD2(1), IVOD2(8) + DATA LENRV1/48/, LENIV1/33/, LENRV2/1/, LENIV2/8/ +C + IF (JOB .EQ. 2) GO TO 100 + DO 10 I = 1,LENRV1 + 10 RSAV(I) = RVOD1(I) + DO 15 I = 1,LENRV2 + 15 RSAV(LENRV1+I) = RVOD2(I) +C + DO 20 I = 1,LENIV1 + 20 ISAV(I) = IVOD1(I) + DO 25 I = 1,LENIV2 + 25 ISAV(LENIV1+I) = IVOD2(I) +C + RETURN +C + 100 CONTINUE + DO 110 I = 1,LENRV1 + 110 RVOD1(I) = RSAV(I) + DO 115 I = 1,LENRV2 + 115 RVOD2(I) = RSAV(LENRV1+I) +C + DO 120 I = 1,LENIV1 + 120 IVOD1(I) = ISAV(I) + DO 125 I = 1,LENIV2 + 125 IVOD2(I) = ISAV(LENIV1+I) +C + RETURN +C----------------------- End of Subroutine DVSRCO ---------------------- + END +*DECK DEWSET + SUBROUTINE DEWSET (N, ITOL, RelTol, AbsTol, YCUR, EWT) + KPP_REAL RelTol, AbsTol, YCUR, EWT + INTEGER N, ITOL + DIMENSION RelTol(*), AbsTol(*), YCUR(N), EWT(N) +C----------------------------------------------------------------------- +C Call sequence input -- N, ITOL, RelTol, AbsTol, YCUR +C Call sequence output -- EWT +C COMMON block variables accessed -- None +C +C Subroutines/functions called by DEWSET.. None +C----------------------------------------------------------------------- +C This subroutine sets the error weight vector EWT according to +C EWT(i) = RelTol(i)*abs(YCUR(i)) + AbsTol(i), i = 1,...,N, +C with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, +C depending on the value of ITOL. +C----------------------------------------------------------------------- + INTEGER I +C + GO TO (10, 20, 30, 40), ITOL + 10 CONTINUE + DO 15 I = 1, N + 15 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(1) + RETURN + 20 CONTINUE + DO 25 I = 1, N + 25 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(I) + RETURN + 30 CONTINUE + DO 35 I = 1, N + 35 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(1) + RETURN + 40 CONTINUE + DO 45 I = 1, N + 45 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(I) + RETURN +C----------------------- End of Subroutine DEWSET ---------------------- + END +*DECK DVNORM + KPP_REAL FUNCTION DVNORM (N, V, W) + KPP_REAL V, W + INTEGER N + DIMENSION V(N), W(N) +C----------------------------------------------------------------------- +C Call sequence input -- N, V, W +C Call sequence output -- None +C COMMON block variables accessed -- None +C +C Subroutines/functions called by DVNORM.. None +C----------------------------------------------------------------------- +C This function routine computes the weighted root-mean-square norm +C of the vector of length N contained in the array V, with weights +C contained in the array W of length N.. +C DVNORM = sqrt( (1/N) * sum( V(i)*W(i) )**2 ) +C +C LOOP UNROLLING BY ADRIAN SANDU, AUG 2, 1995 +C +C----------------------------------------------------------------------- + KPP_REAL SUM + INTEGER I +C + SUM = 0.0D0 + + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + SUM = SUM + (V(I)*W(I))**2 + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + SUM = SUM + (V(I)*W(I))**2 + SUM = SUM + (V(I + 1)*W(I + 1))**2 + SUM = SUM + (V(I + 2)*W(I + 2))**2 + SUM = SUM + (V(I + 3)*W(I + 3))**2 + SUM = SUM + (V(I + 4)*W(I + 4))**2 + SUM = SUM + (V(I + 5)*W(I + 5))**2 + SUM = SUM + (V(I + 6)*W(I + 6))**2 + 50 continue + + DVNORM = SQRT(SUM/REAL(N)) + RETURN +C----------------------- End of Function DVNORM ------------------------ + END + +*DECK D1MACH + KPP_REAL FUNCTION D1MACH (IDUM) + INTEGER IDUM +C----------------------------------------------------------------------- +C This routine computes the unit roundoff of the machine. +C This is defined as the smallest positive machine number +C u such that 1.0 + u .ne. 1.0 +C +C Subroutines/functions called by D1MACH.. None +C----------------------------------------------------------------------- + KPP_REAL U, COMP + U = 1.0D0 + 10 U = U*0.5D0 + COMP = 1.0D0 + U + IF (COMP .NE. 1.0D0) GO TO 10 + D1MACH = U*2.0D0 + RETURN +C----------------------- End of Function D1MACH ------------------------ + END +*DECK XERRWD + SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) + KPP_REAL R1, R2 + INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR + CHARACTER*1 MSG(NMES) +C----------------------------------------------------------------------- +C Subroutines XERRWD, XSETF, XSETUN, and the two function routines +C MFLGSV and LUNSAV, as given here, constitute a simplified version of +C the SLATEC error handling package. +C Written by A. C. Hindmarsh and P. N. Brown at LLNL. +C Version of 13 April, 1989. +C This version is in KPP_REAL. +C +C All arguments are input arguments. +C +C MSG = The message (character array). +C NMES = The length of MSG (number of characters). +C NERR = The error number (not used). +C LEVEL = The error level.. +C 0 or 1 means recoverable (control returns to caller). +C 2 means fatal (run is aborted--see note below). +C NI = Number of integers (0, 1, or 2) to be printed with message. +C I1,I2 = Integers to be printed, depending on NI. +C NR = Number of reals (0, 1, or 2) to be printed with message. +C R1,R2 = Reals to be printed, depending on NR. +C +C Note.. this routine is machine-dependent and specialized for use +C in limited context, in the following ways.. +C 1. The argument MSG is assumed to be of type CHARACTER, and +C the message is printed with a format of (1X,80A1). +C 2. The message is assumed to take only one line. +C Multi-line messages are generated by repeated calls. +C 3. If LEVEL = 2, control passes to the statement STOP +C to abort the run. This statement may be machine-dependent. +C 4. R1 and R2 are assumed to be in KPP_REAL and are printed +C in D21.13 format. +C +C For a different default logical unit number, change the data +C statement in function routine LUNSAV. +C For a different run-abort command, change the statement following +C statement 100 at the end. +C----------------------------------------------------------------------- +C Subroutines called by XERRWD.. None +C Function routines called by XERRWD.. MFLGSV, LUNSAV +C----------------------------------------------------------------------- +C + INTEGER I, LUNIT, LUNSAV, MESFLG, MFLGSV +C +C Get message print flag and logical unit number. ---------------------- + MESFLG = MFLGSV (0,.FALSE.) + LUNIT = LUNSAV (0,.FALSE.) + IF (MESFLG .EQ. 0) GO TO 100 +C Write the message. --------------------------------------------------- + WRITE (LUNIT,10) (MSG(I),I=1,NMES) + 10 FORMAT(1X,80A1) + IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 + 20 FORMAT(6X,'In above message, I1 =',I10) + IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 + 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) + IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 + 40 FORMAT(6X,'In above message, R1 =',D21.13) + IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 + 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) +C Abort the run if LEVEL = 2. ------------------------------------------ + 100 IF (LEVEL .NE. 2) RETURN + STOP +C----------------------- End of Subroutine XERRWD ---------------------- + END +*DECK XSETF + SUBROUTINE XSETF (MFLAG) +C----------------------------------------------------------------------- +C This routine resets the print control flag MFLAG. +C +C Subroutines called by XSETF.. None +C Function routines called by XSETF.. MFLGSV +C----------------------------------------------------------------------- + INTEGER MFLAG, JUNK, MFLGSV +C + IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = MFLGSV (MFLAG,.TRUE.) + RETURN +C----------------------- End of Subroutine XSETF ----------------------- + END +*DECK XSETUN + SUBROUTINE XSETUN (LUN) +C----------------------------------------------------------------------- +C This routine resets the logical unit number for messages. +C +C Subroutines called by XSETUN.. None +C Function routines called by XSETUN.. LUNSAV +C----------------------------------------------------------------------- + INTEGER LUN, JUNK, LUNSAV +C + IF (LUN .GT. 0) JUNK = LUNSAV (LUN,.TRUE.) + RETURN +C----------------------- End of Subroutine XSETUN ---------------------- + END +*DECK MFLGSV + INTEGER FUNCTION MFLGSV (IVALUE, ISET) + LOGICAL ISET + INTEGER IVALUE +C----------------------------------------------------------------------- +C MFLGSV saves and recalls the parameter MESFLG which controls the +C printing of the error messages. +C +C Saved local variable.. +C +C MESFLG = Print control flag.. +C 1 means print all messages (the default). +C 0 means no printing. +C +C On input.. +C +C IVALUE = The value to be set for the MESFLG parameter, +C if ISET is .TRUE. . +C +C ISET = Logical flag to indicate whether to read or write. +C If ISET=.TRUE., the MESFLG parameter will be given +C the value IVALUE. If ISET=.FALSE., the MESFLG +C parameter will be unchanged, and IVALUE is a dummy +C parameter. +C +C On return.. +C +C The (old) value of the MESFLG parameter will be returned +C in the function value, MFLGSV. +C +C This is a modification of the SLATEC library routine J4SAVE. +C +C Subroutines/functions called by MFLGSV.. None +C----------------------------------------------------------------------- + INTEGER MESFLG +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE MESFLG + DATA MESFLG/1/ +C + MFLGSV = MESFLG + IF (ISET) MESFLG = IVALUE + RETURN +C----------------------- End of Function MFLGSV ------------------------ + END +*DECK LUNSAV + INTEGER FUNCTION LUNSAV (IVALUE, ISET) + LOGICAL ISET + INTEGER IVALUE +C----------------------------------------------------------------------- +C LUNSAV saves and recalls the parameter LUNIT which is the logical +C unit number to which error messages are printed. +C +C Saved local variable.. +C +C LUNIT = Logical unit number for messages. +C The default is 6 (machine-dependent). +C +C On input.. +C +C IVALUE = The value to be set for the LUNIT parameter, +C if ISET is .TRUE. . +C +C ISET = Logical flag to indicate whether to read or write. +C If ISET=.TRUE., the LUNIT parameter will be given +C the value IVALUE. If ISET=.FALSE., the LUNIT +C parameter will be unchanged, and IVALUE is a dummy +C parameter. +C +C On return.. +C +C The (old) value of the LUNIT parameter will be returned +C in the function value, LUNSAV. +C +C This is a modification of the SLATEC library routine J4SAVE. +C +C Subroutines/functions called by LUNSAV.. None +C----------------------------------------------------------------------- + INTEGER LUNIT +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE LUNIT + DATA LUNIT/6/ +C + LUNSAV = LUNIT + IF (ISET) LUNIT = IVALUE + RETURN +C----------------------- End of Function LUNSAV ------------------------ + END + + SUBROUTINE VODE_FSPLIT_VAR(N, T, Y, PR) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + REAL*8 Told, T + REAL*8 Y(NVAR), PR(NVAR) + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, PR ) + TIME = Told + RETURN + END + + SUBROUTINE VODE_Jac_SP(N, T, Y, J) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + REAL*8 Told, T + REAL*8 Y(NVAR), J(LU_NONZERO) + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.def new file mode 100755 index 00000000..500c6914 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.def @@ -0,0 +1,7 @@ +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW +#DOUBLE ON +#INTFILE kpp_lsode + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.f90 new file mode 100755 index 00000000..d7b0e393 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_lsode.f90 @@ -0,0 +1,3415 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! LSODE - Stiff method based on backward differentiation formulas (BDF) ! +! By default the code employs the KPP sparse linear algebra routines ! +! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! A. Sandu - version of July 2005 + +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision + USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME, ATOL, RTOL + USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO + USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG + USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & + Set2zero, WLAMCH + + IMPLICIT NONE + PUBLIC + SAVE + + !~~~> Statistics on the work performed by the LSODE method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + ! SDIRK method coefficients + KPP_REAL :: rkAlpha(5,4), rkBeta(5,4), rkD(4,5), & + rkGamma, rkA(5,5), rkB(5), rkC(5) + + ! mz_rs_20050717: TODO: use strings of IERR_NAMES for error messages + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Improper value for maximal no of Newton iterations', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE INTEGRATE( TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + IMPLICIT NONE + + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20), IERR +!!$ INTEGER, SAVE :: Ntotal = 0 + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ICNTRL(5) = 2 ! maximal order + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL KppLsode( TIN,TOUT,VAR,RTOL,ATOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + +! mz_rs_20050716: IERR and ISTATUS are returned to the user who then +! decides what to do about it, i.e. either stop the run or ignore it. +!!$ IF (IERR < 0) THEN +!!$ PRINT*,'LSODE: Unsuccessful exit at T=',TIN,' (IERR=',IERR,')' +!!$ STOP +!!$ ENDIF +!!$ Ntotal = Ntotal + ISTATUS(3) +!!$ PRINT*,'Nsteps = ', ISTATUS(3),' (',Ntotal,')' + + STEPMIN = RSTATUS(ihexit) ! Save last step + + ! if optional parameters are given for output they to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) + IF (PRESENT(IERR_U)) IERR_U = IERR + + END SUBROUTINE INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KppLsode( TIN,TOUT,Y,RelTol,AbsTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +!~~~> +! ICNTRL(1) = not used +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) = not used +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0 the default value of 100000 is used +! +! ICNTRL(5) -> maximum order of the integration formula allowed +! +!~~~> Real parameters +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last predicted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + KPP_REAL :: Y(NVAR), AbsTol(NVAR), RelTol(NVAR), TIN, TOUT + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + INTEGER, PARAMETER :: LRW = 25 + 9*NVAR+2*NVAR*NVAR, & + LIW = 32 + NVAR + KPP_REAL :: RWORK(LRW), RPAR(1) + INTEGER :: IWORK(LIW), IPAR(1), ITOL, ITASK, & + IERR, IOPT, MF + + !~~~> NORMAL COMPUTATION + ITASK = 1 + IERR = 1 + IOPT = 1 ! 0=no/1=use optional input + + RWORK(1:30) = 0.0d0 + IWORK(1:30) = 0 + + IF (ICNTRL(2)==0) THEN + ITOL = 4 ! Abs/RelTol are both vectors + ELSE + ITOL = 1 ! Abs/RelTol are both scalars + END IF + IWORK(6) = ICNTRL(4) ! max number of internal steps + IWORK(5) = ICNTRL(5) ! maximal order + + MF = 21 !~~~> stiff case, analytic full Jacobian + + RWORK(5) = RCNTRL(3) ! Hstart + RWORK(6) = RCNTRL(2) ! Hmax + RWORK(7) = RCNTRL(1) ! Hmin + + CALL DLSODE ( FUN_CHEM, NVAR, Y, TIN, TOUT, ITOL, RelTol, AbsTol, ITASK,& + IERR, IOPT, RWORK, LRW, IWORK, LIW, JAC_CHEM, MF) + + ISTATUS(1) = IWORK(12) ! Number of function evaluations + ISTATUS(2) = IWORK(13) ! Number of Jacobian evaluations + ISTATUS(3) = IWORK(11) ! Number of steps + + RSTATUS(1) = TOUT ! mz_rs_20050717 + RSTATUS(2) = RWORK(11) ! mz_rs_20050717 + + END SUBROUTINE KppLsode +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!DECK DLSODE + SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, & + ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) + EXTERNAL F, JAC + INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, LIW, IWORK(LIW), MF + KPP_REAL Y(*), T, TOUT, RelTol(*), AbsTol(*), RWORK(LRW) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!***BEGIN PROLOGUE DLSODE +!***PURPOSE Livermore Solver for Ordinary Differential Equations. +! DLSODE solves the initial-value problem for stiff or +! nonstiff systems of first-order ODE's, +! dy/dt = f(t,y), or, in component form, +! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. +!***CATEGORY I1A +!***TYPE KPP_REAL (SLSODE-S, DLSODE-D) +!***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, +! STIFF, NONSTIFF +!***AUTHOR Hindmarsh, Alan C., (LLNL) +! Center for Applied Scientific Computing, L-561 +! Lawrence Livermore National Laboratory +! Livermore, CA 94551. +!***DESCRIPTION +! +! NOTE: The "Usage" and "Arguments" sections treat only a subset of +! available options, in condensed fashion. The options +! covered and the information supplied will support most +! standard uses of DLSODE. +! +! For more sophisticated uses, full details on all options are +! given in the concluding section, headed "Long Description." +! A synopsis of the DLSODE Long Description is provided at the +! beginning of that section; general topics covered are: +! - Elements of the call sequence; optional input and output +! - Optional supplemental routines in the DLSODE package +! - internal COMMON block +! +! *Usage: +! Communication between the user and the DLSODE package, for normal +! situations, is summarized here. This summary describes a subset +! of the available options. See "Long Description" for complete +! details, including optional communication, nonstandard options, +! and instructions for special situations. +! +! A sample program is given in the "Examples" section. +! +! Refer to the argument descriptions for the definitions of the +! quantities that appear in the following sample declarations. +! +! For MF = 10, +! PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) +! For MF = 21 or 22, +! PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) +! For MF = 24 or 25, +! PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, +! * LIW = 20 + NEQ) +! +! EXTERNAL F, JAC +! INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), +! * LIW, MF +! KPP_REAL Y(NEQ), T, TOUT, RelTol, AbsTol(ntol), RWORK(LRW) +! +! CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, +! * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) +! +! *Arguments: +! F :EXT Name of subroutine for right-hand-side vector f. +! This name must be declared EXTERNAL in calling +! program. The form of F must be: +! +! SUBROUTINE F (NEQ, T, Y, YDOT) +! INTEGER NEQ +! KPP_REAL T, Y(*), YDOT(*) +! +! The inputs are NEQ, T, Y. F is to set +! +! YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), +! i = 1, ..., NEQ . +! +! NEQ :IN Number of first-order ODE's. +! +! Y :INOUT Array of values of the y(t) vector, of length NEQ. +! Input: For the first call, Y should contain the +! values of y(t) at t = T. (Y is an input +! variable only if ISTATE = 1.) +! Output: On return, Y will contain the values at the +! new t-value. +! +! T :INOUT Value of the independent variable. On return it +! will be the current value of t (normally TOUT). +! +! TOUT :IN Next point where output is desired (.NE. T). +! +! ITOL :IN 1 or 2 according as AbsTol (below) is a scalar or +! an array. +! +! RelTol :IN Relative tolerance parameter (scalar). +! +! AbsTol :IN Absolute tolerance parameter (scalar or array). +! If ITOL = 1, AbsTol need not be dimensioned. +! If ITOL = 2, AbsTol must be dimensioned at least NEQ. +! +! The estimated local error in Y(i) will be controlled +! so as to be roughly less (in magnitude) than +! +! EWT(i) = RelTol*ABS(Y(i)) + AbsTol if ITOL = 1, or +! EWT(i) = RelTol*ABS(Y(i)) + AbsTol(i) if ITOL = 2. +! +! Thus the local error test passes if, in each +! component, either the absolute error is less than +! AbsTol (or AbsTol(i)), or the relative error is less +! than RelTol. +! +! Use RelTol = 0.0 for pure absolute error control, and +! use AbsTol = 0.0 (or AbsTol(i) = 0.0) for pure relative +! error control. Caution: Actual (global) errors may +! exceed these local tolerances, so choose them +! conservatively. +! +! ITASK :IN Flag indicating the task DLSODE is to perform. +! Use ITASK = 1 for normal computation of output +! values of y at t = TOUT. +! +! ISTATE:INOUT Index used for input and output to specify the state +! of the calculation. +! Input: +! 1 This is the first call for a problem. +! 2 This is a subsequent call. +! Output: +! 1 Nothing was done, because TOUT was equal to T. +! 2 DLSODE was successful (otherwise, negative). +! Note that ISTATE need not be modified after a +! successful return. +! -1 Excess work done on this call (perhaps wrong +! MF). +! -2 Excess accuracy requested (tolerances too +! small). +! -3 Illegal input detected (see printed message). +! -4 Repeated error test failures (check all +! inputs). +! -5 Repeated convergence failures (perhaps bad +! Jacobian supplied or wrong choice of MF or +! tolerances). +! -6 Error weight became zero during problem +! (solution component i vanished, and AbsTol or +! AbsTol(i) = 0.). +! +! IOPT :IN Flag indicating whether optional inputs are used: +! 0 No. +! 1 Yes. (See "Optional inputs" under "Long +! Description," Part 1.) +! +! RWORK :WORK Real work array of length at least: +! 20 + 16*NEQ for MF = 10, +! 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, +! 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. +! +! LRW :IN Declared length of RWORK (in user's DIMENSION +! statement). +! +! IWORK :WORK Integer work array of length at least: +! 20 for MF = 10, +! 20 + NEQ for MF = 21, 22, 24, or 25. +! +! If MF = 24 or 25, input in IWORK(1),IWORK(2) the +! lower and upper Jacobian half-bandwidths ML,MU. +! +! On return, IWORK contains information that may be +! of interest to the user: +! +! Name Location Meaning +! ----- --------- ----------------------------------------- +! NST IWORK(11) Number of steps taken for the problem so +! far. +! NFE IWORK(12) Number of f evaluations for the problem +! so far. +! NJE IWORK(13) Number of Jacobian evaluations (and of +! matrix LU decompositions) for the problem +! so far. +! NQU IWORK(14) Method order last used (successfully). +! LENRW IWORK(17) Length of RWORK actually required. This +! is defined on normal returns and on an +! illegal input return for insufficient +! storage. +! LENIW IWORK(18) Length of IWORK actually required. This +! is defined on normal returns and on an +! illegal input return for insufficient +! storage. +! +! LIW :IN Declared length of IWORK (in user's DIMENSION +! statement). +! +! JAC :EXT Name of subroutine for Jacobian matrix (MF = +! 21 or 24). If used, this name must be declared +! EXTERNAL in calling program. If not used, pass a +! dummy name. The form of JAC must be: +! +! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +! INTEGER NEQ, ML, MU, NROWPD +! KPP_REAL T, Y(*), PD(NROWPD,*) +! +! See item c, under "Description" below for more +! information about JAC. +! +! MF :IN Method flag. Standard values are: +! 10 Nonstiff (Adams) method, no Jacobian used. +! 21 Stiff (BDF) method, user-supplied full Jacobian. +! 22 Stiff method, internally generated full +! Jacobian. +! 24 Stiff method, user-supplied banded Jacobian. +! 25 Stiff method, internally generated banded +! Jacobian. +! +! *Description: +! DLSODE solves the initial value problem for stiff or nonstiff +! systems of first-order ODE's, +! +! dy/dt = f(t,y) , +! +! or, in component form, +! +! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) +! (i = 1, ..., NEQ) . +! +! DLSODE is a package based on the GEAR and GEARB packages, and on +! the October 23, 1978, version of the tentative ODEPACK user +! interface standard, with minor modifications. +! +! The steps in solving such a problem are as follows. +! +! a. First write a subroutine of the form +! +! SUBROUTINE F (NEQ, T, Y, YDOT) +! INTEGER NEQ +! KPP_REAL T, Y(*), YDOT(*) +! +! which supplies the vector function f by loading YDOT(i) with +! f(i). +! +! b. Next determine (or guess) whether or not the problem is stiff. +! Stiffness occurs when the Jacobian matrix df/dy has an +! eigenvalue whose real part is negative and large in magnitude +! compared to the reciprocal of the t span of interest. If the +! problem is nonstiff, use method flag MF = 10. If it is stiff, +! there are four standard choices for MF, and DLSODE requires the +! Jacobian matrix in some form. This matrix is regarded either +! as full (MF = 21 or 22), or banded (MF = 24 or 25). In the +! banded case, DLSODE requires two half-bandwidth parameters ML +! and MU. These are, respectively, the widths of the lower and +! upper parts of the band, excluding the main diagonal. Thus the +! band consists of the locations (i,j) with +! +! i - ML <= j <= i + MU , +! +! and the full bandwidth is ML + MU + 1 . +! +! c. If the problem is stiff, you are encouraged to supply the +! Jacobian directly (MF = 21 or 24), but if this is not feasible, +! DLSODE will compute it internally by difference quotients (MF = +! 22 or 25). If you are supplying the Jacobian, write a +! subroutine of the form +! +! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +! INTEGER NEQ, ML, MU, NRWOPD +! KPP_REAL T, Y(*), PD(NROWPD,*) +! +! which provides df/dy by loading PD as follows: +! - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), +! the partial derivative of f(i) with respect to y(j). (Ignore +! the ML and MU arguments in this case.) +! - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with +! df(i)/dy(j); i.e., load the diagonal lines of df/dy into the +! rows of PD from the top down. +! - In either case, only nonzero elements need be loaded. +! +! d. Write a main program that calls subroutine DLSODE once for each +! point at which answers are desired. This should also provide +! for possible use of logical unit 6 for output of error messages +! by DLSODE. +! +! Before the first call to DLSODE, set ISTATE = 1, set Y and T to +! the initial values, and set TOUT to the first output point. To +! continue the integration after a successful return, simply +! reset TOUT and call DLSODE again. No other parameters need be +! reset. +! +! *Examples: +! The following is a simple example problem, with the coding needed +! for its solution by DLSODE. The problem is from chemical kinetics, +! and consists of the following three rate equations: +! +! dy1/dt = -.04*y1 + 1.E4*y2*y3 +! dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 +! dy3/dt = 3.E7*y2**2 +! +! on the interval from t = 0.0 to t = 4.E10, with initial conditions +! y1 = 1.0, y2 = y3 = 0. The problem is stiff. +! +! The following coding solves this problem with DLSODE, using +! MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses +! ITOL = 2 and AbsTol much smaller for y2 than for y1 or y3 because y2 +! has much smaller values. At the end of the run, statistical +! quantities of interest are printed. +! +! EXTERNAL FEX, JEX +! INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, +! * MF, NEQ +! KPP_REAL AbsTol(3), RelTol, RWORK(58), T, TOUT, Y(3) +! NEQ = 3 +! Y(1) = 1.D0 +! Y(2) = 0.D0 +! Y(3) = 0.D0 +! T = 0.D0 +! TOUT = .4D0 +! ITOL = 2 +! RelTol = 1.D-4 +! AbsTol(1) = 1.D-6 +! AbsTol(2) = 1.D-10 +! AbsTol(3) = 1.D-6 +! ITASK = 1 +! ISTATE = 1 +! IOPT = 0 +! LRW = 58 +! LIW = 23 +! MF = 21 +! DO 40 IOUT = 1,12 +! CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RelTol, AbsTol, ITASK, +! * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) +! WRITE(6,20) T, Y(1), Y(2), Y(3) +! 20 FORMAT(' At t =',D12.4,' y =',3D14.6) +! IF (ISTATE .LT. 0) GO TO 80 +! 40 TOUT = TOUT*10.D0 +! WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) +! 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) +! STOP +! 80 WRITE(6,90) ISTATE +! 90 FORMAT(///' Error halt.. ISTATE =',I3) +! STOP +! END +! +! SUBROUTINE FEX (NEQ, T, Y, YDOT) +! INTEGER NEQ +! KPP_REAL T, Y(3), YDOT(3) +! YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) +! YDOT(3) = 3.D7*Y(2)*Y(2) +! YDOT(2) = -YDOT(1) - YDOT(3) +! RETURN +! END +! +! SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) +! INTEGER NEQ, ML, MU, NRPD +! KPP_REAL T, Y(3), PD(NRPD,3) +! PD(1,1) = -.04D0 +! PD(1,2) = 1.D4*Y(3) +! PD(1,3) = 1.D4*Y(2) +! PD(2,1) = .04D0 +! PD(2,3) = -PD(1,3) +! PD(3,2) = 6.D7*Y(2) +! PD(2,2) = -PD(1,2) - PD(3,2) +! RETURN +! END +! +! The output from this program (on a Cray-1 in single precision) +! is as follows. +! +! At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 +! At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 +! At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 +! At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 +! At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 +! At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 +! At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 +! At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 +! At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 +! At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 +! At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 +! At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 +! +! No. steps = 330, No. f-s = 405, No. J-s = 69 +! +! *Accuracy: +! The accuracy of the solution depends on the choice of tolerances +! RelTol and AbsTol. Actual (global) errors may exceed these local +! tolerances, so choose them conservatively. +! +! *Cautions: +! The work arrays should not be altered between calls to DLSODE for +! the same problem, except possibly for the conditional and optional +! inputs. +! +! *Portability: +! Since NEQ is dimensioned inside DLSODE, some compilers may object +! to a call to DLSODE with NEQ a scalar variable. In this event, +! use DIMENSION NEQ. Similar remarks apply to RelTol and AbsTol. +! +! Note to Cray users: +! For maximum efficiency, use the CFT77 compiler. Appropriate +! compiler optimization directives have been inserted for CFT77. +! +! *Reference: +! Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE +! Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. +! (North-Holland, Amsterdam, 1983), pp. 55-64. +! +! *Long Description: +! The following complete description of the user interface to +! DLSODE consists of four parts: +! +! 1. The call sequence to subroutine DLSODE, which is a driver +! routine for the solver. This includes descriptions of both +! the call sequence arguments and user-supplied routines. +! Following these descriptions is a description of optional +! inputs available through the call sequence, and then a +! description of optional outputs in the work arrays. +! +! 2. Descriptions of other routines in the DLSODE package that may +! be (optionally) called by the user. These provide the ability +! to alter error message handling, save and restore the internal +! COMMON, and obtain specified derivatives of the solution y(t). +! +! 3. Descriptions of COMMON block to be declared in overlay or +! similar environments, or to be saved when doing an interrupt +! of the problem and continued solution later. +! +! 4. Description of two routines in the DLSODE package, either of +! which the user may replace with his own version, if desired. +! These relate to the measurement of errors. +! +! +! Part 1. Call Sequence +! ---------------------- +! +! Arguments +! --------- +! The call sequence parameters used for input only are +! +! F, NEQ, TOUT, ITOL, RelTol, AbsTol, ITASK, IOPT, LRW, LIW, JAC, MF, +! +! and those used for both input and output are +! +! Y, T, ISTATE. +! +! The work arrays RWORK and IWORK are also used for conditional and +! optional inputs and optional outputs. (The term output here +! refers to the return from subroutine DLSODE to the user's calling +! program.) +! +! The legality of input parameters will be thoroughly checked on the +! initial call for the problem, but not checked thereafter unless a +! change in input parameters is flagged by ISTATE = 3 on input. +! +! The descriptions of the call arguments are as follows. +! +! F The name of the user-supplied subroutine defining the ODE +! system. The system must be put in the first-order form +! dy/dt = f(t,y), where f is a vector-valued function of +! the scalar t and the vector y. Subroutine F is to compute +! the function f. It is to have the form +! +! SUBROUTINE F (NEQ, T, Y, YDOT) +! KPP_REAL T, Y(*), YDOT(*) +! +! where NEQ, T, and Y are input, and the array YDOT = +! f(T,Y) is output. Y and YDOT are arrays of length NEQ. +! Subroutine F should not alter Y(1),...,Y(NEQ). F must be +! declared EXTERNAL in the calling program. +! +! Subroutine F may access user-defined quantities in +! NEQ(2),... and/or in Y(NEQ+1),..., if NEQ is an array +! (dimensioned in F) and/or Y has length exceeding NEQ. +! See the descriptions of NEQ and Y below. +! +! If quantities computed in the F routine are needed +! externally to DLSODE, an extra call to F should be made +! for this purpose, for consistent and accurate results. +! If only the derivative dy/dt is needed, use DINTDY +! instead. +! +! NEQ The size of the ODE system (number of first-order +! ordinary differential equations). Used only for input. +! NEQ may be decreased, but not increased, during the +! problem. If NEQ is decreased (with ISTATE = 3 on input), +! the remaining components of Y should be left undisturbed, +! if these are to be accessed in F and/or JAC. +! +! Normally, NEQ is a scalar, and it is generally referred +! to as a scalar in this user interface description. +! However, NEQ may be an array, with NEQ set to the +! system size. (The DLSODE package accesses only NEQ.) +! In either case, this parameter is passed as the NEQ +! argument in all calls to F and JAC. Hence, if it is an +! array, locations NEQ(2),... may be used to store other +! integer data and pass it to F and/or JAC. Subroutines +! F and/or JAC must include NEQ in a DIMENSION statement +! in that case. +! +! Y A real array for the vector of dependent variables, of +! length NEQ or more. Used for both input and output on +! the first call (ISTATE = 1), and only for output on +! other calls. On the first call, Y must contain the +! vector of initial values. On output, Y contains the +! computed solution vector, evaluated at T. If desired, +! the Y array may be used for other purposes between +! calls to the solver. +! +! This array is passed as the Y argument in all calls to F +! and JAC. Hence its length may exceed NEQ, and locations +! Y(NEQ+1),... may be used to store other real data and +! pass it to F and/or JAC. (The DLSODE package accesses +! only Y(1),...,Y(NEQ).) +! +! T The independent variable. On input, T is used only on +! the first call, as the initial point of the integration. +! On output, after each call, T is the value at which a +! computed solution Y is evaluated (usually the same as +! TOUT). On an error return, T is the farthest point +! reached. +! +! TOUT The next value of T at which a computed solution is +! desired. Used only for input. +! +! When starting the problem (ISTATE = 1), TOUT may be equal +! to T for one call, then should not equal T for the next +! call. For the initial T, an input value of TOUT .NE. T +! is used in order to determine the direction of the +! integration (i.e., the algebraic sign of the step sizes) +! and the rough scale of the problem. Integration in +! either direction (forward or backward in T) is permitted. +! +! If ITASK = 2 or 5 (one-step modes), TOUT is ignored +! after the first call (i.e., the first call with +! TOUT .NE. T). Otherwise, TOUT is required on every call. +! +! If ITASK = 1, 3, or 4, the values of TOUT need not be +! monotone, but a value of TOUT which backs up is limited +! to the current internal T interval, whose endpoints are +! TCUR - HU and TCUR. (See "Optional Outputs" below for +! TCUR and HU.) +! +! +! ITOL An indicator for the type of error control. See +! description below under AbsTol. Used only for input. +! +! RelTol A relative error tolerance parameter, either a scalar or +! an array of length NEQ. See description below under +! AbsTol. Input only. +! +! AbsTol An absolute error tolerance parameter, either a scalar or +! an array of length NEQ. Input only. +! +! The input parameters ITOL, RelTol, and AbsTol determine the +! error control performed by the solver. The solver will +! control the vector e = (e(i)) of estimated local errors +! in Y, according to an inequality of the form +! +! rms-norm of ( e(i)/EWT(i) ) <= 1, +! +! where +! +! EWT(i) = RelTol(i)*ABS(Y(i)) + AbsTol(i), +! +! and the rms-norm (root-mean-square norm) here is +! +! rms-norm(v) = SQRT(sum v(i)**2 / NEQ). +! +! Here EWT = (EWT(i)) is a vector of weights which must +! always be positive, and the values of RelTol and AbsTol +! should all be nonnegative. The following table gives the +! types (scalar/array) of RelTol and AbsTol, and the +! corresponding form of EWT(i). +! +! ITOL RelTol AbsTol EWT(i) +! ---- ------ ------ ----------------------------- +! 1 scalar scalar RelTol*ABS(Y(i)) + AbsTol +! 2 scalar array RelTol*ABS(Y(i)) + AbsTol(i) +! 3 array scalar RelTol(i)*ABS(Y(i)) + AbsTol +! 4 array array RelTol(i)*ABS(Y(i)) + AbsTol(i) +! +! When either of these parameters is a scalar, it need not +! be dimensioned in the user's calling program. +! +! If none of the above choices (with ITOL, RelTol, and AbsTol +! fixed throughout the problem) is suitable, more general +! error controls can be obtained by substituting +! user-supplied routines for the setting of EWT and/or for +! the norm calculation. See Part 4 below. +! +! If global errors are to be estimated by making a repeated +! run on the same problem with smaller tolerances, then all +! components of RelTol and AbsTol (i.e., of EWT) should be +! scaled down uniformly. +! +! ITASK An index specifying the task to be performed. Input +! only. ITASK has the following values and meanings: +! 1 Normal computation of output values of y(t) at +! t = TOUT (by overshooting and interpolating). +! 2 Take one step only and return. +! 3 Stop at the first internal mesh point at or beyond +! t = TOUT and return. +! 4 Normal computation of output values of y(t) at +! t = TOUT but without overshooting t = TCRIT. TCRIT +! must be input as RWORK(1). TCRIT may be equal to or +! beyond TOUT, but not behind it in the direction of +! integration. This option is useful if the problem +! has a singularity at or beyond t = TCRIT. +! 5 Take one step, without passing TCRIT, and return. +! TCRIT must be input as RWORK(1). +! +! Note: If ITASK = 4 or 5 and the solver reaches TCRIT +! (within roundoff), it will return T = TCRIT (exactly) to +! indicate this (unless ITASK = 4 and TOUT comes before +! TCRIT, in which case answers at T = TOUT are returned +! first). +! +! ISTATE An index used for input and output to specify the state +! of the calculation. +! +! On input, the values of ISTATE are as follows: +! 1 This is the first call for the problem +! (initializations will be done). See "Note" below. +! 2 This is not the first call, and the calculation is to +! continue normally, with no change in any input +! parameters except possibly TOUT and ITASK. (If ITOL, +! RelTol, and/or AbsTol are changed between calls with +! ISTATE = 2, the new values will be used but not +! tested for legality.) +! 3 This is not the first call, and the calculation is to +! continue normally, but with a change in input +! parameters other than TOUT and ITASK. Changes are +! allowed in NEQ, ITOL, RelTol, AbsTol, IOPT, LRW, LIW, MF, +! ML, MU, and any of the optional inputs except H0. +! (See IWORK description for ML and MU.) +! +! Note: A preliminary call with TOUT = T is not counted as +! a first call here, as no initialization or checking of +! input is done. (Such a call is sometimes useful for the +! purpose of outputting the initial conditions.) Thus the +! first call for which TOUT .NE. T requires ISTATE = 1 on +! input. +! +! On output, ISTATE has the following values and meanings: +! 1 Nothing was done, as TOUT was equal to T with +! ISTATE = 1 on input. +! 2 The integration was performed successfully. +! -1 An excessive amount of work (more than MXSTEP steps) +! was done on this call, before completing the +! requested task, but the integration was otherwise +! successful as far as T. (MXSTEP is an optional input +! and is normally 500.) To continue, the user may +! simply reset ISTATE to a value >1 and call again (the +! excess work step counter will be reset to 0). In +! addition, the user may increase MXSTEP to avoid this +! error return; see "Optional Inputs" below. +! -2 Too much accuracy was requested for the precision of +! the machine being used. This was detected before +! completing the requested task, but the integration +! was successful as far as T. To continue, the +! tolerance parameters must be reset, and ISTATE must +! be set to 3. The optional output TOLSF may be used +! for this purpose. (Note: If this condition is +! detected before taking any steps, then an illegal +! input return (ISTATE = -3) occurs instead.) +! -3 Illegal input was detected, before taking any +! integration steps. See written message for details. +! (Note: If the solver detects an infinite loop of +! calls to the solver with illegal input, it will cause +! the run to stop.) +! -4 There were repeated error-test failures on one +! attempted step, before completing the requested task, +! but the integration was successful as far as T. The +! problem may have a singularity, or the input may be +! inappropriate. +! -5 There were repeated convergence-test failures on one +! attempted step, before completing the requested task, +! but the integration was successful as far as T. This +! may be caused by an inaccurate Jacobian matrix, if +! one is being used. +! -6 EWT(i) became zero for some i during the integration. +! Pure relative error control (AbsTol(i)=0.0) was +! requested on a variable which has now vanished. The +! integration was successful as far as T. +! +! Note: Since the normal output value of ISTATE is 2, it +! does not need to be reset for normal continuation. Also, +! since a negative input value of ISTATE will be regarded +! as illegal, a negative output value requires the user to +! change it, and possibly other inputs, before calling the +! solver again. +! +! IOPT An integer flag to specify whether any optional inputs +! are being used on this call. Input only. The optional +! inputs are listed under a separate heading below. +! 0 No optional inputs are being used. Default values +! will be used in all cases. +! 1 One or more optional inputs are being used. +! +! RWORK A real working array (double precision). The length of +! RWORK must be at least +! +! 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM +! +! where +! NYH = the initial value of NEQ, +! MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a +! smaller value is given as an optional input), +! LWM = 0 if MITER = 0, +! LWM = NEQ**2 + 2 if MITER = 1 or 2, +! LWM = NEQ + 2 if MITER = 3, and +! LWM = (2*ML + MU + 1)*NEQ + 2 +! if MITER = 4 or 5. +! (See the MF description below for METH and MITER.) +! +! Thus if MAXORD has its default value and NEQ is constant, +! this length is: +! 20 + 16*NEQ for MF = 10, +! 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, +! 22 + 17*NEQ for MF = 13, +! 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, +! 20 + 9*NEQ for MF = 20, +! 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, +! 22 + 10*NEQ for MF = 23, +! 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. +! +! The first 20 words of RWORK are reserved for conditional +! and optional inputs and optional outputs. +! +! The following word in RWORK is a conditional input: +! RWORK(1) = TCRIT, the critical value of t which the +! solver is not to overshoot. Required if ITASK +! is 4 or 5, and ignored otherwise. See ITASK. +! +! LRW The length of the array RWORK, as declared by the user. +! (This will be checked by the solver.) +! +! IWORK An integer work array. Its length must be at least +! 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or +! 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). +! (See the MF description below for MITER.) The first few +! words of IWORK are used for conditional and optional +! inputs and optional outputs. +! +! The following two words in IWORK are conditional inputs: +! IWORK(1) = ML These are the lower and upper half- +! IWORK(2) = MU bandwidths, respectively, of the banded +! Jacobian, excluding the main diagonal. +! The band is defined by the matrix locations +! (i,j) with i - ML <= j <= i + MU. ML and MU +! must satisfy 0 <= ML,MU <= NEQ - 1. These are +! required if MITER is 4 or 5, and ignored +! otherwise. ML and MU may in fact be the band +! parameters for a matrix to which df/dy is only +! approximately equal. +! +! LIW The length of the array IWORK, as declared by the user. +! (This will be checked by the solver.) +! +! Note: The work arrays must not be altered between calls to DLSODE +! for the same problem, except possibly for the conditional and +! optional inputs, and except for the last 3*NEQ words of RWORK. +! The latter space is used for internal scratch space, and so is +! available for use by the user outside DLSODE between calls, if +! desired (but not for use by F or JAC). +! +! JAC The name of the user-supplied routine (MITER = 1 or 4) to +! compute the Jacobian matrix, df/dy, as a function of the +! scalar t and the vector y. (See the MF description below +! for MITER.) It is to have the form +! +! SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) +! KPP_REAL T, Y(*), PD(NROWPD,*) +! +! where NEQ, T, Y, ML, MU, and NROWPD are input and the +! array PD is to be loaded with partial derivatives +! (elements of the Jacobian matrix) on output. PD must be +! given a first dimension of NROWPD. T and Y have the same +! meaning as in subroutine F. +! +! In the full matrix case (MITER = 1), ML and MU are +! ignored, and the Jacobian is to be loaded into PD in +! columnwise manner, with df(i)/dy(j) loaded into PD(i,j). +! +! In the band matrix case (MITER = 4), the elements within +! the band are to be loaded into PD in columnwise manner, +! with diagonal lines of df/dy loaded into the rows of PD. +! Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML +! and MU are the half-bandwidth parameters (see IWORK). +! The locations in PD in the two triangular areas which +! correspond to nonexistent matrix elements can be ignored +! or loaded arbitrarily, as they are overwritten by DLSODE. +! +! JAC need not provide df/dy exactly. A crude approximation +! (possibly with a smaller bandwidth) will do. +! +! In either case, PD is preset to zero by the solver, so +! that only the nonzero elements need be loaded by JAC. +! Each call to JAC is preceded by a call to F with the same +! arguments NEQ, T, and Y. Thus to gain some efficiency, +! intermediate quantities shared by both calculations may +! be saved in a user COMMON block by F and not recomputed +! by JAC, if desired. Also, JAC may alter the Y array, if +! desired. JAC must be declared EXTERNAL in the calling +! program. +! +! Subroutine JAC may access user-defined quantities in +! NEQ(2),... and/or in Y(NEQ+1),... if NEQ is an array +! (dimensioned in JAC) and/or Y has length exceeding +! NEQ. See the descriptions of NEQ and Y above. +! +! MF The method flag. Used only for input. The legal values +! of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, +! and 25. MF has decimal digits METH and MITER: +! MF = 10*METH + MITER . +! +! METH indicates the basic linear multistep method: +! 1 Implicit Adams method. +! 2 Method based on backward differentiation formulas +! (BDF's). +! +! MITER indicates the corrector iteration method: +! 0 Functional iteration (no Jacobian matrix is +! involved). +! 1 Chord iteration with a user-supplied full (NEQ by +! NEQ) Jacobian. +! 2 Chord iteration with an internally generated +! (difference quotient) full Jacobian (using NEQ +! extra calls to F per df/dy value). +! 3 Chord iteration with an internally generated +! diagonal Jacobian approximation (using one extra call +! to F per df/dy evaluation). +! 4 Chord iteration with a user-supplied banded Jacobian. +! 5 Chord iteration with an internally generated banded +! Jacobian (using ML + MU + 1 extra calls to F per +! df/dy evaluation). +! +! If MITER = 1 or 4, the user must supply a subroutine JAC +! (the name is arbitrary) as described above under JAC. +! For other values of MITER, a dummy argument can be used. +! +! Optional Inputs +! --------------- +! The following is a list of the optional inputs provided for in the +! call sequence. (See also Part 2.) For each such input variable, +! this table lists its name as used in this documentation, its +! location in the call sequence, its meaning, and the default value. +! The use of any of these inputs requires IOPT = 1, and in that case +! all of these inputs are examined. A value of zero for any of +! these optional inputs will cause the default value to be used. +! Thus to use a subset of the optional inputs, simply preload +! locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, +! and then set those of interest to nonzero values. +! +! Name Location Meaning and default value +! ------ --------- ----------------------------------------------- +! H0 RWORK(5) Step size to be attempted on the first step. +! The default value is determined by the solver. +! HMAX RWORK(6) Maximum absolute step size allowed. The +! default value is infinite. +! HMIN RWORK(7) Minimum absolute step size allowed. The +! default value is 0. (This lower bound is not +! enforced on the final step before reaching +! TCRIT when ITASK = 4 or 5.) +! MAXORD IWORK(5) Maximum order to be allowed. The default value +! is 12 if METH = 1, and 5 if METH = 2. (See the +! MF description above for METH.) If MAXORD +! exceeds the default value, it will be reduced +! to the default value. If MAXORD is changed +! during the problem, it may cause the current +! order to be reduced. +! MXSTEP IWORK(6) Maximum number of (internally defined) steps +! allowed during one call to the solver. The +! default value is 500. +! MXHNIL IWORK(7) Maximum number of messages printed (per +! problem) warning that T + H = T on a step +! (H = step size). This must be positive to +! result in a nondefault value. The default +! value is 10. +! +! Optional Outputs +! ---------------- +! As optional additional output from DLSODE, the variables listed +! below are quantities related to the performance of DLSODE which +! are available to the user. These are communicated by way of the +! work arrays, but also have internal mnemonic names as shown. +! Except where stated otherwise, all of these outputs are defined on +! any successful return from DLSODE, and on any return with ISTATE = +! -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), +! they will be unchanged from their existing values (if any), except +! possibly for TOLSF, LENRW, and LENIW. On any error return, +! outputs relevant to the error will be defined, as noted below. +! +! Name Location Meaning +! ----- --------- ------------------------------------------------ +! HU RWORK(11) Step size in t last used (successfully). +! HCUR RWORK(12) Step size to be attempted on the next step. +! TCUR RWORK(13) Current value of the independent variable which +! the solver has actually reached, i.e., the +! current internal mesh point in t. On output, +! TCUR will always be at least as far as the +! argument T, but may be farther (if interpolation +! was done). +! TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, +! computed when a request for too much accuracy +! was detected (ISTATE = -3 if detected at the +! start of the problem, ISTATE = -2 otherwise). +! If ITOL is left unaltered but RelTol and AbsTol are +! uniformly scaled up by a factor of TOLSF for the +! next call, then the solver is deemed likely to +! succeed. (The user may also ignore TOLSF and +! alter the tolerance parameters in any other way +! appropriate.) +! NST IWORK(11) Number of steps taken for the problem so far. +! NFE IWORK(12) Number of F evaluations for the problem so far. +! NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU +! decompositions) for the problem so far. +! NQU IWORK(14) Method order last used (successfully). +! NQCUR IWORK(15) Order to be attempted on the next step. +! IMXER IWORK(16) Index of the component of largest magnitude in +! the weighted local error vector ( e(i)/EWT(i) ), +! on an error return with ISTATE = -4 or -5. +! LENRW IWORK(17) Length of RWORK actually required. This is +! defined on normal returns and on an illegal +! input return for insufficient storage. +! LENIW IWORK(18) Length of IWORK actually required. This is +! defined on normal returns and on an illegal +! input return for insufficient storage. +! +! The following two arrays are segments of the RWORK array which may +! also be of interest to the user as optional outputs. For each +! array, the table below gives its internal name, its base address +! in RWORK, and its description. +! +! Name Base address Description +! ---- ------------ ---------------------------------------------- +! YH 21 The Nordsieck history array, of size NYH by +! (NQCUR + 1), where NYH is the initial value of +! NEQ. For j = 0,1,...,NQCUR, column j + 1 of +! YH contains HCUR**j/factorial(j) times the jth +! derivative of the interpolating polynomial +! currently representing the solution, evaluated +! at t = TCUR. +! ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated +! corrections on each step, scaled on output to +! represent the estimated local error in Y on +! the last step. This is the vector e in the +! description of the error control. It is +! defined only on successful return from DLSODE. +! +! +! Part 2. Other Callable Routines +! -------------------------------- +! +! The following are optional calls which the user may make to gain +! additional capabilities in conjunction with DLSODE. +! +! Form of call Function +! ------------------------ ---------------------------------------- +! CALL XSETUN(LUN) Set the logical unit number, LUN, for +! output of messages from DLSODE, if the +! default is not desired. The default +! value of LUN is 6. This call may be made +! at any time and will take effect +! immediately. +! CALL XSETF(MFLAG) Set a flag to control the printing of +! messages by DLSODE. MFLAG = 0 means do +! not print. (Danger: this risks losing +! valuable information.) MFLAG = 1 means +! print (the default). This call may be +! made at any time and will take effect +! immediately. +! CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the +! internal COMMON blocks used by DLSODE +! (see Part 3 below). RSAV must be a +! real array of length 218 or more, and +! ISAV must be an integer array of length +! 37 or more. JOB = 1 means save COMMON +! into RSAV/ISAV. JOB = 2 means restore +! COMMON from same. DSRCOM is useful if +! one is interrupting a run and restarting +! later, or alternating between two or +! more problems solved with DLSODE. +! CALL DINTDY(,,,,,) Provide derivatives of y, of various +! (see below) orders, at a specified point t, if +! desired. It may be called only after a +! successful return from DLSODE. Detailed +! instructions follow. +! +! Detailed instructions for using DINTDY +! -------------------------------------- +! The form of the CALL is: +! +! CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) +! +! The input parameters are: +! +! T Value of independent variable where answers are +! desired (normally the same as the T last returned by +! DLSODE). For valid results, T must lie between +! TCUR - HU and TCUR. (See "Optional Outputs" above +! for TCUR and HU.) +! K Integer order of the derivative desired. K must +! satisfy 0 <= K <= NQCUR, where NQCUR is the current +! order (see "Optional Outputs"). The capability +! corresponding to K = 0, i.e., computing y(t), is +! already provided by DLSODE directly. Since +! NQCUR >= 1, the first derivative dy/dt is always +! available with DINTDY. +! RWORK(21) The base address of the history array YH. +! NYH Column length of YH, equal to the initial value of NEQ. +! +! The output parameters are: +! +! DKY Real array of length NEQ containing the computed value +! of the Kth derivative of y(t). +! IFLAG Integer flag, returned as 0 if K and T were legal, +! -1 if K was illegal, and -2 if T was illegal. +! On an error return, a message is also written. +! +! +! Part 3. Common Blocks +! ---------------------- +! +! If DLSODE is to be used in an overlay situation, the user must +! declare, in the primary overlay, the variables in: +! (1) the call sequence to DLSODE, +! (2) the internal COMMON block /DLS001/, of length 255 +! (218 double precision words followed by 37 integer words). +! +! If DLSODE is used on a system in which the contents of internal +! COMMON blocks are not preserved between calls, the user should +! declare the above COMMON block in his main program to insure that +! its contents are preserved. +! +! If the solution of a given problem by DLSODE is to be interrupted +! and then later continued, as when restarting an interrupted run or +! alternating between two or more problems, the user should save, +! following the return from the last DLSODE call prior to the +! interruption, the contents of the call sequence variables and the +! internal COMMON block, and later restore these values before the +! next DLSODE call for that problem. In addition, if XSETUN and/or +! XSETF was called for non-default handling of error messages, then +! these calls must be repeated. To save and restore the COMMON +! block, use subroutine DSRCOM (see Part 2 above). +! +! +! Part 4. Optionally Replaceable Solver Routines +! ----------------------------------------------- +! +! Below are descriptions of two routines in the DLSODE package which +! relate to the measurement of errors. Either routine can be +! replaced by a user-supplied version, if desired. However, since +! such a replacement may have a major impact on performance, it +! should be done only when absolutely necessary, and only with great +! caution. (Note: The means by which the package version of a +! routine is superseded by the user's version may be system- +! dependent.) +! +! DEWSET +! ------ +! The following subroutine is called just before each internal +! integration step, and sets the array of error weights, EWT, as +! described under ITOL/RelTol/AbsTol above: +! +! SUBROUTINE DEWSET (NEQ, ITOL, RelTol, AbsTol, YCUR, EWT) +! +! where NEQ, ITOL, RelTol, and AbsTol are as in the DLSODE call +! sequence, YCUR contains the current dependent variable vector, +! and EWT is the array of weights set by DEWSET. +! +! If the user supplies this subroutine, it must return in EWT(i) +! (i = 1,...,NEQ) a positive quantity suitable for comparing errors +! in Y(i) to. The EWT array returned by DEWSET is passed to the +! DVNORM routine (see below), and also used by DLSODE in the +! computation of the optional output IMXER, the diagonal Jacobian +! approximation, and the increments for difference quotient +! Jacobians. +! +! In the user-supplied version of DEWSET, it may be desirable to use +! the current values of derivatives of y. Derivatives up to order NQ +! are available from the history array YH, described above under +! optional outputs. In DEWSET, YH is identical to the YCUR array, +! extended to NQ + 1 columns with a column length of NYH and scale +! factors of H**j/factorial(j). On the first call for the problem, +! given by NST = 0, NQ is 1 and H is temporarily set to 1.0. +! NYH is the initial value of NEQ. The quantities NQ, H, and NST +! can be obtained by including in SEWSET the statements: +! KPP_REAL RLS +! COMMON /DLS001/ RLS(218),ILS(37) +! NQ = ILS(33) +! NST = ILS(34) +! H = RLS(212) +! Thus, for example, the current value of dy/dt can be obtained as +! YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary +! when NST = 0). +! +! DVNORM +! ------ +! DVNORM is a real function routine which computes the weighted +! root-mean-square norm of a vector v: +! +! d = DVNORM (n, v, w) +! +! where: +! n = the length of the vector, +! v = real array of length n containing the vector, +! w = real array of length n containing weights, +! d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). +! +! DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where +! EWT is as set by subroutine DEWSET. +! +! If the user supplies this function, it should return a nonnegative +! value of DVNORM suitable for use in the error control in DLSODE. +! None of the arguments should be altered by DVNORM. For example, a +! user-supplied DVNORM routine might: +! - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +! - Ignore some components of v in the norm, with the effect of +! suppressing the error control on those components of Y. +! --------------------------------------------------------------------- +!***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYYYMMDD) +! 19791129 DATE WRITTEN +! 19791213 Minor changes to declarations; DELP init. in STODE. +! 19800118 Treat NEQ as array; integer declarations added throughout; +! minor changes to prologue. +! 19800306 Corrected TESCO(1,NQP1) setting in CFODE. +! 19800519 Corrected access of YH on forced order reduction; +! numerous corrections to prologues and other comments. +! 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; +! minor corrections to main prologue. +! 19800923 Added zero initialization of HU and NQU. +! 19801218 Revised XERRWD routine; minor corrections to main prologue. +! 19810401 Minor changes to comments and an error message. +! 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags +! JCUR, ICF, IERPJ, IERSL between STODE and subordinates; +! added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; +! reorganized returns from STODE; reorganized type decls.; +! fixed message length in XERRWD; changed default LUNIT to 6; +! changed Common lengths; changed comments throughout. +! 19870330 Major update by ACH: corrected comments throughout; +! removed TRET from Common; rewrote EWSET with 4 loops; +! fixed t test in INTDY; added Cray directives in STODE; +! in STODE, fixed DELP init. and logic around PJAC call; +! combined routines to save/restore Common; +! passed LEVEL = 0 in error message calls (except run abort). +! 19890426 Modified prologue to SLATEC/LDOC format. (FNF) +! 19890501 Many improvements to prologue. (FNF) +! 19890503 A few final corrections to prologue. (FNF) +! 19890504 Minor cosmetic changes. (FNF) +! 19890510 Corrected description of Y in Arguments section. (FNF) +! 19890517 Minor corrections to prologue. (FNF) +! 19920514 Updated with prologue edited 891025 by G. Shaw for manual. +! 19920515 Converted source lines to upper case. (FNF) +! 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH) +! 19920616 Revised prologue comment regarding CFT. (ACH) +! 19921116 Revised prologue comments regarding Common. (ACH). +! 19930326 Added comment about non-reentrancy. (FNF) +! 19930723 Changed D1MACH to DUMACH. (FNF) +! 19930801 Removed ILLIN and NTREP from Common (affects driver logic); +! minor changes to prologue and internal comments; +! changed Hollerith strings to quoted strings; +! changed internal comments to mixed case; +! replaced XERRWD with new version using character type; +! changed dummy dimensions from 1 to *. (ACH) +! 19930809 Changed to generic intrinsic names; changed names of +! subprograms and Common blocks to DLSODE etc. (ACH) +! 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) +! 20010412 Removed all 'own' variables from Common block /DLS001/ +! (affects declarations in 6 routines). (ACH) +! 20010509 Minor corrections to prologue. (ACH) +! 20031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +! 20031112 Added SAVE statements for data-loaded constants. +! +!***END PROLOGUE DLSODE +! +!*Internal Notes: +! +! Other Routines in the DLSODE Package. +! +! In addition to Subroutine DLSODE, the DLSODE package includes the +! following subroutines and function routines: +! DINTDY computes an interpolated value of the y vector at t = TOUT. +! DSTODE is the core integrator, which does one step of the +! integration and the associated error control. +! DCFODE sets all method coefficients and test constants. +! DPREPJ computes and preprocesses the Jacobian matrix J = df/dy +! and the Newton iteration matrix P = I - h*l0*J. +! DSOLSY manages solution of linear system in chord iteration. +! DEWSET sets the error weight vector EWT before each step. +! DVNORM computes the weighted R.M.S. norm of a vector. +! DSRCOM is a user-callable routine to save and restore +! the contents of the internal Common block. +! DGEFA and DGESL are routines from LINPACK for solving full +! systems of linear algebraic equations. +! DGBFA and DGBSL are routines from LINPACK for solving banded +! linear systems. +! DUMACH computes the unit roundoff in a machine-independent manner. +! XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all +! error messages and warnings. XERRWD is machine-dependent. +! Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. +! All the others are subroutines. +! +!**End +! +! Declare externals. +! Note: they are now internal + !EXTERNAL DPREPJ, DSOLSY + !KPP_REAL DUMACH, DVNORM +! +! Declare all other variables. + INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, & + LENIW, LENRW, LENWM, ML, MORD(2), MU, MXHNL0, MXSTP0 + KPP_REAL ROWNS, & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + KPP_REAL AbsTolI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RelTolI, & + TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 + + LOGICAL IHIT + CHARACTER*80 MSG + SAVE MORD, MXSTP0, MXHNL0 +!----------------------------------------------------------------------- +! The following internal Common block contains +! (a) variables which are local to any subroutine but whose values must +! be preserved between calls to the routine ("own" variables), and +! (b) variables which are communicated between subroutines. +! The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE, +! DPREPJ, and DSOLSY. +! Groups of variables are replaced by dummy arrays in the Common +! declarations in routines where those variables are not used. +!----------------------------------------------------------------------- + COMMON /DLS001/ ROWNS(209), & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & + INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +! + DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ +!----------------------------------------------------------------------- +! Block A. +! This code block is executed on every call. +! It tests ISTATE and ITASK for legality and branches appropriately. +! If ISTATE .GT. 1 but the flag INIT shows that initialization has +! not yet been done, an error return occurs. +! If ISTATE = 1 and TOUT = T, return immediately. +!----------------------------------------------------------------------- +! +!***FIRST EXECUTABLE STATEMENT DLSODE + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .EQ. 0) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) RETURN +!----------------------------------------------------------------------- +! Block B. +! The next code block is executed for the initial call (ISTATE = 1), +! or for a continuation call with parameter changes (ISTATE = 3). +! It contains checking of all inputs and various initializations. +! +! First check legality of the non-optional inputs NEQ, ITOL, IOPT, +! MF, ML, and MU. +!----------------------------------------------------------------------- + 20 IF (NEQ .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ .GT. N) GO TO 605 + 25 N = NEQ + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 CONTINUE +! Next process and check the optional inputs. -------------------------- + IF (IOPT .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = 0.0D0 + HMXI = 0.0D0 + HMIN = 0.0D0 + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. 0.0D0) GO TO 615 + HMXI = 0.0D0 + IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. 0.0D0) GO TO 616 +!----------------------------------------------------------------------- +! Set work array pointers and check lengths LRW and LIW. +! Pointers to segments of RWORK and IWORK are named by prefixing L to +! the name of the segment. E.g., the segment YH starts at RWORK(LYH). +! Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. +!----------------------------------------------------------------------- + 60 LYH = 21 + IF (ISTATE .EQ. 1) NYH = N + LWM = LYH + (MAXORD + 1)*NYH + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 + IF (MITER .EQ. 3) LENWM = N + 2 + IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 + LEWT = LWM + LENWM + LSAVF = LEWT + N + LACOR = LSAVF + N + LENRW = LACOR + N - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 20 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +! Check RelTol and AbsTol for legality. ------------------------------------ + RelTolI = RelTol(1) + AbsTolI = AbsTol(1) + DO 70 I = 1,N + IF (ITOL .GE. 3) RelTolI = RelTol(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) + IF (RelTolI .LT. 0.0D0) GO TO 619 + IF (AbsTolI .LT. 0.0D0) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +! If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +! MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- + DO 80 I = 1,N + 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) +! Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + IF (N .EQ. NYH) GO TO 200 +! NEQ was reduced. Zero part of YH to avoid undefined references. ----- + I1 = LYH + L*NYH + I2 = LYH + (MAXORD + 1)*NYH - 1 + IF (I1 .GT. I2) GO TO 200 + DO 95 I = I1,I2 + 95 RWORK(I) = 0.0D0 + GO TO 200 +!----------------------------------------------------------------------- +! Block C. +! The next block is for the initial call only (ISTATE = 1). +! It contains all remaining initializations, the initial call to F, +! and the calculation of the initial step size. +! The error weights in EWT are inverted after being loaded. +!----------------------------------------------------------------------- + 100 UROUND = DUMACH() + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 + IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) & + H0 = TCRIT - T + 110 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + NHNIL = 0 + NST = 0 + NJE = 0 + NSLAST = 0 + HU = 0.0D0 + NQU = 0 + CCMAX = 0.3D0 + MAXCOR = 3 + MSBP = 20 + MXNCF = 10 +! Initial call to F. (LF0 points to YH(*,2).) ------------------------- + LF0 = LYH + NYH + CALL F (NEQ, T, Y, RWORK(LF0)) + NFE = 1 +! Load the initial value vector in YH. --------------------------------- + DO 115 I = 1,N + 115 RWORK(I+LYH-1) = Y(I) +! Load and invert the EWT array. (H is temporarily set to 1.0.) ------- + NQ = 1 + H = 1.0D0 + CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 + 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) +!----------------------------------------------------------------------- +! The coding below computes the step size, H0, to be attempted on the +! first step, unless the user has supplied a value for this. +! First check that TOUT - T differs significantly from zero. +! A scalar tolerance quantity TOL is computed, as MAX(RelTol(I)) +! if this is positive, or MAX(AbsTol(I)/ABS(Y(I))) otherwise, adjusted +! so as to be between 100*UROUND and 1.0E-3. +! Then the computed value H0 is given by.. +! NEQ +! H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) +! 1 +! where w0 = MAX ( ABS(T), ABS(TOUT) ), +! f(i) = i-th component of initial value of f, +! ywt(i) = EWT(i)/TOL (a weight for y(i)). +! The sign of H0 is inferred from the initial values of TOUT and T. +!----------------------------------------------------------------------- + IF (H0 .NE. 0.0D0) GO TO 180 + TDIST = ABS(TOUT - T) + W0 = MAX(ABS(T),ABS(TOUT)) + IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 + TOL = RelTol(1) + IF (ITOL .LE. 2) GO TO 140 + DO 130 I = 1,N + 130 TOL = MAX(TOL,RelTol(I)) + 140 IF (TOL .GT. 0.0D0) GO TO 160 + AbsTolI = AbsTol(1) + DO 150 I = 1,N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) AbsTolI = AbsTol(I) + AYI = ABS(Y(I)) + IF (AYI .NE. 0.0D0) TOL = MAX(TOL,AbsTolI/AYI) + 150 CONTINUE + 160 TOL = MAX(TOL,100.0D0*UROUND) + TOL = MIN(TOL,0.001D0) + SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) + SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 + H0 = 1.0D0/SQRT(SUM) + H0 = MIN(H0,TDIST) + H0 = SIGN(H0,TOUT-T) +! Adjust H0 if necessary to meet HMAX bound. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. 1.0D0) H0 = H0/RH +! Load H with H0 and scale YH(*,2) by H0. ------------------------------ + H = H0 + DO 190 I = 1,N + 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) + GO TO 270 +!----------------------------------------------------------------------- +! Block D. +! The next code block is for continuation calls only (ISTATE = 2 or 3) +! and is to check stop conditions before taking a step. +!----------------------------------------------------------------------- + 200 NSLAST = NST + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) + IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 + IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 + IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 + CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 + H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) + IF (ISTATE .EQ. 2) JSTART = -2 +!----------------------------------------------------------------------- +! Block E. +! The next block is normally executed for all calls and contains +! the call to the one-step core integrator DSTODE. +! +! This is a looping point for the integration steps. +! +! First check for too many steps being taken, update EWT (if not at +! start of problem), check for too much accuracy being requested, and +! check for H below the roundoff level in T. +!----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL DEWSET (N, ITOL, RelTol, AbsTol, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,N + IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 + 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. 1.0D0) GO TO 280 + TOLSF = TOLSF*2.0D0 + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF ((TN + H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + MSG = 'DLSODE- Warning..internal T (=R1) and H (=R2) are' + CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG=' such that in the machine, T + H = T on the next step ' + CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' (H = step size). Solver will continue anyway' + CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + MSG = 'DLSODE- Above warning has been issued I1 times. ' + CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' It will not be issued again for this problem' + CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) + 290 CONTINUE +!----------------------------------------------------------------------- +! CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) +!----------------------------------------------------------------------- + CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), & + RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), & + F, JAC) + !F, JAC, DPREPJ, DSOLSY) + KGO = 1 - KFLAG + GO TO (300, 530, 540), KGO +!----------------------------------------------------------------------- +! Block F. +! The following block handles the case of a successful return from the +! core integrator (KFLAG = 0). Test for stop conditions. +!----------------------------------------------------------------------- + 300 INIT = 1 + GO TO (310, 400, 330, 340, 350), ITASK +! ITASK = 1. If TOUT has been reached, interpolate. ------------------- + 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 + CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +! ITASK = 3. Jump to exit if TOUT was reached. ------------------------ + 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 + GO TO 250 +! ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. + 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 + CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) + IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 + H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) + JSTART = -2 + GO TO 250 +! ITASK = 5. See if TCRIT was reached and jump to exit. --------------- + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX +!----------------------------------------------------------------------- +! Block G. +! The following block handles all successful returns from DLSODE. +! If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. +! ISTATE is set to 2, and the optional outputs are loaded into the +! work arrays before returning. +!----------------------------------------------------------------------- + 400 DO 410 I = 1,N + 410 Y(I) = RWORK(I+LYH-1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +!----------------------------------------------------------------------- +! Block H. +! The following block handles all unsuccessful returns other than +! those for illegal input. First the error message routine is called. +! If there was an error test or convergence test failure, IMXER is set. +! Then Y is loaded from YH and T is set to TN. The optional outputs +! are loaded into the work arrays before returning. +!----------------------------------------------------------------------- +! The maximum number of steps was taken before reaching TOUT. ---------- + 500 MSG = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps ' + CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' taken on this call before reaching TOUT ' + CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) + ISTATE = -1 + GO TO 580 +! EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + MSG = 'DLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.' + CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +! Too much accuracy requested for machine precision. ------------------- + 520 MSG = 'DLSODE- At T (=R1), too much accuracy requested ' + CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' for precision of machine.. see TOLSF (=R2) ' + CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +! KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- + 530 MSG = 'DLSODE- At T(=R1) and step size H(=R2), the error' + CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' test failed repeatedly or with ABS(H) = HMIN' + CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +! KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- + 540 MSG = 'DLSODE- At T (=R1) and step size H (=R2), the ' + CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' corrector convergence failed repeatedly ' + CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG = ' or with ABS(H) = HMIN ' + CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) + ISTATE = -5 +! Compute IMXER if relevant. ------------------------------------------- + 560 BIG = 0.0D0 + IMXER = 1 + DO 570 I = 1,N + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +! Set Y vector, T, and optional outputs. ------------------------------- + 580 DO 590 I = 1,N + 590 Y(I) = RWORK(I+LYH-1) + T = TN + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + RETURN +!----------------------------------------------------------------------- +! Block I. +! The following block handles all error returns due to illegal input +! (ISTATE = -3), as detected before calling the core integrator. +! First the error message routine is called. If the illegal input +! is a negative ISTATE, the run is aborted (apparent infinite loop). +!----------------------------------------------------------------------- + 601 MSG = 'DLSODE- ISTATE (=I1) illegal ' + CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) + IF (ISTATE .LT. 0) GO TO 800 + GO TO 700 + 602 MSG = 'DLSODE- ITASK (=I1) illegal ' + CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 603 MSG = 'DLSODE- ISTATE .GT. 1 but DLSODE not initialized ' + CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 604 MSG = 'DLSODE- NEQ (=I1) .LT. 1 ' + CALL XERRWD (MSG, 30, 4, 0, 1, NEQ, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 605 MSG = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ' + CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ, 0, 0.0D0, 0.0D0) + GO TO 700 + 606 MSG = 'DLSODE- ITOL (=I1) illegal ' + CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 607 MSG = 'DLSODE- IOPT (=I1) illegal ' + CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 608 MSG = 'DLSODE- MF (=I1) illegal ' + CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 609 MSG = 'DLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' + CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ, 0, 0.0D0, 0.0D0) + GO TO 700 + 610 MSG = 'DLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' + CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ, 0, 0.0D0, 0.0D0) + GO TO 700 + 611 MSG = 'DLSODE- MAXORD (=I1) .LT. 0 ' + CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 612 MSG = 'DLSODE- MXSTEP (=I1) .LT. 0 ' + CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 613 MSG = 'DLSODE- MXHNIL (=I1) .LT. 0 ' + CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) + GO TO 700 + 614 MSG = 'DLSODE- TOUT (=R1) behind T (=R2) ' + CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) + MSG = ' Integration direction is given by H0 (=R1) ' + CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) + GO TO 700 + 615 MSG = 'DLSODE- HMAX (=R1) .LT. 0.0 ' + CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) + GO TO 700 + 616 MSG = 'DLSODE- HMIN (=R1) .LT. 0.0 ' + CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) + GO TO 700 + 617 CONTINUE + MSG='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' + CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) + GO TO 700 + 618 CONTINUE + MSG='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' + CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) + GO TO 700 + 619 MSG = 'DLSODE- RelTol(I1) is R1 .LT. 0.0 ' + CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RelTolI, 0.0D0) + GO TO 700 + 620 MSG = 'DLSODE- AbsTol(I1) is R1 .LT. 0.0 ' + CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, AbsTolI, 0.0D0) + GO TO 700 + 621 EWTI = RWORK(LEWT+I-1) + MSG = 'DLSODE- EWT(I1) is R1 .LE. 0.0 ' + CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) + GO TO 700 + 622 CONTINUE + MSG='DLSODE- TOUT (=R1) too close to T(=R2) to start integration' + CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CONTINUE + MSG='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' + CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CONTINUE + MSG='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' + CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CONTINUE + MSG='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' + CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 MSG = 'DLSODE- At start of problem, too much accuracy ' + CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) + MSG=' requested for precision of machine.. See TOLSF (=R1) ' + CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) + RWORK(14) = TOLSF + GO TO 700 + 627 MSG = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1' + CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) +! + 700 ISTATE = -3 + RETURN +! + 800 MSG = 'DLSODE- Run aborted.. apparent infinite loop ' + CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) + RETURN +!----------------------- END OF SUBROUTINE DLSODE ---------------------- + !END SUBROUTINE DLSODE + CONTAINS + + +!DECK DUMACH + KPP_REAL FUNCTION DUMACH () +!***BEGIN PROLOGUE DUMACH +!***PURPOSE Compute the unit roundoff of the machine. +!***CATEGORY R1 +!***TYPE KPP_REAL (RUMACH-S, DUMACH-D) +!***KEYWORDS MACHINE CONSTANTS +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! *Usage: +! KPP_REAL A, DUMACH +! A = DUMACH() +! +! *Function Return Values: +! A : the unit roundoff of the machine. +! +! *Description: +! The unit roundoff is defined as the smallest positive machine +! number u such that 1.0 + u .ne. 1.0. This is computed by DUMACH +! in a machine-independent manner. +! +!***REFERENCES (NONE) +!***ROUTINES CALLED DUMSUM +!***REVISION HISTORY (YYYYMMDD) +! 19930216 DATE WRITTEN +! 19930818 Added SLATEC-format prologue. (FNF) +! 20030707 Added DUMSUM to force normal storage of COMP. (ACH) +!***END PROLOGUE DUMACH +! + KPP_REAL U, COMP +!***FIRST EXECUTABLE STATEMENT DUMACH + U = 1.0D0 + 10 U = U*0.5D0 + CALL DUMSUM(1.0D0, U, COMP) + IF (COMP .NE. 1.0D0) GO TO 10 + DUMACH = U*2.0D0 + RETURN +!----------------------- End of Function DUMACH ------------------------ + END FUNCTION DUMACH + + SUBROUTINE DUMSUM(A,B,C) +! Routine to force normal storing of A + B, for DUMACH. + KPP_REAL A, B, C + C = A + B + RETURN + END SUBROUTINE DUMSUM +!DECK DCFODE + SUBROUTINE DCFODE (METH, ELCO, TESCO) +!***BEGIN PROLOGUE DCFODE +!***SUBSIDIARY +!***PURPOSE Set ODE integrator coefficients. +!***TYPE KPP_REAL (SCFODE-S, DCFODE-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! DCFODE is called by the integrator routine to set coefficients +! needed there. The coefficients for the current method, as +! given by the value of METH, are set for all orders and saved. +! The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. +! (A smaller value of the maximum order is also allowed.) +! DCFODE is called once at the beginning of the problem, +! and is not called again unless and until METH is changed. +! +! The ELCO array contains the basic method coefficients. +! The coefficients el(i), 1 .le. i .le. nq+1, for the method of +! order nq are stored in ELCO(i,nq). They are given by a genetrating +! polynomial, i.e., +! l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. +! For the implicit Adams methods, l(x) is given by +! dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. +! For the BDF methods, l(x) is given by +! l(x) = (x+1)*(x+2)* ... *(x+nq)/K, +! where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). +! +! The TESCO array contains test constants used for the +! local error test and the selection of step size and/or order. +! At order nq, TESCO(k,nq) is used for the selection of step +! size at order nq - 1 if k = 1, at order nq if k = 2, and at order +! nq + 1 if k = 3. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED (NONE) +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +!***END PROLOGUE DCFODE +!**End + INTEGER METH + INTEGER I, IB, NQ, NQM1, NQP1 + KPP_REAL ELCO(13,12), TESCO(3,12), PC(12) + KPP_REAL AGAMQ, FNQ, FNQM1, PINT, RAGQ, RQFAC, RQ1FAC, TSIGN, XPIN +! +!***FIRST EXECUTABLE STATEMENT DCFODE + GO TO (100, 200), METH +! + 100 ELCO(1,1) = 1.0D0 + ELCO(2,1) = 1.0D0 + TESCO(1,1) = 0.0D0 + TESCO(2,1) = 2.0D0 + TESCO(1,2) = 1.0D0 + TESCO(3,12) = 0.0D0 + PC(1) = 1.0D0 + RQFAC = 1.0D0 + DO 140 NQ = 2,12 +!----------------------------------------------------------------------- +! The PC array will contain the coefficients of the polynomial +! p(x) = (x+1)*(x+2)*...*(x+nq-1). +! Initially, p(x) = 1. +!----------------------------------------------------------------------- + RQ1FAC = RQFAC + RQFAC = RQFAC/NQ + NQM1 = NQ - 1 + FNQM1 = NQM1 + NQP1 = NQ + 1 +! Form coefficients of p(x)*(x+nq-1). ---------------------------------- + PC(NQ) = 0.0D0 + DO 110 IB = 1,NQM1 + I = NQP1 - IB + 110 PC(I) = PC(I-1) + FNQM1*PC(I) + PC(1) = FNQM1*PC(1) +! Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0D0 + TSIGN = 1.0D0 + DO 120 I = 2,NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/I + 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) +! Store coefficients in ELCO and TESCO. -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = 1.0D0 + DO 130 I = 2,NQ + 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I + AGAMQ = RQFAC*XPIN + RAGQ = 1.0D0/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 + TESCO(3,NQM1) = RAGQ + 140 CONTINUE + RETURN +! + 200 PC(1) = 1.0D0 + RQ1FAC = 1.0D0 + DO 230 NQ = 1,5 +!----------------------------------------------------------------------- +! The PC array will contain the coefficients of the polynomial +! p(x) = (x+1)*(x+2)*...*(x+nq). +! Initially, p(x) = 1. +!----------------------------------------------------------------------- + FNQ = NQ + NQP1 = NQ + 1 +! Form coefficients of p(x)*(x+nq). ------------------------------------ + PC(NQP1) = 0.0D0 + DO 210 IB = 1,NQ + I = NQ + 2 - IB + 210 PC(I) = PC(I-1) + FNQ*PC(I) + PC(1) = FNQ*PC(1) +! Store coefficients in ELCO and TESCO. -------------------------------- + DO 220 I = 1,NQP1 + 220 ELCO(I,NQ) = PC(I)/PC(2) + ELCO(2,NQ) = 1.0D0 + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = NQP1/ELCO(1,NQ) + TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 230 CONTINUE + RETURN +!----------------------- END OF SUBROUTINE DCFODE ---------------------- + END SUBROUTINE DCFODE +!DECK DINTDY + SUBROUTINE DINTDY (T, K, YH, NYH, DKY, IFLAG) +!***BEGIN PROLOGUE DINTDY +!***SUBSIDIARY +!***PURPOSE Interpolate solution derivatives. +!***TYPE KPP_REAL (SINTDY-S, DINTDY-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! DINTDY computes interpolated values of the K-th derivative of the +! dependent variable vector y, and stores it in DKY. This routine +! is called within the package with K = 0 and T = TOUT, but may +! also be called by the user for any K up to the current order. +! (See detailed instructions in the usage documentation.) +! +! The computed values in DKY are gotten by interpolation using the +! Nordsieck history array YH. This array corresponds uniquely to a +! vector-valued polynomial of degree NQCUR or less, and DKY is set +! to the K-th derivative of this polynomial at T. +! The formula for DKY is: +! q +! DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) +! j=K +! where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. +! The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are +! communicated by COMMON. The above sum is done in reverse order. +! IFLAG is returned negative if either K or T is out of bounds. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED XERRWD +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +! 010418 Reduced size of Common block /DLS001/. (ACH) +! 031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +! 050427 Corrected roundoff decrement in TP. (ACH) +!***END PROLOGUE DINTDY +!**End + INTEGER K, NYH, IFLAG + KPP_REAL T, YH(NYH,*), DKY(*) + INTEGER IOWND, IOWNS, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + KPP_REAL ROWNS, & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /DLS001/ ROWNS(209), & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & + IOWND(6), IOWNS(6), & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 + KPP_REAL C, R, S, TP + CHARACTER*80 MSG +! +!***FIRST EXECUTABLE STATEMENT DINTDY + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TP = TN - HU - 100.0D0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) + IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 +! + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1,NQ + 10 IC = IC*JJ + 15 C = IC + DO 20 I = 1,N + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1,JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1,J + 30 IC = IC*JJ + 35 C = IC + DO 40 I = 1,N + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + DO 60 I = 1,N + 60 DKY(I) = R*DKY(I) + RETURN +! + 80 MSG = 'DINTDY- K (=I1) illegal ' + CALL XERRWD (MSG, 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) + IFLAG = -1 + RETURN + 90 MSG = 'DINTDY- T (=R1) illegal ' + CALL XERRWD (MSG, 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) + MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' + CALL XERRWD (MSG, 60, 52, 0, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +!----------------------- END OF SUBROUTINE DINTDY ---------------------- + END SUBROUTINE DINTDY +!DECK DPREPJ + SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, F, JAC) +!***BEGIN PROLOGUE DPREPJ +!***SUBSIDIARY +!***PURPOSE Compute and process Newton iteration matrix. +!***TYPE KPP_REAL (SPREPJ-S, DPREPJ-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! DPREPJ is called by DSTODE to compute and process the matrix +! P = I - h*el(1)*J , where J is an approximation to the Jacobian. +! Here J is computed by the user-supplied routine JAC if +! MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. +! If MITER = 3, a diagonal approximation to J is used. +! J is stored in WM and replaced by P. If MITER .ne. 3, P is then +! subjected to LU decomposition in preparation for later solution +! of linear systems with P as coefficient matrix. This is done +! by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. +! +! In addition to variables described in DSTODE and DLSODE prologues, +! communication with DPREPJ uses the following: +! Y = array containing predicted values on entry. +! FTEM = work array of length N (ACOR in DSTODE). +! SAVF = array containing f evaluated at predicted y. +! WM = real work space for matrices. On output it contains the +! inverse diagonal matrix if MITER = 3 and the LU decomposition +! of P if MITER is 1, 2 , 4, or 5. +! Storage of matrix elements starts at WM(3). +! WM also contains the following matrix-related data: +! WM(1) = SQRT(UROUND), used in numerical Jacobian increments. +! WM(2) = H*EL0, saved for later use if MITER = 3. +! IWM = integer work space containing pivot information, starting at +! IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band +! parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +! EL0 = EL(1) (input). +! IERPJ = output error flag, = 0 if no trouble, .gt. 0 if +! P matrix found to be singular. +! JCUR = output flag = 1 to indicate that the Jacobian matrix +! (or approximation) is now current. +! This routine also uses the COMMON variables EL0, H, TN, UROUND, +! MITER, N, NFE, and NJE. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED DGBFA, DGEFA, DVNORM +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890504 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +! 010418 Reduced size of Common block /DLS001/. (ACH) +! 031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +!***END PROLOGUE DPREPJ +!**End + EXTERNAL F, JAC + INTEGER NEQ, NYH, IWM(*) + KPP_REAL Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), WM(*) + INTEGER IOWND, IOWNS, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + KPP_REAL ROWNS, & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /DLS001/ ROWNS(209), & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & + IOWND(6), IOWNS(6), & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, & + MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 + KPP_REAL CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ + !KPP_REAL DVNORM +! +!***FIRST EXECUTABLE STATEMENT DPREPJ + NJE = NJE + 1 + IERPJ = 0 + JCUR = 1 + HL0 = H*EL0 + CON = -HL0 + +#ifdef FULL_ALGEBRA + LENP = N*N + DO i = 1,LENP + WM(i+2) = 0.0D0 + END DO + CALL JAC_CHEM (NEQ, TN, Y, WM(3)) + DO I = 1,LENP + WM(I+2) = WM(I+2)*CON + END DO + ! Add identity matrix + J = 3 + NP1 = N + 1 + DO I = 1,N + WM(J) = WM(J) + 1.0D0 + J = J + NP1 + END DO + ! Do LU decomposition on P + CALL DGETRF(N,N,WM(3),N,IWM(21),IER) +#else + CALL JAC_CHEM (NEQ, TN, Y, WM(3)) + DO i = 1,LU_NONZERO + WM(i+2) = WM(i+2)*CON + END DO + ! Add identity matrix + DO i = 1,N + j = 2+LU_DIAG(i) + WM(j) = WM(j) + 1.0D0 + END DO + ! Do LU decomposition on P + CALL KppDecomp(WM(3),IER) +#endif + IF (IER .NE. 0) IERPJ = 1 + RETURN + !----------------------- END OF SUBROUTINE DPREPJ ---------------------- + END SUBROUTINE DPREPJ +!DECK DSOLSY + SUBROUTINE DSOLSY (WM, IWM, X, TEM) +!***BEGIN PROLOGUE DSOLSY +!***SUBSIDIARY +!***PURPOSE ODEPACK linear system solver. +!***TYPE KPP_REAL (SSOLSY-S, DSOLSY-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! This routine manages the solution of the linear system arising from +! a chord iteration. It is called if MITER .ne. 0. +! If MITER is 1 or 2, it calls DGESL to accomplish this. +! If MITER = 3 it updates the coefficient h*EL0 in the diagonal +! matrix, and then computes the solution. +! If MITER is 4 or 5, it calls DGBSL. +! Communication with DSOLSY uses the following variables: +! WM = real work space containing the inverse diagonal matrix if +! MITER = 3 and the LU decomposition of the matrix otherwise. +! Storage of matrix elements starts at WM(3). +! WM also contains the following matrix-related data: +! WM(1) = SQRT(UROUND) (not used here), +! WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. +! IWM = integer work space containing pivot information, starting at +! IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band +! parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +! X = the right-hand side vector on input, and the solution vector +! on output, of length N. +! TEM = vector of work space of length N, not used in this version. +! IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. +! IERSL = 1 if a singular matrix arose with MITER = 3. +! This routine also uses the COMMON variables EL0, H, MITER, and N. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED DGBSL, DGESL +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +! 010418 Reduced size of Common block /DLS001/. (ACH) +! 031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +!***END PROLOGUE DSOLSY +!**End + INTEGER IWM(*) + KPP_REAL WM(*), X(*), TEM(*) + INTEGER IOWND, IOWNS, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + KPP_REAL ROWNS, & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + COMMON /DLS001/ ROWNS(209), & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & + IOWND(6), IOWNS(6), & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, MEBAND, ML, MU + KPP_REAL DI, HL0, PHL0, R +! +!***FIRST EXECUTABLE STATEMENT DSOLSY + IERSL = 0 +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,WM(3),N,IWM(21),X,N,0) +#else + CALL KppSolve(WM(3),X) +#endif + RETURN +!----------------------- END OF SUBROUTINE DSOLSY ---------------------- + END SUBROUTINE DSOLSY +!DECK DSRCOM + SUBROUTINE DSRCOM (RSAV, ISAV, JOB) +!***BEGIN PROLOGUE DSRCOM +!***SUBSIDIARY +!***PURPOSE Save/restore ODEPACK COMMON blocks. +!***TYPE KPP_REAL (SSRCOM-S, DSRCOM-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! This routine saves or restores (depending on JOB) the contents of +! the COMMON block DLS001, which is used internally +! by one or more ODEPACK solvers. +! +! RSAV = real array of length 218 or more. +! ISAV = integer array of length 37 or more. +! JOB = flag indicating to save or restore the COMMON blocks: +! JOB = 1 if COMMON is to be saved (written to RSAV/ISAV) +! JOB = 2 if COMMON is to be restored (read from RSAV/ISAV) +! A call with JOB = 2 presumes a prior call with JOB = 1. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED (NONE) +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 921116 Deleted treatment of block /EH0001/. (ACH) +! 930801 Reduced Common block length by 2. (ACH) +! 930809 Renamed to allow single/double precision versions. (ACH) +! 010418 Reduced Common block length by 209+12. (ACH) +! 031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +! 031112 Added SAVE statement for data-loaded constants. +!***END PROLOGUE DSRCOM +!**End + INTEGER ISAV(*), JOB + INTEGER ILS + INTEGER I, LENILS, LENRLS + KPP_REAL RSAV(*), RLS + SAVE LENRLS, LENILS + COMMON /DLS001/ RLS(218), ILS(37) + DATA LENRLS/218/, LENILS/37/ +! +!***FIRST EXECUTABLE STATEMENT DSRCOM + IF (JOB .EQ. 2) GO TO 100 +! + DO 10 I = 1,LENRLS + 10 RSAV(I) = RLS(I) + DO 20 I = 1,LENILS + 20 ISAV(I) = ILS(I) + RETURN +! + 100 CONTINUE + DO 110 I = 1,LENRLS + 110 RLS(I) = RSAV(I) + DO 120 I = 1,LENILS + 120 ILS(I) = ISAV(I) + RETURN +!----------------------- END OF SUBROUTINE DSRCOM ---------------------- + END SUBROUTINE DSRCOM +!DECK DSTODE + SUBROUTINE DSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, & + WM, IWM, F, JAC) + !WM, IWM, F, JAC, PJAC, SLVS) +!***BEGIN PROLOGUE DSTODE +!***SUBSIDIARY +!***PURPOSE Performs one step of an ODEPACK integration. +!***TYPE KPP_REAL (SSTODE-S, DSTODE-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! DSTODE performs one step of the integration of an initial value +! problem for a system of ordinary differential equations. +! Note: DSTODE is independent of the value of the iteration method +! indicator MITER, when this is .ne. 0, and hence is independent +! of the type of chord method used, or the Jacobian structure. +! Communication with DSTODE is done with the following variables: +! +! NEQ = integer array containing problem size in NEQ, and +! passed as the NEQ argument in all calls to F and JAC. +! Y = an array of length .ge. N used as the Y argument in +! all calls to F and JAC. +! YH = an NYH by LMAX array containing the dependent variables +! and their approximate scaled derivatives, where +! LMAX = MAXORD + 1. YH(i,j+1) contains the approximate +! j-th derivative of y(i), scaled by h**j/factorial(j) +! (j = 0,1,...,NQ). on entry for the first step, the first +! two columns of YH must be set from the initial values. +! NYH = a constant integer .ge. N, the first dimension of YH. +! YH1 = a one-dimensional array occupying the same space as YH. +! EWT = an array of length N containing multiplicative weights +! for local error measurements. Local errors in Y(i) are +! compared to 1.0/EWT(i) in various error tests. +! SAVF = an array of working storage, of length N. +! Also used for input of YH(*,MAXORD+2) when JSTART = -1 +! and MAXORD .lt. the current order NQ. +! ACOR = a work array of length N, used for the accumulated +! corrections. On a successful return, ACOR(i) contains +! the estimated one-step local error in Y(i). +! WM,IWM = real and integer work arrays associated with matrix +! operations in chord iteration (MITER .ne. 0). +! PJAC = name of routine to evaluate and preprocess Jacobian matrix +! and P = I - h*el0*JAC, if a chord method is being used. +! SLVS = name of routine to solve linear system in chord iteration. +! CCMAX = maximum relative change in h*el0 before PJAC is called. +! H = the step size to be attempted on the next step. +! H is altered by the error control algorithm during the +! problem. H can be either positive or negative, but its +! sign must remain constant throughout the problem. +! HMIN = the minimum absolute value of the step size h to be used. +! HMXI = inverse of the maximum absolute value of h to be used. +! HMXI = 0.0 is allowed and corresponds to an infinite hmax. +! HMIN and HMXI may be changed at any time, but will not +! take effect until the next change of h is considered. +! TN = the independent variable. TN is updated on each step taken. +! JSTART = an integer used for input only, with the following +! values and meanings: +! 0 perform the first step. +! .gt.0 take a new step continuing from the last. +! -1 take the next step with a new value of H, MAXORD, +! N, METH, MITER, and/or matrix parameters. +! -2 take the next step with a new value of H, +! but with other inputs unchanged. +! On return, JSTART is set to 1 to facilitate continuation. +! KFLAG = a completion code with the following meanings: +! 0 the step was succesful. +! -1 the requested error could not be achieved. +! -2 corrector convergence could not be achieved. +! -3 fatal error in PJAC or SLVS. +! A return with KFLAG = -1 or -2 means either +! abs(H) = HMIN or 10 consecutive failures occurred. +! On a return with KFLAG negative, the values of TN and +! the YH array are as of the beginning of the last +! step, and H is the last step size attempted. +! MAXORD = the maximum order of integration method to be allowed. +! MAXCOR = the maximum number of corrector iterations allowed. +! MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). +! MXNCF = maximum number of convergence failures allowed. +! METH/MITER = the method flags. See description in driver. +! N = the number of first-order differential equations. +! The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, +! MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED DCFODE, DVNORM +!***COMMON BLOCKS DLS001 +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +! 010418 Reduced size of Common block /DLS001/. (ACH) +! 031105 Restored 'own' variables to Common block /DLS001/, to +! enable interrupt/restart feature. (ACH) +!***END PROLOGUE DSTODE +!**End + EXTERNAL F, JAC !, PJAC, SLVS + INTEGER NEQ, NYH, IWM(*) + KPP_REAL Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), & + ACOR(*), WM(*) + INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ + KPP_REAL CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND + KPP_REAL DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, & + EXUP,R, RH, RHDN, RHSM, RHUP, TOLD + !KPP_REAL DVNORM + COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), & + HOLD, RMAX, TESCO(3,12), & + CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, & + IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, & + ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, & + LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, & + MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU +! +!***FIRST EXECUTABLE STATEMENT DSTODE + KFLAG = 0 + TOLD = TN + NCF = 0 + IERPJ = 0 + IERSL = 0 + JCUR = 0 + ICF = 0 + DELP = 0.0D0 + IF (JSTART .GT. 0) GO TO 200 + IF (JSTART .EQ. -1) GO TO 100 + IF (JSTART .EQ. -2) GO TO 160 +!----------------------------------------------------------------------- +! On the first call, the order is set to 1, and other variables are +! initialized. RMAX is the maximum ratio by which H can be increased +! in a single step. It is initially 1.E4 to compensate for the small +! initial H, but then is normally equal to 10. If a failure +! occurs (in corrector convergence or error test), RMAX is set to 2 +! for the next increase. +!----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0D0 + RC = 0.0D0 + EL0 = 1.0D0 + CRATE = 0.7D0 + HOLD = H + MEO = METH + NSLP = 0 + IPUP = MITER + IRET = 3 + GO TO 140 +!----------------------------------------------------------------------- +! The following block handles preliminaries needed when JSTART = -1. +! IPUP is set to MITER to force a matrix update. +! If an order increase is about to be considered (IALTH = 1), +! IALTH is reset to 2 to postpone consideration one more step. +! If the caller has changed METH, DCFODE is called to reset +! the coefficients of the method. +! If the caller has changed MAXORD to a value less than the current +! order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. +! If H is to be changed, YH must be rescaled. +! If H or METH is being changed, IALTH is reset to L = NQ + 1 +! to prevent further changes in H for that many steps. +!----------------------------------------------------------------------- + 100 IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 110 + CALL DCFODE (METH, ELCO, TESCO) + MEO = METH + IF (NQ .GT. MAXORD) GO TO 120 + IALTH = L + IRET = 1 + GO TO 150 + 110 IF (NQ .LE. MAXORD) GO TO 160 + 120 NQ = MAXORD + L = LMAX + DO 125 I = 1,L + 125 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/(NQ+2) + DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) + EXDN = 1.0D0/L + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + RH = MIN(RHDN,1.0D0) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 170 + RH = MIN(RH,ABS(H/HOLD)) + H = HOLD + GO TO 175 +!----------------------------------------------------------------------- +! DCFODE is called to get all the integration coefficients for the +! current METH. Then the EL vector and related constants are reset +! whenever the order NQ is changed, or at the start of the problem. +!----------------------------------------------------------------------- + 140 CALL DCFODE (METH, ELCO, TESCO) + 150 DO 155 I = 1,L + 155 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/(NQ+2) + GO TO (160, 170, 200), IRET +!----------------------------------------------------------------------- +! If H is being changed, the H ratio RH is checked against +! RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to +! L = NQ + 1 to prevent a change of H for that many steps, unless +! forced by a convergence or error test failure. +!----------------------------------------------------------------------- + 160 IF (H .EQ. HOLD) GO TO 200 + RH = H/HOLD + H = HOLD + IREDO = 3 + GO TO 175 + 170 RH = MAX(RH,HMIN/ABS(H)) + 175 RH = MIN(RH,RMAX) + RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) + R = 1.0D0 + DO 180 J = 2,L + R = R*RH + DO 180 I = 1,N + 180 YH(I,J) = YH(I,J)*R + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .EQ. 0) GO TO 690 +!----------------------------------------------------------------------- +! This section computes the predicted values by effectively +! multiplying the YH array by the Pascal Triangle matrix. +! RC is the ratio of new to old values of the coefficient H*EL(1). +! When RC differs from 1 by more than CCMAX, IPUP is set to MITER +! to force PJAC to be called, if a Jacobian is involved. +! In any case, PJAC is called at least every MSBP steps. +!----------------------------------------------------------------------- + 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER + IF (NST .GE. NSLP+MSBP) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 215 JB = 1,NQ + I1 = I1 - NYH +!dir$ ivdep + DO 210 I = I1,NQNYH + 210 YH1(I) = YH1(I) + YH1(I+NYH) + 215 CONTINUE +!----------------------------------------------------------------------- +! Up to MAXCOR corrector iterations are taken. A convergence test is +! made on the R.M.S. norm of each correction, weighted by the error +! weight vector EWT. The sum of the corrections is accumulated in the +! vector ACOR(i). The YH array is not altered in the corrector loop. +!----------------------------------------------------------------------- + 220 M = 0 + DO 230 I = 1,N + 230 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +!----------------------------------------------------------------------- +! If indicated, the matrix P = I - h*el(1)*J is reevaluated and +! preprocessed before starting the corrector iteration. IPUP is set +! to 0 as an indicator that this has been done. +!----------------------------------------------------------------------- + !CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) + CALL DPREPJ(NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) + IPUP = 0 + RC = 1.0D0 + NSLP = NST + CRATE = 0.7D0 + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = 0.0D0 + 270 IF (MITER .NE. 0) GO TO 350 +!----------------------------------------------------------------------- +! In the case of functional iteration, update Y directly from +! the result of the last function evaluation. +!----------------------------------------------------------------------- + DO 290 I = 1,N + SAVF(I) = H*SAVF(I) - YH(I,2) + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = DVNORM (N, Y, EWT) + DO 300 I = 1,N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + 300 ACOR(I) = SAVF(I) + GO TO 400 +!----------------------------------------------------------------------- +! In the case of the chord method, compute the corrector error, +! and solve the linear system with that as right-hand side and +! P as coefficient matrix. +!----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) + !CALL SLVS (WM, IWM, Y, SAVF) + CALL DSOLSY(WM, IWM, Y, SAVF) + IF (IERSL .LT. 0) GO TO 430 + IF (IERSL .GT. 0) GO TO 410 + DEL = DVNORM (N, Y, EWT) + DO 380 I = 1,N + ACOR(I) = ACOR(I) + Y(I) + 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) +!----------------------------------------------------------------------- +! Test for convergence. If M.gt.0, an estimate of the convergence +! rate constant is stored in CRATE, and this is used in the test. +!----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) + DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) + IF (DCON .LE. 1.0D0) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 + DELP = DEL + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + GO TO 270 +!----------------------------------------------------------------------- +! The corrector iteration failed to converge. +! If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for +! the next try. Otherwise the YH array is retracted to its values +! before prediction, and H is reduced, if possible. If H cannot be +! reduced or MXNCF failures have occurred, exit with KFLAG = -2. +!----------------------------------------------------------------------- + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 + 430 ICF = 2 + NCF = NCF + 1 + RMAX = 2.0D0 + TN = TOLD + I1 = NQNYH + 1 + DO 445 JB = 1,NQ + I1 = I1 - NYH +!dir$ ivdep + DO 440 I = I1,NQNYH + 440 YH1(I) = YH1(I) - YH1(I+NYH) + 445 CONTINUE + IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + RH = 0.25D0 + IPUP = MITER + IREDO = 1 + GO TO 170 +!----------------------------------------------------------------------- +! The corrector has converged. JCUR is set to 0 +! to signal that the Jacobian involved may need updating later. +! The local error test is made and control passes to statement 500 +! if it fails. +!----------------------------------------------------------------------- + 450 JCUR = 0 + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) + IF (DSM .GT. 1.0D0) GO TO 500 +!----------------------------------------------------------------------- +! After a successful step, update the YH array. +! Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. +! If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for +! use in a possible order increase on the next step. +! If a change in H is considered, an increase or decrease in order +! by one is considered also. A change in H is made only if it is by a +! factor of at least 1.1. If not, IALTH is set to 3 to prevent +! testing for that many steps. +!----------------------------------------------------------------------- + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 J = 1,L + DO 470 I = 1,N + 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) + IALTH = IALTH - 1 + IF (IALTH .EQ. 0) GO TO 520 + IF (IALTH .GT. 1) GO TO 700 + IF (L .EQ. LMAX) GO TO 700 + DO 490 I = 1,N + 490 YH(I,LMAX) = ACOR(I) + GO TO 700 +!----------------------------------------------------------------------- +! The error test failed. KFLAG keeps track of multiple failures. +! Restore TN and the YH array to their previous values, and prepare +! to try the step again. Compute the optimum step size for this or +! one lower order. After 2 or more failures, H is forced to decrease +! by a factor of 0.2 or less. +!----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + TN = TOLD + I1 = NQNYH + 1 + DO 515 JB = 1,NQ + I1 = I1 - NYH +!dir$ ivdep + DO 510 I = I1,NQNYH + 510 YH1(I) = YH1(I) - YH1(I+NYH) + 515 CONTINUE + RMAX = 2.0D0 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 + IF (KFLAG .LE. -3) GO TO 640 + IREDO = 2 + RHUP = 0.0D0 + GO TO 540 +!----------------------------------------------------------------------- +! Regardless of the success or failure of the step, factors +! RHDN, RHSM, and RHUP are computed, by which H could be multiplied +! at order NQ - 1, order NQ, or order NQ + 1, respectively. +! In the case of failure, RHUP = 0.0 to avoid an order increase. +! The largest of these is determined and the new order chosen +! accordingly. If the order is to be increased, we compute one +! additional scaled derivative. +!----------------------------------------------------------------------- + 520 RHUP = 0.0D0 + IF (L .EQ. LMAX) GO TO 540 + DO 530 I = 1,N + 530 SAVF(I) = ACOR(I) - YH(I,LMAX) + DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) + EXUP = 1.0D0/(L+1) + RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) + 540 EXSM = 1.0D0/L + RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) + RHDN = 0.0D0 + IF (NQ .EQ. 1) GO TO 560 + DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) + EXDN = 1.0D0/NQ + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + 560 IF (RHSM .GE. RHUP) GO TO 570 + IF (RHUP .GT. RHDN) GO TO 590 + GO TO 580 + 570 IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + GO TO 620 + 580 NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 + GO TO 620 + 590 NEWQ = L + RH = RHUP + IF (RH .LT. 1.1D0) GO TO 610 + R = EL(L)/L + DO 600 I = 1,N + 600 YH(I,NEWQ+1) = ACOR(I)*R + GO TO 630 + 610 IALTH = 3 + GO TO 700 + 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) +!----------------------------------------------------------------------- +! If there is a change of order, reset NQ, l, and the coefficients. +! In any case H is reset according to RH and the YH array is rescaled. +! Then exit from 690 if the step was OK, or redo the step otherwise. +!----------------------------------------------------------------------- + IF (NEWQ .EQ. NQ) GO TO 170 + 630 NQ = NEWQ + L = NQ + 1 + IRET = 2 + GO TO 150 +!----------------------------------------------------------------------- +! Control reaches this section if 3 or more failures have occured. +! If 10 failures have occurred, exit with KFLAG = -1. +! It is assumed that the derivatives that have accumulated in the +! YH array have errors of the wrong order. Hence the first +! derivative is recomputed, and the order is set to 1. Then +! H is reduced by a factor of 10, and the step is retried, +! until it succeeds or H reaches HMIN. +!----------------------------------------------------------------------- + 640 IF (KFLAG .EQ. -10) GO TO 660 + RH = 0.1D0 + RH = MAX(HMIN/ABS(H),RH) + H = H*RH + DO 645 I = 1,N + 645 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, SAVF) + NFE = NFE + 1 + DO 650 I = 1,N + 650 YH(I,2) = H*SAVF(I) + IPUP = MITER + IALTH = 5 + IF (NQ .EQ. 1) GO TO 200 + NQ = 1 + L = 2 + IRET = 3 + GO TO 150 +!----------------------------------------------------------------------- +! All returns are made through this section. H is saved in HOLD +! to allow the caller to change H on the next step. +!----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 KFLAG = -3 + GO TO 720 + 690 RMAX = 10.0D0 + 700 R = 1.0D0/TESCO(2,NQU) + DO 710 I = 1,N + 710 ACOR(I) = ACOR(I)*R + 720 HOLD = H + JSTART = 1 + RETURN +!----------------------- END OF SUBROUTINE DSTODE ---------------------- + END SUBROUTINE DSTODE +!DECK DEWSET + SUBROUTINE DEWSET (N, ITOL, RelTol, AbsTol, YCUR, EWT) +!***BEGIN PROLOGUE DEWSET +!***SUBSIDIARY +!***PURPOSE Set error weight vector. +!***TYPE KPP_REAL (SEWSET-S, DEWSET-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! This subroutine sets the error weight vector EWT according to +! EWT(i) = RelTol(i)*ABS(YCUR(i)) + AbsTol(i), i = 1,...,N, +! with the subscript on RelTol and/or AbsTol possibly replaced by 1 above, +! depending on the value of ITOL. +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED (NONE) +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +!***END PROLOGUE DEWSET +!**End + INTEGER N, ITOL + INTEGER I + KPP_REAL RelTol(*), AbsTol(*), YCUR(N), EWT(N) +! +!***FIRST EXECUTABLE STATEMENT DEWSET + GO TO (10, 20, 30, 40), ITOL + 10 CONTINUE + DO 15 I = 1,N + 15 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(1) + RETURN + 20 CONTINUE + DO 25 I = 1,N + 25 EWT(I) = RelTol(1)*ABS(YCUR(I)) + AbsTol(I) + RETURN + 30 CONTINUE + DO 35 I = 1,N + 35 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(1) + RETURN + 40 CONTINUE + DO 45 I = 1,N + 45 EWT(I) = RelTol(I)*ABS(YCUR(I)) + AbsTol(I) + RETURN +!----------------------- END OF SUBROUTINE DEWSET ---------------------- + END SUBROUTINE DEWSET +!DECK DVNORM + KPP_REAL FUNCTION DVNORM (N, V, W) +!***BEGIN PROLOGUE DVNORM +!***SUBSIDIARY +!***PURPOSE Weighted root-mean-square vector norm. +!***TYPE KPP_REAL (SVNORM-S, DVNORM-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! This function routine computes the weighted root-mean-square norm +! of the vector of length N contained in the array V, with weights +! contained in the array W of length N: +! DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) +! +!***SEE ALSO DLSODE +!***ROUTINES CALLED (NONE) +!***REVISION HISTORY (YYMMDD) +! 791129 DATE WRITTEN +! 890501 Modified prologue to SLATEC/LDOC format. (FNF) +! 890503 Minor cosmetic changes. (FNF) +! 930809 Renamed to allow single/double precision versions. (ACH) +!***END PROLOGUE DVNORM +!**End + INTEGER N, I + KPP_REAL V(N), W(N), SUM +! +!***FIRST EXECUTABLE STATEMENT DVNORM + SUM = 0.0D0 + DO 10 I = 1,N + 10 SUM = SUM + (V(I)*W(I))**2 + DVNORM = SQRT(SUM/N) + RETURN +!----------------------- END OF FUNCTION DVNORM ------------------------ + END FUNCTION DVNORM +!DECK XERRWD + SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) +!***BEGIN PROLOGUE XERRWD +!***SUBSIDIARY +!***PURPOSE Write error message with values. +!***CATEGORY R3C +!***TYPE KPP_REAL (XERRWV-S, XERRWD-D) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, +! as given here, constitute a simplified version of the SLATEC error +! handling package. +! +! All arguments are input arguments. +! +! MSG = The message (character array). +! NMES = The length of MSG (number of characters). +! NERR = The error number (not used). +! LEVEL = The error level.. +! 0 or 1 means recoverable (control returns to caller). +! 2 means fatal (run is aborted--see note below). +! NI = Number of integers (0, 1, or 2) to be printed with message. +! I1,I2 = Integers to be printed, depending on NI. +! NR = Number of reals (0, 1, or 2) to be printed with message. +! R1,R2 = Reals to be printed, depending on NR. +! +! Note.. this routine is machine-dependent and specialized for use +! in limited context, in the following ways.. +! 1. The argument MSG is assumed to be of type CHARACTER, and +! the message is printed with a format of (1X,A). +! 2. The message is assumed to take only one line. +! Multi-line messages are generated by repeated calls. +! 3. If LEVEL = 2, control passes to the statement STOP +! to abort the run. This statement may be machine-dependent. +! 4. R1 and R2 are assumed to be in double precision and are printed +! in D21.13 format. +! +!***ROUTINES CALLED IXSAV +!***REVISION HISTORY (YYMMDD) +! 920831 DATE WRITTEN +! 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) +! 930329 Modified prologue to SLATEC format. (FNF) +! 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) +! 930922 Minor cosmetic change. (FNF) +!***END PROLOGUE XERRWD +! +!*Internal Notes: +! +! For a different default logical unit number, IXSAV (or a subsidiary +! routine that it calls) will need to be modified. +! For a different run-abort command, change the statement following +! statement 100 at the end. +!----------------------------------------------------------------------- +! Subroutines called by XERRWD.. None +! Function routine called by XERRWD.. IXSAV +!----------------------------------------------------------------------- +!**End +! +! Declare arguments. +! + KPP_REAL R1, R2 + INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR + CHARACTER*(*) MSG +! +! Declare local variables. +! + INTEGER LUNIT, MESFLG !, IXSAV +! +! Get logical unit number and message print flag. +! +!***FIRST EXECUTABLE STATEMENT XERRWD + LUNIT = IXSAV (1, 0, .FALSE.) + MESFLG = IXSAV (2, 0, .FALSE.) + IF (MESFLG .EQ. 0) GO TO 100 +! +! Write the message. +! + WRITE (LUNIT,10) MSG + 10 FORMAT(1X,A) + IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 + 20 FORMAT(6X,'In above message, I1 =',I10) + IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 + 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) + IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 + 40 FORMAT(6X,'In above message, R1 =',D21.13) + IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 + 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) +! +! Abort the run if LEVEL = 2. +! + 100 IF (LEVEL .NE. 2) RETURN + STOP +!----------------------- End of Subroutine XERRWD ---------------------- + END SUBROUTINE XERRWD +!DECK XSETF + SUBROUTINE XSETF (MFLAG) +!***BEGIN PROLOGUE XSETF +!***PURPOSE Reset the error print control flag. +!***CATEGORY R3A +!***TYPE ALL (XSETF-A) +!***KEYWORDS ERROR CONTROL +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! XSETF sets the error print control flag to MFLAG: +! MFLAG=1 means print all messages (the default). +! MFLAG=0 means no printing. +! +!***SEE ALSO XERRWD, XERRWV +!***REFERENCES (NONE) +!***ROUTINES CALLED IXSAV +!***REVISION HISTORY (YYMMDD) +! 921118 DATE WRITTEN +! 930329 Added SLATEC format prologue. (FNF) +! 930407 Corrected SEE ALSO section. (FNF) +! 930922 Made user-callable, and other cosmetic changes. (FNF) +!***END PROLOGUE XSETF +! +! Subroutines called by XSETF.. None +! Function routine called by XSETF.. IXSAV +!----------------------------------------------------------------------- +!**End + INTEGER MFLAG, JUNK !, IXSAV +! +!***FIRST EXECUTABLE STATEMENT XSETF + IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.) + RETURN +!----------------------- End of Subroutine XSETF ----------------------- + END SUBROUTINE XSETF +!DECK XSETUN + SUBROUTINE XSETUN (LUN) +!***BEGIN PROLOGUE XSETUN +!***PURPOSE Reset the logical unit number for error messages. +!***CATEGORY R3B +!***TYPE ALL (XSETUN-A) +!***KEYWORDS ERROR CONTROL +!***DESCRIPTION +! +! XSETUN sets the logical unit number for error messages to LUN. +! +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***SEE ALSO XERRWD, XERRWV +!***REFERENCES (NONE) +!***ROUTINES CALLED IXSAV +!***REVISION HISTORY (YYMMDD) +! 921118 DATE WRITTEN +! 930329 Added SLATEC format prologue. (FNF) +! 930407 Corrected SEE ALSO section. (FNF) +! 930922 Made user-callable, and other cosmetic changes. (FNF) +!***END PROLOGUE XSETUN +! +! Subroutines called by XSETUN.. None +! Function routine called by XSETUN.. IXSAV +!----------------------------------------------------------------------- +!**End + INTEGER LUN, JUNK !, IXSAV +! +!***FIRST EXECUTABLE STATEMENT XSETUN + IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.) + RETURN +!----------------------- End of Subroutine XSETUN ---------------------- + END SUBROUTINE XSETUN +!DECK IXSAV + INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) +!***BEGIN PROLOGUE IXSAV +!***SUBSIDIARY +!***PURPOSE Save and recall error message control parameters. +!***CATEGORY R3C +!***TYPE ALL (IXSAV-A) +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! +! IXSAV saves and recalls one of two error message parameters: +! LUNIT, the logical unit number to which messages are printed, and +! MESFLG, the message print flag. +! This is a modification of the SLATEC library routine J4SAVE. +! +! Saved local variables.. +! LUNIT = Logical unit number for messages. The default is obtained +! by a call to IUMACH (may be machine-dependent). +! MESFLG = Print control flag.. +! 1 means print all messages (the default). +! 0 means no printing. +! +! On input.. +! IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). +! IVALUE = The value to be set for the parameter, if ISET = .TRUE. +! ISET = Logical flag to indicate whether to read or write. +! If ISET = .TRUE., the parameter will be given +! the value IVALUE. If ISET = .FALSE., the parameter +! will be unchanged, and IVALUE is a dummy argument. +! +! On return.. +! IXSAV = The (old) value of the parameter. +! +!***SEE ALSO XERRWD, XERRWV +!***ROUTINES CALLED IUMACH +!***REVISION HISTORY (YYMMDD) +! 921118 DATE WRITTEN +! 930329 Modified prologue to SLATEC format. (FNF) +! 930915 Added IUMACH call to get default output unit. (ACH) +! 930922 Minor cosmetic changes. (FNF) +! 010425 Type declaration for IUMACH added. (ACH) +!***END PROLOGUE IXSAV +! +! Subroutines called by IXSAV.. None +! Function routine called by IXSAV.. IUMACH +!----------------------------------------------------------------------- +!**End + LOGICAL ISET + INTEGER IPAR, IVALUE +!----------------------------------------------------------------------- + INTEGER LUNIT, MESFLG!, IUMACH +!----------------------------------------------------------------------- +! The following Fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this routine. +!----------------------------------------------------------------------- + SAVE LUNIT, MESFLG + DATA LUNIT/-1/, MESFLG/1/ +! +!***FIRST EXECUTABLE STATEMENT IXSAV + IF (IPAR .EQ. 1) THEN + IF (LUNIT .EQ. -1) LUNIT = IUMACH() + IXSAV = LUNIT + IF (ISET) LUNIT = IVALUE + ENDIF +! + IF (IPAR .EQ. 2) THEN + IXSAV = MESFLG + IF (ISET) MESFLG = IVALUE + ENDIF +! + RETURN +!----------------------- End of Function IXSAV ------------------------- + END FUNCTION IXSAV +!DECK IUMACH + INTEGER FUNCTION IUMACH() +!***BEGIN PROLOGUE IUMACH +!***PURPOSE Provide standard output unit number. +!***CATEGORY R1 +!***TYPE INTEGER (IUMACH-I) +!***KEYWORDS MACHINE CONSTANTS +!***AUTHOR Hindmarsh, Alan C., (LLNL) +!***DESCRIPTION +! *Usage: +! INTEGER LOUT, IUMACH +! LOUT = IUMACH() +! +! *Function Return Values: +! LOUT : the standard logical unit for Fortran output. +! +!***REFERENCES (NONE) +!***ROUTINES CALLED (NONE) +!***REVISION HISTORY (YYMMDD) +! 930915 DATE WRITTEN +! 930922 Made user-callable, and other cosmetic changes. (FNF) +!***END PROLOGUE IUMACH +! +!*Internal Notes: +! The built-in value of 6 is standard on a wide range of Fortran +! systems. This may be machine-dependent. +!**End +!***FIRST EXECUTABLE STATEMENT IUMACH + IUMACH = 6 +! + RETURN +!----------------------- End of Function IUMACH ------------------------ + END FUNCTION IUMACH + +!---- END OF SUBROUTINE DLSODE AND ITS INTERNAL PROCEDURES + END SUBROUTINE DLSODE +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE FUN_CHEM(N, T, V, FCT) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Function, ONLY: Fun + USE KPP_ROOT_Rates + + IMPLICIT NONE + + INTEGER :: N + KPP_REAL :: V(NVAR), FCT(NVAR), T, TOLD + +! TOLD = TIME +! TIME = T +! CALL Update_SUN() +! CALL Update_RCONST() +! CALL Update_PHOTO() +! TIME = TOLD + + CALL Fun(V, FIX, RCONST, FCT) + + !Nfun=Nfun+1 + + END SUBROUTINE FUN_CHEM + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE JAC_CHEM (N, T, V, JF) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_JacobianSP + USE KPP_ROOT_Jacobian, ONLY: Jac_SP + USE KPP_ROOT_Rates + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), T, TOLD + INTEGER :: I, J, N, ML, MU, NROWPD +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) +#else + KPP_REAL :: JF(LU_NONZERO) +#endif + +! TOLD = TIME +! TIME = T +! CALL Update_SUN() +! CALL Update_RCONST() +! CALL Update_PHOTO() +! TIME = TOLD + +#ifdef FULL_ALGEBRA + CALL Jac_SP(V, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + JF(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + JF(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP(V, FIX, RCONST, JF) +#endif + !Njac=Njac+1 + + END SUBROUTINE JAC_CHEM + + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.def new file mode 100755 index 00000000..52199144 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.def @@ -0,0 +1,42 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW +#DOUBLE ON +#INTFILE kpp_odessa_ddm + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + + +#INLINE C_GLOBAL +extern int Autonomous; +extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT +int Autonomous; +double STEPSTART; +#ENDINLINE + + + +#INLINE C_INIT + STEPMIN=0.0001; + STEPMAX=3600.0; + Autonomous = 0; + STEPSTART=STEPMIN; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.f new file mode 100755 index 00000000..788321fb --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_odessa_ddm.f @@ -0,0 +1,4427 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + REAL*8 TIN +C TOUT - End Time + REAL*8 TOUT +C Concentrations and Sensitivities + REAL*8 Y(NVAR,NSENSIT+1), PARAMS(NSENSIT) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + INTEGER i + + INTEGER LIW, LRW +C PARAMETER (LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) +C PARAMETER (LIW = 21 + NVAR + NSENSIT) +C REAL*8 RWORK(LRW) +C INTEGER IWORK(LIW) +C Note: the following dynamic allocation is not standard F77 and may not work on +C some systems. Declare LRW, LIW parameters as above with some upper bound used for NSENSIT + REAL*8 RWORK(22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR) + INTEGER IWORK(21 + NVAR + NSENSIT) + + INTEGER IOPT(3), NEQ(2) + + EXTERNAL FUNC_CHEM,JAC,DFUNC_CHEMDPAR + + MF = 21 ! --- BDF plus user-supplied Jacobian + + LRW = 22 + 8*(NSENSIT+1)*NVAR + NVAR**2 + NVAR + LIW = 21 + NVAR + NSENSIT + + NEQ(1) = NVAR ! --- No. of Variables + NEQ(2) = NSENSIT ! --- No of parameters + + ITOL=1 ! --- 1=Scalar Tolerances; 4 = VECTOR TOLERANCES + ITASK=1 ! --- Normal Output + ISTATE=1 + IOPT(1)=1 ! --- 0= No optional parameters, 1=Optional parameters + IOPT(2)=1 ! --- 1=Perform sensitivity analysis; 0 if not + IOPT(3)=1 ! --- 1 if DFUNC_CHEMDPAR supplied by the user; + ! --- 0 if finite differences are to be used +C --- Set optional parameters + DO 10 i=1,LRW + RWORK(i) = 0.0D0 + 10 CONTINUE + DO 20 i=1,LIW + IWORK(i) = 0 + 20 CONTINUE + + RWORK(5) = STEPMIN ! THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. + RWORK(6) = STEPMAX ! THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. + RWORK(7) = 0.0D0 ! THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. + IWORK(6) = 5000 ! MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS + + CALL KPP_ODESSA( FUNC_CHEM,DFUNC_CHEMDPAR,NEQ,Y,PARAMS,TIN,TOUT, + & ITOL,RTOL,ATOL, + 1 ITASK,ISTATE,IOPT,RWORK,LRW,IWORK,LIW, + & JAC,MF) + + IF (ISTATE.LT.0) THEN + print *,'KPP_ODESSA: Unsucessfull exit at T=', + & TIN,' (ISTATE=',ISTATE,')' + ENDIF + + RETURN + END + + + + + SUBROUTINE FUNC_CHEM (N, T, V, PARAMS, FCT) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + DIMENSION V(NVAR), PARAMS(*), FCT(NVAR) + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + CALL Fun(V, FIX, RCONST, FCT) + RETURN + END + + SUBROUTINE DFUNC_CHEMDPAR (N, T, V, PARAMS, DFCT, JPAR) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' +C --- NCOEFF = number of rate coefficients w.r.t. which we differentiate +C (note that in some applications NCOEFF may be different than NSENSIT) +C JCOEFF(1:NCOEFF) are the indices of rate coefficients w.r.t. which we differentiate + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + DIMENSION V(NVAR), PARAMS(*), DFCT(NVAR) + INTEGER JPAR, i, JC(1) + IF (DDMTYPE .EQ. 0) THEN +C This setting is required for sensitivities w.r.t. initial conditions + DO i=1,NVAR + DFCT(i) = 0.d0 + END DO + ELSE +C This setting is required for sensitivities w.r.t. rate coefficients +C ... and should be changed by the user for other applications + JC(1) = JCOEFF(JPAR) + CALL dFun_dRcoeff(V, FIX, 1, JC, DFCT ) + END IF + RETURN + END + + SUBROUTINE JAC (N, T, V, PARAMS, ML, MU, JS, NROWPD) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + REAL*8 V(NVAR), PARAMS(*), JS(LU_NONZERO) + INTEGER ML, MU, NROWPD + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TOLD + DO i=1,LU_NONZERO + JS(i) = 0.0D0 + END DO + CALL Jac_SP(V, FIX, RCONST, JS) + RETURN + END + + +C ALGORITHM 658, COLLECTED ALGORITHMS FROM ACM. +C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, +C VOL. 14, NO. 1, P.61. +C----------------------------------------------------------------------- +C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. +C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS. +C +C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF +C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. +C THIS VERSION IS IN DOUBLE PRECISION. +C +C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. +C DY(I)/DP, FOR A SINGLE PARAMETER, OR, +C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, +C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. +C DY/DT = F(Y,T;P). +C----------------------------------------------------------------------- +C REFERENCES... +C +C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND +C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY +C DIFFERENTIAL EQUATIONS. SUBMITTED TO ACM TRANS. MATH. SOFTWARE, +C (1985). +C +C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY DIFFERENTIA +C EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS SENSITIVITY ANALYSIS. +C SUBMITTED TO ACM TRANS. MATH. SOFTWARE, (1985). +C +C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE +C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, +C VOL. 15, NO. 4 (1980), PP. 10-11. +C----------------------------------------------------------------------- +C PROBLEM STATEMENT.. +C +C THE ODESSA MODIFICATION OF THE LSODE PACKAGE PROVIDES THE OPTION TO +C CALCULATE FIRST-ORDER SENSITIVITY COEFFICIENTS FOR A SYSTEM OF STIFF +C OR NON-STIFF EXPLICIT ORDINARY DIFFERENTIAL EQUATIONS OF THE GENERAL +C FORM : +C +C DY/DT = F(Y,T;P) (1) +C +C WHERE Y IS AN N-DIMENSIONAL DEPENDENT VARIABLE VECTOR, T IS THE +C INDEPENDENT INTEGRATION VARIABLE, AND P IS AN NPAR-DIMENSIONAL +C CONSTANT VECTOR. THE GOVERNING EQUATIONS FOR THE FIRST-ORDER +C SENSITIVITY COEFFICIENTS ARE GIVEN BY : +C +C S'(T) = J(T)*S(T) + DF/DP (2) +C +C WHERE +C +C S(T) = DY(T)/DP (= SENSITIVITY FUNCTIONS) +C S'(T) = D(DY(T)/DP)/DT +C J(T) = DF(Y,T;P)/DY(T) (= JACOBIAN MATRIX) +C AND DF/DP = DF(Y,T;P)/DP (= INHOMOGENEITY MATRIX) +C +C SOLUTION OF EQUATIONS (1) AND (2) PROCEEDS SIMULTANEOUSLY VIA AN +C EXTENSION OF THE LSODE PACKAGE AS DESCRIBED IN [1]. +C---------------------------------------------------------------------- +C ACKNOWLEDGEMENT : THE FOLLOWING ODESSA PACKAGE DOCUMENTATION IS A +C MODIFICATION OF THE LSODE DOCUMENTATION WHICH +C ACCOMPANIES THE LSODE PACKAGE CODE. +C---------------------------------------------------------------------- +C SUMMARY OF USAGE. +C +C COMMUNICATION BETWEEN THE USER AND THE ODESSA PACKAGE, FOR NORMAL +C SITUATIONS, IS SUMMARIZED HERE. THIS SUMMARY DESCRIBES ONLY A SUBSET +C OF THE FULL SET OF OPTIONS AVAILABLE. SEE THE FULL DESCRIPTION FOR +C DETAILS, INCLUDING OPTIONAL COMMUNICATION, NONSTANDARD OPTIONS, +C AND INSTRUCTIONS FOR SPECIAL SITUATIONS. SEE ALSO THE EXAMPLE +C PROBLEM (WITH PROGRAM AND OUTPUT) FOLLOWING THIS SUMMARY. +C +C A. FIRST PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE F (N, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, PAR, YDOT +C DIMENSION Y(N), YDOT(N), PAR(NPAR) +C WHICH SUPPLIES THE VECTOR FUNCTION F BY LOADING YDOT(I) WITH F(I). +C N IS THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS IN THE +C ABOVE MODEL. NPAR IS THE NUMBER OF MODEL PARAMETERS FOR WHICH +C VECTOR SENSITIVITY FUNCTIONS ARE DESIRED. YOU ARE ALSO ENCOURAGED +C TO PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE DF (N, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(N), PAR(NPAR), DFDP(N) +C GO TO (1,...,NPAR) JPAR +C 1 DFDP(1) = DF(1)/DP(1) +C . +C DFDP(I) = DF(I)/DP(1) +C . +C DFDP(N) = DF(N)/DP(1) +C RETURN +C 2 DFDP(1) = DF(1)/DP(2) +C . +C DFDP(I) = DF(I)/DP(2) +C . +C DFDP(N) = DF(N)/DP(2) +C RETURN +C . . +C . . +C RETURN +C NPAR DFDP(1) = DF(1)/DP(NPAR) +C . +C DFDP(I) = DF(I)/DP(NPAR) +C . +C DFDP(N) = DF(N)/DP(NPAR) +C RETURN +C END +C ONLY NONZERO ELEMENTS NEED BE LOADED. IF THIS IS NOT FEASIBLE, +C ODESSA WILL GENERATE THIS MATRIX INTERNALLY BY DIFFERENCE QUOTIENTS. +C +C B. NEXT DETERMINE (OR GUESS) WHETHER OR NOT THE PROBLEM IS STIFF. +C STIFFNESS OCCURS WHEN THE JACOBIAN MATRIX DF/DY HAS AN EIGENVALUE +C WHOSE REAL PART IS NEGATIVE AND LARGE IN MAGNITUDE, COMPARED TO THE +C RECIPROCAL OF THE T SPAN OF INTEREST. IF THE PROBLEM IS NONSTIFF, +C USE METH = 10. IF IT IS STIFF, USE METH = 20. THE USER IS REQUIRED +C TO INPUT THE METHOD FLAG MF = 10*METH + MITER. THERE ARE FOUR +C STANDARD CHOICES FOR MITER WHEN A SENSITIVITY ANALYSIS IS DESIRED, +C AND ODESSA REQUIRES THE JACOBIAN MATRIX IN SOME FORM. +C THIS MATRIX IS REGARDED EITHER AS FULL (MITER = 1 OR 2), +C OR BANDED (MITER = 4 OR 5). IN THE BANDED CASE, ODESSA REQUIRES TWO +C HALF-BANDWIDTH PARAMETERS ML AND MU. THESE ARE, RESPECTIVELY, THE +C WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, EXCLUDING THE MAIN +C DIAGONAL. THUS THE BAND CONSISTS OF THE LOCATIONS (I,J) WITH +C I-ML .LE. J .LE. I+MU, AND THE FULL BANDWIDTH IS ML+MU+1. +C +C C. YOU ARE ENCOURAGED TO SUPPLY THE JACOBIAN DIRECTLY (MF = 11, 14, +C 21, OR 24), BUT IF THIS IS NOT FEASIBLE, ODESSA WILL COMPUTE IT +C INTERNALLY BY DIFFERENCE QUOTIENTS (MF = 12, 15, 22, OR 25). IF YOU +C ARE SUPPLYING THE JACOBIAN, PROVIDE A SUBROUTINE OF THE FORM.. +C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) +C DOUBLE PRECISION T, Y, PAR, PD +C DIMENSION Y(N), PD(NROWPD,N), PAR(NPAR) +C WHICH SUPPLIES DF/DY BY LOADING PD AS FOLLOWS.. +C FOR A FULL JACOBIAN (MF = 11, OR 21), LOAD PD(I,J) WITH DF(I)/DY(J), +C THE PARTIAL DERIVATIVE OF F(I) WITH RESPECT TO Y(J). (IGNORE THE +C ML AND MU ARGUMENTS IN THIS CASE.) +C FOR A BANDED JACOBIAN (MF = 14, OR 24), LOAD PD(I-J+MU+1,J) WITH +C DF(I)/DY(J), I.E. LOAD THE DIAGONAL LINES OF DF/DY INTO THE ROWS OF +C PD FROM THE TOP DOWN. +C IN EITHER CASE, ONLY NONZERO ELEMENTS NEED BE LOADED. +C +C D. WRITE A MAIN PROGRAM WHICH CALLS SUBROUTINE ODESSA ONCE FOR +C EACH POINT AT WHICH ANSWERS ARE DESIRED. THIS SHOULD ALSO PROVIDE +C FOR POSSIBLE USE OF LOGICAL UNIT 6 FOR OUTPUT OF ERROR MESSAGES BY +C ODESSA. ON THE FIRST CALL TO ODESSA, SUPPLY ARGUMENTS AS FOLLOWS.. +C F = NAME OF SUBROUTINE FOR RIGHT-HAND SIDE VECTOR F (MODEL). +C THIS NAME MUST BE DECLARED EXTERNAL IN CALLING PROGRAM. +C DF = NAME OF SUBROUTINE FOR INHOMOGENEITY MATRIX DF/DP. +C IF USED (IDF = 1), THIS NAME MUST BE DECLARED EXTERNAL IN +C CALLING PROGRAM. IF NOT USED (IDF = 0), PASS A DUMMY NAME. +C N = NUMBER OF FIRST ORDER ODE-S IN MODEL; LOAD INTO NEQ(1). +C NPAR = NUMBER OF MODEL PARAMETERS OF INTEREST; LOAD INTO NEQ(2). +C Y = AN (N) BY (NPAR+1) REAL ARRAY OF INITIAL VALUES.. +C Y(I,1) , I = 1,N , CONTAIN THE STATE, OR MODEL, DEPENDENT +C VARIABLES, +C Y(I,J) , J = 2,NPAR , CONTAIN THE DEPENDENT SENSITIVITY +C COEFFICIENTS. +C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING MODEL PARAMETERS +C OF INTEREST. +C T = THE INITIAL VALUE OF THE INDEPENDENT VARIABLE. +C TOUT = FIRST POINT WHERE OUTPUT IS DESIRED (.NE. T). +C ITOL = 1, 2, 3, OR 4 ACCORDING AS RTOL, ATOL (BELOW) ARE SCALARS +C OR ARRAYS. +C RTOL = RELATIVE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) +C ARRAY). +C ATOL = ABSOLUTE TOLERANCE PARAMETER (SCALAR OR (N) BY (NPAR+1) +C ARRAY). +C THE ESTIMATED LOCAL ERROR IN Y(I,J) WILL BE CONTROLLED SO AS +C TO BE ROUGHLY LESS (IN MAGNITUDE) THAN +C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL IF ITOL = 1, +C EWT(I,J) = RTOL*ABS(Y(I,J)) + ATOL(I,J) IF ITOL = 2, +C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL IF ITOL = 3, OR +C EWT(I,J) = RTOL(I,J)*ABS(Y(I,J) + ATOL(I,J) IF ITOL = 4. +C THUS THE LOCAL ERROR TEST PASSES IF, IN EACH COMPONENT, +C EITHER THE ABSOLUTE ERROR IS LESS THAN ATOL (OR ATOL(I,J)), +C OR THE RELATIVE ERROR IS LESS THAN RTOL (OR RTOL(I,J)). +C USE RTOL = 0.0 FOR PURE ABSOLUTE ERROR CONTROL, AND +C USE ATOL = 0.0 FOR PURE RELATIVE ERROR CONTROL. +C CAUTION.. ACTUAL (GLOBAL) ERRORS MAY EXCEED THESE LOCAL +C TOLERANCES, SO CHOOSE THEM CONSERVATIVELY. +C ITASK = 1 FOR NORMAL COMPUTATION OF OUTPUT VALUES OF Y AT T = TOUT. +C ISTATE = INTEGER FLAG (INPUT AND OUTPUT). SET ISTATE = 1. +C IOPT = 0, TO INDICATE NO OPTIONAL INPUTS FOR INTEGRATION; +C LOAD INTO IOPT(1). +C ISOPT = 1, TO INDICATE SENSITIVITY ANALYSIS, = 0, TO INDICATE +C NO SENSITIVITY ANALYSIS; LOAD INTO IOPT(2). +C IDF = 1, IF SUBROUTINE DF (ABOVE) IS SUPPLIED BY THE USER, +C = 0, OTHERWISE; LOAD INTO IOPT(3). +C RWORK = REAL WORK ARRAY OF LENGTH AT LEAST.. +C 22 + 16*N + N**2 FOR MF = 11 OR 12, +C 22 + 17*N + (2*ML + MU)*N FOR MF = 14 OR 15, +C 22 + 9*N + N**2 FOR MF = 21 OR 22, +C 22 + 10*N + (2*ML + MU)*N FOR MF = 24 OR 25, +C IF ISOPT = 0, OR.. +C 22 + 15*(NPAR+1)*N + N**2 + N FOR MF = 11 OR 12, +C 24 + 15*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 14 OR 15, +C 22 + 8*(NPAR+1)*N + N**2 + N FOR MF = 21 OR 22, +C 24 + 8*(NPAR+1)*N + (2*ML+MU+2)*N + N FOR MF = 24 OR 25, +C IF ISOPT = 1. +C LRW = DECLARED LENGTH OF RWORK (IN USER-S DIMENSION STATEMENT). +C IWORK = INTEGER WORK ARRAY OF LENGTH AT LEAST.. +C 20 + N IF ISOPT = 0, +C 21 + N + NPAR IF ISOPT = 1. +C IF MITER = 4 OR 5, INPUT IN IWORK(1),IWORK(2) THE LOWER +C AND UPPER HALF-BANDWIDTHS ML,MU (EXCLUDING MAIN DIAGONAL). +C LIW = DECLARED LENGTH OF IWORK (IN USER-S DIMENSION STATEMENT). +C JAC = NAME OF SUBROUTINE FOR JACOBIAN MATRIX. +C IF USED, THIS NAME MUST BE DECLARED EXTERNAL IN CALLING +C PROGRAM. IF NOT USED, PASS A DUMMY NAME. +C MF = METHOD FLAG. STANDARD VALUES FOR ISOPT = 0 ARE.. +C 10 FOR NONSTIFF (ADAMS) METHOD, NO JACOBIAN USED. +C 21 FOR STIFF (BDF) METHOD, USER-SUPPLIED FULL JACOBIAN. +C 22 FOR STIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. +C 24 FOR STIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. +C 25 FOR STIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. +C IF ISOPT = 1, MF = 10 IS ILLEGAL AND CAN BE REPLACED BY.. +C 11 FOR NONSTIFF METHOD, USER-SUPPLIED FULL JACOBIAN. +C 12 FOR NONSTIFF METHOD, INTERNALLY GENERATED FULL JACOBIAN. +C 14 FOR NONSTIFF METHOD, USER-SUPPLIED BANDED JACOBIAN. +C 15 FOR NONSTIFF METHOD, INTERNALLY GENERATED BANDED JACOBIAN. +C NOTE THAT THE MAIN PROGRAM MUST DECLARE ARRAYS Y, RWORK, IWORK, AND +C POSSIBLY ATOL AND RTOL, AS WELL AS NEQ, IOPT, AND PAR IF ISOPT = 1. +C +C E. THE OUTPUT FROM THE FIRST CALL (OR ANY CALL) IS.. +C Y = ARRAY OF COMPUTED VALUES OF Y(T) VECTOR. +C T = CORRESPONDING VALUE OF INDEPENDENT VARIABLE (NORMALLY TOUT). +C ISTATE = 2 IF ODESSA WAS SUCCESSFUL, NEGATIVE OTHERWISE. +C -1 MEANS EXCESS WORK DONE ON THIS CALL (PERHAPS WRONG MF). +C -2 MEANS EXCESS ACCURACY REQUESTED (TOLERANCES TOO SMALL). +C -3 MEANS ILLEGAL INPUT DETECTED (SEE PRINTED MESSAGE). +C -4 MEANS REPEATED ERROR TEST FAILURES (CHECK ALL INPUTS). +C -5 MEANS REPEATED CONVERGENCE FAILURES (PERHAPS BAD JACOBIAN +C SUPPLIED OR WRONG CHOICE OF MF OR TOLERANCES). +C -6 MEANS ERROR WEIGHT BECAME ZERO DURING PROBLEM. (SOLUTION +C COMPONENT I,J VANISHED, AND ATOL OR ATOL(I,J) = 0.0) +C +C F. TO CONTINUE THE INTEGRATION AFTER A SUCCESSFUL RETURN, SIMPLY +C RESET TOUT AND CALL ODESSA AGAIN. NO OTHER PARAMETERS NEED BE RESET. +C---------------------------------------------------------------------- +C EXAMPLE PROBLEM. +C +C THE FOLLOWING IS A SIMPLE EXAMPLE PROBLEM, WITH THE CODING +C NEEDED FOR ITS SOLUTION BY ODESSA. THE PROBLEM IS FROM CHEMICAL +C KINETICS, AND CONSISTS OF THE FOLLOWING THREE RATE EQUATIONS.. +C DY1/DT = -PAR(1)*Y1 + PAR(2)*Y2*Y3 ; PAR(1) = .04, PAR(2) = 1.E4 +C DY2/DT = PAR(1)*Y1 - PAR(2)*Y2*Y3 - PAR(3)*Y2**2 ; PAR(3) = 3.E7 +C DY3/DT = PAR(3)*Y2**2 +C ON THE INTERVAL FROM T = 0.0 TO T = 4.E10, WITH INITIAL CONDITIONS +C Y1 = 1.0, Y2 = Y3 = 0, AND S(I,J) = 0, I = 1,3, J = 1,3. +C THE PROBLEM IS STIFF. +C +C THE FOLLOWING CODING KppSolveS THIS PROBLEM WITH ODESSA, USING +C MF = 21 AND PRINTING RESULTS AT T = .4, 4., ..., 4.E10. +C IT USES ITOL = 4 AND ATOL MUCH SMALLER FOR Y2 THAN Y1 OR Y3, +C BECAUSE Y2 HAS MUCH SMALLER VALUES. LESS STRINGENT TOLERANCES +C ARE ASSIGNED FOR THE SENSITIVITIES TO ACHIEVE GREATER EFFICIENCY. +C AT THE END OF THE RUN, STATISTICAL QUANTITIES OF INTEREST ARE +C PRINTED (SEE OPTIONAL OUTPUTS IN THE FULL DESCRIPTION BELOW). +C +C DOUBLE PRECISION ATOL, RWORK, RTOL, T, TOUT, Y, PAR +C EXTERNAL FEX, JEX, DFEX +C DIMENSION Y(3,4), PAR(3), ATOL(3,4), RTOL(3,4), RWORK(130), +C 1 IWORK(27), NEQ(2), IOPT(3) +C N = 3 +C NPAR = 3 +C NEQ(1) = N +C NEQ(2) = NPAR +C NSV = NPAR+1 +C DO 10 I = 1,N +C DO 10 J = 1,NSV +C 10 Y(I,J) = 0.0D0 +C Y(1,1) = 1.0D0 +C PAR(1) = 0.04D0 +C PAR(2) = 1.0D4 +C PAR(3) = 3.0D7 +C T = 0.D0 +C TOUT = .4D0 +C ITOL = 4 +C ATOL(1,1) = 1.D-6 +C ATOL(2,1) = 1.D-10 +C ATOL(3,1) = 1.D-6 +C DO 20 I = 1,N +C RTOL(I,1) = 1.D-4 +C DO 15 J = 2,NSV +C RTOL(I,J) = 1.D-3 +C 15 ATOL(I,J) = 1.D2 * ATOL(I,1) +C 20 CONTINUE +C ITASK = 1 +C ISTATE = 1 +C IOPT(1) = 0 +C IOPT(2) = 1 +C IOPT(3) = 1 +C LRW = 130 +C LIW = 27 +C MF = 21 +C DO 60 IOUT = 1,12 +C CALL ODESSA(FEX,DFEX,NEQ,Y,PAR,T,TOUT,ITOL,RTOL,ATOL, +C 1 ITASK,ISTATE, IOPT,RWORK,LRW,IWORK,LIW,JEX,MF) +C WRITE(6,30)T,Y(1,1),Y(2,1),Y(3,1) +C 30 FORMAT(1X,7H AT T =,E12.4,6H Y =,3E14.6) +C DO 50 J = 2,NSV +C JPAR = J-1 +C WRITE(6,40)JPAR,Y(1,J),Y(2,J),Y(3,J) +C 40 FORMAT(20X,2HS(,I1,3H) =,3E14.6) +C 50 CONTINUE +C IF (ISTATE .LT. 0) GO TO 80 +C 60 TOUT = TOUT*10.D0 +C WRITE(6,70)IWORK(11),IWORK(12),IWORK(13),IWORK(19) +C 70 FORMAT(1X,/,12H NO. STEPS =,I4,11H NO. F-S =,I4,11H NO. J-S =, +C 1 I4,12H NO. DF-S =,I4) +C STOP +C 80 WRITE(6,90)ISTATE +C 90 FORMAT(///22H ERROR HALT.. ISTATE =,I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, YDOT, PAR +C DIMENSION Y(3), YDOT(3), PAR(3) +C YDOT(1) = -PAR(1)*Y(1) + PAR(2)*Y(2)*Y(3) +C YDOT(3) = PAR(3)*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, PAR, ML, MU, PD, NRPD) +C DOUBLE PRECISION PD, T, Y, PAR +C DIMENSION Y(3), PD(NRPD,3), PAR(3) +C PD(1,1) = -PAR(1) +C PD(1,2) = PAR(2)*Y(3) +C PD(1,3) = PAR(2)*Y(2) +C PD(2,1) = PAR(1) +C PD(2,3) = -PD(1,3) +C PD(3,2) = 2.D0*PAR(3)*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C SUBROUTINE DFEX (NEQ, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(3), PAR(3), DFDP(3) +C GO TO (1,2,3), JPAR +C 1 DFDP(1) = -Y(1) +C DFDP(2) = Y(1) +C RETURN +C 2 DFDP(1) = Y(2)*Y(3) +C DFDP(2) = -Y(2)*Y(3) +C RETURN +C 3 DFDP(2) = -Y(2)*Y(2) +C DFDP(3) = Y(2)*Y(2) +C RETURN +C END +C +C THE OUTPUT OF THIS PROGRAM (ON A DATA GENERAL MV-8000 IN +C DOUBLE PRECISION IS AS FOLLOWS: +C +C AT T = .4000E+00 Y = .985173E+00 .338641E-04 .147930E-01 +C S(1) = -.355914E+00 .390261E-03 .355524E+00 +C S(2) = .955150E-07 -.213065E-09 -.953019E-07 +C S(3) = -.158466E-10 -.529012E-12 .163756E-10 +C AT T = .4000E+01 Y = .905516E+00 .224044E-04 .944615E-01 +C S(1) = -.187621E+01 .179197E-03 .187603E+01 +C S(2) = .296093E-05 -.583104E-09 -.296034E-05 +C S(3) = -.493267E-09 -.276246E-12 .493544E-09 +C AT T = .4000E+02 Y = .715848E+00 .918628E-05 .284143E+00 +C S(1) = -.424730E+01 .459360E-04 .424726E+01 +C S(2) = .137294E-04 -.235815E-09 -.137291E-04 +C S(3) = -.228818E-08 -.113803E-12 .228829E-08 +C AT T = .4000E+03 Y = .450526E+00 .322299E-05 .549471E+00 +C S(1) = -.595837E+01 .354310E-05 .595836E+01 +C S(2) = .227380E-04 -.226041E-10 -.227380E-04 +C S(3) = -.378971E-08 -.499501E-13 .378976E-08 +C AT T = .4000E+04 Y = .183185E+00 .894131E-06 .816814E+00 +C S(1) = -.475006E+01 -.599504E-05 .475007E+01 +C S(2) = .188089E-04 .231330E-10 -.188089E-04 +C S(3) = -.313478E-08 -.187575E-13 .313480E-08 +C AT T = .4000E+05 Y = .389733E-01 .162133E-06 .961027E+00 +C S(1) = -.157477E+01 -.276199E-05 .157477E+01 +C S(2) = .628668E-05 .110026E-10 -.628670E-05 +C S(3) = -.104776E-08 -.453588E-14 .104776E-08 +C AT T = .4000E+06 Y = .493609E-02 .198411E-07 .995064E+00 +C S(1) = -.236244E+00 -.458262E-06 .236244E+00 +C S(2) = .944669E-06 .183193E-11 -.944671E-06 +C S(3) = -.157441E-09 -.635990E-15 .157442E-09 +C AT T = .4000E+07 Y = .516087E-03 .206540E-08 .999484E+00 +C S(1) = -.256277E-01 -.509808E-07 .256278E-01 +C S(2) = .102506E-06 .203905E-12 -.102506E-06 +C S(3) = -.170825E-10 -.684002E-16 .170826E-10 +C AT T = .4000E+08 Y = .519314E-04 .207736E-09 .999948E+00 +C S(1) = -.259316E-02 -.518029E-08 .259316E-02 +C S(2) = .103726E-07 .207209E-13 -.103726E-07 +C S(3) = -.172845E-11 -.691450E-17 .172845E-11 +C AT T = .4000E+09 Y = .544710E-05 .217885E-10 .999995E+00 +C S(1) = -.271637E-03 -.541849E-09 .271638E-03 +C S(2) = .108655E-08 .216739E-14 -.108655E-08 +C S(3) = -.180902E-12 -.723615E-18 .180902E-12 +C AT T = .4000E+10 Y = .446748E-06 .178699E-11 .100000E+01 +C S(1) = -.322322E-04 -.842541E-10 .322323E-04 +C S(2) = .128929E-09 .337016E-15 -.128929E-09 +C S(3) = -.209715E-13 -.838859E-19 .209715E-13 +C AT T = .4000E+11 Y = -.363960E-07 -.145584E-12 .100000E+01 +C S(1) = -.164109E-06 -.429604E-11 .164113E-06 +C S(2) = .656436E-12 .171842E-16 -.656451E-12 +C S(3) = -.689361E-15 -.275745E-20 .689363E-15 +C +C NO. STEPS = 340 NO. F-S = 412 NO. J-S = 343 NO. DF-S =1023 +C---------------------------------------------------------------------- +C FULL DESCRIPTION OF USER INTERFACE TO ODESSA. +C +C THE USER INTERFACE TO ODESSA CONSISTS OF THE FOLLOWING PARTS. +C +C I. THE CALL SEQUENCE TO SUBROUTINE ODESSA, WHICH IS A DRIVER +C ROUTINE FOR THE KppSolveR. THIS INCLUDES DESCRIPTIONS OF BOTH +C THE CALL SEQUENCE ARGUMENTS AND OF USER-SUPPLIED ROUTINES. +C FOLLOWING THESE DESCRIPTIONS IS A DESCRIPTION OF +C OPTIONAL INPUTS AVAILABLE THROUGH THE CALL SEQUENCE, AND THEN +C A DESCRIPTION OF OPTIONAL OUTPUTS (IN THE WORK ARRAYS). +C +C II. DESCRIPTIONS OF OTHER ROUTINES IN THE ODESSA PACKAGE THAT MAY +C BE (OPTIONALLY) CALLED BY THE USER. THESE PROVIDE THE ABILITY +C TO ALTER ERROR MESSAGE HANDLING, SAVE AND RESTORE THE INTERNAL +C COMMON, AND OBTAIN SPECIFIED DERIVATIVES OF THE SOLUTION Y(T). +C +C III. DESCRIPTIONS OF COMMON BLOCKS TO BE DECLARED IN OVERLAY +C OR SIMILAR ENVIRONMENTS, OR TO BE SAVED WHEN DOING AN INTERRUPT +C OF THE PROBLEM AND CONTINUED SOLUTION LATER. +C +C IV. DESCRIPTION OF TWO SUBROUTINES IN THE ODESSA PACKAGE, EITHER OF +C WHICH THE USER MAY REPLACE WITH HIS OWN VERSION, IF DESIRED. +C THESE RELATE TO THE MEASUREMENT OF ERRORS. +C +C V. GENERAL REMARKS WHICH HIGHLIGHT DIFFERENCES BETWEEN THE LSODE +C PACKAGE AND THE ODESSA PACKAGE. +C---------------------------------------------------------------------- +C PART I. CALL SEQUENCE. +C +C THE CALL SEQUENCE PARAMETERS USED FOR INPUT ONLY ARE.. +C F, DF, NEQ, PAR, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, +C JAC, MF, +C AND THOSE USED FOR BOTH INPUT AND OUTPUT ARE +C Y, T, ISTATE. +C THE WORK ARRAYS RWORK AND IWORK ARE ALSO USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. (THE TERM OUTPUT HERE REFERS +C TO THE RETURN FROM SUBROUTINE ODESSA TO THE USER-S CALLING PROGRAM.) +C +C THE LEGALITY OF INPUT PARAMETERS WILL BE THOROUGHLY CHECKED ON THE +C INITIAL CALL FOR THE PROBLEM, BUT NOT CHECKED THEREAFTER UNLESS A +C CHANGE IN INPUT PARAMETERS IS FLAGGED BY ISTATE = 3 ON INPUT. +C +C THE DESCRIPTIONS OF THE CALL ARGUMENTS ARE AS FOLLOWS. +C +C F = THE NAME OF THE USER-SUPPLIED SUBROUTINE DEFINING THE +C ODE MODEL. THIS SYSTEM MUST BE PUT IN THE FIRST-ORDER +C FORM DY/DT = F(Y,T;P), WHERE F IS A VECTOR-VALUED FUNCTION +C OF THE SCALAR T AND VECTORS Y, AND PAR. SUBROUTINE F IS TO +C COMPUTE THE FUNCTION F. IT IS TO HAVE THE FORM.. +C SUBROUTINE F (NEQ, T, Y, PAR, YDOT) +C DOUBLE PRECISION T, Y, PAR, YDOT +C DIMENSION Y(1), PAR(1), YDOT(1) +C WHERE NEQ, T, Y, AND PAR ARE INPUT, AND YDOT = F(Y,T;P) +C IS OUTPUT. Y AND YDOT ARE ARRAYS OF LENGTH N (= NEQ(1)). +C (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY +C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C F SHOULD NOT ALTER ARRAY Y, OR PAR(1),...,PAR(NPAR). +C F MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C +C SUBROUTINE F MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN F) AND PAR HAS LENGTH EXCEEDING NPAR. +C SEE THE DESCRIPTIONS OF NEQ AND PAR BELOW. +C +C DF = THE NAME OF THE USER-SUPPLIED ROUTINE (IDF = 1) TO COMPUTE +C THE INHOMOGENEITY MATRIX, DF/DP, AS A FUNCTION OF THE SCALAR +C T, AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM +C SUBROUTINE DF (NEQ, T, Y, PAR, DFDP, JPAR) +C DOUBLE PRECISION T, Y, PAR, DFDP +C DIMENSION Y(1), PAR(1), DFDP(1) +C GO TO (1,2,...,NPAR) JPAR +C 1 DFDP(1) = DF(1)/DP(1) +C . +C DFDP(I) = DF(I)/DP(1) +C . +C DFDP(N) = DF(N)/DP(1) +C RETURN +C 2 DFDP(1) = DF(1)/DP(2) +C . +C DFDP(I) = DF(I)/DP(2) +C . +C DFDP(N) = DF(N)/DP(2) +C . +C RETURN +C . . +C . . +C NPAR DFDP(1) = DF(1)/DP(NPAR) +C . +C DFDP(I) = DF(I)/DP(NPAR) +C . +C DFDP(N) = DF(N)/DP(NPAR) +C RETURN +C END +C WHERE NEQ, T, Y, PAR, AND JPAR ARE INPUT AND THE VECTOR +C DFDP(*,JPAR) IS TO BE LOADED WITH THE PARTIAL DERIVATIVES +C DF(Y,T;PAR)/DP(JPAR) ON OUTPUT. ONLY NONZERO ELEMENTS NEED +C BE LOADED. T, Y, AND PAR HAVE THE SAME MEANING AS IN +C SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A DUMMY +C DIMENSION.. IT CAN BE REPLACED BY ANY VALUE). +C +C DFDP(*,JPAR) IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY +C THE NONZERO ELEMENTS NEED BE LOADED BY DF. SUBROUTINE DF +C MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM IF USED. +C IF IDF = 0 (OR ISOPT = 0), A DUMMY ARGUMENT CAN BE USED. +C +C SUBROUTINE DF MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),... IF NEQ IS AN ARRAY +C (DIMENSIONED IN DF) AND PAR HAS A LENGTH EXCEEDING NPAR. +C SEE THE DESCRIPTIONS OF NEQ AND PAR (BELOW). +C +C NEQ = THE SIZE OF THE ODE SYSTEM (NUMBER OF FIRST ORDER ORDINARY +C DIFFERENTIAL EQUATIONS (N) IN THE MODEL). USED ONLY FOR +C INPUT. NEQ MAY NOT BE CHANGED DURING THE PROBLEM. +C +C FOR ISOPT = 0, NEQ IS NORMALLY A SCALAR. HOWEVER, NEQ MAY +C BE AN ARRAY, WITH NEQ(1) SET TO THE SYSTEM SIZE (N), IN WHICH +C CASE THE ODESSA PACKAGE ACCESSES ONLY NEQ(1). HOWEVER, +C THIS PARAMETER IS PASSED AS THE NEQ ARGUMENT IN ALL CALLS +C TO F, DF, AND JAC. HENCE, IF IT IS AN ARRAY, LOCATIONS +C NEQ(2),... MAY BE USED TO STORE OTHER INTEGER DATA AND PASS +C IT TO F, DF, AND/OR JAC. FOR ISOPT = 1, NPAR MUST BE LOADED +C INTO NEQ(2), AND IS NOT ALLOWED TO CHANGE DURING THE PROBLEM. +C IN THESE CASES, SUBROUTINES F, DF, AND/OR JAC MUST INCLUDE +C NEQ IN A DIMENSION STATEMENT. +C +C Y = A REAL ARRAY FOR THE VECTOR OF DEPENDENT VARIABLES, OF +C DIMENSION (N) BY (NPAR+1). USED FOR BOTH INPUT AND +C OUTPUT ON THE FIRST CALL (ISTATE = 1), AND ONLY FOR +C OUTPUT ON OTHER CALLS. ON THE FIRST CALL, Y MUST CONTAIN +C THE VECTORS OF INITIAL VALUES. ON OUTPUT, Y CONTAINS THE +C COMPUTED SOLUTION VECTORS, EVALUATED AT T. +C +C PAR = A REAL ARRAY FOR THE VECTOR OF CONSTANT MODEL PARAMETERS +C OF INTEREST IN THE SENSITIVITY ANALYSIS, OF LENGTH NPAR +C OR MORE. PAR IS PASSED AS AN ARGUMENT IN ALL CALLS TO F, +C DF, AND JAC. HENCE LOCATIONS PAR(NPAR+1),... MAY BE USED +C TO STORE OTHER REAL DATA AND PASS IT TO F, DF, AND/OR JAC. +C LOCATIONS PAR(1),...,PAR(NPAR) ARE USED AS INPUT ONLY, +C AND MUST NOT BE CHANGED DURING THE PROBLEM. +C +C T = THE INDEPENDENT VARIABLE. ON INPUT, T IS USED ONLY ON THE +C FIRST CALL, AS THE INITIAL POINT OF THE INTEGRATION. +C ON OUTPUT, AFTER EACH CALL, T IS THE VALUE AT WHICH A +C COMPUTED SOLUTION Y IS EVALUATED (USUALLY THE SAME AS TOUT). +C ON AN ERROR RETURN, T IS THE FARTHEST POINT REACHED. +C +C TOUT = THE NEXT VALUE OF T AT WHICH A COMPUTED SOLUTION IS DESIRED. +C USED ONLY FOR INPUT. +C +C WHEN STARTING THE PROBLEM (ISTATE = 1), TOUT MAY BE EQUAL +C TO T FOR ONE CALL, THEN SHOULD .NE. T FOR THE NEXT CALL. +C FOR THE INITIAL T, AN INPUT VALUE OF TOUT .NE. T IS USED +C IN ORDER TO DETERMINE THE DIRECTION OF THE INTEGRATION +C (I.E. THE ALGEBRAIC SIGN OF THE STEP SIZES) AND THE ROUGH +C SCALE OF THE PROBLEM. INTEGRATION IN EITHER DIRECTION +C (FORWARD OR BACKWARD IN T) IS PERMITTED. +C +C IF ITASK = 2 OR 5 (ONE-STEP MODES), TOUT IS IGNORED AFTER +C THE FIRST CALL (I.E. THE FIRST CALL WITH TOUT .NE. T). +C OTHERWISE, TOUT IS REQUIRED ON EVERY CALL. +C +C IF ITASK = 1, 3, OR 4, THE VALUES OF TOUT NEED NOT BE +C MONOTONE, BUT A VALUE OF TOUT WHICH BACKS UP IS LIMITED +C TO THE CURRENT INTERNAL T INTERVAL, WHOSE ENDPOINTS ARE +C TCUR - HU AND TCUR (SEE OPTIONAL OUTPUTS, BELOW, FOR +C TCUR AND HU). +C +C ITOL = AN INDICATOR FOR THE TYPE OF ERROR CONTROL. SEE +C DESCRIPTION BELOW UNDER ATOL. USED ONLY FOR INPUT. +C +C RTOL = A RELATIVE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF SPACE (N) BY (NPAR+1). SEE DESCRIPTION BELOW +C UNDER ATOL. INPUT ONLY. +C +C ATOL = AN ABSOLUTE ERROR TOLERANCE PARAMETER, EITHER A SCALAR OR +C AN ARRAY OF SPACE (N) BY (NPAR+1). INPUT ONLY. +C +C THE INPUT PARAMETERS ITOL, RTOL, AND ATOL DETERMINE +C THE ERROR CONTROL PERFORMED BY THE KppSolveR. THE KppSolveR WILL +C CONTROL THE VECTOR E = (E(I,J)) OF ESTIMATED LOCAL ERRORS +C IN Y, ACCORDING TO AN INEQUALITY OF THE FORM +C RMS-NORM OF ( E(I,J)/EWT(I,J) ) .LE. 1, +C WHERE EWT(I,J) = RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J), +C AND THE RMS-NORM (ROOT-MEAN-SQUARE NORM) HERE IS +C RMS-NORM(V) = SQRT ( (1/N) * SUM (V(I,J)**2) ); I =1,...,N. +C HERE EWT = (EWT(I,J)) IS A VECTOR OF WEIGHTS WHICH MUST +C ALWAYS BE POSITIVE, AND THE VALUES OF RTOL AND ATOL SHOULD +C ALL BE NON-NEGATIVE. THE FOLLOWING TABLE GIVES THE TYPES +C (SCALAR/ARRAY) OF RTOL AND ATOL, AND THE CORRESPONDING FORM +C OF EWT(I,J). +C +C ITOL RTOL ATOL EWT(I,J) +C 1 SCALAR SCALAR RTOL*ABS(Y(I,J)) + ATOL +C 2 SCALAR ARRAY RTOL*ABS(Y(I,J)) + ATOL(I,J) +C 3 ARRAY SCALAR RTOL(I,J)*ABS(Y(I,J)) + ATOL +C 4 ARRAY ARRAY RTOL(I,J)*ABS(Y(I,J)) + ATOL(I,J) +C +C WHEN EITHER OF THESE PARAMETERS IS A SCALAR, IT NEED NOT +C BE DIMENSIONED IN THE USER-S CALLING PROGRAM. +C +C THE TOTAL NUMBER OF ERROR TEST FAILURES DUE TO THE SENSITIVITY +C ANALYSIS, AND WHICH REQUIRE AN INTEGRATION STEP TO BE +C REPEATED, ARE ACCUMULATED IN THE LAST NPAR+1 LOCATIONS OF THE +C INTEGER WORK ARRAY IWORK (SEE OPTIONAL OUTPUTS BELOW). +C THIS INFORMATION MAY BE OF VALUE IN DETERMINING APPROPRIATE +C ERROR TOLERANCES TO BE APPLIED TO THE SENSITIVITY FUNCTIONS. +C +C IF NONE OF THE ABOVE CHOICES (WITH ITOL, RTOL, AND ATOL +C FIXED THROUGHOUT THE PROBLEM) IS SUITABLE, MORE GENERAL +C ERROR CONTROLS CAN BE OBTAINED BY SUBSTITUTING +C USER-SUPPLIED ROUTINES FOR THE SETTING OF EWT AND/OR FOR +C THE NORM CALCULATION. SEE PART IV BELOW. +C +C IF GLOBAL ERRORS ARE TO BE ESTIMATED BY MAKING A REPEATED +C RUN ON THE SAME PROBLEM WITH SMALLER TOLERANCES, THEN ALL +C COMPONENTS OF RTOL AND ATOL (I.E. OF EWT) SHOULD BE SCALED +C DOWN UNIFORMLY. +C +C ITASK = AN INDEX SPECIFYING THE TASK TO BE PERFORMED. +C INPUT ONLY. ITASK HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT (BY OVERSHOOTING AND INTERPOLATING). +C 2 MEANS TAKE ONE STEP ONLY AND RETURN. +C 3 MEANS STOP AT THE FIRST INTERNAL MESH POINT AT OR +C BEYOND T = TOUT AND RETURN. +C 4 MEANS NORMAL COMPUTATION OF OUTPUT VALUES OF Y(T) AT +C T = TOUT BUT WITHOUT OVERSHOOTING T = TCRIT. +C TCRIT MUST BE INPUT AS RWORK(1). TCRIT MAY BE EQUAL TO +C OR BEYOND TOUT, BUT NOT BEHIND IT IN THE DIRECTION OF +C INTEGRATION. THIS OPTION IS USEFUL IF THE PROBLEM +C HAS A SINGULARITY AT OR BEYOND T = TCRIT. +C 5 MEANS TAKE ONE STEP, WITHOUT PASSING TCRIT, AND RETURN. +C TCRIT MUST BE INPUT AS RWORK(1). +C +C NOTE.. IF ITASK = 4 OR 5 AND THE KppSolveR REACHES TCRIT +C (WITHIN ROUNDOFF), IT WILL RETURN T = TCRIT (EXACTLY) TO +C INDICATE THIS (UNLESS ITASK = 4 AND TOUT COMES BEFORE TCRIT, +C IN WHICH CASE ANSWERS AT T = TOUT ARE RETURNED FIRST). +C +C ISTATE = AN INDEX USED FOR INPUT AND OUTPUT TO SPECIFY THE +C THE STATE OF THE CALCULATION. +C +C ON INPUT, THE VALUES OF ISTATE ARE AS FOLLOWS. +C 1 MEANS THIS IS THE FIRST CALL FOR THE PROBLEM +C (INITIALIZATIONS WILL BE DONE). SEE NOTE BELOW. +C 2 MEANS THIS IS NOT THE FIRST CALL, AND THE CALCULATION +C IS TO CONTINUE NORMALLY, WITH NO CHANGE IN ANY INPUT +C PARAMETERS EXCEPT POSSIBLY TOUT AND ITASK. +C (IF ITOL, RTOL, AND/OR ATOL ARE CHANGED BETWEEN CALLS +C WITH ISTATE = 2, THE NEW VALUES WILL BE USED BUT NOT +C TESTED FOR LEGALITY.) +C 3 MEANS THIS IS NOT THE FIRST CALL, AND THE +C CALCULATION IS TO CONTINUE NORMALLY, BUT WITH +C A CHANGE IN INPUT PARAMETERS OTHER THAN +C TOUT AND ITASK. CHANGES ARE ALLOWED IN +C ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, +C AND ANY OF THE OPTIONAL INPUTS EXCEPT H0. +C (SEE IWORK DESCRIPTION FOR ML AND MU.) +C NOTE.. A PRELIMINARY CALL WITH TOUT = T IS NOT COUNTED +C AS A FIRST CALL HERE, AS NO INITIALIZATION OR CHECKING OF +C INPUT IS DONE. (SUCH A CALL IS SOMETIMES USEFUL FOR THE +C PURPOSE OF OUTPUTTING THE INITIAL CONDITIONS.) +C THUS THE FIRST CALL FOR WHICH TOUT .NE. T REQUIRES +C ISTATE = 1 ON INPUT. +C +C ON OUTPUT, ISTATE HAS THE FOLLOWING VALUES AND MEANINGS. +C 1 MEANS NOTHING WAS DONE, AS TOUT WAS EQUAL TO T WITH +C ISTATE = 1 ON INPUT. (HOWEVER, AN INTERNAL COUNTER WAS +C SET TO DETECT AND PREVENT REPEATED CALLS OF THIS TYPE.) +C 2 MEANS THE INTEGRATION WAS PERFORMED SUCCESSFULLY. +C -1 MEANS AN EXCESSIVE AMOUNT OF WORK (MORE THAN MXSTEP +C STEPS) WAS DONE ON THIS CALL, BEFORE COMPLETING THE +C REQUESTED TASK, BUT THE INTEGRATION WAS OTHERWISE +C SUCCESSFUL AS FAR AS T. (MXSTEP IS AN OPTIONAL INPUT +C AND IS NORMALLY 500.) TO CONTINUE, THE USER MAY +C SIMPLY RESET ISTATE TO A VALUE .GT. 1 AND CALL AGAIN +C (THE EXCESS WORK STEP COUNTER WILL BE RESET TO 0). +C IN ADDITION, THE USER MAY INCREASE MXSTEP TO AVOID +C THIS ERROR RETURN (SEE BELOW ON OPTIONAL INPUTS). +C -2 MEANS TOO MUCH ACCURACY WAS REQUESTED FOR THE PRECISION +C OF THE MACHINE BEING USED. THIS WAS DETECTED BEFORE +C COMPLETING THE REQUESTED TASK, BUT THE INTEGRATION +C WAS SUCCESSFUL AS FAR AS T. TO CONTINUE, THE TOLERANCE +C PARAMETERS MUST BE RESET, AND ISTATE MUST BE SET +C TO 3. THE OPTIONAL OUTPUT TOLSF MAY BE USED FOR THIS +C PURPOSE. (NOTE.. IF THIS CONDITION IS DETECTED BEFORE +C TAKING ANY STEPS, THEN AN ILLEGAL INPUT RETURN +C (ISTATE = -3) OCCURS INSTEAD.) +C -3 MEANS ILLEGAL INPUT WAS DETECTED, BEFORE TAKING ANY +C INTEGRATION STEPS. SEE WRITTEN MESSAGE FOR DETAILS. +C NOTE.. IF THE KppSolveR DETECTS AN INFINITE LOOP OF CALLS +C TO THE KppSolveR WITH ILLEGAL INPUT, IT WILL CAUSE +C THE RUN TO STOP. +C -4 MEANS THERE WERE REPEATED ERROR TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THE PROBLEM MAY HAVE A SINGULARITY, OR THE INPUT +C MAY BE INAPPROPRIATE. +C -5 MEANS THERE WERE REPEATED CONVERGENCE TEST FAILURES ON +C ONE ATTEMPTED STEP, BEFORE COMPLETING THE REQUESTED +C TASK, BUT THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C THIS MAY BE CAUSED BY AN INACCURATE JACOBIAN MATRIX, +C IF ONE IS BEING USED. +C -6 MEANS EWT(I,J) BECAME ZERO FOR SOME I,J DURING THE +C INTEGRATION. PURE RELATIVE ERROR CONTROL (ATOL(I,J)=0.0) +C WAS REQUESTED ON A VARIABLE WHICH HAS NOW VANISHED. +C THE INTEGRATION WAS SUCCESSFUL AS FAR AS T. +C +C NOTE.. SINCE THE NORMAL OUTPUT VALUE OF ISTATE IS 2, +C IT DOES NOT NEED TO BE RESET FOR NORMAL CONTINUATION. +C ALSO, SINCE A NEGATIVE INPUT VALUE OF ISTATE WILL BE +C REGARDED AS ILLEGAL, A NEGATIVE OUTPUT VALUE REQUIRES THE +C USER TO CHANGE IT, AND POSSIBLY OTHER INPUTS, BEFORE +C CALLING THE KppSolveR AGAIN. +C +C IOPT = AN INTEGER ARRAY FLAG TO SPECIFY WHETHER OR NOT ANY OPTIONAL +C INPUTS ARE BEING USED ON THIS CALL. INPUT ONLY. +C THE OPTIONAL INPUTS ARE LISTED SEPARATELY BELOW. +C IOPT(1) = 0 MEANS NO OPTIONAL INPUTS FOR THE KppSolveR WILL BE +C USED. DEFAULT VALUES WILL BE USED IN ALL CASES. +C = 1 MEANS ONE OR MORE OPTIONAL INPUTS FOR THE +C KppSolveR ARE BEING USED. +C NOTE : IOPT(1) IS INDEPENDENT OF ISOPT AND IDF. +C IOPT(2) = 0 MEANS NO SENSITIVITY ANALYSIS WILL BE PERFORMED. +C = 1 MEANS A SENSITIVITY ANALYSIS WILL BE PERFORMED. +C NOTE : IOPT(2) IS RENAMED TO ISOPT IN ODESSA. +C = 0 MEANS DF/DP WILL BE CALCULATED BY FINITE +C DIFFERENCE WITHIN ODESSA. +C IOPT(3) = 1 MEANS DF/DP WILL BE CALCULATED BY A USER-SUPPLIED +C ROUTINE. +C NOTE : IOPT(3) IS RENAMED TO IDF IN ODESSA. +C IF IDF = 1, THE USER MUST SUPPLY A +C SUBROUTINE DF (THE NAME IS ARBITRARY) AS +C DESCRIBED BELOW UNDER DF. FOR IDF = 0, +C A DUMMY ARGUMENT CAN BE USED. +C +C RWORK = A REAL WORKING ARRAY (DOUBLE PRECISION). +C FOR ISOPT = 0, THE LENGTH OF RWORK MUST BE AT LEAST.. +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM +C FOR ISOPT = 1, THE LENGTH OF RWORK MUST BE AT LEAST.. +C 20 + NYH*(MAXORD + 1) + 2*NYH + LWM + N +C WHERE.. +C NYH = THE TOTAL NUMBER OF DEPENDENT VARIABLES; +C (= N IF ISOPT = 0, AND N*(NPAR+1) IF ISOPT = 1). +C MAXORD = 12 (IF METH = 1) OR 5 (IF METH = 2) (UNLESS A +C SMALLER VALUE IS GIVEN AS AN OPTIONAL INPUT), +C LWM = 0 IF MITER = 0, +C LWM = N**2 + 2 IF MITER IS 1 OR 2, +C LWM = N + 2 IF MITER = 3, AND +C LWM = (2*ML+MU+1)*N + 2 IF MITER IS 4 OR 5. +C (SEE THE MF DESCRIPTION FOR METH AND MITER.) +C +C THE FIRST 20 WORDS OF RWORK ARE RESERVED FOR CONDITIONAL +C AND OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING WORD IN RWORK IS A CONDITIONAL INPUT.. +C RWORK(1) = TCRIT = CRITICAL VALUE OF T WHICH THE KppSolveR +C IS NOT TO OVERSHOOT. REQUIRED IF ITASK IS +C 4 OR 5, AND IGNORED OTHERWISE. (SEE ITASK.) +C +C LRW = THE LENGTH OF THE ARRAY RWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE KppSolveR.) +C +C IWORK = AN INTEGER WORK ARRAY. THE LENGTH MUST BE AT LEAST.. +C 20 IF MITER = 0 OR 3 (MF = 10, 13, 20, 23), OR +C 20 + N OTHERWISE (MF = 11, 12, 14, 15, 21, 22, 24, 25). +C FOR ISOPT = 0, OR.. +C 21 + N + NPAR +C FOR ISOPT = 1. +C THE FIRST FEW WORDS OF IWORK ARE USED FOR CONDITIONAL AND +C OPTIONAL INPUTS AND OPTIONAL OUTPUTS. +C +C THE FOLLOWING 2 WORDS IN IWORK ARE CONDITIONAL INPUTS.. +C IWORK(1) = ML THESE ARE THE LOWER AND UPPER +C IWORK(2) = MU HALF-BANDWIDTHS, RESPECTIVELY, OF THE +C BANDED JACOBIAN, EXCLUDING THE MAIN DIAGONAL. +C THE BAND IS DEFINED BY THE MATRIX LOCATIONS +C (I,J) WITH I-ML .LE. J .LE. I+MU. ML AND MU +C MUST SATISFY 0 .LE. ML,MU .LE. NEQ-1. +C THESE ARE REQUIRED IF MITER IS 4 OR 5, AND +C IGNORED OTHERWISE. ML AND MU MAY IN FACT BE +C THE BAND PARAMETERS FOR A MATRIX TO WHICH +C DF/DY IS ONLY APPROXIMATELY EQUAL. +* +C +C LIW = THE LENGTH OF THE ARRAY IWORK, AS DECLARED BY THE USER. +C (THIS WILL BE CHECKED BY THE KppSolveR.) +C +C NOTE.. THE WORK ARRAYS MUST NOT BE ALTERED BETWEEN CALLS TO ODESSA +C FOR THE SAME PROBLEM, EXCEPT POSSIBLY FOR THE CONDITIONAL AND +C OPTIONAL INPUTS, AND EXCEPT FOR THE LAST 2*NYH + N WORDS OF RWORK. +C THE LATTER SPACE IS USED FOR INTERNAL SCRATCH SPACE, AND SO IS +C AVAILABLE FOR USE BY THE USER OUTSIDE ODESSA BETWEEN CALLS, IF +C DESIRED (BUT NOT FOR USE BY F, DF, OR JAC). +C +C JAC = THE NAME OF THE USER-SUPPLIED ROUTINE (MITER = 1 OR 4) TO +C COMPUTE THE JACOBIAN MATRIX, DF/DY, AS A FUNCTION OF THE +C SCALAR T AND THE VECTORS Y, AND PAR. IT IS TO HAVE THE FORM +C SUBROUTINE JAC (NEQ, T, Y, PAR, ML, MU, PD, NROWPD) +C DOUBLE PRECISION T, Y, PAR, PD +C DIMENSION Y(1), PAR(1), PD(NROWPD,1) +C WHERE NEQ, T, Y, PAR, ML, MU, AND NROWPD ARE INPUT AND THE +C ARRAY PD IS TO BE LOADED WITH PARTIAL DERIVATIVES (ELEMENTS +C OF THE JACOBIAN MATRIX) ON OUTPUT. PD MUST BE GIVEN A FIRST +C DIMENSION OF NROWPD. T, Y, AND PAR HAVE THE SAME MEANING AS +C IN SUBROUTINE F. (IN THE DIMENSION STATEMENT ABOVE, 1 IS A +C DUMMY DIMENSION.. IT CAN BE REPLACED BY ANY VALUE.) +C IN THE FULL MATRIX CASE (MITER = 1), ML AND MU ARE +C IGNORED, AND THE JACOBIAN IS TO BE LOADED INTO PD IN +C COLUMNWISE MANNER, WITH DF(I)/DY(J) LOADED INTO PD(I,J). +C IN THE BAND MATRIX CASE (MITER = 4), THE ELEMENTS +C WITHIN THE BAND ARE TO BE LOADED INTO PD IN COLUMNWISE +C MANNER, WITH DIAGONAL LINES OF DF/DY LOADED INTO THE ROWS +C OF PD. THUS DF(I)/DY(J) IS TO BE LOADED INTO PD(I-J+MU+1,J). +C ML AND MU ARE THE HALF-BANDWIDTH PARAMETERS (SEE IWORK). +C THE LOCATIONS IN PD IN THE TWO TRIANGULAR AREAS WHICH +C CORRESPOND TO NONEXISTENT MATRIX ELEMENTS CAN BE IGNORED +C OR LOADED ARBITRARILY, AS THEY ARE OVERWRITTEN BY ODESSA. +C PD IS PRESET TO ZERO BY THE KppSolveR, SO THAT ONLY THE +C NONZERO ELEMENTS NEED BE LOADED BY JAC. EACH CALL TO JAC IS +C PRECEDED BY A CALL TO F WITH THE SAME ARGUMENTS NEQ, T, Y, +C AND PAR. THUS TO GAIN SOME EFFICIENCY, INTERMEDIATE +C QUANTITIES SHARED BY BOTH CALCULATIONS MAY BE SAVED IN A +C USER COMMON BLOCK BY F AND NOT RECOMPUTED BY JAC, IF +C DESIRED. ALSO, JAC MAY ALTER THE Y ARRAY, IF DESIRED. +C JAC MUST BE DECLARED EXTERNAL IN THE CALLING PROGRAM. +C SUBROUTINE JAC MAY ACCESS USER-DEFINED QUANTITIES IN +C NEQ(2),... AND PAR(NPAR+1),.... SEE THE DESCRIPTIONS OF +C NEQ (ABOVE) AND PAR (BELOW). +C +C MF = THE METHOD FLAG. USED ONLY FOR INPUT. THE LEGAL VALUES OF +C MF ARE 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, AND 25. +C MF HAS DECIMAL DIGITS METH AND MITER.. MF = 10*METH + MITER. +C METH INDICATES THE BASIC LINEAR MULTISTEP METHOD.. +C METH = 1 MEANS THE IMPLICIT ADAMS METHOD. +* +C METH = 2 MEANS THE METHOD BASED ON BACKWARD +C DIFFERENTIATION FORMULAS (BDF-S). +C MITER INDICATES THE CORRECTOR ITERATION METHOD.. +C MITER = 0 MEANS FUNCTIONAL ITERATION (NO JACOBIAN MATRIX +C IS INVOLVED). +C MITER = 1 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C FULL (NEQ BY NEQ) JACOBIAN. +C MITER = 2 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED (DIFFERENCE QUOTIENT) FULL JACOBIAN +C (USING NEQ EXTRA CALLS TO F PER DF/DY VALUE). +C MITER = 3 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED DIAGONAL JACOBIAN APPROXIMATION. +C (USING 1 EXTRA CALL TO F PER DF/DY EVALUATION). +C MITER = 4 MEANS CHORD ITERATION WITH A USER-SUPPLIED +C BANDED JACOBIAN. +C MITER = 5 MEANS CHORD ITERATION WITH AN INTERNALLY +C GENERATED BANDED JACOBIAN (USING ML+MU+1 EXTRA +C CALLS TO F PER DF/DY EVALUATION). +C IF MITER = 1 OR 4, THE USER MUST SUPPLY A SUBROUTINE JAC +C (THE NAME IS ARBITRARY) AS DESCRIBED ABOVE UNDER JAC. +C FOR OTHER VALUES OF MITER, A DUMMY ARGUMENT CAN BE USED. +C +C IF A SENSITIVITY ANLYSIS IS DESIRED (ISOPT = 1), MITER = 0 +C AND 3 ARE DISALLOWED. IN THESE CASES, THE USER IS RECOMMENDED +C TO SUPPLY AN ANALYTICAL JACOBIAN (MITER = 1 OR 4) AND AN +C ANALYTICAL INHOMOGENEITY MATRIX (IDF = 1). +C---------------------------------------------------------------------- +C OPTIONAL INPUTS. +C +C THE FOLLOWING IS A LIST OF THE OPTIONAL INPUTS PROVIDED FOR IN THE +C CALL SEQUENCE. (SEE ALSO PART II.) FOR EACH SUCH INPUT VARIABLE, +C THIS TABLE LISTS ITS NAME AS USED IN THIS DOCUMENTATION, ITS +C LOCATION IN THE CALL SEQUENCE, ITS MEANING, AND THE DEFAULT VALUE. +C THE USE OF ANY OF THESE INPUTS REQUIRES IOPT(1) = 1, AND IN THAT +C CASE ALL OF THESE INPUTS ARE EXAMINED. A VALUE OF ZERO FOR ANY +C OF THESE OPTIONAL INPUTS WILL CAUSE THE DEFAULT VALUE TO BE USED. +C THUS TO USE A SUBSET OF THE OPTIONAL INPUTS, SIMPLY PRELOAD +C LOCATIONS 5 TO 10 IN RWORK AND IWORK TO 0.0 AND 0 RESPECTIVELY, AND +C THEN SET THOSE OF INTEREST TO NONZERO VALUES. +C +C NAME LOCATION MEANING AND DEFAULT VALUE +C +C H0 RWORK(5) THE STEP SIZE TO BE ATTEMPTED ON THE FIRST STEP. +C THE DEFAULT VALUE IS DETERMINED BY THE KppSolveR. +C +C HMAX RWORK(6) THE MAXIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS INFINITE. +C +C HMIN RWORK(7) THE MINIMUM ABSOLUTE STEP SIZE ALLOWED. +C THE DEFAULT VALUE IS 0. (THIS LOWER BOUND IS NOT +C ENFORCED ON THE FINAL STEP BEFORE REACHING TCRIT +C WHEN ITASK = 4 OR 5.) +C +C MAXORD IWORK(5) THE MAXIMUM ORDER TO BE ALLOWED. THE DEFAULT +C VALUE IS 12 IF METH = 1, AND 5 IF METH = 2. +C IF MAXORD EXCEEDS THE DEFAULT VALUE, IT WILL +C BE REDUCED TO THE DEFAULT VALUE. +C IF MAXORD IS CHANGED DURING THE PROBLEM, IT MAY +C CAUSE THE CURRENT ORDER TO BE REDUCED. +C +C MXSTEP IWORK(6) MAXIMUM NUMBER OF (INTERNALLY DEFINED) STEPS +C ALLOWED DURING ONE CALL TO THE KppSolveR. +C THE DEFAULT VALUE IS 500. +C +C MXHNIL IWORK(7) MAXIMUM NUMBER OF MESSAGES PRINTED (PER PROBLEM) +C WARNING THAT T + H = T ON A STEP (H = STEP SIZE). +C THIS MUST BE POSITIVE TO RESULT IN A NON-DEFAULT +C VALUE. THE DEFAULT VALUE IS 10. +C---------------------------------------------------------------------- +C OPTIONAL OUTPUTS. +C +C AS OPTIONAL ADDITIONAL OUTPUT FROM ODESSA, THE VARIABLES LISTED +C BELOW ARE QUANTITIES RELATED TO THE PERFORMANCE OF ODESSA +C WHICH ARE AVAILABLE TO THE USER. THESE ARE COMMUNICATED BY WAY OF +C THE WORK ARRAYS, BUT ALSO HAVE INTERNAL MNEMONIC NAMES AS SHOWN. +C EXCEPT WHERE STATED OTHERWISE, ALL OF THESE OUTPUTS ARE DEFINED +C ON ANY SUCCESSFUL RETURN FROM ODESSA, AND ON ANY RETURN WITH +C ISTATE = -1, -2, -4, -5, OR -6. ON AN ILLEGAL INPUT RETURN +C (ISTATE = -3), THEY WILL BE UNCHANGED FROM THEIR EXISTING VALUES +C (IF ANY), EXCEPT POSSIBLY FOR TOLSF, LENRW, AND LENIW. +C ON ANY ERROR RETURN, OUTPUTS RELEVANT TO THE ERROR WILL BE DEFINED, +C AS NOTED BELOW. +C +C NAME LOCATION MEANING +C +C HU RWORK(11) THE STEP SIZE IN T LAST USED (SUCCESSFULLY). +C +C HCUR RWORK(12) THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C +C TCUR RWORK(13) THE CURRENT VALUE OF THE INDEPENDENT VARIABLE +C WHICH THE KppSolveR HAS ACTUALLY REACHED, I.E. THE +C CURRENT INTERNAL MESH POINT IN T. ON OUTPUT, TCUR +C WILL ALWAYS BE AT LEAST AS FAR AS THE ARGUMENT +C T, BUT MAY BE FARTHER (IF INTERPOLATION WAS DONE). +C +C TOLSF RWORK(14) A TOLERANCE SCALE FACTOR, GREATER THAN 1.0, +C COMPUTED WHEN A REQUEST FOR TOO MUCH ACCURACY WAS +C DETECTED (ISTATE = -3 IF DETECTED AT THE START OF +C THE PROBLEM, ISTATE = -2 OTHERWISE). IF ITOL IS +C LEFT UNALTERED BUT RTOL AND ATOL ARE UNIFORMLY +C SCALED UP BY A FACTOR OF TOLSF FOR THE NEXT CALL, +C THEN THE KppSolveR IS DEEMED LIKELY TO SUCCEED. +C (THE USER MAY ALSO IGNORE TOLSF AND ALTER THE +C TOLERANCE PARAMETERS IN ANY OTHER WAY APPROPRIATE.) +C +C NST IWORK(11) THE NUMBER OF STEPS TAKEN FOR THE PROBLEM SO FAR. +C +C NFE IWORK(12) THE NUMBER OF F EVALUATIONS FOR THE PROBLEM SO FAR. +C +C NJE IWORK(13) THE NUMBER OF JACOBIAN EVALUATIONS (AND OF MATRIX +C LU DECOMPOSITIONS IF ISOPT = 0) FOR THE PROBLEM SO +C FAR. IF ISOPT = 1, THE NUMBER OF LU DECOMPOSITIONS +C IS EQUAL TO NJE - NSPE (SEE BELOW). +C +C NQU IWORK(14) THE METHOD ORDER LAST USED (SUCCESSFULLY). +C +C NQCUR IWORK(15) THE ORDER TO BE ATTEMPTED ON THE NEXT STEP. +C +C IMXER IWORK(16) THE INDEX OF THE COMPONENT OF LARGEST MAGNITUDE IN +C THE WEIGHTED LOCAL ERROR VECTOR (E(I,J)/EWT(I,J)), +C ON AN ERROR RETURN WITH ISTATE = -4 OR -5. +C +C LENRW IWORK(17) THE LENGTH OF RWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C LENIW IWORK(18) THE LENGTH OF IWORK ACTUALLY REQUIRED. +C THIS IS DEFINED ON NORMAL RETURNS AND ON AN ILLEGAL +C INPUT RETURN FOR INSUFFICIENT STORAGE. +C +C NDFE IWORK(19) THE NUMBER OF DF/DP (VECTOR) EVALUATIONS. +C +C NSPE IWORK(20) THE NUMBER OF CALLS TO SUBROUTINE SPRIME. EACH CALL +C TO SPRIME REQUIRES A JACOBIAN EVALUATION, BUT NOT +C AN LU DECOMPOSITION. +C +C THE FOLLOWING ARRAYS ARE SEGMENTS OF THE RWORK AND IWORK ARRAYS +C WHICH MAY ALSO BE OF INTEREST TO THE USER AS OPTIONAL OUTPUTS. +C FOR EACH ARRAY, THE TABLE BELOW GIVES ITS INTERNAL NAME, ITS BASE +C ADDRESS IN RWORK OR IWORK, AND ITS DESCRIPTION. +C +C NAME BASE ADDRESS DESCRIPTION +C +C YH 21 IN RWORK THE NORDSIECK HISTORY ARRAY, OF SIZE NYH BY +C (NQCUR + 1). FOR J = 0,1,...,NQCUR, COLUMN J+1 +C OF YH CONTAINS HCUR**J/FACTORIAL(J) TIMES +C THE J-TH DERIVATIVE OF THE INTERPOLATING +C POLYNOMIAL CURRENTLY REPRESENTING THE SOLUTION, +C EVALUATED AT T = TCUR. +C +C ACOR LENRW-NYH+1 ARRAY OF SIZE NYH USED FOR THE ACCUMULATED +C IN RWORK CORRECTIONS ON EACH STEP, SCALED ON OUTPUT +C TO REPRESENT THE ESTIMATED LOCAL ERROR IN Y +C ON THE LAST STEP. THIS IS THE VECTOR E IN +C THE DESCRIPTION OF THE ERROR CONTROL. +C IT IS DEFINED ONLY ON A SUCCESSFUL RETURN +C FROM ODESSA. +C NRS LENIW-NPAR ARRAY OF SIZE NPAR+1, USED TO STORE THE +C IN IWORK ACCUMULATED NUMBER OF REPEATED STEPS DUE TO +C THE SENSITIVITY ANALYSIS.. +C NRS(1) = TOTAL NUMBER OF REPEATED STEPS, +C NRS(2),... = NUMBER OF REPEATED STEPS DUE TO +C MODEL PARAMETER 1,... +C +C---------------------------------------------------------------------- +C PART II. OTHER ROUTINES CALLABLE. +C +C THE FOLLOWING ARE OPTIONAL CALLS WHICH THE USER MAY MAKE TO +C GAIN ADDITIONAL CAPABILITIES IN CONJUNCTION WITH ODESSA. +C (THE ROUTINES XSETUN AND XSETF ARE DESIGNED TO CONFORM TO THE +C SLATEC ERROR HANDLING PACKAGE.) +C +C FORM OF CALL FUNCTION +C CALL XSETUN(LUN) SET THE LOGICAL UNIT NUMBER, LUN, FOR +C OUTPUT OF MESSAGES FROM ODESSA, IF +C THE DEFAULT IS NOT DESIRED. +C THE DEFAULT VALUE OF LUN IS 6. +C +C CALL XSETF(MFLAG) SET A FLAG TO CONTROL THE PRINTING OF +C MESSAGES BY ODESSA.. +C MFLAG = 0 MEANS DO NOT PRINT. (DANGER.. +C THIS RISKS LOSING VALUABLE INFORMATION.) +C MFLAG = 1 MEANS PRINT (THE DEFAULT). +C +C EITHER OF THE ABOVE CALLS MAY BE MADE AT +C ANY TIME AND WILL TAKE EFFECT IMMEDIATELY. +C +C CALL SVCOM (RSAV, ISAV) STORE IN RSAV AND ISAV THE CONTENTS +C OF THE INTERNAL COMMON BLOCKS USED BY +C ODESSA (SEE PART III BELOW). +C RSAV MUST BE A REAL ARRAY OF LENGTH 222 +C OR MORE, AND ISAV MUST BE AN INTEGER +C ARRAY OF LENGTH 54 OR MORE. +C +C CALL RSCOM (RSAV, ISAV) RESTORE, FROM RSAV AND ISAV, THE CONTENTS +C OF THE INTERNAL COMMON BLOCKS USED BY +C ODESSA. PRESUMES A PRIOR CALL TO SVCOM +C WITH THE SAME ARGUMENTS. +C +C SVCOM AND RSCOM ARE USEFUL IF +C INTERRUPTING A RUN AND RESTARTING +C LATER, OR ALTERNATING BETWEEN TWO OR +C MORE PROBLEMS KppSolveD WITH ODESSA. +C +C CALL INTDY(,,,,,) PROVIDE DERIVATIVES OF Y, OF VARIOUS +C (SEE BELOW) ORDERS, AT A SPECIFIED POINT T, IF +C DESIRED. IT MAY BE CALLED ONLY AFTER +C A SUCCESSFUL RETURN FROM ODESSA. +C +C THE DETAILED INSTRUCTIONS FOR USING INTDY ARE AS FOLLOWS. +C THE FORM OF THE CALL IS.. +C +C CALL INTDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C THE INPUT PARAMETERS ARE.. +C +C T = VALUE OF INDEPENDENT VARIABLE WHERE ANSWERS ARE DESIRED +C (NORMALLY THE SAME AS THE T LAST RETURNED BY ODESSA). +C FOR VALID RESULTS, T MUST LIE BETWEEN TCUR - HU AND TCUR. +C (SEE OPTIONAL OUTPUTS FOR TCUR AND HU.) +C K = INTEGER ORDER OF THE DERIVATIVE DESIRED. K MUST SATISFY +C 0 .LE. K .LE. NQCUR, WHERE NQCUR IS THE CURRENT ORDER +C (SEE OPTIONAL OUTPUTS). THE CAPABILITY CORRESPONDING +C TO K = 0, I.E. COMPUTING Y(T), IS ALREADY PROVIDED +C BY ODESSA DIRECTLY. SINCE NQCUR .GE. 1, THE FIRST +C DERIVATIVE DY/DT IS ALWAYS AVAILABLE WITH INTDY. +C RWORK(21) = THE BASE ADDRESS OF THE HISTORY ARRAY YH. +C NYH = COLUMN LENGTH OF YH, EQUAL TO THE TOTAL NUMBER OF +C DEPENDENT VARIABLES. IF ISOPT = 0, NYH = N. IF ISOPT = 1, +C NYH = N * (NPAR + 1). +C +C THE OUTPUT PARAMETERS ARE.. +C +C DKY = A REAL ARRAY OF LENGTH NYH CONTAINING THE COMPUTED VALUE +C OF THE K-TH DERIVATIVE OF Y(T). +C IFLAG = INTEGER FLAG, RETURNED AS 0 IF K AND T WERE LEGAL, +C -1 IF K WAS ILLEGAL, AND -2 IF T WAS ILLEGAL. +C ON AN ERROR RETURN, A MESSAGE IS ALSO WRITTEN. +C---------------------------------------------------------------------- +C PART III. COMMON BLOCKS. +C +C IF ODESSA IS TO BE USED IN AN OVERLAY SITUATION, THE USER +C MUST DECLARE, IN THE PRIMARY OVERLAY, THE VARIABLES IN.. +C (1) THE CALL SEQUENCE TO ODESSA, +C (2) THE THREE INTERNAL COMMON BLOCKS +C /ODE001/ OF LENGTH 258 (219 DOUBLE PRECISION WORDS +C FOLLOWED BY 39 INTEGER WORDS), +C /ODE002/ OF LENGTH 14 (3 DOUBLE PRECISION WORDS FOLLOWED +C BY 11 INTEGER WORDS), +C /EH0001/ OF LENGTH 2 (INTEGER WORDS). +C +C IF ODESSA IS USED ON A SYSTEM IN WHICH THE CONTENTS OF INTERNAL +C COMMON BLOCKS ARE NOT PRESERVED BETWEEN CALLS, THE USER SHOULD +C DECLARE THE ABOVE THREE COMMON BLOCKS IN HIS MAIN PROGRAM TO INSURE +C THAT THEIR CONTENTS ARE PRESERVED. +C +C IF THE SOLUTION OF A GIVEN PROBLEM BY ODESSA IS TO BE INTERRUPTED +C AND THEN LATER CONTINUED, SUCH AS WHEN RESTARTING AN INTERRUPTED RUN +C OR ALTERNATING BETWEEN TWO OR MORE PROBLEMS, THE USER SHOULD SAVE, +C FOLLOWING THE RETURN FROM THE LAST ODESSA CALL PRIOR TO THE +C INTERRUPTION, THE CONTENTS OF THE CALL SEQUENCE VARIABLES AND THE +C INTERNAL COMMON BLOCKS, AND LATER RESTORE THESE VALUES BEFORE THE +C NEXT ODESSA CALL FOR THAT PROBLEM. TO SAVE AND RESTORE THE COMMON +C BLOCKS, USE SUBROUTINES SVCOM AND RSCOM (SEE PART II ABOVE). +C +C---------------------------------------------------------------------- +C PART IV. OPTIONALLY REPLACEABLE KppSolveR ROUTINES. +C +C BELOW ARE DESCRIPTIONS OF TWO ROUTINES IN THE ODESSA PACKAGE WHICH +C RELATE TO THE MEASUREMENT OF ERRORS. EITHER ROUTINE CAN BE +C REPLACED BY A USER-SUPPLIED VERSION, IF DESIRED. HOWEVER, SINCE SUCH +C A REPLACEMENT MAY HAVE A MAJOR IMPACT ON PERFORMANCE, IT SHOULD BE +C DONE ONLY WHEN ABSOLUTELY NECESSARY, AND ONLY WITH GREAT CAUTION. +C (NOTE.. THE MEANS BY WHICH THE PACKAGE VERSION OF A ROUTINE IS +C SUPERSEDED BY THE USER-S VERSION MAY BE SYSTEM-DEPENDENT.) +C +C (A) EWSET. +C THE FOLLOWING SUBROUTINE IS CALLED JUST BEFORE EACH INTERNAL +C INTEGRATION STEP, AND SETS THE ARRAY OF ERROR WEIGHTS, EWT, AS +C DESCRIBED UNDER ITOL/RTOL/ATOL ABOVE.. +C SUBROUTINE EWSET (NYH, ITOL, RTOL, ATOL, YCUR, EWT) +C WHERE NEQ, ITOL, RTOL, AND ATOL ARE AS IN THE ODESSA CALL SEQUENCE, +C YCUR CONTAINS THE CURRENT DEPENDENT VARIABLE VECTOR, AND +C EWT IS THE ARRAY OF WEIGHTS SET BY EWSET. +C +C IF THE USER SUPPLIES THIS SUBROUTINE, IT MUST RETURN IN EWT(I) +C (I = 1,...,NYH) A POSITIVE QUANTITY SUITABLE FOR COMPARING ERRORS +C IN Y(I) TO. THE EWT ARRAY RETURNED BY EWSET IS PASSED TO THE +C VNORM ROUTINE (SEE BELOW), AND ALSO USED BY ODESSA IN THE COMPUTATION +C OF THE OPTIONAL OUTPUT IMXER, THE DIAGONAL JACOBIAN APPROXIMATION, +C AND THE INCREMENTS FOR DIFFERENCE QUOTIENT JACOBIANS. +C +C IN THE USER-SUPPLIED VERSION OF EWSET, IT MAY BE DESIRABLE TO USE +C THE CURRENT VALUES OF DERIVATIVES OF Y. DERIVATIVES UP TO ORDER NQ +C ARE AVAILABLE FROM THE HISTORY ARRAY YH, DESCRIBED ABOVE UNDER +C OPTIONAL OUTPUTS. IN EWSET, YH IS IDENTICAL TO THE YCUR ARRAY, +C EXTENDED TO NQ + 1 COLUMNS WITH A COLUMN LENGTH OF NYH AND SCALE +C FACTORS OF H**J/FACTORIAL(J). ON THE FIRST CALL FOR THE PROBLEM, +C GIVEN BY NST = 0, NQ IS 1 AND H IS TEMPORARILY SET TO 1.0. +C THE QUANTITIES NQ, NYH, H, AND NST CAN BE OBTAINED BY INCLUDING +C IN EWSET THE STATEMENTS.. +C DOUBLE PRECISION H, RLS +C COMMON /ODE001/ RLS(219),ILS(39) +C NQ = ILS(35) +C NYH = ILS(14) +C NST = ILS(36) +C H = RLS(213) +C THUS, FOR EXAMPLE, THE CURRENT VALUE OF DY/DT CAN BE OBTAINED AS +C YCUR(NYH+I)/H (I=1,...,N) (AND THE DIVISION BY H IS +C UNNECESSARY WHEN NST = 0). +C +C (B) VNORM. +C THE FOLLOWING IS A REAL FUNCTION ROUTINE WHICH COMPUTES THE WEIGHTED +C ROOT-MEAN-SQUARE NORM OF A VECTOR V.. +C D = VNORM (LV, V, W) +C WHERE.. +C LV = THE LENGTH OF THE VECTOR, +C V = REAL ARRAY OF LENGTH N CONTAINING THE VECTOR, +C W = REAL ARRAY OF LENGTH N CONTAINING WEIGHTS, +C D = SQRT( (1/N) * SUM(V(I)*W(I))**2 ). +C VNORM IS CALLED WITH LV = N AND WITH W(I) = 1.0/EWT(I), WHERE +C EWT IS AS SET BY SUBROUTINE EWSET. +C +C IF THE USER SUPPLIES THIS FUNCTION, IT SHOULD RETURN A NON-NEGATIVE +C VALUE OF VNORM SUITABLE FOR USE IN THE ERROR CONTROL IN ODESSA. +C NONE OF THE ARGUMENTS SHOULD BE ALTERED BY VNORM. +C FOR EXAMPLE, A USER-SUPPLIED VNORM ROUTINE MIGHT.. +C -SUBSTITUTE A MAX-NORM OF (V(I)*W(I)) FOR THE RMS-NORM, OR +C -IGNORE SOME COMPONENTS OF V IN THE NORM, WITH THE EFFECT OF +C SUPPRESSING THE ERROR CONTROL ON THOSE COMPONENTS OF Y. +C---------------------------------------------------------------------- +C OTHER ROUTINES IN THE ODESSA PACKAGE. +C +C IN ADDITION TO SUBROUTINE ODESSA, THE ODESSA PACKAGE INCLUDES THE +C FOLLOWING SUBROUTINES AND FUNCTION ROUTINES.. +C INTDY COMPUTES AN INTERPOLATED VALUE OF THE Y VECTOR AT T = TOUT. +C STODE IS THE CORE INTEGRATOR, WHICH DOES ONE STEP OF THE +C INTEGRATION AND THE ASSOCIATED ERROR CONTROL. +C STESA MANAGES THE SOLUTION OF THE SENSITIVITY FUNCTIONS. +C CFODE SETS ALL METHOD COEFFICIENTS AND TEST CONSTANTS. +C PREPJ COMPUTES AND PREPROCESSES THE JACOBIAN MATRIX J = DF/DY +C AND THE NEWTON ITERATION MATRIX P = I - H*L0*J. +C IT IS ALSO CALLED BY SPRIME (WITH JOPT = 1) TO JUST +C COMPUTE THE JACOBIAN MATRIX. +C PREPDF COMPUTES THE INHOMOGENEITY MATRIX DF/DP. +C SPRIME DEFINES THE SYSTEM OF SENSITIVITY EQUATIONS. +C SOLSY MANAGES SOLUTION OF LINEAR SYSTEM IN CHORD ITERATION. +C EWSET SETS THE ERROR WEIGHT VECTOR EWT BEFORE EACH STEP. +C VNORM COMPUTES THE WEIGHTED R.M.S. NORM OF A VECTOR. +C SVCOM AND RSCOM ARE USER-CALLABLE ROUTINES TO SAVE AND RESTORE, +C RESPECTIVELY, THE CONTENTS OF THE INTERNAL COMMON BLOCKS. +C DGEFA AND DGESL ARE ROUTINES FROM LINPACK FOR SOLVING FULL +C SYSTEMS OF LINEAR ALGEBRAIC EQUATIONS. +C DGBFA AND DGBSL ARE ROUTINES FROM LINPACK FOR SOLVING BANDED +C LINEAR SYSTEMS. +C DAXPY, DSCAL, IDAMAX, AND DDOT ARE BASIC LINEAR ALGEBRA MODULES +C (BLAS) USED BY THE ABOVE LINPACK ROUTINES. +C D1MACH COMPUTES THE UNIT ROUNDOFF IN A MACHINE-INDEPENDENT MANNER. +C XERR, XSETUN, AND XSETF HANDLE THE PRINTING OF ALL ERROR +C MESSAGES AND WARNINGS. +C NOTE.. VNORM, IDAMAX, DDOT, AND D1MACH ARE FUNCTION ROUTINES. +C ALL THE OTHERS ARE SUBROUTINES. +C +C THE FORTRAN GENERIC INTRINSIC FUNCTIONS USED BY ODESSA ARE.. +C ABS, MAX, MIN, REAL, MOD, SIGN, SQRT, AND WRITE +C +C A BLOCK DATA SUBPROGRAM IS ALSO INCLUDED WITH THE PACKAGE, +C FOR LOADING SOME OF THE VARIABLES IN INTERNAL COMMON. +C +C---------------------------------------------------------------------- +C PART V. GENERAL REMARKS +C +C THIS SECTION HIGHLIGHTS THE BASIC DIFFERENCES BETWEEN THE ORIGINAL +C LSODE PACKAGE AND THE ODESSA MODIFICATION. THIS IS PROVIDED AS A +C SERVICE TO EXPERIENCED LSODE USERS TO EXPEDITE FAMILIARIZATION WITH +C ODESSA. +C +C (A). ORIGINAL SUBROUTINES AND FUNCTIONS. +C +C OF THE ORIGINAL 22 SUBROUTINES AND FUNCTIONS USED IN THE LSODE +C PACKAGE, ALL ARE USED BY ODESSA, WITH THE FOLLOWING HAVING BEEN +C MODIFIED.. +C +C LSODE THE ORIGINAL DRIVER SUBROUTINE FOR THE LSODE PACKAGE IS +C EXTENSIVELY MODIFIED AND RENAMED ODESSA, WHICH NOW +C CONTAINS A CALL TO SPRIME TO ESTABLISH INITIAL CONDITIONS +C FOR THE SENSITIVITY CALCULATIONS. +C +C STODE THE ONE STEP INTEGRATOR IS SLIGHTLY MODIFIED AND RETAINS +C ITS ORIGINAL NAME. IT NOW CONTAINS THE CALL TO STESA, +C AND ALSO CALLS SPRIME IF KFLAG .LE. -3. +C +C PREPJ ALSO NAMED PREPJ IN ODESSA IS SLIGHTLY MODIFIED TO ALLOW +C FOR THE CALCULATION OF JACOBIAN WITH NO PREPROCESSING +C (JOPT = 1). +C +C (B). NEW SUBROUTINES. +C +C IN ADDITION TO THE CHANGES NOTED ABOVE, THREE NEW SUBROUTINES +C HAVE BEEN INTRODUCED (SEE STESA, SPRIME, AND PREPDF AS DESCRIBED +C IN PART IV. ABOVE). +C +C (C). COMMON BLOCKS. +C +C /LS0001/ RETAINS THE SAME LENGTH AND IS RENAMED /ODE001/; +C HOWEVER THE REAL ARRAY ROWNS(209) IS SHORTENED TO A +C LENGTH OF (173) REAL WORDS, ALLOWING THE REMOVAL OF +C TESCO(3,12) WHICH IS NOW PASSED FROM STODE TO STESA. +C IN ADDITION, THE INTEGER ARRAY IOWNS(6) IS SHORTENED +C TO A LENGTH OF (4) INTEGER WORDS, ALLOWING THE REMOVAL +C OF IALTH AND LMAX WHICH ARE NOW PASSED FROM STODE TO +C STESA. +C +C /ODE002/ ADDED COMMON BLOCK FOR VARIABLES IMPORTANT TO +C SENSITIVITY ANALYSIS (SEE PART III. ABOVE). A BLOCK +C DATA PROGRAM IS NOT REQUIRED FOR THIS COMMON BLOCK. +C +C SVCOM,RSCOM THESE TWO SUBROUTINES ARE MODIFIED TO HANDLE +C COMMON BLOCK /ODE002/ AS WELL. +C +C (D). OPTIONAL INPUTS. +C +C THE FULL SET OF OPTIONAL INPUTS AVAILABLE IN LSODE IS ALSO +C AVAILABLE IN ODESSA, WITH THE EXCEPTION THAT THE NUMBER OF ODE'S +C IN THE MODEL (NEQ(1)), MAY NOT BE CHANGED DURING THE PROBLEM. +C IN ODESSA, NYH NOW REFERS TO THE TOTAL NUMBER OF FIRST-ORDER +C ODE'S (MODEL AND SENSITIVITY EQUATIONS) WHICH IS EQUAL TO +C NEQ(1) IF ISOPT = 0, OR NEQ(1)*(NEQ(2)+1) IF ISOPT = 1. +C NEQ(1), NEQ(2), AND NYH ARE NOT ALLOWED TO CHANGE DURING +C THE COURSE OF AN INTEGRATION. +C +C (E). OPTIONAL OUTPUTS. +C +C THE FULL SET OF OPTIONAL OUTPUTS AVAILABLE IN LSODE IS ALSO +C AVAILABLE IN ODESSA. IN ADDITION, IWORK(19) AND IWORK(20) ARE +C LOADED WITH NDFE AND NSPE, RESPECTIVELY, UPON OUTPUT. THE TOTAL +C NUMBER OF LU DECOMPOSITIONS OF THE PROCESSED JACOBIAN IS EQUAL +C TO NJE - NSPE. +C----------------------------------------------------------------------- + SUBROUTINE KPP_ODESSA (F, DF, NEQ, Y, PAR, T, TOUT, + 1 ITOL, RTOL, ATOL, + 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL IHIT + EXTERNAL F, DF, JAC, PREPJ, SOLSY, PREPDF + DIMENSION NEQ(*), Y(*), PAR(*), RTOL(*), ATOL(*), IOPT(*), + 1 RWORK(LRW), IWORK(LIW), MORD(2) +C----------------------------------------------------------------------- +C THIS IS THE SEPTEMBER 1, 1986 VERSION OF ODESSA.. +C AN ORDINARY DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS. +C +C THIS PACKAGE IS A MODIFICATION OF THE AUGUST 13, 1981 VERSION OF +C LSODE.. LIVERMORE KppSolveR FOR ORDINARY DIFFERENTIAL EQUATIONS. +C THIS VERSION IS IN DOUBLE PRECISION. +C +C ODESSA KppSolveS FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS.. +C DY(I)/DP, FOR A SINGLE PARAMETER, OR, +C DY(I)/DP(J), FOR MULTIPLE PARAMETERS, +C ASSOCIATED WITH A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.. +C DY(T)/DT = F(Y,T;P). +C----------------------------------------------------------------------- +C REFERENCES... +C +C 1. JORGE R. LEIS AND MARK A. KRAMER, THE SIMULTANEOUS SOLUTION AND +C EXPLICIT SENSITIVITY ANALYSIS OF SYSTEMS DESCRIBED BY ORDINARY +C DIFFERENTIAL EQUATIONS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE, +C (1985). +C +C 2. JORGE R. LEIS AND MARK A. KRAMER, ODESSA - AN ORDINARY +C DIFFERENTIAL EQUATION KppSolveR WITH EXPLICIT SIMULTANEOUS +C SENSITIVITY ANALYSIS, SUBMITTED TO ACM TRANS. MATH. SOFTWARE. +C (1985). +C +C 3. ALAN C. HINDMARSH, LSODE AND LSODI, TWO NEW INITIAL VALUE +C ORDINARY DIFFERENTIAL EQUATION KppSolveRS, ACM-SIGNUM NEWSLETTER, +C VOL. 15, NO. 4 (1980), PP. 10-11. +C----------------------------------------------------------------------- +C THE FOLLOWING INTERNAL COMMON BLOCKS CONTAIN +C (A) VARIABLES WHICH ARE LOCAL TO ANY SUBROUTINE BUT WHOSE VALUES MUST +C BE PRESERVED BETWEEN CALLS TO THE ROUTINE (OWN VARIABLES), AND +C (B) VARIABLES WHICH ARE COMMUNICATED BETWEEN SUBROUTINES. +C THE STRUCTURE OF THE BLOCKS ARE AS FOLLOWS.. ALL REAL VARIABLES ARE +C LISTED FIRST, FOLLOWED BY ALL INTEGERS. WITHIN EACH TYPE, THE +C VARIABLES ARE GROUPED WITH THOSE LOCAL TO SUBROUTINE ODESSA FIRST, +C THEN THOSE LOCAL TO SUBROUTINE STODE, AND FINALLY THOSE USED +C FOR COMMUNICATION. THE BLOCKS ARE DECLARED IN SUBROUTINES ODESSA +C INTDY, STODE, STESA, PREPJ, PREPDF, AND SOLSY. GROUPS OF VARIABLES +C ARE REPLACED BY DUMMY ARRAYS IN THE COMMON DECLARATIONS IN ROUTINES +C WHERE THOSE VARIABLES ARE NOT USED. +C----------------------------------------------------------------------- + COMMON /ODE001/ TRET, ROWNS(173), + 1 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 2 ILLIN, INIT, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 3 MXSTEP, MXHNIL, NHNIL, NTREP, NSLAST, NYH, IOWNS(4), + 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, + 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 NPAR, LDFDP, LNRS, + 2 ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS + PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,FOUR=4.0D0) + DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ +C----------------------------------------------------------------------- +C BLOCK A. +C THIS CODE BLOCK IS EXECUTED ON EVERY CALL. +C IT TESTS ISTATE AND ITASK FOR LEGALITY AND BRANCHES APPROPIATELY. +C IF ISTATE .GT. 1 BUT THE FLAG INIT SHOWS THAT INITIALIZATION HAS +C NOT YET BEEN DONE, AN ERROR RETURN OCCURS. +C IF ISTATE = 1 AND TOUT = T, JUMP TO BLOCK G AND RETURN IMMEDIATELY. +C----------------------------------------------------------------------- + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .EQ. 0) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) GO TO 430 + 20 NTREP = 0 +C----------------------------------------------------------------------- +C BLOCK B. +C THE NEXT CODE BLOCK IS EXECUTED FOR THE INITIAL CALL (ISTATE = 1), +C OR FOR A CONTINUATION CALL WITH PARAMETER CHANGES (ISTATE = 3). +C IT CONTAINS CHECKING OF ALL INPUTS AND VARIOUS INITIALIZATIONS. +C +C FIRST CHECK LEGALITY OF THE NON-OPTIONAL INPUTS NEQ, ITOL, IOPT, +C MF, ML, AND MU. +C----------------------------------------------------------------------- + IF (NEQ(1) .LE. 0) GO TO 604 + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ(1) .NE. N) GO TO 605 + 25 N = NEQ(1) + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + DO 26 I = 1,3 + 26 IF (IOPT(I) .LT. 0 .OR. IOPT(I) .GT. 1) GO TO 607 + ISOPT = IOPT(2) + IDF = IOPT(3) + NYH = N + NSV = 1 + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 IF (ISOPT .EQ. 0) GO TO 32 +C CHECK LEGALITY OF THE NON-OPTIONAL INPUTS ISOPT, NPAR. +C COMPUTE NUMBER OF SOLUTION VECTORS AND TOTAL NUMBER OF EQUATIONS. + IF (NEQ(2) .LE. 0) GO TO 628 + IF (ISTATE .EQ. 1) GO TO 31 + IF (NEQ(2) .NE. NPAR) GO TO 629 + 31 NPAR = NEQ(2) + NSV = NPAR + 1 + NYH = NSV * N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 630 +C NEXT PROCESS AND CHECK THE OPTIONAL INPUTS. -------------------------- + 32 IF (IOPT(1) .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = ZERO + HMXI = ZERO + HMIN = ZERO + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. ZERO) GO TO 615 + HMXI = ZERO + IF (HMAX .GT. ZERO) HMXI = ONE/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. ZERO) GO TO 616 +C----------------------------------------------------------------------- +C SET WORK ARRAY POINTERS AND CHECK LENGTHS LRW AND LIW. +C POINTERS TO SEGMENTS OF RWORK AND IWORK ARE NAMED BY PREFIXING L TO +C THE NAME OF THE SEGMENT. E.G., THE SEGMENT YH STARTS AT RWORK(LYH). +C SEGMENTS OF RWORK (IN ORDER) ARE DENOTED YH, WM, EWT, SAVF, ACOR. +C WORK SPACE FOR DFDP IS CONTAINED IN ACOR. +C----------------------------------------------------------------------- + 60 LYH = 21 + LWM = LYH + (MAXORD + 1)*NYH + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 + IF (MITER .EQ. 3) LENWM = N + 2 + IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 + LEWT = LWM + LENWM + LSAVF = LEWT + NYH + LACOR = LSAVF + N + LDFDP = LACOR + N + LENRW = LACOR + NYH - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 20 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 + LNRS = LENIW + LIWM + IF (ISOPT .EQ. 1) LENIW = LNRS + NPAR + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C CHECK RTOL AND ATOL FOR LEGALITY. ------------------------------------ + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 70 I = 1,NYH + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + IF (RTOLI .LT. ZERO) GO TO 619 + IF (ATOLI .LT. ZERO) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 +C IF ISTATE = 3, SET FLAG TO SIGNAL PARAMETER CHANGES TO STODE. -------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD WAS REDUCED BELOW NQ. COPY YH(*,MAXORD+2) INTO SAVF. --------- + DO 80 I = 1,N + 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) +C RELOAD WM(1) = RWORK(LWM), SINCE LWM MAY HAVE CHANGED. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + GO TO 200 +C----------------------------------------------------------------------- +C BLOCK C. +C THE NEXT BLOCK IS FOR THE INITIAL CALL ONLY (ISTATE = 1). +C IT CONTAINS ALL REMAINING INITIALIZATIONS, THE INITIAL CALL TO F, +C THE INITIAL CALL TO SPRIME IF ISOPT = 1, +C AND THE CALCULATION OF THE INITIAL STEP SIZE. +C THE ERROR WEIGHTS IN EWT ARE INVERTED AFTER BEING LOADED. +C----------------------------------------------------------------------- + 100 UROUND = D1MACH(4) + TN = T + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 + IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) + 1 H0 = TCRIT - T + 105 JSTART = 0 + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + NHNIL = 0 + NST = 0 + NJE = 0 + NSLAST = 0 + HU = ZERO + NQU = 0 + CCMAX = 0.3D0 + MAXCOR = 3 + IF (ISOPT .EQ. 1) MAXCOR = 4 + MSBP = 20 + MXNCF = 10 +C INITIAL CALL TO F. (LF0 POINTS TO YH(1,2) AND LOADS IN VALUES). + LF0 = LYH + NYH + CALL F (NEQ, T, Y, PAR, RWORK(LF0)) + NFE = 1 + DUPS = ZERO + DSMS = ZERO + DDNS = ZERO + NDFE = 0 + NSPE = 0 + IF (ISOPT .EQ. 0) GO TO 114 +C INITIALIZE COUNTS FOR REPEATED STEPS DUE TO SENSITIVITY ANALYSIS. + DO 110 J = 1,NSV + 110 IWORK(J + LNRS - 1) = 0 +C LOAD THE INITIAL VALUE VECTOR IN YH. --------------------------------- + 114 DO 115 I = 1,NYH + 115 RWORK(I+LYH-1) = Y(I) +C LOAD AND INVERT THE EWT ARRAY. (H IS TEMPORARILY SET TO ONE.) ------- + NQ = 1 + H = ONE + CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,NYH + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 + 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + IF (ISOPT .EQ. 0) GO TO 125 +C CALL SPRIME TO LOAD FIRST-ORDER SENSITIVITY DERIVATIVES INTO +C REMAINING YH(*,2) POSITIONS. + CALL SPRIME (NEQ, Y, RWORK(LYH), NYH, N, NSV, RWORK(LWM), + 1 IWORK(LIWM), RWORK(LEWT), RWORK(LF0), RWORK(LACOR), + 2 RWORK(LDFDP), PAR, F, JAC, DF, PREPJ, PREPDF) + IF (IERSP .EQ. -1) GO TO 631 + IF (IERSP .EQ. -2) GO TO 632 +C----------------------------------------------------------------------- +C THE CODING BELOW COMPUTES THE STEP SIZE, H0, TO BE ATTEMPTED ON THE +C FIRST STEP, UNLESS THE USER HAS SUPPLIED A VALUE FOR THIS. +C FIRST CHECK THAT TOUT - T DIFFERS SIGNIFICANTLY FROM ZERO. +C A SCALAR TOLERANCE QUANTITY TOL IS COMPUTED, AS MAX(RTOL(I)) +C IF THIS IS POSITIVE, OR MAX(ATOL(I)/ABS(Y(I))) OTHERWISE, ADJUSTED +C SO AS TO BE BETWEEN 100*UROUND AND 1.0E-3. ONLY THE ORIGINAL +C SOLUTION VECTOR IS CONSIDERED IN THIS CALCULATION (ISOPT = 0 OR 1). +C THEN THE COMPUTED VALUE H0 IS GIVEN BY.. +C NEQ +C H0**2 = TOL / ( W0**-2 + (1/NEQ) * SUM ( F(I)/YWT(I) )**2 ) +C 1 +C WHERE W0 = MAX ( ABS(T), ABS(TOUT) ), +C F(I) = I-TH COMPONENT OF INITIAL VALUE OF F, +C YWT(I) = EWT(I)/TOL (A WEIGHT FOR Y(I)). +C THE SIGN OF H0 IS INFERRED FROM THE INITIAL VALUES OF TOUT AND T. +C----------------------------------------------------------------------- + 125 IF (H0 .NE. ZERO) GO TO 180 + TDIST = ABS(TOUT - T) + W0 = MAX(ABS(T),ABS(TOUT)) + IF (TDIST .LT. TWO*UROUND*W0) GO TO 622 + TOL = RTOL(1) + IF (ITOL .LE. 2) GO TO 140 + DO 130 I = 1,N + 130 TOL = MAX(TOL,RTOL(I)) + 140 IF (TOL .GT. ZERO) GO TO 160 + ATOLI = ATOL(1) + DO 150 I = 1,N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + AYI = ABS(Y(I)) + IF (AYI .NE. ZERO) TOL = MAX(TOL,ATOLI/AYI) + 150 CONTINUE + 160 TOL = MAX(TOL,100.0D0*UROUND) + TOL = MIN(TOL,0.001D0) + SUM = VNORM (N, RWORK(LF0), RWORK(LEWT)) + SUM = ONE/(TOL*W0*W0) + TOL*SUM**2 + H0 = ONE/SQRT(SUM) + H0 = MIN(H0,TDIST) + H0 = SIGN(H0,TOUT-T) +C ADJUST H0 IF NECESSARY TO MEET HMAX BOUND. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. ONE) H0 = H0/RH +C LOAD H WITH H0 AND SCALE YH(*,2) BY H0. ------------------------------ + H = H0 + DO 190 I = 1,NYH + 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) + GO TO 270 +C----------------------------------------------------------------------- +C BLOCK D. +C THE NEXT CODE BLOCK IS FOR CONTINUATION CALLS ONLY (ISTATE = 2 OR 3) +C AND IS TO CHECK STOP CONDITIONS BEFORE TAKING A STEP. +C----------------------------------------------------------------------- + 200 NSLAST = NST + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(ONE + 100.0D0*UROUND) + IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 + IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + IF (ISTATE .EQ. 2) JSTART = -2 +C----------------------------------------------------------------------- +C BLOCK E. +C THE NEXT BLOCK IS NORMALLY EXECUTED FOR ALL CALLS AND CONTAINS +C THE CALL TO THE ONE-STEP CORE INTEGRATOR STODE. +C +C THIS IS A LOOPING POINT FOR THE INTEGRATION STEPS. +C +C FIRST CHECK FOR TOO MANY STEPS BEING TAKEN, UPDATE EWT (IF NOT AT +C START OF PROBLEM), CHECK FOR TOO MUCH ACCURACY BEING REQUESTED, AND +C CHECK FOR H BELOW THE ROUNDOFF LEVEL IN T. +C TOLSF IS CALCULATED CONSIDERING ALL SOLUTION VECTORS. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL EWSET (NYH, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,NYH + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 + 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*VNORM (NYH, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. ONE) GO TO 280 + TOLSF = TOLSF*2.0D0 + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF (ADDX(TN,H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + CALL XERR ('ODESSA - WARNING..INTERNAL T (=R1) AND H (=R2) ARE', + 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('SUCH THAT IN THE MACHINE, T + H = T ON THE NEXT STEP', + 1 101, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('(H = STEP SIZE). KppSolveR WILL CONTINUE ANYWAY', + 1 101, 1, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + CALL XERR ('ODESSA - ABOVE WARNING HAS BEEN ISSUED I1 TIMES.', + 1 102, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('IT WILL NOT BE ISSUED AGAIN FOR THIS PROBLEM', + 1 102, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL STODE(NEQ,Y,YH,NYH,YH,WM,IWM,EWT,SAVF,ACOR,PAR,NRS, +C 1 F,JAC,DF,PREPJ,PREPDF,SOLSY) +C----------------------------------------------------------------------- + CALL STODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LWM), + 1 IWORK(LIWM), RWORK(LEWT), RWORK(LSAVF), RWORK(LACOR), + 2 PAR, IWORK(LNRS), F, JAC, DF, PREPJ, PREPDF, SOLSY) + KGO = 1 - KFLAG + GO TO (300, 530, 540, 633), KGO +C----------------------------------------------------------------------- +C BLOCK F. +C THE FOLLOWING BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN FROM THE +C CORE INTEGRATOR (KFLAG = 0). TEST FOR STOP CONDITIONS. +C----------------------------------------------------------------------- + 300 INIT = 1 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. IF TOUT HAS BEEN REACHED, INTERPOLATE. ------------------- + 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 +C ITASK = 3. JUMP TO EXIT IF TOUT WAS REACHED. ------------------------ + 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 + GO TO 250 +C ITASK = 4. SEE IF TOUT OR TCRIT WAS REACHED. ADJUST H IF NECESSARY. + 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 + CALL INTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + H*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + JSTART = -2 + GO TO 250 +C ITASK = 5. SEE IF TCRIT WAS REACHED AND JUMP TO EXIT. --------------- + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX +C----------------------------------------------------------------------- +C BLOCK G. +C THE FOLLOWING BLOCK HANDLES ALL SUCCESSFUL RETURNS FROM ODESSA. +C IF ITASK .NE. 1, Y IS LOADED FROM YH AND T IS SET ACCORDINGLY. +C ISTATE IS SET TO 2, THE ILLEGAL INPUT COUNTER IS ZEROED, AND THE +C OPTIONAL OUTPUTS ARE LOADED INTO THE WORK ARRAYS BEFORE RETURNING. +C IF ISTATE = 1 AND TOUT = T, THERE IS A RETURN WITH NO ACTION TAKEN, +C EXCEPT THAT IF THIS HAS HAPPENED REPEATEDLY, THE RUN IS TERMINATED. +C----------------------------------------------------------------------- + 400 DO 410 I = 1,NYH + 410 Y(I) = RWORK(I+LYH-1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IF (ISOPT .EQ. 0) RETURN + IWORK(19) = NDFE + IWORK(20) = NSPE + RETURN + 430 NTREP = NTREP + 1 + IF (NTREP .LT. 5) RETURN + CALL XERR ('ODESSA -- REPEATED CALLS WITH ISTATE = 1 AND + 1TOUT = T (=R1)', 301, 1, 0, 0, 0, 1, T, ZERO) + GO TO 800 +C----------------------------------------------------------------------- +C BLOCK H. +C THE FOLLOWING BLOCK HANDLES ALL UNSUCCESSFUL RETURNS OTHER THAN +C THOSE FOR ILLEGAL INPUT. FIRST THE ERROR MESSAGE ROUTINE IS CALLED. +C IF THERE WAS AN ERROR TEST OR CONVERGENCE TEST FAILURE, IMXER IS SET. +C THEN Y IS LOADED FROM YH, T IS SET TO TN, AND THE ILLEGAL INPUT +C COUNTER ILLIN IS SET TO 0. THE OPTIONAL OUTPUTS ARE LOADED INTO +C THE WORK ARRAYS BEFORE RETURNING. +C----------------------------------------------------------------------- +C THE MAXIMUM NUMBER OF STEPS WAS TAKEN BEFORE REACHING TOUT. ---------- + 500 CALL XERR ('ODESSA - AT CURRENT T (=R1), MXSTEP (=I1) STEPS', + 1 201, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('TAKEN ON THIS CALL BEFORE REACHING TOUT', + 1 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) + ISTATE = -1 + GO TO 580 +C EWT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + CALL XERR ('ODESSA - AT T (=R1), EWT(I1) HAS BECOME R2 .LE. 0.', + 1 202, 1, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C TOO MUCH ACCURACY REQUESTED FOR MACHINE PRECISION. ------------------- + 520 CALL XERR ('ODESSA - AT T (=R1), TOO MUCH ACCURACY REQUESTED', + 1 203, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('FOR PRECISION OF MACHINE.. SEE TOLSF (=R2)', + 1 203, 1, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. ERROR TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ----- + 530 CALL XERR ('ODESSA - AT T(=R1) AND STEP SIZE H(=R2), THE ERROR', + 1 204, 1, 0, 0, 0, 0, ZERO, ZERO) + CALL XERR ('TEST FAILED REPEATEDLY OR WITH ABS(H) = HMIN', + 1 204, 1, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. CONVERGENCE FAILED REPEATEDLY OR WITH ABS(H) = HMIN. ---- + 540 CALL XERR ('ODESSA - AT T (=R1) AND STEP SIZE H (=R2), THE', + 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('CORRECTOR CONVERGENCE FAILED REPEATEDLY', + 1 205, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR ('OR WITH ABS(H) = HMIN', + 1 205, 1, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C COMPUTE IMXER IF RELEVANT. ------------------------------------------- + 560 BIG = ZERO + IMXER = 1 + DO 570 I = 1,NYH + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C SET Y VECTOR, T, ILLIN, AND OPTIONAL OUTPUTS. ------------------------ + 580 DO 590 I = 1,NYH + 590 Y(I) = RWORK(I+LYH-1) + T = TN + ILLIN = 0 + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IF (ISOPT .EQ. 0) RETURN + IWORK(19) = NDFE + IWORK(20) = NSPE + RETURN +C----------------------------------------------------------------------- +C BLOCK I. +C THE FOLLOWING BLOCK HANDLES ALL ERROR RETURNS DUE TO ILLEGAL INPUT +C (ISTATE = -3), AS DETECTED BEFORE CALLING THE CORE INTEGRATOR. +C FIRST THE ERROR MESSAGE ROUTINE IS CALLED. THEN IF THERE HAVE BEEN +C 5 CONSECUTIVE SUCH RETURNS JUST BEFORE THIS CALL TO THE KppSolveR, +C THE RUN IS HALTED. +C----------------------------------------------------------------------- + 601 CALL XERR ('ODESSA - ISTATE (=I1) ILLEGAL', + 1 1, 1, 1, ISTATE, 0, 0, ZERO,ZERO) + GO TO 700 + 602 CALL XERR ('ODESSA - ITASK (=I1) ILLEGAL', + 1 2, 1, 1, ITASK, 0, 0, ZERO,ZERO) + GO TO 700 + 603 CALL XERR ('ODESSA - ISTATE .GT. 1 BUT ODESSA NOT INITIALIZED', + 1 3, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 604 CALL XERR ('ODESSA - NEQ (=I1) .LT. 1', + 1 4, 1, 1, NEQ(1), 0, 0, ZERO,ZERO) + GO TO 700 + 605 CALL XERR ('ODESSA - ISTATE = 3 AND NEQ CHANGED. (I1 TO I2)', + 1 5, 1, 2, N, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 606 CALL XERR ('ODESSA - ITOL (=I1) ILLEGAL', + 1 6, 1, 1, ITOL, 0, 0, ZERO,ZERO) + GO TO 700 + 607 CALL XERR ('ODESSA - IOPT (=I1) ILLEGAL', + 1 7, 1, 1, IOPT, 0, 0, ZERO,ZERO) + GO TO 700 + 608 CALL XERR('ODESSA - MF (=I1) ILLEGAL', + 1 8, 1, 1, MF, 0, 0, ZERO,ZERO) + GO TO 700 + 609 CALL XERR('ODESSA - ML (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 9, 1, 2, ML, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 610 CALL XERR('ODESSA - MU (=I1) ILLEGAL.. .LT.0 OR .GE.NEQ (=I2)', + 1 10, 1, 2, MU, NEQ(1), 0, ZERO,ZERO) + GO TO 700 + 611 CALL XERR('ODESSA - MAXORD (=I1) .LT. 0', + 1 11, 1, 1, MAXORD, 0, 0, ZERO,ZERO) + GO TO 700 + 612 CALL XERR('ODESSA - MXSTEP (=I1) .LT. 0', + 1 12, 1, 1, MXSTEP, 0, 0, ZERO,ZERO) + GO TO 700 + 613 CALL XERR('ODESSA - MXHNIL (=I1) .LT. 0', + 1 13, 1, 1, MXHNIL, 0, 0, ZERO,ZERO) + GO TO 700 + 614 CALL XERR('ODESSA - TOUT (=R1) BEHIND T (=R2)', + 1 14, 1, 0, 0, 0, 2, TOUT, T) + CALL XERR('INTEGRATION DIRECTION IS GIVEN BY H0 (=R1)', + 1 14, 1, 0, 0, 0, 1, H0, ZERO) + GO TO 700 + 615 CALL XERR('ODESSA - HMAX (=R1) .LT. 0.0', + 1 15, 1, 0, 0, 0, 1, HMAX, ZERO) + GO TO 700 + 616 CALL XERR('ODESSA - HMIN (=R1) .LT. 0.0', + 1 16, 1, 0, 0, 0, 1, HMIN, ZERO) + GO TO 700 + 617 CALL XERR('ODESSA - RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS + 1 LRW (=I2)', 17, 1, 2, LENRW, LRW, 0, ZERO,ZERO) + GO TO 700 + 618 CALL XERR('ODESSA - IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS + 1 LIW (=I2)', 18, 1, 2, LENIW, LIW, 0, ZERO,ZERO) + GO TO 700 + 619 CALL XERR('ODESSA - RTOL(I1) IS R1 .LT. 0.0', + 1 19, 1, 1, I, 0, 1, RTOLI, ZREO) + GO TO 700 + 620 CALL XERR('ODESSA - ATOL(I1) IS R1 .LT. 0.0', + 1 20, 1, 1, I, 0, 1, ATOLI, ZERO) + GO TO 700 +* + 621 EWTI = RWORK(LEWT+I-1) + CALL XERR('ODESSA - EWT(I1) IS R1 .LE. 0.0', + 1 21, 1, 1, I, 0, 1, EWTI, ZERO) + GO TO 700 + 622 CALL XERR('ODESSA - TOUT (=R1) TOO CLOSE TO T(=R2) TO START + 1 INTEGRATION', 22, 1, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CALL XERR('ODESSA - ITASK = I1 AND TOUT (=R1) BEHIND TCUR - HU + 1 (= R2)', 23, 1, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TCUR + 1 (=R2)', 24, 1, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CALL XERR('ODESSA - ITASK = 4 OR 5 AND TCRIT (=R1) BEHIND TOUT + 1 (=R2)', 25, 1, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + 626 CALL XERR('ODESSA - AT START OF PROBLEM, TOO MUCH ACCURACY', + 1 26, 1, 0, 0, 0, 0, ZERO,ZERO) + CALL XERR('REQUESTED FOR PRECISION OF MACHINE. SEE TOLSF (=R1)', + 1 26, 1, 0, 0, 0, 1, TOLSF, ZERO) + RWORK(14) = TOLSF + GO TO 700 + 627 CALL XERR('ODESSA - TROUBLE FROM INTDY. ITASK = I1, TOUT = R1', + 1 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) + GO TO 700 +C ERROR STATEMENTS ASSOCIATED WITH SENSITIVITY ANALYSIS. + 628 CALL XERR('ODESSA - NPAR (=I1) .LT. 1', + 1 28, 1, 1, NPAR, 0, 0, ZERO,ZERO) + GO TO 700 + 629 CALL XERR('ODESSA - ISTATE = 3 AND NPAR CHANGED (I1 TO I2)', + 1 29, 1, 2, NP, NPAR, 0, ZERO,ZERO) + GO TO 700 + 630 CALL XERR('ODESSA - MITER (=I1) ILLEGAL', + 1 30, 1, 1, MITER, 0, 0, ZERO,ZERO) + GO TO 700 + 631 CALL XERR('ODESSA - TROUBLE IN SPRIME (IERPJ)', + 1 31, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 632 CALL XERR('ODESSA - TROUBLE IN SPRIME (MITER)', + 1 32, 1, 0, 0, 0, 0, ZERO,ZERO) + GO TO 700 + 633 CALL XERR('ODESSA - FATAL ERROR IN STODE (KFLAG = -3)', + 1 33, 2, 0, 0, 0, 0, ZERO,ZERO) + GO TO 801 +C + 700 IF (ILLIN .EQ. 5) GO TO 710 + ILLIN = ILLIN + 1 + ISTATE = -3 + RETURN + 710 CALL XERR('ODESSA - REPEATED OCCURRENCES OF ILLEGAL INPUT', + 1 302, 1, 0, 0, 0, 0, ZERO,ZERO) +C + 800 CALL XERR('ODESSA - RUN ABORTED.. APPARENT INFINITE LOOP', + 1 303, 2, 0, 0, 0, 0, ZERO,ZERO) + RETURN + 801 CALL XERR('ODESSA - RUN ABORTED', + 1 304, 2, 0, 0, 0, 0, ZERO,ZERO) + RETURN +C-------------------- END OF SUBROUTINE ODESSA ------------------------- + END + DOUBLE PRECISION FUNCTION ADDX(A,B) + DOUBLE PRECISION A,B +C +C THIS FUNCTION IS NECESSARY TO FORCE OPTIMIZING COMPILERS TO +C EXECUTE AND STORE A SUM, FOR SUCCESSFUL EXECUTION OF THE +C TEST A + B = B. +C + ADDX = A + B + RETURN +C-------------------- END OF FUNCTION SUM ------------------------------ + END + SUBROUTINE SPRIME (NEQ, Y, YH, NYH, NROW, NCOL, WM, IWM, + 1 EWT, SAVF, FTEM, DFDP, PAR, F, JAC, DF, PJAC, PDF) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION NEQ(*), Y(*), YH(NROW,NCOL,*), WM(*), IWM(*), + 1 EWT(*), SAVF(*), FTEM(*), DFDP(NROW,*), PAR(*) + EXTERNAL F, JAC, DF, PJAC, PDF + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 RDUM1(37),EL0, H, RDUM2(6), + 2 IOWND1(14), IOWNS(4), + 3 IDUM1(3), IERPJ, IDUM2(6), + 4 MITER, IDUM3(4), N, IDUM4(5) + COMMON /ODE002/ RDUM3(3), + 1 IOWND2(3), IDUM5, NSV, IDUM6, NSPE, IDUM7, IERSP, JOPT, IDUM8 +C----------------------------------------------------------------------- +C SPRIME IS CALLED BY ODESSA TO INITIALIZE THE YH ARRAY. IT IS ALSO +C CALLED BY STODE TO REEVALUATE FIRST ORDER DERIVATIVES WHEN KFLAG +C .LE. -3. SPRIME COMPUTES THE FIRST DERIVATIVES OF THE SENSITIVITY +C COEFFICIENTS WITH RESPECT TO THE INDEPENDENT VARIABLE T... +C +C SPRIME = D(DY/DP)/DT = JAC*DY/DP + DF/DP +C WHERE JAC = JACOBIAN MATRIX +C DY/DP = SENSITIVITY MATRIX +C DF/DP = INHOMOGENEITY MATRIX +C THIS ROUTINE USES THE COMMON VARIABLES EL0, H, IERPJ, MITER, N, +C NSV, NSPE, IERSP, JOPT +C----------------------------------------------------------------------- +C CALL PREPJ WITH JOPT = 1. +C IF MITER = 2 OR 5, EL0 IS TEMPORARILY SET TO -1.0 AND H IS +C TEMPORARILY SET TO 1.0D0. +C----------------------------------------------------------------------- + NSPE = NSPE + 1 + JOPT = 1 + IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 10 + HTEMP = H + ETEMP = EL0 + H = ONE + EL0 = -ONE + 10 CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, + 1 PAR, F, JAC, JOPT) + IF (IERPJ .NE. 0) GO TO 300 + JOPT = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 4) GO TO 20 + H = HTEMP + EL0 = ETEMP +C----------------------------------------------------------------------- +C CALL PREPDF AND LOAD DFDP(*,JPAR). +C----------------------------------------------------------------------- + 20 DO 30 J = 2,NSV + JPAR = J - 1 + CALL PDF (NEQ, Y, WM, SAVF, FTEM, DFDP(1,JPAR), PAR, + 1 F, DF, JPAR) + 30 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE JAC*DY/DP AND STORE RESULTS IN YH(*,*,2). +C----------------------------------------------------------------------- + GO TO (40,40,310,100,100) MITER +C THE JACOBIAN IS FULL.------------------------------------------------ +C FOR EACH ROW OF THE JACOBIAN.. +C 40 DO 70 IROW = 1,N +C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. +C DO 60 J = 2,NSV +C SUM = ZERO +C TAKE THE VECTOR DOT PRODUCT.. +C DO 50 I = 1,N +C IPD = IROW + N*(I-1) + 2 +C SUM = SUM + WM(IPD)*YH(I,J,1) +C 50 CONTINUE +C YH(IROW,J,2) = SUM +C 60 CONTINUE +C 70 CONTINUE + 40 CONTINUE +C FOR EACH COLUMN OF THE SENSITIVITY MATRIX.. + DO 60 J = 2,NSV + CALL Jac_SP_Vec( WM(3), YH(1,J,1), YH(1,J,2) ) + 60 CONTINUE + GO TO 200 +C THE JACOBIAN IS BANDED.----------------------------------------------- + 100 ML = IWM(1) + MU = IWM(2) + ICOUNT = 1 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + NMU = N - MU + ML1 = ML + 1 +C FOR EACH ROW OF THE JACOBIAN.. + DO 160 IROW = 1,N + IF (IROW .GT. ML1) GO TO 110 + IPD = MBAND + IROW + 1 + IYH = 1 + LBAND = MU + IROW + GO TO 120 + 110 ICOUNT = ICOUNT + 1 + IPD = ICOUNT*MEBAND + 2 + IYH = IYH + 1 + LBAND = LBAND - 1 + IF (IROW .LE. NMU) LBAND = MBAND +C AND EACH COLUMN OF THE SENSITIVITY MATRIX.. + 120 DO 150 J = 2,NSV + SUM = ZERO + I1 = IPD + I2 = IYH +C TAKE THE VECTOR DOT PRODUCT. + DO 140 I = 1,LBAND + SUM = SUM + WM(I1)*YH(I2,J,1) + I1 = I1 + MEBAND - 1 + I2 = I2 + 1 + 140 CONTINUE + YH(IROW,J,2) = SUM + 150 CONTINUE + 160 CONTINUE +C----------------------------------------------------------------------- +C ADD THE INHOMOGENEITY TERM, I.E., ADD DFDP(*,JPAR) TO YH(*,JPAR+1,2). +C----------------------------------------------------------------------- + 200 DO 220 J = 2,NSV + JPAR = J - 1 + DO 210 I = 1,N + YH(I,J,2) = YH(I,J,2) + DFDP(I,JPAR) + 210 CONTINUE + 220 CONTINUE + RETURN +C----------------------------------------------------------------------- +C ERROR RETURNS. +C----------------------------------------------------------------------- + 300 IERSP = -1 + RETURN + 310 IERSP = -2 + RETURN +C------------------------END OF SUBROUTINE SPRIME----------------------- + END + SUBROUTINE PREPJ (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, FTEM, + 1 PAR, FUNC_CHEM, JAC, JOPT) +C IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + DIMENSION NEQ(*), Y(*), YH(NYH,*), WM(*), IWM(*), EWT(*), + 1 SAVF(*), FTEM(*), PAR(*) + EXTERNAL FUNC_CHEM, JAC + PARAMETER (ZERO=0.0D0,ONE=1.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(37), EL0, H, RDUM2(4), TN, UROUND, + 3 IOWND(14), IOWNS(4), + 4 IDUM1(3), IERPJ, IDUM2, JCUR, IDUM3(4), + 5 MITER, IDUM4(4), N, IDUM5(2), NFE, NJE, IDUM6 +C----------------------------------------------------------------------- +C PREPJ IS CALLED BY STODE TO COMPUTE AND PROCESS THE MATRIX +C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. +C IF ISOPT = 1, PREPJ IS ALSO CALLED BY SPRIME WITH JOPT = 1. +C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF +C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. +C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. +C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN +C SUBJECTED TO LU DECOMPOSITION (JOPT = 0) IN PREPARATION FOR LATER +C SOLUTION OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS +C DONE BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH PREPJ USES THE FOLLOWING.. +C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. +C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STODE). +C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. +C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE +C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION +C OF P IF MITER IS 1, 2 , 4, OR 5. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. +C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C EL0 = EL(1) (INPUT). +C IERPJ = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .GT. 0 IF +C P MATRIX FOUND TO BE SINGULAR. +C JCUR = OUTPUT FLAG = 1 TO INDICATE THAT THE JACOBIAN MATRIX +C (OR APPROXIMATION) IS NOW CURRENT. +C JOPT = INPUT JACOBIAN OPTION, = 1 IF JAC IS DESIRED ONLY. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, +C IERPJ, JCUR, MITER, N, NFE, AND NJE. +C----------------------------------------------------------------------- + NJE = NJE + 1 + IERPJ = 0 + JCUR = 1 + HL0 = H*EL0 + GO TO (100, 200, 300, 400, 500), MITER +C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- +C 100 LENP = N*N + 100 LENP = LU_NONZERO + DO 110 I = 1,LU_NONZERO + 110 WM(I+2) = ZERO + CALL JAC (NEQ, TN, Y, PAR, 0, 0, WM(3), N) + IF (JOPT .EQ. 1) RETURN + CON = -HL0 + DO 120 I = 1,LU_NONZERO + 120 WM(I+2) = WM(I+2)*CON + GO TO 240 +C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- + 200 FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = -HL0/R + CALL FUNC_CHEM (NEQ, TN, Y, PAR, FTEM) + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + 230 CONTINUE + NFE = NFE + N + IF (JOPT .EQ. 1) RETURN +C ADD IDENTITY MATRIX. ------------------------------------------------- + 240 J = 3 +C DO 250 I = 1,N +C WM(J) = WM(J) + ONE +C 250 J = J + (N + 1) + DO 250 I = 1,NVAR + 250 WM(2+LU_DIAG(I)) = WM(2+LU_DIAG(I)) + ONE +C DO LU DECOMPOSITION ON P. -------------------------------------------- +C CALL DGEFA (WM(3), N, N, IWM(21), IER) + CALL KppDecomp (WM(3), IER) + IF (IER .NE. 0) THEN + IERPJ = 1 + PRINT*,"Singular Matrix" + STOP + END IF + RETURN +C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- + 300 WM(2) = HL0 + R = EL0*0.1D0 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + CALL FUNC_CHEM (NEQ, TN, Y, PAR, WM(3)) + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = 1.0D0 + IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (ABS(DI) .EQ. ZERO) GO TO 330 + WM(I+2) = 0.1D0*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN +C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- + 400 ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N + DO 410 I = 1,LENP + 410 WM(I+2) = ZERO + CALL JAC (NEQ, TN, Y, PAR, ML, MU, WM(ML3), MEBAND) + IF (JOPT .EQ. 1) RETURN + CON = -HL0 + DO 420 I = 1,LENP + 420 WM(I+2) = WM(I+2)*CON + GO TO 570 +C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- + 500 ML = IWM(1) + MU = IWM(2) + MBAND = ML + MU + 1 + MBA = MIN(MBAND,N) + MEBAND = MBAND + ML + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = VNORM (N, SAVF, EWT) + R0 = 1000.0D0*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0/EWT(I)) + 530 Y(I) = Y(I) + R + CALL FUNC_CHEM (NEQ, TN, Y, PAR, FTEM) + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) + FAC = -HL0/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA + IF (JOPT .EQ. 1) RETURN +C ADD IDENTITY MATRIX. ------------------------------------------------- + 570 II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + ONE + 580 II = II + MEBAND +C DO LU DECOMPOSITION OF P. -------------------------------------------- + CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C----------------------- END OF SUBROUTINE PREPJ ----------------------- + END + SUBROUTINE PREPDF (NEQ, Y, SRUR, SAVF, FTEM, DFDP, PAR, + 1 F, DF, JPAR) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, DF + DIMENSION NEQ(*), Y(*), SAVF(*), FTEM(*), DFDP(*), PAR(*) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 RDUM1(43), TN, RDUM2, + 2 IOWND1(14), IOWNS(4), + 3 IDUM1(10), MITER, IDUM2(4), N, IDUM3(2), NFE, IDUM4(2) + COMMON /ODE002/ RDUM3(3), + 1 IOWND2(3), IDUM5(2), NDFE, IDUM6, IDF, IDUM7(3) +C----------------------------------------------------------------------- +C PREPDF IS CALLED BY SPRIME AND STESA TO COMPUTE THE INHOMOGENEITY +C VECTORS DF(I)/DP(JPAR). HERE DF/DP IS COMPUTED BY THE USER-SUPPLIED +C ROUTINE DF IF IDF = 1, OR BY FINITE DIFFERENCING IF IDF = 0. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION WITH +C PREPDF USES THE FOLLOWING.. +C Y = REAL ARRAY OF LENGTH NYH CONTAINING DEPENDENT VARIABLES. +C PREPDF USES ONLY THE FIRST N ENTRIES OF Y(*). +C SRUR = SQRT(UROUND) (= WM(1)). +C SAVF = REAL ARRAY OF LENGTH N CONTAINING DERIVATIVES DY/DT. +C FTEM = REAL ARRAY OF LENGTH N USED TO TEMPORARILY STORE DY/DT FOR +C NUMERICAL DIFFERENTIATION. +C DFDP = REAL ARRAY OF LENGTH N USED TO STORE DF(I)/DP(JPAR), I = 1,N. +C PAR = REAL ARRAY OF LENGTH NPAR CONTAINING EQUATION PARAMETERS +C OF INTEREST. +C JPAR = INPUT PARAMETER, 2 .LE. JPAR .LE. NSV, DESIGNATING THE +C APPROPRIATE SOLUTION VECTOR CORRESPONDING TO PAR(JPAR). +C THIS ROUTINE ALSO USES THE COMMON VARIABLES TN, MITER, N, NFE, NDFE, +C AND IDF. +C----------------------------------------------------------------------- + NDFE = NDFE + 1 + IDF1 = IDF + 1 + GO TO (100, 200), IDF1 +C IDF = 0, CALL F TO APPROXIMATE DFDP. --------------------------------- + 100 RPAR = PAR(JPAR) + R = MAX(SRUR*ABS(RPAR),SRUR) + PAR(JPAR) = RPAR + R + FAC = 1.0D0/R + CALL F (NEQ, TN, Y, PAR, FTEM) + DO 110 I = 1,N + 110 DFDP(I) = (FTEM(I) - SAVF(I))*FAC + PAR(JPAR) = RPAR + NFE = NFE + 1 + RETURN +C IDF = 1, CALL USER SUPPLIED DF. -------------------------------------- + 200 DO 210 I = 1,N + 210 DFDP(I) = 0.0D0 + CALL DF (NEQ, TN, Y, PAR, DFDP, JPAR) + RETURN +C -------------------- END OF SUBROUTINE PREPDF ------------------------ + END + SUBROUTINE INTDY (T, K, YH, NYH, DKY, IFLAG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION YH(NYH,1), DKY(1) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(38),H, RDUM2(2), HU, RDUM3, TN, UROUND, + 3 IOWND(14), IOWNS(4), + 4 IDUM1(8), L, IDUM2, + 5 IDUM3(5), N, NQ, IDUM4(4) +C----------------------------------------------------------------------- +C INTDY COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE +C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. THIS ROUTINE +C IS CALLED WITHIN THE PACKAGE WITH K = 0 AND T = TOUT, BUT MAY +C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. +C (SEE DETAILED INSTRUCTIONS IN THE USAGE DOCUMENTATION.) +C----------------------------------------------------------------------- +C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE +C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A +C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET +C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. +C THE FORMULA FOR DKY IS.. +C Q +C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) +C J=K +C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. +C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE +C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. +C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. +C----------------------------------------------------------------------- + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TP = TN - HU*(1.0D0 + 100.0D0*UROUND) + IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1,NQ + 10 IC = IC*JJ + 15 C = REAL(IC) + DO 20 I = 1,NYH + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + JB2 = NQ - K + DO 50 JB = 1,JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1,J + 30 IC = IC*JJ + 35 C = REAL(IC) + DO 40 I = 1,NYH + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + DO 60 I = 1,NYH + 60 DKY(I) = R*DKY(I) + RETURN +C + 80 CALL XERR('INTDY-- K (=I1) ILLEGAL', + 1 51, 1, 1, K, 0, 0, ZERO,ZERO) + IFLAG = -1 + RETURN + 90 CALL XERR ('INTDY-- T (=R1) ILLEGAL', + 1 52, 1, 0, 0, 0, 1, T, ZERO) + CALL XERR('T NOT IN INTERVAL TCUR - HU (= R1) TO TCUR (=R2)', + 1 52, 1, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- END OF SUBROUTINE INTDY ----------------------- + END + SUBROUTINE STESA (NEQ, Y, NROW, NCOL, YH, WM, IWM, EWT, SAVF, + 1 ACOR, PAR, NRS, F, JAC, DF, PJAC, PDF, KppSolve) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, JAC, DF, PJAC, PDF, KppSolve + DIMENSION NEQ(*), Y(NROW,*), YH(NROW,NCOL,*), WM(*), IWM(*), + 1 EWT(NROW,*), SAVF(*), ACOR(NROW,*), PAR(*), NRS(*) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 1 TESCO(3,12), RDUM1, EL0, H, RDUM2(4), TN, RDUM3, + 2 IOWND1(14), IOWNS(4), + 3 IALTH, LMAX, IDUM1, IERPJ, IERSL, JCUR, IDUM2, KFLAG, L, IDUM3, + 4 MITER, IDUM4(4), N, NQ, IDUM5, NFE, IDUM6(2) + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 IOWND2(3), IDUM7, NSV, IDUM8(2), IDF, IDUM9, JOPT, KFLAGS +C----------------------------------------------------------------------- +C STESA IS CALLED BY STODE TO PERFORM AN EXPLICIT CALCULATION FOR THE +C FIRST-ORDER SENSITIVITY COEFFICIENTS DY(I)/DP(J), I = 1,N; J = 1,NPAR. +C +C IN ADDITION TO THE VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH STESA USES THE FOLLOWING.. +C Y = AN NROW (=N) BY NCOL (=NSV) REAL ARRAY CONTAINING THE +C CORRECTED DEPENDENT VARIABLES ON OUTPUT.. +C Y(I,1) , I = 1,N = STATE VARIABLES (INPUT); +C Y(I,J) , I = 1,N , J = 2,NSV , +C = SENSITIVITY COEFFICIENTS, DY(I)/DP(J). +C YH = AN N BY NSV BY LMAX REAL ARRAY CONTAINING THE PREDICTED +C DEPENDENT VARIABLES AND THEIR APPROXIMATE SCALED DERIVATIVES. +C SAVF = A REAL ARRAY OF LENGTH N USED TO STORE FIRST DERIVATIVES +C OF DEPENDENT VARIABLES IF MITER = 2 OR 5. +C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING THE EQUATION +C PARAMETERS OF INTEREST. +C NRS = AN INTEGER ARRAY OF LENGTH NPAR + 1 CONTAINING THE NUMBER +C OF REPEATED STEPS (KFLAGS .LT. 0) DUE TO THE SENSITIVITY +C CALCULATIONS.. +C NRS(1) = TOTAL NUMBER OF REPEATED STEPS +C NRS(I) , I = 2,NPAR = NUMBER OF REPEATED STEPS DUE +C TO PARAMETER I. +C NSV = NUMBER OF SOLUTION VECTORS = NPAR + 1. +C KFLAGS = LOCAL ERROR TEST FLAG, = 0 IF TEST PASSES, .LT. 0 IF TEST +C FAILS, AND STEP NEEDS TO BE REPEATED. ERROR TEST IS APPLIED +C TO EACH SOLUTION VECTOR INDEPENDENTLY. +C DUPS, DSMS, DDNS = REAL SCALARS USED FOR COMPUTING RHUP, RHSM, RHDN, +C ON RETURN TO STODE (IALTH .EQ. 1). +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, IALTH, LMAX, +C IERPJ, IERSL, JCUR, KFLAG, L, MITER, N, NQ, NFE, AND JOPT. +C----------------------------------------------------------------------- + DUPS = ZERO + DSMS = ZERO + DDNS = ZERO + HL0 = H*EL0 + EL0I = ONE/EL0 + TI2 = ONE/TESCO(2,NQ) + TI3 = ONE/TESCO(3,NQ) +C IF MITER = 2 OR 5 (OR IDF = 0), SUPPLY DERIVATIVES AT CORRECTED +C Y(*,1) VALUES FOR NUMERICAL DIFFERENTIATION IN PJAC AND/OR PDF. + IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. IDF .EQ. 0) GO TO 10 + GO TO 15 + 10 CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 +C IF JCUR = 0, UPDATE THE JACOBIAN MATRIX. +C IF MITER = 5, LOAD CORRECTED Y(*,1) VALUES INTO Y(*,2). + 15 IF (JCUR .EQ. 1) GO TO 30 + IF (MITER .NE. 5) GO TO 25 + DO 20 I = 1,N + 20 Y(I,2) = Y(I,1) + 25 CALL PJAC (NEQ, Y, Y(1,2), N, WM, IWM, EWT, SAVF, ACOR(1,2), + 1 PAR, F, JAC, JOPT) + IF (IERPJ .NE. 0) RETURN +C----------------------------------------------------------------------- +C THIS IS A LOOPING POINT FOR THE SENSITIVITY CALCULATIONS. +C----------------------------------------------------------------------- +C FOR EACH PARAMETER PAR(*), A SENSITIVITY SOLUTION VECTOR IS COMPUTED +C USING THE SAME STEP SIZE (H) AND ORDER (NQ) AS IN STODE. +C A LOCAL ERROR TEST IS APPLIED INDEPENDENTLY TO EACH SOLUTION VECTOR. +C----------------------------------------------------------------------- + 30 DO 100 J = 2,NSV + JPAR = J - 1 +C EVALUATE INHOMOGENEITY TERM, TEMPORARILY LOAD INTO Y(*,JPAR+1). ------ + CALL PDF(NEQ, Y, WM, SAVF, ACOR(1,J), Y(1,J), PAR, + 1 F, DF, JPAR) +C----------------------------------------------------------------------- +C LOAD RHS OF SENSITIVITY SOLUTION (CORRECTOR) EQUATION.. +C +C RHS = DY/DP - EL(1)*H*D(DY/DP)/DT + EL(1)*H*DF/DP +C +C----------------------------------------------------------------------- + DO 40 I = 1,N + 40 Y(I,J) = YH(I,J,1) - EL0*YH(I,J,2) + HL0*Y(I,J) +C----------------------------------------------------------------------- +C KppSolve CORRECTOR EQUATION: THE SOLUTIONS ARE LOCATED IN Y(*,JPAR+1). +C THE EXPLICIT FORMULA IS.. +C +C (I - EL(1)*H*JAC) * DY/DP(CORRECTED) = RHS +C +C----------------------------------------------------------------------- + CALL KppSolve (WM, IWM, Y(1,J), DUM) + IF (IERSL .NE. 0) RETURN +C ESTIMATE LOCAL TRUNCATION ERROR. ------------------------------------- + DO 50 I = 1,N + 50 ACOR(I,J) = (Y(I,J) - YH(I,J,1))*EL0I + ERR = VNORM(N, ACOR(1,J), EWT(1,J))*TI2 + IF (ERR .GT. ONE) GO TO 200 +C----------------------------------------------------------------------- +C LOCAL ERROR TEST PASSED. SET KFLAGS TO 0 TO INDICATE THIS. +C IF IALTH = 1, COMPUTE DSMS, DDNS, AND DUPS (IF L .LT. LMAX). +C----------------------------------------------------------------------- + KFLAGS = 0 + IF (IALTH .GT. 1) GO TO 100 + IF (L .EQ. LMAX) GO TO 70 + DO 60 I= 1,N + 60 Y(I,J) = ACOR(I,J) - YH(I,J,LMAX) + DUPS = MAX(DUPS,VNORM(N,Y(1,J),EWT(1,J))*TI3) + 70 DSMS = MAX(DSMS,ERR) + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C THIS SECTION IS REACHED IF THE ERROR TOLERANCE FOR SENSITIVITY +C SOLUTION VECTOR JPAR HAS BEEN VIOLATED. KFLAGS IS MADE NEGATIVE TO +C INDICATE THIS. IF KFLAGS = -1, SET KFLAG EQUAL TO ZERO SO THAT KFLAG +C IS SET TO -1 ON RETURN TO STODE BEFORE REPEATING THE STEP. +C INCREMENT NRS(1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO ALL +C SENSITIVITY SOLUTION VECTORS) BY ONE. +C INCREMENT NRS(JPAR+1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO +C SOLUTION VECTOR JPAR+1) BY ONE. +C LOAD DSMS FOR RH CALCULATION IN STODE. +C----------------------------------------------------------------------- + 200 KFLAGS = KFLAGS - 1 + IF (KFLAGS .EQ. -1) KFLAG = 0 + NRS(1) = NRS(1) + 1 + NRS(J) = NRS(J) + 1 + DSMS = ERR + RETURN +C------------------------ END OF SUBROUTINE STESA ---------------------- + END + SUBROUTINE STODE (NEQ, Y, YH, NYH, YH1, WM, IWM, EWT, SAVF, ACOR, + 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + EXTERNAL F, JAC, DF, PJAC, PDF, SLVS + DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), WM(*), IWM(*), EWT(*), + 1 SAVF(*), ACOR(*), PAR(*), NRS(*) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) + COMMON /ODE001/ ROWND, + 1 CONIT, CRATE, EL(13), ELCO(13,12), HOLD, RMAX, + 2 TESCO(3,12), CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, + 3 IOWND1(14), IPUP, MEO, NQNYH, NSLP, + 4 IALTH, LMAX, ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, METH, + 5 MITER, MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU + COMMON /ODE002/ DUPS, DSMS, DDNS, + 1 IOWND2(3), ISOPT, NSV, NDFE, NSPE, IDF, IERSP, JOPT, KFLAGS +C----------------------------------------------------------------------- +C STODE PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE +C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. +C NOTE.. STODE IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD +C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT +C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. +C FOR ISOPT = 1, STODE CALLS STESA FOR SENSITIVITY CALCULATIONS. +C VARIABLES USED FOR COMMUNICATION WITH STESA ARE DESCRIBED IN STESA. +C COMMUNICATION WITH STODE IS DONE WITH THE FOLLOWING VARIABLES.. +C +C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND +C NUMBER OF PARAMETERS TO BE CONSIDERED IN THE SENSITIVITY +C ANALYSIS NEQ(2) (FOR ISOPT = 1), AND PASSED AS THE +C NEQ ARGUMENT IN ALL CALLS TO F, JAC, AND DF. +C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN +C ALL CALLS TO F, JAC, AND DF. +C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES +C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE +C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE +C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) +C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST +C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. +C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. +C THE TOTAL NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS.. +C NYH = N, ISOPT = 0, +C NYH = N * (NPAR + 1), ISOPT = 1 +C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. +C EWT = AN ARRAY OF LENGTH NYH CONTAINING MULTIPLICATIVE WEIGHTS +C FOR LOCAL ERROR MEASUREMENTS. LOCAL ERRORS IN Y(I) ARE +C COMPARED TO 1.0/EWT(I) IN VARIOUS ERROR TESTS. +C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. +C ALSO USED FOR INPUT OF YH(*,MAXORD+2) WHEN JSTART = -1 +C AND MAXORD .LT. THE CURRENT ORDER NQ. +C ACOR = A WORK ARRAY OF LENGTH NYH, USED FOR THE ACCUMULATED +C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS +C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). +C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX +C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). +C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX +C AND P = I - H*EL0*JAC, IF A CHORD METHOD IS BEING USED. +C IF ISOPT = 1, PJAC CAN BE CALLED TO CALCULATE JAC BY +C SETTING JOPT = 1. +C SLVS = NAME OF ROUTINE TO KppSolve LINEAR SYSTEM IN CHORD ITERATION. +C CCMAX = MAXIMUM RELATIVE CHANGE IN H*EL0 BEFORE PJAC IS CALLED. +C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. +C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE +C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS +C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. +C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. +C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. +C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. +C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT +C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. +C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. +C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING +C VALUES AND MEANINGS.. +C 0 PERFORM THE FIRST STEP. +C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. +C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, +C N, METH, OR MITER. +C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, +C BUT WITH OTHER INPUTS UNCHANGED. +C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. +C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. +C 0 THE STEP WAS SUCCESFUL. +C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. +C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. +C -3 FATAL ERROR IN PJAC, OR SLVS, (OR STESA). +C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER +C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. +C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND +C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST +C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. +C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. +C MAXCOR = THE MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED. +C (= 3, IF ISOPT = 0) +C (= 4, IF ISOPT = 1) +C MSBP = MAXIMUM NUMBER OF STEPS BETWEEN PJAC CALLS (MITER .GT. 0). +C IF ISOPT = 1, PJAC IS CALLED AT LEAST ONCE EVERY STEP. +C MXNCF = MAXIMUM NUMBER OF CONVERGENCE FAILURES ALLOWED. +C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. +C N = THE NUMBER OF FIRST-ORDER MODEL DIFFERENTIAL EQUATIONS. +C----------------------------------------------------------------------- + KFLAG = 0 + KFLAGS = 0 + TOLD = TN + NCF = 0 + IERPJ = 0 + IERSL = 0 + JCUR = 0 + ICF = 0 + IF (JSTART .GT. 0) GO TO 200 + IF (JSTART .EQ. -1) GO TO 100 + IF (JSTART .EQ. -2) GO TO 160 +C----------------------------------------------------------------------- +C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE +C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED +C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL +C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE +C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 +C FOR THE NEXT INCREASE. +C THESE COMPUTATIONS CONSIDER ONLY THE ORIGINAL SOLUTION VECTOR. +C THE SENSITIVITY SOLUTION VECTORS ARE CONSIDERED IN STESA (ISOPT = 1). +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0D0 + RC = ZERO + EL0 = ONE + CRATE = 0.7D0 + DELP = ZERO + HOLD = H + MEO = METH + NSLP = 0 + IPUP = MITER + IRET = 3 + GO TO 140 +C----------------------------------------------------------------------- +C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. +C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. +C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), +C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. +C IF THE CALLER HAS CHANGED METH, CFODE IS CALLED TO RESET +C THE COEFFICIENTS OF THE METHOD. +C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT +C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. +C IF H IS TO BE CHANGED, YH MUST BE RESCALED. +C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 +C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + 100 IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 110 + CALL CFODE (METH, ELCO, TESCO) + MEO = METH + IF (NQ .GT. MAXORD) GO TO 120 + IALTH = L + IRET = 1 + GO TO 150 + 110 IF (NQ .LE. MAXORD) GO TO 160 + 120 NQ = MAXORD + L = LMAX + DO 125 I = 1,L + 125 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/REAL(NQ+2) + DDN = VNORM (N, SAVF, EWT)/TESCO(1,L) + EXDN = ONE/REAL(L) + RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) + RH = MIN(RHDN,ONE) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 170 + RH = MIN(RH,ABS(H/HOLD)) + H = HOLD + GO TO 175 +C----------------------------------------------------------------------- +C CFODE IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE +C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET +C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. +C----------------------------------------------------------------------- + 140 CALL CFODE (METH, ELCO, TESCO) + 150 DO 155 I = 1,L + 155 EL(I) = ELCO(I,NQ) + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/REAL(NQ+2) + GO TO (160, 170, 200), IRET +C----------------------------------------------------------------------- +C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST +C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO +C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS +C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. +C----------------------------------------------------------------------- + 160 IF (H .EQ. HOLD) GO TO 200 + RH = H/HOLD + H = HOLD + IREDO = 3 + GO TO 175 + 170 RH = MAX(RH,HMIN/ABS(H)) + 175 RH = MIN(RH,RMAX) + RH = RH/MAX(ONE,ABS(H)*HMXI*RH) + R = ONE + DO 180 J = 2,L + R = R*RH + DO 180 I = 1,NYH + 180 YH(I,J) = YH(I,J)*R + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .EQ. 0) GO TO 690 +C----------------------------------------------------------------------- +C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY +C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. +C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). +C WHEN RC DIFFERS FROM 1 BY MORE THAN CCMAX, IPUP IS SET TO MITER +C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. +C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY MSBP STEPS FOR ISOPT = 0, +C AND AT LEAST ONCE EVERY STEP FOR ISOPT = 1. +C----------------------------------------------------------------------- + 200 IF (ABS(RC-ONE) .GT. CCMAX) IPUP = MITER + IF (NST .GE. NSLP+MSBP) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 215 JB = 1,NQ + I1 = I1 - NYH + DO 210 I = I1,NQNYH + 210 YH1(I) = YH1(I) + YH1(I+NYH) + 215 CONTINUE +C----------------------------------------------------------------------- +C UP TO MAXCOR CORRECTOR ITERATIONS ARE TAKEN. (= 3, FOR ISOPT = 0; +C = 4, FOR ISOPT = 1). A CONVERGENCE TEST IS MADE ON THE R.M.S. NORM +C OF EACH CORRECTION, WEIGHTED BY THE ERROR WEIGHT VECTOR EWT. THE SUM +C OF THE CORRECTIONS IS ACCUMULATED IN THE VECTOR ACOR(I), I = 1,N. +C (ACOR(I), I = N+1,NYH IS LOADED IN SUBROUTINE STESA (ISOPT = 1).) +C THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. +C----------------------------------------------------------------------- + 220 M = 0 + DO 230 I = 1,N + 230 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND +C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET +C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. +C----------------------------------------------------------------------- + IPUP = 0 + RC = ONE + NSLP = NST + CRATE = 0.7D0 + CALL PJAC (NEQ, Y, YH, NYH, WM, IWM, EWT, SAVF, ACOR, PAR, + 1 F, JAC, JOPT) + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = ZERO + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM +C THE RESULT OF THE LAST FUNCTION EVALUATION. +C (IF ISOPT = 1, FUNCTIONAL ITERATION IS NOT ALLOWED.) +C----------------------------------------------------------------------- + DO 290 I = 1,N + SAVF(I) = H*SAVF(I) - YH(I,2) + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = VNORM (N, Y, EWT) + DO 300 I = 1,N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + 300 ACOR(I) = SAVF(I) + GO TO 400 +C----------------------------------------------------------------------- +C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, +C AND KppSolve THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND +C P AS COEFFICIENT MATRIX. +C----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) + CALL SLVS (WM, IWM, Y, SAVF) + IF (IERSL .LT. 0) GO TO 430 + IF (IERSL .GT. 0) GO TO 410 + DEL = VNORM (N, Y, EWT) + DO 380 I = 1,N + ACOR(I) = ACOR(I) + Y(I) + 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) +C----------------------------------------------------------------------- +C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE +C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) + DCON = DEL*MIN(ONE,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) + IF (DCON .LE. ONE) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 + DELP = DEL + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + GO TO 270 +C----------------------------------------------------------------------- +C THE CORRECTOR ITERATION FAILED TO CONVERGE IN MAXCOR TRIES. +C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR +C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES +C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE +C REDUCED OR MXNCF FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. +C----------------------------------------------------------------------- + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + GO TO 220 + 430 ICF = 2 + NCF = NCF + 1 + RMAX = 2.0D0 + TN = TOLD + I1 = NQNYH + 1 + DO 445 JB = 1,NQ + I1 = I1 - NYH + DO 440 I = I1,NQNYH + 440 YH1(I) = YH1(I) - YH1(I+NYH) + 445 CONTINUE + IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + RH = 0.25D0 + IPUP = MITER + IREDO = 1 + GO TO 170 +C----------------------------------------------------------------------- +C THE CORRECTOR HAS CONVERGED. +C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 +C IF IT FAILS. OTHERWISE, STESA IS CALLED (ISOPT = 1) TO PERFORM +C SENSITIVITY CALCULATIONS AT CURRENT STEP SIZE AND ORDER. +C----------------------------------------------------------------------- + 450 CONTINUE + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) DSM = VNORM (N, ACOR, EWT)/TESCO(2,NQ) + IF (DSM .GT. ONE) GO TO 500 +C + IF (ISOPT .EQ. 0) GO TO 460 +C----------------------------------------------------------------------- +C CALL STESA TO PERFORM EXPLICIT SENSITIVITY ANALYSIS. +C IF THE LOCAL ERROR TEST FAILS (WITHIN STESA) FOR ANY SOLUTION VECTOR, +C KFLAGS IS SET .LT. 0 AND CONTROL PASSES TO STATEMENT 500 UPON RETURN. +C IN EITHER CASE, JCUR IS SET TO ZERO TO SIGNAL THAT THE JACOBIAN MAY +C NEED UPDATING LATER. +C----------------------------------------------------------------------- + CALL STESA (NEQ, Y, N, NSV, YH, WM, IWM, EWT, SAVF, ACOR, + 1 PAR, NRS, F, JAC, DF, PJAC, PDF, SLVS) + IF (IERPJ .NE. 0 .OR. IERSL .NE. 0) GO TO 680 + IF (KFLAGS .LT. 0) GO TO 500 +C----------------------------------------------------------------------- +C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. +C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. +C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR +C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. +C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER +C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A +C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT +C TESTING FOR THAT MANY STEPS. +C----------------------------------------------------------------------- + 460 JCUR = 0 + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 J = 1,L + DO 470 I = 1,NYH + 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) + IALTH = IALTH - 1 + IF (IALTH .EQ. 0) GO TO 520 + IF (IALTH .GT. 1) GO TO 700 + IF (L .EQ. LMAX) GO TO 700 + DO 490 I = 1,NYH + 490 YH(I,LMAX) = ACOR(I) + GO TO 700 +C----------------------------------------------------------------------- +C THE ERROR TEST FAILED IN EITHER STODE OR STESA. +C KFLAG KEEPS TRACK OF MULTIPLE FAILURES. +C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE +C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR +C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE +C BY A FACTOR OF 0.2 OR LESS. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + JCUR = 0 + TN = TOLD + I1 = NQNYH + 1 + DO 515 JB = 1,NQ + I1 = I1 - NYH + DO 510 I = I1,NQNYH + 510 YH1(I) = YH1(I) - YH1(I+NYH) + 515 CONTINUE + RMAX = 2.0D0 + IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 + IF (KFLAG .LE. -3) GO TO 640 + IREDO = 2 + RHUP = ZERO + GO TO 540 +C----------------------------------------------------------------------- +* +C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS +C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED +C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. +C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. +C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN +C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE +C ADDITIONAL SCALED DERIVATIVE. +C FOR ISOPT = 1, DUPS AND DSMS ARE LOADED WITH THE LARGEST RMS-NORMS +C OBTAINED BY CONSIDERING SEPARATELY THE SENSITIVITY SOLUTION VECTORS. +C----------------------------------------------------------------------- + 520 RHUP = ZERO + IF (L .EQ. LMAX) GO TO 540 + DO 530 I = 1,N + 530 SAVF(I) = ACOR(I) - YH(I,LMAX) + DUP = VNORM (N, SAVF, EWT)/TESCO(3,NQ) + DUP = MAX(DUP,DUPS) + EXUP = ONE/REAL(L+1) + RHUP = ONE/(1.4D0*DUP**EXUP + 0.0000014D0) + 540 EXSM = ONE/REAL(L) + DSM = MAX(DSM,DSMS) + RHSM = ONE/(1.2D0*DSM**EXSM + 0.0000012D0) + RHDN = ZERO + IF (NQ .EQ. 1) GO TO 560 + JPOINT = 1 + DO 550 J = 1,NSV + DDN = VNORM (N, YH(JPOINT,L), EWT(JPOINT))/TESCO(1,NQ) + DDNS = MAX(DDNS,DDN) + JPOINT = JPOINT + N + 550 CONTINUE + DDN = DDNS + DDNS = ZERO + EXDN = ONE/REAL(NQ) + RHDN = ONE/(1.3D0*DDN**EXDN + 0.0000013D0) + 560 IF (RHSM .GE. RHUP) GO TO 570 + IF (RHUP .GT. RHDN) GO TO 590 + GO TO 580 + 570 IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + GO TO 620 + 580 NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. ONE) RH = ONE + GO TO 620 + 590 NEWQ = L + RH = RHUP + IF (RH .LT. 1.1D0) GO TO 610 + R = EL(L)/REAL(L) + DO 600 I = 1,NYH + 600 YH(I,NEWQ+1) = ACOR(I)*R + GO TO 630 + 610 IALTH = 3 + GO TO 700 + 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) +C----------------------------------------------------------------------- +C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. +C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. +C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. +C----------------------------------------------------------------------- + IF (NEWQ .EQ. NQ) GO TO 170 + 630 NQ = NEWQ + L = NQ + 1 + IRET = 2 + GO TO 150 +C----------------------------------------------------------------------- +C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. +C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. +C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE +C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST +C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN +C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, +C UNTIL IT SUCCEEDS OR H REACHES HMIN. +C----------------------------------------------------------------------- + 640 IF (KFLAG .EQ. -10) GO TO 660 + RH = 0.1D0 + RH = MAX(HMIN/ABS(H),RH) + H = H*RH + DO 645 I = 1,NYH + 645 Y(I) = YH(I,1) + CALL F (NEQ, TN, Y, PAR, SAVF) + NFE = NFE + 1 + IF (ISOPT .EQ. 0) GO TO 649 + CALL SPRIME (NEQ, Y, YH, NYH, N, NSV, WM, IWM, EWT, SAVF, ACOR, + 1 ACOR(N+1), PAR, F, JAC, DF, PJAC, PDF) + IF (IERSP .LT. 0) GO TO 680 + DO 646 I = N+1,NYH + 646 YH(I,2) = H*YH(I,2) + 649 DO 650 I = 1,N + 650 YH(I,2) = H*SAVF(I) + IPUP = MITER + IALTH = 5 + IF (NQ .EQ. 1) GO TO 200 + NQ = 1 + L = 2 + IRET = 3 + GO TO 150 +C----------------------------------------------------------------------- +C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD +C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 KFLAG = -3 + GO TO 720 + 690 RMAX = 10.0D0 + 700 R = ONE/TESCO(2,NQU) + DO 710 I = 1,NYH + 710 ACOR(I) = ACOR(I)*R + 720 HOLD = H + JSTART = 1 + RETURN +C----------------------- END OF SUBROUTINE STODE ----------------------- + END + SUBROUTINE CFODE (METH, ELCO, TESCO) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION ELCO(13,12), TESCO(3,12) +C----------------------------------------------------------------------- +C CFODE IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS +C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS +C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. +C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. +C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) +C CFODE IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, +C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. +C +C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. +C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF +C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING +C POLYNOMIAL, I.E., +C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. +C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY +C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. +C FOR THE BDF METHODS, L(X) IS GIVEN BY +C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, +C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). +C +C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE +C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. +C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP +C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER +C NQ + 1 IF K = 3. +C----------------------------------------------------------------------- + DIMENSION PC(12) + PARAMETER (ONE=1.0D0,ZERO=0.0D0) +C + GO TO (100, 200), METH +C + 100 ELCO(1,1) = ONE + ELCO(2,1) = ONE + TESCO(1,1) = ZERO + TESCO(2,1) = 2.0D0 + TESCO(1,2) = ONE + TESCO(3,12) = ZERO + PC(1) = ONE + RQFAC = ONE + DO 140 NQ = 2,12 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ-1). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + RQ1FAC = RQFAC + RQFAC = RQFAC/REAL(NQ) + NQM1 = NQ - 1 + FNQM1 = REAL(NQM1) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- + PC(NQ) = ZERO + DO 110 IB = 1,NQM1 + I = NQP1 - IB + 110 PC(I) = PC(I-1) + FNQM1*PC(I) + PC(1) = FNQM1*PC(1) +C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0D0 + TSIGN = ONE + DO 120 I = 2,NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/REAL(I) + 120 XPIN = XPIN + TSIGN*PC(I)/REAL(I+1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = ONE + DO 130 I = 2,NQ + 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/REAL(I) + AGAMQ = RQFAC*XPIN + RAGQ = ONE/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/REAL(NQP1) + TESCO(3,NQM1) = RAGQ + 140 CONTINUE + RETURN +C + 200 PC(1) = ONE + RQ1FAC = ONE + DO 230 NQ = 1,5 +C----------------------------------------------------------------------- +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL +C P(X) = (X+1)*(X+2)*...*(X+NQ). +C INITIALLY, P(X) = 1. +C----------------------------------------------------------------------- + FNQ = REAL(NQ) + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ + PC(NQP1) = ZERO + DO 210 IB = 1,NQ + I = NQ + 2 - IB + 210 PC(I) = PC(I-1) + FNQ*PC(I) + PC(1) = FNQ*PC(1) +C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- + DO 220 I = 1,NQP1 + 220 ELCO(I,NQ) = PC(I)/PC(2) + ELCO(2,NQ) = ONE + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = REAL(NQP1)/ELCO(1,NQ) + TESCO(3,NQ) = REAL(NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 230 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE CFODE ----------------------- + END + SUBROUTINE SOLSY (WM, IWM, X, TEM) +C IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + DIMENSION WM(*), IWM(*), X(*), TEM(*) + PARAMETER (ZERO=0.0D0,ONE=1.0D0) + COMMON /ODE001/ ROWND, ROWNS(173), + 2 RDUM1(37), EL0, H, RDUM2(6), + 3 IOWND(14), IOWNS(4), + 4 IDUM1(4), IERSL, IDUM2(5), + 5 MITER, IDUM3(4), N, IDUM4(5) +C----------------------------------------------------------------------- +C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM +C A CHORD ITERATION. IT IS CALLED IF MITER .NE. 0. +C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. +C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL +C MATRIX, AND THEN COMPUTES THE SOLUTION. +C IF MITER IS 4 OR 5, IT CALLS DGBSL. +C COMMUNICATION WITH SOLSY USES THE FOLLOWING VARIABLES.. +C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF +C MITER = 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND) (NOT USED HERE), +C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT +C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS BAND +C PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. +C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR +C ON OUTPUT, OF LENGTH N. +C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. +C IERSL = OUTPUT FLAG (IN COMMON). IERSL = 0 IF NO TROUBLE OCCURRED. +C IERSL = 1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. +C----------------------------------------------------------------------- + IERSL = 0 + GO TO (100, 100, 300, 400, 400), MITER +C 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) + 100 CALL KppSolve (WM(3), X) + RETURN +C + 300 PHL0 = WM(2) + HL0 = H*EL0 + WM(2) = HL0 + IF (HL0 .EQ. PHL0) GO TO 330 + R = HL0/PHL0 + DO 320 I = 1,N + DI = ONE - R*(ONE - ONE/WM(I+2)) + IF (ABS(DI) .EQ. ZERO) GO TO 390 + 320 WM(I+2) = ONE/DI + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) + RETURN +C----------------------- END OF SUBROUTINE SOLSY ----------------------- + END + SUBROUTINE EWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) +C----------------------------------------------------------------------- +C THIS SUBROUTINE SETS THE ERROR WEIGHT VECTOR EWT ACCORDING TO +C EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I), I = 1,...,N, +C WITH THE SUBSCRIPT ON RTOL AND/OR ATOL POSSIBLY REPLACED BY 1 ABOVE, +C DEPENDING ON THE VALUE OF ITOL. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) + RTOLI = RTOL(1) + ATOLI = ATOL(1) + DO 10 I = 1,N + IF (ITOL .GE. 3) RTOLI = RTOL(I) + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + EWT(I) = RTOLI*ABS(YCUR(I)) + ATOLI + 10 CONTINUE + RETURN +C----------------------- END OF SUBROUTINE EWSET ----------------------- + END + DOUBLE PRECISION FUNCTION VNORM (N, V, W) +C----------------------------------------------------------------------- +C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM +C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS +C CONTAINED IN THE ARRAY W OF LENGTH N.. +C VNORM = SQRT( (1/N) * SUM( V(I)*W(I) )**2 ) +C PROTECTION FOR UNDERFLOW/OVERFLOW IS ACCOMPLISHED USING TWO +C CONSTANTS WHICH ARE HOPEFULLY APPLICABLE FOR ALL MACHINES. +C THESE ARE: +C CUTLO = maximum of SQRT(U/EPS) over all known machines +C CUTHI = minimum of SQRT(Z) over all known machines +C WHERE +C EPS = smallest number s.t. EPS + 1 .GT. 1 +C U = smallest positive number (underflow limit) +C Z = largest number (overflow limit) +C +C DETAILS OF THE ALGORITHM AND OF VALUES OF CUTLO AND CUTHI ARE +C FOUND IN THE BLAS ROUTINE SNRM2 (SEE ALSO ALGORITHM 539, TRANS. +C MATH. SOFTWARE, VOL. 5 NO. 3, 1979, 308-323. +C FOR SINGLE PRECISION, THE FOLLOWING VALUES SHOULD BE UNIVERSAL: +C DATA CUTLO,CUTHI /4.441E-16,1.304E19/ +C FOR DOUBLE PRECISION, USE +C DATA CUTLO,CUTHI /8.232D-11,1.304D19/ +C +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER NEXT,I,J,N + DIMENSION V(N),W(N) + DATA CUTLO,CUTHI /8.232D-11,1.304D19/ + DATA ZERO,ONE/0.0D0,1.0D0/ +C BLAS ALGORITHM + NEXT = 1 + SUM = ZERO + I = 1 +20 SX = V(I)*W(I) + GO TO (30,40,70,80),NEXT +30 IF (ABS(SX).GT.CUTLO) GO TO 110 + NEXT = 2 + XMAX = ZERO +40 IF (SX.EQ.ZERO) GO TO 130 + IF (ABS(SX).GT.CUTLO) GO TO 110 + NEXT = 3 + GO TO 60 +50 I=J + NEXT = 4 + SUM = (SUM/SX)/SX +60 XMAX = ABS(SX) + GO TO 90 +70 IF(ABS(SX).GT.CUTLO) GO TO 100 +80 IF(ABS(SX).LE.XMAX) GO TO 90 + SUM = ONE + SUM * (XMAX/SX)**2 + XMAX = ABS(SX) + GO TO 130 +90 SUM = SUM + (SX/XMAX)**2 + GO TO 130 +100 SUM = (SUM*XMAX)*XMAX +110 HITEST = CUTHI/REAL(N) + DO 120 J = I,N + SX = V(J)*W(J) + IF(ABS(SX).GE.HITEST) GO TO 50 + SUM = SUM + SX**2 +120 CONTINUE + VNORM = SQRT(SUM) + GO TO 140 +130 CONTINUE + I = I + 1 + IF (I.LE.N) GO TO 20 + VNORM = XMAX * SQRT(SUM) +140 CONTINUE + RETURN +C----------------------- END OF FUNCTION VNORM ------------------------- + END + SUBROUTINE SVCOM (RSAV, ISAV) +C----------------------------------------------------------------------- +C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS +C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSA +C PACKAGE. +C RSAV = REAL ARRAY OF LENGTH 222 OR MORE. +C ISAV = INTEGER ARRAY OF LENGTH 52 OR MORE. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RSAV(*), ISAV(*) + COMMON /ODE001/ RODE1(219), IODE1(39) + COMMON /ODE002/ RODE2(3), IODE2(11) + COMMON /EH0001/ IEH(2) + DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ +C + DO 10 I = 1,LRODE1 + 10 RSAV(I) = RODE1(I) + DO 20 I = 1,LRODE2 + J = LRODE1 + I + 20 RSAV(J) = RODE2(I) + DO 30 I = 1,LIODE1 + 30 ISAV(I) = IODE1(I) + DO 40 I = 1,LIODE2 + J = LIODE1 + I + 40 ISAV(J) = IODE2(I) + ISAV(LIODE1+LIODE2+1) = IEH(1) + ISAV(LIODE1+LIODE2+2) = IEH(2) + RETURN +C----------------------- END OF SUBROUTINE SVCOM ----------------------- + END + SUBROUTINE RSCOM (RSAV, ISAV) +C----------------------------------------------------------------------- +C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON BLOCKS +C ODE001, ODE002 AND EH0001, WHICH ARE USED INTERNALLY IN THE ODESSSA +C PACKAGE. THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS +C OF SUBROUTINE SVCOM OR THE EQUIVALENT. +C----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION RSAV(*), ISAV(*) + COMMON /ODE001/ RODE1(219), IODE1(39) + COMMON /ODE002/ RODE2(3), IODE2(11) + COMMON /EH0001/ IEH(2) + DATA LRODE1/219/, LIODE1/39/, LRODE2/3/, LIODE2/11/ +C + DO 10 I = 1,LRODE1 + 10 RODE1(I) = RSAV(I) + DO 20 I = 1,LRODE2 + J = LRODE1 + I + 20 RODE2(I) = RSAV(J) + DO 30 I = 1,LIODE1 + 30 IODE1(I) = ISAV(I) + DO 40 I = 1,LODE2 + J = LIODE1 + I + 40 IODE2(I) = ISAV(J) + IEH(1) = ISAV(LIODE1+LIODE2+1) + IEH(2) = ISAV(LIODE1+LIODE2+2) + RETURN +C----------------------- END OF SUBROUTINE RSCOM ----------------------- + END + SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) + INTEGER LDA,N,IPVT(*),INFO + DOUBLE PRECISION A(LDA,*) +C +C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. +C +C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED +C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. +C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . +C +C ON ENTRY +C +C A DOUBLE PRECISION(LDA, N) +C THE MATRIX TO BE FACTORED. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C +C N INTEGER +C THE ORDER OF THE MATRIX A . +C +C ON RETURN +C +C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS +C WHICH WERE USED TO OBTAIN IT. +C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE +C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER +C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. +C +C IPVT INTEGER(N) +C AN INTEGER VECTOR OF PIVOT INDICES. +C +C INFO INTEGER +C = 0 NORMAL VALUE. +C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR +C CONDITION FOR THIS SUBROUTINE, BUT IT DOES +C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO +C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE +C INDICATION OF SINGULARITY. +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DSCAL,IDAMAX +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +C +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +C +C FIND L = PIVOT INDEX +C + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) + INTEGER LDA,N,IPVT(*),JOB + DOUBLE PRECISION A(LDA,*),B(*) +C +C DGESL KppSolveS THE DOUBLE PRECISION SYSTEM +C A * X = B OR TRANS(A) * X = B +C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. +C +C ON ENTRY +C +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT FROM DGECO OR DGEFA. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C +C N INTEGER +C THE ORDER OF THE MATRIX A . +C +C IPVT INTEGER(N) +C THE PIVOT VECTOR FROM DGECO OR DGEFA. +C +C B DOUBLE PRECISION(N) +C THE RIGHT HAND SIDE VECTOR. +C +C JOB INTEGER +C = 0 TO KppSolve A*X = B , +C = NONZERO TO KppSolve TRANS(A)*X = B WHERE +C TRANS(A) IS THE TRANSPOSE. +C +C ON RETURN +C +C B THE SOLUTION VECTOR X . +C +C ERROR CONDITION +C +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A +C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY +C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER +C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE +C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 +C OR DGEFA HAS SET INFO .EQ. 0 . +C +C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX +C WITH P COLUMNS +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND IS TOO SMALL) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DDOT +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , KppSolve A * X = B +C FIRST KppSolve L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW KppSolve U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, KppSolve TRANS(A) * X = B +C FIRST KppSolve TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW KppSolve TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) + INTEGER LDA,N,ML,MU,IPVT(*),INFO + DOUBLE PRECISION ABD(LDA,*) +C +C DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION. +C +C DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED +C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. +C +C ON ENTRY +C +C ABD DOUBLE PRECISION(LDA, N) +C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS +C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND +C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS +C ML+1 THROUGH 2*ML+MU+1 OF ABD . +C SEE THE COMMENTS BELOW FOR DETAILS. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY ABD . +C LDA MUST BE .GE. 2*ML + MU + 1 . +C +C N INTEGER +C THE ORDER OF THE ORIGINAL MATRIX. +C +C ML INTEGER +C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. +C 0 .LE. ML .LT. N . +C +C MU INTEGER +C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. +C 0 .LE. MU .LT. N . +C MORE EFFICIENT IF ML .LE. MU . +C ON RETURN +C +C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND +C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. +C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE +C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER +C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. +C +C IPVT INTEGER(N) +C AN INTEGER VECTOR OF PIVOT INDICES. +C +C INFO INTEGER +C = 0 NORMAL VALUE. +C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR +C CONDITION FOR THIS SUBROUTINE, BUT IT DOES +C INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF +C CALLED. USE RCOND IN DGBCO FOR A RELIABLE +C INDICATION OF SINGULARITY. +C +C BAND STORAGE +C +C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT +C WILL SET UP THE INPUT. +C +C ML = (BAND WIDTH BELOW THE DIAGONAL) +C MU = (BAND WIDTH ABOVE THE DIAGONAL) +C M = ML + MU + 1 +C DO 20 J = 1, N +C I1 = MAX0(1, J-MU) +C I2 = MIN0(N, J+ML) +C DO 10 I = I1, I2 +C K = I - J + M +C ABD(K,J) = A(I,J) +C 10 CONTINUE +C 20 CONTINUE +C +C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . +C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR +C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. +C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . +C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE +C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DSCAL,IDAMAX +C FORTRAN MAX0,MIN0 +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION T + INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 +C +C + M = ML + MU + 1 + INFO = 0 +C +C ZERO INITIAL FILL-IN COLUMNS +C + J0 = MU + 2 + J1 = MIN0(N,M) - 1 + IF (J1 .LT. J0) GO TO 30 + DO 20 JZ = J0, J1 + I0 = M + 1 - JZ + DO 10 I = I0, ML + ABD(I,JZ) = 0.0D0 + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + JZ = J1 + JU = 0 +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 130 + DO 120 K = 1, NM1 + KP1 = K + 1 +C +C ZERO NEXT FILL-IN COLUMN +C + JZ = JZ + 1 + IF (JZ .GT. N) GO TO 50 + IF (ML .LT. 1) GO TO 50 + DO 40 I = 1, ML + ABD(I,JZ) = 0.0D0 + 40 CONTINUE + 50 CONTINUE +C +C FIND L = PIVOT INDEX +C + LM = MIN0(ML,N-K) + L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 + IPVT(K) = L + K - M +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. M) GO TO 60 + T = ABD(L,K) + ABD(L,K) = ABD(M,K) + ABD(M,K) = T + 60 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/ABD(M,K) + CALL DSCAL(LM,T,ABD(M+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + JU = MIN0(MAX0(JU,MU+IPVT(K)),N) + MM = M + IF (JU .LT. KP1) GO TO 90 + DO 80 J = KP1, JU + L = L - 1 + MM = MM - 1 + T = ABD(L,J) + IF (L .EQ. MM) GO TO 70 + ABD(L,J) = ABD(MM,J) + ABD(MM,J) = T + 70 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) + 80 CONTINUE + 90 CONTINUE + GO TO 110 + 100 CONTINUE + INFO = K + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + IPVT(N) = N + IF (ABD(M,N) .EQ. 0.0D0) INFO = N + RETURN + END + SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) + INTEGER LDA,N,ML,MU,IPVT(*),JOB + DOUBLE PRECISION ABD(LDA,*),B(*) +C +C DGBSL KppSolveS THE DOUBLE PRECISION BAND SYSTEM +C A * X = B OR TRANS(A) * X = B +C USING THE FACTORS COMPUTED BY DGBCO OR DGBFA. +C +C ON ENTRY +C +C ABD DOUBLE PRECISION(LDA, N) +C THE OUTPUT FROM DGBCO OR DGBFA. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY ABD . +C +C N INTEGER +C THE ORDER OF THE ORIGINAL MATRIX. +C +C ML INTEGER +C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. +C +C MU INTEGER +C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. +C +C IPVT INTEGER(N) +C THE PIVOT VECTOR FROM DGBCO OR DGBFA. +C +C B DOUBLE PRECISION(N) +C THE RIGHT HAND SIDE VECTOR. +C +C JOB INTEGER +C = 0 TO KppSolve A*X = B , +C = NONZERO TO KppSolve TRANS(A)*X = B , WHERE +C TRANS(A) IS THE TRANSPOSE. +C +C ON RETURN +C +C B THE SOLUTION VECTOR X . +C +C ERROR CONDITION +C +C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A +C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY +C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER +C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE +C CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0 +C OR DGBFA HAS SET INFO .EQ. 0 . +C +C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX +C WITH P COLUMNS +C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) +C IF (RCOND IS TOO SMALL) GO TO ... +C DO 10 J = 1, P +C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) +C 10 CONTINUE +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C BLAS DAXPY,DDOT +C FORTRAN MIN0 +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,LA,LB,LM,M,NM1 +C + M = MU + ML + 1 + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , KppSolve A * X = B +C FIRST KppSolve L*Y = B +C + IF (ML .EQ. 0) GO TO 30 + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + LM = MIN0(ML,N-K) + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW KppSolve U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/ABD(M,K) + LM = MIN0(K,M) - 1 + LA = M - LM + LB = K - LM + T = -B(K) + CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, KppSolve TRANS(A) * X = B +C FIRST KppSolve TRANS(U)*Y = B +C + DO 60 K = 1, N + LM = MIN0(K,M) - 1 + LA = M - LM + LB = K - LM + T = DDOT(LM,ABD(LA,K),1,B(LB),1) + B(K) = (B(K) - T)/ABD(M,K) + 60 CONTINUE +C +C NOW KppSolve TRANS(L)*X = Y +C + IF (ML .EQ. 0) GO TO 90 + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + LM = MIN0(ML,N-K) + B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C +C CONSTANT TIMES A VECTOR PLUS A VECTOR. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DY(*),DA + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + IF(N.LE.0)RETURN + IF (DA .EQ. 0.0D0) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + END + SUBROUTINE DSCAL(N,DA,DX,INCX) +C +C SCALES A VECTOR BY A CONSTANT. +C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DA,DX(*) + INTEGER I,INCX,M,MP1,N,NINCX +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +* +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +C +C FORMS THE DOT PRODUCT OF TWO VECTORS. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DY(*),DTEMP + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + RETURN + END + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C +C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(*),DMAX + INTEGER I,INCX,IX,N +C + IDAMAX = 0 + IF( N .LT. 1 ) RETURN + IDAMAX = 1 + IF(N.EQ.1)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF(DABS(DX(IX)).LE.DMAX) GO TO 5 + IDAMAX = I + DMAX = DABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + IF(DABS(DX(I)).LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = DABS(DX(I)) + 30 CONTINUE + RETURN + END + DOUBLE PRECISION FUNCTION D1MACH (IDUM) + INTEGER IDUM +C----------------------------------------------------------------------- +C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE +C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER +C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). +C----------------------------------------------------------------------- + DOUBLE PRECISION U, COMP + U = 1.0D0 + 10 U = U*0.5D0 + COMP = 1.0D0 + U + IF (COMP .NE. 1.0D0) GO TO 10 + D1MACH = U*2.0D0 + RETURN +C----------------------- END OF FUNCTION D1MACH ------------------------ + END + SUBROUTINE XERR (MSG, NERR, IERT, NI, I1, I2, NR, R1, R2) + INTEGER NERR, IERT, NI, I1, I2, NR, + 1 LUN, LUNIT, MESFLG + DOUBLE PRECISION R1, R2 + CHARACTER*(*) MSG +C------------------------------------------------------------------- +C +C ALL ARGUMENTS ARE INPUT ARGUMENTS. +C +C MSG = THE MESSAGE (CHARACTER VARIABLE) +C NERR = THE ERROR NUMBER (NOT USED). +C IERT = THE ERROR TYPE.. +C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). +C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). +C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. +C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. +C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. +C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. +C +C NOTES: +C 1. THE DIMENSION OF MSG IS ASSUMED TO BE AT MOST 60. +C (MULTI-LINE MESSAGES ARE GENERATED BY REPEATED CALLS.) +C 2. IF IERT = 2, CONTROL PASSES TO THE STATEMENT STOP +C TO ABORT THE RUN. THIS STATEMENT MAY BE MACHINE-DEPENDENT. +C 3. R1 AND R2 ARE ASSUMED TO BE IN DOUBLE PRECISION AND ARE PRINTED +C IN D21.13 FORMAT. +C 4. THE COMMON BLOCK /EH0001/ BELOW IS DATA-LOADED (A MACHINE- +C DEPENDENT FEATURE) WITH DEFAULT VALUES. +C THIS BLOCK IS NEEDED FOR PROPER RETENTION OF PARAMETERS USED BY +C THIS ROUTINE WHICH THE USER CAN RESET BY CALLING XSETF OR XSETUN. +C THE VARIABLES IN THIS BLOCK ARE AS FOLLOWS.. +C MESFLG = PRINT CONTROL FLAG.. +C 1 MEANS PRINT ALL MESSAGES (THE DEFAULT). +C 0 MEANS NO PRINTING. +C LUNIT = LOGICAL UNIT NUMBER FOR MESSAGES. +C THE DEFAULT IS 6 (MACHINE-DEPENDENT). +C 5. TO CHANGE THE DEFAULT OUTPUT UNIT, CHANGE THE DATA STATEMENT +C IN THE BLOCK DATA SUBPROGRAM BELOW. +C +C FOR A DIFFERENT RUN-ABORT COMMAND, CHANGE THE STATEMENT FOLLOWING +C STATEMENT 100 AT THE END. +C----------------------------------------------------------------------- + COMMON /EH0001/ MESFLG, LUNIT + IF (MESFLG .EQ. 0) GO TO 100 +C GET LOGICAL UNIT NUMBER. --------------------------------------------- + LUN = LUNIT +C WRITE THE MESSAGE. --------------------------------------------------- + WRITE (LUN, 10) MSG + 10 FORMAT(1X,A) +C----------------------------------------------------------------------- + IF (NI .EQ. 1) WRITE (LUN, 20) I1 + 20 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10) + IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2 + 30 FORMAT(6X,'IN ABOVE MESSAGE, I1 = ',I10,3X,'I2 = ',I10) + IF (NR .EQ. 1) WRITE (LUN, 40) R1 + 40 FORMAT(6X,'IN ABOVE MESSAGE, R1 = ',D21.13) + IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2 + 50 FORMAT(6X,'IN ABOVE, R1 = ',D21.13,3X,'R2 = ',D21.13) +C ABORT THE RUN IF IERT = 2. ------------------------------------------- + 100 IF (IERT .NE. 2) RETURN + STOP +C----------------------- END OF SUBROUTINE XERR ---------------------- + END + SUBROUTINE XSETF (MFLAG) +C +C THIS ROUTINE RESETS THE PRINT CONTROL FLAG MFLAG. +C + INTEGER MFLAG, MESFLG, LUNIT + COMMON /EH0001/ MESFLG, LUNIT +C + IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) MESFLG = MFLAG + RETURN +C----------------------- END OF SUBROUTINE XSETF ----------------------- + END + SUBROUTINE XSETUN (LUN) +C +C THIS ROUTINE RESETS THE LOGICAL UNIT NUMBER FOR MESSAGES. +C + INTEGER LUN, MESFLG, LUNIT + COMMON /EH0001/ MESFLG, LUNIT +C + IF (LUN .GT. 0) LUNIT = LUN + RETURN +C----------------------- END OF SUBROUTINE XSETUN ---------------------- + END + BLOCK DATA +C----------------------------------------------------------------------- +C THIS DATA SUBPROGRAM LOADS VARIABLES INTO THE INTERNAL COMMON +C BLOCKS USED BY ODESSA AND ITS VARIANTS. THE VARIABLES ARE +C DEFINED AS FOLLOWS.. +C ILLIN = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE +C WAS CALLED WITH ILLEGAL INPUT. THE RUN IS STOPPED WHEN +C ILLIN REACHES 5. +C NTREP = COUNTER FOR THE NUMBER OF CONSECUTIVE TIMES THE PACKAGE +C WAS CALLED WITH ISTATE = 1 AND TOUT = T. THE RUN IS +C STOPPED WHEN NTREP REACHES 5. +C MESFLG = FLAG TO CONTROL PRINTING OF ERROR MESSAGES. 1 MEANS PRINT, +C 0 MEANS NO PRINTING. +C LUNIT = DEFAULT VALUE OF LOGICAL UNIT NUMBER FOR PRINTING OF ERROR +C MESSAGES. +C----------------------------------------------------------------------- + INTEGER ILLIN, IDUMA, NTREP, IDUMB, IOWNS, ICOMM, MESFLG, LUNIT + DOUBLE PRECISION ROWND, ROWNS, RCOMM + COMMON /ODE001/ ROWND, ROWNS(173), RCOMM(45), + 1 ILLIN, IDUMA(10), NTREP, IDUMB(2), IOWNS(4), ICOMM(21) + COMMON /EH0001/ MESFLG, LUNIT + DATA ILLIN/0/, NTREP/0/ + DATA MESFLG/1/, LUNIT/6/ +C +C------------------------ END OF BLOCK DATA ---------------------------- + END +C----------------------------------------------------------------------- +C INSTRUCTIONS FOR INSTALLING THE ODESSA PACKAGE. (see @ below.) +C +C ODESSA is an enhanced version of the widely disseminated ODE solver +C LSODE, and as such retains the same properties regarding portability. +C The notes below, adapted from the installation instructions for LSODE, +C are intended to facilitate the installation of the ODESSA package in +C the user's software library. +C +C 1. Both a single and a double precision version of ODESSA are +C provided in this release. It is expected that most users will +C utilize the double precision version, except in the case of +C extended word-length computers. Most routines used by ODESSA +C are named the same regardless of whether they are single or +C double precision. The exceptions are the LINPAK and BLAS +C routines that follow the LINPAK/BLAS naming conventions, i.e. +C D--- for a double precision routine, and S--- for a single +C precision routine. Thus, care should be taken if both single +C and double precision versions are stored in the same library. +C +C 2. Several routines in ODESSA have the same names as the LSODE +C routines from which they were derived, although they contain +C different code. These are: INTDY, STODE, PREPJ, SVCOM, and +C RSCOM. If ODESSA is added to a subroutine library of which +C LSODE is already a member, these routine names must be changed +C in one of the two programs. Also see the note regarding BLOCK +C DATA subroutines below. +C +C 3. In many cases, ODESSA uses unaltered LSODE routines and +C common library routines that may already reside on your system. +C The installation of ODESSA should be done so that identical routines +C are shared rather than kept as duplicate copies. +C a. Normally, the user calls only subroutine ODESSA, but for optional +C capabilities the user may also CALL XSETUN, XSETF, SVCOM, RSCOM, +C or INTDY, as described in Part II of the Full Description in the +C User Documentation (ODESSA.DOC, see below). Except for INTDY, +C none of these are called from within the package. +C b. Two routines, EWSET and VNORM, are optionally replaceable by the +C user if the package version is unsuitable. Hence, the install- +C ation of the package should be done so that the user's version +C for either routine overrides the package version. +C c. The function routine D1MACH is provided to compute the unit +C roundoff of the machine and precision in use, in a manner com- +C patible with machine parameter routines developed at Bell Lab- +C oratories. If such a routine has already been installed on +C your system, the version supplied here may be discarded. +C d. Linear algebraic systems are solved with routines from the +C LINPACK collection, in conjunction with routines from the Basic +C Linear Algebra module collection (BLAS). In double precision, +C the names are DGEFA, DGESL, DGBFA, and DGBSL (from LINPACK), and +C DAXPY, DSCAL, IDAMAX, and DDOT (from BLAS). If these routines +C have already been installed on your system, copies supplied with +C ODESSA may be discarded. The single precision versions of these +C routines are used in the single precision version. +C +C 4. There are four integer variables, in the two labeled COMMON +C blocks /ODE001/ and /EH0001/, which need to be loaded with DATA +C statements. They can vary during execution, and are in common to +C assure their retention between calls. This is legal in ANSI Fortran +C only if done in a BLOCK DATA subprogram, and this package has a +C BLOCK DATA for this purpose. However, BLOCK DATA subprograms can be +C difficult to install in libraries, and many compilers allow such DATA +C statements in subroutines. If your system allows this, the location +C of the DATA statements are just after the initial type and common +C declarations in subroutines ODESSA and XERR. In ODESSA, ILLIN and +C NTREP are DATA-loaded as 0. In XERR, MESFLG is loaded as 1 and +C LUNIT is loaded as the appropriate default logical unit number. +C +C 5. The ODESSA package contains subscript expressions which may not +C be accepted by some compilers. Subscripts of the form I + J, I - J, +C etc., occur in various routines. If any of these forms are +C unacceptable to your compiler, an extra line of code setting the +C subscript to a dummy integer value should be added for each subscipt. +C +C 6. User documentation is provided in a two-level structure +C to accommmodate both the casual and serious user. The novice or +C casual user should need to read only the Summary of Usage and the +C Example Problem located at the beginning of the documentation. More +C experienced users, requiring the full set of available options, +C should read the Full Description which follows the Example Problem. +C +C 7. The user documentation may need corrections in the following ways: +C a. If subroutine names have been changed to avoid conflicts between +C the LSODE and ODESSA packages, the corresponding name changes +C should be made in the documentation. +C b. In the Summary of Usage, and in the description of XSETUN under +C Part II of the Full Description, the default logical unit number +C should be corrected if it is not 6. +C c. In the Summary of Usage, users should be instructed to execute +C CALL XSETF(1) before the first CALL to ODESSA, if this is neces- +C sary for proper error message handling. (see note 2(e) above.) +C d. In the description of the subroutines DF and JAC in the Summary +C of Usage and in Part I of the Full Description, it is stated +C that dummy names may be passed if these two routines are not user +C supplied. Your system may require the user to supply a dummy +C subroutine instead. +C e. The ODESSA package treats the arguments NEQ, RTOL, and ATOL as +C arrays (possibly of length 1), while the usage documentation +C states that these arguments may be either arrays or scalars. +C If your system does not allow such a mismatch, then the +C documentation should be changed to reflect this. +C 8. A demonstration program is provided with the package for +C verification. +C +C +C Jorge R. Leis and Mark A. Kramer +C Department of Chemical Engineering +C Massachusetts Institute of Technology +C Cambridge, Massachusetts 02139 +C U.S.A. +C +C Current address of J.R. Leis (Jan. 1988): +C +C Shell Development Company +C Westhollow Research Center +C Houston, TX +C +C @ Adapted from 'Instructions for Installing LSODE', written by +C Alan C. Hindmarsh, Mathematics & Statistics Division, L-316, +C Lawrence Livermore National Laboratory, Livermore, CA. 94550 diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.def new file mode 100755 index 00000000..e7d0bf54 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.def @@ -0,0 +1,5 @@ +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW +#DOUBLE ON +#INTFILE kpp_radau5 + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.f90 new file mode 100755 index 00000000..9e6560d7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_radau5.f90 @@ -0,0 +1,1200 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! RADAU5 - Runge-Kutta method based on Radau-2A quadrature ! +! (2 stages, order 5) ! +! By default the code employs the KPP sparse linear algebra routines ! +! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! + +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision, ONLY: dp + USE KPP_ROOT_Jacobian, ONLY: NVAR, LU_NONZERO, LU_DIAG + USE KPP_ROOT_LinearAlgebra + + IMPLICIT NONE + PUBLIC + SAVE + + ! Statistics + INTEGER :: Nfun, Njac, Nstp, Nacc, Nrej, Ndec, Nsol, Nsng + + ! Method parameters + KPP_REAL :: Transf(3,3), TransfInv(3,3), & + rkA(3,3), rkB(3), rkC(3), rkE(3), & + rkGamma, rkAlpha, rkBeta + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-11:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -11 + 'Step size too small: T + 10*H = T or H < Roundoff ', & ! -10 + 'No of steps exceeds maximum bound ', & ! -9 + 'Tolerances are too small ', & ! -8 + 'Improper values for Qmin, Qmax ', & ! -7 + 'Newton stopping tolerance too small ', & ! -6 + 'Improper value for ThetaMin ', & ! -5 + 'Improper values for FacMin/FacMax/FacSafe/FacRej ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Improper value for maximal no of Newton iterations', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + + ! ************************************************************************** + + SUBROUTINE INTEGRATE( TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters, ONLY: NVAR + USE KPP_ROOT_Global, ONLY: ATOL,RTOL,VAR + + IMPLICIT NONE + + KPP_REAL :: TIN ! TIN - Start Time + KPP_REAL :: TOUT ! TOUT - End Time + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + KPP_REAL, SAVE :: H + INTEGER :: IERR + + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + INTEGER, SAVE :: Ntotal = 0 + + H =0.0_dp + + !~~~> fine-tune the integrator: + ICNTRL(:) = 0 + ICNTRL(2) = 0 ! 0=vector tolerances, 1=scalar tolerances + ICNTRL(5) = 8 ! Max no. of Newton iterations + ICNTRL(6) = 1 ! Starting values for Newton are interpolated (0) or zero (1) + ICNTRL(11) = 1 ! Gustaffson (1) or classic(2) controller + RCNTRL(1:20) = 0._dp + + !~~~> if optional parameters are given, and if they are >0, + ! then use them to overwrite default settings + IF (PRESENT(ICNTRL_U)) ICNTRL(1:20) = ICNTRL_U(1:20) + IF (PRESENT(RCNTRL_U)) RCNTRL(1:20) = RCNTRL_U(1:20) + + + CALL RADAU5( NVAR,TIN,TOUT,VAR,H, & + RTOL,ATOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + +!!$ Ntotal = Ntotal + Nstp +!!$ PRINT*,'NSTEPS=',Nstp,' (',Ntotal,')' + + Nfun = Nfun + ISTATUS(1) + Njac = Njac + ISTATUS(2) + Nstp = Nstp + ISTATUS(3) + Nacc = Nacc + ISTATUS(4) + Nrej = Nrej + ISTATUS(5) + Ndec = Ndec + ISTATUS(6) + Nsol = Nsol + ISTATUS(7) + Nsng = Nsng + ISTATUS(8) + + ! if optional parameters are given for output + ! use them to store information in them + IF (PRESENT(ISTATUS_U)) THEN + ISTATUS_U(:) = 0 + ISTATUS_U(1) = Nfun ! function calls + ISTATUS_U(2) = Njac ! jacobian calls + ISTATUS_U(3) = Nstp ! steps + ISTATUS_U(4) = Nacc ! accepted steps + ISTATUS_U(5) = Nrej ! rejected steps (except at the beginning) + ISTATUS_U(6) = Ndec ! LU decompositions + ISTATUS_U(7) = Nsol ! forward/backward substitutions + ENDIF + IF (PRESENT(RSTATUS_U)) THEN + RSTATUS_U(:) = 0. + RSTATUS_U(1) = TOUT ! final time + ENDIF + IF (PRESENT(IERR_U)) IERR_U = IERR + +! mz_rs_20050716: IERR is returned to the user who then decides what to do +! about it, i.e. either stop the run or ignore it. +!!$ IF (IERR < 0) THEN +!!$ PRINT *,'RADAU: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' +!!$ STOP +!!$ ENDIF + + END SUBROUTINE INTEGRATE + + SUBROUTINE RADAU5(N,T,Tend,Y,H,RelTol,AbsTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IDID) + +!~~~>----------------------------------------------- +! NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +! SYSTEM OF FirstStep 0RDER ORDINARY DIFFERENTIAL EQUATIONS +! M*Y'=F(T,Y). +! THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M /= I) +! OR EXPLICIT (M=I). +! THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) +! OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. +! C.F. SECTION IV.8 +! +! AUTHORS: E. HAIRER AND G. WANNER +! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +! CH-1211 GENEVE 24, SWITZERLAND +! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +! +! THIS CODE IS PART OF THE BOOK: +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, +! SPRINGER-VERLAG (1991) +! +! VERSION OF SEPTEMBER 30, 1995 +! +! INPUT PARAMETERS +! ---------------- +! N DIMENSION OF THE SYSTEM +! +! FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE +! VALUE OF F(T,Y): +! SUBROUTINE FCN(N,T,Y,F) +! KPP_REAL T,Y(N),F(N) +! F(1)=... ETC. +! RPAR, IPAR (SEE BELOW) +! +! T INITIAL TIME VALUE +! +! Tend FINAL T-VALUE (Tend-T MAY BE POSITIVE OR NEGATIVE) +! +! Y(N) INITIAL VALUES FOR Y +! +! H INITIALL STEP SIZE GUESS; +! FOR STIFF EQUATIONS WITH INITIALL TRANSIENT, +! H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. +! THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS +! QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). +! +! RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. +! for ICNTRL(2) = 0: AbsTol, RelTol are N-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ----- CONTINUOUS OUTPUT: ----- +! DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION +! FOR THE INTERVAL [Told,T] IS AVAILABLE THROUGH +! THE FUNCTION +! >>> CONTR5(I,S,CONT,LRC) <<< +! WHICH PROVIDES AN APPROXIMATION TO THE I-TH +! COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE +! S SHOULD LIE IN THE INTERVAL [Told,T]. +! DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE +! DENSE OUTPUT FUNCTION IS USED. +!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +!~~~> Integer input parameters: +! +! ICNTRL(1) = not used +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) = not used +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0 the default value of 10000 is used +! +! ICNTRL(5) -> maximum number of Newton iterations +! For ICNTRL(5)=0 the default value of 8 is used +! +! ICNTRL(6) -> starting values of Newton iterations: +! ICNTRL(6)=0 : starting values are obtained from +! the extrapolated collocation solution +! (the default) +! ICNTRL(6)=1 : starting values are zero +! +! ICNTRL(11) -> switch for step size strategy +! ICNTRL(8) == 1: mod. predictive controller (Gustafsson) +! ICNTRL(8) == 2: classical step size control +! the default value (for iwork(8)=0) is iwork(8)=1. +! the choice iwork(8) == 1 seems to produce safer results; +! for simple problems, the choice iwork(8) == 2 produces +! often slightly faster runs +! ( currently unused ) +! +!~~~> Real input parameters: +! +! RCNTRL(1) -> not used +! +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! +! RCNTRL(3) -> not used +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +! +! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller +! than ThetaMin the Jacobian is not recomputed; +! (default=0.001) +! +! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method +! (default=0.03) +! +! RCNTRL(10) -> Qmin +! +! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the +! step size is kept constant and the LU factorization +! reused (default Qmin=1, Qmax=1.2) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! +! OUTPUT PARAMETERS +! ----------------- +! T T-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED +! (AFTER SUCCESSFUL RETURN T=Tend). +! +! Y(N) NUMERICAL SOLUTION AT T +! +! H PREDICTED STEP SIZE OF THE LastStep ACCEPTED STEP +! +! IDID REPORTS ON SUCCESSFULNESS UPON RETURN: +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart +! in the subsequent run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER :: N + KPP_REAL :: Y(N),AbsTol(N),RelTol(N),RCNTRL(20),RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + LOGICAL :: StartNewton, Gustafsson + INTEGER :: IDID, ITOL + KPP_REAL :: H,Tend,T + + !~~~> Control arguments + INTEGER :: Max_no_steps, NewtonMaxit + KPP_REAL :: Hstart,Hmin,Hmax,Qmin,Qmax + KPP_REAL :: Roundoff, ThetaMin,TolNewton + KPP_REAL :: FacSafe,FacMin,FacMax,FacRej + !~~~> Local variables + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + + !~~~> variables from the former COMMON block /CONRA5/ + ! KPP_REAL :: Tsol, Hsol + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SETTING THE PARAMETERS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Nfun=0 + Njac=0 + Nstp=0 + Nacc=0 + Nrej=0 + Ndec=0 + Nsol=0 + IDID = 0 + +!~~~> ICNTRL(1) - autonomous system - not used +!~~~> ITOL: 1 for vector and 0 for scalar AbsTol/RelTol + IF (ICNTRL(2) == 0) THEN + ITOL = 1 + ELSE + ITOL = 0 + END IF +!~~~> ICNTRL(3) - method selection - not used +!~~~> Max_no_steps: the maximal number of time steps + IF (ICNTRL(4) == 0) THEN + Max_no_steps = 10000 + ELSE + Max_no_steps=ICNTRL(4) + IF (Max_no_steps <= 0) THEN + WRITE(6,*) 'ICNTRL(4)=',ICNTRL(4) + CALL RAD_ErrorMsg(-1,T,ZERO,IDID) + END IF + END IF +!~~~> NewtonMaxit MAXIMAL NUMBER OF NEWTON ITERATIONS + IF (ICNTRL(5) == 0) THEN + NewtonMaxit = 8 + ELSE + NewtonMaxit=ICNTRL(5) + IF (NewtonMaxit <= 0) THEN + WRITE(6,*) 'ICNTRL(5)=',ICNTRL(5) + CALL RAD_ErrorMsg(-2,T,ZERO,IDID) + END IF + END IF +!~~~> StartNewton: Use extrapolation for starting values of Newton iterations + IF (ICNTRL(6) == 0) THEN + StartNewton = .TRUE. + ELSE + StartNewton = .FALSE. + END IF +!~~~> Gustafsson: step size controller + IF(ICNTRL(11) == 0)THEN + Gustafsson=.TRUE. + ELSE + Gustafsson=.FALSE. + END IF + + +!~~~> Roundoff SMALLEST NUMBER SATISFYING 1.0d0+Roundoff>1.0d0 + Roundoff=WLAMCH('E'); + +!~~~> RCNTRL(1) = Hmin - not used + Hmin = ZERO +!~~~> Hmax = maximal step size + IF (RCNTRL(2) == ZERO) THEN + Hmax=Tend-T + ELSE + Hmax=MAX(ABS(RCNTRL(7)),ABS(Tend-T)) + END IF +!~~~> RCNTRL(3) = Hstart - not used + Hstart = ZERO +!~~~> FacMin: lower bound on step decrease factor + IF(RCNTRL(4) == ZERO)THEN + FacMin = 0.2d0 + ELSE + FacMin = RCNTRL(4) + END IF +!~~~> FacMax: upper bound on step increase factor + IF(RCNTRL(5) == ZERO)THEN + FacMax = 8.D0 + ELSE + FacMax = RCNTRL(5) + END IF +!~~~> FacRej: step decrease factor after 2 consecutive rejections + IF(RCNTRL(6) == ZERO)THEN + FacRej = 0.1d0 + ELSE + FacRej = RCNTRL(6) + END IF +!~~~> FacSafe: by which the new step is slightly smaller +! than the predicted value + IF (RCNTRL(7) == ZERO) THEN + FacSafe=0.9d0 + ELSE + FacSafe=RCNTRL(7) + END IF + IF ( (FacMax < ONE) .OR. (FacMin > ONE) .OR. & + (FacSafe <= 0.001D0) .OR. (FacSafe >= 1.0d0) ) THEN + WRITE(6,*)'RCNTRL(4:7)=',RCNTRL(4:7) + CALL RAD_ErrorMsg(-4,T,ZERO,IDID) + END IF + +!~~~> ThetaMin: decides whether the Jacobian should be recomputed + IF (RCNTRL(8) == ZERO) THEN + ThetaMin = 1.0d-3 + ELSE + ThetaMin=RCNTRL(8) + IF (ThetaMin <= 0.0d0 .OR. ThetaMin >= 1.0d0) THEN + WRITE(6,*) 'RCNTRL(8)=', RCNTRL(8) + CALL RAD_ErrorMsg(-5,T,ZERO,IDID) + END IF + END IF +!~~~> TolNewton: stopping crierion for Newton's method + IF (RCNTRL(9) == ZERO) THEN + TolNewton = 3.0d-2 + ELSE + TolNewton = RCNTRL(9) + IF (TolNewton <= Roundoff) THEN + WRITE(6,*) 'RCNTRL(9)=',RCNTRL(9) + CALL RAD_ErrorMsg(-6,T,ZERO,IDID) + END IF + END IF +!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. + IF (RCNTRL(10) == ZERO) THEN + Qmin=1.D0 + ELSE + Qmin=RCNTRL(10) + END IF + IF (RCNTRL(11) == ZERO) THEN + Qmax=1.2D0 + ELSE + Qmax=RCNTRL(11) + END IF + IF (Qmin > ONE .OR. Qmax < ONE) THEN + WRITE(6,*) 'RCNTRL(10:11)=',Qmin,Qmax + CALL RAD_ErrorMsg(-7,T,ZERO,IDID) + END IF +!~~~> Check if tolerances are reasonable + IF (ITOL == 0) THEN + IF (AbsTol(1) <= ZERO.OR.RelTol(1) <= 10.d0*Roundoff) THEN + WRITE (6,*) 'AbsTol/RelTol=',AbsTol,RelTol + CALL RAD_ErrorMsg(-8,T,ZERO,IDID) + END IF + ELSE + DO i=1,N + IF (AbsTol(i) <= ZERO.OR.RelTol(i) <= 10.d0*Roundoff) THEN + WRITE (6,*) 'AbsTol/RelTol(',i,')=',AbsTol(i),RelTol(i) + CALL RAD_ErrorMsg(-8,T,ZERO,IDID) + END IF + END DO + END IF + +!~~~> WHEN A FAIL HAS OCCURED, RETURN + IF (IDID < 0) RETURN + + +!~~~> CALL TO CORE INTEGRATOR ------------ + CALL RAD_Integrator( N,T,Y,Tend,Hmax,H,RelTol,AbsTol,ITOL,IDID, & + Max_no_steps,Roundoff,FacSafe,ThetaMin,TolNewton,Qmin,Qmax, & + NewtonMaxit,StartNewton,Gustafsson,FacMin,FacMax,FacRej ) + + ISTATUS(1)=Nfun + ISTATUS(2)=Njac + ISTATUS(3)=Nstp + ISTATUS(4)=Nacc + ISTATUS(5)=Nrej + ISTATUS(6)=Ndec + ISTATUS(7)=Nsol + ISTATUS(8)=Nsng + + ! END SUBROUTINE RADAU5 + CONTAINS ! INTERNAL PROCEDURES TO RADAU5 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_Integrator( N,T,Y,Tend,Hmax,H,RelTol,AbsTol,ITOL,IDID, & + Max_no_steps,Roundoff,FacSafe,ThetaMin,TolNewton,Qmin,Qmax, & + NewtonMaxit,StartNewton,Gustafsson,FacMin,FacMax,FacRej ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! CORE INTEGRATOR FOR RADAU5 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + INTEGER :: N + KPP_REAL Y(NVAR),Z1(NVAR),Z2(NVAR),Z3(NVAR),Y0(NVAR),& + SCAL(NVAR),F1(NVAR),F2(NVAR),F3(NVAR), & + CONT(N,4),AbsTol(NVAR),RelTol(NVAR) + +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) + DOUBLE COMPLEX :: E2(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) + DOUBLE COMPLEX :: E2(LU_NONZERO) +#endif + + !~~~> Local variables + KPP_REAL :: TMP(NVAR), T, Tend, Tdirection, & + H, Hmax, HmaxN, Hacc, Hnew, Hopt, Hold, & + Fac, FacMin, Facmax, FacSafe, FacRej, FacGus, FacConv, & + Theta, ThetaMin, TolNewton, ERR, ERRACC, & + Qmin, Qmax, DYNO, Roundoff, & + AK, AK1, AK2, AK3, C3Q, & + Qnewton, DYTH, THQ, THQOLD, DYNOLD, & + DENOM, C1Q, C2Q, ALPHA, BETA, GAMMA, CFAC, ACONT3, QT + INTEGER :: IP1(NVAR),IP2(NVAR), ITOL, IDID, Max_no_steps, & + NewtonIter, NewtonMaxit, ISING + LOGICAL :: REJECT, FirstStep, FreshJac, LastStep, & + Gustafsson, StartNewton, NewtonDone + ! KPP_REAL, PARAMETER :: ONE = 1.0d0, ZERO = 0.0d0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! INITIALISATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + CALL RAD_Coefficients + + Tdirection=SIGN(1.D0,Tend-T) + HmaxN=MIN(ABS(Hmax),ABS(Tend-T)) + H=MIN(ABS(Hmin),ABS(Hstart)) + H=MIN(ABS(H),HmaxN) + IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 + H=SIGN(H,Tdirection) + Hold=H + REJECT=.FALSE. + FirstStep=.TRUE. + LastStep=.FALSE. + FreshJac=.FALSE.; Theta=1.0d0 + IF ((T+H*1.0001D0-Tend)*Tdirection >= 0.D0) THEN + H=Tend-T + LastStep=.TRUE. + END IF + FacConv=1.D0 + CFAC=FacSafe*(1+2*NewtonMaxit) + Nsng=0 +! Told=T + CALL RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) + CALL FUN_CHEM(T,Y,Y0) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Time loop begins +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tloop: DO WHILE ( (Tend-T)*Tdirection - Roundoff > ZERO ) + + !~~~> COMPUTE JACOBIAN MATRIX ANALYTICALLY + IF ( (.NOT.FreshJac) .AND. (Theta > ThetaMin) ) THEN + CALL JAC_CHEM(T,Y,FJAC) + FreshJac=.TRUE. + END IF + + !~~~> Compute the matrices E1 and E2 and their decompositions + GAMMA = rkGamma/H + ALPHA = rkAlpha/H + BETA = rkBeta/H + CALL RAD_DecompReal(N,FJAC,GAMMA,E1,IP1,ISING) + IF (ISING /= 0) THEN + Nsng=Nsng+1 + IF (Nsng >= 5) THEN + CALL RAD_ErrorMsg(-12,T,H,IDID); RETURN + END IF + H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. + CYCLE Tloop + END IF + CALL RAD_DecompCmplx(N,FJAC,ALPHA,BETA,E2,IP2,ISING) + IF (ISING /= 0) THEN + Nsng=Nsng+1 + IF (Nsng >= 5) THEN + CALL RAD_ErrorMsg(-12,T,H,IDID); RETURN + END IF + H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. + CYCLE Tloop + END IF + + 30 CONTINUE + Nstp=Nstp+1 + IF (Nstp > Max_no_steps) THEN + PRINT*,'Max number of time steps is ',Max_no_steps + CALL RAD_ErrorMsg(-9,T,H,IDID); RETURN + END IF + IF (0.1D0*ABS(H) <= ABS(T)*Roundoff) THEN + CALL RAD_ErrorMsg(-10,T,H,IDID); RETURN + END IF + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STARTING VALUES FOR NEWTON ITERATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF ( FirstStep .OR. (.NOT.StartNewton) ) THEN + CALL Set2zero(N,Z1) + CALL Set2zero(N,Z2) + CALL Set2zero(N,Z3) + CALL Set2zero(N,F1) + CALL Set2zero(N,F2) + CALL Set2zero(N,F3) + ELSE + C3Q=H/Hold + C1Q=rkC(1)*C3Q + C2Q=rkC(2)*C3Q + DO i=1,N + AK1=CONT(i,2) + AK2=CONT(i,3) + AK3=CONT(i,4) + Z1(i)=C1Q*(AK1+(C1Q-rkC(2)+ONE)*(AK2+(C1Q-rkC(1)+ONE)*AK3)) + Z2(i)=C2Q*(AK1+(C2Q-rkC(2)+ONE)*(AK2+(C2Q-rkC(1)+ONE)*AK3)) + Z3(i)=C3Q*(AK1+(C3Q-rkC(2)+ONE)*(AK2+(C3Q-rkC(1)+ONE)*AK3)) + END DO + ! F(1,2,3) = TransfInv x Z(1,2,3) + CALL RAD_Transform(N,TransfInv,Z1,Z2,Z3,F1,F2,F3) + END IF +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! LOOP FOR THE SIMPLIFIED NEWTON ITERATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + FacConv = MAX(FacConv,Roundoff)**0.8D0 + Theta=ABS(ThetaMin) + +NewtonLoop:DO NewtonIter = 1, NewtonMaxit + + !~~~> The right-hand side + DO i=1,N + TMP(i)=Y(i)+Z1(i) + END DO + CALL FUN_CHEM(T+rkC(1)*H,TMP,Z1) + DO i=1,N + TMP(i)=Y(i)+Z2(i) + END DO + CALL FUN_CHEM(T+rkC(2)*H,TMP,Z2) + DO i=1,N + TMP(i)=Y(i)+Z3(i) + END DO + CALL FUN_CHEM(T+rkC(3)*H,TMP,Z3) + + !~~~> Solve the linear systems + ! Z(1,2,3) = TransfInv x Z(1,2,3) + CALL RAD_Transform(N,TransfInv,Z1,Z2,Z3,Z1,Z2,Z3) + CALL RAD_Solve( N,FJAC,GAMMA,ALPHA,BETA,E1,E2, & + Z1,Z2,Z3,F1,F2,F3,CONT,IP1,IP2,ISING ) + Nsol=Nsol+1 + + DYNO=0.0d0 + DO i=1,N + DENOM=SCAL(i) + DYNO=DYNO+(Z1(i)/DENOM)**2+(Z2(i)/DENOM)**2+(Z3(i)/DENOM)**2 + END DO + DYNO=SQRT(DYNO/(3*N)) + + !~~~> Bad convergence or number of iterations too large + IF ( (NewtonIter > 1) .AND. (NewtonIter < NewtonMaxit) ) THEN + THQ=DYNO/DYNOLD + IF (NewtonIter == 2) THEN + Theta=THQ + ELSE + Theta=SQRT(THQ*THQOLD) + END IF + THQOLD=THQ + IF (Theta < 0.99d0) THEN + FacConv=Theta/(1.0d0-Theta) + DYTH=FacConv*DYNO*Theta**(NewtonMaxit-1-NewtonIter)/TolNewton + IF (DYTH >= 1.0d0) THEN + Qnewton=MAX(1.0D-4,MIN(20.0d0,DYTH)) + FAC=.8D0*Qnewton**(-1.0d0/(4.0d0+NewtonMaxit-1-NewtonIter)) + H=FAC*H + REJECT=.TRUE. + LastStep=.FALSE. + CYCLE Tloop + END IF + ELSE ! Non-convergence of Newton + H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. + CYCLE Tloop + END IF + END IF + DYNOLD=MAX(DYNO,Roundoff) + CALL WAXPY(N,ONE,Z1,1,F1,1) ! F1 <- F1 + Z1 + CALL WAXPY(N,ONE,Z2,1,F2,1) ! F2 <- F2 + Z2 + CALL WAXPY(N,ONE,Z3,1,F3,1) ! F3 <- F3 + Z3 + ! Z(1,2,3) = Transf x F(1,2,3) + CALL RAD_Transform(N,Transf,F1,F2,F3,Z1,Z2,Z3) + NewtonDone = (FacConv*DYNO <= TolNewton) + IF (NewtonDone) EXIT NewtonLoop + + END DO NewtonLoop + + IF (.NOT.NewtonDone) THEN + CALL RAD_ErrorMsg(-8,T,H,IDID); + H=H*0.5D0; REJECT=.TRUE.; LastStep=.FALSE. + CYCLE Tloop + END IF + + +!~~~> ERROR ESTIMATION + CALL RAD_ErrorEstimate(N,FJAC,H,Y0,Y,T, & + E1,Z1,Z2,Z3,IP1,SCAL,ERR, & + FirstStep,REJECT,GAMMA) +!~~~> COMPUTATION OF Hnew + Fac = ERR**(-0.25d0)* & + MIN(FacSafe,(NewtonIter+2*NewtonMaxit)/CFAC) + Fac = MIN(FacMax,MAX(FacMin,Fac)) + Hnew = Fac*H + +!~~~> IS THE ERROR SMALL ENOUGH ? +accept:IF (ERR < ONE) THEN !~~~> STEP IS ACCEPTED + FirstStep=.FALSE. + Nacc=Nacc+1 + IF (Gustafsson) THEN + !~~~> Predictive controller of Gustafsson + !~~~> Currently not implemented + IF (Nacc > 1) THEN + FacGus=FacSafe*(H/Hacc)*(ERR**2/ERRACC)**(-0.25d0) + FacGus=MIN(FacMax,MAX(FacMin,FacGus)) + Fac=MIN(Fac,FacGus) + Hnew=H*Fac + END IF + Hacc=H + ERRACC=MAX(1.0D-2,ERR) + END IF + ! Told = T + Hold = H + T=T+H + DO i=1,N + Y(i)=Y(i)+Z3(i) + CONT(i,2)=(Z2(i)-Z3(i))/(rkC(2)-ONE) + AK=(Z1(i)-Z2(i))/(rkC(1)-rkC(2)) + ACONT3=Z1(i)/rkC(1) + ACONT3=(AK-ACONT3)/rkC(2) + CONT(i,3)=(AK-CONT(i,2))/(rkC(1)-ONE) + CONT(i,4)=CONT(i,3)-ACONT3 + END DO + CALL RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) + FreshJac=.FALSE. + IF (LastStep) THEN + H=Hopt + IDID=1 + RETURN + END IF + CALL FUN_CHEM(T,Y,Y0) + Hnew=Tdirection*MIN(ABS(Hnew),HmaxN) + Hopt=Hnew + Hopt=MIN(H,Hnew) + IF (REJECT) Hnew=Tdirection*MIN(ABS(Hnew),ABS(H)) + REJECT=.FALSE. + IF ((T+Hnew/Qmin-Tend)*Tdirection >= 0.D0) THEN + H=Tend-T + LastStep=.TRUE. + ELSE + QT=Hnew/H + IF ( (Theta<=ThetaMin) .AND. (QT>=Qmin) & + .AND. (QT<=Qmax) ) GOTO 30 + H=Hnew + END IF + CYCLE Tloop + ELSE accept !~~~> STEP IS REJECTED + REJECT=.TRUE. + LastStep=.FALSE. + IF (FirstStep) THEN + H=H*FacRej + ELSE + H=Hnew + END IF + IF (Nacc >= 1) Nrej=Nrej+1 + CYCLE Tloop + END IF accept + + + END DO Tloop + + + END SUBROUTINE RAD_Integrator + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from RADAU5 due to the following error:' + IF ((Code>=-11).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE RAD_ErrorMsg + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_ErrorScale(N,ITOL,AbsTol,RelTol,Y,SCAL) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER, INTENT(IN) :: N, ITOL + KPP_REAL, INTENT(IN) :: AbsTol(*), RelTol(*), Y(N) + KPP_REAL, INTENT(OUT) :: SCAL(N) + INTEGER :: i + + IF (ITOL==0) THEN + DO i=1,N + SCAL(i)=AbsTol(1)+RelTol(1)*ABS(Y(i)) + END DO + ELSE + DO i=1,N + SCAL(i)=AbsTol(i)+RelTol(i)*ABS(Y(i)) + END DO + END IF + + END SUBROUTINE RAD_ErrorScale + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_Transform(N,Tr,Z1,Z2,Z3,F1,F2,F3) +!~~~> F = Tr x Z +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: N, i + KPP_REAL :: Tr(3,3),Z1(N),Z2(N),Z3(N),F1(N),F2(N),F3(N) + KPP_REAL :: x1, x2, x3 + DO i=1,N + x1 = Z1(i); x2 = Z2(i); x3 = Z3(i) + F1(i) = Tr(1,1)*x1 + Tr(1,2)*x2 + Tr(1,3)*x3 + F2(i) = Tr(2,1)*x1 + Tr(2,2)*x2 + Tr(2,3)*x3 + F3(i) = Tr(3,1)*x1 + Tr(3,2)*x2 + Tr(3,3)*x3 + END DO + END SUBROUTINE RAD_Transform + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_Coefficients +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + KPP_REAL :: s2,s3,s6,x1,x2,x3,x4,y1,y2,y3,y4,y5 + + s2 = SQRT(2.0d0); + s3 = SQRT(3.0d0); + s6 = SQRT(6.0d0); + x1 = 3.d0**(1.d0/3.d0); + x2 = 3.d0**(2.d0/3.d0); + x3 = 3.d0**(1.d0/6.d0); + x4 = 3.d0**(5.d0/6.d0); + + rkA(1,1) = 11.d0/45.d0-7.d0/360.d0*s6 + rkA(1,2) = 37.d0/225.d0-169.d0/1800.d0*s6 + rkA(1,3) = -2.d0/225.d0+s6/75 + rkA(2,1) = 37.d0/225.d0+169.d0/1800.d0*s6 + rkA(2,2) = 11.d0/45.d0+7.d0/360.d0*s6 + rkA(2,3) = -2.d0/225.d0-s6/75 + rkA(3,1) = 4.d0/9.d0-s6/36 + rkA(3,2) = 4.d0/9.d0+s6/36 + rkA(3,3) = 1.d0/9.d0 + + rkB(1) = 4.d0/9.d0-s6/36 + rkB(2) = 4.d0/9.d0+s6/36 + rkB(3) = 1.d0/9.d0 + + rkC(1) = 2.d0/5.d0-s6/10 + rkC(2) = 2.d0/5.d0+s6/10 + rkC(3) = 1.d0 + + ! Error estimation + rkE(1) = -(13.d0+7.d0*s6)/3.d0 + rkE(2) = (-13.d0+7.d0*s6)/3.d0 + rkE(3) = -1.d0/3.d0 + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + !~~~> Diagonalize the RK matrix: + ! TransfInv * inv(rkA) * Transf = + ! | rkGamma 0 0 | + ! | 0 rkAlpha -rkBeta | + ! | 0 rkBeta rkAlpha | + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + rkGamma = 3-x1+x2 + rkAlpha = x1/2-x2/2+3 + rkBeta = -x4/2-3.d0/2.d0*x3 + + y1 = 36.d0/625.d0*s6 + y2 = 129.d0/2500.d0*x1 + y3 = 111.d0/2500.d0*x3*s2 + Transf(1,1) = -31.d0/1250.d0*s6*x1+37.d0/1250.d0*s6*x2-y1 & + +129.d0/1250.d0*x1-33.d0/1250.d0*x2+49.d0/625.d0 + Transf(1,2) = -y1-y2-y3 & + +31.d0/2500.d0*x4*s2+33.d0/2500.d0*x2+49.d0/625.d0 + Transf(1,3) = 3.d0/2500.d0*x3*(-33-43*x2+31*x3*s2+37*s3*s2) + Transf(2,1) = 31.d0/1250.d0*s6*x1-37.d0/1250.d0*s6*x2+y1 & + +129.d0/1250.d0*x1-33.d0/1250.d0*x2+49.d0/625.d0 + Transf(2,2) = y1-y2+y3& + -31.d0/2500.d0*x4*s2+33.d0/2500.d0*x2+49.d0/625.d0 + Transf(2,3) = -3.d0/2500.d0*x3*(33+43*x2+31*x3*s2+37*s3*s2) + Transf(3,1) = 1.d0 + Transf(3,2) = 1.d0 + Transf(3,3) = 0.d0 + + y1 = 11.d0/36.d0*x3*s2 + 43.d0/108.d0*x4*s2 + y2 = 11.d0/36.d0*s2*x2 - 43.d0/36.d0*s2*x1 + y3 = 31.d0/54.d0*x1 + 37.d0/54.d0*x2 + y4 = 31.d0/54.d0*x4-37.d0/18.d0*x3 + y5 = -x2/27+5.d0/27.d0*x1 + TransfInv(1,1) = y1 + y3 + TransfInv(1,2) = -y1 + y3 + TransfInv(1,3) = y5 + 1.d0/3.d0 + TransfInv(2,1) = -y1 - y3 + TransfInv(2,2) = y1 - y3 + TransfInv(2,3) = -y5 + 2.d0/3.d0 + TransfInv(3,1) = y4 - y2 + TransfInv(3,2) = y4 + y2 + TransfInv(3,3) = x3/9+5.d0/27.d0*x4 + + END SUBROUTINE RAD_Coefficients + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_DecompReal(N,FJAC,GAMMA,E1,IP1,ISING) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + + INTEGER :: N, ISING + KPP_REAL :: GAMMA +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR),E1(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO),E1(LU_NONZERO) +#endif + INTEGER :: IP1(N), i, j + +#ifdef FULL_ALGEBRA + DO j=1,N + DO i=1,N + E1(i,j)=-FJAC(i,j) + END DO + E1(j,j)=E1(j,j)+GAMMA + END DO + CALL DGETRF(N,N,E1,N,IP1,ISING) +#else + DO i=1,LU_NONZERO + E1(i)=-FJAC(i) + END DO + DO i=1,NVAR + j = LU_DIAG(i); E1(j)=E1(j)+GAMMA + END DO + CALL KppDecomp(E1,ISING) +#endif + + END SUBROUTINE RAD_DecompReal + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_DecompCmplx(N,FJAC,ALPHA,BETA,E2,IP2,ISING) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: N, ISING +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(N,N) + DOUBLE COMPLEX :: E2(N,N) +#else + KPP_REAL :: FJAC(LU_NONZERO) + DOUBLE COMPLEX :: E2(LU_NONZERO) +#endif + KPP_REAL :: ALPHA, BETA + INTEGER :: IP2(N), i, j + +#ifdef FULL_ALGEBRA + DO j=1,N + DO i=1,N + E2(i,j) = DCMPLX( -FJAC(i,j), 0.0d0 ) + END DO + E2(j,j) = E2(j,j) + DCMPLX( ALPHA, BETA ) + END DO + CALL ZGETRF(N,N,E2,N,IP2,ISING) +#else + DO i=1,LU_NONZERO + E2(i) = DCMPLX( -FJAC(i), 0.0d0 ) + END DO + DO i=1,NVAR + j = LU_DIAG(i); E2(j)=E2(j)+DCMPLX( ALPHA, BETA ) + END DO + CALL KppDecompCmplx(E2,ISING) +#endif + Ndec=Ndec+1 + + END SUBROUTINE RAD_DecompCmplx + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_Solve(N,FJAC,GAMMA,ALPHA,BETA,E1,E2,& + Z1,Z2,Z3,F1,F2,F3,CONT,IP1,IP2,ISING) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: N,IP1(NVAR),IP2(NVAR),ISING +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) + DOUBLE COMPLEX :: E2(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) + DOUBLE COMPLEX :: E2(LU_NONZERO) +#endif + KPP_REAL :: Z1(N),Z2(N),Z3(N), & + F1(N),F2(N),F3(N),CONT(N), & + GAMMA,ALPHA,BETA + DOUBLE COMPLEX :: BC(N) + INTEGER :: i,j + KPP_REAL :: S2, S3 +! + DO i=1,N + S2=-F2(i) + S3=-F3(i) + Z1(i)=Z1(i)-F1(i)*GAMMA + Z2(i)=Z2(i)+S2*ALPHA-S3*BETA + Z3(i)=Z3(i)+S3*ALPHA+S2*BETA + END DO +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E1,N,IP1,Z1,N,0) +#else + CALL KppSolve (E1,Z1) +#endif + + DO j=1,N + BC(j) = DCMPLX(Z2(j),Z3(j)) + END DO +#ifdef FULL_ALGEBRA + CALL ZGETRS ('N',N,1,E2,N,IP2,BC,N,0) +#else + CALL KppSolveCmplx (E2,BC) +#endif + DO j=1,N + Z2(j) = DBLE( BC(j) ) + Z3(j) = AIMAG( BC(j) ) + END DO + + END SUBROUTINE RAD_Solve + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RAD_ErrorEstimate(N,FJAC,H,Y0,Y,T,& + E1,Z1,Z2,Z3,IP1,SCAL,ERR, & + FirstStep,REJECT,GAMMA) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + + INTEGER :: N +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR), E1(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO), E1(LU_NONZERO) +#endif + KPP_REAL :: SCAL(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N), & + Y0(N),Y(N),TMP(N),T,H,GAMMA + INTEGER :: IP1(N), i + LOGICAL FirstStep,REJECT + KPP_REAL :: HEE1,HEE2,HEE3,ERR + + HEE1 = rkE(1)/H + HEE2 = rkE(2)/H + HEE3 = rkE(3)/H + + DO i=1,N + F2(i)=HEE1*Z1(i)+HEE2*Z2(i)+HEE3*Z3(i) + TMP(i)=F2(i)+Y0(i) + END DO + +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) +#else + CALL KppSolve (E1, TMP) +#endif + + ERR=0.D0 + DO i=1,N + ERR=ERR+(TMP(i)/SCAL(i))**2 + END DO + ERR=MAX(SQRT(ERR/N),1.D-10) +! + IF (ERR < 1.D0) RETURN +firej:IF (FirstStep.OR.REJECT) THEN + DO i=1,N + TMP(i)=Y(i)+TMP(i) + END DO + CALL FUN_CHEM(T,TMP,F1) + DO i=1,N + TMP(i)=F1(i)+F2(i) + END DO + +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E1,N,IP1,TMP,N,0) +#else + CALL KppSolve (E1, TMP) +#endif + ERR=0.D0 + DO i=1,N + ERR=ERR+(TMP(i)/SCAL(i))**2 + END DO + ERR=MAX(SQRT(ERR/N),1.0d-10) + END IF firej + + END SUBROUTINE RAD_ErrorEstimate + +!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! KPP_REAL FUNCTION CONTR5(I,N,T,CONT) +!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!! THIS FUNCTION CAN BE USED FOR CONTINUOUS OUTPUT. IT PROVIDES AN +!! APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION AT T. +!! IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR +!! THE STEP SUCCESSFULLY COMPUTED STEP (BY RADAU5). +!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! IMPLICIT NONE +! INTEGER :: I, N +! KPP_REAL :: T, CONT(N,4) +! KPP_REAL :: S +! KPP_REAL, PARAMETER :: ONE = 1.0d0 +! S=(T-Tsol)/Hsol +! CONTR5=CONT(i,1)+S* & +! (CONT(i,2)+(S-rkC(2)+ONE)*(CONT(i,3)+(S-rkC(1)+ONE)*CONT(i,4))) +! END FUNCTION CONTR5 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + END SUBROUTINE RADAU5 ! AND ALL ITS INTERNAL PROCEDURES +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE FUN_CHEM(T, V, FCT) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Function, ONLY: Fun + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), FCT(NVAR) + KPP_REAL :: T, Told + + !Told = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = Told + + CALL Fun(V, FIX, RCONST, FCT) + + Nfun=Nfun+1 + + END SUBROUTINE FUN_CHEM + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE JAC_CHEM (T, V, JF) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_JacobianSP + USE KPP_ROOT_Jacobian, ONLY: Jac_SP + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), T, Told +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), JF(NVAR,NVAR) + INTEGER :: i, j +#else + KPP_REAL :: JF(LU_NONZERO) +#endif + + !Told = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = Told + +#ifdef FULL_ALGEBRA + CALL Jac_SP(V, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + JF(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + JF(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP(V, FIX, RCONST, JF) +#endif + + Njac=Njac+1 + + END SUBROUTINE JAC_CHEM + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.def new file mode 100755 index 00000000..6238cd70 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.def @@ -0,0 +1,20 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_sdirk + +#INLINE F77_GLOBAL + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f new file mode 100755 index 00000000..e04fe7d9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f @@ -0,0 +1,705 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + INTEGER i + + PARAMETER (LWORK=2*NVAR*NVAR+12*NVAR+7,LIWORK=2*NVAR+7) + PARAMETER (LRCONT=5*NVAR+2) + + KPP_REAL WORK(LWORK) + INTEGER IWORK(LIWORK) + COMMON /CONT/ ICONT(4),RCONT(LRCONT) + EXTERNAL FUNC_CHEM,JAC_CHEM + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + + IWORK(3) = 8 + + CALL ATMSDIRK(NVAR,FUNC_CHEM,TIN,VAR,TOUT,STEPMIN, + & RTOL,ATOL,ITOL, + & JAC_CHEM ,IJAC, FUNC_CHEM ,IMAS, + & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) + + IF (IDID.LT.0) THEN + print *,'ATMSDIRK: Unsucessfull exit at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + RETURN + END + + + SUBROUTINE ATMSDIRK(N,FCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC, MAS ,IMAS, + & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) +C ---------------------------------------------------------- +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C DECLARATIONS +C *** *** *** *** *** *** *** *** *** *** *** *** *** + IMPLICIT KPP_REAL (A-H,O-Z) + DIMENSION Y(N),AbsTol(1),RelTol(1),WORK(LWORK),IWORK(LIWORK) + LOGICAL IMPLCT,JBAND,ARRET + EXTERNAL FCN,JAC,MAS + COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL + +C *** *** *** *** *** *** *** +C SETTING THE PARAMETERS +C *** *** *** *** *** *** *** + NFCN=0 + NJAC=0 + NSTEP=0 + NACCPT=0 + NREJCT=0 + NDEC=0 + NSOL=0 + ARRET=.FALSE. +C -------- SWITCH FOR TRANSFORMATION OF JACOBIAN TO HESS_CHEM FORM --- + NHESS1 = 0 ! ADRIAN +C -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- + IF(IWORK(2).EQ.0)THEN + NMAX=100000 + ELSE + NMAX=IWORK(2) + IF(NMAX.LE.0)THEN + WRITE(6,*)' WRONG INPUT IWORK(2)=',IWORK(2) + ARRET=.TRUE. + END IF + END IF +C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS + IF(IWORK(3).EQ.0)THEN + NIT=8 + ELSE + NIT=IWORK(3) + IF(NIT.LE.0)THEN + WRITE(6,*)' CURIOUS INPUT IWORK(3)=',IWORK(3) + ARRET=.TRUE. + END IF + END IF +C -------- METH SWITCH FOR THE COEFFICIENTS OF THE METHOD + METH = 2 +C -------- UROUND SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0 + IF(WORK(1).EQ.0.D0)THEN + UROUND=1.D-16 + ELSE + UROUND=WORK(1) + IF(UROUND.LE.1.D-19.OR.UROUND.GE.1.D0)THEN + WRITE(6,*)' COEFFICIENTS HAVE 20 DIGITS, UROUND=',WORK(1) + ARRET=.TRUE. + END IF + END IF +C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION + IF(WORK(2).EQ.0.D0)THEN + SAFE=0.9D0 + ELSE + SAFE=WORK(2) + IF(SAFE.LE..001D0.OR.SAFE.GE.1.D0)THEN + WRITE(6,*)' CURIOUS INPUT FOR WORK(2)=',WORK(2) + ARRET=.TRUE. + END IF + END IF +C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; + IF(WORK(3).EQ.0.D0)THEN + THET=0.001D0 + ELSE + THET=WORK(3) + END IF +C --- FNEWT STOPPING CRIERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. + IF(WORK(4).EQ.0.D0)THEN + FNEWT=0.03D0 + ELSE + FNEWT=WORK(4) + END IF +C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. + IF(WORK(5).EQ.0.D0)THEN + QUOT1=1.D0 + ELSE + QUOT1=WORK(5) + END IF + IF(WORK(6).EQ.0.D0)THEN + QUOT2=1.2D0 + ELSE + QUOT2=WORK(6) + END IF +C -------- MAXIMAL STEP SIZE + IF(WORK(7).EQ.0.D0)THEN + HMAX=XEND-X + ELSE + HMAX=WORK(7) + END IF +C --------- CHECK IF TOLERANCES ARE O.K. + IF (ITOL.EQ.0) THEN + IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES ARE TOO SMALL' + ARRET=.TRUE. + END IF + ELSE + DO 15 I=1,N + IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL' + ARRET=.TRUE. + END IF + 15 CONTINUE + END IF + +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C COMPUTATION OF ARRAY ENTRIES +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C ---- IMPLICIT, BANDED OR NOT ? + IMPLCT=IMAS.NE.0 + ARRET=.FALSE. +C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- +C -- JACOBIAN + LDJAC=N +C -- MATRIX E FOR LINEAR ALGEBRA + LDE=N +C -- MASS MATRIX + IF (IMPLCT) THEN + print *,'IMPLCT 1' + ELSE + LDMAS=0 + END IF + LDMAS2=MAX(1,LDMAS) + +C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- + IEYHAT=8 + IEZ=IEYHAT+N + IEY0=IEZ+N + IEZ1=IEY0+N + IEZ2=IEZ1+N + IEZ3=IEZ2+N + IEZ4=IEZ3+N + IEZ5=IEZ4+N + IESCAL=IEZ5+N + IEF1=IESCAL+N + IEG1=IEF1+N + IEH1=IEG1+N + IEJAC=IEH1+N + IEMAS=IEJAC+N*LDJAC + IEE=IEMAS+N*LDMAS + +C ------ TOTAL STORAGE REQUIREMENT ----------- + ISTORE=IEE+N*LDE-1 + IF(ISTORE.GT.LWORK)THEN + WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE + ARRET=.TRUE. + END IF +C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- + IEIP=5 + IEHES=IEIP+N +C --------- TOTAL REQUIREMENT --------------- + ISTORE=IEHES+N-1 + IF(ISTORE.GT.LIWORK)THEN + WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE + ARRET=.TRUE. + END IF +C --------- CONTROL OF LENGTH OF COMMON BLOCK "CONT" ------- + IF(LRCONT.LT.(5*N+2))THEN + WRITE(6,*)' INSUFF. STORAGE FOR RCONT, MIN. LRCONT=',5*N+2 + ARRET=.TRUE. + END IF +C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 + IF (ARRET) THEN + IDID=-1 + RETURN + END IF +C -------- CALL TO CORE INTEGRATOR ------------ + CALL SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, + & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, + & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, + & IMPLCT,JBAND,LDJAC,LDE,LDMAS2, + & WORK(IEYHAT),WORK(IEZ),WORK(IEY0),WORK(IEZ1),WORK(IEZ2), + & WORK(IEZ3),WORK(IEZ4),WORK(IEZ5),WORK(IESCAL),WORK(IEF1), + & WORK(IEG1),WORK(IEH1),WORK(IEJAC),WORK(IEE), + & WORK(IEMAS),IWORK(IEIP),IWORK(IEHES)) +C ----------- RETURN ----------- + RETURN + END +C +C +C +C ----- ... AND HERE IS THE CORE INTEGRATOR ---------- +C + SUBROUTINE SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, + & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, + & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, + & IMPLCT,BANDED,LDJAC,LE,LDMAS, + & YHAT,Z,Y0,Z1,Z2,Z3,Z4,Z5,SCAL,F1,G1,H1,FJAC,E,FMAS,IP,IPHES) +C ---------------------------------------------------------- +C CORE INTEGRATOR FOR SDIRK4 +C PARAMETERS SAME AS IN SDIRK4 WITH WORKSPACE ADDED +C ---------------------------------------------------------- +C DECLARATIONS +C ---------------------------------------------------------- + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + KPP_REAL Y(N),YHAT(N),Z(N),Y0(N),Z1(N),Z2(N),Z3(N),Z4(N),Z5(N) + KPP_REAL SCAL(N),F1(N),G1(N),H1(N) + KPP_REAL FJAC(LU_NONZERO),E(LU_NONZERO),FMAS(LDMAS,N) + KPP_REAL AbsTol(1),RelTol(1) + INTEGER IP(N),IPHES(N) + LOGICAL REJECT,FIRST,IMPLCT,BANDED,CALJAC,NEWTRE + COMMON /CONT/NN,NN2,NN3,NN4,XOLD,HSOL,CONT(5*NVAR) + COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL + EXTERNAL MAS, FCN, JAC + +C *** *** *** *** *** *** *** +C INITIALISATIONS +C *** *** *** *** *** *** *** + +C --------- DUPLIFY N FOR COMMON BLOCK CONT ----- + NN=N + NN2=2*N + NN3=3*N + NN4=4*N + +C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- + IF(IMPLCT) CALL MAS(N,FMAS,LDMAS) + +C ---------- CONSTANTS --------- + MBDIAG=MUMAS+1 + IF (METH.EQ.2) THEN +C ---------- METHOD WITH GAMMA = 4/15 --------------- + GAMMA=4.0D0/15.0D0 + C2=23.0D0/30.0D0 + C3=17.0D0/30.0D0 + C4=2881.0D0/28965.0D0+GAMMA + ALPH21=15.0D0/8.0D0 + ALPH31=1577061.0D0/922880.0D0 + ALPH32=-23427.0D0/115360.0D0 + ALPH41=647163682356923881.0D0/2414496535205978880.0D0 + ALPH42=-593512117011179.0D0/3245291041943520.0D0 + ALPH43=559907973726451.0D0/1886325418129671.0D0 + ALPH51=724545451.0D0/796538880.0D0 + ALPH52=-830832077.0D0/267298560.0D0 + ALPH53=30957577.0D0/2509272.0D0 + ALPH54=-69863904375173.0D0/6212571137048.0D0 + E1=7752107607.0D0/11393456128.0D0 + E2=-17881415427.0D0/11470078208.0D0 + E3=2433277665.0D0/179459416.0D0 + E4=-96203066666797.0D0/6212571137048.0D0 + D11= 24.74416644927758D0 + D12= -4.325375951824688D0 + D13= 41.39683763286316D0 + D14= -61.04144619901784D0 + D15= -3.391332232917013D0 + D21= -51.98245719616925D0 + D22= 10.52501981094525D0 + D23= -154.2067922191855D0 + D24= 214.3082125319825D0 + D25= 14.71166018088679D0 + D31= 33.14347947522142D0 + D32= -19.72986789558523D0 + D33= 230.4878502285804D0 + D34= -287.6629744338197D0 + D35= -18.99932366302254D0 + D41= -5.905188728329743D0 + D42= 13.53022403646467D0 + D43= -117.6778956422581D0 + D44= 134.3962081008550D0 + D45= 8.678995715052762D0 + ETA1=23.D0/8.D0 + ANU1= 0.9838473040915402D0 + ANU2= 0.3969226768377252D0 + AMU1= 0.6563374010466914D0 + AMU3= 0.3372498196189311D0 + ELSE + PRINT *, 'WRONG CHOICE OF ' + END IF + POSNEG=SIGN(1.D0,XEND-X) + HMAX1=MIN(ABS(HMAX),ABS(XEND-X)) + IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 + H=MIN(ABS(H),HMAX1) + H=SIGN(H,POSNEG) + HOLD=H + CFAC=SAFE*(1+2*NIT) + NEWTRE=.FALSE. + REJECT=.FALSE. + FIRST=.TRUE. + FACCO1=1.D0 + FACCO2=1.D0 + FACCO3=1.D0 + FACCO4=1.D0 + FACCO5=1.D0 + NSING=0 + XOLD=X + IF (ITOL.EQ.0) THEN + DO 8 I=1,N + 8 SCAL(I)=1.D0 / ( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) + ELSE + DO 9 I=1,N + 9 SCAL(I)=1.D0 / ( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) + END IF + +C --- BASIC INTEGRATION STEP + 10 CONTINUE + +C *** *** *** *** *** *** *** +C COMPUTATION OF THE JACOBIAN +C *** *** *** *** *** *** *** + NJAC=NJAC+1 + CALL JAC(N,X,Y,FJAC) + CALJAC=.TRUE. + 20 CONTINUE + +C *** *** *** *** *** *** *** +C COMPUTE THE MATRIX E AND ITS DECOMPOSITION +C *** *** *** *** *** *** *** + FAC1=1.D0/(H*GAMMA) + IF (IMPLCT) THEN + print *, 'IMPLCT 4' + ELSE ! EXPLICIT SYSTEM +C --- THE MATRIX E (MAS=IDENTITY, JACOBIAN A FULL MATRIX) +c DO 526 J=1,N +c DO 525 I=1,N +c 525 E(I,J)=-FJAC(I,J) +c 526 E(J,J)=E(J,J)+FAC1 +c CALL DEC(N,LE,E,IP,IER) + DO K=1,LU_NONZERO + E(K) = -FJAC(K) + END DO + DO I=1,N + IDG = LU_DIAG(I) + E(IDG) = E(IDG) + FAC1 + END DO + CALL KppDecomp ( E, IER) + + IF (IER.NE.0) GOTO 79 + END IF + NDEC=NDEC+1 + 30 CONTINUE + + IF (NSTEP.GT.NMAX.OR.X+.1D0*H.EQ.X.OR.ABS(H).LE.UROUND) GOTO 79 + XPH=X+H +C --- LOOP FOR THE 5 STAGES + FACCO1=DMAX1(FACCO1,UROUND)**0.8D0 + FACCO2=DMAX1(FACCO2,UROUND)**0.8D0 + FACCO3=DMAX1(FACCO3,UROUND)**0.8D0 + FACCO4=DMAX1(FACCO4,UROUND)**0.8D0 + FACCO5=DMAX1(FACCO5,UROUND)**0.8D0 + +C *** *** *** *** *** *** *** +C STARTING VALUES FOR NEWTON ITERATION +C *** *** *** *** *** *** *** + DO 59 ISTAGE=1,5 + IF (ISTAGE.EQ.1) THEN + XCH=X+GAMMA*H + IF (FIRST.OR.NEWTRE) THEN + DO 132 I=1,N + 132 Z(I)=0.D0 + ELSE + S=1.D0+GAMMA*H/HOLD + DO 232 I=1,N +c 232 Z(I) = 0.D0 + 232 Z(I)=S*(CONT(I+NN)+S*(CONT(I+NN2)+S*(CONT(I+NN3) + & +S*CONT(I+NN4))))-YHAT(I) + + END IF + DO 31 I=1,N + 31 G1(I)=0.D0 + FACCON=FACCO1 + END IF + IF (ISTAGE.EQ.2) THEN + XCH=X+C2*H + DO 131 I=1,N + Z1I=Z1(I) + Z(I)=ETA1*Z1I + 131 G1(I)=ALPH21*Z1I + FACCON=FACCO2 + END IF + IF (ISTAGE.EQ.3) THEN + XCH=X+C3*H + DO 231 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z(I)=ANU1*Z1I+ANU2*Z2I + 231 G1(I)=ALPH31*Z1I+ALPH32*Z2I + FACCON=FACCO3 + END IF + IF (ISTAGE.EQ.4) THEN + XCH=X+C4*H + DO 331 I=1,N + Z1I=Z1(I) + Z3I=Z3(I) + Z(I)=AMU1*Z1I+AMU3*Z3I + 331 G1(I)=ALPH41*Z1I+ALPH42*Z2(I)+ALPH43*Z3I + FACCON=FACCO4 + END IF + IF (ISTAGE.EQ.5) THEN + XCH=XPH + DO 431 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z3I=Z3(I) + Z4I=Z4(I) + Z(I)=E1*Z1I+E2*Z2I+E3*Z3I+E4*Z4I + YHAT(I)=Z(I) + 431 G1(I)=ALPH51*Z1I+ALPH52*Z2I+ALPH53*Z3I+ALPH54*Z4I + FACCON=FACCO5 + END IF + + + +C *** *** *** *** *** *** *** *** *** *** *** +C LOOP FOR THE SIMPLIFIED NEWTON ITERATION +C *** *** *** *** *** *** *** *** *** *** *** + NEWT=0 + THETA=ABS(THET) + IF (REJECT) THETA=2*ABS(THET) + 40 CONTINUE + IF (NEWT.GE.NIT) THEN + H=H/2.D0 + REJECT=.TRUE. + NEWTRE=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + +C --- COMPUTE THE RIGHT-HAND SIDE + DO 41 I=1,N + H1(I)=G1(I)-Z(I) + 41 CONT(I)=Y(I)+Z(I) + CALL FCN(N,XCH,CONT,F1) + NFCN=NFCN+1 + +C --- KppSolve THE LINEAR SYSTEMS + IF (IMPLCT) THEN + print *, 'IMPLCT 2' + ELSE + DO 345 I=1,N + 345 F1(I)=H1(I)*FAC1+F1(I) +C CALL SOL(N,LE,E,F1,IP) + CALL KppSolve(E, F1) + END IF + NEWT=NEWT+1 + DYNO=0.D0 +C --- NORM 2 --- + DO 57 I=1,N + 57 DYNO=DYNO+(F1(I)*SCAL(I))**2 + DYNO=DSQRT(DYNO/N) +C --- NORM INF --- +C DO 57 I=1,N +C 57 DYNO=DMAX1( DYNO, DABS(F1(I)*SCAL(I)) ) + + +C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE + IF (NEWT.GE.2.AND.NEWT.LT.NIT) THEN + THETA=DYNO/DYNOLD + IF (THETA.LT.0.99D0) THEN + FACCON=THETA/(1.0D0-THETA) + DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT) + QNEWT=DMAX1(1.0D-4,DMIN1(16.0D0,DYTH/FNEWT)) + IF (QNEWT.GE.1.0D0) THEN + H=.8D0*H*QNEWT**(-1.0D0/(NIT-NEWT)) + REJECT=.TRUE. + NEWTRE=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + ELSE + NEWTRE=.TRUE. + GOTO 78 + END IF + END IF + DYNOLD=DYNO + DO 58 I=1,N + 58 Z(I)=Z(I)+F1(I) + NSOL=NSOL+1 + IF (FACCON*DYNO.GT.FNEWT) GOTO 40 + +C --- END OF SIMPILFIED NEWTON + IF (ISTAGE.EQ.1) THEN + DO I=1,N + Z1(I) = Z(I) + END DO + FACCO1=FACCON + END IF + IF (ISTAGE.EQ.2) THEN + DO I=1,N + Z2(I) = Z(I) + END DO + FACCO2=FACCON + END IF + IF (ISTAGE.EQ.3) THEN + DO I=1,N + Z3(I) = Z(I) + END DO + FACCO3=FACCON + END IF + IF (ISTAGE.EQ.4) THEN + DO I=1,N + Z4(I) = Z(I) + END DO + FACCO4=FACCON + END IF + IF (ISTAGE.EQ.5) THEN + DO I=1,N + Z5(I) = Z(I) + END DO + FACCO5=FACCON + END IF + 59 CONTINUE + + +C *** *** *** *** *** *** *** +C ERROR ESTIMATION +C *** *** *** *** *** *** *** + NSTEP=NSTEP+1 + IF (IMPLCT) THEN + print *,'IMPLCT 3' + ELSE + DO 461 I=1,N + 461 CONT(I)=FAC1*(Z5(I)-YHAT(I)) + END IF + + CALL KppSolve(E, CONT) + + ERR=0.D0 +C ---- NORM 2 --- + DO 64 I=1,N + 64 ERR=ERR+(CONT(I)*SCAL(I))**2 + ERR=DMAX1(DSQRT(ERR/N),1.D-10) + +C ---- NORM INF --- +C DO 64 I=1,N +c 64 ERR=DMAX1( ERR, DABS( CONT(I)*SCAL(I) ) ) + +C --- COMPUTATION OF HNEW +C --- WE REQUIRE .25<=HNEW/H<=10. + FAC=DMIN1(SAFE,CFAC/(NEWT+2*NIT)) + QUOT=DMAX1(.25D0,DMIN1(10.D0,(ERR)**.25D0/FAC)) + HNEW= H/QUOT + +C *** *** *** *** *** *** *** +C IS THE ERROR SMALL ENOUGH ? +C *** *** *** *** *** *** *** + IF (ERR.LT.1.D0) THEN +C --- STEP IS ACCEPTED + FIRST=.FALSE. + NACCPT=NACCPT+1 + HOLD=H + XOLD=X +C --- COEFFICIENTS FOR CONTINUOUS SOLUTION + DO 74 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z3I=Z3(I) + Z4I=Z4(I) + Z5I=Z5(I) + CONT(I)=Y(I) + Y(I)=Y(I)+Z5I + CONT(I+NN) =D11*Z1I+D12*Z2I+D13*Z3I+D14*Z4I+D15*Z5I + CONT(I+NN2)=D21*Z1I+D22*Z2I+D23*Z3I+D24*Z4I+D25*Z5I + CONT(I+NN3)=D31*Z1I+D32*Z2I+D33*Z3I+D34*Z4I+D35*Z5I + CONT(I+NN4)=D41*Z1I+D42*Z2I+D43*Z3I+D44*Z4I+D45*Z5I + YHAT(I)=Z5I + IF (ITOL.EQ.0) THEN + SCAL(I)=1.D0/( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) + ELSE + SCAL(I)=1.D0/( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) + END IF + 74 CONTINUE + X=XPH + CALJAC=.FALSE. + IF ((X-XEND)*POSNEG+UROUND.GT.0.D0) THEN + H=HOPT + IDID=1 + RETURN + END IF + IF (IJAC.EQ.0) CALL FCN(N,X,Y,Y0) + NFCN=NFCN+1 + HNEW=POSNEG*DMIN1(DABS(HNEW),HMAX1) + HOPT=HNEW + IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) + REJECT=.FALSE. + NEWTRE=.FALSE. + IF ((X+HNEW/QUOT1-XEND)*POSNEG.GT.0.D0) THEN + H=XEND-X + ELSE + QT=HNEW/H + IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 + H = HNEW + END IF + IF (THETA.LE.THET) GOTO 20 + GOTO 10 + + ELSE +C --- STEP IS REJECTED + REJECT=.TRUE. + IF (FIRST) THEN + H=H/10.D0 + ELSE + H=HNEW + END IF + IF (NACCPT.GE.1) NREJCT=NREJCT+1 + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + +C --- UNEXPECTED STEP-REJECTION + 78 CONTINUE + IF (IER.NE.0) THEN + WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' X=',X,' H=',H + NSING=NSING+1 + IF (NSING.GE.6) GOTO 79 + END IF + H=H*0.5D0 + REJECT=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + +C --- FAIL EXIT + 79 WRITE (6,979) X,H,IER + 979 FORMAT(' EXIT OF SDIRK4 AT X=',D14.7,' H=',D14.7,' IER=',I4) + IDID=-1 + RETURN + END +C + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f90 new file mode 100755 index 00000000..19384f72 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_sdirk.f90 @@ -0,0 +1,965 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! SDIRK - Singly-Diagonally-Implicit Runge-Kutta method ! +! (L-stable, 5 stages, order 4) ! +! By default the code employs the KPP sparse linear algebra routines ! +! Compile with -DFULL_ALGEBRA to use full linear algebra (LAPACK) ! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! A. Sandu - version of July 10, 2005 + +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision + USE KPP_ROOT_Global, ONLY: FIX, RCONST, TIME + USE KPP_ROOT_Parameters, ONLY: NVAR, NSPEC, NFIX, LU_NONZERO + USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG + USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve, & + Set2zero, WLAMCH, WAXPY, WCOPY + + IMPLICIT NONE + PUBLIC + SAVE + + !~~~> Statistics on the work performed by the SDIRK method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + ! SDIRK method coefficients + KPP_REAL :: rkAlpha(5,4), rkBeta(5,4), rkD(4,5), & + rkGamma, rkA(5,5), rkB(5), rkC(5) + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small: T + 10*H = T or H < Roundoff ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Improper value for maximal no of Newton iterations', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE INTEGRATE( TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + IMPLICIT NONE + + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + !INTEGER, SAVE :: Ntotal = 0 + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20), IERR + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL SDIRK( NVAR,TIN,TOUT,VAR,RTOL,ATOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + +! mz_rs_20050716: IERR and ISTATUS(istp) are returned to the user who then +! decides what to do about it, i.e. either stop the run or ignore it. +!!$ IF (IERR < 0) THEN +!!$ PRINT *,'SDIRK: Unsuccessful exit at T=',TIN,' (IERR=',IERR,')' +!!$ ENDIF +!!$ Ntotal = Ntotal + Nstp +!!$ PRINT*,'NSTEPS=',Nstp, '(',Ntotal,')' + + STEPMIN = RSTATUS(ihexit) ! Save last step + + ! if optional parameters are given for output they to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) + IF (PRESENT(IERR_U)) IERR_U = IERR + + END SUBROUTINE INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK(N, Tinitial, Tfinal, Y, RelTol, AbsTol, & + RCNTRL, ICNTRL, RSTATUS, ISTATUS, IDID) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Singly-Diagonally-Implicit +! Runge-Kutta (SDIRK) method. +! +! For details on SDIRK methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! This code is based on the SDIRK4 routine in the above book. +! +! (C) Adrian Sandu, July 2005 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tinitial) +!- [Tinitial,Tfinal] = time range of integration +! (if Tinitial>Tfinal the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, +! returns Jcb = dF/dY +!- ICNTRL(1:20) = integer inputs parameters +!- RCNTRL(1:20) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tfinal) +!- ISTATUS(1:20) -> integer output parameters +!- RSTATUS(1:20) -> real output parameters +!- IDID -> job status upon return +! success (positive value) or +! failure (negative value) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +!~~~> +! ICNTRL(1) = not used +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) = not used +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0 the default value of 100000 is used +! +! ICNTRL(5) -> maximum number of Newton iterations +! For ICNTRL(5)=0 the default value of 8 is used +! +! ICNTRL(6) -> starting values of Newton iterations: +! ICNTRL(6)=0 : starting values are interpolated (the default) +! ICNTRL(6)=1 : starting values are zero +! +!~~~> Real parameters +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller +! than ThetaMin the Jacobian is not recomputed; +! (default=0.001) +! RCNTRL(9) -> NewtonTol, stopping criterion for Newton's method +! (default=0.03) +! RCNTRL(10) -> Qmin +! RCNTRL(11) -> Qmax. If Qmin < Hnew/Hold < Qmax, then the +! step size is kept constant and the LU factorization +! reused (default Qmin=1, Qmax=1.2) +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last predicted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Arguments + INTEGER, INTENT(IN) :: N, ICNTRL(20) + KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, & + RelTol(NVAR), AbsTol(NVAR), RCNTRL(20) + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + INTEGER, INTENT(OUT) :: IDID + INTEGER, INTENT(INOUT) :: ISTATUS(20) + KPP_REAL, INTENT(OUT) :: RSTATUS(20) + +! Local variables + KPP_REAL :: Hmin, Hmax, Hstart, Roundoff, & + FacMin, Facmax, FacSafe, FacRej, & + ThetaMin, NewtonTol, Qmin, Qmax, & + Texit, Hexit + INTEGER :: ITOL, NewtonMaxit, Max_no_steps, i + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) +! Nfun=0; Njac=0; Nstp=0; Nacc=0 +! Nrej=0; Ndec=0; Nsol=0; Nsng=0 + + IDID = 0 + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + ITOL = 1 + ELSE + ITOL = 0 + END IF + +!~~~> The maximum number of time steps admitted + IF (ICNTRL(3) == 0) THEN + Max_no_steps = 100000 + ELSEIF (Max_no_steps > 0) THEN + Max_no_steps=ICNTRL(3) + ELSE + PRINT * ,'User-selected ICNTRL(3)=',ICNTRL(3) + CALL SDIRK_ErrorMsg(-1,Tinitial,ZERO,IDID) + END IF + + +!~~~> The maximum number of Newton iterations admitted + IF(ICNTRL(4) == 0)THEN + NewtonMaxit=8 + ELSE + NewtonMaxit=ICNTRL(4) + IF(NewtonMaxit <= 0)THEN + PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) + CALL SDIRK_ErrorMsg(-2,Tinitial,ZERO,IDID) + END IF + END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) + CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) + END IF + +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tfinal-Tinitial) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) + CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) + END IF + +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,Roundoff) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL SDIRK_ErrorMsg(-3,Tinitial,ZERO,IDID) + END IF + +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 10.0_dp + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL SDIRK_ErrorMsg(-4,Tinitial,ZERO,IDID) + END IF + +!~~~> DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; + IF(RCNTRL(8) == 0.D0)THEN + ThetaMin = 1.0d-3 + ELSE + ThetaMin = RCNTRL(8) + END IF + +!~~~> STOPPING CRITERION FOR NEWTON'S METHOD + IF(RCNTRL(9) == 0.0d0)THEN + NewtonTol = 3.0d-2 + ELSE + NewtonTol =RCNTRL(9) + END IF + +!~~~> Qmin AND Qmax: IF Qmin < Hnew/Hold < Qmax, STEP SIZE = CONST. + IF(RCNTRL(10) == 0.D0)THEN + Qmin=1.D0 + ELSE + Qmin=RCNTRL(10) + END IF + IF(RCNTRL(11) == 0.D0)THEN + Qmax=1.2D0 + ELSE + Qmax=RCNTRL(11) + END IF + +!~~~> Check if tolerances are reasonable + IF (ITOL == 0) THEN + IF (AbsTol(1) <= 0.D0.OR.RelTol(1) <= 10.D0*Roundoff) THEN + PRINT * , ' Scalar AbsTol = ',AbsTol(1) + PRINT * , ' Scalar RelTol = ',RelTol(1) + CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,IDID) + END IF + ELSE + DO i=1,N + IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL SDIRK_ErrorMsg(-5,Tinitial,ZERO,IDID) + END IF + END DO + END IF + + IF (IDID < 0) RETURN + + +!~~~> CALL TO CORE INTEGRATOR + CALL SDIRK_Integrator( N,Tinitial,Tfinal,Y,Hmin,Hmax,Hstart, & + RelTol,AbsTol,ITOL, Max_no_steps, NewtonMaxit, & + Roundoff, FacMin, FacMax, FacRej, FacSafe, ThetaMin, & + NewtonTol, Qmin, Qmax, Hexit, Texit, IDID ) + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + CONTAINS ! PROCEDURES INTERNAL TO SDIRK +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_Integrator( N,Tinitial,Tfinal,Y,Hmin,Hmax,Hstart, & + RelTol,AbsTol,ITOL, Max_no_steps, NewtonMaxit, & + Roundoff, FacMin, FacMax, FacRej, FacSafe, ThetaMin, & + NewtonTol, Qmin, Qmax, Hexit, Texit, IDID ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! CORE INTEGRATOR FOR SDIRK4 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + IMPLICIT NONE + +!~~~> Arguments: + INTEGER :: N + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + KPP_REAL, INTENT(IN) :: Tinitial, Tfinal, Hmin, Hmax, Hstart, & + RelTol(NVAR), AbsTol(NVAR), Roundoff, & + FacMin, FacMax, FacRej, FacSafe, ThetaMin, & + NewtonTol, Qmin, Qmax + KPP_REAL, INTENT(OUT) :: Hexit, Texit + INTEGER, INTENT(IN) :: ITOL, Max_no_steps, NewtonMaxit + INTEGER, INTENT(OUT) :: IDID + +!~~~> Local variables: + KPP_REAL :: Z(NVAR,5), FV(NVAR,5), CONT(NVAR,4), & + NewtonFactor(5), SCAL(NVAR), RHS(NVAR), & + G(NVAR), Yhat(NVAR), TMP(NVAR), & + T, H, Hold, Theta, Hratio, Hmax1, W, & + HGammaInv, DYTH, QNEWT, ERR, Fac, Hnew, & + Tdirection, NewtonErr, NewtonErrOld + INTEGER :: i, j, IER, istage, NewtonIter, IP(NVAR) + LOGICAL :: Reject, FIRST, NewtonReject, FreshJac, SkipJacUpdate, SkipLU + +#ifdef FULL_ALGEBRA + KPP_REAL FJAC(NVAR,NVAR), E(NVAR,NVAR) +#else + KPP_REAL FJAC(LU_NONZERO), E(LU_NONZERO) +#endif + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! INITIALISATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + CALL SDIRK_Coefficients + T = Tinitial + Tdirection = SIGN(1.D0,Tfinal-Tinitial) + Hmax1=MIN(ABS(Hmax),ABS(Tfinal-Tinitial)) + H = MAX(ABS(Hmin),ABS(Hstart)) + IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 + H=MIN(ABS(H),Hmax1) + H=SIGN(H,Tdirection) + Hold=H + NewtonReject=.FALSE. + SkipLU =.FALSE. + FreshJac = .FALSE. + SkipJacUpdate = .FALSE. + Reject=.FALSE. + FIRST=.TRUE. + NewtonFactor(1:5)=ONE + + CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Time loop begins +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tloop: DO WHILE ( (Tfinal-T)*Tdirection - Roundoff > ZERO ) + + +!~~~> Compute E = 1/(h*gamma)-Jac and its LU decomposition + IF ( SkipLU ) THEN ! This time around skip the Jac update and LU + SkipLU = .FALSE.; FreshJac = .FALSE.; SkipJacUpdate = .FALSE. + ELSE + CALL SDIRK_PrepareMatrix ( H, T, Y, FJAC, & + FreshJac, SkipJacUpdate, E, IP, Reject, IER ) + IF (IER /= 0) THEN + CALL SDIRK_ErrorMsg(-8,T,H,IDID); RETURN + END IF + END IF + + IF (Nstp>Max_no_steps) THEN + CALL SDIRK_ErrorMsg(-6,T,H,IDID); RETURN + END IF + IF ( (T+0.1d0*H == T) .OR. (ABS(H) <= Roundoff) ) THEN + CALL SDIRK_ErrorMsg(-7,T,H,IDID); RETURN + END IF + + HGammaInv = ONE/(H*rkGamma) + +!~~~> NEWTON ITERATION +stages:DO istage=1,5 + + NewtonFactor(istage) = MAX(NewtonFactor(istage),Roundoff)**0.8d0 + +!~~~> STARTING VALUES FOR NEWTON ITERATION + CALL Set2zero(N,G) + CALL Set2zero(N,Z(1,istage)) + IF (istage==1) THEN + IF (FIRST.OR.NewtonReject) THEN + CALL Set2zero(N,Z(1,istage)) + ELSE + W=ONE+rkGamma*H/Hold + DO i=1,N + Z(i,istage)=W*(CONT(i,1)+W*(CONT(i,2)+W*(CONT(i,3)+W*CONT(i,4))))-Yhat(i) + END DO + END IF + ELSE + DO j = 1, istage-1 + ! Gj(:) = sum_j Beta(i,j)*Zj(:) = H * sum_j A(i,j)*Fun(Zj(:)) + CALL WAXPY(N,rkBeta(istage,j),Z(1,j),1,G,1) + ! CALL WAXPY(N,H*rkA(istage,j),FV(1,j),1,G,1) + ! Zi(:) = sum_j Alpha(i,j)*Zj(:) + CALL WAXPY(N,rkAlpha(istage,j),Z(1,j),1,Z(1,istage),1) + END DO + IF (istage==5) CALL WCOPY(N,Z(1,istage),1,Yhat,1) ! Yhat(:) <- Z5(:) + END IF + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! LOOP FOR THE SIMPLIFIED NEWTON ITERATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NewtonIter=0 + Theta=ABS(ThetaMin) + IF (Reject) Theta=2*ABS(ThetaMin) + NewtonErr = 1.0e+6 ! To force-enter Newton loop + + Newton: DO WHILE (NewtonFactor(istage)*NewtonErr > NewtonTol) + + IF (NewtonIter >= NewtonMaxit) THEN + H=H*0.5d0 + Reject=.TRUE. + NewtonReject=.TRUE. + CYCLE Tloop + END IF + NewtonIter=NewtonIter+1 + +!~~~> COMPUTE THE RIGHT-HAND SIDE + TMP(1:N) = Y(1:N) + Z(1:N,istage) + CALL FUN_CHEM(T+rkC(istage)*H,TMP,RHS) + TMP(1:N) = G(1:N) - Z(1:N,istage) + CALL WAXPY(N,HGammaInv,TMP,1,RHS,1) ! RHS(:) <- RHS(:) + HGammaInv*(G(:)-Z(:)) + +!~~~> SOLVE THE LINEAR SYSTEMS +#ifdef FULL_ALGEBRA + CALL DGETRS( 'N', N, 1, E, N, IP, RHS, N, IER ) +#else + CALL KppSolve(E, RHS) +#endif + Nsol=Nsol+1 + +!~~~> CHECK CONVERGENCE OR IF NUMBER OF ITERATIONS TOO LARGE + CALL SDIRK_ErrorNorm(N, RHS, SCAL, NewtonErr) + IF ( (NewtonIter >= 2) .AND. (NewtonIter < NewtonMaxit) ) THEN + Theta = NewtonErr/NewtonErrOld + IF (Theta < 0.99d0) THEN + NewtonFactor(istage)=Theta/(ONE-Theta) + DYTH = NewtonFactor(istage)*NewtonErr* & + Theta**(NewtonMaxit-1-NewtonIter) + QNEWT = MAX(1.0d-4,MIN(16.0d0,DYTH/NewtonTol)) + IF (QNEWT >= ONE) THEN + H=.8D0*H*QNEWT**(-ONE/(NewtonMaxit-NewtonIter)) + Reject=.TRUE. + NewtonReject=.TRUE. + CYCLE Tloop ! go back to the beginning of DO step + END IF + ELSE + NewtonReject=.TRUE. + H=H*0.5d0 + Reject=.TRUE. + CYCLE Tloop ! go back to the beginning of DO step + END IF + END IF + NewtonErrOld = NewtonErr + CALL WAXPY(N,ONE,RHS,1,Z(1,istage),1) ! Z(:) <-- Z(:)+RHS(:) + + END DO Newton + +!~~> END OF SIMPLIFIED NEWTON ITERATION + ! Save function values + TMP(1:N) = Y(1:N) + Z(1:N,istage) + CALL FUN_CHEM(T+rkC(istage)*H,TMP,FV(1,istage)) + + END DO stages + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ERROR ESTIMATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Nstp=Nstp+1 + TMP(1:N)=HGammaInv*(Z(1:N,5)-Yhat(1:N)) + +#ifdef FULL_ALGEBRA + CALL DGETRS( 'N', N, 1, E, N, IP, TMP, N, IER ) +#else + CALL KppSolve(E, TMP) +#endif + + CALL SDIRK_ErrorNorm(N, TMP, SCAL, ERR) + +!~~~> COMPUTATION OF Hnew: WE REQUIRE FacMin <= Hnew/H <= FacMax + !Safe = FacSafe*DBLE(1+2*NewtonMaxit)/DBLE(NewtonIter+2*NewtonMaxit) + Fac = MAX(FacMin,MIN(FacMax,(ERR)**(-0.25d0)*FacSafe)) + Hnew = H*Fac + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ACCEPT/Reject STEP +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +accept: IF ( ERR < ONE ) THEN !~~~> STEP IS ACCEPTED + + FIRST=.FALSE. + Nacc=Nacc+1 + Hold=H + +!~~~> COEFFICIENTS FOR CONTINUOUS SOLUTION + CALL WAXPY(N,ONE,Z(1,5),1,Y,1) ! Y(:) <-- Y(:)+Z5(:) + CALL WCOPY(N,Z(1,5),1,Yhat,1) ! Yhat <-- Z5 + + DO i=1,4 ! CONTi <-- Sum_j rkD(i,j)*Zj + CALL Set2zero(N,CONT(1,i)) + DO j = 1,5 + CALL WAXPY(N,rkD(i,j),Z(1,j),1,CONT(1,i),1) + END DO + END DO + + CALL SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) + + T=T+H + FreshJac=.FALSE. + + Hnew = Tdirection*MIN(ABS(Hnew),Hmax1) + Hexit = Hnew + IF (Reject) Hnew=Tdirection*MIN(ABS(Hnew),ABS(H)) + Reject = .FALSE. + NewtonReject = .FALSE. + IF ((T+Hnew/Qmin-Tfinal)*Tdirection > 0.D0) THEN + H = Tfinal-T + ELSE + Hratio=Hnew/H + ! If step not changed too much, keep it as is; + ! do not update Jacobian and reuse LU + IF ( (Theta <= ThetaMin) .AND. (Hratio >= Qmin) & + .AND. (Hratio <= Qmax) ) THEN + SkipJacUpdate = .TRUE. + SkipLU = .TRUE. + ELSE + H = Hnew + END IF + END IF + ! If convergence is fast enough, do not update Jacobian + IF (Theta <= ThetaMin) SkipJacUpdate = .TRUE. + + ELSE accept !~~~> STEP IS REJECTED + + Reject=.TRUE. + IF (FIRST) THEN + H=H*FacRej + ELSE + H=Hnew + END IF + IF (Nacc >= 1) Nrej=Nrej+1 + + END IF accept + + END DO Tloop + + ! Successful return + Texit = T + IDID = 1 + + END SUBROUTINE SDIRK_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_ErrorScale(ITOL, AbsTol, RelTol, Y, SCAL) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: i, ITOL + KPP_REAL :: AbsTol(NVAR), RelTol(NVAR), & + Y(NVAR), SCAL(NVAR) + IF (ITOL == 0) THEN + DO i=1,NVAR + SCAL(i) = 1.0d0 / ( AbsTol(1)+RelTol(1)*ABS(Y(i)) ) + END DO + ELSE + DO i=1,NVAR + SCAL(i) = 1.0d0 / ( AbsTol(i)+RelTol(i)*ABS(Y(i)) ) + END DO + END IF + END SUBROUTINE SDIRK_ErrorScale + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_ErrorNorm(N, Y, SCAL, ERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! + INTEGER :: i, N + KPP_REAL :: Y(N), SCAL(N), ERR + ERR=0.0d0 + DO i=1,N + ERR = ERR+(Y(i)*SCAL(i))**2 + END DO + ERR = MAX( SQRT(ERR/DBLE(N)), 1.0d-10 ) +! + END SUBROUTINE SDIRK_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from SDIRK due to the following error:' + IF ((Code>=-8).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE SDIRK_ErrorMsg + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_PrepareMatrix ( H, T, Y, FJAC, & + FreshJac, SkipJacUpdate, E, IP, Reject, IER ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! + IMPLICIT NONE + + KPP_REAL, INTENT(INOUT) :: H + KPP_REAL, INTENT(IN) :: T, Y(NVAR) + LOGICAL, INTENT(INOUT) :: FreshJac, SkipJacUpdate + INTEGER, INTENT(OUT) :: IER, IP(NVAR) + LOGICAL, INTENT(INOUT) :: Reject +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(INOUT) :: FJAC(NVAR,NVAR) + KPP_REAL, INTENT(OUT) :: E(NVAR,NVAR) +#else + KPP_REAL, INTENT(INOUT) :: FJAC(LU_NONZERO) + KPP_REAL, INTENT(OUT) :: E(LU_NONZERO) +#endif + KPP_REAL :: HGammaInv + INTEGER :: i, j, ConsecutiveSng + KPP_REAL, PARAMETER :: ONE = 1.0d0 + + 20 CONTINUE + +!~~~> COMPUTE THE JACOBIAN + IF (SkipJacUpdate) THEN + SkipJacUpdate = .FALSE. + ELSE IF ( .NOT.FreshJac ) THEN + CALL JAC_CHEM( T, Y, FJAC ) + FreshJac = .TRUE. + END IF + +!~~~> Compute the matrix E = 1/(H*GAMMA)*Jac, and its decomposition + ConsecutiveSng = 0 + IER = 1 + +Hloop: DO WHILE (IER /= 0) + + HGammaInv = ONE/(H*rkGamma) + +#ifdef FULL_ALGEBRA + DO j=1,NVAR + DO i=1,NVAR + E(i,j)=-FJAC(i,j) + END DO + E(j,j)=E(j,j)+HGammaInv + END DO + CALL DGETRF( NVAR, NVAR, E, NVAR, IP, IER ) +#else + DO i = 1,LU_NONZERO + E(i) = -FJAC(i) + END DO + DO i = 1,NVAR + j = LU_DIAG(i); E(j) = E(j) + HGammaInv + END DO + CALL KppDecomp ( E, IER) + IP(1) = 1 +#endif + Ndec=Ndec+1 + + IF (IER /= 0) THEN + WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' T=',T,' H=',H + Nsng = Nsng+1; ConsecutiveSng = ConsecutiveSng + 1 + IF (ConsecutiveSng >= 6) RETURN ! Failure + H=H*0.5d0 + Reject=.TRUE. + !~~~> Update Jacobian if not fresh + IF ( .NOT.FreshJac ) GOTO 20 + END IF + + END DO Hloop + + END SUBROUTINE SDIRK_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SDIRK_Coefficients +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + rkGamma=4.0d0/15.0d0 + + rkA(1,1)= 4.d0/15.d0 + rkA(2,1)= 1.d0/2.d0 + rkA(2,2)= 4.d0/15.d0 + rkA(3,1)= 51069.d0/144200.d0 + rkA(3,2)=-7809.d0/144200.d0 + rkA(3,3)= 4.d0/15.d0 + rkA(4,1)= 12047244770625658.d0/141474406359725325.d0 + rkA(4,2)=-3057890203562191.d0/47158135453241775.d0 + rkA(4,3)= 2239631894905804.d0/28294881271945065.d0 + rkA(4,4)= 4.d0/15.d0 + rkA(5,1)= 181513.d0/86430.d0 + rkA(5,2)=-89074.d0/116015.d0 + rkA(5,3)= 83636.d0/34851.d0 + rkA(5,4)=-69863904375173.d0/23297141763930.d0 + rkA(5,5)= 4.d0/15.d0 + + rkB(1)= 181513.d0/86430.d0 + rkB(2)=-89074.d0/116015.d0 + rkB(3)= 83636.d0/34851.d0 + rkB(4)=-69863904375173.d0/23297141763930.d0 + rkB(5)= 4/15.d0 + + rkC(1)=4.d0/15.d0 + rkC(2)=23.d0/30.d0 + rkC(3)=17.d0/30.d0 + rkC(4)=707.d0/1931.d0 + rkC(5)=1.d0 + + rkBeta(2,1)=15.0d0/8.0d0 + rkBeta(3,1)=1577061.0d0/922880.0d0 + rkBeta(3,2)=-23427.0d0/115360.0d0 + rkBeta(4,1)=647163682356923881.0d0/2414496535205978880.0d0 + rkBeta(4,2)=-593512117011179.0d0/3245291041943520.0d0 + rkBeta(4,3)=559907973726451.0d0/1886325418129671.0d0 + rkBeta(5,1)=724545451.0d0/796538880.0d0 + rkBeta(5,2)=-830832077.0d0/267298560.0d0 + rkBeta(5,3)=30957577.0d0/2509272.0d0 + rkBeta(5,4)=-69863904375173.0d0/6212571137048.0d0 + + rkAlpha(2,1)= 23.d0/8.d0 + rkAlpha(3,1)= 0.9838473040915402d0 + rkAlpha(3,2)= 0.3969226768377252d0 + rkAlpha(4,1)= 0.6563374010466914d0 + rkAlpha(4,2)= 0.0d0 + rkAlpha(4,3)= 0.3372498196189311d0 + rkAlpha(5,1)=7752107607.0d0/11393456128.0d0 + rkAlpha(5,2)=-17881415427.0d0/11470078208.0d0 + rkAlpha(5,3)=2433277665.0d0/179459416.0d0 + rkAlpha(5,4)=-96203066666797.0d0/6212571137048.0d0 + + rkD(1,1)= 24.74416644927758d0 + rkD(1,2)= -4.325375951824688d0 + rkD(1,3)= 41.39683763286316d0 + rkD(1,4)= -61.04144619901784d0 + rkD(1,5)= -3.391332232917013d0 + rkD(2,1)= -51.98245719616925d0 + rkD(2,2)= 10.52501981094525d0 + rkD(2,3)= -154.2067922191855d0 + rkD(2,4)= 214.3082125319825d0 + rkD(2,5)= 14.71166018088679d0 + rkD(3,1)= 33.14347947522142d0 + rkD(3,2)= -19.72986789558523d0 + rkD(3,3)= 230.4878502285804d0 + rkD(3,4)= -287.6629744338197d0 + rkD(3,5)= -18.99932366302254d0 + rkD(4,1)= -5.905188728329743d0 + rkD(4,2)= 13.53022403646467d0 + rkD(4,3)= -117.6778956422581d0 + rkD(4,4)= 134.3962081008550d0 + rkD(4,5)= 8.678995715052762d0 + + END SUBROUTINE SDIRK_Coefficients + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + END SUBROUTINE SDIRK ! AND ALL ITS INTERNAL PROCEDURES +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE FUN_CHEM( T, Y, P ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Global, ONLY: NVAR + USE KPP_ROOT_Function + + INTEGER N + KPP_REAL T !, Told + KPP_REAL Y(NVAR), P(NVAR) + + !Told = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + + CALL Fun( Y, FIX, RCONST, P ) + + !TIME = Told + Nfun=Nfun+1 + + END SUBROUTINE FUN_CHEM + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE JAC_CHEM( T, Y, JV ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Global, ONLY: NVAR + USE KPP_ROOT_Jacobian + + INTEGER N + KPP_REAL T !, Told + KPP_REAL Y(NVAR) +#ifdef FULL_ALGEBRA + KPP_REAL :: JS(LU_NONZERO), JV(NVAR,NVAR) + INTEGER :: i, j +#else + KPP_REAL :: JV(LU_NONZERO) +#endif + + !Told = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + +#ifdef FULL_ALGEBRA + CALL Jac_SP(Y, FIX, RCONST, JS) + DO j=1,NVAR + DO j=1,NVAR + JV(i,j) = 0.0D0 + END DO + END DO + DO i=1,LU_NONZERO + JV(LU_IROW(i),LU_ICOL(i)) = JS(i) + END DO +#else + CALL Jac_SP(Y, FIX, RCONST, JV) +#endif + !TIME = Told + Njac = Njac+1 + + END SUBROUTINE JAC_CHEM + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.def new file mode 100755 index 00000000..16dee74d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_seulex + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.f new file mode 100755 index 00000000..98b286cc --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/kpp_seulex.f @@ -0,0 +1,1174 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + INTEGER i + + PARAMETER (KM=12,KM2=2+KM*(KM+3)/2,NRDENS=NVAR) + PARAMETER (LWORK=2*NVAR*NVAR+(KM+8)*NVAR+4*KM+20+KM2*NRDENS) + PARAMETER (LIWORK=2*NVAR+KM+20+NRDENS) + + KPP_REAL WORK(LWORK) + INTEGER IWORK(LIWORK) + EXTERNAL FUNC_CHEM,JAC_CHEM + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + IDFX=0 ! --- INTERNAL TIME DERIVATIVE + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + + CALL ATMSEULEX(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, + & STEPMIN,RTOL,ATOL,ITOL, + & JAC_CHEM,IJAC,MLJAC,MUJAC, + & FUNC_CHEM,IMAS,MLJAC,MUJAC, + & WORK,LWORK,IWORK,LIWORK,IDID) + + IF (IDID.LT.0) THEN + print *,'ATMSEULEX: Unsucessfull exit at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + RETURN + END + + + SUBROUTINE ATMSEULEX(N,FCN,IFCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC,MLJAC,MUJAC, + & MAS,IMAS,MLMAS,MUMAS, + & WORK,LWORK,IWORK,LIWORK,IDID) +C ---------------------------------------------------------- +C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). +C THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE +C LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL +C AND ORDER SELECTION). +C +C AUTHORS: E. HAIRER AND G. WANNER +C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +C CH-1211 GENEVE 24, SWITZERLAND +C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +C INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN +C +C THIS CODE IS PART OF THE BOOK: +C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, +C SPRINGER-VERLAG (1991) +C +C VERSION OF SEPTEMBER 30, 1995 +C +C INPUT PARAMETERS +C ---------------- +C N DIMENSION OF THE SYSTEM +C +C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE +C VALUE OF F(X,Y): +C SUBROUTINE FCN(N,X,Y,F) +C KPP_REAL X,Y(N),F(N) +C F(1)=... ETC. +C RPAR, IPAR (SEE BELOW) +C +C IFCN GIVES INFORMATION ON FCN: +C IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS) +C IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS) +C +C X INITIAL X-VALUE +C +C Y(N) INITIAL VALUES FOR Y +C +C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) +C +C H INITIAL STEP SIZE GUESS; +C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, +C H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. +C THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY +C ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6). +C +C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY +C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. +C +C ITOL SWITCH FOR RelTol AND AbsTol: +C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. +C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF +C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol +C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. +C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW +C RelTol(I)*ABS(Y(I))+AbsTol(I). +C +C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y +C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY +C A DUMMY SUBROUTINE IN THE CASE IJAC=0). +C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM +C SUBROUTINE JAC(N,X,Y,DFY,LDFY) +C KPP_REAL X,Y(N),DFY(LDFY,N) +C DFY(1,1)= ... +C LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS +C FURNISHED BY THE CALLING PROGRAM. +C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO +C BE FULL AND THE PARTIAL DERIVATIVES ARE +C STORED IN DFY AS +C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) +C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND +C THE PARTIAL DERIVATIVES ARE STORED +C DIAGONAL-WISE AS +C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). +C +C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: +C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE +C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. +C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. +C +C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: +C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C +C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLJAC=N. +C +C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- +C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - +C +C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- +C MATRIX M. +C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY +C MATRIX AND NEEDS NOT TO BE DEFINED; +C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. +C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM +C SUBROUTINE MAS(N,AM,LMAS) +C KPP_REAL AM(LMAS,N) +C AM(1,1)= .... +C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED +C AS FULL MATRIX LIKE +C AM(I,J) = M(I,J) +C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED +C DIAGONAL-WISE AS +C AM(I-J+MUMAS+1,J) = M(I,J). +C +C IMAS GIVES INFORMATION ON THE MASS-MATRIX: +C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY +C MATRIX, MAS IS NEVER CALLED. +C IMAS=1: MASS-MATRIX IS SUPPLIED. +C +C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: +C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C MLMAS IS SUPPOSED TO BE .LE. MLJAC. +C +C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLMAS=N. +C MUMAS IS SUPPOSED TO BE .LE. MUJAC. +C +C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE +C NUMERICAL SOLUTION DURING INTEGRATION. +C IF IOUT>=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. +C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. +C IT MUST HAVE THE FORM +C SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N, +C RPAR,IPAR,IRTRN) +C KPP_REAL X,Y(N),RC(LRC),IC(LIC) +C .... +C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH +C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS +C THE FIRST GRID-POINT). +C "XOLD" IS THE PRECEEDING GRID-POINT. +C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN +C IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM. +C DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)! +C +C ----- CONTINUOUS OUTPUT (IF IOUT=2): ----- +C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION +C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH +C THE KPP_REAL FUNCTION +C >>> CONTEX(I,S,RC,LRC,IC,LIC) <<< +C WHICH PROVIDES AN APPROXIMATION TO THE I-TH +C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE +C S SHOULD LIE IN THE INTERVAL [XOLD,X]. +C +C IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: +C IOUT=0: SUBROUTINE IS NEVER CALLED +C IOUT=1: SUBROUTINE IS USED FOR OUTPUT +C IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT +C +C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". +C SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES. +C "LWORK" MUST BE AT LEAST +C N*(LJAC+LMAS+LE1+KM+8)+4*KM+20+KM2*NRDENS +C WHERE +C KM2=2+KM*(KM+3)/2 AND NRDENS=IWORK(6) (SEE BELOW) +C AND +C LJAC=N IF MLJAC=N (FULL JACOBIAN) +C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST +C N*(LJAC+KM+8)+(N-M1)*(LMAS+LE1)+4*KM+20+KM2*NRDENS +C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE1 THE +C NUMBER N CAN BE REPLACED BY N-M1. +C +C LWORK DECLARED LENGTH OF ARRAY "WORK". +C +C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". +C "LIWORK" MUST BE AT LEAST 2*N+KM+20+NRDENS. +C +C LIWORK DECLARED LENGTH OF ARRAY "IWORK". +C +C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH +C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING +C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. +C +C ---------------------------------------------------------------------- +C +C SOPHISTICATED SETTING OF PARAMETERS +C ----------------------------------- +C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK +C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),..,WORK(13) +C AS WELL AS IWORK(1),..,IWORK(4) DIFFERENT FROM ZERO. +C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: +C +C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN +C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY +C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. +C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: +C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE +C JACOBIAN HAVE TO BE STORED +C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL +C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) +C FOR I=1,N-M1 AND J=1,N. +C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) +C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) +C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. +C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL +C 0<=MLJAC OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + + ! if optional parameters are given, and if they are >0, + ! they overwrite the default settings + IF (PRESENT(ICNTRL_U)) ICNTRL(:) = ICNTRL_U(:) + IF (PRESENT(RCNTRL_U)) RCNTRL(:) = RCNTRL_U(:) + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~----- + + + CALL ATMSEULEX(NVAR,TIN,TOUT,VAR,H,RTOL,ATOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + Ntotal = Ntotal + Nstp +!!$ PRINT*,'NSTEPS=',Nstp,' (',Ntotal,') T=',TIN + + + Nfun = Nfun + ISTATUS(1) + Njac = Njac + ISTATUS(2) + Nstp = Nstp + ISTATUS(3) + Nacc = Nacc + ISTATUS(4) + Nrej = Nrej + ISTATUS(5) + Ndec = Ndec + ISTATUS(6) + Nsol = Nsol + ISTATUS(7) + + ! if optional parameters are given for output + ! use them to store information in them + IF (PRESENT(ISTATUS_U)) THEN + ISTATUS_U(:) = 0 + ISTATUS_U(1) = Nfun ! function calls + ISTATUS_U(2) = Njac ! jacobian calls + ISTATUS_U(3) = Nstp ! steps + ISTATUS_U(4) = Nacc ! accepted steps + ISTATUS_U(5) = Nrej ! rejected steps (except at the beginning) + ISTATUS_U(6) = Ndec ! LU decompositions + ISTATUS_U(7) = Nsol ! forward/backward substitutions + ENDIF + IF (PRESENT(RSTATUS_U)) THEN + RSTATUS_U(:) = 0. + RSTATUS_U(1) = TOUT ! final time + ENDIF + IF (PRESENT(IERR_U)) IERR_U = IERR + +! mz_rs_20050716: IERR is returned to the user who then decides what to do +! about it, i.e. either stop the run or ignore it. +!!$ IF (IERR < 0) THEN +!!$ PRINT *,'SEULEX: Unsuccessful exit at T=', TIN,' (IERR=',IERR,')' +!!$ STOP +!!$ ENDIF + + END SUBROUTINE INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ATMSEULEX( N,Tinitial,Tfinal,Y,H,RelTol,AbsTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +! SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(T,Y). +! THIS IS AN EXTRAPOLATION-ALGORITHM, BASED ON THE +! LINEARLY IMPLICIT EULER METHOD (WITH STEP SIZE CONTROL +! AND ORDER SELECTION). +! +! AUTHORS: E. HAIRER AND G. WANNER +! UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +! CH-1211 GENEVE 24, SWITZERLAND +! E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +! INCLUSION OF DENSE OUTPUT BY E. HAIRER AND A. OSTERMANN +! +! THIS CODE IS PART OF THE BOOK: +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, +! SPRINGER-VERLAG (1991) +! +! VERSION OF SEPTEMBER 30, 1995 +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! INPUT PARAMETERS +! ---------------- +! N DIMENSION OF THE SYSTEM +! +! T INITIAL T-VALUE +! +! Y(N) INITIAL VALUES FOR Y +! +! Tend FINAL T-VALUE (Tend-T MAY BE POSITIVE OR NEGATIVE) +! +! H INITIAL STEP SIZE GUESS; +! FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, +! H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. +! THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY +! ADAPTS ITS STEP SIZE (IF H=0.D0, THE CODE PUTS H=1.D-6 +! +! RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY +! CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. +! +! JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +! THE PARTIAL DERIVATIVES OF F(T,Y) WITH RESPECT TO Y +! +! SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE +! NUMERICAL SOLUTION DURING INTEGRATION. +! IF IOUT>=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. +! SUPPLY A DUMMY SUBROUTINE IF IOUT=0. +! IT MUST HAVE THE FORM +! SUBROUTINE SOLOUT (NR,TOLD,T,Y,RC,LRC,IC,LIC,N, +! RPAR,IPAR,IRTRN) +! KPP_REAL T,Y(N),RC(LRC),IC(LIC) +! .... +! SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH +! GRID-POINT "T" (THEREBY THE INITIAL VALUE IS +! THE FIRST GRID-POINT). +! "TOLD" IS THE PRECEEDING GRID-POINT. +! "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN +! IS SET <0, SEULEX RETURNS TO THE CALLING PROGRAM. +! DO NOT CHANGE THE ENTRIES OF RC(LRC),IC(LIC)! +! +! ----- CONTINUOUS OUTPUT (IF IOUT=2): ----- +! DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION +! FOR THE INTERVAL [TOLD,T] IS AVAILABLE THROUGH +! THE KPP_REAL FUNCTION +! >>> CONTEX(I,S,RC,LRC,IC,LIC) <<< +! WHICH PROVIDES AN APPROXIMATION TO THE I-TH +! COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE +! S SHOULD LIE IN THE INTERVAL [TOLD,T]. +! +! IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: +! IOUT=0: SUBROUTINE IS NEVER CALLED +! IOUT=1: SUBROUTINE IS USED FOR OUTPUT +! IOUT=2: DENSE OUTPUT IS PERFORMED IN SOLOUT +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! SOPHISTICATED SETTING OF PARAMETERS +! ----------------------------------- +! SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT CNTRL +! WELL. THEY MAY BE DEFINED BY SETTING CNTRL(1),..,CNTRL(13) +! AS WELL AS ICNTRL(1),..,ICNTRL(4) DIFFERENT FROM ZERO. +! FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: +! +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +!~~~> +! ICNTRL(1) = 1: F = F(y) Independent of T (autonomous) +! = 0: F = F(t,y) Depends on T (non-autonomous) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> not used +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0 the default value of 100000 is used +! +! ICNTRL(11) THE MAXIMUM NUMBER OF COLUMNS IN THE EXTRAPOLATION +! TABLE. THE DEFAULT VALUE (FOR ICNTRL(3)=0) IS 12. +! IF ICNTRL(3).NE.0 THEN ICNTRL(3) SHOULD BE >= 3. +! +! ICNTRL(12) SWITCH FOR THE STEP SIZE SEQUENCE +! IF ICNTRL(4) == 1 THEN 1,2,3,4,6,8,12,16,24,32,48,... +! IF ICNTRL(4) == 2 THEN 2,3,4,6,8,12,16,24,32,48,64,... +! IF ICNTRL(4) == 3 THEN 1,2,3,4,5,6,7,8,9,10,... +! IF ICNTRL(4) == 4 THEN 2,3,4,5,6,7,8,9,10,11,... +! THE DEFAULT VALUE (FOR ICNTRL(4)=0) IS ICNTRL(4)=2. +! +! ICNTRL(13) PARAMETER "LAMBDA" OF DENSE OUTPUT; POSSIBLE VALUES +! ARE 0 AND 1; DEFAULT ICNTRL(5)=0. +! +! ICNTRL(14) = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT +! IS REQUIRED +! +! ICNTRL(21),...,ICNTRL(NRDENS+20) INDICATE THE COMPONENTS, FOR WHICH +! DENSE OUTPUT IS REQUIRED +! +!~~~> Real parameters +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +! RCNTRL(8) -> ThetaMin. If Newton convergence rate smaller +! than ThetaMin the Jacobian is not recomputed; +! (default=0.001). Increase cntrl(3), to 0.01 say, when +! Jacobian evaluations are costly. for small systems it +! should be smaller. +! RCNTRL(9) -> not used +! RCNTRL(10,11) -> FAC1,FAC2 (parameters for step size selection) +! RCNTRL(12,13) -> FAC3,FAC4 (parameters for order selection) +! RCNTRL(14,15) -> FacSafe1, FacSafe2 +! Safety factors for step size prediction +! HNEW=H*FacSafe2*(FacSafe1*TOL/ERR)**(1/(J-1)) +! RCNTRL(16:19) -> WorkFcn, WorkJac, WorkDec, WorkSol +! estimated computational work +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! OUTPUT PARAMETERS +! ----------------- +! T T-VALUE WHERE THE SOLUTION IS COMPUTED +! (AFTER SUCCESSFUL RETURN T=Tend) +! +! Y(N) SOLUTION AT T +! +! H PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! DECLARATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER :: N, IERR, ITOL, Max_no_steps, Ncolumns, Nsequence, Lambda, & + NRDENS, i, Ncolumns2, NRD, IOUT + KPP_REAL :: Y(NVAR),AbsTol(*),RelTol(*) + KPP_REAL :: Tinitial, Tfinal, Roundoff, Hmin, Hmax, & + FacMin, FacMax, FAC1, FAC2, FAC3, FAC4, FacSafe1, & + FacSafe2, H, Hstart,WorkFcn,WorkJac, WorkDec, WorkSol,& + WorkRow, FacRej, FacSafe, ThetaMin, T + LOGICAL :: AUTNMS + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! SETTING THE PARAMETERS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Nfun=0 + Njac=0 + Nstp=0 + Nacc=0 + Nrej=0 + Ndec=0 + Nsol=0 + + IERR = 0 + + IF (ICNTRL(1) == 0) THEN + AUTNMS = .FALSE. + ELSE + AUTNMS = .TRUE. + END IF + +!~~~> For Scalar tolerances (ICNTRL(1)/=0) the code uses AbsTol(1) and RelTol(1) +!~~~> For Vector tolerances (ICNTRL(1)==0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + ITOL = 1 + ELSE + ITOL = 0 + END IF + +!~~~> Max_no_steps: the maximum number of time steps admitted + IF (ICNTRL(4) == 0) THEN + Max_no_steps = 100000 + ELSEIF (ICNTRL(4) > 0) THEN + Max_no_steps=ICNTRL(4) + ELSE + PRINT * ,'User-selected ICNTRL(4)=',ICNTRL(4) + CALL SEULEX_ErrorMsg(-1,Tinitial,ZERO,IERR); + END IF + +!~~~> IOUT = use (or not) the output routine + IOUT = ICNTRL(10) + IF ( IOUT<0 .OR. IOUT>2 ) THEN + PRINT * ,'User-selected ICNTRL(10)=',ICNTRL(10) + IOUT = 0 + END IF + +!~~~> Ncolumns: maximum number of columns in the extrapolation + IF (ICNTRL(11)==0) THEN + Ncolumns=12 + ELSEIF (ICNTRL(11) > 2) THEN + Ncolumns=ICNTRL(11) + ELSE + PRINT * ,'User-selected ICNTRL(11)=',ICNTRL(11) + CALL SEULEX_ErrorMsg(-2,Tinitial,ZERO,IERR); + END IF + +!~~~> Nsequence: choice of step size sequence + IF (ICNTRL(12)==0) THEN + Nsequence = 2 + ELSEIF ( (ICNTRL(12)>0).AND.(ICNTRL(12)<5) ) THEN + Nsequence = ICNTRL(4) + ELSE + PRINT * ,'User-selected ICNTRL(12)=',ICNTRL(12) + CALL SEULEX_ErrorMsg(-3,Tinitial,ZERO,IERR) + END IF + +!~~~> LAMBDA: parameter for dense output + LAMBDA = ICNTRL(13) + IF ( LAMBDA < 0 .OR. LAMBDA >= 2 ) THEN + PRINT * ,'User-selected ICNTRL(13)=',ICNTRL(13) + CALL SEULEX_ErrorMsg(-4,Tinitial,ZERO,IERR) + END IF + +!~~~>- NRDENS: number of dense output components + NRDENS=ICNTRL(14) + IF ( (NRDENS < 0) .OR. (NRDENS > N) ) THEN + PRINT * ,'User-selected ICNTRL(14)=',ICNTRL(14) + CALL SEULEX_ErrorMsg(-5,Tinitial,ZERO,IERR) + END IF + + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected RCNTRL(1)=', RCNTRL(1) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tfinal-Tinitial) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected RCNTRL(2)=', RCNTRL(2) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,Roundoff) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tfinal-Tinitial)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL SEULEX_ErrorMsg(-7,Tinitial,ZERO,IERR) + RETURN + END IF + + +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 10.0_dp + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL SEULEX_ErrorMsg(-8,Tinitial,ZERO,IERR) + RETURN + END IF + +!~~~> ThetaMin: DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; +! INCREASE WORK(3), TO 0.01 SAY, WHEN JACOBIAN EVALUATIONS +! ARE COSTLY. FOR SMALL SYSTEMS WORK(3) SHOULD BE SMALLER. + IF(RCNTRL(8) == 0.D0)THEN + ThetaMin = 1.0d-3 + ELSE + ThetaMin = RCNTRL(8) + END IF + +!~~~> FAC1,FAC2: PARAMETERS FOR STEP SIZE SELECTION +! THE NEW STEP SIZE FOR THE J-TH DIAGONAL ENTRY IS +! CHOSEN SUBJECT TO THE RESTRICTION +! FACMIN/WORK(5) <= HNEW(J)/HOLD <= 1/FACMIN +! WHERE FACMIN=WORK(4)**(1/(J-1)) + IF(RCNTRL(10) == 0.D0)THEN + FAC1=0.1D0 + ELSE + FAC1=RCNTRL(10) + END IF + IF(RCNTRL(11) == 0.D0)THEN + FAC2=4.0D0 + ELSE + FAC2=RCNTRL(11) + END IF +!~~~> FAC3, FAC4: PARAMETERS FOR THE ORDER SELECTION +! ORDER IS DECREASED IF W(K-1) <= W(K)*WORK(6) +! ORDER IS INCREASED IF W(K) <= W(K-1)*WORK(7) + IF(RCNTRL(12) == 0.D0)THEN + FAC3=0.7D0 + ELSE + FAC3=RCNTRL(12) + END IF + IF(RCNTRL(13) == 0.D0)THEN + FAC4=0.9D0 + ELSE + FAC4=RCNTRL(13) + END IF +!~~~>- FacSafe1, FacSafe2: safety factors for step size prediction +! HNEW=H*WORK(9)*(WORK(8)*TOL/ERR)**(1/(J-1)) + IF(RCNTRL(14) == 0.D0)THEN + FacSafe1=0.6D0 + ELSE + FacSafe1=RCNTRL(14) + END IF + IF(RCNTRL(15) == 0.D0)THEN + FacSafe2=0.93D0 + ELSE + FacSafe2=RCNTRL(15) + END IF + +!~~~> WorkFcn: estimated computational work for a calls to FCN + IF(RCNTRL(16) == 0.D0)THEN + WorkFcn=1.D0 + ELSE + WorkFcn=RCNTRL(16) + END IF +!~~~> WorkJac: estimated computational work for calls to JAC + IF(RCNTRL(17) == 0.D0)THEN + WorkJac=5.D0 + ELSE + WorkJac=RCNTRL(17) + END IF +!~~~> WorkDec: estimated computational work for calls to DEC + IF(RCNTRL(18) == 0.D0)THEN + WorkDec=1.D0 + ELSE + WorkDec=RCNTRL(18) + END IF +!~~~> WorkSol: estimated computational work for calls to SOL + IF(RCNTRL(19) == 0.D0)THEN + WorkSol=1.D0 + ELSE + WorkSol=RCNTRL(19) + END IF + WorkRow=WorkFcn+WorkSol + +!~~~> Check if tolerances are reasonable + IF (ITOL == 0) THEN + IF (AbsTol(1) <= 0.D0.OR.RelTol(1) <= 10.D0*Roundoff) THEN + PRINT * , ' Scalar AbsTol = ',AbsTol(1) + PRINT * , ' Scalar RelTol = ',RelTol(1) + CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) + END IF + ELSE + DO i=1,N + IF (AbsTol(i) <= 0.D0.OR.RelTol(i) <= 10.D0*Roundoff) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL SEULEX_ErrorMsg(-9,Tinitial,ZERO,IERR) + END IF + END DO + END IF + + IF (IERR < 0) RETURN + +!~~~>---- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- + Ncolumns2=(Ncolumns*(Ncolumns+1))/2 + NRD=MAX(1,NRDENS) + + T = Tinitial +!~~~> CALL TO CORE INTEGRATOR + CALL SEULEX_Integrator(N,T,Tfinal,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL, & + IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & + FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & + WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) + + ISTATUS(1)=Nfun + ISTATUS(2)=Njac + ISTATUS(3)=Nstp + ISTATUS(4)=Nacc + ISTATUS(5)=Nrej + ISTATUS(6)=Ndec + ISTATUS(7)=Nsol + + END SUBROUTINE ATMSEULEX + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SEULEX_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from SEULEX due to the following error:' + + SELECT CASE (Code) + CASE (-1) + PRINT * , '--> Improper value for maximal no of steps' + CASE (-2) + PRINT * , '--> Improper value for maximum no of columns in extrapolation' + CASE (-3) + PRINT * , '--> Improper value for step size sequence' + CASE (-4) + PRINT * , '--> Improper value for Lambda (must be 0/1)' + CASE (-5) + PRINT * , '--> Improper number of dense output components' + CASE (-6) + PRINT * , '--> Improper parameters for second order equations' + CASE (-7) + PRINT * , '--> Hmin/Hmax/Hstart must be positive' + CASE (-8) + PRINT * , '--> FacMin/FacMax/FacRej must be positive' + CASE (-9) + PRINT * , '--> Improper tolerance values' + CASE (-10) + PRINT * , '--> No of steps exceeds maximum bound' + CASE (-11) + PRINT * , '--> Step size too small: T + 10*H = T', & + ' or H < Roundoff' + CASE (-12) + PRINT * , '--> Matrix is repeatedly singular' + CASE DEFAULT + PRINT *, 'Unknown Error code: ', Code + END SELECT + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE SEULEX_ErrorMsg + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SEULEX_Integrator(N,T,Tend,Y,Hmax,H,Ncolumns,RelTol,AbsTol,ITOL,& + IOUT,IERR,Max_no_steps,Roundoff,Nsequence,AUTNMS, & + FAC1,FAC2,FAC3,FAC4,ThetaMin,FacSafe1,FacSafe2,WorkJac, & + WorkDec,WorkRow,Ncolumns2,NRD,LAMBDA,Nstp) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! CORE INTEGRATOR FOR SEULEX +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! DECLARATIONS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + USE KPP_ROOT_Jacobian + IMPLICIT KPP_REAL (A-H,O-Z) + IMPLICIT INTEGER (I-N) + + INTEGER :: N, Ncolumns, Ncolumns2, K, KC, KRIGHT, KLR, KK, KRN,& + KOPT, NRD + KPP_REAL :: Y(NVAR),DY(NVAR),FX(NVAR),YHH(NVAR) + KPP_REAL :: DYH(NVAR), DEL(NVAR), WH(NVAR) + KPP_REAL :: SCAL(NVAR), HH(Ncolumns), W(Ncolumns), A(Ncolumns) +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO) +#endif + KPP_REAL Table(Ncolumns,N) + INTEGER IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) + KPP_REAL RelTol(*),AbsTol(*) + KPP_REAL FSAFE(Ncolumns2,NRD),FACUL(Ncolumns),E(N,N),DENS((Ncolumns+2)*NRD) + LOGICAL REJECT,LAST,ATOV,CALJAC,CALHES,AUTNMS + + KPP_REAL TOLDD,HHH,NNRD + COMMON /COSEU/TOLDD,HHH,NNRD,KRIGHT + +!~~~> COMPUTE COEFFICIENTS FOR DENSE OUTPUT + IF (IOUT == 2) THEN + NNRD=NRD +!~~~> COMPUTE THE FACTORIALS -------- + FACUL(1)=1.D0 + DO i=1,Ncolumns-1 + FACUL(i+1)=i*FACUL(i) + END DO + END IF + +!~~~> DEFINE THE STEP SIZE SEQUENCE + IF (Nsequence == 1) THEN + NJ(1)=1 + NJ(2)=2 + NJ(3)=3 + DO I=4,Ncolumns + NJ(i)=2*NJ(I-2) + END DO + END IF + IF (Nsequence == 2) THEN + NJ(1)=2 + NJ(2)=3 + DO I=3,Ncolumns + NJ(i)=2*NJ(I-2) + END DO + END IF + DO i=1,Ncolumns + IF (Nsequence == 3) NJ(i)=I + IF (Nsequence == 4) NJ(i)=I+1 + END DO + A(1)=WorkJac+NJ(1)*WorkRow+WorkDec + DO I=2,Ncolumns + A(i)=A(i-1)+(NJ(i)-1)*WorkRow+WorkDec + END DO + K=MAX0(3,MIN0(Ncolumns-2,INT(-DLOG10(RelTol(1)+AbsTol(1))*.6D0+1.5D0))) + + ! T = Tinitial + HmaxN = MIN(ABS(Hmax),ABS(Tend-T)) + IF (ABS(H) <= 10.D0*Roundoff) H=1.0D-6 + H=MIN(ABS(H),HmaxN) + Theta=2*ABS(ThetaMin) + ERR=0.D0 + W(1)=1.D30 + DO i=1,N + IF (ITOL == 0) THEN + SCAL(i)=AbsTol(1)+RelTol(1)*DABS(Y(i)) + ELSE + SCAL(i)=AbsTol(i)+RelTol(i)*DABS(Y(i)) + END IF + END DO + CALJAC=.FALSE. + REJECT=.FALSE. + LAST=.FALSE. + 10 CONTINUE + IF (REJECT) Theta=2*ABS(ThetaMin) + ATOV=.FALSE. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> IS Tend REACHED IN THE NEXT STEP? +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + H1=Tend-T + IF (H1 <= Roundoff) GO TO 110 + HOPT=H + H=MIN(H,H1,HmaxN) + IF (H >= H1-Roundoff) LAST=.TRUE. + IF (AUTNMS) THEN + CALL FUN_CHEM(T,Y,DY) + END IF + IF (Theta > ThetaMin.AND..NOT.CALJAC) THEN +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! COMPUTATION OF THE JACOBIAN +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + CALL JAC_CHEM(T,Y,FJAC) + CALJAC=.TRUE. + CALHES=.FALSE. + END IF +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> THE FIRST AND LAST STEP +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (Nstp == 0.OR.LAST) THEN + IPT=0 + Nstp=Nstp+1 + DO J=1,K + KC=J + CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns, & + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,FAC, & + FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol, & + ERROLD,IPHES,ICOMP,AUTNMS,REJECT, & + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + IF (J > 1 .AND. ERR <= 1.d0) GOTO 60 + END DO + GO TO 55 + END IF +!~~~> BASIC INTEGRATION STEP + 30 CONTINUE + IPT=0 + Nstp=Nstp+1 + IF (Nstp >= Max_no_steps) GOTO 120 + KC=K-1 + DO J=1,KC + CALL SEUL(J,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + END DO +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> CONVERGENCE MONITOR +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (K == 2.OR.REJECT) GO TO 50 + IF (ERR <= 1.D0) GO TO 60 + IF (ERR > DBLE(NJ(K+1)*NJ(K))*4.D0) GO TO 100 + 50 CALL SEUL(K,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + KC=K + IF (ERR <= 1.D0) GO TO 60 +!~~~> HOPE FOR CONVERGENCE IN LINE K+1 + 55 IF (ERR > DBLE(NJ(K+1))*2.D0) GO TO 100 + KC=K+1 + CALL SEUL(KC,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,H,Ncolumns,& + HmaxN,Table,SCAL,NJ,HH,W,A,YHH,DYH,DEL,WH,ERR,FacSafe1,& + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP,AUTNMS,REJECT,& + ATOV,FSAFE,Ncolumns2,NRD,IOUT,IPT,CALHES) + IF (ATOV) GOTO 10 + IF (ERR > 1.D0) GO TO 100 + !Adi IF ((ERR > 1.D0).and.(H.gt.Hmin)) GO TO 100 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STEP IS ACCEPTED +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 60 TOLD=T + T=T+H + IF (IOUT == 2) THEN + KRIGHT=KC + DO i=1,NRD + DENS(i)=Y(ICOMP(i)) + END DO + END IF + DO i=1,N + T1I=Table(1,I) + IF (ITOL == 0) THEN + SCAL(i)=AbsTol(1)+RelTol(1)*DABS(T1I) + ELSE + SCAL(i)=AbsTol(i)+RelTol(i)*DABS(T1I) + END IF + Y(i)=T1I + END DO + Nacc=Nacc+1 + CALJAC=.FALSE. + IF (IOUT == 2) THEN + TOLDD=TOLD + HHH=H + DO i=1,NRD + DENS(NRD+I)=Y(ICOMP(i)) + END DO + DO KLR=1,KRIGHT-1 +!~~~> COMPUTE DIFFERENCES + IF (KLR >= 2) THEN + DO KK=KLR,KC + LBEG=((KK+1)*KK)/2 + LEND=LBEG-KK+2 + DO L=LBEG,LEND,-1 + DO i=1,NRD + FSAFE(L,I)=FSAFE(L,I)-FSAFE(L-1,I) + END DO + END DO + END DO + END IF +!~~~> COMPUTE DERIVATIVES AT RIGHT END ---- + DO KK=KLR+LAMBDA,KC + FACNJ=NJ(KK) + FACNJ=FACNJ**KLR/FACUL(KLR+1) + IPT=((KK+1)*KK)/2 + DO I=1,NRD + KRN=(KK-LAMBDA+1)*NRD + DENS(KRN+I)=FSAFE(IPT,I)*FACNJ + END DO + END DO + DO J=KLR+LAMBDA+1,KC + DBLENJ=NJ(J) + DO L=J,KLR+LAMBDA+1,-1 + FACTOR=DBLENJ/NJ(L-1)-1.D0 + DO i=1,NRD + KRN=(L-LAMBDA+1)*NRD+I + DENS(KRN-NRD)=DENS(KRN)+(DENS(KRN)-DENS(KRN-NRD))/FACTOR + END DO + END DO + END DO + END DO +!~~~> COMPUTE THE COEFFICIENTS OF THE INTERPOLATION POLYNOMIAL + DO IN=1,NRD + DO J=1,KRIGHT + II=NRD*J+IN + DENS(II)=DENS(II)-DENS(II-NRD) + END DO + END DO + END IF +!~~~> COMPUTE OPTIMAL ORDER + IF (KC == 2) THEN + KOPT=3 + IF (REJECT) KOPT=2 + GO TO 80 + END IF + IF (KC <= K) THEN + KOPT=KC + IF (W(KC-1) < W(KC)*FAC3) KOPT=KC-1 + IF (W(KC) < W(KC-1)*FAC4) KOPT=MIN0(KC+1,Ncolumns-1) + ELSE + KOPT=KC-1 + IF (KC > 3.AND.W(KC-2) < W(KC-1)*FAC3) KOPT=KC-2 + IF (W(KC) < W(KOPT)*FAC4) KOPT=MIN0(KC,Ncolumns-1) + END IF +!~~~> AFTER A REJECTED STEP + 80 IF (REJECT) THEN + K=MIN0(KOPT,KC) + H=MIN(H,HH(K)) + REJECT=.FALSE. + GO TO 10 + END IF +!~~~> COMPUTE STEP SIZE FOR NEXT STEP + IF (KOPT <= KC) THEN + H=HH(KOPT) + ELSE + IF (KC < K.AND.W(KC) < W(KC-1)*FAC4) THEN + H=HH(KC)*A(KOPT+1)/A(KC) + ELSE + H=HH(KC)*A(KOPT)/A(KC) + END IF + END IF + K=KOPT + !Adi H = MAX(H, Hmin) + GO TO 10 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STEP IS REJECTED +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + 100 K=MIN0(K,KC) + IF (K > 2.AND.W(K-1) < W(K)*FAC3) K=K-1 + Nrej=Nrej+1 + H=HH(K) + LAST=.FALSE. + REJECT=.TRUE. + IF (CALJAC) GOTO 30 + GO TO 10 +!~~~> SOLUTION EXIT + 110 CONTINUE + H=HOPT + IERR=1 + RETURN +!~~~> FAIL EXIT + 120 WRITE (6,979) T,H + 979 FORMAT(' EXIT OF SEULEX AT T=',D14.7,' H=',D14.7) + IERR=-1 + RETURN + + + END SUBROUTINE SEULEX_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SEUL(JJ,N,T,Y,DY,FX,FJAC,LFJAC,E,LE,IP,& + H,Ncolumns,HmaxN,Table,SCAL,NJ,HH,W,A,YH,DYH,DEL,WH,ERR,FacSafe1, & + FAC,FAC1,FAC2,FacSafe2,Theta,Nfun,Ndec,Nsol,& + ERROLD,IPHES,ICOMP, & + AUTNMS,REJECT,ATOV,FSAFE,Ncolumns2,NRD,IOUT, & + IPT,CALHES) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> THIS SUBROUTINE COMPUTES THE J-TH LINE OF THE +!~~~> EXTRAPOLATION TABLE AND PROVIDES AN ESTIMATE +!~~~> OF THE OPTIMAL STEP SIZE + USE KPP_ROOT_Parameters + USE KPP_ROOT_Jacobian + IMPLICIT KPP_REAL (A-H,O-Z) + IMPLICIT INTEGER (I-N) + INTEGER :: Ncolumns, Ncolumns2, N, NRD + KPP_REAL :: Y(NVAR),YH(NVAR),DY(NVAR),FX(NVAR),DYH(NVAR) + KPP_REAL :: DEL(NVAR),WH(NVAR),SCAL(NVAR),HH(Ncolumns),W(Ncolumns),A(Ncolumns) +#ifdef FULL_ALGEBRA + KPP_REAL :: FJAC(NVAR,NVAR), E(NVAR,NVAR) +#else + KPP_REAL :: FJAC(LU_NONZERO), E(LU_NONZERO) +#endif + KPP_REAL :: Table(Ncolumns,NVAR) + KPP_REAL :: FSAFE(Ncolumns2,NRD) + INTEGER :: IP(N),NJ(Ncolumns),IPHES(N),ICOMP(NRD) + LOGICAL ATOV,REJECT,AUTNMS,CALHES + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! COMPUTE THE MATRIX E AND ITS DECOMPOSITION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + HJ=H/NJ(JJ) + HJI=1.D0/HJ +#ifdef FULL_ALGEBRA + DO j=1,N + DO i=1,N + E(i,j)=-FJAC(i,j) + END DO + E(j,j)=E(j,j)+HJI + END DO + CALL DGETRF(N,N,E,N,IP,ISING) +#else + DO i=1,LU_NONZERO + E(i)=-FJAC(i) + END DO + DO j=1,N + E(LU_DIAG(j))=E(LU_DIAG(j))+HJI + END DO + CALL KppDecomp (E,ISING) +#endif + Ndec=Ndec+1 + IF (ISING.NE.0) GOTO 79 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> STARTING PROCEDURE +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (.NOT.AUTNMS) THEN + CALL FUN_CHEM(T+HJ,Y,DY) + END IF + DO i=1,N + YH(i)=Y(i) + DEL(i)=DY(i) + END DO +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) +#else + CALL KppSolve (E,DEL) +#endif + Nsol=Nsol+1 + M=NJ(JJ) + IF (IOUT == 2.AND.M == JJ) THEN + IPT=IPT+1 + DO i=1,NRD + FSAFE(IPT,I)=DEL(ICOMP(i)) + END DO + END IF +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> SEMI-IMPLICIT EULER METHOD +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (M > 1) THEN + DO MM=1,M-1 + DO i=1,N + YH(i)=YH(i)+DEL(i) + END DO + IF (AUTNMS) THEN + CALL FUN_CHEM(T+HJ*MM,YH,DYH) + ELSE + CALL FUN_CHEM(T+HJ*(MM+1),YH,DYH) + END IF + + IF (MM == 1.AND.JJ <= 2) THEN +!~~~> STABILITY CHECK + DEL1=0.D0 + DO i=1,N + DEL1=DEL1+(DEL(i)/SCAL(i))**2 + END DO + DEL1=SQRT(DEL1) + IF (.NOT.AUTNMS) THEN + CALL FUN_CHEM(T+HJ,YH,WH) + + DO i=1,N + DEL(i)=WH(i)-DEL(i)*HJI + END DO + ELSE + DO i=1,N + DEL(i)=DYH(i)-DEL(i)*HJI + END DO + END IF +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DEL,N,ISING) +#else + CALL KppSolve (E,DEL) +#endif + Nsol=Nsol+1 + DEL2=0.D0 + DO i=1,N + DEL2=DEL2+(DEL(i)/SCAL(i))**2 + END DO + DEL2=SQRT(DEL2) + Theta=DEL2/MAX(1.D0,DEL1) + IF (Theta > 1.D0) GOTO 79 + END IF +#ifdef FULL_ALGEBRA + CALL DGETRS ('N',N,1,E,N,IP,DYH,N,ISING) +#else + CALL KppSolve (E,DYH) +#endif + Nsol=Nsol+1 + DO i=1,N + DEL(i)=DYH(i) + END DO + IF (IOUT == 2.AND.MM >= M-JJ) THEN + IPT=IPT+1 + DO i=1,NRD + FSAFE(IPT,i)=DEL(ICOMP(i)) + END DO + END IF + END DO + END IF + DO i=1,N + Table(JJ,I)=YH(i)+DEL(i) + END DO +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> POLYNOMIAL EXTRAPOLATION +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IF (JJ == 1) RETURN + DO L=JJ,2,-1 + FAC=(DBLE(NJ(JJ))/DBLE(NJ(L-1)))-1.D0 + DO i=1,N + Table(L-1,I)=Table(L,I)+(Table(L,I)-Table(L-1,I))/FAC + END DO + END DO + ERR=0.D0 + DO i=1,N + ERR=ERR+MIN(ABS((Table(1,I)-Table(2,I)))/SCAL(i),1.D15)**2 + END DO + IF (ERR >= 1.D30) GOTO 79 + ERR=SQRT(ERR/DBLE(N)) + IF (JJ > 2.AND.ERR >= ERROLD) GOTO 79 + ERROLD=MAX(4*ERR,1.D0) +!~~~> COMPUTE OPTIMAL STEP SIZES + EXPO=1.D0/JJ + FACMIN=FAC1**EXPO + FAC=MIN(FAC2/FACMIN,MAX(FACMIN,(ERR/FacSafe1)**EXPO/FacSafe2)) + FAC=1.D0/FAC + HH(JJ)=MIN(H*FAC,HmaxN) + W(JJ)=A(JJ)/HH(JJ) + RETURN + 79 ATOV=.TRUE. + H=H*0.5D0 + REJECT=.TRUE. + RETURN + END SUBROUTINE SEUL + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE FUN_CHEM( T, V, FCT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Function, ONLY: Fun + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), FCT(NVAR) + KPP_REAL :: T, TOLD + + !TOLD = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = TOLD + CALL Fun(V, FIX, RCONST, FCT) + Nfun=Nfun+1 + + END SUBROUTINE FUN_CHEM + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE JAC_CHEM ( T, V, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian, ONLY: Jac_SP + USE KPP_ROOT_Rates, ONLY: Update_SUN, Update_RCONST, Update_PHOTO + + IMPLICIT NONE + + KPP_REAL :: V(NVAR), T, TOLD +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) + INTEGER :: i,j +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif + + !TOLD = TIME + !TIME = T + !CALL Update_SUN() + !CALL Update_RCONST() + !CALL Update_PHOTO() + !TIME = TOLD + +#ifdef FULL_ALGEBRA + CALL Jac_SP(V, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0D0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP(V, FIX, RCONST, Jcb) +#endif + Njac=Njac+1 + + END SUBROUTINE JAC_CHEM + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.c new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.def new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.f new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.f90 new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/none.m new file mode 100755 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.c new file mode 100755 index 00000000..019895ae --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.c @@ -0,0 +1,90 @@ +void INTEGRATE( double DT ) +{ +KPP_REAL P_VAR[NVAR], D_VAR[NVAR], V1[NVAR], V2[NVAR]; +int IsReject; +KPP_REAL T, Tnext, STEP, STEPold, Told, SUP; +KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp; +int i; + + T = TIME; + Tnext = TIME + DT; + STEP = STEPMIN; + Told = T; + SUP = 1e-14; + IsReject = 0; + ERR = .5; + +/* -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- */ + + while ( T < Tnext ) { + + T = Told + STEP; + if ( T > Tnext ) { + STEP = Tnext - Told; + T = Tnext; + } + + FSPLIT_VAR ( VAR, P_VAR, D_VAR ); + + for( i = 0; i < NVAR; i++ ) { + if ( fabs(D_VAR[i]) > SUP ) { + ratio = P_VAR[i] / D_VAR[i]; + tmp = (KPP_REAL)exp( (double)(-D_VAR[i] * STEP * 0.5) ); + V1[i] = tmp * tmp * (VAR[i] - ratio) + ratio; + V2[i] = tmp * (VAR[i] - ratio) + ratio; + } else { + tmp = D_VAR[i] * STEP * 0.5; + V1[i] = VAR[i] + P_VAR[i] * STEP * ( 1 - tmp * + ( 1 - 2.0 / 3.0 * tmp ) ); + V2[i] = VAR[i] + P_VAR[i] * 0.5 * STEP * ( 1 - 0.5 * tmp * + ( 1 - 1.0 / 3.0 * tmp ) ); + } + } + + FSPLIT_VAR( V2, P_VAR, D_VAR ); + + for( i = 0; i < NVAR; i++ ) { + if ( fabs(D_VAR[i]) > SUP ) { + ratio = P_VAR[i] / D_VAR[i]; + tmp = (KPP_REAL)exp( (double)(-D_VAR[i] * STEP * 0.5) ); + V2[i] = tmp * (V2[i] - ratio) + ratio; + } else { + tmp = D_VAR[i] * STEP * 0.5; + V2[i] = V2[i] + P_VAR[i] * 0.5 * STEP * ( 1 - 0.5 * tmp * + ( 1 - 1.0 / 3.0 * tmp ) ); + } + } +/* ==== Extrapolation and error estimation ======== */ + + ERRold=ERR; + ERR=0.; + for( i = 0; i < NVAR; i++ ) { + V1[i] = 2.*V2[i] - V1[i]; + tmp = (V2[i] - V1[i]) / (ATOL[i] + RTOL[i]*V2[i]); + ERR = ERR + tmp*tmp; + } + ERR = sqrt(ERR/NVAR); + STEPold = STEP; + +/* ===== choosing the stepsize ==================== */ + + factor = 0.9 / pow(ERR,0.35) * pow(ERRold,0.2); + facmax = IsReject ? 1.0 : 5.0; + + factor = max( 0.2, min(factor,facmax) ); + STEP = min( STEPMAX, max(STEPMIN,factor*STEP) ); + +/*================================================= */ + + if ( (ERR > 1) && (STEPold > STEPMIN) ) { + T = Told; + IsReject = 1; + } else { + IsReject = 0; + Told = T; + for( i = 0; i < NVAR; i++ ) + VAR[i] = max( V1[i], 0.0 ); + TIME = Tnext; + } + } +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.def new file mode 100755 index 00000000..6169246f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.def @@ -0,0 +1,16 @@ + +#FUNCTION SPLIT +#JACOBIAN OFF +#SPARSEDATA OFF +#DOUBLE ON +#INTFILE exqssa + +#INLINE F_INIT_INT + STEPMIN=0.0001 + STEPMAX=60. +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN=0.0001; + STEPMAX=60.; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.f new file mode 100755 index 00000000..925d4a78 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/exqssa.f @@ -0,0 +1,136 @@ +C -- EXTRAPOLATED QSSA WITH STEADY STATE APPROXIMATION -- +C For extrapolated plain QSSA (to remove the steady state assumption) +C modify slow -> 0, fast -> 1e20 +C + + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + +C Local variables + KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) + LOGICAL IsReject + KPP_REAL T, Tnext, STEP, STEPold, Told, SUP + KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp + INTEGER i + KPP_REAL slow, fast + + T = TIN + Tnext = TOUT + STEP = DMAX1(STEPMIN,1.d-10) + Told = T + SUP = 1e-14 + IsReject = .false. + ERR = 1.d0 + ERRold = 1.d0 + slow = 0.01 + fast = 10. + + 10 continue + Tplus = T + STEP + if ( Tplus .gt. Tnext ) then + STEP = Tnext - T + Tplus = Tnext + end if + + + TITI = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) + V1(i) = VAR(i) + XXX + V2(i) = VAR(i) + 0.5*XXX + ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES + V1(i) = P_VAR(i)/D_VAR(i) + V2(i) = V1(i) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio + V2(i) = tmp * (VAR(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * + * ( 1 - 2.0 / 3.0 * tmp ) ) + V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + + TITI = TIME + TIME = T + 0.5*STEP + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) + V2(i) = V2(i) + 0.5*XXX + ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES + V2(i) = P_VAR(i)/D_VAR(i) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V2(i) = tmp * (V2(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + +C ===== Extrapolation and error estimation ======== + + ERRold=ERR + ERR=0.0D0 + do i=1,NVAR + ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 + end do + ERR = DSQRT( ERR/NVAR ) + STEPold=STEP + +C ===== choosing the stepsize ===================== + + factor = 0.9*ERR**(-0.35)*ERRold**0.2 + if (IsReject) then + facmax=1. + else + facmax=8. + end if + factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) + STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) + +C=================================================== + + if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then + IsReject = .true. + else + IsReject = .false. + do 140 i=1,NVAR + VAR(i) = DMAX1(2*V2(i)-V1(i), 0.d0) + 140 continue + T = Tplus + end if + if ( T .lt. Tnext ) go to 10 + + TIME = Tnext + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.def new file mode 100755 index 00000000..9e94c5b7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_rodas + +#INLINE F_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F_INIT_INT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.f new file mode 100755 index 00000000..600021ca --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_rodas.f @@ -0,0 +1,647 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + INTEGER i + + PARAMETER (LWORK=2*NVAR*NVAR+14*NVAR+20,LIWORK=NVAR+20) + KPP_REAL WORK(LWORK) + INTEGER IWORK(LIWORK) + EXTERNAL FUNC_CHEM,JAC_CHEM + + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + IDFX=0 ! --- INTERNAL TIME DERIVATIVE + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + + IWORK(3) = 1 + + CALL ATMRODAS(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, + & STEPMIN,RTOL,ATOL,ITOL, + & JAC_CHEM,IJAC,MLJAC,MUJAC,FUNC_CHEM,IDFX, + & FUNC_CHEM,IMAS, + & WORK,LWORK,IWORK,LIWORK,IDID) + + IF (IDID.LT.0) THEN + print *,'ATMRODAS: Unsucessfull exit at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + + RETURN + END + + + SUBROUTINE ATMRODAS(N,FCN,IFCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC,MLJAC,MUJAC,DFX,IDFX, + & MAS ,IMAS, + & WORK,LWORK,IWORK,LIWORK,IDID) +C ---------------------------------------------------------- +C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). +C THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4 +C (WITH STEP SIZE CONTROL). +C C.F. SECTIONS IV.7 AND VI.3 +C +C AUTHORS: E. HAIRER AND G. WANNER +C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +C CH-1211 GENEVE 24, SWITZERLAND +C E-MAIL: HAIRER@DIVSUN.UNIGE.CH, WANNER@DIVSUN.UNIGE.CH +C --------------------------------------------------------- +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C DECLARATIONS +C *** *** *** *** *** *** *** *** *** *** *** *** *** + IMPLICIT KPP_REAL (A-H,O-Z) + DIMENSION Y(N),AbsTol(*),RelTol(*),WORK(LWORK),IWORK(LIWORK) + LOGICAL AUTNMS,IMPLCT,JBAND,ARRET,PRED + EXTERNAL FCN,JAC,DFX,MAS + COMMON /STATISTICS/ NFCN,NACCPT,NREJCT,NSTEP,NJAC,NDEC,NSOL +C *** *** *** *** *** *** *** +C SETTING THE PARAMETERS +C *** *** *** *** *** *** *** + ARRET=.FALSE. + METH = 1 + NMAX=100000 +C -------- PRED STEP SIZE CONTROL + IF(IWORK(3).LE.1)THEN + PRED=.TRUE. + ELSE + PRED=.FALSE. + END IF + UROUND=1.D-16 + NM1 = N + M1 = N + M2 = N +C -------- MAXIMAL STEP SIZE + IF(WORK(2).EQ.0.D0)THEN + HMAX=XEND-X + ELSE + HMAX=WORK(2) + END IF +C ------- FAC1,FAC2 PARAMETERS FOR STEP SIZE SELECTION + IF(WORK(3).EQ.0.D0)THEN + FAC1=5.D0 + ELSE + FAC1=1.D0/WORK(3) + END IF + IF(WORK(4).EQ.0.D0)THEN + FAC2=1.D0/6.0D0 + ELSE + FAC2=1.D0/WORK(4) + END IF + IF (FAC1.LT.1.0D0.OR.FAC2.GT.1.0D0) THEN + WRITE(6,*)' CURIOUS INPUT WORK(3,4)=',WORK(3),WORK(4) + ARRET=.TRUE. + END IF +C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION + SAFE=0.9D0 +C --------- CHECK IF TOLERANCES ARE O.K. + IF (ITOL.EQ.0) THEN + IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES ARE TOO SMALL' + ARRET=.TRUE. + END IF + ELSE + DO I=1,N + IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL' + ARRET=.TRUE. + END IF + END DO + END IF + + IF (ARRET) STOP + NM1 = N +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C COMPUTATION OF ARRAY ENTRIES +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C ---- AUTONOMOUS, IMPLICIT, BANDED OR NOT ? + AUTNMS=IFCN.EQ.0 + IMPLCT=IMAS.NE.0 + JBAND=MLJAC.LT.NM1 +C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- +C -- JACOBIAN AND MATRIX E + MLJAC=NM1 + MUJAC=NM1 + LDJAC=NM1 + LDE=NM1 +C -- MASS MATRIX + IF (IMPLCT) THEN + print *, 'Implicit 1' + ELSE + LDMAS=0 + IJOB=1 + END IF + LDMAS2=MAX(1,LDMAS) +C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- + IEYNEW=21 + IEDY1=IEYNEW+N + IEDY=IEDY1+N + IEAK1=IEDY+N + IEAK2=IEAK1+N + IEAK3=IEAK2+N + IEAK4=IEAK3+N + IEAK5=IEAK4+N + IEAK6=IEAK5+N + IEFX =IEAK6+N + IECON=IEFX+N + IEJAC=IECON+4*N + IEMAS=IEJAC+N*LDJAC + IEE =IEMAS+NM1*LDMAS +C ------ TOTAL STORAGE REQUIREMENT ----------- + ISTORE=IEE+NM1*LDE-1 + IF(ISTORE.GT.LWORK)THEN + WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE + ARRET=.TRUE. + END IF +C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- + IEIP=21 + ISTORE=IEIP+NM1-1 + IF(ISTORE.GT.LIWORK)THEN + WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE + ARRET=.TRUE. + END IF +C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 + IF (ARRET) THEN + IDID=-1 + RETURN + END IF +C -------- CALL TO CORE INTEGRATOR ------------ + CALL ROSCOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL,JAC,IJAC, + & MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,IOUT,IDID,NMAX, + & UROUND,METH,IJOB,FAC1,FAC2,SAFE,AUTNMS,IMPLCT,JBAND,PRED,LDJAC, + & LDE,LDMAS2,WORK(IEYNEW),WORK(IEDY1),WORK(IEDY),WORK(IEAK1), + & WORK(IEAK2),WORK(IEAK3),WORK(IEAK4),WORK(IEAK5),WORK(IEAK6), + & WORK(IEFX),WORK(IEJAC),WORK(IEE),WORK(IEMAS),IWORK(IEIP), + & WORK(IECON), + & M1,M2,NM1,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL) + IWORK(14)=NFCN + IWORK(15)=NJAC + IWORK(16)=NSTEP + IWORK(17)=NACCPT + IWORK(18)=NREJCT + IWORK(19)=NDEC + IWORK(20)=NSOL +C ----------- RETURN ----------- + RETURN + END +C +C +C +C ----- ... AND HERE IS THE CORE INTEGRATOR ---------- +C + SUBROUTINE ROSCOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol, + & ITOL,JAC,IJAC, + & MLJAC,MUJAC,DFX,IDFX,MAS,MLMAS,MUMAS,IOUT,IDID,NMAX, + & UROUND,METH,IJOB,FAC1,FAC2,SAFE,AUTNMS,IMPLCT,BANDED, + & PRED,LDJAC, + & LDE,LDMAS,YNEW,DY1,DY,AK1,AK2,AK3,AK4,AK5,AK6, + & FX,FJAC,E,FMAS,IP,CONT, + & M1,M2,NM1,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL) +C ---------------------------------------------------------- +C CORE INTEGRATOR FOR RODAS +C PARAMETERS SAME AS IN RODAS WITH WORKSPACE ADDED +C ---------------------------------------------------------- +C DECLARATIONS +C ---------------------------------------------------------- + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' + DIMENSION Y(N),YNEW(N),DY1(N),DY(N),AK1(N), + * AK2(N),AK3(N),AK4(N),AK5(N),AK6(N),FX(N), + * FJAC(LU_NONZERO),E(LDE,NM1),FMAS(LDMAS,NM1), + * AbsTol(*),RelTol(*) + DIMENSION CONT(4*N) + INTEGER IP(NM1) + LOGICAL REJECT,AUTNMS,IMPLCT,BANDED + LOGICAL ONE,LAST,PRED,SINGULAR + EXTERNAL FCN, MAS, JAC, DFX + COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG + COMMON /CONROS/XOLD,HOUT,NN +C *** *** *** *** *** *** *** +C INITIALISATIONS +C *** *** *** *** *** *** *** + NN=N + NN2=2*N + NN3=3*N + LRC=4*N +C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- + IF (IMPLCT) CALL MAS (NM1,FMAS,LDMAS) +C ------ SET THE PARAMETERS OF THE METHOD ----- + CALL ROCOE(METH,A21,A31,A32,A41,A42,A43,A51,A52,A53,A54, + & C21,C31,C32,C41,C42,C43,C51,C52,C53,C54,C61, + & C62,C63,C64,C65,GAMMA,C2,C3,C4,D1,D2,D3,D4, + & D21,D22,D23,D24,D25,D31,D32,D33,D34,D35) +C --- INITIAL PREPARATIONS + IF (M1.GT.0) IJOB=IJOB+10 + POSNEG=SIGN(1.D0,XEND-X) + HMAXN=DMIN1(DABS(HMAX),DABS(XEND-X)) + IF (DABS(H).LE.10.D0*UROUND) H=1.0D-6 + H=DMIN1(DABS(H),HMAXN) + H=SIGN(H,POSNEG) + HACC = H + ERRACC = 1.0d0 + REJECT=.FALSE. + LAST=.FALSE. + NSING=0 + IRTRN=1 + IF (AUTNMS) THEN + HD1=0.0D0 + HD2=0.0D0 + HD3=0.0D0 + HD4=0.0D0 + END IF +C -------- PREPARE BAND-WIDTHS -------- + MBDIAG=MUMAS+1 + +C --- BASIC INTEGRATION STEP + LAST = .FALSE. + DO WHILE (.NOT.LAST) + IF (.NOT. REJECT) THEN + IF (NSTEP.GT.NMAX) CALL FAIL_EXIT(3,X,IDID,H,NMAX) + IF ( 0.1D0*DABS(H) .LE. DABS(X)*UROUND ) + * CALL FAIL_EXIT(2,X,IDID,H,NMAX) + HOPT=H + IF ((X+H*1.0001D0-XEND)*POSNEG.GE.0.D0) THEN + H=XEND-X + LAST=.TRUE. + END IF +C *** *** *** *** *** *** *** +C COMPUTATION OF THE JACOBIAN +C *** *** *** *** *** *** *** + CALL FCN(N,X,Y,DY1) + CALL JAC(N,X,Y,FJAC,LDJAC) + NFCN=NFCN+1 + NJAC=NJAC+1 + + IF (.NOT.AUTNMS) THEN +C --- COMPUTE NUMERICALLY THE DERIVATIVE WITH RESPECT TO X + DELT=DSQRT(UROUND*DMAX1(1.D-5,DABS(X))) + XDELT=X+DELT + CALL FCN(N,XDELT,Y,AK1) + DO J=1,N + FX(J)=(AK1(J)-DY1(J))/DELT + END DO + END IF + END IF + +C *** *** *** *** *** *** *** +C COMPUTE THE STAGES +C *** *** *** *** *** *** *** + SINGULAR = .TRUE. + DO WHILE (SINGULAR) + FAC=1.D0/(H*GAMMA) + CALL DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,IER,IJOB,IMPLCT,IP) + SINGULAR = IER.NE.0 + IF (SINGULAR) THEN + NSING=NSING+1 + IF (NSING.GE.5) CALL FAIL_EXIT(1,X,IDID,H,NMAX) + H=H*0.5D0 + REJECT=.TRUE. + LAST=.FALSE. + ONE = .FALSE. + END IF + END DO + + NDEC=NDEC+1 +C --- PREPARE FOR THE COMPUTATION OF THE 6 STAGES + HC21=C21/H + HC31=C31/H + HC32=C32/H + HC41=C41/H + HC42=C42/H + HC43=C43/H + HC51=C51/H + HC52=C52/H + HC53=C53/H + HC54=C54/H + HC61=C61/H + HC62=C62/H + HC63=C63/H + HC64=C64/H + HC65=C65/H + IF (.NOT.AUTNMS) THEN + HD1=H*D1 + HD2=H*D2 + HD3=H*D3 + HD4=H*D4 + END IF +C --- THE STAGES + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY1,AK1,FX,YNEW,HD1,IJOB,.FALSE.) + DO I=1,N + YNEW(I)=Y(I)+A21*AK1(I) + END DO + CALL FCN(N,X+C2*H,YNEW,DY) + DO I=1,N + YNEW(I)=HC21*AK1(I) + END DO + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY,AK2,FX,YNEW,HD2,IJOB,.TRUE.) + DO I=1,N + YNEW(I)=Y(I)+A31*AK1(I)+A32*AK2(I) + END DO + CALL FCN(N,X+C3*H,YNEW,DY) + DO I=1,N + YNEW(I)=HC31*AK1(I)+HC32*AK2(I) + END DO + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY,AK3,FX,YNEW,HD3,IJOB,.TRUE.) + DO I=1,N + YNEW(I)=Y(I)+A41*AK1(I)+A42*AK2(I)+A43*AK3(I) + END DO + CALL FCN(N,X+C4*H,YNEW,DY) + DO I=1,N + YNEW(I)=HC41*AK1(I)+HC42*AK2(I)+HC43*AK3(I) + END DO + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY,AK4,FX,YNEW,HD4,IJOB,.TRUE.) + DO I=1,N + YNEW(I)=Y(I)+A51*AK1(I)+A52*AK2(I)+A53*AK3(I)+A54*AK4(I) + END DO + CALL FCN(N,X+H,YNEW,DY) + DO I=1,N + AK6(I)=HC52*AK2(I)+HC54*AK4(I)+HC51*AK1(I)+HC53*AK3(I) + END DO + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY,AK5,FX,AK6,0.D0,IJOB,.TRUE.) +C ------------ EMBEDDED SOLUTION --------------- + DO I=1,N + YNEW(I)=YNEW(I)+AK5(I) + END DO + CALL FCN(N,X+H,YNEW,DY) + DO I=1,N + AK5(I)=HC61*AK1(I)+HC62*AK2(I)+HC65*AK5(I) + & +HC64*AK4(I)+HC63*AK3(I) + END DO + CALL SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC,E,LDE,IP,DY,AK6,FX,AK5,0.D0,IJOB,.TRUE.) +C ------------ NEW SOLUTION --------------- + DO I=1,N + YNEW(I)=YNEW(I)+AK6(I) + END DO + NSOL=NSOL+6 + NFCN=NFCN+5 + +C *** *** *** *** *** *** *** +C ERROR ESTIMATION +C *** *** *** *** *** *** *** + NSTEP=NSTEP+1 +C ------------ COMPUTE ERROR ESTIMATION ---------------- + ERR=0.0D0 + DO I=1,N + IF (ITOL.EQ.0) THEN + SK=AbsTol(1)+RelTol(1)*DMAX1(DABS(Y(I)),DABS(YNEW(I))) + ELSE + SK=AbsTol(I)+RelTol(I)*DMAX1(DABS(Y(I)),DABS(YNEW(I))) + END IF + ERR=ERR+(AK6(I)/SK)**2 +c2 ERR = DMAX1(ERR, AK6(I)/SK) + END DO + ERR=DSQRT(ERR/N) + +C --- COMPUTATION OF HNEW +C --- WE REQUIRE .2<=HNEW/H<=6. + FAC=DMAX1(FAC2,DMIN1(FAC1,(ERR)**0.25D0/SAFE)) + HNEW=DMAX1(H/FAC, STEPMIN) + +C *** *** *** *** *** *** *** +C IS THE ERROR SMALL ENOUGH ? +C *** *** *** *** *** *** *** + + IF ( (ERR.LE.1.D0).or.(H.LE.STEPMIN) ) THEN +C --- STEP IS ACCEPTED + NACCPT=NACCPT+1 + IF (PRED) THEN +C --- PREDICTIVE CONTROLLER OF GUSTAFSSON + IF (NACCPT.GT.1) THEN + FACGUS=(HACC/H)*(ERR**2/ERRACC)**0.25D0/SAFE + FACGUS=DMAX1(FAC2,DMIN1(FAC1,FACGUS)) + FAC=DMAX1(FAC,FACGUS) + HNEW=DMAX1(H/FAC, STEPMIN) + END IF + HACC=H + ERRACC=DMAX1(1.0D-2,ERR) + END IF + DO I=1,N + Y(I)=YNEW(I) + END DO + XOLD=X + X=X+H + IF (DABS(HNEW).GT.HMAXN) HNEW=POSNEG*HMAXN + IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) + REJECT=.FALSE. + H=HNEW + ELSE +C --- STEP IS REJECTED + REJECT=.TRUE. + LAST=.FALSE. + H=HNEW + IF (NACCPT.GE.1) NREJCT=NREJCT+1 + END IF + END DO + RETURN + END +C + SUBROUTINE FAIL_EXIT(NERR,X,IDID,H,NMAX) + INTEGER NERR, NMAX + KPP_REAL X, H + GO TO (1,2,3,4) NERR + 1 CONTINUE + WRITE(6,979)X + WRITE(6,*) ' MATRIX IS REPEATEDLY SINGULAR, IER=',IER + IDID=-4 + STOP + 2 CONTINUE + WRITE(6,979)X + WRITE(6,*) ' STEP SIZE TOO SMALL, H=',H + IDID=-3 + STOP + 3 CONTINUE + WRITE(6,979)X + WRITE(6,*) ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED' + IDID=-2 + STOP +C --- EXIT CAUSED BY solout + 4 CONTINUE + WRITE(6,979)X + 979 FORMAT(' EXIT OF RODAS AT X=',E18.4) + IDID=2 + RETURN + END + + SUBROUTINE ROCOE(METH,A21,A31,A32,A41,A42,A43,A51,A52,A53,A54, + & C21,C31,C32,C41,C42,C43,C51,C52,C53,C54,C61, + & C62,C63,C64,C65,GAMMA,C2,C3,C4,D1,D2,D3,D4, + & D21,D22,D23,D24,D25,D31,D32,D33,D34,D35) + IMPLICIT KPP_REAL (A-H,O-Z) + + if (METH.ne.1) print *, 'WRONG CHOICE OF METHOD' + C2=0.386D0 + C3=0.21D0 + C4=0.63D0 + BET2P=0.0317D0 + BET3P=0.0635D0 + BET4P=0.3438D0 + D1= 0.2500000000000000D+00 + D2=-0.1043000000000000D+00 + D3= 0.1035000000000000D+00 + D4=-0.3620000000000023D-01 + A21= 0.1544000000000000D+01 + A31= 0.9466785280815826D+00 + A32= 0.2557011698983284D+00 + A41= 0.3314825187068521D+01 + A42= 0.2896124015972201D+01 + A43= 0.9986419139977817D+00 + A51= 0.1221224509226641D+01 + A52= 0.6019134481288629D+01 + A53= 0.1253708332932087D+02 + A54=-0.6878860361058950D+00 + C21=-0.5668800000000000D+01 + C31=-0.2430093356833875D+01 + C32=-0.2063599157091915D+00 + C41=-0.1073529058151375D+00 + C42=-0.9594562251023355D+01 + C43=-0.2047028614809616D+02 + C51= 0.7496443313967647D+01 + C52=-0.1024680431464352D+02 + C53=-0.3399990352819905D+02 + C54= 0.1170890893206160D+02 + C61= 0.8083246795921522D+01 + C62=-0.7981132988064893D+01 + C63=-0.3152159432874371D+02 + C64= 0.1631930543123136D+02 + C65=-0.6058818238834054D+01 + GAMMA= 0.2500000000000000D+00 + + D21= 0.1012623508344586D+02 + D22=-0.7487995877610167D+01 + D23=-0.3480091861555747D+02 + D24=-0.7992771707568823D+01 + D25= 0.1025137723295662D+01 + D31=-0.6762803392801253D+00 + D32= 0.6087714651680015D+01 + D33= 0.1643084320892478D+02 + D34= 0.2476722511418386D+02 + D35=-0.6594389125716872D+01 + RETURN + END +C + +C ****************************************** +C VERSION OF SEPTEMBER 18, 1995 +C ****************************************** +C + SUBROUTINE DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' + DIMENSION FJAC(LU_NONZERO),FMAS(LDMAS,NM1),E1(LU_NONZERO), + & IP1(NM1),IPHES(N) + LOGICAL CALHES + COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG +C + + +C --- B=IDENTITY, JACOBIAN A FULL MATRIX + DO J=1,LU_NONZERO + E1(J) = -FJAC(J) + END DO + DO J=1,N + E1(LU_DIAG(J)) = E1(LU_DIAG(J)) + FAC1 + END DO + CALL KppDecomp (E1,IER) + RETURN + END +C +C END OF SUBROUTINE DECOMR +C +C *********************************************************** +C +C +C +C + SUBROUTINE SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, + & M1,M2,NM1,FAC1,E,LDE,IP,DY,AK,FX,YNEW,HD,IJOB,STAGE1) + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' + DIMENSION FJAC(LU_NONZERO),FMAS(LDMAS,NM1),E(LU_NONZERO), + & IP(NM1),DY(N),AK(N),FX(N),YNEW(N) + LOGICAL STAGE1 + COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG +C + IF (HD.EQ.0.D0) THEN + DO I=1,N + AK(I)=DY(I) + END DO + ELSE + DO I=1,N + AK(I)=DY(I)+HD*FX(I) + END DO + END IF + +C --- B=IDENTITY, JACOBIAN A FULL MATRIX + IF (STAGE1) THEN + DO I=1,N + AK(I)=AK(I)+YNEW(I) + END DO + END IF + CALL KppSolve (E,AK) + RETURN + END +C +C END OF SUBROUTINE SLVROD +C +C +C *********************************************************** + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.def new file mode 100755 index 00000000..a51d99aa --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE kpp_ros4 + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.f new file mode 100755 index 00000000..6e62b312 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/kpp_ros4.f @@ -0,0 +1,1052 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + INTEGER i + + PARAMETER (LWORK=2*NVAR*NVAR+14*NVAR+20,LIWORK=NVAR+20) + KPP_REAL WORK(LWORK) + INTEGER IWORK(LIWORK) + EXTERNAL FUNC_CHEM,JAC_CHEM,SOLOUT + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + MLJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + MUJAC=NVAR ! --- JACOBIAN IS A FULL MATRIX + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + IOUT=0 ! --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION + IDFX=0 ! --- INTERNAL TIME DERIVATIVE + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + IWORK(2) = 6 + + CALL KPP_ROS4(NVAR,FUNC_CHEM,Autonomous,TIN,VAR,TOUT, + & STEPMIN,RTOL,ATOL,ITOL, + & JAC_CHEM,IJAC,MLJAC,MUJAC,FUNC_CHEM,IDFX, + & FUNC_CHEM,IMAS,MLJAC,MUJAC, + & SOLOUT,IOUT, + & WORK,LWORK,IWORK,LIWORK,IDID) + + IF (IDID.LT.0) THEN + print *,'KPP_ROS4: Unsucessful step at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + RETURN + END + + + SUBROUTINE KPP_ROS4(N,FCN,IFCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC,MLJAC,MUJAC,DFX,IDFX, + & MAS ,IMAS,MLMAS,MUMAS, + & SOLOUT,IOUT, + & WORK,LWORK,IWORK,LIWORK,IDID) +C ---------------------------------------------------------- +C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) +C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y). +C THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4 +C (WITH STEP SIZE CONTROL). +C C.F. SECTION IV.7 +C +C AUTHORS: E. HAIRER AND G. WANNER +C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES +C CH-1211 GENEVE 24, SWITZERLAND +C E-MAIL: HAIRER@CGEUGE51.BITNET, WANNER@CGEUGE51.BITNET +C +C THIS CODE IS PART OF THE BOOK: +C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +C SPRINGER-VERLAG (1990) +C +C VERSION OF NOVEMBER 17, 1992 +C +C INPUT PARAMETERS +C ---------------- +C N DIMENSION OF THE SYSTEM +C +C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE +C VALUE OF F(X,Y): +C SUBROUTINE FCN(N,X,Y,F) +C KPP_REAL X,Y(N),F(N) +C F(1)=... ETC. +C +C IFCN GIVES INFORMATION ON FCN: +C IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS) +C IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS) +C +C X INITIAL X-VALUE +C +C Y(N) INITIAL VALUES FOR Y +C +C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) +C +C H INITIAL STEP SIZE GUESS; +C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, +C H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD. +C THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY +C ADAPTS ITS STEP SIZE. STUDY THE CHOSEN VALUES FOR A FEW +C STEPS IN SUBROUTINE "SOLOUT", WHEN YOU ARE NOT SURE. +C (IF H=0.D0, THE CODE PUTS H=1.D-6). +C +C RelTol,AbsTol RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY +C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. +C +C ITOL SWITCH FOR RelTol AND AbsTol: +C ITOL=0: BOTH RelTol AND AbsTol ARE SCALARS. +C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF +C Y(I) BELOW RelTol*ABS(Y(I))+AbsTol +C ITOL=1: BOTH RelTol AND AbsTol ARE VECTORS. +C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW +C RelTol(I)*ABS(Y(I))+AbsTol(I). +C +C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y +C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY +C A DUMMY SUBROUTINE IN THE CASE IJAC=0). +C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM +C SUBROUTINE JAC(N,X,Y,DFY,LDFY) +C KPP_REAL X,Y(N),DFY(LDFY,N) +C DFY(1,1)= ... +C LDFY, THE COLOMN-LENGTH OF THE ARRAY, IS +C FURNISHED BY THE CALLING PROGRAM. +C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO +C BE FULL AND THE PARTIAL DERIVATIVES ARE +C STORED IN DFY AS +C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) +C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND +C THE PARTIAL DERIVATIVES ARE STORED +C DIAGONAL-WISE AS +C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). +C +C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: +C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE +C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. +C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. +C +C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: +C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C +C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLJAC=N. +C +C DFX NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES +C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO X +C (THIS ROUTINE IS ONLY CALLED IF IDFX=1 AND IFCN=1; +C SUPPLY A DUMMY SUBROUTINE IN THE CASE IDFX=0 OR IFCN=0). +C OTHERWISE, THIS SUBROUTINE MUST HAVE THE FORM +C SUBROUTINE DFX(N,X,Y,FX) +C KPP_REAL X,Y(N),FX(N) +C FX(1)= ... +C +C IDFX SWITCH FOR THE COMPUTATION OF THE DF/DX: +C IDFX=0: DF/DX IS COMPUTED INTERNALLY BY FINITE +C DIFFERENCES, SUBROUTINE "DFX" IS NEVER CALLED. +C IDFX=1: DF/DX IS SUPPLIED BY SUBROUTINE DFX. +C +C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- +C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - +C +C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- +C MATRIX M. +C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY +C MATRIX AND NEEDS NOT TO BE DEFINED; +C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. +C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM +C SUBROUTINE MAS(N,AM,LMAS) +C KPP_REAL AM(LMAS,N) +C AM(1,1)= .... +C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED +C AS FULL MATRIX LIKE +C AM(I,J) = M(I,J) +C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED +C DIAGONAL-WISE AS +C AM(I-J+MUMAS+1,J) = M(I,J). +C +C IMAS GIVES INFORMATION ON THE MASS-MATRIX: +C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY +C MATRIX, MAS IS NEVER CALLED. +C IMAS=1: MASS-MATRIX IS SUPPLIED. +C +C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: +C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR +C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. +C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW +C THE MAIN DIAGONAL). +C MLMAS IS SUPPOSED TO BE .LE. MLJAC. +C +C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- +C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). +C NEED NOT BE DEFINED IF MLMAS=N. +C MUMAS IS SUPPOSED TO BE .LE. MUJAC. +C +C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE +C NUMERICAL SOLUTION DURING INTEGRATION. +C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. +C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. +C IT MUST HAVE THE FORM +C SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,IRTRN) +C KPP_REAL X,Y(N) +C .... +C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH +C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS +C THE FIRST GRID-POINT). +C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN +C IS SET <0, ROS4 RETURNS TO THE CALLING PROGRAM. +C +C IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT: +C IOUT=0: SUBROUTINE IS NEVER CALLED +C IOUT=1: SUBROUTINE IS USED FOR OUTPUT +C +C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". +C SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES. +C "LWORK" MUST BE AT LEAST +C N*(LJAC+LMAS+LE1+8)+5 +C WHERE +C LJAC=N IF MLJAC=N (FULL JACOBIAN) +C LJAC=MLJAC+MUJAC+1 IF MLJAC 0, fast -> 1e20 +C + + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + +C Local variables + KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) + LOGICAL IsReject + KPP_REAL T, Tnext, STEP, STEPold, Told, SUP + KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp + INTEGER i + KPP_REAL slow, fast + + T = TIN + Tnext = TOUT + STEP = DMAX1(STEPMIN,1.d-10) + Told = T + SUP = 1e-14 + IsReject = .false. + ERR = 1.d0 + ERRold = 1.d0 + slow = 0.01 + fast = 10. + + 10 continue + Tplus = T + STEP + if ( Tplus .gt. Tnext ) then + STEP = Tnext - T + Tplus = Tnext + end if + + + TITI = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) + V1(i) = VAR(i) + XXX + V2(i) = VAR(i) + 0.5*XXX + ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES + V1(i) = P_VAR(i)/D_VAR(i) + V2(i) = V1(i) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio + V2(i) = tmp * (VAR(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * + * ( 1 - 2.0 / 3.0 * tmp ) ) + V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + + TITI = TIME + TIME = T + 0.5*STEP + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*STEP .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(i) - D_VAR(i)*VAR(i)) + V2(i) = V2(i) + 0.5*XXX + ELSE IF ( D_VAR(i)*STEP .GT. fast) THEN ! FAST SPECIES + V2(i) = P_VAR(i)/D_VAR(i) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V2(i) = tmp * (V2(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + +C ===== Extrapolation and error estimation ======== + + ERRold=ERR + ERR=0.0D0 + do i=1,NVAR + ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 + end do + ERR = DSQRT( ERR/NVAR ) + STEPold=STEP + +C ===== choosing the stepsize ===================== + + factor = 0.9*ERR**(-0.35)*ERRold**0.2 + if (IsReject) then + facmax=1. + else + facmax=8. + end if + factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) + STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) + +C=================================================== + + if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then + IsReject = .true. + else + IsReject = .false. + do 140 i=1,NVAR + VAR(i) = DMAX1(V2(i), 0.d0) + 140 continue + T = Tplus + end if + if ( T .lt. Tnext ) go to 10 + + TIME = Tnext + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssa1.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssa1.f new file mode 100755 index 00000000..71e16204 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssa1.f @@ -0,0 +1,136 @@ +C -- QSSA WITH STEADY STATE APPROXIMATION -- +C For plain QSSA (to remove the steady state assumption) +C modify slow -> 0, fast -> 1e20 +C + + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + +C Local variables + KPP_REAL P_VAR(NVAR), D_VAR(NVAR), V1(NVAR), V2(NVAR) + LOGICAL IsReject + KPP_REAL T, Tnext, STEP, STEPold, Told, SUP + KPP_REAL ERR, ERRold, ratio, factor, facmax, tmp + INTEGER I + KPP_REAL slow, fast + + T = TIN + Tnext = TOUT + STEP = DMAX1(STEPMIN,1.d-10) + Told = T + SUP = 1e-14 + IsReject = .false. + ERR = 1.d0 + ERRold = 1.d0 + slow = 0.01 + fast = 10. + + 10 continue + Tplus = T + STEP + if ( Tplus .gt. Tnext ) then + STEP = Tnext - T + Tplus = Tnext + end if + + + TITI = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*step .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(I) - D_VAR(I)*VAR(I)) + V1(I) = VAR(I) + XXX + V2(I) = VAR(I) + 0.5*XXX + ELSE IF ( D_VAR(i)*step .GT. fast) THEN ! FAST SPECIES + V1(I) = P_VAR(I)/D_VAR(I) + V2(I) = V1(I) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V1(i) = tmp * tmp * (VAR(i) - ratio) + ratio + V2(i) = tmp * (VAR(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V1(i) = VAR(i) + P_VAR(i) * STEP * ( 1 - tmp * + * ( 1 - 2.0 / 3.0 * tmp ) ) + V2(i) = VAR(i) + P_VAR(i) * 0.5 * STEP*( 1-0.5*tmp* + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + + TITI = TIME + TIME = T + 0.5*STEP + CALL Update_SUN() + CALL Update_RCONST() + TIME = TITI + CALL FSPLIT_VAR ( V2, P_VAR, D_VAR ) + + do i=1,NVAR + IF ( D_VAR(i)*step .lt. slow) THEN ! SLOW SPECIES + XXX = STEP * (P_VAR(I) - D_VAR(I)*VAR(I)) + V2(I) = V2(I) + 0.5*XXX + ELSE IF ( D_VAR(i)*step .GT. fast) THEN ! FAST SPECIES + V2(I) = P_VAR(I)/D_VAR(I) + ELSE ! MEDIUM LIVED + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP*0.5) + V2(i) = tmp * (V2(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP * 0.5 + V2(i) = V2(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + END IF + end do + +C ===== Extrapolation and error estimation ======== + + ERRold=ERR + ERR=0.0D0 + do i=1,NVAR + ERR = ERR + ((V2(i)-V1(i))/(ATOL(i) + RTOL(i)*V2(i)))**2 + end do + ERR = DSQRT( ERR/NVAR ) + STEPold=STEP + +C ===== choosing the stepsize ===================== + + factor = 0.9*ERR**(-0.35)*ERRold**0.2 + if (IsReject) then + facmax=1. + else + facmax=8. + end if + factor = DMAX1( 1.25D-1, DMIN1(factor,facmax) ) + STEP = DMIN1( STEPMAX, DMAX1(STEPMIN,factor*STEP) ) + +C=================================================== + + if ( (ERR.gt.1).and.(STEPold.gt.STEPMIN) ) then + IsReject = .true. + else + IsReject = .false. + do 140 i=1,NVAR + VAR(i) = DMAX1(V2(i), 0.d0) + 140 continue + T = Tplus + end if + if ( T .lt. Tnext ) go to 10 + + TIME = Tnext + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.def new file mode 100755 index 00000000..ed6f40b3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.def @@ -0,0 +1,16 @@ + +#FUNCTION SPLIT +#JACOBIAN OFF +#SPARSEDATA OFF +#DOUBLE ON +#INTFILE qssafix + +#INLINE F_INIT_INT + STEPMIN=0.0001 + STEPMAX=60. +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN=0.0001; + STEPMAX=60.; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.f new file mode 100755 index 00000000..4f0a072e --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/qssafix.f @@ -0,0 +1,56 @@ +C --- Plain QSSA with fixed step size +C + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + +C Local variables + KPP_REAL P_VAR(NVAR), D_VAR(NVAR) + LOGICAL IsReject + KPP_REAL T, Tnext, STEP, Told, SUP + KPP_REAL ratio, tmp + INTEGER i + + T = TIN + Tnext = TOUT + STEP = 0.1 + Told = T + SUP = 1e-14 + IsReject = .false. + +C -- BELOW THIS LIMIT USE TAYLOR INSTEAD OF EXP --- + + do while ( T.lt.Tnext ) + + if ( T.gt.Tnext ) then + STEP = Tnext - Told + T = Tnext + end if + + CALL FSPLIT_VAR ( VAR, P_VAR, D_VAR ) + + do i=1,NVAR + if ( abs(D_VAR(i)).gt.SUP ) then + ratio = P_VAR(i)/D_VAR(i) + tmp = exp(-D_VAR(i)*STEP) + VAR(i) = tmp * (VAR(i) - ratio) + ratio + else + tmp = D_VAR(i) * STEP + VAR(i) = VAR(i) + P_VAR(i) * 0.5 * STEP * ( 1 - 0.5 * tmp * + * ( 1 - 1.0 / 3.0 * tmp ) ) + end if + end do + + T = T + STEP + TIME = T + + end do + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3.c new file mode 100755 index 00000000..92754698 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3.c @@ -0,0 +1,313 @@ + + #define MAX(a,b) ((a) >= (b) ) ?(a):(b) + #define MIN(b,c) ((b) < (c) ) ?(b):(c) + #define abs(x) ((x) >= 0 ) ?(x):(-x) + #define dabs(y) (double)abs(y) + #define DSQRT(d) (double)pow(d,0.5) + + void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + + +void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_PHOTO(); + Fun( Y, FIX, RCONST, P ); + TIME = Told; + } /* function fun ends here */ + +void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_PHOTO(); + Jac_SP( Y, FIX, RCONST, J ); + TIME = Told; + } /* function jac_sp ends here */ + + + INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) + { + /* TIN - Start Time */ + /* TOUT - End Time */ + + int INFO[5]; + + forfun = &FUNC_CHEM; + forjac = &JAC_CHEM; + INFO[0] = Autonomous; + + RODAS3( NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL,RTOL,INFO + ,forfun ,forjac ); + +} + + + +int RODAS3(int N,KPP_REAL T, KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, + KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], + int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []), + void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) + { +/* + Stiffly accurate Rosenbrock 3(2), with + stiffly accurate embedded formula for error control. + + All the arguments aggree with the KPP syntax. + + INPUT ARGUMENTS: + y = Vector of (NVAR) concentrations, contains the + initial values on input + [T, Tnext] = the integration interval + Hmin, Hmax = lower and upper bounds for the selected step-size. + Note that for Step = Hmin the current computed + solution is unconditionally accepted by the error + control mechanism. + AbsTol, RelTol = (NVAR) dimensional vectors of + componentwise absolute and relative tolerances. + FUNC_CHEM = name of routine of derivatives. KPP syntax. + See the header below. + JAC_CHEM = name of routine that computes the Jacobian, in + sparse format. KPP syntax. See the header below. + Info(1) = 1 for autonomous system + = 0 for nonautonomous system + + OUTPUT ARGUMENTS: + y = the values of concentrations at Tend. + T = equals Tend on output. + Info(2) = # of FUNC_CHEM calls. + Info(3) = # of JAC_CHEM calls. + Info(4) = # of accepted steps. + Info(5) = # of rejected steps. + + Adrian Sandu, March 1996 + The Center for Global and Regional Environmental Research +*/ + KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR], K4[NVAR]; + KPP_REAL F1[NVAR], JAC[LU_NONZERO]; + KPP_REAL ghinv,uround,c43,x1,x2,ytol; + KPP_REAL ynew[NVAR]; + KPP_REAL H, Hold, Tplus,tau,tau1,tau2,tau3; + KPP_REAL ERR, factor, facmax; + int n,nfcn,njac,Naccept,Nreject,i,j,ier; + char IsReject,Autonomous; + + + +/* Initialization of counters, etc. */ + Autonomous = (INFO[0] == 1); + uround = (double)1e-15; + c43 = (double)(-8.e0/3.e0); + H = MAX( (double)1e-8, Hstart ); + Hmin = MAX(Hmin,uround*(Tnext-T)); + Hmax = MIN(Hmax,Tnext-T); + Tplus = T; + IsReject = 0; + Naccept = 0; + Nreject = 0; + nfcn = 0; + njac = 0; + + +/* === Starting the time loop === */ + +while(T Tnext ) + { + H = Tnext - T; + Tplus = Tnext; + } + + (*forjac)(NVAR, T, y,JAC ); + + njac = njac+1; + ghinv = (double)-2.0e0/H; + for(j=0;j Hmin ) + { + H = (double)5.0e-1*H; + goto ten; + } + else + printf("IER <> 0 , H = %d", H); + }/* main ier if ends*/ + + + (*forfun)(NVAR , T, y, F1 ) ; + + +/* ====== NONAUTONOMOUS CASE =============== */ + + if( Autonomous == 0) + { + tau = DSQRT( uround*MAX( (double)1.0e-5, dabs(T) ) ); + (*forfun)(NVAR , T+tau , y ,K2 ); + nfcn=nfcn+1; + for(j=0;j1) && (Hold>Hmin) ) + { + IsReject = 1; + Nreject = Nreject + 1; + } + else + { + IsReject = 0; + + for(i=0;i 0, H=',H + stop + end if + end if + + CALL FUNC_CHEM(NVAR, T, y, F1) + +C ====== NONAUTONOMOUS CASE =============== + IF (.not. Autonomous) THEN + tau = DSQRT( uround*DMAX1( 1.0d-5, DABS(T) ) ) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + nfcn=nfcn+1 + do 30 j = 1,NVAR + K3(j) = ( K2(j)-F1(j) )/tau + 30 continue + +C ----- STAGE 1 (NONAUTONOMOUS) ----- + x1 = 0.5*H + do 40 j = 1,NVAR + K1(j) = F1(j) + x1*K3(j) + 40 continue + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 (NONAUTONOMOUS) ----- + x1 = 4.d0/H + x2 = 1.5d0*H + do 50 j = 1,NVAR + K2(j) = F1(j) - x1*K1(j) + x2*K3(j) + 50 continue + CALL KppSolve (JAC, K2) + +C ====== AUTONOMOUS CASE =============== + ELSE +C ----- STAGE 1 (AUTONOMOUS) ----- + do 60 j = 1,NVAR + K1(j) = F1(j) + 60 continue + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 (AUTONOMOUS) ----- + x1 = 4.d0/H + do 70 j = 1,NVAR + K2(j) = F1(j) - x1*K1(j) + 70 continue + CALL KppSolve (JAC, K2) + END IF + +C ----- STAGE 3 ----- + do 80 j = 1,NVAR + ynew(j) = y(j) - 2.0d0*K1(j) + 80 continue + CALL FUNC_CHEM(NVAR, T+H, ynew, F1) + nfcn=nfcn+1 + do 90 j = 1,NVAR + K3(j) = F1(j) + ( -K1(j) + K2(j) )/H + 90 continue + CALL KppSolve (JAC, K3) + +C ----- STAGE 4 ----- + do 100 j = 1,NVAR + ynew(j) = y(j) - 2.0d0*K1(j) - K3(j) + 100 continue + CALL FUNC_CHEM(NVAR, T+H, ynew, F1) + nfcn=nfcn+1 + do 110 j = 1,NVAR + K4(j) = F1(j) + ( -K1(j) + K2(j) - C43*K3(j) )/H + 110 continue + CALL KppSolve (JAC, K4) + +C ---- The Solution --- + + do 120 j = 1,NVAR + ynew(j) = y(j) - 2.0d0*K1(j) - K3(j) - K4(j) + 120 continue + + +C ====== Error estimation ======== + + ERR=0.d0 + do 130 i=1,NVAR + ytol = AbsTol(i) + RelTol(i)*DABS(ynew(i)) + ERR = ERR + ( K4(i)/ytol )**2 + 130 continue + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + elo = 3.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 140 i=1,NVAR + y(i) = ynew(i) + 140 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + + +C ======= End of the time loop =============================== + if ( T .lt. Tnext ) go to 10 + + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.def new file mode 100755 index 00000000..8aefee2d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.def @@ -0,0 +1,52 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE rodas3_ddm +#HESSIAN ON + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=1.e-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT + int Autonomous; + double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.f new file mode 100755 index 00000000..f4906c33 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/rodas3_ddm.f @@ -0,0 +1,592 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT +C Y - Concentrations and Sensitivities + KPP_REAL Y(NVAR*(NSENSIT+1)) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL RODAS3_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,Y,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + + RETURN + END + + + + + SUBROUTINE RODAS3_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INCLUDE 'KPP_ROOT_sparse.h' +C +C Stiffly accurate Rosenbrock 3(2), with +C stiffly accurate embedded formula for error control. +C +C Direct decoupled computation of sensitivities. +C The global variable DDMTYPE distinguishes between: +C DDMTYPE = 0 : sensitivities w.r.t. initial values +C DDMTYPE = 1 : sensitivities w.r.t. parameters +C +C INPUT ARGUMENTS: +C y = Vector of: (1:NVAR) concentrations, followed by +C (1:NVAR) sensitivities w.r.t. first parameter, followed by +C etc., followed by +C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter +C (y contains initial values at input, final values at output) +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations and sensitivities at Tend. +C T = equals TENDon output. +C Info(2) = # of FUNC_CHEM CALLs. +C Info(3) = # of JAC_CHEM CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C +C Adrian Sandu, December 2001 +C + + INTEGER NSENSIT + KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) + KPP_REAL K1(NVAR*(NSENSIT+1)) + KPP_REAL K2(NVAR*(NSENSIT+1)) + KPP_REAL K3(NVAR*(NSENSIT+1)) + KPP_REAL K4(NVAR*(NSENSIT+1)) + KPP_REAL Fv(NVAR), Hv(NVAR) + KPP_REAL DFDT(NVAR*(NSENSIT+1)) + KPP_REAL DJDP(NVAR*NSENSIT) + KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) + KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) + KPP_REAL DJDT(LU_NONZERO) + KPP_REAL HESS(NHESS) + KPP_REAL Hmin,Hmax,Hstart,ghinv,uround + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, Tplus, H, Hnew, elo + KPP_REAL ERR, factor, facmax + KPP_REAL w, e, beta1, beta2, beta3, beta4 + KPP_REAL tau, x1, x2, ytol, dround + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject, Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + +C The method coefficients + DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 + PARAMETER ( gamma = 0.5D+00 ) + PARAMETER ( gamma2 = 1.5D+00 ) + PARAMETER ( gamma3 = 0.0D+00 ) + PARAMETER ( gamma4 = 0.0D+00 ) + DOUBLE PRECISION a21, a31, a32, a41, a42, a43 + PARAMETER ( a21 = 0.0D+00 ) + PARAMETER ( a31 = 2.0D+00 ) + PARAMETER ( a32 = 0.0D+00 ) + PARAMETER ( a41 = 2.0D+00 ) + PARAMETER ( a42 = 0.0D+00 ) + PARAMETER ( a43 = 1.0D+00 ) + DOUBLE PRECISION alpha2, alpha3, alpha4 + PARAMETER ( alpha2 = 0.0D0 ) + PARAMETER ( alpha3 = 1.0D0 ) + PARAMETER ( alpha4 = 1.0D0 ) + DOUBLE PRECISION c21, c31, c32, c41, c42, c43 + PARAMETER ( c21 = 4.0D0 ) + PARAMETER ( c31 = 1.0D0 ) + PARAMETER ( c32 = -1.0D0 ) + PARAMETER ( c41 = 1.0D0 ) + PARAMETER ( c42 = -1.0D0 ) + PARAMETER ( c43 = -2.666666666666667D0 ) + DOUBLE PRECISION b1, b2, b3, b4 + PARAMETER ( b1 = 2.0D+00 ) + PARAMETER ( b2 = 0.0D0 ) + PARAMETER ( b3 = 1.0D0 ) + PARAMETER ( b4 = 1.0D0 ) + DOUBLE PRECISION d1, d2, d3, d4 + PARAMETER ( d1 = 0.0D0 ) + PARAMETER ( d2 = 0.0D0 ) + PARAMETER ( d3 = 0.0D0 ) + PARAMETER ( d4 = 1.0D0 ) + + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + uround = 1.d-15 + dround = DSQRT(uround) + IF (Hmax.le.0.D0) THEN + Hmax = DABS(Tnext-T) + END IF + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 CONTINUE + + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function, Jacobian, and Hessian Values + CALL FUNC_CHEM(NVAR, T, y, Fv) + CALL JAC_CHEM(NVAR, T, y, JAC) + CALL HESS_CHEM( NVAR, T, y, HESS ) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) + END IF + +C The time derivatives for non-Autonomous case + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + CALL JAC_CHEM(NVAR, T+tau, y, AJAC) + nfcn=nfcn+1 + DO 20 j = 1,NVAR + DFDT(j) = ( K2(j)-Fv(j) )/tau + 20 CONTINUE + DO 30 j = 1,LU_NONZERO + DJDT(j) = ( AJAC(j)-JAC(j) )/tau + 30 CONTINUE + DO 35 i=1,NSENSIT + CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) + 35 CONTINUE + END IF + + 11 CONTINUE ! From here we restart after a rejected step + +C Form the Prediction matrix and compute its LU factorization + Njac = Njac+1 + ghinv = 1.0d0/(gamma*H) + DO 40 j=1,LU_NONZERO + AJAC(j) = -JAC(j) + 40 CONTINUE + DO 50 j=1,NVAR + AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + ghinv + 50 CONTINUE + CALL KppDecomp (AJAC, ier) +C + IF (ier.ne.0) THEN + IF ( H.gt.Hmin) THEN + H = 5.0d-1*H + GO TO 10 + ELSE + PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H + STOP + END IF + END IF + +C ------------ STAGE 1------------------------- + DO 60 j = 1,NVAR + K1(j) = Fv(j) + 60 CONTINUE + IF (.NOT. Autonomous) THEN + beta1 = H*gamma + DO 70 j=1,NVAR + K1(j) = K1(j) + beta1*DFDT(j) + 70 CONTINUE + END IF + CALL KppSolve (AJAC, K1) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + DO 100 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) + DO 80 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) + 80 CONTINUE + IF (.NOT. Autonomous) THEN + DO 90 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + beta1*DFDT(i*NVAR+j) + 90 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 95 j = 1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 95 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K1(i*NVAR+1)) + 100 CONTINUE + +C ----------- STAGE 2 ------------------------- +C Note: uses the same function values as Stage 1 +C DO 110 j = 1,NVAR*(NSENSIT+1) +C ynew(j) = y(j) + a21*K1(j) +C 110 CONTINUE +C CALL FUNC_CHEM(NVAR, T+alpha2*H, ynew, Fv) +C IF (DDMTYPE .EQ. 1) THEN +C CALL DFUNDPAR(NVAR, NSENSIT, T+alpha2*H, ynew, DFDP) +C END IF +C nfcn=nfcn+1 + beta1 = c21/H + DO 120 j = 1,NVAR + K2(j) = Fv(j) + beta1*K1(j) + 120 CONTINUE + IF (.NOT. Autonomous) THEN + beta2 = H*gamma2 + DO 130 j=1,NVAR + K2(j) = K2(j) + beta2*DFDT(j) + 130 CONTINUE + END IF + CALL KppSolve (AJAC, K2) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) + njac=njac+1 + DO 160 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) + DO 140 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + Hv(j) + 140 CONTINUE + IF (.NOT. Autonomous) THEN + DO 150 j=1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + beta2*DFDT(i*NVAR+j) + 150 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 155 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 155 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K2(i*NVAR+1)) + 160 CONTINUE + + +C ------------ STAGE 3 ------------------------- + DO 170 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + a31*K1(j) + a32*K2(j) + 170 CONTINUE + CALL FUNC_CHEM(NVAR, T+alpha3*H, ynew, Fv) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) + END IF + nfcn=nfcn+1 + beta1 = c31/H + beta2 = c32/H + DO 180 j = 1,NVAR + K3(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + 180 CONTINUE + IF (.NOT. Autonomous) THEN + beta3 = H*gamma3 + DO 190 j=1,NVAR + K3(j) = K3(j) + beta3*DFDT(j) + 190 CONTINUE + END IF + CALL KppSolve (AJAC, K3) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+alpha3*H, ynew, JAC) + njac=njac+1 + DO 220 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) + DO 200 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + beta2*K2(i*NVAR+j) + Hv(j) + 200 CONTINUE + IF (.NOT. Autonomous) THEN + DO 210 j=1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + beta3*DFDT(i*NVAR+j) + 210 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 215 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 215 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K3(i*NVAR+1)) + 220 CONTINUE + +C ------------ STAGE 4 ------------------------- + DO 225 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + a41*K1(j) + a42*K2(j) + a43*K3(j) + 225 CONTINUE + CALL FUNC_CHEM(NVAR, T+alpha4*H, ynew, Fv) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+alpha4*H, ynew, DFDP) + END IF + nfcn=nfcn+1 + beta1 = c41/H + beta2 = c42/H + beta3 = c43/H + DO 230 j = 1,NVAR + K4(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + beta3*K3(j) + 230 CONTINUE + IF (.NOT. Autonomous) THEN + beta4 = H*gamma4 + DO 240 j=1,NVAR + K4(j) = K4(j) + beta4*DFDT(j) + 240 CONTINUE + END IF + CALL KppSolve (AJAC, K4) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K4(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + njac=njac+1 + DO 270 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K4(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K4(1), Hv ) + DO 250 j = 1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + beta2*K2(i*NVAR+j) + beta3*K3(i*NVAR+j) + & + Hv(j) + 250 CONTINUE + IF (.NOT. Autonomous) THEN + DO 260 j=1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + beta4*DFDT(i*NVAR+j) + 260 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 265 j = 1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 265 CONTINUE + END IF + CALL KppSolve (AJAC, K4(i*NVAR+1)) + 270 CONTINUE + + +C ---- The Solution --- + DO 280 j = 1,NVAR*(NSENSIT+1) +C ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) + ynew(j) = y(j) + 2*K1(j) + K3(j) + K4(j) + 280 CONTINUE + + +C ====== Error estimation -- can be extended to control sensitivities too ======== + + ERR = 0.d0 + DO 290 i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(ynew(i)),DABS(y(i))) +C e = d1*K1(i) + d2*K2(i) + d3*K3(i) + d4*K4(i) + e = K4(i) + ERR = ERR + ( e/w )**2 + 290 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + elo = 3.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 300 i=1,NVAR*(NSENSIT+1) + y(i) = ynew(i) + 300 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) +C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER N + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) +C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), U(NVAR) + KPP_REAL P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + + SUBROUTINE HESS_CHEM(N, T, Y, HESS) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), HESS(NHESS) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, HESS ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.def new file mode 100755 index 00000000..63de92d4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.def @@ -0,0 +1,50 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros1 + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=30.0 + STEPMAX=30.0 + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=30.0 + STEPMAX=30.0 + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT +int Autonomous; +double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 30.0; + STEPMAX = 30.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.f new file mode 100755 index 00000000..795c07bc --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1.f @@ -0,0 +1,166 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS1(NVAR,TIN,TOUT,STEPMIN,VAR, + + Info,FUNC_CHEM,JAC_CHEM) + + + RETURN + END + + + + + SUBROUTINE ROS1(N,T,Tnext,Hstart, + + y,Info,FUNC_CHEM,JAC_CHEM) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' +C +C Linearly Implicit Euler +C A method of theoretical interest but of no practical value +C +C INPUT ARGUMENTS: +C y = Vector of (NVAR) concentrations, contains the +C initial values on input +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at Tend. +C T = equals TENDon output. +C Info(2) = # of FUNC_CHEM CALLs. +C Info(3) = # of JAC_CHEM CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C Hstart = The last accepted stepsize +C +C Adrian Sandu, December 2001 +C + KPP_REAL Fv(NVAR) + KPP_REAL JAC(LU_NONZERO) + KPP_REAL H, Hstart + KPP_REAL y(NVAR) + KPP_REAL T, Tnext, Tplus + KPP_REAL elo,ghinv,uround + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j + INTEGER Info(5) + LOGICAL IsReject, Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM + + + H = Hstart + Tplus = T + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 CONTINUE + + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function and Jacobian values + CALL FUNC_CHEM(NVAR, T, y, Fv) + Nfcn = Nfcn+1 + CALL JAC_CHEM(NVAR, T, y, JAC) + Njac = Njac+1 + +C Form the Prediction matrix and compute its LU factorization + DO 40 j=1,NVAR + JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) - 1.0d0/H + 40 CONTINUE + CALL KppDecomp (JAC, ier) +C + IF (ier.ne.0) THEN + PRINT *,'ROS1: Singular factorization at T=',T,'; H=',H + STOP + END IF + +C ------------ STAGE 1------------------------- + CALL KppSolve (JAC, Fv) + +C ---- The Solution --- + DO 160 j = 1,NVAR + y(j) = y(j) - Fv(j) + 160 CONTINUE + T = T + H + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Njac + Info(5) = 0 + Hstart = H + + RETURN + END + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.def new file mode 100755 index 00000000..25e7b87f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.def @@ -0,0 +1,50 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros1_ddm + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=30.0 + STEPMAX=30.0 + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=30.0 + STEPMAX=30.0 + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT +int Autonomous; +double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 30.0; + STEPMAX = 30.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.f new file mode 100755 index 00000000..0da726a0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros1_ddm.f @@ -0,0 +1,300 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + + INTEGER NSENSIT +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT +C TOUT - End Time + KPP_REAL Y( NVAR*(NSENSIT+1) ) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + + INFO(1) = Autonomous + + CALL ROS1_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,Y, + + Info,FUNC_CHEM,JAC_CHEM,HESS_CHEM) + + + RETURN + END + + + + + SUBROUTINE ROS1_DDM(N,NSENSIT,T,Tnext,Hstart, + + y,Info,FUNC_CHEM,JAC_CHEM,HESS_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' + INCLUDE 'KPP_ROOT_global.h' +C +C Linearly Implicit Euler with direct-decoupled calculation of sensitivities +C A method of theoretical interest but of no practical value +C +C The global variable DDMTYPE distinguishes between: +C DDMTYPE = 0 : sensitivities w.r.t. initial values +C DDMTYPE = 1 : sensitivities w.r.t. parameters +C +C INPUT ARGUMENTS: +C y = Vector of: (1:NVAR) concentrations, followed by +C (1:NVAR) sensitivities w.r.t. first parameter, followed by +C etc., followed by +C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter +C (y contains initial values at input, final values at output) +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at Tend. +C T = equals TENDon output. +C Info(2) = # of FUNC_CHEM CALLs. +C Info(3) = # of JAC_CHEM CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C Hstart = The last accepted stepsize +C +C Adrian Sandu, December 2001 +C + INTEGER NSENSIT + KPP_REAL Fv(NVAR*(NSENSIT+1)), Hv(NVAR) + KPP_REAL DFDP(NVAR*NSENSIT) + KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) + KPP_REAL HESS(NHESS) + KPP_REAL DJDP(NVAR*NSENSIT) + KPP_REAL H, Hstart + KPP_REAL y(NVAR*(NSENSIT+1)) + KPP_REAL T, Tnext, Tplus + KPP_REAL elo,ghinv,uround + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject, Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + + + H = Hstart + Tplus = T + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 CONTINUE + + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function and Jacobian values + CALL FUNC_CHEM(NVAR, T, y, Fv) + Nfcn = Nfcn+1 + CALL JAC_CHEM(NVAR, T, y, JAC) + Njac = Njac+1 + CALL HESS_CHEM( NVAR, T, y, HESS ) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) + END IF + +C Form the Prediction matrix and compute its LU factorization + DO 40 j=1,LU_NONZERO + AJAC(j) = -JAC(j) + 40 CONTINUE + DO 50 j=1,NVAR + AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + 1.0d0/H + 50 CONTINUE + CALL KppDecomp (AJAC, ier) +C + IF (ier.ne.0) THEN + PRINT *,'ROS1: Singular factorization at T=',T,'; H=',H + STOP + END IF + +C ------------ STAGE 1------------------------- + CALL KppSolve (AJAC, Fv) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, Fv(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + DO 100 i=1,NSENSIT + CALL Jac_SP_Vec (JAC, y(i*NVAR+1), Fv(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), Fv(1), Hv ) + IF (DDMTYPE .EQ. 0) THEN + DO 80 j=1,NVAR + Fv(i*NVAR+j) = Fv(i*NVAR+j) + Hv(j) + 80 CONTINUE + ELSE + DO 90 j=1,NVAR + Fv(i*NVAR+j) = Fv(i*NVAR+j) + Hv(j) + & + DFDP(i*NVAR+j)+ DJDP((i-1)*NVAR+j) + 90 CONTINUE + END IF + CALL KppSolve (AJAC, Fv(i*NVAR+1)) + 100 CONTINUE + +C ---- The Solution --- + DO 160 j = 1,NVAR*(NSENSIT+1) + y(j) = y(j) + Fv(j) + 160 CONTINUE + T = T + H + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) THEN + GO TO 10 + END IF + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) +C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) +C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), U(NVAR) + KPP_REAL P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + + SUBROUTINE HESS_CHEM(N, T, Y, HESS) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), HESS(NHESS) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, HESS ) + TIME = Told + RETURN + END + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.c new file mode 100755 index 00000000..88cc5116 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.c @@ -0,0 +1,311 @@ + + #define MAX(a,b) ((a) >= (b)) ?(a):(b) + #define MIN(b,c) ((b) < (c)) ?(b):(c) + #define abs(x) ((x) >= 0 ) ?(x):(-x) + #define dabs(y) (double)abs(y) + #define DSQRT(d) (double)pow(d,0.5) + #define signum(x)((x) >= 0 ) ?(1):(-1) + + + + void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + + + + +void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_RCONST(); + Fun( Y, FIX, RCONST, P ); + TIME = Told; + } + +void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_RCONST(); + Jac_SP( Y, FIX, RCONST, J ); + TIME = Told; + } + + + + + + INTEGRATE(KPP_REAL TIN,KPP_REAL TOUT ) + { + + /* TIN - Start Time */ + /* TOUT - End Time */ + + + int INFO[5]; + forfun = &FUNC_CHEM; + forjac = &JAC_CHEM; + INFO[0] = Autonomous; + ROS2(NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL + ,RTOL,INFO,forfun,forjac); + + } + + +int ROS2(int N,KPP_REAL T, KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, + KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], + int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []), + void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) + { + + +/* + All the arguments aggree with the KPP syntax. + + INPUT ARGUMENTS: + y = Vector of (NVAR) concentrations, contains the + initial values on input + [T, Tnext] = the integration interval + Hmin, Hmax = lower and upper bounds for the selected step-size. + Note that for Step = Hmin the current computed + solution is unconditionally accepted by the error + control mechanism. + AbsTol, RelTol = (NVAR) dimensional vectors of + componentwise absolute and relative tolerances. + FUNC_CHEM = name of routine of derivatives. KPP syntax. + See the header below. + JAC_CHEM = name of routine that computes the Jacobian, in + sparse format. KPP syntax. See the header below. + Info(1) = 1 for autonomous system + = 0 for nonautonomous system + + OUTPUT ARGUMENTS: + y = the values of concentrations at Tend. + T = equals Tend on output. + Info(2) = # of FUNC_CHEM calls. + Info(3) = # of JAC_CHEM calls. + Info(4) = # of accepted steps. + Info(5) = # of rejected steps. +*/ + + KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR], K4[NVAR]; + KPP_REAL F1[NVAR], JAC[LU_NONZERO]; + KPP_REAL ghinv , uround , dround , c43 , tau; + KPP_REAL ynew[NVAR]; + KPP_REAL H, Hold, Tplus; + KPP_REAL ERR, factor, facmax; + int n,nfcn,njac,Naccept,Nreject,i,j,ier; + char IsReject,Autonomous; + + KPP_REAL gamma, m1, m2, alpha, beta, delta, theta, g[NVAR], x[NVAR]; + +/* Initialization of counters, etc. */ + Autonomous = (INFO[0] == 1); + uround = (double)(1e-15); + + dround = DSQRT(uround); + c43 = (double)(- 8.e0/3.e0); + H = MAX( (double)1.e-8, Hmin ); + Tplus = T; + IsReject = 0; + Naccept = 0; + Nreject = 0; + nfcn = 0; + njac = 0; + gamma = (double)(1.e0 + 1.e0/DSQRT(2.e0)); + +/* === Starting the time loop === */ + while(T < Tnext) + { + ten : + Tplus = T + H; + + if ( Tplus > Tnext ) + { + H = Tnext - T; + Tplus = Tnext; + } + + (*forjac)(NVAR, T, y,JAC ); + + njac = njac+1; + ghinv = (double)(-1.0e0/(gamma*H)); + + + + for(j=0;j Hmin ) + { + H = (double)(5.0e-1*H); + goto ten; + } + else + printf("IER <> 0 , H = %d", H); + + }/* main ier if ends*/ + + + (*forfun)(NVAR , T, y, F1 ) ; + + + + + + +/* ====== NONAUTONOMOUS CASE =============== */ + if(Autonomous == 0) + { + tau =( dround*MAX ((double)1.0e-6, dabs(T)) *signum(T) ); + (*forfun)(NVAR, T+tau, y, K2); + nfcn=nfcn+1; + + for(j = 0;j1) && (Hold>Hmin) ) + { + IsReject = 1; + Nreject = Nreject + 1; + } + else + { + IsReject = 0; + for(i=0;i 0, H=',H + STOP + END IF + END IF + + CALL FUNC_CHEM( T, Y, F1 ) + +C ====== NONAUTONOMOUS CASE =============== + IF (.NOT. Autonomous) THEN + tau = DSIGN(DROUND*DMAX1( 1.0d-6, DABS(T) ), T) + CALL FUNC_CHEM( T+tau, Y, K2) + nfcn=nfcn+1 + DO 30 j = 1,NVAR + DFDT(j) = ( K2(j)-F1(j) )/tau + 30 CONTINUE + END IF ! .NOT.Autonomous + +C ----- STAGE 1 ----- + delta = gamma*H + DO 40 j = 1,NVAR + K1(j) = F1(j) + 40 CONTINUE + IF (.NOT.Autonomous) THEN + DO 45 j = 1,NVAR + K1(j) = K1(j) + delta*DFDT(j) + 45 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 ----- + DO 50 j = 1,NVAR + Ynew(j) = Y(j) + a21*K1(j) + 50 CONTINUE + CALL FUNC_CHEM( T+H, Ynew, F1) + nfcn=nfcn+1 + beta = -c21/H + DO 55 j = 1,NVAR + K2(j) = F1(j) + beta*K1(j) + 55 CONTINUE + IF (.NOT.Autonomous) THEN + delta = -gamma*H + DO 56 j = 1,NVAR + K2(j) = K2(j) + delta*DFDT(j) + 56 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K2) + +C ----- STAGE 3 ----- + IF (Embed3) THEN + beta1 = -c31/H + beta2 = -c32/H + delta = gamma3*H + DO 57 j = 1,NVAR + K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) + 57 CONTINUE + IF (.NOT.Autonomous) THEN + DO 58 j = 1,NVAR + K3(j) = K3(j) + delta*DFDT(j) + 58 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K3) + END IF ! Embed3 + + +C ---- The Solution --- + DO 120 j = 1,NVAR + Ynew(j) = Y(j) + m1*K1(j) + m2*K2(j) + 120 CONTINUE + + +C ====== Error estimation ======== + + ERR=0.d0 + DO 130 i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(Y(i)),DABS(Ynew(i))) + IF ( Embed3 ) THEN + e = d1*K1(i) + d2*K2(i) + d3*K3(i) + ELSE + e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) + END IF ! Embed3 + ERR = ERR + ( e/w )**2 + 130 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + IF ( Embed3 ) THEN + elo = 3.0D0 ! estimator local order + ELSE + elo = 2.0D0 + END IF + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 140 i=1,NVAR + Y(i) = Ynew(i) + 140 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize IF previous step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + +C ======= END of the time loop =============================== + END DO + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + + RETURN + END + + + + SUBROUTINE FUNC_CHEM( T, Y, P ) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM( T, Y, J ) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.f90 new file mode 100755 index 00000000..e6b35f12 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2.f90 @@ -0,0 +1,294 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + USE KPP_ROOT_global + +! TIN - Start Time + KPP_REAL TIN +! TOUT - End Time + KPP_REAL TOUT + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + call ROS2(NVAR,TIN,TOUT,STEPMIN,STEPMAX, & + STEPMIN,VAR,ATOL,RTOL, & + Info,FUNC_CHEM,JAC_CHEM) + + + END SUBROUTINE INTEGRATE + + + + + SUBROUTINE ROS2(N,T,Tnext,Hmin,Hmax,Hstart, & + y,AbsTol,RelTol, & + Info,FUNC_CHEM,JAC_CHEM) + + USE KPP_ROOT_params + USE KPP_ROOT_Jacobian_sparsity + IMPLICIT NONE + +! INPUT ARGUMENTS: +! y = Vector of (NVAR) concentrations, contains the +! initial values on input +! [T, Tnext] = the integration interval +! Hmin, Hmax = lower and upper bounds for the selected step-size. +! Note that for Step = Hmin the current computed +! solution is unconditionally accepted by the error +! control mechanism. +! AbsTol, RelTol = (NVAR) dimensional vectors of +! componentwise absolute and relative tolerances. +! FUNC_CHEM = name of routine of derivatives. KPP syntax. +! See the header below. +! JAC_CHEM = name of routine that computes the Jacobian, in +! sparse format. KPP syntax. See the header below. +! Info(1) = 1 for autonomous system +! = 0 for nonautonomous system +! Info(2) = 1 for third order embedded formula +! = 0 for first order embedded formula +! +! Note: Stage 3 used to build strongly A-stable order 3 formula for error control +! Embed3 = (Info(2).EQ.1) +! if Embed3 = .true. then the third order embedded formula is used +! .false. then a first order embedded formula is used +! +! +! OUTPUT ARGUMENTS: +! y = the values of concentrations at Tend. +! T = equals Tend on output. +! Info(2) = # of FUNC_CHEM calls. +! Info(3) = # of JAC_CHEM calls. +! Info(4) = # of accepted steps. +! Info(5) = # of rejected steps. + + KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) + KPP_REAL F1(NVAR), JAC(LU_NONZERO) + KPP_REAL DFDT(NVAR) + KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround + KPP_REAL y(NVAR), ynew(NVAR) + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, H, Hold, Tplus + KPP_REAL ERR, factor, facmax + KPP_REAL tau, beta, elo, dround, a21, c31, c32 + KPP_REAL gamma3, d1, d2, d3, gam + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject, Autonomous, Embed3 + EXTERNAL FUNC_CHEM, JAC_CHEM + + KPP_REAL gamma, m1, m2, alpha, beta1, beta2, delta, w, e + +! Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + Embed3 = Info(2) .EQ. 1 + uround = 1.d-15 + dround = dsqrt(uround) + H = DMAX1(1.d-8, Hmin) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +! Method Parameters + gamma = 1.d0 + 1.d0/sqrt(2.d0) + a21 = - 1.d0/gamma + m1 = -3.d0/(2.d0*gamma) + m2 = -1.d0/(2.d0*gamma) + c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) & + /(-1.0D0+2.0D0*gamma) + c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) & + /(-1.0D0+2.0D0*gamma)/2 + gamma3 = 0.5D0 - 2*gamma + d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ & + (-1.0D0+2*gamma))/6.0D0 + d2 = ((-1.0D0+3.0D0*gamma)/gamma**2/(-1.0D0+2.0D0*gamma))/6.0D0 + d3 = -1.0D0/(3.0D0*gamma) + +! === Starting the time loop === + 10 CONTINUE + Tplus = T + H + if ( Tplus .gt. Tnext ) then + H = Tnext - T + Tplus = Tnext + end if + + call JAC_CHEM(NVAR, T, y, JAC) + + Njac = Njac+1 + ghinv = -1.0d0/(gamma*H) + DO j=1,NVAR + JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv + END DO + CALL KppDecomp (JAC, ier) + + if (ier.ne.0) then + if ( H.gt.Hmin) then + H = 5.0d-1*H + go to 10 + else + print *,'IER <> 0, H=',H + stop + end if + end if + + call FUNC_CHEM(NVAR, T, y, F1) + +! ====== NONAUTONOMOUS CASE =============== + IF (.not. Autonomous) THEN + tau = dsign(dround*dmax1( 1.0d-6, dabs(T) ), T) + call FUNC_CHEM(NVAR, T+tau, y, K2) + nfcn=nfcn+1 + DO j = 1,NVAR + DFDT(j) = ( K2(j)-F1(j) )/tau + END DO + END IF ! .NOT.Autonomous + +! ----- STAGE 1 ----- + DO j = 1,NVAR + K1(j) = F1(j) + END DO + IF (.NOT.Autonomous) THEN + delta = gamma*H + DO j = 1,NVAR + K1(j) = K1(j) + delta*DFDT(j) + END DO + END IF ! .NOT.Autonomous + call KppSolve (JAC, K1) + +! ----- STAGE 2 ----- + DO j = 1,NVAR + ynew(j) = y(j) + a21*K1(j) + END DO + call FUNC_CHEM(NVAR, T+H, ynew, F1) + nfcn=nfcn+1 + beta = 2.d0/(gamma*H) + DO j = 1,NVAR + K2(j) = F1(j) + beta*K1(j) + END DO + IF (.NOT. Autonomous) THEN + delta = -gamma*H + DO j = 1,NVAR + K2(j) = K2(j) + delta*DFDT(j) + END DO + END IF ! .NOT.Autonomous + call KppSolve (JAC, K2) + +! ----- STAGE 3 ----- + IF (Embed3) THEN + beta1 = -c31/H + beta2 = -c32/H + delta = gamma3*H + DO j = 1,NVAR + K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) + END DO + IF (.NOT.Autonomous) THEN + DO j = 1,NVAR + K3(j) = K3(j) + delta*DFDT(j) + END DO + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K3) + END IF ! Embed3 + + + +! ---- The Solution --- + DO j = 1,NVAR + ynew(j) = y(j) + m1*K1(j) + m2*K2(j) + END DO + + +! ====== Error estimation ======== + + ERR=0.d0 + DO i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) + IF ( Embed3 ) THEN + e = d1*K1(i) + d2*K2(i) + d3*K3(i) + ELSE + e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) + END IF ! Embed3 + ERR = ERR + ( e/w )**2 + END DO + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +! ======= Choose the stepsize =============================== + + IF ( Embed3 ) THEN + elo = 3.0D0 ! estimator local order + ELSE + elo = 2.0D0 + END IF + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +! ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO i=1,NVAR + y(i) = ynew(i) + END DO + T = Tplus + IF (.NOT. IsReject) THEN + H = Hnew ! Do not increase stepsize if previous step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + + +! ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + + + +! ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + + END SUBROUTINE Ros2 + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + USE KPP_ROOT_global + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + END SUBROUTINE FUNC_CHEM + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + USE KPP_ROOT_global + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + END SUBROUTINE JAC_CHEM + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_cts_adj.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_cts_adj.f new file mode 100755 index 00000000..353a0938 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_cts_adj.f @@ -0,0 +1,312 @@ + SUBROUTINE ros2_cts_adj(N,T,Tnext,Hmin,Hmax,Hstart, + + y,Lambda,Fix,Rconst,AbsTol,RelTol, + + Info) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C INPUT ARGUMENTS: +C y = Vector of (NVAR) concentrations, contains the +C initial values on input +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUN = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_SP = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for autonomous system +C = 0 for nonautonomous system +C Info(2) = 1 for third order embedded formula +C = 0 for first order embedded formula +C +C Note: Stage 3 used to build strongly A-stable order 3 formula for error control +C Embed3 = (Info(2).EQ.1) +C IF Embed3 = .true. THEN the third order embedded formula is used +C .false. THEN a first order embedded formula is used +C +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at TEND. +C T = equals TEND on output. +C Info(2) = # of FUN CALLs. +C Info(3) = # of JAC_SP CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. + + INTEGER max_no_steps + PARAMETER (max_no_steps = 200) + KPP_REAL Trajectory(NVAR,max_no_steps) + KPP_REAL StepSize(max_no_steps) + + KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) + KPP_REAL F1(NVAR), JAC(LU_NONZERO) + KPP_REAL DFDT(NVAR)(NRAD) + KPP_REAL Fix(NFIX), Rconst(NREACT) + KPP_REAL Hmin,Hmax,Hstart,ghinv,uround + KPP_REAL y(NVAR), Ynew(NVAR) + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, H, Hold, Tplus + KPP_REAL ERR, factor, facmax + KPP_REAL Lambda(NVAR), K11(NVAR), JAC1(LU_NONZERO) + INTEGER n,nfcn,njac,Naccept,Nreject,i,j + INTEGER Info(5) + LOGICAL IsReject, Autonomous, Embed3 + EXTERNAL FUN, JAC_SP + + KPP_REAL gamma, m1, m2, alpha, beta1, beta2, delta, w, e + KPP_REAL ginv +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + Embed3 = Info(2) .EQ. 1 + uround = 1.d-15 + dround = dsqrt(uround) + H = DMAX1(Hstart,DMAX1(1.d-8, Hmin)) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +C Method Parameters + gamma = 1.d0 + 1.d0/sqrt(2.d0) + a21 = - 1.d0/gamma + m1 = -3.d0/(2.d0*gamma) + m2 = -1.d0/(2.d0*gamma) + c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) + & /(-1.0D0+2.0D0*gamma) + c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) + & /(-1.0D0+2.0D0*gamma)/2 + gamma3 = 0.5D0 - 2*gamma + d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ + & (-1.0D0+2*gamma))/6.0D0 + d2 = ((-1.0D0+3.0D0*gam)/gamma**2/ + & (-1.0D0+2.0D0*gamma))/6.0D0 + d3 = -1.0D0/(3.0D0*gamma) + + Trajectory(1:NVAR,1) = Ynew(1) + +C === Starting the time loop === + 10 CONTINUE + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + + CALL Jac_SP( Y, Fix, Rconst, JAC ) + + Njac = Njac+1 + ghinv = -1.0d0/(gamma*H) + DO 20 j=1,NVAR + JAC(LU_DIAG_V(j)) = JAC(LU_DIAG_V(j)) + ghinv + 20 CONTINUE + CALL KppDecomp (NVAR, JAC, ier) + + IF (ier.ne.0) THEN + IF ( H.gt.Hmin) THEN + H = 5.0d-1*H + GO TO 10 + else + PRINT *,'IER <> 0, H=',H + STOP + END IF + END IF + + CALL Fun( Y, Fix, Rconst, F1 ) + +C ====== NONAUTONOMOUS CASE =============== + IF (.not. Autonomous) THEN + tau = dsign(dround*dmax1( 1.0d-6, dabs(T) ), T) + CALL Fun( Y, Fix, Rconst, K2 ) + nfcn=nfcn+1 + DO 30 j = 1,NVAR + DFDT(j) = ( K2(j)-F1(j) )/tau + 30 CONTINUE + END IF ! .NOT.Autonomous + +C ----- STAGE 1 ----- + DO 40 j = 1,NVAR + K1(j) = F1(j) + 40 CONTINUE + IF (.NOT.Autonomous) THEN + delta = gamma*H + DO 45 j = 1,NVAR + K1(j) = K1(j) + delta*DFDT(j) + 45 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 ----- + DO 50 j = 1,NVAR + Ynew(j) = y(j) + a21*K1(j) + 50 CONTINUE + CALL Fun( Ynew, Fix, Rconst, F1 ) + nfcn=nfcn+1 + beta = 2.d0/(gamma*H) + delta = -gamma*H + DO 55 j = 1,NVAR + K2(j) = F1(j) + beta*K1(j) + 55 CONTINUE + IF (.NOT.Autonomous) THEN + DO 56 j = 1,NVAR + K2(j) = K2(j) + delta*DFDT(j) + 56 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K2) + +C ----- STAGE 3 ----- + IF (Embed3) THEN + beta1 = -c31/H + beta2 = -c32/H + delta = gamma3*H + DO 57 j = 1,NVAR + K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) + 57 CONTINUE + IF (.NOT.Autonomous) THEN + DO 58 j = 1,NVAR + K3(j) = K3(j) + delta*DFDT(j) + 58 CONTINUE + END IF ! .NOT.Autonomous + CALL KppSolve (JAC, K3) + END IF ! Embed3 + + +C ---- The Solution --- + DO 120 j = 1,NVAR + Ynew(j) = y(j) + m1*K1(j) + m2*K2(j) + 120 CONTINUE + + +C ====== Error estimation ======== + + ERR=0.d0 + DO 130 i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(Ynew(i))) + IF ( Embed3 ) THEN + e = d1*K1(i) + d2*K2(i) + d3*K3(i) + ELSE + e = 1.d0/(2.d0*gamma)*(K1(i)+K2(i)) + END IF ! Embed3 + ERR = ERR + ( e/w )**2 + 130 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + IF ( Embed3 ) THEN + elo = 3.0D0 ! estimator local order + ELSE + elo = 2.0D0 + END IF + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + Hold = H + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 140 i=1,NVAR + y(i) = Ynew(i) + 140 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize IF previous step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + IF (Naccept+1>max_no_steps) THEN + PRINT*,'Error in Adjoint Ros2: more steps than allowed' + STOP + END IF + Trajectory(1:NVAR,Naccept+1) = Ynew(1:NVAR) + StepSize(Naccept) = Hold +! CALL TRAJISTORE(y,hold) + END IF +C ======= END of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + + ginv = 1.d0/gamma +C -- The backwards loop for the CONTINUOUS ADJOINT + DO istep = Naccept,1,-1 + + h = StepSize(istep) + y(1:NVAR) = Trajectory(1:NVAR,istep+1) + gHinv = -ginv/H + + CALL Jac_SP(Y, Fix, Rconst, JAC) + JAC1(1:LU_NONZERO)=JAC(1:LU_NONZERO) + DO j=1,NVAR + JAC(lu_diag_v(j)) = JAC(lu_diag_v(j)) + gHinv + END DO + CALL KppDecomp (NVAR,JAC,ier) +ccc equivalent to function evaluation in forward integration +ccc is J^T*Lambda in backward integration + CALL JacTR_SP_Vec ( JAC1, Lambda, F1) + +C ----- STAGE 1 (AUTONOMOUS) ----- + K11(1:NVAR) = F1(1:NVAR) + CALL KppSolveTR (JAC,K11,K1) +C ----- STAGE 2 (AUTONOMOUS) ----- + y(1:NVAR) = Trajectory(1:NVAR,istep) + CALL Jac_SP(Y, Fix, Rconst, JAC1) + Ynew(1:NVAR) = Lambda(1:NVAR) - ginv*K1(1:NVAR) + CALL JacTR_SP_Vec ( JAC1, Ynew, F1) + beta = -2.d0*ghinv + K11(1:NVAR) = F1(1:NVAR) + beta*K1(1:NVAR) + CALL KppSolveTR (JAC,K11,K2) +c ---- The solution + Lambda(1:NVAR) = Lambda(1:NVAR)+m1*K1(1:NVAR)+m2*K2(1:NVAR) + + END DO ! istep + + + RETURN + END + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.def new file mode 100755 index 00000000..a4ec8079 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.def @@ -0,0 +1,50 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros2_ddm +#HESSIAN ON + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT + int Autonomous; + double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.f new file mode 100755 index 00000000..2997e1b2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros2_ddm.f @@ -0,0 +1,480 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + + INTEGER NSENSIT +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT +C Y - Concentrations and Sensitivities + KPP_REAL Y(NVAR*(NSENSIT+1)) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS2_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,Y,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + + RETURN + END + + + + + SUBROUTINE ROS2_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INCLUDE 'KPP_ROOT_sparse.h' +C +C Ros2 with direct-decoupled calculation of sensitivities +C +C The global variable DDMTYPE distinguishes between: +C DDMTYPE = 0 : sensitivities w.r.t. initial values +C DDMTYPE = 1 : sensitivities w.r.t. parameters +C +C INPUT ARGUMENTS: +C y = Vector of: (1:NVAR) concentrations, followed by +C (1:NVAR) sensitivities w.r.t. first parameter, followed by +C etc., followed by +C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter +C (y contains initial values at input, final values at output) +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for autonomous system +C = 0 for nonautonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at TEND. +C T = equals TEND on output. +C Info(2) = # of FUNC_CHEM calls. +C Info(3) = # of JAC_CHEM calls. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C +C Adrian Sandu, December 2001 + + + INTEGER NSENSIT + KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) + KPP_REAL K1(NVAR*(NSENSIT+1)) + KPP_REAL K2(NVAR*(NSENSIT+1)) + KPP_REAL K3(NVAR) + KPP_REAL DFDT(NVAR*(NSENSIT+1)) + KPP_REAL DFDP(NVAR*NSENSIT+1), DFDPDT(NVAR*NSENSIT+1) + KPP_REAL DJDP(NVAR*NSENSIT+1) + KPP_REAL F1(NVAR), F2(NVAR) + KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) + KPP_REAL DJDT(LU_NONZERO) + KPP_REAL HESS(NHESS) + KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, H, Hold, Tplus, e + KPP_REAL ERR, factor, facmax, dround, elo, tau, gam + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject,Autonomous,Embed3 + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + + LOGICAL negative + KPP_REAL gamma, m1, m2, alpha, beta, delta, theta, w + KPP_REAL gamma3, d1, d2, d3, beta1, beta2 + KPP_REAL c31, c32, c34 + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + Embed3 = Info(2) .EQ. 1 + uround = 1.d-15 + dround = 1.0d-7 ! DSQRT(uround) + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + gamma = 1.d0 + 1.d0/DSQRT(2.0d0) + c31 = -1.0D0/gamma**2*(1.0D0-7.0D0*gamma+9.0D0*gamma**2) + & /(-1.0D0+2.0D0*gamma) + c32 = -1.0D0/gamma**2*(1.0D0-6.0D0*gamma+6.0D0*gamma**2) + & /(-1.0D0+2.0D0*gamma)/2 + gamma3 = 0.5D0 - 2*gamma + d1 = ((-9.0D0*gamma+8.0D0*gamma**2+2.0D0)/gamma**2/ + & (-1.0D0+2*gamma))/6.0D0 + d2 = ((-1.0D0+3.0D0*gamma)/gamma**2/ + & (-1.0D0+2.0D0*gamma))/6.0D0 + d3 = -1.0D0/(3.0D0*gamma) + m1 = -3.d0/(2.d0*gamma) + m2 = -1.d0/(2.d0*gamma) + + +C === Starting the time loop === + 10 CONTINUE + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function, Jacobian, and Hessian Values + CALL FUNC_CHEM(NVAR, T, y, F1) + CALL JAC_CHEM(NVAR, T, y, JAC) + CALL HESS_CHEM( NVAR, T, y, HESS ) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) + END IF + +C Estimate the time derivatives in non-autonomous case + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + nfcn=nfcn+1 + CALL JAC_CHEM(NVAR, T+tau, y, AJAC) + njac=njac+1 + DO 20 j = 1,NVAR + DFDT(j) = ( K2(j)-F1(j) )/tau + 20 CONTINUE + DO 30 j = 1,LU_NONZERO + DJDT(j) = ( AJAC(j)-JAC(j) )/tau + 30 CONTINUE + DO 40 i=1,NSENSIT + CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) + 40 CONTINUE + END IF ! .not. Autonomous + + Njac = Njac+1 + ghinv = - 1.0d0/(gamma*H) + DO 50 j=1,LU_NONZERO + AJAC(j) = JAC(j) + 50 CONTINUE + DO 60 j=1,NVAR + AJAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv + 60 CONTINUE + CALL KppDecomp (AJAC, ier) + + IF (ier.ne.0) THEN + IF ( H.gt.Hmin) THEN + H = 5.0d-1*H + go to 10 + ELSE + print *,'IER <> 0, H=',H + stop + END IF + END IF + + + + +C ----- STAGE 1 ----- + delta = gamma*H + DO 70 j = 1,NVAR + K1(j) = F1(j) + 70 CONTINUE + IF (.NOT. Autonomous) THEN + DO 80 j = 1,NVAR + K1(j) = K1(j) + delta*DFDT(j) + 80 CONTINUE + END IF + CALL KppSolve (AJAC, K1) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + DO 120 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) + CALL Hess_Vec ( HESS, K1(1), y(i*NVAR+1), F2 ) + DO 90 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + gHinv*F2(j) + 90 CONTINUE + IF (.NOT. Autonomous) THEN + DO 100 j = 1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + delta*DFDT(i*NVAR+j) + 100 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 110 j = 1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 110 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K1(i*NVAR+1)) + 120 CONTINUE + +C ----- STAGE 2 ----- + alpha = - 1.d0/gamma + DO 130 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + alpha*K1(j) + 130 CONTINUE + CALL FUNC_CHEM(NVAR, T+H, ynew, F1) + IF (DDMTYPE.EQ.1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+H, ynew, DFDP) + END IF + nfcn=nfcn+1 + beta1 = 2.d0/(gamma*H) + delta = -gamma*H + DO 140 j = 1,NVAR + K2(j) = F1(j) + beta1*K1(j) + 140 CONTINUE + IF (.NOT. Autonomous) THEN + DO 150 j = 1,NVAR + K2(j) = K2(j) + delta*DFDT(j) + 150 CONTINUE + END IF + CALL KppSolve (AJAC, K2) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+H, Ynew, JAC) + njac=njac+1 + DO 190 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) + CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),F1) + CALL Hess_Vec ( HESS, K2(1), y(i*NVAR+1), F2 ) + DO 160 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + gHinv*F2(j) + 160 CONTINUE + IF (.NOT. Autonomous) THEN + DO 170 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + delta*DFDT(i*NVAR+j) + 170 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 180 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 180 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K2(i*NVAR+1)) + 190 CONTINUE + +C ----- STAGE 3 for error control only ----- + IF (Embed3) THEN + beta1 = -c31/H + beta2 = -c32/H + delta = gamma3*H + DO 195 j = 1,NVAR + K3(j) = F1(j) + beta1*K1(j) + beta2*K2(j) + 195 CONTINUE + IF (.NOT. Autonomous) THEN + DO 196 j = 1,NVAR + K3(j) = K3(j) + delta*DFDT(j) + 196 CONTINUE + END IF + CALL KppSolve (AJAC, K3) + END IF + +C ---- The Solution --- + DO 200 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + m1*K1(j) + m2*K2(j) + 200 CONTINUE + + +C ====== Error estimation for concentrations only; this can be easily adapted to +C estimate the sensitivity error too ======== + + ERR=0.d0 + DO 210 i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) + IF (Embed3) THEN + e = d1*K1(i) + d2*K2(i) + d3*K3(i) + ELSE + e = (1.d0/(2.d0*gamma))*(K1(i)+K2(i)) + END IF + ERR = ERR + ( e/w )**2 + 210 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + IF (Embed3) THEN + elo = 3.0D0 ! estimator local order + ELSE + elo = 2.0D0 + END IF + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 300 i=1,NVAR*(NSENSIT+1) + y(i) = ynew(i) + 300 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previous step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) +C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) +C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), U(NVAR) + KPP_REAL P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + SUBROUTINE HESS_CHEM(N, T, Y, HESS) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), HESS(NHESS) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, HESS ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.c new file mode 100755 index 00000000..da6b1272 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.c @@ -0,0 +1,344 @@ + + #define MAX(a,b) ((a) >= (b)) ?(a):(b) + #define MIN(b,c) ((b) < (c)) ?(b):(c) + #define abs(x) ((x) >= 0 ) ?(x):(-x) + #define dabs(y) (double)abs(y) + #define DSQRT(d) (double)pow(d,0.5) + #define signum(x)((x) >= 0 ) ?(1):(-1) + + void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []); + + + + void FUNC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL P[NVAR]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_PHOTO(); + Fun( Y, FIX, RCONST, P ); + TIME = Told; + }/* function fun ends here */ + + + void JAC_CHEM(int N,KPP_REAL T,KPP_REAL Y[NVAR],KPP_REAL J[LU_NONZERO]) + { + KPP_REAL Told; + Told = TIME; + TIME = T; + Update_SUN(); + Update_PHOTO(); + Jac_SP( Y, FIX, RCONST, J ); + TIME = Told; + } + + + INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) + { + + /* TIN - Start Time */ + /* TOUT - End Time */ + + int INFO[5]; + forfun = &FUNC_CHEM; + forjac = &JAC_CHEM; + INFO[0] = Autonomous; + ROS3(NVAR,TIN,TOUT,STEPMIN,STEPMAX,STEPMIN,VAR,ATOL,RTOL,INFO + ,forfun,forjac); + } /* function integrate ends here */ + + + +int ROS3(int N,KPP_REAL T,KPP_REAL Tnext,KPP_REAL Hmin,KPP_REAL Hmax, +KPP_REAL Hstart,KPP_REAL y[NVAR],KPP_REAL AbsTol[NVAR],KPP_REAL RelTol[NVAR], +int INFO[5],void (*forfun)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) , +void (*forjac)(int,KPP_REAL,KPP_REAL [],KPP_REAL []) ) + { + +/* + + L-stable Rosenbrock 3(2), with + strongly A-stable embedded formula for error control. + + All the arguments aggree with the KPP syntax. + + INPUT ARGUMENTS: + y = Vector of (NVAR) concentrations, contains the + initial values on input + [T, Tnext] = the integration interval + Hmin, Hmax = lower and upper bounds for the selected step-size. + Note that for Step = Hmin the current computed + solution is unconditionally accepted by the error + control mechanism. + AbsTol, RelTol = (NVAR) dimensional vectors of + componentwise absolute and relative tolerances. + FUNC_CHEM = name of routine of derivatives. KPP syntax. + See the header below. + JAC_CHEM = name of routine that computes the Jacobian, in + sparse format. KPP syntax. See the header below. + Info(1) = 1 for autonomous system + = 0 for nonautonomous system + + OUTPUT ARGUMENTS: + y = the values of concentrations at Tend. + T = equals Tend on output. + Info(2) = # of FUNC_CHEM calls. + Info(3) = # of JAC_CHEM calls. + Info(4) = # of accepted steps. + Info(5) = # of rejected steps. + + Adrian Sandu, April 1996 + The Center for Global and Regional Environmental Research +*/ + + KPP_REAL K1[NVAR], K2[NVAR], K3[NVAR]; + KPP_REAL F1[NVAR], JAC[LU_NONZERO]; + KPP_REAL ghinv,uround,dround,c43,x1,x2,x3,ytol; + KPP_REAL gam,c21,c31,c32,b1,b2,b3,d1,d2,d3,a21,a31,a32,alpha2,alpha3, + g1,g2,g3; + KPP_REAL ynew[NVAR]; + KPP_REAL H, Hold, Tplus,tau; + KPP_REAL ERR, factor, facmax; + int n,nfcn,njac,Naccept,Nreject,i,j,ier; + char IsReject,Autonomous; + + +/* Initialization of counters, etc. */ + Autonomous = (INFO[0] == 1); + uround = (double)1.e-15; + dround = DSQRT(uround); + H = MAX( (double)1.e-8, Hstart); + Tplus = T; + IsReject = 0; + Naccept = 0; + Nreject = 0; + nfcn = 0; + njac = 0; + gam = (double) (.43586652150845899941601945119356e+00); + c21 = (double) -(.10156171083877702091975600115545e+01); + c31 = (double) (.40759956452537699824805835358067e+01); + c32 = (double) (.92076794298330791242156818474003e+01); + b1 = (double) (.10000000000000000000000000000000e+01); + b2 = (double) (.61697947043828245592553615689730e+01); + b3 = (double) -(.42772256543218573326238373806514e+00); + d1 = (double) (.50000000000000000000000000000000e+00); + d2 = (double) -(.29079558716805469821718236208017e+01); + d3 = (double) (.22354069897811569627360909276199e+00); + a21 = (double) 1.e0; + a31 = (double) 1.e0; + a32 = (double) 0.e0; + alpha2 = gam; + alpha3 = gam; + g1 = (double) (.43586652150845899941601945119356e+00); + g2 = (double) (.24291996454816804366592249683314e+00); + g3 = (double) (.21851380027664058511513169485832e+01); + + +/* === Starting the time loop === */ + +while( T < Tnext ) + { + ten : + Tplus = T + H; + + if ( Tplus > Tnext ) + { + H = Tnext - T; + Tplus = Tnext; + } + + (*forjac)(NVAR, T, y, JAC); + + njac = njac+1; + ghinv = (double)-1.0e0/(gam*H); + + for(j=0;j Hmin ) + { + H = (double)5.0e-1*H; + goto ten; + } + else + { + printf("IER <> 0 , H = %d", H); + } + }/* main ier if ends*/ + + + (*forfun)(NVAR, T, y, F1); + + +/* ====== NONAUTONOMOUS CASE =============== */ + if( Autonomous == 0 ) + { + tau =(double) (dround*MAX( (double)1.0e-6, dabs(T) ) * signum(T) ); + + (*forfun)(NVAR, T+tau, y, K2); + + nfcn=nfcn+1; + + for(j=0;j /lib/libm.so.6 (0x40015000) + libc.so.6 => /lib/libc.so.6 (0x40032000) + /lib/ld-linux.so.2 => /lib/ld-linux.so.2 (0x40000000) +*/ + +/* ======= Choose the stepsize =============================== */ + + factor = 0.9/pow( ERR , (1.e0/3.e0) ); + if(IsReject == 1) + facmax = (double)1.0; + + else + facmax = (double)10.0; + + + factor = (double)MAX( 1.0e-1, MIN(factor,facmax) ); + Hold = H; + H = (double)MIN( Hmax, MAX(Hmin,factor*H) ); + + +/* ======= Rejected/Accepted Step ============================ */ + + if ( (ERR > 1) && (Hold > Hmin) ) + { + IsReject = 1; + Nreject = Nreject+1; + } + else + { + IsReject = 0; + + for(i = 0;i < NVAR;i++) + y[i] = ynew[i]; + + T = Tplus; + Naccept = Naccept+1; + + }/* else should end here */ + + +/* ======= End of the time loop =============================== */ + + } /* while loop (T < Tnext) ends here */ + + +/* ======= Output Information ================================= */ + INFO[1] = nfcn; + INFO[2] = njac; + INFO[3] = Naccept; + INFO[4] = Nreject; + + } /* function rodas ends here */ + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.def new file mode 100755 index 00000000..d179b6c6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.def @@ -0,0 +1,46 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros3 + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE F90_DECL_INT + INTEGER Autonomous + DOUBLE PRECISION STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE C_DECL_INT + int Autonomous; + double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN=1e-4; + STEPMAX=3600.; + Autonomous = 0; + STEPSTART=STEPMIN; +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.f new file mode 100755 index 00000000..0b773588 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3.f @@ -0,0 +1,304 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS3(NVAR,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,VAR,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + RETURN + END + + + SUBROUTINE ROS3(N,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' + +C L-stable Rosenbrock 3(2), with +C strongly A-stable embedded formula for error control. +C +C All the arguments aggree with the KPP syntax. +C +C INPUT ARGUMENTS: +C y = Vector of (NVAR) concentrations, contains the +C initial values on input +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for autonomous system +C = 0 for nonautonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at Tend. +C T = equals Tend on output. +C Info(2) = # of FUNC_CHEM calls. +C Info(3) = # of JAC_CHEM calls. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C +C Adrian Sandu, April 1996 +C The Center for Global and Regional Environmental Research + + KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR) + KPP_REAL F1(NVAR), JAC(LU_NONZERO) + KPP_REAL Hmin,Hmax,Hnew,Hstart,ghinv,uround + KPP_REAL y(NVAR), ynew(NVAR) + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, Tplus, H, elo + KPP_REAL ERR, factor, facmax + KPP_REAL gam, c21, c31, c32, b1, b2, b3 + KPP_REAL d1, d2, d3, a21, a31, a32 + KPP_REAL alpha2, alpha3, g1, g2, g3 + KPP_REAL tau, x1, x2, x3, dround, ytol + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject,Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM + + gam= .43586652150845899941601945119356d+00 + c21= -.10156171083877702091975600115545d+01 + c31= .40759956452537699824805835358067d+01 + c32= .92076794298330791242156818474003d+01 + b1= .10000000000000000000000000000000d+01 + b2= .61697947043828245592553615689730d+01 + b3= -.42772256543218573326238373806514d+00 + d1= .50000000000000000000000000000000d+00 + d2= -.29079558716805469821718236208017d+01 + d3= .22354069897811569627360909276199d+00 + a21 = 1.d0 + a31 = 1.d0 + a32 = 0.d0 + alpha2 = gam + alpha3 = gam + g1= .43586652150845899941601945119356d+00 + g2= .24291996454816804366592249683314d+00 + g3= .21851380027664058511513169485832d+01 + + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + uround = 1.d-15 + dround = DSQRT(uround) + IF (Hmax.le.0.D0) THEN + Hmax = DABS(Tnext-T) + END IF + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 continue + + Tplus = T + H + if ( Tplus .gt. Tnext ) then + H = Tnext - T + Tplus = Tnext + end if + + CALL JAC_CHEM(NVAR, T, y, JAC) + Njac = Njac+1 + gHinv = -1.0d0/(gam*H) + do 15 j=1,LU_NONZERO + JAC(j) = -JAC(j) + 15 continue + do 20 j=1,NVAR + JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) - gHinv + 20 continue + CALL KppDecomp (JAC, ier) + + if (ier.ne.0) then + if ( H.gt.Hmin) then + H = 5.0d-1*H + go to 10 + else + print *,'IER <> 0, H=',H + stop + end if + end if + + CALL FUNC_CHEM(NVAR, T, y, F1) + +C ====== NONAUTONOMOUS CASE =============== + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + nfcn=nfcn+1 + do 30 j = 1,NVAR + K3(j) = ( K2(j)-F1(j) )/tau + 30 continue + +C ----- STAGE 1 (NONAUTONOMOUS) ----- + x1 = g1*H + do 35 j = 1,NVAR + K1(j) = F1(j) + x1*K3(j) + 35 continue + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 (NONAUTONOMOUS) ----- + do 40 j = 1,NVAR + ynew(j) = y(j) + K1(j) + 40 continue + CALL FUNC_CHEM(NVAR, T+gam*H, ynew, F1) + nfcn=nfcn+1 + x1 = c21/H + x2 = g2*H + do 45 j = 1,NVAR + K2(j) = F1(j) + x1*K1(j) + x2*K3(j) + 45 continue + CALL KppSolve (JAC, K2) + +C ----- STAGE 3 (NONAUTONOMOUS) ----- + x1 = c31/H + x2 = c32/H + x3 = g3*H + do 50 j = 1,NVAR + K3(j) = F1(j) + x1*K1(j) + x2*K2(j) + x3*K3(j) + 50 continue + CALL KppSolve (JAC, K3) + + +C ====== AUTONOMOUS CASE =============== + ELSE + +C ----- STAGE 1 (AUTONOMOUS) ----- + do 60 j = 1,NVAR + K1(j) = F1(j) + 60 continue + CALL KppSolve (JAC, K1) + +C ----- STAGE 2 (AUTONOMOUS) ----- + do 65 j = 1,NVAR + ynew(j) = y(j) + K1(j) + 65 continue + CALL FUNC_CHEM(NVAR, T + gam*H, ynew, F1) + nfcn=nfcn+1 + x1 = c21/H + do 70 j = 1,NVAR + K2(j) = F1(j) + x1*K1(j) + 70 continue + CALL KppSolve (JAC, K2) + +C ----- STAGE 3 (AUTONOMOUS) ----- + x1 = c31/H + x2 = c32/H + do 90 j = 1,NVAR + K3(j) = F1(j) + x1*K1(j) + x2*K2(j) + 90 continue + CALL KppSolve (JAC, K3) + + END IF ! Autonomousous + +C ---- The Solution --- + + do 120 j = 1,NVAR + ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + 120 continue + + +C ====== Error estimation ======== + + ERR=0.d0 + do 130 i=1,NVAR + ytol = AbsTol(i) + RelTol(i)*DMAX1(DABS(y(i)),DABS(ynew(i))) + ERR=ERR+((d1*K1(i)+d2*K2(i)+d3*K3(i))/ytol)**2 + 130 continue + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + elo = 3.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 140 i=1,NVAR + y(i) = ynew(i) + 140 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + + +C ======= End of the time loop =============================== + if ( T .lt. Tnext ) go to 10 + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.def new file mode 100755 index 00000000..04518bcd --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.def @@ -0,0 +1,51 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros3_ddm +#HESSIAN ON + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT + int Autonomous; + double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.f new file mode 100755 index 00000000..db8b3431 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros3_ddm.f @@ -0,0 +1,503 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT +C Y - Concentrations and Sensitivities + KPP_REAL Y(NVAR*(NSENSIT+1)) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS3_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,Y,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + RETURN + END + + + SUBROUTINE ROS3_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INCLUDE 'KPP_ROOT_sparse.h' + +C L-stable Rosenbrock 3(2), with +C strongly A-stable embedded formula for error control. +C +C Direct decoupled computation of sensitivities. +C The global variable DDMTYPE distinguishes between: +C DDMTYPE = 0 : sensitivities w.r.t. initial values +C DDMTYPE = 1 : sensitivities w.r.t. parameters +C +C All the arguments aggree with the KPP syntax. +C +C INPUT ARGUMENTS: +C y = Vector of: (1:NVAR) concentrations, followed by +C (1:NVAR) sensitivities w.r.t. first parameter, followed by +C etc., followed by +C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter +C (y contains initial values at input, final values at output) +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at TEND. +C T = equals TEND on output. +C Info(2) = # of FUNC_CHEM calls. +C Info(3) = # of JAC_CHEM calls. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C +C Adrian Sandu, April 1996 +C The Center for Global and Regional Environmental Research + INTEGER NSENSIT + KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) + KPP_REAL K1(NVAR*(NSENSIT+1)) + KPP_REAL K2(NVAR*(NSENSIT+1)) + KPP_REAL K3(NVAR*(NSENSIT+1)) + KPP_REAL DFDT(NVAR*(NSENSIT+1)) + KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) + KPP_REAL DJDP(NVAR*NSENSIT) + KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) + KPP_REAL DJDT(LU_NONZERO) + KPP_REAL Fv(NVAR), Hv(NVAR) + KPP_REAL HESS(NHESS) + KPP_REAL Hmin,Hmax,Hstart,ghinv,uround + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, Tplus, H, Hnew, elo + KPP_REAL ERR, factor, facmax + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject,Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + + KPP_REAL gamma, c21, c31,c32,b1,b2,b3,d1,d2,d3,a21,a31,a32 + KPP_REAL alpha2, alpha3, g1, g2, g3, x1, x2, x3, ytol + KPP_REAL dround, tau + + gamma= .43586652150845899941601945119356d+00 + c21= -.10156171083877702091975600115545d+01 + c31= .40759956452537699824805835358067d+01 + c32= .92076794298330791242156818474003d+01 + b1= .10000000000000000000000000000000d+01 + b2= .61697947043828245592553615689730d+01 + b3= -.42772256543218573326238373806514d+00 + d1= .50000000000000000000000000000000d+00 + d2= -.29079558716805469821718236208017d+01 + d3= .22354069897811569627360909276199d+00 + a21 = 1.d0 + a31 = 1.d0 + a32 = 0.d0 + alpha2 = gamma + g1= .43586652150845899941601945119356d+00 + g2= .24291996454816804366592249683314d+00 + g3= .21851380027664058511513169485832d+01 + + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + uround = 1.d-15 + dround = DSQRT(uround) + IF (Hmax.le.0.D0) THEN + Hmax = DABS(Tnext-T) + END IF + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + + +C === Starting the time loop === + 10 CONTINUE + +C ====== Initial Function, Jacobian, and Hessian values =============== + CALL FUNC_CHEM(NVAR, T, y, Fv) + Nfcn = Nfcn + 1 + CALL JAC_CHEM(NVAR, T, y, JAC) + Njac = Njac + 1 + CALL HESS_CHEM( NVAR, T, y, HESS ) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) + END IF + +C ====== Time derivatives for NONAutonomousous CASE =============== + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + nfcn=nfcn+1 + DO 20 j = 1,NVAR + DFDT(j) = ( K2(j)-Fv(j) )/tau + 20 CONTINUE + CALL JAC_CHEM(NVAR, T+tau, y, AJAC) + DO 30 j = 1,LU_NONZERO + DJDT(j) = ( AJAC(j)-JAC(j) )/tau + 30 CONTINUE + DO 40 i=1,NSENSIT + CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) + 40 CONTINUE + END IF + + + Tplus = T + H + IF ( Tplus .gt. Tnext ) then + H = Tnext - T + Tplus = Tnext + END IF + + gHinv = 1.0d0/(gamma*H) + DO 50 j=1,LU_NONZERO + AJAC(j) = -JAC(j) + 50 CONTINUE + DO 60 j=1,NVAR + AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + gHinv + 60 CONTINUE + CALL KppDecomp (AJAC, ier) + + IF (ier.NE.0) THEN + IF ( H.GT.Hmin) THEN + H = 5.0d-1*H + GO TO 10 + ELSE + PRINT *,'IER <> 0, H=',H + STOP + END IF + END IF + + Autonomous = .true. + +C ------------------------------- STAGE 1 -------------------------------------- + DO 70 j = 1,NVAR + K1(j) = Fv(j) + 70 CONTINUE + IF (.NOT.Autonomous) THEN + x1 = gamma*H + DO 80 j = 1,NVAR + K1(j) = K1(j) + x1*DFDT(j) + 80 CONTINUE + END IF + CALL KppSolve (AJAC, K1) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + DO 110 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) + DO 90 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) + 90 CONTINUE + IF (.NOT. Autonomous) THEN + DO 100 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + x1*DFDT(i*NVAR+j) + 100 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 44 j = 1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 44 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K1(i*NVAR+1)) + 110 CONTINUE + +C ------------------------------- STAGE 2 -------------------------------------- + DO 120 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + a21*K1(j) + 120 CONTINUE + CALL FUNC_CHEM(NVAR, T + alpha2*H, ynew, Fv) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) + END IF + nfcn=nfcn+1 + x1 = c21/H + DO 130 j = 1,NVAR + K2(j) = Fv(j) + x1*K1(j) + 130 CONTINUE + IF (.NOT.Autonomous) THEN + x2 = g2*H + DO 140 j = 1,NVAR + K2(j) = K2(j) + x2*DFDT(j) + 140 CONTINUE + END IF + CALL KppSolve (AJAC, K2) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) + njac=njac+1 + DO 170 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) + DO 150 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + x1*K1(i*NVAR+j) + & + Hv(j) + 150 CONTINUE + IF (.NOT. Autonomous) THEN + DO 160 j=1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + x2*DFDT(i*NVAR+j) + 160 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 165 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 165 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K2(i*NVAR+1)) + 170 CONTINUE + +C ------------------------------- STAGE 3 -------------------------------------- + x1 = c31/H + x2 = c32/H + DO 180 j = 1,NVAR + K3(j) = Fv(j) + x1*K1(j) + x2*K2(j) + 180 CONTINUE + IF (.NOT.Autonomous) THEN + x3 = g3*H + DO 190 j = 1,NVAR + K3(j) = K3(j) + x3*DFDT(j) + 190 CONTINUE + END IF + CALL KppSolve (AJAC, K3) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + DO 220 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) + DO 200 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) +x1*K1(i*NVAR+j) + & + x2*K2(i*NVAR+j) + Hv(j) + 200 CONTINUE + IF (.NOT. Autonomous) THEN + DO 210 j=1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + x3*DFDT(i*NVAR+j) + 210 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 215 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 215 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K3(i*NVAR+1)) + 220 CONTINUE + +C ------------------------------ The Solution --- + + DO 230 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + 230 CONTINUE + + +C ====== Error estimation ======== + + ERR=0.d0 + DO 240 i=1,NVAR + ytol = AbsTol(i) + RelTol(i)*DABS(ynew(i)) + ERR=ERR+((d1*K1(i)+d2*K2(i)+d3*K3(i))/ytol)**2 + 240 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + elo = 3.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + GO TO 10 + ELSE + DO 250 j=1,NVAR*(NSENSIT+1) + y(j) = ynew(j) + 250 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize IF previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) +C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER N + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) +C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER N + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), U(NVAR) + KPP_REAL P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + + SUBROUTINE HESS_CHEM(N, T, Y, HESS) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), HESS(NHESS) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, HESS ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.def new file mode 100755 index 00000000..9eebbf80 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.def @@ -0,0 +1,63 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros4 + +#INLINE F_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=1.e-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=1.e-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE F90_DECL_INT + INTEGER :: Autonomous + DOUBLE PRECISION :: STEPSTART +#ENDINLINE + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT +int Autonomous; +double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE + +#INLINE MATLAB_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.f new file mode 100755 index 00000000..a3ad21a5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4.f @@ -0,0 +1,334 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS4(NVAR,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,VAR,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + RETURN + END + + + + + SUBROUTINE ROS4(N,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_sparse.h' +C +C Four Stages, Fourth Order L-stable Rosenbrock Method, +C with embedded L-stable, third order method for error control +C Simplified version of E. Hairer's atmros4; the coefficients are slightly +C different +C +C +C INPUT ARGUMENTS: +C y = Vector of (NVAR) concentrations, contains the +C initial values on input +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations at Tend. +C T = equals TENDon output. +C Info(2) = # of FUNC_CHEM CALLs. +C Info(3) = # of JAC_CHEM CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C Hstart = The last accepted stepsize +C +C Adrian Sandu, December 2001 +C + KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR), K4(NVAR) + KPP_REAL F1(NVAR) + KPP_REAL DFDT(NVAR) + KPP_REAL JAC(LU_NONZERO) + KPP_REAL Hmin,Hmax,Hstart + KPP_REAL y(NVAR), ynew(NVAR) + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, H, Hnew, Tplus + KPP_REAL elo,ghinv,uround + KPP_REAL ERR, factor, facmax + KPP_REAL w, e, dround, tau + KPP_REAL hgam1, hgam2, hgam3, hgam4 + KPP_REAL hc21, hc31, hc32, hc41, hc42, hc43 + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject, Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM + + +C The method coefficients + DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 + PARAMETER ( gamma = 0.5728200000000000D+00 ) + PARAMETER ( gamma2 = -0.1769193891319233D+01 ) + PARAMETER ( gamma3 = 0.7592633437920482D+00 ) + PARAMETER ( gamma4 = -0.1049021087100450D+00 ) + DOUBLE PRECISION a21, a31, a32, a41, a42, a43 + PARAMETER ( a21 = 0.2000000000000000D+01 ) + PARAMETER ( a31 = 0.1867943637803922D+01 ) + PARAMETER ( a32 = 0.2344449711399156D+00 ) + DOUBLE PRECISION alpha2, alpha3 + PARAMETER ( alpha2 = 0.1145640000000000D+01 ) + PARAMETER ( alpha3 = 0.6552168638155900D+00 ) + DOUBLE PRECISION c21, c31, c32, c41, c42, c43 + PARAMETER ( c21 = -0.7137615036412310D+01 ) + PARAMETER ( c31 = 0.2580708087951457D+01 ) + PARAMETER ( c32 = 0.6515950076447975D+00 ) + PARAMETER ( c41 = -0.2137148994382534D+01 ) + PARAMETER ( c42 = -0.3214669691237626D+00 ) + PARAMETER ( c43 = -0.6949742501781779D+00 ) + DOUBLE PRECISION b1, b2, b3, b4 + PARAMETER ( b1 = 0.2255570073418735D+01 ) + PARAMETER ( b2 = 0.2870493262186792D+00 ) + PARAMETER ( b3 = 0.4353179431840180D+00 ) + PARAMETER ( b4 = 0.1093502252409163D+01 ) + DOUBLE PRECISION d1, d2, d3, d4 + PARAMETER ( d1 = -0.2815431932141155D+00 ) + PARAMETER ( d2 = -0.7276199124938920D-01 ) + PARAMETER ( d3 = -0.1082196201495311D+00 ) + PARAMETER ( d4 = -0.1093502252409163D+01 ) + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + uround = 1.d-15 + dround = DSQRT(uround) + IF (Hmax.le.0.D0) THEN + Hmax = DABS(Tnext-T) + END IF + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 CONTINUE + + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function and Jacobian values + CALL FUNC_CHEM( T, y, F1 ) + CALL JAC_CHEM( T, y, JAC ) + +C The time derivative for non-Autonomous case + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T) + CALL FUNC_CHEM( T+tau, y, K2 ) + nfcn=nfcn+1 + DO 20 j = 1,NVAR + DFDT(j) = ( K2(j)-F1(j) )/tau + 20 CONTINUE + END IF + +C Form the Prediction matrix and compute its LU factorization + Njac = Njac+1 + ghinv = 1.0d0/(gamma*H) + DO 30 j=1,LU_NONZERO + JAC(j) = -JAC(j) + 30 CONTINUE + DO 40 j=1,NVAR + JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv + 40 CONTINUE + CALL KppDecomp (JAC, ier) +C + IF (ier.ne.0) THEN + IF ( H.gt.Hmin) THEN + H = 5.0d-1*H + GO TO 10 + ELSE + PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H + STOP + END IF + END IF + + +C ------------ STAGE 1------------------------- + DO 50 j = 1,NVAR + K1(j) = F1(j) + 50 CONTINUE + IF (.NOT. Autonomous) THEN + hgam1 = H*gamma + DO 60 j=1,NVAR + K1(j) = K1(j) + hgam1*DFDT(j) + 60 CONTINUE + END IF + CALL KppSolve (JAC, K1) + +C ----------- STAGE 2 ------------------------- + DO 70 j = 1,NVAR + ynew(j) = y(j) + a21*K1(j) + 70 CONTINUE + CALL FUNC_CHEM( T+alpha2*H, ynew, F1) + nfcn=nfcn+1 + hc21 = c21/H + DO 80 j = 1,NVAR + K2(j) = F1(j) + hc21*K1(j) + 80 CONTINUE + IF (.NOT. Autonomous) THEN + hgam2 = H*gamma2 + DO 90 j=1,NVAR + K2(j) = K2(j) + hgam2*DFDT(j) + 90 CONTINUE + END IF + CALL KppSolve (JAC, K2) + + +C ------------ STAGE 3 ------------------------- + DO 100 j = 1,NVAR + ynew(j) = y(j) + a31*K1(j) + a32*K2(j) + 100 CONTINUE + CALL FUNC_CHEM( T+alpha3*H, ynew, F1) + nfcn=nfcn+1 + hc31 = c31/H + hc32 = c32/H + DO 110 j = 1,NVAR + K3(j) = F1(j) + hc31*K1(j) + hc32*K2(j) + 110 CONTINUE + IF (.NOT. Autonomous) THEN + hgam3 = H*gamma3 + DO 120 j=1,NVAR + K3(j) = K3(j) + hgam3*DFDT(j) + 120 CONTINUE + END IF + CALL KppSolve (JAC, K3) + +C ------------ STAGE 4 ------------------------- +C Note: uses the same function value as stage 3 + hc41 = c41/H + hc42 = c42/H + hc43 = c43/H + DO 140 j = 1,NVAR + K4(j) = F1(j) + hc41*K1(j) + hc42*K2(j) + hc43*K3(j) + 140 CONTINUE + IF (.NOT. Autonomous) THEN + hgam4 = H*gamma4 + DO 150 j=1,NVAR + K4(j) = K4(j) + hgam4*DFDT(j) + 150 CONTINUE + END IF + CALL KppSolve (JAC, K4) + + + +C ---- The Solution --- + DO 160 j = 1,NVAR + ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) + 160 CONTINUE + + +C ====== Error estimation ======== + + ERR=0.d0 + DO 170 j = 1,NVAR + w = AbsTol(j) + RelTol(j)*DMAX1(DABS(y(j)),DABS(ynew(j))) + e = d1*K1(j) + d2*K2(j) + d3*K3(j) + d4*K4(j) + ERR = ERR + ( e/w )**2 + 170 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + elo = 4.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 180 i=1,NVAR + y(i) = ynew(i) + 180 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + SUBROUTINE FUNC_CHEM( T, Y, P ) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM( T, Y, J ) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.def new file mode 100755 index 00000000..cac5a9ad --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.def @@ -0,0 +1,58 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros4_ddm +#HESSIAN ON + +#INLINE F77_DECL_INT + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + +#INLINE F90_DECL_INT + INTEGER Autonomous + DOUBLE PRECISION STEPSTART +#ENDINLINE + +#INLINE F90_INIT_INT + STEPMIN=1.0E-4 + STEPMAX=3600. + Autonomous = 0 + STEPSTART=STEPMIN +#ENDINLINE + + +#INLINE C_DECL_INT + extern int Autonomous; + extern double STEPSTART; +#ENDINLINE + +#INLINE C_DATA_INT + int Autonomous; + double STEPSTART; +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE + +#INLINE MATLAB_INIT_INT + STEPMIN = 0.0001; + STEPMAX = 3600.0; + Autonomous = 0; + STEPSTART = STEPMIN; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.f new file mode 100755 index 00000000..79a939c8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/ros4_ddm.f @@ -0,0 +1,615 @@ + SUBROUTINE INTEGRATE( NSENSIT, Y, TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT +C Y - Concentrations and Sensitivities + KPP_REAL Y(NVAR*(NSENSIT+1)) +C --- Note: Y contains: (1:NVAR) concentrations, followed by +C --- (1:NVAR) sensitivities w.r.t. first parameter, followed by +C --- etc., followed by +C --- (1:NVAR) sensitivities w.r.t. NSENSIT's parameter + + INTEGER INFO(5) + + EXTERNAL FUNC_CHEM, JAC_CHEM + + INFO(1) = Autonomous + + CALL ROS4_DDM(NVAR,NSENSIT,TIN,TOUT,STEPMIN,STEPMAX, + + STEPMIN,Y,ATOL,RTOL, + + Info,FUNC_CHEM,JAC_CHEM) + + + RETURN + END + + + + + SUBROUTINE ROS4_DDM(N,NSENSIT,T,Tnext,Hmin,Hmax,Hstart, + + y,AbsTol,RelTol, + + Info,FUNC_CHEM,JAC_CHEM) + IMPLICIT NONE + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INCLUDE 'KPP_ROOT_sparse.h' +C +C Four Stages, Fourth Order L-stable Rosenbrock Method, +C with embedded L-stable, third order method for error control +C Simplified version of E. Hairer's atmros4; the coefficients are slightly different +C +C Direct decoupled computation of sensitivities. +C The global variable DDMTYPE distinguishes between: +C DDMTYPE = 0 : sensitivities w.r.t. initial values +C DDMTYPE = 1 : sensitivities w.r.t. parameters +C +C INPUT ARGUMENTS: +C y = Vector of: (1:NVAR) concentrations, followed by +C (1:NVAR) sensitivities w.r.t. first parameter, followed by +C etc., followed by +C (1:NVAR) sensitivities w.r.t. NSENSIT's parameter +C (y contains initial values at input, final values at output) +C [T, Tnext] = the integration interval +C Hmin, Hmax = lower and upper bounds for the selected step-size. +C Note that for Step = Hmin the current computed +C solution is unconditionally accepted by the error +C control mechanism. +C AbsTol, RelTol = (NVAR) dimensional vectors of +C componentwise absolute and relative tolerances. +C FUNC_CHEM = name of routine of derivatives. KPP syntax. +C See the header below. +C JAC_CHEM = name of routine that computes the Jacobian, in +C sparse format. KPP syntax. See the header below. +C Info(1) = 1 for Autonomous system +C = 0 for nonAutonomous system +C +C OUTPUT ARGUMENTS: +C y = the values of concentrations and sensitivities at Tend. +C T = equals TENDon output. +C Info(2) = # of FUNC_CHEM CALLs. +C Info(3) = # of JAC_CHEM CALLs. +C Info(4) = # of accepted steps. +C Info(5) = # of rejected steps. +C +C Adrian Sandu, December 2001 +C + + + INTEGER NSENSIT + KPP_REAL y(NVAR*(NSENSIT+1)), ynew(NVAR*(NSENSIT+1)) + KPP_REAL K1(NVAR*(NSENSIT+1)) + KPP_REAL K2(NVAR*(NSENSIT+1)) + KPP_REAL K3(NVAR*(NSENSIT+1)) + KPP_REAL K4(NVAR*(NSENSIT+1)) + KPP_REAL Fv(NVAR), Hv(NVAR) + KPP_REAL DFDT(NVAR*(NSENSIT+1)) + KPP_REAL DFDP(NVAR*NSENSIT), DFDPDT(NVAR*NSENSIT) + KPP_REAL DJDP(NVAR*NSENSIT) + KPP_REAL JAC(LU_NONZERO), AJAC(LU_NONZERO) + KPP_REAL DJDT(LU_NONZERO) + KPP_REAL HESS(NHESS) + KPP_REAL Hmin,Hmax,Hstart,ghinv,uround + KPP_REAL AbsTol(NVAR), RelTol(NVAR) + KPP_REAL T, Tnext, Tplus, H, Hnew, elo + KPP_REAL ERR, factor, facmax, dround, tau + KPP_REAL w, e, beta1, beta2, beta3, beta4 + + INTEGER n,nfcn,njac,Naccept,Nreject,i,j,ier + INTEGER Info(5) + LOGICAL IsReject, Autonomous + EXTERNAL FUNC_CHEM, JAC_CHEM, HESS_CHEM + + +C The method coefficients +C DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 +C PARAMETER ( gamma = 0.57281606D0 ) +C PARAMETER ( gamma2 = -1.769177067112013949170520D0 ) +C PARAMETER ( gamma3 = 0.759293964293209853670967D0 ) +C PARAMETER ( gamma4 = -0.104894621490955803206743D0 ) +C DOUBLE PRECISION a21, a31, a32, a41, a42, a43 +C PARAMETER ( a21 = 2.00000000000000000000000D0 ) +C PARAMETER ( a31 = 1.86794814949823713234476D0 ) +C PARAMETER ( a32 = 0.23444556851723885002322D0 ) +C DOUBLE PRECISION alpha2, alpha3, alpha4 +C PARAMETER ( alpha2 = 1.145632120D0 ) +C PARAMETER ( alpha3 = 0.655214975973133829477748D0 ) +C DOUBLE PRECISION c21, c31, c32, c41, c42, c43 +C PARAMETER ( c21 = -7.137649943349979830369260D0 ) +C PARAMETER ( c31 = 2.580923666509657714488050D0 ) +C PARAMETER ( c32 = 0.651629887302032023387417D0 ) +C PARAMETER ( c41 = -2.137115266506619116806370D0 ) +C PARAMETER ( c42 = -0.321469531339951070769241D0 ) +C PARAMETER ( c43 = -0.694966049282445225157329D0 ) +C DOUBLE PRECISION m1, m2, m3, m4, mhat1, mhat2, mhat3, mhat4 +C PARAMETER ( m1 = 2.255566228604565243728840D0 ) +C PARAMETER ( m2 = 0.287055063194157607662630D0 ) +C PARAMETER ( m3 = 0.435311963379983213402707D0 ) +C PARAMETER ( m4 = 1.093507656403247803214820D0 ) +C PARAMETER ( mhat1 = 2.068399160527583734258670D0 ) +C PARAMETER ( mhat2 = 0.238681352067532797956493D0 ) +C PARAMETER ( mhat3 = 0.363373345435391708261747D0 ) +C PARAMETER ( mhat4 = 0.366557127936155144309163D0 ) +C DOUBLE PRECISION e1, e2, e3, e4 +c PARAMETER ( e1 = 1.8716706807698191283861888D-01 ) +c PARAMETER ( e2 = 4.8373711126624835410225955D-02 ) +c PARAMETER ( e3 = 7.1938617944591554120847832D-02 ) +c PARAMETER ( e4 = 7.2695052846709262706070831D-01 ) +C PARAMETER ( e1 = -0.2815431932141155D+00 ) +C PARAMETER ( e2 = -0.7276199124938920D-01 ) +C PARAMETER ( e3 = -0.1082196201495311D+00 ) +C PARAMETER ( e4 = -0.1093502252409163D+01 ) +C The method coefficients + DOUBLE PRECISION gamma, gamma2, gamma3, gamma4 + PARAMETER ( gamma = 0.5728200000000000D+00 ) + PARAMETER ( gamma2 = -0.1769193891319233D+01 ) + PARAMETER ( gamma3 = 0.7592633437920482D+00 ) + PARAMETER ( gamma4 = -0.1049021087100450D+00 ) + DOUBLE PRECISION a21, a31, a32, a41, a42, a43 + PARAMETER ( a21 = 0.2000000000000000D+01 ) + PARAMETER ( a31 = 0.1867943637803922D+01 ) + PARAMETER ( a32 = 0.2344449711399156D+00 ) + DOUBLE PRECISION alpha2, alpha3 + PARAMETER ( alpha2 = 0.1145640000000000D+01 ) + PARAMETER ( alpha3 = 0.6552168638155900D+00 ) + DOUBLE PRECISION c21, c31, c32, c41, c42, c43 + PARAMETER ( c21 = -0.7137615036412310D+01 ) + PARAMETER ( c31 = 0.2580708087951457D+01 ) + PARAMETER ( c32 = 0.6515950076447975D+00 ) + PARAMETER ( c41 = -0.2137148994382534D+01 ) + PARAMETER ( c42 = -0.3214669691237626D+00 ) + PARAMETER ( c43 = -0.6949742501781779D+00 ) + DOUBLE PRECISION b1, b2, b3, b4 + PARAMETER ( b1 = 0.2255570073418735D+01 ) + PARAMETER ( b2 = 0.2870493262186792D+00 ) + PARAMETER ( b3 = 0.4353179431840180D+00 ) + PARAMETER ( b4 = 0.1093502252409163D+01 ) + DOUBLE PRECISION d1, d2, d3, d4 + PARAMETER ( d1 = -0.2815431932141155D+00 ) + PARAMETER ( d2 = -0.7276199124938920D-01 ) + PARAMETER ( d3 = -0.1082196201495311D+00 ) + PARAMETER ( d4 = -0.1093502252409163D+01 ) + + +c Initialization of counters, etc. + Autonomous = Info(1) .EQ. 1 + uround = 1.d-15 + dround = DSQRT(uround) + IF (Hmax.le.0.D0) THEN + Hmax = DABS(Tnext-T) + END IF + H = DMAX1(1.d-8, Hstart) + Tplus = T + IsReject = .false. + Naccept = 0 + Nreject = 0 + Nfcn = 0 + Njac = 0 + +C === Starting the time loop === + 10 CONTINUE + + Tplus = T + H + IF ( Tplus .gt. Tnext ) THEN + H = Tnext - T + Tplus = Tnext + END IF + +C Initial Function, Jacobian, and Hessian Values + CALL FUNC_CHEM(NVAR, T, y, Fv) + CALL JAC_CHEM(NVAR, T, y, JAC) + CALL HESS_CHEM( NVAR, T, y, HESS ) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T, y, DFDP) + END IF + +C The time derivatives for non-Autonomous case + IF (.not. Autonomous) THEN + tau = DSIGN(dround*DMAX1( 1.0d0, DABS(T) ), T) + CALL FUNC_CHEM(NVAR, T+tau, y, K2) + CALL JAC_CHEM(NVAR, T+tau, y, AJAC) + nfcn=nfcn+1 + DO 20 j = 1,NVAR + DFDT(j) = ( K2(j)-Fv(j) )/tau + 20 CONTINUE + DO 30 j = 1,LU_NONZERO + DJDT(j) = ( AJAC(j)-JAC(j) )/tau + 30 CONTINUE + DO 35 i=1,NSENSIT + CALL Jac_SP_Vec (DJDT,y(i*NVAR+1),DFDT(i*NVAR+1)) + 35 CONTINUE + END IF + + 11 CONTINUE ! From here we restart after a rejected step + +C Form the Prediction matrix and compute its LU factorization + Njac = Njac+1 + ghinv = 1.0d0/(gamma*H) + DO 40 j=1,LU_NONZERO + AJAC(j) = -JAC(j) + 40 CONTINUE + DO 50 j=1,NVAR + AJAC(LU_DIAG(j)) = AJAC(LU_DIAG(j)) + ghinv + 50 CONTINUE + CALL KppDecomp (AJAC, ier) +C + IF (ier.ne.0) THEN + IF ( H.gt.Hmin) THEN + H = 5.0d-1*H + GO TO 10 + ELSE + PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H + STOP + END IF + END IF + +C ------------ STAGE 1------------------------- + DO 60 j = 1,NVAR + K1(j) = Fv(j) + 60 CONTINUE + IF (.NOT. Autonomous) THEN + beta1 = H*gamma + DO 70 j=1,NVAR + K1(j) = K1(j) + beta1*DFDT(j) + 70 CONTINUE + END IF + CALL KppSolve (AJAC, K1) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K1(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + DO 100 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,y(i*NVAR+1),K1(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K1(1), Hv ) + DO 80 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + Hv(j) + 80 CONTINUE + IF (.NOT. Autonomous) THEN + DO 90 j=1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + beta1*DFDT(i*NVAR+j) + 90 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 95 j = 1,NVAR + K1(i*NVAR+j) = K1(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 95 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K1(i*NVAR+1)) + 100 CONTINUE + +C ----------- STAGE 2 ------------------------- + DO 110 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + a21*K1(j) + 110 CONTINUE + CALL FUNC_CHEM(NVAR, T+alpha2*H, ynew, Fv) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+alpha2*H, ynew, DFDP) + END IF + nfcn=nfcn+1 + beta1 = c21/H + DO 120 j = 1,NVAR + K2(j) = Fv(j) + beta1*K1(j) + 120 CONTINUE + IF (.NOT. Autonomous) THEN + beta2 = H*gamma2 + DO 130 j=1,NVAR + K2(j) = K2(j) + beta2*DFDT(j) + 130 CONTINUE + END IF + CALL KppSolve (AJAC, K2) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K2(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+alpha2*H, ynew, JAC) + njac=njac+1 + DO 160 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K2(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K2(1), Hv ) + DO 140 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + Hv(j) + 140 CONTINUE + IF (.NOT. Autonomous) THEN + DO 150 j=1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + beta2*DFDT(i*NVAR+j) + 150 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 155 j = 1,NVAR + K2(i*NVAR+j) = K2(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 155 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K2(i*NVAR+1)) + 160 CONTINUE + + +C ------------ STAGE 3 ------------------------- + DO 170 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + a31*K1(j) + a32*K2(j) + 170 CONTINUE + CALL FUNC_CHEM(NVAR, T+alpha3*H, ynew, Fv) + IF (DDMTYPE .EQ. 1) THEN + CALL DFUNDPAR(NVAR, NSENSIT, T+alpha3*H, ynew, DFDP) + END IF + nfcn=nfcn+1 + beta1 = c31/H + beta2 = c32/H + DO 180 j = 1,NVAR + K3(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + 180 CONTINUE + IF (.NOT. Autonomous) THEN + beta3 = H*gamma3 + DO 190 j=1,NVAR + K3(j) = K3(j) + beta3*DFDT(j) + 190 CONTINUE + END IF + CALL KppSolve (AJAC, K3) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K3(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + CALL JAC_CHEM(NVAR, T+alpha3*H, ynew, JAC) + njac=njac+1 + DO 220 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K3(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K3(1), Hv ) + DO 200 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + beta2*K2(i*NVAR+j) + Hv(j) + 200 CONTINUE + IF (.NOT. Autonomous) THEN + DO 210 j=1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + beta3*DFDT(i*NVAR+j) + 210 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 215 j = 1,NVAR + K3(i*NVAR+j) = K3(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 215 CONTINUE + END IF +C --- End of derivative w.r.t. parameters + CALL KppSolve (AJAC, K3(i*NVAR+1)) + 220 CONTINUE + +C ------------ STAGE 4 ------------------------- +C Note: uses the same function values as stage 3 + beta1 = c41/H + beta2 = c42/H + beta3 = c43/H + DO 230 j = 1,NVAR + K4(j) = Fv(j) + beta1*K1(j) + beta2*K2(j) + beta3*K3(j) + 230 CONTINUE + IF (.NOT. Autonomous) THEN + beta4 = H*gamma4 + DO 240 j=1,NVAR + K4(j) = K4(j) + beta4*DFDT(j) + 240 CONTINUE + END IF + CALL KppSolve (AJAC, K4) +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + CALL DJACDPAR(NVAR, NSENSIT, T, y, K4(1), DJDP) + END IF +C --- End of derivative w.r.t. parameters + + njac=njac+1 + DO 270 i=1,NSENSIT + CALL Jac_SP_Vec (JAC,ynew(i*NVAR+1),K4(i*NVAR+1)) + CALL Hess_Vec ( HESS, y(i*NVAR+1), K4(1), Hv ) + DO 250 j = 1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + beta1*K1(i*NVAR+j) + & + beta2*K2(i*NVAR+j) + beta3*K3(i*NVAR+j) + & + Hv(j) + 250 CONTINUE + IF (.NOT. Autonomous) THEN + DO 260 j=1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + beta4*DFDT(i*NVAR+j) + 260 CONTINUE + END IF +C --- If derivative w.r.t. parameters + IF (DDMTYPE .EQ. 1) THEN + DO 265 j = 1,NVAR + K4(i*NVAR+j) = K4(i*NVAR+j) + DFDP((i-1)*NVAR+j) + & + DJDP((i-1)*NVAR+j) + 265 CONTINUE + END IF + CALL KppSolve (AJAC, K4(i*NVAR+1)) + 270 CONTINUE + + +C ---- The Solution --- + DO 280 j = 1,NVAR*(NSENSIT+1) + ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j) + 280 CONTINUE + + +C ====== Error estimation -- can be extended to control sensitivities too ======== + + ERR = 0.d0 + DO 290 i=1,NVAR + w = AbsTol(i) + RelTol(i)*DMAX1(DABS(ynew(i)),DABS(y(i))) + e = d1*K1(i) + d2*K2(i) + d3*K3(i) + d4*K4(i) + ERR = ERR + ( e/w )**2 + 290 CONTINUE + ERR = DMAX1( uround, DSQRT( ERR/NVAR ) ) + +C ======= Choose the stepsize =============================== + + elo = 4.0D0 ! estimator local order + factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0)) + Hnew = DMIN1(Hmax,DMAX1(Hmin, H/factor)) + +C ======= Rejected/Accepted Step ============================ + + IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN + IsReject = .true. + H = DMIN1(H/10,Hnew) + Nreject = Nreject+1 + ELSE + DO 300 i=1,NVAR*(NSENSIT+1) + y(i) = ynew(i) + 300 CONTINUE + T = Tplus + IF (.NOT.IsReject) THEN + H = Hnew ! Do not increase stepsize if previos step was rejected + END IF + IsReject = .false. + Naccept = Naccept+1 + END IF + +C ======= End of the time loop =============================== + IF ( T .lt. Tnext ) GO TO 10 + + + +C ======= Output Information ================================= + Info(2) = Nfcn + Info(3) = Njac + Info(4) = Naccept + Info(5) = Nreject + Hstart = H + + RETURN + END + + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE DFUNDPAR(N, NSENSIT, T, Y, P) +C --- Computes the partial derivatives of FUNC_CHEM w.r.t. parameters + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dFun_dRcoeff( Y, FIX, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + + + SUBROUTINE DJACDPAR(N, NSENSIT, T, Y, U, P) +C --- Computes the partial derivatives of JAC w.r.t. parameters times user vector U + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' +C --- NCOEFF, JCOEFF useful for derivatives w.r.t. rate coefficients + INTEGER N + INTEGER NCOEFF, JCOEFF(NREACT) + COMMON /DDMRCOEFF/ NCOEFF, JCOEFF + + KPP_REAL T, Told + KPP_REAL Y(NVAR), U(NVAR) + KPP_REAL P(NVAR*NSENSIT) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +C + IF (DDMTYPE .EQ. 0) THEN +C --- Note: the values below are for sensitivities w.r.t. initial values; +C --- they may have to be changed for other applications + DO j=1,NSENSIT + DO i=1,NVAR + P(i+NVAR*(j-1)) = 0.0D0 + END DO + END DO + ELSE +C --- Example: the call below is for sensitivities w.r.t. rate coefficients; +C --- JCOEFF(1:NSENSIT) are the indices of the NSENSIT rate coefficients +C --- w.r.t. which one differentiates + CALL dJac_dRcoeff( Y, FIX, U, NCOEFF, JCOEFF, P ) + END IF + TIME = Told + RETURN + END + + + SUBROUTINE HESS_CHEM(N, T, Y, HESS) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), HESS(NHESS) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, HESS ) + TIME = Told + RETURN + END + + + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.def new file mode 100755 index 00000000..2e635625 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.def @@ -0,0 +1,16 @@ + +#FUNCTION SPLIT +#JACOBIAN OFF +#SPARSEDATA OFF +#DOUBLE ON +#INTFILE twostepj + +#INLINE F_INIT_INT + STEPMIN=0.0001 + STEPMAX=60. +#ENDINLINE + +#INLINE C_INIT_INT + STEPMIN=0.0001; + STEPMAX=60.; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.f new file mode 100755 index 00000000..cb8dfe6c --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/oldies/twostepj.f @@ -0,0 +1,244 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + EXTERNAL ITER + KPP_REAL T + KPP_REAL V(NVAR), VOLD(NVAR), VNEW(NVAR) + KPP_REAL startdt, hmin, hmax, h + + INTEGER INFO(5) + + INFO(1) = Autonomous + h = hmin + +c Number of Jacobi-Seidel iterations + numit = 3 + + + DO i=1,NVAR + RTOL(i) = 1.e-2 + ENDDO + + CALL twostepj(NVAR,TIN,TOUT,h,hmin,hmax, + + VOLD,VAR,VNEW, + + ATOL,RTOL,numit, + + nfcn,naccpt,nrejec,nstart,startdt,ITER) + + + RETURN + END + + + + SUBROUTINE ITER(n,T,y,yp,yl) + INCLUDE 'KPP_ROOT_params.h' + INCLUDE 'KPP_ROOT_global.h' + REAL*8 T, y(NVAR), yp(NVAR), yl(NVAR) + TOLD = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL FunSPLIT_VAR(y,Rad,yp,yl) + TIME = TOLD + RETURN + END + + + subroutine twostepj(n,t,te,dt,dtmin,dtmax, + + yold,y,ynew, + + atol,rtol,numit, + + nfcn,naccpt,nrejec,nstart,startdt,ITER) + implicit real*8 (a-h,o-z) + external ITER + integer n,numit,nfcn,naccpt,nrejec,nstart,i,j + real*8 t,te,dt,dtmin,dtmax,startdt,ytol, + + ratio,dtold,a1,a2,c,cp1,dtg,errlte,dy + real*8 yold(n),y(n),ynew(n),yp(n),yl(n), + + work(n),sum(n),atol(n),rtol(n) + logical accept,failer,restart + +c +c Initialization of counters, etc. + + naccpt=0 + nrejec=0 + nfcn=0 + nstart=0 + failer=.false. + restart=.false. + accept=.true. + +c Initial stepsize computation. + + 10 if (dtmin.eq.dtmax) then + nstart=1 + dt=min(dtmin,(te-t)/2) + goto 28 + endif + CALL ITER(n,t,y,yp,yl) + nfcn=nfcn+1 + dt=te-t + do 20 i=1,n + ytol=atol(i)+rtol(i)*abs(y(i)) + dy=yp(i)-y(i)*yl(i) + if (dy.ne.0.0) dt=min(dt,ytol/abs(dy)) + 20 continue + 25 nstart=nstart+1 + if (restart) dt=dt/10.0 + restart=.true. + dt=max(dtmin,min(dt,dtmax)) + CALL FIT(t,te,dt) + dt=min(dt,(te-t)/2) + startdt=dt + +c The starting step is carried out, using the implicit Euler method. + + 28 do 30 i=1,n + ynew(i)=y(i) + yold(i)=y(i) + sum(i)=y(i) + 30 continue + do 40 i=1,numit + CALL ITER(n,t+dt,ynew,yp,yl) + do i2i=1,n + ynew(i2i) = (sum(i2i) + dt*yp(i2i))/(1.+dt*yl(i2i)) + end do + nfcn=nfcn+1 + 40 continue + naccpt=naccpt+1 + t=t+dt + do 50 j=1,n + y(j)=ynew(j) + 50 continue + +c Subsequent steps are carried out with the two-step BDF method. + + dtold=dt + ratio=1.0 + 60 continue + c=1.0/ratio + cp1=c+1.0 + a1=((c+1.0)**2)/(c*c+2.0*c) + a2=-1.0/(c*c+2.0*c) + dtg=dt*(1.0+c)/(2.0+c) + do 70 j=1,n + sum(j)=a1*y(j)+a2*yold(j) + ynew(j)=max(0.0,y(j)+ratio*(y(j)-yold(j))) + 70 continue + do 80 i=1,numit + CALL ITER(n,t+dt,ynew,yp,yl) + do i2i=1,n + ynew(i2i) = (sum(i2i) + dtg*yp(i2i))/(1.+dtg*yl(i2i)) + end do + nfcn=nfcn+1 + 80 continue + +c If stepsizes should remain equal, stepsize control is omitted. + + if (dtmin.eq.dtmax) then + t=t+dtold + naccpt=naccpt+1 + do 85 j=1,n + yold(j)=y(j) + y(j)=ynew(j) + 85 continue + if (dt.ne.dtold) then + t=t-dtold+dt + goto 120 + endif + dt=min(dtold,te-t) + ratio=dt/dtold + if (t.ge.te) goto 120 + goto 60 + endif + +c Otherwise stepsize control is carried out. + + errlte=0.0 + do 90 i=1,n + ytol=atol(i)+rtol(i)*abs(y(i)) + errlte=max(errlte,abs(c*ynew(i)-cp1*y(i)+yold(i))/ytol) + 90 continue + errlte=2.0*errlte/(c+c*c) + CALL NEWDT(t,te,dt,dtold,ratio,errlte,accept, + + dtmin,dtmax) + +c Here the step has been accepted. + + if (accept) then + 201 format(2(E24.16,1X)) + failer=.false. + restart=.false. + t=t+dtold + naccpt=naccpt+1 + do 100 j=1,n + yold(j)=y(j) + y(j)=ynew(j) + 100 continue + if (t.ge.te) goto 120 + goto 60 + endif + +c A restart check is carried out. + + if (failer) then + nrejec=nrejec+1 + failer=.false. + naccpt=naccpt-1 + t=t-dtold + do 110 j=1,n + y(j)=yold(j) + 110 continue + goto 25 + endif + +c Here the step has been rejected. + + nrejec=nrejec+1 + failer=.true. + goto 60 + +c End of TWOSTEP. + 120 end +c===================================================================== + + subroutine NEWDT(t,te,dt,dtold,ratio,errlte, + + accept,dtmin,dtmax) + real*8 t,te,dt,dtold,ratio,errlte,ts,dtmin,dtmax + logical accept + if (errlte.gt.1.0.and.dt.gt.dtmin) then + accept=.false. + ts=t + else + accept=.true. + dtold=dt + ts=t+dtold + endif + dt=max(0.5,min(2.0,0.8/sqrt(errlte)))*dt + dt=max(dtmin,min(dt,dtmax)) + CALL FIT(ts,te,dt) + ratio=dt/dtold + end + + subroutine FIT(t,te,dt) + real*8 t,te,dt,rns + integer ns + rns=(te-t)/dt + if (rns.gt.10.0) goto 10 + ns=int(rns)+1 + dt=(te-t)/ns + dt=(dt+t)-t + 10 return + end + + + +C End of MAIN function +C **************************************************************** + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/readme b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/readme new file mode 100755 index 00000000..93d30ab7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/readme @@ -0,0 +1,21 @@ +The integrator naming conventions: + +*.def = definition file +*.f = Fortran 77 source code +*.f90 = Fortran 90 source code +*.c = C source code + +atm_* = off-the-shelf integrators, adapted to work with KPP + use the native full linear algebra + useful for providing reference solutions + +kpp_* = off-the-shelf integrators, using the KPP sparse linear algebra + very efficient, useful for production runs + +plain names = original integrators + either use the KPP sparse linear algebra, or provide + explicit solutions + +*_ddm = direct decoupled method + integrate for both the concentrations and their sensitivities + implements the forward and the tangent linear models together diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.c new file mode 100755 index 00000000..27eb8930 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.c @@ -0,0 +1,1216 @@ + + #define MAX(a,b) ( ((a) >= (b)) ?(a):(b) ) + #define MIN(b,c) ( ((b) < (c)) ?(b):(c) ) + #define ABS(x) ( ((x) >= 0 ) ?(x):(-x) ) + #define SQRT(d) ( pow((d),0.5) ) + #define SIGN(x) ( ((x) >= 0 ) ?[0]:(-1) ) + +/*~~> Numerical constants */ + #define ZERO (KPP_REAL)0.0 + #define ONE (KPP_REAL)1.0 + #define HALF (KPP_REAL)0.5 + #define DeltaMin (KPP_REAL)1.0e-6 + +/*~~~> Collect statistics: global variables */ + int Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng; + + +/*~~~> Function headers */ + void FunTemplate(KPP_REAL, KPP_REAL [], KPP_REAL []); + void JacTemplate(KPP_REAL, KPP_REAL [], KPP_REAL []) ; + int Rosenbrock(KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, + KPP_REAL AbsTol[], KPP_REAL RelTol[], + void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), + void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), + KPP_REAL RPAR[], int IPAR[]); + int RosenbrockIntegrator( + KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend , + KPP_REAL AbsTol[], KPP_REAL RelTol[], + void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), + void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), + int ros_S, + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_Alpha[],KPP_REAL ros_Gamma[], + KPP_REAL ros_ELO, char ros_NewF[], + char Autonomous, char VectorTol, int Max_no_steps, + KPP_REAL Roundoff, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, + KPP_REAL FacMin, KPP_REAL FacMax, KPP_REAL FacRej, KPP_REAL FacSafe, + KPP_REAL *Texit, KPP_REAL *Hexit ); + char ros_PrepareMatrix ( + KPP_REAL* H, + int Direction, KPP_REAL gam, KPP_REAL Jac0[], + KPP_REAL Ghimj[], int Pivot[] ); + KPP_REAL ros_ErrorNorm ( + KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], + KPP_REAL AbsTol[], KPP_REAL RelTol[], + char VectorTol ); + int ros_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H); + void ros_FunTimeDerivative ( + KPP_REAL T, KPP_REAL Roundoff, + KPP_REAL Y[], KPP_REAL Fcn0[], + void ode_Fun(KPP_REAL, KPP_REAL [], KPP_REAL []), + KPP_REAL dFdT[] ); + void Fun( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); + void Jac_SP( KPP_REAL Y[], KPP_REAL FIX[], KPP_REAL RCONST[], KPP_REAL Ydot[] ); + void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ); + void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ); + void DecompTemplate( KPP_REAL A[], int Pivot[], int* ising ); + void SolveTemplate( KPP_REAL A[], int Pivot[], KPP_REAL b[] ); + void WCOPY(int N, KPP_REAL X[], int incX, KPP_REAL Y[], int incY); + void WAXPY(int N, KPP_REAL Alpha, KPP_REAL X[], int incX, KPP_REAL Y[], int incY ); + void WSCAL(int N, KPP_REAL Alpha, KPP_REAL X[], int incX); + KPP_REAL WLAMCH( char C ); + void Ros2 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); + void Ros3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); + void Ros4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); + void Rodas3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); + void Rodas4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ); + int KppDecomp( KPP_REAL A[] ); + void KppSolve ( KPP_REAL A[], KPP_REAL b[] ); + void Update_SUN(); + void Update_RCONST(); + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void INTEGRATE( KPP_REAL TIN, KPP_REAL TOUT ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + static KPP_REAL RPAR[20]; + static int i, IERR, IPAR[20]; + static int Ns=0, Na=0, Nr=0, Ng=0; + + for ( i = 0; i < 20; i++ ) { + IPAR[i] = 0; + RPAR[i] = ZERO; + } /* for */ + + + IPAR[0] = 0; /* non-autonomous */ + IPAR[1] = 1; /* vector tolerances */ + RPAR[2] = STEPMIN; /* starting step */ + IPAR[3] = 5; /* choice of the method */ + + IERR = Rosenbrock(VAR, TIN, TOUT, + ATOL, RTOL, + &FunTemplate, &JacTemplate, + RPAR, IPAR); + + + Ns=Ns+IPAR[12]; + Na=Na+IPAR[13]; + Nr=Nr+IPAR[14]; + Ng=Ng+IPAR[17]; + printf("\n Step=%d Acc=%d Rej=%d Singular=%d\n", + Ns,Na,Nr,Ng); + + + if (IERR < 0) + printf("\n Rosenbrock: Unsucessful step at T=%g: IERR=%d\n", + TIN,IERR); + + TIN = RPAR[10]; /* Exit time */ + STEPMIN = RPAR[11]; /* Last step */ + +} /* INTEGRATE */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int Rosenbrock(KPP_REAL Y[], KPP_REAL Tstart, KPP_REAL Tend, + KPP_REAL AbsTol[], KPP_REAL RelTol[], + void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), + void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []), + KPP_REAL RPAR[], int IPAR[]) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + Solves the system y'=F(t,y) using a Rosenbrock method defined by: + + G = 1/(H*gamma[0]) - ode_Jac(t0,Y0) + T_i = t0 + Alpha(i)*H + Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j + G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + + gamma(i)*dF/dT(t0, Y0) + Y1 = Y0 + \sum_{j=1}^S M(j)*K_j + + For details on Rosenbrock methods and their implementation consult: + E. Hairer and G. Wanner + "Solving ODEs II. Stiff and differential-algebraic problems". + Springer series in computational mathematics, Springer-Verlag, 1996. + The codes contained in the book inspired this implementation. + + (C) Adrian Sandu, August 2004 + Virginia Polytechnic Institute and State University + Contact: sandu@cs.vt.edu + This implementation is part of KPP - the Kinetic PreProcessor +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + *~~~> INPUT ARGUMENTS: + +- Y(NVAR) = vector of initial conditions (at T=Tstart) +- [Tstart,Tend] = time range of integration + (if Tstart>Tend the integration is performed backwards in time) +- RelTol, AbsTol = user precribed accuracy +- void ode_Fun( T, Y, Ydot ) = ODE function, + returns Ydot = Y' = F(T,Y) +- void ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, + returns Jcb = dF/dY +- IPAR(1:10) = int inputs parameters +- RPAR(1:10) = real inputs parameters +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + *~~~> OUTPUT ARGUMENTS: + +- Y(NVAR) -> vector of final states (at T->Tend) +- IPAR(11:20) -> int output parameters +- RPAR(11:20) -> real output parameters +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + *~~~> RETURN VALUE (int): + +- IERR -> job status upon return + - succes (positive value) or failure (negative value) - + = 1 : Success + = -1 : Improper value for maximal no of steps + = -2 : Selected Rosenbrock method not implemented + = -3 : Hmin/Hmax/Hstart must be positive + = -4 : FacMin/FacMax/FacRej must be positive + = -5 : Improper tolerance values + = -6 : No of steps exceeds maximum bound + = -7 : Step size too small + = -8 : Matrix is repeatedly singular +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + *~~~> INPUT PARAMETERS: + + Note: For input parameters equal to zero the default values of the + corresponding variables are used. + + IPAR[0] = 1: F = F(y) Independent of T (AUTONOMOUS) + = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) + IPAR[1] = 0: AbsTol, RelTol are NVAR-dimensional vectors + = 1: AbsTol, RelTol are scalars + IPAR[2] -> maximum number of integration steps + For IPAR[2]=0) the default value of 100000 is used + + IPAR[3] -> selection of a particular Rosenbrock method + = 0 : default method is Rodas3 + = 1 : method is Ros2 + = 2 : method is Ros3 + = 3 : method is Ros4 + = 4 : method is Rodas3 + = 5: method is Rodas4 + + RPAR[0] -> Hmin, lower bound for the integration step size + It is strongly recommended to keep Hmin = ZERO + RPAR[1] -> Hmax, upper bound for the integration step size + RPAR[2] -> Hstart, starting value for the integration step size + + RPAR[3] -> FacMin, lower bound on step decrease factor (default=0.2) + RPAR[4] -> FacMin,upper bound on step increase factor (default=6) + RPAR[5] -> FacRej, step decrease factor after multiple rejections + (default=0.1) + RPAR[6] -> FacSafe, by which the new step is slightly smaller + than the predicted value (default=0.9) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + *~~~> OUTPUT PARAMETERS: + + Note: each call to Rosenbrock adds the corrent no. of fcn calls + to previous value of IPAR[10], and similar for the other params. + Set IPAR(11:20) = 0 before call to avoid this accumulation. + + IPAR[10] = No. of function calls + IPAR[11] = No. of jacobian calls + IPAR[12] = No. of steps + IPAR[13] = No. of accepted steps + IPAR[14] = No. of rejected steps (except at the beginning) + IPAR[15] = No. of LU decompositions + IPAR[16] = No. of forward/backward substitutions + IPAR[17] = No. of singular matrix decompositions + + RPAR[10] -> Texit, the time corresponding to the + computed Y upon return + RPAR[11] -> Hexit, last accepted step before exit + For multiple restarts, use Hexit as Hstart in the following run +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ +{ + + /*~~~> The method parameters */ + #define Smax 6 + int Method, ros_S; + KPP_REAL ros_M[Smax], ros_E[Smax]; + KPP_REAL ros_A[Smax*(Smax-1)/2], ros_C[Smax*(Smax-1)/2]; + KPP_REAL ros_Alpha[Smax], ros_Gamma[Smax], ros_ELO; + char ros_NewF[Smax], ros_Name[12]; + /*~~~> Local variables */ + int Max_no_steps, IERR, i, UplimTol; + char Autonomous, VectorTol; + KPP_REAL Roundoff,FacMin,FacMax,FacRej,FacSafe; + KPP_REAL Hmin, Hmax, Hstart, Hexit, Texit; +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ */ + + /*~~~> Initialize statistics */ + Nfun = IPAR[10]; + Njac = IPAR[11]; + Nstp = IPAR[12]; + Nacc = IPAR[13]; + Nrej = IPAR[14]; + Ndec = IPAR[15]; + Nsol = IPAR[16]; + Nsng = IPAR[17]; + + /*~~~> Autonomous or time dependent ODE. Default is time dependent. */ + Autonomous = !(IPAR[0] == 0); + + /*~~~> For Scalar tolerances (IPAR[1] != 0) the code uses AbsTol[0] and RelTol[0] +! For Vector tolerances (IPAR[1] == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) */ + if (IPAR[1] == 0) { + VectorTol = 1; UplimTol = KPP_NVAR; + } else { + VectorTol = 0; UplimTol = 1; + } /* end if */ + + /*~~~> The maximum number of steps admitted */ + if (IPAR[2] == 0) + Max_no_steps = 100000; + else + Max_no_steps=IPAR[2]; + if (Max_no_steps < 0) { + printf("\n User-selected max no. of steps: IPAR[2]=%d\n",IPAR[2]); + return ros_ErrorMsg(-1,Tstart,ZERO); + } /* end if */ + + /*~~~> The particular Rosenbrock method chosen */ + if (IPAR[3] == 0) + Method = 3; + else + Method = IPAR[3]; + if ( (IPAR[3] < 1) || (IPAR[3] > 5) ){ + printf("\n User-selected Rosenbrock method: IPAR[3]=%d\n",IPAR[3]); + return ros_ErrorMsg(-2,Tstart,ZERO); + } /* end if */ + + /*~~~> Unit Roundoff (1+Roundoff>1) */ + Roundoff = WLAMCH('E'); + + /*~~~> Lower bound on the step size: (positive value) */ + Hmin = RPAR[0]; + if (RPAR[0] < ZERO) { + printf("\n User-selected Hmin: RPAR[0]=%e\n", RPAR[0]); + return ros_ErrorMsg(-3,Tstart,ZERO); + } /* end if */ + /*~~~> Upper bound on the step size: (positive value) */ + if (RPAR[1] == ZERO) + Hmax = ABS(Tend-Tstart); + else + Hmax = MIN(ABS(RPAR[1]),ABS(Tend-Tstart)); + if (RPAR[1] < ZERO) { + printf("\n User-selected Hmax: RPAR[1]=%e\n", RPAR[1]); + return ros_ErrorMsg(-3,Tstart,ZERO); + } /* end if */ + /*~~~> Starting step size: (positive value) */ + if (RPAR[2] == ZERO) + Hstart = MAX(Hmin,DeltaMin); + else + Hstart = MIN(ABS(RPAR[2]),ABS(Tend-Tstart)); + if (RPAR[2] < ZERO) { + printf("\n User-selected Hstart: RPAR[2]=%e\n", RPAR[2]); + return ros_ErrorMsg(-3,Tstart,ZERO); + } /* end if */ + /*~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax */ + if (RPAR[3] == ZERO) + FacMin = (KPP_REAL)0.2; + else + FacMin = RPAR[3]; + if (RPAR[3] < ZERO) { + printf("\n User-selected FacMin: RPAR[3]=%e\n", RPAR[3]); + return ros_ErrorMsg(-4,Tstart,ZERO); + } /* end if */ + if (RPAR[4] == ZERO) + FacMax = (KPP_REAL)6.0; + else + FacMax = RPAR[4]; + if (RPAR[4] < ZERO) { + printf("\n User-selected FacMax: RPAR[4]=%e\n", RPAR[4]); + return ros_ErrorMsg(-4,Tstart,ZERO); + } /* end if */ + /*~~~> FacRej: Factor to decrease step after 2 succesive rejections */ + if (RPAR[5] == ZERO) + FacRej = (KPP_REAL)0.1; + else + FacRej = RPAR[5]; + if (RPAR[5] < ZERO) { + printf("\n User-selected FacRej: RPAR[5]=%e\n", RPAR[5]); + return ros_ErrorMsg(-4,Tstart,ZERO); + } /* end if */ + /*~~~> FacSafe: Safety Factor in the computation of new step size */ + if (RPAR[6] == ZERO) + FacSafe = (KPP_REAL)0.9; + else + FacSafe = RPAR[6]; + if (RPAR[6] < ZERO) { + printf("\n User-selected FacSafe: RPAR[6]=%e\n", RPAR[6]); + return ros_ErrorMsg(-4,Tstart,ZERO); + } /* end if */ + /*~~~> Check if tolerances are reasonable */ + for (i = 0; i < UplimTol; i++) { + if ( (AbsTol[i] <= ZERO) || (RelTol[i] <= 10.0*Roundoff) + || (RelTol[i] >= ONE) ) { + printf("\n AbsTol[%d] = %e\n",i,AbsTol[i]); + printf("\n RelTol[%d] = %e\n",i,RelTol[i]); + return ros_ErrorMsg(-5,Tstart,ZERO); + } /* end if */ + } /* for */ + + + /*~~~> Initialize the particular Rosenbrock method */ + switch (Method) { + case 1: + Ros2(&ros_S, ros_A, ros_C, ros_M, ros_E, + ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); + break; + case 2: + Ros3(&ros_S, ros_A, ros_C, ros_M, ros_E, + ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); + break; + case 3: + Ros4(&ros_S, ros_A, ros_C, ros_M, ros_E, + ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); + break; + case 4: + Rodas3(&ros_S, ros_A, ros_C, ros_M, ros_E, + ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); + break; + case 5: + Rodas4(&ros_S, ros_A, ros_C, ros_M, ros_E, + ros_Alpha, ros_Gamma, ros_NewF, &ros_ELO, ros_Name); + break; + default: + printf("\n Unknown Rosenbrock method: IPAR[3]= %d", Method); + return ros_ErrorMsg(-2,Tstart,ZERO); + } /* end switch */ + + /*~~~> Rosenbrock method */ + IERR = RosenbrockIntegrator( Y,Tstart,Tend, + AbsTol, RelTol, + ode_Fun,ode_Jac , + /* Rosenbrock method coefficients */ + ros_S, ros_M, ros_E, ros_A, ros_C, + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, + /* Integration parameters */ + Autonomous, VectorTol, Max_no_steps, + Roundoff, Hmin, Hmax, Hstart, + FacMin, FacMax, FacRej, FacSafe, + /* Output parameters */ + &Texit, &Hexit ); + + + /*~~~> Collect run statistics */ + IPAR[10] = Nfun; + IPAR[11] = Njac; + IPAR[12] = Nstp; + IPAR[13] = Nacc; + IPAR[14] = Nrej; + IPAR[15] = Ndec; + IPAR[16] = Nsol; + IPAR[17] = Nsng; + /*~~~> Last T and H */ + RPAR[10] = Texit; + RPAR[11] = Hexit; + + return IERR; + +} /* Rosenbrock */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int RosenbrockIntegrator( + /*~~~> Input: the initial condition at Tstart; Output: the solution at T */ + KPP_REAL Y[], + /*~~~> Input: integration interval */ + KPP_REAL Tstart, KPP_REAL Tend , + /*~~~> Input: tolerances */ + KPP_REAL AbsTol[], KPP_REAL RelTol[], + /*~~~> Input: ode function and its Jacobian */ + void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), + void (*ode_Jac)(KPP_REAL, KPP_REAL [], KPP_REAL []) , + /*~~~> Input: The Rosenbrock method parameters */ + int ros_S, + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_Alpha[],KPP_REAL ros_Gamma[], + KPP_REAL ros_ELO, char ros_NewF[], + /*~~~> Input: integration parameters */ + char Autonomous, char VectorTol, + int Max_no_steps, + KPP_REAL Roundoff, KPP_REAL Hmin, KPP_REAL Hmax, KPP_REAL Hstart, + KPP_REAL FacMin, KPP_REAL FacMax, KPP_REAL FacRej, KPP_REAL FacSafe, + /*~~~> Output: time at which the solution is returned (T=Tend if success) + and last accepted step */ + KPP_REAL *Texit, KPP_REAL *Hexit ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Template for the implementation of a generic Rosenbrock method + defined by ros_S (no of stages) and coefficients ros_{A,C,M,E,Alpha,Gamma} + + returned value: IERR, indicator of success (if positive) + or failure (if negative) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + KPP_REAL Ynew[KPP_NVAR], Fcn0[KPP_NVAR], Fcn[KPP_NVAR], + dFdT[KPP_NVAR], + Jac0[KPP_LU_NONZERO], Ghimj[KPP_LU_NONZERO]; + KPP_REAL K[KPP_NVAR*ros_S]; + KPP_REAL H, T, Hnew, HC, HG, Fac, Tau; + KPP_REAL Err, Yerr[KPP_NVAR]; + int Pivot[KPP_NVAR], Direction, ioffset, j, istage; + char RejectLastH, RejectMoreH; + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + + /*~~~> INITIAL PREPARATIONS */ + T = Tstart; + *Hexit = 0.0; + H = MIN(Hstart,Hmax); + if (ABS(H) <= 10.0*Roundoff) + H = DeltaMin; + + if (Tend >= Tstart) { + Direction = +1; + } else { + Direction = -1; + } /* end if */ + + RejectLastH=0; RejectMoreH=0; + + /*~~~> Time loop begins below */ + + while ( ( (Direction > 0) && ((T-Tend)+Roundoff <= ZERO) ) + || ( (Direction < 0) && ((Tend-T)+Roundoff <= ZERO) ) ) { + + if ( Nstp > Max_no_steps ) { /* Too many steps */ + *Texit = T; + return ros_ErrorMsg(-6,T,H); + } + if ( ((T+0.1*H) == T) || (H <= Roundoff) ) { /* Step size too small */ + *Texit = T; + return ros_ErrorMsg(-7,T,H); + } + + /*~~~> Limit H if necessary to avoid going beyond Tend */ + *Hexit = H; + H = MIN(H,ABS(Tend-T)); + + /*~~~> Compute the function at current time */ + (*ode_Fun)(T,Y,Fcn0); + + /*~~~> Compute the function derivative with respect to T */ + if (!Autonomous) + ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, ode_Fun, dFdT ); + + /*~~~> Compute the Jacobian at current time */ + (*ode_Jac)(T,Y,Jac0); + + /*~~~> Repeat step calculation until current step accepted */ + while (1) { /* WHILE STEP NOT ACCEPTED */ + + + if( ros_PrepareMatrix( &H, Direction, ros_Gamma[0], + Jac0, Ghimj, Pivot) ) { /* More than 5 consecutive failed decompositions */ + *Texit = T; + return ros_ErrorMsg(-8,T,H); + } + + /*~~~> Compute the stages */ + for (istage = 1; istage <= ros_S; istage++) { + + /* Current istage offset. Current istage vector is K[ioffset:ioffset+KPP_NVAR-1] */ + ioffset = KPP_NVAR*(istage-1); + + /* For the 1st istage the function has been computed previously */ + if ( istage == 1 ) + WCOPY(KPP_NVAR,Fcn0,1,Fcn,1); + else { /* istage>1 and a new function evaluation is needed at current istage */ + if ( ros_NewF[istage-1] ) { + WCOPY(KPP_NVAR,Y,1,Ynew,1); + for (j = 1; j <= istage-1; j++) + WAXPY(KPP_NVAR,ros_A[(istage-1)*(istage-2)/2+j-1], + &K[KPP_NVAR*(j-1)],1,Ynew,1); + Tau = T + ros_Alpha[istage-1]*Direction*H; + (*ode_Fun)(Tau,Ynew,Fcn); + } /*end if ros_NewF(istage)*/ + } /* end if istage */ + + WCOPY(KPP_NVAR,Fcn,1,&K[ioffset],1); + for (j = 1; j <= istage-1; j++) { + HC = ros_C[(istage-1)*(istage-2)/2+j-1]/(Direction*H); + WAXPY(KPP_NVAR,HC,&K[KPP_NVAR*(j-1)],1,&K[ioffset],1); + } /* for j */ + + if ((!Autonomous) && (ros_Gamma[istage-1])) { + HG = Direction*H*ros_Gamma[istage-1]; + WAXPY(KPP_NVAR,HG,dFdT,1,&K[ioffset],1); + } /* end if !Autonomous */ + + SolveTemplate(Ghimj, Pivot, &K[ioffset]); + + } /* for istage */ + + + /*~~~> Compute the new solution */ + WCOPY(KPP_NVAR,Y,1,Ynew,1); + for (j=1; j<=ros_S; j++) + WAXPY(KPP_NVAR,ros_M[j-1],&K[KPP_NVAR*(j-1)],1,Ynew,1); + + /*~~~> Compute the error estimation */ + WSCAL(KPP_NVAR,ZERO,Yerr,1); + for (j=1; j<=ros_S; j++) + WAXPY(KPP_NVAR,ros_E[j-1],&K[KPP_NVAR*(j-1)],1,Yerr,1); + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ); + + /*~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax */ + Fac = MIN(FacMax,MAX(FacMin,FacSafe/pow(Err,ONE/ros_ELO))); + Hnew = H*Fac; + + /*~~~> Check the error magnitude and adjust step size */ + Nstp++; + if ( (Err <= ONE) || (H <= Hmin) ) { /*~~~> Accept step */ + Nacc++; + WCOPY(KPP_NVAR,Ynew,1,Y,1); + T += Direction*H; + Hnew = MAX(Hmin,MIN(Hnew,Hmax)); + /* No step size increase after a rejected step */ + if (RejectLastH) + Hnew = MIN(Hnew,H); + RejectLastH = 0; RejectMoreH = 0; + H = Hnew; + break; /* EXIT THE LOOP: WHILE STEP NOT ACCEPTED */ + } else { /*~~~> Reject step */ + if (Nacc >= 1) + Nrej++; + if (RejectMoreH) + Hnew=H*FacRej; + RejectMoreH = RejectLastH; RejectLastH = 1; + H = Hnew; + } /* end if Err <= 1 */ + + } /* while LOOP: WHILE STEP NOT ACCEPTED */ + + } /* while: time loop */ + + /*~~~> The integration was successful */ + *Texit = T; + return 1; + +} /* RosenbrockIntegrator */ + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +KPP_REAL ros_ErrorNorm ( + /*~~~> Input arguments */ + KPP_REAL Y[], KPP_REAL Ynew[], KPP_REAL Yerr[], + KPP_REAL AbsTol[], KPP_REAL RelTol[], + char VectorTol ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Computes and returns the "scaled norm" of the error vector Yerr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Local variables */ + KPP_REAL Err, Scale, Ymax; + int i; + + Err = ZERO; + for (i=0; i Input arguments: */ + KPP_REAL T, KPP_REAL Roundoff, + KPP_REAL Y[], KPP_REAL Fcn0[], + void (*ode_Fun)(KPP_REAL, KPP_REAL [], KPP_REAL []), + /*~~~> Output arguments: */ + KPP_REAL dFdT[] ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The time partial derivative of the function by finite differences +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Local variables */ + KPP_REAL Delta; + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)); + (*ode_Fun)(T+Delta,Y,dFdT); + WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1); + WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1); + +} /* ros_FunTimeDerivative */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +char ros_PrepareMatrix ( + /* Inout argument: (step size is decreased when LU fails) */ + KPP_REAL* H, + /* Input arguments: */ + int Direction, KPP_REAL gam, KPP_REAL Jac0[], + /* Output arguments: */ + KPP_REAL Ghimj[], int Pivot[] ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Prepares the LHS matrix for stage calculations + 1. Construct Ghimj = 1/(H*ham) - Jac0 + "(Gamma H) Inverse Minus Jacobian" + 2. Repeat LU decomposition of Ghimj until successful. + -half the step size if LU decomposition fails and retry + -exit after 5 consecutive fails + + Return value: Singular (true=1=failed_LU or false=0=successful_LU) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Local variables */ + int i, ising, Nconsecutive; + KPP_REAL ghinv; + + Nconsecutive = 0; + + while (1) { /* while Singular */ + + /*~~~> Construct Ghimj = 1/(H*ham) - Jac0 */ + WCOPY(KPP_LU_NONZERO,Jac0,1,Ghimj,1); + WSCAL(KPP_LU_NONZERO,(-ONE),Ghimj,1); + ghinv = ONE/(Direction*(*H)*gam); + for (i=0; i Compute LU decomposition */ + DecompTemplate( Ghimj, Pivot, &ising ); + if (ising == 0) { + /*~~~> if successful done */ + return 0; /* Singular = false */ + } else { /* ising .ne. 0 */ + /*~~~> if unsuccessful half the step size; if 5 consecutive fails return */ + Nsng++; Nconsecutive++; + printf("\nWarning: LU Decomposition returned ising = %d\n",ising); + if (Nconsecutive <= 5) { /* Less than 5 consecutive failed LUs */ + *H = (*H)*HALF; + } else { /* More than 5 consecutive failed LUs */ + return 1; /* Singular = true */ + } /* end if Nconsecutive */ + } /* end if ising */ + + } /* while Singular */ + +} /* ros_PrepareMatrix */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int ros_ErrorMsg(int Code, KPP_REAL T, KPP_REAL H) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Handles all error messages and returns IERR = error Code +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + printf("\nForced exit from Rosenbrock due to the following error:\n"); + + switch (Code) { + case -1: + printf("--> Improper value for maximal no of steps"); break; + case -2: + printf("--> Selected Rosenbrock method not implemented"); break; + case -3: + printf("--> Hmin/Hmax/Hstart must be positive"); break; + case -4: + printf("--> FacMin/FacMax/FacRej must be positive"); break; + case -5: + printf("--> Improper tolerance values"); break; + case -6: + printf("--> No of steps exceeds maximum bound"); break; + case -7: + printf("--> Step size too small (T + H/10 = T) or H < Roundoff"); break; + case -8: + printf("--> Matrix is repeatedly singular"); break; + default: + printf("Unknown Error code: %d ",Code); + } /* end switch */ + + printf("\n Time = %15.7e, H = %15.7e",T,H); + printf("\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n"); + + return Code; + +} /* ros_ErrorMsg */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Ros2 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + AN L-STABLE METHOD, 2 stages, order 2 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + double g = (KPP_REAL)1.70710678118655; /* 1.0 + 1.0/SQRT(2.0) */ + + /*~~~> Name of the method */ + strcpy(ros_Name, "ROS-2"); + + /*~~~> Number of stages */ + *ros_S = 2; + + /*~~~> The coefficient matrices A and C are strictly lower triangular. + The lower triangular (subdiagonal) elements are stored in row-wise order: + A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. + The general mapping formula is: + A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ + ros_A[0] = 1.0/g; + + /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ + ros_C[0] = (-2.0)/g; + + /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) + or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ + ros_NewF[0] = 1; + ros_NewF[1] = 1; + + /*~~~> M_i = Coefficients for new step solution */ + ros_M[0]= (3.0)/(2.0*g); + ros_M[1]= (1.0)/(2.0*g); + + /*~~~> E_i = Coefficients for error estimator */ + ros_E[0] = 1.0/(2.0*g); + ros_E[1] = 1.0/(2.0*g); + + /*~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one */ + *ros_ELO = (KPP_REAL)2.0; + + /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ + ros_Alpha[0] = (KPP_REAL)0.0; + ros_Alpha[1] = (KPP_REAL)1.0; + + /*~~~> Gamma_i = \sum_j gamma_{i,j} */ + ros_Gamma[0] = g; + ros_Gamma[1] = -g; + +} /* Ros2 */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Ros3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Name of the method */ + strcpy(ros_Name, "ROS-3"); + + /*~~~> Number of stages */ + *ros_S = 3; + + /*~~~> The coefficient matrices A and C are strictly lower triangular. + The lower triangular (subdiagonal) elements are stored in row-wise order: + A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. + The general mapping formula is: + A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ + ros_A[0]= (KPP_REAL)1.0; + ros_A[1]= (KPP_REAL)1.0; + ros_A[2]= (KPP_REAL)0.0; + + /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ + ros_C[0] = (KPP_REAL)(-1.0156171083877702091975600115545); + ros_C[1] = (KPP_REAL)4.0759956452537699824805835358067; + ros_C[2] = (KPP_REAL)9.2076794298330791242156818474003; + + /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) + or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ + ros_NewF[0] = 1; + ros_NewF[1] = 1; + ros_NewF[2] = 0; + + /*~~~> M_i = Coefficients for new step solution */ + ros_M[0] = (KPP_REAL)1.0; + ros_M[1] = (KPP_REAL)6.1697947043828245592553615689730; + ros_M[2] = (KPP_REAL)(-0.4277225654321857332623837380651); + + /*~~~> E_i = Coefficients for error estimator */ + ros_E[0] = (KPP_REAL)0.5; + ros_E[1] = (KPP_REAL)(-2.9079558716805469821718236208017); + ros_E[2] = (KPP_REAL)0.2235406989781156962736090927619; + + /*~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 */ + *ros_ELO = (KPP_REAL)3.0; + + /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ + ros_Alpha[0]= (KPP_REAL)0.0; + ros_Alpha[1]= (KPP_REAL)0.43586652150845899941601945119356; + ros_Alpha[2]= (KPP_REAL)0.43586652150845899941601945119356; + + /*~~~> Gamma_i = \sum_j gamma_{i,j} */ + ros_Gamma[0]= (KPP_REAL)0.43586652150845899941601945119356; + ros_Gamma[1]= (KPP_REAL)0.24291996454816804366592249683314; + ros_Gamma[2]= (KPP_REAL)2.1851380027664058511513169485832; + +} /* Ros3 */ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Ros4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES + L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 + + E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL + EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. + SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, + SPRINGER-VERLAG (1990) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Name of the method */ + strcpy(ros_Name, "ROS-4"); + + /*~~~> Number of stages */ + *ros_S = 4; + + /*~~~> The coefficient matrices A and C are strictly lower triangular. + The lower triangular (subdiagonal) elements are stored in row-wise order: + A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. + The general mapping formula is: + A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ + ros_A[0] = (KPP_REAL)0.2000000000000000e+01; + ros_A[1] = (KPP_REAL)0.1867943637803922e+01; + ros_A[2] = (KPP_REAL)0.2344449711399156; + ros_A[3] = ros_A[1]; + ros_A[4] = ros_A[2]; + ros_A[5] = (KPP_REAL)0.0; + + /*~~~> C(i,j) = (KPP_REAL)ros_C( (i-1)*(i-2)/2 + j ) */ + ros_C[0] = (KPP_REAL)(-0.7137615036412310e+01); + ros_C[1] = (KPP_REAL)( 0.2580708087951457e+01); + ros_C[2] = (KPP_REAL)( 0.6515950076447975); + ros_C[3] = (KPP_REAL)(-0.2137148994382534e+01); + ros_C[4] = (KPP_REAL)(-0.3214669691237626); + ros_C[5] = (KPP_REAL)(-0.6949742501781779); + + /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) + or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ + ros_NewF[0] = 1; + ros_NewF[1] = 1; + ros_NewF[2] = 1; + ros_NewF[3] = 0; + + /*~~~> M_i = Coefficients for new step solution */ + ros_M[0] = (KPP_REAL)0.2255570073418735e+01; + ros_M[1] = (KPP_REAL)0.2870493262186792; + ros_M[2] = (KPP_REAL)0.4353179431840180; + ros_M[3] = (KPP_REAL)0.1093502252409163e+01; + + /*~~~> E_i = Coefficients for error estimator */ + ros_E[0] = (KPP_REAL)(-0.2815431932141155); + ros_E[1] = (KPP_REAL)(-0.7276199124938920e-01); + ros_E[2] = (KPP_REAL)(-0.1082196201495311); + ros_E[3] = (KPP_REAL)(-0.1093502252409163e+01); + + /*~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 */ + *ros_ELO = (KPP_REAL)4.0; + + /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ + ros_Alpha[0] = (KPP_REAL)0.0; + ros_Alpha[1] = (KPP_REAL)0.1145640000000000e+01; + ros_Alpha[2] = (KPP_REAL)0.6552168638155900; + ros_Alpha[3] = (KPP_REAL)ros_Alpha[2]; + + /*~~~> Gamma_i = \sum_j gamma_{i,j} */ + ros_Gamma[0] = (KPP_REAL)( 0.5728200000000000); + ros_Gamma[1] = (KPP_REAL)(-0.1769193891319233e+01); + ros_Gamma[2] = (KPP_REAL)( 0.7592633437920482); + ros_Gamma[3] = (KPP_REAL)(-0.1049021087100450); + +} /* Ros4 */ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Rodas3 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Name of the method */ + strcpy(ros_Name, "RODAS-3"); + + /*~~~> Number of stages */ + *ros_S = 4; + + /*~~~> The coefficient matrices A and C are strictly lower triangular. + The lower triangular (subdiagonal) elements are stored in row-wise order: + A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. + The general mapping formula is: + A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ + ros_A[0] = (KPP_REAL)0.0; + ros_A[1] = (KPP_REAL)2.0; + ros_A[2] = (KPP_REAL)0.0; + ros_A[3] = (KPP_REAL)2.0; + ros_A[4] = (KPP_REAL)0.0; + ros_A[5] = (KPP_REAL)1.0; + + /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ + ros_C[0] = (KPP_REAL)4.0; + ros_C[1] = (KPP_REAL)1.0; + ros_C[2] = (KPP_REAL)(-1.0); + ros_C[3] = (KPP_REAL)1.0; + ros_C[4] = (KPP_REAL)(-1.0); + ros_C[5] = (KPP_REAL)(-2.66666666666667); /* -8/3 */ + + /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) + or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ + ros_NewF[0] = 1; + ros_NewF[1] = 0; + ros_NewF[2] = 1; + ros_NewF[3] = 1; + + /*~~~> M_i = Coefficients for new step solution */ + ros_M[0] = (KPP_REAL)2.0; + ros_M[1] = (KPP_REAL)0.0; + ros_M[2] = (KPP_REAL)1.0; + ros_M[3] = (KPP_REAL)1.0; + + /*~~~> E_i = Coefficients for error estimator */ + ros_E[0] = (KPP_REAL)0.0; + ros_E[1] = (KPP_REAL)0.0; + ros_E[2] = (KPP_REAL)0.0; + ros_E[3] = (KPP_REAL)1.0; + + /*~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 */ + *ros_ELO = (KPP_REAL)3.0; + + /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ + ros_Alpha[0] = (KPP_REAL)0.0; + ros_Alpha[1] = (KPP_REAL)0.0; + ros_Alpha[2] = (KPP_REAL)1.0; + ros_Alpha[3] = (KPP_REAL)1.0; + + /*~~~> Gamma_i = \sum_j gamma_{i,j} */ + ros_Gamma[0] = (KPP_REAL)0.5; + ros_Gamma[1] = (KPP_REAL)1.5; + ros_Gamma[2] = (KPP_REAL)0.0; + ros_Gamma[3] = (KPP_REAL)0.0; + +} /* Rodas3 */ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Rodas4 ( int *ros_S, KPP_REAL ros_A[], KPP_REAL ros_C[], + KPP_REAL ros_M[], KPP_REAL ros_E[], + KPP_REAL ros_Alpha[], KPP_REAL ros_Gamma[], + char ros_NewF[], KPP_REAL *ros_ELO, char* ros_Name ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES + + E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL + EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. + SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, + SPRINGER-VERLAG (1996) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Name of the method */ + strcpy(ros_Name, "RODAS-4"); + + /*~~~> Number of stages */ + *ros_S = 6; + + /*~~~> Y_stage_i ~ Y( T + H*Alpha_i ) */ + ros_Alpha[0] = (KPP_REAL)0.000; + ros_Alpha[1] = (KPP_REAL)0.386; + ros_Alpha[2] = (KPP_REAL)0.210; + ros_Alpha[3] = (KPP_REAL)0.630; + ros_Alpha[4] = (KPP_REAL)1.000; + ros_Alpha[5] = (KPP_REAL)1.000; + + /*~~~> Gamma_i = \sum_j gamma_{i,j} */ + ros_Gamma[0] = (KPP_REAL)0.2500000000000000; + ros_Gamma[1] = (KPP_REAL)(-0.1043000000000000); + ros_Gamma[2] = (KPP_REAL)0.1035000000000000; + ros_Gamma[3] = (KPP_REAL)(-0.3620000000000023e-01); + ros_Gamma[4] = (KPP_REAL)0.0; + ros_Gamma[5] = (KPP_REAL)0.0; + + /*~~~> The coefficient matrices A and C are strictly lower triangular. + The lower triangular (subdiagonal) elements are stored in row-wise order: + A(2,1) = ros_A[0], A(3,1)=ros_A[1], A(3,2)=ros_A[2], etc. + The general mapping formula is: A_{i,j} = ros_A[ (i-1)*(i-2)/2 + j -1 ] */ + ros_A[0] = (KPP_REAL)0.1544000000000000e+01; + ros_A[1] = (KPP_REAL)0.9466785280815826; + ros_A[2] = (KPP_REAL)0.2557011698983284; + ros_A[3] = (KPP_REAL)0.3314825187068521e+01; + ros_A[4] = (KPP_REAL)0.2896124015972201e+01; + ros_A[5] = (KPP_REAL)0.9986419139977817; + ros_A[6] = (KPP_REAL)0.1221224509226641e+01; + ros_A[7] = (KPP_REAL)0.6019134481288629e+01; + ros_A[8] = (KPP_REAL)0.1253708332932087e+02; + ros_A[9] = (KPP_REAL)(-0.6878860361058950); + ros_A[10] = ros_A[6]; + ros_A[11] = ros_A[7]; + ros_A[12] = ros_A[8]; + ros_A[13] = ros_A[9]; + ros_A[14] = (KPP_REAL)1.0; + + /*~~~> C_{i,j} = ros_C[ (i-1)*(i-2)/2 + j -1] */ + ros_C[0] = (KPP_REAL)(-0.5668800000000000e+01); + ros_C[1] = (KPP_REAL)(-0.2430093356833875e+01); + ros_C[2] = (KPP_REAL)(-0.2063599157091915); + ros_C[3] = (KPP_REAL)(-0.1073529058151375); + ros_C[4] = (KPP_REAL)(-0.9594562251023355e+01); + ros_C[5] = (KPP_REAL)(-0.2047028614809616e+02); + ros_C[6] = (KPP_REAL)( 0.7496443313967647e+01); + ros_C[7] = (KPP_REAL)(-0.1024680431464352e+02); + ros_C[8] = (KPP_REAL)(-0.3399990352819905e+02); + ros_C[9] = (KPP_REAL)( 0.1170890893206160e+02); + ros_C[10] = (KPP_REAL)( 0.8083246795921522e+01); + ros_C[11] = (KPP_REAL)(-0.7981132988064893e+01); + ros_C[12] = (KPP_REAL)(-0.3152159432874371e+02); + ros_C[13] = (KPP_REAL)( 0.1631930543123136e+02); + ros_C[14] = (KPP_REAL)(-0.6058818238834054e+01); + + /*~~~> M_i = Coefficients for new step solution */ + ros_M[0] = ros_A[6]; + ros_M[1] = ros_A[7]; + ros_M[2] = ros_A[8]; + ros_M[3] = ros_A[9]; + ros_M[4] = (KPP_REAL)1.0; + ros_M[5] = (KPP_REAL)1.0; + + /*~~~> E_i = Coefficients for error estimator */ + ros_E[0] = (KPP_REAL)0.0; + ros_E[1] = (KPP_REAL)0.0; + ros_E[2] = (KPP_REAL)0.0; + ros_E[3] = (KPP_REAL)0.0; + ros_E[4] = (KPP_REAL)0.0; + ros_E[5] = (KPP_REAL)1.0; + + /*~~~> does the stage i require a new function evaluation (ros_NewF(i)=TRUE) + or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) */ + ros_NewF[0] = 1; + ros_NewF[1] = 1; + ros_NewF[2] = 1; + ros_NewF[3] = 1; + ros_NewF[4] = 1; + ros_NewF[5] = 1; + + /*~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 */ + *ros_ELO = (KPP_REAL)4.0; + +} /* Rodas4 */ + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void DecompTemplate( KPP_REAL A[], int Pivot[], int* ising ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Template for the LU decomposition +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + *ising = KppDecomp ( A ); + /*~~~> Note: for a full matrix use Lapack: + DGETRF( KPP_NVAR, KPP_NVAR, A, KPP_NVAR, Pivot, ising ) */ + + Ndec++; + +} /* DecompTemplate */ + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + void SolveTemplate( KPP_REAL A[], int Pivot[], KPP_REAL b[] ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Template for the forward/backward substitution (using pre-computed LU decomposition) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + KppSolve( A, b ); + /*~~~> Note: for a full matrix use Lapack: + NRHS = 1 + DGETRS( 'N', KPP_NVAR , NRHS, A, KPP_NVAR, Pivot, b, KPP_NVAR, INFO ) */ + + Nsol++; + +} /* SolveTemplate */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void FunTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Ydot[] ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Template for the ODE function call. + Updates the rate coefficients (and possibly the fixed species) at each call +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + KPP_REAL Told; + + Told = TIME; + TIME = T; + Update_SUN(); + Update_RCONST(); + Fun( Y, FIX, RCONST, Ydot ); + TIME = Told; + + Nfun++; + +} /* FunTemplate */ + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void JacTemplate( KPP_REAL T, KPP_REAL Y[], KPP_REAL Jcb[] ) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Template for the ODE Jacobian call. + Updates the rate coefficients (and possibly the fixed species) at each call +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + /*~~~> Local variables */ + KPP_REAL Told; + + Told = TIME; + TIME = T ; + Update_SUN(); + Update_RCONST(); + Jac_SP( Y, FIX, RCONST, Jcb ); + TIME = Told; + + Njac++; + +} /* JacTemplate */ + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.def new file mode 100755 index 00000000..81a16c52 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE rosenbrock + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f new file mode 100755 index 00000000..f7920b8f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f @@ -0,0 +1,1286 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER Nstp, Nacc, Nrej, Nsng, IERR + SAVE Nstp, Nacc, Nrej, Nsng + +! TIN - Start Time + KPP_REAL TIN +! TOUT - End Time + KPP_REAL TOUT + INTEGER i + + KPP_REAL RPAR(20) + INTEGER IPAR(20) + EXTERNAL FunTemplate, JacTemplate + + + DO i=1,20 + IPAR(i) = 0 + RPAR(i) = 0.0d0 + ENDDO + + + IPAR(1) = 0 ! non-autonomous + IPAR(2) = 1 ! vector tolerances + RPAR(3) = STEPMIN ! starting step + IPAR(4) = 5 ! choice of the method + + CALL Rosenbrock(VAR,TIN,TOUT, + & ATOL,RTOL, + & FunTemplate,JacTemplate, + & RPAR,IPAR,IERR) + + + Nstp = Nstp + IPAR(13) + Nacc = Nacc + IPAR(14) + Nrej = Nrej + IPAR(15) + Nsng = Nsng + IPAR(18) + PRINT*,'Step=',Nstp,' Acc=',Nacc,' Rej=',Nrej, + & ' Singular=',Nsng + + + IF (IERR.LT.0) THEN + print *,'Rosenbrock: Unsucessful step at T=', + & TIN,' (IERR=',IERR,')' + ENDIF + + TIN = RPAR(11) ! Exit time + STEPMIN = RPAR(12) + + RETURN + END + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rosenbrock(Y,Tstart,Tend, + & AbsTol,RelTol, + & ode_Fun,ode_Jac , + & RPAR,IPAR,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - ode_Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = ode_Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE ode_Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE ode_Fun( T, Y, Ydot ) = Jacobian of the ODE function, +! returns Jcb = dF/dY +!- IPAR(1:10) = integer inputs parameters +!- RPAR(1:10) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- IPAR(11:20) -> integer output parameters +!- RPAR(11:20) -> real output parameters +!- IERR -> job status upon return +! - succes (positive value) or failure (negative value) - +! = 1 : Success +! = -1 : Improper value for maximal no of steps +! = -2 : Selected Rosenbrock method not implemented +! = -3 : Hmin/Hmax/Hstart must be positive +! = -4 : FacMin/FacMax/FacRej must be positive +! = -5 : Improper tolerance values +! = -6 : No of steps exceeds maximum bound +! = -7 : Step size too small +! = -8 : Matrix is repeatedly singular +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! IPAR(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! IPAR(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! IPAR(3) -> maximum number of integration steps +! For IPAR(3)=0) the default value of 100000 is used +! +! IPAR(4) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! RPAR(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RPAR(2) -> Hmax, upper bound for the integration step size +! RPAR(3) -> Hstart, starting value for the integration step size +! +! RPAR(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RPAR(5) -> FacMin,upper bound on step increase factor (default=6) +! RPAR(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RPAR(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the corrent no. of fcn calls +! to previous value of IPAR(11), and similar for the other params. +! Set IPAR(11:20) = 0 before call to avoid this accumulation. +! +! IPAR(11) = No. of function calls +! IPAR(12) = No. of jacobian calls +! IPAR(13) = No. of steps +! IPAR(14) = No. of accepted steps +! IPAR(15) = No. of rejected steps (except at the beginning) +! IPAR(16) = No. of LU decompositions +! IPAR(17) = No. of forward/backward substitutions +! IPAR(18) = No. of singular matrix decompositions +! +! RPAR(11) -> Texit, the time corresponding to the +! computed Y upon return +! RPAR(12) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + KPP_REAL Tstart,Tend + KPP_REAL Y(KPP_NVAR),AbsTol(KPP_NVAR),RelTol(KPP_NVAR) + INTEGER IPAR(20) + KPP_REAL RPAR(20) + INTEGER IERR +!~~~> The method parameters + INTEGER Smax + PARAMETER (Smax = 6) + INTEGER Method, ros_S + KPP_REAL ros_M(Smax), ros_E(Smax) + KPP_REAL ros_A(Smax*(Smax-1)/2), ros_C(Smax*(Smax-1)/2) + KPP_REAL ros_Alpha(Smax), ros_Gamma(Smax), ros_ELO + LOGICAL ros_NewF(Smax) + CHARACTER*12 ros_Name +!~~~> Local variables + KPP_REAL Roundoff,FacMin,FacMax,FacRej,FacSafe + KPP_REAL Hmin, Hmax, Hstart, Hexit + KPP_REAL Texit + INTEGER i, UplimTol, Max_no_steps + LOGICAL Autonomous, VectorTol +!~~~> Statistics on the work performed + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng +!~~~> Parameters + KPP_REAL ZERO, ONE, DeltaMin + PARAMETER (ZERO = 0.0d0) + PARAMETER (ONE = 1.0d0) + PARAMETER (DeltaMin = 1.0d-5) +!~~~> Functions + EXTERNAL ode_Fun, ode_Jac + KPP_REAL WLAMCH, ros_ErrorNorm + EXTERNAL WLAMCH, ros_ErrorNorm + +!~~~> Initialize statistics + Nfun = IPAR(11) + Njac = IPAR(12) + Nstp = IPAR(13) + Nacc = IPAR(14) + Nrej = IPAR(15) + Ndec = IPAR(16) + Nsol = IPAR(17) + Nsng = IPAR(18) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(IPAR(1).EQ.0) + +!~~~> For Scalar tolerances (IPAR(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (IPAR(2).EQ.0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (IPAR(2).EQ.0) THEN + VectorTol = .TRUE. + UplimTol = KPP_NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> The maximum number of steps admitted + IF (IPAR(3).EQ.0) THEN + Max_no_steps = 100000 + ELSEIF (Max_no_steps.GT.0) THEN + Max_no_steps=IPAR(3) + ELSE + WRITE(6,*)'User-selected max no. of steps: IPAR(3)=',IPAR(3) + CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The particular Rosenbrock method chosen + IF (IPAR(4).EQ.0) THEN + Method = 3 + ELSEIF ( (IPAR(4).GE.1).AND.(IPAR(4).LE.5) ) THEN + Method = IPAR(4) + ELSE + WRITE (6,*) 'User-selected Rosenbrock method: IPAR(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RPAR(1).EQ.ZERO) THEN + Hmin = ZERO + ELSEIF (RPAR(1).GT.ZERO) THEN + Hmin = RPAR(1) + ELSE + WRITE (6,*) 'User-selected Hmin: RPAR(1)=', RPAR(1) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RPAR(2).EQ.ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RPAR(2).GT.ZERO) THEN + Hmax = MIN(ABS(RPAR(2)),ABS(Tend-Tstart)) + ELSE + WRITE (6,*) 'User-selected Hmax: RPAR(2)=', RPAR(2) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RPAR(3).EQ.ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RPAR(3).GT.ZERO) THEN + Hstart = MIN(ABS(RPAR(3)),ABS(Tend-Tstart)) + ELSE + WRITE (6,*) 'User-selected Hstart: RPAR(3)=', RPAR(3) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RPAR(4).EQ.ZERO) THEN + FacMin = 0.2d0 + ELSEIF (RPAR(4).GT.ZERO) THEN + FacMin = RPAR(4) + ELSE + WRITE (6,*) 'User-selected FacMin: RPAR(4)=', RPAR(4) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RPAR(5).EQ.ZERO) THEN + FacMax = 6.0d0 + ELSEIF (RPAR(5).GT.ZERO) THEN + FacMax = RPAR(5) + ELSE + WRITE (6,*) 'User-selected FacMax: RPAR(5)=', RPAR(5) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RPAR(6).EQ.ZERO) THEN + FacRej = 0.1d0 + ELSEIF (RPAR(6).GT.ZERO) THEN + FacRej = RPAR(6) + ELSE + WRITE (6,*) 'User-selected FacRej: RPAR(6)=', RPAR(6) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RPAR(7).EQ.ZERO) THEN + FacSafe = 0.9d0 + ELSEIF (RPAR(7).GT.ZERO) THEN + FacSafe = RPAR(7) + ELSE + WRITE (6,*) 'User-selected FacSafe: RPAR(7)=', RPAR(7) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i).LE.ZERO) .OR. (RelTol(i).LE.10.d0*Roundoff) + & .OR. (RelTol(i).GE.1.0d0) ) THEN + WRITE (6,*) ' AbsTol(',i,') = ',AbsTol(i) + WRITE (6,*) ' RelTol(',i,') = ',RelTol(i) + CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Initialize the particular Rosenbrock method + + IF (Method .EQ. 1) THEN + CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, + & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + ELSEIF (Method .EQ. 2) THEN + CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, + & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + ELSEIF (Method .EQ. 3) THEN + CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, + & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + ELSEIF (Method .EQ. 4) THEN + CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, + & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + ELSEIF (Method .EQ. 5) THEN + CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, + & ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + ELSE + WRITE (6,*) 'Unknown Rosenbrock method: IPAR(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> CALL Rosenbrock method + CALL RosenbrockIntegrator(Y,Tstart,Tend,Texit, + & AbsTol,RelTol, + & ode_Fun,ode_Jac , +! Rosenbrock method coefficients + & ros_S, ros_M, ros_E, ros_A, ros_C, + & ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, +! Integration parameters + & Autonomous, VectorTol, Max_no_steps, + & Roundoff, Hmin, Hmax, Hstart, Hexit, + & FacMin, FacMax, FacRej, FacSafe, +! Error indicator + & IERR) + + +!~~~> Collect run statistics + IPAR(11) = Nfun + IPAR(12) = Njac + IPAR(13) = Nstp + IPAR(14) = Nacc + IPAR(15) = Nrej + IPAR(16) = Ndec + IPAR(17) = Nsol + IPAR(18) = Nsng +!~~~> Last T and H + RPAR(11) = Texit + RPAR(12) = Hexit + + RETURN + END ! SUBROUTINE Rosenbrock + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE RosenbrockIntegrator(Y,Tstart,Tend,T, + & AbsTol,RelTol, + & ode_Fun,ode_Jac , +!~~~> Rosenbrock method coefficients + & ros_S, ros_M, ros_E, ros_A, ros_C, + & ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, +!~~~> Integration parameters + & Autonomous, VectorTol, Max_no_steps, + & Roundoff, Hmin, Hmax, Hstart, Hexit, + & FacMin, FacMax, FacRej, FacSafe, +!~~~> Error indicator + & IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL Y(KPP_NVAR) +!~~~> Input: integration interval + KPP_REAL Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL T +!~~~> Input: tolerances + KPP_REAL AbsTol(KPP_NVAR), RelTol(KPP_NVAR) +!~~~> Input: ode function and its Jacobian + EXTERNAL ode_Fun, ode_Jac +!~~~> Input: The Rosenbrock method parameters + INTEGER ros_S + KPP_REAL ros_M(ros_S), ros_E(ros_S) + KPP_REAL ros_A(ros_S*(ros_S-1)/2), ros_C(ros_S*(ros_S-1)/2) + KPP_REAL ros_Alpha(ros_S), ros_Gamma(ros_S), ros_ELO + LOGICAL ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL Autonomous, VectorTol + KPP_REAL Hstart, Hmin, Hmax + INTEGER Max_no_steps + KPP_REAL Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL Hexit +!~~~> Output: Error indicator + INTEGER IERR +! ~~~~ Local variables + KPP_REAL Ynew(KPP_NVAR), Fcn0(KPP_NVAR), Fcn(KPP_NVAR), + & K(KPP_NVAR*ros_S), dFdT(KPP_NVAR), + & Jac0(KPP_LU_NONZERO), Ghimj(KPP_LU_NONZERO) + KPP_REAL H, Hnew, HC, HG, Fac, Tau + KPP_REAL Err, Yerr(KPP_NVAR) + INTEGER Pivot(KPP_NVAR), Direction, ioffset, j, istage + LOGICAL RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL ZERO, ONE, DeltaMin + PARAMETER (ZERO = 0.0d0) + PARAMETER (ONE = 1.0d0) + PARAMETER (DeltaMin = 1.0d-5) +!~~~> Locally called functions + KPP_REAL WLAMCH, ros_ErrorNorm + EXTERNAL WLAMCH, ros_ErrorNorm +!~~~> Statistics on the work performed + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> INITIAL PREPARATIONS + T = Tstart + Hexit = 0.0d0 + H = MIN(Hstart,Hmax) + IF (ABS(H).LE.10.d0*Roundoff) THEN + H = DeltaMin + END IF + + IF (Tend .GE. Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + + DO WHILE ( (Direction.GT.0).AND.((T-Tend)+Roundoff.LE.ZERO) + & .OR. (Direction.LT.0).AND.((Tend-T)+Roundoff.LE.ZERO) ) + + IF ( Nstp.GT.Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H).EQ.T).OR.(H.LE.Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL ode_Fun(T,Y,Fcn0) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, + & Fcn0, ode_Fun, dFdT ) + END IF + +!~~~> Compute the Jacobian at current time + CALL ode_Jac(T,Y,Jac0) + +!~~~> Repeat step calculation until current step accepted + DO WHILE (.TRUE.) ! WHILE STEP NOT ACCEPTED + + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), + & Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages + DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+KPP_NVAR) + ioffset = KPP_NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage.EQ.1 ) THEN + CALL WCOPY(KPP_NVAR,Fcn0,1,Fcn,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(KPP_NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL WAXPY(KPP_NVAR,ros_A((istage-1)*(istage-2)/2+j), + & K(KPP_NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL ode_Fun(Tau,Ynew,Fcn) + END IF ! if istage.EQ.1 elseif ros_NewF(istage) + CALL WCOPY(KPP_NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL WAXPY(KPP_NVAR,HC,K(KPP_NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL WAXPY(KPP_NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL SolveTemplate(Ghimj, Pivot, K(ioffset+1)) + + END DO ! istage + + +!~~~> Compute the new solution + CALL WCOPY(KPP_NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL WAXPY(KPP_NVAR,ros_M(j),K(KPP_NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL WSCAL(KPP_NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL WAXPY(KPP_NVAR,ros_E(j),K(KPP_NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err.LE.ONE).OR.(H.LE.Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL WCOPY(KPP_NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + GOTO 101 ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew=H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc.GE.1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO ! LOOP: WHILE STEP NOT ACCEPTED + +101 CONTINUE + + END DO ! Time loop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + RETURN + END ! SUBROUTINE RosenbrockIntegrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, + & AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + +! Input arguments + KPP_REAL Y(KPP_NVAR), Ynew(KPP_NVAR), Yerr(KPP_NVAR) + KPP_REAL AbsTol(KPP_NVAR), RelTol(KPP_NVAR) + LOGICAL VectorTol +! Local variables + KPP_REAL Err, Scale, Ymax, ZERO + INTEGER i + PARAMETER (ZERO = 0.0d0) + + Err = ZERO + DO i=1,KPP_NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/KPP_NVAR) + + ros_ErrorNorm = Err + + RETURN + END ! FUNCTION ros_ErrorNorm + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, + & Fcn0, ode_Fun, dFdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + +!~~~> Input arguments + KPP_REAL T, Roundoff, Y(KPP_NVAR), Fcn0(KPP_NVAR) + EXTERNAL ode_Fun +!~~~> Output arguments + KPP_REAL dFdT(KPP_NVAR) +!~~~> Global variables + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng +!~~~> Local variables + KPP_REAL Delta, DeltaMin, ONE + PARAMETER ( DeltaMin = 1.0d-6 ) + PARAMETER ( ONE = 1.0d0 ) + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL ode_Fun(T+Delta,Y,dFdT) + CALL WAXPY(KPP_NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL WSCAL(KPP_NVAR,(ONE/Delta),dFdT,1) + + RETURN + END ! SUBROUTINE ros_FunTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, + & Jac0, Ghimj, Pivot, Singular ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + +!~~~> Input arguments + KPP_REAL gam, Jac0(KPP_LU_NONZERO) + INTEGER Direction +!~~~> Output arguments + KPP_REAL Ghimj(KPP_LU_NONZERO) + LOGICAL Singular + INTEGER Pivot(KPP_NVAR) +!~~~> Inout arguments + KPP_REAL H ! step size is decreased when LU fails +!~~~> Global variables + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng +!~~~> Local variables + INTEGER i, ising, Nconsecutive + KPP_REAL ghinv, ONE, HALF + PARAMETER ( ONE = 1.0d0 ) + PARAMETER ( HALF = 0.5d0 ) + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*ham) - Jac0 + CALL WCOPY(KPP_LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(KPP_LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,KPP_NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +!~~~> Compute LU decomposition + CALL DecompTemplate( Ghimj, Pivot, ising ) + IF (ising .EQ. 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive.LE.5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + RETURN + END ! SUBROUTINE ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) + KPP_REAL T, H + INTEGER IERR, Code + + IERR = Code + WRITE(6,*) + & 'Forced exit from Rosenbrock due to the following error:' + + IF (Code .EQ. -1) THEN + WRITE(6,*) '--> Improper value for maximal no of steps' + ELSEIF (Code .EQ. -2) THEN + WRITE(6,*) '--> Selected Rosenbrock method not implemented' + ELSEIF (Code .EQ. -3) THEN + WRITE(6,*) '--> Hmin/Hmax/Hstart must be positive' + ELSEIF (Code .EQ. -4) THEN + WRITE(6,*) '--> FacMin/FacMax/FacRej must be positive' + ELSEIF (Code .EQ. -5) THEN + WRITE(6,*) '--> Improper tolerance values' + ELSEIF (Code .EQ. -6) THEN + WRITE(6,*) '--> No of steps exceeds maximum bound' + ELSEIF (Code .EQ. -7) THEN + WRITE(6,*) '--> Step size too small: T + 10*H = T', + & ' or H < Roundoff' + ELSEIF (Code .EQ. -8) THEN + WRITE(6,*) '--> Matrix is repeatedly singular' + ELSE + WRITE(6,102) 'Unknown Error code: ',Code + END IF + + 102 FORMAT(' ',A,I4) + WRITE(6,103) T, H + + 103 FORMAT(' T=',E15.7,' and H=',E15.7) + + RETURN + END + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, + & ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER S + PARAMETER (S=2) + INTEGER ros_S + KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) + KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO + LOGICAL ros_NewF(S) + CHARACTER*12 ros_Name + DOUBLE PRECISION g + + g = 1.0d0 + 1.0d0/SQRT(2.0d0) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = 2 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.d0)/g + ros_C(1) = (-2.d0)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.d0)/(2.d0*g) + ros_M(2)= (1.d0)/(2.d0*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.d0/(2.d0*g) + ros_E(2) = 1.d0/(2.d0*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d0 + ros_Alpha(2) = 1.0d0 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + RETURN + END ! SUBROUTINE Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, + & ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER S + PARAMETER (S=3) + INTEGER ros_S + KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) + KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO + LOGICAL ros_NewF(S) + CHARACTER*12 ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = 3 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.d0 + ros_A(2)= 1.d0 + ros_A(3)= 0.d0 + + ros_C(1) = -0.10156171083877702091975600115545d+01 + ros_C(2) = 0.40759956452537699824805835358067d+01 + ros_C(3) = 0.92076794298330791242156818474003d+01 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1d+01 + ros_M(2) = 0.61697947043828245592553615689730d+01 + ros_M(3) = -0.42772256543218573326238373806514d+00 +! E_i = Coefficients for error estimator + ros_E(1) = 0.5d+00 + ros_E(2) = -0.29079558716805469821718236208017d+01 + ros_E(3) = 0.22354069897811569627360909276199d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0d+00 + ros_Alpha(2)= 0.43586652150845899941601945119356d+00 + ros_Alpha(3)= 0.43586652150845899941601945119356d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356d+00 + ros_Gamma(2)= 0.24291996454816804366592249683314d+00 + ros_Gamma(3)= 0.21851380027664058511513169485832d+01 + RETURN + END ! SUBROUTINE Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, + & ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + INTEGER S + PARAMETER (S=4) + INTEGER ros_S + KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) + KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO + LOGICAL ros_NewF(S) + CHARACTER*12 ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = 4 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000d+01 + ros_A(2) = 0.1867943637803922d+01 + ros_A(3) = 0.2344449711399156d+00 + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0D0 + + ros_C(1) =-0.7137615036412310d+01 + ros_C(2) = 0.2580708087951457d+01 + ros_C(3) = 0.6515950076447975d+00 + ros_C(4) =-0.2137148994382534d+01 + ros_C(5) =-0.3214669691237626d+00 + ros_C(6) =-0.6949742501781779d+00 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735d+01 + ros_M(2) = 0.2870493262186792d+00 + ros_M(3) = 0.4353179431840180d+00 + ros_M(4) = 0.1093502252409163d+01 +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155d+00 + ros_E(2) =-0.7276199124938920d-01 + ros_E(3) =-0.1082196201495311d+00 + ros_E(4) =-0.1093502252409163d+01 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.D0 + ros_Alpha(2) = 0.1145640000000000d+01 + ros_Alpha(3) = 0.6552168638155900d+00 + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000d+00 + ros_Gamma(2) =-0.1769193891319233d+01 + ros_Gamma(3) = 0.7592633437920482d+00 + ros_Gamma(4) =-0.1049021087100450d+00 + RETURN + END ! SUBROUTINE Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, + & ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + INTEGER S + PARAMETER (S=4) + INTEGER ros_S + KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) + KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO + LOGICAL ros_NewF(S) + CHARACTER*12 ros_Name + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = 4 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0d+00 + ros_A(2) = 2.0d+00 + ros_A(3) = 0.0d+00 + ros_A(4) = 2.0d+00 + ros_A(5) = 0.0d+00 + ros_A(6) = 1.0d+00 + + ros_C(1) = 4.0d+00 + ros_C(2) = 1.0d+00 + ros_C(3) =-1.0d+00 + ros_C(4) = 1.0d+00 + ros_C(5) =-1.0d+00 + ros_C(6) =-(8.0d+00/3.0d+00) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0d+00 + ros_M(2) = 0.0d+00 + ros_M(3) = 1.0d+00 + ros_M(4) = 1.0d+00 +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 1.0d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d+00 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d+00 + ros_Alpha(2) = 0.0d+00 + ros_Alpha(3) = 1.0d+00 + ros_Alpha(4) = 1.0d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5d+00 + ros_Gamma(2) = 1.5d+00 + ros_Gamma(3) = 0.0d+00 + ros_Gamma(4) = 0.0d+00 + RETURN + END ! SUBROUTINE Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha, + & ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + INTEGER S + PARAMETER (S=6) + INTEGER ros_S + KPP_REAL ros_M(S), ros_E(S), ros_A(S*(S-1)/2), ros_C(S*(S-1)/2) + KPP_REAL ros_Alpha(S), ros_Gamma(S), ros_ELO + LOGICAL ros_NewF(S) + CHARACTER*12 ros_Name + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000d0 + ros_Alpha(2) = 0.386d0 + ros_Alpha(3) = 0.210d0 + ros_Alpha(4) = 0.630d0 + ros_Alpha(5) = 1.000d0 + ros_Alpha(6) = 1.000d0 + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000d+00 + ros_Gamma(2) =-0.1043000000000000d+00 + ros_Gamma(3) = 0.1035000000000000d+00 + ros_Gamma(4) =-0.3620000000000023d-01 + ros_Gamma(5) = 0.0d0 + ros_Gamma(6) = 0.0d0 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000d+01 + ros_A(2) = 0.9466785280815826d+00 + ros_A(3) = 0.2557011698983284d+00 + ros_A(4) = 0.3314825187068521d+01 + ros_A(5) = 0.2896124015972201d+01 + ros_A(6) = 0.9986419139977817d+00 + ros_A(7) = 0.1221224509226641d+01 + ros_A(8) = 0.6019134481288629d+01 + ros_A(9) = 0.1253708332932087d+02 + ros_A(10) =-0.6878860361058950d+00 + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0d+00 + + ros_C(1) =-0.5668800000000000d+01 + ros_C(2) =-0.2430093356833875d+01 + ros_C(3) =-0.2063599157091915d+00 + ros_C(4) =-0.1073529058151375d+00 + ros_C(5) =-0.9594562251023355d+01 + ros_C(6) =-0.2047028614809616d+02 + ros_C(7) = 0.7496443313967647d+01 + ros_C(8) =-0.1024680431464352d+02 + ros_C(9) =-0.3399990352819905d+02 + ros_C(10) = 0.1170890893206160d+02 + ros_C(11) = 0.8083246795921522d+01 + ros_C(12) =-0.7981132988064893d+01 + ros_C(13) =-0.3152159432874371d+02 + ros_C(14) = 0.1631930543123136d+02 + ros_C(15) =-0.6058818238834054d+01 + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0d+00 + ros_M(6) = 1.0d+00 + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 0.0d+00 + ros_E(5) = 0.0d+00 + ros_E(6) = 1.0d+00 + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 + + RETURN + END ! SUBROUTINE Rodas4 + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE DecompTemplate( A, Pivot, ising ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' +!~~~> Inout variables + KPP_REAL A(KPP_LU_NONZERO) +!~~~> Output variables + INTEGER Pivot(KPP_NVAR), ising +!~~~> Collect statistics + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng + + CALL KppDecomp ( A, ising ) +!~~~> Note: for a full matrix use Lapack: +! CALL DGETRF( KPP_NVAR, KPP_NVAR, A, KPP_NVAR, Pivot, ising ) + + Ndec = Ndec + 1 + + END ! SUBROUTINE DecompTemplate + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE SolveTemplate( A, Pivot, b ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' +!~~~> Input variables + KPP_REAL A(KPP_LU_NONZERO) + INTEGER Pivot(KPP_NVAR) +!~~~> InOut variables + KPP_REAL b(KPP_NVAR) +!~~~> Collect statistics + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng + + CALL KppSolve( A, b ) +!~~~> Note: for a full matrix use Lapack: +! NRHS = 1 +! CALL DGETRS( 'N', KPP_NVAR , NRHS, A, KPP_NVAR, Pivot, b, KPP_NVAR, INFO ) + + Nsol = Nsol+1 + + END ! SUBROUTINE SolveTemplate + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE FunTemplate( T, Y, Ydot ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' +!~~~> Input variables + KPP_REAL T, Y(KPP_NVAR) +!~~~> Output variables + KPP_REAL Ydot(KPP_NVAR) +!~~~> Local variables + KPP_REAL Told +!~~~> Collect statistics + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, Ydot ) + TIME = Told + + Nfun = Nfun+1 + + RETURN + END ! SUBROUTINE FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE JacTemplate( T, Y, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' +!~~~> Input variables + KPP_REAL T, Y(KPP_NVAR) +!~~~> Output variables + KPP_REAL Jcb(KPP_LU_NONZERO) +!~~~> Local variables + KPP_REAL Told +!~~~> Collect statistics + INTEGER Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + COMMON /Statistics/ Nfun,Njac,Nstp,Nacc,Nrej, + & Ndec,Nsol,Nsng + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, Jcb ) + TIME = Told + + Njac = Njac+1 + + RETURN + END ! SUBROUTINE JacTemplate + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f90 new file mode 100755 index 00000000..6946f938 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock.f90 @@ -0,0 +1,1285 @@ +MODULE KPP_ROOT_Integrator + + IMPLICIT NONE + PUBLIC + SAVE +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, itexit=1, ihexit=2 + + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(-8:1) :: IERR_NAMES = (/ & + 'Matrix is repeatedly singular ', & ! -8 + 'Step size too small ', & ! -7 + 'No of steps exceeds maximum bound ', & ! -6 + 'Improper tolerance values ', & ! -5 + 'FacMin/FacMax/FacRej must be positive ', & ! -4 + 'Hmin/Hmax/Hstart must be positive ', & ! -3 + 'Selected Rosenbrock method not implemented ', & ! -2 + 'Improper value for maximal no of steps ', & ! -1 + ' ', & ! 0 (not used) + 'Success ' /) ! 1 + +CONTAINS + +SUBROUTINE INTEGRATE( TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + IMPLICIT NONE + + KPP_REAL, INTENT(IN) :: TIN ! Start Time + KPP_REAL, INTENT(IN) :: TOUT ! End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + INTEGER :: N_stp, N_acc, N_rej, N_sng + SAVE N_stp, N_acc, N_rej, N_sng + INTEGER :: i, IERR + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + ICNTRL(:) = 0 + RCNTRL(:) = 0.0_dp + ISTATUS(:) = 0 + RSTATUS(:) = 0.0_dp + + ! If optional parameters are given, and if they are >0, + ! then they overwrite default settings. + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) > 0) ICNTRL(:) = ICNTRL_U(:) + END IF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) > 0) RCNTRL(:) = RCNTRL_U(:) + END IF + + CALL Rosenbrock(VAR,TIN,TOUT, & + ATOL,RTOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output they to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(:) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(:) + IF (PRESENT(IERR_U)) IERR_U = IERR + +END SUBROUTINE INTEGRATE + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE Rosenbrock(Y,Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dFun/dY +!- ICNTRL(1:20) = integer inputs parameters +!- RCNTRL(1:20) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- ISTATUS(1:20) -> integer output parameters +!- RSTATUS(1:20) -> real output parameters +!- IERR -> job status upon return +! success (positive value) or +! failure (negative value) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! +! ICNTRL(3) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(4) -> maximum number of integration steps +! For ICNTRL(4)=0) the default value of 100000 is used +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMax, upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the current no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:20) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_LinearAlgebra + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + KPP_REAL, INTENT(IN) :: Tstart,Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(20) + KPP_REAL, INTENT(IN) :: RCNTRL(20) + INTEGER, INTENT(INOUT) :: ISTATUS(20) + KPP_REAL, INTENT(INOUT) :: RSTATUS(20) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(ICNTRL(1) == 0) + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> The particular Rosenbrock method chosen + IF (ICNTRL(3) == 0) THEN + Method = 4 + ELSEIF ( (ICNTRL(3) >= 1).AND.(ICNTRL(3) <= 5) ) THEN + Method = ICNTRL(3) + ELSE + PRINT * , 'User-selected Rosenbrock method: ICNTRL(3)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The maximum number of steps admitted + IF (ICNTRL(4) == 0) THEN + Max_no_steps = 100000 + ELSEIF (ICNTRL(4) > 0) THEN + Max_no_steps=ICNTRL(4) + ELSE + PRINT * ,'User-selected max no. of steps: ICNTRL(4)=',ICNTRL(4) + CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2_dp + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0_dp + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1_dp + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9_dp + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.0_dp*Roundoff) & + .OR. (RelTol(i) >= 1.0_dp) ) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Initialize the particular Rosenbrock method + SELECT CASE (Method) + CASE (1) + CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (2) + CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (3) + CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (4) + CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (5) + CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + +!~~~> CALL Rosenbrock method + CALL ros_Integrator(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR) + + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS ! SUBROUTINES internal to Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from Rosenbrock due to the following error:' + IF ((Code>=-8).AND.(Code<=-1)) THEN + PRINT *, IERR_NAMES(Code) + ELSE + PRINT *, 'Unknown Error code: ', Code + ENDIF + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE ros_ErrorMsg + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Integrator (Y, Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The Rosenbrock method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) +#ifdef FULL_ALGEBRA + KPP_REAL :: Jac0(NVAR,NVAR), Ghimj(NVAR,NVAR) +#else + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) +#endif + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0_dp, ONE = 1.0_dp + KPP_REAL, PARAMETER :: DeltaMin = 1.0E-5_dp +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1_dp*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL FunTemplate(T,Y,Fcn0) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) + END IF + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T,Y,Jac0) + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL WCOPY(NVAR,Fcn0,1,Fcn,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL FunTemplate(Tau,Ynew,Fcn) + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL ros_Solve(Ghimj, Pivot, K(ioffset+1)) + + END DO Stage + + +!~~~> Compute the new solution + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE ros_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0_dp + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + ros_ErrorNorm = Err + + END FUNCTION ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0_dp, DeltaMin = 1.0E-6_dp + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL FunTemplate(T+Delta,Y,dFdT) + CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE ros_FunTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(IN) :: Jac0(NVAR,NVAR) +#else + KPP_REAL, INTENT(IN) :: Jac0(LU_NONZERO) +#endif + KPP_REAL, INTENT(IN) :: gam + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments +#ifdef FULL_ALGEBRA + KPP_REAL, INTENT(OUT) :: Ghimj(NVAR,NVAR) +#else + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) +#endif + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0_dp, HALF = 0.5_dp + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*gam) - Jac0 +#ifdef FULL_ALGEBRA + CALL WCOPY(NVAR*NVAR,Jac0,1,Ghimj,1) + CALL WSCAL(NVAR*NVAR,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(i,i) = Ghimj(i,i)+ghinv + END DO +#else + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +#endif +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, ising ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Decomp( A, Pivot, ising ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + +#ifdef FULL_ALGEBRA + CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) +#else + CALL KppDecomp ( A, ising ) + Pivot(1) = 1 +#endif + Ndec = Ndec + 1 + + END SUBROUTINE ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Solve( A, Pivot, b ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + +#ifdef FULL_ALGEBRA + CALL DGETRS( 'N', NVAR , 1, A, NVAR, Pivot, b, NVAR, 0 ) +#else + CALL KppSolve( A, b ) +#endif + + Nsol = Nsol+1 + + END SUBROUTINE ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + + g = 1.0_dp + 1.0_dp/SQRT(2.0_dp) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.0_dp)/g + ros_C(1) = (-2.0_dp)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.0_dp)/(2.0_dp*g) + ros_M(2)= (1.0_dp)/(2.0_dp*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.0_dp/(2.0_dp*g) + ros_E(2) = 1.0_dp/(2.0_dp*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 1.0_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.0_dp + ros_A(2)= 1.0_dp + ros_A(3)= 0.0_dp + + ros_C(1) = -0.10156171083877702091975600115545E+01_dp + ros_C(2) = 0.40759956452537699824805835358067E+01_dp + ros_C(3) = 0.92076794298330791242156818474003E+01_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1E+01_dp + ros_M(2) = 0.61697947043828245592553615689730E+01_dp + ros_M(3) = -0.42772256543218573326238373806514E+00_dp +! E_i = Coefficients for error estimator + ros_E(1) = 0.5E+00_dp + ros_E(2) = -0.29079558716805469821718236208017E+01_dp + ros_E(3) = 0.22354069897811569627360909276199E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0E+00_dp + ros_Alpha(2)= 0.43586652150845899941601945119356E+00_dp + ros_Alpha(3)= 0.43586652150845899941601945119356E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356E+00_dp + ros_Gamma(2)= 0.24291996454816804366592249683314E+00_dp + ros_Gamma(3)= 0.21851380027664058511513169485832E+01_dp + + END SUBROUTINE Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(4), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(6), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(4), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000E+01_dp + ros_A(2) = 0.1867943637803922E+01_dp + ros_A(3) = 0.2344449711399156E+00_dp + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0_dp + + ros_C(1) =-0.7137615036412310E+01_dp + ros_C(2) = 0.2580708087951457E+01_dp + ros_C(3) = 0.6515950076447975E+00_dp + ros_C(4) =-0.2137148994382534E+01_dp + ros_C(5) =-0.3214669691237626E+00_dp + ros_C(6) =-0.6949742501781779E+00_dp +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735E+01_dp + ros_M(2) = 0.2870493262186792E+00_dp + ros_M(3) = 0.4353179431840180E+00_dp + ros_M(4) = 0.1093502252409163E+01_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155E+00_dp + ros_E(2) =-0.7276199124938920E-01_dp + ros_E(3) =-0.1082196201495311E+00_dp + ros_E(4) =-0.1093502252409163E+01_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0_dp + ros_Alpha(2) = 0.1145640000000000E+01_dp + ros_Alpha(3) = 0.6552168638155900E+00_dp + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000E+00_dp + ros_Gamma(2) =-0.1769193891319233E+01_dp + ros_Gamma(3) = 0.7592633437920482E+00_dp + ros_Gamma(4) =-0.1049021087100450E+00_dp + + END SUBROUTINE Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0E+00_dp + ros_A(2) = 2.0E+00_dp + ros_A(3) = 0.0E+00_dp + ros_A(4) = 2.0E+00_dp + ros_A(5) = 0.0E+00_dp + ros_A(6) = 1.0E+00_dp + + ros_C(1) = 4.0E+00_dp + ros_C(2) = 1.0E+00_dp + ros_C(3) =-1.0E+00_dp + ros_C(4) = 1.0E+00_dp + ros_C(5) =-1.0E+00_dp + ros_C(6) =-(8.0E+00_dp/3.0E+00_dp) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0E+00_dp + ros_M(2) = 0.0E+00_dp + ros_M(3) = 1.0E+00_dp + ros_M(4) = 1.0E+00_dp +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 1.0E+00_dp +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0E+00_dp +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0E+00_dp + ros_Alpha(2) = 0.0E+00_dp + ros_Alpha(3) = 1.0E+00_dp + ros_Alpha(4) = 1.0E+00_dp +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5E+00_dp + ros_Gamma(2) = 1.5E+00_dp + ros_Gamma(3) = 0.0E+00_dp + ros_Gamma(4) = 0.0E+00_dp + + END SUBROUTINE Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = 6 + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000_dp + ros_Alpha(2) = 0.386_dp + ros_Alpha(3) = 0.210_dp + ros_Alpha(4) = 0.630_dp + ros_Alpha(5) = 1.000_dp + ros_Alpha(6) = 1.000_dp + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000E+00_dp + ros_Gamma(2) =-0.1043000000000000E+00_dp + ros_Gamma(3) = 0.1035000000000000E+00_dp + ros_Gamma(4) =-0.3620000000000023E-01_dp + ros_Gamma(5) = 0.0_dp + ros_Gamma(6) = 0.0_dp + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000E+01_dp + ros_A(2) = 0.9466785280815826E+00_dp + ros_A(3) = 0.2557011698983284E+00_dp + ros_A(4) = 0.3314825187068521E+01_dp + ros_A(5) = 0.2896124015972201E+01_dp + ros_A(6) = 0.9986419139977817E+00_dp + ros_A(7) = 0.1221224509226641E+01_dp + ros_A(8) = 0.6019134481288629E+01_dp + ros_A(9) = 0.1253708332932087E+02_dp + ros_A(10) =-0.6878860361058950E+00_dp + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0E+00_dp + + ros_C(1) =-0.5668800000000000E+01_dp + ros_C(2) =-0.2430093356833875E+01_dp + ros_C(3) =-0.2063599157091915E+00_dp + ros_C(4) =-0.1073529058151375E+00_dp + ros_C(5) =-0.9594562251023355E+01_dp + ros_C(6) =-0.2047028614809616E+02_dp + ros_C(7) = 0.7496443313967647E+01_dp + ros_C(8) =-0.1024680431464352E+02_dp + ros_C(9) =-0.3399990352819905E+02_dp + ros_C(10) = 0.1170890893206160E+02_dp + ros_C(11) = 0.8083246795921522E+01_dp + ros_C(12) =-0.7981132988064893E+01_dp + ros_C(13) =-0.3152159432874371E+02_dp + ros_C(14) = 0.1631930543123136E+02_dp + ros_C(15) =-0.6058818238834054E+01_dp + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0E+00_dp + ros_M(6) = 1.0E+00_dp + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0E+00_dp + ros_E(2) = 0.0E+00_dp + ros_E(3) = 0.0E+00_dp + ros_E(4) = 0.0E+00_dp + ros_E(5) = 0.0E+00_dp + ros_E(6) = 1.0E+00_dp + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0_dp + + END SUBROUTINE Rodas4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of the set of internal Rosenbrock subroutines +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END SUBROUTINE Rosenbrock +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE FunTemplate( T, Y, Ydot ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Function + USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) +!~~~> Output variables + KPP_REAL :: Ydot(NVAR) +!~~~> Local variables + KPP_REAL :: Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, Ydot ) + TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE JacTemplate( T, Y, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Jacobian + USE KPP_ROOT_LinearAlgebra + USE KPP_ROOT_Rates +!~~~> Input variables + KPP_REAL :: T, Y(NVAR) +!~~~> Output variables +#ifdef FULL_ALGEBRA + KPP_REAL :: JV(LU_NONZERO), Jcb(NVAR,NVAR) +#else + KPP_REAL :: Jcb(LU_NONZERO) +#endif +!~~~> Local variables + KPP_REAL :: Told +#ifdef FULL_ALGEBRA + INTEGER :: i, j +#endif + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() +#ifdef FULL_ALGEBRA + CALL Jac_SP(Y, FIX, RCONST, JV) + DO j=1,NVAR + DO i=1,NVAR + Jcb(i,j) = 0.0d0 + END DO + END DO + DO i=1,LU_NONZERO + Jcb(LU_IROW(i),LU_ICOL(i)) = JV(i) + END DO +#else + CALL Jac_SP( Y, FIX, RCONST, Jcb ) +#endif + TIME = Told + + Njac = Njac+1 + +END SUBROUTINE JacTemplate + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.def new file mode 100755 index 00000000..c42d76ee --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE rosenbrock_adj + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.f90 new file mode 100755 index 00000000..fe9567fe --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_adj.f90 @@ -0,0 +1,2557 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_LinearAlgebra + USE KPP_ROOT_Rates + USE KPP_ROOT_Function + USE KPP_ROOT_Jacobian + USE KPP_ROOT_Hessian + USE KPP_ROOT_Util + + IMPLICIT NONE + PUBLIC + SAVE +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + INTEGER, PARAMETER :: ifun=11, ijac=12, istp=13, iacc=14, & + irej=15, idec=16, isol=17, isng=18, & + itexit=11,ihexit=12 +!~~~> Types of Adjoints Implemented + INTEGER, PARAMETER :: Adj_none = 1, Adj_discrete = 2, & + Adj_continuous = 3, Adj_simple_continuous = 4 + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 +!~~~> Checkpoints in memory + INTEGER, PARAMETER :: bufsize = 1500 + INTEGER :: stack_ptr = 0 ! last written entry + KPP_REAL, DIMENSION(:), POINTER :: buf_H, buf_T + KPP_REAL, DIMENSION(:,:), POINTER :: buf_Y, buf_K, buf_J + KPP_REAL, DIMENSION(:,:), POINTER :: buf_dY, buf_d2Y + +CONTAINS ! Functions in the module KPP_ROOT_Integrator + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE INTEGRATE_ADJ( NADJ, Y, Lambda, TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Y - Concentrations + KPP_REAL :: Y(NVAR) +!~~~> NADJ - No. of cost functionals for which adjoints +! are evaluated simultaneously +! If single cost functional is considered (like in +! most applications) simply set NADJ = 1 + INTEGER NADJ +!~~~> Lambda - Sensitivities of concentrations +! Note: Lambda (1:NVAR,j) contains sensitivities of +! the j-th cost functional w.r.t. Y(1:NVAR), j=1...NADJ + KPP_REAL :: Lambda(NVAR,NADJ) + KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time + KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time +!~~~> Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + + INTEGER, SAVE :: N_stp, N_acc, N_rej, N_sng, IERR + INTEGER :: i + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + + ICNTRL(1:20) = 0 + RCNTRL(1:20) = 0.0_dp + ISTATUS(1:20) = 0 + RSTATUS(1:20) = 0.0_dp + + + ICNTRL(1) = 0 ! 0 = non-autonomous, 1 = autonomous + ICNTRL(2) = 1 ! 0 = scalar, 1 = vector tolerances + RCNTRL(3) = STEPMIN ! starting step + ICNTRL(4) = 5 ! choice of the method for forward integration + ICNTRL(5) = 2 ! 1=none, 2=discrete, 3=full continuous, 4=simplified continuous adjoint + ICNTRL(6) = 1 ! choice of the method for continuous adjoint + +! Tighter tolerances, especially atol, are needed for the full continuous adjoint +! (Atol on sensitivities is different than on concentrations) +! CADJ_ATOL(1:NVAR) = 1.0d-5 +! CADJ_RTOL(1:NVAR) = 1.0d-4 + + ! if optional parameters are given, and if they are >=0, then they overwrite default settings + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) >= 0) ICNTRL(1:20) = ICNTRL_U(:) + ENDIF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) >= 0) RCNTRL(1:20) = RCNTRL_U(:) + ENDIF + + + CALL RosenbrockADJ(Y, NADJ, Lambda, & + TIN,TOUT, & + ATOL,RTOL, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + +! N_stp = N_stp + ICNTRL(istp) +! N_acc = N_acc + ICNTRL(iacc) +! N_rej = N_rej + ICNTRL(irej) +! N_sng = N_sng + ICNTRL(isng) +! PRINT*,'Step=',N_stp,' Acc=',N_acc,' Rej=',N_rej, & +! ' Singular=',N_sng + + IF (IERR < 0) THEN + print *,'RosenbrockADJ: Unsucessful step at T=', & + TIN,' (IERR=',IERR,')' + ENDIF + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output + ! copy to them to return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) + +END SUBROUTINE INTEGRATE_ADJ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_AllocateDBuffers( S ) +!~~~> Allocate buffer space for discrete adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i, S + + ALLOCATE( buf_H(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer H'; STOP + END IF + ALLOCATE( buf_T(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer T'; STOP + END IF + ALLOCATE( buf_Y(NVAR*S,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer Y'; STOP + END IF + ALLOCATE( buf_K(NVAR*S,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer K'; STOP + END IF + ALLOCATE( buf_J(LU_NONZERO,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer J'; STOP + END IF + + END SUBROUTINE ros_AllocateDBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FreeDBuffers +!~~~> Dallocate buffer space for discrete adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i, S + + DEALLOCATE( buf_H, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer H'; STOP + END IF + DEALLOCATE( buf_T, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer T'; STOP + END IF + DEALLOCATE( buf_Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer Y'; STOP + END IF + DEALLOCATE( buf_K, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer K'; STOP + END IF + DEALLOCATE( buf_J, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer J'; STOP + END IF + + END SUBROUTINE ros_FreeDBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_AllocateCBuffers +!~~~> Allocate buffer space for continuous adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i, S + + ALLOCATE( buf_H(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer H'; STOP + END IF + ALLOCATE( buf_T(bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer T'; STOP + END IF + ALLOCATE( buf_Y(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer Y'; STOP + END IF + ALLOCATE( buf_dY(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer dY'; STOP + END IF + ALLOCATE( buf_d2Y(NVAR,bufsize), STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed allocation of buffer d2Y'; STOP + END IF + + END SUBROUTINE ros_AllocateCBuffers + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FreeCBuffers +!~~~> Dallocate buffer space for continuous adjoint +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: i, S + + DEALLOCATE( buf_H, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer H'; STOP + END IF + DEALLOCATE( buf_T, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer T'; STOP + END IF + DEALLOCATE( buf_Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer Y'; STOP + END IF + DEALLOCATE( buf_dY, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer dY'; STOP + END IF + DEALLOCATE( buf_d2Y, STAT=i ) + IF (i/=0) THEN + PRINT*,'Failed deallocation of buffer d2Y'; STOP + END IF + + END SUBROUTINE ros_FreeCBuffers + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DPush( S, T, H, Ystage, K )!, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Saves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INTEGER :: S ! no of stages + KPP_REAL :: T, H, Ystage(NVAR*S), K(NVAR*S) !, Jcb(LU_NONZERO) + + stack_ptr = stack_ptr + 1 + IF ( stack_ptr > bufsize ) THEN + PRINT*,'Push failed: buffer overflow' + STOP + END IF + buf_H( stack_ptr ) = H + buf_T( stack_ptr ) = T + CALL WCOPY(NVAR*S,Ystage,1,buf_Y(1,stack_ptr),1) + CALL WCOPY(NVAR*S,K,1,buf_K(1,stack_ptr),1) + !CALL WCOPY(LU_NONZERO,Jcb,1,buf_J(1,stack_ptr),1) + + END SUBROUTINE ros_DPush + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DPop( S, T, H, Ystage, K ) !, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Retrieves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER :: S ! no of stages + KPP_REAL :: T, H, Ystage(NVAR*S), K(NVAR*S) ! , Jcb(LU_NONZERO) + + IF ( stack_ptr <= 0 ) THEN + PRINT*,'Pop failed: empty buffer' + STOP + END IF + H = buf_H( stack_ptr ) + T = buf_T( stack_ptr ) + CALL WCOPY(NVAR*S,buf_Y(1,stack_ptr),1,Ystage,1) + CALL WCOPY(NVAR*S,buf_K(1,stack_ptr),1,K,1) + !CALL WCOPY(LU_NONZERO,buf_J(1,stack_ptr),1,Jcb,1) + + stack_ptr = stack_ptr - 1 + + END SUBROUTINE ros_DPop + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CPush( T, H, Y, dY, d2Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Saves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER :: S ! no of stages + KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) + + stack_ptr = stack_ptr + 1 + IF ( stack_ptr > bufsize ) THEN + PRINT*,'Push failed: buffer overflow' + STOP + END IF + buf_H( stack_ptr ) = H + buf_T( stack_ptr ) = T + CALL WCOPY(NVAR,Y,1,buf_Y(1,stack_ptr),1) + CALL WCOPY(NVAR,dY,1,buf_dY(1,stack_ptr),1) + CALL WCOPY(NVAR,d2Y,1,buf_d2Y(1,stack_ptr),1) + + END SUBROUTINE ros_CPush + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CPop( T, H, Y, dY, d2Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Retrieves the next trajectory snapshot for discrete adjoints +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER :: S ! no of stages + KPP_REAL :: T, H, Y(NVAR), dY(NVAR), d2Y(NVAR) + + IF ( stack_ptr <= 0 ) THEN + PRINT*,'Pop failed: empty buffer' + STOP + END IF + H = buf_H( stack_ptr ) + T = buf_T( stack_ptr ) + CALL WCOPY(NVAR,buf_Y(1,stack_ptr),1,Y,1) + CALL WCOPY(NVAR,buf_dY(1,stack_ptr),1,dY,1) + CALL WCOPY(NVAR,buf_d2Y(1,stack_ptr),1,d2Y,1) + + stack_ptr = stack_ptr - 1 + + END SUBROUTINE ros_CPop + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE RosenbrockADJ( Y, NADJ, Lambda, & + Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! ADJ = Adjoint of the Tangent Linear Model of a RosenbrockADJ Method +! +! Solves the system y'=F(t,y) using a RosenbrockADJ method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on RosenbrockADJ methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) = vector of initial conditions (at T=Tstart) +! NADJ -> dimension of linearized system, +! i.e. the number of sensitivity coefficients +!- Lambda(NVAR,NADJ) -> vector of initial sensitivity conditions (at T=Tstart) +!- [Tstart,Tend] = time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol = user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) = ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) = Jacobian of the ODE function, +! returns Jcb = dF/dY +!- ICNTRL(1:10) = integer inputs parameters +!- RCNTRL(1:10) = real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- Lambda(NVAR,NADJ) -> vector of final sensitivities (at T=Tend) +!- ICNTRL(11:20) -> integer output parameters +!- RCNTRL(11:20) -> real output parameters +!- IERR -> job status upon return +! - succes (positive value) or failure (negative value) - +! = 1 : Success +! = -1 : Improper value for maximal no of steps +! = -2 : Selected RosenbrockADJ method not implemented +! = -3 : Hmin/Hmax/Hstart must be positive +! = -4 : FacMin/FacMax/FacRej must be positive +! = -5 : Improper tolerance values +! = -6 : No of steps exceeds maximum bound +! = -7 : Step size too small +! = -8 : Matrix is repeatedly singular +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! ICNTRL(3) -> maximum number of integration steps +! For ICNTRL(3)=0) the default value of 100000 is used +! +! ICNTRL(4) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! ICNTRL(5) -> Type of adjoint algorithm +! = 0 : default is discrete adjoint ( of method ICNTRL(4) ) +! = 1 : no adjoint +! = 2 : discrete adjoint ( of method ICNTRL(4) ) +! = 3 : fully adaptive continuous adjoint ( with method ICNTRL(6) ) +! = 4 : simplified continuous adjoint ( with method ICNTRL(6) ) +! +! ICNTRL(6) -> selection of a particular Rosenbrock method for the +! continuous adjoint integration - for cts adjoint it +! can be different than the forward method ICNTRL(4) +! Note 1: to avoid interpolation errors (which can be huge!) +! it is recommended to use only ICNTRL(6) = 1 or 4 +! Note 2: the performance of the full continuous adjoint +! strongly depends on the forward solution accuracy Abs/RelTol +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMin,upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to RosenbrockADJ adds the corrent no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + INTEGER, INTENT(IN) :: NADJ + KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) + KPP_REAL, INTENT(IN) :: Tstart,Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(10) + KPP_REAL, INTENT(IN) :: RCNTRL(10) + INTEGER, INTENT(INOUT) :: ISTATUS(10) + KPP_REAL, INTENT(INOUT) :: RSTATUS(10) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + INTEGER :: AdjointType, CadjMethod + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(ICNTRL(1) == 0) + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> The maximum number of steps admitted + IF (ICNTRL(3) == 0) THEN + Max_no_steps = bufsize - 1 + ELSEIF (Max_no_steps > 0) THEN + Max_no_steps=ICNTRL(3) + ELSE + PRINT * ,'User-selected max no. of steps: ICNTRL(3)=',ICNTRL(3) + CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The particular Rosenbrock method chosen + IF (ICNTRL(4) == 0) THEN + Method = 5 + ELSEIF ( (ICNTRL(4) >= 1).AND.(ICNTRL(4) <= 5) ) THEN + Method = ICNTRL(4) + ELSE + PRINT * , 'User-selected Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Discrete or continuous adjoint formulation + IF ( ICNTRL(5) == 0 ) THEN + AdjointType = Adj_discrete + ELSEIF ( (ICNTRL(5) >= 1).AND.(ICNTRL(5) <= 4) ) THEN + AdjointType = ICNTRL(5) + ELSE + PRINT * , 'User-selected adjoint type: ICNTRL(5)=', AdjointType + CALL ros_ErrorMsg(-9,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The particular Rosenbrock method chosen for integrating the cts adjoint + IF (ICNTRL(6) == 0) THEN + CadjMethod = 4 + ELSEIF ( (ICNTRL(6) >= 1).AND.(ICNTRL(6) <= 5) ) THEN + CadjMethod = ICNTRL(4) + ELSE + PRINT * , 'User-selected CADJ Rosenbrock method: ICNTRL(6)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2d0 + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0d0 + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1d0 + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9d0 + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & + .OR. (RelTol(i) >= 1.0d0) ) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Initialize the particular RosenbrockADJ method + SELECT CASE (Method) + CASE (1) + CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (2) + CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (3) + CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (4) + CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (5) + CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + +!~~~> Allocate checkpoint space or open checkpoint files + IF (AdjointType == Adj_discrete) THEN + CALL ros_AllocateDBuffers( ros_S ) + ELSEIF ( (AdjointType == Adj_continuous).OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL ros_AllocateCBuffers + END IF + +!~~~> CALL Forward Rosenbrock method + CALL ros_FwdInt(Y,Tstart,Tend,Texit, & + AbsTol, RelTol, & +! RosenbrockADJ method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, AdjointType, & + Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR) + + PRINT*,'FORWARD STATISTICS' + PRINT*,'Step=',Nstp,' Acc=',Nacc, & + ' Rej=',Nrej, ' Singular=',Nsng + Nstp = 0 + Nacc = 0 + Nrej = 0 + Nsng = 0 + +!~~~> If Forward integration failed return + IF (IERR<0) RETURN + +!~~~> Initialize the particular Rosenbrock method for continuous adjoint + IF ( (AdjointType == Adj_continuous).OR. & + (AdjointType == Adj_simple_continuous) ) THEN + SELECT CASE (CadjMethod) + CASE (1) + CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (2) + CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (3) + CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (4) + CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (5) + CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + END IF + + SELECT CASE (AdjointType) + CASE (Adj_discrete) + CALL ros_DadjInt ( & + NADJ, Lambda, & + Tstart, Tend, Texit, & + AbsTol, RelTol, & + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, & + FacMin, FacMax, FacRej, FacSafe, & + IERR ) + CASE (Adj_continuous) + CALL ros_CadjInt ( & + NADJ, Lambda, & + Tend, Tstart, Texit, & + AbsTol, RelTol, & + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & + Autonomous, VectorTol, AdjointType, & + 100000, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & + IERR ) + CASE (Adj_simple_continuous) + CALL ros_SimpleCadjInt ( & + NADJ, Lambda, & + Tstart, Tend, Texit, & + AbsTol, RelTol, & + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & + Autonomous, VectorTol, AdjointType, & + Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, & + FacMin, FacMax, FacRej, FacSafe, & + IERR ) + END SELECT ! AdjointType + + PRINT*,'ADJOINT STATISTICS' + PRINT*,'Step=',Nstp,' Acc=',Nacc, & + ' Rej=',Nrej, ' Singular=',Nsng + +!~~~> Free checkpoint space or close checkpoint files + IF (AdjointType == Adj_discrete) THEN + CALL ros_FreeDBuffers + ELSEIF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL ros_FreeCBuffers + END IF + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + + + END SUBROUTINE RosenbrockADJ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from RosenbrockADJ due to the following error:' + + SELECT CASE (Code) + CASE (-1) + PRINT * , '--> Improper value for maximal no of steps' + CASE (-2) + PRINT * , '--> Selected RosenbrockADJ method not implemented' + CASE (-3) + PRINT * , '--> Hmin/Hmax/Hstart must be positive' + CASE (-4) + PRINT * , '--> FacMin/FacMax/FacRej must be positive' + CASE (-5) + PRINT * , '--> Improper tolerance values' + CASE (-6) + PRINT * , '--> No of steps exceeds maximum buffer bound' + CASE (-7) + PRINT * , '--> Step size too small: T + 10*H = T', & + ' or H < Roundoff' + CASE (-8) + PRINT * , '--> Matrix is repeatedly singular' + CASE (-9) + PRINT * , '--> Improper type of adjoint selected' + CASE DEFAULT + PRINT *, 'Unknown Error code: ', Code + END SELECT + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE ros_ErrorMsg + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FwdInt (Y, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> RosenbrockADJ method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, AdjointType, & + Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The RosenbrockADJ method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + INTEGER, INTENT(IN) :: AdjointType + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S), dFdT(NVAR) + KPP_REAL, DIMENSION(:), POINTER :: Ystage + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Allocate stage vector buffer if needed + IF (AdjointType == Adj_discrete) THEN ! Save stage solution + ALLOCATE(Ystage(NVAR*ros_S), STAT=i) + IF (i/=0) THEN + PRINT*,'Allocation of Ystage failed' + STOP + END IF + END IF + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL FunTemplate(T,Y,Fcn0) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) + END IF + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T,Y,Jac0) + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL WCOPY(NVAR,Fcn0,1,Fcn,1) + IF (AdjointType == Adj_discrete) THEN ! Save stage solution + CALL WCOPY(NVAR,Y,1,Ystage(1),1) + END IF + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j = 1, istage-1 + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL FunTemplate(Tau,Ynew,Fcn) + IF (AdjointType == Adj_discrete) THEN ! Save stage solution + CALL WCOPY(NVAR,Ynew,1,Ystage(ioffset+1),1) + END IF + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + END IF + CALL ros_Solve('N', Ghimj, Pivot, K(ioffset+1)) + + END DO Stage + + +!~~~> Compute the new solution + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + IF (AdjointType == Adj_discrete) THEN ! Save current state + CALL ros_DPush( ros_S, T, H, Ystage, K ) !, Ghimj ) + ELSEIF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL Jac_SP_Vec( Jac0, Fcn0, K(1) ) + IF (.NOT. Autonomous) THEN + CALL WAXPY(NVAR,ONE,dFdT,1,K(1),1) + END IF + CALL ros_CPush( T, H, Y, Fcn0, K(1) ) + END IF + CALL WCOPY(NVAR,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Save last state: only needed for continuous adjoint + IF ( (AdjointType == Adj_continuous) .OR. & + (AdjointType == Adj_simple_continuous) ) THEN + CALL FunTemplate(T,Y,Fcn0) + CALL JacTemplate(T,Y,Jac0) + CALL Jac_SP_Vec( Jac0, Fcn0, K(1) ) + IF (.NOT. Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) + CALL WAXPY(NVAR,ONE,dFdT,1,K(1),1) + END IF + CALL ros_CPush( T, H, Y, Fcn0, K(1) ) +!~~~> Deallocate stage buffer: only needed for discrete adjoint + ELSEIF (AdjointType == Adj_discrete) THEN + DEALLOCATE(Ystage, STAT=i) + IF (i/=0) THEN + PRINT*,'Deallocation of Ystage failed' + STOP + END IF + END IF + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + PRINT*,'Nacc after fwd =',Nacc + + END SUBROUTINE ros_FwdInt + + + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_DadjInt ( & + NADJ, Lambda, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> RosenbrockSOA method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockSOA method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ +!~~~> First order adjoint + KPP_REAL, INTENT(INOUT) :: Lambda(NVAR,NADJ) +!!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The RosenbrockSOA method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Ystage_adj(NVAR,NADJ) + KPP_REAL :: dFdT(NVAR) + KPP_REAL :: Ystage(NVAR*ros_S), K(NVAR*ros_S) + KPP_REAL :: U(NVAR*ros_S,NADJ), V(NVAR*ros_S,NADJ) + KPP_REAL :: Jac(LU_NONZERO), dJdT(LU_NONZERO), Ghimj(LU_NONZERO) + KPP_REAL :: Hes0(NHESS), Hes1(NHESS), dHdT(NHESS) + KPP_REAL :: Tmp(NVAR), Tmp2(NVAR) + KPP_REAL :: H, HC, HA, Tau + INTEGER :: Pivot(NVAR), Direction + INTEGER :: i, j, m, istage, istart, jstart +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + OPEN(55,file='KPP_ROOT_dadj.dat') + +!~~~> Time loop begins below +TimeLoop: DO WHILE ( stack_ptr > 0 ) + + !~~~> Recover checkpoints for stage values and vectors + CALL ros_DPop( ros_S, T, H, Ystage, K ) !, Ghimj ) + + Nstp = Nstp+1 + +!~~~> Compute LU decomposition + CALL JacTemplate(T,Ystage(1),Ghimj) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + Tau = ONE/(Direction*H*ros_Gamma(1)) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+Tau + END DO + CALL ros_Decomp( Ghimj, Pivot, j ) + +!~~~> Compute Hessian at the beginning of the interval + CALL HessTemplate(T,Ystage(1),Hes0) + +!~~~> Compute the stages +Stage: DO istage = ros_S, 1, -1 + + !~~~> Current istage first entry + istart = NVAR*(istage-1) + 1 + + !~~~> Compute U + DO m = 1,NADJ + CALL WCOPY(NVAR,Lambda(1,m),1,U(istart,m),1) + CALL WSCAL(NVAR,ros_M(istage),U(istart,m),1) + END DO ! m=1:NADJ + DO j = istage+1, ros_S + jstart = NVAR*(j-1) + 1 + HA = ros_A((j-1)*(j-2)/2+istage) + HC = ros_C((j-1)*(j-2)/2+istage)/(Direction*H) + DO m = 1,NADJ + CALL WAXPY(NVAR,HA,V(jstart,m),1,U(istart,m),1) + CALL WAXPY(NVAR,HC,U(jstart,m),1,U(istart,m),1) + END DO ! m=1:NADJ + END DO + DO m = 1,NADJ + CALL ros_Solve('T', Ghimj, Pivot, U(istart,m)) + END DO ! m=1:NADJ + !~~~> Compute V + Tau = T + ros_Alpha(istage)*Direction*H + CALL JacTemplate(Tau,Ystage(istart),Jac) + DO m = 1,NADJ + CALL JacTR_SP_Vec(Jac,U(istart,m),V(istart,m)) + END DO ! m=1:NADJ + + END DO Stage + + IF (.NOT.Autonomous) THEN +!~~~> Compute the Jacobian derivative with respect to T. +! Last "Jac" computed for stage 1 + CALL ros_JacTimeDerivative ( T, Roundoff, Ystage(1), & + Jac, dJdT ) + END IF + +!~~~> Compute the new solution + + !~~~> Compute Lambda + DO istage=1,ros_S + istart = NVAR*(istage-1) + 1 + DO m = 1,NADJ + ! Add V_i + CALL WAXPY(NVAR,ONE,V(istart,m),1,Lambda(1,m),1) + ! Add (H0xK_i)^T * U_i + CALL HessTR_Vec ( Hes0, U(istart,m), K(istart), Tmp ) + CALL WAXPY(NVAR,ONE,Tmp,1,Lambda(1,m),1) + END DO ! m=1:NADJ + END DO + ! Add H * dJac_dT_0^T * \sum(gamma_i U_i) + ! Tmp holds sum gamma_i U_i + IF (.NOT.Autonomous) THEN + DO m = 1,NADJ + Tmp(1:NVAR) = ZERO + DO istage = 1, ros_S + istart = NVAR*(istage-1) + 1 + CALL WAXPY(NVAR,ros_Gamma(istage),U(istart,m),1,Tmp,1) + END DO + CALL JacTR_SP_Vec(dJdT,Tmp,Tmp2) + CALL WAXPY(NVAR,H,Tmp2,1,Lambda(1,m),1) + END DO ! m=1:NADJ + END IF ! .NOT.Autonomous + + + END DO TimeLoop + +!~~~> Save last state + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + END SUBROUTINE ros_DadjInt +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_CadjInt ( & + NADJ, Y, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> RosenbrockADJ method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, AdjointType, & + Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ + KPP_REAL, INTENT(INOUT) :: Y(NVAR,NADJ) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The RosenbrockADJ method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + INTEGER, INTENT(IN) :: AdjointType + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Y0(NVAR) + KPP_REAL :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) + KPP_REAL :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) + KPP_REAL :: Jac(LU_NONZERO), dJdT(LU_NONZERO) + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR,NADJ) + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage, iadj + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> INITIAL PREPARATIONS + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.0_dp*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + + OPEN(55,file='KPP_ROOT_full_cadj.dat') + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Interpolate forward solution + CALL ros_cadj_Y( T, Y0 ) +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T, Y0, Jac0) + + WRITE(55,55) T, H, Y0(ind_NO2), Y0(ind_O3), & + Y(ind_NO2,1), Y(ind_O3,2), & + Y(ind_NO2,2), Y(ind_O3,1) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & + Jac0, dJdT ) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(dJdT,Y(1,iadj),dFdT(1,iadj)) + CALL WSCAL(NVAR,(-ONE),dFdT(1,iadj),1) + END DO + END IF + +!~~~> Ydot = -J^T*Y + CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(Jac0,Y(1,iadj),Fcn0(1,iadj)) + END DO + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1), & + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) + END DO + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) + DO j = 1, istage-1 + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + Tau = T + ros_Alpha(istage)*Direction*H + ! CALL FunTemplate(Tau,Ynew,Fcn) + CALL ros_cadj_Y( Tau, Y0 ) + CALL JacTemplate(Tau, Y0, Jac) + CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(Jac,Ynew(1,iadj),Fcn(1,iadj)) + !CALL WSCAL(NVAR,(-ONE),Fcn(1,iadj),1) + END DO + END IF ! if istage == 1 elseif ros_NewF(istage) + + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) + END DO + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1,iadj),1, & + K(ioffset+1,iadj),1) + END DO + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HG,dFdT(1,iadj),1,K(ioffset+1,iadj),1) + END DO + END IF + DO iadj = 1, NADJ + CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1,iadj)) + END DO + + END DO Stage + + +!~~~> Compute the new solution + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Y(1,iadj),1,Ynew(1,iadj),1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR*NADJ,ZERO,Yerr,1) + DO j=1,ros_S + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1,iadj),1,Yerr(1,iadj),1) + END DO + END DO +!~~~> Max error among all adjoint components + iadj = 1 + Err = ros_ErrorNorm ( Y(1,iadj), Ynew(1,iadj), Yerr(1,iadj), & + AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL WCOPY(NVAR*NADJ,Ynew,1,Y,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + WRITE(55,55) T, H, Y0(ind_NO2), Y0(ind_O3), & + Y(ind_NO2,1), Y(ind_O3,2), & + Y(ind_NO2,2), Y(ind_O3,1) + +55 FORMAT(100(E12.5,2X)) + CLOSE(55) + + END SUBROUTINE ros_CadjInt + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_SimpleCadjInt ( & + NADJ, Y, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> RosenbrockADJ method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, AdjointType, & + Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic RosenbrockADJ method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + INTEGER, INTENT(IN) :: NADJ + KPP_REAL, INTENT(INOUT) :: Y(NVAR,NADJ) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The RosenbrockADJ method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + INTEGER, INTENT(IN) :: AdjointType + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Y0(NVAR), Y0old(NVAR), Told + KPP_REAL :: Ynew(NVAR,NADJ), Fcn0(NVAR,NADJ), Fcn(NVAR,NADJ) + KPP_REAL :: K(NVAR*ros_S,NADJ), dFdT(NVAR,NADJ) + KPP_REAL :: Jac0(LU_NONZERO), Ghimj(LU_NONZERO) + KPP_REAL :: Jac(LU_NONZERO), dJdT(LU_NONZERO) + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, ghinv + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage, iadj + INTEGER :: istack + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> INITIAL PREPARATIONS + + IF (Tend >= Tstart) THEN + Direction = -1 + ELSE + Direction = +1 + END IF + + OPEN(55,file='KPP_ROOT_smpl_cadj.dat') + + +!~~~> Time loop begins below +TimeLoop: DO istack = stack_ptr,2,-1 + + T = buf_T(istack) + H = buf_H(istack-1) + CALL WCOPY(NVAR,buf_Y(1,istack),1,Y0,1) + + WRITE(55,55) T, H, Y0(ind_NO2), Y0(ind_O3), & + Y(ind_NO2,1), Y(ind_O3,2), Y(ind_NO2,2), Y(ind_O3,1) + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T, Y0, Jac0) + +!~~~> Compute the function derivative with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_JacTimeDerivative ( T, Roundoff, Y0, & + Jac0, dJdT ) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(dJdT,Y(1,iadj),dFdT(1,iadj)) + CALL WSCAL(NVAR,(-ONE),dFdT(1,iadj),1) + END DO + END IF + +!~~~> Ydot = -J^T*Y + CALL WSCAL(LU_NONZERO,(-ONE),Jac0,1) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(Jac0,Y(1,iadj),Fcn0(1,iadj)) + END DO + +!~~~> Construct Ghimj = 1/(H*ham) - Jac0 + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*ros_Gamma(1)) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, j ) + IF (j /= 0) THEN + CALL ros_ErrorMsg(-8,T,H,IERR) + PRINT*,' The matrix is singular !' + STOP + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn0(1,iadj),1,Fcn(1,iadj),1) + END DO + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR*NADJ,Y,1,Ynew,1) + DO j = 1, istage-1 + DO iadj = 1, NADJ + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1,iadj),1,Ynew(1,iadj),1) + END DO + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL ros_Hermite3( buf_T(istack-1), buf_T(istack), Tau, & + buf_Y(1,istack-1), buf_Y(1,istack), & + buf_dY(1,istack-1), buf_dY(1,istack), Y0 ) + CALL JacTemplate(Tau, Y0, Jac) + CALL WSCAL(LU_NONZERO,(-ONE),Jac,1) + DO iadj = 1, NADJ + CALL JacTR_SP_Vec(Jac,Ynew(1,iadj),Fcn(1,iadj)) + END DO + END IF ! if istage == 1 elseif ros_NewF(istage) + + DO iadj = 1, NADJ + CALL WCOPY(NVAR,Fcn(1,iadj),1,K(ioffset+1,iadj),1) + END DO + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1,iadj),1, & + K(ioffset+1,iadj),1) + END DO + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + DO iadj = 1, NADJ + CALL WAXPY(NVAR,HG,dFdT(1,iadj),1,K(ioffset+1,iadj),1) + END DO + END IF + DO iadj = 1, NADJ + CALL ros_Solve('T', Ghimj, Pivot, K(ioffset+1,iadj)) + END DO + + END DO Stage + + +!~~~> Compute the new solution + DO iadj = 1, NADJ + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1,iadj),1,Y(1,iadj),1) + END DO + END DO + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + WRITE(55,55) T, H, Y0(ind_NO2), Y0(ind_O3), & + Y(ind_NO2,1), Y(ind_O3,2), & + Y(ind_NO2,2), Y(ind_O3,1) + +55 FORMAT(100(E12.5,2X)) + CLOSE(55) + + END SUBROUTINE ros_SimpleCadjInt + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + ros_ErrorNorm = Err + + END FUNCTION ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL FunTemplate(T+Delta,Y,dFdT) + CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE ros_FunTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & + Jac0, dJdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the Jacobian by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Jac0(LU_NONZERO) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dJdT(LU_NONZERO) +!~~~> Local variables + KPP_REAL Delta + KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL JacTemplate(T+Delta,Y,dJdT) + CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) + CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) + + END SUBROUTINE ros_JacTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: gam, Jac0(LU_NONZERO) + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0d0, HALF = 0.5d0 + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*ham) - Jac0 + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, ising ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Decomp( A, Pivot, ising ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + + CALL KppDecomp ( A, ising ) +!~~~> Note: for a full matrix use Lapack: +! CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) + Pivot(1) = 1 + + Ndec = Ndec + 1 + + END SUBROUTINE ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Solve( C, A, Pivot, b ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + CHARACTER, INTENT(IN) :: C + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + + SELECT CASE (C) + CASE ('N') + CALL KppSolve( A, b ) + CASE ('T') + CALL KppSolveTR( A, b, b ) + CASE DEFAULT + PRINT*,'Unknown C = (',C,') in ros_Solve' + STOP + END SELECT +!~~~> Note: for a full matrix use Lapack: +! NRHS = 1 +! CALL DGETRS( C, NVAR , NRHS, A, NVAR, Pivot, b, NVAR, INFO ) + + Nsol = Nsol+1 + + END SUBROUTINE ros_Solve + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_cadj_Y( T, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Finds the solution Y at T by interpolating the stored forward trajectory +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: T +!~~~> Output variables + KPP_REAL, INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + INTEGER :: i, j + KPP_REAL, PARAMETER :: ONE = 1.0d0 + +! buf_H, buf_T, buf_Y, buf_dY, buf_d2Y + + IF( (T < buf_T(1)).OR.(T> buf_T(stack_ptr)) ) THEN + PRINT*,'Cannot locate solution at T = ',T + PRINT*,'Stored trajectory is between Tstart = ',buf_T(1) + PRINT*,' and Tend = ',buf_T(stack_ptr) + STOP + END IF + DO i = 1, stack_ptr-1 + IF( (T>= buf_T(i)).AND.(T<= buf_T(i+1)) ) EXIT + END DO + + + IF (.FALSE.) THEN + + CALL ros_Hermite5( buf_T(i), buf_T(i+1), T, & + buf_Y(1,i), buf_Y(1,i+1), & + buf_dY(1,i), buf_dY(1,i+1), & + buf_d2Y(1,i), buf_d2Y(1,i+1), Y ) + + ELSE + + CALL ros_Hermite3( buf_T(i), buf_T(i+1), T, & + buf_Y(1,i), buf_Y(1,i+1), & + buf_dY(1,i), buf_dY(1,i+1), & + Y ) + + + END IF + + END SUBROUTINE ros_cadj_Y + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Hermite3( a, b, T, Ya, Yb, Ja, Jb, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for Hermite interpolation of order 5 on the interval [a,b] +! P = c(1) + c(2)*(x-a) + ... + c(4)*(x-a)^3 +! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb] +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) + KPP_REAL, INTENT(IN) :: Ja(NVAR), Jb(NVAR) +!~~~> Output variables + KPP_REAL, INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + KPP_REAL :: Tau, amb(3), C(NVAR,4) + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + INTEGER :: i, j + + amb(1) = 1.0d0/(a-b) + DO i=2,3 + amb(i) = amb(i-1)*amb(1) + END DO + + +! c(1) = ya; + CALL WCOPY(NVAR,Ya,1,C(1,1),1) +! c(2) = ja; + CALL WCOPY(NVAR,Ja,1,C(1,2),1) +! c(3) = 2/(a-b)*ja + 1/(a-b)*jb - 3/(a - b)^2*ya + 3/(a - b)^2*yb ; + CALL WCOPY(NVAR,Ya,1,C(1,3),1) + CALL WSCAL(NVAR,-3.0*amb(2),C(1,3),1) + CALL WAXPY(NVAR,3.0*amb(2),Yb,1,C(1,3),1) + CALL WAXPY(NVAR,2.0*amb(1),Ja,1,C(1,3),1) + CALL WAXPY(NVAR,amb(1),Jb,1,C(1,3),1) +! c(4) = 1/(a-b)^2*ja + 1/(a-b)^2*jb - 2/(a-b)^3*ya + 2/(a-b)^3*yb ; + CALL WCOPY(NVAR,Ya,1,C(1,4),1) + CALL WSCAL(NVAR,-2.0*amb(3),C(1,4),1) + CALL WAXPY(NVAR,2.0*amb(3),Yb,1,C(1,4),1) + CALL WAXPY(NVAR,amb(2),Ja,1,C(1,4),1) + CALL WAXPY(NVAR,amb(2),Jb,1,C(1,4),1) + + Tau = T - a + CALL WCOPY(NVAR,C(1,4),1,Y,1) + CALL WSCAL(NVAR,Tau**3,Y,1) + DO j = 3,1,-1 + CALL WAXPY(NVAR,TAU**(j-1),C(1,j),1,Y,1) + END DO + + END SUBROUTINE ros_Hermite3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Hermite5( a, b, T, Ya, Yb, Ja, Jb, Ha, Hb, Y ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for Hermite interpolation of order 5 on the interval [a,b] +! P = c(1) + c(2)*(x-a) + ... + c(6)*(x-a)^5 +! P[a,b] = [Ya,Yb], P'[a,b] = [Ja,Jb], P"[a,b] = [Ha,Hb] +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: a, b, T, Ya(NVAR), Yb(NVAR) + KPP_REAL, INTENT(IN) :: Ja(NVAR), Jb(NVAR), Ha(NVAR), Hb(NVAR) +!~~~> Output variables + KPP_REAL, INTENT(OUT) :: Y(NVAR) +!~~~> Local variables + KPP_REAL :: Tau, amb(5), C(NVAR,6) + KPP_REAL, PARAMETER :: ZERO = 0.0d0, HALF = 0.5d0 + INTEGER :: i, j + + amb(1) = 1.0d0/(a-b) + DO i=2,5 + amb(i) = amb(i-1)*amb(1) + END DO + +! c(1) = ya; + CALL WCOPY(NVAR,Ya,1,C(1,1),1) +! c(2) = ja; + CALL WCOPY(NVAR,Ja,1,C(1,2),1) +! c(3) = ha/2; + CALL WCOPY(NVAR,Ha,1,C(1,3),1) + CALL WSCAL(NVAR,HALF,C(1,3),1) + +! c(4) = 10*amb(3)*ya - 10*amb(3)*yb - 6*amb(2)*ja - 4*amb(2)*jb + 1.5*amb(1)*ha - 0.5*amb(1)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,4),1) + CALL WSCAL(NVAR,10.0*amb(3),C(1,4),1) + CALL WAXPY(NVAR,-10.0*amb(3),Yb,1,C(1,4),1) + CALL WAXPY(NVAR,-6.0*amb(2),Ja,1,C(1,4),1) + CALL WAXPY(NVAR,-4.0*amb(2),Jb,1,C(1,4),1) + CALL WAXPY(NVAR, 1.5*amb(1),Ha,1,C(1,4),1) + CALL WAXPY(NVAR,-0.5*amb(1),Hb,1,C(1,4),1) + +! c(5) = 15*amb(4)*ya - 15*amb(4)*yb - 8.*amb(3)*ja - 7*amb(3)*jb + 1.5*amb(2)*ha - 1*amb(2)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,5),1) + CALL WSCAL(NVAR, 15.0*amb(4),C(1,5),1) + CALL WAXPY(NVAR,-15.0*amb(4),Yb,1,C(1,5),1) + CALL WAXPY(NVAR,-8.0*amb(3),Ja,1,C(1,5),1) + CALL WAXPY(NVAR,-7.0*amb(3),Jb,1,C(1,5),1) + CALL WAXPY(NVAR,1.5*amb(2),Ha,1,C(1,5),1) + CALL WAXPY(NVAR,-amb(2),Hb,1,C(1,5),1) + +! c(6) = 6*amb(5)*ya - 6*amb(5)*yb - 3.*amb(4)*ja - 3.*amb(4)*jb + 0.5*amb(3)*ha -0.5*amb(3)*hb ; + CALL WCOPY(NVAR,Ya,1,C(1,6),1) + CALL WSCAL(NVAR, 6.0*amb(5),C(1,6),1) + CALL WAXPY(NVAR,-6.0*amb(5),Yb,1,C(1,6),1) + CALL WAXPY(NVAR,-3.0*amb(4),Ja,1,C(1,6),1) + CALL WAXPY(NVAR,-3.0*amb(4),Jb,1,C(1,6),1) + CALL WAXPY(NVAR, 0.5*amb(3),Ha,1,C(1,6),1) + CALL WAXPY(NVAR,-0.5*amb(3),Hb,1,C(1,6),1) + + Tau = T - a + CALL WCOPY(NVAR,C(1,6),1,Y,1) + DO j = 5,1,-1 + CALL WSCAL(NVAR,Tau,Y,1) + CALL WAXPY(NVAR,ONE,C(1,j),1,Y,1) + END DO + + END SUBROUTINE ros_Hermite5 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + + g = 1.0d0 + 1.0d0/SQRT(2.0d0) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.d0)/g + ros_C(1) = (-2.d0)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.d0)/(2.d0*g) + ros_M(2)= (1.d0)/(2.d0*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.d0/(2.d0*g) + ros_E(2) = 1.d0/(2.d0*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d0 + ros_Alpha(2) = 1.0d0 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.d0 + ros_A(2)= 1.d0 + ros_A(3)= 0.d0 + + ros_C(1) = -0.10156171083877702091975600115545d+01 + ros_C(2) = 0.40759956452537699824805835358067d+01 + ros_C(3) = 0.92076794298330791242156818474003d+01 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1d+01 + ros_M(2) = 0.61697947043828245592553615689730d+01 + ros_M(3) = -0.42772256543218573326238373806514d+00 +! E_i = Coefficients for error estimator + ros_E(1) = 0.5d+00 + ros_E(2) = -0.29079558716805469821718236208017d+01 + ros_E(3) = 0.22354069897811569627360909276199d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0d+00 + ros_Alpha(2)= 0.43586652150845899941601945119356d+00 + ros_Alpha(3)= 0.43586652150845899941601945119356d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356d+00 + ros_Gamma(2)= 0.24291996454816804366592249683314d+00 + ros_Gamma(3)= 0.21851380027664058511513169485832d+01 + + END SUBROUTINE Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000d+01 + ros_A(2) = 0.1867943637803922d+01 + ros_A(3) = 0.2344449711399156d+00 + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0D0 + + ros_C(1) =-0.7137615036412310d+01 + ros_C(2) = 0.2580708087951457d+01 + ros_C(3) = 0.6515950076447975d+00 + ros_C(4) =-0.2137148994382534d+01 + ros_C(5) =-0.3214669691237626d+00 + ros_C(6) =-0.6949742501781779d+00 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735d+01 + ros_M(2) = 0.2870493262186792d+00 + ros_M(3) = 0.4353179431840180d+00 + ros_M(4) = 0.1093502252409163d+01 +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155d+00 + ros_E(2) =-0.7276199124938920d-01 + ros_E(3) =-0.1082196201495311d+00 + ros_E(4) =-0.1093502252409163d+01 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.D0 + ros_Alpha(2) = 0.1145640000000000d+01 + ros_Alpha(3) = 0.6552168638155900d+00 + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000d+00 + ros_Gamma(2) =-0.1769193891319233d+01 + ros_Gamma(3) = 0.7592633437920482d+00 + ros_Gamma(4) =-0.1049021087100450d+00 + + END SUBROUTINE Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0d+00 + ros_A(2) = 2.0d+00 + ros_A(3) = 0.0d+00 + ros_A(4) = 2.0d+00 + ros_A(5) = 0.0d+00 + ros_A(6) = 1.0d+00 + + ros_C(1) = 4.0d+00 + ros_C(2) = 1.0d+00 + ros_C(3) =-1.0d+00 + ros_C(4) = 1.0d+00 + ros_C(5) =-1.0d+00 + ros_C(6) =-(8.0d+00/3.0d+00) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0d+00 + ros_M(2) = 0.0d+00 + ros_M(3) = 1.0d+00 + ros_M(4) = 1.0d+00 +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 1.0d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d+00 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d+00 + ros_Alpha(2) = 0.0d+00 + ros_Alpha(3) = 1.0d+00 + ros_Alpha(4) = 1.0d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5d+00 + ros_Gamma(2) = 1.5d+00 + ros_Gamma(3) = 0.0d+00 + ros_Gamma(4) = 0.0d+00 + + END SUBROUTINE Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S=6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = S + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000d0 + ros_Alpha(2) = 0.386d0 + ros_Alpha(3) = 0.210d0 + ros_Alpha(4) = 0.630d0 + ros_Alpha(5) = 1.000d0 + ros_Alpha(6) = 1.000d0 + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000d+00 + ros_Gamma(2) =-0.1043000000000000d+00 + ros_Gamma(3) = 0.1035000000000000d+00 + ros_Gamma(4) =-0.3620000000000023d-01 + ros_Gamma(5) = 0.0d0 + ros_Gamma(6) = 0.0d0 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000d+01 + ros_A(2) = 0.9466785280815826d+00 + ros_A(3) = 0.2557011698983284d+00 + ros_A(4) = 0.3314825187068521d+01 + ros_A(5) = 0.2896124015972201d+01 + ros_A(6) = 0.9986419139977817d+00 + ros_A(7) = 0.1221224509226641d+01 + ros_A(8) = 0.6019134481288629d+01 + ros_A(9) = 0.1253708332932087d+02 + ros_A(10) =-0.6878860361058950d+00 + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0d+00 + + ros_C(1) =-0.5668800000000000d+01 + ros_C(2) =-0.2430093356833875d+01 + ros_C(3) =-0.2063599157091915d+00 + ros_C(4) =-0.1073529058151375d+00 + ros_C(5) =-0.9594562251023355d+01 + ros_C(6) =-0.2047028614809616d+02 + ros_C(7) = 0.7496443313967647d+01 + ros_C(8) =-0.1024680431464352d+02 + ros_C(9) =-0.3399990352819905d+02 + ros_C(10) = 0.1170890893206160d+02 + ros_C(11) = 0.8083246795921522d+01 + ros_C(12) =-0.7981132988064893d+01 + ros_C(13) =-0.3152159432874371d+02 + ros_C(14) = 0.1631930543123136d+02 + ros_C(15) =-0.6058818238834054d+01 + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0d+00 + ros_M(6) = 1.0d+00 + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 0.0d+00 + ros_E(5) = 0.0d+00 + ros_E(6) = 1.0d+00 + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 + + END SUBROUTINE Rodas4 + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE FunTemplate( T, Y, Ydot ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Ydot(NVAR) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, Ydot ) + TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE JacTemplate( T, Y, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Jcb(LU_NONZERO) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, Jcb ) + TIME = Told + + Njac = Njac+1 + +END SUBROUTINE JacTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE HessTemplate( T, Y, Hes ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Hessian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Hes(NHESS) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, Hes ) + TIME = Told + +END SUBROUTINE HessTemplate + +END MODULE KPP_ROOT_Integrator + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.def new file mode 100755 index 00000000..6d31074d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.def @@ -0,0 +1,23 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE rosenbrock_tlm + +#INLINE F77_GLOBAL + INTEGER Autonomous + COMMON /INTGDATA/ Autonomous + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + Autonomous = 1 + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.f90 new file mode 100755 index 00000000..50429ce1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/rosenbrock_tlm.f90 @@ -0,0 +1,1390 @@ +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_LinearAlgebra + USE KPP_ROOT_Rates + USE KPP_ROOT_Function + USE KPP_ROOT_Jacobian + USE KPP_ROOT_Hessian + USE KPP_ROOT_Util + + IMPLICIT NONE + PUBLIC + SAVE +!~~~> Statistics on the work performed by the Rosenbrock method + INTEGER :: Nfun,Njac,Nstp,Nacc,Nrej,Ndec,Nsol,Nsng + INTEGER, PARAMETER :: ifun=1, ijac=2, istp=3, iacc=4, & + irej=5, idec=6, isol=7, isng=8, & + itexit=1,ihexit=2 + + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + + +CONTAINS ! Functions in the module KPP_ROOT_Integrator + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE INTEGRATE_TLM( NTLM, Y, Y_tlm, TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Y - Concentrations + KPP_REAL :: Y(NVAR) +!~~~> NTLM - No. of sensitivity coefficients + INTEGER NTLM +!~~~> Y_tlm - Sensitivities of concentrations +! Note: Y_tlm (1:NVAR,j) contains sensitivities of +! Y(1:NVAR) w.r.t. the j-th parameter, j=1...NTLM + KPP_REAL :: Y_tlm(NVAR,NTLM) + KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time + KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time +!~~~> Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + + INTEGER, SAVE :: N_stp, N_acc, N_rej, N_sng, IERR + KPP_REAL :: RCNTRL(20), RSTATUS(20) + INTEGER :: ICNTRL(20), ISTATUS(20) + + ICNTRL(1:10) = 0 + RCNTRL(1:10) = 0.0_dp + ISTATUS(1:10) = 0 + RSTATUS(1:10) = 0.0_dp + + ICNTRL(1) = 0 ! non-autonomous + ICNTRL(2) = 1 ! vector tolerances + RCNTRL(3) = STEPMIN ! starting step + ICNTRL(4) = 5 ! choice of the method + + ! if optional parameters are given, and if they are >=0, then they overwrite default settings + IF (PRESENT(ICNTRL_U)) THEN + WHERE(ICNTRL_U(:) >= 0) ICNTRL(1:20) = ICNTRL_U(:) + ENDIF + IF (PRESENT(RCNTRL_U)) THEN + WHERE(RCNTRL_U(:) >= 0) RCNTRL(1:20) = RCNTRL_U(:) + ENDIF + + CALL RosenbrockTLM(VAR, NTLM, Y_tlm, & + TIN,TOUT, & + ATOL,RTOL, & + FunTemplate,JacTemplate,HessTemplate, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) + + ! N_stp = N_stp + ICNTRL(istp) + ! N_acc = N_acc + ICNTRL(iacc) + ! N_rej = N_rej + ICNTRL(irej) + ! N_sng = N_sng + ICNTRL(isng) + ! PRINT*,'Step=',N_stp,' Acc=',N_acc,' Rej=',N_rej, & + ! ' Singular=',N_sng + + IF (IERR < 0) THEN + print *,'Rosenbrock: Unsucessful step at T=', & + TIN,' (IERR=',IERR,')' + END IF + + STEPMIN = RCNTRL(ihexit) + ! if optional parameters are given for output they return information + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = ISTATUS(1:20) + IF (PRESENT(RSTATUS_U)) RSTATUS_U(:) = RSTATUS(1:20) + +END SUBROUTINE INTEGRATE_TLM + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE RosenbrockTLM(Y,NTLM,Y_tlm,& + Tstart,Tend, & + AbsTol,RelTol, & + RCNTRL,ICNTRL,RSTATUS,ISTATUS,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! TLM = Tangent Linear Model of a Rosenbrock Method +! +! Solves the system y'=F(t,y) using a Rosenbrock method defined by: +! +! G = 1/(H*gamma(1)) - Jac(t0,Y0) +! T_i = t0 + Alpha(i)*H +! Y_i = Y0 + \sum_{j=1}^{i-1} A(i,j)*K_j +! G * K_i = Fun( T_i, Y_i ) + \sum_{j=1}^S C(i,j)/H * K_j + +! gamma(i)*dF/dT(t0, Y0) +! Y1 = Y0 + \sum_{j=1}^S M(j)*K_j +! +! For details on Rosenbrock methods and their implementation consult: +! E. Hairer and G. Wanner +! "Solving ODEs II. Stiff and differential-algebraic problems". +! Springer series in computational mathematics, Springer-Verlag, 1996. +! The codes contained in the book inspired this implementation. +! +! (C) Adrian Sandu, August 2004 +! Virginia Polytechnic Institute and State University +! Contact: sandu@cs.vt.edu +! This implementation is part of KPP - the Kinetic PreProcessor +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of initial conditions (at T=Tstart) +! NTLM -> dimension of linearized system, +! i.e. the number of sensitivity coefficients +!- Y_tlm(NVAR*NTLM) -> vector of initial sensitivity conditions (at T=Tstart) +!- [Tstart,Tend] -> time range of integration +! (if Tstart>Tend the integration is performed backwards in time) +!- RelTol, AbsTol -> user precribed accuracy +!- SUBROUTINE Fun( T, Y, Ydot ) -> ODE function, +! returns Ydot = Y' = F(T,Y) +!- SUBROUTINE Jac( T, Y, Jcb ) -> Jacobian of the ODE function, +! returns Jcb = dF/dY +!- ICNTRL(1:10) -> integer inputs parameters +!- RCNTRL(1:10) -> real inputs parameters +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT ARGUMENTS: +! +!- Y(NVAR) -> vector of final states (at T->Tend) +!- Y_tlm(NVAR*NTLM) -> vector of final sensitivities (at T=Tend) +!- ICNTRL(11:20) -> integer output parameters +!- RCNTRL(11:20) -> real output parameters +!- IERR -> job status upon return +! - succes (positive value) or failure (negative value) - +! = 1 : Success +! = -1 : Improper value for maximal no of steps +! = -2 : Selected Rosenbrock method not implemented +! = -3 : Hmin/Hmax/Hstart must be positive +! = -4 : FacMin/FacMax/FacRej must be positive +! = -5 : Improper tolerance values +! = -6 : No of steps exceeds maximum bound +! = -7 : Step size too small +! = -8 : Matrix is repeatedly singular +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> INPUT PARAMETERS: +! +! Note: For input parameters equal to zero the default values of the +! corresponding variables are used. +! +! ICNTRL(1) = 1: F = F(y) Independent of T (AUTONOMOUS) +! = 0: F = F(t,y) Depends on T (NON-AUTONOMOUS) +! ICNTRL(2) = 0: AbsTol, RelTol are NVAR-dimensional vectors +! = 1: AbsTol, RelTol are scalars +! ICNTRL(3) -> maximum number of integration steps +! For ICNTRL(3)=0) the default value of 100000 is used +! +! ICNTRL(4) -> selection of a particular Rosenbrock method +! = 0 : default method is Rodas3 +! = 1 : method is Ros2 +! = 2 : method is Ros3 +! = 3 : method is Ros4 +! = 4 : method is Rodas3 +! = 5: method is Rodas4 +! +! RCNTRL(1) -> Hmin, lower bound for the integration step size +! It is strongly recommended to keep Hmin = ZERO +! RCNTRL(2) -> Hmax, upper bound for the integration step size +! RCNTRL(3) -> Hstart, starting value for the integration step size +! +! RCNTRL(4) -> FacMin, lower bound on step decrease factor (default=0.2) +! RCNTRL(5) -> FacMin,upper bound on step increase factor (default=6) +! RCNTRL(6) -> FacRej, step decrease factor after multiple rejections +! (default=0.1) +! RCNTRL(7) -> FacSafe, by which the new step is slightly smaller +! than the predicted value (default=0.9) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +!~~~> OUTPUT PARAMETERS: +! +! Note: each call to Rosenbrock adds the corrent no. of fcn calls +! to previous value of ISTATUS(1), and similar for the other params. +! Set ISTATUS(1:10) = 0 before call to avoid this accumulation. +! +! ISTATUS(1) = No. of function calls +! ISTATUS(2) = No. of jacobian calls +! ISTATUS(3) = No. of steps +! ISTATUS(4) = No. of accepted steps +! ISTATUS(5) = No. of rejected steps (except at the beginning) +! ISTATUS(6) = No. of LU decompositions +! ISTATUS(7) = No. of forward/backward substitutions +! ISTATUS(8) = No. of singular matrix decompositions +! +! RSTATUS(1) -> Texit, the time corresponding to the +! computed Y upon return +! RSTATUS(2) -> Hexit, last accepted step before exit +! For multiple restarts, use Hexit as Hstart in the following run +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Arguments + KPP_REAL, INTENT(INOUT) :: Y(NVAR) + INTEGER, INTENT(IN) :: NTLM + KPP_REAL, INTENT(INOUT) :: Y_tlm(NVAR,NTLM) + KPP_REAL, INTENT(IN) :: Tstart, Tend + KPP_REAL, INTENT(IN) :: AbsTol(NVAR),RelTol(NVAR) + INTEGER, INTENT(IN) :: ICNTRL(10) + KPP_REAL, INTENT(IN) :: RCNTRL(10) + INTEGER, INTENT(INOUT) :: ISTATUS(10) + KPP_REAL, INTENT(INOUT) :: RSTATUS(10) + INTEGER, INTENT(OUT) :: IERR +!~~~> The method parameters + INTEGER, PARAMETER :: Smax = 6 + INTEGER :: Method, ros_S + KPP_REAL, DIMENSION(Smax) :: ros_M, ros_E, ros_Alpha, ros_Gamma + KPP_REAL, DIMENSION(Smax*(Smax-1)/2) :: ros_A, ros_C + KPP_REAL :: ros_ELO + LOGICAL, DIMENSION(Smax) :: ros_NewF + CHARACTER(LEN=12) :: ros_Name +!~~~> Local variables + KPP_REAL :: Roundoff, FacMin, FacMax, FacRej, FacSafe + KPP_REAL :: Hmin, Hmax, Hstart, Hexit + KPP_REAL :: Texit + INTEGER :: i, UplimTol, Max_no_steps + LOGICAL :: Autonomous, VectorTol +!~~~> Parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 + +!~~~> Initialize statistics + Nfun = ISTATUS(ifun) + Njac = ISTATUS(ijac) + Nstp = ISTATUS(istp) + Nacc = ISTATUS(iacc) + Nrej = ISTATUS(irej) + Ndec = ISTATUS(idec) + Nsol = ISTATUS(isol) + Nsng = ISTATUS(isng) + +!~~~> Autonomous or time dependent ODE. Default is time dependent. + Autonomous = .NOT.(ICNTRL(1) == 0) + +!~~~> For Scalar tolerances (ICNTRL(2).NE.0) the code uses AbsTol(1) and RelTol(1) +! For Vector tolerances (ICNTRL(2) == 0) the code uses AbsTol(1:NVAR) and RelTol(1:NVAR) + IF (ICNTRL(2) == 0) THEN + VectorTol = .TRUE. + UplimTol = NVAR + ELSE + VectorTol = .FALSE. + UplimTol = 1 + END IF + +!~~~> The maximum number of steps admitted + IF (ICNTRL(3) == 0) THEN + Max_no_steps = 100000 + ELSEIF (Max_no_steps > 0) THEN + Max_no_steps=ICNTRL(3) + ELSE + PRINT * ,'User-selected max no. of steps: ICNTRL(3)=',ICNTRL(3) + CALL ros_ErrorMsg(-1,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> The particular Rosenbrock method chosen + IF (ICNTRL(4) == 0) THEN + Method = 3 + ELSEIF ( (ICNTRL(4) >= 1).AND.(ICNTRL(4) <= 5) ) THEN + Method = ICNTRL(4) + ELSE + PRINT * , 'User-selected Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END IF + +!~~~> Unit roundoff (1+Roundoff>1) + Roundoff = WLAMCH('E') + +!~~~> Lower bound on the step size: (positive value) + IF (RCNTRL(1) == ZERO) THEN + Hmin = ZERO + ELSEIF (RCNTRL(1) > ZERO) THEN + Hmin = RCNTRL(1) + ELSE + PRINT * , 'User-selected Hmin: RCNTRL(1)=', RCNTRL(1) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Upper bound on the step size: (positive value) + IF (RCNTRL(2) == ZERO) THEN + Hmax = ABS(Tend-Tstart) + ELSEIF (RCNTRL(2) > ZERO) THEN + Hmax = MIN(ABS(RCNTRL(2)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hmax: RCNTRL(2)=', RCNTRL(2) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Starting step size: (positive value) + IF (RCNTRL(3) == ZERO) THEN + Hstart = MAX(Hmin,DeltaMin) + ELSEIF (RCNTRL(3) > ZERO) THEN + Hstart = MIN(ABS(RCNTRL(3)),ABS(Tend-Tstart)) + ELSE + PRINT * , 'User-selected Hstart: RCNTRL(3)=', RCNTRL(3) + CALL ros_ErrorMsg(-3,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Step size can be changed s.t. FacMin < Hnew/Hexit < FacMax + IF (RCNTRL(4) == ZERO) THEN + FacMin = 0.2d0 + ELSEIF (RCNTRL(4) > ZERO) THEN + FacMin = RCNTRL(4) + ELSE + PRINT * , 'User-selected FacMin: RCNTRL(4)=', RCNTRL(4) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF + IF (RCNTRL(5) == ZERO) THEN + FacMax = 6.0d0 + ELSEIF (RCNTRL(5) > ZERO) THEN + FacMax = RCNTRL(5) + ELSE + PRINT * , 'User-selected FacMax: RCNTRL(5)=', RCNTRL(5) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacRej: Factor to decrease step after 2 succesive rejections + IF (RCNTRL(6) == ZERO) THEN + FacRej = 0.1d0 + ELSEIF (RCNTRL(6) > ZERO) THEN + FacRej = RCNTRL(6) + ELSE + PRINT * , 'User-selected FacRej: RCNTRL(6)=', RCNTRL(6) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> FacSafe: Safety Factor in the computation of new step size + IF (RCNTRL(7) == ZERO) THEN + FacSafe = 0.9d0 + ELSEIF (RCNTRL(7) > ZERO) THEN + FacSafe = RCNTRL(7) + ELSE + PRINT * , 'User-selected FacSafe: RCNTRL(7)=', RCNTRL(7) + CALL ros_ErrorMsg(-4,Tstart,ZERO,IERR) + RETURN + END IF +!~~~> Check if tolerances are reasonable + DO i=1,UplimTol + IF ( (AbsTol(i) <= ZERO) .OR. (RelTol(i) <= 10.d0*Roundoff) & + .OR. (RelTol(i) >= 1.0d0) ) THEN + PRINT * , ' AbsTol(',i,') = ',AbsTol(i) + PRINT * , ' RelTol(',i,') = ',RelTol(i) + CALL ros_ErrorMsg(-5,Tstart,ZERO,IERR) + RETURN + END IF + END DO + + +!~~~> Initialize the particular Rosenbrock method + SELECT CASE (Method) + CASE (1) + CALL Ros2(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (2) + CALL Ros3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (3) + CALL Ros4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (4) + CALL Rodas3(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE (5) + CALL Rodas4(ros_S, ros_A, ros_C, ros_M, ros_E, & + ros_Alpha, ros_Gamma, ros_NewF, ros_ELO, ros_Name) + CASE DEFAULT + PRINT * , 'Unknown Rosenbrock method: ICNTRL(4)=', Method + CALL ros_ErrorMsg(-2,Tstart,ZERO,IERR) + RETURN + END SELECT + +!~~~> CALL Rosenbrock method + CALL ros_TLM_Int(Y, NTLM, Y_tlm, & + Tstart, Tend, Texit, & + AbsTol, RelTol, & +! Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +! Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +! Error indicator + IERR) + + +!~~~> Collect run statistics + ISTATUS(ifun) = Nfun + ISTATUS(ijac) = Njac + ISTATUS(istp) = Nstp + ISTATUS(iacc) = Nacc + ISTATUS(irej) = Nrej + ISTATUS(idec) = Ndec + ISTATUS(isol) = Nsol + ISTATUS(isng) = Nsng +!~~~> Last T and H + RSTATUS(itexit) = Texit + RSTATUS(ihexit) = Hexit + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +END SUBROUTINE RosenbrockTLM +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_ErrorMsg(Code,T,H,IERR) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Handles all error messages +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL, INTENT(IN) :: T, H + INTEGER, INTENT(IN) :: Code + INTEGER, INTENT(OUT) :: IERR + + IERR = Code + PRINT * , & + 'Forced exit from Rosenbrock due to the following error:' + + SELECT CASE (Code) + CASE (-1) + PRINT * , '--> Improper value for maximal no of steps' + CASE (-2) + PRINT * , '--> Selected Rosenbrock method not implemented' + CASE (-3) + PRINT * , '--> Hmin/Hmax/Hstart must be positive' + CASE (-4) + PRINT * , '--> FacMin/FacMax/FacRej must be positive' + CASE (-5) + PRINT * , '--> Improper tolerance values' + CASE (-6) + PRINT * , '--> No of steps exceeds maximum bound' + CASE (-7) + PRINT * , '--> Step size too small: T + 10*H = T', & + ' or H < Roundoff' + CASE (-8) + PRINT * , '--> Matrix is repeatedly singular' + CASE DEFAULT + PRINT *, 'Unknown Error code: ', Code + END SELECT + + PRINT *, "T=", T, "and H=", H + + END SUBROUTINE ros_ErrorMsg + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_TLM_Int (Y, NTLM, Y_tlm, & + Tstart, Tend, T, & + AbsTol, RelTol, & +!~~~> Rosenbrock method coefficients + ros_S, ros_M, ros_E, ros_A, ros_C, & + ros_Alpha, ros_Gamma, ros_ELO, ros_NewF, & +!~~~> Integration parameters + Autonomous, VectorTol, Max_no_steps, & + Roundoff, Hmin, Hmax, Hstart, Hexit, & + FacMin, FacMax, FacRej, FacSafe, & +!~~~> Error indicator + IERR ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the implementation of a generic Rosenbrock method +! defined by ros_S (no of stages) +! and its coefficients ros_{A,C,M,E,Alpha,Gamma} +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + +!~~~> Input: the initial condition at Tstart; Output: the solution at T + KPP_REAL, INTENT(INOUT) :: Y(NVAR) +!~~~> Input: Number of sensitivity coefficients + INTEGER, INTENT(IN) :: NTLM +!~~~> Input: the initial sensitivites at Tstart; Output: the sensitivities at T + KPP_REAL, INTENT(INOUT) :: Y_tlm(NVAR,NTLM) +!~~~> Input: integration interval + KPP_REAL, INTENT(IN) :: Tstart,Tend +!~~~> Output: time at which the solution is returned (T=Tend if success) + KPP_REAL, INTENT(OUT) :: T +!~~~> Input: tolerances + KPP_REAL, INTENT(IN) :: AbsTol(NVAR), RelTol(NVAR) +!~~~> Input: The Rosenbrock method parameters + INTEGER, INTENT(IN) :: ros_S + KPP_REAL, INTENT(IN) :: ros_M(ros_S), ros_E(ros_S), & + ros_Alpha(ros_S), ros_A(ros_S*(ros_S-1)/2), & + ros_Gamma(ros_S), ros_C(ros_S*(ros_S-1)/2), ros_ELO + LOGICAL, INTENT(IN) :: ros_NewF(ros_S) +!~~~> Input: integration parameters + LOGICAL, INTENT(IN) :: Autonomous, VectorTol + KPP_REAL, INTENT(IN) :: Hstart, Hmin, Hmax + INTEGER, INTENT(IN) :: Max_no_steps + KPP_REAL, INTENT(IN) :: Roundoff, FacMin, FacMax, FacRej, FacSafe +!~~~> Output: last accepted step + KPP_REAL, INTENT(OUT) :: Hexit +!~~~> Output: Error indicator + INTEGER, INTENT(OUT) :: IERR +! ~~~~ Local variables + KPP_REAL :: Ynew(NVAR), Fcn0(NVAR), Fcn(NVAR) + KPP_REAL :: K(NVAR*ros_S) + KPP_REAL :: Ynew_tlm(NVAR,NTLM), Fcn0_tlm(NVAR,NTLM), Fcn_tlm(NVAR,NTLM) + KPP_REAL :: K_tlm(NVAR*ros_S,NTLM) + KPP_REAL :: Hes0(NHESS) + KPP_REAL :: dFdT(NVAR), dJdT(LU_NONZERO) + KPP_REAL :: Jac0(LU_NONZERO), Jac(LU_NONZERO), Ghimj(LU_NONZERO) + KPP_REAL :: H, Hnew, HC, HG, Fac, Tau + KPP_REAL :: Err, Yerr(NVAR) + INTEGER :: Pivot(NVAR), Direction, ioffset, i, j, istage, itlm + LOGICAL :: RejectLastH, RejectMoreH, Singular +!~~~> Local parameters + KPP_REAL, PARAMETER :: ZERO = 0.0d0, ONE = 1.0d0 + KPP_REAL, PARAMETER :: DeltaMin = 1.0d-5 +!~~~> Locally called functions +! KPP_REAL WLAMCH +! EXTERNAL WLAMCH +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~> Initial preparations + T = Tstart + Hexit = 0.0_dp + H = MIN(Hstart,Hmax) + IF (ABS(H) <= 10.D0*Roundoff) H = DeltaMin + + IF (Tend >= Tstart) THEN + Direction = +1 + ELSE + Direction = -1 + END IF + + RejectLastH=.FALSE. + RejectMoreH=.FALSE. + +!~~~> Time loop begins below + +TimeLoop: DO WHILE ( (Direction > 0).AND.((T-Tend)+Roundoff <= ZERO) & + .OR. (Direction < 0).AND.((Tend-T)+Roundoff <= ZERO) ) + + IF ( Nstp > Max_no_steps ) THEN ! Too many steps + CALL ros_ErrorMsg(-6,T,H,IERR) + RETURN + END IF + IF ( ((T+0.1d0*H) == T).OR.(H <= Roundoff) ) THEN ! Step size too small + CALL ros_ErrorMsg(-7,T,H,IERR) + RETURN + END IF + +!~~~> Limit H if necessary to avoid going beyond Tend + Hexit = H + H = MIN(H,ABS(Tend-T)) + +!~~~> Compute the function at current time + CALL FunTemplate(T,Y,Fcn0) + +!~~~> Compute the Jacobian at current time + CALL JacTemplate(T,Y,Jac0) + +!~~~> Compute the Hessian at current time + CALL HessTemplate(T,Y,Hes0) + +!~~~> Compute the TLM function at current time + DO itlm = 1, NTLM + CALL Jac_SP_Vec ( Jac0, Y_tlm(1,itlm), Fcn0_tlm(1,itlm) ) + END DO + +!~~~> Compute the function and Jacobian derivatives with respect to T + IF (.NOT.Autonomous) THEN + CALL ros_FunTimeDerivative ( T, Roundoff, Y, Fcn0, dFdT ) + CALL ros_JacTimeDerivative ( T, Roundoff, Y, Jac0, dJdT ) + END IF + +!~~~> Repeat step calculation until current step accepted +UntilAccepted: DO + + CALL ros_PrepareMatrix(H,Direction,ros_Gamma(1),& + Jac0,Ghimj,Pivot,Singular) + IF (Singular) THEN ! More than 5 consecutive failed decompositions + CALL ros_ErrorMsg(-8,T,H,IERR) + RETURN + END IF + +!~~~> Compute the stages +Stage: DO istage = 1, ros_S + + ! Current istage offset. Current istage vector is K(ioffset+1:ioffset+NVAR) + ioffset = NVAR*(istage-1) + + ! For the 1st istage the function has been computed previously + IF ( istage == 1 ) THEN + CALL WCOPY(NVAR,Fcn0,1,Fcn,1) + CALL WCOPY(NVAR*NTLM,Fcn0_tlm,1,Fcn_tlm,1) + ! istage>1 and a new function evaluation is needed at the current istage + ELSEIF ( ros_NewF(istage) ) THEN + CALL WCOPY(NVAR,Y,1,Ynew,1) + CALL WCOPY(NVAR*NTLM,Y_tlm,1,Ynew_tlm,1) + DO j = 1, istage-1 + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K(NVAR*(j-1)+1),1,Ynew,1) + DO itlm=1,NTLM + CALL WAXPY(NVAR,ros_A((istage-1)*(istage-2)/2+j), & + K_tlm(NVAR*(j-1)+1,itlm),1,Ynew_tlm(1,itlm),1) + END DO + END DO + Tau = T + ros_Alpha(istage)*Direction*H + CALL FunTemplate(Tau,Ynew,Fcn) + CALL JacTemplate(Tau,Ynew,Jac) + DO itlm=1,NTLM + CALL Jac_SP_Vec ( Jac, Ynew_tlm(1,itlm), Fcn_tlm(1,itlm) ) + END DO + END IF ! if istage == 1 elseif ros_NewF(istage) + CALL WCOPY(NVAR,Fcn,1,K(ioffset+1),1) + DO itlm=1,NTLM + CALL WCOPY(NVAR,Fcn_tlm(1,itlm),1,K_tlm(ioffset+1,itlm),1) + END DO + DO j = 1, istage-1 + HC = ros_C((istage-1)*(istage-2)/2+j)/(Direction*H) + CALL WAXPY(NVAR,HC,K(NVAR*(j-1)+1),1,K(ioffset+1),1) + DO itlm=1,NTLM + CALL WAXPY(NVAR,HC,K_tlm(NVAR*(j-1)+1,itlm),1,K_tlm(ioffset+1,itlm),1) + END DO + END DO + IF ((.NOT. Autonomous).AND.(ros_Gamma(istage).NE.ZERO)) THEN + HG = Direction*H*ros_Gamma(istage) + CALL WAXPY(NVAR,HG,dFdT,1,K(ioffset+1),1) + DO itlm=1,NTLM + CALL Jac_SP_Vec ( dJdT, Ynew_tlm(1,itlm), Fcn_tlm(1,itlm) ) + CALL WAXPY(NVAR,HG,Fcn_tlm(1,itlm),1,K_tlm(ioffset+1,itlm),1) + END DO + END IF + CALL ros_Solve(Ghimj, Pivot, K(ioffset+1)) + DO itlm=1,NTLM + CALL Hess_Vec ( Hes0, K(ioffset+1), Y_tlm(1,itlm), Fcn_tlm(1,itlm) ) + CALL WAXPY(NVAR,ONE,Fcn_tlm(1,itlm),1,K_tlm(ioffset+1,itlm),1) + CALL ros_Solve(Ghimj, Pivot, K_tlm(ioffset+1,itlm)) + END DO + + END DO Stage + + +!~~~> Compute the new solution + CALL WCOPY(NVAR,Y,1,Ynew,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K(NVAR*(j-1)+1),1,Ynew,1) + END DO + DO itlm=1,NTLM + CALL WCOPY(NVAR,Y_tlm(1,itlm),1,Ynew_tlm(1,itlm),1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_M(j),K_tlm(NVAR*(j-1)+1,itlm),1,Ynew_tlm(1,itlm),1) + END DO + END DO + +!~~~> Compute the error estimation + CALL WSCAL(NVAR,ZERO,Yerr,1) + DO j=1,ros_S + CALL WAXPY(NVAR,ros_E(j),K(NVAR*(j-1)+1),1,Yerr,1) + END DO + Err = ros_ErrorNorm ( Y, Ynew, Yerr, AbsTol, RelTol, VectorTol ) + +!~~~> New step size is bounded by FacMin <= Hnew/H <= FacMax + Fac = MIN(FacMax,MAX(FacMin,FacSafe/Err**(ONE/ros_ELO))) + Hnew = H*Fac + +!~~~> Check the error magnitude and adjust step size + Nstp = Nstp+1 + IF ( (Err <= ONE).OR.(H <= Hmin) ) THEN !~~~> Accept step + Nacc = Nacc+1 + CALL WCOPY(NVAR,Ynew,1,Y,1) + CALL WCOPY(NVAR*NTLM,Ynew_tlm,1,Y_tlm,1) + T = T + Direction*H + Hnew = MAX(Hmin,MIN(Hnew,Hmax)) + IF (RejectLastH) THEN ! No step size increase after a rejected step + Hnew = MIN(Hnew,H) + END IF + RejectLastH = .FALSE. + RejectMoreH = .FALSE. + H = Hnew + EXIT UntilAccepted ! EXIT THE LOOP: WHILE STEP NOT ACCEPTED + ELSE !~~~> Reject step + IF (RejectMoreH) THEN + Hnew = H*FacRej + END IF + RejectMoreH = RejectLastH + RejectLastH = .TRUE. + H = Hnew + IF (Nacc >= 1) THEN + Nrej = Nrej+1 + END IF + END IF ! Err <= 1 + + END DO UntilAccepted + + END DO TimeLoop + +!~~~> Succesful exit + IERR = 1 !~~~> The integration was successful + + END SUBROUTINE ros_TLM_Int + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + KPP_REAL FUNCTION ros_ErrorNorm ( Y, Ynew, Yerr, & + AbsTol, RelTol, VectorTol ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> Computes the "scaled norm" of the error vector Yerr +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +! Input arguments + KPP_REAL, INTENT(IN) :: Y(NVAR), Ynew(NVAR), & + Yerr(NVAR), AbsTol(NVAR), RelTol(NVAR) + LOGICAL, INTENT(IN) :: VectorTol +! Local variables + KPP_REAL :: Err, Scale, Ymax + INTEGER :: i + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + + Err = ZERO + DO i=1,NVAR + Ymax = MAX(ABS(Y(i)),ABS(Ynew(i))) + IF (VectorTol) THEN + Scale = AbsTol(i)+RelTol(i)*Ymax + ELSE + Scale = AbsTol(1)+RelTol(1)*Ymax + END IF + Err = Err+(Yerr(i)/Scale)**2 + END DO + Err = SQRT(Err/NVAR) + + ros_ErrorNorm = Err + + END FUNCTION ros_ErrorNorm + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_FunTimeDerivative ( T, Roundoff, Y, & + Fcn0, dFdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the function by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Fcn0(NVAR) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dFdT(NVAR) +!~~~> Local variables + KPP_REAL :: Delta + KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL FunTemplate(T+Delta,Y,dFdT) + CALL WAXPY(NVAR,(-ONE),Fcn0,1,dFdT,1) + CALL WSCAL(NVAR,(ONE/Delta),dFdT,1) + + END SUBROUTINE ros_FunTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_JacTimeDerivative ( T, Roundoff, Y, & + Jac0, dJdT ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~> The time partial derivative of the Jacobian by finite differences +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: T, Roundoff, Y(NVAR), Jac0(LU_NONZERO) +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: dJdT(LU_NONZERO) +!~~~> Local variables + KPP_REAL Delta + KPP_REAL, PARAMETER :: ONE = 1.0d0, DeltaMin = 1.0d-6 + + Delta = SQRT(Roundoff)*MAX(DeltaMin,ABS(T)) + CALL JacTemplate(T+Delta,Y,dJdT) + CALL WAXPY(LU_NONZERO,(-ONE),Jac0,1,dJdT,1) + CALL WSCAL(LU_NONZERO,(ONE/Delta),dJdT,1) + + END SUBROUTINE ros_JacTimeDerivative + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_PrepareMatrix ( H, Direction, gam, & + Jac0, Ghimj, Pivot, Singular ) +! --- --- --- --- --- --- --- --- --- --- --- --- --- +! Prepares the LHS matrix for stage calculations +! 1. Construct Ghimj = 1/(H*ham) - Jac0 +! "(Gamma H) Inverse Minus Jacobian" +! 2. Repeat LU decomposition of Ghimj until successful. +! -half the step size if LU decomposition fails and retry +! -exit after 5 consecutive fails +! --- --- --- --- --- --- --- --- --- --- --- --- --- + IMPLICIT NONE + +!~~~> Input arguments + KPP_REAL, INTENT(IN) :: gam, Jac0(LU_NONZERO) + INTEGER, INTENT(IN) :: Direction +!~~~> Output arguments + KPP_REAL, INTENT(OUT) :: Ghimj(LU_NONZERO) + LOGICAL, INTENT(OUT) :: Singular + INTEGER, INTENT(OUT) :: Pivot(NVAR) +!~~~> Inout arguments + KPP_REAL, INTENT(INOUT) :: H ! step size is decreased when LU fails +!~~~> Local variables + INTEGER :: i, ising, Nconsecutive + KPP_REAL :: ghinv + KPP_REAL, PARAMETER :: ONE = 1.0d0, HALF = 0.5d0 + + Nconsecutive = 0 + Singular = .TRUE. + + DO WHILE (Singular) + +!~~~> Construct Ghimj = 1/(H*ham) - Jac0 + CALL WCOPY(LU_NONZERO,Jac0,1,Ghimj,1) + CALL WSCAL(LU_NONZERO,(-ONE),Ghimj,1) + ghinv = ONE/(Direction*H*gam) + DO i=1,NVAR + Ghimj(LU_DIAG(i)) = Ghimj(LU_DIAG(i))+ghinv + END DO +!~~~> Compute LU decomposition + CALL ros_Decomp( Ghimj, Pivot, ising ) + IF (ising == 0) THEN +!~~~> If successful done + Singular = .FALSE. + ELSE ! ising .ne. 0 +!~~~> If unsuccessful half the step size; if 5 consecutive fails then return + Nsng = Nsng+1 + Nconsecutive = Nconsecutive+1 + Singular = .TRUE. + PRINT*,'Warning: LU Decomposition returned ising = ',ising + IF (Nconsecutive <= 5) THEN ! Less than 5 consecutive failed decompositions + H = H*HALF + ELSE ! More than 5 consecutive failed decompositions + RETURN + END IF ! Nconsecutive + END IF ! ising + + END DO ! WHILE Singular + + END SUBROUTINE ros_PrepareMatrix + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Decomp( A, Pivot, ising ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the LU decomposition +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Inout variables + KPP_REAL, INTENT(INOUT) :: A(LU_NONZERO) +!~~~> Output variables + INTEGER, INTENT(OUT) :: Pivot(NVAR), ising + + CALL KppDecomp ( A, ising ) +!~~~> Note: for a full matrix use Lapack: +! CALL DGETRF( NVAR, NVAR, A, NVAR, Pivot, ising ) + Pivot(1) = 1 + + Ndec = Ndec + 1 + + END SUBROUTINE ros_Decomp + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE ros_Solve( A, Pivot, b ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the forward/backward substitution (using pre-computed LU decomposition) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~> Input variables + KPP_REAL, INTENT(IN) :: A(LU_NONZERO) + INTEGER, INTENT(IN) :: Pivot(NVAR) +!~~~> InOut variables + KPP_REAL, INTENT(INOUT) :: b(NVAR) + + CALL KppSolve( A, b ) +!~~~> Note: for a full matrix use Lapack: +! NRHS = 1 +! CALL DGETRS( 'N', NVAR , NRHS, A, NVAR, Pivot, b, NVAR, INFO ) + + Nsol = Nsol+1 + + END SUBROUTINE ros_Solve + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros2 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 2 stages, order 2 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 2 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + + g = 1.0d0 + 1.0d0/SQRT(2.0d0) + +!~~~> Name of the method + ros_Name = 'ROS-2' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = (1.d0)/g + ros_C(1) = (-2.d0)/g +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1)= (3.d0)/(2.d0*g) + ros_M(2)= (1.d0)/(2.d0*g) +! E_i = Coefficients for error estimator + ros_E(1) = 1.d0/(2.d0*g) + ros_E(2) = 1.d0/(2.d0*g) +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus one + ros_ELO = 2.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d0 + ros_Alpha(2) = 1.0d0 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = g + ros_Gamma(2) =-g + + END SUBROUTINE Ros2 + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- AN L-STABLE METHOD, 3 stages, order 3, 2 function evaluations +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 3 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + +!~~~> Name of the method + ros_Name = 'ROS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1)= 1.d0 + ros_A(2)= 1.d0 + ros_A(3)= 0.d0 + + ros_C(1) = -0.10156171083877702091975600115545d+01 + ros_C(2) = 0.40759956452537699824805835358067d+01 + ros_C(3) = 0.92076794298330791242156818474003d+01 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.1d+01 + ros_M(2) = 0.61697947043828245592553615689730d+01 + ros_M(3) = -0.42772256543218573326238373806514d+00 +! E_i = Coefficients for error estimator + ros_E(1) = 0.5d+00 + ros_E(2) = -0.29079558716805469821718236208017d+01 + ros_E(3) = 0.22354069897811569627360909276199d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1)= 0.0d+00 + ros_Alpha(2)= 0.43586652150845899941601945119356d+00 + ros_Alpha(3)= 0.43586652150845899941601945119356d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1)= 0.43586652150845899941601945119356d+00 + ros_Gamma(2)= 0.24291996454816804366592249683314d+00 + ros_Gamma(3)= 0.21851380027664058511513169485832d+01 + + END SUBROUTINE Ros3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Ros4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! L-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 4 STAGES +! L-STABLE EMBEDDED ROSENBROCK METHOD OF ORDER 3 +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1990) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'ROS-4' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.2000000000000000d+01 + ros_A(2) = 0.1867943637803922d+01 + ros_A(3) = 0.2344449711399156d+00 + ros_A(4) = ros_A(2) + ros_A(5) = ros_A(3) + ros_A(6) = 0.0D0 + + ros_C(1) =-0.7137615036412310d+01 + ros_C(2) = 0.2580708087951457d+01 + ros_C(3) = 0.6515950076447975d+00 + ros_C(4) =-0.2137148994382534d+01 + ros_C(5) =-0.3214669691237626d+00 + ros_C(6) =-0.6949742501781779d+00 +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .FALSE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 0.2255570073418735d+01 + ros_M(2) = 0.2870493262186792d+00 + ros_M(3) = 0.4353179431840180d+00 + ros_M(4) = 0.1093502252409163d+01 +!~~~> E_i = Coefficients for error estimator + ros_E(1) =-0.2815431932141155d+00 + ros_E(2) =-0.7276199124938920d-01 + ros_E(3) =-0.1082196201495311d+00 + ros_E(4) =-0.1093502252409163d+01 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.D0 + ros_Alpha(2) = 0.1145640000000000d+01 + ros_Alpha(3) = 0.6552168638155900d+00 + ros_Alpha(4) = ros_Alpha(3) +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5728200000000000d+00 + ros_Gamma(2) =-0.1769193891319233d+01 + ros_Gamma(3) = 0.7592633437920482d+00 + ros_Gamma(4) =-0.1049021087100450d+00 + + END SUBROUTINE Ros4 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas3 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! --- A STIFFLY-STABLE METHOD, 4 stages, order 3 +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 4 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-3' +!~~~> Number of stages + ros_S = S + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: +! A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.0d+00 + ros_A(2) = 2.0d+00 + ros_A(3) = 0.0d+00 + ros_A(4) = 2.0d+00 + ros_A(5) = 0.0d+00 + ros_A(6) = 1.0d+00 + + ros_C(1) = 4.0d+00 + ros_C(2) = 1.0d+00 + ros_C(3) =-1.0d+00 + ros_C(4) = 1.0d+00 + ros_C(5) =-1.0d+00 + ros_C(6) =-(8.0d+00/3.0d+00) + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .FALSE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. +!~~~> M_i = Coefficients for new step solution + ros_M(1) = 2.0d+00 + ros_M(2) = 0.0d+00 + ros_M(3) = 1.0d+00 + ros_M(4) = 1.0d+00 +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 1.0d+00 +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 3.0d+00 +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.0d+00 + ros_Alpha(2) = 0.0d+00 + ros_Alpha(3) = 1.0d+00 + ros_Alpha(4) = 1.0d+00 +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.5d+00 + ros_Gamma(2) = 1.5d+00 + ros_Gamma(3) = 0.0d+00 + ros_Gamma(4) = 0.0d+00 + + END SUBROUTINE Rodas3 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE Rodas4 (ros_S,ros_A,ros_C,ros_M,ros_E,ros_Alpha,& + ros_Gamma,ros_NewF,ros_ELO,ros_Name) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! STIFFLY-STABLE ROSENBROCK METHOD OF ORDER 4, WITH 6 STAGES +! +! E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL +! EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. +! SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS, +! SPRINGER-VERLAG (1996) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE + + INTEGER, PARAMETER :: S = 6 + INTEGER, INTENT(OUT) :: ros_S + KPP_REAL, DIMENSION(S), INTENT(OUT) :: ros_M,ros_E,ros_Alpha,ros_Gamma + KPP_REAL, DIMENSION(S*(S-1)/2), INTENT(OUT) :: ros_A, ros_C + KPP_REAL, INTENT(OUT) :: ros_ELO + LOGICAL, DIMENSION(S), INTENT(OUT) :: ros_NewF + CHARACTER(LEN=12), INTENT(OUT) :: ros_Name + DOUBLE PRECISION g + +!~~~> Name of the method + ros_Name = 'RODAS-4' +!~~~> Number of stages + ros_S = S + +!~~~> Y_stage_i ~ Y( T + H*Alpha_i ) + ros_Alpha(1) = 0.000d0 + ros_Alpha(2) = 0.386d0 + ros_Alpha(3) = 0.210d0 + ros_Alpha(4) = 0.630d0 + ros_Alpha(5) = 1.000d0 + ros_Alpha(6) = 1.000d0 + +!~~~> Gamma_i = \sum_j gamma_{i,j} + ros_Gamma(1) = 0.2500000000000000d+00 + ros_Gamma(2) =-0.1043000000000000d+00 + ros_Gamma(3) = 0.1035000000000000d+00 + ros_Gamma(4) =-0.3620000000000023d-01 + ros_Gamma(5) = 0.0d0 + ros_Gamma(6) = 0.0d0 + +!~~~> The coefficient matrices A and C are strictly lower triangular. +! The lower triangular (subdiagonal) elements are stored in row-wise order: +! A(2,1) = ros_A(1), A(3,1)=ros_A(2), A(3,2)=ros_A(3), etc. +! The general mapping formula is: A(i,j) = ros_A( (i-1)*(i-2)/2 + j ) +! C(i,j) = ros_C( (i-1)*(i-2)/2 + j ) + + ros_A(1) = 0.1544000000000000d+01 + ros_A(2) = 0.9466785280815826d+00 + ros_A(3) = 0.2557011698983284d+00 + ros_A(4) = 0.3314825187068521d+01 + ros_A(5) = 0.2896124015972201d+01 + ros_A(6) = 0.9986419139977817d+00 + ros_A(7) = 0.1221224509226641d+01 + ros_A(8) = 0.6019134481288629d+01 + ros_A(9) = 0.1253708332932087d+02 + ros_A(10) =-0.6878860361058950d+00 + ros_A(11) = ros_A(7) + ros_A(12) = ros_A(8) + ros_A(13) = ros_A(9) + ros_A(14) = ros_A(10) + ros_A(15) = 1.0d+00 + + ros_C(1) =-0.5668800000000000d+01 + ros_C(2) =-0.2430093356833875d+01 + ros_C(3) =-0.2063599157091915d+00 + ros_C(4) =-0.1073529058151375d+00 + ros_C(5) =-0.9594562251023355d+01 + ros_C(6) =-0.2047028614809616d+02 + ros_C(7) = 0.7496443313967647d+01 + ros_C(8) =-0.1024680431464352d+02 + ros_C(9) =-0.3399990352819905d+02 + ros_C(10) = 0.1170890893206160d+02 + ros_C(11) = 0.8083246795921522d+01 + ros_C(12) =-0.7981132988064893d+01 + ros_C(13) =-0.3152159432874371d+02 + ros_C(14) = 0.1631930543123136d+02 + ros_C(15) =-0.6058818238834054d+01 + +!~~~> M_i = Coefficients for new step solution + ros_M(1) = ros_A(7) + ros_M(2) = ros_A(8) + ros_M(3) = ros_A(9) + ros_M(4) = ros_A(10) + ros_M(5) = 1.0d+00 + ros_M(6) = 1.0d+00 + +!~~~> E_i = Coefficients for error estimator + ros_E(1) = 0.0d+00 + ros_E(2) = 0.0d+00 + ros_E(3) = 0.0d+00 + ros_E(4) = 0.0d+00 + ros_E(5) = 0.0d+00 + ros_E(6) = 1.0d+00 + +!~~~> Does the stage i require a new function evaluation (ros_NewF(i)=TRUE) +! or does it re-use the function evaluation from stage i-1 (ros_NewF(i)=FALSE) + ros_NewF(1) = .TRUE. + ros_NewF(2) = .TRUE. + ros_NewF(3) = .TRUE. + ros_NewF(4) = .TRUE. + ros_NewF(5) = .TRUE. + ros_NewF(6) = .TRUE. + +!~~~> ros_ELO = estimator of local order - the minimum between the +! main and the embedded scheme orders plus 1 + ros_ELO = 4.0d0 + + END SUBROUTINE Rodas4 + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE FunTemplate( T, Y, Ydot ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE function call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + IMPLICIT NONE +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Ydot(NVAR) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, Ydot ) + TIME = Told + + Nfun = Nfun+1 + +END SUBROUTINE FunTemplate + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE JacTemplate( T, Y, Jcb ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Jacobian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Jcb(LU_NONZERO) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, Jcb ) + TIME = Told + + Njac = Njac+1 + +END SUBROUTINE JacTemplate + + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE HessTemplate( T, Y, Hes ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Template for the ODE Hessian call. +! Updates the rate coefficients (and possibly the fixed species) at each call +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE + +!~~~> Input variables + KPP_REAL T, Y(NVAR) +!~~~> Output variables + KPP_REAL Hes(NHESS) +!~~~> Local variables + KPP_REAL Told + + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Hessian( Y, FIX, RCONST, Hes ) + TIME = Told + +END SUBROUTINE HessTemplate + +END MODULE KPP_ROOT_Integrator + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.def new file mode 100755 index 00000000..b77434ba --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.def @@ -0,0 +1,20 @@ + +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE sdirk + +#INLINE F77_GLOBAL + REAL*8 STEPSTART + COMMON /GDATA/ STEPSTART +#ENDINLINE + +#INLINE F77_INIT + STEPMIN=0.0001 + STEPMAX=3600. + STEPSTART=STEPMIN +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.f new file mode 100755 index 00000000..3c851dfc --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/sdirk.f @@ -0,0 +1,705 @@ + SUBROUTINE INTEGRATE( TIN, TOUT ) + + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + +C TIN - Start Time + KPP_REAL TIN +C TOUT - End Time + KPP_REAL TOUT + INTEGER i + + PARAMETER (LWORK=2*NVAR*NVAR+12*NVAR+7,LIWORK=2*NVAR+7) + PARAMETER (LRCONT=5*NVAR+2) + + KPP_REAL WORK(LWORK) + INTEGER IWORK(LIWORK) + COMMON /CONT/ ICONT(4),RCONT(LRCONT) + EXTERNAL FUNC_CHEM,JAC_CHEM + + ITOL=1 ! --- VECTOR TOLERANCES + IJAC=1 ! --- COMPUTE THE JACOBIAN ANALYTICALLY + IMAS=0 ! --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM + + DO i=1,20 + IWORK(i) = 0 + WORK(i) = 0.D0 + ENDDO + + IWORK(3) = 8 + + CALL ATMSDIRK(NVAR,FUNC_CHEM,TIN,VAR,TOUT,STEPMIN, + & RTOL,ATOL,ITOL, + & JAC_CHEM ,IJAC, FUNC_CHEM ,IMAS, + & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) + + IF (IDID.LT.0) THEN + print *,'ATMSDIRK: Unsucessfull exit at T=', + & TIN,' (IDID=',IDID,')' + ENDIF + + RETURN + END + + + SUBROUTINE ATMSDIRK(N,FCN,X,Y,XEND,H, + & RelTol,AbsTol,ITOL, + & JAC ,IJAC, MAS ,IMAS, + & WORK,LWORK,IWORK,LIWORK,LRCONT,IDID) +C ---------------------------------------------------------- +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C DECLARATIONS +C *** *** *** *** *** *** *** *** *** *** *** *** *** + IMPLICIT KPP_REAL (A-H,O-Z) + DIMENSION Y(N),AbsTol(1),RelTol(1),WORK(LWORK),IWORK(LIWORK) + LOGICAL IMPLCT,JBAND,ARRET + EXTERNAL FCN,JAC,MAS + COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL + +C *** *** *** *** *** *** *** +C SETTING THE PARAMETERS +C *** *** *** *** *** *** *** + NFCN=0 + NJAC=0 + NSTEP=0 + NACCPT=0 + NREJCT=0 + NDEC=0 + NSOL=0 + ARRET=.FALSE. +C -------- SWITCH FOR TRANSFORMATION OF JACOBIAN TO HESS_CHEM FORM --- + NHESS1 = 0 ! ADRIAN +C -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- + IF(IWORK(2).EQ.0)THEN + NMAX=100000 + ELSE + NMAX=IWORK(2) + IF(NMAX.LE.0)THEN + WRITE(6,*)' WRONG INPUT IWORK(2)=',IWORK(2) + ARRET=.TRUE. + END IF + END IF +C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS + IF(IWORK(3).EQ.0)THEN + NIT=8 + ELSE + NIT=IWORK(3) + IF(NIT.LE.0)THEN + WRITE(6,*)' CURIOUS INPUT IWORK(3)=',IWORK(3) + ARRET=.TRUE. + END IF + END IF +C -------- METH SWITCH FOR THE COEFFICIENTS OF THE METHOD + METH = 2 +C -------- UROUND SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0 + IF(WORK(1).EQ.0.D0)THEN + UROUND=1.D-16 + ELSE + UROUND=WORK(1) + IF(UROUND.LE.1.D-19.OR.UROUND.GE.1.D0)THEN + WRITE(6,*)' COEFFICIENTS HAVE 20 DIGITS, UROUND=',WORK(1) + ARRET=.TRUE. + END IF + END IF +C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION + IF(WORK(2).EQ.0.D0)THEN + SAFE=0.9D0 + ELSE + SAFE=WORK(2) + IF(SAFE.LE..001D0.OR.SAFE.GE.1.D0)THEN + WRITE(6,*)' CURIOUS INPUT FOR WORK(2)=',WORK(2) + ARRET=.TRUE. + END IF + END IF +C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; + IF(WORK(3).EQ.0.D0)THEN + THET=0.001D0 + ELSE + THET=WORK(3) + END IF +C --- FNEWT STOPPING CRIERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. + IF(WORK(4).EQ.0.D0)THEN + FNEWT=0.03D0 + ELSE + FNEWT=WORK(4) + END IF +C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. + IF(WORK(5).EQ.0.D0)THEN + QUOT1=1.D0 + ELSE + QUOT1=WORK(5) + END IF + IF(WORK(6).EQ.0.D0)THEN + QUOT2=1.2D0 + ELSE + QUOT2=WORK(6) + END IF +C -------- MAXIMAL STEP SIZE + IF(WORK(7).EQ.0.D0)THEN + HMAX=XEND-X + ELSE + HMAX=WORK(7) + END IF +C --------- CHECK IF TOLERANCES ARE O.K. + IF (ITOL.EQ.0) THEN + IF (AbsTol(1).LE.0.D0.OR.RelTol(1).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES ARE TOO SMALL' + ARRET=.TRUE. + END IF + ELSE + DO 15 I=1,N + IF (AbsTol(I).LE.0.D0.OR.RelTol(I).LE.10.D0*UROUND) THEN + WRITE (6,*) ' TOLERANCES(',I,') ARE TOO SMALL' + ARRET=.TRUE. + END IF + 15 CONTINUE + END IF + +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C COMPUTATION OF ARRAY ENTRIES +C *** *** *** *** *** *** *** *** *** *** *** *** *** +C ---- IMPLICIT, BANDED OR NOT ? + IMPLCT=IMAS.NE.0 + ARRET=.FALSE. +C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- +C -- JACOBIAN + LDJAC=N +C -- MATRIX E FOR LINEAR ALGEBRA + LDE=N +C -- MASS MATRIX + IF (IMPLCT) THEN + print *,'IMPLCT 1' + ELSE + LDMAS=0 + END IF + LDMAS2=MAX(1,LDMAS) + +C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- + IEYHAT=8 + IEZ=IEYHAT+N + IEY0=IEZ+N + IEZ1=IEY0+N + IEZ2=IEZ1+N + IEZ3=IEZ2+N + IEZ4=IEZ3+N + IEZ5=IEZ4+N + IESCAL=IEZ5+N + IEF1=IESCAL+N + IEG1=IEF1+N + IEH1=IEG1+N + IEJAC=IEH1+N + IEMAS=IEJAC+N*LDJAC + IEE=IEMAS+N*LDMAS + +C ------ TOTAL STORAGE REQUIREMENT ----------- + ISTORE=IEE+N*LDE-1 + IF(ISTORE.GT.LWORK)THEN + WRITE(6,*)' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE + ARRET=.TRUE. + END IF +C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- + IEIP=5 + IEHES=IEIP+N +C --------- TOTAL REQUIREMENT --------------- + ISTORE=IEHES+N-1 + IF(ISTORE.GT.LIWORK)THEN + WRITE(6,*)' INSUFF. STORAGE FOR IWORK, MIN. LIWORK=',ISTORE + ARRET=.TRUE. + END IF +C --------- CONTROL OF LENGTH OF COMMON BLOCK "CONT" ------- + IF(LRCONT.LT.(5*N+2))THEN + WRITE(6,*)' INSUFF. STORAGE FOR RCONT, MIN. LRCONT=',5*N+2 + ARRET=.TRUE. + END IF +C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 + IF (ARRET) THEN + IDID=-1 + RETURN + END IF +C -------- CALL TO CORE INTEGRATOR ------------ + CALL SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, + & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, + & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, + & IMPLCT,JBAND,LDJAC,LDE,LDMAS2, + & WORK(IEYHAT),WORK(IEZ),WORK(IEY0),WORK(IEZ1),WORK(IEZ2), + & WORK(IEZ3),WORK(IEZ4),WORK(IEZ5),WORK(IESCAL),WORK(IEF1), + & WORK(IEG1),WORK(IEH1),WORK(IEJAC),WORK(IEE), + & WORK(IEMAS),IWORK(IEIP),IWORK(IEHES)) +C ----------- RETURN ----------- + RETURN + END +C +C +C +C ----- ... AND HERE IS THE CORE INTEGRATOR ---------- +C + SUBROUTINE SDICOR(N,FCN,X,Y,XEND,HMAX,H,RelTol,AbsTol,ITOL, + & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,IOUT,IDID, + & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,METH,NHESS1, + & IMPLCT,BANDED,LDJAC,LE,LDMAS, + & YHAT,Z,Y0,Z1,Z2,Z3,Z4,Z5,SCAL,F1,G1,H1,FJAC,E,FMAS,IP,IPHES) +C ---------------------------------------------------------- +C CORE INTEGRATOR FOR SDIRK4 +C PARAMETERS SAME AS IN SDIRK4 WITH WORKSPACE ADDED +C ---------------------------------------------------------- +C DECLARATIONS +C ---------------------------------------------------------- + IMPLICIT KPP_REAL (A-H,O-Z) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + KPP_REAL Y(N),YHAT(N),Z(N),Y0(N),Z1(N),Z2(N),Z3(N),Z4(N),Z5(N) + KPP_REAL SCAL(N),F1(N),G1(N),H1(N) + KPP_REAL FJAC(LU_NONZERO),E(LU_NONZERO),FMAS(LDMAS,N) + KPP_REAL AbsTol(1),RelTol(1) + INTEGER IP(N),IPHES(N) + LOGICAL REJECT,FIRST,IMPLCT,BANDED,CALJAC,NEWTRE + COMMON /CONT/NN,NN2,NN3,NN4,XOLD,HSOL,CONT(5*NVAR) + COMMON/STAT/NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL + EXTERNAL MAS, FCN, JAC + +C *** *** *** *** *** *** *** +C INITIALISATIONS +C *** *** *** *** *** *** *** + +C --------- DUPLIFY N FOR COMMON BLOCK CONT ----- + NN=N + NN2=2*N + NN3=3*N + NN4=4*N + +C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- + IF(IMPLCT) CALL MAS(N,FMAS,LDMAS) + +C ---------- CONSTANTS --------- + MBDIAG=MUMAS+1 + IF (METH.EQ.2) THEN +C ---------- METHOD WITH GAMMA = 4/15 --------------- + GAMMA=4.0D0/15.0D0 + C2=23.0D0/30.0D0 + C3=17.0D0/30.0D0 + C4=2881.0D0/28965.0D0+GAMMA + ALPH21=15.0D0/8.0D0 + ALPH31=1577061.0D0/922880.0D0 + ALPH32=-23427.0D0/115360.0D0 + ALPH41=647163682356923881.0D0/2414496535205978880.0D0 + ALPH42=-593512117011179.0D0/3245291041943520.0D0 + ALPH43=559907973726451.0D0/1886325418129671.0D0 + ALPH51=724545451.0D0/796538880.0D0 + ALPH52=-830832077.0D0/267298560.0D0 + ALPH53=30957577.0D0/2509272.0D0 + ALPH54=-69863904375173.0D0/6212571137048.0D0 + E1=7752107607.0D0/11393456128.0D0 + E2=-17881415427.0D0/11470078208.0D0 + E3=2433277665.0D0/179459416.0D0 + E4=-96203066666797.0D0/6212571137048.0D0 + D11= 24.74416644927758D0 + D12= -4.325375951824688D0 + D13= 41.39683763286316D0 + D14= -61.04144619901784D0 + D15= -3.391332232917013D0 + D21= -51.98245719616925D0 + D22= 10.52501981094525D0 + D23= -154.2067922191855D0 + D24= 214.3082125319825D0 + D25= 14.71166018088679D0 + D31= 33.14347947522142D0 + D32= -19.72986789558523D0 + D33= 230.4878502285804D0 + D34= -287.6629744338197D0 + D35= -18.99932366302254D0 + D41= -5.905188728329743D0 + D42= 13.53022403646467D0 + D43= -117.6778956422581D0 + D44= 134.3962081008550D0 + D45= 8.678995715052762D0 + ETA1=23.D0/8.D0 + ANU1= 0.9838473040915402D0 + ANU2= 0.3969226768377252D0 + AMU1= 0.6563374010466914D0 + AMU3= 0.3372498196189311D0 + ELSE + PRINT *, 'WRONG CHOICE OF ' + END IF + POSNEG=SIGN(1.D0,XEND-X) + HMAX1=MIN(ABS(HMAX),ABS(XEND-X)) + IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 + H=MIN(ABS(H),HMAX1) + H=SIGN(H,POSNEG) + HOLD=H + CFAC=SAFE*(1+2*NIT) + NEWTRE=.FALSE. + REJECT=.FALSE. + FIRST=.TRUE. + FACCO1=1.D0 + FACCO2=1.D0 + FACCO3=1.D0 + FACCO4=1.D0 + FACCO5=1.D0 + NSING=0 + XOLD=X + IF (ITOL.EQ.0) THEN + DO 8 I=1,N + 8 SCAL(I)=1.D0 / ( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) + ELSE + DO 9 I=1,N + 9 SCAL(I)=1.D0 / ( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) + END IF + +C --- BASIC INTEGRATION STEP + 10 CONTINUE + +C *** *** *** *** *** *** *** +C COMPUTATION OF THE JACOBIAN +C *** *** *** *** *** *** *** + NJAC=NJAC+1 + CALL JAC(N,X,Y,FJAC) + CALJAC=.TRUE. + 20 CONTINUE + +C *** *** *** *** *** *** *** +C COMPUTE THE MATRIX E AND ITS DECOMPOSITION +C *** *** *** *** *** *** *** + FAC1=1.D0/(H*GAMMA) + IF (IMPLCT) THEN + print *, 'IMPLCT 4' + ELSE ! EXPLICIT SYSTEM +C --- THE MATRIX E (MAS=IDENTITY, JACOBIAN A FULL MATRIX) +c DO 526 J=1,N +c DO 525 I=1,N +c 525 E(I,J)=-FJAC(I,J) +c 526 E(J,J)=E(J,J)+FAC1 +c CALL DEC(N,LE,E,IP,IER) + DO K=1,LU_NONZERO + E(K) = -FJAC(K) + END DO + DO I=1,N + IDG = LU_DIAG(I) + E(IDG) = E(IDG) + FAC1 + END DO + CALL KppDecomp ( E, IER) + + IF (IER.NE.0) GOTO 79 + END IF + NDEC=NDEC+1 + 30 CONTINUE + + IF (NSTEP.GT.NMAX.OR.X+.1D0*H.EQ.X.OR.ABS(H).LE.UROUND) GOTO 79 + XPH=X+H +C --- LOOP FOR THE 5 STAGES + FACCO1=DMAX1(FACCO1,UROUND)**0.8D0 + FACCO2=DMAX1(FACCO2,UROUND)**0.8D0 + FACCO3=DMAX1(FACCO3,UROUND)**0.8D0 + FACCO4=DMAX1(FACCO4,UROUND)**0.8D0 + FACCO5=DMAX1(FACCO5,UROUND)**0.8D0 + +C *** *** *** *** *** *** *** +C STARTING VALUES FOR NEWTON ITERATION +C *** *** *** *** *** *** *** + DO 59 ISTAGE=1,5 + IF (ISTAGE.EQ.1) THEN + XCH=X+GAMMA*H + IF (FIRST.OR.NEWTRE) THEN + DO 132 I=1,N + 132 Z(I)=0.D0 + ELSE + S=1.D0+GAMMA*H/HOLD + DO 232 I=1,N +c 232 Z(I) = 0.D0 + 232 Z(I)=S*(CONT(I+NN)+S*(CONT(I+NN2)+S*(CONT(I+NN3) + & +S*CONT(I+NN4))))-YHAT(I) + + END IF + DO 31 I=1,N + 31 G1(I)=0.D0 + FACCON=FACCO1 + END IF + IF (ISTAGE.EQ.2) THEN + XCH=X+C2*H + DO 131 I=1,N + Z1I=Z1(I) + Z(I)=ETA1*Z1I + 131 G1(I)=ALPH21*Z1I + FACCON=FACCO2 + END IF + IF (ISTAGE.EQ.3) THEN + XCH=X+C3*H + DO 231 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z(I)=ANU1*Z1I+ANU2*Z2I + 231 G1(I)=ALPH31*Z1I+ALPH32*Z2I + FACCON=FACCO3 + END IF + IF (ISTAGE.EQ.4) THEN + XCH=X+C4*H + DO 331 I=1,N + Z1I=Z1(I) + Z3I=Z3(I) + Z(I)=AMU1*Z1I+AMU3*Z3I + 331 G1(I)=ALPH41*Z1I+ALPH42*Z2(I)+ALPH43*Z3I + FACCON=FACCO4 + END IF + IF (ISTAGE.EQ.5) THEN + XCH=XPH + DO 431 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z3I=Z3(I) + Z4I=Z4(I) + Z(I)=E1*Z1I+E2*Z2I+E3*Z3I+E4*Z4I + YHAT(I)=Z(I) + 431 G1(I)=ALPH51*Z1I+ALPH52*Z2I+ALPH53*Z3I+ALPH54*Z4I + FACCON=FACCO5 + END IF + + + +C *** *** *** *** *** *** *** *** *** *** *** +C LOOP FOR THE SIMPLIFIED NEWTON ITERATION +C *** *** *** *** *** *** *** *** *** *** *** + NEWT=0 + THETA=ABS(THET) + IF (REJECT) THETA=2*ABS(THET) + 40 CONTINUE + IF (NEWT.GE.NIT) THEN + H=H/2.D0 + REJECT=.TRUE. + NEWTRE=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + +C --- COMPUTE THE RIGHT-HAND SIDE + DO 41 I=1,N + H1(I)=G1(I)-Z(I) + 41 CONT(I)=Y(I)+Z(I) + CALL FCN(N,XCH,CONT,F1) + NFCN=NFCN+1 + +C --- KppSolve THE LINEAR SYSTEMS + IF (IMPLCT) THEN + print *, 'IMPLCT 2' + ELSE + DO 345 I=1,N + 345 F1(I)=H1(I)*FAC1+F1(I) +C CALL SOL(N,LE,E,F1,IP) + CALL KppSolve(E, F1) + END IF + NEWT=NEWT+1 + DYNO=0.D0 +C --- NORM 2 --- + DO 57 I=1,N + 57 DYNO=DYNO+(F1(I)*SCAL(I))**2 + DYNO=DSQRT(DYNO/N) +C --- NORM INF --- +C DO 57 I=1,N +C 57 DYNO=DMAX1( DYNO, DABS(F1(I)*SCAL(I)) ) + + +C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE + IF (NEWT.GE.2.AND.NEWT.LT.NIT) THEN + THETA=DYNO/DYNOLD + IF (THETA.LT.0.99D0) THEN + FACCON=THETA/(1.0D0-THETA) + DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT) + QNEWT=DMAX1(1.0D-4,DMIN1(16.0D0,DYTH/FNEWT)) + IF (QNEWT.GE.1.0D0) THEN + H=.8D0*H*QNEWT**(-1.0D0/(NIT-NEWT)) + REJECT=.TRUE. + NEWTRE=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + ELSE + NEWTRE=.TRUE. + GOTO 78 + END IF + END IF + DYNOLD=DYNO + DO 58 I=1,N + 58 Z(I)=Z(I)+F1(I) + NSOL=NSOL+1 + IF (FACCON*DYNO.GT.FNEWT) GOTO 40 + +C --- END OF SIMPILFIED NEWTON + IF (ISTAGE.EQ.1) THEN + DO I=1,N + Z1(I) = Z(I) + END DO + FACCO1=FACCON + END IF + IF (ISTAGE.EQ.2) THEN + DO I=1,N + Z2(I) = Z(I) + END DO + FACCO2=FACCON + END IF + IF (ISTAGE.EQ.3) THEN + DO I=1,N + Z3(I) = Z(I) + END DO + FACCO3=FACCON + END IF + IF (ISTAGE.EQ.4) THEN + DO I=1,N + Z4(I) = Z(I) + END DO + FACCO4=FACCON + END IF + IF (ISTAGE.EQ.5) THEN + DO I=1,N + Z5(I) = Z(I) + END DO + FACCO5=FACCON + END IF + 59 CONTINUE + + +C *** *** *** *** *** *** *** +C ERROR ESTIMATION +C *** *** *** *** *** *** *** + NSTEP=NSTEP+1 + IF (IMPLCT) THEN + print *,'IMPLCT 3' + ELSE + DO 461 I=1,N + 461 CONT(I)=FAC1*(Z5(I)-YHAT(I)) + END IF + + CALL KppSolve(E, CONT) + + ERR=0.D0 +C ---- NORM 2 --- + DO 64 I=1,N + 64 ERR=ERR+(CONT(I)*SCAL(I))**2 + ERR=DMAX1(DSQRT(ERR/N),1.D-10) + +C ---- NORM INF --- +C DO 64 I=1,N +c 64 ERR=DMAX1( ERR, DABS( CONT(I)*SCAL(I) ) ) + +C --- COMPUTATION OF HNEW +C --- WE REQUIRE .25<=HNEW/H<=10. + FAC=DMIN1(SAFE,CFAC/(NEWT+2*NIT)) + QUOT=DMAX1(.25D0,DMIN1(10.D0,(ERR)**.25D0/FAC)) + HNEW= H/QUOT + +C *** *** *** *** *** *** *** +C IS THE ERROR SMALL ENOUGH ? +C *** *** *** *** *** *** *** + IF (ERR.LT.1.D0) THEN +C --- STEP IS ACCEPTED + FIRST=.FALSE. + NACCPT=NACCPT+1 + HOLD=H + XOLD=X +C --- COEFFICIENTS FOR CONTINUOUS SOLUTION + DO 74 I=1,N + Z1I=Z1(I) + Z2I=Z2(I) + Z3I=Z3(I) + Z4I=Z4(I) + Z5I=Z5(I) + CONT(I)=Y(I) + Y(I)=Y(I)+Z5I + CONT(I+NN) =D11*Z1I+D12*Z2I+D13*Z3I+D14*Z4I+D15*Z5I + CONT(I+NN2)=D21*Z1I+D22*Z2I+D23*Z3I+D24*Z4I+D25*Z5I + CONT(I+NN3)=D31*Z1I+D32*Z2I+D33*Z3I+D34*Z4I+D35*Z5I + CONT(I+NN4)=D41*Z1I+D42*Z2I+D43*Z3I+D44*Z4I+D45*Z5I + YHAT(I)=Z5I + IF (ITOL.EQ.0) THEN + SCAL(I)=1.D0/( AbsTol(1)+RelTol(1)*DABS(Y(I)) ) + ELSE + SCAL(I)=1.D0/( AbsTol(I)+RelTol(I)*DABS(Y(I)) ) + END IF + 74 CONTINUE + X=XPH + CALJAC=.FALSE. + IF ((X-XEND)*POSNEG+UROUND.GT.0.D0) THEN + H=HOPT + IDID=1 + RETURN + END IF + IF (IJAC.EQ.0) CALL FCN(N,X,Y,Y0) + NFCN=NFCN+1 + HNEW=POSNEG*DMIN1(DABS(HNEW),HMAX1) + HOPT=HNEW + IF (REJECT) HNEW=POSNEG*DMIN1(DABS(HNEW),DABS(H)) + REJECT=.FALSE. + NEWTRE=.FALSE. + IF ((X+HNEW/QUOT1-XEND)*POSNEG.GT.0.D0) THEN + H=XEND-X + ELSE + QT=HNEW/H + IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 + H = HNEW + END IF + IF (THETA.LE.THET) GOTO 20 + GOTO 10 + + ELSE +C --- STEP IS REJECTED + REJECT=.TRUE. + IF (FIRST) THEN + H=H/10.D0 + ELSE + H=HNEW + END IF + IF (NACCPT.GE.1) NREJCT=NREJCT+1 + IF (CALJAC) GOTO 20 + GOTO 10 + END IF + +C --- UNEXPECTED STEP-REJECTION + 78 CONTINUE + IF (IER.NE.0) THEN + WRITE (6,*) ' MATRIX IS SINGULAR, IER=',IER,' X=',X,' H=',H + NSING=NSING+1 + IF (NSING.GE.6) GOTO 79 + END IF + H=H*0.5D0 + REJECT=.TRUE. + IF (CALJAC) GOTO 20 + GOTO 10 + +C --- FAIL EXIT + 79 WRITE (6,979) X,H,IER + 979 FORMAT(' EXIT OF SDIRK4 AT X=',D14.7,' H=',D14.7,' IER=',I4) + IDID=-1 + RETURN + END +C + + + SUBROUTINE FUNC_CHEM(N, T, Y, P) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + KPP_REAL T, Told + KPP_REAL Y(NVAR), P(NVAR) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Fun( Y, FIX, RCONST, P ) + TIME = Told + RETURN + END + + + SUBROUTINE JAC_CHEM(N, T, Y, J) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + INTEGER N + KPP_REAL Told, T + KPP_REAL Y(NVAR), J(LU_NONZERO) + Told = TIME + TIME = T + CALL Update_SUN() + CALL Update_RCONST() + CALL Jac_SP( Y, FIX, RCONST, J ) + TIME = Told + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.def new file mode 100755 index 00000000..98f65d65 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.def @@ -0,0 +1,10 @@ + +#FUNCTION aggregate +#JACOBIAN SPARSE_LU_ROW +#DOUBLE on +#STOCHASTIC on +#INTFILE tau_leap + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.f90 new file mode 100755 index 00000000..c069d867 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/tau_leap.f90 @@ -0,0 +1,1688 @@ +MODULE KPP_ROOT_Random +! A module for random number generation from the following distributions: +! +! Distribution Function/subroutine name +! +! Normal (Gaussian) random_normal +! Gamma random_gamma +! Chi-squared random_chisq +! Exponential random_exponential +! Weibull random_Weibull +! Beta random_beta +! t random_t +! Multivariate normal random_mvnorm +! Generalized inverse Gaussian random_inv_gauss +! Poisson random_Poisson +! Binomial random_binomial1 * +! random_binomial2 * +! Negative binomial random_neg_binomial +! von Mises random_von_Mises +! Cauchy random_Cauchy +! +! Generate a random ordering of the integers 1 .. N +! random_order +! Initialize (seed) the uniform random number generator for ANY compiler +! seed_random_number + +! Lognormal - see note below. + +! ** Two functions are provided for the binomial distribution. +! If the parameter values remain constant, it is recommended that the +! first function is used (random_binomial1). If one or both of the +! parameters change, use the second function (random_binomial2). + +! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r), +! is used to provide a source of uniformly distributed random numbers. + +! N.B. At this stage, only one random number is generated at each call to +! one of the functions above. + +! The module uses the following functions which are included here: +! bin_prob to calculate a single binomial probability +! lngamma to calculate the logarithm to base e of the gamma function + +! Some of the code is adapted from Dagpunar's book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 +! +! In most of Dagpunar's routines, there is a test to see whether the value +! of one or two floating-point parameters has changed since the last call. +! These tests have been replaced by using a logical variable FIRST. +! This should be set to .TRUE. on the first call using new values of the +! parameters, and .FALSE. if the parameter values are the same as for the +! previous call. + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Lognormal distribution +! If X has a lognormal distribution, then log(X) is normally distributed. +! Here the logarithm is the natural logarithm, that is to base e, sometimes +! denoted as ln. To generate random variates from this distribution, generate +! a random deviate from the normal distribution with mean and variance equal +! to the mean and variance of the logarithms of X, then take its exponential. + +! Relationship between the mean & variance of log(X) and the mean & variance +! of X, when X has a lognormal distribution. +! Let m = mean of log(X), and s^2 = variance of log(X) +! Then +! mean of X = exp(m + 0.5s^2) +! variance of X = (mean(X))^2.[exp(s^2) - 1] + +! In the reverse direction (rarely used) +! variance of log(X) = log[1 + var(X)/(mean(X))^2] +! mean of log(X) = log(mean(X) - 0.5var(log(X)) + +! N.B. The above formulae relate to population parameters; they will only be +! approximate if applied to sample values. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Version 1.13, 2 October 2000 +! Changes from version 1.01 +! 1. The random_order, random_Poisson & random_binomial routines have been +! replaced with more efficient routines. +! 2. A routine, seed_random_number, has been added to seed the uniform random +! number generator. This requires input of the required number of seeds +! for the particular compiler from a specified I/O unit such as a keyboard. +! 3. Made compatible with Lahey's ELF90. +! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1. +! 5. INTENT for array f corrected in random_mvnorm. + +! Author: Alan Miller +! CSIRO Division of Mathematical & Information Sciences +! Private Bag 10, Clayton South MDC +! Clayton 3169, Victoria, Australia +! Phone: (+61) 3 9545-8016 Fax: (+61) 3 9545-8080 +! e-mail: amiller @ bigpond.net.au + +IMPLICIT NONE +REAL, PRIVATE :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & + vsmall = TINY(1.0), vlarge = HUGE(1.0) +PRIVATE :: integral +INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) + + +CONTAINS + + +FUNCTION random_normal() RESULT(fn_val) + +! Adapted from the following Fortran 77 code +! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. +! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, +! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. + +! The function random_normal() returns a normally distributed pseudo-random +! number with zero mean and unit variance. + +! The algorithm uses the ratio of uniforms method of A.J. Kinderman +! and J.F. Monahan augmented with quadratic bounding curves. + +REAL :: fn_val + +! Local variables +REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & + r1 = 0.27597, r2 = 0.27846, u, v, x, y, q + +! Generate P = (u,v) uniform in rectangle enclosing acceptance region + +DO + CALL RANDOM_NUMBER(u) + CALL RANDOM_NUMBER(v) + v = 1.7156 * (v - half) + +! Evaluate the quadratic form + x = u - s + y = ABS(v) - t + q = x**2 + y*(a*y - b*x) + +! Accept P if inside inner ellipse + IF (q < r1) EXIT +! Reject P if outside outer ellipse + IF (q > r2) CYCLE +! Reject P if outside acceptance region + IF (v**2 < -4.0*LOG(u)*u**2) EXIT +END DO + +! Return ratio of P's coordinates as the normal deviate +fn_val = v/u +RETURN + +END FUNCTION random_normal + + + +FUNCTION random_gamma(s, first) RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM GAMMA VARIATE. +! CALLS EITHER random_gamma1 (S > 1.0) +! OR random_exponential (S = 1.0) +! OR random_gamma2 (S < 1.0). + +! S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL). + +REAL, INTENT(IN) :: s +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +IF (s <= zero) THEN + WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE' + STOP +END IF + +IF (s > one) THEN + fn_val = random_gamma1(s, first) +ELSE IF (s < one) THEN + fn_val = random_gamma2(s, first) +ELSE + fn_val = random_exponential() +END IF + +RETURN +END FUNCTION random_gamma + + + +FUNCTION random_gamma1(s, first) RESULT(fn_val) + +! Uses the algorithm in +! Marsaglia, G. and Tsang, W.W. (2000) `A simple method for generating +! gamma variables', Trans. om Math. Software (TOMS), vol.26(3), pp.363-372. + +! Generates a random gamma deviate for shape parameter s >= 1. + +REAL, INTENT(IN) :: s +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +! Local variables +REAL, SAVE :: c, d +REAL :: u, v, x + +IF (first) THEN + d = s - one/3. + c = one/SQRT(9.0*d) +END IF + +! Start of main loop +DO + +! Generate v = (1+cx)^3 where x is random normal; repeat if v <= 0. + + DO + x = random_normal() + v = (one + c*x)**3 + IF (v > zero) EXIT + END DO + +! Generate uniform variable U + + CALL RANDOM_NUMBER(u) + IF (u < one - 0.0331*x**4) THEN + fn_val = d*v + EXIT + ELSE IF (LOG(u) < half*x**2 + d*(one - v + LOG(v))) THEN + fn_val = d*v + EXIT + END IF +END DO + +RETURN +END FUNCTION random_gamma1 + + + +FUNCTION random_gamma2(s, first) RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM +! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO +! GAMMA2**(S-1) * EXP(-GAMMA2), +! USING A SWITCHING METHOD. + +! S = SHAPE PARAMETER OF DISTRIBUTION +! (REAL < 1.0) + +REAL, INTENT(IN) :: s +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +! Local variables +REAL :: r, x, w +REAL, SAVE :: a, p, c, uf, vr, d + +IF (s <= zero .OR. s >= one) THEN + WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE' + STOP +END IF + +IF (first) THEN ! Initialization, if necessary + a = one - s + p = a/(a + s*EXP(-a)) + IF (s < vsmall) THEN + WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL' + STOP + END IF + c = one/s + uf = p*(vsmall/a)**s + vr = one - vsmall + d = a*LOG(a) +END IF + +DO + CALL RANDOM_NUMBER(r) + IF (r >= vr) THEN + CYCLE + ELSE IF (r > p) THEN + x = a - LOG((one - r)/(one - p)) + w = a*LOG(x)-d + ELSE IF (r > uf) THEN + x = a*(r/p)**c + w = x + ELSE + fn_val = zero + RETURN + END IF + + CALL RANDOM_NUMBER(r) + IF (one-r <= w .AND. r > zero) THEN + IF (r*(w + one) >= one) CYCLE + IF (-LOG(r) <= w) CYCLE + END IF + EXIT +END DO + +fn_val = x +RETURN + +END FUNCTION random_gamma2 + + + +FUNCTION random_chisq(ndf, first) RESULT(fn_val) + +! Generates a random variate from the chi-squared distribution with +! ndf degrees of freedom + +INTEGER, INTENT(IN) :: ndf +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +fn_val = two * random_gamma(half*ndf, first) +RETURN + +END FUNCTION random_chisq + + + +FUNCTION random_exponential() RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM +! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL +! TO EXP(-random_exponential), USING INVERSION. + +REAL :: fn_val + +! Local variable +REAL :: r + +DO + CALL RANDOM_NUMBER(r) + IF (r > zero) EXIT +END DO + +fn_val = -LOG(r) +RETURN + +END FUNCTION random_exponential + + + +FUNCTION random_Weibull(a) RESULT(fn_val) + +! Generates a random variate from the Weibull distribution with +! probability density: +! a +! a-1 -x +! f(x) = a.x e + +REAL, INTENT(IN) :: a +REAL :: fn_val + +! For speed, there is no checking that a is not zero or very small. + +fn_val = random_exponential() ** (one/a) +RETURN + +END FUNCTION random_Weibull + + + +FUNCTION random_beta(aa, bb, first) RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM VARIATE IN [0,1] +! FROM A BETA DISTRIBUTION WITH DENSITY +! PROPORTIONAL TO BETA**(AA-1) * (1-BETA)**(BB-1). +! USING CHENG'S LOG LOGISTIC METHOD. + +! AA = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) +! BB = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) + +REAL, INTENT(IN) :: aa, bb +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +! Local variables +REAL, PARAMETER :: aln4 = 1.3862944 +REAL :: a, b, g, r, s, x, y, z +REAL, SAVE :: d, f, h, t, c +LOGICAL, SAVE :: swap + +IF (aa <= zero .OR. bb <= zero) THEN + WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE(S)' + STOP +END IF + +IF (first) THEN ! Initialization, if necessary + a = aa + b = bb + swap = b > a + IF (swap) THEN + g = b + b = a + a = g + END IF + d = a/b + f = a+b + IF (b > one) THEN + h = SQRT((two*a*b - f)/(f - two)) + t = one + ELSE + h = b + t = one/(one + (a/(vlarge*b))**b) + END IF + c = a+h +END IF + +DO + CALL RANDOM_NUMBER(r) + CALL RANDOM_NUMBER(x) + s = r*r*x + IF (r < vsmall .OR. s <= zero) CYCLE + IF (r < t) THEN + x = LOG(r/(one - r))/h + y = d*EXP(x) + z = c*x + f*LOG((one + d)/(one + y)) - aln4 + IF (s - one > z) THEN + IF (s - s*z > one) CYCLE + IF (LOG(s) > z) CYCLE + END IF + fn_val = y/(one + y) + ELSE + IF (4.0*s > (one + one/d)**f) CYCLE + fn_val = one + END IF + EXIT +END DO + +IF (swap) fn_val = one - fn_val +RETURN +END FUNCTION random_beta + + + +FUNCTION random_t(m) RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM VARIATE FROM A +! T DISTRIBUTION USING KINDERMAN AND MONAHAN'S RATIO METHOD. + +! M = DEGREES OF FREEDOM OF DISTRIBUTION +! (1 <= 1NTEGER) + +INTEGER, INTENT(IN) :: m +REAL :: fn_val + +! Local variables +REAL, SAVE :: s, c, a, f, g +REAL :: r, x, v + +REAL, PARAMETER :: three = 3.0, four = 4.0, quart = 0.25, & + five = 5.0, sixteen = 16.0 +INTEGER :: mm = 0 + +IF (m < 1) THEN + WRITE(*, *) 'IMPERMISSIBLE DEGREES OF FREEDOM' + STOP +END IF + +IF (m /= mm) THEN ! Initialization, if necessary + s = m + c = -quart*(s + one) + a = four/(one + one/s)**c + f = sixteen/a + IF (m > 1) THEN + g = s - one + g = ((s + one)/g)**c*SQRT((s+s)/g) + ELSE + g = one + END IF + mm = m +END IF + +DO + CALL RANDOM_NUMBER(r) + IF (r <= zero) CYCLE + CALL RANDOM_NUMBER(v) + x = (two*v - one)*g/r + v = x*x + IF (v > five - a*r) THEN + IF (m >= 1 .AND. r*(v + three) > f) CYCLE + IF (r > (one + v/s)**c) CYCLE + END IF + EXIT +END DO + +fn_val = x +RETURN +END FUNCTION random_t + + + +SUBROUTINE random_mvnorm(n, h, d, f, first, x, ier) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! N.B. An extra argument, ier, has been added to Dagpunar's routine + +! SUBROUTINE GENERATES AN N VARIATE RANDOM NORMAL +! VECTOR USING A CHOLESKY DECOMPOSITION. + +! ARGUMENTS: +! N = NUMBER OF VARIATES IN VECTOR +! (INPUT,INTEGER >= 1) +! H(J) = J'TH ELEMENT OF VECTOR OF MEANS +! (INPUT,REAL) +! X(J) = J'TH ELEMENT OF DELIVERED VECTOR +! (OUTPUT,REAL) +! +! D(J*(J-1)/2+I) = (I,J)'TH ELEMENT OF VARIANCE MATRIX (J> = I) +! (INPUT,REAL) +! F((J-1)*(2*N-J)/2+I) = (I,J)'TH ELEMENT OF LOWER TRIANGULAR +! DECOMPOSITION OF VARIANCE MATRIX (J <= I) +! (OUTPUT,REAL) + +! FIRST = .TRUE. IF THIS IS THE FIRST CALL OF THE ROUTINE +! OR IF THE DISTRIBUTION HAS CHANGED SINCE THE LAST CALL OF THE ROUTINE. +! OTHERWISE SET TO .FALSE. +! (INPUT,LOGICAL) + +! ier = 1 if the input covariance matrix is not +ve definite +! = 0 otherwise + +INTEGER, INTENT(IN) :: n +REAL, INTENT(IN) :: h(:), d(:) ! d(n*(n+1)/2) +REAL, INTENT(IN OUT) :: f(:) ! f(n*(n+1)/2) +REAL, INTENT(OUT) :: x(:) +LOGICAL, INTENT(IN) :: first +INTEGER, INTENT(OUT) :: ier + +! Local variables +INTEGER :: j, i, m +REAL :: y, v +INTEGER, SAVE :: n2 + +IF (n < 1) THEN + WRITE(*, *) 'SIZE OF VECTOR IS NON POSITIVE' + STOP +END IF + +ier = 0 +IF (first) THEN ! Initialization, if necessary + n2 = 2*n + IF (d(1) < zero) THEN + ier = 1 + RETURN + END IF + + f(1) = SQRT(d(1)) + y = one/f(1) + DO j = 2,n + f(j) = d(1+j*(j-1)/2) * y + END DO + + DO i = 2,n + v = d(i*(i-1)/2+i) + DO m = 1,i-1 + v = v - f((m-1)*(n2-m)/2+i)**2 + END DO + + IF (v < zero) THEN + ier = 1 + RETURN + END IF + + v = SQRT(v) + y = one/v + f((i-1)*(n2-i)/2+i) = v + DO j = i+1,n + v = d(j*(j-1)/2+i) + DO m = 1,i-1 + v = v - f((m-1)*(n2-m)/2+i)*f((m-1)*(n2-m)/2 + j) + END DO ! m = 1,i-1 + f((i-1)*(n2-i)/2 + j) = v*y + END DO ! j = i+1,n + END DO ! i = 2,n +END IF + +x(1:n) = h(1:n) +DO j = 1,n + y = random_normal() + DO i = j,n + x(i) = x(i) + f((j-1)*(n2-j)/2 + i) * y + END DO ! i = j,n +END DO ! j = 1,n + +RETURN +END SUBROUTINE random_mvnorm + + + +FUNCTION random_inv_gauss(h, b, first) RESULT(fn_val) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY] FROM +! A REPARAMETERISED GENERALISED INVERSE GAUSSIAN (GIG) DISTRIBUTION +! WITH DENSITY PROPORTIONAL TO GIG**(H-1) * EXP(-0.5*B*(GIG+1/GIG)) +! USING A RATIO METHOD. + +! H = PARAMETER OF DISTRIBUTION (0 <= REAL) +! B = PARAMETER OF DISTRIBUTION (0 < REAL) + +REAL, INTENT(IN) :: h, b +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +! Local variables +REAL :: ym, xm, r, w, r1, r2, x +REAL, SAVE :: a, c, d, e +REAL, PARAMETER :: quart = 0.25 + +IF (h < zero .OR. b <= zero) THEN + WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' + STOP +END IF + +IF (first) THEN ! Initialization, if necessary + IF (h > quart*b*SQRT(vlarge)) THEN + WRITE(*, *) 'THE RATIO H:B IS TOO SMALL' + STOP + END IF + e = b*b + d = h + one + ym = (-d + SQRT(d*d + e))/b + IF (ym < vsmall) THEN + WRITE(*, *) 'THE VALUE OF B IS TOO SMALL' + STOP + END IF + + d = h - one + xm = (d + SQRT(d*d + e))/b + d = half*d + e = -quart*b + r = xm + one/xm + w = xm*ym + a = w**(-half*h) * SQRT(xm/ym) * EXP(-e*(r - ym - one/ym)) + IF (a < vsmall) THEN + WRITE(*, *) 'THE VALUE OF H IS TOO LARGE' + STOP + END IF + c = -d*LOG(xm) - e*r +END IF + +DO + CALL RANDOM_NUMBER(r1) + IF (r1 <= zero) CYCLE + CALL RANDOM_NUMBER(r2) + x = a*r2/r1 + IF (x <= zero) CYCLE + IF (LOG(r1) < d*LOG(x) + e*(x + one/x) + c) EXIT +END DO + +fn_val = x + +RETURN +END FUNCTION random_inv_gauss + + + +FUNCTION random_Poisson(mu, first) RESULT(ival) +!********************************************************************** +! Translated to Fortran 90 by Alan Miller from: +! RANLIB +! +! Library of Fortran Routines for Random Number Generation +! +! Compiled and Written by: +! +! Barry W. Brown +! James Lovato +! +! Department of Biomathematics, Box 237 +! The University of Texas, M.D. Anderson Cancer Center +! 1515 Holcombe Boulevard +! Houston, TX 77030 +! +! This work was supported by grant CA-16672 from the National Cancer Institute. + +! GENerate POIsson random deviate + +! Function + +! Generates a single random deviate from a Poisson distribution with mean mu. + +! Arguments + +! mu --> The mean of the Poisson distribution from which +! a random deviate is to be generated. +! REAL mu + +! Method + +! For details see: + +! Ahrens, J.H. and Dieter, U. +! Computer Generation of Poisson Deviates +! From Modified Normal Distributions. +! ACM Trans. Math. Software, 8, 2 +! (June 1982),163-179 + +! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT +! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL + +! SEPARATION OF CASES A AND B + +! .. Scalar Arguments .. +REAL, INTENT(IN) :: mu +LOGICAL, INTENT(IN) :: first +INTEGER :: ival +! .. +! .. Local Scalars .. +REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & + omega, px, py, t, u, v, x, xx +REAL, SAVE :: s, d, p, q, p0 +INTEGER :: j, k, kflag +LOGICAL, SAVE :: full_init +INTEGER, SAVE :: l, m +! .. +! .. Local Arrays .. +REAL, SAVE :: pp(35) +! .. +! .. Data statements .. +REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & + a4 = -.1661269, a5 = .1421878, a6 = -.1384794, & + a7 = .1250060 + +REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & + 40320., 362880. /) + +! .. +! .. Executable Statements .. +IF (mu > 10.0) THEN +! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) + + IF (first) THEN + s = SQRT(mu) + d = 6.0*mu*mu + +! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL +! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) +! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . + + l = mu - 1.1484 + full_init = .false. + END IF + + +! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE + + g = mu + s*random_normal() + IF (g > 0.0) THEN + ival = g + +! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH + + IF (ival>=l) RETURN + +! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U + + fk = ival + difmuk = mu - fk + CALL RANDOM_NUMBER(u) + IF (d*u >= difmuk*difmuk*difmuk) RETURN + END IF + +! STEP P. PREPARATIONS FOR STEPS Q AND H. +! (RECALCULATIONS OF PARAMETERS IF NECESSARY) +! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. +! THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE +! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. +! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. + + IF (.NOT. full_init) THEN + omega = .3989423/s + b1 = .4166667E-1/mu + b2 = .3*b1*b1 + c3 = .1428571*b1*b2 + c2 = b2 - 15.*c3 + c1 = b1 - 6.*b2 + 45.*c3 + c0 = 1. - b1 + 3.*b2 - 15.*c3 + c = .1069/mu + full_init = .true. + END IF + + IF (g < 0.0) GO TO 50 + +! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) + + kflag = 0 + GO TO 70 + +! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) + + 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN + +! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL +! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' +! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) + + 50 e = random_exponential() + CALL RANDOM_NUMBER(u) + u = u + u - one + t = 1.8 + SIGN(e, u) + IF (t <= (-.6744)) GO TO 50 + ival = mu + s*t + fk = ival + difmuk = mu - fk + +! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) + + kflag = 1 + GO TO 70 + +! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) + + 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 + RETURN + +! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. +! CASE ival < 10 USES FACTORIALS FROM TABLE FACT + + 70 IF (ival>=10) GO TO 80 + px = -mu + py = mu**ival/fact(ival+1) + GO TO 110 + +! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION +! A0-A7 FOR ACCURACY WHEN ADVISABLE +! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) + + 80 del = .8333333E-1/fk + del = del - 4.8*del*del*del + v = difmuk/fk + IF (ABS(v)>0.25) THEN + px = fk*LOG(one + v) - difmuk - del + ELSE + px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del + END IF + py = .3989423/SQRT(fk) + 110 x = (half - difmuk)/s + xx = x*x + fx = -half*xx + fy = omega* (((c3*xx + c2)*xx + c1)*xx + c0) + IF (kflag <= 0) GO TO 40 + GO TO 60 + +!--------------------------------------------------------------------------- +! C A S E B. mu < 10 +! START NEW TABLE AND CALCULATE P0 IF NECESSARY + +ELSE + IF (first) THEN + m = MAX(1, INT(mu)) + l = 0 + p = EXP(-mu) + q = p + p0 = p + END IF + +! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD + + DO + CALL RANDOM_NUMBER(u) + ival = 0 + IF (u <= p0) RETURN + +! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE +! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES +! (0.458=PP(9) FOR MU=10) + + IF (l == 0) GO TO 150 + j = 1 + IF (u > 0.458) j = MIN(l, m) + DO k = j, l + IF (u <= pp(k)) GO TO 180 + END DO + IF (l == 35) CYCLE + +! STEP C. CREATION OF NEW POISSON PROBABILITIES P +! AND THEIR CUMULATIVES Q=PP(K) + + 150 l = l + 1 + DO k = l, 35 + p = p*mu / k + q = q + p + pp(k) = q + IF (u <= q) GO TO 170 + END DO + l = 35 + END DO + + 170 l = k + 180 ival = k + RETURN +END IF + +RETURN +END FUNCTION random_Poisson + + + +FUNCTION random_binomial1(n, p, first) RESULT(ival) + +! FUNCTION GENERATES A RANDOM BINOMIAL VARIATE USING C.D.Kemp's method. +! This algorithm is suitable when many random variates are required +! with the SAME parameter values for n & p. + +! P = BERNOULLI SUCCESS PROBABILITY +! (0 <= REAL <= 1) +! N = NUMBER OF BERNOULLI TRIALS +! (1 <= INTEGER) +! FIRST = .TRUE. for the first call using the current parameter values +! = .FALSE. if the values of (n,p) are unchanged from last call + +! Reference: Kemp, C.D. (1986). `A modal method for generating binomial +! variables', Commun. Statist. - Theor. Meth. 15(3), 805-813. + +INTEGER, INTENT(IN) :: n +REAL, INTENT(IN) :: p +LOGICAL, INTENT(IN) :: first +INTEGER :: ival + +! Local variables + +INTEGER :: ru, rd +INTEGER, SAVE :: r0 +REAL :: u, pd, pu +REAL, SAVE :: odds_ratio, p_r +REAL, PARAMETER :: zero = 0.0, one = 1.0 + +IF (first) THEN + r0 = (n+1)*p + p_r = bin_prob(n, p, r0) + odds_ratio = p / (one - p) +END IF + +CALL RANDOM_NUMBER(u) +u = u - p_r +IF (u < zero) THEN + ival = r0 + RETURN +END IF + +pu = p_r +ru = r0 +pd = p_r +rd = r0 +DO + rd = rd - 1 + IF (rd >= 0) THEN + pd = pd * (rd+1) / (odds_ratio * (n-rd)) + u = u - pd + IF (u < zero) THEN + ival = rd + RETURN + END IF + END IF + + ru = ru + 1 + IF (ru <= n) THEN + pu = pu * (n-ru+1) * odds_ratio / ru + u = u - pu + IF (u < zero) THEN + ival = ru + RETURN + END IF + END IF +END DO + +! This point should not be reached, but just in case: + +ival = r0 +RETURN + +END FUNCTION random_binomial1 + + + +FUNCTION bin_prob(n, p, r) RESULT(fn_val) +! Calculate a binomial probability + +INTEGER, INTENT(IN) :: n, r +REAL, INTENT(IN) :: p +REAL :: fn_val + +! Local variable +REAL :: one = 1.0 + +fn_val = EXP( lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1)) & + + r*LOG(p) + (n-r)*LOG(one - p) ) +RETURN + +END FUNCTION bin_prob + + + +FUNCTION lngamma(x) RESULT(fn_val) + +! Logarithm to base e of the gamma function. +! +! Accurate to about 1.e-14. +! Programmer: Alan Miller + +! Latest revision of Fortran 77 version - 28 February 1988 + +REAL (dp), INTENT(IN) :: x +REAL (dp) :: fn_val + +! Local variables + +REAL (dp) :: a1 = -4.166666666554424D-02, a2 = 2.430554511376954D-03, & + a3 = -7.685928044064347D-04, a4 = 5.660478426014386D-04, & + temp, arg, product, lnrt2pi = 9.189385332046727D-1, & + pi = 3.141592653589793D0 +LOGICAL :: reflect + +! lngamma is not defined if x = 0 or a negative integer. + +IF (x > 0.d0) GO TO 10 +IF (x /= INT(x)) GO TO 10 +fn_val = 0.d0 +RETURN + +! If x < 0, use the reflection formula: +! gamma(x) * gamma(1-x) = pi * cosec(pi.x) + +10 reflect = (x < 0.d0) +IF (reflect) THEN + arg = 1.d0 - x +ELSE + arg = x +END IF + +! Increase the argument, if necessary, to make it > 10. + +product = 1.d0 +20 IF (arg <= 10.d0) THEN + product = product * arg + arg = arg + 1.d0 + GO TO 20 +END IF + +! Use a polynomial approximation to Stirling's formula. +! N.B. The real Stirling's formula is used here, not the simpler, but less +! accurate formula given by De Moivre in a letter to Stirling, which +! is the one usually quoted. + +arg = arg - 0.5D0 +temp = 1.d0/arg**2 +fn_val = lnrt2pi + arg * (LOG(arg) - 1.d0 + & + (((a4*temp + a3)*temp + a2)*temp + a1)*temp) - LOG(product) +IF (reflect) THEN + temp = SIN(pi * x) + fn_val = LOG(pi/temp) - fn_val +END IF +RETURN +END FUNCTION lngamma + + + +FUNCTION random_binomial2(n, pp, first) RESULT(ival) +!********************************************************************** +! Translated to Fortran 90 by Alan Miller from: +! RANLIB +! +! Library of Fortran Routines for Random Number Generation +! +! Compiled and Written by: +! +! Barry W. Brown +! James Lovato +! +! Department of Biomathematics, Box 237 +! The University of Texas, M.D. Anderson Cancer Center +! 1515 Holcombe Boulevard +! Houston, TX 77030 +! +! This work was supported by grant CA-16672 from the National Cancer Institute. + +! GENerate BINomial random deviate + +! Function + +! Generates a single random deviate from a binomial +! distribution whose number of trials is N and whose +! probability of an event in each trial is P. + +! Arguments + +! N --> The number of trials in the binomial distribution +! from which a random deviate is to be generated. +! INTEGER N + +! P --> The probability of an event in each trial of the +! binomial distribution from which a random deviate +! is to be generated. +! REAL P + +! FIRST --> Set FIRST = .TRUE. for the first call to perform initialization +! the set FIRST = .FALSE. for further calls using the same pair +! of parameter values (N, P). +! LOGICAL FIRST + +! random_binomial2 <-- A random deviate yielding the number of events +! from N independent trials, each of which has +! a probability of event P. +! INTEGER random_binomial + +! Method + +! This is algorithm BTPE from: + +! Kachitvichyanukul, V. and Schmeiser, B. W. +! Binomial Random Variate Generation. +! Communications of the ACM, 31, 2 (February, 1988) 216. + +!********************************************************************** + +!*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY + +! .. +! .. Scalar Arguments .. +REAL, INTENT(IN) :: pp +INTEGER, INTENT(IN) :: n +LOGICAL, INTENT(IN) :: first +INTEGER :: ival +! .. +! .. Local Scalars .. +REAL :: alv, amaxp, f, f1, f2, u, v, w, w2, x, x1, x2, ynorm, z, z2 +REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0 +INTEGER :: i, ix, ix1, k, mp +INTEGER, SAVE :: m +REAL, SAVE :: p, q, xnp, ffm, fm, xnpq, p1, xm, xl, xr, c, al, xll, & + xlr, p2, p3, p4, qn, r, g + +! .. +! .. Executable Statements .. + +!*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE + +IF (first) THEN + p = MIN(pp, one-pp) + q = one - p + xnp = n * p +END IF + +IF (xnp > 30.) THEN + IF (first) THEN + ffm = xnp + p + m = ffm + fm = m + xnpq = xnp * q + p1 = INT(2.195*SQRT(xnpq) - 4.6*q) + half + xm = fm + half + xl = xm - p1 + xr = xm + p1 + c = 0.134 + 20.5 / (15.3 + fm) + al = (ffm-xl) / (ffm - xl*p) + xll = al * (one + half*al) + al = (xr - ffm) / (xr*q) + xlr = al * (one + half*al) + p2 = p1 * (one + c + c) + p3 = p2 + c / xll + p4 = p3 + c / xlr + END IF + +!*****GENERATE VARIATE, Binomial mean at least 30. + + 20 CALL RANDOM_NUMBER(u) + u = u * p4 + CALL RANDOM_NUMBER(v) + +! TRIANGULAR REGION + + IF (u <= p1) THEN + ix = xm - p1 * v + u + GO TO 110 + END IF + +! PARALLELOGRAM REGION + + IF (u <= p2) THEN + x = xl + (u-p1) / c + v = v * c + one - ABS(xm-x) / p1 + IF (v > one .OR. v <= zero) GO TO 20 + ix = x + ELSE + +! LEFT TAIL + + IF (u <= p3) THEN + ix = xl + LOG(v) / xll + IF (ix < 0) GO TO 20 + v = v * (u-p2) * xll + ELSE + +! RIGHT TAIL + + ix = xr - LOG(v) / xlr + IF (ix > n) GO TO 20 + v = v * (u-p3) * xlr + END IF + END IF + +!*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST + + k = ABS(ix-m) + IF (k <= 20 .OR. k >= xnpq/2-1) THEN + +! EXPLICIT EVALUATION + + f = one + r = p / q + g = (n+1) * r + IF (m < ix) THEN + mp = m + 1 + DO i = mp, ix + f = f * (g/i-r) + END DO + + ELSE IF (m > ix) THEN + ix1 = ix + 1 + DO i = ix1, m + f = f / (g/i-r) + END DO + END IF + + IF (v > f) THEN + GO TO 20 + ELSE + GO TO 110 + END IF + END IF + +! SQUEEZING USING UPPER AND LOWER BOUNDS ON LOG(F(X)) + + amaxp = (k/xnpq) * ((k*(k/3. + .625) + .1666666666666)/xnpq + half) + ynorm = -k * k / (2.*xnpq) + alv = LOG(v) + IF (alvynorm + amaxp) GO TO 20 + +! STIRLING'S (actually de Moivre's) FORMULA TO MACHINE ACCURACY FOR +! THE FINAL ACCEPTANCE/REJECTION TEST + + x1 = ix + 1 + f1 = fm + one + z = n + 1 - fm + w = n - ix + one + z2 = z * z + x2 = x1 * x1 + f2 = f1 * f1 + w2 = w * w + IF (alv - (xm*LOG(f1/x1) + (n-m+half)*LOG(z/w) + (ix-m)*LOG(w*p/(x1*q)) + & + (13860.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320. + & + (13860.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320. + & + (13860.-(462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320. + & + (13860.-(462.-(132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.) > zero) THEN + GO TO 20 + ELSE + GO TO 110 + END IF + +ELSE +! INVERSE CDF LOGIC FOR MEAN LESS THAN 30 + IF (first) THEN + qn = q ** n + r = p / q + g = r * (n+1) + END IF + + 90 ix = 0 + f = qn + CALL RANDOM_NUMBER(u) + 100 IF (u >= f) THEN + IF (ix > 110) GO TO 90 + u = u - f + ix = ix + 1 + f = f * (g/ix - r) + GO TO 100 + END IF +END IF + +110 IF (pp > half) ix = n - ix +ival = ix +RETURN + +END FUNCTION random_binomial2 + + + + +FUNCTION random_neg_binomial(sk, p) RESULT(ival) + +! Adapted from Fortran 77 code from the book: +! Dagpunar, J. 'Principles of random variate generation' +! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + +! FUNCTION GENERATES A RANDOM NEGATIVE BINOMIAL VARIATE USING UNSTORED +! INVERSION AND/OR THE REPRODUCTIVE PROPERTY. + +! SK = NUMBER OF FAILURES REQUIRED (Dagpunar's words!) +! = the `power' parameter of the negative binomial +! (0 < REAL) +! P = BERNOULLI SUCCESS PROBABILITY +! (0 < REAL < 1) + +! THE PARAMETER H IS SET SO THAT UNSTORED INVERSION ONLY IS USED WHEN P <= H, +! OTHERWISE A COMBINATION OF UNSTORED INVERSION AND +! THE REPRODUCTIVE PROPERTY IS USED. + +REAL, INTENT(IN) :: sk, p +INTEGER :: ival + +! Local variables +! THE PARAMETER ULN = -LOG(MACHINE'S SMALLEST REAL NUMBER). + +REAL, PARAMETER :: h = 0.7 +REAL :: q, x, st, uln, v, r, s, y, g +INTEGER :: k, i, n + +IF (sk <= zero .OR. p <= zero .OR. p >= one) THEN + WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' + STOP +END IF + +q = one - p +x = zero +st = sk +IF (p > h) THEN + v = one/LOG(p) + k = st + DO i = 1,k + DO + CALL RANDOM_NUMBER(r) + IF (r > zero) EXIT + END DO + n = v*LOG(r) + x = x + n + END DO + st = st - k +END IF + +s = zero +uln = -LOG(vsmall) +IF (st > -uln/LOG(q)) THEN + WRITE(*, *) ' P IS TOO LARGE FOR THIS VALUE OF SK' + STOP +END IF + +y = q**st +g = st +CALL RANDOM_NUMBER(r) +DO + IF (y > r) EXIT + r = r - y + s = s + one + y = y*p*g/s + g = g + one +END DO + +ival = x + s + half +RETURN +END FUNCTION random_neg_binomial + + + +FUNCTION random_von_Mises(k, first) RESULT(fn_val) + +! Algorithm VMD from: +! Dagpunar, J.S. (1990) `Sampling from the von Mises distribution via a +! comparison of random numbers', J. of Appl. Statist., 17, 165-168. + +! Fortran 90 code by Alan Miller +! CSIRO Division of Mathematical & Information Sciences + +! Arguments: +! k (real) parameter of the von Mises distribution. +! first (logical) set to .TRUE. the first time that the function +! is called, or the first time with a new value +! for k. When first = .TRUE., the function sets +! up starting values and may be very much slower. + +REAL, INTENT(IN) :: k +LOGICAL, INTENT(IN) :: first +REAL :: fn_val + +! Local variables + +INTEGER :: j, n +INTEGER, SAVE :: nk +REAL, PARAMETER :: pi = 3.14159265 +REAL, SAVE :: p(20), theta(0:20) +REAL :: sump, r, th, lambda, rlast +REAL (dp) :: dk + +IF (first) THEN ! Initialization, if necessary + IF (k < zero) THEN + WRITE(*, *) '** Error: argument k for random_von_Mises = ', k + RETURN + END IF + + nk = k + k + one + IF (nk > 20) THEN + WRITE(*, *) '** Error: argument k for random_von_Mises = ', k + RETURN + END IF + + dk = k + theta(0) = zero + IF (k > half) THEN + +! Set up array p of probabilities. + + sump = zero + DO j = 1, nk + IF (j < nk) THEN + theta(j) = ACOS(one - j/k) + ELSE + theta(nk) = pi + END IF + +! Numerical integration of e^[k.cos(x)] from theta(j-1) to theta(j) + + CALL integral(theta(j-1), theta(j), p(j), dk) + sump = sump + p(j) + END DO + p(1:nk) = p(1:nk) / sump + ELSE + p(1) = one + theta(1) = pi + END IF ! if k > 0.5 +END IF ! if first + +CALL RANDOM_NUMBER(r) +DO j = 1, nk + r = r - p(j) + IF (r < zero) EXIT +END DO +r = -r/p(j) + +DO + th = theta(j-1) + r*(theta(j) - theta(j-1)) + lambda = k - j + one - k*COS(th) + n = 1 + rlast = lambda + + DO + CALL RANDOM_NUMBER(r) + IF (r > rlast) EXIT + n = n + 1 + rlast = r + END DO + + IF (n .NE. 2*(n/2)) EXIT ! is n even? + CALL RANDOM_NUMBER(r) +END DO + +fn_val = SIGN(th, (r - rlast)/(one - rlast) - half) +RETURN +END FUNCTION random_von_Mises + + + +SUBROUTINE integral(a, b, result, dk) + +! Gaussian integration of exp(k.cosx) from a to b. + +REAL (dp), INTENT(IN) :: dk +REAL, INTENT(IN) :: a, b +REAL, INTENT(OUT) :: result + +! Local variables + +REAL (dp) :: xmid, range, x1, x2, & + x(3) = (/0.238619186083197_dp, 0.661209386466265_dp, 0.932469514203152_dp/), & + w(3) = (/0.467913934572691_dp, 0.360761573048139_dp, 0.171324492379170_dp/) +INTEGER :: i + +xmid = (a + b)/2._dp +range = (b - a)/2._dp + +result = 0._dp +DO i = 1, 3 + x1 = xmid + x(i)*range + x2 = xmid - x(i)*range + result = result + w(i)*(EXP(dk*COS(x1)) + EXP(dk*COS(x2))) +END DO + +result = result * range +RETURN +END SUBROUTINE integral + + + +FUNCTION random_Cauchy() RESULT(fn_val) + +! Generate a random deviate from the standard Cauchy distribution + +REAL :: fn_val + +! Local variables +REAL :: v(2) + +DO + CALL RANDOM_NUMBER(v) + v = two*(v - half) + IF (ABS(v(2)) < vsmall) CYCLE ! Test for zero + IF (v(1)**2 + v(2)**2 < one) EXIT +END DO +fn_val = v(1) / v(2) + +RETURN +END FUNCTION random_Cauchy + + + +SUBROUTINE random_order(order, n) + +! Generate a random ordering of the integers 1 ... n. + +INTEGER, INTENT(IN) :: n +INTEGER, INTENT(OUT) :: order(n) + +! Local variables + +INTEGER :: i, j, k +REAL :: wk + +DO i = 1, n + order(i) = i +END DO + +! Starting at the end, swap the current last indicator with one +! randomly chosen from those preceeding it. + +DO i = n, 2, -1 + CALL RANDOM_NUMBER(wk) + j = 1 + i * wk + IF (j < i) THEN + k = order(i) + order(i) = order(j) + order(j) = k + END IF +END DO + +RETURN +END SUBROUTINE random_order + + + +SUBROUTINE seed_random_number(iounit) + +INTEGER, INTENT(IN) :: iounit + +! Local variables + +INTEGER :: k +INTEGER, ALLOCATABLE :: seed(:) + +CALL RANDOM_SEED(SIZE=k) +ALLOCATE( seed(k) ) + +WRITE(*, '(a, i2, a)')' Enter ', k, ' integers for random no. seeds: ' +READ(*, *) seed +WRITE(iounit, '(a, (7i10))') ' Random no. seeds: ', seed +CALL RANDOM_SEED(PUT=seed) + +DEALLOCATE( seed ) + +RETURN +END SUBROUTINE seed_random_number + + +END MODULE KPP_ROOT_Random + +MODULE KPP_ROOT_Integrator + USE KPP_ROOT_Random + USE KPP_ROOT_Parameters, ONLY : NVAR, NFIX, NREACT + USE KPP_ROOT_Global, ONLY : TIME, RCONST, Volume + USE KPP_ROOT_Stoichiom + USE KPP_ROOT_Stochastic + USE KPP_ROOT_Rates + USE KPP_ROOT_Random, ddp => dp + IMPLICIT NONE + +CONTAINS + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE TauLeap(Nsteps, Tau, T, SCT, NmlcV, NmlcF) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! +! Tau-leap stochastic integration +! INPUT: +! Nsteps = no. of tau-leap steps to be simulated +! Tau = time step length +! T = time +! SCT = stochastic rate constants +! NmlcV, NmlcF = no. of molecules for variable and fixed species +! OUTPUT: +! T = updated time (after Nsteps) +! NmlcV = updated no. of molecules for variable species +! +! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + IMPLICIT NONE +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + KPP_REAL:: T, Tau + INTEGER :: Nsteps + INTEGER :: NmlcV(NVAR), NmlcF(NFIX) + INTEGER :: i, j, irct, id, istep, Nfirings(NREACT) + REAL :: mu + KPP_REAL :: A(NREACT), SCT(NREACT), x + LOGICAL, SAVE :: First = .TRUE. + + DO istep = 1, Nsteps + + ! Propensity vector + CALL Propensity ( NmlcV, NmlcF, SCT, A ) + + ! Index of next reaction + DO irct = 1, NREACT + mu = A(irct)*Tau + Nfirings(irct) = random_Poisson(mu, First) + First = .TRUE. + END DO + + ! Update time with the leap interval + T = T + Tau; + + ! Directly update state vector + DO irct = 1, NREACT + DO i = CCOL_STOICM(irct), CCOL_STOICM(irct+1)-1 + id = IROW_STOICM(i) + NmlcV(id) = MAX(0, NmlcV(id) + Nfirings(irct)*INT(STOICM(i))) + END DO + END DO + + ! Update state vector + ! DO irct = 1, NREACT + ! DO j = 1, Nfirings(irct) + ! CALL MoleculeChange( irct, NmlcV ) + ! END DO + ! END DO + + END DO + +CONTAINS + + SUBROUTINE PropensityTemplate( T, NmlcV, NmlcF, Prop ) + KPP_REAL, INTENT(IN) :: T + INTEGER, INTENT(IN) :: NmlcV(NVAR), NmlcF(NFIX) + KPP_REAL, INTENT(OUT) :: Prop(NREACT) + KPP_REAL :: Tsave +! Update the stochastic reaction rates, which may be time dependent + Tsave = TIME + TIME = T + CALL Update_RCONST() + CALL StochasticRates( RCONST, Volume, SCT ) + CALL Propensity ( NmlcV, NmlcF, SCT, Prop ) + TIME = Tsave + END SUBROUTINE PropensityTemplate + +END SUBROUTINE TauLeap +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/readme b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/readme new file mode 100755 index 00000000..c2176aa0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/readme @@ -0,0 +1,3 @@ +Integrators in this directory have been contributed by KPP users. By +default, KPP will not search for integrators in this directory. To +activate them, move them into the int/ directory. diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.def new file mode 100755 index 00000000..85c194bf --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.def @@ -0,0 +1,5 @@ +#FUNCTION AGGREGATE +#JACOBIAN SPARSE_LU_ROW + +#DOUBLE ON +#INTFILE ros2_manual diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.f90 new file mode 100755 index 00000000..90b6424a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/int/user_contributed/ros2_manual.f90 @@ -0,0 +1,119 @@ +! Rosenbrock integrator with manual time step control +! Solve: d/dt c = f(t,c) + +! written by Edwin Spee, CWI, Amsterdam. Last update: July 28, 1997 +! email: Edwin.Spee@cwi.nl (http://edwin-spee.mypage.org/) +! adapted to KPP-2.1 by Rolf Sander, Max-Planck Institute, Mainz, Germany, 2005 +! +! Integration method for Ros2: +! C_{n+1} = C_n + 3/2 dt k_1 + 1/2 dt k_2 +! k_1 = S f(t_n, C_n) +! k_2 = S [f(t_{n+1},C_n + dt k_1) - 2 k_1] +! +! where g = 1.0 + sqrt(0.5_dp), +! S = (I - g dt J ) ^ {-1} +! with J the Jacobian + +MODULE KPP_ROOT_Integrator + + USE KPP_ROOT_Precision, ONLY: dp + + IMPLICIT NONE + PUBLIC + SAVE + + ! description of the error numbers IERR + CHARACTER(LEN=50), PARAMETER, DIMENSION(1) :: IERR_NAMES = (/ & + 'dummy value ' /) + +CONTAINS + + ! ************************************************************************** + + SUBROUTINE INTEGRATE( TIN, TOUT, & + ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U ) + + IMPLICIT NONE + + KPP_REAL, INTENT(IN) :: TIN ! TIN - Start Time + KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time + ! Optional input parameters and statistics + INTEGER, INTENT(IN), OPTIONAL :: ICNTRL_U(20) + KPP_REAL, INTENT(IN), OPTIONAL :: RCNTRL_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: ISTATUS_U(20) + KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20) + INTEGER, INTENT(OUT), OPTIONAL :: IERR_U + + CALL ROS2(TIN, TOUT) + + ! if optional parameters are given for output + ! use them to store information in them + IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = 0 + IF (PRESENT(RSTATUS_U)) THEN + RSTATUS_U(:) = 0._dp + RSTATUS_U(1)=TOUT ! put final time into RSTATUS_U + ENDIF + IF (PRESENT(IERR_U)) IERR_U = 1 ! dummy value + + END SUBROUTINE INTEGRATE + + ! ************************************************************************** + + SUBROUTINE ROS2(Tstart,Tend) + + USE KPP_ROOT_Jacobian, ONLY: Jac_SP + USE KPP_ROOT_Global, ONLY: VAR, & ! VARiable species + FIX, & ! FIXed species + RCONST ! rate coefficients + USE KPP_ROOT_JacobianSP, ONLY: LU_DIAG + USE KPP_ROOT_Function, ONLY: Fun + USE KPP_ROOT_LinearAlgebra, ONLY: KppDecomp, KppSolve + USE KPP_ROOT_Parameters, ONLY: NVAR, LU_NONZERO + + IMPLICIT NONE + + KPP_REAL, INTENT(IN) :: Tstart, Tend + + KPP_REAL :: dt ! time step + KPP_REAL :: k1(NVAR), k2(NVAR), w1(NVAR), g, jvs(LU_NONZERO) + INTEGER ising, i + + dt = Tend - Tstart + g = 1.0 + SQRT(0.5_dp) + CALL JAC_sp(VAR, FIX, RCONST, jvs) + jvs(1:LU_NONZERO) = -g*dt*jvs(1:LU_NONZERO) + + ! Rolf von Kuhlmann: + ! optionally cut this out and replace it by directly addressed statements + DO i=1,NVAR + jvs(LU_DIAG(i)) = jvs(LU_DIAG(i)) + 1.0_dp + END DO + + CALL KppDecomp (jvs, ising) + + IF (ising /= 0) THEN + PRINT *,'ising <> 0, dt=',dt + STOP + END IF + + CALL Fun(VAR, FIX, RCONST, k1 ) + + CALL KppSolve (jvs,k1) + + DO i = 1,NVAR + w1(i) = MAX(0.0_dp, VAR(i) + dt * k1(i) ) + END DO + + CALL Fun(w1, FIX, RCONST, k2 ) + + k2(1:NVAR) = k2(1:NVAR) - 2.0_dp*k1(1:NVAR) + CALL KppSolve (jvs,k2) + DO i = 1,NVAR + VAR(i) = MAX( 0.0_dp, VAR(i)+1.5_dp*dt*k1(i)+0.5_dp*dt*k2(i) ) + END DO + + END SUBROUTINE ROS2 + + ! ************************************************************************** + +END MODULE KPP_ROOT_Integrator diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/kpp_compile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/kpp_compile new file mode 100755 index 00000000..3f89e58b --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/kpp_compile @@ -0,0 +1,12 @@ +#!/bin/csh -f + + +setenv KPP_HOME `pwd` +set path=( `pwd`/bin $path ) + +echo $KPP_HOME +echo $path + +make + +exit 0 diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/atoms b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/atoms new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/atoms @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.def new file mode 100755 index 00000000..287ce391 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.def @@ -0,0 +1,63 @@ +#include atoms +#include ./cbm4.spc +#include ./cbm4.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL + +#MONITOR O3; + +#INITVALUES + CFACTOR = 2.55E+10; {ppb-to-mcm} + ALL_SPEC = 1.0E-8; +{Variable species} + NO = 50.0; + NO2 = 20.0; + HONO = 1.0; + O3 = 100.0; + HCHO = 10.0; + ALD2 = 10; + PAN = 1.0; + PAR = 50.0; + OLE = 10.0; + ETH = 10.0; + TOL = 10.0; + XYL = 10.0; + ISOP = 10.0; + CO = 300.0; +{Fixed species} + H2O = 1.25E+8; {30 %} + + +#INLINE F77_INIT + TSTART = 12.D0*3600.D0 + TEND = TSTART + 24.D0*3600.D0 * 5 + DT = 3600.D0 + TEMP = 288.15 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 12.D0*3600.D0 + TEND = TSTART + 24.D0*3600.D0 * 5 + DT = 3600.D0 + TEMP = 288.15 +#ENDINLINE + +#INLINE MATLAB_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 24.0*3600.0*5; + DT = 3600.0; + TEMP = 288.15; +#ENDINLINE + +#INLINE C_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 24.0*3600.0*5; + DT = 3600.0; + TEMP = 288.15; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.eqn new file mode 100755 index 00000000..78bd9fb4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.eqn @@ -0,0 +1,119 @@ +#EQUATIONS {of the CBM-IV mechanism} + +{ 1.} NO2 + hv = NO + O : 8.89E-3*SUN ; +{ 2.} O {+ O2 + M} = O3 : ARR2(1.4E+3, 1175.0) ; +{ 3.} O3 + NO = NO2 : ARR2(1.8E-12, -1370.0) ; +{ 4.} O + NO2 = NO : 9.3E-12 ; +{ 5.} O + NO2 = NO3 : ARR2(1.6E-13, 687.0) ; +{ 6.} O + NO = NO2 : ARR2(2.2E-13, 602.0) ; +{ 7.} O3 + NO2 = NO3 : ARR2(1.2E-13, -2450.0) ; +{ 8.} O3 + hv = O : 3.556E-04*SUN ; {4.0E-2*RCONST(1) ;} +{ 9.} O3 + hv = O1D : 2.489E-05*SUN ; {2.8E-3*RCONST(1) ;} +{10.} O1D = O : ARR2(1.9E+8, 390.0) ; + +{11.} O1D + H2O = 2OH : 2.2E-10 ; +{12.} O3 + OH = HO2 : ARR2(1.6E-12, -940.0) ; +{13.} O3 + HO2 = OH : ARR2(1.4E-14, -580.0) ; +{14.} NO3 + hv = 0.89 NO2 + 0.89 O + + 0.11 NO : 1.378E-01*SUN ; {15.5*RCONST(1);} +{15.} NO3 + NO = 2 NO2 : ARR2(1.3E-11, 250.0) ; +{16.} NO3 + NO2 = NO + NO2 : ARR2(2.5E-14, -1230.0) ; +{17.} NO3 + NO2 = N2O5 : ARR2(5.3E-13, 256.0) ; +{18.} N2O5 + H2O = 2 HNO3 : 1.3E-21 ; +{19.} N2O5 = NO3 + NO2 : ARR2(3.5E+14, -10897.0) ; +{20.} 2 NO = 2 NO2 : ARR2(1.8E-20, 530.0) ; + + +{21.} NO + NO2 + H2O = 2 HONO : 4.4E-40 ; +{22.} OH + NO = HONO : ARR2(4.5E-13, 806.0) ; +{23.} HONO + hv = OH + NO : 1.511e-03*SUN ; {0.17*RCONST(1);} +{24.} OH + HONO = NO2 : 6.6E-12 ; +{25.} 2 HONO = NO + NO2 : 1.0E-20 ; +{26.} OH + NO2 = HNO3 : ARR2(1.0E-12, 713.0) ; +{27.} OH + HNO3 = NO3 : ARR2(5.1E-15, 1000.0) ; +{28.} HO2 + NO = OH + NO2 : ARR2(3.7E-12, 240.0) ; +{29.} HO2 + NO2 = PNA : ARR2(1.2E-13, 749.0) ; +{30.} PNA = HO2 + NO2 : ARR2(4.8E+13, -10121.0) ; + +{31.} OH + PNA = NO2 : ARR2(1.3E-12, 380.0) ; +{32.} 2 HO2 = H2O2 : ARR2(5.9E-14, 1150.0) ; +{33.} 2 HO2 + H2O = H2O2 : ARR2(2.2E-38, 5800.0) ; +{34.} H2O2 + hv = 2 OH : 6.312E-06*SUN ; {7.1E-4*RCONST(1);} +{35.} OH + H2O2 = HO2 : ARR2(3.1E-12, -187.0) ; +{36.} OH + CO = HO2 : 2.2E-13 ; +{37.} HCHO + OH = HO2 + CO : 1.0E-11 ; +{38.} HCHO + hv {+ 2 O2} = 2 HO2 + CO : 2.845E-05*SUN ; {3.2E-3*RCONST(1);} +{39.} HCHO + hv = CO : 3.734E-05*SUN ; {4.2E-3*RCONST(1);} +{40.} HCHO + O = OH + HO2 + CO : ARR2(3.0E-11, -1550.0) ; + +{41.} HCHO + NO3 = HNO3 + + HO2 + CO : 6.3E-16 ; +{42.} ALD2 + O = C2O3 + OH : ARR2(1.2E-11, -986.0) ; +{43.} ALD2 + OH = C2O3 : ARR2(7.0E-12, 250.0) ; +{44.} ALD2 + NO3 = C2O3 + HNO3 : 2.5E-15 ; +{45.} ALD2 + hv {+ 2 O2} = HCHO + XO2 + + CO + 2 HO2 : 4.00E-06*SUN ; {4.5E-4*RCONST(1);} +{46.} C2O3 + NO = HCHO + XO2 + + HO2 + NO2 : ARR2(5.4E-12, 250.0) ; +{47.} C2O3 + NO2 = PAN : ARR2(8.0E-20, 5500.0) ; +{48.} PAN = C2O3 + NO2 : ARR2(9.4E+16, -14000.0) ; +{49.} 2 C2O3 = 2 HCHO + 2 XO2 + 2 HO2 : 2.0E-12 ; +{50.} C2O3 + HO2 = 0.79 HCHO + + 0.79 XO2 + 0.79 HO2 + 0.79 OH : 6.5E-12 ; + +{51.} OH = HCHO + XO2 + HO2 : ARR2(1.1E+2, -1710.0) ; +{52.} PAR + OH = 0.87 XO2 + 0.13 XO2N + + 0.11 HO2 + 0.11 ALD2 + + 0.76 ROR - 0.11 PAR : 8.1E-13 ; +{53.} ROR = 1.1 ALD2 + 0.96 XO2 + + 0.94 HO2 + 0.04 XO2N + + 0.02 ROR - 2.10 PAR : ARR2(1.0E+15, -8000.0) ; +{54.} ROR = HO2 : 1.6E+03 ; +{55.} ROR + NO2 = PROD : 1.5E-11 ; +{56.} O + OLE = 0.63 ALD2 + 0.38 HO2 + + 0.28 XO2 + 0.3 CO + + 0.2 HCHO + 0.02 XO2N + + 0.22 PAR + 0.2 OH : ARR2(1.2E-11, -324.0) ; +{57.} OH + OLE = HCHO + ALD2 + XO2 + + HO2 - PAR : ARR2(5.2E-12, 504.0) ; +{58.} O3 + OLE = 0.5 ALD2 + 0.74 HCHO + + 0.33 CO + 0.44 HO2 + + 0.22 XO2 + + 0.1 OH - PAR : ARR2(1.4E-14, -2105.0) ; +{59.} NO3 + OLE = 0.91 XO2 + HCHO + + ALD2 + 0.09 XO2N + + NO2 - PAR : 7.7E-15 ; +{60.} O + ETH = HCHO + 0.7 XO2 + CO + + 1.7 HO2 + 0.3 OH : ARR2(1.0E-11, -792.0) ; + +{61.} OH + ETH = XO2 + 1.56 HCHO + HO2 + 0.22 ALD2 : ARR2(2.0E-12, 411.0) ; +{62.} O3 + ETH = HCHO + 0.42 CO + 0.12 HO2 : ARR2(1.3E-14, -2633.0) ; +{63.} OH + TOL = 0.08 XO2 + 0.36 CRES + + 0.44 HO2 + 0.56 TO2 : ARR2(2.1E-12, 322.0) ; +{64.} TO2 + NO = 0.9 NO2 + 0.9 OPEN + 0.9 HO2 : 8.1E-12 ; +{65.} TO2 = HO2 + CRES : 4.20 ; +{66.} OH + CRES = 0.4 CRO + 0.6 XO2 + 0.6 HO2 + 0.3 OPEN : 4.1E-11 ; +{67.} NO3 + CRES = CRO + HNO3 : 2.2E-11 ; +{68.} CRO + NO2 = PROD : 1.4E-11 ; +{69.} OH + XYL = 0.7 HO2 + 0.5 XO2 + 0.2 CRES + 0.8 MGLY + + 1.10 PAR + 0.3 TO2 : ARR2(1.7E-11, 116.0) ; +{70.} OH + OPEN = XO2 + C2O3 + 2 HO2 + 2 CO + HCHO : 3.0E-11 ; + +{71.} OPEN + hv = C2O3 + CO + HO2 : 5.334E-05*SUN ; {6.0E-3*RCONST(1);} +{72.} O3 + OPEN = 0.03 ALD2 + 0.62 C2O3 + + 0.7 HCHO + 0.03 XO2 + 0.69 CO + + 0.08 OH + 0.76 HO2 + 0.2 MGLY : ARR2(5.4E-17, -500.0) ; +{73.} OH + MGLY = XO2 + C2O3 : 1.70E-11 ; +{74.} MGLY + hv = C2O3 + CO + HO2 : 1.654E-04*SUN ; {1.86E-2*RCONST(1);} +{75.} O + ISOP = 0.6 HO2 + 0.8 ALD2 + 0.55 OLE + 0.5 XO2 + + 0.5 CO + 0.45 ETH + 0.9 PAR : 1.80E-11 ; +{76.} OH + ISOP = HCHO + XO2 + 0.67 HO2 + + 0.4 MGLY + 0.2 C2O3 + + ETH + 0.2 ALD2 + 0.13 XO2N : 9.6E-11 ; +{77.} O3 + ISOP = HCHO + 0.4 ALD2 + 0.55 ETH + 0.2 MGLY + + 0.06 CO + 0.1 PAR + 0.44 HO2 + 0.1 OH : 1.2E-17 ; +{78.} NO3 + ISOP = XO2N : 3.2E-13 ; +{79.} XO2 + NO = NO2 : 8.1E-12 ; +{80.} 2 XO2 = PROD : ARR2(1.7E-14, 1300.0) ; +{81.} XO2N + NO = PROD : 6.8E-13 ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.spc new file mode 100755 index 00000000..76321bca --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/cbm4.spc @@ -0,0 +1,41 @@ +#DEFVAR + NO = N + O ; {nitric oxide} + NO2 = N + 2O ; {nitrogen dioxide} + NO3 = N + 3O ; {nitrogen trioxide} + N2O5 = 2N + 5O ; {dinitrogen pentoxide} + HONO = H + 2O + N ; {nitrous acid} + HNO3 = H + N + 3O ; { nitric acid } + PNA = H + 4 O + N ; {HO2NO2 peroxynitric acid} + O1D = O ; {oxygen atomic first singlet state} + O = O ; {oxygen atomic ground state (3P)} + OH = O + H ; {hydroxyl radical} + O3 = 3O ; {ozone} + HO2 = H + 2O ; {perhydroxyl radical} + H2O2 = 2H + 2O ; {hydrogen peroxide} + HCHO = C + 2H + O ; {formalydehyde} + ALD2 = IGNORE ; {high molecular weight aldehides} + C2O3 = 2C + 3H + 3O ; {CH3CO(O)OO peroxyacyl radical} + PAN = 2C + 3H + 5O + N ; {CH3C(O)OONO2, peroxyacyl nitrate} + PAR = IGNORE ; {parafin carbon bond} + ROR = IGNORE ; {secondary organic oxy radical} + OLE = IGNORE ; {olefinic carbon bond} + ETH = 2C + 4H ; {CH2=CH2 ethene} + TOL = 7C + 8H ; {C6H5-CH3 toluene} + CRES = IGNORE ; {cresol and h.m.w. phenols} + TO2 = IGNORE ; {toluene-hydroxyl radical adduct} + CRO = IGNORE ; {methylphenoxy radical} + OPEN = IGNORE ; {h.m.w. aromatic oxidation ring fragment} + XYL = 8C + 10H ; {C6H4-(CH3)2 xylene} + MGLY = 3C + 4H + 2O ; {CH3C(O)C(O)H methylglyoxal} + ISOP = IGNORE ; {isoprene} + XO2 = IGNORE ; {NO-to-NO2 operation} + XO2N = IGNORE ; {NO-to-nitrate operation} + CO = C + O ; {carbon monoxide} + +#DEFFIX + H2O = H + 2O ; {water} + H2 = 2H ; {molecular hydrogen} + O2 = 2O ; {molecular oxygen} + N2 = 2N ; {molecular nitrogen} + CH4 = C + 4H ; {methane} + M = IGNORE ; {third body} \ No newline at end of file diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.def new file mode 100755 index 00000000..88b54c93 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.def @@ -0,0 +1,87 @@ +#include saprc99.spc +#include saprc99.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER matlab +#HESSIAN ON} + +#LOOKATALL + +#MONITOR O3; NO; NO2; ETHENE; + +#INITVALUES + + CFACTOR = 2.4476e+13; + + ALL_SPEC = 0.0e0; + NO = 1.0e-1; + NO2 = 5.0e-2; + HONO = 1.e-3; + SO2 = 5.e-2; + HCHO = 1.121e-2; + CCHO = 2.316e-3; + RCHO = 1.72e-3; + ACET = 5.07e-3; + MEK = 3.26e-3; + MEOH = 5.89e-3; + GLY = 1.21e-4; + MGLY = 8.37e-5; + PHEN = 6.06e-4; + CRES = 5.60e-4; + BALD = 7.51e-5; + METHACRO = 1.30e-3; + ISOPROD = 8.93e-5; + PROD2 = 1.93e-3; + ETHENE = 1.89e-2; + ISOPRENE = 4.33e-4; + ALK1 = 1.167e-2; + ALK2 = 1.88e-2; + ALK3 = 4.69e-2; + ALK4 = 4.17e-2; + ALK5 = 3.06e-2; + ARO1 = 1.18e-2; + ARO2 = 8.74e-3; + OLE1 = 1.04e-2; + OLE2 = 7.97e-3; + TERP = 8.20e-4; + XC = 0.2E0; + CCO_OH = 1.16e-3; + RCO_OH = 3.92e-4; + HCOOH = 6.77e-4; + O3P = 7.843e-9; + H2O = 2.0e+04; + O2 = 2.09e+5; + AIR = 1.0e+6; + CH4 = 1.0e0; + +#INLINE F77_INIT + TSTART = 12.0D0*3600.0D0 + TEND = TSTART + 120.0D0*3600.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 12.0d0*3600.0d0 + TEND = TSTART + 120.0d0*3600.0d0 + DT = 3600.d0 + TEMP = 300.0d0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 12*3600; + TEND = TSTART + 120*3600; + DT = 3600; + TEMP = 300; +#ENDINLINE + +#INLINE C_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 120.0*3600.0; + DT = 3600.0; + TEMP = 300.0; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.eqn new file mode 100755 index 00000000..143fb5b0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.eqn @@ -0,0 +1,354 @@ +#Equations + +{1} NO2 + hv = NO + O3P : 6.69e-1*(SUN/60.0e0); +{2} O3P + O2 + AIR = O3 : ARR(5.68e-34,0.0e0,-2.80e0); +{3} O3P + O3 = 2O2 : ARR(8.00e-12,2060.0e0,0.0e0); +{4} O3P + NO + AIR = NO2 : ARR(1.00e-31,0.0e0,-1.60e0); +{5} O3P + NO2 = NO : ARR(6.50e-12,-120.0e0,0.0e0); +{6} O3P + NO2 = NO3 : FALL(9.00e-32,0.0e0,-2.00e0,2.20e-11,0.0e0,0.0e0,0.80e0); +{7} O3 + NO = NO2 : ARR(1.80e-12,1370.0e0,0.0e0); +{8} O3 + NO2 = NO3 : ARR(1.40e-13,2470.0e0,0.0e0); +{9} NO + NO3 = 2NO2 : ARR(1.80e-11,-110.0e0,0.0e0); +{10} NO + NO + O2 = 2NO2 : ARR(3.30e-39,-530.0e0,0.0e0); +{11} NO2 + NO3 = N2O5 : FALL(2.80e-30,0.0e0,-3.50e0,2.00e-12,0.0e0,0.20e0,0.45e0); +{12} N2O5 = NO2 + NO3 : FALL(1.e-3,11000.0e0,-3.5e0,9.7e+14,11080.0e0,0.1e0,0.45e0); +{13} N2O5 + H2O = 2HNO3 : (2.60e-22); +{14} NO2 + NO3 = NO + NO2 : ARR(4.50e-14,1260.0e0,0.0e0); +{15} NO3 + hv = NO : 1.59e0*(SUN/60.0e0); +{16} NO3 + hv = NO2 + O3P : 1.50e+1*(SUN/60.0e0); +{17} O3 + hv = O3P : 3.76e-2*(SUN/60.0e0); +{18} O3 + hv = O1D : 4.19e-3*(SUN/60.0e0); +{19} O1D + H2O = 2OH : (2.20e-10); +{20} O1D + AIR = O3P : ARR(2.09e-11,-95.0e0,0.0e0); +{21} OH + NO = HONO : FALL(7.00e-31,0.0e0,-2.60e0,3.60e-11,0.0e0,-0.10e0,0.60e0); +{22} HONO + hv = OH + NO : 1.27e-1*(SUN/60.0e0); +{23} HONO + hv = HO2 + NO2 : 1.60e-2*(SUN/60.0e0); +{24} OH + HONO = NO2 : ARR(2.70e-12,-260.0e0,0.0e0); +{25} OH + NO2 = HNO3 : FALL(2.43e-30, 0.0e0,-3.10e0,1.67e-11,0.0e0,-2.10e0,0.60e0); +{26} OH + NO3 = HO2 + NO2 : (2.00e-11); +{27} OH + HNO3 = NO3 : EP2(7.20e-15,-785.0e0,4.10e-16,-1440.0e0,1.90e-33,-725.0e0); +{28} HNO3 + hv = OH + NO2 : 5.40e-5*(SUN/60.0e0); +{29} OH + CO = HO2 : EP3(1.30e-13,0.0e0,3.19e-33,0.0e0); +{30} OH + O3 = HO2 : ARR(1.90e-12,1000.0e0,0.0e0); +{31} HO2 + NO = OH + NO2 : ARR(3.40e-12,-270.0e0,0.0e0); +{32} HO2 + NO2 = HNO4 : FALL(1.80e-31,0.0,-3.20,4.70e-12,0.0e0,0.0,0.6); +{33} HNO4 = HO2 + NO2 : FALL(4.10e-05,10650.0,0.0,5.7e+15,11170.0,0.0,0.5); +{34} HNO4 + hv = 0.61HO2 + 0.61NO2 + 0.39OH + + 0.39NO3 : 4.69e-4*(SUN/60.0e0); +{35} HNO4 + OH = NO2 : ARR(1.50e-12,-360.0e0,0.0e0); +{36} HO2 + O3 = OH : ARR(1.40e-14,600.0e0,0.0e0); +{37} HO2 + HO2 = H2O2 : EP3(2.20e-13,-600.0e0,1.85e-33,-980.0e0); +{38} HO2 + HO2 + H2O = H2O2 : EP3(3.08e-34,-2800.0e0,2.59e-54,-3180.0e0); +{39} NO3 + HO2 = 0.8OH + 0.8NO2 + 0.2HNO3 : (4.00e-12); +{40} NO3 + NO3 = 2NO2 : ARR(8.50e-13,2450.0e0,0.0e0); +{41} H2O2 + hv = 2OH : 5.64e-4*(SUN/60.0e0); +{42} H2O2 + OH = HO2 : ARR(2.90e-12,160.0e0,0.0e0); +{43} OH + HO2 = H2O + O2 : ARR(4.80e-11,-250.0e0,0.0e0); +{44} OH + SO2 = HO2 + H2SO4 : FALL(4.00e-31,0.0e0,-3.30e0,2.00e-12,0.0e0,0.0e0,0.45e0); +{45} OH + H2 = HO2 : ARR(7.70e-12,2100.0e0,0.0e0); +{46} C_O2 + NO = NO2 + HCHO + HO2 : ARR(2.80e-12,-285.0e0,0.0e0); +{47} C_O2 + HO2 = COOH : ARR(3.80e-13,-780.0e0,0.0e0); +{48} C_O2 + NO3 = HCHO + HO2 + NO2 : (1.30e-12); +{49} C_O2 + C_O2 = MEOH + HCHO : ARR(2.45e-14,-710.0e0,0.0e0); +{50} C_O2 + C_O2 = 2HCHO + 2HO2 : ARR(5.90e-13,509.0e0,0.0e0); +{51} RO2_R + NO = NO2 + HO2 : ARR(2.70e-12,-360.0e0,0.0e0); +{52} RO2_R + HO2 = ROOH : ARR(1.90e-13,-1300.0e0,0.0e0); +{53} RO2_R + NO3 = NO2 + HO2 : (2.30e-12); +{54} RO2_R + C_O2 = HO2 + 0.75HCHO + + 0.25MEOH : (2.00e-13); +{55} RO2_R + RO2_R = HO2 : (3.50e-14); +{56} R2O2 + NO = NO2 : ARR(2.70e-12,-360.0e0,0.0e0); +{57} R2O2 + HO2 = HO2 : ARR(1.90e-13,-1300.0e0,0.0e0); +{58} R2O2 + NO3 = NO2 : (2.30e-12); +{59} R2O2 + C_O2 = C_O2 : (2.00e-13); +{60} R2O2 + RO2_R = RO2_R : (3.50e-14); +{61} R2O2 + R2O2 = 2R2O2 : (0.0e0); +{62} RO2_N + NO = RNO3 : ARR(2.70e-12,-360.0e0,0.0e0); +{63} RO2_N + HO2 = ROOH : ARR(1.90e-13,-1300.0e0,0.0e0); +{64} RO2_N + C_O2 = HO2 + 0.25MEOH + + 0.5MEK + 0.5PROD2 + 0.75HCHO : (2.00e-13); +{65} RO2_N + NO3 = NO2 + HO2 + MEK : (2.30e-12); +{66} RO2_N + RO2_R = HO2 + 0.5MEK + + 0.5PROD2 : (3.50e-14); +{67} RO2_N + R2O2 = RO2_N : (3.50e-14); +{68} RO2_N + RO2_N = MEK + HO2 + PROD2 : (3.50e-14); +{69} CCO_O2 + NO2 = PAN : FALL(2.70e-28,0.0e0,-7.10e0,1.20e-11,0.0e0,-0.90e0,0.30e0); +{70} PAN = CCO_O2 + NO2 : FALL(4.90e-3,12100.0e0,0.0e0,4.0e+16,13600.0e0,0.e0,0.3e0); +{71} CCO_O2 + NO = C_O2 + NO2 : ARR(7.80e-12,-300.0e0,0.0e0); +{72} CCO_O2 + HO2 = 0.75CCO_OOH + + 0.25CCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{73} CCO_O2 + NO3 = C_O2 + NO2 : (4.00e-12); +{74} CCO_O2 + C_O2 = CCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{75} CCO_O2 + RO2_R = CCO_OH : (7.50e-12); +{76} CCO_O2 + R2O2 = CCO_O2 : (7.50e-12); +{77} CCO_O2 + RO2_N = CCO_OH + PROD2 : (7.50e-12); +{78} CCO_O2 + CCO_O2 = 2C_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{79} RCO_O2 + NO2 = PAN2 : ARR(1.20e-11,0.0e0,-0.90e0); +{80} PAN2 = RCO_O2 + NO2 : ARR(2.00e+15,12800.0e0,0.0e0); +{81} RCO_O2 + NO = NO2 + CCHO + RO2_R : ARR(1.25e-11,-240.0e0,0.0e0); +{82} RCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{83} RCO_O2 + NO3 = NO2 + CCHO + RO2_R : (4.00e-12); +{84} RCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{85} RCO_O2 + RO2_R = RCO_OH : (7.50e-12); +{86} RCO_O2 + R2O2 = RCO_O2 : (7.50e-12); +{87} RCO_O2 + RO2_N = RCO_OH + PROD2 : (7.50e-12); +{88} RCO_O2 + CCO_O2 = C_O2 + CCHO + RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{89} RCO_O2 + RCO_O2 = 2CCHO + 2RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{90} BZCO_O2 + NO2 = PBZN : (1.37e-11); +{91} PBZN = BZCO_O2 + NO2 : ARR(7.90e+16,14000.0e0,0.0e0); +{92} BZCO_O2 + NO = NO2 + BZ_O + R2O2 : ARR(1.25e-11,-240.0e0,0.0e0); +{93} BZCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{94} BZCO_O2 + NO3 = NO2 + BZ_O + R2O2 : (4.00e-12); +{95} BZCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{96} BZCO_O2 + RO2_R = RCO_OH : (7.50e-12); +{97} BZCO_O2 + R2O2 = BZCO_O2 : (7.50e-12); +{98} BZCO_O2 + RO2_N = RCO_OH + PROD2 : (7.50e-12); +{99} BZCO_O2 + CCO_O2 = C_O2 + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{100} BZCO_O2 + RCO_O2 = CCHO + RO2_R + + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{101} BZCO_O2 + BZCO_O2 = 2BZ_O + 2R2O2: ARR(2.90e-12,-500.0e0,0.0e0); +{102} MA_RCO3 + NO2 = MA_PAN : ARR(1.20e-11,0.0e0,-0.90e0); +{103} MA_PAN = MA_RCO3 + NO2 : ARR(1.60e+16,13486.0e0,0.0e0); +{104} MA_RCO3 + NO = NO2 + HCHO + CCO_O2 : ARR(1.25e-11,-240.0e0,0.0e0); +{105} MA_RCO3 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{106} MA_RCO3 + NO3 = NO2 + HCHO + CCO_O2 : (4.00e-12); +{107} MA_RCO3 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{108} MA_RCO3 + RO2_R = RCO_OH : (7.50e-12); +{109} MA_RCO3 + R2O2 = MA_RCO3 : (7.50e-12); +{110} MA_RCO3 + RO2_N = 2RCO_OH : (7.50e-12); +{111} MA_RCO3 + CCO_O2 = C_O2 + HCHO + + CCO_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{112} MA_RCO3 + RCO_O2 = HCHO + CCO_O2 + + CCHO + RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{113} MA_RCO3 + BZCO_O2 = HCHO + CCO_O2 + + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{114} MA_RCO3 + MA_RCO3 = 2HCHO + 2CCO_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{115} TBU_O + NO2 = RNO3 : (2.40e-11); +{116} TBU_O = ACET + C_O2 : ARR(7.50e+14,8152.0e0,0.0e0); +{117} BZ_O + NO2 = NPHE : ARR(2.30e-11,-150.0e0,0.0e0); +{118} BZ_O + HO2 = PHEN : ARR(1.90e-13,-1300.0e0,0.0e0); +{119} BZ_O = PHEN : (1.00e-03); +{120} BZNO2_O + NO2 = 2XN + 6XC: ARR(7.50e+14,8152.0e0,0.0e0); +{121} BZNO2_O + HO2 = NPHE : ARR(2.30e-11,-150.0e0,0.0e0); +{122} BZNO2_O = NPHE : ARR(1.90e-13,-1300.0e0,0.0e0); +{123} HCHO + hv = 2HO2 + CO : 2.32e-3*(SUN/60.0e0); +{124} HCHO + hv = CO : 3.15e-3*(SUN/60.0e0); +{125} HCHO + OH = HO2 + CO : ARR(8.60e-12,-20.0e0,0.0e0); +{126} HCHO + HO2 = HOCOO : ARR(9.70e-15,-625.0e0,0.0e0); +{127} HOCOO = HO2 + HCHO : ARR(2.40e+12,7000.0e0,0.0e0); +{128} HOCOO + NO = HCOOH + NO2 + HO2 : ARR(2.80e-12,-285.0e0,0.0e0); +{129} HCHO + NO3 = HNO3 + HO2 + CO : ARR(2.00e-12,2431.0e0,0.0e0); +{130} CCHO + OH = CCO_O2 : ARR(5.60e-12,-310.0e0,0.0e0); +{131} CCHO +hv = CO + HO2 + C_O2 : 4.16e-4*(SUN/60.0e0); +{132} CCHO + NO3 = HNO3 + CCO_O2 : ARR(1.40e-12,1860.0e0,0.0e0); +{133} RCHO + OH = 0.034RO2_R + 0.001RO2_N + + 0.965RCO_O2 + 0.034CO+ 0.034CCHO : (2.00e-11); +{134} RCHO + hv = CCHO + RO2_R + CO + HO2 : 1.40e-3*(SUN/60.0e0); +{135} RCHO + NO3 = HNO3 + RCO_O2 : ARR(1.40e-12,1771.0e0,0.0e0); +{136} ACET + OH = HCHO + CCO_O2 + R2O2 : ARR(1.10e-12,520.0e0,0.0e0); +{137} ACET + hv = CCO_O2 + C_O2 : 4.16e-5*(SUN/60.0e0); +{138} MEK + OH = 0.37RO2_R + 0.042RO2_N + + 0.616R2O2+ 0.492CCO_O2 + + 0.096RCO_O2 + 0.115HCHO + + 0.482CCHO + 0.37RCHO : ARR(1.30e-12,25.0e0,2.0e0); +{139} MEK + hv = CCO_O2 + CCHO + RO2_R : 9.49e-4*(1.50e-1*SUN/60.0e0); +{140} MEOH + OH = HCHO + HO2 : ARR(3.10e-12,360.0e0,2.0e0); +{141} COOH + OH = 0.35HCHO + 0.35OH + + 0.65C_O2 : ARR(2.90e-12,-190.0e0,0.0e0); +{142} COOH + hv = HCHO + HO2 + OH : 3.94e-4*(SUN/60.0e0); +{143} ROOH + OH = RCHO + 0.34RO2_R + + 0.66OH : (1.10e-11); +{144} ROOH + hv = RCHO + HO2 + OH : 3.94e-4*(SUN/60.0e0); +{145} GLY + hv = 2CO+ 2HO2 : 8.93e-3*(SUN/60.0e0); +{146} GLY + hv = HCHO + CO : 1.81e-1*(6.00e-3*SUN/60.0e0); +{147} GLY + OH = 0.63HO2 + 1.26CO+ + 0.37RCO_O2 : (1.10e-11); +{148} GLY + NO3 = HNO3 + 0.63HO2 + + 1.26CO+ 0.37RCO_O2 : ARR(2.80e-12,2376.0e0,0.0e0); +{149} MGLY + hv = HO2 + CO + CCO_O2 : 1.10e-2*(SUN/60.0e0); +{150} MGLY + OH = CO + CCO_O2 : 1.50e-11; +{151} MGLY + NO3 = HNO3 + CO + CCO_O2 : ARR(1.40e-12,1895.0e0,0.0e0); +{152} BACL + hv = 2CCO_O2 : 1.90e-2*(SUN/60.0e0); +{153} PHEN + OH = 0.24BZ_O + 0.76RO2_R + + 0.23GLY : (2.63e-11); +{154} PHEN + NO3 = HNO3 + BZ_O : (3.78e-12); +{155} CRES + OH = 0.24BZ_O + 0.76RO2_R + + 0.23MGLY : (4.20e-11); +{156} CRES + NO3 = HNO3 + BZ_O : (1.37e-11); +{157} NPHE + NO3 = HNO3 + BZNO2_O : (3.78e-12); +{158} BALD + OH = BZCO_O2 : (1.29e-11); +{159} BALD + hv = 7XC: 6.22e-2*(5.00e-2*SUN/60.0e0); +{160} BALD + NO3 = HNO3 + BZCO_O2 : ARR(1.40e-12,1872.0e0,0.0e0); +{161} METHACRO + OH = 0.5RO2_R + 0.416CO+ + 0.084HCHO + 0.416MEK + + 0.084MGLY + 0.5MA_RCO3 : ARR(1.86e-11,-176.0e0,0.0e0); +{162} METHACRO + O3 = 0.008HO2 + 0.1RO2_R + + 0.208OH + 0.1RCO_O2 + 0.45CO+ + 0.2HCHO + 0.9MGLY + 0.333HCOOH : ARR(1.36e-15,2114.0e0,0.0e0); +{163} METHACRO + NO3 = 0.5HNO3 + 0.5RO2_R + + 0.5CO+ 0.5MA_RCO3 : ARR(1.50e-12,1726.0e0,0.0e0); +{164} METHACRO + O3P = RCHO : (6.34e-12); +{165} METHACRO + hv = 0.34HO2 + 0.33RO2_R + + 0.33OH + 0.67CCO_O2 + 0.67CO+ + 0.67HCHO + 0.33MA_RCO3 : 3.32e-2*(4.10e-3*SUN/60.0e0); +{166} MVK + OH = 0.3RO2_R + 0.025RO2_N + + 0.675R2O2+ 0.675CCO_O2 + + 0.3HCHO + 0.675RCHO + 0.3MGLY : ARR(4.14e-12,-453.0e0,0.0e0); +{167} MVK + O3 = 0.064HO2 + 0.05RO2_R + + 0.164OH + 0.05RCO_O2 + 0.475CO+ + 0.1HCHO + 0.95MGLY + 0.351HCOOH : ARR(7.51e-16,1520.0e0,0.0e0); +{168} MVK + O3P = 0.45RCHO + 0.55MEK : (4.32e-12); +{169} MVK + hv = 0.3C_O2 + 0.7CO+ 0.7PROD2 + + 0.3MA_RCO3 : 3.32e-2*(2.10e-3*SUN/60.0e0); +{170} ISOPROD + OH = 0.67RO2_R + + 0.041RO2_N + 0.289MA_RCO3 + + 0.336CO+ 0.055HCHO + 0.129CCHO + + 0.013RCHO + 0.15MEK + 0.332PROD2 + + 0.15GLY + 0.174MGLY : (6.19e-11); +{171} ISOPROD + O3 = 0.4HO2 + 0.048RO2_R + + 0.048RCO_O2 + 0.285OH + + 0.498CO+ 0.125HCHO + 0.047CCHO + + 0.21MEK + 0.023GLY + 0.742MGLY + + 0.1HCOOH + 0.372RCO_OH : (4.18e-18); +{172} ISOPROD + NO3 = 0.799RO2_R + + 0.051RO2_N + 0.15MA_RCO3 + 0.572CO+ + 0.15HNO3 + 0.227HCHO + 0.218RCHO + + 0.008MGLY + 0.572RNO3 : (1.00e-13); +{173} ISOPROD + hv = 1.233HO2 + 0.467CCO_O2 + + 0.3RCO_O2 + 1.233CO+ 0.3HCHO + + 0.467CCHO + 0.233MEK : 3.32e-2*(4.10e-3*SUN/60.0e0); +{174} PROD2 + OH = 0.379HO2 + 0.473RO2_R + + 0.07RO2_N + 0.029CCO_O2 + + 0.049RCO_O2 + 0.213HCHO + + 0.084CCHO + 0.558RCHO + + 0.115MEK + 0.329PROD2 : (1.50e-11); +{175} PROD2 + hv = 0.96RO2_R + 0.04RO2_N + + 0.515R2O2+ 0.667CCO_O2 + + 0.333RCO_O2 + 0.506HCHO + + 0.246CCHO + 0.71RCHO : 9.49e-4*(2.00e-2*SUN/60.0e0); +{176} RNO3 + OH = 0.338NO2 + 0.113HO2 + + 0.376RO2_R + 0.173RO2_N + + 0.596R2O2+ 0.01HCHO + + 0.439CCHO + 0.213RCHO + + 0.006ACET + 0.177MEK + + 0.048PROD2 + 0.31RNO3 : (7.80e-12); +{177} RNO3 + hv = NO2 + 0.341HO2 + 0.564RO2_R + + 0.095RO2_N + 0.152R2O2+ 0.134HCHO + + 0.431CCHO + 0.147RCHO + 0.02ACET + + 0.243MEK + 0.435PROD2 : 2.35e-4*(SUN/60.0e0); +{178} DCB1 + OH = RCHO + RO2_R + CO : (5.00e-11); +{179} DCB1 + O3 = 1.5HO2 + 0.5OH + + 1.5CO + GLY : (2.00e-18); +{180} DCB2 + OH = R2O2 + RCHO + CCO_O2 : (5.00e-11); +{181} DCB2 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 2.06e-1*(3.65e-1*SUN/60.0e0); +{182} DCB3 + OH = R2O2 + RCHO + CCO_O2 : (5.00e-11); +{183} DCB3 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 3.32e-2*(7.28e0*SUN/60.0e0); +{184} CH4 + OH = C_O2 : ARR(2.15e-12,1735.0e0,0.0e0); +{185} ETHENE + OH = RO2_R + 1.61HCHO + + 0.195CCHO : ARR(1.96e-12,-438.0e0,0.0e0); +{186} ETHENE + O3 = 0.12OH + 0.12HO2 + + 0.5CO+ HCHO + 0.37HCOOH : ARR(9.14e-15,2580.0e0,0.0e0); +{187} ETHENE + NO3 = RO2_R + RCHO : ARR(4.39e-13,2282.0e0,2.0e0); +{188} ETHENE + O3P = 0.5HO2 + 0.2RO2_R + + 0.3C_O2 + 0.491CO+ 0.191HCHO + + 0.25CCHO + 0.009GLY : ARR(1.04e-11,792.0e0,0.0e0); +{189} ISOPRENE + OH = 0.907RO2_R + + 0.093RO2_N + 0.079R2O2+ + 0.624HCHO + 0.23METHACRO + + 0.32MVK + 0.357ISOPROD : ARR(2.50e-11,-408.0e0,0.0e0); +{190} ISOPRENE + O3 = 0.266OH + + 0.066RO2_R + 0.008RO2_N + + 0.126R2O2+ 0.192MA_RCO3 + + 0.275CO+ 0.592HCHO + 0.1PROD2 + + 0.39METHACRO + 0.16MVK + + 0.204HCOOH + 0.15RCO_OH : ARR(7.86e-15,1912.0e0,0.0e0); +{191} ISOPRENE + NO3 = 0.187NO2 + + 0.749RO2_R + 0.064RO2_N + + 0.187R2O2+ 0.936ISOPROD : ARR(3.03e-12,448.0e0,0.0e0); +{192} ISOPRENE + O3P = 0.01RO2_N + + 0.24R2O2+ 0.25C_O2 + 0.24MA_RCO3 + + 0.24HCHO + 0.75PROD2 : (3.60e-11); +{193} TERP + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2 : ARR(1.83e-11,-449.0e0,0.0e0); +{194} TERP + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : ARR(1.08e-15,821.0e0,0.0e0); +{195} TERP + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : ARR(3.66e-12,-175.e00,0.0e0); +{196} TERP + O3P = 0.147RCHO + 0.853PROD2 : (3.27e-11); +{197} ALK1 + OH = RO2_R + CCHO : ARR(1.37e-12,498.0e0,2.0e0); +{198} ALK2 + OH = 0.246OH + 0.121HO2 + + 0.612RO2_R + 0.021RO2_N + + 0.16CO + 0.039HCHO + 0.155RCHO + + 0.417ACET + + 0.248GLY + 0.121HCOOH : ARR(9.87e-12,671.0e0,0.0e0); +{199} ALK3 + OH = 0.695RO2_R + 0.07RO2_N + + 0.559R2O2+ 0.236TBU_O + 0.026HCHO + + 0.445CCHO + 0.122RCHO + 0.024ACET + + 0.332MEK : ARR(1.019e-11,434.0e0,0.0e0); +{200} ALK4 + OH = 0.835RO2_R + 0.143RO2_N + + 0.936R2O2+ 0.011C_O2 + 0.011CCO_O2 + + 0.002CO+ 0.024HCHO + 0.455CCHO + + 0.244RCHO + 0.452ACET + 0.11MEK + + 0.125PROD2 : ARR(5.946e-12,91.0e0,0.0e0); +{201} ALK5 + OH = 0.653RO2_R + 0.347RO2_N + + 0.948R2O2+ 0.026HCHO + 0.099CCHO + + 0.204RCHO + 0.072ACET + 0.089MEK + + 0.417PROD2 : ARR(1.112e-11,52.0e0,0.0e0); +{202} ARO1 + OH = 0.224HO2 + 0.765RO2_R + + 0.011RO2_N + 0.055PROD2 + 0.118GLY + + 0.119MGLY + 0.017PHEN + 0.207CRES + + 0.059BALD + 0.491DCB1 + 0.108DCB2 + + 0.051DCB3 : ARR(1.81e-12,-355.0e0,0.0e0); +{203} ARO2 + OH = 0.187HO2 + 0.804RO2_R + + 0.009RO2_N + 0.097GLY + 0.287MGLY + + 0.087BACL + 0.187CRES + 0.05BALD + + 0.561DCB1 + 0.099DCB2 + 0.093DCB3 : (2.640e-11); +{204} OLE1 + OH = 0.91RO2_R + 0.09RO2_N + + 0.205R2O2+ 0.732HCHO + 0.294CCHO + + 0.497RCHO + 0.005ACET + 0.119PROD2 : ARR(7.095e-12,-451.0e0,0.0e0); +{205} OLE1 + O3 = 0.155OH + 0.056HO2 + + 0.022RO2_R + 0.001RO2_N + + 0.076C_O2 + 0.345CO+ 0.5HCHO + + 0.154CCHO + 0.363RCHO + 0.001ACET + + 0.215PROD2 + 0.185HCOOH + + 0.05CCO_OH + 0.119RCO_OH : ARR(2.617e-15,1640.0e0,0.0e0); +{206} OLE1 + NO3 = 0.824RO2_R + 0.176RO2_N + + 0.488R2O2+ 0.009CCHO + 0.037RCHO + + 0.024ACET + 0.511RNO3 : ARR(4.453e-14,376.0e0,0.0e0); +{207} OLE1 + O3P = 0.45RCHO + 0.437MEK + + 0.113PROD2 : ARR(1.074e-11,234.0e0,0.0e0); +{208} OLE2 + OH = 0.918RO2_R + 0.082RO2_N + + 0.001R2O2+ 0.244HCHO + 0.732CCHO + + 0.511RCHO + 0.127ACET + 0.072MEK + + 0.061BALD + 0.025METHACRO + + 0.025ISOPROD : ARR(1.743e-11,-384.0e0,0.0e0); +{209} OLE2 + O3 = 0.378OH + 0.003HO2 + + 0.033RO2_R + 0.002RO2_N + 0.137R2O2+ + 0.197C_O2 + 0.137CCO_O2 + + 0.006RCO_O2 + 0.265CO+ 0.269HCHO + + 0.456CCHO + 0.305RCHO + 0.045ACET + + 0.026MEK + 0.043PROD2 + 0.042BALD + + 0.026METHACRO + 0.019MVK + + 0.073HCOOH + 0.129CCO_OH + + 0.247RCO_OH : ARR(5.022e-16,461.0e0,0.0e0); +{210} OLE2 + NO3 = 0.391NO2 + 0.442RO2_R + + 0.136RO2_N + 0.711R2O2+ 0.03C_O2 + + 0.079HCHO + 0.507CCHO + 0.151RCHO + + 0.102ACET + 0.001MEK + 0.015BALD + + 0.048MVK + 0.321RNO3 : (7.265e-13); +{211} OLE2 + O3P = 0.013HO2 + 0.012RO2_R + + 0.001RO2_N + 0.012CO+ 0.069RCHO + + 0.659MEK + 0.259PROD2 + + 0.012METHACRO : (2.085e-11); diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.spc new file mode 100755 index 00000000..f7c9745d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprc99.spc @@ -0,0 +1,87 @@ +#include atoms + +#DEFVAR + + O3 = 3O; + H2O2 = 2H + 2O; + NO = N + O; + NO2 = N + 2O; + NO3 = N + 3O; + N2O5 = 2N + 5O; + HONO = H + 2O + N; + HNO3 = H + N + 3O; + HNO4 = H + N + 4O; + SO2 = S + 2O; + H2SO4 = 2H + S + 4O; + CO = C + O; + HCHO = 2H + C + O; + CCHO = 2C + H + O; + RCHO = 3C + IGNORE; + ACET = IGNORE; + MEK = IGNORE; + HCOOH = 2H + C + 2O; + MEOH = IGNORE; + CCO_OH = IGNORE; + RCO_OH = IGNORE; + GLY = IGNORE; + MGLY = 3C + 4H + 2O; + BACL = IGNORE; + CRES = IGNORE; + BALD = IGNORE; + ISOPROD = IGNORE; + METHACRO = IGNORE; + MVK = IGNORE; + PROD2 = IGNORE; + DCB1 = IGNORE; + DCB2 = IGNORE; + DCB3 = IGNORE; + ETHENE = 2C + 4H; + ISOPRENE = IGNORE; + ALK1 = IGNORE; + ALK2 = IGNORE; + ALK3 = IGNORE; + ALK4 = IGNORE; + ALK5 = IGNORE; + ARO1 = IGNORE; + ARO2 = IGNORE; + OLE1 = IGNORE; + OLE2 = IGNORE; + TERP = IGNORE; + RNO3 = IGNORE; + NPHE = IGNORE; + PHEN = IGNORE; + PAN = 2C + 3H + 5O + N; + PAN2 = N + IGNORE; + PBZN = N + IGNORE; + MA_PAN = N + IGNORE; + CCO_OOH = 2C + 3O + H; + RCO_O2 = IGNORE; + RCO_OOH = IGNORE; + XN = IGNORE; + XC = IGNORE; + O3P = O; + O1D = O; + OH = H + O; + HO2 = H+ 2O; + C_O2 = IGNORE; + COOH = C + 2O + H; + ROOH = IGNORE; + RO2_R = IGNORE; + R2O2 = IGNORE; + RO2_N = IGNORE; + HOCOO = H + 3O + C; + CCO_O2 = IGNORE; + BZCO_O2 = IGNORE; + BZNO2_O = IGNORE; + BZ_O = IGNORE; + MA_RCO3 = IGNORE; + TBU_O = IGNORE; + + + +#DEFFIX + AIR = IGNORE; + O2 = 2O; + H2O = 2H + O; + H2 = 2H; + CH4 = C + 4H; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.def new file mode 100755 index 00000000..5b3a669a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.def @@ -0,0 +1,79 @@ +#include saprcnov.spc +#include saprcnov.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL +#MONITOR O3; + +#INITVALUES + + CFACTOR = 2.4476E+13; + + ALl_SPEC = 0.0E0; + NO = 1.0E-1; + NO2 = 5.0E-2; + HONO = 1.E-3; + SO2 = 5.E-2; + ISOPRENE = 4.33E-4; + TERP = 8.20E-4; + ETHENE = 1.89E-2; + MEOH = 5.89E-3; + HCOOH = 6.77E-4; + CCO_OH = 1.16E-3; + RCO_OH = 3.92E-4; + HCHO = 1.12E-2; + CCHO = 2.32E-3; + RCHO = 1.72E-3; + GLY = 1.21E-4; + MGLY = 8.37E-5; + METHACRO = 1.30E-3; + ISOPROD = 8.93E-5; + BALD = 7.51E-5; + ACET = 5.07E-3; + MEK = 3.26E-3; + PROD2 = 1.93E-3; + PHEN = 6.06E-4; + CRES = 5.60E-4; + ALK3 = 4.69E-2; + ALK4 = 4.17E-2; + ALK5 = 3.06E-2; + ARO1 = 1.18E-2; + ARO2 = 8.74E-3; + OLE1 = 1.04E-2; + OLE2 = 7.97E-3; + CH4 = 0.07E0; + H2O = 2.0E+04; + O2 = 2.09E+5; + AIR = 1.0E6; + +#INLINE F77_INIT + TSTART = 0.0D0 + TEND = TSTART + 2*24*3600.0D0 ! 2160.0D0*60.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0.0D0 + TEND = TSTART + 2*24*3600.0D0 ! 2160.0D0*60.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0.0; + TEND = TSTART + 2*24*3600.0D0; + DT = 3600.0; + TEMP = 300.00; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0.0; + TEND = TSTART + 2*24*3600.0D0; /*+ 2160.0*60.0;*/ + DT = 3600.0; + TEMP = 300.00; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.eqn new file mode 100755 index 00000000..7cf3f4a5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.eqn @@ -0,0 +1,385 @@ +#Equations + +{1} NO2 + hv = NO + O3P : 1.0*SUN; +{2} O3P + O2 + AIR = O3 : ARR(5.68e-34,0.0,-2.80); +{3} O3P + O3 = 2O2 : ARR(8.00e-12,2060.0,0.0); +{4} O3P + NO + AIR = NO2 : ARR(1.00e-31,0.0,-1.60); +{5} O3P + NO2 = NO : ARR(6.50e-12,-120.0,0.0); +{6} O3P + NO2 = NO3 : FALL(9.00e-32,0.0,-2.00,2.20e-11,0.0,0.0,0.80); +{7} O3 + NO = NO2 : ARR(1.80e-12,1370.0,0.0); +{8} O3 + NO2 = NO3 : ARR(1.40e-13,2470.0,0.0); +{9} NO + NO3 = 2NO2 : ARR(1.80e-11,-110.0,0.0); +{10} NO + NO + O2 = 2NO2 : ARR(3.30e-39,-530.0,0.0); +{11} NO2 + NO3 = N2O5 : FALL(2.80e-30,0.0,-3.50,2.00e-12,0.0,0.20,0.45); +{12} N2O5 = NO2 + NO3 : FALL(1.e-3,11000.0,-3.5,9.7e14,11080.0,0.1,0.45); +{13} N2O5 + H2O = 2HNO3 : 2.60e-22; +{14} NO2 + NO3 = NO + NO2 : ARR(4.50e-14,1260.0,0.0); +{15} NO3 + hv = NO : 1.0*SUN; +{16} NO3 + hv = NO2 + O3P : 1.0*SUN; +{17} O3 + hv = O3P : 1.0*SUN; +{18} O3 + hv = O1D : 1.0*SUN; +{19} O1D + H2O = 2OH : 2.20e-10; +{20} O1D + AIR = O3P : ARR(2.09e-11,-95.0,0.0); +{21} OH + NO = HONO : FALL(7.00e-31,0.0,-2.60,3.60e-11,0.0,-0.10,0.60); +{22} HONO + hv = OH + NO : 1.0*SUN; +{23} HONO + hv = HO2 + NO2 : 1.0*SUN; +{24} OH + HONO = NO2 : ARR(2.70e-12,-260.0,0.0); +{25} OH + NO2 = HNO3 : FALL(2.43e-30, 0.0,-3.10,1.67e-11,0.0,-2.10,0.60); +{26} OH + NO3 = HO2 + NO2 : 2.00e-11; +{27} OH + HNO3 = NO3 : EP2(7.20e-15,-785.0,4.10e-16,-1440.0,1.90e-33,-725.0); +{28} HNO3 + hv = OH + NO2 : 1.0*SUN; +{29} OH + CO = HO2 : EP3(1.30e-13,0.0,3.19e-33,0.0); +{30} OH + O3 = HO2 : ARR(1.90e-12,1000.0,0.0); +{31} HO2 + NO = OH + NO2 : ARR(3.40e-12,-270.0,0.0); +{32} HO2 + NO2 = HNO4 : FALL(1.80e-31,0.0,-3.20,4.70e-12,0.0,0.0,0.60); +{33} HNO4 = HO2 + NO2 : FALL(4.10e-05,10650.0,0.0,5.7e+15,11170.0,0.0,0.5); +{34} HNO4 + hv = 0.61HO2 + 0.61NO2 + 0.39OH + + 0.39NO3 : 1.0*SUN; +{35} HNO4 + OH = NO2 : ARR(1.50e-12,-360.0,0.0); +{36} HO2 + O3 = OH : ARR(1.40e-14,600.0,0.0); +{37} HO2 + HO2 = H2O2 : EP3(2.20e-13,-600.0,1.85e-33,-980.0); +{38} HO2 + HO2 + H2O = H2O2 : EP3(3.08e-34,-2800.0,2.59e-54,-3180.0); +{39} NO3 + HO2 = 0.8OH + 0.8NO2 + 0.2HNO3 : 4.00e-12; +{40} NO3 + NO3 = 2NO2 : ARR(8.50e-13,2450.0,0.0); +{41} H2O2 + hv = 2OH : 1.0*SUN; +{42} H2O2 + OH = HO2 : ARR(2.90e-12,160.0,0.0); +{43} OH + HO2 = H2O + O2 : ARR(4.80e-11,-250.0,0.0); +{44} OH + SO2 = HO2 + H2SO4 : FALL(4.00e-31,0.0,-3.30,2.00e-12,0.0,0.0,0.45); +{45} OH + H2 = HO2 : ARR(7.70e-12,2100.0,0.0); +{46} C_O2 + NO = NO2 + HCHO + HO2 : ARR(2.80e-12,-285.0,0.0); +{47} C_O2 + HO2 = COOH : ARR(3.80e-13,-780.0,0.0); +{48} C_O2 + NO3 = HCHO + HO2 + NO2 : 1.30e-12; +{49} C_O2 + C_O2 = MEOH + HCHO : ARR(2.45e-14,-710.0,0.0); +{50} C_O2 + C_O2 = 2HCHO + 2HO2 : ARR(5.90e-13,509.0,0.0); +{51} RO2_R + NO = NO2 + HO2 : ARR(2.70e-12,-360.0,0.0); +{52} RO2_R + HO2 = ROOH : ARR(1.90e-13,-1300.0,0.0); +{53} RO2_R + NO3 = NO2 + HO2 : 2.30e-12; +{54} RO2_R + C_O2 = HO2 + 0.75HCHO + + 0.25MEOH : 2.00e-13; +{55} RO2_R + RO2_R = HO2 : 3.50e-14; +{56} R2O2 + NO = NO2 : ARR(2.70e-12,-360.0,0.0); {1.0*RCONST(51);} +{57} R2O2 + HO2 = HO2 : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{58} R2O2 + NO3 = NO2 : 2.30e-12; {1.0*RCONST(53);} +{59} R2O2 + C_O2 = C_O2 : 2.00e-13; {1.0*RCONST(54);} +{60} R2O2 + RO2_R = RO2_R : 3.50e-14; {1.0*RCONST(55);} +{61} R2O2 + R2O2 = 2R2O2 : 0.0; +{62} RO2_N + NO = RNO3 : ARR(2.70e-12,-360.0,0.0); {1.0*RCONST(51);} +{63} RO2_N + HO2 = ROOH : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{64} RO2_N + C_O2 = HO2 + 0.25MEOH + + 0.5MEK + 0.5PROD2 + 0.75HCHO : 2.00e-13; {1.0*RCONST(54);} +{65} RO2_N + NO3 = NO2 + HO2 + MEK : 2.30e-12; {1.0*RCONST(53);} +{66} RO2_N + RO2_R = HO2 + 0.5MEK + + 0.5PROD2 : 3.50e-14; {1.0*RCONST(55);} +{67} RO2_N + R2O2 = RO2_N : 3.50e-14; {1.0*RCONST(55);} +{68} RO2_N + RO2_N = MEK + HO2 + PROD2 : 3.50e-14; {1.0*RCONST(55);} +{69} CCO_O2 + NO2 = PAN : FALL(2.70e-28,0.0,-7.10,1.20e-11,0.0,-0.90,0.30); +{70} PAN = CCO_O2 + NO2 : FALL(4.90e-3,12100.0,0.0,4.0e+16,13600.0,0.,0.3); +{71} CCO_O2 + NO = C_O2 + NO2 : ARR(7.80e-12,-300.0,0.0); +{72} CCO_O2 + HO2 = 0.75CCO_OOH + + 0.25CCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); +{73} CCO_O2 + NO3 = C_O2 + NO2 : 4.00e-12; +{74} CCO_O2 + C_O2 = CCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); +{75} CCO_O2 + RO2_R = CCO_OH : 7.50e-12; +{76} CCO_O2 + R2O2 = CCO_O2 : 7.50e-12; +{77} CCO_O2 + RO2_N = CCO_OH + PROD2 : 7.50e-12; +{78} CCO_O2 + CCO_O2 = 2C_O2 : ARR(2.90e-12,-500.0,0.0); +{79} RCO_O2 + NO2 = PAN2 : ARR(1.20e-11,0.0,-0.90); +{80} PAN2 = RCO_O2 + NO2 : ARR(2.00e+15,12800.0,0.0); +{81} RCO_O2 + NO = NO2 + CCHO + RO2_R : ARR(1.25e-11,-240.0,0.0); +{82} RCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{83} RCO_O2 + NO3 = NO2 + CCHO + RO2_R : 4.00e-12; {1.0*RCONST(73);} +{84} RCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{85} RCO_O2 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{86} RCO_O2 + R2O2 = RCO_O2 : 7.50e-12; {1.0*RCONST(75);} +{87} RCO_O2 + RO2_N = RCO_OH + PROD2 : 7.50e-12; {1.0*RCONST(75);} +{88} RCO_O2 + CCO_O2 = C_O2 + CCHO + RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{89} RCO_O2 + RCO_O2 = 2CCHO + 2RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{90} BZCO_O2 + NO2 = PBZN : 1.37e-11; +{91} PBZN = BZCO_O2 + NO2 : ARR(7.90e+16,14000.0,0.0); +{92} BZCO_O2 + NO = NO2 + BZ_O + R2O2 : ARR(1.25e-11,-240.0,0.0); {1.0*RCONST(81);} +{93} BZCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{94} BZCO_O2 + NO3 = NO2 + BZ_O + R2O2 : 4.00e-12; {1.0*RCONST(73);} +{95} BZCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{96} BZCO_O2 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{97} BZCO_O2 + R2O2 = BZCO_O2 : 7.50e-12; {1.0*RCONST(75);} +{98} BZCO_O2 + RO2_N = RCO_OH + PROD2 : 7.50e-12; {1.0*RCONST(75);} +{99} BZCO_O2 + CCO_O2 = C_O2 + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{100} BZCO_O2 + RCO_O2 = CCHO + RO2_R + + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{101} BZCO_O2 + BZCO_O2 = 2BZ_O + 2R2O2: ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{102} MA_RCO3 + NO2 = MA_PAN : ARR(1.20e-11,0.0,-0.90); {1.0*RCONST(79);} +{103} MA_PAN = MA_RCO3 + NO2 : ARR(1.60e+16,13486.0,0.0); +{104} MA_RCO3 + NO = NO2 + HCHO + CCO_O2 : ARR(1.25e-11,-240.0,0.0); {1.0*RCONST(81);} +{105} MA_RCO3 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{106} MA_RCO3 + NO3 = NO2 + HCHO + CCO_O2 : 4.00e-12; {1.0*RCONST(73);} +{107} MA_RCO3 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{108} MA_RCO3 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{109} MA_RCO3 + R2O2 = MA_RCO3 : 7.50e-12; {1.0*RCONST(75);} +{110} MA_RCO3 + RO2_N = 2RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{111} MA_RCO3 + CCO_O2 = C_O2 + HCHO + + CCO_O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{112} MA_RCO3 + RCO_O2 = HCHO + CCO_O2 + + CCHO + RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{113} MA_RCO3 + BZCO_O2 = HCHO + CCO_O2 + + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{114} MA_RCO3 + MA_RCO3 = 2HCHO + 2CCO_O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{115} TBU_O + NO2 = RNO3 : 2.40e-11; +{116} TBU_O = ACET + C_O2 : ARR(7.50e+14,8152.0,0.0); +{117} BZ_O + NO2 = NPHE : ARR(2.30e-11,-150.0,0.0); +{118} BZ_O + HO2 = PHEN : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{119} BZ_O = PHEN : 1.00e-03; +{120} BZNO2_O + NO2 = 2XN + 6XC: ARR(7.50e+14,8152.0,0.0); {1.0*RCONST(116);} +{121} BZNO2_O + HO2 = NPHE : ARR(2.30e-11,-150.0,0.0); {1.0*RCONST(117);} +{122} BZNO2_O = NPHE : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(118);} +{123} HCHO + hv = 2HO2 + CO : 1.0*SUN; +{124} HCHO + hv = CO : 1.0*SUN; +{125} HCHO + OH = HO2 + CO : ARR(8.60e-12,-20.0,0.0); +{126} HCHO + HO2 = HOCOO : ARR(9.70e-15,-625.0,0.0); +{127} HOCOO = HO2 + HCHO : ARR(2.40e+12,7000.0,0.0); +{128} HOCOO + NO = HCOOH + NO2 + HO2 : ARR(2.80e-12,-285.0,0.0); {1.0*RCONST(46);} +{129} HCHO + NO3 = HNO3 + HO2 + CO : ARR(2.00e-12,2431.0,0.0); +{130} CCHO + OH = CCO_O2 : ARR(5.60e-12,-310.0,0.0); +{131} CCHO +hv = CO + HO2 + C_O2 : 1.0*SUN; +{132} CCHO + NO3 = HNO3 + CCO_O2 : ARR(1.40e-12,1860.0,0.0); +{133} RCHO + OH = 0.034RO2_R + 0.001RO2_N + + 0.965RCO_O2 + 0.034CO+ 0.034CCHO : 2.00e-11; +{134} RCHO + hv = CCHO + RO2_R + CO + HO2 : 1.0*SUN; +{135} RCHO + NO3 = HNO3 + RCO_O2 : ARR(1.40e-12,1771.0,0.0); +{136} ACET + OH = HCHO + CCO_O2 + R2O2 : ARR(1.10e-12,520.0,0.0); +{137} ACET + hv = CCO_O2 + C_O2 : 1.0*SUN; +{138} MEK + OH = 0.37RO2_R + 0.042RO2_N + + 0.616R2O2+ 0.492CCO_O2 + + 0.096RCO_O2 + 0.115HCHO + + 0.482CCHO + 0.37RCHO : ARR(1.30e-12,25.0,2.0); +{139} MEK + hv = CCO_O2 + CCHO + RO2_R : 1.50e-1*SUN; +{140} MEOH + OH = HCHO + HO2 : ARR(3.10e-12,360.0,2.0); +{141} ETOH + OH = 0.95HO2 + 0.05RO2_R + + 0.081HCHO + 0.96CCHO : ARR(0.0,0.0,1.0); +{142} COOH + OH = 0.35HCHO + 0.35OH + + 0.65C_O2 : ARR(2.90e-12,-190.0,0.0); +{143} COOH + hv = HCHO + HO2 + OH : 1.0*SUN; +{144} ROOH + OH = RCHO + 0.34RO2_R + + 0.66OH : 1.10e-11; +{145} ROOH + hv = RCHO + HO2 + OH : 1.0*SUN; +{146} GLY + hv = 2CO+ 2HO2 : 1.0*SUN; +{147} GLY + hv = HCHO + CO : 6.00e-3*SUN; +{148} GLY + OH = 0.63HO2 + 1.26CO+ + 0.37RCO_O2 : 1.10e-11; +{149} GLY + NO3 = HNO3 + 0.63HO2 + + 1.26CO+ 0.37RCO_O2 : ARR(2.80e-12,2376.0,0.0); +{150} MGLY + hv = HO2 + CO + CCO_O2 : 1.0*SUN; +{151} MGLY + OH = CO + CCO_O2 : 1.50e-11; +{152} MGLY + NO3 = HNO3 + CO + CCO_O2 : ARR(1.40e-12,1895.0,0.0); +{153} BACL + hv = 2CCO_O2 : 1.0*SUN; +{154} PHEN + OH = 0.24BZ_O + 0.76RO2_R + + 0.23GLY : 2.63e-11; +{155} PHEN + NO3 = HNO3 + BZ_O : 3.78e-12; +{156} CRES + OH = 0.24BZ_O + 0.76RO2_R + + 0.23MGLY : 4.20e-11; +{157} CRES + NO3 = HNO3 + BZ_O : 1.37e-11; +{158} NPHE + NO3 = HNO3 + BZNO2_O : 2.63e-11; {1.0*RCONST(154);} +{159} BALD + OH = BZCO_O2 : 1.29e-11; +{160} BALD + hv = 7XC: 5.00e-2*SUN; +{161} BALD + NO3 = HNO3 + BZCO_O2 : ARR(1.40e-12,1872.0,0.0); +{162} METHACRO + OH = 0.5RO2_R + 0.416CO+ + 0.084HCHO + 0.416MEK + + 0.084MGLY + 0.5MA_RCO3 : ARR(1.86e-11,-176.0,0.0); +{163} METHACRO + O3 = 0.008HO2 + 0.1RO2_R + + 0.208OH + 0.1RCO_O2 + 0.45CO+ + 0.2HCHO + 0.9MGLY + 0.333HCOOH : ARR(1.36e-15,2114.0,0.0); +{164} METHACRO + NO3 = 0.5HNO3 + 0.5RO2_R + + 0.5CO+ 0.5MA_RCO3 : ARR(1.50e-12,1726.0,0.0); +{165} METHACRO + O3P = RCHO : 6.34e-12; +{166} METHACRO + hv = 0.34HO2 + 0.33RO2_R + + 0.33OH + 0.67CCO_O2 + 0.67CO+ + 0.67HCHO + 0.33MA_RCO3 : 4.10e-3*SUN; +{167} MVK + OH = 0.3RO2_R + 0.025RO2_N + + 0.675R2O2+ 0.675CCO_O2 + + 0.3HCHO + 0.675RCHO + 0.3MGLY : ARR(4.14e-12,-453.0,0.0); +{168} MVK + O3 = 0.064HO2 + 0.05RO2_R + + 0.164OH + 0.05RCO_O2 + 0.475CO+ + 0.1HCHO + 0.95MGLY + 0.351HCOOH : ARR(7.51e-16,1520.0,0.0); +{169} MVK + O3P = 0.45RCHO + 0.55MEK : 4.32e-12; +{170} MVK + hv = 0.3C_O2 + 0.7CO+ 0.7PROD2 + + 0.3MA_RCO3 : 2.10e-3*SUN; +{171} ISOPROD + OH = 0.67RO2_R + + 0.041RO2_N + 0.289MA_RCO3 + + 0.336CO+ 0.055HCHO + 0.129CCHO + + 0.013RCHO + 0.15MEK + 0.332PROD2 + + 0.15GLY + 0.174MGLY : 6.19e-11; +{172} ISOPROD + O3 = 0.4HO2 + 0.048RO2_R + + 0.048RCO_O2 + 0.285OH + + 0.498CO+ 0.125HCHO + 0.047CCHO + + 0.21MEK + 0.023GLY + 0.742MGLY + + 0.1HCOOH + 0.372RCO_OH : 4.18e-18; +{173} ISOPROD + NO3 = 0.799RO2_R + + 0.051RO2_N + 0.15MA_RCO3 + 0.572CO+ + 0.15HNO3 + 0.227HCHO + 0.218RCHO + + 0.008MGLY + 0.572RNO3 : 1.00e-13; +{174} ISOPROD + hv = 1.233HO2 + 0.467CCO_O2 + + 0.3RCO_O2 + 1.233CO+ 0.3HCHO + + 0.467CCHO + 0.233MEK : 4.10e-3*SUN; +{175} PROD2 + OH = 0.379HO2 + 0.473RO2_R + + 0.07RO2_N + 0.029CCO_O2 + + 0.049RCO_O2 + 0.213HCHO + + 0.084CCHO + 0.558RCHO + + 0.115MEK + 0.329PROD2 : 1.50e-11; +{176} PROD2 + hv = 0.96RO2_R + 0.04RO2_N + + 0.515R2O2+ 0.667CCO_O2 + + 0.333RCO_O2 + 0.506HCHO + + 0.246CCHO + 0.71RCHO : 2.00e-2*SUN; +{177} RNO3 + OH = 0.338NO2 + 0.113HO2 + + 0.376RO2_R + 0.173RO2_N + + 0.596R2O2+ 0.01HCHO + + 0.439CCHO + 0.213RCHO + + 0.006ACET + 0.177MEK + + 0.048PROD2 + 0.31RNO3 : 7.80e-12; +{178} RNO3 + hv = NO2 + 0.341HO2 + 0.564RO2_R + + 0.095RO2_N + 0.152R2O2+ 0.134HCHO + + 0.431CCHO + 0.147RCHO + 0.02ACET + + 0.243MEK + 0.435PROD2 : 1.0*SUN; +{179} DCB1 + OH = RCHO + RO2_R + CO : 5.00e-11; +{180} DCB1 + O3 = 1.5HO2 + 0.5OH + + 1.5CO + GLY : 2.00e-18; +{181} DCB2 + OH = R2O2 + RCHO + CCO_O2 : 5.00e-11; +{182} DCB2 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 3.65e-1*SUN; +{183} DCB3 + OH = R2O2 + RCHO + CCO_O2 : 5.00e-11; +{184} DCB3 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 7.28*SUN; +{185} CH4 + OH = C_O2 : ARR(2.15e-12,1735.0,0.0); +{186} ETHENE + OH = RO2_R + 1.61HCHO + + 0.195CCHO : ARR(1.96e-12,-438.0,0.0); +{187} ETHENE + O3 = 0.12OH + 0.12HO2 + + 0.5CO+ HCHO + 0.37HCOOH : ARR(9.14e-15,2580.0,0.0); +{188} ETHENE + NO3 = RO2_R + RCHO : ARR(4.39e-13,2282.0,2.0); +{189} ETHENE + O3P = 0.5HO2 + 0.2RO2_R + + 0.3C_O2 + 0.491CO+ 0.191HCHO + + 0.25CCHO + 0.009GLY : ARR(1.04e-11,792.0,0.0); +{190} ISOPRENE + OH = 0.907RO2_R + + 0.093RO2_N + 0.079R2O2+ + 0.624HCHO + 0.23METHACRO + + 0.32MVK + 0.357ISOPROD : ARR(2.50e-11,-408.0,0.0); +{191} ISOPRENE + O3 = 0.266OH + + 0.066RO2_R + 0.008RO2_N + + 0.126R2O2+ 0.192MA_RCO3 + + 0.275CO+ 0.592HCHO + 0.1PROD2 + + 0.39METHACRO + 0.16MVK + + 0.204HCOOH + 0.15RCO_OH : ARR(7.86e-15,1912.0,0.0); +{192} ISOPRENE + NO3 = 0.187NO2 + + 0.749RO2_R + 0.064RO2_N + + 0.187R2O2+ 0.936ISOPROD : ARR(3.03e-12,448.0,0.0); +{193} ISOPRENE + O3P = 0.01RO2_N + + 0.24R2O2+ 0.25C_O2 + 0.24MA_RCO3 + + 0.24HCHO + 0.75PROD2 : 3.60e-11; +{194} TERP + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2 : ARR(1.83e-11,-449.0,0.0); +{195} TERP + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : ARR(1.08e-15,821.0,0.0); +{196} TERP + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : ARR(3.66e-12,-175.0,0.0); +{197} TERP + O3P = 0.147RCHO + 0.853PROD2 : 3.27e-11; +{198} C2H6 + OH = RO2_R + CCHO : ARR(1.37e-12,498.0,2.0); +{199} C3H8 + OH = 0.965RO2_R + 0.035RO2_N + + 0.261RCHO + 0.704ACET : ARR(0.0,0.0,1.0); +{200} C2H2 + OH = 0.603OH + 0.297HO2 + + 0.1RO2_R + 0.393CO + 0.096HCHO + + 0.607GLY + 0.297HCOOH : ARR(9.87e-12,671.0,0.0); +{201} ALK3 + OH = 0.695RO2_R + 0.07RO2_N + + 0.559R2O2+ 0.236TBU_O + 0.026HCHO + + 0.445CCHO + 0.122RCHO + 0.024ACET + + 0.332MEK : ARR(1.019e-11,434.0,0.0); +{202} ALK4 + OH = 0.835RO2_R + 0.143RO2_N + + 0.936R2O2+ 0.011C_O2 + 0.011CCO_O2 + + 0.002CO+ 0.024HCHO + 0.455CCHO + + 0.244RCHO + 0.452ACET + 0.11MEK + + 0.125PROD2 : ARR(5.946e-12,91.0,0.0); +{203} ALK5 + OH = 0.653RO2_R + 0.347RO2_N + + 0.948R2O2+ 0.026HCHO + 0.099CCHO + + 0.204RCHO + 0.072ACET + 0.089MEK + + 0.417PROD2 : ARR(1.112e-11,52.0,0.0); +{204} ARO1 + OH = 0.224HO2 + 0.765RO2_R + + 0.011RO2_N + 0.055PROD2 + 0.118GLY + + 0.119MGLY + 0.017PHEN + 0.207CRES + + 0.059BALD + 0.491DCB1 + 0.108DCB2 + + 0.051DCB3 : ARR(1.81e-12,-355.0,0.0); +{205} ARO2 + OH = 0.187HO2 + 0.804RO2_R + + 0.009RO2_N + 0.097GLY + 0.287MGLY + + 0.087BACL + 0.187CRES + 0.05BALD + + 0.561DCB1 + 0.099DCB2 + 0.093DCB3 : (2.640e-11); +{206} OLE1 + OH = 0.91RO2_R + 0.09RO2_N + + 0.205R2O2+ 0.732HCHO + 0.294CCHO + + 0.497RCHO + 0.005ACET + 0.119PROD2 : ARR(7.095e-12,-451.0,0.0); +{207} OLE1 + O3 = 0.155OH + 0.056HO2 + + 0.022RO2_R + 0.001RO2_N + + 0.076C_O2 + 0.345CO+ 0.5HCHO + + 0.154CCHO + 0.363RCHO + 0.001ACET + + 0.215PROD2 + 0.185HCOOH + + 0.05CCO_OH + 0.119RCO_OH : ARR(2.617e-15,1640.0,0.0); +{208} OLE1 + NO3 = 0.824RO2_R + 0.176RO2_N + + 0.488R2O2+ 0.009CCHO + 0.037RCHO + + 0.024ACET + 0.511RNO3 : ARR(4.453e-14,376.0,0.0); +{209} OLE1 + O3P = 0.45RCHO + 0.437MEK + + 0.113PROD2 : ARR(1.074e-11,234.0,0.0); +{210} OLE2 + OH = 0.918RO2_R + 0.082RO2_N + + 0.001R2O2+ 0.244HCHO + 0.732CCHO + + 0.511RCHO + 0.127ACET + 0.072MEK + + 0.061BALD + 0.025METHACRO + + 0.025ISOPROD : ARR(1.743e-11,-384.0,0.0); +{211} OLE2 + O3 = 0.378OH + 0.003HO2 + + 0.033RO2_R + 0.002RO2_N + 0.137R2O2+ + 0.197C_O2 + 0.137CCO_O2 + + 0.006RCO_O2 + 0.265CO+ 0.269HCHO + + 0.456CCHO + 0.305RCHO + 0.045ACET + + 0.026MEK + 0.043PROD2 + 0.042BALD + + 0.026METHACRO + 0.019MVK + + 0.073HCOOH + 0.129CCO_OH + + 0.247RCO_OH : ARR(5.022e-16,461.0,0.0); +{212} OLE2 + NO3 = 0.391NO2 + 0.442RO2_R + + 0.136RO2_N + 0.711R2O2+ 0.03C_O2 + + 0.079HCHO + 0.507CCHO + 0.151RCHO + + 0.102ACET + 0.001MEK + 0.015BALD + + 0.048MVK + 0.321RNO3 : 7.265e-13; +{213} OLE2 + O3P = 0.013HO2 + 0.012RO2_R + + 0.001RO2_N + 0.012CO+ 0.069RCHO + + 0.659MEK + 0.259PROD2 + + 0.012METHACRO : 2.085e-11; +{214} C2H2 + O3 = 0.5OH + 1.5HO2 + + 1.5CO + 0.5CO2 : 2.20e-10; +{215} C3H6 + OH = 0.984RO2_R + 0.016RO2_N + + 0.984HCHO + 0.984CCHO + 0.048XC : 2.20e-10; +{216} C3H6 + O3 = 0.32OH + 0.06HO2 + + 0.26C_O2 + 0.51CO + 0.135CO2 + 0.5HCHO + + 0.5CCHO + 0.185HCOOH + 0.17CCO_OH + 0.07XC: 2.20e-10; +{217} C3H6 + NO3 = 0.949RO2_R + 0.051RO2_N + + 2.693XC + 1.0XN : 2.20e-10; +{218} C3H6 + O3P = 0.45RCHO + 0.55MEK + + 0.55XC: 2.20e-10; +{219} SO2 = H2SO4 : 2.20e-10; +{220} HO2 = AIR : 7.00e-7; +{221} SO2 = AIR : 2.20e-10; +{222} H2SO4 = AIR : 2.20e-10; +{223} HNO3 = AIR : 2.20e-10; +{224} H2O2 = AIR : 2.20e-10; +{225} BC = AIR : 7.00e-7; +{226} OC = AIR : 7.00e-7; +{227} SSF = AIR : 7.00e-7; +{228} SSC = AIR : 7.00e-7; +{229} PM10 = AIR : 7.00e-7; +{230} PM25 = AIR : 7.00e-7; +{231} DST1 = AIR : 7.00e-7; +{232} DST2 = AIR : 7.00e-7; +{233} DST3 = AIR : 7.00e-7; +{234} DMS = AIR : 7.00e-7; +{235} CO2 = AIR : 7.00e-7; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.spc new file mode 100755 index 00000000..cc634393 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/saprcnov.spc @@ -0,0 +1,101 @@ +#include atoms + + #DEFVAR + O3 = 3O ; + H2O2 = 2H + 2O ; + NO = N + O ; + NO2 = N + 2O ; + NO3 = N + 3O ; + N2O5 = 2N + 5O ; + HONO = H + 2O + N ; + HNO3 = H + N + 3O ; + HNO4 = H + N + 4O ; + SO2 = S + 2O ; + H2SO4 = 2H + S + 4O ; + CO = C + O ; + HCHO = 2H + C + O ; + CCHO = 2C + H + O ; + RCHO = 3C + ignore ; + ACET = ignore ; + MEK = ignore ; + HCOOH = 2H + C + 2O ; + MEOH = ignore ; + ETOH = ignore ; + CCO_OH = ignore ; + RCO_OH = ignore ; + GLY = ignore ; + MGLY = 3C + 4H + 2O ; + BACL = ignore ; + CRES = ignore ; + BALD = ignore ; + ISOPROD = ignore ; + METHACRO = ignore ; + MVK = ignore ; + PROD2 = ignore ; + DCB1 = ignore ; + DCB2 = ignore ; + DCB3 = ignore ; + ETHENE = 2C + 4H ; + ISOPRENE = ignore ; + C2H6 = 2C + 6H ; + C3H8 = 3C + 8H ; + C2H2 = 2C + 2H ; + C3H6 = 3C + 6H ; + ALK3 = ignore ; + ALK4 = ignore ; + ALK5 = ignore ; + ARO1 = ignore ; + ARO2 = ignore ; + OLE1 = ignore ; + OLE2 = ignore ; + TERP = ignore ; + RNO3 = ignore ; + NPHE = ignore ; + PHEN = ignore ; + PAN = 2C + 3H + 5O + N ; + PAN2 = N + ignore ; + PBZN = N + ignore ; + MA_PAN = N + ignore ; + BC = C ; + OC = C ; + SSF = ignore ; + SSC = ignore ; + PM10 = ignore ; + PM25 = ignore ; + DMS = ignore ; + DST1 = ignore ; + DST2 = ignore ; + DST3 = ignore ; + CO2 = C + 2O ; + CCO_OOH = 2C + 3O + H ; + RCO_O2 = ignore ; + RCO_OOH = ignore ; + XN = ignore ; + XC = ignore ; + O3P = O ; + O1D = O ; + OH = H + O ; + HO2 = H+ 2O ; + C_O2 = ignore ; + COOH = C + 2O + H ; + ROOH = ignore ; + RO2_R = ignore ; + R2O2 = ignore ; + RO2_N = ignore ; + HOCOO = H + 3O + C ; + CCO_O2 = ignore ; + BZCO_O2 = ignore ; + BZNO2_O = ignore ; + BZ_O = ignore ; + MA_RCO3 = ignore ; + TBU_O = ignore ; + + +#DEFFIX + AIR = ignore ; + N2 = 2N ; + O2 = 2O ; + H2O = 2H + O ; + H2 = 2H ; + CH4 = C + 4H ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.def new file mode 100755 index 00000000..6bad0625 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.def @@ -0,0 +1,59 @@ +#include small_strato.spc +#include small_strato.eqn + + +//#LANGUAGE Fortran77 {Output Language} +//#DOUBLE ON {Double Precision} +//#JACOBIAN SPARSE_LU_ROW {Use Sparse DATA STRUCTURES} + +//#INTEGRATOR rodas3 +//#DRIVER general + + +#LOOKATALL {File Output} +#MONITOR O3;N;O2;O;NO;O1D;NO2; {Screen Output} + +#CHECK O; N; {Check Mass Balance} + +#INITVALUES {Initial Values} + +CFACTOR = 1. ; {Conversion Factor} +O1D = 9.906E+01 ; +O = 6.624E+08 ; +O3 = 5.326E+11 ; +O2 = 1.697E+16 ; +NO = 8.725E+08 ; +NO2 = 2.240E+08 ; +M = 8.120E+16 ; + +#INLINE F77_INIT + TSTART = (12*3600) + TEND = TSTART + (3*24*3600) + DT = 0.25*3600 + TEMP = 270 +#ENDINLINE + +#INLINE F90_INIT + TSTART = (12*3600) + TEND = TSTART + (3*24*3600) + DT = 0.25*3600 + TEMP = 270 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = (12*3600); + TEND = TSTART + (3*24*3600); + DT = 0.25*3600; + TEMP = 270; +#ENDINLINE + + +#INLINE C_INIT + TSTART = (12*3600); + TEND = TSTART + (3*24*3600); + DT = 0.25*3600; + TEMP = 270; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.eqn new file mode 100755 index 00000000..8c9b530d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.eqn @@ -0,0 +1,15 @@ +#EQUATIONS { Small Stratospheric Mechanism } + + + O2 + hv = 2O : (2.643E-10) * SUN*SUN*SUN; + O + O2 = O3 : (8.018E-17); + O3 + hv = O + O2 : (6.120E-04) * SUN; + O + O3 = 2O2 : (1.576E-15); + O3 + hv = O1D + O2 : (1.070E-03) * SUN*SUN; + O1D + M = O + M : (7.110E-11); + O1D + O3 = 2O2 : (1.200E-10); + NO + O3 = NO2 + O2 : (6.062E-15); + NO2 + O = NO + O2 : (1.069E-11); + NO2 + hv = NO + O : (1.289E-02) * SUN; + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.spc new file mode 100755 index 00000000..b18cb4f9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/small_strato.spc @@ -0,0 +1,17 @@ +#include atoms + +#DEFVAR +O = O; { Oxygen atomic ground state } +O1D = O; { Oxygen atomic excited state } +O3 = O + O + O; { Ozone } +NO = N + O; { Nitric oxide } +NO2 = N + O + O; { Nitrogen dioxide } + + +#DEFFIX +M = O + O + N + N;{ Atmospheric generic molecule } +O2 = O + O; { Molecular oxygen } + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.def new file mode 100755 index 00000000..a35a2cc8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.def @@ -0,0 +1,49 @@ +#include smog.spc +#include smog.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL +#MONITOR O3; + +#INITVALUES + +CFACTOR = 1.; +ALL_SPEC = 1.0E-8; +RH = 2.0 ; +RCHO = 2.0 ; +NO = 0.5 ; +NO2 = 0.1 ; +H2O = 1.3E+4 ; +O2 = 2.0E+5 ; + +#INLINE F77_INIT + TSTART = 0 + TEND = TSTART + 600 + DT = 60.0 + TEMP = 298 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0 + TEND = TSTART + 600 + DT = 60.0 + TEMP = 298 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0; + TEND = TSTART + 600; + DT = 60.0; + TEMP = 298; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0; + TEND = TSTART + 600; + DT = 60.0; + TEMP = 298; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.eqn new file mode 100755 index 00000000..8aa6d696 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.eqn @@ -0,0 +1,17 @@ +#EQUATIONS + +{ A Generalized Reaction Mechanism for Photochemical Smog } + +{ 1.} NO2 + hv = NO + O : 0.533 ; +{ 2.} O + O2 = O3 : 2.183E-5 ; +{ 3.} NO + O3 = NO2 + O2 : 26.59 ; +{ 4.} RH + OH = RO2 + H2O : 3.775E+3 ; +{ 5.} RCHO + OH = RCOO2 + H2O : 2.341E+4 ; +{ 6.} RCHO + hv = RO2 + HO2 + CO : 1.91E-4 ; +{ 7.} HO2 + NO = NO2 + OH : 1.214E+4 ; +{ 8.} RO2 + NO = NO2 + RCHO + HO2 : 1.127E+4 ; +{ 9.} RCOO2 + NO = NO2 + RO2 + CO2 : 1.127E+4 ; +{10.} OH + NO2 = HNO3 : 1.613E+4 ; +{11.} RCOO2 + NO2 = RCOO2NO2 : 6.893E+3 ; +{12.} RCOO2NO2 = RCOO2 + NO2 : 2.143E-2 ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.spc new file mode 100755 index 00000000..fa070ef9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/smog.spc @@ -0,0 +1,37 @@ +#include atoms + + #DEFVAR + O = O ; {oxygen atomic ground state (3P)} + O3 = 3O ; {ozone} + NO = N + O ; {nitric oxide} + NO2 = N + 2O ; {nitrogen dioxide} + NO3 = N + 3O ; {nitrogen trioxide} + N2O5 = 2N + 5O ; {dinitrogen pentoxide} + HNO3 = H + N + 3O ; { nitric acid } + HNO4 = H + N + 4O ; {HO2NO2 pernitric acid} + H = H ; {hydrogen atomic ground state (2S)} + OH = O + H ; {hydroxyl radical} + HO2 = H + 2O ; {perhydroxyl radical} + H2O2 = 2H + 2O ; {hydrogen peroxide} + CH3 = C + 3H ; {methyl radical} + CH3O = C + 3H + O ; {methoxy radical} + CH3O2 = C + 3H + 2O ; {methylperoxy radical} + CH3OOH = C + 4H + 2O ; {CH4O2 methylperoxy alcohol} + HCO = H + C + O ; {CHO formyl radical} + CH2O = C + 2H + O ; {formalydehyde} + + RH = ignore ; + RO2 = ignore ; + RCHO = ignore ; + RCOO2 = ignore ; + RCOO2NO2 = ignore ; + +#DEFFIX + H2O = H + 2O ; {water} + H2 = 2H ; {molecular hydrogen} + O2 = 2O ; {molecular oxygen} + N2 = 2N ; {molecular nitrogen} + CH4 = C + 4H ; {methane} + CO = C + O ; {carbon monoxide} + CO2 = C + 2O ; {carbon dioxide} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/stochastic_dimer.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/stochastic_dimer.def new file mode 100755 index 00000000..56959750 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/models/stochastic_dimer.def @@ -0,0 +1,62 @@ +{Decaying-dimerizing reaction set + (Gillespie, J. Chem. Phys. 115(4), p. 1716, 2001)} + +#DEFVAR +S1 = ignore; {} +S2 = ignore; {} +S3 = ignore; {} + +#EQUATIONS +S1 = PROD : (1); {c1} +S1 + S1 = S2 : (0.004);{2*c2} +S2 = S1 + S1 : (0.5); {c3} +S2 = S3 : (0.04); {c4} + +#LOOKATALL + +#INITVALUES + CFACTOR = 1.0; + S1 = 1.0e+5; + S2 = 0.0; + S3 = 0.0; + +#INLINE F77_INIT + TSTART = 0.d0 + TEND = 30.0d0 + DT = 0.5d0; + DO i=1,NVAR + RTOL(i) = 1.0e-4 + ATOL(i) = 1.0e-8 + END DO + Volume = 1.0d0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0.d0 + TEND = 30.0d0 + DT = 0.5d0 + RTOL(1:NVAR) = 1.0e-4 + ATOL(1:NVAR) = 1.0e-8 + Volume = 1.0d0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0; + TEND = 30; + DT = 0.5; + RTOL(1:NVAR) = 1.0e-4; + ATOL(1:NVAR) = 1.0e-8; + Volume = 1; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0.0; + TEND = 30.0; + DT = 0.5; + for(i=0; i +;; Time-stamp: <2005-02-15 15:18:42 sander> + +;; to activate it copy kpp.el to a place where emacs can find it and then +;; add "(require 'kpp)" to your .emacs startup file + +;; known problem: +;; ":" inside comments between reaction products confuses font-lock + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; start kpp-mode automatically when loading a *.eqn, *.spc, or *.kpp file +(setq auto-mode-alist + (cons '("\\.eqn\\'" . kpp-mode) auto-mode-alist)) +(setq auto-mode-alist + (cons '("\\.spc\\'" . kpp-mode) auto-mode-alist)) +(setq auto-mode-alist + (cons '("\\.kpp\\'" . kpp-mode) auto-mode-alist)) + +(setq kpp-font-lock-keywords + (list + '("^\\([^=\n]*=[^:\n]*\\):[^;\n]*;" 1 font-lock-constant-face) ; reaction + ;; alternatively, use another color for rate constant: + ;; '("^\\([^=\n]*=[^:\n]*\\):\\([^;\n]*\\);" + ;; (1 font-lock-constant-face) (2 font-lock-keyword-face)) + '("<[A-z0-9_#]+>" 0 font-lock-variable-name-face t) ; equation tag + '("{[^}\n]*}" 0 font-lock-comment-face t) ; comment + '("!.*" 0 font-lock-comment-face t) ; f90 comment + '("{@[^}]+}" 0 font-lock-doc-face t) ; alternative LaTeX text + '("{$[^}]+}" 0 font-lock-string-face t) ; alternative LaTeX text + '("{&[^}]+}" 0 font-lock-builtin-face t) ; BibTeX reference + '("{%[A-z0-9#]+}" 0 font-lock-type-face t) ; marker + ;; KPP sections (Tab. 3 in thesis), commands (Tab. 13 in thesis), and + ;; fragments (Tab. 17 in thesis) + (cons (concat + "\\(#ATOMS\\|#CHECKALL\\|#CHECK\\|#DEFFIX\\|#DEFRAD" + "\\|#DEFVAR\\|#DOUBLE\\|#DRIVER\\|#DUMMYINDEX" + "\\|#ENDINLINE\\|#EQNTAGS\\|#EQUATIONS\\|#FUNCTION" + "\\|#HESSIAN\\|#INCLUDE\\|#INITIALIZE" + "\\|#INITVALUES\\|#INLINE\\|#INTEGRATOR\\|#INTFILE" + "\\|#JACOBIAN\\|#LANGUAGE\\|#LOOKATALL" + "\\|#LOOKAT\\|#LUMP\\|#MEX\\|#MODEL\\|#MONITOR" + "\\|#REORDER\\|#RUN\\|#SETFIX\\|#SETRAD\\|#SETVAR" + "\\|#SPARSEDATA\\|#STOCHASTIC\\|#STOICMAT\\|#TRANSPORTALL" + "\\|#TRANSPORT\\|#USE\\|#USES\\|#WRITE_ATM" + "\\|#WRITE_MAT\\|#WRITE_OPT\\|#WRITE_SPC" + "\\|#XGRID\\|#YGRID\\|#ZGRID\\)" + ) 'font-lock-keyword-face) + '("^//.*" 0 font-lock-comment-face t) ; comment + ) +) + +; comment a region (adopted from wave-comment-region) + +(defvar kpp-comment-region "// " + "*String inserted by \\[kpp-comment-region] at start of each line in region.") + +(defun kpp-comment-region (beg-region end-region arg) + "Comments every line in the region. +Puts kpp-comment-region at the beginning of every line in the region. +BEG-REGION and END-REGION are args which specify the region boundaries. +With non-nil ARG, uncomments the region." + (interactive "*r\nP") + (let ((end-region-mark (make-marker)) (save-point (point-marker))) + (set-marker end-region-mark end-region) + (goto-char beg-region) + (beginning-of-line) + (if (not arg) ;comment the region + (progn (insert kpp-comment-region) + (while (and (= (forward-line 1) 0) + (< (point) end-region-mark)) + (insert kpp-comment-region))) + (let ((com (regexp-quote kpp-comment-region))) ;uncomment the region + (if (looking-at com) + (delete-region (point) (match-end 0))) + (while (and (= (forward-line 1) 0) + (< (point) end-region-mark)) + (if (looking-at com) + (delete-region (point) (match-end 0)))))) + (goto-char save-point) + (set-marker end-region-mark nil) + (set-marker save-point nil))) + +(defvar kpp-mode-map () + "Keymap used in kpp mode.") + +(if kpp-mode-map + () + (setq kpp-mode-map (make-sparse-keymap)) + (define-key kpp-mode-map "\C-c;" 'kpp-comment-region) + ;; TAB inserts 8 spaces, not the TAB character + (define-key kpp-mode-map (kbd "TAB") + '(lambda () (interactive) (insert " "))) +) + +(defun kpp-mode () + "Major mode for editing kpp code. +Turning on kpp mode calls the value of the variable `kpp-mode-hook' +with no args, if that value is non-nil. + +Command Table: +\\{kpp-mode-map}" + (interactive) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '((kpp-font-lock-keywords) t t)) + (make-local-variable 'comment-start) + (setq comment-start "{") + (make-local-variable 'comment-end) + (setq comment-end "}") + (use-local-map kpp-mode-map) + (setq mode-name "kpp") + (setq major-mode 'kpp-mode) + (turn-on-font-lock) + (set-syntax-table (copy-syntax-table)) + (modify-syntax-entry ?_ "w") ; the underscore can be part of a word + (auto-fill-mode 0) ; no automatic line breaks + (run-hooks 'kpp-mode-hook) +) + +(provide 'kpp) + +;; kpp.el ends here diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/Makefile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/Makefile new file mode 100755 index 00000000..96623645 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/Makefile @@ -0,0 +1,87 @@ +######################################################################################## +# +# KPP - The Kinetic PreProcessor +# Builds simulation code for chemical kinetic systems +# +# Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu +# Copyright (C) 1997-2005 Adrian Sandu +# with contributions from: Mirela Damian, Rolf Sander +# +# KPP is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the +# License, or (at your option) any later version. +# +# KPP is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along +## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or +# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +# Adrian Sandu +# Computer Science Department +# Virginia Polytechnic Institute and State University +# Blacksburg, VA 24060 +# E-mail: sandu@cs.vt.edu +# +####################################################################################### + +include ../Makefile.defs + +YACC=yacc -d +CFLAGS=`cat ../cflags` + +all: kpp + +.c.o: + @echo " "$(CC) $(CC_FLAGS) $(CFLAGS) -c $*.c + @$(CC) $(CC_FLAGS) $(CFLAGS) -c $*.c + +OBJS = \ + y.tab.o \ + lex.yy.o \ + scanner.o \ + scanutil.o \ + kpp.o \ + gen.o \ + code.o \ + code_c.o \ + code_f77.o \ + code_f90.o \ + code_matlab.o \ + debug.o + +kpp: $(OBJS) + @echo " "$(CC) $(CC_FLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp + @$(CC) $(CC_FLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp + @mv kpp ../bin + +clean: + @rm -f *~ *.o cflags + +maintainer-clean: clean + @rm -f lex.yy.c y.tab.c y.tab.h + +lex.yy.c: scan.l scan.h + @echo " "$(FLEX) scan.l + @$(FLEX) scan.l + +y.tab.c: scan.y scan.h + @echo " "$(YACC) scan.y + @$(YACC) scan.y + +flex: lex.yy.c y.tab.c + +scanner.o: scan.h gdata.h +scanutil.o: scan.h +kpp.o: gdata.h +gen.o: gdata.h code.h +debug.o: gdata.h +code.o: gdata.h code.h + +code_c.o: gdata.h code.h +code_f.o: gdata.h code.h diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.c new file mode 100755 index 00000000..0efbd0ab --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.c @@ -0,0 +1,818 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include +#include + +/* NONE, ADD, SUB, MUL, DIV, POW, CONST, ELM, VELM, MELM, EELM */ +int PRI[] = { 10, 1, 1, 2, 2, 3, 10, 10, 10, 10, 10 }; + +void (*WriteElm)( NODE *n ); +void (*WriteSymbol)( int op ); +void (*WriteAssign)( char* lval, char* rval ); +void (*WriteComment)( char *fmt, ... ); +void (*Declare)( int v ); +void (*ExternDeclare)( int v ); +void (*GlobalDeclare)( int v ); +void (*InitDeclare)( int var, int nv, void * values ); +void (*DeclareConstant)( int v, char *val ); +void (*FunctionStart)( int f, int *vars ); +void (*FunctionPrototipe)( int f, ... ); +void (*FunctionBegin)( int f, ... ); +void (*FunctionEnd)( int f ); + +NODE * substList; +int substENABLED = 1; +int crtop = NONE; +char *outBuf; +char *outBuffer; + +VARIABLE cnst = { "", CONST, REAL, 0, 0 }; +VARIABLE expr = { "", EELM, 0, 0, 0 }; +VARIABLE *varTable[ MAX_VAR ] = { &cnst, &expr }; + +int IsConst( NODE *n, float val ); +NODE * BinaryOp( int op, NODE *n1, NODE *n2 ); +int NodeCmp( NODE *n1, NODE *n2 ); +NODE * NodeCopy( NODE *n1 ); +void WriteNode( NODE *n ); +void WriteOp( int op ); +void ExpandElm( NODE * n ); +int ExpandNode( NODE *n, int lastop ); +NODE * LookUpSubst( NODE *n ); + +FILE * param_headerFile = 0; +FILE * initFile = 0; /* mz_rs_20050117 */ +FILE * driverFile = 0; +FILE * integratorFile = 0; +FILE * linalgFile = 0; +FILE * functionFile = 0; +FILE * jacobianFile = 0; +FILE * rateFile = 0; +FILE * stoichiomFile = 0; +FILE * utilFile = 0; +FILE * sparse_dataFile = 0; +FILE * sparse_jacFile = 0; +FILE * sparse_hessFile = 0; +FILE * sparse_stoicmFile = 0; +FILE * stochasticFile = 0; +FILE * global_dataFile = 0; +FILE * hessianFile = 0; +FILE * mapFile = 0; +FILE * makeFile = 0; +FILE * monitorFile = 0; +FILE * mex_funFile = 0; +FILE * mex_jacFile = 0; +FILE * mex_hessFile = 0; + +FILE * currentFile; + +int ident = 0; + +FILE * UseFile( FILE * file ) +{ +FILE *oldf; + if (file == NULL) { + printf("\n\nKPP Warning (internal): trying to UseFile NULL file pointer!\n"); + } + oldf = currentFile; + currentFile = file; + return oldf; +} + +void OpenFile( FILE **fpp, char *name, char * ext, char * identity ) +{ +char bufname[200]; +char buf[200]; +time_t t; +int blength; + + time( &t ); + sprintf( bufname, "%s%s", name, ext ); + if( *fpp ) fclose( *fpp ); + *fpp = fopen( bufname, "w" ); + if ( *fpp == 0 ) + FatalError(3,"%s: Can't create file", bufname ); + + UseFile( *fpp ); + + WriteDelim(); + WriteComment(""); + WriteComment("%s",identity); + WriteComment(""); + WriteComment("Generated by KPP-%s symbolic chemistry Kinetics PreProcessor", + KPP_VERSION ); + WriteComment(" (http://www.cs.vt.edu/~asandu/Software/KPP)"); + WriteComment("KPP is distributed under GPL, the general public licence"); + WriteComment(" (http://www.gnu.org/copyleft/gpl.html)"); + WriteComment("(C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa" ); + WriteComment("(C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech" ); + WriteComment(" With important contributions from:" ); + WriteComment(" M. Damian, Villanova University, USA"); + WriteComment(" R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany"); + WriteComment(""); + WriteComment("%-20s : %s", "File", bufname ); + strcpy( buf, ctime( &t ) ); + buf[ (int)strlen(buf) - 1 ] = 0; + WriteComment("%-20s : %s", "Time", buf ); + WriteComment("%-20s : %s", "Working directory", getcwd(buf, 200) ); + WriteComment("%-20s : %s", "Equation file", eqFileName ); + WriteComment("%-20s : %s", "Output root filename", rootFileName ); + WriteComment(""); + WriteDelim(); + NewLines(1); +/* Include Headers in .c Files, except Makefile */ + blength = strlen(bufname); + if ( (bufname[blength-2]=='.')&&(bufname[blength-1]=='c') ) { + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include \"%s_Parameters.h\"", rootFileName); + C_Inline("#include \"%s_Global.h\"", rootFileName); + if( useJacSparse ) + C_Inline("#include \"%s_Sparse.h\"", rootFileName); + } + NewLines(2); +} + +void AllowBreak() +{ + *(outBuffer-1) |= 0x80; +} + +void bprintf( char *fmt, ... ) +{ +Va_list args; + + if ( !fmt ) return; + Va_start( args, fmt ); + vsprintf( outBuffer, fmt, args ); + va_end( args ); + outBuffer += strlen( outBuffer ); +} + +void FlushBuf() +{ +char *p; + + p = outBuf; + while( *p ) + *p++ &= ~0x80; + fprintf( currentFile, outBuf ); + outBuffer = outBuf; + *outBuffer = 0; +} + +void FlushThisBuf( char * buf ) +{ +char *p; + + p = buf; + while( *p ) + *p++ &= ~0x80; + fprintf( currentFile, buf ); +} + +void WriteDelim() +{ +/* + WriteComment("****************************************************************"); +*/ + WriteComment("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); +} + +void NewLines( int n ) +{ + for( ; n > 0; n-- ) + bprintf("\n"); + + FlushBuf(); +} + +void IncludeFile( char * fname ) +{ +FILE *fp; +#define MAX_LINE 200 +char line[ MAX_LINE ]; + + + fp = fopen( fname, "r" ); + if ( fp == 0 ) + FatalError(3,"%s: Can't read file", fname ); + + FlushBuf(); + + while( !feof(fp) ) { + *line = '\0'; + fgets( line, MAX_LINE, fp ); + fputs( line, currentFile ); + } + + fclose( fp ); +} + +void IncludeCode( char* fmt, ... ) +{ +Va_list args; +char buf[200]; +char cmd[500]; +static char tmpfile[] = "kppfile.tmp"; +FILE * fp; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + switch( useLang ) { + case F77_LANG: sprintf( buf, "%s.f", buf ); + break; + case F90_LANG: sprintf( buf, "%s.f90", buf ); + break; + case C_LANG: sprintf( buf, "%s.c", buf ); + break; + case MATLAB_LANG: sprintf( buf, "%s.m", buf ); + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + fp = fopen( buf, "r" ); + if ( fp == 0 ) + FatalError(3,"%s: Can't read file", buf ); + fclose(fp); + + strcpy( cmd, "sed " ); + + sprintf( cmd, "%s -e 's/KPP_ROOT/%s/g'", cmd, rootFileName ); + sprintf( cmd, "%s -e 's/KPP_NVAR/%d/g'", cmd, VarNr ); + sprintf( cmd, "%s -e 's/KPP_NFIX/%d/g'", cmd, FixNr ); + sprintf( cmd, "%s -e 's/KPP_NSPEC/%d/g'", cmd,SpcNr ); + sprintf( cmd, "%s -e 's/KPP_NREACT/%d/g'", cmd, EqnNr ); + sprintf( cmd, "%s -e 's/KPP_NONZERO/%d/g'", cmd, Jac_NZ ); + sprintf( cmd, "%s -e 's/KPP_LU_NONZERO/%d/g'", cmd, LU_Jac_NZ ); + sprintf( cmd, "%s -e 's/KPP_NHESS/%d/g'", cmd, Hess_NZ ); + + switch( useLang ) { + case F77_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, F77_types[real] ); + break; + case F90_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, F90_types[real] ); + break; + case C_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, C_types[real] ); + break; + case MATLAB_LANG: + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + + sprintf( cmd, "%s %s > %s", cmd, buf, tmpfile ); + + system( cmd ); + IncludeFile( tmpfile ); + sprintf( cmd, "rm %s", tmpfile ); + system( cmd ); +} + +void MapFunctionComment( int f, int *vars ) +{ +FILE *oldf; + + oldf = UseFile( mapFile ); + FunctionStart( f, vars ); + /*NewLines(1); + CommentFncBegin( f, vars );*/ + FlushBuf(); + UseFile( oldf ); +} + +int DefineVariable( char * name, int t, int bt, int maxi, int maxj, char * comment ) +{ +int i; +VARIABLE * var; + + for( i = 0; i < MAX_VAR; i++ ) + if( varTable[ i ] == 0 ) break; + + if( varTable[ i ] != 0 ) { + printf("\nVariable Table overflow"); + return -1; + } + + var = (VARIABLE*) malloc( sizeof( VARIABLE ) ); + var->name = name; + var->type = t; + var->baseType = bt; + var->maxi = maxi; + var->maxj = maxj; + var->value = -1; + var->comment = comment; + + varTable[ i ] = var; + return i; +} + +void FreeVariable( int n ) +{ + if( varTable[ n ] ) { + free( varTable[ n ] ); + varTable[ n ] = 0; + } +} + +NODE * Elm( int v, ... ) +{ +Va_list args; +NODE *n; +ELEMENT *elm; +VARIABLE *var; +int i, j; +float val; +char *expr; + + var = varTable[ v ]; + n = (NODE*) malloc( sizeof(NODE) ); + elm = (ELEMENT*) malloc( sizeof(ELEMENT) ); + n->left = 0; + n->right = 0; + n->sign = 1; + n->type = var->type; + n->elm = elm; + elm->var = v; + + Va_start( args, v ); + switch( var->type ) { + case CONST: switch( var->baseType ) { + case REAL: elm->val.cnst = (float)va_arg( args, double ); + break; + case INT: elm->val.cnst = (float)va_arg( args, int ); + } + if( elm->val.cnst < 0 ) { + elm->val.cnst = -elm->val.cnst; + n->sign = -1; + } + break; + case ELM: + break; + case VELM: elm->val.idx.i = va_arg( args, int ); + break; + case MELM: elm->val.idx.i = va_arg( args, int ); + elm->val.idx.j = va_arg( args, int ); + break; + case EELM: elm->val.expr = va_arg( args, char* ); + break; + } + va_end( args ); + + return n; +} + +int IsConst( NODE *n, float val ) +{ + return ( ( n ) && + ( n->type == CONST ) && + ( n->elm->val.cnst == val ) + ); +} + +NODE * BinaryOp( int op, NODE *n1, NODE *n2 ) +{ +NODE *n; + + n = (NODE*) malloc( sizeof(NODE) ); + n->left = n1; + n->right = n2; + n->type = op; + n->sign = 1; + n->elm = 0; + return n; +} + +NODE * Add( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + + if( IsConst( n1, 0 ) ) { + FreeNode( n1 ); + return n2; + } + if( IsConst( n2, 0 ) ) { + FreeNode( n2 ); + return n1; + } + return BinaryOp( ADD, n1, n2 ); +} + +NODE * Sub( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return BinaryOp( SUB, 0, n2 ); + if( n2 == 0 ) return n1; + + if( IsConst( n1, 0 ) ) { + FreeNode( n1 ); + return BinaryOp( SUB, 0, n2 ); + } + if( IsConst( n2, 0 ) ) { + FreeNode( n2 ); + return n1; + } + return BinaryOp( SUB, n1, n2 ); +} + +NODE * Mul( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + + if( IsConst( n1, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n1 ); + return n2; + } + if( IsConst( n2, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n2 ); + return n1; + } + if( IsConst( n1, 0 ) ) { + FreeNode( n2 ); + return n1; + } + if( IsConst( n2, 0 ) ) { + FreeNode( n1 ); + return n2; + } + + return BinaryOp( MUL, n1, n2 ); +} + +NODE * Div( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return BinaryOp( DIV, Const(1), n2 ); + if( n2 == 0 ) return n1; + + if( IsConst( n2, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n2 ); + return n1; + } + + return BinaryOp( DIV, n1, n2 ); +} + +NODE * Pow( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + return BinaryOp( POW, n1, n2 ); +} + +void FreeNode( NODE * n ) +{ + if( n == 0 ) return; + FreeNode( n->left ); + FreeNode( n->right ); + if( n->elm ) free( n->elm ); + free( n ); +} + +int NodeCmp( NODE *n1, NODE *n2 ) +{ +ELEMENT *elm1; +ELEMENT *elm2; + + if( n1 == n2 ) return 1; + if( n1 == 0 ) return 0; + if( n2 == 0 ) return 0; + + if( (n1->type % SUBST) != (n2->type % SUBST) ) return 0; + + elm1 = n1->elm; + elm2 = n2->elm; + + if( elm1 == elm2 ) return 1; + if( elm1 == 0 ) return 0; + if( elm2 == 0 ) return 0; + + if( elm1->var != elm2->var )return 0; + switch( n1->type ) { + case CONST: if( elm1->val.cnst != elm2->val.cnst ) return 0; + break; + case ELM: break; + case VELM: if( elm1->val.idx.i != elm2->val.idx.i ) return 0; + break; + case MELM: if( elm1->val.idx.i != elm2->val.idx.i ) return 0; + if( elm1->val.idx.j != elm2->val.idx.j ) return 0; + break; + case EELM: if( strcmp( elm1->val.expr, elm2->val.expr ) != 0 ) return 0; + break; + } + + return 1; +} + +NODE * NodeCopy( NODE *n1 ) +{ +NODE *n; +ELEMENT *elm; + + n = (NODE*) malloc( sizeof(NODE) ); + elm = (ELEMENT*) malloc( sizeof(ELEMENT) ); + *n = *n1; + n->elm = elm; + *n->elm = *n1->elm; + return n; +} + +void WriteNode( NODE *n ) +{ + crtop = NONE; + ExpandNode( n, NONE ); +} + +void WriteOp( int op ) +{ + WriteSymbol( op ); + crtop = NONE; +} + +void ExpandElm( NODE * n ) +{ +NODE *cn; + + if( substENABLED == 0 ) { + WriteElm( n ); + return; + } + cn = LookUpSubst( n ); + if( cn == 0 ) { + WriteElm( n ); + } else { + if( cn->type > SUBST ) { + WriteElm( n ); + } else { + cn->type += SUBST; + WriteSymbol( O_PAREN ); + WriteNode( cn->right ); + WriteSymbol( C_PAREN ); + cn->type -= SUBST; + } + } +} + +int ExpandNode( NODE *n, int lastop ) +{ +int needParen = 0; + + if( n == 0 ) return lastop; + + if( ( n->left ) && + ( PRI[ n->left->type ] < PRI[ n->type ] ) ) + needParen = 1; + + if( needParen ) { + WriteOp( crtop ); + WriteSymbol( O_PAREN ); + } + lastop = ExpandNode( n->left, lastop ); + if( needParen ) WriteSymbol( C_PAREN ); + + switch( n->type ) { + case ADD: + case SUB: + case MUL: + case DIV: + case POW: crtop = n->type; + break; + case NONE: printf("ERROR - null element"); + break; + case CONST: + case ELM: + case VELM: + case MELM: + case EELM: + switch( crtop ) { + case MUL: case DIV: case POW: + WriteOp( crtop ); + if ( n->sign == -1 ) { + WriteSymbol( O_PAREN ); + WriteOp( SUB ); + ExpandElm( n ); + WriteSymbol( C_PAREN ); + } else { + ExpandElm( n ); + } + break; + case ADD: if( n->sign == -1 ) + crtop = SUB; + WriteOp( crtop ); + ExpandElm( n ); + break; + case SUB: if( n->sign == -1 ) + crtop = ADD; + WriteOp( crtop ); + ExpandElm( n ); + break; + case NONE: if( n->sign == -1 ) + WriteOp( SUB ); + ExpandElm( n ); + break; + } + break; + } + + if( ( n->right ) && + ( PRI[ n->right->type ] <= PRI[ n->type ] ) ) + needParen = 1; + + if( needParen ) { + WriteOp( crtop ); + WriteSymbol( O_PAREN ); + } + lastop = ExpandNode( n->right, n->type ); + if( needParen ) WriteSymbol( C_PAREN ); + return lastop; +} + +void Assign( NODE *lval, NODE *rval ) +{ +char *ls; +char *rs; +char *olds; + + ls = (char*)malloc( MAX_OUTBUF ); + rs = (char*)malloc( MAX_OUTBUF ); + + olds = outBuffer; + outBuffer = ls; + WriteNode( lval ); + outBuffer = rs; + WriteNode( rval ); + outBuffer = olds; + + WriteAssign( ls, rs ); + + free( rs ); + free( ls ); + FreeNode( lval ); + FreeNode( rval ); +} + +NODE * LookUpSubst( NODE *n ) +{ +NODE *cn; + + cn = substList; + while( cn != 0 ) { + if( NodeCmp( n, cn ) ) + return cn; + cn = cn->left; + } + return 0; +} + +void MkSubst( NODE *n1, NODE *n2 ) +{ +NODE *n; + + n = LookUpSubst( n1 ); + if( n == 0 ) { + n = n1; + n->left = substList; + substList = n; + } else { + FreeNode( n->right ); + FreeNode( n1 ); + } + n->right = n2; +} + +void RmSubst( NODE *n ) +{ +NODE *pn; +NODE *cn; + + pn = 0; + cn = substList; + while( cn != 0 ) { + if( NodeCmp( n, cn ) ) + break; + pn = cn; + cn = cn->left; + } + if( cn == 0 ) return; + + FreeNode( cn->right ); + if( pn ) + pn->left = cn->left; + else + substList = cn->left; + + cn->right = 0; + cn->left = 0; + FreeNode( cn ); +} + +void DisplaySubst() +{ +NODE *n; + + n = substList; + substENABLED = 0; + while( n != 0 ) { + printf("Subst: "); + WriteElm( n ); + printf( " --> " ); + WriteNode( n->right ); + printf("\n"); + n = n->left; + } + substENABLED = 1; +} + +void CommentFncBegin( int f, int *vars ) +{ +VARIABLE *var; +char * name; +int narg; +int i; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + var = varTable[ f ]; + + WriteDelim(); + WriteComment(""); + WriteComment("%s - %s", var->name, var->comment ); + WriteComment(" Arguments :"); + for( i = 0; i < narg; i++ ) { + var = varTable[vars[i]]; + WriteComment(" %-10s- %s", var->name, var->comment ); + } + WriteComment(""); + WriteDelim(); + NewLines(1); +} + +void CommentFunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + /* MapFunctionComment( f, vars ); */ +} + +void CommentFunctionEnd( int f ) +{ + WriteComment("End of %s function", varTable[ f ]->name ); + WriteDelim(); + NewLines(2); +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.h new file mode 100755 index 00000000..2f7f9dd8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code.h @@ -0,0 +1,190 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#ifndef _CODE_H_ +#define _CODE_H_ + +#include +#include "gdef.h" + +#define MAX_DEPTH 10 +#define MAX_SUBST 20 +#define SUBST 100 +#define MAX_VAR 150 +#define MAX_OUTBUF 200000 +#define MAX_COLS 8 +#define MAX_LINES 20 + +#define WriteAll bprintf + +enum types { NONE, ADD, SUB, MUL, DIV, POW, CONST, ELM, VELM, MELM, EELM, FNC }; +extern int PRI[]; + +enum signs { O_PAREN = 20, C_PAREN }; +enum base_types { VOID, INT, REAL, DOUBLE, STRING, DOUBLESTRING }; +/* mz_rs_20050117+ */ +extern FILE * initFile; +/* mz_rs_20050117- */ +extern FILE * driverFile; +extern FILE * functionFile; +extern FILE * global_dataFile; +extern FILE * hessianFile; +extern FILE * integratorFile; +extern FILE * jacobianFile; +extern FILE * linalgFile; +extern FILE * mapFile; +extern FILE * makeFile; +extern FILE * monitorFile; +extern FILE * mex_funFile; +extern FILE * mex_jacFile; +extern FILE * mex_hessFile; +extern FILE * param_headerFile; +extern FILE * rateFile; +extern FILE * sparse_dataFile; +extern FILE * sparse_jacFile; +extern FILE * sparse_hessFile; +extern FILE * sparse_stoicmFile; +extern FILE * stoichiomFile; +extern FILE * stochasticFile; +extern FILE * utilFile; + +extern FILE * currentFile; + +extern int ident; +extern int real; +extern char * CommonName; + +void OpenFile( FILE **fpp, char *name, char * ext, char * identity ); +FILE * UseFile( FILE *fp ); + +typedef struct { + char *name; + int type; + int baseType; + int maxi; + int maxj; + int value; + char *comment; + } VARIABLE; + +extern VARIABLE* varTable[]; + +extern char *outBuf; +extern char *outBuffer; + +void AllowBreak(); +void bprintf( char *fmt, ... ); +void FlushBuf(); +void FlushThisBuf( char * buf ); +void NewLines( int n ); +void C_Inline( char *fmt, ... ); +void F77_Inline( char *fmt, ... ); +void IncludeFile( char * fname ); +void IncludeCode( char *fmt, ... ); +void MapFunctionComment( int f, int *vars ); + +int DefineVariable( char * name, int t, int bt, int maxi, int maxj, char * comment ); +void FreeVariable( int n ); + +#define DefConst( name, bt, cmt ) DefineVariable( name, CONST, bt, 0, 0, cmt ) +#define DefElm( name, bt, cmt ) DefineVariable( name, ELM, bt, 0, 0, cmt ) +#define DefvElm( name, bt, n, cmt ) DefineVariable( name, VELM, bt, n, 0, cmt ) +#define DefmElm( name, bt, m, n, cmt ) DefineVariable( name, MELM, bt, m, n, cmt ) +#define DefeElm( name, cmt ) DefineVariable( name, EELM, 0, 0, 0, cmt ) +#define DefFnc( name, n, cmt ) DefineVariable( name, FNC, 0, n, 0, cmt ) + +typedef struct { + int var; + union { + char * expr; + float cnst; + struct { + int i; + int j; + } idx; + } val; + } ELEMENT; + +typedef struct node { + struct node * left; + struct node * right; + int type; + int sign; + ELEMENT *elm; + } NODE; + +extern char *F77_types[]; +extern char *F90_types[]; +extern char *C_types[]; +extern char *MATLAB_types[]; + +NODE * Elm( int v, ... ); +#define Const( x ) Elm( 0, (double)x ) +#define Expr( x ) Elm( 1, x ) + +void FreeNode( NODE * n ); + +NODE * Add( NODE *n1, NODE *n2 ); +NODE * Sub( NODE *n1, NODE *n2 ); +NODE * Mul( NODE *n1, NODE *n2 ); +NODE * Div( NODE *n1, NODE *n2 ); +NODE * Pow( NODE *n1, NODE *n2 ); + +void Assign( NODE *lval, NODE *rval ); +void MkSubst( NODE *n1, NODE *n2 ); +void RmSubst( NODE *n ); +void CommentFncBegin( int f, int *vars ); +void CommentFunctionBegin( int f, ... ); +void CommentFunctionEnd( int f ); + +void Use_C(); +void Use_F(); +void Use_F90(); +void Use_MATLAB(); + +extern void (*WriteElm)( NODE *n ); +extern void (*WriteSymbol)( int op ); +extern void (*WriteAssign)( char* ls, char* rs ); +extern void (*WriteComment)( char *fmt, ... ); +extern void (*Declare)( int v ); +extern void (*ExternDeclare)( int v ); +extern void (*GlobalDeclare)( int v ); +extern void (*InitDeclare)( int v, int n, void * values ); +extern void (*DeclareConstant)( int v, char *val ); +extern void (*FunctionStart)( int f, int *vars ); +extern void (*FunctionPrototipe)( int f, ... ); +extern void (*FunctionBegin)( int f, ... ); +extern void (*FunctionEnd)( int f ); + +void WriteDelim(); + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_c.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_c.c new file mode 100755 index 00000000..64deef20 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_c.c @@ -0,0 +1,543 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include + +#define MAX_LINE 120 +#define LINE_LENGTH 70 + +int fncPrototipe = 0; + +char *C_types[] = { "void", /* VOID */ + "int", /* INT */ + "float", /* FLOAT */ + "double", /* DOUBLE */ + "char *", /* STRING */ + "char *" /* DOUBLESTRING */ + }; + +void C_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s[%s]", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s[%s][%s]", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +void C_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +void C_WriteAssign( char *ls, char *rs ) +{ +int start; +int crtident; +int linelg; +int i,j; +char c; +int first; +int number_of_lines = 1, MAX_NO_OF_LINES = 99; +int ifound, jfound; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 2 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + crtident + 2; + linelg = LINE_LENGTH - start; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) {/* if a new line needs to be started */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + /*for( i=linelg; i>10; i-- ) + if( ( rs[i] & 0x80 ) || ( rs[i] == ',' ) ) + break; + if( i < 10 ) { + printf("\nPossible error when cutting lines"); + i = linelg; + }*/ + + c = rs[i]; + rs[i] = 0; + if ( first ) { + bprintf("%s", rs ); + linelg++; + first = 0; + } else { + bprintf("\n%*s%s", start, "", rs ); + if ( jfound ) { + bprintf(";\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) + printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls); + + if ( first ) bprintf("%s;\n", rs ); + else bprintf("\n%*s%s;\n", start, "", rs ); + + FlushBuf(); +} + +void C_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + bprintf( "/* %-*s */\n", LINE_LENGTH - 6, buf ); + + FlushBuf(); +} + + +char * C_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = C_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + sprintf( buf, "%s %s", baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /*if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + sprintf( maxi, "%s+1", maxi );*/ + if( fncPrototipe ) + sprintf( buf, "%s %s[]", baseType, var->name ); + else + sprintf( buf, "%s %s[%s]", baseType, var->name, maxi ); + break; + case MELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + if( fncPrototipe ) + sprintf( buf, "%s %s[][]", baseType, var->name ); + else + sprintf( buf, "%s %s[%s][%s]", + baseType, var->name, maxi, maxj ); + break; + default: + Message( "Can not declare type %d", var->type ); + Message( "v = %d", v ); + break; + } + return buf; +} + +void C_Declare( int v ) +{ + bprintf("%-40s", strcat( C_Decl(v), ";" ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_ExternDeclare( int v ) +{ + bprintf("extern %-40s", strcat( C_Decl(v), ";" ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_GlobalDeclare( int v ) +{ + C_Declare( v ); +} + +void C_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +int maxCols = MAX_COLS; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + if( var->comment ) + bprintf(" /* %s */\n\n", var->comment ); + + switch( var->type ) { + case VELM: bprintf( " %s %s[] = {\n%5s", C_types[var->baseType], var->name, " " ); + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "\"%s\"", cval[i] ); maxCols=8; break; + case DOUBLESTRING:bprintf( "\"%s\"", cval[i] ); maxCols=1; break; + } + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) bprintf( "\n%5s", " " ); + } + if( n == 0 ) bprintf( "0" ); + bprintf( " }; \n\n" ); + break; + + case ELM: bprintf( " %s %s = ", C_types[var->baseType], var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "\"%s\"", *cval ); break; + case DOUBLESTRING:bprintf( "\"%s\"", *cval ); break; + } + bprintf( ";\n\n" ); + break; + + default: printf( "\n Function not defined !\n" ); + break; + } + + FlushBuf(); +} + +void C_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + switch( var->type ) { + case CONST: bprintf("#define %-20s %-10s ", var->name, val ); + break; + default: + printf( "Invalid constant", var->type ); + break; + } + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + fncPrototipe = 1; + + bprintf("void %s( \n", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf(" %-38s", strcat( C_Decl(v), "," ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + } + if( narg >= 1 ) { + v = vars[ i ]; + bprintf(" %-38s", C_Decl(v) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + } + bprintf(")"); + + fncPrototipe = 0; + + FlushBuf(); +} + +void C_FunctionPrototipe( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + C_FunctionStart( f, vars ); + bprintf(";\n"); + + FlushBuf(); +} + +void C_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + C_FunctionStart( f, vars ); + bprintf("\n"); + bprintf("{\n"); + + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +void C_FunctionEnd( int f ) +{ + bprintf("}\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +void C_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != C_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n",buf ); + + FlushBuf(); +} + +void Use_C() +{ + WriteElm = C_WriteElm; + WriteSymbol = C_WriteSymbol; + WriteAssign = C_WriteAssign; + WriteComment = C_WriteComment; + DeclareConstant = C_DeclareConstant; + Declare = C_Declare; + ExternDeclare = C_ExternDeclare; + GlobalDeclare = C_GlobalDeclare; + InitDeclare = C_InitDeclare; + + FunctionStart = C_FunctionStart; + FunctionPrototipe = C_FunctionPrototipe; + FunctionBegin = C_FunctionBegin; + FunctionEnd = C_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.h", "Parameter Header File" ); + OpenFile( &initFile, rootFileName, "_Initialize.c", "Initialization File" ); + OpenFile( &driverFile, rootFileName, "_Main.c", "Main Program File" ); + OpenFile( &integratorFile, rootFileName, "_Integrator.c", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.c", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.c", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.c", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.c", + "The Reaction Rates File" ); + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.c", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.c", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.c", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.c", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.h", "Sparse Data Header File" ); + OpenFile( &global_dataFile, rootFileName, "_Global.h", "Global Data Header File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.c", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.c", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.c", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.c", + "Utility Data Initialization" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f77.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f77.c new file mode 100755 index 00000000..ce8b1e5f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f77.c @@ -0,0 +1,588 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include + +#define MAX_LINE 120 + +char *F77_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL", /* FLOAT */ + "REAL*8", /* DOUBLE */ + "CHARACTER*12", /* STRING */ + "CHARACTER*100" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void F77_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void F77_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void F77_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i,j; +char c; +int first; +int crtident; +int number_of_lines = 1, MAX_NO_OF_LINES = 36; +int ifound, jfound; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 6 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 70 - crtident - start - 1; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) {/* if a new line needs to be started */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + /*for( i=linelg; i>10; i-- ) + if( ( rs[i] & 0x80 )||( rs[i]==',' ) ) + break; + if( i < 10 ) { + printf("\nPossible error when cutting lines"); + i = linelg; + } */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf("\n &%*s%s", start, "", rs ); + if ( jfound ) { + bprintf("\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) + printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls); + + if ( first ) bprintf("%s\n", rs ); /* non-split row */ + else bprintf("\n &%*s%s\n", start, "", rs ); /* last line in a split row */ + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F77_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "C %-65s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +char * F77_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = F77_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: sprintf( buf, "%s %s", + baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + sprintf( buf, "%s %s(%s)", + baseType, var->name, maxi ); + break; + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + /*if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1");*/ + sprintf( buf, "%s %s(%s,%s)", + baseType, var->name, maxi, maxj ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void F77_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + F77_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + bprintf(" %s\n", F77_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_ExternDeclare( int v ) +{ + F77_Declare( v ); + bprintf(" COMMON /%s/ %s\n", CommonName, varTable[ v ]->name ); +} + +/*************************************************************************************************/ +void F77_GlobalDeclare( int v ) +{ +} + +/*************************************************************************************************/ +void F77_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + F77_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" %s %s\n", + F77_types[ var->baseType ], var->name ); + bprintf(" PARAMETER ( %s = %s )\n", + var->name, val); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + +/*************************************************************************************************/ +void WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sDATA( %s(i), i = %d, %d ) /\n%5s*", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sDATA %s /\n%5s*", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_DeclareData( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s*", " " ); + nlines++; + } + } + max ++; + } + WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sDATA %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void F77_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + F77_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void F77_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" SUBROUTINE %s ( ", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s, ", varTable[ v ]->name ); + } + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("%s ", varTable[ v ]->name ); + } + bprintf(")\n"); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_FunctionPrototipe( int f, ... ) +{ +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + F77_FunctionStart( f, vars ); + NewLines(1); + bprintf(" IMPLICIT NONE\n" ); + bprintf(" INCLUDE '%s_Parameters.h'\n\n", rootFileName ); + + FlushBuf(); + + for( i = 0; i < narg; i++ ) + F77_Declare( vars[ i ] ); + + bprintf("\n"); + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void F77_FunctionEnd( int f ) +{ + bprintf(" RETURN\n"); + bprintf(" END\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +/*************************************************************************************************/ +void F77_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != F77_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void Use_F() +{ + WriteElm = F77_WriteElm; + WriteSymbol = F77_WriteSymbol; + WriteAssign = F77_WriteAssign; + WriteComment = F77_WriteComment; + DeclareConstant = F77_DeclareConstant; + Declare = F77_Declare; + ExternDeclare = F77_ExternDeclare; + GlobalDeclare = F77_GlobalDeclare; + InitDeclare = F77_InitDeclare; + + FunctionStart = F77_FunctionStart; + FunctionPrototipe = F77_FunctionPrototipe; + FunctionBegin = F77_FunctionBegin; + FunctionEnd = F77_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.h", "Parameter Header File" ); + OpenFile( &initFile, rootFileName, "_Initialize.f", "Initialization File" ); + OpenFile( &driverFile, rootFileName, "_Main.f", "Main Program File" ); + OpenFile( &integratorFile, rootFileName, "_Integrator.f", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.f", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.f", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.f", + "The Reaction Rates File" ); + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.f", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.f", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.h", "Sparse Data Header File" ); + OpenFile( &global_dataFile, rootFileName, "_Global.h", "Global Data Header File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.f", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.f", + "Initialization of Utility Data Structures" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f90.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f90.c new file mode 100755 index 00000000..95febea9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_f90.c @@ -0,0 +1,764 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include + +#define MAX_LINE 120 + +char *F90_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL(kind=sp)", /* FLOAT */ + "REAL(kind=dp)", /* DOUBLE */ + "CHARACTER(LEN=12)", /* STRING */ + "CHARACTER(LEN=100)" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void F90_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void F90_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void F90_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i, j; +int ifound, jfound; +char c; +int first; +int crtident; + +/* Max no of continuation lines in F90/F95 differs with compilers, but 39 + should work for every compiler*/ +int number_of_lines = 1, MAX_NO_OF_LINES = 36; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 2 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 120 - crtident - start - 1; /* F90 max line length is 132 */ + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) { + /* If a new line needs to be started. + Note: the approach below will create erroneous code if the +/- is within a subexpression, e.g. for + A*(B+C) one cannot start a new continuation line by splitting at the + sign */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: double-check continuation lines for:\n %s = %s\n",ls,rs); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf("&\n %*s&%s", start, "", rs ); + if ( jfound ) { + bprintf("\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; /* jump to the first not-yet-written character */ + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) { + printf("\n Warning: %d continuation lines for %s = ...",number_of_lines,ls); + } + + if ( first ) bprintf("%s\n", rs ); /* non-split row */ + else bprintf("&\n %*s&%s\n", start, "", rs ); /* last line in a split row */ + + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F90_WriteComment( char *fmt, ... ) +{ +Va_list args; +int n; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + /* remove trailing spaces */ + /* taken from http://www.cs.bath.ac.uk/~pjw/NOTES/ansi_c/ch10-idioms.pdf */ + for (n= strlen(buf) - 1; n >= 0; n--) + if (buf[n] != ' ') break; + buf[n + 1]= '\0'; + bprintf( "! %s\n", buf ); + FlushBuf(); +} + +/*************************************************************************************************/ +char * F90_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = F90_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + sprintf( buf, "%s :: %s", baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + /*sprintf( buf, "%s, DIMENSION(%s) :: %s", baseType, maxi, var->name );*/ + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + sprintf( buf, "%s :: %s(%s)", baseType, var->name, maxi ); + break; + case MELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + /* else sprintf( maxj, "%s", varTable[ -var->maxj ]->name); */ + /*if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1");*/ + /*sprintf( buf, "%s, DIMENSION(%s,%s) :: %s", + baseType, maxi, maxj,var->name ); */ + sprintf( buf, "%s :: %s(%s,%s)", + baseType, var->name, maxi, maxj ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +char * F90_DeclareData( int v, void * values, int n) +{ +int i, j; +int nlines; +int split; +static char buf[120]; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +char *baseType; +char maxi[20]; +char maxj[20]; +int maxCols = MAX_COLS; +char dsbuf[200]; + + int i_from, i_to; + int isplit; + int splitsize; + int maxi_mod; + int maxi_div; + + char mynumber[30]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double *) values; + cval = (char **) values; + + nlines = 1; + split = 0; + var -> maxi = max( n, 1 ); + + baseType = F90_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + bprintf( " %s :: %s = ", baseType, var->name ); + switch ( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: bprintf( "%f", *dval); break; + case REAL: bprintf( "%lg", *dval ); break; + case STRING: bprintf( "'%3s'", *cval ); break; + } + break; + case VELM: + /* define maxCols here already and choose suitable splitsize */ + switch( var -> baseType ) { + case INT: maxCols =12; break; + case DOUBLE: maxCols = 5; break; + case REAL: maxCols = 5; break; + case STRING: maxCols = 3; break; + case DOUBLESTRING: maxCols = 1; break; + } + splitsize = 30 * maxCols; /* elements = lines * columns */ + maxi_mod = var->maxi % splitsize; + maxi_div = var->maxi / splitsize; + /* correction if var->maxi is a multiple of splitsize */ + if ( (maxi_div>0) && (maxi_mod==0) ) { + maxi_mod = splitsize; + maxi_div--; + } + for ( isplit=0; isplit <= maxi_div; isplit++ ) { + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + bprintf( " %s, " , baseType); + if( n>0 ) bprintf( "PARAMETER, " ); /* if values are assigned now */ + if ( maxi_div==0 ) { /* define array in one piece */ + bprintf( "DIMENSION(%s) :: %s", + maxi, var->name) ; + } else {/* define partial arrays */ + if ( isplit==maxi_div ) { /* last part has size maxi_mod */ + bprintf( "DIMENSION(%d) :: %s_%d", + maxi_mod, var->name, isplit) ; + } else { /* all other parts have size splitsize */ + bprintf( "DIMENSION(%d) :: %s_%d", + splitsize, var->name, isplit) ; + } + } + if( n<=0 ) break; + + /* now list values */ + bprintf( " = (/ &\n " ); + /* if the array is defined in one piece, then the for loop will + go from 0 to n. Otherwise, there will be partial arrays from + i_from to i_to which are of size splitsize except for the + last one which is usually smaller and contains the rest */ + i_from = isplit * splitsize; + i_to = min(i_from+splitsize,n); + for ( i=i_from; i < i_to; i++ ) { + switch( var -> baseType ) { + case INT: + bprintf( "%3d", ival[i] ); break; + case DOUBLE: + /* bprintf( "%4f", dval[i] ); maxCols = 5; break; */ + sprintf(mynumber, "%12.6e_dp",dval[i]); + /* mynumber[ strlen(mynumber)-4 ] = 'd'; */ + bprintf( " %s", mynumber ); break; + case REAL: + bprintf( "%12.6e", dval[i] ); break; + case STRING: + bprintf( "'%-12s'", cval[i] ); break; + case DOUBLESTRING: + /* strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; */ + /* bprintf( "'%48s'", dsbuf ); break; */ + bprintf( "'%-100.100s'", cval[i] ); break; + } + if( i < i_to-1 ) { + bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( " &\n " ); + nlines++; + } + } + } + bprintf( " /)\n" ); + } + + /* combine the partial arrays */ + if ( maxi_div != 0 ) { + bprintf( " %s, PARAMETER, DIMENSION(%s) :: %s = (/&\n ", + baseType, maxi, var->name) ; + for ( isplit=0; isplit <= maxi_div; isplit++ ) { + bprintf( "%s_%d", var->name, isplit) ; + if( isplit < maxi_div ) { /* more parts will follow */ + bprintf( ", " ); + /* line break after 5 variables */ + if( (isplit+1) % 5 == 0 ) bprintf( "&\n " ); + } else { /* after last part */ + bprintf( " /)\n" ); + } + } + } + + break; + + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s\n", /* changed here */ + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void F90_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + F90_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + bprintf(" %s\n", F90_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_ExternDeclare( int v ) +{ + F90_Declare( v ); +// bprintf(" COMMON /%s/ %s\n", CommonName, varTable[ v ]->name ); +} + +/*************************************************************************************************/ +void F90_GlobalDeclare( int v ) +{ +} + +/*************************************************************************************************/ +void F90_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + F90_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" %s, PARAMETER :: %s = %s \n", + F90_types[ var->baseType ], var->name, val ); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F90_WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sdata( %s(i), i = %d, %d ) / &\n%5s", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sdata %s / &\n%5s", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_DeclareDataOld( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + F90_WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s", " " ); + nlines++; + } + } + max ++; + } + F90_WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sdata %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void F90_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + F90_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void F90_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf("SUBROUTINE %s ( ", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s, ", varTable[ v ]->name ); + } + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("%s ", varTable[ v ]->name ); + } + bprintf(")\n"); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_FunctionPrototipe( int f, ... ) +{ +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + F90_FunctionStart( f, vars ); + NewLines(1); + /* bprintf(" USE %s_Precision\n", rootFileName ); + bprintf(" USE %s_Parameters\n\n", rootFileName ); */ + /* bprintf(" IMPLICIT NONE\n" ); */ + + FlushBuf(); + + for( i = 0; i < narg; i++ ) + F90_Declare( vars[ i ] ); + + bprintf("\n"); + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void F90_FunctionEnd( int f ) +{ + bprintf(" \nEND SUBROUTINE %s\n\n", varTable[ f ]->name ); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +/*************************************************************************************************/ +void F90_Inline( char *fmt, ... ) +{ +va_list args; +char buf[ 1000 ]; + + if( useLang != F90_LANG ) return; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); + +} + +/*************************************************************************************************/ +void Use_F90() +{ + WriteElm = F90_WriteElm; + WriteSymbol = F90_WriteSymbol; + WriteAssign = F90_WriteAssign; + WriteComment = F90_WriteComment; + DeclareConstant = F90_DeclareConstant; + Declare = F90_Declare; + ExternDeclare = F90_ExternDeclare; + GlobalDeclare = F90_GlobalDeclare; + InitDeclare = F90_InitDeclare; + + FunctionStart = F90_FunctionStart; + FunctionPrototipe = F90_FunctionPrototipe; + FunctionBegin = F90_FunctionBegin; + FunctionEnd = F90_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.f90", "Parameter Module File" ); + /* mz_rs_20050117+ */ + OpenFile( &initFile, rootFileName, "_Initialize.f90", "Initialization File" ); + /* mz_rs_20050117- */ + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + OpenFile( &driverFile, rootFileName, "_Main.f90", "Main Program File" ); + /* mz_rs_20050518- */ + OpenFile( &integratorFile, rootFileName, "_Integrator.f90", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f90", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.f90", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.f90", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.f90", + "The Reaction Rates File" ); + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.f90", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f90", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f90", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.f90", + "Auxiliary Routines File" ); + /* OpenFile( &sparse_dataFile, rootFileName, "_Sparse.f90", + "Sparse Data Module File" );*/ + OpenFile( &global_dataFile, rootFileName, "_Global.f90", "Global Data Module File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f90", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.f90", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f90", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.f90", + "Utility Data Module File" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_matlab.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_matlab.c new file mode 100755 index 00000000..746486b9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/code_matlab.c @@ -0,0 +1,719 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include + +#define MAX_LINE 120 + +char *MATLAB_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL", /* FLOAT */ + /*"REAL(dp)", */ /* DOUBLE */ + "DOUBLE PRECISION", /* DOUBLE */ + "CHARACTER(LEN=12)", /* STRING */ + "CHARACTER(LEN=100)" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void MATLAB_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void MATLAB_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("^"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void MATLAB_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i, j; +int ifound, jfound; +char c; +int first; +int crtident; + +/* Max no of continuation lines in F95 standard is 39 */ +int number_of_lines = 1, MAX_NO_OF_LINES = 36; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 3 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 70 - crtident - start - 1; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) { + /* If a new line needs to be started. + Note: the approach below will create erroneous code if the +/- is within a subexpression, e.g. for + A*(B+C) one cannot start a new continuation line by splitting at the + sign */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf(" ...\n %*s%s", start, "", rs ); + if ( jfound ) { + bprintf(" ;\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; /* jump to the first not-yet-written character */ + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) { + printf("\n Warning: %d continuation lines for %s = ...",number_of_lines,ls); + } + + if ( first ) bprintf("%s ;\n", rs ); /* non-split row */ + else bprintf(" ...\n %*s%s;\n", start, "", rs ); /* last line in a split row */ + + + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + fprintf( currentFile, "%c ", '%' ); + bprintf( "%-65s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +char * MATLAB_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + buf[0] = 0; return buf; /* Nothing to declare in matlab */ + var = varTable[ v ]; + baseType = MATLAB_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: sprintf( buf, "%s :: %s", + baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + sprintf( buf, "%s, DIMENSION(%s) :: %s", + baseType, maxi, var->name ); + break; + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s", + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +char * MATLAB_DeclareData( int v, void * values, int n) +{ +int i, j; +int nlines, nmax; +int split; +static char buf[120]; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +char *baseType; +char maxi[20]; +char maxj[20]; +int maxCols = MAX_COLS; +char dsbuf[55]; + + int i_from, i_to; + int isplit; + int splitsize; + int maxi_mod; + int maxi_div; + + char mynumber[30]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double *) values; + cval = (char **) values; + + nlines = 1; + nmax = 1; + split = 0; + var -> maxi = max( n, 1 ); + + baseType = MATLAB_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { /* changed here */ + case ELM: + /* bprintf( " %s :: %s = ", baseType, var->name ); + switch ( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: bprintf( "%f", *dval); break; + case REAL: bprintf( "%lg", *dval ); break; + case STRING: bprintf( "'%3s'", *cval ); break; + } */ + break; + case VELM: + splitsize = 36; /*elements*/ + maxi_mod = var->maxi % splitsize; + maxi_div = var->maxi / splitsize; + + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + /* now list values */ + /* if ( (var->baseType==STRING)||(var->baseType==DOUBLESTRING) ) { + bprintf( "%s(1:%s,:) = [ ... \n", var->name, maxi) ; + } else { + bprintf( "%s(1:%s) = [ ... \n", var->name, maxi) ; + }*/ + if ( (var->baseType==STRING)||(var->baseType==DOUBLESTRING) ) { + bprintf( "%s = [ ... \n", var->name, maxi) ; + } else { + bprintf( "%s = [ ... \n", var->name, maxi) ; + } + + /* if the array is defined in one piece, then the for loop will + go from 0 to n. Otherwise, there will be partial arrays from + i_from to i_to which are of size splitsize except for the + last one which is usually smaller and contains the rest */ + for ( i=0; i < n; i++ ) { + switch( var -> baseType ) { + case INT: + bprintf( "%4d", ival[i] ); maxCols =12; break; + case DOUBLE: + sprintf(mynumber, "%12.6e",dval[i]); + bprintf( " %s", mynumber ); maxCols = 5; break; + case REAL: + bprintf( "%12.6e", dval[i] ); maxCols = 5; break; + case STRING: + bprintf( "'%12s'", cval[i] ); maxCols = 3; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( i < n-1 ) { + bprintf( ";" ); + if( (i+1) % maxCols == 0 ) { + bprintf( " ... \n" ); + nlines++; + } + } + } + bprintf( " ];\n" ); + break; + + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s\n", /* changed here */ + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void MATLAB_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + MATLAB_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + FlushBuf(); + bprintf(" %s\n", MATLAB_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_ExternDeclare( int v ) +{ + if( varTable[ v ]->comment ) { + MATLAB_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + FlushBuf(); + bprintf(" global %s;\n", varTable[ v ]->name ); + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_GlobalDeclare( int v ) +{ +} + + +/*************************************************************************************************/ +void MATLAB_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + MATLAB_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" global %s;",var->name, val ); + bprintf(" %s = %s; \n", var->name, val ); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sdata( %s(i), i = %d, %d ) / &\n%5s", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sdata %s / &\n%5s", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_DeclareDataOld( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + MATLAB_WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s", " " ); + nlines++; + } + } + max ++; + } + MATLAB_WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sdata %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void MATLAB_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + MATLAB_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void MATLAB_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf("function " ); + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("[ %s ] = ", varTable[ v ]->name ); + } + bprintf(" %s_%s ( ", rootFileName, name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s ", varTable[ v ]->name ); + if (iname; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; +char buf[200], bufname[200]; +time_t t; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + /*Adi - each Matlab functin requires a separate file*/ + sprintf( buf, "%s_%s.m", rootFileName, varTable[ f ]->name ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + /*Adi*/ + + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + + WriteDelim(); + WriteComment(""); + WriteComment("Generated by KPP - symbolic chemistry Kinetics PreProcessor" ); + WriteComment(" KPP is developed at CGRER labs University of Iowa by" ); + WriteComment(" Valeriu Damian & Adrian Sandu" ); + WriteComment(""); + WriteComment("%-20s : %s", "File", buf ); + strcpy( buf, (char*)ctime( &t ) ); + buf[ (int)strlen(buf) - 1 ] = 0; + WriteComment("%-20s : %s", "Time", buf ); + WriteComment("%-20s : %s", "Working directory", getcwd(buf, 200) ); + WriteComment("%-20s : %s", "Equation file", eqFileName ); + WriteComment("%-20s : %s", "Output root filename", rootFileName ); + WriteComment(""); + WriteDelim(); + NewLines(1); + + MATLAB_FunctionStart( f, vars ); + NewLines(1); + + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void MATLAB_FunctionEnd( int f ) +{ + bprintf(" \nreturn\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); + + /*Adi*/ + fclose(mex_funFile); + + +} + +/*************************************************************************************************/ +void MATLAB_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != MATLAB_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void Use_MATLAB() +{ + WriteElm = MATLAB_WriteElm; + WriteSymbol = MATLAB_WriteSymbol; + WriteAssign = MATLAB_WriteAssign; + WriteComment = MATLAB_WriteComment; + DeclareConstant = MATLAB_DeclareConstant; + Declare = MATLAB_Declare; + ExternDeclare = MATLAB_ExternDeclare; + GlobalDeclare = MATLAB_GlobalDeclare; + InitDeclare = MATLAB_InitDeclare; + + FunctionStart = MATLAB_FunctionStart; + FunctionPrototipe = MATLAB_FunctionPrototipe; + FunctionBegin = MATLAB_FunctionBegin; + FunctionEnd = MATLAB_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.m","Parameter Definition File" ); + OpenFile( &driverFile, rootFileName, "_Main.m", "Main Program File" ); + OpenFile( &rateFile, rootFileName, "_Rates.m", + "The Reaction Rates File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.m", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.m", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.m", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.m", + "Sparse Data Definition File" ); + OpenFile( &global_dataFile, rootFileName, "_Global_defs.m", "Global Data Definition File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.m", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.m", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.m", + "Utility Data Definition File" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/copyright b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/copyright new file mode 100755 index 00000000..ecfc2a21 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/copyright @@ -0,0 +1,32 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/debug.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/debug.c new file mode 100755 index 00000000..703c4e06 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/debug.c @@ -0,0 +1,148 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "scan.h" + +void WriteAtoms() +{ +int i; + + printf("\nATM -----------------------------------------------" ); + + for( i = 0; i < SpeciesNr; i++ ) { + switch( AtomTable[i].check ) { + case NO_CHECK: + printf( "\n(%3d) %6s, NO -- ------ ", i, AtomTable[i].name ); + break; + case DO_CHECK: + printf( "\n(%3d) %6s, -- DO ------", i, AtomTable[i].name ); + break; + case CANCEL_CHECK: + printf( "\n(%3d) %6s, -- -- CANCEL", i, AtomTable[i].name ); + break; + default: + printf( "\n(%3d) %6s, -- -- ------ UNKNOWN [%d]", i, + AtomTable[i].name, AtomTable[i].check ); + break; + } + } +} + +void WriteSpecies() +{ +int i; +int j; +char *type; +char *lookat; + + printf("\nSPC -----------------------------------------------" ); + + for( i = 0; i < SpeciesNr; i++ ) { + + switch( SpeciesTable[i].type ) { + case VAR_SPC: type = "V - -"; break; + case RAD_SPC: type = "- R -"; break; + case FIX_SPC: type = "- - F"; break; + default: type = "? ? ?"; break; + } + + switch( SpeciesTable[i].lookat ) { + case 0: lookat = "----"; break; + case 1: lookat = "LOOK"; break; + default: lookat = "????"; break; + } + + printf( "\n(%3d) %-10s, type %s,%s {", + i, SpeciesTable[i].name, type, lookat ); + for( j = 0; j < SpeciesTable[i].nratoms; j++ ) + printf( " %d%s", SpeciesTable[i].atoms[j].nr, + AtomTable[ SpeciesTable[i].atoms[j].code ].name ); + printf("}"); + } +} + +void WriteMatrices() +{ +int i, j; + + printf("\nMAT ------------------ cc -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich_Left[i][j] ); + } + } + + printf("\nMAT ------------------ cd -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich_Right[i][j] ); + } + } + + printf("\nMAT ------------------ cf -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i], Reactive[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich[i][j] ); + } + } +} + +void WriteOptions() +{ + printf("\n### Options -------------------------------------------\n"); + if( useAggregate ) printf("FUNCTION - AGGREGATE\n"); + else printf("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: printf("JACOBIAN - OFF\n"); break; + case JAC_FULL: printf("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: printf("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: printf("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) printf("DOUBLE - ON\n"); + else printf("DOUBLE - OFF\n"); + if( useReorder ) printf("REORDER - ON\n"); + else printf("REORDER - OFF\n"); + if( useMex ) printf("MEX - ON\n"); + else printf("MEX - OFF\n"); + if( useDummyindex) printf("DUMMYINDEX - ON\n"); + else printf("DUMMYINDEX - OFF\n"); + if( useEqntags) printf("EQNTAGS - ON\n"); + else printf("EQNTAGS - OFF\n"); +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdata.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdata.h new file mode 100755 index 00000000..0deefd33 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdata.h @@ -0,0 +1,207 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + +#define KPP_VERSION "2.1" + +#ifndef _GDATA_H_ +#define _GDATA_H_ + +#include + +#define MAX_EQN 900 /* mz_rs_20050130 */ +#define MAX_SPECIES 400 /* mz_rs_20050130 */ +#define MAX_SPNAME 30 +#define MAX_IVAL 40 +/* MAX_EQNTAG = max length of equation ID in eqn file */ +#define MAX_EQNTAG 12 +/* MAX_K = max length of rate expression in eqn file */ +#define MAX_K 150 +#define MAX_ATOMS 10 +#define MAX_ATNAME 10 +#define MAX_ATNR 250 +#define MAX_PATH 120 +#define MAX_FILES 20 +#define MAX_EQNLEN 100 + +#define NO_CODE -1 +#define max( x, y ) (x) > (y) ? (x) : (y) +#define min( x, y ) (x) < (y) ? (x) : (y) + +#define IncName(x) FileName((x),"MODELS","models","") +#define ModelName(x) FileName((x),"MODELS","models",".def") +#define IntegName(x) FileName((x),"INTEG","int",".def") + +enum krtypes { NUMBER, EXPRESION, PHOTO }; +enum table_modes { F_TEXT, FC_TEXT, C_TEXT, S_TEXT }; +enum lang { NO_LANG, C_LANG, F77_LANG, F90_LANG, MATLAB_LANG }; +enum inl_code { F77_GLOBAL, F77_INIT, F77_DATA, F77_UTIL, F77_RATES, F77_RCONST, + F90_GLOBAL, F90_INIT, F90_DATA, F90_UTIL, F90_RATES, F90_RCONST, + C_GLOBAL, C_INIT, C_DATA, C_UTIL, C_RATES, C_RCONST, + MATLAB_GLOBAL, MATLAB_INIT, MATLAB_DATA, MATLAB_UTIL, MATLAB_RATES, MATLAB_RCONST, + INLINE_OPT + }; + +enum jacobian_format { JAC_OFF, JAC_FULL, JAC_LU_ROW, JAC_ROW }; + + +typedef short int CODE; +typedef float EQ_VECT[ MAX_EQN ]; + +typedef struct { + char name[ MAX_ATNAME ]; + char check; + char masscheck; + } ATOM_DEF; + +typedef struct { + unsigned char code; + unsigned char nr; + } ATOM; + +typedef struct { + char type; + char lookat; + char moni; + char trans; + short int nratoms; + char name[ MAX_SPNAME ]; + char ival[ MAX_IVAL ]; + ATOM atoms[ MAX_ATOMS ]; + } SPECIES_DEF; + +typedef struct { + char type; + union { + char st[ MAX_K ]; + float f; + } val; + char label[ MAX_EQNTAG ]; + } KREACT; + +typedef struct { + char * code; + int maxlen; + } ICODE; + + +extern int SpeciesNr; +extern int EqnNr; +extern int SpcNr; +extern int AtomNr; +extern int VarNr; +extern int VarActiveNr; +extern int FixNr; +extern int VarStartNr; +extern int FixStartNr; +extern int Hess_NZ; +extern int LU_Jac_NZ; +extern int Jac_NZ; + +extern int generateSD; + +extern int initNr; +extern int xNr; +extern int yNr; +extern int zNr; + +extern int falseSpcNr; + +extern int useAggregate; +extern int useJacobian; +extern int useJacSparse; +extern int useHessian; +extern int useStoicmat; +extern int useDouble; +extern int useReorder; +extern int useMex; +extern int useDummyindex; +extern int useEqntags; +extern int useLang; +extern int useStochastic; + +extern char Home[ MAX_PATH ]; +extern char integrator[ MAX_PATH ]; +extern char driver[ MAX_PATH ]; +extern char runArgs[ MAX_PATH ]; + +extern char *eqFileName; +extern char *rootFileName; + +extern ATOM_DEF AtomTable[ MAX_ATNR ]; +extern SPECIES_DEF SpeciesTable[ MAX_SPECIES ]; +extern KREACT kr [ MAX_EQN ]; +extern CODE ReverseCode[ MAX_SPECIES ]; +extern CODE Code [ MAX_SPECIES ]; +extern float** Stoich_Left; +extern float** Stoich; +extern float** Stoich_Right; +extern int Reactive [ MAX_SPECIES ]; + +extern int **structB; +extern int **structJ; +extern int **LUstructJ; + +extern ICODE InlineCode[ INLINE_OPT ]; + +extern char *fileList[ MAX_FILES ]; +extern int fileNr; + +extern char varDefault[ MAX_IVAL ]; +extern char radDefault[ MAX_IVAL ]; +extern char fixDefault[ MAX_IVAL ]; +extern double cfactor; + +void CmdFunction( char *cmd ); +void CmdJacobian( char *cmd ); +void CmdHessian( char *cmd ); +void CmdDouble( char *cmd ); +void CmdReorder( char *cmd ); +void CmdMex( char *cmd ); +void CmdDummyindex( char *cmd ); +void CmdEqntags( char *cmd ); +void CmdUse( char *cmd ); +void CmdLanguage( char *cmd ); +void CmdIntegrator( char *cmd ); +void CmdDriver( char *cmd ); +void CmdRun( char *cmd ); +void CmdStochastic( char *cmd ); + +void Generate(); + +char * FileName( char *name, char* env, char *dir, char *ext ); + +int* AllocIntegerVector( int n, char* message ); +int** AllocIntegerMatrix( int m, int n, char* message ); +void FreeIntegerMatrix ( int** mat, int m, int n ); +int Index( int i ); + +#endif + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdef.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdef.h new file mode 100755 index 00000000..39f38277 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gdef.h @@ -0,0 +1,46 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#ifndef _GDEF_H_ +#define _GDEF_H_ + +#include + +#if defined ( __BORLANDC__ ) + #include +#endif + +#include +#define Va_start( x, y ) va_start( x, y ) +#define Va_list va_list + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gen.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gen.c new file mode 100755 index 00000000..d4cd5326 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/gen.c @@ -0,0 +1,3324 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include "scan.h" + +#define MAX_MONITOR 8 + + +enum strutypes { PLAIN, LU }; + +int **structB; +int **structJ; +int **LUstructJ; + +ICODE InlineCode[ INLINE_OPT ]; + +int NSPEC, NVAR, NVARACT, NFIX, NREACT; +int NVARST, NFIXST, PI; +int C_DEFAULT, C; +int DC; +int ARP, JVRP, NJVRP, CROW_JVRP, IROW_JVRP, ICOL_JVRP; +int V, F, VAR, FIX; +int RCONST, RCT; +int Vdot, P_VAR, D_VAR; +int KR, A, BV, BR, IV; +int JV, UV, JUV, JTUV, JVS; +int JR, UR, JUR, JRS; +int U1, U2, HU, HTU; +int X, XX, NTMPB; +int D2A, NTMPD2A, NHESS, HESS, IHESS_I, IHESS_J, IHESS_K; +int DDMTYPE; +int STOICM, NSTOICM, IROW_STOICM, ICOL_STOICM, CCOL_STOICM, CNEQN; +int IROW, ICOL, CROW, DIAG; +int LU_IROW, LU_ICOL, LU_CROW, LU_DIAG, CNVAR; +int LOOKAT, NLOOKAT, MONITOR, NMONITOR; +int NMASS, SMASS; +int SPC_NAMES, EQN_NAMES; +int EQN_TAGS; +int NONZERO, LU_NONZERO; +int TIME, SUN, TEMP; +int RTOLS, TSTART, TEND, DT; +int ATOL, RTOL, STEPMIN, STEPMAX, CFACTOR; +int V_USER, CL; +int NMLCV, NMLCF, SCT, PROPENSITY, VOLUME, IRCT; + +int Jac_NZ, LU_Jac_NZ, nzr; + +NODE *sum, *prod; +int real; +int nlookat; +int nmoni; +int ntrans; +int nmass; +char * CommonName; + +int Hess_NZ, *iHess_i, *iHess_j, *iHess_k; +int nnz_stoicm; + +/* if ValueDimension=1 KPP replaces parameters like NVAR etc. by their values in vector/matrix declarations */ +char ValueDimension = 0; + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +char * ascii(int x) +{ +static char s[40]; + + sprintf(s, "%d", x); + return s; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +char * ascid(double x) +{ +static char s[40]; + + sprintf(s, "%12.6e", x); + /* if (useDouble && ( (useLang==F77_LANG)||(useLang==F90_LANG) ) ) { */ + if (useDouble && (useLang==F77_LANG)) + s[strlen(s)-4] = 'd'; + if (useDouble && (useLang==F90_LANG)) + sprintf(s, "%s_dp",s); + return s; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +NODE * RConst( int n ) +{ + switch( kr[n].type ) { + case NUMBER: return Const( kr[n].val.f ); + case PHOTO: + case EXPRESION: return Elm( RCT, n ); + } + return 0; +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void InitGen() +{ +int i,j; + + NSPEC = DefConst( "NSPEC", INT, "Number of chemical species" ); + NVAR = DefConst( "NVAR", INT, "Number of Variable species" ); + NVARACT = DefConst( "NVARACT", INT, "Number of Active species" ); + NFIX = DefConst( "NFIX", INT, "Number of Fixed species" ); + NREACT = DefConst( "NREACT", INT, "Number of reactions" ); + NVARST = DefConst( "NVARST", INT, "Starting of variables in conc. vect." ); + NFIXST = DefConst( "NFIXST", INT, "Starting of fixed in conc. vect." ); + NONZERO = DefConst( "NONZERO", INT, "Number of nonzero entries in Jacobian" ); + LU_NONZERO = DefConst( "LU_NONZERO", INT, "Number of nonzero entries in LU factoriz. of Jacobian" ); + CNVAR = DefConst( "CNVAR", INT, "(NVAR+1) Number of elements in compressed row format" ); + CNEQN = DefConst( "CNEQN", INT, "(NREACT+1) Number stoicm elements in compressed col format" ); + + PI = DefConst( "PI", real, "Value of pi" ); + + VAR = DefvElm( "VAR", real, -NVAR, "Concentrations of variable species (global)" ); + FIX = DefvElm( "FIX", real, -NFIX, "Concentrations of fixed species (global)" ); + + V = DefvElm( "V", real, -NVAR, "Concentrations of variable species (local)" ); + F = DefvElm( "F", real, -NFIX, "Concentrations of fixed species (local)" ); + + V_USER = DefvElm( "V_USER", real, -NVAR, "Concentration of variable species in USER's order" ); + + RCONST = DefvElm( "RCONST", real, -NREACT, "Rate constants (global)" ); + RCT = DefvElm( "RCT", real, -NREACT, "Rate constants (local)" ); + + Vdot = DefvElm( "Vdot", real, -NVAR, "Time derivative of variable species concentrations" ); + P_VAR = DefvElm( "P_VAR", real, -NVAR, "Production term" ); + D_VAR = DefvElm( "D_VAR", real, -NVAR, "Destruction term" ); + + + JVS = DefvElm( "JVS", real, -LU_NONZERO, "sparse Jacobian of variables" ); + + JV = DefmElm( "JV", real, -NVAR, -NVAR, "full Jacobian of variables" ); + + UV = DefvElm( "UV", real, -NVAR, "User vector for variables" ); + JUV = DefvElm( "JUV", real, -NVAR, "Jacobian times user vector" ); + JTUV = DefvElm( "JTUV",real, -NVAR, "Jacobian transposed times user vector" ); + + X = DefvElm( "X", real, -NVAR, "Vector for variables" ); + XX = DefvElm( "XX", real, -NVAR, "Vector for output variables" ); + + TIME = DefElm( "TIME", real, "Current integration time"); + SUN = DefElm( "SUN", real, "Sunlight intensity between [0,1]"); + TEMP = DefElm( "TEMP", real, "Temperature"); + + RTOLS = DefElm( "RTOLS", real, "(scalar) Relative tolerance"); + TSTART = DefElm( "TSTART", real, "Integration start time"); + TEND = DefElm( "TEND", real, "Integration end time"); + DT = DefElm( "DT", real, "Integration step"); + + A = DefvElm( "A", real, -NREACT, "Rate for each equation" ); + + ARP = DefvElm( "ARP", real, -NREACT, "Reactant product in each equation" ); + NJVRP = DefConst( "NJVRP", INT, "Length of sparse Jacobian JVRP" ); + JVRP = DefvElm( "JVRP", real, -NJVRP, "d ARP(1:NREACT)/d VAR (1:NVAR)" ); + CROW_JVRP= DefvElm( "CROW_JVRP", INT, -CNEQN, "Beginning of rows in JVRP" ); + ICOL_JVRP= DefvElm( "ICOL_JVRP", INT, -NJVRP, "Column indices in JVRP" ); + IROW_JVRP= DefvElm( "IROW_JVRP", INT, -NJVRP, "Row indices in JVRP" ); + + NTMPB = DefConst( "NTMPB", INT, "Length of Temporary Array B" ); + BV = DefvElm( "B", real, -NTMPB, "Temporary array" ); + + NSTOICM = DefConst("NSTOICM", INT, "Length of Sparse Stoichiometric Matrix" ); + STOICM = DefvElm( "STOICM", real, -NSTOICM, "Stoichiometric Matrix in compressed column format" ); + IROW_STOICM = DefvElm( "IROW_STOICM", INT, -NSTOICM, "Row indices in STOICM" ); + ICOL_STOICM = DefvElm( "ICOL_STOICM", INT, -NSTOICM, "Column indices in STOICM" ); + CCOL_STOICM = DefvElm( "CCOL_STOICM", INT, -CNEQN, "Beginning of columns in STOICM" ); + + DDMTYPE = DefElm( "DDMTYPE", INT, "DDM sensitivity w.r.t.: 0=init.val., 1=params" ); + + NTMPD2A= DefConst( "NTMPD2A", INT, "Length of Temporary Array D2A" ); + D2A = DefvElm( "D2A", real, -NTMPD2A, "Second derivatives of equation rates" ); + NHESS = DefConst( "NHESS", INT, "Length of Sparse Hessian" ); + HESS = DefvElm( "HESS", real, -NHESS, "Hessian of Var (i.e. the 3-tensor d Jac / d Var)" ); + IHESS_I = DefvElm( "IHESS_I", INT, -NHESS, "Index i of Hessian element d^2 f_i/dv_j.dv_k" ); + IHESS_J = DefvElm( "IHESS_J", INT, -NHESS, "Index j of Hessian element d^2 f_i/dv_j.dv_k" ); + IHESS_K = DefvElm( "IHESS_K", INT, -NHESS, "Index k of Hessian element d^2 f_i/dv_j.dv_k" ); + U1 = DefvElm( "U1", real, -NVAR, "User vector" ); + U2 = DefvElm( "U2", real, -NVAR, "User vector" ); + HU = DefvElm( "HU", real, -NVAR, "Hessian times user vectors: (Hess x U2) * U1 = [d (Jac*U1)/d Var] * U2" ); + HTU = DefvElm( "HTU", real, -NVAR, "Transposed Hessian times user vectors: (Hess x U2)^T * U1 = [d (Jac^T*U1)/d Var] * U2 " ); + + KR = DefeElm( "KR", 0 ); + + IROW = DefvElm( "IROW", INT, -NONZERO, "Row indexes of the Jacobian of variables" ); + ICOL = DefvElm( "ICOL", INT, -NONZERO, "Column indexes of the Jacobian of variables" ); + CROW = DefvElm( "CROW", INT, -CNVAR, "Compressed row indexes of the Jacobian of variables" ); + DIAG = DefvElm( "DIAG", INT, -CNVAR, "Diagonal indexes of the Jacobian of variables" ); + LU_IROW = DefvElm( "LU_IROW", INT, -LU_NONZERO, "Row indexes of the LU Jacobian of variables" ); + LU_ICOL = DefvElm( "LU_ICOL", INT, -LU_NONZERO, "Column indexes of the LU Jacobian of variables" ); + LU_CROW = DefvElm( "LU_CROW", INT, -CNVAR, "Compressed row indexes of the LU Jacobian of variables" ); + LU_DIAG = DefvElm( "LU_DIAG", INT, -CNVAR, "Diagonal indexes of the LU Jacobian of variables" ); + + IV = DefeElm( "IV", 0 ); + + C_DEFAULT = DefvElm( "C_DEFAULT", real, -NSPEC, "Default concentration for all species" ); + C = DefvElm( "C", real, -NSPEC, "Concentration of all species" ); + CL = DefvElm( "CL", real, -NSPEC, "Concentration of all species (local)" ); + DC = DefvElm( "DC", real, -NSPEC, "Fluxes of all species" ); + ATOL = DefvElm( "ATOL", real, -NSPEC, "Absolute tolerance" ); + RTOL = DefvElm( "RTOL", real, -NSPEC, "Relative tolerance" ); + + STEPMIN = DefElm( "STEPMIN", real, "Lower bound for integration step"); + STEPMAX = DefElm( "STEPMAX", real, "Upper bound for integration step"); + + NLOOKAT = DefConst( "NLOOKAT", INT, "Number of species to look at" ); + LOOKAT = DefvElm( "LOOKAT", INT, -NLOOKAT, "Indexes of species to look at" ); + + NMONITOR = DefConst( "NMONITOR", INT, "Number of species to monitor" ); + MONITOR = DefvElm( "MONITOR", INT, -NMONITOR, "Indexes of species to monitor" ); + + NMASS = DefConst( "NMASS", INT, "Number of atoms to check mass balance" ); + SMASS = DefvElm( "SMASS", STRING, -NMASS, "Names of atoms for mass balance" ); + + EQN_TAGS = DefvElm( "EQN_TAGS", STRING, -NREACT, "Equation tags" ); + EQN_NAMES = DefvElm( "EQN_NAMES", DOUBLESTRING, -NREACT, "Equation names" ); + SPC_NAMES = DefvElm( "SPC_NAMES", STRING, -NSPEC, "Names of chemical species" ); + + CFACTOR = DefElm( "CFACTOR", real, "Conversion factor for concentration units"); + + /* Elements of Stochastic simulation*/ + NMLCV = DefvElm( "NmlcV", INT, -NVAR, "No. molecules of variable species" ); + NMLCF = DefvElm( "NmlcF", INT, -NFIX, "No. molecules of fixed species" ); + SCT = DefvElm( "SCT", real, -NREACT, "Stochastic rate constants" ); + PROPENSITY = DefvElm( "Prop", real, -NREACT, "Propensity vector" ); + VOLUME = DefElm( "Volume", real, "Volume of the reaction container" ); + IRCT = DefElm( "IRCT", INT, "Index of chemical reaction" ); + + for ( i=0; i value = max(SpcNr,1); + varTable[ NVAR ] -> value = max(VarNr,1); + varTable[ NVARACT ] -> value = max(VarActiveNr,1); + varTable[ NFIX ] -> value = max(FixNr,1); + varTable[ NREACT ] -> value = max(EqnNr,1); + varTable[ NVARST ] -> value = Index(0); + varTable[ NFIXST ] -> value = Index(VarNr); + } +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int NonZero( int stru, int start, int end, + int *row, int *col, int *crow, int *diag ) +{ +int nElm; +int i,j; + + nElm = 0; + for (i = 0; i < end-start; i++) { + crow[i] = Index(nElm); + for (j = 0; j < end-start; j++) { + if( (i == j) || ( (stru) ? LUstructJ[i+start][j+start] + : structJ[i+start][j+start] ) ) { + row[nElm] = Index(i); + col[nElm] = Index(j); + nElm++; + } + if( i == j ) { + diag[i] = Index(nElm-1); + } + } + } + crow[i] = Index(nElm); + diag[i] = Index(nElm); + return nElm; +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *EQN_NAMES[MAX_EQN]; +char *EQN_TAGS[MAX_EQN]; +char *bufeqn, *p; +int dim; + + if ( (useLang != C_LANG)&&(useLang != MATLAB_LANG) ) return; + + UseFile( driverFile ); + + NewLines(1); + + GlobalDeclare( C ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[VAR]->name, varTable[C]->name, 0 ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[FIX]->name, varTable[C]->name, VarNr ); + + + GlobalDeclare( RCONST ); + GlobalDeclare( TIME ); + GlobalDeclare( SUN ); + GlobalDeclare( TEMP ); + GlobalDeclare( RTOLS ); + GlobalDeclare( TSTART ); + GlobalDeclare( TEND ); + GlobalDeclare( DT ); + GlobalDeclare( ATOL ); + GlobalDeclare( RTOL ); + GlobalDeclare( STEPMIN ); + GlobalDeclare( STEPMAX ); + GlobalDeclare( CFACTOR ); + if (useStochastic) + GlobalDeclare( VOLUME ); + + MATLAB_Inline(" %s_Parameters;",rootFileName); + MATLAB_Inline(" %s_Global_defs;",rootFileName); + MATLAB_Inline(" %s_Sparse;",rootFileName); + MATLAB_Inline(" %s_Monitor;",rootFileName); + if (useJacSparse ) + MATLAB_Inline(" %s_JacobianSP;",rootFileName); + if (useHessian ) + MATLAB_Inline(" %s_HessianSP;",rootFileName); + if (useStoicmat ) + MATLAB_Inline(" %s_StoichiomSP;",rootFileName); + + NewLines(1); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMonitorData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *seqn[MAX_EQN]; +char *bufeqn, *p; +int dim; + + + /* Allocate local data structures */ + dim = SpcNr+2; + crow = AllocIntegerVector( dim, "crow in GenerateMonitorData"); + diag = AllocIntegerVector( dim, "diag in GenerateMonitorData"); + lookat = AllocIntegerVector( dim, "lookat in GenerateMonitorData"); + moni = AllocIntegerVector( dim, "moni in GenerateMonitorData"); + trans = AllocIntegerVector( dim, "trans in GenerateMonitorData"); + + UseFile( monitorFile ); + + F77_Inline("%6sBLOCK DATA MONITOR_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Parameters.h'", " ",rootFileName); + F77_Inline("%6sINCLUDE '%s_Global.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i", " " ); + + /* InitDeclare( CFACTOR, 0, (void*)&cfactor ); */ + + NewLines(1); + + for (i = 0; i < SpcNr; i++) { + snames[i] = SpeciesTable[Code[i]].name; + } + InitDeclare( SPC_NAMES, SpcNr, (void*)snames ); + + nlookat = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].lookat ) { + lookat[nlookat] = Index(i); + nlookat++; + } + + if (ValueDimension) + varTable[ NLOOKAT ] -> value = max(nlookat,1); + InitDeclare( LOOKAT, nlookat, (void*)lookat ); + + nmoni = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].moni ) { + moni[nmoni] = Index(i); + nmoni++; + } + + if( nmoni > MAX_MONITOR ) { + Warning( "%d species to monitorize. Too many, keeping %d.", + nmoni, MAX_MONITOR ); + nmoni = MAX_MONITOR; + } + + if (ValueDimension) + varTable[ NMONITOR ] -> value = max(nmoni,1); + InitDeclare( MONITOR, nmoni, (void*)moni ); + + ntrans = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].trans ) { + trans[ntrans] = Index(i); + strans[ntrans] = SpeciesTable[Code[i]].name; + ntrans++; + } + + nmass = 0; + for (i = 0; i < AtomNr; i++) + if ( AtomTable[i].masscheck ) { + smass[nmass] = AtomTable[i].name; + nmass++; + } + if (ValueDimension) + varTable[ NMASS ] -> value = max(nmass,1); + InitDeclare( SMASS, nmass, (void*)smass ); + + if ( (bufeqn = (char*)malloc(MAX_EQNLEN*EqnNr+2))==NULL ) { + FatalError(-30,"GenerateMonitorData: Cannot allocate bufeqn (%d chars)", + MAX_EQNLEN*EqnNr); + } + + p = bufeqn; + for (i = 0; i < EqnNr; i++) { + EqnString(i, p); + seqn[i] = p; + p += MAX_EQNLEN; + } + InitDeclare( EQN_NAMES, EqnNr, (void*)seqn ); + + free( bufeqn ); + + if (useEqntags==1) { + for (i = 0; i < EqnNr; i++) { + seqn[i] = kr[i].label; + } + InitDeclare( EQN_TAGS, EqnNr, (void*)seqn ); + } + + NewLines(1); + WriteComment("INLINED global variables"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_DATA ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_DATA ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_DATA ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_DATA ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED global variables"); + NewLines(1); + + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local data structures */ + free(crow); free(diag); free(lookat); free(moni); free(trans); + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseData() +{ +int* irow; +int* icol; +int* crow; +int* diag; +int nElm; +int dim; + + if( !useJacSparse ) return; + + /* Allocate local arrays */ + dim=MAX_SPECIES; + irow = AllocIntegerVector( dim*dim, "irow in GenerateJacobianSparseData" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateJacobianSparseData" ); + crow = AllocIntegerVector( dim, "crow in GenerateJacobianSparseData" ); + diag = AllocIntegerVector( dim, "diag in GenerateJacobianSparseData" ); + + UseFile( sparse_jacFile ); + + NewLines(1); + WriteComment("Sparse Jacobian Data"); + NewLines(1); + + F77_Inline("%6sBLOCK DATA JACOBIAN_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i"," "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + + + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + if (ValueDimension) { + varTable[NONZERO] -> value = Jac_NZ; + varTable[LU_NONZERO] -> value = LU_Jac_NZ; + } + + switch (useJacobian) { + case JAC_ROW: + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( IROW, Jac_NZ, (void*)irow ); + InitDeclare( ICOL, Jac_NZ, (void*)icol ); + InitDeclare( CROW, VarNr+1, (void*)crow ); + InitDeclare( DIAG, VarNr+1, (void*)diag ); + break; + case JAC_LU_ROW: + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( LU_IROW, LU_Jac_NZ, (void*)irow ); + InitDeclare( LU_ICOL, LU_Jac_NZ, (void*)icol ); + InitDeclare( LU_CROW, VarNr+1, (void*)crow ); + InitDeclare( LU_DIAG, VarNr+1, (void*)diag ); + } + NewLines(1); + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local arrays */ + free(irow); free(icol); free(crow); free(diag); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseHeader() +{ + UseFile( sparse_dataFile ); + + CommonName = "SDATA"; + + NewLines(1); + WriteComment(" ----------> Sparse Jacobian Data"); + NewLines(1); + + switch (useJacobian) { + case JAC_ROW: + ExternDeclare( IROW ); + ExternDeclare( ICOL ); + ExternDeclare( CROW ); + ExternDeclare( DIAG ); + break; + case JAC_LU_ROW: + ExternDeclare( LU_IROW ); + ExternDeclare( LU_ICOL ); + ExternDeclare( LU_CROW ); + ExternDeclare( LU_DIAG ); + } + + NewLines(1); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateFun() +{ +int i, j, k; +int used; +int l, m; +int F_VAR, FSPLIT_VAR; + + if( VarNr == 0 ) return; + + if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ + UseFile( functionFile ); + + F_VAR = DefFnc( "Fun", 4, "time derivatives of variables - Agregate form"); + FSPLIT_VAR = DefFnc( "Fun_SPLIT", 5, "time derivatives of variables - Split form"); + + if( useAggregate ) + FunctionBegin( F_VAR, V, F, RCT, Vdot ); + else + FunctionBegin( FSPLIT_VAR, V, F, RCT, P_VAR, D_VAR ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + + if ( useLang!=F90_LANG ) { /* A is a module variable in F90 */ + NewLines(1); + WriteComment("Local variables"); + Declare( A ); + } + NewLines(1); + WriteComment("Computation of equation rates"); + + for(j=0; j 1. PROPENSITY FUNCTION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "Propensity", 4, "Propensity function"); + FunctionBegin( F_VAR, NMLCV, NMLCF, SCT, PROPENSITY ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + NewLines(1); + + for(j=0; j 2. RATE CONVERSION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "StochasticRates", 3, "Convert deterministic rates to stochastic"); + FunctionBegin( F_VAR, RCT, VOLUME, SCT ); + WriteComment("No. of molecules = Concentration x Volume"); + WriteComment("For a reaction with k reactants:"); + WriteComment(" RCT [ (molec/Volume)^(1-k) * sec^(-1) ]"); + WriteComment(" SCT [ (molec)^(1-k) * sec^(-1) ] = RCT*Volume^(k-1)"); + WriteComment("For p molecules of the same type: SCT = SCT/(p!)"); + + NewLines(1); + + for(j=0; j 3. THE CHANGE IN NUMBER OF MOLECULES */ + if (useLang == MATLAB_LANG) { + F_VAR = DefFnc( "MoleculeChange", 3, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV, NMLCV ); + } else { + F_VAR = DefFnc( "MoleculeChange", 2, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV ); + } + + NewLines(1); + + F90_Inline("\n SELECT CASE (IRCT)\n"); + C_Inline ("\n switch (IRCT) { \n"); + MATLAB_Inline("\n switch (IRCT) \n"); + for(j=0; j value = JVRP_NZ + 1; + + FunctionEnd( F_STOIC ); + FreeVariable( F_STOIC ); + + + UseFile( sparse_stoicmFile ); + NewLines(1); + WriteComment("Row-compressed sparse data for the Jacobian of reaction products JVRP"); + F77_Inline("%6sBLOCK DATA JVRP_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ", rootFileName); + F77_Inline("%6sINTEGER i", " "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + if( (useLang==F77_LANG)||(useLang==F90_LANG) ) { + for (k=0; k value = nonzeros_B; + Declare( BV ); + } + + NewLines(1); + + for ( i=0; i=2) + nElm++; + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) + nElm++; + } + +/* Allocate temporary index arrays */ + coeff_j = AllocIntegerVector(nElm, "coeff_j in GenerateHess"); + coeff_i1 = AllocIntegerVector(nElm, "coeff_i1 in GenerateHess"); + coeff_i2 = AllocIntegerVector(nElm, "coeff_i2 in GenerateHess"); + +/* Fill in temporary index arrays */ + nElm = 0; + for(j=0; j=2) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } +/* Number of nonzero terms of the form d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + Djv_isElm = 1; + } + if (Djv_isElm == 1) Hess_NZ++ ; + } /* for i, i1, i2 */ + if (ValueDimension) + varTable[ NHESS ] -> value = max( Hess_NZ, 1 ); + +/* Allocate temporary index arrays */ + iHess_i = AllocIntegerVector(Hess_NZ, "iHess_i in GenerateHess"); + iHess_j = AllocIntegerVector(Hess_NZ, "iHess_j in GenerateHess"); + iHess_k = AllocIntegerVector(Hess_NZ, "iHess_k in GenerateHess"); + + F_Hess = DefFnc( "Hessian", 4, "function for Hessian (Jac derivative w.r.t. variables)"); + FunctionBegin( F_Hess, V, F, RCT, HESS ); + + WriteComment("--------------------------------------------------------"); + WriteComment("Note: HESS is represented in coordinate sparse format: "); + WriteComment(" HESS(m) = d^2 f_i / dv_j dv_k = d Jac_{i,j} / dv_k"); + WriteComment(" where i = IHESS_I(m), j = IHESS_J(m), k = IHESS_K(m)."); + WriteComment("--------------------------------------------------------"); + WriteComment("Note: d^2 f_i / dv_j dv_k = d^2 f_i / dv_k dv_j, "); + WriteComment(" therefore only the terms d^2 f_i / dv_j dv_k"); + WriteComment(" with j <= k are computed and stored in HESS."); + WriteComment("--------------------------------------------------------"); + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) { + NewLines(1); + WriteComment("Local variables"); + /* DeclareConstant( NTMPD2A, ascii( max( nElm, 1 ) ) ); */ + varTable[ NTMPD2A ] -> value = max( nElm, 1 ); + Declare( D2A ); + } + + NewLines(1); + WriteComment("Computation of the second derivatives of equation rates"); + +/* Generate d^2 A(j)/ ( d v(i1) d v(i2) )*/ + nElm = 0; + for(j=0; j=2) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j]-1 ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-2; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d)/{dV(%d)dV(%d)}",Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if (Stoich_Left[i1][j]>=2) */ + + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-1; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < i2; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i2][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i2][j]-1; k++ ) + prod = Mul( prod, Elm( V, i2 ) ); + for (i = i2+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d) / dV(%d)dV(%d)", + Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) */ + } /* if i1==i2 */ + + } /* for j, i1, i2 */ + + NewLines(1); + WriteComment("Computation of the Jacobian derivative"); + +/* Generate d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + sum = Const(0); + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + sum = Add( sum, + Mul( Const( Stoich[i][j] ), Elm( D2A, k ) ) ); + Djv_isElm = 1; + } + if (Djv_isElm == 1) { + WriteComment("HESS(%d) = d^2 Vdot(%d)/{dV(%d)dV(%d)} = d^2 Vdot(%d)/{dV(%d)dV(%d)}", + Index(Hess_NZ),Index(i),Index(i1),Index(i2),Index(i),Index(i2),Index(i1)); + Assign( Elm( HESS, Hess_NZ ), sum ); + iHess_i[ Hess_NZ ] = i; + iHess_j[ Hess_NZ ] = i1; + iHess_k[ Hess_NZ ] = i2; + Hess_NZ++; + } + + } /* for i, i1, i2 */ + + +/* free temporary index arrays */ + free(coeff_j); free(coeff_i1); free(coeff_i2); + + MATLAB_Inline("\n HESS = HESS(:);"); + + FunctionEnd( F_Hess ); + + FreeVariable( F_Hess ); + + + F_HessTR_VEC = DefFnc( "HessTR_Vec", 4, "Hessian transposed times user vectors"); + FunctionBegin( F_HessTR_VEC, HESS, U1, U2, HTU ); + WriteComment("Compute the vector HTU =(Hess x U2)^T * U1 = d (Jac^T*U1)/d Var * U2 "); + + for (i=0; i Sparse Hessian Data"); + NewLines(1); + + ExternDeclare( IHESS_I ); + ExternDeclare( IHESS_J ); + ExternDeclare( IHESS_K ); + + NewLines(1); +} + + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateStoicmSparseData() +{ +int i,j,k, nnz_stoicm; +/* +int irow_stoicm[MAX_SPECIES*MAX_EQN]; +int ccol_stoicm[MAX_EQN+2]; +int icol_stoicm[MAX_SPECIES*MAX_EQN]; +double stoicm[MAX_SPECIES*MAX_EQN]; +*/ + +int *irow_stoicm; +int *ccol_stoicm; +int *icol_stoicm; +double *stoicm; + +/* Compute the sparsity structure and allocate data structure vectors */ + nnz_stoicm = 0; + for (j=0; j Sparse Stoichiometric Matrix"); + NewLines(1); + CommonName = "STOICM_VALUES"; + ExternDeclare( STOICM ); + CommonName = "STOICM_DATA"; + ExternDeclare( IROW_STOICM ); + ExternDeclare( CCOL_STOICM ); + ExternDeclare( ICOL_STOICM ); + NewLines(1); + + NewLines(1); + WriteComment(" ----------> Sparse Data for Jacobian of Reactant Products"); + NewLines(1); + CommonName = "JVRP"; + ExternDeclare( ICOL_JVRP ); + ExternDeclare( IROW_JVRP ); + ExternDeclare( CROW_JVRP ); + NewLines(1); + +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacVect() +{ +int i, j, nElm; +int Jac_VEC; +int Jac_SP_VEC; + + if( useLang == MATLAB_LANG ) return; + + if( VarNr == 0 ) return; + + UseFile( jacobianFile ); + Jac_VEC = DefFnc( "Jac_Vec", 3, + "function for sparse multiplication: square Jacobian times vector"); + Jac_SP_VEC = DefFnc( "Jac_SP_Vec", 3, + "function for sparse multiplication: sparse Jacobian times vector"); + + if ( useJacSparse ) { + FunctionBegin( Jac_SP_VEC, JVS, UV, JUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JVS, nElm ), Elm( UV, j ) ) ); + nElm++; + } + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_SP_VEC ); + } + + else { + FunctionBegin( Jac_VEC, JV, UV, JUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JV, i, j ), Elm( UV, j ) ) ); + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_VEC ); + } + + FreeVariable( Jac_VEC ); + FreeVariable( Jac_SP_VEC ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacTRVect() +{ +int i, j, nElm; +int JacTR_VEC; +int JacTR_SP_VEC; +int **TmpStruct; + + if( useLang == MATLAB_LANG ) return; + + if ( VarNr == 0 ) return; + + UseFile( jacobianFile ); + + JacTR_VEC = DefFnc( "JacTR_Vec", 3, + "sparse multiplication: square Jacobian transposed times vector"); + JacTR_SP_VEC = DefFnc( "JacTR_SP_Vec", 3, + "sparse multiplication: sparse Jacobian transposed times vector"); + + if ( useJacSparse ) { + + /* The temporary array of structure */ + TmpStruct = AllocIntegerMatrix( VarNr, VarNr, "TmpStruct in GenerateJacTRVect" ); + + nElm = 0; + for( i = 0; i < VarNr; i++) + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + TmpStruct[i][j] = nElm; + nElm++; + } + + FunctionBegin( JacTR_SP_VEC, JVS, UV, JTUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JVS, TmpStruct[j][i] ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_SP_VEC ); + + /* Free the temporary array of structure */ + FreeIntegerMatrix( TmpStruct, VarNr, VarNr ); + + } /* useJacSparse*/ + + else { + FunctionBegin( JacTR_VEC, JV, UV, JTUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JV, j, i ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_VEC ); + } + + FreeVariable( JacTR_VEC ); + FreeVariable( JacTR_SP_VEC ); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSparseUtil() +{ +int SUTIL; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + SUTIL = DefFnc( "SPARSE_UTIL", 0, "SPARSE utility functions"); + CommentFunctionBegin( SUTIL ); + + IncludeCode( "%s/util/sutil", Home ); + + CommentFunctionEnd( SUTIL ); + FreeVariable( SUTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateBlas() +{ +int BLAS; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + BLAS = DefFnc( "BLAS_UTIL", 0, "BLAS-LIKE utility functions"); + CommentFunctionBegin( BLAS ); + + IncludeCode( "%s/util/blas", Home ); + + CommentFunctionEnd( BLAS ); + FreeVariable( BLAS ); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDFunDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dFun_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDJacDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dJac_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSolve() +{ +int i, j; +int SOLVE; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateSolve" ); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVE = DefFnc( "KppSolve", 2, "sparse back substitution"); + FunctionBegin( SOLVE, JVS, X ); + + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + sum = Elm( X, i ); + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + Assign( Elm( X, i ), sum ); + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + sum = Elm( X, i ); + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + sum = Div( sum, Elm( JVS, diag[i] ) ); + Assign( Elm( X, i ), sum ); + } + + FunctionEnd( SOLVE ); + FreeVariable( SOLVE ); + + /* Free Local Arrays */ + free(irow); + free(icol); + free(crow); + free(diag); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateTRSolve() +{ +int i, j; +int SOLVETR; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int **pos; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateTRSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateTRSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateTRSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateTRSolve" ); + pos = AllocIntegerMatrix( dim+1, dim+1, "pos in GenerateTRSolve"); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVETR = DefFnc( "KppSolveTR", 3, "sparse, transposed back substitution"); + FunctionBegin( SOLVETR, JVS, X, XX ); + for( i = 0; i < VarNr; i++) { + for( j = 0; j < VarNr; j++) + pos[i][j]=-1; + } + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + pos[i][i]=diag[i]; + } + + for( i = 0; i= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + sum=Div( sum, Elm(JVS, diag[i] ) ); + Assign( Elm( XX, i ), sum ); + } + for( i = VarNr-1; i >=0; i--) { + sum = Elm( XX, i ); + for (j=i+1; j= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + Assign( Elm( XX, i ), sum ); + } + + FunctionEnd( SOLVETR ); + FreeVariable( SOLVETR ); + /* Free Local Arrays */ + free(irow); free(icol); free(crow); free(diag); + FreeIntegerMatrix(pos, dim+1, dim+1); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateRateLaws() +{ + + UseFile( rateFile ); + + NewLines(1); + WriteComment("Begin Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + IncludeCode( "%s/util/UserRateLaws", Home ); + NewLines(1); + WriteComment("End Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED Rate Law Functions"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RATES ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RATES ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RATES ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RATES ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Rate Law Functions"); + NewLines(1); + + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateSun() +{ +int UPDATE_SUN; + + UseFile( rateFile ); + + UPDATE_SUN = DefFnc( "Update_SUN", 0, "update SUN light using TIME"); + CommentFunctionBegin( UPDATE_SUN ); + + IncludeCode( "%s/util/UpdateSun", Home ); + + CommentFunctionEnd( UPDATE_SUN ); + FreeVariable( UPDATE_SUN ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateRconst() +{ +int i; +int UPDATE_RCONST; + + UseFile( rateFile ); + + UPDATE_RCONST = DefFnc( "Update_RCONST", 0, "function to update rate constants"); + + FunctionBegin( UPDATE_RCONST ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + if ( (useLang==F77_LANG) ) + IncludeCode( "%s/util/UserRateLaws_FcnHeader", Home ); + + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED RCONST"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RCONST ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RCONST ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RCONST ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RCONST ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED RCONST"); + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == EXPRESION ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + /* mz_rs_20050117+ */ + if ( kr[i].type == NUMBER ) { + F90_Inline("! RCONST(%d) = constant rate coefficient", i+1); + /* WriteComment("Constant rate coefficient (value inlined in the code):"); */ + /* Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); */ + } + /* mz_rs_20050117- */ + } + + MATLAB_Inline(" RCONST = RCONST(:);"); + + FunctionEnd( UPDATE_RCONST ); + FreeVariable( UPDATE_RCONST ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdatePhoto() +{ +int i; +int UPDATE_PHOTO; + + UseFile( rateFile ); + + UPDATE_PHOTO = DefFnc( "Update_PHOTO", 0, "function to update photolytical rate constants"); + + FunctionBegin( UPDATE_PHOTO ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + } + + FunctionEnd( UPDATE_PHOTO ); + FreeVariable( UPDATE_PHOTO ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateIntegrator() +{ +int TIN, TOUT, INTEGRATE; + + UseFile( integratorFile ); + + TIN = DefElm( "TIN", real, "Start Time for Integration"); + TOUT = DefElm( "TOUT", real, "End Time for Integration"); + INTEGRATE = DefFnc( "INTEGRATE", 2, "Integrator routine"); + CommentFunctionBegin( INTEGRATE, TIN, TOUT ); + + if( strchr( integrator, '/' ) ) + IncludeCode( integrator ); + else + IncludeCode( "%s/int/%s", Home, integrator ); + + CommentFunctionEnd( INTEGRATE ); + FreeVariable( INTEGRATE ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDriver() +{ +int MAIN; + + UseFile( driverFile ); + + MAIN = DefFnc( "MAIN", 0, "Main program - driver routine"); + CommentFunctionBegin( MAIN ); + + if( strchr( driver, '/' ) ) + IncludeCode( driver ); + else + IncludeCode( "%s/drv/%s", Home, driver ); + + CommentFunctionEnd( MAIN ); + FreeVariable( MAIN ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUtil() +{ +int UTIL; + +/* if (useLang == MATLAB_LANG) return; */ + + UseFile( utilFile ); + NewLines(1); + WriteComment("User INLINED Utility Functions"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_UTIL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_UTIL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_UTIL ].code ); + break; + case MATLAB_LANG:bprintf( InlineCode[ MATLAB_UTIL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Utility Functions"); + NewLines(1); + + WriteComment("Utility Functions from KPP_HOME/util/util"); + UTIL = DefFnc( "UTIL", 0, "Utility functions"); + CommentFunctionBegin( UTIL); + + IncludeCode( "%s/util/util", Home ); + + if ((useLang == F90_LANG) && (useEqntags==1)) { + IncludeCode( "%s/util/tag2num", Home ); + } + + WriteComment("End Utility Functions from KPP_HOME/util/util"); + CommentFunctionEnd( UTIL ); + FreeVariable( UTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateParamHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + +int j,dummy_species; + +/* ----------> First declaration of constants */ + UseFile( param_headerFile ); + + NewLines(1); + DeclareConstant( NSPEC, ascii( max(SpcNr, 1) ) ); + DeclareConstant( NVAR, ascii( max(VarNr, 1) ) ); + DeclareConstant( NVARACT, ascii( max(VarActiveNr, 1) ) ); + DeclareConstant( NFIX, ascii( max(FixNr, 1) ) ); + DeclareConstant( NREACT, ascii( max(EqnNr, 1) ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + DeclareConstant( NONZERO, ascii( max(Jac_NZ, 1) ) ); + DeclareConstant( LU_NONZERO, ascii( max(LU_Jac_NZ, 1) ) ); + DeclareConstant( CNVAR, ascii( VarNr+1 ) ); + if ( useStoicmat ) { + DeclareConstant( CNEQN, ascii( EqnNr+1 ) ); + } + if ( useHessian ) { + DeclareConstant( NHESS, ascii( max(Hess_NZ, 1) ) ); + } + + DeclareConstant( NLOOKAT, ascii( nlookat ) ); + DeclareConstant( NMONITOR, ascii( nmoni ) ); + DeclareConstant( NMASS, ascii( nmass ) ); + + DeclareConstant( PI, "3.14159265358979" ); + + NewLines(1); + WriteComment("Index declaration for variable species in C and VAR"); + WriteComment(" VAR(ind_spc) = C(ind_spc)"); + NewLines(1); + for( i = 0; i < VarNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } + + NewLines(1); + WriteComment("Index declaration for fixed species in C"); + WriteComment(" C(ind_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i+VarNr) ) ); + FreeVariable( spc ); + } + + if (useDummyindex==1) { + NewLines(1); + WriteComment("Index declaration for dummy species"); + NewLines(1); + for( i = 0; i < MAX_SPECIES; i++) { + if (SpeciesTable[i].type == 0) continue; + dummy_species = 1; + for( j = 0; j < MAX_SPECIES; j++) + if (Code[j] == i) dummy_species = 0; + if (dummy_species) { + sprintf( name, "ind_%s", SpeciesTable[i].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( 0 ) ); + FreeVariable( spc ); + } + } + } + + NewLines(1); + WriteComment("Index declaration for fixed species in FIX"); + WriteComment(" FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "indf_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGlobalHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + + UseFile( global_dataFile ); + + CommonName = "GDATA"; + + NewLines(1); + WriteComment("Declaration of global variables"); + NewLines(1); + + /* ExternDeclare( C_DEFAULT ); */ + + ExternDeclare( C ); + + if( useLang == F77_LANG ) { + + Declare( VAR ); + Declare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == F90_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == MATLAB_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + } + + C_Inline(" extern %s * %s;", C_types[real], varTable[VAR]->name ); + C_Inline(" extern %s * %s;", C_types[real], varTable[FIX]->name ); + + + ExternDeclare( RCONST ); + ExternDeclare( TIME ); + ExternDeclare( SUN ); + ExternDeclare( TEMP ); + ExternDeclare( RTOLS ); + ExternDeclare( TSTART ); + ExternDeclare( TEND ); + ExternDeclare( DT ); + ExternDeclare( ATOL ); + ExternDeclare( RTOL ); + ExternDeclare( STEPMIN ); + ExternDeclare( STEPMAX ); + ExternDeclare( CFACTOR ); + if (useStochastic) + ExternDeclare( VOLUME ); + + CommonName = "INTGDATA"; + if ( useHessian ) { + ExternDeclare( DDMTYPE ); + } + + + if ( (useLang == C_LANG) || (useLang == F77_LANG) ) { + CommonName = "INTGDATA"; + ExternDeclare( LOOKAT ); + ExternDeclare( MONITOR ); + CommonName = "CHARGDATA"; + ExternDeclare( SPC_NAMES ); + ExternDeclare( SMASS ); + ExternDeclare( EQN_NAMES ); + ExternDeclare( EQN_TAGS ); + } + + NewLines(1); + WriteComment("INLINED global variable declarations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_GLOBAL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_GLOBAL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_GLOBAL ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_GLOBAL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("INLINED global variable declarations"); + NewLines(1); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void WriteSpec( int i, int j ) +{ +char buf[100]; + + if( Reactive[j] ) + sprintf( buf, "%s (r)", SpeciesTable[ Code[j] ].name ); + else + sprintf( buf, "%s (n)", SpeciesTable[ Code[j] ].name ); + WriteAll("%3d = %-10s", 1 + i, buf ); + FlushBuf(); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnStr( int eq, char * buf, float** mat ) +{ +int spc, first; + +/* bugfix if stoichiometric factor is not an integer */ +int n; +char s[40]; + + first = 1; + *buf = 0; + for( spc = 0; spc < SpcNr; spc++ ) + if( mat[spc][eq] != 0 ) { + if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { + sprintf(s, ""); + } else { + /* real */ + /* mz_rs_20050130+ */ + /* sprintf(s, "%g", mat[spc][eq]); */ + /* remove the minus sign with fabs(), it will be re-inserted later */ + sprintf(s, "%g", fabs(mat[spc][eq])); + /* mz_rs_20050130- */ + /* remove trailing zeroes */ + for (n= strlen(s) - 1; n >= 0; n--) + if (s[n] != '0') break; + s[n + 1]= '\0'; + sprintf(s, "%s ", s); + } + + if( first ) { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); + else sprintf(buf, "%s- %s", buf, s); + first = 0; + } else { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); + else sprintf(buf, "%s - %s", buf, s); + } + sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); + if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ + sprintf(buf, "%s ... etc.",buf); + break; + } + } + + return strlen(buf); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnString( int eq, char * buf ) +{ +static int lhs = 0; +static int rhs = 0; + +int i, l; +char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; + + if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, lhsbuf, Stoich_Left); + lhs = (lhs > l) ? lhs : l; + } + + if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, rhsbuf, Stoich_Right); + rhs = (rhs > l) ? lhs : l; + } + + + EqnStr( eq, lhsbuf, Stoich_Left); + EqnStr( eq, rhsbuf, Stoich_Right); + + sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); + return strlen(buf); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMap() +{ +int i; +int dn; + + UseFile( mapFile ); + + WriteAll("### Options -------------------------------------------\n"); + NewLines(1); + if( useAggregate ) WriteAll("FUNCTION - AGGREGATE\n"); + else WriteAll("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: WriteAll("JACOBIAN - OFF\n"); break; + case JAC_FULL: WriteAll("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: WriteAll("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: WriteAll("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) WriteAll("DOUBLE - ON\n"); + else WriteAll("DOUBLE - OFF\n"); + if( useReorder ) WriteAll("REORDER - ON\n"); + else WriteAll("REORDER - OFF\n"); + NewLines(1); + + WriteAll("### Parameters ----------------------------------------\n"); + NewLines(1); + + VarStartNr = Index(0); + FixStartNr = Index(VarNr); + + DeclareConstant( NSPEC, ascii( SpcNr ) ); + DeclareConstant( NVAR, ascii( max( VarNr, 1 ) ) ); + DeclareConstant( NVARACT, ascii( max( VarActiveNr, 1 ) ) ); + DeclareConstant( NFIX, ascii( max( FixNr, 1 ) ) ); + DeclareConstant( NREACT, ascii( EqnNr ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + + NewLines(1); + WriteAll("### Species -------------------------------------------\n"); + + NewLines(1); + WriteAll("Variable species\n"); + + dn = VarNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i -= 2*dn; WriteAll("\n"); + } + + + NewLines(1); + WriteAll("Fixed species\n"); + + dn = FixNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i -= 2*dn; WriteAll("\n"); + } + + NewLines(1); + WriteAll("### Subroutines ---------------------------------------\n"); + NewLines(1); + FlushBuf(); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateInitialize() +{ +int i; +int I, X; +int INITVAL; + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) + UseFile( initFile ); + + INITVAL = DefFnc( "Initialize", 0, "function to initialize concentrations"); + FunctionBegin( INITVAL ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global\n", rootFileName); + MATLAB_Inline("global CFACTOR VAR FIX NVAR NFIX", rootFileName); + + I = DefElm( "i", INT, 0); + X = DefElm( "x", real, 0); + Declare( I ); + Declare( X ); + + NewLines(1); + WriteAssign( varTable[CFACTOR]->name , ascid( (double)cfactor ) ); + NewLines(1); + + Assign( Elm( X ), Mul( Elm( IV, varDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NVAR; i++ )" ); + F77_Inline(" DO i = 1, NVAR" ); + F90_Inline(" DO i = 1, NVAR" ); + MATLAB_Inline(" for i = 1:NVAR" ); + ident++; + Assign( Elm( VAR, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + Assign( Elm( X ), Mul( Elm( IV, fixDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NFIX; i++ )" ); + F77_Inline(" DO i = 1, NFIX" ); + F90_Inline(" DO i = 1, NFIX" ); + MATLAB_Inline(" for i = 1:NFIX" ); + ident++; + Assign( Elm( FIX, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + + for( i = 0; i < VarNr; i++) { + if( *SpeciesTable[ Code[i] ].ival == 0 ) continue; + Assign( Elm( VAR, i ), Mul( + Elm( IV, SpeciesTable[ Code[i] ].ival ), + Elm( CFACTOR ) ) ); + } + + + for( i = 0; i < FixNr; i++) { + if( *SpeciesTable[ Code[i + VarNr] ].ival == 0 ) continue; + Assign( Elm( FIX, i ), Mul( + Elm( IV, SpeciesTable[ Code[i + VarNr] ].ival ), + Elm( CFACTOR ) ) ); + } + +/* NewLines(1); + C_Inline(" for( i = 0; i < NSPEC; i++ )" ); + F77_Inline(" do i = 1, NSPEC" ); + ident++; + Assign( Elm( C_DEFAULT, -I ), Elm( C, -I ) ); + ident--; + F77_Inline(" end do" ); +*/ + + /* mz_rs_20050117+ */ + WriteComment("constant rate coefficients"); + for( i = 0; i < EqnNr; i++) { + if ( kr[i].type == NUMBER ) + Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); + } + WriteComment("END constant rate coefficients"); + /* mz_rs_20050117- */ + + NewLines(1); + WriteComment("INLINED initializations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_INIT ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_INIT ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_INIT ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_INIT ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED initializations"); + NewLines(1); + + MATLAB_Inline(" VAR = VAR(:);\n FIX = FIX(:);\n" ); + + FreeVariable( X ); + FreeVariable( I ); + FunctionEnd( INITVAL ); + FreeVariable( INITVAL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_user2kpp() +{ +int i,k,l; +int Shuffle_user2kpp; + + UseFile( utilFile ); + + Shuffle_user2kpp = DefFnc( "Shuffle_user2kpp", 2, "function to copy concentrations from USER to KPP"); + FunctionBegin( Shuffle_user2kpp, V_USER, V ); + + k = 0;l = 0; + for( i = 1; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) { + Assign( Elm( V, ReverseCode[i] ), Elm( V_USER, k++ ) ); + break; + } + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_user2kpp ); + FreeVariable( Shuffle_user2kpp ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_kpp2user() +{ +int i,k,l; +int Shuffle_kpp2user; + + UseFile( utilFile ); + + Shuffle_kpp2user = DefFnc( "Shuffle_kpp2user", 2, "function to restore concentrations from KPP to USER"); + FunctionBegin( Shuffle_kpp2user, V, V_USER ); + + k = 0; l = 0; + for( i = 0; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) + Assign( Elm( V_USER, k++ ), Elm( V, ReverseCode[i] ) ); + break; + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_kpp2user ); + FreeVariable( Shuffle_kpp2user ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGetMass() +{ +int i; +int atm, spc; +int GETMASS, MASS; +SPECIES_DEF *sp; +int numass; + + UseFile( utilFile ); + + nmass = 0; + for( atm = 0; atm < AtomNr; atm++ ) + if( AtomTable[atm].masscheck ) nmass++; + if( nmass == 0 ) nmass = 1; + + MASS = DefvElm( "Mass", real, nmass, "value of mass balance" ); + GETMASS = DefFnc( "GetMass", 2, "compute total mass of selected atoms"); + FunctionBegin( GETMASS, CL, MASS); + + numass = 0; + for( atm = 0; atm < AtomNr; atm++ ) { + if( AtomTable[atm].masscheck ) { + sum = Const( 0 ); + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + for( i = 0; i < sp->nratoms; i++ ) { + if( sp->atoms[i].code == atm ) { + sum = Add( sum, Mul( Const( sp->atoms[i].nr ), + Elm( CL, spc ) ) ); + } + } + } + Assign( Elm( MASS, numass ), sum ); + numass++; + } + } + + FunctionEnd( GETMASS ); + FreeVariable( GETMASS ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMakefile() +{ +char buf[100]; + + if ( useLang == MATLAB_LANG ) return; + + sprintf( buf, "Makefile_%s", rootFileName ); + makeFile = fopen(buf, "w"); + if( makeFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + + UseFile( makeFile ); + + IncludeCode( "%s/util/Makefile", Home ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMex() +{ +char buf[100], suffix[5]; + + if (useLang == MATLAB_LANG) return; + if (useMex == 0) return; + + switch( useLang ) { + case F77_LANG: sprintf( suffix, "f"); + break; + case F90_LANG: sprintf( suffix, "f90"); + break; + case C_LANG: sprintf( suffix, "c"); + break; + default: printf("\nCannot create mex files for language %d\n", useLang); + exit(1); + break; + } + + sprintf( buf, "%s_mex_Fun.%s", rootFileName, suffix ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Mex_Fun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_mex_Jac_SP.%s", rootFileName, suffix ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Mex_Jac_SP", Home ); + } + + if (useHessian) { + sprintf( buf, "%s_mex_Hessian.%s", rootFileName, suffix ); + mex_hessFile = fopen(buf, "w"); + if( mex_hessFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_hessFile ); + IncludeCode( "%s/util/Mex_Hessian", Home ); + } + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMatlabTemplates() +{ +char buf[200], suffix[5]; + + if (useLang != MATLAB_LANG) return; + + + sprintf( buf, "%s_Fun_Chem.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Template_Fun_Chem", Home ); + + sprintf( buf, "%s_Update_SUN.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/UpdateSun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_Jac_Chem.m", rootFileName ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Template_Jac_Chem", Home ); + } + + if (useHessian) { + } + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateF90Modules(char where) +{ +char buf[200]; + +if (useLang != F90_LANG) return; + +switch (where) { +case 'h': + + sprintf( buf, "%s_Precision.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("\nMODULE %s_Precision\n", rootFileName ); + F90_Inline("!"); + F90_Inline("! Definition of different levels of accuracy"); + F90_Inline("! for REAL variables using KIND parameterization"); + F90_Inline("!"); + F90_Inline("! KPP SP - Single precision kind"); + F90_Inline(" INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,30)"); + F90_Inline("! KPP DP - Double precision kind"); + F90_Inline(" INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,300)"); + F90_Inline("! KPP QP - Quadruple precision kind"); + F90_Inline(" INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(18,400)"); + F90_Inline("\nEND MODULE %s_Precision\n\n", rootFileName ); + + UseFile( initFile ); + F90_Inline("MODULE %s_Initialize\n", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + F90_Inline("CONTAINS\n\n"); + + UseFile( param_headerFile ); + F90_Inline("MODULE %s_Parameters\n", rootFileName ); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( global_dataFile ); + F90_Inline("MODULE %s_Global\n", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: dp, NSPEC, NVAR, NFIX, NREACT", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( functionFile ); + F90_Inline("MODULE %s_Function\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + Declare( A ); /* mz_rs_20050117 */ + F90_Inline("\nCONTAINS\n\n"); + + UseFile( rateFile ); + F90_Inline("MODULE %s_Rates\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("MODULE %s_Stochastic\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: NVAR, NFIX, NREACT", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("MODULE %s_JacobianSP\n", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + } + + UseFile( jacobianFile ); + F90_Inline("MODULE %s_Jacobian\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("MODULE %s_StoichiomSP\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( stoichiomFile ); + F90_Inline("MODULE %s_Stoichiom\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_StoichiomSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("MODULE %s_HessianSP\n", rootFileName); + /* F90_Inline(" USE %s_Precision", rootFileName ); */ /* mz_rs_20050321 */ + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( hessianFile ); + F90_Inline("MODULE %s_Hessian\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_HessianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + UseFile( monitorFile ); + F90_Inline("MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("MODULE %s_LinearAlgebra\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + /* mz_rs_20050511+ if( useJacSparse ) added */ + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + /* mz_rs_20050511- */ + /* mz_rs_20050321+ */ + /* if (useHessian) */ + /* F90_Inline(" USE %s_HessianSP\n", rootFileName); */ + /* mz_rs_20050321- */ + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + UseFile( utilFile ); + F90_Inline("MODULE %s_Util\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + /* Here we define the model module which aggregates everything */ + /* put module rootFileName_Model into separate file */ + /* (reusing "sparse_dataFile" as done above for _Precision file) */ + sprintf( buf, "%s_Model.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("MODULE %s_Model\n", rootFileName); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("! Completely defines the model %s", rootFileName); + F90_Inline("! by using all the associated modules"); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("\n USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" USE %s_Function", rootFileName ); + F90_Inline(" USE %s_Integrator", rootFileName ); + F90_Inline(" USE %s_Rates", rootFileName ); + if ( useStochastic ) + F90_Inline(" USE %s_Stochastic", rootFileName ); + if ( useJacobian ) + F90_Inline(" USE %s_Jacobian", rootFileName ); + if ( useHessian ) + F90_Inline(" USE %s_Hessian", rootFileName); + if ( useStoicmat ) + F90_Inline(" USE %s_Stoichiom", rootFileName); + F90_Inline(" USE %s_LinearAlgebra", rootFileName); + F90_Inline(" USE %s_Monitor", rootFileName); + F90_Inline(" USE %s_Util", rootFileName); + F90_Inline("\nEND MODULE %s_Model\n", rootFileName); + + /* mz_rs_20050518+ */ + /* UseFile( driverFile ); */ + /* WriteDelim(); */ + /* mz_rs_20050518- */ + + break; + +case 't': + + /* mz_rs_20050117+ */ + UseFile( initFile ); + F90_Inline("\nEND MODULE %s_Initialize\n", rootFileName ); + /* mz_rs_20050117- */ + + UseFile( param_headerFile ); + F90_Inline("\nEND MODULE %s_Parameters\n", rootFileName ); + + UseFile( global_dataFile ); + F90_Inline("\nEND MODULE %s_Global\n", rootFileName ); + + UseFile( functionFile ); + F90_Inline("\nEND MODULE %s_Function\n", rootFileName ); + + UseFile( rateFile ); + F90_Inline("\nEND MODULE %s_Rates\n", rootFileName ); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("\nEND MODULE %s_Stochastic\n", rootFileName); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("\nEND MODULE %s_JacobianSP\n", rootFileName); + } + + UseFile( jacobianFile ); + F90_Inline("\nEND MODULE %s_Jacobian\n", rootFileName ); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("\nEND MODULE %s_StoichiomSP\n", rootFileName); + + UseFile( stoichiomFile ); + F90_Inline("\nEND MODULE %s_Stoichiom\n", rootFileName); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("\nEND MODULE %s_HessianSP\n", rootFileName); + + UseFile( hessianFile ); + F90_Inline("\nEND MODULE %s_Hessian\n", rootFileName ); + } + + UseFile(monitorFile); + F90_Inline("\nEND MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("\nEND MODULE %s_LinearAlgebra\n", rootFileName); + + UseFile( utilFile ); + F90_Inline("\nEND MODULE %s_Util\n", rootFileName); + + break; + +default: + printf("\n Unrecognized option '%s' in GenerateF90Modules\n", where); + break; +} +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Generate() +{ +int i, j; +int n; + + VarStartNr = 0; + FixStartNr = VarNr; + + real = useDouble ? DOUBLE : REAL; + + n = MAX_OUTBUF; + for( i = 1; i < INLINE_OPT; i++ ) + if( InlineCode[i].maxlen > n ) + n = InlineCode[i].maxlen; + + outBuf = (char*)malloc( n ); + outBuffer = outBuf; + + switch( useLang ) { + case F77_LANG: Use_F( rootFileName ); + break; + case F90_LANG: Use_F90( rootFileName ); + break; + case C_LANG: Use_C( rootFileName ); + break; + case MATLAB_LANG: Use_MATLAB( rootFileName ); + break; + default: printf("\n Language no '%s' unknown\n",useLang ); + } + printf("\nKPP is initializing the code generation."); + InitGen(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('h'); + + GenerateMap(); + +/* if( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) +{*/ + printf("\nKPP is generating the monitor data:"); + printf("\n - %s_Monitor",rootFileName); + GenerateMonitorData(); +/* }*/ + + printf("\nKPP is generating the utility data:"); + printf("\n - %s_Util",rootFileName); + GenerateUtil(); + + printf("\nKPP is generating the global declarations:"); + printf("\n - %s_Main",rootFileName); + GenerateGData(); + + + printf("\nKPP is generating the ODE function:"); + printf("\n - %s_Function",rootFileName); + GenerateFun(); + + if ( useStochastic ) { + printf("\nKPP is generating the Stochastic description:"); + printf("\n - %s_Function",rootFileName); + GenerateStochastic(); + } + + if ( useJacobian ) { + printf("\nKPP is generating the ODE Jacobian:"); + printf("\n - %s_Jacobian\n - %s_JacobianSP",rootFileName,rootFileName); + GenerateJac(); + GenerateJacobianSparseData(); + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) { + GenerateJacVect(); + GenerateJacTRVect(); + if( useJacSparse ) { + printf("\nKPP is generating the linear algebra routines:"); + printf("\n - %s_LinearAlgebra",rootFileName); + GenerateSparseUtil(); + GenerateSolve(); + GenerateTRSolve(); + } + } + } + + GenerateBlas(); + + if( useHessian ) { + printf("\nKPP is generating the Hessian:"); + printf("\n - %s_Hessian\n - %s_HessianSP",rootFileName,rootFileName); + GenerateHessian(); + GenerateHessianSparseData(); + } + + printf("\nKPP is generating the utility functions:"); + printf("\n - %s_Util",rootFileName); + + GenerateInitialize(); + + GenerateShuffle_user2kpp(); + GenerateShuffle_kpp2user(); + + printf("\nKPP is generating the rate laws:"); + printf("\n - %s_Rates",rootFileName); + + GenerateRateLaws(); + GenerateUpdateSun(); + GenerateUpdateRconst(); + GenerateUpdatePhoto(); + GenerateGetMass(); + + + printf("\nKPP is generating the parameters:"); + printf("\n - %s_Parameters",rootFileName); + + GenerateParamHeader(); + + printf("\nKPP is generating the global data:"); + printf("\n - %s_Global",rootFileName); + + GenerateGlobalHeader(); + + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) { + printf("\nKPP is generating the sparsity data:"); + if( useJacSparse ) { + GenerateJacobianSparseHeader(); + printf("\n - %s_JacobianSP",rootFileName); + } + if( useHessian ) { + GenerateHessianSparseHeader(); + printf("\n - %s_HessianSP",rootFileName); + } + } + + if ( useStoicmat ) { + printf("\nKPP is generating the stoichiometric description files:"); + printf("\n - %s_Stoichiom\n - %s_StoichiomSP",rootFileName,rootFileName); + GenerateReactantProd(); + GenerateJacReactantProd(); + GenerateStoicmSparseData(); + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) + GenerateStoicmSparseHeader(); + GenerateDFunDRcoeff(); + GenerateDJacDRcoeff(); + } + + printf("\nKPP is generating the driver from %s.f90:", driver); + printf("\n - %s_Main",rootFileName); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateIntegrator(); + + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + GenerateDriver(); + /* mz_rs_20050518- */ + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMakefile(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('t'); + + if ( useLang == MATLAB_LANG ) + GenerateMatlabTemplates(); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMex(); + + /* mz_rs_20050117+ */ + if( initFile ) fclose( initFile ); + /* mz_rs_20050117- */ + if( driverFile ) fclose( driverFile ); + if( functionFile ) fclose( functionFile ); + if( global_dataFile ) fclose( global_dataFile ); + if( hessianFile ) fclose( hessianFile ); + if( integratorFile ) fclose( integratorFile ); + if( jacobianFile ) fclose( jacobianFile ); + if( linalgFile ) fclose( linalgFile ); + if( mapFile ) fclose( mapFile ); + if( makeFile ) fclose( makeFile ); + if( monitorFile ) fclose( monitorFile ); + if( mex_funFile ) fclose( mex_funFile ); + if( mex_jacFile ) fclose( mex_jacFile ); + if( mex_hessFile ) fclose( mex_hessFile ); + if( param_headerFile ) fclose( param_headerFile ); + if( rateFile ) fclose( rateFile ); + if( sparse_dataFile ) fclose( sparse_dataFile ); + if( sparse_jacFile ) fclose( sparse_jacFile ); + if( sparse_hessFile ) fclose( sparse_hessFile ); + if( sparse_stoicmFile ) fclose( sparse_stoicmFile ); + if( stoichiomFile ) fclose( stoichiomFile ); + if( utilFile ) fclose( utilFile ); + if( stochasticFile ) fclose( stochasticFile ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int* AllocIntegerVector(int n, char* message) +{ +int* vec; +if ( ( vec=(int*)calloc(n,sizeof(int)) ) == NULL ) + FatalError(-30,"%s: Cannot allocate vector.",message); +return vec; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/* Allocates a matrix of integers */ +int** AllocIntegerMatrix(int m, int n, char* message) +{ +int** mat; +int i; +if ( (mat = (int**)calloc(m,sizeof(int*)))==NULL ) { + FatalError(-30,"%s: Cannot allocate matrix.", message); + } +for (i=0; i value = max(SpcNr,1); + varTable[ NVAR ] -> value = max(VarNr,1); + varTable[ NVARACT ] -> value = max(VarActiveNr,1); + varTable[ NFIX ] -> value = max(FixNr,1); + varTable[ NREACT ] -> value = max(EqnNr,1); + varTable[ NVARST ] -> value = Index(0); + varTable[ NFIXST ] -> value = Index(VarNr); + } +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int NonZero( int stru, int start, int end, + int *row, int *col, int *crow, int *diag ) +{ +int nElm; +int i,j; + + nElm = 0; + for (i = 0; i < end-start; i++) { + crow[i] = Index(nElm); + for (j = 0; j < end-start; j++) { + if( (i == j) || ( (stru) ? LUstructJ[i+start][j+start] + : structJ[i+start][j+start] ) ) { + row[nElm] = Index(i); + col[nElm] = Index(j); + nElm++; + } + if( i == j ) { + diag[i] = Index(nElm-1); + } + } + } + crow[i] = Index(nElm); + diag[i] = Index(nElm); + return nElm; +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *EQN_NAMES[MAX_EQN]; +char *EQN_TAGS[MAX_EQN]; +char *bufeqn, *p; +int dim; + + if ( (useLang != C_LANG)&&(useLang != MATLAB_LANG) ) return; + + UseFile( driverFile ); + + NewLines(1); + + GlobalDeclare( C ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[VAR]->name, varTable[C]->name, 0 ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[FIX]->name, varTable[C]->name, VarNr ); + + + GlobalDeclare( RCONST ); + GlobalDeclare( TIME ); + GlobalDeclare( SUN ); + GlobalDeclare( TEMP ); + GlobalDeclare( RTOLS ); + GlobalDeclare( TSTART ); + GlobalDeclare( TEND ); + GlobalDeclare( DT ); + GlobalDeclare( ATOL ); + GlobalDeclare( RTOL ); + GlobalDeclare( STEPMIN ); + GlobalDeclare( STEPMAX ); + GlobalDeclare( CFACTOR ); + if (useStochastic) + GlobalDeclare( VOLUME ); + + MATLAB_Inline(" %s_Parameters;",rootFileName); + MATLAB_Inline(" %s_Global_defs;",rootFileName); + MATLAB_Inline(" %s_Sparse;",rootFileName); + MATLAB_Inline(" %s_Monitor;",rootFileName); + if (useJacSparse ) + MATLAB_Inline(" %s_JacobianSP;",rootFileName); + if (useHessian ) + MATLAB_Inline(" %s_HessianSP;",rootFileName); + if (useStoicmat ) + MATLAB_Inline(" %s_StoichiomSP;",rootFileName); + + NewLines(1); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMonitorData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *seqn[MAX_EQN]; +char *bufeqn, *p; +int dim; + + + /* Allocate local data structures */ + dim = SpcNr+2; + crow = AllocIntegerVector( dim, "crow in GenerateMonitorData"); + diag = AllocIntegerVector( dim, "diag in GenerateMonitorData"); + lookat = AllocIntegerVector( dim, "lookat in GenerateMonitorData"); + moni = AllocIntegerVector( dim, "moni in GenerateMonitorData"); + trans = AllocIntegerVector( dim, "trans in GenerateMonitorData"); + + UseFile( monitorFile ); + + F77_Inline("%6sBLOCK DATA MONITOR_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Parameters.h'", " ",rootFileName); + F77_Inline("%6sINCLUDE '%s_Global.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i", " " ); + + /* InitDeclare( CFACTOR, 0, (void*)&cfactor ); */ + + NewLines(1); + + for (i = 0; i < SpcNr; i++) { + snames[i] = SpeciesTable[Code[i]].name; + } + InitDeclare( SPC_NAMES, SpcNr, (void*)snames ); + + nlookat = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].lookat ) { + lookat[nlookat] = Index(i); + nlookat++; + } + + if (ValueDimension) + varTable[ NLOOKAT ] -> value = max(nlookat,1); + InitDeclare( LOOKAT, nlookat, (void*)lookat ); + + nmoni = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].moni ) { + moni[nmoni] = Index(i); + nmoni++; + } + + if( nmoni > MAX_MONITOR ) { + Warning( "%d species to monitorize. Too many, keeping %d.", + nmoni, MAX_MONITOR ); + nmoni = MAX_MONITOR; + } + + if (ValueDimension) + varTable[ NMONITOR ] -> value = max(nmoni,1); + InitDeclare( MONITOR, nmoni, (void*)moni ); + + ntrans = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].trans ) { + trans[ntrans] = Index(i); + strans[ntrans] = SpeciesTable[Code[i]].name; + ntrans++; + } + + nmass = 0; + for (i = 0; i < AtomNr; i++) + if ( AtomTable[i].masscheck ) { + smass[nmass] = AtomTable[i].name; + nmass++; + } + if (ValueDimension) + varTable[ NMASS ] -> value = max(nmass,1); + InitDeclare( SMASS, nmass, (void*)smass ); + + if ( (bufeqn = (char*)malloc(MAX_EQNLEN*EqnNr+2))==NULL ) { + FatalError(-30,"GenerateMonitorData: Cannot allocate bufeqn (%d chars)", + MAX_EQNLEN*EqnNr); + } + + p = bufeqn; + for (i = 0; i < EqnNr; i++) { + EqnString(i, p); + seqn[i] = p; + p += MAX_EQNLEN; + } + InitDeclare( EQN_NAMES, EqnNr, (void*)seqn ); + + free( bufeqn ); + + if (useEqntags==1) { + for (i = 0; i < EqnNr; i++) { + seqn[i] = kr[i].label; + } + InitDeclare( EQN_TAGS, EqnNr, (void*)seqn ); + } + + NewLines(1); + WriteComment("INLINED global variables"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_DATA ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_DATA ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_DATA ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_DATA ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED global variables"); + NewLines(1); + + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local data structures */ + free(crow); free(diag); free(lookat); free(moni); free(trans); + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseData() +{ +int* irow; +int* icol; +int* crow; +int* diag; +int nElm; +int dim; + + if( !useJacSparse ) return; + + /* Allocate local arrays */ + dim=MAX_SPECIES; + irow = AllocIntegerVector( dim*dim, "irow in GenerateJacobianSparseData" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateJacobianSparseData" ); + crow = AllocIntegerVector( dim, "crow in GenerateJacobianSparseData" ); + diag = AllocIntegerVector( dim, "diag in GenerateJacobianSparseData" ); + + UseFile( sparse_jacFile ); + + NewLines(1); + WriteComment("Sparse Jacobian Data"); + NewLines(1); + + F77_Inline("%6sBLOCK DATA JACOBIAN_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i"," "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + + + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + if (ValueDimension) { + varTable[NONZERO] -> value = Jac_NZ; + varTable[LU_NONZERO] -> value = LU_Jac_NZ; + } + + switch (useJacobian) { + case JAC_ROW: + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( IROW, Jac_NZ, (void*)irow ); + InitDeclare( ICOL, Jac_NZ, (void*)icol ); + InitDeclare( CROW, VarNr+1, (void*)crow ); + InitDeclare( DIAG, VarNr+1, (void*)diag ); + break; + case JAC_LU_ROW: + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( LU_IROW, LU_Jac_NZ, (void*)irow ); + InitDeclare( LU_ICOL, LU_Jac_NZ, (void*)icol ); + InitDeclare( LU_CROW, VarNr+1, (void*)crow ); + InitDeclare( LU_DIAG, VarNr+1, (void*)diag ); + } + NewLines(1); + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local arrays */ + free(irow); free(icol); free(crow); free(diag); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseHeader() +{ + UseFile( sparse_dataFile ); + + CommonName = "SDATA"; + + NewLines(1); + WriteComment(" ----------> Sparse Jacobian Data"); + NewLines(1); + + switch (useJacobian) { + case JAC_ROW: + ExternDeclare( IROW ); + ExternDeclare( ICOL ); + ExternDeclare( CROW ); + ExternDeclare( DIAG ); + break; + case JAC_LU_ROW: + ExternDeclare( LU_IROW ); + ExternDeclare( LU_ICOL ); + ExternDeclare( LU_CROW ); + ExternDeclare( LU_DIAG ); + } + + NewLines(1); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateFun() +{ +int i, j, k; +int used; +int l, m; +int F_VAR, FSPLIT_VAR; + + if( VarNr == 0 ) return; + + if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ + UseFile( functionFile ); + + F_VAR = DefFnc( "Fun", 4, "time derivatives of variables - Agregate form"); + FSPLIT_VAR = DefFnc( "Fun_SPLIT", 5, "time derivatives of variables - Split form"); + + if( useAggregate ) + FunctionBegin( F_VAR, V, F, RCT, Vdot ); + else + FunctionBegin( FSPLIT_VAR, V, F, RCT, P_VAR, D_VAR ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + + if ( useLang!=F90_LANG ) { /* A is a module variable in F90 */ + NewLines(1); + WriteComment("Local variables"); + Declare( A ); + } + NewLines(1); + WriteComment("Computation of equation rates"); + + for(j=0; j 1. PROPENSITY FUNCTION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "Propensity", 4, "Propensity function"); + FunctionBegin( F_VAR, NMLCV, NMLCF, SCT, PROPENSITY ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + NewLines(1); + + for(j=0; j 2. RATE CONVERSION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "StochasticRates", 3, "Convert deterministic rates to stochastic"); + FunctionBegin( F_VAR, RCT, VOLUME, SCT ); + WriteComment("No. of molecules = Concentration x Volume"); + WriteComment("For a reaction with k reactants:"); + WriteComment(" RCT [ (molec/Volume)^(1-k) * sec^(-1) ]"); + WriteComment(" SCT [ (molec)^(1-k) * sec^(-1) ] = RCT*Volume^(k-1)"); + WriteComment("For p molecules of the same type: SCT = SCT/(p!)"); + + NewLines(1); + + for(j=0; j 3. THE CHANGE IN NUMBER OF MOLECULES */ + if (useLang == MATLAB_LANG) { + F_VAR = DefFnc( "MoleculeChange", 3, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV, NMLCV ); + } else { + F_VAR = DefFnc( "MoleculeChange", 2, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV ); + } + + NewLines(1); + + F90_Inline("\n SELECT CASE (IRCT)\n"); + C_Inline ("\n switch (IRCT) { \n"); + MATLAB_Inline("\n switch (IRCT) \n"); + for(j=0; j value = JVRP_NZ + 1; + + FunctionEnd( F_STOIC ); + FreeVariable( F_STOIC ); + + + UseFile( sparse_stoicmFile ); + NewLines(1); + WriteComment("Row-compressed sparse data for the Jacobian of reaction products JVRP"); + F77_Inline("%6sBLOCK DATA JVRP_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ", rootFileName); + F77_Inline("%6sINTEGER i", " "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + if( (useLang==F77_LANG)||(useLang==F90_LANG) ) { + for (k=0; k value = nonzeros_B; + Declare( BV ); + } + + NewLines(1); + + for ( i=0; i=2) + nElm++; + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) + nElm++; + } + +/* Allocate temporary index arrays */ + coeff_j = AllocIntegerVector(nElm, "coeff_j in GenerateHess"); + coeff_i1 = AllocIntegerVector(nElm, "coeff_i1 in GenerateHess"); + coeff_i2 = AllocIntegerVector(nElm, "coeff_i2 in GenerateHess"); + +/* Fill in temporary index arrays */ + nElm = 0; + for(j=0; j=2) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } +/* Number of nonzero terms of the form d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + Djv_isElm = 1; + } + if (Djv_isElm == 1) Hess_NZ++ ; + } /* for i, i1, i2 */ + if (ValueDimension) + varTable[ NHESS ] -> value = max( Hess_NZ, 1 ); + +/* Allocate temporary index arrays */ + iHess_i = AllocIntegerVector(Hess_NZ, "iHess_i in GenerateHess"); + iHess_j = AllocIntegerVector(Hess_NZ, "iHess_j in GenerateHess"); + iHess_k = AllocIntegerVector(Hess_NZ, "iHess_k in GenerateHess"); + + F_Hess = DefFnc( "Hessian", 4, "function for Hessian (Jac derivative w.r.t. variables)"); + FunctionBegin( F_Hess, V, F, RCT, HESS ); + + WriteComment("--------------------------------------------------------"); + WriteComment("Note: HESS is represented in coordinate sparse format: "); + WriteComment(" HESS(m) = d^2 f_i / dv_j dv_k = d Jac_{i,j} / dv_k"); + WriteComment(" where i = IHESS_I(m), j = IHESS_J(m), k = IHESS_K(m)."); + WriteComment("--------------------------------------------------------"); + WriteComment("Note: d^2 f_i / dv_j dv_k = d^2 f_i / dv_k dv_j, "); + WriteComment(" therefore only the terms d^2 f_i / dv_j dv_k"); + WriteComment(" with j <= k are computed and stored in HESS."); + WriteComment("--------------------------------------------------------"); + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) { + NewLines(1); + WriteComment("Local variables"); + /* DeclareConstant( NTMPD2A, ascii( max( nElm, 1 ) ) ); */ + varTable[ NTMPD2A ] -> value = max( nElm, 1 ); + Declare( D2A ); + } + + NewLines(1); + WriteComment("Computation of the second derivatives of equation rates"); + +/* Generate d^2 A(j)/ ( d v(i1) d v(i2) )*/ + nElm = 0; + for(j=0; j=2) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j]-1 ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-2; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d)/{dV(%d)dV(%d)}",Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if (Stoich_Left[i1][j]>=2) */ + + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-1; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < i2; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i2][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i2][j]-1; k++ ) + prod = Mul( prod, Elm( V, i2 ) ); + for (i = i2+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d) / dV(%d)dV(%d)", + Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) */ + } /* if i1==i2 */ + + } /* for j, i1, i2 */ + + NewLines(1); + WriteComment("Computation of the Jacobian derivative"); + +/* Generate d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + sum = Const(0); + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + sum = Add( sum, + Mul( Const( Stoich[i][j] ), Elm( D2A, k ) ) ); + Djv_isElm = 1; + } + if (Djv_isElm == 1) { + WriteComment("HESS(%d) = d^2 Vdot(%d)/{dV(%d)dV(%d)} = d^2 Vdot(%d)/{dV(%d)dV(%d)}", + Index(Hess_NZ),Index(i),Index(i1),Index(i2),Index(i),Index(i2),Index(i1)); + Assign( Elm( HESS, Hess_NZ ), sum ); + iHess_i[ Hess_NZ ] = i; + iHess_j[ Hess_NZ ] = i1; + iHess_k[ Hess_NZ ] = i2; + Hess_NZ++; + } + + } /* for i, i1, i2 */ + + +/* free temporary index arrays */ + free(coeff_j); free(coeff_i1); free(coeff_i2); + + MATLAB_Inline("\n HESS = HESS(:);"); + + FunctionEnd( F_Hess ); + + FreeVariable( F_Hess ); + + + F_HessTR_VEC = DefFnc( "HessTR_Vec", 4, "Hessian transposed times user vectors"); + FunctionBegin( F_HessTR_VEC, HESS, U1, U2, HTU ); + WriteComment("Compute the vector HTU =(Hess x U2)^T * U1 = d (Jac^T*U1)/d Var * U2 "); + + for (i=0; i Sparse Hessian Data"); + NewLines(1); + + ExternDeclare( IHESS_I ); + ExternDeclare( IHESS_J ); + ExternDeclare( IHESS_K ); + + NewLines(1); +} + + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateStoicmSparseData() +{ +int i,j,k, nnz_stoicm; +/* +int irow_stoicm[MAX_SPECIES*MAX_EQN]; +int ccol_stoicm[MAX_EQN+2]; +int icol_stoicm[MAX_SPECIES*MAX_EQN]; +double stoicm[MAX_SPECIES*MAX_EQN]; +*/ + +int *irow_stoicm; +int *ccol_stoicm; +int *icol_stoicm; +double *stoicm; + +/* Compute the sparsity structure and allocate data structure vectors */ + nnz_stoicm = 0; + for (j=0; j Sparse Stoichiometric Matrix"); + NewLines(1); + CommonName = "STOICM_VALUES"; + ExternDeclare( STOICM ); + CommonName = "STOICM_DATA"; + ExternDeclare( IROW_STOICM ); + ExternDeclare( CCOL_STOICM ); + ExternDeclare( ICOL_STOICM ); + NewLines(1); + + NewLines(1); + WriteComment(" ----------> Sparse Data for Jacobian of Reactant Products"); + NewLines(1); + CommonName = "JVRP"; + ExternDeclare( ICOL_JVRP ); + ExternDeclare( IROW_JVRP ); + ExternDeclare( CROW_JVRP ); + NewLines(1); + +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacVect() +{ +int i, j, nElm; +int Jac_VEC; +int Jac_SP_VEC; + + if( useLang == MATLAB_LANG ) return; + + if( VarNr == 0 ) return; + + UseFile( jacobianFile ); + Jac_VEC = DefFnc( "Jac_Vec", 3, + "function for sparse multiplication: square Jacobian times vector"); + Jac_SP_VEC = DefFnc( "Jac_SP_Vec", 3, + "function for sparse multiplication: sparse Jacobian times vector"); + + if ( useJacSparse ) { + FunctionBegin( Jac_SP_VEC, JVS, UV, JUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JVS, nElm ), Elm( UV, j ) ) ); + nElm++; + } + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_SP_VEC ); + } + + else { + FunctionBegin( Jac_VEC, JV, UV, JUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JV, i, j ), Elm( UV, j ) ) ); + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_VEC ); + } + + FreeVariable( Jac_VEC ); + FreeVariable( Jac_SP_VEC ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacTRVect() +{ +int i, j, nElm; +int JacTR_VEC; +int JacTR_SP_VEC; +int **TmpStruct; + + if( useLang == MATLAB_LANG ) return; + + if ( VarNr == 0 ) return; + + UseFile( jacobianFile ); + + JacTR_VEC = DefFnc( "JacTR_Vec", 3, + "sparse multiplication: square Jacobian transposed times vector"); + JacTR_SP_VEC = DefFnc( "JacTR_SP_Vec", 3, + "sparse multiplication: sparse Jacobian transposed times vector"); + + if ( useJacSparse ) { + + /* The temporary array of structure */ + TmpStruct = AllocIntegerMatrix( VarNr, VarNr, "TmpStruct in GenerateJacTRVect" ); + + nElm = 0; + for( i = 0; i < VarNr; i++) + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + TmpStruct[i][j] = nElm; + nElm++; + } + + FunctionBegin( JacTR_SP_VEC, JVS, UV, JTUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JVS, TmpStruct[j][i] ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_SP_VEC ); + + /* Free the temporary array of structure */ + FreeIntegerMatrix( TmpStruct, VarNr, VarNr ); + + } /* useJacSparse*/ + + else { + FunctionBegin( JacTR_VEC, JV, UV, JTUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JV, j, i ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_VEC ); + } + + FreeVariable( JacTR_VEC ); + FreeVariable( JacTR_SP_VEC ); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSparseUtil() +{ +int SUTIL; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + SUTIL = DefFnc( "SPARSE_UTIL", 0, "SPARSE utility functions"); + CommentFunctionBegin( SUTIL ); + + IncludeCode( "%s/util/sutil", Home ); + + CommentFunctionEnd( SUTIL ); + FreeVariable( SUTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateBlas() +{ +int BLAS; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + BLAS = DefFnc( "BLAS_UTIL", 0, "BLAS-LIKE utility functions"); + CommentFunctionBegin( BLAS ); + + IncludeCode( "%s/util/blas", Home ); + + CommentFunctionEnd( BLAS ); + FreeVariable( BLAS ); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDFunDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dFun_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDJacDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dJac_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSolve() +{ +int i, j; +int SOLVE; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateSolve" ); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVE = DefFnc( "KppSolve", 2, "sparse back substitution"); + FunctionBegin( SOLVE, JVS, X ); + + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + sum = Elm( X, i ); + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + Assign( Elm( X, i ), sum ); + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + sum = Elm( X, i ); + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + sum = Div( sum, Elm( JVS, diag[i] ) ); + Assign( Elm( X, i ), sum ); + } + + FunctionEnd( SOLVE ); + FreeVariable( SOLVE ); + + /* Free Local Arrays */ + free(irow); + free(icol); + free(crow); + free(diag); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateTRSolve() +{ +int i, j; +int SOLVETR; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int **pos; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateTRSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateTRSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateTRSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateTRSolve" ); + pos = AllocIntegerMatrix( dim+1, dim+1, "pos in GenerateTRSolve"); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVETR = DefFnc( "KppSolveTR", 3, "sparse, transposed back substitution"); + FunctionBegin( SOLVETR, JVS, X, XX ); + for( i = 0; i < VarNr; i++) { + for( j = 0; j < VarNr; j++) + pos[i][j]=-1; + } + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + pos[i][i]=diag[i]; + } + + for( i = 0; i= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + sum=Div( sum, Elm(JVS, diag[i] ) ); + Assign( Elm( XX, i ), sum ); + } + for( i = VarNr-1; i >=0; i--) { + sum = Elm( XX, i ); + for (j=i+1; j= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + Assign( Elm( XX, i ), sum ); + } + + FunctionEnd( SOLVETR ); + FreeVariable( SOLVETR ); + /* Free Local Arrays */ + free(irow); free(icol); free(crow); free(diag); + FreeIntegerMatrix(pos, dim+1, dim+1); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateRateLaws() +{ + + UseFile( rateFile ); + + NewLines(1); + WriteComment("Begin Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + IncludeCode( "%s/util/UserRateLaws", Home ); + NewLines(1); + WriteComment("End Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED Rate Law Functions"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RATES ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RATES ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RATES ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RATES ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Rate Law Functions"); + NewLines(1); + + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateSun() +{ +int UPDATE_SUN; + + UseFile( rateFile ); + + UPDATE_SUN = DefFnc( "Update_SUN", 0, "update SUN light using TIME"); + CommentFunctionBegin( UPDATE_SUN ); + + IncludeCode( "%s/util/UpdateSun", Home ); + + CommentFunctionEnd( UPDATE_SUN ); + FreeVariable( UPDATE_SUN ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateRconst() +{ +int i; +int UPDATE_RCONST; + + UseFile( rateFile ); + + UPDATE_RCONST = DefFnc( "Update_RCONST", 0, "function to update rate constants"); + + FunctionBegin( UPDATE_RCONST ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + if ( (useLang==F77_LANG) ) + IncludeCode( "%s/util/UserRateLaws_FcnHeader", Home ); + + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED RCONST"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RCONST ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RCONST ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RCONST ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RCONST ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED RCONST"); + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == EXPRESION ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + /* mz_rs_20050117+ */ + if ( kr[i].type == NUMBER ) { + F90_Inline("! RCONST(%d) = constant rate coefficient", i+1); + /* WriteComment("Constant rate coefficient (value inlined in the code):"); */ + /* Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); */ + } + /* mz_rs_20050117- */ + } + + MATLAB_Inline(" RCONST = RCONST(:);"); + + FunctionEnd( UPDATE_RCONST ); + FreeVariable( UPDATE_RCONST ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdatePhoto() +{ +int i; +int UPDATE_PHOTO; + + UseFile( rateFile ); + + UPDATE_PHOTO = DefFnc( "Update_PHOTO", 0, "function to update photolytical rate constants"); + + FunctionBegin( UPDATE_PHOTO ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + } + + FunctionEnd( UPDATE_PHOTO ); + FreeVariable( UPDATE_PHOTO ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateIntegrator() +{ +int TIN, TOUT, INTEGRATE; + + UseFile( integratorFile ); + + TIN = DefElm( "TIN", real, "Start Time for Integration"); + TOUT = DefElm( "TOUT", real, "End Time for Integration"); + INTEGRATE = DefFnc( "INTEGRATE", 2, "Integrator routine"); + CommentFunctionBegin( INTEGRATE, TIN, TOUT ); + + if( strchr( integrator, '/' ) ) + IncludeCode( integrator ); + else + IncludeCode( "%s/int/%s", Home, integrator ); + + CommentFunctionEnd( INTEGRATE ); + FreeVariable( INTEGRATE ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDriver() +{ +int MAIN; + + UseFile( driverFile ); + + MAIN = DefFnc( "MAIN", 0, "Main program - driver routine"); + CommentFunctionBegin( MAIN ); + + if( strchr( driver, '/' ) ) + IncludeCode( driver ); + else + IncludeCode( "%s/drv/%s", Home, driver ); + + CommentFunctionEnd( MAIN ); + FreeVariable( MAIN ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUtil() +{ +int UTIL; + +/* if (useLang == MATLAB_LANG) return; */ + + UseFile( utilFile ); + NewLines(1); + WriteComment("User INLINED Utility Functions"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_UTIL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_UTIL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_UTIL ].code ); + break; + case MATLAB_LANG:bprintf( InlineCode[ MATLAB_UTIL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Utility Functions"); + NewLines(1); + + WriteComment("Utility Functions from KPP_HOME/util/util"); + UTIL = DefFnc( "UTIL", 0, "Utility functions"); + CommentFunctionBegin( UTIL); + + IncludeCode( "%s/util/util", Home ); + + if ((useLang == F90_LANG) && (useEqntags==1)) { + IncludeCode( "%s/util/tag2num", Home ); + } + + WriteComment("End Utility Functions from KPP_HOME/util/util"); + CommentFunctionEnd( UTIL ); + FreeVariable( UTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateParamHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + +int j,dummy_species; + +/* ----------> First declaration of constants */ + UseFile( param_headerFile ); + + NewLines(1); + DeclareConstant( NSPEC, ascii( max(SpcNr, 1) ) ); + DeclareConstant( NVAR, ascii( max(VarNr, 1) ) ); + DeclareConstant( NVARACT, ascii( max(VarActiveNr, 1) ) ); + DeclareConstant( NFIX, ascii( max(FixNr, 1) ) ); + DeclareConstant( NREACT, ascii( max(EqnNr, 1) ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + DeclareConstant( NONZERO, ascii( max(Jac_NZ, 1) ) ); + DeclareConstant( LU_NONZERO, ascii( max(LU_Jac_NZ, 1) ) ); + DeclareConstant( CNVAR, ascii( VarNr+1 ) ); + if ( useStoicmat ) { + DeclareConstant( CNEQN, ascii( EqnNr+1 ) ); + } + if ( useHessian ) { + DeclareConstant( NHESS, ascii( max(Hess_NZ, 1) ) ); + } + + DeclareConstant( NLOOKAT, ascii( nlookat ) ); + DeclareConstant( NMONITOR, ascii( nmoni ) ); + DeclareConstant( NMASS, ascii( nmass ) ); + + DeclareConstant( PI, "3.14159265358979" ); + + NewLines(1); + WriteComment("Index declaration for variable species in C and VAR"); + WriteComment(" VAR(ind_spc) = C(ind_spc)"); + NewLines(1); + for( i = 0; i < VarNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } + + NewLines(1); + WriteComment("Index declaration for fixed species in C"); + WriteComment(" C(ind_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i+VarNr) ) ); + FreeVariable( spc ); + } + + if (useDummyindex==1) { + NewLines(1); + WriteComment("Index declaration for dummy species"); + NewLines(1); + for( i = 0; i < MAX_SPECIES; i++) { + if (SpeciesTable[i].type == 0) continue; + dummy_species = 1; + for( j = 0; j < MAX_SPECIES; j++) + if (Code[j] == i) dummy_species = 0; + if (dummy_species) { + sprintf( name, "ind_%s", SpeciesTable[i].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( 0 ) ); + FreeVariable( spc ); + } + } + } + + NewLines(1); + WriteComment("Index declaration for fixed species in FIX"); + WriteComment(" FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "indf_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGlobalHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + + UseFile( global_dataFile ); + + CommonName = "GDATA"; + + NewLines(1); + WriteComment("Declaration of global variables"); + NewLines(1); + + /* ExternDeclare( C_DEFAULT ); */ + + ExternDeclare( C ); + + if( useLang == F77_LANG ) { + + Declare( VAR ); + Declare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == F90_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == MATLAB_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + } + + C_Inline(" extern %s * %s;", C_types[real], varTable[VAR]->name ); + C_Inline(" extern %s * %s;", C_types[real], varTable[FIX]->name ); + + + ExternDeclare( RCONST ); + ExternDeclare( TIME ); + ExternDeclare( SUN ); + ExternDeclare( TEMP ); + ExternDeclare( RTOLS ); + ExternDeclare( TSTART ); + ExternDeclare( TEND ); + ExternDeclare( DT ); + ExternDeclare( ATOL ); + ExternDeclare( RTOL ); + ExternDeclare( STEPMIN ); + ExternDeclare( STEPMAX ); + ExternDeclare( CFACTOR ); + if (useStochastic) + ExternDeclare( VOLUME ); + + CommonName = "INTGDATA"; + if ( useHessian ) { + ExternDeclare( DDMTYPE ); + } + + + if ( (useLang == C_LANG) || (useLang == F77_LANG) ) { + CommonName = "INTGDATA"; + ExternDeclare( LOOKAT ); + ExternDeclare( MONITOR ); + CommonName = "CHARGDATA"; + ExternDeclare( SPC_NAMES ); + ExternDeclare( SMASS ); + ExternDeclare( EQN_NAMES ); + ExternDeclare( EQN_TAGS ); + } + + NewLines(1); + WriteComment("INLINED global variable declarations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_GLOBAL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_GLOBAL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_GLOBAL ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_GLOBAL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("INLINED global variable declarations"); + NewLines(1); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void WriteSpec( int i, int j ) +{ +char buf[100]; + + if( Reactive[j] ) + sprintf( buf, "%s (r)", SpeciesTable[ Code[j] ].name ); + else + sprintf( buf, "%s (n)", SpeciesTable[ Code[j] ].name ); + WriteAll("%3d = %-10s", 1 + i, buf ); + FlushBuf(); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnStr( int eq, char * buf, float** mat ) +{ +int spc, first; + +/* bugfix if stoichiometric factor is not an integer */ +int n; +char s[40]; + + first = 1; + *buf = 0; + for( spc = 0; spc < SpcNr; spc++ ) + if( mat[spc][eq] != 0 ) { + if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { + sprintf(s, ""); + } else { + /* real */ + /* mz_rs_20050130+ */ + /* sprintf(s, "%g", mat[spc][eq]); */ + /* remove the minus sign with fabs(), it will be re-inserted later */ + sprintf(s, "%g", fabs(mat[spc][eq])); + /* mz_rs_20050130- */ + /* remove trailing zeroes */ + for (n= strlen(s) - 1; n >= 0; n--) + if (s[n] != '0') break; + s[n + 1]= '\0'; + sprintf(s, "%s ", s); + } + + if( first ) { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); + else sprintf(buf, "%s- %s", buf, s); + first = 0; + } else { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); + else sprintf(buf, "%s - %s", buf, s); + } + sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); + if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ + sprintf(buf, "%s ... etc.",buf); + break; + } + } + + return strlen(buf); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnString( int eq, char * buf ) +{ +static int lhs = 0; +static int rhs = 0; + +int i, l; +char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; + + if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, lhsbuf, Stoich_Left); + lhs = (lhs > l) ? lhs : l; + } + + if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, rhsbuf, Stoich_Right); + rhs = (rhs > l) ? lhs : l; + } + + + EqnStr( eq, lhsbuf, Stoich_Left); + EqnStr( eq, rhsbuf, Stoich_Right); + + sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); + return strlen(buf); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMap() +{ +int i; +int dn; + + UseFile( mapFile ); + + WriteAll("### Options -------------------------------------------\n"); + NewLines(1); + if( useAggregate ) WriteAll("FUNCTION - AGGREGATE\n"); + else WriteAll("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: WriteAll("JACOBIAN - OFF\n"); break; + case JAC_FULL: WriteAll("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: WriteAll("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: WriteAll("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) WriteAll("DOUBLE - ON\n"); + else WriteAll("DOUBLE - OFF\n"); + if( useReorder ) WriteAll("REORDER - ON\n"); + else WriteAll("REORDER - OFF\n"); + NewLines(1); + + WriteAll("### Parameters ----------------------------------------\n"); + NewLines(1); + + VarStartNr = Index(0); + FixStartNr = Index(VarNr); + + DeclareConstant( NSPEC, ascii( SpcNr ) ); + DeclareConstant( NVAR, ascii( max( VarNr, 1 ) ) ); + DeclareConstant( NVARACT, ascii( max( VarActiveNr, 1 ) ) ); + DeclareConstant( NFIX, ascii( max( FixNr, 1 ) ) ); + DeclareConstant( NREACT, ascii( EqnNr ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + + NewLines(1); + WriteAll("### Species -------------------------------------------\n"); + + NewLines(1); + WriteAll("Variable species\n"); + + dn = VarNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i -= 2*dn; WriteAll("\n"); + } + + + NewLines(1); + WriteAll("Fixed species\n"); + + dn = FixNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i -= 2*dn; WriteAll("\n"); + } + + NewLines(1); + WriteAll("### Subroutines ---------------------------------------\n"); + NewLines(1); + FlushBuf(); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateInitialize() +{ +int i; +int I, X; +int INITVAL; + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) + UseFile( initFile ); + + INITVAL = DefFnc( "Initialize", 0, "function to initialize concentrations"); + FunctionBegin( INITVAL ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global\n", rootFileName); + MATLAB_Inline("global CFACTOR VAR FIX NVAR NFIX", rootFileName); + + I = DefElm( "i", INT, 0); + X = DefElm( "x", real, 0); + Declare( I ); + Declare( X ); + + NewLines(1); + WriteAssign( varTable[CFACTOR]->name , ascid( (double)cfactor ) ); + NewLines(1); + + Assign( Elm( X ), Mul( Elm( IV, varDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NVAR; i++ )" ); + F77_Inline(" DO i = 1, NVAR" ); + F90_Inline(" DO i = 1, NVAR" ); + MATLAB_Inline(" for i = 1:NVAR" ); + ident++; + Assign( Elm( VAR, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + Assign( Elm( X ), Mul( Elm( IV, fixDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NFIX; i++ )" ); + F77_Inline(" DO i = 1, NFIX" ); + F90_Inline(" DO i = 1, NFIX" ); + MATLAB_Inline(" for i = 1:NFIX" ); + ident++; + Assign( Elm( FIX, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + + for( i = 0; i < VarNr; i++) { + if( *SpeciesTable[ Code[i] ].ival == 0 ) continue; + Assign( Elm( VAR, i ), Mul( + Elm( IV, SpeciesTable[ Code[i] ].ival ), + Elm( CFACTOR ) ) ); + } + + + for( i = 0; i < FixNr; i++) { + if( *SpeciesTable[ Code[i + VarNr] ].ival == 0 ) continue; + Assign( Elm( FIX, i ), Mul( + Elm( IV, SpeciesTable[ Code[i + VarNr] ].ival ), + Elm( CFACTOR ) ) ); + } + +/* NewLines(1); + C_Inline(" for( i = 0; i < NSPEC; i++ )" ); + F77_Inline(" do i = 1, NSPEC" ); + ident++; + Assign( Elm( C_DEFAULT, -I ), Elm( C, -I ) ); + ident--; + F77_Inline(" end do" ); +*/ + + /* mz_rs_20050117+ */ + WriteComment("constant rate coefficients"); + for( i = 0; i < EqnNr; i++) { + if ( kr[i].type == NUMBER ) + Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); + } + WriteComment("END constant rate coefficients"); + /* mz_rs_20050117- */ + + NewLines(1); + WriteComment("INLINED initializations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_INIT ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_INIT ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_INIT ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_INIT ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED initializations"); + NewLines(1); + + MATLAB_Inline(" VAR = VAR(:);\n FIX = FIX(:);\n" ); + + FreeVariable( X ); + FreeVariable( I ); + FunctionEnd( INITVAL ); + FreeVariable( INITVAL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_user2kpp() +{ +int i,k,l; +int Shuffle_user2kpp; + + UseFile( utilFile ); + + Shuffle_user2kpp = DefFnc( "Shuffle_user2kpp", 2, "function to copy concentrations from USER to KPP"); + FunctionBegin( Shuffle_user2kpp, V_USER, V ); + + k = 0;l = 0; + for( i = 1; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) { + Assign( Elm( V, ReverseCode[i] ), Elm( V_USER, k++ ) ); + break; + } + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_user2kpp ); + FreeVariable( Shuffle_user2kpp ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_kpp2user() +{ +int i,k,l; +int Shuffle_kpp2user; + + UseFile( utilFile ); + + Shuffle_kpp2user = DefFnc( "Shuffle_kpp2user", 2, "function to restore concentrations from KPP to USER"); + FunctionBegin( Shuffle_kpp2user, V, V_USER ); + + k = 0; l = 0; + for( i = 0; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) + Assign( Elm( V_USER, k++ ), Elm( V, ReverseCode[i] ) ); + break; + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_kpp2user ); + FreeVariable( Shuffle_kpp2user ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGetMass() +{ +int i; +int atm, spc; +int GETMASS, MASS; +SPECIES_DEF *sp; +int numass; + + UseFile( utilFile ); + + nmass = 0; + for( atm = 0; atm < AtomNr; atm++ ) + if( AtomTable[atm].masscheck ) nmass++; + if( nmass == 0 ) nmass = 1; + + MASS = DefvElm( "Mass", real, nmass, "value of mass balance" ); + GETMASS = DefFnc( "GetMass", 2, "compute total mass of selected atoms"); + FunctionBegin( GETMASS, CL, MASS); + + numass = 0; + for( atm = 0; atm < AtomNr; atm++ ) { + if( AtomTable[atm].masscheck ) { + sum = Const( 0 ); + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + for( i = 0; i < sp->nratoms; i++ ) { + if( sp->atoms[i].code == atm ) { + sum = Add( sum, Mul( Const( sp->atoms[i].nr ), + Elm( CL, spc ) ) ); + } + } + } + Assign( Elm( MASS, numass ), sum ); + numass++; + } + } + + FunctionEnd( GETMASS ); + FreeVariable( GETMASS ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMakefile() +{ +char buf[100]; + + if ( useLang == MATLAB_LANG ) return; + + sprintf( buf, "Makefile_%s", rootFileName ); + makeFile = fopen(buf, "w"); + if( makeFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + + UseFile( makeFile ); + + IncludeCode( "%s/util/Makefile", Home ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMex() +{ +char buf[100], suffix[5]; + + if (useLang == MATLAB_LANG) return; + if (useMex == 0) return; + + switch( useLang ) { + case F77_LANG: sprintf( suffix, "f"); + break; + case F90_LANG: sprintf( suffix, "f90"); + break; + case C_LANG: sprintf( suffix, "c"); + break; + default: printf("\nCannot create mex files for language %d\n", useLang); + exit(1); + break; + } + + sprintf( buf, "%s_mex_Fun.%s", rootFileName, suffix ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Mex_Fun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_mex_Jac_SP.%s", rootFileName, suffix ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Mex_Jac_SP", Home ); + } + + if (useHessian) { + sprintf( buf, "%s_mex_Hessian.%s", rootFileName, suffix ); + mex_hessFile = fopen(buf, "w"); + if( mex_hessFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_hessFile ); + IncludeCode( "%s/util/Mex_Hessian", Home ); + } + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMatlabTemplates() +{ +char buf[200], suffix[5]; + + if (useLang != MATLAB_LANG) return; + + + sprintf( buf, "%s_Fun_Chem.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Template_Fun_Chem", Home ); + + sprintf( buf, "%s_Update_SUN.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/UpdateSun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_Jac_Chem.m", rootFileName ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Template_Jac_Chem", Home ); + } + + if (useHessian) { + } + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateF90Modules(char where) +{ +char buf[200]; + +if (useLang != F90_LANG) return; + +switch (where) { +case 'h': + + sprintf( buf, "%s_Precision.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("\nMODULE %s_Precision\n", rootFileName ); + F90_Inline("!"); + F90_Inline("! Definition of different levels of accuracy"); + F90_Inline("! for REAL variables using KIND parameterization"); + F90_Inline("!"); + F90_Inline("! KPP SP - Single precision kind"); + F90_Inline(" INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,30)"); + F90_Inline("! KPP DP - Double precision kind"); + F90_Inline(" INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,300)"); + F90_Inline("! KPP QP - Quadruple precision kind"); + F90_Inline(" INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(18,400)"); + F90_Inline("\nEND MODULE %s_Precision\n\n", rootFileName ); + + UseFile( initFile ); + F90_Inline("MODULE %s_Initialize\n", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + F90_Inline("CONTAINS\n\n"); + + UseFile( param_headerFile ); + F90_Inline("MODULE %s_Parameters\n", rootFileName ); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( global_dataFile ); + F90_Inline("MODULE %s_Global\n", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: dp, NSPEC, NVAR, NFIX, NREACT", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( functionFile ); + F90_Inline("MODULE %s_Function\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + Declare( A ); /* mz_rs_20050117 */ + F90_Inline("\nCONTAINS\n\n"); + + UseFile( rateFile ); + F90_Inline("MODULE %s_Rates\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("MODULE %s_Stochastic\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: NVAR, NFIX, NREACT", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("MODULE %s_JacobianSP\n", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + } + + UseFile( jacobianFile ); + F90_Inline("MODULE %s_Jacobian\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("MODULE %s_StoichiomSP\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( stoichiomFile ); + F90_Inline("MODULE %s_Stoichiom\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_StoichiomSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("MODULE %s_HessianSP\n", rootFileName); + /* F90_Inline(" USE %s_Precision", rootFileName ); */ /* mz_rs_20050321 */ + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( hessianFile ); + F90_Inline("MODULE %s_Hessian\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_HessianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + UseFile( monitorFile ); + F90_Inline("MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("MODULE %s_LinearAlgebra\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + /* mz_rs_20050511+ if( useJacSparse ) added */ + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + /* mz_rs_20050511- */ + /* mz_rs_20050321+ */ + /* if (useHessian) */ + /* F90_Inline(" USE %s_HessianSP\n", rootFileName); */ + /* mz_rs_20050321- */ + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + UseFile( utilFile ); + F90_Inline("MODULE %s_Util\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + /* Here we define the model module which aggregates everything */ + /* put module rootFileName_Model into separate file */ + /* (reusing "sparse_dataFile" as done above for _Precision file) */ + sprintf( buf, "%s_Model.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("MODULE %s_Model\n", rootFileName); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("! Completely defines the model %s", rootFileName); + F90_Inline("! by using all the associated modules"); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("\n USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" USE %s_Function", rootFileName ); + F90_Inline(" USE %s_Integrator", rootFileName ); + F90_Inline(" USE %s_Rates", rootFileName ); + if ( useStochastic ) + F90_Inline(" USE %s_Stochastic", rootFileName ); + if ( useJacobian ) + F90_Inline(" USE %s_Jacobian", rootFileName ); + if ( useHessian ) + F90_Inline(" USE %s_Hessian", rootFileName); + if ( useStoicmat ) + F90_Inline(" USE %s_Stoichiom", rootFileName); + F90_Inline(" USE %s_LinearAlgebra", rootFileName); + F90_Inline(" USE %s_Monitor", rootFileName); + F90_Inline(" USE %s_Util", rootFileName); + F90_Inline("\nEND MODULE %s_Model\n", rootFileName); + + /* mz_rs_20050518+ */ + /* UseFile( driverFile ); */ + /* WriteDelim(); */ + /* mz_rs_20050518- */ + + break; + +case 't': + + /* mz_rs_20050117+ */ + UseFile( initFile ); + F90_Inline("\nEND MODULE %s_Initialize\n", rootFileName ); + /* mz_rs_20050117- */ + + UseFile( param_headerFile ); + F90_Inline("\nEND MODULE %s_Parameters\n", rootFileName ); + + UseFile( global_dataFile ); + F90_Inline("\nEND MODULE %s_Global\n", rootFileName ); + + UseFile( functionFile ); + F90_Inline("\nEND MODULE %s_Function\n", rootFileName ); + + UseFile( rateFile ); + F90_Inline("\nEND MODULE %s_Rates\n", rootFileName ); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("\nEND MODULE %s_Stochastic\n", rootFileName); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("\nEND MODULE %s_JacobianSP\n", rootFileName); + } + + UseFile( jacobianFile ); + F90_Inline("\nEND MODULE %s_Jacobian\n", rootFileName ); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("\nEND MODULE %s_StoichiomSP\n", rootFileName); + + UseFile( stoichiomFile ); + F90_Inline("\nEND MODULE %s_Stoichiom\n", rootFileName); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("\nEND MODULE %s_HessianSP\n", rootFileName); + + UseFile( hessianFile ); + F90_Inline("\nEND MODULE %s_Hessian\n", rootFileName ); + } + + UseFile(monitorFile); + F90_Inline("\nEND MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("\nEND MODULE %s_LinearAlgebra\n", rootFileName); + + UseFile( utilFile ); + F90_Inline("\nEND MODULE %s_Util\n", rootFileName); + + break; + +default: + printf("\n Unrecognized option '%s' in GenerateF90Modules\n", where); + break; +} +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Generate() +{ +int i, j; +int n; + + VarStartNr = 0; + FixStartNr = VarNr; + + real = useDouble ? DOUBLE : REAL; + + n = MAX_OUTBUF; + for( i = 1; i < INLINE_OPT; i++ ) + if( InlineCode[i].maxlen > n ) + n = InlineCode[i].maxlen; + + outBuf = (char*)malloc( n ); + outBuffer = outBuf; + + switch( useLang ) { + case F77_LANG: Use_F( rootFileName ); + break; + case F90_LANG: Use_F90( rootFileName ); + break; + case C_LANG: Use_C( rootFileName ); + break; + case MATLAB_LANG: Use_MATLAB( rootFileName ); + break; + default: printf("\n Language no '%s' unknown\n",useLang ); + } + printf("\nKPP is initializing the code generation."); + InitGen(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('h'); + + GenerateMap(); + +/* if( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) +{*/ + printf("\nKPP is generating the monitor data:"); + printf("\n - %s_Monitor",rootFileName); + GenerateMonitorData(); +/* }*/ + + printf("\nKPP is generating the utility data:"); + printf("\n - %s_Util",rootFileName); + GenerateUtil(); + + printf("\nKPP is generating the global declarations:"); + printf("\n - %s_Main",rootFileName); + GenerateGData(); + + + printf("\nKPP is generating the ODE function:"); + printf("\n - %s_Function",rootFileName); + GenerateFun(); + + if ( useStochastic ) { + printf("\nKPP is generating the Stochastic description:"); + printf("\n - %s_Function",rootFileName); + GenerateStochastic(); + } + + if ( useJacobian ) { + printf("\nKPP is generating the ODE Jacobian:"); + printf("\n - %s_Jacobian\n - %s_JacobianSP",rootFileName,rootFileName); + GenerateJac(); + GenerateJacobianSparseData(); + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) { + GenerateJacVect(); + GenerateJacTRVect(); + if( useJacSparse ) { + printf("\nKPP is generating the linear algebra routines:"); + printf("\n - %s_LinearAlgebra",rootFileName); + GenerateSparseUtil(); + GenerateSolve(); + GenerateTRSolve(); + } + } + } + + GenerateBlas(); + + if( useHessian ) { + printf("\nKPP is generating the Hessian:"); + printf("\n - %s_Hessian\n - %s_HessianSP",rootFileName,rootFileName); + GenerateHessian(); + GenerateHessianSparseData(); + } + + printf("\nKPP is generating the utility functions:"); + printf("\n - %s_Util",rootFileName); + + GenerateInitialize(); + + GenerateShuffle_user2kpp(); + GenerateShuffle_kpp2user(); + + printf("\nKPP is generating the rate laws:"); + printf("\n - %s_Rates",rootFileName); + + GenerateRateLaws(); + GenerateUpdateSun(); + GenerateUpdateRconst(); + GenerateUpdatePhoto(); + GenerateGetMass(); + + + printf("\nKPP is generating the parameters:"); + printf("\n - %s_Parameters",rootFileName); + + GenerateParamHeader(); + + printf("\nKPP is generating the global data:"); + printf("\n - %s_Global",rootFileName); + + GenerateGlobalHeader(); + + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) { + printf("\nKPP is generating the sparsity data:"); + if( useJacSparse ) { + GenerateJacobianSparseHeader(); + printf("\n - %s_JacobianSP",rootFileName); + } + if( useHessian ) { + GenerateHessianSparseHeader(); + printf("\n - %s_HessianSP",rootFileName); + } + } + + if ( useStoicmat ) { + printf("\nKPP is generating the stoichiometric description files:"); + printf("\n - %s_Stoichiom\n - %s_StoichiomSP",rootFileName,rootFileName); + GenerateReactantProd(); + GenerateJacReactantProd(); + GenerateStoicmSparseData(); + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) + GenerateStoicmSparseHeader(); + GenerateDFunDRcoeff(); + GenerateDJacDRcoeff(); + } + + printf("\nKPP is generating the driver from %s.f90:", driver); + printf("\n - %s_Main",rootFileName); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateIntegrator(); + + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + GenerateDriver(); + /* mz_rs_20050518- */ + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMakefile(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('t'); + + if ( useLang == MATLAB_LANG ) + GenerateMatlabTemplates(); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMex(); + + /* mz_rs_20050117+ */ + if( initFile ) fclose( initFile ); + /* mz_rs_20050117- */ + if( driverFile ) fclose( driverFile ); + if( functionFile ) fclose( functionFile ); + if( global_dataFile ) fclose( global_dataFile ); + if( hessianFile ) fclose( hessianFile ); + if( integratorFile ) fclose( integratorFile ); + if( jacobianFile ) fclose( jacobianFile ); + if( linalgFile ) fclose( linalgFile ); + if( mapFile ) fclose( mapFile ); + if( makeFile ) fclose( makeFile ); + if( monitorFile ) fclose( monitorFile ); + if( mex_funFile ) fclose( mex_funFile ); + if( mex_jacFile ) fclose( mex_jacFile ); + if( mex_hessFile ) fclose( mex_hessFile ); + if( param_headerFile ) fclose( param_headerFile ); + if( rateFile ) fclose( rateFile ); + if( sparse_dataFile ) fclose( sparse_dataFile ); + if( sparse_jacFile ) fclose( sparse_jacFile ); + if( sparse_hessFile ) fclose( sparse_hessFile ); + if( sparse_stoicmFile ) fclose( sparse_stoicmFile ); + if( stoichiomFile ) fclose( stoichiomFile ); + if( utilFile ) fclose( utilFile ); + if( stochasticFile ) fclose( stochasticFile ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int* AllocIntegerVector(int n, char* message) +{ +int* vec; +if ( ( vec=(int*)calloc(n,sizeof(int)) ) == NULL ) + FatalError(-30,"%s: Cannot allocate vector.",message); +return vec; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/* Allocates a matrix of integers */ +int** AllocIntegerMatrix(int m, int n, char* message) +{ +int** mat; +int i; +if ( (mat = (int**)calloc(m,sizeof(int*)))==NULL ) { + FatalError(-30,"%s: Cannot allocate matrix.", message); + } +for (i=0; i +#include +#include "gdata.h" +#include "scan.h" + +char *eqFileName; +char *rootFileName = "ff"; +char Home[ MAX_PATH ] = ""; + +short int linStru[ MAX_SPECIES ]; +short int colStru[ MAX_SPECIES ]; +short int bestStru[ MAX_SPECIES ]; +short int *Stru; + +enum stru_criteria { UNSORT, LINSORT, COLSORT, BESTSORT }; + +void EqCopy( EQ_VECT e1, EQ_VECT e2 ) +{ +int i; + + for( i = 0; i < EqnNr; i++ ) e2[i] = e1[i]; +} + +int NoSort( const void *p1, const void *p2 ) +{ + return -1; +} + +int CodeCmp( const void *p1, const void *p2 ) +{ +CODE *c1, *c2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + if ( *c1 < *c2 ) return -1; + if ( *c1 > *c2 ) return 1; + return 0; +} + +int CodeRCmp( const void *p1, const void *p2 ) +{ +int rc1, rc2; +CODE *c1, *c2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + rc1 = Reactive[ ReverseCode[ *c1 ] ]; + rc2 = Reactive[ ReverseCode[ *c2 ] ]; + if ( rc1 > rc2 ) return -1; + if ( rc1 < rc2 ) return 1; + if ( *c1 < *c2 ) return -1; + if ( *c1 > *c2 ) return 1; + return 0; +} + +int CodeSSCmp( const void *p1, const void *p2 ) +{ + return -CodeRCmp(p1,p2); +} + +int CodeSCmp( const void *p1, const void *p2 ) +{ +CODE *c1, *c2; +short int sc1, sc2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + sc1 = Stru[ ReverseCode[ *c1 ] ]; + sc2 = Stru[ ReverseCode[ *c2 ] ]; + + if ( sc1 > sc2 ) return 1; + if ( sc1 < sc2 ) return -1; + if ( *c1 < *c2 ) return 1; + if ( *c1 > *c2 ) return -1; + return 0; +} + +void UpdateStructJ() +{ +int i,j,k; + + for ( i=0; i j) nl++; + if(i <= j) nu++; + } + + return nu+nl; +} + +int LUnonZero() +{ +CODE v[MAX_SPECIES]; +CODE *var; +int i,j,k; +int nu,nl; + + var = v; + if( Stru != bestStru ) { + for( i=0; i tmp; mv tmp %s_Update_RCONST.m;", + root, root, root ); + system( buf ); + } + +/* Postprocessing to replace parameter names by values in the declarations + strcpy( cmd, "sed " ); + sprintf( cmd, "%s -e 's/(NVAR)/(%d)/g'", cmd, VarNr ); + sprintf( cmd, "%s -e 's/(NFIX)/(%d)/g'", cmd, FixNr ); + sprintf( cmd, "%s -e 's/(NSPEC)/(%d)/g'", cmd,SpcNr ); + sprintf( cmd, "%s -e 's/(NREACT)/(%d)/g'", cmd, EqnNr ); + sprintf( cmd, "%s -e 's/(NONZERO)/(%d)/g'", cmd, Jac_NZ ); + sprintf( cmd, "%s -e 's/(LU_NONZERO)/(%d)/g'", cmd, LU_Jac_NZ ); + sprintf( cmd, "%s -e 's/(NHESS)/(%)/g'", cmd, Hess_NZ ); + + sprintf( buf, "%s_Function", rootFileName ); + switch( useLang ) { + case F77_LANG: sprintf( buf, "%s.f", buf ); + break; + case F90_LANG: sprintf( buf, "%s.f90", buf ); + break; + case C_LANG: sprintf( buf, "%s.c", buf ); + break; + case MATLAB_LANG: sprintf( buf, "%s.m", buf ); + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + sprintf( cmdexe, "%s %s > %s; mv %s %s;", cmd, buf, tmpfile, tmpfile, buf ); + printf("\n\nCMDEXE='%s'\n",cmdexe); + system( cmdexe ); +*/ +} + +/*******************************************************************/ +int main( int argc, char * argv[] ) +{ +int status; +char name[ 200 ]; +char *p; +int i,j; + + AllocInternalArrays(); + + p = getenv("KPP_HOME"); + if( p ) strcpy( Home, p ); + + switch( argc ) { + case 3: eqFileName = argv[1]; + rootFileName = argv[2]; + break; + case 2: eqFileName = argv[1]; + strcpy( name, eqFileName ); + p = name + strlen(name); + while( p > name ) { + if( *p == '.') { + *p = '\0'; + break; + } + p--; + } + rootFileName = name; + break; + default: FatalError(1,"\nUsage :" + "\n kpp [output file]\n"); + } + + printf("\nThis is KPP-%s.\n", KPP_VERSION); + + printf("\nKPP is parsing the equation file."); + status = ParseEquationFile( argv[1] ); + + if( status ) FatalError(2,"%d errors and %d warnings encountered.", + nError, nWarning ); + /* Allocate some internal data structures */ + AllocStructArrays(); + + printf("\nKPP is computing Jacobian sparsity structure."); + ReorderSpecies( UNSORT ); + if (useReorder==1){ + BestSparsity(); + ReorderSpecies( BESTSORT ); + } + UpdateStructJ(); + ComputeLUStructJ(); + + if( initNr == -1 ) initNr = VarNr; + + + printf("\nKPP is starting the code generation."); + Generate( rootFileName ); + + printf("\nKPP is starting the code post-processing."); + Postprocess( rootFileName ); + + printf("\n\nKPP has succesfully created the model \"%s\".\n\n",rootFileName); + + if( nError ) exit(4); + if( nWarning ) exit(5); + + exit(0); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/lex.yy.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/lex.yy.c new file mode 100755 index 00000000..c33b6073 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/lex.yy.c @@ -0,0 +1,2405 @@ +/* A lexical scanner generated by flex */ + +/* Scanner skeleton version: + * $Header: /home/daffy/u0/vern/flex/RCS/flex.skl,v 2.91 96/09/10 16:58:48 vern Exp $ + */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 + +#include + + +/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ +#ifdef c_plusplus +#ifndef __cplusplus +#define __cplusplus +#endif +#endif + + +#ifdef __cplusplus + +#include +#include + +/* Use prototypes in function declarations. */ +#define YY_USE_PROTOS + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +#if __STDC__ + +#define YY_USE_PROTOS +#define YY_USE_CONST + +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ + +#ifdef __TURBOC__ + #pragma warn -rch + #pragma warn -use +#include +#include +#define YY_USE_CONST +#define YY_USE_PROTOS +#endif + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + + +#ifdef YY_USE_PROTOS +#define YY_PROTO(proto) proto +#else +#define YY_PROTO(proto) () +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN yy_start = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START ((yy_start - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart( yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#define YY_BUF_SIZE 16384 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +extern int yyleng; +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + +/* The funky do-while in the following #define is used to turn the definition + * int a single C statement (which needs a semi-colon terminator). This + * avoids problems with code like: + * + * if ( condition_holds ) + * yyless( 5 ); + * else + * do_something_else(); + * + * Prior to using the do-while the compiler would get upset at the + * "else" because it interpreted the "if" statement as being all + * done when it reached the ';' after the yyless() call. + */ + +/* Return all but the first 'n' matched characters back to the input stream. */ + +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + *yy_cp = yy_hold_char; \ + YY_RESTORE_YY_MORE_OFFSET \ + yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, yytext_ptr ) + +/* The following is because we cannot portably get our hands on size_t + * (without autoconf's help, which isn't available because we want + * flex-generated scanners to compile on their own). + */ +typedef unsigned int yy_size_t; + + +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + }; + +static YY_BUFFER_STATE yy_current_buffer = 0; + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + */ +#define YY_CURRENT_BUFFER yy_current_buffer + + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; + +static int yy_n_chars; /* number of characters read into yy_ch_buf */ + + +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 1; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart YY_PROTO(( FILE *input_file )); + +void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); +void yy_load_buffer_state YY_PROTO(( void )); +YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); +void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); +void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); +void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b )); +#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer ) + +YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size )); +YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *yy_str )); +YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len )); + +static void *yy_flex_alloc YY_PROTO(( yy_size_t )); +static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t )); +static void yy_flex_free YY_PROTO(( void * )); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (yy_current_buffer->yy_at_bol) + +typedef unsigned char YY_CHAR; +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; +typedef int yy_state_type; +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state YY_PROTO(( void )); +static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); +static int yy_get_next_buffer YY_PROTO(( void )); +static void yy_fatal_error YY_PROTO(( yyconst char msg[] )); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + yytext_ptr = yy_bp; \ + yyleng = (int) (yy_cp - yy_bp); \ + yy_hold_char = *yy_cp; \ + *yy_cp = '\0'; \ + yy_c_buf_p = yy_cp; + +#define YY_NUM_RULES 58 +#define YY_END_OF_BUFFER 59 +static yyconst short int yy_accept[199] = + { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 19, 19, 0, 0, 29, 29, 33, 33, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 5, 5, 7, 7, 0, 0, 57, 57, + 59, 58, 1, 9, 2, 58, 3, 10, 10, 11, + 11, 12, 12, 13, 13, 14, 14, 23, 1, 9, + 21, 23, 19, 22, 20, 18, 3, 25, 24, 30, + 1, 9, 30, 29, 30, 29, 28, 27, 26, 26, + 3, 35, 33, 33, 34, 36, 32, 31, 31, 37, + + 38, 39, 39, 40, 45, 1, 9, 42, 45, 43, + 44, 41, 3, 15, 15, 17, 16, 47, 46, 54, + 54, 53, 52, 49, 48, 50, 50, 51, 5, 1, + 2, 5, 3, 6, 7, 1, 8, 2, 7, 3, + 57, 56, 55, 1, 4, 10, 4, 11, 4, 12, + 4, 13, 4, 14, 4, 19, 18, 24, 29, 29, + 0, 29, 29, 26, 0, 26, 33, 0, 33, 33, + 31, 0, 31, 37, 39, 4, 41, 15, 4, 16, + 46, 54, 4, 52, 48, 50, 4, 5, 1, 4, + 7, 1, 4, 57, 55, 29, 33, 0 + + } ; + +static yyconst int yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 1, 4, 1, 1, 1, 1, 1, + 1, 1, 5, 1, 6, 7, 8, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 10, 11, 12, + 13, 14, 1, 1, 15, 15, 15, 15, 16, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 1, 1, 1, 1, 15, 1, 15, 15, 15, 15, + + 16, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 17, 1, 18, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst int yy_meta[19] = + { 0, + 1, 2, 3, 4, 5, 5, 1, 1, 6, 1, + 7, 1, 1, 1, 8, 8, 7, 9 + } ; + +static yyconst short int yy_base[237] = + { 0, + 0, 16, 32, 49, 66, 83, 100, 117, 134, 151, + 168, 185, 203, 0, 211, 217, 233, 0, 247, 0, + 255, 0, 270, 287, 305, 0, 322, 339, 0, 0, + 347, 353, 359, 365, 380, 397, 405, 411, 417, 423, + 438, 455, 472, 489, 506, 522, 0, 0, 2, 6, + 88, 842, 80, 842, 842, 73, 842, 0, 72, 0, + 71, 0, 70, 0, 68, 0, 67, 842, 71, 842, + 842, 64, 62, 842, 842, 0, 842, 842, 0, 842, + 63, 842, 55, 5, 55, 533, 842, 842, 0, 545, + 842, 842, 6, 555, 842, 842, 842, 0, 567, 0, + + 842, 0, 54, 842, 842, 59, 842, 842, 51, 842, + 842, 0, 842, 0, 50, 842, 0, 842, 0, 0, + 48, 842, 0, 842, 0, 0, 47, 842, 0, 52, + 0, 40, 0, 842, 0, 45, 842, 0, 38, 0, + 0, 842, 0, 43, 842, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 35, 0, 0, 0, 7, + 33, 16, 0, 0, 32, 30, 21, 20, 22, 0, + 0, 19, 18, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 0, + 0, 11, 0, 0, 0, 3, 2, 842, 583, 592, + + 601, 610, 619, 628, 637, 646, 655, 664, 673, 682, + 691, 700, 708, 716, 724, 732, 735, 738, 741, 744, + 747, 755, 758, 766, 769, 772, 780, 783, 786, 794, + 802, 810, 819, 828, 833, 835 + } ; + +static yyconst short int yy_def[237] = + { 0, + 199, 199, 200, 200, 201, 201, 202, 202, 203, 203, + 204, 204, 198, 13, 2, 2, 198, 17, 2, 19, + 2, 21, 205, 205, 198, 25, 206, 206, 2, 2, + 2, 2, 2, 2, 207, 207, 2, 2, 2, 2, + 208, 208, 209, 209, 210, 210, 2, 2, 211, 211, + 198, 198, 198, 198, 198, 198, 198, 212, 212, 213, + 213, 214, 214, 215, 215, 216, 216, 198, 198, 198, + 198, 198, 198, 198, 198, 217, 198, 198, 218, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 219, 198, + 198, 198, 198, 198, 198, 198, 198, 220, 198, 221, + + 198, 222, 222, 198, 198, 198, 198, 198, 198, 198, + 198, 223, 198, 224, 224, 198, 225, 198, 226, 227, + 227, 198, 228, 198, 229, 230, 230, 198, 231, 231, + 231, 231, 231, 198, 232, 232, 198, 232, 232, 232, + 233, 198, 234, 198, 198, 212, 212, 213, 213, 214, + 214, 215, 215, 216, 216, 198, 217, 218, 86, 198, + 235, 198, 86, 219, 198, 219, 198, 236, 198, 94, + 220, 198, 220, 221, 222, 222, 223, 224, 224, 225, + 226, 227, 227, 228, 229, 230, 230, 231, 231, 231, + 232, 232, 232, 233, 234, 198, 198, 0, 198, 198, + + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198 + } ; + +static yyconst short int yy_nxt[861] = + { 0, + 198, 53, 54, 55, 142, 143, 198, 56, 142, 143, + 197, 196, 192, 160, 167, 160, 57, 53, 54, 55, + 161, 168, 161, 56, 160, 189, 173, 197, 197, 167, + 167, 161, 57, 53, 54, 55, 168, 168, 166, 59, + 196, 196, 52, 156, 144, 193, 192, 190, 57, 52, + 53, 54, 55, 189, 187, 183, 59, 179, 145, 52, + 144, 176, 145, 159, 144, 57, 52, 53, 54, 55, + 156, 145, 144, 61, 155, 153, 52, 151, 149, 147, + 145, 144, 57, 52, 53, 54, 55, 198, 198, 198, + 61, 198, 198, 52, 198, 198, 198, 198, 198, 57, + + 52, 53, 54, 55, 198, 198, 198, 63, 198, 198, + 52, 198, 198, 198, 198, 198, 57, 52, 53, 54, + 55, 198, 198, 198, 63, 198, 198, 52, 198, 198, + 198, 198, 198, 57, 52, 53, 54, 55, 198, 198, + 198, 65, 198, 198, 52, 198, 198, 198, 198, 198, + 57, 52, 53, 54, 55, 198, 198, 198, 65, 198, + 198, 52, 198, 198, 198, 198, 198, 57, 52, 53, + 54, 55, 198, 198, 198, 67, 198, 198, 52, 198, + 198, 198, 198, 198, 57, 52, 53, 54, 55, 198, + 198, 198, 67, 198, 198, 52, 198, 198, 198, 198, + + 198, 57, 52, 68, 69, 70, 55, 71, 68, 68, + 72, 73, 68, 74, 68, 75, 68, 76, 76, 77, + 68, 78, 198, 198, 198, 79, 79, 78, 198, 198, + 198, 79, 79, 80, 81, 82, 55, 83, 83, 84, + 85, 86, 80, 87, 80, 88, 80, 89, 90, 91, + 80, 92, 92, 93, 198, 94, 95, 198, 96, 97, + 198, 98, 99, 100, 198, 198, 198, 198, 101, 100, + 100, 53, 54, 55, 198, 198, 198, 103, 198, 198, + 104, 198, 198, 198, 198, 198, 57, 52, 53, 54, + 55, 198, 198, 198, 103, 198, 198, 104, 198, 198, + + 198, 198, 198, 57, 52, 105, 106, 107, 55, 108, + 105, 105, 109, 105, 110, 111, 105, 105, 105, 112, + 112, 113, 105, 53, 54, 55, 198, 198, 198, 115, + 198, 198, 52, 198, 198, 198, 198, 198, 57, 52, + 53, 54, 55, 198, 198, 198, 115, 198, 198, 52, + 198, 198, 198, 198, 198, 57, 52, 116, 198, 198, + 198, 117, 117, 116, 198, 198, 198, 117, 117, 118, + 198, 198, 198, 119, 119, 118, 198, 198, 198, 119, + 119, 53, 54, 55, 198, 198, 198, 121, 198, 198, + 52, 198, 198, 198, 198, 198, 57, 52, 53, 54, + + 55, 198, 198, 198, 121, 198, 198, 52, 198, 198, + 198, 198, 198, 57, 52, 122, 198, 198, 198, 123, + 123, 122, 198, 198, 198, 123, 123, 124, 198, 198, + 198, 125, 125, 124, 198, 198, 198, 125, 125, 53, + 54, 55, 198, 198, 198, 127, 198, 198, 128, 198, + 198, 198, 198, 198, 57, 52, 53, 54, 55, 198, + 198, 198, 127, 198, 198, 128, 198, 198, 198, 198, + 198, 57, 52, 130, 54, 131, 198, 198, 198, 132, + 198, 198, 198, 198, 198, 198, 198, 198, 133, 134, + 130, 54, 131, 198, 198, 198, 132, 198, 198, 198, + + 198, 198, 198, 198, 198, 133, 134, 136, 137, 138, + 198, 198, 198, 139, 198, 198, 198, 198, 198, 198, + 198, 198, 140, 136, 137, 138, 198, 198, 198, 139, + 198, 198, 198, 198, 198, 198, 198, 198, 140, 162, + 198, 163, 198, 198, 198, 198, 198, 198, 161, 165, + 165, 198, 198, 166, 198, 198, 198, 198, 198, 164, + 164, 169, 198, 170, 198, 198, 198, 198, 198, 198, + 168, 172, 172, 198, 198, 173, 198, 198, 198, 198, + 198, 171, 171, 52, 52, 52, 52, 52, 52, 52, + 52, 52, 58, 58, 58, 58, 58, 58, 58, 58, + + 58, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 62, 62, 62, 62, 62, 62, 62, 62, 62, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 126, 126, 126, 126, 126, 126, + 126, 126, 126, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 135, 135, 135, 135, 135, 135, 135, 135, + 135, 141, 141, 141, 141, 141, 141, 141, 141, 141, + + 146, 198, 198, 198, 146, 146, 198, 146, 148, 198, + 198, 198, 148, 148, 198, 148, 150, 198, 198, 198, + 150, 150, 198, 150, 152, 198, 198, 198, 152, 152, + 198, 152, 154, 198, 198, 198, 154, 154, 198, 154, + 157, 198, 157, 158, 198, 158, 164, 198, 164, 171, + 198, 171, 174, 198, 174, 175, 198, 198, 198, 175, + 175, 198, 175, 177, 198, 177, 178, 198, 198, 198, + 178, 178, 198, 178, 180, 198, 180, 181, 198, 181, + 182, 198, 198, 198, 182, 182, 198, 182, 184, 198, + 184, 185, 198, 185, 186, 198, 198, 198, 186, 186, + + 198, 186, 188, 188, 198, 188, 188, 188, 188, 188, + 191, 191, 198, 191, 191, 191, 191, 191, 191, 194, + 194, 198, 198, 194, 194, 194, 194, 194, 195, 198, + 198, 195, 195, 195, 195, 195, 195, 165, 165, 172, + 172, 51, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198 + } ; + +static yyconst short int yy_chk[861] = + { 0, + 0, 1, 1, 1, 49, 49, 0, 1, 50, 50, + 197, 196, 192, 84, 93, 160, 1, 2, 2, 2, + 84, 93, 160, 2, 162, 189, 173, 172, 168, 167, + 169, 162, 2, 3, 3, 3, 167, 169, 166, 3, + 165, 161, 3, 156, 144, 139, 136, 132, 3, 3, + 4, 4, 4, 130, 127, 121, 4, 115, 109, 4, + 106, 103, 85, 83, 81, 4, 4, 5, 5, 5, + 73, 72, 69, 5, 67, 65, 5, 63, 61, 59, + 56, 53, 5, 5, 6, 6, 6, 51, 0, 0, + 6, 0, 0, 6, 0, 0, 0, 0, 0, 6, + + 6, 7, 7, 7, 0, 0, 0, 7, 0, 0, + 7, 0, 0, 0, 0, 0, 7, 7, 8, 8, + 8, 0, 0, 0, 8, 0, 0, 8, 0, 0, + 0, 0, 0, 8, 8, 9, 9, 9, 0, 0, + 0, 9, 0, 0, 9, 0, 0, 0, 0, 0, + 9, 9, 10, 10, 10, 0, 0, 0, 10, 0, + 0, 10, 0, 0, 0, 0, 0, 10, 10, 11, + 11, 11, 0, 0, 0, 11, 0, 0, 11, 0, + 0, 0, 0, 0, 11, 11, 12, 12, 12, 0, + 0, 0, 12, 0, 0, 12, 0, 0, 0, 0, + + 0, 12, 12, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 15, 0, 0, 0, 15, 15, 16, 0, 0, + 0, 16, 16, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 19, 19, 19, 0, 19, 19, 0, 19, 19, + 0, 19, 19, 21, 0, 0, 0, 0, 21, 21, + 21, 23, 23, 23, 0, 0, 0, 23, 0, 0, + 23, 0, 0, 0, 0, 0, 23, 23, 24, 24, + 24, 0, 0, 0, 24, 0, 0, 24, 0, 0, + + 0, 0, 0, 24, 24, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 27, 27, 27, 0, 0, 0, 27, + 0, 0, 27, 0, 0, 0, 0, 0, 27, 27, + 28, 28, 28, 0, 0, 0, 28, 0, 0, 28, + 0, 0, 0, 0, 0, 28, 28, 31, 0, 0, + 0, 31, 31, 32, 0, 0, 0, 32, 32, 33, + 0, 0, 0, 33, 33, 34, 0, 0, 0, 34, + 34, 35, 35, 35, 0, 0, 0, 35, 0, 0, + 35, 0, 0, 0, 0, 0, 35, 35, 36, 36, + + 36, 0, 0, 0, 36, 0, 0, 36, 0, 0, + 0, 0, 0, 36, 36, 37, 0, 0, 0, 37, + 37, 38, 0, 0, 0, 38, 38, 39, 0, 0, + 0, 39, 39, 40, 0, 0, 0, 40, 40, 41, + 41, 41, 0, 0, 0, 41, 0, 0, 41, 0, + 0, 0, 0, 0, 41, 41, 42, 42, 42, 0, + 0, 0, 42, 0, 0, 42, 0, 0, 0, 0, + 0, 42, 42, 43, 43, 43, 0, 0, 0, 43, + 0, 0, 0, 0, 0, 0, 0, 0, 43, 43, + 44, 44, 44, 0, 0, 0, 44, 0, 0, 0, + + 0, 0, 0, 0, 0, 44, 44, 45, 45, 45, + 0, 0, 0, 45, 0, 0, 0, 0, 0, 0, + 0, 0, 45, 46, 46, 46, 0, 0, 0, 46, + 0, 0, 0, 0, 0, 0, 0, 0, 46, 86, + 0, 86, 0, 0, 0, 0, 0, 0, 86, 90, + 90, 0, 0, 90, 0, 0, 0, 0, 0, 90, + 90, 94, 0, 94, 0, 0, 0, 0, 0, 0, + 94, 99, 99, 0, 0, 99, 0, 0, 0, 0, + 0, 99, 99, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 200, 200, 200, 200, 200, 200, 200, 200, + + 200, 201, 201, 201, 201, 201, 201, 201, 201, 201, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 204, 204, + 204, 204, 204, 204, 204, 204, 204, 205, 205, 205, + 205, 205, 205, 205, 205, 205, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 208, 208, 208, 208, 208, 208, + 208, 208, 208, 209, 209, 209, 209, 209, 209, 209, + 209, 209, 210, 210, 210, 210, 210, 210, 210, 210, + 210, 211, 211, 211, 211, 211, 211, 211, 211, 211, + + 212, 0, 0, 0, 212, 212, 0, 212, 213, 0, + 0, 0, 213, 213, 0, 213, 214, 0, 0, 0, + 214, 214, 0, 214, 215, 0, 0, 0, 215, 215, + 0, 215, 216, 0, 0, 0, 216, 216, 0, 216, + 217, 0, 217, 218, 0, 218, 219, 0, 219, 220, + 0, 220, 221, 0, 221, 222, 0, 0, 0, 222, + 222, 0, 222, 223, 0, 223, 224, 0, 0, 0, + 224, 224, 0, 224, 225, 0, 225, 226, 0, 226, + 227, 0, 0, 0, 227, 227, 0, 227, 228, 0, + 228, 229, 0, 229, 230, 0, 0, 0, 230, 230, + + 0, 230, 231, 231, 0, 231, 231, 231, 231, 231, + 232, 232, 0, 232, 232, 232, 232, 232, 232, 233, + 233, 0, 0, 233, 233, 233, 233, 233, 234, 0, + 0, 234, 234, 234, 234, 234, 234, 235, 235, 236, + 236, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "scan.l" +#define INITIAL 0 +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ +#define CMD_STATE 1 +#define INC_STATE 2 +#define MOD_STATE 3 +#define INT_STATE 4 + +#define PRM_STATE 5 +#define DSP_STATE 6 +#define SSP_STATE 7 +#define INI_STATE 8 +#define EQN_STATE 9 +#define EQNTAG_STATE 10 + +#define RATE_STATE 11 +#define LMP_STATE 12 +#define CR_IGNORE 13 +#define SC_IGNORE 14 +#define ATM_STATE 15 +#define LKT_STATE 16 +#define INL_STATE 17 + +#define MNI_STATE 18 +#define TPT_STATE 19 +#define USE_STATE 20 + +#define COMMENT 21 +#define COMMENT2 22 +#define EQN_ID 23 + +#define INL_CODE 24 + +#line 42 "scan.l" + #include "gdata.h" + #include "scan.h" + #include "y.tab.h" + + void Include ( char * filename ); + int EndInclude(); + + int crt_line_no = 1; + char *crt_filename; + + #define MAX_INCLUDE 10 + + YY_BUFFER_STATE yy_buffers[ MAX_INCLUDE ]; + int yy_line_no[ MAX_INCLUDE ]; + char *yy_filename[ MAX_INCLUDE ]; + int yy_buf_level = 0; + + char crtToken[100]; + char nextToken[100]; + int crtTokType; + int nextTokType; + int crtLine; + char crtFile[100]; + char crt_rate[100]; + + int oldnErr = 0; + + int idx; + int oldstate; + extern int yyerrflag; + + typedef struct { + char *name; + int next; + int cmd; + } KEYWORD; + + KEYWORD keywords[] = { { "INCLUDE", INC_STATE, 0 }, + { "MODEL", MOD_STATE, 0 }, + { "INTEGRATOR", INT_STATE, 0 }, + { "JACOBIAN", PRM_STATE, JACOBIAN }, + { "HESSIAN", PRM_STATE, HESSIAN }, + { "STOICMAT", PRM_STATE, STOICMAT }, + { "STOCHASTIC", PRM_STATE, STOCHASTIC }, + { "DOUBLE", PRM_STATE, DOUBLE }, + { "REORDER", PRM_STATE, REORDER }, + { "MEX", PRM_STATE, MEX }, + { "DUMMYINDEX", PRM_STATE, DUMMYINDEX}, + { "EQNTAGS", PRM_STATE, EQNTAGS}, + { "FUNCTION", PRM_STATE, FUNCTION }, + { "ATOMS", ATM_STATE, ATOMDECL }, + { "CHECK", ATM_STATE, CHECK }, + { "CHECKALL", INITIAL, CHECKALL }, + { "DEFVAR", DSP_STATE, DEFVAR }, + { "DEFRAD", DSP_STATE, DEFRAD }, + { "DEFFIX", DSP_STATE, DEFFIX }, + { "SETVAR", SSP_STATE, SETVAR }, + { "SETRAD", SSP_STATE, SETRAD }, + { "SETFIX", SSP_STATE, SETFIX }, + { "INITVALUES", INI_STATE, INITVALUES }, + { "EQUATIONS", EQN_STATE, EQUATIONS }, + { "LUMP", LMP_STATE, LUMP }, + { "LOOKAT", LKT_STATE, LOOKAT }, + { "LOOKATALL", INITIAL, LOOKATALL }, + { "TRANSPORT", TPT_STATE, TRANSPORT }, + { "TRANSPORTALL", INITIAL, TRANSPORTALL }, + { "INITIALIZE", PRM_STATE, INITIALIZE }, + { "XGRID", PRM_STATE, XGRID }, + { "YGRID", PRM_STATE, YGRID }, + { "ZGRID", PRM_STATE, ZGRID }, + { "MONITOR", MNI_STATE, MONITOR }, + { "WRITE_ATM", INITIAL, WRITE_ATM }, + { "WRITE_SPC", INITIAL, WRITE_SPC }, + { "WRITE_MAT", INITIAL, WRITE_MAT }, + { "WRITE_OPT", INITIAL, WRITE_OPT }, + { "USE", PRM_STATE, USE }, + { "LANGUAGE", PRM_STATE, LANGUAGE }, + { "INLINE", INL_STATE, INLINE }, + { "ENDINLINE", INITIAL, ENDINLINE }, + { "INTFILE", PRM_STATE, INTFILE }, + { "DRIVER", PRM_STATE, DRIVER }, + { "RUN", PRM_STATE, RUN }, + { "USES", USE_STATE, USES }, + { "SPARSEDATA", PRM_STATE, SPARSEDATA }, + { 0, 0, 0 } + }; + + int CheckKeyword( char *cmd ); + +#define RETURN( x ) \ + if(1) { \ + if ( yyerrflag == 0) { \ + strcpy( crtToken, nextToken ); \ + crtTokType = nextTokType; \ + crtLine = crt_line_no; \ + strcpy( crtFile, crt_filename ); \ + } \ + strcpy( nextToken, yytext); \ + nextTokType = x; \ + return (x); \ + } +#line 783 "lex.yy.c" + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap YY_PROTO(( void )); +#else +extern int yywrap YY_PROTO(( void )); +#endif +#endif + +#ifndef YY_NO_UNPUT +static void yyunput YY_PROTO(( int c, char *buf_ptr )); +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int )); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen YY_PROTO(( yyconst char * )); +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus +static int yyinput YY_PROTO(( void )); +#else +static int input YY_PROTO(( void )); +#endif +#endif + +#if YY_STACK_USED +static int yy_start_stack_ptr = 0; +static int yy_start_stack_depth = 0; +static int *yy_start_stack = 0; +#ifndef YY_NO_PUSH_STATE +static void yy_push_state YY_PROTO(( int new_state )); +#endif +#ifndef YY_NO_POP_STATE +static void yy_pop_state YY_PROTO(( void )); +#endif +#ifndef YY_NO_TOP_STATE +static int yy_top_state YY_PROTO(( void )); +#endif + +#else +#define YY_NO_PUSH_STATE 1 +#define YY_NO_POP_STATE 1 +#define YY_NO_TOP_STATE 1 +#endif + +#ifdef YY_MALLOC_DECL +YY_MALLOC_DECL +#else +#if __STDC__ +#ifndef __cplusplus +#include +#endif +#else +/* Just try to get by without declaring the routines. This will fail + * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) + * or sizeof(void*) != sizeof(int). + */ +#endif +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ + +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( yy_current_buffer->yy_is_interactive ) \ + { \ + int c = '*', n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ + && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL int yylex YY_PROTO(( void )) +#endif + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +YY_DECL + { + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 164 "scan.l" + +#line 936 "lex.yy.c" + + if ( yy_init ) + { + yy_init = 0; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! yy_start ) + yy_start = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! yy_current_buffer ) + yy_current_buffer = + yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_load_buffer_state(); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = yy_c_buf_p; + + /* Support of yytext. */ + *yy_cp = yy_hold_char; + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = yy_start; +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 842 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + +do_action: /* This label is used only to access EOF actions. */ + + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = yy_hold_char; + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + goto yy_find_action; + +case 1: +YY_RULE_SETUP +#line 165 "scan.l" +{ + } + YY_BREAK +case 2: +YY_RULE_SETUP +#line 167 "scan.l" +{ BEGIN CMD_STATE; + } + YY_BREAK +case 3: +YY_RULE_SETUP +#line 169 "scan.l" +{ oldstate = (yy_start - 1) / 2; + BEGIN COMMENT; + } + YY_BREAK +case 4: +YY_RULE_SETUP +#line 172 "scan.l" +{ oldstate = (yy_start - 1) / 2; + BEGIN COMMENT2; + } + YY_BREAK +case 5: +YY_RULE_SETUP +#line 175 "scan.l" +{ + } + YY_BREAK +case 6: +YY_RULE_SETUP +#line 177 "scan.l" +{ BEGIN oldstate; + } + YY_BREAK +case 7: +YY_RULE_SETUP +#line 179 "scan.l" +{ + } + YY_BREAK +case 8: +YY_RULE_SETUP +#line 181 "scan.l" +{ crt_line_no++; + BEGIN oldstate; + } + YY_BREAK +case 9: +YY_RULE_SETUP +#line 184 "scan.l" +{ crt_line_no++; + } + YY_BREAK +case 10: +YY_RULE_SETUP +#line 186 "scan.l" +{ idx = CheckKeyword( yytext ); + if ( idx < 0 ) { + BEGIN CR_IGNORE; + break; + } + BEGIN keywords[idx].next; + if ( keywords[idx].cmd ) { + crt_section = keywords[idx].cmd; + RETURN( keywords[idx].cmd ); + } + } + YY_BREAK +case 11: +YY_RULE_SETUP +#line 197 "scan.l" +{ Include( IncName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 200 "scan.l" +{ Include( ModelName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 13: +YY_RULE_SETUP +#line 203 "scan.l" +{ Include( IntegName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 206 "scan.l" +{ strcpy( yylval.str, yytext ); + BEGIN CR_IGNORE; + RETURN( PARAMETER ); + } + YY_BREAK +case 15: +YY_RULE_SETUP +#line 210 "scan.l" +{ ScanError("Extra parameter on command line '%s'", yytext); + } + YY_BREAK +case 16: +YY_RULE_SETUP +#line 212 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( ATOMID ); + } + YY_BREAK +case 17: +YY_RULE_SETUP +#line 215 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 18: +YY_RULE_SETUP +#line 217 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SPCSPC ); + } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 220 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SPCNR ); + } + YY_BREAK +case 20: +YY_RULE_SETUP +#line 223 "scan.l" +{ RETURN( SPCEQUAL ); + } + YY_BREAK +case 21: +YY_RULE_SETUP +#line 225 "scan.l" +{ RETURN( SPCPLUS ); + } + YY_BREAK +case 22: +YY_RULE_SETUP +#line 227 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 23: +YY_RULE_SETUP +#line 229 "scan.l" +{ ScanError("Invalid character '%c' in species definition", yytext[0] ); + } + YY_BREAK +case 24: +YY_RULE_SETUP +#line 231 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SSPID ); + } + YY_BREAK +case 25: +YY_RULE_SETUP +#line 234 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 26: +YY_RULE_SETUP +#line 236 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( INISPC ); + } + YY_BREAK +case 27: +YY_RULE_SETUP +#line 239 "scan.l" +{ RETURN( INIEQUAL ); + } + YY_BREAK +case 28: +YY_RULE_SETUP +#line 241 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 29: +YY_RULE_SETUP +#line 243 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( INIVALUE ); + } + YY_BREAK +case 30: +YY_RULE_SETUP +#line 246 "scan.l" +{ ScanError("Invalid character '%c' in initial values", yytext[0] ); + } + YY_BREAK +case 31: +YY_RULE_SETUP +#line 248 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNSPC ); + } + YY_BREAK +case 32: +YY_RULE_SETUP +#line 251 "scan.l" +{ RETURN( EQNEQUAL ); + } + YY_BREAK +case 33: +YY_RULE_SETUP +#line 253 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNCOEF ); + } + YY_BREAK +case 34: +YY_RULE_SETUP +#line 256 "scan.l" +{ BEGIN RATE_STATE; + *crt_rate = 0; + RETURN( EQNCOLON ); + } + YY_BREAK +case 35: +YY_RULE_SETUP +#line 260 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNSIGN ); + } + YY_BREAK +case 36: +YY_RULE_SETUP +#line 263 "scan.l" +{ BEGIN EQNTAG_STATE; + RETURN( EQNLESS ); + } + YY_BREAK +case 37: +YY_RULE_SETUP +#line 266 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNTAG ); + } + YY_BREAK +case 38: +YY_RULE_SETUP +#line 269 "scan.l" +{ BEGIN EQN_STATE; + RETURN( EQNGREATER ); + } + YY_BREAK +case 39: +YY_RULE_SETUP +#line 272 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( RATE ); + } + YY_BREAK +case 40: +YY_RULE_SETUP +#line 275 "scan.l" +{ BEGIN EQN_STATE; + RETURN( yytext[0] ); + } + YY_BREAK +case 41: +YY_RULE_SETUP +#line 278 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( LMPSPC ); + } + YY_BREAK +case 42: +YY_RULE_SETUP +#line 281 "scan.l" +{ RETURN( LMPPLUS ); + } + YY_BREAK +case 43: +YY_RULE_SETUP +#line 283 "scan.l" +{ RETURN( LMPCOLON ); + } + YY_BREAK +case 44: +YY_RULE_SETUP +#line 285 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 45: +YY_RULE_SETUP +#line 287 "scan.l" +{ ScanError("Invalid character '%c' in species definition", yytext[0] ); + } + YY_BREAK +case 46: +YY_RULE_SETUP +#line 289 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( LKTID ); + } + YY_BREAK +case 47: +YY_RULE_SETUP +#line 292 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 48: +YY_RULE_SETUP +#line 294 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( TPTID ); + } + YY_BREAK +case 49: +YY_RULE_SETUP +#line 297 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 50: +YY_RULE_SETUP +#line 299 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( USEID ); + } + YY_BREAK +case 51: +YY_RULE_SETUP +#line 302 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 52: +YY_RULE_SETUP +#line 304 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( MNIID ); + } + YY_BREAK +case 53: +YY_RULE_SETUP +#line 307 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 54: +YY_RULE_SETUP +#line 309 "scan.l" +{ strcpy( yylval.str, yytext ); + BEGIN INL_CODE; + RETURN( INLCTX ); + } + YY_BREAK +case 55: +YY_RULE_SETUP +#line 313 "scan.l" +{ if ( EqNoCase( yytext+1, "ENDINLINE" ) ){ + BEGIN INITIAL; + RETURN( ENDINLINE ); + } + else { + strcpy( yylval.str, yytext ); + RETURN( INCODE ); + } + } + YY_BREAK +case 56: +YY_RULE_SETUP +#line 322 "scan.l" +{ crt_line_no++; + strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } + YY_BREAK +case 57: +YY_RULE_SETUP +#line 326 "scan.l" +{ strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } + YY_BREAK +case YY_STATE_EOF(INITIAL): +case YY_STATE_EOF(CMD_STATE): +case YY_STATE_EOF(INC_STATE): +case YY_STATE_EOF(MOD_STATE): +case YY_STATE_EOF(INT_STATE): +case YY_STATE_EOF(PRM_STATE): +case YY_STATE_EOF(DSP_STATE): +case YY_STATE_EOF(SSP_STATE): +case YY_STATE_EOF(INI_STATE): +case YY_STATE_EOF(EQN_STATE): +case YY_STATE_EOF(EQNTAG_STATE): +case YY_STATE_EOF(RATE_STATE): +case YY_STATE_EOF(LMP_STATE): +case YY_STATE_EOF(CR_IGNORE): +case YY_STATE_EOF(SC_IGNORE): +case YY_STATE_EOF(ATM_STATE): +case YY_STATE_EOF(LKT_STATE): +case YY_STATE_EOF(INL_STATE): +case YY_STATE_EOF(MNI_STATE): +case YY_STATE_EOF(TPT_STATE): +case YY_STATE_EOF(USE_STATE): +case YY_STATE_EOF(COMMENT): +case YY_STATE_EOF(COMMENT2): +case YY_STATE_EOF(EQN_ID): +case YY_STATE_EOF(INL_CODE): +#line 329 "scan.l" +{ if ( ! EndInclude() ) { + RETURN( INITIAL ); + } + } + YY_BREAK +case 58: +YY_RULE_SETUP +#line 333 "scan.l" +ECHO; + YY_BREAK +#line 1447 "lex.yy.c" + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = yy_hold_char; + YY_RESTORE_YY_MORE_OFFSET + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between yy_current_buffer and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + yy_n_chars = yy_current_buffer->yy_n_chars; + yy_current_buffer->yy_input_file = yyin; + yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = yytext_ptr + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++yy_c_buf_p; + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = yy_c_buf_p; + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + yy_did_buffer_switch_on_eof = 0; + + if ( yywrap() ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = + yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + yy_c_buf_p = + &yy_current_buffer->yy_ch_buf[yy_n_chars]; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of yylex */ + + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ + +static int yy_get_next_buffer() + { + register char *dest = yy_current_buffer->yy_ch_buf; + register char *source = yytext_ptr; + register int number_to_move, i; + int ret_val; + + if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( yy_current_buffer->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + yy_current_buffer->yy_n_chars = yy_n_chars = 0; + + else + { + int num_to_read = + yy_current_buffer->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ +#ifdef YY_USES_REJECT + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); +#else + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = yy_current_buffer; + + int yy_c_buf_p_offset = + (int) (yy_c_buf_p - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + int new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yy_flex_realloc( (void *) b->yy_ch_buf, + b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = yy_current_buffer->yy_buf_size - + number_to_move - 1; +#endif + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), + yy_n_chars, num_to_read ); + + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + if ( yy_n_chars == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + yy_current_buffer->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + yy_n_chars += number_to_move; + yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; + yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; + + yytext_ptr = &yy_current_buffer->yy_ch_buf[0]; + + return ret_val; + } + + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +static yy_state_type yy_get_previous_state() + { + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = yy_start; + + for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; + } + + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + +#ifdef YY_USE_PROTOS +static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) +#else +static yy_state_type yy_try_NUL_trans( yy_current_state ) +yy_state_type yy_current_state; +#endif + { + register int yy_is_jam; + register char *yy_cp = yy_c_buf_p; + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 198); + + return yy_is_jam ? 0 : yy_current_state; + } + + +#ifndef YY_NO_UNPUT +#ifdef YY_USE_PROTOS +static void yyunput( int c, register char *yy_bp ) +#else +static void yyunput( c, yy_bp ) +int c; +register char *yy_bp; +#endif + { + register char *yy_cp = yy_c_buf_p; + + /* undo effects of setting up yytext */ + *yy_cp = yy_hold_char; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = yy_n_chars + 2; + register char *dest = &yy_current_buffer->yy_ch_buf[ + yy_current_buffer->yy_buf_size + 2]; + register char *source = + &yy_current_buffer->yy_ch_buf[number_to_move]; + + while ( source > yy_current_buffer->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + yy_current_buffer->yy_n_chars = + yy_n_chars = yy_current_buffer->yy_buf_size; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + + yytext_ptr = yy_bp; + yy_hold_char = *yy_cp; + yy_c_buf_p = yy_cp; + } +#endif /* ifndef YY_NO_UNPUT */ + + +#ifdef __cplusplus +static int yyinput() +#else +static int input() +#endif + { + int c; + + *yy_c_buf_p = yy_hold_char; + + if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + /* This was really a NUL. */ + *yy_c_buf_p = '\0'; + + else + { /* need more input */ + int offset = yy_c_buf_p - yytext_ptr; + ++yy_c_buf_p; + + switch ( yy_get_next_buffer() ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart( yyin ); + + /* fall through */ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap() ) + return EOF; + + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = yytext_ptr + offset; + break; + } + } + } + + c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ + *yy_c_buf_p = '\0'; /* preserve yytext */ + yy_hold_char = *++yy_c_buf_p; + + + return c; + } + + +#ifdef YY_USE_PROTOS +void yyrestart( FILE *input_file ) +#else +void yyrestart( input_file ) +FILE *input_file; +#endif + { + if ( ! yy_current_buffer ) + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_init_buffer( yy_current_buffer, input_file ); + yy_load_buffer_state(); + } + + +#ifdef YY_USE_PROTOS +void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) +#else +void yy_switch_to_buffer( new_buffer ) +YY_BUFFER_STATE new_buffer; +#endif + { + if ( yy_current_buffer == new_buffer ) + return; + + if ( yy_current_buffer ) + { + /* Flush out information for old buffer. */ + *yy_c_buf_p = yy_hold_char; + yy_current_buffer->yy_buf_pos = yy_c_buf_p; + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + yy_current_buffer = new_buffer; + yy_load_buffer_state(); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + yy_did_buffer_switch_on_eof = 1; + } + + +#ifdef YY_USE_PROTOS +void yy_load_buffer_state( void ) +#else +void yy_load_buffer_state() +#endif + { + yy_n_chars = yy_current_buffer->yy_n_chars; + yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; + yyin = yy_current_buffer->yy_input_file; + yy_hold_char = *yy_c_buf_p; + } + + +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) +#else +YY_BUFFER_STATE yy_create_buffer( file, size ) +FILE *file; +int size; +#endif + { + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer( b, file ); + + return b; + } + + +#ifdef YY_USE_PROTOS +void yy_delete_buffer( YY_BUFFER_STATE b ) +#else +void yy_delete_buffer( b ) +YY_BUFFER_STATE b; +#endif + { + if ( ! b ) + return; + + if ( b == yy_current_buffer ) + yy_current_buffer = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yy_flex_free( (void *) b->yy_ch_buf ); + + yy_flex_free( (void *) b ); + } + + +#ifndef YY_ALWAYS_INTERACTIVE +#ifndef YY_NEVER_INTERACTIVE +extern int isatty YY_PROTO(( int )); +#endif +#endif + +#ifdef YY_USE_PROTOS +void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) +#else +void yy_init_buffer( b, file ) +YY_BUFFER_STATE b; +FILE *file; +#endif + + + { + yy_flush_buffer( b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + +#if YY_ALWAYS_INTERACTIVE + b->yy_is_interactive = 1; +#else +#if YY_NEVER_INTERACTIVE + b->yy_is_interactive = 0; +#else + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; +#endif +#endif + } + + +#ifdef YY_USE_PROTOS +void yy_flush_buffer( YY_BUFFER_STATE b ) +#else +void yy_flush_buffer( b ) +YY_BUFFER_STATE b; +#endif + + { + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == yy_current_buffer ) + yy_load_buffer_state(); + } + + +#ifndef YY_NO_SCAN_BUFFER +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size ) +#else +YY_BUFFER_STATE yy_scan_buffer( base, size ) +char *base; +yy_size_t size; +#endif + { + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer( b ); + + return b; + } +#endif + + +#ifndef YY_NO_SCAN_STRING +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_string( yyconst char *yy_str ) +#else +YY_BUFFER_STATE yy_scan_string( yy_str ) +yyconst char *yy_str; +#endif + { + int len; + for ( len = 0; yy_str[len]; ++len ) + ; + + return yy_scan_bytes( yy_str, len ); + } +#endif + + +#ifndef YY_NO_SCAN_BYTES +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len ) +#else +YY_BUFFER_STATE yy_scan_bytes( bytes, len ) +yyconst char *bytes; +int len; +#endif + { + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = len + 2; + buf = (char *) yy_flex_alloc( n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < len; ++i ) + buf[i] = bytes[i]; + + buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer( buf, n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; + } +#endif + + +#ifndef YY_NO_PUSH_STATE +#ifdef YY_USE_PROTOS +static void yy_push_state( int new_state ) +#else +static void yy_push_state( new_state ) +int new_state; +#endif + { + if ( yy_start_stack_ptr >= yy_start_stack_depth ) + { + yy_size_t new_size; + + yy_start_stack_depth += YY_START_STACK_INCR; + new_size = yy_start_stack_depth * sizeof( int ); + + if ( ! yy_start_stack ) + yy_start_stack = (int *) yy_flex_alloc( new_size ); + + else + yy_start_stack = (int *) yy_flex_realloc( + (void *) yy_start_stack, new_size ); + + if ( ! yy_start_stack ) + YY_FATAL_ERROR( + "out of memory expanding start-condition stack" ); + } + + yy_start_stack[yy_start_stack_ptr++] = YY_START; + + BEGIN(new_state); + } +#endif + + +#ifndef YY_NO_POP_STATE +static void yy_pop_state() + { + if ( --yy_start_stack_ptr < 0 ) + YY_FATAL_ERROR( "start-condition stack underflow" ); + + BEGIN(yy_start_stack[yy_start_stack_ptr]); + } +#endif + + +#ifndef YY_NO_TOP_STATE +static int yy_top_state() + { + return yy_start_stack[yy_start_stack_ptr - 1]; + } +#endif + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +#ifdef YY_USE_PROTOS +static void yy_fatal_error( yyconst char msg[] ) +#else +static void yy_fatal_error( msg ) +char msg[]; +#endif + { + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); + } + + + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + yytext[yyleng] = yy_hold_char; \ + yy_c_buf_p = yytext + n; \ + yy_hold_char = *yy_c_buf_p; \ + *yy_c_buf_p = '\0'; \ + yyleng = n; \ + } \ + while ( 0 ) + + +/* Internal utility routines. */ + +#ifndef yytext_ptr +#ifdef YY_USE_PROTOS +static void yy_flex_strncpy( char *s1, yyconst char *s2, int n ) +#else +static void yy_flex_strncpy( s1, s2, n ) +char *s1; +yyconst char *s2; +int n; +#endif + { + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; + } +#endif + +#ifdef YY_NEED_STRLEN +#ifdef YY_USE_PROTOS +static int yy_flex_strlen( yyconst char *s ) +#else +static int yy_flex_strlen( s ) +yyconst char *s; +#endif + { + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; + } +#endif + + +#ifdef YY_USE_PROTOS +static void *yy_flex_alloc( yy_size_t size ) +#else +static void *yy_flex_alloc( size ) +yy_size_t size; +#endif + { + return (void *) malloc( size ); + } + +#ifdef YY_USE_PROTOS +static void *yy_flex_realloc( void *ptr, yy_size_t size ) +#else +static void *yy_flex_realloc( ptr, size ) +void *ptr; +yy_size_t size; +#endif + { + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); + } + +#ifdef YY_USE_PROTOS +static void yy_flex_free( void *ptr ) +#else +static void yy_flex_free( ptr ) +void *ptr; +#endif + { + free( ptr ); + } + +#if YY_MAIN +int main() + { + yylex(); + return 0; + } +#endif +#line 333 "scan.l" + + +void Include ( char * name ) +{ +FILE *f; +YY_BUFFER_STATE newb; + + if ( yy_buf_level == MAX_INCLUDE ) { + printf("\nInclude nested too deep. Include %s ignored", name); + return; + } + + yy_buffers[ yy_buf_level ] = yy_current_buffer; + yy_line_no[ yy_buf_level ] = crt_line_no; + yy_filename[ yy_buf_level ] = crt_filename; + yy_buf_level++; + + crt_line_no = 1; + + crt_filename = malloc( 1 + strlen( name ) ); + strcpy( crt_filename, name ); + + + f = fopen( name, "r" ); + if( f == 0 ) + FatalError(3,"%s: Can't read file", name ); + + newb = yy_create_buffer(f, YY_BUF_SIZE); + yy_switch_to_buffer( newb ); +} + +int EndInclude() +{ +YY_BUFFER_STATE oldb; +char * oldn; + + if ( yy_buf_level > 0 ) { + oldb = yy_current_buffer; + oldn = crt_filename; + yy_buf_level--; + yy_switch_to_buffer( yy_buffers[yy_buf_level] ); + crt_line_no = yy_line_no[ yy_buf_level ]; + crt_filename = yy_filename[ yy_buf_level ]; + yy_delete_buffer( oldb ); + free( oldn ); + return 1; + } + return 0; +} + +int EqNoCase( char *s1, char *s2 ) +{ + while( *s1 ) { + if ( toupper(*s1++) != toupper(*s2++) ) return 0; + } + return *s1 == *s2; +} + +int CheckKeyword( char *cmd ) +{ +int i; + + i = 0; + while( 1 ) { + if( keywords[i].name == 0 ) { + ScanError( "'%s': Unknown command (ignored)", cmd); + return -1; + } + if( EqNoCase( cmd, keywords[i].name ) ) { + return i; + } + i++; + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.h new file mode 100755 index 00000000..1f5fdc62 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.h @@ -0,0 +1,103 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +#ifndef _SCAN_H_ +#define _SCAN_H_ + +#include +#include "gdef.h" + +/* mz_rs_20050518+ value increased */ +#define MAX_INLINE 10000 +/* #define MAX_INLINE 4000 */ +/* mz_rs_20050518- */ + +enum eq_state { LHS, RHS, RAT }; +enum sptypes { DUMMY_SPC, VAR_SPC, RAD_SPC, FIX_SPC }; +enum atomcheck { NO_CHECK, DO_CHECK, CANCEL_CHECK }; +enum codetype { APPEND, REPLACE }; + +typedef struct { + int key; + int type; + char * kname; + } INLINE_KEY; + +extern int eqState; +extern int isPhoto; +extern int crt_line_no; +extern char *crt_filename; +extern int crtLine; +extern char crtFile[]; +extern char crtToken[]; +extern char nextToken[]; +extern int crtTokType; +extern int nextTokType; +extern int nError; +extern int nWarning; +extern int crt_section; + +int Parser( char * filename ); +void ScanError( char *fmt, ... ); +void ParserError( char *fmt, ... ); +void ScanWarning( char *fmt, ... ); +void ParserWarning( char *fmt, ... ); +void Error( char *fmt, ... ); +void Warning( char *fmt, ... ); +void Message( char *fmt, ... ); +void FatalError( int status, char *fmt, ... ); + +void DeclareAtom( char *atname ); +void SetAtomType( char *atname, int type ); +void AddAtom( char *atname, char *nr ); +void DeclareSpecies( int type, char* spname ); +void SetSpcType( int type, char *spname ); +void AssignInitialValue( char *spname , char *spval ); +void StoreEquationRate( char *rate, char *label ); +void CheckEquation(); +void ProcessTerm( int side, char *sign, char *coef, char *spname ); +void AddLumpSpecies( char *spname ); +void CheckLump( char *spname ); +void AddLookAt( char *spname ); +void AddMonitor( char *spname ); +void AddTransport( char *spname ); + +void WriteAtoms(); +void WriteSpecies(); +void WriteMatrices(); +void WriteOptions(); + +char * AppendString( char * s1, char * s2, int * len, int addlen ); +void AddInlineCode( char * context, char * code ); + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.l b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.l new file mode 100755 index 00000000..36b2d279 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.l @@ -0,0 +1,407 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +%s CMD_STATE INC_STATE MOD_STATE INT_STATE +%s PRM_STATE DSP_STATE SSP_STATE INI_STATE EQN_STATE EQNTAG_STATE +%s RATE_STATE LMP_STATE CR_IGNORE SC_IGNORE ATM_STATE LKT_STATE INL_STATE +%s MNI_STATE TPT_STATE USE_STATE +%s COMMENT COMMENT2 EQN_ID +%x INL_CODE + +%{ + #include "gdata.h" + #include "scan.h" + #include "y.tab.h" + + void Include ( char * filename ); + int EndInclude(); + + int crt_line_no = 1; + char *crt_filename; + + #define MAX_INCLUDE 10 + + YY_BUFFER_STATE yy_buffers[ MAX_INCLUDE ]; + int yy_line_no[ MAX_INCLUDE ]; + char *yy_filename[ MAX_INCLUDE ]; + int yy_buf_level = 0; + + char crtToken[100]; + char nextToken[100]; + int crtTokType; + int nextTokType; + int crtLine; + char crtFile[100]; + char crt_rate[100]; + + int oldnErr = 0; + + int idx; + int oldstate; + extern int yyerrflag; + + typedef struct { + char *name; + int next; + int cmd; + } KEYWORD; + + KEYWORD keywords[] = { { "INCLUDE", INC_STATE, 0 }, + { "MODEL", MOD_STATE, 0 }, + { "INTEGRATOR", INT_STATE, 0 }, + { "JACOBIAN", PRM_STATE, JACOBIAN }, + { "HESSIAN", PRM_STATE, HESSIAN }, + { "STOICMAT", PRM_STATE, STOICMAT }, + { "STOCHASTIC", PRM_STATE, STOCHASTIC }, + { "DOUBLE", PRM_STATE, DOUBLE }, + { "REORDER", PRM_STATE, REORDER }, + { "MEX", PRM_STATE, MEX }, + { "DUMMYINDEX", PRM_STATE, DUMMYINDEX}, + { "EQNTAGS", PRM_STATE, EQNTAGS}, + { "FUNCTION", PRM_STATE, FUNCTION }, + { "ATOMS", ATM_STATE, ATOMDECL }, + { "CHECK", ATM_STATE, CHECK }, + { "CHECKALL", INITIAL, CHECKALL }, + { "DEFVAR", DSP_STATE, DEFVAR }, + { "DEFRAD", DSP_STATE, DEFRAD }, + { "DEFFIX", DSP_STATE, DEFFIX }, + { "SETVAR", SSP_STATE, SETVAR }, + { "SETRAD", SSP_STATE, SETRAD }, + { "SETFIX", SSP_STATE, SETFIX }, + { "INITVALUES", INI_STATE, INITVALUES }, + { "EQUATIONS", EQN_STATE, EQUATIONS }, + { "LUMP", LMP_STATE, LUMP }, + { "LOOKAT", LKT_STATE, LOOKAT }, + { "LOOKATALL", INITIAL, LOOKATALL }, + { "TRANSPORT", TPT_STATE, TRANSPORT }, + { "TRANSPORTALL", INITIAL, TRANSPORTALL }, + { "INITIALIZE", PRM_STATE, INITIALIZE }, + { "XGRID", PRM_STATE, XGRID }, + { "YGRID", PRM_STATE, YGRID }, + { "ZGRID", PRM_STATE, ZGRID }, + { "MONITOR", MNI_STATE, MONITOR }, + { "WRITE_ATM", INITIAL, WRITE_ATM }, + { "WRITE_SPC", INITIAL, WRITE_SPC }, + { "WRITE_MAT", INITIAL, WRITE_MAT }, + { "WRITE_OPT", INITIAL, WRITE_OPT }, + { "USE", PRM_STATE, USE }, + { "LANGUAGE", PRM_STATE, LANGUAGE }, + { "INLINE", INL_STATE, INLINE }, + { "ENDINLINE", INITIAL, ENDINLINE }, + { "INTFILE", PRM_STATE, INTFILE }, + { "DRIVER", PRM_STATE, DRIVER }, + { "RUN", PRM_STATE, RUN }, + { "USES", USE_STATE, USES }, + { "SPARSEDATA", PRM_STATE, SPARSEDATA }, + { 0, 0, 0 } + }; + + int CheckKeyword( char *cmd ); + +#define RETURN( x ) \ + if(1) { \ + if ( yyerrflag == 0) { \ + strcpy( crtToken, nextToken ); \ + crtTokType = nextTokType; \ + crtLine = crt_line_no; \ + strcpy( crtFile, crt_filename ); \ + } \ + strcpy( nextToken, yytext); \ + nextTokType = x; \ + return (x); \ + } +%} + + +BT [ \t] +SPACE [ \t] +CR [\n] +TAG [a-zA-Z_0-9]+ +STRING [^ \t\n{}#;]+ + +LIT [a-zA-Z_] +CIF [0-9] + +IDSPC {LIT}[a-zA-Z_0-9]* + +NR {CIF}* +NRS [+-]?{CIF}+ +REAL {NRS}?"."?{NR} +UREAL {NR}?"."?{NR} +FLOAT {REAL}([eE]{NRS})? +UFLOAT {UREAL}([eE]{NRS})? + +%% +{SPACE}+ { + } +# { BEGIN CMD_STATE; + } +\{ { oldstate = (yy_start - 1) / 2; + BEGIN COMMENT; + } +\/\/ { oldstate = (yy_start - 1) / 2; + BEGIN COMMENT2; + } +[^\}\n]* { + } +\} { BEGIN oldstate; + } +[^\n]* { + } +{CR} { crt_line_no++; + BEGIN oldstate; + } +{CR} { crt_line_no++; + } +{STRING} { idx = CheckKeyword( yytext ); + if ( idx < 0 ) { + BEGIN CR_IGNORE; + break; + } + BEGIN keywords[idx].next; + if ( keywords[idx].cmd ) { + crt_section = keywords[idx].cmd; + RETURN( keywords[idx].cmd ); + } + } +{STRING} { Include( IncName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { Include( ModelName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { Include( IntegName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { strcpy( yylval.str, yytext ); + BEGIN CR_IGNORE; + RETURN( PARAMETER ); + } +{STRING} { ScanError("Extra parameter on command line '%s'", yytext); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( ATOMID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( SPCSPC ); + } +{NR} { strcpy( yylval.str, yytext ); + RETURN( SPCNR ); + } +[=] { RETURN( SPCEQUAL ); + } +[+] { RETURN( SPCPLUS ); + } +; { RETURN( yytext[0] ); + } +[^;#] { ScanError("Invalid character '%c' in species definition", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( SSPID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( INISPC ); + } +[=] { RETURN( INIEQUAL ); + } +; { RETURN( yytext[0] ); + } +{FLOAT} { strcpy( yylval.str, yytext ); + RETURN( INIVALUE ); + } +[^=;#] { ScanError("Invalid character '%c' in initial values", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( EQNSPC ); + } +[=] { RETURN( EQNEQUAL ); + } +{UFLOAT} { strcpy( yylval.str, yytext ); + RETURN( EQNCOEF ); + } +[:] { BEGIN RATE_STATE; + *crt_rate = 0; + RETURN( EQNCOLON ); + } +[+-] { strcpy( yylval.str, yytext ); + RETURN( EQNSIGN ); + } +[<] { BEGIN EQNTAG_STATE; + RETURN( EQNLESS ); + } +{TAG} { strcpy( yylval.str, yytext ); + RETURN( EQNTAG ); + } +[>] { BEGIN EQN_STATE; + RETURN( EQNGREATER ); + } +{STRING} { strcpy( yylval.str, yytext ); + RETURN( RATE ); + } +; { BEGIN EQN_STATE; + RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( LMPSPC ); + } +[+] { RETURN( LMPPLUS ); + } +[:] { RETURN( LMPCOLON ); + } +; { RETURN( yytext[0] ); + } +[^;#] { ScanError("Invalid character '%c' in species definition", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( LKTID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( TPTID ); + } +; { RETURN( yytext[0] ); + } +{STRING} { strcpy( yylval.str, yytext ); + RETURN( USEID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( MNIID ); + } +; { RETURN( yytext[0] ); + } +{STRING} { strcpy( yylval.str, yytext ); + BEGIN INL_CODE; + RETURN( INLCTX ); + } +#[^ \t\n]* { if ( EqNoCase( yytext+1, "ENDINLINE" ) ){ + BEGIN INITIAL; + RETURN( ENDINLINE ); + } + else { + strcpy( yylval.str, yytext ); + RETURN( INCODE ); + } + } +\n { crt_line_no++; + strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } +[^#\n]* { strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } +<> { if ( ! EndInclude() ) { + RETURN( INITIAL ); + } + } +%% + +void Include ( char * name ) +{ +FILE *f; +YY_BUFFER_STATE newb; + + if ( yy_buf_level == MAX_INCLUDE ) { + printf("\nInclude nested too deep. Include %s ignored", name); + return; + } + + yy_buffers[ yy_buf_level ] = yy_current_buffer; + yy_line_no[ yy_buf_level ] = crt_line_no; + yy_filename[ yy_buf_level ] = crt_filename; + yy_buf_level++; + + crt_line_no = 1; + + crt_filename = malloc( 1 + strlen( name ) ); + strcpy( crt_filename, name ); + + + f = fopen( name, "r" ); + if( f == 0 ) + FatalError(3,"%s: Can't read file", name ); + + newb = yy_create_buffer(f, YY_BUF_SIZE); + yy_switch_to_buffer( newb ); +} + +int EndInclude() +{ +YY_BUFFER_STATE oldb; +char * oldn; + + if ( yy_buf_level > 0 ) { + oldb = yy_current_buffer; + oldn = crt_filename; + yy_buf_level--; + yy_switch_to_buffer( yy_buffers[yy_buf_level] ); + crt_line_no = yy_line_no[ yy_buf_level ]; + crt_filename = yy_filename[ yy_buf_level ]; + yy_delete_buffer( oldb ); + free( oldn ); + return 1; + } + return 0; +} + +int EqNoCase( char *s1, char *s2 ) +{ + while( *s1 ) { + if ( toupper(*s1++) != toupper(*s2++) ) return 0; + } + return *s1 == *s2; +} + +int CheckKeyword( char *cmd ) +{ +int i; + + i = 0; + while( 1 ) { + if( keywords[i].name == 0 ) { + ScanError( "'%s': Unknown command (ignored)", cmd); + return -1; + } + if( EqNoCase( cmd, keywords[i].name ) ) { + return i; + } + i++; + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.y b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.y new file mode 100755 index 00000000..b861c6c1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scan.y @@ -0,0 +1,488 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +%{ + #include + #include + #include + #include + #include + #include "scan.h" + + #define __YYSCLASS + + #define YYDEBUG 1 + extern char yytext[]; + extern FILE * yyin; + + int nError = 0; + int nWarning = 0; + + int crt_section; + int eqState; + int isPhoto = 0; + + char crt_term[ 30 ]; + char crt_coef[ 30 ]; + + char * InlineBuf; + int InlineLen; + + void SemicolonError(); + extern int yyerrflag; + +%} + +%union{ + char str[80]; +}; + +%token JACOBIAN DOUBLE FUNCTION DEFVAR DEFRAD DEFFIX SETVAR SETRAD SETFIX +%token HESSIAN STOICMAT STOCHASTIC +%token INITVALUES EQUATIONS LUMP INIEQUAL EQNEQUAL EQNCOLON +%token LMPCOLON LMPPLUS SPCPLUS SPCEQUAL ATOMDECL CHECK CHECKALL REORDER +%token MEX DUMMYINDEX EQNTAGS +%token LOOKAT LOOKATALL TRANSPORT TRANSPORTALL MONITOR USES SPARSEDATA +%token WRFCONFORM +%token WRITE_ATM WRITE_SPC WRITE_MAT WRITE_OPT INITIALIZE XGRID YGRID ZGRID +%token USE LANGUAGE INTFILE DRIVER RUN INLINE ENDINLINE +%token PARAMETER SPCSPC INISPC INIVALUE EQNSPC EQNSIGN EQNCOEF +%type PARAMETER SPCSPC INISPC INIVALUE EQNSPC EQNSIGN EQNCOEF +%token RATE LMPSPC SPCNR ATOMID LKTID MNIID INLCTX INCODE SSPID +%type RATE LMPSPC SPCNR ATOMID LKTID MNIID INLCTX INCODE SSPID +%token EQNLESS EQNTAG EQNGREATER +%type EQNLESS EQNTAG EQNGREATER +%token TPTID USEID +%type TPTID USEID +%type rate eqntag + +%% + +program : section + | section program + ; +section : JACOBIAN PARAMETER + { CmdJacobian( $2 ); + } + | HESSIAN PARAMETER + { CmdHessian( $2 ); + } + | STOICMAT PARAMETER + { CmdStoicmat( $2 ); + } + | DOUBLE PARAMETER + { CmdDouble( $2 ); + } + | REORDER PARAMETER + { CmdReorder( $2 ); + } + | MEX PARAMETER + { CmdMex( $2 ); + } + | DUMMYINDEX PARAMETER + { CmdDummyindex( $2 ); + } + | EQNTAGS PARAMETER + { CmdEqntags( $2 ); + } + | FUNCTION PARAMETER + { CmdFunction( $2 ); + } + | STOCHASTIC PARAMETER + { CmdStochastic( $2 ); + } + | ATOMDECL atomlist + {} + | CHECK atomlist + {} + | DEFVAR species + {} + | DEFRAD species + {} + | DEFFIX species + {} + | SETVAR setspclist + {} + | SETRAD setspclist + {} + | SETFIX setspclist + {} + | INITVALUES initvalues + {} + | EQUATIONS equations + {} + | LUMP lumps + {} + | LOOKAT lookatlist + {} + | MONITOR monitorlist + {} + | TRANSPORT translist + {} + | CHECKALL + { CheckAll(); } + | LOOKATALL + { LookAtAll(); } + | TRANSPORTALL + { TransportAll(); } + | WRITE_ATM + { WriteAtoms(); } + | WRITE_SPC + { WriteSpecies(); } + | WRITE_MAT + { WriteMatrices(); } + | WRITE_OPT + { WriteOptions(); } + | USE PARAMETER + { CmdUse( $2 ); } + | LANGUAGE PARAMETER + { CmdLanguage( $2 ); } + | INITIALIZE PARAMETER + { DefineInitializeNbr( $2 ); } + | XGRID PARAMETER + { DefineXGrid( $2 ); } + | YGRID PARAMETER + { DefineYGrid( $2 ); } + | ZGRID PARAMETER + { DefineZGrid( $2 ); } + | INLINE INLCTX inlinecode ENDINLINE + { + AddInlineCode( $2, InlineBuf ); + free( InlineBuf ); + } + | INLINE error + { ParserErrorMessage(); } + | INTFILE PARAMETER + { CmdIntegrator( $2 ); } + | DRIVER PARAMETER + { CmdDriver( $2 ); } + | RUN PARAMETER + { CmdRun( $2 ); } + | USES uselist + {} + | SPARSEDATA PARAMETER + { SparseData( $2 ); + } + ; +semicolon : semicolon ';' + { ScanWarning("Unnecessary ';'"); + } + | ';' + ; +atomlist : atomlist atomdef semicolon + | atomdef semicolon + | error semicolon + { ParserErrorMessage(); } + ; +atomdef : ATOMID + { switch( crt_section ) { + case ATOMDECL: DeclareAtom( $1 ); break; + case CHECK: SetAtomType( $1, DO_CHECK ); break; + } + } + ; +lookatlist : lookatlist lookatspc semicolon + | lookatspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +lookatspc : LKTID + { AddLookAt( $1 ); + } + ; +monitorlist : monitorlist monitorspc semicolon + | monitorspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +monitorspc : MNIID + { AddMonitor( $1 ); + } + ; +translist : translist transspc semicolon + | transspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +transspc : TPTID + { AddTransport( $1 ); + } + ; +uselist : uselist usefile semicolon + | usefile semicolon + | error semicolon + { ParserErrorMessage(); } + ; +usefile : USEID + { AddUseFile( $1 ); + } + ; +setspclist : setspclist setspcspc semicolon + | setspcspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +setspcspc : SSPID + { switch( crt_section ) { + case SETVAR: SetSpcType( VAR_SPC, $1 ); break; + case SETRAD: SetSpcType( RAD_SPC, $1 ); break; + case SETFIX: SetSpcType( FIX_SPC, $1 ); break; + } + } + ; +species : species spc semicolon + | spc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +spc : spcname + | spcdef + ; +spcname : SPCSPC SPCEQUAL atoms + { switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, $1 ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, $1 ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, $1 ); break; + } + } + ; +spcdef : SPCSPC + { switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, $1 ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, $1 ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, $1 ); break; + } + } + ; +atoms : atoms SPCPLUS atom + | atom + ; +atom : SPCNR SPCSPC + { AddAtom( $2, $1 ); + } + | SPCSPC + { AddAtom( $1, "1" ); + } + ; +initvalues : initvalues assignment semicolon + | assignment semicolon + | error semicolon + { ParserErrorMessage(); } + ; +assignment : INISPC INIEQUAL INIVALUE + { AssignInitialValue( $1, $3 ); } + ; +equations : equations equation semicolon + | equation semicolon + | error semicolon + { ParserErrorMessage(); + eqState = LHS; + } + ; +equation : eqntag lefths righths rate + { eqState = LHS; + StoreEquationRate( $4, $1 ); + CheckEquation(); + } + | lefths righths rate + { eqState = LHS; + StoreEquationRate( $3, " " ); + CheckEquation(); + } +rate : RATE rate + { strcpy( $$, $1 ); + strcat( $$, $2 ); + } + | RATE + { strcpy( $$, $1 ); + } + ; +eqntag : EQNLESS EQNTAG EQNGREATER + { strcpy( $$, $2 ); + } + ; +lefths : expresion EQNEQUAL + { eqState = RHS; } + ; +righths : expresion EQNCOLON + { eqState = RAT; } + ; +expresion : expresion EQNSIGN term + { ProcessTerm( eqState, $2, crt_coef, crt_term ); + } + | EQNSIGN term + { ProcessTerm( eqState, $1, crt_coef, crt_term ); + } + | term + { ProcessTerm( eqState, "+", crt_coef, crt_term ); + } + ; +term : EQNCOEF EQNSPC + { strcpy( crt_term, $2 ); + strcpy( crt_coef, $1 ); + } + | EQNSPC + { strcpy( crt_term, $1 ); + strcpy( crt_coef, "1" ); + } + ; +lumps : lumps lump semicolon + | lump semicolon + | error semicolon + { ParserErrorMessage(); } + ; +lump : LMPSPC LMPPLUS lump + { AddLumpSpecies( $1 ); + } + | LMPSPC LMPCOLON LMPSPC + { + AddLumpSpecies( $1 ); + CheckLump( $3 ); + } +inlinecode : inlinecode INCODE + { + InlineBuf = AppendString( InlineBuf, $2, &InlineLen, MAX_INLINE ); + } + | INCODE + { + InlineBuf = malloc( MAX_INLINE ); + InlineLen = MAX_INLINE; + strcpy( InlineBuf, $1); + } + ; +%% + +void yyerror( char * str ) +{ +} + +void ParserErrorMessage() +{ + yyerrok; +/* + Message("[%d,%s] -> [%d,%s]", crtTokType, crtToken, nextTokType, nextToken ); +*/ + if( crtToken[0] == ';' ) { + ParserError("Misplaced ';'"); + return; + } + switch( crtTokType ) { + case ATOMID: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case SPCSPC: + ParserError("Missing ';' or '+' after '%s'", crtToken ); + break; + case SPCNR: + ParserError("Missing species after '%s'", crtToken ); + break; + case SPCPLUS: + ParserError("Missing atom after '%s'", crtToken ); + break; + case SPCEQUAL: + ParserError("Invalid '=' after '%s'", crtToken ); + break; + + case INISPC: + ParserError("Missing '=' after '%s'", crtToken ); + break; + case INIEQUAL: + ParserError("Missing value after '%s'", crtToken ); + break; + case INIVALUE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case EQNSPC: + ParserError("Missing '+' or '=' after '%s'", crtToken ); + break; + case EQNEQUAL: + ParserError("Invalid right hand side of equation"); + break; + case EQNCOLON: + ParserError("Missing rate after '%s'", crtToken ); + break; + case EQNSIGN: + ParserError("Missing coeficient after '%s'", crtToken ); + break; + case EQNCOEF: + ParserError("Missing species after '%s'", crtToken ); + break; + case RATE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case LMPSPC: + ParserError("Missing '+' or ':' or ';' after '%s'", crtToken ); + break; + case LMPPLUS: + ParserError("Missing species after '%s'", crtToken ); + break; + case LMPCOLON: + ParserError("Missing species after '%s'", crtToken ); + break; + case INLINE: + ParserError("Missing inline option after '%s'", crtToken ); + break; + + default: + ParserError("Syntax error after '%s'", crtToken ); + } +} + + +int Parser( char * filename ) +{ +extern int yydebug; +FILE *f; + + crt_filename = filename; + + f = fopen( crt_filename, "r" ); + if( f == 0 ) { + FatalError(7,"%s: File not found", crt_filename); + } + + yyin = f; + nError = 0; + nWarning = 0; + yydebug = 0; + + yyparse(); + + fclose( f ); + + return nError; +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanner.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanner.c new file mode 100755 index 00000000..73278a29 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanner.c @@ -0,0 +1,906 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "scan.h" +#include "y.tab.h" +#include +#include +#include + +int AtomNr = 0; +int SpeciesNr = 0; +int EqnNr = 0; +int SpcNr = 0; +int VarNr = 0; +int VarActiveNr = 0; +int FixNr = 0; +int VarStartNr = 0; +int FixStartNr = 0; + + +int initNr = -1; +int xNr = 0; +int yNr = 0; +int zNr = 0; + +int falseSpcNr = 0; + +ATOM_DEF AtomTable[ MAX_ATNR ]; +SPECIES_DEF SpeciesTable[ MAX_SPECIES ]; +CODE ReverseCode[ MAX_SPECIES ]; +CODE Code[ MAX_SPECIES ]; +KREACT kr[ MAX_EQN ]; + +float** Stoich_Left; +float** Stoich; +float** Stoich_Right; +int Reactive[ MAX_SPECIES ]; + +INLINE_KEY InlineKeys[] = { { F77_GLOBAL, APPEND, "F77_GLOBAL" }, + { F77_INIT, APPEND, "F77_INIT" }, + { F77_DATA, APPEND, "F77_DATA" }, + { F77_UTIL, APPEND, "F77_UTIL" }, + { F77_RATES, APPEND, "F77_RATES" }, + { F77_RCONST, APPEND, "F77_RCONST" }, + { F90_GLOBAL, APPEND, "F90_GLOBAL" }, + { F90_INIT, APPEND, "F90_INIT" }, + { F90_DATA, APPEND, "F90_DATA" }, + { F90_UTIL, APPEND, "F90_UTIL" }, + { F90_RATES, APPEND, "F90_RATES" }, + { F90_RCONST, APPEND, "F90_RCONST" }, + { C_GLOBAL, APPEND, "C_GLOBAL" }, + { C_INIT, APPEND, "C_INIT" }, + { C_DATA, APPEND, "C_DATA" }, + { C_UTIL, APPEND, "C_UTIL" }, + { C_RATES, APPEND, "C_RATES" }, + { C_RCONST, APPEND, "C_RCONST" }, + { MATLAB_GLOBAL, APPEND, "MATLAB_GLOBAL" }, + { MATLAB_INIT, APPEND, "MATLAB_INIT" }, + { MATLAB_DATA, APPEND, "MATLAB_DATA" }, + { MATLAB_UTIL, APPEND, "MATLAB_UTIL" }, + { MATLAB_RATES, APPEND, "MATLAB_RATES" }, + { MATLAB_RCONST, APPEND, "MATLAB_RCONST" } + }; + +int useAggregate = 1; +int useJacobian = JAC_LU_ROW; +int useJacSparse = 1; +int useHessian = 1; +int useStoicmat = 1; +int useDouble = 1; +int useReorder = 1; +int useMex = 1; +int useDummyindex = 0; +int useEqntags = 0; +int useLang = F77_LANG; +int useStochastic = 0; + +char integrator[ MAX_PATH ] = "none"; +char driver[ MAX_PATH ] = "none"; +char runArgs[ MAX_PATH ] = ""; + +/* mz_rs_20050701+ */ +/* char varDefault[ MAX_IVAL ] = "1.E-8"; */ +/* char fixDefault[ MAX_IVAL ] = "1.E-8"; */ +/* double cfactor = 1.09E+10; */ +char varDefault[ MAX_IVAL ] = "0."; +char fixDefault[ MAX_IVAL ] = "0."; +double cfactor = 1.; +/* mz_rs_20050701- */ + +ATOM crtAtoms[ MAX_ATOMS ]; +int crtAtomNr = 0; + +char *fileList[ MAX_FILES ]; +int fileNr = 0; + +double Abs( double x ) +{ + return x > 0 ? x : -x; +} + +void DefineInitializeNbr( char *cmd ) +{ +int n; + + n = sscanf( cmd, "%d", &initNr); + if( n != 1 ) + ScanError("Bad number of species to initialize <%s>", cmd); +} + +void DefineXGrid( char *cmd ) +{ +int n; + + xNr = 1; + n = sscanf( cmd, "%d", &xNr); + if( n != 1 ) + ScanError("Bad X grid number <%s>", cmd); +} + +void DefineYGrid( char *cmd ) +{ +int n; + + yNr = 1; + n = sscanf( cmd, "%d", &yNr); + if( n != 1 ) + ScanError("Bad Y grid number <%s>", cmd); +} + +void DefineZGrid( char *cmd ) +{ +int n; + + zNr = 1; + n = sscanf( cmd, "%d", &zNr); + if( n != 1 ) + ScanError("Bad Z grid number <%s>", cmd); +} + +void CmdFunction( char *cmd ) +{ + if( EqNoCase( cmd, "AGGREGATE" ) ) { + useAggregate = 1; + return; + } + if( EqNoCase( cmd, "SPLIT" ) ) { + useAggregate = 0; + return; + } + ScanError("'%s': Unknown parameter for #FUNCTION [AGGREGATE|SPLIT]", cmd ); +} + +void CmdJacobian( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useJacobian = JAC_OFF; + useJacSparse = 0; + return; + } + if( EqNoCase( cmd, "FULL" ) ) { + useJacobian = JAC_FULL; + useJacSparse = 0; + return; + } + if( EqNoCase( cmd, "SPARSE_LU_ROW" ) ) { + useJacobian = JAC_LU_ROW; + useJacSparse = 1; + return; + } + if( EqNoCase( cmd, "SPARSE_ROW" ) ) { + useJacobian = JAC_ROW; + useJacSparse = 1; + return; + } + ScanError("'%s': Unknown parameter for #JACOBIAN [OFF|FULL|SPARSE_LU_ROW|SPARSE_ROW]", cmd ); +} + +void SparseData( char *cmd ) { + ScanError("Deprecated use of #SPARSEDATA %s: see #JACOBIAN for equivalent functionality", cmd ); +} + +void CmdHessian( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useHessian = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useHessian = 1; + return; + } + ScanError("'%s': Unknown parameter for #HESSIAN [ON|OFF]", cmd ); +} + +void CmdStoicmat( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useStoicmat = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useStoicmat = 1; + return; + } + ScanError("'%s': Unknown parameter for #STOICMAT [ON|OFF]", cmd ); +} + +void CmdDouble( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useDouble = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useDouble = 1; + return; + } + ScanError("'%s': Unknown parameter for #DOUBLE [ON|OFF]", cmd ); +} + +void CmdReorder( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useReorder = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useReorder = 1; + return; + } + ScanError("'%s': Unknown parameter for #REORDER [ON|OFF]", cmd ); +} + +void CmdMex( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useMex = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useMex = 1; + return; + } + ScanError("'%s': Unknown parameter for #MEX [ON|OFF]", cmd ); +} + +void CmdDummyindex( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useDummyindex = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useDummyindex = 1; + return; + } + ScanError("'%s': Unknown parameter for #DUMMYINDEX [ON|OFF]", cmd ); +} + +void CmdEqntags( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useEqntags = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useEqntags = 1; + return; + } + ScanError("'%s': Unknown parameter for #EQNTAGS [ON|OFF]", cmd ); +} + +void CmdUse( char *cmd ) +{ + ScanError("Deprecated command '#USE %s';\nReplace with '#LANGUAGE %s'.",cmd,cmd ); +} + + +void CmdLanguage( char *cmd ) +{ + if( EqNoCase( cmd, "FORTRAN77" ) ) { + useLang = F77_LANG; + return; + } + if( EqNoCase( cmd, "FORTRAN" ) ) { + ScanWarning("Fortran version not specified in '#LANGUAGE %s'. Will use Fortran 77.", cmd); + useLang = F77_LANG; + return; + } + if( EqNoCase( cmd, "FORTRAN90" ) ) { + useLang = F90_LANG; + return; + } + if( EqNoCase( cmd, "MATLAB" ) ) { + useLang = MATLAB_LANG; + return; + } + if( EqNoCase( cmd, "C" ) ) { + useLang = C_LANG; + return; + } + ScanError("'%s': Unknown parameter for #LANGUAGE [Fortran77|Fortran90|C|Matlab]", cmd ); +} + +void CmdStochastic( char *cmd ) +{ + if( EqNoCase( cmd, "ON" ) ) { + useStochastic = 1; + return; + } + if( EqNoCase( cmd, "OFF" ) ) { + useStochastic = 0; + return; + } + ScanError("'%s': Unknown parameter for #STOCHASTIC [OFF|ON]", cmd ); +} + +void CmdIntegrator( char *cmd ) +{ + strcpy( integrator, cmd ); +} + +void CmdDriver( char *cmd ) +{ + strcpy( driver, cmd ); +} + +void CmdRun( char *cmd ) +{ + strcpy( runArgs, cmd ); +} + +int FindAtom( char *atname ) +{ +int i; + + for( i=0; i= 0 ) { + ScanError("Multiple declaration for atom %s.", atname ); + return; + } + if( AtomNr >= MAX_ATNR ) { + Error("Too many atoms"); + return; + } + + strcpy( AtomTable[ AtomNr ].name, atname ); + AtomTable[ AtomNr ].check = NO_CHECK; + AtomTable[ AtomNr ].masscheck = 0; + AtomNr++; +} + +void SetAtomType( char *atname, int type ) +{ +int code; + + code = FindAtom( atname ); + if ( code < 0 ) { + ScanError("Undefined atom %s.", atname ); + return; + } + AtomTable[ code ].check = type; +} + +void CheckAll() +{ +int i; + + for( i=0; i 0 ) ) { + SpeciesTable[ index ].nratoms = crtAtomNr; + for( i = 0; i < crtAtomNr; i++ ) + SpeciesTable[ index ].atoms[i] = crtAtoms[i]; + } + crtAtomNr = 0; +} + +void DeclareSpecies( int type, char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code >= 0 ) { + ScanError("Multiple declaration for species %s.", spname ); + return; + } + if( SpeciesNr >= MAX_SPECIES ) { + Error("Too many species"); + return; + } + StoreSpecies( SpeciesNr, type, spname ); + SpeciesNr++; +} + +void SetSpcType( int type, char *spname ) +{ +int code; +int i; + + if( EqNoCase( spname, "VAR_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + if( SpeciesTable[i].type == VAR_SPC ) + SpeciesTable[i].type = type; + return; + } + if( EqNoCase( spname, "FIX_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + if( SpeciesTable[i].type == FIX_SPC ) + SpeciesTable[i].type = type; + return; + } + if( EqNoCase( spname, "ALL_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + SpeciesTable[i].type = type; + return; + } + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + SpeciesTable[ code ].type = type; +} + +void AssignInitialValue( char *spname , char *spval ) +{ +int code; +double cf; + + if( EqNoCase( spname, "CFACTOR" ) ) { + code = sscanf( spval, "%lg", &cf ); + if( code != 1 ) { + ScanWarning("Invalid CFACTOR value: %s", spval); + return; + } + cfactor = cf; + return; + } + + if( EqNoCase( spname, "VAR_SPEC" ) ) { + strcpy( varDefault, spval ); + return; + } + + + if( EqNoCase( spname, "FIX_SPEC" ) ) { + strcpy( fixDefault, spval ); + return; + } + + if( EqNoCase( spname, "ALL_SPEC" ) ) { + strcpy( varDefault, spval ); + strcpy( fixDefault, spval ); + return; + } + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + strcpy( SpeciesTable[ code ].ival, spval ); +} + +void StoreEquationRate( char *rate, char *label ) +{ +double f; +char buf[ MAX_K ]; +int n; +KREACT *kreact; + + kreact = &kr[ EqnNr ]; + strcpy( kreact->label, label ); + if( isPhoto ) { + kreact->type = PHOTO; + strcpy( kreact->val.st, rate ); + isPhoto = 0; + return; + } + n = sscanf( rate, "%lf%s", &f, buf ); + if ( n == 1 ) { + kreact->type = NUMBER; + kreact->val.f = f; + return; + } + kreact->type = EXPRESION; + strcpy( kreact->val.st, rate ); + return; +} + +void CheckEquation() +{ +int i,j; +int equal, index; +double r1, r2; +float atcnt[ MAX_ATNR ]; +int spc; +SPECIES_DEF *sp; +char errmsg[80]; +int err; + + if( EqnNr >= MAX_EQN ) { + Error("Too many equations"); + return; + } + + for( i = 0; i < AtomNr; i++ ) + atcnt[i] = 0; + + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + if( Stoich_Left[spc][EqnNr] != 0 ) { + for( i = 0; i < sp->nratoms; i++ ) + atcnt[ sp->atoms[i].code ] += Stoich_Left[spc][EqnNr] * sp->atoms[i].nr; + } + if( Stoich_Right[spc][EqnNr] != 0 ) { + for( i = 0; i < sp->nratoms; i++ ) + atcnt[ sp->atoms[i].code ] -= Stoich_Right[spc][EqnNr] * sp->atoms[i].nr; + } + } + + *errmsg = 0; + err = 0; + + for( i = 0; i < AtomNr; i++ ) { + if ( Abs( atcnt[i] ) > 1e-5 ) { + if ( AtomTable[i].check == CANCEL_CHECK ) { + err = 0; + break; + } + if ( AtomTable[i].check == NO_CHECK ) { + continue; + } + if ( AtomTable[i].check == DO_CHECK ) { + err = 1; + sprintf(errmsg, "%s %s", errmsg, AtomTable[i].name ); + continue; + } + } + } + + if ( err ) + ScanWarning( "(eqn %d) Atom balance mismatch for:%s.", EqnNr+1, errmsg ); + + for( j = 0; j < SpcNr; j++ ) + if( Stoich_Left[j][EqnNr] != 0 ) + { index = j; break; } + for( i = 0; i < EqnNr; i++ ) { + equal = 1; + r1 = Stoich_Left[index][EqnNr]; + r2 = Stoich_Left[index][i]; + for( j = 0; j < SpcNr; j++ ) { + if( r1 * Stoich_Left[j][i] != r2 * Stoich_Left[j][EqnNr] ) + { equal = 0; break; } + if( r1 * Stoich_Right[j][i] != r2 * Stoich_Right[j][EqnNr] ) + { equal = 0; break; } + } + if ( equal ) { + if( r1 == r2 ) + ScanError( "Duplicate equation: " + " (eqn<%d> = eqn<%d> )", i+1, EqnNr+1 ); + else + ScanError( "Linearly dependent equations: " + "( %.0f eqn<%d> = %.0f eqn<%d> )", + r1, i+1, r2, EqnNr+1 ); + break; + } + } + EqnNr++; +} + +void ProcessTerm( int side, char *sign, char *coef, char *spname ) +{ +int code; +CODE crtSpec; +double val; +char buf[40]; + + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + crtSpec = ReverseCode[ code ]; + + if(EqNoCase(spname,"HV")) isPhoto = 1; + + if ( crtSpec == NO_CODE ) { + if( MAX_SPECIES - code <= 2 ) falseSpcNr++; + crtSpec = SpcNr++; + Code[ crtSpec ] = code; + ReverseCode[ code ] = crtSpec; + } + + strcpy( buf, sign ); + strcat( buf, coef ); + sscanf( buf, "%lf", &val ); + + switch( side ) { + case LHS: Stoich_Left[ crtSpec ][ EqnNr ] += val; + Stoich[ crtSpec ][ EqnNr ] -= val; + Reactive[ crtSpec ] = 1; + break; + case RHS: Stoich_Right[ crtSpec ][ EqnNr ] += val; + Stoich[ crtSpec ][ EqnNr ] += val; + break; + } +} + +void AddLumpSpecies( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + /* ... */ + +} + +void CheckLump( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + /* ... */ + +} + +void AddLookAt( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + SpeciesTable[ code ].lookat = 1; +} + +void LookAtAll() +{ +int i; + + for( i=0; i= 0 ) { + SpeciesTable[ code ].moni = 1; + return; + } + + code = FindAtom( spname ); + if ( code >= 0 ) { + AtomTable[ code ].masscheck = 1; + return; + } + + ScanError("Undefined species or atom %s.", spname ); +} + +void AddTransport( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + SpeciesTable[ code ].trans = 1; +} + +void TransportAll() +{ +int i; + + for( i=0; i= *maxlen ) { + s1 = (char*)realloc( (void*)s1, *maxlen ); + } + strcat( s1, s2 ); + return s1; +} + +char * ReplaceString( char * s1, char * s2, int * maxlen, int addlen ) +{ +char * tmp; + + if( s1 ) free(s1); + + *maxlen = strlen( s2 ); + s1 = (char*)malloc( 1+*maxlen ); + strcpy( s1, s2 ); + + return s1; +} + +void AddInlineCode( char * ctx, char * s ) +{ +ICODE * c; +int i, key, type; +int totallength; /* mz_rs_20050607 */ + + c = NULL; + + for( i = 0; i < INLINE_OPT; i++ ) + if( EqNoCase( ctx, InlineKeys[i].kname ) ) { + key = InlineKeys[i].key; + c = &InlineCode[key]; + type = InlineKeys[i].type; + break; + } + if( !c ) { + printf( "\n'%s': Unknown inline option (ignored)", ctx ); + return; + } + + /* mz_rs_20050607+ */ + if (c->code) + totallength = strlen( c->code )+strlen( s ); + else + totallength = strlen( s ); + if (totallength>MAX_INLINE) + ScanError("\nInline code for %s is too long (%d>%d).\nIncrease MAX_INLINE in scan.h and recompile kpp!", + ctx, totallength, MAX_INLINE); + /* mz_rs_20050607- */ + + switch( type ) { + case APPEND: c->code = AppendString( c->code, s, &c->maxlen, MAX_INLINE ); + break; + case REPLACE: c->code = ReplaceString( c->code, s, &c->maxlen, MAX_INLINE ); + break; + } +} + +int ParseEquationFile( char * filename ) +{ +int i,j; +int code; + + for( i = 0; i < MAX_SPECIES; i++ ) { + ReverseCode[i] = NO_CODE; + Reactive[i] = 0; + } + for( i = 0; i < MAX_SPECIES; i++ ) { + for( j = 0; j < MAX_EQN; j++ ) { + Stoich_Left[i][j] = 0; + Stoich[i][j] = 0; + Stoich_Right[i][j] = 0; + } + } + for( i = 0; i < MAX_SPECIES; i++ ) { + SpeciesTable[ i ].nratoms = 0; + } + + for( i = 0; i < INLINE_OPT; i++ ) { + InlineCode[i].code = NULL; + InlineCode[i].maxlen = 0; + } + + EqnNr = 0; + SpcNr = 0; + + DeclareAtom( "CANCEL" ); + SetAtomType( "CANCEL", CANCEL_CHECK ); + DeclareAtom( "IGNORE" ); + SetAtomType( "IGNORE", NO_CHECK ); + DeclareSpecies( DUMMY_SPC, "???" ); + StoreSpecies( MAX_SPECIES-1, DUMMY_SPC, "HV" ); + AddAtom( "CANCEL", "1" ); + StoreSpecies( MAX_SPECIES-2, DUMMY_SPC, "PROD" ); + + code = Parser( filename ); + + return code; +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanutil.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanutil.c new file mode 100755 index 00000000..cd992aee --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/scanutil.c @@ -0,0 +1,202 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include +#include +#include +#include +#include +#include "gdata.h" +#include "scan.h" + +#define MAX_BUFFER 200 + +void ScanError( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error :%s:%d: %s\n", crt_filename, crt_line_no, buf ); + nError++; +} + +void ParserError( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error :%s:%d: %s\n", crtFile, crtLine, buf ); + nError++; +} + +void ScanWarning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning :%s:%d: %s\n", crt_filename, crt_line_no, buf ); + nWarning++; +} + +void ParserWarning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning :%s:%d: %s\n", crtFile, crtLine, buf ); + nWarning++; +} + +void Error( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error : %s\n", buf ); + nError++; +} + +void Warning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning : %s\n", buf ); + nWarning++; +} + +void Message( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, " Message :%s:%d: %s\n", crt_filename, crt_line_no, buf ); +} + +void FatalError( int status, char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "\nFatal error : %s\nProgram aborted\n", buf ); + exit(status); +} + +char * FileName( char *fname, char *env, char *dir, char *ext ) +{ +static char pathname[MAX_PATH]; +char *path; +char *crtpath; +char *p; +FILE *fp; +static char name[MAX_PATH]; +int noext; + + strcpy(name, fname); + p = name + strlen(name); + noext = 1; + while( p > name ) { + if( *p == '.') { + noext = 0; + break; + } + if( *p == '/' ) break; + p--; + } + + if( noext ) strcat(name, ext); + + fp = fopen(name,"r"); + if( fp ) { + fclose(fp); + return name; + } + + path = getenv(env); + if( path ) { + crtpath = path; + p = pathname; + while( 1 ) { + if( isspace(*crtpath) ) { + crtpath++; + continue; + } + if((*crtpath == ':')||(*crtpath==0)) { + *p = 0; + sprintf(pathname,"%s/%s",pathname,name); + fp = fopen(pathname,"r"); + if( fp ) { + fclose(fp); + return pathname; + } + if (*crtpath==0) break; + crtpath++; + p = pathname; + continue; + } + *p++ = *crtpath++; + } + } + + sprintf(pathname, "%s/%s/%s", Home, dir, name); + fp = fopen(pathname,"r"); + if( fp ) { + fclose(fp); + return pathname; + } + + return name; +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.c new file mode 100755 index 00000000..adc1feb8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.c @@ -0,0 +1,1702 @@ +#ifndef lint +/*static char yysccsid[] = "from: @(#)yaccpar 1.9 (Berkeley) 02/21/93";*/ +static char yyrcsid[] = "$Id: skeleton.c,v 1.4 1993/12/21 18:45:32 jtc Exp $"; +#endif +#define YYBYACC 1 +#define YYMAJOR 1 +#define YYMINOR 9 +#define yyclearin (yychar=(-1)) +#define yyerrok (yyerrflag=0) +#define YYRECOVERING (yyerrflag!=0) +#define YYPREFIX "yy" +#line 35 "scan.y" + #include + #include + #include + #include + #include + #include "scan.h" + + #define __YYSCLASS + + #define YYDEBUG 1 + extern char yytext[]; + extern FILE * yyin; + + int nError = 0; + int nWarning = 0; + + int crt_section; + int eqState; + int isPhoto = 0; + + char crt_term[ 30 ]; + char crt_coef[ 30 ]; + + char * InlineBuf; + int InlineLen; + + void SemicolonError(); + extern int yyerrflag; + +#line 66 "scan.y" +typedef union{ + char str[80]; +} YYSTYPE; +#line 47 "y.tab.c" +#define JACOBIAN 257 +#define DOUBLE 258 +#define FUNCTION 259 +#define DEFVAR 260 +#define DEFRAD 261 +#define DEFFIX 262 +#define SETVAR 263 +#define SETRAD 264 +#define SETFIX 265 +#define HESSIAN 266 +#define STOICMAT 267 +#define STOCHASTIC 268 +#define INITVALUES 269 +#define EQUATIONS 270 +#define LUMP 271 +#define INIEQUAL 272 +#define EQNEQUAL 273 +#define EQNCOLON 274 +#define LMPCOLON 275 +#define LMPPLUS 276 +#define SPCPLUS 277 +#define SPCEQUAL 278 +#define ATOMDECL 279 +#define CHECK 280 +#define CHECKALL 281 +#define REORDER 282 +#define MEX 283 +#define DUMMYINDEX 284 +#define EQNTAGS 285 +#define LOOKAT 286 +#define LOOKATALL 287 +#define TRANSPORT 288 +#define TRANSPORTALL 289 +#define MONITOR 290 +#define USES 291 +#define SPARSEDATA 292 +#define WRFCONFORM 293 +#define WRITE_ATM 294 +#define WRITE_SPC 295 +#define WRITE_MAT 296 +#define WRITE_OPT 297 +#define INITIALIZE 298 +#define XGRID 299 +#define YGRID 300 +#define ZGRID 301 +#define USE 302 +#define LANGUAGE 303 +#define INTFILE 304 +#define DRIVER 305 +#define RUN 306 +#define INLINE 307 +#define ENDINLINE 308 +#define PARAMETER 309 +#define SPCSPC 310 +#define INISPC 311 +#define INIVALUE 312 +#define EQNSPC 313 +#define EQNSIGN 314 +#define EQNCOEF 315 +#define RATE 316 +#define LMPSPC 317 +#define SPCNR 318 +#define ATOMID 319 +#define LKTID 320 +#define MNIID 321 +#define INLCTX 322 +#define INCODE 323 +#define SSPID 324 +#define EQNLESS 325 +#define EQNTAG 326 +#define EQNGREATER 327 +#define TPTID 328 +#define USEID 329 +#define YYERRCODE 256 +short yylhs[] = { -1, + 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 15, 15, 4, 4, + 4, 16, 10, 10, 10, 17, 11, 11, 11, 18, + 12, 12, 12, 19, 14, 14, 14, 20, 6, 6, + 6, 21, 5, 5, 5, 22, 22, 23, 24, 25, + 25, 26, 26, 7, 7, 7, 27, 8, 8, 8, + 28, 28, 1, 1, 2, 29, 30, 31, 31, 31, + 32, 32, 9, 9, 9, 33, 33, 13, 13, +}; +short yylen[] = { 2, + 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, + 1, 1, 1, 2, 2, 2, 2, 2, 2, 4, + 2, 2, 2, 2, 2, 2, 2, 1, 3, 2, + 2, 1, 3, 2, 2, 1, 3, 2, 2, 1, + 3, 2, 2, 1, 3, 2, 2, 1, 3, 2, + 2, 1, 3, 2, 2, 1, 1, 3, 1, 3, + 1, 2, 1, 3, 2, 2, 3, 3, 2, 2, + 4, 3, 2, 1, 3, 2, 2, 3, 2, 1, + 2, 1, 3, 2, 2, 3, 3, 2, 1, +}; +short yydefred[] = { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 27, 0, 0, + 0, 0, 0, 28, 0, 29, 0, 0, 0, 30, + 31, 32, 33, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 3, 6, 11, 0, 0, + 0, 0, 76, 77, 0, 0, 0, 72, 0, 0, + 0, 0, 4, 5, 12, 0, 0, 0, 0, 0, + 102, 0, 0, 0, 0, 0, 0, 0, 0, 100, + 0, 0, 0, 0, 0, 52, 0, 0, 0, 7, + 8, 9, 10, 0, 56, 0, 0, 0, 64, 0, + 0, 0, 60, 0, 0, 0, 68, 0, 0, 46, + 36, 37, 38, 39, 34, 35, 42, 43, 44, 41, + 0, 2, 48, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 99, 101, 0, 0, 0, + 0, 0, 0, 96, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 109, 0, 47, 83, 0, + 0, 81, 0, 0, 87, 0, 95, 0, 0, 0, + 92, 97, 98, 107, 106, 0, 0, 0, 0, 0, + 0, 40, 108, 82, 0, 91, 93, 80, +}; +short yydgoto[] = { 44, + 181, 75, 45, 87, 51, 59, 68, 76, 83, 96, + 104, 100, 167, 108, 124, 88, 97, 105, 101, 109, + 60, 52, 53, 54, 171, 172, 69, 77, 78, 142, + 79, 80, 84, +}; +short yysindex[] = { -139, + -285, -278, -271, -240, -240, -240, -253, -253, -253, -226, + -219, -212, -243, -249, -248, -237, -237, 0, -211, -210, + -209, -207, -246, 0, -251, 0, -242, -256, -204, 0, + 0, 0, 0, -203, -201, -200, -198, -197, -195, -194, + -192, -176, -250, 0, -139, 0, 0, 0, -3, -215, + -175, -3, 0, 0, -175, -175, -3, 0, -265, -3, + -265, -265, 0, 0, 0, -3, -138, -174, -3, -3, + 0, -288, -177, -188, -227, -270, -3, -227, -247, 0, + -3, -228, -178, -3, -3, 0, -150, -3, -150, 0, + 0, 0, 0, -3, 0, -149, -3, -3, 0, -158, + -3, -3, 0, -148, -3, -3, 0, -157, -3, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + -147, 0, 0, 115, -290, -3, 115, 115, -3, 115, + 115, -137, -3, 115, 115, 0, 0, -146, -227, -3, + 115, -136, -263, 0, -288, 115, -140, -178, -3, 115, + 115, -3, 115, 115, -3, 115, 115, -3, 115, 115, + -3, 115, 115, -3, 115, 0, -291, 0, 0, -132, + -98, 0, 115, 115, 0, 115, 0, -136, 115, -136, + 0, 0, 0, 0, 0, 115, 115, 115, 115, 115, + 115, 0, 0, 0, -290, 0, 0, 0, +}; +short yyrindex[] = { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 182, 0, 0, 0, 0, 124, + 1996, 0, 0, 0, 2047, 2100, 0, 0, 2153, 0, + 2204, 2268, 0, 0, 0, 0, 0, 2319, 0, 0, + 0, 0, 0, 0, 0, 2372, 0, 0, 0, 0, + 0, 0, 2425, 0, 0, 0, 2476, 0, 2540, 0, + 0, 0, 0, 0, 0, 2591, 0, 0, 0, 2644, + 0, 0, 0, 2697, 0, 0, 0, 2748, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1792, 0, 0, 1860, 567, 0, 636, + 1588, 0, 0, 1655, 328, 0, 0, 0, 0, 0, + 426, 0, 0, 0, 0, 1383, 0, 0, 0, 1452, + 1180, 0, 1248, 976, 0, 1044, 154, 0, 205, 772, + 0, 839, 1, 0, 52, 0, 0, 0, 0, 0, + 125, 0, 1927, 704, 0, 1724, 0, 0, 498, 126, + 0, 0, 0, 0, 0, 1520, 1316, 1111, 256, 908, + 103, 0, 0, 0, 0, 0, 0, 0, +}; +short yygindex[] = { 141, + -118, 0, 0, 170, 88, 87, 0, 0, 0, 0, + 0, 0, 0, 0, -48, 2, 92, 85, 90, 83, + -20, -21, 0, 0, 0, -2, 127, 116, 119, 57, + -55, -70, -68, +}; +#define YYTABLESIZE 3055 +short yytable[] = { 106, + 67, 136, 57, 127, 98, 120, 70, 81, 128, 94, + 182, 130, 66, 102, 149, 49, 192, 131, 85, 169, + 134, 135, 143, 46, 71, 144, 73, 170, 141, 126, + 47, 193, 146, 126, 126, 150, 151, 48, 129, 153, + 129, 129, 71, 72, 73, 154, 147, 148, 156, 157, + 145, 66, 159, 160, 74, 123, 162, 163, 58, 196, + 165, 197, 125, 71, 72, 73, 145, 67, 82, 50, + 58, 121, 107, 95, 183, 74, 99, 173, 103, 185, + 174, 86, 63, 143, 176, 71, 72, 73, 152, 64, + 152, 179, 55, 56, 61, 62, 65, 90, 91, 92, + 186, 93, 65, 187, 110, 111, 188, 112, 113, 189, + 114, 115, 190, 116, 117, 191, 118, 1, 2, 3, + 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, + 14, 15, 119, 132, 50, 137, 67, 138, 82, 16, + 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, + 27, 28, 29, 63, 30, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 86, 99, + 95, 107, 103, 168, 175, 166, 184, 194, 195, 180, + 177, 1, 79, 78, 94, 122, 89, 155, 161, 158, + 164, 140, 198, 139, 133, 178, 0, 0, 0, 0, + 0, 0, 0, 0, 62, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 61, 0, 67, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, + 67, 67, 0, 0, 0, 0, 0, 0, 0, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 0, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 0, 0, 0, 0, 90, 0, 67, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 0, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 65, + 65, 65, 65, 65, 65, 65, 65, 65, 65, 65, + 65, 65, 65, 65, 0, 0, 0, 0, 0, 0, + 66, 65, 65, 65, 65, 65, 65, 65, 65, 65, + 65, 65, 65, 65, 65, 0, 65, 65, 65, 65, + 65, 65, 65, 65, 65, 65, 65, 65, 65, 65, + 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 63, 63, 63, 89, 0, 0, 0, 0, + 0, 65, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 63, 63, 63, 63, 0, 63, 63, 63, + 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 62, 62, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 62, 62, 62, 0, 0, 0, 0, + 0, 63, 0, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 62, 62, 62, 62, 88, 62, 62, + 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 61, 61, 61, 61, 61, 61, 61, 61, + 61, 61, 61, 61, 61, 61, 61, 0, 0, 0, + 0, 0, 62, 0, 61, 61, 61, 61, 61, 61, + 61, 61, 61, 61, 61, 61, 61, 61, 0, 61, + 61, 61, 61, 61, 61, 61, 61, 61, 61, 61, + 61, 61, 61, 0, 0, 0, 71, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 61, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 0, + 0, 0, 0, 0, 0, 0, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 0, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 70, 0, 0, 0, 0, + 90, 90, 90, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 90, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 89, 89, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 89, 0, 0, 0, + 0, 0, 0, 69, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 89, 89, 0, 89, + 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 0, 0, 0, 0, 0, 89, 89, + 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 89, 0, 0, 0, 88, 88, 88, 88, 88, 88, + 88, 88, 88, 88, 88, 88, 88, 88, 88, 0, + 0, 59, 0, 0, 0, 0, 88, 88, 88, 88, + 88, 88, 88, 88, 88, 88, 88, 88, 88, 88, + 0, 88, 88, 88, 88, 88, 88, 88, 88, 88, + 88, 88, 88, 88, 88, 0, 0, 0, 0, 0, + 88, 88, 88, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 88, 71, 71, 71, 71, 71, 71, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 58, 0, + 0, 0, 0, 0, 0, 71, 71, 71, 71, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 71, 0, + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, + 71, 71, 71, 71, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 71, 0, 70, 70, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 70, 70, 70, 70, 57, 0, 0, + 0, 0, 0, 0, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 70, 70, 70, 70, 70, 0, 70, + 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 70, + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, + 69, 69, 69, 69, 69, 55, 0, 0, 0, 0, + 0, 0, 69, 69, 69, 69, 69, 69, 69, 69, + 69, 69, 69, 69, 69, 69, 0, 69, 69, 69, + 69, 69, 69, 69, 69, 69, 69, 69, 69, 69, + 69, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 69, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 54, 0, 0, 0, 0, 0, 0, + 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 59, 0, 59, 59, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 59, 0, 0, 58, 58, 58, 58, 58, + 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 53, 0, 0, 0, 0, 0, 0, 58, 58, 58, + 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 0, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 58, 58, 58, 58, 58, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 58, + 0, 0, 0, 0, 57, 57, 57, 57, 57, 57, + 57, 57, 57, 57, 57, 57, 57, 57, 57, 51, + 0, 0, 0, 0, 0, 0, 57, 57, 57, 57, + 57, 57, 57, 57, 57, 57, 57, 57, 57, 57, + 0, 57, 57, 57, 57, 57, 57, 57, 57, 57, + 57, 57, 57, 57, 57, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 57, 0, + 0, 0, 55, 55, 55, 55, 55, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 55, 50, 0, 0, + 0, 0, 0, 0, 55, 55, 55, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 55, 55, 0, 55, + 55, 55, 55, 55, 55, 55, 55, 55, 55, 55, + 55, 55, 55, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 55, 0, 0, 0, 0, + 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 54, 54, 54, 54, 49, 0, 0, 0, 0, + 0, 0, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 54, 54, 54, 54, 54, 0, 54, 54, 54, + 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 54, 0, 0, 0, 53, 53, 53, + 53, 53, 53, 53, 53, 53, 53, 53, 53, 53, + 53, 53, 105, 0, 0, 0, 0, 0, 0, 53, + 53, 53, 53, 53, 53, 53, 53, 53, 53, 53, + 53, 53, 53, 0, 53, 53, 53, 53, 53, 53, + 53, 53, 53, 53, 53, 53, 53, 53, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 53, 0, 0, 0, 0, 0, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, + 51, 104, 0, 0, 0, 0, 0, 0, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, + 51, 51, 0, 51, 51, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 51, 0, + 0, 0, 0, 0, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 103, + 0, 0, 0, 0, 0, 0, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 0, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 50, 0, 0, 0, + 0, 0, 49, 49, 49, 49, 49, 49, 49, 49, + 49, 49, 49, 49, 49, 49, 49, 86, 0, 0, + 0, 0, 0, 0, 49, 49, 49, 49, 49, 49, + 49, 49, 49, 49, 49, 49, 49, 49, 0, 49, + 49, 49, 49, 49, 49, 49, 49, 49, 49, 49, + 49, 49, 49, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 49, 0, 0, 0, 0, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 85, 0, 0, 0, 0, 0, + 0, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 0, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 105, + 0, 0, 0, 0, 0, 0, 0, 0, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 84, 0, 0, 0, 0, 0, 0, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 0, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 104, 0, + 0, 0, 0, 0, 0, 0, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, + 103, 75, 0, 0, 0, 0, 0, 0, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, + 103, 103, 0, 103, 103, 103, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 103, 0, 0, 0, + 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 74, + 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 0, 0, 0, 86, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 73, 0, 0, 0, + 0, 0, 0, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 0, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 0, 0, 0, 85, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, + 84, 84, 84, 84, 84, 15, 0, 0, 0, 0, + 0, 0, 84, 84, 84, 84, 84, 84, 84, 84, + 84, 84, 84, 84, 84, 84, 0, 84, 84, 84, + 84, 84, 84, 84, 84, 84, 84, 84, 84, 84, + 84, 0, 0, 0, 84, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 16, 0, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 0, 0, 0, 0, 0, 0, 0, + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 75, 0, 75, 75, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 75, 17, + 0, 75, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 74, 74, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, + 74, 0, 0, 0, 0, 0, 0, 0, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, + 74, 74, 18, 74, 74, 74, 74, 74, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 0, 0, 74, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 0, 0, + 0, 0, 0, 19, 0, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 0, + 73, 73, 73, 73, 73, 73, 73, 73, 73, 73, + 73, 73, 73, 73, 0, 0, 73, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 20, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 21, 0, + 0, 0, 0, 0, 0, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 0, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 0, 0, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 22, 0, 0, 0, 0, 0, 0, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 0, 0, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 23, 0, 0, 0, 0, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 13, 0, 0, 0, 0, + 0, 0, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 0, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 20, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 20, 14, + 0, 0, 0, 0, 0, 0, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, + 0, 20, 20, 20, 20, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 24, 0, 0, 0, 0, 0, 0, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 0, 0, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 22, 22, 26, 0, 0, 0, 0, 0, 0, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 22, 22, 22, 0, 22, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 0, + 0, 23, 23, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 25, 0, 0, 0, + 0, 0, 0, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 0, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 45, 0, 0, + 0, 0, 0, 0, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 0, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 0, 0, 0, 0, 0, 0, 0, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 0, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 0, 0, + 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 0, 0, 0, 0, 0, + 0, 0, 26, 26, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 26, 0, 26, 26, 26, + 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, + 26, 0, 0, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 0, 0, + 0, 0, 0, 0, 0, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 0, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 0, + 0, 0, 0, 0, 0, 0, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 0, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, +}; +short yycheck[] = { 256, + 0, 72, 256, 52, 256, 256, 256, 256, 57, 256, + 274, 60, 256, 256, 83, 256, 308, 66, 256, 310, + 69, 70, 78, 309, 313, 273, 315, 318, 77, 51, + 309, 323, 81, 55, 56, 84, 85, 309, 59, 88, + 61, 62, 313, 314, 315, 94, 275, 276, 97, 98, + 314, 0, 101, 102, 325, 59, 105, 106, 324, 178, + 109, 180, 278, 313, 314, 315, 314, 311, 317, 310, + 324, 322, 329, 320, 145, 325, 328, 126, 321, 148, + 129, 319, 309, 139, 133, 313, 314, 315, 87, 309, + 89, 140, 5, 6, 8, 9, 309, 309, 309, 309, + 149, 309, 0, 152, 309, 309, 155, 309, 309, 158, + 309, 309, 161, 309, 309, 164, 309, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, 309, 272, 310, 313, 311, 326, 317, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 0, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 319, 328, + 320, 329, 321, 59, 312, 323, 317, 310, 277, 316, + 327, 0, 59, 59, 59, 45, 17, 96, 104, 100, + 108, 76, 195, 75, 68, 139, -1, -1, -1, -1, + -1, -1, -1, -1, 0, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 0, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, -1, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, -1, -1, -1, 0, -1, 329, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, -1, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + 329, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, -1, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, 329, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, -1, -1, -1, -1, + -1, 328, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 0, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, -1, 328, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, 0, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 328, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, 0, -1, -1, -1, -1, + 313, 314, 315, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 325, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, -1, -1, 0, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, 313, 314, + 315, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 325, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, 0, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, -1, -1, + 313, 314, 315, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 325, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, 0, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, -1, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 324, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 324, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 324, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, 0, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, -1, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 321, -1, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 0, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, -1, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 321, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, 0, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 321, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 320, -1, -1, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 320, -1, -1, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, 0, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, -1, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 320, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, 0, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, -1, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 319, -1, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, 0, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 319, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 319, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 0, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, -1, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 317, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, 0, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, -1, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 317, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, 0, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, -1, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 317, -1, -1, -1, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, 0, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, 311, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, 0, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, -1, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, -1, -1, -1, 311, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, -1, -1, -1, 311, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 0, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, -1, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 0, + -1, 310, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, -1, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 0, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, -1, -1, 310, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, 0, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, -1, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, -1, -1, 310, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, 0, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, -1, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, 0, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, -1, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 0, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, -1, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, 0, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 0, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, -1, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, -1, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, 0, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, -1, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, -1, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, 0, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, -1, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, -1, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, -1, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, -1, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, -1, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, -1, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, -1, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, -1, -1, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, -1, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + -1, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, +}; +#define YYFINAL 44 +#ifndef YYDEBUG +#define YYDEBUG 0 +#endif +#define YYMAXTOKEN 329 +#if YYDEBUG +char *yyname[] = { +"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"';'",0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"JACOBIAN","DOUBLE", +"FUNCTION","DEFVAR","DEFRAD","DEFFIX","SETVAR","SETRAD","SETFIX","HESSIAN", +"STOICMAT","STOCHASTIC","INITVALUES","EQUATIONS","LUMP","INIEQUAL","EQNEQUAL", +"EQNCOLON","LMPCOLON","LMPPLUS","SPCPLUS","SPCEQUAL","ATOMDECL","CHECK", +"CHECKALL","REORDER","MEX","DUMMYINDEX","EQNTAGS","LOOKAT","LOOKATALL", +"TRANSPORT","TRANSPORTALL","MONITOR","USES","SPARSEDATA","WRFCONFORM", +"WRITE_ATM","WRITE_SPC","WRITE_MAT","WRITE_OPT","INITIALIZE","XGRID","YGRID", +"ZGRID","USE","LANGUAGE","INTFILE","DRIVER","RUN","INLINE","ENDINLINE", +"PARAMETER","SPCSPC","INISPC","INIVALUE","EQNSPC","EQNSIGN","EQNCOEF","RATE", +"LMPSPC","SPCNR","ATOMID","LKTID","MNIID","INLCTX","INCODE","SSPID","EQNLESS", +"EQNTAG","EQNGREATER","TPTID","USEID", +}; +char *yyrule[] = { +"$accept : program", +"program : section", +"program : section program", +"section : JACOBIAN PARAMETER", +"section : HESSIAN PARAMETER", +"section : STOICMAT PARAMETER", +"section : DOUBLE PARAMETER", +"section : REORDER PARAMETER", +"section : MEX PARAMETER", +"section : DUMMYINDEX PARAMETER", +"section : EQNTAGS PARAMETER", +"section : FUNCTION PARAMETER", +"section : STOCHASTIC PARAMETER", +"section : ATOMDECL atomlist", +"section : CHECK atomlist", +"section : DEFVAR species", +"section : DEFRAD species", +"section : DEFFIX species", +"section : SETVAR setspclist", +"section : SETRAD setspclist", +"section : SETFIX setspclist", +"section : INITVALUES initvalues", +"section : EQUATIONS equations", +"section : LUMP lumps", +"section : LOOKAT lookatlist", +"section : MONITOR monitorlist", +"section : TRANSPORT translist", +"section : CHECKALL", +"section : LOOKATALL", +"section : TRANSPORTALL", +"section : WRITE_ATM", +"section : WRITE_SPC", +"section : WRITE_MAT", +"section : WRITE_OPT", +"section : USE PARAMETER", +"section : LANGUAGE PARAMETER", +"section : INITIALIZE PARAMETER", +"section : XGRID PARAMETER", +"section : YGRID PARAMETER", +"section : ZGRID PARAMETER", +"section : INLINE INLCTX inlinecode ENDINLINE", +"section : INLINE error", +"section : INTFILE PARAMETER", +"section : DRIVER PARAMETER", +"section : RUN PARAMETER", +"section : USES uselist", +"section : SPARSEDATA PARAMETER", +"semicolon : semicolon ';'", +"semicolon : ';'", +"atomlist : atomlist atomdef semicolon", +"atomlist : atomdef semicolon", +"atomlist : error semicolon", +"atomdef : ATOMID", +"lookatlist : lookatlist lookatspc semicolon", +"lookatlist : lookatspc semicolon", +"lookatlist : error semicolon", +"lookatspc : LKTID", +"monitorlist : monitorlist monitorspc semicolon", +"monitorlist : monitorspc semicolon", +"monitorlist : error semicolon", +"monitorspc : MNIID", +"translist : translist transspc semicolon", +"translist : transspc semicolon", +"translist : error semicolon", +"transspc : TPTID", +"uselist : uselist usefile semicolon", +"uselist : usefile semicolon", +"uselist : error semicolon", +"usefile : USEID", +"setspclist : setspclist setspcspc semicolon", +"setspclist : setspcspc semicolon", +"setspclist : error semicolon", +"setspcspc : SSPID", +"species : species spc semicolon", +"species : spc semicolon", +"species : error semicolon", +"spc : spcname", +"spc : spcdef", +"spcname : SPCSPC SPCEQUAL atoms", +"spcdef : SPCSPC", +"atoms : atoms SPCPLUS atom", +"atoms : atom", +"atom : SPCNR SPCSPC", +"atom : SPCSPC", +"initvalues : initvalues assignment semicolon", +"initvalues : assignment semicolon", +"initvalues : error semicolon", +"assignment : INISPC INIEQUAL INIVALUE", +"equations : equations equation semicolon", +"equations : equation semicolon", +"equations : error semicolon", +"equation : eqntag lefths righths rate", +"equation : lefths righths rate", +"rate : RATE rate", +"rate : RATE", +"eqntag : EQNLESS EQNTAG EQNGREATER", +"lefths : expresion EQNEQUAL", +"righths : expresion EQNCOLON", +"expresion : expresion EQNSIGN term", +"expresion : EQNSIGN term", +"expresion : term", +"term : EQNCOEF EQNSPC", +"term : EQNSPC", +"lumps : lumps lump semicolon", +"lumps : lump semicolon", +"lumps : error semicolon", +"lump : LMPSPC LMPPLUS lump", +"lump : LMPSPC LMPCOLON LMPSPC", +"inlinecode : inlinecode INCODE", +"inlinecode : INCODE", +}; +#endif +#ifdef YYSTACKSIZE +#undef YYMAXDEPTH +#define YYMAXDEPTH YYSTACKSIZE +#else +#ifdef YYMAXDEPTH +#define YYSTACKSIZE YYMAXDEPTH +#else +#define YYSTACKSIZE 500 +#define YYMAXDEPTH 500 +#endif +#endif +int yydebug; +int yynerrs; +int yyerrflag; +int yychar; +short *yyssp; +YYSTYPE *yyvsp; +YYSTYPE yyval; +YYSTYPE yylval; +short yyss[YYSTACKSIZE]; +YYSTYPE yyvs[YYSTACKSIZE]; +#define yystacksize YYSTACKSIZE +#line 384 "scan.y" + +void yyerror( char * str ) +{ +} + +void ParserErrorMessage() +{ + yyerrok; +/* + Message("[%d,%s] -> [%d,%s]", crtTokType, crtToken, nextTokType, nextToken ); +*/ + if( crtToken[0] == ';' ) { + ParserError("Misplaced ';'"); + return; + } + switch( crtTokType ) { + case ATOMID: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case SPCSPC: + ParserError("Missing ';' or '+' after '%s'", crtToken ); + break; + case SPCNR: + ParserError("Missing species after '%s'", crtToken ); + break; + case SPCPLUS: + ParserError("Missing atom after '%s'", crtToken ); + break; + case SPCEQUAL: + ParserError("Invalid '=' after '%s'", crtToken ); + break; + + case INISPC: + ParserError("Missing '=' after '%s'", crtToken ); + break; + case INIEQUAL: + ParserError("Missing value after '%s'", crtToken ); + break; + case INIVALUE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case EQNSPC: + ParserError("Missing '+' or '=' after '%s'", crtToken ); + break; + case EQNEQUAL: + ParserError("Invalid right hand side of equation"); + break; + case EQNCOLON: + ParserError("Missing rate after '%s'", crtToken ); + break; + case EQNSIGN: + ParserError("Missing coeficient after '%s'", crtToken ); + break; + case EQNCOEF: + ParserError("Missing species after '%s'", crtToken ); + break; + case RATE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case LMPSPC: + ParserError("Missing '+' or ':' or ';' after '%s'", crtToken ); + break; + case LMPPLUS: + ParserError("Missing species after '%s'", crtToken ); + break; + case LMPCOLON: + ParserError("Missing species after '%s'", crtToken ); + break; + case INLINE: + ParserError("Missing inline option after '%s'", crtToken ); + break; + + default: + ParserError("Syntax error after '%s'", crtToken ); + } +} + + +int Parser( char * filename ) +{ +extern int yydebug; +FILE *f; + + crt_filename = filename; + + f = fopen( crt_filename, "r" ); + if( f == 0 ) { + FatalError(7,"%s: File not found", crt_filename); + } + + yyin = f; + nError = 0; + nWarning = 0; + yydebug = 0; + + yyparse(); + + fclose( f ); + + return nError; +} + +#line 1109 "y.tab.c" +#define YYABORT goto yyabort +#define YYREJECT goto yyabort +#define YYACCEPT goto yyaccept +#define YYERROR goto yyerrlab +int +#if defined(__STDC__) +yyparse(void) +#else +yyparse() +#endif +{ + register int yym, yyn, yystate; +#if YYDEBUG + register char *yys; + extern char *getenv(); + + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; + if (yyn >= '0' && yyn <= '9') + yydebug = yyn - '0'; + } +#endif + + yynerrs = 0; + yyerrflag = 0; + yychar = (-1); + + yyssp = yyss; + yyvsp = yyvs; + *yyssp = yystate = 0; + +yyloop: + if ((yyn = yydefred[yystate]) != 0) goto yyreduce; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + } + if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, shifting to state %d\n", + YYPREFIX, yystate, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + yychar = (-1); + if (yyerrflag > 0) --yyerrflag; + goto yyloop; + } + if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { + yyn = yytable[yyn]; + goto yyreduce; + } + if (yyerrflag) goto yyinrecovery; + yyerror("syntax error"); +#ifdef lint + goto yyerrlab; +#endif +yyerrlab: + ++yynerrs; +yyinrecovery: + if (yyerrflag < 3) + { + yyerrflag = 3; + for (;;) + { + if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, error recovery shifting\ + to state %d\n", YYPREFIX, *yyssp, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + goto yyloop; + } + else + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: error recovery discarding state %d\n", + YYPREFIX, *yyssp); +#endif + if (yyssp <= yyss) goto yyabort; + --yyssp; + --yyvsp; + } + } + } + else + { + if (yychar == 0) goto yyabort; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, error recovery discards token %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + yychar = (-1); + goto yyloop; + } +yyreduce: +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, reducing by rule %d (%s)\n", + YYPREFIX, yystate, yyn, yyrule[yyn]); +#endif + yym = yylen[yyn]; + yyval = yyvsp[1-yym]; + switch (yyn) + { +case 3: +#line 95 "scan.y" +{ CmdJacobian( yyvsp[0].str ); + } +break; +case 4: +#line 98 "scan.y" +{ CmdHessian( yyvsp[0].str ); + } +break; +case 5: +#line 101 "scan.y" +{ CmdStoicmat( yyvsp[0].str ); + } +break; +case 6: +#line 104 "scan.y" +{ CmdDouble( yyvsp[0].str ); + } +break; +case 7: +#line 107 "scan.y" +{ CmdReorder( yyvsp[0].str ); + } +break; +case 8: +#line 110 "scan.y" +{ CmdMex( yyvsp[0].str ); + } +break; +case 9: +#line 113 "scan.y" +{ CmdDummyindex( yyvsp[0].str ); + } +break; +case 10: +#line 116 "scan.y" +{ CmdEqntags( yyvsp[0].str ); + } +break; +case 11: +#line 119 "scan.y" +{ CmdFunction( yyvsp[0].str ); + } +break; +case 12: +#line 122 "scan.y" +{ CmdStochastic( yyvsp[0].str ); + } +break; +case 13: +#line 125 "scan.y" +{} +break; +case 14: +#line 127 "scan.y" +{} +break; +case 15: +#line 129 "scan.y" +{} +break; +case 16: +#line 131 "scan.y" +{} +break; +case 17: +#line 133 "scan.y" +{} +break; +case 18: +#line 135 "scan.y" +{} +break; +case 19: +#line 137 "scan.y" +{} +break; +case 20: +#line 139 "scan.y" +{} +break; +case 21: +#line 141 "scan.y" +{} +break; +case 22: +#line 143 "scan.y" +{} +break; +case 23: +#line 145 "scan.y" +{} +break; +case 24: +#line 147 "scan.y" +{} +break; +case 25: +#line 149 "scan.y" +{} +break; +case 26: +#line 151 "scan.y" +{} +break; +case 27: +#line 153 "scan.y" +{ CheckAll(); } +break; +case 28: +#line 155 "scan.y" +{ LookAtAll(); } +break; +case 29: +#line 157 "scan.y" +{ TransportAll(); } +break; +case 30: +#line 159 "scan.y" +{ WriteAtoms(); } +break; +case 31: +#line 161 "scan.y" +{ WriteSpecies(); } +break; +case 32: +#line 163 "scan.y" +{ WriteMatrices(); } +break; +case 33: +#line 165 "scan.y" +{ WriteOptions(); } +break; +case 34: +#line 167 "scan.y" +{ CmdUse( yyvsp[0].str ); } +break; +case 35: +#line 169 "scan.y" +{ CmdLanguage( yyvsp[0].str ); } +break; +case 36: +#line 171 "scan.y" +{ DefineInitializeNbr( yyvsp[0].str ); } +break; +case 37: +#line 173 "scan.y" +{ DefineXGrid( yyvsp[0].str ); } +break; +case 38: +#line 175 "scan.y" +{ DefineYGrid( yyvsp[0].str ); } +break; +case 39: +#line 177 "scan.y" +{ DefineZGrid( yyvsp[0].str ); } +break; +case 40: +#line 179 "scan.y" +{ + AddInlineCode( yyvsp[-2].str, InlineBuf ); + free( InlineBuf ); + } +break; +case 41: +#line 184 "scan.y" +{ ParserErrorMessage(); } +break; +case 42: +#line 186 "scan.y" +{ CmdIntegrator( yyvsp[0].str ); } +break; +case 43: +#line 188 "scan.y" +{ CmdDriver( yyvsp[0].str ); } +break; +case 44: +#line 190 "scan.y" +{ CmdRun( yyvsp[0].str ); } +break; +case 45: +#line 192 "scan.y" +{} +break; +case 46: +#line 194 "scan.y" +{ SparseData( yyvsp[0].str ); + } +break; +case 47: +#line 198 "scan.y" +{ ScanWarning("Unnecessary ';'"); + } +break; +case 51: +#line 205 "scan.y" +{ ParserErrorMessage(); } +break; +case 52: +#line 208 "scan.y" +{ switch( crt_section ) { + case ATOMDECL: DeclareAtom( yyvsp[0].str ); break; + case CHECK: SetAtomType( yyvsp[0].str, DO_CHECK ); break; + } + } +break; +case 55: +#line 217 "scan.y" +{ ParserErrorMessage(); } +break; +case 56: +#line 220 "scan.y" +{ AddLookAt( yyvsp[0].str ); + } +break; +case 59: +#line 226 "scan.y" +{ ParserErrorMessage(); } +break; +case 60: +#line 229 "scan.y" +{ AddMonitor( yyvsp[0].str ); + } +break; +case 63: +#line 235 "scan.y" +{ ParserErrorMessage(); } +break; +case 64: +#line 238 "scan.y" +{ AddTransport( yyvsp[0].str ); + } +break; +case 67: +#line 244 "scan.y" +{ ParserErrorMessage(); } +break; +case 68: +#line 247 "scan.y" +{ AddUseFile( yyvsp[0].str ); + } +break; +case 71: +#line 253 "scan.y" +{ ParserErrorMessage(); } +break; +case 72: +#line 256 "scan.y" +{ switch( crt_section ) { + case SETVAR: SetSpcType( VAR_SPC, yyvsp[0].str ); break; + case SETRAD: SetSpcType( RAD_SPC, yyvsp[0].str ); break; + case SETFIX: SetSpcType( FIX_SPC, yyvsp[0].str ); break; + } + } +break; +case 75: +#line 266 "scan.y" +{ ParserErrorMessage(); } +break; +case 78: +#line 272 "scan.y" +{ switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, yyvsp[-2].str ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, yyvsp[-2].str ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, yyvsp[-2].str ); break; + } + } +break; +case 79: +#line 280 "scan.y" +{ switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, yyvsp[0].str ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, yyvsp[0].str ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, yyvsp[0].str ); break; + } + } +break; +case 82: +#line 291 "scan.y" +{ AddAtom( yyvsp[0].str, yyvsp[-1].str ); + } +break; +case 83: +#line 294 "scan.y" +{ AddAtom( yyvsp[0].str, "1" ); + } +break; +case 86: +#line 300 "scan.y" +{ ParserErrorMessage(); } +break; +case 87: +#line 303 "scan.y" +{ AssignInitialValue( yyvsp[-2].str, yyvsp[0].str ); } +break; +case 90: +#line 308 "scan.y" +{ ParserErrorMessage(); + eqState = LHS; + } +break; +case 91: +#line 313 "scan.y" +{ eqState = LHS; + StoreEquationRate( yyvsp[0].str, yyvsp[-3].str ); + CheckEquation(); + } +break; +case 92: +#line 318 "scan.y" +{ eqState = LHS; + StoreEquationRate( yyvsp[0].str, " " ); + CheckEquation(); + } +break; +case 93: +#line 323 "scan.y" +{ strcpy( yyval.str, yyvsp[-1].str ); + strcat( yyval.str, yyvsp[0].str ); + } +break; +case 94: +#line 327 "scan.y" +{ strcpy( yyval.str, yyvsp[0].str ); + } +break; +case 95: +#line 331 "scan.y" +{ strcpy( yyval.str, yyvsp[-1].str ); + } +break; +case 96: +#line 335 "scan.y" +{ eqState = RHS; } +break; +case 97: +#line 338 "scan.y" +{ eqState = RAT; } +break; +case 98: +#line 341 "scan.y" +{ ProcessTerm( eqState, yyvsp[-1].str, crt_coef, crt_term ); + } +break; +case 99: +#line 344 "scan.y" +{ ProcessTerm( eqState, yyvsp[-1].str, crt_coef, crt_term ); + } +break; +case 100: +#line 347 "scan.y" +{ ProcessTerm( eqState, "+", crt_coef, crt_term ); + } +break; +case 101: +#line 351 "scan.y" +{ strcpy( crt_term, yyvsp[0].str ); + strcpy( crt_coef, yyvsp[-1].str ); + } +break; +case 102: +#line 355 "scan.y" +{ strcpy( crt_term, yyvsp[0].str ); + strcpy( crt_coef, "1" ); + } +break; +case 105: +#line 362 "scan.y" +{ ParserErrorMessage(); } +break; +case 106: +#line 365 "scan.y" +{ AddLumpSpecies( yyvsp[-2].str ); + } +break; +case 107: +#line 368 "scan.y" +{ + AddLumpSpecies( yyvsp[-2].str ); + CheckLump( yyvsp[0].str ); + } +break; +case 108: +#line 373 "scan.y" +{ + InlineBuf = AppendString( InlineBuf, yyvsp[0].str, &InlineLen, MAX_INLINE ); + } +break; +case 109: +#line 377 "scan.y" +{ + InlineBuf = malloc( MAX_INLINE ); + InlineLen = MAX_INLINE; + strcpy( InlineBuf, yyvsp[0].str); + } +break; +#line 1647 "y.tab.c" + } + yyssp -= yym; + yystate = *yyssp; + yyvsp -= yym; + yym = yylhs[yyn]; + if (yystate == 0 && yym == 0) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state 0 to\ + state %d\n", YYPREFIX, YYFINAL); +#endif + yystate = YYFINAL; + *++yyssp = YYFINAL; + *++yyvsp = yyval; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, YYFINAL, yychar, yys); + } +#endif + } + if (yychar == 0) goto yyaccept; + goto yyloop; + } + if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yystate) + yystate = yytable[yyn]; + else + yystate = yydgoto[yym]; +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state %d \ +to state %d\n", YYPREFIX, *yyssp, yystate); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate; + *++yyvsp = yyval; + goto yyloop; +yyoverflow: + yyerror("yacc stack overflow"); +yyabort: + return (1); +yyaccept: + return (0); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.h new file mode 100755 index 00000000..d60aacb6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src.org/y.tab.h @@ -0,0 +1,77 @@ +#define JACOBIAN 257 +#define DOUBLE 258 +#define FUNCTION 259 +#define DEFVAR 260 +#define DEFRAD 261 +#define DEFFIX 262 +#define SETVAR 263 +#define SETRAD 264 +#define SETFIX 265 +#define HESSIAN 266 +#define STOICMAT 267 +#define STOCHASTIC 268 +#define INITVALUES 269 +#define EQUATIONS 270 +#define LUMP 271 +#define INIEQUAL 272 +#define EQNEQUAL 273 +#define EQNCOLON 274 +#define LMPCOLON 275 +#define LMPPLUS 276 +#define SPCPLUS 277 +#define SPCEQUAL 278 +#define ATOMDECL 279 +#define CHECK 280 +#define CHECKALL 281 +#define REORDER 282 +#define MEX 283 +#define DUMMYINDEX 284 +#define EQNTAGS 285 +#define LOOKAT 286 +#define LOOKATALL 287 +#define TRANSPORT 288 +#define TRANSPORTALL 289 +#define MONITOR 290 +#define USES 291 +#define SPARSEDATA 292 +#define WRFCONFORM 293 +#define WRITE_ATM 294 +#define WRITE_SPC 295 +#define WRITE_MAT 296 +#define WRITE_OPT 297 +#define INITIALIZE 298 +#define XGRID 299 +#define YGRID 300 +#define ZGRID 301 +#define USE 302 +#define LANGUAGE 303 +#define INTFILE 304 +#define DRIVER 305 +#define RUN 306 +#define INLINE 307 +#define ENDINLINE 308 +#define PARAMETER 309 +#define SPCSPC 310 +#define INISPC 311 +#define INIVALUE 312 +#define EQNSPC 313 +#define EQNSIGN 314 +#define EQNCOEF 315 +#define RATE 316 +#define LMPSPC 317 +#define SPCNR 318 +#define ATOMID 319 +#define LKTID 320 +#define MNIID 321 +#define INLCTX 322 +#define INCODE 323 +#define SSPID 324 +#define EQNLESS 325 +#define EQNTAG 326 +#define EQNGREATER 327 +#define TPTID 328 +#define USEID 329 +typedef union{ + char str[80]; +} YYSTYPE; +extern YYSTYPE yylval; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile new file mode 100755 index 00000000..adbf2fb2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile @@ -0,0 +1,94 @@ +######################################################################################## +# +# KPP - The Kinetic PreProcessor +# Builds simulation code for chemical kinetic systems +# +# Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu +# Copyright (C) 1997-2005 Adrian Sandu +# with contributions from: Mirela Damian, Rolf Sander +# +# KPP is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the +# License, or (at your option) any later version. +# +# KPP is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along +## with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or +# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. +# +# Adrian Sandu +# Computer Science Department +# Virginia Polytechnic Institute and State University +# Blacksburg, VA 24060 +# E-mail: sandu@cs.vt.edu +# +# +# modified by M. Salzmann, MPI for Chemistry, Mainz, Germany +# for usage with KPP +# +####################################################################################### + +include ../Makefile.defs + + +#!cmsCFLAGS=`cat ../cflags` +#CFLAGS= -Aa +CFLAGS= +CLFLAGS = -lm + +all: kpp + +.c.o: + @echo " "$(SCC) $(CC_FLAGS) $(CFLAGS) -c $*.c + @$(SCC) $(CC_FLAGS) $(CFLAGS) -c $*.c + +OBJS = \ + y.tab.o \ + lex.yy.o \ + scanner.o \ + scanutil.o \ + kpp.o \ + gen.o \ + code.o \ + code_c.o \ + code_f77.o \ + code_f90.o \ + code_matlab.o \ + debug.o + +kpp: $(OBJS) + @echo " "$(SCC) $(CC_FLAGS) $(CLFLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp + @$(SCC) $(CC_FLAGS) $(CFLAGS) $(CLFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -o kpp + @mv kpp ../bin + +clean: + @rm -f *~ *.o cflags + +maintainer-clean: clean + @rm -f lex.yy.c y.tab.c y.tab.h + +lex.yy.c: scan.l scan.h + @echo " "$(FLEX) scan.l + @$(FLEX) scan.l + +y.tab.c: scan.y scan.h + @echo " "$(YACC) scan.y + @$(YACC) scan.y + +flex: lex.yy.c y.tab.c + +scanner.o: scan.h gdata.h +scanutil.o: scan.h +kpp.o: gdata.h +gen.o: gdata.h code.h +debug.o: gdata.h +code.o: gdata.h code.h + +code_c.o: gdata.h code.h +code_f.o: gdata.h code.h diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.c new file mode 100755 index 00000000..01e5df42 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.c @@ -0,0 +1,820 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include +#include + +/* NONE, ADD, SUB, MUL, DIV, POW, CONST, ELM, VELM, MELM, EELM */ +int PRI[] = { 10, 1, 1, 2, 2, 3, 10, 10, 10, 10, 10 }; + +void (*WriteElm)( NODE *n ); +void (*WriteSymbol)( int op ); +void (*WriteAssign)( char* lval, char* rval ); +void (*WriteComment)( char *fmt, ... ); +void (*Declare)( int v ); +void (*ExternDeclare)( int v ); +void (*GlobalDeclare)( int v ); +void (*InitDeclare)( int var, int nv, void * values ); +void (*DeclareConstant)( int v, char *val ); +void (*FunctionStart)( int f, int *vars ); +void (*FunctionPrototipe)( int f, ... ); +void (*FunctionBegin)( int f, ... ); +void (*FunctionEnd)( int f ); + +NODE * substList; +int substENABLED = 1; +int crtop = NONE; +char *outBuf; +char *outBuffer; + +VARIABLE cnst = { "", CONST, REAL, 0, 0 }; +VARIABLE expr = { "", EELM, 0, 0, 0 }; +VARIABLE *varTable[ MAX_VAR ] = { &cnst, &expr }; + +int IsConst( NODE *n, float val ); +NODE * BinaryOp( int op, NODE *n1, NODE *n2 ); +int NodeCmp( NODE *n1, NODE *n2 ); +NODE * NodeCopy( NODE *n1 ); +void WriteNode( NODE *n ); +void WriteOp( int op ); +void ExpandElm( NODE * n ); +int ExpandNode( NODE *n, int lastop ); +NODE * LookUpSubst( NODE *n ); + +FILE * param_headerFile = 0; +FILE * initFile = 0; /* mz_rs_20050117 */ +FILE * driverFile = 0; +FILE * integratorFile = 0; +FILE * linalgFile = 0; +FILE * functionFile = 0; +FILE * jacobianFile = 0; +FILE * rateFile = 0; +FILE * stoichiomFile = 0; +FILE * utilFile = 0; +FILE * sparse_dataFile = 0; +FILE * sparse_jacFile = 0; +FILE * sparse_hessFile = 0; +FILE * sparse_stoicmFile = 0; +FILE * stochasticFile = 0; +FILE * global_dataFile = 0; +FILE * hessianFile = 0; +FILE * mapFile = 0; +FILE * makeFile = 0; +FILE * monitorFile = 0; +FILE * mex_funFile = 0; +FILE * mex_jacFile = 0; +FILE * mex_hessFile = 0; +FILE * wrf_UpdateRconstFile = 0; + + +FILE * currentFile; + +int ident = 0; + +FILE * UseFile( FILE * file ) +{ +FILE *oldf; + if (file == NULL) { + printf("\n\nKPP Warning (internal): trying to UseFile NULL file pointer!\n"); + } + oldf = currentFile; + currentFile = file; + return oldf; +} + +void OpenFile( FILE **fpp, char *name, char * ext, char * identity ) +{ +char bufname[200]; +char buf[200]; +time_t t; +int blength; + + time( &t ); + sprintf( bufname, "%s%s", name, ext ); + if( *fpp ) fclose( *fpp ); + *fpp = fopen( bufname, "w" ); + if ( *fpp == 0 ) + FatalError(3,"%s: Can't create file", bufname ); + + UseFile( *fpp ); + + WriteDelim(); + WriteComment(""); + WriteComment("%s",identity); + WriteComment(""); + WriteComment("Generated by KPP-%s symbolic chemistry Kinetics PreProcessor", + KPP_VERSION ); + WriteComment(" (http://www.cs.vt.edu/~asandu/Software/KPP)"); + WriteComment("KPP is distributed under GPL, the general public licence"); + WriteComment(" (http://www.gnu.org/copyleft/gpl.html)"); + WriteComment("(C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa" ); + WriteComment("(C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech" ); + WriteComment(" With important contributions from:" ); + WriteComment(" M. Damian, Villanova University, USA"); + WriteComment(" R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany"); + WriteComment(""); + WriteComment("%-20s : %s", "File", bufname ); + strcpy( buf, ctime( &t ) ); + buf[ (int)strlen(buf) - 1 ] = 0; + WriteComment("%-20s : %s", "Time", buf ); + WriteComment("%-20s : %s", "Working directory", getcwd(buf, 200) ); + WriteComment("%-20s : %s", "Equation file", eqFileName ); + WriteComment("%-20s : %s", "Output root filename", rootFileName ); + WriteComment(""); + WriteDelim(); + NewLines(1); +/* Include Headers in .c Files, except Makefile */ + blength = strlen(bufname); + if ( (bufname[blength-2]=='.')&&(bufname[blength-1]=='c') ) { + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include "); + C_Inline("#include \"%s_Parameters.h\"", rootFileName); + C_Inline("#include \"%s_Global.h\"", rootFileName); + if( useJacSparse ) + C_Inline("#include \"%s_Sparse.h\"", rootFileName); + } + NewLines(2); +} + +void AllowBreak() +{ + *(outBuffer-1) |= 0x80; +} + +void bprintf( char *fmt, ... ) +{ +Va_list args; + + if ( !fmt ) return; + Va_start( args, fmt ); + vsprintf( outBuffer, fmt, args ); + va_end( args ); + outBuffer += strlen( outBuffer ); +} + +void FlushBuf() +{ +char *p; + + p = outBuf; + while( *p ) + *p++ &= ~0x80; + fprintf( currentFile, outBuf ); + outBuffer = outBuf; + *outBuffer = 0; +} + +void FlushThisBuf( char * buf ) +{ +char *p; + + p = buf; + while( *p ) + *p++ &= ~0x80; + fprintf( currentFile, buf ); +} + +void WriteDelim() +{ +/* + WriteComment("****************************************************************"); +*/ + WriteComment("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); +} + +void NewLines( int n ) +{ + for( ; n > 0; n-- ) + bprintf("\n"); + + FlushBuf(); +} + +void IncludeFile( char * fname ) +{ +FILE *fp; +#define MAX_LINE 200 +char line[ MAX_LINE ]; + + + fp = fopen( fname, "r" ); + if ( fp == 0 ) + FatalError(3,"%s: Can't read file", fname ); + + FlushBuf(); + + while( !feof(fp) ) { + *line = '\0'; + fgets( line, MAX_LINE, fp ); + fputs( line, currentFile ); + } + + fclose( fp ); +} + +void IncludeCode( char* fmt, ... ) +{ +Va_list args; +char buf[200]; +char cmd[500]; +static char tmpfile[] = "kppfile.tmp"; +FILE * fp; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + switch( useLang ) { + case F77_LANG: sprintf( buf, "%s.f", buf ); + break; + case F90_LANG: sprintf( buf, "%s.f90", buf ); + break; + case C_LANG: sprintf( buf, "%s.c", buf ); + break; + case MATLAB_LANG: sprintf( buf, "%s.m", buf ); + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + fp = fopen( buf, "r" ); + if ( fp == 0 ) + FatalError(3,"%s: Can't read file", buf ); + fclose(fp); + + strcpy( cmd, "sed " ); + + sprintf( cmd, "%s -e 's/KPP_ROOT/%s/g'", cmd, rootFileName ); + sprintf( cmd, "%s -e 's/KPP_NVAR/%d/g'", cmd, VarNr ); + sprintf( cmd, "%s -e 's/KPP_NFIX/%d/g'", cmd, FixNr ); + sprintf( cmd, "%s -e 's/KPP_NSPEC/%d/g'", cmd,SpcNr ); + sprintf( cmd, "%s -e 's/KPP_NREACT/%d/g'", cmd, EqnNr ); + sprintf( cmd, "%s -e 's/KPP_NONZERO/%d/g'", cmd, Jac_NZ ); + sprintf( cmd, "%s -e 's/KPP_LU_NONZERO/%d/g'", cmd, LU_Jac_NZ ); + sprintf( cmd, "%s -e 's/KPP_NHESS/%d/g'", cmd, Hess_NZ ); + + switch( useLang ) { + case F77_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, F77_types[real] ); + break; + case F90_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, F90_types[real] ); + break; + case C_LANG: + sprintf( cmd, "%s -e 's/KPP_REAL/%s/g'", cmd, C_types[real] ); + break; + case MATLAB_LANG: + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + + sprintf( cmd, "%s %s > %s", cmd, buf, tmpfile ); + + system( cmd ); + IncludeFile( tmpfile ); + sprintf( cmd, "rm %s", tmpfile ); + system( cmd ); +} + +void MapFunctionComment( int f, int *vars ) +{ +FILE *oldf; + + oldf = UseFile( mapFile ); + FunctionStart( f, vars ); + /*NewLines(1); + CommentFncBegin( f, vars );*/ + FlushBuf(); + UseFile( oldf ); +} + +int DefineVariable( char * name, int t, int bt, int maxi, int maxj, char * comment ) +{ +int i; +VARIABLE * var; + + for( i = 0; i < MAX_VAR; i++ ) + if( varTable[ i ] == 0 ) break; + + if( varTable[ i ] != 0 ) { + printf("\nVariable Table overflow"); + return -1; + } + + var = (VARIABLE*) malloc( sizeof( VARIABLE ) ); + var->name = name; + var->type = t; + var->baseType = bt; + var->maxi = maxi; + var->maxj = maxj; + var->value = -1; + var->comment = comment; + + varTable[ i ] = var; + return i; +} + +void FreeVariable( int n ) +{ + if( varTable[ n ] ) { + free( varTable[ n ] ); + varTable[ n ] = 0; + } +} + +NODE * Elm( int v, ... ) +{ +Va_list args; +NODE *n; +ELEMENT *elm; +VARIABLE *var; +int i, j; +float val; +char *expr; + + var = varTable[ v ]; + n = (NODE*) malloc( sizeof(NODE) ); + elm = (ELEMENT*) malloc( sizeof(ELEMENT) ); + n->left = 0; + n->right = 0; + n->sign = 1; + n->type = var->type; + n->elm = elm; + elm->var = v; + + Va_start( args, v ); + switch( var->type ) { + case CONST: switch( var->baseType ) { + case REAL: elm->val.cnst = (float)va_arg( args, double ); + break; + case INT: elm->val.cnst = (float)va_arg( args, int ); + } + if( elm->val.cnst < 0 ) { + elm->val.cnst = -elm->val.cnst; + n->sign = -1; + } + break; + case ELM: + break; + case VELM: elm->val.idx.i = va_arg( args, int ); + break; + case MELM: elm->val.idx.i = va_arg( args, int ); + elm->val.idx.j = va_arg( args, int ); + break; + case EELM: elm->val.expr = va_arg( args, char* ); + break; + } + va_end( args ); + + return n; +} + +int IsConst( NODE *n, float val ) +{ + return ( ( n ) && + ( n->type == CONST ) && + ( n->elm->val.cnst == val ) + ); +} + +NODE * BinaryOp( int op, NODE *n1, NODE *n2 ) +{ +NODE *n; + + n = (NODE*) malloc( sizeof(NODE) ); + n->left = n1; + n->right = n2; + n->type = op; + n->sign = 1; + n->elm = 0; + return n; +} + +NODE * Add( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + + if( IsConst( n1, 0 ) ) { + FreeNode( n1 ); + return n2; + } + if( IsConst( n2, 0 ) ) { + FreeNode( n2 ); + return n1; + } + return BinaryOp( ADD, n1, n2 ); +} + +NODE * Sub( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return BinaryOp( SUB, 0, n2 ); + if( n2 == 0 ) return n1; + + if( IsConst( n1, 0 ) ) { + FreeNode( n1 ); + return BinaryOp( SUB, 0, n2 ); + } + if( IsConst( n2, 0 ) ) { + FreeNode( n2 ); + return n1; + } + return BinaryOp( SUB, n1, n2 ); +} + +NODE * Mul( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + + if( IsConst( n1, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n1 ); + return n2; + } + if( IsConst( n2, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n2 ); + return n1; + } + if( IsConst( n1, 0 ) ) { + FreeNode( n2 ); + return n1; + } + if( IsConst( n2, 0 ) ) { + FreeNode( n1 ); + return n2; + } + + return BinaryOp( MUL, n1, n2 ); +} + +NODE * Div( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return BinaryOp( DIV, Const(1), n2 ); + if( n2 == 0 ) return n1; + + if( IsConst( n2, 1 ) ) { + n2->sign *= n1->sign; + FreeNode( n2 ); + return n1; + } + + return BinaryOp( DIV, n1, n2 ); +} + +NODE * Pow( NODE *n1, NODE *n2 ) +{ + if( n1 == 0 ) return n2; + if( n2 == 0 ) return n1; + return BinaryOp( POW, n1, n2 ); +} + +void FreeNode( NODE * n ) +{ + if( n == 0 ) return; + FreeNode( n->left ); + FreeNode( n->right ); + if( n->elm ) free( n->elm ); + free( n ); +} + +int NodeCmp( NODE *n1, NODE *n2 ) +{ +ELEMENT *elm1; +ELEMENT *elm2; + + if( n1 == n2 ) return 1; + if( n1 == 0 ) return 0; + if( n2 == 0 ) return 0; + + if( (n1->type % SUBST) != (n2->type % SUBST) ) return 0; + + elm1 = n1->elm; + elm2 = n2->elm; + + if( elm1 == elm2 ) return 1; + if( elm1 == 0 ) return 0; + if( elm2 == 0 ) return 0; + + if( elm1->var != elm2->var )return 0; + switch( n1->type ) { + case CONST: if( elm1->val.cnst != elm2->val.cnst ) return 0; + break; + case ELM: break; + case VELM: if( elm1->val.idx.i != elm2->val.idx.i ) return 0; + break; + case MELM: if( elm1->val.idx.i != elm2->val.idx.i ) return 0; + if( elm1->val.idx.j != elm2->val.idx.j ) return 0; + break; + case EELM: if( strcmp( elm1->val.expr, elm2->val.expr ) != 0 ) return 0; + break; + } + + return 1; +} + +NODE * NodeCopy( NODE *n1 ) +{ +NODE *n; +ELEMENT *elm; + + n = (NODE*) malloc( sizeof(NODE) ); + elm = (ELEMENT*) malloc( sizeof(ELEMENT) ); + *n = *n1; + n->elm = elm; + *n->elm = *n1->elm; + return n; +} + +void WriteNode( NODE *n ) +{ + crtop = NONE; + ExpandNode( n, NONE ); +} + +void WriteOp( int op ) +{ + WriteSymbol( op ); + crtop = NONE; +} + +void ExpandElm( NODE * n ) +{ +NODE *cn; + + if( substENABLED == 0 ) { + WriteElm( n ); + return; + } + cn = LookUpSubst( n ); + if( cn == 0 ) { + WriteElm( n ); + } else { + if( cn->type > SUBST ) { + WriteElm( n ); + } else { + cn->type += SUBST; + WriteSymbol( O_PAREN ); + WriteNode( cn->right ); + WriteSymbol( C_PAREN ); + cn->type -= SUBST; + } + } +} + +int ExpandNode( NODE *n, int lastop ) +{ +int needParen = 0; + + if( n == 0 ) return lastop; + + if( ( n->left ) && + ( PRI[ n->left->type ] < PRI[ n->type ] ) ) + needParen = 1; + + if( needParen ) { + WriteOp( crtop ); + WriteSymbol( O_PAREN ); + } + lastop = ExpandNode( n->left, lastop ); + if( needParen ) WriteSymbol( C_PAREN ); + + switch( n->type ) { + case ADD: + case SUB: + case MUL: + case DIV: + case POW: crtop = n->type; + break; + case NONE: printf("ERROR - null element"); + break; + case CONST: + case ELM: + case VELM: + case MELM: + case EELM: + switch( crtop ) { + case MUL: case DIV: case POW: + WriteOp( crtop ); + if ( n->sign == -1 ) { + WriteSymbol( O_PAREN ); + WriteOp( SUB ); + ExpandElm( n ); + WriteSymbol( C_PAREN ); + } else { + ExpandElm( n ); + } + break; + case ADD: if( n->sign == -1 ) + crtop = SUB; + WriteOp( crtop ); + ExpandElm( n ); + break; + case SUB: if( n->sign == -1 ) + crtop = ADD; + WriteOp( crtop ); + ExpandElm( n ); + break; + case NONE: if( n->sign == -1 ) + WriteOp( SUB ); + ExpandElm( n ); + break; + } + break; + } + + if( ( n->right ) && + ( PRI[ n->right->type ] <= PRI[ n->type ] ) ) + needParen = 1; + + if( needParen ) { + WriteOp( crtop ); + WriteSymbol( O_PAREN ); + } + lastop = ExpandNode( n->right, n->type ); + if( needParen ) WriteSymbol( C_PAREN ); + return lastop; +} + +void Assign( NODE *lval, NODE *rval ) +{ +char *ls; +char *rs; +char *olds; + + ls = (char*)malloc( MAX_OUTBUF ); + rs = (char*)malloc( MAX_OUTBUF ); + + olds = outBuffer; + outBuffer = ls; + WriteNode( lval ); + outBuffer = rs; + WriteNode( rval ); + outBuffer = olds; + + WriteAssign( ls, rs ); + + free( rs ); + free( ls ); + FreeNode( lval ); + FreeNode( rval ); +} + +NODE * LookUpSubst( NODE *n ) +{ +NODE *cn; + + cn = substList; + while( cn != 0 ) { + if( NodeCmp( n, cn ) ) + return cn; + cn = cn->left; + } + return 0; +} + +void MkSubst( NODE *n1, NODE *n2 ) +{ +NODE *n; + + n = LookUpSubst( n1 ); + if( n == 0 ) { + n = n1; + n->left = substList; + substList = n; + } else { + FreeNode( n->right ); + FreeNode( n1 ); + } + n->right = n2; +} + +void RmSubst( NODE *n ) +{ +NODE *pn; +NODE *cn; + + pn = 0; + cn = substList; + while( cn != 0 ) { + if( NodeCmp( n, cn ) ) + break; + pn = cn; + cn = cn->left; + } + if( cn == 0 ) return; + + FreeNode( cn->right ); + if( pn ) + pn->left = cn->left; + else + substList = cn->left; + + cn->right = 0; + cn->left = 0; + FreeNode( cn ); +} + +void DisplaySubst() +{ +NODE *n; + + n = substList; + substENABLED = 0; + while( n != 0 ) { + printf("Subst: "); + WriteElm( n ); + printf( " --> " ); + WriteNode( n->right ); + printf("\n"); + n = n->left; + } + substENABLED = 1; +} + +void CommentFncBegin( int f, int *vars ) +{ +VARIABLE *var; +char * name; +int narg; +int i; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + var = varTable[ f ]; + + WriteDelim(); + WriteComment(""); + WriteComment("%s - %s", var->name, var->comment ); + WriteComment(" Arguments :"); + for( i = 0; i < narg; i++ ) { + var = varTable[vars[i]]; + WriteComment(" %-10s- %s", var->name, var->comment ); + } + WriteComment(""); + WriteDelim(); + NewLines(1); +} + +void CommentFunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + /* MapFunctionComment( f, vars ); */ +} + +void CommentFunctionEnd( int f ) +{ + WriteComment("End of %s function", varTable[ f ]->name ); + WriteDelim(); + NewLines(2); +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.h new file mode 100755 index 00000000..a40de2de --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code.h @@ -0,0 +1,191 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#ifndef _CODE_H_ +#define _CODE_H_ + +#include +#include "gdef.h" + +#define MAX_DEPTH 10 +#define MAX_SUBST 20 +#define SUBST 100 +#define MAX_VAR 150 +#define MAX_OUTBUF 200000 +#define MAX_COLS 8 +#define MAX_LINES 20 + +#define WriteAll bprintf + +enum types { NONE, ADD, SUB, MUL, DIV, POW, CONST, ELM, VELM, MELM, EELM, FNC }; +extern int PRI[]; + +enum signs { O_PAREN = 20, C_PAREN }; +enum base_types { VOID, INT, REAL, DOUBLE, STRING, DOUBLESTRING }; +/* mz_rs_20050117+ */ +extern FILE * initFile; +/* mz_rs_20050117- */ +extern FILE * driverFile; +extern FILE * functionFile; +extern FILE * global_dataFile; +extern FILE * hessianFile; +extern FILE * integratorFile; +extern FILE * jacobianFile; +extern FILE * linalgFile; +extern FILE * mapFile; +extern FILE * makeFile; +extern FILE * monitorFile; +extern FILE * mex_funFile; +extern FILE * mex_jacFile; +extern FILE * mex_hessFile; +extern FILE * param_headerFile; +extern FILE * rateFile; +extern FILE * sparse_dataFile; +extern FILE * sparse_jacFile; +extern FILE * sparse_hessFile; +extern FILE * sparse_stoicmFile; +extern FILE * stoichiomFile; +extern FILE * stochasticFile; +extern FILE * utilFile; +extern FILE * wrf_UpdateRconstFile; + +extern FILE * currentFile; + +extern int ident; +extern int real; +extern char * CommonName; + +void OpenFile( FILE **fpp, char *name, char * ext, char * identity ); +FILE * UseFile( FILE *fp ); + +typedef struct { + char *name; + int type; + int baseType; + int maxi; + int maxj; + int value; + char *comment; + } VARIABLE; + +extern VARIABLE* varTable[]; + +extern char *outBuf; +extern char *outBuffer; + +void AllowBreak(); +void bprintf( char *fmt, ... ); +void FlushBuf(); +void FlushThisBuf( char * buf ); +void NewLines( int n ); +void C_Inline( char *fmt, ... ); +void F77_Inline( char *fmt, ... ); +void IncludeFile( char * fname ); +void IncludeCode( char *fmt, ... ); +void MapFunctionComment( int f, int *vars ); + +int DefineVariable( char * name, int t, int bt, int maxi, int maxj, char * comment ); +void FreeVariable( int n ); + +#define DefConst( name, bt, cmt ) DefineVariable( name, CONST, bt, 0, 0, cmt ) +#define DefElm( name, bt, cmt ) DefineVariable( name, ELM, bt, 0, 0, cmt ) +#define DefvElm( name, bt, n, cmt ) DefineVariable( name, VELM, bt, n, 0, cmt ) +#define DefmElm( name, bt, m, n, cmt ) DefineVariable( name, MELM, bt, m, n, cmt ) +#define DefeElm( name, cmt ) DefineVariable( name, EELM, 0, 0, 0, cmt ) +#define DefFnc( name, n, cmt ) DefineVariable( name, FNC, 0, n, 0, cmt ) + +typedef struct { + int var; + union { + char * expr; + float cnst; + struct { + int i; + int j; + } idx; + } val; + } ELEMENT; + +typedef struct node { + struct node * left; + struct node * right; + int type; + int sign; + ELEMENT *elm; + } NODE; + +extern char *F77_types[]; +extern char *F90_types[]; +extern char *C_types[]; +extern char *MATLAB_types[]; + +NODE * Elm( int v, ... ); +#define Const( x ) Elm( 0, (double)x ) +#define Expr( x ) Elm( 1, x ) + +void FreeNode( NODE * n ); + +NODE * Add( NODE *n1, NODE *n2 ); +NODE * Sub( NODE *n1, NODE *n2 ); +NODE * Mul( NODE *n1, NODE *n2 ); +NODE * Div( NODE *n1, NODE *n2 ); +NODE * Pow( NODE *n1, NODE *n2 ); + +void Assign( NODE *lval, NODE *rval ); +void MkSubst( NODE *n1, NODE *n2 ); +void RmSubst( NODE *n ); +void CommentFncBegin( int f, int *vars ); +void CommentFunctionBegin( int f, ... ); +void CommentFunctionEnd( int f ); + +void Use_C(); +void Use_F(); +void Use_F90(); +void Use_MATLAB(); + +extern void (*WriteElm)( NODE *n ); +extern void (*WriteSymbol)( int op ); +extern void (*WriteAssign)( char* ls, char* rs ); +extern void (*WriteComment)( char *fmt, ... ); +extern void (*Declare)( int v ); +extern void (*ExternDeclare)( int v ); +extern void (*GlobalDeclare)( int v ); +extern void (*InitDeclare)( int v, int n, void * values ); +extern void (*DeclareConstant)( int v, char *val ); +extern void (*FunctionStart)( int f, int *vars ); +extern void (*FunctionPrototipe)( int f, ... ); +extern void (*FunctionBegin)( int f, ... ); +extern void (*FunctionEnd)( int f ); + +void WriteDelim(); + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_c.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_c.c new file mode 100755 index 00000000..64deef20 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_c.c @@ -0,0 +1,543 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include + +#define MAX_LINE 120 +#define LINE_LENGTH 70 + +int fncPrototipe = 0; + +char *C_types[] = { "void", /* VOID */ + "int", /* INT */ + "float", /* FLOAT */ + "double", /* DOUBLE */ + "char *", /* STRING */ + "char *" /* DOUBLESTRING */ + }; + +void C_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s[%s]", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s[%s][%s]", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +void C_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +void C_WriteAssign( char *ls, char *rs ) +{ +int start; +int crtident; +int linelg; +int i,j; +char c; +int first; +int number_of_lines = 1, MAX_NO_OF_LINES = 99; +int ifound, jfound; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 2 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + crtident + 2; + linelg = LINE_LENGTH - start; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) {/* if a new line needs to be started */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + /*for( i=linelg; i>10; i-- ) + if( ( rs[i] & 0x80 ) || ( rs[i] == ',' ) ) + break; + if( i < 10 ) { + printf("\nPossible error when cutting lines"); + i = linelg; + }*/ + + c = rs[i]; + rs[i] = 0; + if ( first ) { + bprintf("%s", rs ); + linelg++; + first = 0; + } else { + bprintf("\n%*s%s", start, "", rs ); + if ( jfound ) { + bprintf(";\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) + printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls); + + if ( first ) bprintf("%s;\n", rs ); + else bprintf("\n%*s%s;\n", start, "", rs ); + + FlushBuf(); +} + +void C_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + bprintf( "/* %-*s */\n", LINE_LENGTH - 6, buf ); + + FlushBuf(); +} + + +char * C_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = C_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + sprintf( buf, "%s %s", baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /*if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + sprintf( maxi, "%s+1", maxi );*/ + if( fncPrototipe ) + sprintf( buf, "%s %s[]", baseType, var->name ); + else + sprintf( buf, "%s %s[%s]", baseType, var->name, maxi ); + break; + case MELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + if( fncPrototipe ) + sprintf( buf, "%s %s[][]", baseType, var->name ); + else + sprintf( buf, "%s %s[%s][%s]", + baseType, var->name, maxi, maxj ); + break; + default: + Message( "Can not declare type %d", var->type ); + Message( "v = %d", v ); + break; + } + return buf; +} + +void C_Declare( int v ) +{ + bprintf("%-40s", strcat( C_Decl(v), ";" ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_ExternDeclare( int v ) +{ + bprintf("extern %-40s", strcat( C_Decl(v), ";" ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_GlobalDeclare( int v ) +{ + C_Declare( v ); +} + +void C_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +int maxCols = MAX_COLS; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + if( var->comment ) + bprintf(" /* %s */\n\n", var->comment ); + + switch( var->type ) { + case VELM: bprintf( " %s %s[] = {\n%5s", C_types[var->baseType], var->name, " " ); + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "\"%s\"", cval[i] ); maxCols=8; break; + case DOUBLESTRING:bprintf( "\"%s\"", cval[i] ); maxCols=1; break; + } + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) bprintf( "\n%5s", " " ); + } + if( n == 0 ) bprintf( "0" ); + bprintf( " }; \n\n" ); + break; + + case ELM: bprintf( " %s %s = ", C_types[var->baseType], var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "\"%s\"", *cval ); break; + case DOUBLESTRING:bprintf( "\"%s\"", *cval ); break; + } + bprintf( ";\n\n" ); + break; + + default: printf( "\n Function not defined !\n" ); + break; + } + + FlushBuf(); +} + +void C_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + switch( var->type ) { + case CONST: bprintf("#define %-20s %-10s ", var->name, val ); + break; + default: + printf( "Invalid constant", var->type ); + break; + } + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + + FlushBuf(); +} + +void C_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + fncPrototipe = 1; + + bprintf("void %s( \n", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf(" %-38s", strcat( C_Decl(v), "," ) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + } + if( narg >= 1 ) { + v = vars[ i ]; + bprintf(" %-38s", C_Decl(v) ); + if( varTable[ v ]->comment ) + bprintf(" /* %s */\n", varTable[ v ]->comment ); + else + bprintf("\n"); + } + bprintf(")"); + + fncPrototipe = 0; + + FlushBuf(); +} + +void C_FunctionPrototipe( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + C_FunctionStart( f, vars ); + bprintf(";\n"); + + FlushBuf(); +} + +void C_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int vars[20]; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[i] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + C_FunctionStart( f, vars ); + bprintf("\n"); + bprintf("{\n"); + + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +void C_FunctionEnd( int f ) +{ + bprintf("}\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +void C_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != C_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n",buf ); + + FlushBuf(); +} + +void Use_C() +{ + WriteElm = C_WriteElm; + WriteSymbol = C_WriteSymbol; + WriteAssign = C_WriteAssign; + WriteComment = C_WriteComment; + DeclareConstant = C_DeclareConstant; + Declare = C_Declare; + ExternDeclare = C_ExternDeclare; + GlobalDeclare = C_GlobalDeclare; + InitDeclare = C_InitDeclare; + + FunctionStart = C_FunctionStart; + FunctionPrototipe = C_FunctionPrototipe; + FunctionBegin = C_FunctionBegin; + FunctionEnd = C_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.h", "Parameter Header File" ); + OpenFile( &initFile, rootFileName, "_Initialize.c", "Initialization File" ); + OpenFile( &driverFile, rootFileName, "_Main.c", "Main Program File" ); + OpenFile( &integratorFile, rootFileName, "_Integrator.c", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.c", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.c", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.c", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.c", + "The Reaction Rates File" ); + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.c", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.c", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.c", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.c", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.h", "Sparse Data Header File" ); + OpenFile( &global_dataFile, rootFileName, "_Global.h", "Global Data Header File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.c", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.c", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.c", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.c", + "Utility Data Initialization" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f77.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f77.c new file mode 100755 index 00000000..ce8b1e5f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f77.c @@ -0,0 +1,588 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include + +#define MAX_LINE 120 + +char *F77_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL", /* FLOAT */ + "REAL*8", /* DOUBLE */ + "CHARACTER*12", /* STRING */ + "CHARACTER*100" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void F77_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void F77_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void F77_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i,j; +char c; +int first; +int crtident; +int number_of_lines = 1, MAX_NO_OF_LINES = 36; +int ifound, jfound; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 6 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 70 - crtident - start - 1; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) {/* if a new line needs to be started */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + /*for( i=linelg; i>10; i-- ) + if( ( rs[i] & 0x80 )||( rs[i]==',' ) ) + break; + if( i < 10 ) { + printf("\nPossible error when cutting lines"); + i = linelg; + } */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf("\n &%*s%s", start, "", rs ); + if ( jfound ) { + bprintf("\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) + printf("\n Warning: many continuation lines (%d) for %s = ...",number_of_lines,ls); + + if ( first ) bprintf("%s\n", rs ); /* non-split row */ + else bprintf("\n &%*s%s\n", start, "", rs ); /* last line in a split row */ + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F77_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "C %-65s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +char * F77_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = F77_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: sprintf( buf, "%s %s", + baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + sprintf( buf, "%s %s(%s)", + baseType, var->name, maxi ); + break; + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + /*if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1");*/ + sprintf( buf, "%s %s(%s,%s)", + baseType, var->name, maxi, maxj ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void F77_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + F77_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + bprintf(" %s\n", F77_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_ExternDeclare( int v ) +{ + F77_Declare( v ); + bprintf(" COMMON /%s/ %s\n", CommonName, varTable[ v ]->name ); +} + +/*************************************************************************************************/ +void F77_GlobalDeclare( int v ) +{ +} + +/*************************************************************************************************/ +void F77_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + F77_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" %s %s\n", + F77_types[ var->baseType ], var->name ); + bprintf(" PARAMETER ( %s = %s )\n", + var->name, val); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + +/*************************************************************************************************/ +void WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sDATA( %s(i), i = %d, %d ) /\n%5s*", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sDATA %s /\n%5s*", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_DeclareData( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s*", " " ); + nlines++; + } + } + max ++; + } + WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sDATA %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void F77_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + F77_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void F77_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" SUBROUTINE %s ( ", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s, ", varTable[ v ]->name ); + } + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("%s ", varTable[ v ]->name ); + } + bprintf(")\n"); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_FunctionPrototipe( int f, ... ) +{ +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F77_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + F77_FunctionStart( f, vars ); + NewLines(1); + bprintf(" IMPLICIT NONE\n" ); + bprintf(" INCLUDE '%s_Parameters.h'\n\n", rootFileName ); + + FlushBuf(); + + for( i = 0; i < narg; i++ ) + F77_Declare( vars[ i ] ); + + bprintf("\n"); + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void F77_FunctionEnd( int f ) +{ + bprintf(" RETURN\n"); + bprintf(" END\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +/*************************************************************************************************/ +void F77_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != F77_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void Use_F() +{ + WriteElm = F77_WriteElm; + WriteSymbol = F77_WriteSymbol; + WriteAssign = F77_WriteAssign; + WriteComment = F77_WriteComment; + DeclareConstant = F77_DeclareConstant; + Declare = F77_Declare; + ExternDeclare = F77_ExternDeclare; + GlobalDeclare = F77_GlobalDeclare; + InitDeclare = F77_InitDeclare; + + FunctionStart = F77_FunctionStart; + FunctionPrototipe = F77_FunctionPrototipe; + FunctionBegin = F77_FunctionBegin; + FunctionEnd = F77_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.h", "Parameter Header File" ); + OpenFile( &initFile, rootFileName, "_Initialize.f", "Initialization File" ); + OpenFile( &driverFile, rootFileName, "_Main.f", "Main Program File" ); + OpenFile( &integratorFile, rootFileName, "_Integrator.f", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.f", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.f", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.f", + "The Reaction Rates File" ); + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.f", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.f", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.h", "Sparse Data Header File" ); + OpenFile( &global_dataFile, rootFileName, "_Global.h", "Global Data Header File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.f", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.f", + "Initialization of Utility Data Structures" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f90.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f90.c new file mode 100755 index 00000000..b9f4b141 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_f90.c @@ -0,0 +1,771 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include +#include + +#define MAX_LINE 120 + +char *F90_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL(kind=sp)", /* FLOAT */ + "REAL(kind=dp)", /* DOUBLE */ + "CHARACTER(LEN=12)", /* STRING */ + "CHARACTER(LEN=100)" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void F90_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void F90_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("power"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void F90_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i, j; +int ifound, jfound; +char c; +int first; +int crtident; + +/* Max no of continuation lines in F90/F95 differs with compilers, but 39 + should work for every compiler*/ +int number_of_lines = 1, MAX_NO_OF_LINES = 36; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 2 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 120 - crtident - start - 1; /* F90 max line length is 132 */ + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) { + /* If a new line needs to be started. + Note: the approach below will create erroneous code if the +/- is within a subexpression, e.g. for + A*(B+C) one cannot start a new continuation line by splitting at the + sign */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: double-check continuation lines for:\n %s = %s\n",ls,rs); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf("&\n %*s&%s", start, "", rs ); + if ( jfound ) { + bprintf("\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; /* jump to the first not-yet-written character */ + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) { + printf("\n Warning: %d continuation lines for %s = ...",number_of_lines,ls); + } + + if ( first ) bprintf("%s\n", rs ); /* non-split row */ + else bprintf("&\n %*s&%s\n", start, "", rs ); /* last line in a split row */ + + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F90_WriteComment( char *fmt, ... ) +{ +Va_list args; +int n; +char buf[ MAX_LINE ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + /* remove trailing spaces */ + /* taken from http://www.cs.bath.ac.uk/~pjw/NOTES/ansi_c/ch10-idioms.pdf */ + for (n= strlen(buf) - 1; n >= 0; n--) + if (buf[n] != ' ') break; + buf[n + 1]= '\0'; + bprintf( "! %s\n", buf ); + FlushBuf(); +} + +/*************************************************************************************************/ +char * F90_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + var = varTable[ v ]; + baseType = F90_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + sprintf( buf, "%s :: %s", baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + /*sprintf( buf, "%s, DIMENSION(%s) :: %s", baseType, maxi, var->name );*/ + if( var->maxi == 0 ) sprintf( maxi, "%d", 1 ); + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + if ( var->maxi < 0 ) { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + sprintf( buf, "%s :: %s(%s)", baseType, var->name, maxi ); + break; + case MELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else { + if (varTable[ -var->maxi ]->value < 0) + sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + else + sprintf( maxi, "%d", (varTable[-var->maxi]->value)==0? + 1:varTable[-var->maxi]->value ); + } + /* else sprintf( maxi, "%s", varTable[ -var->maxi ]->name); */ + /* if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); */ + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else { + if (varTable[ -var->maxj ]->value < 0) + sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + else + sprintf( maxj, "%d", (varTable[-var->maxj]->value)==0? + 1:varTable[-var->maxj]->value ); + } + /* else sprintf( maxj, "%s", varTable[ -var->maxj ]->name); */ + /*if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1");*/ + /*sprintf( buf, "%s, DIMENSION(%s,%s) :: %s", + baseType, maxi, maxj,var->name ); */ + sprintf( buf, "%s :: %s(%s,%s)", + baseType, var->name, maxi, maxj ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +char * F90_DeclareData( int v, void * values, int n) +{ +int i, j; +int nlines; +int split; +static char buf[120]; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +char *baseType; +char maxi[20]; +char maxj[20]; +int maxCols = MAX_COLS; +char dsbuf[200]; + + int i_from, i_to; + int isplit; + int splitsize; + int maxi_mod; + int maxi_div; + + char mynumber[30]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double *) values; + cval = (char **) values; + + nlines = 1; + split = 0; + var -> maxi = max( n, 1 ); + + baseType = F90_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: + bprintf( " %s :: %s = ", baseType, var->name ); + switch ( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: bprintf( "%f", *dval); break; + case REAL: bprintf( "%lg", *dval ); break; + case STRING: bprintf( "'%3s'", *cval ); break; + } + break; + case VELM: + /* define maxCols here already and choose suitable splitsize */ + switch( var -> baseType ) { + case INT: maxCols =12; break; + case DOUBLE: maxCols = 5; break; + case REAL: maxCols = 5; break; + case STRING: maxCols = 3; break; + case DOUBLESTRING: maxCols = 1; break; + } + splitsize = 30 * maxCols; /* elements = lines * columns */ + maxi_mod = var->maxi % splitsize; + maxi_div = var->maxi / splitsize; + /* correction if var->maxi is a multiple of splitsize */ + if ( (maxi_div>0) && (maxi_mod==0) ) { + maxi_mod = splitsize; + maxi_div--; + } + for ( isplit=0; isplit <= maxi_div; isplit++ ) { + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + bprintf( " %s, " , baseType); + if( n>0 ) bprintf( "PARAMETER, " ); /* if values are assigned now */ + if ( maxi_div==0 ) { /* define array in one piece */ + bprintf( "DIMENSION(%s) :: %s", + maxi, var->name) ; + } else {/* define partial arrays */ + if ( isplit==maxi_div ) { /* last part has size maxi_mod */ + bprintf( "DIMENSION(%d) :: %s_%d", + maxi_mod, var->name, isplit) ; + } else { /* all other parts have size splitsize */ + bprintf( "DIMENSION(%d) :: %s_%d", + splitsize, var->name, isplit) ; + } + } + if( n<=0 ) break; + + /* now list values */ + bprintf( " = (/ &\n " ); + /* if the array is defined in one piece, then the for loop will + go from 0 to n. Otherwise, there will be partial arrays from + i_from to i_to which are of size splitsize except for the + last one which is usually smaller and contains the rest */ + i_from = isplit * splitsize; + i_to = min(i_from+splitsize,n); + for ( i=i_from; i < i_to; i++ ) { + switch( var -> baseType ) { + case INT: + bprintf( "%3d", ival[i] ); break; + case DOUBLE: + /* bprintf( "%4f", dval[i] ); maxCols = 5; break; */ + sprintf(mynumber, "%12.6e_dp",dval[i]); + /* mynumber[ strlen(mynumber)-4 ] = 'd'; */ + bprintf( " %s", mynumber ); break; + case REAL: + bprintf( "%12.6e", dval[i] ); break; + case STRING: + bprintf( "'%-12s'", cval[i] ); break; + case DOUBLESTRING: + /* strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; */ + /* bprintf( "'%48s'", dsbuf ); break; */ + bprintf( "'%-100.100s'", cval[i] ); break; + } + if( i < i_to-1 ) { + bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( " &\n " ); + nlines++; + } + } + } + bprintf( " /)\n" ); + } + + /* combine the partial arrays */ + if ( maxi_div != 0 ) { + bprintf( " %s, PARAMETER, DIMENSION(%s) :: %s = (/&\n ", + baseType, maxi, var->name) ; + for ( isplit=0; isplit <= maxi_div; isplit++ ) { + bprintf( "%s_%d", var->name, isplit) ; + if( isplit < maxi_div ) { /* more parts will follow */ + bprintf( ", " ); + /* line break after 5 variables */ + if( (isplit+1) % 5 == 0 ) bprintf( "&\n " ); + } else { /* after last part */ + bprintf( " /)\n" ); + } + } + } + + break; + + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s\n", /* changed here */ + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void F90_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + F90_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + bprintf(" %s\n", F90_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_ExternDeclare( int v ) +{ + F90_Declare( v ); + /* !cms bprintf(" COMMON /%s/ %s\n", CommonName, varTable[ v ]->name ); */ +} + +/*************************************************************************************************/ +void F90_GlobalDeclare( int v ) +{ +} + +/*************************************************************************************************/ +void F90_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + F90_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" %s, PARAMETER :: %s = %s \n", + F90_types[ var->baseType ], var->name, val ); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + + +/*************************************************************************************************/ +void F90_WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sdata( %s(i), i = %d, %d ) / &\n%5s", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sdata %s / &\n%5s", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_DeclareDataOld( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + F90_WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s", " " ); + nlines++; + } + } + max ++; + } + F90_WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sdata %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void F90_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + F90_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void F90_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf("SUBROUTINE %s ( ", name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s, ", varTable[ v ]->name ); + } + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("%s ", varTable[ v ]->name ); + } + bprintf(")\n"); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_FunctionPrototipe( int f, ... ) +{ +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void F90_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + F90_FunctionStart( f, vars ); + NewLines(1); + /* bprintf(" USE %s_Precision\n", rootFileName ); + bprintf(" USE %s_Parameters\n\n", rootFileName ); */ + /* bprintf(" IMPLICIT NONE\n" ); */ + + FlushBuf(); + + for( i = 0; i < narg; i++ ) + F90_Declare( vars[ i ] ); + + bprintf("\n"); + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void F90_FunctionEnd( int f ) +{ + bprintf(" \nEND SUBROUTINE %s\n\n", varTable[ f ]->name ); + + FlushBuf(); + + CommentFunctionEnd( f ); +} + +/*************************************************************************************************/ +void F90_Inline( char *fmt, ... ) +{ +va_list args; +char buf[ 1000 ]; + + if( useLang != F90_LANG ) return; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); + +} + +/*************************************************************************************************/ +void Use_F90() +{ + WriteElm = F90_WriteElm; + WriteSymbol = F90_WriteSymbol; + WriteAssign = F90_WriteAssign; + WriteComment = F90_WriteComment; + DeclareConstant = F90_DeclareConstant; + Declare = F90_Declare; + ExternDeclare = F90_ExternDeclare; + GlobalDeclare = F90_GlobalDeclare; + InitDeclare = F90_InitDeclare; + + FunctionStart = F90_FunctionStart; + FunctionPrototipe = F90_FunctionPrototipe; + FunctionBegin = F90_FunctionBegin; + FunctionEnd = F90_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.f90", "Parameter Module File" ); + /* mz_rs_20050117+ */ + OpenFile( &initFile, rootFileName, "_Initialize.f90", "Initialization File" ); + /* mz_rs_20050117- */ + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + OpenFile( &driverFile, rootFileName, "_Main.f90", "Main Program File" ); + /* mz_rs_20050518- */ + OpenFile( &integratorFile, rootFileName, "_Integrator.f90", + "Numerical Integrator (Time-Stepping) File" ); + OpenFile( &linalgFile, rootFileName, "_LinearAlgebra.f90", + "Linear Algebra Data and Routines File" ); + OpenFile( &functionFile, rootFileName, "_Function.f90", + "The ODE Function of Chemical Model File" ); + OpenFile( &jacobianFile, rootFileName, "_Jacobian.f90", + "The ODE Jacobian of Chemical Model File" ); + OpenFile( &rateFile, rootFileName, "_Rates.f90", + "The Reaction Rates File" ); + + if ( useWRFConform ) { + OpenFile( &wrf_UpdateRconstFile, rootFileName, "_Update_Rconst.f90", + "The KPP-WRF conform Reaction Rates File" ); + } + + + if ( useStochastic ) + OpenFile( &stochasticFile, rootFileName, "_Stochastic.f90", + "The Stochastic Chemical Model File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.f90", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.f90", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.f90", + "Auxiliary Routines File" ); + /* OpenFile( &sparse_dataFile, rootFileName, "_Sparse.f90", + "Sparse Data Module File" );*/ + OpenFile( &global_dataFile, rootFileName, "_Global.f90", "Global Data Module File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.f90", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &hessianFile, rootFileName, "_Hessian.f90", "Hessian File" ); + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.f90", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.f90", + "Utility Data Module File" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_matlab.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_matlab.c new file mode 100755 index 00000000..746486b9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/code_matlab.c @@ -0,0 +1,719 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include + +#define MAX_LINE 120 + +char *MATLAB_types[] = { "", /* VOID */ + "INTEGER", /* INT */ + "REAL", /* FLOAT */ + /*"REAL(dp)", */ /* DOUBLE */ + "DOUBLE PRECISION", /* DOUBLE */ + "CHARACTER(LEN=12)", /* STRING */ + "CHARACTER(LEN=100)" /* DOUBLESTRING */ + }; + +/*************************************************************************************************/ +void MATLAB_WriteElm( NODE * n ) +{ +ELEMENT *elm; +char * name; +char maxi[20]; +char maxj[20]; + + elm = n->elm; + name = varTable[ elm->var ]->name; + + switch( n->type ) { + case CONST: bprintf("%g", elm->val.cnst); + break; + case ELM: bprintf("%s", name); + break; + case VELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + bprintf("%s(%s)", name, maxi ); + break; + case MELM: if( elm->val.idx.i >= 0 ) sprintf( maxi, "%d", elm->val.idx.i+1 ); + else sprintf( maxi, "%s", varTable[ -elm->val.idx.i ]->name ); + if( elm->val.idx.j >= 0 ) sprintf( maxj, "%d", elm->val.idx.j+1 ); + else sprintf( maxj, "%s", varTable[ -elm->val.idx.j ]->name ); + bprintf("%s(%s,%s)", name, maxi, maxj ); + break; + case EELM: bprintf("(%s)", elm->val.expr ); + break; + } +} + +/*************************************************************************************************/ +void MATLAB_WriteSymbol( int op ) +{ + switch( op ) { + case ADD: bprintf("+"); + AllowBreak(); + break; + case SUB: bprintf("-"); + AllowBreak(); + break; + case MUL: bprintf("*"); + AllowBreak(); + break; + case DIV: bprintf("/"); + AllowBreak(); + break; + case POW: bprintf("^"); + break; + case O_PAREN: bprintf("("); + AllowBreak(); + break; + case C_PAREN: bprintf(")"); + break; + case NONE: + break; + } +} + +/*************************************************************************************************/ +void MATLAB_WriteAssign( char *ls, char *rs ) +{ +int start; +int linelg; +int i, j; +int ifound, jfound; +char c; +int first; +int crtident; + +/* Max no of continuation lines in F95 standard is 39 */ +int number_of_lines = 1, MAX_NO_OF_LINES = 36; + +/* Operator Mapping: 0xaa = '*' | 0xab = '+' | 0xac = ',' + 0xad = '-' | 0xae ='.' | 0xaf = '/' */ +char op_mult=0xaa, op_plus=0xab, op_minus=0xad, op_dot=0xae, op_div=0xaf; + + crtident = 3 + ident * 2; + bprintf("%*s%s = ", crtident, "", ls); + start = strlen( ls ) + 2; + linelg = 70 - crtident - start - 1; + + first = 1; + while( strlen(rs) > linelg ) { + ifound = 0; jfound = 0; + if ( number_of_lines >= MAX_NO_OF_LINES ) { + /* If a new line needs to be started. + Note: the approach below will create erroneous code if the +/- is within a subexpression, e.g. for + A*(B+C) one cannot start a new continuation line by splitting at the + sign */ + for( j=linelg; j>5; j-- ) /* split row here if +, -, or comma */ + if ( ( rs[j] == op_plus )||( rs[j] == op_minus )||( rs[j]==',' ) ) { + jfound = 1; i=j; break; + } + } + if ( ( number_of_lines < MAX_NO_OF_LINES )||( !jfound ) ) { + for( i=linelg; i>10; i-- ) /* split row here if operator or comma */ + if ( ( rs[i] & 0x80 )||( rs[i]==',' ) ) { + ifound = 1; break; + } + if( i <= 10 ) { + printf("\n Warning: possible error in continuation lines for %s = ...",ls); + i = linelg; + } + } + while ( rs[i-1] & 0x80 ) i--; /* put all operators on the next row */ + while ( rs[i] == ',' ) i++; /* put commas on the current row */ + + c = rs[i]; + rs[i] = 0; + + if ( first ) { /* first line in a split row */ + bprintf("%s", rs ); + linelg++; + first = 0; + } else {/* continuation line in a split row - but not last line*/ + bprintf(" ...\n %*s%s", start, "", rs ); + if ( jfound ) { + bprintf(" ;\n%*s%s = %s", crtident, "", ls, ls); + number_of_lines = 1; + } + } + rs[i] = c; + rs += i; /* jump to the first not-yet-written character */ + number_of_lines++; + } + + if ( number_of_lines > MAX_NO_OF_LINES ) { + printf("\n Warning: %d continuation lines for %s = ...",number_of_lines,ls); + } + + if ( first ) bprintf("%s ;\n", rs ); /* non-split row */ + else bprintf(" ...\n %*s%s;\n", start, "", rs ); /* last line in a split row */ + + + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_WriteComment( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_LINE ]; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + fprintf( currentFile, "%c ", '%' ); + bprintf( "%-65s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +char * MATLAB_Decl( int v ) +{ +static char buf[120]; +VARIABLE *var; +char *baseType; +char maxi[20]; +char maxj[20]; + + buf[0] = 0; return buf; /* Nothing to declare in matlab */ + var = varTable[ v ]; + baseType = MATLAB_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { + case ELM: sprintf( buf, "%s :: %s", + baseType, var->name ); + break; + case VELM: + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + sprintf( buf, "%s, DIMENSION(%s) :: %s", + baseType, maxi, var->name ); + break; + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s", + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d\n", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +char * MATLAB_DeclareData( int v, void * values, int n) +{ +int i, j; +int nlines, nmax; +int split; +static char buf[120]; +VARIABLE *var; +int * ival; +double * dval; +char ** cval; +char *baseType; +char maxi[20]; +char maxj[20]; +int maxCols = MAX_COLS; +char dsbuf[55]; + + int i_from, i_to; + int isplit; + int splitsize; + int maxi_mod; + int maxi_div; + + char mynumber[30]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double *) values; + cval = (char **) values; + + nlines = 1; + nmax = 1; + split = 0; + var -> maxi = max( n, 1 ); + + baseType = MATLAB_types[ var->baseType ]; + + *buf = 0; + + switch( var->type ) { /* changed here */ + case ELM: + /* bprintf( " %s :: %s = ", baseType, var->name ); + switch ( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: bprintf( "%f", *dval); break; + case REAL: bprintf( "%lg", *dval ); break; + case STRING: bprintf( "'%3s'", *cval ); break; + } */ + break; + case VELM: + splitsize = 36; /*elements*/ + maxi_mod = var->maxi % splitsize; + maxi_div = var->maxi / splitsize; + + if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + /* now list values */ + /* if ( (var->baseType==STRING)||(var->baseType==DOUBLESTRING) ) { + bprintf( "%s(1:%s,:) = [ ... \n", var->name, maxi) ; + } else { + bprintf( "%s(1:%s) = [ ... \n", var->name, maxi) ; + }*/ + if ( (var->baseType==STRING)||(var->baseType==DOUBLESTRING) ) { + bprintf( "%s = [ ... \n", var->name, maxi) ; + } else { + bprintf( "%s = [ ... \n", var->name, maxi) ; + } + + /* if the array is defined in one piece, then the for loop will + go from 0 to n. Otherwise, there will be partial arrays from + i_from to i_to which are of size splitsize except for the + last one which is usually smaller and contains the rest */ + for ( i=0; i < n; i++ ) { + switch( var -> baseType ) { + case INT: + bprintf( "%4d", ival[i] ); maxCols =12; break; + case DOUBLE: + sprintf(mynumber, "%12.6e",dval[i]); + bprintf( " %s", mynumber ); maxCols = 5; break; + case REAL: + bprintf( "%12.6e", dval[i] ); maxCols = 5; break; + case STRING: + bprintf( "'%12s'", cval[i] ); maxCols = 3; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( i < n-1 ) { + bprintf( ";" ); + if( (i+1) % maxCols == 0 ) { + bprintf( " ... \n" ); + nlines++; + } + } + } + bprintf( " ];\n" ); + break; + + case MELM: if( var->maxi > 0 ) sprintf( maxi, "%d", var->maxi ); + else sprintf( maxi, "%s", varTable[ -var->maxi ]->name ); + if( (var->maxi == 0) || + ((var->maxi < 0) && (varTable[ -var->maxi ]->maxi == 0)) ) + strcat( maxi, "+1"); + if( var->maxj > 0 ) sprintf( maxj, "%d", var->maxj ); + else sprintf( maxj, "%s", varTable[ -var->maxj ]->name ); + if( (var->maxj == 0) || + ((var->maxj < 0 ) && (varTable[ -var->maxj ]->maxi == 0)) ) + strcat( maxj, "+1"); + sprintf( buf, "%s, DIMENSION(%s,%s) :: %s\n", /* changed here */ + baseType, maxi, maxj,var->name ); + break; + default: + printf( "Can not declare type %d", var->type ); + break; + } + return buf; +} + +/*************************************************************************************************/ +void MATLAB_Declare( int v ) +{ + if( varTable[ v ]->comment ) { + MATLAB_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + FlushBuf(); + bprintf(" %s\n", MATLAB_Decl(v) ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_ExternDeclare( int v ) +{ + if( varTable[ v ]->comment ) { + MATLAB_WriteComment( "%s - %s", + varTable[ v ]->name, varTable[ v ]->comment ); + } + FlushBuf(); + bprintf(" global %s;\n", varTable[ v ]->name ); + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_GlobalDeclare( int v ) +{ +} + + +/*************************************************************************************************/ +void MATLAB_DeclareConstant( int v, char *val ) +{ +VARIABLE *var; +int ival; +char dummy_val[100]; /* used just to avoid strange behaviour of + sscanf when compiled with gcc */ + + strcpy(dummy_val,val);val = dummy_val; + + var = varTable[ v ]; + + if( sscanf(val, "%d", &ival) == 1 ) + if( ival == 0 ) var->maxi = 0; + else var->maxi = 1; + else + var->maxi = -1; + + if( var->comment ) + MATLAB_WriteComment( "%s - %s", var->name, var->comment ); + + switch( var->type ) { + case CONST: bprintf(" global %s;",var->name, val ); + bprintf(" %s = %s; \n", var->name, val ); + break; + default: + printf( "Invalid constant %d", var->type ); + break; + } + + FlushBuf(); +} + + +/*************************************************************************************************/ +void MATLAB_WriteVecData( VARIABLE * var, int min, int max, int split ) +{ +char buf[80]; +char *p; + + if( split ) + sprintf( buf, "%6sdata( %s(i), i = %d, %d ) / &\n%5s", + " ", var->name, min, max, " " ); + else + sprintf( buf, "%6sdata %s / &\n%5s", + " ", var->name, " " ); + + FlushThisBuf( buf ); + bprintf( " / \n\n" ); + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_DeclareDataOld( int v, int * values, int n ) +{ +int i, j; +int nlines, min, max; +int split; +VARIABLE *var; +int * ival; +double * dval; +char **cval; +int maxCols = MAX_COLS; +char dsbuf[55]; + + var = varTable[ v ]; + ival = (int*) values; + dval = (double*) values; + cval = (char**) values; + + nlines = 1; + min = max = 1; + split = 0; + + switch( var->type ) { + case VELM: if( n <= 0 ) break; + for( i = 0; i < n; i++ ) { + switch( var->baseType ) { + case INT: bprintf( "%3d", ival[i] ); maxCols=12; break; + case DOUBLE: + case REAL:bprintf( "%5lg", dval[i] ); maxCols=8; break; + case STRING:bprintf( "'%s'", cval[i] ); maxCols=5; break; + case DOUBLESTRING: + strncpy( dsbuf, cval[i], 54 ); dsbuf[54]='\0'; + bprintf( "'%48s'", dsbuf ); maxCols=1; break; + } + if( ( (i+1) % 12 == 0 ) && ( nlines > MAX_LINES ) ) { + split = 1; nlines = 1; + MATLAB_WriteVecData( var, min, max, split ); + min = max + 1; + } + else { + if( i < n-1 ) bprintf( "," ); + if( (i+1) % maxCols == 0 ) { + bprintf( "\n%5s", " " ); + nlines++; + } + } + max ++; + } + MATLAB_WriteVecData( var, min, max-1, split ); + break; + + case ELM: bprintf( "%6sdata %s / ", " ", var->name ); + switch( var->baseType ) { + case INT: bprintf( "%d", *ival ); break; + case DOUBLE: + case REAL:bprintf( "%lg", *dval ); break; + case STRING:bprintf( "'%s'", *cval ); break; + case DOUBLESTRING: + strncpy( dsbuf, *cval, 54 ); dsbuf[54]='\0'; + bprintf( "'%s'", dsbuf ); maxCols=1; break; + /* bprintf( "'%50s'", *cval ); break; */ + } + bprintf( " / \n" ); + FlushBuf(); + break; + default: + printf( "\n Function not defined !\n" ); + break; + } +} + +/*************************************************************************************************/ +void MATLAB_InitDeclare( int v, int n, void * values ) +{ +int i; +VARIABLE * var; + + var = varTable[ v ]; + var->maxi = max( n, 1 ); + + NewLines(1); + MATLAB_DeclareData( v, values, n ); +} + +/*************************************************************************************************/ +void MATLAB_FunctionStart( int f, int *vars ) +{ +int i; +int v; +char * name; +int narg; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + bprintf("function " ); + if( narg >= 1 ) { + v = vars[ narg-1 ]; + bprintf("[ %s ] = ", varTable[ v ]->name ); + } + bprintf(" %s_%s ( ", rootFileName, name ); + for( i = 0; i < narg-1; i++ ) { + v = vars[ i ]; + bprintf("%s ", varTable[ v ]->name ); + if (iname; + narg = varTable[ f ]->maxi; + + bprintf(" EXTERNAL %s\n", name ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void MATLAB_FunctionBegin( int f, ... ) +{ +Va_list args; +int i; +int v; +int vars[20]; +char * name; +int narg; +FILE *oldf; +char buf[200], bufname[200]; +time_t t; + + name = varTable[ f ]->name; + narg = varTable[ f ]->maxi; + + /*Adi - each Matlab functin requires a separate file*/ + sprintf( buf, "%s_%s.m", rootFileName, varTable[ f ]->name ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + /*Adi*/ + + + Va_start( args, f ); + for( i = 0; i < narg; i++ ) + vars[ i ] = va_arg( args, int ); + va_end( args ); + + CommentFncBegin( f, vars ); + + WriteDelim(); + WriteComment(""); + WriteComment("Generated by KPP - symbolic chemistry Kinetics PreProcessor" ); + WriteComment(" KPP is developed at CGRER labs University of Iowa by" ); + WriteComment(" Valeriu Damian & Adrian Sandu" ); + WriteComment(""); + WriteComment("%-20s : %s", "File", buf ); + strcpy( buf, (char*)ctime( &t ) ); + buf[ (int)strlen(buf) - 1 ] = 0; + WriteComment("%-20s : %s", "Time", buf ); + WriteComment("%-20s : %s", "Working directory", getcwd(buf, 200) ); + WriteComment("%-20s : %s", "Equation file", eqFileName ); + WriteComment("%-20s : %s", "Output root filename", rootFileName ); + WriteComment(""); + WriteDelim(); + NewLines(1); + + MATLAB_FunctionStart( f, vars ); + NewLines(1); + + FlushBuf(); + + MapFunctionComment( f, vars ); +} + +/*************************************************************************************************/ +void MATLAB_FunctionEnd( int f ) +{ + bprintf(" \nreturn\n\n"); + + FlushBuf(); + + CommentFunctionEnd( f ); + + /*Adi*/ + fclose(mex_funFile); + + +} + +/*************************************************************************************************/ +void MATLAB_Inline( char *fmt, ... ) +{ +Va_list args; +char buf[ 1000 ]; + + if( useLang != MATLAB_LANG ) return; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + bprintf( "%s\n", buf ); + + FlushBuf(); +} + +/*************************************************************************************************/ +void Use_MATLAB() +{ + WriteElm = MATLAB_WriteElm; + WriteSymbol = MATLAB_WriteSymbol; + WriteAssign = MATLAB_WriteAssign; + WriteComment = MATLAB_WriteComment; + DeclareConstant = MATLAB_DeclareConstant; + Declare = MATLAB_Declare; + ExternDeclare = MATLAB_ExternDeclare; + GlobalDeclare = MATLAB_GlobalDeclare; + InitDeclare = MATLAB_InitDeclare; + + FunctionStart = MATLAB_FunctionStart; + FunctionPrototipe = MATLAB_FunctionPrototipe; + FunctionBegin = MATLAB_FunctionBegin; + FunctionEnd = MATLAB_FunctionEnd; + + OpenFile( ¶m_headerFile, rootFileName, "_Parameters.m","Parameter Definition File" ); + OpenFile( &driverFile, rootFileName, "_Main.m", "Main Program File" ); + OpenFile( &rateFile, rootFileName, "_Rates.m", + "The Reaction Rates File" ); + if ( useStoicmat ) { + OpenFile( &stoichiomFile, rootFileName, "_Stoichiom.m", + "The Stoichiometric Chemical Model File" ); + OpenFile( &sparse_stoicmFile, rootFileName, "_StoichiomSP.m", + "Sparse Stoichiometric Data Structures File" ); + } + OpenFile( &utilFile, rootFileName, "_Util.m", + "Auxiliary Routines File" ); + OpenFile( &sparse_dataFile, rootFileName, "_Sparse.m", + "Sparse Data Definition File" ); + OpenFile( &global_dataFile, rootFileName, "_Global_defs.m", "Global Data Definition File" ); + if ( useJacSparse ) { + OpenFile( &sparse_jacFile, rootFileName, "_JacobianSP.m", + "Sparse Jacobian Data Structures File" ); + } + if ( useHessian ) { + OpenFile( &sparse_hessFile, rootFileName, "_HessianSP.m", + "Sparse Hessian Data Structures File" ); + } + OpenFile( &mapFile, rootFileName, ".map", + "Map File with Human-Readable Information" ); + OpenFile( &monitorFile, rootFileName, "_Monitor.m", + "Utility Data Definition File" ); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/copyright b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/copyright new file mode 100755 index 00000000..ecfc2a21 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/copyright @@ -0,0 +1,32 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/debug.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/debug.c new file mode 100755 index 00000000..703c4e06 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/debug.c @@ -0,0 +1,148 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "scan.h" + +void WriteAtoms() +{ +int i; + + printf("\nATM -----------------------------------------------" ); + + for( i = 0; i < SpeciesNr; i++ ) { + switch( AtomTable[i].check ) { + case NO_CHECK: + printf( "\n(%3d) %6s, NO -- ------ ", i, AtomTable[i].name ); + break; + case DO_CHECK: + printf( "\n(%3d) %6s, -- DO ------", i, AtomTable[i].name ); + break; + case CANCEL_CHECK: + printf( "\n(%3d) %6s, -- -- CANCEL", i, AtomTable[i].name ); + break; + default: + printf( "\n(%3d) %6s, -- -- ------ UNKNOWN [%d]", i, + AtomTable[i].name, AtomTable[i].check ); + break; + } + } +} + +void WriteSpecies() +{ +int i; +int j; +char *type; +char *lookat; + + printf("\nSPC -----------------------------------------------" ); + + for( i = 0; i < SpeciesNr; i++ ) { + + switch( SpeciesTable[i].type ) { + case VAR_SPC: type = "V - -"; break; + case RAD_SPC: type = "- R -"; break; + case FIX_SPC: type = "- - F"; break; + default: type = "? ? ?"; break; + } + + switch( SpeciesTable[i].lookat ) { + case 0: lookat = "----"; break; + case 1: lookat = "LOOK"; break; + default: lookat = "????"; break; + } + + printf( "\n(%3d) %-10s, type %s,%s {", + i, SpeciesTable[i].name, type, lookat ); + for( j = 0; j < SpeciesTable[i].nratoms; j++ ) + printf( " %d%s", SpeciesTable[i].atoms[j].nr, + AtomTable[ SpeciesTable[i].atoms[j].code ].name ); + printf("}"); + } +} + +void WriteMatrices() +{ +int i, j; + + printf("\nMAT ------------------ cc -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich_Left[i][j] ); + } + } + + printf("\nMAT ------------------ cd -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich_Right[i][j] ); + } + } + + printf("\nMAT ------------------ cf -------------------------" ); + for( i = 0; i < SpcNr; i++ ) { + printf("\n %-6s (%d)[%d] ", SpeciesTable[ Code[i] ].name, + SpeciesTable[ Code[i] ].type, Code[i], Reactive[i] ); + for( j = 0; j < EqnNr; j++ ) { + printf( "%5.1f ", Stoich[i][j] ); + } + } +} + +void WriteOptions() +{ + printf("\n### Options -------------------------------------------\n"); + if( useAggregate ) printf("FUNCTION - AGGREGATE\n"); + else printf("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: printf("JACOBIAN - OFF\n"); break; + case JAC_FULL: printf("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: printf("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: printf("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) printf("DOUBLE - ON\n"); + else printf("DOUBLE - OFF\n"); + if( useReorder ) printf("REORDER - ON\n"); + else printf("REORDER - OFF\n"); + if( useMex ) printf("MEX - ON\n"); + else printf("MEX - OFF\n"); + if( useDummyindex) printf("DUMMYINDEX - ON\n"); + else printf("DUMMYINDEX - OFF\n"); + if( useEqntags) printf("EQNTAGS - ON\n"); + else printf("EQNTAGS - OFF\n"); +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdata.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdata.h new file mode 100755 index 00000000..d025b62e --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdata.h @@ -0,0 +1,208 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + +#define KPP_VERSION "2.1" + +#ifndef _GDATA_H_ +#define _GDATA_H_ + +#include + +#define MAX_EQN 900 /* mz_rs_20050130 */ +#define MAX_SPECIES 400 /* mz_rs_20050130 */ +#define MAX_SPNAME 30 +#define MAX_IVAL 40 +/* MAX_EQNTAG = max length of equation ID in eqn file */ +#define MAX_EQNTAG 12 +/* MAX_K = max length of rate expression in eqn file */ +#define MAX_K 150 +#define MAX_ATOMS 10 +#define MAX_ATNAME 10 +#define MAX_ATNR 250 +#define MAX_PATH 120 +#define MAX_FILES 20 +#define MAX_EQNLEN 100 + +#define NO_CODE -1 +#define max( x, y ) (x) > (y) ? (x) : (y) +#define min( x, y ) (x) < (y) ? (x) : (y) + +#define IncName(x) FileName((x),"MODELS","models","") +#define ModelName(x) FileName((x),"MODELS","models",".def") +#define IntegName(x) FileName((x),"INTEG","int",".def") + +enum krtypes { NUMBER, EXPRESION, PHOTO }; +enum table_modes { F_TEXT, FC_TEXT, C_TEXT, S_TEXT }; +enum lang { NO_LANG, C_LANG, F77_LANG, F90_LANG, MATLAB_LANG }; +enum inl_code { F77_GLOBAL, F77_INIT, F77_DATA, F77_UTIL, F77_RATES, F77_RCONST, + F90_GLOBAL, F90_INIT, F90_DATA, F90_UTIL, F90_RATES, F90_RCONST, + C_GLOBAL, C_INIT, C_DATA, C_UTIL, C_RATES, C_RCONST, + MATLAB_GLOBAL, MATLAB_INIT, MATLAB_DATA, MATLAB_UTIL, MATLAB_RATES, MATLAB_RCONST, + INLINE_OPT + }; + +enum jacobian_format { JAC_OFF, JAC_FULL, JAC_LU_ROW, JAC_ROW }; + + +typedef short int CODE; +typedef float EQ_VECT[ MAX_EQN ]; + +typedef struct { + char name[ MAX_ATNAME ]; + char check; + char masscheck; + } ATOM_DEF; + +typedef struct { + unsigned char code; + unsigned char nr; + } ATOM; + +typedef struct { + char type; + char lookat; + char moni; + char trans; + short int nratoms; + char name[ MAX_SPNAME ]; + char ival[ MAX_IVAL ]; + ATOM atoms[ MAX_ATOMS ]; + } SPECIES_DEF; + +typedef struct { + char type; + union { + char st[ MAX_K ]; + float f; + } val; + char label[ MAX_EQNTAG ]; + } KREACT; + +typedef struct { + char * code; + int maxlen; + } ICODE; + + +extern int SpeciesNr; +extern int EqnNr; +extern int SpcNr; +extern int AtomNr; +extern int VarNr; +extern int VarActiveNr; +extern int FixNr; +extern int VarStartNr; +extern int FixStartNr; +extern int Hess_NZ; +extern int LU_Jac_NZ; +extern int Jac_NZ; + +extern int generateSD; + +extern int initNr; +extern int xNr; +extern int yNr; +extern int zNr; + +extern int falseSpcNr; + +extern int useAggregate; +extern int useJacobian; +extern int useJacSparse; +extern int useHessian; +extern int useStoicmat; +extern int useDouble; +extern int useReorder; +extern int useMex; +extern int useDummyindex; +extern int useEqntags; +extern int useLang; +extern int useStochastic; +extern int useWRFConform; + +extern char Home[ MAX_PATH ]; +extern char integrator[ MAX_PATH ]; +extern char driver[ MAX_PATH ]; +extern char runArgs[ MAX_PATH ]; + +extern char *eqFileName; +extern char *rootFileName; + +extern ATOM_DEF AtomTable[ MAX_ATNR ]; +extern SPECIES_DEF SpeciesTable[ MAX_SPECIES ]; +extern KREACT kr [ MAX_EQN ]; +extern CODE ReverseCode[ MAX_SPECIES ]; +extern CODE Code [ MAX_SPECIES ]; +extern float** Stoich_Left; +extern float** Stoich; +extern float** Stoich_Right; +extern int Reactive [ MAX_SPECIES ]; + +extern int **structB; +extern int **structJ; +extern int **LUstructJ; + +extern ICODE InlineCode[ INLINE_OPT ]; + +extern char *fileList[ MAX_FILES ]; +extern int fileNr; + +extern char varDefault[ MAX_IVAL ]; +extern char radDefault[ MAX_IVAL ]; +extern char fixDefault[ MAX_IVAL ]; +extern double cfactor; + +void CmdFunction( char *cmd ); +void CmdJacobian( char *cmd ); +void CmdHessian( char *cmd ); +void CmdDouble( char *cmd ); +void CmdReorder( char *cmd ); +void CmdMex( char *cmd ); +void CmdDummyindex( char *cmd ); +void CmdEqntags( char *cmd ); +void CmdUse( char *cmd ); +void CmdLanguage( char *cmd ); +void CmdIntegrator( char *cmd ); +void CmdDriver( char *cmd ); +void CmdRun( char *cmd ); +void CmdStochastic( char *cmd ); + +void Generate(); + +char * FileName( char *name, char* env, char *dir, char *ext ); + +int* AllocIntegerVector( int n, char* message ); +int** AllocIntegerMatrix( int m, int n, char* message ); +void FreeIntegerMatrix ( int** mat, int m, int n ); +int Index( int i ); + +#endif + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdef.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdef.h new file mode 100755 index 00000000..39f38277 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gdef.h @@ -0,0 +1,46 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#ifndef _GDEF_H_ +#define _GDEF_H_ + +#include + +#if defined ( __BORLANDC__ ) + #include +#endif + +#include +#define Va_start( x, y ) va_start( x, y ) +#define Va_list va_list + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gen.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gen.c new file mode 100755 index 00000000..d803eef7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/gen.c @@ -0,0 +1,3563 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "code.h" +#include "scan.h" + +#define MAX_MONITOR 8 + + +enum strutypes { PLAIN, LU }; + +int **structB; +int **structJ; +int **LUstructJ; + +ICODE InlineCode[ INLINE_OPT ]; + +int NSPEC, NVAR, NVARACT, NFIX, NREACT; +int NVARST, NFIXST, PI; +int C_DEFAULT, C; +int DC; +int ARP, JVRP, NJVRP, CROW_JVRP, IROW_JVRP, ICOL_JVRP; +int V, F, VAR, FIX; +int RCONST, RCT; +int Vdot, P_VAR, D_VAR; +int KR, A, BV, BR, IV; +int JV, UV, JUV, JTUV, JVS; +int JR, UR, JUR, JRS; +int U1, U2, HU, HTU; +int X, XX, NTMPB; +int D2A, NTMPD2A, NHESS, HESS, IHESS_I, IHESS_J, IHESS_K; +int DDMTYPE; +int STOICM, NSTOICM, IROW_STOICM, ICOL_STOICM, CCOL_STOICM, CNEQN; +int IROW, ICOL, CROW, DIAG; +int LU_IROW, LU_ICOL, LU_CROW, LU_DIAG, CNVAR; +int LOOKAT, NLOOKAT, MONITOR, NMONITOR; +int NMASS, SMASS; +int SPC_NAMES, EQN_NAMES; +int EQN_TAGS; +int NONZERO, LU_NONZERO; +int TIME, SUN, TEMP; +int RTOLS, TSTART, TEND, DT; +int ATOL, RTOL, STEPMIN, STEPMAX, CFACTOR; +int V_USER, CL; +int NMLCV, NMLCF, SCT, PROPENSITY, VOLUME, IRCT; + +int Jac_NZ, LU_Jac_NZ, nzr; + +NODE *sum, *prod; +int real; +int nlookat; +int nmoni; +int ntrans; +int nmass; +char * CommonName; + +int Hess_NZ, *iHess_i, *iHess_j, *iHess_k; +int nnz_stoicm; + +/* if ValueDimension=1 KPP replaces parameters like NVAR etc. by their values in vector/matrix declarations */ +char ValueDimension = 0; + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +char * ascii(int x) +{ +static char s[40]; + + sprintf(s, "%d", x); + return s; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +char * ascid(double x) +{ +static char s[40]; + + sprintf(s, "%12.6e", x); + /* if (useDouble && ( (useLang==F77_LANG)||(useLang==F90_LANG) ) ) { */ + if (useDouble && (useLang==F77_LANG)) + s[strlen(s)-4] = 'd'; + if (useDouble && (useLang==F90_LANG)) + sprintf(s, "%s_dp",s); + return s; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +NODE * RConst( int n ) +{ + switch( kr[n].type ) { + case NUMBER: return Const( kr[n].val.f ); + case PHOTO: + case EXPRESION: return Elm( RCT, n ); + } + return 0; +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void InitGen() +{ +int i,j; + + NSPEC = DefConst( "NSPEC", INT, "Number of chemical species" ); + NVAR = DefConst( "NVAR", INT, "Number of Variable species" ); + NVARACT = DefConst( "NVARACT", INT, "Number of Active species" ); + NFIX = DefConst( "NFIX", INT, "Number of Fixed species" ); + NREACT = DefConst( "NREACT", INT, "Number of reactions" ); + NVARST = DefConst( "NVARST", INT, "Starting of variables in conc. vect." ); + NFIXST = DefConst( "NFIXST", INT, "Starting of fixed in conc. vect." ); + NONZERO = DefConst( "NONZERO", INT, "Number of nonzero entries in Jacobian" ); + LU_NONZERO = DefConst( "LU_NONZERO", INT, "Number of nonzero entries in LU factoriz. of Jacobian" ); + CNVAR = DefConst( "CNVAR", INT, "(NVAR+1) Number of elements in compressed row format" ); + CNEQN = DefConst( "CNEQN", INT, "(NREACT+1) Number stoicm elements in compressed col format" ); + + PI = DefConst( "PI", real, "Value of pi" ); + + VAR = DefvElm( "VAR", real, -NVAR, "Concentrations of variable species (global)" ); + FIX = DefvElm( "FIX", real, -NFIX, "Concentrations of fixed species (global)" ); + + V = DefvElm( "V", real, -NVAR, "Concentrations of variable species (local)" ); + F = DefvElm( "F", real, -NFIX, "Concentrations of fixed species (local)" ); + + V_USER = DefvElm( "V_USER", real, -NVAR, "Concentration of variable species in USER's order" ); + + RCONST = DefvElm( "RCONST", real, -NREACT, "Rate constants (global)" ); + RCT = DefvElm( "RCT", real, -NREACT, "Rate constants (local)" ); + + Vdot = DefvElm( "Vdot", real, -NVAR, "Time derivative of variable species concentrations" ); + P_VAR = DefvElm( "P_VAR", real, -NVAR, "Production term" ); + D_VAR = DefvElm( "D_VAR", real, -NVAR, "Destruction term" ); + + + JVS = DefvElm( "JVS", real, -LU_NONZERO, "sparse Jacobian of variables" ); + + JV = DefmElm( "JV", real, -NVAR, -NVAR, "full Jacobian of variables" ); + + UV = DefvElm( "UV", real, -NVAR, "User vector for variables" ); + JUV = DefvElm( "JUV", real, -NVAR, "Jacobian times user vector" ); + JTUV = DefvElm( "JTUV",real, -NVAR, "Jacobian transposed times user vector" ); + + X = DefvElm( "X", real, -NVAR, "Vector for variables" ); + XX = DefvElm( "XX", real, -NVAR, "Vector for output variables" ); + + TIME = DefElm( "TIME", real, "Current integration time"); + SUN = DefElm( "SUN", real, "Sunlight intensity between [0,1]"); + TEMP = DefElm( "TEMP", real, "Temperature"); + + RTOLS = DefElm( "RTOLS", real, "(scalar) Relative tolerance"); + TSTART = DefElm( "TSTART", real, "Integration start time"); + TEND = DefElm( "TEND", real, "Integration end time"); + DT = DefElm( "DT", real, "Integration step"); + + A = DefvElm( "A", real, -NREACT, "Rate for each equation" ); + + ARP = DefvElm( "ARP", real, -NREACT, "Reactant product in each equation" ); + NJVRP = DefConst( "NJVRP", INT, "Length of sparse Jacobian JVRP" ); + JVRP = DefvElm( "JVRP", real, -NJVRP, "d ARP(1:NREACT)/d VAR (1:NVAR)" ); + CROW_JVRP= DefvElm( "CROW_JVRP", INT, -CNEQN, "Beginning of rows in JVRP" ); + ICOL_JVRP= DefvElm( "ICOL_JVRP", INT, -NJVRP, "Column indices in JVRP" ); + IROW_JVRP= DefvElm( "IROW_JVRP", INT, -NJVRP, "Row indices in JVRP" ); + + NTMPB = DefConst( "NTMPB", INT, "Length of Temporary Array B" ); + BV = DefvElm( "B", real, -NTMPB, "Temporary array" ); + + NSTOICM = DefConst("NSTOICM", INT, "Length of Sparse Stoichiometric Matrix" ); + STOICM = DefvElm( "STOICM", real, -NSTOICM, "Stoichiometric Matrix in compressed column format" ); + IROW_STOICM = DefvElm( "IROW_STOICM", INT, -NSTOICM, "Row indices in STOICM" ); + ICOL_STOICM = DefvElm( "ICOL_STOICM", INT, -NSTOICM, "Column indices in STOICM" ); + CCOL_STOICM = DefvElm( "CCOL_STOICM", INT, -CNEQN, "Beginning of columns in STOICM" ); + + DDMTYPE = DefElm( "DDMTYPE", INT, "DDM sensitivity w.r.t.: 0=init.val., 1=params" ); + + NTMPD2A= DefConst( "NTMPD2A", INT, "Length of Temporary Array D2A" ); + D2A = DefvElm( "D2A", real, -NTMPD2A, "Second derivatives of equation rates" ); + NHESS = DefConst( "NHESS", INT, "Length of Sparse Hessian" ); + HESS = DefvElm( "HESS", real, -NHESS, "Hessian of Var (i.e. the 3-tensor d Jac / d Var)" ); + IHESS_I = DefvElm( "IHESS_I", INT, -NHESS, "Index i of Hessian element d^2 f_i/dv_j.dv_k" ); + IHESS_J = DefvElm( "IHESS_J", INT, -NHESS, "Index j of Hessian element d^2 f_i/dv_j.dv_k" ); + IHESS_K = DefvElm( "IHESS_K", INT, -NHESS, "Index k of Hessian element d^2 f_i/dv_j.dv_k" ); + U1 = DefvElm( "U1", real, -NVAR, "User vector" ); + U2 = DefvElm( "U2", real, -NVAR, "User vector" ); + HU = DefvElm( "HU", real, -NVAR, "Hessian times user vectors: (Hess x U2) * U1 = [d (Jac*U1)/d Var] * U2" ); + HTU = DefvElm( "HTU", real, -NVAR, "Transposed Hessian times user vectors: (Hess x U2)^T * U1 = [d (Jac^T*U1)/d Var] * U2 " ); + + KR = DefeElm( "KR", 0 ); + + IROW = DefvElm( "IROW", INT, -NONZERO, "Row indexes of the Jacobian of variables" ); + ICOL = DefvElm( "ICOL", INT, -NONZERO, "Column indexes of the Jacobian of variables" ); + CROW = DefvElm( "CROW", INT, -CNVAR, "Compressed row indexes of the Jacobian of variables" ); + DIAG = DefvElm( "DIAG", INT, -CNVAR, "Diagonal indexes of the Jacobian of variables" ); + LU_IROW = DefvElm( "LU_IROW", INT, -LU_NONZERO, "Row indexes of the LU Jacobian of variables" ); + LU_ICOL = DefvElm( "LU_ICOL", INT, -LU_NONZERO, "Column indexes of the LU Jacobian of variables" ); + LU_CROW = DefvElm( "LU_CROW", INT, -CNVAR, "Compressed row indexes of the LU Jacobian of variables" ); + LU_DIAG = DefvElm( "LU_DIAG", INT, -CNVAR, "Diagonal indexes of the LU Jacobian of variables" ); + + IV = DefeElm( "IV", 0 ); + + C_DEFAULT = DefvElm( "C_DEFAULT", real, -NSPEC, "Default concentration for all species" ); + C = DefvElm( "C", real, -NSPEC, "Concentration of all species" ); + CL = DefvElm( "CL", real, -NSPEC, "Concentration of all species (local)" ); + DC = DefvElm( "DC", real, -NSPEC, "Fluxes of all species" ); + ATOL = DefvElm( "ATOL", real, -NSPEC, "Absolute tolerance" ); + RTOL = DefvElm( "RTOL", real, -NSPEC, "Relative tolerance" ); + + STEPMIN = DefElm( "STEPMIN", real, "Lower bound for integration step"); + STEPMAX = DefElm( "STEPMAX", real, "Upper bound for integration step"); + + NLOOKAT = DefConst( "NLOOKAT", INT, "Number of species to look at" ); + LOOKAT = DefvElm( "LOOKAT", INT, -NLOOKAT, "Indexes of species to look at" ); + + NMONITOR = DefConst( "NMONITOR", INT, "Number of species to monitor" ); + MONITOR = DefvElm( "MONITOR", INT, -NMONITOR, "Indexes of species to monitor" ); + + NMASS = DefConst( "NMASS", INT, "Number of atoms to check mass balance" ); + SMASS = DefvElm( "SMASS", STRING, -NMASS, "Names of atoms for mass balance" ); + + EQN_TAGS = DefvElm( "EQN_TAGS", STRING, -NREACT, "Equation tags" ); + EQN_NAMES = DefvElm( "EQN_NAMES", DOUBLESTRING, -NREACT, "Equation names" ); + SPC_NAMES = DefvElm( "SPC_NAMES", STRING, -NSPEC, "Names of chemical species" ); + + CFACTOR = DefElm( "CFACTOR", real, "Conversion factor for concentration units"); + + /* Elements of Stochastic simulation*/ + NMLCV = DefvElm( "NmlcV", INT, -NVAR, "No. molecules of variable species" ); + NMLCF = DefvElm( "NmlcF", INT, -NFIX, "No. molecules of fixed species" ); + SCT = DefvElm( "SCT", real, -NREACT, "Stochastic rate constants" ); + PROPENSITY = DefvElm( "Prop", real, -NREACT, "Propensity vector" ); + VOLUME = DefElm( "Volume", real, "Volume of the reaction container" ); + IRCT = DefElm( "IRCT", INT, "Index of chemical reaction" ); + + for ( i=0; i value = max(SpcNr,1); + varTable[ NVAR ] -> value = max(VarNr,1); + varTable[ NVARACT ] -> value = max(VarActiveNr,1); + varTable[ NFIX ] -> value = max(FixNr,1); + varTable[ NREACT ] -> value = max(EqnNr,1); + varTable[ NVARST ] -> value = Index(0); + varTable[ NFIXST ] -> value = Index(VarNr); + } +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int NonZero( int stru, int start, int end, + int *row, int *col, int *crow, int *diag ) +{ +int nElm; +int i,j; + + nElm = 0; + for (i = 0; i < end-start; i++) { + crow[i] = Index(nElm); + for (j = 0; j < end-start; j++) { + if( (i == j) || ( (stru) ? LUstructJ[i+start][j+start] + : structJ[i+start][j+start] ) ) { + row[nElm] = Index(i); + col[nElm] = Index(j); + nElm++; + } + if( i == j ) { + diag[i] = Index(nElm-1); + } + } + } + crow[i] = Index(nElm); + diag[i] = Index(nElm); + return nElm; +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *EQN_NAMES[MAX_EQN]; +char *EQN_TAGS[MAX_EQN]; +char *bufeqn, *p; +int dim; + + if ( (useLang != C_LANG)&&(useLang != MATLAB_LANG) ) return; + + UseFile( driverFile ); + + NewLines(1); + + GlobalDeclare( C ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[VAR]->name, varTable[C]->name, 0 ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[FIX]->name, varTable[C]->name, VarNr ); + + + GlobalDeclare( RCONST ); + GlobalDeclare( TIME ); + GlobalDeclare( SUN ); + GlobalDeclare( TEMP ); + GlobalDeclare( RTOLS ); + GlobalDeclare( TSTART ); + GlobalDeclare( TEND ); + GlobalDeclare( DT ); + GlobalDeclare( ATOL ); + GlobalDeclare( RTOL ); + GlobalDeclare( STEPMIN ); + GlobalDeclare( STEPMAX ); + GlobalDeclare( CFACTOR ); + if (useStochastic) + GlobalDeclare( VOLUME ); + + MATLAB_Inline(" %s_Parameters;",rootFileName); + MATLAB_Inline(" %s_Global_defs;",rootFileName); + MATLAB_Inline(" %s_Sparse;",rootFileName); + MATLAB_Inline(" %s_Monitor;",rootFileName); + if (useJacSparse ) + MATLAB_Inline(" %s_JacobianSP;",rootFileName); + if (useHessian ) + MATLAB_Inline(" %s_HessianSP;",rootFileName); + if (useStoicmat ) + MATLAB_Inline(" %s_StoichiomSP;",rootFileName); + + NewLines(1); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMonitorData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *seqn[MAX_EQN]; +char *bufeqn, *p; +int dim; + + + /* Allocate local data structures */ + dim = SpcNr+2; + crow = AllocIntegerVector( dim, "crow in GenerateMonitorData"); + diag = AllocIntegerVector( dim, "diag in GenerateMonitorData"); + lookat = AllocIntegerVector( dim, "lookat in GenerateMonitorData"); + moni = AllocIntegerVector( dim, "moni in GenerateMonitorData"); + trans = AllocIntegerVector( dim, "trans in GenerateMonitorData"); + + UseFile( monitorFile ); + + F77_Inline("%6sBLOCK DATA MONITOR_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Parameters.h'", " ",rootFileName); + F77_Inline("%6sINCLUDE '%s_Global.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i", " " ); + + /* InitDeclare( CFACTOR, 0, (void*)&cfactor ); */ + + NewLines(1); + + for (i = 0; i < SpcNr; i++) { + snames[i] = SpeciesTable[Code[i]].name; + } + InitDeclare( SPC_NAMES, SpcNr, (void*)snames ); + + nlookat = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].lookat ) { + lookat[nlookat] = Index(i); + nlookat++; + } + + if (ValueDimension) + varTable[ NLOOKAT ] -> value = max(nlookat,1); + InitDeclare( LOOKAT, nlookat, (void*)lookat ); + + nmoni = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].moni ) { + moni[nmoni] = Index(i); + nmoni++; + } + + if( nmoni > MAX_MONITOR ) { + Warning( "%d species to monitorize. Too many, keeping %d.", + nmoni, MAX_MONITOR ); + nmoni = MAX_MONITOR; + } + + if (ValueDimension) + varTable[ NMONITOR ] -> value = max(nmoni,1); + InitDeclare( MONITOR, nmoni, (void*)moni ); + + ntrans = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].trans ) { + trans[ntrans] = Index(i); + strans[ntrans] = SpeciesTable[Code[i]].name; + ntrans++; + } + + nmass = 0; + for (i = 0; i < AtomNr; i++) + if ( AtomTable[i].masscheck ) { + smass[nmass] = AtomTable[i].name; + nmass++; + } + if (ValueDimension) + varTable[ NMASS ] -> value = max(nmass,1); + InitDeclare( SMASS, nmass, (void*)smass ); + + if ( (bufeqn = (char*)malloc(MAX_EQNLEN*EqnNr+2))==NULL ) { + FatalError(-30,"GenerateMonitorData: Cannot allocate bufeqn (%d chars)", + MAX_EQNLEN*EqnNr); + } + + p = bufeqn; + for (i = 0; i < EqnNr; i++) { + EqnString(i, p); + seqn[i] = p; + p += MAX_EQNLEN; + } + InitDeclare( EQN_NAMES, EqnNr, (void*)seqn ); + + free( bufeqn ); + + if (useEqntags==1) { + for (i = 0; i < EqnNr; i++) { + seqn[i] = kr[i].label; + } + InitDeclare( EQN_TAGS, EqnNr, (void*)seqn ); + } + + NewLines(1); + WriteComment("INLINED global variables"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_DATA ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_DATA ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_DATA ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_DATA ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED global variables"); + NewLines(1); + + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local data structures */ + free(crow); free(diag); free(lookat); free(moni); free(trans); + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseData() +{ +int* irow; +int* icol; +int* crow; +int* diag; +int nElm; +int dim; + + if( !useJacSparse ) return; + + /* Allocate local arrays */ + dim=MAX_SPECIES; + irow = AllocIntegerVector( dim*dim, "irow in GenerateJacobianSparseData" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateJacobianSparseData" ); + crow = AllocIntegerVector( dim, "crow in GenerateJacobianSparseData" ); + diag = AllocIntegerVector( dim, "diag in GenerateJacobianSparseData" ); + + + UseFile( sparse_jacFile ); + + NewLines(1); + WriteComment("Sparse Jacobian Data"); + NewLines(1); + + F77_Inline("%6sBLOCK DATA JACOBIAN_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i"," "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + + + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + if (ValueDimension) { + varTable[NONZERO] -> value = Jac_NZ; + varTable[LU_NONZERO] -> value = LU_Jac_NZ; + } + + switch (useJacobian) { + case JAC_ROW: + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( IROW, Jac_NZ, (void*)irow ); + InitDeclare( ICOL, Jac_NZ, (void*)icol ); + InitDeclare( CROW, VarNr+1, (void*)crow ); + InitDeclare( DIAG, VarNr+1, (void*)diag ); + break; + case JAC_LU_ROW: + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( LU_IROW, LU_Jac_NZ, (void*)irow ); + InitDeclare( LU_ICOL, LU_Jac_NZ, (void*)icol ); + InitDeclare( LU_CROW, VarNr+1, (void*)crow ); + InitDeclare( LU_DIAG, VarNr+1, (void*)diag ); + } + NewLines(1); + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local arrays */ + free(irow); free(icol); free(crow); free(diag); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseHeader() +{ + UseFile( sparse_dataFile ); + + CommonName = "SDATA"; + + NewLines(1); + WriteComment(" ----------> Sparse Jacobian Data"); + NewLines(1); + + switch (useJacobian) { + case JAC_ROW: + ExternDeclare( IROW ); + ExternDeclare( ICOL ); + ExternDeclare( CROW ); + ExternDeclare( DIAG ); + break; + case JAC_LU_ROW: + ExternDeclare( LU_IROW ); + ExternDeclare( LU_ICOL ); + ExternDeclare( LU_CROW ); + ExternDeclare( LU_DIAG ); + } + + NewLines(1); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateFun() +{ +int i, j, k; +int used; +int l, m; +int F_VAR, FSPLIT_VAR; +char buf1[100], buf2[100]; + + if( VarNr == 0 ) return; + + if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ + + if ( useWRFConform ) + UseFile( integratorFile ); + else + UseFile( functionFile ); + + if ( useWRFConform ) + { + sprintf( buf1, "%s_Fun", rootFileName ); + F_VAR = DefFnc( buf1, 4, "time derivatives of variables - Agregate form"); + sprintf( buf2, "%s_Fun_SPLIT", rootFileName ); + FSPLIT_VAR = DefFnc( buf2, 4, "time derivatives of variables - Agregate form"); + } + else + { + F_VAR = DefFnc( "Fun", 4, "time derivatives of variables - Agregate form"); + FSPLIT_VAR = DefFnc( "Fun_SPLIT", 5, "time derivatives of variables - Split form"); + + } + + if( useAggregate ) + FunctionBegin( F_VAR, V, F, RCT, Vdot ); + else + FunctionBegin( FSPLIT_VAR, V, F, RCT, P_VAR, D_VAR ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + + if ( useLang!=F90_LANG ) { /* A is a module variable in F90 */ + NewLines(1); + WriteComment("Local variables"); + Declare( A ); + } + + + if ( useWRFConform ) { /* .. but A is not a module variable in WRFConform */ + NewLines(1); + WriteComment("Local variables"); + Declare( A ); + } + + + NewLines(1); + WriteComment("Computation of equation rates"); + + for(j=0; j 1. PROPENSITY FUNCTION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "Propensity", 4, "Propensity function"); + FunctionBegin( F_VAR, NMLCV, NMLCF, SCT, PROPENSITY ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + NewLines(1); + + for(j=0; j 2. RATE CONVERSION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "StochasticRates", 3, "Convert deterministic rates to stochastic"); + FunctionBegin( F_VAR, RCT, VOLUME, SCT ); + WriteComment("No. of molecules = Concentration x Volume"); + WriteComment("For a reaction with k reactants:"); + WriteComment(" RCT [ (molec/Volume)^(1-k) * sec^(-1) ]"); + WriteComment(" SCT [ (molec)^(1-k) * sec^(-1) ] = RCT*Volume^(k-1)"); + WriteComment("For p molecules of the same type: SCT = SCT/(p!)"); + + NewLines(1); + + for(j=0; j 3. THE CHANGE IN NUMBER OF MOLECULES */ + if (useLang == MATLAB_LANG) { + F_VAR = DefFnc( "MoleculeChange", 3, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV, NMLCV ); + } else { + F_VAR = DefFnc( "MoleculeChange", 2, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV ); + } + + NewLines(1); + + F90_Inline("\n SELECT CASE (IRCT)\n"); + C_Inline ("\n switch (IRCT) { \n"); + MATLAB_Inline("\n switch (IRCT) \n"); + for(j=0; j value = JVRP_NZ + 1; + + FunctionEnd( F_STOIC ); + FreeVariable( F_STOIC ); + + + UseFile( sparse_stoicmFile ); + NewLines(1); + WriteComment("Row-compressed sparse data for the Jacobian of reaction products JVRP"); + F77_Inline("%6sBLOCK DATA JVRP_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ", rootFileName); + F77_Inline("%6sINTEGER i", " "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + if( (useLang==F77_LANG)||(useLang==F90_LANG) ) { + for (k=0; k value = nonzeros_B; + Declare( BV ); + } + + NewLines(1); + + for ( i=0; i=2) + nElm++; + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) + nElm++; + } + +/* Allocate temporary index arrays */ + coeff_j = AllocIntegerVector(nElm, "coeff_j in GenerateHess"); + coeff_i1 = AllocIntegerVector(nElm, "coeff_i1 in GenerateHess"); + coeff_i2 = AllocIntegerVector(nElm, "coeff_i2 in GenerateHess"); + +/* Fill in temporary index arrays */ + nElm = 0; + for(j=0; j=2) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } +/* Number of nonzero terms of the form d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + Djv_isElm = 1; + } + if (Djv_isElm == 1) Hess_NZ++ ; + } /* for i, i1, i2 */ + if (ValueDimension) + varTable[ NHESS ] -> value = max( Hess_NZ, 1 ); + +/* Allocate temporary index arrays */ + iHess_i = AllocIntegerVector(Hess_NZ, "iHess_i in GenerateHess"); + iHess_j = AllocIntegerVector(Hess_NZ, "iHess_j in GenerateHess"); + iHess_k = AllocIntegerVector(Hess_NZ, "iHess_k in GenerateHess"); + + F_Hess = DefFnc( "Hessian", 4, "function for Hessian (Jac derivative w.r.t. variables)"); + FunctionBegin( F_Hess, V, F, RCT, HESS ); + + WriteComment("--------------------------------------------------------"); + WriteComment("Note: HESS is represented in coordinate sparse format: "); + WriteComment(" HESS(m) = d^2 f_i / dv_j dv_k = d Jac_{i,j} / dv_k"); + WriteComment(" where i = IHESS_I(m), j = IHESS_J(m), k = IHESS_K(m)."); + WriteComment("--------------------------------------------------------"); + WriteComment("Note: d^2 f_i / dv_j dv_k = d^2 f_i / dv_k dv_j, "); + WriteComment(" therefore only the terms d^2 f_i / dv_j dv_k"); + WriteComment(" with j <= k are computed and stored in HESS."); + WriteComment("--------------------------------------------------------"); + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) { + NewLines(1); + WriteComment("Local variables"); + /* DeclareConstant( NTMPD2A, ascii( max( nElm, 1 ) ) ); */ + varTable[ NTMPD2A ] -> value = max( nElm, 1 ); + Declare( D2A ); + } + + NewLines(1); + WriteComment("Computation of the second derivatives of equation rates"); + +/* Generate d^2 A(j)/ ( d v(i1) d v(i2) )*/ + nElm = 0; + for(j=0; j=2) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j]-1 ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-2; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d)/{dV(%d)dV(%d)}",Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if (Stoich_Left[i1][j]>=2) */ + + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-1; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < i2; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i2][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i2][j]-1; k++ ) + prod = Mul( prod, Elm( V, i2 ) ); + for (i = i2+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d) / dV(%d)dV(%d)", + Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) */ + } /* if i1==i2 */ + + } /* for j, i1, i2 */ + + NewLines(1); + WriteComment("Computation of the Jacobian derivative"); + +/* Generate d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + sum = Const(0); + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + sum = Add( sum, + Mul( Const( Stoich[i][j] ), Elm( D2A, k ) ) ); + Djv_isElm = 1; + } + if (Djv_isElm == 1) { + WriteComment("HESS(%d) = d^2 Vdot(%d)/{dV(%d)dV(%d)} = d^2 Vdot(%d)/{dV(%d)dV(%d)}", + Index(Hess_NZ),Index(i),Index(i1),Index(i2),Index(i),Index(i2),Index(i1)); + Assign( Elm( HESS, Hess_NZ ), sum ); + iHess_i[ Hess_NZ ] = i; + iHess_j[ Hess_NZ ] = i1; + iHess_k[ Hess_NZ ] = i2; + Hess_NZ++; + } + + } /* for i, i1, i2 */ + + +/* free temporary index arrays */ + free(coeff_j); free(coeff_i1); free(coeff_i2); + + MATLAB_Inline("\n HESS = HESS(:);"); + + FunctionEnd( F_Hess ); + + FreeVariable( F_Hess ); + + + F_HessTR_VEC = DefFnc( "HessTR_Vec", 4, "Hessian transposed times user vectors"); + FunctionBegin( F_HessTR_VEC, HESS, U1, U2, HTU ); + WriteComment("Compute the vector HTU =(Hess x U2)^T * U1 = d (Jac^T*U1)/d Var * U2 "); + + for (i=0; i Sparse Hessian Data"); + NewLines(1); + + ExternDeclare( IHESS_I ); + ExternDeclare( IHESS_J ); + ExternDeclare( IHESS_K ); + + NewLines(1); +} + + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateStoicmSparseData() +{ +int i,j,k, nnz_stoicm; +/* +int irow_stoicm[MAX_SPECIES*MAX_EQN]; +int ccol_stoicm[MAX_EQN+2]; +int icol_stoicm[MAX_SPECIES*MAX_EQN]; +double stoicm[MAX_SPECIES*MAX_EQN]; +*/ + +int *irow_stoicm; +int *ccol_stoicm; +int *icol_stoicm; +double *stoicm; + +/* Compute the sparsity structure and allocate data structure vectors */ + nnz_stoicm = 0; + for (j=0; j Sparse Stoichiometric Matrix"); + NewLines(1); + CommonName = "STOICM_VALUES"; + ExternDeclare( STOICM ); + CommonName = "STOICM_DATA"; + ExternDeclare( IROW_STOICM ); + ExternDeclare( CCOL_STOICM ); + ExternDeclare( ICOL_STOICM ); + NewLines(1); + + NewLines(1); + WriteComment(" ----------> Sparse Data for Jacobian of Reactant Products"); + NewLines(1); + CommonName = "JVRP"; + ExternDeclare( ICOL_JVRP ); + ExternDeclare( IROW_JVRP ); + ExternDeclare( CROW_JVRP ); + NewLines(1); + +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacVect() +{ +int i, j, nElm; +int Jac_VEC; +int Jac_SP_VEC; + + if( useLang == MATLAB_LANG ) return; + + if( VarNr == 0 ) return; + + UseFile( jacobianFile ); + Jac_VEC = DefFnc( "Jac_Vec", 3, + "function for sparse multiplication: square Jacobian times vector"); + Jac_SP_VEC = DefFnc( "Jac_SP_Vec", 3, + "function for sparse multiplication: sparse Jacobian times vector"); + + if ( useJacSparse ) { + FunctionBegin( Jac_SP_VEC, JVS, UV, JUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JVS, nElm ), Elm( UV, j ) ) ); + nElm++; + } + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_SP_VEC ); + } + + else { + FunctionBegin( Jac_VEC, JV, UV, JUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JV, i, j ), Elm( UV, j ) ) ); + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_VEC ); + } + + FreeVariable( Jac_VEC ); + FreeVariable( Jac_SP_VEC ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacTRVect() +{ +int i, j, nElm; +int JacTR_VEC; +int JacTR_SP_VEC; +int **TmpStruct; + + if( useLang == MATLAB_LANG ) return; + + if ( VarNr == 0 ) return; + + UseFile( jacobianFile ); + + JacTR_VEC = DefFnc( "JacTR_Vec", 3, + "sparse multiplication: square Jacobian transposed times vector"); + JacTR_SP_VEC = DefFnc( "JacTR_SP_Vec", 3, + "sparse multiplication: sparse Jacobian transposed times vector"); + + if ( useJacSparse ) { + + /* The temporary array of structure */ + TmpStruct = AllocIntegerMatrix( VarNr, VarNr, "TmpStruct in GenerateJacTRVect" ); + + nElm = 0; + for( i = 0; i < VarNr; i++) + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + TmpStruct[i][j] = nElm; + nElm++; + } + + FunctionBegin( JacTR_SP_VEC, JVS, UV, JTUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JVS, TmpStruct[j][i] ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_SP_VEC ); + + /* Free the temporary array of structure */ + FreeIntegerMatrix( TmpStruct, VarNr, VarNr ); + + } /* useJacSparse*/ + + else { + FunctionBegin( JacTR_VEC, JV, UV, JTUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JV, j, i ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_VEC ); + } + + FreeVariable( JacTR_VEC ); + FreeVariable( JacTR_SP_VEC ); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSparseUtil() +{ +int SUTIL; + + if ( useLang == MATLAB_LANG ) return; + + + if ( useWRFConform ) + UseFile( integratorFile ); + else + UseFile( linalgFile ); + + + SUTIL = DefFnc( "SPARSE_UTIL", 0, "SPARSE utility functions"); + CommentFunctionBegin( SUTIL ); + + if ( useWRFConform ) + IncludeCode( "%s/util/WRF_conform/sutil", Home ); + else + IncludeCode( "%s/util/sutil", Home ); + + CommentFunctionEnd( SUTIL ); + FreeVariable( SUTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateBlas() +{ +int BLAS; + + if ( useLang == MATLAB_LANG ) return; + + + if ( useWRFConform ) + UseFile( integratorFile ); + else + UseFile( linalgFile ); + + BLAS = DefFnc( "BLAS_UTIL", 0, "BLAS-LIKE utility functions"); + CommentFunctionBegin( BLAS ); + + + if ( useWRFConform ) + IncludeCode( "%s/util/WRF_conform/blas", Home ); + else + IncludeCode( "%s/util/blas", Home ); + + CommentFunctionEnd( BLAS ); + FreeVariable( BLAS ); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDFunDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dFun_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDJacDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dJac_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSolve() +{ +int i, j; +int SOLVE; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int dim; +char buf1[100]; + + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateSolve" ); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + + if ( useWRFConform ){ + UseFile( integratorFile ); + sprintf( buf1, "%s_KppSolve", rootFileName ); + }else{ + UseFile( linalgFile ); + sprintf( buf1, "KppSolve", rootFileName ); + } + + SOLVE = DefFnc( buf1, 2, "sparse back substitution"); + FunctionBegin( SOLVE, JVS, X ); + + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + sum = Elm( X, i ); + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + Assign( Elm( X, i ), sum ); + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + sum = Elm( X, i ); + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + sum = Div( sum, Elm( JVS, diag[i] ) ); + Assign( Elm( X, i ), sum ); + } + + FunctionEnd( SOLVE ); + FreeVariable( SOLVE ); + + /* Free Local Arrays */ + free(irow); + free(icol); + free(crow); + free(diag); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateTRSolve() +{ +int i, j; +int SOLVETR; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int **pos; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateTRSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateTRSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateTRSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateTRSolve" ); + pos = AllocIntegerMatrix( dim+1, dim+1, "pos in GenerateTRSolve"); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVETR = DefFnc( "KppSolveTR", 3, "sparse, transposed back substitution"); + FunctionBegin( SOLVETR, JVS, X, XX ); + for( i = 0; i < VarNr; i++) { + for( j = 0; j < VarNr; j++) + pos[i][j]=-1; + } + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + pos[i][i]=diag[i]; + } + + for( i = 0; i= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + sum=Div( sum, Elm(JVS, diag[i] ) ); + Assign( Elm( XX, i ), sum ); + } + for( i = VarNr-1; i >=0; i--) { + sum = Elm( XX, i ); + for (j=i+1; j= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + Assign( Elm( XX, i ), sum ); + } + + FunctionEnd( SOLVETR ); + FreeVariable( SOLVETR ); + /* Free Local Arrays */ + free(irow); free(icol); free(crow); free(diag); + FreeIntegerMatrix(pos, dim+1, dim+1); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateRateLaws() +{ + + UseFile( rateFile ); + + NewLines(1); + WriteComment("Begin Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + IncludeCode( "%s/util/UserRateLaws", Home ); + NewLines(1); + WriteComment("End Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED Rate Law Functions"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RATES ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RATES ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RATES ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RATES ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Rate Law Functions"); + NewLines(1); + + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateRateLawsWRF() +{ + + UseFile( wrf_UpdateRconstFile ); + + NewLines(1); + WriteComment("Begin Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + IncludeCode( "%s/util/WRF_conform/WRFUserRateLaws", Home ); + NewLines(1); + WriteComment("End Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED Rate Law Functions"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RATES ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RATES ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RATES ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RATES ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Rate Law Functions"); + NewLines(1); + + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateSun() +{ +int UPDATE_SUN; + + UseFile( rateFile ); + + UPDATE_SUN = DefFnc( "Update_SUN", 0, "update SUN light using TIME"); + CommentFunctionBegin( UPDATE_SUN ); + + IncludeCode( "%s/util/UpdateSun", Home ); + + CommentFunctionEnd( UPDATE_SUN ); + FreeVariable( UPDATE_SUN ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateRconst() +{ +int i; +int UPDATE_RCONST; + + UseFile( rateFile ); + + UPDATE_RCONST = DefFnc( "Update_RCONST", 0, "function to update rate constants"); + + FunctionBegin( UPDATE_RCONST ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + if ( (useLang==F77_LANG) ) + IncludeCode( "%s/util/UserRateLaws_FcnHeader", Home ); + + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED RCONST"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RCONST ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RCONST ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RCONST ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RCONST ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED RCONST"); + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == EXPRESION ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + /* mz_rs_20050117+ */ + if ( kr[i].type == NUMBER ) { + F90_Inline("! RCONST(%d) = constant rate coefficient", i+1); + /* WriteComment("Constant rate coefficient (value inlined in the code):"); */ + /* Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); */ + } + /* mz_rs_20050117- */ + } + + MATLAB_Inline(" RCONST = RCONST(:);"); + + FunctionEnd( UPDATE_RCONST ); + FreeVariable( UPDATE_RCONST ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateRconstWRF( ) +{ +int i; +/* int UPDATE_RCONST; */ + + + UseFile( wrf_UpdateRconstFile ); + + bprintf( "SUBROUTINE %s_Update_RCONST( &\n", rootFileName ); + bprintf( "!\n"); + bprintf( "#include \n",rootFileName ); + bprintf( "!\n"); + bprintf( "#include \n"); + bprintf( "!\n)\n\n\n"); + bprintf( "!\n"); + bprintf( "#include \n"); + bprintf( "!\n"); + bprintf( "#include \n",rootFileName ); + bprintf( "!\n"); + + /* UPDATE_RCONST = DefFnc( buf1, 0, "function to update rate constants"); */ + + /* FunctionBegin( UPDATE_RCONST ); */ + + + + + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED RCONST"); + NewLines(1); + + switch( useLang ) { + case C_LANG: FatalError(-99,"USE F90 with WRF_conform option"); + break; + case F77_LANG: FatalError(-99,"USE F90 with WRF_conform option"); + break; + case F90_LANG: bprintf( InlineCode[ F90_RCONST ].code ); + break; + case MATLAB_LANG: FatalError(-99,"USE F90 with WRF_conform option"); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED RCONST"); + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == EXPRESION ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + /* mz_rs_20050117+ */ + if ( kr[i].type == NUMBER ) { + /* F90_Inline("! RCONST(%d) = constant rate coefficient", i+1); */ + /* WriteComment("Constant rate coefficient (value inlined in the code):"); */ + Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); + } + /* mz_rs_20050117- */ + } + + + /* FunctionEnd( UPDATE_RCONST ); + FreeVariable( UPDATE_RCONST ); */ + + bprintf( "END SUBROUTINE %s_Update_RCONST\n", rootFileName ); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdatePhoto() +{ +int i; +int UPDATE_PHOTO; + + UseFile( rateFile ); + + UPDATE_PHOTO = DefFnc( "Update_PHOTO", 0, "function to update photolytical rate constants"); + + FunctionBegin( UPDATE_PHOTO ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + } + + FunctionEnd( UPDATE_PHOTO ); + FreeVariable( UPDATE_PHOTO ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateIntegrator() +{ +int TIN, TOUT, INTEGRATE; + + UseFile( integratorFile ); + + TIN = DefElm( "TIN", real, "Start Time for Integration"); + TOUT = DefElm( "TOUT", real, "End Time for Integration"); + INTEGRATE = DefFnc( "INTEGRATE", 2, "Integrator routine"); + CommentFunctionBegin( INTEGRATE, TIN, TOUT ); + + if( strchr( integrator, '/' ) ) + IncludeCode( integrator ); + else { + + if ( useWRFConform ){ + printf( "\n \n KPP is using the WRF conform integrator routine: \n %s/int/WRF_conform/%s \n", Home, integrator ); + IncludeCode( "%s/int/WRF_conform/%s", Home, integrator ); } + else + IncludeCode( "%s/int/%s", Home, integrator ); + + } + + CommentFunctionEnd( INTEGRATE ); + FreeVariable( INTEGRATE ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDriver() +{ +int MAIN; + + UseFile( driverFile ); + + MAIN = DefFnc( "MAIN", 0, "Main program - driver routine"); + CommentFunctionBegin( MAIN ); + + if( strchr( driver, '/' ) ) + IncludeCode( driver ); + else + IncludeCode( "%s/drv/%s", Home, driver ); + + CommentFunctionEnd( MAIN ); + FreeVariable( MAIN ); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateEndModule() +{ + + + UseFile( integratorFile ); + + F90_Inline("END MODULE %s_Integrator", rootFileName); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUtil() +{ +int UTIL; + +/* if (useLang == MATLAB_LANG) return; */ + + UseFile( utilFile ); + NewLines(1); + WriteComment("User INLINED Utility Functions"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_UTIL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_UTIL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_UTIL ].code ); + break; + case MATLAB_LANG:bprintf( InlineCode[ MATLAB_UTIL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Utility Functions"); + NewLines(1); + + WriteComment("Utility Functions from KPP_HOME/util/util"); + UTIL = DefFnc( "UTIL", 0, "Utility functions"); + CommentFunctionBegin( UTIL); + + IncludeCode( "%s/util/util", Home ); + + if ((useLang == F90_LANG) && (useEqntags==1)) { + IncludeCode( "%s/util/tag2num", Home ); + } + + WriteComment("End Utility Functions from KPP_HOME/util/util"); + CommentFunctionEnd( UTIL ); + FreeVariable( UTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateParamHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + +int j,dummy_species; + +/* ----------> First declaration of constants */ + UseFile( param_headerFile ); + + NewLines(1); + DeclareConstant( NSPEC, ascii( max(SpcNr, 1) ) ); + DeclareConstant( NVAR, ascii( max(VarNr, 1) ) ); + DeclareConstant( NVARACT, ascii( max(VarActiveNr, 1) ) ); + DeclareConstant( NFIX, ascii( max(FixNr, 1) ) ); + DeclareConstant( NREACT, ascii( max(EqnNr, 1) ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + DeclareConstant( NONZERO, ascii( max(Jac_NZ, 1) ) ); + DeclareConstant( LU_NONZERO, ascii( max(LU_Jac_NZ, 1) ) ); + DeclareConstant( CNVAR, ascii( VarNr+1 ) ); + if ( useStoicmat ) { + DeclareConstant( CNEQN, ascii( EqnNr+1 ) ); + } + if ( useHessian ) { + DeclareConstant( NHESS, ascii( max(Hess_NZ, 1) ) ); + } + + DeclareConstant( NLOOKAT, ascii( nlookat ) ); + DeclareConstant( NMONITOR, ascii( nmoni ) ); + DeclareConstant( NMASS, ascii( nmass ) ); + + DeclareConstant( PI, "3.14159265358979" ); + + NewLines(1); + WriteComment("Index declaration for variable species in C and VAR"); + WriteComment(" VAR(ind_spc) = C(ind_spc)"); + NewLines(1); + for( i = 0; i < VarNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } + + NewLines(1); + WriteComment("Index declaration for fixed species in C"); + WriteComment(" C(ind_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i+VarNr) ) ); + FreeVariable( spc ); + } + + if (useDummyindex==1) { + NewLines(1); + WriteComment("Index declaration for dummy species"); + NewLines(1); + for( i = 0; i < MAX_SPECIES; i++) { + if (SpeciesTable[i].type == 0) continue; + dummy_species = 1; + for( j = 0; j < MAX_SPECIES; j++) + if (Code[j] == i) dummy_species = 0; + if (dummy_species) { + sprintf( name, "ind_%s", SpeciesTable[i].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( 0 ) ); + FreeVariable( spc ); + } + } + } + + NewLines(1); + WriteComment("Index declaration for fixed species in FIX"); + WriteComment(" FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "indf_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGlobalHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + + UseFile( global_dataFile ); + + CommonName = "GDATA"; + + NewLines(1); + WriteComment("Declaration of global variables"); + NewLines(1); + + /* ExternDeclare( C_DEFAULT ); */ + + ExternDeclare( C ); + + if( useLang == F77_LANG ) { + + Declare( VAR ); + Declare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == F90_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == MATLAB_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + } + + C_Inline(" extern %s * %s;", C_types[real], varTable[VAR]->name ); + C_Inline(" extern %s * %s;", C_types[real], varTable[FIX]->name ); + + + ExternDeclare( RCONST ); + ExternDeclare( TIME ); + ExternDeclare( SUN ); + ExternDeclare( TEMP ); + ExternDeclare( RTOLS ); + ExternDeclare( TSTART ); + ExternDeclare( TEND ); + ExternDeclare( DT ); + ExternDeclare( ATOL ); + ExternDeclare( RTOL ); + ExternDeclare( STEPMIN ); + ExternDeclare( STEPMAX ); + ExternDeclare( CFACTOR ); + if (useStochastic) + ExternDeclare( VOLUME ); + + CommonName = "INTGDATA"; + if ( useHessian ) { + ExternDeclare( DDMTYPE ); + } + + + if ( (useLang == C_LANG) || (useLang == F77_LANG) ) { + CommonName = "INTGDATA"; + ExternDeclare( LOOKAT ); + ExternDeclare( MONITOR ); + CommonName = "CHARGDATA"; + ExternDeclare( SPC_NAMES ); + ExternDeclare( SMASS ); + ExternDeclare( EQN_NAMES ); + ExternDeclare( EQN_TAGS ); + } + + NewLines(1); + WriteComment("INLINED global variable declarations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_GLOBAL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_GLOBAL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_GLOBAL ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_GLOBAL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("INLINED global variable declarations"); + NewLines(1); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void WriteSpec( int i, int j ) +{ +char buf[100]; + + if( Reactive[j] ) + sprintf( buf, "%s (r)", SpeciesTable[ Code[j] ].name ); + else + sprintf( buf, "%s (n)", SpeciesTable[ Code[j] ].name ); + WriteAll("%3d = %-10s", 1 + i, buf ); + FlushBuf(); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnStr( int eq, char * buf, float** mat ) +{ +int spc, first; + +/* bugfix if stoichiometric factor is not an integer */ +int n; +char s[40]; + + first = 1; + *buf = 0; + for( spc = 0; spc < SpcNr; spc++ ) + if( mat[spc][eq] != 0 ) { + if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { + sprintf(s, ""); + } else { + /* real */ + /* mz_rs_20050130+ */ + /* sprintf(s, "%g", mat[spc][eq]); */ + /* remove the minus sign with fabs(), it will be re-inserted later */ + sprintf(s, "%g", fabs(mat[spc][eq])); + /* mz_rs_20050130- */ + /* remove trailing zeroes */ + for (n= strlen(s) - 1; n >= 0; n--) + if (s[n] != '0') break; + s[n + 1]= '\0'; + sprintf(s, "%s ", s); + } + + if( first ) { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); + else sprintf(buf, "%s- %s", buf, s); + first = 0; + } else { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); + else sprintf(buf, "%s - %s", buf, s); + } + sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); + if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ + sprintf(buf, "%s ... etc.",buf); + break; + } + } + + return strlen(buf); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnString( int eq, char * buf ) +{ +static int lhs = 0; +static int rhs = 0; + +int i, l; +char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; + + if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, lhsbuf, Stoich_Left); + lhs = (lhs > l) ? lhs : l; + } + + if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, rhsbuf, Stoich_Right); + rhs = (rhs > l) ? lhs : l; + } + + + EqnStr( eq, lhsbuf, Stoich_Left); + EqnStr( eq, rhsbuf, Stoich_Right); + + sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); + return strlen(buf); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMap() +{ +int i; +int dn; + + UseFile( mapFile ); + + WriteAll("### Options -------------------------------------------\n"); + NewLines(1); + if( useAggregate ) WriteAll("FUNCTION - AGGREGATE\n"); + else WriteAll("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: WriteAll("JACOBIAN - OFF\n"); break; + case JAC_FULL: WriteAll("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: WriteAll("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: WriteAll("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) WriteAll("DOUBLE - ON\n"); + else WriteAll("DOUBLE - OFF\n"); + if( useReorder ) WriteAll("REORDER - ON\n"); + else WriteAll("REORDER - OFF\n"); + NewLines(1); + + WriteAll("### Parameters ----------------------------------------\n"); + NewLines(1); + + VarStartNr = Index(0); + FixStartNr = Index(VarNr); + + DeclareConstant( NSPEC, ascii( SpcNr ) ); + DeclareConstant( NVAR, ascii( max( VarNr, 1 ) ) ); + DeclareConstant( NVARACT, ascii( max( VarActiveNr, 1 ) ) ); + DeclareConstant( NFIX, ascii( max( FixNr, 1 ) ) ); + DeclareConstant( NREACT, ascii( EqnNr ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + + NewLines(1); + WriteAll("### Species -------------------------------------------\n"); + + NewLines(1); + WriteAll("Variable species\n"); + + dn = VarNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i -= 2*dn; WriteAll("\n"); + } + + + NewLines(1); + WriteAll("Fixed species\n"); + + dn = FixNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i -= 2*dn; WriteAll("\n"); + } + + NewLines(1); + WriteAll("### Subroutines ---------------------------------------\n"); + NewLines(1); + FlushBuf(); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateInitialize() +{ +int i; +int I, X; +int INITVAL; + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) + UseFile( initFile ); + + INITVAL = DefFnc( "Initialize", 0, "function to initialize concentrations"); + FunctionBegin( INITVAL ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global\n", rootFileName); + MATLAB_Inline("global CFACTOR VAR FIX NVAR NFIX", rootFileName); + + I = DefElm( "i", INT, 0); + X = DefElm( "x", real, 0); + Declare( I ); + Declare( X ); + + NewLines(1); + WriteAssign( varTable[CFACTOR]->name , ascid( (double)cfactor ) ); + NewLines(1); + + Assign( Elm( X ), Mul( Elm( IV, varDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NVAR; i++ )" ); + F77_Inline(" DO i = 1, NVAR" ); + F90_Inline(" DO i = 1, NVAR" ); + MATLAB_Inline(" for i = 1:NVAR" ); + ident++; + Assign( Elm( VAR, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + Assign( Elm( X ), Mul( Elm( IV, fixDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NFIX; i++ )" ); + F77_Inline(" DO i = 1, NFIX" ); + F90_Inline(" DO i = 1, NFIX" ); + MATLAB_Inline(" for i = 1:NFIX" ); + ident++; + Assign( Elm( FIX, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + + for( i = 0; i < VarNr; i++) { + if( *SpeciesTable[ Code[i] ].ival == 0 ) continue; + Assign( Elm( VAR, i ), Mul( + Elm( IV, SpeciesTable[ Code[i] ].ival ), + Elm( CFACTOR ) ) ); + } + + + for( i = 0; i < FixNr; i++) { + if( *SpeciesTable[ Code[i + VarNr] ].ival == 0 ) continue; + Assign( Elm( FIX, i ), Mul( + Elm( IV, SpeciesTable[ Code[i + VarNr] ].ival ), + Elm( CFACTOR ) ) ); + } + +/* NewLines(1); + C_Inline(" for( i = 0; i < NSPEC; i++ )" ); + F77_Inline(" do i = 1, NSPEC" ); + ident++; + Assign( Elm( C_DEFAULT, -I ), Elm( C, -I ) ); + ident--; + F77_Inline(" end do" ); +*/ + + /* mz_rs_20050117+ */ + WriteComment("constant rate coefficients"); + for( i = 0; i < EqnNr; i++) { + if ( kr[i].type == NUMBER ) + Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); + } + WriteComment("END constant rate coefficients"); + /* mz_rs_20050117- */ + + NewLines(1); + WriteComment("INLINED initializations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_INIT ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_INIT ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_INIT ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_INIT ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED initializations"); + NewLines(1); + + MATLAB_Inline(" VAR = VAR(:);\n FIX = FIX(:);\n" ); + + FreeVariable( X ); + FreeVariable( I ); + FunctionEnd( INITVAL ); + FreeVariable( INITVAL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_user2kpp() +{ +int i,k,l; +int Shuffle_user2kpp; + + UseFile( utilFile ); + + Shuffle_user2kpp = DefFnc( "Shuffle_user2kpp", 2, "function to copy concentrations from USER to KPP"); + FunctionBegin( Shuffle_user2kpp, V_USER, V ); + + k = 0;l = 0; + for( i = 1; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) { + Assign( Elm( V, ReverseCode[i] ), Elm( V_USER, k++ ) ); + break; + } + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_user2kpp ); + FreeVariable( Shuffle_user2kpp ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_kpp2user() +{ +int i,k,l; +int Shuffle_kpp2user; + + UseFile( utilFile ); + + Shuffle_kpp2user = DefFnc( "Shuffle_kpp2user", 2, "function to restore concentrations from KPP to USER"); + FunctionBegin( Shuffle_kpp2user, V, V_USER ); + + k = 0; l = 0; + for( i = 0; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) + Assign( Elm( V_USER, k++ ), Elm( V, ReverseCode[i] ) ); + break; + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_kpp2user ); + FreeVariable( Shuffle_kpp2user ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGetMass() +{ +int i; +int atm, spc; +int GETMASS, MASS; +SPECIES_DEF *sp; +int numass; + + UseFile( utilFile ); + + nmass = 0; + for( atm = 0; atm < AtomNr; atm++ ) + if( AtomTable[atm].masscheck ) nmass++; + if( nmass == 0 ) nmass = 1; + + MASS = DefvElm( "Mass", real, nmass, "value of mass balance" ); + GETMASS = DefFnc( "GetMass", 2, "compute total mass of selected atoms"); + FunctionBegin( GETMASS, CL, MASS); + + numass = 0; + for( atm = 0; atm < AtomNr; atm++ ) { + if( AtomTable[atm].masscheck ) { + sum = Const( 0 ); + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + for( i = 0; i < sp->nratoms; i++ ) { + if( sp->atoms[i].code == atm ) { + sum = Add( sum, Mul( Const( sp->atoms[i].nr ), + Elm( CL, spc ) ) ); + } + } + } + Assign( Elm( MASS, numass ), sum ); + numass++; + } + } + + FunctionEnd( GETMASS ); + FreeVariable( GETMASS ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMakefile() +{ +char buf[100]; + + if ( useLang == MATLAB_LANG ) return; + + sprintf( buf, "Makefile_%s", rootFileName ); + makeFile = fopen(buf, "w"); + if( makeFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + + UseFile( makeFile ); + + IncludeCode( "%s/util/Makefile", Home ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMex() +{ +char buf[100], suffix[5]; + + if (useLang == MATLAB_LANG) return; + if (useMex == 0) return; + + switch( useLang ) { + case F77_LANG: sprintf( suffix, "f"); + break; + case F90_LANG: sprintf( suffix, "f90"); + break; + case C_LANG: sprintf( suffix, "c"); + break; + default: printf("\nCannot create mex files for language %d\n", useLang); + exit(1); + break; + } + + sprintf( buf, "%s_mex_Fun.%s", rootFileName, suffix ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Mex_Fun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_mex_Jac_SP.%s", rootFileName, suffix ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Mex_Jac_SP", Home ); + } + + if (useHessian) { + sprintf( buf, "%s_mex_Hessian.%s", rootFileName, suffix ); + mex_hessFile = fopen(buf, "w"); + if( mex_hessFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_hessFile ); + IncludeCode( "%s/util/Mex_Hessian", Home ); + } + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMatlabTemplates() +{ +char buf[200], suffix[5]; + + if (useLang != MATLAB_LANG) return; + + + sprintf( buf, "%s_Fun_Chem.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Template_Fun_Chem", Home ); + + sprintf( buf, "%s_Update_SUN.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/UpdateSun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_Jac_Chem.m", rootFileName ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Template_Jac_Chem", Home ); + } + + if (useHessian) { + } + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateF90Modules(char where) +{ +char buf[200]; + +if (useLang != F90_LANG) return; + +switch (where) { +case 'h': + + sprintf( buf, "%s_Precision.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("\nMODULE %s_Precision\n", rootFileName ); + F90_Inline("!"); + F90_Inline("! Definition of different levels of accuracy"); + F90_Inline("! for REAL variables using KIND parameterization"); + F90_Inline("!"); + F90_Inline("! KPP SP - Single precision kind"); + F90_Inline(" INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,30)"); + F90_Inline("! KPP DP - Double precision kind"); + F90_Inline(" INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,300)"); + F90_Inline("! KPP QP - Quadruple precision kind"); + F90_Inline(" INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(18,400)"); + F90_Inline("\nEND MODULE %s_Precision\n\n", rootFileName ); + + UseFile( initFile ); + F90_Inline("MODULE %s_Initialize\n", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + F90_Inline("CONTAINS\n\n"); + + UseFile( param_headerFile ); + F90_Inline("MODULE %s_Parameters\n", rootFileName ); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( global_dataFile ); + F90_Inline("MODULE %s_Global\n", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: dp, NSPEC, NVAR, NFIX, NREACT", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( functionFile ); + F90_Inline("MODULE %s_Function\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + Declare( A ); /* mz_rs_20050117 */ + F90_Inline("\nCONTAINS\n\n"); + + UseFile( rateFile ); + F90_Inline("MODULE %s_Rates\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + + if ( useWRFConform ) { + UseFile( wrf_UpdateRconstFile ); + F90_Inline("MODULE %s_UpdateRconstWRF\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("MODULE %s_Stochastic\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: NVAR, NFIX, NREACT", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("MODULE %s_JacobianSP\n", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + } + + UseFile( jacobianFile ); + F90_Inline("MODULE %s_Jacobian\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("MODULE %s_StoichiomSP\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( stoichiomFile ); + F90_Inline("MODULE %s_Stoichiom\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_StoichiomSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("MODULE %s_HessianSP\n", rootFileName); + /* F90_Inline(" USE %s_Precision", rootFileName ); */ /* mz_rs_20050321 */ + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( hessianFile ); + F90_Inline("MODULE %s_Hessian\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_HessianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + UseFile( monitorFile ); + F90_Inline("MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("MODULE %s_LinearAlgebra\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + /* mz_rs_20050511+ if( useJacSparse ) added */ + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + /* mz_rs_20050511- */ + /* mz_rs_20050321+ */ + /* if (useHessian) */ + /* F90_Inline(" USE %s_HessianSP\n", rootFileName); */ + /* mz_rs_20050321- */ + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + UseFile( utilFile ); + F90_Inline("MODULE %s_Util\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + /* Here we define the model module which aggregates everything */ + /* put module rootFileName_Model into separate file */ + /* (reusing "sparse_dataFile" as done above for _Precision file) */ + sprintf( buf, "%s_Model.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("MODULE %s_Model\n", rootFileName); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("! Completely defines the model %s", rootFileName); + F90_Inline("! by using all the associated modules"); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("\n USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" USE %s_Function", rootFileName ); + F90_Inline(" USE %s_Integrator", rootFileName ); + F90_Inline(" USE %s_Rates", rootFileName ); + if ( useStochastic ) + F90_Inline(" USE %s_Stochastic", rootFileName ); + if ( useJacobian ) + F90_Inline(" USE %s_Jacobian", rootFileName ); + if ( useHessian ) + F90_Inline(" USE %s_Hessian", rootFileName); + if ( useStoicmat ) + F90_Inline(" USE %s_Stoichiom", rootFileName); + F90_Inline(" USE %s_LinearAlgebra", rootFileName); + F90_Inline(" USE %s_Monitor", rootFileName); + F90_Inline(" USE %s_Util", rootFileName); + F90_Inline("\nEND MODULE %s_Model\n", rootFileName); + + /* mz_rs_20050518+ */ + /* UseFile( driverFile ); */ + /* WriteDelim(); */ + /* mz_rs_20050518- */ + + break; + +case 't': + + /* mz_rs_20050117+ */ + UseFile( initFile ); + F90_Inline("\nEND MODULE %s_Initialize\n", rootFileName ); + /* mz_rs_20050117- */ + + UseFile( param_headerFile ); + F90_Inline("\nEND MODULE %s_Parameters\n", rootFileName ); + + UseFile( global_dataFile ); + F90_Inline("\nEND MODULE %s_Global\n", rootFileName ); + + UseFile( functionFile ); + F90_Inline("\nEND MODULE %s_Function\n", rootFileName ); + + UseFile( rateFile ); + F90_Inline("\nEND MODULE %s_Rates\n", rootFileName ); + + if ( useWRFConform ){ + UseFile( wrf_UpdateRconstFile ); + F90_Inline("\nEND MODULE %s_UpdateRconstWRF\n", rootFileName ); + } + + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("\nEND MODULE %s_Stochastic\n", rootFileName); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("\nEND MODULE %s_JacobianSP\n", rootFileName); + } + + UseFile( jacobianFile ); + F90_Inline("\nEND MODULE %s_Jacobian\n", rootFileName ); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("\nEND MODULE %s_StoichiomSP\n", rootFileName); + + UseFile( stoichiomFile ); + F90_Inline("\nEND MODULE %s_Stoichiom\n", rootFileName); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("\nEND MODULE %s_HessianSP\n", rootFileName); + + UseFile( hessianFile ); + F90_Inline("\nEND MODULE %s_Hessian\n", rootFileName ); + } + + UseFile(monitorFile); + F90_Inline("\nEND MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("\nEND MODULE %s_LinearAlgebra\n", rootFileName); + + UseFile( utilFile ); + F90_Inline("\nEND MODULE %s_Util\n", rootFileName); + + break; + +default: + printf("\n Unrecognized option '%s' in GenerateF90Modules\n", where); + break; +} +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Generate() +{ +int i, j; +int n; + + VarStartNr = 0; + FixStartNr = VarNr; + + real = useDouble ? DOUBLE : REAL; + + n = MAX_OUTBUF; + for( i = 1; i < INLINE_OPT; i++ ) + if( InlineCode[i].maxlen > n ) + n = InlineCode[i].maxlen; + + outBuf = (char*)malloc( n ); + outBuffer = outBuf; + + switch( useLang ) { + case F77_LANG: Use_F( rootFileName ); + break; + case F90_LANG: Use_F90( rootFileName ); + break; + case C_LANG: Use_C( rootFileName ); + break; + case MATLAB_LANG: Use_MATLAB( rootFileName ); + break; + default: printf("\n Language no '%s' unknown\n",useLang ); + } + printf("\nKPP is initializing the code generation."); + InitGen(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('h'); + + GenerateMap(); + + + + + if ( useWRFConform) + { + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateIntegrator(); + } + + +/* if( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) +{*/ + printf("\nKPP is generating the monitor data:"); + printf("\n - %s_Monitor",rootFileName); + GenerateMonitorData(); +/* }*/ + + printf("\nKPP is generating the utility data:"); + printf("\n - %s_Util",rootFileName); + GenerateUtil(); + + printf("\nKPP is generating the global declarations:"); + printf("\n - %s_Main",rootFileName); + GenerateGData(); + + + printf("\nKPP is generating the ODE function:"); + printf("\n - %s_Function",rootFileName); + GenerateFun(); + + if ( useStochastic ) { + printf("\nKPP is generating the Stochastic description:"); + printf("\n - %s_Function",rootFileName); + GenerateStochastic(); + } + + if ( useJacobian ) { + printf("\nKPP is generating the ODE Jacobian:"); + printf("\n - %s_Jacobian\n - %s_JacobianSP",rootFileName,rootFileName); + GenerateJac(); + GenerateJacobianSparseData(); + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) { + GenerateJacVect(); + GenerateJacTRVect(); + if( useJacSparse ) { + printf("\nKPP is generating the linear algebra routines:"); + printf("\n - %s_LinearAlgebra",rootFileName); + GenerateSparseUtil(); + GenerateSolve(); + GenerateTRSolve(); + } + } + } + + GenerateBlas(); + + if( useHessian ) { + printf("\nKPP is generating the Hessian:"); + printf("\n - %s_Hessian\n - %s_HessianSP",rootFileName,rootFileName); + GenerateHessian(); + GenerateHessianSparseData(); + } + + printf("\nKPP is generating the utility functions:"); + printf("\n - %s_Util",rootFileName); + + GenerateInitialize(); + + GenerateShuffle_user2kpp(); + GenerateShuffle_kpp2user(); + + printf("\nKPP is generating the rate laws:"); + printf("\n - %s_Rates",rootFileName); + + GenerateRateLaws(); + GenerateUpdateSun(); + GenerateUpdateRconst(); + GenerateUpdatePhoto(); + GenerateGetMass(); + + + if ( useWRFConform ) { + printf("\nKPP is generating UpdateRconstWRF (WRF conform): "); + printf("\n - %s_UpdateRconst",rootFileName); + GenerateUpdateRconstWRF(); + GenerateRateLawsWRF(); + } + + + printf("\nKPP is generating the parameters:"); + printf("\n - %s_Parameters",rootFileName); + + GenerateParamHeader(); + + printf("\nKPP is generating the global data:"); + printf("\n - %s_Global",rootFileName); + + GenerateGlobalHeader(); + + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) { + printf("\nKPP is generating the sparsity data:"); + if( useJacSparse ) { + GenerateJacobianSparseHeader(); + printf("\n - %s_JacobianSP",rootFileName); + } + if( useHessian ) { + GenerateHessianSparseHeader(); + printf("\n - %s_HessianSP",rootFileName); + } + } + + if ( useStoicmat ) { + printf("\nKPP is generating the stoichiometric description files:"); + printf("\n - %s_Stoichiom\n - %s_StoichiomSP",rootFileName,rootFileName); + GenerateReactantProd(); + GenerateJacReactantProd(); + GenerateStoicmSparseData(); + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) + GenerateStoicmSparseHeader(); + GenerateDFunDRcoeff(); + GenerateDJacDRcoeff(); + } + + printf("\nKPP is generating the driver from %s.f90:", driver); + printf("\n - %s_Main",rootFileName); + + + if ( !useWRFConform) + { + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateIntegrator(); + } + + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + GenerateDriver(); + /* mz_rs_20050518- */ + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMakefile(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('t'); + + if ( useLang == MATLAB_LANG ) + GenerateMatlabTemplates(); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMex(); + + + if ( useWRFConform) + GenerateEndModule(); + + + /* mz_rs_20050117+ */ + if( initFile ) fclose( initFile ); + /* mz_rs_20050117- */ + if( driverFile ) fclose( driverFile ); + if( functionFile ) fclose( functionFile ); + if( global_dataFile ) fclose( global_dataFile ); + if( hessianFile ) fclose( hessianFile ); + if( integratorFile ) fclose( integratorFile ); + if( jacobianFile ) fclose( jacobianFile ); + if( linalgFile ) fclose( linalgFile ); + if( mapFile ) fclose( mapFile ); + if( makeFile ) fclose( makeFile ); + if( monitorFile ) fclose( monitorFile ); + if( mex_funFile ) fclose( mex_funFile ); + if( mex_jacFile ) fclose( mex_jacFile ); + if( mex_hessFile ) fclose( mex_hessFile ); + if( param_headerFile ) fclose( param_headerFile ); + if( rateFile ) fclose( rateFile ); + if( wrf_UpdateRconstFile ) fclose( wrf_UpdateRconstFile ); + if( sparse_dataFile ) fclose( sparse_dataFile ); + if( sparse_jacFile ) fclose( sparse_jacFile ); + if( sparse_hessFile ) fclose( sparse_hessFile ); + if( sparse_stoicmFile ) fclose( sparse_stoicmFile ); + if( stoichiomFile ) fclose( stoichiomFile ); + if( utilFile ) fclose( utilFile ); + if( stochasticFile ) fclose( stochasticFile ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int* AllocIntegerVector(int n, char* message) +{ +int* vec; +if ( ( vec=(int*)calloc(n,sizeof(int)) ) == NULL ) + FatalError(-30,"%s: Cannot allocate vector.",message); +return vec; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/* Allocates a matrix of integers */ +int** AllocIntegerMatrix(int m, int n, char* message) +{ +int** mat; +int i; +if ( (mat = (int**)calloc(m,sizeof(int*)))==NULL ) { + FatalError(-30,"%s: Cannot allocate matrix.", message); + } +for (i=0; i value = max(SpcNr,1); + varTable[ NVAR ] -> value = max(VarNr,1); + varTable[ NVARACT ] -> value = max(VarActiveNr,1); + varTable[ NFIX ] -> value = max(FixNr,1); + varTable[ NREACT ] -> value = max(EqnNr,1); + varTable[ NVARST ] -> value = Index(0); + varTable[ NFIXST ] -> value = Index(VarNr); + } +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int NonZero( int stru, int start, int end, + int *row, int *col, int *crow, int *diag ) +{ +int nElm; +int i,j; + + nElm = 0; + for (i = 0; i < end-start; i++) { + crow[i] = Index(nElm); + for (j = 0; j < end-start; j++) { + if( (i == j) || ( (stru) ? LUstructJ[i+start][j+start] + : structJ[i+start][j+start] ) ) { + row[nElm] = Index(i); + col[nElm] = Index(j); + nElm++; + } + if( i == j ) { + diag[i] = Index(nElm-1); + } + } + } + crow[i] = Index(nElm); + diag[i] = Index(nElm); + return nElm; +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *EQN_NAMES[MAX_EQN]; +char *EQN_TAGS[MAX_EQN]; +char *bufeqn, *p; +int dim; + + if ( (useLang != C_LANG)&&(useLang != MATLAB_LANG) ) return; + + UseFile( driverFile ); + + NewLines(1); + + GlobalDeclare( C ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[VAR]->name, varTable[C]->name, 0 ); + C_Inline("%s * %s = & %s[%d];", C_types[real], + varTable[FIX]->name, varTable[C]->name, VarNr ); + + + GlobalDeclare( RCONST ); + GlobalDeclare( TIME ); + GlobalDeclare( SUN ); + GlobalDeclare( TEMP ); + GlobalDeclare( RTOLS ); + GlobalDeclare( TSTART ); + GlobalDeclare( TEND ); + GlobalDeclare( DT ); + GlobalDeclare( ATOL ); + GlobalDeclare( RTOL ); + GlobalDeclare( STEPMIN ); + GlobalDeclare( STEPMAX ); + GlobalDeclare( CFACTOR ); + if (useStochastic) + GlobalDeclare( VOLUME ); + + MATLAB_Inline(" %s_Parameters;",rootFileName); + MATLAB_Inline(" %s_Global_defs;",rootFileName); + MATLAB_Inline(" %s_Sparse;",rootFileName); + MATLAB_Inline(" %s_Monitor;",rootFileName); + if (useJacSparse ) + MATLAB_Inline(" %s_JacobianSP;",rootFileName); + if (useHessian ) + MATLAB_Inline(" %s_HessianSP;",rootFileName); + if (useStoicmat ) + MATLAB_Inline(" %s_StoichiomSP;",rootFileName); + + NewLines(1); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMonitorData() +{ +int i,j,k; +int *crow; +int *diag; +int nElm; +int *lookat; +int *moni; +char *snames[MAX_SPECIES]; +int *trans; +char *strans[MAX_SPECIES]; +char *smass[MAX_ATOMS]; +char *seqn[MAX_EQN]; +char *bufeqn, *p; +int dim; + + + /* Allocate local data structures */ + dim = SpcNr+2; + crow = AllocIntegerVector( dim, "crow in GenerateMonitorData"); + diag = AllocIntegerVector( dim, "diag in GenerateMonitorData"); + lookat = AllocIntegerVector( dim, "lookat in GenerateMonitorData"); + moni = AllocIntegerVector( dim, "moni in GenerateMonitorData"); + trans = AllocIntegerVector( dim, "trans in GenerateMonitorData"); + + UseFile( monitorFile ); + + F77_Inline("%6sBLOCK DATA MONITOR_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Parameters.h'", " ",rootFileName); + F77_Inline("%6sINCLUDE '%s_Global.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i", " " ); + + /* InitDeclare( CFACTOR, 0, (void*)&cfactor ); */ + + NewLines(1); + + for (i = 0; i < SpcNr; i++) { + snames[i] = SpeciesTable[Code[i]].name; + } + InitDeclare( SPC_NAMES, SpcNr, (void*)snames ); + + nlookat = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].lookat ) { + lookat[nlookat] = Index(i); + nlookat++; + } + + if (ValueDimension) + varTable[ NLOOKAT ] -> value = max(nlookat,1); + InitDeclare( LOOKAT, nlookat, (void*)lookat ); + + nmoni = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].moni ) { + moni[nmoni] = Index(i); + nmoni++; + } + + if( nmoni > MAX_MONITOR ) { + Warning( "%d species to monitorize. Too many, keeping %d.", + nmoni, MAX_MONITOR ); + nmoni = MAX_MONITOR; + } + + if (ValueDimension) + varTable[ NMONITOR ] -> value = max(nmoni,1); + InitDeclare( MONITOR, nmoni, (void*)moni ); + + ntrans = 0; + for (i = 0; i < SpcNr; i++) + if ( SpeciesTable[Code[i]].trans ) { + trans[ntrans] = Index(i); + strans[ntrans] = SpeciesTable[Code[i]].name; + ntrans++; + } + + nmass = 0; + for (i = 0; i < AtomNr; i++) + if ( AtomTable[i].masscheck ) { + smass[nmass] = AtomTable[i].name; + nmass++; + } + if (ValueDimension) + varTable[ NMASS ] -> value = max(nmass,1); + InitDeclare( SMASS, nmass, (void*)smass ); + + if ( (bufeqn = (char*)malloc(MAX_EQNLEN*EqnNr+2))==NULL ) { + FatalError(-30,"GenerateMonitorData: Cannot allocate bufeqn (%d chars)", + MAX_EQNLEN*EqnNr); + } + + p = bufeqn; + for (i = 0; i < EqnNr; i++) { + EqnString(i, p); + seqn[i] = p; + p += MAX_EQNLEN; + } + InitDeclare( EQN_NAMES, EqnNr, (void*)seqn ); + + free( bufeqn ); + + if (useEqntags==1) { + for (i = 0; i < EqnNr; i++) { + seqn[i] = kr[i].label; + } + InitDeclare( EQN_TAGS, EqnNr, (void*)seqn ); + } + + NewLines(1); + WriteComment("INLINED global variables"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_DATA ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_DATA ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_DATA ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_DATA ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED global variables"); + NewLines(1); + + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local data structures */ + free(crow); free(diag); free(lookat); free(moni); free(trans); + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseData() +{ +int* irow; +int* icol; +int* crow; +int* diag; +int nElm; +int dim; + + if( !useJacSparse ) return; + + /* Allocate local arrays */ + dim=MAX_SPECIES; + irow = AllocIntegerVector( dim*dim, "irow in GenerateJacobianSparseData" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateJacobianSparseData" ); + crow = AllocIntegerVector( dim, "crow in GenerateJacobianSparseData" ); + diag = AllocIntegerVector( dim, "diag in GenerateJacobianSparseData" ); + + UseFile( sparse_jacFile ); + + NewLines(1); + WriteComment("Sparse Jacobian Data"); + NewLines(1); + + F77_Inline("%6sBLOCK DATA JACOBIAN_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ",rootFileName); + F77_Inline("%6sINTEGER i"," "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + + + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + if (ValueDimension) { + varTable[NONZERO] -> value = Jac_NZ; + varTable[LU_NONZERO] -> value = LU_Jac_NZ; + } + + switch (useJacobian) { + case JAC_ROW: + Jac_NZ = NonZero( PLAIN, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( IROW, Jac_NZ, (void*)irow ); + InitDeclare( ICOL, Jac_NZ, (void*)icol ); + InitDeclare( CROW, VarNr+1, (void*)crow ); + InitDeclare( DIAG, VarNr+1, (void*)diag ); + break; + case JAC_LU_ROW: + LU_Jac_NZ = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + InitDeclare( LU_IROW, LU_Jac_NZ, (void*)irow ); + InitDeclare( LU_ICOL, LU_Jac_NZ, (void*)icol ); + InitDeclare( LU_CROW, VarNr+1, (void*)crow ); + InitDeclare( LU_DIAG, VarNr+1, (void*)diag ); + } + NewLines(1); + F77_Inline( "%6sEND\n\n", " " ); + + /* Free local arrays */ + free(irow); free(icol); free(crow); free(diag); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacobianSparseHeader() +{ + UseFile( sparse_dataFile ); + + CommonName = "SDATA"; + + NewLines(1); + WriteComment(" ----------> Sparse Jacobian Data"); + NewLines(1); + + switch (useJacobian) { + case JAC_ROW: + ExternDeclare( IROW ); + ExternDeclare( ICOL ); + ExternDeclare( CROW ); + ExternDeclare( DIAG ); + break; + case JAC_LU_ROW: + ExternDeclare( LU_IROW ); + ExternDeclare( LU_ICOL ); + ExternDeclare( LU_CROW ); + ExternDeclare( LU_DIAG ); + } + + NewLines(1); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateFun() +{ +int i, j, k; +int used; +int l, m; +int F_VAR, FSPLIT_VAR; + + if( VarNr == 0 ) return; + + if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ + UseFile( functionFile ); + + F_VAR = DefFnc( "Fun", 4, "time derivatives of variables - Agregate form"); + FSPLIT_VAR = DefFnc( "Fun_SPLIT", 5, "time derivatives of variables - Split form"); + + if( useAggregate ) + FunctionBegin( F_VAR, V, F, RCT, Vdot ); + else + FunctionBegin( FSPLIT_VAR, V, F, RCT, P_VAR, D_VAR ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + + if ( useLang!=F90_LANG ) { /* A is a module variable in F90 */ + NewLines(1); + WriteComment("Local variables"); + Declare( A ); + } + NewLines(1); + WriteComment("Computation of equation rates"); + + for(j=0; j 1. PROPENSITY FUNCTION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "Propensity", 4, "Propensity function"); + FunctionBegin( F_VAR, NMLCV, NMLCF, SCT, PROPENSITY ); + + if ( (useLang==MATLAB_LANG)&&(!useAggregate) ) + printf("\nWarning: in the function definition move P_VAR to output vars\n"); + + NewLines(1); + + for(j=0; j 2. RATE CONVERSION ~~~~~~~~~~~~ */ + F_VAR = DefFnc( "StochasticRates", 3, "Convert deterministic rates to stochastic"); + FunctionBegin( F_VAR, RCT, VOLUME, SCT ); + WriteComment("No. of molecules = Concentration x Volume"); + WriteComment("For a reaction with k reactants:"); + WriteComment(" RCT [ (molec/Volume)^(1-k) * sec^(-1) ]"); + WriteComment(" SCT [ (molec)^(1-k) * sec^(-1) ] = RCT*Volume^(k-1)"); + WriteComment("For p molecules of the same type: SCT = SCT/(p!)"); + + NewLines(1); + + for(j=0; j 3. THE CHANGE IN NUMBER OF MOLECULES */ + if (useLang == MATLAB_LANG) { + F_VAR = DefFnc( "MoleculeChange", 3, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV, NMLCV ); + } else { + F_VAR = DefFnc( "MoleculeChange", 2, "Change in the number of molecules"); + FunctionBegin( F_VAR, IRCT, NMLCV ); + } + + NewLines(1); + + F90_Inline("\n SELECT CASE (IRCT)\n"); + C_Inline ("\n switch (IRCT) { \n"); + MATLAB_Inline("\n switch (IRCT) \n"); + for(j=0; j value = JVRP_NZ + 1; + + FunctionEnd( F_STOIC ); + FreeVariable( F_STOIC ); + + + UseFile( sparse_stoicmFile ); + NewLines(1); + WriteComment("Row-compressed sparse data for the Jacobian of reaction products JVRP"); + F77_Inline("%6sBLOCK DATA JVRP_SPARSE_DATA\n", " " ); + F77_Inline("%6sINCLUDE '%s_Sparse.h'", " ", rootFileName); + F77_Inline("%6sINTEGER i", " "); + /* F90_Inline(" USE %s_Sparse", rootFileName); */ + if( (useLang==F77_LANG)||(useLang==F90_LANG) ) { + for (k=0; k value = nonzeros_B; + Declare( BV ); + } + + NewLines(1); + + for ( i=0; i=2) + nElm++; + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) + nElm++; + } + +/* Allocate temporary index arrays */ + coeff_j = AllocIntegerVector(nElm, "coeff_j in GenerateHess"); + coeff_i1 = AllocIntegerVector(nElm, "coeff_i1 in GenerateHess"); + coeff_i2 = AllocIntegerVector(nElm, "coeff_i2 in GenerateHess"); + +/* Fill in temporary index arrays */ + nElm = 0; + for(j=0; j=2) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + coeff_j[nElm] = j; coeff_i1[nElm] = i1; coeff_i2[nElm] = i2; + nElm++; + } + } +/* Number of nonzero terms of the form d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + Djv_isElm = 1; + } + if (Djv_isElm == 1) Hess_NZ++ ; + } /* for i, i1, i2 */ + if (ValueDimension) + varTable[ NHESS ] -> value = max( Hess_NZ, 1 ); + +/* Allocate temporary index arrays */ + iHess_i = AllocIntegerVector(Hess_NZ, "iHess_i in GenerateHess"); + iHess_j = AllocIntegerVector(Hess_NZ, "iHess_j in GenerateHess"); + iHess_k = AllocIntegerVector(Hess_NZ, "iHess_k in GenerateHess"); + + F_Hess = DefFnc( "Hessian", 4, "function for Hessian (Jac derivative w.r.t. variables)"); + FunctionBegin( F_Hess, V, F, RCT, HESS ); + + WriteComment("--------------------------------------------------------"); + WriteComment("Note: HESS is represented in coordinate sparse format: "); + WriteComment(" HESS(m) = d^2 f_i / dv_j dv_k = d Jac_{i,j} / dv_k"); + WriteComment(" where i = IHESS_I(m), j = IHESS_J(m), k = IHESS_K(m)."); + WriteComment("--------------------------------------------------------"); + WriteComment("Note: d^2 f_i / dv_j dv_k = d^2 f_i / dv_k dv_j, "); + WriteComment(" therefore only the terms d^2 f_i / dv_j dv_k"); + WriteComment(" with j <= k are computed and stored in HESS."); + WriteComment("--------------------------------------------------------"); + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) { + NewLines(1); + WriteComment("Local variables"); + /* DeclareConstant( NTMPD2A, ascii( max( nElm, 1 ) ) ); */ + varTable[ NTMPD2A ] -> value = max( nElm, 1 ); + Declare( D2A ); + } + + NewLines(1); + WriteComment("Computation of the second derivatives of equation rates"); + +/* Generate d^2 A(j)/ ( d v(i1) d v(i2) )*/ + nElm = 0; + for(j=0; j=2) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j]-1 ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-2; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d)/{dV(%d)dV(%d)}",Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if (Stoich_Left[i1][j]>=2) */ + + } else { /* i1 != i2 */ + if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) { + prod = RConst( j ); + for (i = 0; i < i1; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i1][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i1][j]-1; k++ ) + prod = Mul( prod, Elm( V, i1 ) ); + for (i = i1+1; i < i2; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + prod = Mul( prod, Const( Stoich_Left[i2][j] ) ); + for (k = 1; k <= (int)Stoich_Left[i2][j]-1; k++ ) + prod = Mul( prod, Elm( V, i2 ) ); + for (i = i2+1; i < VarNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( V, i ) ); + for ( ; i < SpcNr; i++) + for (k = 1; k <= (int)Stoich_Left[i][j]; k++ ) + prod = Mul( prod, Elm( F, i - VarNr ) ); + /* Comment the D2A */ + WriteComment("D2A(%d) = d^2 A(%d) / dV(%d)dV(%d)", + Index(nElm),Index(j),Index(i1),Index(i2)); + Assign( Elm( D2A, nElm ), prod ); + nElm++; + } /* if ( (Stoich_Left[i1][j]>=1)&&(Stoich_Left[i2][j]>=1) ) */ + } /* if i1==i2 */ + + } /* for j, i1, i2 */ + + NewLines(1); + WriteComment("Computation of the Jacobian derivative"); + +/* Generate d^2 f(i)/ ( d v(i1) d v(i2) ) */ + Hess_NZ = 0; + for (i = 0; i < VarNr; i++) + for (i1 = 0; i1 < VarNr; i1++) + for (i2 = i1; i2 < VarNr; i2++) { + sum = Const(0); + Djv_isElm = 0; + for (j = 0; j < EqnNr; j++) + if ( Stoich[i][j] != 0 ) + for (k = 0; k < nElm; k++) + if ( (coeff_j[k]==j) && (coeff_i1[k]==i1) + && (coeff_i2[k]==i2) ) { + sum = Add( sum, + Mul( Const( Stoich[i][j] ), Elm( D2A, k ) ) ); + Djv_isElm = 1; + } + if (Djv_isElm == 1) { + WriteComment("HESS(%d) = d^2 Vdot(%d)/{dV(%d)dV(%d)} = d^2 Vdot(%d)/{dV(%d)dV(%d)}", + Index(Hess_NZ),Index(i),Index(i1),Index(i2),Index(i),Index(i2),Index(i1)); + Assign( Elm( HESS, Hess_NZ ), sum ); + iHess_i[ Hess_NZ ] = i; + iHess_j[ Hess_NZ ] = i1; + iHess_k[ Hess_NZ ] = i2; + Hess_NZ++; + } + + } /* for i, i1, i2 */ + + +/* free temporary index arrays */ + free(coeff_j); free(coeff_i1); free(coeff_i2); + + MATLAB_Inline("\n HESS = HESS(:);"); + + FunctionEnd( F_Hess ); + + FreeVariable( F_Hess ); + + + F_HessTR_VEC = DefFnc( "HessTR_Vec", 4, "Hessian transposed times user vectors"); + FunctionBegin( F_HessTR_VEC, HESS, U1, U2, HTU ); + WriteComment("Compute the vector HTU =(Hess x U2)^T * U1 = d (Jac^T*U1)/d Var * U2 "); + + for (i=0; i Sparse Hessian Data"); + NewLines(1); + + ExternDeclare( IHESS_I ); + ExternDeclare( IHESS_J ); + ExternDeclare( IHESS_K ); + + NewLines(1); +} + + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateStoicmSparseData() +{ +int i,j,k, nnz_stoicm; +/* +int irow_stoicm[MAX_SPECIES*MAX_EQN]; +int ccol_stoicm[MAX_EQN+2]; +int icol_stoicm[MAX_SPECIES*MAX_EQN]; +double stoicm[MAX_SPECIES*MAX_EQN]; +*/ + +int *irow_stoicm; +int *ccol_stoicm; +int *icol_stoicm; +double *stoicm; + +/* Compute the sparsity structure and allocate data structure vectors */ + nnz_stoicm = 0; + for (j=0; j Sparse Stoichiometric Matrix"); + NewLines(1); + CommonName = "STOICM_VALUES"; + ExternDeclare( STOICM ); + CommonName = "STOICM_DATA"; + ExternDeclare( IROW_STOICM ); + ExternDeclare( CCOL_STOICM ); + ExternDeclare( ICOL_STOICM ); + NewLines(1); + + NewLines(1); + WriteComment(" ----------> Sparse Data for Jacobian of Reactant Products"); + NewLines(1); + CommonName = "JVRP"; + ExternDeclare( ICOL_JVRP ); + ExternDeclare( IROW_JVRP ); + ExternDeclare( CROW_JVRP ); + NewLines(1); + +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacVect() +{ +int i, j, nElm; +int Jac_VEC; +int Jac_SP_VEC; + + if( useLang == MATLAB_LANG ) return; + + if( VarNr == 0 ) return; + + UseFile( jacobianFile ); + Jac_VEC = DefFnc( "Jac_Vec", 3, + "function for sparse multiplication: square Jacobian times vector"); + Jac_SP_VEC = DefFnc( "Jac_SP_Vec", 3, + "function for sparse multiplication: sparse Jacobian times vector"); + + if ( useJacSparse ) { + FunctionBegin( Jac_SP_VEC, JVS, UV, JUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JVS, nElm ), Elm( UV, j ) ) ); + nElm++; + } + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_SP_VEC ); + } + + else { + FunctionBegin( Jac_VEC, JV, UV, JUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[i][j] != 0 ) + sum = Add( sum, Mul( Elm( JV, i, j ), Elm( UV, j ) ) ); + Assign( Elm( JUV, i ), sum ); + } + FunctionEnd( Jac_VEC ); + } + + FreeVariable( Jac_VEC ); + FreeVariable( Jac_SP_VEC ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateJacTRVect() +{ +int i, j, nElm; +int JacTR_VEC; +int JacTR_SP_VEC; +int **TmpStruct; + + if( useLang == MATLAB_LANG ) return; + + if ( VarNr == 0 ) return; + + UseFile( jacobianFile ); + + JacTR_VEC = DefFnc( "JacTR_Vec", 3, + "sparse multiplication: square Jacobian transposed times vector"); + JacTR_SP_VEC = DefFnc( "JacTR_SP_Vec", 3, + "sparse multiplication: sparse Jacobian transposed times vector"); + + if ( useJacSparse ) { + + /* The temporary array of structure */ + TmpStruct = AllocIntegerMatrix( VarNr, VarNr, "TmpStruct in GenerateJacTRVect" ); + + nElm = 0; + for( i = 0; i < VarNr; i++) + for( j = 0; j < VarNr; j++ ) + if( LUstructJ[i][j] ) { + TmpStruct[i][j] = nElm; + nElm++; + } + + FunctionBegin( JacTR_SP_VEC, JVS, UV, JTUV ); + nElm = 0; + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JVS, TmpStruct[j][i] ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_SP_VEC ); + + /* Free the temporary array of structure */ + FreeIntegerMatrix( TmpStruct, VarNr, VarNr ); + + } /* useJacSparse*/ + + else { + FunctionBegin( JacTR_VEC, JV, UV, JTUV ); + for( i = 0; i < VarNr; i++) { + sum = Const(0); + for( j = 0; j < VarNr; j++ ) + if( structJ[j][i] != 0 ) + sum = Add( sum, Mul( Elm( JV, j, i ), Elm( UV, j ) ) ); + Assign( Elm( JTUV, i ), sum ); + } + FunctionEnd( JacTR_VEC ); + } + + FreeVariable( JacTR_VEC ); + FreeVariable( JacTR_SP_VEC ); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSparseUtil() +{ +int SUTIL; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + SUTIL = DefFnc( "SPARSE_UTIL", 0, "SPARSE utility functions"); + CommentFunctionBegin( SUTIL ); + + IncludeCode( "%s/util/sutil", Home ); + + CommentFunctionEnd( SUTIL ); + FreeVariable( SUTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateBlas() +{ +int BLAS; + + if ( useLang == MATLAB_LANG ) return; + + UseFile( linalgFile ); + + BLAS = DefFnc( "BLAS_UTIL", 0, "BLAS-LIKE utility functions"); + CommentFunctionBegin( BLAS ); + + IncludeCode( "%s/util/blas", Home ); + + CommentFunctionEnd( BLAS ); + FreeVariable( BLAS ); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDFunDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dFun_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDJacDRcoeff() +{ + + UseFile( stoichiomFile ); + + NewLines(1); + WriteComment("Begin Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + + IncludeCode( "%s/util/dJac_dRcoeff", Home ); + + NewLines(1); + WriteComment("End Jacobian Derivative w.r.t. Rate Coefficients"); + NewLines(1); + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateSolve() +{ +int i, j; +int SOLVE; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateSolve" ); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVE = DefFnc( "KppSolve", 2, "sparse back substitution"); + FunctionBegin( SOLVE, JVS, X ); + + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + sum = Elm( X, i ); + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + Assign( Elm( X, i ), sum ); + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + sum = Elm( X, i ); + for( j = ibgn; j < iend; j++ ) + sum = Sub( sum, Mul( Elm( JVS, j ), Elm( X, icol[j] ) ) ); + sum = Div( sum, Elm( JVS, diag[i] ) ); + Assign( Elm( X, i ), sum ); + } + + FunctionEnd( SOLVE ); + FreeVariable( SOLVE ); + + /* Free Local Arrays */ + free(irow); + free(icol); + free(crow); + free(diag); +} + + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateTRSolve() +{ +int i, j; +int SOLVETR; +int *irow; +int *icol; +int *crow; +int *diag; +int nElm; +int ibgn, iend; +int useLangOld; +int **pos; +int dim; + + if( useLang == MATLAB_LANG ) return; + + /* Allocate local arrays for dimension dim */ + dim = VarNr+2; + irow = AllocIntegerVector( dim*dim, "irow in GenerateTRSolve" ); + icol = AllocIntegerVector( dim*dim, "icol in GenerateTRSolve" ); + crow = AllocIntegerVector( dim, "crow in GenerateTRSolve" ); + diag = AllocIntegerVector( dim, "diag in GenerateTRSolve" ); + pos = AllocIntegerMatrix( dim+1, dim+1, "pos in GenerateTRSolve"); + + useLangOld = useLang; + useLang = C_LANG; + nElm = NonZero( LU, 0, VarNr, irow, icol, crow, diag ); + useLang = useLangOld; + + UseFile( linalgFile ); + + SOLVETR = DefFnc( "KppSolveTR", 3, "sparse, transposed back substitution"); + FunctionBegin( SOLVETR, JVS, X, XX ); + for( i = 0; i < VarNr; i++) { + for( j = 0; j < VarNr; j++) + pos[i][j]=-1; + } + for( i = 0; i < VarNr; i++) { + ibgn = crow[i]; + iend = diag[i]; + if( ibgn <= iend ) { + if ( ibgn < iend ) { + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + } + } + } + + for( i = VarNr-1; i >=0; i--) { + ibgn = diag[i] + 1; + iend = crow[i+1]; + for( j = ibgn; j < iend; j++ ) + pos[icol[j]][i]=j; + pos[i][i]=diag[i]; + } + + for( i = 0; i= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + sum=Div( sum, Elm(JVS, diag[i] ) ); + Assign( Elm( XX, i ), sum ); + } + for( i = VarNr-1; i >=0; i--) { + sum = Elm( XX, i ); + for (j=i+1; j= 0) { + sum=Sub( sum, Mul ( Elm(JVS,pos[i][j] ), Elm( XX, j ) ) ); + } + } + Assign( Elm( XX, i ), sum ); + } + + FunctionEnd( SOLVETR ); + FreeVariable( SOLVETR ); + /* Free Local Arrays */ + free(irow); free(icol); free(crow); free(diag); + FreeIntegerMatrix(pos, dim+1, dim+1); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateRateLaws() +{ + + UseFile( rateFile ); + + NewLines(1); + WriteComment("Begin Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + IncludeCode( "%s/util/UserRateLaws", Home ); + NewLines(1); + WriteComment("End Rate Law Functions from KPP_HOME/util/UserRateLaws"); + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED Rate Law Functions"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RATES ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RATES ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RATES ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RATES ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Rate Law Functions"); + NewLines(1); + + +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateSun() +{ +int UPDATE_SUN; + + UseFile( rateFile ); + + UPDATE_SUN = DefFnc( "Update_SUN", 0, "update SUN light using TIME"); + CommentFunctionBegin( UPDATE_SUN ); + + IncludeCode( "%s/util/UpdateSun", Home ); + + CommentFunctionEnd( UPDATE_SUN ); + FreeVariable( UPDATE_SUN ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdateRconst() +{ +int i; +int UPDATE_RCONST; + + UseFile( rateFile ); + + UPDATE_RCONST = DefFnc( "Update_RCONST", 0, "function to update rate constants"); + + FunctionBegin( UPDATE_RCONST ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + if ( (useLang==F77_LANG) ) + IncludeCode( "%s/util/UserRateLaws_FcnHeader", Home ); + + NewLines(1); + + NewLines(1); + WriteComment("Begin INLINED RCONST"); + NewLines(1); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_RCONST ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_RCONST ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_RCONST ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_RCONST ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED RCONST"); + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == EXPRESION ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + /* mz_rs_20050117+ */ + if ( kr[i].type == NUMBER ) { + F90_Inline("! RCONST(%d) = constant rate coefficient", i+1); + /* WriteComment("Constant rate coefficient (value inlined in the code):"); */ + /* Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); */ + } + /* mz_rs_20050117- */ + } + + MATLAB_Inline(" RCONST = RCONST(:);"); + + FunctionEnd( UPDATE_RCONST ); + FreeVariable( UPDATE_RCONST ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUpdatePhoto() +{ +int i; +int UPDATE_PHOTO; + + UseFile( rateFile ); + + UPDATE_PHOTO = DefFnc( "Update_PHOTO", 0, "function to update photolytical rate constants"); + + FunctionBegin( UPDATE_PHOTO ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global", rootFileName); + MATLAB_Inline("global SUN TEMP RCONST"); + + NewLines(1); + + for( i = 0; i < EqnNr; i++) { + if( kr[i].type == PHOTO ) + Assign( Elm( RCONST, i ), Elm( KR, kr[i].val.st ) ); + } + + FunctionEnd( UPDATE_PHOTO ); + FreeVariable( UPDATE_PHOTO ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateIntegrator() +{ +int TIN, TOUT, INTEGRATE; + + UseFile( integratorFile ); + + TIN = DefElm( "TIN", real, "Start Time for Integration"); + TOUT = DefElm( "TOUT", real, "End Time for Integration"); + INTEGRATE = DefFnc( "INTEGRATE", 2, "Integrator routine"); + CommentFunctionBegin( INTEGRATE, TIN, TOUT ); + + if( strchr( integrator, '/' ) ) + IncludeCode( integrator ); + else + IncludeCode( "%s/int/%s", Home, integrator ); + + CommentFunctionEnd( INTEGRATE ); + FreeVariable( INTEGRATE ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateDriver() +{ +int MAIN; + + UseFile( driverFile ); + + MAIN = DefFnc( "MAIN", 0, "Main program - driver routine"); + CommentFunctionBegin( MAIN ); + + if( strchr( driver, '/' ) ) + IncludeCode( driver ); + else + IncludeCode( "%s/drv/%s", Home, driver ); + + CommentFunctionEnd( MAIN ); + FreeVariable( MAIN ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateUtil() +{ +int UTIL; + +/* if (useLang == MATLAB_LANG) return; */ + + UseFile( utilFile ); + NewLines(1); + WriteComment("User INLINED Utility Functions"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_UTIL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_UTIL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_UTIL ].code ); + break; + case MATLAB_LANG:bprintf( InlineCode[ MATLAB_UTIL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED Utility Functions"); + NewLines(1); + + WriteComment("Utility Functions from KPP_HOME/util/util"); + UTIL = DefFnc( "UTIL", 0, "Utility functions"); + CommentFunctionBegin( UTIL); + + IncludeCode( "%s/util/util", Home ); + + if ((useLang == F90_LANG) && (useEqntags==1)) { + IncludeCode( "%s/util/tag2num", Home ); + } + + WriteComment("End Utility Functions from KPP_HOME/util/util"); + CommentFunctionEnd( UTIL ); + FreeVariable( UTIL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateParamHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + +int j,dummy_species; + +/* ----------> First declaration of constants */ + UseFile( param_headerFile ); + + NewLines(1); + DeclareConstant( NSPEC, ascii( max(SpcNr, 1) ) ); + DeclareConstant( NVAR, ascii( max(VarNr, 1) ) ); + DeclareConstant( NVARACT, ascii( max(VarActiveNr, 1) ) ); + DeclareConstant( NFIX, ascii( max(FixNr, 1) ) ); + DeclareConstant( NREACT, ascii( max(EqnNr, 1) ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + DeclareConstant( NONZERO, ascii( max(Jac_NZ, 1) ) ); + DeclareConstant( LU_NONZERO, ascii( max(LU_Jac_NZ, 1) ) ); + DeclareConstant( CNVAR, ascii( VarNr+1 ) ); + if ( useStoicmat ) { + DeclareConstant( CNEQN, ascii( EqnNr+1 ) ); + } + if ( useHessian ) { + DeclareConstant( NHESS, ascii( max(Hess_NZ, 1) ) ); + } + + DeclareConstant( NLOOKAT, ascii( nlookat ) ); + DeclareConstant( NMONITOR, ascii( nmoni ) ); + DeclareConstant( NMASS, ascii( nmass ) ); + + DeclareConstant( PI, "3.14159265358979" ); + + NewLines(1); + WriteComment("Index declaration for variable species in C and VAR"); + WriteComment(" VAR(ind_spc) = C(ind_spc)"); + NewLines(1); + for( i = 0; i < VarNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } + + NewLines(1); + WriteComment("Index declaration for fixed species in C"); + WriteComment(" C(ind_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "ind_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i+VarNr) ) ); + FreeVariable( spc ); + } + + if (useDummyindex==1) { + NewLines(1); + WriteComment("Index declaration for dummy species"); + NewLines(1); + for( i = 0; i < MAX_SPECIES; i++) { + if (SpeciesTable[i].type == 0) continue; + dummy_species = 1; + for( j = 0; j < MAX_SPECIES; j++) + if (Code[j] == i) dummy_species = 0; + if (dummy_species) { + sprintf( name, "ind_%s", SpeciesTable[i].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( 0 ) ); + FreeVariable( spc ); + } + } + } + + NewLines(1); + WriteComment("Index declaration for fixed species in FIX"); + WriteComment(" FIX(indf_spc) = C(ind_spc) = C(NVAR+indf_spc)"); + NewLines(1); + for( i = 0; i < FixNr; i++) { + sprintf( name, "indf_%s", SpeciesTable[ Code[i + VarNr] ].name ); + spc = DefConst( name, INT, 0 ); + DeclareConstant( spc, ascii( Index(i) ) ); + FreeVariable( spc ); + } +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGlobalHeader() +{ +int spc; +int i; +char name[20]; +int offs; +int mxyz; + + UseFile( global_dataFile ); + + CommonName = "GDATA"; + + NewLines(1); + WriteComment("Declaration of global variables"); + NewLines(1); + + /* ExternDeclare( C_DEFAULT ); */ + + ExternDeclare( C ); + + if( useLang == F77_LANG ) { + + Declare( VAR ); + Declare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F77_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == F90_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + WriteComment("VAR, FIX are chunks of array C"); + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, 1, varTable[VAR]->name ); + if ( FixNr > 0 ) { /* mz_rs_20050121 */ + F90_Inline(" EQUIVALENCE( %s(%d),%s(1) )", + varTable[C]->name, VarNr+1, varTable[FIX]->name ); + } + } + + if( useLang == MATLAB_LANG ) { + ExternDeclare( VAR ); + ExternDeclare( FIX ); + } + + C_Inline(" extern %s * %s;", C_types[real], varTable[VAR]->name ); + C_Inline(" extern %s * %s;", C_types[real], varTable[FIX]->name ); + + + ExternDeclare( RCONST ); + ExternDeclare( TIME ); + ExternDeclare( SUN ); + ExternDeclare( TEMP ); + ExternDeclare( RTOLS ); + ExternDeclare( TSTART ); + ExternDeclare( TEND ); + ExternDeclare( DT ); + ExternDeclare( ATOL ); + ExternDeclare( RTOL ); + ExternDeclare( STEPMIN ); + ExternDeclare( STEPMAX ); + ExternDeclare( CFACTOR ); + if (useStochastic) + ExternDeclare( VOLUME ); + + CommonName = "INTGDATA"; + if ( useHessian ) { + ExternDeclare( DDMTYPE ); + } + + + if ( (useLang == C_LANG) || (useLang == F77_LANG) ) { + CommonName = "INTGDATA"; + ExternDeclare( LOOKAT ); + ExternDeclare( MONITOR ); + CommonName = "CHARGDATA"; + ExternDeclare( SPC_NAMES ); + ExternDeclare( SMASS ); + ExternDeclare( EQN_NAMES ); + ExternDeclare( EQN_TAGS ); + } + + NewLines(1); + WriteComment("INLINED global variable declarations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_GLOBAL ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_GLOBAL ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_GLOBAL ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_GLOBAL ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("INLINED global variable declarations"); + NewLines(1); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void WriteSpec( int i, int j ) +{ +char buf[100]; + + if( Reactive[j] ) + sprintf( buf, "%s (r)", SpeciesTable[ Code[j] ].name ); + else + sprintf( buf, "%s (n)", SpeciesTable[ Code[j] ].name ); + WriteAll("%3d = %-10s", 1 + i, buf ); + FlushBuf(); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnStr( int eq, char * buf, float** mat ) +{ +int spc, first; + +/* bugfix if stoichiometric factor is not an integer */ +int n; +char s[40]; + + first = 1; + *buf = 0; + for( spc = 0; spc < SpcNr; spc++ ) + if( mat[spc][eq] != 0 ) { + if( ((mat[spc][eq] == 1)||(mat[spc][eq] == -1)) ) { + sprintf(s, ""); + } else { + /* real */ + /* mz_rs_20050130+ */ + /* sprintf(s, "%g", mat[spc][eq]); */ + /* remove the minus sign with fabs(), it will be re-inserted later */ + sprintf(s, "%g", fabs(mat[spc][eq])); + /* mz_rs_20050130- */ + /* remove trailing zeroes */ + for (n= strlen(s) - 1; n >= 0; n--) + if (s[n] != '0') break; + s[n + 1]= '\0'; + sprintf(s, "%s ", s); + } + + if( first ) { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s%s", buf, s); + else sprintf(buf, "%s- %s", buf, s); + first = 0; + } else { + if( mat[spc][eq] > 0 ) sprintf(buf, "%s + %s", buf, s); + else sprintf(buf, "%s - %s", buf, s); + } + sprintf(buf, "%s%s", buf, SpeciesTable[ Code[spc] ].name); + if (strlen(buf)>MAX_EQNLEN/2) { /* truncate if eqn string too long */ + sprintf(buf, "%s ... etc.",buf); + break; + } + } + + return strlen(buf); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int EqnString( int eq, char * buf ) +{ +static int lhs = 0; +static int rhs = 0; + +int i, l; +char lhsbuf[MAX_EQNLEN], rhsbuf[MAX_EQNLEN]; + + if(lhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, lhsbuf, Stoich_Left); + lhs = (lhs > l) ? lhs : l; + } + + if(rhs == 0) for( i = 0; i < EqnNr; i++ ) { + l = EqnStr( i, rhsbuf, Stoich_Right); + rhs = (rhs > l) ? lhs : l; + } + + + EqnStr( eq, lhsbuf, Stoich_Left); + EqnStr( eq, rhsbuf, Stoich_Right); + + sprintf(buf, "%*s --> %-*s", lhs, lhsbuf, rhs, rhsbuf); + return strlen(buf); +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMap() +{ +int i; +int dn; + + UseFile( mapFile ); + + WriteAll("### Options -------------------------------------------\n"); + NewLines(1); + if( useAggregate ) WriteAll("FUNCTION - AGGREGATE\n"); + else WriteAll("FUNCTION - SPLIT\n"); + switch ( useJacobian ) { + case JAC_OFF: WriteAll("JACOBIAN - OFF\n"); break; + case JAC_FULL: WriteAll("JACOBIAN - FULL\n"); break; + case JAC_LU_ROW: WriteAll("JACOBIAN - SPARSE W/ ACCOUNT FOR LU DECOMPOSITION FILL-IN\n"); break; + case JAC_ROW: WriteAll("JACOBIAN - SPARSE\n"); break; + } + if( useDouble ) WriteAll("DOUBLE - ON\n"); + else WriteAll("DOUBLE - OFF\n"); + if( useReorder ) WriteAll("REORDER - ON\n"); + else WriteAll("REORDER - OFF\n"); + NewLines(1); + + WriteAll("### Parameters ----------------------------------------\n"); + NewLines(1); + + VarStartNr = Index(0); + FixStartNr = Index(VarNr); + + DeclareConstant( NSPEC, ascii( SpcNr ) ); + DeclareConstant( NVAR, ascii( max( VarNr, 1 ) ) ); + DeclareConstant( NVARACT, ascii( max( VarActiveNr, 1 ) ) ); + DeclareConstant( NFIX, ascii( max( FixNr, 1 ) ) ); + DeclareConstant( NREACT, ascii( EqnNr ) ); + DeclareConstant( NVARST, ascii( VarStartNr ) ); + DeclareConstant( NFIXST, ascii( FixStartNr ) ); + + NewLines(1); + WriteAll("### Species -------------------------------------------\n"); + + NewLines(1); + WriteAll("Variable species\n"); + + dn = VarNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i += dn; if( i < VarNr ) WriteSpec( i, i ); + i -= 2*dn; WriteAll("\n"); + } + + + NewLines(1); + WriteAll("Fixed species\n"); + + dn = FixNr/3 + 1; + for( i = 0; i < dn; i++ ) { + if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i += dn; if( i < FixNr ) WriteSpec( i, i + VarNr ); + i -= 2*dn; WriteAll("\n"); + } + + NewLines(1); + WriteAll("### Subroutines ---------------------------------------\n"); + NewLines(1); + FlushBuf(); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateInitialize() +{ +int i; +int I, X; +int INITVAL; + + if ( (useLang==C_LANG)||(useLang==F77_LANG)||(useLang==F90_LANG) ) + UseFile( initFile ); + + INITVAL = DefFnc( "Initialize", 0, "function to initialize concentrations"); + FunctionBegin( INITVAL ); + F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); + F90_Inline(" USE %s_Global\n", rootFileName); + MATLAB_Inline("global CFACTOR VAR FIX NVAR NFIX", rootFileName); + + I = DefElm( "i", INT, 0); + X = DefElm( "x", real, 0); + Declare( I ); + Declare( X ); + + NewLines(1); + WriteAssign( varTable[CFACTOR]->name , ascid( (double)cfactor ) ); + NewLines(1); + + Assign( Elm( X ), Mul( Elm( IV, varDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NVAR; i++ )" ); + F77_Inline(" DO i = 1, NVAR" ); + F90_Inline(" DO i = 1, NVAR" ); + MATLAB_Inline(" for i = 1:NVAR" ); + ident++; + Assign( Elm( VAR, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + Assign( Elm( X ), Mul( Elm( IV, fixDefault ), Elm( CFACTOR ) ) ); + C_Inline(" for( i = 0; i < NFIX; i++ )" ); + F77_Inline(" DO i = 1, NFIX" ); + F90_Inline(" DO i = 1, NFIX" ); + MATLAB_Inline(" for i = 1:NFIX" ); + ident++; + Assign( Elm( FIX, -I ), Elm( X ) ); + ident--; + F77_Inline(" END DO" ); + F90_Inline(" END DO" ); + MATLAB_Inline(" end" ); + + + NewLines(1); + + for( i = 0; i < VarNr; i++) { + if( *SpeciesTable[ Code[i] ].ival == 0 ) continue; + Assign( Elm( VAR, i ), Mul( + Elm( IV, SpeciesTable[ Code[i] ].ival ), + Elm( CFACTOR ) ) ); + } + + + for( i = 0; i < FixNr; i++) { + if( *SpeciesTable[ Code[i + VarNr] ].ival == 0 ) continue; + Assign( Elm( FIX, i ), Mul( + Elm( IV, SpeciesTable[ Code[i + VarNr] ].ival ), + Elm( CFACTOR ) ) ); + } + +/* NewLines(1); + C_Inline(" for( i = 0; i < NSPEC; i++ )" ); + F77_Inline(" do i = 1, NSPEC" ); + ident++; + Assign( Elm( C_DEFAULT, -I ), Elm( C, -I ) ); + ident--; + F77_Inline(" end do" ); +*/ + + /* mz_rs_20050117+ */ + WriteComment("constant rate coefficients"); + for( i = 0; i < EqnNr; i++) { + if ( kr[i].type == NUMBER ) + Assign( Elm( RCONST, i ), Const( kr[i].val.f ) ); + } + WriteComment("END constant rate coefficients"); + /* mz_rs_20050117- */ + + NewLines(1); + WriteComment("INLINED initializations"); + + switch( useLang ) { + case C_LANG: bprintf( InlineCode[ C_INIT ].code ); + break; + case F77_LANG: bprintf( InlineCode[ F77_INIT ].code ); + break; + case F90_LANG: bprintf( InlineCode[ F90_INIT ].code ); + break; + case MATLAB_LANG: bprintf( InlineCode[ MATLAB_INIT ].code ); + break; + } + FlushBuf(); + + NewLines(1); + WriteComment("End INLINED initializations"); + NewLines(1); + + MATLAB_Inline(" VAR = VAR(:);\n FIX = FIX(:);\n" ); + + FreeVariable( X ); + FreeVariable( I ); + FunctionEnd( INITVAL ); + FreeVariable( INITVAL ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_user2kpp() +{ +int i,k,l; +int Shuffle_user2kpp; + + UseFile( utilFile ); + + Shuffle_user2kpp = DefFnc( "Shuffle_user2kpp", 2, "function to copy concentrations from USER to KPP"); + FunctionBegin( Shuffle_user2kpp, V_USER, V ); + + k = 0;l = 0; + for( i = 1; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) { + Assign( Elm( V, ReverseCode[i] ), Elm( V_USER, k++ ) ); + break; + } + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_user2kpp ); + FreeVariable( Shuffle_user2kpp ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateShuffle_kpp2user() +{ +int i,k,l; +int Shuffle_kpp2user; + + UseFile( utilFile ); + + Shuffle_kpp2user = DefFnc( "Shuffle_kpp2user", 2, "function to restore concentrations from KPP to USER"); + FunctionBegin( Shuffle_kpp2user, V, V_USER ); + + k = 0; l = 0; + for( i = 0; i < SpcNr; i++) { + if( ReverseCode[i] < 0 ) { + if( SpeciesTable[i].type == VAR_SPC ) k++; + continue; + } + switch( SpeciesTable[i].type ) { + case VAR_SPC: + if( k < initNr ) + Assign( Elm( V_USER, k++ ), Elm( V, ReverseCode[i] ) ); + break; + case FIX_SPC: + case DUMMY_SPC: + default: break; + } + } + + FunctionEnd( Shuffle_kpp2user ); + FreeVariable( Shuffle_kpp2user ); +} + + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateGetMass() +{ +int i; +int atm, spc; +int GETMASS, MASS; +SPECIES_DEF *sp; +int numass; + + UseFile( utilFile ); + + nmass = 0; + for( atm = 0; atm < AtomNr; atm++ ) + if( AtomTable[atm].masscheck ) nmass++; + if( nmass == 0 ) nmass = 1; + + MASS = DefvElm( "Mass", real, nmass, "value of mass balance" ); + GETMASS = DefFnc( "GetMass", 2, "compute total mass of selected atoms"); + FunctionBegin( GETMASS, CL, MASS); + + numass = 0; + for( atm = 0; atm < AtomNr; atm++ ) { + if( AtomTable[atm].masscheck ) { + sum = Const( 0 ); + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + for( i = 0; i < sp->nratoms; i++ ) { + if( sp->atoms[i].code == atm ) { + sum = Add( sum, Mul( Const( sp->atoms[i].nr ), + Elm( CL, spc ) ) ); + } + } + } + Assign( Elm( MASS, numass ), sum ); + numass++; + } + } + + FunctionEnd( GETMASS ); + FreeVariable( GETMASS ); +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMakefile() +{ +char buf[100]; + + if ( useLang == MATLAB_LANG ) return; + + sprintf( buf, "Makefile_%s", rootFileName ); + makeFile = fopen(buf, "w"); + if( makeFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + + UseFile( makeFile ); + + IncludeCode( "%s/util/Makefile", Home ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMex() +{ +char buf[100], suffix[5]; + + if (useLang == MATLAB_LANG) return; + if (useMex == 0) return; + + switch( useLang ) { + case F77_LANG: sprintf( suffix, "f"); + break; + case F90_LANG: sprintf( suffix, "f90"); + break; + case C_LANG: sprintf( suffix, "c"); + break; + default: printf("\nCannot create mex files for language %d\n", useLang); + exit(1); + break; + } + + sprintf( buf, "%s_mex_Fun.%s", rootFileName, suffix ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Mex_Fun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_mex_Jac_SP.%s", rootFileName, suffix ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Mex_Jac_SP", Home ); + } + + if (useHessian) { + sprintf( buf, "%s_mex_Hessian.%s", rootFileName, suffix ); + mex_hessFile = fopen(buf, "w"); + if( mex_hessFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_hessFile ); + IncludeCode( "%s/util/Mex_Hessian", Home ); + } + +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateMatlabTemplates() +{ +char buf[200], suffix[5]; + + if (useLang != MATLAB_LANG) return; + + + sprintf( buf, "%s_Fun_Chem.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/Template_Fun_Chem", Home ); + + sprintf( buf, "%s_Update_SUN.m", rootFileName ); + mex_funFile = fopen(buf, "w"); + if( mex_funFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_funFile ); + IncludeCode( "%s/util/UpdateSun", Home ); + + if (useJacSparse) { + sprintf( buf, "%s_Jac_Chem.m", rootFileName ); + mex_jacFile = fopen(buf, "w"); + if( mex_jacFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( mex_jacFile ); + IncludeCode( "%s/util/Template_Jac_Chem", Home ); + } + + if (useHessian) { + } + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void GenerateF90Modules(char where) +{ +char buf[200]; + +if (useLang != F90_LANG) return; + +switch (where) { +case 'h': + + sprintf( buf, "%s_Precision.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("\nMODULE %s_Precision\n", rootFileName ); + F90_Inline("!"); + F90_Inline("! Definition of different levels of accuracy"); + F90_Inline("! for REAL variables using KIND parameterization"); + F90_Inline("!"); + F90_Inline("! KPP SP - Single precision kind"); + F90_Inline(" INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND(6,30)"); + F90_Inline("! KPP DP - Double precision kind"); + F90_Inline(" INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,300)"); + F90_Inline("! KPP QP - Quadruple precision kind"); + F90_Inline(" INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(18,400)"); + F90_Inline("\nEND MODULE %s_Precision\n\n", rootFileName ); + + UseFile( initFile ); + F90_Inline("MODULE %s_Initialize\n", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + F90_Inline("CONTAINS\n\n"); + + UseFile( param_headerFile ); + F90_Inline("MODULE %s_Parameters\n", rootFileName ); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( global_dataFile ); + F90_Inline("MODULE %s_Global\n", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: dp, NSPEC, NVAR, NFIX, NREACT", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( functionFile ); + F90_Inline("MODULE %s_Function\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE\n", rootFileName ); + Declare( A ); /* mz_rs_20050117 */ + F90_Inline("\nCONTAINS\n\n"); + + UseFile( rateFile ); + F90_Inline("MODULE %s_Rates\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("MODULE %s_Stochastic\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters, ONLY: NVAR, NFIX, NREACT", rootFileName ); + F90_Inline(" PUBLIC\n SAVE\n"); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("MODULE %s_JacobianSP\n", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + } + + UseFile( jacobianFile ); + F90_Inline("MODULE %s_Jacobian\n", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("MODULE %s_StoichiomSP\n", rootFileName); + F90_Inline(" USE %s_Precision", rootFileName); + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( stoichiomFile ); + F90_Inline("MODULE %s_Stoichiom\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_StoichiomSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("MODULE %s_HessianSP\n", rootFileName); + /* F90_Inline(" USE %s_Precision", rootFileName ); */ /* mz_rs_20050321 */ + F90_Inline(" PUBLIC\n SAVE\n"); + + UseFile( hessianFile ); + F90_Inline("MODULE %s_Hessian\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_HessianSP\n", rootFileName); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + } + + UseFile( monitorFile ); + F90_Inline("MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("MODULE %s_LinearAlgebra\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + /* mz_rs_20050511+ if( useJacSparse ) added */ + if ( useJacSparse ) + F90_Inline(" USE %s_JacobianSP\n", rootFileName); + /* mz_rs_20050511- */ + /* mz_rs_20050321+ */ + /* if (useHessian) */ + /* F90_Inline(" USE %s_HessianSP\n", rootFileName); */ + /* mz_rs_20050321- */ + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + UseFile( utilFile ); + F90_Inline("MODULE %s_Util\n", rootFileName); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" IMPLICIT NONE", rootFileName ); + F90_Inline("\nCONTAINS\n\n"); + + /* Here we define the model module which aggregates everything */ + /* put module rootFileName_Model into separate file */ + /* (reusing "sparse_dataFile" as done above for _Precision file) */ + sprintf( buf, "%s_Model.f90", rootFileName ); + sparse_dataFile = fopen(buf, "w"); + if( sparse_dataFile == 0 ) { + FatalError(3,"%s: Can't create file", buf ); + } + UseFile( sparse_dataFile ); + F90_Inline("MODULE %s_Model\n", rootFileName); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("! Completely defines the model %s", rootFileName); + F90_Inline("! by using all the associated modules"); + F90_Inline("!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"); + F90_Inline("\n USE %s_Precision", rootFileName ); + F90_Inline(" USE %s_Parameters", rootFileName ); + F90_Inline(" USE %s_Global", rootFileName ); + F90_Inline(" USE %s_Function", rootFileName ); + F90_Inline(" USE %s_Integrator", rootFileName ); + F90_Inline(" USE %s_Rates", rootFileName ); + if ( useStochastic ) + F90_Inline(" USE %s_Stochastic", rootFileName ); + if ( useJacobian ) + F90_Inline(" USE %s_Jacobian", rootFileName ); + if ( useHessian ) + F90_Inline(" USE %s_Hessian", rootFileName); + if ( useStoicmat ) + F90_Inline(" USE %s_Stoichiom", rootFileName); + F90_Inline(" USE %s_LinearAlgebra", rootFileName); + F90_Inline(" USE %s_Monitor", rootFileName); + F90_Inline(" USE %s_Util", rootFileName); + F90_Inline("\nEND MODULE %s_Model\n", rootFileName); + + /* mz_rs_20050518+ */ + /* UseFile( driverFile ); */ + /* WriteDelim(); */ + /* mz_rs_20050518- */ + + break; + +case 't': + + /* mz_rs_20050117+ */ + UseFile( initFile ); + F90_Inline("\nEND MODULE %s_Initialize\n", rootFileName ); + /* mz_rs_20050117- */ + + UseFile( param_headerFile ); + F90_Inline("\nEND MODULE %s_Parameters\n", rootFileName ); + + UseFile( global_dataFile ); + F90_Inline("\nEND MODULE %s_Global\n", rootFileName ); + + UseFile( functionFile ); + F90_Inline("\nEND MODULE %s_Function\n", rootFileName ); + + UseFile( rateFile ); + F90_Inline("\nEND MODULE %s_Rates\n", rootFileName ); + + if ( useStochastic ) { + UseFile(stochasticFile); + F90_Inline("\nEND MODULE %s_Stochastic\n", rootFileName); + } + + if ( useJacSparse ) { + UseFile(sparse_jacFile); + F90_Inline("\nEND MODULE %s_JacobianSP\n", rootFileName); + } + + UseFile( jacobianFile ); + F90_Inline("\nEND MODULE %s_Jacobian\n", rootFileName ); + + if ( useStoicmat ) { + UseFile(sparse_stoicmFile); + F90_Inline("\nEND MODULE %s_StoichiomSP\n", rootFileName); + + UseFile( stoichiomFile ); + F90_Inline("\nEND MODULE %s_Stoichiom\n", rootFileName); + } + + if ( useHessian ) { + UseFile(sparse_hessFile); + F90_Inline("\nEND MODULE %s_HessianSP\n", rootFileName); + + UseFile( hessianFile ); + F90_Inline("\nEND MODULE %s_Hessian\n", rootFileName ); + } + + UseFile(monitorFile); + F90_Inline("\nEND MODULE %s_Monitor", rootFileName); + + UseFile( linalgFile ); + F90_Inline("\nEND MODULE %s_LinearAlgebra\n", rootFileName); + + UseFile( utilFile ); + F90_Inline("\nEND MODULE %s_Util\n", rootFileName); + + break; + +default: + printf("\n Unrecognized option '%s' in GenerateF90Modules\n", where); + break; +} +} + + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void Generate() +{ +int i, j; +int n; + + VarStartNr = 0; + FixStartNr = VarNr; + + real = useDouble ? DOUBLE : REAL; + + n = MAX_OUTBUF; + for( i = 1; i < INLINE_OPT; i++ ) + if( InlineCode[i].maxlen > n ) + n = InlineCode[i].maxlen; + + outBuf = (char*)malloc( n ); + outBuffer = outBuf; + + switch( useLang ) { + case F77_LANG: Use_F( rootFileName ); + break; + case F90_LANG: Use_F90( rootFileName ); + break; + case C_LANG: Use_C( rootFileName ); + break; + case MATLAB_LANG: Use_MATLAB( rootFileName ); + break; + default: printf("\n Language no '%s' unknown\n",useLang ); + } + printf("\nKPP is initializing the code generation."); + InitGen(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('h'); + + GenerateMap(); + +/* if( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) +{*/ + printf("\nKPP is generating the monitor data:"); + printf("\n - %s_Monitor",rootFileName); + GenerateMonitorData(); +/* }*/ + + printf("\nKPP is generating the utility data:"); + printf("\n - %s_Util",rootFileName); + GenerateUtil(); + + printf("\nKPP is generating the global declarations:"); + printf("\n - %s_Main",rootFileName); + GenerateGData(); + + + printf("\nKPP is generating the ODE function:"); + printf("\n - %s_Function",rootFileName); + GenerateFun(); + + if ( useStochastic ) { + printf("\nKPP is generating the Stochastic description:"); + printf("\n - %s_Function",rootFileName); + GenerateStochastic(); + } + + if ( useJacobian ) { + printf("\nKPP is generating the ODE Jacobian:"); + printf("\n - %s_Jacobian\n - %s_JacobianSP",rootFileName,rootFileName); + GenerateJac(); + GenerateJacobianSparseData(); + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) { + GenerateJacVect(); + GenerateJacTRVect(); + if( useJacSparse ) { + printf("\nKPP is generating the linear algebra routines:"); + printf("\n - %s_LinearAlgebra",rootFileName); + GenerateSparseUtil(); + GenerateSolve(); + GenerateTRSolve(); + } + } + } + + GenerateBlas(); + + if( useHessian ) { + printf("\nKPP is generating the Hessian:"); + printf("\n - %s_Hessian\n - %s_HessianSP",rootFileName,rootFileName); + GenerateHessian(); + GenerateHessianSparseData(); + } + + printf("\nKPP is generating the utility functions:"); + printf("\n - %s_Util",rootFileName); + + GenerateInitialize(); + + GenerateShuffle_user2kpp(); + GenerateShuffle_kpp2user(); + + printf("\nKPP is generating the rate laws:"); + printf("\n - %s_Rates",rootFileName); + + GenerateRateLaws(); + GenerateUpdateSun(); + GenerateUpdateRconst(); + GenerateUpdatePhoto(); + GenerateGetMass(); + + + printf("\nKPP is generating the parameters:"); + printf("\n - %s_Parameters",rootFileName); + + GenerateParamHeader(); + + printf("\nKPP is generating the global data:"); + printf("\n - %s_Global",rootFileName); + + GenerateGlobalHeader(); + + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) { + printf("\nKPP is generating the sparsity data:"); + if( useJacSparse ) { + GenerateJacobianSparseHeader(); + printf("\n - %s_JacobianSP",rootFileName); + } + if( useHessian ) { + GenerateHessianSparseHeader(); + printf("\n - %s_HessianSP",rootFileName); + } + } + + if ( useStoicmat ) { + printf("\nKPP is generating the stoichiometric description files:"); + printf("\n - %s_Stoichiom\n - %s_StoichiomSP",rootFileName,rootFileName); + GenerateReactantProd(); + GenerateJacReactantProd(); + GenerateStoicmSparseData(); + if ( (useLang == F77_LANG)||(useLang == C_LANG)||(useLang == MATLAB_LANG) ) + GenerateStoicmSparseHeader(); + GenerateDFunDRcoeff(); + GenerateDJacDRcoeff(); + } + + printf("\nKPP is generating the driver from %s.f90:", driver); + printf("\n - %s_Main",rootFileName); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateIntegrator(); + + /* mz_rs_20050518+ no driver file if driver = none */ + if( strcmp( driver, "none" ) != 0 ) + GenerateDriver(); + /* mz_rs_20050518- */ + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMakefile(); + + if ( useLang == F90_LANG ) + GenerateF90Modules('t'); + + if ( useLang == MATLAB_LANG ) + GenerateMatlabTemplates(); + + if ( (useLang == F77_LANG)||(useLang == F90_LANG)||(useLang == C_LANG) ) + GenerateMex(); + + /* mz_rs_20050117+ */ + if( initFile ) fclose( initFile ); + /* mz_rs_20050117- */ + if( driverFile ) fclose( driverFile ); + if( functionFile ) fclose( functionFile ); + if( global_dataFile ) fclose( global_dataFile ); + if( hessianFile ) fclose( hessianFile ); + if( integratorFile ) fclose( integratorFile ); + if( jacobianFile ) fclose( jacobianFile ); + if( linalgFile ) fclose( linalgFile ); + if( mapFile ) fclose( mapFile ); + if( makeFile ) fclose( makeFile ); + if( monitorFile ) fclose( monitorFile ); + if( mex_funFile ) fclose( mex_funFile ); + if( mex_jacFile ) fclose( mex_jacFile ); + if( mex_hessFile ) fclose( mex_hessFile ); + if( param_headerFile ) fclose( param_headerFile ); + if( rateFile ) fclose( rateFile ); + if( sparse_dataFile ) fclose( sparse_dataFile ); + if( sparse_jacFile ) fclose( sparse_jacFile ); + if( sparse_hessFile ) fclose( sparse_hessFile ); + if( sparse_stoicmFile ) fclose( sparse_stoicmFile ); + if( stoichiomFile ) fclose( stoichiomFile ); + if( utilFile ) fclose( utilFile ); + if( stochasticFile ) fclose( stochasticFile ); + +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +int* AllocIntegerVector(int n, char* message) +{ +int* vec; +if ( ( vec=(int*)calloc(n,sizeof(int)) ) == NULL ) + FatalError(-30,"%s: Cannot allocate vector.",message); +return vec; +} + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +/* Allocates a matrix of integers */ +int** AllocIntegerMatrix(int m, int n, char* message) +{ +int** mat; +int i; +if ( (mat = (int**)calloc(m,sizeof(int*)))==NULL ) { + FatalError(-30,"%s: Cannot allocate matrix.", message); + } +for (i=0; i +#include +#include "gdata.h" +#include "scan.h" + +char *eqFileName; +char *rootFileName = "ff"; +char Home[ MAX_PATH ] = ""; + +short int linStru[ MAX_SPECIES ]; +short int colStru[ MAX_SPECIES ]; +short int bestStru[ MAX_SPECIES ]; +short int *Stru; + +enum stru_criteria { UNSORT, LINSORT, COLSORT, BESTSORT }; + +void EqCopy( EQ_VECT e1, EQ_VECT e2 ) +{ +int i; + + for( i = 0; i < EqnNr; i++ ) e2[i] = e1[i]; +} + +int NoSort( const void *p1, const void *p2 ) +{ + return -1; +} + +int CodeCmp( const void *p1, const void *p2 ) +{ +CODE *c1, *c2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + if ( *c1 < *c2 ) return -1; + if ( *c1 > *c2 ) return 1; + return 0; +} + +int CodeRCmp( const void *p1, const void *p2 ) +{ +int rc1, rc2; +CODE *c1, *c2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + rc1 = Reactive[ ReverseCode[ *c1 ] ]; + rc2 = Reactive[ ReverseCode[ *c2 ] ]; + if ( rc1 > rc2 ) return -1; + if ( rc1 < rc2 ) return 1; + if ( *c1 < *c2 ) return -1; + if ( *c1 > *c2 ) return 1; + return 0; +} + +int CodeSSCmp( const void *p1, const void *p2 ) +{ + return -CodeRCmp(p1,p2); +} + +int CodeSCmp( const void *p1, const void *p2 ) +{ +CODE *c1, *c2; +short int sc1, sc2; + + c1 = (CODE*)p1; + c2 = (CODE*)p2; + + sc1 = Stru[ ReverseCode[ *c1 ] ]; + sc2 = Stru[ ReverseCode[ *c2 ] ]; + + if ( sc1 > sc2 ) return 1; + if ( sc1 < sc2 ) return -1; + if ( *c1 < *c2 ) return 1; + if ( *c1 > *c2 ) return -1; + return 0; +} + +void UpdateStructJ() +{ +int i,j,k; + + for ( i=0; i j) nl++; + if(i <= j) nu++; + } + + return nu+nl; +} + +int LUnonZero() +{ +CODE v[MAX_SPECIES]; +CODE *var; +int i,j,k; +int nu,nl; + + var = v; + if( Stru != bestStru ) { + for( i=0; i tmp; mv tmp %s_Update_RCONST.m;", + root, root, root ); + system( buf ); + } + +/* Postprocessing to replace parameter names by values in the declarations + strcpy( cmd, "sed " ); + sprintf( cmd, "%s -e 's/(NVAR)/(%d)/g'", cmd, VarNr ); + sprintf( cmd, "%s -e 's/(NFIX)/(%d)/g'", cmd, FixNr ); + sprintf( cmd, "%s -e 's/(NSPEC)/(%d)/g'", cmd,SpcNr ); + sprintf( cmd, "%s -e 's/(NREACT)/(%d)/g'", cmd, EqnNr ); + sprintf( cmd, "%s -e 's/(NONZERO)/(%d)/g'", cmd, Jac_NZ ); + sprintf( cmd, "%s -e 's/(LU_NONZERO)/(%d)/g'", cmd, LU_Jac_NZ ); + sprintf( cmd, "%s -e 's/(NHESS)/(%)/g'", cmd, Hess_NZ ); + + sprintf( buf, "%s_Function", rootFileName ); + switch( useLang ) { + case F77_LANG: sprintf( buf, "%s.f", buf ); + break; + case F90_LANG: sprintf( buf, "%s.f90", buf ); + break; + case C_LANG: sprintf( buf, "%s.c", buf ); + break; + case MATLAB_LANG: sprintf( buf, "%s.m", buf ); + break; + default: printf("\n Language '%d' not implemented!\n",useLang); + exit(1); + } + sprintf( cmdexe, "%s %s > %s; mv %s %s;", cmd, buf, tmpfile, tmpfile, buf ); + printf("\n\nCMDEXE='%s'\n",cmdexe); + system( cmdexe ); +*/ +} + +/*******************************************************************/ +int main( int argc, char * argv[] ) +{ +int status; +char name[ 200 ]; +char *p; +int i,j; + + AllocInternalArrays(); + + p = getenv("KPP_HOME"); + if( p ) strcpy( Home, p ); + + switch( argc ) { + case 3: eqFileName = argv[1]; + rootFileName = argv[2]; + break; + case 2: eqFileName = argv[1]; + strcpy( name, eqFileName ); + p = name + strlen(name); + while( p > name ) { + if( *p == '.') { + *p = '\0'; + break; + } + p--; + } + rootFileName = name; + break; + default: FatalError(1,"\nUsage :" + "\n kpp [output file]\n"); + } + + printf("\nThis is KPP-%s.\n", KPP_VERSION); + + printf("\nKPP is parsing the equation file."); + status = ParseEquationFile( argv[1] ); + + if( status ) FatalError(2,"%d errors and %d warnings encountered.", + nError, nWarning ); + /* Allocate some internal data structures */ + AllocStructArrays(); + + printf("\nKPP is computing Jacobian sparsity structure."); + ReorderSpecies( UNSORT ); + if (useReorder==1){ + BestSparsity(); + ReorderSpecies( BESTSORT ); + } + UpdateStructJ(); + ComputeLUStructJ(); + + if( initNr == -1 ) initNr = VarNr; + + + printf("\nKPP is starting the code generation."); + Generate( rootFileName ); + + printf("\nKPP is starting the code post-processing."); + Postprocess( rootFileName ); + + printf("\n\nKPP has succesfully created the model \"%s\".\n\n",rootFileName); + + if( nError ) exit(4); + if( nWarning ) exit(5); + + exit(0); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/lex.yy.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/lex.yy.c new file mode 100755 index 00000000..167ceea1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/lex.yy.c @@ -0,0 +1,2406 @@ +/* A lexical scanner generated by flex */ + +/* Scanner skeleton version: + * $Header: /home/daffy/u0/vern/flex/RCS/flex.skl,v 2.91 96/09/10 16:58:48 vern Exp $ + */ + +#define FLEX_SCANNER +#define YY_FLEX_MAJOR_VERSION 2 +#define YY_FLEX_MINOR_VERSION 5 + +#include + + +/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ +#ifdef c_plusplus +#ifndef __cplusplus +#define __cplusplus +#endif +#endif + + +#ifdef __cplusplus + +#include +#include + +/* Use prototypes in function declarations. */ +#define YY_USE_PROTOS + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +#if __STDC__ + +#define YY_USE_PROTOS +#define YY_USE_CONST + +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ + +#ifdef __TURBOC__ + #pragma warn -rch + #pragma warn -use +#include +#include +#define YY_USE_CONST +#define YY_USE_PROTOS +#endif + +#ifdef YY_USE_CONST +#define yyconst const +#else +#define yyconst +#endif + + +#ifdef YY_USE_PROTOS +#define YY_PROTO(proto) proto +#else +#define YY_PROTO(proto) () +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN yy_start = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. The YYSTATE alias is for lex + * compatibility. + */ +#define YY_START ((yy_start - 1) / 2) +#define YYSTATE YY_START + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". */ +#define YY_NEW_FILE yyrestart( yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#define YY_BUF_SIZE 16384 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +extern int yyleng; +extern FILE *yyin, *yyout; + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + +/* The funky do-while in the following #define is used to turn the definition + * int a single C statement (which needs a semi-colon terminator). This + * avoids problems with code like: + * + * if ( condition_holds ) + * yyless( 5 ); + * else + * do_something_else(); + * + * Prior to using the do-while the compiler would get upset at the + * "else" because it interpreted the "if" statement as being all + * done when it reached the ';' after the yyless() call. + */ + +/* Return all but the first 'n' matched characters back to the input stream. */ + +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + *yy_cp = yy_hold_char; \ + YY_RESTORE_YY_MORE_OFFSET \ + yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, yytext_ptr ) + +/* The following is because we cannot portably get our hands on size_t + * (without autoconf's help, which isn't available because we want + * flex-generated scanners to compile on their own). + */ +typedef unsigned int yy_size_t; + + +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + yy_size_t yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether we "own" the buffer - i.e., we know we created it, + * and can realloc() it to grow it, and should free() it to + * delete it. + */ + int yy_is_our_buffer; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether we're considered to be at the beginning of a line. + * If so, '^' rules will be active on the next match, otherwise + * not. + */ + int yy_at_bol; + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + }; + +static YY_BUFFER_STATE yy_current_buffer = 0; + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + */ +#define YY_CURRENT_BUFFER yy_current_buffer + + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; + +static int yy_n_chars; /* number of characters read into yy_ch_buf */ + + +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 1; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +void yyrestart YY_PROTO(( FILE *input_file )); + +void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); +void yy_load_buffer_state YY_PROTO(( void )); +YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); +void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); +void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); +void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b )); +#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer ) + +YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size )); +YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *yy_str )); +YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len )); + +static void *yy_flex_alloc YY_PROTO(( yy_size_t )); +static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t )); +static void yy_flex_free YY_PROTO(( void * )); + +#define yy_new_buffer yy_create_buffer + +#define yy_set_interactive(is_interactive) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_is_interactive = is_interactive; \ + } + +#define yy_set_bol(at_bol) \ + { \ + if ( ! yy_current_buffer ) \ + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \ + yy_current_buffer->yy_at_bol = at_bol; \ + } + +#define YY_AT_BOL() (yy_current_buffer->yy_at_bol) + +typedef unsigned char YY_CHAR; +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; +typedef int yy_state_type; +extern char *yytext; +#define yytext_ptr yytext + +static yy_state_type yy_get_previous_state YY_PROTO(( void )); +static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); +static int yy_get_next_buffer YY_PROTO(( void )); +static void yy_fatal_error YY_PROTO(( yyconst char msg[] )); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + yytext_ptr = yy_bp; \ + yyleng = (int) (yy_cp - yy_bp); \ + yy_hold_char = *yy_cp; \ + *yy_cp = '\0'; \ + yy_c_buf_p = yy_cp; + +#define YY_NUM_RULES 58 +#define YY_END_OF_BUFFER 59 +static yyconst short int yy_accept[199] = + { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 19, 19, 0, 0, 29, 29, 33, 33, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 5, 5, 7, 7, 0, 0, 57, 57, + 59, 58, 1, 9, 2, 58, 3, 10, 10, 11, + 11, 12, 12, 13, 13, 14, 14, 23, 1, 9, + 21, 23, 19, 22, 20, 18, 3, 25, 24, 30, + 1, 9, 30, 29, 30, 29, 28, 27, 26, 26, + 3, 35, 33, 33, 34, 36, 32, 31, 31, 37, + + 38, 39, 39, 40, 45, 1, 9, 42, 45, 43, + 44, 41, 3, 15, 15, 17, 16, 47, 46, 54, + 54, 53, 52, 49, 48, 50, 50, 51, 5, 1, + 2, 5, 3, 6, 7, 1, 8, 2, 7, 3, + 57, 56, 55, 1, 4, 10, 4, 11, 4, 12, + 4, 13, 4, 14, 4, 19, 18, 24, 29, 29, + 0, 29, 29, 26, 0, 26, 33, 0, 33, 33, + 31, 0, 31, 37, 39, 4, 41, 15, 4, 16, + 46, 54, 4, 52, 48, 50, 4, 5, 1, 4, + 7, 1, 4, 57, 55, 29, 33, 0 + + } ; + +static yyconst int yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 2, 1, 1, 4, 1, 1, 1, 1, 1, + 1, 1, 5, 1, 6, 7, 8, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 10, 11, 12, + 13, 14, 1, 1, 15, 15, 15, 15, 16, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 1, 1, 1, 1, 15, 1, 15, 15, 15, 15, + + 16, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 17, 1, 18, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static yyconst int yy_meta[19] = + { 0, + 1, 2, 3, 4, 5, 5, 1, 1, 6, 1, + 7, 1, 1, 1, 8, 8, 7, 9 + } ; + +static yyconst short int yy_base[237] = + { 0, + 0, 16, 32, 49, 66, 83, 100, 117, 134, 151, + 168, 185, 203, 0, 211, 217, 233, 0, 247, 0, + 255, 0, 270, 287, 305, 0, 322, 339, 0, 0, + 347, 353, 359, 365, 380, 397, 405, 411, 417, 423, + 438, 455, 472, 489, 506, 522, 0, 0, 2, 6, + 88, 842, 80, 842, 842, 73, 842, 0, 72, 0, + 71, 0, 70, 0, 68, 0, 67, 842, 71, 842, + 842, 64, 62, 842, 842, 0, 842, 842, 0, 842, + 63, 842, 55, 5, 55, 533, 842, 842, 0, 545, + 842, 842, 6, 555, 842, 842, 842, 0, 567, 0, + + 842, 0, 54, 842, 842, 59, 842, 842, 51, 842, + 842, 0, 842, 0, 50, 842, 0, 842, 0, 0, + 48, 842, 0, 842, 0, 0, 47, 842, 0, 52, + 0, 40, 0, 842, 0, 45, 842, 0, 38, 0, + 0, 842, 0, 43, 842, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 35, 0, 0, 0, 7, + 33, 16, 0, 0, 32, 30, 21, 20, 22, 0, + 0, 19, 18, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 24, 0, + 0, 11, 0, 0, 0, 3, 2, 842, 583, 592, + + 601, 610, 619, 628, 637, 646, 655, 664, 673, 682, + 691, 700, 708, 716, 724, 732, 735, 738, 741, 744, + 747, 755, 758, 766, 769, 772, 780, 783, 786, 794, + 802, 810, 819, 828, 833, 835 + } ; + +static yyconst short int yy_def[237] = + { 0, + 199, 199, 200, 200, 201, 201, 202, 202, 203, 203, + 204, 204, 198, 13, 2, 2, 198, 17, 2, 19, + 2, 21, 205, 205, 198, 25, 206, 206, 2, 2, + 2, 2, 2, 2, 207, 207, 2, 2, 2, 2, + 208, 208, 209, 209, 210, 210, 2, 2, 211, 211, + 198, 198, 198, 198, 198, 198, 198, 212, 212, 213, + 213, 214, 214, 215, 215, 216, 216, 198, 198, 198, + 198, 198, 198, 198, 198, 217, 198, 198, 218, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 219, 198, + 198, 198, 198, 198, 198, 198, 198, 220, 198, 221, + + 198, 222, 222, 198, 198, 198, 198, 198, 198, 198, + 198, 223, 198, 224, 224, 198, 225, 198, 226, 227, + 227, 198, 228, 198, 229, 230, 230, 198, 231, 231, + 231, 231, 231, 198, 232, 232, 198, 232, 232, 232, + 233, 198, 234, 198, 198, 212, 212, 213, 213, 214, + 214, 215, 215, 216, 216, 198, 217, 218, 86, 198, + 235, 198, 86, 219, 198, 219, 198, 236, 198, 94, + 220, 198, 220, 221, 222, 222, 223, 224, 224, 225, + 226, 227, 227, 228, 229, 230, 230, 231, 231, 231, + 232, 232, 232, 233, 234, 198, 198, 0, 198, 198, + + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198 + } ; + +static yyconst short int yy_nxt[861] = + { 0, + 198, 53, 54, 55, 142, 143, 198, 56, 142, 143, + 197, 196, 192, 160, 167, 160, 57, 53, 54, 55, + 161, 168, 161, 56, 160, 189, 173, 197, 197, 167, + 167, 161, 57, 53, 54, 55, 168, 168, 166, 59, + 196, 196, 52, 156, 144, 193, 192, 190, 57, 52, + 53, 54, 55, 189, 187, 183, 59, 179, 145, 52, + 144, 176, 145, 159, 144, 57, 52, 53, 54, 55, + 156, 145, 144, 61, 155, 153, 52, 151, 149, 147, + 145, 144, 57, 52, 53, 54, 55, 198, 198, 198, + 61, 198, 198, 52, 198, 198, 198, 198, 198, 57, + + 52, 53, 54, 55, 198, 198, 198, 63, 198, 198, + 52, 198, 198, 198, 198, 198, 57, 52, 53, 54, + 55, 198, 198, 198, 63, 198, 198, 52, 198, 198, + 198, 198, 198, 57, 52, 53, 54, 55, 198, 198, + 198, 65, 198, 198, 52, 198, 198, 198, 198, 198, + 57, 52, 53, 54, 55, 198, 198, 198, 65, 198, + 198, 52, 198, 198, 198, 198, 198, 57, 52, 53, + 54, 55, 198, 198, 198, 67, 198, 198, 52, 198, + 198, 198, 198, 198, 57, 52, 53, 54, 55, 198, + 198, 198, 67, 198, 198, 52, 198, 198, 198, 198, + + 198, 57, 52, 68, 69, 70, 55, 71, 68, 68, + 72, 73, 68, 74, 68, 75, 68, 76, 76, 77, + 68, 78, 198, 198, 198, 79, 79, 78, 198, 198, + 198, 79, 79, 80, 81, 82, 55, 83, 83, 84, + 85, 86, 80, 87, 80, 88, 80, 89, 90, 91, + 80, 92, 92, 93, 198, 94, 95, 198, 96, 97, + 198, 98, 99, 100, 198, 198, 198, 198, 101, 100, + 100, 53, 54, 55, 198, 198, 198, 103, 198, 198, + 104, 198, 198, 198, 198, 198, 57, 52, 53, 54, + 55, 198, 198, 198, 103, 198, 198, 104, 198, 198, + + 198, 198, 198, 57, 52, 105, 106, 107, 55, 108, + 105, 105, 109, 105, 110, 111, 105, 105, 105, 112, + 112, 113, 105, 53, 54, 55, 198, 198, 198, 115, + 198, 198, 52, 198, 198, 198, 198, 198, 57, 52, + 53, 54, 55, 198, 198, 198, 115, 198, 198, 52, + 198, 198, 198, 198, 198, 57, 52, 116, 198, 198, + 198, 117, 117, 116, 198, 198, 198, 117, 117, 118, + 198, 198, 198, 119, 119, 118, 198, 198, 198, 119, + 119, 53, 54, 55, 198, 198, 198, 121, 198, 198, + 52, 198, 198, 198, 198, 198, 57, 52, 53, 54, + + 55, 198, 198, 198, 121, 198, 198, 52, 198, 198, + 198, 198, 198, 57, 52, 122, 198, 198, 198, 123, + 123, 122, 198, 198, 198, 123, 123, 124, 198, 198, + 198, 125, 125, 124, 198, 198, 198, 125, 125, 53, + 54, 55, 198, 198, 198, 127, 198, 198, 128, 198, + 198, 198, 198, 198, 57, 52, 53, 54, 55, 198, + 198, 198, 127, 198, 198, 128, 198, 198, 198, 198, + 198, 57, 52, 130, 54, 131, 198, 198, 198, 132, + 198, 198, 198, 198, 198, 198, 198, 198, 133, 134, + 130, 54, 131, 198, 198, 198, 132, 198, 198, 198, + + 198, 198, 198, 198, 198, 133, 134, 136, 137, 138, + 198, 198, 198, 139, 198, 198, 198, 198, 198, 198, + 198, 198, 140, 136, 137, 138, 198, 198, 198, 139, + 198, 198, 198, 198, 198, 198, 198, 198, 140, 162, + 198, 163, 198, 198, 198, 198, 198, 198, 161, 165, + 165, 198, 198, 166, 198, 198, 198, 198, 198, 164, + 164, 169, 198, 170, 198, 198, 198, 198, 198, 198, + 168, 172, 172, 198, 198, 173, 198, 198, 198, 198, + 198, 171, 171, 52, 52, 52, 52, 52, 52, 52, + 52, 52, 58, 58, 58, 58, 58, 58, 58, 58, + + 58, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 62, 62, 62, 62, 62, 62, 62, 62, 62, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 114, 114, 114, 114, + 114, 114, 114, 114, 114, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 126, 126, 126, 126, 126, 126, + 126, 126, 126, 129, 129, 129, 129, 129, 129, 129, + 129, 129, 135, 135, 135, 135, 135, 135, 135, 135, + 135, 141, 141, 141, 141, 141, 141, 141, 141, 141, + + 146, 198, 198, 198, 146, 146, 198, 146, 148, 198, + 198, 198, 148, 148, 198, 148, 150, 198, 198, 198, + 150, 150, 198, 150, 152, 198, 198, 198, 152, 152, + 198, 152, 154, 198, 198, 198, 154, 154, 198, 154, + 157, 198, 157, 158, 198, 158, 164, 198, 164, 171, + 198, 171, 174, 198, 174, 175, 198, 198, 198, 175, + 175, 198, 175, 177, 198, 177, 178, 198, 198, 198, + 178, 178, 198, 178, 180, 198, 180, 181, 198, 181, + 182, 198, 198, 198, 182, 182, 198, 182, 184, 198, + 184, 185, 198, 185, 186, 198, 198, 198, 186, 186, + + 198, 186, 188, 188, 198, 188, 188, 188, 188, 188, + 191, 191, 198, 191, 191, 191, 191, 191, 191, 194, + 194, 198, 198, 194, 194, 194, 194, 194, 195, 198, + 198, 195, 195, 195, 195, 195, 195, 165, 165, 172, + 172, 51, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198 + } ; + +static yyconst short int yy_chk[861] = + { 0, + 0, 1, 1, 1, 49, 49, 0, 1, 50, 50, + 197, 196, 192, 84, 93, 160, 1, 2, 2, 2, + 84, 93, 160, 2, 162, 189, 173, 172, 168, 167, + 169, 162, 2, 3, 3, 3, 167, 169, 166, 3, + 165, 161, 3, 156, 144, 139, 136, 132, 3, 3, + 4, 4, 4, 130, 127, 121, 4, 115, 109, 4, + 106, 103, 85, 83, 81, 4, 4, 5, 5, 5, + 73, 72, 69, 5, 67, 65, 5, 63, 61, 59, + 56, 53, 5, 5, 6, 6, 6, 51, 0, 0, + 6, 0, 0, 6, 0, 0, 0, 0, 0, 6, + + 6, 7, 7, 7, 0, 0, 0, 7, 0, 0, + 7, 0, 0, 0, 0, 0, 7, 7, 8, 8, + 8, 0, 0, 0, 8, 0, 0, 8, 0, 0, + 0, 0, 0, 8, 8, 9, 9, 9, 0, 0, + 0, 9, 0, 0, 9, 0, 0, 0, 0, 0, + 9, 9, 10, 10, 10, 0, 0, 0, 10, 0, + 0, 10, 0, 0, 0, 0, 0, 10, 10, 11, + 11, 11, 0, 0, 0, 11, 0, 0, 11, 0, + 0, 0, 0, 0, 11, 11, 12, 12, 12, 0, + 0, 0, 12, 0, 0, 12, 0, 0, 0, 0, + + 0, 12, 12, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 15, 0, 0, 0, 15, 15, 16, 0, 0, + 0, 16, 16, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 19, 19, 19, 0, 19, 19, 0, 19, 19, + 0, 19, 19, 21, 0, 0, 0, 0, 21, 21, + 21, 23, 23, 23, 0, 0, 0, 23, 0, 0, + 23, 0, 0, 0, 0, 0, 23, 23, 24, 24, + 24, 0, 0, 0, 24, 0, 0, 24, 0, 0, + + 0, 0, 0, 24, 24, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 27, 27, 27, 0, 0, 0, 27, + 0, 0, 27, 0, 0, 0, 0, 0, 27, 27, + 28, 28, 28, 0, 0, 0, 28, 0, 0, 28, + 0, 0, 0, 0, 0, 28, 28, 31, 0, 0, + 0, 31, 31, 32, 0, 0, 0, 32, 32, 33, + 0, 0, 0, 33, 33, 34, 0, 0, 0, 34, + 34, 35, 35, 35, 0, 0, 0, 35, 0, 0, + 35, 0, 0, 0, 0, 0, 35, 35, 36, 36, + + 36, 0, 0, 0, 36, 0, 0, 36, 0, 0, + 0, 0, 0, 36, 36, 37, 0, 0, 0, 37, + 37, 38, 0, 0, 0, 38, 38, 39, 0, 0, + 0, 39, 39, 40, 0, 0, 0, 40, 40, 41, + 41, 41, 0, 0, 0, 41, 0, 0, 41, 0, + 0, 0, 0, 0, 41, 41, 42, 42, 42, 0, + 0, 0, 42, 0, 0, 42, 0, 0, 0, 0, + 0, 42, 42, 43, 43, 43, 0, 0, 0, 43, + 0, 0, 0, 0, 0, 0, 0, 0, 43, 43, + 44, 44, 44, 0, 0, 0, 44, 0, 0, 0, + + 0, 0, 0, 0, 0, 44, 44, 45, 45, 45, + 0, 0, 0, 45, 0, 0, 0, 0, 0, 0, + 0, 0, 45, 46, 46, 46, 0, 0, 0, 46, + 0, 0, 0, 0, 0, 0, 0, 0, 46, 86, + 0, 86, 0, 0, 0, 0, 0, 0, 86, 90, + 90, 0, 0, 90, 0, 0, 0, 0, 0, 90, + 90, 94, 0, 94, 0, 0, 0, 0, 0, 0, + 94, 99, 99, 0, 0, 99, 0, 0, 0, 0, + 0, 99, 99, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 200, 200, 200, 200, 200, 200, 200, 200, + + 200, 201, 201, 201, 201, 201, 201, 201, 201, 201, + 202, 202, 202, 202, 202, 202, 202, 202, 202, 203, + 203, 203, 203, 203, 203, 203, 203, 203, 204, 204, + 204, 204, 204, 204, 204, 204, 204, 205, 205, 205, + 205, 205, 205, 205, 205, 205, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 208, 208, 208, 208, 208, 208, + 208, 208, 208, 209, 209, 209, 209, 209, 209, 209, + 209, 209, 210, 210, 210, 210, 210, 210, 210, 210, + 210, 211, 211, 211, 211, 211, 211, 211, 211, 211, + + 212, 0, 0, 0, 212, 212, 0, 212, 213, 0, + 0, 0, 213, 213, 0, 213, 214, 0, 0, 0, + 214, 214, 0, 214, 215, 0, 0, 0, 215, 215, + 0, 215, 216, 0, 0, 0, 216, 216, 0, 216, + 217, 0, 217, 218, 0, 218, 219, 0, 219, 220, + 0, 220, 221, 0, 221, 222, 0, 0, 0, 222, + 222, 0, 222, 223, 0, 223, 224, 0, 0, 0, + 224, 224, 0, 224, 225, 0, 225, 226, 0, 226, + 227, 0, 0, 0, 227, 227, 0, 227, 228, 0, + 228, 229, 0, 229, 230, 0, 0, 0, 230, 230, + + 0, 230, 231, 231, 0, 231, 231, 231, 231, 231, + 232, 232, 0, 232, 232, 232, 232, 232, 232, 233, + 233, 0, 0, 233, 233, 233, 233, 233, 234, 0, + 0, 234, 234, 234, 234, 234, 234, 235, 235, 236, + 236, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198 + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +#define YY_RESTORE_YY_MORE_OFFSET +char *yytext; +#line 1 "scan.l" +#define INITIAL 0 +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ +#define CMD_STATE 1 +#define INC_STATE 2 +#define MOD_STATE 3 +#define INT_STATE 4 + +#define PRM_STATE 5 +#define DSP_STATE 6 +#define SSP_STATE 7 +#define INI_STATE 8 +#define EQN_STATE 9 +#define EQNTAG_STATE 10 + +#define RATE_STATE 11 +#define LMP_STATE 12 +#define CR_IGNORE 13 +#define SC_IGNORE 14 +#define ATM_STATE 15 +#define LKT_STATE 16 +#define INL_STATE 17 + +#define MNI_STATE 18 +#define TPT_STATE 19 +#define USE_STATE 20 + +#define COMMENT 21 +#define COMMENT2 22 +#define EQN_ID 23 + +#define INL_CODE 24 + +#line 42 "scan.l" + #include "gdata.h" + #include "scan.h" + #include "y.tab.h" + + void Include ( char * filename ); + int EndInclude(); + + int crt_line_no = 1; + char *crt_filename; + + #define MAX_INCLUDE 10 + + YY_BUFFER_STATE yy_buffers[ MAX_INCLUDE ]; + int yy_line_no[ MAX_INCLUDE ]; + char *yy_filename[ MAX_INCLUDE ]; + int yy_buf_level = 0; + + char crtToken[100]; + char nextToken[100]; + int crtTokType; + int nextTokType; + int crtLine; + char crtFile[100]; + char crt_rate[100]; + + int oldnErr = 0; + + int idx; + int oldstate; + extern int yyerrflag; + + typedef struct { + char *name; + int next; + int cmd; + } KEYWORD; + + KEYWORD keywords[] = { { "INCLUDE", INC_STATE, 0 }, + { "MODEL", MOD_STATE, 0 }, + { "INTEGRATOR", INT_STATE, 0 }, + { "JACOBIAN", PRM_STATE, JACOBIAN }, + { "HESSIAN", PRM_STATE, HESSIAN }, + { "STOICMAT", PRM_STATE, STOICMAT }, + { "STOCHASTIC", PRM_STATE, STOCHASTIC }, + { "DOUBLE", PRM_STATE, DOUBLE }, + { "REORDER", PRM_STATE, REORDER }, + { "MEX", PRM_STATE, MEX }, + { "DUMMYINDEX", PRM_STATE, DUMMYINDEX}, + { "EQNTAGS", PRM_STATE, EQNTAGS}, + { "FUNCTION", PRM_STATE, FUNCTION }, + { "ATOMS", ATM_STATE, ATOMDECL }, + { "CHECK", ATM_STATE, CHECK }, + { "CHECKALL", INITIAL, CHECKALL }, + { "DEFVAR", DSP_STATE, DEFVAR }, + { "DEFRAD", DSP_STATE, DEFRAD }, + { "DEFFIX", DSP_STATE, DEFFIX }, + { "SETVAR", SSP_STATE, SETVAR }, + { "SETRAD", SSP_STATE, SETRAD }, + { "SETFIX", SSP_STATE, SETFIX }, + { "INITVALUES", INI_STATE, INITVALUES }, + { "EQUATIONS", EQN_STATE, EQUATIONS }, + { "LUMP", LMP_STATE, LUMP }, + { "LOOKAT", LKT_STATE, LOOKAT }, + { "LOOKATALL", INITIAL, LOOKATALL }, + { "TRANSPORT", TPT_STATE, TRANSPORT }, + { "TRANSPORTALL", INITIAL, TRANSPORTALL }, + { "INITIALIZE", PRM_STATE, INITIALIZE }, + { "XGRID", PRM_STATE, XGRID }, + { "YGRID", PRM_STATE, YGRID }, + { "ZGRID", PRM_STATE, ZGRID }, + { "MONITOR", MNI_STATE, MONITOR }, + { "WRITE_ATM", INITIAL, WRITE_ATM }, + { "WRITE_SPC", INITIAL, WRITE_SPC }, + { "WRITE_MAT", INITIAL, WRITE_MAT }, + { "WRITE_OPT", INITIAL, WRITE_OPT }, + { "USE", PRM_STATE, USE }, + { "LANGUAGE", PRM_STATE, LANGUAGE }, + { "INLINE", INL_STATE, INLINE }, + { "ENDINLINE", INITIAL, ENDINLINE }, + { "INTFILE", PRM_STATE, INTFILE }, + { "DRIVER", PRM_STATE, DRIVER }, + { "RUN", PRM_STATE, RUN }, + { "USES", USE_STATE, USES }, + { "SPARSEDATA", PRM_STATE, SPARSEDATA }, + { "WRFCONFORM", INITIAL, WRFCONFORM }, + { 0, 0, 0 } + }; + + int CheckKeyword( char *cmd ); + +#define RETURN( x ) \ + if(1) { \ + if ( yyerrflag == 0) { \ + strcpy( crtToken, nextToken ); \ + crtTokType = nextTokType; \ + crtLine = crt_line_no; \ + strcpy( crtFile, crt_filename ); \ + } \ + strcpy( nextToken, yytext); \ + nextTokType = x; \ + return (x); \ + } +#line 784 "lex.yy.c" + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifndef YY_SKIP_YYWRAP +#ifdef __cplusplus +extern "C" int yywrap YY_PROTO(( void )); +#else +extern int yywrap YY_PROTO(( void )); +#endif +#endif + +#ifndef YY_NO_UNPUT +static void yyunput YY_PROTO(( int c, char *buf_ptr )); +#endif + +#ifndef yytext_ptr +static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int )); +#endif + +#ifdef YY_NEED_STRLEN +static int yy_flex_strlen YY_PROTO(( yyconst char * )); +#endif + +#ifndef YY_NO_INPUT +#ifdef __cplusplus +static int yyinput YY_PROTO(( void )); +#else +static int input YY_PROTO(( void )); +#endif +#endif + +#if YY_STACK_USED +static int yy_start_stack_ptr = 0; +static int yy_start_stack_depth = 0; +static int *yy_start_stack = 0; +#ifndef YY_NO_PUSH_STATE +static void yy_push_state YY_PROTO(( int new_state )); +#endif +#ifndef YY_NO_POP_STATE +static void yy_pop_state YY_PROTO(( void )); +#endif +#ifndef YY_NO_TOP_STATE +static int yy_top_state YY_PROTO(( void )); +#endif + +#else +#define YY_NO_PUSH_STATE 1 +#define YY_NO_POP_STATE 1 +#define YY_NO_TOP_STATE 1 +#endif + +#ifdef YY_MALLOC_DECL +YY_MALLOC_DECL +#else +#if __STDC__ +#ifndef __cplusplus +#include +#endif +#else +/* Just try to get by without declaring the routines. This will fail + * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) + * or sizeof(void*) != sizeof(int). + */ +#endif +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ + +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( yy_current_buffer->yy_is_interactive ) \ + { \ + int c = '*', n; \ + for ( n = 0; n < max_size && \ + (c = getc( yyin )) != EOF && c != '\n'; ++n ) \ + buf[n] = (char) c; \ + if ( c == '\n' ) \ + buf[n++] = (char) c; \ + if ( c == EOF && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); \ + result = n; \ + } \ + else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ + && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL int yylex YY_PROTO(( void )) +#endif + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +#define YY_RULE_SETUP \ + YY_USER_ACTION + +YY_DECL + { + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +#line 165 "scan.l" + +#line 937 "lex.yy.c" + + if ( yy_init ) + { + yy_init = 0; + +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! yy_start ) + yy_start = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( ! yy_current_buffer ) + yy_current_buffer = + yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_load_buffer_state(); + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = yy_c_buf_p; + + /* Support of yytext. */ + *yy_cp = yy_hold_char; + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = yy_start; +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 842 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + if ( yy_act == 0 ) + { /* have to back up */ + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + yy_act = yy_accept[yy_current_state]; + } + + YY_DO_BEFORE_ACTION; + + +do_action: /* This label is used only to access EOF actions. */ + + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = yy_hold_char; + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + goto yy_find_action; + +case 1: +YY_RULE_SETUP +#line 166 "scan.l" +{ + } + YY_BREAK +case 2: +YY_RULE_SETUP +#line 168 "scan.l" +{ BEGIN CMD_STATE; + } + YY_BREAK +case 3: +YY_RULE_SETUP +#line 170 "scan.l" +{ oldstate = (yy_start - 1) / 2; + BEGIN COMMENT; + } + YY_BREAK +case 4: +YY_RULE_SETUP +#line 173 "scan.l" +{ oldstate = (yy_start - 1) / 2; + BEGIN COMMENT2; + } + YY_BREAK +case 5: +YY_RULE_SETUP +#line 176 "scan.l" +{ + } + YY_BREAK +case 6: +YY_RULE_SETUP +#line 178 "scan.l" +{ BEGIN oldstate; + } + YY_BREAK +case 7: +YY_RULE_SETUP +#line 180 "scan.l" +{ + } + YY_BREAK +case 8: +YY_RULE_SETUP +#line 182 "scan.l" +{ crt_line_no++; + BEGIN oldstate; + } + YY_BREAK +case 9: +YY_RULE_SETUP +#line 185 "scan.l" +{ crt_line_no++; + } + YY_BREAK +case 10: +YY_RULE_SETUP +#line 187 "scan.l" +{ idx = CheckKeyword( yytext ); + if ( idx < 0 ) { + BEGIN CR_IGNORE; + break; + } + BEGIN keywords[idx].next; + if ( keywords[idx].cmd ) { + crt_section = keywords[idx].cmd; + RETURN( keywords[idx].cmd ); + } + } + YY_BREAK +case 11: +YY_RULE_SETUP +#line 198 "scan.l" +{ Include( IncName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 12: +YY_RULE_SETUP +#line 201 "scan.l" +{ Include( ModelName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 13: +YY_RULE_SETUP +#line 204 "scan.l" +{ Include( IntegName(yytext) ); + BEGIN CR_IGNORE; + } + YY_BREAK +case 14: +YY_RULE_SETUP +#line 207 "scan.l" +{ strcpy( yylval.str, yytext ); + BEGIN CR_IGNORE; + RETURN( PARAMETER ); + } + YY_BREAK +case 15: +YY_RULE_SETUP +#line 211 "scan.l" +{ ScanError("Extra parameter on command line '%s'", yytext); + } + YY_BREAK +case 16: +YY_RULE_SETUP +#line 213 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( ATOMID ); + } + YY_BREAK +case 17: +YY_RULE_SETUP +#line 216 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 18: +YY_RULE_SETUP +#line 218 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SPCSPC ); + } + YY_BREAK +case 19: +YY_RULE_SETUP +#line 221 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SPCNR ); + } + YY_BREAK +case 20: +YY_RULE_SETUP +#line 224 "scan.l" +{ RETURN( SPCEQUAL ); + } + YY_BREAK +case 21: +YY_RULE_SETUP +#line 226 "scan.l" +{ RETURN( SPCPLUS ); + } + YY_BREAK +case 22: +YY_RULE_SETUP +#line 228 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 23: +YY_RULE_SETUP +#line 230 "scan.l" +{ ScanError("Invalid character '%c' in species definition", yytext[0] ); + } + YY_BREAK +case 24: +YY_RULE_SETUP +#line 232 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( SSPID ); + } + YY_BREAK +case 25: +YY_RULE_SETUP +#line 235 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 26: +YY_RULE_SETUP +#line 237 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( INISPC ); + } + YY_BREAK +case 27: +YY_RULE_SETUP +#line 240 "scan.l" +{ RETURN( INIEQUAL ); + } + YY_BREAK +case 28: +YY_RULE_SETUP +#line 242 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 29: +YY_RULE_SETUP +#line 244 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( INIVALUE ); + } + YY_BREAK +case 30: +YY_RULE_SETUP +#line 247 "scan.l" +{ ScanError("Invalid character '%c' in initial values", yytext[0] ); + } + YY_BREAK +case 31: +YY_RULE_SETUP +#line 249 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNSPC ); + } + YY_BREAK +case 32: +YY_RULE_SETUP +#line 252 "scan.l" +{ RETURN( EQNEQUAL ); + } + YY_BREAK +case 33: +YY_RULE_SETUP +#line 254 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNCOEF ); + } + YY_BREAK +case 34: +YY_RULE_SETUP +#line 257 "scan.l" +{ BEGIN RATE_STATE; + *crt_rate = 0; + RETURN( EQNCOLON ); + } + YY_BREAK +case 35: +YY_RULE_SETUP +#line 261 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNSIGN ); + } + YY_BREAK +case 36: +YY_RULE_SETUP +#line 264 "scan.l" +{ BEGIN EQNTAG_STATE; + RETURN( EQNLESS ); + } + YY_BREAK +case 37: +YY_RULE_SETUP +#line 267 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( EQNTAG ); + } + YY_BREAK +case 38: +YY_RULE_SETUP +#line 270 "scan.l" +{ BEGIN EQN_STATE; + RETURN( EQNGREATER ); + } + YY_BREAK +case 39: +YY_RULE_SETUP +#line 273 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( RATE ); + } + YY_BREAK +case 40: +YY_RULE_SETUP +#line 276 "scan.l" +{ BEGIN EQN_STATE; + RETURN( yytext[0] ); + } + YY_BREAK +case 41: +YY_RULE_SETUP +#line 279 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( LMPSPC ); + } + YY_BREAK +case 42: +YY_RULE_SETUP +#line 282 "scan.l" +{ RETURN( LMPPLUS ); + } + YY_BREAK +case 43: +YY_RULE_SETUP +#line 284 "scan.l" +{ RETURN( LMPCOLON ); + } + YY_BREAK +case 44: +YY_RULE_SETUP +#line 286 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 45: +YY_RULE_SETUP +#line 288 "scan.l" +{ ScanError("Invalid character '%c' in species definition", yytext[0] ); + } + YY_BREAK +case 46: +YY_RULE_SETUP +#line 290 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( LKTID ); + } + YY_BREAK +case 47: +YY_RULE_SETUP +#line 293 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 48: +YY_RULE_SETUP +#line 295 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( TPTID ); + } + YY_BREAK +case 49: +YY_RULE_SETUP +#line 298 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 50: +YY_RULE_SETUP +#line 300 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( USEID ); + } + YY_BREAK +case 51: +YY_RULE_SETUP +#line 303 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 52: +YY_RULE_SETUP +#line 305 "scan.l" +{ strcpy( yylval.str, yytext ); + RETURN( MNIID ); + } + YY_BREAK +case 53: +YY_RULE_SETUP +#line 308 "scan.l" +{ RETURN( yytext[0] ); + } + YY_BREAK +case 54: +YY_RULE_SETUP +#line 310 "scan.l" +{ strcpy( yylval.str, yytext ); + BEGIN INL_CODE; + RETURN( INLCTX ); + } + YY_BREAK +case 55: +YY_RULE_SETUP +#line 314 "scan.l" +{ if ( EqNoCase( yytext+1, "ENDINLINE" ) ){ + BEGIN INITIAL; + RETURN( ENDINLINE ); + } + else { + strcpy( yylval.str, yytext ); + RETURN( INCODE ); + } + } + YY_BREAK +case 56: +YY_RULE_SETUP +#line 323 "scan.l" +{ crt_line_no++; + strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } + YY_BREAK +case 57: +YY_RULE_SETUP +#line 327 "scan.l" +{ strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } + YY_BREAK +case YY_STATE_EOF(INITIAL): +case YY_STATE_EOF(CMD_STATE): +case YY_STATE_EOF(INC_STATE): +case YY_STATE_EOF(MOD_STATE): +case YY_STATE_EOF(INT_STATE): +case YY_STATE_EOF(PRM_STATE): +case YY_STATE_EOF(DSP_STATE): +case YY_STATE_EOF(SSP_STATE): +case YY_STATE_EOF(INI_STATE): +case YY_STATE_EOF(EQN_STATE): +case YY_STATE_EOF(EQNTAG_STATE): +case YY_STATE_EOF(RATE_STATE): +case YY_STATE_EOF(LMP_STATE): +case YY_STATE_EOF(CR_IGNORE): +case YY_STATE_EOF(SC_IGNORE): +case YY_STATE_EOF(ATM_STATE): +case YY_STATE_EOF(LKT_STATE): +case YY_STATE_EOF(INL_STATE): +case YY_STATE_EOF(MNI_STATE): +case YY_STATE_EOF(TPT_STATE): +case YY_STATE_EOF(USE_STATE): +case YY_STATE_EOF(COMMENT): +case YY_STATE_EOF(COMMENT2): +case YY_STATE_EOF(EQN_ID): +case YY_STATE_EOF(INL_CODE): +#line 330 "scan.l" +{ if ( ! EndInclude() ) { + RETURN( INITIAL ); + } + } + YY_BREAK +case 58: +YY_RULE_SETUP +#line 334 "scan.l" +ECHO; + YY_BREAK +#line 1448 "lex.yy.c" + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = yy_hold_char; + YY_RESTORE_YY_MORE_OFFSET + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between yy_current_buffer and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + yy_n_chars = yy_current_buffer->yy_n_chars; + yy_current_buffer->yy_input_file = yyin; + yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = yytext_ptr + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++yy_c_buf_p; + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = yy_c_buf_p; + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + yy_did_buffer_switch_on_eof = 0; + + if ( yywrap() ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = + yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + yy_c_buf_p = + &yy_current_buffer->yy_ch_buf[yy_n_chars]; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of yylex */ + + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ + +static int yy_get_next_buffer() + { + register char *dest = yy_current_buffer->yy_ch_buf; + register char *source = yytext_ptr; + register int number_to_move, i; + int ret_val; + + if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( yy_current_buffer->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) + { + /* We matched a single character, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + yy_current_buffer->yy_n_chars = yy_n_chars = 0; + + else + { + int num_to_read = + yy_current_buffer->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ +#ifdef YY_USES_REJECT + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); +#else + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = yy_current_buffer; + + int yy_c_buf_p_offset = + (int) (yy_c_buf_p - b->yy_ch_buf); + + if ( b->yy_is_our_buffer ) + { + int new_size = b->yy_buf_size * 2; + + if ( new_size <= 0 ) + b->yy_buf_size += b->yy_buf_size / 8; + else + b->yy_buf_size *= 2; + + b->yy_ch_buf = (char *) + /* Include room in for 2 EOB chars. */ + yy_flex_realloc( (void *) b->yy_ch_buf, + b->yy_buf_size + 2 ); + } + else + /* Can't grow it, we don't own it. */ + b->yy_ch_buf = 0; + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = yy_current_buffer->yy_buf_size - + number_to_move - 1; +#endif + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), + yy_n_chars, num_to_read ); + + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + if ( yy_n_chars == 0 ) + { + if ( number_to_move == YY_MORE_ADJ ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + yy_current_buffer->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + yy_n_chars += number_to_move; + yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; + yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; + + yytext_ptr = &yy_current_buffer->yy_ch_buf[0]; + + return ret_val; + } + + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +static yy_state_type yy_get_previous_state() + { + register yy_state_type yy_current_state; + register char *yy_cp; + + yy_current_state = yy_start; + + for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; + } + + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + +#ifdef YY_USE_PROTOS +static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) +#else +static yy_state_type yy_try_NUL_trans( yy_current_state ) +yy_state_type yy_current_state; +#endif + { + register int yy_is_jam; + register char *yy_cp = yy_c_buf_p; + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 199 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 198); + + return yy_is_jam ? 0 : yy_current_state; + } + + +#ifndef YY_NO_UNPUT +#ifdef YY_USE_PROTOS +static void yyunput( int c, register char *yy_bp ) +#else +static void yyunput( c, yy_bp ) +int c; +register char *yy_bp; +#endif + { + register char *yy_cp = yy_c_buf_p; + + /* undo effects of setting up yytext */ + *yy_cp = yy_hold_char; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = yy_n_chars + 2; + register char *dest = &yy_current_buffer->yy_ch_buf[ + yy_current_buffer->yy_buf_size + 2]; + register char *source = + &yy_current_buffer->yy_ch_buf[number_to_move]; + + while ( source > yy_current_buffer->yy_ch_buf ) + *--dest = *--source; + + yy_cp += (int) (dest - source); + yy_bp += (int) (dest - source); + yy_current_buffer->yy_n_chars = + yy_n_chars = yy_current_buffer->yy_buf_size; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + *--yy_cp = (char) c; + + + yytext_ptr = yy_bp; + yy_hold_char = *yy_cp; + yy_c_buf_p = yy_cp; + } +#endif /* ifndef YY_NO_UNPUT */ + + +#ifdef __cplusplus +static int yyinput() +#else +static int input() +#endif + { + int c; + + *yy_c_buf_p = yy_hold_char; + + if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + /* This was really a NUL. */ + *yy_c_buf_p = '\0'; + + else + { /* need more input */ + int offset = yy_c_buf_p - yytext_ptr; + ++yy_c_buf_p; + + switch ( yy_get_next_buffer() ) + { + case EOB_ACT_LAST_MATCH: + /* This happens because yy_g_n_b() + * sees that we've accumulated a + * token and flags that we need to + * try matching the token before + * proceeding. But for input(), + * there's no matching to consider. + * So convert the EOB_ACT_LAST_MATCH + * to EOB_ACT_END_OF_FILE. + */ + + /* Reset buffer status. */ + yyrestart( yyin ); + + /* fall through */ + + case EOB_ACT_END_OF_FILE: + { + if ( yywrap() ) + return EOF; + + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = yytext_ptr + offset; + break; + } + } + } + + c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ + *yy_c_buf_p = '\0'; /* preserve yytext */ + yy_hold_char = *++yy_c_buf_p; + + + return c; + } + + +#ifdef YY_USE_PROTOS +void yyrestart( FILE *input_file ) +#else +void yyrestart( input_file ) +FILE *input_file; +#endif + { + if ( ! yy_current_buffer ) + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_init_buffer( yy_current_buffer, input_file ); + yy_load_buffer_state(); + } + + +#ifdef YY_USE_PROTOS +void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) +#else +void yy_switch_to_buffer( new_buffer ) +YY_BUFFER_STATE new_buffer; +#endif + { + if ( yy_current_buffer == new_buffer ) + return; + + if ( yy_current_buffer ) + { + /* Flush out information for old buffer. */ + *yy_c_buf_p = yy_hold_char; + yy_current_buffer->yy_buf_pos = yy_c_buf_p; + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + yy_current_buffer = new_buffer; + yy_load_buffer_state(); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + yy_did_buffer_switch_on_eof = 1; + } + + +#ifdef YY_USE_PROTOS +void yy_load_buffer_state( void ) +#else +void yy_load_buffer_state() +#endif + { + yy_n_chars = yy_current_buffer->yy_n_chars; + yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; + yyin = yy_current_buffer->yy_input_file; + yy_hold_char = *yy_c_buf_p; + } + + +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) +#else +YY_BUFFER_STATE yy_create_buffer( file, size ) +FILE *file; +int size; +#endif + { + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_is_our_buffer = 1; + + yy_init_buffer( b, file ); + + return b; + } + + +#ifdef YY_USE_PROTOS +void yy_delete_buffer( YY_BUFFER_STATE b ) +#else +void yy_delete_buffer( b ) +YY_BUFFER_STATE b; +#endif + { + if ( ! b ) + return; + + if ( b == yy_current_buffer ) + yy_current_buffer = (YY_BUFFER_STATE) 0; + + if ( b->yy_is_our_buffer ) + yy_flex_free( (void *) b->yy_ch_buf ); + + yy_flex_free( (void *) b ); + } + + +#ifndef YY_ALWAYS_INTERACTIVE +#ifndef YY_NEVER_INTERACTIVE +#include +#endif +#endif + +#ifdef YY_USE_PROTOS +void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) +#else +void yy_init_buffer( b, file ) +YY_BUFFER_STATE b; +FILE *file; +#endif + + + { + yy_flush_buffer( b ); + + b->yy_input_file = file; + b->yy_fill_buffer = 1; + +#if YY_ALWAYS_INTERACTIVE + b->yy_is_interactive = 1; +#else +#if YY_NEVER_INTERACTIVE + b->yy_is_interactive = 0; +#else + b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0; +#endif +#endif + } + + +#ifdef YY_USE_PROTOS +void yy_flush_buffer( YY_BUFFER_STATE b ) +#else +void yy_flush_buffer( b ) +YY_BUFFER_STATE b; +#endif + + { + if ( ! b ) + return; + + b->yy_n_chars = 0; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[0]; + + b->yy_at_bol = 1; + b->yy_buffer_status = YY_BUFFER_NEW; + + if ( b == yy_current_buffer ) + yy_load_buffer_state(); + } + + +#ifndef YY_NO_SCAN_BUFFER +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size ) +#else +YY_BUFFER_STATE yy_scan_buffer( base, size ) +char *base; +yy_size_t size; +#endif + { + YY_BUFFER_STATE b; + + if ( size < 2 || + base[size-2] != YY_END_OF_BUFFER_CHAR || + base[size-1] != YY_END_OF_BUFFER_CHAR ) + /* They forgot to leave room for the EOB's. */ + return 0; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" ); + + b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */ + b->yy_buf_pos = b->yy_ch_buf = base; + b->yy_is_our_buffer = 0; + b->yy_input_file = 0; + b->yy_n_chars = b->yy_buf_size; + b->yy_is_interactive = 0; + b->yy_at_bol = 1; + b->yy_fill_buffer = 0; + b->yy_buffer_status = YY_BUFFER_NEW; + + yy_switch_to_buffer( b ); + + return b; + } +#endif + + +#ifndef YY_NO_SCAN_STRING +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_string( yyconst char *yy_str ) +#else +YY_BUFFER_STATE yy_scan_string( yy_str ) +yyconst char *yy_str; +#endif + { + int len; + for ( len = 0; yy_str[len]; ++len ) + ; + + return yy_scan_bytes( yy_str, len ); + } +#endif + + +#ifndef YY_NO_SCAN_BYTES +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len ) +#else +YY_BUFFER_STATE yy_scan_bytes( bytes, len ) +yyconst char *bytes; +int len; +#endif + { + YY_BUFFER_STATE b; + char *buf; + yy_size_t n; + int i; + + /* Get memory for full buffer, including space for trailing EOB's. */ + n = len + 2; + buf = (char *) yy_flex_alloc( n ); + if ( ! buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" ); + + for ( i = 0; i < len; ++i ) + buf[i] = bytes[i]; + + buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR; + + b = yy_scan_buffer( buf, n ); + if ( ! b ) + YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" ); + + /* It's okay to grow etc. this buffer, and we should throw it + * away when we're done. + */ + b->yy_is_our_buffer = 1; + + return b; + } +#endif + + +#ifndef YY_NO_PUSH_STATE +#ifdef YY_USE_PROTOS +static void yy_push_state( int new_state ) +#else +static void yy_push_state( new_state ) +int new_state; +#endif + { + if ( yy_start_stack_ptr >= yy_start_stack_depth ) + { + yy_size_t new_size; + + yy_start_stack_depth += YY_START_STACK_INCR; + new_size = yy_start_stack_depth * sizeof( int ); + + if ( ! yy_start_stack ) + yy_start_stack = (int *) yy_flex_alloc( new_size ); + + else + yy_start_stack = (int *) yy_flex_realloc( + (void *) yy_start_stack, new_size ); + + if ( ! yy_start_stack ) + YY_FATAL_ERROR( + "out of memory expanding start-condition stack" ); + } + + yy_start_stack[yy_start_stack_ptr++] = YY_START; + + BEGIN(new_state); + } +#endif + + +#ifndef YY_NO_POP_STATE +static void yy_pop_state() + { + if ( --yy_start_stack_ptr < 0 ) + YY_FATAL_ERROR( "start-condition stack underflow" ); + + BEGIN(yy_start_stack[yy_start_stack_ptr]); + } +#endif + + +#ifndef YY_NO_TOP_STATE +static int yy_top_state() + { + return yy_start_stack[yy_start_stack_ptr - 1]; + } +#endif + +#ifndef YY_EXIT_FAILURE +#define YY_EXIT_FAILURE 2 +#endif + +#ifdef YY_USE_PROTOS +static void yy_fatal_error( yyconst char msg[] ) +#else +static void yy_fatal_error( msg ) +char msg[]; +#endif + { + (void) fprintf( stderr, "%s\n", msg ); + exit( YY_EXIT_FAILURE ); + } + + + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + yytext[yyleng] = yy_hold_char; \ + yy_c_buf_p = yytext + n; \ + yy_hold_char = *yy_c_buf_p; \ + *yy_c_buf_p = '\0'; \ + yyleng = n; \ + } \ + while ( 0 ) + + +/* Internal utility routines. */ + +#ifndef yytext_ptr +#ifdef YY_USE_PROTOS +static void yy_flex_strncpy( char *s1, yyconst char *s2, int n ) +#else +static void yy_flex_strncpy( s1, s2, n ) +char *s1; +yyconst char *s2; +int n; +#endif + { + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; + } +#endif + +#ifdef YY_NEED_STRLEN +#ifdef YY_USE_PROTOS +static int yy_flex_strlen( yyconst char *s ) +#else +static int yy_flex_strlen( s ) +yyconst char *s; +#endif + { + register int n; + for ( n = 0; s[n]; ++n ) + ; + + return n; + } +#endif + + +#ifdef YY_USE_PROTOS +static void *yy_flex_alloc( yy_size_t size ) +#else +static void *yy_flex_alloc( size ) +yy_size_t size; +#endif + { + return (void *) malloc( size ); + } + +#ifdef YY_USE_PROTOS +static void *yy_flex_realloc( void *ptr, yy_size_t size ) +#else +static void *yy_flex_realloc( ptr, size ) +void *ptr; +yy_size_t size; +#endif + { + /* The cast to (char *) in the following accommodates both + * implementations that use char* generic pointers, and those + * that use void* generic pointers. It works with the latter + * because both ANSI C and C++ allow castless assignment from + * any pointer type to void*, and deal with argument conversions + * as though doing an assignment. + */ + return (void *) realloc( (char *) ptr, size ); + } + +#ifdef YY_USE_PROTOS +static void yy_flex_free( void *ptr ) +#else +static void yy_flex_free( ptr ) +void *ptr; +#endif + { + free( ptr ); + } + +#if YY_MAIN +int main() + { + yylex(); + return 0; + } +#endif +#line 334 "scan.l" + + +void Include ( char * name ) +{ +FILE *f; +YY_BUFFER_STATE newb; + + if ( yy_buf_level == MAX_INCLUDE ) { + printf("\nInclude nested too deep. Include %s ignored", name); + return; + } + + yy_buffers[ yy_buf_level ] = yy_current_buffer; + yy_line_no[ yy_buf_level ] = crt_line_no; + yy_filename[ yy_buf_level ] = crt_filename; + yy_buf_level++; + + crt_line_no = 1; + + crt_filename = malloc( 1 + strlen( name ) ); + strcpy( crt_filename, name ); + + + f = fopen( name, "r" ); + if( f == 0 ) + FatalError(3,"%s: Can't read file", name ); + + newb = yy_create_buffer(f, YY_BUF_SIZE); + yy_switch_to_buffer( newb ); +} + +int EndInclude() +{ +YY_BUFFER_STATE oldb; +char * oldn; + + if ( yy_buf_level > 0 ) { + oldb = yy_current_buffer; + oldn = crt_filename; + yy_buf_level--; + yy_switch_to_buffer( yy_buffers[yy_buf_level] ); + crt_line_no = yy_line_no[ yy_buf_level ]; + crt_filename = yy_filename[ yy_buf_level ]; + yy_delete_buffer( oldb ); + free( oldn ); + return 1; + } + return 0; +} + +int EqNoCase( char *s1, char *s2 ) +{ + while( *s1 ) { + if ( toupper(*s1++) != toupper(*s2++) ) return 0; + } + return *s1 == *s2; +} + +int CheckKeyword( char *cmd ) +{ +int i; + + i = 0; + while( 1 ) { + if( keywords[i].name == 0 ) { + ScanError( "'%s': Unknown command (ignored)", cmd); + return -1; + } + if( EqNoCase( cmd, keywords[i].name ) ) { + return i; + } + i++; + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.h new file mode 100755 index 00000000..1f5fdc62 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.h @@ -0,0 +1,103 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +#ifndef _SCAN_H_ +#define _SCAN_H_ + +#include +#include "gdef.h" + +/* mz_rs_20050518+ value increased */ +#define MAX_INLINE 10000 +/* #define MAX_INLINE 4000 */ +/* mz_rs_20050518- */ + +enum eq_state { LHS, RHS, RAT }; +enum sptypes { DUMMY_SPC, VAR_SPC, RAD_SPC, FIX_SPC }; +enum atomcheck { NO_CHECK, DO_CHECK, CANCEL_CHECK }; +enum codetype { APPEND, REPLACE }; + +typedef struct { + int key; + int type; + char * kname; + } INLINE_KEY; + +extern int eqState; +extern int isPhoto; +extern int crt_line_no; +extern char *crt_filename; +extern int crtLine; +extern char crtFile[]; +extern char crtToken[]; +extern char nextToken[]; +extern int crtTokType; +extern int nextTokType; +extern int nError; +extern int nWarning; +extern int crt_section; + +int Parser( char * filename ); +void ScanError( char *fmt, ... ); +void ParserError( char *fmt, ... ); +void ScanWarning( char *fmt, ... ); +void ParserWarning( char *fmt, ... ); +void Error( char *fmt, ... ); +void Warning( char *fmt, ... ); +void Message( char *fmt, ... ); +void FatalError( int status, char *fmt, ... ); + +void DeclareAtom( char *atname ); +void SetAtomType( char *atname, int type ); +void AddAtom( char *atname, char *nr ); +void DeclareSpecies( int type, char* spname ); +void SetSpcType( int type, char *spname ); +void AssignInitialValue( char *spname , char *spval ); +void StoreEquationRate( char *rate, char *label ); +void CheckEquation(); +void ProcessTerm( int side, char *sign, char *coef, char *spname ); +void AddLumpSpecies( char *spname ); +void CheckLump( char *spname ); +void AddLookAt( char *spname ); +void AddMonitor( char *spname ); +void AddTransport( char *spname ); + +void WriteAtoms(); +void WriteSpecies(); +void WriteMatrices(); +void WriteOptions(); + +char * AppendString( char * s1, char * s2, int * len, int addlen ); +void AddInlineCode( char * context, char * code ); + +#endif diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.l b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.l new file mode 100755 index 00000000..f9dbdc8b --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.l @@ -0,0 +1,408 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +%s CMD_STATE INC_STATE MOD_STATE INT_STATE +%s PRM_STATE DSP_STATE SSP_STATE INI_STATE EQN_STATE EQNTAG_STATE +%s RATE_STATE LMP_STATE CR_IGNORE SC_IGNORE ATM_STATE LKT_STATE INL_STATE +%s MNI_STATE TPT_STATE USE_STATE +%s COMMENT COMMENT2 EQN_ID +%x INL_CODE + +%{ + #include "gdata.h" + #include "scan.h" + #include "y.tab.h" + + void Include ( char * filename ); + int EndInclude(); + + int crt_line_no = 1; + char *crt_filename; + + #define MAX_INCLUDE 10 + + YY_BUFFER_STATE yy_buffers[ MAX_INCLUDE ]; + int yy_line_no[ MAX_INCLUDE ]; + char *yy_filename[ MAX_INCLUDE ]; + int yy_buf_level = 0; + + char crtToken[100]; + char nextToken[100]; + int crtTokType; + int nextTokType; + int crtLine; + char crtFile[100]; + char crt_rate[100]; + + int oldnErr = 0; + + int idx; + int oldstate; + extern int yyerrflag; + + typedef struct { + char *name; + int next; + int cmd; + } KEYWORD; + + KEYWORD keywords[] = { { "INCLUDE", INC_STATE, 0 }, + { "MODEL", MOD_STATE, 0 }, + { "INTEGRATOR", INT_STATE, 0 }, + { "JACOBIAN", PRM_STATE, JACOBIAN }, + { "HESSIAN", PRM_STATE, HESSIAN }, + { "STOICMAT", PRM_STATE, STOICMAT }, + { "STOCHASTIC", PRM_STATE, STOCHASTIC }, + { "DOUBLE", PRM_STATE, DOUBLE }, + { "REORDER", PRM_STATE, REORDER }, + { "MEX", PRM_STATE, MEX }, + { "DUMMYINDEX", PRM_STATE, DUMMYINDEX}, + { "EQNTAGS", PRM_STATE, EQNTAGS}, + { "FUNCTION", PRM_STATE, FUNCTION }, + { "ATOMS", ATM_STATE, ATOMDECL }, + { "CHECK", ATM_STATE, CHECK }, + { "CHECKALL", INITIAL, CHECKALL }, + { "DEFVAR", DSP_STATE, DEFVAR }, + { "DEFRAD", DSP_STATE, DEFRAD }, + { "DEFFIX", DSP_STATE, DEFFIX }, + { "SETVAR", SSP_STATE, SETVAR }, + { "SETRAD", SSP_STATE, SETRAD }, + { "SETFIX", SSP_STATE, SETFIX }, + { "INITVALUES", INI_STATE, INITVALUES }, + { "EQUATIONS", EQN_STATE, EQUATIONS }, + { "LUMP", LMP_STATE, LUMP }, + { "LOOKAT", LKT_STATE, LOOKAT }, + { "LOOKATALL", INITIAL, LOOKATALL }, + { "TRANSPORT", TPT_STATE, TRANSPORT }, + { "TRANSPORTALL", INITIAL, TRANSPORTALL }, + { "INITIALIZE", PRM_STATE, INITIALIZE }, + { "XGRID", PRM_STATE, XGRID }, + { "YGRID", PRM_STATE, YGRID }, + { "ZGRID", PRM_STATE, ZGRID }, + { "MONITOR", MNI_STATE, MONITOR }, + { "WRITE_ATM", INITIAL, WRITE_ATM }, + { "WRITE_SPC", INITIAL, WRITE_SPC }, + { "WRITE_MAT", INITIAL, WRITE_MAT }, + { "WRITE_OPT", INITIAL, WRITE_OPT }, + { "USE", PRM_STATE, USE }, + { "LANGUAGE", PRM_STATE, LANGUAGE }, + { "INLINE", INL_STATE, INLINE }, + { "ENDINLINE", INITIAL, ENDINLINE }, + { "INTFILE", PRM_STATE, INTFILE }, + { "DRIVER", PRM_STATE, DRIVER }, + { "RUN", PRM_STATE, RUN }, + { "USES", USE_STATE, USES }, + { "SPARSEDATA", PRM_STATE, SPARSEDATA }, + { "WRFCONFORM", INITIAL, WRFCONFORM }, + { 0, 0, 0 } + }; + + int CheckKeyword( char *cmd ); + +#define RETURN( x ) \ + if(1) { \ + if ( yyerrflag == 0) { \ + strcpy( crtToken, nextToken ); \ + crtTokType = nextTokType; \ + crtLine = crt_line_no; \ + strcpy( crtFile, crt_filename ); \ + } \ + strcpy( nextToken, yytext); \ + nextTokType = x; \ + return (x); \ + } +%} + + +BT [ \t] +SPACE [ \t] +CR [\n] +TAG [a-zA-Z_0-9]+ +STRING [^ \t\n{}#;]+ + +LIT [a-zA-Z_] +CIF [0-9] + +IDSPC {LIT}[a-zA-Z_0-9]* + +NR {CIF}* +NRS [+-]?{CIF}+ +REAL {NRS}?"."?{NR} +UREAL {NR}?"."?{NR} +FLOAT {REAL}([eE]{NRS})? +UFLOAT {UREAL}([eE]{NRS})? + +%% +{SPACE}+ { + } +# { BEGIN CMD_STATE; + } +\{ { oldstate = (yy_start - 1) / 2; + BEGIN COMMENT; + } +\/\/ { oldstate = (yy_start - 1) / 2; + BEGIN COMMENT2; + } +[^\}\n]* { + } +\} { BEGIN oldstate; + } +[^\n]* { + } +{CR} { crt_line_no++; + BEGIN oldstate; + } +{CR} { crt_line_no++; + } +{STRING} { idx = CheckKeyword( yytext ); + if ( idx < 0 ) { + BEGIN CR_IGNORE; + break; + } + BEGIN keywords[idx].next; + if ( keywords[idx].cmd ) { + crt_section = keywords[idx].cmd; + RETURN( keywords[idx].cmd ); + } + } +{STRING} { Include( IncName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { Include( ModelName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { Include( IntegName(yytext) ); + BEGIN CR_IGNORE; + } +{STRING} { strcpy( yylval.str, yytext ); + BEGIN CR_IGNORE; + RETURN( PARAMETER ); + } +{STRING} { ScanError("Extra parameter on command line '%s'", yytext); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( ATOMID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( SPCSPC ); + } +{NR} { strcpy( yylval.str, yytext ); + RETURN( SPCNR ); + } +[=] { RETURN( SPCEQUAL ); + } +[+] { RETURN( SPCPLUS ); + } +; { RETURN( yytext[0] ); + } +[^;#] { ScanError("Invalid character '%c' in species definition", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( SSPID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( INISPC ); + } +[=] { RETURN( INIEQUAL ); + } +; { RETURN( yytext[0] ); + } +{FLOAT} { strcpy( yylval.str, yytext ); + RETURN( INIVALUE ); + } +[^=;#] { ScanError("Invalid character '%c' in initial values", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( EQNSPC ); + } +[=] { RETURN( EQNEQUAL ); + } +{UFLOAT} { strcpy( yylval.str, yytext ); + RETURN( EQNCOEF ); + } +[:] { BEGIN RATE_STATE; + *crt_rate = 0; + RETURN( EQNCOLON ); + } +[+-] { strcpy( yylval.str, yytext ); + RETURN( EQNSIGN ); + } +[<] { BEGIN EQNTAG_STATE; + RETURN( EQNLESS ); + } +{TAG} { strcpy( yylval.str, yytext ); + RETURN( EQNTAG ); + } +[>] { BEGIN EQN_STATE; + RETURN( EQNGREATER ); + } +{STRING} { strcpy( yylval.str, yytext ); + RETURN( RATE ); + } +; { BEGIN EQN_STATE; + RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( LMPSPC ); + } +[+] { RETURN( LMPPLUS ); + } +[:] { RETURN( LMPCOLON ); + } +; { RETURN( yytext[0] ); + } +[^;#] { ScanError("Invalid character '%c' in species definition", yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( LKTID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( TPTID ); + } +; { RETURN( yytext[0] ); + } +{STRING} { strcpy( yylval.str, yytext ); + RETURN( USEID ); + } +; { RETURN( yytext[0] ); + } +{IDSPC} { strcpy( yylval.str, yytext ); + RETURN( MNIID ); + } +; { RETURN( yytext[0] ); + } +{STRING} { strcpy( yylval.str, yytext ); + BEGIN INL_CODE; + RETURN( INLCTX ); + } +#[^ \t\n]* { if ( EqNoCase( yytext+1, "ENDINLINE" ) ){ + BEGIN INITIAL; + RETURN( ENDINLINE ); + } + else { + strcpy( yylval.str, yytext ); + RETURN( INCODE ); + } + } +\n { crt_line_no++; + strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } +[^#\n]* { strcpy( yylval.str,yytext ); + RETURN( INCODE ); + } +<> { if ( ! EndInclude() ) { + RETURN( INITIAL ); + } + } +%% + +void Include ( char * name ) +{ +FILE *f; +YY_BUFFER_STATE newb; + + if ( yy_buf_level == MAX_INCLUDE ) { + printf("\nInclude nested too deep. Include %s ignored", name); + return; + } + + yy_buffers[ yy_buf_level ] = yy_current_buffer; + yy_line_no[ yy_buf_level ] = crt_line_no; + yy_filename[ yy_buf_level ] = crt_filename; + yy_buf_level++; + + crt_line_no = 1; + + crt_filename = malloc( 1 + strlen( name ) ); + strcpy( crt_filename, name ); + + + f = fopen( name, "r" ); + if( f == 0 ) + FatalError(3,"%s: Can't read file", name ); + + newb = yy_create_buffer(f, YY_BUF_SIZE); + yy_switch_to_buffer( newb ); +} + +int EndInclude() +{ +YY_BUFFER_STATE oldb; +char * oldn; + + if ( yy_buf_level > 0 ) { + oldb = yy_current_buffer; + oldn = crt_filename; + yy_buf_level--; + yy_switch_to_buffer( yy_buffers[yy_buf_level] ); + crt_line_no = yy_line_no[ yy_buf_level ]; + crt_filename = yy_filename[ yy_buf_level ]; + yy_delete_buffer( oldb ); + free( oldn ); + return 1; + } + return 0; +} + +int EqNoCase( char *s1, char *s2 ) +{ + while( *s1 ) { + if ( toupper(*s1++) != toupper(*s2++) ) return 0; + } + return *s1 == *s2; +} + +int CheckKeyword( char *cmd ) +{ +int i; + + i = 0; + while( 1 ) { + if( keywords[i].name == 0 ) { + ScanError( "'%s': Unknown command (ignored)", cmd); + return -1; + } + if( EqNoCase( cmd, keywords[i].name ) ) { + return i; + } + i++; + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.y b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.y new file mode 100755 index 00000000..18e3f244 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scan.y @@ -0,0 +1,491 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + + +%{ + #include + #include + #include + #include + #include + #include "scan.h" + + #define __YYSCLASS + + #define YYDEBUG 1 + extern char yytext[]; + extern FILE * yyin; + + int nError = 0; + int nWarning = 0; + + int crt_section; + int eqState; + int isPhoto = 0; + + char crt_term[ 30 ]; + char crt_coef[ 30 ]; + + char * InlineBuf; + int InlineLen; + + void SemicolonError(); + extern int yyerrflag; + +%} + +%union{ + char str[80]; +}; + +%token JACOBIAN DOUBLE FUNCTION DEFVAR DEFRAD DEFFIX SETVAR SETRAD SETFIX +%token HESSIAN STOICMAT STOCHASTIC +%token INITVALUES EQUATIONS LUMP INIEQUAL EQNEQUAL EQNCOLON +%token LMPCOLON LMPPLUS SPCPLUS SPCEQUAL ATOMDECL CHECK CHECKALL REORDER +%token MEX DUMMYINDEX EQNTAGS +%token LOOKAT LOOKATALL TRANSPORT TRANSPORTALL MONITOR USES SPARSEDATA +%token WRFCONFORM +%token WRITE_ATM WRITE_SPC WRITE_MAT WRITE_OPT INITIALIZE XGRID YGRID ZGRID +%token USE LANGUAGE INTFILE DRIVER RUN INLINE ENDINLINE +%token PARAMETER SPCSPC INISPC INIVALUE EQNSPC EQNSIGN EQNCOEF +%type PARAMETER SPCSPC INISPC INIVALUE EQNSPC EQNSIGN EQNCOEF +%token RATE LMPSPC SPCNR ATOMID LKTID MNIID INLCTX INCODE SSPID +%type RATE LMPSPC SPCNR ATOMID LKTID MNIID INLCTX INCODE SSPID +%token EQNLESS EQNTAG EQNGREATER +%type EQNLESS EQNTAG EQNGREATER +%token TPTID USEID +%type TPTID USEID +%type rate eqntag + +%% + +program : section + | section program + ; +section : JACOBIAN PARAMETER + { CmdJacobian( $2 ); + } + | HESSIAN PARAMETER + { CmdHessian( $2 ); + } + | STOICMAT PARAMETER + { CmdStoicmat( $2 ); + } + | DOUBLE PARAMETER + { CmdDouble( $2 ); + } + | REORDER PARAMETER + { CmdReorder( $2 ); + } + | MEX PARAMETER + { CmdMex( $2 ); + } + | DUMMYINDEX PARAMETER + { CmdDummyindex( $2 ); + } + | EQNTAGS PARAMETER + { CmdEqntags( $2 ); + } + | FUNCTION PARAMETER + { CmdFunction( $2 ); + } + | STOCHASTIC PARAMETER + { CmdStochastic( $2 ); + } + | ATOMDECL atomlist + {} + | CHECK atomlist + {} + | DEFVAR species + {} + | DEFRAD species + {} + | DEFFIX species + {} + | SETVAR setspclist + {} + | SETRAD setspclist + {} + | SETFIX setspclist + {} + | INITVALUES initvalues + {} + | EQUATIONS equations + {} + | LUMP lumps + {} + | LOOKAT lookatlist + {} + | MONITOR monitorlist + {} + | TRANSPORT translist + {} + | CHECKALL + { CheckAll(); } + | LOOKATALL + { LookAtAll(); } + | TRANSPORTALL + { TransportAll(); } + | WRITE_ATM + { WriteAtoms(); } + | WRITE_SPC + { WriteSpecies(); } + | WRITE_MAT + { WriteMatrices(); } + | WRITE_OPT + { WriteOptions(); } + | USE PARAMETER + { CmdUse( $2 ); } + | LANGUAGE PARAMETER + { CmdLanguage( $2 ); } + | INITIALIZE PARAMETER + { DefineInitializeNbr( $2 ); } + | XGRID PARAMETER + { DefineXGrid( $2 ); } + | YGRID PARAMETER + { DefineYGrid( $2 ); } + | ZGRID PARAMETER + { DefineZGrid( $2 ); } + | INLINE INLCTX inlinecode ENDINLINE + { + AddInlineCode( $2, InlineBuf ); + free( InlineBuf ); + } + | INLINE error + { ParserErrorMessage(); } + | INTFILE PARAMETER + { CmdIntegrator( $2 ); } + | DRIVER PARAMETER + { CmdDriver( $2 ); } + | RUN PARAMETER + { CmdRun( $2 ); } + | USES uselist + {} + | SPARSEDATA PARAMETER + { SparseData( $2 ); + } + | WRFCONFORM + { WRFConform(); + } + ; +semicolon : semicolon ';' + { ScanWarning("Unnecessary ';'"); + } + | ';' + ; +atomlist : atomlist atomdef semicolon + | atomdef semicolon + | error semicolon + { ParserErrorMessage(); } + ; +atomdef : ATOMID + { switch( crt_section ) { + case ATOMDECL: DeclareAtom( $1 ); break; + case CHECK: SetAtomType( $1, DO_CHECK ); break; + } + } + ; +lookatlist : lookatlist lookatspc semicolon + | lookatspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +lookatspc : LKTID + { AddLookAt( $1 ); + } + ; +monitorlist : monitorlist monitorspc semicolon + | monitorspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +monitorspc : MNIID + { AddMonitor( $1 ); + } + ; +translist : translist transspc semicolon + | transspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +transspc : TPTID + { AddTransport( $1 ); + } + ; +uselist : uselist usefile semicolon + | usefile semicolon + | error semicolon + { ParserErrorMessage(); } + ; +usefile : USEID + { AddUseFile( $1 ); + } + ; +setspclist : setspclist setspcspc semicolon + | setspcspc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +setspcspc : SSPID + { switch( crt_section ) { + case SETVAR: SetSpcType( VAR_SPC, $1 ); break; + case SETRAD: SetSpcType( RAD_SPC, $1 ); break; + case SETFIX: SetSpcType( FIX_SPC, $1 ); break; + } + } + ; +species : species spc semicolon + | spc semicolon + | error semicolon + { ParserErrorMessage(); } + ; +spc : spcname + | spcdef + ; +spcname : SPCSPC SPCEQUAL atoms + { switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, $1 ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, $1 ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, $1 ); break; + } + } + ; +spcdef : SPCSPC + { switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, $1 ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, $1 ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, $1 ); break; + } + } + ; +atoms : atoms SPCPLUS atom + | atom + ; +atom : SPCNR SPCSPC + { AddAtom( $2, $1 ); + } + | SPCSPC + { AddAtom( $1, "1" ); + } + ; +initvalues : initvalues assignment semicolon + | assignment semicolon + | error semicolon + { ParserErrorMessage(); } + ; +assignment : INISPC INIEQUAL INIVALUE + { AssignInitialValue( $1, $3 ); } + ; +equations : equations equation semicolon + | equation semicolon + | error semicolon + { ParserErrorMessage(); + eqState = LHS; + } + ; +equation : eqntag lefths righths rate + { eqState = LHS; + StoreEquationRate( $4, $1 ); + CheckEquation(); + } + | lefths righths rate + { eqState = LHS; + StoreEquationRate( $3, " " ); + CheckEquation(); + } +rate : RATE rate + { strcpy( $$, $1 ); + strcat( $$, $2 ); + } + | RATE + { strcpy( $$, $1 ); + } + ; +eqntag : EQNLESS EQNTAG EQNGREATER + { strcpy( $$, $2 ); + } + ; +lefths : expresion EQNEQUAL + { eqState = RHS; } + ; +righths : expresion EQNCOLON + { eqState = RAT; } + ; +expresion : expresion EQNSIGN term + { ProcessTerm( eqState, $2, crt_coef, crt_term ); + } + | EQNSIGN term + { ProcessTerm( eqState, $1, crt_coef, crt_term ); + } + | term + { ProcessTerm( eqState, "+", crt_coef, crt_term ); + } + ; +term : EQNCOEF EQNSPC + { strcpy( crt_term, $2 ); + strcpy( crt_coef, $1 ); + } + | EQNSPC + { strcpy( crt_term, $1 ); + strcpy( crt_coef, "1" ); + } + ; +lumps : lumps lump semicolon + | lump semicolon + | error semicolon + { ParserErrorMessage(); } + ; +lump : LMPSPC LMPPLUS lump + { AddLumpSpecies( $1 ); + } + | LMPSPC LMPCOLON LMPSPC + { + AddLumpSpecies( $1 ); + CheckLump( $3 ); + } +inlinecode : inlinecode INCODE + { + InlineBuf = AppendString( InlineBuf, $2, &InlineLen, MAX_INLINE ); + } + | INCODE + { + InlineBuf = malloc( MAX_INLINE ); + InlineLen = MAX_INLINE; + strcpy( InlineBuf, $1); + } + ; +%% + +void yyerror( char * str ) +{ +} + +void ParserErrorMessage() +{ + yyerrok; +/* + Message("[%d,%s] -> [%d,%s]", crtTokType, crtToken, nextTokType, nextToken ); +*/ + if( crtToken[0] == ';' ) { + ParserError("Misplaced ';'"); + return; + } + switch( crtTokType ) { + case ATOMID: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case SPCSPC: + ParserError("Missing ';' or '+' after '%s'", crtToken ); + break; + case SPCNR: + ParserError("Missing species after '%s'", crtToken ); + break; + case SPCPLUS: + ParserError("Missing atom after '%s'", crtToken ); + break; + case SPCEQUAL: + ParserError("Invalid '=' after '%s'", crtToken ); + break; + + case INISPC: + ParserError("Missing '=' after '%s'", crtToken ); + break; + case INIEQUAL: + ParserError("Missing value after '%s'", crtToken ); + break; + case INIVALUE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case EQNSPC: + ParserError("Missing '+' or '=' after '%s'", crtToken ); + break; + case EQNEQUAL: + ParserError("Invalid right hand side of equation"); + break; + case EQNCOLON: + ParserError("Missing rate after '%s'", crtToken ); + break; + case EQNSIGN: + ParserError("Missing coeficient after '%s'", crtToken ); + break; + case EQNCOEF: + ParserError("Missing species after '%s'", crtToken ); + break; + case RATE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case LMPSPC: + ParserError("Missing '+' or ':' or ';' after '%s'", crtToken ); + break; + case LMPPLUS: + ParserError("Missing species after '%s'", crtToken ); + break; + case LMPCOLON: + ParserError("Missing species after '%s'", crtToken ); + break; + case INLINE: + ParserError("Missing inline option after '%s'", crtToken ); + break; + + default: + ParserError("Syntax error after '%s'", crtToken ); + } +} + + +int Parser( char * filename ) +{ +extern int yydebug; +FILE *f; + + crt_filename = filename; + + f = fopen( crt_filename, "r" ); + if( f == 0 ) { + FatalError(7,"%s: File not found", crt_filename); + } + + yyin = f; + nError = 0; + nWarning = 0; + yydebug = 0; + + yyparse(); + + fclose( f ); + + return nError; +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanner.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanner.c new file mode 100755 index 00000000..bc8a5ab5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanner.c @@ -0,0 +1,913 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include "gdata.h" +#include "scan.h" +#include "y.tab.h" +#include +#include +#include + +int AtomNr = 0; +int SpeciesNr = 0; +int EqnNr = 0; +int SpcNr = 0; +int VarNr = 0; +int VarActiveNr = 0; +int FixNr = 0; +int VarStartNr = 0; +int FixStartNr = 0; + + +int initNr = -1; +int xNr = 0; +int yNr = 0; +int zNr = 0; + +int falseSpcNr = 0; + +ATOM_DEF AtomTable[ MAX_ATNR ]; +SPECIES_DEF SpeciesTable[ MAX_SPECIES ]; +CODE ReverseCode[ MAX_SPECIES ]; +CODE Code[ MAX_SPECIES ]; +KREACT kr[ MAX_EQN ]; + +float** Stoich_Left; +float** Stoich; +float** Stoich_Right; +int Reactive[ MAX_SPECIES ]; + +INLINE_KEY InlineKeys[] = { { F77_GLOBAL, APPEND, "F77_GLOBAL" }, + { F77_INIT, APPEND, "F77_INIT" }, + { F77_DATA, APPEND, "F77_DATA" }, + { F77_UTIL, APPEND, "F77_UTIL" }, + { F77_RATES, APPEND, "F77_RATES" }, + { F77_RCONST, APPEND, "F77_RCONST" }, + { F90_GLOBAL, APPEND, "F90_GLOBAL" }, + { F90_INIT, APPEND, "F90_INIT" }, + { F90_DATA, APPEND, "F90_DATA" }, + { F90_UTIL, APPEND, "F90_UTIL" }, + { F90_RATES, APPEND, "F90_RATES" }, + { F90_RCONST, APPEND, "F90_RCONST" }, + { C_GLOBAL, APPEND, "C_GLOBAL" }, + { C_INIT, APPEND, "C_INIT" }, + { C_DATA, APPEND, "C_DATA" }, + { C_UTIL, APPEND, "C_UTIL" }, + { C_RATES, APPEND, "C_RATES" }, + { C_RCONST, APPEND, "C_RCONST" }, + { MATLAB_GLOBAL, APPEND, "MATLAB_GLOBAL" }, + { MATLAB_INIT, APPEND, "MATLAB_INIT" }, + { MATLAB_DATA, APPEND, "MATLAB_DATA" }, + { MATLAB_UTIL, APPEND, "MATLAB_UTIL" }, + { MATLAB_RATES, APPEND, "MATLAB_RATES" }, + { MATLAB_RCONST, APPEND, "MATLAB_RCONST" } + }; + +int useAggregate = 1; +int useJacobian = JAC_LU_ROW; +int useJacSparse = 1; +int useHessian = 1; +int useStoicmat = 1; +int useDouble = 1; +int useReorder = 1; +int useMex = 1; +int useDummyindex = 0; +int useEqntags = 0; +int useLang = F77_LANG; +int useStochastic = 0; +int useWRFConform = 0; + + +char integrator[ MAX_PATH ] = "none"; +char driver[ MAX_PATH ] = "none"; +char runArgs[ MAX_PATH ] = ""; + +/* mz_rs_20050701+ */ +/* char varDefault[ MAX_IVAL ] = "1.E-8"; */ +/* char fixDefault[ MAX_IVAL ] = "1.E-8"; */ +/* double cfactor = 1.09E+10; */ +char varDefault[ MAX_IVAL ] = "0."; +char fixDefault[ MAX_IVAL ] = "0."; +double cfactor = 1.; +/* mz_rs_20050701- */ + +ATOM crtAtoms[ MAX_ATOMS ]; +int crtAtomNr = 0; + +char *fileList[ MAX_FILES ]; +int fileNr = 0; + +double Abs( double x ) +{ + return x > 0 ? x : -x; +} + +void DefineInitializeNbr( char *cmd ) +{ +int n; + + n = sscanf( cmd, "%d", &initNr); + if( n != 1 ) + ScanError("Bad number of species to initialize <%s>", cmd); +} + +void DefineXGrid( char *cmd ) +{ +int n; + + xNr = 1; + n = sscanf( cmd, "%d", &xNr); + if( n != 1 ) + ScanError("Bad X grid number <%s>", cmd); +} + +void DefineYGrid( char *cmd ) +{ +int n; + + yNr = 1; + n = sscanf( cmd, "%d", &yNr); + if( n != 1 ) + ScanError("Bad Y grid number <%s>", cmd); +} + +void DefineZGrid( char *cmd ) +{ +int n; + + zNr = 1; + n = sscanf( cmd, "%d", &zNr); + if( n != 1 ) + ScanError("Bad Z grid number <%s>", cmd); +} + +void CmdFunction( char *cmd ) +{ + if( EqNoCase( cmd, "AGGREGATE" ) ) { + useAggregate = 1; + return; + } + if( EqNoCase( cmd, "SPLIT" ) ) { + useAggregate = 0; + return; + } + ScanError("'%s': Unknown parameter for #FUNCTION [AGGREGATE|SPLIT]", cmd ); +} + +void CmdJacobian( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useJacobian = JAC_OFF; + useJacSparse = 0; + return; + } + if( EqNoCase( cmd, "FULL" ) ) { + useJacobian = JAC_FULL; + useJacSparse = 0; + return; + } + if( EqNoCase( cmd, "SPARSE_LU_ROW" ) ) { + useJacobian = JAC_LU_ROW; + useJacSparse = 1; + return; + } + if( EqNoCase( cmd, "SPARSE_ROW" ) ) { + useJacobian = JAC_ROW; + useJacSparse = 1; + return; + } + ScanError("'%s': Unknown parameter for #JACOBIAN [OFF|FULL|SPARSE_LU_ROW|SPARSE_ROW]", cmd ); +} + +void SparseData( char *cmd ) { + ScanError("Deprecated use of #SPARSEDATA %s: see #JACOBIAN for equivalent functionality", cmd ); +} + +void CmdHessian( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useHessian = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useHessian = 1; + return; + } + ScanError("'%s': Unknown parameter for #HESSIAN [ON|OFF]", cmd ); +} + +void CmdStoicmat( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useStoicmat = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useStoicmat = 1; + return; + } + ScanError("'%s': Unknown parameter for #STOICMAT [ON|OFF]", cmd ); +} + +void CmdDouble( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useDouble = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useDouble = 1; + return; + } + ScanError("'%s': Unknown parameter for #DOUBLE [ON|OFF]", cmd ); +} + +void CmdReorder( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useReorder = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useReorder = 1; + return; + } + ScanError("'%s': Unknown parameter for #REORDER [ON|OFF]", cmd ); +} + +void CmdMex( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useMex = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useMex = 1; + return; + } + ScanError("'%s': Unknown parameter for #MEX [ON|OFF]", cmd ); +} + +void CmdDummyindex( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useDummyindex = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useDummyindex = 1; + return; + } + ScanError("'%s': Unknown parameter for #DUMMYINDEX [ON|OFF]", cmd ); +} + +void CmdEqntags( char *cmd ) +{ + if( EqNoCase( cmd, "OFF" ) ) { + useEqntags = 0; + return; + } + if( EqNoCase( cmd, "ON" ) ) { + useEqntags = 1; + return; + } + ScanError("'%s': Unknown parameter for #EQNTAGS [ON|OFF]", cmd ); +} + +void CmdUse( char *cmd ) +{ + ScanError("Deprecated command '#USE %s';\nReplace with '#LANGUAGE %s'.",cmd,cmd ); +} + + +void CmdLanguage( char *cmd ) +{ + if( EqNoCase( cmd, "FORTRAN77" ) ) { + useLang = F77_LANG; + return; + } + if( EqNoCase( cmd, "FORTRAN" ) ) { + ScanWarning("Fortran version not specified in '#LANGUAGE %s'. Will use Fortran 77.", cmd); + useLang = F77_LANG; + return; + } + if( EqNoCase( cmd, "FORTRAN90" ) ) { + useLang = F90_LANG; + return; + } + if( EqNoCase( cmd, "MATLAB" ) ) { + useLang = MATLAB_LANG; + return; + } + if( EqNoCase( cmd, "C" ) ) { + useLang = C_LANG; + return; + } + ScanError("'%s': Unknown parameter for #LANGUAGE [Fortran77|Fortran90|C|Matlab]", cmd ); +} + +void CmdStochastic( char *cmd ) +{ + if( EqNoCase( cmd, "ON" ) ) { + useStochastic = 1; + return; + } + if( EqNoCase( cmd, "OFF" ) ) { + useStochastic = 0; + return; + } + ScanError("'%s': Unknown parameter for #STOCHASTIC [OFF|ON]", cmd ); +} + +void CmdIntegrator( char *cmd ) +{ + strcpy( integrator, cmd ); +} + +void CmdDriver( char *cmd ) +{ + strcpy( driver, cmd ); +} + +void CmdRun( char *cmd ) +{ + strcpy( runArgs, cmd ); +} + +int FindAtom( char *atname ) +{ +int i; + + for( i=0; i= 0 ) { + ScanError("Multiple declaration for atom %s.", atname ); + return; + } + if( AtomNr >= MAX_ATNR ) { + Error("Too many atoms"); + return; + } + + strcpy( AtomTable[ AtomNr ].name, atname ); + AtomTable[ AtomNr ].check = NO_CHECK; + AtomTable[ AtomNr ].masscheck = 0; + AtomNr++; +} + +void SetAtomType( char *atname, int type ) +{ +int code; + + code = FindAtom( atname ); + if ( code < 0 ) { + ScanError("Undefined atom %s.", atname ); + return; + } + AtomTable[ code ].check = type; +} + +void CheckAll() +{ +int i; + + for( i=0; i 0 ) ) { + SpeciesTable[ index ].nratoms = crtAtomNr; + for( i = 0; i < crtAtomNr; i++ ) + SpeciesTable[ index ].atoms[i] = crtAtoms[i]; + } + crtAtomNr = 0; +} + +void DeclareSpecies( int type, char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code >= 0 ) { + ScanError("Multiple declaration for species %s.", spname ); + return; + } + if( SpeciesNr >= MAX_SPECIES ) { + Error("Too many species"); + return; + } + StoreSpecies( SpeciesNr, type, spname ); + SpeciesNr++; +} + +void SetSpcType( int type, char *spname ) +{ +int code; +int i; + + if( EqNoCase( spname, "VAR_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + if( SpeciesTable[i].type == VAR_SPC ) + SpeciesTable[i].type = type; + return; + } + if( EqNoCase( spname, "FIX_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + if( SpeciesTable[i].type == FIX_SPC ) + SpeciesTable[i].type = type; + return; + } + if( EqNoCase( spname, "ALL_SPEC" ) ) { + for( i = 0; i < SpeciesNr; i++ ) + SpeciesTable[i].type = type; + return; + } + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + SpeciesTable[ code ].type = type; +} + +void AssignInitialValue( char *spname , char *spval ) +{ +int code; +double cf; + + if( EqNoCase( spname, "CFACTOR" ) ) { + code = sscanf( spval, "%lg", &cf ); + if( code != 1 ) { + ScanWarning("Invalid CFACTOR value: %s", spval); + return; + } + cfactor = cf; + return; + } + + if( EqNoCase( spname, "VAR_SPEC" ) ) { + strcpy( varDefault, spval ); + return; + } + + + if( EqNoCase( spname, "FIX_SPEC" ) ) { + strcpy( fixDefault, spval ); + return; + } + + if( EqNoCase( spname, "ALL_SPEC" ) ) { + strcpy( varDefault, spval ); + strcpy( fixDefault, spval ); + return; + } + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + strcpy( SpeciesTable[ code ].ival, spval ); +} + +void StoreEquationRate( char *rate, char *label ) +{ +double f; +char buf[ MAX_K ]; +int n; +KREACT *kreact; + + kreact = &kr[ EqnNr ]; + strcpy( kreact->label, label ); + if( isPhoto ) { + kreact->type = PHOTO; + strcpy( kreact->val.st, rate ); + isPhoto = 0; + return; + } + n = sscanf( rate, "%lf%s", &f, buf ); + if ( n == 1 ) { + kreact->type = NUMBER; + kreact->val.f = f; + return; + } + kreact->type = EXPRESION; + strcpy( kreact->val.st, rate ); + return; +} + +void CheckEquation() +{ +int i,j; +int equal, index; +double r1, r2; +float atcnt[ MAX_ATNR ]; +int spc; +SPECIES_DEF *sp; +char errmsg[80]; +int err; + + if( EqnNr >= MAX_EQN ) { + Error("Too many equations"); + return; + } + + for( i = 0; i < AtomNr; i++ ) + atcnt[i] = 0; + + for( spc = 0; spc < SpcNr; spc++ ) { + sp = &SpeciesTable[ Code[spc] ]; + if( Stoich_Left[spc][EqnNr] != 0 ) { + for( i = 0; i < sp->nratoms; i++ ) + atcnt[ sp->atoms[i].code ] += Stoich_Left[spc][EqnNr] * sp->atoms[i].nr; + } + if( Stoich_Right[spc][EqnNr] != 0 ) { + for( i = 0; i < sp->nratoms; i++ ) + atcnt[ sp->atoms[i].code ] -= Stoich_Right[spc][EqnNr] * sp->atoms[i].nr; + } + } + + *errmsg = 0; + err = 0; + + for( i = 0; i < AtomNr; i++ ) { + if ( Abs( atcnt[i] ) > 1e-5 ) { + if ( AtomTable[i].check == CANCEL_CHECK ) { + err = 0; + break; + } + if ( AtomTable[i].check == NO_CHECK ) { + continue; + } + if ( AtomTable[i].check == DO_CHECK ) { + err = 1; + sprintf(errmsg, "%s %s", errmsg, AtomTable[i].name ); + continue; + } + } + } + + if ( err ) + ScanWarning( "(eqn %d) Atom balance mismatch for:%s.", EqnNr+1, errmsg ); + + for( j = 0; j < SpcNr; j++ ) + if( Stoich_Left[j][EqnNr] != 0 ) + { index = j; break; } + for( i = 0; i < EqnNr; i++ ) { + equal = 1; + r1 = Stoich_Left[index][EqnNr]; + r2 = Stoich_Left[index][i]; + for( j = 0; j < SpcNr; j++ ) { + if( r1 * Stoich_Left[j][i] != r2 * Stoich_Left[j][EqnNr] ) + { equal = 0; break; } + if( r1 * Stoich_Right[j][i] != r2 * Stoich_Right[j][EqnNr] ) + { equal = 0; break; } + } + if ( equal ) { + if( r1 == r2 ) + ScanError( "Duplicate equation: " + " (eqn<%d> = eqn<%d> )", i+1, EqnNr+1 ); + else + ScanError( "Linearly dependent equations: " + "( %.0f eqn<%d> = %.0f eqn<%d> )", + r1, i+1, r2, EqnNr+1 ); + break; + } + } + EqnNr++; +} + +void ProcessTerm( int side, char *sign, char *coef, char *spname ) +{ +int code; +CODE crtSpec; +double val; +char buf[40]; + + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + crtSpec = ReverseCode[ code ]; + + if(EqNoCase(spname,"HV")) isPhoto = 1; + + if ( crtSpec == NO_CODE ) { + if( MAX_SPECIES - code <= 2 ) falseSpcNr++; + crtSpec = SpcNr++; + Code[ crtSpec ] = code; + ReverseCode[ code ] = crtSpec; + } + + strcpy( buf, sign ); + strcat( buf, coef ); + sscanf( buf, "%lf", &val ); + + switch( side ) { + case LHS: Stoich_Left[ crtSpec ][ EqnNr ] += val; + Stoich[ crtSpec ][ EqnNr ] -= val; + Reactive[ crtSpec ] = 1; + break; + case RHS: Stoich_Right[ crtSpec ][ EqnNr ] += val; + Stoich[ crtSpec ][ EqnNr ] += val; + break; + } +} + +void AddLumpSpecies( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + /* ... */ + +} + +void CheckLump( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + /* ... */ + +} + +void AddLookAt( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + SpeciesTable[ code ].lookat = 1; +} + +void LookAtAll() +{ +int i; + + for( i=0; i= 0 ) { + SpeciesTable[ code ].moni = 1; + return; + } + + code = FindAtom( spname ); + if ( code >= 0 ) { + AtomTable[ code ].masscheck = 1; + return; + } + + ScanError("Undefined species or atom %s.", spname ); +} + +void AddTransport( char *spname ) +{ +int code; + + code = FindSpecies( spname ); + if ( code < 0 ) { + ScanError("Undefined species %s.", spname ); + return; + } + + SpeciesTable[ code ].trans = 1; +} + +void TransportAll() +{ +int i; + + for( i=0; i= *maxlen ) { + s1 = (char*)realloc( (void*)s1, *maxlen ); + } + strcat( s1, s2 ); + return s1; +} + +char * ReplaceString( char * s1, char * s2, int * maxlen, int addlen ) +{ +char * tmp; + + if( s1 ) free(s1); + + *maxlen = strlen( s2 ); + s1 = (char*)malloc( 1+*maxlen ); + strcpy( s1, s2 ); + + return s1; +} + +void AddInlineCode( char * ctx, char * s ) +{ +ICODE * c; +int i, key, type; +int totallength; /* mz_rs_20050607 */ + + c = NULL; + + for( i = 0; i < INLINE_OPT; i++ ) + if( EqNoCase( ctx, InlineKeys[i].kname ) ) { + key = InlineKeys[i].key; + c = &InlineCode[key]; + type = InlineKeys[i].type; + break; + } + if( !c ) { + printf( "\n'%s': Unknown inline option (ignored)", ctx ); + return; + } + + /* mz_rs_20050607+ */ + if (c->code) + totallength = strlen( c->code )+strlen( s ); + else + totallength = strlen( s ); + if (totallength>MAX_INLINE) + ScanError("\nInline code for %s is too long (%d>%d).\nIncrease MAX_INLINE in scan.h and recompile kpp!", + ctx, totallength, MAX_INLINE); + /* mz_rs_20050607- */ + + switch( type ) { + case APPEND: c->code = AppendString( c->code, s, &c->maxlen, MAX_INLINE ); + break; + case REPLACE: c->code = ReplaceString( c->code, s, &c->maxlen, MAX_INLINE ); + break; + } +} + +int ParseEquationFile( char * filename ) +{ +int i,j; +int code; + + for( i = 0; i < MAX_SPECIES; i++ ) { + ReverseCode[i] = NO_CODE; + Reactive[i] = 0; + } + for( i = 0; i < MAX_SPECIES; i++ ) { + for( j = 0; j < MAX_EQN; j++ ) { + Stoich_Left[i][j] = 0; + Stoich[i][j] = 0; + Stoich_Right[i][j] = 0; + } + } + for( i = 0; i < MAX_SPECIES; i++ ) { + SpeciesTable[ i ].nratoms = 0; + } + + for( i = 0; i < INLINE_OPT; i++ ) { + InlineCode[i].code = NULL; + InlineCode[i].maxlen = 0; + } + + EqnNr = 0; + SpcNr = 0; + + DeclareAtom( "CANCEL" ); + SetAtomType( "CANCEL", CANCEL_CHECK ); + DeclareAtom( "IGNORE" ); + SetAtomType( "IGNORE", NO_CHECK ); + DeclareSpecies( DUMMY_SPC, "???" ); + StoreSpecies( MAX_SPECIES-1, DUMMY_SPC, "HV" ); + AddAtom( "CANCEL", "1" ); + StoreSpecies( MAX_SPECIES-2, DUMMY_SPC, "PROD" ); + + code = Parser( filename ); + + return code; +} + +void WRFConform() +{ + useWRFConform = 1; +printf("\nKPP was told to generate WRF conform code"); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanutil.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanutil.c new file mode 100755 index 00000000..cd992aee --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/scanutil.c @@ -0,0 +1,202 @@ +/****************************************************************************** + + KPP - The Kinetic PreProcessor + Builds simulation code for chemical kinetic systems + + Copyright (C) 1995-1996 Valeriu Damian and Adrian Sandu + Copyright (C) 1997-2005 Adrian Sandu + + KPP is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + KPP is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Adrian Sandu + Computer Science Department + Virginia Polytechnic Institute and State University + Blacksburg, VA 24060 + E-mail: sandu@cs.vt.edu + +******************************************************************************/ + + +#include +#include +#include +#include +#include +#include "gdata.h" +#include "scan.h" + +#define MAX_BUFFER 200 + +void ScanError( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error :%s:%d: %s\n", crt_filename, crt_line_no, buf ); + nError++; +} + +void ParserError( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error :%s:%d: %s\n", crtFile, crtLine, buf ); + nError++; +} + +void ScanWarning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning :%s:%d: %s\n", crt_filename, crt_line_no, buf ); + nWarning++; +} + +void ParserWarning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning :%s:%d: %s\n", crtFile, crtLine, buf ); + nWarning++; +} + +void Error( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Error : %s\n", buf ); + nError++; +} + +void Warning( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "Warning : %s\n", buf ); + nWarning++; +} + +void Message( char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, " Message :%s:%d: %s\n", crt_filename, crt_line_no, buf ); +} + +void FatalError( int status, char *fmt, ... ) +{ +Va_list args; +char buf[ MAX_BUFFER ]; + + Va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + fprintf( stdout, "\nFatal error : %s\nProgram aborted\n", buf ); + exit(status); +} + +char * FileName( char *fname, char *env, char *dir, char *ext ) +{ +static char pathname[MAX_PATH]; +char *path; +char *crtpath; +char *p; +FILE *fp; +static char name[MAX_PATH]; +int noext; + + strcpy(name, fname); + p = name + strlen(name); + noext = 1; + while( p > name ) { + if( *p == '.') { + noext = 0; + break; + } + if( *p == '/' ) break; + p--; + } + + if( noext ) strcat(name, ext); + + fp = fopen(name,"r"); + if( fp ) { + fclose(fp); + return name; + } + + path = getenv(env); + if( path ) { + crtpath = path; + p = pathname; + while( 1 ) { + if( isspace(*crtpath) ) { + crtpath++; + continue; + } + if((*crtpath == ':')||(*crtpath==0)) { + *p = 0; + sprintf(pathname,"%s/%s",pathname,name); + fp = fopen(pathname,"r"); + if( fp ) { + fclose(fp); + return pathname; + } + if (*crtpath==0) break; + crtpath++; + p = pathname; + continue; + } + *p++ = *crtpath++; + } + } + + sprintf(pathname, "%s/%s/%s", Home, dir, name); + fp = fopen(pathname,"r"); + if( fp ) { + fclose(fp); + return pathname; + } + + return name; +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.c new file mode 100755 index 00000000..c4ce97ec --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.c @@ -0,0 +1,1726 @@ +#ifndef lint +/*static char yysccsid[] = "from: @(#)yaccpar 1.9 (Berkeley) 02/21/93";*/ +static char yyrcsid[] = "$Id: skeleton.c,v 1.4 1993/12/21 18:45:32 jtc Exp $"; +#endif +#define YYBYACC 1 +#define YYMAJOR 1 +#define YYMINOR 9 +#define yyclearin (yychar=(-1)) +#define yyerrok (yyerrflag=0) +#define YYRECOVERING (yyerrflag!=0) +#define YYPREFIX "yy" +#line 35 "scan.y" + #include + #include + #include + #include + #include + #include "scan.h" + + #define __YYSCLASS + + #define YYDEBUG 1 + extern char yytext[]; + extern FILE * yyin; + + int nError = 0; + int nWarning = 0; + + int crt_section; + int eqState; + int isPhoto = 0; + + char crt_term[ 30 ]; + char crt_coef[ 30 ]; + + char * InlineBuf; + int InlineLen; + + void SemicolonError(); + extern int yyerrflag; + +#line 66 "scan.y" +typedef union{ + char str[80]; +} YYSTYPE; +#line 47 "y.tab.c" +#define JACOBIAN 257 +#define DOUBLE 258 +#define FUNCTION 259 +#define DEFVAR 260 +#define DEFRAD 261 +#define DEFFIX 262 +#define SETVAR 263 +#define SETRAD 264 +#define SETFIX 265 +#define HESSIAN 266 +#define STOICMAT 267 +#define STOCHASTIC 268 +#define INITVALUES 269 +#define EQUATIONS 270 +#define LUMP 271 +#define INIEQUAL 272 +#define EQNEQUAL 273 +#define EQNCOLON 274 +#define LMPCOLON 275 +#define LMPPLUS 276 +#define SPCPLUS 277 +#define SPCEQUAL 278 +#define ATOMDECL 279 +#define CHECK 280 +#define CHECKALL 281 +#define REORDER 282 +#define MEX 283 +#define DUMMYINDEX 284 +#define EQNTAGS 285 +#define LOOKAT 286 +#define LOOKATALL 287 +#define TRANSPORT 288 +#define TRANSPORTALL 289 +#define MONITOR 290 +#define USES 291 +#define SPARSEDATA 292 +#define WRFCONFORM 293 +#define WRITE_ATM 294 +#define WRITE_SPC 295 +#define WRITE_MAT 296 +#define WRITE_OPT 297 +#define INITIALIZE 298 +#define XGRID 299 +#define YGRID 300 +#define ZGRID 301 +#define USE 302 +#define LANGUAGE 303 +#define INTFILE 304 +#define DRIVER 305 +#define RUN 306 +#define INLINE 307 +#define ENDINLINE 308 +#define PARAMETER 309 +#define SPCSPC 310 +#define INISPC 311 +#define INIVALUE 312 +#define EQNSPC 313 +#define EQNSIGN 314 +#define EQNCOEF 315 +#define RATE 316 +#define LMPSPC 317 +#define SPCNR 318 +#define ATOMID 319 +#define LKTID 320 +#define MNIID 321 +#define INLCTX 322 +#define INCODE 323 +#define SSPID 324 +#define EQNLESS 325 +#define EQNTAG 326 +#define EQNGREATER 327 +#define TPTID 328 +#define USEID 329 +#define YYERRCODE 256 +short yylhs[] = { -1, + 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 15, 15, 4, + 4, 4, 16, 10, 10, 10, 17, 11, 11, 11, + 18, 12, 12, 12, 19, 14, 14, 14, 20, 6, + 6, 6, 21, 5, 5, 5, 22, 22, 23, 24, + 25, 25, 26, 26, 7, 7, 7, 27, 8, 8, + 8, 28, 28, 1, 1, 2, 29, 30, 31, 31, + 31, 32, 32, 9, 9, 9, 33, 33, 13, 13, +}; +short yylen[] = { 2, + 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, + 1, 1, 1, 2, 2, 2, 2, 2, 2, 4, + 2, 2, 2, 2, 2, 2, 1, 2, 1, 3, + 2, 2, 1, 3, 2, 2, 1, 3, 2, 2, + 1, 3, 2, 2, 1, 3, 2, 2, 1, 3, + 2, 2, 1, 3, 2, 2, 1, 1, 3, 1, + 3, 1, 2, 1, 3, 2, 2, 3, 3, 2, + 2, 4, 3, 2, 1, 3, 2, 2, 3, 2, + 1, 2, 1, 3, 2, 2, 3, 3, 2, 1, +}; +short yydefred[] = { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 27, 0, 0, + 0, 0, 0, 28, 0, 29, 0, 0, 0, 47, + 30, 31, 32, 33, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 3, 6, 11, 0, + 0, 0, 0, 77, 78, 0, 0, 0, 73, 0, + 0, 0, 0, 4, 5, 12, 0, 0, 0, 0, + 0, 103, 0, 0, 0, 0, 0, 0, 0, 0, + 101, 0, 0, 0, 0, 0, 53, 0, 0, 0, + 7, 8, 9, 10, 0, 57, 0, 0, 0, 65, + 0, 0, 0, 61, 0, 0, 0, 69, 0, 0, + 46, 36, 37, 38, 39, 34, 35, 42, 43, 44, + 41, 0, 2, 49, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 100, 102, 0, 0, + 0, 0, 0, 0, 97, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 110, 0, 48, 84, + 0, 0, 82, 0, 0, 88, 0, 96, 0, 0, + 0, 93, 98, 99, 108, 107, 0, 0, 0, 0, + 0, 0, 40, 109, 83, 0, 92, 94, 81, +}; +short yydgoto[] = { 45, + 182, 76, 46, 88, 52, 60, 69, 77, 84, 97, + 105, 101, 168, 109, 125, 89, 98, 106, 102, 110, + 61, 53, 54, 55, 172, 173, 70, 78, 79, 143, + 80, 81, 85, +}; +short yysindex[] = { -124, + -285, -278, -271, -240, -240, -240, -253, -253, -253, -226, + -213, -212, -243, -249, -248, -237, -237, 0, -211, -210, + -209, -207, -246, 0, -251, 0, -242, -256, -204, 0, + 0, 0, 0, 0, -203, -201, -200, -198, -197, -195, + -194, -192, -191, -250, 0, -124, 0, 0, 0, -3, + -219, -190, -3, 0, 0, -190, -190, -3, 0, -261, + -3, -261, -261, 0, 0, 0, -3, -153, -189, -3, + -3, 0, -288, -188, -205, -227, -270, -3, -227, -247, + 0, -3, -228, -193, -3, -3, 0, -196, -3, -196, + 0, 0, 0, 0, -3, 0, -172, -3, -3, 0, + -202, -3, -3, 0, -171, -3, -3, 0, -199, -3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, -174, 0, 0, 68, -290, -3, 68, 68, -3, + 68, 68, -184, -3, 68, 68, 0, 0, -176, -227, + -3, 68, -187, -263, 0, -288, 68, -186, -193, -3, + 68, 68, -3, 68, 68, -3, 68, 68, -3, 68, + 68, -3, 68, 68, -3, 68, 0, -291, 0, 0, + -178, -125, 0, 68, 68, 0, 68, 0, -187, 68, + -187, 0, 0, 0, 0, 0, 68, 68, 68, 68, + 68, 68, 0, 0, 0, -290, 0, 0, 0, +}; +short yyrindex[] = { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 153, 0, 0, 0, 0, + 125, 1977, 0, 0, 0, 2041, 2102, 0, 0, 2163, + 0, 2224, 2285, 0, 0, 0, 0, 0, 2349, 0, + 0, 0, 0, 0, 0, 0, 2410, 0, 0, 0, + 0, 0, 0, 2471, 0, 0, 0, 2532, 0, 2593, + 0, 0, 0, 0, 0, 0, 2657, 0, 0, 0, + 2718, 0, 0, 0, 2779, 0, 0, 0, 2840, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1794, 0, 0, 1855, 600, 0, + 651, 1608, 0, 0, 1669, 328, 0, 0, 0, 0, + 0, 426, 0, 0, 0, 0, 1425, 0, 0, 0, + 1486, 1231, 0, 1297, 1025, 0, 1089, 154, 0, 205, + 753, 0, 836, 1, 0, 52, 0, 0, 0, 0, + 0, 126, 0, 1916, 702, 0, 1733, 0, 0, 528, + 127, 0, 0, 0, 0, 0, 1547, 1361, 1153, 256, + 923, 103, 0, 0, 0, 0, 0, 0, 0, +}; +short yygindex[] = { 141, + -119, 0, 0, 171, 84, 86, 0, 0, 0, 0, + 0, 0, 0, 0, -49, 3, 92, 85, 90, 83, + -21, -22, 0, 0, 0, -2, 124, 118, 120, 57, + -56, -71, -69, +}; +#define YYTABLESIZE 3147 +short yytable[] = { 107, + 68, 137, 58, 128, 99, 121, 71, 82, 129, 95, + 183, 131, 67, 103, 150, 50, 193, 132, 86, 170, + 135, 136, 144, 47, 72, 145, 74, 171, 142, 127, + 48, 194, 147, 127, 127, 151, 152, 49, 130, 154, + 130, 130, 72, 73, 74, 155, 148, 149, 157, 158, + 146, 67, 160, 161, 75, 124, 163, 164, 126, 197, + 166, 198, 59, 72, 73, 74, 146, 68, 83, 51, + 59, 122, 108, 96, 184, 75, 100, 174, 104, 186, + 175, 87, 64, 144, 177, 72, 73, 74, 56, 57, + 153, 180, 153, 62, 63, 65, 66, 91, 92, 93, + 187, 94, 66, 188, 111, 112, 189, 113, 114, 190, + 115, 116, 191, 117, 118, 192, 119, 120, 133, 51, + 139, 68, 87, 83, 138, 100, 169, 176, 181, 108, + 185, 195, 1, 2, 3, 4, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 96, 167, 104, + 178, 196, 1, 64, 16, 17, 18, 19, 20, 21, + 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, + 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, + 42, 43, 44, 80, 79, 95, 123, 90, 156, 162, + 159, 165, 134, 199, 141, 140, 179, 0, 0, 0, + 0, 0, 0, 0, 63, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 62, 0, 68, 68, 68, + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, + 68, 68, 0, 0, 0, 0, 0, 0, 0, 68, + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, + 68, 68, 68, 68, 68, 68, 68, 68, 68, 68, + 68, 68, 68, 68, 68, 68, 68, 68, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 0, 0, 0, 0, 91, 0, 68, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 67, + 67, 67, 67, 67, 67, 67, 67, 67, 67, 66, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 0, 0, 0, 0, 0, 0, + 67, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 66, 66, 66, 66, 66, 66, 66, 66, 66, 66, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 90, 0, 0, 0, 0, + 0, 66, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 63, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 63, 63, 63, 63, 0, 0, 0, 0, + 0, 64, 0, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, + 63, 63, 62, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 62, 62, 62, 62, 89, 0, 0, + 0, 0, 63, 0, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 62, 62, 62, 62, 62, 62, 62, + 62, 62, 62, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 62, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 72, + 0, 0, 0, 0, 0, 0, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 0, 0, 0, 0, 0, + 91, 91, 91, 0, 0, 0, 0, 0, 0, 0, + 71, 0, 91, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 0, 0, 0, + 0, 70, 0, 0, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 0, 0, 0, 0, 0, 90, 90, + 90, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 90, 0, 60, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 89, 89, 89, 0, + 0, 0, 0, 0, 0, 0, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 89, 89, 89, 89, 89, + 89, 89, 89, 89, 89, 59, 0, 0, 0, 0, + 89, 89, 89, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 89, 0, 0, 0, 72, 72, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + 72, 0, 0, 0, 0, 0, 0, 0, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 71, 71, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, + 71, 71, 58, 72, 0, 0, 0, 0, 0, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 71, 71, + 71, 71, 71, 71, 71, 71, 71, 71, 70, 70, + 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 0, 71, 0, 0, 0, 0, 0, + 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 70, 70, 70, 70, 70, 70, 70, + 70, 70, 70, 70, 70, 70, 70, 70, 70, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 56, 70, 0, 0, 0, 0, + 0, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 60, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 55, 0, + 0, 0, 59, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 0, 0, 0, + 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 59, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 54, 0, 0, 0, 59, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 58, + 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 58, 58, 58, 0, 0, 0, 0, 0, 0, + 0, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 58, 58, 58, 58, 58, 58, 58, 58, 58, 58, + 52, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 58, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 51, 0, 0, 0, + 0, 0, 0, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 56, 55, 55, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 55, 55, 55, 55, + 50, 0, 0, 0, 0, 0, 0, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 55, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 55, 55, 55, 55, + 55, 55, 55, 55, 55, 55, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 55, 54, + 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 54, 54, 54, 106, 0, 0, 0, 0, 0, + 0, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 54, 54, 54, 54, 54, 54, 54, 54, 54, 54, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 54, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 105, 0, 52, 52, 52, + 52, 52, 52, 52, 52, 52, 52, 52, 52, 52, + 52, 52, 0, 0, 0, 0, 0, 0, 0, 52, + 52, 52, 52, 52, 52, 52, 52, 52, 52, 52, + 52, 52, 52, 52, 52, 52, 52, 52, 52, 52, + 52, 52, 52, 52, 52, 52, 52, 52, 0, 0, + 0, 0, 0, 0, 0, 0, 104, 0, 0, 52, + 0, 0, 0, 51, 51, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 51, 0, 0, + 0, 0, 0, 0, 0, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, + 51, 51, 51, 51, 0, 0, 0, 87, 0, 0, + 0, 0, 0, 0, 0, 51, 0, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 0, 0, 0, 0, 0, 0, 0, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, + 50, 50, 50, 50, 50, 50, 50, 50, 86, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, + 0, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 0, 0, 0, 0, + 0, 0, 0, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 85, 0, 0, 0, 0, 0, 0, 0, + 0, 106, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 0, 0, 0, + 0, 0, 0, 0, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 76, 0, 0, 0, 0, 0, 0, + 0, 0, 105, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 0, 0, + 0, 0, 0, 0, 0, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 75, 0, 0, 0, 0, 0, + 0, 0, 0, 104, 87, 87, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 87, 87, 87, 87, 0, + 0, 0, 0, 0, 0, 0, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 74, 0, 0, 87, 0, + 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 15, 0, 0, 86, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 0, 0, 0, 0, 0, 0, + 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 16, 0, 0, 85, 0, 0, 0, 0, 0, 0, + 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, + 76, 76, 76, 76, 76, 0, 0, 0, 0, 0, + 0, 0, 76, 76, 76, 76, 76, 76, 76, 76, + 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, + 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, + 76, 17, 0, 76, 0, 0, 0, 0, 0, 0, + 0, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 0, 0, 0, 0, + 0, 0, 0, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 18, 0, 75, 0, 0, 0, 0, 0, + 0, 0, 74, 74, 74, 74, 74, 74, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 0, 0, 0, + 0, 0, 0, 0, 74, 74, 74, 74, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, + 74, 74, 74, 74, 74, 74, 74, 74, 74, 74, + 74, 74, 74, 19, 0, 74, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 20, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 0, 0, 0, 0, 0, 0, 0, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, 21, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 22, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, + 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 23, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 0, 0, 0, 0, 0, + 0, 0, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 13, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 20, 20, 20, 20, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 0, 0, 0, 0, + 0, 0, 0, 20, 20, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, + 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, + 20, 20, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 24, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 0, 0, 0, 0, 0, 0, 0, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 26, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 0, 0, 0, 0, 0, 0, 0, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 23, 23, + 23, 23, 23, 23, 23, 23, 23, 23, 25, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 0, 0, 0, 0, 0, 0, 0, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 45, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 0, 0, + 0, 0, 0, 0, 0, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 26, 26, 26, 26, 0, + 0, 0, 0, 0, 0, 0, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, + 26, 26, 26, 26, 26, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 0, 0, 0, 0, 0, 0, 0, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, + 25, 25, 25, 25, 25, 25, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 0, 0, 0, 0, 0, 0, 0, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, 45, 45, 45, + 45, 45, 45, 45, 45, 45, 45, +}; +short yycheck[] = { 256, + 0, 73, 256, 53, 256, 256, 256, 256, 58, 256, + 274, 61, 256, 256, 84, 256, 308, 67, 256, 310, + 70, 71, 79, 309, 313, 273, 315, 318, 78, 52, + 309, 323, 82, 56, 57, 85, 86, 309, 60, 89, + 62, 63, 313, 314, 315, 95, 275, 276, 98, 99, + 314, 0, 102, 103, 325, 59, 106, 107, 278, 179, + 110, 181, 324, 313, 314, 315, 314, 311, 317, 310, + 324, 322, 329, 320, 146, 325, 328, 127, 321, 149, + 130, 319, 309, 140, 134, 313, 314, 315, 5, 6, + 88, 141, 90, 8, 9, 309, 309, 309, 309, 309, + 150, 309, 0, 153, 309, 309, 156, 309, 309, 159, + 309, 309, 162, 309, 309, 165, 309, 309, 272, 310, + 326, 311, 319, 317, 313, 328, 59, 312, 316, 329, + 317, 310, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 320, 323, 321, + 327, 277, 0, 0, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, 59, 59, 59, 46, 17, 97, 105, + 101, 109, 69, 196, 77, 76, 140, -1, -1, -1, + -1, -1, -1, -1, 0, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 0, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, -1, -1, -1, 0, -1, 329, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + 329, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 0, -1, -1, -1, -1, + -1, 329, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, -1, -1, -1, -1, + -1, 328, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, 0, -1, -1, + -1, -1, 328, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 328, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, 0, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, -1, -1, + 313, 314, 315, -1, -1, -1, -1, -1, -1, -1, + 0, -1, 325, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, 0, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, 313, 314, + 315, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 325, -1, 0, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, 0, -1, -1, -1, -1, + 313, 314, 315, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 325, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, -1, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, 0, 324, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, 324, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 0, 324, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 321, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 0, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 0, -1, -1, -1, 321, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 321, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, 0, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 320, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + 0, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 320, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, 0, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 320, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 0, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, -1, -1, + -1, -1, -1, -1, -1, -1, 0, -1, -1, 319, + -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, -1, -1, -1, 0, -1, -1, + -1, -1, -1, -1, -1, 319, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 0, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 319, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, -1, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 0, -1, -1, -1, -1, -1, -1, -1, + -1, 317, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, 0, -1, -1, -1, -1, -1, -1, + -1, -1, 317, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, 0, -1, -1, -1, -1, -1, + -1, -1, -1, 317, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, 0, -1, -1, 311, -1, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + -1, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, 0, -1, -1, 311, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 0, -1, -1, 311, -1, -1, -1, -1, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, -1, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, 0, -1, 310, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, -1, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 0, -1, 310, -1, -1, -1, -1, -1, + -1, -1, 257, 258, 259, 260, 261, 262, 263, 264, + 265, 266, 267, 268, 269, 270, 271, -1, -1, -1, + -1, -1, -1, -1, 279, 280, 281, 282, 283, 284, + 285, 286, 287, 288, 289, 290, 291, 292, 293, 294, + 295, 296, 297, 298, 299, 300, 301, 302, 303, 304, + 305, 306, 307, 0, -1, 310, -1, -1, -1, -1, + -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, 0, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 0, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 0, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, -1, -1, -1, -1, -1, + -1, -1, 279, 280, 281, 282, 283, 284, 285, 286, + 287, 288, 289, 290, 291, 292, 293, 294, 295, 296, + 297, 298, 299, 300, 301, 302, 303, 304, 305, 306, + 307, 0, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 257, 258, 259, 260, 261, 262, 263, 264, 265, + 266, 267, 268, 269, 270, 271, -1, -1, -1, -1, + -1, -1, -1, 279, 280, 281, 282, 283, 284, 285, + 286, 287, 288, 289, 290, 291, 292, 293, 294, 295, + 296, 297, 298, 299, 300, 301, 302, 303, 304, 305, + 306, 307, 0, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + -1, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, 0, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, -1, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, 0, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 257, 258, 259, + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, + 270, 271, -1, -1, -1, -1, -1, -1, -1, 279, + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, + 300, 301, 302, 303, 304, 305, 306, 307, 0, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 257, 258, + 259, 260, 261, 262, 263, 264, 265, 266, 267, 268, + 269, 270, 271, -1, -1, -1, -1, -1, -1, -1, + 279, 280, 281, 282, 283, 284, 285, 286, 287, 288, + 289, 290, 291, 292, 293, 294, 295, 296, 297, 298, + 299, 300, 301, 302, 303, 304, 305, 306, 307, 0, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 257, + 258, 259, 260, 261, 262, 263, 264, 265, 266, 267, + 268, 269, 270, 271, -1, -1, -1, -1, -1, -1, + -1, 279, 280, 281, 282, 283, 284, 285, 286, 287, + 288, 289, 290, 291, 292, 293, 294, 295, 296, 297, + 298, 299, 300, 301, 302, 303, 304, 305, 306, 307, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 257, 258, 259, 260, 261, 262, 263, + 264, 265, 266, 267, 268, 269, 270, 271, -1, -1, + -1, -1, -1, -1, -1, 279, 280, 281, 282, 283, + 284, 285, 286, 287, 288, 289, 290, 291, 292, 293, + 294, 295, 296, 297, 298, 299, 300, 301, 302, 303, + 304, 305, 306, 307, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 257, 258, 259, 260, 261, 262, + 263, 264, 265, 266, 267, 268, 269, 270, 271, -1, + -1, -1, -1, -1, -1, -1, 279, 280, 281, 282, + 283, 284, 285, 286, 287, 288, 289, 290, 291, 292, + 293, 294, 295, 296, 297, 298, 299, 300, 301, 302, + 303, 304, 305, 306, 307, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 257, 258, 259, 260, 261, + 262, 263, 264, 265, 266, 267, 268, 269, 270, 271, + -1, -1, -1, -1, -1, -1, -1, 279, 280, 281, + 282, 283, 284, 285, 286, 287, 288, 289, 290, 291, + 292, 293, 294, 295, 296, 297, 298, 299, 300, 301, + 302, 303, 304, 305, 306, 307, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 257, 258, 259, 260, + 261, 262, 263, 264, 265, 266, 267, 268, 269, 270, + 271, -1, -1, -1, -1, -1, -1, -1, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 289, 290, + 291, 292, 293, 294, 295, 296, 297, 298, 299, 300, + 301, 302, 303, 304, 305, 306, 307, +}; +#define YYFINAL 45 +#ifndef YYDEBUG +#define YYDEBUG 0 +#endif +#define YYMAXTOKEN 329 +#if YYDEBUG +char *yyname[] = { +"end-of-file",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"';'",0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,"JACOBIAN","DOUBLE", +"FUNCTION","DEFVAR","DEFRAD","DEFFIX","SETVAR","SETRAD","SETFIX","HESSIAN", +"STOICMAT","STOCHASTIC","INITVALUES","EQUATIONS","LUMP","INIEQUAL","EQNEQUAL", +"EQNCOLON","LMPCOLON","LMPPLUS","SPCPLUS","SPCEQUAL","ATOMDECL","CHECK", +"CHECKALL","REORDER","MEX","DUMMYINDEX","EQNTAGS","LOOKAT","LOOKATALL", +"TRANSPORT","TRANSPORTALL","MONITOR","USES","SPARSEDATA","WRFCONFORM", +"WRITE_ATM","WRITE_SPC","WRITE_MAT","WRITE_OPT","INITIALIZE","XGRID","YGRID", +"ZGRID","USE","LANGUAGE","INTFILE","DRIVER","RUN","INLINE","ENDINLINE", +"PARAMETER","SPCSPC","INISPC","INIVALUE","EQNSPC","EQNSIGN","EQNCOEF","RATE", +"LMPSPC","SPCNR","ATOMID","LKTID","MNIID","INLCTX","INCODE","SSPID","EQNLESS", +"EQNTAG","EQNGREATER","TPTID","USEID", +}; +char *yyrule[] = { +"$accept : program", +"program : section", +"program : section program", +"section : JACOBIAN PARAMETER", +"section : HESSIAN PARAMETER", +"section : STOICMAT PARAMETER", +"section : DOUBLE PARAMETER", +"section : REORDER PARAMETER", +"section : MEX PARAMETER", +"section : DUMMYINDEX PARAMETER", +"section : EQNTAGS PARAMETER", +"section : FUNCTION PARAMETER", +"section : STOCHASTIC PARAMETER", +"section : ATOMDECL atomlist", +"section : CHECK atomlist", +"section : DEFVAR species", +"section : DEFRAD species", +"section : DEFFIX species", +"section : SETVAR setspclist", +"section : SETRAD setspclist", +"section : SETFIX setspclist", +"section : INITVALUES initvalues", +"section : EQUATIONS equations", +"section : LUMP lumps", +"section : LOOKAT lookatlist", +"section : MONITOR monitorlist", +"section : TRANSPORT translist", +"section : CHECKALL", +"section : LOOKATALL", +"section : TRANSPORTALL", +"section : WRITE_ATM", +"section : WRITE_SPC", +"section : WRITE_MAT", +"section : WRITE_OPT", +"section : USE PARAMETER", +"section : LANGUAGE PARAMETER", +"section : INITIALIZE PARAMETER", +"section : XGRID PARAMETER", +"section : YGRID PARAMETER", +"section : ZGRID PARAMETER", +"section : INLINE INLCTX inlinecode ENDINLINE", +"section : INLINE error", +"section : INTFILE PARAMETER", +"section : DRIVER PARAMETER", +"section : RUN PARAMETER", +"section : USES uselist", +"section : SPARSEDATA PARAMETER", +"section : WRFCONFORM", +"semicolon : semicolon ';'", +"semicolon : ';'", +"atomlist : atomlist atomdef semicolon", +"atomlist : atomdef semicolon", +"atomlist : error semicolon", +"atomdef : ATOMID", +"lookatlist : lookatlist lookatspc semicolon", +"lookatlist : lookatspc semicolon", +"lookatlist : error semicolon", +"lookatspc : LKTID", +"monitorlist : monitorlist monitorspc semicolon", +"monitorlist : monitorspc semicolon", +"monitorlist : error semicolon", +"monitorspc : MNIID", +"translist : translist transspc semicolon", +"translist : transspc semicolon", +"translist : error semicolon", +"transspc : TPTID", +"uselist : uselist usefile semicolon", +"uselist : usefile semicolon", +"uselist : error semicolon", +"usefile : USEID", +"setspclist : setspclist setspcspc semicolon", +"setspclist : setspcspc semicolon", +"setspclist : error semicolon", +"setspcspc : SSPID", +"species : species spc semicolon", +"species : spc semicolon", +"species : error semicolon", +"spc : spcname", +"spc : spcdef", +"spcname : SPCSPC SPCEQUAL atoms", +"spcdef : SPCSPC", +"atoms : atoms SPCPLUS atom", +"atoms : atom", +"atom : SPCNR SPCSPC", +"atom : SPCSPC", +"initvalues : initvalues assignment semicolon", +"initvalues : assignment semicolon", +"initvalues : error semicolon", +"assignment : INISPC INIEQUAL INIVALUE", +"equations : equations equation semicolon", +"equations : equation semicolon", +"equations : error semicolon", +"equation : eqntag lefths righths rate", +"equation : lefths righths rate", +"rate : RATE rate", +"rate : RATE", +"eqntag : EQNLESS EQNTAG EQNGREATER", +"lefths : expresion EQNEQUAL", +"righths : expresion EQNCOLON", +"expresion : expresion EQNSIGN term", +"expresion : EQNSIGN term", +"expresion : term", +"term : EQNCOEF EQNSPC", +"term : EQNSPC", +"lumps : lumps lump semicolon", +"lumps : lump semicolon", +"lumps : error semicolon", +"lump : LMPSPC LMPPLUS lump", +"lump : LMPSPC LMPCOLON LMPSPC", +"inlinecode : inlinecode INCODE", +"inlinecode : INCODE", +}; +#endif +#ifdef YYSTACKSIZE +#undef YYMAXDEPTH +#define YYMAXDEPTH YYSTACKSIZE +#else +#ifdef YYMAXDEPTH +#define YYSTACKSIZE YYMAXDEPTH +#else +#define YYSTACKSIZE 500 +#define YYMAXDEPTH 500 +#endif +#endif +int yydebug; +int yynerrs; +int yyerrflag; +int yychar; +short *yyssp; +YYSTYPE *yyvsp; +YYSTYPE yyval; +YYSTYPE yylval; +short yyss[YYSTACKSIZE]; +YYSTYPE yyvs[YYSTACKSIZE]; +#define yystacksize YYSTACKSIZE +#line 387 "scan.y" + +void yyerror( char * str ) +{ +} + +void ParserErrorMessage() +{ + yyerrok; +/* + Message("[%d,%s] -> [%d,%s]", crtTokType, crtToken, nextTokType, nextToken ); +*/ + if( crtToken[0] == ';' ) { + ParserError("Misplaced ';'"); + return; + } + switch( crtTokType ) { + case ATOMID: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case SPCSPC: + ParserError("Missing ';' or '+' after '%s'", crtToken ); + break; + case SPCNR: + ParserError("Missing species after '%s'", crtToken ); + break; + case SPCPLUS: + ParserError("Missing atom after '%s'", crtToken ); + break; + case SPCEQUAL: + ParserError("Invalid '=' after '%s'", crtToken ); + break; + + case INISPC: + ParserError("Missing '=' after '%s'", crtToken ); + break; + case INIEQUAL: + ParserError("Missing value after '%s'", crtToken ); + break; + case INIVALUE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case EQNSPC: + ParserError("Missing '+' or '=' after '%s'", crtToken ); + break; + case EQNEQUAL: + ParserError("Invalid right hand side of equation"); + break; + case EQNCOLON: + ParserError("Missing rate after '%s'", crtToken ); + break; + case EQNSIGN: + ParserError("Missing coeficient after '%s'", crtToken ); + break; + case EQNCOEF: + ParserError("Missing species after '%s'", crtToken ); + break; + case RATE: + ParserError("Missing ';' after '%s'", crtToken ); + break; + + case LMPSPC: + ParserError("Missing '+' or ':' or ';' after '%s'", crtToken ); + break; + case LMPPLUS: + ParserError("Missing species after '%s'", crtToken ); + break; + case LMPCOLON: + ParserError("Missing species after '%s'", crtToken ); + break; + case INLINE: + ParserError("Missing inline option after '%s'", crtToken ); + break; + + default: + ParserError("Syntax error after '%s'", crtToken ); + } +} + + +int Parser( char * filename ) +{ +extern int yydebug; +FILE *f; + + crt_filename = filename; + + f = fopen( crt_filename, "r" ); + if( f == 0 ) { + FatalError(7,"%s: File not found", crt_filename); + } + + yyin = f; + nError = 0; + nWarning = 0; + yydebug = 0; + + yyparse(); + + fclose( f ); + + return nError; +} + +#line 1128 "y.tab.c" +#define YYABORT goto yyabort +#define YYREJECT goto yyabort +#define YYACCEPT goto yyaccept +#define YYERROR goto yyerrlab +int +#if defined(__STDC__) +yyparse(void) +#else +yyparse() +#endif +{ + register int yym, yyn, yystate; +#if YYDEBUG + register char *yys; + extern char *getenv(); + + if (yys = getenv("YYDEBUG")) + { + yyn = *yys; + if (yyn >= '0' && yyn <= '9') + yydebug = yyn - '0'; + } +#endif + + yynerrs = 0; + yyerrflag = 0; + yychar = (-1); + + yyssp = yyss; + yyvsp = yyvs; + *yyssp = yystate = 0; + +yyloop: + if ((yyn = yydefred[yystate]) != 0) goto yyreduce; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + } + if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, shifting to state %d\n", + YYPREFIX, yystate, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + yychar = (-1); + if (yyerrflag > 0) --yyerrflag; + goto yyloop; + } + if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yychar) + { + yyn = yytable[yyn]; + goto yyreduce; + } + if (yyerrflag) goto yyinrecovery; + yyerror("syntax error"); +#ifdef lint + goto yyerrlab; +#endif +yyerrlab: + ++yynerrs; +yyinrecovery: + if (yyerrflag < 3) + { + yyerrflag = 3; + for (;;) + { + if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, error recovery shifting\ + to state %d\n", YYPREFIX, *yyssp, yytable[yyn]); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate = yytable[yyn]; + *++yyvsp = yylval; + goto yyloop; + } + else + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: error recovery discarding state %d\n", + YYPREFIX, *yyssp); +#endif + if (yyssp <= yyss) goto yyabort; + --yyssp; + --yyvsp; + } + } + } + else + { + if (yychar == 0) goto yyabort; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, error recovery discards token %d (%s)\n", + YYPREFIX, yystate, yychar, yys); + } +#endif + yychar = (-1); + goto yyloop; + } +yyreduce: +#if YYDEBUG + if (yydebug) + printf("%sdebug: state %d, reducing by rule %d (%s)\n", + YYPREFIX, yystate, yyn, yyrule[yyn]); +#endif + yym = yylen[yyn]; + yyval = yyvsp[1-yym]; + switch (yyn) + { +case 3: +#line 95 "scan.y" +{ CmdJacobian( yyvsp[0].str ); + } +break; +case 4: +#line 98 "scan.y" +{ CmdHessian( yyvsp[0].str ); + } +break; +case 5: +#line 101 "scan.y" +{ CmdStoicmat( yyvsp[0].str ); + } +break; +case 6: +#line 104 "scan.y" +{ CmdDouble( yyvsp[0].str ); + } +break; +case 7: +#line 107 "scan.y" +{ CmdReorder( yyvsp[0].str ); + } +break; +case 8: +#line 110 "scan.y" +{ CmdMex( yyvsp[0].str ); + } +break; +case 9: +#line 113 "scan.y" +{ CmdDummyindex( yyvsp[0].str ); + } +break; +case 10: +#line 116 "scan.y" +{ CmdEqntags( yyvsp[0].str ); + } +break; +case 11: +#line 119 "scan.y" +{ CmdFunction( yyvsp[0].str ); + } +break; +case 12: +#line 122 "scan.y" +{ CmdStochastic( yyvsp[0].str ); + } +break; +case 13: +#line 125 "scan.y" +{} +break; +case 14: +#line 127 "scan.y" +{} +break; +case 15: +#line 129 "scan.y" +{} +break; +case 16: +#line 131 "scan.y" +{} +break; +case 17: +#line 133 "scan.y" +{} +break; +case 18: +#line 135 "scan.y" +{} +break; +case 19: +#line 137 "scan.y" +{} +break; +case 20: +#line 139 "scan.y" +{} +break; +case 21: +#line 141 "scan.y" +{} +break; +case 22: +#line 143 "scan.y" +{} +break; +case 23: +#line 145 "scan.y" +{} +break; +case 24: +#line 147 "scan.y" +{} +break; +case 25: +#line 149 "scan.y" +{} +break; +case 26: +#line 151 "scan.y" +{} +break; +case 27: +#line 153 "scan.y" +{ CheckAll(); } +break; +case 28: +#line 155 "scan.y" +{ LookAtAll(); } +break; +case 29: +#line 157 "scan.y" +{ TransportAll(); } +break; +case 30: +#line 159 "scan.y" +{ WriteAtoms(); } +break; +case 31: +#line 161 "scan.y" +{ WriteSpecies(); } +break; +case 32: +#line 163 "scan.y" +{ WriteMatrices(); } +break; +case 33: +#line 165 "scan.y" +{ WriteOptions(); } +break; +case 34: +#line 167 "scan.y" +{ CmdUse( yyvsp[0].str ); } +break; +case 35: +#line 169 "scan.y" +{ CmdLanguage( yyvsp[0].str ); } +break; +case 36: +#line 171 "scan.y" +{ DefineInitializeNbr( yyvsp[0].str ); } +break; +case 37: +#line 173 "scan.y" +{ DefineXGrid( yyvsp[0].str ); } +break; +case 38: +#line 175 "scan.y" +{ DefineYGrid( yyvsp[0].str ); } +break; +case 39: +#line 177 "scan.y" +{ DefineZGrid( yyvsp[0].str ); } +break; +case 40: +#line 179 "scan.y" +{ + AddInlineCode( yyvsp[-2].str, InlineBuf ); + free( InlineBuf ); + } +break; +case 41: +#line 184 "scan.y" +{ ParserErrorMessage(); } +break; +case 42: +#line 186 "scan.y" +{ CmdIntegrator( yyvsp[0].str ); } +break; +case 43: +#line 188 "scan.y" +{ CmdDriver( yyvsp[0].str ); } +break; +case 44: +#line 190 "scan.y" +{ CmdRun( yyvsp[0].str ); } +break; +case 45: +#line 192 "scan.y" +{} +break; +case 46: +#line 194 "scan.y" +{ SparseData( yyvsp[0].str ); + } +break; +case 47: +#line 197 "scan.y" +{ WRFConform(); + } +break; +case 48: +#line 201 "scan.y" +{ ScanWarning("Unnecessary ';'"); + } +break; +case 52: +#line 208 "scan.y" +{ ParserErrorMessage(); } +break; +case 53: +#line 211 "scan.y" +{ switch( crt_section ) { + case ATOMDECL: DeclareAtom( yyvsp[0].str ); break; + case CHECK: SetAtomType( yyvsp[0].str, DO_CHECK ); break; + } + } +break; +case 56: +#line 220 "scan.y" +{ ParserErrorMessage(); } +break; +case 57: +#line 223 "scan.y" +{ AddLookAt( yyvsp[0].str ); + } +break; +case 60: +#line 229 "scan.y" +{ ParserErrorMessage(); } +break; +case 61: +#line 232 "scan.y" +{ AddMonitor( yyvsp[0].str ); + } +break; +case 64: +#line 238 "scan.y" +{ ParserErrorMessage(); } +break; +case 65: +#line 241 "scan.y" +{ AddTransport( yyvsp[0].str ); + } +break; +case 68: +#line 247 "scan.y" +{ ParserErrorMessage(); } +break; +case 69: +#line 250 "scan.y" +{ AddUseFile( yyvsp[0].str ); + } +break; +case 72: +#line 256 "scan.y" +{ ParserErrorMessage(); } +break; +case 73: +#line 259 "scan.y" +{ switch( crt_section ) { + case SETVAR: SetSpcType( VAR_SPC, yyvsp[0].str ); break; + case SETRAD: SetSpcType( RAD_SPC, yyvsp[0].str ); break; + case SETFIX: SetSpcType( FIX_SPC, yyvsp[0].str ); break; + } + } +break; +case 76: +#line 269 "scan.y" +{ ParserErrorMessage(); } +break; +case 79: +#line 275 "scan.y" +{ switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, yyvsp[-2].str ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, yyvsp[-2].str ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, yyvsp[-2].str ); break; + } + } +break; +case 80: +#line 283 "scan.y" +{ switch( crt_section ) { + case DEFVAR: DeclareSpecies( VAR_SPC, yyvsp[0].str ); break; + case DEFRAD: DeclareSpecies( RAD_SPC, yyvsp[0].str ); break; + case DEFFIX: DeclareSpecies( FIX_SPC, yyvsp[0].str ); break; + } + } +break; +case 83: +#line 294 "scan.y" +{ AddAtom( yyvsp[0].str, yyvsp[-1].str ); + } +break; +case 84: +#line 297 "scan.y" +{ AddAtom( yyvsp[0].str, "1" ); + } +break; +case 87: +#line 303 "scan.y" +{ ParserErrorMessage(); } +break; +case 88: +#line 306 "scan.y" +{ AssignInitialValue( yyvsp[-2].str, yyvsp[0].str ); } +break; +case 91: +#line 311 "scan.y" +{ ParserErrorMessage(); + eqState = LHS; + } +break; +case 92: +#line 316 "scan.y" +{ eqState = LHS; + StoreEquationRate( yyvsp[0].str, yyvsp[-3].str ); + CheckEquation(); + } +break; +case 93: +#line 321 "scan.y" +{ eqState = LHS; + StoreEquationRate( yyvsp[0].str, " " ); + CheckEquation(); + } +break; +case 94: +#line 326 "scan.y" +{ strcpy( yyval.str, yyvsp[-1].str ); + strcat( yyval.str, yyvsp[0].str ); + } +break; +case 95: +#line 330 "scan.y" +{ strcpy( yyval.str, yyvsp[0].str ); + } +break; +case 96: +#line 334 "scan.y" +{ strcpy( yyval.str, yyvsp[-1].str ); + } +break; +case 97: +#line 338 "scan.y" +{ eqState = RHS; } +break; +case 98: +#line 341 "scan.y" +{ eqState = RAT; } +break; +case 99: +#line 344 "scan.y" +{ ProcessTerm( eqState, yyvsp[-1].str, crt_coef, crt_term ); + } +break; +case 100: +#line 347 "scan.y" +{ ProcessTerm( eqState, yyvsp[-1].str, crt_coef, crt_term ); + } +break; +case 101: +#line 350 "scan.y" +{ ProcessTerm( eqState, "+", crt_coef, crt_term ); + } +break; +case 102: +#line 354 "scan.y" +{ strcpy( crt_term, yyvsp[0].str ); + strcpy( crt_coef, yyvsp[-1].str ); + } +break; +case 103: +#line 358 "scan.y" +{ strcpy( crt_term, yyvsp[0].str ); + strcpy( crt_coef, "1" ); + } +break; +case 106: +#line 365 "scan.y" +{ ParserErrorMessage(); } +break; +case 107: +#line 368 "scan.y" +{ AddLumpSpecies( yyvsp[-2].str ); + } +break; +case 108: +#line 371 "scan.y" +{ + AddLumpSpecies( yyvsp[-2].str ); + CheckLump( yyvsp[0].str ); + } +break; +case 109: +#line 376 "scan.y" +{ + InlineBuf = AppendString( InlineBuf, yyvsp[0].str, &InlineLen, MAX_INLINE ); + } +break; +case 110: +#line 380 "scan.y" +{ + InlineBuf = malloc( MAX_INLINE ); + InlineLen = MAX_INLINE; + strcpy( InlineBuf, yyvsp[0].str); + } +break; +#line 1671 "y.tab.c" + } + yyssp -= yym; + yystate = *yyssp; + yyvsp -= yym; + yym = yylhs[yyn]; + if (yystate == 0 && yym == 0) + { +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state 0 to\ + state %d\n", YYPREFIX, YYFINAL); +#endif + yystate = YYFINAL; + *++yyssp = YYFINAL; + *++yyvsp = yyval; + if (yychar < 0) + { + if ((yychar = yylex()) < 0) yychar = 0; +#if YYDEBUG + if (yydebug) + { + yys = 0; + if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; + if (!yys) yys = "illegal-symbol"; + printf("%sdebug: state %d, reading %d (%s)\n", + YYPREFIX, YYFINAL, yychar, yys); + } +#endif + } + if (yychar == 0) goto yyaccept; + goto yyloop; + } + if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 && + yyn <= YYTABLESIZE && yycheck[yyn] == yystate) + yystate = yytable[yyn]; + else + yystate = yydgoto[yym]; +#if YYDEBUG + if (yydebug) + printf("%sdebug: after reduction, shifting from state %d \ +to state %d\n", YYPREFIX, *yyssp, yystate); +#endif + if (yyssp >= yyss + yystacksize - 1) + { + goto yyoverflow; + } + *++yyssp = yystate; + *++yyvsp = yyval; + goto yyloop; +yyoverflow: + yyerror("yacc stack overflow"); +yyabort: + return (1); +yyaccept: + return (0); +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.h new file mode 100755 index 00000000..d60aacb6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/y.tab.h @@ -0,0 +1,77 @@ +#define JACOBIAN 257 +#define DOUBLE 258 +#define FUNCTION 259 +#define DEFVAR 260 +#define DEFRAD 261 +#define DEFFIX 262 +#define SETVAR 263 +#define SETRAD 264 +#define SETFIX 265 +#define HESSIAN 266 +#define STOICMAT 267 +#define STOCHASTIC 268 +#define INITVALUES 269 +#define EQUATIONS 270 +#define LUMP 271 +#define INIEQUAL 272 +#define EQNEQUAL 273 +#define EQNCOLON 274 +#define LMPCOLON 275 +#define LMPPLUS 276 +#define SPCPLUS 277 +#define SPCEQUAL 278 +#define ATOMDECL 279 +#define CHECK 280 +#define CHECKALL 281 +#define REORDER 282 +#define MEX 283 +#define DUMMYINDEX 284 +#define EQNTAGS 285 +#define LOOKAT 286 +#define LOOKATALL 287 +#define TRANSPORT 288 +#define TRANSPORTALL 289 +#define MONITOR 290 +#define USES 291 +#define SPARSEDATA 292 +#define WRFCONFORM 293 +#define WRITE_ATM 294 +#define WRITE_SPC 295 +#define WRITE_MAT 296 +#define WRITE_OPT 297 +#define INITIALIZE 298 +#define XGRID 299 +#define YGRID 300 +#define ZGRID 301 +#define USE 302 +#define LANGUAGE 303 +#define INTFILE 304 +#define DRIVER 305 +#define RUN 306 +#define INLINE 307 +#define ENDINLINE 308 +#define PARAMETER 309 +#define SPCSPC 310 +#define INISPC 311 +#define INIVALUE 312 +#define EQNSPC 313 +#define EQNSIGN 314 +#define EQNCOEF 315 +#define RATE 316 +#define LMPSPC 317 +#define SPCNR 318 +#define ATOMID 319 +#define LKTID 320 +#define MNIID 321 +#define INLCTX 322 +#define INCODE 323 +#define SSPID 324 +#define EQNLESS 325 +#define EQNTAG 326 +#define EQNGREATER 327 +#define TPTID 328 +#define USEID 329 +typedef union{ + char str[80]; +} YYSTYPE; +extern YYSTYPE yylval; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile new file mode 100755 index 00000000..5e58d92a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile @@ -0,0 +1,160 @@ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: Set here the F90 compiler and options +# Pedefined compilers: INTEL, PGF, HPUX, LAHEY +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +COMPILER = GNU +#COMPILER = LAHEY +#COMPILER = INTEL +#COMPILER = PGF +#COMPILER = HPUX + +FC_GNU = g95 +FOPT_GNU = -cpp -O -pg -fbounds-check +FC_LAHEY = lf95 +FOPT_LAHEY = -Cpp --pca +#FOPT_LAHEY = -Cpp --chk a,e,s,u --pca --ap -O0 -g --trap +FC_INTEL = ifort +FOPT_INTEL = -cpp -O -mp -pc80 -prec_div -tpp7 -implicitnone +FC_PGF = pgf90 +FOPT_PGF = -Mpreprocess -O -fast -pc 80 -Kieee +FC_HPUX = f90 +FOPT_HPUX = -O -u +Oall +check=on + +# define FULL_ALGEBRA for non-sparse integration +FC = $(FC_$(COMPILER)) +FOPT = $(FOPT_$(COMPILER)) # -DFULL_ALGEBRA + +LIBS = +#LIBS = -llapack -lblas + +# Command to create Matlab mex gateway routines +# Note: use $(FC) as the mex Fortran compiler +MEX = mex + +GENSRC = saprc99_Precision.f90 \ + saprc99_Parameters.f90 \ + saprc99_Global.f90 + +GENOBJ = saprc99_Precision.o \ + saprc99_Parameters.o \ + saprc99_Global.o + +FUNSRC = saprc99_Function.f90 +FUNOBJ = saprc99_Function.o + +JACSRC = saprc99_JacobianSP.f90 saprc99_Jacobian.f90 +JACOBJ = saprc99_JacobianSP.o saprc99_Jacobian.o + +HESSRC = saprc99_HessianSP.f90 saprc99_Hessian.f90 +HESOBJ = saprc99_HessianSP.o saprc99_Hessian.o + +STMSRC = saprc99_StoichiomSP.f90 saprc99_Stoichiom.f90 +STMOBJ = saprc99_StoichiomSP.o saprc99_Stoichiom.o + +UTLSRC = saprc99_Rates.f90 saprc99_Util.f90 saprc99_Monitor.f90 +UTLOBJ = saprc99_Rates.o saprc99_Util.o saprc99_Monitor.o + +LASRC = saprc99_LinearAlgebra.f90 +LAOBJ = saprc99_LinearAlgebra.o + +STOCHSRC = saprc99_Stochastic.f90 +STOCHOBJ = saprc99_Stochastic.o + +MAINSRC = saprc99_Main.f90 saprc99_Initialize.f90 saprc99_Integrator.f90 saprc99_Model.f90 +MAINOBJ = saprc99_Main.o saprc99_Initialize.o saprc99_Integrator.o saprc99_Model.o + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# objects needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ALLOBJ = $(GENOBJ) $(FUNOBJ) $(JACOBJ) $(HESOBJ) $(STMOBJ) \ + $(UTLOBJ) $(LAOBJ) + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# executables needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +all: exe + +exe: $(ALLOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(MAINOBJ) $(LIBS) -o saprc99.exe + +stochastic:$(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) $(LIBS) \ + -o saprc99_stochastic.exe + +mex: $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Fun.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Jac_SP.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Hessian.f90 $(ALLOBJ) + +clean: + rm -f saprc99*.o saprc99*.mod \ + saprc99*.dat saprc99.exe saprc99*.mexglx \ + saprc99.map + +distclean: + rm -f saprc99*.o saprc99*.mod \ + saprc99*.dat saprc99.exe saprc99.map \ + saprc99*.f90 saprc99_*.mexglx + +saprc99_Precision.o: saprc99_Precision.f90 + $(FC) $(FOPT) -c $< + +saprc99_Parameters.o: saprc99_Parameters.f90 \ + saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Monitor.o: saprc99_Monitor.f90 \ + saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Global.o: saprc99_Global.f90 \ + saprc99_Parameters.o saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Initialize.o: saprc99_Initialize.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Function.o: saprc99_Function.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Stochastic.o: saprc99_Stochastic.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_JacobianSP.o: saprc99_JacobianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Jacobian.o: saprc99_Jacobian.f90 $(GENOBJ) saprc99_JacobianSP.o + $(FC) $(FOPT) -c $< + +saprc99_LinearAlgebra.o: saprc99_LinearAlgebra.f90 $(GENOBJ) saprc99_JacobianSP.o + $(FC) $(FOPT) -c $< + +saprc99_Rates.o: saprc99_Rates.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_HessianSP.o: saprc99_HessianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Hessian.o: saprc99_Hessian.f90 $(GENOBJ) saprc99_HessianSP.o + $(FC) $(FOPT) -c $< + +saprc99_StoichiomSP.o: saprc99_StoichiomSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Stoichiom.o: saprc99_Stoichiom.f90 $(GENOBJ) saprc99_StoichiomSP.o + $(FC) $(FOPT) -c $< + +saprc99_Util.o: saprc99_Util.f90 $(GENOBJ) saprc99_Monitor.o + $(FC) $(FOPT) -c $< + +saprc99_Main.o: saprc99_Main.f90 $(ALLOBJ) saprc99_Initialize.o saprc99_Model.o saprc99_Integrator.o + $(FC) $(FOPT) -c $< + +saprc99_Model.o: saprc99_Model.f90 $(ALLOBJ) saprc99_Integrator.o + $(FC) $(FOPT) -c $< + +saprc99_Integrator.o: saprc99_Integrator.f90 $(ALLOBJ) + $(FC) $(FOPT) -c $< diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_pan b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_pan new file mode 100755 index 00000000..751bf1c8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_pan @@ -0,0 +1,160 @@ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: Set here the F90 compiler and options +# Pedefined compilers: INTEL, PGF, HPUX, LAHEY +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +COMPILER = GNU +#COMPILER = LAHEY +#COMPILER = INTEL +#COMPILER = PGF +#COMPILER = HPUX + +FC_GNU = g95 +FOPT_GNU = -cpp -O -pg -fbounds-check +FC_LAHEY = lf95 +FOPT_LAHEY = -Cpp --pca +#FOPT_LAHEY = -Cpp --chk a,e,s,u --pca --ap -O0 -g --trap +FC_INTEL = ifort +FOPT_INTEL = -cpp -O -mp -pc80 -prec_div -tpp7 -implicitnone +FC_PGF = pgf90 +FOPT_PGF = -Mpreprocess -O -fast -pc 80 -Kieee +FC_HPUX = f90 +FOPT_HPUX = -O -u +Oall +check=on + +# define FULL_ALGEBRA for non-sparse integration +FC = $(FC_$(COMPILER)) +FOPT = $(FOPT_$(COMPILER)) # -DFULL_ALGEBRA + +LIBS = +#LIBS = -llapack -lblas + +# Command to create Matlab mex gateway routines +# Note: use $(FC) as the mex Fortran compiler +MEX = mex + +GENSRC = pan_Precision.f90 \ + pan_Parameters.f90 \ + pan_Global.f90 + +GENOBJ = pan_Precision.o \ + pan_Parameters.o \ + pan_Global.o + +FUNSRC = pan_Function.f90 +FUNOBJ = pan_Function.o + +JACSRC = pan_JacobianSP.f90 pan_Jacobian.f90 +JACOBJ = pan_JacobianSP.o pan_Jacobian.o + +HESSRC = pan_HessianSP.f90 pan_Hessian.f90 +HESOBJ = pan_HessianSP.o pan_Hessian.o + +STMSRC = pan_StoichiomSP.f90 pan_Stoichiom.f90 +STMOBJ = pan_StoichiomSP.o pan_Stoichiom.o + +UTLSRC = pan_Rates.f90 pan_Util.f90 pan_Monitor.f90 +UTLOBJ = pan_Rates.o pan_Util.o pan_Monitor.o + +LASRC = pan_LinearAlgebra.f90 +LAOBJ = pan_LinearAlgebra.o + +STOCHSRC = pan_Stochastic.f90 +STOCHOBJ = pan_Stochastic.o + +MAINSRC = pan_Main.f90 pan_Initialize.f90 pan_Integrator.f90 pan_Model.f90 +MAINOBJ = pan_Main.o pan_Initialize.o pan_Integrator.o pan_Model.o + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# objects needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ALLOBJ = $(GENOBJ) $(FUNOBJ) $(JACOBJ) $(HESOBJ) $(STMOBJ) \ + $(UTLOBJ) $(LAOBJ) + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# executables needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +all: exe + +exe: $(ALLOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(MAINOBJ) $(LIBS) -o pan.exe + +stochastic:$(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) $(LIBS) \ + -o pan_stochastic.exe + +mex: $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O pan_mex_Fun.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O pan_mex_Jac_SP.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O pan_mex_Hessian.f90 $(ALLOBJ) + +clean: + rm -f pan*.o pan*.mod \ + pan*.dat pan.exe pan*.mexglx \ + pan.map + +distclean: + rm -f pan*.o pan*.mod \ + pan*.dat pan.exe pan.map \ + pan*.f90 pan_*.mexglx + +pan_Precision.o: pan_Precision.f90 + $(FC) $(FOPT) -c $< + +pan_Parameters.o: pan_Parameters.f90 \ + pan_Precision.o + $(FC) $(FOPT) -c $< + +pan_Monitor.o: pan_Monitor.f90 \ + pan_Precision.o + $(FC) $(FOPT) -c $< + +pan_Global.o: pan_Global.f90 \ + pan_Parameters.o pan_Precision.o + $(FC) $(FOPT) -c $< + +pan_Initialize.o: pan_Initialize.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_Function.o: pan_Function.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_Stochastic.o: pan_Stochastic.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_JacobianSP.o: pan_JacobianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_Jacobian.o: pan_Jacobian.f90 $(GENOBJ) pan_JacobianSP.o + $(FC) $(FOPT) -c $< + +pan_LinearAlgebra.o: pan_LinearAlgebra.f90 $(GENOBJ) pan_JacobianSP.o + $(FC) $(FOPT) -c $< + +pan_Rates.o: pan_Rates.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_HessianSP.o: pan_HessianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_Hessian.o: pan_Hessian.f90 $(GENOBJ) pan_HessianSP.o + $(FC) $(FOPT) -c $< + +pan_StoichiomSP.o: pan_StoichiomSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +pan_Stoichiom.o: pan_Stoichiom.f90 $(GENOBJ) pan_StoichiomSP.o + $(FC) $(FOPT) -c $< + +pan_Util.o: pan_Util.f90 $(GENOBJ) pan_Monitor.o + $(FC) $(FOPT) -c $< + +pan_Main.o: pan_Main.f90 $(ALLOBJ) pan_Initialize.o pan_Model.o pan_Integrator.o + $(FC) $(FOPT) -c $< + +pan_Model.o: pan_Model.f90 $(ALLOBJ) pan_Integrator.o + $(FC) $(FOPT) -c $< + +pan_Integrator.o: pan_Integrator.f90 $(ALLOBJ) + $(FC) $(FOPT) -c $< diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_saprc99 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_saprc99 new file mode 100755 index 00000000..5e58d92a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_saprc99 @@ -0,0 +1,160 @@ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: Set here the F90 compiler and options +# Pedefined compilers: INTEL, PGF, HPUX, LAHEY +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +COMPILER = GNU +#COMPILER = LAHEY +#COMPILER = INTEL +#COMPILER = PGF +#COMPILER = HPUX + +FC_GNU = g95 +FOPT_GNU = -cpp -O -pg -fbounds-check +FC_LAHEY = lf95 +FOPT_LAHEY = -Cpp --pca +#FOPT_LAHEY = -Cpp --chk a,e,s,u --pca --ap -O0 -g --trap +FC_INTEL = ifort +FOPT_INTEL = -cpp -O -mp -pc80 -prec_div -tpp7 -implicitnone +FC_PGF = pgf90 +FOPT_PGF = -Mpreprocess -O -fast -pc 80 -Kieee +FC_HPUX = f90 +FOPT_HPUX = -O -u +Oall +check=on + +# define FULL_ALGEBRA for non-sparse integration +FC = $(FC_$(COMPILER)) +FOPT = $(FOPT_$(COMPILER)) # -DFULL_ALGEBRA + +LIBS = +#LIBS = -llapack -lblas + +# Command to create Matlab mex gateway routines +# Note: use $(FC) as the mex Fortran compiler +MEX = mex + +GENSRC = saprc99_Precision.f90 \ + saprc99_Parameters.f90 \ + saprc99_Global.f90 + +GENOBJ = saprc99_Precision.o \ + saprc99_Parameters.o \ + saprc99_Global.o + +FUNSRC = saprc99_Function.f90 +FUNOBJ = saprc99_Function.o + +JACSRC = saprc99_JacobianSP.f90 saprc99_Jacobian.f90 +JACOBJ = saprc99_JacobianSP.o saprc99_Jacobian.o + +HESSRC = saprc99_HessianSP.f90 saprc99_Hessian.f90 +HESOBJ = saprc99_HessianSP.o saprc99_Hessian.o + +STMSRC = saprc99_StoichiomSP.f90 saprc99_Stoichiom.f90 +STMOBJ = saprc99_StoichiomSP.o saprc99_Stoichiom.o + +UTLSRC = saprc99_Rates.f90 saprc99_Util.f90 saprc99_Monitor.f90 +UTLOBJ = saprc99_Rates.o saprc99_Util.o saprc99_Monitor.o + +LASRC = saprc99_LinearAlgebra.f90 +LAOBJ = saprc99_LinearAlgebra.o + +STOCHSRC = saprc99_Stochastic.f90 +STOCHOBJ = saprc99_Stochastic.o + +MAINSRC = saprc99_Main.f90 saprc99_Initialize.f90 saprc99_Integrator.f90 saprc99_Model.f90 +MAINOBJ = saprc99_Main.o saprc99_Initialize.o saprc99_Integrator.o saprc99_Model.o + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# objects needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ALLOBJ = $(GENOBJ) $(FUNOBJ) $(JACOBJ) $(HESOBJ) $(STMOBJ) \ + $(UTLOBJ) $(LAOBJ) + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# executables needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +all: exe + +exe: $(ALLOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(MAINOBJ) $(LIBS) -o saprc99.exe + +stochastic:$(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) $(LIBS) \ + -o saprc99_stochastic.exe + +mex: $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Fun.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Jac_SP.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O saprc99_mex_Hessian.f90 $(ALLOBJ) + +clean: + rm -f saprc99*.o saprc99*.mod \ + saprc99*.dat saprc99.exe saprc99*.mexglx \ + saprc99.map + +distclean: + rm -f saprc99*.o saprc99*.mod \ + saprc99*.dat saprc99.exe saprc99.map \ + saprc99*.f90 saprc99_*.mexglx + +saprc99_Precision.o: saprc99_Precision.f90 + $(FC) $(FOPT) -c $< + +saprc99_Parameters.o: saprc99_Parameters.f90 \ + saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Monitor.o: saprc99_Monitor.f90 \ + saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Global.o: saprc99_Global.f90 \ + saprc99_Parameters.o saprc99_Precision.o + $(FC) $(FOPT) -c $< + +saprc99_Initialize.o: saprc99_Initialize.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Function.o: saprc99_Function.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Stochastic.o: saprc99_Stochastic.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_JacobianSP.o: saprc99_JacobianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Jacobian.o: saprc99_Jacobian.f90 $(GENOBJ) saprc99_JacobianSP.o + $(FC) $(FOPT) -c $< + +saprc99_LinearAlgebra.o: saprc99_LinearAlgebra.f90 $(GENOBJ) saprc99_JacobianSP.o + $(FC) $(FOPT) -c $< + +saprc99_Rates.o: saprc99_Rates.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_HessianSP.o: saprc99_HessianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Hessian.o: saprc99_Hessian.f90 $(GENOBJ) saprc99_HessianSP.o + $(FC) $(FOPT) -c $< + +saprc99_StoichiomSP.o: saprc99_StoichiomSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +saprc99_Stoichiom.o: saprc99_Stoichiom.f90 $(GENOBJ) saprc99_StoichiomSP.o + $(FC) $(FOPT) -c $< + +saprc99_Util.o: saprc99_Util.f90 $(GENOBJ) saprc99_Monitor.o + $(FC) $(FOPT) -c $< + +saprc99_Main.o: saprc99_Main.f90 $(ALLOBJ) saprc99_Initialize.o saprc99_Model.o saprc99_Integrator.o + $(FC) $(FOPT) -c $< + +saprc99_Model.o: saprc99_Model.f90 $(ALLOBJ) saprc99_Integrator.o + $(FC) $(FOPT) -c $< + +saprc99_Integrator.o: saprc99_Integrator.f90 $(ALLOBJ) + $(FC) $(FOPT) -c $< diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_small_strato b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_small_strato new file mode 100755 index 00000000..353209ab --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_small_strato @@ -0,0 +1,160 @@ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: Set here the F90 compiler and options +# Pedefined compilers: INTEL, PGF, HPUX, LAHEY +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +COMPILER = GNU +#COMPILER = LAHEY +#COMPILER = INTEL +#COMPILER = PGF +#COMPILER = HPUX + +FC_GNU = g95 +FOPT_GNU = -cpp -O -pg -fbounds-check +FC_LAHEY = lf95 +FOPT_LAHEY = -Cpp --pca +#FOPT_LAHEY = -Cpp --chk a,e,s,u --pca --ap -O0 -g --trap +FC_INTEL = ifort +FOPT_INTEL = -cpp -O -mp -pc80 -prec_div -tpp7 -implicitnone +FC_PGF = pgf90 +FOPT_PGF = -Mpreprocess -O -fast -pc 80 -Kieee +FC_HPUX = f90 +FOPT_HPUX = -O -u +Oall +check=on + +# define FULL_ALGEBRA for non-sparse integration +FC = $(FC_$(COMPILER)) +FOPT = $(FOPT_$(COMPILER)) # -DFULL_ALGEBRA + +LIBS = +#LIBS = -llapack -lblas + +# Command to create Matlab mex gateway routines +# Note: use $(FC) as the mex Fortran compiler +MEX = mex + +GENSRC = small_strato_Precision.f90 \ + small_strato_Parameters.f90 \ + small_strato_Global.f90 + +GENOBJ = small_strato_Precision.o \ + small_strato_Parameters.o \ + small_strato_Global.o + +FUNSRC = small_strato_Function.f90 +FUNOBJ = small_strato_Function.o + +JACSRC = small_strato_JacobianSP.f90 small_strato_Jacobian.f90 +JACOBJ = small_strato_JacobianSP.o small_strato_Jacobian.o + +HESSRC = small_strato_HessianSP.f90 small_strato_Hessian.f90 +HESOBJ = small_strato_HessianSP.o small_strato_Hessian.o + +STMSRC = small_strato_StoichiomSP.f90 small_strato_Stoichiom.f90 +STMOBJ = small_strato_StoichiomSP.o small_strato_Stoichiom.o + +UTLSRC = small_strato_Rates.f90 small_strato_Util.f90 small_strato_Monitor.f90 +UTLOBJ = small_strato_Rates.o small_strato_Util.o small_strato_Monitor.o + +LASRC = small_strato_LinearAlgebra.f90 +LAOBJ = small_strato_LinearAlgebra.o + +STOCHSRC = small_strato_Stochastic.f90 +STOCHOBJ = small_strato_Stochastic.o + +MAINSRC = small_strato_Main.f90 small_strato_Initialize.f90 small_strato_Integrator.f90 small_strato_Model.f90 +MAINOBJ = small_strato_Main.o small_strato_Initialize.o small_strato_Integrator.o small_strato_Model.o + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# objects needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ALLOBJ = $(GENOBJ) $(FUNOBJ) $(JACOBJ) $(HESOBJ) $(STMOBJ) \ + $(UTLOBJ) $(LAOBJ) + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# executables needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +all: exe + +exe: $(ALLOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(MAINOBJ) $(LIBS) -o small_strato.exe + +stochastic:$(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) $(LIBS) \ + -o small_strato_stochastic.exe + +mex: $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O small_strato_mex_Fun.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O small_strato_mex_Jac_SP.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O small_strato_mex_Hessian.f90 $(ALLOBJ) + +clean: + rm -f small_strato*.o small_strato*.mod \ + small_strato*.dat small_strato.exe small_strato*.mexglx \ + small_strato.map + +distclean: + rm -f small_strato*.o small_strato*.mod \ + small_strato*.dat small_strato.exe small_strato.map \ + small_strato*.f90 small_strato_*.mexglx + +small_strato_Precision.o: small_strato_Precision.f90 + $(FC) $(FOPT) -c $< + +small_strato_Parameters.o: small_strato_Parameters.f90 \ + small_strato_Precision.o + $(FC) $(FOPT) -c $< + +small_strato_Monitor.o: small_strato_Monitor.f90 \ + small_strato_Precision.o + $(FC) $(FOPT) -c $< + +small_strato_Global.o: small_strato_Global.f90 \ + small_strato_Parameters.o small_strato_Precision.o + $(FC) $(FOPT) -c $< + +small_strato_Initialize.o: small_strato_Initialize.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_Function.o: small_strato_Function.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_Stochastic.o: small_strato_Stochastic.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_JacobianSP.o: small_strato_JacobianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_Jacobian.o: small_strato_Jacobian.f90 $(GENOBJ) small_strato_JacobianSP.o + $(FC) $(FOPT) -c $< + +small_strato_LinearAlgebra.o: small_strato_LinearAlgebra.f90 $(GENOBJ) small_strato_JacobianSP.o + $(FC) $(FOPT) -c $< + +small_strato_Rates.o: small_strato_Rates.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_HessianSP.o: small_strato_HessianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_Hessian.o: small_strato_Hessian.f90 $(GENOBJ) small_strato_HessianSP.o + $(FC) $(FOPT) -c $< + +small_strato_StoichiomSP.o: small_strato_StoichiomSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +small_strato_Stoichiom.o: small_strato_Stoichiom.f90 $(GENOBJ) small_strato_StoichiomSP.o + $(FC) $(FOPT) -c $< + +small_strato_Util.o: small_strato_Util.f90 $(GENOBJ) small_strato_Monitor.o + $(FC) $(FOPT) -c $< + +small_strato_Main.o: small_strato_Main.f90 $(ALLOBJ) small_strato_Initialize.o small_strato_Model.o small_strato_Integrator.o + $(FC) $(FOPT) -c $< + +small_strato_Model.o: small_strato_Model.f90 $(ALLOBJ) small_strato_Integrator.o + $(FC) $(FOPT) -c $< + +small_strato_Integrator.o: small_strato_Integrator.f90 $(ALLOBJ) + $(FC) $(FOPT) -c $< diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_strato b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_strato new file mode 100755 index 00000000..e0b23bc2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/Makefile_strato @@ -0,0 +1,160 @@ +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: Set here the F90 compiler and options +# Pedefined compilers: INTEL, PGF, HPUX, LAHEY +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +COMPILER = GNU +#COMPILER = LAHEY +#COMPILER = INTEL +#COMPILER = PGF +#COMPILER = HPUX + +FC_GNU = g95 +FOPT_GNU = -cpp -O -pg -fbounds-check +FC_LAHEY = lf95 +FOPT_LAHEY = -Cpp --pca +#FOPT_LAHEY = -Cpp --chk a,e,s,u --pca --ap -O0 -g --trap +FC_INTEL = ifort +FOPT_INTEL = -cpp -O -mp -pc80 -prec_div -tpp7 -implicitnone +FC_PGF = pgf90 +FOPT_PGF = -Mpreprocess -O -fast -pc 80 -Kieee +FC_HPUX = f90 +FOPT_HPUX = -O -u +Oall +check=on + +# define FULL_ALGEBRA for non-sparse integration +FC = $(FC_$(COMPILER)) +FOPT = $(FOPT_$(COMPILER)) # -DFULL_ALGEBRA + +LIBS = +#LIBS = -llapack -lblas + +# Command to create Matlab mex gateway routines +# Note: use $(FC) as the mex Fortran compiler +MEX = mex + +GENSRC = strato_Precision.f90 \ + strato_Parameters.f90 \ + strato_Global.f90 + +GENOBJ = strato_Precision.o \ + strato_Parameters.o \ + strato_Global.o + +FUNSRC = strato_Function.f90 +FUNOBJ = strato_Function.o + +JACSRC = strato_JacobianSP.f90 strato_Jacobian.f90 +JACOBJ = strato_JacobianSP.o strato_Jacobian.o + +HESSRC = strato_HessianSP.f90 strato_Hessian.f90 +HESOBJ = strato_HessianSP.o strato_Hessian.o + +STMSRC = strato_StoichiomSP.f90 strato_Stoichiom.f90 +STMOBJ = strato_StoichiomSP.o strato_Stoichiom.o + +UTLSRC = strato_Rates.f90 strato_Util.f90 strato_Monitor.f90 +UTLOBJ = strato_Rates.o strato_Util.o strato_Monitor.o + +LASRC = strato_LinearAlgebra.f90 +LAOBJ = strato_LinearAlgebra.o + +STOCHSRC = strato_Stochastic.f90 +STOCHOBJ = strato_Stochastic.o + +MAINSRC = strato_Main.f90 strato_Initialize.f90 strato_Integrator.f90 strato_Model.f90 +MAINOBJ = strato_Main.o strato_Initialize.o strato_Integrator.o strato_Model.o + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# objects needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ALLOBJ = $(GENOBJ) $(FUNOBJ) $(JACOBJ) $(HESOBJ) $(STMOBJ) \ + $(UTLOBJ) $(LAOBJ) + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# User: modify the line below to include only the +# executables needed by your application +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +all: exe + +exe: $(ALLOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(MAINOBJ) $(LIBS) -o strato.exe + +stochastic:$(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) + $(FC) $(FOPT) $(ALLOBJ) $(STOCHOBJ) $(MAINOBJ) $(LIBS) \ + -o strato_stochastic.exe + +mex: $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O strato_mex_Fun.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O strato_mex_Jac_SP.f90 $(ALLOBJ) + $(MEX) FC#$(FC) -fortran -O strato_mex_Hessian.f90 $(ALLOBJ) + +clean: + rm -f strato*.o strato*.mod \ + strato*.dat strato.exe strato*.mexglx \ + strato.map + +distclean: + rm -f strato*.o strato*.mod \ + strato*.dat strato.exe strato.map \ + strato*.f90 strato_*.mexglx + +strato_Precision.o: strato_Precision.f90 + $(FC) $(FOPT) -c $< + +strato_Parameters.o: strato_Parameters.f90 \ + strato_Precision.o + $(FC) $(FOPT) -c $< + +strato_Monitor.o: strato_Monitor.f90 \ + strato_Precision.o + $(FC) $(FOPT) -c $< + +strato_Global.o: strato_Global.f90 \ + strato_Parameters.o strato_Precision.o + $(FC) $(FOPT) -c $< + +strato_Initialize.o: strato_Initialize.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_Function.o: strato_Function.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_Stochastic.o: strato_Stochastic.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_JacobianSP.o: strato_JacobianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_Jacobian.o: strato_Jacobian.f90 $(GENOBJ) strato_JacobianSP.o + $(FC) $(FOPT) -c $< + +strato_LinearAlgebra.o: strato_LinearAlgebra.f90 $(GENOBJ) strato_JacobianSP.o + $(FC) $(FOPT) -c $< + +strato_Rates.o: strato_Rates.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_HessianSP.o: strato_HessianSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_Hessian.o: strato_Hessian.f90 $(GENOBJ) strato_HessianSP.o + $(FC) $(FOPT) -c $< + +strato_StoichiomSP.o: strato_StoichiomSP.f90 $(GENOBJ) + $(FC) $(FOPT) -c $< + +strato_Stoichiom.o: strato_Stoichiom.f90 $(GENOBJ) strato_StoichiomSP.o + $(FC) $(FOPT) -c $< + +strato_Util.o: strato_Util.f90 $(GENOBJ) strato_Monitor.o + $(FC) $(FOPT) -c $< + +strato_Main.o: strato_Main.f90 $(ALLOBJ) strato_Initialize.o strato_Model.o strato_Integrator.o + $(FC) $(FOPT) -c $< + +strato_Model.o: strato_Model.f90 $(ALLOBJ) strato_Integrator.o + $(FC) $(FOPT) -c $< + +strato_Integrator.o: strato_Integrator.f90 $(ALLOBJ) + $(FC) $(FOPT) -c $< diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/atoms b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/atoms new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/atoms @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.def new file mode 100755 index 00000000..287ce391 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.def @@ -0,0 +1,63 @@ +#include atoms +#include ./cbm4.spc +#include ./cbm4.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL + +#MONITOR O3; + +#INITVALUES + CFACTOR = 2.55E+10; {ppb-to-mcm} + ALL_SPEC = 1.0E-8; +{Variable species} + NO = 50.0; + NO2 = 20.0; + HONO = 1.0; + O3 = 100.0; + HCHO = 10.0; + ALD2 = 10; + PAN = 1.0; + PAR = 50.0; + OLE = 10.0; + ETH = 10.0; + TOL = 10.0; + XYL = 10.0; + ISOP = 10.0; + CO = 300.0; +{Fixed species} + H2O = 1.25E+8; {30 %} + + +#INLINE F77_INIT + TSTART = 12.D0*3600.D0 + TEND = TSTART + 24.D0*3600.D0 * 5 + DT = 3600.D0 + TEMP = 288.15 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 12.D0*3600.D0 + TEND = TSTART + 24.D0*3600.D0 * 5 + DT = 3600.D0 + TEMP = 288.15 +#ENDINLINE + +#INLINE MATLAB_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 24.0*3600.0*5; + DT = 3600.0; + TEMP = 288.15; +#ENDINLINE + +#INLINE C_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 24.0*3600.0*5; + DT = 3600.0; + TEMP = 288.15; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.eqn new file mode 100755 index 00000000..78bd9fb4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.eqn @@ -0,0 +1,119 @@ +#EQUATIONS {of the CBM-IV mechanism} + +{ 1.} NO2 + hv = NO + O : 8.89E-3*SUN ; +{ 2.} O {+ O2 + M} = O3 : ARR2(1.4E+3, 1175.0) ; +{ 3.} O3 + NO = NO2 : ARR2(1.8E-12, -1370.0) ; +{ 4.} O + NO2 = NO : 9.3E-12 ; +{ 5.} O + NO2 = NO3 : ARR2(1.6E-13, 687.0) ; +{ 6.} O + NO = NO2 : ARR2(2.2E-13, 602.0) ; +{ 7.} O3 + NO2 = NO3 : ARR2(1.2E-13, -2450.0) ; +{ 8.} O3 + hv = O : 3.556E-04*SUN ; {4.0E-2*RCONST(1) ;} +{ 9.} O3 + hv = O1D : 2.489E-05*SUN ; {2.8E-3*RCONST(1) ;} +{10.} O1D = O : ARR2(1.9E+8, 390.0) ; + +{11.} O1D + H2O = 2OH : 2.2E-10 ; +{12.} O3 + OH = HO2 : ARR2(1.6E-12, -940.0) ; +{13.} O3 + HO2 = OH : ARR2(1.4E-14, -580.0) ; +{14.} NO3 + hv = 0.89 NO2 + 0.89 O + + 0.11 NO : 1.378E-01*SUN ; {15.5*RCONST(1);} +{15.} NO3 + NO = 2 NO2 : ARR2(1.3E-11, 250.0) ; +{16.} NO3 + NO2 = NO + NO2 : ARR2(2.5E-14, -1230.0) ; +{17.} NO3 + NO2 = N2O5 : ARR2(5.3E-13, 256.0) ; +{18.} N2O5 + H2O = 2 HNO3 : 1.3E-21 ; +{19.} N2O5 = NO3 + NO2 : ARR2(3.5E+14, -10897.0) ; +{20.} 2 NO = 2 NO2 : ARR2(1.8E-20, 530.0) ; + + +{21.} NO + NO2 + H2O = 2 HONO : 4.4E-40 ; +{22.} OH + NO = HONO : ARR2(4.5E-13, 806.0) ; +{23.} HONO + hv = OH + NO : 1.511e-03*SUN ; {0.17*RCONST(1);} +{24.} OH + HONO = NO2 : 6.6E-12 ; +{25.} 2 HONO = NO + NO2 : 1.0E-20 ; +{26.} OH + NO2 = HNO3 : ARR2(1.0E-12, 713.0) ; +{27.} OH + HNO3 = NO3 : ARR2(5.1E-15, 1000.0) ; +{28.} HO2 + NO = OH + NO2 : ARR2(3.7E-12, 240.0) ; +{29.} HO2 + NO2 = PNA : ARR2(1.2E-13, 749.0) ; +{30.} PNA = HO2 + NO2 : ARR2(4.8E+13, -10121.0) ; + +{31.} OH + PNA = NO2 : ARR2(1.3E-12, 380.0) ; +{32.} 2 HO2 = H2O2 : ARR2(5.9E-14, 1150.0) ; +{33.} 2 HO2 + H2O = H2O2 : ARR2(2.2E-38, 5800.0) ; +{34.} H2O2 + hv = 2 OH : 6.312E-06*SUN ; {7.1E-4*RCONST(1);} +{35.} OH + H2O2 = HO2 : ARR2(3.1E-12, -187.0) ; +{36.} OH + CO = HO2 : 2.2E-13 ; +{37.} HCHO + OH = HO2 + CO : 1.0E-11 ; +{38.} HCHO + hv {+ 2 O2} = 2 HO2 + CO : 2.845E-05*SUN ; {3.2E-3*RCONST(1);} +{39.} HCHO + hv = CO : 3.734E-05*SUN ; {4.2E-3*RCONST(1);} +{40.} HCHO + O = OH + HO2 + CO : ARR2(3.0E-11, -1550.0) ; + +{41.} HCHO + NO3 = HNO3 + + HO2 + CO : 6.3E-16 ; +{42.} ALD2 + O = C2O3 + OH : ARR2(1.2E-11, -986.0) ; +{43.} ALD2 + OH = C2O3 : ARR2(7.0E-12, 250.0) ; +{44.} ALD2 + NO3 = C2O3 + HNO3 : 2.5E-15 ; +{45.} ALD2 + hv {+ 2 O2} = HCHO + XO2 + + CO + 2 HO2 : 4.00E-06*SUN ; {4.5E-4*RCONST(1);} +{46.} C2O3 + NO = HCHO + XO2 + + HO2 + NO2 : ARR2(5.4E-12, 250.0) ; +{47.} C2O3 + NO2 = PAN : ARR2(8.0E-20, 5500.0) ; +{48.} PAN = C2O3 + NO2 : ARR2(9.4E+16, -14000.0) ; +{49.} 2 C2O3 = 2 HCHO + 2 XO2 + 2 HO2 : 2.0E-12 ; +{50.} C2O3 + HO2 = 0.79 HCHO + + 0.79 XO2 + 0.79 HO2 + 0.79 OH : 6.5E-12 ; + +{51.} OH = HCHO + XO2 + HO2 : ARR2(1.1E+2, -1710.0) ; +{52.} PAR + OH = 0.87 XO2 + 0.13 XO2N + + 0.11 HO2 + 0.11 ALD2 + + 0.76 ROR - 0.11 PAR : 8.1E-13 ; +{53.} ROR = 1.1 ALD2 + 0.96 XO2 + + 0.94 HO2 + 0.04 XO2N + + 0.02 ROR - 2.10 PAR : ARR2(1.0E+15, -8000.0) ; +{54.} ROR = HO2 : 1.6E+03 ; +{55.} ROR + NO2 = PROD : 1.5E-11 ; +{56.} O + OLE = 0.63 ALD2 + 0.38 HO2 + + 0.28 XO2 + 0.3 CO + + 0.2 HCHO + 0.02 XO2N + + 0.22 PAR + 0.2 OH : ARR2(1.2E-11, -324.0) ; +{57.} OH + OLE = HCHO + ALD2 + XO2 + + HO2 - PAR : ARR2(5.2E-12, 504.0) ; +{58.} O3 + OLE = 0.5 ALD2 + 0.74 HCHO + + 0.33 CO + 0.44 HO2 + + 0.22 XO2 + + 0.1 OH - PAR : ARR2(1.4E-14, -2105.0) ; +{59.} NO3 + OLE = 0.91 XO2 + HCHO + + ALD2 + 0.09 XO2N + + NO2 - PAR : 7.7E-15 ; +{60.} O + ETH = HCHO + 0.7 XO2 + CO + + 1.7 HO2 + 0.3 OH : ARR2(1.0E-11, -792.0) ; + +{61.} OH + ETH = XO2 + 1.56 HCHO + HO2 + 0.22 ALD2 : ARR2(2.0E-12, 411.0) ; +{62.} O3 + ETH = HCHO + 0.42 CO + 0.12 HO2 : ARR2(1.3E-14, -2633.0) ; +{63.} OH + TOL = 0.08 XO2 + 0.36 CRES + + 0.44 HO2 + 0.56 TO2 : ARR2(2.1E-12, 322.0) ; +{64.} TO2 + NO = 0.9 NO2 + 0.9 OPEN + 0.9 HO2 : 8.1E-12 ; +{65.} TO2 = HO2 + CRES : 4.20 ; +{66.} OH + CRES = 0.4 CRO + 0.6 XO2 + 0.6 HO2 + 0.3 OPEN : 4.1E-11 ; +{67.} NO3 + CRES = CRO + HNO3 : 2.2E-11 ; +{68.} CRO + NO2 = PROD : 1.4E-11 ; +{69.} OH + XYL = 0.7 HO2 + 0.5 XO2 + 0.2 CRES + 0.8 MGLY + + 1.10 PAR + 0.3 TO2 : ARR2(1.7E-11, 116.0) ; +{70.} OH + OPEN = XO2 + C2O3 + 2 HO2 + 2 CO + HCHO : 3.0E-11 ; + +{71.} OPEN + hv = C2O3 + CO + HO2 : 5.334E-05*SUN ; {6.0E-3*RCONST(1);} +{72.} O3 + OPEN = 0.03 ALD2 + 0.62 C2O3 + + 0.7 HCHO + 0.03 XO2 + 0.69 CO + + 0.08 OH + 0.76 HO2 + 0.2 MGLY : ARR2(5.4E-17, -500.0) ; +{73.} OH + MGLY = XO2 + C2O3 : 1.70E-11 ; +{74.} MGLY + hv = C2O3 + CO + HO2 : 1.654E-04*SUN ; {1.86E-2*RCONST(1);} +{75.} O + ISOP = 0.6 HO2 + 0.8 ALD2 + 0.55 OLE + 0.5 XO2 + + 0.5 CO + 0.45 ETH + 0.9 PAR : 1.80E-11 ; +{76.} OH + ISOP = HCHO + XO2 + 0.67 HO2 + + 0.4 MGLY + 0.2 C2O3 + + ETH + 0.2 ALD2 + 0.13 XO2N : 9.6E-11 ; +{77.} O3 + ISOP = HCHO + 0.4 ALD2 + 0.55 ETH + 0.2 MGLY + + 0.06 CO + 0.1 PAR + 0.44 HO2 + 0.1 OH : 1.2E-17 ; +{78.} NO3 + ISOP = XO2N : 3.2E-13 ; +{79.} XO2 + NO = NO2 : 8.1E-12 ; +{80.} 2 XO2 = PROD : ARR2(1.7E-14, 1300.0) ; +{81.} XO2N + NO = PROD : 6.8E-13 ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.spc new file mode 100755 index 00000000..76321bca --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/cbm4.spc @@ -0,0 +1,41 @@ +#DEFVAR + NO = N + O ; {nitric oxide} + NO2 = N + 2O ; {nitrogen dioxide} + NO3 = N + 3O ; {nitrogen trioxide} + N2O5 = 2N + 5O ; {dinitrogen pentoxide} + HONO = H + 2O + N ; {nitrous acid} + HNO3 = H + N + 3O ; { nitric acid } + PNA = H + 4 O + N ; {HO2NO2 peroxynitric acid} + O1D = O ; {oxygen atomic first singlet state} + O = O ; {oxygen atomic ground state (3P)} + OH = O + H ; {hydroxyl radical} + O3 = 3O ; {ozone} + HO2 = H + 2O ; {perhydroxyl radical} + H2O2 = 2H + 2O ; {hydrogen peroxide} + HCHO = C + 2H + O ; {formalydehyde} + ALD2 = IGNORE ; {high molecular weight aldehides} + C2O3 = 2C + 3H + 3O ; {CH3CO(O)OO peroxyacyl radical} + PAN = 2C + 3H + 5O + N ; {CH3C(O)OONO2, peroxyacyl nitrate} + PAR = IGNORE ; {parafin carbon bond} + ROR = IGNORE ; {secondary organic oxy radical} + OLE = IGNORE ; {olefinic carbon bond} + ETH = 2C + 4H ; {CH2=CH2 ethene} + TOL = 7C + 8H ; {C6H5-CH3 toluene} + CRES = IGNORE ; {cresol and h.m.w. phenols} + TO2 = IGNORE ; {toluene-hydroxyl radical adduct} + CRO = IGNORE ; {methylphenoxy radical} + OPEN = IGNORE ; {h.m.w. aromatic oxidation ring fragment} + XYL = 8C + 10H ; {C6H4-(CH3)2 xylene} + MGLY = 3C + 4H + 2O ; {CH3C(O)C(O)H methylglyoxal} + ISOP = IGNORE ; {isoprene} + XO2 = IGNORE ; {NO-to-NO2 operation} + XO2N = IGNORE ; {NO-to-nitrate operation} + CO = C + O ; {carbon monoxide} + +#DEFFIX + H2O = H + 2O ; {water} + H2 = 2H ; {molecular hydrogen} + O2 = 2O ; {molecular oxygen} + N2 = 2N ; {molecular nitrogen} + CH4 = C + 4H ; {methane} + M = IGNORE ; {third body} \ No newline at end of file diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.def new file mode 100755 index 00000000..f2b559e0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.def @@ -0,0 +1,38 @@ +#include atoms +#include ./pan.spc +#include ./pan.eqn + +#LANGUAGE FORTRAN90 + +#INTEGRATOR rosenbrock +{#DRIVER kppbox} + +#CHECKALL +{#LOOKATALL} +#LOOKAT O3; O1D ;OH; HO2; H2O2; NO; NO2; + +{#MONITOR O3;} + +#INITVALUES { default values, overwritten later in the code !} + CFACTOR = 2.5482E19; {vmr-to-molec/cm^3, same as in FACSIMILE} + {P*6.022E23/8.31441/TEMP*1E6} + ALL_SPEC = 0.0E-19; +{Variable species} + O3 = 30.E-9; + NO2 = 200.E-12; + HNO3 = 100.E-12; + H2O2 = 2.E-9; + CH4 = 1700.E-9; + CO = 100.E-9; +{Fixed species} + H2O = 1.E-2; + M = 1. ; + +#INLINE F_INIT + TSTART = 0. + TEND = TSTART + 24.*3600. * 5. + DT = 20.*60. + TEMP = 288. + PRESS = 101325. +#ENDINLINE +{ TEMP must fit to number above in CFACTOR!} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.eqn new file mode 100755 index 00000000..91db96cd --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.eqn @@ -0,0 +1,68 @@ +#EQUATIONS {-------- background CH4-CO-NOx-HOx chemistry ------updated with nmhc6 July 18.2000---------------} +{ NOTE that the numbers at the beginning of each line are used by the budget routines in MATCH, + so keep them updated!!! } +{ based on Rolf von Kuhlmann, ...} +{ last changed:; cms -added PAN based on RvK ...} +{1} O3 + hv = O1D : j(P_RJ_O1D); +{2} O1D + M = O3 : .78084D0*1.8D-11*exp(110.D0/TEMP)+.20946D0*3.2D-11*exp(70./TEMP); {JPL97} +{3} O1D + H2O = 2 OH : 2.2D-10; {JPL97} +{4} M + hv = 2 O3 : min(1.D-11,.20946D0*j(P_RJ_O2)); +{5} O3 + OH = HO2 : 1.5D-12*exp(-880.D0/TEMP); {JPL2000} +{6} O3 + HO2 = OH : 2.D-14*exp(-680.D0/TEMP); {JPL2000} +{7} HO2 + OH = H2O : 4.8D-11*exp(250.D0/TEMP); {JPL97,JPL2000} +{8} 2 HO2 = H2O2 : RHO2HO2(F(2),F(1),TEMP); {JPL97} +{9} H2O2 + hv = 2 OH : j(P_RJ_H2O2); +{10} OH + H2O2 = HO2 : 2.9D-12*exp(-160.D0/TEMP); {JPL97} +{11} OH + CO = HO2 {+ CO2} : 1.5D-13*(1.D0+0.6D0*PRESS/101325.); {JPL97} +{12} CH4 + OH = MeO2 + H2O : 2.8D-14*exp(0.667D0*log(TEMP)-1575./TEMP); {JPL97} +{13} MeO2 + HO2 = MeOOH : 4.15D-13*exp(750.D0/TEMP);{Tyn00; note that a <10% HCHO-channel may exist} +{14} MeO2 + NO = HCHO + HO2 + NO2 : 2.8D-12*exp(300.D0/TEMP); {Tyn00, MCM-.1% MeONO2,J.Crowley<1D-5,+oth.path.} +{15} 2 MeO2 = 2 HCHO + 2 HO2 : 9.5D-14*exp(390.D0/TEMP)/(1.+1./26.2*EXP(1130./TEMP)); {Tyn00} +{16} 2 MeO2 = HCHO + MeOH : 9.5D-14*exp(390.D0/TEMP)/(1.+26.2*EXP(-1130./TEMP)); {Tyn00} +{17} MeO2 + NO3 = HCHO + HO2 + NO2 : 1.3D-12; {Atk. 99} +{18} MeOOH + hv = HCHO + HO2 + OH : j(P_RJ_CH3OOH); +{19} MeOOH + OH = .7 MeO2 + .3 HCHO + .3 OH : 3.8D-12*exp(200.D0/TEMP); {JPL97} +{20} HCHO + hv {+ 2 O2} = CO + 2 HO2 : j(P_RJ_CHOH); +{21} HCHO + hv = CO {+ H2} : j(P_RJ_COH2); +{22} HCHO + OH = CO + HO2 + H2O : 1.D-11; {JPL97} +{23} HCHO + NO3 = HNO3 + CO + HO2 : 3.4D-13*exp(-1900.D0/TEMP); {JPL97, E/R ass. same as ALD+NO3} +{24} NO + O3 = NO2 {+O2} : 3.D-12*exp(-1500.D0/TEMP); {JPL2000} +{25} NO + HO2 = NO2 + OH : 3.5D-12*exp(250.D0/TEMP); {JPL97} +{26} NO2 + hv = NO + O3 : j(P_RJ_NO2); +{27} NO2 + O3 = NO3 : 1.2D-13*exp(-2450.D0/TEMP); {JPL97} +{28} NO2 + OH {+M} = HNO3 : TROE(F(2),TEMP,.933D0,2.85D-30,-2.67D0,3.13D-11, 363.D0);{Dransfield '99} +{29} NO2 + HO2 {+M} = HNO4 : RJPL(1.8D-31, 3.2D0, 4.7D-12, 1.4D0,F(2),TEMP);{JPL97} +{30} HNO3 + hv = OH + NO2 : j(P_RJ_HNO3); +{31} OH + HNO3 {+M} = NO3 : RHNO3(F(2),TEMP); {Brown '99b, JPL2000} +{32} NO3 + hv {+O2} = NO2 + O3 : j(P_RJ_NO2O); +{33} NO3 + hv = NO : j(P_RJ_NOO2); +{34} NO3 + NO = 2 NO2 : 1.5D-11*exp(170.D0/TEMP); {JPL97} +{35} NO3 + NO2 {+M} = N2O5 : RJPL(2.D-30,4.4D0,1.4D-12,0.7D0,F(2),TEMP);{JPL2000} +{36} NO3 + HO2 = .8 NO2 + .8 OH + .2 HNO3 : 3.5D-12;{JPL97, branching: see comment C14} +{37} N2O5 + hv = NO3 + NO2 : j(P_RJ_N2O5); +{38} N2O5 {+M} = NO3 + NO2 : RCONST(35)/(3.D-27*exp(10991.D0/TEMP));{JPL2000} +{39} N2O5 = 2 HNO3 : hetn2o5; {~10D-5,Dentener&Crutzen93} +{40} N2O5 + H2O = 2 HNO3 : 4.D-22; {JPL97;<2.D-21,from 3 studies, a 4th study gets <5.D-22} +{41} HNO4 + hv = .39 NO3 + .39 OH + .61 NO2 + .61 HO2 : j(P_RJ_HNO4);{Atk.97,S.Sander:.56 +-.17 NO2 yield} +{42} HNO4 {+M} = HO2 + NO2 : RCONST(29)/(2.1D-27*exp(10900.D0/TEMP)); {JPL97} +{43} HNO4 + OH = NO2 {+H2O +O2} : 1.3D-12*exp(380./TEMP); {JPL97} +{44} M{=H2} + OH {+O2} = HO2 + H2O : 5.31D-7*5.5D-12*exp(-2000.D0/TEMP);{JPL97, fixed H2 (531ppb) Novelli '99} +{45} MeOH + OH = HCHO + HO2 : 6.7D-12*exp(-600.D0/TEMP); {JPL97, possibly different products} +{PAN ------------------------------------------------------------------------------------------------------ } +{46} PA + HO2 = PAA : 4.3D-13*exp(1040.D0/TEMP)/(1.D0+1.D0/37.D0*exp(660.D0/TEMP)); {Tyn01} +{47} PA + HO2 = CH3COOH + O3 : 4.3D-13*exp(1040.D0/TEMP)/(1.D0+37.D0*exp(-660.D0/TEMP)); {Tyn01} +{48} PA + NO = MeO2 + NO2 {+CO2} : 8.1D-12*exp(270.D0/TEMP); {Tyn01} +{49} PA + NO2 = PAN : RJPL(8.5D-29,6.5D0,1.1D-11,1.0D0,F(2),TEMP); {Tyn01} +{50} PA + MeO2 = HCHO + HO2 + MeO2 {+CO2} : 2.0D-12*exp(500.D0/TEMP)/(1.D0+1.D0/2.2D6*exp(3820.D0/TEMP));{Tyn01,br.JPL97} +{51} PA + MeO2 = CH3COOH + HCHO : 2.0D-12*exp(500.D0/TEMP)/(1.D0+2.2D6* exp(-3820.D0/TEMP));{Tyn01,br.:JPL97} +{52} 2 PA = 2 MeO2 { + 2 CO2 +O2} : 2.5D-12*exp(500.D0/TEMP); {Tyn01} +{53} PA + NO3 = MeO2 + NO2 {+CO2} : 4.D-12; {K&S 96,MCM} +{54} PAA + hv = MeO2 + OH : j(P_RJ_CHOH);{rvk99,Giguerre&Olmos56 extrapol. 300-340nm} +{55} PAA + OH = PA : RCONST(19);{as MeOOH+OH, different products used in RACM} +{56} PAN + OH = HCHO + NO2 {+CO2} : 2.D-14; {JPL97:<4.D-14(products unknown), could probably skip this} +{57} PAN + hv = PA + NO2 : j(P_RJ_PAN); +{58} PAN {+M} = PA + NO2 : RCONST(49)/9.D-29*exp(-14000./TEMP); {JPL97} +{59} CH3COOH + OH = MeO2 {+CO2} : 4.D-13*exp(200.D0/TEMP); {JPL97} + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.k b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.k new file mode 100755 index 00000000..9fd4e7f4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.k @@ -0,0 +1,97 @@ +#MODEL pan +#INTEGRATOR ros3 +#DRIVER ./pan_drv + +#INLINE F_DECL_INT + REAL PRESS +#ENDINLINE + +#INLINE F95_UTIL_INT +!************** SPECIAL RATE FUNCTIONS ********************** + DOUBLE PRECISION FUNCTION RJPL( K0300, Q, KU300, R, M, T ) + IMPLICIT NONE + DOUBLE PRECISION k0300,q,ku300,r,m,t + DOUBLE PRECISION tt,k0,ku,k0m,kk,lgkk,e,f +! JPL standard three body reaction rate format extended + TT= T / 3.D2 + K0= K0300 * exp(-1.D0*Q*log(TT)) + KU= KU300 * exp(-1.D0*R*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926D0 * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(-0.5108256237659887D0*E) ! -0.51=log(0.6) + RJPL = F * K0M / ( 1.D0 + KK ) + END FUNCTION RJPL +!--------------------------------------------------------------------- +!TROE(FIX(I_M),TEMP,.933,2.85E-30,-2.67,3.13E-11,363.)!Dransfield et al.'99(GRL) this call in XYZ.eqn +!--------------------------------------------------------------------- + DOUBLE PRECISION FUNCTION TROE(M,T,beta,k0,k0e,kinf,Tc) + IMPLICIT NONE + DOUBLE PRECISION M,T,beta,k0,k0e,kinf,Tc + DOUBLE PRECISION k0t,bcrit,Trat,dN,N,Bx,F +! real Troe rate constants: for OH + NO2 -> HNO3, Dransfield et al. 1999 (GRL) + k0t = k0 * exp(k0e*log(T/3.D2)) + bcrit = beta*M*k0t/kinf + Trat = T/Tc + dN=sign(0.1D0-0.2605766891419492D0*Trat,1.D0-bcrit) ! 0.26=0.6*.434;log-->log10 + N = 0.75D0 + 0.5515539920171264D0*Trat ! 0.55=1.27*.434;log-->log10 + Bx = (0.43429448190324926D0*log(bcrit)-0.12D0) / (N+dN) + F = exp(-1.D0*Trat/(1. + Bx*Bx)) + TROE = k0t * (beta*M/(1.+bcrit)) * F + END FUNCTION TROE +!--------------------------------------------------------------------- + DOUBLE PRECISION FUNCTION RHNO3(M,T) + IMPLICIT NONE + DOUBLE PRECISION M,T + DOUBLE PRECISION K0,K2,K3 +! SPECIAL RATE CONSTANTS: OH + HNO3 {+M} --> NO3 +! taken from S. Brown et al. 1999 GRL, JPL 2000 + K0=2.4D-14*EXP(460.D0/T) + K2=2.7D-17*EXP(2199.D0/T) + K3=M*6.5D-34*EXP(1335.D0/T) + RHNO3 = K0 + K2 / ( 1 + K2/K3 ) + END FUNCTION RHNO3 +!--------------------------------------------------------------------- + DOUBLE PRECISION FUNCTION RHO2HO2(M,H2O,T) + IMPLICIT NONE + DOUBLE PRECISION M,H2O,T + DOUBLE PRECISION RX1,RX2,RX3 +! rate constant of the HO2 + HO2 --> H2O2 + O2 reaction + RX1= 2.3D-13 *EXP(600.D0/T) + RX2= 1.7D-33 *EXP(1000.D0/T) * M + RX3= 1.4D-21 *EXP(2200.D0/T) * H2O + RHO2HO2 = (RX1 + RX2)*(1.D0 + RX3) + END FUNCTION RHO2HO2 +!--------------------------------------------------------------------- + DOUBLE PRECISION FUNCTION PHUX(X,Y,Z,CHI) +! BERECHNUNG VON PHOTOLYSERATEN MIT EINEM ALGORITHMUS AUS +! ROETHS FLUX-PROGRAMM +! CHI IN RADIANT(BOGENMASS) +! X,Y,Z WERDEN VON ROETH UEBERNOMMEN +! X IST EINE MAXIMALPHOTOLYSERATE FUER CHI=0 +! KUHN 07.09.93 +!rvk: no minimal photolysis rate (use zero instead, since KPP has no problems with that) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,CHI,CHIZ,YCHIZ,MINYZ,EYCHIZ,EMINYZ + PARAMETER (MINYZ = -30.D0, EMINYZ = 9.357623D-14 ) !EMINYZ=EXP(MINYZ) + CHIZ = CHI * Z +! BERECHNUNG DES AUSDRUCKES NUR FUER CHIZ KLEINER PI/2 (COS > 0) + IF (CHIZ.LT.1.57079632679489D0) THEN + YCHIZ = Y * (1. - (1./ COS(CHIZ) ) ) +! SKALIERUNGSFAKTOR GROESSER EXP(-MINYZ) + IF (YCHIZ.GT.MINYZ) THEN + EYCHIZ = EXP (YCHIZ) + ELSE +! EYCHIZ = EMINYZ + EYCHIZ = 0.D0 + ENDIF + ELSE +! EYCHIZ = EMINYZ + EYCHIZ = 0.D0 + ENDIF + PHUX = X * EYCHIZ + if (PHUX.lt.1.D-10) PHUX = 0.D0 + END FUNCTION PHUX +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.spc new file mode 100755 index 00000000..169a7a49 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/pan.spc @@ -0,0 +1,28 @@ +#DEFVAR +{1} O3 = 3O ; {A: ozone} +{2} CH4 = C + 4H ; {A: methane} +{3} CO = C + O ; {A: carbon monoxide} +{4} H2O2 = 2H + 2O ; {A: hydrogen peroxide} +{5} HNO3 = H + N + 3O ; {A: nitric acid} +{6} MeOOH = C + 4H + 2O ; {A: methyl hydro peroxide} +{7} HCHO = C + 2H + O ; {A: formalydehyde} +{8} MeOH = C + 4H + O ; {A: methanol} +{c -- non advected species --- } +{9} O1D = O ; {N: oxygen atomic first singlet state} +{10} OH = O + H ; {N: hydroxyl radical} +{11} HO2 = H + 2O ; {N: perhydroxyl radical} +{12} NO = N + O ; {N:1 nitric oxide} +{13} NO2 = N + 2O ; {N:1 nitrogen dioxide} +{14} NO3 = N + 3O ; {N: nitrogen trioxide} +{15} N2O5 = 2N + 5O ; {N: dinitrogen pentoxide} +{16} HNO4 = H + 4O + N ; {N: HO2NO2 peroxynitric acid} +{17} MeO2 = C + 3H + 2O ; {N: methylperoxy radical} +{18} PAA = 2C + 4H + 3O; {A: peroxy acetylic acid} +{19} PAN = 2C + 3H + 5O + N; {A: peroxyacetylnitrate} +{20} PA = 2C + 3H + 3O; {N: peroxy acetyl radical} +{21} CH3COOH = 2C + 4H + 2O; {A: acetic acid} +OHCH2O2 = IGNORE ; +HCOOH = IGNORE ; +#DEFFIX +{1} H2O = H + 2O ; {water} +{2} M = IGNORE ; {third body} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.def new file mode 100755 index 00000000..35f6d4f2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.def @@ -0,0 +1,90 @@ +#include saprc99.spc +#include saprc99.eqn + + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER matlab +#HESSIAN ON} + +#LANGUAGE Fortran90 + +#LOOKATALL + +#MONITOR O3; NO; NO2; ETHENE; + +#INITVALUES + + CFACTOR = 2.4476e+13; + + ALL_SPEC = 0.0e0; + NO = 1.0e-1; + NO2 = 5.0e-2; + HONO = 1.e-3; + SO2 = 5.e-2; + HCHO = 1.121e-2; + CCHO = 2.316e-3; + RCHO = 1.72e-3; + ACET = 5.07e-3; + MEK = 3.26e-3; + MEOH = 5.89e-3; + GLY = 1.21e-4; + MGLY = 8.37e-5; + PHEN = 6.06e-4; + CRES = 5.60e-4; + BALD = 7.51e-5; + METHACRO = 1.30e-3; + ISOPROD = 8.93e-5; + PROD2 = 1.93e-3; + ETHENE = 1.89e-2; + ISOPRENE = 4.33e-4; + ALK1 = 1.167e-2; + ALK2 = 1.88e-2; + ALK3 = 4.69e-2; + ALK4 = 4.17e-2; + ALK5 = 3.06e-2; + ARO1 = 1.18e-2; + ARO2 = 8.74e-3; + OLE1 = 1.04e-2; + OLE2 = 7.97e-3; + TERP = 8.20e-4; + XC = 0.2E0; + CCO_OH = 1.16e-3; + RCO_OH = 3.92e-4; + HCOOH = 6.77e-4; + O3P = 7.843e-9; + H2O = 2.0e+04; + O2 = 2.09e+5; + AIR = 1.0e+6; + CH4 = 1.0e0; + +#INLINE F77_INIT + TSTART = 12.0D0*3600.0D0 + TEND = TSTART + 120.0D0*3600.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 12.0d0*3600.0d0 + TEND = TSTART + 120.0d0*3600.0d0 + DT = 3600.d0 + TEMP = 300.0d0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 12*3600; + TEND = TSTART + 120*3600; + DT = 3600; + TEMP = 300; +#ENDINLINE + +#INLINE C_INIT + TSTART = 12.0*3600.0; + TEND = TSTART + 120.0*3600.0; + DT = 3600.0; + TEMP = 300.0; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.eqn new file mode 100755 index 00000000..143fb5b0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.eqn @@ -0,0 +1,354 @@ +#Equations + +{1} NO2 + hv = NO + O3P : 6.69e-1*(SUN/60.0e0); +{2} O3P + O2 + AIR = O3 : ARR(5.68e-34,0.0e0,-2.80e0); +{3} O3P + O3 = 2O2 : ARR(8.00e-12,2060.0e0,0.0e0); +{4} O3P + NO + AIR = NO2 : ARR(1.00e-31,0.0e0,-1.60e0); +{5} O3P + NO2 = NO : ARR(6.50e-12,-120.0e0,0.0e0); +{6} O3P + NO2 = NO3 : FALL(9.00e-32,0.0e0,-2.00e0,2.20e-11,0.0e0,0.0e0,0.80e0); +{7} O3 + NO = NO2 : ARR(1.80e-12,1370.0e0,0.0e0); +{8} O3 + NO2 = NO3 : ARR(1.40e-13,2470.0e0,0.0e0); +{9} NO + NO3 = 2NO2 : ARR(1.80e-11,-110.0e0,0.0e0); +{10} NO + NO + O2 = 2NO2 : ARR(3.30e-39,-530.0e0,0.0e0); +{11} NO2 + NO3 = N2O5 : FALL(2.80e-30,0.0e0,-3.50e0,2.00e-12,0.0e0,0.20e0,0.45e0); +{12} N2O5 = NO2 + NO3 : FALL(1.e-3,11000.0e0,-3.5e0,9.7e+14,11080.0e0,0.1e0,0.45e0); +{13} N2O5 + H2O = 2HNO3 : (2.60e-22); +{14} NO2 + NO3 = NO + NO2 : ARR(4.50e-14,1260.0e0,0.0e0); +{15} NO3 + hv = NO : 1.59e0*(SUN/60.0e0); +{16} NO3 + hv = NO2 + O3P : 1.50e+1*(SUN/60.0e0); +{17} O3 + hv = O3P : 3.76e-2*(SUN/60.0e0); +{18} O3 + hv = O1D : 4.19e-3*(SUN/60.0e0); +{19} O1D + H2O = 2OH : (2.20e-10); +{20} O1D + AIR = O3P : ARR(2.09e-11,-95.0e0,0.0e0); +{21} OH + NO = HONO : FALL(7.00e-31,0.0e0,-2.60e0,3.60e-11,0.0e0,-0.10e0,0.60e0); +{22} HONO + hv = OH + NO : 1.27e-1*(SUN/60.0e0); +{23} HONO + hv = HO2 + NO2 : 1.60e-2*(SUN/60.0e0); +{24} OH + HONO = NO2 : ARR(2.70e-12,-260.0e0,0.0e0); +{25} OH + NO2 = HNO3 : FALL(2.43e-30, 0.0e0,-3.10e0,1.67e-11,0.0e0,-2.10e0,0.60e0); +{26} OH + NO3 = HO2 + NO2 : (2.00e-11); +{27} OH + HNO3 = NO3 : EP2(7.20e-15,-785.0e0,4.10e-16,-1440.0e0,1.90e-33,-725.0e0); +{28} HNO3 + hv = OH + NO2 : 5.40e-5*(SUN/60.0e0); +{29} OH + CO = HO2 : EP3(1.30e-13,0.0e0,3.19e-33,0.0e0); +{30} OH + O3 = HO2 : ARR(1.90e-12,1000.0e0,0.0e0); +{31} HO2 + NO = OH + NO2 : ARR(3.40e-12,-270.0e0,0.0e0); +{32} HO2 + NO2 = HNO4 : FALL(1.80e-31,0.0,-3.20,4.70e-12,0.0e0,0.0,0.6); +{33} HNO4 = HO2 + NO2 : FALL(4.10e-05,10650.0,0.0,5.7e+15,11170.0,0.0,0.5); +{34} HNO4 + hv = 0.61HO2 + 0.61NO2 + 0.39OH + + 0.39NO3 : 4.69e-4*(SUN/60.0e0); +{35} HNO4 + OH = NO2 : ARR(1.50e-12,-360.0e0,0.0e0); +{36} HO2 + O3 = OH : ARR(1.40e-14,600.0e0,0.0e0); +{37} HO2 + HO2 = H2O2 : EP3(2.20e-13,-600.0e0,1.85e-33,-980.0e0); +{38} HO2 + HO2 + H2O = H2O2 : EP3(3.08e-34,-2800.0e0,2.59e-54,-3180.0e0); +{39} NO3 + HO2 = 0.8OH + 0.8NO2 + 0.2HNO3 : (4.00e-12); +{40} NO3 + NO3 = 2NO2 : ARR(8.50e-13,2450.0e0,0.0e0); +{41} H2O2 + hv = 2OH : 5.64e-4*(SUN/60.0e0); +{42} H2O2 + OH = HO2 : ARR(2.90e-12,160.0e0,0.0e0); +{43} OH + HO2 = H2O + O2 : ARR(4.80e-11,-250.0e0,0.0e0); +{44} OH + SO2 = HO2 + H2SO4 : FALL(4.00e-31,0.0e0,-3.30e0,2.00e-12,0.0e0,0.0e0,0.45e0); +{45} OH + H2 = HO2 : ARR(7.70e-12,2100.0e0,0.0e0); +{46} C_O2 + NO = NO2 + HCHO + HO2 : ARR(2.80e-12,-285.0e0,0.0e0); +{47} C_O2 + HO2 = COOH : ARR(3.80e-13,-780.0e0,0.0e0); +{48} C_O2 + NO3 = HCHO + HO2 + NO2 : (1.30e-12); +{49} C_O2 + C_O2 = MEOH + HCHO : ARR(2.45e-14,-710.0e0,0.0e0); +{50} C_O2 + C_O2 = 2HCHO + 2HO2 : ARR(5.90e-13,509.0e0,0.0e0); +{51} RO2_R + NO = NO2 + HO2 : ARR(2.70e-12,-360.0e0,0.0e0); +{52} RO2_R + HO2 = ROOH : ARR(1.90e-13,-1300.0e0,0.0e0); +{53} RO2_R + NO3 = NO2 + HO2 : (2.30e-12); +{54} RO2_R + C_O2 = HO2 + 0.75HCHO + + 0.25MEOH : (2.00e-13); +{55} RO2_R + RO2_R = HO2 : (3.50e-14); +{56} R2O2 + NO = NO2 : ARR(2.70e-12,-360.0e0,0.0e0); +{57} R2O2 + HO2 = HO2 : ARR(1.90e-13,-1300.0e0,0.0e0); +{58} R2O2 + NO3 = NO2 : (2.30e-12); +{59} R2O2 + C_O2 = C_O2 : (2.00e-13); +{60} R2O2 + RO2_R = RO2_R : (3.50e-14); +{61} R2O2 + R2O2 = 2R2O2 : (0.0e0); +{62} RO2_N + NO = RNO3 : ARR(2.70e-12,-360.0e0,0.0e0); +{63} RO2_N + HO2 = ROOH : ARR(1.90e-13,-1300.0e0,0.0e0); +{64} RO2_N + C_O2 = HO2 + 0.25MEOH + + 0.5MEK + 0.5PROD2 + 0.75HCHO : (2.00e-13); +{65} RO2_N + NO3 = NO2 + HO2 + MEK : (2.30e-12); +{66} RO2_N + RO2_R = HO2 + 0.5MEK + + 0.5PROD2 : (3.50e-14); +{67} RO2_N + R2O2 = RO2_N : (3.50e-14); +{68} RO2_N + RO2_N = MEK + HO2 + PROD2 : (3.50e-14); +{69} CCO_O2 + NO2 = PAN : FALL(2.70e-28,0.0e0,-7.10e0,1.20e-11,0.0e0,-0.90e0,0.30e0); +{70} PAN = CCO_O2 + NO2 : FALL(4.90e-3,12100.0e0,0.0e0,4.0e+16,13600.0e0,0.e0,0.3e0); +{71} CCO_O2 + NO = C_O2 + NO2 : ARR(7.80e-12,-300.0e0,0.0e0); +{72} CCO_O2 + HO2 = 0.75CCO_OOH + + 0.25CCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{73} CCO_O2 + NO3 = C_O2 + NO2 : (4.00e-12); +{74} CCO_O2 + C_O2 = CCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{75} CCO_O2 + RO2_R = CCO_OH : (7.50e-12); +{76} CCO_O2 + R2O2 = CCO_O2 : (7.50e-12); +{77} CCO_O2 + RO2_N = CCO_OH + PROD2 : (7.50e-12); +{78} CCO_O2 + CCO_O2 = 2C_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{79} RCO_O2 + NO2 = PAN2 : ARR(1.20e-11,0.0e0,-0.90e0); +{80} PAN2 = RCO_O2 + NO2 : ARR(2.00e+15,12800.0e0,0.0e0); +{81} RCO_O2 + NO = NO2 + CCHO + RO2_R : ARR(1.25e-11,-240.0e0,0.0e0); +{82} RCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{83} RCO_O2 + NO3 = NO2 + CCHO + RO2_R : (4.00e-12); +{84} RCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{85} RCO_O2 + RO2_R = RCO_OH : (7.50e-12); +{86} RCO_O2 + R2O2 = RCO_O2 : (7.50e-12); +{87} RCO_O2 + RO2_N = RCO_OH + PROD2 : (7.50e-12); +{88} RCO_O2 + CCO_O2 = C_O2 + CCHO + RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{89} RCO_O2 + RCO_O2 = 2CCHO + 2RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{90} BZCO_O2 + NO2 = PBZN : (1.37e-11); +{91} PBZN = BZCO_O2 + NO2 : ARR(7.90e+16,14000.0e0,0.0e0); +{92} BZCO_O2 + NO = NO2 + BZ_O + R2O2 : ARR(1.25e-11,-240.0e0,0.0e0); +{93} BZCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{94} BZCO_O2 + NO3 = NO2 + BZ_O + R2O2 : (4.00e-12); +{95} BZCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{96} BZCO_O2 + RO2_R = RCO_OH : (7.50e-12); +{97} BZCO_O2 + R2O2 = BZCO_O2 : (7.50e-12); +{98} BZCO_O2 + RO2_N = RCO_OH + PROD2 : (7.50e-12); +{99} BZCO_O2 + CCO_O2 = C_O2 + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{100} BZCO_O2 + RCO_O2 = CCHO + RO2_R + + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{101} BZCO_O2 + BZCO_O2 = 2BZ_O + 2R2O2: ARR(2.90e-12,-500.0e0,0.0e0); +{102} MA_RCO3 + NO2 = MA_PAN : ARR(1.20e-11,0.0e0,-0.90e0); +{103} MA_PAN = MA_RCO3 + NO2 : ARR(1.60e+16,13486.0e0,0.0e0); +{104} MA_RCO3 + NO = NO2 + HCHO + CCO_O2 : ARR(1.25e-11,-240.0e0,0.0e0); +{105} MA_RCO3 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0e0,0.0e0); +{106} MA_RCO3 + NO3 = NO2 + HCHO + CCO_O2 : (4.00e-12); +{107} MA_RCO3 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0e0,0.0e0); +{108} MA_RCO3 + RO2_R = RCO_OH : (7.50e-12); +{109} MA_RCO3 + R2O2 = MA_RCO3 : (7.50e-12); +{110} MA_RCO3 + RO2_N = 2RCO_OH : (7.50e-12); +{111} MA_RCO3 + CCO_O2 = C_O2 + HCHO + + CCO_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{112} MA_RCO3 + RCO_O2 = HCHO + CCO_O2 + + CCHO + RO2_R : ARR(2.90e-12,-500.0e0,0.0e0); +{113} MA_RCO3 + BZCO_O2 = HCHO + CCO_O2 + + BZ_O + R2O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{114} MA_RCO3 + MA_RCO3 = 2HCHO + 2CCO_O2 : ARR(2.90e-12,-500.0e0,0.0e0); +{115} TBU_O + NO2 = RNO3 : (2.40e-11); +{116} TBU_O = ACET + C_O2 : ARR(7.50e+14,8152.0e0,0.0e0); +{117} BZ_O + NO2 = NPHE : ARR(2.30e-11,-150.0e0,0.0e0); +{118} BZ_O + HO2 = PHEN : ARR(1.90e-13,-1300.0e0,0.0e0); +{119} BZ_O = PHEN : (1.00e-03); +{120} BZNO2_O + NO2 = 2XN + 6XC: ARR(7.50e+14,8152.0e0,0.0e0); +{121} BZNO2_O + HO2 = NPHE : ARR(2.30e-11,-150.0e0,0.0e0); +{122} BZNO2_O = NPHE : ARR(1.90e-13,-1300.0e0,0.0e0); +{123} HCHO + hv = 2HO2 + CO : 2.32e-3*(SUN/60.0e0); +{124} HCHO + hv = CO : 3.15e-3*(SUN/60.0e0); +{125} HCHO + OH = HO2 + CO : ARR(8.60e-12,-20.0e0,0.0e0); +{126} HCHO + HO2 = HOCOO : ARR(9.70e-15,-625.0e0,0.0e0); +{127} HOCOO = HO2 + HCHO : ARR(2.40e+12,7000.0e0,0.0e0); +{128} HOCOO + NO = HCOOH + NO2 + HO2 : ARR(2.80e-12,-285.0e0,0.0e0); +{129} HCHO + NO3 = HNO3 + HO2 + CO : ARR(2.00e-12,2431.0e0,0.0e0); +{130} CCHO + OH = CCO_O2 : ARR(5.60e-12,-310.0e0,0.0e0); +{131} CCHO +hv = CO + HO2 + C_O2 : 4.16e-4*(SUN/60.0e0); +{132} CCHO + NO3 = HNO3 + CCO_O2 : ARR(1.40e-12,1860.0e0,0.0e0); +{133} RCHO + OH = 0.034RO2_R + 0.001RO2_N + + 0.965RCO_O2 + 0.034CO+ 0.034CCHO : (2.00e-11); +{134} RCHO + hv = CCHO + RO2_R + CO + HO2 : 1.40e-3*(SUN/60.0e0); +{135} RCHO + NO3 = HNO3 + RCO_O2 : ARR(1.40e-12,1771.0e0,0.0e0); +{136} ACET + OH = HCHO + CCO_O2 + R2O2 : ARR(1.10e-12,520.0e0,0.0e0); +{137} ACET + hv = CCO_O2 + C_O2 : 4.16e-5*(SUN/60.0e0); +{138} MEK + OH = 0.37RO2_R + 0.042RO2_N + + 0.616R2O2+ 0.492CCO_O2 + + 0.096RCO_O2 + 0.115HCHO + + 0.482CCHO + 0.37RCHO : ARR(1.30e-12,25.0e0,2.0e0); +{139} MEK + hv = CCO_O2 + CCHO + RO2_R : 9.49e-4*(1.50e-1*SUN/60.0e0); +{140} MEOH + OH = HCHO + HO2 : ARR(3.10e-12,360.0e0,2.0e0); +{141} COOH + OH = 0.35HCHO + 0.35OH + + 0.65C_O2 : ARR(2.90e-12,-190.0e0,0.0e0); +{142} COOH + hv = HCHO + HO2 + OH : 3.94e-4*(SUN/60.0e0); +{143} ROOH + OH = RCHO + 0.34RO2_R + + 0.66OH : (1.10e-11); +{144} ROOH + hv = RCHO + HO2 + OH : 3.94e-4*(SUN/60.0e0); +{145} GLY + hv = 2CO+ 2HO2 : 8.93e-3*(SUN/60.0e0); +{146} GLY + hv = HCHO + CO : 1.81e-1*(6.00e-3*SUN/60.0e0); +{147} GLY + OH = 0.63HO2 + 1.26CO+ + 0.37RCO_O2 : (1.10e-11); +{148} GLY + NO3 = HNO3 + 0.63HO2 + + 1.26CO+ 0.37RCO_O2 : ARR(2.80e-12,2376.0e0,0.0e0); +{149} MGLY + hv = HO2 + CO + CCO_O2 : 1.10e-2*(SUN/60.0e0); +{150} MGLY + OH = CO + CCO_O2 : 1.50e-11; +{151} MGLY + NO3 = HNO3 + CO + CCO_O2 : ARR(1.40e-12,1895.0e0,0.0e0); +{152} BACL + hv = 2CCO_O2 : 1.90e-2*(SUN/60.0e0); +{153} PHEN + OH = 0.24BZ_O + 0.76RO2_R + + 0.23GLY : (2.63e-11); +{154} PHEN + NO3 = HNO3 + BZ_O : (3.78e-12); +{155} CRES + OH = 0.24BZ_O + 0.76RO2_R + + 0.23MGLY : (4.20e-11); +{156} CRES + NO3 = HNO3 + BZ_O : (1.37e-11); +{157} NPHE + NO3 = HNO3 + BZNO2_O : (3.78e-12); +{158} BALD + OH = BZCO_O2 : (1.29e-11); +{159} BALD + hv = 7XC: 6.22e-2*(5.00e-2*SUN/60.0e0); +{160} BALD + NO3 = HNO3 + BZCO_O2 : ARR(1.40e-12,1872.0e0,0.0e0); +{161} METHACRO + OH = 0.5RO2_R + 0.416CO+ + 0.084HCHO + 0.416MEK + + 0.084MGLY + 0.5MA_RCO3 : ARR(1.86e-11,-176.0e0,0.0e0); +{162} METHACRO + O3 = 0.008HO2 + 0.1RO2_R + + 0.208OH + 0.1RCO_O2 + 0.45CO+ + 0.2HCHO + 0.9MGLY + 0.333HCOOH : ARR(1.36e-15,2114.0e0,0.0e0); +{163} METHACRO + NO3 = 0.5HNO3 + 0.5RO2_R + + 0.5CO+ 0.5MA_RCO3 : ARR(1.50e-12,1726.0e0,0.0e0); +{164} METHACRO + O3P = RCHO : (6.34e-12); +{165} METHACRO + hv = 0.34HO2 + 0.33RO2_R + + 0.33OH + 0.67CCO_O2 + 0.67CO+ + 0.67HCHO + 0.33MA_RCO3 : 3.32e-2*(4.10e-3*SUN/60.0e0); +{166} MVK + OH = 0.3RO2_R + 0.025RO2_N + + 0.675R2O2+ 0.675CCO_O2 + + 0.3HCHO + 0.675RCHO + 0.3MGLY : ARR(4.14e-12,-453.0e0,0.0e0); +{167} MVK + O3 = 0.064HO2 + 0.05RO2_R + + 0.164OH + 0.05RCO_O2 + 0.475CO+ + 0.1HCHO + 0.95MGLY + 0.351HCOOH : ARR(7.51e-16,1520.0e0,0.0e0); +{168} MVK + O3P = 0.45RCHO + 0.55MEK : (4.32e-12); +{169} MVK + hv = 0.3C_O2 + 0.7CO+ 0.7PROD2 + + 0.3MA_RCO3 : 3.32e-2*(2.10e-3*SUN/60.0e0); +{170} ISOPROD + OH = 0.67RO2_R + + 0.041RO2_N + 0.289MA_RCO3 + + 0.336CO+ 0.055HCHO + 0.129CCHO + + 0.013RCHO + 0.15MEK + 0.332PROD2 + + 0.15GLY + 0.174MGLY : (6.19e-11); +{171} ISOPROD + O3 = 0.4HO2 + 0.048RO2_R + + 0.048RCO_O2 + 0.285OH + + 0.498CO+ 0.125HCHO + 0.047CCHO + + 0.21MEK + 0.023GLY + 0.742MGLY + + 0.1HCOOH + 0.372RCO_OH : (4.18e-18); +{172} ISOPROD + NO3 = 0.799RO2_R + + 0.051RO2_N + 0.15MA_RCO3 + 0.572CO+ + 0.15HNO3 + 0.227HCHO + 0.218RCHO + + 0.008MGLY + 0.572RNO3 : (1.00e-13); +{173} ISOPROD + hv = 1.233HO2 + 0.467CCO_O2 + + 0.3RCO_O2 + 1.233CO+ 0.3HCHO + + 0.467CCHO + 0.233MEK : 3.32e-2*(4.10e-3*SUN/60.0e0); +{174} PROD2 + OH = 0.379HO2 + 0.473RO2_R + + 0.07RO2_N + 0.029CCO_O2 + + 0.049RCO_O2 + 0.213HCHO + + 0.084CCHO + 0.558RCHO + + 0.115MEK + 0.329PROD2 : (1.50e-11); +{175} PROD2 + hv = 0.96RO2_R + 0.04RO2_N + + 0.515R2O2+ 0.667CCO_O2 + + 0.333RCO_O2 + 0.506HCHO + + 0.246CCHO + 0.71RCHO : 9.49e-4*(2.00e-2*SUN/60.0e0); +{176} RNO3 + OH = 0.338NO2 + 0.113HO2 + + 0.376RO2_R + 0.173RO2_N + + 0.596R2O2+ 0.01HCHO + + 0.439CCHO + 0.213RCHO + + 0.006ACET + 0.177MEK + + 0.048PROD2 + 0.31RNO3 : (7.80e-12); +{177} RNO3 + hv = NO2 + 0.341HO2 + 0.564RO2_R + + 0.095RO2_N + 0.152R2O2+ 0.134HCHO + + 0.431CCHO + 0.147RCHO + 0.02ACET + + 0.243MEK + 0.435PROD2 : 2.35e-4*(SUN/60.0e0); +{178} DCB1 + OH = RCHO + RO2_R + CO : (5.00e-11); +{179} DCB1 + O3 = 1.5HO2 + 0.5OH + + 1.5CO + GLY : (2.00e-18); +{180} DCB2 + OH = R2O2 + RCHO + CCO_O2 : (5.00e-11); +{181} DCB2 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 2.06e-1*(3.65e-1*SUN/60.0e0); +{182} DCB3 + OH = R2O2 + RCHO + CCO_O2 : (5.00e-11); +{183} DCB3 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 3.32e-2*(7.28e0*SUN/60.0e0); +{184} CH4 + OH = C_O2 : ARR(2.15e-12,1735.0e0,0.0e0); +{185} ETHENE + OH = RO2_R + 1.61HCHO + + 0.195CCHO : ARR(1.96e-12,-438.0e0,0.0e0); +{186} ETHENE + O3 = 0.12OH + 0.12HO2 + + 0.5CO+ HCHO + 0.37HCOOH : ARR(9.14e-15,2580.0e0,0.0e0); +{187} ETHENE + NO3 = RO2_R + RCHO : ARR(4.39e-13,2282.0e0,2.0e0); +{188} ETHENE + O3P = 0.5HO2 + 0.2RO2_R + + 0.3C_O2 + 0.491CO+ 0.191HCHO + + 0.25CCHO + 0.009GLY : ARR(1.04e-11,792.0e0,0.0e0); +{189} ISOPRENE + OH = 0.907RO2_R + + 0.093RO2_N + 0.079R2O2+ + 0.624HCHO + 0.23METHACRO + + 0.32MVK + 0.357ISOPROD : ARR(2.50e-11,-408.0e0,0.0e0); +{190} ISOPRENE + O3 = 0.266OH + + 0.066RO2_R + 0.008RO2_N + + 0.126R2O2+ 0.192MA_RCO3 + + 0.275CO+ 0.592HCHO + 0.1PROD2 + + 0.39METHACRO + 0.16MVK + + 0.204HCOOH + 0.15RCO_OH : ARR(7.86e-15,1912.0e0,0.0e0); +{191} ISOPRENE + NO3 = 0.187NO2 + + 0.749RO2_R + 0.064RO2_N + + 0.187R2O2+ 0.936ISOPROD : ARR(3.03e-12,448.0e0,0.0e0); +{192} ISOPRENE + O3P = 0.01RO2_N + + 0.24R2O2+ 0.25C_O2 + 0.24MA_RCO3 + + 0.24HCHO + 0.75PROD2 : (3.60e-11); +{193} TERP + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2 : ARR(1.83e-11,-449.0e0,0.0e0); +{194} TERP + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : ARR(1.08e-15,821.0e0,0.0e0); +{195} TERP + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : ARR(3.66e-12,-175.e00,0.0e0); +{196} TERP + O3P = 0.147RCHO + 0.853PROD2 : (3.27e-11); +{197} ALK1 + OH = RO2_R + CCHO : ARR(1.37e-12,498.0e0,2.0e0); +{198} ALK2 + OH = 0.246OH + 0.121HO2 + + 0.612RO2_R + 0.021RO2_N + + 0.16CO + 0.039HCHO + 0.155RCHO + + 0.417ACET + + 0.248GLY + 0.121HCOOH : ARR(9.87e-12,671.0e0,0.0e0); +{199} ALK3 + OH = 0.695RO2_R + 0.07RO2_N + + 0.559R2O2+ 0.236TBU_O + 0.026HCHO + + 0.445CCHO + 0.122RCHO + 0.024ACET + + 0.332MEK : ARR(1.019e-11,434.0e0,0.0e0); +{200} ALK4 + OH = 0.835RO2_R + 0.143RO2_N + + 0.936R2O2+ 0.011C_O2 + 0.011CCO_O2 + + 0.002CO+ 0.024HCHO + 0.455CCHO + + 0.244RCHO + 0.452ACET + 0.11MEK + + 0.125PROD2 : ARR(5.946e-12,91.0e0,0.0e0); +{201} ALK5 + OH = 0.653RO2_R + 0.347RO2_N + + 0.948R2O2+ 0.026HCHO + 0.099CCHO + + 0.204RCHO + 0.072ACET + 0.089MEK + + 0.417PROD2 : ARR(1.112e-11,52.0e0,0.0e0); +{202} ARO1 + OH = 0.224HO2 + 0.765RO2_R + + 0.011RO2_N + 0.055PROD2 + 0.118GLY + + 0.119MGLY + 0.017PHEN + 0.207CRES + + 0.059BALD + 0.491DCB1 + 0.108DCB2 + + 0.051DCB3 : ARR(1.81e-12,-355.0e0,0.0e0); +{203} ARO2 + OH = 0.187HO2 + 0.804RO2_R + + 0.009RO2_N + 0.097GLY + 0.287MGLY + + 0.087BACL + 0.187CRES + 0.05BALD + + 0.561DCB1 + 0.099DCB2 + 0.093DCB3 : (2.640e-11); +{204} OLE1 + OH = 0.91RO2_R + 0.09RO2_N + + 0.205R2O2+ 0.732HCHO + 0.294CCHO + + 0.497RCHO + 0.005ACET + 0.119PROD2 : ARR(7.095e-12,-451.0e0,0.0e0); +{205} OLE1 + O3 = 0.155OH + 0.056HO2 + + 0.022RO2_R + 0.001RO2_N + + 0.076C_O2 + 0.345CO+ 0.5HCHO + + 0.154CCHO + 0.363RCHO + 0.001ACET + + 0.215PROD2 + 0.185HCOOH + + 0.05CCO_OH + 0.119RCO_OH : ARR(2.617e-15,1640.0e0,0.0e0); +{206} OLE1 + NO3 = 0.824RO2_R + 0.176RO2_N + + 0.488R2O2+ 0.009CCHO + 0.037RCHO + + 0.024ACET + 0.511RNO3 : ARR(4.453e-14,376.0e0,0.0e0); +{207} OLE1 + O3P = 0.45RCHO + 0.437MEK + + 0.113PROD2 : ARR(1.074e-11,234.0e0,0.0e0); +{208} OLE2 + OH = 0.918RO2_R + 0.082RO2_N + + 0.001R2O2+ 0.244HCHO + 0.732CCHO + + 0.511RCHO + 0.127ACET + 0.072MEK + + 0.061BALD + 0.025METHACRO + + 0.025ISOPROD : ARR(1.743e-11,-384.0e0,0.0e0); +{209} OLE2 + O3 = 0.378OH + 0.003HO2 + + 0.033RO2_R + 0.002RO2_N + 0.137R2O2+ + 0.197C_O2 + 0.137CCO_O2 + + 0.006RCO_O2 + 0.265CO+ 0.269HCHO + + 0.456CCHO + 0.305RCHO + 0.045ACET + + 0.026MEK + 0.043PROD2 + 0.042BALD + + 0.026METHACRO + 0.019MVK + + 0.073HCOOH + 0.129CCO_OH + + 0.247RCO_OH : ARR(5.022e-16,461.0e0,0.0e0); +{210} OLE2 + NO3 = 0.391NO2 + 0.442RO2_R + + 0.136RO2_N + 0.711R2O2+ 0.03C_O2 + + 0.079HCHO + 0.507CCHO + 0.151RCHO + + 0.102ACET + 0.001MEK + 0.015BALD + + 0.048MVK + 0.321RNO3 : (7.265e-13); +{211} OLE2 + O3P = 0.013HO2 + 0.012RO2_R + + 0.001RO2_N + 0.012CO+ 0.069RCHO + + 0.659MEK + 0.259PROD2 + + 0.012METHACRO : (2.085e-11); diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.spc new file mode 100755 index 00000000..f7c9745d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprc99.spc @@ -0,0 +1,87 @@ +#include atoms + +#DEFVAR + + O3 = 3O; + H2O2 = 2H + 2O; + NO = N + O; + NO2 = N + 2O; + NO3 = N + 3O; + N2O5 = 2N + 5O; + HONO = H + 2O + N; + HNO3 = H + N + 3O; + HNO4 = H + N + 4O; + SO2 = S + 2O; + H2SO4 = 2H + S + 4O; + CO = C + O; + HCHO = 2H + C + O; + CCHO = 2C + H + O; + RCHO = 3C + IGNORE; + ACET = IGNORE; + MEK = IGNORE; + HCOOH = 2H + C + 2O; + MEOH = IGNORE; + CCO_OH = IGNORE; + RCO_OH = IGNORE; + GLY = IGNORE; + MGLY = 3C + 4H + 2O; + BACL = IGNORE; + CRES = IGNORE; + BALD = IGNORE; + ISOPROD = IGNORE; + METHACRO = IGNORE; + MVK = IGNORE; + PROD2 = IGNORE; + DCB1 = IGNORE; + DCB2 = IGNORE; + DCB3 = IGNORE; + ETHENE = 2C + 4H; + ISOPRENE = IGNORE; + ALK1 = IGNORE; + ALK2 = IGNORE; + ALK3 = IGNORE; + ALK4 = IGNORE; + ALK5 = IGNORE; + ARO1 = IGNORE; + ARO2 = IGNORE; + OLE1 = IGNORE; + OLE2 = IGNORE; + TERP = IGNORE; + RNO3 = IGNORE; + NPHE = IGNORE; + PHEN = IGNORE; + PAN = 2C + 3H + 5O + N; + PAN2 = N + IGNORE; + PBZN = N + IGNORE; + MA_PAN = N + IGNORE; + CCO_OOH = 2C + 3O + H; + RCO_O2 = IGNORE; + RCO_OOH = IGNORE; + XN = IGNORE; + XC = IGNORE; + O3P = O; + O1D = O; + OH = H + O; + HO2 = H+ 2O; + C_O2 = IGNORE; + COOH = C + 2O + H; + ROOH = IGNORE; + RO2_R = IGNORE; + R2O2 = IGNORE; + RO2_N = IGNORE; + HOCOO = H + 3O + C; + CCO_O2 = IGNORE; + BZCO_O2 = IGNORE; + BZNO2_O = IGNORE; + BZ_O = IGNORE; + MA_RCO3 = IGNORE; + TBU_O = IGNORE; + + + +#DEFFIX + AIR = IGNORE; + O2 = 2O; + H2O = 2H + O; + H2 = 2H; + CH4 = C + 4H; diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.def new file mode 100755 index 00000000..5b3a669a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.def @@ -0,0 +1,79 @@ +#include saprcnov.spc +#include saprcnov.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL +#MONITOR O3; + +#INITVALUES + + CFACTOR = 2.4476E+13; + + ALl_SPEC = 0.0E0; + NO = 1.0E-1; + NO2 = 5.0E-2; + HONO = 1.E-3; + SO2 = 5.E-2; + ISOPRENE = 4.33E-4; + TERP = 8.20E-4; + ETHENE = 1.89E-2; + MEOH = 5.89E-3; + HCOOH = 6.77E-4; + CCO_OH = 1.16E-3; + RCO_OH = 3.92E-4; + HCHO = 1.12E-2; + CCHO = 2.32E-3; + RCHO = 1.72E-3; + GLY = 1.21E-4; + MGLY = 8.37E-5; + METHACRO = 1.30E-3; + ISOPROD = 8.93E-5; + BALD = 7.51E-5; + ACET = 5.07E-3; + MEK = 3.26E-3; + PROD2 = 1.93E-3; + PHEN = 6.06E-4; + CRES = 5.60E-4; + ALK3 = 4.69E-2; + ALK4 = 4.17E-2; + ALK5 = 3.06E-2; + ARO1 = 1.18E-2; + ARO2 = 8.74E-3; + OLE1 = 1.04E-2; + OLE2 = 7.97E-3; + CH4 = 0.07E0; + H2O = 2.0E+04; + O2 = 2.09E+5; + AIR = 1.0E6; + +#INLINE F77_INIT + TSTART = 0.0D0 + TEND = TSTART + 2*24*3600.0D0 ! 2160.0D0*60.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0.0D0 + TEND = TSTART + 2*24*3600.0D0 ! 2160.0D0*60.0D0 + DT = 3600.D0 + TEMP = 300.0D0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0.0; + TEND = TSTART + 2*24*3600.0D0; + DT = 3600.0; + TEMP = 300.00; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0.0; + TEND = TSTART + 2*24*3600.0D0; /*+ 2160.0*60.0;*/ + DT = 3600.0; + TEMP = 300.00; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.eqn new file mode 100755 index 00000000..7cf3f4a5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.eqn @@ -0,0 +1,385 @@ +#Equations + +{1} NO2 + hv = NO + O3P : 1.0*SUN; +{2} O3P + O2 + AIR = O3 : ARR(5.68e-34,0.0,-2.80); +{3} O3P + O3 = 2O2 : ARR(8.00e-12,2060.0,0.0); +{4} O3P + NO + AIR = NO2 : ARR(1.00e-31,0.0,-1.60); +{5} O3P + NO2 = NO : ARR(6.50e-12,-120.0,0.0); +{6} O3P + NO2 = NO3 : FALL(9.00e-32,0.0,-2.00,2.20e-11,0.0,0.0,0.80); +{7} O3 + NO = NO2 : ARR(1.80e-12,1370.0,0.0); +{8} O3 + NO2 = NO3 : ARR(1.40e-13,2470.0,0.0); +{9} NO + NO3 = 2NO2 : ARR(1.80e-11,-110.0,0.0); +{10} NO + NO + O2 = 2NO2 : ARR(3.30e-39,-530.0,0.0); +{11} NO2 + NO3 = N2O5 : FALL(2.80e-30,0.0,-3.50,2.00e-12,0.0,0.20,0.45); +{12} N2O5 = NO2 + NO3 : FALL(1.e-3,11000.0,-3.5,9.7e14,11080.0,0.1,0.45); +{13} N2O5 + H2O = 2HNO3 : 2.60e-22; +{14} NO2 + NO3 = NO + NO2 : ARR(4.50e-14,1260.0,0.0); +{15} NO3 + hv = NO : 1.0*SUN; +{16} NO3 + hv = NO2 + O3P : 1.0*SUN; +{17} O3 + hv = O3P : 1.0*SUN; +{18} O3 + hv = O1D : 1.0*SUN; +{19} O1D + H2O = 2OH : 2.20e-10; +{20} O1D + AIR = O3P : ARR(2.09e-11,-95.0,0.0); +{21} OH + NO = HONO : FALL(7.00e-31,0.0,-2.60,3.60e-11,0.0,-0.10,0.60); +{22} HONO + hv = OH + NO : 1.0*SUN; +{23} HONO + hv = HO2 + NO2 : 1.0*SUN; +{24} OH + HONO = NO2 : ARR(2.70e-12,-260.0,0.0); +{25} OH + NO2 = HNO3 : FALL(2.43e-30, 0.0,-3.10,1.67e-11,0.0,-2.10,0.60); +{26} OH + NO3 = HO2 + NO2 : 2.00e-11; +{27} OH + HNO3 = NO3 : EP2(7.20e-15,-785.0,4.10e-16,-1440.0,1.90e-33,-725.0); +{28} HNO3 + hv = OH + NO2 : 1.0*SUN; +{29} OH + CO = HO2 : EP3(1.30e-13,0.0,3.19e-33,0.0); +{30} OH + O3 = HO2 : ARR(1.90e-12,1000.0,0.0); +{31} HO2 + NO = OH + NO2 : ARR(3.40e-12,-270.0,0.0); +{32} HO2 + NO2 = HNO4 : FALL(1.80e-31,0.0,-3.20,4.70e-12,0.0,0.0,0.60); +{33} HNO4 = HO2 + NO2 : FALL(4.10e-05,10650.0,0.0,5.7e+15,11170.0,0.0,0.5); +{34} HNO4 + hv = 0.61HO2 + 0.61NO2 + 0.39OH + + 0.39NO3 : 1.0*SUN; +{35} HNO4 + OH = NO2 : ARR(1.50e-12,-360.0,0.0); +{36} HO2 + O3 = OH : ARR(1.40e-14,600.0,0.0); +{37} HO2 + HO2 = H2O2 : EP3(2.20e-13,-600.0,1.85e-33,-980.0); +{38} HO2 + HO2 + H2O = H2O2 : EP3(3.08e-34,-2800.0,2.59e-54,-3180.0); +{39} NO3 + HO2 = 0.8OH + 0.8NO2 + 0.2HNO3 : 4.00e-12; +{40} NO3 + NO3 = 2NO2 : ARR(8.50e-13,2450.0,0.0); +{41} H2O2 + hv = 2OH : 1.0*SUN; +{42} H2O2 + OH = HO2 : ARR(2.90e-12,160.0,0.0); +{43} OH + HO2 = H2O + O2 : ARR(4.80e-11,-250.0,0.0); +{44} OH + SO2 = HO2 + H2SO4 : FALL(4.00e-31,0.0,-3.30,2.00e-12,0.0,0.0,0.45); +{45} OH + H2 = HO2 : ARR(7.70e-12,2100.0,0.0); +{46} C_O2 + NO = NO2 + HCHO + HO2 : ARR(2.80e-12,-285.0,0.0); +{47} C_O2 + HO2 = COOH : ARR(3.80e-13,-780.0,0.0); +{48} C_O2 + NO3 = HCHO + HO2 + NO2 : 1.30e-12; +{49} C_O2 + C_O2 = MEOH + HCHO : ARR(2.45e-14,-710.0,0.0); +{50} C_O2 + C_O2 = 2HCHO + 2HO2 : ARR(5.90e-13,509.0,0.0); +{51} RO2_R + NO = NO2 + HO2 : ARR(2.70e-12,-360.0,0.0); +{52} RO2_R + HO2 = ROOH : ARR(1.90e-13,-1300.0,0.0); +{53} RO2_R + NO3 = NO2 + HO2 : 2.30e-12; +{54} RO2_R + C_O2 = HO2 + 0.75HCHO + + 0.25MEOH : 2.00e-13; +{55} RO2_R + RO2_R = HO2 : 3.50e-14; +{56} R2O2 + NO = NO2 : ARR(2.70e-12,-360.0,0.0); {1.0*RCONST(51);} +{57} R2O2 + HO2 = HO2 : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{58} R2O2 + NO3 = NO2 : 2.30e-12; {1.0*RCONST(53);} +{59} R2O2 + C_O2 = C_O2 : 2.00e-13; {1.0*RCONST(54);} +{60} R2O2 + RO2_R = RO2_R : 3.50e-14; {1.0*RCONST(55);} +{61} R2O2 + R2O2 = 2R2O2 : 0.0; +{62} RO2_N + NO = RNO3 : ARR(2.70e-12,-360.0,0.0); {1.0*RCONST(51);} +{63} RO2_N + HO2 = ROOH : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{64} RO2_N + C_O2 = HO2 + 0.25MEOH + + 0.5MEK + 0.5PROD2 + 0.75HCHO : 2.00e-13; {1.0*RCONST(54);} +{65} RO2_N + NO3 = NO2 + HO2 + MEK : 2.30e-12; {1.0*RCONST(53);} +{66} RO2_N + RO2_R = HO2 + 0.5MEK + + 0.5PROD2 : 3.50e-14; {1.0*RCONST(55);} +{67} RO2_N + R2O2 = RO2_N : 3.50e-14; {1.0*RCONST(55);} +{68} RO2_N + RO2_N = MEK + HO2 + PROD2 : 3.50e-14; {1.0*RCONST(55);} +{69} CCO_O2 + NO2 = PAN : FALL(2.70e-28,0.0,-7.10,1.20e-11,0.0,-0.90,0.30); +{70} PAN = CCO_O2 + NO2 : FALL(4.90e-3,12100.0,0.0,4.0e+16,13600.0,0.,0.3); +{71} CCO_O2 + NO = C_O2 + NO2 : ARR(7.80e-12,-300.0,0.0); +{72} CCO_O2 + HO2 = 0.75CCO_OOH + + 0.25CCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); +{73} CCO_O2 + NO3 = C_O2 + NO2 : 4.00e-12; +{74} CCO_O2 + C_O2 = CCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); +{75} CCO_O2 + RO2_R = CCO_OH : 7.50e-12; +{76} CCO_O2 + R2O2 = CCO_O2 : 7.50e-12; +{77} CCO_O2 + RO2_N = CCO_OH + PROD2 : 7.50e-12; +{78} CCO_O2 + CCO_O2 = 2C_O2 : ARR(2.90e-12,-500.0,0.0); +{79} RCO_O2 + NO2 = PAN2 : ARR(1.20e-11,0.0,-0.90); +{80} PAN2 = RCO_O2 + NO2 : ARR(2.00e+15,12800.0,0.0); +{81} RCO_O2 + NO = NO2 + CCHO + RO2_R : ARR(1.25e-11,-240.0,0.0); +{82} RCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{83} RCO_O2 + NO3 = NO2 + CCHO + RO2_R : 4.00e-12; {1.0*RCONST(73);} +{84} RCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{85} RCO_O2 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{86} RCO_O2 + R2O2 = RCO_O2 : 7.50e-12; {1.0*RCONST(75);} +{87} RCO_O2 + RO2_N = RCO_OH + PROD2 : 7.50e-12; {1.0*RCONST(75);} +{88} RCO_O2 + CCO_O2 = C_O2 + CCHO + RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{89} RCO_O2 + RCO_O2 = 2CCHO + 2RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{90} BZCO_O2 + NO2 = PBZN : 1.37e-11; +{91} PBZN = BZCO_O2 + NO2 : ARR(7.90e+16,14000.0,0.0); +{92} BZCO_O2 + NO = NO2 + BZ_O + R2O2 : ARR(1.25e-11,-240.0,0.0); {1.0*RCONST(81);} +{93} BZCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{94} BZCO_O2 + NO3 = NO2 + BZ_O + R2O2 : 4.00e-12; {1.0*RCONST(73);} +{95} BZCO_O2 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{96} BZCO_O2 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{97} BZCO_O2 + R2O2 = BZCO_O2 : 7.50e-12; {1.0*RCONST(75);} +{98} BZCO_O2 + RO2_N = RCO_OH + PROD2 : 7.50e-12; {1.0*RCONST(75);} +{99} BZCO_O2 + CCO_O2 = C_O2 + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{100} BZCO_O2 + RCO_O2 = CCHO + RO2_R + + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{101} BZCO_O2 + BZCO_O2 = 2BZ_O + 2R2O2: ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{102} MA_RCO3 + NO2 = MA_PAN : ARR(1.20e-11,0.0,-0.90); {1.0*RCONST(79);} +{103} MA_PAN = MA_RCO3 + NO2 : ARR(1.60e+16,13486.0,0.0); +{104} MA_RCO3 + NO = NO2 + HCHO + CCO_O2 : ARR(1.25e-11,-240.0,0.0); {1.0*RCONST(81);} +{105} MA_RCO3 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : ARR(4.30e-13,-1040.0,0.0); {1.0*RCONST(72);} +{106} MA_RCO3 + NO3 = NO2 + HCHO + CCO_O2 : 4.00e-12; {1.0*RCONST(73);} +{107} MA_RCO3 + C_O2 = RCO_OH + HCHO : ARR(1.80e-12,-500.0,0.0); {1.0*RCONST(74);} +{108} MA_RCO3 + RO2_R = RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{109} MA_RCO3 + R2O2 = MA_RCO3 : 7.50e-12; {1.0*RCONST(75);} +{110} MA_RCO3 + RO2_N = 2RCO_OH : 7.50e-12; {1.0*RCONST(75);} +{111} MA_RCO3 + CCO_O2 = C_O2 + HCHO + + CCO_O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{112} MA_RCO3 + RCO_O2 = HCHO + CCO_O2 + + CCHO + RO2_R : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{113} MA_RCO3 + BZCO_O2 = HCHO + CCO_O2 + + BZ_O + R2O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{114} MA_RCO3 + MA_RCO3 = 2HCHO + 2CCO_O2 : ARR(2.90e-12,-500.0,0.0); {1.0*RCONST(78);} +{115} TBU_O + NO2 = RNO3 : 2.40e-11; +{116} TBU_O = ACET + C_O2 : ARR(7.50e+14,8152.0,0.0); +{117} BZ_O + NO2 = NPHE : ARR(2.30e-11,-150.0,0.0); +{118} BZ_O + HO2 = PHEN : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(52);} +{119} BZ_O = PHEN : 1.00e-03; +{120} BZNO2_O + NO2 = 2XN + 6XC: ARR(7.50e+14,8152.0,0.0); {1.0*RCONST(116);} +{121} BZNO2_O + HO2 = NPHE : ARR(2.30e-11,-150.0,0.0); {1.0*RCONST(117);} +{122} BZNO2_O = NPHE : ARR(1.90e-13,-1300.0,0.0); {1.0*RCONST(118);} +{123} HCHO + hv = 2HO2 + CO : 1.0*SUN; +{124} HCHO + hv = CO : 1.0*SUN; +{125} HCHO + OH = HO2 + CO : ARR(8.60e-12,-20.0,0.0); +{126} HCHO + HO2 = HOCOO : ARR(9.70e-15,-625.0,0.0); +{127} HOCOO = HO2 + HCHO : ARR(2.40e+12,7000.0,0.0); +{128} HOCOO + NO = HCOOH + NO2 + HO2 : ARR(2.80e-12,-285.0,0.0); {1.0*RCONST(46);} +{129} HCHO + NO3 = HNO3 + HO2 + CO : ARR(2.00e-12,2431.0,0.0); +{130} CCHO + OH = CCO_O2 : ARR(5.60e-12,-310.0,0.0); +{131} CCHO +hv = CO + HO2 + C_O2 : 1.0*SUN; +{132} CCHO + NO3 = HNO3 + CCO_O2 : ARR(1.40e-12,1860.0,0.0); +{133} RCHO + OH = 0.034RO2_R + 0.001RO2_N + + 0.965RCO_O2 + 0.034CO+ 0.034CCHO : 2.00e-11; +{134} RCHO + hv = CCHO + RO2_R + CO + HO2 : 1.0*SUN; +{135} RCHO + NO3 = HNO3 + RCO_O2 : ARR(1.40e-12,1771.0,0.0); +{136} ACET + OH = HCHO + CCO_O2 + R2O2 : ARR(1.10e-12,520.0,0.0); +{137} ACET + hv = CCO_O2 + C_O2 : 1.0*SUN; +{138} MEK + OH = 0.37RO2_R + 0.042RO2_N + + 0.616R2O2+ 0.492CCO_O2 + + 0.096RCO_O2 + 0.115HCHO + + 0.482CCHO + 0.37RCHO : ARR(1.30e-12,25.0,2.0); +{139} MEK + hv = CCO_O2 + CCHO + RO2_R : 1.50e-1*SUN; +{140} MEOH + OH = HCHO + HO2 : ARR(3.10e-12,360.0,2.0); +{141} ETOH + OH = 0.95HO2 + 0.05RO2_R + + 0.081HCHO + 0.96CCHO : ARR(0.0,0.0,1.0); +{142} COOH + OH = 0.35HCHO + 0.35OH + + 0.65C_O2 : ARR(2.90e-12,-190.0,0.0); +{143} COOH + hv = HCHO + HO2 + OH : 1.0*SUN; +{144} ROOH + OH = RCHO + 0.34RO2_R + + 0.66OH : 1.10e-11; +{145} ROOH + hv = RCHO + HO2 + OH : 1.0*SUN; +{146} GLY + hv = 2CO+ 2HO2 : 1.0*SUN; +{147} GLY + hv = HCHO + CO : 6.00e-3*SUN; +{148} GLY + OH = 0.63HO2 + 1.26CO+ + 0.37RCO_O2 : 1.10e-11; +{149} GLY + NO3 = HNO3 + 0.63HO2 + + 1.26CO+ 0.37RCO_O2 : ARR(2.80e-12,2376.0,0.0); +{150} MGLY + hv = HO2 + CO + CCO_O2 : 1.0*SUN; +{151} MGLY + OH = CO + CCO_O2 : 1.50e-11; +{152} MGLY + NO3 = HNO3 + CO + CCO_O2 : ARR(1.40e-12,1895.0,0.0); +{153} BACL + hv = 2CCO_O2 : 1.0*SUN; +{154} PHEN + OH = 0.24BZ_O + 0.76RO2_R + + 0.23GLY : 2.63e-11; +{155} PHEN + NO3 = HNO3 + BZ_O : 3.78e-12; +{156} CRES + OH = 0.24BZ_O + 0.76RO2_R + + 0.23MGLY : 4.20e-11; +{157} CRES + NO3 = HNO3 + BZ_O : 1.37e-11; +{158} NPHE + NO3 = HNO3 + BZNO2_O : 2.63e-11; {1.0*RCONST(154);} +{159} BALD + OH = BZCO_O2 : 1.29e-11; +{160} BALD + hv = 7XC: 5.00e-2*SUN; +{161} BALD + NO3 = HNO3 + BZCO_O2 : ARR(1.40e-12,1872.0,0.0); +{162} METHACRO + OH = 0.5RO2_R + 0.416CO+ + 0.084HCHO + 0.416MEK + + 0.084MGLY + 0.5MA_RCO3 : ARR(1.86e-11,-176.0,0.0); +{163} METHACRO + O3 = 0.008HO2 + 0.1RO2_R + + 0.208OH + 0.1RCO_O2 + 0.45CO+ + 0.2HCHO + 0.9MGLY + 0.333HCOOH : ARR(1.36e-15,2114.0,0.0); +{164} METHACRO + NO3 = 0.5HNO3 + 0.5RO2_R + + 0.5CO+ 0.5MA_RCO3 : ARR(1.50e-12,1726.0,0.0); +{165} METHACRO + O3P = RCHO : 6.34e-12; +{166} METHACRO + hv = 0.34HO2 + 0.33RO2_R + + 0.33OH + 0.67CCO_O2 + 0.67CO+ + 0.67HCHO + 0.33MA_RCO3 : 4.10e-3*SUN; +{167} MVK + OH = 0.3RO2_R + 0.025RO2_N + + 0.675R2O2+ 0.675CCO_O2 + + 0.3HCHO + 0.675RCHO + 0.3MGLY : ARR(4.14e-12,-453.0,0.0); +{168} MVK + O3 = 0.064HO2 + 0.05RO2_R + + 0.164OH + 0.05RCO_O2 + 0.475CO+ + 0.1HCHO + 0.95MGLY + 0.351HCOOH : ARR(7.51e-16,1520.0,0.0); +{169} MVK + O3P = 0.45RCHO + 0.55MEK : 4.32e-12; +{170} MVK + hv = 0.3C_O2 + 0.7CO+ 0.7PROD2 + + 0.3MA_RCO3 : 2.10e-3*SUN; +{171} ISOPROD + OH = 0.67RO2_R + + 0.041RO2_N + 0.289MA_RCO3 + + 0.336CO+ 0.055HCHO + 0.129CCHO + + 0.013RCHO + 0.15MEK + 0.332PROD2 + + 0.15GLY + 0.174MGLY : 6.19e-11; +{172} ISOPROD + O3 = 0.4HO2 + 0.048RO2_R + + 0.048RCO_O2 + 0.285OH + + 0.498CO+ 0.125HCHO + 0.047CCHO + + 0.21MEK + 0.023GLY + 0.742MGLY + + 0.1HCOOH + 0.372RCO_OH : 4.18e-18; +{173} ISOPROD + NO3 = 0.799RO2_R + + 0.051RO2_N + 0.15MA_RCO3 + 0.572CO+ + 0.15HNO3 + 0.227HCHO + 0.218RCHO + + 0.008MGLY + 0.572RNO3 : 1.00e-13; +{174} ISOPROD + hv = 1.233HO2 + 0.467CCO_O2 + + 0.3RCO_O2 + 1.233CO+ 0.3HCHO + + 0.467CCHO + 0.233MEK : 4.10e-3*SUN; +{175} PROD2 + OH = 0.379HO2 + 0.473RO2_R + + 0.07RO2_N + 0.029CCO_O2 + + 0.049RCO_O2 + 0.213HCHO + + 0.084CCHO + 0.558RCHO + + 0.115MEK + 0.329PROD2 : 1.50e-11; +{176} PROD2 + hv = 0.96RO2_R + 0.04RO2_N + + 0.515R2O2+ 0.667CCO_O2 + + 0.333RCO_O2 + 0.506HCHO + + 0.246CCHO + 0.71RCHO : 2.00e-2*SUN; +{177} RNO3 + OH = 0.338NO2 + 0.113HO2 + + 0.376RO2_R + 0.173RO2_N + + 0.596R2O2+ 0.01HCHO + + 0.439CCHO + 0.213RCHO + + 0.006ACET + 0.177MEK + + 0.048PROD2 + 0.31RNO3 : 7.80e-12; +{178} RNO3 + hv = NO2 + 0.341HO2 + 0.564RO2_R + + 0.095RO2_N + 0.152R2O2+ 0.134HCHO + + 0.431CCHO + 0.147RCHO + 0.02ACET + + 0.243MEK + 0.435PROD2 : 1.0*SUN; +{179} DCB1 + OH = RCHO + RO2_R + CO : 5.00e-11; +{180} DCB1 + O3 = 1.5HO2 + 0.5OH + + 1.5CO + GLY : 2.00e-18; +{181} DCB2 + OH = R2O2 + RCHO + CCO_O2 : 5.00e-11; +{182} DCB2 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 3.65e-1*SUN; +{183} DCB3 + OH = R2O2 + RCHO + CCO_O2 : 5.00e-11; +{184} DCB3 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 7.28*SUN; +{185} CH4 + OH = C_O2 : ARR(2.15e-12,1735.0,0.0); +{186} ETHENE + OH = RO2_R + 1.61HCHO + + 0.195CCHO : ARR(1.96e-12,-438.0,0.0); +{187} ETHENE + O3 = 0.12OH + 0.12HO2 + + 0.5CO+ HCHO + 0.37HCOOH : ARR(9.14e-15,2580.0,0.0); +{188} ETHENE + NO3 = RO2_R + RCHO : ARR(4.39e-13,2282.0,2.0); +{189} ETHENE + O3P = 0.5HO2 + 0.2RO2_R + + 0.3C_O2 + 0.491CO+ 0.191HCHO + + 0.25CCHO + 0.009GLY : ARR(1.04e-11,792.0,0.0); +{190} ISOPRENE + OH = 0.907RO2_R + + 0.093RO2_N + 0.079R2O2+ + 0.624HCHO + 0.23METHACRO + + 0.32MVK + 0.357ISOPROD : ARR(2.50e-11,-408.0,0.0); +{191} ISOPRENE + O3 = 0.266OH + + 0.066RO2_R + 0.008RO2_N + + 0.126R2O2+ 0.192MA_RCO3 + + 0.275CO+ 0.592HCHO + 0.1PROD2 + + 0.39METHACRO + 0.16MVK + + 0.204HCOOH + 0.15RCO_OH : ARR(7.86e-15,1912.0,0.0); +{192} ISOPRENE + NO3 = 0.187NO2 + + 0.749RO2_R + 0.064RO2_N + + 0.187R2O2+ 0.936ISOPROD : ARR(3.03e-12,448.0,0.0); +{193} ISOPRENE + O3P = 0.01RO2_N + + 0.24R2O2+ 0.25C_O2 + 0.24MA_RCO3 + + 0.24HCHO + 0.75PROD2 : 3.60e-11; +{194} TERP + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2 : ARR(1.83e-11,-449.0,0.0); +{195} TERP + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : ARR(1.08e-15,821.0,0.0); +{196} TERP + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : ARR(3.66e-12,-175.0,0.0); +{197} TERP + O3P = 0.147RCHO + 0.853PROD2 : 3.27e-11; +{198} C2H6 + OH = RO2_R + CCHO : ARR(1.37e-12,498.0,2.0); +{199} C3H8 + OH = 0.965RO2_R + 0.035RO2_N + + 0.261RCHO + 0.704ACET : ARR(0.0,0.0,1.0); +{200} C2H2 + OH = 0.603OH + 0.297HO2 + + 0.1RO2_R + 0.393CO + 0.096HCHO + + 0.607GLY + 0.297HCOOH : ARR(9.87e-12,671.0,0.0); +{201} ALK3 + OH = 0.695RO2_R + 0.07RO2_N + + 0.559R2O2+ 0.236TBU_O + 0.026HCHO + + 0.445CCHO + 0.122RCHO + 0.024ACET + + 0.332MEK : ARR(1.019e-11,434.0,0.0); +{202} ALK4 + OH = 0.835RO2_R + 0.143RO2_N + + 0.936R2O2+ 0.011C_O2 + 0.011CCO_O2 + + 0.002CO+ 0.024HCHO + 0.455CCHO + + 0.244RCHO + 0.452ACET + 0.11MEK + + 0.125PROD2 : ARR(5.946e-12,91.0,0.0); +{203} ALK5 + OH = 0.653RO2_R + 0.347RO2_N + + 0.948R2O2+ 0.026HCHO + 0.099CCHO + + 0.204RCHO + 0.072ACET + 0.089MEK + + 0.417PROD2 : ARR(1.112e-11,52.0,0.0); +{204} ARO1 + OH = 0.224HO2 + 0.765RO2_R + + 0.011RO2_N + 0.055PROD2 + 0.118GLY + + 0.119MGLY + 0.017PHEN + 0.207CRES + + 0.059BALD + 0.491DCB1 + 0.108DCB2 + + 0.051DCB3 : ARR(1.81e-12,-355.0,0.0); +{205} ARO2 + OH = 0.187HO2 + 0.804RO2_R + + 0.009RO2_N + 0.097GLY + 0.287MGLY + + 0.087BACL + 0.187CRES + 0.05BALD + + 0.561DCB1 + 0.099DCB2 + 0.093DCB3 : (2.640e-11); +{206} OLE1 + OH = 0.91RO2_R + 0.09RO2_N + + 0.205R2O2+ 0.732HCHO + 0.294CCHO + + 0.497RCHO + 0.005ACET + 0.119PROD2 : ARR(7.095e-12,-451.0,0.0); +{207} OLE1 + O3 = 0.155OH + 0.056HO2 + + 0.022RO2_R + 0.001RO2_N + + 0.076C_O2 + 0.345CO+ 0.5HCHO + + 0.154CCHO + 0.363RCHO + 0.001ACET + + 0.215PROD2 + 0.185HCOOH + + 0.05CCO_OH + 0.119RCO_OH : ARR(2.617e-15,1640.0,0.0); +{208} OLE1 + NO3 = 0.824RO2_R + 0.176RO2_N + + 0.488R2O2+ 0.009CCHO + 0.037RCHO + + 0.024ACET + 0.511RNO3 : ARR(4.453e-14,376.0,0.0); +{209} OLE1 + O3P = 0.45RCHO + 0.437MEK + + 0.113PROD2 : ARR(1.074e-11,234.0,0.0); +{210} OLE2 + OH = 0.918RO2_R + 0.082RO2_N + + 0.001R2O2+ 0.244HCHO + 0.732CCHO + + 0.511RCHO + 0.127ACET + 0.072MEK + + 0.061BALD + 0.025METHACRO + + 0.025ISOPROD : ARR(1.743e-11,-384.0,0.0); +{211} OLE2 + O3 = 0.378OH + 0.003HO2 + + 0.033RO2_R + 0.002RO2_N + 0.137R2O2+ + 0.197C_O2 + 0.137CCO_O2 + + 0.006RCO_O2 + 0.265CO+ 0.269HCHO + + 0.456CCHO + 0.305RCHO + 0.045ACET + + 0.026MEK + 0.043PROD2 + 0.042BALD + + 0.026METHACRO + 0.019MVK + + 0.073HCOOH + 0.129CCO_OH + + 0.247RCO_OH : ARR(5.022e-16,461.0,0.0); +{212} OLE2 + NO3 = 0.391NO2 + 0.442RO2_R + + 0.136RO2_N + 0.711R2O2+ 0.03C_O2 + + 0.079HCHO + 0.507CCHO + 0.151RCHO + + 0.102ACET + 0.001MEK + 0.015BALD + + 0.048MVK + 0.321RNO3 : 7.265e-13; +{213} OLE2 + O3P = 0.013HO2 + 0.012RO2_R + + 0.001RO2_N + 0.012CO+ 0.069RCHO + + 0.659MEK + 0.259PROD2 + + 0.012METHACRO : 2.085e-11; +{214} C2H2 + O3 = 0.5OH + 1.5HO2 + + 1.5CO + 0.5CO2 : 2.20e-10; +{215} C3H6 + OH = 0.984RO2_R + 0.016RO2_N + + 0.984HCHO + 0.984CCHO + 0.048XC : 2.20e-10; +{216} C3H6 + O3 = 0.32OH + 0.06HO2 + + 0.26C_O2 + 0.51CO + 0.135CO2 + 0.5HCHO + + 0.5CCHO + 0.185HCOOH + 0.17CCO_OH + 0.07XC: 2.20e-10; +{217} C3H6 + NO3 = 0.949RO2_R + 0.051RO2_N + + 2.693XC + 1.0XN : 2.20e-10; +{218} C3H6 + O3P = 0.45RCHO + 0.55MEK + + 0.55XC: 2.20e-10; +{219} SO2 = H2SO4 : 2.20e-10; +{220} HO2 = AIR : 7.00e-7; +{221} SO2 = AIR : 2.20e-10; +{222} H2SO4 = AIR : 2.20e-10; +{223} HNO3 = AIR : 2.20e-10; +{224} H2O2 = AIR : 2.20e-10; +{225} BC = AIR : 7.00e-7; +{226} OC = AIR : 7.00e-7; +{227} SSF = AIR : 7.00e-7; +{228} SSC = AIR : 7.00e-7; +{229} PM10 = AIR : 7.00e-7; +{230} PM25 = AIR : 7.00e-7; +{231} DST1 = AIR : 7.00e-7; +{232} DST2 = AIR : 7.00e-7; +{233} DST3 = AIR : 7.00e-7; +{234} DMS = AIR : 7.00e-7; +{235} CO2 = AIR : 7.00e-7; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.spc new file mode 100755 index 00000000..cc634393 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/saprcnov.spc @@ -0,0 +1,101 @@ +#include atoms + + #DEFVAR + O3 = 3O ; + H2O2 = 2H + 2O ; + NO = N + O ; + NO2 = N + 2O ; + NO3 = N + 3O ; + N2O5 = 2N + 5O ; + HONO = H + 2O + N ; + HNO3 = H + N + 3O ; + HNO4 = H + N + 4O ; + SO2 = S + 2O ; + H2SO4 = 2H + S + 4O ; + CO = C + O ; + HCHO = 2H + C + O ; + CCHO = 2C + H + O ; + RCHO = 3C + ignore ; + ACET = ignore ; + MEK = ignore ; + HCOOH = 2H + C + 2O ; + MEOH = ignore ; + ETOH = ignore ; + CCO_OH = ignore ; + RCO_OH = ignore ; + GLY = ignore ; + MGLY = 3C + 4H + 2O ; + BACL = ignore ; + CRES = ignore ; + BALD = ignore ; + ISOPROD = ignore ; + METHACRO = ignore ; + MVK = ignore ; + PROD2 = ignore ; + DCB1 = ignore ; + DCB2 = ignore ; + DCB3 = ignore ; + ETHENE = 2C + 4H ; + ISOPRENE = ignore ; + C2H6 = 2C + 6H ; + C3H8 = 3C + 8H ; + C2H2 = 2C + 2H ; + C3H6 = 3C + 6H ; + ALK3 = ignore ; + ALK4 = ignore ; + ALK5 = ignore ; + ARO1 = ignore ; + ARO2 = ignore ; + OLE1 = ignore ; + OLE2 = ignore ; + TERP = ignore ; + RNO3 = ignore ; + NPHE = ignore ; + PHEN = ignore ; + PAN = 2C + 3H + 5O + N ; + PAN2 = N + ignore ; + PBZN = N + ignore ; + MA_PAN = N + ignore ; + BC = C ; + OC = C ; + SSF = ignore ; + SSC = ignore ; + PM10 = ignore ; + PM25 = ignore ; + DMS = ignore ; + DST1 = ignore ; + DST2 = ignore ; + DST3 = ignore ; + CO2 = C + 2O ; + CCO_OOH = 2C + 3O + H ; + RCO_O2 = ignore ; + RCO_OOH = ignore ; + XN = ignore ; + XC = ignore ; + O3P = O ; + O1D = O ; + OH = H + O ; + HO2 = H+ 2O ; + C_O2 = ignore ; + COOH = C + 2O + H ; + ROOH = ignore ; + RO2_R = ignore ; + R2O2 = ignore ; + RO2_N = ignore ; + HOCOO = H + 3O + C ; + CCO_O2 = ignore ; + BZCO_O2 = ignore ; + BZNO2_O = ignore ; + BZ_O = ignore ; + MA_RCO3 = ignore ; + TBU_O = ignore ; + + +#DEFFIX + AIR = ignore ; + N2 = 2N ; + O2 = 2O ; + H2O = 2H + O ; + H2 = 2H ; + CH4 = C + 4H ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.def new file mode 100755 index 00000000..6bad0625 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.def @@ -0,0 +1,59 @@ +#include small_strato.spc +#include small_strato.eqn + + +//#LANGUAGE Fortran77 {Output Language} +//#DOUBLE ON {Double Precision} +//#JACOBIAN SPARSE_LU_ROW {Use Sparse DATA STRUCTURES} + +//#INTEGRATOR rodas3 +//#DRIVER general + + +#LOOKATALL {File Output} +#MONITOR O3;N;O2;O;NO;O1D;NO2; {Screen Output} + +#CHECK O; N; {Check Mass Balance} + +#INITVALUES {Initial Values} + +CFACTOR = 1. ; {Conversion Factor} +O1D = 9.906E+01 ; +O = 6.624E+08 ; +O3 = 5.326E+11 ; +O2 = 1.697E+16 ; +NO = 8.725E+08 ; +NO2 = 2.240E+08 ; +M = 8.120E+16 ; + +#INLINE F77_INIT + TSTART = (12*3600) + TEND = TSTART + (3*24*3600) + DT = 0.25*3600 + TEMP = 270 +#ENDINLINE + +#INLINE F90_INIT + TSTART = (12*3600) + TEND = TSTART + (3*24*3600) + DT = 0.25*3600 + TEMP = 270 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = (12*3600); + TEND = TSTART + (3*24*3600); + DT = 0.25*3600; + TEMP = 270; +#ENDINLINE + + +#INLINE C_INIT + TSTART = (12*3600); + TEND = TSTART + (3*24*3600); + DT = 0.25*3600; + TEMP = 270; +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.eqn new file mode 100755 index 00000000..8c9b530d --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.eqn @@ -0,0 +1,15 @@ +#EQUATIONS { Small Stratospheric Mechanism } + + + O2 + hv = 2O : (2.643E-10) * SUN*SUN*SUN; + O + O2 = O3 : (8.018E-17); + O3 + hv = O + O2 : (6.120E-04) * SUN; + O + O3 = 2O2 : (1.576E-15); + O3 + hv = O1D + O2 : (1.070E-03) * SUN*SUN; + O1D + M = O + M : (7.110E-11); + O1D + O3 = 2O2 : (1.200E-10); + NO + O3 = NO2 + O2 : (6.062E-15); + NO2 + O = NO + O2 : (1.069E-11); + NO2 + hv = NO + O : (1.289E-02) * SUN; + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.kpp b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.kpp new file mode 100755 index 00000000..c28866b0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.kpp @@ -0,0 +1,10 @@ +#MODEL small_strato +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.spc new file mode 100755 index 00000000..b18cb4f9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/small_strato.spc @@ -0,0 +1,17 @@ +#include atoms + +#DEFVAR +O = O; { Oxygen atomic ground state } +O1D = O; { Oxygen atomic excited state } +O3 = O + O + O; { Ozone } +NO = N + O; { Nitric oxide } +NO2 = N + O + O; { Nitrogen dioxide } + + +#DEFFIX +M = O + O + N + N;{ Atmospheric generic molecule } +O2 = O + O; { Molecular oxygen } + + + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.def new file mode 100755 index 00000000..a35a2cc8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.def @@ -0,0 +1,49 @@ +#include smog.spc +#include smog.eqn + +{#LANGUAGE Fortran77 +#INTEGRATOR rodas3 +#DRIVER general} + +#LOOKATALL +#MONITOR O3; + +#INITVALUES + +CFACTOR = 1.; +ALL_SPEC = 1.0E-8; +RH = 2.0 ; +RCHO = 2.0 ; +NO = 0.5 ; +NO2 = 0.1 ; +H2O = 1.3E+4 ; +O2 = 2.0E+5 ; + +#INLINE F77_INIT + TSTART = 0 + TEND = TSTART + 600 + DT = 60.0 + TEMP = 298 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0 + TEND = TSTART + 600 + DT = 60.0 + TEMP = 298 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0; + TEND = TSTART + 600; + DT = 60.0; + TEMP = 298; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0; + TEND = TSTART + 600; + DT = 60.0; + TEMP = 298; +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.eqn b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.eqn new file mode 100755 index 00000000..8aa6d696 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.eqn @@ -0,0 +1,17 @@ +#EQUATIONS + +{ A Generalized Reaction Mechanism for Photochemical Smog } + +{ 1.} NO2 + hv = NO + O : 0.533 ; +{ 2.} O + O2 = O3 : 2.183E-5 ; +{ 3.} NO + O3 = NO2 + O2 : 26.59 ; +{ 4.} RH + OH = RO2 + H2O : 3.775E+3 ; +{ 5.} RCHO + OH = RCOO2 + H2O : 2.341E+4 ; +{ 6.} RCHO + hv = RO2 + HO2 + CO : 1.91E-4 ; +{ 7.} HO2 + NO = NO2 + OH : 1.214E+4 ; +{ 8.} RO2 + NO = NO2 + RCHO + HO2 : 1.127E+4 ; +{ 9.} RCOO2 + NO = NO2 + RO2 + CO2 : 1.127E+4 ; +{10.} OH + NO2 = HNO3 : 1.613E+4 ; +{11.} RCOO2 + NO2 = RCOO2NO2 : 6.893E+3 ; +{12.} RCOO2NO2 = RCOO2 + NO2 : 2.143E-2 ; + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.spc b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.spc new file mode 100755 index 00000000..fa070ef9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/smog.spc @@ -0,0 +1,37 @@ +#include atoms + + #DEFVAR + O = O ; {oxygen atomic ground state (3P)} + O3 = 3O ; {ozone} + NO = N + O ; {nitric oxide} + NO2 = N + 2O ; {nitrogen dioxide} + NO3 = N + 3O ; {nitrogen trioxide} + N2O5 = 2N + 5O ; {dinitrogen pentoxide} + HNO3 = H + N + 3O ; { nitric acid } + HNO4 = H + N + 4O ; {HO2NO2 pernitric acid} + H = H ; {hydrogen atomic ground state (2S)} + OH = O + H ; {hydroxyl radical} + HO2 = H + 2O ; {perhydroxyl radical} + H2O2 = 2H + 2O ; {hydrogen peroxide} + CH3 = C + 3H ; {methyl radical} + CH3O = C + 3H + O ; {methoxy radical} + CH3O2 = C + 3H + 2O ; {methylperoxy radical} + CH3OOH = C + 4H + 2O ; {CH4O2 methylperoxy alcohol} + HCO = H + C + O ; {CHO formyl radical} + CH2O = C + 2H + O ; {formalydehyde} + + RH = ignore ; + RO2 = ignore ; + RCHO = ignore ; + RCOO2 = ignore ; + RCOO2NO2 = ignore ; + +#DEFFIX + H2O = H + 2O ; {water} + H2 = 2H ; {molecular hydrogen} + O2 = 2O ; {molecular oxygen} + N2 = 2N ; {molecular nitrogen} + CH4 = C + 4H ; {methane} + CO = C + O ; {carbon monoxide} + CO2 = C + 2O ; {carbon dioxide} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/stochastic_dimer.def b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/stochastic_dimer.def new file mode 100755 index 00000000..56959750 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/test/stochastic_dimer.def @@ -0,0 +1,62 @@ +{Decaying-dimerizing reaction set + (Gillespie, J. Chem. Phys. 115(4), p. 1716, 2001)} + +#DEFVAR +S1 = ignore; {} +S2 = ignore; {} +S3 = ignore; {} + +#EQUATIONS +S1 = PROD : (1); {c1} +S1 + S1 = S2 : (0.004);{2*c2} +S2 = S1 + S1 : (0.5); {c3} +S2 = S3 : (0.04); {c4} + +#LOOKATALL + +#INITVALUES + CFACTOR = 1.0; + S1 = 1.0e+5; + S2 = 0.0; + S3 = 0.0; + +#INLINE F77_INIT + TSTART = 0.d0 + TEND = 30.0d0 + DT = 0.5d0; + DO i=1,NVAR + RTOL(i) = 1.0e-4 + ATOL(i) = 1.0e-8 + END DO + Volume = 1.0d0 +#ENDINLINE + +#INLINE F90_INIT + TSTART = 0.d0 + TEND = 30.0d0 + DT = 0.5d0 + RTOL(1:NVAR) = 1.0e-4 + ATOL(1:NVAR) = 1.0e-8 + Volume = 1.0d0 +#ENDINLINE + +#INLINE MATLAB_INIT + global TSTART TEND DT TEMP + TSTART = 0; + TEND = 30; + DT = 0.5; + RTOL(1:NVAR) = 1.0e-4; + ATOL(1:NVAR) = 1.0e-8; + Volume = 1; +#ENDINLINE + +#INLINE C_INIT + TSTART = 0.0; + TEND = 30.0; + DT = 0.5; + for(i=0; i (y) ? (x) : (y) + +void mexFunction( int nlhs, mxArray *plhs[], + int nrhs, const mxArray *prhs[] ) +{ + int mrows, mcols; + KPP_REAL *V, *F, *RCT, *Vdot; + +/* Check for the right number and size of input arguments */ + if ( nrhs != 3 ) { + mexErrMsgTxt("KPP_ROOT_Fun requires 3 input vectors: V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)"); + } + mrows = mxGetM(prhs[0]); mcols = mxGetN(prhs[0]); + if ( ( mrows != KPP_NVAR )||( mcols != 1 ) ) { + mexPrintf("First KPP_ROOT_Fun input argument is of size V(%d,%d).", + mrows, mcols); + mexErrMsgTxt("First KPP_ROOT_Fun input argument should be a column vector V(KPP_NVAR,1)"); + } + mrows = mxGetM(prhs[1]); mcols = mxGetN(prhs[1]); + if ( ( mrows != KPP_NFIX )||( mcols != 1 ) ) { + mexPrintf("Second KPP_ROOT_Fun input argument is of size F(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Second KPP_ROOT_Fun input argument should be a column vector F(KPP_NFIX,1)"); + } + mrows = mxGetM(prhs[2]); mcols = mxGetN(prhs[2]); + if ( ( mrows != KPP_NREACT )||( mcols != 1 ) ) { + mexPrintf("Third KPP_ROOT_Fun input argument is of size RCT(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Third KPP_ROOT_Fun input argument should be a column vector RCT(KPP_NREACT,1)"); + } + +/* Check for the right number of output arguments */ + if ( nlhs != 1 ) { + mexErrMsgTxt("KPP_ROOT_Fun requires 1 output column vector: Vdot(KPP_NVAR)"); + } + + V = mxGetPr(prhs[0]); + F = mxGetPr(prhs[1]); + RCT = mxGetPr(prhs[2]); + + plhs[0] = mxCreateDoubleMatrix(KPP_NVAR,1,mxREAL); + Vdot = mxGetPr(plhs[0]); + + Fun( V, F, RCT, Vdot ); + +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f new file mode 100755 index 00000000..d76126c1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f @@ -0,0 +1,44 @@ + +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Matlab Gateway for the Derivative Function Fun +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, VdotPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL Vdot(KPP_NVAR) + +C Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Fun requires 3 input vectors: + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +C Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Fun requires 1 output vector: + &Vdot(KPP_NVAR)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_NVAR,1,0) + + VPtr = mxGetPr(prhs(1)) + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)) + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)) + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + VdotPtr = mxGetPr(plhs(1)) + + CALL Fun( V, F, RCT, Vdot ) + + CALL mxCopyReal8ToPtr(Vdot, VdotPtr, KPP_NVAR) + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f90 new file mode 100755 index 00000000..19ebb7d5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Fun.f90 @@ -0,0 +1,45 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Matlab Gateway for the Derivative Function Fun +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Model + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, VdotPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL Vdot(KPP_NVAR) + +! Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Fun requires 3 input vectors: & + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +! Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Fun requires 1 output vector: & + &Vdot(KPP_NVAR)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_NVAR,1,0) + + VPtr = mxGetPr(prhs(1)) + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)) + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)) + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + VdotPtr = mxGetPr(plhs(1)) + + CALL Fun( V, F, RCT, Vdot ) + + CALL mxCopyReal8ToPtr(Vdot, VdotPtr, KPP_NVAR) + + END SUBROUTINE mexFunction diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.c new file mode 100755 index 00000000..14b52db8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.c @@ -0,0 +1,54 @@ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Matlab Gateway for the Hessian +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + +#include "mex.h" +#define min( x, y ) (x) < (y) ? (x) : (y) +#define max( x, y ) (x) > (y) ? (x) : (y) + +void mexFunction( int nlhs, mxArray *plhs[], + int nrhs, const mxArray *prhs[] ) +{ + int mrows, mcols; + KPP_REAL *V, *F, *RCT, *HESS; + + +/* Check for the right number and size of input arguments */ + if ( nrhs != 3 ) { + mexErrMsgTxt("KPP_ROOT_Hessian requires 3 input vectors: V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)"); + } + mrows = mxGetM(prhs[0]); mcols = mxGetN(prhs[0]); + if ( ( mrows != KPP_NVAR )||( mcols != 1 ) ) { + mexPrintf("First KPP_ROOT_Hessian input argument is of size V(%d,%d).", + mrows, mcols); + mexErrMsgTxt("First KPP_ROOT_Hessian input argument should be a column vector V(KPP_NVAR,1)"); + } + mrows = mxGetM(prhs[1]); mcols = mxGetN(prhs[1]); + if ( ( mrows != KPP_NFIX )||( mcols != 1 ) ) { + mexPrintf("Second KPP_ROOT_Hessian input argument is of size F(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Second KPP_ROOT_Hessian input argument should be a column vector F(KPP_NFIX,1)"); + } + mrows = mxGetM(prhs[2]); mcols = mxGetN(prhs[2]); + if ( ( mrows != KPP_NREACT )||( mcols != 1 ) ) { + mexPrintf("Third KPP_ROOT_Hessian input argument is of size RCT(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Third KPP_ROOT_Hessian input argument should be a column vector RCT(KPP_NREACT,1)"); + } + +/* Check for the right number of output arguments */ + if ( nlhs != 1 ) { + mexErrMsgTxt("KPP_ROOT_Hessian requires 1 output column vector: HESS(KPP_NHESS)"); + } + + + V = mxGetPr(prhs[0]); + F = mxGetPr(prhs[1]); + RCT = mxGetPr(prhs[2]); + + plhs[0] = mxCreateDoubleMatrix(KPP_NHESS,1,mxREAL); + HESS = mxGetPr(plhs[0]); + + Hessian( V, F, RCT, HESS ); + +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f new file mode 100755 index 00000000..56457154 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f @@ -0,0 +1,43 @@ +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Matlab Gateway for the Sparse Hessian +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, HESSPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL HESS(KPP_NHESS) + +C Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Hessian requires 3 input vectors: + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +C Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Hessian requires 1 output vector: + &HESS(KPP_NHESS)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_NHESS,1,0) + + VPtr = mxGetPr(prhs(1)) + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)) + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)) + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + HESSPtr = mxGetPr(plhs(1)) + + CALL Hessian( V, F, RCT, HESS ) + + CALL mxCopyReal8ToPtr(HESS, HESSPtr, KPP_NHESS) + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f90 new file mode 100755 index 00000000..4282ff85 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Hessian.f90 @@ -0,0 +1,45 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Matlab Gateway for the Function Hessian +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Model + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, HESSPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL HESS(KPP_NHESS) + +! Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Hessian requires 3 input vectors: & + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +! Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Hessian requires 1 output vector: & + &HESS(KPP_NHESS)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_NHESS,1,0) + + VPtr = mxGetPr(prhs(1)); + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)); + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)); + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + HESSPtr = mxGetPr(plhs(1)) + + CALL Hessian( V, F, RCT, HESS ) + + CALL mxCopyReal8ToPtr(HESS, HESSPtr, KPP_NHESS) + + END SUBROUTINE mexFunction diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.c new file mode 100755 index 00000000..eec652a5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.c @@ -0,0 +1,53 @@ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Matlab Gateway for the Jacobian Jac_SP +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ + +#include "mex.h" +#define min( x, y ) (x) < (y) ? (x) : (y) +#define max( x, y ) (x) > (y) ? (x) : (y) + +void mexFunction( int nlhs, mxArray *plhs[], + int nrhs, const mxArray *prhs[] ) +{ + int mrows, mcols; + KPP_REAL *V, *F, *RCT, *JVS; + +/* Check for the right number and size of input arguments */ + if ( nrhs != 3 ) { + mexErrMsgTxt("KPP_ROOT_Jac_SP requires 3 input vectors: V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)"); + } + mrows = mxGetM(prhs[0]); mcols = mxGetN(prhs[0]); + if ( ( mrows != KPP_NVAR )||( mcols != 1 ) ) { + mexPrintf("First KPP_ROOT_Jac_SP input argument is of size V(%d,%d).", + mrows, mcols); + mexErrMsgTxt("First KPP_ROOT_Jac_SP input argument should be a column vector V(KPP_NVAR,1)"); + } + mrows = mxGetM(prhs[1]); mcols = mxGetN(prhs[1]); + if ( ( mrows != KPP_NFIX )||( mcols != 1 ) ) { + mexPrintf("Second KPP_ROOT_Jac_SP input argument is of size F(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Second KPP_ROOT_Jac_SP input argument should be a column vector F(KPP_NFIX,1)"); + } + mrows = mxGetM(prhs[2]); mcols = mxGetN(prhs[2]); + if ( ( mrows != KPP_NREACT )||( mcols != 1 ) ) { + mexPrintf("Third KPP_ROOT_Jac_SP input argument is of size RCT(%d,%d).", + mrows, mcols); + mexErrMsgTxt("Third KPP_ROOT_Jac_SP input argument should be a column vector RCT(KPP_NREACT,1)"); + } + +/* Check for the right number of output arguments */ + if ( nlhs != 1 ) { + mexErrMsgTxt("KPP_ROOT_Jac_SP requires 1 output column vector: JVS(KPP_LU_NONZERO)"); + } + + + V = mxGetPr(prhs[0]); + F = mxGetPr(prhs[1]); + RCT = mxGetPr(prhs[2]); + + plhs[0] = mxCreateDoubleMatrix(KPP_LU_NONZERO,1,mxREAL); + JVS = mxGetPr(plhs[0]); + + Jac_SP( V, F, RCT, JVS ); + +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f new file mode 100755 index 00000000..f444b306 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f @@ -0,0 +1,43 @@ + + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Matlab Gateway for the Sparse Jacobian Function Jac_SP +C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, JVSPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL JVS(KPP_LU_NONZERO) + +C Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Jac_SP requires 3 input vectors: + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +C Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Jac_SP requires 1 output vector: + &JVS(KPP_LU_NONZERO)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_LU_NONZERO,1,0) + + VPtr = mxGetPr(prhs(1)) + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)) + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)) + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + JVSPtr = mxGetPr(plhs(1)) + + CALL Jac_SP( V, F, RCT, JVS ) + + CALL mxCopyReal8ToPtr(JVS, JVSPtr, KPP_LU_NONZERO) + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f90 new file mode 100755 index 00000000..c316aecb --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Mex_Jac_SP.f90 @@ -0,0 +1,44 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE mexFunction( nlhs, plhs, nrhs, prhs ) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Matlab Gateway for the Sparse Jacobian Function Jac_SP +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Model + + INTEGER nlhs, nrhs + INTEGER plhs(*), prhs(*) + INTEGER mxGetPr, mxCreateFull, mxGetM, mxgetN + INTEGER VPtr, FPtr, RPtr, JVSPtr + KPP_REAL V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT) + KPP_REAL JVS(KPP_LU_NONZERO) + +! Check for the right number of input arguments + IF ( nrhs .ne. 3 ) THEN + CALL mexErrMsgTxt('Jac_SP requires 3 input vectors: & + &V(KPP_NVAR), F(KPP_NFIX), RCT(KPP_NREACT)') + END IF +! Check for the right number of output arguments + IF ( nlhs .ne. 1 ) THEN + CALL mexErrMsgTxt('Jac_SP requires 1 output vector: & + &JVS(KPP_LU_NONZERO)') + END IF + + plhs(1) = mxCreateDoubleMatrix(KPP_LU_NONZERO,1,0) + + VPtr = mxGetPr(prhs(1)) + CALL mxCopyPtrToReal8(VPtr,V,KPP_NVAR) + + FPtr = mxGetPr(prhs(2)) + CALL mxCopyPtrToReal8(FPtr,F,KPP_NFIX) + + RPtr = mxGetPr(prhs(3)) + CALL mxCopyPtrToReal8(RPtr,RCT,KPP_NREACT) + + JVSPtr = mxGetPr(plhs(1)) + + CALL Jac_SP( V, F, RCT, JVS ) + + CALL mxCopyReal8ToPtr(JVS, JVSPtr, KPP_LU_NONZERO) + + END SUBROUTINE mexFunction diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Fun_Chem.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Fun_Chem.m new file mode 100755 index 00000000..62ad1e19 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Fun_Chem.m @@ -0,0 +1,22 @@ + +% Wrapper for calling the ODE function routine +% in a format required by Matlab's ODE integrators + +function P = KPP_ROOT_Fun_Chem(T, Y) + + global TIME FIX RCONST + + Told = TIME; + TIME = T; + KPP_ROOT_Update_SUN; + KPP_ROOT_Update_RCONST; + +% This line calls the Matlab ODE function routine + P = KPP_ROOT_Fun( Y, FIX, RCONST ); + +% To call the mex routine instead, comment the line above and uncomment the following line: +% P = KPP_ROOT_mex_Fun( Y, FIX, RCONST ); + + TIME = Told; + +return diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Jac_Chem.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Jac_Chem.m new file mode 100755 index 00000000..3dcf527c --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/Template_Jac_Chem.m @@ -0,0 +1,32 @@ + +% Wrapper for calling the sparse ODE Jacobian routine +% in a format required by Matlab's ODE integrators + +function J = KPP_ROOT_Jac_Chem(T, Y) + + global TIME FIX RCONST +% To call the mex file uncomment one of the following lines: +% 1) LU prefix if SPARSE_LU_ROW option was used in code generation +% global LU_IROW LU_ICOL +% 2) if SPARSE_ROW option was used in code generation +% global IROW ICOL + + Told = TIME; + TIME = T; + KPP_ROOT_Update_SUN; + KPP_ROOT_Update_RCONST; + +% This line calls the Matlab ODE Jacobian routine + J = KPP_ROOT_Jac_SP( Y, FIX, RCONST ); + +% To call the mex routine instead, comment the line above and uncomment one of the following lines: +% 1) LU prefix if SPARSE_LU_ROW option was used in code generation +% J = sparse( LU_IROW, LU_ICOL, ... +% KPP_ROOT_mex_Jac_SP( Y, FIX, RCONST ), KPP_NVAR, KPP_NVAR); +% 2) if SPARSE_ROW option was used in code generation +% J = sparse( IROW, ICOL, ... +% KPP_ROOT_mex_Jac_SP( Y, FIX, RCONST ), KPP_NVAR, KPP_NVAR); + + TIME = Told; + +return diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.c new file mode 100755 index 00000000..81a82ba7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.c @@ -0,0 +1,19 @@ +void Update_SUN() +{ +KPP_REAL SunRise, SunSet; +KPP_REAL Thour, Tlocal, Ttmp; + + SunRise = 4.5; + SunSet = 19.5; + Thour = TIME/3600.0; + Tlocal = Thour - ((int)Thour/24)*24; + + if ( (Tlocal >= SunRise) && (Tlocal <= SunSet) ) { + Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise); + if (Ttmp > 0) Ttmp = Ttmp*Ttmp; + else Ttmp = -Ttmp*Ttmp; + SUN = ( 1.0 + cos(PI*Ttmp) )/2.0; + } else { + SUN=0.0; + } +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f new file mode 100755 index 00000000..634167cf --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f @@ -0,0 +1,29 @@ + SUBROUTINE Update_SUN() + + IMPLICIT NONE + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + KPP_REAL SunRise, SunSet + KPP_REAL Thour, Tlocal, Ttmp + + SunRise = 4.5 + SunSet = 19.5 + Thour = TIME/3600. + Tlocal = Thour - (INT(Thour)/24)*24 + + IF ((Tlocal.GE.SunRise).AND.(Tlocal.LE.SunSet)) THEN + Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise) + IF (Ttmp.GT.0) THEN + Ttmp = Ttmp*Ttmp + ELSE + Ttmp = -Ttmp*Ttmp + END IF + SUN = ( 1.0 + COS(PI*Ttmp) )/2.0 + ELSE + SUN = 0.0 + END IF + + RETURN + END + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f90 new file mode 100755 index 00000000..f909720a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.f90 @@ -0,0 +1,28 @@ + SUBROUTINE Update_SUN() + !USE KPP_ROOT_Parameters + !USE KPP_ROOT_Global + + IMPLICIT NONE + + KPP_REAL SunRise, SunSet + KPP_REAL Thour, Tlocal, Ttmp + + SunRise = 4.5_dp + SunSet = 19.5_dp + Thour = TIME/3600.0_dp + Tlocal = Thour - (INT(Thour)/24)*24 + + IF ((Tlocal>=SunRise).AND.(Tlocal<=SunSet)) THEN + Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise) + IF (Ttmp.GT.0) THEN + Ttmp = Ttmp*Ttmp + ELSE + Ttmp = -Ttmp*Ttmp + END IF + SUN = ( 1.0_dp + COS(PI*Ttmp) )/2.0_dp + ELSE + SUN = 0.0_dp + END IF + + END SUBROUTINE Update_SUN + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.m new file mode 100755 index 00000000..dbfab58a --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UpdateSun.m @@ -0,0 +1,23 @@ +function Update_SUN( ) + +global TIME SUN + + SunRise = 4.5; + SunSet = 19.5; + Thour = TIME/3600.; + Tlocal = Thour - floor(Thour/24)*24; + + if ( (Tlocal>=SunRise) & (Tlocal<=SunSet) ) + Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise); + if (Ttmp>0) + Ttmp = Ttmp*Ttmp; + else + Ttmp = -Ttmp*Ttmp; + end + SUN = ( 1.0 + cos(pi*Ttmp) )/2.0 ; + else + SUN = 0.0; + end + +return % Update_SUN + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.c new file mode 100755 index 00000000..9e0c3b54 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.c @@ -0,0 +1,67 @@ +/* User-defined Rate Law functions + Note: the default argument type for rate laws, as read from the equations file, is single precision + but all the internal calculations are performed in double precision +*/ +/* Arrhenius */ +KPP_REAL ARR( float A0, float B0, float C0 ) + { + double ARR_RES; + + ARR_RES = (double)A0 * exp( -(double)B0/TEMP ) + * pow( (TEMP/300.0), (double)C0 ); + + return (KPP_REAL)ARR_RES; + } + + +/* Simplified Arrhenius, with two arguments */ +/* Note that the argument B0 has a changed sign when compared to ARR */ +KPP_REAL ARR2( float A0, float B0 ) + { + double ARR_RES; + + ARR_RES = (double)A0 * exp( (double)B0/TEMP ); + + return (KPP_REAL)ARR_RES; + } + + +KPP_REAL EP2( float A0, float C0, float A2, float C2, float A3, float C3) + { + double K0, K2, K3, EP2_RES; + + K0 = (double)A0 * exp( -(double)C0/TEMP ); + K2 = (double)A2 * exp( -(double)C2/TEMP ); + K3 = (double)A3 * exp( -(double)C3/TEMP ); + K3 = K3*CFACTOR*1.0e+6; + EP2_RES = K0 + K3/( 1.0+K3/K2 ); + + return (KPP_REAL)EP2_RES; + } + + +KPP_REAL EP3( float A1, float C1, float A2, float C2) + { + double K1, K2, EP3_RES; + + K1 = (double)A1 * exp(-(double)C1/TEMP); + K2 = (double)A2 * exp(-(double)C2/TEMP); + EP3_RES = K1 + K2*(1.0e+6*CFACTOR); + + return (KPP_REAL)EP3_RES; + } + + +KPP_REAL FALL ( float A0, float B0, float C0, float A1, float B1, float C1, float CF) + { + double K0, K1, FALL_RES; + + K0 = (double)A0 * exp(-(double)B0/TEMP)* pow( (TEMP/300.0), (double)C0 ); + K1 = (double)A1 * exp(-(double)B1/TEMP)* pow( (TEMP/300.0), (double)C1 ); + K0 = K0*CFACTOR*1.0e+6; + K1 = K0/K1; + FALL_RES = (K0/(1.0+K1))* + pow( (double)CF, ( 1.0/( 1.0+pow( (log10(K1)),2 ) ) ) ); + + return (KPP_REAL)FALL_RES; + } diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f new file mode 100755 index 00000000..00c1c381 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f @@ -0,0 +1,76 @@ +C User-defined Rate Law functions +C Note: the default argument type for rate laws, as read from the equations file, is single precision +C but all the internal calculations are performed in REAL*8 + +C Arrhenius + KPP_REAL FUNCTION ARR( A0,B0,C0 ) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL A0,B0,C0 + ARR = DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0D0)**DBLE(C0) + + RETURN + END + + +C Simplified Arrhenius, with two arguments +C Note: The argument B0 has a changed sign when compared to ARR + KPP_REAL FUNCTION ARR2( A0,B0 ) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL A0,B0 + ARR2 = DBLE(A0) * EXP( DBLE(B0)/TEMP ) + + RETURN + END + + KPP_REAL FUNCTION EP2(A0,C0,A2,C2,A3,C3) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL A0,C0,A2,C2,A3,C3 + REAL*8 K0,K2,K3 + + K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP) + K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP) + K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP) + K3 = K3*CFACTOR*1.0d6 + EP2 = K0 + K3/(1.0d0+K3/K2 ) + + RETURN + END + + + KPP_REAL FUNCTION EP3(A1,C1,A2,C2) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL A1, C1, A2, C2 + REAL*8 K1, K2 + + K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP) + K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP) + EP3 = K1 + K2*(1.0d6*CFACTOR) + + RETURN + END + + + KPP_REAL FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF) + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + REAL A0,B0,C0,A1,B1,C1,CF + REAL*8 K0, K1 + + K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0D0)**DBLE(C0) + K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0D0)**DBLE(C1) + K0 = K0*CFACTOR*1.0D6 + K1 = K0/K1 + FALL = (K0/(1.0d0+K1))* + * DBLE(CF)**(1.0d0/(1.0d0+(DLOG10(K1))**2)) + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f90 new file mode 100755 index 00000000..f6281133 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.f90 @@ -0,0 +1,89 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! User-defined Rate Law functions +! Note: the default argument type for rate laws, as read from the equations file, is single precision +! but all the internal calculations are performed in double precision +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Arrhenius + KPP_REAL FUNCTION ARR( A0,B0,C0 ) + REAL A0,B0,C0 + ARR = DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0) + END FUNCTION ARR + +!~~~> Simplified Arrhenius, with two arguments +!~~~> Note: The argument B0 has a changed sign when compared to ARR + KPP_REAL FUNCTION ARR2( A0,B0 ) + REAL A0,B0 + ARR2 = DBLE(A0) * EXP( DBLE(B0)/TEMP ) + END FUNCTION ARR2 + + KPP_REAL FUNCTION EP2(A0,C0,A2,C2,A3,C3) + REAL A0,C0,A2,C2,A3,C3 + REAL(dp) K0,K2,K3 + K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP) + K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP) + K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP) + K3 = K3*CFACTOR*1.0E6_dp + EP2 = K0 + K3/(1.0_dp+K3/K2 ) + END FUNCTION EP2 + + KPP_REAL FUNCTION EP3(A1,C1,A2,C2) + REAL A1, C1, A2, C2 + REAL(dp) K1, K2 + K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP) + K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP) + EP3 = K1 + K2*(1.0E6_dp*CFACTOR) + END FUNCTION EP3 + + KPP_REAL FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF) + REAL A0,B0,C0,A1,B1,C1,CF + REAL(dp) K0, K1 + K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0) + K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1) + K0 = K0*CFACTOR*1.0E6_dp + K1 = K0/K1 + FALL = (K0/(1.0_dp+K1))* & + DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2)) + END FUNCTION FALL + + !--------------------------------------------------------------------------- + + ELEMENTAL REAL(dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc) + + INTRINSIC LOG10 + + REAL(dp), INTENT(IN) :: temp ! temperature [K] + REAL(dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL, INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL, INTENT(IN) :: n ! exponent for low pressure limit + REAL, INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL, INTENT(IN) :: m ! exponent for high pressure limit + REAL, INTENT(IN) :: fc ! broadening factor (usually fc=0.6) + REAL :: zt_help, k0_T, kinf_T, k_ratio + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + k_3rd = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + END FUNCTION k_3rd + + !--------------------------------------------------------------------------- + + ELEMENTAL REAL(dp) FUNCTION k_arr (k_298,tdep,temp) + ! Arrhenius function + + REAL, INTENT(IN) :: k_298 ! k at T = 298.15K + REAL, INTENT(IN) :: tdep ! temperature dependence + REAL(dp), INTENT(IN) :: temp ! temperature + + INTRINSIC EXP + + k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3 + + END FUNCTION k_arr + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of User-defined Rate Law functions +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.m new file mode 100755 index 00000000..38294b51 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws.m @@ -0,0 +1,41 @@ +% User-defined Rate Law functions +% Note: insert this file at the end of Update_RCONST + +%--- Arrhenius + function [rate] = ARR( A0,B0,C0 ) + global TEMP CFACTOR + rate = (A0) * exp(-(B0)/TEMP) * (TEMP/300.0)^(C0) ; + return % ARR + +%--- Simplified Arrhenius, with two arguments +%--- Note: The argument B0 has a changed sign when compared to ARR + function [rate] = ARR2( A0,B0 ) + global TEMP CFACTOR + rate = (A0) * exp( (B0)/TEMP ) ; + return % ARR2 + + function [rate] = EP2(A0,C0,A2,C2,A3,C3) + global TEMP CFACTOR + K0 = (A0) * exp(-C0/TEMP); + K2 = (A2) * exp(-C2/TEMP); + K3 = (A3) * exp(-C3/TEMP); + K3 = K3*CFACTOR*1.0e+6; + rate = K0 + K3/(1.0+K3/K2) ; + return % EP2 + + function [rate] = EP3(A1,C1,A2,C2) + global TEMP CFACTOR + K1 = (A1) * exp(-(C1)/TEMP); + K2 = (A2) * exp(-(C2)/TEMP); + rate = K1 + K2*(1.0e+6*CFACTOR); + return % EP3 + + function [rate] = FALL ( A0,B0,C0,A1,B1,C1,CF) + global TEMP CFACTOR + K0 = A0 * exp(-B0/TEMP)* (TEMP/300.0)^(C0); + K1 = A1 * exp(-B1/TEMP)* (TEMP/300.0)^(C1); + K0 = K0*CFACTOR*1.0e+6; + K1 = K0/K1; + rate = (K0/(1.0+K1))*(CF)^(1.0/(1.0+(log(K1))^2)); + return % FALL + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws_FcnHeader.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws_FcnHeader.f new file mode 100755 index 00000000..072aa3a1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/UserRateLaws_FcnHeader.f @@ -0,0 +1,6 @@ +C Definitions for User-defined Rate Law functions +C To be inserted in funcions that call rate laws + + KPP_REAL ARR, ARR2 + KPP_REAL EP2, EP3, FALL + EXTERNAL ARR, ARR2, EP2, EP3, FALL diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/WRFUserRateLaws.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/WRFUserRateLaws.f90 new file mode 100755 index 00000000..3c1b18be --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/WRFUserRateLaws.f90 @@ -0,0 +1,83 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! User-defined Rate Law functions +! Note: the default argument type for rate laws, as read from the equations file, is single precision +! but all the internal calculations are performed in double precision +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!~~~> Simplified Arrhenius, with two arguments + KPP_REAL FUNCTION ARR2( A0,B0, TEMP ) + REAL(KIND=dp) :: TEMP + REAL A0,B0 + ARR2 = A0 * EXP( REAL(-B0, KIND=dp)/TEMP ) + END FUNCTION ARR2 + + +!------------------------------------ +! Troe reactions (as in Stockwell et al, 1997) + + KPP_REAL FUNCTION TROE(k0_300K,n,kinf_300K,m,temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL, INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL, INTENT(IN) :: n ! exponent for low pressure limit + REAL, INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL, INTENT(IN) :: m ! exponent for high pressure limit + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + TROE = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + END FUNCTION TROE + + + +!------------------------------------------- +! Troe equilibrium reactions (as in Stockwell et al, 1997) + + KPP_REAL FUNCTION TROEE(A, B, k0_300K,n,kinf_300K,m,temp,cair) + + INTRINSIC LOG10 + + REAL(dp), INTENT(IN) :: temp ! temperature [K] + REAL(dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL, INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL, INTENT(IN) :: n ! exponent for low pressure limit + REAL, INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL, INTENT(IN) :: m ! exponent for high pressure limit + REAL, INTENT(IN) :: A, B + REAL(dp) :: zt_help, k0_T, kinf_T, k_ratio, troe + + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + troe = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + TROEE = A * EXP( -REAL(B, KIND=dp) / temp) * troe + + + + END FUNCTION TROEE + +!------------------------ +! k=T^2 C exp (-D/T) reactions + + KPP_REAL FUNCTION THERMAL_T2(c, d ,temp) + REAL(dp), INTENT(IN) :: temp ! temperature [K] + REAL, INTENT(IN) :: c, d + + + THERMAL_T2= temp**2._dp * c * EXP(-REAL(d, KIND=dp)/temp) + + END FUNCTION THERMAL_T2 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! End of User-defined Rate Law functions +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/blas.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/blas.f90 new file mode 100755 index 00000000..5a8edf98 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/blas.f90 @@ -0,0 +1,295 @@ +!-------------------------------------------------------------- +! +! BLAS/LAPACK-like subroutines used by the integration algorithms +! It is recommended to replace them by calls to the optimized +! BLAS/LAPACK library for your machine +! +! (C) Adrian Sandu, Aug. 2004 +! Virginia Polytechnic Institute and State University +!-------------------------------------------------------------- + + +!-------------------------------------------------------------- + SUBROUTINE KPP_ROOT_WCOPY(N,X,incX,Y,incY) +!-------------------------------------------------------------- +! copies a vector, x, to a vector, y: y <- x +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SCOPY(N,X,1,Y,1) or CALL DCOPY(N,X,1,Y,1) +!-------------------------------------------------------------- +! USE KPP_ROOT_Precision + + INTEGER i,incX,incY,M,MP1,N + KPP_REAL X(N),Y(N) + + IF (N.LE.0) RETURN + + M = MOD(N,8) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = X(i) + END DO + IF( N .LT. 8 ) RETURN + END IF + MP1 = M+1 + DO i = MP1,N,8 + Y(i) = X(i) + Y(i + 1) = X(i + 1) + Y(i + 2) = X(i + 2) + Y(i + 3) = X(i + 3) + Y(i + 4) = X(i + 4) + Y(i + 5) = X(i + 5) + Y(i + 6) = X(i + 6) + Y(i + 7) = X(i + 7) + END DO + + END SUBROUTINE KPP_ROOT_WCOPY + + +!-------------------------------------------------------------- + SUBROUTINE KPP_ROOT_WAXPY(N,Alpha,X,incX,Y,incY) +!-------------------------------------------------------------- +! constant times a vector plus a vector: y <- y + Alpha*x +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SAXPY(N,Alpha,X,1,Y,1) or CALL DAXPY(N,Alpha,X,1,Y,1) +!-------------------------------------------------------------- +! USE KPP_ROOT_Precision + + INTEGER i,incX,incY,M,MP1,N + KPP_REAL X(N),Y(N),Alpha + KPP_REAL ZERO + PARAMETER( ZERO = 0.0_dp ) + + IF (Alpha .EQ. ZERO) RETURN + IF (N .LE. 0) RETURN + + M = MOD(N,4) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = Y(i) + Alpha*X(i) + END DO + IF( N .LT. 4 ) RETURN + END IF + MP1 = M + 1 + DO i = MP1,N,4 + Y(i) = Y(i) + Alpha*X(i) + Y(i + 1) = Y(i + 1) + Alpha*X(i + 1) + Y(i + 2) = Y(i + 2) + Alpha*X(i + 2) + Y(i + 3) = Y(i + 3) + Alpha*X(i + 3) + END DO + + END SUBROUTINE KPP_ROOT_WAXPY + + + +!-------------------------------------------------------------- + SUBROUTINE KPP_ROOT_WSCAL(N,Alpha,X,incX) +!-------------------------------------------------------------- +! constant times a vector: x(1:N) <- Alpha*x(1:N) +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SSCAL(N,Alpha,X,1) or CALL DSCAL(N,Alpha,X,1) +!-------------------------------------------------------------- +! USE KPP_ROOT_Precision + + INTEGER i,incX,M,MP1,N + KPP_REAL X(N),Alpha + KPP_REAL ZERO, ONE + PARAMETER( ZERO = 0.0_dp ) + PARAMETER( ONE = 1.0_dp ) + + IF (Alpha .EQ. ONE) RETURN + IF (N .LE. 0) RETURN + + M = MOD(N,5) + IF( M .NE. 0 ) THEN + IF (Alpha .EQ. (-ONE)) THEN + DO i = 1,M + X(i) = -X(i) + END DO + ELSEIF (Alpha .EQ. ZERO) THEN + DO i = 1,M + X(i) = ZERO + END DO + ELSE + DO i = 1,M + X(i) = Alpha*X(i) + END DO + END IF + IF( N .LT. 5 ) RETURN + END IF + MP1 = M + 1 + IF (Alpha .EQ. (-ONE)) THEN + DO i = MP1,N,5 + X(i) = -X(i) + X(i + 1) = -X(i + 1) + X(i + 2) = -X(i + 2) + X(i + 3) = -X(i + 3) + X(i + 4) = -X(i + 4) + END DO + ELSEIF (Alpha .EQ. ZERO) THEN + DO i = MP1,N,5 + X(i) = ZERO + X(i + 1) = ZERO + X(i + 2) = ZERO + X(i + 3) = ZERO + X(i + 4) = ZERO + END DO + ELSE + DO i = MP1,N,5 + X(i) = Alpha*X(i) + X(i + 1) = Alpha*X(i + 1) + X(i + 2) = Alpha*X(i + 2) + X(i + 3) = Alpha*X(i + 3) + X(i + 4) = Alpha*X(i + 4) + END DO + END IF + + END SUBROUTINE KPP_ROOT_WSCAL + +!-------------------------------------------------------------- + KPP_REAL FUNCTION KPP_ROOT_WLAMCH( C ) +!-------------------------------------------------------------- +! returns epsilon machine +! after LAPACK +! replace this by the function from the optimized LAPACK implementation: +! CALL SLAMCH('E') or CALL DLAMCH('E') +!-------------------------------------------------------------- +! USE KPP_ROOT_Precision + + CHARACTER C + INTEGER i + KPP_REAL ONE, HALF, Eps, Sum + PARAMETER (ONE = 1.0_dp) + PARAMETER (HALF = 0.5_dp) + LOGICAL First + SAVE First, Eps + DATA First /.TRUE./ + + IF (First) THEN + First = .FALSE. + Eps = HALF**(16) + DO i = 17, 80 + Eps = Eps*HALF + CALL KPP_ROOT_WLAMCH_ADD(ONE,Eps,Sum) + IF (Sum.LE.ONE) GOTO 10 + END DO + PRINT*,'ERROR IN WLAMCH. EPS < ',Eps + RETURN +10 Eps = Eps*2 + i = i-1 + END IF + + KPP_ROOT_WLAMCH = Eps + + END FUNCTION KPP_ROOT_WLAMCH + + SUBROUTINE KPP_ROOT_WLAMCH_ADD( A, B, Sum ) +! USE KPP_ROOT_Precision + + KPP_REAL A, B, Sum + Sum = A + B + + END SUBROUTINE KPP_ROOT_WLAMCH_ADD +!-------------------------------------------------------------- + + +!-------------------------------------------------------------- + SUBROUTINE KPP_ROOT_SET2ZERO(N,Y) +!-------------------------------------------------------------- +! copies zeros into the vector y: y <- 0 +! after BLAS +!-------------------------------------------------------------- + + INTEGER :: i,M,MP1,N + KPP_REAL :: Y(N) + KPP_REAL, PARAMETER :: ZERO = 0.0d0 + + IF (N.LE.0) RETURN + + M = MOD(N,8) + IF( M .NE. 0 ) THEN + DO i = 1,M + Y(i) = ZERO + END DO + IF( N .LT. 8 ) RETURN + END IF + MP1 = M+1 + DO i = MP1,N,8 + Y(i) = ZERO + Y(i + 1) = ZERO + Y(i + 2) = ZERO + Y(i + 3) = ZERO + Y(i + 4) = ZERO + Y(i + 5) = ZERO + Y(i + 6) = ZERO + Y(i + 7) = ZERO + END DO + + END SUBROUTINE KPP_ROOT_SET2ZERO + + +!-------------------------------------------------------------- + KPP_REAL FUNCTION KPP_ROOT_WDOT (N, DX, incX, DY, incY) +!-------------------------------------------------------------- +! dot produce: wdot = x(1:N)*y(1:N) +! only for incX=incY=1 +! after BLAS +! replace this by the function from the optimized BLAS implementation: +! CALL SDOT(N,X,1,Y,1) or CALL DDOT(N,X,1,Y,1) +!-------------------------------------------------------------- +! USE messy_mecca_kpp_Precision +!-------------------------------------------------------------- + IMPLICIT NONE + INTEGER :: N, incX, incY + KPP_REAL :: DX(N), DY(N) + + INTEGER :: i, IX, IY, M, MP1, NS + + KPP_ROOT_WDOT = 0.0D0 + IF (N .LE. 0) RETURN + IF (incX .EQ. incY) IF (incX-1) 5,20,60 +! +! Code for unequal or nonpositive increments. +! + 5 IX = 1 + IY = 1 + IF (incX .LT. 0) IX = (-N+1)*incX + 1 + IF (incY .LT. 0) IY = (-N+1)*incY + 1 + DO i = 1,N + KPP_ROOT_WDOT = KPP_ROOT_WDOT + DX(IX)*DY(IY) + IX = IX + incX + IY = IY + incY + END DO + RETURN +! +! Code for both increments equal to 1. +! +! Clean-up loop so remaining vector length is a multiple of 5. +! + 20 M = MOD(N,5) + IF (M .EQ. 0) GO TO 40 + DO i = 1,M + KPP_ROOT_WDOT = KPP_ROOT_WDOT + DX(i)*DY(i) + END DO + IF (N .LT. 5) RETURN + 40 MP1 = M + 1 + DO i = MP1,N,5 + KPP_ROOT_WDOT = KPP_ROOT_WDOT + DX(i)*DY(i) + DX(i+1)*DY(i+1) +& + DX(i+2)*DY(i+2) + & + DX(i+3)*DY(i+3) + DX(i+4)*DY(i+4) + END DO + RETURN +! +! Code for equal, positive, non-unit increments. +! + 60 NS = N*incX + DO i = 1,NS,incX + KPP_ROOT_WDOT = KPP_ROOT_WDOT + DX(i)*DY(i) + END DO + + END FUNCTION KPP_ROOT_WDOT diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/sutil.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/sutil.f90 new file mode 100755 index 00000000..d5efe61c --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/WRF_conform/sutil.f90 @@ -0,0 +1,134 @@ + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_KppDecomp( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! USE KPP_ROOT_Parameters +! USE KPP_ROOT_JacobianSP + + INTEGER :: IER + KPP_REAL :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a + INTEGER :: k, kk, j, jj + + a = 0. ! mz_rs_20050606 + IER = 0 + DO k=1,NVAR + ! mz_rs_20050606: don't check if real value == 0 + ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KPP_ROOT_KppDecomp + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_KppDecompCmplx( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization, complex +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! USE KPP_ROOT_Parameters +! USE KPP_ROOT_JacobianSP + + INTEGER :: IER + DOUBLE COMPLEX :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a + INTEGER :: k, kk, j, jj + + IER = 0 + DO k=1,NVAR + IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KPP_ROOT_KppDecompCmplx + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_KppSolveIndirect( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! USE KPP_ROOT_Parameters +! USE KPP_ROOT_JacobianSP + + INTEGER i, j + KPP_REAL JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KPP_ROOT_KppSolveIndirect + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KPP_ROOT_KppSolveCmplx( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! USE KPP_ROOT_Parameters +! USE KPP_ROOT_JacobianSP + + INTEGER i, j + DOUBLE COMPLEX JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KPP_ROOT_KppSolveCmplx diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/blas.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/blas.c new file mode 100755 index 00000000..c2db8f87 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/blas.c @@ -0,0 +1,180 @@ +/*-------------------------------------------------------------- + + BLAS/LAPACK-like subroutines used by the integration algorithms + It is recommended to replace them by calls to the optimized + BLAS/LAPACK library for your machine + + (C) Adrian Sandu, Aug. 2004 + +--------------------------------------------------------------*/ + +#define ZERO (KPP_REAL)0.0 +#define ONE (KPP_REAL)1.0 +#define HALF (KPP_REAL)0.5 +#define TWO (KPP_REAL)2.0 +#define MOD(A,B) (int)((A)%(B)) + +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +void WCOPY(int N, KPP_REAL X[], int incX, KPP_REAL Y[], int incY) +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + copies a vector, x, to a vector, y: y <- x + only for incX=incY=1 + after BLAS + replace this by the function from the optimized BLAS implementation: + CALL SCOPY(N,X,1,Y,1) or CALL DCOPY(N,X,1,Y,1) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ +{ + int i, M; + if (N <= 0) return; + + M = MOD(N,8); + if( M != 0 ) { + for ( i = 0; i < M; i++ ) + Y[i] = X[i]; + if( N < 8 ) return; + } /* end if */ + for ( i = M; i */ +#include "mex.h" +#include + +#define MAX_BUF 200 + +void Usage() +{ + mexPrintf(" \n" + "To get this help message use: KPP_ROOT ? \n" + " \n" + "To initialize default values use: KPP_ROOT \n" + " (type who to see the variables created) \n" + " \n" + "To integrate the model use: \n" + " [ c, m, f ] = KPP_ROOT( t, c0, k, p, fn, tfn ); \n" + " \n" + " input : \n" + " t - Time vector, contains the time at which results \n" + " should be reported; \n" + " c0 - Vector with the initial concentrations for all \n" + " species; \n" + " k - Vector with all rate constants; \n" + " p - Vector of parameters for the integration; \n" + " p(1) holds the relative tolerance \n" + " p(2) holds the absolute tolerance \n" + " p(3) holds the minimum step size allowed \n" + " p(4) holds the maximum step size allowed \n" + " If any of the above is zero the default value is \n" + " used; \n" + " fn - (optional) Name of a matlab function to be called \n" + " to update the values of k's and concentrations \n" + " If not present no update is performed. \n" + " \n" + " tfn - (optional) Time at which the fn function should \n" + " be called. If missing is assumed. \n" + " \n" + " output: \n" + " c - Matrix of concentrations of all species vs. time; \n" + " m - (optional) Mass conservation of all atoms vs. time; \n" + " f - (optional) Matrix of fluxes of all species vs. time; \n" + " \n" + ); +} + +int giveusage; + +void F9Error( char *fmt, ... ) +{ +va_list args; +char buf[ MAX_BUF ]; +char errmsg[ MAX_BUF ]; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + if( giveusage ) Usage(); + + mexPrintf("Error: %s\n", buf); + mexErrMsgTxt( 0 ); +} + +char allvars[1000]; + +int CreateVar(char *name, KPP_REAL val) +{ +mxArray *GA; +double *pga; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateDoubleMatrix(1,1,mxREAL); + pga = mxGetPr(GA); + *pga = (double)val; + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateVec(char *name, int len, KPP_REAL *val) +{ +mxArray *GA; +double *pga; +int i; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateDoubleMatrix(1,len,mxREAL); + pga = mxGetPr(GA); + if( sizeof(KPP_REAL) == sizeof(double) ) { + memmove( pga, val, len*sizeof(double) ); + } else { + for( i = 0; i < len; i++ ) pga[i] = (double)val[i]; + } + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateStrVec(char *name, int len, char **val) +{ +mxArray *GA; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateCharMatrixFromStrings( len, (const char **)val ); + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateStr(char *name, char *val) +{ +mxArray *GA; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateString( val ); + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +#define T_PRM prhs[0] +#define C0_PRM prhs[1] +#define K_PRM prhs[2] +#define P_PRM prhs[3] +#define FN_PRM prhs[4] +#define TFN_PRM prhs[5] + +#define C_PRM plhs[0] +#define M_PRM plhs[1] +#define F_PRM plhs[2] + +#define HAS_FN (nrhs >= 5) +#define HAS_TFN (nrhs >= 6) + +#define HAS_M (nlhs >= 2) +#define HAS_F (nlhs >= 3) + +#define DBL (sizeof(KPP_REAL) == sizeof(double)) + +void mexFunction( + int nlhs, mxArray *plhs[], + int nrhs, const mxArray *prhs[] + ) +{ +double * tp; +double * c0p; +double * kp; +double * pp; +char fnp[ MAX_BUF ]; +double *tfnp; + +double * cp; +double * mp; +double * fp; +double ATOLS; +double dval[ NMASS+NSPEC ]; + +mxArray *Carr, *Karr, *Tarr; +double *fcp; +double *fkp; +double *ftp, *ftp1; + +int i,j,m,n,nd,t; +int nsteps, nspc, nreact, ncb; +int tcb, CallBack; +KPP_REAL prm[4]; + + giveusage = 1; + + if(nrhs == 0) { + + InitVal(); + Update_RCONST(); + + prm[0] = 1e-4; + prm[1] = 1.0E-18; + prm[2] = 0.01; + prm[3] = 900; + + sprintf(allvars,"global "); + + CreateVec("PRM",4, prm); + + CreateVar("NSPEC",NSPEC); + CreateVar("NREACT",NREACT); + CreateVar("NMASS",NMASS); + + CreateVec("C0", NSPEC, C); + CreateVec("K0", NREACT, RCONST); + + for( i = 0; i < NLOOKAT; i++ ) + CreateVar( SLOOKAT[i], (double)(i+1) ); + + for( i = 0; i < NMASS; i++ ) + CreateVar( SMASS[i], (double)(i+1) ); + + CreateStrVec("SSPEC", NSPEC, SLOOKAT); + CreateStrVec("SMASS", NMASS, SMASS); + CreateStrVec("SEQN", NREACT, SEQN); + + CreateStr("GLOBALCMD", allvars); + + mexEvalString(allvars); +/* + mexPrintf("The KPP_ROOT model parameters were sucessfully initialized.\n"); +*/ + return; + } + + if( nrhs < 4 ) + F9Error("First 4 parameters are REQUIRED only %d received.", nrhs); + if( nlhs < 1 ) + F9Error("At least one output parameter REQUIRED."); + + if(! mxIsDouble(T_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(C0_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(K_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(P_PRM)) F9Error("

must be of type double."); + if((nrhs > 4) && (! mxIsChar(FN_PRM))) F9Error(" must be of type char."); + if((nrhs > 5) && (! mxIsDouble(TFN_PRM))) F9Error(" must be of type double."); + + nd = mxGetNumberOfDimensions( T_PRM ); + m = mxGetM( T_PRM ); + n = mxGetN( T_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nsteps = (m == 1) ? n : m; + tp = mxGetPr( T_PRM ); + + nd = mxGetNumberOfDimensions( C0_PRM ); + m = mxGetM( C0_PRM ); + n = mxGetN( C0_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nspc = (m == 1) ? n : m; + c0p = mxGetPr( C0_PRM ); + + nd = mxGetNumberOfDimensions( K_PRM ); + m = mxGetM( K_PRM ); + n = mxGetN( K_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nreact = (m == 1) ? n : m; + kp = mxGetPr( K_PRM ); + + nd = mxGetNumberOfDimensions( P_PRM ); + m = mxGetM( P_PRM ); + n = mxGetN( P_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) && (n*m == 4) ) ) + F9Error("

must be a column vectorof length 4."); + pp = mxGetPr( P_PRM ); + + *fnp = 0; + if( HAS_FN ) { + nd = mxGetNumberOfDimensions( FN_PRM ); + m = mxGetM( FN_PRM ); + n = mxGetN( FN_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a character string."); + if( mxGetString( FN_PRM, fnp, MAX_BUF ) ) + F9Error("Can not read function mane (too long?)"); + + Carr = mxCreateDoubleMatrix(1,NSPEC,mxREAL); + fcp = mxGetPr(Carr); + mxSetName(Carr,"C"); + mexPutArray(Carr,"base"); + + Karr = mxCreateDoubleMatrix(1,NREACT,mxREAL); + fkp = mxGetPr(Karr); + mxSetName(Karr,"K"); + mexPutArray(Karr,"base"); + + Tarr = mxCreateDoubleMatrix(1,1,mxREAL); + ftp = mxGetPr(Tarr); + mxSetName(Tarr,"T"); + mexPutArray(Tarr,"base"); + } + + tfnp = 0; ncb = 0; + if( HAS_TFN ) { + nd = mxGetNumberOfDimensions( TFN_PRM ); + m = mxGetM( TFN_PRM ); + n = mxGetN( TFN_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + ncb = (m == 1) ? n : m; + tfnp = mxGetPr( TFN_PRM ); + } + + giveusage = 0; + + if( !((nspc == NSPEC) && (nreact == NREACT)) ) { + F9Error("Size of parameters do not match the model:\n\n" + " Number of species was %d and should be %d;\n" + " Number of rections (rate constants) was %d and should be %d;\n", + nspc, NSPEC, nreact, NREACT); + } + + if( DBL ) { memmove( C, c0p, sizeof(double)*NSPEC ); + memmove( RCONST, kp, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) C[i] = (KPP_REAL)c0p[i]; + for( i = 0; i < NREACT; i++ ) RCONST[i] = (KPP_REAL)kp[i]; } + + RTOLS = 1e-4; + ATOLS = 1e-18; + STEPMIN = 0.01; + STEPMAX = 900.0; + + if( pp[0] ) RTOLS = pp[0]; + if( pp[1] ) ATOLS = pp[1]; + if( pp[2] ) STEPMIN = pp[2]; + if( pp[3] ) STEPMAX = pp[3]; + + for( i = 0; i < NVAR; i++ ) { + RTOL[i] = RTOLS; + ATOL[i] = ATOLS; + } + + C_PRM = mxCreateDoubleMatrix(NSPEC,nsteps,mxREAL); + cp = mxGetPr(C_PRM); + + if( HAS_M ) { + M_PRM = mxCreateDoubleMatrix(NMASS,nsteps,mxREAL); + mp = mxGetPr(M_PRM); + } + + if( HAS_F ) { + F_PRM = mxCreateDoubleMatrix(NSPEC,nsteps,mxREAL); + fp = mxGetPr(F_PRM); + } + + tcb = 0; + + for( t = 0; t < nsteps; t++ ) { + if( t ) { + TIME = tp[t-1]; + + CallBack = 0; + if( HAS_TFN ) { + if( tcb < ncb ) + if( tfnp[tcb] <= TIME ) { CallBack = 1; tcb++; } + } else { + CallBack = HAS_FN; + } + + if( CallBack ) { + if( DBL ) { memmove( fcp, C, sizeof(double)*NSPEC ); + memmove( fkp, RCONST, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) fcp[i] = (double)C[i]; + for( i = 0; i < NREACT; i++ ) fkp[i] = (double)RCONST[i]; } + *ftp = TIME; + + mexPutArray(Carr,"base"); + mexPutArray(Karr,"base"); + mexPutArray(Tarr,"base"); + + mexCallMATLAB( 0, 0, 0, 0, fnp ); + + mxDestroyArray(Carr); Carr = mexGetArray("C","base"); fcp = mxGetPr(Carr); + mxDestroyArray(Karr); Karr = mexGetArray("K","base"); fkp = mxGetPr(Karr); + mxDestroyArray(Tarr); Tarr = mexGetArray("T","base"); ftp = mxGetPr(Tarr); + + if( DBL ) { memmove( C, fcp, sizeof(double)*NSPEC ); + memmove( RCONST, fkp, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) C[i] = (KPP_REAL)fcp[i]; + for( i = 0; i < NREACT; i++ ) RCONST[i] = (KPP_REAL)fkp[i]; } + + } + + INTEGRATE( tp[t-1], tp[t] ); + } + if( DBL ) { memmove( cp, C, sizeof(double)*NSPEC ); cp += NSPEC; } + else { for( i = 0; i < NSPEC; i++ ) *cp++ = (double)C[i]; } + if( HAS_M ) { + if( DBL ) { GetMass( mp ); mp += NMASS; } + else { GetMass( dval ); + for( i = 0; i < NMASS; i++ ) *mp++ = (double)dval[i]; } + } + if( HAS_F ) { + if( DBL ) { FLUX( fp ); fp += NSPEC; } + else { FLUX( dval ); + for( i = 0; i < NSPEC; i++ ) *fp++ = (double)dval[i]; } + } + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/mex.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/mex.f new file mode 100755 index 00000000..609d5de7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/mex.f @@ -0,0 +1,377 @@ +/* #include */ +#include "mex.h" +#include + +#define MAX_BUF 200 + +void Usage() +{ + mexPrintf(" \n" + "To get this help message use: KPP_ROOT ? \n" + " \n" + "To initialize default values use: KPP_ROOT \n" + " (type who to see the variables created) \n" + " \n" + "To integrate the model use: \n" + " [ c, m, f ] = KPP_ROOT( t, c0, k, p, fn, tfn ); \n" + " \n" + " input : \n" + " t - Time vector, contains the time at which results \n" + " should be reported; \n" + " c0 - Vector with the initial concentrations for all \n" + " species; \n" + " k - Vector with all rate constants; \n" + " p - Vector of parameters for the integration; \n" + " p(1) holds the relative tolerance \n" + " p(2) holds the absolute tolerance \n" + " p(3) holds the minimum step size allowed \n" + " p(4) holds the maximum step size allowed \n" + " If any of the above is zero the default value is \n" + " used; \n" + " fn - (optional) Name of a matlab function to be called \n" + " to update the values of k's and concentrations \n" + " If not present no update is performed. \n" + " \n" + " tfn - (optional) Time at which the fn function should \n" + " be called. If missing is assumed. \n" + " \n" + " output: \n" + " c - Matrix of concentrations of all species vs. time; \n" + " m - (optional) Mass conservation of all atoms vs. time; \n" + " f - (optional) Matrix of fluxes of all species vs. time; \n" + " \n" + ); +} + +int giveusage; + +void F9Error( char *fmt, ... ) +{ +va_list args; +char buf[ MAX_BUF ]; +char errmsg[ MAX_BUF ]; + + va_start( args, fmt ); + vsprintf( buf, fmt, args ); + va_end( args ); + + if( giveusage ) Usage(); + + mexPrintf("Error: %s\n", buf); + mexErrMsgTxt( 0 ); +} + +char allvars[1000]; + +int CreateVar(char *name, KPP_REAL val) +{ +mxArray *GA; +double *pga; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateDoubleMatrix(1,1,mxREAL); + pga = mxGetPr(GA); + *pga = (double)val; + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateVec(char *name, int len, KPP_REAL *val) +{ +mxArray *GA; +double *pga; +int i; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateDoubleMatrix(1,len,mxREAL); + pga = mxGetPr(GA); + if( sizeof(KPP_REAL) == sizeof(double) ) { + memmove( pga, val, len*sizeof(double) ); + } else { + for( i = 0; i < len; i++ ) pga[i] = (double)val[i]; + } + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateStrVec(char *name, int len, char **val) +{ +mxArray *GA; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateCharMatrixFromStrings( len, (const char **)val ); + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +int CreateStr(char *name, char *val) +{ +mxArray *GA; + + sprintf(allvars, "%s %s",allvars, name); + GA = mxCreateString( val ); + mxSetName(GA,name); + return mexPutArray(GA,"global"); +} + +#define T_PRM prhs[0] +#define C0_PRM prhs[1] +#define K_PRM prhs[2] +#define P_PRM prhs[3] +#define FN_PRM prhs[4] +#define TFN_PRM prhs[5] + +#define C_PRM plhs[0] +#define M_PRM plhs[1] +#define F_PRM plhs[2] + +#define HAS_FN (nrhs >= 5) +#define HAS_TFN (nrhs >= 6) + +#define HAS_M (nlhs >= 2) +#define HAS_F (nlhs >= 3) + +#define DBL (sizeof(KPP_REAL) == sizeof(double)) + +void mexFunction( + int nlhs, mxArray *plhs[], + int nrhs, const mxArray *prhs[] + ) +{ +double * tp; +double * c0p; +double * kp; +double * pp; +char fnp[ MAX_BUF ]; +double *tfnp; + +double * cp; +double * mp; +double * fp; +double ATOLS; +double dval[ NMASS+NSPEC ]; + +mxArray *Carr, *Karr, *Tarr; +double *fcp; +double *fkp; +double *ftp, *ftp1; + +int i,j,m,n,nd,t; +int nsteps, nspc, nreact, ncb; +int tcb, CallBack; +KPP_REAL prm[4]; + + giveusage = 1; + + if(nrhs == 0) { + + InitVal(); + Update_RCONST(); + + prm[0] = 1e-4; + prm[1] = 1.0E-18; + prm[2] = 0.01; + prm[3] = 900; + + sprintf(allvars,"global "); + + CreateVec("PRM",4, prm); + + CreateVar("NSPEC",NSPEC); + CreateVar("NREACT",NREACT); + CreateVar("NMASS",NMASS); + + CreateVec("C0", NSPEC, C); + CreateVec("K0", NREACT, RCONST); + + for( i = 0; i < NLOOKAT; i++ ) + CreateVar( SLOOKAT[i], (double)(i+1) ); + + for( i = 0; i < NMASS; i++ ) + CreateVar( SMASS[i], (double)(i+1) ); + + CreateStrVec("SSPEC", NSPEC, SLOOKAT); + CreateStrVec("SMASS", NMASS, SMASS); + CreateStrVec("SEQN", NREACT, SEQN); + + CreateStr("GLOBALCMD", allvars); + + mexEvalString(allvars); +/* + mexPrintf("The KPP_ROOT model parameters were sucessfully initialized.\n"); +*/ + return; + } + + if( nrhs < 4 ) + F9Error("First 4 parameters are REQUIRED only %d received.", nrhs); + if( nlhs < 1 ) + F9Error("At least one output parameter REQUIRED."); + + if(! mxIsDouble(T_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(C0_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(K_PRM)) F9Error(" must be of type double."); + if(! mxIsDouble(P_PRM)) F9Error("

must be of type double."); + if((nrhs > 4) && (! mxIsChar(FN_PRM))) F9Error(" must be of type char."); + if((nrhs > 5) && (! mxIsDouble(TFN_PRM))) F9Error(" must be of type double."); + + nd = mxGetNumberOfDimensions( T_PRM ); + m = mxGetM( T_PRM ); + n = mxGetN( T_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nsteps = (m == 1) ? n : m; + tp = mxGetPr( T_PRM ); + + nd = mxGetNumberOfDimensions( C0_PRM ); + m = mxGetM( C0_PRM ); + n = mxGetN( C0_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nspc = (m == 1) ? n : m; + c0p = mxGetPr( C0_PRM ); + + nd = mxGetNumberOfDimensions( K_PRM ); + m = mxGetM( K_PRM ); + n = mxGetN( K_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + nreact = (m == 1) ? n : m; + kp = mxGetPr( K_PRM ); + + nd = mxGetNumberOfDimensions( P_PRM ); + m = mxGetM( P_PRM ); + n = mxGetN( P_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) && (n*m == 4) ) ) + F9Error("

must be a column vectorof length 4."); + pp = mxGetPr( P_PRM ); + + *fnp = 0; + if( HAS_FN ) { + nd = mxGetNumberOfDimensions( FN_PRM ); + m = mxGetM( FN_PRM ); + n = mxGetN( FN_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a character string."); + if( mxGetString( FN_PRM, fnp, MAX_BUF ) ) + F9Error("Can not read function mane (too long?)"); + + Carr = mxCreateDoubleMatrix(1,NSPEC,mxREAL); + fcp = mxGetPr(Carr); + mxSetName(Carr,"C"); + mexPutArray(Carr,"base"); + + Karr = mxCreateDoubleMatrix(1,NREACT,mxREAL); + fkp = mxGetPr(Karr); + mxSetName(Karr,"K"); + mexPutArray(Karr,"base"); + + Tarr = mxCreateDoubleMatrix(1,1,mxREAL); + ftp = mxGetPr(Tarr); + mxSetName(Tarr,"T"); + mexPutArray(Tarr,"base"); + } + + tfnp = 0; ncb = 0; + if( HAS_TFN ) { + nd = mxGetNumberOfDimensions( TFN_PRM ); + m = mxGetM( TFN_PRM ); + n = mxGetN( TFN_PRM ); + if( !( (nd == 2) && ((m == 1) || (n == 1)) ) ) F9Error(" must be a column vector."); + ncb = (m == 1) ? n : m; + tfnp = mxGetPr( TFN_PRM ); + } + + giveusage = 0; + + if( !((nspc == NSPEC) && (nreact == NREACT)) ) { + F9Error("Size of parameters do not match the model:\n\n" + " Number of species was %d and should be %d;\n" + " Number of rections (rate constants) was %d and should be %d;\n", + nspc, NSPEC, nreact, NREACT); + } + + if( DBL ) { memmove( C, c0p, sizeof(double)*NSPEC ); + memmove( RCONST, kp, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) C[i] = (KPP_REAL)c0p[i]; + for( i = 0; i < NREACT; i++ ) RCONST[i] = (KPP_REAL)kp[i]; } + + RTOLS = 1e-4; + ATOLS = 1e-18; + STEPMIN = 0.01; + STEPMAX = 900.0; + + if( pp[0] ) RTOLS = pp[0]; + if( pp[1] ) ATOLS = pp[1]; + if( pp[2] ) STEPMIN = pp[2]; + if( pp[3] ) STEPMAX = pp[3]; + + for( i = 0; i < NVAR; i++ ) { + RTOL[i] = RTOLS; + ATOL[i] = ATOLS; + } + + C_PRM = mxCreateDoubleMatrix(NSPEC,nsteps,mxREAL); + cp = mxGetPr(C_PRM); + + if( HAS_M ) { + M_PRM = mxCreateDoubleMatrix(NMASS,nsteps,mxREAL); + mp = mxGetPr(M_PRM); + } + + if( HAS_F ) { + F_PRM = mxCreateDoubleMatrix(NSPEC,nsteps,mxREAL); + fp = mxGetPr(F_PRM); + } + + tcb = 0; + + for( t = 0; t < nsteps; t++ ) { + if( t ) { + TIME = tp[t-1]; + + CallBack = 0; + if( HAS_TFN ) { + if( tcb < ncb ) + if( tfnp[tcb] <= TIME ) { CallBack = 1; tcb++; } + } else { + CallBack = HAS_FN; + } + + if( CallBack ) { + if( DBL ) { memmove( fcp, C, sizeof(double)*NSPEC ); + memmove( fkp, RCONST, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) fcp[i] = (double)C[i]; + for( i = 0; i < NREACT; i++ ) fkp[i] = (double)RCONST[i]; } + *ftp = TIME; + + mexPutArray(Carr,"base"); + mexPutArray(Karr,"base"); + mexPutArray(Tarr,"base"); + + mexCallMATLAB( 0, 0, 0, 0, fnp ); + + mxDestroyArray(Carr); Carr = mexGetArray("C","base"); fcp = mxGetPr(Carr); + mxDestroyArray(Karr); Karr = mexGetArray("K","base"); fkp = mxGetPr(Karr); + mxDestroyArray(Tarr); Tarr = mexGetArray("T","base"); ftp = mxGetPr(Tarr); + + if( DBL ) { memmove( C, fcp, sizeof(double)*NSPEC ); + memmove( RCONST, fkp, sizeof(double)*NREACT ); } + else { for( i = 0; i < NSPEC; i++ ) C[i] = (KPP_REAL)fcp[i]; + for( i = 0; i < NREACT; i++ ) RCONST[i] = (KPP_REAL)fkp[i]; } + + } + + INTEGRATE( tp[t-1], tp[t] ); + } + if( DBL ) { memmove( cp, C, sizeof(double)*NSPEC ); cp += NSPEC; } + else { for( i = 0; i < NSPEC; i++ ) *cp++ = (double)C[i]; } + if( HAS_M ) { + if( DBL ) { GetMass( mp ); mp += NMASS; } + else { GetMass( dval ); + for( i = 0; i < NMASS; i++ ) *mp++ = (double)dval[i]; } + } + if( HAS_F ) { + if( DBL ) { FLUX( fp ); fp += NSPEC; } + else { FLUX( dval ); + for( i = 0; i < NSPEC; i++ ) *fp++ = (double)dval[i]; } + } + } +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.c new file mode 100755 index 00000000..78886fb1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.c @@ -0,0 +1,295 @@ +#include +#include +#include +#include +#include +#include "ncar.h" + +#define MAX_COLORS 9 +#define MAX_GRAPHS 8 +#define WS_ID 1 + +Grgb colors[] = {{ 0.0, 0.0, 0.0 }, + { 1.0, 1.0, 1.0 }, + { 0.0, 1.0, 0.0 }, + { 1.0, 1.0, 0.0 }, + { 0.0, 1.0, 1.0 }, + { 1.0, 0.4, 0.4 }, + { 1.0, 0.0, 1.0 }, + { 0.7, 1.0, 0.7 }, + { 0.5, 0.5, 1.0 } + }; + + +int nGraphs = 0; +int nMax; +int nCrt; +int CrtGraph; + +char *graphName[ MAX_GRAPHS ]; +char *graphTitle; +char * startMsg = "Working... Press CTRL-C to stop"; +char * endMsg = "DONE ! Press when ready."; +char * status = "S"; + +float * Xval; +float * Yval; +float * scale; +float * offset; +float ch; + +float XminGraph, XmaxGraph; +float Ybottom[ MAX_GRAPHS ]; +float Ytop[ MAX_GRAPHS ]; +float Ymin[ MAX_GRAPHS ]; +float Ymax[ MAX_GRAPHS ]; +float Ybase[ MAX_GRAPHS ]; + +int crtState; +int clean = 0; + +void Boundary(); + +void OpenWin() +{ +int i; +Gcolr_rep colr; + + gopen_gks( "stdout", 0 ); + gopen_ws( WS_ID, (char*)0, 8 ); + gactivate_ws( WS_ID ); + + for( i = 0; i < MAX_COLORS; i++ ) { + colr.rgb.red = colors[i].red; + colr.rgb.green = colors[i].green; + colr.rgb.blue = colors[i].blue; + gset_colr_rep( 1, i, &colr ); + } +} + + +int DefineGraph( char * label, float min, float max ) +{ + graphName[ nGraphs ] = label; + Ymin[ nGraphs ] = min; + Ymax[ nGraphs ] = max; + nGraphs++; + return nGraphs; +} + +void SelectGraph( int i ) +{ + CrtGraph = i; + + c_agsetf("GRID/BOTTOM.", Ybottom[i]); + c_agsetf("GRID/TOP." , Ytop[i]); + + c_agsetf("Y/MINIMUM.", Ymin[i]); + c_agsetf("Y/MAXIMUM.", Ymax[i]); +/* + c_agsetf("LEFT/MAJOR/BASE.", Ybase[i] ); +*/ + if( i == 0 ) + c_agsetf("BOTTOM/TYPE.", 3); + else + c_agsetf("BOTTOM/TYPE.", 0); +} + +void InitGraph( int n, float Xmin, float Xmax, char *title ) +{ +int i; +float step; +char buf[100]; + + nMax = n; + n = n + 1; + XminGraph = Xmin; + XmaxGraph = Xmax; + graphTitle = title; + + step = (Xmax - Xmin) / nMax; + + Xval = (float*)malloc( n * sizeof(float) ); + for( i = 0; i < n; i++ ) + Xval[i] = Xmin + step*i; + + Yval = (float*)malloc( nGraphs * n * sizeof(float) ); + for( i = 0; i < nGraphs * n; i++ ) + Yval[i] = NULL/1; + + c_agseti("WINDOWING.",1); + c_agseti("FRAME.", 2 ); + c_agseti("BACKGROUND.", 3 ); + + c_agsetf("GRID/LEFT." ,.15); + c_agsetf("GRID/RIGHT." ,.90); + + for( i = 0; i < nGraphs; i++ ) { + Ybottom[i] = .08 + 0.02 + i*0.84/nGraphs; + Ytop[i] = .08 - 0.02 + (i+1)*0.84/nGraphs; + } + ch = (Ytop[0] - Ybottom[0]); + ch = .02/ch; + + c_agsetf("X/MINIMUM.", Xmin); + c_agsetf("X/MAXIMUM.", Xmax); + + c_agsetc("LABEL/NAME.","T"); + c_agseti("LINE/NUMBER.",100); + c_agsetf("LINE/CH.", 0.1 ); + + c_agsetc("LABEL/NAME.","B"); + c_agseti("LINE/NUMBER.",-100); + c_agsetc("LINE/TEXT.", " " ); + + c_agsetf("BOTTOM/MAJOR/OUTWARD.", .02 ); + c_agsetf("BOTTOM/WIDTH/MA.", 0.20 ); + c_agsetf("BOTTOM/WIDTH/EX.", 0.15 ); + + c_agsetc("LABEL/NAME.","L"); + c_agseti("LINE/NUMBER.",100); + c_agsetc("LINE/TEXT.", " " ); + + c_agseti("LEFT/MAJOR/TYPE.", 1 ); + c_agsetf("LEFT/MAJOR/OUTWARD.", .02 ); + c_agseti("LEFT/MINOR/SPACING.",4); + c_agsetf("LEFT/WIDTH/MA.", .7*ch ); + c_agsetf("LEFT/WIDTH/EX.", .5*ch ); + + c_agsetc("LABEL/NAME.", status ); + c_agsetf("LABEL/BASEPOINT/X.", 0.5); + c_agsetf("LABEL/BASEPOINT/Y.", 1+2*ch); + c_agseti("LABEL/ANGLE.", 0); + c_agseti("LINE/NUMBER.", 0); + c_agsetc("LINE/TEXT.", startMsg ); + c_agsetf("LINE/CH.", ch ); + + Boundary(); +} + +float Round( float x ) +{ +float p; + + if( x == 0 ) return x; + p = (float)pow( 10.0, -3.0 + (int)(.5+log10( (double)x ) ) ); + return p * (int)(.5 + x/p); +} + + +void UpdateGraph( float * val ) +{ +int i, j, n; +static int init = 1; +Gint err, oldcolor; +int start; +float v; + + if( nCrt >= nMax ) return; + n = nMax+1; + + for( i = 0; i < nGraphs; i++ ) + Yval[i*n+nCrt] = val[i]; + nCrt++; + + start = nGraphs-1; + + if( init ) { + init = 0; + ginq_text_colr_ind( &err, &oldcolor ); + + c_pcloqu( 0.9, 0.03 , "TIME [hours]", -0.9, 0, 0 ); + c_pcloqu( 0.08,0.93, "CONC [ppb]", -0.8, 0, 0 ); + + for( i = 0; i < nGraphs; i++ ) { + v = val[i] == 0 ? .001 : val[i]; + Ymin[i] = Round( v * (1 - Ymin[i]) ); + Ymax[i] = Round( v * (1 + Ymax[i]) ); +/* + Ybase[i] = Round((Ymax[i] - Ymin[i])/2); + Ymin[i] = Ybase[i]*(int)(.5 + Ymin[i]/Ybase[i]); + Ymax[i] = Ymin[i]+2*Ybase[i]; +*/ + gset_text_colr_ind( i % MAX_COLORS + 2 ); + c_pcloqu( .86, Ytop[i]-0.01, graphName[i], -1.2, 0, -1 ); + } + gupd_ws( WS_ID, GUPD_PEND ); + + gset_text_colr_ind( oldcolor ); + + SelectGraph(start); + c_ezxy ( Xval, &Yval[start*n], nCrt, "" ); + c_agsetc("LABEL/NAME.", status ); + c_agsetf("LABEL/SU.", 1.); + start--; + } + + for( i = start; i >=0; i-- ) { + SelectGraph( i ); + c_ezxy ( Xval, &Yval[i*n], nCrt, "" ); + } +} + +void CloseWin() +{ + c_agsetc("LABEL/NAME.", status ); + c_agsetf("LABEL/SU.", 0. ); + + clean = 1; + SelectGraph( nGraphs - 1 ); + c_ezxy ( Xval, &Yval[(nGraphs - 1)*(nMax+1)], nCrt, "" ); + clean = 0; + + c_agsetc("LABEL/NAME.", status ); + c_agseti("LINE/NUMBER.", 0); + c_agsetc("LINE/TEXT.", endMsg ); + + c_ezxy ( Xval, &Yval[(nGraphs - 1)*(nMax+1)], nCrt, "" ); + + getchar(); + c_clsgks(); +} + +void Boundary() +{ + c_plotif( 0, 0,0); + c_plotif(32767, 0,1); + c_plotif(32767,32767,1); + c_plotif( 0,32767,1); + c_plotif( 0, 0,1); +} + + +void agchcu( int * iflag, int * n ) +{ + c_plotif( 0., 0., 2 ); + if( *iflag == 0 ) + gset_line_colr_ind( CrtGraph % MAX_COLORS + 2 ); + else + gset_line_colr_ind( 1 ); +} + +int CmpLabelName( char * s1, char * s2 ) +{ + while ( isspace( *s1 ) ) s1++; + while( *s1 == *s2 ) { + s1++; s2++; + } + if( *s2 == '\0' ) + return 1; + return 0; +} + + +void agchil( int * iflag, char * lname, int * lnum ) +{ + c_plotif( 0., 0., 2 ); + switch( *iflag ) { + case 0: + if( CmpLabelName( lname, status ) ) + gset_text_colr_ind( 1 - clean ); + break; + case 1: gset_text_colr_ind( 1 ); + break; + } +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.h b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.h new file mode 100755 index 00000000..b47c4d73 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/ncar.h @@ -0,0 +1,5 @@ +void OpenWin(); +void CloseWin(); +int DefineGraph( char * label, float plus, float minus ); +void InitGraph( int n, float Xmin, float Xmax, char *title ); +void UpdateGraph( float * val ); diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sparsity_plots.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sparsity_plots.m new file mode 100755 index 00000000..cb3b3c23 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sparsity_plots.m @@ -0,0 +1,46 @@ +% Plots the sparsity patterns of the Jacobian and the Hessian + +%%%%% JACOBIAN +figure(1); + +J = zeros(NVAR,NVAR); +for k=1:LU_NONZERO + J( LU_IROW(k), LU_ICOL(k) ) = 1; +end +spy(J); +TK = floor( linspace(1,NVAR,5) ); +set(gca,'XTick',TK,'YTick',TK,'FontSize',14,'LineWidth',2); + +%%%%% HESSIAN +figure(2); + +H = zeros(NVAR,NVAR,NVAR); +for k=1:NHESS + H( IHESS_I(k), IHESS_J(k), IHESS_K(k) ) = 1; + H( IHESS_I(k), IHESS_K(k), IHESS_J(k) ) = 1; +end + +M = ceil( sqrt(NVAR) ); + +for i=1:M + for j=1:M + k = M*(i-1)+j; + if ( k <= NVAR ) + subplot(M,M,k); + hold on + G = reshape( H(k,1:NVAR,1:NVAR), NVAR, NVAR ); + % spy(G); figure;hold on + for iH=1:NVAR; for jH=1:NVAR + if( G(iH, jH) ) + plot(iH,NVAR+1-jH,'.'); + end; + end; end + text(NVAR/6,NVAR*0.6,int2str(k)) + set(gca,'XLim',[1,NVAR],'YLim',[1,NVAR]); + set(gca,'XTick',[],'YTick',[]); + axis('square'); + box on + hold off; + end + end +end diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.c new file mode 100755 index 00000000..83f4da23 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.c @@ -0,0 +1,23 @@ + +int KppDecomp( double *JVS ) +{ +double W[KPP_NVAR]; +double a; +int k, kk, j, jj; + + for( k = 0; k < KPP_NVAR; k++ ) { + if( JVS[ LU_DIAG[k] ] == 0.0 ) return k+1; + for( kk = LU_CROW[k]; kk < LU_CROW[k+1]; kk++ ) + W[ LU_ICOL[kk] ] = JVS[kk]; + for( kk = LU_CROW[k]; kk < LU_DIAG[k]; kk++ ) { + j = LU_ICOL[kk]; + a = -W[j] / JVS[ LU_DIAG[j] ]; + W[j] = -a; + for( jj = LU_DIAG[j]+1; jj < LU_CROW[j+1]; jj++ ) + W[ LU_ICOL[jj] ] += a*JVS[jj]; + } + for( kk = LU_CROW[k]; kk < LU_CROW[k+1]; kk++ ) + JVS[kk] = W[ LU_ICOL[kk] ]; + } + return 0; +} diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f new file mode 100755 index 00000000..68457be7 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f @@ -0,0 +1,131 @@ + +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KppDecomp( JVS, IER ) +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Sparse LU factorization +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + INTEGER IER + KPP_REAL JVS(KPP_LU_NONZERO), W(KPP_NVAR) + INTEGER k, kk, j, jj + KPP_REAL a + + IER = 0 + DO k=1,NVAR + IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + RETURN + END + +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KppDecompCmplx( JVS, IER ) +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Sparse LU factorization, complex +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + INTEGER IER + DOUBLE COMPLEX JVS(KPP_LU_NONZERO), W(KPP_NVAR), a + INTEGER k, kk, j, jj + + IER = 0 + DO k=1,NVAR + IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + RETURN + END + +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KppSolveIndirect( JVS, X ) +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Sparse solve subroutine using indirect addressing +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + INTEGER i, j + KPP_REAL JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + + RETURN + END + +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + SUBROUTINE KppSolveCmplx( JVS, X ) +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +C Complex sparse solve subroutine using indirect addressing +C ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Sparse.h' + + INTEGER i, j + DOUBLE COMPLEX JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + + RETURN + END diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f90 new file mode 100755 index 00000000..daf8fa5b --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/sutil.f90 @@ -0,0 +1,134 @@ + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppDecomp( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_JacobianSP + + INTEGER :: IER + KPP_REAL :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a + INTEGER :: k, kk, j, jj + + a = 0. ! mz_rs_20050606 + IER = 0 + DO k=1,NVAR + ! mz_rs_20050606: don't check if real value == 0 + ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KppDecomp + + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppDecompCmplx( JVS, IER ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse LU factorization, complex +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_JacobianSP + + INTEGER :: IER + DOUBLE COMPLEX :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a + INTEGER :: k, kk, j, jj + + IER = 0 + DO k=1,NVAR + IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN + IER = k + RETURN + END IF + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + W( LU_ICOL(kk) ) = JVS(kk) + END DO + DO kk = LU_CROW(k), LU_DIAG(k)-1 + j = LU_ICOL(kk) + a = -W(j) / JVS( LU_DIAG(j) ) + W(j) = -a + DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1 + W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj) + END DO + END DO + DO kk = LU_CROW(k), LU_CROW(k+1)-1 + JVS(kk) = W( LU_ICOL(kk) ) + END DO + END DO + +END SUBROUTINE KppDecompCmplx + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveIndirect( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_JacobianSP + + INTEGER i, j + KPP_REAL JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KppSolveIndirect + +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SUBROUTINE KppSolveCmplx( JVS, X ) +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Complex sparse solve subroutine using indirect addressing +! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + USE KPP_ROOT_Parameters + USE KPP_ROOT_JacobianSP + + INTEGER i, j + DOUBLE COMPLEX JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum + + DO i=1,NVAR + DO j = LU_CROW(i), LU_DIAG(i)-1 + X(i) = X(i) - JVS(j)*X(LU_ICOL(j)); + END DO + END DO + + DO i=NVAR,1,-1 + sum = X(i); + DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1 + sum = sum - JVS(j)*X(LU_ICOL(j)); + END DO + X(i) = sum/JVS(LU_DIAG(i)); + END DO + +END SUBROUTINE KppSolveCmplx diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/tag2num.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/tag2num.f90 new file mode 100755 index 00000000..50bb4fa2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/tag2num.f90 @@ -0,0 +1,28 @@ +! **************************************************************** +! +! tag2num - convert equation tags to kpp reaction number +! Arguments : +! id - string with the equation tag +! +! **************************************************************** + +ELEMENTAL INTEGER FUNCTION tag2num ( id ) + + USE KPP_ROOT_Monitor, ONLY: EQN_TAGS + + CHARACTER(LEN=*), INTENT(IN) :: id + INTEGER i + + tag2num = 0 ! mz_rs_20050115 + DO i = 1, SIZE(EQN_TAGS) + IF (TRIM(EQN_TAGS(i)) == TRIM(id)) THEN + tag2num = i ! mz_rs_20050115 + EXIT + ENDIF + END DO + +END FUNCTION tag2num + +! End of tag2num function +! **************************************************************** + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.c b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.c new file mode 100755 index 00000000..4140f185 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.c @@ -0,0 +1,70 @@ +/* +#include +#include +#include +*/ +KPP_REAL min( KPP_REAL x, KPP_REAL y ) +{ + return ( x <= y ) ? x : y; +} + +KPP_REAL max( KPP_REAL x, KPP_REAL y ) +{ + return ( x >= y ) ? x : y; +} + +static FILE *fpDat = 0; + +int InitSaveData() +{ + fpDat = fopen("KPP_ROOT.dat", "w"); + if( fpDat == 0 ) { + printf("\n Can't create file : KPP_ROOT.dat"); + exit(1); + } + return 0; +} + +int SaveData() +{ +int i; + + fprintf( fpDat, "%6.1f ", TIME/3600.0 ); + for( i = 0; i < NLOOKAT; i++ ) + fprintf( fpDat, "%24.16e ", C[ LOOKAT[i] ]/CFACTOR ); + fprintf( fpDat, "\n"); + return 0; +} + +int CloseSaveData() +{ + fclose( fpDat ); + return 0; +} + +int GenerateMatlab( char * prefix ) +{ +int i; +FILE *fpMatlab; + + fpMatlab = fopen("KPP_ROOT.m", "w"); + if( fpMatlab == 0 ) { + printf("\n Can't create file : KPP_ROOT.m"); + exit(1); + } + + fprintf(fpMatlab, "load KPP_ROOT.dat;\n"); + fprintf(fpMatlab, "%sc = KPP_ROOT;\n", prefix); + fprintf(fpMatlab, "clear KPP_ROOT;\n"); + fprintf(fpMatlab, "%st=%sc(:,1);\n", prefix, prefix); + fprintf(fpMatlab, "%sc(:,1)=[];\n", prefix); + + for( i = 0; i < NLOOKAT; i++ ) + fprintf( fpMatlab, "%s%s = %sc(:,%d);\n", + prefix, SPC_NAMES[LOOKAT[i]], + prefix, i+1 ); + + fclose( fpMatlab ); + return 0; +} + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f new file mode 100755 index 00000000..e37aad8f --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f @@ -0,0 +1,102 @@ +C **************************************************************** +C +C InitSaveData - Opens the data file for writing +C Parameters : +C +C **************************************************************** + + SUBROUTINE InitSaveData () + + INCLUDE 'KPP_ROOT_Parameters.h' + + open(10, file='KPP_ROOT.dat') + + RETURN + END + +C End of InitSaveData function +C **************************************************************** + +C **************************************************************** +C +C SaveData - Write LOOKAT species in the data file +C Parameters : +C +C **************************************************************** + + SUBROUTINE SaveData () + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + INTEGER i + + WRITE(10,999) (TIME-TSTART)/3600.D0, + * (C(LOOKAT(i))/CFACTOR, i=1,NLOOKAT) +999 FORMAT(E24.16,100(1X,E24.16)) + + RETURN + END + +C End of SaveData function +C **************************************************************** + +C **************************************************************** +C +C CloseSaveData - Close the data file +C Parameters : +C +C **************************************************************** + + SUBROUTINE CloseSaveData () + + INCLUDE 'KPP_ROOT_Parameters.h' + + CLOSE(10) + + RETURN + END + +C End of CloseSaveData function +C **************************************************************** + +C **************************************************************** +C +C GenerateMatlab - Generates MATLAB file to load the data file +C Parameters : +C It will have a character string to prefix each +C species name with. +C +C **************************************************************** + + SUBROUTINE GenerateMatlab ( PREFIX ) + + INCLUDE 'KPP_ROOT_Parameters.h' + INCLUDE 'KPP_ROOT_Global.h' + + CHARACTER*8 PREFIX + INTEGER i + + open(20, file='KPP_ROOT.m') + write(20,*) 'load KPP_ROOT.dat;' + write(20,990) PREFIX +990 FORMAT(A1,'c = KPP_ROOT;') + write(20,*) 'clear KPP_ROOT;' + write(20,991) PREFIX, PREFIX +991 FORMAT(A1,'t=',A1,'c(:,1);') + write(20,992) PREFIX +992 FORMAT(A1,'c(:,1)=[];') + + do i=1,NLOOKAT + write(20,993) PREFIX, SPC_NAMES(LOOKAT(i)), PREFIX, i +993 FORMAT(A1,A6,' = ',A1,'c(:,',I2,');') + end do + + CLOSE(20) + + RETURN + END + +C End of GenerateMatlab function +C **************************************************************** + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f90 b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f90 new file mode 100755 index 00000000..96c5f205 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.f90 @@ -0,0 +1,101 @@ +! **************************************************************** +! +! InitSaveData - Opens the data file for writing +! Parameters : +! +! **************************************************************** + + SUBROUTINE InitSaveData () + + USE KPP_ROOT_Parameters + + open(10, file='KPP_ROOT.dat') + + END SUBROUTINE InitSaveData + +! End of InitSaveData function +! **************************************************************** + +! **************************************************************** +! +! SaveData - Write LOOKAT species in the data file +! Parameters : +! +! **************************************************************** + + SUBROUTINE SaveData () + + USE KPP_ROOT_Global + USE KPP_ROOT_Monitor + + INTEGER i + + WRITE(10,999) (TIME-TSTART)/3600.D0, & + (C(LOOKAT(i))/CFACTOR, i=1,NLOOKAT) +999 FORMAT(E24.16,100(1X,E24.16)) + + END SUBROUTINE SaveData + +! End of SaveData function +! **************************************************************** + +! **************************************************************** +! +! CloseSaveData - Close the data file +! Parameters : +! +! **************************************************************** + + SUBROUTINE CloseSaveData () + + USE KPP_ROOT_Parameters + + CLOSE(10) + + END SUBROUTINE CloseSaveData + +! End of CloseSaveData function +! **************************************************************** + +! **************************************************************** +! +! GenerateMatlab - Generates MATLAB file to load the data file +! Parameters : +! It will have a character string to prefix each +! species name with. +! +! **************************************************************** + + SUBROUTINE GenerateMatlab ( PREFIX ) + + USE KPP_ROOT_Parameters + USE KPP_ROOT_Global + USE KPP_ROOT_Monitor + + + CHARACTER(LEN=8) PREFIX + INTEGER i + + open(20, file='KPP_ROOT.m') + write(20,*) 'load KPP_ROOT.dat;' + write(20,990) PREFIX +990 FORMAT(A1,'c = KPP_ROOT;') + write(20,*) 'clear KPP_ROOT;' + write(20,991) PREFIX, PREFIX +991 FORMAT(A1,'t=',A1,'c(:,1);') + write(20,992) PREFIX +992 FORMAT(A1,'c(:,1)=[];') + + do i=1,NLOOKAT + write(20,993) PREFIX, SPC_NAMES(LOOKAT(i)), PREFIX, i +993 FORMAT(A1,A6,' = ',A1,'c(:,',I2,');') + end do + + CLOSE(20) + + END SUBROUTINE GenerateMatlab + +! End of GenerateMatlab function +! **************************************************************** + + diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.m b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.m new file mode 100755 index 00000000..4f094685 --- /dev/null +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/util/util.m @@ -0,0 +1,54 @@ +% **************************************************************** +% +% InitSaveData - Opens the data file for writing +% +% **************************************************************** + +function InitSaveData () + +global KPP_ROOT_FID + + KPP_ROOT_FID = fopen('KPP_ROOT.dat','w'); + +return % InitSaveData + +% End of InitSaveData function +% **************************************************************** + +% **************************************************************** +% +% SaveData - Write LOOKAT species in the data file +% +% **************************************************************** + +function SaveData () + +global VAR FIX CFACTOR LOOKAT NLOOKAT KPP_ROOT_FID + + C(1:KPP_NVAR) = VAR(1:KPP_NVAR); + C(KPP_NVAR+1:KPP_NSPEC) = FIX(1:KPP_NFIX); + + fprintf(KPP_ROOT_FID,'%12.5e,',C(LOOKAT(1:NLOOKAT))); + +return % SaveData + +% End of SaveData function +% **************************************************************** + +% **************************************************************** +% +% CloseSaveData - Close the data file +% +% **************************************************************** + +function CloseSaveData () +global KPP_ROOT_FID + + fclose( KPP_ROOT_FID ); + +return % CloseSaveData + +% End of CloseSaveData function +% **************************************************************** + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racm/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/racm.def b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.def new file mode 100644 index 00000000..5e8af943 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.def @@ -0,0 +1,21 @@ +#include atoms_red +#include ./racm.spc +#include ./racm.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/racm.eqn b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.eqn new file mode 100644 index 00000000..d4defe89 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.eqn @@ -0,0 +1,242 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00e-34*(TEMP/300.0)**(-2.3)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00e-12 , 2060.0, TEMP) ; + {026:003} O1D + M = O3{+O2} : .78084*ARR2(1.8E-11,-110., TEMP); + {027:004} O1D + M = O3P{+O2} : .20946*ARR2( 3.20e-11 , -70.0 , TEMP ) ; + {028:005} O1D+H2O=HO+HO : 2.20e-10 ; + {029:006} O3+HO=HO2{+O2} : ARR2( 1.60e-12 , 940.0, TEMP ) ; + {030:007} O3+HO2=HO{+2.0 O2} : ARR2( 1.10e-14 , 500.0, TEMP ) ; + {031:008} HO+HO2=H2O{+O2} : ARR2( 4.80e-11 , -250.0, TEMP ) ; + {032:009} H2O2+HO=HO2+H2O : ARR2( 2.90e-12 , 160.0, TEMP ) ; + {033:010} HO2+HO2=H2O2{+O2} : (2.3e-13*EXP(600./TEMP) + 1.7e-33* C_M *EXP(1000./TEMP)) ; + {034:011} HO2+HO2+H2O=H2O2+H2O{+O2} : (3.22e-34* EXP(2800./TEMP)+ 2.38e-54* C_M *EXP(3200./TEMP)) ; + {035:012} O3P+NO=NO2 : TROE( 9.00e-32 , 1.5 , 3.00e-11 , 0.0 , TEMP, C_M) ; + {036:013} O3P+NO2=NO{+O2} : ARR2( 6.50e-12 , -120.0, TEMP) ; + {037:014} O3P+NO2=NO3 : TROE( 9.00e-32 , 2.0 , 2.20e-11 , 0.0 , TEMP, C_M) ; + {038:015} NO+HO=HONO : TROE( 7.00e-31 , 2.6 , 1.50e-11 , 0.5 , TEMP, C_M) ; + {039:016} HO+NO2=HNO3 : TROE( 2.60e-30 , 3.2 , 2.40e-11 , 1.3 , TEMP, C_M) ; + {040:017} HO+NO3=NO2+HO2 : 2.20e-11 ; + {041:018} HO2+NO=NO2+HO : ARR2( 3.70e-12 , -250.0, TEMP ) ; + {042:019} HO2+NO2=HNO4 : TROE( 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M) ; + {043:020} HNO4=HO2+NO2 : TROEE( 4.76e26,10900.0, 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M ) ; + {044:021} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50e-12 ; + {045:022} HO+HONO=NO2+H2O : ARR2( 1.80e-11 , 390.0, TEMP ) ; + {046:023} HO+HNO3=NO3+H2O : k46(TEMP,C_M) ; + {047:024} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30e-12 , -380.0, TEMP ) ; + {048:025} O3+NO=NO2{+O2} : ARR2( 2.00e-12 , 1400.0, TEMP ) ; + {049:026} O3+NO2=NO3{+O2} : ARR2( 1.20e-13 , 2450.0, TEMP ) ; + {050:027} NO+NO+M{O2}=NO2+NO2 : (.20946e0*ARR2( 3.30e-39 , -530.0, TEMP )) ; + {051:028} NO3+NO=NO2+NO2 : ARR2( 1.50e-11 , -170.0 , TEMP) ; + {052:029} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50e-14, 1260.0, TEMP ) ; + {053:030} NO3+NO2=N2O5 : TROE( 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M) ; + {054:031} N2O5=NO2+NO3 : TROEE(3.70e26,11000.0, 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M ) ; + {055:032} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50e-13 , 2450.0, TEMP ) ; + {056:033} HO+M{=H2}=H2O+HO2 : (5.31E-7*ARR2( 5.50e-12 , 2000.0, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {057:034} HO+SO2=SULF+HO2 : TROE( 3.00e-31 , 3.3 , 1.50e-12 , 0.0 , TEMP, C_M) ; + {058:035} CO+HO=HO2+CO2 : 1.5e-13 * (1.0 + 2.439e-20 * C_M) ; + {059:036} ISO+O3P=0.86 OLT+0.05 HCHO+0.02 HO+0.01 CO+0.13 DCB+0.28 HO2+0.15 XO2 : 6.0E-11 ; + {060:037} MACR+O3P=ALD : ARR2(1.59E-11,-13.0, TEMP) ; + {061:038} CH4+HO=MO2+H2O : (THERMAL_T2(7.44e-18, 1361.0,TEMP )) ; + {062:039} ETH+HO=ETHP+H2O : (THERMAL_T2(1.51e-17, 492.0,TEMP )) ; + {063:040} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26e-12 , 260.0, TEMP ) ; + {064:041} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02e-12 , 155.0, TEMP ) ; + {065:042} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64e-11 , 125.0, TEMP ) ; + {066:043} ETE+HO=ETEP : ARR2( 1.96e-12 , -438.0, TEMP ) ; + {067:044} OLT+HO=OLTP : ARR2( 5.72e-12 , -500.0, TEMP ) ; + {068:045} OLI+HO=OLIP : ARR2( 1.33e-11 , -500.0, TEMP ) ; + {069:046} DIEN+HO=ISOP : ARR2( 1.48e-11 , -448.0, TEMP ) ; + {070:047} ISO+HO=ISOP : ARR2( 2.54e-11 , -410.0, TEMP ) ; + {071:048} API+HO=APIP : ARR2( 1.21e-11 , -444.0, TEMP ) ; + {072:049} LIM+HO=LIMP : 1.71e-10 ; + {073:050} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81e-12 , -355.0, TEMP ) ; + {074:051} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30e-12 , -355.0, TEMP ) ; + {075:052} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.00e-11 ; + {076:053} HCHO+HO=HO2+CO+H2O : 1.00e-11 ; + {077:054} ALD+HO=ACO3+H2O : ARR2( 5.55e-12 , -331.0, TEMP ) ; + {078:055} KET+HO=KETP+H2O : (THERMAL_T2(5.68e-18, -92.0,TEMP )) ; + {079:056} HKET+HO=HO2+MGLY+H2O : 3.00e-12 ; + {080:057} GLY+HO=HO2+2.0 CO+H2O : 1.14e-11 ; + {081:058} MGLY+HO=ACO3+CO+H2O : 1.72e-11 ; + {082:059} MACR+HO=0.51 TCO3+0.41 HKET+0.08 MGLY+0.41 CO+0.08 HCHO+0.49 HO2+0.49 XO2 : ARR2(1.86E-11, -175.0, TEMP) ; + {083:060} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80e-11 , -175.0, TEMP ) ; + {084:061} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70e-10 ; + {085:062} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {086:063} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40e-12 , -190.0, TEMP ) ; + {087:064} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {088:065} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00e-14 ; + {089:066} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25e-13 , -500.0, TEMP ) ; + {090:067} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31e-12 , 260.0 , TEMP) ; + {091:068} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40e-13 , 1900.0, TEMP ) ; + {092:069} ALD+NO3=ACO3+HNO3 : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {093:070} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90e-12 , 1900.0, TEMP ) ; + {094:071} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {095:072} MACR+NO3=0.20 TCO3+0.20 HNO3+0.80 OLNN+0.80 CO : ARR2(8.27E-15, 150.0, TEMP) ; + {096:073} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87e-13 , 1000.0, TEMP ) ; + {097:074} CSL+NO3=HNO3+PHO : 2.20e-11 ; + {098:075} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88e-18 , 2282.0,TEMP )) ; + {099:076} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79e-13 , 450.0, TEMP ) ; + {100:077} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64e-13 , -450.0, TEMP ) ; + {101:078} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00e-13 ; + {102:079} ISO+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : ARR2(4.0E-12, 446.0, TEMP) ; + {103:080} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19e-12 , -490.0, TEMP ) ; + {104:081} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22e-11 ; + {105:082} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20e-14 , 500.0, TEMP ) ; + {106:083} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 9.14e-15 , 2580.0, TEMP ) ; + {107:084} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33e-15, 1800.0, TEMP ) ; + {108:085} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40e-15 , 845.0, TEMP ) ; + {109:086} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34e-14 , 2283.0, TEMP ) ; + {110:087} ISO+O3=0.9 HCHO+0.39 MACR+0.36 CO +0.15 ORA1+0.09 O3P+0.30 HO2 +0.35 OLT+0.28 HO +0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2 +0.001 H2O2{+0.05 H2} : ARR2(7.86E-15, 1913.0, TEMP) ; + {111:088} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01e-15 , 732.0, TEMP ) ; + {112:089} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00e-16 ; + {113:090} MACR+O3=0.40 HCHO+0.60 MGLY+0.13 ORA2+0.54 CO+0.22 ORA1+0.29 HO2+0.07 HO+0.13 OP2+0.13 ACO3 {+0.08 H2} : ARR2(1.36E-15, 2112.0, TEMP) ; + {114:091} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00e-18 ; + {115:092} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46e-15 , 1700.0, TEMP ) ; + {116:093} PHO+NO2=0.10 CSL+ONIT : 2.00e-11 ; + {117:094} PHO+HO2=CSL : 1.00e-11 ; + {118:095} ADDT+NO2=CSL+HONO : 3.60e-11 ; + {119:096} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {120:097} ADDT+O3=CSL+HO : 5.00e-11 ; + {121:098} ADDX+NO2=CSL+HONO : 3.60e-11 ; + {122:099} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {123:100} ADDX+O3=CSL+HO : 1.00e-11 ; + {124:101} ADDC+NO2=CSL+HONO : 3.60e-11 ; + {125:102} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {126:103} ADDC+O3=CSL+HO : 5.00e-11 ; + {127:104} ACO3+NO2=PAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {128:105} PAN=ACO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {129:106} TCO3+NO2=TPAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {130:107} TPAN=TCO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M ) ; + {131:108} MO2+NO=HCHO+HO2+NO2 : ARR2( 4.20e-12 , -180.0, TEMP ) ; + {132:109} ETHP+NO=ALD+HO2+NO2 : 8.70e-12 ; + {133:110} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00e-12 ; + {134:111} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00e-12 ; + {135:112} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00e-12 ; + {136:113} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00e-12 ; + {137:114} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00e-12 ; + {138:115} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00e-12 ; + {139:116} ISOP+NO=0.446 MACR+0.354 OLT +0.847 HO2+0.606 HCHO+0.153 ONIT+0.847 NO2 : 4.0E-12 ; + {140:117} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00e-12 ; + {141:118} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00e-12 ; + {142:119} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00e-12 ; + {143:120} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00e-12 ; + {144:121} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00e-12 ; + {145:122} ACO3+NO=MO2+NO2 : 2.00e-11 ; + {146:123} TCO3+NO=ACO3+HCHO+NO2 : 2.00e-11 ; + {147:124} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00e-12 ; + {148:125} OLNN+NO=HO2+ONIT+NO2 : 4.00e-12 ; + {149:126} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00e-12 ; + {150:127} MO2+HO2=OP1 : ARR2( 3.80e-13 , -800.0, TEMP ) ; + {151:128} ETHP+HO2=OP2 : ARR2( 7.50e-13 , -700.0, TEMP ) ; + {152:129} HC3P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {153:130} HC5P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {154:131} HC8P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {155:132} ETEP+HO2=OP2 : ARR2( 1.90e-13 , -1300.0, TEMP ) ; + {156:133} OLTP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {157:134} OLIP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {158:135} ISOP+HO2=OP2 : ARR2( 1.28E-13 , -1300.0, TEMP) ; + {159:136} APIP+HO2=OP2 : 1.50e-11 ; + {160:137} LIMP+HO2=OP2 : 1.50e-11 ; + {161:138} TOLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {162:139} XYLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP) ; + {163:140} CSLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {164:141} ACO3+HO2=PAA : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {165:142} ACO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {166:143} TCO3+HO2=OP2 : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {167:144} TCO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {168:145} KETP+HO2=OP2 : ARR2( 1.15e-13 , -1300.0, TEMP ) ; + {169:146} OLNN+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {170:147} OLND+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {171:148} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.10e-14 , -416.0, TEMP ) ; + {172:149} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18e-13 , -158.0, TEMP ) ; + {173:150} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46e-14 , -431.0 , TEMP) ; + {174:151} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00e-13 , -467.0, TEMP ) ; + {175:152} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34e-14 , -633.0, TEMP ) ; + {176:153} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71e-13 , -708.0, TEMP ) ; + {177:154} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46e-13 , -708.0, TEMP ) ; + {178:155} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18e-14 , -708.0, TEMP ) ; + {179:156} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36e-13 , -708.0, TEMP ) ; + {180:157} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {181:158} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {182:159} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {183:160} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {184:161} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {185:162} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {186:163} ACO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {187:164} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {188:165} TCO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {189:166} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91e-13 , -508.0, TEMP ) ; + {190:167} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60e-13 , -708.0, TEMP ) ; + {191:168} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68e-14 , -708.0, TEMP ) ; + {192:169} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03e-12 , -211.0, TEMP ) ; + {193:170} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90e-13 , -460.0, TEMP ) ; + {194:171} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59e-13 , -522.0, TEMP ) ; + {195:172} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47e-13 , -683.0, TEMP ) ; + {196:173} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48e-13 , -765.0, TEMP ) ; + {197:174} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11e-13 , -765.0, TEMP ) ; + {198:175} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09e-13 , -765.0, TEMP ) ; + {199:176} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60e-13 , -765.0, TEMP ) ; + {200:177} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {201:178} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {202:179} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {203:180} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {204:181} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {205:182} ACO3+ACO3=2.0 MO2 : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {206:183} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {207:184} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51e-13 , -565.0, TEMP ) ; + {208:185} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85e-13 , -765.0, TEMP ) ; + {209:186} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37e-13 , -765.0, TEMP ) ; + {210:187} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00e-14 , -1000.0 , TEMP) ; + {211:188} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25e-14 , -1000.0, TEMP ) ; + {212:189} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96e-14 , -1000.0, TEMP ) ; + {213:190} MO2+NO3=HCHO+HO2+NO2 : 1.20e-12 ; + {214:191} ETHP+NO3=ALD+HO2+NO2 : 1.20e-12 ; + {215:192} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20e-12 ; + {216:193} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20e-12 ; + {217:194} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20e-12 ; + {218:195} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20e-12 ; + {219:196} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20e-12 ; + {220:197} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20e-12 ; + {221:198} ISOP+NO3=0.60 MACR+0.40 OLT +0.686 HCHO+HO2+NO2 : 1.20E-12 ; + {222:199} APIP+NO3=ALD+KET+HO2+NO2 : 1.20e-12 ; + {223:200} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20e-12 ; + {224:201} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20e-12 ; + {225:202} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20e-12 ; + {226:203} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20e-12; + {227:204} ACO3+NO3=MO2+NO2 : 4.00e-12; + {228:205} TCO3+NO3=HCHO+ACO3+NO2 : 4.00e-12; + {229:206} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20e-12 ; + {230:207} OLNN+NO3=ONIT+HO2+NO2 : 1.20e-12 ; + {231:208} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20e-12 ; + {232:209} XO2+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {233:210} XO2+MO2=HCHO+HO2 : ARR2( 5.99e-15 , -1510.0, TEMP ) ; + {234:211} XO2+ACO3=MO2 : ARR2( 3.40e-14 , -1560.0, TEMP ) ; + {235:212} XO2+XO2=M{O2} : ARR2( 7.13e-17 , -2950.0, TEMP ) ; + {236:213} XO2+NO=NO2 : 4.00e-12 ; + {237:214} XO2+NO3=NO2 : 1.20e-12 ; + + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/racm.kpp b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.kpp new file mode 100644 index 00000000..d757d33f --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.kpp @@ -0,0 +1,10 @@ +#MODEL racm +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/racm.spc b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.spc new file mode 100644 index 00000000..bd882298 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/racm.spc @@ -0,0 +1,81 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + XO2 =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/racm_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racm/racm_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/racm_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm/temp.eqnf b/wrfv2_fire/chem/KPP/mechanisms/racm/temp.eqnf new file mode 100644 index 00000000..59ab29f0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm/temp.eqnf @@ -0,0 +1,19 @@ + + + HACE =IGNORE ; + ISHP =IGNORE ; + ISON =IGNORE ; + MACP =IGNORE ; + MAHP =IGNORE ; + MPAN =IGNORE ; + NALD =IGNORE ; + + + {238:215} ISOP+ISOP=2. MACR+HCHO+HO2 : 2.00e-12 ; + {239:216} ISHP+HO=MACR+HO : 1.00e-10 ; + {240:217} ISON+HO=HACE+NALD : 1.30e-11 ; + {241:218} MACP+NO=NO2+0.25 HACE+0.25 CO+0.25 ACO3+0.5 MGLY+0.75 HCHO+0.75 HO2 : ARR2( 2.54e-12 , -360.0, TEMP ) ; + {242:219} MACP+HO2=MAHP : ARR2( 1.82e-13 , -1300.0, TEMP ) ; + {243:220} MACP+MACP=HACE+MGLY+0.5 HCHO+0.5 CO+HO2 : 2.00e-12 ; + {244:221} MACP+NO2=MPAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {245:222} MPAN=MACP+NO2 : TROEE(1.11e28,14000.0,9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M ) ; \ No newline at end of file diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.def b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.def new file mode 100644 index 00000000..68490fc8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.def @@ -0,0 +1,21 @@ +#include atoms_red +#include ./racm_mim.spc +#include ./racm_mim.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.eqn b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.eqn new file mode 100644 index 00000000..61c16321 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.eqn @@ -0,0 +1,247 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00e-34*(TEMP/300.0)**(-2.3)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00e-12 , 2060.0, TEMP) ; + {026:003} O1D + M = O3{+O2} : .78084*ARR2(1.8E-11,-110., TEMP); + {027:004} O1D + M = O3P{+O2} : .20946*ARR2( 3.20e-11 , -70.0 , TEMP ) ; + {028:005} O1D+H2O=HO+HO : 2.20e-10 ; + {029:006} O3+HO=HO2{+O2} : ARR2( 1.60e-12 , 940.0, TEMP ) ; + {030:007} O3+HO2=HO{+2.0 O2} : ARR2( 1.10e-14 , 500.0, TEMP ) ; + {031:008} HO+HO2=H2O{+O2} : ARR2( 4.80e-11 , -250.0, TEMP ) ; + {032:009} H2O2+HO=HO2+H2O : ARR2( 2.90e-12 , 160.0, TEMP ) ; + {033:010} HO2+HO2=H2O2{+O2} : (2.3e-13*EXP(600./TEMP) + 1.7e-33* C_M *EXP(1000./TEMP)) ; + {034:011} HO2+HO2+H2O=H2O2+H2O{+O2} : (3.22e-34* EXP(2800./TEMP)+ 2.38e-54* C_M *EXP(3200./TEMP)) ; + {035:012} O3P+NO=NO2 : TROE( 9.00e-32 , 1.5 , 3.00e-11 , 0.0 , TEMP, C_M) ; + {036:013} O3P+NO2=NO{+O2} : ARR2( 6.50e-12 , -120.0, TEMP) ; + {037:014} O3P+NO2=NO3 : TROE( 9.00e-32 , 2.0 , 2.20e-11 , 0.0 , TEMP, C_M) ; + {038:015} NO+HO=HONO : TROE( 7.00e-31 , 2.6 , 1.50e-11 , 0.5 , TEMP, C_M) ; + {039:016} HO+NO2=HNO3 : TROE( 2.60e-30 , 3.2 , 2.40e-11 , 1.3 , TEMP, C_M) ; + {040:017} HO+NO3=NO2+HO2 : 2.20e-11 ; + {041:018} HO2+NO=NO2+HO : ARR2( 3.70e-12 , -250.0, TEMP ) ; + {042:019} HO2+NO2=HNO4 : TROE( 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M) ; + {043:020} HNO4=HO2+NO2 : TROEE( 4.76e26,10900.0, 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M ) ; + {044:021} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50e-12 ; + {045:022} HO+HONO=NO2+H2O : ARR2( 1.80e-11 , 390.0, TEMP ) ; + {046:023} HO+HNO3=NO3+H2O : k46(TEMP,C_M) ; + {047:024} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30e-12 , -380.0, TEMP ) ; + {048:025} O3+NO=NO2{+O2} : ARR2( 2.00e-12 , 1400.0, TEMP ) ; + {049:026} O3+NO2=NO3{+O2} : ARR2( 1.20e-13 , 2450.0, TEMP ) ; + {050:027} NO+NO+M{O2}=NO2+NO2 : (.20946e0*ARR2( 3.30e-39 , -530.0, TEMP )) ; + {051:028} NO3+NO=NO2+NO2 : ARR2( 1.50e-11 , -170.0 , TEMP) ; + {052:029} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50e-14, 1260.0, TEMP ) ; + {053:030} NO3+NO2=N2O5 : TROE( 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M) ; + {054:031} N2O5=NO2+NO3 : TROEE(3.70e26,11000.0, 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M ) ; + {055:032} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50e-13 , 2450.0, TEMP ) ; + {056:033} HO+M{=H2}=H2O+HO2 : (5.31E-7*ARR2( 5.50e-12 , 2000.0, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {057:034} HO+SO2=SULF+HO2 : TROE( 3.00e-31 , 3.3 , 1.50e-12 , 0.0 , TEMP, C_M) ; + {058:035} CO+HO=HO2+CO2 : 1.5e-13 * (1.0 + 2.439e-20 * C_M) ; + {059:036} NALD+HO=HCHO+CO+NO2 : ARR2( 5.60e-12 , -270.0, TEMP ) ; + {060:037} HACE+HO=MGLY+HO2 : 3.00e-12 ; + {061:038} CH4+HO=MO2+H2O : (THERMAL_T2(7.44e-18, 1361.0,TEMP )) ; + {062:039} ETH+HO=ETHP+H2O : (THERMAL_T2(1.51e-17, 492.0,TEMP )) ; + {063:040} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26e-12 , 260.0, TEMP ) ; + {064:041} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02e-12 , 155.0, TEMP ) ; + {065:042} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64e-11 , 125.0, TEMP ) ; + {066:043} ETE+HO=ETEP : ARR2( 1.96e-12 , -438.0, TEMP ) ; + {067:044} OLT+HO=OLTP : ARR2( 5.72e-12 , -500.0, TEMP ) ; + {068:045} OLI+HO=OLIP : ARR2( 1.33e-11 , -500.0, TEMP ) ; + {069:046} DIEN+HO=ISOP : ARR2( 1.48e-11 , -448.0, TEMP ) ; + {070:047} ISO+HO=ISOP : ARR2( 2.54e-11 , -410.0, TEMP ) ; + {071:048} API+HO=APIP : ARR2( 1.21e-11 , -444.0, TEMP ) ; + {072:049} LIM+HO=LIMP : 1.71e-10 ; + {073:050} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81e-12 , -355.0, TEMP ) ; + {074:051} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30e-12 , -355.0, TEMP ) ; + {075:052} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.00e-11 ; + {076:053} HCHO+HO=HO2+CO+H2O : 1.00e-11 ; + {077:054} ALD+HO=ACO3+H2O : ARR2( 5.55e-12 , -331.0, TEMP ) ; + {078:055} KET+HO=KETP+H2O : (THERMAL_T2(5.68e-18, -92.0,TEMP )) ; + {079:056} HKET+HO=HO2+MGLY+H2O : 3.00e-12 ; + {080:057} GLY+HO=HO2+2.0 CO+H2O : 1.14e-11 ; + {081:058} MGLY+HO=ACO3+CO+H2O : 1.72e-11 ; + {082:059} MACR+HO=MACP : .5*(4.13e-12*EXP(425./TEMP) + 1.86e-11*EXP(175./TEMP)) ; + {083:060} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80e-11 , -175.0, TEMP ) ; + {084:061} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70e-10 ; + {085:062} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {086:063} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40e-12 , -190.0, TEMP ) ; + {087:064} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {088:065} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00e-14 ; + {089:066} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25e-13 , -500.0, TEMP ) ; + {090:067} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31e-12 , 260.0 , TEMP) ; + {091:068} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40e-13 , 1900.0, TEMP ) ; + {092:069} ALD+NO3=ACO3+HNO3 : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {093:070} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90e-12 , 1900.0, TEMP ) ; + {094:071} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {095:072} MAHP+HO=MACP : 3.00e-11 ; + {096:073} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87e-13 , 1000.0, TEMP ) ; + {097:074} CSL+NO3=HNO3+PHO : 2.20e-11 ; + {098:075} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88e-18 , 2282.0,TEMP )) ; + {099:076} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79e-13 , 450.0, TEMP ) ; + {100:077} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64e-13 , -450.0, TEMP ) ; + {101:078} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00e-13 ; + {102:079} ISO+NO3=ISON : ARR2( 3.03e-12 , 446.0, TEMP ) ; + {103:080} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19e-12 , -490.0, TEMP ) ; + {104:081} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22e-11 ; + {105:082} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20e-14 , 500.0, TEMP ) ; + {106:083} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 9.14e-15 , 2580.0, TEMP ) ; + {107:084} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33e-15, 1800.0, TEMP ) ; + {108:085} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40e-15 , 845.0, TEMP ) ; + {109:086} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34e-14 , 2283.0, TEMP ) ; + {110:087} ISO+O3=0.65 MACR+0.58 HCHO+0.1 MACP+0.1 ACO3+0.08 MO2+0.28 ORA1+0.14 CO+0.09 H2O2+0.25 HO2+0.25 HO : ARR2( 7.86e-15 , 1913.0, TEMP ) ; + {111:088} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01e-15 , 732.0, TEMP ) ; + {112:089} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00e-16 ; + {113:090} MACR+O3=0.9 MGLY+0.45 ORA1+0.32 HO2+0.22 CO+0.19 HO+0.1 ACO3 : .5*(1.36e-15*EXP(-2112./TEMP)+7.51e-16*EXP(-1521./TEMP)) ; + {114:091} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00e-18 ; + {115:092} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46e-15 , 1700.0, TEMP ) ; + {116:093} PHO+NO2=0.10 CSL+ONIT : 2.00e-11 ; + {117:094} PHO+HO2=CSL : 1.00e-11 ; + {118:095} ADDT+NO2=CSL+HONO : 3.60e-11 ; + {119:096} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {120:097} ADDT+O3=CSL+HO : 5.00e-11 ; + {121:098} ADDX+NO2=CSL+HONO : 3.60e-11 ; + {122:099} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {123:100} ADDX+O3=CSL+HO : 1.00e-11 ; + {124:101} ADDC+NO2=CSL+HONO : 3.60e-11 ; + {125:102} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {126:103} ADDC+O3=CSL+HO : 5.00e-11 ; + {127:104} ACO3+NO2=PAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {128:105} PAN=ACO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {129:106} TCO3+NO2=TPAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {130:107} TPAN=TCO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M ) ; + {131:108} MO2+NO=HCHO+HO2+NO2 : ARR2( 4.20e-12 , -180.0, TEMP ) ; + {132:109} ETHP+NO=ALD+HO2+NO2 : 8.70e-12 ; + {133:110} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00e-12 ; + {134:111} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00e-12 ; + {135:112} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00e-12 ; + {136:113} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00e-12 ; + {137:114} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00e-12 ; + {138:115} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00e-12 ; + {139:116} ISOP+NO=MACR+NO2+HCHO+HO2+0.046 ISON : ARR2( 2.43e-12 , -360.0, TEMP ) ; + {140:117} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00e-12 ; + {141:118} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00e-12 ; + {142:119} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00e-12 ; + {143:120} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00e-12 ; + {144:121} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00e-12 ; + {145:122} ACO3+NO=MO2+NO2 : 2.00e-11 ; + {146:123} TCO3+NO=ACO3+HCHO+NO2 : 2.00e-11 ; + {147:124} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00e-12 ; + {148:125} OLNN+NO=HO2+ONIT+NO2 : 4.00e-12 ; + {149:126} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00e-12 ; + {150:127} MO2+HO2=OP1 : ARR2( 3.80e-13 , -800.0, TEMP ) ; + {151:128} ETHP+HO2=OP2 : ARR2( 7.50e-13 , -700.0, TEMP ) ; + {152:129} HC3P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {153:130} HC5P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {154:131} HC8P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {155:132} ETEP+HO2=OP2 : ARR2( 1.90e-13 , -1300.0, TEMP ) ; + {156:133} OLTP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {157:134} OLIP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {158:135} ISOP+HO2=ISHP : ARR2( 2.05e-13 , -1300.0, TEMP ) ; + {159:136} APIP+HO2=OP2 : 1.50e-11 ; + {160:137} LIMP+HO2=OP2 : 1.50e-11 ; + {161:138} TOLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {162:139} XYLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP) ; + {163:140} CSLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {164:141} ACO3+HO2=PAA : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {165:142} ACO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {166:143} TCO3+HO2=OP2 : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {167:144} TCO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {168:145} KETP+HO2=OP2 : ARR2( 1.15e-13 , -1300.0, TEMP ) ; + {169:146} OLNN+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {170:147} OLND+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {171:148} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.10e-14 , -416.0, TEMP ) ; + {172:149} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18e-13 , -158.0, TEMP ) ; + {173:150} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46e-14 , -431.0 , TEMP) ; + {174:151} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00e-13 , -467.0, TEMP ) ; + {175:152} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34e-14 , -633.0, TEMP ) ; + {176:153} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71e-13 , -708.0, TEMP ) ; + {177:154} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46e-13 , -708.0, TEMP ) ; + {178:155} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18e-14 , -708.0, TEMP ) ; + {179:156} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36e-13 , -708.0, TEMP ) ; + {180:157} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {181:158} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {182:159} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {183:160} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {184:161} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {185:162} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {186:163} ACO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {187:164} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {188:165} TCO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {189:166} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91e-13 , -508.0, TEMP ) ; + {190:167} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60e-13 , -708.0, TEMP ) ; + {191:168} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68e-14 , -708.0, TEMP ) ; + {192:169} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03e-12 , -211.0, TEMP ) ; + {193:170} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90e-13 , -460.0, TEMP ) ; + {194:171} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59e-13 , -522.0, TEMP ) ; + {195:172} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47e-13 , -683.0, TEMP ) ; + {196:173} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48e-13 , -765.0, TEMP ) ; + {197:174} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11e-13 , -765.0, TEMP ) ; + {198:175} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09e-13 , -765.0, TEMP ) ; + {199:176} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60e-13 , -765.0, TEMP ) ; + {200:177} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {201:178} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {202:179} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {203:180} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {204:181} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {205:182} ACO3+ACO3=2.0 MO2 : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {206:183} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {207:184} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51e-13 , -565.0, TEMP ) ; + {208:185} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85e-13 , -765.0, TEMP ) ; + {209:186} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37e-13 , -765.0, TEMP ) ; + {210:187} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00e-14 , -1000.0 , TEMP) ; + {211:188} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25e-14 , -1000.0, TEMP ) ; + {212:189} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96e-14 , -1000.0, TEMP ) ; + {213:190} MO2+NO3=HCHO+HO2+NO2 : 1.20e-12 ; + {214:191} ETHP+NO3=ALD+HO2+NO2 : 1.20e-12 ; + {215:192} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20e-12 ; + {216:193} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20e-12 ; + {217:194} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20e-12 ; + {218:195} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20e-12 ; + {219:196} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20e-12 ; + {220:197} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20e-12 ; + {221:198} MPAN+HO=HACE+NO2 : 3.60e-12 ; + {222:199} APIP+NO3=ALD+KET+HO2+NO2 : 1.20e-12 ; + {223:200} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20e-12 ; + {224:201} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20e-12 ; + {225:202} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20e-12 ; + {226:203} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20e-12; + {227:204} ACO3+NO3=MO2+NO2 : 4.00e-12; + {228:205} TCO3+NO3=HCHO+ACO3+NO2 : 4.00e-12; + {229:206} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20e-12 ; + {230:207} OLNN+NO3=ONIT+HO2+NO2 : 1.20e-12 ; + {231:208} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20e-12 ; + {232:209} XO2+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {233:210} XO2+MO2=HCHO+HO2 : ARR2( 5.99e-15 , -1510.0, TEMP ) ; + {234:211} XO2+ACO3=MO2 : ARR2( 3.40e-14 , -1560.0, TEMP ) ; + {235:212} XO2+XO2=M{O2} : ARR2( 7.13e-17 , -2950.0, TEMP ) ; + {236:213} XO2+NO=NO2 : 4.00e-12 ; + {237:214} XO2+NO3=NO2 : 1.20e-12 ; + {238:215} ISOP+ISOP=2. MACR+HCHO+HO2 : 2.00e-12 ; + {239:216} ISHP+HO=MACR+HO : 1.00e-10 ; + {240:217} ISON+HO=HACE+NALD : 1.30e-11 ; + {241:218} MACP+NO=NO2+0.25 HACE+0.25 CO+0.25 ACO3+0.5 MGLY+0.75 HCHO+0.75 HO2 : ARR2( 2.54e-12 , -360.0, TEMP ) ; + {242:219} MACP+HO2=MAHP : ARR2( 1.82e-13 , -1300.0, TEMP ) ; + {243:220} MACP+MACP=HACE+MGLY+0.5 HCHO+0.5 CO+HO2 : 2.00e-12 ; + {244:221} MACP+NO2=MPAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {245:222} MPAN=MACP+NO2 : TROEE(1.11e28,14000.0,9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M ) ; + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.kpp b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.kpp new file mode 100644 index 00000000..fad1c44a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.kpp @@ -0,0 +1,10 @@ +#MODEL racm_mim +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.spc b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.spc new file mode 100644 index 00000000..5685a481 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim.spc @@ -0,0 +1,88 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE ; + XO2 =IGNORE ; + HACE =IGNORE ; + ISHP =IGNORE ; + ISON =IGNORE ; + MACP =IGNORE ; + MAHP =IGNORE ; + MPAN =IGNORE ; + NALD =IGNORE ; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_mim/racm_mim_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.def b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.def new file mode 100644 index 00000000..86d27a63 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.def @@ -0,0 +1,21 @@ +#include atoms_red +#include ./racmsorg.spc +#include ./racmsorg.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.eqn b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.eqn new file mode 100644 index 00000000..d4defe89 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.eqn @@ -0,0 +1,242 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00e-34*(TEMP/300.0)**(-2.3)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00e-12 , 2060.0, TEMP) ; + {026:003} O1D + M = O3{+O2} : .78084*ARR2(1.8E-11,-110., TEMP); + {027:004} O1D + M = O3P{+O2} : .20946*ARR2( 3.20e-11 , -70.0 , TEMP ) ; + {028:005} O1D+H2O=HO+HO : 2.20e-10 ; + {029:006} O3+HO=HO2{+O2} : ARR2( 1.60e-12 , 940.0, TEMP ) ; + {030:007} O3+HO2=HO{+2.0 O2} : ARR2( 1.10e-14 , 500.0, TEMP ) ; + {031:008} HO+HO2=H2O{+O2} : ARR2( 4.80e-11 , -250.0, TEMP ) ; + {032:009} H2O2+HO=HO2+H2O : ARR2( 2.90e-12 , 160.0, TEMP ) ; + {033:010} HO2+HO2=H2O2{+O2} : (2.3e-13*EXP(600./TEMP) + 1.7e-33* C_M *EXP(1000./TEMP)) ; + {034:011} HO2+HO2+H2O=H2O2+H2O{+O2} : (3.22e-34* EXP(2800./TEMP)+ 2.38e-54* C_M *EXP(3200./TEMP)) ; + {035:012} O3P+NO=NO2 : TROE( 9.00e-32 , 1.5 , 3.00e-11 , 0.0 , TEMP, C_M) ; + {036:013} O3P+NO2=NO{+O2} : ARR2( 6.50e-12 , -120.0, TEMP) ; + {037:014} O3P+NO2=NO3 : TROE( 9.00e-32 , 2.0 , 2.20e-11 , 0.0 , TEMP, C_M) ; + {038:015} NO+HO=HONO : TROE( 7.00e-31 , 2.6 , 1.50e-11 , 0.5 , TEMP, C_M) ; + {039:016} HO+NO2=HNO3 : TROE( 2.60e-30 , 3.2 , 2.40e-11 , 1.3 , TEMP, C_M) ; + {040:017} HO+NO3=NO2+HO2 : 2.20e-11 ; + {041:018} HO2+NO=NO2+HO : ARR2( 3.70e-12 , -250.0, TEMP ) ; + {042:019} HO2+NO2=HNO4 : TROE( 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M) ; + {043:020} HNO4=HO2+NO2 : TROEE( 4.76e26,10900.0, 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M ) ; + {044:021} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50e-12 ; + {045:022} HO+HONO=NO2+H2O : ARR2( 1.80e-11 , 390.0, TEMP ) ; + {046:023} HO+HNO3=NO3+H2O : k46(TEMP,C_M) ; + {047:024} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30e-12 , -380.0, TEMP ) ; + {048:025} O3+NO=NO2{+O2} : ARR2( 2.00e-12 , 1400.0, TEMP ) ; + {049:026} O3+NO2=NO3{+O2} : ARR2( 1.20e-13 , 2450.0, TEMP ) ; + {050:027} NO+NO+M{O2}=NO2+NO2 : (.20946e0*ARR2( 3.30e-39 , -530.0, TEMP )) ; + {051:028} NO3+NO=NO2+NO2 : ARR2( 1.50e-11 , -170.0 , TEMP) ; + {052:029} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50e-14, 1260.0, TEMP ) ; + {053:030} NO3+NO2=N2O5 : TROE( 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M) ; + {054:031} N2O5=NO2+NO3 : TROEE(3.70e26,11000.0, 2.20e-30 , 3.9 , 1.50e-12 , 0.7 , TEMP, C_M ) ; + {055:032} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50e-13 , 2450.0, TEMP ) ; + {056:033} HO+M{=H2}=H2O+HO2 : (5.31E-7*ARR2( 5.50e-12 , 2000.0, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {057:034} HO+SO2=SULF+HO2 : TROE( 3.00e-31 , 3.3 , 1.50e-12 , 0.0 , TEMP, C_M) ; + {058:035} CO+HO=HO2+CO2 : 1.5e-13 * (1.0 + 2.439e-20 * C_M) ; + {059:036} ISO+O3P=0.86 OLT+0.05 HCHO+0.02 HO+0.01 CO+0.13 DCB+0.28 HO2+0.15 XO2 : 6.0E-11 ; + {060:037} MACR+O3P=ALD : ARR2(1.59E-11,-13.0, TEMP) ; + {061:038} CH4+HO=MO2+H2O : (THERMAL_T2(7.44e-18, 1361.0,TEMP )) ; + {062:039} ETH+HO=ETHP+H2O : (THERMAL_T2(1.51e-17, 492.0,TEMP )) ; + {063:040} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26e-12 , 260.0, TEMP ) ; + {064:041} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02e-12 , 155.0, TEMP ) ; + {065:042} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64e-11 , 125.0, TEMP ) ; + {066:043} ETE+HO=ETEP : ARR2( 1.96e-12 , -438.0, TEMP ) ; + {067:044} OLT+HO=OLTP : ARR2( 5.72e-12 , -500.0, TEMP ) ; + {068:045} OLI+HO=OLIP : ARR2( 1.33e-11 , -500.0, TEMP ) ; + {069:046} DIEN+HO=ISOP : ARR2( 1.48e-11 , -448.0, TEMP ) ; + {070:047} ISO+HO=ISOP : ARR2( 2.54e-11 , -410.0, TEMP ) ; + {071:048} API+HO=APIP : ARR2( 1.21e-11 , -444.0, TEMP ) ; + {072:049} LIM+HO=LIMP : 1.71e-10 ; + {073:050} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81e-12 , -355.0, TEMP ) ; + {074:051} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30e-12 , -355.0, TEMP ) ; + {075:052} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.00e-11 ; + {076:053} HCHO+HO=HO2+CO+H2O : 1.00e-11 ; + {077:054} ALD+HO=ACO3+H2O : ARR2( 5.55e-12 , -331.0, TEMP ) ; + {078:055} KET+HO=KETP+H2O : (THERMAL_T2(5.68e-18, -92.0,TEMP )) ; + {079:056} HKET+HO=HO2+MGLY+H2O : 3.00e-12 ; + {080:057} GLY+HO=HO2+2.0 CO+H2O : 1.14e-11 ; + {081:058} MGLY+HO=ACO3+CO+H2O : 1.72e-11 ; + {082:059} MACR+HO=0.51 TCO3+0.41 HKET+0.08 MGLY+0.41 CO+0.08 HCHO+0.49 HO2+0.49 XO2 : ARR2(1.86E-11, -175.0, TEMP) ; + {083:060} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80e-11 , -175.0, TEMP ) ; + {084:061} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70e-10 ; + {085:062} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {086:063} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40e-12 , -190.0, TEMP ) ; + {087:064} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 2.93e-12 , -190.0, TEMP ) ; + {088:065} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00e-14 ; + {089:066} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25e-13 , -500.0, TEMP ) ; + {090:067} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31e-12 , 260.0 , TEMP) ; + {091:068} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40e-13 , 1900.0, TEMP ) ; + {092:069} ALD+NO3=ACO3+HNO3 : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {093:070} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90e-12 , 1900.0, TEMP ) ; + {094:071} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40e-12 , 1900.0, TEMP ) ; + {095:072} MACR+NO3=0.20 TCO3+0.20 HNO3+0.80 OLNN+0.80 CO : ARR2(8.27E-15, 150.0, TEMP) ; + {096:073} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87e-13 , 1000.0, TEMP ) ; + {097:074} CSL+NO3=HNO3+PHO : 2.20e-11 ; + {098:075} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88e-18 , 2282.0,TEMP )) ; + {099:076} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79e-13 , 450.0, TEMP ) ; + {100:077} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64e-13 , -450.0, TEMP ) ; + {101:078} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00e-13 ; + {102:079} ISO+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : ARR2(4.0E-12, 446.0, TEMP) ; + {103:080} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19e-12 , -490.0, TEMP ) ; + {104:081} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22e-11 ; + {105:082} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20e-14 , 500.0, TEMP ) ; + {106:083} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 9.14e-15 , 2580.0, TEMP ) ; + {107:084} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33e-15, 1800.0, TEMP ) ; + {108:085} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40e-15 , 845.0, TEMP ) ; + {109:086} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34e-14 , 2283.0, TEMP ) ; + {110:087} ISO+O3=0.9 HCHO+0.39 MACR+0.36 CO +0.15 ORA1+0.09 O3P+0.30 HO2 +0.35 OLT+0.28 HO +0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2 +0.001 H2O2{+0.05 H2} : ARR2(7.86E-15, 1913.0, TEMP) ; + {111:088} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01e-15 , 732.0, TEMP ) ; + {112:089} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00e-16 ; + {113:090} MACR+O3=0.40 HCHO+0.60 MGLY+0.13 ORA2+0.54 CO+0.22 ORA1+0.29 HO2+0.07 HO+0.13 OP2+0.13 ACO3 {+0.08 H2} : ARR2(1.36E-15, 2112.0, TEMP) ; + {114:091} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00e-18 ; + {115:092} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46e-15 , 1700.0, TEMP ) ; + {116:093} PHO+NO2=0.10 CSL+ONIT : 2.00e-11 ; + {117:094} PHO+HO2=CSL : 1.00e-11 ; + {118:095} ADDT+NO2=CSL+HONO : 3.60e-11 ; + {119:096} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {120:097} ADDT+O3=CSL+HO : 5.00e-11 ; + {121:098} ADDX+NO2=CSL+HONO : 3.60e-11 ; + {122:099} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {123:100} ADDX+O3=CSL+HO : 1.00e-11 ; + {124:101} ADDC+NO2=CSL+HONO : 3.60e-11 ; + {125:102} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66e-17 , -1044.0, TEMP )) ; + {126:103} ADDC+O3=CSL+HO : 5.00e-11 ; + {127:104} ACO3+NO2=PAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {128:105} PAN=ACO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {129:106} TCO3+NO2=TPAN : TROE( 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M) ; + {130:107} TPAN=TCO3+NO2 : TROEE(1.16e28,13954.0, 9.70e-29 , 5.6 , 9.30e-12 , 1.5 , TEMP, C_M ) ; + {131:108} MO2+NO=HCHO+HO2+NO2 : ARR2( 4.20e-12 , -180.0, TEMP ) ; + {132:109} ETHP+NO=ALD+HO2+NO2 : 8.70e-12 ; + {133:110} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00e-12 ; + {134:111} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00e-12 ; + {135:112} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00e-12 ; + {136:113} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00e-12 ; + {137:114} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00e-12 ; + {138:115} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00e-12 ; + {139:116} ISOP+NO=0.446 MACR+0.354 OLT +0.847 HO2+0.606 HCHO+0.153 ONIT+0.847 NO2 : 4.0E-12 ; + {140:117} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00e-12 ; + {141:118} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00e-12 ; + {142:119} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00e-12 ; + {143:120} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00e-12 ; + {144:121} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00e-12 ; + {145:122} ACO3+NO=MO2+NO2 : 2.00e-11 ; + {146:123} TCO3+NO=ACO3+HCHO+NO2 : 2.00e-11 ; + {147:124} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00e-12 ; + {148:125} OLNN+NO=HO2+ONIT+NO2 : 4.00e-12 ; + {149:126} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00e-12 ; + {150:127} MO2+HO2=OP1 : ARR2( 3.80e-13 , -800.0, TEMP ) ; + {151:128} ETHP+HO2=OP2 : ARR2( 7.50e-13 , -700.0, TEMP ) ; + {152:129} HC3P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {153:130} HC5P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {154:131} HC8P+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {155:132} ETEP+HO2=OP2 : ARR2( 1.90e-13 , -1300.0, TEMP ) ; + {156:133} OLTP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {157:134} OLIP+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {158:135} ISOP+HO2=OP2 : ARR2( 1.28E-13 , -1300.0, TEMP) ; + {159:136} APIP+HO2=OP2 : 1.50e-11 ; + {160:137} LIMP+HO2=OP2 : 1.50e-11 ; + {161:138} TOLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {162:139} XYLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP) ; + {163:140} CSLP+HO2=OP2 : ARR2( 3.75e-13 , -980.0, TEMP ) ; + {164:141} ACO3+HO2=PAA : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {165:142} ACO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {166:143} TCO3+HO2=OP2 : ARR2( 1.15e-12 , -550.0, TEMP ) ; + {167:144} TCO3+HO2=ORA2+O3 : ARR2( 3.86e-16 , -2640.0, TEMP ) ; + {168:145} KETP+HO2=OP2 : ARR2( 1.15e-13 , -1300.0, TEMP ) ; + {169:146} OLNN+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {170:147} OLND+HO2=ONIT : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {171:148} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.10e-14 , -416.0, TEMP ) ; + {172:149} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18e-13 , -158.0, TEMP ) ; + {173:150} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46e-14 , -431.0 , TEMP) ; + {174:151} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00e-13 , -467.0, TEMP ) ; + {175:152} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34e-14 , -633.0, TEMP ) ; + {176:153} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71e-13 , -708.0, TEMP ) ; + {177:154} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46e-13 , -708.0, TEMP ) ; + {178:155} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18e-14 , -708.0, TEMP ) ; + {179:156} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36e-13 , -708.0, TEMP ) ; + {180:157} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {181:158} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {182:159} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {183:160} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {184:161} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56e-14 , -708.0, TEMP ) ; + {185:162} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {186:163} ACO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {187:164} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 3.21e-11 , 440.0, TEMP ) ; + {188:165} TCO3+MO2=HCHO+ORA2 : ARR2( 2.68e-16 , -2510.0, TEMP ) ; + {189:166} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91e-13 , -508.0, TEMP ) ; + {190:167} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60e-13 , -708.0, TEMP ) ; + {191:168} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68e-14 , -708.0, TEMP ) ; + {192:169} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03e-12 , -211.0, TEMP ) ; + {193:170} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90e-13 , -460.0, TEMP ) ; + {194:171} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59e-13 , -522.0, TEMP ) ; + {195:172} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47e-13 , -683.0, TEMP ) ; + {196:173} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48e-13 , -765.0, TEMP ) ; + {197:174} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11e-13 , -765.0, TEMP ) ; + {198:175} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09e-13 , -765.0, TEMP ) ; + {199:176} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60e-13 , -765.0, TEMP ) ; + {200:177} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {201:178} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {202:179} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {203:180} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {204:181} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40e-13 , -765.0, TEMP ) ; + {205:182} ACO3+ACO3=2.0 MO2 : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {206:183} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.80e-12 , -530.0, TEMP ) ; + {207:184} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51e-13 , -565.0, TEMP ) ; + {208:185} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85e-13 , -765.0, TEMP ) ; + {209:186} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37e-13 , -765.0, TEMP ) ; + {210:187} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00e-14 , -1000.0 , TEMP) ; + {211:188} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25e-14 , -1000.0, TEMP ) ; + {212:189} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96e-14 , -1000.0, TEMP ) ; + {213:190} MO2+NO3=HCHO+HO2+NO2 : 1.20e-12 ; + {214:191} ETHP+NO3=ALD+HO2+NO2 : 1.20e-12 ; + {215:192} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20e-12 ; + {216:193} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20e-12 ; + {217:194} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20e-12 ; + {218:195} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20e-12 ; + {219:196} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20e-12 ; + {220:197} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20e-12 ; + {221:198} ISOP+NO3=0.60 MACR+0.40 OLT +0.686 HCHO+HO2+NO2 : 1.20E-12 ; + {222:199} APIP+NO3=ALD+KET+HO2+NO2 : 1.20e-12 ; + {223:200} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20e-12 ; + {224:201} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20e-12 ; + {225:202} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20e-12 ; + {226:203} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20e-12; + {227:204} ACO3+NO3=MO2+NO2 : 4.00e-12; + {228:205} TCO3+NO3=HCHO+ACO3+NO2 : 4.00e-12; + {229:206} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20e-12 ; + {230:207} OLNN+NO3=ONIT+HO2+NO2 : 1.20e-12 ; + {231:208} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20e-12 ; + {232:209} XO2+HO2=OP2 : ARR2( 1.66e-13 , -1300.0, TEMP ) ; + {233:210} XO2+MO2=HCHO+HO2 : ARR2( 5.99e-15 , -1510.0, TEMP ) ; + {234:211} XO2+ACO3=MO2 : ARR2( 3.40e-14 , -1560.0, TEMP ) ; + {235:212} XO2+XO2=M{O2} : ARR2( 7.13e-17 , -2950.0, TEMP ) ; + {236:213} XO2+NO=NO2 : 4.00e-12 ; + {237:214} XO2+NO3=NO2 : 1.20e-12 ; + + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.kpp b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.kpp new file mode 100644 index 00000000..b90fd47b --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.kpp @@ -0,0 +1,10 @@ +#MODEL racmsorg +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.spc b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.spc new file mode 100644 index 00000000..bd882298 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg.spc @@ -0,0 +1,81 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + XO2 =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg/racmsorg_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/radm2/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.def b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.def new file mode 100644 index 00000000..9d08c05d --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.def @@ -0,0 +1,24 @@ +#include atoms_red +#include ./radm2.spc +#include ./radm2.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) * C_M + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 + + + +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.eqn b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.eqn new file mode 100755 index 00000000..0590a874 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.eqn @@ -0,0 +1,226 @@ +#EQUATIONS {RADM2, check troee, k46, rc_n2o5 } + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=OH+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=OH+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 OH+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=OH+OH : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+OH : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+OH : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+OH : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + { 22:001 } O3P+M{=O2}=O3 : .20946e0*(C_M *6.00e-34*(TEMP/300.0)**(-2.3)) ; + { 23:002 } O3P+NO2=NO{+O2} : ARR2(6.5E-12, -120.0, TEMP); + { 24:003 } O1D+M=O3P : .78084* ARR2(1.8E-11, -110.0, TEMP) + .20946e0* ARR2(3.2E-11, -70.0, TEMP); + { 26:005 } O1D+H2O=OH+OH : 2.2E-10 ; + { 27:006 } O3+NO=NO2{+O2} : ARR2(2.0E-12, 1400.0, TEMP); + { 28:007 } O3+OH=HO2{+O2} : ARR2(1.6E-12, 940.0, TEMP); + { 29:008 } O3+HO2=OH{+2.00 O2} : ARR2(1.1E-14, 500.0, TEMP); + { 30:009 } HO2+NO=NO2+OH : ARR2(3.7E-12, -240.0, TEMP); + { 31:010 } HO2+NO2=HNO4 : TROE( 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M) ; + { 32:011 } HNO4=HO2+NO2 : TROEE( 4.76e26,10900.0, 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M ) ; + { 33:012 } HO2+HO2=H2O2 : (2.2e-13*EXP(600./TEMP) + 1.9e-33* C_M *EXP(980./TEMP)) ; + { 34:013 } HO2+HO2+H2O=H2O2 : (3.08e-34* EXP(2800./TEMP)+ 2.66e-54* C_M *EXP(3180./TEMP)) ; + { 35:014 } H2O2+OH=HO2+H2O : ARR2(3.3E-12, 200.0, TEMP); + { 36:015 } NO+OH=HONO : TROE( 7.00e-31 , 2.6 , 1.50e-11 , 0.5 , TEMP, C_M) ; + { 37:016 } NO+NO+M{=O2}=NO2+NO2 : .20946e0* ARR2(3.3E-39, -530.0, TEMP); + { 38:017 } O3+NO2=NO3 : ARR2(1.4E-13, 2500.0, TEMP); + { 39:018 } NO3+NO=NO2+NO2 : ARR2(1.7E-11, -150.0, TEMP); + { 40:019 } NO3+NO2=NO+NO2{+O2} : ARR2(2.5E-14, 1230.0, TEMP); + { 41:020 } NO3+HO2=HNO3{+O2} : 2.5E-12 ; + { 42:021 } NO3+NO2=N2O5 : TROE( 2.20e-30 , 4.3 , 1.50e-12 , 0.5 , TEMP, C_M) ; + { 43:022 } N2O5=NO2+NO3 : TROEE(9.09e26,11200.0, 2.20e-30 , 4.3 , 1.50e-12 , 0.5 , TEMP, C_M ) ; + { 44:137, 14} N2O5=2.00 HNO3 : rc_n2o5; + { 45:024 } OH+NO2=HNO3 : TROE( 2.60e-30 , 3.2 , 2.40e-11 , 1.3 , TEMP, C_M) ; + { 46:025 } OH+HNO3=NO3+H2O : k46(TEMP,C_M) ; + { 47:026 } OH+HNO4=NO2+H2O{+O2} : ARR2(1.3E-12, -380.0, TEMP); + { 48:027 } OH+HO2=H2O{+O2} : ARR2(4.6E-11, -230.0, TEMP); + { 49:028 } OH+SO2=SULF+HO2 : TROE( 3.00e-31 , 3.3 , 1.50e-12 , 0.0 , TEMP, C_M) ; + { 50:029 } CO+OH=HO2+CO2 : (1.5E-13 * (1 + 2.439E-20*C_M)); + { 51:030 } CH4+OH=MO2+H2O : THERMAL_T2(6.95E-18, 1280.0, TEMP) ; + { 52:031 } ETH+OH=ETHP+H2O : THERMAL_T2(1.37E-17, 444.0, TEMP) ; + { 53:032 } HC3+OH=0.83 HC3P+0.17 HO2 + +0.009 HCHO+0.075 ALD + +0.025 KET+H2O : ARR2(1.59E-11, 540.0, TEMP); + { 54:033 } HC5+OH=HC5P+0.25 XO2+H2O : ARR2(1.73E-11, 380.0, TEMP); + { 55:034 } HC8+OH=HC8P+0.75 XO2+H2O : ARR2(3.64E-11, 380.0, TEMP); + { 56:035 } OL2+OH=OL2P : ARR2(2.15E-12, -411.0, TEMP); + { 57:036 } OLT+OH=OLTP : ARR2(5.32E-12, -504.0, TEMP); + { 58:037 } OLI+OH=OLIP : ARR2(1.07E-11, -549.0, TEMP); + { 59:038 } TOL+OH=0.75 TOLP+0.25 CSL + +0.25 HO2 : ARR2(2.1E-12, -322.0, TEMP); + { 60:039 } XYL+OH=0.83 XYLP+0.17 CSL + +0.17 HO2 : ARR2(1.89E-11, -116.0, TEMP); + { 61:040 } CSL+OH=0.10 HO2+0.90 XO2 + +0.90 TCO3-0.90 OH : 4.0E-11 ; + { 62:041 } HCHO+OH=HO2+CO+H2O : 9.0E-12 ; + { 63:042 } ALD+OH=ACO3+H2O : ARR2(6.87E-12, -256.0, TEMP); + { 64:043 } KET+OH=KETP+H2O : ARR2(1.2E-11, 745.0, TEMP); + { 65:044 } GLY+OH=HO2+2.00 CO+H2O : 1.15E-11 ; + { 66:045 } MGLY+OH=ACO3+CO+H2O : 1.7E-11 ; + { 67:046 } DCB+OH=TCO3+H2O : 2.8E-11 ; + { 68:047 } OP1+OH=0.50 MO2+0.50 HCHO + +0.50 OH : 1.0E-11 ; + { 69:048 } OP2+OH=0.50 HC3P+0.50 ALD + +0.50 OH : 1.0E-11 ; + { 70:049 } PAA+OH=ACO3+H2O : 1.0E-11 ; + { 71:050 } PAN+OH=HCHO+NO3+XO2 : THERMAL_T2(6.85E-18, 444.0, TEMP) ; + { 72:051 } ONIT+OH=HC3P+NO2 : ARR2(1.55E-11, 540.0, TEMP); + { 73:052 } ISO+OH=OLTP : ARR2(2.55E-11, -409.0, TEMP); + { 74:053 } ACO3+NO2=PAN : ARR2(2.8E-12, -181.0, TEMP); + { 75:054 } PAN=ACO3+NO2 : ARR2(1.95E+16, 13543.0, TEMP); + { 76:055 } TCO3+NO2=TPAN : 4.7E-12 ; + { 77:056 } TPAN=TCO3+NO2 : ARR2(1.95E+16, 13543.0, TEMP); + { 78:057 } MO2+NO=HCHO+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 79:058 } HC3P+NO=0.75 ALD+0.25 KET + +0.09 HCHO+0.036 ONIT + +0.964 NO2+0.964 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 80:060 } HC5P+NO=0.38 ALD+0.69 KET + +0.08 ONIT+0.92 NO2 + +0.92 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 81:062 } HC8P+NO=0.35 ALD+1.06 KET + +0.04 HCHO+0.24 ONIT + +0.76 NO2+0.76 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 82:064 } OL2P+NO=1.60 HCHO+HO2+NO2 + +0.20 ALD : ARR2(4.2E-12, -180.0, TEMP); + { 83:065 } OLTP+NO=ALD+HCHO+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 84:066 } OLIP+NO=HO2+1.45 ALD + +0.28 HCHO+0.10 KET+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 85:067 } ACO3+NO=MO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 86:068 } TCO3+NO=NO2+0.92 HO2 + +0.89 GLY+0.11 MGLY + +0.05 ACO3+0.95 CO + +2.00 XO2 : ARR2(4.2E-12, -180.0, TEMP); + { 87:069 } TOLP+NO=NO2+HO2+0.17 MGLY + +0.16 GLY+0.70 DCB : ARR2(4.2E-12, -180.0, TEMP); + { 88:070 } XYLP+NO=NO2+HO2+0.45 MGLY + +0.806 DCB : ARR2(4.2E-12, -180.0, TEMP); + { 89:071 } ETHP+NO=ALD+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 90:072 } KETP+NO=MGLY+NO2+HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 91:073 } OLN+NO=HCHO+ALD+2.00 NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 92:074 } HCHO+NO3=HO2+HNO3+CO : ARR2(6.0E-13, 2058.0, TEMP); + { 93:075 } ALD+NO3=ACO3+HNO3 : ARR2(1.4E-12, 1900.0, TEMP); + { 94:076 } GLY+NO3=HNO3+HO2+2.00 CO : ARR2(6.0E-13, 2058.0, TEMP); + { 95:077 } MGLY+NO3=HNO3+ACO3+CO : ARR2(1.4E-12, 1900.0, TEMP); + { 96:078 } DCB+NO3=HNO3+TCO3 : ARR2(1.4E-12, 1900.0, TEMP); + { 97:079 } CSL+NO3=HNO3+XNO2+0.50 CSL : 2.2E-11 ; + { 98:080 } OL2+NO3=OLN : ARR2(2.0E-12, 2923.0, TEMP); + { 99:081 } OLT+NO3=OLN : ARR2(1.0E-11, 1895.0, TEMP); + {100:082 } OLI+NO3=OLN : ARR2(3.23E-11, 975.0, TEMP); + {101:083 } ISO+NO3=OLN : 5.81E-13 ; + {102:084 } OL2+O3=HCHO+0.42 CO+0.40 ORA1 + +0.12 HO2 : ARR2(1.2E-14, 2633.0, TEMP); + {103:085 } OLT+O3=0.53 HCHO+0.50 ALD + +0.33 CO+0.20 ORA1 + +0.20 ORA2+0.23 HO2 + +0.22 MO2+0.10 OH + +0.06 CH4 : ARR2(1.32E-14, 2105.0, TEMP); + {104:086 } OLI+O3=0.18 HCHO+0.72 ALD + +0.10 KET+0.23 CO + +0.06 ORA1+0.29 ORA2 + +0.09 CH4+0.26 HO2 + +0.31 MO2+0.14 OH : ARR2(7.29E-15, 1136.0, TEMP); + {105:087 } ISO+O3=0.53 HCHO+0.50 ALD + +0.33 CO+0.20 ORA1 + +0.20 ORA2+0.23 HO2 + +0.22 MO2+0.10 OH : ARR2(1.23E-14, 2013.0, TEMP); + {106:088 } HO2+MO2=OP1 : ARR2(7.7E-14, -1300.0, TEMP); + {107:089 } HO2+ETHP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {108:090 } HO2+HC3P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {109:091 } HO2+HC5P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {110:092 } HO2+HC8P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {111:093 } HO2+OL2P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {112:094 } HO2+OLTP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {113:095 } HO2+OLIP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {114:096 } HO2+KETP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {115:097 } HO2+ACO3=PAA : ARR2(7.7E-14, -1300.0, TEMP); + {116:098 } HO2+TOLP= OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {117:099 } HO2+XYLP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {118:100 } HO2+TCO3=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {119:101 } HO2+OLN=ONIT : ARR2(7.7E-14, -1300.0, TEMP); + {120:102 } MO2+MO2=1.50 HCHO+HO2 : ARR2(1.9E-13, -220.0, TEMP); + {121:103 } MO2+ETHP=0.75 HCHO+HO2 + +0.75 ALD : ARR2(1.4E-13, -220.0, TEMP); + {122:104 } MO2+HC3P=0.75 HCHO+HO2 + +0.15 ALD+0.6 KET : ARR2(4.2E-14, -220.0, TEMP); + {123:105 } MO2+HC5P=0.77 HCHO+HO2 + +0.41 ALD+0.75 KET : ARR2(3.4E-14, -220.0, TEMP); + {124:106 } MO2+HC8P=0.80 HCHO+HO2 + +0.46 ALD+1.39 KET : ARR2(2.9E-14, -220.0, TEMP); + {125:107 } MO2+OL2P=1.55 HCHO+HO2 + +0.35 ALD : ARR2(1.4E-13, -220.0, TEMP); + {126:108 } MO2+OLTP=1.25 HCHO+HO2 + +0.75 ALD : ARR2(1.4E-13, -220.0, TEMP); + {127:109 } MO2+OLIP=0.89 HCHO+HO2 + +0.725 ALD+0.55 KET : ARR2(1.7E-14, -220.0, TEMP); + {128:110 } MO2+KETP=0.75 HCHO+HO2 + +0.75 MGLY : ARR2(1.7E-14, -220.0, TEMP); + {129:111 } MO2+ACO3=HCHO+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(9.6E-13, -220.0, TEMP); + {130:112 } MO2+TOLP=HCHO+2.00 HO2 + +0.17 MGLY+0.16 GLY + +0.70 DCB : ARR2(1.7E-14, -220.0, TEMP); + {131:113 } MO2+XYLP=HCHO+2.00 HO2 + +0.45 MGLY+0.806 DCB : ARR2(1.7E-14, -220.0, TEMP); + {132:114 } MO2+TCO3=0.50 HCHO+0.50 ORA2 + +0.445 GLY+0.055 MGLY + +0.025 ACO3+0.475 CO + +0.46 HO2+XO2 : ARR2(9.6E-13, -220.0, TEMP); + {133:115 } ETHP+ACO3=ALD+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(3.4E-13, -220.0, TEMP); + {134:116 } HC3P+ACO3=0.2 ALD+0.8 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(1.0E-13, -220.0, TEMP); + {135:117 } HC5P+ACO3=0.14 ALD+0.86 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(8.4E-14, -220.0, TEMP); + {136:118 } HC8P+ACO3=0.1 ALD+0.9 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(7.2E-14, -220.0, TEMP); + {137:119 } OL2P+ACO3=0.80 HCHO+0.60 ALD + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(3.4E-13, -220.0, TEMP); + {138:120 } OLTP+ACO3=ALD+0.50 HCHO + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(3.4E-13, -220.0, TEMP); + {139:121 } OLIP+ACO3=0.725 ALD+0.55 KET + +0.14 HCHO+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(4.2E-14, -220.0, TEMP); + {140:122 } KETP+ACO3=MGLY+0.50 HO2 + +0.50 ORA2+0.50 MO2 : ARR2(4.2E-14, -220.0, TEMP); + {141:123 } ACO3+ACO3=2.00 MO2 : ARR2(1.19E-12, -220.0, TEMP); + {142:124 } ACO3+TOLP=0.8 MGLY+0.2 GLY + +1.00 DCB+HO2+MO2 : ARR2(4.2E-14, -220.0, TEMP); + {143:125 } ACO3+XYLP=MO2+1.00 MGLY + +1.00 DCB+HO2 : ARR2(4.2E-14, -220.0, TEMP); + {144:126 } ACO3+TCO3=MO2+0.92 HO2 + +0.89 GLY+0.11 MGLY + +0.05 ACO3+0.95 CO + +2.00 XO2 : ARR2(1.19E-12, -220.0, TEMP); + {145:127 } XO2+HO2=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {146:128 } XO2+MO2=HCHO+HO2 : ARR2(1.7E-14, -220.0, TEMP); + {147:129 } XO2+ACO3=MO2 : ARR2(4.2E-14, -220.0, TEMP); + {148:130 } XO2+XO2=H2O : ARR2(3.6E-16, -220.0, TEMP); + {149:131 } XO2+NO=NO2 : ARR2(4.2E-12, -180.0, TEMP); + {150:132 } XNO2+NO2=ONIT : ARR2(4.2E-12, -180.0, TEMP); + {151:133 } XNO2+HO2=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {152:134 } XNO2+MO2=HCHO+HO2 : ARR2(1.7E-14, -220.0, TEMP); + {153:135 } XNO2+ACO3=MO2 : ARR2(4.2E-14, -220.0, TEMP); + {154:136 } XNO2+XNO2=H2O : ARR2(3.6E-16, -220.0, TEMP); + {155:138 } MO2+OLN=1.75 HCHO+.5 HO2 + +ALD+NO2 : ARR2(1.7E-14, -220.0, TEMP); + {156:139 } ACO3+OLN=HCHO+ALD+0.50 ORA2 + +NO2+0.50 MO2 : ARR2(4.2E-14, -220.0, TEMP); + {157:140 } OLN+OLN=2.00 HCHO+2.00 ALD + +2.00 NO2 : ARR2(3.6E-16, -220.0, TEMP); diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.kpp b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.kpp new file mode 100644 index 00000000..f2574e98 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.kpp @@ -0,0 +1,11 @@ +#MODEL radm2 +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.spc b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.spc new file mode 100644 index 00000000..60cdfb83 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2.spc @@ -0,0 +1,67 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + OL2 =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + ISO =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + ETHP = IGNORE; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + MO2 = IGNORE ; + DCB =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + OH =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + OLN =IGNORE ; + XO2 =IGNORE ; + XNO2 =IGNORE ; + CH4=IGNORE ; + CO2=IGNORE; + OL2P =IGNORE ; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2_wrfkpp.equiv new file mode 100644 index 00000000..cb388efe --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/radm2_wrfkpp.equiv @@ -0,0 +1,11 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/radm2/temp.eqn b/wrfv2_fire/chem/KPP/mechanisms/radm2/temp.eqn new file mode 100644 index 00000000..118325b5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/radm2/temp.eqn @@ -0,0 +1,228 @@ +#EQUATIONS {RADM2, check n2o5, troee} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=OH+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=OH+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 OH+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=OH+OH : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+OH : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+OH : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+OH : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + { 22:001 } O3P+O2=O3 : (C_M *6.00e-34*(TEMP/300.0)**(-2.3)) ; + { 23:002 } O3P+NO2=NO+O2 : ARR2(6.5E-12, -120.0, TEMP); + { 24:003 } O1D+N2=O3P+N2 : ARR2(1.8E-11, -110.0, TEMP); + { 25:004 } O1D+O2=O3P+O2 : ARR2(3.2E-11, -70.0, TEMP); + { 26:005 } O1D+H2O=OH+OH : 2.2E-10 ; + { 27:006 } O3+NO=NO2+O2 : ARR2(2.0E-12, 1400.0, TEMP); + { 28:007 } O3+OH=HO2+O2 : ARR2(1.6E-12, 940.0, TEMP); + { 29:008 } O3+HO2=OH+2.00 O2 : ARR2(1.1E-14, 500.0, TEMP); + { 30:009 } HO2+NO=NO2+OH : ARR2(3.7E-12, -240.0, TEMP); + { 31:010 } HO2+NO2=HNO4 : TROE( 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M) ; + { 32:011 } HNO4=HO2+NO2 : TROEE( 4.76e26,10900.0, 1.80e-31 , 3.2 , 4.70e-12 , 1.4 , TEMP, C_M ) ; + { 33:012 } HO2+HO2=H2O2 : (2.2e-13*EXP(600./TEMP) + 1.9e-33* C_M *EXP(980./TEMP)) ; + { 34:013 } HO2+HO2+H2O=H2O2 : (3.08e-34* EXP(2800./TEMP)+ 2.66e-54* C_M *EXP(3180./TEMP)) ; + { 35:014 } H2O2+OH=HO2+H2O : ARR2(3.3E-12, 200.0, TEMP); + { 36:015 } NO+OH=HONO : TROE( 7.00e-31 , 2.6 , 1.50e-11 , 0.5 , TEMP, C_M) ; + { 37:016 } NO+NO+O2=NO2+NO2 : ARR2(3.3E-39, -530.0, TEMP); + { 38:017 } O3+NO2=NO3 : ARR2(1.4E-13, 2500.0, TEMP); + { 39:018 } NO3+NO=NO2+NO2 : ARR2(1.7E-11, -150.0, TEMP); + { 40:019 } NO3+NO2=NO+NO2+O2 : ARR2(2.5E-14, 1230.0, TEMP); + { 41:020 } NO3+HO2=HNO3+O2 : 2.5E-12 ; + + { 42:021 } NO3+NO2=N2O5 : TROE( 2.20e-30 , 4.3 , 1.50e-12 , 0.5 , TEMP, C_M) ; + { 43:022 } N2O5=NO2+NO3 : TROEE(9.09e26,11200.0, 2.20e-30 , 4.3 , 1.50e-12 , 0.5 , TEMP, C_M ) ; + { !!!!! 44:137 N2O5=2.00 HNO3 : call rh_N2O5 ;} + { 45:024 } OH+NO2=HNO3 : TROE( 2.60e-30 , 3.2 , 2.40e-11 , 1.3 , TEMP, C_M) ; + { 46:025 } OH+HNO3=NO3+H2O : (7.2E-15 * exp(785/TEMP) + 1.9E-33 * exp(725/TEMP) * C_M / (1+(1.9E-33 * exp(725/TEMP)*C_M)/(4.1E-16 * exp(1440/TEMP)))); + { 47:026 } OH+HNO4=NO2+H2O+O2 : ARR2(1.3E-12, -380.0, TEMP); + { 48:027 } OH+HO2=H2O+O2 : ARR2(4.6E-11, -230.0, TEMP); + { 49:028 } OH+SO2=SULF+HO2 : TROE( 3.00e-31 , 3.3 , 1.50e-12 , 0.0 , TEMP, C_M) ; + { 50:029 } CO+OH=HO2+CO2 : (1.5E-13 * (1 + 2.439E-20*C_M)); + { 51:030 } CH4+OH=MO2+H2O : ARR2(6.95E-18, 1280.0, TEMP) ; + { 52:031 } ETH+OH=ETHP+H2O : ARR2(1.37E-17, 444.0, TEMP) ; + { 53:032 } HC3+OH=0.83 HC3P+0.17 HO2 + +0.009 HCHO+0.075 ALD + +0.025 KET+H2O : ARR2(1.59E-11, 540.0, TEMP); + { 54:033 } HC5+OH=HC5P+0.25 XO2+H2O : ARR2(1.73E-11, 380.0, TEMP); + { 55:034 } HC8+OH=HC8P+0.75 XO2+H2O : ARR2(3.64E-11, 380.0, TEMP); + { 56:035 } OL2+OH=OL2P : ARR2(2.15E-12, -411.0, TEMP); + { 57:036 } OLT+OH=OLTP : ARR2(5.32E-12, -504.0, TEMP); + { 58:037 } OLI+OH=OLIP : ARR2(1.07E-11, -549.0, TEMP); + { 59:038 } TOL+OH=0.75 TOLP+0.25 CSL + +0.25 HO2 : ARR2(2.1E-12, -322.0, TEMP); + { 60:039 } XYL+OH=0.83 XYLP+0.17 CSL + +0.17 HO2 : ARR2(1.89E-11, -116.0, TEMP); + { 61:040 } CSL+OH=0.10 HO2+0.90 XO2 + +0.90 TCO3-0.90 OH : 4.0E-11 ; + { 62:041 } HCHO+OH=HO2+CO+H2O : 9.0E-12 ; + { 63:042 } ALD+OH=ACO3+H2O : ARR2(6.87E-12, -256.0, TEMP); + { 64:043 } KET+OH=KETP+H2O : ARR2(1.2E-11, 745.0, TEMP); + { 65:044 } GLY+OH=HO2+2.00 CO+H2O : 1.15E-11 ; + { 66:045 } MGLY+OH=ACO3+CO+H2O : 1.7E-11 ; + { 67:046 } DCB+OH=TCO3+H2O : 2.8E-11 ; + { 68:047 } OP1+OH=0.50 MO2+0.50 HCHO + +0.50 OH : 1.0E-11 ; + { 69:048 } OP2+OH=0.50 HC3P+0.50 ALD + +0.50 OH : 1.0E-11 ; + { 70:049 } PAA+OH=ACO3+H2O : 1.0E-11 ; + { 71:050 } PAN+OH=HCHO+NO3+XO2 : t2arr(6.85E-18, 444.0) ; + { 72:051 } ONIT+OH=HC3P+NO2 : ARR2(1.55E-11, 540.0, TEMP); + { 73:052 } ISO+OH=OLTP : ARR2(2.55E-11, -409.0, TEMP); + { 74:053 } ACO3+NO2=PAN : ARR2(2.8E-12, -181.0, TEMP); + { 75:054 } PAN=ACO3+NO2 : ARR2(1.95E+16, 13543.0, TEMP); + { 76:055 } TCO3+NO2=TPAN : 4.7E-12 ; + { 77:056 } TPAN=TCO3+NO2 : ARR2(1.95E+16, 13543.0, TEMP); + { 78:057 } MO2+NO=HCHO+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 79:058 } HC3P+NO=0.75 ALD+0.25 KET + +0.09 HCHO+0.036 ONIT + +0.964 NO2+0.964 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 80:060 } HC5P+NO=0.38 ALD+0.69 KET + +0.08 ONIT+0.92 NO2 + +0.92 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 81:062 } HC8P+NO=0.35 ALD+1.06 KET + +0.04 HCHO+0.24 ONIT + +0.76 NO2+0.76 HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 82:064 } OL2P+NO=1.60 HCHO+HO2+NO2 + +0.20 ALD : ARR2(4.2E-12, -180.0, TEMP); + { 83:065 } OLTP+NO=ALD+HCHO+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 84:066 } OLIP+NO=HO2+1.45 ALD + +0.28 HCHO+0.10 KET+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 85:067 } ACO3+NO=MO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 86:068 } TCO3+NO=NO2+0.92 HO2 + +0.89 GLY+0.11 MGLY + +0.05 ACO3+0.95 CO + +2.00 XO2 : ARR2(4.2E-12, -180.0, TEMP); + { 87:069 } TOLP+NO=NO2+HO2+0.17 MGLY + +0.16 GLY+0.70 DCB : ARR2(4.2E-12, -180.0, TEMP); + { 88:070 } XYLP+NO=NO2+HO2+0.45 MGLY + +0.806 DCB : ARR2(4.2E-12, -180.0, TEMP); + { 89:071 } ETHP+NO=ALD+HO2+NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 90:072 } KETP+NO=MGLY+NO2+HO2 : ARR2(4.2E-12, -180.0, TEMP); + { 91:073 } OLN+NO=HCHO+ALD+2.00 NO2 : ARR2(4.2E-12, -180.0, TEMP); + { 92:074 } HCHO+NO3=HO2+HNO3+CO : ARR2(6.0E-13, 2058.0, TEMP); + { 93:075 } ALD+NO3=ACO3+HNO3 : ARR2(1.4E-12, 1900.0, TEMP); + { 94:076 } GLY+NO3=HNO3+HO2+2.00 CO : ARR2(6.0E-13, 2058.0, TEMP); + { 95:077 } MGLY+NO3=HNO3+ACO3+CO : ARR2(1.4E-12, 1900.0, TEMP); + { 96:078 } DCB+NO3=HNO3+TCO3 : ARR2(1.4E-12, 1900.0, TEMP); + { 97:079 } CSL+NO3=HNO3+XNO2+0.50 CSL : 2.2E-11 ; + { 98:080 } OL2+NO3=OLN : ARR2(2.0E-12, 2923.0, TEMP); + { 99:081 } OLT+NO3=OLN : ARR2(1.0E-11, 1895.0, TEMP); + {100:082 } OLI+NO3=OLN : ARR2(3.23E-11, 975.0, TEMP); + {101:083 } ISO+NO3=OLN : 5.81E-13 ; + {102:084 } OL2+O3=HCHO+0.42 CO+0.40 ORA1 + +0.12 HO2 : ARR2(1.2E-14, 2633.0, TEMP); + {103:085 } OLT+O3=0.53 HCHO+0.50 ALD + +0.33 CO+0.20 ORA1 + +0.20 ORA2+0.23 HO2 + +0.22 MO2+0.10 OH + +0.06 CH4 : ARR2(1.32E-14, 2105.0, TEMP); + {104:086 } OLI+O3=0.18 HCHO+0.72 ALD + +0.10 KET+0.23 CO + +0.06 ORA1+0.29 ORA2 + +0.09 CH4+0.26 HO2 + +0.31 MO2+0.14 OH : ARR2(7.29E-15, 1136.0, TEMP); + {105:087 } ISO+O3=0.53 HCHO+0.50 ALD + +0.33 CO+0.20 ORA1 + +0.20 ORA2+0.23 HO2 + +0.22 MO2+0.10 OH : ARR2(1.23E-14, 2013.0, TEMP); + {106:088 } HO2+MO2=OP1 : ARR2(7.7E-14, -1300.0, TEMP); + {107:089 } HO2+ETHP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {108:090 } HO2+HC3P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {109:091 } HO2+HC5P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {110:092 } HO2+HC8P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {111:093 } HO2+OL2P=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {112:094 } HO2+OLTP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {113:095 } HO2+OLIP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {114:096 } HO2+KETP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {115:097 } HO2+ACO3=PAA : ARR2(7.7E-14, -1300.0, TEMP); + {116:098 } HO2+TOLP= OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {117:099 } HO2+XYLP=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {118:100 } HO2+TCO3=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {119:101 } HO2+OLN=ONIT : ARR2(7.7E-14, -1300.0, TEMP); + {120:102 } MO2+MO2=1.50 HCHO+HO2 : ARR2(1.9E-13, -220.0, TEMP); + {121:103 } MO2+ETHP=0.75 HCHO+HO2 + +0.75 ALD : ARR2(1.4E-13, -220.0, TEMP); + {122:104 } MO2+HC3P=0.75 HCHO+HO2 + +0.15 ALD+0.6 KET : ARR2(4.2E-14, -220.0, TEMP); + {123:105 } MO2+HC5P=0.77 HCHO+HO2 + +0.41 ALD+0.75 KET : ARR2(3.4E-14, -220.0, TEMP); + {124:106 } MO2+HC8P=0.80 HCHO+HO2 + +0.46 ALD+1.39 KET : ARR2(2.9E-14, -220.0, TEMP); + {125:107 } MO2+OL2P=1.55 HCHO+HO2 + +0.35 ALD : ARR2(1.4E-13, -220.0, TEMP); + {126:108 } MO2+OLTP=1.25 HCHO+HO2 + +0.75 ALD : ARR2(1.4E-13, -220.0, TEMP); + {127:109 } MO2+OLIP=0.89 HCHO+HO2 + +0.725 ALD+0.55 KET : ARR2(1.7E-14, -220.0, TEMP); + {128:110 } MO2+KETP=0.75 HCHO+HO2 + +0.75 MGLY : ARR2(1.7E-14, -220.0, TEMP); + {129:111 } MO2+ACO3=HCHO+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(9.6E-13, -220.0, TEMP); + {130:112 } MO2+TOLP=HCHO+2.00 HO2 + +0.17 MGLY+0.16 GLY + +0.70 DCB : ARR2(1.7E-14, -220.0, TEMP); + {131:113 } MO2+XYLP=HCHO+2.00 HO2 + +0.45 MGLY+0.806 DCB : ARR2(1.7E-14, -220.0, TEMP); + {132:114 } MO2+TCO3=0.50 HCHO+0.50 ORA2 + +0.445 GLY+0.055 MGLY + +0.025 ACO3+0.475 CO + +0.46 HO2+XO2 : ARR2(9.6E-13, -220.0, TEMP); + {133:115 } ETHP+ACO3=ALD+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(3.4E-13, -220.0, TEMP); + {134:116 } HC3P+ACO3=0.2 ALD+0.8 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(1.0E-13, -220.0, TEMP); + {135:117 } HC5P+ACO3=0.14 ALD+0.86 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(8.4E-14, -220.0, TEMP); + {136:118 } HC8P+ACO3=0.1 ALD+0.9 KET + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(7.2E-14, -220.0, TEMP); + {137:119 } OL2P+ACO3=0.80 HCHO+0.60 ALD + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(3.4E-13, -220.0, TEMP); + {138:120 } OLTP+ACO3=ALD+0.50 HCHO + +0.50 HO2+0.50 ORA2 + +0.50 MO2 : ARR2(3.4E-13, -220.0, TEMP); + {139:121 } OLIP+ACO3=0.725 ALD+0.55 KET + +0.14 HCHO+0.50 HO2 + +0.50 MO2+0.50 ORA2 : ARR2(4.2E-14, -220.0, TEMP); + {140:122 } KETP+ACO3=MGLY+0.50 HO2 + +0.50 ORA2+0.50 MO2 : ARR2(4.2E-14, -220.0, TEMP); + {141:123 } ACO3+ACO3=2.00 MO2 : ARR2(1.19E-12, -220.0, TEMP); + {142:124 } ACO3+TOLP=0.8 MGLY+0.2 GLY + +1.00 DCB+HO2+MO2 : ARR2(4.2E-14, -220.0, TEMP); + {143:125 } ACO3+XYLP=MO2+1.00 MGLY + +1.00 DCB+HO2 : ARR2(4.2E-14, -220.0, TEMP); + {144:126 } ACO3+TCO3=MO2+0.92 HO2 + +0.89 GLY+0.11 MGLY + +0.05 ACO3+0.95 CO + +2.00 XO2 : ARR2(1.19E-12, -220.0, TEMP); + {145:127 } XO2+HO2=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {146:128 } XO2+MO2=HCHO+HO2 : ARR2(1.7E-14, -220.0, TEMP); + {147:129 } XO2+ACO3=MO2 : ARR2(4.2E-14, -220.0, TEMP); + {148:130 } XO2+XO2=H2O : ARR2(3.6E-16, -220.0, TEMP); + {149:131 } XO2+NO=NO2 : ARR2(4.2E-12, -180.0, TEMP); + {150:132 } XNO2+NO2=ONIT : ARR2(4.2E-12, -180.0, TEMP); + {151:133 } XNO2+HO2=OP2 : ARR2(7.7E-14, -1300.0, TEMP); + {152:134 } XNO2+MO2=HCHO+HO2 : ARR2(1.7E-14, -220.0, TEMP); + {153:135 } XNO2+ACO3=MO2 : ARR2(4.2E-14, -220.0, TEMP); + {154:136 } XNO2+XNO2=H2O : ARR2(3.6E-16, -220.0, TEMP); + {155:138 } MO2+OLN=1.75 HCHO+.5 HO2 + +ALD+NO2 : ARR2(1.7E-14, -220.0, TEMP); + {156:139 } ACO3+OLN=HCHO+ALD+0.50 ORA2 + +NO2+0.50 MO2 : ARR2(4.2E-14, -220.0, TEMP); + {157:140 } OLN+OLN=2.00 HCHO+2.00 ALD + +2.00 NO2 : ARR2(3.6E-16, -220.0, TEMP); diff --git a/wrfv2_fire/chem/KPP/module_wkppc_constants.F b/wrfv2_fire/chem/KPP/module_wkppc_constants.F new file mode 100644 index 00000000..370513a6 --- /dev/null +++ b/wrfv2_fire/chem/KPP/module_wkppc_constants.F @@ -0,0 +1,45 @@ +MODULE module_wkppc_constants + + +! A few constants + + REAL, PARAMETER :: navgdro = 6.022e23 ! molecules/mol + + REAL, PARAMETER :: & !molecular weights + mwh = 1.0079, mwo = 15.9994, mwair = 28.97 + + + REAL, PARAMETER :: mwh2o = 2*mwh + mwo + + +!dens2con air + REAL, PARAMETER :: dens2con_a = 1.e-3 &! kg/m3 -> g/cm3 + * (1./mwair) &! -> mole/cm3 + * navgdro ! -> molec/cm3 + + + +!dens2con water + REAL, PARAMETER :: dens2con_w = 1.e-3 &! kg/m3 -> g/cm3 + * (1./mwh2o) &! -> mole/cm3 + * navgdro ! -> molec/cm3 + + + + + + + +! constants for KPP +! should be moved to namelist input in the future + + + + REAL, PARAMETER :: rtols=1.E-3 ! 1e-2 means two digits + REAL, PARAMETER :: atols=1. + + + + + +END MODULE module_wkppc_constants diff --git a/wrfv2_fire/chem/KPP/util/Makefile b/wrfv2_fire/chem/KPP/util/Makefile new file mode 100644 index 00000000..bff0f7ec --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/Makefile @@ -0,0 +1,10 @@ +# + +mod_registry : ../../../Registry/Registry.EM_CHEM + touch run_wkc + touch mod_registry + touch ../mechanisms/*/*.kpp + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +mod_registry: ../../Makefile_org ../inc diff --git a/wrfv2_fire/chem/KPP/util/Makefile_kpp b/wrfv2_fire/chem/KPP/util/Makefile_kpp new file mode 100644 index 00000000..06af0058 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/Makefile_kpp @@ -0,0 +1,20 @@ + +$(MODEL)_Integrator.f90: + $(KPP) $(MODEL).kpp + cp -f $(MODEL)_Integrator.f90 ../../../module_kpp_$(MODEL)_Integr.F + cp -f $(MODEL)_Parameters.f90 ../../../module_kpp_$(MODEL)_Parameters.F + cp -f $(MODEL)_Precision.f90 ../../../module_kpp_$(MODEL)_Precision.F + cp -f $(MODEL)_JacobianSP.f90 ../../../module_kpp_$(MODEL)_JacobianSP.F + cp -f $(MODEL)_Jacobian.f90 ../../../module_kpp_$(MODEL)_Jacobian.F + cp -f $(MODEL)_Update_Rconst.f90 ../../../module_kpp_$(MODEL)_Update_Rconst.F + touch ../../util/run_wkc + + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + + +$(MODEL)_Integrator.f90: \ + $(MODEL).spc $(MODEL).eqn $(MODEL).def $(MODEL).kpp $(MODEL)_wrfkpp.equiv + + + diff --git a/wrfv2_fire/chem/KPP/util/mod_registry b/wrfv2_fire/chem/KPP/util/mod_registry new file mode 100644 index 00000000..e69de29b diff --git a/wrfv2_fire/chem/KPP/util/wkc/Makefile b/wrfv2_fire/chem/KPP/util/wkc/Makefile new file mode 100644 index 00000000..49031993 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/Makefile @@ -0,0 +1,58 @@ +.SUFFIXES: .c .o + +#CC = cc + +include ../../configure.kpp + +CFLAGS = #-ansi +LDFLAGS = +DEBUG = -g +OBJ = registry_kpp.o my_strtok.o data.o type.o misc.o reg_parse.o \ + gen_kpp.o get_wrf_chem_specs.o gen_kpp_mech_dr.o gen_kpp_interface.o \ + get_kpp_chem_specs.o compare_kpp_to_species.o get_wrf_radicals.o \ + get_wrf_jvals.o gen_kpp_utils.o change_chem_Makefile.o \ + gen_kpp_interf_utils.o gen_kpp_args_to_Update_Rconst.o kpp_data.o \ + sym.o symtab_gen.o + + + +registry : $(OBJ) + $(SCC) -o registry_kpp $(DEBUG) $(LDFLAGS) $(OBJ) + +.c.o : + $(SCC) $(CFLAGS) -c $(DEBUG) $< + +clean: + /bin/rm -f $(OBJ) gen_comms.c + +gen_comms.c : gen_comms.stub + /bin/cp gen_comms.stub gen_comms.c + +# regenerate this list with "makedepend -Y *.c" + +# DO NOT DELETE THIS LINE -- make depend depends on it. + +data.o: registry.h protos.h data.h protos_kpp.h +reg_parse.o: registry.h protos.h data.h protos_kpp.h +registry.o: protos.h registry.h data.h protos_kpp.h +kpp_data.o: registry.h protos.h data.h kpp_data.h protos_kpp.h +gen_kpp.o:registry.h protos.h data.h protos_kpp.h kpp_data.h \ + gen_kpp_mech_dr.o \ + gen_kpp_interface.o get_wrf_chem_specs.o get_kpp_chem_specs.o \ + compare_kpp_to_species.o get_wrf_radicals.o get_wrf_jvals.o \ + gen_kpp_utils.o change_chem_Makefile.o gen_kpp_interf_utils.o \ + gen_kpp_args_to_Update_Rconst.o copy_makefiles_kpp.o +gen_kpp_mech_dr.o:protos.h kpp_data.h gen_kpp_utils.o protos_kpp.h +gen_kpp_interface.o:registry.h protos.h data.h kpp_data.h protos_kpp.h +get_wrf_chem_specs.o:registry.h protos.h data.h kpp_data.h protos_kpp.h +get_kpp_chem_specs.o:registry.h protos.h data.h kpp_data.h protos_kpp.h +compare_kpp_to_species.o:data.h kpp_data.h +get_wrf_radicals.o:registry.h protos.h data.h kpp_data.h protos_kpp.h +get_wrf_jvals.o:registry.h protos.h data.h kpp_data.h protos_kpp.h +copy_makefiles_kpp.o:protos.h kpp_data.h protos_kpp.h +gen_kpp_utils.o:registry.h kpp_data.h +gen_kpp_interf_utils.o: protos.h kpp_data.h protos_kpp.h +change_chem_Makefile.o: protos.h kpp_data.h protos_kpp.h +gen_kpp_args_to_Update_Rconst.o: protos.h kpp_data.h protos_kpp.h +sym.o: sym.h + diff --git a/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c b/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c new file mode 100644 index 00000000..f633c797 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c @@ -0,0 +1,113 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + + + +int +change_chem_Makefile ( ) +{ +knode_t * p1, * p2, * pm1; + FILE * ch_Makefile, * t_Makefile; + char inln[4096]; + char kname[NAMELEN]; + char * org_Mf = "chem/Makefile_org"; + char * t_Mf = "chem/Makefile.temp"; + char * Mf = "chem/Makefile"; + char cp_command[NAMELEN]; + + + + + ch_Makefile = fopen(org_Mf, "r" ); + t_Makefile = fopen(t_Mf, "w" ); + + + sprintf( cp_command,"cp %s %s",t_Mf,Mf); + + fprintf(t_Makefile,"# \n"); + fprintf(t_Makefile,"# MANUAL CHANGES TO THIS FILE WILL BE LOST \n"); + fprintf(t_Makefile,"# ... EDIT Makefile_org INSTEAD ...\n"); + fprintf(t_Makefile,"# this file was written by gen_kpp.c \n\n"); + + + + /* loop over lines in chem/Makefile */ + while ( fgets ( inln , 4096 , ch_Makefile ) != NULL ){ + + + /* printf("%s ", inln ); */ + fprintf(t_Makefile, inln); + + + + + /* if ( strncmp(inln, "MODULES",6) == 0){ */ + + if ( strncmp(inln, " module_data_sorgam",19) == 0){ + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + + strcpy( kname, p1->name ); + fprintf(t_Makefile, " module_kpp_%s_Integr.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_Precision.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_Parameters.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_Jacobian.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_JacobianSP.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_Update_Rconst.o \\\n",kname ); + fprintf(t_Makefile, " module_kpp_%s_interface.o \\\n",kname ); + } + } + fprintf(t_Makefile, " module_wkppc_constants.o \\\n"); + } + + if ( strncmp(inln, "# DEPENDENCIES",14) == 0){ + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + + p2 = p1->assoc_wrf_pack; + + if ( p2 ) { + + + strcpy( kname, p1->name ); + + fprintf(t_Makefile, "module_kpp_%s_Jacobian.o: module_kpp_%s_JacobianSP.o \n\n",kname, kname ); + + fprintf(t_Makefile, "module_kpp_%s_Parameters.o: module_kpp_%s_Precision.o \n\n",kname, kname ); + + fprintf(t_Makefile, "module_kpp_%s_Integr.o: module_kpp_%s_Parameters.o module_kpp_%s_Jacobian.o module_kpp_%s_JacobianSP.o module_kpp_%s_Update_Rconst.o module_wkppc_constants.o \n\n",kname, kname, kname, kname, kname ); + + } + } + + + fprintf(t_Makefile, "module_wkkpc_constants.o:\n\n"); + fprintf(t_Makefile, "module_kpp_%s_interface.o:\n\n"); + } + + + + if ( strncmp(inln, "OBJS",3) == 0){ + fprintf(t_Makefile, "\tkpp_mechanism_driver.o \\\n"); + + } + } + + + + fclose( t_Makefile ); + fclose( ch_Makefile ); + + + system(cp_command); + +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c b/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c new file mode 100644 index 00000000..14ccf567 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c @@ -0,0 +1,407 @@ +#include +#include +#include +#include +#include +#include +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + + +#define DEBUGR 0 + +/* variable name of water vapor in KPP file*/ +char * kpp_h2o = "H2O" ; + + +/* variable name of third body in KPP file*/ +char * kpp_third_body = "M" ; + + +int +compare_kpp_to_species ( char * kpp_dirname) +{ + knode_t * p1, *p2, * p, * pm1, * pm2, * p3, * pm3 , wrf_kpp_equivs; + char name1[NAMELEN], name2[NAMELEN], name3[NAMELEN] ; + char equivfilename[NAMELEN]; + FILE * equivFile; + char inln[4096], newln[4096]; + int in_comment, got_it; + char wrf_name[NAMELEN], kpp_name[NAMELEN]; + int i; + int got_h2o, got_air; + + + + /* first find matching packages */ + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + for ( p2 = WRFC_packs ; p2 != NULL ; p2 = p2->next ) { + + /* printf(" ... test0 %s %s\n",p1->name, p2->name ); */ + + + if ( strcmp (p1->name, p2->name) == 0) { + + + + /* point from a KPP-pack to the corresponding WRFC_pack */ + p1->assoc_wrf_pack = p2; + + } + + } + } + + + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + printf(" ... testing %s %s\n",p1, p2 ); + if ( p2 ) { + fprintf(stderr, "\n \n FOUND match between WRF-Chem/KPP for mechanism: %s \n", p2->name); + + + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + pm1->found_match = 0; + pm1->is_radical =0; + } + + + + /* if file *_wrfkpp.equiv exists store contents in wrf_kpp_equivs struct */ + + sprintf( equivfilename, "%s/%s/%s_wrfkpp.equiv", kpp_dirname, p2->name, p2->name); + + /* printf("%s \n", equivfilename ); */ + + equivFile = fopen (equivfilename, "r" ); + + if ( equivFile == NULL ) { + fprintf(stderr," Did NOT find file %s\n",equivfilename); + } + else + { + fprintf(stderr," Found file %s\n",equivfilename); + + /* loop over lines in wrf_kpp_equiv file */ + while ( fgets ( inln , 4096 , equivFile ) != NULL ){ + if ( DEBUGR == 1 ) printf(" i %s ", inln ); + + + int j; + for(j = 0; j < 4096 ; j++) wrf_name[j]='\0'; + for(j = 0; j < 4096 ; j++) kpp_name[j]='\0'; + + int n=0; + in_comment = 0; + for(j = 0; j < 4096 ; j++) newln[j]='\0'; + + while ( inln[n] != '\0' ){ + if (inln[n] == '!') { + in_comment = 1; + } + if ( !in_comment ) { + newln[n] = inln[n]; + } + n++; + } + + + if ( DEBUGR == 1 ) printf(" n %s ", newln ); + if ( !in_comment && strlen(newln) > 1 ) { + n=0; + while ( newln[n] != '\0' ){ + i=0; + + while ( newln[n] != ' ' ){ + wrf_name[i]=newln[n]; + i++; + n++; + } + + n++; + + i=0; + while ( newln[n] != ' ' && newln[n] != '\0'){ + if (newln[n] != '\n'){ + kpp_name[i]=newln[n]; + } + i++; + n++; + } + + } + + + + + + make_upper_case(wrf_name); + + make_upper_case(kpp_name); + + /* wrf_name=strtok(newln, " "); + kpp_name=strtok(NULL, " "); */ + printf(" kpp_name, wrf_name %s %s \n ", kpp_name, wrf_name ); + + + + /* check whether wrf_name was found in Registry */ + /* either as associated 4D chem var in a package */ + + got_it=0; + for ( pm2 = p2 -> members; pm2 != NULL ; pm2 = pm2->next ) { + + strcpy( name2, pm2->name ); + make_upper_case(name2); + + if ( DEBUGR > 1 ) { + fprintf(stderr,"comp %s %s \n",pm2->name, wrf_name); + } + if ( strcmp(name2, wrf_name) == 0 ) { + got_it=1; + + + } + } + + + + + + /* (b) or declared as a non-transported radical */ + + + p3 = WRFC_radicals; + + + for ( pm3 = p3 -> members; pm3 != NULL ; pm3 = pm3->next ) { + + + strcpy( name3, pm3->name ); + make_upper_case(name3); + + + if ( DEBUGR > 1 ) { + fprintf(stderr,"comp ra %s %s \n",name3, wrf_name); + } + if ( strcmp(name3, wrf_name) == 0 ) { + got_it=1; + + + } + } + + + + if ( got_it != 1 ) { + fprintf(stderr, "ERROR: variable name %s was found in file %s but not in the Registry \n", wrf_name, equivfilename); + exit (0); + } + + + /*-------------------------------------------------*/ + + /* check whether kpp_name was found in species file and + store name from wrf_kpp_equiv file in assoc_wrf_name */ + got_it=0; + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + + + strcpy( name1, pm1->name ); + make_upper_case(name1); + + if ( strcmp(name1, kpp_name) == 0 ) { + got_it=1; + pm1->found_match = 1; + strcpy( pm1->assoc_wrf_name, wrf_name); + + + + /* still have to check if it is a radical .. */ + + for ( pm3 = p3 -> members; pm3 != NULL ; pm3 = pm3->next ) { + + + strcpy( name3, pm3->name ); + make_upper_case(name3); + + + if ( DEBUGR > 1 ) { + fprintf(stderr,"comp ra %s %s \n",name3, wrf_name); + } + if ( strcmp(name3, wrf_name) == 0 ) { + + pm1->is_radical = 1; + + } + } + + + if ( DEBUGR == 1 ) { + fprintf(stderr,"matching %s %s %i \n",pm1->name, kpp_name, got_it); + } + } + if ( DEBUGR > 1 ) { + fprintf(stderr,"comp %s %s %i \n",pm1->name, kpp_name, got_it); + } + + } + + + + + if ( got_it != 1 ) { + fprintf(stderr, "ERROR: variable name %s was not found in species file in directory %s/%s but it was found in %s \n", kpp_name, kpp_dirname, p2->name, equivfilename); + exit (0); + } + + + + } + } + } + + + + /* compare compound names, use variable */ + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + + + if ( DEBUGR == 1 ) { + fprintf(stderr, " SEARCHING FOR %s \n", pm1->name ); + } + + + strcpy( name1, pm1->name ); + make_upper_case(name1); + + for ( pm2 = p2 -> members; pm2 != NULL ; pm2 = pm2->next ) { + + + strcpy( name2, pm2->name ); + make_upper_case(name2); + + + + if ( strcmp (name1, name2) == 0) { + /* store matching name of WRF var in members of KPP_packs */ + strcpy( pm1->assoc_wrf_name, pm2->name); + pm1->found_match = 1; + if ( DEBUGR == 1 ) { + fprintf(stderr, " matching names: %s %s \n", pm1->name, pm1->assoc_wrf_name); + } + } + } + + + /* the same for radicals */ + if ( pm1->found_match != 1 ) { + + if ( DEBUGR == 1 ){ + fprintf(stderr, " STILL SEARCHING FOR %s \n", pm1->name ); + } + p3 = WRFC_radicals; + + + for ( pm3 = p3 -> members; pm3 != NULL ; pm3 = pm3->next ) { + + + strcpy( name3, pm3->name ); + make_upper_case(name3); + + + /* fprintf(stderr, " comparing radicals %s %s \n", name1, name3); */ + + if ( strcmp (name1, name3) == 0) { + /* store matching name of WRF var in members of KPP_packs */ + strcpy( pm1->assoc_wrf_name, pm3->name); + pm1->found_match = 1; + pm1->is_radical = 1; + if ( DEBUGR == 1 ) { + fprintf(stderr, " matching radical name : %s %s \n", pm1->name, pm1->assoc_wrf_name); + } + } + } + } + + + + } + + + got_air = 0; + got_h2o = 0; + /* take care of water, third body */ + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + strcpy( name1, pm1->name ); + make_upper_case(name1); + if ( strcmp (name1, kpp_h2o) == 0) { + pm1->found_match = 2; + strcpy( pm1->assoc_wrf_name, "WATER VAPOR"); + got_air = 1; + } + if ( strcmp (name1, kpp_third_body) == 0) { + pm1->found_match = 2; + strcpy( pm1->assoc_wrf_name, "THIRD BODY"); + got_h2o = 1; + } + } + + if ( got_air != 1 ) { + fprintf(stderr, "ERROR: variable name for third body in KPP species file is expected to be %s, but was not found in %s species file \n", kpp_third_body, p2->name); + /* exit (0); */ + } + + + if ( got_h2o != 1 ) { + fprintf(stderr, "ERROR: variable name for water in KPP species file is expected to be %s, but was not found in %s species file\n", kpp_h2o, p2->name); + /* exit (0); */ + } + + + + + } + } + + + + /* now in screen_out + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + fprintf(stderr, "1 MATCHING PACKS: %s \n", p2->name); + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + + if ( pm1 -> found_match == 1 ) { + fprintf(stderr, " 1 found %s %s \n", pm1->name, pm1 -> assoc_wrf_name ); + } + else if ( pm1 -> found_match == 2 ) { + fprintf(stderr, " 1 found %s %s \n", pm1->name, pm1 -> assoc_wrf_name ); + } + else { + fprintf(stderr, " 0 NOT found %s \n", pm1->name ); + exit (0); + } + + } + + } + } + + */ + + + return(0) ; + +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/do_makefiles_kpp.c b/wrfv2_fire/chem/KPP/util/wkc/do_makefiles_kpp.c new file mode 100644 index 00000000..4dd6cecd --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/do_makefiles_kpp.c @@ -0,0 +1,46 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + +#define DEBUGR 0 + +int +write_makefiles_kpp ( char* kpp_dirname, char * kpp_version ) +{ + knode_t * p1, * p2; + +char kname[NAMELEN]; +char mfname0[NAMELEN], mfname[NAMELEN]; +FILE * mfile; + + + strcpy( mfname0, "Makefile" ); + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + + strcpy( kname, p1->name ); + sprintf( mfname, "%s/%s/%s", kpp_dirname, kname, mfname0 ); + + + mfile = fopen ( mfname, "w" ); + + /* fprintf(mfile," hh %s\n", mfname); */ + + gen_kpp_warning(mfile, "tools/write_makefiles_kpp.c","#" ); + fprintf(mfile,"$(MODEL):\t$(MODEL).kpp\n"); + fprintf(mfile,"\t\t${KPP_HOME}/bin/kpp"); + + fclose(mfile); + } + } + + + exit (0); + return(0) ; + +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c new file mode 100644 index 00000000..85346c0f --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c @@ -0,0 +1,259 @@ +/* + WRF-Chem to KPP coupler (WKC) + + Copyright (C) 2006 Marc Salzmann + + WKC is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation (http://www.gnu.org/copyleft/gpl.html); either version 2 of the + License, or (at your option) any later version. + + WKC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along + with this program; if not, consult http://www.gnu.org/copyleft/gpl.html or + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + Marc Salzmann + Max Planck Institute for Chemistry + Department of Atmospheric Chemistry + Postfach 3060 + 55020 Mainz, Germany + e-mail: salzmann@mpch-mainz.mpg.de + www.mpch-mainz.mpg.de/~salzmann/my_home/index.html + +..................................................................... + + assumed directory name in KPP corresponds to WRF package name +.. + +*/ + +#include +#include +#include +#include +#include +#include +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + + +#define DEBUGR 1 + + + + + +/* for data storage issues see kpp_data.h */ + + +/* cd chem/KPP/util/wkc; make -i -r CC="gcc" ; cd ../../../.. + in ~WRF: chem/KPP/util/wkc/registry_kpp Registry/Registry */ + + +int +gen_kpp ( char * inc_dirname, char * kpp_dirname ) +{ + + + + /* put chem compound names defined in Registry into linked list WRFC_packs */ + + if ( DEBUGR == 1 ) printf("next: get_wrf_chem_specs \n"); + get_wrf_chem_specs () ; + if ( DEBUGR == 2 ) write_list_to_screen( WRFC_packs ) ; + + + + + /* put radical names defined in Registry into linked list WRFC_radicals */ + + if ( DEBUGR == 1 ) printf("next: get_wrf_radicals \n"); + get_wrf_radicals () ; + if ( DEBUGR == 2 ) write_list_to_screen( WRFC_radicals ) ; + + + /* put photolysis rates defined in Registry into linked list WRFC_jvals */ + + if ( DEBUGR == 1 ) printf("next: get_wrf_jvals \n"); + get_wrf_jvals () ; + if ( DEBUGR == 2 ) write_list_to_screen( WRFC_jvals ) ; + + + /* read KPP species files and put compound names into linked list KPP_packs */ + if ( DEBUGR == 1 ) printf("next: get_kpp_chem_specs \n"); + get_kpp_chem_specs ( kpp_dirname ) ; + if ( DEBUGR == 2 ) {write_list_to_screen( KPP_packs ) ;} + + + + + + /* define pointer from each KPP package to corresponding WRF-Chem chemistry package and check whether variable names are consistent. If *_wrfkpp.equiv file exists in KPP directory use it for name matching */ + + + if ( DEBUGR == 1 ) printf("next: compare_kpp_to_species \n"); + compare_kpp_to_species ( kpp_dirname ); + + + + + + /* write some output to screen */ + if ( DEBUGR == 1 ) printf("next: screen_out \n"); + screen_out( ); + + + /* make sure that wrf and kpp variables match and stop if not. */ + if ( DEBUGR == 1 ) printf("next: check_all \n"); + check_all ( kpp_dirname ); + + + + /* add the kpp generated modules to the Makefile in the chem directory */ + if ( DEBUGR == 1 ) printf("next: change_chem_Makefile \n"); + change_chem_Makefile ( ); + + + + + /* write the mechanism driver */ + if ( DEBUGR == 1 ) printf("next: gen_kpp_mechanism_driver (writing chem/kpp_mechanism_driver.F) \n"); + gen_kpp_mechanism_driver ( ); + + + if ( DEBUGR == 1 ) printf("next: gen_call_to_kpp_mechanism_driver (writing inc/call_to_kpp_mech_drive.inc) \n"); + gen_kpp_call_to_mech_dr ( ); + + + /* write arguments for call to KPPs Update_Rconst */ + if ( DEBUGR == 1 ) printf("next: gen_kpp_args_to_Update_Rconst (writing inc/args_to_update_rconst.inc and inc/next ) + { + fprintf(stderr,"-- Mechanism %s ----- \n", l1->name); + for ( l2 = l1->members ; l2 != NULL ; l2 = l2->next ) + { + fprintf(stderr,"%s ", l2->name); + } + fprintf(stderr," \n \n "); + } +} + +/*---------------------------------------------------------------------*/ +int +screen_out ( ) +{ +knode_t * p1, * p2, * pm1; +int count; + + count=0; + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + + /* fprintf(stderr, "KPP PACK: %s \n", p1->name); */ + + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + fprintf(stderr, "MATCHING PACK: %s_kpp \n", p2->name); + count =count+1; + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + + if ( pm1 -> found_match == 1 ) { + + if ( pm1 -> is_radical == 1 ) { + if ( DEBUGR == 2 ) { + fprintf(stderr, " 1 found (radical) %s %s \n", pm1->name, pm1 -> assoc_wrf_name ); + } + + } else{ + if ( DEBUGR == 2 ){ + fprintf(stderr, " 1 found %s %s \n", pm1->name, pm1 -> assoc_wrf_name ); + } + } + } + else if ( pm1 -> found_match == 2 ) { + fprintf(stderr, " 1 found (special) %s %s \n", pm1->name, pm1 -> assoc_wrf_name ); + } + else { + fprintf(stderr, " 0 NOT found %s \n", pm1->name ); + /* exit (0); */ + } + + } + + } + + /* if ( count == 0 ) { + fprintf(stderr, " DIDN'T FIND ANY matching packages \n"); + fprintf(stderr, " .. add packages to Registry and to chem/KPP/mechanisms \n"); + exit (0); + } */ + + + } + + + +} +/*---------------------------------------------------------------------*/ +int +check_all( char* kpp_dirname ) +{ +knode_t * p1, * p2, * pm1; + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + + if ( pm1 -> found_match < 1 ) { + + + fprintf(stderr, "\n FATAL ERROR MAPPING WRF TO KPP SPECIES FOR MECHANISM: %s \n", p2->name ); + fprintf(stderr, " variable %s NOT FOUND \n", pm1->name ); + fprintf(stderr, " Please check: \n"); + fprintf(stderr, " (a) the Registry \n"); + fprintf(stderr, " (b) ./%s/%s/%s.spc\n", kpp_dirname, p2->name, p2->name); + fprintf(stderr, " and ./%s/%s/%s_wrfkpp.equiv (if present) \n",kpp_dirname, p2->name, p2->name); + fprintf(stderr, " EXITING \n"); + exit(1); + + } + } + + } + } +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c.temp b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c.temp new file mode 100644 index 00000000..0f06e957 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp.c.temp @@ -0,0 +1,346 @@ +/* +... + assumed directory name in KPP corresponds to WRF package name +.. + +missuse next4d +*/ + +#include +#include +#include +#include +#include +#include +#include + + +#include "protos.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + + +#define DEBUGR 0 + + + + +/* store chemistry packages from WRF in linked list rooted at WRFC_packs + - species variables will be stored as members of each package */ +knode_t * WRFC_packs ; + +/* store chemistry packages from KPP */ +knode_t * KPP_packs ; + + + + +/* cd tools; make -i -r CC="gcc"; cd .." + in ~WRF: tools/registry -DDEREF_KLUDGE -DIO_DEREF_KLUDGE -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF -DGRIB1 -DTRIEDNTRUE -DLIMIT_ARGS Registry/Registry ) */ + + +int +gen_kpp ( char * inc_dirname, char * kpp_dirname ) +{ + + + /* put chem compound names defined in Registry into linked list WRFC_packs */ + + get_wrf_chem_specs () ; + + + + /* read KPP species files and put compound names into linked list KPP_packs */ + + get_kpp_chem_specs ( kpp_dirname ) ; + + + + /* define pointer from each KPP package to corresponding WRF-Chem chemistry package + and check whether variable names are consistent */ + + compare_kpp_to_species (); + + + if ( DEBUGR == 1 ) { + write_list_to_screen( WRFC_packs ) ; + write_list_to_screen( KPP_packs ); + } + + + + + + + + + return(0) ; +} + +/*---------------------------------------------------------------*/ +int +get_wrf_chem_specs ( ) +{ + node_t * pkg; + char assoc_namelist_var[NAMELEN]; + char scalars_str[NAMELEN] ; + char * scalar ; + + knode_t * q , * member ; + + + for ( pkg = Packages ; pkg != NULL ; pkg = pkg->next ) + { + + + if ( !strncmp( pkg->pkg_assoc ,"chem_opt", 8) ) + { + + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, pkg->name ); + add_knode_to_end( q , &(WRFC_packs) ) ; + + + strcpy(scalars_str,pkg->pkg_4dscalars) ; + + + scalar=strtok(scalars_str, ":"); + scalar=strtok(NULL, ","); + + + while (scalar != NULL) + { + + member = new_knode( ) ; + strcpy( member->name , scalar ) ; + member->next = NULL ; + add_knode_to_end( member , &(q->members) ) ; + + + scalar = strtok(NULL, ","); + + } + + + } + } + return(0) ; +} + +/*---------------------------------------------------------------*/ +int +get_kpp_chem_specs ( char* kpp_dirname ) +{ + + +knode_t * q , * member ; +DIR * dir; +struct dirent * entry; +struct stat dir_stat; +char fulldirname[NAMELEN], spcfilename[NAMELEN]; +char inln[4096], kpp_spec[4096]; +FILE * spcFile; +int in_comment, got_it; + + + + /* http://users.actcom.co.il/~choo/lupg/tutorials/handling-files/handling-files.html#directory_struct */ + + + + dir = opendir(kpp_dirname); + if (!dir) { + fprintf(stderr, "WARNING from gen_kpp: Cannot read directory: %s \n", kpp_dirname); + perror(""); + return; + } + + + /* loop through sub directories in KPP directory */ + + while ((entry = readdir(dir))) { + if (entry->d_name ) { + + if ( strcmp(entry->d_name, ".") == 0) + continue; + if ( strcmp(entry->d_name, "..") == 0) + continue; + + + sprintf( fulldirname, "%s/%s", kpp_dirname, entry->d_name); + + printf("%s \n", fulldirname ); + + /* check if the given entry is a directory. */ + if (stat(fulldirname, &dir_stat) == -1) { + perror("WARNING from gen_kpp: "); + continue; + } + + + /* check if KPP species file is present. */ + + sprintf( spcfilename, "%s/%s/%s.spc", kpp_dirname, entry->d_name, entry->d_name); + + + spcFile = fopen (spcfilename, "r" ); + + if ( spcFile == NULL ) { + fprintf(stderr,"WARNING from gen_kpp: File %s not found. Skipping. \n", spcfilename); + continue; + } + + printf(" Using %s \n", spcfilename ); + + + /* put KPP packagename into linked list */ + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, entry->d_name ); + add_node_to_end( q , &(KPP_packs) ) ; + + /* loop over lines in KPP species file */ + while ( fgets ( inln , 4096 , spcFile ) != NULL ){ + if ( DEBUGR == 1 ){ printf("%s ", inln); } + /* strip from comments (loop through letters) */ + int n=0; + int nn = 0; + int j; + in_comment = 0; + got_it = 0; + + for(j = 0; j < 4096 ; j++) kpp_spec[j]='\0'; + while ( inln[n] != '\0' ){ + if ( inln[n] == '{') in_comment=1; + if ( in_comment == 0 ) { + if (inln[n] == '=' || inln[n] == '#') { + got_it=1; + } + if ( got_it == 0 && inln[n] != ' '){ + /* printf("%c %i \n ", inln[n], in_comment ); */ + + kpp_spec[nn]=inln[n]; + nn++; + + } + } + + if (inln[n] == '}') in_comment=0; + n++; + + } + + /* printf("spec: %s \n ", kpp_spec); */ + + if (kpp_spec[0] != '\0' && got_it == 1 ) { + + if ( DEBUGR == 1 ){ + printf("spec: %s \n ", kpp_spec); + fprintf(stderr," p, name %s %s \n", q->name, kpp_spec ); + } + + member = new_knode( ) ; + strcpy( member->name , kpp_spec ) ; + member->next = NULL ; + add_node_to_end( member , &(q->members) ) ; + + } + } + + + + fclose(spcFile); + + } + + } + + return(0) ; +} + + +/*---------------------------------------------------------------------*/ + + +int +compare_kpp_to_species () +{ + node_t * p1, *p2, * p, * pm1, * pm2; + char name1[NAMELEN], name2[NAMELEN] ; + + + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + for ( p2 = WRFC_packs ; p2 != NULL ; p2 = p2->next ) { + if ( strcmp (p1->name, p2->name) == 0) { + + + /* here next4d is used to point from a KPP-pack to the corresponding WRFC_pack */ + p1->next4d = p2; + + } + + } + } + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->next4d; + if ( p2 ) { + fprintf(stderr, "FOUND match between WRF-Chem/KPP for mechanism: %s \n", p2->name); + + + /* compare compound names, use variable "mark" from data.h here */ + for ( pm1 = p1 -> members; pm1 != NULL ; pm1 = pm1->next ) { + for ( pm2 = p2 -> members; pm2 != NULL ; pm2 = pm2->next ) { + strcpy( name1, pm1->name ); + strcpy( name2, pm2->name ); + make_upper_case(name1); + make_upper_case(name2); + if ( strcmp (name1, name2) == 0) { + /* use "dname" to store matching name of WRF var in members of KPP_packs */ + strcpy( pm1->dname, pm2->name); + pm1->mark = 1; + pm2->mark = 1; + fprintf(stderr, " matching names: %s %s \n", pm1->name, pm1->dname); + } + else { + /* if a KPP species is not found registry package check */ + + } + + } + } + + + + + + + } + } + + + return(0) ; + +} +/*---------------------------------------------------------------------*/ +int +write_list_to_screen ( node_t * starting_point ) +{ +node_t * l1, *l2; + for ( l1 = starting_point ; l1 != NULL ; l1 = l1->next ) + { + fprintf(stderr,"-- Mechanism %s ----- \n", l1->name); + for ( l2 = l1->members ; l2 != NULL ; l2 = l2->next ) + { + fprintf(stderr,"%s ", l2->name); + } + fprintf(stderr," \n \n "); + } +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_args_to_Update_Rconst.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_args_to_Update_Rconst.c new file mode 100644 index 00000000..7f903e53 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_args_to_Update_Rconst.c @@ -0,0 +1,73 @@ +#include + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + + +int +gen_kpp_args_to_Update_Rconst( ) +{ + FILE * args_urc, * args_to_urc, * decls_urc; + char args_fname[NAMELEN], argst_fname[NAMELEN], decls_fname[NAMELEN]; + int n; + + + sprintf( args_fname, "inc/args_update_rconst.inc"); + sprintf( argst_fname, "inc/args_to_update_rconst.inc"); + sprintf( decls_fname, "inc/decls_update_rconst.inc"); + + + args_to_urc = fopen(argst_fname, "w" ); + args_urc= fopen(args_fname, "w" ); + decls_urc = fopen(decls_fname, "w" ); + + + + + + + + fprintf(args_to_urc," jv, njv, &\n" ); + fprintf(args_urc," j, nj, &\n" ); + + fprintf(args_to_urc," RCONST, &\n" ); + fprintf(args_urc," RCONST, &\n" ); + + + /* pass down pointers to photolysis rates */ + gen_kpp_pargs(args_to_urc, WRFC_jvals); + gen_kpp_pargs(args_urc, WRFC_jvals); + + + + + fprintf(args_to_urc," FIX(indf_M), FIX(indf_H2O), TEMP & \n" ); + fprintf(args_urc," C_M, C_H2O, TEMP & \n" ); + + fprintf(decls_urc,"\n IMPLICIT NONE\n"); + + + fprintf(decls_urc,"\n INTEGER, INTENT (IN ) :: nj \n\n" ); + fprintf(decls_urc," REAL(KIND=dp), DIMENSION(nj), INTENT(IN) :: j\n\n\n"); + + fprintf(decls_urc," REAL(KIND=dp), DIMENSION(NREACT), INTENT(OUT) :: RCONST\n\n\n"); + + + fprintf(decls_urc," REAL(KIND=dp), INTENT(IN) :: C_M, C_H2O,&\n"); + fprintf(decls_urc," TEMP\n\n\n"); + + + /* declare pointers to photolysis rates */ + gen_kpp_pdecl(decls_urc, WRFC_jvals); + + + + fclose( args_to_urc); + fclose( args_urc); + fclose( decls_urc); + + +} + diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interf_utils.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interf_utils.c new file mode 100644 index 00000000..1588fab0 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interf_utils.c @@ -0,0 +1,327 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + +int +decl_misc ( FILE * ofile ) +{ + + + fprintf(ofile," REAL(KIND=dp):: TIME_START\n"); + fprintf(ofile," REAL(KIND=dp):: TIME_END\n\n"); + + + fprintf(ofile," INTEGER, DIMENSION(20) :: ICNTRL \n"); + fprintf(ofile," REAL(KIND=dp), DIMENSION(20) :: RCNTRL\n"); + fprintf(ofile," INTEGER, DIMENSION(20) :: ISTATUS \n"); + fprintf(ofile," REAL(KIND=dp), DIMENSION(20) :: RSTATUS\n"); + fprintf(ofile," INTEGER :: IERR_U\n\n"); + + fprintf(ofile," REAL(KIND=dp), DIMENSION(NREACT):: RCONST \n\n"); + fprintf(ofile," REAL(KIND=dp), DIMENSION(NVAR) :: var\n"); + fprintf(ofile," REAL(KIND=dp), DIMENSION(NFIX) :: fix\n\n"); + + fprintf(ofile," !temperature (K)\n"); + fprintf(ofile," REAL(KIND=dp) :: TEMP \n\n"); + + fprintf(ofile," REAL(KIND=dp), DIMENSION(NSPEC) :: ATOL, RTOL\n\n"); + + + + fprintf(ofile," REAL(KIND=dp) :: conv, oconv \n\n"); + + fprintf(ofile," INTEGER :: i,j,k,n \n"); + + fprintf(ofile," \n\n\n\n "); +} + +int +decl_jv ( FILE * ofile ) +{ + int n; + + n=count_members( WRFC_jvals ); + + + fprintf(ofile," INTEGER, PARAMETER :: njv=%i\n",n); + fprintf(ofile," REAL(KIND=dp), DIMENSION(njv) :: jv\n\n\n"); + + + +} + + +int +count_members( knode_t * nl ) +{ + knode_t * pml; + int n=0; + + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + n=n+1; + } + + return(n); +} + + + +int +decl_jv_pointers ( FILE * ofile ) +{ + knode_t * pl; + char s1[NAMELEN], s2[NAMELEN]; + int count=1; + int i; + + fprintf(ofile, "! locally define pointers to photolysis rates\n\n"); + + for ( pl = WRFC_jvals -> members ; pl != NULL ; pl = pl->next ) { + + strcpy(s1,pl->name); + + for(i=0;i<50;i=i+1){ + s2[i]=s1[i+3]; + } + + + fprintf(ofile, " INTEGER, PARAMETER, PRIVATE :: Pj_%s = %i \n", s2, count); + + count = count + 1; + } + + + fprintf(ofile," \n\n\n"); + +} + + +int +gen_map_jval ( FILE * ofile ) +{ + knode_t * pl; + char s1[NAMELEN], s2[NAMELEN]; + int i; + + for ( pl = WRFC_jvals -> members ; pl != NULL ; pl = pl->next ) { + + strcpy(s1,pl->name); + + for(i=0;i<50;i=i+1){ + s2[i]=s1[i+3]; + } + fprintf(ofile, " jv(Pj_%s) = REAL(%s(i,k,j)/60., KIND=dp) \n", s2, s1); + + } + + fprintf(ofile," \n\n\n"); +} + + + + +int +gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + + if ( pml -> found_match == 1 ) { + + if ( pml -> is_radical == 0 ){ + fprintf(ofile, " var(ind_%s) = conv * REAL( MAX(chem(i,k,j,P_%s),0.), KIND=dp) \n", pml->name, pml -> assoc_wrf_name ); + } + else if ( pml -> is_radical == 1 ){ + fprintf(ofile, " var(ind_%s) = conv * REAL( MAX(%s(i,k,j),0.), KIND=dp) \n", pml->name, pml -> assoc_wrf_name ); + } + + } + else if ( pml -> found_match != 2 ) { + fprintf(stderr, " FATAL ERROR"); + exit (0); + } + + } +} + + + +int +gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + + if ( pml -> found_match == 1 ) { + + if ( pml -> is_radical == 0 ){ + fprintf(ofile, " chem(i,k,j,P_%s) = MAX ( REAL (oconv * var(ind_%s), KIND=sp), 0.) \n", pml -> assoc_wrf_name, pml->name ); + } + else if ( pml -> is_radical == 1 ){ + fprintf(ofile, " %s(i,k,j) = MAX (REAL (oconv * var(ind_%s) , KIND=sp),0.) \n", pml -> assoc_wrf_name, pml->name ); + } + + } + else if ( pml -> found_match != 2 ) { + fprintf(stderr, " NOT found %s \n", pml->name ); + exit (0); + } + + } +} + + +int +gen_kpp_pargs( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + char s1[NAMELEN], s2[NAMELEN]; + int countit; + int max_per_line=5; + int i; + fprintf(ofile," "); + + countit=0; + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + + + strcpy(s1,pml->name); + + for(i=0;i<50;i=i+1){ + s2[i]=s1[i+3]; + } + + + fprintf(ofile," Pj_%s,", s2); + countit = countit+1; + if ( countit % max_per_line == 0) { + fprintf(ofile," & \n "); + } + } + + + fprintf(ofile," & \n"); + + +} + + +int +gen_kpp_pdecl( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + char s1[NAMELEN], s2[NAMELEN]; + int countit; + int max_per_line=5; + int i; + + fprintf(ofile, "\n\n\n INTEGER, INTENT(IN ) :: & \n "); + + + countit=0; + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + + strcpy(s1,pml->name); + + for(i=0;i<50;i=i+1){ + s2[i]=s1[i+3]; + } + + if ( pml->next != NULL ){ + fprintf(ofile," Pj_%s,", s2); + } + else{ + fprintf(ofile," Pj_%s", s2); + } + + countit = countit+1; + if ( countit % max_per_line == 0) { + if ( pml->next != NULL ){ + fprintf(ofile," & \n "); + } + } + } +} + + +int +wki_start_loop( FILE * ofile ) +{ + + fprintf(ofile,"\n DO j=jts, jte\n"); + fprintf(ofile," DO k=kts, kte-1\n"); + fprintf(ofile," DO i=its, ite\n\n\n"); +} + +int +wki_end_loop( FILE * ofile ) +{ + + fprintf(ofile,"\n\n\n END DO\n"); + fprintf(ofile," END DO\n"); + fprintf(ofile," END DO\n\n"); +} + + +int +wki_prelim( FILE * ofile ) +{ + + + + + fprintf(ofile," DO n=1, 20\n"); + fprintf(ofile," ICNTRL(n) = 0\n"); + fprintf(ofile," END DO\n\n"); + + + fprintf(ofile," ICNTRL(3) = 2\n\n"); + + fprintf(ofile," DO n=1, NSPEC\n"); + fprintf(ofile," ATOL(n) = REAL(atols, KIND=dp)\n"); + fprintf(ofile," RTOL(n) = REAL(rtols, KIND=dp)\n"); + fprintf(ofile," END DO\n\n\n"); + + fprintf(ofile," TIME_START = 0.0_dp \n"); + fprintf(ofile," TIME_END = REAL(dtstepc, KIND=dp) \n\n"); + + + +} + + +int +wki_one_d_vars( FILE * ofile ) +{ + + + fprintf(ofile," ! 3rd body concentration (molec/cm^3)\n"); + fprintf(ofile," FIX(indf_M) = REAL(dens2con_a * rho_phy(i,k,j), KIND=dp)\n\n"); + + fprintf(ofile," ! water concentration (molec/cm^3)\n"); + fprintf(ofile," FIX(indf_H2O) = REAL(dens2con_w * moist(i,k,j,P_QV) * rho_phy(i,k,j), KIND=dp)\n\n\n"); + + + + fprintf(ofile," ! temperature (K)\n"); + fprintf(ofile," TEMP = REAL(t_phy(i,k,j), KIND=dp)\n\n"); + + + fprintf(ofile," ! convesion from ppmV to molecules/cm3 and back\n"); + fprintf(ofile," conv=1.E-6_dp*dens2con_a*rho_phy(i,k,j)\n"); + fprintf(ofile," oconv = 1.E0_dp/conv\n\n\n"); + + + +} + + + + + diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interface.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interface.c new file mode 100644 index 00000000..a77cc680 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_interface.c @@ -0,0 +1,167 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + + +int +gen_kpp_interface ( ) +{ +knode_t * p1, * p2, * pm1; +char kpp_interf_fname[NAMELEN]; +FILE * kpp_if; + + + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + + + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + + sprintf( kpp_interf_fname, "chem/module_kpp_%s_interface.F",p2->name); + + + + kpp_if = fopen(kpp_interf_fname, "w" ); + + gen_kpp_warning(kpp_if, " tools/gen_kpp_interface.c","!"); + + + + fprintf(kpp_if,"MODULE module_kpp_%s_interf \n\n\n",p2->name ); + + fprintf(kpp_if," USE module_state_description\n"); + fprintf(kpp_if," USE module_configure\n\n"); + + + fprintf(kpp_if," USE %s_Parameters\n",p2->name ); + fprintf(kpp_if," USE %s_Precision\n",p2->name ); + fprintf(kpp_if," USE %s_UpdateRconstWRF\n",p2->name ); + fprintf(kpp_if," USE %s_Integrator\n\n",p2->name ); + + fprintf(kpp_if," USE module_wkppc_constants\n\n" ); + + + fprintf(kpp_if,"\n#include \n\n\n",p2->name ); + + + /* define pointers to jvals */ + decl_jv_pointers ( kpp_if ); + + + fprintf(kpp_if,"CONTAINS \n\n"); + + + fprintf(kpp_if,"SUBROUTINE %s_interface( &\n",p2->name ); + /* pass down variables (see gen_kpp_utils) */ + + + gen_kpp_pass_down( kpp_if ); + + fprintf(kpp_if," IMPLICIT NONE"); + + /* declare variables */ + gen_kpp_decl ( kpp_if ); + + + fprintf(kpp_if,"!local variables \n\n"); + + + /* declare local array for photolysis rates */ + decl_jv ( kpp_if ); + + /* declare misc variables (esp. for kpp) */ + decl_misc ( kpp_if ); + + + fprintf(kpp_if,"\n#include \n\n\n",p2->name ); + + + fprintf(kpp_if," \n\n"); + + + + /* preliminaries (setting atol, rtol from atols, rtols) */ + wki_prelim ( kpp_if ); + + + + fprintf(kpp_if,"\n\n"); + fprintf(kpp_if,"\n#include \n\n\n",p2->name ); + + /* start loop over 3-D fields */ + wki_start_loop ( kpp_if ); + + + /* 1-D water and 3rd body concentrations, temperature */ + wki_one_d_vars ( kpp_if ); + + + /* fprintf(stderr, "1 MATCHING PACKS: %s \n", p2->name); */ + + /* map jvals for KPP (currently all jvals are mapped) */ + gen_map_jval ( kpp_if ); + + + + /* map wrf to kpp species */ + + gen_map_wrf_to_kpp ( kpp_if, p1 ); + + fprintf(kpp_if,"\n#include \n\n",p2->name ); + + + fprintf(kpp_if, "\n\n\n\n CALL %s_Update_Rconst( &\n", p2->name ); fprintf(kpp_if, "!\n"); + fprintf(kpp_if, "#include \n", p2->name); + fprintf(kpp_if, "!\n"); + fprintf(kpp_if, "#include \n"); + fprintf(kpp_if, "!\n)\n\n"); + + + fprintf(kpp_if,"\n#include \n\n",p2->name ); + + fprintf(kpp_if, "\n\n\n\n CALL %s_INTEGRATE(TIME_START, TIME_END, & \n", p2->name ); + fprintf(kpp_if, " FIX, VAR, RCONST, ATOL, RTOL, & \n"); + fprintf(kpp_if, " ICNTRL_U=icntrl )\n\n\n\n\n"); + + + /* fprintf(kpp_if, " ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U )\n\n\n\n\n"); */ + + + fprintf(kpp_if,"\n#include \n\n",p2->name ); + + + + /* return values from kpp to wrf */ + gen_map_kpp_to_wrf ( kpp_if, p1 ); + + + + /* end loop over 3-D fields */ + wki_end_loop( kpp_if ); + + + fprintf(kpp_if,"\n\n"); + fprintf(kpp_if,"\n#include \n\n\n",p2->name ); + + fprintf(kpp_if,"\n\nEND SUBROUTINE %s_interface\n",p2->name ); + fprintf(kpp_if,"\n\nEND MODULE module_kpp_%s_interf \n",p2->name ); + + fprintf(kpp_if,"\n#include \n\n\n",p2->name ); + + fclose( kpp_if ); + + + } + } + + + +} + +/*---------------------------------------------------------------------*/ diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_mech_dr.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_mech_dr.c new file mode 100644 index 00000000..4b33e741 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_mech_dr.c @@ -0,0 +1,140 @@ + +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + + +/*---------------------------------------------------------------------*/ +int +gen_kpp_mechanism_driver ( ) +{ +knode_t * p1, * p2, * p3, * p4, * pm1, * pm3, * pm4; + char kpp_mdr_fname[NAMELEN]; + FILE * kpp_mdr; + int countit; + int max_per_line=6; + + + sprintf( kpp_mdr_fname, "chem/kpp_mechanism_driver.F"); + + + kpp_mdr = fopen(kpp_mdr_fname, "w" ); + + + + + + /* print warning THIS FILE WAS AUTOMATICALLY GENERATED ... */ + gen_kpp_warning(kpp_mdr, "tools/gen_kpp_mech_dr.c","!" ); + + + + fprintf(kpp_mdr, " SUBROUTINE kpp_mechanism_driver( &\n" ); + + /* pass down variables (see gen_kpp_utils) */ + gen_kpp_pass_down( kpp_mdr ); + + + fprintf(kpp_mdr, " USE module_configure\n"); + fprintf(kpp_mdr, " USE module_state_description\n\n"); + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + fprintf(kpp_mdr, " USE module_kpp_%s_interf \n",p2->name ); + } + } + + + fprintf(kpp_mdr, "\n IMPLICIT NONE\n\n"); + + /* declare variables */ + gen_kpp_decl ( kpp_mdr ); + + + fprintf(kpp_mdr, "\n\n!--------\n\n\n"); + fprintf(kpp_mdr, "\n\n kpp_chem_select: SELECT CASE(config_flags%%chem_opt) \n\n"); + + + + + /* write calls to kpp interface routines */ + + + + for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { + p2 = p1->assoc_wrf_pack; + if ( p2 ) { + + + /* fprintf(stderr, "1 MATCHING PACKS: %s \n", p2->name); */ + + /* map wrf to kpp species */ + + + fprintf(kpp_mdr, " CASE (%s_kpp) \n\n", p2->name ); + fprintf(kpp_mdr, " CALL wrf_debug(15,'kpp_mechanism_driver: calling %s_interface') \n\n", p2->name ); + fprintf(kpp_mdr, " CALL %s_interface( &\n", p2->name ); + /* pass down variables */ + gen_kpp_pass_down ( kpp_mdr ); + + + + } + } + + + fprintf(kpp_mdr, "\n CASE DEFAULT\n\n"); + + fprintf(kpp_mdr, " END SELECT kpp_chem_select\n\n"); + + fprintf(kpp_mdr, " END SUBROUTINE kpp_mechanism_driver\n\n"); + + + + + + fclose(kpp_mdr); + +} + + + +int +gen_kpp_call_to_mech_dr ( ) +{ +knode_t * p1, * p2, * p3, * p4, * pm1, * pm3, * pm4; + char kpp_cmd_fname[NAMELEN]; + FILE * kpp_cmd; + int countit; + int max_per_line=6; + + sprintf( kpp_cmd_fname, "inc/call_to_kpp_mech_drive.inc"); + + + kpp_cmd = fopen(kpp_cmd_fname, "w" ); + + + + + /* print warning THIS FILE WAS AUTOMATICALLY GENERATED ... */ + gen_kpp_warning(kpp_cmd, "tools/gen_kpp_mech_dr.c","!" ); + + + + /* pass down all radicals */ + gen_kpp_argl_new( kpp_cmd, WRFC_radicals ); + + + /* pass down jvals */ + gen_kpp_argl_new( kpp_cmd, WRFC_jvals ); + + + +} + diff --git a/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_utils.c b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_utils.c new file mode 100644 index 00000000..416e48e1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/gen_kpp_utils.c @@ -0,0 +1,182 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + +int gen_kpp_warning( FILE * ofile, char * gen_by_name, char*cchar ) +{ + fprintf(ofile, "%s \n", cchar); + fprintf(ofile, "%s THIS FILE WAS AUTOMATICALLY GENERATED BY \n%s\n",cchar,cchar ); + fprintf(ofile, "%s %s \n%s\n", cchar, gen_by_name, cchar); + fprintf(ofile, "%s MANUAL CHANGES TO THIS FILE WILL BE LOST !!! \n", cchar); fprintf(ofile, "%s \n", cchar); + fprintf(ofile, "%s \n", cchar); +} + + + +int +gen_kpp_pass_down ( FILE * ofile ) +{ + + fprintf(ofile,"!\n"); + fprintf(ofile,"#include \n"); + fprintf(ofile,"!\n"); + + /* pass down all radicals */ + gen_kpp_argl( ofile, WRFC_radicals ); + + + /* pass down jvals */ + gen_kpp_argl( ofile, WRFC_jvals ); + + + /* pass down dimensions */ + gen_kpp_argd ( ofile ); + +} + + +int +gen_kpp_decl ( FILE * ofile ) +{ + /* declare dimensions */ + gen_kpp_decld ( ofile ); + + + fprintf(ofile,"#include \n\n\n"); + + + + /* declare radicals */ + fprintf(ofile, "\n\n! \n"); + fprintf(ofile, "! radicals \n"); + fprintf(ofile, "! \n"); + + gen_kpp_decl3d( ofile, WRFC_radicals); + + + /* declare photolysis rates */ + fprintf(ofile, "\n\n! \n"); + fprintf(ofile, "! photolysis rates \n"); + fprintf(ofile, "! \n"); + + gen_kpp_decl3d( ofile, WRFC_jvals); + + + fprintf(ofile, " \n\n\n"); + + +} + +int gen_kpp_argl( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + int countit; + int max_per_line=5; + + fprintf(ofile," "); + + countit=0; + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + fprintf(ofile," %s,", pml->name); + countit = countit+1; + if ( countit % max_per_line == 0) { + fprintf(ofile," & \n "); + } + } + + + fprintf(ofile," & \n"); + + +} + + + +int gen_kpp_argl_new( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + int countit; + int max_per_line=4; + + fprintf(ofile," "); + + countit=0; + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + fprintf(ofile," grid%%%s,", pml->name); + countit = countit+1; + if ( countit % max_per_line == 0) { + fprintf(ofile," & \n "); + } + } + + + fprintf(ofile," & \n"); + + +} + + + + + +int gen_kpp_argd ( FILE * ofile ) +{ + fprintf(ofile, " ids,ide, jds,jde, kds,kde, &\n"); + fprintf(ofile, " ims,ime, jms,jme, kms,kme, &\n"); + fprintf(ofile, " its,ite, jts,jte, kts,kte )\n\n\n"); +} + + +int gen_kpp_decld ( FILE * ofile ) +{ + fprintf(ofile, "\n\n\n INTEGER, INTENT(IN ) :: &\n"); + fprintf(ofile, " ids,ide, jds,jde, kds,kde, & \n"); + fprintf(ofile, " ims,ime, jms,jme, kms,kme, & \n"); + fprintf(ofile, " its,ite, jts,jte, kts,kte \n\n\n\n"); +} + +int gen_kpp_decl3d( FILE * ofile, knode_t * nl ) +{ + knode_t * pml; + int countit; + int max_per_line=5; + + fprintf(ofile, " REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & \n"); + fprintf(ofile, " INTENT(INOUT ) :: & \n "); + + + countit=0; + for ( pml = nl -> members; pml != NULL ; pml = pml->next ) { + + + + if ( pml->next != NULL ){ + fprintf(ofile," %s,", pml->name); + } + else{ + fprintf(ofile," %s", pml->name); + } + + countit = countit+1; + if ( countit % max_per_line == 0) { + if ( pml->next != NULL ){ + fprintf(ofile," & \n "); + } + } + } +} + + + + + + + + + + + diff --git a/wrfv2_fire/chem/KPP/util/wkc/get_kpp_chem_specs.c b/wrfv2_fire/chem/KPP/util/wkc/get_kpp_chem_specs.c new file mode 100644 index 00000000..c818547e --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/get_kpp_chem_specs.c @@ -0,0 +1,157 @@ +#include +#include +#include +#include +#include +#include +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + +#define DEBUGR 0 + +int +get_kpp_chem_specs ( char* kpp_dirname ) +{ + + +knode_t * q , * member ; +DIR * dir; +struct dirent * entry; +struct stat dir_stat; +char fulldirname[NAMELEN], spcfilename[NAMELEN]; +char inln[4096], kpp_spec[4096]; +FILE * spcFile; +int in_comment, got_it; + + + + /* http://users.actcom.co.il/~choo/lupg/tutorials/handling-files/handling-files.html#directory_struct */ + + + + dir = opendir(kpp_dirname); + if (!dir) { + fprintf(stderr, "WARNING from gen_kpp: Cannot read directory: %s \n", kpp_dirname); + perror(""); + return; + } + + + /* loop through sub directories in KPP directory */ + + while ((entry = readdir(dir))) { + if (entry->d_name ) { + + if ( strcmp(entry->d_name, ".") == 0) + continue; + if ( strcmp(entry->d_name, "..") == 0) + continue; + + + + sprintf( fulldirname, "%s/%s", kpp_dirname, entry->d_name); + + printf("%s \n", fulldirname ); + + /* check if the given entry is a directory. */ + if (stat(fulldirname, &dir_stat) == -1) { + fprintf(stderr, "WAA\n\n"); + perror("WARNING from gen_kpp: "); + continue; + } + + + /* check if KPP species file is present. */ + + sprintf( spcfilename, "%s/%s/%s.spc", kpp_dirname, entry->d_name, entry->d_name); + + + ;fprintf(stderr, " spcfilename: %s \n",spcfilename); + + spcFile = fopen (spcfilename, "r" ); + + if ( spcFile == NULL ) { + fprintf(stderr,"WARNING from gen_kpp: File %s not found. Skipping. \n", spcfilename); + continue; + } + + printf(" Found %s \n", spcfilename ); + + + + + /*----------------------------------------------------*/ + + + /* put KPP packagename into linked list */ + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, entry->d_name ); + add_knode_to_end( q , &(KPP_packs) ) ; + + /* loop over lines in KPP species file */ + while ( fgets ( inln , 4096 , spcFile ) != NULL ){ + if ( DEBUGR == 1 ){ printf("%s ", inln); } + /* strip from comments (loop through letters) */ + int n=0; + int nn = 0; + int j; + in_comment = 0; + got_it = 0; + + for(j = 0; j < 4096 ; j++) kpp_spec[j]='\0'; + while ( inln[n] != '\0' ){ + if ( inln[n] == '{') in_comment=1; + if ( in_comment == 0 ) { + if (inln[n] == '=' || inln[n] == '#') { + got_it=1; + } + if ( got_it == 0 && inln[n] != ' '){ + /* printf("%c %i \n ", inln[n], in_comment ); */ + + kpp_spec[nn]=inln[n]; + nn++; + + } + } + + if (inln[n] == '}') in_comment=0; + n++; + + } + + /* printf("spec: %s \n ", kpp_spec); */ + + if (kpp_spec[0] != '\0' && got_it == 1 ) { + + if ( DEBUGR == 1 ){ + printf("spec: %s \n ", kpp_spec); + fprintf(stderr," p, name %s %s \n", q->name, kpp_spec ); + } + + member = new_knode( ) ; + strcpy( member->name , kpp_spec ) ; + member->next = NULL ; + add_knode_to_end( member , &(q->members) ) ; + + } + } + + + + fclose(spcFile); + + } + + } + + return(0) ; +} + diff --git a/wrfv2_fire/chem/KPP/util/wkc/get_wrf_chem_specs.c b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_chem_specs.c new file mode 100644 index 00000000..3399c64a --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_chem_specs.c @@ -0,0 +1,95 @@ +#include +#include +#include +#include +#include +#include +#include + + + +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + + +int +get_wrf_chem_specs ( ) +{ + node_t * pkg; + char assoc_namelist_var[NAMELEN]; + char scalars_str[NAMELEN] ; + char * scalar ; + char * suffix; + char pname[NAMELEN] ; + int j; + + knode_t * q , * member ; + + + for ( pkg = Packages ; pkg != NULL ; pkg = pkg->next ) + { + + + if ( !strncmp( pkg->pkg_assoc ,"chem_opt", 8) ) + { + + + + suffix=strrchr(pkg->name, '_'); + /* printf("suffix 0 %s \n",suffix ); */ + + + /* only use packages ending on "_kpp" */ + + if ( suffix == NULL ) continue; + if (strlen(suffix) != 4) continue; + if (strcmp(suffix, "_kpp") != 0) continue; + + /* clear string */ + for(j = 0; j < NAMELEN ; j++) pname[j]='\0'; + + /* remove the _kpp at the end */ + strncpy(pname, pkg->name, strlen(pkg->name)-4); + + + /* printf("pname 0 %s %s %i \n",pname,pkg->name, strlen(pkg->name)-4 ); */ + + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, pname ); + add_knode_to_end( q , &(WRFC_packs) ) ; + + + strcpy(scalars_str,pkg->pkg_4dscalars) ; + + + scalar=strtok(scalars_str, ":"); + scalar=strtok(NULL, ","); + + + while (scalar != NULL) + { + + member = new_knode( ) ; + strcpy( member->name , scalar ) ; + member->next = NULL ; + add_knode_to_end( member , &(q->members) ) ; + + + scalar = strtok(NULL, ","); + + } + + + } + } + + + + + return(0) ; +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/get_wrf_jvals.c b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_jvals.c new file mode 100644 index 00000000..3a0ac0c5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_jvals.c @@ -0,0 +1,47 @@ +#include + + +#include "protos.h" +#include "protos_kpp.h" +#include "kpp_data.h" + + +int get_wrf_jvals( ) +{ + + + knode_t * q, * member; + node_t *p ; + + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, "WRFC_jvals" ); + add_knode_to_end( q , &(WRFC_jvals) ); + + + + + + for ( p = Domain.fields ; p != NULL ; p = p->next ) + { + + if ( !strncmp( p->dname ,"PHOTR",5) ) + { + + /* fprintf(stdout, " %s: %s %s\n", p->dname, p->name, p->dname); */ + + member = new_knode( ) ; + strcpy( member->name , p->name ) ; + member->next = NULL ; + add_knode_to_end( member , &(q->members) ) ; + + + } + } + + + +return(0) ; +} + diff --git a/wrfv2_fire/chem/KPP/util/wkc/get_wrf_radicals.c b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_radicals.c new file mode 100644 index 00000000..d7e5e0ad --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/get_wrf_radicals.c @@ -0,0 +1,49 @@ +#include + +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "kpp_data.h" + + + +int +get_wrf_radicals () +{ + + + knode_t * q, * member; + node_t *p ; + + + q = new_knode( ); + q->next = NULL ; + strcpy( q->name, "WRFC_radicals" ); + add_knode_to_end( q , &(WRFC_radicals) ); + + + + + + for ( p = Domain.fields ; p != NULL ; p = p->next ) + { + + if ( !strncmp( p->descrip ,"Radicals",8) ) + { + + /* fprintf(stdout, " %s: %s \n", p->descrip, p->dname); */ + + member = new_knode( ) ; + strcpy( member->name , p->dname ) ; + member->next = NULL ; + add_knode_to_end( member , &(q->members) ) ; + + + } + } + + + + return(0) ; +} diff --git a/wrfv2_fire/chem/KPP/util/wkc/kpp_data.c b/wrfv2_fire/chem/KPP/util/wkc/kpp_data.c new file mode 100644 index 00000000..2a779b8f --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/kpp_data.c @@ -0,0 +1,32 @@ +#include +#include +#include +#include + +#include "registry.h" +#include "protos.h" +#include "protos_kpp.h" +#include "data.h" +#include "kpp_data.h" + + +knode_t * +new_knode ( int * kind ) +{ knode_t *p ; p = (knode_t *)malloc(sizeof(knode_t)) ; bzero(p,sizeof(knode_t)); return (p) ; } + +int +add_knode_to_end ( knode_t * knode , knode_t ** list ) +{ + knode_t * p ; + if ( *list == NULL ) + { *list = knode ; } + else + { + for ( p = *list ; p->next != NULL ; p = p->next ) ; + p->next = knode ; + } + return(0) ; +} + + + diff --git a/wrfv2_fire/chem/KPP/util/wkc/kpp_data.h b/wrfv2_fire/chem/KPP/util/wkc/kpp_data.h new file mode 100644 index 00000000..64585430 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/kpp_data.h @@ -0,0 +1,62 @@ +#ifndef KDATA_H +#include "registry.h" + + + + +typedef struct knode_struct { + + char name[NAMELEN] ; + struct knode_struct * members ; + struct knode_struct * next ; + + + char wrf_name[NAMELEN] ; + + struct knode_struct * assoc_wrf_pack ; + + char assoc_wrf_name[NAMELEN] ; + + /* flag whether a matching varname was found */ + int found_match ; + + /* flag whether variable is declared as radical species */ + int is_radical ; + + +} knode_t ; + +#ifndef DEFINE_GLOBALS +# define EXTERN extern +#else +# define EXTERN +#endif + + + +/* store chemistry packages (mechanisms) from WRF in linked list rooted at WRFC_packs + - species variables will be stored as members of each package */ +EXTERN knode_t * WRFC_packs ; + + + +/* store chemistry packages (mechanisms) from KPP */ +EXTERN knode_t * KPP_packs ; + + +/* non-transported radicals are not part of the packages */ +EXTERN knode_t * WRFC_radicals ; + + +/* photolysis rates from Registry */ +EXTERN knode_t * WRFC_jvals ; + + + + + + + + +#define KDATA_H +#endif diff --git a/wrfv2_fire/chem/KPP/util/wkc/linker.csh b/wrfv2_fire/chem/KPP/util/wkc/linker.csh new file mode 100755 index 00000000..35ee6bc8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/linker.csh @@ -0,0 +1,19 @@ +#!/bin/csh -f + + +if ( $#argv != 1 ) then +Error: Usage: linker.csh option +exit +endif + +set files=( data.c data.h misc.c my_strtok.c protos.h reg_parse.c registry.h type.c sym.c sym.h symtab_gen.c ) + + +foreach file ( $files ) +if ( $argv[1] == 'link' ) ln -s ../../../../tools/$file +if ( $argv[1] == 'unlink' ) rm -f $file +end + + +exit + diff --git a/wrfv2_fire/chem/KPP/util/wkc/protos_kpp.h b/wrfv2_fire/chem/KPP/util/wkc/protos_kpp.h new file mode 100644 index 00000000..27d6d01d --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/protos_kpp.h @@ -0,0 +1,64 @@ +#ifndef PROTOS_H_KPP +#include "kpp_data.h" + +/* added for gen_kpp */ +knode_t * new_knode () ; + +int add_knode_to_end ( knode_t * node , knode_t ** list ) ; +int gen_kpp (char * dirname1, char * dirname2); + +int get_wrf_chem_specs ( ) ; +int get_wrf_radicals ( ) ; +int get_wrf_jvals ( ); + +int get_kpp_chem_specs ( char * kpp_dirname ) ; + + +int compare_kpp_to_species ( char * kpp_dirname) ; + + +int run_kpp( char * dirname , char * kpp_version ); +int change_chem_Makefile( ); + + +int gen_kpp_mechanism_driver ( ); +int gen_kpp_call_to_mech_dr ( ); +int gen_kpp_args_to_Update_Rconst ( ); +int gen_kpp_interface( ); + + +int debug_out( ); + +/* int copy_makefiles_kpp ( char * kpp_dirname ); */ + + + + +/* added gen_kpp utils */ +int gen_kpp_warning( FILE * ofile, char * gen_by_name, char * cchar ); +int gen_kpp_pass_down ( FILE * ofile ); +int gen_kpp_decl ( FILE * ofile ); +int gen_kpp_argl( FILE * ofile , knode_t * nl ); +int gen_kpp_argl_new( FILE * ofile , knode_t * nl ); +int gen_kpp_argd ( FILE * ofile ); +int gen_kpp_decld ( FILE * ofile ); +int gen_kpp_decl3d( FILE * ofile, knode_t * nl ); + +/* added gen_kpp_interf utils */ +int decl_misc ( FILE * ofile ); +int decl_jv ( FILE * ofile ); +int count_members( knode_t * nl ); +int decl_jv_pointers ( FILE * ofile ); +int decl_kwc_constants ( FILE * ofile ); +int gen_map_jval( FILE * ofile ); +int gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ); +int gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ); +int gen_kpp_pargs( FILE * ofile, knode_t * nl ); +int gen_kpp_pdecl( FILE * ofile, knode_t * nl ); +int wki_prelim( FILE * ofile ); +int wki_start_loop( FILE * ofile ); +int wki_end_loop( FILE * ofile ); +int wki_one_d_vars ( FILE * ofile ); + +#define PROTOS_H_KPP +#endif diff --git a/wrfv2_fire/chem/KPP/util/wkc/registry_kpp b/wrfv2_fire/chem/KPP/util/wkc/registry_kpp new file mode 100755 index 00000000..5bb3e84c Binary files /dev/null and b/wrfv2_fire/chem/KPP/util/wkc/registry_kpp differ diff --git a/wrfv2_fire/chem/KPP/util/wkc/registry_kpp.c b/wrfv2_fire/chem/KPP/util/wkc/registry_kpp.c new file mode 100644 index 00000000..1ad117b3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/registry_kpp.c @@ -0,0 +1,166 @@ +#include +#include +#include +#include +#include +#include +#include + +#define DEFINE_GLOBALS +#include "protos.h" +#include "protos_kpp.h" +#include "registry.h" +#include "data.h" +#include "sym.h" + +main( int argc, char *argv[], char *env[] ) +{ + char fname_in[NAMELEN], dir[NAMELEN], fname_tmp[NAMELEN], command[NAMELEN] ; + FILE * fp_in, *fp_tmp ; + char * thisprog ; + int mypid ; + struct rlimit rlim ; + + mypid = (int) getpid() ; + strcpy( thiscom, argv[0] ) ; + argv++ ; + + sw_deref_kludge = 0 ; + sw_io_deref_kludge = 0 ; + sw_3dvar_iry_kludge = 0 ; + sw_distrib_io_layer = 1 ; + sw_limit_args = 0 ; /* usually set -- except for GRAPS */ + sw_dm_parallel = 0 ; + sw_all_x_staggered = 0 ; + sw_move = 0 ; + sw_all_y_staggered = 0 ; + sw_ifort_kludge = 0 ; + sw_dm_serial_in_only = 0 ; /* input and bdy data set is distributed by node 0, + other data streams are written to file per process */ + + strcpy( fname_in , "" ) ; + + rlim.rlim_cur = RLIM_INFINITY ; + rlim.rlim_max = RLIM_INFINITY ; + + setrlimit ( RLIMIT_STACK , &rlim ) ; + + sym_forget() ; + thisprog = *argv ; + while (*argv) { + if (*argv[0] == '-') { /* an option */ + if (!strncmp(*argv,"-D",2)) { + char * p ; + p = *argv ; + sym_add(p+2) ; + } + + if (!strcmp(*argv,"-DDEREF_KLUDGE")) { + sw_deref_kludge = 1 ; + } + if (!strcmp(*argv,"-DIO_DEREF_KLUDGE")) { + sw_io_deref_kludge = 1 ; + } + if (!strcmp(*argv,"-DLIMIT_ARGS")) { + sw_limit_args = 1 ; + } + if (!strcmp(*argv,"-DMOVE_NESTS")) { + sw_move = 1 ; + } + if (!strcmp(*argv,"-DIFORT_KLUDGE")) { + sw_ifort_kludge = 1 ; + } + if (!strcmp(*argv,"-DD3VAR_IRY_KLUDGE")) { +#if 0 + sw_3dvar_iry_kludge = 1 ; +#else + fprintf(stderr,"WARNING: -DD3VAR_IRY_KLUDGE option obsolete (it is now disabled by default). Ignored.\n") ; +#endif + } + if (!strcmp(*argv,"-DALL_X_STAGGERED")) { + sw_all_x_staggered = 1 ; + } + if (!strcmp(*argv,"-DALL_Y_STAGGERED")) { + sw_all_y_staggered = 1 ; + } + if (!strcmp(*argv,"-DDM_PARALLEL")) { + sw_dm_parallel = 1 ; + } + if (!strcmp(*argv,"-DDISTRIB_IO_LAYER")) { +#if 0 + sw_distrib_io_layer = 1 ; +#else + fprintf(stderr,"WARNING: -DDISTRIB_IO_LAYER option obsolete (it is now default). Ignored.\n") ; +#endif + } + if (!strcmp(*argv,"-DDM_SERIAL_IN_ONLY")) { + sw_dm_serial_in_only = 1 ; + } + if (!strncmp(*argv,"-h",2)) { + fprintf(stderr,"Usage: %s [-DDEREF_KLUDGE] [-DDM_PARALLEL] [-DDISTRIB_IO_LAYER] [-DDM_SERIAL_IN_ONLY] [-DD3VAR_IRY_KLUDGE] registryfile\n",thisprog) ; + exit(1) ; + } + } + else /* consider it an input file */ + { + strcpy( fname_in , *argv ) ; + } + argv++ ; + } + + init_parser() ; + init_type_table() ; + init_dim_table() ; + init_core_table() ; + + if ( !strcmp(fname_in,"") ) fp_in = stdin ; + else + if (( fp_in = fopen( fname_in , "r" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open %s for reading. Ending.\n", fname_in ) ; + exit(2) ; + } + + sprintf( fname_tmp , "Registry_tmp.%d",mypid) ; + if (( fp_tmp = fopen( fname_tmp , "w" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open temporary %s for writing. Ending.\n", fname_tmp ) ; + exit(2) ; + } + + { char *e ; + strcpy( dir , fname_in ) ; + if ( ( e = rindex ( dir , '/' ) ) != NULL ) { *e = '\0' ; } else { strcpy( dir, "." ) ; } + } + + if ( pre_parse( dir, fp_in, fp_tmp ) ) { + fprintf(stderr,"Problem with Registry File %s\n", fname_in ) ; + goto cleanup ; + } + sym_forget() ; + + fclose(fp_in) ; + fclose(fp_tmp) ; + + if (( fp_tmp = fopen( fname_tmp , "r" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open %s for reading. Ending.\n", fname_tmp ) ; + goto cleanup ; + } + + reg_parse(fp_tmp) ; + + fclose(fp_tmp) ; + + check_dimspecs() ; + + + gen_kpp("inc", "chem/KPP/mechanisms"); + + +cleanup: + sprintf(command,"/bin/rm -f %s\n",fname_tmp ); + system( command ) ; + +} + diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile new file mode 100755 index 00000000..ed886e00 --- /dev/null +++ b/wrfv2_fire/chem/Makefile @@ -0,0 +1,191 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + + +MODULES = \ + module_chem_utilities.o \ + module_data_radm2.o \ + module_data_racm.o \ + module_data_sorgam.o \ + module_data_cbmz.o \ + module_data_mosaic_asect.o \ + module_data_mosaic_other.o \ + module_data_mosaic_therm.o \ + module_data_cmu_bulkaqchem.o \ + module_peg_util.o \ + module_mosaic_csuesat.o \ + module_cbmz_lsodes_solver.o \ + module_cbmz_rodas3_solver.o \ + module_cbmz_rodas_prep.o \ + module_radm.o \ + module_racm.o \ + module_cbmz.o \ + module_phot_mad.o \ + module_dep_simple.o \ + module_bioemi_simple.o \ + module_bioemi_beis311.o \ + module_vertmx_wrf.o \ + module_aerosols_sorgam.o \ + module_mosaic_movesect.o \ + module_mosaic_therm.o \ + module_mosaic_newnuc.o \ + module_mosaic_coag.o \ + module_mosaic_driver.o \ + module_mosaic_drydep.o \ + module_cbmz_addemiss.o \ + module_mosaic_addemiss.o \ + module_input_chem_data.o \ + module_input_chem_bioemiss.o \ + module_fastj_data.o \ + module_fastj_mie.o \ + module_phot_fastj.o \ + module_ctrans_aqchem.o \ + module_ctrans_grell.o \ + module_emissions_anthropogenics.o \ + module_cbmz_initmixrats.o \ + module_mosaic_initmixrats.o \ + module_mosaic_wetscav.o \ + module_cmu_dvode_solver.o \ + module_cmu_bulkaqchem.o \ + module_mosaic_cloudchem.o \ + module_wetscav_driver.o \ + module_mixactivate_wrappers.o + + +OBJS = \ + chemics_init.o \ + chem_driver.o \ + cloudchem_driver.o \ + photolysis_driver.o \ + mechanism_driver.o \ + emissions_driver.o \ + dry_dep_driver.o \ + aerosol_driver.o + + +LIBTARGET = chemics +TARGETDIR = ./ +$(LIBTARGET) : $(MODULES) $(OBJS) + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) + +include ../configure.wrf + +CPP = cpp + +clean: + @ echo 'use the clean script' + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +module_mixactivate_wrappers.o: ../phys/module_mixactivate.o + +module_data_radm2.o: + +module_data_racm.o: + +module_chem.utilities.o: + +module_radm.o: + +module_racm.o: + +module_data_cbmz.o: + +module_peg_util.o: + +module_cbmz.o: + +module_cbmz_addemiss.o: + +module_cbmz_rodas_prep.o: + +module_cbmz_initmixrats.o: + +module_phot_mad.o: + +module_phot_fastj.o: + +module_input_chem_data.o: module_aerosols_sorgam.o + +module_input_chem_bioemiss.o: + +module_dep_simple.o: + +module_bioemi_simple.o: + +module_vertmx_wrf.o: + +module_emissions_anthropogenics.o: + +module_data_sorgam.o: + +module_aerosols_sorgam.o: + +module_cbmz_lsodes_solver.o: + +module_cbmz_rodas3_solver.o: + +module_mosaic_csuesat.o: + +module_data_mosaic_asect.o: + +module_data_mosaic_other.o: + +module_data_mosaic_therm.o: + +module_mosaic_addemiss.o: module_data_mosaic_asect.o + +module_mosaic_drydep.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o + +module_mosaic_initmixrats.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o + +module_mosaic_movesect.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o + +module_mosaic_therm.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_data_mosaic_therm.o module_mosaic_movesect.o + +module_mosaic_newnuc.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_mosaic_movesect.o + +module_mosaic_coag.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_mosaic_movesect.o + +module_mosaic_driver.o: module_peg_util.o module_mosaic_csuesat.o module_data_mosaic_asect.o module_data_mosaic_other.o module_data_mosaic_therm.o module_mosaic_movesect.o module_mosaic_therm.o module_mosaic_newnuc.o module_mosaic_coag.o module_mosaic_wetscav.o + +module_cmu_dvode_solver.o: + +module_data_cmu_bulkaqchem.o: + +module_cmu_bulkaqchem.o: module_data_cmu_bulkaqchem.o module_cmu_dvode_solver.o + +module_mosaic_cloudchem.o: module_data_cmu_bulkaqchem.o module_cmu_bulkaqchem.o module_data_mosaic_asect.o module_mosaic_movesect.o module_mosaic_driver.o + +module_fastj_data.o: + +module_fastj_mie.o: + +module_ctrans_grell.o: + +chem_driver.o: module_radm.o module_racm.o module_data_racm.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o + +chemics_init.o: module_phot_mad.o module_aerosols_sorgam.o + +aerosol_driver.o: module_aerosols_sorgam.o + +cloudchem_driver.o: module_mosaic_cloudchem.o + +photolysis_driver.o: module_phot_mad.o module_phot_fastj.o + +mechanism_driver.o: module_data_radm2.o module_radm.o module_data_racm.o module_aerosols_sorgam.o module_data_cbmz.o module_cbmz.o + +emissions_driver.o: module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis311.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o + +dry_dep_driver.o: module_data_radm2.o module_dep_simple.o module_aerosols_sorgam.o module_mosaic_drydep.o ../phys/module_mixactivate.o + +convert_bioemiss : convert_bioemiss.o + $(RANLIB) ../main/libwrflib.a + $(FC) -o convert_bioemiss.exe $(LDFLAGS) convert_bioemiss.o ../main/libwrflib.a $(LIB) + +convert_emiss : convert_emiss.o + $(RANLIB) ../main/libwrflib.a + $(FC) -o convert_emiss.exe $(LDFLAGS) convert_emiss.o ../main/libwrflib.a $(LIB) diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F new file mode 100755 index 00000000..231c60d9 --- /dev/null +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -0,0 +1,299 @@ +!WRF:MODEL_LAYER:PHYSICS +! + SUBROUTINE aerosols_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc, & + alt,t_phy,moist,aerwrf,p8w,t8w,p_phy,chem,rho_phy,dz8w, & + z,z_at_w,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1, & + cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old,& + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, & + e_so4i,e_so4j,e_no3i,e_no3j, & + vdrog3, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_model_constants + +! *** add new modules of schemes here + + USE module_aerosols_sorgam + USE module_data_sorgam + USE module_mosaic_driver, only: mosaic_aerchem_driver + + ! This driver calls subroutines for aerosols parameterizations. + ! + ! 1. MADE-SORGAM + ! 2. MOSAIC + +!---------------------------------------------------------------------- + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +!-- alt inverse density +!-- t_phy temperature (K) +!-- w vertical velocity (m/s) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- dz8w dz between full levels (m) +!-- p8w pressure at full levels (Pa) +!-- p_phy pressure (Pa) +! points (dimensionless) +!-- z 3D height with lowest level being the terrain +!-- rho_phy density (kg/m^3) +!-- R_d gas constant for dry air ( 287. J/kg/K) +!-- R_v gas constant for water vapor (461 J/k/kg) +!-- Cp specific heat at constant pressure (1004 J/k/kg) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- G acceleration due to gravity (m/s^2) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- config_flags%kemit end index for k for emissions arrays +! +!====================================================================== + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id,ktau,ktauc + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 +! +! aerosol emissions arrays +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(INOUT ) :: & + e_so4i,e_so4j,e_no3i,e_no3j, & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10 +! +! arrays for aerosol/radiation feedback +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + aerwrf +! +! aerosol/radm2 interaction +! + REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog), & + INTENT(IN ) :: & + VDROG3 +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy +! +! sulf concentration before modification by chemical mechanism +! + REAL, dimension (ims:ime,kms:kme-0,jms:jme), & + INTENT(INOUT) :: & + vcsulf_old + +! LOCAL VAR + integer :: ii,jj,kk + + +!----------------------------------------------------------------- + +! These are unneeded, since the default behavior is to do nothing. +! If the default changes, then lines need to be added for CBMZ and +! CBMZ_BB. +! IF (config_flags%chem_opt .eq. 0) return +! IF (config_flags%chem_opt .eq. 1) return + +! +! select which aerosol scheme to take +! + cps_select: SELECT CASE(config_flags%chem_opt) + + CASE (RADM2SORG,RADM2SORG_KPP) + CALL wrf_debug(15,'aerosols_driver calling sorgam_driver') + do ii=its,ite + do kk=kts,kte + do jj=jts,jte + if(chem(ii,kk,jj,p_nu0).lt.1.e07)then + chem(ii,kk,jj,p_nu0)=1.e7 + endif + enddo + enddo + enddo + call sorgam_driver (id,ktauc,dtstepc,t_phy,moist,aerwrf,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old, & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, & + e_so4i,e_so4j,e_no3i,e_no3j, & + vdrog3, & + config_flags%kemit, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (RACMSORG,RACMSORG_KPP) + CALL wrf_debug(15,'aerosols_driver calling sorgam_driver') + do ii=its,ite + do kk=kts,kte + do jj=jts,jte + if(chem(ii,kk,jj,p_nu0).lt.1.e07)then + chem(ii,kk,jj,p_nu0)=1.e7 + endif + enddo + enddo + enddo + call sorgam_driver (id,ktauc,dtstepc,t_phy,moist,aerwrf,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old, & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, & + e_so4i,e_so4j,e_no3i,e_no3j, & + vdrog3, & + config_flags%kemit, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'aerosols_driver calling mosaic_aerchem_driver') + CALL mosaic_aerchem_driver( & + id, ktau, dtstep, ktauc, dtstepc, config_flags, & + t_phy, rho_phy, p_phy, & + moist, chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT cps_select + + END SUBROUTINE aerosols_driver + +!----------------------------------------------------------------------- + + SUBROUTINE sum_pm_driver ( config_flags, & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE module_aerosols_sorgam, only: sum_pm_sorgam + USE module_mosaic_driver, only: sum_pm_mosaic + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt,h2oaj,h2oai + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10 + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags +! +! Select the active aerosol scheme and sum up pm2.5 and pm10 mass +! for use in radiation and/or diagnostic purposes. +! + sum_pm_select: SELECT CASE(config_flags%chem_opt) + + CASE (RADM2SORG, RACMSORG,RADM2SORG_KPP,RACMSORG_KPP) + CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_sorgam') + CALL sum_pm_sorgam ( & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic') + call sum_pm_mosaic ( & + alt, chem, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT sum_pm_select + + END SUBROUTINE sum_pm_driver diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F new file mode 100755 index 00000000..f6903354 --- /dev/null +++ b/wrfv2_fire/chem/chem_driver.F @@ -0,0 +1,920 @@ +!WRF:MODEL_LAYER:CHEMICS +! +#if ( NMM_CORE == 1 ) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!NCEP_MESO:MEDIATION_LAYER:SOLVER +! +!----------------------------------------------------------------------- +#include "../dyn_nmm/nmm_loop_basemacros.h" +#include "../dyn_nmm/nmm_loop_macros.h" +!----------------------------------------------------------------------- +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine chem_driver ( grid , config_flags & + +#if ( EM_CORE == 1 ) +#include "em_dummy_new_args.inc" +#endif + +#if ( NMM_CORE == 1 ) +#include "nmm_dummy_new_args.inc" +#endif + + ) +!---------------------------------------------------------------------- + USE module_domain + USE module_configure +#if ( EM_CORE == 1 ) + USE module_driver_constants + USE module_machine + USE module_tiles +#endif + USE module_dm + USE module_model_constants + USE module_state_description +#if ( NMM_CORE == 1 ) + USE MODULE_PHYSICS_CALLS +#endif + USE module_data_radm2 + USE module_data_sorgam + USE module_radm + USE module_dep_simple + USE module_bioemi_simple + USE module_phot_mad + USE module_aerosols_sorgam + USE module_chem_utilities + USE module_ctrans_grell + USE module_wetscav_driver, only: wetscav_driver + USE module_input_chem_data, only: & +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + chem_dbg, & +#endif + get_last_gas + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , TARGET :: grid + ! + ! Definitions of dummy arguments to solve +#if ( EM_CORE == 1 ) +#include +#define NO_I1_OLD +!#include +#endif +#if ( NMM_CORE == 1 ) +#include +#ifdef DM_PARALLEL + INCLUDE "mpif.h" +#endif +#endif + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte +! .. +! .. Local Scalars .. + INTEGER :: stepave,i,j,k,numgas,nv,n, nr,ktauc, ktau,k_start,k_end,idf,jdf,kdf + +! ................................................................ +! .. +! +! necessary for aerosols (module dependent) +! + real, dimension(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) ::vcsulf_old + real, dimension(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,ldrog) ::vdrog3 + + +!!! rate for n2o5 hyrolysis (calculated outside the chemistry solver routines) + real, dimension(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) ::n2o5_het +! met-variables needed +! + REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: & + p_phy,u_phy,v_phy & + ,t_phy,dz8w,t8w,p8w & + ,rho,rri,z_at_w,vvel,zmid + REAL,DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: pbl_h +#if ( NMM_CORE == 1 ) +! met-variables needed when using NMM +! + REAL,DIMENSION(grid%sm32:grid%em32-1) :: QL,TL +! + REAL,DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: REXNSFC,FACTRS & + ,TOT,TSFC +! + REAL :: DAYI,DPL,FICE,FRAIN,HOUR,PLYR & + & ,QI,QR,QW,RADT,TIMES,WC,TDUM,WMSK,RWMSK +#endif + + + INTEGER :: ij + INTEGER :: im , num_3d_m , ic , num_3d_c + INTEGER :: ijds, ijde + INTEGER :: ksubt + + REAL :: chem_minval, dtstepc + + INTEGER :: numgas_aqfrac = 0 ! last dimension of gas_aqfrac + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: gas_aqfrac + ! fraction of gas that is in cloud water + + LOGICAL :: haveaer +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min +! .. + +! Number of levels to exclude from the chem calculations counting from +! the model top. + ksubt=0 + stepave=1800./grid%dt + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ktau = grid%itimestep +!initialize +! +#if ( NMM_CORE == 1 ) +!*** IN NMM SET CONTROLS FOR TILES TO PATCHES +! +!----------------------------------------------------------------------- + KTAU=GRID%NMM_NTSD + IDF=IDE-1 + JDF=JDE-1 + KDF=KDE-1 + ITS=IPS + ITE=MIN(IPE,IDF) + JTS=JPS + JTE=MIN(JPE,JDF) + KTS=KPS + KTE=MIN(KPE,KDF) + +#endif + if(ktau.le.1)then + grid%gd_cloud_a=0. + grid%gd_cloud2_a=0. + grid%gd_cloud_b=0. + grid%gd_cloud2_b=0. + grid%raincv_a=0. + grid%raincv_b=0. + endif + + + + num_3d_m = num_moist + num_3d_c = num_chem + numgas = get_last_gas(config_flags%chem_opt) + + +#if ( EM_CORE == 1 ) + + ! Compute these starting and stopping locations for each tile and number of tiles. + CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe ) + k_start = kps + k_end = kpe + +#endif + ijds = min(ids, jds) + ijde = max(ide, jde) + + + chem_minval = epsilc !chem_minval can be case dependant and set below... + chem_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2) + CALL wrf_debug(15,'calling radm2 from chem_driver') + haveaer = .false. + CASE (RADM2_KPP) + CALL wrf_debug(15,'calling radm2_kpp from chem_driver') + haveaer = .false. + CASE (RADM2SORG) + CALL wrf_debug(15,'calling radm2sorg aerosols driver from chem_driver') + haveaer = .true. + CASE (RADM2SORG_KPP) + CALL wrf_debug(15,'calling radm2sorg aerosols driver from chem_driver') + haveaer = .false. + CASE (RADM2SORG_AQ) + CALL wrf_debug(15,'calling radm2sorg_aq aerosols driver from chem_driver') + haveaer = .true. + CASE (RACM) + CALL wrf_debug(15,'calling racm from chem_driver') + haveaer = .false. + CASE (RACM_KPP) + CALL wrf_debug(15,'calling racm_kpp from chem_driver') + haveaer = .false. + CASE (RACM_MIM_KPP) + CALL wrf_debug(15,'calling racm_mim_kpp from chem_driver') + haveaer = .false. + CASE (RACMSORG) + CALL wrf_debug(15,'calling racmsorg aerosols driver from chem_driver') + haveaer = .true. + CASE (RACMSORG_KPP) + CALL wrf_debug(15,'calling racmsorg_kpp aerosols driver from chem_driver') + haveaer = .false. + CASE (RACMSORG_AQ) + CALL wrf_debug(15,'calling racmsorg_aq aerosols driver from chem_driver') + haveaer = .true. + CASE (CBMZ) + CALL wrf_debug(15,'calling cbmz from chem_driver') + haveaer = .false. + CASE (CBMZ_BB) + CALL wrf_debug(15,'calling cbmz_bb from chem_driver') + haveaer = .false. + CASE (CBMZ_MOSAIC_4BIN) + CALL wrf_debug(15,'calling cbmz_mosaic_4bin aerosols driver from chem_driver') + haveaer = .true. + CASE (CBMZ_MOSAIC_8BIN) + CALL wrf_debug(15,'calling cbmz_mosaic_8bin aerosols driver from chem_driver') + haveaer = .true. + CASE (CBMZ_MOSAIC_4BIN_AQ) + CALL wrf_debug(15,'calling cbmz_mosaic_4bin_aq aerosols driver from chem_driver') + haveaer = .true. + CASE (CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'calling cbmz_mosaic_8bin_aq aerosols driver from chem_driver') + haveaer = .true. + CASE (CHEM_TRACER) + CALL wrf_debug(15,'tracer mode: only doing emissions and dry dep in chem_driver') + CASE DEFAULT + CALL wrf_debug(15,'calling chem_opt=? from chem_driver') + END SELECT chem_select + +! +! +! +#if ( NMM_CORE == 1 ) + k_start = kts + k_end = kte +! this should be in seperate routine!!!!!! + GRID%SIGMA=1 + grid%nmm_HYDRO=.FALSE. + its=max(its,MYIS1) + jts=max(jts,MYJS2) + ite=min(ite,MYIE1) + jte=min(jte,MYJE2) + DO J=jts,jte + DO I=its,ite + pbl_h(i,j)=grid%nmm_pblh(i,j) +! +! PDSL=PD(I,J)*RES(I,J) +!----------------------------------------------------------------------- +!*** LONG AND SHORTWAVE FLUX AT GROUND SURFACE +!----------------------------------------------------------------------- + IF(grid%nmm_CZMEAN(I,J)>0.) THEN + FACTRS(I,J)=grid%nmm_CZEN(I,J)/grid%nmm_CZMEAN(I,J) + ELSE + FACTRS(I,J)=0. + ENDIF + grid%GSW(I,J)=(grid%nmm_RSWIN(I,J)-grid%nmm_RSWOUT(I,J))*grid%nmm_HBM2(I,J)*FACTRS(I,J) + P8W(I,KTE+1,J)=grid%nmm_PT + grid%XLAT(I,J)=grid%nmm_GLAT(I,J)/DEGRAD + grid%XLONG(I,J)=grid%nmm_GLON(I,J)/DEGRAD + grid%XLAND(I,J)=grid%nmm_SM(I,J)+1. + grid%PSFC(i,j)=grid%nmm_PD(I,J)+grid%nmm_PDTOP+grid%nmm_PT + grid%UST(I,J)=grid%nmm_USTAR(I,J) + REXNSFC(I,J)=(grid%PSFC(i,j)*1.E-5)**CAPA + TSFC(I,J)=grid%nmm_THS(I,J)*REXNSFC(I,J) + grid%TSK(I,J)=TSFC(I,J) + + T8W(I,1,J)=TSFC(I,J) + P8W(I,KTS,J)=grid%nmm_ETA1(KTS)*grid%nmm_PDTOP+grid%nmm_ETA2(KTS)*grid%nmm_PDSL(i,j)+grid%nmm_PT +! +!----------------------------------------------------------------------- +!*** FILL THE SINGLE-COLUMN INPUT +!----------------------------------------------------------------------- +! + z_at_w(i,kts,j)=grid%nmm_fis(i,j)/g + DO K=KTS,KTE + vvel(i,k,j)=grid%nmm_w(i,k,j) + DPL=grid%nmm_DETA1(K)*grid%nmm_PDTOP+grid%nmm_DETA2(K)*grid%nmm_PDSL(i,j) + QL(K)=AMAX1(grid%nmm_Q(I,K,J),EPSQ) + PLYR=grid%nmm_AETA1(K)*grid%nmm_PDTOP+grid%nmm_AETA2(K)*grid%nmm_PDSL(i,j)+grid%nmm_PT + TL(K)=grid%nmm_T(I,K,J) +! +! here rri is inverse density! +! + RHO(I,K,J)=PLYR/(R_D*TL(K)*(1.+P608*QL(K))) + RRI(I,K,J)=1./RHO(i,k,j) + T_PHY(I,K,J)=TL(K) + moist(I,K,J,P_QV)=QL(K)/(1.-QL(K)) + P8W(I,K+1,J)=grid%nmm_ETA1(K+1)*grid%nmm_PDTOP+grid%nmm_ETA2(K+1)*grid%nmm_PDSL(i,j)+grid%nmm_PT + P_PHY(I,K,J)=PLYR + DZ8W(I,K,J)=TL(K)*(P608*QL(K)+1.)*R_D & + & *(P8W(I,K,J)-P8W(I,K+1,J)) & + & /(P_PHY(I,K,J)*G) + if(K.gt.kts)then + Z_AT_W(i,k,j)=Z_AT_W(I,k-1,j)+DZ8W(I,K-1,J) + ZMID(I,K-1,J)=.5*(Z_AT_W(I,K-1,J)+Z_AT_W(I,K,J)) + endif + + ENDDO +! + DO K=KTS+1,KTE + T8W(I,K,J)=0.5*(TL(K-1)+TL(K)) + ENDDO + T8W(I,KTE+1,J)=-1.E20 + ZMID(I,KTE,J)=Z_AT_W(I,KTE,J) +! + ENDDO + ENDDO +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS +! +!----------------------------------------------------------------------- +!$omp parallel do & +!$omp& private(i,j,k,rwmsk,wmsk) + DO J=MYJS1_P1,MYJE1_P1 +! + DO K=KTS,KTE + DO I=MYIS_P1,MYIE_P1 + WMSK=grid%nmm_VTM(I+grid%nmm_IHE(J),K,J)+grid%nmm_VTM(I+grid%nmm_IHW(J),K,J) & + & +grid%nmm_VTM(I,K,J+1)+grid%nmm_VTM(I,K,J-1) + IF(WMSK>0.)THEN + RWMSK=1./WMSK + U_PHY(I,K,J)=(grid%nmm_U(I+grid%nmm_IHE(J),K,J)*grid%nmm_VTM(I+grid%nmm_IHE(J),K,J) & + & +grid%nmm_U(I+grid%nmm_IHW(J),K,J)*grid%nmm_VTM(I+grid%nmm_IHW(J),K,J) & + & +grid%nmm_U(I,K,J+1)*grid%nmm_VTM(I,K,J+1) & + & +grid%nmm_U(I,K,J-1)*grid%nmm_VTM(I,K,J-1))*RWMSK + V_PHY(I,K,J)=(grid%nmm_V(I+grid%nmm_IHE(J),K,J)*grid%nmm_VTM(I+grid%nmm_IHE(J),K,J) & + & +grid%nmm_V(I+grid%nmm_IHW(J),K,J)*grid%nmm_VTM(I+grid%nmm_IHW(J),K,J) & + & +grid%nmm_V(I,K,J+1)*grid%nmm_VTM(I,K,J+1) & + & +grid%nmm_V(I,K,J-1)*grid%nmm_VTM(I,K,J-1))*RWMSK + ELSE + U_PHY(I,K,J)=0. + V_PHY(I,K,J)=0. + ENDIF + ENDDO + ENDDO + ENDDO + + + +#endif + + do nv=1,num_chem + do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + chem(i,k,j,nv)=max(chem(i,k,j,nv),chem_minval) + enddo + enddo + enddo + enddo + select case (config_flags%chem_opt) + case (RADM2SORG, RADM2SORG_KPP,RACMSORG,RACMSORG_KPP) + do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + if(chem(i,k,j,p_nu0).lt.1.e07) then + chem(i,k,j,p_nu0)=1.e7 + endif + enddo + enddo + enddo + end select + + + vdrog3=0. +#if ( EM_CORE == 1 ) + do j=jps,min(jde-1,jpe) + do k=kps,kpe + do i=ips,min(ide-1,ipe) + rri(i,k,j)=grid%em_alt(i,k,j) + vvel(i,k,j)=grid%em_w_2(i,k,j) + zmid(i,k,j)=grid%em_z(i,k,j) + enddo + enddo + enddo + do j=jps,min(jde-1,jpe) + do i=ips,min(ide-1,ipe) + pbl_h(i,j)=grid%pblh(i,j) + enddo + enddo + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, its, ite, jts, jte ) + chem_tile_loop_1: DO ij = 1 , grid%num_tiles + its = max(grid%i_start(ij),ids+1) + ite = min(grid%i_end(ij),ide-2) + jts = max(grid%j_start(ij),jds+1) + jte = min(grid%j_end(ij),jde-2) + kts=k_start + kte=k_end +#endif +! +! no time average available in first half hour +! + if( config_flags%chem_conv_tr>0)then + if(ktau.le.stepave)then + do j=jts,jte + do i=its,ite + grid%raincv_b(i,j)=grid%raincv(i,j) + enddo + enddo + endif +! +! build time average, and stored in raincv_b to be used by convective transport routine +! + if(mod(ktau,stepave).ne.0)then + do j=jts,jte + do i=its,ite + grid%raincv_a(i,j)=grid%raincv_a(i,j)+grid%raincv(i,j) + enddo + enddo + else if(mod(ktau,stepave).eq.0)then + do j=jts,jte + do i=its,ite + grid%raincv_b(i,j)=grid%raincv_a(i,j)/float(stepave) + grid%raincv_a(i,j)=0. + enddo + enddo + endif + endif ! chem_conv_tr +! +! do the same for convwective parameterization cloud water mix ratio, +! currently only for cu_physics=3, used by both photolysis and atmospheric radiation +! + if( config_flags%cu_physics == 3 )then + if(ktau.le.stepave)then + do j=jts,jte + do k=kts,kte + do i=its,ite + grid%gd_cloud_b(i,k,j)=grid%gd_cloud(i,k,j) + grid%gd_cloud2_b(i,k,j)=grid%gd_cloud2(i,k,j) + enddo + enddo + enddo + endif ! stepave +! +! +! + if(mod(ktau,stepave).ne.0)then + do j=jts,jte + do k=kts,kte + do i=its,ite + grid%gd_cloud_a(i,k,j)=grid%gd_cloud_a(i,k,j)+grid%gd_cloud(i,k,j) + grid%gd_cloud2_a(i,k,j)=grid%gd_cloud2_a(i,k,j)+grid%gd_cloud2(i,k,j) + enddo + enddo + enddo + else if(mod(ktau,stepave).eq.0)then + do j=jts,jte + do k=kts,kte + do i=its,ite + grid%gd_cloud_b(i,k,j)=grid%gd_cloud_a(i,k,j)/float(stepave) + grid%gd_cloud_a(i,k,j)=0. + grid%gd_cloud2_b(i,k,j)=grid%gd_cloud2_a(i,k,j)/float(stepave) + grid%gd_cloud2_a(i,k,j)=0. + enddo + enddo + enddo + endif !stepave + endif ! cu_physics +! +! +#if ( EM_CORE == 1 ) + CALL wrf_debug ( 15 , ' call chem_prep' ) + CALL chem_prep ( config_flags, & + grid%em_u_2, grid%em_v_2, grid%em_p, grid%em_pb, & + grid%em_alt,grid%em_ph_2, grid%em_phb, grid%em_t_2, & + moist, num_3d_m, rho, & + p_phy, u_phy, v_phy, & + p8w, t_phy, t8w, grid%em_z, z_at_w, & + dz8w, grid%em_fnm, grid%em_fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its,ite,jts,jte, & + k_start, k_end ) +#endif + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,"calling chem_dbg at top of chem_driver") + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit ) + end if +#endif + +!--- emissions + if(config_flags%emiss_inpt_opt > 0)then + call wrf_debug(15,'calling emissions driver') + call emissions_driver(grid%id,ktau,grid%dt,grid%DX, & + config_flags, grid%stepbioe, & + grid%gmt,grid%julday,rri,t_phy,moist,p8w,t8w, & + grid%e_bio,p_phy,chem,rho,dz8w,grid%ne_area, & + grid%e_iso,grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3, & + grid%e_hc5,grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_pm25,grid%e_pm10,grid%e_nh3, & + grid%e_pm25i,grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi, & + grid%e_orgj,grid%e_no2,grid%e_ch3oh, & + grid%e_c2h5oh,grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c, & + grid%e_orgc,grid%e_ecc, & + grid%u10,grid%v10,grid%ivgtyp,grid%gsw,grid%vegfra,grid%rmol, & + grid%ust,grid%znt, & + grid%xland,grid%xlat,grid%xlong, & + z_at_w, & + grid%sebio_iso,grid%sebio_oli,grid%sebio_api,grid%sebio_lim, & + grid%sebio_xyl,grid%sebio_hc3,grid%sebio_ete,grid%sebio_olt, & + grid%sebio_ket,grid%sebio_ald,grid%sebio_hcho,grid%sebio_eth, & + grid%sebio_ora2,grid%sebio_co,grid%sebio_nr, & + grid%noag_grow,grid%noag_nongrow,grid%nononag,grid%slai, & + grid%ebio_iso,grid%ebio_oli,grid%ebio_api,grid%ebio_lim,grid%ebio_xyl, & + grid%ebio_hc3,grid%ebio_ete,grid%ebio_olt,grid%ebio_ket,grid%ebio_ald, & + grid%ebio_hcho,grid%ebio_eth,grid%ebio_ora2,grid%ebio_co,grid%ebio_nr, & + grid%ebio_no,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,'calling chem_dbg after emissions_driver') + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit ) + end if +#endif + endif + +! +! calculate photolysis rates +!o +! print *,'stepphot = ',grid%stepphot + if((ktau.eq.1 .or. mod(ktau,grid%stepphot).eq.0) & + .and. config_flags%chem_opt /= CHEM_TRACER) then + call wrf_debug(15,'calling photolysis driver') + call photolysis_driver (grid%id,ktau,grid%dt,config_flags,haveaer, & + grid%gmt,grid%julday,t_phy,moist,grid%aerwrf,p8w,t8w,p_phy, & + chem,rho,dz8w,grid%xlat,grid%xlong, & + z_at_w, & + grid%gd_cloud_b,grid%gd_cloud2_b, & + grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & + grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & + grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & + grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho, & + grid%ph_hcochest,grid%ph_ch3o2h,grid%ph_ch3coo2h,grid%ph_ch3ono2, & + grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2, & + grid%tauaer1,grid%tauaer2,grid%tauaer3,grid%tauaer4, & + grid%gaer1,grid%gaer2,grid%gaer3,grid%gaer4, & + grid%waer1,grid%waer2,grid%waer3,grid%waer4, & + grid%pm2_5_dry,grid%pm2_5_water,grid%uvrad, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,'calling chem_dbg after photolysis_driver') + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit, & + grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & + grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & + grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & + grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho, & + grid%ph_hcochest,grid%ph_ch3o2h,grid%ph_ch3coo2h, & + grid%ph_ch3ono2,grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2 & + ) + end if +#endif + endif +! +! do vertical mixing with dry deposition +! 28-jun-2005 rce - added vertmix_onoff to turn vertical mixing on/off +! + if (config_flags%vertmix_onoff>0) then + if (ktau.gt.2) then + call wrf_debug(15,'calling dry_deposition_driver') + call dry_dep_driver(grid%id,ktau,grid%dt,config_flags, & + grid%gmt,grid%julday,t_phy,moist,scalar,p8w,t8w,vvel, & + rri,p_phy,chem,rho,dz8w,grid%exch_h, & + grid%cldfra, grid%cldfra_old, & + grid%ccn1, grid%ccn2, grid%ccn3, grid%ccn4, grid%ccn5, grid%ccn6, & + grid%qndropsource,grid%ivgtyp,grid%tsk,grid%gsw,grid%vegfra,pbl_h, & + grid%rmol,grid%ust,grid%znt,grid%xlat,grid%xlong, & + zmid,z_at_w, & + grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3,grid%asulf, & + grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2,grid%cvalk1,grid%cvole1,& + grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,grid%dep_vel_o3, & + grid%e_co,config_flags%kemit,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) +! k_start , min(k_end,kde-ksubt) ) + end if + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,'calling chem_dbg after dry_deposition_driver') + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit, & + ) + end if +#endif + end if + + +! +! convective transport/wet deposition +! +! +! + if( config_flags%cu_physics>0 .and. config_flags%chem_conv_tr>0)then + call wrf_debug(15,'calling conv transport') + call grelldrvct(grid%DT,ktau,grid%DX,grid%id,config_flags, & + rho,grid%RAINCV_B,chem, & + U_phy,V_phy,t_phy,moist,dz8w, & + p_phy,XLV,CP,G,r_v, & + z_at_w, & + grid%cu_co_ten, & + num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) +! k_start , min(k_end,kde-1) ) + end if +! +! +! +! +n2o5_het=0. +! Calculate rate of n2o5 hydrolysis + call wrf_debug(15,'calling calc_het_n2o5') + + + +! +! For the chemistry tracer mode, only emissions and vertical mixing are done. +! So, finish any remaining tiles and then skip to the end of chem_driver. +! + kts=k_start + kte=k_end + if((ktau.eq.1.or.mod(ktau,grid%stepchem).eq.0) & + .and. config_flags%chem_opt /= CHEM_TRACER) then + dtstepc=grid%dt*float(grid%stepchem) + ktauc=max(ktau/grid%stepchem,1) + if(ktau.eq.1)dtstepc=grid%dt + if(config_flags%gaschem_onoff>0)then +! +! chemical mechanisms +! + call mechanism_driver(grid%id,ktau,grid%dt,ktauc,dtstepc,config_flags, & + grid%gmt,grid%julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho,dz8w, & + zmid,z_at_w, & + vdrog3,vcsulf_old, & + grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & + grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & + grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & + grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho,grid%ph_hcochest, & + grid%ph_ch3o2h,grid%ph_ch3coo2h,grid%ph_ch3ono2,grid%ph_hcochob, & + grid%ph_n2o5,grid%ph_o2,grid%addt,grid%addx,grid%addc,grid%etep, & + grid%oltp,grid%olip,grid%cslp,grid%limp,grid%hc5p,grid%hc8p,grid%tolp, & + grid%xylp,grid%apip,grid%isop,grid%hc3p,grid%ethp,grid%o3p,grid%tco3, & + grid%mo2,grid%o1d,grid%olnn,grid%rpho,grid%xo2, & + grid%ketp,grid%olnd, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte ) + + +!cms++ +! + + +#ifdef WRF_KPP + CALL wrf_debug(15,'calling kpp_mechanism_driver') + + +CALL kpp_mechanism_driver (chem, & + grid%id,dtstepc,config_flags, & + p_phy,t_phy,rho,moist, & + vdrog3, ldrog, & + n2o5_het, & +! +#include +! + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) +! k_start , min(k_end,kde-ksubt) ) + + +!cms-- +! +#endif +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,'calling chem_dbg after mechanism_driver') + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit, & + grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & + grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & + grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & + grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho, & + grid%ph_hcochest,grid%ph_ch3o2h,grid%ph_ch3coo2h, & + grid%ph_ch3ono2,grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2 & + ) + end if +#endif + endif + + + +! allocate gas_aqfrac if either cldchem or wetscav is on + if ( (config_flags%cldchem_onoff > 0) .or. & + (config_flags%wetscav_onoff > 0) ) then + numgas_aqfrac = max( numgas, 1 ) + allocate( gas_aqfrac( grid%sm31:grid%em31, grid%sm32:grid%em32, & + grid%sm33:grid%em33, numgas_aqfrac ) ) + gas_aqfrac(:,:,:,:) = 0.0 + end if + +! +! now do cloud chemistry +! + if (config_flags%cldchem_onoff > 0) then + + call cloudchem_driver( & + grid%id, ktau, ktauc, grid%dt, dtstepc, config_flags, & + t_phy, p_phy, rho, rri, & + moist, grid%cldfra, grid%ph_no2, & + chem, gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + endif + + +! +! now do aerosols +! + if(config_flags%aerchem_onoff>0)then + call aerosols_driver (grid%id,ktau,grid%dt,ktauc,config_flags,dtstepc, & + rri,t_phy,moist,grid%aerwrf,p8w,t8w, & + p_phy,chem,rho,dz8w, & + zmid,z_at_w, & + grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3,grid%asulf, & + grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2,grid%cvalk1,grid%cvole1, & + grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,vcsulf_old, & + grid%e_pm25i,grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi, & + grid%e_orgj,grid%e_pm10,grid%e_so4i,grid%e_so4j,grid%e_no3i,grid%e_no3j,& + vdrog3, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,kte) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & + (jts <= CHEM_DBG_J .and. jte >= CHEM_DBG_J) .and. & + (k_start <= CHEM_DBG_K .and. k_end >= CHEM_DBG_K) ) then + call wrf_debug(15,'calling chem_dbg after aerosols_driver') + call chem_dbg(CHEM_DBG_I,CHEM_DBG_J,CHEM_DBG_K,grid%dt,ktau, & + dz8w,t_phy,p_phy,rho,chem, & + grid%e_so2,grid%e_no,grid%e_co,grid%e_eth,grid%e_hc3,grid%e_hc5, & + grid%e_hc8,grid%e_xyl,grid%e_ol2,grid%e_olt, & + grid%e_oli,grid%e_tol,grid%e_csl,grid%e_hcho,grid%e_ald,grid%e_ket, & + grid%e_ora2,grid%e_nh3,grid%e_pm10,grid%e_pm25,grid%e_pm25i, & + grid%e_pm25j,grid%e_eci,grid%e_ecj,grid%e_orgi,grid%e_orgj, & + grid%e_no2,grid%e_ch3oh,grid%e_c2h5oh,grid%e_iso, & + grid%e_so4j,grid%e_so4c,grid%e_no3j,grid%e_no3c,grid%e_orgc,grid%e_ecc,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end, & + config_flags%kemit, + grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & + grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & + grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & + grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho, & + grid%ph_hcochest,grid%ph_ch3o2h,grid%ph_ch3coo2h, & + grid%ph_ch3ono2,grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2 & + ) + end if +#endif + endif + + +! +! now do wet removal +! + if (config_flags%wetscav_onoff > 0) then + call wetscav_driver (grid%id,ktau,grid%dt,ktauc,config_flags,dtstepc, & + rri,t_phy,moist,p8w,t8w, & + p_phy,chem,rho,grid%cldfra, & + grid%qlsink,grid%precr,grid%preci,grid%precs,grid%precg, & + gas_aqfrac, numgas_aqfrac, & + grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3, & + grid%asulf,grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2, & + grid%cvalk1,grid%cvole1,grid%cvapi1,grid%cvapi2, & + grid%cvlim1,grid%cvlim2, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + grid%i_start(ij), min(grid%i_end(ij),ide-1), & + grid%j_start(ij), min(grid%j_end(ij),jde-1), & + k_start , min(k_end,kde-ksubt) ) + + endif + + if (numgas_aqfrac > 0) then + deallocate( gas_aqfrac ) + numgas_aqfrac = 0 + end if + +end if !Chemistry time step check +! +! Sum up the aerosol mass for radiation and diagnostic purposes. Unlike +! aerosol_driver, which is called every dtchem, this must be done every +! time step because of emissions and deposition. +! + call sum_pm_driver ( config_flags, & + rri, chem, grid%h2oaj, grid%h2oai, & + grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, k_start,k_end ) + +! Fill top level to prevent spurious interpolation results (no extrapolation) +! should this be done on halo too???? + do nv=1,num_chem + do j=jts,jte + do i=its,ite + chem(i,kte,j,nv)=chem(i,kte-1,j,nv) + enddo + enddo + enddo + call wrf_debug(15,'done tileloop in chem_driver') +# if ( EM_CORE == 1 ) + END DO chem_tile_loop_1 +#endif + + + END subroutine chem_driver diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F new file mode 100755 index 00000000..9635f4ee --- /dev/null +++ b/wrfv2_fire/chem/chemics_init.F @@ -0,0 +1,942 @@ +!WRF:MODEL_LAYER:INITIALIZATION +! + subroutine chem_init (id,chem,dt,bioemdt,photdt,chemdt,stepbioe, & + stepphot,stepchem,z_at_w,g,aerwrf,config_flags, & + alt,t,p,CONVFAC, & + gd_cloud, gd_cloud2, & + gd_cloud_b, gd_cloud2_b, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec,chem_in_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! IMPLICIT NONE + USE module_domain + USE module_configure + USE module_state_description + USE module_phot_mad + USE module_aerosols_sorgam + USE module_dep_simple + USE module_cbmz_initmixrats, only: cbmz_init_wrf_mixrats + USE module_mosaic_driver, only: init_data_mosaic_asect + USE module_mosaic_initmixrats, only: mosaic_init_wrf_mixrats + USE module_input_chem_data, only: get_last_gas, gasprofile_init_pnnl + + real , intent(in) :: bioemdt,photdt,chemdt,dt + INTEGER, INTENT(IN ) :: chem_in_opt + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gd_cloud, gd_cloud2, & + gd_cloud_b, gd_cloud2_b, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4 + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + z_at_w,t,p,alt,convfac + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , & + INTENT(INOUT ) :: & + chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + aerwrf + real, INTENT (IN) :: g + integer, intent(out) :: stepbioe,stepphot,stepchem + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags +! +! local stuff +! + integer :: i,j,k,l,numgas + +#ifdef CHEM_DBG_I + call print_chem_species_index( config_flags%chem_opt ) +#endif + +call wrf_message("*********************************************************************") +call wrf_message("* PROGRAM: WRF/CHEM VERSION 2.2 *") +call wrf_message("* *") +call wrf_message("* PLEASE REPORT ANY BUGS TO WRF/CHEM HELP at *") +call wrf_message("* *") +call wrf_message("* wrfchemhelp.gsd@noaa.gov *") +call wrf_message("* *") +call wrf_message("*********************************************************************") + + numgas = get_last_gas(config_flags%chem_opt) + +if ( config_flags%chem_opt == 9 .or. config_flags%chem_opt == 10 ) then +call wrf_message("*********************************************************************") +call wrf_message("* WARNING: THE COMBINATION OF progn=1 AND chem_opt=9 or 10 IS *") +call wrf_message("* CONSIDERED BETA CODE THAT IS STILL IN DEVELOPMENT. THE *") +call wrf_message("* RESULTS APPEAR REASONABLE, BUT SMALL DIFFERENCES WILL *") +call wrf_message("* ARRISE WHEN CHANGING THE NUMBER OF PROCESSORS. ALSO, *") +call wrf_message("* OPTION ASSOCIATED WITH CLOUD-AEROSOL INTERACTIONS AND *") +call wrf_message("* AQUEOUS CHEMISTRY USING MOSAIC HAVE NOT BEEN TESTED ON A *") +call wrf_message("* WIDE RANGE OF COMPUTER ARCHITECTURES. USERS THAT CHOOSE *") +call wrf_message("* THSE OPTIONS ARE ASKED TO REPORT ANY BUGS THAT APPEAR TO *") +call wrf_message("* BE ASSOCIATED WITH CLOUD-AEROSOL INTERACTION MODULES TO *") +call wrf_message("* jerome.fast@pnl.gov and wrfchemhelp.gsd@noaa.gov *") +call wrf_message("*********************************************************************") +endif +#if ( NMM_CORE == 1 ) +call wrf_message("*********************************************************************") +call wrf_message("* WARNING: THE USE OF THE NMM WITH CHEMISTRY IS *") +call wrf_message("* CONSIDERED BETA CODE THAT IS STILL IN DEVELOPMENT. *") +call wrf_message("* PLEASE REPORT ANY BUGS TO wrfchemhelp.gsd@noaa.gov *") +call wrf_message("*********************************************************************") +#endif + + IF ( config_flags%chem_opt == 0 .AND. config_flags%aer_ra_feedback .NE. 0 ) THEN +! config_flags%aer_ra_feedback = 0 + call wrf_error_fatal(" ERROR: CHEM_INIT: FOR CHEM_OPT = 0, AER_RA_FEEDBACK MUST = 0 ") + ENDIF + + if( .NOT. config_flags%restart ) then + do j=jts,jte + do k=kts,kte + do i=its,ite + tauaer1(i,k,j) = 0. + tauaer2(i,k,j) = 0. + tauaer3(i,k,j) = 0. + tauaer4(i,k,j) = 0. + gaer1(i,k,j) = 0. + gaer2(i,k,j) = 0. + gaer3(i,k,j) = 0. + gaer4(i,k,j) = 0. + waer1(i,k,j) = 0. + waer2(i,k,j) = 0. + waer3(i,k,j) = 0. + waer4(i,k,j) = 0. + end do + end do + end do + end if + do j=jts,jte + do k=kts,kte + do i=its,ite + gd_cloud(i,k,j) = 0. + gd_cloud2(i,k,j) = 0. + gd_cloud_b(i,k,j) = 0. + gd_cloud2_b(i,k,j) = 0. + end do + end do + end do + +! RETURN IF CHEMISTRY IS NOT RUNNING + IF ( config_flags%chem_opt == 0 ) RETURN + + stepbioe=nint(bioemdt*60./dt) + stepphot=nint(photdt*60./dt) + stepchem=nint(chemdt*60./dt) + stepbioe=max(stepbioe,1) + stepphot=max(stepphot,1) + stepchem=max(stepchem,1) + call wrf_debug( 15, 'in chem_init' ) +! print *,'stepbioe,stepphot,stepchem',stepbioe,stepphot,stepchem + +! +! An alternative ozone profile option +! + if ( (config_flags%gas_bc_opt == GAS_BC_PNNL) .or. & + (config_flags%gas_ic_opt == GAS_IC_PNNL) ) then + call gasprofile_init_pnnl + end if +! +! we are doing initialization here, first photolysis +! + phot_select: SELECT CASE(config_flags%phot_opt) + CASE (PHOTMAD) + CALL wrf_debug(00,'call madronich phot initialization') + call photmad_init(z_at_w,aerwrf,g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + END SELECT phot_select +! +! initialization for aerosols +! + +! Technically, we are doing a no-no here. The array is_aerosol is being +! "re-allocated" and overwritten by each domain. Therefore, if different +! chemistry settings are used for each nest level, we will get errors. I +! have a feeling that this is not the only place that will have a problem +! though so I am not worrying about it for now. The dilemma is that we +! cannot declare and allocate is_aerosol via the registry because the +! number of aerosols is not known at compile time. I have not figured out +! a way to allocate a separate array for each nest outside of the +! regiistry. For now, we will do a simple check to trap a change in the +! desired size of num_chem and assume that if the size is the same, the +! species will be too. wig, 24-Oct-2005 + if( .not.allocated(is_aerosol) ) then + allocate (is_aerosol(num_chem)) + else + if( size(is_aerosol) /= num_chem ) & + call wrf_error_fatal("The number of chemistry species has changed between nests. Are you trying to mix chem_opt settings between nests? Shame on you!") + end if + + kpp_select: SELECT CASE(config_flags%chem_opt) + CASE (RACM_KPP,RACMSORG_KPP, RACM_MIM_KPP) + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_co2)=370. + chem(i,k,j,p_ch4)=1.7 + chem(i,k,j,p_ete)=chem(i,k,j,p_olt) + chem(i,k,j,p_ete)=epsilc + chem(i,k,j,p_udd)=chem(i,k,j,p_ete) + chem(i,k,j,p_hket)=chem(i,k,j,p_ete) + chem(i,k,j,p_api)=chem(i,k,j,p_ete) + chem(i,k,j,p_lim)=chem(i,k,j,p_ete) + chem(i,k,j,p_dien)=chem(i,k,j,p_ete) + chem(i,k,j,p_macr)=chem(i,k,j,p_ete) + enddo + enddo + enddo + END SELECT kpp_select + aer_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG, RADM2SORG_AQ, RACMSORG_AQ, RADM2SORG_KPP, RACMSORG,RACMSORG_KPP) + CALL wrf_debug(15,'call MADE/SORGAM aerosols initialization') + + call aerosols_sorgam_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + chem_in_opt,config_flags%aer_ic_opt,is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!...Convert aerosols to mixing ratio + if(config_flags%chem_in_opt == 0 )then + do l=p_so4aj,num_chem + do j=jts,jte + do k=kts,kte + kk = min(k,kte-1) + do i=its,ite + chem(i,k,j,l)=chem(i,kk,j,l)*alt(i,kk,j) + enddo + enddo + enddo + enddo + endif + chem=max(chem,epsilc) + + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + call wrf_debug(15,'call MOSAIC aerosols initialization') + call init_data_mosaic_asect(is_aerosol) + if( .NOT. config_flags%restart ) & + call mosaic_init_wrf_mixrats( & + 0, config_flags, & + chem, alt, z_at_w, g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + END SELECT aer_select + + aer_sanity_check : SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG_AQ, RACMSORG_AQ, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + if( config_flags%progn == 0 ) & + call wrf_error_fatal("ERROR: When using aqueous chemistry, progn must be set to 1.") + END SELECT aer_sanity_check + + do nv=1,num_chem + do j=jms,jme + do i=ims,ime + chem(i,kde,j,nv)=chem(i,kde-1,j,nv) + enddo + enddo + enddo + +! +! initialization for wesely (gas) dry deposition +! + drydep_select: SELECT CASE(config_flags%drydep_opt) + CASE (WESELY) + CALL wrf_debug(15,'initializing dry dep (wesely)') + call dep_init(id,config_flags,numgas) + + END SELECT drydep_select +! +! initialization for cbmz gas-phase chemistry +! + cbmz_select: SELECT CASE(config_flags%chem_opt) + CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'initializing cbmz gas-phase chemistry') + if( .NOT. config_flags%restart ) & + call cbmz_init_wrf_mixrats(config_flags, & + z_at_w, g, & + chem, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + END SELECT cbmz_select + + END SUBROUTINE chem_init + +!----------------------------------------------------------------------- +#ifdef CHEM_DBG_I +subroutine print_chem_species_index( chem_opt ) + use module_state_description + implicit none + + integer, intent(in) :: chem_opt + + print*,'Index numbers for chemistry species:' +! +! Gas species... +! + select case (chem_opt) + case (RADM2, RADM2SORG, RADM2SORG_AQ, RADM2_KPP, RADM2SORG_KPP) + print*,p_so2,"so2" + print*,p_sulf,"sulf" + print*,p_no2,"no2" + print*,p_no,"no" + print*,p_o3,"o3" + print*,p_hno3,"hno3" + print*,p_h2o2,"h2o2" + print*,p_ald,"ald" + print*,p_hcho,"hcho" + print*,p_op1,"op1" + print*,p_op2,"op2" + print*,p_paa,"paa" + print*,p_ora1,"ora1" + print*,p_ora2,"ora2" + print*,p_nh3,"nh3" + print*,p_n2o5,"n2o5" + print*,p_no3,"no3" + print*,p_pan,"pan" + print*,p_hc3,"hc3" + print*,p_hc5,"hc5" + print*,p_hc8,"hc8" + print*,p_eth,"eth" + print*,p_co,"co" + print*,p_ol2,"ol2" + print*,p_olt,"olt" + print*,p_oli,"oli" + print*,p_tol,"tol" + print*,p_xyl,"xyl" + print*,p_aco3,"aco3" + print*,p_tpan,"tpan" + print*,p_hono,"hono" + print*,p_hno4,"hno4" + print*,p_ket,"ket" + print*,p_gly,"gly" + print*,p_mgly,"mgly" + print*,p_dcb,"dcb" + print*,p_onit,"onit" + print*,p_csl,"csl" + print*,p_iso,"iso" + print*,p_ho,"ho" + print*,p_ho2,"ho2" + case (RACM, RACMSORG, RACMSORG_AQ, RACM_KPP, RACMSORG_KPP) + print*,p_so2,"so2" + print*,p_sulf,"sulf" + print*,p_no2,"no2" + print*,p_no,"no" + print*,p_o3,"o3" + print*,p_hno3,"hno3" + print*,p_h2o2,"h2o2" + print*,p_ald,"ald" + print*,p_hcho,"hcho" + print*,p_op1,"op1" + print*,p_op2,"op2" + print*,p_paa,"paa" + print*,p_ora1,"ora1" + print*,p_ora2,"ora2" + print*,p_nh3,"nh3" + print*,p_n2o5,"n2o5" + print*,p_no3,"no3" + print*,p_pan,"pan" + print*,p_hc3,"hc3" + print*,p_hc5,"hc5" + print*,p_hc8,"hc8" + print*,p_eth,"eth" + print*,p_co,"co" + print*,p_ete,"ete" + print*,p_olt,"olt" + print*,p_oli,"oli" + print*,p_tol,"tol" + print*,p_xyl,"xyl" + print*,p_aco3,"aco3" + print*,p_tpan,"tpan" + print*,p_hono,"hono" + print*,p_hno4,"hno4" + print*,p_ket,"ket" + print*,p_gly,"gly" + print*,p_mgly,"mgly" + print*,p_dcb,"dcb" + print*,p_onit,"onit" + print*,p_csl,"csl" + print*,p_iso,"iso" + print*,p_co2,"co2" + print*,p_ch4,"ch4" + print*,p_udd,"udd" + print*,p_hket,"hket" + print*,p_api,"api" + print*,p_lim,"lim" + print*,p_dien,"dien" + print*,p_macr,"macr" + print*,p_ho,"ho" + print*,p_ho2,"ho2" + case (CBMZ) + print*,p_so2,"so2" + print*,p_sulf,"sulf" + print*,p_no2,"no2" + print*,p_no,"no" + print*,p_o3,"o3" + print*,p_hno3,"hno3" + print*,p_h2o2,"h2o2" + print*,p_ald,"ald" + print*,p_hcho,"hcho" + print*,p_op1,"op1" + print*,p_op2,"op2" + print*,p_paa,"paa" + print*,p_ora1,"ora1" + print*,p_ora2,"ora2" + print*,p_nh3,"nh3" + print*,p_n2o5,"n2o5" + print*,p_no3,"no3" + print*,p_pan,"pan" + print*,p_hc3,"hc3" + print*,p_hc5,"hc5" + print*,p_hc8,"hc8" + print*,p_eth,"eth" + print*,p_co,"co" + print*,p_ol2,"ol2" + print*,p_olt,"olt" + print*,p_oli,"oli" + print*,p_tol,"tol" + print*,p_xyl,"xyl" + print*,p_aco3,"aco3" + print*,p_tpan,"tpan" + print*,p_hono,"hono" + print*,p_hno4,"hno4" + print*,p_ket,"ket" + print*,p_gly,"gly" + print*,p_mgly,"mgly" + print*,p_dcb,"dcb" + print*,p_onit,"onit" + print*,p_csl,"csl" + print*,p_iso,"iso" + print*,p_ho,"ho" + print*,p_ho2,"ho2" + print*,p_hcl,"hcl" + print*,p_ch3o2,"ch3o2" + print*,p_ethp,"ethp" + print*,p_ch3oh,"ch3oh" + print*,p_c2h5oh,"c2h5oh" + print*,p_par,"par" + print*,p_to2,"to2" + print*,p_cro,"cro" + print*,p_open,"open" + print*,p_op3,"op3" + print*,p_c2o3,"c2o3" + print*,p_ro2,"ro2" + print*,p_ano2,"ano2" + print*,p_nap,"nap" + print*,p_xo2,"xo2" + print*,p_xpar,"xpar" + print*,p_isoprd,"isoprd" + print*,p_isopp,"isopp" + print*,p_isopn,"isopn" + print*,p_isopo2,"isopo2" + print*,p_dms,"dms" + print*,p_msa,"msa" + print*,p_dmso,"dmso" + print*,p_dmso2,"dmso2" + print*,p_ch3so2h,"ch3so2h" + print*,p_ch3sch2oo,"ch3sch2oo" + print*,p_ch3so2,"ch3so2" + print*,p_ch3so3,"ch3so3" + print*,p_ch3so2oo,"ch3so2oo" + print*,p_ch3so2ch2oo,"ch3so2ch2oo" + print*,p_mtf,"mtf" + case (CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + print*,p_so2,"so2" + print*,p_sulf,"sulf" + print*,p_no2,"no2" + print*,p_no,"no" + print*,p_o3,"o3" + print*,p_hno3,"hno3" + print*,p_h2o2,"h2o2" + print*,p_ald,"ald" + print*,p_hcho,"hcho" + print*,p_op1,"op1" + print*,p_op2,"op2" + print*,p_paa,"paa" + print*,p_ora1,"ora1" + print*,p_ora2,"ora2" + print*,p_nh3,"nh3" + print*,p_n2o5,"n2o5" + print*,p_no3,"no3" + print*,p_pan,"pan" + print*,p_hc3,"hc3" + print*,p_hc5,"hc5" + print*,p_hc8,"hc8" + print*,p_eth,"eth" + print*,p_co,"co" + print*,p_ol2,"ol2" + print*,p_olt,"olt" + print*,p_oli,"oli" + print*,p_tol,"tol" + print*,p_xyl,"xyl" + print*,p_aco3,"aco3" + print*,p_tpan,"tpan" + print*,p_hono,"hono" + print*,p_hno4,"hno4" + print*,p_ket,"ket" + print*,p_gly,"gly" + print*,p_mgly,"mgly" + print*,p_dcb,"dcb" + print*,p_onit,"onit" + print*,p_csl,"csl" + print*,p_iso,"iso" + print*,p_ho,"ho" + print*,p_ho2,"ho2" + print*,p_hcl,"hcl" + print*,p_ch3o2,"ch3o2" + print*,p_ethp,"ethp" + print*,p_ch3oh,"ch3oh" + print*,p_c2h5oh,"c2h5oh" + print*,p_par,"par" + print*,p_to2,"to2" + print*,p_cro,"cro" + print*,p_open,"open" + print*,p_op3,"op3" + print*,p_c2o3,"c2o3" + print*,p_ro2,"ro2" + print*,p_ano2,"ano2" + print*,p_nap,"nap" + print*,p_xo2,"xo2" + print*,p_xpar,"xpar" + print*,p_isoprd,"isoprd" + print*,p_isopp,"isopp" + print*,p_isopn,"isopn" + print*,p_isopo2,"isopo2" + end select +! +! Aerosol species... +! + select case (chem_opt) + case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_KPP, RACMSORG, RACMSORG_AQ, RACMSORG_KPP) + print*,p_so4aj,"so4aj" + print*,p_so4ai,"so4ai" + print*,p_nh4aj,"nh4aj" + print*,p_nh4ai,"nh4ai" + print*,p_no3aj,"no3aj" + print*,p_no3ai,"no3ai" + print*,p_orgaro1j,"orgaro1j" + print*,p_orgaro1i,"orgaro1i" + print*,p_orgaro2j,"orgaro2j" + print*,p_orgaro2i,"orgaro2i" + print*,p_orgalk1j,"orgalk1j" + print*,p_orgalk1i,"orgalk1i" + print*,p_orgole1j,"orgole1j" + print*,p_orgole1i,"orgole1i" + print*,p_orgba1j,"orgba1j" + print*,p_orgba1i,"orgba1i" + print*,p_orgba2j,"orgba2j" + print*,p_orgba2i,"orgba2i" + print*,p_orgba3j,"orgba3j" + print*,p_orgba3i,"orgba3i" + print*,p_orgba4j,"orgba4j" + print*,p_orgba4i,"orgba4i" + print*,p_orgpaj,"orgpaj" + print*,p_orgpai,"orgpai" + print*,p_ecj,"ecj" + print*,p_eci,"eci" + print*,p_p25j,"p25j" + print*,p_p25i,"p25i" + print*,p_antha,"antha" + print*,p_seas,"seas" + print*,p_soila,"soila" + print*,p_nu0,"nu0" + print*,p_ac0,"ac0" + print*,p_corn,"corn" + case (CBMZ_MOSAIC_4BIN) + print*,p_so4_a01,"so4_a01" + print*,p_no3_a01,"no3_a01" + print*,p_cl_a01,"cl_a01" + print*,p_nh4_a01,"nh4_a01" + print*,p_na_a01,"na_a01" + print*,p_oin_a01,"oin_a01" + print*,p_oc_a01,"oc_a01" + print*,p_bc_a01,"bc_a01" + print*,p_hysw_a01,"hysw_a01" + print*,p_water_a01,"water_a01" + print*,p_num_a01,"num_a01" + print*,p_so4_a02,"so4_a02" + print*,p_no3_a02,"no3_a02" + print*,p_cl_a02,"cl_a02" + print*,p_nh4_a02,"nh4_a02" + print*,p_na_a02,"na_a02" + print*,p_oin_a02,"oin_a02" + print*,p_oc_a02,"oc_a02" + print*,p_bc_a02,"bc_a02" + print*,p_hysw_a02,"hysw_a02" + print*,p_water_a02,"water_a02" + print*,p_num_a02,"num_a02" + print*,p_so4_a03,"so4_a03" + print*,p_no3_a03,"no3_a03" + print*,p_cl_a03,"cl_a03" + print*,p_nh4_a03,"nh4_a03" + print*,p_na_a03,"na_a03" + print*,p_oin_a03,"oin_a03" + print*,p_oc_a03,"oc_a03" + print*,p_bc_a03,"bc_a03" + print*,p_hysw_a03,"hysw_a03" + print*,p_water_a03,"water_a03" + print*,p_num_a03,"num_a03" + print*,p_so4_a04,"so4_a04" + print*,p_no3_a04,"no3_a04" + print*,p_cl_a04,"cl_a04" + print*,p_nh4_a04,"nh4_a04" + print*,p_na_a04,"na_a04" + print*,p_oin_a04,"oin_a04" + print*,p_oc_a04,"oc_a04" + print*,p_bc_a04,"bc_a04" + print*,p_hysw_a04,"hysw_a04" + print*,p_water_a04,"water_a04" + print*,p_num_a04,"num_a04" + case (CBMZ_MOSAIC_8BIN) + print*,p_so4_a01,"so4_a01" + print*,p_no3_a01,"no3_a01" + print*,p_cl_a01,"cl_a01" + print*,p_nh4_a01,"nh4_a01" + print*,p_na_a01,"na_a01" + print*,p_oin_a01,"oin_a01" + print*,p_oc_a01,"oc_a01" + print*,p_bc_a01,"bc_a01" + print*,p_hysw_a01,"hysw_a01" + print*,p_water_a01,"water_a01" + print*,p_num_a01,"num_a01" + print*,p_so4_a02,"so4_a02" + print*,p_no3_a02,"no3_a02" + print*,p_cl_a02,"cl_a02" + print*,p_nh4_a02,"nh4_a02" + print*,p_na_a02,"na_a02" + print*,p_oin_a02,"oin_a02" + print*,p_oc_a02,"oc_a02" + print*,p_bc_a02,"bc_a02" + print*,p_hysw_a02,"hysw_a02" + print*,p_water_a02,"water_a02" + print*,p_num_a02,"num_a02" + print*,p_so4_a03,"so4_a03" + print*,p_no3_a03,"no3_a03" + print*,p_cl_a03,"cl_a03" + print*,p_nh4_a03,"nh4_a03" + print*,p_na_a03,"na_a03" + print*,p_oin_a03,"oin_a03" + print*,p_oc_a03,"oc_a03" + print*,p_bc_a03,"bc_a03" + print*,p_hysw_a03,"hysw_a03" + print*,p_water_a03,"water_a03" + print*,p_num_a03,"num_a03" + print*,p_so4_a04,"so4_a04" + print*,p_no3_a04,"no3_a04" + print*,p_cl_a04,"cl_a04" + print*,p_nh4_a04,"nh4_a04" + print*,p_na_a04,"na_a04" + print*,p_oin_a04,"oin_a04" + print*,p_oc_a04,"oc_a04" + print*,p_bc_a04,"bc_a04" + print*,p_hysw_a04,"hysw_a04" + print*,p_water_a04,"water_a04" + print*,p_num_a04,"num_a04" + print*,p_so4_a05,"so4_a05" + print*,p_no3_a05,"no3_a05" + print*,p_cl_a05,"cl_a05" + print*,p_nh4_a05,"nh4_a05" + print*,p_na_a05,"na_a05" + print*,p_oin_a05,"oin_a05" + print*,p_oc_a05,"oc_a05" + print*,p_bc_a05,"bc_a05" + print*,p_hysw_a05,"hysw_a05" + print*,p_water_a05,"water_a05" + print*,p_num_a05,"num_a05" + print*,p_so4_a06,"so4_a06" + print*,p_no3_a06,"no3_a06" + print*,p_cl_a06,"cl_a06" + print*,p_nh4_a06,"nh4_a06" + print*,p_na_a06,"na_a06" + print*,p_oin_a06,"oin_a06" + print*,p_oc_a06,"oc_a06" + print*,p_bc_a06,"bc_a06" + print*,p_hysw_a06,"hysw_a06" + print*,p_water_a06,"water_a06" + print*,p_num_a06,"num_a06" + print*,p_so4_a07,"so4_a07" + print*,p_no3_a07,"no3_a07" + print*,p_cl_a07,"cl_a07" + print*,p_nh4_a07,"nh4_a07" + print*,p_na_a07,"na_a07" + print*,p_oin_a07,"oin_a07" + print*,p_oc_a07,"oc_a07" + print*,p_bc_a07,"bc_a07" + print*,p_hysw_a07,"hysw_a07" + print*,p_water_a07,"water_a07" + print*,p_num_a07,"num_a07" + print*,p_so4_a08,"so4_a08" + print*,p_no3_a08,"no3_a08" + print*,p_cl_a08,"cl_a08" + print*,p_nh4_a08,"nh4_a08" + print*,p_na_a08,"na_a08" + print*,p_oin_a08,"oin_a08" + print*,p_oc_a08,"oc_a08" + print*,p_bc_a08,"bc_a08" + print*,p_hysw_a08,"hysw_a08" + print*,p_water_a08,"water_a08" + print*,p_num_a08,"num_a08" + case (CBMZ_MOSAIC_4BIN_AQ) + print*,p_so4_a01,"so4_a01" + print*,p_no3_a01,"no3_a01" + print*,p_cl_a01,"cl_a01" + print*,p_nh4_a01,"nh4_a01" + print*,p_na_a01,"na_a01" + print*,p_oin_a01,"oin_a01" + print*,p_oc_a01,"oc_a01" + print*,p_bc_a01,"bc_a01" + print*,p_hysw_a01,"hysw_a01" + print*,p_water_a01,"water_a01" + print*,p_num_a01,"num_a01" + print*,p_so4_a02,"so4_a02" + print*,p_no3_a02,"no3_a02" + print*,p_cl_a02,"cl_a02" + print*,p_nh4_a02,"nh4_a02" + print*,p_na_a02,"na_a02" + print*,p_oin_a02,"oin_a02" + print*,p_oc_a02,"oc_a02" + print*,p_bc_a02,"bc_a02" + print*,p_hysw_a02,"hysw_a02" + print*,p_water_a02,"water_a02" + print*,p_num_a02,"num_a02" + print*,p_so4_a03,"so4_a03" + print*,p_no3_a03,"no3_a03" + print*,p_cl_a03,"cl_a03" + print*,p_nh4_a03,"nh4_a03" + print*,p_na_a03,"na_a03" + print*,p_oin_a03,"oin_a03" + print*,p_oc_a03,"oc_a03" + print*,p_bc_a03,"bc_a03" + print*,p_hysw_a03,"hysw_a03" + print*,p_water_a03,"water_a03" + print*,p_num_a03,"num_a03" + print*,p_so4_a04,"so4_a04" + print*,p_no3_a04,"no3_a04" + print*,p_cl_a04,"cl_a04" + print*,p_nh4_a04,"nh4_a04" + print*,p_na_a04,"na_a04" + print*,p_oin_a04,"oin_a04" + print*,p_oc_a04,"oc_a04" + print*,p_bc_a04,"bc_a04" + print*,p_hysw_a04,"hysw_a04" + print*,p_water_a04,"water_a04" + print*,p_num_a04,"num_a04" + print*,p_so4_cw01,"so4_cw01" + print*,p_no3_cw01,"no3_cw01" + print*,p_cl_cw01,"cl_cw01" + print*,p_nh4_cw01,"nh4_cw01" + print*,p_na_cw01,"na_cw01" + print*,p_oin_cw01,"oin_cw01" + print*,p_oc_cw01,"oc_cw01" + print*,p_bc_cw01,"bc_cw01" + print*,p_num_cw01,"num_cw01" + print*,p_so4_cw02,"so4_cw02" + print*,p_no3_cw02,"no3_cw02" + print*,p_cl_cw02,"cl_cw02" + print*,p_nh4_cw02,"nh4_cw02" + print*,p_na_cw02,"na_cw02" + print*,p_oin_cw02,"oin_cw02" + print*,p_oc_cw02,"oc_cw02" + print*,p_bc_cw02,"bc_cw02" + print*,p_num_cw02,"num_cw02" + print*,p_so4_cw03,"so4_cw03" + print*,p_no3_cw03,"no3_cw03" + print*,p_cl_cw03,"cl_cw03" + print*,p_nh4_cw03,"nh4_cw03" + print*,p_na_cw03,"na_cw03" + print*,p_oin_cw03,"oin_cw03" + print*,p_oc_cw03,"oc_cw03" + print*,p_bc_cw03,"bc_cw03" + print*,p_num_cw03,"num_cw03" + print*,p_so4_cw04,"so4_cw04" + print*,p_no3_cw04,"no3_cw04" + print*,p_cl_cw04,"cl_cw04" + print*,p_nh4_cw04,"nh4_cw04" + print*,p_na_cw04,"na_cw04" + print*,p_oin_cw04,"oin_cw04" + print*,p_oc_cw04,"oc_cw04" + print*,p_bc_cw04,"bc_cw04" + print*,p_num_cw04,"num_cw04" + + case (CBMZ_MOSAIC_8BIN_AQ) + print*,p_so4_a01,"so4_a01" + print*,p_no3_a01,"no3_a01" + print*,p_cl_a01,"cl_a01" + print*,p_nh4_a01,"nh4_a01" + print*,p_na_a01,"na_a01" + print*,p_oin_a01,"oin_a01" + print*,p_oc_a01,"oc_a01" + print*,p_bc_a01,"bc_a01" + print*,p_hysw_a01,"hysw_a01" + print*,p_water_a01,"water_a01" + print*,p_num_a01,"num_a01" + print*,p_so4_a02,"so4_a02" + print*,p_no3_a02,"no3_a02" + print*,p_cl_a02,"cl_a02" + print*,p_nh4_a02,"nh4_a02" + print*,p_na_a02,"na_a02" + print*,p_oin_a02,"oin_a02" + print*,p_oc_a02,"oc_a02" + print*,p_bc_a02,"bc_a02" + print*,p_hysw_a02,"hysw_a02" + print*,p_water_a02,"water_a02" + print*,p_num_a02,"num_a02" + print*,p_so4_a03,"so4_a03" + print*,p_no3_a03,"no3_a03" + print*,p_cl_a03,"cl_a03" + print*,p_nh4_a03,"nh4_a03" + print*,p_na_a03,"na_a03" + print*,p_oin_a03,"oin_a03" + print*,p_oc_a03,"oc_a03" + print*,p_bc_a03,"bc_a03" + print*,p_hysw_a03,"hysw_a03" + print*,p_water_a03,"water_a03" + print*,p_num_a03,"num_a03" + print*,p_so4_a04,"so4_a04" + print*,p_no3_a04,"no3_a04" + print*,p_cl_a04,"cl_a04" + print*,p_nh4_a04,"nh4_a04" + print*,p_na_a04,"na_a04" + print*,p_oin_a04,"oin_a04" + print*,p_oc_a04,"oc_a04" + print*,p_bc_a04,"bc_a04" + print*,p_hysw_a04,"hysw_a04" + print*,p_water_a04,"water_a04" + print*,p_num_a04,"num_a04" + print*,p_so4_a05,"so4_a05" + print*,p_no3_a05,"no3_a05" + print*,p_cl_a05,"cl_a05" + print*,p_nh4_a05,"nh4_a05" + print*,p_na_a05,"na_a05" + print*,p_oin_a05,"oin_a05" + print*,p_oc_a05,"oc_a05" + print*,p_bc_a05,"bc_a05" + print*,p_hysw_a05,"hysw_a05" + print*,p_water_a05,"water_a05" + print*,p_num_a05,"num_a05" + print*,p_so4_a06,"so4_a06" + print*,p_no3_a06,"no3_a06" + print*,p_cl_a06,"cl_a06" + print*,p_nh4_a06,"nh4_a06" + print*,p_na_a06,"na_a06" + print*,p_oin_a06,"oin_a06" + print*,p_oc_a06,"oc_a06" + print*,p_bc_a06,"bc_a06" + print*,p_hysw_a06,"hysw_a06" + print*,p_water_a06,"water_a06" + print*,p_num_a06,"num_a06" + print*,p_so4_a07,"so4_a07" + print*,p_no3_a07,"no3_a07" + print*,p_cl_a07,"cl_a07" + print*,p_nh4_a07,"nh4_a07" + print*,p_na_a07,"na_a07" + print*,p_oin_a07,"oin_a07" + print*,p_oc_a07,"oc_a07" + print*,p_bc_a07,"bc_a07" + print*,p_hysw_a07,"hysw_a07" + print*,p_water_a07,"water_a07" + print*,p_num_a07,"num_a07" + print*,p_so4_a08,"so4_a08" + print*,p_no3_a08,"no3_a08" + print*,p_cl_a08,"cl_a08" + print*,p_nh4_a08,"nh4_a08" + print*,p_na_a08,"na_a08" + print*,p_oin_a08,"oin_a08" + print*,p_oc_a08,"oc_a08" + print*,p_bc_a08,"bc_a08" + print*,p_hysw_a08,"hysw_a08" + print*,p_water_a08,"water_a08" + print*,p_num_a08,"num_a08" + + print*,p_so4_cw01,"so4_cw01" + print*,p_no3_cw01,"no3_cw01" + print*,p_cl_cw01,"cl_cw01" + print*,p_nh4_cw01,"nh4_cw01" + print*,p_na_cw01,"na_cw01" + print*,p_oin_cw01,"oin_cw01" + print*,p_oc_cw01,"oc_cw01" + print*,p_bc_cw01,"bc_cw01" + print*,p_num_cw01,"num_cw01" + print*,p_so4_cw02,"so4_cw02" + print*,p_no3_cw02,"no3_cw02" + print*,p_cl_cw02,"cl_cw02" + print*,p_nh4_cw02,"nh4_cw02" + print*,p_na_cw02,"na_cw02" + print*,p_oin_cw02,"oin_cw02" + print*,p_oc_cw02,"oc_cw02" + print*,p_bc_cw02,"bc_cw02" + print*,p_num_cw02,"num_cw02" + print*,p_so4_cw03,"so4_cw03" + print*,p_no3_cw03,"no3_cw03" + print*,p_cl_cw03,"cl_cw03" + print*,p_nh4_cw03,"nh4_cw03" + print*,p_na_cw03,"na_cw03" + print*,p_oin_cw03,"oin_cw03" + print*,p_oc_cw03,"oc_cw03" + print*,p_bc_cw03,"bc_cw03" + print*,p_num_cw03,"num_cw03" + print*,p_so4_cw04,"so4_cw04" + print*,p_no3_cw04,"no3_cw04" + print*,p_cl_cw04,"cl_cw04" + print*,p_nh4_cw04,"nh4_cw04" + print*,p_na_cw04,"na_cw04" + print*,p_oin_cw04,"oin_cw04" + print*,p_oc_cw04,"oc_cw04" + print*,p_bc_cw04,"bc_cw04" + print*,p_num_cw04,"num_cw04" + print*,p_so4_cw05,"so4_cw05" + print*,p_no3_cw05,"no3_cw05" + print*,p_cl_cw05,"cl_cw05" + print*,p_nh4_cw05,"nh4_cw05" + print*,p_na_cw05,"na_cw05" + print*,p_oin_cw05,"oin_cw05" + print*,p_oc_cw05,"oc_cw05" + print*,p_bc_cw05,"bc_cw05" + print*,p_num_cw05,"num_cw05" + print*,p_so4_cw06,"so4_cw06" + print*,p_no3_cw06,"no3_cw06" + print*,p_cl_cw06,"cl_cw06" + print*,p_nh4_cw06,"nh4_cw06" + print*,p_na_cw06,"na_cw06" + print*,p_oin_cw06,"oin_cw06" + print*,p_oc_cw06,"oc_cw06" + print*,p_bc_cw06,"bc_cw06" + print*,p_num_cw06,"num_cw06" + print*,p_so4_cw07,"so4_cw07" + print*,p_no3_cw07,"no3_cw07" + print*,p_cl_cw07,"cl_cw07" + print*,p_nh4_cw07,"nh4_cw07" + print*,p_na_cw07,"na_cw07" + print*,p_oin_cw07,"oin_cw07" + print*,p_oc_cw07,"oc_cw07" + print*,p_bc_cw07,"bc_cw07" + print*,p_num_cw07,"num_cw07" + print*,p_so4_cw08,"so4_cw08" + print*,p_no3_cw08,"no3_cw08" + print*,p_cl_cw08,"cl_cw08" + print*,p_nh4_cw08,"nh4_cw08" + print*,p_na_cw08,"na_cw08" + print*,p_oin_cw08,"oin_cw08" + print*,p_oc_cw08,"oc_cw08" + print*,p_bc_cw08,"bc_cw08" + print*,p_num_cw08,"num_cw08" +end select +end subroutine print_chem_species_index +#endif diff --git a/wrfv2_fire/chem/cloudchem_driver.F b/wrfv2_fire/chem/cloudchem_driver.F new file mode 100644 index 00000000..8a0e46e6 --- /dev/null +++ b/wrfv2_fire/chem/cloudchem_driver.F @@ -0,0 +1,182 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + +! file cloudchem_driver.F + + + SUBROUTINE cloudchem_driver( & + id, ktau, ktauc, dtstep, dtstepc, config_flags, & + t_phy, p_phy, rho_phy, alt, & + moist, cldfra, ph_no2, & + chem, gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_model_constants + USE module_mosaic_cloudchem, only: mosaic_cloudchem_driver + + ! This driver calls subroutines for wet scavenging. + ! + ! 1. MADE-SORGAM (not yet implemented) + ! 2. MOSAIC + +!---------------------------------------------------------------------- + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +!-- alt inverse density +!-- t_phy temperature (K) +!-- w vertical velocity (m/s) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- dz8w dz between full levels (m) +!-- p8w pressure at full levels (Pa) +!-- p_phy pressure (Pa) +! points (dimensionless) +!-- z 3D height with lowest level being the terrain +!-- rho_phy density (kg/m^3) +!-- qlsink Fractional cloud water sink (/s) +!-- precr rain precipitation rate at all levels (kg/m2/s) +!-- preci ice precipitation rate at all levels (kg/m2/s) +!-- precs snow precipitation rate at all levels (kg/m2/s) +!-- precg graupel precipitation rate at all levels (kg/m2/s) & +!-- R_d gas constant for dry air ( 287. J/kg/K) +!-- R_v gas constant for water vapor (461 J/k/kg) +!-- Cp specific heat at constant pressure (1004 J/k/kg) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- G acceleration due to gravity (m/s^2) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- config_flags%kemit end index for k for emissions arrays +! +!====================================================================== + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, & + numgas_aqfrac + REAL, INTENT(IN ) :: dtstep, dtstepc +! +! moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + rho_phy, & + alt, & + cldfra, & + ph_no2 +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(INOUT ) :: gas_aqfrac + + + +! LOCAL VAR + integer :: ii,jj,kk + + +!----------------------------------------------------------------- + +! These are unneeded, since the default behavior is to do nothing. +! If the default changes, then lines need to be added for CBMZ and +! CBMZ_BB. +! IF (config_flags%chem_opt .eq. 0) return +! IF (config_flags%chem_opt .eq. 1) return + +! +! select which aerosol scheme to take +! + cps_select: SELECT CASE(config_flags%chem_opt) + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + + call wrf_debug(15,'cloudchem_driver calling mosaic_cloudchem_driver') + call mosaic_cloudchem_driver( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT cps_select + + END SUBROUTINE cloudchem_driver + diff --git a/wrfv2_fire/chem/convert_bioemiss.F b/wrfv2_fire/chem/convert_bioemiss.F new file mode 100644 index 00000000..b651e6ab --- /dev/null +++ b/wrfv2_fire/chem/convert_bioemiss.F @@ -0,0 +1,305 @@ +! This is a program that converts biobenic emissions data +! into WRF input data. +! + +PROGRAM convert_bioemiss +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE module_machine + USE module_domain + USE module_initialize + USE module_integrate + USE module_driver_constants + USE module_configure + USE module_io_wrf + USE module_io_domain + USE module_timing + USE module_utility + USE module_wrf_error + USE module_input_chem_bioemiss +#ifdef DM_PARALLEL + USE module_dm +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IMPLICIT NONE + + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + + REAL :: time + + INTEGER :: loop , levels_to_process + INTEGER :: rc + + TYPE(domain) , POINTER :: keep_grid, grid_ptr, null_domain, grid, ingrid + TYPE (grid_config_rec_type) :: config_flags, config_flags_in + INTEGER :: number_at_same_level + + INTEGER :: max_dom, domain_id + INTEGER :: id1 , id , fid, ierr + INTEGER :: idum1, idum2 , ihour +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + REAL :: dt_from_file, tstart_from_file, tend_from_file + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: i , j , k , idts, ntsd, emi_frame, nemi_frames + INTEGER :: debug_level = 0 + + CHARACTER (LEN=80) :: message + + CHARACTER(LEN=24) :: previous_date , this_date , next_date + CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char + CHARACTER(LEN= 4) :: loop_char + + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop + + REAL :: cen_lat, cen_lon, moad_cen_lat, truelat1, truelat2, gmt, stand_lon, dum1 + INTEGER :: map_proj, julyr, julday, iswater, isice, isurban, isoilwater + CHARACTER(LEN= 8) :: chlanduse + + + CHARACTER (LEN=80) :: inpname , eminame, dum_str, wrfinname + +! these are needed on some compilers, eg compaq/alpha, to +! permit pass by reference through the registry generated +! interface to med_read_emissions, below +#ifdef DEREF_KLUDGE + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +#endif + + ! Get the NAMELIST data for input. + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "WRF V2.1.2 BIOGENIC EMISSIONS PREPROCESSOR" + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + +! CALL init_modules + CALL wrf_debug ( 100 , 'convert_emiss: calling init_modules ' ) + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + ENDIF + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + CALL wrf_message ( program_name ) + + CALL init_wrfio + +! ! Get the grid info from the wrfinput file + + write(message,FMT='(A)') ' allocate for wrfinput_d01 ' + CALL wrf_message ( program_name ) + NULLIFY( null_domain ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + write(message,FMT='(A)') ' pointer for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + grid => head_grid + write(message,FMT='(A)') ' set scalars for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + write(message,FMT='(A)') ' construct filename for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + CALL construct_filename1( wrfinname , 'wrfinput' , grid%id , 2 ) + + write(message,FMT='(A,A)') ' open file ',TRIM(wrfinname) + CALL wrf_message ( message ) + CALL open_r_dataset ( fid, TRIM(wrfinname) , grid , config_flags , "DATASET=INPUT", ierr ) + + + write(message,FMT='(A)') ' wrfinput open error check ' + CALL wrf_debug ( 100, message ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) & + 'program convert_emiss: error opening ',TRIM(wrfinname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + write(message,FMT='(A)') ' past opening wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + + CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISICE ' , isice , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , isurban , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , isoilwater , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_char ( fid , 'MMINLU' , chlanduse , ierr ) + + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + + + ! An available simple timer from the timing module. + + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + CALL Setup_Timekeeping ( grid ) + CALL domain_clock_set( grid, & + time_step_seconds=model_config_rec%interval_seconds ) + CALL domain_clock_get ( grid, current_timestr=message ) + write(message,FMT='(A,A)') ' current_time ',Trim(message) + CALL wrf_debug ( 100, message ) + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! print *,'start date=',model_config_rec%start_year(grid%id),model_config_rec%start_month(grid%id),& +! model_config_rec%start_day(grid%id),model_config_rec%start_hour(grid%id) +! print *,'end date=',model_config_rec%end_year(grid%id),model_config_rec%end_month(grid%id),& +! model_config_rec%end_day(grid%id),model_config_rec%end_hour(grid%id) +! print *,'interval =',model_config_rec%interval_seconds +! print *,'init_typ =',model_config_rec%real_data_init_type + + ! Figure out the starting and ending dates in a character format. + + start_year = model_config_rec%start_year (grid%id) + start_month = model_config_rec%start_month (grid%id) + start_day = model_config_rec%start_day (grid%id) + start_hour = model_config_rec%start_hour (grid%id) + start_minute = model_config_rec%start_minute(grid%id) + start_second = model_config_rec%start_second(grid%id) + + end_year = model_config_rec% end_year (grid%id) + end_month = model_config_rec% end_month (grid%id) + end_day = model_config_rec% end_day (grid%id) + end_hour = model_config_rec% end_hour (grid%id) + end_minute = model_config_rec% end_minute(grid%id) + end_second = model_config_rec% end_second(grid%id) + + interval_seconds = 3600 + real_data_init_type = model_config_rec%real_data_init_type + + WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + start_year,start_month,start_day,start_hour,start_minute,start_second + WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + end_year, end_month, end_day, end_hour, end_minute, end_second + +! these are needed on some compilers, eg compaq/alpha, to +! permit pass by reference through the registry generated +! interface to med_read_emissions, below +#ifdef DEREF_KLUDGE + sm31 = grid%sm31 + em31 = grid%em31 + sm32 = grid%sm32 + em32 = grid%em32 + sm33 = grid%sm33 + em33 = grid%em33 +#endif + + ihour = start_hour + write(message,FMT='(A)') ' READ BIOGENIC EMISSIONS ' + CALL wrf_debug ( 100, message ) + CALL input_ext_chem_beis3_file ( grid ) + write(message,FMT='(A)') ' PAST READ BIOGENIC EMISSIONS ' + CALL wrf_debug ( 100, message ) + + grid%input_from_file = .false. + + write(message,FMT='(A)') ' OPEN BIOGENIC EMISSIONS WRF file' + CALL wrf_debug ( 100, message ) + + CALL construct_filename1( inpname , 'wrfbiochemi' , grid%id , 2 ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input4 , "DATASET=AUXINPUT4", ierr ) + write(message,FMT='(A,A)') ' BIOGENIC EMISSIONS file name: ',TRIM(inpname) + CALL wrf_message ( message ) + + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) + ENDIF + + write(message,FMT='(A)') ' PAST OPEN BIOGENIC EMISSIONS WRF file ' + CALL wrf_debug ( 100, message ) + + CALL calc_current_date ( grid%id , 0. ) + CALL geth_newdate ( current_date_char, current_date, 3600 ) + current_date = current_date_char // '.0000' + + if( stand_lon == 0. ) then + stand_lon = cen_lon + endif + + if( moad_cen_lat == 0. ) then + moad_cen_lat = cen_lat + endif + + CALL output_aux_model_input4 ( id1 , grid , config_flags , ierr ) + + write(message,FMT='(A)') ' BIOGENIC EMISSIONS: fix global attributes ' + CALL wrf_debug ( 100, message ) + + ! write global atributes into wrf emissions file + + idum1 = 1 + call wrf_put_dom_ti_char ( id1 , 'START_DATE' ,TRIM(start_date_char) , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'MOAD_CEN_LAT' , moad_cen_lat, 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'CEN_LAT' , cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'CEN_LON' , cen_lon , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'STAND_LON' , stand_lon , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT1' , truelat1 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT2' , truelat2 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( id1 , 'GMT' , gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'JULYR' , julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'JULDAY' , julday , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'CHEM_OPT' , chem_opt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'ISWATER' , iswater , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'ISICE ' , isice , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'ISURBAN' , isurban , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( id1 , 'ISOILWATER' , isoilwater , 1 , ierr ) + CALL wrf_put_dom_ti_char ( id1 , 'MMINLU' , TRIM(chlanduse) , ierr ) + + + CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT4" ) + + write(message,FMT='(A)') ' BIOGENIC EMISSIONS: end of program ' + CALL wrf_message ( message ) + + + CALL wrf_shutdown + CALL WRFU_Finalize( rc=rc ) + +!#ifdef DM_PARALLEL +! CALL wrf_dm_shutdown +!#endif + + STOP + +END PROGRAM convert_bioemiss diff --git a/wrfv2_fire/chem/convert_emiss.F b/wrfv2_fire/chem/convert_emiss.F new file mode 100644 index 00000000..2e328174 --- /dev/null +++ b/wrfv2_fire/chem/convert_emiss.F @@ -0,0 +1,414 @@ +! This is a program that converts emissions data into WRF input data. +! + +PROGRAM convert_emiss +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + USE module_machine + USE module_domain + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_initialize + USE module_integrate + USE module_driver_constants + USE module_state_description + USE module_configure + USE module_timing + USE module_utility + USE module_input_chem_data +#ifdef DM_PARALLEL + USE module_dm +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IMPLICIT NONE + + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + + REAL :: time + + INTEGER :: loop , levels_to_process + INTEGER :: rc + + TYPE(domain) , POINTER :: keep_grid, grid_ptr, null_domain, grid, ingrid + TYPE (grid_config_rec_type) :: config_flags, config_flags_in + INTEGER :: number_at_same_level + + INTEGER :: max_dom, domain_id + INTEGER :: id1 , id , fid, ierr + INTEGER :: idum1, idum2 , ihour +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + REAL :: dt_from_file, tstart_from_file, tend_from_file + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: i , j , k , idts, ntsd, emi_frame, nemi_frames + INTEGER :: debug_level = 0 + + INTEGER ibuf(1) + REAL rbuf(1) + + CHARACTER (LEN=80) :: message + + CHARACTER(LEN=24) :: previous_date , this_date , next_date + CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char + CHARACTER(LEN= 4) :: loop_char + + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop + + REAL :: cen_lat, cen_lon, moad_cen_lat, truelat1, truelat2, gmt, stand_lon, dum1 + INTEGER :: map_proj, julyr, julday, iswater, isice, isurban, isoilwater + CHARACTER(LEN= 8) :: chlanduse + + + CHARACTER (LEN=80) :: inpname , eminame, dum_str, wrfinname + +! these are needed on some compilers, eg compaq/alpha, to +! permit pass by reference through the registry generated +! interface to med_read_emissions, below +#ifdef DEREF_KLUDGE + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +#endif + + ! Get the NAMELIST data for input. + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "WRF V2.1.2 EMISSIONS PREPROCESSOR " + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + +! CALL init_modules + CALL wrf_debug ( 100 , 'convert_emiss: calling init_modules ' ) + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + ENDIF + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + CALL wrf_message ( program_name ) + + CALL init_wrfio + +! ! Get the grid info from the wrfinput file + + write(message,FMT='(A)') ' allocate for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + NULLIFY( null_domain ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + write(message,FMT='(A)') ' pointer for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + grid => head_grid + write(message,FMT='(A)') ' set scalars for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + write(message,FMT='(A)') ' construct filename for wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + CALL construct_filename1( wrfinname , 'wrfinput' , grid%id , 2 ) + + write(message,FMT='(A,A)')' open file ',TRIM(wrfinname) + CALL wrf_debug ( 100, message ) + CALL open_r_dataset ( fid, TRIM(wrfinname) , grid , config_flags , "DATASET=INPUT", ierr ) + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + + write(message,FMT='(A)') ' wrfinput open error check ' + CALL wrf_debug ( 100, message ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) & + 'program convert_emiss: error opening ',TRIM(wrfinname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + write(message,FMT='(A)') ' past opening wrfinput_d01 ' + CALL wrf_debug ( 100, message ) + + CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISICE ' , isice , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , isurban , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , isoilwater , 1 , idum1 , ierr ) + CALL wrf_get_dom_ti_char ( fid , 'MMINLU' , chlanduse , ierr ) + + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + + + ! An available simple timer from the timing module. + +! NULLIFY( null_domain ) +! CALL alloc_and_configure_domain ( domain_id = 1 , & +! grid = head_grid , & +! parent = null_domain , & +! kid = -1 ) + +! grid => head_grid + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + + CALL Setup_Timekeeping ( grid ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG emissions_convert: clock after Setup_Timekeeping,' ) + CALL domain_clock_set( grid, & + time_step_seconds=model_config_rec%interval_seconds ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG emissions_convert: clock after timeStep set,' ) + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! print *,'start date=',model_config_rec%start_year(grid%id),model_config_rec%start_month(grid%id),& +! model_config_rec%start_day(grid%id),model_config_rec%start_hour(grid%id) +! print *,'end date=',model_config_rec%end_year(grid%id),model_config_rec%end_month(grid%id),& +! model_config_rec%end_day(grid%id),model_config_rec%end_hour(grid%id) +! print *,'interval =',model_config_rec%interval_seconds +! print *,'init_typ =',model_config_rec%real_data_init_type + + ! Figure out the starting and ending dates in a character format. + + start_year = model_config_rec%start_year (grid%id) + start_month = model_config_rec%start_month (grid%id) + start_day = model_config_rec%start_day (grid%id) + start_hour = model_config_rec%start_hour (grid%id) + start_minute = model_config_rec%start_minute(grid%id) + start_second = model_config_rec%start_second(grid%id) + + end_year = model_config_rec% end_year (grid%id) + end_month = model_config_rec% end_month (grid%id) + end_day = model_config_rec% end_day (grid%id) + end_hour = model_config_rec% end_hour (grid%id) + end_minute = model_config_rec% end_minute(grid%id) + end_second = model_config_rec% end_second(grid%id) + + interval_seconds = 3600 + real_data_init_type = model_config_rec%real_data_init_type + + WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + start_year,start_month,start_day,start_hour,start_minute,start_second + WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + end_year, end_month, end_day, end_hour, end_minute, end_second + + + ! Figure out our loop count for the processing times. + + time_loop = 1 + write(message,FMT='(A,I4,A,A)') 'Time period #',time_loop,' to process = ',start_date_char + CALL wrf_message ( message ) + current_date_char = start_date_char + loop_count : DO + CALL geth_newdate ( next_date_char , current_date_char , interval_seconds ) + IF ( next_date_char .LT. end_date_char ) THEN + time_loop = time_loop + 1 + write(message,FMT='(A,I4,A,A)') 'Time period #',time_loop,' to process = ',next_date_char + CALL wrf_message ( message ) + current_date_char = next_date_char + ELSE IF ( next_date_char .EQ. end_date_char ) THEN + time_loop = time_loop + 1 + write(message,FMT='(A,I4,A,A)') 'Time period #',time_loop,' to process = ',next_date_char + CALL wrf_message ( message ) + write(message,FMT='(A,I4)') 'Total analysis times to input = ',time_loop + CALL wrf_message ( message ) + time_loop_max = time_loop + EXIT loop_count + ELSE IF ( next_date_char .GT. end_date_char ) THEN + write(message,FMT='(A,I4)') 'Total analysis times to input = ',time_loop + CALL wrf_message ( message ) + time_loop_max = time_loop + EXIT loop_count + END IF + END DO loop_count + write(message,FMT='(A,I4,A,I4)') 'Total number of times to input = ',time_loop,' ',time_loop_max + CALL wrf_message ( message ) + + ! Here we define the initial time to process, for later use by the code. + + current_date_char = start_date_char + start_date = start_date_char // '.0000' + current_date = start_date + +! these are needed on some compilers, eg compaq/alpha, to +! permit pass by reference through the registry generated +! interface to med_read_emissions, below +#ifdef DEREF_KLUDGE + sm31 = grid%sm31 + em31 = grid%em31 + sm32 = grid%sm32 + em32 = grid%em32 + sm33 = grid%sm33 + em33 = grid%em33 +#endif + + ihour = start_hour + write(message,FMT='(A)') ' READ EMISSIONS 1' + CALL wrf_debug ( 100, message ) + CALL med_read_bin_chem_emiss ( grid , config_flags, ihour, time_loop ) + write(message,FMT='(A)') ' PAST READ EMISSIONS 1' + CALL wrf_debug ( 100, message ) + + grid%input_from_file = .false. + + write(message,FMT='(A)') ' OPEN EMISSIONS WRF file ' + CALL wrf_debug ( 100, message ) + + CALL construct_filename1( inpname , 'wrfchemi' , grid%id , 2 ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr ) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + write(message,FMT='(A,A)') ' EMISSIONS file name: ',TRIM(inpname) + CALL wrf_message ( message ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) + ENDIF + + write(message,FMT='(A)') ' PAST OPEN EMISSIONS WRF file ' + CALL wrf_debug ( 100, message ) + + CALL calc_current_date ( grid%id , 0. ) + CALL geth_newdate ( current_date_char, current_date, 3600 ) + current_date = current_date_char // '.0000' + + if( stand_lon == 0. ) then + stand_lon = cen_lon + endif + + if( moad_cen_lat == 0. ) then + moad_cen_lat = cen_lat + endif + +! CALL output_aux_model_input5 ( id1 , grid , config_flags , ierr ) + + ! write global atributes into wrf emissions file + +! grid%map_proj = map_proj +! grid%cen_lat = cen_lat +! grid%cen_lon = cen_lon + config_flags%map_proj = map_proj + config_flags%cen_lat = cen_lat + config_flags%cen_lon = cen_lon + config_flags%stand_lon = stand_lon + config_flags%truelat1 = truelat1 + config_flags%truelat2 = truelat2 + config_flags%gmt = gmt + config_flags%julyr = julyr + config_flags%julday = julday + config_flags%iswater = iswater + config_flags%isice = isice + config_flags%isurban = isurban + config_flags%isoilwater = isoilwater + config_flags%moad_cen_lat = moad_cen_lat +! config_flags%mminlu = TRIM(chlanduse) + + CALL output_aux_model_input5 ( id1 , grid , config_flags, ierr ) + + current_date_char = start_date_char + current_date = current_date_char + + nemi_frames = time_loop + if( debug_level >= -100) print *,'NEMI_FRAMES ', nemi_frames,time_loop + + DO emi_frame = 2,nemi_frames + write(message,FMT='(A,I4)') 'emi_frame: ',emi_frame + CALL wrf_debug ( 100, message ) + CALL domain_clock_get ( grid, current_timestr=message ) + write(message,FMT='(A,A)') ' Current time ',Trim(message) + CALL wrf_debug ( 100, message ) + + current_date_char = current_date(1:19) + CALL geth_newdate ( next_date_char, current_date_char, int(interval_seconds) ) + current_date = next_date_char // '.0000' + + write(message,FMT='(A,A)') ' Date & time ',Trim(current_date) + CALL wrf_message ( message ) + + CALL domain_clockadvance( grid ) + + write(message,FMT='(A,I4)') ' Read emissions ',emi_frame + CALL wrf_debug ( 100, message ) + ihour = mod(ihour + 1,24) + CALL med_read_bin_chem_emiss ( grid , config_flags, ihour, nemi_frames-1 ) + + ! write global atributes into wrf emissions file + + write(message,FMT='(A)') ' Output emissions ' + CALL wrf_debug ( 100, message ) + CALL output_aux_model_input5 ( id1 , grid , config_flags , ierr ) + +! idum1 = 1 +! CALL wrf_put_dom_ti_char ( id1 , 'START_DATE' ,TRIM(start_date_char) , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'MOAD_CEN_LAT' , moad_cen_lat, 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'CEN_LAT' , cen_lat , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'CEN_LON' , cen_lon , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'STAND_LON' , stand_lon , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT1' , truelat1 , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'TRUELAT2' , truelat2 , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( id1 , 'GMT' , gmt , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'MAP_PROJ' , map_proj , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'JULYR' , julyr , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'JULDAY' , julday , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'ISWATER' , iswater , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'ISICE ' , isice , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'ISURBAN' , isurban , 1 , ierr ) +! CALL wrf_put_dom_ti_integer ( id1 , 'ISOILWATER' , isoilwater , 1 , ierr ) +! CALL wrf_put_dom_ti_char ( id1 , 'MMINLU' , TRIM(chlanduse) , ierr ) + + +! print *,' map_proj ', config_flags%map_proj, map_proj +! print *,' cen_lat ', config_flags%cen_lat , cen_lat +! print *,' cen_lon ', config_flags%cen_lon , cen_lon + + END DO + + CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT5" ) + + write(message,FMT='(A)') 'CONVERT EMISSIONS: end of program ' + CALL wrf_message ( message ) + + CALL wrf_shutdown + CALL WRFU_Finalize( rc=rc ) + +!#ifdef DM_PARALLEL +! CALL wrf_dm_shutdown +!#endif + STOP + +END PROGRAM convert_emiss diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F new file mode 100755 index 00000000..7599eaf4 --- /dev/null +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -0,0 +1,325 @@ +!WRF:MODEL_LAYER:CHEMICS +! + subroutine dry_dep_driver(id,ktau,dtstep,config_flags, & + gmt,julday,t_phy,moist,scalar,p8w,t8w,w,alt, & + p_phy,chem,rho_phy,dz8w,exch_h, & + cldfra, cldfra_old, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,dep_vel_o3, & + e_co,kemit,numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_model_constants + USE module_configure + USE module_state_description + USE module_dep_simple + USE module_vertmx_wrf + USE module_data_sorgam + USE module_aerosols_sorgam + USE module_mosaic_drydep, only: mosaic_drydep_driver + USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: id,julday, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_scalar ), & + INTENT(INOUT ) :: scalar + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + INTEGER, INTENT(IN ) :: kemit + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(IN ) :: & + e_co + + + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + alt, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + w, & + exch_h,rho_phy,z + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + rmol, & + ust, & + xlat, & + xlong, & + znt + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + cldfra, & ! cloud fraction current timestep + cldfra_old ! cloud fraction previous timestep + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(OUT) :: & + dep_vel_o3 + REAL, INTENT(OUT), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + REAL, INTENT(IN ) :: & + dtstep,gmt + +!--- deposition and emissions stuff +! .. Parameters .. +! .. +! .. Local Scalars .. + REAL :: clwchem, dvfog, dvpart, & + rad, rhchem, ta, ustar, vegfrac, z1,zntt + + INTEGER :: iland, iprt, iseason, jce, jcs, & + n, nr, ipr, jpr, nvr, & + idrydep_onoff + + LOGICAL :: highnh3, rainflag, vegflag, wetflag +! CHARACTER (4) :: luse_typ,mminlu_loc +! .. +! .. Local Arrays .. + REAL :: p(kts:kte-1) + REAL, DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy + REAL, DIMENSION( kms:kme ) :: dryrho_1d + +! turbulent transport + real :: pblst(kts:kte-1),ekmfull(kts:kte),zzfull(kts:kte),zz(kts:kte-1) + integer :: ii,jj,kk,i,j,k,nv +! +! necessary for aerosols (module dependent) +! + REAL, DIMENSION( its:ite, jts:jte ) :: aer_res + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min + +! +! compute dry deposition velocities = ddvel +! +! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine +! only when drydep_opt == WESELY +! the wesely_driver routine computes aer_res, and currently +! you cannot compute aerosol drydep without it !! +! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines +! + ddvel(:,:,:) = 0.0 + idrydep_onoff = 0 + + drydep_select: SELECT CASE(config_flags%drydep_opt) + + CASE ( WESELY ) +! +! drydep_opt == WESELY means +! wesely for gases +! other (appropriate) routine for aerosols +! + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') + + IF( config_flags%chem_opt /= CHEM_TRACER ) THEN + call wesely_driver(id,ktau,dtstep, & + config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE + !Set dry deposition velocity to zero when using the + !chemistry tracer mode. + ddvel(:,:,:) = 0. + END IF + + idrydep_onoff = 1 + + + adrydep_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/RADM') + call sorgam_depdriver (id,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & + aer_res,ddvel(:,:,numgas+1:num_chem), & + num_chem-numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE (RACMSORG,RACMSORG_AQ,RACMSORG_KPP) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/RACM') + call sorgam_depdriver (id,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & + aer_res,ddvel(:,:,numgas+1:num_chem), & + num_chem-numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR MOSAIC AEROSOLS') + call mosaic_drydep_driver( & + id, ktau, dtstep, config_flags, & + gmt, julday, & + t_phy, rho_phy, p_phy, & + ust, aer_res, & + moist, chem, ddvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + + END SELECT adrydep_select + + CASE DEFAULT + + END SELECT drydep_select + + + +! This will be called later from subgrd_transport_driver.F !!!!!!!! +! +! + dep_vel_o3=0. + do 100 j=jts,jte + do 100 i=its,ite + pblst=0. +! +! +!-- start with vertical mixing +! + do k=kts,kte + zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) + ekmfull(k)=max(1.e-6,exch_h(i,k,j)) + enddo + +!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO +!!$! FORCE MIXING TO A CERTAIN DEPTH: +!!$! +!!$! --- Mix the emissions up several layers +!!$! if e_co > 0., the grid cell should not be over water +!!$! if e_co > 200, the grid cell should be over a large urban region +!!$! +! if (e_co(i,kts,j) .gt. 0) then +! ekmfull(kts:kts+10) = max(ekmfull(kts:kts+10),1.) +! endif +! if (e_co(i,kts,j) .gt. 200) then +! ekmfull(kts:kte/2) = max(ekmfull(kts:kte/2),2.) +! endif +!!$! +! +! + do k=kts,kte-1 + zz(k)=z(i,k,j)-z_at_w(i,kts,j) + enddo + ekmfull(kts)=0. + ekmfull(kte)=0. +! +! vertical mixing routine (including deposition) +! need to be careful here with that dumm tracer in spot 1 +! do not need lho,lho2 +! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) +! + dep_vel_o3(i,j)=ddvel(i,j,p_o3) + do nv=2,num_chem-0 + do k=kts,kte-1 +! pblst(k)=max(epsilc,chem(i,k,j,nv)) + pblst(k)=max(epsilc,chem(i,k,j,nv)/alt(i,k,j)) + dryrho_1d(k) = 1./alt(i,k,j) + enddo +! if(ktau.ge.20)then +! write(0,*)i,j,nv,ddvel(i,j,nv),e_co(i,kts,j) +! endif + + mix_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG_AQ, RACMSORG_AQ, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + if(.not.is_aerosol(nv))then ! mix gases not aerosol +! call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & +! zzfull,zz,ddvel(i,j,nv),kts,kte-1) + call vertmx(dtstep,pblst,ekmfull,zzfull,zz,ddvel(i,j,nv),kts,kte-1) + + endif +! CASE (PRESCRIBE_AEROSOL) + + CASE DEFAULT + call vertmx(dtstep,pblst,ekmfull,zzfull,zz,ddvel(i,j,nv),kts,kte-1) + + END SELECT mix_select + + do k=kts,kte-2 + +! chem(i,k,j,nv)=max(epsilc,pblst(k)) + chem(i,k,j,nv)=max(epsilc,pblst(k)*alt(i,k,j)) + enddo + enddo +100 continue +! +! vertical mixing and activation of aerosol +! + where( alt(its:ite,kts:kte,jts:jte) /= 0. ) !get dry density to conserve mass in mixactivate, wig, 24-apr-2006 + dryrho_phy(its:ite,kts:kte,jts:jte) = 1./alt(its:ite,kts:kte,jts:jte) + dryrho_phy(its:ite,kts:kte,jts:jte) = 1. + elsewhere + dryrho_phy(its:ite,kts:kte,jts:jte) = 0. + end where + + mixactivate_select: SELECT CASE(config_flags%chem_opt) + + CASE (RADM2SORG_AQ, RACMSORG_AQ) + call sorgam_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + dryrho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p8w, t8w, exch_h, & + moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & + scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'call mixactive for mosaic aerosol') + call mosaic_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + dryrho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p8w, t8w, exch_h, & + moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & + scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + END SELECT mixactivate_select + CALL wrf_debug(15,'end of dry_dep_driver') + +END SUBROUTINE dry_dep_driver diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F new file mode 100755 index 00000000..4965c16f --- /dev/null +++ b/wrfv2_fire/chem/emissions_driver.F @@ -0,0 +1,243 @@ +!WRF:MODEL_LAYER:CHEMICS +! + subroutine emissions_driver(id,ktau,dtstep,DX, & + config_flags, stepbioe,gmt,julday,alt,t_phy,moist,p8w,t8w, & + e_bio,p_phy,chem,rho_phy,dz8w,ne_area, & + e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_pm25,e_pm10,e_nh3, & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_no2,e_ch3oh, & + e_c2h5oh,e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + u10,v10,ivgtyp,gsw,vegfra,rmol,ust,znt, & + xland,xlat,xlong,z_at_w, & + sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & + sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & + sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & + noag_grow,noag_nongrow,nononag,slai, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_data_radm2 + USE module_emissions_anthropogenics + USE module_bioemi_simple + USE module_bioemi_beis311 + USE module_cbmz_addemiss + USE module_mosaic_addemiss + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id,julday, ne_area, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau,stepbioe + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, jms:jme, ne_area ), & + INTENT(INOUT ) :: e_bio +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: & + e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2, & + e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_pm25, & + e_pm10,e_nh3,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_no2, & + e_ch3oh,e_c2h5oh,e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc +! +! +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + u10, & + v10, & + gsw, & + vegfra, & + rmol, & + ust, & + xland, & + xlat, & + xlong, & + znt + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT ) :: & + sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & + sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & + sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & + noag_grow,noag_nongrow,nononag,slai, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no + + REAL, INTENT(IN ) :: & + dtstep,dx,gmt +! +! Local variables... +! + INTEGER :: i, j, k, ksub + REAL :: conv + CHARACTER (LEN=80) :: message + +! .. +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min +! .. + ksub=1 +#if ( NMM_CORE == 1 ) + ksub=0 +#endif + bioem_select: SELECT CASE(config_flags%bio_emiss_opt) + CASE (GUNTHER1) + CALL wrf_debug(15,'biogenic emissions: calling Gunther1') + if(ktau.eq.1.or.mod(ktau,stepbioe).eq.0)then + call bio_emissions(id,ktau,dtstep,DX,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + e_bio,p_phy,chem,rho_phy,dz8w,ne_area, & + ivgtyp,gsw,vegfra,rmol,ust,znt,xlat,xlong,z_at_w, & + numgas-1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + CASE (BEIS311) + if(ktau.eq.1.or.mod(ktau,stepbioe).eq.0)then + if(config_flags%chem_opt > RACMSORG .AND. config_flags%chem_opt < 100 ) then !<100: kpp mechs, e.g. RACMSORG_KPP + CALL wrf_error_fatal( & + "emissions_driver: beis3.1.1 biogenic emis. not currently implemented for CBMZ") + endif + CALL wrf_debug(15,'biogenic emissions: calling beis3.1.1') + call bio_emissions_beis311(id,config_flags,ktau,dtstep, & + julday,gmt,xlat,xlong,t_phy,p_phy,gsw, & + sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & + sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & + sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & + noag_grow,noag_nongrow,nononag,slai, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + + CASE DEFAULT + if(ktau.eq.1.or.mod(ktau,stepbioe).eq.0) & + e_bio(its:ite,jts:jte,1:ne_area) = 0. +!wig: May need to zero out all ebio_xxx arrays too if they are incorporated +! into CBMZ/MOSAIC. + + END SELECT bioem_select + + gas_addemiss_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2, RADM2_KPP, RADM2SORG, RACM, RACMSORG,RACM_KPP,RACMSORG_KPP, RACM_MIM_KPP,RADM2SORG_KPP) + IF(config_flags%kemit .GT. kte-ksub) THEN + message = ' EMISSIONS_DRIVER: KEMIT > KME ' + k=config_flags%kemit + write(0,*)kme,kte-ksub,k + CALL WRF_ERROR_FATAL (message) + ENDIF + call wrf_debug(15,'emissions_driver calling add_anthropogenics') + call add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,chem,& + e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl, & + e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2, & + e_pm25,e_pm10,e_nh3, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + call wrf_debug(15,'emissions_driver calling add_biogenics') + call add_biogenics(id,dtstep,dz8w,config_flags, rho_phy,chem, & + e_bio,ne_area, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + IF(config_flags%kemit .GT. kte-ksub) THEN + message = ' EMISSIONS_DRIVER: KEMIT > KME ' + CALL WRF_ERROR_FATAL (message) + ENDIF + call wrf_debug(15,'emissions_driver calling cbmz_addemiss_anthro') + call cbmz_addemiss_anthro( id, dtstep, dz8w, config_flags, & + rho_phy, chem, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + call wrf_debug(15,'emissions_driver calling cbmz_addemiss_bio') + call cbmz_addemiss_bio( id, dtstep, dz8w, config_flags, & + rho_phy, chem, e_bio, ne_area, e_iso, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (CHEM_TRACER) + do j=jts,jte + do i=its,ite + do k=kts,min(config_flags%kemit,kte-ksub) + conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +e_so2(i,k,j)*conv + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +e_co(i,k,j)*conv + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +e_co(i,k,j)*conv + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +e_co(i,k,j)*conv + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +e_co(i,k,j)*conv + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +e_co(i,k,j)*conv + end do + end do + end do + + CASE DEFAULT + call wrf_debug(15,'emissions_driver NOT CALLING gas add_... routines') + + END SELECT gas_addemiss_select + + aer_addemiss_select: SELECT CASE(config_flags%chem_opt) + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + call wrf_debug(15,'emissions_driver calling mosaic_addemiss') + call mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & + config_flags, chem, & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + call wrf_debug(15,'emissions_driver NOT CALLING aer add_... routines') + + END SELECT aer_addemiss_select + + END subroutine emissions_driver diff --git a/wrfv2_fire/chem/mechanism_driver.F b/wrfv2_fire/chem/mechanism_driver.F new file mode 100755 index 00000000..ec002781 --- /dev/null +++ b/wrfv2_fire/chem/mechanism_driver.F @@ -0,0 +1,181 @@ +!WRF:MODEL_LAYER:CHEMICS +! + subroutine mechanism_driver(id,ktau,dtstep,ktauc,dtstepc, & + config_flags,gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3,vcsulf_old, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5,ph_o2, & + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_data_radm2 + USE module_data_sorgam + USE module_data_racm + USE module_radm + USE module_racm + USE module_aerosols_sorgam + USE module_cbmz, only: cbmz_driver + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau,ktauc + REAL, INTENT(IN ) :: & + dtstep,dtstepc,gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! +! arrays that hold the photolysis rates +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5,ph_o2 +! +! RACM radicals +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd + +! +! on input from meteorological model +! + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy +! .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags +! +! for interaction of aerosls/chemistry (MADE/SORGAM only) +! + real , INTENT(INOUT ) :: & + vdrog3(ims:ime,kms:kme-0,jms:jme,ldrog) + real , INTENT(INOUT ) :: & + vcsulf_old(ims:ime,kms:kme-0,jms:jme) + + + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min +! .. +! +! select chemical mechanism +! + chem_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2) + CALL wrf_debug(15,'calling radm2 from mechanism_driver') + call radm_driver(id,ktauc,dtstepc,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (RADM2SORG) + CALL wrf_debug(15,'calling radm2 from mechanism_driver') + vcsulf_old(its:ite,kts:kte-1,jts:jte) = & + max(chem(its:ite,kts:kte-1,jts:jte,p_sulf),epsilc) + call radm_driver(id,ktauc,dtstepc,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (RACM) + CALL wrf_debug(15,'calling racm from mechanism_driver') + call racm_driver(id,ktauc,dtstepc,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (RACMSORG_KPP,RADM2SORG_KPP) + vcsulf_old(its:ite,kts:kte-1,jts:jte) = max(chem(its:ite,kts:kte-1,jts:jte,p_sulf),epsilc) + CASE (RACMSORG) + CALL wrf_debug(15,'calling racm/sorgam from mechanism_driver') + vcsulf_old(its:ite,kts:kte-1,jts:jte) = max(chem(its:ite,kts:kte-1,jts:jte,p_sulf),epsilc) + call racm_driver(id,ktauc,dtstepc,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & + CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'calling cbmz_driver from mechanism_driver') + call cbmz_driver(id,ktau,dtstep,ktauc,dtstepc, & + config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om, & + ph_ch3o2h,ph_n2o5, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT chem_select + + + END subroutine mechanism_driver diff --git a/wrfv2_fire/chem/module_aerosols_sorgam.F b/wrfv2_fire/chem/module_aerosols_sorgam.F new file mode 100644 index 00000000..e65d6b06 --- /dev/null +++ b/wrfv2_fire/chem/module_aerosols_sorgam.F @@ -0,0 +1,7361 @@ + +MODULE module_aerosols_sorgam +! + USE module_state_description + USE module_data_radm2 + USE module_data_sorgam + USE module_radm +! + IMPLICIT NONE +#define cw_species_are_in_registry + +CONTAINS + SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & + t8w,alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old, & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, & + e_so4i,e_so4j,e_no3i,e_no3j, & + vdrog3, & + kemit, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kemit, & + id,ktau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 + +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(INOUT ) :: & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, & + e_so4i,e_so4j,e_no3i,e_no3j + + REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog), & + INTENT(IN ) :: & + VDROG3 + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + alt, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + aerwrf , & + rho_phy + REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , & + INTENT(IN ) :: & + vcsulf_old + REAL, INTENT(IN ) :: & + dtstep + + REAL drog_in(ldrog) ! anthropogenic AND + ! biogenic organic + ! aerosol precursor [ug m**-3 s**-1] + + REAL condvap_in(lspcv) !bs + !rs + ! condensable vapors [ug m**-3] + REAL rgas + DATA rgas/8.314510/ + REAL convfac,convfac2 +!...BLKSIZE set to one in column model ciarev02 + + INTEGER blksize + PARAMETER (blksize=1) + +!...number of aerosol species +! number of species (gas + aerosol) + INTEGER nspcsda + PARAMETER (nspcsda=l1ae) !bs +! (internal aerosol dynamics) +!bs # of anth. cond. vapors in SORGAM + INTEGER nacv + PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM +!bs total # of cond. vapors in SORGAM + INTEGER ncv + PARAMETER (ncv=lspcv) !bs +!bs total # of cond. vapors in CTM + REAL cblk(blksize,nspcsda) ! main array of variables + ! particles [ug/m^3/s] + REAL soilrat_in + ! emission rate of soil derived coars + ! input HNO3 to CBLK [ug/m^3] + REAL nitrate_in + ! input NH3 to CBLK [ug/m^3] + REAL nh3_in + ! input SO4 vapor [ug/m^3] + REAL vsulf_in + + REAL so4rat_in + ! input SO4 formation[ug/m^3/sec] + REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize) + ! Emission rate of i-mode EC [ug m**-3 s**-1] + REAL eeci_in + ! Emission rate of j-mode EC [ug m**-3 s**-1] + REAL eecj_in + ! Emission rate of j-mode org. aerosol [ug m**- + REAL eorgi_in + + REAL eorgj_in + ! Emission rate of j-mode org. aerosol [ug m**- + ! pressure in cb + REAL pres + ! temperature in K + REAL temp + !bs + REAL relhum + ! rel. humidity (0,1) + REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1) + +!...molecular weights ciarev02 + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +!bs molecular weight for Organic Spec +! REAL mworg +! PARAMETER (mworg=175.0) + +!bs molecular weight for Elemental Ca + REAL mwec + PARAMETER (mwec=12.0) + +!rs molecular weight + REAL mwaro1 + PARAMETER (mwaro1=150.0) + +!rs molecular weight + REAL mwaro2 + PARAMETER (mwaro2=150.0) + +!rs molecular weight + REAL mwalk1 + PARAMETER (mwalk1=140.0) + +!rs molecular weight + REAL mwalk2 + PARAMETER (mwalk2=140.0) + +!rs molecular weight +!rs molecular weight + REAL mwole1 + PARAMETER (mwole1=140.0) + +!rs molecular weight + REAL mwapi1 + PARAMETER (mwapi1=200.0) + +!rs molecular weight + REAL mwapi2 + PARAMETER (mwapi2=200.0) + +!rs molecular weight + REAL mwlim1 + PARAMETER (mwlim1=200.0) + +!rs molecular weight + REAL mwlim2 + PARAMETER (mwlim2=200.0) + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + INTEGER :: i,j,k,kk,l,debug_level + +! +! convert advected aerosol variables to ug/m3 from mixing ratio +! they will be converted back at the end of this driver +! + do l=p_so4aj,num_chem + do j=jts,jte + do k=kts,kte + kk=min(k,kte-1) + do i=its,ite + chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)/alt(i,kk,j)) + enddo + enddo + enddo + enddo + do 100 j=jts,jte + do 100 i=its,ite + debug_level=0 + do k=kts,kte-1 + t(k) = t_phy(i,k,j) + p(k) = .001*p_phy(i,k,j) + rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/.01*p_phy(i,k,j)) ) + rh(k)=max(.1,0.01*rh(k)) +! rh(k) = .10 + enddo + do k=kts,kte-1 +! if(timer.gt.2.)then +! if((i.eq.12.and.j.eq.17.and.k.eq.1).or. & +! (i.eq.12.and.j.eq.7.and.k.eq.2).or. & +! (i.eq.1.and.j.eq.17.and.k.eq.2))iprt=1 +! if(debug_level.ge.1)print *,ktau,timer,i,j,k,p(k),t(k),dtstep,rgas,vcsulf_old(i,k,j),MWSO4,chem(i,k,j,p_sulf) +! endif + cblk=0. + do l=1,ldrog + drog_in(l)=0. + enddo + do l=1,lspcv + condvap_in(l)=0. + enddo + convfac = p(k)/rgas/t(k)*1000. + so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4 + soilrat_in = 0. + nitrate_in =max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3) + nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3) + vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4) + if(i.eq.23.and.j.eq.37.and.k.eq.22)then + print *,'vsulfin = ',vsulf_in,chem(i,k,j,p_sulf),convfac,mwso4 + endif + +!rs +!rs * organic aerosol precursors +!rs * anthropogenic organics DeltaROG + drog_in(PXYL ) = VDROG3(i,k,j,PXYL ) + drog_in(PTOL ) = VDROG3(i,k,j,PTOL ) + drog_in(PCSL1) = VDROG3(i,k,j,PCSL1) + drog_in(PCSL2) = VDROG3(i,k,j,PCSL2) + drog_in(PHC8 ) = VDROG3(i,k,j,PHC8 ) + drog_in(POLI1) = VDROG3(i,k,j,POLI1) + drog_in(POLI2) = VDROG3(i,k,j,POLI2) + drog_in(POLI3) = VDROG3(i,k,j,POLI3) + drog_in(POLT1) = VDROG3(i,k,j,POLT1) + drog_in(POLT2) = VDROG3(i,k,j,POLT2) + drog_in(POLT3) = VDROG3(i,k,j,POLT3) +!rs * biogenic organics DeltaROG + if(p_ete.eq.1)then + drog_in(PAPI1) = 0. + drog_in(PAPI2) = 0. + drog_in(PAPI3) = 0. + drog_in(PLIM1) = 0. + drog_in(PLIM2) = 0. + drog_in(PLIM3) = 0. + condvap_in(PSOAAPI1) = 0. + condvap_in(PSOAAPI2) = 0. + condvap_in(PSOALIM1) = 0. + condvap_in(PSOALIM2) = 0. + elseif(p_ete.gt.1)then + drog_in(PAPI1) = VDROG3(i,k,j,PAPI1) + drog_in(PAPI2) = VDROG3(i,k,j,PAPI2) + drog_in(PAPI3) = VDROG3(i,k,j,PAPI3) + drog_in(PLIM1) = VDROG3(i,k,j,PLIM1) + drog_in(PLIM2) = VDROG3(i,k,j,PLIM2) + drog_in(PLIM3) = VDROG3(i,k,j,PLIM3) + condvap_in(PSOAAPI1) = max(epsilc,cvapi1(i,k,j)) + condvap_in(PSOAAPI2) = max(epsilc,cvapi2(i,k,j)) + condvap_in(PSOALIM1) = max(epsilc,cvlim1(i,k,j)) + condvap_in(PSOALIM2) = max(epsilc,cvlim2(i,k,j)) + endif + condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j)) + condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j)) + condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j)) + condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j)) + cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j) + cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i) + cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j) + cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i) + cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j) + cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i) + cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j) + cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i) + cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j) + cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i) + cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j) + cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i) + cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j) + cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i) + cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j) + cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i) + cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj) + cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai) + cblk(1,VECJ ) = chem(i,k,j,p_ecj) + cblk(1,VECI ) = chem(i,k,j,p_eci) + cblk(1,VP25AJ ) = chem(i,k,j,p_p25j) + cblk(1,VP25AI ) = chem(i,k,j,p_p25i) + cblk(1,VANTHA ) = chem(i,k,j,p_antha) + cblk(1,VSEAS ) = chem(i,k,j,p_seas) + cblk(1,VSOILA ) = chem(i,k,j,p_soila) + cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j)) + cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j)) + cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j)) + cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j)) + cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j)) + cblk(1,VCVARO1 ) = max(epsilc,cvaro1(i,k,j)) + cblk(1,VCVARO2 ) = max(epsilc,cvaro2(i,k,j)) + cblk(1,VCVALK1 ) = max(epsilc,cvalk1(i,k,j)) + cblk(1,VCVOLE1 ) = max(epsilc,cvole1(i,k,j)) + cblk(1,VCVAPI1 ) = 0. + cblk(1,VCVAPI2 ) = 0. + cblk(1,VCVLIM1 ) = 0. + cblk(1,VCVLIM2 ) = 0. +! +! Set emissions to zero when above level kemit. +! + if( k > kemit ) then + epmcoarse(1) = 0. + epm25i(1) = 0. + epm25j (1) = 0. + eeci_in = 0. + eecj_in = 0. + eorgi_in = 0. + eorgj_in = 0. + cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj) + cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai) + cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj) + cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai) + else + epmcoarse(1) = e_pm10(i,k,j)/dz8w(i,k,j) + epm25i(1) = e_pm25i(i,k,j)/dz8w(i,k,j) + epm25j(1) = e_pm25j(i,k,j)/dz8w(i,k,j) + eeci_in = e_eci(i,k,j)/dz8w(i,k,j) + eecj_in = e_ecj(i,k,j)/dz8w(i,k,j) + eorgi_in = e_orgi(i,k,j)/dz8w(i,k,j) + eorgj_in = e_orgj(i,k,j)/dz8w(i,k,j) + cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)+e_so4j(i,k,j)/dz8w(i,k,j)*dtstep + cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)+e_so4i(i,k,j)/dz8w(i,k,j)*dtstep + cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)+e_no3j(i,k,j)/dz8w(i,k,j)*dtstep + cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)+e_no3i(i,k,j)/dz8w(i,k,j)*dtstep + end if +!rs. nitrate, nh3, sulf + cblk(1,vsulf) = vsulf_in + cblk(1,vhno3) = nitrate_in + cblk(1,vnh3) = nh3_in + cblk(1,VNH4AJ ) = chem(i,k,j,p_nh4aj) + cblk(1,VNH4AI ) = chem(i,k,j,p_nh4ai) + cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0)) + cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0)) + cblk(1,VCORN ) = chem(i,k,j,p_corn) + + + if(debug_level.ge.1)then +! if(i.eq.23.and.j.eq.37.and.k.eq.22)then + print*,'in a_mechanisms',i,j,k + print*,'NSPCSDA, BLKSIZE',NSPCSDA, BLKSIZE + print*,'k,DTA,PRES,TEMP,RELHUM',k,DTstep,10.*P(k),T(k),RH(k) + print*,'nitrate_in, nh3_in, vsulf_in, so4rat_in', & + nitrate_in, nh3_in, vsulf_in, so4rat_in + print*,'drog_in,ldrog',drog_in,ldrog + print*,'condvap_in,NCV,NACV',condvap_in,NCV,NACV + print*,'eeci_in, eecj_in, eorgi_in, eorgj_in,convfac' & + ,eeci_in, eecj_in, eorgi_in, eorgj_in,convfac + print*,'CBLK',CBLK + endif + CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh(k),nitrate_in,nh3_in, & + vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv,nacv,eeci_in,eecj_in, & + eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k) + chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ ) + chem(i,k,j,p_so4ai) = cblk(1,VSO4AI ) + chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ ) + chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI ) + chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ ) + chem(i,k,j,p_no3ai) = cblk(1,VNO3AI ) + chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J) + chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I) + chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J) + chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I) + chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J) + chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I) + chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J) + chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I) + chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J ) + chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I ) + chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J ) + chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I ) + chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J ) + chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I ) + chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J ) + chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I ) + chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ ) + chem(i,k,j,p_orgpai) = cblk(1,VORGPAI ) + chem(i,k,j,p_ecj) = cblk(1,VECJ ) + chem(i,k,j,p_eci) = cblk(1,VECI ) + chem(i,k,j,p_p25j) = cblk(1,VP25AJ ) + chem(i,k,j,p_p25i) = cblk(1,VP25AI ) + chem(i,k,j,p_antha) =cblk(1,VANTHA ) + chem(i,k,j,p_seas) = cblk(1,VSEAS ) + chem(i,k,j,p_soila) = cblk(1,VSOILA ) + chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 )) + chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 )) +! chem(i,k,j,p_ac0) = cblk(1,VAC0 ) + chem(i,k,j,p_corn) = cblk(1,VCORN ) + h2oaj(i,k,j) = cblk(1,VH2OAJ ) + h2oai(i,k,j) = cblk(1,VH2OAI ) + nu3(i,k,j) = cblk(1,VNU3 ) + ac3(i,k,j) = cblk(1,VAC3 ) + cor3(i,k,j) = cblk(1,VCOR3 ) + cvaro1(i,k,j) = cblk(1,VCVARO1 ) + cvaro2(i,k,j) = cblk(1,VCVARO2 ) + cvalk1(i,k,j) = cblk(1,VCVALK1 ) + cvole1(i,k,j) = cblk(1,VCVOLE1 ) + cvapi1(i,k,j) = 0. + cvapi2(i,k,j) = 0. + cvlim1(i,k,j) = 0. + cvlim2(i,k,j) = 0. + chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4) + chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3) + chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3) + enddo ! k-loop + 100 continue ! i,j-loop + +! +! convert aerosol variables back to mixing ratio from ug/m3 +! + do l=p_so4aj,num_chem + do j=jts,jte + do k=kts,kte + kk=min(k,kte-1) + do i=its,ite + chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)*alt(i,kk,j)) + enddo + enddo + enddo + enddo + + END SUBROUTINE sorgam_driver +! /////////////////////////////////////////////////// + SUBROUTINE sum_pm_sorgam ( & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt,h2oaj,h2oai + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10 + + INTEGER :: i,ii,j,jj,k,kk,n +! +! sum up pm2_5 and pm10 output +! + pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0. + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte-1 + kk=min(kde-1,k) + do i=its,ite + ii=min(ide-1,i) + do n=p_so4aj,p_p25i + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,kk,jj,n) + enddo + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,kk,jj,p_ecj) & + + chem(ii,kk,jj,p_eci) + pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) & + + h2oai(i,k,j) + + !Convert the units from mixing ratio to concentration (ug m^-3) + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,kk,jj) + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,kk,jj) + pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,kk,jj) + enddo + enddo + enddo + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte-1 + kk=min(kde-1,k) + do i=its,ite + ii=min(ide-1,i) + pm10(i,k,j) = pm2_5_dry(i,k,j) & + + ( chem(ii,kk,jj,p_antha) & + + chem(ii,kk,jj,p_soila) & + + chem(ii,kk,jj,p_seas) ) / alt(ii,kk,jj) + enddo + enddo + enddo + END SUBROUTINE sum_pm_sorgam +! /////////////////////////////////////////////////// + SUBROUTINE sorgam_depdriver (id,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & + aer_res,vgsa, & + numaer, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + INTEGER, INTENT(IN ) :: & + numaer, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id,ktau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( its:ite, jts:jte, numaer ), & + INTENT(INOUT ) :: & + vgsa + REAL, DIMENSION( its:ite, jts:jte ), & + INTENT(INOUT ) :: & + aer_res + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + alt, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ust + REAL, INTENT(IN ) :: & + dtstep + + REAL rgas + DATA rgas/8.314510/ + REAL convfac,convfac2 +!...BLKSIZE set to one in column model ciarev02 + + INTEGER blksize + PARAMETER (blksize=1) + +!...number of aerosol species +! number of species (gas + aerosol) + INTEGER nspcsda + PARAMETER (nspcsda=l1ae) !bs +! (internal aerosol dynamics) +!bs # of anth. cond. vapors in SORGAM + INTEGER nacv + PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM +!bs total # of cond. vapors in SORGAM + INTEGER ncv + PARAMETER (ncv=lspcv) !bs +!bs total # of cond. vapors in CTM + REAL cblk(blksize,nspcsda) ! main array of variables + ! particles [ug/m^3/s] + REAL soilrat_in + ! emission rate of soil derived coars + ! input HNO3 to CBLK [ug/m^3] + REAL nitrate_in + ! input NH3 to CBLK [ug/m^3] + REAL nh3_in + ! input SO4 vapor [ug/m^3] + REAL vsulf_in + + REAL so4rat_in + ! input SO4 formation[ug/m^3/sec] + ! pressure in cb + REAL pres + ! temperature in K + REAL temp + !bs + REAL relhum + ! rel. humidity (0,1) + REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1) + +!...molecular weights ciarev02 + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +!bs molecular weight for Organic Spec +! REAL mworg +! PARAMETER (mworg=175.0) + +!bs molecular weight for Elemental Ca + REAL mwec + PARAMETER (mwec=12.0) + +!rs molecular weight + REAL mwaro1 + PARAMETER (mwaro1=150.0) + +!rs molecular weight + REAL mwaro2 + PARAMETER (mwaro2=150.0) + +!rs molecular weight + REAL mwalk1 + PARAMETER (mwalk1=140.0) + +!rs molecular weight + REAL mwalk2 + PARAMETER (mwalk2=140.0) + +!rs molecular weight +!rs molecular weight + REAL mwole1 + PARAMETER (mwole1=140.0) + +!rs molecular weight + REAL mwapi1 + PARAMETER (mwapi1=200.0) + +!rs molecular weight + REAL mwapi2 + PARAMETER (mwapi2=200.0) + +!rs molecular weight + REAL mwlim1 + PARAMETER (mwlim1=200.0) + +!rs molecular weight + REAL mwlim2 + PARAMETER (mwlim2=200.0) + INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model) +!ia kept to 1 in current version of column model + + PARAMETER( NUMCELLS = 1) + + + REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ] + REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ] + REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ] + + REAL BLKPRS(BLKSIZE) ! pressure in cb + REAL BLKTA(BLKSIZE) ! temperature in K + REAL BLKDENS(BLKSIZE) ! Air density in kg/m3 + +! +! *** OUTPUT: +! +! *** atmospheric properties + + REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ] + REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ] + +! *** followng is for future version + REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ] + REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ] + +! *** modal diameters: [ m ] + + REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ] + REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ] + REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ] + + +! *** aerosol properties: + +! *** Modal mass concentrations [ ug m**3 ] + + REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode + REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode + REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode + +! *** average modal particle densities [ kg/m**3 ] + + REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode + REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode + REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode + +! *** average modal Knudsen numbers + + REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number + REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number + REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + INTEGER :: i,j,k,l +! +! print *,'in sorgdepdriver ',its,ite,jts,jte + do l=1,numaer + do i=its,ite + do j=jts,jte + vgsa(i,j,l)=0. + enddo + enddo + enddo + vdep=0. + do 100 j=jts,jte + do 100 i=its,ite + cblk=epsilc + do k=kts,kte-1 + t(k) = t_phy(i,k,j) + p(k) = .001*p_phy(i,k,j) + rh(k) = MIN( 100.,100. * moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rh(k)=max(.05,0.01*rh(k)) + enddo +! do k=kts,kte-1 + k=kts + convfac = p(k)/rgas/t(k)*1000. + nitrate_in =chem(i,k,j,p_hno3)*convfac*mwhno3 + nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3 + vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4 + +!rs. nitrate, nh3, sulf + BLKPRS(BLKSIZE) = P(K) ! pressure in hPa + BLKTA(BLKSIZE) = T(K) ! temperature in K + BLKDENS(BLKSIZE)=BLKPRS(BLKSIZE)/(RDGAS * BLKTA(BLKSIZE)) + USTAR(BLKSIZE) = max(1.e-8,UST(i,j)) + WSTAR(BLKSIZE) = 0. + convfac2=1./alt(i,k,j) + cblk(1,vsulf) = max(epsilc,vsulf_in) + cblk(1,vhno3) = max(epsilc,nitrate_in) + cblk(1,vnh3) = max(epsilc,nh3_in) + cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2) + cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2) + cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2) + cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2) + cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2) + cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2) + cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2) + cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2) + cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2) + cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2) + cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2) + cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2) + cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2) + cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2) + cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2) + cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2) + cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2) + cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2) + cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2) + cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2) + cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2) + cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2) + cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2) + cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2) + cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2) + cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2) + cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2) + cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2) + cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2) + cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2) + cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2) + cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2) + cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2) + cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2) + cblk(1,VH2OAJ ) = h2oaj(i,k,j) + cblk(1,VH2OAI ) = h2oai(i,k,j) + cblk(1,VNU3 ) = nu3(i,k,j) + cblk(1,VAC3 ) = ac3(i,k,j) + cblk(1,VCOR3 ) = cor3(i,k,j) + cblk(1,VCVARO1 ) = cvaro1(i,k,j) + cblk(1,VCVARO2 ) = cvaro2(i,k,j) + cblk(1,VCVALK1 ) = cvalk1(i,k,j) + cblk(1,VCVOLE1 ) = cvole1(i,k,j) + cblk(1,VCVAPI1 ) = 0. + cblk(1,VCVAPI2 ) = 0. + cblk(1,VCVLIM1 ) = 0. + cblk(1,VCVLIM2 ) = 0. +! cblk(1,VCVAPI1 ) = cvapi1(i,k,j) +! cblk(1,VCVAPI2 ) = cvapi2(i,k,j) +! cblk(1,VCVLIM1 ) = cvlim1(i,k,j) +! cblk(1,VCVLIM2 ) = cvlim2(i,k,j) +! +!rs. get size distribution information +! +! if(i.eq.126.and.j.eq.99)then +! print *,'in modpar ',i,j +! print *,cblk,BLKTA,BLKPRS,USTAR +! print *,'BLKSIZE, NSPCSDA, NUMCELLS' +! print *,BLKSIZE, NSPCSDA, NUMCELLS +! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC' +! print *,XLM, AMU,PDENSN, PDENSA, PDENSC +! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai +! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai) +! endif + + CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, & + CBLK, & + BLKTA, BLKPRS, & + PMASSN, PMASSA, PMASSC, & + PDENSN, PDENSA, PDENSC, & + XLM, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR ) +! print *,'out modpar ',i,j + CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, & + BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC ) + VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC ) + VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR ) + VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA ) + VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA ) + VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC ) + VGSA(i, j, VAC0 ) = VDEP(1, VDNACC ) + VGSA(i, j, VCORN ) = VDEP(1, VDNCOR ) +! enddo ! k-loop + 100 continue ! i,j-loop + +END SUBROUTINE sorgam_depdriver +! /////////////////////////////////////////////////// + SUBROUTINE actcof(cat,an,gama,molnu,phimult) + +!----------------------------------------------------------------------- + +! DESCRIPTION: + +! This subroutine computes the activity coefficients of (2NH4+,SO4--), +! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous +! multicomponent solution, using Bromley's model and Pitzer's method. + +! REFERENCES: + +! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes +! in aqueous solutions. AIChE J. 19, 313-320. + +! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of +! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673. + +! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures +! of strong acids over saline solutions - I HNO3, +! Atmos. Environ. (22): 91-100 + +! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures +! and mean activity and osmotic coefficients of 0-100% nitric acid +! as a function of temperature, J. Phys. Chem (94): 5369 - 5380 + +! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a +! general equilibrium model for inorganic multicomponent atmospheric +! aerosols. Atmos. Environ. 21(11), 2453-2466. + + + + +! ARGUMENT DESCRIPTION: + +! CAT(1) : conc. of H+ (moles/kg) +! CAT(2) : conc. of NH4+ (moles/kg) +! AN(1) : conc. of SO4-- (moles/kg) +! AN(2) : conc. of NO3- (moles/kg) +! AN(3) : conc. of HSO4- (moles/kg) +! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--) +! GAMA(2,2) : (NH4+,NO3-) +! GAMA(2,3) : (NH4+. HSO4-) +! GAMA(1,1) : (2H+,SO4--) +! GAMA(1,2) : (H+,NO3-) +! GAMA(1,3) : (H+,HSO4-) +! MOLNU : the total number of moles of all ions. +! PHIMULT : the multicomponent paractical osmotic coefficient. + +! REVISION HISTORY: +! Who When Detailed description of changes +! --------- -------- ------------------------------------------- +! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this +! new routine using a method described by Pilini +! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24 +! S.Roselle 7/30/97 Modified for use in Models-3 +! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA + +!----------------------------------------------------------------------- + +! IMPLICIT NONE + +!...........INCLUDES and their descriptions + +! INCLUDE SUBST_XSTAT ! M3EXIT status codes +!.................................................................... + +! Normal, successful completion + INTEGER xstat0 + PARAMETER (xstat0=0) +! File I/O error + INTEGER xstat1 + PARAMETER (xstat1=1) +! Execution error + INTEGER xstat2 + PARAMETER (xstat2=2) +! Special error + INTEGER xstat3 + PARAMETER (xstat3=3) + + CHARACTER*120 xmsg + +!...........PARAMETERS and their descriptions: + +! number of cations + INTEGER ncat + PARAMETER (ncat=2) + +! number of anions + INTEGER nan + PARAMETER (nan=3) + +!...........ARGUMENTS and their descriptions + +! tot # moles of all ions + REAL molnu +! multicomponent paractical osmo + REAL phimult + REAL cat(ncat) ! cation conc in moles/kg (input + REAL an(nan) ! anion conc in moles/kg (input) + REAL gama(ncat,nan) +!...........SCRATCH LOCAL VARIABLES and their descriptions: + +! mean molal ionic activity coef + CHARACTER*16 & ! driver program name + pname + SAVE pname + +! anion indX + INTEGER ian + + INTEGER icat +! cation indX + + REAL fgama +! ionic strength + REAL i + + REAL r + + REAL s + + REAL ta + + REAL tb + + REAL tc + + REAL texpv + + REAL trm +! 2*ionic strength + REAL twoi +! 2*sqrt of ionic strength + REAL twosri + + REAL zbar + + REAL zbar2 + + REAL zot1 +! square root of ionic strength + REAL sri + REAL f2(ncat) + REAL f1(nan) + REAL zp(ncat) ! absolute value of charges of c + REAL zm(nan) ! absolute value of charges of a + REAL bgama(ncat,nan) + REAL x(ncat,nan) + REAL m(ncat,nan) ! molality of each electrolyte + REAL lgama0(ncat,nan) ! binary activity coefficients + REAL y(nan,ncat) + REAL beta0(ncat,nan) ! binary activity coefficient pa + REAL beta1(ncat,nan) ! binary activity coefficient pa + REAL cgama(ncat,nan) ! binary activity coefficient pa + REAL v1(ncat,nan) ! number of cations in electroly + REAL v2(ncat,nan) +! number of anions in electrolyt + DATA zp/1.0, 1.0/ + DATA zm/2.0, 1.0, 1.0/ + DATA xmsg/' '/ + DATA pname/'ACTCOF'/ + +! *** Sources for the coefficients BETA0, BETA1, CGAMA: + +! *** (1,1);(1,3) - Clegg & Brimblecombe (1988) +! *** (2,3) - Pilinis & Seinfeld (1987), cgama different +! *** (1,2) - Clegg & Brimblecombe (1990) +! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992) + +! *** now set the basic constants, BETA0, BETA1, CGAMA + + DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 & + / +! 2H+SO4 + DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 & + / +! HNO3 + DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 & + / +! H+HSO4 + DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/, & + cgama(2,1)/ -1.2683E-3 & + / +! (NH4)2 + DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/, & + cgama(2,2)/3.51217E-5 & + / +! NH4NO3 + DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 & + / +! NH4HSO + DATA v1(1,1), v2(1,1)/2.0, 1.0 & ! 2H+SO4- + / + DATA v1(2,1), v2(2,1)/2.0, 1.0 & ! (NH4)2SO4 + / + DATA v1(1,2), v2(1,2)/1.0, 1.0 & ! HNO3 + / + DATA v1(2,2), v2(2,2)/1.0, 1.0 & ! NH4NO3 + / + DATA v1(1,3), v2(1,3)/1.0, 1.0 & ! H+HSO4- + / + DATA v1(2,3), v2(2,3)/1.0, 1.0 & + / +!----------------------------------------------------------------------- +! begin body of subroutine ACTCOF + +!...compute ionic strength + +! NH4HSO4 + i = 0.0 + + DO icat = 1, ncat + i = i + cat(icat)*zp(icat)*zp(icat) + END DO + + DO ian = 1, nan + i = i + an(ian)*zm(ian)*zm(ian) + END DO + + i = 0.5*i + +!...check for problems in the ionic strength + + IF (i==0.0) THEN + + DO ian = 1, nan + DO icat = 1, ncat + gama(icat,ian) = 0.0 + END DO + END DO + +! xmsg = 'Ionic strength is zero...returning zero activities' +! WRITE (6,*) xmsg + RETURN + + ELSE IF (i<0.0) THEN +! xmsg = 'Ionic strength below zero...negative concentrations' + CALL wrf_error_fatal ( xmsg ) + END IF + +!...compute some essential expressions + + sri = sqrt(i) + twosri = 2.0*sri + twoi = 2.0*i + texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi) + r = 1.0 + 0.75*i + s = 1.0 + 1.5*i + zot1 = 0.511*sri/(1.0+sri) + +!...Compute binary activity coeffs + + fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri))) + + DO icat = 1, ncat + DO ian = 1, nan + + bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) & + )*texpv + +!...compute the molality of each electrolyte for given ionic strength + + m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** & + (1.0/(v1(icat,ian)+v2(icat,ian))) + +!...calculate the binary activity coefficients + + lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, & + ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, & + ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* & + v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, & + ian)))/2.302585093 + + END DO + END DO + +!...prepare variables for computing the multicomponent activity coeffs + + DO ian = 1, nan + DO icat = 1, ncat + zbar = (zp(icat)+zm(ian))*0.5 + zbar2 = zbar*zbar + y(ian,icat) = zbar2*an(ian)/i + x(icat,ian) = zbar2*cat(icat)/i + END DO + END DO + + DO ian = 1, nan + f1(ian) = 0.0 + DO icat = 1, ncat + f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + & + zot1*zp(icat)*zm(ian)*x(icat,ian) + END DO + END DO + + DO icat = 1, ncat + f2(icat) = 0.0 + DO ian = 1, nan + f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + & + zot1*zp(icat)*zm(ian)*y(ian,icat) + END DO + END DO + +!...now calculate the multicomponent activity coefficients + + DO ian = 1, nan + DO icat = 1, ncat + + ta = -zot1*zp(icat)*zm(ian) + tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian)) + tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian)) + trm = ta + tb*tc + + IF (trm>30.0) THEN + gama(icat,ian) = 1.0E+30 +! xmsg = 'Multicomponent activity coefficient is extremely large' +! WRITE (6,*) xmsg + ELSE + gama(icat,ian) = 10.0**trm + END IF + + END DO + END DO + + RETURN +!ia********************************************************************* + END SUBROUTINE actcof +!ia +!ia AEROSOL DYNAMICS DRIVER ROUTINE * +!ia based on MODELS3 formulation by FZB +!ia Modified by IA in November 97 +!ia +!ia Revision history +!ia When WHO WHAT +!ia ---- ---- ---- +!ia ???? FZB BEGIN +!ia 05/97 IA Adapted for use in CTM2-S +!ia 11/97 IA Modified for new model version +!ia see comments under iarev02 +!ia +!ia Called BY: RPMMOD3 +!ia +!ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP +!ia GETVSED +!ia +!ia********************************************************************* +! actcof + SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, & + blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat, & + orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,epm25i, & + epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, & + dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, & + kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, & + ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid) + + + + +! IMPLICIT NONE +! dimension of arrays + INTEGER blksize +! number of species in CBLK + INTEGER nspcsda +! actual number of cells in arrays + INTEGER numcells +! number of k-level + INTEGER layer +! of organic aerosol precursor + INTEGER ldrog + REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a + + REAL dt +! *** Meteorological information: + +! synchronization time [s] + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL blkdens(blksize) ! Air density [ kg/ m**3 ] + REAL blkrh(blksize) +! *** Chemical production rates: [ ug / m**3 s ] + +! Fractional relative humidity + REAL so4rat(blksize) +!bs +! sulfate gas-phase production rate +! total # of cond. vapors & SOA species + INTEGER ncv +!bs + INTEGER nacv +!bs * organic condensable vapor production rate +! # of anthrop. cond. vapors & SOA speci + REAL drog(blksize,ldrog) !bs +! *** anthropogenic organic aerosol mass production rates from aromatics +! Delta ROG conc. [ppm] + REAL orgaro1rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from aromatics + REAL orgaro2rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from alkanes & + REAL orgalk1rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from alkenes & + REAL orgole1rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio1rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio2rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio3rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio4rat(blksize) + +! *** Primary emissions rates: [ ug / m**3 s ] + +! *** emissions rates for unidentified PM2.5 mass + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** emissions rates for coarse mode particles +! Accumululaton mode + REAL esoil(blksize) ! soil derived coarse aerosols + REAL eseas(blksize) ! marine coarse aerosols + REAL epmcoarse(blksize) + +! *** OUTPUT: + +! *** atmospheric properties + +! anthropogenic coarse aerosols + REAL xlm(blksize) ! atmospheric mean free path [ m ] + REAL amu(blksize) +! *** modal diameters: [ m ] + +! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! nuclei mode geometric mean diamete + REAL dgacc(blksize) ! accumulation geometric mean diamet + REAL dgcor(blksize) + +! *** aerosol properties: + +! *** Modal mass concentrations [ ug m**3 ] + +! coarse mode geometric mean diamete + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) +! *** average modal particle densities [ kg/m**3 ] + +! mass concentration in coarse mode + REAL pdensn(blksize) ! average particle density in nuclei + REAL pdensa(blksize) ! average particle density in accumu + REAL pdensc(blksize) +! *** average modal Knudsen numbers + +! average particle density in coarse + REAL knnuc(blksize) ! nuclei mode Knudsen number + REAL knacc(blksize) ! accumulation Knudsen number + REAL kncor(blksize) +! *** modal condensation factors ( see comments in NUCLCOND ) + +! coarse mode Knudsen number + REAL fconcn(blksize) + REAL fconca(blksize) +!bs + REAL fconcn_org(blksize) + REAL fconca_org(blksize) +!bs + +! *** Rates for secondary particle formation: + +! *** production of new mass concentration [ ug/m**3 s ] + REAL dmdt(blksize) ! by particle formation + +! *** production of new number concentration [ number/m**3 s ] + +! rate of production of new mass concen + REAL dndt(blksize) ! by particle formation + +! *** growth rate for third moment by condensation of precursor +! vapor on existing particles [ 3rd mom/m**3 s ] + +! rate of producton of new particle num + REAL cgrn3(blksize) ! Aitken mode + REAL cgra3(blksize) +! *** Rates for coaglulation: [ m**3/s ] + +! *** Unimodal Rates: + +! Accumulation mode + REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra + REAL ura00(blksize) + +! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod + +! accumulation mode 0th moment self-coagulat + REAL brna01(blksize) +! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS +! rate for 0th moment + REAL c30(blksize) ! by intermodal c + +! *** other processes + +! intermodal 3rd moment transfer r + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u + + +! INTEGER NN, VV ! loop indICES + +! increment of concentration added to +! ////////////////////// Begin code /////////////////////////////////// + + + + +! concentration lower limit + CHARACTER*16 pname + PARAMETER (pname=' AEROPROC ') + + INTEGER unit + PARAMETER (unit=20) + integer igrid,jgrid,kgrid + + + + +! *** get water, ammonium and nitrate content: +! for now, don't call if temp is below -40C (humidity +! for this wrf version is already limited to 10 percent) + + if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then + CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh) + endif + +! *** get size distribution information: + + CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, & + pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, & + kncor) + +! *** Calculate coagulation rates for fine particles: + + CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, & + dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30) + + +! *** get condensation and particle formation (nucleation) rates: + + CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, & + so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, & + orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, & + fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3) + + if(dndt(1).lt.-10.)print*,'dndt in aeroproc',dndt + +! *** advance forward in time DT seconds: + CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,orgaro1rat, & + orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat, & + orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, & + dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, & + dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid) + + +! *** get new distribution information: + + CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, & + pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, & + kncor) + + RETURN + END SUBROUTINE aeroproc +!////////////////////////////////////////////////////////////////// +! *** Time stepping code advances the aerosol moments one timestep; + + + SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat & + ,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat & + ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas & + ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn & + ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, & + igrid,jgrid,kgrid & + ) + +!*********************************************************************** + +! NOTE: + +! *** DESCRIPTION: Integrate the Number and Mass equations +! for each mode over the time interval DT. + +! PRECONDITIONS: +! AEROSTEP() must follow calls to all other dynamics routines. + +! *** Revision history: +! Adapted 3/95 by UAS and CJC from EAM2's code. +! Revised 7/29/96 by FSB to use block structure +! Revised 11/15/96 by FSB dropped flow-through and cast +! number solver into Riccati equation form. +! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mo +! each predicted rather than total mass and +! Aitken mode mass. Also used a local approximati +! the error function. Also added coarse mode. +! Revised 9/18/97 by FSB to fix mass transfer from Aitken to +! accumulation mode by coagulation +! Revised 10/27/97 by FSB to modify code to use primay emissions +! and to correct 3rd moment updates. +! Also added coarse mode. +! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5 +! Revised 11/5/97 by FSB to fix error in MSTRNSFR +! Revised 11/6/97 FSB to correct the expression for FACTRANS to +! remove the 6/pi coefficient. UAS found this. +! Revised 12/15/97 by FSB to change equations for mass concentrati +! to a chemical production form with analytic +! solutions for the Aitken mode and to remove +! time stepping of the 3rd moments. The mass conc +! in the accumulation mode is updated with a forw +! Euler step. +! Revised 1/6/98 by FSB Lowered minimum concentration for +! sulfate aerosol to 0.1 [ ng / m**3 ]. +! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represen +! intermodal transfer rate of 3rd moment in place +! of 3rd moment coagulation rate. +! Revised 5/5/98 added new renaming criterion based on diameters +! Added 3/23/98 by BS condensational groth factors for organics + +!********************************************************************** + +! IMPLICIT NONE + +! Includes: + + + +! *** ARGUMENTS: + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells +! nmber of species in CBLK + INTEGER nspcsda +! model layer + INTEGER layer + REAL cblk(blksize,nspcsda) ! main array of variables + INTEGER igrid,jgrid,kgrid + REAL dt +! *** Chemical production rates: [ ug / m**3 s ] + +! time step [sec] + REAL so4rat(blksize) +! *** anthropogenic organic aerosol mass production rates from aromatics +! sulfate gas-phase production rate + REAL orgaro1rat(blksize) + REAL orgaro2rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from alkanes & + REAL orgalk1rat(blksize) + REAL orgole1rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio1rat(blksize) + REAL orgbio2rat(blksize) + REAL orgbio3rat(blksize) + REAL orgbio4rat(blksize) + +! *** Primary emissions rates: [ ug / m**3 s ] + +! *** emissions rates for unidentified PM2.5 mass + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** emissions rates for coarse mode particles +! Accumululaton mode + REAL esoil(blksize) ! soil derived coarse aerosols + REAL eseas(blksize) ! marine coarse aerosols + REAL epmcoarse(blksize) +! anthropogenic coarse aerosols + REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ] + REAL dgacc(blksize) +! accumulation + REAL fconcn(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate + REAL fconca(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate + REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate for organ + REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate for organ + REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ] +! rate of production of new mass concent + REAL dndt(blksize) ! by particle formation [ number/m**3 /s +! rate of producton of new particle numb + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m +! increment of concentration added to + REAL urn00(blksize) ! Aitken intramodal coagulation rate + REAL ura00(blksize) ! Accumulation mode intramodal coagulati + REAL brna01(blksize) ! bimodal coagulation rate for number + REAL c30(blksize) ! by intermodal coagulation +! intermodal 3rd moment transfer rate by + REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken + REAL cgra3(blksize) +! *** Modal mass concentrations [ ug m**3 ] + +! growth rate for 3rd moment for Accumul + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) + +! *** Local Variables + +! mass concentration in coarse mode + INTEGER l, lcell, & + spc +! ** following scratch variables are used for solvers + + + +! *** variables needed for modal dynamics solvers: + +! Loop indices + REAL*8 a, b, c + REAL*8 m1, m2, y0, y + REAL*8 dhat, p, pexpdt, expdt + REAL*8 loss, prod, pol, lossinv +! mass intermodal transfer by coagulation + REAL mstrnsfr + + REAL factrans + +! *** CODE additions for renaming + REAL getaf2 + REAL aaa, xnum, xm3, fnum, fm3, phnum, & ! Defined below + phm3 + REAL erf, & ! Error and complementary error function + erfc + + REAL xx +! dummy argument for ERF and ERFC +! a numerical value for a minimum concentration + +! *** This value is smaller than any reported tropospheric concentration + + +! ::::::::::::::::::::::::::::::::::::: +! *** Statement function given for error function. Source is +! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet +! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec +! 20:253-265. They cite Reasearch & Education Asociation (REA), (19 +! Handbook of Mathematical, Scientific, and Engineering Formulas, +! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49 + + erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs)) + erfc(xx) = 1.0 - erf(xx) +! :::::::::::::::::::::::::::::::::::::::: + + +! ///// begin code + + + + +! *** set up time-step integration + + DO l = 1, numcells + +! *** code to move number forward by one time step. +! *** solves the Ricatti equation: + +! dY/dt = C - A * Y ** 2 - B * Y + +! Coded 11/21/96 by Dr. Francis S. Binkowski + +! *** Aitken mode: + +! *** coefficients + + a = urn00(l) + b = brna01(l)*cblk(l,vac0) + c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l)) + +! includes primary emissions + y0 = cblk(l,vnu0) +! *** trap on C = 0 + +! initial condition + IF (c>0.0D0) THEN + + dhat = sqrt(b*b+4.0D0*a*c) + + m1 = 2.0D0*a*c/(b+dhat) + + m2 = -0.5D0*(b+dhat) + + p = -(m1-a*y0)/(m2-a*y0) + + pexpdt = p*exp(-dhat*dt) + + y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) +! solution + ELSE + +! *** rearrange solution for NUMERICAL stability +! note If B << A * Y0, the following form, although +! seemingly awkward gives the correct answer. + + expdt = exp(-b*dt) + IF (expdt<1.0D0) THEN + y = b*y0*expdt/(b+a*y0*(1.0D0-expdt)) + ELSE + y = y0 + END IF + + END IF + if(y.lt.nummin_i)then + print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)' + print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid + print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l) + endif + + cblk(l,vnu0) = max(nummin_i,y) + +! *** now do accumulation mode number + +! *** coefficients + +! update + a = ura00(l) + b = & ! NOTE B = 0.0 + 0.0D0 + c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l)) +! includes primary emissi + y0 = cblk(l,vac0) +! *** this equation requires special handling, because C can be zero. +! if this happens, the form of the equation is different: + +! initial condition +! print *,vac0,y0,c,nummin_j,a + IF (c>0.0D0) THEN + + dhat = sqrt(4.0D0*a*c) + + m1 = 2.0D0*a*c/dhat + + m2 = -0.5D0*dhat + + p = -(m1-a*y0)/(m2-a*y0) + +! print *,p,-dhat,dt,-dhat*dt +! print *,exp(-dhat*dt) + pexpdt = p*exp(-dhat*dt) + + y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) +! solution + ELSE + + y = y0/(1.0D0+dt*a*y0) +! print *,dhat,y0,dt,a + y = y0/(1.+dt*a*y0) +! print *,y +! correct solution to equatio + END IF + + cblk(l,vac0) = max(nummin_j,y) +! *** now do coarse mode number neglecting coagulation +! update +! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l) + prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l) + +! print *,cblk(l,vcorn),factnumc,prod + cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt + + +! *** Prepare to advance modal mass concentration one time step. + +! *** Set up production and and intermodal transfer terms terms: +! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l) + cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l) + +! includes growth from pri + cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + & + orgfac*eorgj(l) ! and transfer of 3rd momen + ! intermodal coagulation + +! *** set up transfer coefficients for coagulation between Aitken and ac + + +! *** set up special factors for mass transfer from the Aitken to accumu +! intermodal coagulation. The mass transfer rate is proportional to +! transfer rate, C30. The proportionality factor is p/6 times the th +! density. The average particle density for a species is the species +! divided by the particle volume concentration, pi/6 times the 3rd m +! The p/6 coefficients cancel. + +! includes growth from prim +! print *,'loss',vnu3,c30(l),cblk(l,vnu3) + loss = c30(l)/cblk(l,vnu3) + +! Normalized coagulation transfer r + factrans = loss* & ! yields an estimate of the amount of mass t + dt + ! the Aitken to the accumulation mode in the + +! Multiplying this factor by the species con +! print *,'factrans = ',factrans,loss + expdt = exp(-factrans) ! decay term is common to all Aitken mode +! print *,'factrans = ',factrans,loss,expdt +! variable name is re-used here. This expo + lossinv = 1.0/ & + loss +! *** now advance mass concentrations one time step. + + +! *** update sulfuric acid vapor concentration by removing mass concent +! condensed sulfate and newly produced particles. +! *** The method follows Youngblood and Kreidenweis, Further Development +! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep +! Atmospheric Science Paper Number 550, April,1994, pp 85-89. +! set up for multiplication rather than divi + cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt)) + + +! *** Solve Aitken-mode equations of form: dc/dt = P - L*c +! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt) + +! *** sulfate: + + mstrnsfr = cblk(l,vso4ai)*factrans + prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass + + pol = prod*lossinv +! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr + + cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt + + cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai)) + + cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr + +! *** anthropogenic secondary organic: +!bs * anthropogenic secondary organics from aromatic precursors + + mstrnsfr = cblk(l,vorgaro1i)*factrans + prod = orgaro1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgaro1i) = pol + (cblk(l,vorgaro1i)-pol)*expdt + + cblk(l,vorgaro1i) = max(conmin,cblk(l,vorgaro1i)) + + cblk(l,vorgaro1j) = cblk(l,vorgaro1j) + orgaro1rat(l)*fconca_org(l)*dt & + + mstrnsfr +!bs * second species from aromatics + mstrnsfr = cblk(l,vorgaro2i)*factrans + prod = orgaro2rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgaro2i) = pol + (cblk(l,vorgaro2i)-pol)*expdt + + cblk(l,vorgaro2i) = max(conmin,cblk(l,vorgaro2i)) + + cblk(l,vorgaro2j) = cblk(l,vorgaro2j) + orgaro2rat(l)*fconca_org(l)*dt & + + mstrnsfr + +!bs * anthropogenic secondary organics from alkanes & other precursors +!bs * higher alkanes + mstrnsfr = cblk(l,vorgalk1i)*factrans + prod = orgalk1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgalk1i) = pol + (cblk(l,vorgalk1i)-pol)*expdt + + cblk(l,vorgalk1i) = max(conmin,cblk(l,vorgalk1i)) + + cblk(l,vorgalk1j) = cblk(l,vorgalk1j) + orgalk1rat(l)*fconca_org(l)*dt & + + mstrnsfr +!bs * higher olefines + mstrnsfr = cblk(l,vorgole1i)*factrans + prod = orgole1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgole1i) = pol + (cblk(l,vorgole1i)-pol)*expdt + + cblk(l,vorgole1i) = max(conmin,cblk(l,vorgole1i)) + + cblk(l,vorgole1j) = cblk(l,vorgole1j) + orgole1rat(l)*fconca_org(l)*dt & + + mstrnsfr + +! *** biogenic secondary organic + + mstrnsfr = cblk(l,vorgba1i)*factrans + prod = orgbio1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgba1i) = pol + (cblk(l,vorgba1i)-pol)*expdt + + cblk(l,vorgba1i) = max(conmin,cblk(l,vorgba1i)) + + cblk(l,vorgba1j) = cblk(l,vorgba1j) + orgbio1rat(l)*fconca_org(l)*dt + & + mstrnsfr +!bs * second biogenic species + mstrnsfr = cblk(l,vorgba2i)*factrans + prod = orgbio2rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgba2i) = pol + (cblk(l,vorgba2i)-pol)*expdt + + cblk(l,vorgba2i) = max(conmin,cblk(l,vorgba2i)) + + cblk(l,vorgba2j) = cblk(l,vorgba2j) + orgbio2rat(l)*fconca_org(l)*dt + & + mstrnsfr + +!bs * third biogenic species + mstrnsfr = cblk(l,vorgba3i)*factrans + prod = orgbio3rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgba3i) = pol + (cblk(l,vorgba3i)-pol)*expdt + + cblk(l,vorgba3i) = max(conmin,cblk(l,vorgba3i)) + + cblk(l,vorgba3j) = cblk(l,vorgba3j) + orgbio3rat(l)*fconca_org(l)*dt + & + mstrnsfr + +!bs * fourth biogenic species + mstrnsfr = cblk(l,vorgba4i)*factrans + prod = orgbio4rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vorgba4i) = pol + (cblk(l,vorgba4i)-pol)*expdt + + cblk(l,vorgba4i) = max(conmin,cblk(l,vorgba4i)) + + cblk(l,vorgba4j) = cblk(l,vorgba4j) + orgbio4rat(l)*fconca_org(l)*dt + & + mstrnsfr + +! *** primary anthropogenic organic + + mstrnsfr = cblk(l,vorgpai)*factrans + prod = eorgi(l) + pol = prod*lossinv + + cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt + + cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai)) + + cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr + +! *** other anthropogenic PM2.5 + + mstrnsfr = cblk(l,vp25ai)*factrans + prod = epm25i(l) + pol = prod*lossinv + + cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt + + cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai)) + + cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr + +! *** elemental carbon + + mstrnsfr = cblk(l,veci)*factrans + prod = eeci(l) + pol = prod*lossinv + + cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt + + cblk(l,veci) = max(conmin,cblk(l,veci)) + + cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr + + +! *** coarse mode + +! *** soil dust + + cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt + cblk(l,vsoila) = max(conmin,cblk(l,vsoila)) + +! *** sea salt + + cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt + cblk(l,vseas) = max(conmin,cblk(l,vseas)) + +! *** anthropogenic PM10 coarse fraction + + cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt + cblk(l,vantha) = max(conmin,cblk(l,vantha)) + + + + END DO + + +! *** Check for mode merging,if Aitken mode is growing faster than j-mod +! then merge modes by renaming. + +! *** use Binkowski-Kreidenweis paradigm, now including emissions + + +! end of time-step loop for total mass + DO lcell = 1, numcells + +! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND. +! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer + IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( & + lcell,vnu0)>cblk(lcell,vac0)) & + THEN + +! check if mer + aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), & + dgacc(lcell),xxlsgn,xxlsga,sqrt2) + +! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where +! dd is the diameter at which the Aitken-mode and accumulation-mo +! distributions intersect (overap). + + + xnum = max(aaa,xxm3) ! this means that no more than one ha + ! total Aitken mode number may be tra + ! per call. + +! do not let XNUM become negative bec + xm3 = xnum - & + xxm3 +! set up for 3rd moment and mass tran + IF (xm3>0.0) & + THEN +! do mode merging if overlap is corr + phnum = 0.5*(1.0+erf(xnum)) + phm3 = 0.5*(1.0+erf(xm3)) + fnum = 0.5*erfc(xnum) + fm3 = 0.5*erfc(xm3) + + +! In the Aitken mode: + +! *** FNUM and FM3 are the fractions of the number and 3rd moment +! distributions with diameters greater than dd respectively. + + +! *** PHNUM and PHM3 are the fractions of the number and 3rd moment +! distributions with diameters less than dd. + + +! *** rename the Aitken mode particle number as accumulation mode +! particle number + + cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0) + + +! *** adjust the Aitken mode number + + cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0) + +! *** Rename mass from Aitken mode to acumulation mode. The mass transfe +! to the accumulation mode is proportional to the amount of 3rd mome +! transferred, therefore FM3 is used for mass transfer. + + cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3 + + cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3 + + cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3 + + cblk(lcell,vorgaro1j) = cblk(lcell,vorgaro1j) + & + cblk(lcell,vorgaro1i)*fm3 + + cblk(lcell,vorgaro2j) = cblk(lcell,vorgaro2j) + & + cblk(lcell,vorgaro2i)*fm3 + + cblk(lcell,vorgalk1j) = cblk(lcell,vorgalk1j) + & + cblk(lcell,vorgalk1i)*fm3 + + cblk(lcell,vorgole1j) = cblk(lcell,vorgole1j) + & + cblk(lcell,vorgole1i)*fm3 + + cblk(lcell,vorgba1j) = cblk(lcell,vorgba1j) + & + cblk(lcell,vorgba1i)*fm3 + + cblk(lcell,vorgba2j) = cblk(lcell,vorgba2j) + & + cblk(lcell,vorgba2i)*fm3 + + cblk(lcell,vorgba3j) = cblk(lcell,vorgba3j) + & + cblk(lcell,vorgba3i)*fm3 + + cblk(lcell,vorgba4j) = cblk(lcell,vorgba4j) + & + cblk(lcell,vorgba4i)*fm3 + + cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + & + cblk(lcell,vorgpai)*fm3 + + cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3 + + cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3 + +! *** update Aitken mode for mass loss to accumulation mode + + cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3 + + + cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3 + + cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3 + + cblk(lcell,vorgaro1i) = cblk(lcell,vorgaro1i)*phm3 + + cblk(lcell,vorgaro2i) = cblk(lcell,vorgaro2i)*phm3 + + cblk(lcell,vorgalk1i) = cblk(lcell,vorgalk1i)*phm3 + + cblk(lcell,vorgole1i) = cblk(lcell,vorgole1i)*phm3 + + cblk(lcell,vorgba1i) = cblk(lcell,vorgba1i)*phm3 + + cblk(lcell,vorgba2i) = cblk(lcell,vorgba2i)*phm3 + + cblk(lcell,vorgba3i) = cblk(lcell,vorgba3i)*phm3 + + cblk(lcell,vorgba4i) = cblk(lcell,vorgba4i)*phm3 + + cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3 + + cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3 + + cblk(lcell,veci) = cblk(lcell,veci)*phm3 + + + END IF +! end check on whether modal overlap is OK + + END IF +! end check on necessity for merging + + END DO +! set min value for all concentrations + +! loop for merging + DO spc = 1, nspcsda + DO lcell = 1, numcells + cblk(lcell,spc) = max(cblk(lcell,spc),conmin) + END DO + END DO + + + RETURN + +!####################################################################### + END SUBROUTINE aerostep +! aerostep + SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o) +! NOTE!!! wh2o is returned in micrograms / cubic meter +! mso4,mnh4,mno3 are in microMOLES / cubic meter + +! This version uses polynomials rather than tables, and uses empirical +! polynomials for the mass fraction of solute (mfs) as a function of wat +! where: + +! mfs = ms / ( ms + mw) +! ms is the mass of solute +! mw is the mass of water. + +! Define y = mw/ ms + +! then mfs = 1 / (1 + y) + +! y can then be obtained from the values of mfs as + +! y = (1 - mfs) / mfs + + +! the aerosol is assumed to be in a metastable state if the rh is +! is below the rh of deliquescence, but above the rh of crystallizat + +! ZSR interpolation is used for sulfates with x ( the molar ratio of +! ammonium to sulfate in eh range 0 <= x <= 2, by sections. +! section 1: 0 <= x < 1 +! section 2: 1 <= x < 1.5 +! section 3: 1.5 <= x < 2.0 +! section 4: 2 <= x +! In sections 1 through 3, only the sulfates can affect the amount o +! on the particles. +! In section 4, we have fully neutralized sulfate, and extra ammoniu +! allows more nitrate to be present. Thus, the ammount of water is c +! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati +! assumed to occur in sections 2,3,and 4. See detailed discussion be + + + +! definitions: +! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of +! for sulfate, ammonium, and nitrate respectively +! irhx is the relative humidity (%) +! wh2o is the returned water amount in micrograms / cubic meter of a +! x is the molar ratio of ammonium to sulfate +! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol +! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively +! y3 is the value of the mass ratio of water to solute for +! a pure ammonium nitrate solution. + + +!oded by Dr. Francis S. Binkowski, 4/8/96. + +! IMPLICIT NONE + INTEGER irhx, irh + REAL mso4, mnh4, mno3 + REAL tso4, tnh4, tno3, wh2o, x + REAL aw, awc +! REAL poly4, poly6 + REAL mfs0, mfs1, mfs15, mfs2 + REAL c0(4), c1(4), c15(4), c2(4) + REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc + REAL kso4(6), kno3(6), mfsso4, mfsno3 + + + + REAL mwso4, mwnh4, mwno3, mw2, mwano3 + +! *** molecular weights: + PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, & + mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4) + +! The polynomials use data for aw as a function of mfs from Tang and +! Munkelwitz, JGR 99: 18801-18808, 1994. +! The polynomials were fit to Tang's values of water activity as a +! function of mfs. + +! *** coefficients of polynomials fit to Tang and Munkelwitz data +! now give mfs as a function of water activity. + + DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/ + DATA c15/1.697092, -4.045936, 5.833688, -3.463783/ + DATA c2/2.085067, -6.024139, 8.967967, -5.002934/ + +! *** the following coefficients are a fit to the data in Table 1 of +! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975 +! data c0/0.8258941, -1.899205, 3.296905, -2.214749 / +! *** New data fit to data from +! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975 +! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960 +! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200 + DATA c0/0.798079, -1.574367, 2.536686, -1.735297/ + + +! *** polynomials for ammonium nitrate and ammonium sulfate are from: +! Chan et al.1992, Atmospheric Environment (26A): 1661-1673. + + DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/ + DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/ + + +! *** check range of per cent relative humidity + irh = irhx + irh = max(1,irh) + irh = min(irh,100) + aw = float(irh)/ & ! water activity = fractional relative h + 100.0 + tso4 = max(mso4,0.0) + tnh4 = max(mnh4,0.0) + tno3 = max(mno3,0.0) + x = 0.0 +! *** if there is non-zero sulfate calculate the molar ratio + IF (tso4>0.0) THEN + x = tnh4/tso4 + ELSE +! *** otherwise check for non-zero nitrate and ammonium + IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0 + END IF + + + +! *** begin screen on x for calculating wh2o + IF (x<1.0) THEN + + mfs0 = poly4(c0,aw) + mfs1 = poly4(c1,aw) + y0 = (1.0-mfs0)/mfs0 + y1 = (1.0-mfs1)/mfs1 + y = (1.0-x)*y0 + x*y1 + + + ELSE IF (x<1.5) THEN + + IF (irh>=40) THEN + mfs1 = poly4(c1,aw) + mfs15 = poly4(c15,aw) + y1 = (1.0-mfs1)/mfs1 + y15 = (1.0-mfs15)/mfs15 + y = 2.0*(y1*(1.5-x)+y15*(x-1.0)) + ELSE +! *** set up for crystalization + +! *** Crystallization is done as follows: +! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4 +! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01 +! and since the code does not allow ar rh < 0.01, crystallization +! is assumed not to occur in this range. +! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line +! from a value of y15 at rh = 0.4 to a value of zero at y1. From +! point B to point A in the diagram. +! The algorithm does a double interpolation to calculate the amount +! water. + +! y1(0.40) y15(0.40) +! + + Point B + + + + +! +--------------------+ +! x=1 x=1.5 +! Point A + + + + awc = 0.80*(x-1.0) ! rh along the crystallization curve. + y = 0.0 + IF (aw>=awc) & ! interpolate using crystalization + THEN + mfs1 = poly4(c1,0.40) + mfs15 = poly4(c15,0.40) + y140 = (1.0-mfs1)/mfs1 + y1540 = (1.0-mfs15)/mfs15 + y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0)) + yc = 2.0*y1540*(x-1.0) ! y along crystallization cur + y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc) +! end of checking for aw + END IF + + END IF +! end of checking on irh + ELSE IF (x<1.9999) THEN + + y = 0.0 + IF (irh>=40) THEN + mfs15 = poly4(c15,aw) + mfs2 = poly4(c2,aw) + y15 = (1.0-mfs15)/mfs15 + y2 = (1.0-mfs2)/mfs2 + y = 2.0*(y15*(2.0-x)+y2*(x-1.5)) + + END IF + + + +! end of check for crystallization + + ELSE +! regime where ammonium sulfate and ammonium nitrate are in solution. + +! *** following cf&s for both ammonium sulfate and ammonium nitrate +! *** check for crystallization here. their data indicate a 40% value +! is appropriate. +! 1.9999 < x + y2 = 0.0 + y3 = 0.0 + IF (irh>=40) THEN + mfsso4 = poly6(kso4,aw) + mfsno3 = poly6(kno3,aw) + y2 = (1.0-mfsso4)/mfsso4 + y3 = (1.0-mfsno3)/mfsno3 + + END IF + + + END IF +! *** now set up output of wh2o + +! wh2o units are micrograms (liquid water) / cubic meter of air + +! end of checking on x + IF (x<1.9999) THEN + + wh2o = y*(tso4*mwso4+mwnh4*tnh4) + + ELSE + +! *** this is the case that all the sulfate is ammonium sulfate +! and the excess ammonium forms ammonum nitrate + + wh2o = y2*tso4*mw2 + y3*tno3*mwano3 + + END IF + + RETURN + END SUBROUTINE awater +!////////////////////////////////////////////////////////////////////// + + SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, & + dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30) +!*********************************************************************** +!** DESCRIPTION: calculates aerosol coagulation rates for unimodal +! and bimodal coagulation using E. Whitby 1990's prescription. + +!....... Rates for coaglulation: +!....... Unimodal Rates: +!....... URN00: nuclei mode 0th moment self-coagulation rate +!....... URA00: accumulation mode 0th moment self-coagulation rate + +!....... Bimodal Rates: (only 1st order coeffs appear) +!....... NA-- nuclei with accumulation coagulation rates, +!....... AN-- accumulation with nuclei coagulation rates +!....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term) +!....... BRNA31: 3rd ( d(nuclei mode 3) / dt term) +!** +!** +!** Revision history: +! prototype 1/95 by Uma and Carlie +! Revised 8/95 by US for calculation of density from stmt func +! and collect met variable stmt funcs in one include fil +! REVISED 7/25/96 by FSB to use block structure +! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only. +! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs +! changed. All coagulation coefficients +! returned with positive signs. Their +! linearization is also abandoned. +! Fixed values are used for the corrections +! to the free-molecular coagulation integra +! The code forces the harmonic means to be +! evaluated in 64 bit arithmetic on 32 bit +! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit + +! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa +! because BRNA31 can become zero on a works +! because of limited precision. With the ch +! aerostep to omit update of the 3rd moment +! C30 is the only variable now needed. +! the logic using ONE88 to force REAL*8 ari +! has been removed and all intermediates ar +! REAL*8. + +! IMPLICIT NONE + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells + + INTEGER nspcsda + +! nmber of species in CBLK + REAL cblk(blksize,nspcsda) ! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL pdensn(blksize) ! average particel density in Aitk + REAL pdensa(blksize) ! average particel density in accu + REAL amu(blksize) ! atmospheric dynamic viscosity [ + REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ] + REAL dgacc(blksize) ! accumulation mode mean diameter + REAL knnuc(blksize) ! Aitken mode Knudsen number + REAL knacc(blksize) +! *** output: + +! accumulation mode Knudsen number + REAL urn00(blksize) ! intramodal coagulation rate (Ait + REAL ura00(blksize) +! intramodal coagulation rate (acc + REAL brna01(blksize) ! intermodal coagulaton rate (numb + REAL c30(blksize) ! by inter + +! *** Local variables: +! intermodal 3rd moment transfer r + REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate + kncacc + REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate + kfmacc + REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate + kfm + REAL*8 bencnn, & ! NC 0th moment coag rate (both modes) + bencna + REAL*8 & ! NC 3rd moment coag rate (nuc mode) + bencm3n + REAL*8 befmnn, & ! FM 0th moment coag rate (both modes) + befmna + REAL*8 & ! FM 3rd moment coag rate (nuc mode) + befm3n + REAL*8 betann, & ! composite coag rates, mom 0 (both mode + betana + REAL*8 & ! intermodal coagulation rate for 3rd mo + brna31 + REAL*8 & ! scratch subexpression + s1 + REAL*8 t1, & ! scratch subexpressions + t2 + REAL*8 t16, & ! T1**6, T2**6 + t26 + REAL*8 rat, & ! ratio of acc to nuc size and its inver + rin + REAL*8 rsqt, & ! sqrt( rat ), rsqt**4 + rsq4 + REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 ) + rsqi3 + REAL*8 & ! dgnuc**3 + dgn3 + REAL*8 & ! in 64 bit arithmetic + dga3 + +! dgacc**3 + + INTEGER lcell +! *** Fixed values for correctionss to coagulation +! integrals for free-molecular case. +! loop counter + REAL*8 bm0 + PARAMETER (bm0=0.8D0) + REAL*8 bm0i + PARAMETER (bm0i=0.9D0) + REAL*8 bm3i + PARAMETER (bm3i=0.9D0) + REAL*8 & ! approx Cunningham corr. factor + a + PARAMETER (a=1.246D0) + +!....................................................................... +! begin body of subroutine COAGRATE + +!........... Main computational grid-traversal loops +!........... for computing coagulation rates. + +! *** Both modes have fixed std devs. + DO lcell = 1, & + numcells +! *** moment independent factors + +! loop on LCELL + s1 = two3*boltz*blkta(lcell)/amu(lcell) + +! For unimodal coagualtion: + + kncnuc = s1 + kncacc = s1 + + kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell)) + kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell)) + +! For bimodal coagulation: + + knc = s1 + kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell))) + + + +!........... Begin unimodal coagulation rate calculations: + +!........... Near-continuum regime. + + dgn3 = dgnuc(lcell)**3 + dga3 = dgacc(lcell)**3 + + t1 = sqrt(dgnuc(lcell)) + t2 = sqrt(dgacc(lcell)) + t16 = & ! = T1**6 + dgn3 + t26 = & + dga3 +!....... Note rationalization of fractions and subsequent cancellation +!....... from the formulation in Whitby et al. (1990) + +! = T2**6 + bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20)) + + bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20)) + + +!........... Free molecular regime. Uses fixed value for correction +! factor BM0 + + + befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0 + + befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0 + + +!........... Calculate half the harmonic mean between unimodal rates +!........... free molecular and near-continuum regimes + +! FSB 64 bit evaluation + + betann = bencnn*befmnn/(bencnn+befmnn) + betana = bencna*befmna/(bencna+befmna) + + + + urn00(lcell) = betann + ura00(lcell) = betana + + +! *** End of unimodal coagulation calculations. + +!........... Begin bimodal coagulation rate calculations: + + rat = dgacc(lcell)/dgnuc(lcell) + rin = 1.0D0/rat + rsqt = sqrt(rat) + rsq4 = rat**2 + + rsqti = 1.0D0/rsqt + rsqi3 = rin*rsqti + +!........... Near-continuum coeffs: +!........... 0th moment nuc mode bimodal coag coefficient + + bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell & + )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04) + +!........... 3rd moment nuc mode bimodal coag coefficient + + bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a & + *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ & + rin*esn64*esa04) + + + +!........... Free molecular regime coefficients: +!........... Uses fixed value for correction +! factor BM0I, BM3I + + +!........... 0th moment nuc mode coeff + + + + befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ & + rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1) + +!........... 3rd moment nuc mode coeff + + befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ & + rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1) + + +!........... Calculate half the harmonic mean between bimodal rates +!........... free molecular and near-continuum regimes + +! FSB Force 64 bit evaluation + + + brna01(lcell) = bencnn*befmnn/(bencnn+befmnn) + + brna31 = bencm3n* & ! BRNA31 now is a scala + befm3n/(bencm3n+befm3n) + c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0) +! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0) + ! 3d moment transfer by intermodal coagula + +! End bimodal coagulation rate. + + + + END DO +! end of main lop over cells + RETURN +!------------------------------------------------------------------ + END SUBROUTINE coagrate +! subroutine to find the roots of a cubic equation / 3rd order polynomi +! formulae can be found in numer. recip. on page 145 +! kiran developed this version on 25/4/1990 +! dr. francis binkowski modified the routine on 6/24/91, 8/7/97 +! *** +!234567 +! coagrate + SUBROUTINE cubic(a2,a1,a0,nr,crutes) +! IMPLICIT NONE + INTEGER nr + REAL*8 a2, a1, a0 + REAL crutes(3) + REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd + REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3 + REAL*8 costh, sinth + DATA sqrt3/1.732050808/, one3rd/0.333333333/ +!bs + REAL*8 onebs + PARAMETER (onebs=1.0) +!bs + a2sq = a2*a2 + qq = (a2sq-3.*a1)/9. + rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54. +! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT + dum1 = qq*qq*qq + rrsq = rr*rr + dum2 = dum1 - rrsq + IF (dum2>=0.) THEN +! NOW WE HAVE THREE REAL ROOTS + phi = sqrt(dum1) + IF (abs(phi)<1.E-20) THEN + print *, ' cubic phi small, phi = ',phi + crutes(1) = 0.0 + crutes(2) = 0.0 + crutes(3) = 0.0 + nr = 0 + CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE') + END IF + theta = acos(rr/phi)/3.0 + costh = cos(theta) + sinth = sin(theta) +! *** use trig identities to simplify the expressions +! *** binkowski's modification + part1 = sqrt(qq) + yy1 = part1*costh + yy2 = yy1 - a2/3.0 + yy3 = sqrt3*part1*sinth + crutes(3) = -2.0*yy1 - a2/3.0 + crutes(2) = yy2 + yy3 + crutes(1) = yy2 - yy3 +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE + IF (crutes(1)<0.0) crutes(1) = 1.0E9 + IF (crutes(2)<0.0) crutes(2) = 1.0E9 + IF (crutes(3)<0.0) crutes(3) = 1.0E9 +! *** put smallest positive root in crutes(1) + crutes(1) = min(crutes(1),crutes(2),crutes(3)) + nr = 3 +! NOW HERE WE HAVE ONLY ONE REAL ROOT + ELSE +! dum IS NEGATIVE + part1 = sqrt(rrsq-dum1) + part2 = abs(rr) + part3 = (part1+part2)**one3rd + crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3. +!bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3. + crutes(2) = 0. + crutes(3) = 0. +!IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE +! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9 + nr = 1 + END IF + RETURN +!/////////////////////////////////////////////////////////////////////// + END SUBROUTINE cubic + +! Calculate the aerosol chemical speciation and water content. + +! cubic + SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh) +!*********************************************************************** +!** DESCRIPTION: +! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate, +! and water between the gas and aerosol phases as the total sulfate, +! ammonia, and nitrate concentrations, relative humidity and +! temperature change. The evolution of the aerosol mass concentration +! due to the change in aerosol chemical composition is calculated. +!** REVISION HISTORY: +! prototype 1/95 by Uma and Carlie +! Revised 8/95 by US to calculate air density in stmt func +! and collect met variable stmt funcs in one include fil +! Revised 7/26/96 by FSB to use block concept. +! Revise 12/1896 to do do i-mode calculation. +!********************************************************************** + +! IMPLICIT NONE + + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells +! nmber of species in CBLK + INTEGER nspcsda + REAL cblk(blksize,nspcsda) +! *** Meteorological information in blocked arays: + +! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkrh(blksize) + +! Fractional relative humidity + + INTEGER lcell +! loop counter +! air temperature + REAL temp +!iamodels3 + REAL rh +! relative humidity + REAL so4, no3, nh3, nh4, hno3 + REAL aso4, ano3, ah2o, anh4, gnh3, gno3 +! Fraction of dry sulfate mass in i-mode + REAL fraci +!....................................................................... + REAL fracj + +! WRITE(20,*) ' IN EQL 3 ' + + + +! Fraction of dry sulfate mass in j-mode + DO lcell = 1, & + numcells +! *** Fetch temperature, fractional relative humidity, and +! air density + +! loop on cells + temp = blkta(lcell) + rh = blkrh(lcell) + +! *** the following is an interim procedure. Assume the i-mode has the +! same relative mass concentrations as the total mass. Use SO4 as +! the surrogate. The results of this should be the same as those +! from the original RPM. + +! *** do total aerosol + + so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai) + +!iamodels3 + no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai) +! & + CBLK(LCELL, VHNO3) + + hno3 = cblk(lcell,vhno3) + +!iamodels3 + + nh3 = cblk(lcell,vnh3) + + nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai) +! & + CBLK(LCELL, VNH3) + +!bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP, +!bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3) +!bs +!bs * call old version of rpmares +!bs + CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, & + gnh3,gno3) +!bs + +! *** get modal fraction + fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai)) + fracj = 1.0 - fraci + +! *** update do i-mode + + cblk(lcell,vh2oai) = fraci*ah2o + cblk(lcell,vnh4ai) = fraci*anh4 + cblk(lcell,vno3ai) = fraci*ano3 + +! *** update accumulation mode: + + cblk(lcell,vh2oaj) = fracj*ah2o + cblk(lcell,vnh4aj) = fracj*anh4 + cblk(lcell,vno3aj) = fracj*ano3 + + +! *** update gas / vapor phase + + cblk(lcell,vnh3) = gnh3 + cblk(lcell,vhno3) = gno3 + + END DO +! end loop on cells + RETURN + +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + END SUBROUTINE eql3 +! eql3 + SUBROUTINE fdjac(n,x,fjac,ct,cs,imw) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Get the Jacobian of the function ! +!bs ! +!bs ( a1 * X1^2 + b1 * X1 + c1 ) ! +!bs ( a2 * X2^2 + b2 * X1 + c2 ) ! +!bs ( a3 * X3^2 + b3 * X1 + c3 ) ! +!bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. ! +!bs ( a5 * X5^2 + b5 * X1 + c5 ) ! +!bs ( a6 * X6^2 + b6 * X1 + c6 ) ! +!bs ! +!bs a_i = IMW_i ! +!bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i ! +!bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] ! +!bs ! +!bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j ! +!bs J_ij = ----------- = ( ! +!bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j ! +!bs ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs +!dimension of problem + INTEGER n + REAL x(n) !bs +! INTEGER NP !bs maximum expected value of N +! PARAMETER (NP = 6) +!bs initial guess of CAER + REAL ct(np) + REAL cs(np) + REAL imw(np) +!bs + REAL fjac(n,n) +!bs + INTEGER i, & !bs loop index + j + REAL a(np) + REAL b(np) + REAL b1(np) + REAL b2(np) + REAL sum_jnei +!bs + DO i = 1, n + a(i) = imw(i) + sum_jnei = 0. + DO j = 1, n + sum_jnei = sum_jnei + x(j)*imw(j) + END DO + b1(i) = sum_jnei - (x(i)*imw(i)) + b2(i) = cs(i)*imw(i) - ct(i)*imw(i) + b(i) = b1(i) + b2(i) + END DO + DO j = 1, n + DO i = 1, n + IF (i==j) THEN + fjac(i,j) = 2.*a(i)*x(i) + b(i) + ELSE + fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j) + END IF + END DO + END DO +!bs + RETURN + END SUBROUTINE fdjac +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + FUNCTION fmin(x,fvec,n,ct,cs,imw,m) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. ! +!bs ! +!bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, ! +!bs user-supplied routine that returns the vector of functions at X. ! +!bs The common block NEWTV communicates the function values back to ! +!bs NEWT. ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs Calls: FUNCV ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + +! IMPLICIT NONE + +!bs +!bs + INTEGER n +! INTEGER NP +! PARAMETER (NP = 6) + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL m,fmin + REAL x(*), fvec(np) + + + INTEGER i + REAL sum + + CALL funcv(n,x,fvec,ct,cs,imw,m) + sum = 0. + DO i = 1, n + sum = sum + fvec(i)**2 + END DO + fmin = 0.5*sum + RETURN + END FUNCTION fmin +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Called by: FMIN ! +!bs ! +!bs Calls: None ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs + INTEGER n + REAL x(*) + REAL fvec(n) +!bs +! INTEGER NP +! PARAMETER (NP = 6) + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL m +!bs + INTEGER i, j + REAL sum_jnei + REAL a(np) + REAL b(np) + REAL c(np) +!bs + DO i = 1, n + a(i) = imw(i) + sum_jnei = 0. + DO j = 1, n + sum_jnei = sum_jnei + x(j)*imw(j) + END DO + sum_jnei = sum_jnei - (x(i)*imw(i)) + b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i) + c(i) = -ct(i)*(sum_jnei+m) + fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i) + END DO +!bs + RETURN + END SUBROUTINE funcv + REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2) +! *** set up new processor for renaming of particles from i to j modes +! IMPLICIT NONE + REAL aa, bb, cc, disc, qq, alfa, l, yji + REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2 + + alfa = xlsgi/xlsgj + yji = log(dgnj/dgni)/(sqrt2*xlsgi) + aa = 1.0 - alfa*alfa + l = log(alfa*nj/ni) + bb = 2.0*yji*alfa*alfa + cc = l - yji*yji*alfa*alfa + disc = bb*bb - 4.0*aa*cc + IF (disc<0.0) THEN + getaf = - & ! error in intersection + 5.0 + RETURN + END IF + qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc)) + getaf = cc/qq + RETURN +! *** subroutine to implement Kulmala, Laaksonen, Pirjola + END FUNCTION getaf +! Parameterization for sulfuric acid/water +! nucleation rates, J. Geophys. Research (103), pp 8301-8307, +! April 20, 1998. + +!ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f +!ia rev02 27.04.99 security check on MDOT > SO4RAT + + +!ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT) +! getaf + SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat) +! IMPLICIT NONE + + +! *** Input: + +! ambient temperature [ K ] + REAL temp +! fractional relative humidity + REAL rh +! sulfuric acid concentration [ ug / m**3 ] + REAL h2so4 + + REAL so4rat +! *** Output: + +!sulfuric acid production rate [ ug / ( m**3 s )] +! particle number production rate [ # / ( m**3 s )] + REAL ndot1 +! particle mass production rate [ ug / ( m**3 s )] + REAL mdot1 + ! [ m**2 / ( m**3 s )] + REAL m2dot + +! *** Internal: + +! *** NOTE, all units are cgs internally. +! particle second moment production rate + + REAL ra +! fractional relative acidity +! sulfuric acid vaper concentration [ cm ** -3 ] + REAL nav +! water vapor concentration [ cm ** -3 ] + REAL nwv +! equilibrium sulfuric acid vapor conc. [ cm ** -3 ] + REAL nav0 + ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1 + REAL nac +! critical sulfuric acid vapor concentration [ cm ** -3 +! mole fractio of the critical nucleus + REAL xal + REAL nsulf, & ! see usage + delta + REAL*8 & ! factor to calculate Jnuc + chi + REAL*8 & + jnuc +! nucleation rate [ cm ** -3 s ** -1 ] + REAL tt, & ! dummy variables for statement functions + rr + REAL pi + PARAMETER (pi=3.14159265) + + REAL pid6 + PARAMETER (pid6=pi/6.0) + +! avogadro's constant [ 1/mol ] + REAL avo + PARAMETER (avo=6.0221367E23) + +! universal gas constant [ j/mol-k ] + REAL rgasuniv + PARAMETER (rgasuniv=8.314510) + +! 1 atmosphere in pascals + REAL atm + PARAMETER (atm=1013.25E+02) + +! formula weight for h2so4 [ g mole **-1 ] + REAL mwh2so4 + PARAMETER (mwh2so4=98.07948) + +! diameter of a 3.5 nm particle in cm + REAL d35 + PARAMETER (d35=3.5E-07) + REAL d35sq + PARAMETER (d35sq=d35*d35) +! volume of a 3.5 nm particle in cm**3 + REAL v35 + PARAMETER (v35=pid6*d35*d35sq) +!ia rev01 + + REAL mp +! *** conversion factors: +! mass of sulfate in a 3.5 nm particle + ! number per cubic cm. + REAL ugm3_ncm3 +! micrograms per cubic meter to + PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12) +!ia rev01 +! molecules to micrograms + REAL nc_ug + PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo) + + + +! *** statement functions ************** + + REAL pdens, & + rho_p +! particle density [ g / cm**3] + REAL ad0, ad1, ad2, & + ad3 +! coefficients for density expression + PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427) +! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets +! as a function of relative humidity, +! J. Aerosol Science, 6, pp 265-271, 1975. + +!ia rev01 + +! fit to Nair & Vohra data + ! the mass of sulfate in a 3.5 nm particle + REAL mp35 +! arithmetic statement function to compute + REAL a0, a1, a2, & ! coefficients for cubic in mp35 + a3 + PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2) + + REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ] + ph2o + + +! arithmetic statement functions + pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3)) + + ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03) + + ph2so4(tt) = exp(27.78492066-10156.0/tt) + +! *** both ph2o and ph2so4 are as in Kulmala et al. paper + +!ia rev01 + +! *** function for the mass of sulfate in a 3.5 nm sphere +! *** obtained from a fit to the number of sulfate monomers in +! a 3.5 nm particle. Uses data from Nair & Vohra + mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3))) + + + +! *** begin code: + +! The 1.0e-6 factor in the following converts from MKS to cgs units + +! *** get water vapor concentration [ molecles / cm **3 ] + + nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6 + +! *** calculate the equilibrium h2so4 vapor concentration. + +! *** use Kulmala corrections: + + +! *** + + nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6 + +! *** convert sulfuric acid vapor concentration from micrograms +! per cubic meter to molecules per cubic centimeter. + + nav = ugm3_ncm3*h2so4 + + +! *** calculate critical concentration of sulfuric acid vapor + + nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp) + +! *** calculate relative acidity + + ra = nav/nav0 + +! *** calculate temperature correction + + delta = 1.0 + (temp-273.15)/273.14 + +! *** calculate molar fraction + + xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + & + 0.0016*temp + +! *** calculate Nsulf + nsulf = log(nav/nac) + +! *** calculate particle produtcion rate [ # / cm**3 ] + + chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - & + 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh + + jnuc = exp(chi) +! [ # / cm**3 ] + ndot1 = (1.0E06)*jnuc +! write(91,*) ' inside klpnuc ' +! write(91,*) ' Jnuc = ', Jnuc +! write(91,*) ' NDOT = ', NDOT1 + +! *** calculate particle density + + + rho_p = pdens(rh) + +! write(91,*) ' rho_p =', rho_p + +! *** get the mass of sulfate in a 3.5 nm particle + + mp = mp35(rh) ! in a 3.5 nm particle at ambient RH + +! *** calculate mass production rate [ ug / m**3] +! assume that the particles are 3.5 nm in diameter. + + +! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc + +!ia rev01 + +! number of micrograms of sulfate + mdot1 = mp*ndot1 + +!ia rev02 + + IF (mdot1>so4rat) THEN + + mdot1 = & + so4rat +! limit nucleated mass by available ma + ndot1 = mdot1/ & + mp +! adjust DNDT to this + END IF + + + IF (mdot1==0.) ndot1 = 0. + +! *** calculate M2 production rate [ m**2 / (m**3 s)] + + m2dot = 1.0E-04*d35sq*ndot1 + + RETURN + + END SUBROUTINE klpnuc + SUBROUTINE lnsrch(ctot,n,xold,fold,g,p,x,f,stpmax,check,func, & + fvec,ct,cs,imw,m) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. ! +!bs ! +!bs Given an n-dimensional point XOLD(1:N), the value of the function ! +!bs and gradient there, FOLD and G(1:N), and a direction P(1:N), ! +!bs finds a new point X(1:N) along the direction P from XOLD where ! +!bs the function FUNC has decreased 'sufficiently'. The new function ! +!bs value is returned in F. STPMAX is an input quantity that limits ! +!bs the length of the steps so that you do not try to evaluate the ! +!bs function in regions where it is undefined or subject to overflow. ! +!bs P is usually the Newton direction. The output quantity CHECK is ! +!bs false on a normal; exit. It is true when X is too close to XOLD. ! +!bs In a minimization algorithm, this usually signals convergence and ! +!bs can be ignored. However, in a zero-finding algorithm the calling ! +!bs program should check whether the convergence is spurious. ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs Calls: FUNC ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + +! IMPLICIT NONE +!bs +!bs + INTEGER n + LOGICAL check + REAL f, fold, stpmax + REAL g(n), p(n), x(n), xold(n) + REAL func + REAL ctot(n) + REAL alf + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL fvec(n) + REAL m + + PARAMETER (alf=1.E-04) + + EXTERNAL func + + INTEGER i + REAL a, alam, alam2, alamin, b, disc + REAL f2, fold2, rhs1, rhs2, slope + REAL sum, temp, test, tmplam + + check = .FALSE. + sum = 0. + DO i = 1, n + sum = sum + p(i)*p(i) + END DO + sum = sqrt(sum) + IF (sum>stpmax) THEN + DO i = 1, n + p(i) = p(i)*stpmax/sum + END DO + END IF + slope = 0. + DO i = 1, n + slope = slope + g(i)*p(i) + END DO + test = 0. + DO i = 1, n + temp = abs(p(i))/max(abs(xold(i)),1.) + IF (temp>test) test = temp + END DO + alamin = tolx/test + alam = 1. + +10 CONTINUE + +!bs +!bs * avoid negative concentrations and set upper limit given by CTOT. +!bs + DO i = 1, n + x(i) = xold(i) + alam*p(i) + IF (x(i)<=0.) x(i) = conmin + IF (x(i)>ctot(i)) x(i) = ctot(i) + END DO + f = func(x,fvec,n,ct,cs,imw,m) + IF (alam0.5*alam) tmplam = 0.5*alam + END IF + END IF + alam2 = alam + f2 = f + fold2 = fold + alam = max(tmplam,0.1*alam) + GO TO 10 + + END SUBROUTINE lnsrch +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + SUBROUTINE lubksb(a,n,np,indx,b) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. ! +!bs ! +!bs Solves the set of N linear equations A * X = B. Here A is input, ! +!bs not as the matrix A but rather as its LU decomposition, ! +!bs determined by the routine LUDCMP. B(1:N) is input as the right- ! +!bs hand side vector B, and returns with the solution vector X. A, N, ! +!bs NP, and INDX are not modified by this routine and can be left in ! +!bs place for successive calls with different right-hand sides B. ! +!bs This routine takes into account the possibilitythat B will begin ! +!bs with many zero elements, so it is efficient for use in matrix ! +!bs inversion. ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs + INTEGER n, np, indx(n) + REAL a(np,np), b(n) + + INTEGER i, ii, j, ll + REAL sum + + ii = 0 + DO i = 1, n + ll = indx(i) + sum = b(ll) + b(ll) = b(i) + IF (ii/=0) THEN + DO j = ii, i - 1 + sum = sum - a(i,j)*b(j) + END DO + ELSE IF (sum/=0) THEN + ii = i + END IF + b(i) = sum + END DO + DO i = n, 1, -1 + sum = b(i) + DO j = i + 1, n + sum = sum - a(i,j)*b(j) + END DO + b(i) = sum/a(i,i) + END DO + + RETURN + END SUBROUTINE lubksb +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + SUBROUTINE ludcmp(a,n,np,indx,d,klev) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. ! +!bs ! +!bs Equation (2.3.14) Numerical Recipes, p 36: ! +!bs | b_11 b_12 b_13 b_14 | ! +!bs | a_21 b_22 b_23 b_24 | ! +!bs | a_31 a_32 b_33 b_34 | ! +!bs | a_41 a_42 a_43 b_44 | ! +!bs ! +!bs Given a matrix A(1:N,1:N), with physical dimension NP by NP, this ! +!bs routine replaces it by the LU decomposition of a rowwise ! +!bs permutation of itself. A and N are input. A is output arranged as ! +!bs in equation (2.3.14) above; INDX(1:N) is an output vector that ! +!bs records vector that records the row permutation effected by the ! +!bs partial pivoting; D is output as +-1 depending on whether the ! +!bs number of row interchanges was even or odd, respectively. This ! +!bs routine is used in combination with SR LUBKSB to solve linear ! +!bs equations or invert a matrix. ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs + INTEGER n, np, indx(n) + INTEGER nmax + PARAMETER (nmax=10) !largest expected N + REAL d, a(np,np) + REAL tiny + PARAMETER (tiny=1.0E-20) + + INTEGER i, imax, j, k + REAL aamax, dum, sum, vv(nmax) + integer klev + + d = 1 + DO i = 1, n + aamax = 0. + DO j = 1, n + IF (abs(a(i,j))>aamax) aamax = abs(a(i,j)) + END DO + IF (aamax==0) THEN + print *, 'Singular matrix in ludcmp, klev = ',klev + a(1,1)=epsilc +! STOP + END IF + vv(i) = 1./aamax + END DO + DO j = 1, n + DO i = 1, j - 1 + sum = a(i,j) + DO k = 1, i - 1 + sum = sum - a(i,k)*a(k,j) + END DO + a(i,j) = sum + END DO + aamax = 0. + DO i = j, n + sum = a(i,j) + DO k = 1, j - 1 + sum = sum - a(i,k)*a(k,j) + END DO + a(i,j) = sum + dum = vv(i)*abs(sum) + IF (dum>=aamax) THEN + imax = i + aamax = dum + END IF + END DO + IF (j/=imax) THEN + DO k = 1, n + dum = a(imax,k) + a(imax,k) = a(j,k) + a(j,k) = dum + END DO + d = -d + vv(imax) = vv(j) + END IF + indx(j) = imax + IF (a(j,j)==0.) a(j,j) = tiny + IF (j/=n) THEN + dum = 1./a(j,j) + DO i = j + 1, n + a(i,j) = a(i,j)*dum + END DO + END IF + END DO + + RETURN + END SUBROUTINE ludcmp + +! ////////////////////////////////////////////////////////////////// + + SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, & + pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, & + knacc,kncor) +!*********************************************************************** + + + +!** DESCRIPTION: +! Calculates modal parameters and derived variables, +! log-squared of std deviation, mode mean size, Knudsen number) +! based on current values of moments for the modes. +! FSB Now calculates the 3rd moment, mass, and density in all 3 modes. +!** +!** Revision history: +! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3 +! Revised 7/23/96 by FSB to use COMMON blocks and small blocks +! instead of large 3-d arrays, and to assume a fixed std. +! Revised 12/06/96 by FSB to include coarse mode +! Revised 1/10/97 by FSB to have arrays passed in call vector +!********************************************************************** + +! IMPLICIT NONE + +! Includes: + + +! *** input: + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells + + INTEGER nspcsda + +! nmber of species in CBLK + REAL cblk(blksize,nspcsda) ! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) +! *** output: + +! Air pressure in [ Pa ] +! concentration lower limit [ ug/m* +! lowest particle diameter ( m ) + REAL dgmin + PARAMETER (dgmin=1.0E-09) + +! lowest particle density ( Kg/m**3 + REAL densmin + PARAMETER (densmin=1.0E03) + + REAL pmassn(blksize) ! mass concentration in nuclei mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) ! mass concentration in coarse mode + REAL pdensn(blksize) ! average particel density in Aitken + REAL pdensa(blksize) ! average particel density in accumu + REAL pdensc(blksize) ! average particel density in coarse + REAL xlm(blksize) ! atmospheric mean free path [ m] + REAL amu(blksize) ! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ] + REAL dgacc(blksize) ! accumulation + REAL dgcor(blksize) ! coarse mode + REAL knnuc(blksize) ! Aitken mode Knudsen number + REAL knacc(blksize) ! accumulation + REAL kncor(blksize) + +! coarse mode + + INTEGER lcell +! WRITE(20,*) ' IN MODPAR ' + +! *** set up aerosol 3rd moment, mass, density + +! loop counter + DO lcell = 1, numcells + +! *** Aitken-mode +! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan + cblk(lcell,vnu3) = so4fac*cblk(lcell, & + vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, & + vh2oai)+no3fac*cblk(lcell,vno3ai)+orgfac*cblk(lcell, & + vorgaro1i)+orgfac*cblk(lcell,vorgaro2i)+orgfac*cblk(lcell, & + vorgalk1i)+orgfac*cblk(lcell,vorgole1i)+orgfac*cblk(lcell, & + vorgba1i)+orgfac*cblk(lcell,vorgba2i)+orgfac*cblk(lcell, & + vorgba3i)+orgfac*cblk(lcell,vorgba4i)+orgfac*cblk(lcell, & + vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci) +! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan + + + +! *** Accumulation-mode + +! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan + cblk(lcell,vac3) = so4fac*cblk(lcell, & + vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, & + vh2oaj)+no3fac*cblk(lcell,vno3aj)+orgfac*cblk(lcell, & + vorgaro1j)+orgfac*cblk(lcell,vorgaro2j)+orgfac*cblk(lcell, & + vorgalk1j)+orgfac*cblk(lcell,vorgole1j)+orgfac*cblk(lcell, & + vorgba1j)+orgfac*cblk(lcell,vorgba2j)+orgfac*cblk(lcell, & + vorgba3j)+orgfac*cblk(lcell,vorgba4j)+orgfac*cblk(lcell, & + vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj) +! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan + +! *** coarse mode + +! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment +! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha))) + cblk(lcell,vcor3) = soilfac*cblk(lcell, & + vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha) + +! *** now get particle mass and density + +! *** Aitken-mode: + + pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, & + vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, & + vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, & + vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, & + vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, & + vp25ai)+cblk(lcell,veci))) + + +! *** Accumulation-mode: + + pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, & + vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, & + vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, & + vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, & + vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, & + vp25aj)+cblk(lcell,vecj))) + + +! *** coarse mode: + + pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( & + lcell,vantha)) + + + + END DO +! *** now get particle density, mean free path, and dynamic viscosity + +! aerosol 3rd moment and mass + DO lcell = 1, & + numcells +! *** density in [ kg m**-3 ] + +! Density and mean free path + pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3))) + pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3))) + pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3))) + +! *** Calculate mean free path [ m ]: + + xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell)) + +! *** 6.6328E-8 is the sea level values given in Table I.2.8 +! *** on page 10 of U.S. Standard Atmosphere 1962 + +! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]: + +! *** U.S. Standard Atmosphere 1962 page 14 expression +! for dynamic viscosity is: +! dynamic viscosity = beta * T * sqrt(T) / ( T + S) +! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ]. + + amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ & + (blkta(lcell)+110.4) + + + END DO + +!............... Standard deviation fixed in both modes, so +!............... diagnose diameter from 3rd moment and number concentr + + +! density and mean free path + DO lcell = 1, & + numcells + +! calculate diameters + dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** & + one3) + + + dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** & + one3) + + + dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) & + **one3) + + + END DO +! end loop on diameters + DO lcell = 1, & + numcells +! Calculate Knudsen numbers + knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell) + + knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell) + + kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell) + + + END DO + +! end loop for Knudsen numbers + RETURN + +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + END SUBROUTINE modpar +! modpar + SUBROUTINE newt(layer,x,n,check,ctot,csat,imwcv,minitw,its) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. ! +!bs ! +!bs Given an initial guess X(1:N) for a root in N dimensions, find ! +!bs the root by globally convergent Newton's method. The vector of ! +!bs functions to be zeroed, called FVEC(1:N) in the routine below. is ! +!bs retuned by a user-supplied function that must be called FUNCV and ! +!bs have the declaration SUBROUTINE FUNCV(NX,FVEC). The output ! +!bs quantity CHECK is false on a normal return and true if the ! +!bs routine has converged to a local minimum of the function FMIN ! +!bs defined below. In this case try restarting from a different ! +!bs initial guess. ! +!bs ! +!bs PARAMETERS ! +!bs NP : maximum expected value of N ! +!bs MAXITS : maximum number of iterations ! +!bs TOLF : convergence criterion on function values ! +!bs TOLMIN : criterion for decidingwhether spurios convergence to a ! +!bs minimum of FMIN has ocurred ! +!bs TOLX : convergence criterion on delta_X ! +!bs STPMX : scaled maximum step length allowed in line searches ! +!bs ! +!bs Called by: SOA_PART ! +!bs ! +!bs Calls: FDJAC ! +!bs FMIN ! +!bs LNSRCH ! +!bs LUBKSB ! +!bs LUDCMP ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs * includes +!bs +!bs +!bs * input variables +!bs +!bs model layer + INTEGER layer +!bs dimension of problem + INTEGER n + REAL x(n) !bs initial guess of CAER + LOGICAL check + REAL ctot(n) !bs total concentration GAS + AER + PROD + REAL csat(n) !bs saturation conc. of cond. vapor [ug/m^ + REAL imwcv(n) !bs inverse molecular weights +!bs + REAL minitw +!bs * following Numerical recipes +!bs +!bs weighted initial mass + INTEGER nn +! INTEGER NP +! PARAMETER (NP = 6) + REAL fvec(np) !bs +!bs +!bs vector of functions to be zeroed + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL m +!bs + INTEGER i, its, j, indx(np) + REAL d, den, f, fold, stpmax, sum, temp, test + REAL fjac(np,np) + REAL g(np), p(np), xold(np) +!bs +! EXTERNAL fmin +!bs +!bs * begin code +!bs + m = minitw + DO i = 1, n + ct(i) = ctot(i) + cs(i) = csat(i) + imw(i) = imwcv(i) + END DO +!bs + nn = n + f = fmin(x,fvec,nn,ct,cs,imw,m) !The vector FVEC is + test = & !Test for initial guess being a root. Us + 0. + DO i = 1, & !stringent test than simply TOLF. + n + IF (abs(fvec(i))>test) test = abs(fvec(i)) + END DO + IF (test<0.01*tolf) RETURN + sum = & !Calculate STPMAX for line searches + 0. + DO i = 1, n + sum = sum + x(i)**2 + END DO + stpmax = stpmx*max(sqrt(sum),float(n)) + DO its = 1, & !start of iteration loop + maxits + CALL fdjac(n,x,fjac,ct,cs,imw) !get Jacobian + DO i = 1, & !compute Delta f for line search + n + sum = 0. + DO j = 1, n + sum = sum + fjac(j,i)*fvec(j) + END DO + g(i) = sum + END DO + DO i = 1, & !store X + n + xold(i) = x(i) + END DO + fold = & !store F + f + DO i = 1, & !right-hand side for linear equations + n + p(i) = -fvec(i) + END DO + CALL ludcmp(fjac,n,np,indx,d,layer) !solve linear equations by LU dec + CALL lubksb(fjac,n,np,indx,p) + CALL lnsrch(ctot,n,xold,fold,g, & !LNSRCH returns new X and F. It a + p,x,f,stpmax, & !calculates FVEC at the new X whe + check,fmin,fvec,ct,cs,imw,m) !calls FMIN + test = 0. + DO i = 1, n + IF (abs(fvec(i))>test) test = abs(fvec(i)) + END DO + IF (testtest) test = temp + END DO + IF (testtest) test = temp + END DO + IF (test so4 [mom-3/g/s] + REAL chemrat +! conv rate for organics [mom-3/g/s] + REAL chemrat_org + REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_ + am1a + REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_ + am2a + REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den + gnc3a + REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den + gfm3a +! total reciprocal condensation rate + REAL fconc + + REAL td +! d * tinf (cgs) + REAL*8 & ! Cnstant to force 64 bit evaluation of + one88 + PARAMETER (one88=1.0D0) +! *** variables to set up sulfate and organic condensation rates + +! sulfuric acid vapor at current time step + REAL vapor1 +! chemistry and emissions + REAL vapor2 +! Sulfuric acid vapor prior to addition from +!bs + REAL deltavap +!bs * start update +!bs +! change to vapor at previous time step + REAL diffcorr + +!bs * + REAL csqt_org +!bs * end update +!bs + + REAL csqt +!....................................................................... +! begin body of subroutine NUCLCOND + + +!........... Main computational grid-traversal loop nest +!........... for computing condensation and nucleation: + + DO lcell = 1, & + numcells +! *** First moment: + +! 1st loop over NUMCELLS + am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04 + am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04 + +!.............. near-continuum factors [ 1 / sec ] +!bs +!bs * adopted from code of FSB +!bs * correction to DIFFSULF and DIFFORG for temperature and pressure +!bs + diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1. +!bs + gnc3n = cconc*am1n*diffcorr + gnc3a = cconc*am1a*diffcorr + + +! *** Second moment: + + am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16 + am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16 + + csqt = ccofm*sqrt(blkta(lcell)) +!............... free molecular factors [ 1 / sec ] + +! put in temperature fac + gfm3n = csqt*am2n + gfm3a = csqt*am2a + +! *** Condensation factors in [ s**-1] for h2so4 +! *** In the future, separate factors for condensing organics will +! be included. In this version, the h2so4 values are used. + +!............... Twice the harmonic mean of fm, nc functions: + +! *** Force 64 bit evaluation: + + fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n) + fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a) + fconc = fconcn(lcell) + fconca(lcell) + +! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<< +!bs +!bs * start modifications for organcis +!bs + gnc3n = cconc_org*am1n*diffcorr + gnc3a = cconc_org*am1a*diffcorr +!bs + csqt_org = ccofm_org*sqrt(blkta(lcell)) + gfm3n = csqt_org*am2n + gfm3a = csqt_org*am2a +!bs + fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n) + fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a) +!bs +!bs * end modifications for organics +!bs +! *** calculate the total change to sulfuric acid vapor from production +! and condensation + + vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor + vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* & + dt +! vapor at prev + vapor2 = max(0.0,vapor2) + + deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt))) + +! *** Calculate increment in total sufate aerosol mass concentration + +! *** This follows the method of Youngblood & Kreidenweis. + +!bs +!bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP) +!bs +!bs * allow DELTASO4A to be negative, but the change must not be larger +!bs * than the amount of vapor available. +!bs + deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), & + so4rat(lcell)*dt-deltavap) +!bs + +! *** zero out growth coefficients + + cgrn3(lcell) = 0.0 + cgra3(lcell) = 0.0 + + + END DO + +! *** Select method of nucleation + +! End 1st loop over NUMCELLS + IF (inucl==1) THEN + +! *** Do Youngblood & Kreidenweis Nucleation + +! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH, +! & DNDT,DMDT,NUMCELLS,BLKSIZE, +! & VAPOR1) +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF + + ELSE IF (inucl==0) THEN + +! *** Do Kerminen & Wexler Nucleation + +! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH, +! & DNDT,DMDT,NUMCELLS,BLKSIZE) +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF + + + ELSE IF (inucl==2) THEN + +!bs ** Do Kulmala et al. Nucleation +! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1) + + if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then + CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)) + else + dndt(1)=0. + dmdt(1)=0. + endif + + +! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)) + if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1) + IF (dndt(1)==0.) dmdt(1) = 0. + IF (dmdt(1)==0.) dndt(1) = 0. +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF +! ELSE +! WRITE (6,'(a)') '*************************************' +! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!' +! WRITE (6,'(a)') ' PROGRAM TERMINATED !!' +! WRITE (6,'(a)') '*************************************' +! STOP + + END IF +!bs +!bs * Secondary organic aerosol module (SORGAM) +!bs +! end of selection of nucleation method + CALL sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, & + orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, & + nacv,cblk,blksize,nspcsda,numcells,dt) +!bs +!bs * Secondary organic aerosol module (SORGAM) +!bs + + DO lcell = 1, numcells + +! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL +! condensation factors + + td = 1.0/(fconcn(lcell)+fconca(lcell)) + fconcn(lcell) = td*fconcn(lcell) + fconca(lcell) = td*fconca(lcell) +!bs + td = 1.0/(fconcn_org(lcell)+fconca_org(lcell)) + fconcn_org(lcell) = td*fconcn_org(lcell) + fconca_org(lcell) = td*fconca_org(lcell) +!bs + END DO + +! *** Begin second loop over cells + + DO lcell = 1, & + numcells +! *** note CHEMRAT includes species other than sulfate. + +! 3rd loop on NUMCELLS + chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s- + chemrat_org = orgfac*(orgaro1rat(lcell)+orgaro2rat(lcell)+orgalk1rat( & + lcell)+orgole1rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ & + orgbio3rat(lcell)+orgbio4rat(lcell)) +! *** Calculate the production rates for new particle + +! [mom3 m**-3 s- + cgrn3(lcell) = so4fac*dmdt(lcell) +! Rate of increase of 3rd + chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro + +!bs Remove the rate of new pa + chemrat = max(chemrat,0.0) +! *** Now calculate the rate of condensation on existing particles. + +! Prevent CHEMRAT from being negativ + cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + & + chemrat_org*fconcn_org(lcell) + + cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell) + +! *** + + END DO +! end 2nd loop over NUMCELLS + RETURN + + END SUBROUTINE nuclcond +!23456789012345678901234567890123456789012345678901234567890123456789012 + +! nuclcond + REAL FUNCTION poly4(a,x) + REAL a(4), x + + poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)))) + RETURN + END FUNCTION poly4 + REAL FUNCTION poly6(a,x) + REAL a(6), x + + poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6)))))) + RETURN + END FUNCTION poly6 + + +!----------------------------------------------------------------------- + + + + SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, & + gnh3,gno3) + +!----------------------------------------------------------------------- + +! Description: + +! ARES calculates the chemical composition of a sulfate/nitrate/ +! ammonium/water aerosol based on equilibrium thermodynamics. + +! This code considers two regimes depending upon the molar ratio +! of ammonium to sulfate. + +! For values of this ratio less than 2,the code solves a cubic for +! hydrogen ion molality, HPLUS, and if enough ammonium and liquid +! water are present calculates the dissolved nitric acid. For molal +! ionic strengths greater than 50, nitrate is assumed not to be presen + +! For values of the molar ratio of 2 or greater, all sulfate is assume +! to be ammonium sulfate and a calculation is made for the presence of +! ammonium nitrate. + +! The Pitzer multicomponent approach is used in subroutine ACTCOF to +! obtain the activity coefficients. Abandoned -7/30/97 FSB + +! The Bromley method of calculating the activity coefficients is s use +! in this version + +! The calculation of liquid water +! is done in subroutine water. Details for both calculations are given +! in the respective subroutines. + +! Based upon MARS due to +! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld, +! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986. + +! and SCAPE due to +! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology, +! Vol 19, number 2, pages 157-181 and pages 182-198, 1993. + +! NOTE: All concentrations supplied to this subroutine are TOTAL +! over gas and aerosol phases + +! Parameters: + +! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN) +! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN) +! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN) +! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN) +! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN) +! RH : Fractional relative humidity (IN) +! TEMP : Temperature in Kelvin (IN) +! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT) +! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT) +! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT) +! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT) +! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT) +! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT) +! NITR : Number of iterations for obtaining activity coefficients (OU +! NR : Number of real roots to the cubic in the low ammonia case (OU + +! Revision History: +! Who When Detailed description of changes +! --------- -------- ------------------------------------------- +! S.Roselle 11/10/87 Received the first version of the MARS code +! S.Roselle 12/30/87 Restructured code +! S.Roselle 2/12/88 Made correction to compute liquid-phase +! concentration of H2O2. +! S.Roselle 5/26/88 Made correction as advised by SAI, for +! computing H+ concentration. +! S.Roselle 3/1/89 Modified to operate with EM2 +! S.Roselle 5/19/89 Changed the maximum ionic strength from +! 100 to 20, for numerical stability. +! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case +! using equations for nitrate budget. +! F.Binkowski 6/18/91 New ammonia poor case which +! omits letovicite. +! F.Binkowski 7/25/91 Rearranged entire code, restructured +! ammonia poor case. +! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output +! as SO4-- +! F.Binkowski 12/6/91 Changed the ammonia defficient case so that +! there is only neutralized sulfate (ammonium +! sulfate) and sulfuric acid. +! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen +! with the Cohen et al. (1987) maximum molalit +! of 36.2 in Table III.( J. Phys Chem (91) page +! 4569, and Table IV p 4587.) +! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem +! possibility for denomenator becoming zero; +! this involved solving for HPLUS first. +! Note that for a relative humidity +! less than 50%, the model assumes that there i +! aerosol nitrate. +! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System +! Redid logic as follows +! 1. Water algorithm now follows Spann & Richard +! 2. Pitzer Multicomponent method used +! 3. Multicomponent practical osmotic coefficien +! use to close iterations. +! 4. The model now assumes that for a water +! mass fraction WFRAC less than 50% there is +! no aerosol nitrate. +! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p +! case, and changed the WFRAC criterion to 40%. +! For ammonium to sulfate ratio less than 1.0 +! all ammonium is aerosol and no nitrate aerosol +! exists. +! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case +! allow gas-phase ammonia to exist. +! F.Binkowski 7/26/95 Changed equilibrium constants to values from +! Kim et al. (1993) +! F.Binkowski 6/27/96 Changed to new water format +! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent +! activity coefficients. The binary activity coe +! are the same as the previous version +! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e +! 1 picogram per cubic meter + +!----------------------------------------------------------------------- + +! IMPLICIT NONE + +!...........INCLUDES and their descriptions + +!cc INCLUDE SUBST_CONST ! constants + +!...........PARAMETERS and their descriptions: + +! molecular weight for NaCl + REAL mwnacl + PARAMETER (mwnacl=58.44277) + +! molecular weight for NO3 + REAL mwno3 + PARAMETER (mwno3=62.0049) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HSO4 + REAL mwhso4 + PARAMETER (mwhso4=mwso4+1.0080) + +! molecular weight for H2SO4 + REAL mh2so4 + PARAMETER (mh2so4=98.07354) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +! molecular weight for NH4 + REAL mwnh4 + PARAMETER (mwnh4=18.03858) + +! molecular weight for Organic Specie + REAL mworg + PARAMETER (mworg=16.0) + +! molecular weight for Chloride + REAL mwcl + PARAMETER (mwcl=35.453) + +! molecular weight for AIR + REAL mwair + PARAMETER (mwair=28.964) + +! molecular weight for Letovicite + REAL mwlct + PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080) + +! molecular weight for Ammonium Sulfa + REAL mwas + PARAMETER (mwas=2.0*mwnh4+mwso4) + +! molecular weight for Ammonium Bisul + REAL mwabs + PARAMETER (mwabs=mwnh4+mwso4+1.0080) + +!...........ARGUMENTS and their descriptions + +!iamodels3 + REAL so4 +! Total sulfate in micrograms / m**3 +! Total nitric acid in micrograms / m + REAL hno3 +! Total nitrate in micrograms / m**3 + REAL no3 +! Total ammonia in micrograms / m**3 + REAL nh3 +! Total ammonium in micrograms / m**3 + REAL nh4 +! Fractional relative humidity + REAL rh +! Temperature in Kelvin + REAL temp +! Aerosol sulfate in micrograms / m** + REAL aso4 +! Aerosol nitrate in micrograms / m** + REAL ano3 +! Aerosol liquid water content water + REAL ah2o +! Aerosol ammonium in micrograms / m* + REAL anh4 +! Gas-phase nitric acid in micrograms + REAL gno3 + + REAL gnh3 +!...........SCRATCH LOCAL VARIABLES and their descriptions: + +! Gas-phase ammonia in micrograms / m +! Index set to percent relative humid + INTEGER irh +! Number of iterations for activity c + INTEGER nitr +! Loop index for iterations + INTEGER nnn + + INTEGER nr +! Number of roots to cubic equation f + REAL*8 & ! Coefficients and roots of + a0 + REAL*8 & ! Coefficients and roots of + a1 + REAL*8 & ! Coefficients and roots of + a2 +! Coefficients and discriminant for q + REAL aa +! internal variables ( high ammonia c + REAL bal +! Coefficients and discriminant for q + REAL bb +! Variables used for ammonia solubili + REAL bhat +! Coefficients and discriminant for q + REAL cc +! Factor for conversion of units + REAL convt +! Coefficients and discriminant for q + REAL dd +! Coefficients and discriminant for q + REAL disc +! Relative error used for convergence + REAL eror +! Free ammonia concentration , that + REAL fnh3 +! Activity Coefficient for (NH4+, HSO + REAL gamaab +! Activity coefficient for (NH4+, NO3 + REAL gamaan +! Variables used for ammonia solubili + REAL gamahat +! Activity coefficient for (H+ ,NO3-) + REAL gamana +! Activity coefficient for (2H+, SO4- + REAL gamas1 +! Activity coefficient for (H+, HSO4- + REAL gamas2 +! used for convergence of iteration + REAL gamold +! internal variables ( high ammonia c + REAL gasqd +! Hydrogen ion (low ammonia case) (mo + REAL hplus +! Equilibrium constant for ammoniua t + REAL k1a +! Equilibrium constant for sulfate-bi + REAL k2sa +! Dissociation constant for ammonium + REAL k3 +! Equilibrium constant for ammonium n + REAL kan +! Variables used for ammonia solubili + REAL khat +! Equilibrium constant for nitric aci + REAL kna +! Henry's Law Constant for ammonia + REAL kph +! Equilibrium constant for water diss + REAL kw +! Internal variable using KAN + REAL kw2 +! Nitrate (high ammonia case) (moles + REAL man +! Sulfate (high ammonia case) (moles + REAL mas +! Bisulfate (low ammonia case) (moles + REAL mhso4 +! Nitrate (low ammonia case) (moles / + REAL mna +! Ammonium (moles / kg water) + REAL mnh4 +! Total number of moles of all ions + REAL molnu +! Sulfate (low ammonia case) (moles / + REAL mso4 +! Practical osmotic coefficient + REAL phibar +! Previous value of practical osmotic + REAL phiold +! Molar ratio of ammonium to sulfate + REAL ratio +! Internal variable using K2SA + REAL rk2sa +! Internal variables using KNA + REAL rkna +! Internal variables using KNA + REAL rknwet + REAL rr1 + REAL rr2 +! Ionic strength + REAL stion +! Internal variables for temperature + REAL t1 +! Internal variables for temperature + REAL t2 +! Internal variables of convenience ( + REAL t21 +! Internal variables of convenience ( + REAL t221 +! Internal variables for temperature + REAL t3 +! Internal variables for temperature + REAL t4 +! Internal variables for temperature + REAL t6 +! Total ammonia and ammonium in micro + REAL tnh4 +! Total nitrate in micromoles / meter + REAL tno3 +! Tolerances for convergence test + REAL toler1 +! Tolerances for convergence test + REAL toler2 +! Total sulfate in micromoles / meter + REAL tso4 +! 2.0 * TSO4 (high ammonia case) (mo + REAL twoso4 +! Water mass fraction + REAL wfrac + ! micrograms / meter **3 on output + REAL wh2o + ! internally it is 10 ** (-6) kg (wat + ! the conversion factor (1000 g = 1 k + ! for AH2O output +! Aerosol liquid water content (inter +! internal variables ( high ammonia c + REAL wsqd +! Nitrate aerosol concentration in mi + REAL xno3 +! Variable used in quadratic solution + REAL xxq +! Ammonium aerosol concentration in m + REAL ynh4 +! Water variable saved in case ionic + REAL zh2o + + REAL zso4 +! Total sulfate molality - mso4 + mhs + REAL cat(2) ! Array for cations (1, H+); (2, NH4+ + REAL an(3) ! Array for anions (1, SO4--); (2, NO + REAL crutes(3) ! Coefficients and roots of + REAL gams(2,3) ! Array of activity coefficients +! Minimum value of sulfate laerosol c + REAL minso4 + PARAMETER (minso4=1.0E-6/mwso4) + REAL floor + PARAMETER (floor=1.0E-30) +!----------------------------------------------------------------------- +! begin body of subroutine RPMARES + +!...convert into micromoles/m**3 +!cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3 +!iamodels3 merge NH3/NH4 , HNO3,NO3 here +! minimum concentration + tso4 = max(0.0,so4/mwso4) + tno3 = max(0.0,(no3/mwno3+hno3/mwhno3)) + tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4)) +!cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH + +!...now set humidity index IRH as a percent + + irh = nint(100.0*rh) + +!...Check for valid IRH + + irh = max(1,irh) + irh = min(99,irh) +!cc WRITE(10,*)'RH,IRH ',RH,IRH + +!...Specify the equilibrium constants at correct +!... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA +!... KPH, and K3 ) +!... Values from Kim et al. (1993) except as noted. + + convt = 1.0/(0.082*temp) + t6 = 0.082E-9*temp + t1 = 298.0/temp + t2 = alog(t1) + t3 = t1 - 1.0 + t4 = 1.0 + t2 - t1 + kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6 + k1a = 1.805E-05*exp(-1.50*t3+26.92*t4) + k2sa = 1.015E-02*exp(8.85*t3+25.14*t4) + kw = 1.010E-14*exp(-22.52*t3+26.92*t4) + kph = 57.639*exp(13.79*t3-5.39*t4)*t6 +!cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6 + khat = kph*k1a/kw + kan = kna*khat + +!...Compute temperature dependent equilibrium constant for NH4NO3 +!... ( from Mozurkewich, 1993) + + k3 = exp(118.87-24084.0/temp-6.025*alog(temp)) + +!...Convert to (micromoles/m**3) **2 + + k3 = k3*convt*convt + + wh2o = 0.0 + stion = 0.0 + ah2o = 0.0 + mas = 0.0 + man = 0.0 + hplus = 0.0 + toler1 = 0.00001 + toler2 = 0.001 + nitr = 0 + nr = 0 + ratio = 0.0 + gamaan = 1.0 + gamold = 1.0 + +!...set the ratio according to the amount of sulfate and nitrate + IF (tso4>minso4) THEN + ratio = tnh4/tso4 + +!...If there is no sulfate and no nitrate, there can be no ammonium +!... under the current paradigm. Organics are ignored in this version. + + ELSE + + IF (tno3==0.0) THEN + +! *** If there is very little sulfate and no nitrate set concentrations +! to a very small value and return. + aso4 = max(floor,aso4) + ano3 = max(floor,ano3) + wh2o = 0.0 + ah2o = 0.0 + gnh3 = max(floor,gnh3) + gno3 = max(floor,gno3) + RETURN + END IF + +!...For the case of no sulfate and nonzero nitrate, set ratio to 5 +!... to send the code to the high ammonia case + + ratio = 5.0 + END IF + +!.................................... +!......... High Ammonia Case ........ +!.................................... + + IF (ratio>2.0) THEN + + gamaan = 0.1 + +!...Set up twice the sulfate for future use. + + twoso4 = 2.0*tso4 + xno3 = 0.0 + ynh4 = twoso4 + +!...Treat different regimes of relative humidity + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... start with ammomium sulfate solution without nitrate + + CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3 + wh2o = 1.0E-3*ah2o + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 + wfrac = ah2o/(aso4+anh4+ah2o) +!cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water + IF (wfrac<0.2) THEN + +!... dry ammonium sulfate and ammonium nitrate +!... compute free ammonia + + fnh3 = tnh4 - twoso4 + cc = tno3*fnh3 - k3 + +!...check for not enough to support aerosol + + IF (cc<=0.0) THEN + xno3 = 0.0 + ELSE + aa = 1.0 + bb = -(tno3+fnh3) + disc = bb*bb - 4.0*cc + +!...Check for complex roots of the quadratic +!... set nitrate to zero and RETURN if complex roots are found + + IF (disc<0.0) THEN + xno3 = 0.0 + ah2o = 1000.0*wh2o + ynh4 = twoso4 + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 + RETURN + END IF + +!...to get here, BB .lt. 0.0, CC .gt. 0.0 always + + dd = sqrt(disc) + xxq = -0.5*(bb+sign(1.0,bb)*dd) + +!...Since both roots are positive, select smaller root. + + xno3 = min(xxq/aa,cc/xxq) + + END IF + ah2o = 1000.0*wh2o + ynh4 = 2.0*tso4 + xno3 + gno3 = (tno3-xno3)*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = xno3*mwno3 + anh4 = ynh4*mwnh4 + RETURN + + END IF + +!...liquid phase containing completely neutralized sulfate and +!... some nitrate. Solve for composition and quantity. + + mas = tso4/wh2o + man = 0.0 + xno3 = 0.0 + ynh4 = twoso4 + phiold = 1.0 + +!...Start loop for iteration + +!...The assumption here is that all sulfate is ammonium sulfate, +!... and is supersaturated at lower relative humidities. + + DO nnn = 1, 150 + nitr = nnn + gasqd = gamaan*gamaan + wsqd = wh2o*wh2o + kw2 = kan*wsqd/gasqd + aa = 1.0 - kw2 + bb = twoso4 + kw2*(tno3+tnh4-twoso4) + cc = -kw2*tno3*(tnh4-twoso4) + +!...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut + + disc = bb*bb - 4.0*aa*cc + +!...Check for complex roots, if so set nitrate to zero and RETURN + + IF (disc<0.0) THEN + xno3 = 0.0 + ah2o = 1000.0*wh2o + ynh4 = twoso4 + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 +!cc WRITE( 10, * ) ' COMPLEX ROOTS ' + RETURN + END IF + + dd = sqrt(disc) + xxq = -0.5*(bb+sign(1.0,bb)*dd) + rr1 = xxq/aa + rr2 = cc/xxq + +!...choose minimum positve root + + IF ((rr1*rr2)<0.0) THEN + xno3 = max(rr1,rr2) + ELSE + xno3 = min(rr1,rr2) + END IF + + xno3 = min(xno3,tno3) + +!...This version assumes no solid sulfate forms (supersaturated ) +!... Now update water + + CALL awater(irh,tso4,ynh4,xno3,ah2o) + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... The conversion from micromoles to moles is done by the units of WH + + wh2o = 1.0E-3*ah2o + +!...Ionic balance determines the ammonium in solution. + + man = xno3/wh2o + mas = tso4/wh2o + mnh4 = 2.0*mas + man + ynh4 = mnh4*wh2o + +!...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate +!... and ammonium in molal units (moles/(kg water) ). + + stion = 3.0*mas + man + cat(1) = 0.0 + cat(2) = mnh4 + an(1) = mas + an(2) = man + an(3) = 0.0 + CALL actcof(cat,an,gams,molnu,phibar) + gamaan = gams(2,2) + +!...Use GAMAAN for convergence control + + eror = abs(gamold-gamaan)/gamold + gamold = gamaan + +!...Check to see if we have a solution + + IF (eror<=toler1) THEN +!cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS +!cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR + + aso4 = tso4*mwso4 + ano3 = xno3*mwno3 + anh4 = ynh4*mwnh4 + gno3 = (tno3-xno3)*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + ah2o = 1000.0*wh2o + RETURN + END IF + + END DO + +!...If after NITR iterations no solution is found, then: + + aso4 = tso4*mwso4 + ano3 = 0.0 + ynh4 = twoso4 + anh4 = ynh4*mwnh4 + CALL awater(irh,tso4,ynh4,xno3,ah2o) + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + RETURN + + ELSE + +!...................................... +!......... Low Ammonia Case ........... +!...................................... + +!...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95) + +!...All cases covered by this logic + wh2o = 0.0 + CALL awater(irh,tso4,tnh4,tno3,ah2o) + wh2o = 1.0E-3*ah2o + zh2o = ah2o +!...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate +!... per cubic meter of air (1000 g = 1 kg) + + aso4 = tso4*mwso4 + anh4 = tnh4*mwnh4 + ano3 = 0.0 + gno3 = tno3*mwhno3 + gnh3 = 0.0 + +!...Check for zero water. + + IF (wh2o==0.0) RETURN + zso4 = tso4/wh2o + +!...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4 + +!cc IF ( ZSO4 .GT. 11.0 ) THEN + +!...do not solve for aerosol nitrate for total sulfate molality +!... greater than 11.0 because the model parameters break down +!... greater than 9.0 because the model parameters break down + + IF (zso4>9.0) & ! 18 June 97 + THEN + RETURN + END IF + +!...First solve with activity coeffs of 1.0, then iterate. + + phiold = 1.0 + gamana = 1.0 + gamas1 = 1.0 + gamas2 = 1.0 + gamaab = 1.0 + gamold = 1.0 + +!...All ammonia is considered to be aerosol ammonium. + + mnh4 = tnh4/wh2o + +!...MNH4 is the molality of ammonium ion. + + ynh4 = tnh4 +!...loop for iteration + + DO nnn = 1, 150 + nitr = nnn + +!...set up equilibrium constants including activities +!... solve the system for hplus first then sulfate & nitrate +! print*,'gamas,gamana',gamas1,gamas2,gamana + rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1) + rkna = kna/(gamana*gamana) + rknwet = rkna*wh2o + t21 = zso4 - mnh4 + t221 = zso4 + t21 + +!...set up coefficients for cubic + + a2 = rk2sa + rknwet - t21 + a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3 + a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3) + + + CALL cubic(a2,a1,a0,nr,crutes) + +!...Code assumes the smallest positive root is in CRUTES(1) + + hplus = crutes(1) + bal = hplus**3 + a2*hplus**2 + a1*hplus + a0 + mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat + mhso4 = zso4 - & ! molality of bisulf + mso4 + mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat + mna = max(0.0,mna) + mna = min(mna,tno3/wh2o) + xno3 = mna*wh2o + ano3 = mna*wh2o*mwno3 + gno3 = (tno3-xno3)*mwhno3 +!...Calculate ionic strength + + stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4) + +!...Update water + + CALL awater(irh,tso4,ynh4,xno3,ah2o) + +!...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate +!... per cubic meter of air (1000 g = 1 kg) + + wh2o = 1.0E-3*ah2o + cat(1) = hplus + cat(2) = mnh4 + an(1) = mso4 + an(2) = mna + an(3) = mhso4 +! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar + CALL actcof(cat,an,gams,molnu,phibar) + + gamana = gams(1,2) + gamas1 = gams(1,1) + gamas2 = gams(1,3) + gamaan = gams(2,2) + + gamahat = (gamas2*gamas2/(gamaab*gamaab)) + bhat = khat*gamahat +!cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD ) +!cc PHIOLD = PHIBAR + eror = abs(gamold-gamahat)/gamold + gamold = gamahat + +!...write out molalities and activity coefficient +!... and return with good solution + + IF (eror<=toler2) THEN +!cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA +!cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3), +!cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR + RETURN + END IF + + END DO + +!...after NITR iterations, failure to solve the system, no ANO3 + + gno3 = tno3*mwhno3 + ano3 = 0.0 + CALL awater(irh,tso4,tnh4,tno3,ah2o) + RETURN + + + END IF +! ratio .gt. 2.0 +! /////////////////////////////////////////////////// + END SUBROUTINE rpmares_old +!ia********************************************************* +!ia * +!ia BEGIN OF AEROSOL ROUTINE * +!ia * +!ia********************************************************* + +!*********************************************************************** + +! BEGIN OF AEROSOL CALCULATIONS + +!*********************************************************************** + + +!ia********************************************************************* +!ia * +!ia MAIN AEROSOL DYNAMICS ROUTINE * +!ia based on MODELS3 formulation by FZB * +!ia Modified by IA in May 97 * +!ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE +!ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND +!ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL +!ia CALCULATIONS. +!ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR +!ia ONE GRID CELL!!!! +!ia and passed to dynamics calcs. subroutines. +!ia * +!ia Revision history * +!ia When WHO WHAT * +!ia ---- ---- ---- * +!ia ???? FZB BEGIN * +!ia 05/97 IA Adapted for use in CTM2-S * +!ia Modified renaming/bug fixing * +!ia 11/97 IA Modified for new model version +!ia see comments under iarev02 +!ia 03/98 IA corrected error on pressure units +!ia * +!ia Called BY: CHEM * +!ia * +!ia Calls to: OUTPUT1,AEROPRC * +!ia * +!ia********************************************************************* + +! end RPMares + SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, & + nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv, & + nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, & + soilrat_in,cblk,igrid,jgrid,kgrid) + + + +! IMPLICIT NONE + +! Includes: + +!iarev02 INCLUDE AEROINCL.EXT +! block size, set to 1 in column model ciarev0 + INTEGER blksize +!ia kept to 1 in current version of column model + INTEGER numcells + +! actual number of cells in arrays ( default is + PARAMETER (numcells=1) + + + INTEGER layer +! number of layer (default is 1 in + + INTEGER ncell +! index for cell in blocked array (default is 1 in + PARAMETER (ncell=1) +! *** inputs +! Input temperature [ K ] + REAL temp +! Input relative humidity [ fraction ] + REAL relhum +! Input pressure [ hPa ] + REAL pres +! Input number for Aitken mode [ m**-3 ] + REAL numnuc_in +! Input number for accumulation mode [ m**-3 ] + REAL numacc_in +! Input number for coarse mode [ m**-3 ] + REAL numcor_in + ! sulfuric acid [ ug m**-3 ] + REAL vsulf_in +! total sulfate vapor as sulfuric acid as + ! sulfuric acid [ ug m**-3 ] + REAL asulf_in +! total sulfate aerosol as sulfuric acid as +! i-mode sulfate input as sulfuric acid [ ug m* + REAL asulfi_in +! ammonia gas [ ug m**-3 ] + REAL nh3_in +! input value of nitric acid vapor [ ug m**-3 ] + REAL nitrate_in +! Production rate of sulfuric acid [ ug m**-3 + REAL so4rat_in + ! aerosol [ ug m**-3 s**-1 ] + REAL soilrat_in +! Production rate of soil derived coarse +! Emission rate of i-mode EC [ug m**-3 s**-1] + REAL eeci_in +! Emission rate of j-mode EC [ug m**-3 s**-1] + REAL eecj_in +! Emission rate of j-mode org. aerosol [ug m**- + REAL eorgi_in + + REAL eorgj_in +!bs +! Emission rate of j-mode org. aerosol [ug m**- +! total # of cond. vapors & SOA species + INTEGER ncv +! # of anthrop. cond. vapors & SOA speci + INTEGER nacv +! # of organic aerosol precursor + INTEGER ldrog + REAL drog_in(ldrog) ! organic aerosol precursor [ppm] +! Input delta ROG concentration of + REAL condvap_in(ncv) ! cond. vapor input [ug m^-3] + REAL drog(blksize,ldrog) ! organic aerosol precursor [ppm] +!bs +! *** Primary emissions rates: [ ug / m**3 s ] + +! *** emissions rates for unidentified PM2.5 mass +! Delta ROG concentration of + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** Primary emissions rates [ ug m**-3 s -1 ] : + +! Accumululaton mode + REAL epm25(blksize) ! emissions rate for PM2.5 mass + REAL esoil(blksize) ! emissions rate for soil derived coarse a + REAL eseas(blksize) ! emissions rate for marine coarse aerosol + REAL epmcoarse(blksize) +! emissions rate for anthropogenic coarse + + REAL dtsec + +! time step [ s ], PASSED FROM MAIN COLUMN MODE + + REAL newm3 + + REAL totaersulf +! total aerosol sulfate +! loop index for time steps + INTEGER numsteps + + REAL step + +! *** arrays for aerosol model codes: + +! synchronization time [s] + + INTEGER nspcsda + +! number of species in CBLK ciarev02 + REAL cblk(blksize,nspcsda) + +! *** Meteorological information in blocked arays: + +! *** Thermodynamic variables: + +! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL blkdens(blksize) ! Air density [ kg m^-3 ] + REAL blkrh(blksize) + + +! *** Chemical production rates [ ug m**-3 s -1 ] : + +! Fractional relative humidity + REAL so4rat(blksize) ! rate [ug/m^3/s] +! sulfuric acid vapor-phase production + REAL orgaro1rat(blksize) ! production rate from aromatics [ ug / +! anthropogenic organic aerosol mass + REAL orgaro2rat(blksize) ! production rate from aromatics [ ug / +! anthropogenic organic aerosol mass + REAL orgalk1rat(blksize) ! rate from alkanes & others [ ug / m^3 +! anthropogenic organic aerosol mass pro + REAL orgole1rat(blksize) ! rate from alkanes & others [ ug / m^3 +! anthropogenic organic aerosol mass pro + REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ] +!bs +! *** atmospheric properties + +! biogenic organic aerosol production + REAL xlm(blksize) ! atmospheric mean free path [ m ] + REAL amu(blksize) +! *** aerosol properties: + + +! *** modal diameters: + +! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! nuclei mode geometric mean diamete + REAL dgacc(blksize) ! accumulation geometric mean diamet + REAL dgcor(blksize) + +! *** Modal mass concentrations [ ug m**3 ] + +! coarse mode geometric mean diamete + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) +! *** average modal particle densities [ kg/m**3 ] + +! mass concentration in coarse mode + REAL pdensn(blksize) ! average particle density in nuclei + REAL pdensa(blksize) ! average particle density in accumu + REAL pdensc(blksize) +! *** average modal Knudsen numbers + +! average particle density in coarse + REAL knnuc(blksize) ! nuclei mode Knudsen number + REAL knacc(blksize) ! accumulation Knudsen number + REAL kncor(blksize) +! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ] + +! coarse mode Knudsen number + REAL fconcn(blksize) +! reciprocal condensation rate Aitke + REAL fconca(blksize) !bs +! reciprocal condensation rate acclu + REAL fconcn_org(blksize) + REAL fconca_org(blksize) +!bs + +! *** Rates for secondary particle formation: + +! *** production of new mass concentration [ ug/m**3 s ] + REAL dmdt(blksize) ! by particle formation + +! *** production of new number concentration [ number/m**3 s ] + +! rate of production of new mass concen + REAL dndt(blksize) ! by particle formation +! *** growth rate for third moment by condensation of precursor +! vapor on existing particles [ 3rd mom/m**3 s ] + +! rate of producton of new particle num + REAL cgrn3(blksize) ! Aitken mode + REAL cgra3(blksize) +! *** Rates for coaglulation: [ m**3/s ] + +! *** Unimodal Rates: + +! Accumulation mode + REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra + REAL ura00(blksize) + +! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod + +! accumulation mode 0th moment self-coagulat + REAL brna01(blksize) ! rate for 0th moment + REAL brna31(blksize) +! *** other processes + +! rate for 3rd moment + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u + + +! *** housekeeping variables: + +! increment of concentration added to + INTEGER unit + PARAMETER (unit=30) + + CHARACTER*16 pname + PARAMETER (pname=' BOX ') + + + + + INTEGER isp,igrid,jgrid,kgrid + +! loop index for species. + INTEGER ii, iimap(8) + DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/ + + +! begin body of program box + +! *** Set up files and other info + + +! *** set up experimental conditions + +! *** initialize model variables + +!ia *** not required any more + +!ia DO ISP = 1, NSPCSDA +!ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number +!ia END DO + + step = & ! set time step + dtsec + blkta(blksize) = & ! T in Kelvin + temp + blkprs(blksize) = pres* & ! P in Pa (pres is given in + 100. + blkrh(blksize) = & ! fractional RH + relhum + blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in +!rs CBLK(BLKSIZE,VHNO3) = nitrate_in +!rs CBLK(BLKSIZE,VNH3) = nh3_in +!bs +!rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1) +!rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2) +!rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1) +!rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1) +!rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1) +!rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2) +!rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1) +!rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2) +! dr + DO isp = 1, ldrog + drog(blksize,isp) = drog_in(isp) + END DO +! print*,'drog in rpm',drog +!bs +!ia *** 27/05/97 the following variables are transported quantities +!ia *** of the column-model now and thuse do not need this init. +!ia *** step. + +! CBLK(BLKSIZE,VNU0) = numnuc_in +! CBLK(BLKSIZE,VAC0) = numacc_in +! CBLK(BLKSIZE,VSO4A) = asulf_in +! CBLK(BLKSIZE,VSO4AI) = asulfi_in +! CBLK(BLKSIZE, VCORN) = numcor_in + + + so4rat(blksize) = so4rat_in + +!...INITIALISE EMISSION RATES + +! epm25i(blksize) = & ! unidentified PM2.5 mass +! 0.0 +! epm25j(blksize) = & +! 0.0 +! unidentified PM2.5 m + eorgi(blksize) = & ! primary organic + eorgi_in + eorgj(blksize) = & + eorgi_in +! primary organic + eeci(blksize) = & ! elemental carbon + eeci_in + eecj(blksize) = & + eecj_in +! elemental carbon + epm25(blksize) = & !currently from input file ACTIONIA + 0.0 + esoil(blksize) = & ! ACTIONIA + soilrat_in + eseas(blksize) = & !currently from input file ACTIONIA + 0.0 +! epmcoarse(blksize) = & !currently from input file ACTIONIA +! 0.0 + dgnuc(blksize) = dginin + dgacc(blksize) = dginia + dgcor(blksize) = dginic + newm3 = 0.0 + + + +! *** Set up initial total 3rd moment factors + + totaersulf = 0.0 + newm3 = 0.0 +! *** time loop + +! write(50,*) ' numsteps dgnuc dgacc ', +! & ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j' + + +! *** Call aerosol routines + + CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, & + blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat, & + orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, & + nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, & + amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, & + knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, & + urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid) + +! *** write output + +! WRITE(UNIT,*) ' AFTER AEROPROC ' +! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS + +! *** Write out file for graphing. + +! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8) + + +! *** update sulfuric acid vapor +!ia 21.04.98 this update is not required here +!ia artefact from box model +! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) + +! & SO4RAT(BLKSIZE) * STEP + + RETURN + +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + END SUBROUTINE rpmmod3 +! main box model + SUBROUTINE soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, & + orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, & + nacv,cblk,blksize,nspcsda,numcells,dt) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs SOA_PART calculates the formation and partitioning of secondary ! +!bs organic aerosol based on (pseudo-)ideal solution thermodynamics. ! +!bs ! +!bs This code considers two cases: ! +!bs i) initil absorbing mass is existend in the aerosol phase ! +!bs ii) a threshold has to be exeeded before partitioning (even below ! +!bs saturation) will take place. ! +!bs ! +!bs The temperature dependence of the saturation concentrations are ! +!bs calculated using the Clausius-Clapeyron equation. ! +!bs ! +!bs It is assumed that the condensable vapors also evaporate if the ! +!bs saturation concentraion lowers e.g. due to temperature effects. ! +!bs Therefor negative production rates (= evaporation rates) are ! +!bs possible. ! +!bs ! +!bs If there is no absorbing mass at all the Pandis method is applied ! +!bs for the first steps. ! +!bs ! +!bs References: ! +!bs Pankow (1994): ! +!bs An absorption model of the gas/aerosol ! +!bs partitioning involved in the formation of ! +!bs secondary organic aerosol, Atmos. Environ. 28(2), ! +!bs 189-193. ! +!bs Odum et al. (1996): ! +!bs Gas/particle partitioning and secondary organic ! +!bs aerosol yields, Environ. Sci. Technol. 30, ! +!bs 2580-2585. ! +!bs see also ! +!bs Bowman et al. (1997): ! +!bs Mathematical model for gas-particle partitioning ! +!bs of secondary organic aerosols, Atmos. Environ. ! +!bs 31(23), 3921-3931. ! +!bs Seinfeld and Pandis (1998): ! +!bs Atmospheric Chemistry and Physics (0-471-17816-0) ! +!bs chapter 13.5.2 Formation of binary ideal solution ! +!bs with -- preexisting aerosol ! +!bs -- other organic vapor ! +!bs ! +!bs Called by: SORGAM ! +!bs ! +!bs Calls: None ! +!bs ! +!bs Arguments: LAYER, ! +!bs BLKTA, BLKPRS, ! +!bs ORGARO1RAT, ORGARO2RAT, ! +!bs ORGALK1RAT, ORGOLE1RAT, ! +!bs ORGBIO1RAT, ORGBIO2RAT, ! +!bs ORGBIO3RAT, ORGBIO4RAT, ! +!bs DROG, LDROG, NCV, NACV, ! +!bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, ! +!bs DT ! +!bs ! +!bs Include files: AEROSTUFF.EXT ! +!bs AERO_internal.EXT ! +!bs ! +!bs Data: None ! +!bs ! +!bs Input files: None ! +!bs ! +!bs Output files: None ! +!bs ! +!bs--------------------------------------------------------------------! +!bs ! +!bs History: ! +!bs No Date Author Change ! +!bs ____ ______ ________________ _________________________________ ! +!bs 01 170399 B.Schell Set up ! +!bs 02 050499 B.Schell introduced SR NEWT ! +!bs 03 040599 B.Schell include-file sorgam.inc ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs * includes +!bs +!bs +!bs * input variables +!bs +! model layer + INTEGER layer +! dimension of arrays + INTEGER blksize +! number of species in CBLK + INTEGER nspcsda +! actual number of cells in arrays + INTEGER numcells +! # of organic aerosol precursor + INTEGER ldrog +! total # of cond. vapors & SOA sp + INTEGER ncv +! # of anthrop. cond. vapors & SOA + INTEGER nacv + REAL cblk(blksize,nspcsda) ! main array of variables +! model time step in SECONDS + REAL dt + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL orgaro1rat(blksize) ! rates from aromatics +! anth. organic vapor production + REAL orgaro2rat(blksize) ! rates from aromatics +! anth. organic vapor production + REAL orgalk1rat(blksize) ! rates from alkenes and others +! anth. organic vapor production + REAL orgole1rat(blksize) ! rates from alkanes and others +! anth. organic vapor production + REAL orgbio1rat(blksize) ! bio. organic vapor production ra + REAL orgbio2rat(blksize) ! bio. organic vapor production ra + REAL orgbio3rat(blksize) ! bio. organic vapor production ra + REAL orgbio4rat(blksize) ! bio. organic vapor production ra + REAL drog(blksize,ldrog) !bs +!bs * local variable declaration +!bs +! Delta ROG conc. [ppm] +!bs numerical value for a minimum thresh + REAL thrsmin + PARAMETER (thrsmin=1.E-19) +!bs numerical value for a minimum thresh +!bs +!bs universal gas constant [J/mol-K] + REAL rgas + PARAMETER (rgas=8.314510) +!bs reference temperature T0 = 298 K + REAL tnull + PARAMETER (tnull=298.) +!bs molecular weight for C + REAL mwc + PARAMETER (mwc=12.0) +!bs molecular weight for organic species + REAL mworg + PARAMETER (mworg=175.0) +!bs molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) +!bs molecular weight for NH4 + REAL mwnh4 + PARAMETER (mwnh4=18.03858) +!bs molecular weight for NO3 + REAL mwno3 + PARAMETER (mwno3=62.01287) +!bs relative tolerance for mass check + REAL rtol + PARAMETER (rtol=1.E-04) +!bs REAL DTMIN !bs minimum time step in seconds +!bs PARAMETER (DTMIN = 0.1) +!bs +!bs loop index + INTEGER lcell + INTEGER l, & !bs loop index + n +!bs conversion factor ppm --> ug/m^3 + REAL convfac +!bs difference of inverse temperatures + REAL ttinv +!bs weighted initial organic mass [10^-6 + REAL minitw +!bs weighted total organic mass [10^-6 m + REAL mtotw +!bs weighted inorganic mass [10^-6 mol/m + REAL mnonow +!bs 1. / MTOTW + REAL imtotw +!bs initial organic mass [ug/m^3] + REAL minit +!bs inorganic mass [ug/m^3] + REAL mnono +!bs total organic mass [ug/m^3] + REAL mtot +!bs threshold for SOA formatio for low M + REAL thres +!bs mass check ratio of input/output mas + REAL mcheck + REAL msum(ncv) !bs input total mass [ug/m^3] + REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/ + REAL imwcv(ncv) !bs 1. / MWCV(NCV) + REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa] + REAL dhvap(ncv) !bs heat of vaporisation of compound i [ + REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa] + REAL ctot(ncv) !bs total conc. of cond. vapor aerosol + + REAL cgas(ncv) !bs gasphase concentration of cond. vapo + REAL caer(ncv) !bs aerosolphase concentration of cond. + REAL asav(ncv) !bs saved CAER for iteration + REAL aold(ncv) !bs saved CAER for rate determination + REAL csat(ncv) !bs saturation conc. of cond. vapor [ug/ + REAL alpha(ncv) !bs molar yield for condensable vapors + REAL prod(ncv) !bs production of condensable vapor [ug/ + REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3] + REAL f(ldrog) !bs scaling factor for ind. oxidant +!bs check convergence of SR NEWT + LOGICAL check +!bs + INTEGER its +!bs * initialisation +!bs +!bs * DVAP data: average value calculated from C14-C18 monocarboxylic +!bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989): +!bs * Eniron. Sci. Technol. 1989, 23, 1519-1523. +!bs * average value is 156 kJ/mol +!bs +!bs number of iterations in NEWT + dhvap(psoaaro1) = 156.0E03 + dhvap(psoaaro2) = 156.0E03 + dhvap(psoaalk1) = 156.0E03 + dhvap(psoaole1) = 156.0E03 + dhvap(psoaapi1) = 156.0E03 + dhvap(psoaapi2) = 156.0E03 + dhvap(psoalim1) = 156.0E03 + dhvap(psoalim2) = 156.0E03 +!bs +!bs * MWCV data: average value calculated from C14-C18 monocarboxylic +!bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989): +!bs * Eniron. Sci. Technol. 1989, 23, 1519-1523. +!bs * average value is 222.5 g/mol +!bs * +!bs * molecular weights used are estimates taking the origin (reactants) +!bs * into account. This should be updated if more information abou +!bs * the products is available. +!bs * First hints are taken from Forstner et al. (1997), Environ. S +!bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmo +!bs * Environ. 31(13), 1953-1964. +!bs * +!bs * !! these molecular weights should be identical with WTM in CTM !! +!bs + mwcv(psoaaro1) = 150. + mwcv(psoaaro2) = 150. + mwcv(psoaalk1) = 140. + mwcv(psoaole1) = 140. + mwcv(psoaapi1) = 184. + mwcv(psoaapi2) = 184. + mwcv(psoalim1) = 200. + mwcv(psoalim2) = 200. +!bs +!bs * aromatic yields from: +!bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, R.C. Flagan, and +!bs * J.H. Seinfeld: The atmospheric aerosol-forming potential of whol +!bs * gasoline vapor, Science 276, 96-99, 1997. +!bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, H.J.L. Forstner, R.C. Fl +!bs * and J.H. Seinfeld: Aromatics, reformulated gasoline, and atmosph +!bs * organic aerosol formation, Environ. Sci. Technol. 31, 1890-1897, +!bs * +!bs * !! yields provided by Odum are mass-based stoichiometric coefficen +!bs * average for high and low yield aromatics +!bs * alpha1 = 0.0545 K1 = 0.0475 m^3/ug +!bs * alpha2 = 0.1525 K2 = 0.00165 m^3/ug +!bs * change to molar yields using the model MW +!bs * alpha1 * MW(XYL) / MW(PSOAARO1) = alpha1 * 106 / 150 = 0.0385 +!bs * alpha2 * MW(XYL) / MW(PSOAARO2) = alpha2 * 106 / 150 = 0.1077 +!bs * ALPHA(PSOAARO1) = 0.0385; ALPHA(PSOAARO2) = 0.1077 +!bs * +!bs +!bs * alkane and alkene yields from: +!bs * Moucheron M.C. and J. Milford: Development and testing of a proces +!bs * model for secondary organic aerosols. Air & Waste Manag. Assoc. +!bs * for presentation at the 89th Annual Meeting & Exhibition, Nashv +!bs * Tennessee, June 23-28, 96-FA130B.03, 1996. +!bs * molar yields used instead of [ ug m^-3 / ppm ], calculation +!bs * at T=298K, P=1.0133*10^5 Pa +!bs * ALPHA(PSOAALK1) = 0.048; ALPHA(PSOAOLE1) = 0.008 +!bs +!bs * biogenic yields from: +!bs * Griffin R.J., D.R. Cocker III, R.C. Flagan, and J.H. Seinfeld: +!bs * Organic aerosol formation from the oxidation of biogenic hydro- +!bs * carbons, JGR, 1999 in press. +!bs * the yields given in Table 3 are mass yields [ ug m^-3 / ug m^-3 +!bs * change to molar yields via: +!bs * molar yield = mass yield * ((R*T/M_soa*p) / (R*T/M_terp*p)) +!bs * = mass yield * (M_terp / M_soa) +!bs * = mass yield * ( M(Terpenes) / M(pinonic acid) ) +!bs * = mass yield * 136 / 184 +!bs * average for a-Pinene and Limonene, maybe splitted in future versio +!bs * 0.138 * 0.739 = 0.102; 0.345 * 0.739 = 0.254 +!bs * values for a-Pinene (molar yield) alpha1 = 0.028, alpha2 = 0.241 +!bs * values for limonene (molar yield) alpha1 = 0.163, alpha2 = 0.247 +!bs + alpha(psoaaro1) = 0.039 + alpha(psoaaro2) = 0.108 + alpha(psoaalk1) = 0.048 + alpha(psoaole1) = 0.008 +!bs ALPHA(PSOAAPI1) = 0.028 +!bs ALPHA(PSOAAPI2) = 0.241 + alpha(psoaapi1) = & !bs API + O3 only Griffin '99 + 0.092 + alpha(psoaapi2) = & !bs API + O3 only Griffin '99 + 0.075 + alpha(psoalim1) = 0.163 + alpha(psoalim2) = 0.247 +!bs +!bs * P0 data in Pa for T = 298K: +!bs * aromatics: Odum et al. (1997) using R = 8.314 J/(mol*K), +!bs * DHvap = 156 kJ/mol, T = 313K, MW = 150 g/mol and averaged +!bs * Ki's of high and low aromatics. +!bs * T = 313 => PNULL(ARO1) = 1.7E-05, PNULL(ARO2) = 5.1E-04 +!bs * T = 307.4 => PNULL(ARO1) = 5.7E-05, PNULL(ARO2) = 1.6E-03 +!bs * biogenics: Hoffmann et al. (1997); Griffin et al. (1999); +!bs * using R = 8.314 J/(mol*K), +!bs * DHvap = 156 kJ/mol, T = 313, MW = 184 g/mol, and +!bs * averaged Ki's of a-pinene and limonene +!bs * p1(298K) = 6.1E-06; p2(298K) = 1.5E-04 +!bs * Ki's for a-pinene p1(298K) = 4.0E-06; p2(298K) = 1.7E-04 +!bs * Ki's for limonene p1(298K) = 2.5E-05; p2(298K) = 1.2E-04 +!bs * alkanes and alkenes: no data available, use low value to get cl +!bs * to the Pandis yields, 1 ppt = 1*10^-7 Pa. +!bs + pnull(psoaaro1) = 5.7E-05 + pnull(psoaaro2) = 1.6E-03 + pnull(psoaalk1) = 5.0E-06 + pnull(psoaole1) = 5.0E-06 +!bs PNULL(PSOAAPI1) = 4.0E-06 +!bs PNULL(PSOAAPI2) = 1.7E-04 + pnull(psoaapi1) = & !bs API + O3 only Griffin '99 + 2.488E-05 + pnull(psoaapi2) = & !bs API + O3 only Griffin '99 + 2.778E-05 + pnull(psoalim1) = 2.5E-05 + pnull(psoalim2) = 1.2E-04 +!bs +!bs * scaling of contribution of individual oxidants to aerosol formatio +!bs + f(pxyl) = & !bs * XYL + OH + 1. + f(ptol) = & !bs * TOL + OH + 1. + f(pcsl1) = & !bs * CSL + OH + 1. + f(pcsl2) = & !bs * CSL + NO + 1. + f(phc8) = & !bs * HC + OH + 1. + f(poli1) = & !bs * OLI + OH + 1. + f(poli2) = & !bs * OLI + NO + 1. + f(poli3) = & !bs * OLI + O3 + 1. + f(polt1) = & !bs * OLT + OH + 1. + f(polt2) = & !bs * OLT + NO + 1. + f(polt3) = & !bs F(PAPI1) = 0.228 !bs * API + OH + 1. +!bs F(PAPI2) = 0. !bs * API + NO +!bs F(PAPI3) = 0.771 !bs * API + O3 +!bs * OLT + O3 + f(papi1) = & !bs * API + OH + 0. + f(papi2) = & !bs * API + NO + 0. + f(papi3) = & !bs * API + O3 + 1. + f(plim1) = & !bs * LIM + OH + 0.228 + f(plim2) = & !bs * LIM + NO + 0. + f(plim3) = & !bs + 0.771 +!bs * begin code ------------------------------------------------------- +!bs +!bs * LIM + O3 + DO lcell = 1, numcells + DO l = 1, ldrog + drog(lcell,l) = f(l)*drog(lcell,l) + END DO + ttinv = 1./tnull - 1./blkta(lcell) + convfac = blkprs(lcell)/(rgas*blkta(lcell)) + cgas(psoaaro1) = cblk(lcell,vcvaro1) + cgas(psoaaro2) = cblk(lcell,vcvaro2) + cgas(psoaalk1) = cblk(lcell,vcvalk1) + cgas(psoaole1) = cblk(lcell,vcvole1) + cgas(psoaapi1) = cblk(lcell,vcvapi1) + cgas(psoaapi2) = cblk(lcell,vcvapi2) + cgas(psoalim1) = cblk(lcell,vcvlim1) + cgas(psoalim2) = cblk(lcell,vcvlim2) + caer(psoaaro1) = cblk(lcell,vorgaro1j) + cblk(lcell,vorgaro1i) + caer(psoaaro2) = cblk(lcell,vorgaro2j) + cblk(lcell,vorgaro2i) + caer(psoaalk1) = cblk(lcell,vorgalk1j) + cblk(lcell,vorgalk1i) + caer(psoaole1) = cblk(lcell,vorgole1j) + cblk(lcell,vorgole1i) + caer(psoaapi1) = cblk(lcell,vorgba1j) + cblk(lcell,vorgba1i) + caer(psoaapi2) = cblk(lcell,vorgba2j) + cblk(lcell,vorgba2i) + caer(psoalim1) = cblk(lcell,vorgba3j) + cblk(lcell,vorgba3i) + caer(psoalim2) = cblk(lcell,vorgba4j) + cblk(lcell,vorgba4i) +!bs + prod(psoaaro1) = drog(lcell,pxyl) + drog(lcell,ptol) + & + drog(lcell,pcsl1) + drog(lcell,pcsl2) + prod(psoaaro2) = drog(lcell,pxyl) + drog(lcell,ptol) + & + drog(lcell,pcsl1) + drog(lcell,pcsl2) + prod(psoaalk1) = drog(lcell,phc8) + prod(psoaole1) = drog(lcell,poli1) + drog(lcell,poli2) + & + drog(lcell,poli3) + drog(lcell,polt1) + drog(lcell,poli2) + & + drog(lcell,polt3) + prod(psoaapi1) = drog(lcell,papi1) + drog(lcell,papi2) + & + drog(lcell,papi3) + prod(psoaapi2) = drog(lcell,papi1) + drog(lcell,papi2) + & + drog(lcell,papi3) + prod(psoalim1) = drog(lcell,plim1) + drog(lcell,plim2) + & + drog(lcell,plim3) + prod(psoalim2) = drog(lcell,plim1) + drog(lcell,plim2) + & + drog(lcell,plim3) +!bs +!bs * calculate actual production from gasphase reactions [ug/m^3] +!bs * calculate vapor pressure of pure compound as a liquid +!bs * using the Clausius-Clapeyromn equation and the actual +!bs * saturation concentration. +!bs * calculate the threshold for partitioning if no initial mass +!bs * is present to partition into. +!bs + thres = 0. + mtot = 0. + mtotw = 0. + DO l = 1, ncv + prod(l) = convfac*mwcv(l)*alpha(l)*prod(l) + ctot(l) = prod(l) + cgas(l) + caer(l) !bs redefined below + p(l) = prod(l) + msum(l) = cgas(l) + caer(l) + prod(l) + aold(l) = caer(l) + imwcv(l) = 1./mwcv(l) + pvap(l) = pnull(l)*exp(dhvap(l)/rgas*ttinv) + csat(l) = pvap(l)*mwcv(l)*1.0E06/(rgas*blkta(lcell)) + thres = thres + ((cgas(l)+prod(l))/csat(l)) + mtot = mtot + caer(l) + mtotw = mtotw + caer(l)*imwcv(l) + END DO +!bs +!bs * small amount of non-volatile absorbing mass is assumed to be +!bs * present (following Bowman et al. (1997) 0.01% of the inorganic +!bs * mass in each size section, here mode) +!bs + mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+cblk(lcell, & + vno3aj)) + mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+cblk( & + lcell,vno3ai)) + mnonow = 0.0001*(cblk(lcell,vso4aj)/mwso4+cblk(lcell,vnh4aj)/mwnh4+ & + cblk(lcell,vno3aj)/mwno3) + mnonow = mnonow + 0.0001*(cblk(lcell,vso4ai)/mwso4+cblk(lcell,vnh4ai)/ & + mwnh4+cblk(lcell,vno3ai)/mwno3) + mnono = max(mnono,conmin) + mnonow = max(mnonow,conmin) +!bs +!bs MNONOW = 0. +!bs MNONO = 0. +!bs + minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + & + cblk(lcell,vorgpai) + mnono + minitw = (cblk(lcell,vecj)+cblk(lcell,veci))/mwc + & + (cblk(lcell,vorgpaj)+cblk(lcell,vorgpai))/mworg + mnonow +!bs +!bs * If MINIT is set to zero partitioning will occur if the pure +!bs * saturation concentation is exceeded (Pandis et al. 1992). +!bs * If some amount of absorbing organic mass is formed gas/particle +!bs * partitioning will follow the ideal solution approach. +!bs + minit = 0. + minitw = 0. +!bs + mtot = mtot + minit + mtotw = mtotw + minitw + imtotw = 1./mtotw +!bs +!bs * do the gas/particle partitioning +!bs + IF ((thres>1 .AND. minitwthrsmin) .OR. & + (mtot>thrsmin)) THEN +!bs + DO l = 1, ncv + ctot(l) = p(l) + cgas(l) + caer(l) + caer(l) = ctot(l) !bs 'initial' guess + END DO +!bs +!bs * globally convergent method for nonlinear system of equations +!bs * adopted from Numerical Recipes 2nd Edition +!bs + CALL newt(layer,caer,ncv,check,ctot,csat,imwcv,minitw,its) +!bs + IF (check) THEN +! WRITE (6,'(a,i2)') '!! Problems in SR NEWT !! K: ', layer + END IF +!bs +!bs IF (layer==1) WRITE (76,'(i3)') its +!bs + DO l = 1, ncv + IF (caer(l)<=tolmin) THEN +! IF (abs(caer(l))>tolmin) WRITE (6,90000) l, caer(l) + caer(l) = conmin + END IF + IF (caer(l)>ctot(l)) THEN + IF (caer(l)-ctot(l)>tolmin) THEN +! WRITE (6,90010) + END IF + caer(l) = ctot(l) + END IF + cgas(l) = ctot(l) - caer(l) + END DO +!bs +!90000 FORMAT ('!! PROBLEMS WITH CAER, CAER < 0. !!',1X,I1,1PE14.6) +!90010 FORMAT ('!! PROBLEMS WITH CAER, CAER > CTOT !!') +!bs +!bs * assign values to CBLK array +!bs + cblk(lcell,vcvaro1) = max(cgas(psoaaro1),conmin) + cblk(lcell,vcvaro2) = max(cgas(psoaaro2),conmin) + cblk(lcell,vcvalk1) = max(cgas(psoaalk1),conmin) + cblk(lcell,vcvole1) = max(cgas(psoaole1),conmin) + cblk(lcell,vcvapi1) = max(cgas(psoaapi1),conmin) + cblk(lcell,vcvapi2) = max(cgas(psoaapi2),conmin) + cblk(lcell,vcvlim1) = max(cgas(psoalim1),conmin) + cblk(lcell,vcvlim2) = max(cgas(psoalim2),conmin) + orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt + orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt + orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt + orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt + orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt + orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt + orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt + orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt +!bs +!bs + ELSE +!bs WRITE(6,'(a)') 'Pandis method in SR SOA_PART.F used!' +!bs WRITE(6,1010) THRES, MINITW +!bs 1010 FORMAT('THRES =',1pe14.6,1X,'MINITW =',1pe14.6) +!bs +!bs do Pandis method + DO l = 1, ncv + caer(l) = ctot(l) - csat(l) + caer(l) = max(caer(l),0.) + cgas(l) = ctot(l) - caer(l) + END DO +!bs + cblk(lcell,vcvaro1) = cgas(psoaaro1) + cblk(lcell,vcvaro2) = cgas(psoaaro2) + cblk(lcell,vcvalk1) = cgas(psoaalk1) + cblk(lcell,vcvole1) = cgas(psoaole1) + cblk(lcell,vcvapi1) = cgas(psoaapi1) + cblk(lcell,vcvapi2) = cgas(psoaapi2) + cblk(lcell,vcvlim1) = cgas(psoalim1) + cblk(lcell,vcvlim2) = cgas(psoalim2) + orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt + orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt + orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt + orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt + orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt + orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt + orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt + orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt +!bs + END IF +!bs +!bs * check mass conservation +!bs + DO l = 1, ncv +!rs check is component exits + IF (cgas(l)==0. .AND. caer(l)==0. .AND. msum(l)==0) THEN + mcheck = 1. + ELSE + mcheck = (cgas(l)+caer(l))/msum(l) + END IF + IF ((mcheck<1.-rtol) .OR. (mcheck>1.+rtol)) THEN +! WRITE (6,'(/,a)') 'Problems with mass conservation!' +! WRITE (6,90020) layer, l, mcheck, cgas(l) + caer(l) +! WRITE (6,'(a)') '!! CHECK RESULTS !!' +90020 FORMAT ('LAYER = ',I2,', L = ',I2,', MCHECK = ',E12.6,', MASS = ', & + E12.6) + END IF + END DO +!bs +!bs + END DO +!bs * end of SR SOA_PART +!bs +!bs loop over NUMCELLS + RETURN + END SUBROUTINE soa_part + SUBROUTINE sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, & + orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, & + nacv,cblk,blksize,nspcsda,numcells,dt) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: Secondary organic aerosol module ! +!bs This module calculates the gas/particle parti- ! +!bs tioning of semi-volatile organic vapors ! +!bs ! +!bs Called by: RPMMOD3 ! +!bs ! +!bs Calls: SOA_PANDIS ! +!bs SOA_PART ! +!bs ! +!bs Arguments: LAYER, BLKTA, ! +!bs ORGARO1RAT, ORGARO2RAT, ! +!bs ORGALK1RAT, ORGOLE1RAT, ! +!bs ORGBIO1RAT, ORGBIO2RAT, ! +!bs DROG, LDROG, ! +!bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, ! +!bs DT ! +!bs ! +!bs Include files: AEROSTUFF.EXT ! +!bs AERO_internal.EXT ! +!bs ! +!bs Data: ! +!bs ! +!bs Input files: None ! +!bs ! +!bs Output files: UNIT 90: control output ! +!bs ! +!bs--------------------------------------------------------------------! +!bs ! +!bs History: ! +!bs No Date Author Change ! +!bs ____ ______ ________________ _________________________________ ! +!bs 01 040299 B.Schell Set up ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +!bs * Literature: +!bs * Pandis et al. (1992): Secondary organic aerosol formation and +!bs * transport. Atmos Environ. 26A, 2453-2466. +!bs * Seinfeld and Pandis (1998): Atmospheric Chemistry and Physics +!bs * chapter 13.5.2 Noninteracting SOA compounds. (0-471-17816-0) +!bs * STI Report (Sonoma Technology, Inc.) (1998): +!bs * Development of gas-phase chemistry, secondary organic aerosol, +!bs * and aqueous-phase chemistry modules for PM modeling. +!bs * By: R. Strader, C. Gurciullo, S. Pandis, N. Kumar, F. Lurmann +!bs * Prepared for: Coordinating Research Council, Atlanta, Aug 24 1 +!bs * Tao and McMurray (1989): Vapor pressures and surface free energies +!bs * C14-C18 monocarboxylic acids and C5 and C6 dicarboxylic acids. +!bs * Eniron. Sci. Technol. 23, 1519-1523. +!bs * Pankow (1994): An absorption model of gas/particle partitioning of +!bs * organic compounds in the atmosphere. Atmos. Environ. 28, 185-1 +!bs * Pankow (1994): An absorption model of gas/aerosol partitioning inv +!bs * in the formation of secondary organic aerosol. +!bs * Atmos. Environ. 28, 189-193. +!bs * Odum et al. (1996): Gas/particle partitioning and secondary organi +!bs * aerosol yields. Environ. Sci. Technol. 30(8), 2580-2585. +!bs +! IMPLICIT NONE +!bs +!bs +!bs * variable declaration +!bs +!bs +!bs * inputs +!bs +! dimension of arrays + INTEGER blksize +! number of species in CBLK + INTEGER nspcsda +! actual number of cells in arrays + INTEGER numcells +! model layer + INTEGER layer +! # of organic aerosol precursor + INTEGER ldrog +! total # of cond. vapors & SOA sp + INTEGER ncv +! # of anthrop. cond. vapors & SOA + INTEGER nacv +! model time step in SECONDS + REAL dt + REAL cblk(blksize,nspcsda) ! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL orgaro1rat(blksize) ! rates from aromatics +! anth. organic vapor production + REAL orgaro2rat(blksize) ! rates from aromatics +! anth. organic vapor production + REAL orgalk1rat(blksize) ! rates from alkanes and others +! anth. organic vapor production + REAL orgole1rat(blksize) ! rates from alkenes and others +! anth. organic vapor production + REAL orgbio1rat(blksize) ! bio. organic vapor production ra + REAL orgbio2rat(blksize) ! bio. organic vapor production ra + REAL orgbio3rat(blksize) ! bio. organic vapor production ra + REAL orgbio4rat(blksize) ! bio. organic vapor production ra + REAL drog(blksize,ldrog) !bs +!bs * get some infos +!bs +!bs INTEGER LL +!bs IF (LAYER .EQ. 1) THEN +!bs WRITE(75,4711) (CBLK(1,LL), LL = VORGARO1J, VORGOLE1I) +!bs WRITE(75,4711) (CBLK(1,LL), LL = VORGBA1J , VORGBA4I ) +!bs WRITE(75,4712) (CBLK(1,LL), LL = VCVARO1, VCVLIM2) +!bs WRITE(75,4712) (DROG(1,LL), LL = 1, 8) +!bs WRITE(75,4712) (DROG(1,LL), LL = 9, 16) +!bs WRITE(75,4714) (DROG(1,LL), LL = 17,LDROG) +!bs ENDIF +!bs 4711 FORMAT(8(e12.6,1X)) +!bs 4712 FORMAT(8(e12.6,1X)) +!bs 4713 FORMAT(17(e12.6,1X)) +!bs 4714 FORMAT(e12.6,/) +!bs +!bs * begin code +!bs +! ROG production rate [ug m^-3 s^- + IF (orgaer==1) THEN +! IF (firstime) THEN +! WRITE (6,'(a)') +! WRITE (6,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!' +! WRITE (6,'(a)') +! WRITE (90,'(a)') +! WRITE (90,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!' +! firstime = .FALSE. +! END IF +! CALL SOA_PANDIS( +! & LAYER, +! & BLKTA, BLKPRS, +! & ORGARO1RAT, ORGARO2RAT, +! & ORGALK1RAT, ORGOLE1RAT, +! & ORGBIO1RAT, ORGBIO2RAT, +! & ORGBIO3RAT, ORGBIO4RAT, +! & DROG, LDROG, NCV, NACV, +! & CBLK, BLKSIZE, NSPCSDA, NUMCELLS, +! & DT +! & ) + ELSE IF (orgaer==2) THEN +! IF (firstime) THEN +! WRITE (6,'(a)') +! WRITE (6,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!' +! WRITE (6,'(a)') +! WRITE (90,'(a)') +! WRITE (90,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!' +! firstime = .FALSE. +! END IF + CALL soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, & + orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog, & + ncv,nacv,cblk,blksize,nspcsda,numcells,dt) + ELSE +! WRITE (6,'(a)') +! WRITE (6,'(a)') 'WRONG PARAMETER ORGAER !!' +! WRITE (6,90000) orgaer +! WRITE (6,'(a)') 'PROGRAM TERMINATED !!' +! WRITE (6,'(a)') +! STOP + END IF +!bs +!bs ORGARO1RAT(1) = 0. +!bs ORGARO2RAT(1) = 0. +!bs ORGALK1RAT(1) = 0. +!bs ORGOLE1RAT(1) = 0. +!bs ORGBIO1RAT(1) = 0. +!bs ORGBIO2RAT(1) = 0. +!bs ORGBIO3RAT(1) = 0. +!bs ORGBIO4RAT(1) = 0. +!bs WRITE(6,'(a)') '!!! ORGRATs SET TO 0. !!!' +!bs +!bs * formats +!bs +90000 FORMAT ('ORGAER = ',I2) +!bs +!bs * end of SR SORGAM +!bs + RETURN + END SUBROUTINE sorgam +!**************************************************************** +! +! +! +! +! /////////////////////////////// +! *** this routine calculates the dry deposition and sedimentation +! velocities for the three modes. +! coded 1/23/97 by Dr. Francis S. Binkowski. Follows +! FSB's original method, i.e. uses Jon Pleim's expression for deposition +! velocity but includes Marv Wesely's wstar contribution. +!ia eliminated Stokes term for coarse mode deposition calcs., +!ia see comments below + + SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, & + LAYER, & + CBLK, & + BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + +! *** calculate size-averaged particle dry deposition and +! size-averaged sedimentation velocities. + + +! IMPLICIT NONE + + INTEGER BLKSIZE ! dimension of arrays + INTEGER NSPCSDA ! number of species in CBLK + INTEGER NUMCELLS ! actual number of cells in arrays + INTEGER LAYER ! number of layer + + REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables + REAL BLKTA( BLKSIZE ) ! Air temperature [ K ] + REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ] + REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ] + REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ] + REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ] + REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ] + REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ] + REAL DGACC( BLKSIZE ) ! accumulation + REAL DGCOR( BLKSIZE ) ! coarse mode + REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number + REAL KNACC( BLKSIZE ) ! accumulation + REAL KNCOR( BLKSIZE ) ! coarse mode + REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ] + REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ] + REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ] + + +! *** modal particle diffusivities for number and 3rd moment, or mass: + + REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE) + REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE) + +! *** modal sedimentation velocities for number and 3rd moment, or mass: + + REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE) + REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE) + +! *** deposition and sedimentation velocities + + REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ] + REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ] + + + INTEGER LCELL + REAL DCONST1, DCONST1N, DCONST1A, DCONST1C + REAL DCONST2, DCONST3N, DCONST3A,DCONST3C + REAL SC0N, SC0A, SC0C ! Schmidt numbers for number + REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment + REAL ST0N, ST0A, ST0C ! Stokes numbers for number + REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment + REAL RD0N, RD0A, RD0C ! canopy resistance for number + REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment + REAL UTSCALE ! scratch function of USTAR and WSTAR. + REAL NU !kinematic viscosity [ m**2 s**-1 ] + REAL USTFAC ! scratch function of USTAR, NU, and GRAV + REAL BHAT + PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction. + + +! *** check layer value. + + IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and +! sedimentation velocities + + DO LCELL = 1, NUMCELLS + + DCONST1 = BOLTZ * BLKTA(LCELL) / & + ( THREEPI * AMU(LCELL) ) + DCONST1N = DCONST1 / DGNUC( LCELL ) + DCONST1A = DCONST1 / DGACC( LCELL ) + DCONST1C = DCONST1 / DGCOR( LCELL ) + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2 + DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2 + DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2 + +! *** i-mode + + DCHAT0N(LCELL) = DCONST1N & + * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 ) + + DCHAT3N(LCELL) = DCONST1N & + * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 ) + + VGHAT0N(LCELL) = DCONST3N & + * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 ) + + VGHAT3N(LCELL) = DCONST3N & + * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 ) + +! *** j-mode + + DCHAT0A(LCELL) = DCONST1A & + * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 ) + + DCHAT3A(LCELL) = DCONST1A & + * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 ) + + VGHAT0A(LCELL) = DCONST3A & + * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 ) + + VGHAT3A(LCELL) = DCONST3A & + * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 ) + + +! *** coarse mode + + DCHAT0C(LCELL)= DCONST1C & + * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 ) + + DCHAT3C(LCELL) = DCONST1C & + * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 ) + + VGHAT0C(LCELL) = DCONST3C & + * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 ) + + VGHAT3C(LCELL) = DCONST3C & + * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 ) + + END DO + +! *** now calculate the deposition and sedmentation velocities + +!ia 07.05.98 +! *** NOTE In the deposition velocity for coarse mode, +! the impaction term 10.0 ** (-3.0 / st) is eliminated because +! coarse particles are likely to bounce on impact and the current +! formulation does not account for this. + + + DO LCELL = 1, NUMCELLS + + NU = AMU(LCELL) / BLKDENS(LCELL) + USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU) + UTSCALE = USTAR(LCELL) + & + 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL) + +! *** first do number + +! *** nuclei or Aitken mode ( no sedimentation velocity ) + + SC0N = NU / DCHAT0N(LCELL) + ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01) + RD0N = 1.0 / ( UTSCALE * & + ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) ) + + VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) ) + + VSED( LCELL, VSNNUC) = VGHAT0N(LCELL) + +! *** accumulation mode + + SC0A = NU / DCHAT0A(LCELL) + ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01) + RD0A = 1.0 / ( UTSCALE * & + ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) ) + + VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) ) + + VSED( LCELL, VSNACC) = VGHAT0A(LCELL) + +! *** coarse mode + + SC0C = NU / DCHAT0C(LCELL) +!ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 ) +!ia RD0C = 1.0 / ( UTSCALE * +!ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) ) + + RD0C = 1.0 / ( UTSCALE * & + ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term + + VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) ) + + VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) + +! *** now do m3 for the deposition of mass + +! *** nuclei or Aitken mode + + SC3N = NU / DCHAT3N(LCELL) + ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01) + RD3N = 1.0 / ( UTSCALE * & + ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) ) + + VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) ) + + VSED(LCELL, VSMNUC) = VGHAT3N(LCELL) + +! *** accumulation mode + + SC3A = NU / DCHAT3A(LCELL) + ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 ) + RD3A = 1.0 / ( UTSCALE * & + ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) ) + + VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) ) + + +! *** fine mass deposition velocity: combine Aitken and accumulation +! mode deposition velocities. Assume density is the same +! for both modes. + + +! VDEP(LCELL,VDMFINE) = ( +! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) + +! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) / +! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) ) + + +! *** fine mass sedimentation velocity + +! VSED( LCELL, VSMFINE) = ( +! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + +! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) / +! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) ) + + VSED( LCELL, VSMACC ) = VGHAT3A(LCELL) + +! *** coarse mode + + SC3C = NU / DCHAT3C(LCELL) +!ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 ) +!ia RD3C = 1.0 / ( UTSCALE * +!ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) ) + + RD3C = 1.0 / ( UTSCALE * & + ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term + VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL)) + +! *** coarse mode sedmentation velocity + + VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) + + + + END DO + + ELSE ! LAYER greater than 1 + +! *** for layer greater than 1 calculate sedimentation velocities only + + DO LCELL = 1, NUMCELLS + + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + + DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2 + DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2 + DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2 + + VGHAT0N(LCELL) = DCONST3N & + * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 ) + +! *** nucleation mode number sedimentation velocity + + VSED( LCELL, VSNNUC) = VGHAT0N(LCELL) + + VGHAT3N(LCELL) = DCONST3N & + * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 ) + +! *** nucleation mode volume sedimentation velocity + + VSED( LCELL, VSMNUC) = VGHAT3N(LCELL) + + VGHAT0A(LCELL) = DCONST3A & + * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 ) + +! *** accumulation mode number sedimentation velocity + + VSED( LCELL, VSNACC) = VGHAT0A(LCELL) + + VGHAT3A(LCELL) = DCONST3A & + * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 ) + +! *** fine mass sedimentation velocity + +! VSED( LCELL, VSMFINE) = ( +! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + +! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) / +! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) ) + + VSED( LCELL, VSMACC) = VGHAT3A(LCELL) + + VGHAT0C(LCELL) = DCONST3C & + * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 ) + +! *** coarse mode sedimentation velocity + + VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) + + + VGHAT3C(LCELL) = DCONST3C & + * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 ) + +! *** coarse mode mass sedimentation velocity + + VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) + + END DO + + END IF ! check on layer + +END SUBROUTINE vdvg +! +! + SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + chem_in_opt,aer_ic_opt, is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none + INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , & + INTENT(INOUT ) :: & + chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + convfac + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + z_at_w + integer i,j,k,l,ii,jj,kk + real tempfac,mwso4,zz +! real,dimension(its:ite,kts:kte,jts:jte) :: convfac + REAL splitfac + !between gas and aerosol phase + REAL so4vaptoaer +!factor for splitting initial conc. of SO4 +!3rd moment i-mode [3rd moment/m^3] + REAL m3nuc +!3rd MOMENT j-mode [3rd moment/m^3] + REAL m3acc +! REAL ESN36 + REAL m3cor + DATA splitfac/.98/ + DATA so4vaptoaer/.999/ + integer iphase,itype + integer ll, n, p1st + + nphase_aer = 1 + if(p_so4cwj.ge. param_first_scalar) then + nphase_aer = 2 + endif + ntype_aer = 3 + nsize_aer(:)=1 + ai_phase=-999888777 + cw_phase=-999888777 + ci_phase=-999888777 + cr_phase=-999888777 + cs_phase=-999888777 + cg_phase=-999888777 + if(nphase_aer>=1)ai_phase=1 + if(nphase_aer>=2)cw_phase=2 + if(nphase_aer>=3)cr_phase=3 + if(nphase_aer>=4)ci_phase=4 + if(nphase_aer>=5)cw_phase=5 + if(nphase_aer>=6)cg_phase=6 + msectional = 0 + maerosolincw = 0 +#if defined ( cw_species_are_in_registry ) + maerosolincw = 1 +#endif + name_mastercomp_aer( 1) = 'sulfate' + dens_mastercomp_aer( 1) = dens_so4_aer + mw_mastercomp_aer( 1) = mw_so4_aer + hygro_mastercomp_aer(1) = hygro_so4_aer + + name_mastercomp_aer( 2) = 'nitrate' + dens_mastercomp_aer( 2) = dens_no3_aer + mw_mastercomp_aer( 2) = mw_no3_aer + hygro_mastercomp_aer(2) = hygro_no3_aer + + name_mastercomp_aer( 3) = 'ammonium' + dens_mastercomp_aer( 3) = dens_nh4_aer + mw_mastercomp_aer( 3) = mw_nh4_aer + hygro_mastercomp_aer(3) = hygro_nh4_aer + + name_mastercomp_aer( 4) = 'orgaro1' + dens_mastercomp_aer( 4) = dens_oc_aer + mw_mastercomp_aer( 4) = mw_oc_aer + hygro_mastercomp_aer(4) = hygro_oc_aer + + name_mastercomp_aer( 5) = 'orgaro2' + dens_mastercomp_aer( 5) = dens_oc_aer + mw_mastercomp_aer( 5) = mw_oc_aer + hygro_mastercomp_aer(5) = hygro_oc_aer + + name_mastercomp_aer( 6) = 'orgalk' + dens_mastercomp_aer( 6) = dens_oc_aer + mw_mastercomp_aer( 6) = mw_oc_aer + hygro_mastercomp_aer(6) = hygro_oc_aer + + name_mastercomp_aer( 7) = 'orgole' + dens_mastercomp_aer( 7) = dens_oc_aer + mw_mastercomp_aer( 7) = mw_oc_aer + hygro_mastercomp_aer(7) = hygro_oc_aer + + name_mastercomp_aer( 8) = 'orgba1' + dens_mastercomp_aer( 8) = dens_oc_aer + mw_mastercomp_aer( 8) = mw_oc_aer + hygro_mastercomp_aer(8) = hygro_oc_aer + + name_mastercomp_aer( 9) = 'orgba2' + dens_mastercomp_aer( 9) = dens_oc_aer + mw_mastercomp_aer( 9) = mw_oc_aer + hygro_mastercomp_aer(9) = hygro_oc_aer + + name_mastercomp_aer( 10) = 'orgba3' + dens_mastercomp_aer( 10) = dens_oc_aer + mw_mastercomp_aer( 10) = mw_oc_aer + hygro_mastercomp_aer(10) = hygro_oc_aer + + name_mastercomp_aer( 11) = 'orgba4' + dens_mastercomp_aer( 11) = dens_oc_aer + mw_mastercomp_aer( 11) = mw_oc_aer + hygro_mastercomp_aer(11) = hygro_oc_aer + + name_mastercomp_aer( 12) = 'orgpa' + dens_mastercomp_aer( 12) = dens_oc_aer + mw_mastercomp_aer( 12) = mw_oc_aer + hygro_mastercomp_aer(12) = hygro_oc_aer + + name_mastercomp_aer( 13) = 'ec' + dens_mastercomp_aer( 13) = dens_ec_aer + mw_mastercomp_aer( 13) = mw_ec_aer + hygro_mastercomp_aer(13) = hygro_ec_aer + + name_mastercomp_aer( 14) = 'p25' + dens_mastercomp_aer( 14) = dens_so4_aer + mw_mastercomp_aer( 14) = mw_so4_aer + mw_nh4_aer + hygro_mastercomp_aer(14) = hygro_so4_aer + hygro_nh4_aer + + name_mastercomp_aer( 15) = 'anth' + dens_mastercomp_aer( 15) = dens_so4_aer + mw_mastercomp_aer( 15) = mw_so4_aer + mw_nh4_aer + hygro_mastercomp_aer(15) = hygro_so4_aer + hygro_nh4_aer + + name_mastercomp_aer( 16) = 'seas' + dens_mastercomp_aer( 16) = dens_seas_aer + mw_mastercomp_aer( 16) = mw_seas_aer + hygro_mastercomp_aer(16) = hygro_seas_aer + + name_mastercomp_aer( 17) = 'soil' + dens_mastercomp_aer( 17) = dens_ca_aer + mw_mastercomp_aer( 17) = mw_ca_aer + mw_co3_aer + hygro_mastercomp_aer(17) = hygro_ca_aer + hygro_co3_aer + + lptr_so4_aer(:,:,:) = 1 + lptr_nh4_aer(:,:,:) = 1 + lptr_no3_aer(:,:,:) = 1 + lptr_orgaro1_aer(:,:,:) = 1 + lptr_orgaro2_aer(:,:,:) = 1 + lptr_orgalk_aer(:,:,:) = 1 + lptr_orgole_aer(:,:,:) = 1 + lptr_orgba1_aer(:,:,:) = 1 + lptr_orgba2_aer(:,:,:) = 1 + lptr_orgba3_aer(:,:,:) = 1 + lptr_orgba4_aer(:,:,:) = 1 + lptr_orgpa_aer(:,:,:) = 1 + lptr_ec_aer(:,:,:) = 1 + lptr_p25_aer(:,:,:) = 1 + lptr_anth_aer(:,:,:) = 1 + lptr_seas_aer(:,:,:) = 1 + lptr_soil_aer(:,:,:) = 1 + numptr_aer(:,:,:) = 1 + + +! Accumulation mode + ncomp_aer(1) = 14 + lptr_so4_aer(1,1,ai_phase)= p_so4aj + lptr_nh4_aer(1,1,ai_phase) = p_nh4aj + lptr_no3_aer(1,1,ai_phase) = p_no3aj + lptr_orgaro1_aer(1,1,ai_phase) = p_orgaro1j + lptr_orgaro2_aer(1,1,ai_phase) = p_orgaro2j + lptr_orgalk_aer(1,1,ai_phase) = p_orgalk1j + lptr_orgole_aer(1,1,ai_phase) = p_orgole1j + lptr_orgba1_aer(1,1,ai_phase) = p_orgba1j + lptr_orgba2_aer(1,1,ai_phase) = p_orgba2j + lptr_orgba3_aer(1,1,ai_phase) = p_orgba3j + lptr_orgba4_aer(1,1,ai_phase) = p_orgba4j + lptr_orgpa_aer(1,1,ai_phase) = p_orgpaj + lptr_ec_aer(1,1,ai_phase) = p_ecj + lptr_p25_aer(1,1,ai_phase) = p_p25j + numptr_aer(1,1,ai_phase) = p_ac0 +! Aitken mode + ncomp_aer(2) = 14 + lptr_so4_aer(1,2,ai_phase)= p_so4ai + lptr_nh4_aer(1,2,ai_phase) = p_nh4ai + lptr_no3_aer(1,2,ai_phase) = p_no3ai + lptr_orgaro1_aer(1,2,ai_phase) = p_orgaro1i + lptr_orgaro2_aer(1,2,ai_phase) = p_orgaro2i + lptr_orgalk_aer(1,2,ai_phase) = p_orgalk1i + lptr_orgole_aer(1,2,ai_phase) = p_orgole1i + lptr_orgba1_aer(1,2,ai_phase) = p_orgba1i + lptr_orgba2_aer(1,2,ai_phase) = p_orgba2i + lptr_orgba3_aer(1,2,ai_phase) = p_orgba3i + lptr_orgba4_aer(1,2,ai_phase) = p_orgba4i + lptr_orgpa_aer(1,2,ai_phase) = p_orgpai + lptr_ec_aer(1,2,ai_phase) = p_eci + lptr_p25_aer(1,2,ai_phase) = p_p25i + numptr_aer(1,2,ai_phase) = p_nu0 +! coarse mode + ncomp_aer(3) = 3 + lptr_anth_aer(1,3,ai_phase) = p_antha + lptr_seas_aer(1,3,ai_phase) = p_seas + lptr_soil_aer(1,3,ai_phase) = p_soila + numptr_aer(1,3,ai_phase) = p_corn +! aerosol in cloud water + if(cw_phase.gt.0)then +! Accumulation mode + lptr_so4_aer(1,1,cw_phase)= p_so4cwj + lptr_nh4_aer(1,1,cw_phase) = p_nh4cwj + lptr_no3_aer(1,1,cw_phase) = p_no3cwj + lptr_orgaro1_aer(1,1,cw_phase) = p_orgaro1cwj + lptr_orgaro2_aer(1,1,cw_phase) = p_orgaro2cwj + lptr_orgalk_aer(1,1,cw_phase) = p_orgalk1cwj + lptr_orgole_aer(1,1,cw_phase) = p_orgole1cwj + lptr_orgba1_aer(1,1,cw_phase) = p_orgba1cwj + lptr_orgba2_aer(1,1,cw_phase) = p_orgba2cwj + lptr_orgba3_aer(1,1,cw_phase) = p_orgba3cwj + lptr_orgba4_aer(1,1,cw_phase) = p_orgba4cwj + lptr_orgpa_aer(1,1,cw_phase) = p_orgpacwj + lptr_ec_aer(1,1,cw_phase) = p_eccwj + lptr_p25_aer(1,1,cw_phase) = p_p25cwj + numptr_aer(1,1,cw_phase) = p_ac0cw +! Aitken mode + lptr_so4_aer(1,2,cw_phase)= p_so4cwi + lptr_nh4_aer(1,2,cw_phase) = p_nh4cwi + lptr_no3_aer(1,2,cw_phase) = p_no3cwi + lptr_orgaro1_aer(1,2,cw_phase) = p_orgaro1cwi + lptr_orgaro2_aer(1,2,cw_phase) = p_orgaro2cwi + lptr_orgalk_aer(1,2,cw_phase) = p_orgalk1cwi + lptr_orgole_aer(1,2,cw_phase) = p_orgole1cwi + lptr_orgba1_aer(1,2,cw_phase) = p_orgba1cwi + lptr_orgba2_aer(1,2,cw_phase) = p_orgba2cwi + lptr_orgba3_aer(1,2,cw_phase) = p_orgba3cwi + lptr_orgba4_aer(1,2,cw_phase) = p_orgba4cwi + lptr_orgpa_aer(1,2,cw_phase) = p_orgpacwi + lptr_ec_aer(1,2,cw_phase) = p_eccwi + lptr_p25_aer(1,2,cw_phase) = p_p25cwi + numptr_aer(1,2,cw_phase) = p_nu0cw +! coarse mode + lptr_anth_aer(1,3,cw_phase) = p_anthcw + lptr_seas_aer(1,3,cw_phase) = p_seascw + lptr_soil_aer(1,3,cw_phase) = p_soilcw + numptr_aer(1,3,cw_phase) = p_corncw + endif + + massptr_aer(:,:,:,:) = -999888777 + mastercompptr_aer(:,:) = -999888777 + + p1st = param_first_scalar + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + ll = 0 + if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 1 + end if + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 2 + end if + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 3 + end if + if (lptr_orgaro1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgaro1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 4 + end if + if (lptr_orgaro2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgaro2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 5 + end if + if (lptr_orgalk_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgalk_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 6 + end if + if (lptr_orgole_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgole_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 7 + end if + if (lptr_orgba1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 8 + end if + if (lptr_orgba2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 9 + end if + if (lptr_orgba3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 10 + end if + if (lptr_orgba4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 11 + end if + if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 12 + end if + if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 13 + end if + if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 14 + end if + if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 15 + end if + if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 16 + end if + if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 17 + end if + ncomp_aer_nontracer(itype) = ll + + ncomp_aer(itype) = ll + + mprognum_aer(n,itype,iphase) = 0 + if (numptr_aer(n,itype,iphase) .ge. p1st) then + mprognum_aer(n,itype,iphase) = 1 + end if + + end do ! size + end do ! type + end do ! phase +9320 format( a, i1, a, 10x ) + + waterptr_aer(:,:) = 0. + + do itype=1,ntype_aer + do l=1,ncomp_aer(itype) + dens_aer(l,itype) = dens_mastercomp_aer(mastercompptr_aer(l,itype)) + mw_aer(l,itype) = mw_mastercomp_aer(mastercompptr_aer(l,itype)) + hygro_aer(l,itype) = hygro_mastercomp_aer(mastercompptr_aer(l,itype)) + name_aer(l,itype) = name_mastercomp_aer(mastercompptr_aer(l,itype)) + end do + end do + + is_aerosol(:) = .false. + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_aer(itype) + is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. + end do + is_aerosol(numptr_aer(n,itype,iphase))=.true. + end do ! size + end do ! type + end do ! phase + + pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0. + +! *** Compute these once and they will all be saved in COMMON + xxlsgn = log(sginin) + xxlsga = log(sginia) + xxlsgc = log(sginic) + + l2sginin = xxlsgn**2 + l2sginia = xxlsga**2 + l2sginic = xxlsgc**2 + + en1 = exp(0.125*l2sginin) + ea1 = exp(0.125*l2sginia) + ec1 = exp(0.125*l2sginic) + + dhi_sect(1,1)=1.e2*dginin*exp(l2sginin) + dlo_sect(1,1)=1.e2*dginin/exp(l2sginin) + dhi_sect(1,2)=1.e2*dginia*exp(l2sginia) + dlo_sect(1,2)=1.e2*dginia/exp(l2sginia) + dhi_sect(1,3)=1.e2*dginic*exp(l2sginic) + dlo_sect(1,3)=1.e2*dginic/exp(l2sginic) + + sigmag_aer(1,1)=sginin + sigmag_aer(1,2)=sginia + sigmag_aer(1,3)=sginic + + esn04 = en1**4 + esa04 = ea1**4 + esc04 = ec1**4 + + esn05 = esn04*en1 + esa05 = esa04*ea1 + + esn08 = esn04*esn04 + esa08 = esa04*esa04 + esc08 = esc04*esc04 + + esn09 = esn04*esn05 + esa09 = esa04*esa05 + + esn12 = esn04*esn04*esn04 + esa12 = esa04*esa04*esa04 + esc12 = esc04*esc04*esc04 + + esn16 = esn08*esn08 + esa16 = esa08*esa08 + esc16 = esc08*esc08 + + esn20 = esn16*esn04 + esa20 = esa16*esa04 + esc20 = esc16*esc04 + + esn24 = esn12*esn12 + esa24 = esa12*esa12 + esc24 = esc12*esc12 + + esn25 = esn16*esn09 + esa25 = esa16*esa09 + + esn28 = esn20*esn08 + esa28 = esa20*esa08 + esc28 = esc20*esc08 + + + esn32 = esn16*esn16 + esa32 = esa16*esa16 + esc32 = esc16*esc16 + + esn36 = esn16*esn20 + esa36 = esa16*esa20 + esc36 = esc16*esc20 + + esn49 = esn25*esn20*esn04 + esa49 = esa25*esa20*esa04 + + esn52 = esn16*esn36 + esa52 = esa16*esa36 + + esn64 = esn32*esn32 + esa64 = esa32*esa32 + esc64 = esc32*esc32 + + esn100 = esn36*esn64 + + esnm20 = 1.0/esn20 + esam20 = 1.0/esa20 + escm20 = 1.0/esc20 + + esnm32 = 1.0/esn32 + esam32 = 1.0/esa32 + escm32 = 1.0/esc32 + + + xxm3 = 3.0*xxlsgn/ sqrt2 +! factor used in error function cal + nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36) + + nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36) + + nummin_c = anthfac*aeroconcmin/(dginic**3*esc36) + +! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume) +! size distribution , then + +! vol = (p/6) * density * num * (dgemv_xx**3) * +! exp(- 4.5 * log( sgem_xx)**2 ) ) +! note minus sign!! + + factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3 + factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3 + factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3 + ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4)) + ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg)) + mwso4=96.03 +! +! +! IF USING OLD SIMULATION, DO NOT REINITIALIZE! +! +! + if(chem_in_opt == 1 ) return + do l=p_so4aj,num_chem + chem(ims:ime,kms:kme,jms:jme,l)=epsilc + enddo + chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8 + chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8 + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte-1 + kk=min(kde-1,k) + do i=its,ite + ii=min(ide-1,i) + +!Option for alternate ic's + if( aer_ic_opt == AER_IC_DEFAULT ) then + chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4*splitfac*so4vaptoaer + chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4* & + (1.-splitfac)*so4vaptoaer + chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer) + chem(i,k,j,p_nh4aj) = 10.E-05 + chem(i,k,j,p_nh4ai) = 10.E-05 + chem(i,k,j,p_no3aj) = 10.E-05 + chem(i,k,j,p_no3ai) = 10.E-05 + elseif( aer_ic_opt == AER_IC_PNNL ) then + zz = (z_at_w(i,k,j)+z_at_w(i,k+1,j))*0.5 + call sorgam_init_aer_ic_pnnl( & + chem, zz, i,k,j, ims,ime,jms,jme,kms,kme ) + else + call wrf_error_fatal( & + "aerosols_sorgam_init: unable to parse aer_ic_opt" ) + end if + +!... i-mode + m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + & + no3fac*chem(i,k,j,p_no3ai) + orgfac*chem(i,k,j,p_orgaro1i) + & + orgfac*chem(i,k,j,p_orgaro2i) + orgfac*chem(i,k,j,p_orgalk1i) + & + orgfac*chem(i,k,j,p_orgole1i) + orgfac*chem(i,k,j,p_orgba1i) + & + orgfac*chem(i,k,j,p_orgba2i) + orgfac*chem(i,k,j,p_orgba3i) + & + orgfac*chem(i,k,j,p_orgba4i) + orgfac*chem(i,k,j,p_orgpai) + & + anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci) + +!... j-mode + m3acc = so4fac*(chem(i,k,j,p_so4aj)) + nh4fac*(chem(i,k,j,p_nh4aj)) + & + no3fac*(chem(i,k,j,p_no3aj)) + orgfac*(chem(i,k,j,p_orgaro1j)) + & + orgfac*(chem(i,k,j,p_orgaro2j)) + orgfac*(chem(i,k,j,p_orgalk1j)) + & + orgfac*(chem(i,k,j,p_orgole1j)) + orgfac*(chem(i,k,j,p_orgba1j)) + & + orgfac*(chem(i,k,j,p_orgba2j)) + orgfac*(chem(i,k,j,p_orgba3j)) + & + orgfac*(chem(i,k,j,p_orgba4j)) + orgfac*(chem(i,k,j,p_orgpaj)) + & + anthfac*(chem(i,k,j,p_p25j)) + anthfac*(chem(i,k,j,p_ecj)) + +!...c-mode + m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + & + anthfac*chem(i,k,j,p_antha) + + +!...NOW CALCULATE INITIAL NUMBER CONCENTRATION + chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36) + + chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36) + + chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36) + +!jdf, added if statement, don't want to overide specified values for PNNL case + if( aer_ic_opt == AER_IC_DEFAULT ) then + chem(i,k,j,p_so4aj)=chem(i,k,j,p_so4aj) + chem(i,k,j,p_so4ai)=chem(i,k,j,p_so4ai) + chem(i,k,j,p_nh4aj) = 10.E-05 + chem(i,k,j,p_nh4ai) = 10.E-05 + chem(i,k,j,p_no3aj) = 10.E-05 + chem(i,k,j,p_no3ai) = 10.E-05 + endif +!jdf + enddo + enddo + enddo + + + return + END SUBROUTINE aerosols_sorgam_init + +!**************************************************************** +! * +! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE * +! aer_ic_opt == aer_ic_pnnl OPTION. * +! * +! wig, 21-Apr-2004, original version * +! rce, 25-apr-2004 - name changes for consistency with * +! new aer_ic constants in Registry * +! wig, 7-May-2004, added height dependance * +! * +! CALLS THE FOLLOWING SUBROUTINES: NONE * +! * +! CALLED BY : aerosols_sorgam_init * +! * +!**************************************************************** + SUBROUTINE sorgam_init_aer_ic_pnnl( & + chem, z, i,k,j, ims,ime, jms,jme, kms,kme ) + + USE module_configure,only:num_chem + implicit none + + INTEGER,INTENT(IN ) :: i,k,j, & + ims,ime, jms,jme, kms,kme + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),& + INTENT(INOUT ) :: chem + + real, intent(in ) :: z + real :: mult + +! +! Determine height multiplier... +! This should mimic the calculation in sorgam_set_aer_bc_pnnl, +! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic +!!$! Height(m) Multiplier +!!$! --------- ---------- +!!$! <=2000 1.0 +!!$! 2000=3000 0.25 +!!$! +!!$! which translates to: +!!$! 2000 2000. & +!!$ .and. z <= 3000. ) then +!!$ mult = 1.0 - 0.0005*(z-2000.) +!!$ elseif( z > 3000. & +!!$ .and. z <= 5000. ) then +!!$ mult = 0.5 - 1.25e-4*(z-3000.) +!!$ else +!!$ mult = 0.25 +!!$ end if +! Updated aerosol profile multiplier 1-Apr-2005: +! Height(m) Multiplier +! --------- ---------- +! <=2000 1.0 +! 2000=5000 0.125 +! +! which translates to: +! 2000 2000. & + .and. z <= 3000. ) then + mult = 1.0 - 0.00075*(z-2000.) + elseif( z > 3000. & + .and. z <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(z-3000.) + else + mult = 0.125 + end if + +! These should match what is in sorgam_set_aer_bc_pnnl. +! Values as of 2-Dec-2004: + chem(i,k,j,p_sulf) = mult*conmin + chem(i,k,j,p_so4aj) = mult*2.375 + chem(i,k,j,p_so4ai) = mult*0.179 + chem(i,k,j,p_nh4aj) = mult*0.9604 + chem(i,k,j,p_nh4ai) = mult*0.0196 + chem(i,k,j,p_no3aj) = mult*0.0650 + chem(i,k,j,p_no3ai) = mult*0.0050 + chem(i,k,j,p_ecj) = mult*0.1630 + chem(i,k,j,p_eci) = mult*0.0120 + chem(i,k,j,p_p25j) = mult*0.6350 + chem(i,k,j,p_p25i) = mult*0.0490 + chem(i,k,j,p_antha) = mult*2.2970 + chem(i,k,j,p_orgpaj) = mult*0.9300 + chem(i,k,j,p_orgpai) = mult*0.0700 + chem(i,k,j,p_orgaro1j) = conmin + chem(i,k,j,p_orgaro1i) = conmin + chem(i,k,j,p_orgaro2j) = conmin + chem(i,k,j,p_orgaro2i) = conmin + chem(i,k,j,p_orgalk1j) = conmin + chem(i,k,j,p_orgalk1i) = conmin + chem(i,k,j,p_orgole1j) = conmin + chem(i,k,j,p_orgole1i) = conmin + chem(i,k,j,p_orgba1j) = conmin + chem(i,k,j,p_orgba1i) = conmin + chem(i,k,j,p_orgba2j) = conmin + chem(i,k,j,p_orgba2i) = conmin + chem(i,k,j,p_orgba3j) = conmin + chem(i,k,j,p_orgba3i) = conmin + chem(i,k,j,p_orgba4j) = conmin + chem(i,k,j,p_orgba4i) = conmin + chem(i,k,j,p_seas) = mult*0.229 + + END SUBROUTINE sorgam_init_aer_ic_pnnl + +END Module module_aerosols_sorgam diff --git a/wrfv2_fire/chem/module_bioemi_beis311.F b/wrfv2_fire/chem/module_bioemi_beis311.F new file mode 100755 index 00000000..c4ec9b88 --- /dev/null +++ b/wrfv2_fire/chem/module_bioemi_beis311.F @@ -0,0 +1,858 @@ +MODULE module_bioemi_beis311 + +! BEIS3.11 Emissions Module for WRF-Chem +! Written by Greg Frost 6/2004 +! Using off-line gridded standard biogenic emissions +! for each model compound with such emissions, +! model shortwave solar flux (isoprene only), +! & air temperature, pressure, and density in lowest model level, +! calculates actual biogenic emissions of each compound. +! Based on hrbeis311.f from BEIS3.11 for SMOKE, with major +! surgery performed on original routines for use with WRF-Chem. +! This version assumes chemical mechanism is RACM. +! The following 16 RACM compounds have biogenic emissions: +! iso, no, oli, api, lim, xyl, hc3, ete, olt, ket, ald, hcho, eth, ora2, co, nr +!23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 + + CONTAINS + SUBROUTINE bio_emissions_beis311(id,config_flags,ktau,dtstep, & + julday,gmt,xlat,xlong,t_phy,p_phy,gsw, & + sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & + sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & + sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & + noag_grow,noag_nongrow,nononag,slai, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE module_state_description + + IMPLICIT NONE + +! .. Parameters .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + +! .. Indices .. + INTEGER, INTENT(IN ) :: id,ktau, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte +! .. Passed variables .. + INTEGER, INTENT (IN) :: julday ! current simulation julian day + + REAL, INTENT (IN) :: gmt,dtstep + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + t_phy, & !air T (K) + p_phy !P (Pa) + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: & + xlat, & !latitude (deg) + xlong, & !longitude (deg) + gsw !downward shortwave surface flux (W/m^2) + +! Normalized biogenic emissions for standard conditions (moles compound/km^2/hr) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: & + sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & + sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & + sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & + noag_grow,noag_nongrow,nononag + +! Leaf area index for isoprene + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: slai + +! Actual biogenic emissions (moles compound/km^2/hr) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT ) :: & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no + + +! .. Local Scalars .. + + INTEGER :: i,j + +! Variables for 1 element of I/O arrays +! met and phys input variables + REAL :: tair ! surface air temperature (K) + REAL :: tsolar ! downward shortwave surface flux (W/m^2) + REAL :: pres ! surface pressure (mb) + REAL :: ylat ! latitude (deg) + REAL :: ylong ! longitude (deg) +! normalized emissions (moles compound/km^2/hr) + REAL :: se_iso,se_oli,se_api,se_lim,se_xyl, & + se_hc3,se_ete,se_olt,se_ket,se_ald, & + se_hcho,se_eth,se_ora2,se_co,se_nr, & + growagno,ngrowagno,nonagno +! leaf area index for isoprene + REAL :: tlai +! actual emissions for NO + REAL :: e_no + +! Other parameters needed in calculations +! Guenther's parameterizations: Guenther et al. JGR 98, 12609-12617, 1993 + REAL :: ct, dt ! Guenther's temperature correction for isoprene + REAL :: cfno ! NO correction factor + REAL :: cfovoc ! non-isoprene correction factor + REAL :: par ! PAR = photosynthetically active radiation (micromole/m^2/s) + REAL :: csubl ! C sub l from Guenther + REAL :: zen ! zenith angle (radians) + REAL :: coszen ! cosine(zenith angle) + REAL :: pardb ! PAR direct beam + REAL :: pardif ! PAR diffuse + REAL :: gmtp ! current simulation time + +! Error message variables + INTEGER , PARAMETER :: ldev = 6 ! unit number for log file + CHARACTER*256 :: mesg + +! Functions called directly or indirectly +! clnew calculates csubl based on zenith angle, par, and lai +! cguen Guenther's equation for computing light correction +! fertilizer_adj computes fertlizer adjustment factor +! veg_adj computes vegatation adjustment factor +! growseason computes day of growing season + +! Subroutines called directly or indirectly +! calc_zenithb calculates zenith angle from latitude, longitude, julian day, and GMT +! NOTE: longitude input for this routine is nonstandard: >0 for W, <0 for E!! +! getpar computes PAR (direct beam and diffuse) in umol/m2-sec from downward shortwave flux +! hrno algorithm to estimate NO emissions; does not include precipitation adjustment + +!*************************************** +! begin body of subroutine bio_emissions_beis311 + +! hour into integration + gmtp=float(ktau)*dtstep/3600. +! + gmtp=mod(gmt+gmtp,24.) + write(mesg,*) 'calculate beis311 emissions at gmtp = ',gmtp + call wrf_debug(15,mesg) + DO 100 j=jts,jte + DO 100 i=its,ite + + tair = t_phy(i,kts,j) + pres = .01*p_phy(i,kts,j) + ylat = xlat(i,j) + ylong = xlong(i,j) + tsolar = gsw(i,j) + tlai = slai(i,j) + se_iso = sebio_iso(i,j) + se_oli = sebio_oli(i,j) + se_api = sebio_api(i,j) + se_lim = sebio_lim(i,j) + se_xyl = sebio_xyl(i,j) + se_hc3 = sebio_hc3(i,j) + se_ete = sebio_ete(i,j) + se_olt = sebio_olt(i,j) + se_ket = sebio_ket(i,j) + se_ald = sebio_ald(i,j) + se_hcho = sebio_hcho(i,j) + se_eth = sebio_eth(i,j) + se_ora2 = sebio_ora2(i,j) + se_co = sebio_co(i,j) + se_nr = sebio_nr(i,j) + growagno = noag_grow(i,j) + ngrowagno = noag_nongrow(i,j) + nonagno = nononag(i,j) + +!....Perform checks on max and min bounds for temperature + + IF (tair .LT. 200.0) THEN +! WRITE( mesg, 94010 ) +! & 'tair=', tair, +! & 'too low at i,j= ',i,',',j + WRITE( ldev, * ) mesg + END IF + + IF (tair .GT. 315.0 ) THEN +! WRITE( mesg, 94020 ) +! & 'tair=', tair, +! & 'too high at i,j= ',i,',',j, +! & '...resetting to 315K' + tair = 315.0 +! WRITE( ldev, * ) mesg + ENDIF + +!... Isoprene emissions +!...... Calculate temperature correction term + dt = 28668.514 / tair + ct = EXP( 37.711 - 0.398570815 * dt ) / & + (1.0 + EXP( 91.301 - dt ) ) + +!...... Calculate zenith angle in radians +! NOTE: nonstandard longitude input here: >0 for W, <0 for E!! + CALL calc_zenithb(ylat,-ylong,julday,gmtp,zen) + coszen = COS(zen) + +!...... Convert tsolar to PAR and find direct and diffuse fractions + CALL getpar( tsolar, pres, zen, pardb, pardif ) + par = pardb + pardif + +!...... Check max/min bounds of PAR and calculate +!...... biogenic isoprene + IF ( par .LT. 0.00 .OR. par .GT. 2600.0 ) THEN +! WRITE( mesg, 94010 ) +! & 'PAR=', par, +! & 'out of range at i,j= ',i,',',j +! WRITE( ldev, * ) mesg + ENDIF + +!...... Check max bound of LAI + IF ( tlai .GT. 10.0 ) THEN +! WRITE( mesg, 94010 ) +! & 'LAI=', tlai, +! & 'out of range at i,j= ',i,',',j +! WRITE( ldev, * ) mesg + ENDIF + +!...... Initialize csubl + csubl = 0.0 + +!...... If PAR < 0.01 or zenith angle > 89 deg, set isoprene emissions to 0. + IF ( par .LE. 0.01 .OR. coszen .LE. 0.02079483 ) THEN + ebio_iso(i,j) = 0.0 + + ELSE + +!...... Calculate csubl including shading if LAI > 0.1 + IF ( tlai .GT. 0.1 ) THEN + csubl = clnew( zen, pardb, pardif, tlai ) + +!...... Otherwise calculate csubl without considering LAI + ELSE ! keep this or not? + csubl = cguen( par ) + + ENDIF + + ebio_iso(i,j) = se_iso * ct * csubl + + ENDIF + + +!... Other biogenic emissions except NO: +!...... RACM: oli, api, lim, hc3, ete, olt, ket, ald, hcho, eth, ora2, co + + cfovoc = EXP( 0.09 * ( tair - 303.0 ) ) + + ebio_oli(i,j) = se_oli * cfovoc + ebio_api(i,j) = se_api * cfovoc + ebio_lim(i,j) = se_lim * cfovoc + ebio_xyl(i,j) = se_xyl * cfovoc + ebio_hc3(i,j) = se_hc3 * cfovoc + ebio_ete(i,j) = se_ete * cfovoc + ebio_olt(i,j) = se_olt * cfovoc + ebio_ket(i,j) = se_ket * cfovoc + ebio_ald(i,j) = se_ald * cfovoc + ebio_hcho(i,j) = se_hcho * cfovoc + ebio_eth(i,j) = se_eth * cfovoc + ebio_ora2(i,j) = se_ora2 * cfovoc + ebio_co(i,j) = se_co * cfovoc + ebio_nr(i,j) = se_nr * cfovoc + +!... NO emissions + + CALL hrno( julday, growagno, ngrowagno, nonagno, tair, e_no) + + ebio_no(i,j) = e_no + + 100 CONTINUE + + RETURN + + +!****************** FORMAT STATEMENTS ****************************** + +!........... Informational (LOG) message formats... 92xxx + + +!........... Internal buffering formats............ 94xxx + + +94010 FORMAT( A, F10.2, 1X, A, I4, A1, I4) +94020 FORMAT( A, F10.2, 1X, A, I4, A1, I4, 1X, A) + + +!***************** CONTAINS ******************************************** + CONTAINS + + REAL FUNCTION clnew( zen, pardb, pardif, tlai ) + +!........ Function to calculate csubl based on zenith angle, PAR, and LAI + + IMPLICIT NONE + + REAL, INTENT (IN) :: pardb ! direct beam PAR( umol/m2-s) + REAL, INTENT (IN) :: pardif ! diffuse PAR ( umol/m2-s) + REAL, INTENT (IN) :: zen ! solar zenith angle (radians) + REAL, INTENT (IN) :: tlai ! leaf area index for grid cell + REAL kbe ! extinction coefficient for direct beam + REAL canparscat ! exponentially wtd scattered PAR (umol/m2-s) + REAL canpardif ! exponentially wtd diffuse PAR (umol/m2-s) + REAL parshade ! PAR on shaded leaves (umol/m2-s) + REAL parsun ! PAR on sunlit leaves (umol/m2-s) + REAL laisun ! LAI that is sunlit + REAL fracsun ! fraction of leaves that are sunlit + REAL fracshade ! fraction of leaves that are shaded + +!........... CN98 - eqn 15.4, assume x=1 + + kbe = 0.5 * SQRT(1. + TAN( zen ) * TAN( zen )) + +!.......... CN98 - p. 261 (this is usually small) + + canparscat = 0.5 * pardb * (EXP(-0.894 * kbe * tlai) - & + EXP(-1.* kbe * tlai)) + +!.......... CN98 - p. 261 (assume exponentially wtd avg) + + canpardif = pardif * (1. - EXP(-0.61 * tlai))/(0.61 * tlai) + +!......... CN98 - p. 261 (for next 3 eqns) + + parshade = canpardif + canparscat + parsun = kbe * (pardb + pardif) + parshade + laisun = (1. - EXP( -kbe * tlai))/kbe + fracsun = laisun/tlai + fracshade = 1. - fracsun + +!.......... cguen is guenther's eqn for computing light correction as a +!.......... function of PAR...fracSun should probably be higher since +!.......... sunlit leaves tend to be thicker than shaded leaves. But +!.......... since we need to make crude asmptns regarding leave +!.......... orientation (x=1), will not attempt to fix at the moment. + + clnew =fracsun * cguen(parsun) + fracshade * cguen(parshade) + + RETURN + END FUNCTION clnew + + REAL FUNCTION cguen( partmp ) + +!.......... Guenther's equation for computing light correction + + IMPLICIT NONE + REAL, INTENT (IN) :: partmp + REAL, PARAMETER :: alpha2 = 0.00000729 + + IF ( partmp .LE. 0.01) THEN + cguen = 0.0 + ELSE + cguen = (0.0028782 * partmp) / & + SQRT(1. + alpha2 * partmp * partmp) + ENDIF + + RETURN + END FUNCTION cguen + + END SUBROUTINE bio_emissions_beis311 + +!================================================================= + + SUBROUTINE calc_zenithb(lat,long,ijd,gmt,zenith) + ! Based on calc_zenith from WRF-Chem module_phot_mad.F + ! this subroutine calculates solar zenith angle for a + ! time and location. must specify: + ! input: + ! lat - latitude in decimal degrees + ! long - longitude in decimal degrees + ! NOTE: Nonstandard convention for long: >0 for W, <0 for E!! + ! gmt - greenwich mean time - decimal military eg. + ! 22.75 = 45 min after ten pm gmt + ! output + ! zenith - in radians (GJF, 6/2004) + ! remove azimuth angle calculation since not needed (GJF, 6/2004) + ! .. Scalar Arguments .. + REAL :: gmt, lat, long, zenith + INTEGER :: ijd + ! .. Local Scalars .. + REAL :: csz, cw, d, decl, dr, ec, epsi, eqt, eyt, feqt, feqt1, & + feqt2, feqt3, feqt4, feqt5, feqt6, feqt7, lbgmt, lzgmt, ml, pepsi, & + pi, ra, rdecl, reqt, rlt, rml, rphi, rra, ssw, sw, tab, w, wr, & + yt, zpt, zr + INTEGER :: jd + CHARACTER*256 :: mesg + ! .. Intrinsic Functions .. + INTRINSIC acos, atan, cos, min, sin, tan + ! convert to radians + pi = 3.1415926535590 + dr = pi/180. + rlt = lat*dr + rphi = long*dr + + ! ???? + (yr - yref) + + jd = ijd + + d = jd + gmt/24.0 + ! calc geom mean longitude + ml = 279.2801988 + .9856473354*d + 2.267E-13*d*d + rml = ml*dr + + ! calc equation of time in sec + ! w = mean long of perigee + ! e = eccentricity + ! epsi = mean obliquity of ecliptic + w = 282.4932328 + 4.70684E-5*d + 3.39E-13*d*d + wr = w*dr + ec = 1.6720041E-2 - 1.1444E-9*d - 9.4E-17*d*d + epsi = 23.44266511 - 3.5626E-7*d - 1.23E-15*d*d + pepsi = epsi*dr + yt = (tan(pepsi/2.0))**2 + cw = cos(wr) + sw = sin(wr) + ssw = sin(2.0*wr) + eyt = 2.*ec*yt + feqt1 = sin(rml)*(-eyt*cw-2.*ec*cw) + feqt2 = cos(rml)*(2.*ec*sw-eyt*sw) + feqt3 = sin(2.*rml)*(yt-(5.*ec**2/4.)*(cw**2-sw**2)) + feqt4 = cos(2.*rml)*(5.*ec**2*ssw/4.) + feqt5 = sin(3.*rml)*(eyt*cw) + feqt6 = cos(3.*rml)*(-eyt*sw) + feqt7 = -sin(4.*rml)*(.5*yt**2) + feqt = feqt1 + feqt2 + feqt3 + feqt4 + feqt5 + feqt6 + feqt7 + eqt = feqt*13751.0 + + ! convert eq of time from sec to deg + reqt = eqt/240. + ! calc right ascension in rads + ra = ml - reqt + rra = ra*dr + ! calc declination in rads, deg + tab = 0.43360*sin(rra) + rdecl = atan(tab) + decl = rdecl/dr + ! calc local hour angle + lbgmt = 12.0 - eqt/3600. + long*24./360. + lzgmt = 15.0*(gmt-lbgmt) + zpt = lzgmt*dr + csz = sin(rlt)*sin(rdecl) + cos(rlt)*cos(rdecl)*cos(zpt) + if(csz.gt.1) then + write(mesg,*) 'calczen,csz ',csz + call wrf_debug(15,mesg) + endif + csz = min(1.,csz) + zr = acos(csz) +! zenith = zr/dr +! keep zenith angle in radians for later use (GJF 6/2004) + zenith = zr + + RETURN + + END SUBROUTINE calc_zenithb + +!================================================================= + + + SUBROUTINE getpar( tsolar, pres, zen, pardb, pardif ) + +!*********************************************************************** +! subroutine body starts at line +! +! DESCRIPTION: +! +! Based on code from Bart Brashers (10/2000), which was based on +! code from Weiss and Norman (1985). +! +! +! PRECONDITIONS REQUIRED: +! Solar radiation (W/m2) and pressure (mb) +! +! SUBROUTINES AND FUNCTIONS CALLED: +! +! REVISION HISTORY: +! 3/01 : Prototype by JMV +! +!*********************************************************************** +! +! Project Title: Sparse Matrix Operator Kernel Emissions (SMOKE) Modeling +! System +! File: @(#)Id: getpar.f,v 1.1.1.1 2001/03/27 19:08:49 smith_w Exp +! +! COPYRIGHT (C) 2001, MCNC--North Carolina Supercomputing Center +! All Rights Reserved +! +! See file COPYRIGHT for conditions of use. +! +! MCNC-Environmental Programs Group +! P.O. Box 12889 +! Research Triangle Park, NC 27709-2889 +! +! env_progs@mcnc.org +! +! Pathname: Source: /env/proj/archive/cvs/jmv/beis3v0.9/getpar.f,v +! Last updated: Date: 2001/03/27 19:08:49 +! +!*********************************************************************** + + IMPLICIT NONE + +!........ Inputs + + REAL , INTENT (IN) :: tsolar ! modeled or observed total radiation (W/m2) + REAL , INTENT (IN) :: pres ! atmospheric pressure (mb) + REAL , INTENT (IN) :: zen ! solar zenith angle (radians) + +!........ Outputs + + REAL, INTENT (OUT) :: pardb ! direct beam PAR( umol/m2-s) + REAL, INTENT (OUT) :: pardif ! diffuse PAR ( umol/m2-s) + +!........... PARAMETERS and their descriptions: + + REAL, PARAMETER :: watt2umol = 4.6 ! convert W/m^2 to umol/m^2-s (4.6) + +! + REAL ratio ! transmission fraction for total radiation + REAL ot ! optical thickness + REAL rdvis ! possible direct visible beam (W/m^2) + REAL rfvis ! possible visible diffuse (W/m^2) + REAL wa ! water absorption in near-IR (W/m^2) + REAL rdir ! direct beam in near-IR (W/m^2) + REAL rfir ! diffuse near-IR (W/m^2) + REAL rvt ! total possible visible radiation (W/m^2) + REAL rirt ! total possible near-IR radiation (W/m^2) + REAL fvis ! fraction of visible to total + REAL fvb ! fraction of visible that is direct beam + REAL fvd ! fraction of visible that is diffuse + +!*************************************** +! begin body of subroutine + +!............ Assume that PAR = 0 if zenith angle is greater than 87 degrees +!............ or if solar radiation is zero + + IF (zen .GE. 1.51844 .OR. tsolar .LE. 0.) THEN + pardb = 0. + pardif = 0. + RETURN + ENDIF + +!............ Compute clear sky (aka potential) radiation terms + + ot = pres / 1013.25 / COS(zen) !Atmospheric Optical thickness + rdvis = 600. * EXP(-.185 * ot) * COS(zen) !Direct visible beam, eqn (1) + rfvis = 0.42 * (600 - rdvis) * COS(zen) !Visible Diffuse, eqn (3) + wa = 1320 * .077 * (2. * ot)**0.3 !water absorption in near-IR, eqn (6) + rdir = (720. * EXP(-0.06 * ot)-wa) * COS(zen) !Direct beam near-IR, eqn (4) + rfir = 0.65 * (720. - wa - rdir) * COS(zen) !Diffuse near-IR, eqn (5) + + rvt = rdvis + rfvis !Total visible radiation, eqn (9) + rirt = rdir + rfir !Total near-IR radiation, eqn (10) + fvis = rvt/(rirt + rvt) !Fraction of visible to total radiation, eqn 7 + ratio = tsolar /(rirt + rvt) !Ratio of "actual" to clear sky solar radiation + +!............ Compute fraction of visible that is direct beam + + IF (ratio .GE. 0.89) THEN + fvb = rdvis/rvt * 0.941124 + ELSE IF (ratio .LE. 0.21) THEN + fvb = rdvis/rvt * 9.55E-3 + ELSE + fvb = rdvis/rvt * (1.-((0.9 - ratio)/0.7)**0.666667) + ENDIF + fvd = 1. - fvb + +!............ Compute PAR (direct beam and diffuse) in umol/m2-sec + + pardb = tsolar * fvis * fvb * watt2umol + pardif = tsolar * fvis * fvd * watt2umol + + + RETURN + +!****************** FORMAT STATEMENTS ****************************** + +!........... Informational (LOG) message formats... 92xxx + + +!........... Internal buffering formats............ 94xxx + + END SUBROUTINE getpar + + SUBROUTINE hrno( julday, growagno, ngrowagno, nonagno, tairin, e_no) + +!*********************************************************************** +! subroutine body starts at line 150 +! +! DESCRIPTION: +! +! Uses new NO algorithm NO = Normalized*Tadj*Fadj*Cadj +! to estimate NO emissions +! Information needed to estimate NO emissions +! Julian Day (integer) julday +! Surface Temperature (MCIP field) tair (K) +! Note: Precipitation adjustment not used in the WRF-Chem implementation of BEIS3.11 +! because of differences in soil categories between BEIS and WRF-Chem +! +! The calculation are based on the following paper by J.J. Yienger and H. Levy II +! J.J. Yienger and H. Levy II, Journal of Geophysical Research, vol 100,11447-11464,1995 +! +! Also see the following paper for more information: +! Proceedings of the Air and Waste Management Association/U.S. Environmental Protection +! Agency EMission Inventory Conference, Raleigh October 26-28, 1999 Raleigh NC +! by Tom Pierce and Lucille Bender +! +! REFERENCES +! +! JACQUEMIN B. AND NOILHAN J. (1990), BOUND.-LAYER METEOROL., 52, 93-134. +! J.J. Yienger and H. Levy II, Journal of Geophysical Research, vol 100,11447-11464,1995 +! T. Pierce and L. Bender, Examining the Temporal Variability of Ammonia and Nitric Oxide Emissions from Agricultural Processes +! Proceedings of the Air and Waste Management Association/U.S. Environmental Protection +! Agency EMission Inventory Conference, Raleigh October 26-28, 1999 Raleigh NC +! +! PRECONDITIONS REQUIRED: +! Normalized NO emissions, Surface Temperature +! +! SUBROUTINES AND FUNCTIONS CALLED (directly or indirectly): +! fertilizer_adj computes fertlizer adjustment factor +! veg_adj computes vegatation adjustment factor +! growseason computes day of growing season +! +! +! REVISION HISTORY: +! 10/01 : Prototype by GAP +! +!*********************************************************************** +! +! Project Title: BEIS3 Enhancements for NO emission calculation +! File: hrno.f +! +! +!*********************************************************************** + + IMPLICIT NONE + +!........... ARGUMENTS and their descriptions: + + INTEGER, INTENT (IN) :: julday ! current julian day + + + REAL, INTENT (IN) :: tairin ! air temperature (K) + REAL, INTENT (IN) :: growagno ! norm NO emissions, agricultural, growing + REAL, INTENT (IN) :: ngrowagno ! norm NO emissions, agricultural, not growing + REAL, INTENT (IN) :: nonagno ! norm NO emissions, non-agricultural + + REAL, INTENT (OUT) :: e_no ! output NO emissions + +!........... SCRATCH LOCAL VARIABLES and their descriptions: + + REAL cfno ! NO correction factor + REAL cfnograss ! NO correction factor for grasslands + REAL tsoi ! soil temperature + REAL tair ! air temperature + + REAL :: cfnowet, cfnodry + + INTEGER growseason, gday + EXTERNAL growseason +!*********************************************************************** + + tair = tairin + +!............. calculate NO emissions by going thru temperature cases + + ! gday = growseason(julday) + gday = 91 + IF (gday .eq. 0) THEN !not growing season + IF ( tair .GT. 303.00 ) tair = 303.00 + + IF ( tair .GT. 268.8690 ) THEN + cfno = EXP( 0.04686 * tair - 14.30579 ) ! grass (from BEIS2) + ELSE + cfno = 0.0 + ENDIF + + e_no = & + ngrowagno * cfno & !agriculture + + nonagno * cfno ! non-agriculture + + ELSE + + tsoi = 0.72*tair+82.28 + IF (tsoi .LE. 273.16) tsoi = 273.16 + IF (tsoi .GE. 303.16) tsoi = 303.16 + + cfnodry = (1./3.)*(1./30.)*(tsoi-273.16) ! see YL 1995 Equa 9a p. 11452 + IF (tsoi .LE. 283.16) THEN ! linear cold case + cfnowet = (tsoi-273.16)*EXP(-0.103*30.0)*0.28 ! see YL 1995 Equ 7b + ELSE ! exponential case + cfnowet = EXP(0.103*(tsoi-273.16)) & + *EXP(-0.103*30.0) + ENDIF + cfno = 0.5*cfnowet + 0.5*cfnodry + + IF ( tair .GT. 303.00 ) tair = 303.00 + + IF ( tair .GT. 268.8690 ) THEN + cfnograss = EXP( 0.04686 * tair - 14.30579 ) ! grass (from BEIS2) + ELSE + cfnograss = 0.0 + ENDIF + + e_no = growagno * cfno *fertilizer_adj(julday)*veg_adj(julday) & + + nonagno * cfnograss + + ENDIF + + RETURN + +!***************** CONTAINS ******************************************** + CONTAINS + + REAL FUNCTION fertilizer_adj(julday) +!***************************************************************** +! +! SUMMARY: +! computes fertilizer adjustment factor from Julian day +! +! FUNCTION CALLS: +! growseason computes day of growing season +! +! NOTE: julday = Julian day format +! +!***************************************************************** + implicit none + integer julday +! +!******** local scratch variables +! + integer gday +! +!******** function calls +! + INTEGER growseason + EXTERNAL growseason + + ! gday = growseason(julday) + gday = 91 + + IF (gday .EQ. 0) THEN + fertilizer_adj = 0.0 + ELSEIF ((gday .GE. 1) .AND. (gday .LT. 30)) THEN ! first month of growing season + fertilizer_adj = 1.0 + ELSEIF (gday .GE. 30) THEN + fertilizer_adj = 1.0+30.0/184.0-float(gday)/184.0 + ELSE + write (*,*) 'ERROR: invalid Julian day' + write (*,*) 'julday = ', julday + write (*,*) 'growing season day = ',gday + CALL wrf_error_fatal ( 'INVALID GROWING SEASON DAY') + ENDIF + + RETURN + + END FUNCTION fertilizer_adj + + + REAL FUNCTION veg_adj(julday) +!***************************************************************** +! +! SUMMARY: +! computes vegetation adjustment factor from Julian day +! +! FUNCTION CALLS: +! growseason computes day of growing season +! +! NOTE: julday = Julian day format +! +!***************************************************************** + implicit none + + integer julday + + +! +!******** locals +! + integer gday + +! +!******* function calls +! + INTEGER growseason + EXTERNAL growseason + + !gday = growseason(julday) + gday = 91 + + IF (gday .LE. 30) THEN + veg_adj = 1.0 + ELSEIF ((gday .GT. 30) .AND. (gday .LT. 60)) THEN + veg_adj = 1.5-(float(gday)/60.0) + ELSEIF (gday .GE. 60) THEN + veg_adj = 0.5 + ELSE + write (*,*) 'ERROR: invalid Julian day' + write (*,*) 'julday = ', julday + write (*,*) 'growing season day = ',gday + CALL wrf_error_fatal ( 'veg_adj: INVALID GROWING SEASON DAY' ) + ENDIF + + + RETURN + + + END FUNCTION veg_adj + + END SUBROUTINE hrno + + INTEGER FUNCTION growseason(julday) +!***************************************************************** +! +! SUMMARY: +! computes day of growing season from Julian day +! +! NOTE: julday = Julian day format +! +!***************************************************************** + implicit none + integer julday + +!******* +! +! +! given Julian day, compute day of growing season +! +! +! +!******** locals + + integer gsjulian_start + integer gsjulian_end + + data gsjulian_start /91/ !=April 1 in non-leap-year + data gsjulian_end /304/ !=Oct 31 in non-leap-year + + IF ((julday .GE. gsjulian_start) & + .AND. (julday .LE. gsjulian_end)) THEN ! growing season + + growseason = julday-gsjulian_start+1 + + + ELSEIF ((julday .GE. 1) & ! before or after growing season + .AND. (julday .LE. 366)) THEN + + growseason = 0 + + ELSE + write (*,*) 'ERROR: Invalid julday ' + write (*,*) 'julday = ',julday + CALL wrf_error_fatal ( 'growseason: INVALID JULIAN DAY') + ENDIF + + + RETURN + END FUNCTION growseason + + +END MODULE module_bioemi_beis311 diff --git a/wrfv2_fire/chem/module_bioemi_simple.F b/wrfv2_fire/chem/module_bioemi_simple.F new file mode 100755 index 00000000..631e19d0 --- /dev/null +++ b/wrfv2_fire/chem/module_bioemi_simple.F @@ -0,0 +1,1309 @@ +MODULE module_bioemi_simple +! .. +! make sure that whatever you put in here agrees with dry_dep_simple +! and met model luse stuff. This should be improved, but currently, +! there is only usgs in wrf +! + USE module_data_radm2 + INTEGER, PARAMETER :: nlu = 25, & + iswater_temp = 16,isice_temp = 24 + REAL :: aefiso(nlu), aefmter(nlu), aefovoc(nlu), aef_n(nlu) + CHARACTER (4),PARAMETER :: mminlu_loc = 'USGS' + INTEGER :: ixxxlu(nlu) + + + CONTAINS + SUBROUTINE bio_emissions(id,ktau,dtstep,DX, & + config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + e_bio,p_phy,chem,rho_phy,dz8w,ne_area, & + ivgtyp,gsw,vegfra,rmol,ust,znt,xlat,xlong,z_at_w, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + IMPLICIT NONE + INTEGER, INTENT(IN ) :: id,julday, ne_area, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,numgas + INTEGER, INTENT(IN ) :: & + ktau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, jms:jme, ne_area ), & + INTENT(INOUT ) :: e_bio + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + gsw, & + vegfra, & + rmol, & + ust, & + xlat, & + xlong, & + znt + REAL, INTENT(IN ) :: & + dtstep,dx,gmt +!--- deposition and emissions stuff +! .. Parameters .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + +! .. +! .. Local Arrays .. +! .. Parameters .. +! INTEGER, PARAMETER :: nlu = 25, & +! nseason = 1, nseasons = 2 +! REAL :: aefiso(nlu), aefmter(nlu), aefovoc(nlu), aef_n(nlu), & +! emiss_bio(numgas) + REAL :: emiss_bio(numgas) + LOGICAL :: highnh3, rainflag, vegflag, wetflag + CHARACTER (4) :: luse_typ +! .. +! .. Local Scalars .. + REAL :: clwchem,eiso,eisoc,emter,emterc,eovoc,eovocc,e_n,e_nn, & + pa,rad, rhchem, ta, ustar, vegfrac, vocsc, xtimin, z1,zntt + INTEGER :: i,j,iland, iprt, iseason, n, nr, ipr,jpr,nvr + + +! .. Intrinsic Functions .. + INTRINSIC max, min +! + luse_typ=mminlu_loc +! print *,'luse_typ,iswater',luse_typ,iswater_temp + iseason=1 + if(julday.lt.90.or.julday.gt.270)then + iseason=2 + CALL wrf_debug(100,'setting iseason in bio_emi to 2') + endif + + +! test program to test chemics stuff in 1-d + +! first prepare for biogenic emissions + + CALL bioemiin(iseason,luse_typ,vegflag) + do 100 j=jts,jte + do 100 i=its,ite + iland = ivgtyp(i,j) + ta = t_phy(i,kts,j) + rad = gsw(i,j) + vegfrac = vegfra(i,j) + pa = .01*p_phy(i,kts,j) + clwchem = moist(i,kts,j,p_qc) + ustar = ust(i,j) + zntt = znt(i,j) + z1 = z_at_w(i,kts+1,j)-z_at_w(i,kts,j) + +! Set logical default values + rainflag = .FALSE. + wetflag = .FALSE. + highnh3 = .FALSE. + + if(moist(i,kts,j,p_qr).gt.0.)rainflag = .true. +! if(raincv(i,kts,j).gt.0. .and. rainncv(i,kts,j).gt.0. )rainflag = .true. + +! qvs = 380.*exp(17.27*(tair-273.)/(tair-36.))/pressure + rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) + rhchem = max(rhchem,5.) + if (rhchem >= 95.) wetflag = .true. +! print *,chem(i,kts,j,p_nh3),chem(i,kts,j,p_so2) + if(chem(i,kts,j,p_nh3).gt.2.*chem(i,kts,j,p_so2))highnh3 = .true. + iseason = 1 +!--- biogenic emissions + emiss_bio=0. + CALL biogen(iland,ta,rad,eiso,emter,eovoc,e_n,vocsc,eisoc,emterc,eovocc, & + e_nn,pa,luse_typ,iseason,vegflag) +! if(i.eq.5.and.j.eq.5)then +! print *,iland +! print *,ta,rad,vocsc,pa,luse_typ,aefiso,aefovoc,aefmter, & +! aef_n,ixxxlu,vegflag,isice_temp,iswater_temp +! PRINT *, eiso, emter, eovoc, e_n, eisoc, eovocc +! endif + +! PRINT *, eiso, emter, eovoc, e_n, eisoc, eovocc + CALL biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,numgas,vegfrac, & + luse_typ,vegflag) +! PRINT *, 'emiss_bio(liso) emiss_bio(lald) emiss_bio(lhcho) ', & +! ' emiss_bio(lhc3)' +! PRINT *, emiss_bio(liso), emiss_bio(lald), emiss_bio(lhcho), & +! emiss_bio(lhc3) +! DO n = 1, numgas-2 !wig, 22-May-2006: CBMZ uses more species than ne_area so would get array overwrites + DO n = 1, ne_area-2 + e_bio(i,j,n) = emiss_bio(n) +! if(i.eq.5.and.j.eq.5)print *,emiss_bio(n) + END DO + 100 continue +END SUBROUTINE bio_emissions +! ********************************************************************** +! ********************** SUBROUTINE BIOEMIIN ************************** +! ********************************************************************** + SUBROUTINE bioemiin(isn,mminlu,vegflag) +!********************************************************************** +! THIS SUBROUTINE INITIALIZES THE EMISSION FACTORS +! AND THE SIMPLIFIED LANDUSE SCHEME +! FOR THE BIOGENIC EMISSION AND DEPOSITION SUBROUTINES +! WRITTEN BY: WINFRIED SEIDL (MARCH 2000) +! CALLED BY: +! CALLS: - +!********************************************************************** +!********************************************************************** +! REFERENCES FOR EMISSION FACTORS: +! (S+R) T. Schoenemeyer and K. Richter +! (S95) D. Simpson, A. Guenther, C. N. Hewitt, and R. Steinbrecher +! J. Geophysical Research 100D (1995), 22875-22890 +! (G94) A. Guenther, P. Zimmerman and M. Wildermuth +! Atmospheric Environment 28 (1994), 1197-1210 +! (Z88) P. R. Zimmerman, J. P. Greenberg, and C. E. Westberg +! J. Geophysical Research 93D (1988), 1407-1416 +! (K88) W. A. Kaplan, S. C. Wofsy, M. Keller, and J. M. da Costa +! J. Geophysical Research 93D (1988), 1389-1395 +! (K94) L. F. Klinger, P. R. Zimmermann, J. P. Greenberg, L. E. Hei +! and A. B. Guenther +! J. Geophysical Research 99D (1994), 1469-1494 +! --------------------------------------------------------- +! PCU/NCAR landuse categories: +! 1 Highrise urban area +! 2 Agricultural land +! 3 Grassland, rangeland +! 4 Deciduous forest +! 5 Coniferous forest +! 6 Mixed forest (including wetland) +! 7 Water +! 8 Wet rangeland, nonforested wetland +! 9 Desert +! 10 Tundra +! 11 Permanent ice +! 12 Tropical forest land +! 13 Savannah +! --------------------------------------------------------- +! USGS landuse categories: +! 1 Urban and built-up land +! 2 Dryland cropland and pasture +! 3 Irrigated cropland and pasture +! 4 Mix. dry/irrg. cropland and pasture +! 5 Cropland/grassland mosaic +! 6 Cropland/woodland mosaic +! 7 Grassland +! 8 Shrubland +! 9 Mixed shrubland/grassland +! 10 Savanna +! 11 Deciduous broadleaf forest +! 12 Deciduous needleleaf forest +! 13 Evergreen broadleaf forest +! 14 Evergreen needleleaf forest +! 15 Mixed Forest +! 16 Water Bodies +! 17 Herbaceous wetland +! 18 Wooded wetland +! 19 Barren or sparsely vegetated +! 20 Herbaceous Tundra +! 21 Wooded Tundra +! 22 Mixed Tundra +! 23 Bare Ground Tundra +! 24 Snow or Ice +! 25 No data +! --------------------------------------------------------- +! SiB landuse categories: +! 1 Evergreen broadleaf trees +! 2 Broadleaf deciduous trees +! 3 Deciduous and evergreen trees +! 4 Evergreen needleleaf trees +! 5 Deciduous needleleaf trees +! 6 Ground cover with trees and shrubs +! 7 Ground cover only +! 8 Broadleaf shrub with Perennial ground cover +! 9 Broadleaf shrub with bare soil +! 10 Groundcover with dwarf trees and shrubs +! 11 Bare soil +! 12 Agriculture or C3 grassland +! 13 Persistent Wetland +! 14 Dry coastal complexes +! 15 Water +! 16 Ice cap and glacier +! 17 No data +!-------------------------------------------------------------- +! .. Scalar Arguments .. + LOGICAL :: vegflag + CHARACTER (4) :: mminlu + INTEGER :: isn +! .. +! .. Array Arguments .. +! REAL :: aefiso(nlu), aefmter(nlu), aefovoc(nlu), aef_n(nlu) +! INTEGER :: ixxxlu(nlu) +! .. +! .. Local Scalars .. +! INTEGER :: nseas + INTEGER :: sum +! .. +!********************************************************************** +! Emission Factors for Isoprene in ug C/(m*m*h) +! PRINT *, 'mminlu = ', mminlu + IF (mminlu=='OLD ') THEN +! urban + aefiso(1) = 0. +! agriculture (S+R) + aefiso(2) = 8. +! grassland (S+R) + aefiso(3) = 0. +! deciduous (G94) + aefiso(4) = 4400. +! coniferous (G94) + aefiso(5) = 780. +! mixed forest (G94) + aefiso(6) = 5775. +! water + aefiso(7) = 0. +! wetland, emission unknown + aefiso(8) = 0. +! desert + aefiso(9) = 0. +! tundra (K94) + aefiso(10) = 70. +! ice + aefiso(11) = 0. +! tropical forest (Z88) + aefiso(12) = 3100. +! savanna (Z88) + aefiso(13) = 0 + END IF + IF (mminlu=='USGS') THEN +! urban + aefiso(1) = 0. +! agriculture (S+R) + aefiso(2) = 8. +! agriculture (S+R) + aefiso(3) = 8. +! agriculture (S+R) + aefiso(4) = 8. +! half agriculture/grassland assumed + aefiso(5) = 4. +! half agriculture/deciduous assumed + aefiso(6) = 2204. +! grassland (S+R) + aefiso(7) = 0. +! grassland assumed + aefiso(8) = 0. +! grassland assumed + aefiso(9) = 0. +! savanna (Z88) + aefiso(10) = 0. +! deciduous (G94) + aefiso(11) = 4400. +! coniferous (G94) + aefiso(12) = 780. +! deciduous (G94) + aefiso(13) = 4400. +! coniferous (G94) + aefiso(14) = 780. +! mixed forest (G94) + aefiso(15) = 5775. +! water + aefiso(16) = 0. +! wetland emission unknown + aefiso(17) = 0. +! mixed forest assumed + aefiso(18) = 5775. +! barren + aefiso(19) = 0. +! tundra (K94) assumed + aefiso(20) = 70. +! tundra (K94) assumed + aefiso(21) = 70. +! tundra (K94) assumed + aefiso(22) = 70. +! barren tundra + aefiso(23) = 0. +! ice + aefiso(24) = 0. +! no data + aefiso(25) = 0. + END IF + IF (mminlu=='SiB ') THEN +! deciduous (G94) + aefiso(1) = 4400. +! deciduous (G94) + aefiso(2) = 4400. +! deciduous (G94) + aefiso(3) = 4400. +! coniferous (G94) + aefiso(4) = 780. +! coniferous (G94) + aefiso(5) = 780. +! grassland assumed + aefiso(6) = 0. +! grassland assumed + aefiso(7) = 0. +! grassland assumed + aefiso(8) = 0. +! grassland assumed + aefiso(9) = 0. +! grassland assumed + aefiso(10) = 0. +! bare soil + aefiso(11) = 0. +! agriculture (S+R) + aefiso(12) = 8. +! wetland, emission unknown + aefiso(13) = 0. +! dry, coastal + aefiso(14) = 0. +! water + aefiso(15) = 0. +! ice + aefiso(16) = 0. +! no data + aefiso(17) = 0. + END IF +! --------------------------------------------------------- +! Emission Factors for Monoterpenes in ug C/(m*m*h) + + IF (mminlu=='OLD ') THEN +! urban + aefmter(1) = 0. +! agriculture (S+R) + aefmter(2) = 20. +! grassland (S+R) + aefmter(3) = 20. +! deciduous (G94) + aefmter(4) = 385. +! coniferous (G94) + aefmter(5) = 1380. +! mixed forest (G94) + aefmter(6) = 1001. +! water + aefmter(7) = 0. +! wetland, emission unknown + aefmter(8) = 0. +! desert + aefmter(9) = 0. +! tundra (K94) + aefmter(10) = 0. +! ice + aefmter(11) = 0. +! tropical forest (Z88) + aefmter(12) = 270. +! savanna (Z88) + aefmter(13) = 0 + END IF + IF (mminlu=='USGS') THEN +! urban + aefmter(1) = 0. +! agriculture (S+R) + aefmter(2) = 20. +! agriculture (S+R) + aefmter(3) = 20. +! agriculture (S+R) + aefmter(4) = 20. +! half agriculture/grassland assumed + aefmter(5) = 20. +! half agriculture/deciduous assumed + aefmter(6) = 202.5 +! grassland (S+R) + aefmter(7) = 20. +! grassland assumed + aefmter(8) = 20. +! grassland assumed + aefmter(9) = 20. +! savanna (Z88) + aefmter(10) = 0 +! deciduous (G94) + aefmter(11) = 385. +! coniferous (G94) + aefmter(12) = 1380. +! deciduous (G94) + aefmter(13) = 385. +! coniferous (G94) + aefmter(14) = 1380. +! mixed forest (G94) + aefmter(15) = 1001. +! water + aefmter(16) = 0. +! wetland emission unknown + aefmter(17) = 0. +! mixed forest assumed + aefmter(18) = 1001. +! barren + aefmter(19) = 0. +! tundra (K94) assumed + aefmter(20) = 0. +! tundra (K94) assumed + aefmter(21) = 0. +! tundra (K94) assumed + aefmter(22) = 0. +! barren tundra + aefmter(23) = 0. +! ice + aefmter(24) = 0. +! no data + aefmter(25) = 0. + END IF + IF (mminlu=='SiB ') THEN +! deciduous (G94) + aefmter(1) = 385. +! deciduous (G94) + aefmter(2) = 385. +! deciduous (G94) + aefmter(3) = 385. +! coniferous (G94) + aefmter(4) = 1380. +! coniferous (G94) + aefmter(5) = 1380. +! grassland assumed + aefmter(6) = 20. +! grassland assumed + aefmter(7) = 20. +! grassland assumed + aefmter(8) = 20. +! grassland assumed + aefmter(9) = 20. +! grassland assumed + aefmter(10) = 20. +! bare soil + aefmter(11) = 0. +! agriculture (S+R) + aefmter(12) = 20. +! wetland, emission unknown + aefmter(13) = 0. +! dry, coastal + aefmter(14) = 0. +! water + aefmter(15) = 0. +! ice + aefmter(16) = 0. +! no data + aefmter(17) = 0. + END IF +! --------------------------------------------------------- +! Emission Factors for Other VOCs in ug C/(m*m*h) + + IF (mminlu=='OLD ') THEN +! urban + aefovoc(1) = 0. +! agriculture (S+R) + aefovoc(2) = 12. +! grassland (S+R) + aefovoc(3) = 80. +! deciduous (G94) + aefovoc(4) = 715. +! coniferous (G94) + aefovoc(5) = 840. +! mixed forest (G94) + aefovoc(6) = 924. +! water + aefovoc(7) = 0. +! wetland, emission unknown + aefovoc(8) = 0. +! desert + aefovoc(9) = 0. +! tundra (K94) + aefovoc(10) = 0. +! ice + aefovoc(11) = 0. +! tropical forest (Z88) + aefovoc(12) = 0. +! savanna (Z88) + aefovoc(13) = 0 + END IF + IF (mminlu=='USGS') THEN +! urban + aefovoc(1) = 0. +! agriculture (S+R) + aefovoc(2) = 12. +! agriculture (S+R) + aefovoc(3) = 12. +! agriculture (S+R) + aefovoc(4) = 12. +! half agriculture/grassland assumed + aefovoc(5) = 46. +! half agriculture/deciduous assumed + aefovoc(6) = 363.5 +! grassland (S+R) + aefovoc(7) = 80. +! grassland assumed + aefovoc(8) = 80. +! grassland assumed + aefovoc(9) = 80. +! savanna (Z88) + aefovoc(10) = 0 +! deciduous (G94) + aefovoc(11) = 715. +! coniferous (G94) + aefovoc(12) = 840. +! deciduous (G94) + aefovoc(13) = 715. +! coniferous (G94) + aefovoc(14) = 840. +! mixed forest (G94) + aefovoc(15) = 924. +! water + aefovoc(16) = 0. +! wetland emission unknown + aefovoc(17) = 0. +! mixed forest assumed + aefovoc(18) = 924. +! barren + aefovoc(19) = 0. +! tundra (K94) assumed + aefovoc(20) = 0. +! tundra (K94) assumed + aefovoc(21) = 0. +! tundra (K94) assumed + aefovoc(22) = 0. +! barren tundra + aefovoc(23) = 0. +! ice + aefovoc(24) = 0. +! no data + aefovoc(25) = 0. + END IF + IF (mminlu=='SiB ') THEN +! deciduous (G94) + aefovoc(1) = 715. +! deciduous (G94) + aefovoc(2) = 715. +! deciduous (G94) + aefovoc(3) = 715. +! coniferous (G94) + aefovoc(4) = 840. +! coniferous (G94) + aefovoc(5) = 840. +! grassland assumed + aefovoc(6) = 80. +! grassland assumed + aefovoc(7) = 80. +! grassland assumed + aefovoc(8) = 80. +! grassland assumed + aefovoc(9) = 80. +! grassland assumed + aefovoc(10) = 80. +! bare soil + aefovoc(11) = 0. +! agriculture (S+R) + aefovoc(12) = 12. +! wetland, emission unknown + aefovoc(13) = 0. +! dry, coastal + aefovoc(14) = 0. +! water + aefovoc(15) = 0. +! ice + aefovoc(16) = 0. +! no data + aefovoc(17) = 0. + END IF +! --------------------------------------------------------- +! Emission Factors for Nitrogen in ng N /(m*m*sec) + + IF (mminlu=='OLD ') THEN +! urban + aef_n(1) = 0. +! agriculture (S+R) + aef_n(2) = 9. +! grassland (S+R) + aef_n(3) = 0.9 +! deciduous (G94) + aef_n(4) = 0.07 +! coniferous (G94) + aef_n(5) = 0.07 +! mixed forest (G94) + aef_n(6) = 0.07 +! water + aef_n(7) = 0. +! wetland, emission unknown + aef_n(8) = 0. +! desert + aef_n(9) = 0. +! tundra (K94) + aef_n(10) = 0. +! ice + aef_n(11) = 0. +! tropical forest (Z88) + aef_n(12) = 1.78 +! savanna (Z88) + aef_n(13) = 0 + END IF + IF (mminlu=='USGS') THEN +! urban + aef_n(1) = 0. +! agriculture (S+R) + aef_n(2) = 9. +! agriculture (S+R) + aef_n(3) = 9. +! agriculture (S+R) + aef_n(4) = 9. +! half agriculture/grassland assumed + aef_n(5) = 4.95 +! half agriculture/deciduous assumed + aef_n(6) = 4.535 +! grassland (S+R) + aef_n(7) = 0.9 +! grassland assumed + aef_n(8) = 0.07 +! grassland assumed + aef_n(9) = 0.07 +! savanna (Z88) + aef_n(10) = 0. +! deciduous (G94) + aef_n(11) = 0.07 +! coniferous (G94) + aef_n(12) = 0.07 +! deciduous (G94) + aef_n(13) = 0.07 +! coniferous (G94) + aef_n(14) = 0.07 +! mixed forest (G94) + aef_n(15) = 0.07 +! water + aef_n(16) = 0. +! wetland emission unknown + aef_n(17) = 0. +! mixed forest assumed + aef_n(18) = 0.07 +! barren + aef_n(19) = 0. +! tundra (K94) assumed + aef_n(20) = 0. +! tundra (K94) assumed + aef_n(21) = 0. +! tundra (K94) assumed + aef_n(22) = 0. +! barren tundra + aef_n(23) = 0. +! ice + aef_n(24) = 0. +! no data + aef_n(25) = 0. + END IF + IF (mminlu=='SiB ') THEN +! deciduous (G94) + aef_n(1) = 0.07 +! deciduous (G94) + aef_n(2) = 0.07 +! deciduous (G94) + aef_n(3) = 0.07 +! coniferous (G94) + aef_n(4) = 0.07 +! coniferous (G94) + aef_n(5) = 0.07 +! natural vegetation assumed + aef_n(6) = 0.07 +! grassland assumed + aef_n(7) = 0.9 +! natural vegetation assumed + aef_n(8) = 0.07 +! natural vegetation assumed + aef_n(9) = 0.07 +! natural vegetation assumed + aef_n(10) = 0.07 +! bare soil + aef_n(11) = 0. +! agriculture (S+R) + aef_n(12) = 9. +! wetland, emission unknown + aef_n(13) = 0. +! dry, coastal + aef_n(14) = 0. +! water + aef_n(15) = 0. +! ice + aef_n(16) = 0. +! no data + aef_n(17) = 0. + END IF +! ********************************************************* + +! Simplified landuse scheme for deposition and biogenic emission +! subroutines +! (ISWATER and ISICE are already defined elsewhere, +! therefore water and ice are not considered here) + +! 1 urban or bare soil +! 2 agricultural +! 3 grassland +! 4 deciduous forest +! 5 coniferous and mixed forest +! 6 other natural landuse categories + + + IF (mminlu=='OLD ') THEN + ixxxlu(1) = 1 + ixxxlu(2) = 2 + ixxxlu(3) = 3 + ixxxlu(4) = 4 + ixxxlu(5) = 5 + ixxxlu(6) = 5 + ixxxlu(7) = 0 + ixxxlu(8) = 6 + ixxxlu(9) = 1 + ixxxlu(10) = 6 + ixxxlu(11) = 0 + ixxxlu(12) = 4 + ixxxlu(13) = 6 + END IF + IF (mminlu=='USGS') THEN + ixxxlu(1) = 1 + ixxxlu(2) = 2 + ixxxlu(3) = 2 + ixxxlu(4) = 2 + ixxxlu(5) = 2 + ixxxlu(6) = 4 + ixxxlu(7) = 3 + ixxxlu(8) = 6 + ixxxlu(9) = 3 + ixxxlu(10) = 6 + ixxxlu(11) = 4 + ixxxlu(12) = 5 + ixxxlu(13) = 4 + ixxxlu(14) = 5 + ixxxlu(15) = 5 + ixxxlu(16) = 0 + ixxxlu(17) = 6 + ixxxlu(18) = 4 + ixxxlu(19) = 1 + ixxxlu(20) = 6 + ixxxlu(21) = 4 + ixxxlu(22) = 6 + ixxxlu(23) = 1 + ixxxlu(24) = 0 + ixxxlu(25) = 1 + END IF + IF (mminlu=='SiB ') THEN + ixxxlu(1) = 4 + ixxxlu(2) = 4 + ixxxlu(3) = 4 + ixxxlu(4) = 5 + ixxxlu(5) = 5 + ixxxlu(6) = 6 + ixxxlu(7) = 3 + ixxxlu(8) = 6 + ixxxlu(9) = 6 + ixxxlu(10) = 6 + ixxxlu(11) = 1 + ixxxlu(12) = 2 + ixxxlu(13) = 6 + ixxxlu(14) = 1 + ixxxlu(15) = 0 + ixxxlu(16) = 0 + ixxxlu(17) = 1 + END IF + + +!********************************************************************** +! Calculation of seasonal dependence of emissions +!********************************************************************** +! (if the season is variable during the model run, +! this section should be placed in the beginning of subroutine BIOGEN) +!********************************************************************** + + + IF (mminlu=='OLD ') THEN +! WINTER + IF (isn==2) THEN +! agriculture + aefiso(2) = 0. +! deciduous + aefiso(4) = 0. +! mixed forest + aefiso(6) = 5775./2. +! tundra + aefiso(10) = 0. +! agriculture + aefmter(2) = 0. +! deciduous + aefmter(4) = 0. +! mixed forest + aefmter(6) = 1001./2. +! agriculture + aefovoc(2) = 0. +! deciduous + aefovoc(4) = 0. +! mixed forest + aefovoc(6) = 924./2. + END IF + END IF + + IF (mminlu=='USGS') THEN +! DOES VEGETATION FRACTION EXIST? + sum = 0. +! DO J=1,jl-1 +! DO I=1,il-1 +! SUM=SUM+VEGFRC(I,J) +! END DO +! END DO + IF (sum>1) THEN + vegflag = .TRUE. + ELSE + vegflag = .FALSE. + END IF +! VEGFLAG=.FALSE. + IF (( .NOT. vegflag) .AND. (isn==2)) THEN +! IF ((.NOT.VEGFLAG)) THEN +! VEGETATION FRACTION DOES NOT EXIST, +! CORRECTION FOR WINTER SEASON +! agriculture + aefiso(2) = 0. +! agriculture + aefiso(3) = 0. +! agriculture + aefiso(4) = 0. +! half agriculture/grassland assumed + aefiso(5) = 0. +! half agriculture/deciduous assumed + aefiso(6) = 0. +! deciduous broadleaf + aefiso(11) = 0. +! deciduous needleleaf + aefiso(12) = 0. +! mixed forest + aefiso(15) = 5775./2. +! mixed forest assumed + aefiso(18) = 5775./2. +! tundra + aefiso(20) = 0. +! tundra + aefiso(21) = 0. +! tundra + aefiso(22) = 0. +! agriculture + aefmter(2) = 0. +! agriculture + aefmter(3) = 0. +! agriculture + aefmter(4) = 0. +! half agriculture/grassland assumed + aefmter(5) = 10. +! half agriculture/deciduous assumed + aefmter(6) = 0. +! deciduous broadleaf + aefmter(11) = 0. +! deciduous needleleaf + aefmter(12) = 0. +! mixed forest + aefmter(15) = 1001./2. +! mixed forest assumed + aefmter(18) = 1001./2. +! agriculture + aefovoc(2) = 0. +! agriculture + aefovoc(3) = 0. +! agriculture + aefovoc(4) = 0. +! half agriculture/grassland assumed + aefovoc(5) = 40. +! half agriculture/deciduous assumed + aefovoc(6) = 0. +! deciduous broadleaf + aefovoc(11) = 0. +! deciduous needleleaf + aefovoc(12) = 0. +! mixed forest + aefovoc(15) = 924./2. +! mixed forest assumed + aefovoc(18) = 924./2. + END IF + END IF + + IF (mminlu=='SiB ') THEN +! WINTER + IF (isn==2) THEN +! deciduous + aefiso(1) = 0. +! deciduous + aefiso(2) = 0. +! deciduous + aefiso(3) = 0. +! agriculture + aefiso(12) = 0. +! deciduous + aefmter(1) = 0. +! deciduous + aefmter(2) = 0. +! deciduous + aefmter(3) = 0. +! agriculture + aefmter(12) = 0. +! deciduous + aefovoc(1) = 0. +! deciduous + aefovoc(2) = 0. +! deciduous + aefovoc(3) = 0. +! agriculture + aefovoc(12) = 0. + END IF + END IF + + END SUBROUTINE bioemiin +! ********************************************************************** +! *********************** SUBROUTINE BIOGEN ************************** +! ********************************************************************** + SUBROUTINE biogen(iland,ta,rad,eiso,emter,eovoc,e_n,vocsc,eisoc,emterc, & + eovocc,e_nn,pa,mminlu,isn,vegflag) + +! THIS PROGRAMM COMPUTES THE ACTUAL BIOGENIC EMISSION RATE FOR +! ISOPRENE, MONTERPENES, OTHER ORGANIC COMPOUNDS, AND NITROGEN FOR +! EACH GRID CELL DEPENDING ON TEMPERATURE AND GLOBAL RADIATION +!*********************************************************************** +! PROGRAM DEVELOPED BY:- THOMAS SCHOENEMEYER (5 JANUARY 1995) +! MODIFIED BY: - THOMAS SCHOENEMEYER (21 AUGUST 1996) +! UND KLAUS RICHTER +! NACH SIMPSON ET AL. +! - WINFRIED SEIDL (JUNE 1997) +! ADAPTATION FOR USE IN MM5 +! - WINFRIED SEIDL (MARCH 2000) +! MODIFICATION FOR MM5 VERSION 3 +! - Georg Grell (March 2002) for f90 and WRF +!*********************************************************************** +!...PROGRAM VARIABLES... +! ILAND - Land use category +! TA - Air temperature in K +! RAD - Solare global radiation in W/m2 +! EISO - Emission von Isopren in ppm*m/min +! EMTER - Emission von Monoterpenen in ppm*m/min +! EOVOC - Emission sonstiger fluechtiger Kohlenwasserstoffe +! in ppm*m/min +! E_N - Emission von Stickstoff in ppm*m/min +! AEFISO(NLU) - Emissionsfaktor fuer Isopren fuer die Land- +! nutzungsart K, standardisiert auf 303 K und +! voller Sonneneinstrahlung in ug C /(m*m*h) +! AEFOVOC(NLU)- Emissionsfaktor fuer sonstige fluechtige +! Kohlenwasserstoffe in ug C /(m*m*h) +! AEFMTER(NLU)- Emissionsfaktor fuer MONOTERPENE +! in ug C /(m*m*h) +! AEF_N(NLU) - Emissionsfaktor fuer Stickstoff +! in ng N /(m*m*sec) +! ECF_ISO - dimensionsloser Korrekturfaktor fuer Isopren, +! abhaengig von Temperatur und Strahlung +! ECF_OVOC dimensionsloser Korrekturfaktor fuer die +! sonstigen fluechtigen Kohlenwasserstoffe +! ECF_MTER dimensionsloser Korrekturfaktor fuer die +! MONOTERPENE +! ECF_N - dimensionsloser Korrekturfaktor fuer +! Stickstoff +! .. Scalar Arguments .. + REAL :: eiso, eisoc, emter, emterc, eovoc, eovocc, e_n, e_nn, pa, rad, & + ta, vocsc + INTEGER :: iland, isn + LOGICAL :: vegflag + CHARACTER (4) :: mminlu +! .. +! .. Array Arguments .. +! REAL :: aefiso(nlu), aefmter(nlu), aefovoc(nlu), aef_n(nlu) +! INTEGER :: ixxxlu(nlu) +! .. +! .. Local Scalars .. + REAL :: alpha, beta, cl, cl1, coniso, conn, conovoc, conter, ct, ct1, & + ct2, ecf_iso, ecf_mter, ecf_n, ecf_ovoc, par, r, rat, tm, ts, tsoil +! .. +! .. Intrinsic Functions .. + INTRINSIC exp, sqrt +! .. +! empirischer Koeffizient + alpha = 0.0027 +! empirischer Koeffizient + cl1 = 1.066 +! Gaskonstante in J/(K*mol) + r = 8.314 +! empirischer Koeffizient in J/mol + ct1 = 95000 +! empirischer Koeffizient in J/mol + ct2 = 230000 +! empirischer Koeffizient in K + tm = 314. +! faktoren bestimmt werden + ts = 303. +! Standardtemperatur bei der Emissions- + beta = 0.09 +!********************************************************************** +!********************************************************************** +! Temperature and Radiation Dependent Correction Factors +! for Emissions +!********************************************************************** +!********************************************************************** + + +! ***************************************************************** +! Forest land use categories + +! empirischer TemperaturKoeffizient + IF ((ixxxlu(iland)==4) .OR. (ixxxlu(iland)==5)) THEN +! ! = photosynthetisch aktive Strahlung; + par = 2.0*rad +! ! Umrechnungsfaktor: 2.0 uE/J (beruecksich +! auch, dass PAR ein kleinerer Wellenlaeng +! bereich ist als die Globalstrahlung. +! Langholz und Haeckl, 1985, Met. Rundscha + +! PAR flux in Mikromol je m**2 und s + cl = alpha*cl1*par/sqrt(1+alpha*alpha*par*par) + ct = exp(ct1*(ta-ts)/(r*ts*ta))/(1+exp(ct2*(ta-tm)/(r*ts*ta))) + + ecf_iso = cl*ct +! Korrekturfaktor fuer Isopr + ecf_mter = exp(beta*(ta-ts)) ! Korrekturfaktor fuer MTER + ecf_ovoc = ecf_mter +! Korrekturfaktor fuer OVOC + tsoil = 0.84*(ta-273.15) + 3.6 + ecf_n = exp(0.071*tsoil) +! Korrekturfaktor fuer N + END IF + +! ***************************************************************** +! Agricultural land use category + + IF (ixxxlu(iland)==2) THEN + ecf_iso = exp(0.1*(ta-30.-273.15)) ! vgl. Hahn et al. + ecf_mter = ecf_iso + ecf_ovoc = ecf_iso + + tsoil = 0.72*(ta-273.15) + 5.8 + ecf_n = exp(0.071*tsoil) + END IF + +! ***************************************************************** +! Grassland and natural nonforested land use categories + + IF ((ixxxlu(iland)==3) .OR. (ixxxlu(iland)==6)) THEN + ecf_iso = exp(0.1*(ta-30.-273.15)) ! vgl. Hahn et al. + ecf_mter = ecf_iso + ecf_ovoc = ecf_iso + + tsoil = 0.66*(ta-273.15) + 8.8 + ecf_n = exp(0.071*tsoil) + END IF + +! ***************************************************************** +! Non-emitting land use categories + + IF ((ixxxlu(iland)==1) .OR. (iland==iswater_temp) .OR. (iland==isice_temp)) THEN + ecf_iso = 0. + ecf_mter = 0. + ecf_ovoc = 0. + ecf_n = 0. + END IF +!********************************************************************** +!********************************************************************** +! Calculation of Emissions +!********************************************************************** +!********************************************************************** + +! CONVERSION FROM MICROGRAM C/M2/H TO PPM*M/MIN +! CORRECTION TERM FOR TEMP(K) AND PRESSURE +! K = (T/P) *R)/(MW*60) +! R = 8.3143E-2 m3 mbar/(K mole) + + rat = ta/pa +! ***************************************************************** +! Isopren: + + coniso = rat*2.3095E-5 + eisoc = aefiso(iland)*ecf_iso + eiso = coniso*eisoc + +! ***************************************************************** +! Monoterpenes: + + conter = rat*1.1548E-5 + emterc = aefmter(iland)*ecf_mter + emter = conter*emterc + +! ***************************************************************** +! Other VOCs: + +! as 3-hexenyl-acetate (C=96g/mole) + + conovoc = rat*1.4435E-5 + eovocc = aefovoc(iland)*ecf_ovoc + eovoc = conovoc*eovocc +! ***************************************************************** +! SUM OF ALL VOCS + + vocsc = eisoc + emterc + eovocc + +! ***************************************************************** +! Nitrogen: + +! CONVERSION FROM NANOGRAM N/M2/SEC TO PPM*M/MIN +! CORRECTION TERM FOR TEMP(K) AND PRESSURE +! INVENTORY AS N +! INPUT TO THE MODEL ASSUMED AS NO +! K = (T/P) *R*60)/(MW*1000) +! R = 8.3143E-2 m3 mbar/(K mole) + + conn = rat*3.5633E-4 + e_nn = aef_n(iland)*ecf_n + e_n = conn*e_nn + + + END SUBROUTINE biogen +! ********************************************************************** +! *********************** SUBROUTINE BIOSPLIT ************************* +! ********************************************************************** + SUBROUTINE biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,numgas, & + vegfrc,mminlu,vegflag) +! THIS PROGRAMM SPLITS THE BIOGENIC EMISSION RATES FOR +! MONOTERPENES AND OTHER ORGANIC COMPOUNDS INTO THE +! COMPOUND CLASSES OF THE CHEMISTRY MODEL +! --- VERSION FOR RADM2 AND RACM CHEMISTRY --- +!*********************************************************************** +! PROGRAM DEVELOPED BY:- WINFRIED SEIDL (JULY 1997) +! MODIFIED BY: - WINFRIED SEIDL (JULY 1998) +! FOR RACM-CHEMISTRY +! - WINFRIED SEIDL (MARCH 2000) +! FOR MM5 VERSION 3 +!*********************************************************************** +!...PROGRAM VARIABLES... +! ILAND - Land use category +! EISO - Emission von Isopren in ppm*m/min +! EMTER - Emission von Monoterpenen in ppm*m/min +! EOVOC - Emission sonstiger fluechtiger Kohlenwasserstoffe +! in ppm*m/min +! E_N - Emission von Stickstoff in ppm*m/min +!*********************************************************************** +!...Comments... +! The split of the monoterpenes and the other VOCs into RADM clas +! is mostly rather uncertain. Every plant species emitts a differ +! mix of chemical substances. So e.g. different types of deciduou +! trees show totally different emissions. By taking the MM5 +! land use categories, the kind of biogenic emissions can be +! estimated only roughly. Especially for the other VOCs little +! is known, so the splits presented here have to be regarded as +! a preliminary assumption. +! Some literature on this field: +! Arey et al., J. Geophys. Res. 96D (1991), 9329-9336 +! Arey et al., Atmospheric Environment 25A (1991), 1063-1075 +! Koenig et al., Atmospheric Environment 29 (1995), 861-874 +! Isidorov et al., Atmospheric Environment 19 (1985), 1-8 +! Martin et al., Abstract Air & Waste Management Association''s +! 90th Annual Meeting & Exhibition, Toronto 1997, Paper 97-RP139. +! Winer et al., Final Report 1983, California Air Resources Bord, +! Contract No. AO-056-32 +! For the RADM 2 chemistry, most of the monoterpenes are grouped +! into the OLI class +! (Middleton et al., Atmospheric Environment 24A (1990), 1107-113 +! with a few exceptions: +! ISO -- myrcene, ocimene +! XYL -- p-cymene +! For the RACM chemistry, the monoterpenes are split +! between the API, LIM, ISO and XYL classes: +! API -- a-pinene, b-pinene, D3-carene, sabinene, camphene, +! 1,8-cineole, a-terpineole, thujene +! LIM -- limonene, terpinene, phellandrene, terpinolene +! ISO -- myrcene, ocimene +! XYL -- p-cymene +! The other VOCs are grouped according to Middleton et al. (1990) +!*********************************************************************** +! .. Scalar Arguments .. + REAL :: eiso, emter, eovoc, e_n, vegfrc + INTEGER :: iland, numgas +! INTEGER :: lald, lhc3, lhc5, lhc8, lhcho, liso, lket, lno, & +! loli, lolt, lora1, lora2, lxyl +! .. +! .. Array Arguments .. + REAL :: emiss_bio(numgas) +! INTEGER :: ixxxlu(nlu) +! .. +! .. Local Scalars .. + LOGICAL :: vegflag + CHARACTER (4) :: mminlu +! .. +! ***************************************************************** +! Correction for vegetation fraction + IF ((mminlu=='USGS') .AND. (vegflag)) THEN + eiso = eiso*vegfrc/100. + emter = emter*vegfrc/100. + eovoc = eovoc*vegfrc/100. + END IF + +! ***************************************************************** +! Isoprene and NO + + emiss_bio(liso) = eiso + emiss_bio(lno) = emiss_bio(lno) + e_n + +! ***************************************************************** +! Agricultural land + + IF (ixxxlu(iland)==2) THEN + emiss_bio(loli) = emiss_bio(loli) + 0.80*emter + emiss_bio(liso) = emiss_bio(liso) + 0.20*emter + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.16*eovoc + emiss_bio(lhc8) = emiss_bio(lhc8) + 0.27*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.05*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.37*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.03*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.12*eovoc + END IF + +! ***************************************************************** +! Grassland + + IF (ixxxlu(iland)==3) THEN + emiss_bio(loli) = emiss_bio(loli) + 0.98*emter + emiss_bio(liso) = emiss_bio(liso) + 0.02*emter + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.09*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.07*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.51*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.15*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.18*eovoc + END IF + +! ***************************************************************** +! Deciduous forest + + IF (ixxxlu(iland)==4) THEN + emiss_bio(loli) = emiss_bio(loli) + 0.94*emter + emiss_bio(liso) = emiss_bio(liso) + 0.02*emter + emiss_bio(lhcho) = emiss_bio(lhcho) + 0.19*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.13*eovoc + emiss_bio(lxyl) = emiss_bio(lxyl) + 0.04*emter + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.03*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.07*eovoc + emiss_bio(lora1) = emiss_bio(lora1) + 0.23*eovoc + emiss_bio(lora2) = emiss_bio(lora2) + 0.35*eovoc + END IF + +! ***************************************************************** +! Coniferous forest and mixed forest + + + IF (ixxxlu(iland)==5) THEN + emiss_bio(loli) = emiss_bio(loli) + 0.85*emter + emiss_bio(liso) = emiss_bio(liso) + 0.15*emter + emiss_bio(lhcho) = emiss_bio(lhcho) + 0.04*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.14*eovoc + emiss_bio(lhc3) = emiss_bio(lhc3) + 0.07*eovoc + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.07*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.07*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.50*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.03*eovoc + emiss_bio(lora1) = emiss_bio(lora1) + 0.03*eovoc + emiss_bio(lora2) = emiss_bio(lora2) + 0.05*eovoc + END IF + +! ***************************************************************** +! Tropical forest (not available in SiB and USGS) + + IF ((mminlu=='OLD ') .AND. (iland==12)) THEN + emiss_bio(loli) = emiss_bio(loli) + emter + END IF + + END SUBROUTINE biosplit + + END MODULE module_bioemi_simple diff --git a/wrfv2_fire/chem/module_cbmz.F b/wrfv2_fire/chem/module_cbmz.F new file mode 100644 index 00000000..7e64a158 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz.F @@ -0,0 +1,3935 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! Chemistry Option: CBMZ (Carbon Bond Mechanism IV - Zaveri) +! * Primary investigator: Rahul A. Zaveri +! * Co-investigator: Richard C. Easter, William I. Gustafson Jr. +! Last update: September 2005 +! +! Contacts: +! Rahul A. Zaveri, PhD Jerome D. Fast, PhD +! Senior Research Scientist Staff Scientist +! Pacific Northwest National Laboratory Pacific Northwest National Laboratory +! P.O. Box 999, MSIN K9-30 P.O. Box 999, MSIN K9-30 +! Richland, WA 99352 Richland, WA, 99352 +! Phone: (509) 372-6159 Phone: (509) 372-6116 +! Email: Rahul.Zaveri@pnl.gov Email: Jerome.Fast@pnl.gov +! +! Please report any bugs or problems to Rahul Zaveri, the primary author of the +! code, or Jerome Fast, the WRF-chem implementation team leader +! +!Terms of Use: +! 1) CBMZ and its sub-modules may not be included in any commerical package, +! or used for any commercial applications without the primary author's +! prior consent. +! 2) The CBMZ source code is provided to the WRF modeling community; however, +! no portion of CBMZ can be used separately or in another code without the +! primary author's prior consent. +! 3) The CBMZ source code may be used for research, educational, and non-profit +! purposes only. Any other usage must be first approved by the primary author. +! 4) Publications resulting from the usage of CBMZ must use one or more of the +! references below (depending on the application) for proper acknowledgment. +! +! References: +! 1) Zaveri R.A., and L.K. Peters (1999), A new lumped structure photochemical +! mechanism for large-scale applications, J. Geophys. Res., 104, 30387-30415. +! 2) Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. Barnard, E.G. +! Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution of ozone, particulates, +! and aerosol direct radiative forcing in the vicinity of Houston using a fully- +! coupled meteorology-chemistry-aerosol model, Submitted to J. Geophys. Res. +! +! Contact Jerome Fast for updates on the status of manuscripts under review. +! +! Additional information: +! 1) www.pnl.gov/atmos_sciences/raz +! 2) www.pnl.gov/atmos_sciences/Jdf/wrfchem.html +! +! Support: +! Funding for developing and evaluating CBMZ was provided by the U.S. Department +! of Energy under the auspices of Atmospheric Science Program of the Office of +! Biological and Environmental Research the the PNNL Laboratory Research and +! Directed Research and Development program. +!********************************************************************************** + module module_cbmz + + + + use module_peg_util + + contains + + +!*********************************************************************** +! < 1.> subr cbmz_driver +! +! purpose: serves as an interface between subr. gas_chemistry and +! the actual solver subr such as lsodes, rodas, etc. +! +! grid : fixed i,j,k (box-model) +! +! author : Rahul A. Zaveri +! date : November 1998 +! +!----------------------------------------------------------------------- + + subroutine cbmz_driver( & + id, ktau, dtstep, ktauc, dtstepc, config_flags, & + gmt, julday, t_phy, moist, p8w, t8w, & + p_phy, chem, rho_phy, dz8w, z, z_at_w, vdrog3, & + ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, ph_hno2, & + ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, ph_ch2om, & + ph_ch3o2h, ph_n2o5, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure, only: grid_config_rec_type, num_moist, num_chem, & + p_qv, p_so2, p_ho2, p_so4aj, p_corn, p_hcl, p_mtf + USE module_data_sorgam, only: ldrog + USE module_data_cbmz + IMPLICIT NONE + + +!----------------------------------------------------------------------- +! subr arguments + + INTEGER, INTENT(IN ) :: id, julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ktau, ktauc + + REAL, INTENT(IN ) :: dtstep, dtstepc, gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! advected chemical tracers +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! arrays that hold photolysis rates +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, ph_hno2, & + ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, ph_ch2om, & + ph_ch3o2h, ph_n2o5 +! +! on input from met model +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & ! temperature + rho_phy, & ! air density (kg/m3) + p_phy, & ! NOT USED + z, z_at_w, & ! NOT USED + dz8w, & ! NOT USED + t8w, p8w ! NOT USED +! +! for interaction with aerosols (really is output) +! + REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme , ldrog ) , & + INTENT(INOUT ) :: & + vdrog3 ! NOT USED + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + +!----------------------------------------------------------------------- + + +! local variables + integer :: idum, iok + integer :: iregime + integer :: igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 + integer :: igas_solver, iregime_forced + integer :: i_boxtest_units_convert + integer :: i_print_gasode_stats + integer :: i_force_dump, mode_force_dump + integer :: it, jt, kt + integer :: jsolver + integer :: lunerr, lunout, levdbg_err, levdbg_info + integer :: mgaschem + + + real :: abs_error, rel_error, trun + real :: tchem, dtchem + real :: tstart, tstop + real :: airdenbox, pressbox, tempbox + real :: cair_mlc + real :: h2o, ch4, oxygen, nitrogen, hydrogen + real :: cboxnew(ngas_z), cboxold(ngas_z) + real :: Aperox(nperox,nperox), Bperox(nperox,nperox) + real :: rk_param(nperox), rk_photo(nphoto) + real :: rk_m1(nrxn_m1), rk_m2(nrxn_m2), rk_m3(nrxn_m3), rk_m4(nrxn_m4) + + integer, dimension(2,6), save :: inforodas=0 + integer, dimension(6), save :: iodestatus_count=0, ioderegime_count=0 + +#ifdef CHEM_DBG_I +!rcetestb diagnostics -------------------------------------------------- + print 93010, ' ' + print 93010, 'rcetestb diagnostics from cbmz_driver' + print 93010, 'id, chem_opt, ktau, ktauc, julday ', & + id, config_flags%chem_opt, ktau, ktauc, julday + print 93020, 'dtstep, dtstepc, gmt ', & + dtstep, dtstepc, gmt + print 93010, 'ids/e, j, k', ids, ide, jds, jde, kds, kde + print 93010, 'ims/e, j, k', ims, ime, jms, jme, kms, kme + print 93010, 'its/e, j, k', its, ite, jts, jte, kts, kte + print 93010, 'num_moist, p_qv ', num_moist, p_qv + print 93010, 'num_chem, p_so2, p_ho2 ', num_chem, p_so2, p_ho2 + print 93010, 'p_so4aj, p_corn, p_hcl, p_mtf', p_so4aj, p_corn, p_hcl, p_mtf +93010 format( a, 8(1x,i6) ) +93020 format( a, 8(1p,e14.6) ) +!rcetestb diagnostics -------------------------------------------------- +#endif + + +! set some control variables to their "standard for wrf-chem" values + igas_solver = 1 + iregime_forced = -1 + mgaschem = +1 + i_boxtest_units_convert = 0 + + i_print_gasode_stats = 1 + mode_force_dump = 0 + lunerr = -1 + lunout = -1 + levdbg_err = 0 + levdbg_info = 15 + + abs_error = 1.0e1 ! solver absolute tolerance (molecules/cm3) + rel_error = 1.0e-3 ! solver relative tolerance + +! set some control variables to non-standard values for testing +! force dumps for center column, every 3rd level +! mode_force_dump = +77 +! force dumps for center column, 1st level +! mode_force_dump = +7 +! do levdbg_info output always + levdbg_info = 0 + + +! following call is for boxwrf testing only +! it must be commented out for actual wrf applications +! call boxtest_get_extra_args( & +! igas_solver, iregime_forced, & +! i_boxtest_units_convert, lunerr, lunout, & +! abs_error, rel_error, trun ) + + +! currently nothing is done with vdrog3 +! vdrog3(its:ite,kts:kte,jts:jte,:) = 0.0 !This is already set to zero in chem_driver. + + +! determine which regimes are allowed +! based on which gas species are "active" + call set_gaschem_allowed_regimes( lunerr, & + igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 ) + +! +! main loop -- do gas chemistry at each i,j,k +! + do 2900 jt = jts, jte + do 2900 kt = kts, kte-1 + do 2900 it = its, ite + + trun = dtstep*(ktau-1) ! run time in s + tchem = gmt*3600.0 + dtstep*(ktau-1) + tchem = mod( tchem, 86400.0 ) ! time from 00 UTC in s + dtchem = dtstepc + tstart = tchem ! s + tstop = tstart + dtchem ! s + +! skip integration for very small dtchem + if ((tstop-tstart) .le. 1.0e-5) goto 2900 + + +! initial species mapping from host array + call mapgas_tofrom_host( 0, & + i_boxtest_units_convert, & + it,jt,kt, ims,ime, jms,jme, kms,kme, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy, & + cboxold, tempbox, pressbox, airdenbox, & + cair_mlc, & + h2o, ch4, oxygen, nitrogen, hydrogen ) + cboxnew(:) = cboxold(:) + +! determine regime + call selectgasregime( iregime, iregime_forced, cboxold, & + igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 ) + idum = iregime + if ((idum .lt. 1) .or. (idum .ge. 6)) idum = 6 + ioderegime_count(idum) = ioderegime_count(idum) + 1 + iodestatus_count(6) = iodestatus_count(6) + 1 + +! compute rate constants +! transfer/map incoming photolysis rate contants to local array + call gasphotoconstants( rk_photo, & + i_boxtest_units_convert, & + it,jt,kt, ims,ime, jms,jme, kms,kme, & + ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, ph_hno2, & + ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, ph_ch2om, & + ph_ch3o2h, ph_n2o5 ) +! loads Aperox and Bperox + call loadperoxyparameters( Aperox, Bperox ) +! calculate parameterized rate constants + call peroxyrateconstants( tempbox, cboxold, & + Aperox, Bperox, rk_param ) +! calculate thermal rate constants + call gasrateconstants( iregime, tempbox, cair_mlc, & + rk_photo, rk_param, rk_m1, rk_m2, rk_m3, rk_m4 ) + +! mode_force_dump selects a detailed dump of gaschem at either +! first ijk grid, first ij column, all ijk, or no ijk + i_force_dump = 0 + if (mode_force_dump .eq. 1) then + if ((it.eq.its) .and. (jt.eq.jts) & + .and. (kt.eq.kts)) i_force_dump = 1 + else if (mode_force_dump .eq. 10) then + if ((it.eq.its) .and. (jt.eq.jts)) i_force_dump = 1 + else if (mode_force_dump .eq. 100) then + i_force_dump = 1 + else if (mode_force_dump .eq. 7) then + if ( (it .eq. (its+ite)/2) .and. & + (jt .eq. (jts+jte)/2) .and. & + (kt .eq. kts) ) i_force_dump = 1 + else if (mode_force_dump .eq. 77) then + if ( (it .eq. (its+ite)/2) .and. & + (jt .eq. (jts+jte)/2) .and. & + (mod(kt-kts,3) .eq. 0) ) i_force_dump = 1 + end if + + +! rodas + iok = 0 + jsolver = 0 + if (igas_solver .eq. 1) then + jsolver = 1 + call gasodesolver_rodas( tstart, tstop, iok, & + it, jt, kt, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info, & + i_force_dump, inforodas, iodestatus_count, & + abs_error, rel_error, trun, & + tempbox, pressbox, airdenbox, cboxnew, cboxold, & + rk_m1, rk_m2, rk_m3, rk_m4 ) + endif + +! lsodes + if (igas_solver.eq.2 .or. iok.le.0) then + jsolver = 2 + call gasodesolver_lsodes( tstart, tstop, iok, & + it, jt, kt, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info, & + i_force_dump, iodestatus_count, & + abs_error, rel_error, trun, & + tempbox, pressbox, airdenbox, cboxnew, cboxold, & + rk_m1, rk_m2, rk_m3, rk_m4 ) + endif + +! final species mapping back to host array -- only when iok > 0 + if (iok .gt. 0) then + call mapgas_tofrom_host( 1, & + i_boxtest_units_convert, & + it,jt,kt, ims,ime, jms,jme, kms,kme, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy, & + cboxnew, tempbox, pressbox, airdenbox, & + cair_mlc, & + h2o, ch4, oxygen, nitrogen, hydrogen ) + end if + +! following call is for boxwrf testing only +! it must be commented out for actual wrf applications +! call boxtest_set_extra_args( iregime, it, jt, kt ) + +2900 continue + + if (i_print_gasode_stats .gt. 0) & + call print_gasode_stats( lunout, levdbg_info, & + inforodas, iodestatus_count, ioderegime_count ) + return + end subroutine cbmz_driver + + + +!*********************************************************************** +! < xx.> subr print_gasode_stats +! +! purpose: writes some statistics on ode solver performance to unit lunout +! +!----------------------------------------------------------------------- + + subroutine print_gasode_stats( lunout, levdbg, & + inforodas, iodestatus_count, ioderegime_count ) + + implicit none + +! subr arguments + integer lunout, levdbg + integer inforodas(2,6), iodestatus_count(6), ioderegime_count(6) + +! local variables + integer i, j + character*80 msg + + + msg = ' ' + call peg_debugmsg( lunout, levdbg, msg ) + msg = 'output from dump_cbmz_gasodeinfo' + call peg_debugmsg( lunout, levdbg, msg ) + write(msg,9100) 'oderegime(1-6)', (ioderegime_count(i), i=1,6) + call peg_debugmsg( lunout, levdbg, msg ) + write(msg,9100) 'odestatus(1-6)', (iodestatus_count(i), i=1,6) + call peg_debugmsg( lunout, levdbg, msg ) + + write(msg,9200) & + 'inforodas(1-3)', ((inforodas(j,i), j=1,2), i=1,3) + call peg_debugmsg( lunout, levdbg, msg ) + write(msg,9200) & + 'inforodas(4-6)', ((inforodas(j,i), j=1,2), i=4,6) + call peg_debugmsg( lunout, levdbg, msg ) + +9100 format( a, 6i11 ) +9200 format( a, 3( i11, '--', i9.9 ) ) + + return + end subroutine print_gasode_stats + + + +!*********************************************************************** +! < xx.> subr gasodesolver_rodas +! +! purpose: interfaces to rodas ode solver +! +!----------------------------------------------------------------------- + + subroutine gasodesolver_rodas( tstart, tstop, iok, & + isvode, jsvode, ksvode, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info, & + i_force_dump, inforodas, iodestatus_count, & + abs_error, rel_error, trun, & + tempbox, pressbox, airdenbox, cboxnew, cboxold, & + rk_m1, rk_m2, rk_m3, rk_m4 ) + + use module_data_cbmz + use module_cbmz_rodas_prep, only: & + cbmz_v02r01_mapconcs, cbmz_v02r01_maprates, cbmz_v02r01_torodas, & + cbmz_v02r02_mapconcs, cbmz_v02r02_maprates, cbmz_v02r02_torodas, & + cbmz_v02r03_mapconcs, cbmz_v02r03_maprates, cbmz_v02r03_torodas, & + cbmz_v02r04_mapconcs, cbmz_v02r04_maprates, cbmz_v02r04_torodas, & + cbmz_v02r05_mapconcs, cbmz_v02r05_maprates, cbmz_v02r05_torodas, & + cbmz_v02r06_mapconcs, cbmz_v02r06_maprates, cbmz_v02r06_torodas + + implicit none + +! subr arguments + integer iok, isvode, jsvode, ksvode, i_force_dump, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info + integer inforodas(2,6), iodestatus_count(6) + real tstart, tstop, abs_error, rel_error, trun + real tempbox, pressbox, airdenbox + real cboxnew(ngas_z), cboxold(ngas_z) + real rk_m1(nrxn_m1), rk_m2(nrxn_m2), rk_m3(nrxn_m3), rk_m4(nrxn_m4) + +! local variables + integer :: ia, idum, idydt_sngldble, ig, l, ntot + integer, save :: nrodas_failures = 0 + integer, dimension(6) :: inforodas_cur + + real hmin, hstart, taa, tzz + real atolvec(ngas_z), rtolvec(ngas_z), & + stot(ngas_z), & + yposlimit(ngas_z), yneglimit(ngas_z) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + + character*80 msg + +! map reaction rate constants (pegasus --> kpp) +! map concentrations (cboxold --> stot) +! dump rates (for debugging) + if (iregime .eq. 1) then + call cbmz_v02r01_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r01_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + + else if (iregime .eq. 2) then + call cbmz_v02r02_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r02_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + + else if (iregime .eq. 3) then + call cbmz_v02r03_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r03_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + + else if (iregime .eq. 4) then + call cbmz_v02r04_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r04_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + + else if (iregime .eq. 5) then + call cbmz_v02r05_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r05_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + + else + call cbmz_v02r06_maprates( rk_m1, rk_m2, rk_m3, rk_m4, & + rconstkpp ) + call cbmz_v02r06_mapconcs( 0, ntot, stot, sfixedkpp, cboxold ) + end if + +! set parameters for rodas call + do l = 1, ntot + atolvec(l) = abs_error + rtolvec(l) = rel_error + yposlimit(l) = 1.0e20 + yneglimit(l) = -1.0e8 + end do + + taa = tstart + tzz = tstop + hmin = 1.0e-5 + hstart = 60.0 + idydt_sngldble = 1 + +! call rodas integrator +! subr cbmz_v02r06_torodas( +! + ngas, taa, tzz, +! + stot, atol, rtol, yposlimit, yneglimit, +! + hmin, hstart, +! + inforodas_cur, iok, lunerr, idydt_sngldble ) + + if (iregime .eq. 1) then + call cbmz_v02r01_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + + else if (iregime .eq. 2) then + call cbmz_v02r02_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + + else if (iregime .eq. 3) then + call cbmz_v02r03_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + + else if (iregime .eq. 4) then + call cbmz_v02r04_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + + else if (iregime .eq. 5) then + call cbmz_v02r05_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + + else + call cbmz_v02r06_torodas( & + ntot, taa, tzz, & + stot, atolvec, rtolvec, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + inforodas_cur, iok, lunerr, idydt_sngldble ) + end if + + +! increment odeinfo counters + if (iok .gt. 0) then + if (inforodas_cur(6) .le. 0) then + ia = 1 + else + ia = 2 + end if + else + ia = 3 + end if + iodestatus_count(ia) = iodestatus_count(ia) + 1 +! do following to avoid overflow of the "inforodas" numbers +! inforodas(2,i) contains rightmost 9 digits of each inforodas number +! inforodas(1,i) contains any higher digits of each inforodas number + do ia = 1, 6 + idum = inforodas(2,ia) + inforodas_cur(ia) + inforodas(1,ia) = inforodas(1,ia) + (idum/1000000000) + inforodas(2,ia) = mod(idum, 1000000000) + end do + + +! map concentrations (stot --> cboxnew) + if (iregime .eq. 1) then + call cbmz_v02r01_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + else if (iregime .eq. 2) then + call cbmz_v02r02_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + else if (iregime .eq. 3) then + call cbmz_v02r03_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + else if (iregime .eq. 4) then + call cbmz_v02r04_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + else if (iregime .eq. 5) then + call cbmz_v02r05_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + else + call cbmz_v02r06_mapconcs( 1, ntot, stot, sfixedkpp, cboxnew ) + end if + + +! diagnostic output if integration fails OR if i_force_dump > 0 + if (iok .gt. 0) then + if (i_force_dump .le. 0) goto 20000 + else + nrodas_failures = nrodas_failures + 1 + if (nrodas_failures .gt. 100) goto 20000 + end if + + msg = ' ' + call peg_debugmsg( lunout, levdbg_err, msg ) + if (iok .gt. 0) then + msg = '*** gasodesolver_rodas forced dump' + else + write(msg,*) '*** gasodesolver_rodas failure no.', & + nrodas_failures + end if + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = 'iregime, iok, i, j, k / t' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97010) iregime, iok, isvode, jsvode, ksvode + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) trun + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = 'inforodas_cur(1-6) =' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97010) inforodas_cur + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = & + 'tstart, tstop, abs_error, rel_error / temp, press, cair, cos_sza =' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) tstart, tstop, abs_error, rel_error + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) tempbox, pressbox, airdenbox, -99.0 + call peg_debugmsg( lunout, levdbg_err, msg ) + + idum = 0 + do ig = nreact_kppmax, 1, -1 + if ((idum .eq. 0) .and. (rconstkpp(ig) .ne. 0.0)) idum = ig + end do + msg = 'ngas_z, nrconst_nonzero =' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97010) ngas_z, idum + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = 'l, name, cboxold, cboxnew for l=1,ngas_z' + call peg_debugmsg( lunout, levdbg_err, msg ) + do l = 1, ngas_z + write(msg,97030) l, name_z(l), cboxold(l), cboxnew(l) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + msg = 'rconst for i=1,nrconst_nonzero' + call peg_debugmsg( lunout, levdbg_err, msg ) + do ia = 1, idum, 4 + write(msg,97020) ( rconstkpp(ig), ig = ia, min(ia+3,idum) ) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + +97010 format( 6i12 ) +97020 format( 4(1pe18.10) ) +97030 format(( i3, 1x, a, 2(1pe18.10) )) + + +! force non-negative values +20000 do l = 1, ngas_z + cboxnew(l) = max( cboxnew(l), 0.0 ) + end do + + return + end subroutine gasodesolver_rodas + + + +!*********************************************************************** +! < xx.> subr gasodesolver_lsodes +! +! purpose: interface to lsodes ode solver +! +! author : Rahul A. Zaveri +! date : May, 2000 +! +!----------------------------------------------------------------------- + + subroutine gasodesolver_lsodes( tstart, tstop, iok, & + isvode, jsvode, ksvode, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info, & + i_force_dump, iodestatus_count, & + abs_error, rel_error, trun, & + tempbox, pressbox, airdenbox, cboxnew, cboxold, & + rk_m1, rk_m2, rk_m3, rk_m4 ) + + use module_data_cbmz + use module_cbmz_lsodes_solver, only: lsodes_solver, xsetf, & + set_lsodes_common_vars + implicit none + +! subr arguments + integer i, iok, isvode, jsvode, ksvode, i_force_dump, iregime, & + mgaschem, lunerr, lunout, levdbg_err, levdbg_info + integer iodestatus_count(6) + real tstart, tstop, abs_error, rel_error, trun + real tempbox, pressbox, airdenbox + real cboxnew(ngas_z), cboxold(ngas_z) + real rk_m1(nrxn_m1), rk_m2(nrxn_m2), rk_m3(nrxn_m3), rk_m4(nrxn_m4) + +! lsodes parameters and local variables + integer itoler, itask, iopt, mf, lwm, nrdim, nidim + integer nruserpar, niuserpar + parameter( itoler = 1, itask = 1, iopt = 1, mf= 222 ) + parameter( lwm = 3*ngas_tot*ngas_tot + 12*ngas_tot ) + parameter( nrdim = 20 + 9*ngas_tot + lwm ) + parameter( nidim = 31 + ngas_tot + ngas_tot*ngas_tot ) + parameter( nruserpar = 5 + nrxn_m1 + nrxn_m2 + nrxn_m3 + nrxn_m4) + parameter( niuserpar = ngas_z + 1 ) + + integer ia, idum, ig, ioffset, istate, iwork(nidim), l + integer ntotvec(1), iuserpar(niuserpar) + integer indx(ngas_z) + integer, save :: iflagout = 0 + integer, save :: nlsodes_failures = 0 + + real dtchem, rwork(nrdim), stot(ngas_tot) + real atolvec(1), rtolvec(1), ruserpar(nruserpar) + + character*80 msg + + + + iok = 1 ! reset + + call set_lsodes_common_vars() + +! sets gas species indices for iregime + call setgasindices( iregime, indx ) + +! map cboxold --> stot + call mapgasspecies( cboxold, stot, 0, iregime, indx ) + +!---------------------------------------------------------------------- +! set number of species (ntot) for the selected regime for LSODES + if (iregime .eq. 1) then + ntotvec(1) = ngas_r1 + else if (iregime .eq. 2) then + ntotvec(1) = ngas_r2 + else if (iregime .eq. 3) then + ntotvec(1) = ngas_r3 + else if (iregime .eq. 4) then + ntotvec(1) = ngas_r4 + else if (iregime .eq. 5) then + ntotvec(1) = ngas_r5 + else + ntotvec(1) = ngas_r6 + end if + +100 continue + +! set other LSODES parameters... + iwork(6) = 1000 ! max iterations for a time step + iwork(7) = 1 + istate = 1 + rwork(6) = dtchem + if(iflagout.eq.0)then + call xsetf(iflagout) + endif + + atolvec(1) = abs_error + rtolvec(1) = rel_error + + do ig = 1, 5 + ruserpar(ig) = ig*7.0 + end do + ruserpar(1) = cboxold(ih2o_z) + ruserpar(2) = cboxold(ich4_z) + ruserpar(3) = cboxold(io2_z) + ruserpar(4) = cboxold(in2_z) + ruserpar(5) = cboxold(ih2_z) + ioffset = 5 + do ig = 1, nrxn_m1 + ruserpar(ioffset+ig) = rk_m1(ig) + end do + ioffset = ioffset + nrxn_m1 + do ig = 1, nrxn_m2 + ruserpar(ioffset+ig) = rk_m2(ig) + end do + ioffset = ioffset + nrxn_m2 + do ig = 1, nrxn_m3 + ruserpar(ioffset+ig) = rk_m3(ig) + end do + ioffset = ioffset + nrxn_m3 + do ig = 1, nrxn_m4 + ruserpar(ioffset+ig) = rk_m4(ig) + end do + + iuserpar(1) = iregime + do ig = 1, ngas_z + iuserpar(1+ig) = indx(ig) + end do + + call lsodes_solver( & + gasode_cbmz, ntotvec, stot, tstart, tstop, & + itoler, rtolvec, atolvec, itask, istate, iopt, & + rwork, nrdim, iwork, nidim, jcs, mf, & + ruserpar, nruserpar, iuserpar, niuserpar ) + + if (istate .le. 0) iok = -1 + + +! increment odeinfo counters + if (iok .gt. 0) then + ia = 4 + else + ia = 5 + end if + iodestatus_count(ia) = iodestatus_count(ia) + 1 + + +! map stot --> cboxnew + call mapgasspecies( cboxnew, stot, 1, iregime, indx ) + + +! do diagnostic output if integration fails OR if i_force_dump > 0 + if (iok .gt. 0) then + if (i_force_dump .le. 0) goto 20000 + else + nlsodes_failures = nlsodes_failures + 1 + end if + + msg = ' ' + call peg_debugmsg( lunout, levdbg_err, msg ) + if (iok .gt. 0) then + msg = '*** gasodesolver_lsodes forced dump' + else + write(msg,*) '*** gasodesolver_lsodes failure no.', & + nlsodes_failures + end if + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = 'iregime, iok, i, j, k / t' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97010) iregime, iok, isvode, jsvode, ksvode + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) trun + call peg_debugmsg( lunout, levdbg_err, msg ) + if (nlsodes_failures .gt. 1000) then + write(msg,*) '*** exceeded lsodes failure limit =', 1000 + call peg_debugmsg( lunout, levdbg_err, msg ) + call peg_error_fatal( lunerr, msg ) + end if + if (nlsodes_failures .gt. 100) goto 20000 + + write(msg,*) 'istate -', istate + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = & + 'tstart, tstop, abs_error, rel_error / temp, press, cair, cos_sza =' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) tstart, tstop, abs_error, rel_error + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97020) tempbox, pressbox, airdenbox, -99.0 + call peg_debugmsg( lunout, levdbg_err, msg ) + + idum = nrxn_m1 + nrxn_m2 + nrxn_m3 + nrxn_m4 + msg = 'ngas_z, nrconst_m1+m2+m3+m4 =' + call peg_debugmsg( lunout, levdbg_err, msg ) + write(msg,97010) ngas_z, idum + call peg_debugmsg( lunout, levdbg_err, msg ) + msg = 'l, name, cboxold, cboxnew for l=1,ngas_z' + call peg_debugmsg( lunout, levdbg_err, msg ) + do l = 1, ngas_z + write(msg,97030) l, name_z(l), cboxold(l), cboxnew(l) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + msg = 'rconst for i=1,nrconst_nonzero' + call peg_debugmsg( lunout, levdbg_err, msg ) + do ia = 1, nrxn_m1, 4 + write(msg,97020) ( rk_m1(ig), ig = ia, min(ia+3,nrxn_m1) ) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + do ia = 1, nrxn_m2, 4 + write(msg,97020) ( rk_m2(ig), ig = ia, min(ia+3,nrxn_m2) ) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + do ia = 1, nrxn_m3, 4 + write(msg,97020) ( rk_m3(ig), ig = ia, min(ia+3,nrxn_m3) ) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + do ia = 1, nrxn_m4, 4 + write(msg,97020) ( rk_m4(ig), ig = ia, min(ia+3,nrxn_m4) ) + call peg_debugmsg( lunout, levdbg_err, msg ) + end do + +97010 format( 6i12 ) +97020 format( 4(1pe18.10) ) +97030 format(( i3, 1x, a, 2(1pe18.10) )) + + +! force non-negative values +20000 do l = 1, ngas_z + cboxnew(l) = max( cboxnew(l), 0.0 ) + end do + + return + end subroutine gasodesolver_lsodes + + + +!*********************************************************************** +! < 2.> subr selectgasregime +! +! purpose: selects an optimum combination of gas-phase +! mechanisms based on sensitivity of [OH] +! concentrations to some lumped structure +! hydrocarbon groups concentrations and [DMS] +! concentration. +! +! input : cbox = full species concentrations array (mol/cc) +! +! output: iregime = 1 : com +! = 2 : com + urb +! = 3 : com + urb + bio +! = 4 : com + mar +! = 5 : com + urb + mar +! = 6 : com + urb + bio + mar +! ntot = number of gas-phase species in the selected mechanism +! +! author: Rahul A. Zaveri +! date : April 2000 +! +!--------------------------------------------------------------------- + + subroutine selectgasregime( iregime, iregime_forced, cbox, & + igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer iregime, iregime_forced + integer igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 + real cbox(ngas_z) + +! local variables + integer iwork(6) + integer m_m1, m_m2, m_m3, m_m4 + real cut_molecpcc + + + cut_molecpcc = 5.e+6 ! molecules/cc + +! initialize mechanism flags + m_m1 = 1 ! 1 (always) + m_m2 = 0 ! 0 or 1 + m_m3 = 0 ! 0 or 2 + m_m4 = 0 ! 0 or 3 + + if (igaschem_allowed_m2 .gt. 0) then + if (cbox(ipar_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iaone_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(imgly_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ieth_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iolet_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iolei_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ixyl_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(icres_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ito2_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(icro_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iopen_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ionit_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(irooh_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iro2_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(iano2_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(inap_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ixo2_z ) .gt. cut_molecpcc) m_m2 = 1 + if (cbox(ixpar_z ) .gt. cut_molecpcc) m_m2 = 1 + end if + + if (igaschem_allowed_m3 .gt. 0) then + if (cbox(iisop_z ) .gt. cut_molecpcc) m_m3 = 2 + if (cbox(iisoprd_z ) .gt. cut_molecpcc) m_m3 = 2 + if (cbox(iisopp_z ) .gt. cut_molecpcc) m_m3 = 2 + if (cbox(iisopn_z ) .gt. cut_molecpcc) m_m3 = 2 + if (cbox(iisopo2_z ) .gt. cut_molecpcc) m_m3 = 2 + end if + + if (igaschem_allowed_m4 .gt. 0) then + if (cbox(idms_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(imsa_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(idmso_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(idmso2_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3so2h_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3sch2oo_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3so2_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3so3_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3so2oo_z ) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(ich3so2ch2oo_z) .gt. cut_molecpcc) m_m4 = 3 + if (cbox(imtf_z ) .gt. cut_molecpcc) m_m4 = 3 + end if + + iregime = m_m1 + m_m2*((2-m_m3)/2) + m_m3 + m_m4 + +! force iregime = iregime_forced + if ((iregime_forced .ge. 1) .and. (iregime_forced .le. 6)) & + iregime = iregime_forced + + return + end subroutine selectgasregime + + + +!*********************************************************************** +! < 3.> subr setgasindices +! +! purpose: sets gas species indices +! +! author : Rahul A. Zaveri +! date : May, 2000 +! +!----------------------------------------------------------------------- + + subroutine setgasindices( iregime, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer iregime, indx(ngas_z) + +! local variables + integer ilast + + ilast = 0 + indx(:) = -999888777 + + goto (1,2,3,4,5,6), iregime + +1 call setgasindex_m1( ilast, indx ) ! regime 1 + return + +2 call setgasindex_m1( ilast, indx ) ! regime 2 + call setgasindex_m2( ilast, indx ) + return + +3 call setgasindex_m1( ilast, indx ) ! regime 3 + call setgasindex_m2( ilast, indx ) + call setgasindex_m3( ilast, indx ) + return + +4 call setgasindex_m1( ilast, indx ) ! regime 4 + call setgasindex_m4( ilast, indx ) + return + +5 call setgasindex_m1( ilast, indx ) ! regime 5 + call setgasindex_m2( ilast, indx ) + call setgasindex_m4( ilast, indx ) + return + +6 call setgasindex_m1( ilast, indx ) ! regime 6 + call setgasindex_m2( ilast, indx ) + call setgasindex_m3( ilast, indx ) + call setgasindex_m4( ilast, indx ) + return + + end subroutine setgasindices + + + + +!*********************************************************************** +! < 4.> subr gasrateconstants +! +! purpose: calls regime-dependent subrs for calculating +! gas-phase thermal reaction rate constants +! +! author : Rahul A. Zaveri +! date : May, 2000 +! +!----------------------------------------------------------------------- + + subroutine gasrateconstants( iregime, tempbox, cair_mlc, & + rk_photo, rk_param, rk_m1, rk_m2, rk_m3, rk_m4 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer iregime + real tempbox, cair_mlc + real rk_photo(nphoto), rk_param(nperox) + real rk_m1(nrxn_m1), rk_m2(nrxn_m2), rk_m3(nrxn_m3), rk_m4(nrxn_m4) + + +! iregime=1 --> do m1 +! iregime=2 --> do m1, m2 +! iregime=3 --> do m1, m2, m3 +! iregime=4 --> do m1, --, --, m4 +! iregime=5 --> do m1, m2, --, m4 +! iregime=6 --> do m1, m2, m3, m4 + + call gasthermrk_m1( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m1, rk_m2 ) + + if ((iregime .eq. 2) .or. & + (iregime .eq. 3) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasthermrk_m2( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m2 ) + + if ((iregime .eq. 3) .or. & + (iregime .eq. 6)) & + call gasthermrk_m3( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m3 ) + + if ((iregime .eq. 4) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasthermrk_m4( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m4 ) + + return + end subroutine gasrateconstants + + + +!*********************************************************************** +! < 3.> subr setgasindex_m1 +! +! purpose: defines gas species indices for regime 1 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +!----------------------------------------------------------------------- + + subroutine setgasindex_m1( ilast, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer ilast, indx(ngas_z) + + + indx(ino_z) = 1 + indx(ino2_z) = 2 + indx(ino3_z) = 3 + indx(in2o5_z) = 4 + indx(ihono_z) = 5 + indx(ihno3_z) = 6 + indx(ihno4_z) = 7 + indx(io3_z) = 8 + indx(io1d_z) = 9 + indx(io3p_z) = 10 + indx(ioh_z) = 11 + indx(iho2_z) = 12 + indx(ih2o2_z) = 13 + indx(ico_z) = 14 + indx(iso2_z) = 15 + indx(ih2so4_z) = 16 + indx(inh3_z) = 17 + indx(ihcl_z) = 18 + indx(ic2h6_z) = 19 + indx(ich3o2_z) = 20 + indx(iethp_z) = 21 + indx(ihcho_z) = 22 + indx(ich3oh_z) = 23 + indx(ic2h5oh_z) = 24 + indx(ich3ooh_z) = 25 + indx(iethooh_z) = 26 + indx(iald2_z) = 27 + indx(ihcooh_z) = 28 + indx(ircooh_z) = 29 + indx(ic2o3_z) = 30 + indx(ipan_z) = 31 + + ilast = indx(ipan_z) + + return + end subroutine setgasindex_m1 + + + +!*********************************************************************** +! < 4.> subr setgasindex_m2 +! +! purpose: defines gas species indices for regime 2 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +!----------------------------------------------------------------------- + subroutine setgasindex_m2( ilast, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer ilast, indx(ngas_z) + + + indx(ipar_z) = ilast + 1 + indx(iaone_z) = ilast + 2 + indx(imgly_z) = ilast + 3 + indx(ieth_z) = ilast + 4 + indx(iolet_z) = ilast + 5 + indx(iolei_z) = ilast + 6 + indx(itol_z) = ilast + 7 + indx(ixyl_z) = ilast + 8 + indx(icres_z) = ilast + 9 + indx(ito2_z) = ilast + 10 + indx(icro_z) = ilast + 11 + indx(iopen_z) = ilast + 12 + indx(ionit_z) = ilast + 13 +! indx(ipan_z) = ilast + 14 +! indx(ircooh_z) = ilast + 15 + indx(irooh_z) = ilast + 14 +! indx(ic2o3_z) = ilast + 17 + indx(iro2_z) = ilast + 15 + indx(iano2_z) = ilast + 16 + indx(inap_z) = ilast + 17 + indx(ixo2_z) = ilast + 18 + indx(ixpar_z) = ilast + 19 + + ilast = indx(ixpar_z) + + return + end subroutine setgasindex_m2 + + + +!*********************************************************************** +! < 5.> subr setgasindex_m3 +! +! purpose: defines gas species indices for regime 3 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +!----------------------------------------------------------------------- + subroutine setgasindex_m3( ilast, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer ilast, indx(ngas_z) + + + indx(iisop_z) = ilast + 1 + indx(iisoprd_z) = ilast + 2 + indx(iisopp_z) = ilast + 3 + indx(iisopn_z) = ilast + 4 + indx(iisopo2_z) = ilast + 5 + + ilast = indx(iisopo2_z) + + return + end subroutine setgasindex_m3 + + + +!*********************************************************************** +! < 6.> subr setgasindex_m4 +! +! purpose: defines gas species indices for regime 4 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +!----------------------------------------------------------------------- + + subroutine setgasindex_m4( ilast, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer ilast, indx(ngas_z) + + +! + indx(idms_z) = ilast + 1 + indx(imsa_z) = ilast + 2 + indx(idmso_z) = ilast + 3 + indx(idmso2_z) = ilast + 4 + indx(ich3so2h_z) = ilast + 5 + indx(ich3sch2oo_z) = ilast + 6 + indx(ich3so2_z) = ilast + 7 + indx(ich3so3_z) = ilast + 8 + indx(ich3so2oo_z) = ilast + 9 + indx(ich3so2ch2oo_z) = ilast + 10 + indx(imtf_z) = ilast + 11 + + ilast = indx(imtf_z) + + return + end subroutine setgasindex_m4 + + + +!*********************************************************************** +! < 9.> subr mapgasspecies +! +! purpose: map gas species between stot and cbox arrays +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine mapgasspecies( cbox, stot, imap, iregime, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer imap, iregime, indx(ngas_z) + real cbox(ngas_z) + real stot(ngas_tot) +! +! + goto (1,2,3,4,5,6), iregime +! +! +1 call mapgas_m1( cbox, stot, imap, indx ) + return +! +! +2 call mapgas_m1( cbox, stot, imap, indx ) + call mapgas_m2( cbox, stot, imap, indx ) + return +! +! +3 call mapgas_m1( cbox, stot, imap, indx ) + call mapgas_m2( cbox, stot, imap, indx ) + call mapgas_m3( cbox, stot, imap, indx ) + return +! +! +4 call mapgas_m1( cbox, stot, imap, indx ) + call mapgas_m4( cbox, stot, imap, indx ) + return +! +! +5 call mapgas_m1( cbox, stot, imap, indx ) + call mapgas_m2( cbox, stot, imap, indx ) + call mapgas_m4( cbox, stot, imap, indx ) + return +! +! +6 call mapgas_m1( cbox, stot, imap, indx ) + call mapgas_m2( cbox, stot, imap, indx ) + call mapgas_m3( cbox, stot, imap, indx ) + call mapgas_m4( cbox, stot, imap, indx ) + return + + end subroutine mapgasspecies + + + +!*********************************************************************** +! <10.> subr mapgas_m1 +! +! purpose: maps gas species between stot and cbox arrays for mechanism 1 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine mapgas_m1( cbox, stot, imap, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer imap, indx(ngas_z) + real cbox(ngas_z) + real stot(ngas_tot) + + if(imap.eq.0)then ! map cbox --> stot (both molec/cc) + stot(indx(ino_z)) = cbox(ino_z) + stot(indx(ino2_z)) = cbox(ino2_z) + stot(indx(ino3_z)) = cbox(ino3_z) + stot(indx(in2o5_z)) = cbox(in2o5_z) + stot(indx(ihono_z)) = cbox(ihono_z) + stot(indx(ihno3_z)) = cbox(ihno3_z) + stot(indx(ihno4_z)) = cbox(ihno4_z) + stot(indx(io3_z)) = cbox(io3_z) + stot(indx(io1d_z)) = cbox(io1d_z) + stot(indx(io3p_z)) = cbox(io3p_z) + stot(indx(ioh_z)) = cbox(ioh_z) + stot(indx(iho2_z)) = cbox(iho2_z) + stot(indx(ih2o2_z)) = cbox(ih2o2_z) + stot(indx(ico_z)) = cbox(ico_z) + stot(indx(iso2_z)) = cbox(iso2_z) + stot(indx(ih2so4_z)) = cbox(ih2so4_z) + stot(indx(inh3_z)) = cbox(inh3_z) + stot(indx(ihcl_z)) = cbox(ihcl_z) + stot(indx(ic2h6_z)) = cbox(ic2h6_z) + stot(indx(ich3o2_z)) = cbox(ich3o2_z) + stot(indx(iethp_z)) = cbox(iethp_z) + stot(indx(ihcho_z)) = cbox(ihcho_z) + stot(indx(ich3oh_z)) = cbox(ich3oh_z) + stot(indx(ic2h5oh_z)) = cbox(ic2h5oh_z) + stot(indx(ich3ooh_z)) = cbox(ich3ooh_z) + stot(indx(iethooh_z)) = cbox(iethooh_z) + stot(indx(iald2_z)) = cbox(iald2_z) + stot(indx(ihcooh_z)) = cbox(ihcooh_z) + stot(indx(ircooh_z)) = cbox(ircooh_z) + stot(indx(ic2o3_z)) = cbox(ic2o3_z) + stot(indx(ipan_z)) = cbox(ipan_z) +! + else ! map stot --> cbox (both molec/cc) + cbox(ino_z) = stot(indx(ino_z)) + cbox(ino2_z) = stot(indx(ino2_z)) + cbox(ino3_z) = stot(indx(ino3_z)) + cbox(in2o5_z) = stot(indx(in2o5_z)) + cbox(ihono_z) = stot(indx(ihono_z)) + cbox(ihno3_z) = stot(indx(ihno3_z)) + cbox(ihno4_z) = stot(indx(ihno4_z)) + cbox(io3_z) = stot(indx(io3_z)) + cbox(io1d_z) = stot(indx(io1d_z)) + cbox(io3p_z) = stot(indx(io3p_z)) + cbox(ioh_z) = stot(indx(ioh_z)) + cbox(iho2_z) = stot(indx(iho2_z)) + cbox(ih2o2_z) = stot(indx(ih2o2_z)) + cbox(ico_z) = stot(indx(ico_z)) + cbox(iso2_z) = stot(indx(iso2_z)) + cbox(ih2so4_z) = stot(indx(ih2so4_z)) + cbox(inh3_z) = stot(indx(inh3_z)) + cbox(ihcl_z) = stot(indx(ihcl_z)) + cbox(ic2h6_z) = stot(indx(ic2h6_z)) + cbox(ich3o2_z) = stot(indx(ich3o2_z)) + cbox(iethp_z) = stot(indx(iethp_z)) + cbox(ihcho_z) = stot(indx(ihcho_z)) + cbox(ich3oh_z) = stot(indx(ich3oh_z)) + cbox(ic2h5oh_z) = stot(indx(ic2h5oh_z)) + cbox(ich3ooh_z) = stot(indx(ich3ooh_z)) + cbox(iethooh_z) = stot(indx(iethooh_z)) + cbox(iald2_z) = stot(indx(iald2_z)) + cbox(ihcooh_z) = stot(indx(ihcooh_z)) + cbox(ircooh_z) = stot(indx(ircooh_z)) + cbox(ic2o3_z) = stot(indx(ic2o3_z)) + cbox(ipan_z) = stot(indx(ipan_z)) + endif + + return + end subroutine mapgas_m1 + + + +!*********************************************************************** +! <11.> subr mapgas_m2 +! +! purpose: maps gas species between stot and cbox arrays for mechanism 2 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine mapgas_m2( cbox, stot, imap, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer imap, indx(ngas_z) + real cbox(ngas_z) + real stot(ngas_tot) + + if(imap.eq.0)then ! map cbox --> stot (both molec/cc) + stot(indx(ipar_z)) = cbox(ipar_z) + stot(indx(iaone_z)) = cbox(iaone_z) + stot(indx(imgly_z)) = cbox(imgly_z) + stot(indx(ieth_z)) = cbox(ieth_z) + stot(indx(iolet_z)) = cbox(iolet_z) + stot(indx(iolei_z)) = cbox(iolei_z) + stot(indx(itol_z)) = cbox(itol_z) + stot(indx(ixyl_z)) = cbox(ixyl_z) + stot(indx(icres_z)) = cbox(icres_z) + stot(indx(ito2_z)) = cbox(ito2_z) + stot(indx(icro_z)) = cbox(icro_z) + stot(indx(iopen_z)) = cbox(iopen_z) + stot(indx(ionit_z)) = cbox(ionit_z) +! stot(indx(ipan_z)) = cbox(ipan_z) +! stot(indx(ircooh_z)) = cbox(ircooh_z) + stot(indx(irooh_z)) = cbox(irooh_z) +! stot(indx(ic2o3_z)) = cbox(ic2o3_z) + stot(indx(iro2_z)) = cbox(iro2_z) + stot(indx(iano2_z)) = cbox(iano2_z) + stot(indx(inap_z)) = cbox(inap_z) + stot(indx(ixo2_z)) = cbox(ixo2_z) + stot(indx(ixpar_z)) = cbox(ixpar_z) +! + else ! map stot --> cbox (both molec/cc) + cbox(ipar_z) = stot(indx(ipar_z)) + cbox(iaone_z) = stot(indx(iaone_z)) + cbox(imgly_z) = stot(indx(imgly_z)) + cbox(ieth_z) = stot(indx(ieth_z)) + cbox(iolet_z) = stot(indx(iolet_z)) + cbox(iolei_z) = stot(indx(iolei_z)) + cbox(itol_z) = stot(indx(itol_z)) + cbox(ixyl_z) = stot(indx(ixyl_z)) + cbox(icres_z) = stot(indx(icres_z)) + cbox(ito2_z) = stot(indx(ito2_z)) + cbox(icro_z) = stot(indx(icro_z)) + cbox(iopen_z) = stot(indx(iopen_z)) + cbox(ionit_z) = stot(indx(ionit_z)) +! cbox(ipan_z) = stot(indx(ipan_z)) +! cbox(ircooh_z) = stot(indx(ircooh_z)) + cbox(irooh_z) = stot(indx(irooh_z)) +! cbox(ic2o3_z) = stot(indx(ic2o3_z)) + cbox(iro2_z) = stot(indx(iro2_z)) + cbox(iano2_z) = stot(indx(iano2_z)) + cbox(inap_z) = stot(indx(inap_z)) + cbox(ixo2_z) = stot(indx(ixo2_z)) + cbox(ixpar_z) = stot(indx(ixpar_z)) + endif + + return + end subroutine mapgas_m2 + + + +!*********************************************************************** +! <12.> subr mapgas_m3 +! +! purpose: maps gas species between stot and cbox arrays for mechanism 3 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine mapgas_m3( cbox, stot, imap, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer imap, indx(ngas_z) + real cbox(ngas_z) + real stot(ngas_tot) + + if(imap.eq.0)then ! map cbox --> stot (both molec/cc) + stot(indx(iisop_z)) = cbox(iisop_z) + stot(indx(iisoprd_z)) = cbox(iisoprd_z) + stot(indx(iisopp_z)) = cbox(iisopp_z) + stot(indx(iisopn_z)) = cbox(iisopn_z) + stot(indx(iisopo2_z)) = cbox(iisopo2_z) +! + else ! map stot --> cbox (both molec/cc) + cbox(iisop_z) = stot(indx(iisop_z)) + cbox(iisoprd_z) = stot(indx(iisoprd_z)) + cbox(iisopp_z) = stot(indx(iisopp_z)) + cbox(iisopn_z) = stot(indx(iisopn_z)) + cbox(iisopo2_z) = stot(indx(iisopo2_z)) + endif + + return + end subroutine mapgas_m3 + + + +!*********************************************************************** +! <13.> subr mapgas_m4 +! +! purpose: maps gas species between stot and cbox arrays for mechanism 4 +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine mapgas_m4( cbox, stot, imap, indx ) + + use module_data_cbmz + implicit none + +! subr arguments + integer imap, indx(ngas_z) + real cbox(ngas_z) + real stot(ngas_tot) + + if(imap.eq.0)then ! map cbox --> stot (both molec/cc) + stot(indx(idms_z)) = cbox(idms_z) + stot(indx(imsa_z)) = cbox(imsa_z) + stot(indx(idmso_z)) = cbox(idmso_z) + stot(indx(idmso2_z)) = cbox(idmso2_z) + stot(indx(ich3so2h_z)) = cbox(ich3so2h_z) + stot(indx(ich3sch2oo_z)) = cbox(ich3sch2oo_z) + stot(indx(ich3so2_z)) = cbox(ich3so2_z) + stot(indx(ich3so3_z)) = cbox(ich3so3_z) + stot(indx(ich3so2oo_z)) = cbox(ich3so2oo_z) + stot(indx(ich3so2ch2oo_z))= cbox(ich3so2ch2oo_z) + stot(indx(imtf_z)) = cbox(imtf_z) +! + else ! map stot --> cbox (both molec/cc) + cbox(idms_z) = stot(indx(idms_z)) + cbox(imsa_z) = stot(indx(imsa_z)) + cbox(idmso_z) = stot(indx(idmso_z)) + cbox(idmso2_z) = stot(indx(idmso2_z)) + cbox(ich3so2h_z) = stot(indx(ich3so2h_z)) + cbox(ich3sch2oo_z) = stot(indx(ich3sch2oo_z)) + cbox(ich3so2_z) = stot(indx(ich3so2_z)) + cbox(ich3so3_z) = stot(indx(ich3so3_z)) + cbox(ich3so2oo_z) = stot(indx(ich3so2oo_z)) + cbox(ich3so2ch2oo_z)= stot(indx(ich3so2ch2oo_z)) + cbox(imtf_z) = stot(indx(imtf_z)) + endif + + return + end subroutine mapgas_m4 + + + +!*********************************************************************** +! subr check_userpar +! +! purpose: called by lsodes (external) +! computes time derivatives of species concentrations ds/dt. +! by calling subr. gasrate and ode +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!--------------------------------------------------------------------------- + + subroutine check_userpar( ruserpar, nruserpar, iuserpar, niuserpar ) + + use module_data_cbmz + implicit none + +! subr arguments + integer nruserpar, niuserpar + integer iuserpar(niuserpar) + real ruserpar(nruserpar) + +! local variables + integer i + real dum + character*80 msg + + if (nruserpar .ne. (5 + nrxn_m1 + nrxn_m2 + nrxn_m3 + nrxn_m4)) then + write(msg,9010) 'nruserpar', -1, nruserpar + call wrf_error_fatal( msg ) + end if + + if (niuserpar .ne. (ngas_z + 1)) then + write(msg,9010) 'niuserpar', -1, niuserpar + call wrf_error_fatal( msg ) + end if + +9010 format( '*** check_userpar error -- ', a, 1x, i8, 1x, i8 ) + + + return + end subroutine check_userpar + + + +!*********************************************************************** +! <14.> subr gasode_cbmz +! +! purpose: called by lsodes (external) +! computes time derivatives of species concentrations ds/dt. +! by calling subr. gasrate and ode +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!--------------------------------------------------------------------------- + + subroutine gasode_cbmz( ntot, tt, s, sdot, & + ruserpar, nruserpar, iuserpar, niuserpar ) + + use module_data_cbmz + implicit none + +! subr arguments + integer ntot, nruserpar, niuserpar + integer iuserpar(niuserpar) + real tt + real s(ngas_tot), sdot(ngas_tot), ruserpar(nruserpar) + +! local variables + integer ig, ioffset, iregime, irxn + integer indx(ngas_z) + real h2o, ch4, oxygen, nitrogen, hydrogen + real rk_m1(nrxn_m1), r_m1(nrxn_m1) + real rk_m2(nrxn_m2), r_m2(nrxn_m2) + real rk_m3(nrxn_m3), r_m3(nrxn_m3) + real rk_m4(nrxn_m4), r_m4(nrxn_m4) + real p_m1(ngas_tot), d_m1(ngas_tot) + real p_m2(ngas_tot), d_m2(ngas_tot) + real p_m3(ngas_tot), d_m3(ngas_tot) + real p_m4(ngas_tot), d_m4(ngas_tot) + + +! test on userpar + call check_userpar( ruserpar, nruserpar, iuserpar, niuserpar ) + + iregime = iuserpar(1) + do ig = 1, ngas_z + indx(ig) = iuserpar(ig+1) + end do + + h2o = ruserpar(1) + ch4 = ruserpar(2) + oxygen = ruserpar(3) + nitrogen = ruserpar(4) + hydrogen = ruserpar(5) + ioffset = 5 + do ig = 1, nrxn_m1 + rk_m1(ig) = ruserpar(ioffset+ig) + end do + ioffset = ioffset + nrxn_m1 + do ig = 1, nrxn_m2 + rk_m2(ig) = ruserpar(ioffset+ig) + end do + ioffset = ioffset + nrxn_m2 + do ig = 1, nrxn_m3 + rk_m3(ig) = ruserpar(ioffset+ig) + end do + ioffset = ioffset + nrxn_m3 + do ig = 1, nrxn_m4 + rk_m4(ig) = ruserpar(ioffset+ig) + end do + + +! initialize to zero + do irxn=1,nrxn_m1 + r_m1(irxn) = 0. + enddo + + do irxn=1,nrxn_m2 + r_m2(irxn) = 0. + enddo + + do irxn=1,nrxn_m3 + r_m3(irxn) = 0. + enddo + + do irxn=1,nrxn_m4 + r_m4(irxn) = 0. + enddo +! +! +! initialize to zero + do ig=1,ngas_tot + p_m1(ig) = 0. + p_m2(ig) = 0. + p_m3(ig) = 0. + p_m4(ig) = 0. +! + d_m1(ig) = 0. + d_m2(ig) = 0. + d_m3(ig) = 0. + d_m4(ig) = 0. + enddo + + +! iregime=1 --> do m1 +! iregime=2 --> do m1, m2 +! iregime=3 --> do m1, m2, m3 +! iregime=4 --> do m1, --, --, m4 +! iregime=5 --> do m1, m2, --, m4 +! iregime=6 --> do m1, m2, m3, m4 + + call gasrate_m1( indx, s, r_m1, r_m2, rk_m1, rk_m2, & + h2o, ch4, oxygen, nitrogen, hydrogen ) + + if ((iregime .eq. 2) .or. & + (iregime .eq. 3) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasrate_m2( indx, s, r_m2, rk_m2 ) + + if ((iregime .eq. 3) .or. & + (iregime .eq. 6)) & + call gasrate_m3( indx, s, r_m3, rk_m3 ) + + if ((iregime .eq. 4) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasrate_m4( indx, s, r_m4, rk_m4, oxygen ) + + call gasode_m1( indx, r_m1, p_m1, d_m1, r_m2 ) + + if ((iregime .eq. 2) .or. & + (iregime .eq. 3) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasode_m2( indx, r_m2, p_m2, d_m2 ) + + if ((iregime .eq. 3) .or. & + (iregime .eq. 6)) & + call gasode_m3( indx, r_m3, p_m3, d_m3 ) + + if ((iregime .eq. 4) .or. & + (iregime .eq. 5) .or. & + (iregime .eq. 6)) & + call gasode_m4( indx, r_m4, p_m4, d_m4 ) + + + if (iregime .eq. 1) then +! regime = 1 + do ig = 1, ngas_r1 + sdot(ig) = real( dble(p_m1(ig)) - & + dble(d_m1(ig)) ) + end do + + else if (iregime .eq. 2) then +! regime = 2 + do ig = 1, ngas_r2 + sdot(ig) = real( dble(p_m1(ig)+p_m2(ig)) - & + dble(d_m1(ig)+d_m2(ig)) ) + end do + + else if (iregime .eq. 3) then +! regime = 3 + do ig = 1, ngas_r3 + sdot(ig) = real( dble(p_m1(ig)+p_m2(ig)+p_m3(ig)) - & + dble(d_m1(ig)+d_m2(ig)+d_m3(ig)) ) + end do + + else if (iregime .eq. 4) then +! regime = 4 + do ig = 1, ngas_r4 + sdot(ig) = real( dble(p_m1(ig)+p_m4(ig)) - & + dble(d_m1(ig)+d_m4(ig)) ) + end do + + else if (iregime .eq. 5) then +! regime = 5 + do ig = 1, ngas_r5 + sdot(ig) = real( dble(p_m1(ig)+p_m2(ig)+p_m4(ig)) - & + dble(d_m1(ig)+d_m2(ig)+d_m4(ig)) ) + end do + + else if (iregime .eq. 6) then +! regime = 6 + do ig = 1, ngas_r6 + sdot(ig) = real( dble(p_m1(ig)+p_m2(ig)+p_m3(ig)+p_m4(ig)) - & + dble(d_m1(ig)+d_m2(ig)+d_m3(ig)+d_m4(ig)) ) + end do + + end if + + return + end subroutine gasode_cbmz + + + +!*********************************************************************** +! <15.> subr jcs +! +! purpose: external dummy jacobian evaluation for LSODES (when mf=222) +! +!----------------------------------------------------------------------- + + subroutine jcs( ngas, tt, s, j, ian, jan, pdj, & + ruserpar, nruserpar, iuserpar, niuserpar ) + + implicit none + integer ngas, j, ian(*), jan(*), nruserpar, niuserpar + integer iuserpar(niuserpar) + real tt, s(*), pdj(*) + real ruserpar(nruserpar) + +! test on userpar + call check_userpar( ruserpar, nruserpar, iuserpar, niuserpar ) + + return + end subroutine jcs + + + +!*********************************************************************** +! <16.> subr gasode_m1 +! +! purpose: updates production and destruction rates for mechanism 1 +! background troposphere +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine gasode_m1( indx, r_m1, p_m1, d_m1, r_m2 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real r_m1(nrxn_m1), p_m1(ngas_tot), d_m1(ngas_tot) + real r_m2(nrxn_m2) + + + p_m1(indx(ino_z))= r_m1(1)+0.11*r_m1(2) & + +r_m1(3)+r_m1(15)+r_m1(38) + d_m1(indx(ino_z))= r_m1(17)+r_m1(18)+r_m1(23) & + +r_m1(33)+r_m1(37)+r_m1(57) & + +r_m1(58) & + +r_m2(34) +! + p_m1(indx(ino2_z))= 0.89*r_m1(2)+r_m1(4) & + +r_m1(5)+r_m1(6)+r_m1(17) & + +r_m1(18)+r_m1(25) & + +r_m1(26)+r_m1(28) & + +r_m1(33)+r_m1(36) & + +r_m1(37)+r_m1(37) & + +r_m1(38)+r_m1(40) & + +r_m1(40)+.7*r_m1(41) & + +r_m1(43)+r_m1(57) & + +r_m1(58)+r_m1(59) & + +r_m1(60) & + +r_m2(32)+r_m2(34)+r_m2(39) + d_m1(indx(ino2_z))= r_m1(1)+r_m1(15)+r_m1(16) & + +r_m1(19)+r_m1(24) & + +r_m1(34)+r_m1(35) & + +r_m1(38)+r_m1(39) & + +r_m2(31) +! + p_m1(indx(ino3_z))= r_m1(6)+r_m1(16)+r_m1(19) & + +r_m1(27)+r_m1(43) + d_m1(indx(ino3_z))= r_m1(2)+r_m1(25)+r_m1(37) & + +r_m1(38)+r_m1(39) & + +r_m1(40)+r_m1(40) & + +r_m1(41)+r_m1(52) & + +r_m1(59)+r_m1(60) & + +r_m2(4)+r_m2(39) +! + p_m1(indx(in2o5_z))= r_m1(39) + d_m1(indx(in2o5_z))= r_m1(6)+r_m1(42) & + +r_m1(43) +! + p_m1(indx(ihono_z))= r_m1(23)+r_m1(35) + d_m1(indx(ihono_z))= r_m1(3)+r_m1(26) +! + p_m1(indx(ihno3_z))= r_m1(24)+.3*r_m1(41) & + +r_m1(42)+r_m1(42) & + +r_m1(52) & + +r_m2(4) + d_m1(indx(ihno3_z))= r_m1(4)+r_m1(27) +! + p_m1(indx(ihno4_z))= r_m1(34) + d_m1(indx(ihno4_z))= r_m1(5)+r_m1(28) & + +r_m1(36) +! + p_m1(indx(io3_z))= r_m1(13) & + +.4*r_m2(44) + d_m1(indx(io3_z))= r_m1(7)+r_m1(8)+r_m1(14) & + +r_m1(18)+r_m1(19)+r_m1(20) & + +r_m1(21) +! + p_m1(indx(io1d_z))= r_m1(8) + d_m1(indx(io1d_z))= r_m1(10)+r_m1(11) & + +r_m1(12) +! + p_m1(indx(io3p_z))= r_m1(1)+0.89*r_m1(2) & + +r_m1(7)+r_m1(10)+r_m1(11) + d_m1(indx(io3p_z))= r_m1(13)+r_m1(14) & + +r_m1(15)+r_m1(16) & + +r_m1(17) +! + p_m1(indx(ioh_z))= r_m1(3)+r_m1(4)+2*r_m1(9) & + +2*r_m1(12)+r_m1(21) & + +r_m1(33)+.7*r_m1(41) & + +r_m1(53)+r_m1(54)+.3*r_m1(55) & + +.5*r_m1(56) + d_m1(indx(ioh_z))= r_m1(20)+r_m1(22)+r_m1(23) & + +r_m1(24)+r_m1(25)+r_m1(26) & + +r_m1(27)+r_m1(28)+r_m1(29) & + +r_m1(30)+r_m1(44)+r_m1(45) & + +r_m1(46)+r_m1(47)+r_m1(48) & + +r_m1(51)+r_m1(55)+r_m1(56) & + +r_m1(65) & + +r_m2(3) +! + p_m1(indx(iho2_z))= r_m1(5)+r_m1(20)+r_m1(22) & + +r_m1(25)+r_m1(30) & + +r_m1(36)+r_m1(44) & + +r_m1(45)+r_m1(48) & + +2*r_m1(49)+r_m1(51) & + +r_m1(52)+r_m1(53) & + +r_m1(54)+r_m1(57) & + +r_m1(58)+r_m1(59) & + +r_m1(60)+.32*r_m1(63) & + +.6*r_m1(64)+r_m1(65) & + +r_m2(2) + d_m1(indx(iho2_z))= r_m1(21)+r_m1(29) & + +r_m1(31)+r_m1(31) & + +r_m1(32)+r_m1(32) & + +r_m1(33)+r_m1(34) & + +r_m1(35)+r_m1(41) & + +r_m1(61)+r_m1(62) & + +r_m2(44) +! + p_m1(indx(ih2o2_z))= r_m1(31)+r_m1(32) + d_m1(indx(ih2o2_z))= r_m1(9)+r_m1(30) +! + p_m1(indx(ico_z))= r_m1(49)+r_m1(50)+r_m1(51) & + +r_m1(52) & + +r_m2(2) + d_m1(indx(ico_z))= r_m1(44) +! + p_m1(indx(iso2_z))= 0.0 + d_m1(indx(iso2_z))= r_m1(45) +! + p_m1(indx(ih2so4_z))= r_m1(45) + d_m1(indx(ih2so4_z))= 0.0 +! + p_m1(indx(inh3_z))= 0.0 + d_m1(indx(inh3_z))= 0.0 +! + p_m1(indx(ihcl_z))= 0.0 + d_m1(indx(ihcl_z))= 0.0 +! + p_m1(indx(ic2h6_z))= .2*r_m1(64) + d_m1(indx(ic2h6_z))= r_m1(47) +! + p_m1(indx(ich3o2_z))= r_m1(46)+.7*r_m1(55) & + +r_m2(2)+r_m2(34)+r_m2(39)+r_m2(49) + d_m1(indx(ich3o2_z))= r_m1(57)+r_m1(59) & + +r_m1(61)+r_m1(63) +! + p_m1(indx(iethp_z))= r_m1(47)+.5*r_m1(56) + d_m1(indx(iethp_z))= r_m1(58)+r_m1(60) & + +r_m1(62)+r_m1(64) +! + p_m1(indx(ihcho_z))= r_m1(48)+r_m1(53) & + +.3*r_m1(55)+r_m1(57) & + +r_m1(59)+.66*r_m1(63) + d_m1(indx(ihcho_z))= r_m1(49)+r_m1(50) & + +r_m1(51)+r_m1(52) +! + p_m1(indx(ich3oh_z))= .34*r_m1(63) + d_m1(indx(ich3oh_z))= r_m1(48) +! + p_m1(indx(ic2h5oh_z))= 0.0 + d_m1(indx(ic2h5oh_z))= r_m1(65) +! + p_m1(indx(ich3ooh_z))= r_m1(61) + d_m1(indx(ich3ooh_z))= r_m1(53)+r_m1(55) +! + p_m1(indx(iethooh_z))= r_m1(62) + d_m1(indx(iethooh_z))= r_m1(54)+r_m1(56) +! + p_m1(indx(iald2_z))= r_m1(54)+.5*r_m1(56) & + +r_m1(58)+r_m1(60) & + +.8*r_m1(64)+r_m1(65) + d_m1(indx(iald2_z))= r_m2(2)+r_m2(3)+r_m2(4) +! + p_m1(indx(ihcooh_z))= 0.0 + d_m1(indx(ihcooh_z))= 0.0 +! + p_m1(indx(ircooh_z))= .4*r_m2(44) + d_m1(indx(ircooh_z))= 0.0 +! + p_m1(indx(ic2o3_z))= r_m2(3)+r_m2(4)+r_m2(32) + d_m1(indx(ic2o3_z))= r_m2(31)+r_m2(34)+r_m2(39)+r_m2(44)+r_m2(49) +! + p_m1(indx(ipan_z))= r_m2(31) + d_m1(indx(ipan_z))= r_m2(32) + + return + end subroutine gasode_m1 + + + +!*********************************************************************** +! <17.> subr gasode_m2 +! +! purpose: updates production and destruction rates for mechanism 2 +! anthropogenic hydrocarbons +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine gasode_m2( indx, r_m2, p_m2, d_m2 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real r_m2(nrxn_m2), p_m2(ngas_tot), d_m2(ngas_tot) + + + p_m2(indx(ino_z))= 0.0 + d_m2(indx(ino_z))= r_m2(20)+r_m2(33) +r_m2(35) & + +r_m2(36)+r_m2(37) +! + p_m2(indx(ino2_z))= .95*r_m2(20)+r_m2(30) +.84*r_m2(33) & + +r_m2(35)+1.5*r_m2(36)+r_m2(37) & + +r_m2(38) +r_m2(40)+1.5*r_m2(41)+r_m2(42) & + +.5*r_m2(51) + d_m2(indx(ino2_z))= r_m2(23) +! + p_m2(indx(ino3_z))= 0.0 + d_m2(indx(ino3_z))= +r_m2(9)+r_m2(16)+r_m2(17)+r_m2(22) & + +r_m2(38) +r_m2(40)+r_m2(41)+r_m2(42) +! + p_m2(indx(ihno3_z))= +r_m2(9)+r_m2(22) + d_m2(indx(ihno3_z))= 0.0 +! + p_m2(indx(io3_z))= 0.0 + d_m2(indx(io3_z))= r_m2(10)+r_m2(12)+r_m2(13)+r_m2(26) +! + p_m2(indx(ioh_z))= .12*r_m2(10)+.33*r_m2(12)+.60*r_m2(13) & + +.08*r_m2(26)+r_m2(27)+.23*r_m2(28) + d_m2(indx(ioh_z))= r_m2(1) +r_m2(6)+r_m2(8)+r_m2(11) & + +r_m2(14)+r_m2(15)+r_m2(18)+r_m2(19)+r_m2(21) & + +r_m2(24)+r_m2(28)+r_m2(29) +! + p_m2(indx(iho2_z))= +r_m2(7)+.22*r_m2(10)+r_m2(11) & + +.26*r_m2(12)+.22*r_m2(13)+r_m2(14)+r_m2(15) & + +.2*r_m2(18)+.55*r_m2(19)+.95*r_m2(20) & + +.6*r_m2(21)+2*r_m2(24)+r_m2(25)+.76*r_m2(26) & + +.9*r_m2(27)+.9*r_m2(30)+.76*r_m2(33)+.5*r_m2(36) & + +.9*r_m2(38)+.5*r_m2(41)+.54*r_m2(48) + d_m2(indx(iho2_z))= r_m2(43) +r_m2(45)+r_m2(46)+r_m2(47) +! + p_m2(indx(ico_z))= +r_m2(7)+r_m2(9)+.24*r_m2(10) & + +.31*r_m2(12)+.30*r_m2(13)+2*r_m2(24)+r_m2(25) & + +.69*r_m2(26) + d_m2(indx(ico_z))= 0.0 +! + p_m2(indx(ipar_z))= 1.1*r_m2(19) + d_m2(indx(ipar_z))= r_m2(1) + r_m2(53) +! + p_m2(indx(ich3oh_z))= .03*r_m2(12)+.04*r_m2(13) + d_m2(indx(ich3oh_z))= 0.0 +! + p_m2(indx(ihcho_z))= r_m2(10)+1.56*r_m2(11)+.57*r_m2(12)+r_m2(14) & + +r_m2(24)+.7*r_m2(26)+r_m2(35)+.5*r_m2(36) & + +r_m2(40)+.5*r_m2(41)+.7*r_m2(50)+.5*r_m2(51) + d_m2(indx(ihcho_z))= 0.0 +! + p_m2(indx(iald2_z))= .22*r_m2(11)+.47*r_m2(12)+1.03*r_m2(13) & + +r_m2(14)+1.77*r_m2(15)+.03*r_m2(26)+.3*r_m2(27) & + +.04*r_m2(28)+.3*r_m2(30)+.25*r_m2(33)+.5*r_m2(36) & + +.3*r_m2(38)+.5*r_m2(41)+.21*r_m2(48)+.5*r_m2(51) + d_m2(indx(iald2_z))= 0.0 +! + p_m2(indx(ihcooh_z))= .52*r_m2(10)+.22*r_m2(12) + d_m2(indx(ihcooh_z))= 0.0 +! + p_m2(indx(iaone_z))= .07*r_m2(13)+.23*r_m2(15)+.74*r_m2(27) & + +.74*r_m2(30)+.62*r_m2(33)+.74*r_m2(38) & + +.57*r_m2(48)+.15*r_m2(50) + d_m2(indx(iaone_z))= r_m2(5)+r_m2(6) +! + p_m2(indx(imgly_z))= .04*r_m2(12)+.07*r_m2(13)+.8*r_m2(19) & + +.2*r_m2(26)+.19*r_m2(28)+.15*r_m2(50) + d_m2(indx(imgly_z))= r_m2(7)+r_m2(8)+r_m2(9) +! + p_m2(indx(ieth_z))= 0.0 + d_m2(indx(ieth_z))= r_m2(10)+r_m2(11) +! + p_m2(indx(iolet_z))= 0.0 + d_m2(indx(iolet_z))= r_m2(12)+r_m2(14)+r_m2(16) +! + p_m2(indx(iolei_z))= 0.0 + d_m2(indx(iolei_z))= r_m2(13)+r_m2(15)+r_m2(17) +! + p_m2(indx(itol_z))= 0.0 + d_m2(indx(itol_z))= r_m2(18) +! + p_m2(indx(ixyl_z))= 0.0 + d_m2(indx(ixyl_z))= r_m2(19) +! + p_m2(indx(icres_z))= .12*r_m2(18)+.05*r_m2(19) + d_m2(indx(icres_z))= r_m2(21)+r_m2(22) +! + p_m2(indx(ito2_z))= .8*r_m2(18)+.45*r_m2(19) + d_m2(indx(ito2_z))= r_m2(20) +! + p_m2(indx(icro_z))= .4*r_m2(21)+r_m2(22) + d_m2(indx(icro_z))= r_m2(23) +! + p_m2(indx(iopen_z))= .95*r_m2(20)+.3*r_m2(21) + d_m2(indx(iopen_z))= r_m2(24)+r_m2(25)+r_m2(26) +! + p_m2(indx(ionit_z))= .05*r_m2(20)+r_m2(23)+.16*r_m2(33) & + +.5*r_m2(36)+.5*r_m2(41)+r_m2(46)+.5*r_m2(51) + d_m2(indx(ionit_z))= r_m2(29)+r_m2(30) +! + p_m2(indx(ipan_z))= 0.0 + d_m2(indx(ipan_z))= 0.0 +! + p_m2(indx(ircooh_z))= .09*r_m2(12)+.16*r_m2(13) + d_m2(indx(ircooh_z))= 0.0 +! + p_m2(indx(irooh_z))= r_m2(43)+r_m2(45) + d_m2(indx(irooh_z))= r_m2(27)+r_m2(28) +! + p_m2(indx(ich3o2_z))= +r_m2(5)+.07*r_m2(12)+.10*r_m2(13) + d_m2(indx(ich3o2_z))= 0.0 +! + p_m2(indx(iethp_z))= .06*r_m2(12)+.05*r_m2(13)+.1*r_m2(27) & + +.1*r_m2(30)+.08*r_m2(33)+.1*r_m2(38)+.06*r_m2(48) + d_m2(indx(iethp_z))= 0.0 +! + p_m2(indx(ic2o3_z))= +r_m2(5)+r_m2(7)+r_m2(8) & + +r_m2(9)+.13*r_m2(12)+.19*r_m2(13)+r_m2(24) & + +r_m2(25)+.62*r_m2(26) +r_m2(35) & + +r_m2(40)+.7*r_m2(50) + d_m2(indx(ic2o3_z))= 0.0 +! + p_m2(indx(iro2_z))= r_m2(1)+.03*r_m2(12)+.09*r_m2(13)+.77*r_m2(28) + d_m2(indx(iro2_z))= r_m2(33)+r_m2(38)+r_m2(43)+r_m2(48) +! + p_m2(indx(iano2_z))= r_m2(6)+.11*r_m2(13) + d_m2(indx(iano2_z))= r_m2(35)+r_m2(40)+r_m2(45)+r_m2(50) +! + p_m2(indx(inap_z))= r_m2(16)+r_m2(17)+r_m2(29) + d_m2(indx(inap_z))= r_m2(36)+r_m2(41)+r_m2(46)+r_m2(51) +! + p_m2(indx(ixo2_z))= r_m2(8)+r_m2(11)+r_m2(14)+r_m2(15) & + +.08*r_m2(18)+.5*r_m2(19)+.6*r_m2(21) & + +r_m2(24)+.03*r_m2(26)+.4*r_m2(27)+.4*r_m2(30) & + +.34*r_m2(33)+.4*r_m2(38)+.24*r_m2(48) + d_m2(indx(ixo2_z))= r_m2(37)+r_m2(42)+r_m2(47)+r_m2(52) + + p_m2(indx(ixpar_z))= 1.06*r_m2(12)+2.26*r_m2(13)+r_m2(14) & + +2.23*r_m2(15)+1.98*r_m2(27)+.42*r_m2(28) & + +1.98*r_m2(30)+1.68*r_m2(33)+r_m2(36) & + +1.98*r_m2(38)+r_m2(41)+1.25*r_m2(48)+r_m2(51) + d_m2(indx(ixpar_z))= r_m2(53) +! + return + end subroutine gasode_m2 + + + +!*********************************************************************** +! <18.> subr gasode_m3 +! +! purpose: updates production and destruction rates for mechanism 3 +! isoprene +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine gasode_m3( indx, r_m3, p_m3, d_m3 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real r_m3(nrxn_m3), p_m3(ngas_tot), d_m3(ngas_tot) + + + p_m3(indx(ino_z))= 0.0 + d_m3(indx(ino_z))= r_m3(8)+r_m3(9)+r_m3(10) +! + p_m3(indx(ino2_z))= .91*r_m3(8)+1.2*r_m3(9)+r_m3(10) + d_m3(indx(ino2_z))= 0.0 +! + p_m3(indx(ino3_z))= 0.0 + d_m3(indx(ino3_z))= r_m3(3)+r_m3(7) +! + p_m3(indx(ihno3_z))= .07*r_m3(7) + d_m3(indx(ihno3_z))= 0.0 +! + p_m3(indx(io3_z))= 0.0 + d_m3(indx(io3_z))= r_m3(2)+r_m3(6) +! + p_m3(indx(ioh_z))= .27*r_m3(2)+.27*r_m3(6) + d_m3(indx(ioh_z))= r_m3(1)+r_m3(5) +! + p_m3(indx(iho2_z))= .07*r_m3(2)+.33*r_m3(4)+.1*r_m3(6)+.93*r_m3(7) & + +.91*r_m3(8)+.8*r_m3(9)+r_m3(10) + d_m3(indx(iho2_z))= r_m3(11)+r_m3(12)+r_m3(13) +! + p_m3(indx(ico_z))= .07*r_m3(2)+.33*r_m3(4)+.16*r_m3(6)+.64*r_m3(7) & + +.59*r_m3(10) + d_m3(indx(ico_z))= 0.0 +! + p_m3(indx(ipar_z))= 1.86*r_m3(7)+0.18*r_m3(8)+1.6*r_m3(9)+2*r_m3(12) & + +2*r_m3(15) + d_m3(indx(ipar_z))= 0.0 +! + p_m3(indx(ihcho_z))= .6*r_m3(2)+.2*r_m3(4)+.15*r_m3(6)+.28*r_m3(7) & + +.63*r_m3(8)+.25*r_m3(10) + d_m3(indx(ihcho_z))= 0.0 +! + p_m3(indx(iald2_z))= .15*r_m3(2)+.07*r_m3(4)+.02*r_m3(6)+.28*r_m3(7) & + +.8*r_m3(9)+.55*r_m3(10)+r_m3(15)+.5*r_m3(16) + d_m3(indx(iald2_z))= 0.0 +! + p_m3(indx(iaone_z))= .03*r_m3(4)+.09*r_m3(6)+.63*r_m3(10)+.5*r_m3(16) + d_m3(indx(iaone_z))= 0.0 +! + p_m3(indx(imgly_z))= .85*r_m3(6)+.34*r_m3(10) + d_m3(indx(imgly_z))= 0.0 +! + p_m3(indx(ionit_z))= .93*r_m3(7)+.09*r_m3(8)+.8*r_m3(9)+r_m3(12) & + +r_m3(15) + d_m3(indx(ionit_z))= 0.0 +! + p_m3(indx(ihcooh_z))= .39*r_m3(2)+.46*r_m3(6) + d_m3(indx(ihcooh_z))= 0.0 +! + p_m3(indx(irooh_z))= r_m3(11)+r_m3(13) + d_m3(indx(irooh_z))= 0.0 +! + p_m3(indx(ich3o2_z))= .7*r_m3(4)+.05*r_m3(6) + d_m3(indx(ich3o2_z))= 0.0 +! + p_m3(indx(ic2o3_z))= .2*r_m3(2)+.97*r_m3(4)+.5*r_m3(5)+.11*r_m3(6) & + +.07*r_m3(7) + d_m3(indx(ic2o3_z))= 0.0 +! + p_m3(indx(ixo2_z))= .08*r_m3(1)+.2*r_m3(2)+.2*r_m3(5)+.07*r_m3(6) & + +.93*r_m3(7) + d_m3(indx(ixo2_z))= 0.0 +! + p_m3(indx(iisop_z))= 0.0 + d_m3(indx(iisop_z))= r_m3(1)+r_m3(2)+r_m3(3) +! + p_m3(indx(iisoprd_z))= .65*r_m3(2)+.91*r_m3(8)+.2*r_m3(9)+r_m3(14) + d_m3(indx(iisoprd_z))= r_m3(4)+r_m3(5)+r_m3(6)+r_m3(7) +! + p_m3(indx(iisopp_z))= r_m3(1) + d_m3(indx(iisopp_z))= r_m3(8)+r_m3(11)+r_m3(14) +! + p_m3(indx(iisopn_z))= r_m3(3) + d_m3(indx(iisopn_z))= r_m3(9)+r_m3(12)+r_m3(15) +! + p_m3(indx(iisopo2_z))= .5*r_m3(5) + d_m3(indx(iisopo2_z))= r_m3(10)+r_m3(13)+r_m3(16) +! + return + end subroutine gasode_m3 + + + +!*********************************************************************** +! <19.> subr gasode_m4 +! +! purpose: updates production and destruction rates for mechanism 4 +! dimethylsulfide +! +! author : Rahul A. Zaveri +! date : December, 1998 +! +! ---------------------------------------------------------------------- + + subroutine gasode_m4( indx, r_m4, p_m4, d_m4 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real r_m4(nrxn_m4), p_m4(ngas_tot), d_m4(ngas_tot) + + + p_m4(indx(ino_z))= r_m4(19) + d_m4(indx(ino_z))= r_m4(5)+r_m4(11)+r_m4(26)+r_m4(30) +! + p_m4(indx(ino2_z))= r_m4(5)+r_m4(11)+r_m4(26) + d_m4(indx(ino2_z))= r_m4(19)+r_m4(29) +! + p_m4(indx(ino3_z))= 0.0 + d_m4(indx(ino3_z))= r_m4(2)+r_m4(14) +! + p_m4(indx(ihono_z))= r_m4(30) + d_m4(indx(ihono_z))= 0.0 +! + p_m4(indx(ihno3_z))= r_m4(2)+r_m4(14)+r_m4(29) + d_m4(indx(ihno3_z))= 0.0 +! + p_m4(indx(io3_z))= 0.0 + d_m4(indx(io3_z))= r_m4(20) +! + p_m4(indx(io3p_z))= 0.0 + d_m4(indx(io3p_z))= r_m4(3) +! + p_m4(indx(ioh_z))= r_m4(21) + d_m4(indx(ioh_z))= r_m4(1)+r_m4(4)+r_m4(9)+r_m4(10)+r_m4(16)+r_m4(23) +! + p_m4(indx(iho2_z))= .965*r_m4(4)+r_m4(6)+.27*r_m4(9)+r_m4(12)+r_m4(22) & + +r_m4(27)+r_m4(32) + d_m4(indx(iho2_z))= r_m4(13)+r_m4(21)+r_m4(31) +! + p_m4(indx(ih2o2_z))= r_m4(13) + d_m4(indx(ih2o2_z))= 0.0 +! + p_m4(indx(ico_z))= r_m4(32) + d_m4(indx(ico_z))= 0.0 +! + p_m4(indx(iso2_z))= r_m4(18) + d_m4(indx(iso2_z))= 0.0 +! + p_m4(indx(ih2so4_z))= r_m4(28) + d_m4(indx(ih2so4_z))= 0.0 +! + p_m4(indx(ihcho_z))= r_m4(5)+2*r_m4(6)+r_m4(7)+r_m4(11)+2*r_m4(12) & + +r_m4(22)+r_m4(27) + d_m4(indx(ihcho_z))= r_m4(32) +! + p_m4(indx(ich3o2_z))= r_m4(3)+.035*r_m4(4)+.73*r_m4(9)+r_m4(18)+r_m4(28) + d_m4(indx(ich3o2_z))= r_m4(6)+r_m4(12)+r_m4(15)+r_m4(22)+r_m4(27) +! + p_m4(indx(ich3ooh_z))= r_m4(15) + d_m4(indx(ich3ooh_z))= 0.0 +! + p_m4(indx(idms_z))= 0.0 + d_m4(indx(idms_z))= r_m4(1)+r_m4(2)+r_m4(3)+r_m4(4) +! + p_m4(indx(imsa_z))= r_m4(17)+r_m4(23)+r_m4(29)+r_m4(30)+r_m4(31)+r_m4(32) + d_m4(indx(imsa_z))= 0.0 +! + p_m4(indx(idmso_z))= .965*r_m4(4) + d_m4(indx(idmso_z))= r_m4(9) +! + p_m4(indx(idmso2_z))= .27*r_m4(9) + d_m4(indx(idmso2_z))= r_m4(10) +! + p_m4(indx(ich3so2h_z))= .73*r_m4(9) + d_m4(indx(ich3so2h_z))= r_m4(13)+r_m4(14)+r_m4(15)+r_m4(16)+r_m4(17) +! + p_m4(indx(ich3sch2oo_z))= r_m4(1)+r_m4(2) + d_m4(indx(ich3sch2oo_z))= r_m4(5)+r_m4(6)+r_m4(7)+r_m4(8)+r_m4(8) +! + p_m4(indx(ich3so2_z))= r_m4(3)+.035*r_m4(4)+r_m4(5)+r_m4(6)+r_m4(7) & + +1.85*r_m4(8) & + +r_m4(11)+r_m4(12)+r_m4(13)+r_m4(14)+r_m4(15) & + +r_m4(16)+r_m4(17)+r_m4(25) + d_m4(indx(ich3so2_z))= r_m4(7)+r_m4(18)+r_m4(19)+r_m4(20)+r_m4(21) & + +r_m4(22)+r_m4(23)+r_m4(24) +! + p_m4(indx(ich3so3_z))= r_m4(7)+r_m4(19)+r_m4(20)+r_m4(21)+r_m4(22) & + +r_m4(26)+r_m4(27) + d_m4(indx(ich3so3_z))= r_m4(17)+r_m4(28)+r_m4(29)+r_m4(30)+r_m4(31) & + +r_m4(32) +! + p_m4(indx(ich3so2oo_z))= r_m4(24) + d_m4(indx(ich3so2oo_z))= r_m4(25)+r_m4(26)+r_m4(27) +! + p_m4(indx(ich3so2ch2oo_z))= r_m4(10) + d_m4(indx(ich3so2ch2oo_z))= r_m4(11)+r_m4(12) +! + p_m4(indx(imtf_z))= .15*r_m4(8) + d_m4(indx(imtf_z))= 0.0 +! + return + end subroutine gasode_m4 + + + +!*********************************************************************** +! <20.> subr gasrate_m1 +! +! purpose: computes reaction rates for mechanism 1 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- + + subroutine gasrate_m1( indx, s, r_m1, r_m2, rk_m1, rk_m2, & + h2o, ch4, oxygen, nitrogen, hydrogen ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real s(ngas_tot), r_m1(nrxn_m1), r_m2(nrxn_m2) + real rk_m1(nrxn_m1), rk_m2(nrxn_m2) + real h2o, ch4, oxygen, nitrogen, hydrogen + + r_m1(1) = rk_m1(1)*s(indx(ino2_z)) + r_m1(2) = rk_m1(2)*s(indx(ino3_z)) + r_m1(3) = rk_m1(3)*s(indx(ihono_z)) + r_m1(4) = rk_m1(4)*s(indx(ihno3_z)) + r_m1(5) = rk_m1(5)*s(indx(ihno4_z)) + r_m1(6) = rk_m1(6)*s(indx(in2o5_z)) + r_m1(7) = rk_m1(7)*s(indx(io3_z)) + r_m1(8) = rk_m1(8)*s(indx(io3_z)) + r_m1(9) = rk_m1(9)*s(indx(ih2o2_z)) + r_m1(10) = rk_m1(10)*s(indx(io1d_z))*oxygen + r_m1(11) = rk_m1(11)*s(indx(io1d_z))*nitrogen + r_m1(12) = rk_m1(12)*s(indx(io1d_z))*h2o + r_m1(13) = rk_m1(13)*s(indx(io3p_z))*oxygen + r_m1(14) = rk_m1(14)*s(indx(io3p_z))*s(indx(io3_z)) + r_m1(15) = rk_m1(15)*s(indx(io3p_z))*s(indx(ino2_z)) + r_m1(16) = rk_m1(16)*s(indx(io3p_z))*s(indx(ino2_z)) + r_m1(17) = rk_m1(17)*s(indx(io3p_z))*s(indx(ino_z)) + r_m1(18) = rk_m1(18)*s(indx(io3_z))*s(indx(ino_z)) + r_m1(19) = rk_m1(19)*s(indx(io3_z))*s(indx(ino2_z)) + r_m1(20) = rk_m1(20)*s(indx(io3_z))*s(indx(ioh_z)) + r_m1(21) = rk_m1(21)*s(indx(io3_z))*s(indx(iho2_z)) + r_m1(22) = rk_m1(22)*s(indx(ioh_z))*hydrogen + r_m1(23) = rk_m1(23)*s(indx(ioh_z))*s(indx(ino_z)) + r_m1(24) = rk_m1(24)*s(indx(ioh_z))*s(indx(ino2_z)) + r_m1(25) = rk_m1(25)*s(indx(ioh_z))*s(indx(ino3_z)) + r_m1(26) = rk_m1(26)*s(indx(ioh_z))*s(indx(ihono_z)) + r_m1(27) = rk_m1(27)*s(indx(ioh_z))*s(indx(ihno3_z)) + r_m1(28) = rk_m1(28)*s(indx(ioh_z))*s(indx(ihno4_z)) + r_m1(29) = rk_m1(29)*s(indx(ioh_z))*s(indx(iho2_z)) + r_m1(30) = rk_m1(30)*s(indx(ioh_z))*s(indx(ih2o2_z)) + r_m1(31) = rk_m1(31)*s(indx(iho2_z))*s(indx(iho2_z)) + r_m1(32) = rk_m1(32)*s(indx(iho2_z))*s(indx(iho2_z))*h2o + r_m1(33) = rk_m1(33)*s(indx(iho2_z))*s(indx(ino_z)) + r_m1(34) = rk_m1(34)*s(indx(iho2_z))*s(indx(ino2_z)) + r_m1(35) = rk_m1(35)*s(indx(iho2_z))*s(indx(ino2_z)) + r_m1(36) = rk_m1(36)*s(indx(ihno4_z)) + r_m1(37) = rk_m1(37)*s(indx(ino3_z))*s(indx(ino_z)) + r_m1(38) = rk_m1(38)*s(indx(ino3_z))*s(indx(ino2_z)) + r_m1(39) = rk_m1(39)*s(indx(ino3_z))*s(indx(ino2_z)) + r_m1(40) = rk_m1(40)*s(indx(ino3_z))*s(indx(ino3_z)) + r_m1(41) = rk_m1(41)*s(indx(ino3_z))*s(indx(iho2_z)) + r_m1(42) = rk_m1(42)*s(indx(in2o5_z))*h2o + r_m1(43) = rk_m1(43)*s(indx(in2o5_z)) + r_m1(44) = rk_m1(44)*s(indx(ico_z))*s(indx(ioh_z)) + r_m1(45) = rk_m1(45)*s(indx(iso2_z))*s(indx(ioh_z)) + r_m1(46) = rk_m1(46)*s(indx(ioh_z))*ch4 + r_m1(47) = rk_m1(47)*s(indx(ic2h6_z))*s(indx(ioh_z)) + r_m1(48) = rk_m1(48)*s(indx(ich3oh_z))*s(indx(ioh_z)) + r_m1(49) = rk_m1(49)*s(indx(ihcho_z)) + r_m1(50) = rk_m1(50)*s(indx(ihcho_z)) + r_m1(51) = rk_m1(51)*s(indx(ihcho_z))*s(indx(ioh_z)) + r_m1(52) = rk_m1(52)*s(indx(ihcho_z))*s(indx(ino3_z)) + r_m1(53) = rk_m1(53)*s(indx(ich3ooh_z)) + r_m1(54) = rk_m1(54)*s(indx(iethooh_z)) + r_m1(55) = rk_m1(55)*s(indx(ich3ooh_z))*s(indx(ioh_z)) + r_m1(56) = rk_m1(56)*s(indx(iethooh_z))*s(indx(ioh_z)) + r_m1(57) = rk_m1(57)*s(indx(ich3o2_z))*s(indx(ino_z)) + r_m1(58) = rk_m1(58)*s(indx(iethp_z))*s(indx(ino_z)) + r_m1(59) = rk_m1(59)*s(indx(ich3o2_z))*s(indx(ino3_z)) + r_m1(60) = rk_m1(60)*s(indx(iethp_z))*s(indx(ino3_z)) + r_m1(61) = rk_m1(61)*s(indx(ich3o2_z))*s(indx(iho2_z)) + r_m1(62) = rk_m1(62)*s(indx(iethp_z))*s(indx(iho2_z)) + r_m1(63) = rk_m1(63)*s(indx(ich3o2_z)) + r_m1(64) = rk_m1(64)*s(indx(iethp_z)) + r_m1(65) = rk_m1(65)*s(indx(ic2h5oh_z))*s(indx(ioh_z)) + + r_m2(2) = rk_m2(2)*s(indx(iald2_z)) + r_m2(3) = rk_m2(3)*s(indx(iald2_z))*s(indx(ioh_z)) + r_m2(4) = rk_m2(4)*s(indx(iald2_z))*s(indx(ino3_z)) + r_m2(31) = rk_m2(31)*s(indx(ic2o3_z))*s(indx(ino2_z)) + r_m2(32) = rk_m2(32)*s(indx(ipan_z)) + r_m2(34) = rk_m2(34)*s(indx(ic2o3_z))*s(indx(ino_z)) + r_m2(39) = rk_m2(39)*s(indx(ic2o3_z))*s(indx(ino3_z)) + r_m2(44) = rk_m2(44)*s(indx(ic2o3_z))*s(indx(iho2_z)) + r_m2(49) = rk_m2(49)*s(indx(ic2o3_z)) + + return + end subroutine gasrate_m1 + + + +!*********************************************************************** +! <21.> subr gasrate_m2 +! +! purpose: computes reaction rates for mechanism 2 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- +! + subroutine gasrate_m2( indx, s, r_m2, rk_m2 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real s(ngas_tot), r_m2(nrxn_m2), rk_m2(nrxn_m2) + + r_m2(1) = rk_m2(1)*s(indx(ipar_z))*s(indx(ioh_z)) + + r_m2(5) = rk_m2(5)*s(indx(iaone_z)) + r_m2(6) = rk_m2(6)*s(indx(iaone_z))*s(indx(ioh_z)) + r_m2(7) = rk_m2(7)*s(indx(imgly_z)) + r_m2(8) = rk_m2(8)*s(indx(imgly_z))*s(indx(ioh_z)) + r_m2(9) = rk_m2(9)*s(indx(imgly_z))*s(indx(ino3_z)) + r_m2(10) = rk_m2(10)*s(indx(ieth_z))*s(indx(io3_z)) + r_m2(11) = rk_m2(11)*s(indx(ieth_z))*s(indx(ioh_z)) + r_m2(12) = rk_m2(12)*s(indx(iolet_z))*s(indx(io3_z)) + r_m2(13) = rk_m2(13)*s(indx(iolei_z))*s(indx(io3_z)) + r_m2(14) = rk_m2(14)*s(indx(iolet_z))*s(indx(ioh_z)) + r_m2(15) = rk_m2(15)*s(indx(iolei_z))*s(indx(ioh_z)) + r_m2(16) = rk_m2(16)*s(indx(iolet_z))*s(indx(ino3_z)) + r_m2(17) = rk_m2(17)*s(indx(iolei_z))*s(indx(ino3_z)) + r_m2(18) = rk_m2(18)*s(indx(itol_z))*s(indx(ioh_z)) + r_m2(19) = rk_m2(19)*s(indx(ixyl_z))*s(indx(ioh_z)) + r_m2(20) = rk_m2(20)*s(indx(ito2_z))*s(indx(ino_z)) + r_m2(21) = rk_m2(21)*s(indx(icres_z))*s(indx(ioh_z)) + r_m2(22) = rk_m2(22)*s(indx(icres_z))*s(indx(ino3_z)) + r_m2(23) = rk_m2(23)*s(indx(icro_z))*s(indx(ino2_z)) + r_m2(24) = rk_m2(24)*s(indx(iopen_z))*s(indx(ioh_z)) + r_m2(25) = rk_m2(25)*s(indx(iopen_z)) + r_m2(26) = rk_m2(26)*s(indx(iopen_z))*s(indx(io3_z)) + r_m2(27) = rk_m2(27)*s(indx(irooh_z)) + r_m2(28) = rk_m2(28)*s(indx(irooh_z))*s(indx(ioh_z)) + r_m2(29) = rk_m2(29)*s(indx(ionit_z))*s(indx(ioh_z)) + r_m2(30) = rk_m2(30)*s(indx(ionit_z)) + + r_m2(33) = rk_m2(33)*s(indx(iro2_z))*s(indx(ino_z)) + + r_m2(35) = rk_m2(35)*s(indx(iano2_z))*s(indx(ino_z)) + r_m2(36) = rk_m2(36)*s(indx(inap_z))*s(indx(ino_z)) + r_m2(37) = rk_m2(37)*s(indx(ixo2_z))*s(indx(ino_z)) + r_m2(38) = rk_m2(38)*s(indx(iro2_z))*s(indx(ino3_z)) + + r_m2(40) = rk_m2(40)*s(indx(iano2_z))*s(indx(ino3_z)) + r_m2(41) = rk_m2(41)*s(indx(inap_z))*s(indx(ino3_z)) + r_m2(42) = rk_m2(42)*s(indx(ixo2_z))*s(indx(ino3_z)) + r_m2(43) = rk_m2(43)*s(indx(iro2_z))*s(indx(iho2_z)) + + r_m2(45) = rk_m2(45)*s(indx(iano2_z))*s(indx(iho2_z)) + r_m2(46) = rk_m2(46)*s(indx(inap_z))*s(indx(iho2_z)) + r_m2(47) = rk_m2(47)*s(indx(ixo2_z))*s(indx(iho2_z)) + r_m2(48) = rk_m2(48)*s(indx(iro2_z)) + + r_m2(50) = rk_m2(50)*s(indx(iano2_z)) + r_m2(51) = rk_m2(51)*s(indx(inap_z)) + r_m2(52) = rk_m2(52)*s(indx(ixo2_z)) + r_m2(53) = rk_m2(53)*s(indx(ipar_z))*s(indx(ixpar_z)) +! + return + end subroutine gasrate_m2 + + + +!*********************************************************************** +! <22.> subr gasrate_m3 +! +! purpose: computes reaction rates for mechanism 3 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- +! + subroutine gasrate_m3( indx, s, r_m3, rk_m3 ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real s(ngas_tot), r_m3(nrxn_m3), rk_m3(nrxn_m3) + + r_m3(1) = rk_m3(1)*s(indx(iisop_z))*s(indx(ioh_z)) + r_m3(2) = rk_m3(2)*s(indx(iisop_z))*s(indx(io3_z)) + r_m3(3) = rk_m3(3)*s(indx(iisop_z))*s(indx(ino3_z)) + r_m3(4) = rk_m3(4)*s(indx(iisoprd_z)) + r_m3(5) = rk_m3(5)*s(indx(iisoprd_z))*s(indx(ioh_z)) + r_m3(6) = rk_m3(6)*s(indx(iisoprd_z))*s(indx(io3_z)) + r_m3(7) = rk_m3(7)*s(indx(iisoprd_z))*s(indx(ino3_z)) + r_m3(8) = rk_m3(8)*s(indx(iisopp_z))*s(indx(ino_z)) + r_m3(9) = rk_m3(9)*s(indx(iisopn_z))*s(indx(ino_z)) + r_m3(10) = rk_m3(10)*s(indx(iisopo2_z))*s(indx(ino_z)) + r_m3(11) = rk_m3(11)*s(indx(iisopp_z))*s(indx(iho2_z)) + r_m3(12) = rk_m3(12)*s(indx(iisopn_z))*s(indx(iho2_z)) + r_m3(13) = rk_m3(13)*s(indx(iisopo2_z))*s(indx(iho2_z)) + r_m3(14) = rk_m3(14)*s(indx(iisopp_z)) + r_m3(15) = rk_m3(15)*s(indx(iisopn_z)) + r_m3(16) = rk_m3(16)*s(indx(iisopo2_z)) + + return + end subroutine gasrate_m3 + + + +!*********************************************************************** +! <23.> subr gasrate_m4 +! +! purpose: computes reaction rates for mechanism 4 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- +! + subroutine gasrate_m4( indx, s, r_m4, rk_m4, oxygen ) + + use module_data_cbmz + implicit none + +! subr arguments + integer indx(ngas_z) + real s(ngas_tot), r_m4(nrxn_m4), rk_m4(nrxn_m4) + real oxygen + + r_m4(1) = rk_m4(1)*s(indx(idms_z))*s(indx(ioh_z)) + r_m4(2) = rk_m4(2)*s(indx(idms_z))*s(indx(ino3_z)) + r_m4(3) = rk_m4(3)*s(indx(idms_z))*s(indx(io3p_z)) + r_m4(4) = rk_m4(4)*s(indx(idms_z))*s(indx(ioh_z)) + r_m4(5) = rk_m4(5)*s(indx(ich3sch2oo_z))*s(indx(ino_z)) + r_m4(6) = rk_m4(6)*s(indx(ich3sch2oo_z))*s(indx(ich3o2_z)) + r_m4(7) = rk_m4(7)*s(indx(ich3sch2oo_z))*s(indx(ich3so2_z)) + r_m4(8) = rk_m4(8)*s(indx(ich3sch2oo_z))*s(indx(ich3sch2oo_z)) + r_m4(9) = rk_m4(9)*s(indx(idmso_z))*s(indx(ioh_z)) + r_m4(10) = rk_m4(10)*s(indx(idmso2_z))*s(indx(ioh_z)) + r_m4(11) = rk_m4(11)*s(indx(ich3so2ch2oo_z))*s(indx(ino_z)) + r_m4(12) = rk_m4(12)*s(indx(ich3so2ch2oo_z))*s(indx(ich3o2_z)) + r_m4(13) = rk_m4(13)*s(indx(ich3so2h_z))*s(indx(iho2_z)) + r_m4(14) = rk_m4(14)*s(indx(ich3so2h_z))*s(indx(ino3_z)) + r_m4(15) = rk_m4(15)*s(indx(ich3so2h_z))*s(indx(ich3o2_z)) + r_m4(16) = rk_m4(16)*s(indx(ich3so2h_z))*s(indx(ioh_z)) + r_m4(17) = rk_m4(17)*s(indx(ich3so2h_z))*s(indx(ich3so3_z)) + r_m4(18) = rk_m4(18)*s(indx(ich3so2_z)) + r_m4(19) = rk_m4(19)*s(indx(ich3so2_z))*s(indx(ino2_z)) + r_m4(20) = rk_m4(20)*s(indx(ich3so2_z))*s(indx(io3_z)) + r_m4(21) = rk_m4(21)*s(indx(ich3so2_z))*s(indx(iho2_z)) + r_m4(22) = rk_m4(22)*s(indx(ich3so2_z))*s(indx(ich3o2_z)) + r_m4(23) = rk_m4(23)*s(indx(ich3so2_z))*s(indx(ioh_z)) + r_m4(24) = rk_m4(24)*s(indx(ich3so2_z))*oxygen + r_m4(25) = rk_m4(25)*s(indx(ich3so2oo_z)) + r_m4(26) = rk_m4(26)*s(indx(ich3so2oo_z))*s(indx(ino_z)) + r_m4(27) = rk_m4(27)*s(indx(ich3so2oo_z))*s(indx(ich3o2_z)) + r_m4(28) = rk_m4(28)*s(indx(ich3so3_z)) + r_m4(29) = rk_m4(29)*s(indx(ich3so3_z))*s(indx(ino2_z)) + r_m4(30) = rk_m4(30)*s(indx(ich3so3_z))*s(indx(ino_z)) + r_m4(31) = rk_m4(31)*s(indx(ich3so3_z))*s(indx(iho2_z)) + r_m4(32) = rk_m4(32)*s(indx(ich3so3_z))*s(indx(ihcho_z)) + + return + end subroutine gasrate_m4 + + + +!************************************************************************** +! <24.> subr loadperoxyparameters +! +! purpose: loads thermal rate coefficients for peroxy-peroxy +! permutation reactions +! +! author : Rahul A. Zaveri +! date : June 1998 +! +! nomenclature: +! Aperox = Pre-exponential factor (molec-cc-s) +! Bperox = activation energy (-E/R) (K) +! +!------------------------------------------------------------------------- + subroutine loadperoxyparameters( Aperox, Bperox ) + + use module_data_cbmz + implicit none + +! subr arguments + real Aperox(nperox,nperox), Bperox(nperox,nperox) + +! local variables + integer i, j + + Aperox(jch3o2,jch3o2) = 2.5e-13 + Aperox(jethp,jethp) = 6.8e-14 + Aperox(jc2o3,jc2o3) = 2.9e-12 + Aperox(jano2,jano2) = 8.0e-12 + Aperox(jnap,jnap) = 1.0e-12 + Aperox(jro2,jro2) = 5.3e-16 + Aperox(jisopp,jisopp) = 3.1e-14 + Aperox(jisopn,jisopn) = 3.1e-14 + Aperox(jisopo2,jisopo2) = 3.1e-14 + Aperox(jxo2,jxo2) = 3.1e-14 + + Bperox(jch3o2,jch3o2) = 190. + Bperox(jethp,jethp) = 0.0 + Bperox(jc2o3,jc2o3) = 500. + Bperox(jano2,jano2) = 0.0 + Bperox(jnap,jnap) = 0.0 + Bperox(jro2,jro2) = 1980. + Bperox(jisopp,jisopp) = 1000. + Bperox(jisopn,jisopn) = 1000. + Bperox(jisopo2,jisopo2) = 1000. + Bperox(jxo2,jxo2) = 1000. + + do i = 1, nperox + do j = 1, nperox + if(i.ne.j)then + Aperox(i,j) = 2.0*sqrt(Aperox(i,i)*Aperox(j,j)) + Bperox(i,j) = 0.5*(Bperox(i,i) + Bperox(j,j)) + endif + enddo + enddo + +! except for + Aperox(jc2o3,jch3o2) = 1.3e-12 + Aperox(jch3o2,jc2o3) = 1.3e-12 + Bperox(jc2o3,jch3o2) = 640. + Bperox(jch3o2,jc2o3) = 640. + + return + end subroutine loadperoxyparameters + + + + +!************************************************************************** +! <25.> subr peroxyrateconstants +! +! purpose: computes parameterized thermal rate coefficients +! for the alkylperoxy radical permutation reactions +! for the entire mechanism. +! +! author : Rahul A. Zaveri +! date : June 1998 +! +! nomenclature: +! rk_param = parameterized reaction rate constants (1/s) +! rk_perox = individual permutation reaction rate constants (molec-cc-s) +! te = ambient atmospheric temperature (K) +! +!------------------------------------------------------------------------- + subroutine peroxyrateconstants( tempbox, cbox, & + Aperox, Bperox, rk_param ) + + use module_data_cbmz + implicit none + +! subr arguments + real tempbox, cbox(ngas_z) + real Aperox(nperox,nperox), Bperox(nperox,nperox), rk_param(nperox) + +! local variables + integer i, j + real te + real sperox(nperox), rk_perox(nperox,nperox) + + + te = tempbox + + sperox(jch3o2) = cbox(ich3o2_z) + sperox(jethp) = cbox(iethp_z) + sperox(jro2) = cbox(iro2_z) + sperox(jc2o3) = cbox(ic2o3_z) + sperox(jano2) = cbox(iano2_z) + sperox(jnap) = cbox(inap_z) + sperox(jisopp) = cbox(iisopp_z) + sperox(jisopn) = cbox(iisopn_z) + sperox(jisopo2) = cbox(iisopo2_z) + sperox(jxo2) = cbox(ixo2_z) + +! +! initialize to zero + do i = 1, nperox + rk_param(i) = 0.0 + enddo + + do i = 1, nperox + do j = 1, nperox + rk_perox(i,j) = arr( Aperox(i,j), Bperox(i,j), te ) + rk_param(i) = rk_param(i) + rk_perox(i,j)*sperox(j) + enddo + enddo + + return + end subroutine peroxyrateconstants + + + +!*********************************************************************** +! <26.> subr gasthermrk_m1 +! +! purpose: computes thermal reaction rate coefficients for +! mechanism 1 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- + + subroutine gasthermrk_m1( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m1, rk_m2 ) + + use module_data_cbmz + implicit none + +! subr arguments + real tempbox, cair_mlc + real rk_photo(nphoto), rk_param(nperox) + real rk_m1(nrxn_m1), rk_m2(nrxn_m2) +! local variables + integer i + real rk0, rk2, rk3, rki, rko, rmm, rnn, te +! real arr, troe + + + te = tempbox + + rk_m1(1) = rk_photo(jphoto_no2) + rk_m1(2) = rk_photo(jphoto_no3) + rk_m1(3) = rk_photo(jphoto_hono) + rk_m1(4) = rk_photo(jphoto_hno3) + rk_m1(5) = rk_photo(jphoto_hno4) + rk_m1(6) = rk_photo(jphoto_n2o5) + rk_m1(7) = rk_photo(jphoto_o3a) + rk_m1(8) = rk_photo(jphoto_o3b) + rk_m1(9) = rk_photo(jphoto_h2o2) + rk_m1(10) = arr(3.2e-11, 70., te) + rk_m1(11) = arr(1.8e-11, 110., te) + rk_m1(12) = 2.2e-10 + rk_m1(13) = cair_mlc*6.e-34*(te/300.)**(-2.3) + rk_m1(14) = arr(8.0e-12, -2060., te) + rk_m1(15) = arr(6.5e-12, -120., te) +! + rk0 = 9.0e-32 + rnn = 2.0 + rki = 2.2e-11 + rmm = 0.0 + rk_m1(16) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk0 = 9.0e-32 + rnn = 1.5 + rki = 3.0e-11 + rmm = 0.0 + rk_m1(17) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m1(18) = arr(2.0e-12, -1400., te) + rk_m1(19) = arr(1.2e-13, -2450., te) + rk_m1(20) = arr(1.6e-12, -940., te) + rk_m1(21) = arr(1.1e-14, -500., te) + rk_m1(22) = arr(5.5e-12, -2000., te) +! + rk0 = 7.0e-31 + rnn = 2.6 + rki = 3.6e-11 + rmm = 0.1 + rk_m1(23) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk0 = 2.5e-30 + rnn = 4.4 + rki = 1.6e-11 + rmm = 1.7 + rk_m1(24) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m1(25) = 2.2e-11 + rk_m1(26) = arr(1.8e-11, -390., te) + rko = 7.2e-15 * exp(785./te) + rk2 = 4.1e-16 * exp(1440./te) + rk3 = 1.9e-33 * exp(725./te)*cair_mlc + rk_m1(27) = rko + rk3/(1.+rk3/rk2) + rk_m1(28) = arr(1.3e-12, 380., te) + rk_m1(29) = arr(4.8e-11, 250., te) + rk_m1(30) = arr(2.9e-12, -160., te) + rk_m1(31) = 2.3e-13 * exp(600./te) + & + 1.7e-33 * exp(1000./te)*cair_mlc ! ho2 + ho2 --> h2o2 + rk_m1(32) = rk_m1(31)*1.4e-21*exp(2200./te) ! ho2 + ho2 + h2o --> h2o2 + rk_m1(33) = arr(3.5e-12, 250., te) +! + rk0 = 1.8e-31 + rnn = 3.2 + rki = 4.7e-12 + rmm = 1.4 + rk_m1(34) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m1(35) = 5.0e-16 + rk_m1(36) = rk_m1(34)*arr(4.8e26, -10900., te) + rk_m1(37) = arr(1.5e-11, 170., te) + rk_m1(38) = arr(4.5e-14, -1260., te) +! + rk0 = 2.2e-30 + rnn = 3.9 + rki = 1.5e-12 + rmm = 0.7 + rk_m1(39) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m1(40) = arr(8.5e-13, -2450., te) + rk_m1(41) = 3.5e-12 + rk_m1(42) = 2.0e-21 + rk_m1(43) = rk_m1(39)*arr(3.7e26, -11000., te) + rk_m1(44) = 1.5e-13 * (1.+8.18e-23*te*cair_mlc) ! co + oh --> ho2 + + rk0 = 3.0e-31 + rnn = 3.3 + rki = 1.5e-12 + rmm = 0.0 + rk_m1(45) = Troe(cair_mlc,te,rk0,rnn,rki,rmm) + + rk_m1(46) = te**.667*arr(2.8e-14, -1575., te) + rk_m1(47) = te**2*arr(1.5e-17, -492., te) + rk_m1(48) = arr(6.7e-12, -600., te) + rk_m1(49) = rk_photo(jphoto_hchoa) ! hcho + hv --> 2ho2 + co + rk_m1(50) = rk_photo(jphoto_hchob) ! hcho + hv --> co + rk_m1(51) = 1.0e-11 + rk_m1(52) = arr(3.4e-13, -1900., te) + rk_m1(53) = rk_photo(jphoto_ch3ooh) + rk_m1(54) = rk_photo(jphoto_ethooh) + rk_m1(55) = arr(3.8e-12, 200., te) + rk_m1(56) = arr(3.8e-12, 200., te) + rk_m1(57) = arr(3.0e-12, 280., te) + rk_m1(58) = arr(2.6e-12, 365., te) + rk_m1(59) = 1.1e-12 + rk_m1(60) = 2.5e-12 + rk_m1(61) = arr(3.8e-13, 800., te) + rk_m1(62) = arr(7.5e-13, 700., te) + rk_m1(63) = rk_param(jch3o2) + rk_m1(64) = rk_param(jethp) + rk_m1(65) = arr(7.0e-12, -235.,te) + + rk_m2(2) = rk_photo(jphoto_ald2) + rk_m2(3) = arr(5.6e-12, 270., te) + rk_m2(4) = arr(1.4e-12, -1900., te) +! + rk0 = 9.7e-29 + rnn = 5.6 + rki = 9.3e-12 + rmm = 1.5 + rk_m2(31) = troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m2(32) = rk_m2(31)*arr(1.1e28, -14000., te) + rk_m2(34) = arr(5.3e-12, 360., te) + rk_m2(39) = 4.0e-12 + rk_m2(44) = arr(4.5e-13, 1000., te) + rk_m2(49) = rk_param(jc2o3) + +! Heterogeneous reactions +! rk_m1(65) = rk_het(1) ! O3 --> +! rk_m1(66) = rk_het(2) ! HO2 --> 0.5H2O2 +! rk_m1(67) = rk_het(3) ! NO2 --> 0.5HONO + 0.5HNO3 +! rk_m1(68) = rk_het(4) ! N2O5 --> 2HNO3 +! rk_m1(69) = rk_het(5) ! HNO3 --> NO2 +! rk_m1(70) = rk_het(6) ! HNO3 --> NO +! rk_m1(71) = rk_het(7) ! NO3 --> NO + O2 + +! all rate constants but be >= 0 + do i = 1, nrxn_m1 + rk_m1(i) = max( rk_m1(i), 0.0 ) + end do + do i = 1, nrxn_m2 + rk_m2(i) = max( rk_m2(i), 0.0 ) + end do + + return + end subroutine gasthermrk_m1 + + + +!*********************************************************************** +! <27.> subr gasthermrk_m2 +! +! purpose: computes thermal reaction rate coefficients for +! mechanism 2 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- + + subroutine gasthermrk_m2( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m2 ) + + use module_data_cbmz + implicit none + +! subr arguments + real tempbox, cair_mlc + real rk_photo(nphoto), rk_param(nperox), rk_m2(nrxn_m2) +! local variables + integer i + real rk0, rki, rmm, rnn, te +! real arr, troe + + + te = tempbox + + rk_m2(1) = 8.1e-13 + + rk_m2(5) = rk_photo(jphoto_aone) + rk_m2(6) = te**2*arr(5.3e-18, -230., te) + rk_m2(7) = rk_photo(jphoto_mgly) + rk_m2(8) = 1.7e-11 + rk_m2(9) = arr(1.4e-12, -1900., te) + rk_m2(10) = arr(1.2e-14, -2630., te) +! + rk0 = 1.0e-28 + rnn = 0.8 + rki = 8.8e-12 + rmm = 0.0 + rk_m2(11) = troe(cair_mlc,te,rk0,rnn,rki,rmm) +! + rk_m2(12) = arr(4.2e-15, -1800., te) + rk_m2(13) = arr(8.9e-16, -392., te) + rk_m2(14) = arr(5.8e-12, 478., te) + rk_m2(15) = arr(2.9e-11, 255., te) + rk_m2(16) = arr(3.1e-13, -1010., te) + rk_m2(17) = 2.5e-12 + rk_m2(18) = arr(2.1e-12, 322., te) + rk_m2(19) = arr(1.7e-11, 116., te) + rk_m2(20) = 8.1e-12 + rk_m2(21) = 4.1e-11 + rk_m2(22) = 2.2e-11 + rk_m2(23) = 1.4e-11 + rk_m2(24) = 3.0e-11 + rk_m2(25) = rk_photo(jphoto_open) + rk_m2(26) = arr(5.4e-17, -500., te) + rk_m2(27) = rk_photo(jphoto_rooh) + rk_m2(28) = arr(3.8e-12, 200., te) + rk_m2(29) = arr(1.6e-11, -540., te) + rk_m2(30) = rk_photo(jphoto_onit) + + rk_m2(33) = 4.0e-12 + + rk_m2(35) = 4.0e-12 + rk_m2(36) = 4.0e-12 + rk_m2(37) = 4.0e-12 + rk_m2(38) = 2.5e-12 + + rk_m2(40) = 1.2e-12 + rk_m2(41) = 4.0e-12 + rk_m2(42) = 2.5e-12 + rk_m2(43) = arr(1.7e-13, 1300., te) + + rk_m2(45) = arr(1.2e-13, 1300., te) + rk_m2(46) = arr(1.7e-13, 1300., te) + rk_m2(47) = arr(1.7e-13, 1300., te) + rk_m2(48) = rk_param(jro2) + + rk_m2(50) = rk_param(jano2) + rk_m2(51) = rk_param(jnap) + rk_m2(52) = rk_param(jxo2) + rk_m2(53) = 1.0e-11 ! XPAR + PAR --> + +! all rate constants but be >= 0 + do i = 1, nrxn_m2 + rk_m2(i) = max( rk_m2(i), 0.0 ) + end do + + return + end subroutine gasthermrk_m2 + + + +!*********************************************************************** +! <28.> subr gasthermrk_m3 +! +! purpose: computes thermal reaction rate coefficients for +! mechanism 3 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- + + subroutine gasthermrk_m3( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m3 ) + + use module_data_cbmz + implicit none + +! subr arguments + real tempbox, cair_mlc + real rk_photo(nphoto), rk_param(nperox), rk_m3(nrxn_m3) +! local variables + integer i + real te +! real arr + + + te = tempbox +! + rk_m3(1) = arr(2.6e-11, 409., te) + rk_m3(2) = arr(1.2e-14, -2013., te) + rk_m3(3) = arr(3.0e-12, -446., te) + rk_m3(4) = rk_photo(jphoto_isoprd) + rk_m3(5) = 3.3e-11 + rk_m3(6) = 7.0e-18 + rk_m3(7) = 1.0e-15 + rk_m3(8) = 4.0e-12 + rk_m3(9) = 4.0e-12 + rk_m3(10) = 4.0e-12 + rk_m3(11) = arr(1.7e-13, 1300., te) + rk_m3(12) = arr(1.7e-13, 1300., te) + rk_m3(13) = arr(1.7e-13, 1300., te) + rk_m3(14) = rk_param(jisopp) + rk_m3(15) = rk_param(jisopn) + rk_m3(16) = rk_param(jisopo2) + +! all rate constants but be >= 0 + do i = 1, nrxn_m3 + rk_m3(i) = max( rk_m3(i), 0.0 ) + end do + + return + end subroutine gasthermrk_m3 + + + +!*********************************************************************** +! <29.> subr gasthermrk_m4 +! +! purpose: computes thermal reaction rate coefficients for +! mechanism 4 +! +! author : Rahul A. Zaveri +! date : December 1998 +! +!------------------------------------------------------------------------- + + subroutine gasthermrk_m4( tempbox, cair_mlc, & + rk_photo, rk_param, rk_m4 ) + + use module_data_cbmz + implicit none + +! subr arguments + real tempbox, cair_mlc + real rk_photo(nphoto), rk_param(nperox), rk_m4(nrxn_m4) +! local variables + integer i + real B_abs, B_add, rk_tot, rk_tot_den, rk_tot_num, te +! real arr + + + te = tempbox +! + rk_m4(1) = arr(9.6e-12, -234., te) ! ch3sch3 + oh --> ch3sch2 + rk_m4(2) = arr(1.4e-13, 500., te) + rk_m4(3) = arr(1.3e-11, 409., te) + +! Hynes et al. (1986) + rk_tot_num = te * exp(-234./te) + & + 8.46e-10 * exp(7230./te) + & + 2.68e-10 * exp(7810./te) + rk_tot_den = 1.04e+11 * te + 88.1 * exp(7460./te) + rk_tot = rk_tot_num/rk_tot_den + B_abs = rk_m4(1)/rk_tot + B_add = 1. - B_abs + + rk_m4(4) = B_add*rk_tot ! ch3sch3 + oh --> ch3s(oh)ch3 + rk_m4(5) = 8.0e-12 + rk_m4(6) = 1.8e-13 + rk_m4(7) = 2.5e-13 + rk_m4(8) = 8.6e-14 + rk_m4(9) = 5.8e-11 + rk_m4(10) = 1.0e-14 + rk_m4(11) = 5.0e-12 + rk_m4(12) = 1.8e-13 + rk_m4(13) = 1.0e-15 + rk_m4(14) = 1.0e-13 + rk_m4(15) = 1.0e-15 + rk_m4(16) = 1.6e-11 + rk_m4(17) = 1.0e-13 + rk_m4(18) = arr(2.5e-13, -8686., te) + rk_m4(19) = 1.0e-14 + rk_m4(20) = 5.0e-15 + rk_m4(21) = 2.5e-13 + rk_m4(22) = 2.5e-13 + rk_m4(23) = 5.0e-11 + rk_m4(24) = 2.6e-18 + rk_m4(25) = 3.3 + rk_m4(26) = 1.0e-11 + rk_m4(27) = 5.5e-12 + rk_m4(28) = arr(2.0e17, -12626., te) + rk_m4(29) = 3.0e-15 + rk_m4(30) = 3.0e-15 + rk_m4(31) = 5.0e-11 + rk_m4(32) = 1.6e-15 + +! all rate constants but be >= 0 + do i = 1, nrxn_m4 + rk_m4(i) = max( rk_m4(i), 0.0 ) + end do + + return + end subroutine gasthermrk_m4 + + + + +!*********************************************************************** +! <26.> subr hetrateconstants +! +! purpose: computes heterogeneous reaction rate coefficients +! +! author : Rahul A. Zaveri +! date : May 2000 +! +!------------------------------------------------------------------------- + + subroutine hetrateconstants + implicit none + + return + end subroutine hetrateconstants + + + +!*********************************************************************** +! <31.> func troe +! +! purpose: calculates Troe reaction rate coefficient +! +! author : Rahul A. Zaveri +! date : December 1998 +!----------------------------------------------------------------------- + + real function troe( cairmlc, te, rk0, rnn, rki, rmm ) + implicit none +! func parameters + real cairmlc, te, rk0, rnn, rki, rmm +! local variables + real expo + + rk0 = rk0*cairmlc*(te/300.)**(-rnn) + rki = rki*(te/300.)**(-rmm) + expo= 1./(1. + (ALOG10(rk0/rki))**2) + troe = (rk0*rki/(rk0+rki))*.6**expo + return + end function troe + + + +!*********************************************************************** +! <32.> func arr +! +! purpose: calculates arrhenius rate coefficient +! +! author : Rahul A. Zaveri +! date : December 1998 +!----------------------------------------------------------------------- + + real function arr( aa, bb, te ) + implicit none +! func parameters + real aa, bb, te + + arr = aa*exp(bb/te) + return + end function arr + + + +!*********************************************************************** +! subr mapgas_tofrom_host +! +! purpose: maps gas species between cboxold/new and host arrays +! +! author : R. C. Easter +! date : November, 2003 +! +! ---------------------------------------------------------------------- + + subroutine mapgas_tofrom_host( imap, & + i_boxtest_units_convert, & + it,jt,kt, ims,ime, jms,jme, kms,kme, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy, & + cbox, tempbox, pressbox, airdenbox, & + cair_mlc, & + h2o, ch4, oxygen, nitrogen, hydrogen ) + + use module_configure, only: & + p_qv, & + p_so2, p_sulf, p_no2, p_no, p_o3, & + p_hno3, p_h2o2, p_ald, p_hcho, p_op1, & + p_op2, p_paa, p_ora1, p_ora2, p_nh3, & + p_n2o5, p_no3, p_pan, p_hc3, p_hc5, & + p_hc8, p_eth, p_co, p_ol2, p_olt, & + p_oli, p_tol, p_xyl, p_aco3, p_tpan, & + p_hono, p_hno4, p_ket, p_gly, p_mgly, & + p_dcb, p_onit, p_csl, p_iso, p_ho, & + p_ho2, & + p_hcl, p_ch3o2, p_ethp, p_ch3oh, p_c2h5oh, & + p_par, p_to2, p_cro, p_open, p_op3, & + p_c2o3, p_ro2, p_ano2, p_nap, p_xo2, & + p_xpar, p_isoprd, p_isopp, p_isopn, p_isopo2, & + p_dms, p_msa, p_dmso, p_dmso2, p_ch3so2h, & + p_ch3sch2oo, p_ch3so2, p_ch3so3, p_ch3so2oo, p_ch3so2ch2oo, & + p_mtf + use module_data_cbmz + implicit none + +! subr arguments + INTEGER, INTENT(IN) :: imap, it,jt,kt, ims,ime, jms,jme, kms,kme, & + num_moist, num_chem, i_boxtest_units_convert + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT) :: chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN) :: t_phy, & ! temperature + p_phy, & ! air pressure (Pa) + rho_phy ! air density (kg/m3) + REAL, INTENT(INOUT) :: cbox(ngas_z) + REAL, INTENT(INOUT) :: tempbox, pressbox, airdenbox + REAL, INTENT(INOUT) :: cair_mlc + REAL, INTENT(INOUT) :: h2o, ch4, oxygen, nitrogen, hydrogen + +! local variables + integer l + real factoraa + real, parameter :: eps=0.622 + + + tempbox = t_phy(it,kt,jt) +! p_phy = (Pa); pressbox = (dynes/cm2) + pressbox = p_phy(it,kt,jt)*10.0 +! rho_phy = (kg_air/m3); airdenbox = (mole_air/cm3) + airdenbox = rho_phy(it,kt,jt)/28.966e3 + if (i_boxtest_units_convert .eq. 10) then + airdenbox = rho_phy(it,kt,jt) + end if + + if (imap .gt. 0) goto 2000 + +! +! imap==0 -- initial species mapping from host array to cboxold +! chem --> czz --> cbox +! +! note: do not map nh3, hcl +! + cbox(:) = 0.0 + +! cair_mlc = (molecules_air/cm3) + cair_mlc = airdenbox*avognumkpp + +! moist = (kg_h2o/kg_air); czz = (mole_h2o/cm3); h2o = (molecules_h2o/cm3) +! czz(ih2o_z) = (moist(it,kt,jt,p_qv)/eps)*airdenbox +! if (i_boxtest_units_convert .eq. 10) then +! czz(ih2o_z) = moist(it,kt,jt,p_qv)*airdenbox +! end if +! h2o = czz(ih2o_z)*avognumkpp + h2o = (moist(it,kt,jt,p_qv)/eps)*airdenbox + if (i_boxtest_units_convert .eq. 10) then + h2o = moist(it,kt,jt,p_qv)*airdenbox + end if + h2o = h2o*avognumkpp + +! czz(ich4_z) = 1.7e-6*airdenbox ! ch4 conc. in mol/cc +! ch4 = czz(ich4_z)*avognumkpp ! ch4 conc. in molec/cc + ch4 = 1.7e-6*airdenbox*avognumkpp ! ch4 conc. in molec/cc + + oxygen = 0.21*cair_mlc ! o2 conc. in molec/cc + nitrogen = 0.79*cair_mlc ! n2 conc. in molec/cc + hydrogen = 0.58e-6*cair_mlc ! h2 conc. in molec/cc + +! chem units = (ppm); czz units = (mole/cm3); cbox units = (molecules/cm3) + factoraa = airdenbox*1.0e-6 + if (i_boxtest_units_convert .eq. 10) factoraa = airdenbox + factoraa = factoraa*avognumkpp + + cbox(iso2_z) = chem(it,kt,jt,p_so2)*factoraa + cbox(ih2so4_z) = chem(it,kt,jt,p_sulf)*factoraa + cbox(ino2_z) = chem(it,kt,jt,p_no2)*factoraa + cbox(ino_z) = chem(it,kt,jt,p_no)*factoraa + cbox(io3_z) = chem(it,kt,jt,p_o3)*factoraa + cbox(ihno3_z) = chem(it,kt,jt,p_hno3)*factoraa + cbox(ih2o2_z) = chem(it,kt,jt,p_h2o2)*factoraa + cbox(iald2_z) = chem(it,kt,jt,p_ald)*factoraa + cbox(ihcho_z) = chem(it,kt,jt,p_hcho)*factoraa + cbox(ich3ooh_z) = chem(it,kt,jt,p_op1)*factoraa + cbox(iethooh_z) = chem(it,kt,jt,p_op2)*factoraa + cbox(ihcooh_z) = chem(it,kt,jt,p_ora1)*factoraa + cbox(ircooh_z) = chem(it,kt,jt,p_ora2)*factoraa + cbox(inh3_z) = chem(it,kt,jt,p_nh3)*factoraa + cbox(in2o5_z) = chem(it,kt,jt,p_n2o5)*factoraa + cbox(ino3_z) = chem(it,kt,jt,p_no3)*factoraa + cbox(ipan_z) = chem(it,kt,jt,p_pan)*factoraa + cbox(ic2h6_z) = chem(it,kt,jt,p_eth)*factoraa + cbox(ico_z) = chem(it,kt,jt,p_co)*factoraa + cbox(ieth_z) = chem(it,kt,jt,p_ol2)*factoraa + cbox(iolet_z) = chem(it,kt,jt,p_olt)*factoraa + cbox(iolei_z) = chem(it,kt,jt,p_oli)*factoraa + cbox(itol_z) = chem(it,kt,jt,p_tol)*factoraa + cbox(ixyl_z) = chem(it,kt,jt,p_xyl)*factoraa + cbox(ihono_z) = chem(it,kt,jt,p_hono)*factoraa + cbox(ihno4_z) = chem(it,kt,jt,p_hno4)*factoraa + cbox(iaone_z) = chem(it,kt,jt,p_ket)*factoraa + cbox(imgly_z) = chem(it,kt,jt,p_mgly)*factoraa + cbox(ionit_z) = chem(it,kt,jt,p_onit)*factoraa + cbox(icres_z) = chem(it,kt,jt,p_csl)*factoraa + cbox(iisop_z) = chem(it,kt,jt,p_iso)*factoraa + cbox(ioh_z) = chem(it,kt,jt,p_ho)*factoraa + cbox(iho2_z) = chem(it,kt,jt,p_ho2)*factoraa + + cbox(ihcl_z) = chem(it,kt,jt,p_hcl)*factoraa + cbox(ich3o2_z) = chem(it,kt,jt,p_ch3o2)*factoraa + cbox(iethp_z) = chem(it,kt,jt,p_ethp)*factoraa + cbox(ich3oh_z) = chem(it,kt,jt,p_ch3oh)*factoraa + cbox(ic2h5oh_z) = chem(it,kt,jt,p_c2h5oh)*factoraa + cbox(ipar_z) = chem(it,kt,jt,p_par)*factoraa + cbox(ito2_z) = chem(it,kt,jt,p_to2)*factoraa + cbox(icro_z) = chem(it,kt,jt,p_cro)*factoraa + cbox(iopen_z) = chem(it,kt,jt,p_open)*factoraa + cbox(irooh_z) = chem(it,kt,jt,p_op3)*factoraa + cbox(ic2o3_z) = chem(it,kt,jt,p_c2o3)*factoraa + cbox(iro2_z) = chem(it,kt,jt,p_ro2)*factoraa + cbox(iano2_z) = chem(it,kt,jt,p_ano2)*factoraa + cbox(inap_z) = chem(it,kt,jt,p_nap)*factoraa + cbox(ixo2_z) = chem(it,kt,jt,p_xo2)*factoraa + cbox(ixpar_z) = chem(it,kt,jt,p_xpar)*factoraa + cbox(iisoprd_z) = chem(it,kt,jt,p_isoprd)*factoraa + cbox(iisopp_z) = chem(it,kt,jt,p_isopp)*factoraa + cbox(iisopn_z) = chem(it,kt,jt,p_isopn)*factoraa + cbox(iisopo2_z) = chem(it,kt,jt,p_isopo2)*factoraa + cbox(idms_z) = chem(it,kt,jt,p_dms)*factoraa + cbox(imsa_z) = chem(it,kt,jt,p_msa)*factoraa + cbox(idmso_z) = chem(it,kt,jt,p_dmso)*factoraa + cbox(idmso2_z) = chem(it,kt,jt,p_dmso2)*factoraa + cbox(ich3so2h_z) = chem(it,kt,jt,p_ch3so2h)*factoraa + cbox(ich3sch2oo_z) = chem(it,kt,jt,p_ch3sch2oo)*factoraa + cbox(ich3so2_z) = chem(it,kt,jt,p_ch3so2)*factoraa + cbox(ich3so3_z) = chem(it,kt,jt,p_ch3so3)*factoraa + cbox(ich3so2oo_z) = chem(it,kt,jt,p_ch3so2oo)*factoraa + cbox(ich3so2ch2oo_z) = chem(it,kt,jt,p_ch3so2ch2oo)*factoraa + cbox(imtf_z) = chem(it,kt,jt,p_mtf)*factoraa + + cbox(ih2o_z) = h2o + cbox(ich4_z) = ch4 + cbox(io2_z) = oxygen + cbox(in2_z) = nitrogen + cbox(ih2_z) = hydrogen + + return + +! +! imap==1 -- final species mapping from cbox back to host array +! cbox --> czz --> chem +! +! note1: do not map nh3, hcl, ch4 +! +2000 continue +! chem = (ppm); czz = (mole/cm3); cbox = (molecules/cm3) + factoraa = airdenbox*1.0e-6 + if (i_boxtest_units_convert .eq. 10) factoraa = airdenbox + factoraa = factoraa*avognumkpp + + chem(it,kt,jt,p_so2) = cbox(iso2_z)/factoraa + chem(it,kt,jt,p_sulf) = cbox(ih2so4_z)/factoraa + chem(it,kt,jt,p_no2) = cbox(ino2_z)/factoraa + chem(it,kt,jt,p_no) = cbox(ino_z)/factoraa + chem(it,kt,jt,p_o3) = cbox(io3_z)/factoraa + chem(it,kt,jt,p_hno3) = cbox(ihno3_z)/factoraa + chem(it,kt,jt,p_h2o2) = cbox(ih2o2_z)/factoraa + chem(it,kt,jt,p_ald) = cbox(iald2_z)/factoraa + chem(it,kt,jt,p_hcho) = cbox(ihcho_z)/factoraa + chem(it,kt,jt,p_op1) = cbox(ich3ooh_z)/factoraa + chem(it,kt,jt,p_op2) = cbox(iethooh_z)/factoraa + chem(it,kt,jt,p_ora1) = cbox(ihcooh_z)/factoraa + chem(it,kt,jt,p_ora2) = cbox(ircooh_z)/factoraa + chem(it,kt,jt,p_nh3) = cbox(inh3_z)/factoraa + chem(it,kt,jt,p_n2o5) = cbox(in2o5_z)/factoraa + chem(it,kt,jt,p_no3) = cbox(ino3_z)/factoraa + chem(it,kt,jt,p_pan) = cbox(ipan_z)/factoraa + chem(it,kt,jt,p_eth) = cbox(ic2h6_z)/factoraa + chem(it,kt,jt,p_co) = cbox(ico_z)/factoraa + chem(it,kt,jt,p_ol2) = cbox(ieth_z)/factoraa + chem(it,kt,jt,p_olt) = cbox(iolet_z)/factoraa + chem(it,kt,jt,p_oli) = cbox(iolei_z)/factoraa + chem(it,kt,jt,p_tol) = cbox(itol_z)/factoraa + chem(it,kt,jt,p_xyl) = cbox(ixyl_z)/factoraa + chem(it,kt,jt,p_hono) = cbox(ihono_z)/factoraa + chem(it,kt,jt,p_hno4) = cbox(ihno4_z)/factoraa + chem(it,kt,jt,p_ket) = cbox(iaone_z)/factoraa + chem(it,kt,jt,p_mgly) = cbox(imgly_z)/factoraa + chem(it,kt,jt,p_onit) = cbox(ionit_z)/factoraa + chem(it,kt,jt,p_csl) = cbox(icres_z)/factoraa + chem(it,kt,jt,p_iso) = cbox(iisop_z)/factoraa + chem(it,kt,jt,p_ho) = cbox(ioh_z)/factoraa + chem(it,kt,jt,p_ho2) = cbox(iho2_z)/factoraa + + chem(it,kt,jt,p_hcl) = cbox(ihcl_z)/factoraa + chem(it,kt,jt,p_ch3o2) = cbox(ich3o2_z)/factoraa + chem(it,kt,jt,p_ethp) = cbox(iethp_z)/factoraa + chem(it,kt,jt,p_ch3oh) = cbox(ich3oh_z)/factoraa + chem(it,kt,jt,p_c2h5oh) = cbox(ic2h5oh_z)/factoraa + chem(it,kt,jt,p_par) = cbox(ipar_z)/factoraa + chem(it,kt,jt,p_to2) = cbox(ito2_z)/factoraa + chem(it,kt,jt,p_cro) = cbox(icro_z)/factoraa + chem(it,kt,jt,p_open) = cbox(iopen_z)/factoraa + chem(it,kt,jt,p_op3) = cbox(irooh_z)/factoraa + chem(it,kt,jt,p_c2o3) = cbox(ic2o3_z)/factoraa + chem(it,kt,jt,p_ro2) = cbox(iro2_z)/factoraa + chem(it,kt,jt,p_ano2) = cbox(iano2_z)/factoraa + chem(it,kt,jt,p_nap) = cbox(inap_z)/factoraa + chem(it,kt,jt,p_xo2) = cbox(ixo2_z)/factoraa + chem(it,kt,jt,p_xpar) = cbox(ixpar_z)/factoraa + chem(it,kt,jt,p_isoprd) = cbox(iisoprd_z)/factoraa + chem(it,kt,jt,p_isopp) = cbox(iisopp_z)/factoraa + chem(it,kt,jt,p_isopn) = cbox(iisopn_z)/factoraa + chem(it,kt,jt,p_isopo2) = cbox(iisopo2_z)/factoraa + chem(it,kt,jt,p_dms) = cbox(idms_z)/factoraa + chem(it,kt,jt,p_msa) = cbox(imsa_z)/factoraa + chem(it,kt,jt,p_dmso) = cbox(idmso_z)/factoraa + chem(it,kt,jt,p_dmso2) = cbox(idmso2_z)/factoraa + chem(it,kt,jt,p_ch3so2h) = cbox(ich3so2h_z)/factoraa + chem(it,kt,jt,p_ch3sch2oo) = cbox(ich3sch2oo_z)/factoraa + chem(it,kt,jt,p_ch3so2) = cbox(ich3so2_z)/factoraa + chem(it,kt,jt,p_ch3so3) = cbox(ich3so3_z)/factoraa + chem(it,kt,jt,p_ch3so2oo) = cbox(ich3so2oo_z)/factoraa + chem(it,kt,jt,p_ch3so2ch2oo) = cbox(ich3so2ch2oo_z)/factoraa + chem(it,kt,jt,p_mtf) = cbox(imtf_z)/factoraa + + return + end subroutine mapgas_tofrom_host + + + +!*********************************************************************** +! subr set_gaschem_allowed_regimes +! +! purpose: determines which gas-phase chemistry regimes are allowed based +! on which species are active in the simulation +! +! author : +! date : +! +! ---------------------------------------------------------------------- + + subroutine set_gaschem_allowed_regimes( lunerr, & + igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 ) +! +! determines which gas-phase chemistry regimes are allowed based +! on which species are active in the simulation +! + use module_configure, only: & + p_qv, & + p_so2, p_sulf, p_no2, p_no, p_o3, & + p_hno3, p_h2o2, p_ald, p_hcho, p_op1, & + p_op2, p_paa, p_ora1, p_ora2, p_nh3, & + p_n2o5, p_no3, p_pan, p_hc3, p_hc5, & + p_hc8, p_eth, p_co, p_ol2, p_olt, & + p_oli, p_tol, p_xyl, p_aco3, p_tpan, & + p_hono, p_hno4, p_ket, p_gly, p_mgly, & + p_dcb, p_onit, p_csl, p_iso, p_ho, & + p_ho2, & + p_hcl, p_ch3o2, p_ethp, p_ch3oh, p_c2h5oh, & + p_par, p_to2, p_cro, p_open, p_op3, & + p_c2o3, p_ro2, p_ano2, p_nap, p_xo2, & + p_xpar, p_isoprd, p_isopp, p_isopn, p_isopo2, & + p_dms, p_msa, p_dmso, p_dmso2, p_ch3so2h, & + p_ch3sch2oo, p_ch3so2, p_ch3so3, p_ch3so2oo, p_ch3so2ch2oo, & + p_mtf + use module_state_description, only: param_first_scalar + use module_data_cbmz + implicit none + +! subr arguments + integer lunerr + integer igaschem_allowed_m1, igaschem_allowed_m2, & + igaschem_allowed_m3, igaschem_allowed_m4 + +! local variables + integer nactive, ndum, p1st + character*80 msg + + +! index for first "active" scalar (= 2) + p1st = param_first_scalar + +! determine if regime 1 is allowed +! (note: p_xxx>1 if xxx is active, p_xxx=1 if inactive) + if (p_qv .lt. p1st) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + msg = '*** water vapor IS NOT ACTIVE' + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + +! determine if regime 1 is allowed +! (note: p_xxx>1 if xxx is active, p_xxx=1 if inactive) + nactive = 0 + ndum = 27 + if (p_no .ge. p1st) nactive = nactive + 1 + if (p_no2 .ge. p1st) nactive = nactive + 1 + if (p_no3 .ge. p1st) nactive = nactive + 1 + if (p_n2o5 .ge. p1st) nactive = nactive + 1 + if (p_hono .ge. p1st) nactive = nactive + 1 + if (p_hno3 .ge. p1st) nactive = nactive + 1 + if (p_hno4 .ge. p1st) nactive = nactive + 1 + if (p_o3 .ge. p1st) nactive = nactive + 1 +! if (p_o1d .ge. p1st) nactive = nactive + 1 +! if (p_o3p .ge. p1st) nactive = nactive + 1 + if (p_ho .ge. p1st) nactive = nactive + 1 + if (p_ho2 .ge. p1st) nactive = nactive + 1 + if (p_h2o2 .ge. p1st) nactive = nactive + 1 + if (p_co .ge. p1st) nactive = nactive + 1 + if (p_so2 .ge. p1st) nactive = nactive + 1 + if (p_sulf .ge. p1st) nactive = nactive + 1 +! if (p_nh3 .ge. p1st) nactive = nactive + 1 +! if (p_hcl .ge. p1st) nactive = nactive + 1 + if (p_eth .ge. p1st) nactive = nactive + 1 + if (p_ch3o2 .ge. p1st) nactive = nactive + 1 + if (p_ethp .ge. p1st) nactive = nactive + 1 + if (p_hcho .ge. p1st) nactive = nactive + 1 + if (p_ch3oh .ge. p1st) nactive = nactive + 1 + if (p_c2h5oh .ge. p1st) nactive = nactive + 1 + if (p_op1 .ge. p1st) nactive = nactive + 1 + if (p_op2 .ge. p1st) nactive = nactive + 1 + if (p_ald .ge. p1st) nactive = nactive + 1 + if (p_ora1 .ge. p1st) nactive = nactive + 1 + if (p_pan .ge. p1st) nactive = nactive + 1 + if (p_ora2 .ge. p1st) nactive = nactive + 1 + if (p_c2o3 .ge. p1st) nactive = nactive + 1 + + if (nactive .le. 0) then + igaschem_allowed_m1 = 0 + else if (nactive .eq. ndum) then + igaschem_allowed_m1 = 1 + else + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90200) 1, nactive, ndum + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if +90200 format( ' error for regime ', i1, ', nactive, nexpected = ', 2i5 ) + +! determine if regime 2 is allowed + nactive = 0 + ndum = 19 + if (p_par .ge. p1st) nactive = nactive + 1 + if (p_ket .ge. p1st) nactive = nactive + 1 + if (p_mgly .ge. p1st) nactive = nactive + 1 + if (p_ol2 .ge. p1st) nactive = nactive + 1 + if (p_olt .ge. p1st) nactive = nactive + 1 + if (p_oli .ge. p1st) nactive = nactive + 1 + if (p_tol .ge. p1st) nactive = nactive + 1 + if (p_xyl .ge. p1st) nactive = nactive + 1 + if (p_csl .ge. p1st) nactive = nactive + 1 + if (p_to2 .ge. p1st) nactive = nactive + 1 + if (p_cro .ge. p1st) nactive = nactive + 1 + if (p_open .ge. p1st) nactive = nactive + 1 + if (p_onit .ge. p1st) nactive = nactive + 1 + if (p_op3 .ge. p1st) nactive = nactive + 1 + if (p_ro2 .ge. p1st) nactive = nactive + 1 + if (p_ano2 .ge. p1st) nactive = nactive + 1 + if (p_nap .ge. p1st) nactive = nactive + 1 + if (p_xo2 .ge. p1st) nactive = nactive + 1 + if (p_xpar .ge. p1st) nactive = nactive + 1 + if (nactive .le. 0) then + igaschem_allowed_m2 = 0 + else if (nactive .eq. ndum) then + igaschem_allowed_m2 = 2 + else + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90200) 2, nactive, ndum + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + +! determine if regime 3 is allowed + nactive = 0 + ndum = 5 + if (p_iso .ge. p1st) nactive = nactive + 1 + if (p_isoprd .ge. p1st) nactive = nactive + 1 + if (p_isopp .ge. p1st) nactive = nactive + 1 + if (p_isopn .ge. p1st) nactive = nactive + 1 + if (p_isopo2 .ge. p1st) nactive = nactive + 1 + if (nactive .le. 0) then + igaschem_allowed_m3 = 0 + else if (nactive .eq. ndum) then + igaschem_allowed_m3 = 3 + else + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90200) 3, nactive, ndum + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + +! determine if regime 4 is allowed + nactive = 0 + ndum = 11 + if (p_dms .ge. p1st) nactive = nactive + 1 + if (p_msa .ge. p1st) nactive = nactive + 1 + if (p_dmso .ge. p1st) nactive = nactive + 1 + if (p_dmso2 .ge. p1st) nactive = nactive + 1 + if (p_ch3so2h .ge. p1st) nactive = nactive + 1 + if (p_ch3sch2oo .ge. p1st) nactive = nactive + 1 + if (p_ch3so2 .ge. p1st) nactive = nactive + 1 + if (p_ch3so3 .ge. p1st) nactive = nactive + 1 + if (p_ch3so2oo .ge. p1st) nactive = nactive + 1 + if (p_ch3so2ch2oo .ge. p1st) nactive = nactive + 1 + if (p_mtf .ge. p1st) nactive = nactive + 1 + if (nactive .le. 0) then + igaschem_allowed_m4 = 0 + else if (nactive .eq. ndum) then + igaschem_allowed_m4 = 4 + else + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90200) 4, nactive, ndum + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + +! regime 1 must always be allowed + if (igaschem_allowed_m1 .le. 0) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90300) 1 + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if +90300 format( ' regime ', i1, ' must always be allowed' ) + +! if regime 2 is allowed, then regime 1 must be allowed + if (igaschem_allowed_m2 .gt. 0) then + if (igaschem_allowed_m1 .le. 0) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90400) 2, 1 + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + end if +90400 format( ' regime ', i1, ' allowed BUT regime ', i1, ' unallowed' ) + +! if regime 3 is allowed, then regimes 1&2 must be allowed + if (igaschem_allowed_m3 .gt. 0) then + if (igaschem_allowed_m1 .le. 0) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90400) 3, 1 + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + else if (igaschem_allowed_m2 .le. 0) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90400) 3, 2 + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + end if + +! if regime 4 is allowed, then regime 1 must be allowed + if (igaschem_allowed_m4 .gt. 0) then + if (igaschem_allowed_m1 .le. 0) then + msg = '*** subr set_gaschem_allowed_regimes' + call peg_message( lunerr, msg ) + write(msg,90400) 4, 1 + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if + end if + + return + end subroutine set_gaschem_allowed_regimes + + + +!*********************************************************************** +! subr gasphotoconstants +! +! purpose: copy photolytic rate constants from host arrays to local array +! +!----------------------------------------------------------------------- + subroutine gasphotoconstants( rk_photo, & + i_boxtest_units_convert, & + it,jt,kt, ims,ime, jms,jme, kms,kme, & + ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, ph_hno2, & + ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, ph_ch2om, & + ph_ch3o2h, ph_n2o5 ) +! +! copies photolytic rate constants from host arrays to local arrays +! note1: currently 8 rate constants are scaled to other rate constants +! as is done in zz06gasphotolysis.f +! note2: currently the n2o5 rate is set to zero +! + use module_data_cbmz + implicit none + +! subr arguments + integer it,jt,kt, ims,ime, jms,jme, kms,kme + integer i_boxtest_units_convert + real rk_photo(nphoto) + real, dimension( ims:ime, kms:kme, jms:jme ) :: & + ph_o31d, ph_o33p, ph_no2, ph_no3o2, ph_no3o, ph_hno2, & + ph_hno3, ph_hno4, ph_h2o2, ph_ch2or, ph_ch2om, & + ph_ch3o2h, ph_n2o5 + +! local variables + real ft + + + rk_photo(:) = 0.0 + +! these from wrf/madronnich rate constants + rk_photo(jphoto_no2) = ph_no2(it,kt,jt) + rk_photo(jphoto_no3) = ph_no3o(it,kt,jt) & + + ph_no3o2(it,kt,jt) + rk_photo(jphoto_o3a) = ph_o33p(it,kt,jt) + rk_photo(jphoto_o3b) = ph_o31d(it,kt,jt) + rk_photo(jphoto_hono) = ph_hno2(it,kt,jt) + rk_photo(jphoto_hno3) = ph_hno3(it,kt,jt) + rk_photo(jphoto_hno4) = ph_hno4(it,kt,jt) + rk_photo(jphoto_h2o2) = ph_h2o2(it,kt,jt) + rk_photo(jphoto_ch3ooh) = ph_ch3o2h(it,kt,jt) + rk_photo(jphoto_hchoa) = ph_ch2or(it,kt,jt) + rk_photo(jphoto_hchob) = ph_ch2om(it,kt,jt) + rk_photo(jphoto_n2o5) = ph_n2o5(it,kt,jt) + +! these scaled to other rate constants + rk_photo(jphoto_ethooh) = 0.7 *rk_photo(jphoto_h2o2) + rk_photo(jphoto_ald2) = 4.6e-4*rk_photo(jphoto_no2) + rk_photo(jphoto_aone) = 7.8e-5*rk_photo(jphoto_no2) + rk_photo(jphoto_mgly) = 9.64 *rk_photo(jphoto_hchoa) + rk_photo(jphoto_open) = 9.04 *rk_photo(jphoto_hchoa) + rk_photo(jphoto_rooh) = 0.7 *rk_photo(jphoto_h2o2) + rk_photo(jphoto_onit) = 1.0e-4*rk_photo(jphoto_no2) + rk_photo(jphoto_isoprd) = .025 *rk_photo(jphoto_hchob) + +! convert from (1/min) to (1/s) +! (except when i_boxtest_units_convert = 10 or 20) + ft = 60.0 + if (i_boxtest_units_convert .eq. 10) ft = 1.0 + if (i_boxtest_units_convert .eq. 20) ft = 1.0 + if (ft .ne. 1.0) then + rk_photo(:) = rk_photo(:)/ft + end if + + + return + end subroutine gasphotoconstants + + + +!----------------------------------------------------------------------- + end module module_cbmz diff --git a/wrfv2_fire/chem/module_cbmz_addemiss.F b/wrfv2_fire/chem/module_cbmz_addemiss.F new file mode 100644 index 00000000..69a6d808 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz_addemiss.F @@ -0,0 +1,371 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** + +MODULE module_cbmz_addemiss +!WRF:MODEL_LAYER:CHEMICS + + + + integer, parameter :: cbmz_addemiss_masscheck = -1 + ! only do emissions masscheck calcs when this is positive + + + +CONTAINS + + + +!---------------------------------------------------------------------- + subroutine cbmz_addemiss_anthro( id, dtstep, dz8w, config_flags, & + rho_phy, chem, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! adds emissions for cbmz trace gas species +! (i.e., emissions tendencies over time dtstep are applied +! to the trace gas concentrations) +! + + USE module_configure + USE module_state_description + USE module_data_radm2 + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! trace species mixing ratios (gases=ppm) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! emissions arrays (v.1: ppm m/min; v.2: mole km^-2 hr^-1) +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh + +! layer thickness (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: dz8w, rho_phy + +! local variables + integer :: i,j,k + real, parameter :: efact1 = 1.0/60.0 + real :: conv + double precision :: chem_sum(num_chem) + + +! do mass check initial calc + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 1, 'cbmz_addemiss', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 21, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh ) + + +! +! add emissions +! + do 100 j=jts,jte + do 100 i=its,ite + + DO k=kts,min(config_flags%kemit,kte-1) +!v1 units: conv = dtstep/(dz8w(i,k,j)*60.) +!v2 units: + conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (i <= CHEM_DBG_I .and. i >= CHEM_DBG_I) .and. & + (j <= CHEM_DBG_J .and. j >= CHEM_DBG_J) .and. & + (k <= CHEM_DBG_K .and. k >= CHEM_DBG_K) ) then + print* + print*,"Converted emissions for CBMZ:" + print*,"e_csl=",e_csl(i,k,j)*conv + print*,"e_so2=",e_so2(i,k,j)*conv + print*,"e_no=",e_no(i,k,j)*conv + print*,"e_ald=",e_ald(i,k,j)*conv + print*,"e_hcho=",e_hcho(i,k,j)*conv + print*,"e_ora2=",e_ora2(i,k,j)*conv + print*,"e_nh3=",e_nh3(i,k,j)*conv + print*,"e_hc3=",e_hc3(i,k,j)*conv + print*,"e_hc5=",e_hc5(i,k,j)*conv + print*,"e_hc8=",e_hc8(i,k,j)*conv + print*,"e_eth=",e_eth(i,k,j)*conv + print*,"e_co=",e_co(i,k,j)*conv + print*,"e_ol2=",e_ol2(i,k,j)*conv + print*,"e_olt=",e_olt(i,k,j)*conv + print*,"e_oli=",e_oli(i,k,j)*conv + print*,"e_tol=",e_tol(i,k,j)*conv + print*,"e_xyl=",e_xyl(i,k,j)*conv + print*,"e_ket=",e_ket(i,k,j)*conv + end if +#endif + + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +e_csl(i,k,j)*conv + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +e_so2(i,k,j)*conv + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +e_no(i,k,j)*conv + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +e_ald(i,k,j)*conv + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +e_hcho(i,k,j)*conv + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +e_ora2(i,k,j)*conv + chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) & + +e_nh3(i,k,j)*conv + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +e_hc3(i,k,j)*conv + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +e_hc5(i,k,j)*conv + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +e_hc8(i,k,j)*conv + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +e_eth(i,k,j)*conv + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +e_co(i,k,j)*conv + chem(i,k,j,p_ol2) = chem(i,k,j,p_ol2) & + +e_ol2(i,k,j)*conv + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +e_olt(i,k,j)*conv + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +e_oli(i,k,j)*conv + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +e_tol(i,k,j)*conv + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +e_xyl(i,k,j)*conv + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +e_ket(i,k,j)*conv + +! when emissions input file is "radm2sorg" variety, calc par emissions as a +! combination of the anthropogenic emissions for radm2 primary voc species + if ( (config_flags%emiss_inpt_opt == EMISS_INPT_DEFAULT) .or. & + (config_flags%emiss_inpt_opt == EMISS_INPT_PNNL_RS) ) then + chem(i,k,j,p_par) = chem(i,k,j,p_par) & + + conv* & + ( 0.4*e_ald(i,k,j) + 2.9*e_hc3(i,k,j) & + + 4.8*e_hc5(i,k,j) + 7.9*e_hc8(i,k,j) & + + 0.9*e_ket(i,k,j) + 2.8*e_oli(i,k,j) & + + 1.8*e_olt(i,k,j) + 1.0*e_ora2(i,k,j) ) + +! when emissions input file is "cbmzmosaic" variety, +! the par emissions are read into e_hc5 +! and there are emissions for other species + else + chem(i,k,j,p_par) = chem(i,k,j,p_par) & + + conv*e_hc5(i,k,j) + + chem(i,k,j,p_no2) = chem(i,k,j,p_no2) & + + conv*e_no2(i,k,j) + chem(i,k,j,p_ch3oh) = chem(i,k,j,p_ch3oh) & + + conv*e_ch3oh(i,k,j) + chem(i,k,j,p_c2h5oh) = chem(i,k,j,p_c2h5oh) & + + conv*e_c2h5oh(i,k,j) + end if + + END DO + 100 continue + + +! do mass check final calc + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 2, 'cbmz_addemiss', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 21, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh ) + + + END subroutine cbmz_addemiss_anthro + + + +!---------------------------------------------------------------------- + subroutine cbmz_addemiss_bio( id, dtstep, dz8w, config_flags, & + rho_phy, chem, e_bio, ne_area, e_iso, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE module_state_description + USE module_data_radm2 + USE module_aerosols_sorgam + + IMPLICIT NONE + +! subr arguments + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, ne_area, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + REAL, DIMENSION( ims:ime, jms:jme,ne_area ), & + INTENT(IN ) :: e_bio + +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: e_iso + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: dz8w, rho_phy + + +! local variables + integer i,j,k,n + real, parameter :: efact1 = 1.0/60.0 + double precision :: chem_sum(num_chem) + + +! +! apply gunther online biogenic gas emissions when bio_emiss_opt == GUNTHER1 +! + if (config_flags%bio_emiss_opt == GUNTHER1) then + + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 1, 'cbmz_addemiss_bioaa', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kms, 13, & + e_bio(ims,jms,p_ald-1), e_bio(ims,jms,p_hc3-1), & + e_bio(ims,jms,p_hc5-1), e_bio(ims,jms,p_hc8-1), & + e_bio(ims,jms,p_hcho-1), e_bio(ims,jms,p_iso-1), & + e_bio(ims,jms,p_ket-1), e_bio(ims,jms,p_no-1), & + e_bio(ims,jms,p_oli-1), e_bio(ims,jms,p_olt-1), & + e_bio(ims,jms,p_ora1-1), e_bio(ims,jms,p_ora2-1), & + e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1) ) + + DO n = 1, ne_area-2 !Assumes CBMZ and RADM2 species locations match up to p_iso + do 100 j=jts,jte + do 100 i=its,ite + chem(i,kts,j,n+1) = chem(i,kts,j,n+1) & + + e_bio(i,j,n)/(dz8w(i,kts,j)*60.)*dtstep + 100 continue + enddo + +! calc par emissions as a combination of the biogenic emissions +! for radm2 primary voc species + do j = jts, jte + do i = its, ite + chem(i,kts,j,p_par) = chem(i,kts,j,p_par) & + + (dtstep/(dz8w(i,kts,j)*60.))* & + ( 0.4*e_bio(i,j,p_ald-1) + 2.9*e_bio(i,j,p_hc3-1) & + + 4.8*e_bio(i,j,p_hc5-1) + 7.9*e_bio(i,j,p_hc8-1) & + + 0.9*e_bio(i,j,p_ket-1) + 2.8*e_bio(i,j,p_oli-1) & + + 1.8*e_bio(i,j,p_olt-1) + 1.0*e_bio(i,j,p_ora2-1) ) + end do + end do + + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 2, 'cbmz_addemiss_bioaa', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kms, 13, & + e_bio(ims,jms,p_ald-1), e_bio(ims,jms,p_hc3-1), & + e_bio(ims,jms,p_hc5-1), e_bio(ims,jms,p_hc8-1), & + e_bio(ims,jms,p_hcho-1), e_bio(ims,jms,p_iso-1), & + e_bio(ims,jms,p_ket-1), e_bio(ims,jms,p_no-1), & + e_bio(ims,jms,p_oli-1), e_bio(ims,jms,p_olt-1), & + e_bio(ims,jms,p_ora1-1), e_bio(ims,jms,p_ora2-1), & + e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1), & + e_bio(ims,jms,p_xyl-1), e_bio(ims,jms,p_xyl-1) ) + + end if + + +! +! apply offline isoprene emissions when bio_emiss_opt /= GUNTHER1 +! + if (config_flags%bio_emiss_opt /= GUNTHER1) then + + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 1, 'cbmz_addemiss_biobb', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 1, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso ) + + do j = jts, jte + do k = kts, min(config_flags%kemit,kte-1) + do i = its, ite + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) + e_iso(i,k,j) & + *4.828e-4/rho_phy(i,k,j)*(dtstep/(dz8w(i,k,j)*60.)) + end do + end do + end do + + if (cbmz_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 2, 'cbmz_addemiss_biobb', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 1, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso, & + e_iso,e_iso,e_iso,e_iso,e_iso,e_iso,e_iso ) + + end if + + + END subroutine cbmz_addemiss_bio + + +END MODULE module_cbmz_addemiss + + + diff --git a/wrfv2_fire/chem/module_cbmz_initmixrats.F b/wrfv2_fire/chem/module_cbmz_initmixrats.F new file mode 100644 index 00000000..553f7439 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz_initmixrats.F @@ -0,0 +1,234 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** + module module_cbmz_initmixrats + + + use module_peg_util + + + integer, parameter :: cbmz_init_wrf_mixrats_flagaa = 1 + ! turns subr cbmz_init_wrf_mixrats on/off + + + contains + + +!----------------------------------------------------------------------- + subroutine cbmz_init_wrf_mixrats( & + config_flags, & + z_at_w, g, & + chem, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! provides initial values for cbmz gas species +! for gas species that are common to both cbmz and radm2, the initial +! values are provided via the run initialization file +! (The radm2 gas species are initialized from this file +! when chem_in_opt==anything. This ought to be changed!) +! for gas species that are in cbmz but not in radm2, the initial values +! are provided here +! currently only hcl and "par" have non-zero initial values, +! and other species are near-zero +! +! when (gas_ic_opt == gas_ic_pnnl) AND (chem_in_opt == 0), +! ozone is set to "Texas August 2000" values +! +! setting cbmz_init_wrf_mixrats_flagaa = 1/0 turns this subr on/off. +! + + USE module_configure, only: grid_config_rec_type, num_chem, & + p_o3, p_ald, p_hc3, p_hc5, p_hc8, p_ket, p_oli, p_olt, p_ora2, & + p_hcl, p_par + USE module_state_description, only: param_first_scalar, & + gas_ic_pnnl + USE module_input_chem_data, only: bdy_chem_value + + IMPLICIT NONE + + +!----------------------------------------------------------------------- +! subr arguments + + INTEGER, INTENT(IN) :: numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN) :: g + +! perturbation and base geopotential at layer boundaries + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: z_at_w + +! advected chemical tracers + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT) :: chem + + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags +!----------------------------------------------------------------------- + +! local variables + integer i, j, k, kp1 + real, dimension( its:ite, kts:kte, jts:jte ) :: z + + if (cbmz_init_wrf_mixrats_flagaa <= 0) return + +! +! calculate the mid-level heights +! + do j = jts, min(jte,jde-1) + do k = kts, kte + kp1 = min(k+1, kte) + do i = its, min(ite,ide-1) + z(i,k,j) = (z_at_w(i,k,j)+z_at_w(i,kp1,j))*0.5 + end do + end do + end do + +! +! when (gas_ic_opt == gas_ic_pnnl) AND (chem_in_opt == 0), +! set ozone (and other gas?) to "Texas August 2000" values +! + if ( (config_flags%chem_in_opt == 0) .and. & + (config_flags%gas_ic_opt == gas_ic_pnnl) ) then + do j = jts, min(jte,jde-1) + do k = kts, kte + do i = its, min(ite,ide-1) + call bdy_chem_value( chem(i,k,j,p_o3),z(i,k,j), p_o3, numgas ) + end do + end do + end do + end if + +! +! compute hcl initial mixing ratio based on the article: +! Graedel TE and WC Keene, 1995: Troposhperic budget of reactive chlorine. +! Global Biogeochemical Cycles. 9, (1), 47-77. +! This calculation should mimic the hcl profile in bdy_chem_value_cbmz, +! below. +! +! Height(m) HCl concentration +! --------- ----------------- +! <=1000 0.4 ppbv +! 1000=2500 0.1 ppbv +! + do j = jts, min(jte,jde-1) + do k = kts, kte + do i = its, min(ite,ide-1) + if( z(i,k,j) <= 1000. ) then + chem(i,k,j,p_hcl) = 0.4*1e-3 + elseif( z(i,k,j) > 1000. & + .and. z(i,k,j) <= 2500. ) then + chem(i,k,j,p_hcl) = (0.4*1e-3) + (z(i,k,j)-1000.)* & + ((0.1*1e-3)-(0.4*1e-3)) / (2500.-1000.) + else + chem(i,k,j,p_hcl) = 0.1*1e-3 + end if + end do + end do + end do + +! +! compute par initial mixing ratio from radm2 hydrocarbon species +! using same formula as for par emissions +! + do j = jts, min(jte,jde-1) + do k = kts, kte + do i = its, min(ite,ide-1) + chem(i,k,j,p_par) = & + 0.4*chem(i,k,j,p_ald) + 2.9*chem(i,k,j,p_hc3) & + + 4.8*chem(i,k,j,p_hc5) + 7.9*chem(i,k,j,p_hc8) & + + 0.9*chem(i,k,j,p_ket) + 2.8*chem(i,k,j,p_oli) & + + 1.8*chem(i,k,j,p_olt) + 1.0*chem(i,k,j,p_ora2) + end do + end do + end do + + return + end subroutine cbmz_init_wrf_mixrats + + + +!----------------------------------------------------------------------- + end module module_cbmz_initmixrats + + + +!----------------------------------------------------------------------- + subroutine bdy_chem_value_cbmz ( chem_bv, z, nch, numgas ) +! +! provides boundary values for cbmz gas species +! for gas species that are common to both cbmz and radm2, the boundary +! values are provided by subr bdy_chem_value +! for gas species that are in cbmz but not in radm2, the boundary values +! are provided here +! currently only "par" has a non-zero boundary value, +! and other species are near-zero +! +! this is outside of the module declaration because of potential +! module1 --> module2 --> module1 use conflicts +! + use module_configure, only: grid_config_rec_type, & + p_o3, p_ald, p_hc3, p_hc5, p_hc8, p_ket, p_oli, & + p_olt, p_ora2, p_hcl, p_par + use module_input_chem_data, only: bdy_chem_value + + implicit none + +! arguments + REAL, INTENT(OUT) :: chem_bv ! boundary value for chem(-,-,-,nch) + REAL, INTENT(IN) :: z ! height + INTEGER, INTENT(IN) :: nch ! index number of chemical species + INTEGER, INTENT(IN) :: numgas ! index number of last gas species +! local variables + real chem_bv_ald, chem_bv_hc3, chem_bv_hc5, & + chem_bv_hc8, chem_bv_ket, chem_bv_oli, & + chem_bv_olt, chem_bv_ora2 + real, parameter :: chem_bv_def = 1.0e-20 + + + if( nch == p_hcl ) then + !This calculation should mimic the hcl profile in + !cbmz_init_wrf_mixrats, above. + if( z <= 1000. ) then + chem_bv = 0.4*1e-3 + elseif( z > 1000. & + .and. z <= 2500. ) then + chem_bv = (0.4*1e-3) + (z-1000.)* & + ((0.1*1e-3)-(0.4*1e-3)) / (2500.-1000.) + else + chem_bv = 0.1*1e-3 + end if + + else if( nch == p_par ) then + call bdy_chem_value( chem_bv_ald, z, p_ald, numgas ) + call bdy_chem_value( chem_bv_hc3, z, p_hc3, numgas ) + call bdy_chem_value( chem_bv_hc5, z, p_hc5, numgas ) + call bdy_chem_value( chem_bv_hc8, z, p_hc8, numgas ) + call bdy_chem_value( chem_bv_ket, z, p_ket, numgas ) + call bdy_chem_value( chem_bv_oli, z, p_oli, numgas ) + call bdy_chem_value( chem_bv_olt, z, p_olt, numgas ) + call bdy_chem_value( chem_bv_ora2, z, p_ora2, numgas ) + + chem_bv = 0.4*chem_bv_ald + 2.9*chem_bv_hc3 & + + 4.8*chem_bv_hc5 + 7.9*chem_bv_hc8 & + + 0.9*chem_bv_ket + 2.8*chem_bv_oli & + + 1.8*chem_bv_olt + 1.0*chem_bv_ora2 + + else + ! chem_bv=0 for all other species + chem_bv = chem_bv_def + + end if + + return + end subroutine bdy_chem_value_cbmz diff --git a/wrfv2_fire/chem/module_cbmz_lsodes_solver.F b/wrfv2_fire/chem/module_cbmz_lsodes_solver.F new file mode 100644 index 00000000..bcec38d1 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz_lsodes_solver.F @@ -0,0 +1,5947 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** + + module module_cbmz_lsodes_solver + +!----------------------------------------------------------------------- +! 08-feb-2004 rce - this file contains a significantly modified +! version of the 11-oct-1994 netlib lsodes code +! and associated linpack routines +! converted to lowercase and fortran90 +! converted to a module +! integer variables used to store characters for error messages +! changed to character variables +! ruserpar, nruserpar, iuserpar, niuserpar argument added - +! they are "user parameters" that are passed through to "subroutine f" +!----------------------------------------------------------------------- +! 18-mar-2006 rce - +! encountering a situation with overflow in function vnorm, +! when called from lsodes_solver after label 160 +! first, tried to modify the vnorm code so that it would +! scale the v(i)*w(i) when doing sum-of-squares. +! Seemed like a good idea, but this just caused problems elsewhere +! second, added iok_vnorm coding as a bandaid +! in vnorm, if any v(i)*w(i) > 1.0e18, then vnorm +! is set to 1.0e18 and iok_vnorm to -1 +! in lsodes_solver, after vnorm call near label 160, +! iok_vnorm is tested, and "-1" causes a return +! with istate=-901 +! elsewhere in lsodes_solver, before each return, +! iok_vnorm is tested, and "-1" causes istate=-91x +!----------------------------------------------------------------------- +! 18-mar-2006 rce - +! subr r1mach - replaced the integer data statements used to +! define rmach(1:5) with real*4 data statements +! to avoid possible problems on mpp2 +! also added code to define rmach(1:5) using the +! tiny, huge, spacing, epsilon, & log10 intrinsic functions, +! BUT this code is currently commented out +!----------------------------------------------------------------------- + + + contains + + +!ZZ +! +! Obtained Oct 11, 1994 from ODEPACK in NETLIB by RDS + subroutine lsodes_solver ( & + f, neq, y, t, tout, itol, rtol, atol, itask, & + istate, iopt, rwork, lrw, iwork, liw, jac, mf, & + ruserpar, nruserpar, iuserpar, niuserpar ) + external f, jac + integer neq, itol, itask, istate, iopt, lrw, iwork, liw, mf + integer nruserpar, iuserpar, niuserpar + real y, t, tout, rtol, atol, rwork + real ruserpar +!jdf dimension neq(1), y(1), rtol(1), atol(1), rwork(lrw), iwork(liw) + dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw) + dimension ruserpar(nruserpar), iuserpar(niuserpar) +!----------------------------------------------------------------------- +! this is the march 30, 1987 version of +! lsodes.. livermore solver for ordinary differential equations +! with general sparse jacobian matrices. +! this version is in single precision. +! +! lsodes solves the initial value problem for stiff or nonstiff +! systems of first order ode-s, +! dy/dt = f(t,y) , or, in component form, +! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(neq)) (i = 1,...,neq). +! lsodes is a variant of the lsode package, and is intended for +! problems in which the jacobian matrix df/dy has an arbitrary +! sparse structure (when the problem is stiff). +! +! authors.. alan c. hindmarsh, +! computing and mathematics research division, l-316 +! lawrence livermore national laboratory +! livermore, ca 94550. +! +! and andrew h. sherman +! j. s. nolen and associates +! houston, tx 77084 +!----------------------------------------------------------------------- +! references.. +! 1. alan c. hindmarsh, odepack, a systematized collection of ode +! solvers, in scientific computing, r. s. stepleman et al. (eds.), +! north-holland, amsterdam, 1983, pp. 55-64. +! +! 2. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, +! yale sparse matrix package.. i. the symmetric codes, +! int. j. num. meth. eng., 18 (1982), pp. 1145-1151. +! +! 3. s. c. eisenstat, m. c. gursky, m. h. schultz, and a. h. sherman, +! yale sparse matrix package.. ii. the nonsymmetric codes, +! research report no. 114, dept. of computer sciences, yale +! university, 1977. +!----------------------------------------------------------------------- +! summary of usage. +! +! communication between the user and the lsodes package, for normal +! situations, is summarized here. this summary describes only a subset +! of the full set of options available. see the full description for +! details, including optional communication, nonstandard options, +! and instructions for special situations. see also the example +! problem (with program and output) following this summary. +! +! a. first provide a subroutine of the form.. +! subroutine f (neq, t, y, ydot) +! dimension y(neq), ydot(neq) +! which supplies the vector function f by loading ydot(i) with f(i). +! +! b. next determine (or guess) whether or not the problem is stiff. +! stiffness occurs when the jacobian matrix df/dy has an eigenvalue +! whose real part is negative and large in magnitude, compared to the +! reciprocal of the t span of interest. if the problem is nonstiff, +! use a method flag mf = 10. if it is stiff, there are two standard +! for the method flag, mf = 121 and mf = 222. in both cases, lsodes +! requires the jacobian matrix in some form, and it treats this matrix +! in general sparse form, with sparsity structure determined internally. +! (for options where the user supplies the sparsity structure, see +! the full description of mf below.) +! +! c. if the problem is stiff, you are encouraged to supply the jacobian +! directly (mf = 121), but if this is not feasible, lsodes will +! compute it internally by difference quotients (mf = 222). +! if you are supplying the jacobian, provide a subroutine of the form.. +! subroutine jac (neq, t, y, j, ian, jan, pdj) +! dimension y(1), ian(1), jan(1), pdj(1) +! here neq, t, y, and j are input arguments, and the jac routine is to +! load the array pdj (of length neq) with the j-th column of df/dy. +! i.e., load pdj(i) with df(i)/dy(j) for all relevant values of i. +! the arguments ian and jan should be ignored for normal situations. +! lsodes will call the jac routine with j = 1,2,...,neq. +! only nonzero elements need be loaded. usually, a crude approximation +! to df/dy, possibly with fewer nonzero elements, will suffice. +! +! d. write a main program which calls subroutine lsodes once for +! each point at which answers are desired. this should also provide +! for possible use of logical unit 6 for output of error messages +! by lsodes. on the first call to lsodes, supply arguments as follows.. +! f = name of subroutine for right-hand side vector f. +! this name must be declared external in calling program. +! neq = number of first order ode-s. +! y = array of initial values, of length neq. +! t = the initial value of the independent variable. +! tout = first point where output is desired (.ne. t). +! itol = 1 or 2 according as atol (below) is a scalar or array. +! rtol = relative tolerance parameter (scalar). +! atol = absolute tolerance parameter (scalar or array). +! the estimated local error in y(i) will be controlled so as +! to be roughly less (in magnitude) than +! ewt(i) = rtol*abs(y(i)) + atol if itol = 1, or +! ewt(i) = rtol*abs(y(i)) + atol(i) if itol = 2. +! thus the local error test passes if, in each component, +! either the absolute error is less than atol (or atol(i)), +! or the relative error is less than rtol. +! use rtol = 0.0 for pure absolute error control, and +! use atol = 0.0 (or atol(i) = 0.0) for pure relative error +! control. caution.. actual (global) errors may exceed these +! local tolerances, so choose them conservatively. +! itask = 1 for normal computation of output values of y at t = tout. +! istate = integer flag (input and output). set istate = 1. +! iopt = 0 to indicate no optional inputs used. +! rwork = real work array of length at least.. +! 20 + 16*neq for mf = 10, +! 20 + (2 + 1./lenrat)*nnz + (11 + 9./lenrat)*neq +! for mf = 121 or 222, +! where.. +! nnz = the number of nonzero elements in the sparse +! jacobian (if this is unknown, use an estimate), and +! lenrat = the real to integer wordlength ratio (usually 1 in +! single precision and 2 in double precision). +! in any case, the required size of rwork cannot generally +! be predicted in advance if mf = 121 or 222, and the value +! above is a rough estimate of a crude lower bound. some +! experimentation with this size may be necessary. +! (when known, the correct required length is an optional +! output, available in iwork(17).) +! lrw = declared length of rwork (in user-s dimension). +! iwork = integer work array of length at least 30. +! liw = declared length of iwork (in user-s dimension). +! jac = name of subroutine for jacobian matrix (mf = 121). +! if used, this name must be declared external in calling +! program. if not used, pass a dummy name. +! mf = method flag. standard values are.. +! 10 for nonstiff (adams) method, no jacobian used. +! 121 for stiff (bdf) method, user-supplied sparse jacobian. +! 222 for stiff method, internally generated sparse jacobian. +! note that the main program must declare arrays y, rwork, iwork, +! and possibly atol. +! +! e. the output from the first call (or any call) is.. +! y = array of computed values of y(t) vector. +! t = corresponding value of independent variable (normally tout). +! istate = 2 if lsodes was successful, negative otherwise. +! -1 means excess work done on this call (perhaps wrong mf). +! -2 means excess accuracy requested (tolerances too small). +! -3 means illegal input detected (see printed message). +! -4 means repeated error test failures (check all inputs). +! -5 means repeated convergence failures (perhaps bad jacobian +! supplied or wrong choice of mf or tolerances). +! -6 means error weight became zero during problem. (solution +! component i vanished, and atol or atol(i) = 0.) +! -7 means a fatal error return flag came from the sparse +! solver cdrv by way of prjs or slss. should never happen. +! a return with istate = -1, -4, or -5 may result from using +! an inappropriate sparsity structure, one that is quite +! different from the initial structure. consider calling +! lsodes again with istate = 3 to force the structure to be +! reevaluated. see the full description of istate below. +! +! f. to continue the integration after a successful return, simply +! reset tout and call lsodes again. no other parameters need be reset. +! +!----------------------------------------------------------------------- +! example problem. +! +! the following is a simple example problem, with the coding +! needed for its solution by lsodes. the problem is from chemical +! kinetics, and consists of the following 12 rate equations.. +! dy1/dt = -rk1*y1 +! dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 +! - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 +! dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 +! + rk11*rk14*y4 + rk12*rk14*y6 +! dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 +! dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 +! dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 +! dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 +! dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 +! dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 +! dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 +! + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 +! - rk6*y10 - rk9*y10 +! dy11/dt = rk10*y8 +! dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 +! - rk15*y2*y12 - rk17*y10*y12 +! +! with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, +! rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, +! rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, +! rk15 = rk17 = 100.0. +! +! the t interval is from 0 to 1000, and the initial conditions +! are y1 = 1, y2 = y3 = ... = y12 = 0. the problem is stiff. +! +! the following coding solves this problem with lsodes, using mf = 121 +! and printing results at t = .1, 1., 10., 100., 1000. it uses +! itol = 1 and mixed relative/absolute tolerance controls. +! during the run and at the end, statistical quantities of interest +! are printed (see optional outputs in the full description below). +! +! external fex, jex +! dimension y(12), rwork(500), iwork(30) +! data lrw/500/, liw/30/ +! neq = 12 +! do 10 i = 1,neq +! 10 y(i) = 0.0e0 +! y(1) = 1.0e0 +! t = 0.0e0 +! tout = 0.1e0 +! itol = 1 +! rtol = 1.0e-4 +! atol = 1.0e-6 +! itask = 1 +! istate = 1 +! iopt = 0 +! mf = 121 +! do 40 iout = 1,5 +! call lsodes (fex, neq, y, t, tout, itol, rtol, atol, +! 1 itask, istate, iopt, rwork, lrw, iwork, liw, jex, mf) +! write(6,30)t,iwork(11),rwork(11),(y(i),i=1,neq) +! 30 format(//7h at t =,e11.3,4x, +! 1 12h no. steps =,i5,4x,12h last step =,e11.3/ +! 2 13h y array = ,4e14.5/13x,4e14.5/13x,4e14.5) +! if (istate .lt. 0) go to 80 +! tout = tout*10.0e0 +! 40 continue +! lenrw = iwork(17) +! leniw = iwork(18) +! nst = iwork(11) +! nfe = iwork(12) +! nje = iwork(13) +! nlu = iwork(21) +! nnz = iwork(19) +! nnzlu = iwork(25) + iwork(26) + neq +! write (6,70) lenrw,leniw,nst,nfe,nje,nlu,nnz,nnzlu +! 70 format(//22h required rwork size =,i4,15h iwork size =,i4/ +! 1 12h no. steps =,i4,12h no. f-s =,i4,12h no. j-s =,i4, +! 2 13h no. lu-s =,i4/23h no. of nonzeros in j =,i5, +! 3 26h no. of nonzeros in lu =,i5) +! stop +! 80 write(6,90)istate +! 90 format(///22h error halt.. istate =,i3) +! stop +! end +! +! subroutine fex (neq, t, y, ydot) +! real t, y, ydot +! real rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, +! 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 +! dimension y(12), ydot(12) +! data rk1/0.1e0/, rk2/10.0e0/, rk3/50.0e0/, rk4/2.5e0/, rk5/0.1e0/, +! 1 rk6/10.0e0/, rk7/50.0e0/, rk8/2.5e0/, rk9/50.0e0/, rk10/5.0e0/, +! 2 rk11/50.0e0/, rk12/50.0e0/, rk13/50.0e0/, rk14/30.0e0/, +! 3 rk15/100.0e0/, rk16/2.5e0/, rk17/100.0e0/, rk18/2.5e0/, +! 4 rk19/50.0e0/, rk20/50.0e0/ +! ydot(1) = -rk1*y(1) +! ydot(2) = rk1*y(1) + rk11*rk14*y(4) + rk19*rk14*y(5) +! 1 - rk3*y(2)*y(3) - rk15*y(2)*y(12) - rk2*y(2) +! ydot(3) = rk2*y(2) - rk5*y(3) - rk3*y(2)*y(3) - rk7*y(10)*y(3) +! 1 + rk11*rk14*y(4) + rk12*rk14*y(6) +! ydot(4) = rk3*y(2)*y(3) - rk11*rk14*y(4) - rk4*y(4) +! ydot(5) = rk15*y(2)*y(12) - rk19*rk14*y(5) - rk16*y(5) +! ydot(6) = rk7*y(10)*y(3) - rk12*rk14*y(6) - rk8*y(6) +! ydot(7) = rk17*y(10)*y(12) - rk20*rk14*y(7) - rk18*y(7) +! ydot(8) = rk9*y(10) - rk13*rk14*y(8) - rk10*y(8) +! ydot(9) = rk4*y(4) + rk16*y(5) + rk8*y(6) + rk18*y(7) +! ydot(10) = rk5*y(3) + rk12*rk14*y(6) + rk20*rk14*y(7) +! 1 + rk13*rk14*y(8) - rk7*y(10)*y(3) - rk17*y(10)*y(12) +! 2 - rk6*y(10) - rk9*y(10) +! ydot(11) = rk10*y(8) +! ydot(12) = rk6*y(10) + rk19*rk14*y(5) + rk20*rk14*y(7) +! 1 - rk15*y(2)*y(12) - rk17*y(10)*y(12) +! return +! end +! +! subroutine jex (neq, t, y, j, ia, ja, pdj) +! real t, y, pdj +! real rk1, rk2, rk3, rk4, rk5, rk6, rk7, rk8, rk9, +! 1 rk10, rk11, rk12, rk13, rk14, rk15, rk16, rk17 +! dimension y(1), ia(1), ja(1), pdj(1) +! data rk1/0.1e0/, rk2/10.0e0/, rk3/50.0e0/, rk4/2.5e0/, rk5/0.1e0/, +! 1 rk6/10.0e0/, rk7/50.0e0/, rk8/2.5e0/, rk9/50.0e0/, rk10/5.0e0/, +! 2 rk11/50.0e0/, rk12/50.0e0/, rk13/50.0e0/, rk14/30.0e0/, +! 3 rk15/100.0e0/, rk16/2.5e0/, rk17/100.0e0/, rk18/2.5e0/, +! 4 rk19/50.0e0/, rk20/50.0e0/ +! go to (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), j +! 1 pdj(1) = -rk1 +! pdj(2) = rk1 +! return +! 2 pdj(2) = -rk3*y(3) - rk15*y(12) - rk2 +! pdj(3) = rk2 - rk3*y(3) +! pdj(4) = rk3*y(3) +! pdj(5) = rk15*y(12) +! pdj(12) = -rk15*y(12) +! return +! 3 pdj(2) = -rk3*y(2) +! pdj(3) = -rk5 - rk3*y(2) - rk7*y(10) +! pdj(4) = rk3*y(2) +! pdj(6) = rk7*y(10) +! pdj(10) = rk5 - rk7*y(10) +! return +! 4 pdj(2) = rk11*rk14 +! pdj(3) = rk11*rk14 +! pdj(4) = -rk11*rk14 - rk4 +! pdj(9) = rk4 +! return +! 5 pdj(2) = rk19*rk14 +! pdj(5) = -rk19*rk14 - rk16 +! pdj(9) = rk16 +! pdj(12) = rk19*rk14 +! return +! 6 pdj(3) = rk12*rk14 +! pdj(6) = -rk12*rk14 - rk8 +! pdj(9) = rk8 +! pdj(10) = rk12*rk14 +! return +! 7 pdj(7) = -rk20*rk14 - rk18 +! pdj(9) = rk18 +! pdj(10) = rk20*rk14 +! pdj(12) = rk20*rk14 +! return +! 8 pdj(8) = -rk13*rk14 - rk10 +! pdj(10) = rk13*rk14 +! pdj(11) = rk10 +! 9 return +! 10 pdj(3) = -rk7*y(3) +! pdj(6) = rk7*y(3) +! pdj(7) = rk17*y(12) +! pdj(8) = rk9 +! pdj(10) = -rk7*y(3) - rk17*y(12) - rk6 - rk9 +! pdj(12) = rk6 - rk17*y(12) +! 11 return +! 12 pdj(2) = -rk15*y(2) +! pdj(5) = rk15*y(2) +! pdj(7) = rk17*y(10) +! pdj(10) = -rk17*y(10) +! pdj(12) = -rk15*y(2) - rk17*y(10) +! return +! end +! +! the output of this program (on a cray-1 in single precision) +! is as follows.. +! +! +! at t = 1.000e-01 no. steps = 12 last step = 1.515e-02 +! y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 +! 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 +! 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 +! +! +! at t = 1.000e+00 no. steps = 33 last step = 7.880e-02 +! y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 +! 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 +! 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 +! +! +! at t = 1.000e+01 no. steps = 48 last step = 1.239e+00 +! y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 +! 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 +! 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 +! +! +! at t = 1.000e+02 no. steps = 91 last step = 3.764e+00 +! y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 +! 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 +! 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 +! +! +! at t = 1.000e+03 no. steps = 111 last step = 4.156e+02 +! y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 +! -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 +! 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 +! +! +! required rwork size = 442 iwork size = 30 +! no. steps = 111 no. f-s = 142 no. j-s = 2 no. lu-s = 20 +! no. of nonzeros in j = 44 no. of nonzeros in lu = 50 +!----------------------------------------------------------------------- +! full description of user interface to lsodes. +! +! the user interface to lsodes consists of the following parts. +! +! i. the call sequence to subroutine lsodes, which is a driver +! routine for the solver. this includes descriptions of both +! the call sequence arguments and of user-supplied routines. +! following these descriptions is a description of +! optional inputs available through the call sequence, and then +! a description of optional outputs (in the work arrays). +! +! ii. descriptions of other routines in the lsodes package that may be +! (optionally) called by the user. these provide the ability to +! alter error message handling, save and restore the internal +! common, and obtain specified derivatives of the solution y(t). +! +! iii. descriptions of common blocks to be declared in overlay +! or similar environments, or to be saved when doing an interrupt +! of the problem and continued solution later. +! +! iv. description of two routines in the lsodes package, either of +! which the user may replace with his own version, if desired. +! these relate to the measurement of errors. +! +!----------------------------------------------------------------------- +! part i. call sequence. +! +! the call sequence parameters used for input only are +! f, neq, tout, itol, rtol, atol, itask, iopt, lrw, liw, jac, mf, +! and those used for both input and output are +! y, t, istate. +! the work arrays rwork and iwork are also used for conditional and +! optional inputs and optional outputs. (the term output here refers +! to the return from subroutine lsodes to the user-s calling program.) +! +! the legality of input parameters will be thoroughly checked on the +! initial call for the problem, but not checked thereafter unless a +! change in input parameters is flagged by istate = 3 on input. +! +! the descriptions of the call arguments are as follows. +! +! f = the name of the user-supplied subroutine defining the +! ode system. the system must be put in the first-order +! form dy/dt = f(t,y), where f is a vector-valued function +! of the scalar t and the vector y. subroutine f is to +! compute the function f. it is to have the form +! subroutine f (neq, t, y, ydot) +! dimension y(1), ydot(1) +! where neq, t, and y are input, and the array ydot = f(t,y) +! is output. y and ydot are arrays of length neq. +! (in the dimension statement above, 1 is a dummy +! dimension.. it can be replaced by any value.) +! subroutine f should not alter y(1),...,y(neq). +! f must be declared external in the calling program. +! +! subroutine f may access user-defined quantities in +! neq(2),... and/or in y(neq(1)+1),... if neq is an array +! (dimensioned in f) and/or y has length exceeding neq(1). +! see the descriptions of neq and y below. +! +! if quantities computed in the f routine are needed +! externally to lsodes, an extra call to f should be made +! for this purpose, for consistent and accurate results. +! if only the derivative dy/dt is needed, use intdy instead. +! +! neq = the size of the ode system (number of first order +! ordinary differential equations). used only for input. +! neq may be decreased, but not increased, during the problem. +! if neq is decreased (with istate = 3 on input), the +! remaining components of y should be left undisturbed, if +! these are to be accessed in f and/or jac. +! +! normally, neq is a scalar, and it is generally referred to +! as a scalar in this user interface description. however, +! neq may be an array, with neq(1) set to the system size. +! (the lsodes package accesses only neq(1).) in either case, +! this parameter is passed as the neq argument in all calls +! to f and jac. hence, if it is an array, locations +! neq(2),... may be used to store other integer data and pass +! it to f and/or jac. subroutines f and/or jac must include +! neq in a dimension statement in that case. +! +! y = a real array for the vector of dependent variables, of +! length neq or more. used for both input and output on the +! first call (istate = 1), and only for output on other calls. +! on the first call, y must contain the vector of initial +! values. on output, y contains the computed solution vector, +! evaluated at t. if desired, the y array may be used +! for other purposes between calls to the solver. +! +! this array is passed as the y argument in all calls to +! f and jac. hence its length may exceed neq, and locations +! y(neq+1),... may be used to store other real data and +! pass it to f and/or jac. (the lsodes package accesses only +! y(1),...,y(neq).) +! +! t = the independent variable. on input, t is used only on the +! first call, as the initial point of the integration. +! on output, after each call, t is the value at which a +! computed solution y is evaluated (usually the same as tout). +! on an error return, t is the farthest point reached. +! +! tout = the next value of t at which a computed solution is desired. +! used only for input. +! +! when starting the problem (istate = 1), tout may be equal +! to t for one call, then should .ne. t for the next call. +! for the initial t, an input value of tout .ne. t is used +! in order to determine the direction of the integration +! (i.e. the algebraic sign of the step sizes) and the rough +! scale of the problem. integration in either direction +! (forward or backward in t) is permitted. +! +! if itask = 2 or 5 (one-step modes), tout is ignored after +! the first call (i.e. the first call with tout .ne. t). +! otherwise, tout is required on every call. +! +! if itask = 1, 3, or 4, the values of tout need not be +! monotone, but a value of tout which backs up is limited +! to the current internal t interval, whose endpoints are +! tcur - hu and tcur (see optional outputs, below, for +! tcur and hu). +! +! itol = an indicator for the type of error control. see +! description below under atol. used only for input. +! +! rtol = a relative error tolerance parameter, either a scalar or +! an array of length neq. see description below under atol. +! input only. +! +! atol = an absolute error tolerance parameter, either a scalar or +! an array of length neq. input only. +! +! the input parameters itol, rtol, and atol determine +! the error control performed by the solver. the solver will +! control the vector e = (e(i)) of estimated local errors +! in y, according to an inequality of the form +! rms-norm of ( e(i)/ewt(i) ) .le. 1, +! where ewt(i) = rtol(i)*abs(y(i)) + atol(i), +! and the rms-norm (root-mean-square norm) here is +! rms-norm(v) = sqrt(sum v(i)**2 / neq). here ewt = (ewt(i)) +! is a vector of weights which must always be positive, and +! the values of rtol and atol should all be non-negative. +! the following table gives the types (scalar/array) of +! rtol and atol, and the corresponding form of ewt(i). +! +! itol rtol atol ewt(i) +! 1 scalar scalar rtol*abs(y(i)) + atol +! 2 scalar array rtol*abs(y(i)) + atol(i) +! 3 array scalar rtol(i)*abs(y(i)) + atol +! 4 array array rtol(i)*abs(y(i)) + atol(i) +! +! when either of these parameters is a scalar, it need not +! be dimensioned in the user-s calling program. +! +! if none of the above choices (with itol, rtol, and atol +! fixed throughout the problem) is suitable, more general +! error controls can be obtained by substituting +! user-supplied routines for the setting of ewt and/or for +! the norm calculation. see part iv below. +! +! if global errors are to be estimated by making a repeated +! run on the same problem with smaller tolerances, then all +! components of rtol and atol (i.e. of ewt) should be scaled +! down uniformly. +! +! itask = an index specifying the task to be performed. +! input only. itask has the following values and meanings. +! 1 means normal computation of output values of y(t) at +! t = tout (by overshooting and interpolating). +! 2 means take one step only and return. +! 3 means stop at the first internal mesh point at or +! beyond t = tout and return. +! 4 means normal computation of output values of y(t) at +! t = tout but without overshooting t = tcrit. +! tcrit must be input as rwork(1). tcrit may be equal to +! or beyond tout, but not behind it in the direction of +! integration. this option is useful if the problem +! has a singularity at or beyond t = tcrit. +! 5 means take one step, without passing tcrit, and return. +! tcrit must be input as rwork(1). +! +! note.. if itask = 4 or 5 and the solver reaches tcrit +! (within roundoff), it will return t = tcrit (exactly) to +! indicate this (unless itask = 4 and tout comes before tcrit, +! in which case answers at t = tout are returned first). +! +! istate = an index used for input and output to specify the +! the state of the calculation. +! +! on input, the values of istate are as follows. +! 1 means this is the first call for the problem +! (initializations will be done). see note below. +! 2 means this is not the first call, and the calculation +! is to continue normally, with no change in any input +! parameters except possibly tout and itask. +! (if itol, rtol, and/or atol are changed between calls +! with istate = 2, the new values will be used but not +! tested for legality.) +! 3 means this is not the first call, and the +! calculation is to continue normally, but with +! a change in input parameters other than +! tout and itask. changes are allowed in +! neq, itol, rtol, atol, iopt, lrw, liw, mf, +! the conditional inputs ia and ja, +! and any of the optional inputs except h0. +! in particular, if miter = 1 or 2, a call with istate = 3 +! will cause the sparsity structure of the problem to be +! recomputed (or reread from ia and ja if moss = 0). +! note.. a preliminary call with tout = t is not counted +! as a first call here, as no initialization or checking of +! input is done. (such a call is sometimes useful for the +! purpose of outputting the initial conditions.) +! thus the first call for which tout .ne. t requires +! istate = 1 on input. +! +! on output, istate has the following values and meanings. +! 1 means nothing was done, as tout was equal to t with +! istate = 1 on input. (however, an internal counter was +! set to detect and prevent repeated calls of this type.) +! 2 means the integration was performed successfully. +! -1 means an excessive amount of work (more than mxstep +! steps) was done on this call, before completing the +! requested task, but the integration was otherwise +! successful as far as t. (mxstep is an optional input +! and is normally 500.) to continue, the user may +! simply reset istate to a value .gt. 1 and call again +! (the excess work step counter will be reset to 0). +! in addition, the user may increase mxstep to avoid +! this error return (see below on optional inputs). +! -2 means too much accuracy was requested for the precision +! of the machine being used. this was detected before +! completing the requested task, but the integration +! was successful as far as t. to continue, the tolerance +! parameters must be reset, and istate must be set +! to 3. the optional output tolsf may be used for this +! purpose. (note.. if this condition is detected before +! taking any steps, then an illegal input return +! (istate = -3) occurs instead.) +! -3 means illegal input was detected, before taking any +! integration steps. see written message for details. +! note.. if the solver detects an infinite loop of calls +! to the solver with illegal input, it will cause +! the run to stop. +! -4 means there were repeated error test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! the problem may have a singularity, or the input +! may be inappropriate. +! -5 means there were repeated convergence test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! this may be caused by an inaccurate jacobian matrix, +! if one is being used. +! -6 means ewt(i) became zero for some i during the +! integration. pure relative error control (atol(i)=0.0) +! was requested on a variable which has now vanished. +! the integration was successful as far as t. +! -7 means a fatal error return flag came from the sparse +! solver cdrv by way of prjs or slss (numerical +! factorization or backsolve). this should never happen. +! the integration was successful as far as t. +! +! note.. an error return with istate = -1, -4, or -5 and with +! miter = 1 or 2 may mean that the sparsity structure of the +! problem has changed significantly since it was last +! determined (or input). in that case, one can attempt to +! complete the integration by setting istate = 3 on the next +! call, so that a new structure determination is done. +! +! note.. since the normal output value of istate is 2, +! it does not need to be reset for normal continuation. +! also, since a negative input value of istate will be +! regarded as illegal, a negative output value requires the +! user to change it, and possibly other inputs, before +! calling the solver again. +! +! iopt = an integer flag to specify whether or not any optional +! inputs are being used on this call. input only. +! the optional inputs are listed separately below. +! iopt = 0 means no optional inputs are being used. +! default values will be used in all cases. +! iopt = 1 means one or more optional inputs are being used. +! +! rwork = a work array used for a mixture of real (single precision) +! and integer work space. +! the length of rwork (in real words) must be at least +! 20 + nyh*(maxord + 1) + 3*neq + lwm where +! nyh = the initial value of neq, +! maxord = 12 (if meth = 1) or 5 (if meth = 2) (unless a +! smaller value is given as an optional input), +! lwm = 0 if miter = 0, +! lwm = 2*nnz + 2*neq + (nnz+9*neq)/lenrat if miter = 1, +! lwm = 2*nnz + 2*neq + (nnz+10*neq)/lenrat if miter = 2, +! lwm = neq + 2 if miter = 3. +! in the above formulas, +! nnz = number of nonzero elements in the jacobian matrix. +! lenrat = the real to integer wordlength ratio (usually 1 in +! single precision and 2 in double precision). +! (see the mf description for meth and miter.) +! thus if maxord has its default value and neq is constant, +! the minimum length of rwork is.. +! 20 + 16*neq for mf = 10, +! 20 + 16*neq + lwm for mf = 11, 111, 211, 12, 112, 212, +! 22 + 17*neq for mf = 13, +! 20 + 9*neq for mf = 20, +! 20 + 9*neq + lwm for mf = 21, 121, 221, 22, 122, 222, +! 22 + 10*neq for mf = 23. +! if miter = 1 or 2, the above formula for lwm is only a +! crude lower bound. the required length of rwork cannot +! be readily predicted in general, as it depends on the +! sparsity structure of the problem. some experimentation +! may be necessary. +! +! the first 20 words of rwork are reserved for conditional +! and optional inputs and optional outputs. +! +! the following word in rwork is a conditional input.. +! rwork(1) = tcrit = critical value of t which the solver +! is not to overshoot. required if itask is +! 4 or 5, and ignored otherwise. (see itask.) +! +! lrw = the length of the array rwork, as declared by the user. +! (this will be checked by the solver.) +! +! iwork = an integer work array. the length of iwork must be at least +! 31 + neq + nnz if moss = 0 and miter = 1 or 2, or +! 30 otherwise. +! (nnz is the number of nonzero elements in df/dy.) +! +! in lsodes, iwork is used only for conditional and +! optional inputs and optional outputs. +! +! the following two blocks of words in iwork are conditional +! inputs, required if moss = 0 and miter = 1 or 2, but not +! otherwise (see the description of mf for moss). +! iwork(30+j) = ia(j) (j=1,...,neq+1) +! iwork(31+neq+k) = ja(k) (k=1,...,nnz) +! the two arrays ia and ja describe the sparsity structure +! to be assumed for the jacobian matrix. ja contains the row +! indices where nonzero elements occur, reading in columnwise +! order, and ia contains the starting locations in ja of the +! descriptions of columns 1,...,neq, in that order, with +! ia(1) = 1. thus, for each column index j = 1,...,neq, the +! values of the row index i in column j where a nonzero +! element may occur are given by +! i = ja(k), where ia(j) .le. k .lt. ia(j+1). +! if nnz is the total number of nonzero locations assumed, +! then the length of the ja array is nnz, and ia(neq+1) must +! be nnz + 1. duplicate entries are not allowed. +! +! liw = the length of the array iwork, as declared by the user. +! (this will be checked by the solver.) +! +! note.. the work arrays must not be altered between calls to lsodes +! for the same problem, except possibly for the conditional and +! optional inputs, and except for the last 3*neq words of rwork. +! the latter space is used for internal scratch space, and so is +! available for use by the user outside lsodes between calls, if +! desired (but not for use by f or jac). +! +! jac = name of user-supplied routine (miter = 1 or moss = 1) to +! compute the jacobian matrix, df/dy, as a function of +! the scalar t and the vector y. it is to have the form +! subroutine jac (neq, t, y, j, ian, jan, pdj) +! dimension y(1), ian(1), jan(1), pdj(1) +! where neq, t, y, j, ian, and jan are input, and the array +! pdj, of length neq, is to be loaded with column j +! of the jacobian on output. thus df(i)/dy(j) is to be +! loaded into pdj(i) for all relevant values of i. +! here t and y have the same meaning as in subroutine f, +! and j is a column index (1 to neq). ian and jan are +! undefined in calls to jac for structure determination +! (moss = 1). otherwise, ian and jan are structure +! descriptors, as defined under optional outputs below, and +! so can be used to determine the relevant row indices i, if +! desired. (in the dimension statement above, 1 is a +! dummy dimension.. it can be replaced by any value.) +! jac need not provide df/dy exactly. a crude +! approximation (possibly with greater sparsity) will do. +! in any case, pdj is preset to zero by the solver, +! so that only the nonzero elements need be loaded by jac. +! calls to jac are made with j = 1,...,neq, in that order, and +! each such set of calls is preceded by a call to f with the +! same arguments neq, t, and y. thus to gain some efficiency, +! intermediate quantities shared by both calculations may be +! saved in a user common block by f and not recomputed by jac, +! if desired. jac must not alter its input arguments. +! jac must be declared external in the calling program. +! subroutine jac may access user-defined quantities in +! neq(2),... and/or in y(neq(1)+1),... if neq is an array +! (dimensioned in jac) and/or y has length exceeding neq(1). +! see the descriptions of neq and y above. +! +! mf = the method flag. used only for input. +! mf has three decimal digits-- moss, meth, miter-- +! mf = 100*moss + 10*meth + miter. +! moss indicates the method to be used to obtain the sparsity +! structure of the jacobian matrix if miter = 1 or 2.. +! moss = 0 means the user has supplied ia and ja +! (see descriptions under iwork above). +! moss = 1 means the user has supplied jac (see below) +! and the structure will be obtained from neq +! initial calls to jac. +! moss = 2 means the structure will be obtained from neq+1 +! initial calls to f. +! meth indicates the basic linear multistep method.. +! meth = 1 means the implicit adams method. +! meth = 2 means the method based on backward +! differentiation formulas (bdf-s). +! miter indicates the corrector iteration method.. +! miter = 0 means functional iteration (no jacobian matrix +! is involved). +! miter = 1 means chord iteration with a user-supplied +! sparse jacobian, given by subroutine jac. +! miter = 2 means chord iteration with an internally +! generated (difference quotient) sparse jacobian +! (using ngp extra calls to f per df/dy value, +! where ngp is an optional output described below.) +! miter = 3 means chord iteration with an internally +! generated diagonal jacobian approximation. +! (using 1 extra call to f per df/dy evaluation). +! if miter = 1 or moss = 1, the user must supply a subroutine +! jac (the name is arbitrary) as described above under jac. +! otherwise, a dummy argument can be used. +! +! the standard choices for mf are.. +! mf = 10 for a nonstiff problem, +! mf = 21 or 22 for a stiff problem with ia/ja supplied +! (21 if jac is supplied, 22 if not), +! mf = 121 for a stiff problem with jac supplied, +! but not ia/ja, +! mf = 222 for a stiff problem with neither ia/ja nor +! jac supplied. +! the sparseness structure can be changed during the +! problem by making a call to lsodes with istate = 3. +!----------------------------------------------------------------------- +! optional inputs. +! +! the following is a list of the optional inputs provided for in the +! call sequence. (see also part ii.) for each such input variable, +! this table lists its name as used in this documentation, its +! location in the call sequence, its meaning, and the default value. +! the use of any of these inputs requires iopt = 1, and in that +! case all of these inputs are examined. a value of zero for any +! of these optional inputs will cause the default value to be used. +! thus to use a subset of the optional inputs, simply preload +! locations 5 to 10 in rwork and iwork to 0.0 and 0 respectively, and +! then set those of interest to nonzero values. +! +! name location meaning and default value +! +! h0 rwork(5) the step size to be attempted on the first step. +! the default value is determined by the solver. +! +! hmax rwork(6) the maximum absolute step size allowed. +! the default value is infinite. +! +! hmin rwork(7) the minimum absolute step size allowed. +! the default value is 0. (this lower bound is not +! enforced on the final step before reaching tcrit +! when itask = 4 or 5.) +! +! seth rwork(8) the element threshhold for sparsity determination +! when moss = 1 or 2. if the absolute value of +! an estimated jacobian element is .le. seth, it +! will be assumed to be absent in the structure. +! the default value of seth is 0. +! +! maxord iwork(5) the maximum order to be allowed. the default +! value is 12 if meth = 1, and 5 if meth = 2. +! if maxord exceeds the default value, it will +! be reduced to the default value. +! if maxord is changed during the problem, it may +! cause the current order to be reduced. +! +! mxstep iwork(6) maximum number of (internally defined) steps +! allowed during one call to the solver. +! the default value is 500. +! +! mxhnil iwork(7) maximum number of messages printed (per problem) +! warning that t + h = t on a step (h = step size). +! this must be positive to result in a non-default +! value. the default value is 10. +!----------------------------------------------------------------------- +! optional outputs. +! +! as optional additional output from lsodes, the variables listed +! below are quantities related to the performance of lsodes +! which are available to the user. these are communicated by way of +! the work arrays, but also have internal mnemonic names as shown. +! except where stated otherwise, all of these outputs are defined +! on any successful return from lsodes, and on any return with +! istate = -1, -2, -4, -5, or -6. on an illegal input return +! (istate = -3), they will be unchanged from their existing values +! (if any), except possibly for tolsf, lenrw, and leniw. +! on any error return, outputs relevant to the error will be defined, +! as noted below. +! +! name location meaning +! +! hu rwork(11) the step size in t last used (successfully). +! +! hcur rwork(12) the step size to be attempted on the next step. +! +! tcur rwork(13) the current value of the independent variable +! which the solver has actually reached, i.e. the +! current internal mesh point in t. on output, tcur +! will always be at least as far as the argument +! t, but may be farther (if interpolation was done). +! +! tolsf rwork(14) a tolerance scale factor, greater than 1.0, +! computed when a request for too much accuracy was +! detected (istate = -3 if detected at the start of +! the problem, istate = -2 otherwise). if itol is +! left unaltered but rtol and atol are uniformly +! scaled up by a factor of tolsf for the next call, +! then the solver is deemed likely to succeed. +! (the user may also ignore tolsf and alter the +! tolerance parameters in any other way appropriate.) +! +! nst iwork(11) the number of steps taken for the problem so far. +! +! nfe iwork(12) the number of f evaluations for the problem so far, +! excluding those for structure determination +! (moss = 2). +! +! nje iwork(13) the number of jacobian evaluations for the problem +! so far, excluding those for structure determination +! (moss = 1). +! +! nqu iwork(14) the method order last used (successfully). +! +! nqcur iwork(15) the order to be attempted on the next step. +! +! imxer iwork(16) the index of the component of largest magnitude in +! the weighted local error vector ( e(i)/ewt(i) ), +! on an error return with istate = -4 or -5. +! +! lenrw iwork(17) the length of rwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! leniw iwork(18) the length of iwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! nnz iwork(19) the number of nonzero elements in the jacobian +! matrix, including the diagonal (miter = 1 or 2). +! (this may differ from that given by ia(neq+1)-1 +! if moss = 0, because of added diagonal entries.) +! +! ngp iwork(20) the number of groups of column indices, used in +! difference quotient jacobian aproximations if +! miter = 2. this is also the number of extra f +! evaluations needed for each jacobian evaluation. +! +! nlu iwork(21) the number of sparse lu decompositions for the +! problem so far. +! +! lyh iwork(22) the base address in rwork of the history array yh, +! described below in this list. +! +! ipian iwork(23) the base address of the structure descriptor array +! ian, described below in this list. +! +! ipjan iwork(24) the base address of the structure descriptor array +! jan, described below in this list. +! +! nzl iwork(25) the number of nonzero elements in the strict lower +! triangle of the lu factorization used in the chord +! iteration (miter = 1 or 2). +! +! nzu iwork(26) the number of nonzero elements in the strict upper +! triangle of the lu factorization used in the chord +! iteration (miter = 1 or 2). +! the total number of nonzeros in the factorization +! is therefore nzl + nzu + neq. +! +! the following four arrays are segments of the rwork array which +! may also be of interest to the user as optional outputs. +! for each array, the table below gives its internal name, +! its base address, and its description. +! for yh and acor, the base addresses are in rwork (a real array). +! the integer arrays ian and jan are to be obtained by declaring an +! integer array iwk and identifying iwk(1) with rwork(21), using either +! an equivalence statement or a subroutine call. then the base +! addresses ipian (of ian) and ipjan (of jan) in iwk are to be obtained +! as optional outputs iwork(23) and iwork(24), respectively. +! thus ian(1) is iwk(ipian), etc. +! +! name base address description +! +! ian ipian (in iwk) structure descriptor array of size neq + 1. +! jan ipjan (in iwk) structure descriptor array of size nnz. +! (see above) ian and jan together describe the sparsity +! structure of the jacobian matrix, as used by +! lsodes when miter = 1 or 2. +! jan contains the row indices of the nonzero +! locations, reading in columnwise order, and +! ian contains the starting locations in jan of +! the descriptions of columns 1,...,neq, in +! that order, with ian(1) = 1. thus for each +! j = 1,...,neq, the row indices i of the +! nonzero locations in column j are +! i = jan(k), ian(j) .le. k .lt. ian(j+1). +! note that ian(neq+1) = nnz + 1. +! (if moss = 0, ian/jan may differ from the +! input ia/ja because of a different ordering +! in each column, and added diagonal entries.) +! +! yh lyh the nordsieck history array, of size nyh by +! (optional (nqcur + 1), where nyh is the initial value +! output) of neq. for j = 0,1,...,nqcur, column j+1 +! of yh contains hcur**j/factorial(j) times +! the j-th derivative of the interpolating +! polynomial currently representing the solution, +! evaluated at t = tcur. the base address lyh +! is another optional output, listed above. +! +! acor lenrw-neq+1 array of size neq used for the accumulated +! corrections on each step, scaled on output +! to represent the estimated local error in y +! on the last step. this is the vector e in +! the description of the error control. it is +! defined only on a successful return from +! lsodes. +! +!----------------------------------------------------------------------- +! part ii. other routines callable. +! +! the following are optional calls which the user may make to +! gain additional capabilities in conjunction with lsodes. +! (the routines xsetun and xsetf are designed to conform to the +! slatec error handling package.) +! +! form of call function +! call xsetun(lun) set the logical unit number, lun, for +! output of messages from lsodes, if +! the default is not desired. +! the default value of lun is 6. +! +! call xsetf(mflag) set a flag to control the printing of +! messages by lsodes. +! mflag = 0 means do not print. (danger.. +! this risks losing valuable information.) +! mflag = 1 means print (the default). +! +! either of the above calls may be made at +! any time and will take effect immediately. +! +! call srcms(rsav,isav,job) saves and restores the contents of +! the internal common blocks used by +! lsodes (see part iii below). +! rsav must be a real array of length 224 +! or more, and isav must be an integer +! array of length 75 or more. +! job=1 means save common into rsav/isav. +! job=2 means restore common from rsav/isav. +! srcms is useful if one is +! interrupting a run and restarting +! later, or alternating between two or +! more problems solved with lsodes. +! +! call intdy(,,,,,) provide derivatives of y, of various +! (see below) orders, at a specified point t, if +! desired. it may be called only after +! a successful return from lsodes. +! +! the detailed instructions for using intdy are as follows. +! the form of the call is.. +! +! lyh = iwork(22) +! call intdy (t, k, rwork(lyh), nyh, dky, iflag) +! +! the input parameters are.. +! +! t = value of independent variable where answers are desired +! (normally the same as the t last returned by lsodes). +! for valid results, t must lie between tcur - hu and tcur. +! (see optional outputs for tcur and hu.) +! k = integer order of the derivative desired. k must satisfy +! 0 .le. k .le. nqcur, where nqcur is the current order +! (see optional outputs). the capability corresponding +! to k = 0, i.e. computing y(t), is already provided +! by lsodes directly. since nqcur .ge. 1, the first +! derivative dy/dt is always available with intdy. +! lyh = the base address of the history array yh, obtained +! as an optional output as shown above. +! nyh = column length of yh, equal to the initial value of neq. +! +! the output parameters are.. +! +! dky = a real array of length neq containing the computed value +! of the k-th derivative of y(t). +! iflag = integer flag, returned as 0 if k and t were legal, +! -1 if k was illegal, and -2 if t was illegal. +! on an error return, a message is also written. +!----------------------------------------------------------------------- +! part iii. common blocks. +! +! if lsodes is to be used in an overlay situation, the user +! must declare, in the primary overlay, the variables in.. +! (1) the call sequence to lsodes, +! (2) the three internal common blocks +! /ls0001/ of length 257 (218 single precision words +! followed by 39 integer words), +! /lss001/ of length 40 ( 6 single precision words +! followed by 34 integer words), +! /eh0001/ of length 2 (integer words). +! +! if lsodes is used on a system in which the contents of internal +! common blocks are not preserved between calls, the user should +! declare the above three common blocks in his main program to insure +! that their contents are preserved. +! +! if the solution of a given problem by lsodes is to be interrupted +! and then later continued, such as when restarting an interrupted run +! or alternating between two or more problems, the user should save, +! following the return from the last lsodes call prior to the +! interruption, the contents of the call sequence variables and the +! internal common blocks, and later restore these values before the +! next lsodes call for that problem. to save and restore the common +! blocks, use subroutine srcms (see part ii above). +! +! note.. in this version of lsodes, there are two data statements, +! in subroutines lsodes and xerrwv, which load variables into these +! labeled common blocks. on some systems, it may be necessary to +! move these to a separate block data subprogram. +! +!----------------------------------------------------------------------- +! part iv. optionally replaceable solver routines. +! +! below are descriptions of two routines in the lsodes package which +! relate to the measurement of errors. either routine can be +! replaced by a user-supplied version, if desired. however, since such +! a replacement may have a major impact on performance, it should be +! done only when absolutely necessary, and only with great caution. +! (note.. the means by which the package version of a routine is +! superseded by the user-s version may be system-dependent.) +! +! (a) ewset. +! the following subroutine is called just before each internal +! integration step, and sets the array of error weights, ewt, as +! described under itol/rtol/atol above.. +! subroutine ewset (neq, itol, rtol, atol, ycur, ewt) +! where neq, itol, rtol, and atol are as in the lsodes call sequence, +! ycur contains the current dependent variable vector, and +! ewt is the array of weights set by ewset. +! +! if the user supplies this subroutine, it must return in ewt(i) +! (i = 1,...,neq) a positive quantity suitable for comparing errors +! in y(i) to. the ewt array returned by ewset is passed to the +! vnorm routine (see below), and also used by lsodes in the computation +! of the optional output imxer, the diagonal jacobian approximation, +! and the increments for difference quotient jacobians. +! +! in the user-supplied version of ewset, it may be desirable to use +! the current values of derivatives of y. derivatives up to order nq +! are available from the history array yh, described above under +! optional outputs. in ewset, yh is identical to the ycur array, +! extended to nq + 1 columns with a column length of nyh and scale +! factors of h**j/factorial(j). on the first call for the problem, +! given by nst = 0, nq is 1 and h is temporarily set to 1.0. +! the quantities nq, nyh, h, and nst can be obtained by including +! in ewset the statements.. +! common /ls0001/ rls(218),ils(39) +! nq = ils(35) +! nyh = ils(14) +! nst = ils(36) +! h = rls(212) +! thus, for example, the current value of dy/dt can be obtained as +! ycur(nyh+i)/h (i=1,...,neq) (and the division by h is +! unnecessary when nst = 0). +! +! (b) vnorm. +! the following is a real function routine which computes the weighted +! root-mean-square norm of a vector v.. +! d = vnorm (n, v, w) +! where.. +! n = the length of the vector, +! v = real array of length n containing the vector, +! w = real array of length n containing weights, +! d = sqrt( (1/n) * sum(v(i)*w(i))**2 ). +! vnorm is called with n = neq and with w(i) = 1.0/ewt(i), where +! ewt is as set by subroutine ewset. +! +! if the user supplies this function, it should return a non-negative +! value of vnorm suitable for use in the error control in lsodes. +! none of the arguments should be altered by vnorm. +! for example, a user-supplied vnorm routine might.. +! -substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +! -ignore some components of v in the norm, with the effect of +! suppressing the error control on those components of y. +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! other routines in the lsodes package. +! +! in addition to subroutine lsodes, the lsodes package includes the +! following subroutines and function routines.. +! iprep acts as an iterface between lsodes and prep, and also does +! adjusting of work space pointers and work arrays. +! prep is called by iprep to compute sparsity and do sparse matrix +! preprocessing if miter = 1 or 2. +! jgroup is called by prep to compute groups of jacobian column +! indices for use when miter = 2. +! adjlr adjusts the length of required sparse matrix work space. +! it is called by prep. +! cntnzu is called by prep and counts the nonzero elements in the +! strict upper triangle of j + j-transpose, where j = df/dy. +! intdy computes an interpolated value of the y vector at t = tout. +! stode is the core integrator, which does one step of the +! integration and the associated error control. +! cfode sets all method coefficients and test constants. +! prjs computes and preprocesses the jacobian matrix j = df/dy +! and the newton iteration matrix p = i - h*l0*j. +! slss manages solution of linear system in chord iteration. +! ewset sets the error weight vector ewt before each step. +! vnorm computes the weighted r.m.s. norm of a vector. +! srcms is a user-callable routine to save and restore +! the contents of the internal common blocks. +! odrv constructs a reordering of the rows and columns of +! a matrix by the minimum degree algorithm. odrv is a +! driver routine which calls subroutines md, mdi, mdm, +! mdp, mdu, and sro. see ref. 2 for details. (the odrv +! module has been modified since ref. 2, however.) +! cdrv performs reordering, symbolic factorization, numerical +! factorization, or linear system solution operations, +! depending on a path argument ipath. cdrv is a +! driver routine which calls subroutines nroc, nsfc, +! nnfc, nnsc, and nntc. see ref. 3 for details. +! lsodes uses cdrv to solve linear systems in which the +! coefficient matrix is p = i - con*j, where i is the +! identity, con is a scalar, and j is an approximation to +! the jacobian df/dy. because cdrv deals with rowwise +! sparsity descriptions, cdrv works with p-transpose, not p. +! r1mach computes the unit roundoff in a machine-independent manner. +! xerrwv, xsetun, and xsetf handle the printing of all error +! messages and warnings. xerrwv is machine-dependent. +! note.. vnorm and r1mach are function routines. +! all the others are subroutines. +! +! the intrinsic and external routines used by lsodes are.. +! abs, amax1, amin1, float, max0, min0, mod, sign, sqrt, and write. +! +!----------------------------------------------------------------------- +! the following card is for optimized compilation on lll compilers. +!lll. optimize +!----------------------------------------------------------------------- +!rce external prjs, slss + integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, & + mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns + integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, i1, i2, iflag, imax, imul, imxer, ipflag, ipgo, irem, & + j, kgo, lenrat, lenyht, leniw, lenrw, lf0, lia, lja, & + lrtem, lwtem, lyhd, lyhn, mf1, mord, mxhnl0, mxstp0, ncolm + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real con0, conmin, ccmxj, psmall, rbig, seth +!rce real atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli, & +!rce tcrit, tdist, tnext, tol, tolsf, tp, size, sum, w0, & +!rce r1mach, vnorm + real atoli, ayi, big, ewti, h0, hmax, hmx, rh, rtoli, & + tcrit, tdist, tnext, tol, tolsf, tp, size, sum, w0 + dimension mord(2) + logical ihit +!----------------------------------------------------------------------- +! the following two internal common blocks contain +! (a) variables which are local to any subroutine but whose values must +! be preserved between calls to the routine (own variables), and +! (b) variables which are communicated between subroutines. +! the structure of each block is as follows.. all real variables are +! listed first, followed by all integers. within each type, the +! variables are grouped with those local to subroutine lsodes first, +! then those local to subroutine stode or subroutine prjs +! (no other routines have own variables), and finally those used +! for communication. the block ls0001 is declared in subroutines +! lsodes, iprep, prep, intdy, stode, prjs, and slss. the block lss001 +! is declared in subroutines lsodes, iprep, prep, prjs, and slss. +! groups of variables are replaced by dummy arrays in the common +! declarations in routines where those variables are not used. +!----------------------------------------------------------------------- + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, & + mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +! + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, & + iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + + integer iok_vnorm + common / lsodes_cmn_iok_vnorm / iok_vnorm +! + data mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/ +!raz data illin/0/, ntrep/0/ +!----------------------------------------------------------------------- +! in the data statement below, set lenrat equal to the ratio of +! the wordlength for a real number to that for an integer. usually, +! lenrat = 1 for single precision and 2 for double precision. if the +! true ratio is not an integer, use the next smaller integer (.ge. 1). +!----------------------------------------------------------------------- + data lenrat/1/ +!----------------------------------------------------------------------- +! block a. +! this code block is executed on every call. +! it tests istate and itask for legality and branches appropriately. +! if istate .gt. 1 but the flag init shows that initialization has +! not yet been done, an error return occurs. +! if istate = 1 and tout = t, jump to block g and return immediately. +!----------------------------------------------------------------------- + iok_vnorm = 1 + + if (istate .lt. 1 .or. istate .gt. 3) go to 601 + if (itask .lt. 1 .or. itask .gt. 5) go to 602 + if (istate .eq. 1) go to 10 + if (init .eq. 0) go to 603 + if (istate .eq. 2) go to 200 + go to 20 + 10 init = 0 + if (tout .eq. t) go to 430 + 20 ntrep = 0 +!----------------------------------------------------------------------- +! block b. +! the next code block is executed for the initial call (istate = 1), +! or for a continuation call with parameter changes (istate = 3). +! it contains checking of all inputs and various initializations. +! if istate = 1, the final setting of work space pointers, the matrix +! preprocessing, and other initializations are done in block c. +! +! first check legality of the non-optional inputs neq, itol, iopt, +! mf, ml, and mu. +!----------------------------------------------------------------------- + if (neq(1) .le. 0) go to 604 + if (istate .eq. 1) go to 25 + if (neq(1) .gt. n) go to 605 + 25 n = neq(1) + if (itol .lt. 1 .or. itol .gt. 4) go to 606 + if (iopt .lt. 0 .or. iopt .gt. 1) go to 607 + moss = mf/100 + mf1 = mf - 100*moss + meth = mf1/10 + miter = mf1 - 10*meth + if (moss .lt. 0 .or. moss .gt. 2) go to 608 + if (meth .lt. 1 .or. meth .gt. 2) go to 608 + if (miter .lt. 0 .or. miter .gt. 3) go to 608 + if (miter .eq. 0 .or. miter .eq. 3) moss = 0 +! next process and check the optional inputs. -------------------------- + if (iopt .eq. 1) go to 40 + maxord = mord(meth) + mxstep = mxstp0 + mxhnil = mxhnl0 + if (istate .eq. 1) h0 = 0.0e0 + hmxi = 0.0e0 + hmin = 0.0e0 + seth = 0.0e0 + go to 60 + 40 maxord = iwork(5) + if (maxord .lt. 0) go to 611 + if (maxord .eq. 0) maxord = 100 + maxord = min0(maxord,mord(meth)) + mxstep = iwork(6) + if (mxstep .lt. 0) go to 612 + if (mxstep .eq. 0) mxstep = mxstp0 + mxhnil = iwork(7) + if (mxhnil .lt. 0) go to 613 + if (mxhnil .eq. 0) mxhnil = mxhnl0 + if (istate .ne. 1) go to 50 + h0 = rwork(5) + if ((tout - t)*h0 .lt. 0.0e0) go to 614 + 50 hmax = rwork(6) + if (hmax .lt. 0.0e0) go to 615 + hmxi = 0.0e0 + if (hmax .gt. 0.0e0) hmxi = 1.0e0/hmax + hmin = rwork(7) + if (hmin .lt. 0.0e0) go to 616 + seth = rwork(8) + if (seth .lt. 0.0e0) go to 609 +! check rtol and atol for legality. ------------------------------------ + 60 rtoli = rtol(1) + atoli = atol(1) + do 65 i = 1,n + if (itol .ge. 3) rtoli = rtol(i) + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + if (rtoli .lt. 0.0e0) go to 619 + if (atoli .lt. 0.0e0) go to 620 + 65 continue +!----------------------------------------------------------------------- +! compute required work array lengths, as far as possible, and test +! these against lrw and liw. then set tentative pointers for work +! arrays. pointers to rwork/iwork segments are named by prefixing l to +! the name of the segment. e.g., the segment yh starts at rwork(lyh). +! segments of rwork (in order) are denoted wm, yh, savf, ewt, acor. +! if miter = 1 or 2, the required length of the matrix work space wm +! is not yet known, and so a crude minimum value is used for the +! initial tests of lrw and liw, and yh is temporarily stored as far +! to the right in rwork as possible, to leave the maximum amount +! of space for wm for matrix preprocessing. thus if miter = 1 or 2 +! and moss .ne. 2, some of the segments of rwork are temporarily +! omitted, as they are not needed in the preprocessing. these +! omitted segments are.. acor if istate = 1, ewt and acor if istate = 3 +! and moss = 1, and savf, ewt, and acor if istate = 3 and moss = 0. +!----------------------------------------------------------------------- + lrat = lenrat + if (istate .eq. 1) nyh = n + lwmin = 0 + if (miter .eq. 1) lwmin = 4*n + 10*n/lrat + if (miter .eq. 2) lwmin = 4*n + 11*n/lrat + if (miter .eq. 3) lwmin = n + 2 + lenyh = (maxord+1)*nyh + lrest = lenyh + 3*n + lenrw = 20 + lwmin + lrest + iwork(17) = lenrw + leniw = 30 + if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) & + leniw = leniw + n + 1 + iwork(18) = leniw + if (lenrw .gt. lrw) go to 617 + if (leniw .gt. liw) go to 618 + lia = 31 + if (moss .eq. 0 .and. miter .ne. 0 .and. miter .ne. 3) & + leniw = leniw + iwork(lia+n) - 1 + iwork(18) = leniw + if (leniw .gt. liw) go to 618 + lja = lia + n + 1 + lia = min0(lia,liw) + lja = min0(lja,liw) + lwm = 21 + if (istate .eq. 1) nq = 1 + ncolm = min0(nq+1,maxord+2) + lenyhm = ncolm*nyh + lenyht = lenyh + if (miter .eq. 1 .or. miter .eq. 2) lenyht = lenyhm + imul = 2 + if (istate .eq. 3) imul = moss + if (moss .eq. 2) imul = 3 + lrtem = lenyht + imul*n + lwtem = lwmin + if (miter .eq. 1 .or. miter .eq. 2) lwtem = lrw - 20 - lrtem + lenwk = lwtem + lyhn = lwm + lwtem + lsavf = lyhn + lenyht + lewt = lsavf + n + lacor = lewt + n + istatc = istate + if (istate .eq. 1) go to 100 +!----------------------------------------------------------------------- +! istate = 3. move yh to its new location. +! note that only the part of yh needed for the next step, namely +! min(nq+1,maxord+2) columns, is actually moved. +! a temporary error weight array ewt is loaded if moss = 2. +! sparse matrix processing is done in iprep/prep if miter = 1 or 2. +! if maxord was reduced below nq, then the pointers are finally set +! so that savf is identical to yh(*,maxord+2). +!----------------------------------------------------------------------- + lyhd = lyh - lyhn + imax = lyhn - 1 + lenyhm +! move yh. branch for move right, no move, or move left. -------------- + if (lyhd) 70,80,74 + 70 do 72 i = lyhn,imax + j = imax + lyhn - i + 72 rwork(j) = rwork(j+lyhd) + go to 80 + 74 do 76 i = lyhn,imax + 76 rwork(i) = rwork(i+lyhd) + 80 lyh = lyhn + iwork(22) = lyh + if (miter .eq. 0 .or. miter .eq. 3) go to 92 + if (moss .ne. 2) go to 85 +! temporarily load ewt if miter = 1 or 2 and moss = 2. ----------------- + call ewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 82 i = 1,n + if (rwork(i+lewt-1) .le. 0.0e0) go to 621 + 82 rwork(i+lewt-1) = 1.0e0/rwork(i+lewt-1) + 85 continue +! iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- + lsavf = min0(lsavf,lrw) + lewt = min0(lewt,lrw) + lacor = min0(lacor,lrw) + call iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar) + lenrw = lwm - 1 + lenwk + lrest + iwork(17) = lenrw + if (ipflag .ne. -1) iwork(23) = ipian + if (ipflag .ne. -1) iwork(24) = ipjan + ipgo = -ipflag + 1 + go to (90, 628, 629, 630, 631, 632, 633), ipgo + 90 iwork(22) = lyh + if (lenrw .gt. lrw) go to 617 +! set flag to signal parameter changes to stode. ----------------------- + 92 jstart = -1 + if (n .eq. nyh) go to 200 +! neq was reduced. zero part of yh to avoid undefined references. ----- + i1 = lyh + l*nyh + i2 = lyh + (maxord + 1)*nyh - 1 + if (i1 .gt. i2) go to 200 + do 95 i = i1,i2 + 95 rwork(i) = 0.0e0 + go to 200 +!----------------------------------------------------------------------- +! block c. +! the next block is for the initial call only (istate = 1). +! it contains all remaining initializations, the initial call to f, +! the sparse matrix preprocessing (miter = 1 or 2), and the +! calculation of the initial step size. +! the error weights in ewt are inverted after being loaded. +!----------------------------------------------------------------------- + 100 continue + lyh = lyhn + iwork(22) = lyh + tn = t + nst = 0 + h = 1.0e0 + nnz = 0 + ngp = 0 + nzl = 0 + nzu = 0 +! load the initial value vector in yh. --------------------------------- + do 105 i = 1,n + 105 rwork(i+lyh-1) = y(i) +! initial call to f. (lf0 points to yh(*,2).) ------------------------- + lf0 = lyh + nyh + call f (neq, t, y, rwork(lf0), & + ruserpar, nruserpar, iuserpar, niuserpar) + nfe = 1 +! load and invert the ewt array. (h is temporarily set to 1.0.) ------- + call ewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 110 i = 1,n + if (rwork(i+lewt-1) .le. 0.0e0) go to 621 + 110 rwork(i+lewt-1) = 1.0e0/rwork(i+lewt-1) + if (miter .eq. 0 .or. miter .eq. 3) go to 120 +! iprep and prep do sparse matrix preprocessing if miter = 1 or 2. ----- + lacor = min0(lacor,lrw) + call iprep (neq, y, rwork, iwork(lia), iwork(lja), ipflag, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar) + lenrw = lwm - 1 + lenwk + lrest + iwork(17) = lenrw + if (ipflag .ne. -1) iwork(23) = ipian + if (ipflag .ne. -1) iwork(24) = ipjan + ipgo = -ipflag + 1 + go to (115, 628, 629, 630, 631, 632, 633), ipgo + 115 iwork(22) = lyh + if (lenrw .gt. lrw) go to 617 +! check tcrit for legality (itask = 4 or 5). --------------------------- + 120 continue + if (itask .ne. 4 .and. itask .ne. 5) go to 125 + tcrit = rwork(1) + if ((tcrit - tout)*(tout - t) .lt. 0.0e0) go to 625 + if (h0 .ne. 0.0e0 .and. (t + h0 - tcrit)*h0 .gt. 0.0e0) & + h0 = tcrit - t +! initialize all remaining parameters. --------------------------------- + 125 uround = r1mach(4) + jstart = 0 + if (miter .ne. 0) rwork(lwm) = sqrt(uround) + msbj = 50 + nslj = 0 + ccmxj = 0.2e0 + psmall = 1000.0e0*uround + rbig = 0.01e0/psmall + nhnil = 0 + nje = 0 + nlu = 0 + nslast = 0 + hu = 0.0e0 + nqu = 0 + ccmax = 0.3e0 + maxcor = 3 + msbp = 20 + mxncf = 10 +!----------------------------------------------------------------------- +! the coding below computes the step size, h0, to be attempted on the +! first step, unless the user has supplied a value for this. +! first check that tout - t differs significantly from zero. +! a scalar tolerance quantity tol is computed, as max(rtol(i)) +! if this is positive, or max(atol(i)/abs(y(i))) otherwise, adjusted +! so as to be between 100*uround and 1.0e-3. +! then the computed value h0 is given by.. +! neq +! h0**2 = tol / ( w0**-2 + (1/neq) * sum ( f(i)/ywt(i) )**2 ) +! 1 +! where w0 = max ( abs(t), abs(tout) ), +! f(i) = i-th component of initial value of f, +! ywt(i) = ewt(i)/tol (a weight for y(i)). +! the sign of h0 is inferred from the initial values of tout and t. +!----------------------------------------------------------------------- + lf0 = lyh + nyh + if (h0 .ne. 0.0e0) go to 180 + tdist = abs(tout - t) + w0 = amax1(abs(t),abs(tout)) + if (tdist .lt. 2.0e0*uround*w0) go to 622 + tol = rtol(1) + if (itol .le. 2) go to 140 + do 130 i = 1,n + 130 tol = amax1(tol,rtol(i)) + 140 if (tol .gt. 0.0e0) go to 160 + atoli = atol(1) + do 150 i = 1,n + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + ayi = abs(y(i)) + if (ayi .ne. 0.0e0) tol = amax1(tol,atoli/ayi) + 150 continue + 160 tol = amax1(tol,100.0e0*uround) + tol = amin1(tol,0.001e0) + sum = vnorm (n, rwork(lf0), rwork(lewt)) + if (iok_vnorm .lt. 0) then + istate = -901 + return + end if + sum = 1.0e0/(tol*w0*w0) + tol*sum**2 + h0 = 1.0e0/sqrt(sum) + h0 = amin1(h0,tdist) + h0 = sign(h0,tout-t) +! adjust h0 if necessary to meet hmax bound. --------------------------- + 180 rh = abs(h0)*hmxi + if (rh .gt. 1.0e0) h0 = h0/rh +! load h with h0 and scale yh(*,2) by h0. ------------------------------ + h = h0 + do 190 i = 1,n + 190 rwork(i+lf0-1) = h0*rwork(i+lf0-1) + go to 270 +!----------------------------------------------------------------------- +! block d. +! the next code block is for continuation calls only (istate = 2 or 3) +! and is to check stop conditions before taking a step. +!----------------------------------------------------------------------- + 200 nslast = nst + go to (210, 250, 220, 230, 240), itask + 210 if ((tn - tout)*h .lt. 0.0e0) go to 250 + call intdy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 220 tp = tn - hu*(1.0e0 + 100.0e0*uround) + if ((tp - tout)*h .gt. 0.0e0) go to 623 + if ((tn - tout)*h .lt. 0.0e0) go to 250 + go to 400 + 230 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. 0.0e0) go to 624 + if ((tcrit - tout)*h .lt. 0.0e0) go to 625 + if ((tn - tout)*h .lt. 0.0e0) go to 245 + call intdy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 240 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. 0.0e0) go to 624 + 245 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. 100.0e0*uround*hmx + if (ihit) go to 400 + tnext = tn + h*(1.0e0 + 4.0e0*uround) + if ((tnext - tcrit)*h .le. 0.0e0) go to 250 + h = (tcrit - tn)*(1.0e0 - 4.0e0*uround) + if (istate .eq. 2) jstart = -2 +!----------------------------------------------------------------------- +! block e. +! the next block is normally executed for all calls and contains +! the call to the one-step core integrator stode. +! +! this is a looping point for the integration steps. +! +! first check for too many steps being taken, update ewt (if not at +! start of problem), check for too much accuracy being requested, and +! check for h below the roundoff level in t. +!----------------------------------------------------------------------- + 250 continue + if ((nst-nslast) .ge. mxstep) go to 500 + call ewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 260 i = 1,n + if (rwork(i+lewt-1) .le. 0.0e0) go to 510 + 260 rwork(i+lewt-1) = 1.0e0/rwork(i+lewt-1) + 270 tolsf = uround*vnorm (n, rwork(lyh), rwork(lewt)) + if (tolsf .le. 1.0e0) go to 280 +! diagnostic dump + tolsf = tolsf*2.0e0 + if (nst .eq. 0) go to 626 + go to 520 + 280 if ((tn + h) .ne. tn) go to 290 + nhnil = nhnil + 1 + if (nhnil .gt. mxhnil) go to 290 + call xerrwv('lsodes-- warning..internal t (=r1) and h (=r2) are', & + 50, 101, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' such that in the machine, t + h = t on the next step ', & + 60, 101, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' (h = step size). solver will continue anyway', & + 50, 101, 0, 0, 0, 0, 2, tn, h) + if (nhnil .lt. mxhnil) go to 290 + call xerrwv('lsodes-- above warning has been issued i1 times. ', & + 50, 102, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' it will not be issued again for this problem', & + 50, 102, 0, 1, mxhnil, 0, 0, 0.0e0, 0.0e0) + 290 continue +!----------------------------------------------------------------------- +! call stode(neq,y,yh,nyh,yh,ewt,savf,acor,wm,wm,f,jac,prjs,slss) +!----------------------------------------------------------------------- + call stode_lsodes (neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), & + rwork(lsavf), rwork(lacor), rwork(lwm), rwork(lwm), & + f, jac, prjs, slss, & + ruserpar, nruserpar, iuserpar, niuserpar ) + kgo = 1 - kflag + go to (300, 530, 540, 550), kgo +!----------------------------------------------------------------------- +! block f. +! the following block handles the case of a successful return from the +! core integrator (kflag = 0). test for stop conditions. +!----------------------------------------------------------------------- + 300 init = 1 + go to (310, 400, 330, 340, 350), itask +! itask = 1. if tout has been reached, interpolate. ------------------- + 310 if ((tn - tout)*h .lt. 0.0e0) go to 250 + call intdy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 +! itask = 3. jump to exit if tout was reached. ------------------------ + 330 if ((tn - tout)*h .ge. 0.0e0) go to 400 + go to 250 +! itask = 4. see if tout or tcrit was reached. adjust h if necessary. + 340 if ((tn - tout)*h .lt. 0.0e0) go to 345 + call intdy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 + 345 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. 100.0e0*uround*hmx + if (ihit) go to 400 + tnext = tn + h*(1.0e0 + 4.0e0*uround) + if ((tnext - tcrit)*h .le. 0.0e0) go to 250 + h = (tcrit - tn)*(1.0e0 - 4.0e0*uround) + jstart = -2 + go to 250 +! itask = 5. see if tcrit was reached and jump to exit. --------------- + 350 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. 100.0e0*uround*hmx +!----------------------------------------------------------------------- +! block g. +! the following block handles all successful returns from lsodes. +! if itask .ne. 1, y is loaded from yh and t is set accordingly. +! istate is set to 2, the illegal input counter is zeroed, and the +! optional outputs are loaded into the work arrays before returning. +! if istate = 1 and tout = t, there is a return with no action taken, +! except that if this has happened repeatedly, the run is terminated. +!----------------------------------------------------------------------- + 400 do 410 i = 1,n + 410 y(i) = rwork(i+lyh-1) + t = tn + if (itask .ne. 4 .and. itask .ne. 5) go to 420 + if (ihit) t = tcrit + 420 istate = 2 + illin = 0 + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nnz + iwork(20) = ngp + iwork(21) = nlu + iwork(25) = nzl + iwork(26) = nzu + if (iok_vnorm .lt. 0) istate = -912 + return +! + 430 ntrep = ntrep + 1 +! if (ntrep .lt. 5) return + if (ntrep .lt. 5) then + if (iok_vnorm .lt. 0) istate = -913 + return + end if + call xerrwv( & + 'lsodes-- repeated calls with istate = 1 and tout = t (=r1) ', & + 60, 301, 0, 0, 0, 0, 1, t, 0.0e0) + go to 800 +!----------------------------------------------------------------------- +! block h. +! the following block handles all unsuccessful returns other than +! those for illegal input. first the error message routine is called. +! if there was an error test or convergence test failure, imxer is set. +! then y is loaded from yh, t is set to tn, and the illegal input +! counter illin is set to 0. the optional outputs are loaded into +! the work arrays before returning. +!----------------------------------------------------------------------- +! the maximum number of steps was taken before reaching tout. ---------- + 500 call xerrwv('lsodes-- at current t (=r1), mxstep (=i1) steps ', & + 50, 201, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' taken on this call before reaching tout ', & + 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0e0) + istate = -1 + go to 580 +! ewt(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 ewti = rwork(lewt+i-1) + call xerrwv('lsodes-- at t (=r1), ewt(i1) has become r2 .le. 0.', & + 50, 202, 0, 1, i, 0, 2, tn, ewti) + istate = -6 + go to 580 +! too much accuracy requested for machine precision. ------------------- + 520 call xerrwv('lsodes-- at t (=r1), too much accuracy requested ', & + 50, 203, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' for precision of machine.. see tolsf (=r2) ', & + 50, 203, 0, 0, 0, 0, 2, tn, tolsf) + rwork(14) = tolsf + istate = -2 + go to 580 +! kflag = -1. error test failed repeatedly or with abs(h) = hmin. ----- + 530 call xerrwv('lsodes-- at t(=r1) and step size h(=r2), the error', & + 50, 204, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' test failed repeatedly or with abs(h) = hmin', & + 50, 204, 0, 0, 0, 0, 2, tn, h) + istate = -4 + go to 560 +! kflag = -2. convergence failed repeatedly or with abs(h) = hmin. ---- + 540 call xerrwv('lsodes-- at t (=r1) and step size h (=r2), the ', & + 50, 205, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' corrector convergence failed repeatedly ', & + 50, 205, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' or with abs(h) = hmin ', & + 30, 205, 0, 0, 0, 0, 2, tn, h) + istate = -5 + go to 560 +! kflag = -3. fatal error flag returned by prjs or slss (cdrv). ------- + 550 call xerrwv('lsodes-- at t (=r1) and step size h (=r2), a fatal', & + 50, 207, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' error flag was returned by cdrv (by way of ', & + 50, 207, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv(' subroutine prjs or slss)', & + 30, 207, 0, 0, 0, 0, 2, tn, h) + istate = -7 + go to 580 +! compute imxer if relevant. ------------------------------------------- + 560 big = 0.0e0 + imxer = 1 + do 570 i = 1,n + size = abs(rwork(i+lacor-1)*rwork(i+lewt-1)) + if (big .ge. size) go to 570 + big = size + imxer = i + 570 continue + iwork(16) = imxer +! set y vector, t, illin, and optional outputs. ------------------------ + 580 do 590 i = 1,n + 590 y(i) = rwork(i+lyh-1) + t = tn + illin = 0 + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nnz + iwork(20) = ngp + iwork(21) = nlu + iwork(25) = nzl + iwork(26) = nzu + if (iok_vnorm .lt. 0) istate = -914 + return +!----------------------------------------------------------------------- +! block i. +! the following block handles all error returns due to illegal input +! (istate = -3), as detected before calling the core integrator. +! first the error message routine is called. then if there have been +! 5 consecutive such returns just before this call to the solver, +! the run is halted. +!----------------------------------------------------------------------- + 601 call xerrwv('lsodes-- istate (=i1) illegal ', & + 30, 1, 0, 1, istate, 0, 0, 0.0e0, 0.0e0) + go to 700 + 602 call xerrwv('lsodes-- itask (=i1) illegal ', & + 30, 2, 0, 1, itask, 0, 0, 0.0e0, 0.0e0) + go to 700 + 603 call xerrwv('lsodes-- istate .gt. 1 but lsodes not initialized ', & + 50, 3, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + go to 700 + 604 call xerrwv('lsodes-- neq (=i1) .lt. 1 ', & + 30, 4, 0, 1, neq(1), 0, 0, 0.0e0, 0.0e0) + go to 700 + 605 call xerrwv('lsodes-- istate = 3 and neq increased (i1 to i2) ', & + 50, 5, 0, 2, n, neq(1), 0, 0.0e0, 0.0e0) + go to 700 + 606 call xerrwv('lsodes-- itol (=i1) illegal ', & + 30, 6, 0, 1, itol, 0, 0, 0.0e0, 0.0e0) + go to 700 + 607 call xerrwv('lsodes-- iopt (=i1) illegal ', & + 30, 7, 0, 1, iopt, 0, 0, 0.0e0, 0.0e0) + go to 700 + 608 call xerrwv('lsodes-- mf (=i1) illegal ', & + 30, 8, 0, 1, mf, 0, 0, 0.0e0, 0.0e0) + go to 700 + 609 call xerrwv('lsodes-- seth (=r1) .lt. 0.0 ', & + 30, 9, 0, 0, 0, 0, 1, seth, 0.0e0) + go to 700 + 611 call xerrwv('lsodes-- maxord (=i1) .lt. 0 ', & + 30, 11, 0, 1, maxord, 0, 0, 0.0e0, 0.0e0) + go to 700 + 612 call xerrwv('lsodes-- mxstep (=i1) .lt. 0 ', & + 30, 12, 0, 1, mxstep, 0, 0, 0.0e0, 0.0e0) + go to 700 + 613 call xerrwv('lsodes-- mxhnil (=i1) .lt. 0 ', & + 30, 13, 0, 1, mxhnil, 0, 0, 0.0e0, 0.0e0) + go to 700 + 614 call xerrwv('lsodes-- tout (=r1) behind t (=r2) ', & + 40, 14, 0, 0, 0, 0, 2, tout, t) + call xerrwv(' integration direction is given by h0 (=r1) ', & + 50, 14, 0, 0, 0, 0, 1, h0, 0.0e0) + go to 700 + 615 call xerrwv('lsodes-- hmax (=r1) .lt. 0.0 ', & + 30, 15, 0, 0, 0, 0, 1, hmax, 0.0e0) + go to 700 + 616 call xerrwv('lsodes-- hmin (=r1) .lt. 0.0 ', & + 30, 16, 0, 0, 0, 0, 1, hmin, 0.0e0) + go to 700 + 617 call xerrwv('lsodes-- rwork length is insufficient to proceed. ', & + 50, 17, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. lenrw (=i1), exceeds lrw (=i2)', & + 60, 17, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0) + go to 700 + 618 call xerrwv('lsodes-- iwork length is insufficient to proceed. ', & + 50, 18, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. leniw (=i1), exceeds liw (=i2)', & + 60, 18, 0, 2, leniw, liw, 0, 0.0e0, 0.0e0) + go to 700 + 619 call xerrwv('lsodes-- rtol(i1) is r1 .lt. 0.0 ', & + 40, 19, 0, 1, i, 0, 1, rtoli, 0.0e0) + go to 700 + 620 call xerrwv('lsodes-- atol(i1) is r1 .lt. 0.0 ', & + 40, 20, 0, 1, i, 0, 1, atoli, 0.0e0) + go to 700 + 621 ewti = rwork(lewt+i-1) + call xerrwv('lsodes-- ewt(i1) is r1 .le. 0.0 ', & + 40, 21, 0, 1, i, 0, 1, ewti, 0.0e0) + go to 700 + 622 call xerrwv( & + 'lsodes-- tout (=r1) too close to t(=r2) to start integration', & + 60, 22, 0, 0, 0, 0, 2, tout, t) + go to 700 + 623 call xerrwv( & + 'lsodes-- itask = i1 and tout (=r1) behind tcur - hu (= r2) ', & + 60, 23, 0, 1, itask, 0, 2, tout, tp) + go to 700 + 624 call xerrwv( & + 'lsodes-- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) ', & + 60, 24, 0, 0, 0, 0, 2, tcrit, tn) + go to 700 + 625 call xerrwv( & + 'lsodes-- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) ', & + 60, 25, 0, 0, 0, 0, 2, tcrit, tout) + go to 700 + 626 call xerrwv('lsodes-- at start of problem, too much accuracy ', & + 50, 26, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' requested for precision of machine.. see tolsf (=r1) ', & + 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0e0) + rwork(14) = tolsf + go to 700 + 627 call xerrwv('lsodes-- trouble from intdy. itask = i1, tout = r1', & + 50, 27, 0, 1, itask, 0, 1, tout, 0.0e0) + go to 700 + 628 call xerrwv( & + 'lsodes-- rwork length insufficient (for subroutine prep). ', & + 60, 28, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. lenrw (=i1), exceeds lrw (=i2)', & + 60, 28, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0) + go to 700 + 629 call xerrwv( & + 'lsodes-- rwork length insufficient (for subroutine jgroup). ', & + 60, 29, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. lenrw (=i1), exceeds lrw (=i2)', & + 60, 29, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0) + go to 700 + 630 call xerrwv( & + 'lsodes-- rwork length insufficient (for subroutine odrv). ', & + 60, 30, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. lenrw (=i1), exceeds lrw (=i2)', & + 60, 30, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0) + go to 700 + 631 call xerrwv( & + 'lsodes-- error from odrv in yale sparse matrix package ', & + 60, 31, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + imul = (iys - 1)/n + irem = iys - imul*n + call xerrwv( & + ' at t (=r1), odrv returned error flag = i1*neq + i2. ', & + 60, 31, 0, 2, imul, irem, 1, tn, 0.0e0) + go to 700 + 632 call xerrwv( & + 'lsodes-- rwork length insufficient (for subroutine cdrv). ', & + 60, 32, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + call xerrwv( & + ' length needed is .ge. lenrw (=i1), exceeds lrw (=i2)', & + 60, 32, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0) + go to 700 + 633 call xerrwv( & + 'lsodes-- error from cdrv in yale sparse matrix package ', & + 60, 33, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + imul = (iys - 1)/n + irem = iys - imul*n + call xerrwv( & + ' at t (=r1), cdrv returned error flag = i1*neq + i2. ', & + 60, 33, 0, 2, imul, irem, 1, tn, 0.0e0) + if (imul .eq. 2) call xerrwv( & + ' duplicate entry in sparsity structure descriptors ', & + 60, 33, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) + if (imul .eq. 3 .or. imul .eq. 6) call xerrwv( & + ' insufficient storage for nsfc (called by cdrv) ', & + 60, 33, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) +! + 700 if (illin .eq. 5) go to 710 + illin = illin + 1 + istate = -3 + if (iok_vnorm .lt. 0) istate = -915 + return + 710 call xerrwv('lsodes-- repeated occurrences of illegal input ', & + 50, 302, 0, 0, 0, 0, 0, 0.0e0, 0.0e0) +! + 800 call xerrwv('lsodes-- run aborted.. apparent infinite loop ', & + 50, 303, 2, 0, 0, 0, 0, 0.0e0, 0.0e0) + if (iok_vnorm .lt. 0) istate = -916 + return +!----------------------- end of subroutine lsodes ---------------------- + end subroutine lsodes_solver + subroutine adjlr (n, isp, ldif) + integer n, isp, ldif +!jdf dimension isp(1) + dimension isp(*) +!----------------------------------------------------------------------- +! this routine computes an adjustment, ldif, to the required +! integer storage space in iwk (sparse matrix work space). +! it is called only if the word length ratio is lrat = 1. +! this is to account for the possibility that the symbolic lu phase +! may require more storage than the numerical lu and solution phases. +!----------------------------------------------------------------------- + integer ip, jlmax, jumax, lnfc, lsfc, nzlu +! + ip = 2*n + 1 +! get jlmax = ijl(n) and jumax = iju(n) (sizes of jl and ju). ---------- + jlmax = isp(ip) + jumax = isp(ip+ip) +! nzlu = (size of l) + (size of u) = (il(n+1)-il(1)) + (iu(n+1)-iu(1)). + nzlu = isp(n+1) - isp(1) + isp(ip+n+1) - isp(ip+1) + lsfc = 12*n + 3 + 2*max0(jlmax,jumax) + lnfc = 9*n + 2 + jlmax + jumax + nzlu + ldif = max0(0, lsfc - lnfc) + return +!----------------------- end of subroutine adjlr ----------------------- + end subroutine adjlr + subroutine cdrv & + (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) +!lll. optimize +!*** subroutine cdrv +!*** driver for subroutines for solving sparse nonsymmetric systems of +! linear equations (compressed pointer storage) +! +! +! parameters +! class abbreviations are-- +! n - integer variable +! f - real variable +! v - supplies a value to the driver +! r - returns a result from the driver +! i - used internally by the driver +! a - array +! +! class - parameter +! ------+---------- +! - +! the nonzero entries of the coefficient matrix m are stored +! row-by-row in the array a. to identify the individual nonzero +! entries in each row, we need to know in which column each entry +! lies. the column indices which correspond to the nonzero entries +! of m are stored in the array ja. i.e., if a(k) = m(i,j), then +! ja(k) = j. in addition, we need to know where each row starts and +! how long it is. the index positions in ja and a where the rows of +! m begin are stored in the array ia. i.e., if m(i,j) is the first +! nonzero entry (stored) in the i-th row and a(k) = m(i,j), then +! ia(i) = k. moreover, the index in ja and a of the first location +! following the last element in the last row is stored in ia(n+1). +! thus, the number of entries in the i-th row is given by +! ia(i+1) - ia(i), the nonzero entries of the i-th row are stored +! consecutively in +! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +! and the corresponding column indices are stored consecutively in +! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +! for example, the 5 by 5 matrix +! ( 1. 0. 2. 0. 0.) +! ( 0. 3. 0. 0. 0.) +! m = ( 0. 4. 5. 6. 0.) +! ( 0. 0. 0. 7. 0.) +! ( 0. 0. 0. 8. 9.) +! would be stored as +! - 1 2 3 4 5 6 7 8 9 +! ---+-------------------------- +! ia - 1 3 4 7 8 10 +! ja - 1 3 2 2 3 4 4 4 5 +! a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . +! +! nv - n - number of variables/equations. +! fva - a - nonzero entries of the coefficient matrix m, stored +! - by rows. +! - size = number of nonzero entries in m. +! nva - ia - pointers to delimit the rows in a. +! - size = n+1. +! nva - ja - column numbers corresponding to the elements of a. +! - size = size of a. +! fva - b - right-hand side b. b and z can the same array. +! - size = n. +! fra - z - solution x. b and z can be the same array. +! - size = n. +! +! the rows and columns of the original matrix m can be +! reordered (e.g., to reduce fillin or ensure numerical stability) +! before calling the driver. if no reordering is done, then set +! r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned +! in the original order. +! if the columns have been reordered (i.e., c(i).ne.i for some +! i), then the driver will call a subroutine (nroc) which rearranges +! each row of ja and a, leaving the rows in the original order, but +! placing the elements of each row in increasing order with respect +! to the new ordering. if path.ne.1, then nroc is assumed to have +! been called already. +! +! nva - r - ordering of the rows of m. +! - size = n. +! nva - c - ordering of the columns of m. +! - size = n. +! nva - ic - inverse of the ordering of the columns of m. i.e., +! - ic(c(i)) = i for i=1,...,n. +! - size = n. +! +! the solution of the system of linear equations is divided into +! three stages -- +! nsfc -- the matrix m is processed symbolically to determine where +! fillin will occur during the numeric factorization. +! nnfc -- the matrix m is factored numerically into the product ldu +! of a unit lower triangular matrix l, a diagonal matrix +! d, and a unit upper triangular matrix u, and the system +! mx = b is solved. +! nnsc -- the linear system mx = b is solved using the ldu +! or factorization from nnfc. +! nntc -- the transposed linear system mt x = b is solved using +! the ldu factorization from nnf. +! for several systems whose coefficient matrices have the same +! nonzero structure, nsfc need be done only once (for the first +! system). then nnfc is done once for each additional system. for +! several systems with the same coefficient matrix, nsfc and nnfc +! need be done only once (for the first system). then nnsc or nntc +! is done once for each additional right-hand side. +! +! nv - path - path specification. values and their meanings are -- +! - 1 perform nroc, nsfc, and nnfc. +! - 2 perform nnfc only (nsfc is assumed to have been +! - done in a manner compatible with the storage +! - allocation used in the driver). +! - 3 perform nnsc only (nsfc and nnfc are assumed to +! - have been done in a manner compatible with the +! - storage allocation used in the driver). +! - 4 perform nntc only (nsfc and nnfc are assumed to +! - have been done in a manner compatible with the +! - storage allocation used in the driver). +! - 5 perform nroc and nsfc. +! +! various errors are detected by the driver and the individual +! subroutines. +! +! nr - flag - error flag. values and their meanings are -- +! - 0 no errors detected +! - n+k null row in a -- row = k +! - 2n+k duplicate entry in a -- row = k +! - 3n+k insufficient storage in nsfc -- row = k +! - 4n+1 insufficient storage in nnfc +! - 5n+k null pivot -- row = k +! - 6n+k insufficient storage in nsfc -- row = k +! - 7n+1 insufficient storage in nnfc +! - 8n+k zero pivot -- row = k +! - 10n+1 insufficient storage in cdrv +! - 11n+1 illegal path specification +! +! working storage is needed for the factored form of the matrix +! m plus various temporary vectors. the arrays isp and rsp should be +! equivalenced. integer storage is allocated from the beginning of +! isp and real storage from the end of rsp. +! +! nv - nsp - declared dimension of rsp. nsp generally must +! - be larger than 8n+2 + 2k (where k = (number of +! - nonzero entries in m)). +! nvira - isp - integer working storage divided up into various arrays +! - needed by the subroutines. isp and rsp should be +! - equivalenced. +! - size = lratio*nsp. +! fvira - rsp - real working storage divided up into various arrays +! - needed by the subroutines. isp and rsp should be +! - equivalenced. +! - size = nsp. +! nr - esp - if sufficient storage was available to perform the +! - symbolic factorization (nsfc), then esp is set to +! - the amount of excess storage provided (negative if +! - insufficient storage was available to perform the +! - numeric factorization (nnfc)). +! +! +! conversion to double precision +! +! to convert these routines for double precision arrays.. +! (1) use the double precision declarations in place of the real +! declarations in each subprogram, as given in comment cards. +! (2) change the data-loaded value of the integer lratio +! in subroutine cdrv, as indicated below. +! (3) change e0 to d0 in the constants in statement number 10 +! in subroutine nnfc and the line following that. +! +!jdf integer r(1), c(1), ic(1), ia(1), ja(1), isp(1), esp, path, +!jdf * flag, d, u, q, row, tmp, ar, umax +!jdf real a(1), b(1), z(1), rsp(1) + integer r(*), c(*), ic(*), ia(*), ja(*), isp(*), esp, path, & + flag, d, u, q, row, tmp, ar, umax + real a(*), b(*), z(*), rsp(*) +! double precision a(1), b(1), z(1), rsp(1) +! +! set lratio equal to the ratio between the length of floating point +! and integer array data. e. g., lratio = 1 for (real, integer), +! lratio = 2 for (double precision, integer) +! + data lratio/1/ +! + if (path.lt.1 .or. 5.lt.path) go to 111 +!******initialize and divide up temporary storage ******************* + il = 1 + ijl = il + (n+1) + iu = ijl + n + iju = iu + (n+1) + irl = iju + n + jrl = irl + n + jl = jrl + n +! +! ****** reorder a if necessary, call nsfc if flag is set *********** + if ((path-1) * (path-5) .ne. 0) go to 5 + max = (lratio*nsp + 1 - jl) - (n+1) - 5*n + jlmax = max/2 + q = jl + jlmax + ira = q + (n+1) + jra = ira + n + irac = jra + n + iru = irac + n + jru = iru + n + jutmp = jru + n + jumax = lratio*nsp + 1 - jutmp + esp = max/lratio + if (jlmax.le.0 .or. jumax.le.0) go to 110 +! + do 1 i=1,n + if (c(i).ne.i) go to 2 + 1 continue + go to 3 + 2 ar = nsp + 1 - n + call nroc & + (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) + if (flag.ne.0) go to 100 +! + 3 call nsfc & + (n, r, ic, ia,ja, & + jlmax, isp(il), isp(jl), isp(ijl), & + jumax, isp(iu), isp(jutmp), isp(iju), & + isp(q), isp(ira), isp(jra), isp(irac), & + isp(irl), isp(jrl), isp(iru), isp(jru), flag) + if(flag .ne. 0) go to 100 +! ****** move ju next to jl ***************************************** + jlmax = isp(ijl+n-1) + ju = jl + jlmax + jumax = isp(iju+n-1) + if (jumax.le.0) go to 5 + do 4 j=1,jumax + 4 isp(ju+j-1) = isp(jutmp+j-1) +! +! ****** call remaining subroutines ********************************* + 5 jlmax = isp(ijl+n-1) + ju = jl + jlmax + jumax = isp(iju+n-1) + l = (ju + jumax - 2 + lratio) / lratio + 1 + lmax = isp(il+n) - 1 + d = l + lmax + u = d + n + row = nsp + 1 - n + tmp = row - n + umax = tmp - u + esp = umax - (isp(iu+n) - 1) +! + if ((path-1) * (path-2) .ne. 0) go to 6 + if (umax.lt.0) go to 110 + call nnfc & + (n, r, c, ic, ia, ja, a, z, b, & + lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), & + umax, isp(iu), isp(ju), isp(iju), rsp(u), & + rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) + if(flag .ne. 0) go to 100 +! + 6 if ((path-3) .ne. 0) go to 7 + call nnsc & + (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), & + rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), & + z, b, rsp(tmp)) +! + 7 if ((path-4) .ne. 0) go to 8 + call nntc & + (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), & + rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), & + z, b, rsp(tmp)) + 8 return +! +! ** error.. error detected in nroc, nsfc, nnfc, or nnsc + 100 return +! ** error.. insufficient storage + 110 flag = 10*n + 1 + return +! ** error.. illegal path specification + 111 flag = 11*n + 1 + return + end subroutine cdrv + subroutine cfode (meth, elco, tesco) +!lll. optimize + integer meth + integer i, ib, nq, nqm1, nqp1 + real elco, tesco + real agamq, fnq, fnqm1, pc, pint, ragq, & + rqfac, rq1fac, tsign, xpin + dimension elco(13,12), tesco(3,12) +!----------------------------------------------------------------------- +! cfode is called by the integrator routine to set coefficients +! needed there. the coefficients for the current method, as +! given by the value of meth, are set for all orders and saved. +! the maximum order assumed here is 12 if meth = 1 and 5 if meth = 2. +! (a smaller value of the maximum order is also allowed.) +! cfode is called once at the beginning of the problem, +! and is not called again unless and until meth is changed. +! +! the elco array contains the basic method coefficients. +! the coefficients el(i), 1 .le. i .le. nq+1, for the method of +! order nq are stored in elco(i,nq). they are given by a genetrating +! polynomial, i.e., +! l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. +! for the implicit adams methods, l(x) is given by +! dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. +! for the bdf methods, l(x) is given by +! l(x) = (x+1)*(x+2)* ... *(x+nq)/k, +! where k = factorial(nq)*(1 + 1/2 + ... + 1/nq). +! +! the tesco array contains test constants used for the +! local error test and the selection of step size and/or order. +! at order nq, tesco(k,nq) is used for the selection of step +! size at order nq - 1 if k = 1, at order nq if k = 2, and at order +! nq + 1 if k = 3. +!----------------------------------------------------------------------- + dimension pc(12) +! + go to (100, 200), meth +! + 100 elco(1,1) = 1.0e0 + elco(2,1) = 1.0e0 + tesco(1,1) = 0.0e0 + tesco(2,1) = 2.0e0 + tesco(1,2) = 1.0e0 + tesco(3,12) = 0.0e0 + pc(1) = 1.0e0 + rqfac = 1.0e0 + do 140 nq = 2,12 +!----------------------------------------------------------------------- +! the pc array will contain the coefficients of the polynomial +! p(x) = (x+1)*(x+2)*...*(x+nq-1). +! initially, p(x) = 1. +!----------------------------------------------------------------------- + rq1fac = rqfac + rqfac = rqfac/float(nq) + nqm1 = nq - 1 + fnqm1 = float(nqm1) + nqp1 = nq + 1 +! form coefficients of p(x)*(x+nq-1). ---------------------------------- + pc(nq) = 0.0e0 + do 110 ib = 1,nqm1 + i = nqp1 - ib + 110 pc(i) = pc(i-1) + fnqm1*pc(i) + pc(1) = fnqm1*pc(1) +! compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- + pint = pc(1) + xpin = pc(1)/2.0e0 + tsign = 1.0e0 + do 120 i = 2,nq + tsign = -tsign + pint = pint + tsign*pc(i)/float(i) + 120 xpin = xpin + tsign*pc(i)/float(i+1) +! store coefficients in elco and tesco. -------------------------------- + elco(1,nq) = pint*rq1fac + elco(2,nq) = 1.0e0 + do 130 i = 2,nq + 130 elco(i+1,nq) = rq1fac*pc(i)/float(i) + agamq = rqfac*xpin + ragq = 1.0e0/agamq + tesco(2,nq) = ragq + if (nq .lt. 12) tesco(1,nqp1) = ragq*rqfac/float(nqp1) + tesco(3,nqm1) = ragq + 140 continue + return +! + 200 pc(1) = 1.0e0 + rq1fac = 1.0e0 + do 230 nq = 1,5 +!----------------------------------------------------------------------- +! the pc array will contain the coefficients of the polynomial +! p(x) = (x+1)*(x+2)*...*(x+nq). +! initially, p(x) = 1. +!----------------------------------------------------------------------- + fnq = float(nq) + nqp1 = nq + 1 +! form coefficients of p(x)*(x+nq). ------------------------------------ + pc(nqp1) = 0.0e0 + do 210 ib = 1,nq + i = nq + 2 - ib + 210 pc(i) = pc(i-1) + fnq*pc(i) + pc(1) = fnq*pc(1) +! store coefficients in elco and tesco. -------------------------------- + do 220 i = 1,nqp1 + 220 elco(i,nq) = pc(i)/pc(2) + elco(2,nq) = 1.0e0 + tesco(1,nq) = rq1fac + tesco(2,nq) = float(nqp1)/elco(1,nq) + tesco(3,nq) = float(nq+2)/elco(1,nq) + rq1fac = rq1fac/fnq + 230 continue + return +!----------------------- end of subroutine cfode ----------------------- + end subroutine cfode + subroutine cntnzu (n, ia, ja, nzsut) + integer n, ia, ja, nzsut +!jdf dimension ia(1), ja(1) + dimension ia(*), ja(*) +!----------------------------------------------------------------------- +! this routine counts the number of nonzero elements in the strict +! upper triangle of the matrix m + m(transpose), where the sparsity +! structure of m is given by pointer arrays ia and ja. +! this is needed to compute the storage requirements for the +! sparse matrix reordering operation in odrv. +!----------------------------------------------------------------------- + integer ii, jj, j, jmin, jmax, k, kmin, kmax, num +! + num = 0 + do 50 ii = 1,n + jmin = ia(ii) + jmax = ia(ii+1) - 1 + if (jmin .gt. jmax) go to 50 + do 40 j = jmin,jmax + if (ja(j) - ii) 10, 40, 30 + 10 jj =ja(j) + kmin = ia(jj) + kmax = ia(jj+1) - 1 + if (kmin .gt. kmax) go to 30 + do 20 k = kmin,kmax + if (ja(k) .eq. ii) go to 40 + 20 continue + 30 num = num + 1 + 40 continue + 50 continue + nzsut = num + return +!----------------------- end of subroutine cntnzu ---------------------- + end subroutine cntnzu + subroutine ewset (n, itol, rtol, atol, ycur, ewt) +!lll. optimize +!----------------------------------------------------------------------- +! this subroutine sets the error weight vector ewt according to +! ewt(i) = rtol(i)*abs(ycur(i)) + atol(i), i = 1,...,n, +! with the subscript on rtol and/or atol possibly replaced by 1 above, +! depending on the value of itol. +!----------------------------------------------------------------------- + integer n, itol + integer i + real rtol, atol, ycur, ewt +!jdf dimension rtol(1), atol(1), ycur(n), ewt(n) + dimension rtol(*), atol(*), ycur(n), ewt(n) +! + go to (10, 20, 30, 40), itol + 10 continue + do 15 i = 1,n + 15 ewt(i) = rtol(1)*abs(ycur(i)) + atol(1) + return + 20 continue + do 25 i = 1,n + 25 ewt(i) = rtol(1)*abs(ycur(i)) + atol(i) + return + 30 continue + do 35 i = 1,n + 35 ewt(i) = rtol(i)*abs(ycur(i)) + atol(1) + return + 40 continue + do 45 i = 1,n + 45 ewt(i) = rtol(i)*abs(ycur(i)) + atol(i) + return +!----------------------- end of subroutine ewset ----------------------- + end subroutine ewset + subroutine intdy (t, k, yh, nyh, dky, iflag) +!lll. optimize + integer k, nyh, iflag + integer iownd, iowns, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer i, ic, j, jb, jb2, jj, jj1, jp1 + real t, yh, dky + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real c, r, s, tp +!jdf dimension yh(nyh,1), dky(1) + dimension yh(nyh,*), dky(*) + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + iownd(14), iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +!----------------------------------------------------------------------- +! intdy computes interpolated values of the k-th derivative of the +! dependent variable vector y, and stores it in dky. this routine +! is called within the package with k = 0 and t = tout, but may +! also be called by the user for any k up to the current order. +! (see detailed instructions in the usage documentation.) +!----------------------------------------------------------------------- +! the computed values in dky are gotten by interpolation using the +! nordsieck history array yh. this array corresponds uniquely to a +! vector-valued polynomial of degree nqcur or less, and dky is set +! to the k-th derivative of this polynomial at t. +! the formula for dky is.. +! q +! dky(i) = sum c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1) +! j=k +! where c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur. +! the quantities nq = nqcur, l = nq+1, n = neq, tn, and h are +! communicated by common. the above sum is done in reverse order. +! iflag is returned negative if either k or t is out of bounds. +!----------------------------------------------------------------------- + iflag = 0 + if (k .lt. 0 .or. k .gt. nq) go to 80 + tp = tn - hu - 100.0e0*uround*(tn + hu) + if ((t-tp)*(t-tn) .gt. 0.0e0) go to 90 +! + s = (t - tn)/h + ic = 1 + if (k .eq. 0) go to 15 + jj1 = l - k + do 10 jj = jj1,nq + 10 ic = ic*jj + 15 c = float(ic) + do 20 i = 1,n + 20 dky(i) = c*yh(i,l) + if (k .eq. nq) go to 55 + jb2 = nq - k + do 50 jb = 1,jb2 + j = nq - jb + jp1 = j + 1 + ic = 1 + if (k .eq. 0) go to 35 + jj1 = jp1 - k + do 30 jj = jj1,j + 30 ic = ic*jj + 35 c = float(ic) + do 40 i = 1,n + 40 dky(i) = c*yh(i,jp1) + s*dky(i) + 50 continue + if (k .eq. 0) return + 55 r = h**(-k) + do 60 i = 1,n + 60 dky(i) = r*dky(i) + return +! + 80 call xerrwv('intdy-- k (=i1) illegal ', & + 30, 51, 0, 1, k, 0, 0, 0.0e0, 0.0e0) + iflag = -1 + return + 90 call xerrwv('intdy-- t (=r1) illegal ', & + 30, 52, 0, 0, 0, 0, 1, t, 0.0e0) + call xerrwv( & + ' t not in interval tcur - hu (= r1) to tcur (=r2) ', & + 60, 52, 0, 0, 0, 0, 2, tp, tn) + iflag = -2 + return +!----------------------- end of subroutine intdy ----------------------- + end subroutine intdy + subroutine iprep (neq, y, rwork, ia, ja, ipflag, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar ) +!lll. optimize + external f, jac + integer neq, ia, ja, ipflag + integer illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, & + mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns + integer icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, imax, lewtn, lyhd, lyhn + integer nruserpar, iuserpar, niuserpar + real y, rwork + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real rlss + real ruserpar +!jdf dimension neq(1), y(1), rwork(1), ia(1), ja(1) + dimension neq(*), y(*), rwork(*), ia(*), ja(*) + dimension ruserpar(nruserpar), iuserpar(niuserpar) + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, & + mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ rlss(6), & + iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu +!----------------------------------------------------------------------- +! this routine serves as an interface between the driver and +! subroutine prep. it is called only if miter is 1 or 2. +! tasks performed here are.. +! * call prep, +! * reset the required wm segment length lenwk, +! * move yh back to its final location (following wm in rwork), +! * reset pointers for yh, savf, ewt, and acor, and +! * move ewt to its new position if istate = 1. +! ipflag is an output error indication flag. ipflag = 0 if there was +! no trouble, and ipflag is the value of the prep error flag ipper +! if there was trouble in subroutine prep. +!----------------------------------------------------------------------- + ipflag = 0 +! call prep to do matrix preprocessing operations. --------------------- + call prep_lsodes (neq, y, rwork(lyh), rwork(lsavf), rwork(lewt), & + rwork(lacor), ia, ja, rwork(lwm), rwork(lwm), ipflag, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar ) + lenwk = max0(lreq,lwmin) + if (ipflag .lt. 0) return +! if prep was successful, move yh to end of required space for wm. ----- + lyhn = lwm + lenwk + if (lyhn .gt. lyh) return + lyhd = lyh - lyhn + if (lyhd .eq. 0) go to 20 + imax = lyhn - 1 + lenyhm + do 10 i = lyhn,imax + 10 rwork(i) = rwork(i+lyhd) + lyh = lyhn +! reset pointers for savf, ewt, and acor. ------------------------------ + 20 lsavf = lyh + lenyh + lewtn = lsavf + n + lacor = lewtn + n + if (istatc .eq. 3) go to 40 +! if istate = 1, move ewt (left) to its new position. ------------------ + if (lewtn .gt. lewt) return + do 30 i = 1,n + 30 rwork(i+lewtn-1) = rwork(i+lewt-1) + 40 lewt = lewtn + return +!----------------------- end of subroutine iprep ----------------------- + end subroutine iprep + subroutine jgroup (n,ia,ja,maxg,ngrp,igp,jgp,incl,jdone,ier) +!lll. optimize + integer n, ia, ja, maxg, ngrp, igp, jgp, incl, jdone, ier +!jdf dimension ia(1), ja(1), igp(1), jgp(n), incl(n), jdone(n) + dimension ia(*), ja(*), igp(*), jgp(n), incl(n), jdone(n) +!----------------------------------------------------------------------- +! this subroutine constructs groupings of the column indices of +! the jacobian matrix, used in the numerical evaluation of the +! jacobian by finite differences. +! +! input.. +! n = the order of the matrix. +! ia,ja = sparse structure descriptors of the matrix by rows. +! maxg = length of available storate in the igp array. +! +! output.. +! ngrp = number of groups. +! jgp = array of length n containing the column indices by groups. +! igp = pointer array of length ngrp + 1 to the locations in jgp +! of the beginning of each group. +! ier = error indicator. ier = 0 if no error occurred, or 1 if +! maxg was insufficient. +! +! incl and jdone are working arrays of length n. +!----------------------------------------------------------------------- + integer i, j, k, kmin, kmax, ncol, ng +! + ier = 0 + do 10 j = 1,n + 10 jdone(j) = 0 + ncol = 1 + do 60 ng = 1,maxg + igp(ng) = ncol + do 20 i = 1,n + 20 incl(i) = 0 + do 50 j = 1,n +! reject column j if it is already in a group.-------------------------- + if (jdone(j) .eq. 1) go to 50 + kmin = ia(j) + kmax = ia(j+1) - 1 + do 30 k = kmin,kmax +! reject column j if it overlaps any column already in this group.------ + i = ja(k) + if (incl(i) .eq. 1) go to 50 + 30 continue +! accept column j into group ng.---------------------------------------- + jgp(ncol) = j + ncol = ncol + 1 + jdone(j) = 1 + do 40 k = kmin,kmax + i = ja(k) + 40 incl(i) = 1 + 50 continue +! stop if this group is empty (grouping is complete).------------------- + if (ncol .eq. igp(ng)) go to 70 + 60 continue +! error return if not all columns were chosen (maxg too small).--------- + if (ncol .le. n) go to 80 + ng = maxg + 70 ngrp = ng - 1 + return + 80 ier = 1 + return +!----------------------- end of subroutine jgroup ---------------------- + end subroutine jgroup + subroutine md & + (n, ia,ja, max, v,l, head,last,next, mark, flag) +!lll. optimize +!*********************************************************************** +! md -- minimum degree algorithm (based on element model) +!*********************************************************************** +! +! description +! +! md finds a minimum degree ordering of the rows and columns of a +! general sparse matrix m stored in (ia,ja,a) format. +! when the structure of m is nonsymmetric, the ordering is that +! obtained for the symmetric matrix m + m-transpose. +! +! +! additional parameters +! +! max - declared dimension of the one-dimensional arrays v and l. +! max must be at least n+2k, where k is the number of +! nonzeroes in the strict upper triangle of m + m-transpose +! +! v - integer one-dimensional work array. dimension = max +! +! l - integer one-dimensional work array. dimension = max +! +! head - integer one-dimensional work array. dimension = n +! +! last - integer one-dimensional array used to return the permutation +! of the rows and columns of m corresponding to the minimum +! degree ordering. dimension = n +! +! next - integer one-dimensional array used to return the inverse of +! the permutation returned in last. dimension = n +! +! mark - integer one-dimensional work array (may be the same as v). +! dimension = n +! +! flag - integer error flag. values and their meanings are - +! 0 no errors detected +! 9n+k insufficient storage in md +! +! +! definitions of internal parameters +! +! ---------+--------------------------------------------------------- +! v(s) - value field of list entry +! ---------+--------------------------------------------------------- +! l(s) - link field of list entry (0 =) end of list) +! ---------+--------------------------------------------------------- +! l(vi) - pointer to element list of uneliminated vertex vi +! ---------+--------------------------------------------------------- +! l(ej) - pointer to boundary list of active element ej +! ---------+--------------------------------------------------------- +! head(d) - vj =) vj head of d-list d +! - 0 =) no vertex in d-list d +! +! +! - vi uneliminated vertex +! - vi in ek - vi not in ek +! ---------+-----------------------------+--------------------------- +! next(vi) - undefined but nonnegative - vj =) vj next in d-list +! - - 0 =) vi tail of d-list +! ---------+-----------------------------+--------------------------- +! last(vi) - (not set until mdp) - -d =) vi head of d-list d +! --vk =) compute degree - vj =) vj last in d-list +! - ej =) vi prototype of ej - 0 =) vi not in any d-list +! - 0 =) do not compute degree - +! ---------+-----------------------------+--------------------------- +! mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) +! +! +! - vi eliminated vertex +! - ei active element - otherwise +! ---------+-----------------------------+--------------------------- +! next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex +! - to be eliminated - to be eliminated +! ---------+-----------------------------+--------------------------- +! last(vi) - m =) size of ei = m - undefined +! ---------+-----------------------------+--------------------------- +! mark(vi) - -m =) overlap count of ei - undefined +! - with ek = m - +! - otherwise nonnegative tag - +! - .lt. mark(vk) - +! +!----------------------------------------------------------------------- +! +!jdf integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), +!jdf * mark(1), flag, tag, dmin, vk,ek, tail + integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), & + mark(*), flag, tag, dmin, vk,ek, tail + equivalence (vk,ek) +! +!----initialization + tag = 0 + call mdi & + (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) + if (flag.ne.0) return +! + k = 0 + dmin = 1 +! +!----while k .lt. n do + 1 if (k.ge.n) go to 4 +! +!------search for vertex of minimum degree + 2 if (head(dmin).gt.0) go to 3 + dmin = dmin + 1 + go to 2 +! +!------remove vertex vk of minimum degree from degree list + 3 vk = head(dmin) + head(dmin) = next(vk) + if (head(dmin).gt.0) last(head(dmin)) = -dmin +! +!------number vertex vk, adjust tag, and tag vk + k = k+1 + next(vk) = -k + last(ek) = dmin - 1 + tag = tag + last(ek) + mark(vk) = tag +! +!------form element ek from uneliminated neighbors of vk + call mdm & + (vk,tail, v,l, last,next, mark) +! +!------purge inactive elements and do mass elimination + call mdp & + (k,ek,tail, v,l, head,last,next, mark) +! +!------update degrees of uneliminated vertices in ek + call mdu & + (ek,dmin, v,l, head,last,next, mark) +! + go to 1 +! +!----generate inverse permutation from permutation + 4 do 5 k=1,n + next(k) = -next(k) + 5 last(next(k)) = k +! + return + end subroutine md + subroutine mdi & + (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) +!lll. optimize +!*********************************************************************** +! mdi -- initialization +!*********************************************************************** +!jdf integer ia(1), ja(1), v(1), l(1), head(1), last(1), next(1), +!jdf * mark(1), tag, flag, sfs, vi,dvi, vj + integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), & + mark(*), tag, flag, sfs, vi,dvi, vj +! +!----initialize degrees, element lists, and degree lists + do 1 vi=1,n + mark(vi) = 1 + l(vi) = 0 + 1 head(vi) = 0 + sfs = n+1 +! +!----create nonzero structure +!----for each nonzero entry a(vi,vj) + do 6 vi=1,n + jmin = ia(vi) + jmax = ia(vi+1) - 1 + if (jmin.gt.jmax) go to 6 + do 5 j=jmin,jmax + vj = ja(j) + if (vj-vi) 2, 5, 4 +! +!------if a(vi,vj) is in strict lower triangle +!------check for previous occurrence of a(vj,vi) + 2 lvk = vi + kmax = mark(vi) - 1 + if (kmax .eq. 0) go to 4 + do 3 k=1,kmax + lvk = l(lvk) + if (v(lvk).eq.vj) go to 5 + 3 continue +!----for unentered entries a(vi,vj) + 4 if (sfs.ge.max) go to 101 +! +!------enter vj in element list for vi + mark(vi) = mark(vi) + 1 + v(sfs) = vj + l(sfs) = l(vi) + l(vi) = sfs + sfs = sfs+1 +! +!------enter vi in element list for vj + mark(vj) = mark(vj) + 1 + v(sfs) = vi + l(sfs) = l(vj) + l(vj) = sfs + sfs = sfs+1 + 5 continue + 6 continue +! +!----create degree lists and initialize mark vector + do 7 vi=1,n + dvi = mark(vi) + next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + nextvi = next(vi) + if (nextvi.gt.0) last(nextvi) = vi + 7 mark(vi) = tag +! + return +! +! ** error- insufficient storage + 101 flag = 9*n + vi + return + end subroutine mdi + subroutine mdm & + (vk,tail, v,l, last,next, mark) +!lll. optimize +!*********************************************************************** +! mdm -- form element from uneliminated neighbors of vk +!*********************************************************************** +!jdf integer vk, tail, v(1), l(1), last(1), next(1), mark(1), +!jdf * tag, s,ls,vs,es, b,lb,vb, blp,blpmax + integer vk, tail, v(*), l(*), last(*), next(*), mark(*), & + tag, s,ls,vs,es, b,lb,vb, blp,blpmax + equivalence (vs, es) +! +!----initialize tag and list of uneliminated neighbors + tag = mark(vk) + tail = vk +! +!----for each vertex/element vs/es in element list of vk + ls = l(vk) + 1 s = ls + if (s.eq.0) go to 5 + ls = l(s) + vs = v(s) + if (next(vs).lt.0) go to 2 +! +!------if vs is uneliminated vertex, then tag and append to list of +!------uneliminated neighbors + mark(vs) = tag + l(tail) = s + tail = s + go to 4 +! +!------if es is active element, then ... +!--------for each vertex vb in boundary list of element es + 2 lb = l(es) + blpmax = last(es) + do 3 blp=1,blpmax + b = lb + lb = l(b) + vb = v(b) +! +!----------if vb is untagged vertex, then tag and append to list of +!----------uneliminated neighbors + if (mark(vb).ge.tag) go to 3 + mark(vb) = tag + l(tail) = b + tail = b + 3 continue +! +!--------mark es inactive + mark(es) = tag +! + 4 go to 1 +! +!----terminate list of uneliminated neighbors + 5 l(tail) = 0 +! + return + end subroutine mdm + subroutine mdp & + (k,ek,tail, v,l, head,last,next, mark) +!lll. optimize +!*********************************************************************** +! mdp -- purge inactive elements and do mass elimination +!*********************************************************************** +!jdf integer ek, tail, v(1), l(1), head(1), last(1), next(1), +!jdf * mark(1), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax + integer ek, tail, v(*), l(*), head(*), last(*), next(*), & + mark(*), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax +! +!----initialize tag + tag = mark(ek) +! +!----for each vertex vi in ek + li = ek + ilpmax = last(ek) + if (ilpmax.le.0) go to 12 + do 11 ilp=1,ilpmax + i = li + li = l(i) + vi = v(li) +! +!------remove vi from degree list + if (last(vi).eq.0) go to 3 + if (last(vi).gt.0) go to 1 + head(-last(vi)) = next(vi) + go to 2 + 1 next(last(vi)) = next(vi) + 2 if (next(vi).gt.0) last(next(vi)) = last(vi) +! +!------remove inactive items from element list of vi + 3 ls = vi + 4 s = ls + ls = l(s) + if (ls.eq.0) go to 6 + es = v(ls) + if (mark(es).lt.tag) go to 5 + free = ls + l(s) = l(ls) + ls = s + 5 go to 4 +! +!------if vi is interior vertex, then remove from list and eliminate + 6 lvi = l(vi) + if (lvi.ne.0) go to 7 + l(i) = l(li) + li = i +! + k = k+1 + next(vi) = -k + last(ek) = last(ek) - 1 + go to 11 +! +!------else ... +!--------classify vertex vi + 7 if (l(lvi).ne.0) go to 9 + evi = v(lvi) + if (next(evi).ge.0) go to 9 + if (mark(evi).lt.0) go to 8 +! +!----------if vi is prototype vertex, then mark as such, initialize +!----------overlap count for corresponding element, and move vi to end +!----------of boundary list + last(vi) = evi + mark(evi) = -1 + l(tail) = li + tail = li + l(i) = l(li) + li = i + go to 10 +! +!----------else if vi is duplicate vertex, then mark as such and adjust +!----------overlap count for corresponding element + 8 last(vi) = 0 + mark(evi) = mark(evi) - 1 + go to 10 +! +!----------else mark vi to compute degree + 9 last(vi) = -ek +! +!--------insert ek in element list of vi + 10 v(free) = ek + l(free) = l(vi) + l(vi) = free + 11 continue +! +!----terminate boundary list + 12 l(tail) = 0 +! + return + end subroutine mdp + subroutine mdu & + (ek,dmin, v,l, head,last,next, mark) +!lll. optimize +!*********************************************************************** +! mdu -- update degrees of uneliminated vertices in ek +!*********************************************************************** +!jdf integer ek, dmin, v(1), l(1), head(1), last(1), next(1), +!jdf * mark(1), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, +!jdf * blp,blpmax + integer ek, dmin, v(*), l(*), head(*), last(*), next(*), & + mark(*), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, & + blp,blpmax + equivalence (vs, es) +! +!----initialize tag + tag = mark(ek) - last(ek) +! +!----for each vertex vi in ek + i = ek + ilpmax = last(ek) + if (ilpmax.le.0) go to 11 + do 10 ilp=1,ilpmax + i = l(i) + vi = v(i) + if (last(vi)) 1, 10, 8 +! +!------if vi neither prototype nor duplicate vertex, then merge elements +!------to compute degree + 1 tag = tag + 1 + dvi = last(ek) +! +!--------for each vertex/element vs/es in element list of vi + s = l(vi) + 2 s = l(s) + if (s.eq.0) go to 9 + vs = v(s) + if (next(vs).lt.0) go to 3 +! +!----------if vs is uneliminated vertex, then tag and adjust degree + mark(vs) = tag + dvi = dvi + 1 + go to 5 +! +!----------if es is active element, then expand +!------------check for outmatched vertex + 3 if (mark(es).lt.0) go to 6 +! +!------------for each vertex vb in es + b = es + blpmax = last(es) + do 4 blp=1,blpmax + b = l(b) + vb = v(b) +! +!--------------if vb is untagged, then tag and adjust degree + if (mark(vb).ge.tag) go to 4 + mark(vb) = tag + dvi = dvi + 1 + 4 continue +! + 5 go to 2 +! +!------else if vi is outmatched vertex, then adjust overlaps but do not +!------compute degree + 6 last(vi) = 0 + mark(es) = mark(es) - 1 + 7 s = l(s) + if (s.eq.0) go to 10 + es = v(s) + if (mark(es).lt.0) mark(es) = mark(es) - 1 + go to 7 +! +!------else if vi is prototype vertex, then calculate degree by +!------inclusion/exclusion and reset overlap count + 8 evi = last(vi) + dvi = last(ek) + last(evi) + mark(evi) + mark(evi) = 0 +! +!------insert vi in appropriate degree list + 9 next(vi) = head(dvi) + head(dvi) = vi + last(vi) = -dvi + if (next(vi).gt.0) last(next(vi)) = vi + if (dvi.lt.dmin) dmin = dvi +! + 10 continue +! + 11 return + end subroutine mdu + subroutine nnfc & + (n, r,c,ic, ia,ja,a, z, b, & + lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, & + row, tmp, irl,jrl, flag) +!lll. optimize +!*** subroutine nnfc +!*** numerical ldu-factorization of sparse nonsymmetric matrix and +! solution of system of linear equations (compressed pointer +! storage) +! +! +! input variables.. n, r, c, ic, ia, ja, a, b, +! il, jl, ijl, lmax, iu, ju, iju, umax +! output variables.. z, l, d, u, flag +! +! parameters used internally.. +! nia - irl, - vectors used to find the rows of l. at the kth step +! nia - jrl of the factorization, jrl(k) points to the head +! - of a linked list in jrl of column indices j +! - such j .lt. k and l(k,j) is nonzero. zero +! - indicates the end of the list. irl(j) (j.lt.k) +! - points to the smallest i such that i .ge. k and +! - l(i,j) is nonzero. +! - size of each = n. +! fia - row - holds intermediate values in calculation of u and l. +! - size = n. +! fia - tmp - holds new right-hand side b* for solution of the +! - equation ux = b*. +! - size = n. +! +! internal variables.. +! jmin, jmax - indices of the first and last positions in a row to +! be examined. +! sum - used in calculating tmp. +! + integer rk,umax +!jdf integer r(1), c(1), ic(1), ia(1), ja(1), il(1), jl(1), ijl(1) +!jdf integer iu(1), ju(1), iju(1), irl(1), jrl(1), flag +!jdf real a(1), l(1), d(1), u(1), z(1), b(1), row(1) +!jdf real tmp(1), lki, sum, dk + integer r(*), c(*), ic(*), ia(*), ja(*), il(*), jl(*), ijl(*) + integer iu(*), ju(*), iju(*), irl(*), jrl(*), flag + real a(*), l(*), d(*), u(*), z(*), b(*), row(*) + real tmp(*), lki, sum, dk +! double precision a(1), l(1), d(1), u(1), z(1), b(1), row(1) +! double precision tmp(1), lki, sum, dk +! +! ****** initialize pointers and test storage *********************** + if(il(n+1)-1 .gt. lmax) go to 104 + if(iu(n+1)-1 .gt. umax) go to 107 + do 1 k=1,n + irl(k) = il(k) + jrl(k) = 0 + 1 continue +! +! ****** for each row *********************************************** + do 19 k=1,n +! ****** reverse jrl and zero row where kth row of l will fill in *** + row(k) = 0 + i1 = 0 + if (jrl(k) .eq. 0) go to 3 + i = jrl(k) + 2 i2 = jrl(i) + jrl(i) = i1 + i1 = i + row(i) = 0 + i = i2 + if (i .ne. 0) go to 2 +! ****** set row to zero where u will fill in *********************** + 3 jmin = iju(k) + jmax = jmin + iu(k+1) - iu(k) - 1 + if (jmin .gt. jmax) go to 5 + do 4 j=jmin,jmax + 4 row(ju(j)) = 0 +! ****** place kth row of a in row ********************************** + 5 rk = r(k) + jmin = ia(rk) + jmax = ia(rk+1) - 1 + do 6 j=jmin,jmax + row(ic(ja(j))) = a(j) + 6 continue +! ****** initialize sum, and link through jrl *********************** + sum = b(rk) + i = i1 + if (i .eq. 0) go to 10 +! ****** assign the kth row of l and adjust row, sum **************** + 7 lki = -row(i) +! ****** if l is not required, then comment out the following line ** + l(irl(i)) = -lki + sum = sum + lki * tmp(i) + jmin = iu(i) + jmax = iu(i+1) - 1 + if (jmin .gt. jmax) go to 9 + mu = iju(i) - jmin + do 8 j=jmin,jmax + 8 row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) + 9 i = jrl(i) + if (i .ne. 0) go to 7 +! +! ****** assign kth row of u and diagonal d, set tmp(k) ************* + 10 if (row(k) .eq. 0.0e0) go to 108 + dk = 1.0e0 / row(k) + d(k) = dk + tmp(k) = sum * dk + if (k .eq. n) go to 19 + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 12 + mu = iju(k) - jmin + do 11 j=jmin,jmax + 11 u(j) = row(ju(mu+j)) * dk + 12 continue +! +! ****** update irl and jrl, keeping jrl in decreasing order ******** + i = i1 + if (i .eq. 0) go to 18 + 14 irl(i) = irl(i) + 1 + i1 = jrl(i) + if (irl(i) .ge. il(i+1)) go to 17 + ijlb = irl(i) - il(i) + ijl(i) + j = jl(ijlb) + 15 if (i .gt. jrl(j)) go to 16 + j = jrl(j) + go to 15 + 16 jrl(i) = jrl(j) + jrl(j) = i + 17 i = i1 + if (i .ne. 0) go to 14 + 18 if (irl(k) .ge. il(k+1)) go to 19 + j = jl(ijl(k)) + jrl(k) = jrl(j) + jrl(j) = k + 19 continue +! +! ****** solve ux = tmp by back substitution ********************** + k = n + do 22 i=1,n + sum = tmp(k) + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 21 + mu = iju(k) - jmin + do 20 j=jmin,jmax + 20 sum = sum - u(j) * tmp(ju(mu+j)) + 21 tmp(k) = sum + z(c(k)) = sum + 22 k = k-1 + flag = 0 + return +! +! ** error.. insufficient storage for l + 104 flag = 4*n + 1 + return +! ** error.. insufficient storage for u + 107 flag = 7*n + 1 + return +! ** error.. zero pivot + 108 flag = 8*n + k + return + end subroutine nnfc + subroutine nnsc & + (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) +!lll. optimize +!*** subroutine nnsc +!*** numerical solution of sparse nonsymmetric system of linear +! equations given ldu-factorization (compressed pointer storage) +! +! +! input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b +! output variables.. z +! +! parameters used internally.. +! fia - tmp - temporary vector which gets result of solving ly = b. +! - size = n. +! +! internal variables.. +! jmin, jmax - indices of the first and last positions in a row of +! u or l to be used. +! +!jdf integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) +!jdf real l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk, sum + integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) + real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk, sum +! double precision l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum +! +! ****** set tmp to reordered b ************************************* + do 1 k=1,n + 1 tmp(k) = b(r(k)) +! ****** solve ly = b by forward substitution ********************* + do 3 k=1,n + jmin = il(k) + jmax = il(k+1) - 1 + tmpk = -d(k) * tmp(k) + tmp(k) = -tmpk + if (jmin .gt. jmax) go to 3 + ml = ijl(k) - jmin + do 2 j=jmin,jmax + 2 tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) + 3 continue +! ****** solve ux = y by back substitution ************************ + k = n + do 6 i=1,n + sum = -tmp(k) + jmin = iu(k) + jmax = iu(k+1) - 1 + if (jmin .gt. jmax) go to 5 + mu = iju(k) - jmin + do 4 j=jmin,jmax + 4 sum = sum + u(j) * tmp(ju(mu+j)) + 5 tmp(k) = -sum + z(c(k)) = -sum + k = k - 1 + 6 continue + return + end subroutine nnsc + subroutine nntc & + (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) +!lll. optimize +!*** subroutine nntc +!*** numeric solution of the transpose of a sparse nonsymmetric system +! of linear equations given lu-factorization (compressed pointer +! storage) +! +! +! input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b +! output variables.. z +! +! parameters used internally.. +! fia - tmp - temporary vector which gets result of solving ut y = b +! - size = n. +! +! internal variables.. +! jmin, jmax - indices of the first and last positions in a row of +! u or l to be used. +! +!jdf integer r(1), c(1), il(1), jl(1), ijl(1), iu(1), ju(1), iju(1) +!jdf real l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum + integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) + real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum +! double precision l(1), d(1), u(1), b(1), z(1), tmp(1), tmpk,sum +! +! ****** set tmp to reordered b ************************************* + do 1 k=1,n + 1 tmp(k) = b(c(k)) +! ****** solve ut y = b by forward substitution ******************* + do 3 k=1,n + jmin = iu(k) + jmax = iu(k+1) - 1 + tmpk = -tmp(k) + if (jmin .gt. jmax) go to 3 + mu = iju(k) - jmin + do 2 j=jmin,jmax + 2 tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) + 3 continue +! ****** solve lt x = y by back substitution ********************** + k = n + do 6 i=1,n + sum = -tmp(k) + jmin = il(k) + jmax = il(k+1) - 1 + if (jmin .gt. jmax) go to 5 + ml = ijl(k) - jmin + do 4 j=jmin,jmax + 4 sum = sum + l(j) * tmp(jl(ml+j)) + 5 tmp(k) = -sum * d(k) + z(r(k)) = tmp(k) + k = k - 1 + 6 continue + return + end subroutine nntc + subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) +!lll. optimize +! +! ---------------------------------------------------------------- +! +! yale sparse matrix package - nonsymmetric codes +! solving the system of equations mx = b +! +! i. calling sequences +! the coefficient matrix can be processed by an ordering routine +! (e.g., to reduce fillin or ensure numerical stability) before using +! the remaining subroutines. if no reordering is done, then set +! r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine +! is used, then nroc should be used to reorder the coefficient matrix +! the calling sequence is -- +! ( (matrix ordering)) +! (nroc (matrix reordering)) +! nsfc (symbolic factorization to determine where fillin will +! occur during numeric factorization) +! nnfc (numeric factorization into product ldu of unit lower +! triangular matrix l, diagonal matrix d, and unit +! upper triangular matrix u, and solution of linear +! system) +! nnsc (solution of linear system for additional right-hand +! side using ldu factorization from nnfc) +! (if only one system of equations is to be solved, then the +! subroutine trk should be used.) +! +! ii. storage of sparse matrices +! the nonzero entries of the coefficient matrix m are stored +! row-by-row in the array a. to identify the individual nonzero +! entries in each row, we need to know in which column each entry +! lies. the column indices which correspond to the nonzero entries +! of m are stored in the array ja. i.e., if a(k) = m(i,j), then +! ja(k) = j. in addition, we need to know where each row starts and +! how long it is. the index positions in ja and a where the rows of +! m begin are stored in the array ia. i.e., if m(i,j) is the first +! (leftmost) entry in the i-th row and a(k) = m(i,j), then +! ia(i) = k. moreover, the index in ja and a of the first location +! following the last element in the last row is stored in ia(n+1). +! thus, the number of entries in the i-th row is given by +! ia(i+1) - ia(i), the nonzero entries of the i-th row are stored +! consecutively in +! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +! and the corresponding column indices are stored consecutively in +! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +! for example, the 5 by 5 matrix +! ( 1. 0. 2. 0. 0.) +! ( 0. 3. 0. 0. 0.) +! m = ( 0. 4. 5. 6. 0.) +! ( 0. 0. 0. 7. 0.) +! ( 0. 0. 0. 8. 9.) +! would be stored as +! - 1 2 3 4 5 6 7 8 9 +! ---+-------------------------- +! ia - 1 3 4 7 8 10 +! ja - 1 3 2 2 3 4 4 4 5 +! a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . +! +! the strict upper (lower) triangular portion of the matrix +! u (l) is stored in a similar fashion using the arrays iu, ju, u +! (il, jl, l) except that an additional array iju (ijl) is used to +! compress storage of ju (jl) by allowing some sequences of column +! (row) indices to used for more than one row (column) (n.b., l is +! stored by columns). iju(k) (ijl(k)) points to the starting +! location in ju (jl) of entries for the kth row (column). +! compression in ju (jl) occurs in two ways. first, if a row +! (column) i was merged into the current row (column) k, and the +! number of elements merged in from (the tail portion of) row +! (column) i is the same as the final length of row (column) k, then +! the kth row (column) and the tail of row (column) i are identical +! and iju(k) (ijl(k)) points to the start of the tail. second, if +! some tail portion of the (k-1)st row (column) is identical to the +! head of the kth row (column), then iju(k) (ijl(k)) points to the +! start of that tail portion. for example, the nonzero structure of +! the strict upper triangular part of the matrix +! d 0 x x x +! 0 d 0 x x +! 0 0 d x 0 +! 0 0 0 d x +! 0 0 0 0 d +! would be represented as +! - 1 2 3 4 5 6 +! ----+------------ +! iu - 1 4 6 7 8 8 +! ju - 3 4 5 4 +! iju - 1 2 4 3 . +! the diagonal entries of l and u are assumed to be equal to one and +! are not stored. the array d contains the reciprocals of the +! diagonal entries of the matrix d. +! +! iii. additional storage savings +! in nsfc, r and ic can be the same array in the calling +! sequence if no reordering of the coefficient matrix has been done. +! in nnfc, r, c, and ic can all be the same array if no +! reordering has been done. if only the rows have been reordered, +! then c and ic can be the same array. if the row and column +! orderings are the same, then r and c can be the same array. z and +! row can be the same array. +! in nnsc or nntc, r and c can be the same array if no +! reordering has been done or if the row and column orderings are the +! same. z and b can be the same array. however, then b will be +! destroyed. +! +! iv. parameters +! following is a list of parameters to the programs. names are +! uniform among the various subroutines. class abbreviations are -- +! n - integer variable +! f - real variable +! v - supplies a value to a subroutine +! r - returns a result from a subroutine +! i - used internally by a subroutine +! a - array +! +! class - parameter +! ------+---------- +! fva - a - nonzero entries of the coefficient matrix m, stored +! - by rows. +! - size = number of nonzero entries in m. +! fva - b - right-hand side b. +! - size = n. +! nva - c - ordering of the columns of m. +! - size = n. +! fvra - d - reciprocals of the diagonal entries of the matrix d. +! - size = n. +! nr - flag - error flag. values and their meanings are -- +! - 0 no errors detected +! - n+k null row in a -- row = k +! - 2n+k duplicate entry in a -- row = k +! - 3n+k insufficient storage for jl -- row = k +! - 4n+1 insufficient storage for l +! - 5n+k null pivot -- row = k +! - 6n+k insufficient storage for ju -- row = k +! - 7n+1 insufficient storage for u +! - 8n+k zero pivot -- row = k +! nva - ia - pointers to delimit the rows of a. +! - size = n+1. +! nvra - ijl - pointers to the first element in each column in jl, +! - used to compress storage in jl. +! - size = n. +! nvra - iju - pointers to the first element in each row in ju, used +! - to compress storage in ju. +! - size = n. +! nvra - il - pointers to delimit the columns of l. +! - size = n+1. +! nvra - iu - pointers to delimit the rows of u. +! - size = n+1. +! nva - ja - column numbers corresponding to the elements of a. +! - size = size of a. +! nvra - jl - row numbers corresponding to the elements of l. +! - size = jlmax. +! nv - jlmax - declared dimension of jl. jlmax must be larger than +! - the number of nonzeros in the strict lower triangle +! - of m plus fillin minus compression. +! nvra - ju - column numbers corresponding to the elements of u. +! - size = jumax. +! nv - jumax - declared dimension of ju. jumax must be larger than +! - the number of nonzeros in the strict upper triangle +! - of m plus fillin minus compression. +! fvra - l - nonzero entries in the strict lower triangular portion +! - of the matrix l, stored by columns. +! - size = lmax. +! nv - lmax - declared dimension of l. lmax must be larger than +! - the number of nonzeros in the strict lower triangle +! - of m plus fillin (il(n+1)-1 after nsfc). +! nv - n - number of variables/equations. +! nva - r - ordering of the rows of m. +! - size = n. +! fvra - u - nonzero entries in the strict upper triangular portion +! - of the matrix u, stored by rows. +! - size = umax. +! nv - umax - declared dimension of u. umax must be larger than +! - the number of nonzeros in the strict upper triangle +! - of m plus fillin (iu(n+1)-1 after nsfc). +! fra - z - solution x. +! - size = n. +! +! ---------------------------------------------------------------- +! +!*** subroutine nroc +!*** reorders rows of a, leaving row order unchanged +! +! +! input parameters.. n, ic, ia, ja, a +! output parameters.. ja, a, flag +! +! parameters used internally.. +! nia - p - at the kth step, p is a linked list of the reordered +! - column indices of the kth row of a. p(n+1) points +! - to the first entry in the list. +! - size = n+1. +! nia - jar - at the kth step,jar contains the elements of the +! - reordered column indices of a. +! - size = n. +! fia - ar - at the kth step, ar contains the elements of the +! - reordered row of a. +! - size = n. +! +!jdf integer ic(1), ia(1), ja(1), jar(1), p(1), flag +!jdf real a(1), ar(1) + integer ic(*), ia(*), ja(*), jar(*), p(*), flag + real a(*), ar(*) +! double precision a(1), ar(1) +! +! ****** for each nonempty row ******************************* + do 5 k=1,n + jmin = ia(k) + jmax = ia(k+1) - 1 + if(jmin .gt. jmax) go to 5 + p(n+1) = n + 1 +! ****** insert each element in the list ********************* + do 3 j=jmin,jmax + newj = ic(ja(j)) + i = n + 1 + 1 if(p(i) .ge. newj) go to 2 + i = p(i) + go to 1 + 2 if(p(i) .eq. newj) go to 102 + p(newj) = p(i) + p(i) = newj + jar(newj) = ja(j) + ar(newj) = a(j) + 3 continue +! ****** replace old row in ja and a ************************* + i = n + 1 + do 4 j=jmin,jmax + i = p(i) + ja(j) = jar(i) + 4 a(j) = ar(i) + 5 continue + flag = 0 + return +! +! ** error.. duplicate entry in a + 102 flag = n + k + return + end subroutine nroc + subroutine nsfc & + (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, & + q, ira,jra, irac, irl,jrl, iru,jru, flag) +!lll. optimize +!*** subroutine nsfc +!*** symbolic ldu-factorization of nonsymmetric sparse matrix +! (compressed pointer storage) +! +! +! input variables.. n, r, ic, ia, ja, jlmax, jumax. +! output variables.. il, jl, ijl, iu, ju, iju, flag. +! +! parameters used internally.. +! nia - q - suppose m* is the result of reordering m. if +! - processing of the ith row of m* (hence the ith +! - row of u) is being done, q(j) is initially +! - nonzero if m*(i,j) is nonzero (j.ge.i). since +! - values need not be stored, each entry points to the +! - next nonzero and q(n+1) points to the first. n+1 +! - indicates the end of the list. for example, if n=9 +! - and the 5th row of m* is +! - 0 x x 0 x 0 0 x 0 +! - then q will initially be +! - a a a a 8 a a 10 5 (a - arbitrary). +! - as the algorithm proceeds, other elements of q +! - are inserted in the list because of fillin. +! - q is used in an analogous manner to compute the +! - ith column of l. +! - size = n+1. +! nia - ira, - vectors used to find the columns of m. at the kth +! nia - jra, step of the factorization, irac(k) points to the +! nia - irac head of a linked list in jra of row indices i +! - such that i .ge. k and m(i,k) is nonzero. zero +! - indicates the end of the list. ira(i) (i.ge.k) +! - points to the smallest j such that j .ge. k and +! - m(i,j) is nonzero. +! - size of each = n. +! nia - irl, - vectors used to find the rows of l. at the kth step +! nia - jrl of the factorization, jrl(k) points to the head +! - of a linked list in jrl of column indices j +! - such j .lt. k and l(k,j) is nonzero. zero +! - indicates the end of the list. irl(j) (j.lt.k) +! - points to the smallest i such that i .ge. k and +! - l(i,j) is nonzero. +! - size of each = n. +! nia - iru, - vectors used in a manner analogous to irl and jrl +! nia - jru to find the columns of u. +! - size of each = n. +! +! internal variables.. +! jlptr - points to the last position used in jl. +! juptr - points to the last position used in ju. +! jmin,jmax - are the indices in a or u of the first and last +! elements to be examined in a given row. +! for example, jmin=ia(k), jmax=ia(k+1)-1. +! + integer cend, qm, rend, rk, vj +!jdf integer ia(1), ja(1), ira(1), jra(1), il(1), jl(1), ijl(1) +!jdf integer iu(1), ju(1), iju(1), irl(1), jrl(1), iru(1), jru(1) +!jdf integer r(1), ic(1), q(1), irac(1), flag + integer ia(*), ja(*), ira(*), jra(*), il(*), jl(*), ijl(*) + integer iu(*), ju(*), iju(*), irl(*), jrl(*), iru(*), jru(*) + integer r(*), ic(*), q(*), irac(*), flag +! +! ****** initialize pointers **************************************** + np1 = n + 1 + jlmin = 1 + jlptr = 0 + il(1) = 1 + jumin = 1 + juptr = 0 + iu(1) = 1 + do 1 k=1,n + irac(k) = 0 + jra(k) = 0 + jrl(k) = 0 + 1 jru(k) = 0 +! ****** initialize column pointers for a *************************** + do 2 k=1,n + rk = r(k) + iak = ia(rk) + if (iak .ge. ia(rk+1)) go to 101 + jaiak = ic(ja(iak)) + if (jaiak .gt. k) go to 105 + jra(k) = irac(jaiak) + irac(jaiak) = k + 2 ira(k) = iak +! +! ****** for each column of l and row of u ************************** + do 41 k=1,n +! +! ****** initialize q for computing kth column of l ***************** + q(np1) = np1 + luk = -1 +! ****** by filling in kth column of a ****************************** + vj = irac(k) + if (vj .eq. 0) go to 5 + 3 qm = np1 + 4 m = qm + qm = q(m) + if (qm .lt. vj) go to 4 + if (qm .eq. vj) go to 102 + luk = luk + 1 + q(m) = vj + q(vj) = qm + vj = jra(vj) + if (vj .ne. 0) go to 3 +! ****** link through jru ******************************************* + 5 lastid = 0 + lasti = 0 + ijl(k) = jlptr + i = k + 6 i = jru(i) + if (i .eq. 0) go to 10 + qm = np1 + jmin = irl(i) + jmax = ijl(i) + il(i+1) - il(i) - 1 + long = jmax - jmin + if (long .lt. 0) go to 6 + jtmp = jl(jmin) + if (jtmp .ne. k) long = long + 1 + if (jtmp .eq. k) r(i) = -r(i) + if (lastid .ge. long) go to 7 + lasti = i + lastid = long +! ****** and merge the corresponding columns into the kth column **** + 7 do 9 j=jmin,jmax + vj = jl(j) + 8 m = qm + qm = q(m) + if (qm .lt. vj) go to 8 + if (qm .eq. vj) go to 9 + luk = luk + 1 + q(m) = vj + q(vj) = qm + qm = vj + 9 continue + go to 6 +! ****** lasti is the longest column merged into the kth ************ +! ****** see if it equals the entire kth column ********************* + 10 qm = q(np1) + if (qm .ne. k) go to 105 + if (luk .eq. 0) go to 17 + if (lastid .ne. luk) go to 11 +! ****** if so, jl can be compressed ******************************** + irll = irl(lasti) + ijl(k) = irll + 1 + if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 + go to 17 +! ****** if not, see if kth column can overlap the previous one ***** + 11 if (jlmin .gt. jlptr) go to 15 + qm = q(qm) + do 12 j=jlmin,jlptr + if (jl(j) - qm) 12, 13, 15 + 12 continue + go to 15 + 13 ijl(k) = j + do 14 i=j,jlptr + if (jl(i) .ne. qm) go to 15 + qm = q(qm) + if (qm .gt. n) go to 17 + 14 continue + jlptr = j - 1 +! ****** move column indices from q to jl, update vectors *********** + 15 jlmin = jlptr + 1 + ijl(k) = jlmin + if (luk .eq. 0) go to 17 + jlptr = jlptr + luk + if (jlptr .gt. jlmax) go to 103 + qm = q(np1) + do 16 j=jlmin,jlptr + qm = q(qm) + 16 jl(j) = qm + 17 irl(k) = ijl(k) + il(k+1) = il(k) + luk +! +! ****** initialize q for computing kth row of u ******************** + q(np1) = np1 + luk = -1 +! ****** by filling in kth row of reordered a *********************** + rk = r(k) + jmin = ira(k) + jmax = ia(rk+1) - 1 + if (jmin .gt. jmax) go to 20 + do 19 j=jmin,jmax + vj = ic(ja(j)) + qm = np1 + 18 m = qm + qm = q(m) + if (qm .lt. vj) go to 18 + if (qm .eq. vj) go to 102 + luk = luk + 1 + q(m) = vj + q(vj) = qm + 19 continue +! ****** link through jrl, ****************************************** + 20 lastid = 0 + lasti = 0 + iju(k) = juptr + i = k + i1 = jrl(k) + 21 i = i1 + if (i .eq. 0) go to 26 + i1 = jrl(i) + qm = np1 + jmin = iru(i) + jmax = iju(i) + iu(i+1) - iu(i) - 1 + long = jmax - jmin + if (long .lt. 0) go to 21 + jtmp = ju(jmin) + if (jtmp .eq. k) go to 22 +! ****** update irl and jrl, ***************************************** + long = long + 1 + cend = ijl(i) + il(i+1) - il(i) + irl(i) = irl(i) + 1 + if (irl(i) .ge. cend) go to 22 + j = jl(irl(i)) + jrl(i) = jrl(j) + jrl(j) = i + 22 if (lastid .ge. long) go to 23 + lasti = i + lastid = long +! ****** and merge the corresponding rows into the kth row ********** + 23 do 25 j=jmin,jmax + vj = ju(j) + 24 m = qm + qm = q(m) + if (qm .lt. vj) go to 24 + if (qm .eq. vj) go to 25 + luk = luk + 1 + q(m) = vj + q(vj) = qm + qm = vj + 25 continue + go to 21 +! ****** update jrl(k) and irl(k) *********************************** + 26 if (il(k+1) .le. il(k)) go to 27 + j = jl(irl(k)) + jrl(k) = jrl(j) + jrl(j) = k +! ****** lasti is the longest row merged into the kth *************** +! ****** see if it equals the entire kth row ************************ + 27 qm = q(np1) + if (qm .ne. k) go to 105 + if (luk .eq. 0) go to 34 + if (lastid .ne. luk) go to 28 +! ****** if so, ju can be compressed ******************************** + irul = iru(lasti) + iju(k) = irul + 1 + if (ju(irul) .ne. k) iju(k) = iju(k) - 1 + go to 34 +! ****** if not, see if kth row can overlap the previous one ******** + 28 if (jumin .gt. juptr) go to 32 + qm = q(qm) + do 29 j=jumin,juptr + if (ju(j) - qm) 29, 30, 32 + 29 continue + go to 32 + 30 iju(k) = j + do 31 i=j,juptr + if (ju(i) .ne. qm) go to 32 + qm = q(qm) + if (qm .gt. n) go to 34 + 31 continue + juptr = j - 1 +! ****** move row indices from q to ju, update vectors ************** + 32 jumin = juptr + 1 + iju(k) = jumin + if (luk .eq. 0) go to 34 + juptr = juptr + luk + if (juptr .gt. jumax) go to 106 + qm = q(np1) + do 33 j=jumin,juptr + qm = q(qm) + 33 ju(j) = qm + 34 iru(k) = iju(k) + iu(k+1) = iu(k) + luk +! +! ****** update iru, jru ******************************************** + i = k + 35 i1 = jru(i) + if (r(i) .lt. 0) go to 36 + rend = iju(i) + iu(i+1) - iu(i) + if (iru(i) .ge. rend) go to 37 + j = ju(iru(i)) + jru(i) = jru(j) + jru(j) = i + go to 37 + 36 r(i) = -r(i) + 37 i = i1 + if (i .eq. 0) go to 38 + iru(i) = iru(i) + 1 + go to 35 +! +! ****** update ira, jra, irac ************************************** + 38 i = irac(k) + if (i .eq. 0) go to 41 + 39 i1 = jra(i) + ira(i) = ira(i) + 1 + if (ira(i) .ge. ia(r(i)+1)) go to 40 + irai = ira(i) + jairai = ic(ja(irai)) + if (jairai .gt. i) go to 40 + jra(i) = irac(jairai) + irac(jairai) = i + 40 i = i1 + if (i .ne. 0) go to 39 + 41 continue +! + ijl(n) = jlptr + iju(n) = juptr + flag = 0 + return +! +! ** error.. null row in a + 101 flag = n + rk + return +! ** error.. duplicate entry in a + 102 flag = 2*n + rk + return +! ** error.. insufficient storage for jl + 103 flag = 3*n + k + return +! ** error.. null pivot + 105 flag = 5*n + k + return +! ** error.. insufficient storage for ju + 106 flag = 6*n + k + return + end subroutine nsfc + subroutine odrv & + (n, ia,ja,a, p,ip, nsp,isp, path, flag) +!lll. optimize +! 5/2/83 +!*********************************************************************** +! odrv -- driver for sparse matrix reordering routines +!*********************************************************************** +! +! description +! +! odrv finds a minimum degree ordering of the rows and columns +! of a matrix m stored in (ia,ja,a) format (see below). for the +! reordered matrix, the work and storage required to perform +! gaussian elimination is (usually) significantly less. +! +! note.. odrv and its subordinate routines have been modified to +! compute orderings for general matrices, not necessarily having any +! symmetry. the miminum degree ordering is computed for the +! structure of the symmetric matrix m + m-transpose. +! modifications to the original odrv module have been made in +! the coding in subroutine mdi, and in the initial comments in +! subroutines odrv and md. +! +! if only the nonzero entries in the upper triangle of m are being +! stored, then odrv symmetrically reorders (ia,ja,a), (optionally) +! with the diagonal entries placed first in each row. this is to +! ensure that if m(i,j) will be in the upper triangle of m with +! respect to the new ordering, then m(i,j) is stored in row i (and +! thus m(j,i) is not stored), whereas if m(i,j) will be in the +! strict lower triangle of m, then m(j,i) is stored in row j (and +! thus m(i,j) is not stored). +! +! +! storage of sparse matrices +! +! the nonzero entries of the matrix m are stored row-by-row in the +! array a. to identify the individual nonzero entries in each row, +! we need to know in which column each entry lies. these column +! indices are stored in the array ja. i.e., if a(k) = m(i,j), then +! ja(k) = j. to identify the individual rows, we need to know where +! each row starts. these row pointers are stored in the array ia. +! i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row +! and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to +! the first location following the last element in the last row. +! thus, the number of entries in the i-th row is ia(i+1) - ia(i), +! the nonzero entries in the i-th row are stored consecutively in +! +! a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), +! +! and the corresponding column indices are stored consecutively in +! +! ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). +! +! when the coefficient matrix is symmetric, only the nonzero entries +! in the upper triangle need be stored. for example, the matrix +! +! ( 1 0 2 3 0 ) +! ( 0 4 0 0 0 ) +! m = ( 2 0 5 6 0 ) +! ( 3 0 6 7 8 ) +! ( 0 0 0 8 9 ) +! +! could be stored as +! +! - 1 2 3 4 5 6 7 8 9 10 11 12 13 +! ---+-------------------------------------- +! ia - 1 4 5 8 12 14 +! ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 +! a - 1 2 3 4 2 5 6 3 6 7 8 8 9 +! +! or (symmetrically) as +! +! - 1 2 3 4 5 6 7 8 9 +! ---+-------------------------- +! ia - 1 4 5 7 9 10 +! ja - 1 3 4 2 3 4 4 5 5 +! a - 1 2 3 4 5 6 7 8 9 . +! +! +! parameters +! +! n - order of the matrix +! +! ia - integer one-dimensional array containing pointers to delimit +! rows in ja and a. dimension = n+1 +! +! ja - integer one-dimensional array containing the column indices +! corresponding to the elements of a. dimension = number of +! nonzero entries in (the upper triangle of) m +! +! a - real one-dimensional array containing the nonzero entries in +! (the upper triangle of) m, stored by rows. dimension = +! number of nonzero entries in (the upper triangle of) m +! +! p - integer one-dimensional array used to return the permutation +! of the rows and columns of m corresponding to the minimum +! degree ordering. dimension = n +! +! ip - integer one-dimensional array used to return the inverse of +! the permutation returned in p. dimension = n +! +! nsp - declared dimension of the one-dimensional array isp. nsp +! must be at least 3n+4k, where k is the number of nonzeroes +! in the strict upper triangle of m +! +! isp - integer one-dimensional array used for working storage. +! dimension = nsp +! +! path - integer path specification. values and their meanings are - +! 1 find minimum degree ordering only +! 2 find minimum degree ordering and reorder symmetrically +! stored matrix (used when only the nonzero entries in +! the upper triangle of m are being stored) +! 3 reorder symmetrically stored matrix as specified by +! input permutation (used when an ordering has already +! been determined and only the nonzero entries in the +! upper triangle of m are being stored) +! 4 same as 2 but put diagonal entries at start of each row +! 5 same as 3 but put diagonal entries at start of each row +! +! flag - integer error flag. values and their meanings are - +! 0 no errors detected +! 9n+k insufficient storage in md +! 10n+1 insufficient storage in odrv +! 11n+1 illegal path specification +! +! +! conversion from real to double precision +! +! change the real declarations in odrv and sro to double precision +! declarations. +! +!----------------------------------------------------------------------- +! +!jdf integer ia(1), ja(1), p(1), ip(1), isp(1), path, flag, +!jdf * v, l, head, tmp, q +!jdf real a(1) + integer ia(*), ja(*), p(*), ip(*), isp(*), path, flag, & + v, l, head, tmp, q + real a(*) +!... double precision a(1) + logical dflag +! +!----initialize error flag and validate path specification + flag = 0 + if (path.lt.1 .or. 5.lt.path) go to 111 +! +!----allocate storage and find minimum degree ordering + if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 + max = (nsp-n)/2 + v = 1 + l = v + max + head = l + max + next = head + n + if (max.lt.n) go to 110 +! + call md & + (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) + if (flag.ne.0) go to 100 +! +!----allocate storage and symmetrically reorder matrix + 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 + tmp = (nsp+1) - n + q = tmp - (ia(n+1)-1) + if (q.lt.1) go to 110 +! + dflag = path.eq.4 .or. path.eq.5 + call sro & + (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) +! + 2 return +! +! ** error -- error detected in md + 100 return +! ** error -- insufficient storage + 110 flag = 10*n + 1 + return +! ** error -- illegal path specified + 111 flag = 11*n + 1 + return + end subroutine odrv + + + + subroutine prjs (neq,y,yh,nyh,ewt,ftem,savf,wk,iwk,f,jac, & + ruserpar, nruserpar, iuserpar, niuserpar ) +!lll. optimize + external f,jac + integer neq, nyh, iwk + integer iownd, iowns, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, imul, j, jj, jok, jmax, jmin, k, kmax, kmin, ng + integer nruserpar, iuserpar, niuserpar + real y, yh, ewt, ftem, savf, wk + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real con0, conmin, ccmxj, psmall, rbig, seth +!rce real con, di, fac, hl0, pij, r, r0, rcon, rcont, & +!rce srur, vnorm + real con, di, fac, hl0, pij, r, r0, rcon, rcont, & + srur + real ruserpar +!jdf dimension neq(1), y(1), yh(nyh,1), ewt(1), ftem(1), savf(1), +!jdf 1 wk(1), iwk(1) + dimension neq(*), y(*), yh(nyh,*), ewt(*), ftem(*), savf(*), & + wk(*), iwk(*) + dimension ruserpar(nruserpar), iuserpar(niuserpar) + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + iownd(14), iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, & + iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu +!----------------------------------------------------------------------- +! prjs is called to compute and process the matrix +! p = i - h*el(1)*j , where j is an approximation to the jacobian. +! j is computed by columns, either by the user-supplied routine jac +! if miter = 1, or by finite differencing if miter = 2. +! if miter = 3, a diagonal approximation to j is used. +! if miter = 1 or 2, and if the existing value of the jacobian +! (as contained in p) is considered acceptable, then a new value of +! p is reconstructed from the old value. in any case, when miter +! is 1 or 2, the p matrix is subjected to lu decomposition in cdrv. +! p and its lu decomposition are stored (separately) in wk. +! +! in addition to variables described previously, communication +! with prjs uses the following.. +! y = array containing predicted values on entry. +! ftem = work array of length n (acor in stode). +! savf = array containing f evaluated at predicted y. +! wk = real work space for matrices. on output it contains the +! inverse diagonal matrix if miter = 3, and p and its sparse +! lu decomposition if miter is 1 or 2. +! storage of matrix elements starts at wk(3). +! wk also contains the following matrix-related data.. +! wk(1) = sqrt(uround), used in numerical jacobian increments. +! wk(2) = h*el0, saved for later use if miter = 3. +! iwk = integer work space for matrix-related data, assumed to +! be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) +! are assumed to have identical locations. +! el0 = el(1) (input). +! ierpj = output error flag (in common). +! = 0 if no error. +! = 1 if zero pivot found in cdrv. +! = 2 if a singular matrix arose with miter = 3. +! = -1 if insufficient storage for cdrv (should not occur here). +! = -2 if other error found in cdrv (should not occur here). +! jcur = output flag = 1 to indicate that the jacobian matrix +! (or approximation) is now current. +! this routine also uses other variables in common. +!----------------------------------------------------------------------- + hl0 = h*el0 + con = -hl0 + if (miter .eq. 3) go to 300 +! see whether j should be reevaluated (jok = 0) or not (jok = 1). ------ + jok = 1 + if (nst .eq. 0 .or. nst .ge. nslj+msbj) jok = 0 + if (icf .eq. 1 .and. abs(rc - 1.0e0) .lt. ccmxj) jok = 0 + if (icf .eq. 2) jok = 0 + if (jok .eq. 1) go to 250 +! +! miter = 1 or 2, and the jacobian is to be reevaluated. --------------- + 20 jcur = 1 + nje = nje + 1 + nslj = nst + iplost = 0 + conmin = abs(con) + go to (100, 200), miter +! +! if miter = 1, call jac, multiply by scalar, and add identity. -------- + 100 continue + kmin = iwk(ipian) + do 130 j = 1, n + kmax = iwk(ipian+j) - 1 + do 110 i = 1,n + 110 ftem(i) = 0.0e0 + call jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), ftem, & + ruserpar, nruserpar, iuserpar, niuserpar) + do 120 k = kmin, kmax + i = iwk(ibjan+k) + wk(iba+k) = ftem(i)*con + if (i .eq. j) wk(iba+k) = wk(iba+k) + 1.0e0 + 120 continue + kmin = kmax + 1 + 130 continue + go to 290 +! +! if miter = 2, make ngp calls to f to approximate j and p. ------------ + 200 continue + fac = vnorm(n, savf, ewt) + r0 = 1000.0e0 * abs(h) * uround * float(n) * fac + if (r0 .eq. 0.0e0) r0 = 1.0e0 + srur = wk(1) + jmin = iwk(ipigp) + do 240 ng = 1,ngp + jmax = iwk(ipigp+ng) - 1 + do 210 j = jmin,jmax + jj = iwk(ibjgp+j) + r = amax1(srur*abs(y(jj)),r0/ewt(jj)) + 210 y(jj) = y(jj) + r + call f (neq, tn, y, ftem, & + ruserpar, nruserpar, iuserpar, niuserpar) + do 230 j = jmin,jmax + jj = iwk(ibjgp+j) + y(jj) = yh(jj,1) + r = amax1(srur*abs(y(jj)),r0/ewt(jj)) + fac = -hl0/r + kmin =iwk(ibian+jj) + kmax =iwk(ibian+jj+1) - 1 + do 220 k = kmin,kmax + i = iwk(ibjan+k) + wk(iba+k) = (ftem(i) - savf(i))*fac + if (i .eq. jj) wk(iba+k) = wk(iba+k) + 1.0e0 + 220 continue + 230 continue + jmin = jmax + 1 + 240 continue + nfe = nfe + ngp + go to 290 +! +! if jok = 1, reconstruct new p from old p. ---------------------------- + 250 jcur = 0 + rcon = con/con0 + rcont = abs(con)/conmin + if (rcont .gt. rbig .and. iplost .eq. 1) go to 20 + kmin = iwk(ipian) + do 275 j = 1,n + kmax = iwk(ipian+j) - 1 + do 270 k = kmin,kmax + i = iwk(ibjan+k) + pij = wk(iba+k) + if (i .ne. j) go to 260 + pij = pij - 1.0e0 + if (abs(pij) .ge. psmall) go to 260 + iplost = 1 + conmin = amin1(abs(con0),conmin) + 260 pij = pij*rcon + if (i .eq. j) pij = pij + 1.0e0 + wk(iba+k) = pij + 270 continue + kmin = kmax + 1 + 275 continue +! +! do numerical factorization of p matrix. ------------------------------ + 290 nlu = nlu + 1 + con0 = con + ierpj = 0 + do 295 i = 1,n + 295 ftem(i) = 0.0e0 + call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), & + wk(ipa),ftem,ftem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys) + if (iys .eq. 0) return + imul = (iys - 1)/n + ierpj = -2 + if (imul .eq. 8) ierpj = 1 + if (imul .eq. 10) ierpj = -1 + return +! +! if miter = 3, construct a diagonal approximation to j and p. --------- + 300 continue + jcur = 1 + nje = nje + 1 + wk(2) = hl0 + ierpj = 0 + r = el0*0.1e0 + do 310 i = 1,n + 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) + call f (neq, tn, y, wk(3), & + ruserpar, nruserpar, iuserpar, niuserpar) + nfe = nfe + 1 + do 320 i = 1,n + r0 = h*savf(i) - yh(i,2) + di = 0.1e0*r0 - h*(wk(i+2) - savf(i)) + wk(i+2) = 1.0e0 + if (abs(r0) .lt. uround/ewt(i)) go to 320 + if (abs(di) .eq. 0.0e0) go to 330 + wk(i+2) = 0.1e0*r0/di + 320 continue + return + 330 ierpj = 2 + return +!----------------------- end of subroutine prjs ------------------------ + end subroutine prjs + subroutine slss (wk, iwk, x, tem) +!lll. optimize + integer iwk + integer iownd, iowns, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i + real wk, x, tem + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real rlss + real di, hl0, phl0, r +!jdf dimension wk(1), iwk(1), x(1), tem(1) + dimension wk(*), iwk(*), x(*), tem(*) + + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + iownd(14), iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ rlss(6), & + iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu +!----------------------------------------------------------------------- +! this routine manages the solution of the linear system arising from +! a chord iteration. it is called if miter .ne. 0. +! if miter is 1 or 2, it calls cdrv to accomplish this. +! if miter = 3 it updates the coefficient h*el0 in the diagonal +! matrix, and then computes the solution. +! communication with slss uses the following variables.. +! wk = real work space containing the inverse diagonal matrix if +! miter = 3 and the lu decomposition of the matrix otherwise. +! storage of matrix elements starts at wk(3). +! wk also contains the following matrix-related data.. +! wk(1) = sqrt(uround) (not used here), +! wk(2) = hl0, the previous value of h*el0, used if miter = 3. +! iwk = integer work space for matrix-related data, assumed to +! be equivalenced to wk. in addition, wk(iprsp) and iwk(ipisp) +! are assumed to have identical locations. +! x = the right-hand side vector on input, and the solution vector +! on output, of length n. +! tem = vector of work space of length n, not used in this version. +! iersl = output flag (in common). +! iersl = 0 if no trouble occurred. +! iersl = -1 if cdrv returned an error flag (miter = 1 or 2). +! this should never occur and is considered fatal. +! iersl = 1 if a singular matrix arose with miter = 3. +! this routine also uses other variables in common. +!----------------------------------------------------------------------- + iersl = 0 + go to (100, 100, 300), miter + 100 call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), & + wk(ipa),x,x,nsp,iwk(ipisp),wk(iprsp),iesp,4,iersl) + if (iersl .ne. 0) iersl = -1 + return +! + 300 phl0 = wk(2) + hl0 = h*el0 + wk(2) = hl0 + if (hl0 .eq. phl0) go to 330 + r = hl0/phl0 + do 320 i = 1,n + di = 1.0e0 - r*(1.0e0 - 1.0e0/wk(i+2)) + if (abs(di) .eq. 0.0e0) go to 390 + 320 wk(i+2) = 1.0e0/di + 330 do 340 i = 1,n + 340 x(i) = wk(i+2)*x(i) + return + 390 iersl = 1 + return +! +!----------------------- end of subroutine slss ------------------------ + end subroutine slss + subroutine sro & + (n, ip, ia,ja,a, q, r, dflag) +!lll. optimize +!*********************************************************************** +! sro -- symmetric reordering of sparse symmetric matrix +!*********************************************************************** +! +! description +! +! the nonzero entries of the matrix m are assumed to be stored +! symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) +! are stored if i ne j). +! +! sro does not rearrange the order of the rows, but does move +! nonzeroes from one row to another to ensure that if m(i,j) will be +! in the upper triangle of m with respect to the new ordering, then +! m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas +! if m(i,j) will be in the strict lower triangle of m, then m(j,i) is +! stored in row j (and thus m(i,j) is not stored). +! +! +! additional parameters +! +! q - integer one-dimensional work array. dimension = n +! +! r - integer one-dimensional work array. dimension = number of +! nonzero entries in the upper triangle of m +! +! dflag - logical variable. if dflag = .true., then store nonzero +! diagonal elements at the beginning of the row +! +!----------------------------------------------------------------------- +! +!jdf integer ip(1), ia(1), ja(1), q(1), r(1) +!jdf real a(1), ak + integer ip(*), ia(*), ja(*), q(*), r(*) + real a(*), ak +!... double precision a(1), ak + logical dflag +! +! +!--phase 1 -- find row in which to store each nonzero +!----initialize count of nonzeroes to be stored in each row + do 1 i=1,n + 1 q(i) = 0 +! +!----for each nonzero element a(j) + do 3 i=1,n + jmin = ia(i) + jmax = ia(i+1) - 1 + if (jmin.gt.jmax) go to 3 + do 2 j=jmin,jmax +! +!--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... + k = ja(j) + if (ip(k).lt.ip(i)) ja(j) = i + if (ip(k).ge.ip(i)) k = i + r(j) = k +! +!--------... and increment count of nonzeroes (=q(r(j)) in that row + 2 q(k) = q(k) + 1 + 3 continue +! +! +!--phase 2 -- find new ia and permutation to apply to (ja,a) +!----determine pointers to delimit rows in permuted (ja,a) + do 4 i=1,n + ia(i+1) = ia(i) + q(i) + 4 q(i) = ia(i+1) +! +!----determine where each (ja(j),a(j)) is stored in permuted (ja,a) +!----for each nonzero element (in reverse order) + ilast = 0 + jmin = ia(1) + jmax = ia(n+1) - 1 + j = jmax + do 6 jdummy=jmin,jmax + i = r(j) + if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 +! +!------if dflag, then put diagonal nonzero at beginning of row + r(j) = ia(i) + ilast = i + go to 6 +! +!------put (off-diagonal) nonzero in last unused location in row + 5 q(i) = q(i) - 1 + r(j) = q(i) +! + 6 j = j-1 +! +! +!--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) + do 8 j=jmin,jmax + 7 if (r(j).eq.j) go to 8 + k = r(j) + r(j) = r(k) + r(k) = k + jak = ja(k) + ja(k) = ja(j) + ja(j) = jak + ak = a(k) + a(k) = a(j) + a(j) = ak + go to 7 + 8 continue +! + return + end subroutine sro + + + + real function vnorm (n, v, w) +!lll. optimize +!----------------------------------------------------------------------- +! this function routine computes the weighted root-mean-square norm +! of the vector of length n contained in the array v, with weights +! contained in the array w of length n.. +! vnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 ) +!----------------------------------------------------------------------- + integer n, i + real v, w, sum + dimension v(n), w(n) + integer iok_vnorm + common / lsodes_cmn_iok_vnorm / iok_vnorm + sum = 0.0e0 + do 10 i = 1,n + if (abs(v(i)*w(i)) .ge. 1.0e18) then + vnorm = 1.0e18 + iok_vnorm = -1 + return + end if + 10 sum = sum + (v(i)*w(i))**2 + vnorm = sqrt(sum/float(n)) + return +!----------------------- end of function vnorm ------------------------- + end function vnorm + subroutine xerrwv (msg, nmes, nerr, level, ni, i1, i2, nr, r1, r2) + use module_peg_util, only: peg_message, peg_error_fatal +! integer msg, nmes, nerr, level, ni, i1, i2, nr, & + integer nmes, nerr, level, ni, i1, i2, nr, & + i, lun, lunit, mesflg, ncpw, nch, nwds + real r1, r2 + character(*) msg + character*80 errmsg +!----------------------------------------------------------------------- +! subroutines xerrwv, xsetf, and xsetun, as given here, constitute +! a simplified version of the slatec error handling package. +! written by a. c. hindmarsh at llnl. version of march 30, 1987. +! +! all arguments are input arguments. +! +! msg = the message (hollerith literal or integer array). +! nmes = the length of msg (number of characters). +! nerr = the error number (not used). +! level = the error level.. +! 0 or 1 means recoverable (control returns to caller). +! 2 means fatal (run is aborted--see note below). +! ni = number of integers (0, 1, or 2) to be printed with message. +! i1,i2 = integers to be printed, depending on ni. +! nr = number of reals (0, 1, or 2) to be printed with message. +! r1,r2 = reals to be printed, depending on nr. +! +! note.. this routine is machine-dependent and specialized for use +! in limited context, in the following ways.. +! 1. the number of hollerith characters stored per word, denoted +! by ncpw below, is a data-loaded constant. +! 2. the value of nmes is assumed to be at most 60. +! (multi-line messages are generated by repeated calls.) +! 3. if level = 2, control passes to the statement stop +! to abort the run. this statement may be machine-dependent. +! 4. r1 and r2 are assumed to be in single precision and are printed +! in e21.13 format. +! 5. the common block /eh0001/ below is data-loaded (a machine- +! dependent feature) with default values. +! this block is needed for proper retention of parameters used by +! this routine which the user can reset by calling xsetf or xsetun. +! the variables in this block are as follows.. +! mesflg = print control flag.. +! 1 means print all messages (the default). +! 0 means no printing. +! lunit = logical unit number for messages. +! the default is 6 (machine-dependent). +!----------------------------------------------------------------------- +! the following are instructions for installing this routine +! in different machine environments. +! +! to change the default output unit, change the data statement below. +! +! for some systems, the data statement below must be replaced +! by a separate block data subprogram. +! +! for a different number of characters per word, change the +! data statement setting ncpw below, and format 10. alternatives for +! various computers are shown in comment cards. +! +! for a different run-abort command, change the statement following +! statement 100 at the end. +!----------------------------------------------------------------------- + common /eh0001/ mesflg, lunit +! +!raz data mesflg/1/, lunit/6/ + mesflg = 1 + lunit = 6 +!----------------------------------------------------------------------- +! the following data-loaded value of ncpw is valid for the cdc-6600 +! and cdc-7600 computers. +! data ncpw/10/ +! the following is valid for the cray-1 computer. +! data ncpw/8/ +! the following is valid for the burroughs 6700 and 7800 computers. +! data ncpw/6/ +! the following is valid for the pdp-10 computer. +! data ncpw/5/ +! the following is valid for the vax computer with 4 bytes per integer, +! and for the ibm-360, ibm-370, ibm-303x, and ibm-43xx computers. + data ncpw/4/ +! the following is valid for the pdp-11, or vax with 2-byte integers. +! data ncpw/2/ +!----------------------------------------------------------------------- +! + if (mesflg .eq. 0) go to 100 +! get logical unit number. --------------------------------------------- + lun = lunit +! get number of words in message. -------------------------------------- + nch = min0(nmes,60) + nwds = nch/ncpw + if (nch .ne. nwds*ncpw) nwds = nwds + 1 +! write the message. --------------------------------------------------- +! write (lun, 10) (msg(i),i=1,nwds) +! write (lun, 10) msg + call peg_message( lun, msg ) +!----------------------------------------------------------------------- +! the following format statement is to have the form +! 10 format(1x,mmann) +! where nn = ncpw and mm is the smallest integer .ge. 60/ncpw. +! the following is valid for ncpw = 10. +! 10 format(1x,6a10) +! the following is valid for ncpw = 8. +! 10 format(1x,8a8) +! the following is valid for ncpw = 6. +! 10 format(1x,10a6) +! the following is valid for ncpw = 5. +! 10 format(1x,12a5) +! the following is valid for ncpw = 4. +! 10 format(1x,15a4) + 10 format(1x,a) +! the following is valid for ncpw = 2. +! 10 format(1x,30a2) +!----------------------------------------------------------------------- + errmsg = ' ' +! if (ni .eq. 1) write (lun, 20) i1 + if (ni .eq. 1) write (errmsg, 20) i1 + 20 format(6x,23hin above message, i1 =,i10) + +! if (ni .eq. 2) write (lun, 30) i1,i2 + if (ni .eq. 2) write (errmsg, 30) i1,i2 + 30 format(6x,23hin above message, i1 =,i10,3x,4hi2 =,i10) + +! if (nr .eq. 1) write (lun, 40) r1 + if (nr .eq. 1) write (errmsg, 40) r1 + 40 format(6x,23hin above message, r1 =,e21.13) + +! if (nr .eq. 2) write (lun, 50) r1,r2 + if (nr .eq. 2) write (errmsg, 50) r1,r2 + 50 format(6x,15hin above, r1 =,e21.13,3x,4hr2 =,e21.13) + + if (errmsg .ne. ' ') call peg_message( lun, errmsg ) + +! abort the run if level = 2. ------------------------------------------ + 100 if (level .ne. 2) return + call peg_error_fatal( lun, '*** subr xerrwv fatal error' ) + stop +!----------------------- end of subroutine xerrwv ---------------------- + end subroutine xerrwv +!----------------------------------------------------------------------- + real function r1mach(i) + use module_peg_util, only: peg_error_fatal +! +! single-precision machine constants +! +! r1mach(1) = b**(emin-1), the smallest positive magnitude. +! +! r1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. +! +! r1mach(3) = b**(-t), the smallest relative spacing. +! +! r1mach(4) = b**(1-t), the largest relative spacing. +! +! r1mach(5) = log10(b) +! +! to alter this function for a particular environment, +! the desired set of data statements should be activated by +! removing the c from column 1. +! on rare machines a static statement may need to be added. +! (but probably more systems prohibit it than require it.) +! +! for ieee-arithmetic machines (binary standard), the first +! set of constants below should be appropriate. +! +! where possible, decimal, octal or hexadecimal constants are used +! to specify the constants exactly. sometimes this requires using +! equivalent integer arrays. if your compiler uses half-word +! integers by default (sometimes called integer*2), you may need to +! change integer to integer*4 or otherwise instruct your compiler +! to use full-word integers in the next 5 declarations. +! + integer mach_small(2) + integer mach_large(2) + integer mach_right(2) + integer mach_diver(2) + integer mach_log10(2) + integer sc +! + character*80 errmsg +! + real rmach(5) +! + equivalence (rmach(1), mach_small(1)) + equivalence (rmach(2), mach_large(1)) + equivalence (rmach(3), mach_right(1)) + equivalence (rmach(4), mach_diver(1)) + equivalence (rmach(5), mach_log10(1)) +! +! machine constants for ieee arithmetic machines, such as the at&t +! 3b series, motorola 68000 based machines (e.g. sun 3 and at&t +! pc 7300), and 8087 based micros (e.g. ibm pc and at&t 6300). +! +! data small(1) / 8388608 / +! data large(1) / 2139095039 / +! data right(1) / 864026624 / +! data diver(1) / 872415232 / +! data log10(1) / 1050288283 /, sc/987/ + +! 18-may-2006 -- +! the following values are produced on our current linux +! workstations, when the data statments for +! 'motorola 68000 based machines' are used +! specifiying them using 'real' data statements should work fine + data rmach(1) / 1.1754944000E-38 / + data rmach(2) / 3.4028235000E+38 / + data rmach(3) / 5.9604645000E-08 / + data rmach(4) / 1.1920929000E-07 / + data rmach(5) / 3.0103001000E-01 / + data sc / 987 / +! +! machine constants for amdahl machines. +! +! data small(1) / 1048576 / +! data large(1) / 2147483647 / +! data right(1) / 990904320 / +! data diver(1) / 1007681536 / +! data log10(1) / 1091781651 /, sc/987/ +! +! machine constants for the burroughs 1700 system. +! +! data rmach(1) / z400800000 / +! data rmach(2) / z5ffffffff / +! data rmach(3) / z4e9800000 / +! data rmach(4) / z4ea800000 / +! data rmach(5) / z500e730e8 /, sc/987/ +! +! machine constants for the burroughs 5700/6700/7700 systems. +! +! data rmach(1) / o1771000000000000 / +! data rmach(2) / o0777777777777777 / +! data rmach(3) / o1311000000000000 / +! data rmach(4) / o1301000000000000 / +! data rmach(5) / o1157163034761675 /, sc/987/ +! +! machine constants for ftn4 on the cdc 6000/7000 series. +! +! data rmach(1) / 00564000000000000000b / +! data rmach(2) / 37767777777777777776b / +! data rmach(3) / 16414000000000000000b / +! data rmach(4) / 16424000000000000000b / +! data rmach(5) / 17164642023241175720b /, sc/987/ +! +! machine constants for ftn5 on the cdc 6000/7000 series. +! +! data rmach(1) / o"00564000000000000000" / +! data rmach(2) / o"37767777777777777776" / +! data rmach(3) / o"16414000000000000000" / +! data rmach(4) / o"16424000000000000000" / +! data rmach(5) / o"17164642023241175720" /, sc/987/ +! +! machine constants for convex c-1. +! +! data rmach(1) / '00800000'x / +! data rmach(2) / '7fffffff'x / +! data rmach(3) / '34800000'x / +! data rmach(4) / '35000000'x / +! data rmach(5) / '3f9a209b'x /, sc/987/ +! +! machine constants for the cray 1, xmp, 2, and 3. +! +! data rmach(1) / 200034000000000000000b / +! data rmach(2) / 577767777777777777776b / +! data rmach(3) / 377224000000000000000b / +! data rmach(4) / 377234000000000000000b / +! data rmach(5) / 377774642023241175720b /, sc/987/ +! +! machine constants for the data general eclipse s/200. +! +! note - it may be appropriate to include the following line - +! static rmach(5) +! +! data small/20k,0/,large/77777k,177777k/ +! data right/35420k,0/,diver/36020k,0/ +! data log10/40423k,42023k/, sc/987/ +! +! machine constants for the harris slash 6 and slash 7. +! +! data small(1),small(2) / '20000000, '00000201 / +! data large(1),large(2) / '37777777, '00000177 / +! data right(1),right(2) / '20000000, '00000352 / +! data diver(1),diver(2) / '20000000, '00000353 / +! data log10(1),log10(2) / '23210115, '00000377 /, sc/987/ +! +! machine constants for the honeywell dps 8/70 series. +! +! data rmach(1) / o402400000000 / +! data rmach(2) / o376777777777 / +! data rmach(3) / o714400000000 / +! data rmach(4) / o716400000000 / +! data rmach(5) / o776464202324 /, sc/987/ +! +! machine constants for the ibm 360/370 series, +! the xerox sigma 5/7/9 and the sel systems 85/86. +! +! data rmach(1) / z00100000 / +! data rmach(2) / z7fffffff / +! data rmach(3) / z3b100000 / +! data rmach(4) / z3c100000 / +! data rmach(5) / z41134413 /, sc/987/ +! +! machine constants for the interdata 8/32 +! with the unix system fortran 77 compiler. +! +! for the interdata fortran vii compiler replace +! the z's specifying hex constants with y's. +! +! data rmach(1) / z'00100000' / +! data rmach(2) / z'7effffff' / +! data rmach(3) / z'3b100000' / +! data rmach(4) / z'3c100000' / +! data rmach(5) / z'41134413' /, sc/987/ +! +! machine constants for the pdp-10 (ka or ki processor). +!---------------------------------------------------------------------- +! rce 2004-01-07 +! The following 5 lines for rmach(1-5) each contained one +! quotation-mark character. +! The WRF preprocessor did not like this, so I changed the +! quotation-mark characters to QUOTE. +! +! data rmach(1) / QUOTE000400000000 / +! data rmach(2) / QUOTE377777777777 / +! data rmach(3) / QUOTE146400000000 / +! data rmach(4) / QUOTE147400000000 / +! data rmach(5) / QUOTE177464202324 /, sc/987/ +!---------------------------------------------------------------------- +! +! machine constants for pdp-11 fortrans supporting +! 32-bit integers (expressed in integer and octal). +! +! data small(1) / 8388608 / +! data large(1) / 2147483647 / +! data right(1) / 880803840 / +! data diver(1) / 889192448 / +! data log10(1) / 1067065499 /, sc/987/ +! +! data rmach(1) / o00040000000 / +! data rmach(2) / o17777777777 / +! data rmach(3) / o06440000000 / +! data rmach(4) / o06500000000 / +! data rmach(5) / o07746420233 /, sc/987/ +! +! machine constants for pdp-11 fortrans supporting +! 16-bit integers (expressed in integer and octal). +! +! data small(1),small(2) / 128, 0 / +! data large(1),large(2) / 32767, -1 / +! data right(1),right(2) / 13440, 0 / +! data diver(1),diver(2) / 13568, 0 / +! data log10(1),log10(2) / 16282, 8347 /, sc/987/ +! +! data small(1),small(2) / o000200, o000000 / +! data large(1),large(2) / o077777, o177777 / +! data right(1),right(2) / o032200, o000000 / +! data diver(1),diver(2) / o032400, o000000 / +! data log10(1),log10(2) / o037632, o020233 /, sc/987/ +! +! machine constants for the sequent balance 8000. +! +! data small(1) / $00800000 / +! data large(1) / $7f7fffff / +! data right(1) / $33800000 / +! data diver(1) / $34000000 / +! data log10(1) / $3e9a209b /, sc/987/ +! +! machine constants for the univac 1100 series. +! +! data rmach(1) / o000400000000 / +! data rmach(2) / o377777777777 / +! data rmach(3) / o146400000000 / +! data rmach(4) / o147400000000 / +! data rmach(5) / o177464202324 /, sc/987/ +! +! machine constants for the vax unix f77 compiler. +! +! data small(1) / 128 / +! data large(1) / -32769 / +! data right(1) / 13440 / +! data diver(1) / 13568 / +! data log10(1) / 547045274 /, sc/987/ +! +! machine constants for the vax-11 with +! fortran iv-plus compiler. +! +! data rmach(1) / z00000080 / +! data rmach(2) / zffff7fff / +! data rmach(3) / z00003480 / +! data rmach(4) / z00003500 / +! data rmach(5) / z209b3f9a /, sc/987/ +! +! machine constants for vax/vms version 2.2. +! +! data rmach(1) / '80'x / +! data rmach(2) / 'ffff7fff'x / +! data rmach(3) / '3480'x / +! data rmach(4) / '3500'x / +! data rmach(5) / '209b3f9a'x /, sc/987/ +! + real dum + + +! *** issue stop 778 if all data statements are commented... +! if (sc .ne. 987) stop 778 + if (sc .ne. 987) then + call peg_error_fatal( -1, & + '*** func r1mach fatal error -- all data statements inactive' ) + stop + end if + + if (i .lt. 1 .or. i .gt. 5) goto 999 + + r1mach = rmach(i) + +! 18-may-2006 -- +! the following compares results from data statements +! and fortran90 functions +! write(*,'(/a,i5 )') & +! 'in module_cbmz_lsodes_solver r1mach - i =', i +! dum = tiny( 1.0 ) +! write(*,'( a,1pe18.10)') ' rmach(1) =', rmach(1) +! write(*,'( a,1pe18.10)') ' tiny(1.0) =', dum +! dum = huge( 1.0 ) +! write(*,'( a,1pe18.10)') ' rmach(2) =', rmach(2) +! write(*,'( a,1pe18.10)') ' huge(1.0) =', dum +! dum = spacing( 0.5 ) +! write(*,'( a,1pe18.10)') ' rmach(3) =', rmach(3) +! write(*,'( a,1pe18.10)') ' spacing(0.5)=', dum +! dum = epsilon( 1.0 ) +! write(*,'( a,1pe18.10)') ' rmach(4) =', rmach(4) +! write(*,'( a,1pe18.10)') ' epsilon(1.0)=', dum +! dum = log10( 2.0 ) +! write(*,'( a,1pe18.10)') ' rmach(5) =', rmach(5) +! write(*,'( a,1pe18.10)') ' log10(2.0) =', dum +! write(*,*) + +! 18-may-2006 -- +! the following fortran90 functions give the same results +! as the 'real' data statements on our linux workstations +! and could probably be used to replace the data statements +! if (i .eq. 1) then +! dum = 1.0 +! r1mach = tiny( dum ) +! else if (i .eq. 2) then +! dum = 1.0 +! r1mach = huge( dum ) +! else if (i .eq. 3) then +! dum = 0.5 +! r1mach = spacing( dum ) +! else if (i .eq. 4) then +! dum = 1.0 +! r1mach = epsilon( dum ) +! else if (i .eq. 5) then +! dum = 2.0 +! r1mach = log10( dum ) +! end if + + return + +! 999 write(*,1999) i +!1999 format(' r1mach - i out of bounds',i10) + 999 write(errmsg,1999) i + 1999 format('*** func r1mach fatal error -- i out of bounds',i10) + call peg_error_fatal( -1, errmsg ) + stop + end function r1mach +! +! subroutine xsetf + + subroutine xsetf (mflag) +! +! this routine resets the print control flag mflag. +! + integer mflag, mesflg, lunit + common /eh0001/ mesflg, lunit +! + if (mflag .eq. 0 .or. mflag .eq. 1) mesflg = mflag + return +!----------------------- end of subroutine xsetf ----------------------- + end subroutine xsetf + + +!----------------------------------------------------------------------- + subroutine set_lsodes_common_vars() +! +! place various constant or initial values into lsodes common blocks +! + common /eh0001/ mesflg, lunit + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + illin, init, lyh, lewt, lacor, lsavf, lwm, liwm, & + mxstep, mxhnil, nhnil, ntrep, nslast, nyh, iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + +! lsodes parameters + illin = 0 + ntrep = 0 + mesflg = 1 + lunit = 6 + + return +!--------------- end of subroutine set_lsodes_common_vars --------------- + end subroutine set_lsodes_common_vars + + + end module module_cbmz_lsodes_solver + + +!---------------------------------------------------------------------- +! Subr stode and prep must be outside of the module definition. +! When lsodes calls stode, the rwork array (in lsodes) is passed to +! both the wm and iwm arrays (in stode). This is treated as a +! severe error if stode is within the module. +! The same problem arises when iprep calls prep. +! These two routines were renamed to stode_lsodes and prep_lsodes +! to reduce the chance of name conflicts. +! + subroutine stode_lsodes (neq, y, yh, nyh, yh1, ewt, savf, acor, & + wm, iwm, f, jac, pjac, slvs, & + ruserpar, nruserpar, iuserpar, niuserpar ) + use module_cbmz_lsodes_solver, only: cfode, prjs, slss, r1mach, vnorm +!lll. optimize + external f, jac, pjac, slvs + integer neq, nyh, iwm + integer iownd, ialth, ipup, lmax, meo, nqnyh, nslp, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer i, i1, iredo, iret, j, jb, m, ncf, newq + integer nruserpar, iuserpar, niuserpar + real y, yh, yh1, ewt, savf, acor, wm + real conit, crate, el, elco, hold, rmax, tesco, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround +!rce real dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup, & +!rce r, rh, rhdn, rhsm, rhup, told, vnorm + real dcon, ddn, del, delp, dsm, dup, exdn, exsm, exup, & + r, rh, rhdn, rhsm, rhup, told + real ruserpar +!jdf dimension neq(1), y(1), yh(nyh,1), yh1(1), ewt(1), savf(1), +!jdf 1 acor(1), wm(1), iwm(1) + dimension neq(*), y(*), yh(nyh,*), yh1(*), ewt(*), savf(*), & + acor(*), wm(*), iwm(*) + dimension ruserpar(nruserpar), iuserpar(niuserpar) + common /ls0001/ conit, crate, el(13), elco(13,12), & + hold, rmax, tesco(3,12), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, iownd(14), & + ialth, ipup, lmax, meo, nqnyh, nslp, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu +!----------------------------------------------------------------------- +! stode performs one step of the integration of an initial value +! problem for a system of ordinary differential equations. +! note.. stode is independent of the value of the iteration method +! indicator miter, when this is .ne. 0, and hence is independent +! of the type of chord method used, or the jacobian structure. +! communication with stode is done with the following variables.. +! +! neq = integer array containing problem size in neq(1), and +! passed as the neq argument in all calls to f and jac. +! y = an array of length .ge. n used as the y argument in +! all calls to f and jac. +! yh = an nyh by lmax array containing the dependent variables +! and their approximate scaled derivatives, where +! lmax = maxord + 1. yh(i,j+1) contains the approximate +! j-th derivative of y(i), scaled by h**j/factorial(j) +! (j = 0,1,...,nq). on entry for the first step, the first +! two columns of yh must be set from the initial values. +! nyh = a constant integer .ge. n, the first dimension of yh. +! yh1 = a one-dimensional array occupying the same space as yh. +! ewt = an array of length n containing multiplicative weights +! for local error measurements. local errors in y(i) are +! compared to 1.0/ewt(i) in various error tests. +! savf = an array of working storage, of length n. +! also used for input of yh(*,maxord+2) when jstart = -1 +! and maxord .lt. the current order nq. +! acor = a work array of length n, used for the accumulated +! corrections. on a successful return, acor(i) contains +! the estimated one-step local error in y(i). +! wm,iwm = real and integer work arrays associated with matrix +! operations in chord iteration (miter .ne. 0). +! pjac = name of routine to evaluate and preprocess jacobian matrix +! and p = i - h*el0*jac, if a chord method is being used. +! slvs = name of routine to solve linear system in chord iteration. +! ccmax = maximum relative change in h*el0 before pjac is called. +! h = the step size to be attempted on the next step. +! h is altered by the error control algorithm during the +! problem. h can be either positive or negative, but its +! sign must remain constant throughout the problem. +! hmin = the minimum absolute value of the step size h to be used. +! hmxi = inverse of the maximum absolute value of h to be used. +! hmxi = 0.0 is allowed and corresponds to an infinite hmax. +! hmin and hmxi may be changed at any time, but will not +! take effect until the next change of h is considered. +! tn = the independent variable. tn is updated on each step taken. +! jstart = an integer used for input only, with the following +! values and meanings.. +! 0 perform the first step. +! .gt.0 take a new step continuing from the last. +! -1 take the next step with a new value of h, maxord, +! n, meth, miter, and/or matrix parameters. +! -2 take the next step with a new value of h, +! but with other inputs unchanged. +! on return, jstart is set to 1 to facilitate continuation. +! kflag = a completion code with the following meanings.. +! 0 the step was succesful. +! -1 the requested error could not be achieved. +! -2 corrector convergence could not be achieved. +! -3 fatal error in pjac or slvs. +! a return with kflag = -1 or -2 means either +! abs(h) = hmin or 10 consecutive failures occurred. +! on a return with kflag negative, the values of tn and +! the yh array are as of the beginning of the last +! step, and h is the last step size attempted. +! maxord = the maximum order of integration method to be allowed. +! maxcor = the maximum number of corrector iterations allowed. +! msbp = maximum number of steps between pjac calls (miter .gt. 0). +! mxncf = maximum number of convergence failures allowed. +! meth/miter = the method flags. see description in driver. +! n = the number of first-order differential equations. +!----------------------------------------------------------------------- + kflag = 0 + told = tn + ncf = 0 + ierpj = 0 + iersl = 0 + jcur = 0 + icf = 0 + delp = 0.0e0 + if (jstart .gt. 0) go to 200 + if (jstart .eq. -1) go to 100 + if (jstart .eq. -2) go to 160 +!----------------------------------------------------------------------- +! on the first call, the order is set to 1, and other variables are +! initialized. rmax is the maximum ratio by which h can be increased +! in a single step. it is initially 1.e4 to compensate for the small +! initial h, but then is normally equal to 10. if a failure +! occurs (in corrector convergence or error test), rmax is set at 2 +! for the next increase. +!----------------------------------------------------------------------- + lmax = maxord + 1 + nq = 1 + l = 2 + ialth = 2 + rmax = 10000.0e0 + rc = 0.0e0 + el0 = 1.0e0 + crate = 0.7e0 + hold = h + meo = meth + nslp = 0 + ipup = miter + iret = 3 + go to 140 +!----------------------------------------------------------------------- +! the following block handles preliminaries needed when jstart = -1. +! ipup is set to miter to force a matrix update. +! if an order increase is about to be considered (ialth = 1), +! ialth is reset to 2 to postpone consideration one more step. +! if the caller has changed meth, cfode is called to reset +! the coefficients of the method. +! if the caller has changed maxord to a value less than the current +! order nq, nq is reduced to maxord, and a new h chosen accordingly. +! if h is to be changed, yh must be rescaled. +! if h or meth is being changed, ialth is reset to l = nq + 1 +! to prevent further changes in h for that many steps. +!----------------------------------------------------------------------- + 100 ipup = miter + lmax = maxord + 1 + if (ialth .eq. 1) ialth = 2 + if (meth .eq. meo) go to 110 + call cfode (meth, elco, tesco) + meo = meth + if (nq .gt. maxord) go to 120 + ialth = l + iret = 1 + go to 150 + 110 if (nq .le. maxord) go to 160 + 120 nq = maxord + l = lmax + do 125 i = 1,l + 125 el(i) = elco(i,nq) + nqnyh = nq*nyh + rc = rc*el(1)/el0 + el0 = el(1) + conit = 0.5e0/float(nq+2) + ddn = vnorm (n, savf, ewt)/tesco(1,l) + exdn = 1.0e0/float(l) + rhdn = 1.0e0/(1.3e0*ddn**exdn + 0.0000013e0) + rh = amin1(rhdn,1.0e0) + iredo = 3 + if (h .eq. hold) go to 170 + rh = amin1(rh,abs(h/hold)) + h = hold + go to 175 +!----------------------------------------------------------------------- +! cfode is called to get all the integration coefficients for the +! current meth. then the el vector and related constants are reset +! whenever the order nq is changed, or at the start of the problem. +!----------------------------------------------------------------------- + 140 call cfode (meth, elco, tesco) + 150 do 155 i = 1,l + 155 el(i) = elco(i,nq) + nqnyh = nq*nyh + rc = rc*el(1)/el0 + el0 = el(1) + conit = 0.5e0/float(nq+2) + go to (160, 170, 200), iret +!----------------------------------------------------------------------- +! if h is being changed, the h ratio rh is checked against +! rmax, hmin, and hmxi, and the yh array rescaled. ialth is set to +! l = nq + 1 to prevent a change of h for that many steps, unless +! forced by a convergence or error test failure. +!----------------------------------------------------------------------- + 160 if (h .eq. hold) go to 200 + rh = h/hold + h = hold + iredo = 3 + go to 175 + 170 rh = amax1(rh,hmin/abs(h)) + 175 rh = amin1(rh,rmax) + rh = rh/amax1(1.0e0,abs(h)*hmxi*rh) + r = 1.0e0 + do 180 j = 2,l + r = r*rh + do 180 i = 1,n + 180 yh(i,j) = yh(i,j)*r + h = h*rh + rc = rc*rh + ialth = l + if (iredo .eq. 0) go to 690 +!----------------------------------------------------------------------- +! this section computes the predicted values by effectively +! multiplying the yh array by the pascal triangle matrix. +! rc is the ratio of new to old values of the coefficient h*el(1). +! when rc differs from 1 by more than ccmax, ipup is set to miter +! to force pjac to be called, if a jacobian is involved. +! in any case, pjac is called at least every msbp steps. +!----------------------------------------------------------------------- + 200 if (abs(rc-1.0e0) .gt. ccmax) ipup = miter + if (nst .ge. nslp+msbp) ipup = miter + tn = tn + h + i1 = nqnyh + 1 + do 215 jb = 1,nq + i1 = i1 - nyh +!dir$ ivdep + do 210 i = i1,nqnyh + 210 yh1(i) = yh1(i) + yh1(i+nyh) + 215 continue +!----------------------------------------------------------------------- +! up to maxcor corrector iterations are taken. a convergence test is +! made on the r.m.s. norm of each correction, weighted by the error +! weight vector ewt. the sum of the corrections is accumulated in the +! vector acor(i). the yh array is not altered in the corrector loop. +!----------------------------------------------------------------------- + 220 m = 0 + do 230 i = 1,n + 230 y(i) = yh(i,1) + call f (neq, tn, y, savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + nfe = nfe + 1 + if (ipup .le. 0) go to 250 +!----------------------------------------------------------------------- +! if indicated, the matrix p = i - h*el(1)*j is reevaluated and +! preprocessed before starting the corrector iteration. ipup is set +! to 0 as an indicator that this has been done. +!----------------------------------------------------------------------- + call pjac (neq, y, yh, nyh, ewt, acor, savf, wm, iwm, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar ) + ipup = 0 + rc = 1.0e0 + nslp = nst + crate = 0.7e0 + if (ierpj .ne. 0) go to 430 + 250 do 260 i = 1,n + 260 acor(i) = 0.0e0 + 270 if (miter .ne. 0) go to 350 +!----------------------------------------------------------------------- +! in the case of functional iteration, update y directly from +! the result of the last function evaluation. +!----------------------------------------------------------------------- + do 290 i = 1,n + savf(i) = h*savf(i) - yh(i,2) + 290 y(i) = savf(i) - acor(i) + del = vnorm (n, y, ewt) + do 300 i = 1,n + y(i) = yh(i,1) + el(1)*savf(i) + 300 acor(i) = savf(i) + go to 400 +!----------------------------------------------------------------------- +! in the case of the chord method, compute the corrector error, +! and solve the linear system with that as right-hand side and +! p as coefficient matrix. +!----------------------------------------------------------------------- + 350 do 360 i = 1,n + 360 y(i) = h*savf(i) - (yh(i,2) + acor(i)) + call slvs (wm, iwm, y, savf) + if (iersl .lt. 0) go to 430 + if (iersl .gt. 0) go to 410 + del = vnorm (n, y, ewt) + do 380 i = 1,n + acor(i) = acor(i) + y(i) + 380 y(i) = yh(i,1) + el(1)*acor(i) +!----------------------------------------------------------------------- +! test for convergence. if m.gt.0, an estimate of the convergence +! rate constant is stored in crate, and this is used in the test. +!----------------------------------------------------------------------- + 400 if (m .ne. 0) crate = amax1(0.2e0*crate,del/delp) + dcon = del*amin1(1.0e0,1.5e0*crate)/(tesco(2,nq)*conit) + if (dcon .le. 1.0e0) go to 450 + m = m + 1 + if (m .eq. maxcor) go to 410 + if (m .ge. 2 .and. del .gt. 2.0e0*delp) go to 410 + delp = del + call f (neq, tn, y, savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + nfe = nfe + 1 + go to 270 +!----------------------------------------------------------------------- +! the corrector iteration failed to converge. +! if miter .ne. 0 and the jacobian is out of date, pjac is called for +! the next try. otherwise the yh array is retracted to its values +! before prediction, and h is reduced, if possible. if h cannot be +! reduced or mxncf failures have occurred, exit with kflag = -2. +!----------------------------------------------------------------------- + 410 if (miter .eq. 0 .or. jcur .eq. 1) go to 430 + icf = 1 + ipup = miter + go to 220 + 430 icf = 2 + ncf = ncf + 1 + rmax = 2.0e0 + tn = told + i1 = nqnyh + 1 + do 445 jb = 1,nq + i1 = i1 - nyh +!dir$ ivdep + do 440 i = i1,nqnyh + 440 yh1(i) = yh1(i) - yh1(i+nyh) + 445 continue + if (ierpj .lt. 0 .or. iersl .lt. 0) go to 680 + if (abs(h) .le. hmin*1.00001e0) go to 670 + if (ncf .eq. mxncf) go to 670 + rh = 0.25e0 + ipup = miter + iredo = 1 + go to 170 +!----------------------------------------------------------------------- +! the corrector has converged. jcur is set to 0 +! to signal that the jacobian involved may need updating later. +! the local error test is made and control passes to statement 500 +! if it fails. +!----------------------------------------------------------------------- + 450 jcur = 0 + if (m .eq. 0) dsm = del/tesco(2,nq) + if (m .gt. 0) dsm = vnorm (n, acor, ewt)/tesco(2,nq) + if (dsm .gt. 1.0e0) go to 500 +!----------------------------------------------------------------------- +! after a successful step, update the yh array. +! consider changing h if ialth = 1. otherwise decrease ialth by 1. +! if ialth is then 1 and nq .lt. maxord, then acor is saved for +! use in a possible order increase on the next step. +! if a change in h is considered, an increase or decrease in order +! by one is considered also. a change in h is made only if it is by a +! factor of at least 1.1. if not, ialth is set to 3 to prevent +! testing for that many steps. +!----------------------------------------------------------------------- + kflag = 0 + iredo = 0 + nst = nst + 1 + hu = h + nqu = nq + do 470 j = 1,l + do 470 i = 1,n + 470 yh(i,j) = yh(i,j) + el(j)*acor(i) + ialth = ialth - 1 + if (ialth .eq. 0) go to 520 + if (ialth .gt. 1) go to 700 + if (l .eq. lmax) go to 700 + do 490 i = 1,n + 490 yh(i,lmax) = acor(i) + go to 700 +!----------------------------------------------------------------------- +! the error test failed. kflag keeps track of multiple failures. +! restore tn and the yh array to their previous values, and prepare +! to try the step again. compute the optimum step size for this or +! one lower order. after 2 or more failures, h is forced to decrease +! by a factor of 0.2 or less. +!----------------------------------------------------------------------- + 500 kflag = kflag - 1 + tn = told + i1 = nqnyh + 1 + do 515 jb = 1,nq + i1 = i1 - nyh +!dir$ ivdep + do 510 i = i1,nqnyh + 510 yh1(i) = yh1(i) - yh1(i+nyh) + 515 continue + rmax = 2.0e0 + if (abs(h) .le. hmin*1.00001e0) go to 660 + if (kflag .le. -3) go to 640 + iredo = 2 + rhup = 0.0e0 + go to 540 +!----------------------------------------------------------------------- +! regardless of the success or failure of the step, factors +! rhdn, rhsm, and rhup are computed, by which h could be multiplied +! at order nq - 1, order nq, or order nq + 1, respectively. +! in the case of failure, rhup = 0.0 to avoid an order increase. +! the largest of these is determined and the new order chosen +! accordingly. if the order is to be increased, we compute one +! additional scaled derivative. +!----------------------------------------------------------------------- + 520 rhup = 0.0e0 + if (l .eq. lmax) go to 540 + do 530 i = 1,n + 530 savf(i) = acor(i) - yh(i,lmax) + dup = vnorm (n, savf, ewt)/tesco(3,nq) + exup = 1.0e0/float(l+1) + rhup = 1.0e0/(1.4e0*dup**exup + 0.0000014e0) + 540 exsm = 1.0e0/float(l) + rhsm = 1.0e0/(1.2e0*dsm**exsm + 0.0000012e0) + rhdn = 0.0e0 + if (nq .eq. 1) go to 560 + ddn = vnorm (n, yh(1,l), ewt)/tesco(1,nq) + exdn = 1.0e0/float(nq) + rhdn = 1.0e0/(1.3e0*ddn**exdn + 0.0000013e0) + 560 if (rhsm .ge. rhup) go to 570 + if (rhup .gt. rhdn) go to 590 + go to 580 + 570 if (rhsm .lt. rhdn) go to 580 + newq = nq + rh = rhsm + go to 620 + 580 newq = nq - 1 + rh = rhdn + if (kflag .lt. 0 .and. rh .gt. 1.0e0) rh = 1.0e0 + go to 620 + 590 newq = l + rh = rhup + if (rh .lt. 1.1e0) go to 610 + r = el(l)/float(l) + do 600 i = 1,n + 600 yh(i,newq+1) = acor(i)*r + go to 630 + 610 ialth = 3 + go to 700 + 620 if ((kflag .eq. 0) .and. (rh .lt. 1.1e0)) go to 610 + if (kflag .le. -2) rh = amin1(rh,0.2e0) +!----------------------------------------------------------------------- +! if there is a change of order, reset nq, l, and the coefficients. +! in any case h is reset according to rh and the yh array is rescaled. +! then exit from 690 if the step was ok, or redo the step otherwise. +!----------------------------------------------------------------------- + if (newq .eq. nq) go to 170 + 630 nq = newq + l = nq + 1 + iret = 2 + go to 150 +!----------------------------------------------------------------------- +! control reaches this section if 3 or more failures have occured. +! if 10 failures have occurred, exit with kflag = -1. +! it is assumed that the derivatives that have accumulated in the +! yh array have errors of the wrong order. hence the first +! derivative is recomputed, and the order is set to 1. then +! h is reduced by a factor of 10, and the step is retried, +! until it succeeds or h reaches hmin. +!----------------------------------------------------------------------- + 640 if (kflag .eq. -10) go to 660 + rh = 0.1e0 + rh = amax1(hmin/abs(h),rh) + h = h*rh + do 645 i = 1,n + 645 y(i) = yh(i,1) + call f (neq, tn, y, savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + nfe = nfe + 1 + do 650 i = 1,n + 650 yh(i,2) = h*savf(i) + ipup = miter + ialth = 5 + if (nq .eq. 1) go to 200 + nq = 1 + l = 2 + iret = 3 + go to 150 +!----------------------------------------------------------------------- +! all returns are made through this section. h is saved in hold +! to allow the caller to change h on the next step. +!----------------------------------------------------------------------- + 660 kflag = -1 + go to 720 + 670 kflag = -2 + go to 720 + 680 kflag = -3 + go to 720 + 690 rmax = 10.0e0 + 700 r = 1.0e0/tesco(2,nqu) + do 710 i = 1,n + 710 acor(i) = acor(i)*r + 720 hold = h + jstart = 1 + return +!----------------------- end of subroutine stode_lsodes ----------------------- + end subroutine stode_lsodes + + + + subroutine prep_lsodes (neq, y, yh, savf, ewt, ftem, ia, ja, & + wk, iwk, ipper, f, jac, & + ruserpar, nruserpar, iuserpar, niuserpar ) + use module_cbmz_lsodes_solver, only: adjlr, cdrv, cntnzu, jgroup, & + odrv +!lll. optimize + external f,jac + integer neq, ia, ja, iwk, ipper + integer iownd, iowns, & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu + integer i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, jfound, k, & + knew, kmax, kmin, ldif, lenigp, liwk, maxg, np1, nzsut + integer nruserpar, iuserpar, niuserpar + real y, yh, savf, ewt, ftem, wk + real rowns, & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround + real con0, conmin, ccmxj, psmall, rbig, seth + real dq, dyj, erwt, fac, yj + real ruserpar +!jdf dimension neq(1), y(1), yh(1), savf(1), ewt(1), ftem(1), +!jdf 1 ia(1), ja(1), wk(1), iwk(1) + dimension neq(*), y(*), yh(*), savf(*), ewt(*), ftem(*), & + ia(*), ja(*), wk(*), iwk(*) + dimension ruserpar(nruserpar), iuserpar(niuserpar) + common /ls0001/ rowns(209), & + ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround, & + iownd(14), iowns(6), & + icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter, & + maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu + common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth, & + iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp, & + ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa, & + lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj, & + nslj, ngp, nlu, nnz, nsp, nzl, nzu +!----------------------------------------------------------------------- +! this routine performs preprocessing related to the sparse linear +! systems that must be solved if miter = 1 or 2. +! the operations that are performed here are.. +! * compute sparseness structure of jacobian according to moss, +! * compute grouping of column indices (miter = 2), +! * compute a new ordering of rows and columns of the matrix, +! * reorder ja corresponding to the new ordering, +! * perform a symbolic lu factorization of the matrix, and +! * set pointers for segments of the iwk/wk array. +! in addition to variables described previously, prep uses the +! following for communication.. +! yh = the history array. only the first column, containing the +! current y vector, is used. used only if moss .ne. 0. +! savf = a work array of length neq, used only if moss .ne. 0. +! ewt = array of length neq containing (inverted) error weights. +! used only if moss = 2 or if istate = moss = 1. +! ftem = a work array of length neq, identical to acor in the driver, +! used only if moss = 2. +! wk = a real work array of length lenwk, identical to wm in +! the driver. +! iwk = integer work array, assumed to occupy the same space as wk. +! lenwk = the length of the work arrays wk and iwk. +! istatc = a copy of the driver input argument istate (= 1 on the +! first call, = 3 on a continuation call). +! iys = flag value from odrv or cdrv. +! ipper = output error flag with the following values and meanings.. +! 0 no error. +! -1 insufficient storage for internal structure pointers. +! -2 insufficient storage for jgroup. +! -3 insufficient storage for odrv. +! -4 other error flag from odrv (should never occur). +! -5 insufficient storage for cdrv. +! -6 other error flag from cdrv. +!----------------------------------------------------------------------- + ibian = lrat*2 + ipian = ibian + 1 + np1 = n + 1 + ipjan = ipian + np1 + ibjan = ipjan - 1 + liwk = lenwk*lrat + if (ipjan+n-1 .gt. liwk) go to 210 + if (moss .eq. 0) go to 30 +! + if (istatc .eq. 3) go to 20 +! istate = 1 and moss .ne. 0. perturb y for structure determination. -- + do 10 i = 1,n + erwt = 1.0e0/ewt(i) + fac = 1.0e0 + 1.0e0/(float(i)+1.0e0) + y(i) = y(i) + fac*sign(erwt,y(i)) + 10 continue + go to (70, 100), moss +! + 20 continue +! istate = 3 and moss .ne. 0. load y from yh(*,1). -------------------- + do 25 i = 1,n + 25 y(i) = yh(i) + go to (70, 100), moss +! +! moss = 0. process user-s ia,ja. add diagonal entries if necessary. - + 30 knew = ipjan + kmin = ia(1) + iwk(ipian) = 1 + do 60 j = 1,n + jfound = 0 + kmax = ia(j+1) - 1 + if (kmin .gt. kmax) go to 45 + do 40 k = kmin,kmax + i = ja(k) + if (i .eq. j) jfound = 1 + if (knew .gt. liwk) go to 210 + iwk(knew) = i + knew = knew + 1 + 40 continue + if (jfound .eq. 1) go to 50 + 45 if (knew .gt. liwk) go to 210 + iwk(knew) = j + knew = knew + 1 + 50 iwk(ipian+j) = knew + 1 - ipjan + kmin = kmax + 1 + 60 continue + go to 140 +! +! moss = 1. compute structure from user-supplied jacobian routine jac. + 70 continue +! a dummy call to f allows user to create temporaries for use in jac. -- + call f (neq, tn, y, savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + k = ipjan + iwk(ipian) = 1 + do 90 j = 1,n + if (k .gt. liwk) go to 210 + iwk(k) = j + k = k + 1 + do 75 i = 1,n + 75 savf(i) = 0.0e0 + call jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + do 80 i = 1,n + if (abs(savf(i)) .le. seth) go to 80 + if (i .eq. j) go to 80 + if (k .gt. liwk) go to 210 + iwk(k) = i + k = k + 1 + 80 continue + iwk(ipian+j) = k + 1 - ipjan + 90 continue + go to 140 +! +! moss = 2. compute structure from results of n + 1 calls to f. ------- + 100 k = ipjan + iwk(ipian) = 1 + call f (neq, tn, y, savf, & + ruserpar, nruserpar, iuserpar, niuserpar) + do 120 j = 1,n + if (k .gt. liwk) go to 210 + iwk(k) = j + k = k + 1 + yj = y(j) + erwt = 1.0e0/ewt(j) + dyj = sign(erwt,yj) + y(j) = yj + dyj + call f (neq, tn, y, ftem, & + ruserpar, nruserpar, iuserpar, niuserpar) + y(j) = yj + do 110 i = 1,n + dq = (ftem(i) - savf(i))/dyj + if (abs(dq) .le. seth) go to 110 + if (i .eq. j) go to 110 + if (k .gt. liwk) go to 210 + iwk(k) = i + k = k + 1 + 110 continue + iwk(ipian+j) = k + 1 - ipjan + 120 continue +! + 140 continue + if (moss .eq. 0 .or. istatc .ne. 1) go to 150 +! if istate = 1 and moss .ne. 0, restore y from yh. -------------------- + do 145 i = 1,n + 145 y(i) = yh(i) + 150 nnz = iwk(ipian+n) - 1 + lenigp = 0 + ipigp = ipjan + nnz + if (miter .ne. 2) go to 160 +! +! compute grouping of column indices (miter = 2). ---------------------- + maxg = np1 + ipjgp = ipjan + nnz + ibjgp = ipjgp - 1 + ipigp = ipjgp + n + iptt1 = ipigp + np1 + iptt2 = iptt1 + n + lreq = iptt2 + n - 1 + if (lreq .gt. liwk) go to 220 + call jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp), & + iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier) + if (ier .ne. 0) go to 220 + lenigp = ngp + 1 +! +! compute new ordering of rows/columns of jacobian. -------------------- + 160 ipr = ipigp + lenigp + ipc = ipr + ipic = ipc + n + ipisp = ipic + n + iprsp = (ipisp - 2)/lrat + 2 + iesp = lenwk + 1 - iprsp + if (iesp .lt. 0) go to 230 + ibr = ipr - 1 + do 170 i = 1,n + 170 iwk(ibr+i) = i + nsp = liwk + 1 - ipisp + call odrv (n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic), & + nsp, iwk(ipisp), 1, iys) + if (iys .eq. 11*n+1) go to 240 + if (iys .ne. 0) go to 230 +! +! reorder jan and do symbolic lu factorization of matrix. -------------- + ipa = lenwk + 1 - nnz + nsp = ipa - iprsp + lreq = max0(12*n/lrat, 6*n/lrat+2*n+nnz) + 3 + lreq = lreq + iprsp - 1 + nnz + if (lreq .gt. lenwk) go to 250 + iba = ipa - 1 + do 180 i = 1,nnz + 180 wk(iba+i) = 0.0e0 + ipisp = lrat*(iprsp - 1) + 1 + call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan), & + wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys) + lreq = lenwk - iesp + if (iys .eq. 10*n+1) go to 250 + if (iys .ne. 0) go to 260 + ipil = ipisp + ipiu = ipil + 2*n + 1 + nzu = iwk(ipil+n) - iwk(ipil) + nzl = iwk(ipiu+n) - iwk(ipiu) + if (lrat .gt. 1) go to 190 + call adjlr (n, iwk(ipisp), ldif) + lreq = lreq + ldif + 190 continue + if (lrat .eq. 2 .and. nnz .eq. n) lreq = lreq + 1 + nsp = nsp + lreq - lenwk + ipa = lreq + 1 - nnz + iba = ipa - 1 + ipper = 0 + return +! + 210 ipper = -1 + lreq = 2 + (2*n + 1)/lrat + lreq = max0(lenwk+1,lreq) + return +! + 220 ipper = -2 + lreq = (lreq - 1)/lrat + 1 + return +! + 230 ipper = -3 + call cntnzu (n, iwk(ipian), iwk(ipjan), nzsut) + lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1 + return +! + 240 ipper = -4 + return +! + 250 ipper = -5 + return +! + 260 ipper = -6 + lreq = lenwk + return +!----------------------- end of subroutine prep_lsodes ------------------------ + end subroutine prep_lsodes diff --git a/wrfv2_fire/chem/module_cbmz_rodas3_solver.F b/wrfv2_fire/chem/module_cbmz_rodas3_solver.F new file mode 100644 index 00000000..d73d75e8 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz_rodas3_solver.F @@ -0,0 +1,393 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** + module module_cbmz_rodas3_solver + + contains + + +!----------------------------------------------------------------------- + + subroutine rodas3_ff_x2( n, t, tnext, hmin, hmax, hstart, & + y, abstol, reltol, yposlimit, yneglimit, & + yfixed, rconst, & + lu_nonzero_v, lu_crow_v, lu_diag_v, lu_icol_v, & + info, iok, lunerr, & + dydtsubr, yjacsubr, decompsubr, solvesubr ) +! include 'sparse_s.h' + +! stiffly accurate rosenbrock 3(2), with +! stiffly accurate embedded formula for error control. +! +! all the arguments aggree with the kpp syntax. +! +! input arguments: +! n = number of dependent variables (i.e., time-varying species) +! [t, tnext] = the integration interval +! hmin, hmax = lower and upper bounds for the selected step-size. +! note that for step = hmin the current computed +! solution is unconditionally accepted by the error +! control mechanism. +! hstart = initial guess step-size +! y = vector of (n) concentrations, contains the +! initial values on input +! abstol, reltol = (n) dimensional vectors of +! componentwise absolute and relative tolerances. +! yposlimit = vector of (n) upper-limit positive concentrations +! yneglimit = vector of (n) upper-limit negative concentrations +! yfixed = vector of (*) concentrations of fixed/non-reacting species +! rconst = vector of (*) concentrations of fixed/non-reacting species +! +! lu_nonzero_v = number of non-zero entries in the "augmented jacobian" +! (i.e., the jacobian with all diagonal elements filled in) +! lu_crow_v = vector of (n) pointers to the crow (?) elements +! lu_diag_v = vector of (n) pointers to the diagonal elements +! of the sparsely organized jacobian. +! jac(lu_diag_v(i)) is the i,i diagonal element +! lu_icol_v = vector of (lu_nonzero_v) pointers to the icol (?) elements +! info(1) = 1 for autonomous system +! = 0 for nonautonomous system +! iok = completion code (output) +! +1 = successful integration +! +2 = successful integration, but some substeps were h=hmin +! and error > abstol,reltol +! -1 = failure -- lu decomposition failed with minimum stepsize h=hmin +! -1001 --> -1999 = failure -- with minimum stepsize h=hmin, +! species i = -(iok+1000) was NaN +! -2001 --> -2999 = failure -- with minimum stepsize h=hmin, +! species i = -(iok+2000) was > yneglimit +! -3001 --> -3999 = failure -- with minimum stepsize h=hmin, +! species i = -(iok+3000) was < yposlimit +! -5001 --> -5999 = failure -- with minimum stepsize h=hmin, +! species i = -(iok+5000) had abs(kn(i)) > ylimit_solvesubr +! before call to solvesubr, where kn is either k1,k2,k3,k4 +! +! dydtsubr = name of routine of derivatives. kpp syntax. +! see the header below. +! yjacsubr = name of routine that computes the jacobian, in +! sparse format. kpp syntax. see the header below. +! decompsubr = name of routine that does sparse lu decomposition +! solvesubr = name of routine that does sparse lu backsolve +! +! output arguments: +! y = the values of concentrations at tend. +! t = equals tend on output. +! info(2) = # of dydtsubr calls. +! info(3) = # of yjacsubr calls. +! info(4) = # of accepted steps. +! info(5) = # of rejected steps. +! info(6) = # of steps that were accepted but had +! (hold.eq.hmin) .and. (err.gt.1) +! which means stepsize=minimum and error>tolerance +! +! adrian sandu, march 1996 +! the center for global and regional environmental research + + use module_peg_util, only: peg_message, peg_error_fatal + + implicit none + + integer nvar_maxd, lu_nonzero_v_maxd + parameter (nvar_maxd=99) + parameter (lu_nonzero_v_maxd=999) + +! common block variables + +! subr parameters + integer n, info(6), iok, lunerr, lu_nonzero_v + integer lu_crow_v(n), lu_diag_v(n), lu_icol_v(lu_nonzero_v) + real t, tnext, hmin, hmax, hstart + real y(n), abstol(n), reltol(n), yposlimit(n), yneglimit(n) + real yfixed(*), rconst(*) + external dydtsubr, yjacsubr, decompsubr, solvesubr + +! local variables + logical isreject, autonom + integer nfcn, njac, naccept, nreject, nnocnvg, i, j + integer ier + + real k1(nvar_maxd), k2(nvar_maxd) + real k3(nvar_maxd), k4(nvar_maxd) + real f1(nvar_maxd), ynew(nvar_maxd) + real jac(lu_nonzero_v_maxd) + real ghinv, uround + real tin, tplus, h, hold, hlowest + real err, factor, facmax + real dround, c43, tau, x1, x2, ytol + real ylimit_solvesubr + + character*80 errmsg + + ylimit_solvesubr = 1.0e18 + +! check n and lu_nonzero_v + if (n .gt. nvar_maxd) then + call peg_message( lunerr, '*** rodas3 dimensioning problem' ) + write(errmsg,9050) 'n, nvar_maxd = ', n, nvar_maxd + call peg_message( lunerr, errmsg ) + call peg_error_fatal( lunerr, '*** rodas3 fatal error' ) + else if (lu_nonzero_v .gt. lu_nonzero_v_maxd) then + call peg_message( lunerr, '*** rodas3 dimensioning problem' ) + write(errmsg,9050) 'lu_nonvero_v, lu_nonzero_v_maxd = ', & + lu_nonzero_v, lu_nonzero_v_maxd + call peg_message( lunerr, errmsg ) + call peg_error_fatal( lunerr, '*** rodas3 fatal error' ) + end if +9050 format( a, 2(1x,i6) ) + +! initialization + uround = 1.e-7 + dround = sqrt(uround) + +! check hmin and hmax + hlowest = dround + if (info(1) .eq. 1) hlowest = 1.0e-7 + if (hmin .lt. hlowest) then + call peg_message( lunerr, '*** rodas3 -- hmin is too small' ) + write(errmsg,9060) 'hmin and minimum allowed value = ', & + hmin, hlowest + call peg_message( lunerr, errmsg ) + call peg_error_fatal( lunerr, '*** rodas3 fatal error' ) + else if (hmin .ge. hmax) then + call peg_message( lunerr, '*** rodas3 -- hmin >= hmax' ) + write(errmsg,9060) 'hmin, hmax = ', hmin, hmax + call peg_message( lunerr, errmsg ) + call peg_error_fatal( lunerr, '*** rodas3 fatal error' ) + end if +9060 format( a, 1p, 2e14.4 ) + +! initialization of counters, etc. + autonom = info(1) .eq. 1 +!##checkthis## + c43 = - 8.e0/3.e0 +! h = 60.e0 ! hmin + h = max( hstart, hmin ) + tplus = t + tin = t + isreject = .false. + naccept = 0 + nreject = 0 + nnocnvg = 0 + nfcn = 0 + njac = 0 + + +! === starting the time loop === + 10 continue + tplus = t + h + if ( tplus .gt. tnext ) then + h = tnext - t + tplus = tnext + end if + + call yjacsubr( n, t, y, jac, yfixed, rconst ) + njac = njac+1 + ghinv = -2.0e0/h + do 20 j=1,n + jac(lu_diag_v(j)) = jac(lu_diag_v(j)) + ghinv + 20 continue + call decompsubr( n, jac, ier, lu_crow_v, lu_diag_v, lu_icol_v ) + + if (ier.ne.0) then + if ( h.gt.hmin) then + h = 5.0e-1*h + go to 10 + else +! print *,'ier <> 0, h=',h +! stop + iok = -1 + goto 200 + end if + end if + + call dydtsubr( n, t, y, f1, yfixed, rconst ) + +! ====== nonautonomous case =============== + if (.not. autonom) then +! tau = sign(dround*max( 1.0e-6, abs(t) ), t) + tau = dround*max( 1.0e-6, abs(t) ) + call dydtsubr( n, t+tau, y, k2, yfixed, rconst ) + nfcn=nfcn+1 + do 30 j = 1,n + k3(j) = ( k2(j)-f1(j) )/tau + 30 continue + +! ----- stage 1 (nonautonomous) ----- + x1 = 0.5*h + do 40 j = 1,n + k1(j) = f1(j) + x1*k3(j) + if (abs(k1(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 40 continue + call solvesubr( jac, k1 ) + +! ----- stage 2 (nonautonomous) ----- + x1 = 4.e0/h + x2 = 1.5e0*h + do 50 j = 1,n + k2(j) = f1(j) - x1*k1(j) + x2*k3(j) + if (abs(k2(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 50 continue + call solvesubr( jac, k2 ) + +! ====== autonomous case =============== + else +! ----- stage 1 (autonomous) ----- + do 60 j = 1,n + k1(j) = f1(j) + if (abs(k1(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 60 continue + call solvesubr( jac, k1 ) + +! ----- stage 2 (autonomous) ----- + x1 = 4.e0/h + do 70 j = 1,n + k2(j) = f1(j) - x1*k1(j) + if (abs(k2(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 70 continue + call solvesubr( jac, k2 ) + end if + +! ----- stage 3 ----- + do 80 j = 1,n + ynew(j) = y(j) - 2.0e0*k1(j) + 80 continue + call dydtsubr( n, t+h, ynew, f1, yfixed, rconst ) + nfcn=nfcn+1 + do 90 j = 1,n + k3(j) = f1(j) + ( -k1(j) + k2(j) )/h + if (abs(k3(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 90 continue + call solvesubr( jac, k3 ) + +! ----- stage 4 ----- + do 100 j = 1,n + ynew(j) = y(j) - 2.0e0*k1(j) - k3(j) + 100 continue + call dydtsubr( n, t+h, ynew, f1, yfixed, rconst ) + nfcn=nfcn+1 + do 110 j = 1,n + k4(j) = f1(j) + ( -k1(j) + k2(j) - c43*k3(j) )/h + if (abs(k4(j)) .gt. ylimit_solvesubr) then + iok = -(5000+j) + goto 135 + end if + 110 continue + call solvesubr( jac, k4 ) + +! ---- the solution --- + + do 120 j = 1,n + ynew(j) = y(j) - 2.0e0*k1(j) - k3(j) - k4(j) + 120 continue + + +! ====== error estimation ======== + + err=0.e0 + do 130 i=1,n + ytol = abstol(i) + reltol(i)*abs(ynew(i)) + err = err + ( k4(i)/ytol )**2 + 130 continue + err = max( uround, sqrt( err/n ) ) + +! ======= choose the stepsize =============================== + + factor = 0.9/err**(1.e0/3.e0) + if (isreject) then + facmax=1.0 + else + facmax=10.0 + end if + factor = max( 1.0e-1, min(factor,facmax) ) + hold = h + h = min( hmax, max(hmin,factor*h) ) + +! ======= check for nan, too big, too small ================= +! if any of these conditions occur, either +! exit if hold <= hmin +! reduce step size and retry if hold > hmin + + iok = 1 + do i = 1, n + if (y(i) .ne. y(i)) then + iok = -(1000+i) + goto 135 + else if (y(i) .lt. yneglimit(i)) then + iok = -(2000+i) + goto 135 + else if (y(i) .gt. yposlimit(i)) then + iok = -(3000+i) + goto 135 + end if + end do +135 if (iok .lt. 0) then + if (hold .le. hmin) then + goto 200 + else + isreject = .true. + nreject = nreject+1 + h = max(hmin, 0.5*hold) + if (t.eq.tin) h = max(hmin, 1.0e-1*hold) + goto 10 + end if + end if + + +! ======= rejected/accepted step ============================ + + if ( (err.gt.1).and.(hold.gt.hmin) ) then + isreject = .true. + nreject = nreject+1 + if (t.eq.tin) h = max(hmin, 1.0e-1*hold) + else + isreject = .false. + do 140 i=1,n + y(i) = ynew(i) + 140 continue + t = tplus + if (err.gt.1) then + nnocnvg = nnocnvg+1 + else + naccept = naccept+1 + end if + end if + +! ======= end of the time loop =============================== + if ( t .lt. tnext ) go to 10 + + iok = 1 + if (nnocnvg .gt. 0) iok = 2 + + +! ======= output information ================================= +200 info(2) = nfcn + info(3) = njac + info(4) = naccept + info(5) = nreject + info(6) = nnocnvg + + return + end subroutine rodas3_ff_x2 + + + end module module_cbmz_rodas3_solver diff --git a/wrfv2_fire/chem/module_cbmz_rodas_prep.F b/wrfv2_fire/chem/module_cbmz_rodas_prep.F new file mode 100644 index 00000000..d686efb9 --- /dev/null +++ b/wrfv2_fire/chem/module_cbmz_rodas_prep.F @@ -0,0 +1,10874 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** + module module_cbmz_rodas_prep + + + contains + + +!----------------------------------------------------------------------- +! cbmz_v02r01_torodas.f - created on 18-nov-2003 from previous +! cbmz_v02r01_torodas.f cbmz_v02r01_mapconcs.f +! cbmz_v02r01_maprates.f cbmz_v02r01_dydt.f +! cbmz_v02r01_jacob.f cbmz_v02r01_decomp.f +! cbmz_v02r01_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r01_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r01 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r01_dydt +! external cbmz_v02r01_jacob +! external cbmz_v02r01_decomp +! external cbmz_v02r01_solve + + integer i + + real hmax + + integer lu_crow_v(nvar_r01_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r01_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r01_kpp) + save lu_icol_v + + data lu_icol_v / & + 1, 4, 25, 2, 22, 24, 3, 26, 4, 25, 5, 25, & + 6, 24, 25, 7, 19, 25, 8, 22, 28, 9, 23, 28, & + 10, 21, 25, 11, 18, 20, 23, 25, 12, 24, 25, 28, & + 13, 24, 25, 27, 28, 14, 21, 24, 25, 15, 19, 24, & + 25, 3, 16, 23, 26, 27, 28, 9, 17, 18, 20, 23, & + 24, 25, 28, 10, 14, 18, 21, 23, 24, 25, 27, 7, & + 15, 19, 23, 24, 25, 27, 5, 15, 19, 20, 23, 24, & + 25, 27, 14, 20, 21, 22, 23, 24, 25, 27, 8, 20, & + 22, 23, 24, 25, 27, 28, 9, 16, 17, 18, 19, 20, & + 21, 22, 23, 24, 25, 26, 27, 28, 4, 5, 6, 10, & + 11, 12, 14, 15, 18, 19, 20, 21, 22, 23, 24, 25, & + 26, 27, 28, 3, 4, 5, 6, 7, 10, 11, 12, 13, & + 14, 15, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, & + 27, 28, 16, 22, 23, 24, 25, 26, 27, 28, 13, 16, & + 19, 21, 22, 23, 24, 25, 26, 27, 28, 8, 9, 12, & + 13, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, & + 27, 28 / + + data lu_crow_v / & + 1, 4, 7, 9, 11, 13, 16, 19, 22, 25, 28, 33, & + 37, 42, 46, 50, 56, 64, 72, 79, 87, 95,103,117, & + 136,159,167,178,195 / + + data lu_diag_v / & + 1, 4, 7, 9, 11, 13, 16, 19, 22, 25, 28, 33, & + 37, 42, 46, 51, 57, 66, 74, 82, 89, 97,111,131, & + 155,164,176,194,195 / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r01_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r01_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r01_dydt, & + cbmz_v02r01_jacob, & + cbmz_v02r01_decomp, & + cbmz_v02r01_solve ) + + return + end subroutine cbmz_v02r01_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r01 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r01_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 2 ) + integer io1d_kpp + parameter ( io1d_kpp = 3 ) + integer iso2_kpp + parameter ( iso2_kpp = 4 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 5 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 6 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 7 ) + integer ipan_kpp + parameter ( ipan_kpp = 8 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 9 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 10 ) + integer ico_kpp + parameter ( ico_kpp = 11 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 12 ) + integer ihono_kpp + parameter ( ihono_kpp = 13 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 14 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 15 ) + integer io3p_kpp + parameter ( io3p_kpp = 16 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 17 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 18 ) + integer iethp_kpp + parameter ( iethp_kpp = 19 ) + integer iald2_kpp + parameter ( iald2_kpp = 20 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 21 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 22 ) + integer ino3_kpp + parameter ( ino3_kpp = 23 ) + integer iho2_kpp + parameter ( iho2_kpp = 24 ) + integer ioh_kpp + parameter ( ioh_kpp = 25 ) + integer io3_kpp + parameter ( io3_kpp = 26 ) + integer ino_kpp + parameter ( ino_kpp = 27 ) + integer ino2_kpp + parameter ( ino2_kpp = 28 ) + +! indexes declaration for fixed species + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + + nyy = nvar_r01_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(ico_kpp) = cbox(ico_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(ino3_kpp) = cbox(ino3_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(ioh_kpp) = cbox(ioh_z) + yy(io3_kpp) = cbox(io3_z) + yy(ino_kpp) = cbox(ino_z) + yy(ino2_kpp) = cbox(ino2_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(ino3_z) = yy(ino3_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(ioh_z) = yy(ioh_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(ino2_z) = yy(ino2_kpp) + + return + end subroutine cbmz_v02r01_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r01 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + return + end subroutine cbmz_v02r01_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r01 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r01_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r01_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r01_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r01_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(28) + a(2) = rconst(2)*v(23) + a(3) = rconst(3)*v(13) + a(4) = rconst(4)*v(17) + a(5) = rconst(5)*v(12) + a(6) = rconst(6)*v(9) + a(7) = rconst(7)*v(26) + a(8) = rconst(8)*v(26) + a(9) = rconst(9)*v(6) + a(10) = rconst(10)*v(3)*f(4) + a(11) = rconst(11)*v(3)*f(5) + a(12) = rconst(12)*v(3)*f(2) + a(13) = rconst(13)*v(16)*f(4) + a(14) = rconst(14)*v(16)*v(26) + a(15) = rconst(15)*v(16)*v(28) + a(16) = rconst(16)*v(16)*v(28) + a(17) = rconst(17)*v(16)*v(27) + a(18) = rconst(18)*v(26)*v(27) + a(19) = rconst(19)*v(26)*v(28) + a(20) = rconst(20)*v(25)*v(26) + a(21) = rconst(21)*v(24)*v(26) + a(22) = rconst(22)*v(25)*f(3) + a(23) = rconst(23)*v(25)*v(27) + a(24) = rconst(24)*v(25)*v(28) + a(25) = rconst(25)*v(23)*v(25) + a(26) = rconst(26)*v(13)*v(25) + a(27) = rconst(27)*v(17)*v(25) + a(28) = rconst(28)*v(12)*v(25) + a(29) = rconst(29)*v(24)*v(25) + a(30) = rconst(30)*v(6)*v(25) + a(31) = rconst(31)*v(24)*v(24) + a(32) = rconst(32)*v(24)*v(24)*f(2) + a(33) = rconst(33)*v(24)*v(27) + a(34) = rconst(34)*v(24)*v(28) + a(35) = rconst(35)*v(24)*v(28) + a(36) = rconst(36)*v(12) + a(37) = rconst(37)*v(23)*v(27) + a(38) = rconst(38)*v(23)*v(28) + a(39) = rconst(39)*v(23)*v(28) + a(40) = rconst(40)*v(23)*v(23) + a(41) = rconst(41)*v(23)*v(24) + a(42) = rconst(42)*v(9)*f(2) + a(43) = rconst(43)*v(9) + a(44) = rconst(44)*v(11)*v(25) + a(45) = rconst(45)*v(4)*v(25) + a(46) = rconst(46)*v(25)*f(1) + a(47) = rconst(47)*v(7)*v(25) + a(48) = rconst(48)*v(10)*v(25) + a(49) = rconst(49)*v(18) + a(50) = rconst(50)*v(18) + a(51) = rconst(51)*v(18)*v(25) + a(52) = rconst(52)*v(18)*v(23) + a(53) = rconst(53)*v(14) + a(54) = rconst(54)*v(15) + a(55) = rconst(55)*v(14)*v(25) + a(56) = rconst(56)*v(15)*v(25) + a(57) = rconst(57)*v(21)*v(27) + a(58) = rconst(58)*v(19)*v(27) + a(59) = rconst(59)*v(21)*v(23) + a(60) = rconst(60)*v(19)*v(23) + a(61) = rconst(61)*v(21)*v(24) + a(62) = rconst(62)*v(19)*v(24) + a(63) = rconst(63)*v(21) + a(64) = rconst(64)*v(19) + a(65) = rconst(65)*v(5)*v(25) + a(66) = rconst(66)*v(20) + a(67) = rconst(67)*v(20)*v(25) + a(68) = rconst(68)*v(20)*v(23) + a(69) = rconst(69)*v(22)*v(28) + a(70) = rconst(70)*v(8) + a(71) = rconst(71)*v(22)*v(27) + a(72) = rconst(72)*v(22)*v(23) + a(73) = rconst(73)*v(22)*v(24) + a(74) = rconst(74)*v(22) + +! aggregate function + a_var(1) = a(45) + a_var(2) = 0.4*a(73) + a_var(3) = a(8)-a(10)-a(11)-a(12) + a_var(4) = -a(45) + a_var(5) = -a(65) + a_var(6) = -a(9)-a(30)+a(31)+a(32) + a_var(7) = -a(47)+0.2*a(64) + a_var(8) = a(69)-a(70) + a_var(9) = -a(6)+a(39)-a(42)-a(43) + a_var(10) = -a(48)+0.34*a(63) + a_var(11) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66) + a_var(12) = -a(5)-a(28)+a(34)-a(36) + a_var(13) = -a(3)+a(23)-a(26)+a(35) + a_var(14) = -a(53)-a(55)+a(61) + a_var(15) = -a(54)-a(56)+a(62) + a_var(16) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17) + a_var(17) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) + a_var(18) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63) + a_var(19) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64) + a_var(20) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68) + a_var(21) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74) + a_var(22) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) + a_var(23) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) + a_var(24) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73) + a_var(25) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67) + a_var(26) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73) + a_var(27) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71) + a_var(28) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72) + return + end subroutine cbmz_v02r01_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r01 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r01_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r01_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r01_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r01_kpp,nvar_r01_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,28) = rconst(1) + b(2,23) = rconst(2) + b(3,13) = rconst(3) + b(4,17) = rconst(4) + b(5,12) = rconst(5) + b(6,9) = rconst(6) + b(7,26) = rconst(7) + b(8,26) = rconst(8) + b(9,6) = rconst(9) + b(10,3) = rconst(10)*f(4) + b(11,3) = rconst(11)*f(5) + b(12,3) = rconst(12)*f(2) + b(13,16) = rconst(13)*f(4) + b(14,16) = rconst(14)*v(26) + b(14,26) = rconst(14)*v(16) + b(15,16) = rconst(15)*v(28) + b(15,28) = rconst(15)*v(16) + b(16,16) = rconst(16)*v(28) + b(16,28) = rconst(16)*v(16) + b(17,16) = rconst(17)*v(27) + b(17,27) = rconst(17)*v(16) + b(18,26) = rconst(18)*v(27) + b(18,27) = rconst(18)*v(26) + b(19,26) = rconst(19)*v(28) + b(19,28) = rconst(19)*v(26) + b(20,25) = rconst(20)*v(26) + b(20,26) = rconst(20)*v(25) + b(21,24) = rconst(21)*v(26) + b(21,26) = rconst(21)*v(24) + b(22,25) = rconst(22)*f(3) + b(23,25) = rconst(23)*v(27) + b(23,27) = rconst(23)*v(25) + b(24,25) = rconst(24)*v(28) + b(24,28) = rconst(24)*v(25) + b(25,23) = rconst(25)*v(25) + b(25,25) = rconst(25)*v(23) + b(26,13) = rconst(26)*v(25) + b(26,25) = rconst(26)*v(13) + b(27,17) = rconst(27)*v(25) + b(27,25) = rconst(27)*v(17) + b(28,12) = rconst(28)*v(25) + b(28,25) = rconst(28)*v(12) + b(29,24) = rconst(29)*v(25) + b(29,25) = rconst(29)*v(24) + b(30,6) = rconst(30)*v(25) + b(30,25) = rconst(30)*v(6) + b(31,24) = rconst(31)*2*v(24) + b(32,24) = rconst(32)*2*v(24)*f(2) + b(33,24) = rconst(33)*v(27) + b(33,27) = rconst(33)*v(24) + b(34,24) = rconst(34)*v(28) + b(34,28) = rconst(34)*v(24) + b(35,24) = rconst(35)*v(28) + b(35,28) = rconst(35)*v(24) + b(36,12) = rconst(36) + b(37,23) = rconst(37)*v(27) + b(37,27) = rconst(37)*v(23) + b(38,23) = rconst(38)*v(28) + b(38,28) = rconst(38)*v(23) + b(39,23) = rconst(39)*v(28) + b(39,28) = rconst(39)*v(23) + b(40,23) = rconst(40)*2*v(23) + b(41,23) = rconst(41)*v(24) + b(41,24) = rconst(41)*v(23) + b(42,9) = rconst(42)*f(2) + b(43,9) = rconst(43) + b(44,11) = rconst(44)*v(25) + b(44,25) = rconst(44)*v(11) + b(45,4) = rconst(45)*v(25) + b(45,25) = rconst(45)*v(4) + b(46,25) = rconst(46)*f(1) + b(47,7) = rconst(47)*v(25) + b(47,25) = rconst(47)*v(7) + b(48,10) = rconst(48)*v(25) + b(48,25) = rconst(48)*v(10) + b(49,18) = rconst(49) + b(50,18) = rconst(50) + b(51,18) = rconst(51)*v(25) + b(51,25) = rconst(51)*v(18) + b(52,18) = rconst(52)*v(23) + b(52,23) = rconst(52)*v(18) + b(53,14) = rconst(53) + b(54,15) = rconst(54) + b(55,14) = rconst(55)*v(25) + b(55,25) = rconst(55)*v(14) + b(56,15) = rconst(56)*v(25) + b(56,25) = rconst(56)*v(15) + b(57,21) = rconst(57)*v(27) + b(57,27) = rconst(57)*v(21) + b(58,19) = rconst(58)*v(27) + b(58,27) = rconst(58)*v(19) + b(59,21) = rconst(59)*v(23) + b(59,23) = rconst(59)*v(21) + b(60,19) = rconst(60)*v(23) + b(60,23) = rconst(60)*v(19) + b(61,21) = rconst(61)*v(24) + b(61,24) = rconst(61)*v(21) + b(62,19) = rconst(62)*v(24) + b(62,24) = rconst(62)*v(19) + b(63,21) = rconst(63) + b(64,19) = rconst(64) + b(65,5) = rconst(65)*v(25) + b(65,25) = rconst(65)*v(5) + b(66,20) = rconst(66) + b(67,20) = rconst(67)*v(25) + b(67,25) = rconst(67)*v(20) + b(68,20) = rconst(68)*v(23) + b(68,23) = rconst(68)*v(20) + b(69,22) = rconst(69)*v(28) + b(69,28) = rconst(69)*v(22) + b(70,8) = rconst(70) + b(71,22) = rconst(71)*v(27) + b(71,27) = rconst(71)*v(22) + b(72,22) = rconst(72)*v(23) + b(72,23) = rconst(72)*v(22) + b(73,22) = rconst(73)*v(24) + b(73,24) = rconst(73)*v(22) + b(74,22) = rconst(74) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,4) + jvs(3) = b(45,25) + jvs(4) = 0 + jvs(5) = 0.4*b(73,22) + jvs(6) = 0.4*b(73,24) + jvs(7) = -b(10,3)-b(11,3)-b(12,3) + jvs(8) = b(8,26) + jvs(9) = -b(45,4) + jvs(10) = -b(45,25) + jvs(11) = -b(65,5) + jvs(12) = -b(65,25) + jvs(13) = -b(9,6)-b(30,6) + jvs(14) = b(31,24)+b(32,24) + jvs(15) = -b(30,25) + jvs(16) = -b(47,7) + jvs(17) = 0.2*b(64,19) + jvs(18) = -b(47,25) + jvs(19) = -b(70,8) + jvs(20) = b(69,22) + jvs(21) = b(69,28) + jvs(22) = -b(6,9)-b(42,9)-b(43,9) + jvs(23) = b(39,23) + jvs(24) = b(39,28) + jvs(25) = -b(48,10) + jvs(26) = 0.34*b(63,21) + jvs(27) = -b(48,25) + jvs(28) = -b(44,11) + jvs(29) = b(49,18)+b(50,18)+b(51,18)+b(52,18) + jvs(30) = b(66,20) + jvs(31) = b(52,23) + jvs(32) = -b(44,25)+b(51,25) + jvs(33) = -b(5,12)-b(28,12)-b(36,12) + jvs(34) = b(34,24) + jvs(35) = -b(28,25) + jvs(36) = b(34,28) + jvs(37) = -b(3,13)-b(26,13) + jvs(38) = b(35,24) + jvs(39) = b(23,25)-b(26,25) + jvs(40) = b(23,27) + jvs(41) = b(35,28) + jvs(42) = -b(53,14)-b(55,14) + jvs(43) = b(61,21) + jvs(44) = b(61,24) + jvs(45) = -b(55,25) + jvs(46) = -b(54,15)-b(56,15) + jvs(47) = b(62,19) + jvs(48) = b(62,24) + jvs(49) = -b(56,25) + jvs(50) = b(10,3)+b(11,3) + jvs(51) = -b(13,16)-b(14,16)-b(15,16)-b(16,16)-b(17,16) + jvs(52) = 0.89*b(2,23) + jvs(53) = b(7,26)-b(14,26) + jvs(54) = -b(17,27) + jvs(55) = b(1,28)-b(15,28)-b(16,28) + jvs(56) = 2*b(42,9) + jvs(57) = -b(4,17)-b(27,17) + jvs(58) = b(52,18) + jvs(59) = b(68,20) + jvs(60) = 0.3*b(41,23)+b(52,23)+b(68,23) + jvs(61) = 0.3*b(41,24) + jvs(62) = b(24,25)-b(27,25) + jvs(63) = b(24,28) + jvs(64) = b(48,10) + jvs(65) = b(53,14)+0.3*b(55,14) + jvs(66) = -b(49,18)-b(50,18)-b(51,18)-b(52,18) + jvs(67) = b(57,21)+b(59,21)+0.66*b(63,21) + jvs(68) = -b(52,23)+b(59,23) + jvs(69) = 0 + jvs(70) = b(48,25)-b(51,25)+0.3*b(55,25) + jvs(71) = b(57,27) + jvs(72) = b(47,7) + jvs(73) = 0.5*b(56,15) + jvs(74) = -b(58,19)-b(60,19)-b(62,19)-b(64,19) + jvs(75) = -b(60,23) + jvs(76) = -b(62,24) + jvs(77) = b(47,25)+0.5*b(56,25) + jvs(78) = -b(58,27) + jvs(79) = b(65,5) + jvs(80) = b(54,15)+0.5*b(56,15) + jvs(81) = b(58,19)+b(60,19)+0.8*b(64,19) + jvs(82) = -b(66,20)-b(67,20)-b(68,20) + jvs(83) = b(60,23)-b(68,23) + jvs(84) = 0 + jvs(85) = 0.5*b(56,25)+b(65,25)-b(67,25) + jvs(86) = b(58,27) + jvs(87) = 0.7*b(55,14) + jvs(88) = b(66,20) + jvs(89) = -b(57,21)-b(59,21)-b(61,21)-b(63,21) + jvs(90) = b(71,22)+b(72,22)+b(74,22) + jvs(91) = -b(59,23)+b(72,23) + jvs(92) = -b(61,24) + jvs(93) = b(46,25)+0.7*b(55,25) + jvs(94) = -b(57,27)+b(71,27) + jvs(95) = b(70,8) + jvs(96) = b(67,20)+b(68,20) + jvs(97) = -b(69,22)-b(71,22)-b(72,22)-b(73,22)-b(74,22) + jvs(98) = b(68,23)-b(72,23) + jvs(99) = -b(73,24) + jvs(100) = b(67,25) + jvs(101) = -b(71,27) + jvs(102) = -b(69,28) + jvs(103) = b(6,9)+b(43,9) + jvs(104) = b(16,16) + jvs(105) = b(27,17) + jvs(106) = -b(52,18) + jvs(107) = -b(60,19) + jvs(108) = -b(68,20) + jvs(109) = -b(59,21) + jvs(110) = -b(72,22) + jvs(111) = -b(2,23)-b(25,23)-b(37,23)-b(38,23)-b(39,23)-2 & + *b(40,23)-b(41,23)-b(52,23)-b(59,23)-b(60,23)-b(68,23) & + -b(72,23) + jvs(112) = -b(41,24) + jvs(113) = -b(25,25)+b(27,25) + jvs(114) = b(19,26) + jvs(115) = -b(37,27) + jvs(116) = b(16,28)+b(19,28)-b(38,28)-b(39,28) + jvs(117) = b(45,4) + jvs(118) = b(65,5) + jvs(119) = b(30,6) + jvs(120) = b(48,10) + jvs(121) = b(44,11) + jvs(122) = b(5,12)+b(36,12) + jvs(123) = b(53,14) + jvs(124) = b(54,15) + jvs(125) = 2*b(49,18)+b(51,18)+b(52,18) + jvs(126) = b(58,19)+b(60,19)-b(62,19)+0.6*b(64,19) + jvs(127) = b(66,20) + jvs(128) = b(57,21)+b(59,21)-b(61,21)+0.32*b(63,21) + jvs(129) = -b(73,22) + jvs(130) = b(25,23)-b(41,23)+b(52,23)+b(59,23)+b(60,23) + jvs(131) = -b(21,24)-b(29,24)-2*b(31,24)-2*b(32,24)-b(33,24) & + -b(34,24)-b(35,24)-b(41,24)-b(61,24)-b(62,24)-b(73,24) + jvs(132) = b(20,25)+b(22,25)+b(25,25)-b(29,25)+b(30,25)+b(44,25) & + +b(45,25)+b(48,25)+b(51,25)+b(65,25) + jvs(133) = b(20,26)-b(21,26) + jvs(134) = -b(33,27)+b(57,27)+b(58,27) + jvs(135) = -b(34,28)-b(35,28) + jvs(136) = 2*b(12,3) + jvs(137) = -b(45,4) + jvs(138) = -b(65,5) + jvs(139) = 2*b(9,6)-b(30,6) + jvs(140) = -b(47,7) + jvs(141) = -b(48,10) + jvs(142) = -b(44,11) + jvs(143) = -b(28,12) + jvs(144) = b(3,13)-b(26,13) + jvs(145) = b(53,14)-0.7*b(55,14) + jvs(146) = b(54,15)-0.5*b(56,15) + jvs(147) = b(4,17)-b(27,17) + jvs(148) = -b(51,18) + jvs(149) = 0 + jvs(150) = -b(67,20) + jvs(151) = 0 + jvs(152) = 0 + jvs(153) = -b(25,23)+0.7*b(41,23) + jvs(154) = b(21,24)-b(29,24)+b(33,24)+0.7*b(41,24) + jvs(155) = -b(20,25)-b(22,25)-b(23,25)-b(24,25)-b(25,25) & + -b(26,25)-b(27,25)-b(28,25)-b(29,25)-b(30,25)-b(44,25) & + -b(45,25)-b(46,25)-b(47,25)-b(48,25)-b(51,25)-0.7 & + *b(55,25)-0.5*b(56,25)-b(65,25)-b(67,25) + jvs(156) = -b(20,26)+b(21,26) + jvs(157) = -b(23,27)+b(33,27) + jvs(158) = -b(24,28) + jvs(159) = b(13,16)-b(14,16) + jvs(160) = 0.4*b(73,22) + jvs(161) = 0 + jvs(162) = -b(21,24)+0.4*b(73,24) + jvs(163) = -b(20,25) + jvs(164) = -b(7,26)-b(8,26)-b(14,26)-b(18,26)-b(19,26)-b(20,26) & + -b(21,26) + jvs(165) = -b(18,27) + jvs(166) = -b(19,28) + jvs(167) = b(3,13) + jvs(168) = b(15,16)-b(17,16) + jvs(169) = -b(58,19) + jvs(170) = -b(57,21) + jvs(171) = -b(71,22) + jvs(172) = 0.11*b(2,23)-b(37,23)+b(38,23) + jvs(173) = -b(33,24) + jvs(174) = -b(23,25) + jvs(175) = -b(18,26) + jvs(176) = -b(17,27)-b(18,27)-b(23,27)-b(33,27)-b(37,27) & + -b(57,27)-b(58,27)-b(71,27) + jvs(177) = b(1,28)+b(15,28)+b(38,28) + jvs(178) = b(70,8) + jvs(179) = b(6,9)+b(43,9) + jvs(180) = b(5,12)+b(28,12)+b(36,12) + jvs(181) = b(26,13) + jvs(182) = -b(15,16)-b(16,16)+b(17,16) + jvs(183) = b(4,17) + jvs(184) = 0 + jvs(185) = b(58,19)+b(60,19) + jvs(186) = 0 + jvs(187) = b(57,21)+b(59,21) + jvs(188) = -b(69,22)+b(71,22)+b(72,22) + jvs(189) = 0.89*b(2,23)+b(25,23)+2*b(37,23)-b(39,23)+2*b(40,23) & + +0.7*b(41,23)+b(59,23)+b(60,23)+b(72,23) + jvs(190) = b(33,24)-b(34,24)-b(35,24)+0.7*b(41,24) + jvs(191) = -b(24,25)+b(25,25)+b(26,25)+b(28,25) + jvs(192) = b(18,26)-b(19,26) + jvs(193) = b(17,27)+b(18,27)+b(33,27)+2*b(37,27)+b(57,27) & + +b(58,27)+b(71,27) + jvs(194) = -b(1,28)-b(15,28)-b(16,28)-b(19,28)-b(24,28)-b(34,28) & + -b(35,28)-b(39,28)-b(69,28) + return + end subroutine cbmz_v02r01_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r01 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = non-zero elements of the sparse jacobian [input] + real v(lu_nonzero_v_r01_kpp) + + integer lu_crow_v(nvar_r01_kpp + 1) + integer lu_diag_v(nvar_r01_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r01_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r01_kpp + 1) + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r01_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r01_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r01 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(16) = x(16)-jvs(50)*x(3) + x(17) = x(17)-jvs(56)*x(9) + x(18) = x(18)-jvs(64)*x(10)-jvs(65)*x(14) + x(19) = x(19)-jvs(72)*x(7)-jvs(73)*x(15) + x(20) = x(20)-jvs(79)*x(5)-jvs(80)*x(15)-jvs(81)*x(19) + x(21) = x(21)-jvs(87)*x(14)-jvs(88)*x(20) + x(22) = x(22)-jvs(95)*x(8)-jvs(96)*x(20) + x(23) = x(23)-jvs(103)*x(9)-jvs(104)*x(16)-jvs(105)*x(17) & + -jvs(106)*x(18)-jvs(107)*x(19)-jvs(108)*x(20)-jvs(109) & + *x(21)-jvs(110)*x(22) + x(24) = x(24)-jvs(117)*x(4)-jvs(118)*x(5)-jvs(119)*x(6)-jvs(120) & + *x(10)-jvs(121)*x(11)-jvs(122)*x(12)-jvs(123)*x(14) & + -jvs(124)*x(15)-jvs(125)*x(18)-jvs(126)*x(19)-jvs(127) & + *x(20)-jvs(128)*x(21)-jvs(129)*x(22)-jvs(130)*x(23) + x(25) = x(25)-jvs(136)*x(3)-jvs(137)*x(4)-jvs(138)*x(5)-jvs(139) & + *x(6)-jvs(140)*x(7)-jvs(141)*x(10)-jvs(142)*x(11) & + -jvs(143)*x(12)-jvs(144)*x(13)-jvs(145)*x(14)-jvs(146) & + *x(15)-jvs(147)*x(17)-jvs(148)*x(18)-jvs(149)*x(19) & + -jvs(150)*x(20)-jvs(151)*x(21)-jvs(152)*x(22)-jvs(153) & + *x(23)-jvs(154)*x(24) + x(26) = x(26)-jvs(159)*x(16)-jvs(160)*x(22)-jvs(161)*x(23) & + -jvs(162)*x(24)-jvs(163)*x(25) + x(27) = x(27)-jvs(167)*x(13)-jvs(168)*x(16)-jvs(169)*x(19) & + -jvs(170)*x(21)-jvs(171)*x(22)-jvs(172)*x(23)-jvs(173) & + *x(24)-jvs(174)*x(25)-jvs(175)*x(26) + x(28) = x(28)-jvs(178)*x(8)-jvs(179)*x(9)-jvs(180)*x(12) & + -jvs(181)*x(13)-jvs(182)*x(16)-jvs(183)*x(17)-jvs(184) & + *x(18)-jvs(185)*x(19)-jvs(186)*x(20)-jvs(187)*x(21) & + -jvs(188)*x(22)-jvs(189)*x(23)-jvs(190)*x(24)-jvs(191) & + *x(25)-jvs(192)*x(26)-jvs(193)*x(27) + x(28) = x(28)/jvs(194) + x(27) = (x(27)-jvs(177)*x(28))/(jvs(176)) + x(26) = (x(26)-jvs(165)*x(27)-jvs(166)*x(28))/(jvs(164)) + x(25) = (x(25)-jvs(156)*x(26)-jvs(157)*x(27)-jvs(158)*x(28))/ & + (jvs(155)) + x(24) = (x(24)-jvs(132)*x(25)-jvs(133)*x(26)-jvs(134)*x(27) & + -jvs(135)*x(28))/(jvs(131)) + x(23) = (x(23)-jvs(112)*x(24)-jvs(113)*x(25)-jvs(114)*x(26) & + -jvs(115)*x(27)-jvs(116)*x(28))/(jvs(111)) + x(22) = (x(22)-jvs(98)*x(23)-jvs(99)*x(24)-jvs(100)*x(25) & + -jvs(101)*x(27)-jvs(102)*x(28))/(jvs(97)) + x(21) = (x(21)-jvs(90)*x(22)-jvs(91)*x(23)-jvs(92)*x(24)-jvs(93) & + *x(25)-jvs(94)*x(27))/(jvs(89)) + x(20) = (x(20)-jvs(83)*x(23)-jvs(84)*x(24)-jvs(85)*x(25)-jvs(86) & + *x(27))/(jvs(82)) + x(19) = (x(19)-jvs(75)*x(23)-jvs(76)*x(24)-jvs(77)*x(25)-jvs(78) & + *x(27))/(jvs(74)) + x(18) = (x(18)-jvs(67)*x(21)-jvs(68)*x(23)-jvs(69)*x(24)-jvs(70) & + *x(25)-jvs(71)*x(27))/(jvs(66)) + x(17) = (x(17)-jvs(58)*x(18)-jvs(59)*x(20)-jvs(60)*x(23)-jvs(61) & + *x(24)-jvs(62)*x(25)-jvs(63)*x(28))/(jvs(57)) + x(16) = (x(16)-jvs(52)*x(23)-jvs(53)*x(26)-jvs(54)*x(27)-jvs(55) & + *x(28))/(jvs(51)) + x(15) = (x(15)-jvs(47)*x(19)-jvs(48)*x(24)-jvs(49)*x(25))/ & + (jvs(46)) + x(14) = (x(14)-jvs(43)*x(21)-jvs(44)*x(24)-jvs(45)*x(25))/ & + (jvs(42)) + x(13) = (x(13)-jvs(38)*x(24)-jvs(39)*x(25)-jvs(40)*x(27)-jvs(41) & + *x(28))/(jvs(37)) + x(12) = (x(12)-jvs(34)*x(24)-jvs(35)*x(25)-jvs(36)*x(28))/ & + (jvs(33)) + x(11) = (x(11)-jvs(29)*x(18)-jvs(30)*x(20)-jvs(31)*x(23)-jvs(32) & + *x(25))/(jvs(28)) + x(10) = (x(10)-jvs(26)*x(21)-jvs(27)*x(25))/(jvs(25)) + x(9) = (x(9)-jvs(23)*x(23)-jvs(24)*x(28))/(jvs(22)) + x(8) = (x(8)-jvs(20)*x(22)-jvs(21)*x(28))/(jvs(19)) + x(7) = (x(7)-jvs(17)*x(19)-jvs(18)*x(25))/(jvs(16)) + x(6) = (x(6)-jvs(14)*x(24)-jvs(15)*x(25))/(jvs(13)) + x(5) = (x(5)-jvs(12)*x(25))/(jvs(11)) + x(4) = (x(4)-jvs(10)*x(25))/(jvs(9)) + x(3) = (x(3)-jvs(8)*x(26))/(jvs(7)) + x(2) = (x(2)-jvs(5)*x(22)-jvs(6)*x(24))/(jvs(4)) + x(1) = (x(1)-jvs(2)*x(4)-jvs(3)*x(25))/(jvs(1)) + return + end subroutine cbmz_v02r01_solve + + +! cbmz_v02r02_torodas.f - created on 17-nov-2003 from previous +! cbmz_v02r02_torodas.f cbmz_v02r02_mapconcs.f +! cbmz_v02r02_maprates.f cbmz_v02r02_dydt.f +! cbmz_v02r02_jacob.f cbmz_v02r02_decomp.f +! cbmz_v02r02_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r02_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r02 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r02_dydt +! external cbmz_v02r02_jacob +! external cbmz_v02r02_decomp +! external cbmz_v02r02_solve + + integer i + + real hmax + + integer lu_crow_v(nvar_r02_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r02_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r02_kpp) + save lu_icol_v + + data( lu_icol_v(i), i = 1, 252 ) / & + 1, 5, 44, 2, 20, 30, 43, 3, 30, 33, 42, 43, & + 45, 4, 43, 5, 44, 6, 44, 7, 42, 44, 8, 35, & + 44, 9, 45, 47, 10, 44, 11, 47, 48, 12, 44, 12, & + 13, 25, 44, 14, 23, 44, 47, 48, 15, 42, 44, 47, & + 10, 12, 16, 44, 46, 17, 38, 42, 44, 18, 35, 42, & + 44, 19, 42, 44, 46, 47, 20, 43, 44, 21, 30, 33, & + 38, 43, 44, 4, 22, 43, 46, 47, 48, 10, 12, 23, & + 44, 48, 20, 24, 27, 30, 31, 33, 34, 37, 43, 44, & + 48, 13, 25, 28, 30, 33, 36, 40, 41, 43, 44, 46, & + 48, 11, 23, 26, 31, 34, 37, 42, 44, 47, 48, 16, & + 23, 27, 43, 44, 46, 48, 28, 39, 40, 42, 44, 28, & + 29, 33, 39, 40, 41, 42, 43, 44, 46, 48, 30, 43, & + 44, 48, 17, 20, 21, 27, 30, 31, 33, 36, 38, 39, & + 42, 43, 44, 46, 48, 10, 12, 20, 23, 27, 28, 30, & + 32, 33, 34, 39, 40, 41, 42, 43, 44, 46, 48, 33, & + 43, 44, 48, 12, 27, 28, 30, 33, 34, 39, 40, 42, & + 43, 44, 46, 48, 8, 18, 28, 30, 33, 35, 39, 40, & + 41, 42, 43, 44, 46, 48, 30, 33, 36, 41, 42, 43, & + 44, 46, 48, 6, 18, 20, 27, 28, 30, 33, 35, 36, & + 37, 39, 40, 41, 42, 43, 44, 46, 48, 17, 29, 30, & + 33, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 48 / + + data( lu_icol_v(i), i = 253, 459 ) / & + 29, 33, 39, 40, 41, 42, 43, 44, 46, 48, 13, 25, & + 28, 30, 33, 36, 39, 40, 41, 42, 43, 44, 46, 48, & + 14, 16, 23, 36, 40, 41, 42, 43, 44, 46, 47, 48, & + 5, 6, 7, 10, 12, 15, 16, 17, 18, 20, 21, 23, & + 24, 27, 28, 30, 31, 32, 33, 34, 35, 36, 37, 38, & + 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 20, 22, & + 27, 30, 33, 42, 43, 44, 45, 46, 47, 48, 4, 5, & + 6, 7, 8, 10, 12, 13, 15, 17, 18, 19, 20, 21, & + 23, 24, 25, 26, 27, 28, 29, 30, 31, 33, 34, 35, & + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, & + 48, 9, 27, 29, 30, 33, 34, 37, 39, 40, 41, 42, & + 43, 44, 45, 46, 47, 48, 16, 19, 22, 32, 33, 34, & + 35, 36, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, & + 48, 9, 11, 14, 15, 16, 19, 22, 23, 26, 31, 32, & + 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, & + 45, 46, 47, 48, 11, 22, 23, 26, 30, 31, 32, 33, & + 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, & + 46, 47, 48 / + + data lu_crow_v / & + 1, 4, 8, 14, 16, 18, 20, 23, 26, 29, 31, 34, & + 36, 40, 45, 49, 54, 58, 62, 67, 70, 76, 82, 87, & + 98,110,120,127,132,143,147,162,180,184,197,211, & + 220,238,253,263,277,289,323,335,374,391,410,437, & + 460 / + + data lu_diag_v / & + 1, 4, 8, 14, 16, 18, 20, 23, 26, 29, 31, 34, & + 37, 40, 45, 51, 54, 58, 62, 67, 70, 77, 84, 88, & + 99,112,122,127,133,143,152,169,180,189,202,213, & + 229,243,255,270,282,316,329,369,387,407,435,459, & + 460 / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r02_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r02_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r02_dydt, & + cbmz_v02r02_jacob, & + cbmz_v02r02_decomp, & + cbmz_v02r02_solve ) + + return + end subroutine cbmz_v02r02_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r02 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r02_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ihcooh_kpp + parameter ( ihcooh_kpp = 2 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 3 ) + integer io1d_kpp + parameter ( io1d_kpp = 4 ) + integer iso2_kpp + parameter ( iso2_kpp = 5 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 6 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 7 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 8 ) + integer ipan_kpp + parameter ( ipan_kpp = 9 ) + integer itol_kpp + parameter ( itol_kpp = 10 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 11 ) + integer ixyl_kpp + parameter ( ixyl_kpp = 12 ) + integer ipar_kpp + parameter ( ipar_kpp = 13 ) + integer icro_kpp + parameter ( icro_kpp = 14 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 15 ) + integer ito2_kpp + parameter ( ito2_kpp = 16 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 17 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 18 ) + integer ihono_kpp + parameter ( ihono_kpp = 19 ) + integer ieth_kpp + parameter ( ieth_kpp = 20 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 21 ) + integer io3p_kpp + parameter ( io3p_kpp = 22 ) + integer icres_kpp + parameter ( icres_kpp = 23 ) + integer ico_kpp + parameter ( ico_kpp = 24 ) + integer ixpar_kpp + parameter ( ixpar_kpp = 25 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 26 ) + integer iopen_kpp + parameter ( iopen_kpp = 27 ) + integer irooh_kpp + parameter ( irooh_kpp = 28 ) + integer iaone_kpp + parameter ( iaone_kpp = 29 ) + integer iolet_kpp + parameter ( iolet_kpp = 30 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 31 ) + integer ixo2_kpp + parameter ( ixo2_kpp = 32 ) + integer iolei_kpp + parameter ( iolei_kpp = 33 ) + integer imgly_kpp + parameter ( imgly_kpp = 34 ) + integer iethp_kpp + parameter ( iethp_kpp = 35 ) + integer inap_kpp + parameter ( inap_kpp = 36 ) + integer iald2_kpp + parameter ( iald2_kpp = 37 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 38 ) + integer iano2_kpp + parameter ( iano2_kpp = 39 ) + integer iro2_kpp + parameter ( iro2_kpp = 40 ) + integer ionit_kpp + parameter ( ionit_kpp = 41 ) + integer iho2_kpp + parameter ( iho2_kpp = 42 ) + integer io3_kpp + parameter ( io3_kpp = 43 ) + integer ioh_kpp + parameter ( ioh_kpp = 44 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 45 ) + integer ino_kpp + parameter ( ino_kpp = 46 ) + integer ino2_kpp + parameter ( ino2_kpp = 47 ) + integer ino3_kpp + parameter ( ino3_kpp = 48 ) + +! indexes declaration for fixed species + + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + nyy = nvar_r02_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ihcooh_kpp) = cbox(ihcooh_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(itol_kpp) = cbox(itol_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ixyl_kpp) = cbox(ixyl_z) + yy(ipar_kpp) = cbox(ipar_z) + yy(icro_kpp) = cbox(icro_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ito2_kpp) = cbox(ito2_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ieth_kpp) = cbox(ieth_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(icres_kpp) = cbox(icres_z) + yy(ico_kpp) = cbox(ico_z) + yy(ixpar_kpp) = cbox(ixpar_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(iopen_kpp) = cbox(iopen_z) + yy(irooh_kpp) = cbox(irooh_z) + yy(iaone_kpp) = cbox(iaone_z) + yy(iolet_kpp) = cbox(iolet_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(ixo2_kpp) = cbox(ixo2_z) + yy(iolei_kpp) = cbox(iolei_z) + yy(imgly_kpp) = cbox(imgly_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(inap_kpp) = cbox(inap_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(iano2_kpp) = cbox(iano2_z) + yy(iro2_kpp) = cbox(iro2_z) + yy(ionit_kpp) = cbox(ionit_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(io3_kpp) = cbox(io3_z) + yy(ioh_kpp) = cbox(ioh_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(ino_kpp) = cbox(ino_z) + yy(ino2_kpp) = cbox(ino2_z) + yy(ino3_kpp) = cbox(ino3_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ihcooh_z) = yy(ihcooh_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(itol_z) = yy(itol_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ixyl_z) = yy(ixyl_kpp) + cbox(ipar_z) = yy(ipar_kpp) + cbox(icro_z) = yy(icro_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ito2_z) = yy(ito2_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ieth_z) = yy(ieth_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(icres_z) = yy(icres_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(ixpar_z) = yy(ixpar_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(iopen_z) = yy(iopen_kpp) + cbox(irooh_z) = yy(irooh_kpp) + cbox(iaone_z) = yy(iaone_kpp) + cbox(iolet_z) = yy(iolet_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(ixo2_z) = yy(ixo2_kpp) + cbox(iolei_z) = yy(iolei_kpp) + cbox(imgly_z) = yy(imgly_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(inap_z) = yy(inap_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(iano2_z) = yy(iano2_kpp) + cbox(iro2_z) = yy(iro2_kpp) + cbox(ionit_z) = yy(ionit_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(ioh_z) = yy(ioh_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(ino2_z) = yy(ino2_kpp) + cbox(ino3_z) = yy(ino3_kpp) + + return + end subroutine cbmz_v02r02_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r02 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + rconst(75) = (rk_m2(1)) + rconst(76) = (rk_m2(5)) + rconst(77) = (rk_m2(6)) + rconst(78) = (rk_m2(7)) + rconst(79) = (rk_m2(8)) + rconst(80) = (rk_m2(9)) + rconst(81) = (rk_m2(10)) + rconst(82) = (rk_m2(11)) + rconst(83) = (rk_m2(12)) + rconst(84) = (rk_m2(13)) + rconst(85) = (rk_m2(14)) + rconst(86) = (rk_m2(15)) + rconst(87) = (rk_m2(16)) + rconst(88) = (rk_m2(17)) + rconst(89) = (rk_m2(18)) + rconst(90) = (rk_m2(19)) + rconst(91) = (rk_m2(20)) + rconst(92) = (rk_m2(21)) + rconst(93) = (rk_m2(22)) + rconst(94) = (rk_m2(23)) + rconst(95) = (rk_m2(24)) + rconst(96) = (rk_m2(25)) + rconst(97) = (rk_m2(26)) + rconst(98) = (rk_m2(27)) + rconst(99) = (rk_m2(28)) + rconst(100) = (rk_m2(29)) + rconst(101) = (rk_m2(30)) + rconst(102) = (rk_m2(33)) + rconst(103) = (rk_m2(35)) + rconst(104) = (rk_m2(36)) + rconst(105) = (rk_m2(37)) + rconst(106) = (rk_m2(38)) + rconst(107) = (rk_m2(40)) + rconst(108) = (rk_m2(41)) + rconst(109) = (rk_m2(42)) + rconst(110) = (rk_m2(43)) + rconst(111) = (rk_m2(45)) + rconst(112) = (rk_m2(46)) + rconst(113) = (rk_m2(47)) + rconst(114) = (rk_m2(48)) + rconst(115) = (rk_m2(50)) + rconst(116) = (rk_m2(51)) + rconst(117) = (rk_m2(52)) + rconst(118) = (rk_m2(53)) + return + end subroutine cbmz_v02r02_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r02 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r02_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r02_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r02_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r02_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(47) + a(2) = rconst(2)*v(48) + a(3) = rconst(3)*v(19) + a(4) = rconst(4)*v(26) + a(5) = rconst(5)*v(15) + a(6) = rconst(6)*v(11) + a(7) = rconst(7)*v(43) + a(8) = rconst(8)*v(43) + a(9) = rconst(9)*v(7) + a(10) = rconst(10)*v(4)*f(4) + a(11) = rconst(11)*v(4)*f(5) + a(12) = rconst(12)*v(4)*f(2) + a(13) = rconst(13)*v(22)*f(4) + a(14) = rconst(14)*v(22)*v(43) + a(15) = rconst(15)*v(22)*v(47) + a(16) = rconst(16)*v(22)*v(47) + a(17) = rconst(17)*v(22)*v(46) + a(18) = rconst(18)*v(43)*v(46) + a(19) = rconst(19)*v(43)*v(47) + a(20) = rconst(20)*v(43)*v(44) + a(21) = rconst(21)*v(42)*v(43) + a(22) = rconst(22)*v(44)*f(3) + a(23) = rconst(23)*v(44)*v(46) + a(24) = rconst(24)*v(44)*v(47) + a(25) = rconst(25)*v(44)*v(48) + a(26) = rconst(26)*v(19)*v(44) + a(27) = rconst(27)*v(26)*v(44) + a(28) = rconst(28)*v(15)*v(44) + a(29) = rconst(29)*v(42)*v(44) + a(30) = rconst(30)*v(7)*v(44) + a(31) = rconst(31)*v(42)*v(42) + a(32) = rconst(32)*v(42)*v(42)*f(2) + a(33) = rconst(33)*v(42)*v(46) + a(34) = rconst(34)*v(42)*v(47) + a(35) = rconst(35)*v(42)*v(47) + a(36) = rconst(36)*v(15) + a(37) = rconst(37)*v(46)*v(48) + a(38) = rconst(38)*v(47)*v(48) + a(39) = rconst(39)*v(47)*v(48) + a(40) = rconst(40)*v(48)*v(48) + a(41) = rconst(41)*v(42)*v(48) + a(42) = rconst(42)*v(11)*f(2) + a(43) = rconst(43)*v(11) + a(44) = rconst(44)*v(24)*v(44) + a(45) = rconst(45)*v(5)*v(44) + a(46) = rconst(46)*v(44)*f(1) + a(47) = rconst(47)*v(8)*v(44) + a(48) = rconst(48)*v(21)*v(44) + a(49) = rconst(49)*v(31) + a(50) = rconst(50)*v(31) + a(51) = rconst(51)*v(31)*v(44) + a(52) = rconst(52)*v(31)*v(48) + a(53) = rconst(53)*v(17) + a(54) = rconst(54)*v(18) + a(55) = rconst(55)*v(17)*v(44) + a(56) = rconst(56)*v(18)*v(44) + a(57) = rconst(57)*v(38)*v(46) + a(58) = rconst(58)*v(35)*v(46) + a(59) = rconst(59)*v(38)*v(48) + a(60) = rconst(60)*v(35)*v(48) + a(61) = rconst(61)*v(38)*v(42) + a(62) = rconst(62)*v(35)*v(42) + a(63) = rconst(63)*v(38) + a(64) = rconst(64)*v(35) + a(65) = rconst(65)*v(6)*v(44) + a(66) = rconst(66)*v(37) + a(67) = rconst(67)*v(37)*v(44) + a(68) = rconst(68)*v(37)*v(48) + a(69) = rconst(69)*v(45)*v(47) + a(70) = rconst(70)*v(9) + a(71) = rconst(71)*v(45)*v(46) + a(72) = rconst(72)*v(45)*v(48) + a(73) = rconst(73)*v(42)*v(45) + a(74) = rconst(74)*v(45) + a(75) = rconst(75)*v(13)*v(44) + a(76) = rconst(76)*v(29) + a(77) = rconst(77)*v(29)*v(44) + a(78) = rconst(78)*v(34) + a(79) = rconst(79)*v(34)*v(44) + a(80) = rconst(80)*v(34)*v(48) + a(81) = rconst(81)*v(20)*v(43) + a(82) = rconst(82)*v(20)*v(44) + a(83) = rconst(83)*v(30)*v(43) + a(84) = rconst(84)*v(33)*v(43) + a(85) = rconst(85)*v(30)*v(44) + a(86) = rconst(86)*v(33)*v(44) + a(87) = rconst(87)*v(30)*v(48) + a(88) = rconst(88)*v(33)*v(48) + a(89) = rconst(89)*v(10)*v(44) + a(90) = rconst(90)*v(12)*v(44) + a(91) = rconst(91)*v(16)*v(46) + a(92) = rconst(92)*v(23)*v(44) + a(93) = rconst(93)*v(23)*v(48) + a(94) = rconst(94)*v(14)*v(47) + a(95) = rconst(95)*v(27)*v(44) + a(96) = rconst(96)*v(27) + a(97) = rconst(97)*v(27)*v(43) + a(98) = rconst(98)*v(28) + a(99) = rconst(99)*v(28)*v(44) + a(100) = rconst(100)*v(41)*v(44) + a(101) = rconst(101)*v(41) + a(102) = rconst(102)*v(40)*v(46) + a(103) = rconst(103)*v(39)*v(46) + a(104) = rconst(104)*v(36)*v(46) + a(105) = rconst(105)*v(32)*v(46) + a(106) = rconst(106)*v(40)*v(48) + a(107) = rconst(107)*v(39)*v(48) + a(108) = rconst(108)*v(36)*v(48) + a(109) = rconst(109)*v(32)*v(48) + a(110) = rconst(110)*v(40)*v(42) + a(111) = rconst(111)*v(39)*v(42) + a(112) = rconst(112)*v(36)*v(42) + a(113) = rconst(113)*v(32)*v(42) + a(114) = rconst(114)*v(40) + a(115) = rconst(115)*v(39) + a(116) = rconst(116)*v(36) + a(117) = rconst(117)*v(32) + a(118) = rconst(118)*v(13)*v(25) + +! aggregate function + a_var(1) = a(45) + a_var(2) = 0.52*a(81)+0.22*a(83) + a_var(3) = 0.4*a(73)+0.09*a(83)+0.16*a(84) + a_var(4) = a(8)-a(10)-a(11)-a(12) + a_var(5) = -a(45) + a_var(6) = -a(65) + a_var(7) = -a(9)-a(30)+a(31)+a(32) + a_var(8) = -a(47)+0.2*a(64) + a_var(9) = a(69)-a(70) + a_var(10) = -a(89) + a_var(11) = -a(6)+a(39)-a(42)-a(43) + a_var(12) = -a(90) + a_var(13) = -a(75)+1.1*a(90)-a(118) + a_var(14) = 0.4*a(92)+a(93)-a(94) + a_var(15) = -a(5)-a(28)+a(34)-a(36) + a_var(16) = 0.8*a(89)+0.45*a(90)-a(91) + a_var(17) = -a(53)-a(55)+a(61) + a_var(18) = -a(54)-a(56)+a(62) + a_var(19) = -a(3)+a(23)-a(26)+a(35) + a_var(20) = -a(81)-a(82) + a_var(21) = -a(48)+0.34*a(63)+0.03*a(83)+0.04*a(84) + a_var(22) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17) + a_var(23) = 0.12*a(89)+0.05*a(90)-a(92)-a(93) + a_var(24) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66)+a(78)+a(80) & + +0.24*a(81)+0.31*a(83)+0.3*a(84)+2*a(95)+a(96)+0.69 & + *a(97) + a_var(25) = 1.06*a(83)+2.26*a(84)+a(85)+2.23*a(86)+1.98*a(98) & + +0.42*a(99)+1.98*a(101)+1.68*a(102)+a(104)+1.98 & + *a(106)+a(108)+1.25*a(114)+a(116)-a(118) + a_var(26) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) & + +a(80)+a(93) + a_var(27) = 0.95*a(91)+0.3*a(92)-a(95)-a(96)-a(97) + a_var(28) = -a(98)-a(99)+a(110)+a(111) + a_var(29) = -a(76)-a(77)+0.07*a(84)+0.23*a(86)+0.74*a(98)+0.74 & + *a(101)+0.62*a(102)+0.74*a(106)+0.57*a(114)+0.15 & + *a(115) + a_var(30) = -a(83)-a(85)-a(87) + a_var(31) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63)+a(81)+1.56*a(82)+0.57*a(83)+a(85) & + +a(95)+0.7*a(97)+a(103)+0.5*a(104)+a(107)+0.5*a(108) & + +0.7*a(115)+0.5*a(116) + a_var(32) = a(79)+a(82)+a(85)+a(86)+0.08*a(89)+0.5*a(90)+0.6 & + *a(92)+a(95)+0.03*a(97)+0.4*a(98)+0.4*a(101)+0.34 & + *a(102)-a(105)+0.4*a(106)-a(109)-a(113)+0.24*a(114) & + -a(117) + a_var(33) = -a(84)-a(86)-a(88) + a_var(34) = -a(78)-a(79)-a(80)+0.04*a(83)+0.07*a(84)+0.8*a(90) & + +0.2*a(97)+0.19*a(99)+0.15*a(115) + a_var(35) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64)+0.06*a(83) & + +0.05*a(84)+0.1*a(98)+0.1*a(101)+0.08*a(102)+0.1 & + *a(106)+0.06*a(114) + a_var(36) = a(87)+a(88)+a(100)-a(104)-a(108)-a(112)-a(116) + a_var(37) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68)+0.22*a(82)+0.47*a(83)+1.03*a(84)+a(85) & + +1.77*a(86)+0.03*a(97)+0.3*a(98)+0.04*a(99)+0.3 & + *a(101)+0.25*a(102)+0.5*a(104)+0.3*a(106)+0.5*a(108) & + +0.21*a(114)+0.5*a(116) + a_var(38) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74)+a(76)+0.07*a(83)+0.1*a(84) + a_var(39) = a(77)+0.11*a(84)-a(103)-a(107)-a(111)-a(115) + a_var(40) = a(75)+0.03*a(83)+0.09*a(84)+0.77*a(99)-a(102)-a(106) & + -a(110)-a(114) + a_var(41) = 0.05*a(91)+a(94)-a(100)-a(101)+0.16*a(102)+0.5 & + *a(104)+0.5*a(108)+a(112)+0.5*a(116) + a_var(42) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73)+a(78)+0.22*a(81)+a(82)+0.26*a(83)+0.22 & + *a(84)+a(85)+a(86)+0.2*a(89)+0.55*a(90)+0.95*a(91) & + +0.6*a(92)+2*a(95)+a(96)+0.76*a(97)+0.9*a(98)+0.9 & + *a(101)+0.76*a(102)+0.5*a(104)+0.9*a(106)+0.5*a(108) & + -a(110)-a(111)-a(112)-a(113)+0.54*a(114) + a_var(43) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73)-a(81)-a(83)-a(84)-a(97) + a_var(44) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67)-a(75)-a(77) & + -a(79)+0.12*a(81)-a(82)+0.33*a(83)+0.6*a(84)-a(85) & + -a(86)-a(89)-a(90)-a(92)-a(95)+0.08*a(97)+a(98)-0.77 & + *a(99)-a(100) + a_var(45) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) & + +a(76)+a(78)+a(79)+a(80)+0.13*a(83)+0.19*a(84)+a(95) & + +a(96)+0.62*a(97)+a(103)+a(107)+0.7*a(115) + a_var(46) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71)-a(91)-a(102)-a(103) & + -a(104)-a(105) + a_var(47) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72)+0.95 & + *a(91)-a(94)+a(101)+0.84*a(102)+a(103)+1.5*a(104) & + +a(105)+a(106)+a(107)+1.5*a(108)+a(109)+0.5*a(116) + a_var(48) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) & + -a(80)-a(87)-a(88)-a(93)-a(106)-a(107)-a(108)-a(109) + return + end subroutine cbmz_v02r02_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r02 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r02_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r02_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r02_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r02_kpp,nvar_r02_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,47) = rconst(1) + b(2,48) = rconst(2) + b(3,19) = rconst(3) + b(4,26) = rconst(4) + b(5,15) = rconst(5) + b(6,11) = rconst(6) + b(7,43) = rconst(7) + b(8,43) = rconst(8) + b(9,7) = rconst(9) + b(10,4) = rconst(10)*f(4) + b(11,4) = rconst(11)*f(5) + b(12,4) = rconst(12)*f(2) + b(13,22) = rconst(13)*f(4) + b(14,22) = rconst(14)*v(43) + b(14,43) = rconst(14)*v(22) + b(15,22) = rconst(15)*v(47) + b(15,47) = rconst(15)*v(22) + b(16,22) = rconst(16)*v(47) + b(16,47) = rconst(16)*v(22) + b(17,22) = rconst(17)*v(46) + b(17,46) = rconst(17)*v(22) + b(18,43) = rconst(18)*v(46) + b(18,46) = rconst(18)*v(43) + b(19,43) = rconst(19)*v(47) + b(19,47) = rconst(19)*v(43) + b(20,43) = rconst(20)*v(44) + b(20,44) = rconst(20)*v(43) + b(21,42) = rconst(21)*v(43) + b(21,43) = rconst(21)*v(42) + b(22,44) = rconst(22)*f(3) + b(23,44) = rconst(23)*v(46) + b(23,46) = rconst(23)*v(44) + b(24,44) = rconst(24)*v(47) + b(24,47) = rconst(24)*v(44) + b(25,44) = rconst(25)*v(48) + b(25,48) = rconst(25)*v(44) + b(26,19) = rconst(26)*v(44) + b(26,44) = rconst(26)*v(19) + b(27,26) = rconst(27)*v(44) + b(27,44) = rconst(27)*v(26) + b(28,15) = rconst(28)*v(44) + b(28,44) = rconst(28)*v(15) + b(29,42) = rconst(29)*v(44) + b(29,44) = rconst(29)*v(42) + b(30,7) = rconst(30)*v(44) + b(30,44) = rconst(30)*v(7) + b(31,42) = rconst(31)*2*v(42) + b(32,42) = rconst(32)*2*v(42)*f(2) + b(33,42) = rconst(33)*v(46) + b(33,46) = rconst(33)*v(42) + b(34,42) = rconst(34)*v(47) + b(34,47) = rconst(34)*v(42) + b(35,42) = rconst(35)*v(47) + b(35,47) = rconst(35)*v(42) + b(36,15) = rconst(36) + b(37,46) = rconst(37)*v(48) + b(37,48) = rconst(37)*v(46) + b(38,47) = rconst(38)*v(48) + b(38,48) = rconst(38)*v(47) + b(39,47) = rconst(39)*v(48) + b(39,48) = rconst(39)*v(47) + b(40,48) = rconst(40)*2*v(48) + b(41,42) = rconst(41)*v(48) + b(41,48) = rconst(41)*v(42) + b(42,11) = rconst(42)*f(2) + b(43,11) = rconst(43) + b(44,24) = rconst(44)*v(44) + b(44,44) = rconst(44)*v(24) + b(45,5) = rconst(45)*v(44) + b(45,44) = rconst(45)*v(5) + b(46,44) = rconst(46)*f(1) + b(47,8) = rconst(47)*v(44) + b(47,44) = rconst(47)*v(8) + b(48,21) = rconst(48)*v(44) + b(48,44) = rconst(48)*v(21) + b(49,31) = rconst(49) + b(50,31) = rconst(50) + b(51,31) = rconst(51)*v(44) + b(51,44) = rconst(51)*v(31) + b(52,31) = rconst(52)*v(48) + b(52,48) = rconst(52)*v(31) + b(53,17) = rconst(53) + b(54,18) = rconst(54) + b(55,17) = rconst(55)*v(44) + b(55,44) = rconst(55)*v(17) + b(56,18) = rconst(56)*v(44) + b(56,44) = rconst(56)*v(18) + b(57,38) = rconst(57)*v(46) + b(57,46) = rconst(57)*v(38) + b(58,35) = rconst(58)*v(46) + b(58,46) = rconst(58)*v(35) + b(59,38) = rconst(59)*v(48) + b(59,48) = rconst(59)*v(38) + b(60,35) = rconst(60)*v(48) + b(60,48) = rconst(60)*v(35) + b(61,38) = rconst(61)*v(42) + b(61,42) = rconst(61)*v(38) + b(62,35) = rconst(62)*v(42) + b(62,42) = rconst(62)*v(35) + b(63,38) = rconst(63) + b(64,35) = rconst(64) + b(65,6) = rconst(65)*v(44) + b(65,44) = rconst(65)*v(6) + b(66,37) = rconst(66) + b(67,37) = rconst(67)*v(44) + b(67,44) = rconst(67)*v(37) + b(68,37) = rconst(68)*v(48) + b(68,48) = rconst(68)*v(37) + b(69,45) = rconst(69)*v(47) + b(69,47) = rconst(69)*v(45) + b(70,9) = rconst(70) + b(71,45) = rconst(71)*v(46) + b(71,46) = rconst(71)*v(45) + b(72,45) = rconst(72)*v(48) + b(72,48) = rconst(72)*v(45) + b(73,42) = rconst(73)*v(45) + b(73,45) = rconst(73)*v(42) + b(74,45) = rconst(74) + b(75,13) = rconst(75)*v(44) + b(75,44) = rconst(75)*v(13) + b(76,29) = rconst(76) + b(77,29) = rconst(77)*v(44) + b(77,44) = rconst(77)*v(29) + b(78,34) = rconst(78) + b(79,34) = rconst(79)*v(44) + b(79,44) = rconst(79)*v(34) + b(80,34) = rconst(80)*v(48) + b(80,48) = rconst(80)*v(34) + b(81,20) = rconst(81)*v(43) + b(81,43) = rconst(81)*v(20) + b(82,20) = rconst(82)*v(44) + b(82,44) = rconst(82)*v(20) + b(83,30) = rconst(83)*v(43) + b(83,43) = rconst(83)*v(30) + b(84,33) = rconst(84)*v(43) + b(84,43) = rconst(84)*v(33) + b(85,30) = rconst(85)*v(44) + b(85,44) = rconst(85)*v(30) + b(86,33) = rconst(86)*v(44) + b(86,44) = rconst(86)*v(33) + b(87,30) = rconst(87)*v(48) + b(87,48) = rconst(87)*v(30) + b(88,33) = rconst(88)*v(48) + b(88,48) = rconst(88)*v(33) + b(89,10) = rconst(89)*v(44) + b(89,44) = rconst(89)*v(10) + b(90,12) = rconst(90)*v(44) + b(90,44) = rconst(90)*v(12) + b(91,16) = rconst(91)*v(46) + b(91,46) = rconst(91)*v(16) + b(92,23) = rconst(92)*v(44) + b(92,44) = rconst(92)*v(23) + b(93,23) = rconst(93)*v(48) + b(93,48) = rconst(93)*v(23) + b(94,14) = rconst(94)*v(47) + b(94,47) = rconst(94)*v(14) + b(95,27) = rconst(95)*v(44) + b(95,44) = rconst(95)*v(27) + b(96,27) = rconst(96) + b(97,27) = rconst(97)*v(43) + b(97,43) = rconst(97)*v(27) + b(98,28) = rconst(98) + b(99,28) = rconst(99)*v(44) + b(99,44) = rconst(99)*v(28) + b(100,41) = rconst(100)*v(44) + b(100,44) = rconst(100)*v(41) + b(101,41) = rconst(101) + b(102,40) = rconst(102)*v(46) + b(102,46) = rconst(102)*v(40) + b(103,39) = rconst(103)*v(46) + b(103,46) = rconst(103)*v(39) + b(104,36) = rconst(104)*v(46) + b(104,46) = rconst(104)*v(36) + b(105,32) = rconst(105)*v(46) + b(105,46) = rconst(105)*v(32) + b(106,40) = rconst(106)*v(48) + b(106,48) = rconst(106)*v(40) + b(107,39) = rconst(107)*v(48) + b(107,48) = rconst(107)*v(39) + b(108,36) = rconst(108)*v(48) + b(108,48) = rconst(108)*v(36) + b(109,32) = rconst(109)*v(48) + b(109,48) = rconst(109)*v(32) + b(110,40) = rconst(110)*v(42) + b(110,42) = rconst(110)*v(40) + b(111,39) = rconst(111)*v(42) + b(111,42) = rconst(111)*v(39) + b(112,36) = rconst(112)*v(42) + b(112,42) = rconst(112)*v(36) + b(113,32) = rconst(113)*v(42) + b(113,42) = rconst(113)*v(32) + b(114,40) = rconst(114) + b(115,39) = rconst(115) + b(116,36) = rconst(116) + b(117,32) = rconst(117) + b(118,13) = rconst(118)*v(25) + b(118,25) = rconst(118)*v(13) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,5) + jvs(3) = b(45,44) + jvs(4) = 0 + jvs(5) = 0.52*b(81,20) + jvs(6) = 0.22*b(83,30) + jvs(7) = 0.52*b(81,43)+0.22*b(83,43) + jvs(8) = 0 + jvs(9) = 0.09*b(83,30) + jvs(10) = 0.16*b(84,33) + jvs(11) = 0.4*b(73,42) + jvs(12) = 0.09*b(83,43)+0.16*b(84,43) + jvs(13) = 0.4*b(73,45) + jvs(14) = -b(10,4)-b(11,4)-b(12,4) + jvs(15) = b(8,43) + jvs(16) = -b(45,5) + jvs(17) = -b(45,44) + jvs(18) = -b(65,6) + jvs(19) = -b(65,44) + jvs(20) = -b(9,7)-b(30,7) + jvs(21) = b(31,42)+b(32,42) + jvs(22) = -b(30,44) + jvs(23) = -b(47,8) + jvs(24) = 0.2*b(64,35) + jvs(25) = -b(47,44) + jvs(26) = -b(70,9) + jvs(27) = b(69,45) + jvs(28) = b(69,47) + jvs(29) = -b(89,10) + jvs(30) = -b(89,44) + jvs(31) = -b(6,11)-b(42,11)-b(43,11) + jvs(32) = b(39,47) + jvs(33) = b(39,48) + jvs(34) = -b(90,12) + jvs(35) = -b(90,44) + jvs(36) = 1.1*b(90,12) + jvs(37) = -b(75,13)-b(118,13) + jvs(38) = -b(118,25) + jvs(39) = -b(75,44)+1.1*b(90,44) + jvs(40) = -b(94,14) + jvs(41) = 0.4*b(92,23)+b(93,23) + jvs(42) = 0.4*b(92,44) + jvs(43) = -b(94,47) + jvs(44) = b(93,48) + jvs(45) = -b(5,15)-b(28,15)-b(36,15) + jvs(46) = b(34,42) + jvs(47) = -b(28,44) + jvs(48) = b(34,47) + jvs(49) = 0.8*b(89,10) + jvs(50) = 0.45*b(90,12) + jvs(51) = -b(91,16) + jvs(52) = 0.8*b(89,44)+0.45*b(90,44) + jvs(53) = -b(91,46) + jvs(54) = -b(53,17)-b(55,17) + jvs(55) = b(61,38) + jvs(56) = b(61,42) + jvs(57) = -b(55,44) + jvs(58) = -b(54,18)-b(56,18) + jvs(59) = b(62,35) + jvs(60) = b(62,42) + jvs(61) = -b(56,44) + jvs(62) = -b(3,19)-b(26,19) + jvs(63) = b(35,42) + jvs(64) = b(23,44)-b(26,44) + jvs(65) = b(23,46) + jvs(66) = b(35,47) + jvs(67) = -b(81,20)-b(82,20) + jvs(68) = -b(81,43) + jvs(69) = -b(82,44) + jvs(70) = -b(48,21) + jvs(71) = 0.03*b(83,30) + jvs(72) = 0.04*b(84,33) + jvs(73) = 0.34*b(63,38) + jvs(74) = 0.03*b(83,43)+0.04*b(84,43) + jvs(75) = -b(48,44) + jvs(76) = b(10,4)+b(11,4) + jvs(77) = -b(13,22)-b(14,22)-b(15,22)-b(16,22)-b(17,22) + jvs(78) = b(7,43)-b(14,43) + jvs(79) = -b(17,46) + jvs(80) = b(1,47)-b(15,47)-b(16,47) + jvs(81) = 0.89*b(2,48) + jvs(82) = 0.12*b(89,10) + jvs(83) = 0.05*b(90,12) + jvs(84) = -b(92,23)-b(93,23) + jvs(85) = 0.12*b(89,44)+0.05*b(90,44)-b(92,44) + jvs(86) = -b(93,48) + jvs(87) = 0.24*b(81,20) + jvs(88) = -b(44,24) + jvs(89) = 2*b(95,27)+b(96,27)+0.69*b(97,27) + jvs(90) = 0.31*b(83,30) + jvs(91) = b(49,31)+b(50,31)+b(51,31)+b(52,31) + jvs(92) = 0.3*b(84,33) + jvs(93) = b(78,34)+b(80,34) + jvs(94) = b(66,37) + jvs(95) = 0.24*b(81,43)+0.31*b(83,43)+0.3*b(84,43)+0.69*b(97,43) + jvs(96) = -b(44,44)+b(51,44)+2*b(95,44) + jvs(97) = b(52,48)+b(80,48) + jvs(98) = -b(118,13) + jvs(99) = -b(118,25) + jvs(100) = 1.98*b(98,28)+0.42*b(99,28) + jvs(101) = 1.06*b(83,30)+b(85,30) + jvs(102) = 2.26*b(84,33)+2.23*b(86,33) + jvs(103) = b(104,36)+b(108,36)+b(116,36) + jvs(104) = 1.68*b(102,40)+1.98*b(106,40)+1.25*b(114,40) + jvs(105) = 1.98*b(101,41) + jvs(106) = 1.06*b(83,43)+2.26*b(84,43) + jvs(107) = b(85,44)+2.23*b(86,44)+0.42*b(99,44) + jvs(108) = 1.68*b(102,46)+b(104,46) + jvs(109) = 1.98*b(106,48)+b(108,48) + jvs(110) = 2*b(42,11) + jvs(111) = b(93,23) + jvs(112) = -b(4,26)-b(27,26) + jvs(113) = b(52,31) + jvs(114) = b(80,34) + jvs(115) = b(68,37) + jvs(116) = 0.3*b(41,42) + jvs(117) = b(24,44)-b(27,44) + jvs(118) = b(24,47) + jvs(119) = 0.3*b(41,48)+b(52,48)+b(68,48)+b(80,48)+b(93,48) + jvs(120) = 0.95*b(91,16) + jvs(121) = 0.3*b(92,23) + jvs(122) = -b(95,27)-b(96,27)-b(97,27) + jvs(123) = -b(97,43) + jvs(124) = 0.3*b(92,44)-b(95,44) + jvs(125) = 0.95*b(91,46) + jvs(126) = 0 + jvs(127) = -b(98,28)-b(99,28) + jvs(128) = b(111,39) + jvs(129) = b(110,40) + jvs(130) = b(110,42)+b(111,42) + jvs(131) = -b(99,44) + jvs(132) = 0.74*b(98,28) + jvs(133) = -b(76,29)-b(77,29) + jvs(134) = 0.07*b(84,33)+0.23*b(86,33) + jvs(135) = 0.15*b(115,39) + jvs(136) = 0.62*b(102,40)+0.74*b(106,40)+0.57*b(114,40) + jvs(137) = 0.74*b(101,41) + jvs(138) = 0 + jvs(139) = 0.07*b(84,43) + jvs(140) = -b(77,44)+0.23*b(86,44) + jvs(141) = 0.62*b(102,46) + jvs(142) = 0.74*b(106,48) + jvs(143) = -b(83,30)-b(85,30)-b(87,30) + jvs(144) = -b(83,43) + jvs(145) = -b(85,44) + jvs(146) = -b(87,48) + jvs(147) = b(53,17)+0.3*b(55,17) + jvs(148) = b(81,20)+1.56*b(82,20) + jvs(149) = b(48,21) + jvs(150) = b(95,27)+0.7*b(97,27) + jvs(151) = 0.57*b(83,30)+b(85,30) + jvs(152) = -b(49,31)-b(50,31)-b(51,31)-b(52,31) + jvs(153) = 0 + jvs(154) = 0.5*b(104,36)+0.5*b(108,36)+0.5*b(116,36) + jvs(155) = b(57,38)+b(59,38)+0.66*b(63,38) + jvs(156) = b(103,39)+b(107,39)+0.7*b(115,39) + jvs(157) = 0 + jvs(158) = b(81,43)+0.57*b(83,43)+0.7*b(97,43) + jvs(159) = b(48,44)-b(51,44)+0.3*b(55,44)+1.56*b(82,44)+b(85,44) & + +b(95,44) + jvs(160) = b(57,46)+b(103,46)+0.5*b(104,46) + jvs(161) = -b(52,48)+b(59,48)+b(107,48)+0.5*b(108,48) + jvs(162) = 0.08*b(89,10) + jvs(163) = 0.5*b(90,12) + jvs(164) = b(82,20) + jvs(165) = 0.6*b(92,23) + jvs(166) = b(95,27)+0.03*b(97,27) + jvs(167) = 0.4*b(98,28) + jvs(168) = b(85,30) + jvs(169) = -b(105,32)-b(109,32)-b(113,32)-b(117,32) + jvs(170) = b(86,33) + jvs(171) = b(79,34) + jvs(172) = 0 + jvs(173) = 0.34*b(102,40)+0.4*b(106,40)+0.24*b(114,40) + jvs(174) = 0.4*b(101,41) + jvs(175) = -b(113,42) + jvs(176) = 0.03*b(97,43) + jvs(177) = b(79,44)+b(82,44)+b(85,44)+b(86,44)+0.08*b(89,44)+0.5 & + *b(90,44)+0.6*b(92,44)+b(95,44) + jvs(178) = 0.34*b(102,46)-b(105,46) + jvs(179) = 0.4*b(106,48)-b(109,48) + jvs(180) = -b(84,33)-b(86,33)-b(88,33) + jvs(181) = -b(84,43) + jvs(182) = -b(86,44) + jvs(183) = -b(88,48) + jvs(184) = 0.8*b(90,12) + jvs(185) = 0.2*b(97,27) + jvs(186) = 0.19*b(99,28) + jvs(187) = 0.04*b(83,30) + jvs(188) = 0.07*b(84,33) + jvs(189) = -b(78,34)-b(79,34)-b(80,34) + jvs(190) = 0.15*b(115,39) + jvs(191) = 0 + jvs(192) = 0 + jvs(193) = 0.04*b(83,43)+0.07*b(84,43)+0.2*b(97,43) + jvs(194) = -b(79,44)+0.8*b(90,44)+0.19*b(99,44) + jvs(195) = 0 + jvs(196) = -b(80,48) + jvs(197) = b(47,8) + jvs(198) = 0.5*b(56,18) + jvs(199) = 0.1*b(98,28) + jvs(200) = 0.06*b(83,30) + jvs(201) = 0.05*b(84,33) + jvs(202) = -b(58,35)-b(60,35)-b(62,35)-b(64,35) + jvs(203) = 0 + jvs(204) = 0.08*b(102,40)+0.1*b(106,40)+0.06*b(114,40) + jvs(205) = 0.1*b(101,41) + jvs(206) = -b(62,42) + jvs(207) = 0.06*b(83,43)+0.05*b(84,43) + jvs(208) = b(47,44)+0.5*b(56,44) + jvs(209) = -b(58,46)+0.08*b(102,46) + jvs(210) = -b(60,48)+0.1*b(106,48) + jvs(211) = b(87,30) + jvs(212) = b(88,33) + jvs(213) = -b(104,36)-b(108,36)-b(112,36)-b(116,36) + jvs(214) = b(100,41) + jvs(215) = -b(112,42) + jvs(216) = 0 + jvs(217) = b(100,44) + jvs(218) = -b(104,46) + jvs(219) = b(87,48)+b(88,48)-b(108,48) + jvs(220) = b(65,6) + jvs(221) = b(54,18)+0.5*b(56,18) + jvs(222) = 0.22*b(82,20) + jvs(223) = 0.03*b(97,27) + jvs(224) = 0.3*b(98,28)+0.04*b(99,28) + jvs(225) = 0.47*b(83,30)+b(85,30) + jvs(226) = 1.03*b(84,33)+1.77*b(86,33) + jvs(227) = b(58,35)+b(60,35)+0.8*b(64,35) + jvs(228) = 0.5*b(104,36)+0.5*b(108,36)+0.5*b(116,36) + jvs(229) = -b(66,37)-b(67,37)-b(68,37) + jvs(230) = 0 + jvs(231) = 0.25*b(102,40)+0.3*b(106,40)+0.21*b(114,40) + jvs(232) = 0.3*b(101,41) + jvs(233) = 0 + jvs(234) = 0.47*b(83,43)+1.03*b(84,43)+0.03*b(97,43) + jvs(235) = 0.5*b(56,44)+b(65,44)-b(67,44)+0.22*b(82,44)+b(85,44) & + +1.77*b(86,44)+0.04*b(99,44) + jvs(236) = b(58,46)+0.25*b(102,46)+0.5*b(104,46) + jvs(237) = b(60,48)-b(68,48)+0.3*b(106,48)+0.5*b(108,48) + jvs(238) = 0.7*b(55,17) + jvs(239) = b(76,29) + jvs(240) = 0.07*b(83,30) + jvs(241) = 0.1*b(84,33) + jvs(242) = b(66,37) + jvs(243) = -b(57,38)-b(59,38)-b(61,38)-b(63,38) + jvs(244) = 0 + jvs(245) = 0 + jvs(246) = 0 + jvs(247) = -b(61,42) + jvs(248) = 0.07*b(83,43)+0.1*b(84,43) + jvs(249) = b(46,44)+0.7*b(55,44) + jvs(250) = b(71,45)+b(72,45)+b(74,45) + jvs(251) = -b(57,46)+b(71,46) + jvs(252) = -b(59,48)+b(72,48) + jvs(253) = b(77,29) + jvs(254) = 0.11*b(84,33) + jvs(255) = -b(103,39)-b(107,39)-b(111,39)-b(115,39) + jvs(256) = 0 + jvs(257) = 0 + jvs(258) = -b(111,42) + jvs(259) = 0.11*b(84,43) + jvs(260) = b(77,44) + jvs(261) = -b(103,46) + jvs(262) = -b(107,48) + jvs(263) = b(75,13) + jvs(264) = 0 + jvs(265) = 0.77*b(99,28) + jvs(266) = 0.03*b(83,30) + jvs(267) = 0.09*b(84,33) + jvs(268) = 0 + jvs(269) = 0 + jvs(270) = -b(102,40)-b(106,40)-b(110,40)-b(114,40) + jvs(271) = 0 + jvs(272) = -b(110,42) + jvs(273) = 0.03*b(83,43)+0.09*b(84,43) + jvs(274) = b(75,44)+0.77*b(99,44) + jvs(275) = -b(102,46) + jvs(276) = -b(106,48) + jvs(277) = b(94,14) + jvs(278) = 0.05*b(91,16) + jvs(279) = 0 + jvs(280) = 0.5*b(104,36)+0.5*b(108,36)+b(112,36)+0.5*b(116,36) + jvs(281) = 0.16*b(102,40) + jvs(282) = -b(100,41)-b(101,41) + jvs(283) = b(112,42) + jvs(284) = 0 + jvs(285) = -b(100,44) + jvs(286) = 0.05*b(91,46)+0.16*b(102,46)+0.5*b(104,46) + jvs(287) = b(94,47) + jvs(288) = 0.5*b(108,48) + jvs(289) = b(45,5) + jvs(290) = b(65,6) + jvs(291) = b(30,7) + jvs(292) = 0.2*b(89,10) + jvs(293) = 0.55*b(90,12) + jvs(294) = b(5,15)+b(36,15) + jvs(295) = 0.95*b(91,16) + jvs(296) = b(53,17) + jvs(297) = b(54,18) + jvs(298) = 0.22*b(81,20)+b(82,20) + jvs(299) = b(48,21) + jvs(300) = 0.6*b(92,23) + jvs(301) = b(44,24) + jvs(302) = 2*b(95,27)+b(96,27)+0.76*b(97,27) + jvs(303) = 0.9*b(98,28) + jvs(304) = 0.26*b(83,30)+b(85,30) + jvs(305) = 2*b(49,31)+b(51,31)+b(52,31) + jvs(306) = -b(113,32) + jvs(307) = 0.22*b(84,33)+b(86,33) + jvs(308) = b(78,34) + jvs(309) = b(58,35)+b(60,35)-b(62,35)+0.6*b(64,35) + jvs(310) = 0.5*b(104,36)+0.5*b(108,36)-b(112,36) + jvs(311) = b(66,37) + jvs(312) = b(57,38)+b(59,38)-b(61,38)+0.32*b(63,38) + jvs(313) = -b(111,39) + jvs(314) = 0.76*b(102,40)+0.9*b(106,40)-b(110,40)+0.54*b(114,40) + jvs(315) = 0.9*b(101,41) + jvs(316) = -b(21,42)-b(29,42)-2*b(31,42)-2*b(32,42)-b(33,42) & + -b(34,42)-b(35,42)-b(41,42)-b(61,42)-b(62,42)-b(73,42) & + -b(110,42)-b(111,42)-b(112,42)-b(113,42) + jvs(317) = b(20,43)-b(21,43)+0.22*b(81,43)+0.26*b(83,43)+0.22 & + *b(84,43)+0.76*b(97,43) + jvs(318) = b(20,44)+b(22,44)+b(25,44)-b(29,44)+b(30,44)+b(44,44) & + +b(45,44)+b(48,44)+b(51,44)+b(65,44)+b(82,44)+b(85,44) & + +b(86,44)+0.2*b(89,44)+0.55*b(90,44)+0.6*b(92,44)+2 & + *b(95,44) + jvs(319) = -b(73,45) + jvs(320) = -b(33,46)+b(57,46)+b(58,46)+0.95*b(91,46)+0.76 & + *b(102,46)+0.5*b(104,46) + jvs(321) = -b(34,47)-b(35,47) + jvs(322) = b(25,48)-b(41,48)+b(52,48)+b(59,48)+b(60,48)+0.9 & + *b(106,48)+0.5*b(108,48) + jvs(323) = -b(81,20) + jvs(324) = b(13,22)-b(14,22) + jvs(325) = -b(97,27) + jvs(326) = -b(83,30) + jvs(327) = -b(84,33) + jvs(328) = -b(21,42)+0.4*b(73,42) + jvs(329) = -b(7,43)-b(8,43)-b(14,43)-b(18,43)-b(19,43)-b(20,43) & + -b(21,43)-b(81,43)-b(83,43)-b(84,43)-b(97,43) + jvs(330) = -b(20,44) + jvs(331) = 0.4*b(73,45) + jvs(332) = -b(18,46) + jvs(333) = -b(19,47) + jvs(334) = 0 + jvs(335) = 2*b(12,4) + jvs(336) = -b(45,5) + jvs(337) = -b(65,6) + jvs(338) = 2*b(9,7)-b(30,7) + jvs(339) = -b(47,8) + jvs(340) = -b(89,10) + jvs(341) = -b(90,12) + jvs(342) = -b(75,13) + jvs(343) = -b(28,15) + jvs(344) = b(53,17)-0.7*b(55,17) + jvs(345) = b(54,18)-0.5*b(56,18) + jvs(346) = b(3,19)-b(26,19) + jvs(347) = 0.12*b(81,20)-b(82,20) + jvs(348) = -b(48,21) + jvs(349) = -b(92,23) + jvs(350) = -b(44,24) + jvs(351) = 0 + jvs(352) = b(4,26)-b(27,26) + jvs(353) = -b(95,27)+0.08*b(97,27) + jvs(354) = b(98,28)-0.77*b(99,28) + jvs(355) = -b(77,29) + jvs(356) = 0.33*b(83,30)-b(85,30) + jvs(357) = -b(51,31) + jvs(358) = 0.6*b(84,33)-b(86,33) + jvs(359) = -b(79,34) + jvs(360) = 0 + jvs(361) = 0 + jvs(362) = -b(67,37) + jvs(363) = 0 + jvs(364) = 0 + jvs(365) = 0 + jvs(366) = -b(100,41) + jvs(367) = b(21,42)-b(29,42)+b(33,42)+0.7*b(41,42) + jvs(368) = -b(20,43)+b(21,43)+0.12*b(81,43)+0.33*b(83,43)+0.6 & + *b(84,43)+0.08*b(97,43) + jvs(369) = -b(20,44)-b(22,44)-b(23,44)-b(24,44)-b(25,44) & + -b(26,44)-b(27,44)-b(28,44)-b(29,44)-b(30,44)-b(44,44) & + -b(45,44)-b(46,44)-b(47,44)-b(48,44)-b(51,44)-0.7 & + *b(55,44)-0.5*b(56,44)-b(65,44)-b(67,44)-b(75,44) & + -b(77,44)-b(79,44)-b(82,44)-b(85,44)-b(86,44)-b(89,44) & + -b(90,44)-b(92,44)-b(95,44)-0.77*b(99,44)-b(100,44) + jvs(370) = 0 + jvs(371) = -b(23,46)+b(33,46) + jvs(372) = -b(24,47) + jvs(373) = -b(25,48)+0.7*b(41,48) + jvs(374) = b(70,9) + jvs(375) = b(95,27)+b(96,27)+0.62*b(97,27) + jvs(376) = b(76,29) + jvs(377) = 0.13*b(83,30) + jvs(378) = 0.19*b(84,33) + jvs(379) = b(78,34)+b(79,34)+b(80,34) + jvs(380) = b(67,37)+b(68,37) + jvs(381) = b(103,39)+b(107,39)+0.7*b(115,39) + jvs(382) = 0 + jvs(383) = 0 + jvs(384) = -b(73,42) + jvs(385) = 0.13*b(83,43)+0.19*b(84,43)+0.62*b(97,43) + jvs(386) = b(67,44)+b(79,44)+b(95,44) + jvs(387) = -b(69,45)-b(71,45)-b(72,45)-b(73,45)-b(74,45) + jvs(388) = -b(71,46)+b(103,46) + jvs(389) = -b(69,47) + jvs(390) = b(68,48)-b(72,48)+b(80,48)+b(107,48) + jvs(391) = -b(91,16) + jvs(392) = b(3,19) + jvs(393) = b(15,22)-b(17,22) + jvs(394) = -b(105,32) + jvs(395) = 0 + jvs(396) = 0 + jvs(397) = -b(58,35) + jvs(398) = -b(104,36) + jvs(399) = -b(57,38) + jvs(400) = -b(103,39) + jvs(401) = -b(102,40) + jvs(402) = 0 + jvs(403) = -b(33,42) + jvs(404) = -b(18,43) + jvs(405) = -b(23,44) + jvs(406) = -b(71,45) + jvs(407) = -b(17,46)-b(18,46)-b(23,46)-b(33,46)-b(37,46) & + -b(57,46)-b(58,46)-b(71,46)-b(91,46)-b(102,46) & + -b(103,46)-b(104,46)-b(105,46) + jvs(408) = b(1,47)+b(15,47)+b(38,47) + jvs(409) = 0.11*b(2,48)-b(37,48)+b(38,48) + jvs(410) = b(70,9) + jvs(411) = b(6,11)+b(43,11) + jvs(412) = -b(94,14) + jvs(413) = b(5,15)+b(28,15)+b(36,15) + jvs(414) = 0.95*b(91,16) + jvs(415) = b(26,19) + jvs(416) = -b(15,22)-b(16,22)+b(17,22) + jvs(417) = 0 + jvs(418) = b(4,26) + jvs(419) = 0 + jvs(420) = b(105,32)+b(109,32) + jvs(421) = 0 + jvs(422) = 0 + jvs(423) = b(58,35)+b(60,35) + jvs(424) = 1.5*b(104,36)+1.5*b(108,36)+0.5*b(116,36) + jvs(425) = 0 + jvs(426) = b(57,38)+b(59,38) + jvs(427) = b(103,39)+b(107,39) + jvs(428) = 0.84*b(102,40)+b(106,40) + jvs(429) = b(101,41) + jvs(430) = b(33,42)-b(34,42)-b(35,42)+0.7*b(41,42) + jvs(431) = b(18,43)-b(19,43) + jvs(432) = -b(24,44)+b(25,44)+b(26,44)+b(28,44) + jvs(433) = -b(69,45)+b(71,45)+b(72,45) + jvs(434) = b(17,46)+b(18,46)+b(33,46)+2*b(37,46)+b(57,46) & + +b(58,46)+b(71,46)+0.95*b(91,46)+0.84*b(102,46) & + +b(103,46)+1.5*b(104,46)+b(105,46) + jvs(435) = -b(1,47)-b(15,47)-b(16,47)-b(19,47)-b(24,47)-b(34,47) & + -b(35,47)-b(39,47)-b(69,47)-b(94,47) + jvs(436) = 0.89*b(2,48)+b(25,48)+2*b(37,48)-b(39,48)+2*b(40,48) & + +0.7*b(41,48)+b(59,48)+b(60,48)+b(72,48)+b(106,48) & + +b(107,48)+1.5*b(108,48)+b(109,48) + jvs(437) = b(6,11)+b(43,11) + jvs(438) = b(16,22) + jvs(439) = -b(93,23) + jvs(440) = b(27,26) + jvs(441) = -b(87,30) + jvs(442) = -b(52,31) + jvs(443) = -b(109,32) + jvs(444) = -b(88,33) + jvs(445) = -b(80,34) + jvs(446) = -b(60,35) + jvs(447) = -b(108,36) + jvs(448) = -b(68,37) + jvs(449) = -b(59,38) + jvs(450) = -b(107,39) + jvs(451) = -b(106,40) + jvs(452) = 0 + jvs(453) = -b(41,42) + jvs(454) = b(19,43) + jvs(455) = -b(25,44)+b(27,44) + jvs(456) = -b(72,45) + jvs(457) = -b(37,46) + jvs(458) = b(16,47)+b(19,47)-b(38,47)-b(39,47) + jvs(459) = -b(2,48)-b(25,48)-b(37,48)-b(38,48)-b(39,48)-2 & + *b(40,48)-b(41,48)-b(52,48)-b(59,48)-b(60,48)-b(68,48) & + -b(72,48)-b(80,48)-b(87,48)-b(88,48)-b(93,48) & + -b(106,48)-b(107,48)-b(108,48)-b(109,48) + return + end subroutine cbmz_v02r02_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r02 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = non-zero elements of the sparse jacobian [input] + real v(lu_nonzero_v_r02_kpp) + + integer lu_crow_v(nvar_r02_kpp + 1) + integer lu_diag_v(nvar_r02_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r02_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r02_kpp + 1) + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r02_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r02_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r02 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(13) = x(13)-jvs(36)*x(12) + x(16) = x(16)-jvs(49)*x(10)-jvs(50)*x(12) + x(22) = x(22)-jvs(76)*x(4) + x(23) = x(23)-jvs(82)*x(10)-jvs(83)*x(12) + x(24) = x(24)-jvs(87)*x(20) + x(25) = x(25)-jvs(98)*x(13) + x(26) = x(26)-jvs(110)*x(11)-jvs(111)*x(23) + x(27) = x(27)-jvs(120)*x(16)-jvs(121)*x(23) + x(29) = x(29)-jvs(132)*x(28) + x(31) = x(31)-jvs(147)*x(17)-jvs(148)*x(20)-jvs(149)*x(21) & + -jvs(150)*x(27)-jvs(151)*x(30) + x(32) = x(32)-jvs(162)*x(10)-jvs(163)*x(12)-jvs(164)*x(20) & + -jvs(165)*x(23)-jvs(166)*x(27)-jvs(167)*x(28)-jvs(168) & + *x(30) + x(34) = x(34)-jvs(184)*x(12)-jvs(185)*x(27)-jvs(186)*x(28) & + -jvs(187)*x(30)-jvs(188)*x(33) + x(35) = x(35)-jvs(197)*x(8)-jvs(198)*x(18)-jvs(199)*x(28) & + -jvs(200)*x(30)-jvs(201)*x(33) + x(36) = x(36)-jvs(211)*x(30)-jvs(212)*x(33) + x(37) = x(37)-jvs(220)*x(6)-jvs(221)*x(18)-jvs(222)*x(20) & + -jvs(223)*x(27)-jvs(224)*x(28)-jvs(225)*x(30)-jvs(226) & + *x(33)-jvs(227)*x(35)-jvs(228)*x(36) + x(38) = x(38)-jvs(238)*x(17)-jvs(239)*x(29)-jvs(240)*x(30) & + -jvs(241)*x(33)-jvs(242)*x(37) + x(39) = x(39)-jvs(253)*x(29)-jvs(254)*x(33) + x(40) = x(40)-jvs(263)*x(13)-jvs(264)*x(25)-jvs(265)*x(28) & + -jvs(266)*x(30)-jvs(267)*x(33)-jvs(268)*x(36)-jvs(269) & + *x(39) + x(41) = x(41)-jvs(277)*x(14)-jvs(278)*x(16)-jvs(279)*x(23) & + -jvs(280)*x(36)-jvs(281)*x(40) + x(42) = x(42)-jvs(289)*x(5)-jvs(290)*x(6)-jvs(291)*x(7)-jvs(292) & + *x(10)-jvs(293)*x(12)-jvs(294)*x(15)-jvs(295)*x(16) & + -jvs(296)*x(17)-jvs(297)*x(18)-jvs(298)*x(20)-jvs(299) & + *x(21)-jvs(300)*x(23)-jvs(301)*x(24)-jvs(302)*x(27) & + -jvs(303)*x(28)-jvs(304)*x(30)-jvs(305)*x(31)-jvs(306) & + *x(32)-jvs(307)*x(33)-jvs(308)*x(34)-jvs(309)*x(35) & + -jvs(310)*x(36)-jvs(311)*x(37)-jvs(312)*x(38)-jvs(313) & + *x(39)-jvs(314)*x(40)-jvs(315)*x(41) + x(43) = x(43)-jvs(323)*x(20)-jvs(324)*x(22)-jvs(325)*x(27) & + -jvs(326)*x(30)-jvs(327)*x(33)-jvs(328)*x(42) + x(44) = x(44)-jvs(335)*x(4)-jvs(336)*x(5)-jvs(337)*x(6)-jvs(338) & + *x(7)-jvs(339)*x(8)-jvs(340)*x(10)-jvs(341)*x(12) & + -jvs(342)*x(13)-jvs(343)*x(15)-jvs(344)*x(17)-jvs(345) & + *x(18)-jvs(346)*x(19)-jvs(347)*x(20)-jvs(348)*x(21) & + -jvs(349)*x(23)-jvs(350)*x(24)-jvs(351)*x(25)-jvs(352) & + *x(26)-jvs(353)*x(27)-jvs(354)*x(28)-jvs(355)*x(29) & + -jvs(356)*x(30)-jvs(357)*x(31)-jvs(358)*x(33)-jvs(359) & + *x(34)-jvs(360)*x(35)-jvs(361)*x(36)-jvs(362)*x(37) & + -jvs(363)*x(38)-jvs(364)*x(39)-jvs(365)*x(40)-jvs(366) & + *x(41)-jvs(367)*x(42)-jvs(368)*x(43) + x(45) = x(45)-jvs(374)*x(9)-jvs(375)*x(27)-jvs(376)*x(29) & + -jvs(377)*x(30)-jvs(378)*x(33)-jvs(379)*x(34)-jvs(380) & + *x(37)-jvs(381)*x(39)-jvs(382)*x(40)-jvs(383)*x(41) & + -jvs(384)*x(42)-jvs(385)*x(43)-jvs(386)*x(44) + x(46) = x(46)-jvs(391)*x(16)-jvs(392)*x(19)-jvs(393)*x(22) & + -jvs(394)*x(32)-jvs(395)*x(33)-jvs(396)*x(34)-jvs(397) & + *x(35)-jvs(398)*x(36)-jvs(399)*x(38)-jvs(400)*x(39) & + -jvs(401)*x(40)-jvs(402)*x(41)-jvs(403)*x(42)-jvs(404) & + *x(43)-jvs(405)*x(44)-jvs(406)*x(45) + x(47) = x(47)-jvs(410)*x(9)-jvs(411)*x(11)-jvs(412)*x(14) & + -jvs(413)*x(15)-jvs(414)*x(16)-jvs(415)*x(19)-jvs(416) & + *x(22)-jvs(417)*x(23)-jvs(418)*x(26)-jvs(419)*x(31) & + -jvs(420)*x(32)-jvs(421)*x(33)-jvs(422)*x(34)-jvs(423) & + *x(35)-jvs(424)*x(36)-jvs(425)*x(37)-jvs(426)*x(38) & + -jvs(427)*x(39)-jvs(428)*x(40)-jvs(429)*x(41)-jvs(430) & + *x(42)-jvs(431)*x(43)-jvs(432)*x(44)-jvs(433)*x(45) & + -jvs(434)*x(46) + x(48) = x(48)-jvs(437)*x(11)-jvs(438)*x(22)-jvs(439)*x(23) & + -jvs(440)*x(26)-jvs(441)*x(30)-jvs(442)*x(31)-jvs(443) & + *x(32)-jvs(444)*x(33)-jvs(445)*x(34)-jvs(446)*x(35) & + -jvs(447)*x(36)-jvs(448)*x(37)-jvs(449)*x(38)-jvs(450) & + *x(39)-jvs(451)*x(40)-jvs(452)*x(41)-jvs(453)*x(42) & + -jvs(454)*x(43)-jvs(455)*x(44)-jvs(456)*x(45)-jvs(457) & + *x(46)-jvs(458)*x(47) + x(48) = x(48)/jvs(459) + x(47) = (x(47)-jvs(436)*x(48))/(jvs(435)) + x(46) = (x(46)-jvs(408)*x(47)-jvs(409)*x(48))/(jvs(407)) + x(45) = (x(45)-jvs(388)*x(46)-jvs(389)*x(47)-jvs(390)*x(48))/ & + (jvs(387)) + x(44) = (x(44)-jvs(370)*x(45)-jvs(371)*x(46)-jvs(372)*x(47) & + -jvs(373)*x(48))/(jvs(369)) + x(43) = (x(43)-jvs(330)*x(44)-jvs(331)*x(45)-jvs(332)*x(46) & + -jvs(333)*x(47)-jvs(334)*x(48))/(jvs(329)) + x(42) = (x(42)-jvs(317)*x(43)-jvs(318)*x(44)-jvs(319)*x(45) & + -jvs(320)*x(46)-jvs(321)*x(47)-jvs(322)*x(48))/(jvs(316)) + x(41) = (x(41)-jvs(283)*x(42)-jvs(284)*x(43)-jvs(285)*x(44) & + -jvs(286)*x(46)-jvs(287)*x(47)-jvs(288)*x(48))/(jvs(282)) + x(40) = (x(40)-jvs(271)*x(41)-jvs(272)*x(42)-jvs(273)*x(43) & + -jvs(274)*x(44)-jvs(275)*x(46)-jvs(276)*x(48))/(jvs(270)) + x(39) = (x(39)-jvs(256)*x(40)-jvs(257)*x(41)-jvs(258)*x(42) & + -jvs(259)*x(43)-jvs(260)*x(44)-jvs(261)*x(46)-jvs(262) & + *x(48))/(jvs(255)) + x(38) = (x(38)-jvs(244)*x(39)-jvs(245)*x(40)-jvs(246)*x(41) & + -jvs(247)*x(42)-jvs(248)*x(43)-jvs(249)*x(44)-jvs(250) & + *x(45)-jvs(251)*x(46)-jvs(252)*x(48))/(jvs(243)) + x(37) = (x(37)-jvs(230)*x(39)-jvs(231)*x(40)-jvs(232)*x(41) & + -jvs(233)*x(42)-jvs(234)*x(43)-jvs(235)*x(44)-jvs(236) & + *x(46)-jvs(237)*x(48))/(jvs(229)) + x(36) = (x(36)-jvs(214)*x(41)-jvs(215)*x(42)-jvs(216)*x(43) & + -jvs(217)*x(44)-jvs(218)*x(46)-jvs(219)*x(48))/(jvs(213)) + x(35) = (x(35)-jvs(203)*x(39)-jvs(204)*x(40)-jvs(205)*x(41) & + -jvs(206)*x(42)-jvs(207)*x(43)-jvs(208)*x(44)-jvs(209) & + *x(46)-jvs(210)*x(48))/(jvs(202)) + x(34) = (x(34)-jvs(190)*x(39)-jvs(191)*x(40)-jvs(192)*x(42) & + -jvs(193)*x(43)-jvs(194)*x(44)-jvs(195)*x(46)-jvs(196) & + *x(48))/(jvs(189)) + x(33) = (x(33)-jvs(181)*x(43)-jvs(182)*x(44)-jvs(183)*x(48))/ & + (jvs(180)) + x(32) = (x(32)-jvs(170)*x(33)-jvs(171)*x(34)-jvs(172)*x(39) & + -jvs(173)*x(40)-jvs(174)*x(41)-jvs(175)*x(42)-jvs(176) & + *x(43)-jvs(177)*x(44)-jvs(178)*x(46)-jvs(179)*x(48))/ & + (jvs(169)) + x(31) = (x(31)-jvs(153)*x(33)-jvs(154)*x(36)-jvs(155)*x(38) & + -jvs(156)*x(39)-jvs(157)*x(42)-jvs(158)*x(43)-jvs(159) & + *x(44)-jvs(160)*x(46)-jvs(161)*x(48))/(jvs(152)) + x(30) = (x(30)-jvs(144)*x(43)-jvs(145)*x(44)-jvs(146)*x(48))/ & + (jvs(143)) + x(29) = (x(29)-jvs(134)*x(33)-jvs(135)*x(39)-jvs(136)*x(40) & + -jvs(137)*x(41)-jvs(138)*x(42)-jvs(139)*x(43)-jvs(140) & + *x(44)-jvs(141)*x(46)-jvs(142)*x(48))/(jvs(133)) + x(28) = (x(28)-jvs(128)*x(39)-jvs(129)*x(40)-jvs(130)*x(42) & + -jvs(131)*x(44))/(jvs(127)) + x(27) = (x(27)-jvs(123)*x(43)-jvs(124)*x(44)-jvs(125)*x(46) & + -jvs(126)*x(48))/(jvs(122)) + x(26) = (x(26)-jvs(113)*x(31)-jvs(114)*x(34)-jvs(115)*x(37) & + -jvs(116)*x(42)-jvs(117)*x(44)-jvs(118)*x(47)-jvs(119) & + *x(48))/(jvs(112)) + x(25) = (x(25)-jvs(100)*x(28)-jvs(101)*x(30)-jvs(102)*x(33) & + -jvs(103)*x(36)-jvs(104)*x(40)-jvs(105)*x(41)-jvs(106) & + *x(43)-jvs(107)*x(44)-jvs(108)*x(46)-jvs(109)*x(48))/ & + (jvs(99)) + x(24) = (x(24)-jvs(89)*x(27)-jvs(90)*x(30)-jvs(91)*x(31)-jvs(92) & + *x(33)-jvs(93)*x(34)-jvs(94)*x(37)-jvs(95)*x(43)-jvs(96) & + *x(44)-jvs(97)*x(48))/(jvs(88)) + x(23) = (x(23)-jvs(85)*x(44)-jvs(86)*x(48))/(jvs(84)) + x(22) = (x(22)-jvs(78)*x(43)-jvs(79)*x(46)-jvs(80)*x(47)-jvs(81) & + *x(48))/(jvs(77)) + x(21) = (x(21)-jvs(71)*x(30)-jvs(72)*x(33)-jvs(73)*x(38)-jvs(74) & + *x(43)-jvs(75)*x(44))/(jvs(70)) + x(20) = (x(20)-jvs(68)*x(43)-jvs(69)*x(44))/(jvs(67)) + x(19) = (x(19)-jvs(63)*x(42)-jvs(64)*x(44)-jvs(65)*x(46)-jvs(66) & + *x(47))/(jvs(62)) + x(18) = (x(18)-jvs(59)*x(35)-jvs(60)*x(42)-jvs(61)*x(44))/ & + (jvs(58)) + x(17) = (x(17)-jvs(55)*x(38)-jvs(56)*x(42)-jvs(57)*x(44))/ & + (jvs(54)) + x(16) = (x(16)-jvs(52)*x(44)-jvs(53)*x(46))/(jvs(51)) + x(15) = (x(15)-jvs(46)*x(42)-jvs(47)*x(44)-jvs(48)*x(47))/ & + (jvs(45)) + x(14) = (x(14)-jvs(41)*x(23)-jvs(42)*x(44)-jvs(43)*x(47)-jvs(44) & + *x(48))/(jvs(40)) + x(13) = (x(13)-jvs(38)*x(25)-jvs(39)*x(44))/(jvs(37)) + x(12) = (x(12)-jvs(35)*x(44))/(jvs(34)) + x(11) = (x(11)-jvs(32)*x(47)-jvs(33)*x(48))/(jvs(31)) + x(10) = (x(10)-jvs(30)*x(44))/(jvs(29)) + x(9) = (x(9)-jvs(27)*x(45)-jvs(28)*x(47))/(jvs(26)) + x(8) = (x(8)-jvs(24)*x(35)-jvs(25)*x(44))/(jvs(23)) + x(7) = (x(7)-jvs(21)*x(42)-jvs(22)*x(44))/(jvs(20)) + x(6) = (x(6)-jvs(19)*x(44))/(jvs(18)) + x(5) = (x(5)-jvs(17)*x(44))/(jvs(16)) + x(4) = (x(4)-jvs(15)*x(43))/(jvs(14)) + x(3) = (x(3)-jvs(9)*x(30)-jvs(10)*x(33)-jvs(11)*x(42)-jvs(12) & + *x(43)-jvs(13)*x(45))/(jvs(8)) + x(2) = (x(2)-jvs(5)*x(20)-jvs(6)*x(30)-jvs(7)*x(43))/(jvs(4)) + x(1) = (x(1)-jvs(2)*x(5)-jvs(3)*x(44))/(jvs(1)) + return + end subroutine cbmz_v02r02_solve + + +! cbmz_v02r03_torodas.f - created on 17-nov-2003 from previous +! cbmz_v02r03_torodas.f cbmz_v02r03_mapconcs.f +! cbmz_v02r03_maprates.f cbmz_v02r03_dydt.f +! cbmz_v02r03_jacob.f cbmz_v02r03_decomp.f +! cbmz_v02r03_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r03_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r03 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r03_dydt +! external cbmz_v02r03_jacob +! external cbmz_v02r03_decomp +! external cbmz_v02r03_solve + + integer i + + real hmax + integer lu_crow_v(nvar_r03_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r03_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r03_kpp) + save lu_icol_v + + data( lu_icol_v(i), i = 1, 252 ) / & + 1, 5, 48, 2, 20, 31, 32, 42, 49, 3, 31, 36, & + 47, 49, 50, 4, 49, 5, 48, 6, 48, 7, 48, 50, & + 8, 39, 48, 9, 47, 52, 10, 48, 11, 52, 53, 12, & + 48, 13, 23, 48, 52, 53, 14, 48, 50, 52, 10, 12, & + 15, 48, 51, 16, 26, 31, 36, 37, 44, 45, 46, 48, & + 49, 51, 53, 17, 41, 48, 50, 18, 39, 48, 50, 19, & + 48, 50, 51, 52, 20, 48, 49, 21, 31, 36, 41, 48, & + 49, 4, 22, 49, 51, 52, 53, 10, 12, 23, 48, 53, & + 11, 23, 24, 33, 38, 40, 42, 48, 50, 52, 53, 20, & + 25, 27, 30, 31, 32, 33, 36, 38, 40, 42, 48, 49, & + 51, 53, 12, 16, 26, 28, 29, 31, 36, 37, 42, 44, & + 45, 46, 48, 49, 50, 51, 53, 15, 23, 27, 48, 49, & + 51, 53, 28, 32, 50, 51, 53, 29, 32, 48, 50, 51, & + 30, 42, 48, 50, 51, 31, 48, 49, 53, 32, 48, 49, & + 53, 17, 20, 21, 27, 29, 30, 31, 32, 33, 36, 37, & + 41, 42, 43, 48, 49, 50, 51, 53, 10, 12, 20, 23, & + 27, 31, 32, 34, 36, 38, 42, 44, 45, 46, 48, 49, & + 50, 51, 53, 30, 35, 36, 42, 43, 44, 45, 46, 48, & + 49, 50, 51, 53, 36, 48, 49, 53, 31, 36, 37, 46, & + 48, 49, 50, 51, 53, 12, 27, 30, 31, 36, 38, 42, & + 43, 44, 48, 49, 50, 51, 53, 8, 18, 31, 36, 39 / + + data( lu_icol_v(i), i = 253, 504 ) / & + 44, 45, 46, 48, 49, 50, 51, 53, 6, 18, 20, 27, & + 28, 30, 31, 32, 36, 37, 39, 40, 42, 44, 45, 46, & + 48, 49, 50, 51, 53, 17, 31, 35, 36, 40, 41, 42, & + 43, 44, 45, 46, 47, 48, 49, 50, 51, 53, 28, 29, & + 32, 42, 48, 49, 50, 51, 53, 35, 36, 42, 43, 44, & + 45, 46, 48, 49, 50, 51, 53, 29, 30, 32, 42, 43, & + 44, 45, 46, 48, 49, 50, 51, 53, 26, 28, 29, 31, & + 32, 36, 37, 42, 44, 45, 46, 48, 49, 50, 51, 53, & + 13, 15, 23, 28, 29, 32, 37, 42, 45, 46, 48, 49, & + 50, 51, 52, 53, 9, 27, 31, 32, 35, 36, 38, 40, & + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, & + 4, 5, 6, 7, 8, 10, 12, 14, 17, 18, 19, 20, & + 21, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, & + 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, & + 47, 48, 49, 50, 51, 52, 53, 20, 22, 27, 31, 32, & + 36, 42, 47, 48, 49, 50, 51, 52, 53, 5, 6, 7, & + 10, 12, 14, 15, 17, 18, 20, 21, 23, 25, 27, 28, & + 29, 30, 31, 32, 33, 34, 36, 37, 38, 39, 40, 41, & + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, & + 15, 19, 22, 28, 29, 30, 32, 34, 36, 37, 38, 39, & + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52 / + + data( lu_icol_v(i), i = 505, 564 ) / & + 53, 9, 11, 13, 14, 15, 19, 22, 23, 24, 28, 29, & + 30, 32, 33, 34, 36, 37, 38, 39, 40, 41, 42, 43, & + 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 11, 22, & + 23, 24, 31, 32, 33, 34, 36, 37, 38, 39, 40, 41, & + 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53 / + + data lu_crow_v / & + 1, 4, 10, 16, 18, 20, 22, 25, 28, 31, 33, 36, & + 38, 43, 47, 52, 64, 68, 72, 77, 80, 86, 92, 97, & + 108,123,140,147,152,157,162,166,170,189,208,221, & + 225,234,248,261,282,299,308,320,333,349,365,385, & + 428,442,481,506,539,565 / + + data lu_diag_v / & + 1, 4, 10, 16, 18, 20, 22, 25, 28, 31, 33, 36, & + 38, 43, 49, 52, 64, 68, 72, 77, 80, 87, 94, 99, & + 109,125,142,147,152,157,162,166,178,196,209,221, & + 227,239,252,272,287,302,311,325,342,358,378,422, & + 437,477,503,537,564,565 / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r03_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r03_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r03_dydt, & + cbmz_v02r03_jacob, & + cbmz_v02r03_decomp, & + cbmz_v02r03_solve ) + + return + end subroutine cbmz_v02r03_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r03 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r03_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ihcooh_kpp + parameter ( ihcooh_kpp = 2 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 3 ) + integer io1d_kpp + parameter ( io1d_kpp = 4 ) + integer iso2_kpp + parameter ( iso2_kpp = 5 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 6 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 7 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 8 ) + integer ipan_kpp + parameter ( ipan_kpp = 9 ) + integer itol_kpp + parameter ( itol_kpp = 10 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 11 ) + integer ixyl_kpp + parameter ( ixyl_kpp = 12 ) + integer icro_kpp + parameter ( icro_kpp = 13 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 14 ) + integer ito2_kpp + parameter ( ito2_kpp = 15 ) + integer ixpar_kpp + parameter ( ixpar_kpp = 16 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 17 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 18 ) + integer ihono_kpp + parameter ( ihono_kpp = 19 ) + integer ieth_kpp + parameter ( ieth_kpp = 20 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 21 ) + integer io3p_kpp + parameter ( io3p_kpp = 22 ) + integer icres_kpp + parameter ( icres_kpp = 23 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 24 ) + integer ico_kpp + parameter ( ico_kpp = 25 ) + integer ipar_kpp + parameter ( ipar_kpp = 26 ) + integer iopen_kpp + parameter ( iopen_kpp = 27 ) + integer iisopn_kpp + parameter ( iisopn_kpp = 28 ) + integer iisopp_kpp + parameter ( iisopp_kpp = 29 ) + integer iisopo2_kpp + parameter ( iisopo2_kpp = 30 ) + integer iolet_kpp + parameter ( iolet_kpp = 31 ) + integer iisop_kpp + parameter ( iisop_kpp = 32 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 33 ) + integer ixo2_kpp + parameter ( ixo2_kpp = 34 ) + integer iaone_kpp + parameter ( iaone_kpp = 35 ) + integer iolei_kpp + parameter ( iolei_kpp = 36 ) + integer inap_kpp + parameter ( inap_kpp = 37 ) + integer imgly_kpp + parameter ( imgly_kpp = 38 ) + integer iethp_kpp + parameter ( iethp_kpp = 39 ) + integer iald2_kpp + parameter ( iald2_kpp = 40 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 41 ) + integer iisoprd_kpp + parameter ( iisoprd_kpp = 42 ) + integer iano2_kpp + parameter ( iano2_kpp = 43 ) + integer irooh_kpp + parameter ( irooh_kpp = 44 ) + integer iro2_kpp + parameter ( iro2_kpp = 45 ) + integer ionit_kpp + parameter ( ionit_kpp = 46 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 47 ) + integer ioh_kpp + parameter ( ioh_kpp = 48 ) + integer io3_kpp + parameter ( io3_kpp = 49 ) + integer iho2_kpp + parameter ( iho2_kpp = 50 ) + integer ino_kpp + parameter ( ino_kpp = 51 ) + integer ino2_kpp + parameter ( ino2_kpp = 52 ) + integer ino3_kpp + parameter ( ino3_kpp = 53 ) + +! indexes declaration for fixed species + + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + nyy = nvar_r03_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ihcooh_kpp) = cbox(ihcooh_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(itol_kpp) = cbox(itol_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ixyl_kpp) = cbox(ixyl_z) + yy(icro_kpp) = cbox(icro_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ito2_kpp) = cbox(ito2_z) + yy(ixpar_kpp) = cbox(ixpar_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ieth_kpp) = cbox(ieth_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(icres_kpp) = cbox(icres_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(ico_kpp) = cbox(ico_z) + yy(ipar_kpp) = cbox(ipar_z) + yy(iopen_kpp) = cbox(iopen_z) + yy(iisopn_kpp) = cbox(iisopn_z) + yy(iisopp_kpp) = cbox(iisopp_z) + yy(iisopo2_kpp) = cbox(iisopo2_z) + yy(iolet_kpp) = cbox(iolet_z) + yy(iisop_kpp) = cbox(iisop_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(ixo2_kpp) = cbox(ixo2_z) + yy(iaone_kpp) = cbox(iaone_z) + yy(iolei_kpp) = cbox(iolei_z) + yy(inap_kpp) = cbox(inap_z) + yy(imgly_kpp) = cbox(imgly_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(iisoprd_kpp) = cbox(iisoprd_z) + yy(iano2_kpp) = cbox(iano2_z) + yy(irooh_kpp) = cbox(irooh_z) + yy(iro2_kpp) = cbox(iro2_z) + yy(ionit_kpp) = cbox(ionit_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(ioh_kpp) = cbox(ioh_z) + yy(io3_kpp) = cbox(io3_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(ino_kpp) = cbox(ino_z) + yy(ino2_kpp) = cbox(ino2_z) + yy(ino3_kpp) = cbox(ino3_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ihcooh_z) = yy(ihcooh_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(itol_z) = yy(itol_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ixyl_z) = yy(ixyl_kpp) + cbox(icro_z) = yy(icro_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ito2_z) = yy(ito2_kpp) + cbox(ixpar_z) = yy(ixpar_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ieth_z) = yy(ieth_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(icres_z) = yy(icres_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(ipar_z) = yy(ipar_kpp) + cbox(iopen_z) = yy(iopen_kpp) + cbox(iisopn_z) = yy(iisopn_kpp) + cbox(iisopp_z) = yy(iisopp_kpp) + cbox(iisopo2_z) = yy(iisopo2_kpp) + cbox(iolet_z) = yy(iolet_kpp) + cbox(iisop_z) = yy(iisop_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(ixo2_z) = yy(ixo2_kpp) + cbox(iaone_z) = yy(iaone_kpp) + cbox(iolei_z) = yy(iolei_kpp) + cbox(inap_z) = yy(inap_kpp) + cbox(imgly_z) = yy(imgly_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(iisoprd_z) = yy(iisoprd_kpp) + cbox(iano2_z) = yy(iano2_kpp) + cbox(irooh_z) = yy(irooh_kpp) + cbox(iro2_z) = yy(iro2_kpp) + cbox(ionit_z) = yy(ionit_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(ioh_z) = yy(ioh_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(ino2_z) = yy(ino2_kpp) + cbox(ino3_z) = yy(ino3_kpp) + + return + end subroutine cbmz_v02r03_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r03 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + rconst(75) = (rk_m2(1)) + rconst(76) = (rk_m2(5)) + rconst(77) = (rk_m2(6)) + rconst(78) = (rk_m2(7)) + rconst(79) = (rk_m2(8)) + rconst(80) = (rk_m2(9)) + rconst(81) = (rk_m2(10)) + rconst(82) = (rk_m2(11)) + rconst(83) = (rk_m2(12)) + rconst(84) = (rk_m2(13)) + rconst(85) = (rk_m2(14)) + rconst(86) = (rk_m2(15)) + rconst(87) = (rk_m2(16)) + rconst(88) = (rk_m2(17)) + rconst(89) = (rk_m2(18)) + rconst(90) = (rk_m2(19)) + rconst(91) = (rk_m2(20)) + rconst(92) = (rk_m2(21)) + rconst(93) = (rk_m2(22)) + rconst(94) = (rk_m2(23)) + rconst(95) = (rk_m2(24)) + rconst(96) = (rk_m2(25)) + rconst(97) = (rk_m2(26)) + rconst(98) = (rk_m2(27)) + rconst(99) = (rk_m2(28)) + rconst(100) = (rk_m2(29)) + rconst(101) = (rk_m2(30)) + rconst(102) = (rk_m2(33)) + rconst(103) = (rk_m2(35)) + rconst(104) = (rk_m2(36)) + rconst(105) = (rk_m2(37)) + rconst(106) = (rk_m2(38)) + rconst(107) = (rk_m2(40)) + rconst(108) = (rk_m2(41)) + rconst(109) = (rk_m2(42)) + rconst(110) = (rk_m2(43)) + rconst(111) = (rk_m2(45)) + rconst(112) = (rk_m2(46)) + rconst(113) = (rk_m2(47)) + rconst(114) = (rk_m2(48)) + rconst(115) = (rk_m2(50)) + rconst(116) = (rk_m2(51)) + rconst(117) = (rk_m2(52)) + rconst(118) = (rk_m2(53)) + rconst(119) = (rk_m3(1)) + rconst(120) = (rk_m3(2)) + rconst(121) = (rk_m3(3)) + rconst(122) = (rk_m3(4)) + rconst(123) = (rk_m3(5)) + rconst(124) = (rk_m3(6)) + rconst(125) = (rk_m3(7)) + rconst(126) = (rk_m3(8)) + rconst(127) = (rk_m3(9)) + rconst(128) = (rk_m3(10)) + rconst(129) = (rk_m3(11)) + rconst(130) = (rk_m3(12)) + rconst(131) = (rk_m3(13)) + rconst(132) = (rk_m3(14)) + rconst(133) = (rk_m3(15)) + rconst(134) = (rk_m3(16)) + return + end subroutine cbmz_v02r03_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r03 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r03_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r03_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r03_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r03_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(52) + a(2) = rconst(2)*v(53) + a(3) = rconst(3)*v(19) + a(4) = rconst(4)*v(24) + a(5) = rconst(5)*v(14) + a(6) = rconst(6)*v(11) + a(7) = rconst(7)*v(49) + a(8) = rconst(8)*v(49) + a(9) = rconst(9)*v(7) + a(10) = rconst(10)*v(4)*f(4) + a(11) = rconst(11)*v(4)*f(5) + a(12) = rconst(12)*v(4)*f(2) + a(13) = rconst(13)*v(22)*f(4) + a(14) = rconst(14)*v(22)*v(49) + a(15) = rconst(15)*v(22)*v(52) + a(16) = rconst(16)*v(22)*v(52) + a(17) = rconst(17)*v(22)*v(51) + a(18) = rconst(18)*v(49)*v(51) + a(19) = rconst(19)*v(49)*v(52) + a(20) = rconst(20)*v(48)*v(49) + a(21) = rconst(21)*v(49)*v(50) + a(22) = rconst(22)*v(48)*f(3) + a(23) = rconst(23)*v(48)*v(51) + a(24) = rconst(24)*v(48)*v(52) + a(25) = rconst(25)*v(48)*v(53) + a(26) = rconst(26)*v(19)*v(48) + a(27) = rconst(27)*v(24)*v(48) + a(28) = rconst(28)*v(14)*v(48) + a(29) = rconst(29)*v(48)*v(50) + a(30) = rconst(30)*v(7)*v(48) + a(31) = rconst(31)*v(50)*v(50) + a(32) = rconst(32)*v(50)*v(50)*f(2) + a(33) = rconst(33)*v(50)*v(51) + a(34) = rconst(34)*v(50)*v(52) + a(35) = rconst(35)*v(50)*v(52) + a(36) = rconst(36)*v(14) + a(37) = rconst(37)*v(51)*v(53) + a(38) = rconst(38)*v(52)*v(53) + a(39) = rconst(39)*v(52)*v(53) + a(40) = rconst(40)*v(53)*v(53) + a(41) = rconst(41)*v(50)*v(53) + a(42) = rconst(42)*v(11)*f(2) + a(43) = rconst(43)*v(11) + a(44) = rconst(44)*v(25)*v(48) + a(45) = rconst(45)*v(5)*v(48) + a(46) = rconst(46)*v(48)*f(1) + a(47) = rconst(47)*v(8)*v(48) + a(48) = rconst(48)*v(21)*v(48) + a(49) = rconst(49)*v(33) + a(50) = rconst(50)*v(33) + a(51) = rconst(51)*v(33)*v(48) + a(52) = rconst(52)*v(33)*v(53) + a(53) = rconst(53)*v(17) + a(54) = rconst(54)*v(18) + a(55) = rconst(55)*v(17)*v(48) + a(56) = rconst(56)*v(18)*v(48) + a(57) = rconst(57)*v(41)*v(51) + a(58) = rconst(58)*v(39)*v(51) + a(59) = rconst(59)*v(41)*v(53) + a(60) = rconst(60)*v(39)*v(53) + a(61) = rconst(61)*v(41)*v(50) + a(62) = rconst(62)*v(39)*v(50) + a(63) = rconst(63)*v(41) + a(64) = rconst(64)*v(39) + a(65) = rconst(65)*v(6)*v(48) + a(66) = rconst(66)*v(40) + a(67) = rconst(67)*v(40)*v(48) + a(68) = rconst(68)*v(40)*v(53) + a(69) = rconst(69)*v(47)*v(52) + a(70) = rconst(70)*v(9) + a(71) = rconst(71)*v(47)*v(51) + a(72) = rconst(72)*v(47)*v(53) + a(73) = rconst(73)*v(47)*v(50) + a(74) = rconst(74)*v(47) + a(75) = rconst(75)*v(26)*v(48) + a(76) = rconst(76)*v(35) + a(77) = rconst(77)*v(35)*v(48) + a(78) = rconst(78)*v(38) + a(79) = rconst(79)*v(38)*v(48) + a(80) = rconst(80)*v(38)*v(53) + a(81) = rconst(81)*v(20)*v(49) + a(82) = rconst(82)*v(20)*v(48) + a(83) = rconst(83)*v(31)*v(49) + a(84) = rconst(84)*v(36)*v(49) + a(85) = rconst(85)*v(31)*v(48) + a(86) = rconst(86)*v(36)*v(48) + a(87) = rconst(87)*v(31)*v(53) + a(88) = rconst(88)*v(36)*v(53) + a(89) = rconst(89)*v(10)*v(48) + a(90) = rconst(90)*v(12)*v(48) + a(91) = rconst(91)*v(15)*v(51) + a(92) = rconst(92)*v(23)*v(48) + a(93) = rconst(93)*v(23)*v(53) + a(94) = rconst(94)*v(13)*v(52) + a(95) = rconst(95)*v(27)*v(48) + a(96) = rconst(96)*v(27) + a(97) = rconst(97)*v(27)*v(49) + a(98) = rconst(98)*v(44) + a(99) = rconst(99)*v(44)*v(48) + a(100) = rconst(100)*v(46)*v(48) + a(101) = rconst(101)*v(46) + a(102) = rconst(102)*v(45)*v(51) + a(103) = rconst(103)*v(43)*v(51) + a(104) = rconst(104)*v(37)*v(51) + a(105) = rconst(105)*v(34)*v(51) + a(106) = rconst(106)*v(45)*v(53) + a(107) = rconst(107)*v(43)*v(53) + a(108) = rconst(108)*v(37)*v(53) + a(109) = rconst(109)*v(34)*v(53) + a(110) = rconst(110)*v(45)*v(50) + a(111) = rconst(111)*v(43)*v(50) + a(112) = rconst(112)*v(37)*v(50) + a(113) = rconst(113)*v(34)*v(50) + a(114) = rconst(114)*v(45) + a(115) = rconst(115)*v(43) + a(116) = rconst(116)*v(37) + a(117) = rconst(117)*v(34) + a(118) = rconst(118)*v(16)*v(26) + a(119) = rconst(119)*v(32)*v(48) + a(120) = rconst(120)*v(32)*v(49) + a(121) = rconst(121)*v(32)*v(53) + a(122) = rconst(122)*v(42) + a(123) = rconst(123)*v(42)*v(48) + a(124) = rconst(124)*v(42)*v(49) + a(125) = rconst(125)*v(42)*v(53) + a(126) = rconst(126)*v(29)*v(51) + a(127) = rconst(127)*v(28)*v(51) + a(128) = rconst(128)*v(30)*v(51) + a(129) = rconst(129)*v(29)*v(50) + a(130) = rconst(130)*v(28)*v(50) + a(131) = rconst(131)*v(30)*v(50) + a(132) = rconst(132)*v(29) + a(133) = rconst(133)*v(28) + a(134) = rconst(134)*v(30) + +! aggregate function + a_var(1) = a(45) + a_var(2) = 0.52*a(81)+0.22*a(83)+0.39*a(120)+0.46*a(124) + a_var(3) = 0.4*a(73)+0.09*a(83)+0.16*a(84) + a_var(4) = a(8)-a(10)-a(11)-a(12) + a_var(5) = -a(45) + a_var(6) = -a(65) + a_var(7) = -a(9)-a(30)+a(31)+a(32) + a_var(8) = -a(47)+0.2*a(64) + a_var(9) = a(69)-a(70) + a_var(10) = -a(89) + a_var(11) = -a(6)+a(39)-a(42)-a(43) + a_var(12) = -a(90) + a_var(13) = 0.4*a(92)+a(93)-a(94) + a_var(14) = -a(5)-a(28)+a(34)-a(36) + a_var(15) = 0.8*a(89)+0.45*a(90)-a(91) + a_var(16) = 1.06*a(83)+2.26*a(84)+a(85)+2.23*a(86)+1.98*a(98) & + +0.42*a(99)+1.98*a(101)+1.68*a(102)+a(104)+1.98 & + *a(106)+a(108)+1.25*a(114)+a(116)-a(118) + a_var(17) = -a(53)-a(55)+a(61) + a_var(18) = -a(54)-a(56)+a(62) + a_var(19) = -a(3)+a(23)-a(26)+a(35) + a_var(20) = -a(81)-a(82) + a_var(21) = -a(48)+0.34*a(63)+0.03*a(83)+0.04*a(84) + a_var(22) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17) + a_var(23) = 0.12*a(89)+0.05*a(90)-a(92)-a(93) + a_var(24) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) & + +a(80)+a(93)+0.07*a(125) + a_var(25) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66)+a(78)+a(80) & + +0.24*a(81)+0.31*a(83)+0.3*a(84)+2*a(95)+a(96)+0.69 & + *a(97)+0.07*a(120)+0.33*a(122)+0.16*a(124)+0.64 & + *a(125)+0.59*a(128) + a_var(26) = -a(75)+1.1*a(90)-a(118)+1.86*a(125)+0.18*a(126)+1.6 & + *a(127)+2*a(130)+2*a(133) + a_var(27) = 0.95*a(91)+0.3*a(92)-a(95)-a(96)-a(97) + a_var(28) = a(121)-a(127)-a(130)-a(133) + a_var(29) = a(119)-a(126)-a(129)-a(132) + a_var(30) = 0.5*a(123)-a(128)-a(131)-a(134) + a_var(31) = -a(83)-a(85)-a(87) + a_var(32) = -a(119)-a(120)-a(121) + a_var(33) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63)+a(81)+1.56*a(82)+0.57*a(83)+a(85) & + +a(95)+0.7*a(97)+a(103)+0.5*a(104)+a(107)+0.5*a(108) & + +0.7*a(115)+0.5*a(116)+0.6*a(120)+0.2*a(122)+0.15 & + *a(124)+0.28*a(125)+0.63*a(126)+0.25*a(128) + a_var(34) = a(79)+a(82)+a(85)+a(86)+0.08*a(89)+0.5*a(90)+0.6 & + *a(92)+a(95)+0.03*a(97)+0.4*a(98)+0.4*a(101)+0.34 & + *a(102)-a(105)+0.4*a(106)-a(109)-a(113)+0.24*a(114) & + -a(117)+0.08*a(119)+0.2*a(120)+0.2*a(123)+0.07*a(124) & + +0.93*a(125) + a_var(35) = -a(76)-a(77)+0.07*a(84)+0.23*a(86)+0.74*a(98)+0.74 & + *a(101)+0.62*a(102)+0.74*a(106)+0.57*a(114)+0.15 & + *a(115)+0.03*a(122)+0.09*a(124)+0.63*a(128)+0.5 & + *a(134) + a_var(36) = -a(84)-a(86)-a(88) + a_var(37) = a(87)+a(88)+a(100)-a(104)-a(108)-a(112)-a(116) + a_var(38) = -a(78)-a(79)-a(80)+0.04*a(83)+0.07*a(84)+0.8*a(90) & + +0.2*a(97)+0.19*a(99)+0.15*a(115)+0.85*a(124)+0.34 & + *a(128) + a_var(39) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64)+0.06*a(83) & + +0.05*a(84)+0.1*a(98)+0.1*a(101)+0.08*a(102)+0.1 & + *a(106)+0.06*a(114) + a_var(40) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68)+0.22*a(82)+0.47*a(83)+1.03*a(84)+a(85) & + +1.77*a(86)+0.03*a(97)+0.3*a(98)+0.04*a(99)+0.3 & + *a(101)+0.25*a(102)+0.5*a(104)+0.3*a(106)+0.5*a(108) & + +0.21*a(114)+0.5*a(116)+0.15*a(120)+0.07*a(122)+0.02 & + *a(124)+0.28*a(125)+0.8*a(127)+0.55*a(128)+a(133)+0.5 & + *a(134) + a_var(41) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74)+a(76)+0.07*a(83)+0.1*a(84)+0.7*a(122) & + +0.05*a(124) + a_var(42) = 0.65*a(120)-a(122)-a(123)-a(124)-a(125)+0.91*a(126) & + +0.2*a(127)+a(132) + a_var(43) = a(77)+0.11*a(84)-a(103)-a(107)-a(111)-a(115) + a_var(44) = -a(98)-a(99)+a(110)+a(111)+a(129)+a(131) + a_var(45) = a(75)+0.03*a(83)+0.09*a(84)+0.77*a(99)-a(102)-a(106) & + -a(110)-a(114) + a_var(46) = 0.05*a(91)+a(94)-a(100)-a(101)+0.16*a(102)+0.5 & + *a(104)+0.5*a(108)+a(112)+0.5*a(116)+0.93*a(125)+0.09 & + *a(126)+0.8*a(127)+a(130)+a(133) + a_var(47) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) & + +a(76)+a(78)+a(79)+a(80)+0.13*a(83)+0.19*a(84)+a(95) & + +a(96)+0.62*a(97)+a(103)+a(107)+0.7*a(115)+0.2*a(120) & + +0.97*a(122)+0.5*a(123)+0.11*a(124)+0.07*a(125) + a_var(48) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67)-a(75)-a(77) & + -a(79)+0.12*a(81)-a(82)+0.33*a(83)+0.6*a(84)-a(85) & + -a(86)-a(89)-a(90)-a(92)-a(95)+0.08*a(97)+a(98)-0.77 & + *a(99)-a(100)-a(119)+0.27*a(120)-a(123)+0.27*a(124) + a_var(49) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73)-a(81)-a(83)-a(84)-a(97)-a(120)-a(124) + a_var(50) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73)+a(78)+0.22*a(81)+a(82)+0.26*a(83)+0.22 & + *a(84)+a(85)+a(86)+0.2*a(89)+0.55*a(90)+0.95*a(91) & + +0.6*a(92)+2*a(95)+a(96)+0.76*a(97)+0.9*a(98)+0.9 & + *a(101)+0.76*a(102)+0.5*a(104)+0.9*a(106)+0.5*a(108) & + -a(110)-a(111)-a(112)-a(113)+0.54*a(114)+0.07*a(120) & + +0.33*a(122)+0.1*a(124)+0.93*a(125)+0.91*a(126)+0.8 & + *a(127)+a(128)-a(129)-a(130)-a(131) + a_var(51) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71)-a(91)-a(102)-a(103) & + -a(104)-a(105)-a(126)-a(127)-a(128) + a_var(52) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72)+0.95 & + *a(91)-a(94)+a(101)+0.84*a(102)+a(103)+1.5*a(104) & + +a(105)+a(106)+a(107)+1.5*a(108)+a(109)+0.5*a(116) & + +0.91*a(126)+1.2*a(127)+a(128) + a_var(53) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) & + -a(80)-a(87)-a(88)-a(93)-a(106)-a(107)-a(108)-a(109) & + -a(121)-a(125) + return + end subroutine cbmz_v02r03_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r03 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r03_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r03_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r03_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r03_kpp,nvar_r03_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,52) = rconst(1) + b(2,53) = rconst(2) + b(3,19) = rconst(3) + b(4,24) = rconst(4) + b(5,14) = rconst(5) + b(6,11) = rconst(6) + b(7,49) = rconst(7) + b(8,49) = rconst(8) + b(9,7) = rconst(9) + b(10,4) = rconst(10)*f(4) + b(11,4) = rconst(11)*f(5) + b(12,4) = rconst(12)*f(2) + b(13,22) = rconst(13)*f(4) + b(14,22) = rconst(14)*v(49) + b(14,49) = rconst(14)*v(22) + b(15,22) = rconst(15)*v(52) + b(15,52) = rconst(15)*v(22) + b(16,22) = rconst(16)*v(52) + b(16,52) = rconst(16)*v(22) + b(17,22) = rconst(17)*v(51) + b(17,51) = rconst(17)*v(22) + b(18,49) = rconst(18)*v(51) + b(18,51) = rconst(18)*v(49) + b(19,49) = rconst(19)*v(52) + b(19,52) = rconst(19)*v(49) + b(20,48) = rconst(20)*v(49) + b(20,49) = rconst(20)*v(48) + b(21,49) = rconst(21)*v(50) + b(21,50) = rconst(21)*v(49) + b(22,48) = rconst(22)*f(3) + b(23,48) = rconst(23)*v(51) + b(23,51) = rconst(23)*v(48) + b(24,48) = rconst(24)*v(52) + b(24,52) = rconst(24)*v(48) + b(25,48) = rconst(25)*v(53) + b(25,53) = rconst(25)*v(48) + b(26,19) = rconst(26)*v(48) + b(26,48) = rconst(26)*v(19) + b(27,24) = rconst(27)*v(48) + b(27,48) = rconst(27)*v(24) + b(28,14) = rconst(28)*v(48) + b(28,48) = rconst(28)*v(14) + b(29,48) = rconst(29)*v(50) + b(29,50) = rconst(29)*v(48) + b(30,7) = rconst(30)*v(48) + b(30,48) = rconst(30)*v(7) + b(31,50) = rconst(31)*2*v(50) + b(32,50) = rconst(32)*2*v(50)*f(2) + b(33,50) = rconst(33)*v(51) + b(33,51) = rconst(33)*v(50) + b(34,50) = rconst(34)*v(52) + b(34,52) = rconst(34)*v(50) + b(35,50) = rconst(35)*v(52) + b(35,52) = rconst(35)*v(50) + b(36,14) = rconst(36) + b(37,51) = rconst(37)*v(53) + b(37,53) = rconst(37)*v(51) + b(38,52) = rconst(38)*v(53) + b(38,53) = rconst(38)*v(52) + b(39,52) = rconst(39)*v(53) + b(39,53) = rconst(39)*v(52) + b(40,53) = rconst(40)*2*v(53) + b(41,50) = rconst(41)*v(53) + b(41,53) = rconst(41)*v(50) + b(42,11) = rconst(42)*f(2) + b(43,11) = rconst(43) + b(44,25) = rconst(44)*v(48) + b(44,48) = rconst(44)*v(25) + b(45,5) = rconst(45)*v(48) + b(45,48) = rconst(45)*v(5) + b(46,48) = rconst(46)*f(1) + b(47,8) = rconst(47)*v(48) + b(47,48) = rconst(47)*v(8) + b(48,21) = rconst(48)*v(48) + b(48,48) = rconst(48)*v(21) + b(49,33) = rconst(49) + b(50,33) = rconst(50) + b(51,33) = rconst(51)*v(48) + b(51,48) = rconst(51)*v(33) + b(52,33) = rconst(52)*v(53) + b(52,53) = rconst(52)*v(33) + b(53,17) = rconst(53) + b(54,18) = rconst(54) + b(55,17) = rconst(55)*v(48) + b(55,48) = rconst(55)*v(17) + b(56,18) = rconst(56)*v(48) + b(56,48) = rconst(56)*v(18) + b(57,41) = rconst(57)*v(51) + b(57,51) = rconst(57)*v(41) + b(58,39) = rconst(58)*v(51) + b(58,51) = rconst(58)*v(39) + b(59,41) = rconst(59)*v(53) + b(59,53) = rconst(59)*v(41) + b(60,39) = rconst(60)*v(53) + b(60,53) = rconst(60)*v(39) + b(61,41) = rconst(61)*v(50) + b(61,50) = rconst(61)*v(41) + b(62,39) = rconst(62)*v(50) + b(62,50) = rconst(62)*v(39) + b(63,41) = rconst(63) + b(64,39) = rconst(64) + b(65,6) = rconst(65)*v(48) + b(65,48) = rconst(65)*v(6) + b(66,40) = rconst(66) + b(67,40) = rconst(67)*v(48) + b(67,48) = rconst(67)*v(40) + b(68,40) = rconst(68)*v(53) + b(68,53) = rconst(68)*v(40) + b(69,47) = rconst(69)*v(52) + b(69,52) = rconst(69)*v(47) + b(70,9) = rconst(70) + b(71,47) = rconst(71)*v(51) + b(71,51) = rconst(71)*v(47) + b(72,47) = rconst(72)*v(53) + b(72,53) = rconst(72)*v(47) + b(73,47) = rconst(73)*v(50) + b(73,50) = rconst(73)*v(47) + b(74,47) = rconst(74) + b(75,26) = rconst(75)*v(48) + b(75,48) = rconst(75)*v(26) + b(76,35) = rconst(76) + b(77,35) = rconst(77)*v(48) + b(77,48) = rconst(77)*v(35) + b(78,38) = rconst(78) + b(79,38) = rconst(79)*v(48) + b(79,48) = rconst(79)*v(38) + b(80,38) = rconst(80)*v(53) + b(80,53) = rconst(80)*v(38) + b(81,20) = rconst(81)*v(49) + b(81,49) = rconst(81)*v(20) + b(82,20) = rconst(82)*v(48) + b(82,48) = rconst(82)*v(20) + b(83,31) = rconst(83)*v(49) + b(83,49) = rconst(83)*v(31) + b(84,36) = rconst(84)*v(49) + b(84,49) = rconst(84)*v(36) + b(85,31) = rconst(85)*v(48) + b(85,48) = rconst(85)*v(31) + b(86,36) = rconst(86)*v(48) + b(86,48) = rconst(86)*v(36) + b(87,31) = rconst(87)*v(53) + b(87,53) = rconst(87)*v(31) + b(88,36) = rconst(88)*v(53) + b(88,53) = rconst(88)*v(36) + b(89,10) = rconst(89)*v(48) + b(89,48) = rconst(89)*v(10) + b(90,12) = rconst(90)*v(48) + b(90,48) = rconst(90)*v(12) + b(91,15) = rconst(91)*v(51) + b(91,51) = rconst(91)*v(15) + b(92,23) = rconst(92)*v(48) + b(92,48) = rconst(92)*v(23) + b(93,23) = rconst(93)*v(53) + b(93,53) = rconst(93)*v(23) + b(94,13) = rconst(94)*v(52) + b(94,52) = rconst(94)*v(13) + b(95,27) = rconst(95)*v(48) + b(95,48) = rconst(95)*v(27) + b(96,27) = rconst(96) + b(97,27) = rconst(97)*v(49) + b(97,49) = rconst(97)*v(27) + b(98,44) = rconst(98) + b(99,44) = rconst(99)*v(48) + b(99,48) = rconst(99)*v(44) + b(100,46) = rconst(100)*v(48) + b(100,48) = rconst(100)*v(46) + b(101,46) = rconst(101) + b(102,45) = rconst(102)*v(51) + b(102,51) = rconst(102)*v(45) + b(103,43) = rconst(103)*v(51) + b(103,51) = rconst(103)*v(43) + b(104,37) = rconst(104)*v(51) + b(104,51) = rconst(104)*v(37) + b(105,34) = rconst(105)*v(51) + b(105,51) = rconst(105)*v(34) + b(106,45) = rconst(106)*v(53) + b(106,53) = rconst(106)*v(45) + b(107,43) = rconst(107)*v(53) + b(107,53) = rconst(107)*v(43) + b(108,37) = rconst(108)*v(53) + b(108,53) = rconst(108)*v(37) + b(109,34) = rconst(109)*v(53) + b(109,53) = rconst(109)*v(34) + b(110,45) = rconst(110)*v(50) + b(110,50) = rconst(110)*v(45) + b(111,43) = rconst(111)*v(50) + b(111,50) = rconst(111)*v(43) + b(112,37) = rconst(112)*v(50) + b(112,50) = rconst(112)*v(37) + b(113,34) = rconst(113)*v(50) + b(113,50) = rconst(113)*v(34) + b(114,45) = rconst(114) + b(115,43) = rconst(115) + b(116,37) = rconst(116) + b(117,34) = rconst(117) + b(118,16) = rconst(118)*v(26) + b(118,26) = rconst(118)*v(16) + b(119,32) = rconst(119)*v(48) + b(119,48) = rconst(119)*v(32) + b(120,32) = rconst(120)*v(49) + b(120,49) = rconst(120)*v(32) + b(121,32) = rconst(121)*v(53) + b(121,53) = rconst(121)*v(32) + b(122,42) = rconst(122) + b(123,42) = rconst(123)*v(48) + b(123,48) = rconst(123)*v(42) + b(124,42) = rconst(124)*v(49) + b(124,49) = rconst(124)*v(42) + b(125,42) = rconst(125)*v(53) + b(125,53) = rconst(125)*v(42) + b(126,29) = rconst(126)*v(51) + b(126,51) = rconst(126)*v(29) + b(127,28) = rconst(127)*v(51) + b(127,51) = rconst(127)*v(28) + b(128,30) = rconst(128)*v(51) + b(128,51) = rconst(128)*v(30) + b(129,29) = rconst(129)*v(50) + b(129,50) = rconst(129)*v(29) + b(130,28) = rconst(130)*v(50) + b(130,50) = rconst(130)*v(28) + b(131,30) = rconst(131)*v(50) + b(131,50) = rconst(131)*v(30) + b(132,29) = rconst(132) + b(133,28) = rconst(133) + b(134,30) = rconst(134) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,5) + jvs(3) = b(45,48) + jvs(4) = 0 + jvs(5) = 0.52*b(81,20) + jvs(6) = 0.22*b(83,31) + jvs(7) = 0.39*b(120,32) + jvs(8) = 0.46*b(124,42) + jvs(9) = 0.52*b(81,49)+0.22*b(83,49)+0.39*b(120,49)+0.46 & + *b(124,49) + jvs(10) = 0 + jvs(11) = 0.09*b(83,31) + jvs(12) = 0.16*b(84,36) + jvs(13) = 0.4*b(73,47) + jvs(14) = 0.09*b(83,49)+0.16*b(84,49) + jvs(15) = 0.4*b(73,50) + jvs(16) = -b(10,4)-b(11,4)-b(12,4) + jvs(17) = b(8,49) + jvs(18) = -b(45,5) + jvs(19) = -b(45,48) + jvs(20) = -b(65,6) + jvs(21) = -b(65,48) + jvs(22) = -b(9,7)-b(30,7) + jvs(23) = -b(30,48) + jvs(24) = b(31,50)+b(32,50) + jvs(25) = -b(47,8) + jvs(26) = 0.2*b(64,39) + jvs(27) = -b(47,48) + jvs(28) = -b(70,9) + jvs(29) = b(69,47) + jvs(30) = b(69,52) + jvs(31) = -b(89,10) + jvs(32) = -b(89,48) + jvs(33) = -b(6,11)-b(42,11)-b(43,11) + jvs(34) = b(39,52) + jvs(35) = b(39,53) + jvs(36) = -b(90,12) + jvs(37) = -b(90,48) + jvs(38) = -b(94,13) + jvs(39) = 0.4*b(92,23)+b(93,23) + jvs(40) = 0.4*b(92,48) + jvs(41) = -b(94,52) + jvs(42) = b(93,53) + jvs(43) = -b(5,14)-b(28,14)-b(36,14) + jvs(44) = -b(28,48) + jvs(45) = b(34,50) + jvs(46) = b(34,52) + jvs(47) = 0.8*b(89,10) + jvs(48) = 0.45*b(90,12) + jvs(49) = -b(91,15) + jvs(50) = 0.8*b(89,48)+0.45*b(90,48) + jvs(51) = -b(91,51) + jvs(52) = -b(118,16) + jvs(53) = -b(118,26) + jvs(54) = 1.06*b(83,31)+b(85,31) + jvs(55) = 2.26*b(84,36)+2.23*b(86,36) + jvs(56) = b(104,37)+b(108,37)+b(116,37) + jvs(57) = 1.98*b(98,44)+0.42*b(99,44) + jvs(58) = 1.68*b(102,45)+1.98*b(106,45)+1.25*b(114,45) + jvs(59) = 1.98*b(101,46) + jvs(60) = b(85,48)+2.23*b(86,48)+0.42*b(99,48) + jvs(61) = 1.06*b(83,49)+2.26*b(84,49) + jvs(62) = 1.68*b(102,51)+b(104,51) + jvs(63) = 1.98*b(106,53)+b(108,53) + jvs(64) = -b(53,17)-b(55,17) + jvs(65) = b(61,41) + jvs(66) = -b(55,48) + jvs(67) = b(61,50) + jvs(68) = -b(54,18)-b(56,18) + jvs(69) = b(62,39) + jvs(70) = -b(56,48) + jvs(71) = b(62,50) + jvs(72) = -b(3,19)-b(26,19) + jvs(73) = b(23,48)-b(26,48) + jvs(74) = b(35,50) + jvs(75) = b(23,51) + jvs(76) = b(35,52) + jvs(77) = -b(81,20)-b(82,20) + jvs(78) = -b(82,48) + jvs(79) = -b(81,49) + jvs(80) = -b(48,21) + jvs(81) = 0.03*b(83,31) + jvs(82) = 0.04*b(84,36) + jvs(83) = 0.34*b(63,41) + jvs(84) = -b(48,48) + jvs(85) = 0.03*b(83,49)+0.04*b(84,49) + jvs(86) = b(10,4)+b(11,4) + jvs(87) = -b(13,22)-b(14,22)-b(15,22)-b(16,22)-b(17,22) + jvs(88) = b(7,49)-b(14,49) + jvs(89) = -b(17,51) + jvs(90) = b(1,52)-b(15,52)-b(16,52) + jvs(91) = 0.89*b(2,53) + jvs(92) = 0.12*b(89,10) + jvs(93) = 0.05*b(90,12) + jvs(94) = -b(92,23)-b(93,23) + jvs(95) = 0.12*b(89,48)+0.05*b(90,48)-b(92,48) + jvs(96) = -b(93,53) + jvs(97) = 2*b(42,11) + jvs(98) = b(93,23) + jvs(99) = -b(4,24)-b(27,24) + jvs(100) = b(52,33) + jvs(101) = b(80,38) + jvs(102) = b(68,40) + jvs(103) = 0.07*b(125,42) + jvs(104) = b(24,48)-b(27,48) + jvs(105) = 0.3*b(41,50) + jvs(106) = b(24,52) + jvs(107) = 0.3*b(41,53)+b(52,53)+b(68,53)+b(80,53)+b(93,53)+0.07 & + *b(125,53) + jvs(108) = 0.24*b(81,20) + jvs(109) = -b(44,25) + jvs(110) = 2*b(95,27)+b(96,27)+0.69*b(97,27) + jvs(111) = 0.59*b(128,30) + jvs(112) = 0.31*b(83,31) + jvs(113) = 0.07*b(120,32) + jvs(114) = b(49,33)+b(50,33)+b(51,33)+b(52,33) + jvs(115) = 0.3*b(84,36) + jvs(116) = b(78,38)+b(80,38) + jvs(117) = b(66,40) + jvs(118) = 0.33*b(122,42)+0.16*b(124,42)+0.64*b(125,42) + jvs(119) = -b(44,48)+b(51,48)+2*b(95,48) + jvs(120) = 0.24*b(81,49)+0.31*b(83,49)+0.3*b(84,49)+0.69 & + *b(97,49)+0.07*b(120,49)+0.16*b(124,49) + jvs(121) = 0.59*b(128,51) + jvs(122) = b(52,53)+b(80,53)+0.64*b(125,53) + jvs(123) = 1.1*b(90,12) + jvs(124) = -b(118,16) + jvs(125) = -b(75,26)-b(118,26) + jvs(126) = 1.6*b(127,28)+2*b(130,28)+2*b(133,28) + jvs(127) = 0.18*b(126,29) + jvs(128) = 0 + jvs(129) = 0 + jvs(130) = 0 + jvs(131) = 1.86*b(125,42) + jvs(132) = 0 + jvs(133) = 0 + jvs(134) = 0 + jvs(135) = -b(75,48)+1.1*b(90,48) + jvs(136) = 0 + jvs(137) = 2*b(130,50) + jvs(138) = 0.18*b(126,51)+1.6*b(127,51) + jvs(139) = 1.86*b(125,53) + jvs(140) = 0.95*b(91,15) + jvs(141) = 0.3*b(92,23) + jvs(142) = -b(95,27)-b(96,27)-b(97,27) + jvs(143) = 0.3*b(92,48)-b(95,48) + jvs(144) = -b(97,49) + jvs(145) = 0.95*b(91,51) + jvs(146) = 0 + jvs(147) = -b(127,28)-b(130,28)-b(133,28) + jvs(148) = b(121,32) + jvs(149) = -b(130,50) + jvs(150) = -b(127,51) + jvs(151) = b(121,53) + jvs(152) = -b(126,29)-b(129,29)-b(132,29) + jvs(153) = b(119,32) + jvs(154) = b(119,48) + jvs(155) = -b(129,50) + jvs(156) = -b(126,51) + jvs(157) = -b(128,30)-b(131,30)-b(134,30) + jvs(158) = 0.5*b(123,42) + jvs(159) = 0.5*b(123,48) + jvs(160) = -b(131,50) + jvs(161) = -b(128,51) + jvs(162) = -b(83,31)-b(85,31)-b(87,31) + jvs(163) = -b(85,48) + jvs(164) = -b(83,49) + jvs(165) = -b(87,53) + jvs(166) = -b(119,32)-b(120,32)-b(121,32) + jvs(167) = -b(119,48) + jvs(168) = -b(120,49) + jvs(169) = -b(121,53) + jvs(170) = b(53,17)+0.3*b(55,17) + jvs(171) = b(81,20)+1.56*b(82,20) + jvs(172) = b(48,21) + jvs(173) = b(95,27)+0.7*b(97,27) + jvs(174) = 0.63*b(126,29) + jvs(175) = 0.25*b(128,30) + jvs(176) = 0.57*b(83,31)+b(85,31) + jvs(177) = 0.6*b(120,32) + jvs(178) = -b(49,33)-b(50,33)-b(51,33)-b(52,33) + jvs(179) = 0 + jvs(180) = 0.5*b(104,37)+0.5*b(108,37)+0.5*b(116,37) + jvs(181) = b(57,41)+b(59,41)+0.66*b(63,41) + jvs(182) = 0.2*b(122,42)+0.15*b(124,42)+0.28*b(125,42) + jvs(183) = b(103,43)+b(107,43)+0.7*b(115,43) + jvs(184) = b(48,48)-b(51,48)+0.3*b(55,48)+1.56*b(82,48)+b(85,48) & + +b(95,48) + jvs(185) = b(81,49)+0.57*b(83,49)+0.7*b(97,49)+0.6*b(120,49) & + +0.15*b(124,49) + jvs(186) = 0 + jvs(187) = b(57,51)+b(103,51)+0.5*b(104,51)+0.63*b(126,51)+0.25 & + *b(128,51) + jvs(188) = -b(52,53)+b(59,53)+b(107,53)+0.5*b(108,53)+0.28 & + *b(125,53) + jvs(189) = 0.08*b(89,10) + jvs(190) = 0.5*b(90,12) + jvs(191) = b(82,20) + jvs(192) = 0.6*b(92,23) + jvs(193) = b(95,27)+0.03*b(97,27) + jvs(194) = b(85,31) + jvs(195) = 0.08*b(119,32)+0.2*b(120,32) + jvs(196) = -b(105,34)-b(109,34)-b(113,34)-b(117,34) + jvs(197) = b(86,36) + jvs(198) = b(79,38) + jvs(199) = 0.2*b(123,42)+0.07*b(124,42)+0.93*b(125,42) + jvs(200) = 0.4*b(98,44) + jvs(201) = 0.34*b(102,45)+0.4*b(106,45)+0.24*b(114,45) + jvs(202) = 0.4*b(101,46) + jvs(203) = b(79,48)+b(82,48)+b(85,48)+b(86,48)+0.08*b(89,48)+0.5 & + *b(90,48)+0.6*b(92,48)+b(95,48)+0.08*b(119,48)+0.2 & + *b(123,48) + jvs(204) = 0.03*b(97,49)+0.2*b(120,49)+0.07*b(124,49) + jvs(205) = -b(113,50) + jvs(206) = 0.34*b(102,51)-b(105,51) + jvs(207) = 0.4*b(106,53)-b(109,53)+0.93*b(125,53) + jvs(208) = 0.63*b(128,30)+0.5*b(134,30) + jvs(209) = -b(76,35)-b(77,35) + jvs(210) = 0.07*b(84,36)+0.23*b(86,36) + jvs(211) = 0.03*b(122,42)+0.09*b(124,42) + jvs(212) = 0.15*b(115,43) + jvs(213) = 0.74*b(98,44) + jvs(214) = 0.62*b(102,45)+0.74*b(106,45)+0.57*b(114,45) + jvs(215) = 0.74*b(101,46) + jvs(216) = -b(77,48)+0.23*b(86,48) + jvs(217) = 0.07*b(84,49)+0.09*b(124,49) + jvs(218) = 0 + jvs(219) = 0.62*b(102,51)+0.63*b(128,51) + jvs(220) = 0.74*b(106,53) + jvs(221) = -b(84,36)-b(86,36)-b(88,36) + jvs(222) = -b(86,48) + jvs(223) = -b(84,49) + jvs(224) = -b(88,53) + jvs(225) = b(87,31) + jvs(226) = b(88,36) + jvs(227) = -b(104,37)-b(108,37)-b(112,37)-b(116,37) + jvs(228) = b(100,46) + jvs(229) = b(100,48) + jvs(230) = 0 + jvs(231) = -b(112,50) + jvs(232) = -b(104,51) + jvs(233) = b(87,53)+b(88,53)-b(108,53) + jvs(234) = 0.8*b(90,12) + jvs(235) = 0.2*b(97,27) + jvs(236) = 0.34*b(128,30) + jvs(237) = 0.04*b(83,31) + jvs(238) = 0.07*b(84,36) + jvs(239) = -b(78,38)-b(79,38)-b(80,38) + jvs(240) = 0.85*b(124,42) + jvs(241) = 0.15*b(115,43) + jvs(242) = 0.19*b(99,44) + jvs(243) = -b(79,48)+0.8*b(90,48)+0.19*b(99,48) + jvs(244) = 0.04*b(83,49)+0.07*b(84,49)+0.2*b(97,49)+0.85 & + *b(124,49) + jvs(245) = 0 + jvs(246) = 0.34*b(128,51) + jvs(247) = -b(80,53) + jvs(248) = b(47,8) + jvs(249) = 0.5*b(56,18) + jvs(250) = 0.06*b(83,31) + jvs(251) = 0.05*b(84,36) + jvs(252) = -b(58,39)-b(60,39)-b(62,39)-b(64,39) + jvs(253) = 0.1*b(98,44) + jvs(254) = 0.08*b(102,45)+0.1*b(106,45)+0.06*b(114,45) + jvs(255) = 0.1*b(101,46) + jvs(256) = b(47,48)+0.5*b(56,48) + jvs(257) = 0.06*b(83,49)+0.05*b(84,49) + jvs(258) = -b(62,50) + jvs(259) = -b(58,51)+0.08*b(102,51) + jvs(260) = -b(60,53)+0.1*b(106,53) + jvs(261) = b(65,6) + jvs(262) = b(54,18)+0.5*b(56,18) + jvs(263) = 0.22*b(82,20) + jvs(264) = 0.03*b(97,27) + jvs(265) = 0.8*b(127,28)+b(133,28) + jvs(266) = 0.55*b(128,30)+0.5*b(134,30) + jvs(267) = 0.47*b(83,31)+b(85,31) + jvs(268) = 0.15*b(120,32) + jvs(269) = 1.03*b(84,36)+1.77*b(86,36) + jvs(270) = 0.5*b(104,37)+0.5*b(108,37)+0.5*b(116,37) + jvs(271) = b(58,39)+b(60,39)+0.8*b(64,39) + jvs(272) = -b(66,40)-b(67,40)-b(68,40) + jvs(273) = 0.07*b(122,42)+0.02*b(124,42)+0.28*b(125,42) + jvs(274) = 0.3*b(98,44)+0.04*b(99,44) + jvs(275) = 0.25*b(102,45)+0.3*b(106,45)+0.21*b(114,45) + jvs(276) = 0.3*b(101,46) + jvs(277) = 0.5*b(56,48)+b(65,48)-b(67,48)+0.22*b(82,48)+b(85,48) & + +1.77*b(86,48)+0.04*b(99,48) + jvs(278) = 0.47*b(83,49)+1.03*b(84,49)+0.03*b(97,49)+0.15 & + *b(120,49)+0.02*b(124,49) + jvs(279) = 0 + jvs(280) = b(58,51)+0.25*b(102,51)+0.5*b(104,51)+0.8*b(127,51) & + +0.55*b(128,51) + jvs(281) = b(60,53)-b(68,53)+0.3*b(106,53)+0.5*b(108,53)+0.28 & + *b(125,53) + jvs(282) = 0.7*b(55,17) + jvs(283) = 0.07*b(83,31) + jvs(284) = b(76,35) + jvs(285) = 0.1*b(84,36) + jvs(286) = b(66,40) + jvs(287) = -b(57,41)-b(59,41)-b(61,41)-b(63,41) + jvs(288) = 0.7*b(122,42)+0.05*b(124,42) + jvs(289) = 0 + jvs(290) = 0 + jvs(291) = 0 + jvs(292) = 0 + jvs(293) = b(71,47)+b(72,47)+b(74,47) + jvs(294) = b(46,48)+0.7*b(55,48) + jvs(295) = 0.07*b(83,49)+0.1*b(84,49)+0.05*b(124,49) + jvs(296) = -b(61,50) + jvs(297) = -b(57,51)+b(71,51) + jvs(298) = -b(59,53)+b(72,53) + jvs(299) = 0.2*b(127,28) + jvs(300) = 0.91*b(126,29)+b(132,29) + jvs(301) = 0.65*b(120,32) + jvs(302) = -b(122,42)-b(123,42)-b(124,42)-b(125,42) + jvs(303) = -b(123,48) + jvs(304) = 0.65*b(120,49)-b(124,49) + jvs(305) = 0 + jvs(306) = 0.91*b(126,51)+0.2*b(127,51) + jvs(307) = -b(125,53) + jvs(308) = b(77,35) + jvs(309) = 0.11*b(84,36) + jvs(310) = 0 + jvs(311) = -b(103,43)-b(107,43)-b(111,43)-b(115,43) + jvs(312) = 0 + jvs(313) = 0 + jvs(314) = 0 + jvs(315) = b(77,48) + jvs(316) = 0.11*b(84,49) + jvs(317) = -b(111,50) + jvs(318) = -b(103,51) + jvs(319) = -b(107,53) + jvs(320) = b(129,29) + jvs(321) = b(131,30) + jvs(322) = 0 + jvs(323) = 0 + jvs(324) = b(111,43) + jvs(325) = -b(98,44)-b(99,44) + jvs(326) = b(110,45) + jvs(327) = 0 + jvs(328) = -b(99,48) + jvs(329) = 0 + jvs(330) = b(110,50)+b(111,50)+b(129,50)+b(131,50) + jvs(331) = 0 + jvs(332) = 0 + jvs(333) = b(75,26) + jvs(334) = 0 + jvs(335) = 0 + jvs(336) = 0.03*b(83,31) + jvs(337) = 0 + jvs(338) = 0.09*b(84,36) + jvs(339) = 0 + jvs(340) = 0 + jvs(341) = 0.77*b(99,44) + jvs(342) = -b(102,45)-b(106,45)-b(110,45)-b(114,45) + jvs(343) = 0 + jvs(344) = b(75,48)+0.77*b(99,48) + jvs(345) = 0.03*b(83,49)+0.09*b(84,49) + jvs(346) = -b(110,50) + jvs(347) = -b(102,51) + jvs(348) = -b(106,53) + jvs(349) = b(94,13) + jvs(350) = 0.05*b(91,15) + jvs(351) = 0 + jvs(352) = 0.8*b(127,28)+b(130,28)+b(133,28) + jvs(353) = 0.09*b(126,29) + jvs(354) = 0 + jvs(355) = 0.5*b(104,37)+0.5*b(108,37)+b(112,37)+0.5*b(116,37) + jvs(356) = 0.93*b(125,42) + jvs(357) = 0.16*b(102,45) + jvs(358) = -b(100,46)-b(101,46) + jvs(359) = -b(100,48) + jvs(360) = 0 + jvs(361) = b(112,50)+b(130,50) + jvs(362) = 0.05*b(91,51)+0.16*b(102,51)+0.5*b(104,51)+0.09 & + *b(126,51)+0.8*b(127,51) + jvs(363) = b(94,52) + jvs(364) = 0.5*b(108,53)+0.93*b(125,53) + jvs(365) = b(70,9) + jvs(366) = b(95,27)+b(96,27)+0.62*b(97,27) + jvs(367) = 0.13*b(83,31) + jvs(368) = 0.2*b(120,32) + jvs(369) = b(76,35) + jvs(370) = 0.19*b(84,36) + jvs(371) = b(78,38)+b(79,38)+b(80,38) + jvs(372) = b(67,40)+b(68,40) + jvs(373) = 0.97*b(122,42)+0.5*b(123,42)+0.11*b(124,42)+0.07 & + *b(125,42) + jvs(374) = b(103,43)+b(107,43)+0.7*b(115,43) + jvs(375) = 0 + jvs(376) = 0 + jvs(377) = 0 + jvs(378) = -b(69,47)-b(71,47)-b(72,47)-b(73,47)-b(74,47) + jvs(379) = b(67,48)+b(79,48)+b(95,48)+0.5*b(123,48) + jvs(380) = 0.13*b(83,49)+0.19*b(84,49)+0.62*b(97,49)+0.2 & + *b(120,49)+0.11*b(124,49) + jvs(381) = -b(73,50) + jvs(382) = -b(71,51)+b(103,51) + jvs(383) = -b(69,52) + jvs(384) = b(68,53)-b(72,53)+b(80,53)+b(107,53)+0.07*b(125,53) + jvs(385) = 2*b(12,4) + jvs(386) = -b(45,5) + jvs(387) = -b(65,6) + jvs(388) = 2*b(9,7)-b(30,7) + jvs(389) = -b(47,8) + jvs(390) = -b(89,10) + jvs(391) = -b(90,12) + jvs(392) = -b(28,14) + jvs(393) = b(53,17)-0.7*b(55,17) + jvs(394) = b(54,18)-0.5*b(56,18) + jvs(395) = b(3,19)-b(26,19) + jvs(396) = 0.12*b(81,20)-b(82,20) + jvs(397) = -b(48,21) + jvs(398) = -b(92,23) + jvs(399) = b(4,24)-b(27,24) + jvs(400) = -b(44,25) + jvs(401) = -b(75,26) + jvs(402) = -b(95,27)+0.08*b(97,27) + jvs(403) = 0 + jvs(404) = 0 + jvs(405) = 0 + jvs(406) = 0.33*b(83,31)-b(85,31) + jvs(407) = -b(119,32)+0.27*b(120,32) + jvs(408) = -b(51,33) + jvs(409) = -b(77,35) + jvs(410) = 0.6*b(84,36)-b(86,36) + jvs(411) = 0 + jvs(412) = -b(79,38) + jvs(413) = 0 + jvs(414) = -b(67,40) + jvs(415) = 0 + jvs(416) = -b(123,42)+0.27*b(124,42) + jvs(417) = 0 + jvs(418) = b(98,44)-0.77*b(99,44) + jvs(419) = 0 + jvs(420) = -b(100,46) + jvs(421) = 0 + jvs(422) = -b(20,48)-b(22,48)-b(23,48)-b(24,48)-b(25,48) & + -b(26,48)-b(27,48)-b(28,48)-b(29,48)-b(30,48)-b(44,48) & + -b(45,48)-b(46,48)-b(47,48)-b(48,48)-b(51,48)-0.7 & + *b(55,48)-0.5*b(56,48)-b(65,48)-b(67,48)-b(75,48) & + -b(77,48)-b(79,48)-b(82,48)-b(85,48)-b(86,48)-b(89,48) & + -b(90,48)-b(92,48)-b(95,48)-0.77*b(99,48)-b(100,48) & + -b(119,48)-b(123,48) + jvs(423) = -b(20,49)+b(21,49)+0.12*b(81,49)+0.33*b(83,49)+0.6 & + *b(84,49)+0.08*b(97,49)+0.27*b(120,49)+0.27*b(124,49) + jvs(424) = b(21,50)-b(29,50)+b(33,50)+0.7*b(41,50) + jvs(425) = -b(23,51)+b(33,51) + jvs(426) = -b(24,52) + jvs(427) = -b(25,53)+0.7*b(41,53) + jvs(428) = -b(81,20) + jvs(429) = b(13,22)-b(14,22) + jvs(430) = -b(97,27) + jvs(431) = -b(83,31) + jvs(432) = -b(120,32) + jvs(433) = -b(84,36) + jvs(434) = -b(124,42) + jvs(435) = 0.4*b(73,47) + jvs(436) = -b(20,48) + jvs(437) = -b(7,49)-b(8,49)-b(14,49)-b(18,49)-b(19,49)-b(20,49) & + -b(21,49)-b(81,49)-b(83,49)-b(84,49)-b(97,49) & + -b(120,49)-b(124,49) + jvs(438) = -b(21,50)+0.4*b(73,50) + jvs(439) = -b(18,51) + jvs(440) = -b(19,52) + jvs(441) = 0 + jvs(442) = b(45,5) + jvs(443) = b(65,6) + jvs(444) = b(30,7) + jvs(445) = 0.2*b(89,10) + jvs(446) = 0.55*b(90,12) + jvs(447) = b(5,14)+b(36,14) + jvs(448) = 0.95*b(91,15) + jvs(449) = b(53,17) + jvs(450) = b(54,18) + jvs(451) = 0.22*b(81,20)+b(82,20) + jvs(452) = b(48,21) + jvs(453) = 0.6*b(92,23) + jvs(454) = b(44,25) + jvs(455) = 2*b(95,27)+b(96,27)+0.76*b(97,27) + jvs(456) = 0.8*b(127,28)-b(130,28) + jvs(457) = 0.91*b(126,29)-b(129,29) + jvs(458) = b(128,30)-b(131,30) + jvs(459) = 0.26*b(83,31)+b(85,31) + jvs(460) = 0.07*b(120,32) + jvs(461) = 2*b(49,33)+b(51,33)+b(52,33) + jvs(462) = -b(113,34) + jvs(463) = 0.22*b(84,36)+b(86,36) + jvs(464) = 0.5*b(104,37)+0.5*b(108,37)-b(112,37) + jvs(465) = b(78,38) + jvs(466) = b(58,39)+b(60,39)-b(62,39)+0.6*b(64,39) + jvs(467) = b(66,40) + jvs(468) = b(57,41)+b(59,41)-b(61,41)+0.32*b(63,41) + jvs(469) = 0.33*b(122,42)+0.1*b(124,42)+0.93*b(125,42) + jvs(470) = -b(111,43) + jvs(471) = 0.9*b(98,44) + jvs(472) = 0.76*b(102,45)+0.9*b(106,45)-b(110,45)+0.54*b(114,45) + jvs(473) = 0.9*b(101,46) + jvs(474) = -b(73,47) + jvs(475) = b(20,48)+b(22,48)+b(25,48)-b(29,48)+b(30,48)+b(44,48) & + +b(45,48)+b(48,48)+b(51,48)+b(65,48)+b(82,48)+b(85,48) & + +b(86,48)+0.2*b(89,48)+0.55*b(90,48)+0.6*b(92,48)+2 & + *b(95,48) + jvs(476) = b(20,49)-b(21,49)+0.22*b(81,49)+0.26*b(83,49)+0.22 & + *b(84,49)+0.76*b(97,49)+0.07*b(120,49)+0.1*b(124,49) + jvs(477) = -b(21,50)-b(29,50)-2*b(31,50)-2*b(32,50)-b(33,50) & + -b(34,50)-b(35,50)-b(41,50)-b(61,50)-b(62,50)-b(73,50) & + -b(110,50)-b(111,50)-b(112,50)-b(113,50)-b(129,50) & + -b(130,50)-b(131,50) + jvs(478) = -b(33,51)+b(57,51)+b(58,51)+0.95*b(91,51)+0.76 & + *b(102,51)+0.5*b(104,51)+0.91*b(126,51)+0.8*b(127,51) & + +b(128,51) + jvs(479) = -b(34,52)-b(35,52) + jvs(480) = b(25,53)-b(41,53)+b(52,53)+b(59,53)+b(60,53)+0.9 & + *b(106,53)+0.5*b(108,53)+0.93*b(125,53) + jvs(481) = -b(91,15) + jvs(482) = b(3,19) + jvs(483) = b(15,22)-b(17,22) + jvs(484) = -b(127,28) + jvs(485) = -b(126,29) + jvs(486) = -b(128,30) + jvs(487) = 0 + jvs(488) = -b(105,34) + jvs(489) = 0 + jvs(490) = -b(104,37) + jvs(491) = 0 + jvs(492) = -b(58,39) + jvs(493) = -b(57,41) + jvs(494) = 0 + jvs(495) = -b(103,43) + jvs(496) = 0 + jvs(497) = -b(102,45) + jvs(498) = 0 + jvs(499) = -b(71,47) + jvs(500) = -b(23,48) + jvs(501) = -b(18,49) + jvs(502) = -b(33,50) + jvs(503) = -b(17,51)-b(18,51)-b(23,51)-b(33,51)-b(37,51) & + -b(57,51)-b(58,51)-b(71,51)-b(91,51)-b(102,51) & + -b(103,51)-b(104,51)-b(105,51)-b(126,51)-b(127,51) & + -b(128,51) + jvs(504) = b(1,52)+b(15,52)+b(38,52) + jvs(505) = 0.11*b(2,53)-b(37,53)+b(38,53) + jvs(506) = b(70,9) + jvs(507) = b(6,11)+b(43,11) + jvs(508) = -b(94,13) + jvs(509) = b(5,14)+b(28,14)+b(36,14) + jvs(510) = 0.95*b(91,15) + jvs(511) = b(26,19) + jvs(512) = -b(15,22)-b(16,22)+b(17,22) + jvs(513) = 0 + jvs(514) = b(4,24) + jvs(515) = 1.2*b(127,28) + jvs(516) = 0.91*b(126,29) + jvs(517) = b(128,30) + jvs(518) = 0 + jvs(519) = 0 + jvs(520) = b(105,34)+b(109,34) + jvs(521) = 0 + jvs(522) = 1.5*b(104,37)+1.5*b(108,37)+0.5*b(116,37) + jvs(523) = 0 + jvs(524) = b(58,39)+b(60,39) + jvs(525) = 0 + jvs(526) = b(57,41)+b(59,41) + jvs(527) = 0 + jvs(528) = b(103,43)+b(107,43) + jvs(529) = 0 + jvs(530) = 0.84*b(102,45)+b(106,45) + jvs(531) = b(101,46) + jvs(532) = -b(69,47)+b(71,47)+b(72,47) + jvs(533) = -b(24,48)+b(25,48)+b(26,48)+b(28,48) + jvs(534) = b(18,49)-b(19,49) + jvs(535) = b(33,50)-b(34,50)-b(35,50)+0.7*b(41,50) + jvs(536) = b(17,51)+b(18,51)+b(33,51)+2*b(37,51)+b(57,51) & + +b(58,51)+b(71,51)+0.95*b(91,51)+0.84*b(102,51) & + +b(103,51)+1.5*b(104,51)+b(105,51)+0.91*b(126,51)+1.2 & + *b(127,51)+b(128,51) + jvs(537) = -b(1,52)-b(15,52)-b(16,52)-b(19,52)-b(24,52)-b(34,52) & + -b(35,52)-b(39,52)-b(69,52)-b(94,52) + jvs(538) = 0.89*b(2,53)+b(25,53)+2*b(37,53)-b(39,53)+2*b(40,53) & + +0.7*b(41,53)+b(59,53)+b(60,53)+b(72,53)+b(106,53) & + +b(107,53)+1.5*b(108,53)+b(109,53) + jvs(539) = b(6,11)+b(43,11) + jvs(540) = b(16,22) + jvs(541) = -b(93,23) + jvs(542) = b(27,24) + jvs(543) = -b(87,31) + jvs(544) = -b(121,32) + jvs(545) = -b(52,33) + jvs(546) = -b(109,34) + jvs(547) = -b(88,36) + jvs(548) = -b(108,37) + jvs(549) = -b(80,38) + jvs(550) = -b(60,39) + jvs(551) = -b(68,40) + jvs(552) = -b(59,41) + jvs(553) = -b(125,42) + jvs(554) = -b(107,43) + jvs(555) = 0 + jvs(556) = -b(106,45) + jvs(557) = 0 + jvs(558) = -b(72,47) + jvs(559) = -b(25,48)+b(27,48) + jvs(560) = b(19,49) + jvs(561) = -b(41,50) + jvs(562) = -b(37,51) + jvs(563) = b(16,52)+b(19,52)-b(38,52)-b(39,52) + jvs(564) = -b(2,53)-b(25,53)-b(37,53)-b(38,53)-b(39,53)-2 & + *b(40,53)-b(41,53)-b(52,53)-b(59,53)-b(60,53)-b(68,53) & + -b(72,53)-b(80,53)-b(87,53)-b(88,53)-b(93,53) & + -b(106,53)-b(107,53)-b(108,53)-b(109,53)-b(121,53) & + -b(125,53) + return + end subroutine cbmz_v02r03_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r03 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = non-zero elements of the sparse jacobian [input] + real v(lu_nonzero_v_r03_kpp) + + integer lu_crow_v(nvar_r03_kpp + 1) + integer lu_diag_v(nvar_r03_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r03_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r03_kpp + 1) + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r03_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r03_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r03 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(15) = x(15)-jvs(47)*x(10)-jvs(48)*x(12) + x(22) = x(22)-jvs(86)*x(4) + x(23) = x(23)-jvs(92)*x(10)-jvs(93)*x(12) + x(24) = x(24)-jvs(97)*x(11)-jvs(98)*x(23) + x(25) = x(25)-jvs(108)*x(20) + x(26) = x(26)-jvs(123)*x(12)-jvs(124)*x(16) + x(27) = x(27)-jvs(140)*x(15)-jvs(141)*x(23) + x(33) = x(33)-jvs(170)*x(17)-jvs(171)*x(20)-jvs(172)*x(21) & + -jvs(173)*x(27)-jvs(174)*x(29)-jvs(175)*x(30)-jvs(176) & + *x(31)-jvs(177)*x(32) + x(34) = x(34)-jvs(189)*x(10)-jvs(190)*x(12)-jvs(191)*x(20) & + -jvs(192)*x(23)-jvs(193)*x(27)-jvs(194)*x(31)-jvs(195) & + *x(32) + x(35) = x(35)-jvs(208)*x(30) + x(37) = x(37)-jvs(225)*x(31)-jvs(226)*x(36) + x(38) = x(38)-jvs(234)*x(12)-jvs(235)*x(27)-jvs(236)*x(30) & + -jvs(237)*x(31)-jvs(238)*x(36) + x(39) = x(39)-jvs(248)*x(8)-jvs(249)*x(18)-jvs(250)*x(31) & + -jvs(251)*x(36) + x(40) = x(40)-jvs(261)*x(6)-jvs(262)*x(18)-jvs(263)*x(20) & + -jvs(264)*x(27)-jvs(265)*x(28)-jvs(266)*x(30)-jvs(267) & + *x(31)-jvs(268)*x(32)-jvs(269)*x(36)-jvs(270)*x(37) & + -jvs(271)*x(39) + x(41) = x(41)-jvs(282)*x(17)-jvs(283)*x(31)-jvs(284)*x(35) & + -jvs(285)*x(36)-jvs(286)*x(40) + x(42) = x(42)-jvs(299)*x(28)-jvs(300)*x(29)-jvs(301)*x(32) + x(43) = x(43)-jvs(308)*x(35)-jvs(309)*x(36)-jvs(310)*x(42) + x(44) = x(44)-jvs(320)*x(29)-jvs(321)*x(30)-jvs(322)*x(32) & + -jvs(323)*x(42)-jvs(324)*x(43) + x(45) = x(45)-jvs(333)*x(26)-jvs(334)*x(28)-jvs(335)*x(29) & + -jvs(336)*x(31)-jvs(337)*x(32)-jvs(338)*x(36)-jvs(339) & + *x(37)-jvs(340)*x(42)-jvs(341)*x(44) + x(46) = x(46)-jvs(349)*x(13)-jvs(350)*x(15)-jvs(351)*x(23) & + -jvs(352)*x(28)-jvs(353)*x(29)-jvs(354)*x(32)-jvs(355) & + *x(37)-jvs(356)*x(42)-jvs(357)*x(45) + x(47) = x(47)-jvs(365)*x(9)-jvs(366)*x(27)-jvs(367)*x(31) & + -jvs(368)*x(32)-jvs(369)*x(35)-jvs(370)*x(36)-jvs(371) & + *x(38)-jvs(372)*x(40)-jvs(373)*x(42)-jvs(374)*x(43) & + -jvs(375)*x(44)-jvs(376)*x(45)-jvs(377)*x(46) + x(48) = x(48)-jvs(385)*x(4)-jvs(386)*x(5)-jvs(387)*x(6)-jvs(388) & + *x(7)-jvs(389)*x(8)-jvs(390)*x(10)-jvs(391)*x(12) & + -jvs(392)*x(14)-jvs(393)*x(17)-jvs(394)*x(18)-jvs(395) & + *x(19)-jvs(396)*x(20)-jvs(397)*x(21)-jvs(398)*x(23) & + -jvs(399)*x(24)-jvs(400)*x(25)-jvs(401)*x(26)-jvs(402) & + *x(27)-jvs(403)*x(28)-jvs(404)*x(29)-jvs(405)*x(30) & + -jvs(406)*x(31)-jvs(407)*x(32)-jvs(408)*x(33)-jvs(409) & + *x(35)-jvs(410)*x(36)-jvs(411)*x(37)-jvs(412)*x(38) & + -jvs(413)*x(39)-jvs(414)*x(40)-jvs(415)*x(41)-jvs(416) & + *x(42)-jvs(417)*x(43)-jvs(418)*x(44)-jvs(419)*x(45) & + -jvs(420)*x(46)-jvs(421)*x(47) + x(49) = x(49)-jvs(428)*x(20)-jvs(429)*x(22)-jvs(430)*x(27) & + -jvs(431)*x(31)-jvs(432)*x(32)-jvs(433)*x(36)-jvs(434) & + *x(42)-jvs(435)*x(47)-jvs(436)*x(48) + x(50) = x(50)-jvs(442)*x(5)-jvs(443)*x(6)-jvs(444)*x(7)-jvs(445) & + *x(10)-jvs(446)*x(12)-jvs(447)*x(14)-jvs(448)*x(15) & + -jvs(449)*x(17)-jvs(450)*x(18)-jvs(451)*x(20)-jvs(452) & + *x(21)-jvs(453)*x(23)-jvs(454)*x(25)-jvs(455)*x(27) & + -jvs(456)*x(28)-jvs(457)*x(29)-jvs(458)*x(30)-jvs(459) & + *x(31)-jvs(460)*x(32)-jvs(461)*x(33)-jvs(462)*x(34) & + -jvs(463)*x(36)-jvs(464)*x(37)-jvs(465)*x(38)-jvs(466) & + *x(39)-jvs(467)*x(40)-jvs(468)*x(41)-jvs(469)*x(42) & + -jvs(470)*x(43)-jvs(471)*x(44)-jvs(472)*x(45)-jvs(473) & + *x(46)-jvs(474)*x(47)-jvs(475)*x(48)-jvs(476)*x(49) + x(51) = x(51)-jvs(481)*x(15)-jvs(482)*x(19)-jvs(483)*x(22) & + -jvs(484)*x(28)-jvs(485)*x(29)-jvs(486)*x(30)-jvs(487) & + *x(32)-jvs(488)*x(34)-jvs(489)*x(36)-jvs(490)*x(37) & + -jvs(491)*x(38)-jvs(492)*x(39)-jvs(493)*x(41)-jvs(494) & + *x(42)-jvs(495)*x(43)-jvs(496)*x(44)-jvs(497)*x(45) & + -jvs(498)*x(46)-jvs(499)*x(47)-jvs(500)*x(48)-jvs(501) & + *x(49)-jvs(502)*x(50) + x(52) = x(52)-jvs(506)*x(9)-jvs(507)*x(11)-jvs(508)*x(13) & + -jvs(509)*x(14)-jvs(510)*x(15)-jvs(511)*x(19)-jvs(512) & + *x(22)-jvs(513)*x(23)-jvs(514)*x(24)-jvs(515)*x(28) & + -jvs(516)*x(29)-jvs(517)*x(30)-jvs(518)*x(32)-jvs(519) & + *x(33)-jvs(520)*x(34)-jvs(521)*x(36)-jvs(522)*x(37) & + -jvs(523)*x(38)-jvs(524)*x(39)-jvs(525)*x(40)-jvs(526) & + *x(41)-jvs(527)*x(42)-jvs(528)*x(43)-jvs(529)*x(44) & + -jvs(530)*x(45)-jvs(531)*x(46)-jvs(532)*x(47)-jvs(533) & + *x(48)-jvs(534)*x(49)-jvs(535)*x(50)-jvs(536)*x(51) + x(53) = x(53)-jvs(539)*x(11)-jvs(540)*x(22)-jvs(541)*x(23) & + -jvs(542)*x(24)-jvs(543)*x(31)-jvs(544)*x(32)-jvs(545) & + *x(33)-jvs(546)*x(34)-jvs(547)*x(36)-jvs(548)*x(37) & + -jvs(549)*x(38)-jvs(550)*x(39)-jvs(551)*x(40)-jvs(552) & + *x(41)-jvs(553)*x(42)-jvs(554)*x(43)-jvs(555)*x(44) & + -jvs(556)*x(45)-jvs(557)*x(46)-jvs(558)*x(47)-jvs(559) & + *x(48)-jvs(560)*x(49)-jvs(561)*x(50)-jvs(562)*x(51) & + -jvs(563)*x(52) + x(53) = x(53)/jvs(564) + x(52) = (x(52)-jvs(538)*x(53))/(jvs(537)) + x(51) = (x(51)-jvs(504)*x(52)-jvs(505)*x(53))/(jvs(503)) + x(50) = (x(50)-jvs(478)*x(51)-jvs(479)*x(52)-jvs(480)*x(53))/ & + (jvs(477)) + x(49) = (x(49)-jvs(438)*x(50)-jvs(439)*x(51)-jvs(440)*x(52) & + -jvs(441)*x(53))/(jvs(437)) + x(48) = (x(48)-jvs(423)*x(49)-jvs(424)*x(50)-jvs(425)*x(51) & + -jvs(426)*x(52)-jvs(427)*x(53))/(jvs(422)) + x(47) = (x(47)-jvs(379)*x(48)-jvs(380)*x(49)-jvs(381)*x(50) & + -jvs(382)*x(51)-jvs(383)*x(52)-jvs(384)*x(53))/(jvs(378)) + x(46) = (x(46)-jvs(359)*x(48)-jvs(360)*x(49)-jvs(361)*x(50) & + -jvs(362)*x(51)-jvs(363)*x(52)-jvs(364)*x(53))/(jvs(358)) + x(45) = (x(45)-jvs(343)*x(46)-jvs(344)*x(48)-jvs(345)*x(49) & + -jvs(346)*x(50)-jvs(347)*x(51)-jvs(348)*x(53))/(jvs(342)) + x(44) = (x(44)-jvs(326)*x(45)-jvs(327)*x(46)-jvs(328)*x(48) & + -jvs(329)*x(49)-jvs(330)*x(50)-jvs(331)*x(51)-jvs(332) & + *x(53))/(jvs(325)) + x(43) = (x(43)-jvs(312)*x(44)-jvs(313)*x(45)-jvs(314)*x(46) & + -jvs(315)*x(48)-jvs(316)*x(49)-jvs(317)*x(50)-jvs(318) & + *x(51)-jvs(319)*x(53))/(jvs(311)) + x(42) = (x(42)-jvs(303)*x(48)-jvs(304)*x(49)-jvs(305)*x(50) & + -jvs(306)*x(51)-jvs(307)*x(53))/(jvs(302)) + x(41) = (x(41)-jvs(288)*x(42)-jvs(289)*x(43)-jvs(290)*x(44) & + -jvs(291)*x(45)-jvs(292)*x(46)-jvs(293)*x(47)-jvs(294) & + *x(48)-jvs(295)*x(49)-jvs(296)*x(50)-jvs(297)*x(51) & + -jvs(298)*x(53))/(jvs(287)) + x(40) = (x(40)-jvs(273)*x(42)-jvs(274)*x(44)-jvs(275)*x(45) & + -jvs(276)*x(46)-jvs(277)*x(48)-jvs(278)*x(49)-jvs(279) & + *x(50)-jvs(280)*x(51)-jvs(281)*x(53))/(jvs(272)) + x(39) = (x(39)-jvs(253)*x(44)-jvs(254)*x(45)-jvs(255)*x(46) & + -jvs(256)*x(48)-jvs(257)*x(49)-jvs(258)*x(50)-jvs(259) & + *x(51)-jvs(260)*x(53))/(jvs(252)) + x(38) = (x(38)-jvs(240)*x(42)-jvs(241)*x(43)-jvs(242)*x(44) & + -jvs(243)*x(48)-jvs(244)*x(49)-jvs(245)*x(50)-jvs(246) & + *x(51)-jvs(247)*x(53))/(jvs(239)) + x(37) = (x(37)-jvs(228)*x(46)-jvs(229)*x(48)-jvs(230)*x(49) & + -jvs(231)*x(50)-jvs(232)*x(51)-jvs(233)*x(53))/(jvs(227)) + x(36) = (x(36)-jvs(222)*x(48)-jvs(223)*x(49)-jvs(224)*x(53))/ & + (jvs(221)) + x(35) = (x(35)-jvs(210)*x(36)-jvs(211)*x(42)-jvs(212)*x(43) & + -jvs(213)*x(44)-jvs(214)*x(45)-jvs(215)*x(46)-jvs(216) & + *x(48)-jvs(217)*x(49)-jvs(218)*x(50)-jvs(219)*x(51) & + -jvs(220)*x(53))/(jvs(209)) + x(34) = (x(34)-jvs(197)*x(36)-jvs(198)*x(38)-jvs(199)*x(42) & + -jvs(200)*x(44)-jvs(201)*x(45)-jvs(202)*x(46)-jvs(203) & + *x(48)-jvs(204)*x(49)-jvs(205)*x(50)-jvs(206)*x(51) & + -jvs(207)*x(53))/(jvs(196)) + x(33) = (x(33)-jvs(179)*x(36)-jvs(180)*x(37)-jvs(181)*x(41) & + -jvs(182)*x(42)-jvs(183)*x(43)-jvs(184)*x(48)-jvs(185) & + *x(49)-jvs(186)*x(50)-jvs(187)*x(51)-jvs(188)*x(53))/ & + (jvs(178)) + x(32) = (x(32)-jvs(167)*x(48)-jvs(168)*x(49)-jvs(169)*x(53))/ & + (jvs(166)) + x(31) = (x(31)-jvs(163)*x(48)-jvs(164)*x(49)-jvs(165)*x(53))/ & + (jvs(162)) + x(30) = (x(30)-jvs(158)*x(42)-jvs(159)*x(48)-jvs(160)*x(50) & + -jvs(161)*x(51))/(jvs(157)) + x(29) = (x(29)-jvs(153)*x(32)-jvs(154)*x(48)-jvs(155)*x(50) & + -jvs(156)*x(51))/(jvs(152)) + x(28) = (x(28)-jvs(148)*x(32)-jvs(149)*x(50)-jvs(150)*x(51) & + -jvs(151)*x(53))/(jvs(147)) + x(27) = (x(27)-jvs(143)*x(48)-jvs(144)*x(49)-jvs(145)*x(51) & + -jvs(146)*x(53))/(jvs(142)) + x(26) = (x(26)-jvs(126)*x(28)-jvs(127)*x(29)-jvs(128)*x(31) & + -jvs(129)*x(36)-jvs(130)*x(37)-jvs(131)*x(42)-jvs(132) & + *x(44)-jvs(133)*x(45)-jvs(134)*x(46)-jvs(135)*x(48) & + -jvs(136)*x(49)-jvs(137)*x(50)-jvs(138)*x(51)-jvs(139) & + *x(53))/(jvs(125)) + x(25) = (x(25)-jvs(110)*x(27)-jvs(111)*x(30)-jvs(112)*x(31) & + -jvs(113)*x(32)-jvs(114)*x(33)-jvs(115)*x(36)-jvs(116) & + *x(38)-jvs(117)*x(40)-jvs(118)*x(42)-jvs(119)*x(48) & + -jvs(120)*x(49)-jvs(121)*x(51)-jvs(122)*x(53))/(jvs(109)) + x(24) = (x(24)-jvs(100)*x(33)-jvs(101)*x(38)-jvs(102)*x(40) & + -jvs(103)*x(42)-jvs(104)*x(48)-jvs(105)*x(50)-jvs(106) & + *x(52)-jvs(107)*x(53))/(jvs(99)) + x(23) = (x(23)-jvs(95)*x(48)-jvs(96)*x(53))/(jvs(94)) + x(22) = (x(22)-jvs(88)*x(49)-jvs(89)*x(51)-jvs(90)*x(52)-jvs(91) & + *x(53))/(jvs(87)) + x(21) = (x(21)-jvs(81)*x(31)-jvs(82)*x(36)-jvs(83)*x(41)-jvs(84) & + *x(48)-jvs(85)*x(49))/(jvs(80)) + x(20) = (x(20)-jvs(78)*x(48)-jvs(79)*x(49))/(jvs(77)) + x(19) = (x(19)-jvs(73)*x(48)-jvs(74)*x(50)-jvs(75)*x(51)-jvs(76) & + *x(52))/(jvs(72)) + x(18) = (x(18)-jvs(69)*x(39)-jvs(70)*x(48)-jvs(71)*x(50))/ & + (jvs(68)) + x(17) = (x(17)-jvs(65)*x(41)-jvs(66)*x(48)-jvs(67)*x(50))/ & + (jvs(64)) + x(16) = (x(16)-jvs(53)*x(26)-jvs(54)*x(31)-jvs(55)*x(36)-jvs(56) & + *x(37)-jvs(57)*x(44)-jvs(58)*x(45)-jvs(59)*x(46)-jvs(60) & + *x(48)-jvs(61)*x(49)-jvs(62)*x(51)-jvs(63)*x(53))/ & + (jvs(52)) + x(15) = (x(15)-jvs(50)*x(48)-jvs(51)*x(51))/(jvs(49)) + x(14) = (x(14)-jvs(44)*x(48)-jvs(45)*x(50)-jvs(46)*x(52))/ & + (jvs(43)) + x(13) = (x(13)-jvs(39)*x(23)-jvs(40)*x(48)-jvs(41)*x(52)-jvs(42) & + *x(53))/(jvs(38)) + x(12) = (x(12)-jvs(37)*x(48))/(jvs(36)) + x(11) = (x(11)-jvs(34)*x(52)-jvs(35)*x(53))/(jvs(33)) + x(10) = (x(10)-jvs(32)*x(48))/(jvs(31)) + x(9) = (x(9)-jvs(29)*x(47)-jvs(30)*x(52))/(jvs(28)) + x(8) = (x(8)-jvs(26)*x(39)-jvs(27)*x(48))/(jvs(25)) + x(7) = (x(7)-jvs(23)*x(48)-jvs(24)*x(50))/(jvs(22)) + x(6) = (x(6)-jvs(21)*x(48))/(jvs(20)) + x(5) = (x(5)-jvs(19)*x(48))/(jvs(18)) + x(4) = (x(4)-jvs(17)*x(49))/(jvs(16)) + x(3) = (x(3)-jvs(11)*x(31)-jvs(12)*x(36)-jvs(13)*x(47)-jvs(14) & + *x(49)-jvs(15)*x(50))/(jvs(10)) + x(2) = (x(2)-jvs(5)*x(20)-jvs(6)*x(31)-jvs(7)*x(32)-jvs(8)*x(42) & + -jvs(9)*x(49))/(jvs(4)) + x(1) = (x(1)-jvs(2)*x(5)-jvs(3)*x(48))/(jvs(1)) + return + end subroutine cbmz_v02r03_solve + + +! cbmz_v02r04_torodas.f - created on 18-nov-2003 from previous +! cbmz_v02r04_torodas.f cbmz_v02r04_mapconcs.f +! cbmz_v02r04_maprates.f cbmz_v02r04_dydt.f +! cbmz_v02r04_jacob.f cbmz_v02r04_decomp.f +! cbmz_v02r04_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r04_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r04 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r04_dydt +! external cbmz_v02r04_jacob +! external cbmz_v02r04_decomp +! external cbmz_v02r04_solve + + integer i + + real hmax + + integer lu_crow_v(nvar_r04_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r04_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r04_kpp) + save lu_icol_v + + data( lu_icol_v(i), i = 1, 252 ) / & + 1, 7, 33, 39, 2, 25, 34, 3, 28, 29, 32, 33, & + 34, 37, 38, 39, 4, 27, 5, 31, 6, 39, 7, 32, & + 39, 8, 21, 39, 9, 25, 37, 10, 16, 39, 11, 29, & + 34, 39, 12, 35, 39, 13, 36, 37, 14, 34, 37, 39, & + 15, 22, 28, 33, 36, 39, 16, 26, 39, 17, 21, 34, & + 39, 18, 33, 34, 37, 38, 39, 19, 29, 34, 35, 39, & + 20, 32, 35, 38, 8, 17, 21, 34, 36, 38, 39, 6, & + 17, 21, 22, 34, 36, 38, 39, 10, 16, 23, 26, 35, & + 38, 39, 13, 22, 24, 26, 28, 29, 33, 34, 36, 37, & + 38, 39, 9, 22, 25, 34, 36, 37, 38, 39, 26, 30, & + 36, 39, 26, 27, 30, 32, 35, 36, 38, 39, 12, 19, & + 20, 23, 26, 27, 28, 29, 30, 32, 33, 34, 35, 36, & + 38, 39, 16, 26, 29, 30, 33, 34, 35, 36, 39, 5, & + 26, 30, 31, 36, 37, 38, 39, 25, 30, 31, 32, 34, & + 36, 37, 38, 39, 20, 23, 26, 27, 29, 30, 31, 32, & + 33, 34, 35, 36, 37, 38, 39, 20, 27, 28, 29, 30, & + 31, 32, 33, 34, 35, 36, 37, 38, 39, 6, 7, 11, & + 12, 14, 15, 16, 17, 19, 20, 21, 22, 23, 25, 26, & + 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, & + 39, 16, 19, 20, 22, 23, 25, 26, 27, 29, 30, 31, & + 32, 33, 34, 35, 36, 37, 38, 39, 13, 21, 22, 24 / + + data( lu_icol_v(i), i = 253, 334 ) / & + 25, 26, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, & + 38, 39, 9, 13, 14, 18, 20, 21, 23, 24, 25, 26, & + 27, 28, 29, 30, 31, 32, 33, 34, 35, 37, 38, 39, & + 18, 20, 21, 23, 25, 26, 27, 30, 31, 32, 33, 34, & + 35, 36, 37, 38, 39, 5, 6, 7, 8, 10, 11, 12, & + 14, 15, 16, 17, 18, 19, 21, 22, 24, 26, 28, 29, & + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39 / + + data lu_crow_v / & + 1, 5, 8, 17, 19, 21, 23, 26, 29, 32, 35, 39, & + 42, 45, 49, 55, 58, 62, 68, 73, 77, 84, 92, 99, & + 111,119,123,131,147,156,164,173,188,202,230,249, & + 267,289,306,335 / + + data lu_diag_v / & + 1, 5, 8, 17, 19, 21, 23, 26, 29, 32, 35, 39, & + 42, 45, 49, 55, 58, 62, 68, 73, 79, 87, 94,101, & + 113,119,124,137,149,158,166,180,195,224,244,263, & + 286,304,334,335 / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r04_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r04_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r04_dydt, & + cbmz_v02r04_jacob, & + cbmz_v02r04_decomp, & + cbmz_v02r04_solve ) + + return + end subroutine cbmz_v02r04_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r04 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r04_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 2 ) + integer imsa_kpp + parameter ( imsa_kpp = 3 ) + integer imtf_kpp + parameter ( imtf_kpp = 4 ) + integer io1d_kpp + parameter ( io1d_kpp = 5 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 6 ) + integer iso2_kpp + parameter ( iso2_kpp = 7 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 8 ) + integer ipan_kpp + parameter ( ipan_kpp = 9 ) + integer idmso2_kpp + parameter ( idmso2_kpp = 10 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 11 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 12 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 13 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 14 ) + integer ico_kpp + parameter ( ico_kpp = 15 ) + integer idmso_kpp + parameter ( idmso_kpp = 16 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 17 ) + integer ihono_kpp + parameter ( ihono_kpp = 18 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 19 ) + integer ich3so2oo_kpp + parameter ( ich3so2oo_kpp = 20 ) + integer iethp_kpp + parameter ( iethp_kpp = 21 ) + integer iald2_kpp + parameter ( iald2_kpp = 22 ) + integer ich3so2ch2oo_kpp + parameter ( ich3so2ch2oo_kpp = 23 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 24 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 25 ) + integer idms_kpp + parameter ( idms_kpp = 26 ) + integer ich3sch2oo_kpp + parameter ( ich3sch2oo_kpp = 27 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 28 ) + integer ich3so2h_kpp + parameter ( ich3so2h_kpp = 29 ) + integer io3p_kpp + parameter ( io3p_kpp = 30 ) + integer io3_kpp + parameter ( io3_kpp = 31 ) + integer ich3so2_kpp + parameter ( ich3so2_kpp = 32 ) + integer ich3so3_kpp + parameter ( ich3so3_kpp = 33 ) + integer iho2_kpp + parameter ( iho2_kpp = 34 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 35 ) + integer ino3_kpp + parameter ( ino3_kpp = 36 ) + integer ino2_kpp + parameter ( ino2_kpp = 37 ) + integer ino_kpp + parameter ( ino_kpp = 38 ) + integer ioh_kpp + parameter ( ioh_kpp = 39 ) + +! indexes declaration for fixed species + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + nyy = nvar_r04_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(imsa_kpp) = cbox(imsa_z) + yy(imtf_kpp) = cbox(imtf_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(idmso2_kpp) = cbox(idmso2_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ico_kpp) = cbox(ico_z) + yy(idmso_kpp) = cbox(idmso_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(ich3so2oo_kpp) = cbox(ich3so2oo_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ich3so2ch2oo_kpp) = cbox(ich3so2ch2oo_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(idms_kpp) = cbox(idms_z) + yy(ich3sch2oo_kpp) = cbox(ich3sch2oo_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(ich3so2h_kpp) = cbox(ich3so2h_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(io3_kpp) = cbox(io3_z) + yy(ich3so2_kpp) = cbox(ich3so2_z) + yy(ich3so3_kpp) = cbox(ich3so3_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(ino3_kpp) = cbox(ino3_z) + yy(ino2_kpp) = cbox(ino2_z) + yy(ino_kpp) = cbox(ino_z) + yy(ioh_kpp) = cbox(ioh_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(imsa_z) = yy(imsa_kpp) + cbox(imtf_z) = yy(imtf_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(idmso2_z) = yy(idmso2_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(idmso_z) = yy(idmso_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(ich3so2oo_z) = yy(ich3so2oo_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ich3so2ch2oo_z) = yy(ich3so2ch2oo_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(idms_z) = yy(idms_kpp) + cbox(ich3sch2oo_z) = yy(ich3sch2oo_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(ich3so2h_z) = yy(ich3so2h_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(ich3so2_z) = yy(ich3so2_kpp) + cbox(ich3so3_z) = yy(ich3so3_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(ino3_z) = yy(ino3_kpp) + cbox(ino2_z) = yy(ino2_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(ioh_z) = yy(ioh_kpp) + + return + end subroutine cbmz_v02r04_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r04 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + rconst(75) = (rk_m4(1)) + rconst(76) = (rk_m4(2)) + rconst(77) = (rk_m4(3)) + rconst(78) = (rk_m4(4)) + rconst(79) = (rk_m4(5)) + rconst(80) = (rk_m4(6)) + rconst(81) = (rk_m4(7)) + rconst(82) = (rk_m4(8)) + rconst(83) = (rk_m4(9)) + rconst(84) = (rk_m4(10)) + rconst(85) = (rk_m4(11)) + rconst(86) = (rk_m4(12)) + rconst(87) = (rk_m4(13)) + rconst(88) = (rk_m4(14)) + rconst(89) = (rk_m4(15)) + rconst(90) = (rk_m4(16)) + rconst(91) = (rk_m4(17)) + rconst(92) = (rk_m4(18)) + rconst(93) = (rk_m4(19)) + rconst(94) = (rk_m4(20)) + rconst(95) = (rk_m4(21)) + rconst(96) = (rk_m4(22)) + rconst(97) = (rk_m4(23)) + rconst(98) = (rk_m4(24)) + rconst(99) = (rk_m4(25)) + rconst(100) = (rk_m4(26)) + rconst(101) = (rk_m4(27)) + rconst(102) = (rk_m4(28)) + rconst(103) = (rk_m4(29)) + rconst(104) = (rk_m4(30)) + rconst(105) = (rk_m4(31)) + rconst(106) = (rk_m4(32)) + return + end subroutine cbmz_v02r04_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r04 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r04_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r04_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r04_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r04_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(37) + a(2) = rconst(2)*v(36) + a(3) = rconst(3)*v(18) + a(4) = rconst(4)*v(24) + a(5) = rconst(5)*v(14) + a(6) = rconst(6)*v(13) + a(7) = rconst(7)*v(31) + a(8) = rconst(8)*v(31) + a(9) = rconst(9)*v(11) + a(10) = rconst(10)*v(5)*f(4) + a(11) = rconst(11)*v(5)*f(5) + a(12) = rconst(12)*v(5)*f(2) + a(13) = rconst(13)*v(30)*f(4) + a(14) = rconst(14)*v(30)*v(31) + a(15) = rconst(15)*v(30)*v(37) + a(16) = rconst(16)*v(30)*v(37) + a(17) = rconst(17)*v(30)*v(38) + a(18) = rconst(18)*v(31)*v(38) + a(19) = rconst(19)*v(31)*v(37) + a(20) = rconst(20)*v(31)*v(39) + a(21) = rconst(21)*v(31)*v(34) + a(22) = rconst(22)*v(39)*f(3) + a(23) = rconst(23)*v(38)*v(39) + a(24) = rconst(24)*v(37)*v(39) + a(25) = rconst(25)*v(36)*v(39) + a(26) = rconst(26)*v(18)*v(39) + a(27) = rconst(27)*v(24)*v(39) + a(28) = rconst(28)*v(14)*v(39) + a(29) = rconst(29)*v(34)*v(39) + a(30) = rconst(30)*v(11)*v(39) + a(31) = rconst(31)*v(34)*v(34) + a(32) = rconst(32)*v(34)*v(34)*f(2) + a(33) = rconst(33)*v(34)*v(38) + a(34) = rconst(34)*v(34)*v(37) + a(35) = rconst(35)*v(34)*v(37) + a(36) = rconst(36)*v(14) + a(37) = rconst(37)*v(36)*v(38) + a(38) = rconst(38)*v(36)*v(37) + a(39) = rconst(39)*v(36)*v(37) + a(40) = rconst(40)*v(36)*v(36) + a(41) = rconst(41)*v(34)*v(36) + a(42) = rconst(42)*v(13)*f(2) + a(43) = rconst(43)*v(13) + a(44) = rconst(44)*v(15)*v(39) + a(45) = rconst(45)*v(7)*v(39) + a(46) = rconst(46)*v(39)*f(1) + a(47) = rconst(47)*v(8)*v(39) + a(48) = rconst(48)*v(12)*v(39) + a(49) = rconst(49)*v(28) + a(50) = rconst(50)*v(28) + a(51) = rconst(51)*v(28)*v(39) + a(52) = rconst(52)*v(28)*v(36) + a(53) = rconst(53)*v(19) + a(54) = rconst(54)*v(17) + a(55) = rconst(55)*v(19)*v(39) + a(56) = rconst(56)*v(17)*v(39) + a(57) = rconst(57)*v(35)*v(38) + a(58) = rconst(58)*v(21)*v(38) + a(59) = rconst(59)*v(35)*v(36) + a(60) = rconst(60)*v(21)*v(36) + a(61) = rconst(61)*v(34)*v(35) + a(62) = rconst(62)*v(21)*v(34) + a(63) = rconst(63)*v(35) + a(64) = rconst(64)*v(21) + a(65) = rconst(65)*v(6)*v(39) + a(66) = rconst(66)*v(22) + a(67) = rconst(67)*v(22)*v(39) + a(68) = rconst(68)*v(22)*v(36) + a(69) = rconst(69)*v(25)*v(37) + a(70) = rconst(70)*v(9) + a(71) = rconst(71)*v(25)*v(38) + a(72) = rconst(72)*v(25)*v(36) + a(73) = rconst(73)*v(25)*v(34) + a(74) = rconst(74)*v(25) + a(75) = rconst(75)*v(26)*v(39) + a(76) = rconst(76)*v(26)*v(36) + a(77) = rconst(77)*v(26)*v(30) + a(78) = rconst(78)*v(26)*v(39) + a(79) = rconst(79)*v(27)*v(38) + a(80) = rconst(80)*v(27)*v(35) + a(81) = rconst(81)*v(27)*v(32) + a(82) = rconst(82)*v(27)*v(27) + a(83) = rconst(83)*v(16)*v(39) + a(84) = rconst(84)*v(10)*v(39) + a(85) = rconst(85)*v(23)*v(38) + a(86) = rconst(86)*v(23)*v(35) + a(87) = rconst(87)*v(29)*v(34) + a(88) = rconst(88)*v(29)*v(36) + a(89) = rconst(89)*v(29)*v(35) + a(90) = rconst(90)*v(29)*v(39) + a(91) = rconst(91)*v(29)*v(33) + a(92) = rconst(92)*v(32) + a(93) = rconst(93)*v(32)*v(37) + a(94) = rconst(94)*v(31)*v(32) + a(95) = rconst(95)*v(32)*v(34) + a(96) = rconst(96)*v(32)*v(35) + a(97) = rconst(97)*v(32)*v(39) + a(98) = rconst(98)*v(32)*f(4) + a(99) = rconst(99)*v(20) + a(100) = rconst(100)*v(20)*v(38) + a(101) = rconst(101)*v(20)*v(35) + a(102) = rconst(102)*v(33) + a(103) = rconst(103)*v(33)*v(37) + a(104) = rconst(104)*v(33)*v(38) + a(105) = rconst(105)*v(33)*v(34) + a(106) = rconst(106)*v(28)*v(33) + +! aggregate function + a_var(1) = a(45)+a(102) + a_var(2) = 0.4*a(73) + a_var(3) = a(91)+a(97)+a(103)+a(104)+a(105)+a(106) + a_var(4) = 0.15*a(82) + a_var(5) = a(8)-a(10)-a(11)-a(12) + a_var(6) = -a(65) + a_var(7) = -a(45)+a(92) + a_var(8) = -a(47)+0.2*a(64) + a_var(9) = a(69)-a(70) + a_var(10) = 0.27*a(83)-a(84) + a_var(11) = -a(9)-a(30)+a(31)+a(32)+a(87) + a_var(12) = -a(48)+0.34*a(63) + a_var(13) = -a(6)+a(39)-a(42)-a(43) + a_var(14) = -a(5)-a(28)+a(34)-a(36) + a_var(15) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66)+a(106) + a_var(16) = 0.965*a(78)-a(83) + a_var(17) = -a(54)-a(56)+a(62) + a_var(18) = -a(3)+a(23)-a(26)+a(35)+a(104) + a_var(19) = -a(53)-a(55)+a(61)+a(89) + a_var(20) = a(98)-a(99)-a(100)-a(101) + a_var(21) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64) + a_var(22) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68) + a_var(23) = a(84)-a(85)-a(86) + a_var(24) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) & + +a(76)+a(88)+a(103) + a_var(25) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) + a_var(26) = -a(75)-a(76)-a(77)-a(78) + a_var(27) = a(75)+a(76)-a(79)-a(80)-a(81)-2*a(82) + a_var(28) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63)+a(79)+2*a(80)+a(81)+a(85)+2*a(86) & + +a(96)+a(101)-a(106) + a_var(29) = 0.73*a(83)-a(87)-a(88)-a(89)-a(90)-a(91) + a_var(30) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17)-a(77) + a_var(31) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73)-a(94) + a_var(32) = a(77)+0.035*a(78)+a(79)+a(80)+1.85*a(82)+a(85)+a(86) & + +a(87)+a(88)+a(89)+a(90)+a(91)-a(92)-a(93)-a(94) & + -a(95)-a(96)-a(97)-a(98)+a(99) + a_var(33) = a(81)-a(91)+a(93)+a(94)+a(95)+a(96)+a(100)+a(101) & + -a(102)-a(103)-a(104)-a(105)-a(106) + a_var(34) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73)+0.965*a(78)+a(80)+0.27*a(83)+a(86)-a(87) & + -a(95)+a(96)+a(101)-a(105)+a(106) + a_var(35) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74)+a(77)+0.035*a(78)-a(80)+0.73*a(83)-a(86) & + -a(89)+a(92)-a(96)-a(101)+a(102) + a_var(36) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) & + -a(76)-a(88) + a_var(37) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72) & + +a(79)+a(85)-a(93)+a(100)-a(103) + a_var(38) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71)-a(79)-a(85)+a(93) & + -a(100)-a(104) + a_var(39) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67)-a(75)-a(78) & + -a(83)-a(84)-a(90)+a(95)-a(97) + return + end subroutine cbmz_v02r04_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r04 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r04_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r04_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r04_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r04_kpp,nvar_r04_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,37) = rconst(1) + b(2,36) = rconst(2) + b(3,18) = rconst(3) + b(4,24) = rconst(4) + b(5,14) = rconst(5) + b(6,13) = rconst(6) + b(7,31) = rconst(7) + b(8,31) = rconst(8) + b(9,11) = rconst(9) + b(10,5) = rconst(10)*f(4) + b(11,5) = rconst(11)*f(5) + b(12,5) = rconst(12)*f(2) + b(13,30) = rconst(13)*f(4) + b(14,30) = rconst(14)*v(31) + b(14,31) = rconst(14)*v(30) + b(15,30) = rconst(15)*v(37) + b(15,37) = rconst(15)*v(30) + b(16,30) = rconst(16)*v(37) + b(16,37) = rconst(16)*v(30) + b(17,30) = rconst(17)*v(38) + b(17,38) = rconst(17)*v(30) + b(18,31) = rconst(18)*v(38) + b(18,38) = rconst(18)*v(31) + b(19,31) = rconst(19)*v(37) + b(19,37) = rconst(19)*v(31) + b(20,31) = rconst(20)*v(39) + b(20,39) = rconst(20)*v(31) + b(21,31) = rconst(21)*v(34) + b(21,34) = rconst(21)*v(31) + b(22,39) = rconst(22)*f(3) + b(23,38) = rconst(23)*v(39) + b(23,39) = rconst(23)*v(38) + b(24,37) = rconst(24)*v(39) + b(24,39) = rconst(24)*v(37) + b(25,36) = rconst(25)*v(39) + b(25,39) = rconst(25)*v(36) + b(26,18) = rconst(26)*v(39) + b(26,39) = rconst(26)*v(18) + b(27,24) = rconst(27)*v(39) + b(27,39) = rconst(27)*v(24) + b(28,14) = rconst(28)*v(39) + b(28,39) = rconst(28)*v(14) + b(29,34) = rconst(29)*v(39) + b(29,39) = rconst(29)*v(34) + b(30,11) = rconst(30)*v(39) + b(30,39) = rconst(30)*v(11) + b(31,34) = rconst(31)*2*v(34) + b(32,34) = rconst(32)*2*v(34)*f(2) + b(33,34) = rconst(33)*v(38) + b(33,38) = rconst(33)*v(34) + b(34,34) = rconst(34)*v(37) + b(34,37) = rconst(34)*v(34) + b(35,34) = rconst(35)*v(37) + b(35,37) = rconst(35)*v(34) + b(36,14) = rconst(36) + b(37,36) = rconst(37)*v(38) + b(37,38) = rconst(37)*v(36) + b(38,36) = rconst(38)*v(37) + b(38,37) = rconst(38)*v(36) + b(39,36) = rconst(39)*v(37) + b(39,37) = rconst(39)*v(36) + b(40,36) = rconst(40)*2*v(36) + b(41,34) = rconst(41)*v(36) + b(41,36) = rconst(41)*v(34) + b(42,13) = rconst(42)*f(2) + b(43,13) = rconst(43) + b(44,15) = rconst(44)*v(39) + b(44,39) = rconst(44)*v(15) + b(45,7) = rconst(45)*v(39) + b(45,39) = rconst(45)*v(7) + b(46,39) = rconst(46)*f(1) + b(47,8) = rconst(47)*v(39) + b(47,39) = rconst(47)*v(8) + b(48,12) = rconst(48)*v(39) + b(48,39) = rconst(48)*v(12) + b(49,28) = rconst(49) + b(50,28) = rconst(50) + b(51,28) = rconst(51)*v(39) + b(51,39) = rconst(51)*v(28) + b(52,28) = rconst(52)*v(36) + b(52,36) = rconst(52)*v(28) + b(53,19) = rconst(53) + b(54,17) = rconst(54) + b(55,19) = rconst(55)*v(39) + b(55,39) = rconst(55)*v(19) + b(56,17) = rconst(56)*v(39) + b(56,39) = rconst(56)*v(17) + b(57,35) = rconst(57)*v(38) + b(57,38) = rconst(57)*v(35) + b(58,21) = rconst(58)*v(38) + b(58,38) = rconst(58)*v(21) + b(59,35) = rconst(59)*v(36) + b(59,36) = rconst(59)*v(35) + b(60,21) = rconst(60)*v(36) + b(60,36) = rconst(60)*v(21) + b(61,34) = rconst(61)*v(35) + b(61,35) = rconst(61)*v(34) + b(62,21) = rconst(62)*v(34) + b(62,34) = rconst(62)*v(21) + b(63,35) = rconst(63) + b(64,21) = rconst(64) + b(65,6) = rconst(65)*v(39) + b(65,39) = rconst(65)*v(6) + b(66,22) = rconst(66) + b(67,22) = rconst(67)*v(39) + b(67,39) = rconst(67)*v(22) + b(68,22) = rconst(68)*v(36) + b(68,36) = rconst(68)*v(22) + b(69,25) = rconst(69)*v(37) + b(69,37) = rconst(69)*v(25) + b(70,9) = rconst(70) + b(71,25) = rconst(71)*v(38) + b(71,38) = rconst(71)*v(25) + b(72,25) = rconst(72)*v(36) + b(72,36) = rconst(72)*v(25) + b(73,25) = rconst(73)*v(34) + b(73,34) = rconst(73)*v(25) + b(74,25) = rconst(74) + b(75,26) = rconst(75)*v(39) + b(75,39) = rconst(75)*v(26) + b(76,26) = rconst(76)*v(36) + b(76,36) = rconst(76)*v(26) + b(77,26) = rconst(77)*v(30) + b(77,30) = rconst(77)*v(26) + b(78,26) = rconst(78)*v(39) + b(78,39) = rconst(78)*v(26) + b(79,27) = rconst(79)*v(38) + b(79,38) = rconst(79)*v(27) + b(80,27) = rconst(80)*v(35) + b(80,35) = rconst(80)*v(27) + b(81,27) = rconst(81)*v(32) + b(81,32) = rconst(81)*v(27) + b(82,27) = rconst(82)*2*v(27) + b(83,16) = rconst(83)*v(39) + b(83,39) = rconst(83)*v(16) + b(84,10) = rconst(84)*v(39) + b(84,39) = rconst(84)*v(10) + b(85,23) = rconst(85)*v(38) + b(85,38) = rconst(85)*v(23) + b(86,23) = rconst(86)*v(35) + b(86,35) = rconst(86)*v(23) + b(87,29) = rconst(87)*v(34) + b(87,34) = rconst(87)*v(29) + b(88,29) = rconst(88)*v(36) + b(88,36) = rconst(88)*v(29) + b(89,29) = rconst(89)*v(35) + b(89,35) = rconst(89)*v(29) + b(90,29) = rconst(90)*v(39) + b(90,39) = rconst(90)*v(29) + b(91,29) = rconst(91)*v(33) + b(91,33) = rconst(91)*v(29) + b(92,32) = rconst(92) + b(93,32) = rconst(93)*v(37) + b(93,37) = rconst(93)*v(32) + b(94,31) = rconst(94)*v(32) + b(94,32) = rconst(94)*v(31) + b(95,32) = rconst(95)*v(34) + b(95,34) = rconst(95)*v(32) + b(96,32) = rconst(96)*v(35) + b(96,35) = rconst(96)*v(32) + b(97,32) = rconst(97)*v(39) + b(97,39) = rconst(97)*v(32) + b(98,32) = rconst(98)*f(4) + b(99,20) = rconst(99) + b(100,20) = rconst(100)*v(38) + b(100,38) = rconst(100)*v(20) + b(101,20) = rconst(101)*v(35) + b(101,35) = rconst(101)*v(20) + b(102,33) = rconst(102) + b(103,33) = rconst(103)*v(37) + b(103,37) = rconst(103)*v(33) + b(104,33) = rconst(104)*v(38) + b(104,38) = rconst(104)*v(33) + b(105,33) = rconst(105)*v(34) + b(105,34) = rconst(105)*v(33) + b(106,28) = rconst(106)*v(33) + b(106,33) = rconst(106)*v(28) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,7) + jvs(3) = b(102,33) + jvs(4) = b(45,39) + jvs(5) = 0 + jvs(6) = 0.4*b(73,25) + jvs(7) = 0.4*b(73,34) + jvs(8) = 0 + jvs(9) = b(106,28) + jvs(10) = b(91,29) + jvs(11) = b(97,32) + jvs(12) = b(91,33)+b(103,33)+b(104,33)+b(105,33)+b(106,33) + jvs(13) = b(105,34) + jvs(14) = b(103,37) + jvs(15) = b(104,38) + jvs(16) = b(97,39) + jvs(17) = 0 + jvs(18) = 0.15*b(82,27) + jvs(19) = -b(10,5)-b(11,5)-b(12,5) + jvs(20) = b(8,31) + jvs(21) = -b(65,6) + jvs(22) = -b(65,39) + jvs(23) = -b(45,7) + jvs(24) = b(92,32) + jvs(25) = -b(45,39) + jvs(26) = -b(47,8) + jvs(27) = 0.2*b(64,21) + jvs(28) = -b(47,39) + jvs(29) = -b(70,9) + jvs(30) = b(69,25) + jvs(31) = b(69,37) + jvs(32) = -b(84,10) + jvs(33) = 0.27*b(83,16) + jvs(34) = 0.27*b(83,39)-b(84,39) + jvs(35) = -b(9,11)-b(30,11) + jvs(36) = b(87,29) + jvs(37) = b(31,34)+b(32,34)+b(87,34) + jvs(38) = -b(30,39) + jvs(39) = -b(48,12) + jvs(40) = 0.34*b(63,35) + jvs(41) = -b(48,39) + jvs(42) = -b(6,13)-b(42,13)-b(43,13) + jvs(43) = b(39,36) + jvs(44) = b(39,37) + jvs(45) = -b(5,14)-b(28,14)-b(36,14) + jvs(46) = b(34,34) + jvs(47) = b(34,37) + jvs(48) = -b(28,39) + jvs(49) = -b(44,15) + jvs(50) = b(66,22) + jvs(51) = b(49,28)+b(50,28)+b(51,28)+b(52,28)+b(106,28) + jvs(52) = b(106,33) + jvs(53) = b(52,36) + jvs(54) = -b(44,39)+b(51,39) + jvs(55) = -b(83,16) + jvs(56) = 0.965*b(78,26) + jvs(57) = 0.965*b(78,39)-b(83,39) + jvs(58) = -b(54,17)-b(56,17) + jvs(59) = b(62,21) + jvs(60) = b(62,34) + jvs(61) = -b(56,39) + jvs(62) = -b(3,18)-b(26,18) + jvs(63) = b(104,33) + jvs(64) = b(35,34) + jvs(65) = b(35,37) + jvs(66) = b(23,38)+b(104,38) + jvs(67) = b(23,39)-b(26,39) + jvs(68) = -b(53,19)-b(55,19) + jvs(69) = b(89,29) + jvs(70) = b(61,34) + jvs(71) = b(61,35)+b(89,35) + jvs(72) = -b(55,39) + jvs(73) = -b(99,20)-b(100,20)-b(101,20) + jvs(74) = b(98,32) + jvs(75) = -b(101,35) + jvs(76) = -b(100,38) + jvs(77) = b(47,8) + jvs(78) = 0.5*b(56,17) + jvs(79) = -b(58,21)-b(60,21)-b(62,21)-b(64,21) + jvs(80) = -b(62,34) + jvs(81) = -b(60,36) + jvs(82) = -b(58,38) + jvs(83) = b(47,39)+0.5*b(56,39) + jvs(84) = b(65,6) + jvs(85) = b(54,17)+0.5*b(56,17) + jvs(86) = b(58,21)+b(60,21)+0.8*b(64,21) + jvs(87) = -b(66,22)-b(67,22)-b(68,22) + jvs(88) = 0 + jvs(89) = b(60,36)-b(68,36) + jvs(90) = b(58,38) + jvs(91) = 0.5*b(56,39)+b(65,39)-b(67,39) + jvs(92) = b(84,10) + jvs(93) = 0 + jvs(94) = -b(85,23)-b(86,23) + jvs(95) = 0 + jvs(96) = -b(86,35) + jvs(97) = -b(85,38) + jvs(98) = b(84,39) + jvs(99) = 2*b(42,13) + jvs(100) = b(68,22) + jvs(101) = -b(4,24)-b(27,24) + jvs(102) = b(76,26) + jvs(103) = b(52,28) + jvs(104) = b(88,29) + jvs(105) = b(103,33) + jvs(106) = 0.3*b(41,34) + jvs(107) = 0.3*b(41,36)+b(52,36)+b(68,36)+b(76,36)+b(88,36) + jvs(108) = b(24,37)+b(103,37) + jvs(109) = 0 + jvs(110) = b(24,39)-b(27,39) + jvs(111) = b(70,9) + jvs(112) = b(67,22)+b(68,22) + jvs(113) = -b(69,25)-b(71,25)-b(72,25)-b(73,25)-b(74,25) + jvs(114) = -b(73,34) + jvs(115) = b(68,36)-b(72,36) + jvs(116) = -b(69,37) + jvs(117) = -b(71,38) + jvs(118) = b(67,39) + jvs(119) = -b(75,26)-b(76,26)-b(77,26)-b(78,26) + jvs(120) = -b(77,30) + jvs(121) = -b(76,36) + jvs(122) = -b(75,39)-b(78,39) + jvs(123) = b(75,26)+b(76,26) + jvs(124) = -b(79,27)-b(80,27)-b(81,27)-2*b(82,27) + jvs(125) = 0 + jvs(126) = -b(81,32) + jvs(127) = -b(80,35) + jvs(128) = b(76,36) + jvs(129) = -b(79,38) + jvs(130) = b(75,39) + jvs(131) = b(48,12) + jvs(132) = b(53,19)+0.3*b(55,19) + jvs(133) = b(101,20) + jvs(134) = b(85,23)+2*b(86,23) + jvs(135) = 0 + jvs(136) = b(79,27)+2*b(80,27)+b(81,27) + jvs(137) = -b(49,28)-b(50,28)-b(51,28)-b(52,28)-b(106,28) + jvs(138) = 0 + jvs(139) = 0 + jvs(140) = b(81,32)+b(96,32) + jvs(141) = -b(106,33) + jvs(142) = 0 + jvs(143) = b(57,35)+b(59,35)+0.66*b(63,35)+2*b(80,35)+2*b(86,35) & + +b(96,35)+b(101,35) + jvs(144) = -b(52,36)+b(59,36) + jvs(145) = b(57,38)+b(79,38)+b(85,38) + jvs(146) = b(48,39)-b(51,39)+0.3*b(55,39) + jvs(147) = 0.73*b(83,16) + jvs(148) = 0 + jvs(149) = -b(87,29)-b(88,29)-b(89,29)-b(90,29)-b(91,29) + jvs(150) = 0 + jvs(151) = -b(91,33) + jvs(152) = -b(87,34) + jvs(153) = -b(89,35) + jvs(154) = -b(88,36) + jvs(155) = 0.73*b(83,39)-b(90,39) + jvs(156) = b(10,5)+b(11,5) + jvs(157) = -b(77,26) + jvs(158) = -b(13,30)-b(14,30)-b(15,30)-b(16,30)-b(17,30) & + -b(77,30) + jvs(159) = b(7,31)-b(14,31) + jvs(160) = 0.89*b(2,36) + jvs(161) = b(1,37)-b(15,37)-b(16,37) + jvs(162) = -b(17,38) + jvs(163) = 0 + jvs(164) = 0.4*b(73,25) + jvs(165) = b(13,30)-b(14,30) + jvs(166) = -b(7,31)-b(8,31)-b(14,31)-b(18,31)-b(19,31)-b(20,31) & + -b(21,31)-b(94,31) + jvs(167) = -b(94,32) + jvs(168) = -b(21,34)+0.4*b(73,34) + jvs(169) = 0 + jvs(170) = -b(19,37) + jvs(171) = -b(18,38) + jvs(172) = -b(20,39) + jvs(173) = b(99,20) + jvs(174) = b(85,23)+b(86,23) + jvs(175) = b(77,26)+0.035*b(78,26) + jvs(176) = b(79,27)+b(80,27)+1.85*b(82,27) + jvs(177) = b(87,29)+b(88,29)+b(89,29)+b(90,29)+b(91,29) + jvs(178) = b(77,30) + jvs(179) = -b(94,31) + jvs(180) = -b(92,32)-b(93,32)-b(94,32)-b(95,32)-b(96,32) & + -b(97,32)-b(98,32) + jvs(181) = b(91,33) + jvs(182) = b(87,34)-b(95,34) + jvs(183) = b(80,35)+b(86,35)+b(89,35)-b(96,35) + jvs(184) = b(88,36) + jvs(185) = -b(93,37) + jvs(186) = b(79,38)+b(85,38) + jvs(187) = 0.035*b(78,39)+b(90,39)-b(97,39) + jvs(188) = b(100,20)+b(101,20) + jvs(189) = b(81,27) + jvs(190) = -b(106,28) + jvs(191) = -b(91,29) + jvs(192) = 0 + jvs(193) = b(94,31) + jvs(194) = b(81,32)+b(93,32)+b(94,32)+b(95,32)+b(96,32) + jvs(195) = -b(91,33)-b(102,33)-b(103,33)-b(104,33)-b(105,33) & + -b(106,33) + jvs(196) = b(95,34)-b(105,34) + jvs(197) = b(96,35)+b(101,35) + jvs(198) = 0 + jvs(199) = b(93,37)-b(103,37) + jvs(200) = b(100,38)-b(104,38) + jvs(201) = 0 + jvs(202) = b(65,6) + jvs(203) = b(45,7) + jvs(204) = b(30,11) + jvs(205) = b(48,12) + jvs(206) = b(5,14)+b(36,14) + jvs(207) = b(44,15) + jvs(208) = 0.27*b(83,16) + jvs(209) = b(54,17) + jvs(210) = b(53,19) + jvs(211) = b(101,20) + jvs(212) = b(58,21)+b(60,21)-b(62,21)+0.6*b(64,21) + jvs(213) = b(66,22) + jvs(214) = b(86,23) + jvs(215) = -b(73,25) + jvs(216) = 0.965*b(78,26) + jvs(217) = b(80,27) + jvs(218) = 2*b(49,28)+b(51,28)+b(52,28)+b(106,28) + jvs(219) = -b(87,29) + jvs(220) = 0 + jvs(221) = b(20,31)-b(21,31) + jvs(222) = -b(95,32)+b(96,32) + jvs(223) = -b(105,33)+b(106,33) + jvs(224) = -b(21,34)-b(29,34)-2*b(31,34)-2*b(32,34)-b(33,34) & + -b(34,34)-b(35,34)-b(41,34)-b(61,34)-b(62,34)-b(73,34) & + -b(87,34)-b(95,34)-b(105,34) + jvs(225) = b(57,35)+b(59,35)-b(61,35)+0.32*b(63,35)+b(80,35) & + +b(86,35)+b(96,35)+b(101,35) + jvs(226) = b(25,36)-b(41,36)+b(52,36)+b(59,36)+b(60,36) + jvs(227) = -b(34,37)-b(35,37) + jvs(228) = -b(33,38)+b(57,38)+b(58,38) + jvs(229) = b(20,39)+b(22,39)+b(25,39)-b(29,39)+b(30,39)+b(44,39) & + +b(45,39)+b(48,39)+b(51,39)+b(65,39)+0.965*b(78,39) & + +0.27*b(83,39) + jvs(230) = 0.73*b(83,16) + jvs(231) = 0.7*b(55,19) + jvs(232) = -b(101,20) + jvs(233) = b(66,22) + jvs(234) = -b(86,23) + jvs(235) = b(71,25)+b(72,25)+b(74,25) + jvs(236) = b(77,26)+0.035*b(78,26) + jvs(237) = -b(80,27) + jvs(238) = -b(89,29) + jvs(239) = b(77,30) + jvs(240) = 0 + jvs(241) = b(92,32)-b(96,32) + jvs(242) = b(102,33) + jvs(243) = -b(61,34) + jvs(244) = -b(57,35)-b(59,35)-b(61,35)-b(63,35)-b(80,35) & + -b(86,35)-b(89,35)-b(96,35)-b(101,35) + jvs(245) = -b(59,36)+b(72,36) + jvs(246) = 0 + jvs(247) = -b(57,38)+b(71,38) + jvs(248) = b(46,39)+0.7*b(55,39)+0.035*b(78,39)+0.73*b(83,39) + jvs(249) = b(6,13)+b(43,13) + jvs(250) = -b(60,21) + jvs(251) = -b(68,22) + jvs(252) = b(27,24) + jvs(253) = -b(72,25) + jvs(254) = -b(76,26) + jvs(255) = -b(52,28) + jvs(256) = -b(88,29) + jvs(257) = b(16,30) + jvs(258) = b(19,31) + jvs(259) = 0 + jvs(260) = 0 + jvs(261) = -b(41,34) + jvs(262) = -b(59,35) + jvs(263) = 0 + jvs(264) = b(16,37)+b(19,37)-b(38,37)-b(39,37) + jvs(265) = -b(37,38) + jvs(266) = -b(25,39)+b(27,39) + jvs(267) = b(70,9) + jvs(268) = b(6,13)+b(43,13) + jvs(269) = b(5,14)+b(28,14)+b(36,14) + jvs(270) = b(26,18) + jvs(271) = b(100,20) + jvs(272) = b(58,21)+b(60,21) + jvs(273) = b(85,23) + jvs(274) = b(4,24) + jvs(275) = -b(69,25)+b(71,25)+b(72,25) + jvs(276) = 0 + jvs(277) = b(79,27) + jvs(278) = 0 + jvs(279) = 0 + jvs(280) = -b(15,30)-b(16,30)+b(17,30) + jvs(281) = b(18,31)-b(19,31) + jvs(282) = -b(93,32) + jvs(283) = -b(103,33) + jvs(284) = b(33,34)-b(34,34)-b(35,34)+0.7*b(41,34) + jvs(285) = b(57,35)+b(59,35) + jvs(286) = -b(1,37)-b(15,37)-b(16,37)-b(19,37)-b(24,37)-b(34,37) & + -b(35,37)-b(39,37)-b(69,37)-b(93,37)-b(103,37) + jvs(287) = b(17,38)+b(18,38)+b(33,38)+2*b(37,38)+b(57,38) & + +b(58,38)+b(71,38)+b(79,38)+b(85,38)+b(100,38) + jvs(288) = -b(24,39)+b(25,39)+b(26,39)+b(28,39) + jvs(289) = b(3,18) + jvs(290) = -b(100,20) + jvs(291) = -b(58,21) + jvs(292) = -b(85,23) + jvs(293) = -b(71,25) + jvs(294) = 0 + jvs(295) = -b(79,27) + jvs(296) = b(15,30)-b(17,30) + jvs(297) = -b(18,31) + jvs(298) = b(93,32) + jvs(299) = -b(104,33) + jvs(300) = -b(33,34) + jvs(301) = -b(57,35) + jvs(302) = 0.11*b(2,36)-b(37,36)+b(38,36) + jvs(303) = b(1,37)+b(15,37)+b(38,37)+b(93,37) + jvs(304) = -b(17,38)-b(18,38)-b(23,38)-b(33,38)-b(37,38) & + -b(57,38)-b(58,38)-b(71,38)-b(79,38)-b(85,38) & + -b(100,38)-b(104,38) + jvs(305) = -b(23,39) + jvs(306) = 2*b(12,5) + jvs(307) = -b(65,6) + jvs(308) = -b(45,7) + jvs(309) = -b(47,8) + jvs(310) = -b(84,10) + jvs(311) = 2*b(9,11)-b(30,11) + jvs(312) = -b(48,12) + jvs(313) = -b(28,14) + jvs(314) = -b(44,15) + jvs(315) = -b(83,16) + jvs(316) = b(54,17)-0.5*b(56,17) + jvs(317) = b(3,18)-b(26,18) + jvs(318) = b(53,19)-0.7*b(55,19) + jvs(319) = 0 + jvs(320) = -b(67,22) + jvs(321) = b(4,24)-b(27,24) + jvs(322) = -b(75,26)-b(78,26) + jvs(323) = -b(51,28) + jvs(324) = -b(90,29) + jvs(325) = 0 + jvs(326) = -b(20,31)+b(21,31) + jvs(327) = b(95,32)-b(97,32) + jvs(328) = 0 + jvs(329) = b(21,34)-b(29,34)+b(33,34)+0.7*b(41,34)+b(95,34) + jvs(330) = 0 + jvs(331) = -b(25,36)+0.7*b(41,36) + jvs(332) = -b(24,37) + jvs(333) = -b(23,38)+b(33,38) + jvs(334) = -b(20,39)-b(22,39)-b(23,39)-b(24,39)-b(25,39) & + -b(26,39)-b(27,39)-b(28,39)-b(29,39)-b(30,39)-b(44,39) & + -b(45,39)-b(46,39)-b(47,39)-b(48,39)-b(51,39)-0.7 & + *b(55,39)-0.5*b(56,39)-b(65,39)-b(67,39)-b(75,39) & + -b(78,39)-b(83,39)-b(84,39)-b(90,39)-b(97,39) + return + end subroutine cbmz_v02r04_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r04 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = non-zero elements of the sparse jacobian [input] + real v(lu_nonzero_v_r04_kpp) + + integer lu_crow_v(nvar_r04_kpp + 1) + integer lu_diag_v(nvar_r04_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r04_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r04_kpp + 1) + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r04_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r04_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r04 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(21) = x(21)-jvs(77)*x(8)-jvs(78)*x(17) + x(22) = x(22)-jvs(84)*x(6)-jvs(85)*x(17)-jvs(86)*x(21) + x(23) = x(23)-jvs(92)*x(10)-jvs(93)*x(16) + x(24) = x(24)-jvs(99)*x(13)-jvs(100)*x(22) + x(25) = x(25)-jvs(111)*x(9)-jvs(112)*x(22) + x(27) = x(27)-jvs(123)*x(26) + x(28) = x(28)-jvs(131)*x(12)-jvs(132)*x(19)-jvs(133)*x(20) & + -jvs(134)*x(23)-jvs(135)*x(26)-jvs(136)*x(27) + x(29) = x(29)-jvs(147)*x(16)-jvs(148)*x(26) + x(30) = x(30)-jvs(156)*x(5)-jvs(157)*x(26) + x(31) = x(31)-jvs(164)*x(25)-jvs(165)*x(30) + x(32) = x(32)-jvs(173)*x(20)-jvs(174)*x(23)-jvs(175)*x(26) & + -jvs(176)*x(27)-jvs(177)*x(29)-jvs(178)*x(30)-jvs(179) & + *x(31) + x(33) = x(33)-jvs(188)*x(20)-jvs(189)*x(27)-jvs(190)*x(28) & + -jvs(191)*x(29)-jvs(192)*x(30)-jvs(193)*x(31)-jvs(194) & + *x(32) + x(34) = x(34)-jvs(202)*x(6)-jvs(203)*x(7)-jvs(204)*x(11) & + -jvs(205)*x(12)-jvs(206)*x(14)-jvs(207)*x(15)-jvs(208) & + *x(16)-jvs(209)*x(17)-jvs(210)*x(19)-jvs(211)*x(20) & + -jvs(212)*x(21)-jvs(213)*x(22)-jvs(214)*x(23)-jvs(215) & + *x(25)-jvs(216)*x(26)-jvs(217)*x(27)-jvs(218)*x(28) & + -jvs(219)*x(29)-jvs(220)*x(30)-jvs(221)*x(31)-jvs(222) & + *x(32)-jvs(223)*x(33) + x(35) = x(35)-jvs(230)*x(16)-jvs(231)*x(19)-jvs(232)*x(20) & + -jvs(233)*x(22)-jvs(234)*x(23)-jvs(235)*x(25)-jvs(236) & + *x(26)-jvs(237)*x(27)-jvs(238)*x(29)-jvs(239)*x(30) & + -jvs(240)*x(31)-jvs(241)*x(32)-jvs(242)*x(33)-jvs(243) & + *x(34) + x(36) = x(36)-jvs(249)*x(13)-jvs(250)*x(21)-jvs(251)*x(22) & + -jvs(252)*x(24)-jvs(253)*x(25)-jvs(254)*x(26)-jvs(255) & + *x(28)-jvs(256)*x(29)-jvs(257)*x(30)-jvs(258)*x(31) & + -jvs(259)*x(32)-jvs(260)*x(33)-jvs(261)*x(34)-jvs(262) & + *x(35) + x(37) = x(37)-jvs(267)*x(9)-jvs(268)*x(13)-jvs(269)*x(14) & + -jvs(270)*x(18)-jvs(271)*x(20)-jvs(272)*x(21)-jvs(273) & + *x(23)-jvs(274)*x(24)-jvs(275)*x(25)-jvs(276)*x(26) & + -jvs(277)*x(27)-jvs(278)*x(28)-jvs(279)*x(29)-jvs(280) & + *x(30)-jvs(281)*x(31)-jvs(282)*x(32)-jvs(283)*x(33) & + -jvs(284)*x(34)-jvs(285)*x(35) + x(38) = x(38)-jvs(289)*x(18)-jvs(290)*x(20)-jvs(291)*x(21) & + -jvs(292)*x(23)-jvs(293)*x(25)-jvs(294)*x(26)-jvs(295) & + *x(27)-jvs(296)*x(30)-jvs(297)*x(31)-jvs(298)*x(32) & + -jvs(299)*x(33)-jvs(300)*x(34)-jvs(301)*x(35)-jvs(302) & + *x(36)-jvs(303)*x(37) + x(39) = x(39)-jvs(306)*x(5)-jvs(307)*x(6)-jvs(308)*x(7)-jvs(309) & + *x(8)-jvs(310)*x(10)-jvs(311)*x(11)-jvs(312)*x(12) & + -jvs(313)*x(14)-jvs(314)*x(15)-jvs(315)*x(16)-jvs(316) & + *x(17)-jvs(317)*x(18)-jvs(318)*x(19)-jvs(319)*x(21) & + -jvs(320)*x(22)-jvs(321)*x(24)-jvs(322)*x(26)-jvs(323) & + *x(28)-jvs(324)*x(29)-jvs(325)*x(30)-jvs(326)*x(31) & + -jvs(327)*x(32)-jvs(328)*x(33)-jvs(329)*x(34)-jvs(330) & + *x(35)-jvs(331)*x(36)-jvs(332)*x(37)-jvs(333)*x(38) + x(39) = x(39)/jvs(334) + x(38) = (x(38)-jvs(305)*x(39))/(jvs(304)) + x(37) = (x(37)-jvs(287)*x(38)-jvs(288)*x(39))/(jvs(286)) + x(36) = (x(36)-jvs(264)*x(37)-jvs(265)*x(38)-jvs(266)*x(39))/ & + (jvs(263)) + x(35) = (x(35)-jvs(245)*x(36)-jvs(246)*x(37)-jvs(247)*x(38) & + -jvs(248)*x(39))/(jvs(244)) + x(34) = (x(34)-jvs(225)*x(35)-jvs(226)*x(36)-jvs(227)*x(37) & + -jvs(228)*x(38)-jvs(229)*x(39))/(jvs(224)) + x(33) = (x(33)-jvs(196)*x(34)-jvs(197)*x(35)-jvs(198)*x(36) & + -jvs(199)*x(37)-jvs(200)*x(38)-jvs(201)*x(39))/(jvs(195)) + x(32) = (x(32)-jvs(181)*x(33)-jvs(182)*x(34)-jvs(183)*x(35) & + -jvs(184)*x(36)-jvs(185)*x(37)-jvs(186)*x(38)-jvs(187) & + *x(39))/(jvs(180)) + x(31) = (x(31)-jvs(167)*x(32)-jvs(168)*x(34)-jvs(169)*x(36) & + -jvs(170)*x(37)-jvs(171)*x(38)-jvs(172)*x(39))/(jvs(166)) + x(30) = (x(30)-jvs(159)*x(31)-jvs(160)*x(36)-jvs(161)*x(37) & + -jvs(162)*x(38)-jvs(163)*x(39))/(jvs(158)) + x(29) = (x(29)-jvs(150)*x(30)-jvs(151)*x(33)-jvs(152)*x(34) & + -jvs(153)*x(35)-jvs(154)*x(36)-jvs(155)*x(39))/(jvs(149)) + x(28) = (x(28)-jvs(138)*x(29)-jvs(139)*x(30)-jvs(140)*x(32) & + -jvs(141)*x(33)-jvs(142)*x(34)-jvs(143)*x(35)-jvs(144) & + *x(36)-jvs(145)*x(38)-jvs(146)*x(39))/(jvs(137)) + x(27) = (x(27)-jvs(125)*x(30)-jvs(126)*x(32)-jvs(127)*x(35) & + -jvs(128)*x(36)-jvs(129)*x(38)-jvs(130)*x(39))/(jvs(124)) + x(26) = (x(26)-jvs(120)*x(30)-jvs(121)*x(36)-jvs(122)*x(39))/ & + (jvs(119)) + x(25) = (x(25)-jvs(114)*x(34)-jvs(115)*x(36)-jvs(116)*x(37) & + -jvs(117)*x(38)-jvs(118)*x(39))/(jvs(113)) + x(24) = (x(24)-jvs(102)*x(26)-jvs(103)*x(28)-jvs(104)*x(29) & + -jvs(105)*x(33)-jvs(106)*x(34)-jvs(107)*x(36)-jvs(108) & + *x(37)-jvs(109)*x(38)-jvs(110)*x(39))/(jvs(101)) + x(23) = (x(23)-jvs(95)*x(26)-jvs(96)*x(35)-jvs(97)*x(38)-jvs(98) & + *x(39))/(jvs(94)) + x(22) = (x(22)-jvs(88)*x(34)-jvs(89)*x(36)-jvs(90)*x(38)-jvs(91) & + *x(39))/(jvs(87)) + x(21) = (x(21)-jvs(80)*x(34)-jvs(81)*x(36)-jvs(82)*x(38)-jvs(83) & + *x(39))/(jvs(79)) + x(20) = (x(20)-jvs(74)*x(32)-jvs(75)*x(35)-jvs(76)*x(38))/ & + (jvs(73)) + x(19) = (x(19)-jvs(69)*x(29)-jvs(70)*x(34)-jvs(71)*x(35)-jvs(72) & + *x(39))/(jvs(68)) + x(18) = (x(18)-jvs(63)*x(33)-jvs(64)*x(34)-jvs(65)*x(37)-jvs(66) & + *x(38)-jvs(67)*x(39))/(jvs(62)) + x(17) = (x(17)-jvs(59)*x(21)-jvs(60)*x(34)-jvs(61)*x(39))/ & + (jvs(58)) + x(16) = (x(16)-jvs(56)*x(26)-jvs(57)*x(39))/(jvs(55)) + x(15) = (x(15)-jvs(50)*x(22)-jvs(51)*x(28)-jvs(52)*x(33)-jvs(53) & + *x(36)-jvs(54)*x(39))/(jvs(49)) + x(14) = (x(14)-jvs(46)*x(34)-jvs(47)*x(37)-jvs(48)*x(39))/ & + (jvs(45)) + x(13) = (x(13)-jvs(43)*x(36)-jvs(44)*x(37))/(jvs(42)) + x(12) = (x(12)-jvs(40)*x(35)-jvs(41)*x(39))/(jvs(39)) + x(11) = (x(11)-jvs(36)*x(29)-jvs(37)*x(34)-jvs(38)*x(39))/ & + (jvs(35)) + x(10) = (x(10)-jvs(33)*x(16)-jvs(34)*x(39))/(jvs(32)) + x(9) = (x(9)-jvs(30)*x(25)-jvs(31)*x(37))/(jvs(29)) + x(8) = (x(8)-jvs(27)*x(21)-jvs(28)*x(39))/(jvs(26)) + x(7) = (x(7)-jvs(24)*x(32)-jvs(25)*x(39))/(jvs(23)) + x(6) = (x(6)-jvs(22)*x(39))/(jvs(21)) + x(5) = (x(5)-jvs(20)*x(31))/(jvs(19)) + x(4) = (x(4)-jvs(18)*x(27))/(jvs(17)) + x(3) = (x(3)-jvs(9)*x(28)-jvs(10)*x(29)-jvs(11)*x(32)-jvs(12) & + *x(33)-jvs(13)*x(34)-jvs(14)*x(37)-jvs(15)*x(38)-jvs(16) & + *x(39))/(jvs(8)) + x(2) = (x(2)-jvs(6)*x(25)-jvs(7)*x(34))/(jvs(5)) + x(1) = (x(1)-jvs(2)*x(7)-jvs(3)*x(33)-jvs(4)*x(39))/(jvs(1)) + return + end subroutine cbmz_v02r04_solve + + +! cbmz_v02r05_torodas.f - created on 18-nov-2003 from previous +! cbmz_v02r05_torodas.f cbmz_v02r05_mapconcs.f +! cbmz_v02r05_maprates.f cbmz_v02r05_dydt.f +! cbmz_v02r05_jacob.f cbmz_v02r05_decomp.f +! cbmz_v02r05_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r05_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r05 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r05_dydt +! external cbmz_v02r05_jacob +! external cbmz_v02r05_decomp +! external cbmz_v02r05_solve + + integer i + + real hmax + + integer lu_crow_v(nvar_r05_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r05_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r05_kpp) + save lu_icol_v + + data( lu_icol_v(i), i = 1, 252 ) / & + 1, 8, 52, 59, 2, 22, 36, 51, 3, 36, 39, 46, & + 51, 56, 4, 42, 47, 52, 53, 54, 55, 56, 59, 5, & + 38, 6, 51, 7, 59, 8, 54, 59, 9, 41, 59, 10, & + 46, 53, 11, 20, 59, 12, 59, 13, 42, 56, 59, 14, & + 53, 57, 15, 59, 15, 16, 27, 59, 17, 26, 53, 57, & + 59, 18, 53, 56, 59, 12, 15, 19, 55, 59, 20, 34, & + 59, 21, 41, 56, 59, 22, 51, 59, 23, 36, 39, 51, & + 58, 59, 24, 52, 53, 55, 56, 59, 25, 42, 56, 58, & + 59, 12, 15, 26, 57, 59, 16, 27, 33, 36, 39, 44, & + 49, 50, 51, 55, 57, 59, 22, 28, 32, 36, 39, 40, & + 45, 47, 51, 52, 57, 59, 29, 54, 55, 58, 11, 20, & + 30, 34, 55, 58, 59, 14, 26, 31, 34, 40, 42, 45, & + 47, 52, 53, 56, 57, 59, 19, 26, 32, 51, 55, 57, & + 59, 33, 48, 49, 56, 59, 34, 43, 57, 59, 33, 35, & + 39, 48, 49, 50, 51, 55, 56, 57, 59, 36, 51, 57, & + 59, 12, 15, 22, 26, 32, 33, 36, 37, 39, 40, 48, & + 49, 50, 51, 55, 56, 57, 59, 34, 38, 43, 54, 55, & + 57, 58, 59, 39, 51, 57, 59, 15, 32, 33, 36, 39, & + 40, 48, 49, 51, 55, 56, 57, 59, 9, 21, 33, 36, & + 39, 41, 48, 49, 50, 51, 55, 56, 57, 59, 20, 34, & + 42, 43, 52, 56, 57, 58, 59, 6, 34, 43, 51, 53 / + + data( lu_icol_v(i), i = 253, 504 ) / & + 55, 57, 59, 36, 39, 44, 50, 51, 55, 56, 57, 59, & + 7, 21, 22, 32, 33, 36, 39, 41, 44, 45, 48, 49, & + 50, 51, 55, 56, 57, 59, 10, 32, 35, 36, 39, 40, & + 45, 46, 48, 49, 50, 51, 53, 55, 56, 57, 59, 22, & + 23, 25, 29, 30, 32, 34, 36, 38, 39, 42, 43, 44, & + 47, 48, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, & + 35, 39, 48, 49, 50, 51, 55, 56, 57, 59, 16, 27, & + 33, 36, 39, 44, 48, 49, 50, 51, 55, 56, 57, 59, & + 17, 19, 26, 44, 49, 50, 51, 53, 55, 56, 57, 59, & + 22, 32, 36, 39, 43, 46, 48, 49, 50, 51, 53, 54, & + 55, 56, 57, 59, 29, 38, 42, 43, 47, 48, 49, 50, & + 51, 52, 53, 54, 55, 56, 57, 58, 59, 10, 14, 17, & + 18, 19, 24, 26, 29, 30, 31, 34, 37, 38, 39, 40, & + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, & + 53, 54, 55, 56, 58, 59, 29, 30, 34, 38, 42, 43, & + 51, 52, 53, 54, 55, 56, 57, 58, 59, 19, 24, 29, & + 30, 34, 37, 38, 39, 40, 41, 43, 44, 46, 48, 49, & + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 7, 8, & + 12, 13, 15, 18, 19, 20, 21, 22, 23, 25, 26, 28, & + 29, 30, 32, 33, 34, 36, 37, 38, 39, 40, 41, 42, & + 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54 / + + data( lu_icol_v(i), i = 505, 606 ) / & + 55, 56, 57, 58, 59, 14, 26, 31, 34, 36, 37, 39, & + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, & + 52, 53, 54, 55, 56, 57, 58, 59, 20, 25, 29, 30, & + 34, 35, 36, 38, 39, 42, 43, 45, 46, 48, 49, 50, & + 51, 52, 53, 54, 55, 56, 57, 58, 59, 6, 7, 8, & + 9, 11, 12, 13, 15, 16, 18, 20, 21, 22, 23, 24, & + 25, 26, 27, 28, 31, 32, 33, 34, 35, 36, 39, 40, & + 41, 42, 43, 44, 45, 47, 48, 49, 50, 51, 52, 53, & + 54, 55, 56, 57, 58, 59 / + + data lu_crow_v / & + 1, 5, 9, 15, 24, 26, 28, 30, 33, 36, 39, 42, & + 44, 48, 51, 53, 57, 62, 66, 71, 74, 78, 81, 87, & + 93, 98,103,115,127,131,138,151,158,163,167,178, & + 182,200,208,212,225,239,248,256,265,283,300,325, & + 335,349,361,377,394,427,442,467,510,537,562,607 & + / + + data lu_diag_v / & + 1, 5, 9, 15, 24, 26, 28, 30, 33, 36, 39, 42, & + 44, 48, 51, 54, 57, 62, 68, 71, 74, 78, 81, 87, & + 93,100,104,116,127,133,140,153,158,163,168,178, & + 189,201,208,217,230,241,250,258,274,290,313,327, & + 342,354,370,386,421,436,462,506,534,560,606,607 & + / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r05_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r05_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r05_dydt, & + cbmz_v02r05_jacob, & + cbmz_v02r05_decomp, & + cbmz_v02r05_solve ) + + return + end subroutine cbmz_v02r05_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r05 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r05_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ihcooh_kpp + parameter ( ihcooh_kpp = 2 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 3 ) + integer imsa_kpp + parameter ( imsa_kpp = 4 ) + integer imtf_kpp + parameter ( imtf_kpp = 5 ) + integer io1d_kpp + parameter ( io1d_kpp = 6 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 7 ) + integer iso2_kpp + parameter ( iso2_kpp = 8 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 9 ) + integer ipan_kpp + parameter ( ipan_kpp = 10 ) + integer idmso2_kpp + parameter ( idmso2_kpp = 11 ) + integer itol_kpp + parameter ( itol_kpp = 12 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 13 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 14 ) + integer ixyl_kpp + parameter ( ixyl_kpp = 15 ) + integer ipar_kpp + parameter ( ipar_kpp = 16 ) + integer icro_kpp + parameter ( icro_kpp = 17 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 18 ) + integer ito2_kpp + parameter ( ito2_kpp = 19 ) + integer idmso_kpp + parameter ( idmso_kpp = 20 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 21 ) + integer ieth_kpp + parameter ( ieth_kpp = 22 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 23 ) + integer ihono_kpp + parameter ( ihono_kpp = 24 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 25 ) + integer icres_kpp + parameter ( icres_kpp = 26 ) + integer ixpar_kpp + parameter ( ixpar_kpp = 27 ) + integer ico_kpp + parameter ( ico_kpp = 28 ) + integer ich3so2oo_kpp + parameter ( ich3so2oo_kpp = 29 ) + integer ich3so2ch2oo_kpp + parameter ( ich3so2ch2oo_kpp = 30 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 31 ) + integer iopen_kpp + parameter ( iopen_kpp = 32 ) + integer irooh_kpp + parameter ( irooh_kpp = 33 ) + integer idms_kpp + parameter ( idms_kpp = 34 ) + integer iaone_kpp + parameter ( iaone_kpp = 35 ) + integer iolet_kpp + parameter ( iolet_kpp = 36 ) + integer ixo2_kpp + parameter ( ixo2_kpp = 37 ) + integer ich3sch2oo_kpp + parameter ( ich3sch2oo_kpp = 38 ) + integer iolei_kpp + parameter ( iolei_kpp = 39 ) + integer imgly_kpp + parameter ( imgly_kpp = 40 ) + integer iethp_kpp + parameter ( iethp_kpp = 41 ) + integer ich3so2h_kpp + parameter ( ich3so2h_kpp = 42 ) + integer io3p_kpp + parameter ( io3p_kpp = 43 ) + integer inap_kpp + parameter ( inap_kpp = 44 ) + integer iald2_kpp + parameter ( iald2_kpp = 45 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 46 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 47 ) + integer iano2_kpp + parameter ( iano2_kpp = 48 ) + integer iro2_kpp + parameter ( iro2_kpp = 49 ) + integer ionit_kpp + parameter ( ionit_kpp = 50 ) + integer io3_kpp + parameter ( io3_kpp = 51 ) + integer ich3so3_kpp + parameter ( ich3so3_kpp = 52 ) + integer ino2_kpp + parameter ( ino2_kpp = 53 ) + integer ich3so2_kpp + parameter ( ich3so2_kpp = 54 ) + integer ino_kpp + parameter ( ino_kpp = 55 ) + integer iho2_kpp + parameter ( iho2_kpp = 56 ) + integer ino3_kpp + parameter ( ino3_kpp = 57 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 58 ) + integer ioh_kpp + parameter ( ioh_kpp = 59 ) + +! indexes declaration for fixed species + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + nyy = nvar_r05_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ihcooh_kpp) = cbox(ihcooh_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(imsa_kpp) = cbox(imsa_z) + yy(imtf_kpp) = cbox(imtf_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(idmso2_kpp) = cbox(idmso2_z) + yy(itol_kpp) = cbox(itol_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ixyl_kpp) = cbox(ixyl_z) + yy(ipar_kpp) = cbox(ipar_z) + yy(icro_kpp) = cbox(icro_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ito2_kpp) = cbox(ito2_z) + yy(idmso_kpp) = cbox(idmso_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(ieth_kpp) = cbox(ieth_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(icres_kpp) = cbox(icres_z) + yy(ixpar_kpp) = cbox(ixpar_z) + yy(ico_kpp) = cbox(ico_z) + yy(ich3so2oo_kpp) = cbox(ich3so2oo_z) + yy(ich3so2ch2oo_kpp) = cbox(ich3so2ch2oo_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(iopen_kpp) = cbox(iopen_z) + yy(irooh_kpp) = cbox(irooh_z) + yy(idms_kpp) = cbox(idms_z) + yy(iaone_kpp) = cbox(iaone_z) + yy(iolet_kpp) = cbox(iolet_z) + yy(ixo2_kpp) = cbox(ixo2_z) + yy(ich3sch2oo_kpp) = cbox(ich3sch2oo_z) + yy(iolei_kpp) = cbox(iolei_z) + yy(imgly_kpp) = cbox(imgly_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(ich3so2h_kpp) = cbox(ich3so2h_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(inap_kpp) = cbox(inap_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(iano2_kpp) = cbox(iano2_z) + yy(iro2_kpp) = cbox(iro2_z) + yy(ionit_kpp) = cbox(ionit_z) + yy(io3_kpp) = cbox(io3_z) + yy(ich3so3_kpp) = cbox(ich3so3_z) + yy(ino2_kpp) = cbox(ino2_z) + yy(ich3so2_kpp) = cbox(ich3so2_z) + yy(ino_kpp) = cbox(ino_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(ino3_kpp) = cbox(ino3_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(ioh_kpp) = cbox(ioh_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ihcooh_z) = yy(ihcooh_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(imsa_z) = yy(imsa_kpp) + cbox(imtf_z) = yy(imtf_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(idmso2_z) = yy(idmso2_kpp) + cbox(itol_z) = yy(itol_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ixyl_z) = yy(ixyl_kpp) + cbox(ipar_z) = yy(ipar_kpp) + cbox(icro_z) = yy(icro_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ito2_z) = yy(ito2_kpp) + cbox(idmso_z) = yy(idmso_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(ieth_z) = yy(ieth_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(icres_z) = yy(icres_kpp) + cbox(ixpar_z) = yy(ixpar_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(ich3so2oo_z) = yy(ich3so2oo_kpp) + cbox(ich3so2ch2oo_z) = yy(ich3so2ch2oo_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(iopen_z) = yy(iopen_kpp) + cbox(irooh_z) = yy(irooh_kpp) + cbox(idms_z) = yy(idms_kpp) + cbox(iaone_z) = yy(iaone_kpp) + cbox(iolet_z) = yy(iolet_kpp) + cbox(ixo2_z) = yy(ixo2_kpp) + cbox(ich3sch2oo_z) = yy(ich3sch2oo_kpp) + cbox(iolei_z) = yy(iolei_kpp) + cbox(imgly_z) = yy(imgly_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(ich3so2h_z) = yy(ich3so2h_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(inap_z) = yy(inap_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(iano2_z) = yy(iano2_kpp) + cbox(iro2_z) = yy(iro2_kpp) + cbox(ionit_z) = yy(ionit_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(ich3so3_z) = yy(ich3so3_kpp) + cbox(ino2_z) = yy(ino2_kpp) + cbox(ich3so2_z) = yy(ich3so2_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(ino3_z) = yy(ino3_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(ioh_z) = yy(ioh_kpp) + + return + end subroutine cbmz_v02r05_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r05 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + rconst(75) = (rk_m2(1)) + rconst(76) = (rk_m2(5)) + rconst(77) = (rk_m2(6)) + rconst(78) = (rk_m2(7)) + rconst(79) = (rk_m2(8)) + rconst(80) = (rk_m2(9)) + rconst(81) = (rk_m2(10)) + rconst(82) = (rk_m2(11)) + rconst(83) = (rk_m2(12)) + rconst(84) = (rk_m2(13)) + rconst(85) = (rk_m2(14)) + rconst(86) = (rk_m2(15)) + rconst(87) = (rk_m2(16)) + rconst(88) = (rk_m2(17)) + rconst(89) = (rk_m2(18)) + rconst(90) = (rk_m2(19)) + rconst(91) = (rk_m2(20)) + rconst(92) = (rk_m2(21)) + rconst(93) = (rk_m2(22)) + rconst(94) = (rk_m2(23)) + rconst(95) = (rk_m2(24)) + rconst(96) = (rk_m2(25)) + rconst(97) = (rk_m2(26)) + rconst(98) = (rk_m2(27)) + rconst(99) = (rk_m2(28)) + rconst(100) = (rk_m2(29)) + rconst(101) = (rk_m2(30)) + rconst(102) = (rk_m2(33)) + rconst(103) = (rk_m2(35)) + rconst(104) = (rk_m2(36)) + rconst(105) = (rk_m2(37)) + rconst(106) = (rk_m2(38)) + rconst(107) = (rk_m2(40)) + rconst(108) = (rk_m2(41)) + rconst(109) = (rk_m2(42)) + rconst(110) = (rk_m2(43)) + rconst(111) = (rk_m2(45)) + rconst(112) = (rk_m2(46)) + rconst(113) = (rk_m2(47)) + rconst(114) = (rk_m2(48)) + rconst(115) = (rk_m2(50)) + rconst(116) = (rk_m2(51)) + rconst(117) = (rk_m2(52)) + rconst(118) = (rk_m2(53)) + rconst(119) = (rk_m4(1)) + rconst(120) = (rk_m4(2)) + rconst(121) = (rk_m4(3)) + rconst(122) = (rk_m4(4)) + rconst(123) = (rk_m4(5)) + rconst(124) = (rk_m4(6)) + rconst(125) = (rk_m4(7)) + rconst(126) = (rk_m4(8)) + rconst(127) = (rk_m4(9)) + rconst(128) = (rk_m4(10)) + rconst(129) = (rk_m4(11)) + rconst(130) = (rk_m4(12)) + rconst(131) = (rk_m4(13)) + rconst(132) = (rk_m4(14)) + rconst(133) = (rk_m4(15)) + rconst(134) = (rk_m4(16)) + rconst(135) = (rk_m4(17)) + rconst(136) = (rk_m4(18)) + rconst(137) = (rk_m4(19)) + rconst(138) = (rk_m4(20)) + rconst(139) = (rk_m4(21)) + rconst(140) = (rk_m4(22)) + rconst(141) = (rk_m4(23)) + rconst(142) = (rk_m4(24)) + rconst(143) = (rk_m4(25)) + rconst(144) = (rk_m4(26)) + rconst(145) = (rk_m4(27)) + rconst(146) = (rk_m4(28)) + rconst(147) = (rk_m4(29)) + rconst(148) = (rk_m4(30)) + rconst(149) = (rk_m4(31)) + rconst(150) = (rk_m4(32)) + return + end subroutine cbmz_v02r05_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r05 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r05_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r05_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r05_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r05_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(53) + a(2) = rconst(2)*v(57) + a(3) = rconst(3)*v(24) + a(4) = rconst(4)*v(31) + a(5) = rconst(5)*v(18) + a(6) = rconst(6)*v(14) + a(7) = rconst(7)*v(51) + a(8) = rconst(8)*v(51) + a(9) = rconst(9)*v(13) + a(10) = rconst(10)*v(6)*f(4) + a(11) = rconst(11)*v(6)*f(5) + a(12) = rconst(12)*v(6)*f(2) + a(13) = rconst(13)*v(43)*f(4) + a(14) = rconst(14)*v(43)*v(51) + a(15) = rconst(15)*v(43)*v(53) + a(16) = rconst(16)*v(43)*v(53) + a(17) = rconst(17)*v(43)*v(55) + a(18) = rconst(18)*v(51)*v(55) + a(19) = rconst(19)*v(51)*v(53) + a(20) = rconst(20)*v(51)*v(59) + a(21) = rconst(21)*v(51)*v(56) + a(22) = rconst(22)*v(59)*f(3) + a(23) = rconst(23)*v(55)*v(59) + a(24) = rconst(24)*v(53)*v(59) + a(25) = rconst(25)*v(57)*v(59) + a(26) = rconst(26)*v(24)*v(59) + a(27) = rconst(27)*v(31)*v(59) + a(28) = rconst(28)*v(18)*v(59) + a(29) = rconst(29)*v(56)*v(59) + a(30) = rconst(30)*v(13)*v(59) + a(31) = rconst(31)*v(56)*v(56) + a(32) = rconst(32)*v(56)*v(56)*f(2) + a(33) = rconst(33)*v(55)*v(56) + a(34) = rconst(34)*v(53)*v(56) + a(35) = rconst(35)*v(53)*v(56) + a(36) = rconst(36)*v(18) + a(37) = rconst(37)*v(55)*v(57) + a(38) = rconst(38)*v(53)*v(57) + a(39) = rconst(39)*v(53)*v(57) + a(40) = rconst(40)*v(57)*v(57) + a(41) = rconst(41)*v(56)*v(57) + a(42) = rconst(42)*v(14)*f(2) + a(43) = rconst(43)*v(14) + a(44) = rconst(44)*v(28)*v(59) + a(45) = rconst(45)*v(8)*v(59) + a(46) = rconst(46)*v(59)*f(1) + a(47) = rconst(47)*v(9)*v(59) + a(48) = rconst(48)*v(23)*v(59) + a(49) = rconst(49)*v(47) + a(50) = rconst(50)*v(47) + a(51) = rconst(51)*v(47)*v(59) + a(52) = rconst(52)*v(47)*v(57) + a(53) = rconst(53)*v(25) + a(54) = rconst(54)*v(21) + a(55) = rconst(55)*v(25)*v(59) + a(56) = rconst(56)*v(21)*v(59) + a(57) = rconst(57)*v(55)*v(58) + a(58) = rconst(58)*v(41)*v(55) + a(59) = rconst(59)*v(57)*v(58) + a(60) = rconst(60)*v(41)*v(57) + a(61) = rconst(61)*v(56)*v(58) + a(62) = rconst(62)*v(41)*v(56) + a(63) = rconst(63)*v(58) + a(64) = rconst(64)*v(41) + a(65) = rconst(65)*v(7)*v(59) + a(66) = rconst(66)*v(45) + a(67) = rconst(67)*v(45)*v(59) + a(68) = rconst(68)*v(45)*v(57) + a(69) = rconst(69)*v(46)*v(53) + a(70) = rconst(70)*v(10) + a(71) = rconst(71)*v(46)*v(55) + a(72) = rconst(72)*v(46)*v(57) + a(73) = rconst(73)*v(46)*v(56) + a(74) = rconst(74)*v(46) + a(75) = rconst(75)*v(16)*v(59) + a(76) = rconst(76)*v(35) + a(77) = rconst(77)*v(35)*v(59) + a(78) = rconst(78)*v(40) + a(79) = rconst(79)*v(40)*v(59) + a(80) = rconst(80)*v(40)*v(57) + a(81) = rconst(81)*v(22)*v(51) + a(82) = rconst(82)*v(22)*v(59) + a(83) = rconst(83)*v(36)*v(51) + a(84) = rconst(84)*v(39)*v(51) + a(85) = rconst(85)*v(36)*v(59) + a(86) = rconst(86)*v(39)*v(59) + a(87) = rconst(87)*v(36)*v(57) + a(88) = rconst(88)*v(39)*v(57) + a(89) = rconst(89)*v(12)*v(59) + a(90) = rconst(90)*v(15)*v(59) + a(91) = rconst(91)*v(19)*v(55) + a(92) = rconst(92)*v(26)*v(59) + a(93) = rconst(93)*v(26)*v(57) + a(94) = rconst(94)*v(17)*v(53) + a(95) = rconst(95)*v(32)*v(59) + a(96) = rconst(96)*v(32) + a(97) = rconst(97)*v(32)*v(51) + a(98) = rconst(98)*v(33) + a(99) = rconst(99)*v(33)*v(59) + a(100) = rconst(100)*v(50)*v(59) + a(101) = rconst(101)*v(50) + a(102) = rconst(102)*v(49)*v(55) + a(103) = rconst(103)*v(48)*v(55) + a(104) = rconst(104)*v(44)*v(55) + a(105) = rconst(105)*v(37)*v(55) + a(106) = rconst(106)*v(49)*v(57) + a(107) = rconst(107)*v(48)*v(57) + a(108) = rconst(108)*v(44)*v(57) + a(109) = rconst(109)*v(37)*v(57) + a(110) = rconst(110)*v(49)*v(56) + a(111) = rconst(111)*v(48)*v(56) + a(112) = rconst(112)*v(44)*v(56) + a(113) = rconst(113)*v(37)*v(56) + a(114) = rconst(114)*v(49) + a(115) = rconst(115)*v(48) + a(116) = rconst(116)*v(44) + a(117) = rconst(117)*v(37) + a(118) = rconst(118)*v(16)*v(27) + a(119) = rconst(119)*v(34)*v(59) + a(120) = rconst(120)*v(34)*v(57) + a(121) = rconst(121)*v(34)*v(43) + a(122) = rconst(122)*v(34)*v(59) + a(123) = rconst(123)*v(38)*v(55) + a(124) = rconst(124)*v(38)*v(58) + a(125) = rconst(125)*v(38)*v(54) + a(126) = rconst(126)*v(38)*v(38) + a(127) = rconst(127)*v(20)*v(59) + a(128) = rconst(128)*v(11)*v(59) + a(129) = rconst(129)*v(30)*v(55) + a(130) = rconst(130)*v(30)*v(58) + a(131) = rconst(131)*v(42)*v(56) + a(132) = rconst(132)*v(42)*v(57) + a(133) = rconst(133)*v(42)*v(58) + a(134) = rconst(134)*v(42)*v(59) + a(135) = rconst(135)*v(42)*v(52) + a(136) = rconst(136)*v(54) + a(137) = rconst(137)*v(53)*v(54) + a(138) = rconst(138)*v(51)*v(54) + a(139) = rconst(139)*v(54)*v(56) + a(140) = rconst(140)*v(54)*v(58) + a(141) = rconst(141)*v(54)*v(59) + a(142) = rconst(142)*v(54)*f(4) + a(143) = rconst(143)*v(29) + a(144) = rconst(144)*v(29)*v(55) + a(145) = rconst(145)*v(29)*v(58) + a(146) = rconst(146)*v(52) + a(147) = rconst(147)*v(52)*v(53) + a(148) = rconst(148)*v(52)*v(55) + a(149) = rconst(149)*v(52)*v(56) + a(150) = rconst(150)*v(47)*v(52) + +! aggregate function + a_var(1) = a(45)+a(146) + a_var(2) = 0.52*a(81)+0.22*a(83) + a_var(3) = 0.4*a(73)+0.09*a(83)+0.16*a(84) + a_var(4) = a(135)+a(141)+a(147)+a(148)+a(149)+a(150) + a_var(5) = 0.15*a(126) + a_var(6) = a(8)-a(10)-a(11)-a(12) + a_var(7) = -a(65) + a_var(8) = -a(45)+a(136) + a_var(9) = -a(47)+0.2*a(64) + a_var(10) = a(69)-a(70) + a_var(11) = 0.27*a(127)-a(128) + a_var(12) = -a(89) + a_var(13) = -a(9)-a(30)+a(31)+a(32)+a(131) + a_var(14) = -a(6)+a(39)-a(42)-a(43) + a_var(15) = -a(90) + a_var(16) = -a(75)+1.1*a(90)-a(118) + a_var(17) = 0.4*a(92)+a(93)-a(94) + a_var(18) = -a(5)-a(28)+a(34)-a(36) + a_var(19) = 0.8*a(89)+0.45*a(90)-a(91) + a_var(20) = 0.965*a(122)-a(127) + a_var(21) = -a(54)-a(56)+a(62) + a_var(22) = -a(81)-a(82) + a_var(23) = -a(48)+0.34*a(63)+0.03*a(83)+0.04*a(84) + a_var(24) = -a(3)+a(23)-a(26)+a(35)+a(148) + a_var(25) = -a(53)-a(55)+a(61)+a(133) + a_var(26) = 0.12*a(89)+0.05*a(90)-a(92)-a(93) + a_var(27) = 1.06*a(83)+2.26*a(84)+a(85)+2.23*a(86)+1.98*a(98) & + +0.42*a(99)+1.98*a(101)+1.68*a(102)+a(104)+1.98 & + *a(106)+a(108)+1.25*a(114)+a(116)-a(118) + a_var(28) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66)+a(78)+a(80) & + +0.24*a(81)+0.31*a(83)+0.3*a(84)+2*a(95)+a(96)+0.69 & + *a(97)+a(150) + a_var(29) = a(142)-a(143)-a(144)-a(145) + a_var(30) = a(128)-a(129)-a(130) + a_var(31) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) & + +a(80)+a(93)+a(120)+a(132)+a(147) + a_var(32) = 0.95*a(91)+0.3*a(92)-a(95)-a(96)-a(97) + a_var(33) = -a(98)-a(99)+a(110)+a(111) + a_var(34) = -a(119)-a(120)-a(121)-a(122) + a_var(35) = -a(76)-a(77)+0.07*a(84)+0.23*a(86)+0.74*a(98)+0.74 & + *a(101)+0.62*a(102)+0.74*a(106)+0.57*a(114)+0.15 & + *a(115) + a_var(36) = -a(83)-a(85)-a(87) + a_var(37) = a(79)+a(82)+a(85)+a(86)+0.08*a(89)+0.5*a(90)+0.6 & + *a(92)+a(95)+0.03*a(97)+0.4*a(98)+0.4*a(101)+0.34 & + *a(102)-a(105)+0.4*a(106)-a(109)-a(113)+0.24*a(114) & + -a(117) + a_var(38) = a(119)+a(120)-a(123)-a(124)-a(125)-2*a(126) + a_var(39) = -a(84)-a(86)-a(88) + a_var(40) = -a(78)-a(79)-a(80)+0.04*a(83)+0.07*a(84)+0.8*a(90) & + +0.2*a(97)+0.19*a(99)+0.15*a(115) + a_var(41) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64)+0.06*a(83) & + +0.05*a(84)+0.1*a(98)+0.1*a(101)+0.08*a(102)+0.1 & + *a(106)+0.06*a(114) + a_var(42) = 0.73*a(127)-a(131)-a(132)-a(133)-a(134)-a(135) + a_var(43) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17)-a(121) + a_var(44) = a(87)+a(88)+a(100)-a(104)-a(108)-a(112)-a(116) + a_var(45) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68)+0.22*a(82)+0.47*a(83)+1.03*a(84)+a(85) & + +1.77*a(86)+0.03*a(97)+0.3*a(98)+0.04*a(99)+0.3 & + *a(101)+0.25*a(102)+0.5*a(104)+0.3*a(106)+0.5*a(108) & + +0.21*a(114)+0.5*a(116) + a_var(46) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) & + +a(76)+a(78)+a(79)+a(80)+0.13*a(83)+0.19*a(84)+a(95) & + +a(96)+0.62*a(97)+a(103)+a(107)+0.7*a(115) + a_var(47) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63)+a(81)+1.56*a(82)+0.57*a(83)+a(85) & + +a(95)+0.7*a(97)+a(103)+0.5*a(104)+a(107)+0.5*a(108) & + +0.7*a(115)+0.5*a(116)+a(123)+2*a(124)+a(125)+a(129) & + +2*a(130)+a(140)+a(145)-a(150) + a_var(48) = a(77)+0.11*a(84)-a(103)-a(107)-a(111)-a(115) + a_var(49) = a(75)+0.03*a(83)+0.09*a(84)+0.77*a(99)-a(102)-a(106) & + -a(110)-a(114) + a_var(50) = 0.05*a(91)+a(94)-a(100)-a(101)+0.16*a(102)+0.5 & + *a(104)+0.5*a(108)+a(112)+0.5*a(116) + a_var(51) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73)-a(81)-a(83)-a(84)-a(97)-a(138) + a_var(52) = a(125)-a(135)+a(137)+a(138)+a(139)+a(140)+a(144) & + +a(145)-a(146)-a(147)-a(148)-a(149)-a(150) + a_var(53) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72)+0.95 & + *a(91)-a(94)+a(101)+0.84*a(102)+a(103)+1.5*a(104) & + +a(105)+a(106)+a(107)+1.5*a(108)+a(109)+0.5*a(116) & + +a(123)+a(129)-a(137)+a(144)-a(147) + a_var(54) = a(121)+0.035*a(122)+a(123)+a(124)+1.85*a(126)+a(129) & + +a(130)+a(131)+a(132)+a(133)+a(134)+a(135)-a(136) & + -a(137)-a(138)-a(139)-a(140)-a(141)-a(142)+a(143) + a_var(55) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71)-a(91)-a(102)-a(103) & + -a(104)-a(105)-a(123)-a(129)+a(137)-a(144)-a(148) + a_var(56) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73)+a(78)+0.22*a(81)+a(82)+0.26*a(83)+0.22 & + *a(84)+a(85)+a(86)+0.2*a(89)+0.55*a(90)+0.95*a(91) & + +0.6*a(92)+2*a(95)+a(96)+0.76*a(97)+0.9*a(98)+0.9 & + *a(101)+0.76*a(102)+0.5*a(104)+0.9*a(106)+0.5*a(108) & + -a(110)-a(111)-a(112)-a(113)+0.54*a(114)+0.965*a(122) & + +a(124)+0.27*a(127)+a(130)-a(131)-a(139)+a(140) & + +a(145)-a(149)+a(150) + a_var(57) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) & + -a(80)-a(87)-a(88)-a(93)-a(106)-a(107)-a(108)-a(109) & + -a(120)-a(132) + a_var(58) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74)+a(76)+0.07*a(83)+0.1*a(84)+a(121)+0.035 & + *a(122)-a(124)+0.73*a(127)-a(130)-a(133)+a(136) & + -a(140)-a(145)+a(146) + a_var(59) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67)-a(75)-a(77) & + -a(79)+0.12*a(81)-a(82)+0.33*a(83)+0.6*a(84)-a(85) & + -a(86)-a(89)-a(90)-a(92)-a(95)+0.08*a(97)+a(98)-0.77 & + *a(99)-a(100)-a(119)-a(122)-a(127)-a(128)-a(134) & + +a(139)-a(141) + return + end subroutine cbmz_v02r05_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r05 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r05_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r05_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r05_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r05_kpp,nvar_r05_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,53) = rconst(1) + b(2,57) = rconst(2) + b(3,24) = rconst(3) + b(4,31) = rconst(4) + b(5,18) = rconst(5) + b(6,14) = rconst(6) + b(7,51) = rconst(7) + b(8,51) = rconst(8) + b(9,13) = rconst(9) + b(10,6) = rconst(10)*f(4) + b(11,6) = rconst(11)*f(5) + b(12,6) = rconst(12)*f(2) + b(13,43) = rconst(13)*f(4) + b(14,43) = rconst(14)*v(51) + b(14,51) = rconst(14)*v(43) + b(15,43) = rconst(15)*v(53) + b(15,53) = rconst(15)*v(43) + b(16,43) = rconst(16)*v(53) + b(16,53) = rconst(16)*v(43) + b(17,43) = rconst(17)*v(55) + b(17,55) = rconst(17)*v(43) + b(18,51) = rconst(18)*v(55) + b(18,55) = rconst(18)*v(51) + b(19,51) = rconst(19)*v(53) + b(19,53) = rconst(19)*v(51) + b(20,51) = rconst(20)*v(59) + b(20,59) = rconst(20)*v(51) + b(21,51) = rconst(21)*v(56) + b(21,56) = rconst(21)*v(51) + b(22,59) = rconst(22)*f(3) + b(23,55) = rconst(23)*v(59) + b(23,59) = rconst(23)*v(55) + b(24,53) = rconst(24)*v(59) + b(24,59) = rconst(24)*v(53) + b(25,57) = rconst(25)*v(59) + b(25,59) = rconst(25)*v(57) + b(26,24) = rconst(26)*v(59) + b(26,59) = rconst(26)*v(24) + b(27,31) = rconst(27)*v(59) + b(27,59) = rconst(27)*v(31) + b(28,18) = rconst(28)*v(59) + b(28,59) = rconst(28)*v(18) + b(29,56) = rconst(29)*v(59) + b(29,59) = rconst(29)*v(56) + b(30,13) = rconst(30)*v(59) + b(30,59) = rconst(30)*v(13) + b(31,56) = rconst(31)*2*v(56) + b(32,56) = rconst(32)*2*v(56)*f(2) + b(33,55) = rconst(33)*v(56) + b(33,56) = rconst(33)*v(55) + b(34,53) = rconst(34)*v(56) + b(34,56) = rconst(34)*v(53) + b(35,53) = rconst(35)*v(56) + b(35,56) = rconst(35)*v(53) + b(36,18) = rconst(36) + b(37,55) = rconst(37)*v(57) + b(37,57) = rconst(37)*v(55) + b(38,53) = rconst(38)*v(57) + b(38,57) = rconst(38)*v(53) + b(39,53) = rconst(39)*v(57) + b(39,57) = rconst(39)*v(53) + b(40,57) = rconst(40)*2*v(57) + b(41,56) = rconst(41)*v(57) + b(41,57) = rconst(41)*v(56) + b(42,14) = rconst(42)*f(2) + b(43,14) = rconst(43) + b(44,28) = rconst(44)*v(59) + b(44,59) = rconst(44)*v(28) + b(45,8) = rconst(45)*v(59) + b(45,59) = rconst(45)*v(8) + b(46,59) = rconst(46)*f(1) + b(47,9) = rconst(47)*v(59) + b(47,59) = rconst(47)*v(9) + b(48,23) = rconst(48)*v(59) + b(48,59) = rconst(48)*v(23) + b(49,47) = rconst(49) + b(50,47) = rconst(50) + b(51,47) = rconst(51)*v(59) + b(51,59) = rconst(51)*v(47) + b(52,47) = rconst(52)*v(57) + b(52,57) = rconst(52)*v(47) + b(53,25) = rconst(53) + b(54,21) = rconst(54) + b(55,25) = rconst(55)*v(59) + b(55,59) = rconst(55)*v(25) + b(56,21) = rconst(56)*v(59) + b(56,59) = rconst(56)*v(21) + b(57,55) = rconst(57)*v(58) + b(57,58) = rconst(57)*v(55) + b(58,41) = rconst(58)*v(55) + b(58,55) = rconst(58)*v(41) + b(59,57) = rconst(59)*v(58) + b(59,58) = rconst(59)*v(57) + b(60,41) = rconst(60)*v(57) + b(60,57) = rconst(60)*v(41) + b(61,56) = rconst(61)*v(58) + b(61,58) = rconst(61)*v(56) + b(62,41) = rconst(62)*v(56) + b(62,56) = rconst(62)*v(41) + b(63,58) = rconst(63) + b(64,41) = rconst(64) + b(65,7) = rconst(65)*v(59) + b(65,59) = rconst(65)*v(7) + b(66,45) = rconst(66) + b(67,45) = rconst(67)*v(59) + b(67,59) = rconst(67)*v(45) + b(68,45) = rconst(68)*v(57) + b(68,57) = rconst(68)*v(45) + b(69,46) = rconst(69)*v(53) + b(69,53) = rconst(69)*v(46) + b(70,10) = rconst(70) + b(71,46) = rconst(71)*v(55) + b(71,55) = rconst(71)*v(46) + b(72,46) = rconst(72)*v(57) + b(72,57) = rconst(72)*v(46) + b(73,46) = rconst(73)*v(56) + b(73,56) = rconst(73)*v(46) + b(74,46) = rconst(74) + b(75,16) = rconst(75)*v(59) + b(75,59) = rconst(75)*v(16) + b(76,35) = rconst(76) + b(77,35) = rconst(77)*v(59) + b(77,59) = rconst(77)*v(35) + b(78,40) = rconst(78) + b(79,40) = rconst(79)*v(59) + b(79,59) = rconst(79)*v(40) + b(80,40) = rconst(80)*v(57) + b(80,57) = rconst(80)*v(40) + b(81,22) = rconst(81)*v(51) + b(81,51) = rconst(81)*v(22) + b(82,22) = rconst(82)*v(59) + b(82,59) = rconst(82)*v(22) + b(83,36) = rconst(83)*v(51) + b(83,51) = rconst(83)*v(36) + b(84,39) = rconst(84)*v(51) + b(84,51) = rconst(84)*v(39) + b(85,36) = rconst(85)*v(59) + b(85,59) = rconst(85)*v(36) + b(86,39) = rconst(86)*v(59) + b(86,59) = rconst(86)*v(39) + b(87,36) = rconst(87)*v(57) + b(87,57) = rconst(87)*v(36) + b(88,39) = rconst(88)*v(57) + b(88,57) = rconst(88)*v(39) + b(89,12) = rconst(89)*v(59) + b(89,59) = rconst(89)*v(12) + b(90,15) = rconst(90)*v(59) + b(90,59) = rconst(90)*v(15) + b(91,19) = rconst(91)*v(55) + b(91,55) = rconst(91)*v(19) + b(92,26) = rconst(92)*v(59) + b(92,59) = rconst(92)*v(26) + b(93,26) = rconst(93)*v(57) + b(93,57) = rconst(93)*v(26) + b(94,17) = rconst(94)*v(53) + b(94,53) = rconst(94)*v(17) + b(95,32) = rconst(95)*v(59) + b(95,59) = rconst(95)*v(32) + b(96,32) = rconst(96) + b(97,32) = rconst(97)*v(51) + b(97,51) = rconst(97)*v(32) + b(98,33) = rconst(98) + b(99,33) = rconst(99)*v(59) + b(99,59) = rconst(99)*v(33) + b(100,50) = rconst(100)*v(59) + b(100,59) = rconst(100)*v(50) + b(101,50) = rconst(101) + b(102,49) = rconst(102)*v(55) + b(102,55) = rconst(102)*v(49) + b(103,48) = rconst(103)*v(55) + b(103,55) = rconst(103)*v(48) + b(104,44) = rconst(104)*v(55) + b(104,55) = rconst(104)*v(44) + b(105,37) = rconst(105)*v(55) + b(105,55) = rconst(105)*v(37) + b(106,49) = rconst(106)*v(57) + b(106,57) = rconst(106)*v(49) + b(107,48) = rconst(107)*v(57) + b(107,57) = rconst(107)*v(48) + b(108,44) = rconst(108)*v(57) + b(108,57) = rconst(108)*v(44) + b(109,37) = rconst(109)*v(57) + b(109,57) = rconst(109)*v(37) + b(110,49) = rconst(110)*v(56) + b(110,56) = rconst(110)*v(49) + b(111,48) = rconst(111)*v(56) + b(111,56) = rconst(111)*v(48) + b(112,44) = rconst(112)*v(56) + b(112,56) = rconst(112)*v(44) + b(113,37) = rconst(113)*v(56) + b(113,56) = rconst(113)*v(37) + b(114,49) = rconst(114) + b(115,48) = rconst(115) + b(116,44) = rconst(116) + b(117,37) = rconst(117) + b(118,16) = rconst(118)*v(27) + b(118,27) = rconst(118)*v(16) + b(119,34) = rconst(119)*v(59) + b(119,59) = rconst(119)*v(34) + b(120,34) = rconst(120)*v(57) + b(120,57) = rconst(120)*v(34) + b(121,34) = rconst(121)*v(43) + b(121,43) = rconst(121)*v(34) + b(122,34) = rconst(122)*v(59) + b(122,59) = rconst(122)*v(34) + b(123,38) = rconst(123)*v(55) + b(123,55) = rconst(123)*v(38) + b(124,38) = rconst(124)*v(58) + b(124,58) = rconst(124)*v(38) + b(125,38) = rconst(125)*v(54) + b(125,54) = rconst(125)*v(38) + b(126,38) = rconst(126)*2*v(38) + b(127,20) = rconst(127)*v(59) + b(127,59) = rconst(127)*v(20) + b(128,11) = rconst(128)*v(59) + b(128,59) = rconst(128)*v(11) + b(129,30) = rconst(129)*v(55) + b(129,55) = rconst(129)*v(30) + b(130,30) = rconst(130)*v(58) + b(130,58) = rconst(130)*v(30) + b(131,42) = rconst(131)*v(56) + b(131,56) = rconst(131)*v(42) + b(132,42) = rconst(132)*v(57) + b(132,57) = rconst(132)*v(42) + b(133,42) = rconst(133)*v(58) + b(133,58) = rconst(133)*v(42) + b(134,42) = rconst(134)*v(59) + b(134,59) = rconst(134)*v(42) + b(135,42) = rconst(135)*v(52) + b(135,52) = rconst(135)*v(42) + b(136,54) = rconst(136) + b(137,53) = rconst(137)*v(54) + b(137,54) = rconst(137)*v(53) + b(138,51) = rconst(138)*v(54) + b(138,54) = rconst(138)*v(51) + b(139,54) = rconst(139)*v(56) + b(139,56) = rconst(139)*v(54) + b(140,54) = rconst(140)*v(58) + b(140,58) = rconst(140)*v(54) + b(141,54) = rconst(141)*v(59) + b(141,59) = rconst(141)*v(54) + b(142,54) = rconst(142)*f(4) + b(143,29) = rconst(143) + b(144,29) = rconst(144)*v(55) + b(144,55) = rconst(144)*v(29) + b(145,29) = rconst(145)*v(58) + b(145,58) = rconst(145)*v(29) + b(146,52) = rconst(146) + b(147,52) = rconst(147)*v(53) + b(147,53) = rconst(147)*v(52) + b(148,52) = rconst(148)*v(55) + b(148,55) = rconst(148)*v(52) + b(149,52) = rconst(149)*v(56) + b(149,56) = rconst(149)*v(52) + b(150,47) = rconst(150)*v(52) + b(150,52) = rconst(150)*v(47) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,8) + jvs(3) = b(146,52) + jvs(4) = b(45,59) + jvs(5) = 0 + jvs(6) = 0.52*b(81,22) + jvs(7) = 0.22*b(83,36) + jvs(8) = 0.52*b(81,51)+0.22*b(83,51) + jvs(9) = 0 + jvs(10) = 0.09*b(83,36) + jvs(11) = 0.16*b(84,39) + jvs(12) = 0.4*b(73,46) + jvs(13) = 0.09*b(83,51)+0.16*b(84,51) + jvs(14) = 0.4*b(73,56) + jvs(15) = 0 + jvs(16) = b(135,42) + jvs(17) = b(150,47) + jvs(18) = b(135,52)+b(147,52)+b(148,52)+b(149,52)+b(150,52) + jvs(19) = b(147,53) + jvs(20) = b(141,54) + jvs(21) = b(148,55) + jvs(22) = b(149,56) + jvs(23) = b(141,59) + jvs(24) = 0 + jvs(25) = 0.15*b(126,38) + jvs(26) = -b(10,6)-b(11,6)-b(12,6) + jvs(27) = b(8,51) + jvs(28) = -b(65,7) + jvs(29) = -b(65,59) + jvs(30) = -b(45,8) + jvs(31) = b(136,54) + jvs(32) = -b(45,59) + jvs(33) = -b(47,9) + jvs(34) = 0.2*b(64,41) + jvs(35) = -b(47,59) + jvs(36) = -b(70,10) + jvs(37) = b(69,46) + jvs(38) = b(69,53) + jvs(39) = -b(128,11) + jvs(40) = 0.27*b(127,20) + jvs(41) = 0.27*b(127,59)-b(128,59) + jvs(42) = -b(89,12) + jvs(43) = -b(89,59) + jvs(44) = -b(9,13)-b(30,13) + jvs(45) = b(131,42) + jvs(46) = b(31,56)+b(32,56)+b(131,56) + jvs(47) = -b(30,59) + jvs(48) = -b(6,14)-b(42,14)-b(43,14) + jvs(49) = b(39,53) + jvs(50) = b(39,57) + jvs(51) = -b(90,15) + jvs(52) = -b(90,59) + jvs(53) = 1.1*b(90,15) + jvs(54) = -b(75,16)-b(118,16) + jvs(55) = -b(118,27) + jvs(56) = -b(75,59)+1.1*b(90,59) + jvs(57) = -b(94,17) + jvs(58) = 0.4*b(92,26)+b(93,26) + jvs(59) = -b(94,53) + jvs(60) = b(93,57) + jvs(61) = 0.4*b(92,59) + jvs(62) = -b(5,18)-b(28,18)-b(36,18) + jvs(63) = b(34,53) + jvs(64) = b(34,56) + jvs(65) = -b(28,59) + jvs(66) = 0.8*b(89,12) + jvs(67) = 0.45*b(90,15) + jvs(68) = -b(91,19) + jvs(69) = -b(91,55) + jvs(70) = 0.8*b(89,59)+0.45*b(90,59) + jvs(71) = -b(127,20) + jvs(72) = 0.965*b(122,34) + jvs(73) = 0.965*b(122,59)-b(127,59) + jvs(74) = -b(54,21)-b(56,21) + jvs(75) = b(62,41) + jvs(76) = b(62,56) + jvs(77) = -b(56,59) + jvs(78) = -b(81,22)-b(82,22) + jvs(79) = -b(81,51) + jvs(80) = -b(82,59) + jvs(81) = -b(48,23) + jvs(82) = 0.03*b(83,36) + jvs(83) = 0.04*b(84,39) + jvs(84) = 0.03*b(83,51)+0.04*b(84,51) + jvs(85) = 0.34*b(63,58) + jvs(86) = -b(48,59) + jvs(87) = -b(3,24)-b(26,24) + jvs(88) = b(148,52) + jvs(89) = b(35,53) + jvs(90) = b(23,55)+b(148,55) + jvs(91) = b(35,56) + jvs(92) = b(23,59)-b(26,59) + jvs(93) = -b(53,25)-b(55,25) + jvs(94) = b(133,42) + jvs(95) = b(61,56) + jvs(96) = b(61,58)+b(133,58) + jvs(97) = -b(55,59) + jvs(98) = 0.12*b(89,12) + jvs(99) = 0.05*b(90,15) + jvs(100) = -b(92,26)-b(93,26) + jvs(101) = -b(93,57) + jvs(102) = 0.12*b(89,59)+0.05*b(90,59)-b(92,59) + jvs(103) = -b(118,16) + jvs(104) = -b(118,27) + jvs(105) = 1.98*b(98,33)+0.42*b(99,33) + jvs(106) = 1.06*b(83,36)+b(85,36) + jvs(107) = 2.26*b(84,39)+2.23*b(86,39) + jvs(108) = b(104,44)+b(108,44)+b(116,44) + jvs(109) = 1.68*b(102,49)+1.98*b(106,49)+1.25*b(114,49) + jvs(110) = 1.98*b(101,50) + jvs(111) = 1.06*b(83,51)+2.26*b(84,51) + jvs(112) = 1.68*b(102,55)+b(104,55) + jvs(113) = 1.98*b(106,57)+b(108,57) + jvs(114) = b(85,59)+2.23*b(86,59)+0.42*b(99,59) + jvs(115) = 0.24*b(81,22) + jvs(116) = -b(44,28) + jvs(117) = 2*b(95,32)+b(96,32)+0.69*b(97,32) + jvs(118) = 0.31*b(83,36) + jvs(119) = 0.3*b(84,39) + jvs(120) = b(78,40)+b(80,40) + jvs(121) = b(66,45) + jvs(122) = b(49,47)+b(50,47)+b(51,47)+b(52,47)+b(150,47) + jvs(123) = 0.24*b(81,51)+0.31*b(83,51)+0.3*b(84,51)+0.69 & + *b(97,51) + jvs(124) = b(150,52) + jvs(125) = b(52,57)+b(80,57) + jvs(126) = -b(44,59)+b(51,59)+2*b(95,59) + jvs(127) = -b(143,29)-b(144,29)-b(145,29) + jvs(128) = b(142,54) + jvs(129) = -b(144,55) + jvs(130) = -b(145,58) + jvs(131) = b(128,11) + jvs(132) = 0 + jvs(133) = -b(129,30)-b(130,30) + jvs(134) = 0 + jvs(135) = -b(129,55) + jvs(136) = -b(130,58) + jvs(137) = b(128,59) + jvs(138) = 2*b(42,14) + jvs(139) = b(93,26) + jvs(140) = -b(4,31)-b(27,31) + jvs(141) = b(120,34) + jvs(142) = b(80,40) + jvs(143) = b(132,42) + jvs(144) = b(68,45) + jvs(145) = b(52,47) + jvs(146) = b(147,52) + jvs(147) = b(24,53)+b(147,53) + jvs(148) = 0.3*b(41,56) + jvs(149) = 0.3*b(41,57)+b(52,57)+b(68,57)+b(80,57)+b(93,57) & + +b(120,57)+b(132,57) + jvs(150) = b(24,59)-b(27,59) + jvs(151) = 0.95*b(91,19) + jvs(152) = 0.3*b(92,26) + jvs(153) = -b(95,32)-b(96,32)-b(97,32) + jvs(154) = -b(97,51) + jvs(155) = 0.95*b(91,55) + jvs(156) = 0 + jvs(157) = 0.3*b(92,59)-b(95,59) + jvs(158) = -b(98,33)-b(99,33) + jvs(159) = b(111,48) + jvs(160) = b(110,49) + jvs(161) = b(110,56)+b(111,56) + jvs(162) = -b(99,59) + jvs(163) = -b(119,34)-b(120,34)-b(121,34)-b(122,34) + jvs(164) = -b(121,43) + jvs(165) = -b(120,57) + jvs(166) = -b(119,59)-b(122,59) + jvs(167) = 0.74*b(98,33) + jvs(168) = -b(76,35)-b(77,35) + jvs(169) = 0.07*b(84,39)+0.23*b(86,39) + jvs(170) = 0.15*b(115,48) + jvs(171) = 0.62*b(102,49)+0.74*b(106,49)+0.57*b(114,49) + jvs(172) = 0.74*b(101,50) + jvs(173) = 0.07*b(84,51) + jvs(174) = 0.62*b(102,55) + jvs(175) = 0 + jvs(176) = 0.74*b(106,57) + jvs(177) = -b(77,59)+0.23*b(86,59) + jvs(178) = -b(83,36)-b(85,36)-b(87,36) + jvs(179) = -b(83,51) + jvs(180) = -b(87,57) + jvs(181) = -b(85,59) + jvs(182) = 0.08*b(89,12) + jvs(183) = 0.5*b(90,15) + jvs(184) = b(82,22) + jvs(185) = 0.6*b(92,26) + jvs(186) = b(95,32)+0.03*b(97,32) + jvs(187) = 0.4*b(98,33) + jvs(188) = b(85,36) + jvs(189) = -b(105,37)-b(109,37)-b(113,37)-b(117,37) + jvs(190) = b(86,39) + jvs(191) = b(79,40) + jvs(192) = 0 + jvs(193) = 0.34*b(102,49)+0.4*b(106,49)+0.24*b(114,49) + jvs(194) = 0.4*b(101,50) + jvs(195) = 0.03*b(97,51) + jvs(196) = 0.34*b(102,55)-b(105,55) + jvs(197) = -b(113,56) + jvs(198) = 0.4*b(106,57)-b(109,57) + jvs(199) = b(79,59)+b(82,59)+b(85,59)+b(86,59)+0.08*b(89,59)+0.5 & + *b(90,59)+0.6*b(92,59)+b(95,59) + jvs(200) = b(119,34)+b(120,34) + jvs(201) = -b(123,38)-b(124,38)-b(125,38)-2*b(126,38) + jvs(202) = 0 + jvs(203) = -b(125,54) + jvs(204) = -b(123,55) + jvs(205) = b(120,57) + jvs(206) = -b(124,58) + jvs(207) = b(119,59) + jvs(208) = -b(84,39)-b(86,39)-b(88,39) + jvs(209) = -b(84,51) + jvs(210) = -b(88,57) + jvs(211) = -b(86,59) + jvs(212) = 0.8*b(90,15) + jvs(213) = 0.2*b(97,32) + jvs(214) = 0.19*b(99,33) + jvs(215) = 0.04*b(83,36) + jvs(216) = 0.07*b(84,39) + jvs(217) = -b(78,40)-b(79,40)-b(80,40) + jvs(218) = 0.15*b(115,48) + jvs(219) = 0 + jvs(220) = 0.04*b(83,51)+0.07*b(84,51)+0.2*b(97,51) + jvs(221) = 0 + jvs(222) = 0 + jvs(223) = -b(80,57) + jvs(224) = -b(79,59)+0.8*b(90,59)+0.19*b(99,59) + jvs(225) = b(47,9) + jvs(226) = 0.5*b(56,21) + jvs(227) = 0.1*b(98,33) + jvs(228) = 0.06*b(83,36) + jvs(229) = 0.05*b(84,39) + jvs(230) = -b(58,41)-b(60,41)-b(62,41)-b(64,41) + jvs(231) = 0 + jvs(232) = 0.08*b(102,49)+0.1*b(106,49)+0.06*b(114,49) + jvs(233) = 0.1*b(101,50) + jvs(234) = 0.06*b(83,51)+0.05*b(84,51) + jvs(235) = -b(58,55)+0.08*b(102,55) + jvs(236) = -b(62,56) + jvs(237) = -b(60,57)+0.1*b(106,57) + jvs(238) = b(47,59)+0.5*b(56,59) + jvs(239) = 0.73*b(127,20) + jvs(240) = 0 + jvs(241) = -b(131,42)-b(132,42)-b(133,42)-b(134,42)-b(135,42) + jvs(242) = 0 + jvs(243) = -b(135,52) + jvs(244) = -b(131,56) + jvs(245) = -b(132,57) + jvs(246) = -b(133,58) + jvs(247) = 0.73*b(127,59)-b(134,59) + jvs(248) = b(10,6)+b(11,6) + jvs(249) = -b(121,34) + jvs(250) = -b(13,43)-b(14,43)-b(15,43)-b(16,43)-b(17,43) & + -b(121,43) + jvs(251) = b(7,51)-b(14,51) + jvs(252) = b(1,53)-b(15,53)-b(16,53) + jvs(253) = -b(17,55) + jvs(254) = 0.89*b(2,57) + jvs(255) = 0 + jvs(256) = b(87,36) + jvs(257) = b(88,39) + jvs(258) = -b(104,44)-b(108,44)-b(112,44)-b(116,44) + jvs(259) = b(100,50) + jvs(260) = 0 + jvs(261) = -b(104,55) + jvs(262) = -b(112,56) + jvs(263) = b(87,57)+b(88,57)-b(108,57) + jvs(264) = b(100,59) + jvs(265) = b(65,7) + jvs(266) = b(54,21)+0.5*b(56,21) + jvs(267) = 0.22*b(82,22) + jvs(268) = 0.03*b(97,32) + jvs(269) = 0.3*b(98,33)+0.04*b(99,33) + jvs(270) = 0.47*b(83,36)+b(85,36) + jvs(271) = 1.03*b(84,39)+1.77*b(86,39) + jvs(272) = b(58,41)+b(60,41)+0.8*b(64,41) + jvs(273) = 0.5*b(104,44)+0.5*b(108,44)+0.5*b(116,44) + jvs(274) = -b(66,45)-b(67,45)-b(68,45) + jvs(275) = 0 + jvs(276) = 0.25*b(102,49)+0.3*b(106,49)+0.21*b(114,49) + jvs(277) = 0.3*b(101,50) + jvs(278) = 0.47*b(83,51)+1.03*b(84,51)+0.03*b(97,51) + jvs(279) = b(58,55)+0.25*b(102,55)+0.5*b(104,55) + jvs(280) = 0 + jvs(281) = b(60,57)-b(68,57)+0.3*b(106,57)+0.5*b(108,57) + jvs(282) = 0.5*b(56,59)+b(65,59)-b(67,59)+0.22*b(82,59)+b(85,59) & + +1.77*b(86,59)+0.04*b(99,59) + jvs(283) = b(70,10) + jvs(284) = b(95,32)+b(96,32)+0.62*b(97,32) + jvs(285) = b(76,35) + jvs(286) = 0.13*b(83,36) + jvs(287) = 0.19*b(84,39) + jvs(288) = b(78,40)+b(79,40)+b(80,40) + jvs(289) = b(67,45)+b(68,45) + jvs(290) = -b(69,46)-b(71,46)-b(72,46)-b(73,46)-b(74,46) + jvs(291) = b(103,48)+b(107,48)+0.7*b(115,48) + jvs(292) = 0 + jvs(293) = 0 + jvs(294) = 0.13*b(83,51)+0.19*b(84,51)+0.62*b(97,51) + jvs(295) = -b(69,53) + jvs(296) = -b(71,55)+b(103,55) + jvs(297) = -b(73,56) + jvs(298) = b(68,57)-b(72,57)+b(80,57)+b(107,57) + jvs(299) = b(67,59)+b(79,59)+b(95,59) + jvs(300) = b(81,22)+1.56*b(82,22) + jvs(301) = b(48,23) + jvs(302) = b(53,25)+0.3*b(55,25) + jvs(303) = b(145,29) + jvs(304) = b(129,30)+2*b(130,30) + jvs(305) = b(95,32)+0.7*b(97,32) + jvs(306) = 0 + jvs(307) = 0.57*b(83,36)+b(85,36) + jvs(308) = b(123,38)+2*b(124,38)+b(125,38) + jvs(309) = 0 + jvs(310) = 0 + jvs(311) = 0 + jvs(312) = 0.5*b(104,44)+0.5*b(108,44)+0.5*b(116,44) + jvs(313) = -b(49,47)-b(50,47)-b(51,47)-b(52,47)-b(150,47) + jvs(314) = b(103,48)+b(107,48)+0.7*b(115,48) + jvs(315) = 0 + jvs(316) = b(81,51)+0.57*b(83,51)+0.7*b(97,51) + jvs(317) = -b(150,52) + jvs(318) = 0 + jvs(319) = b(125,54)+b(140,54) + jvs(320) = b(57,55)+b(103,55)+0.5*b(104,55)+b(123,55)+b(129,55) + jvs(321) = 0 + jvs(322) = -b(52,57)+b(59,57)+b(107,57)+0.5*b(108,57) + jvs(323) = b(57,58)+b(59,58)+0.66*b(63,58)+2*b(124,58)+2 & + *b(130,58)+b(140,58)+b(145,58) + jvs(324) = b(48,59)-b(51,59)+0.3*b(55,59)+1.56*b(82,59)+b(85,59) & + +b(95,59) + jvs(325) = b(77,35) + jvs(326) = 0.11*b(84,39) + jvs(327) = -b(103,48)-b(107,48)-b(111,48)-b(115,48) + jvs(328) = 0 + jvs(329) = 0 + jvs(330) = 0.11*b(84,51) + jvs(331) = -b(103,55) + jvs(332) = -b(111,56) + jvs(333) = -b(107,57) + jvs(334) = b(77,59) + jvs(335) = b(75,16) + jvs(336) = 0 + jvs(337) = 0.77*b(99,33) + jvs(338) = 0.03*b(83,36) + jvs(339) = 0.09*b(84,39) + jvs(340) = 0 + jvs(341) = 0 + jvs(342) = -b(102,49)-b(106,49)-b(110,49)-b(114,49) + jvs(343) = 0 + jvs(344) = 0.03*b(83,51)+0.09*b(84,51) + jvs(345) = -b(102,55) + jvs(346) = -b(110,56) + jvs(347) = -b(106,57) + jvs(348) = b(75,59)+0.77*b(99,59) + jvs(349) = b(94,17) + jvs(350) = 0.05*b(91,19) + jvs(351) = 0 + jvs(352) = 0.5*b(104,44)+0.5*b(108,44)+b(112,44)+0.5*b(116,44) + jvs(353) = 0.16*b(102,49) + jvs(354) = -b(100,50)-b(101,50) + jvs(355) = 0 + jvs(356) = b(94,53) + jvs(357) = 0.05*b(91,55)+0.16*b(102,55)+0.5*b(104,55) + jvs(358) = b(112,56) + jvs(359) = 0.5*b(108,57) + jvs(360) = -b(100,59) + jvs(361) = -b(81,22) + jvs(362) = -b(97,32) + jvs(363) = -b(83,36) + jvs(364) = -b(84,39) + jvs(365) = b(13,43)-b(14,43) + jvs(366) = 0.4*b(73,46) + jvs(367) = 0 + jvs(368) = 0 + jvs(369) = 0 + jvs(370) = -b(7,51)-b(8,51)-b(14,51)-b(18,51)-b(19,51)-b(20,51) & + -b(21,51)-b(81,51)-b(83,51)-b(84,51)-b(97,51) & + -b(138,51) + jvs(371) = -b(19,53) + jvs(372) = -b(138,54) + jvs(373) = -b(18,55) + jvs(374) = -b(21,56)+0.4*b(73,56) + jvs(375) = 0 + jvs(376) = -b(20,59) + jvs(377) = b(144,29)+b(145,29) + jvs(378) = b(125,38) + jvs(379) = -b(135,42) + jvs(380) = 0 + jvs(381) = -b(150,47) + jvs(382) = 0 + jvs(383) = 0 + jvs(384) = 0 + jvs(385) = b(138,51) + jvs(386) = -b(135,52)-b(146,52)-b(147,52)-b(148,52)-b(149,52) & + -b(150,52) + jvs(387) = b(137,53)-b(147,53) + jvs(388) = b(125,54)+b(137,54)+b(138,54)+b(139,54)+b(140,54) + jvs(389) = b(144,55)-b(148,55) + jvs(390) = b(139,56)-b(149,56) + jvs(391) = 0 + jvs(392) = b(140,58)+b(145,58) + jvs(393) = 0 + jvs(394) = b(70,10) + jvs(395) = b(6,14)+b(43,14) + jvs(396) = -b(94,17) + jvs(397) = b(5,18)+b(28,18)+b(36,18) + jvs(398) = 0.95*b(91,19) + jvs(399) = b(26,24) + jvs(400) = 0 + jvs(401) = b(144,29) + jvs(402) = b(129,30) + jvs(403) = b(4,31) + jvs(404) = 0 + jvs(405) = b(105,37)+b(109,37) + jvs(406) = b(123,38) + jvs(407) = 0 + jvs(408) = 0 + jvs(409) = b(58,41)+b(60,41) + jvs(410) = 0 + jvs(411) = -b(15,43)-b(16,43)+b(17,43) + jvs(412) = 1.5*b(104,44)+1.5*b(108,44)+0.5*b(116,44) + jvs(413) = 0 + jvs(414) = -b(69,46)+b(71,46)+b(72,46) + jvs(415) = 0 + jvs(416) = b(103,48)+b(107,48) + jvs(417) = 0.84*b(102,49)+b(106,49) + jvs(418) = b(101,50) + jvs(419) = b(18,51)-b(19,51) + jvs(420) = -b(147,52) + jvs(421) = -b(1,53)-b(15,53)-b(16,53)-b(19,53)-b(24,53)-b(34,53) & + -b(35,53)-b(39,53)-b(69,53)-b(94,53)-b(137,53) & + -b(147,53) + jvs(422) = -b(137,54) + jvs(423) = b(17,55)+b(18,55)+b(33,55)+2*b(37,55)+b(57,55) & + +b(58,55)+b(71,55)+0.95*b(91,55)+0.84*b(102,55) & + +b(103,55)+1.5*b(104,55)+b(105,55)+b(123,55)+b(129,55) & + +b(144,55) + jvs(424) = b(33,56)-b(34,56)-b(35,56)+0.7*b(41,56) + jvs(425) = b(57,58)+b(59,58) + jvs(426) = -b(24,59)+b(25,59)+b(26,59)+b(28,59) + jvs(427) = b(143,29) + jvs(428) = b(129,30)+b(130,30) + jvs(429) = b(121,34)+0.035*b(122,34) + jvs(430) = b(123,38)+b(124,38)+1.85*b(126,38) + jvs(431) = b(131,42)+b(132,42)+b(133,42)+b(134,42)+b(135,42) + jvs(432) = b(121,43) + jvs(433) = -b(138,51) + jvs(434) = b(135,52) + jvs(435) = -b(137,53) + jvs(436) = -b(136,54)-b(137,54)-b(138,54)-b(139,54)-b(140,54) & + -b(141,54)-b(142,54) + jvs(437) = b(123,55)+b(129,55) + jvs(438) = b(131,56)-b(139,56) + jvs(439) = b(132,57) + jvs(440) = b(124,58)+b(130,58)+b(133,58)-b(140,58) + jvs(441) = 0.035*b(122,59)+b(134,59)-b(141,59) + jvs(442) = -b(91,19) + jvs(443) = b(3,24) + jvs(444) = -b(144,29) + jvs(445) = -b(129,30) + jvs(446) = 0 + jvs(447) = -b(105,37) + jvs(448) = -b(123,38) + jvs(449) = 0 + jvs(450) = 0 + jvs(451) = -b(58,41) + jvs(452) = b(15,43)-b(17,43) + jvs(453) = -b(104,44) + jvs(454) = -b(71,46) + jvs(455) = -b(103,48) + jvs(456) = -b(102,49) + jvs(457) = 0 + jvs(458) = -b(18,51) + jvs(459) = -b(148,52) + jvs(460) = b(1,53)+b(15,53)+b(38,53)+b(137,53) + jvs(461) = b(137,54) + jvs(462) = -b(17,55)-b(18,55)-b(23,55)-b(33,55)-b(37,55) & + -b(57,55)-b(58,55)-b(71,55)-b(91,55)-b(102,55) & + -b(103,55)-b(104,55)-b(105,55)-b(123,55)-b(129,55) & + -b(144,55)-b(148,55) + jvs(463) = -b(33,56) + jvs(464) = 0.11*b(2,57)-b(37,57)+b(38,57) + jvs(465) = -b(57,58) + jvs(466) = -b(23,59) + jvs(467) = b(65,7) + jvs(468) = b(45,8) + jvs(469) = 0.2*b(89,12) + jvs(470) = b(30,13) + jvs(471) = 0.55*b(90,15) + jvs(472) = b(5,18)+b(36,18) + jvs(473) = 0.95*b(91,19) + jvs(474) = 0.27*b(127,20) + jvs(475) = b(54,21) + jvs(476) = 0.22*b(81,22)+b(82,22) + jvs(477) = b(48,23) + jvs(478) = b(53,25) + jvs(479) = 0.6*b(92,26) + jvs(480) = b(44,28) + jvs(481) = b(145,29) + jvs(482) = b(130,30) + jvs(483) = 2*b(95,32)+b(96,32)+0.76*b(97,32) + jvs(484) = 0.9*b(98,33) + jvs(485) = 0.965*b(122,34) + jvs(486) = 0.26*b(83,36)+b(85,36) + jvs(487) = -b(113,37) + jvs(488) = b(124,38) + jvs(489) = 0.22*b(84,39)+b(86,39) + jvs(490) = b(78,40) + jvs(491) = b(58,41)+b(60,41)-b(62,41)+0.6*b(64,41) + jvs(492) = -b(131,42) + jvs(493) = 0 + jvs(494) = 0.5*b(104,44)+0.5*b(108,44)-b(112,44) + jvs(495) = b(66,45) + jvs(496) = -b(73,46) + jvs(497) = 2*b(49,47)+b(51,47)+b(52,47)+b(150,47) + jvs(498) = -b(111,48) + jvs(499) = 0.76*b(102,49)+0.9*b(106,49)-b(110,49)+0.54*b(114,49) + jvs(500) = 0.9*b(101,50) + jvs(501) = b(20,51)-b(21,51)+0.22*b(81,51)+0.26*b(83,51)+0.22 & + *b(84,51)+0.76*b(97,51) + jvs(502) = -b(149,52)+b(150,52) + jvs(503) = -b(34,53)-b(35,53) + jvs(504) = -b(139,54)+b(140,54) + jvs(505) = -b(33,55)+b(57,55)+b(58,55)+0.95*b(91,55)+0.76 & + *b(102,55)+0.5*b(104,55) + jvs(506) = -b(21,56)-b(29,56)-2*b(31,56)-2*b(32,56)-b(33,56) & + -b(34,56)-b(35,56)-b(41,56)-b(61,56)-b(62,56)-b(73,56) & + -b(110,56)-b(111,56)-b(112,56)-b(113,56)-b(131,56) & + -b(139,56)-b(149,56) + jvs(507) = b(25,57)-b(41,57)+b(52,57)+b(59,57)+b(60,57)+0.9 & + *b(106,57)+0.5*b(108,57) + jvs(508) = b(57,58)+b(59,58)-b(61,58)+0.32*b(63,58)+b(124,58) & + +b(130,58)+b(140,58)+b(145,58) + jvs(509) = b(20,59)+b(22,59)+b(25,59)-b(29,59)+b(30,59)+b(44,59) & + +b(45,59)+b(48,59)+b(51,59)+b(65,59)+b(82,59)+b(85,59) & + +b(86,59)+0.2*b(89,59)+0.55*b(90,59)+0.6*b(92,59)+2 & + *b(95,59)+0.965*b(122,59)+0.27*b(127,59) + jvs(510) = b(6,14)+b(43,14) + jvs(511) = -b(93,26) + jvs(512) = b(27,31) + jvs(513) = -b(120,34) + jvs(514) = -b(87,36) + jvs(515) = -b(109,37) + jvs(516) = -b(88,39) + jvs(517) = -b(80,40) + jvs(518) = -b(60,41) + jvs(519) = -b(132,42) + jvs(520) = b(16,43) + jvs(521) = -b(108,44) + jvs(522) = -b(68,45) + jvs(523) = -b(72,46) + jvs(524) = -b(52,47) + jvs(525) = -b(107,48) + jvs(526) = -b(106,49) + jvs(527) = 0 + jvs(528) = b(19,51) + jvs(529) = 0 + jvs(530) = b(16,53)+b(19,53)-b(38,53)-b(39,53) + jvs(531) = 0 + jvs(532) = -b(37,55) + jvs(533) = -b(41,56) + jvs(534) = -b(2,57)-b(25,57)-b(37,57)-b(38,57)-b(39,57)-2 & + *b(40,57)-b(41,57)-b(52,57)-b(59,57)-b(60,57)-b(68,57) & + -b(72,57)-b(80,57)-b(87,57)-b(88,57)-b(93,57) & + -b(106,57)-b(107,57)-b(108,57)-b(109,57)-b(120,57) & + -b(132,57) + jvs(535) = -b(59,58) + jvs(536) = -b(25,59)+b(27,59) + jvs(537) = 0.73*b(127,20) + jvs(538) = 0.7*b(55,25) + jvs(539) = -b(145,29) + jvs(540) = -b(130,30) + jvs(541) = b(121,34)+0.035*b(122,34) + jvs(542) = b(76,35) + jvs(543) = 0.07*b(83,36) + jvs(544) = -b(124,38) + jvs(545) = 0.1*b(84,39) + jvs(546) = -b(133,42) + jvs(547) = b(121,43) + jvs(548) = b(66,45) + jvs(549) = b(71,46)+b(72,46)+b(74,46) + jvs(550) = 0 + jvs(551) = 0 + jvs(552) = 0 + jvs(553) = 0.07*b(83,51)+0.1*b(84,51) + jvs(554) = b(146,52) + jvs(555) = 0 + jvs(556) = b(136,54)-b(140,54) + jvs(557) = -b(57,55)+b(71,55) + jvs(558) = -b(61,56) + jvs(559) = -b(59,57)+b(72,57) + jvs(560) = -b(57,58)-b(59,58)-b(61,58)-b(63,58)-b(124,58) & + -b(130,58)-b(133,58)-b(140,58)-b(145,58) + jvs(561) = b(46,59)+0.7*b(55,59)+0.035*b(122,59)+0.73*b(127,59) + jvs(562) = 2*b(12,6) + jvs(563) = -b(65,7) + jvs(564) = -b(45,8) + jvs(565) = -b(47,9) + jvs(566) = -b(128,11) + jvs(567) = -b(89,12) + jvs(568) = 2*b(9,13)-b(30,13) + jvs(569) = -b(90,15) + jvs(570) = -b(75,16) + jvs(571) = -b(28,18) + jvs(572) = -b(127,20) + jvs(573) = b(54,21)-0.5*b(56,21) + jvs(574) = 0.12*b(81,22)-b(82,22) + jvs(575) = -b(48,23) + jvs(576) = b(3,24)-b(26,24) + jvs(577) = b(53,25)-0.7*b(55,25) + jvs(578) = -b(92,26) + jvs(579) = 0 + jvs(580) = -b(44,28) + jvs(581) = b(4,31)-b(27,31) + jvs(582) = -b(95,32)+0.08*b(97,32) + jvs(583) = b(98,33)-0.77*b(99,33) + jvs(584) = -b(119,34)-b(122,34) + jvs(585) = -b(77,35) + jvs(586) = 0.33*b(83,36)-b(85,36) + jvs(587) = 0.6*b(84,39)-b(86,39) + jvs(588) = -b(79,40) + jvs(589) = 0 + jvs(590) = -b(134,42) + jvs(591) = 0 + jvs(592) = 0 + jvs(593) = -b(67,45) + jvs(594) = -b(51,47) + jvs(595) = 0 + jvs(596) = 0 + jvs(597) = -b(100,50) + jvs(598) = -b(20,51)+b(21,51)+0.12*b(81,51)+0.33*b(83,51)+0.6 & + *b(84,51)+0.08*b(97,51) + jvs(599) = 0 + jvs(600) = -b(24,53) + jvs(601) = b(139,54)-b(141,54) + jvs(602) = -b(23,55)+b(33,55) + jvs(603) = b(21,56)-b(29,56)+b(33,56)+0.7*b(41,56)+b(139,56) + jvs(604) = -b(25,57)+0.7*b(41,57) + jvs(605) = 0 + jvs(606) = -b(20,59)-b(22,59)-b(23,59)-b(24,59)-b(25,59) & + -b(26,59)-b(27,59)-b(28,59)-b(29,59)-b(30,59)-b(44,59) & + -b(45,59)-b(46,59)-b(47,59)-b(48,59)-b(51,59)-0.7 & + *b(55,59)-0.5*b(56,59)-b(65,59)-b(67,59)-b(75,59) & + -b(77,59)-b(79,59)-b(82,59)-b(85,59)-b(86,59)-b(89,59) & + -b(90,59)-b(92,59)-b(95,59)-0.77*b(99,59)-b(100,59) & + -b(119,59)-b(122,59)-b(127,59)-b(128,59)-b(134,59) & + -b(141,59) + return + end subroutine cbmz_v02r05_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r05 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = elements of the sparse jacobian [input] + real v(lu_nonzero_v_r05_kpp) + + integer lu_crow_v(nvar_r05_kpp + 1) + integer lu_diag_v(nvar_r05_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r05_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r05_kpp + 1) + + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r05_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r05_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r05 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(16) = x(16)-jvs(53)*x(15) + x(19) = x(19)-jvs(66)*x(12)-jvs(67)*x(15) + x(26) = x(26)-jvs(98)*x(12)-jvs(99)*x(15) + x(27) = x(27)-jvs(103)*x(16) + x(28) = x(28)-jvs(115)*x(22) + x(30) = x(30)-jvs(131)*x(11)-jvs(132)*x(20) + x(31) = x(31)-jvs(138)*x(14)-jvs(139)*x(26) + x(32) = x(32)-jvs(151)*x(19)-jvs(152)*x(26) + x(35) = x(35)-jvs(167)*x(33) + x(37) = x(37)-jvs(182)*x(12)-jvs(183)*x(15)-jvs(184)*x(22) & + -jvs(185)*x(26)-jvs(186)*x(32)-jvs(187)*x(33)-jvs(188) & + *x(36) + x(38) = x(38)-jvs(200)*x(34) + x(40) = x(40)-jvs(212)*x(15)-jvs(213)*x(32)-jvs(214)*x(33) & + -jvs(215)*x(36)-jvs(216)*x(39) + x(41) = x(41)-jvs(225)*x(9)-jvs(226)*x(21)-jvs(227)*x(33) & + -jvs(228)*x(36)-jvs(229)*x(39) + x(42) = x(42)-jvs(239)*x(20)-jvs(240)*x(34) + x(43) = x(43)-jvs(248)*x(6)-jvs(249)*x(34) + x(44) = x(44)-jvs(256)*x(36)-jvs(257)*x(39) + x(45) = x(45)-jvs(265)*x(7)-jvs(266)*x(21)-jvs(267)*x(22) & + -jvs(268)*x(32)-jvs(269)*x(33)-jvs(270)*x(36)-jvs(271) & + *x(39)-jvs(272)*x(41)-jvs(273)*x(44) + x(46) = x(46)-jvs(283)*x(10)-jvs(284)*x(32)-jvs(285)*x(35) & + -jvs(286)*x(36)-jvs(287)*x(39)-jvs(288)*x(40)-jvs(289) & + *x(45) + x(47) = x(47)-jvs(300)*x(22)-jvs(301)*x(23)-jvs(302)*x(25) & + -jvs(303)*x(29)-jvs(304)*x(30)-jvs(305)*x(32)-jvs(306) & + *x(34)-jvs(307)*x(36)-jvs(308)*x(38)-jvs(309)*x(39) & + -jvs(310)*x(42)-jvs(311)*x(43)-jvs(312)*x(44) + x(48) = x(48)-jvs(325)*x(35)-jvs(326)*x(39) + x(49) = x(49)-jvs(335)*x(16)-jvs(336)*x(27)-jvs(337)*x(33) & + -jvs(338)*x(36)-jvs(339)*x(39)-jvs(340)*x(44)-jvs(341) & + *x(48) + x(50) = x(50)-jvs(349)*x(17)-jvs(350)*x(19)-jvs(351)*x(26) & + -jvs(352)*x(44)-jvs(353)*x(49) + x(51) = x(51)-jvs(361)*x(22)-jvs(362)*x(32)-jvs(363)*x(36) & + -jvs(364)*x(39)-jvs(365)*x(43)-jvs(366)*x(46)-jvs(367) & + *x(48)-jvs(368)*x(49)-jvs(369)*x(50) + x(52) = x(52)-jvs(377)*x(29)-jvs(378)*x(38)-jvs(379)*x(42) & + -jvs(380)*x(43)-jvs(381)*x(47)-jvs(382)*x(48)-jvs(383) & + *x(49)-jvs(384)*x(50)-jvs(385)*x(51) + x(53) = x(53)-jvs(394)*x(10)-jvs(395)*x(14)-jvs(396)*x(17) & + -jvs(397)*x(18)-jvs(398)*x(19)-jvs(399)*x(24)-jvs(400) & + *x(26)-jvs(401)*x(29)-jvs(402)*x(30)-jvs(403)*x(31) & + -jvs(404)*x(34)-jvs(405)*x(37)-jvs(406)*x(38)-jvs(407) & + *x(39)-jvs(408)*x(40)-jvs(409)*x(41)-jvs(410)*x(42) & + -jvs(411)*x(43)-jvs(412)*x(44)-jvs(413)*x(45)-jvs(414) & + *x(46)-jvs(415)*x(47)-jvs(416)*x(48)-jvs(417)*x(49) & + -jvs(418)*x(50)-jvs(419)*x(51)-jvs(420)*x(52) + x(54) = x(54)-jvs(427)*x(29)-jvs(428)*x(30)-jvs(429)*x(34) & + -jvs(430)*x(38)-jvs(431)*x(42)-jvs(432)*x(43)-jvs(433) & + *x(51)-jvs(434)*x(52)-jvs(435)*x(53) + x(55) = x(55)-jvs(442)*x(19)-jvs(443)*x(24)-jvs(444)*x(29) & + -jvs(445)*x(30)-jvs(446)*x(34)-jvs(447)*x(37)-jvs(448) & + *x(38)-jvs(449)*x(39)-jvs(450)*x(40)-jvs(451)*x(41) & + -jvs(452)*x(43)-jvs(453)*x(44)-jvs(454)*x(46)-jvs(455) & + *x(48)-jvs(456)*x(49)-jvs(457)*x(50)-jvs(458)*x(51) & + -jvs(459)*x(52)-jvs(460)*x(53)-jvs(461)*x(54) + x(56) = x(56)-jvs(467)*x(7)-jvs(468)*x(8)-jvs(469)*x(12) & + -jvs(470)*x(13)-jvs(471)*x(15)-jvs(472)*x(18)-jvs(473) & + *x(19)-jvs(474)*x(20)-jvs(475)*x(21)-jvs(476)*x(22) & + -jvs(477)*x(23)-jvs(478)*x(25)-jvs(479)*x(26)-jvs(480) & + *x(28)-jvs(481)*x(29)-jvs(482)*x(30)-jvs(483)*x(32) & + -jvs(484)*x(33)-jvs(485)*x(34)-jvs(486)*x(36)-jvs(487) & + *x(37)-jvs(488)*x(38)-jvs(489)*x(39)-jvs(490)*x(40) & + -jvs(491)*x(41)-jvs(492)*x(42)-jvs(493)*x(43)-jvs(494) & + *x(44)-jvs(495)*x(45)-jvs(496)*x(46)-jvs(497)*x(47) & + -jvs(498)*x(48)-jvs(499)*x(49)-jvs(500)*x(50)-jvs(501) & + *x(51)-jvs(502)*x(52)-jvs(503)*x(53)-jvs(504)*x(54) & + -jvs(505)*x(55) + x(57) = x(57)-jvs(510)*x(14)-jvs(511)*x(26)-jvs(512)*x(31) & + -jvs(513)*x(34)-jvs(514)*x(36)-jvs(515)*x(37)-jvs(516) & + *x(39)-jvs(517)*x(40)-jvs(518)*x(41)-jvs(519)*x(42) & + -jvs(520)*x(43)-jvs(521)*x(44)-jvs(522)*x(45)-jvs(523) & + *x(46)-jvs(524)*x(47)-jvs(525)*x(48)-jvs(526)*x(49) & + -jvs(527)*x(50)-jvs(528)*x(51)-jvs(529)*x(52)-jvs(530) & + *x(53)-jvs(531)*x(54)-jvs(532)*x(55)-jvs(533)*x(56) + x(58) = x(58)-jvs(537)*x(20)-jvs(538)*x(25)-jvs(539)*x(29) & + -jvs(540)*x(30)-jvs(541)*x(34)-jvs(542)*x(35)-jvs(543) & + *x(36)-jvs(544)*x(38)-jvs(545)*x(39)-jvs(546)*x(42) & + -jvs(547)*x(43)-jvs(548)*x(45)-jvs(549)*x(46)-jvs(550) & + *x(48)-jvs(551)*x(49)-jvs(552)*x(50)-jvs(553)*x(51) & + -jvs(554)*x(52)-jvs(555)*x(53)-jvs(556)*x(54)-jvs(557) & + *x(55)-jvs(558)*x(56)-jvs(559)*x(57) + x(59) = x(59)-jvs(562)*x(6)-jvs(563)*x(7)-jvs(564)*x(8)-jvs(565) & + *x(9)-jvs(566)*x(11)-jvs(567)*x(12)-jvs(568)*x(13) & + -jvs(569)*x(15)-jvs(570)*x(16)-jvs(571)*x(18)-jvs(572) & + *x(20)-jvs(573)*x(21)-jvs(574)*x(22)-jvs(575)*x(23) & + -jvs(576)*x(24)-jvs(577)*x(25)-jvs(578)*x(26)-jvs(579) & + *x(27)-jvs(580)*x(28)-jvs(581)*x(31)-jvs(582)*x(32) & + -jvs(583)*x(33)-jvs(584)*x(34)-jvs(585)*x(35)-jvs(586) & + *x(36)-jvs(587)*x(39)-jvs(588)*x(40)-jvs(589)*x(41) & + -jvs(590)*x(42)-jvs(591)*x(43)-jvs(592)*x(44)-jvs(593) & + *x(45)-jvs(594)*x(47)-jvs(595)*x(48)-jvs(596)*x(49) & + -jvs(597)*x(50)-jvs(598)*x(51)-jvs(599)*x(52)-jvs(600) & + *x(53)-jvs(601)*x(54)-jvs(602)*x(55)-jvs(603)*x(56) & + -jvs(604)*x(57)-jvs(605)*x(58) + x(59) = x(59)/jvs(606) + x(58) = (x(58)-jvs(561)*x(59))/(jvs(560)) + x(57) = (x(57)-jvs(535)*x(58)-jvs(536)*x(59))/(jvs(534)) + x(56) = (x(56)-jvs(507)*x(57)-jvs(508)*x(58)-jvs(509)*x(59))/ & + (jvs(506)) + x(55) = (x(55)-jvs(463)*x(56)-jvs(464)*x(57)-jvs(465)*x(58) & + -jvs(466)*x(59))/(jvs(462)) + x(54) = (x(54)-jvs(437)*x(55)-jvs(438)*x(56)-jvs(439)*x(57) & + -jvs(440)*x(58)-jvs(441)*x(59))/(jvs(436)) + x(53) = (x(53)-jvs(422)*x(54)-jvs(423)*x(55)-jvs(424)*x(56) & + -jvs(425)*x(58)-jvs(426)*x(59))/(jvs(421)) + x(52) = (x(52)-jvs(387)*x(53)-jvs(388)*x(54)-jvs(389)*x(55) & + -jvs(390)*x(56)-jvs(391)*x(57)-jvs(392)*x(58)-jvs(393) & + *x(59))/(jvs(386)) + x(51) = (x(51)-jvs(371)*x(53)-jvs(372)*x(54)-jvs(373)*x(55) & + -jvs(374)*x(56)-jvs(375)*x(57)-jvs(376)*x(59))/(jvs(370)) + x(50) = (x(50)-jvs(355)*x(51)-jvs(356)*x(53)-jvs(357)*x(55) & + -jvs(358)*x(56)-jvs(359)*x(57)-jvs(360)*x(59))/(jvs(354)) + x(49) = (x(49)-jvs(343)*x(50)-jvs(344)*x(51)-jvs(345)*x(55) & + -jvs(346)*x(56)-jvs(347)*x(57)-jvs(348)*x(59))/(jvs(342)) + x(48) = (x(48)-jvs(328)*x(49)-jvs(329)*x(50)-jvs(330)*x(51) & + -jvs(331)*x(55)-jvs(332)*x(56)-jvs(333)*x(57)-jvs(334) & + *x(59))/(jvs(327)) + x(47) = (x(47)-jvs(314)*x(48)-jvs(315)*x(50)-jvs(316)*x(51) & + -jvs(317)*x(52)-jvs(318)*x(53)-jvs(319)*x(54)-jvs(320) & + *x(55)-jvs(321)*x(56)-jvs(322)*x(57)-jvs(323)*x(58) & + -jvs(324)*x(59))/(jvs(313)) + x(46) = (x(46)-jvs(291)*x(48)-jvs(292)*x(49)-jvs(293)*x(50) & + -jvs(294)*x(51)-jvs(295)*x(53)-jvs(296)*x(55)-jvs(297) & + *x(56)-jvs(298)*x(57)-jvs(299)*x(59))/(jvs(290)) + x(45) = (x(45)-jvs(275)*x(48)-jvs(276)*x(49)-jvs(277)*x(50) & + -jvs(278)*x(51)-jvs(279)*x(55)-jvs(280)*x(56)-jvs(281) & + *x(57)-jvs(282)*x(59))/(jvs(274)) + x(44) = (x(44)-jvs(259)*x(50)-jvs(260)*x(51)-jvs(261)*x(55) & + -jvs(262)*x(56)-jvs(263)*x(57)-jvs(264)*x(59))/(jvs(258)) + x(43) = (x(43)-jvs(251)*x(51)-jvs(252)*x(53)-jvs(253)*x(55) & + -jvs(254)*x(57)-jvs(255)*x(59))/(jvs(250)) + x(42) = (x(42)-jvs(242)*x(43)-jvs(243)*x(52)-jvs(244)*x(56) & + -jvs(245)*x(57)-jvs(246)*x(58)-jvs(247)*x(59))/(jvs(241)) + x(41) = (x(41)-jvs(231)*x(48)-jvs(232)*x(49)-jvs(233)*x(50) & + -jvs(234)*x(51)-jvs(235)*x(55)-jvs(236)*x(56)-jvs(237) & + *x(57)-jvs(238)*x(59))/(jvs(230)) + x(40) = (x(40)-jvs(218)*x(48)-jvs(219)*x(49)-jvs(220)*x(51) & + -jvs(221)*x(55)-jvs(222)*x(56)-jvs(223)*x(57)-jvs(224) & + *x(59))/(jvs(217)) + x(39) = (x(39)-jvs(209)*x(51)-jvs(210)*x(57)-jvs(211)*x(59))/ & + (jvs(208)) + x(38) = (x(38)-jvs(202)*x(43)-jvs(203)*x(54)-jvs(204)*x(55) & + -jvs(205)*x(57)-jvs(206)*x(58)-jvs(207)*x(59))/(jvs(201)) + x(37) = (x(37)-jvs(190)*x(39)-jvs(191)*x(40)-jvs(192)*x(48) & + -jvs(193)*x(49)-jvs(194)*x(50)-jvs(195)*x(51)-jvs(196) & + *x(55)-jvs(197)*x(56)-jvs(198)*x(57)-jvs(199)*x(59))/ & + (jvs(189)) + x(36) = (x(36)-jvs(179)*x(51)-jvs(180)*x(57)-jvs(181)*x(59))/ & + (jvs(178)) + x(35) = (x(35)-jvs(169)*x(39)-jvs(170)*x(48)-jvs(171)*x(49) & + -jvs(172)*x(50)-jvs(173)*x(51)-jvs(174)*x(55)-jvs(175) & + *x(56)-jvs(176)*x(57)-jvs(177)*x(59))/(jvs(168)) + x(34) = (x(34)-jvs(164)*x(43)-jvs(165)*x(57)-jvs(166)*x(59))/ & + (jvs(163)) + x(33) = (x(33)-jvs(159)*x(48)-jvs(160)*x(49)-jvs(161)*x(56) & + -jvs(162)*x(59))/(jvs(158)) + x(32) = (x(32)-jvs(154)*x(51)-jvs(155)*x(55)-jvs(156)*x(57) & + -jvs(157)*x(59))/(jvs(153)) + x(31) = (x(31)-jvs(141)*x(34)-jvs(142)*x(40)-jvs(143)*x(42) & + -jvs(144)*x(45)-jvs(145)*x(47)-jvs(146)*x(52)-jvs(147) & + *x(53)-jvs(148)*x(56)-jvs(149)*x(57)-jvs(150)*x(59))/ & + (jvs(140)) + x(30) = (x(30)-jvs(134)*x(34)-jvs(135)*x(55)-jvs(136)*x(58) & + -jvs(137)*x(59))/(jvs(133)) + x(29) = (x(29)-jvs(128)*x(54)-jvs(129)*x(55)-jvs(130)*x(58))/ & + (jvs(127)) + x(28) = (x(28)-jvs(117)*x(32)-jvs(118)*x(36)-jvs(119)*x(39) & + -jvs(120)*x(40)-jvs(121)*x(45)-jvs(122)*x(47)-jvs(123) & + *x(51)-jvs(124)*x(52)-jvs(125)*x(57)-jvs(126)*x(59))/ & + (jvs(116)) + x(27) = (x(27)-jvs(105)*x(33)-jvs(106)*x(36)-jvs(107)*x(39) & + -jvs(108)*x(44)-jvs(109)*x(49)-jvs(110)*x(50)-jvs(111) & + *x(51)-jvs(112)*x(55)-jvs(113)*x(57)-jvs(114)*x(59))/ & + (jvs(104)) + x(26) = (x(26)-jvs(101)*x(57)-jvs(102)*x(59))/(jvs(100)) + x(25) = (x(25)-jvs(94)*x(42)-jvs(95)*x(56)-jvs(96)*x(58)-jvs(97) & + *x(59))/(jvs(93)) + x(24) = (x(24)-jvs(88)*x(52)-jvs(89)*x(53)-jvs(90)*x(55)-jvs(91) & + *x(56)-jvs(92)*x(59))/(jvs(87)) + x(23) = (x(23)-jvs(82)*x(36)-jvs(83)*x(39)-jvs(84)*x(51)-jvs(85) & + *x(58)-jvs(86)*x(59))/(jvs(81)) + x(22) = (x(22)-jvs(79)*x(51)-jvs(80)*x(59))/(jvs(78)) + x(21) = (x(21)-jvs(75)*x(41)-jvs(76)*x(56)-jvs(77)*x(59))/ & + (jvs(74)) + x(20) = (x(20)-jvs(72)*x(34)-jvs(73)*x(59))/(jvs(71)) + x(19) = (x(19)-jvs(69)*x(55)-jvs(70)*x(59))/(jvs(68)) + x(18) = (x(18)-jvs(63)*x(53)-jvs(64)*x(56)-jvs(65)*x(59))/ & + (jvs(62)) + x(17) = (x(17)-jvs(58)*x(26)-jvs(59)*x(53)-jvs(60)*x(57)-jvs(61) & + *x(59))/(jvs(57)) + x(16) = (x(16)-jvs(55)*x(27)-jvs(56)*x(59))/(jvs(54)) + x(15) = (x(15)-jvs(52)*x(59))/(jvs(51)) + x(14) = (x(14)-jvs(49)*x(53)-jvs(50)*x(57))/(jvs(48)) + x(13) = (x(13)-jvs(45)*x(42)-jvs(46)*x(56)-jvs(47)*x(59))/ & + (jvs(44)) + x(12) = (x(12)-jvs(43)*x(59))/(jvs(42)) + x(11) = (x(11)-jvs(40)*x(20)-jvs(41)*x(59))/(jvs(39)) + x(10) = (x(10)-jvs(37)*x(46)-jvs(38)*x(53))/(jvs(36)) + x(9) = (x(9)-jvs(34)*x(41)-jvs(35)*x(59))/(jvs(33)) + x(8) = (x(8)-jvs(31)*x(54)-jvs(32)*x(59))/(jvs(30)) + x(7) = (x(7)-jvs(29)*x(59))/(jvs(28)) + x(6) = (x(6)-jvs(27)*x(51))/(jvs(26)) + x(5) = (x(5)-jvs(25)*x(38))/(jvs(24)) + x(4) = (x(4)-jvs(16)*x(42)-jvs(17)*x(47)-jvs(18)*x(52)-jvs(19) & + *x(53)-jvs(20)*x(54)-jvs(21)*x(55)-jvs(22)*x(56)-jvs(23) & + *x(59))/(jvs(15)) + x(3) = (x(3)-jvs(10)*x(36)-jvs(11)*x(39)-jvs(12)*x(46)-jvs(13) & + *x(51)-jvs(14)*x(56))/(jvs(9)) + x(2) = (x(2)-jvs(6)*x(22)-jvs(7)*x(36)-jvs(8)*x(51))/(jvs(5)) + x(1) = (x(1)-jvs(2)*x(8)-jvs(3)*x(52)-jvs(4)*x(59))/(jvs(1)) + return + end subroutine cbmz_v02r05_solve + + +! cbmz_v02r06_torodas.f - created on 18-nov-2003 from previous +! cbmz_v02r06_torodas.f cbmz_v02r06_mapconcs.f +! cbmz_v02r06_maprates.f cbmz_v02r06_dydt.f +! cbmz_v02r06_jacob.f cbmz_v02r06_decomp.f +! cbmz_v02r06_solve.f +! so now everything is in a single file +!----------------------------------------------------------------------- + + subroutine cbmz_v02r06_torodas( & + ngas, taa, tzz, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + hmin, hstart, & + info_rodas, iok, lunerr, idydt_sngldble ) +! +! interfaces to rodas3 solver formechanism-version-regime =cbmz_v02r06 +! +! *** do not include any pegasus common blocks *** +! + use module_data_cbmz + use module_cbmz_rodas3_solver, only: rodas3_ff_x2 + implicit none + +! subr parameters + integer ngas, iok, lunerr, idydt_sngldble + integer info_rodas(6) + real taa, tzz, hmin, hstart + real stot(ngas), atol(ngas), rtol(ngas) + real yposlimit(ngas), yneglimit(ngas) + real sfixedkpp(nfixed_kppmax), rconstkpp(nreact_kppmax) + +! local variables + +! external cbmz_v02r06_dydt +! external cbmz_v02r06_jacob +! external cbmz_v02r06_decomp +! external cbmz_v02r06_solve + + integer i + + real hmax + + integer lu_crow_v(nvar_r06_kpp + 1) + save lu_crow_v + integer lu_diag_v(nvar_r06_kpp + 1) + save lu_diag_v + integer lu_icol_v(lu_nonzero_v_r06_kpp) + save lu_icol_v + + data( lu_icol_v(i), i = 1, 252 ) / & + 1, 8, 54, 61, 2, 22, 37, 38, 51, 58, 3, 37, & + 42, 52, 58, 63, 4, 45, 49, 50, 54, 56, 60, 61, & + 63, 5, 39, 6, 58, 7, 61, 8, 50, 61, 9, 44, & + 61, 10, 52, 56, 11, 19, 61, 12, 61, 13, 45, 61, & + 63, 14, 56, 62, 15, 61, 16, 26, 56, 61, 62, 17, & + 56, 61, 63, 12, 15, 18, 60, 61, 19, 34, 61, 20, & + 30, 37, 42, 47, 53, 57, 58, 59, 60, 61, 62, 21, & + 44, 61, 63, 22, 58, 61, 23, 37, 42, 55, 58, 61, & + 24, 54, 56, 60, 61, 63, 25, 45, 55, 61, 63, 12, & + 15, 26, 61, 62, 27, 50, 55, 60, 11, 19, 28, 34, & + 55, 60, 61, 29, 38, 60, 62, 63, 15, 20, 29, 30, & + 35, 37, 38, 42, 47, 51, 53, 57, 58, 59, 60, 61, & + 62, 63, 22, 31, 32, 36, 37, 38, 42, 43, 48, 49, & + 51, 54, 58, 60, 61, 62, 18, 26, 32, 58, 60, 61, & + 62, 14, 26, 33, 34, 43, 45, 48, 49, 51, 54, 56, & + 61, 62, 63, 34, 46, 61, 62, 35, 38, 60, 61, 63, & + 36, 51, 60, 61, 63, 37, 58, 61, 62, 38, 58, 61, & + 62, 34, 39, 46, 50, 55, 60, 61, 62, 12, 15, 22, & + 26, 32, 37, 38, 40, 42, 43, 51, 53, 57, 58, 59, & + 60, 61, 62, 63, 36, 41, 42, 51, 53, 57, 58, 59, & + 60, 61, 62, 63, 64, 42, 58, 61, 62, 15, 32, 36 / + + data( lu_icol_v(i), i = 253, 504 ) / & + 37, 42, 43, 51, 53, 58, 60, 61, 62, 63, 64, 9, & + 21, 37, 42, 44, 53, 57, 58, 59, 60, 61, 62, 63, & + 19, 34, 45, 46, 54, 55, 61, 62, 63, 6, 34, 46, & + 56, 58, 60, 61, 62, 37, 42, 47, 57, 58, 60, 61, & + 62, 63, 7, 21, 22, 29, 32, 36, 37, 38, 42, 44, & + 47, 48, 51, 53, 57, 58, 59, 60, 61, 62, 63, 22, & + 23, 25, 27, 28, 32, 34, 35, 36, 37, 38, 39, 42, & + 45, 46, 47, 49, 50, 51, 54, 55, 56, 57, 58, 60, & + 61, 62, 63, 64, 27, 28, 34, 39, 45, 46, 50, 54, & + 55, 56, 58, 60, 61, 62, 63, 29, 35, 38, 51, 58, & + 60, 61, 62, 63, 10, 32, 37, 38, 41, 42, 43, 48, & + 51, 52, 53, 56, 57, 58, 59, 60, 61, 62, 63, 64, & + 35, 36, 38, 51, 53, 58, 59, 60, 61, 62, 63, 64, & + 27, 39, 45, 46, 49, 50, 51, 54, 55, 56, 57, 58, & + 60, 61, 62, 63, 64, 19, 25, 27, 28, 34, 37, 39, & + 41, 42, 45, 46, 48, 50, 51, 52, 53, 54, 55, 56, & + 57, 58, 59, 60, 61, 62, 63, 64, 10, 14, 16, 17, & + 18, 24, 26, 27, 28, 29, 33, 34, 35, 36, 38, 39, & + 40, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, & + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, & + 16, 18, 26, 29, 35, 38, 47, 51, 56, 57, 58, 59 / + + data( lu_icol_v(i), i = 505, 715 ) / & + 60, 61, 62, 63, 64, 22, 32, 37, 38, 42, 46, 50, & + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, & + 63, 64, 30, 35, 37, 38, 42, 47, 51, 53, 57, 58, & + 59, 60, 61, 62, 63, 64, 18, 24, 27, 28, 29, 34, & + 35, 36, 38, 39, 40, 42, 43, 44, 46, 47, 50, 51, & + 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, & + 64, 6, 7, 8, 9, 11, 12, 13, 15, 17, 19, 21, & + 22, 23, 24, 25, 26, 30, 31, 32, 33, 34, 35, 36, & + 37, 38, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, & + 51, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, & + 64, 14, 26, 33, 34, 37, 38, 40, 42, 43, 44, 45, & + 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, & + 58, 59, 60, 61, 62, 63, 64, 7, 8, 12, 13, 15, & + 17, 18, 19, 21, 22, 23, 25, 26, 27, 28, 29, 31, & + 32, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, & + 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, & + 58, 59, 60, 61, 62, 63, 64, 41, 42, 51, 53, 57, & + 58, 59, 60, 61, 62, 63, 64 / + + data lu_crow_v / & + 1, 5, 11, 17, 26, 28, 30, 32, 35, 38, 41, 44, & + 46, 50, 53, 55, 60, 64, 69, 72, 84, 88, 91, 97, & + 103,108,113,117,124,129,147,163,170,184,188,193, & + 198,202,206,214,233,246,250,264,277,286,294,303, & + 324,353,368,377,397,409,426,453,493,510,531,547, & + 578,626,656,704,716 / + + data lu_diag_v / & + 1, 5, 11, 17, 26, 28, 30, 32, 35, 38, 41, 44, & + 46, 50, 53, 55, 60, 66, 69, 72, 84, 88, 91, 97, & + 103,110,113,119,124,132,148,165,172,184,188,193, & + 198,202,207,221,234,246,255,268,279,288,296,314, & + 340,359,371,386,401,416,443,484,502,524,541,573, & + 622,653,702,715,716 / + + + + info_rodas(1) = 1 + do i = 2, 6 + info_rodas(i) = 0 + end do + hmax = tzz - taa + +! do not integrate if hmax is less/equal to hmin +! because hmin is generally 0.1 s or less + if (hmax .le. 1.001*hmin) then + iok = 11 + return + end if + + call rodas3_ff_x2( & + nvar_r06_kpp, taa, tzz, hmin, hmax, hstart, & + stot, atol, rtol, yposlimit, yneglimit, & + sfixedkpp, rconstkpp, & + lu_nonzero_v_r06_kpp, lu_crow_v, lu_diag_v, lu_icol_v, & + info_rodas, iok, lunerr, & + cbmz_v02r06_dydt, & + cbmz_v02r06_jacob, & + cbmz_v02r06_decomp, & + cbmz_v02r06_solve ) + + return + end subroutine cbmz_v02r06_torodas + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_mapconcs( imap, nyy, yy, yyfixed, cbox ) +! +! maps species concentrations (gaschemistry cbox array <--> kpp yy array) +! for mechanism-version-regime = cbmz_v02r06 +! + use module_data_cbmz + implicit none + +! subr parameters +! imap = mapping direction flag [input] +! 0 = map cbox --> yy and yyfixed +! 1 = map yy --> cbox + integer imap +! nyy = number of kpp "variable" species [output] + integer nyy +! yy = kpp species concentrations array [input/output] + real yy(nvar_r06_kpp) +! yyfixed = kpp species concentrations array [input/output] + real yyfixed(nfixed_kppmax) +! cbox = main gaschemistry species conc array [input/output] + real cbox(ngas_z) + +! local variables + integer ih2so4_kpp + parameter ( ih2so4_kpp = 1 ) + integer ihcooh_kpp + parameter ( ihcooh_kpp = 2 ) + integer ircooh_kpp + parameter ( ircooh_kpp = 3 ) + integer imsa_kpp + parameter ( imsa_kpp = 4 ) + integer imtf_kpp + parameter ( imtf_kpp = 5 ) + integer io1d_kpp + parameter ( io1d_kpp = 6 ) + integer ic2h5oh_kpp + parameter ( ic2h5oh_kpp = 7 ) + integer iso2_kpp + parameter ( iso2_kpp = 8 ) + integer ic2h6_kpp + parameter ( ic2h6_kpp = 9 ) + integer ipan_kpp + parameter ( ipan_kpp = 10 ) + integer idmso2_kpp + parameter ( idmso2_kpp = 11 ) + integer itol_kpp + parameter ( itol_kpp = 12 ) + integer ih2o2_kpp + parameter ( ih2o2_kpp = 13 ) + integer in2o5_kpp + parameter ( in2o5_kpp = 14 ) + integer ixyl_kpp + parameter ( ixyl_kpp = 15 ) + integer icro_kpp + parameter ( icro_kpp = 16 ) + integer ihno4_kpp + parameter ( ihno4_kpp = 17 ) + integer ito2_kpp + parameter ( ito2_kpp = 18 ) + integer idmso_kpp + parameter ( idmso_kpp = 19 ) + integer ixpar_kpp + parameter ( ixpar_kpp = 20 ) + integer iethooh_kpp + parameter ( iethooh_kpp = 21 ) + integer ieth_kpp + parameter ( ieth_kpp = 22 ) + integer ich3oh_kpp + parameter ( ich3oh_kpp = 23 ) + integer ihono_kpp + parameter ( ihono_kpp = 24 ) + integer ich3ooh_kpp + parameter ( ich3ooh_kpp = 25 ) + integer icres_kpp + parameter ( icres_kpp = 26 ) + integer ich3so2oo_kpp + parameter ( ich3so2oo_kpp = 27 ) + integer ich3so2ch2oo_kpp + parameter ( ich3so2ch2oo_kpp = 28 ) + integer iisopn_kpp + parameter ( iisopn_kpp = 29 ) + integer ipar_kpp + parameter ( ipar_kpp = 30 ) + integer ico_kpp + parameter ( ico_kpp = 31 ) + integer iopen_kpp + parameter ( iopen_kpp = 32 ) + integer ihno3_kpp + parameter ( ihno3_kpp = 33 ) + integer idms_kpp + parameter ( idms_kpp = 34 ) + integer iisopp_kpp + parameter ( iisopp_kpp = 35 ) + integer iisopo2_kpp + parameter ( iisopo2_kpp = 36 ) + integer iolet_kpp + parameter ( iolet_kpp = 37 ) + integer iisop_kpp + parameter ( iisop_kpp = 38 ) + integer ich3sch2oo_kpp + parameter ( ich3sch2oo_kpp = 39 ) + integer ixo2_kpp + parameter ( ixo2_kpp = 40 ) + integer iaone_kpp + parameter ( iaone_kpp = 41 ) + integer iolei_kpp + parameter ( iolei_kpp = 42 ) + integer imgly_kpp + parameter ( imgly_kpp = 43 ) + integer iethp_kpp + parameter ( iethp_kpp = 44 ) + integer ich3so2h_kpp + parameter ( ich3so2h_kpp = 45 ) + integer io3p_kpp + parameter ( io3p_kpp = 46 ) + integer inap_kpp + parameter ( inap_kpp = 47 ) + integer iald2_kpp + parameter ( iald2_kpp = 48 ) + integer ihcho_kpp + parameter ( ihcho_kpp = 49 ) + integer ich3so2_kpp + parameter ( ich3so2_kpp = 50 ) + integer iisoprd_kpp + parameter ( iisoprd_kpp = 51 ) + integer ic2o3_kpp + parameter ( ic2o3_kpp = 52 ) + integer irooh_kpp + parameter ( irooh_kpp = 53 ) + integer ich3so3_kpp + parameter ( ich3so3_kpp = 54 ) + integer ich3o2_kpp + parameter ( ich3o2_kpp = 55 ) + integer ino2_kpp + parameter ( ino2_kpp = 56 ) + integer ionit_kpp + parameter ( ionit_kpp = 57 ) + integer io3_kpp + parameter ( io3_kpp = 58 ) + integer iro2_kpp + parameter ( iro2_kpp = 59 ) + integer ino_kpp + parameter ( ino_kpp = 60 ) + integer ioh_kpp + parameter ( ioh_kpp = 61 ) + integer ino3_kpp + parameter ( ino3_kpp = 62 ) + integer iho2_kpp + parameter ( iho2_kpp = 63 ) + integer iano2_kpp + parameter ( iano2_kpp = 64 ) + +! indexes declaration for fixed species + integer ich4_kpp + parameter ( ich4_kpp = 1 ) + integer ih2o_kpp + parameter ( ih2o_kpp = 2 ) + integer ih2_kpp + parameter ( ih2_kpp = 3 ) + integer io2_kpp + parameter ( io2_kpp = 4 ) + integer in2_kpp + parameter ( in2_kpp = 5 ) + + + nyy = nvar_r06_kpp + + if (imap .le. 0) goto 1000 + if (imap .ge. 1) goto 2000 + + +! +! map cbox values into yyvarkpp and yyfixkpp +! +1000 continue + yy(ih2so4_kpp) = cbox(ih2so4_z) + yy(ihcooh_kpp) = cbox(ihcooh_z) + yy(ircooh_kpp) = cbox(ircooh_z) + yy(imsa_kpp) = cbox(imsa_z) + yy(imtf_kpp) = cbox(imtf_z) + yy(io1d_kpp) = cbox(io1d_z) + yy(ic2h5oh_kpp) = cbox(ic2h5oh_z) + yy(iso2_kpp) = cbox(iso2_z) + yy(ic2h6_kpp) = cbox(ic2h6_z) + yy(ipan_kpp) = cbox(ipan_z) + yy(idmso2_kpp) = cbox(idmso2_z) + yy(itol_kpp) = cbox(itol_z) + yy(ih2o2_kpp) = cbox(ih2o2_z) + yy(in2o5_kpp) = cbox(in2o5_z) + yy(ixyl_kpp) = cbox(ixyl_z) + yy(icro_kpp) = cbox(icro_z) + yy(ihno4_kpp) = cbox(ihno4_z) + yy(ito2_kpp) = cbox(ito2_z) + yy(idmso_kpp) = cbox(idmso_z) + yy(ixpar_kpp) = cbox(ixpar_z) + yy(iethooh_kpp) = cbox(iethooh_z) + yy(ieth_kpp) = cbox(ieth_z) + yy(ich3oh_kpp) = cbox(ich3oh_z) + yy(ihono_kpp) = cbox(ihono_z) + yy(ich3ooh_kpp) = cbox(ich3ooh_z) + yy(icres_kpp) = cbox(icres_z) + yy(ich3so2oo_kpp) = cbox(ich3so2oo_z) + yy(ich3so2ch2oo_kpp) = cbox(ich3so2ch2oo_z) + yy(iisopn_kpp) = cbox(iisopn_z) + yy(ipar_kpp) = cbox(ipar_z) + yy(ico_kpp) = cbox(ico_z) + yy(iopen_kpp) = cbox(iopen_z) + yy(ihno3_kpp) = cbox(ihno3_z) + yy(idms_kpp) = cbox(idms_z) + yy(iisopp_kpp) = cbox(iisopp_z) + yy(iisopo2_kpp) = cbox(iisopo2_z) + yy(iolet_kpp) = cbox(iolet_z) + yy(iisop_kpp) = cbox(iisop_z) + yy(ich3sch2oo_kpp) = cbox(ich3sch2oo_z) + yy(ixo2_kpp) = cbox(ixo2_z) + yy(iaone_kpp) = cbox(iaone_z) + yy(iolei_kpp) = cbox(iolei_z) + yy(imgly_kpp) = cbox(imgly_z) + yy(iethp_kpp) = cbox(iethp_z) + yy(ich3so2h_kpp) = cbox(ich3so2h_z) + yy(io3p_kpp) = cbox(io3p_z) + yy(inap_kpp) = cbox(inap_z) + yy(iald2_kpp) = cbox(iald2_z) + yy(ihcho_kpp) = cbox(ihcho_z) + yy(ich3so2_kpp) = cbox(ich3so2_z) + yy(iisoprd_kpp) = cbox(iisoprd_z) + yy(ic2o3_kpp) = cbox(ic2o3_z) + yy(irooh_kpp) = cbox(irooh_z) + yy(ich3so3_kpp) = cbox(ich3so3_z) + yy(ich3o2_kpp) = cbox(ich3o2_z) + yy(ino2_kpp) = cbox(ino2_z) + yy(ionit_kpp) = cbox(ionit_z) + yy(io3_kpp) = cbox(io3_z) + yy(iro2_kpp) = cbox(iro2_z) + yy(ino_kpp) = cbox(ino_z) + yy(ioh_kpp) = cbox(ioh_z) + yy(ino3_kpp) = cbox(ino3_z) + yy(iho2_kpp) = cbox(iho2_z) + yy(iano2_kpp) = cbox(iano2_z) + + yyfixed(ich4_kpp) = cbox(ich4_z) + yyfixed(ih2o_kpp) = cbox(ih2o_z) + yyfixed(ih2_kpp) = cbox(ih2_z) + yyfixed(io2_kpp) = cbox(io2_z) + yyfixed(in2_kpp) = cbox(in2_z) + +! +! map yyvarkpp values into cbox +! +2000 continue + cbox(ih2so4_z) = yy(ih2so4_kpp) + cbox(ihcooh_z) = yy(ihcooh_kpp) + cbox(ircooh_z) = yy(ircooh_kpp) + cbox(imsa_z) = yy(imsa_kpp) + cbox(imtf_z) = yy(imtf_kpp) + cbox(io1d_z) = yy(io1d_kpp) + cbox(ic2h5oh_z) = yy(ic2h5oh_kpp) + cbox(iso2_z) = yy(iso2_kpp) + cbox(ic2h6_z) = yy(ic2h6_kpp) + cbox(ipan_z) = yy(ipan_kpp) + cbox(idmso2_z) = yy(idmso2_kpp) + cbox(itol_z) = yy(itol_kpp) + cbox(ih2o2_z) = yy(ih2o2_kpp) + cbox(in2o5_z) = yy(in2o5_kpp) + cbox(ixyl_z) = yy(ixyl_kpp) + cbox(icro_z) = yy(icro_kpp) + cbox(ihno4_z) = yy(ihno4_kpp) + cbox(ito2_z) = yy(ito2_kpp) + cbox(idmso_z) = yy(idmso_kpp) + cbox(ixpar_z) = yy(ixpar_kpp) + cbox(iethooh_z) = yy(iethooh_kpp) + cbox(ieth_z) = yy(ieth_kpp) + cbox(ich3oh_z) = yy(ich3oh_kpp) + cbox(ihono_z) = yy(ihono_kpp) + cbox(ich3ooh_z) = yy(ich3ooh_kpp) + cbox(icres_z) = yy(icres_kpp) + cbox(ich3so2oo_z) = yy(ich3so2oo_kpp) + cbox(ich3so2ch2oo_z) = yy(ich3so2ch2oo_kpp) + cbox(iisopn_z) = yy(iisopn_kpp) + cbox(ipar_z) = yy(ipar_kpp) + cbox(ico_z) = yy(ico_kpp) + cbox(iopen_z) = yy(iopen_kpp) + cbox(ihno3_z) = yy(ihno3_kpp) + cbox(idms_z) = yy(idms_kpp) + cbox(iisopp_z) = yy(iisopp_kpp) + cbox(iisopo2_z) = yy(iisopo2_kpp) + cbox(iolet_z) = yy(iolet_kpp) + cbox(iisop_z) = yy(iisop_kpp) + cbox(ich3sch2oo_z) = yy(ich3sch2oo_kpp) + cbox(ixo2_z) = yy(ixo2_kpp) + cbox(iaone_z) = yy(iaone_kpp) + cbox(iolei_z) = yy(iolei_kpp) + cbox(imgly_z) = yy(imgly_kpp) + cbox(iethp_z) = yy(iethp_kpp) + cbox(ich3so2h_z) = yy(ich3so2h_kpp) + cbox(io3p_z) = yy(io3p_kpp) + cbox(inap_z) = yy(inap_kpp) + cbox(iald2_z) = yy(iald2_kpp) + cbox(ihcho_z) = yy(ihcho_kpp) + cbox(ich3so2_z) = yy(ich3so2_kpp) + cbox(iisoprd_z) = yy(iisoprd_kpp) + cbox(ic2o3_z) = yy(ic2o3_kpp) + cbox(irooh_z) = yy(irooh_kpp) + cbox(ich3so3_z) = yy(ich3so3_kpp) + cbox(ich3o2_z) = yy(ich3o2_kpp) + cbox(ino2_z) = yy(ino2_kpp) + cbox(ionit_z) = yy(ionit_kpp) + cbox(io3_z) = yy(io3_kpp) + cbox(iro2_z) = yy(iro2_kpp) + cbox(ino_z) = yy(ino_kpp) + cbox(ioh_z) = yy(ioh_kpp) + cbox(ino3_z) = yy(ino3_kpp) + cbox(iho2_z) = yy(iho2_kpp) + cbox(iano2_z) = yy(iano2_kpp) + + return + end subroutine cbmz_v02r06_mapconcs + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_maprates( & + rk_m1, & + rk_m2, & + rk_m3, & + rk_m4, & + rconst ) +! +! maps reaction rate constants (host code array --> kpp rconst array) +! for mechanism-version-regime = cbmz_v02r06 +! + use module_data_cbmz + implicit none + +! subr parameters +! all are host-code reaction-rate-constant arrays [input] + real rk_m1(*) + real rk_m2(*) + real rk_m3(*) + real rk_m4(*) + real rconst(nreact_kppmax) + +! local variables + integer i + + do i = 1, nreact_kppmax + rconst(i) = 0. + end do + + + rconst(1) = (rk_m1(1)) + rconst(2) = (rk_m1(2)) + rconst(3) = (rk_m1(3)) + rconst(4) = (rk_m1(4)) + rconst(5) = (rk_m1(5)) + rconst(6) = (rk_m1(6)) + rconst(7) = (rk_m1(7)) + rconst(8) = (rk_m1(8)) + rconst(9) = (rk_m1(9)) + rconst(10) = (rk_m1(10)) + rconst(11) = (rk_m1(11)) + rconst(12) = (rk_m1(12)) + rconst(13) = (rk_m1(13)) + rconst(14) = (rk_m1(14)) + rconst(15) = (rk_m1(15)) + rconst(16) = (rk_m1(16)) + rconst(17) = (rk_m1(17)) + rconst(18) = (rk_m1(18)) + rconst(19) = (rk_m1(19)) + rconst(20) = (rk_m1(20)) + rconst(21) = (rk_m1(21)) + rconst(22) = (rk_m1(22)) + rconst(23) = (rk_m1(23)) + rconst(24) = (rk_m1(24)) + rconst(25) = (rk_m1(25)) + rconst(26) = (rk_m1(26)) + rconst(27) = (rk_m1(27)) + rconst(28) = (rk_m1(28)) + rconst(29) = (rk_m1(29)) + rconst(30) = (rk_m1(30)) + rconst(31) = (rk_m1(31)) + rconst(32) = (rk_m1(32)) + rconst(33) = (rk_m1(33)) + rconst(34) = (rk_m1(34)) + rconst(35) = (rk_m1(35)) + rconst(36) = (rk_m1(36)) + rconst(37) = (rk_m1(37)) + rconst(38) = (rk_m1(38)) + rconst(39) = (rk_m1(39)) + rconst(40) = (rk_m1(40)) + rconst(41) = (rk_m1(41)) + rconst(42) = (rk_m1(42)) + rconst(43) = (rk_m1(43)) + rconst(44) = (rk_m1(44)) + rconst(45) = (rk_m1(45)) + rconst(46) = (rk_m1(46)) + rconst(47) = (rk_m1(47)) + rconst(48) = (rk_m1(48)) + rconst(49) = (rk_m1(49)) + rconst(50) = (rk_m1(50)) + rconst(51) = (rk_m1(51)) + rconst(52) = (rk_m1(52)) + rconst(53) = (rk_m1(53)) + rconst(54) = (rk_m1(54)) + rconst(55) = (rk_m1(55)) + rconst(56) = (rk_m1(56)) + rconst(57) = (rk_m1(57)) + rconst(58) = (rk_m1(58)) + rconst(59) = (rk_m1(59)) + rconst(60) = (rk_m1(60)) + rconst(61) = (rk_m1(61)) + rconst(62) = (rk_m1(62)) + rconst(63) = (rk_m1(63)) + rconst(64) = (rk_m1(64)) + rconst(65) = (rk_m1(65)) + rconst(66) = (rk_m2(2)) + rconst(67) = (rk_m2(3)) + rconst(68) = (rk_m2(4)) + rconst(69) = (rk_m2(31)) + rconst(70) = (rk_m2(32)) + rconst(71) = (rk_m2(34)) + rconst(72) = (rk_m2(39)) + rconst(73) = (rk_m2(44)) + rconst(74) = (rk_m2(49)) + rconst(75) = (rk_m2(1)) + rconst(76) = (rk_m2(5)) + rconst(77) = (rk_m2(6)) + rconst(78) = (rk_m2(7)) + rconst(79) = (rk_m2(8)) + rconst(80) = (rk_m2(9)) + rconst(81) = (rk_m2(10)) + rconst(82) = (rk_m2(11)) + rconst(83) = (rk_m2(12)) + rconst(84) = (rk_m2(13)) + rconst(85) = (rk_m2(14)) + rconst(86) = (rk_m2(15)) + rconst(87) = (rk_m2(16)) + rconst(88) = (rk_m2(17)) + rconst(89) = (rk_m2(18)) + rconst(90) = (rk_m2(19)) + rconst(91) = (rk_m2(20)) + rconst(92) = (rk_m2(21)) + rconst(93) = (rk_m2(22)) + rconst(94) = (rk_m2(23)) + rconst(95) = (rk_m2(24)) + rconst(96) = (rk_m2(25)) + rconst(97) = (rk_m2(26)) + rconst(98) = (rk_m2(27)) + rconst(99) = (rk_m2(28)) + rconst(100) = (rk_m2(29)) + rconst(101) = (rk_m2(30)) + rconst(102) = (rk_m2(33)) + rconst(103) = (rk_m2(35)) + rconst(104) = (rk_m2(36)) + rconst(105) = (rk_m2(37)) + rconst(106) = (rk_m2(38)) + rconst(107) = (rk_m2(40)) + rconst(108) = (rk_m2(41)) + rconst(109) = (rk_m2(42)) + rconst(110) = (rk_m2(43)) + rconst(111) = (rk_m2(45)) + rconst(112) = (rk_m2(46)) + rconst(113) = (rk_m2(47)) + rconst(114) = (rk_m2(48)) + rconst(115) = (rk_m2(50)) + rconst(116) = (rk_m2(51)) + rconst(117) = (rk_m2(52)) + rconst(118) = (rk_m2(53)) + rconst(119) = (rk_m3(1)) + rconst(120) = (rk_m3(2)) + rconst(121) = (rk_m3(3)) + rconst(122) = (rk_m3(4)) + rconst(123) = (rk_m3(5)) + rconst(124) = (rk_m3(6)) + rconst(125) = (rk_m3(7)) + rconst(126) = (rk_m3(8)) + rconst(127) = (rk_m3(9)) + rconst(128) = (rk_m3(10)) + rconst(129) = (rk_m3(11)) + rconst(130) = (rk_m3(12)) + rconst(131) = (rk_m3(13)) + rconst(132) = (rk_m3(14)) + rconst(133) = (rk_m3(15)) + rconst(134) = (rk_m3(16)) + rconst(135) = (rk_m4(1)) + rconst(136) = (rk_m4(2)) + rconst(137) = (rk_m4(3)) + rconst(138) = (rk_m4(4)) + rconst(139) = (rk_m4(5)) + rconst(140) = (rk_m4(6)) + rconst(141) = (rk_m4(7)) + rconst(142) = (rk_m4(8)) + rconst(143) = (rk_m4(9)) + rconst(144) = (rk_m4(10)) + rconst(145) = (rk_m4(11)) + rconst(146) = (rk_m4(12)) + rconst(147) = (rk_m4(13)) + rconst(148) = (rk_m4(14)) + rconst(149) = (rk_m4(15)) + rconst(150) = (rk_m4(16)) + rconst(151) = (rk_m4(17)) + rconst(152) = (rk_m4(18)) + rconst(153) = (rk_m4(19)) + rconst(154) = (rk_m4(20)) + rconst(155) = (rk_m4(21)) + rconst(156) = (rk_m4(22)) + rconst(157) = (rk_m4(23)) + rconst(158) = (rk_m4(24)) + rconst(159) = (rk_m4(25)) + rconst(160) = (rk_m4(26)) + rconst(161) = (rk_m4(27)) + rconst(162) = (rk_m4(28)) + rconst(163) = (rk_m4(29)) + rconst(164) = (rk_m4(30)) + rconst(165) = (rk_m4(31)) + rconst(166) = (rk_m4(32)) + return + end subroutine cbmz_v02r06_maprates + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_dydt( nvardum, tdum, v, a_var, f, rconst ) +! +! computes rates of change for mechanism-version-regime = cbmz_v02r06 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r06_kpp) +! a_var = dydt for each species [output] + real a_var(nvar_r06_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r06_kpp) + +! local variables +! a = rate for each reaction + real a(nreact_r06_kpp) + +! computation of equation rates + a(1) = rconst(1)*v(56) + a(2) = rconst(2)*v(62) + a(3) = rconst(3)*v(24) + a(4) = rconst(4)*v(33) + a(5) = rconst(5)*v(17) + a(6) = rconst(6)*v(14) + a(7) = rconst(7)*v(58) + a(8) = rconst(8)*v(58) + a(9) = rconst(9)*v(13) + a(10) = rconst(10)*v(6)*f(4) + a(11) = rconst(11)*v(6)*f(5) + a(12) = rconst(12)*v(6)*f(2) + a(13) = rconst(13)*v(46)*f(4) + a(14) = rconst(14)*v(46)*v(58) + a(15) = rconst(15)*v(46)*v(56) + a(16) = rconst(16)*v(46)*v(56) + a(17) = rconst(17)*v(46)*v(60) + a(18) = rconst(18)*v(58)*v(60) + a(19) = rconst(19)*v(56)*v(58) + a(20) = rconst(20)*v(58)*v(61) + a(21) = rconst(21)*v(58)*v(63) + a(22) = rconst(22)*v(61)*f(3) + a(23) = rconst(23)*v(60)*v(61) + a(24) = rconst(24)*v(56)*v(61) + a(25) = rconst(25)*v(61)*v(62) + a(26) = rconst(26)*v(24)*v(61) + a(27) = rconst(27)*v(33)*v(61) + a(28) = rconst(28)*v(17)*v(61) + a(29) = rconst(29)*v(61)*v(63) + a(30) = rconst(30)*v(13)*v(61) + a(31) = rconst(31)*v(63)*v(63) + a(32) = rconst(32)*v(63)*v(63)*f(2) + a(33) = rconst(33)*v(60)*v(63) + a(34) = rconst(34)*v(56)*v(63) + a(35) = rconst(35)*v(56)*v(63) + a(36) = rconst(36)*v(17) + a(37) = rconst(37)*v(60)*v(62) + a(38) = rconst(38)*v(56)*v(62) + a(39) = rconst(39)*v(56)*v(62) + a(40) = rconst(40)*v(62)*v(62) + a(41) = rconst(41)*v(62)*v(63) + a(42) = rconst(42)*v(14)*f(2) + a(43) = rconst(43)*v(14) + a(44) = rconst(44)*v(31)*v(61) + a(45) = rconst(45)*v(8)*v(61) + a(46) = rconst(46)*v(61)*f(1) + a(47) = rconst(47)*v(9)*v(61) + a(48) = rconst(48)*v(23)*v(61) + a(49) = rconst(49)*v(49) + a(50) = rconst(50)*v(49) + a(51) = rconst(51)*v(49)*v(61) + a(52) = rconst(52)*v(49)*v(62) + a(53) = rconst(53)*v(25) + a(54) = rconst(54)*v(21) + a(55) = rconst(55)*v(25)*v(61) + a(56) = rconst(56)*v(21)*v(61) + a(57) = rconst(57)*v(55)*v(60) + a(58) = rconst(58)*v(44)*v(60) + a(59) = rconst(59)*v(55)*v(62) + a(60) = rconst(60)*v(44)*v(62) + a(61) = rconst(61)*v(55)*v(63) + a(62) = rconst(62)*v(44)*v(63) + a(63) = rconst(63)*v(55) + a(64) = rconst(64)*v(44) + a(65) = rconst(65)*v(7)*v(61) + a(66) = rconst(66)*v(48) + a(67) = rconst(67)*v(48)*v(61) + a(68) = rconst(68)*v(48)*v(62) + a(69) = rconst(69)*v(52)*v(56) + a(70) = rconst(70)*v(10) + a(71) = rconst(71)*v(52)*v(60) + a(72) = rconst(72)*v(52)*v(62) + a(73) = rconst(73)*v(52)*v(63) + a(74) = rconst(74)*v(52) + a(75) = rconst(75)*v(30)*v(61) + a(76) = rconst(76)*v(41) + a(77) = rconst(77)*v(41)*v(61) + a(78) = rconst(78)*v(43) + a(79) = rconst(79)*v(43)*v(61) + a(80) = rconst(80)*v(43)*v(62) + a(81) = rconst(81)*v(22)*v(58) + a(82) = rconst(82)*v(22)*v(61) + a(83) = rconst(83)*v(37)*v(58) + a(84) = rconst(84)*v(42)*v(58) + a(85) = rconst(85)*v(37)*v(61) + a(86) = rconst(86)*v(42)*v(61) + a(87) = rconst(87)*v(37)*v(62) + a(88) = rconst(88)*v(42)*v(62) + a(89) = rconst(89)*v(12)*v(61) + a(90) = rconst(90)*v(15)*v(61) + a(91) = rconst(91)*v(18)*v(60) + a(92) = rconst(92)*v(26)*v(61) + a(93) = rconst(93)*v(26)*v(62) + a(94) = rconst(94)*v(16)*v(56) + a(95) = rconst(95)*v(32)*v(61) + a(96) = rconst(96)*v(32) + a(97) = rconst(97)*v(32)*v(58) + a(98) = rconst(98)*v(53) + a(99) = rconst(99)*v(53)*v(61) + a(100) = rconst(100)*v(57)*v(61) + a(101) = rconst(101)*v(57) + a(102) = rconst(102)*v(59)*v(60) + a(103) = rconst(103)*v(60)*v(64) + a(104) = rconst(104)*v(47)*v(60) + a(105) = rconst(105)*v(40)*v(60) + a(106) = rconst(106)*v(59)*v(62) + a(107) = rconst(107)*v(62)*v(64) + a(108) = rconst(108)*v(47)*v(62) + a(109) = rconst(109)*v(40)*v(62) + a(110) = rconst(110)*v(59)*v(63) + a(111) = rconst(111)*v(63)*v(64) + a(112) = rconst(112)*v(47)*v(63) + a(113) = rconst(113)*v(40)*v(63) + a(114) = rconst(114)*v(59) + a(115) = rconst(115)*v(64) + a(116) = rconst(116)*v(47) + a(117) = rconst(117)*v(40) + a(118) = rconst(118)*v(20)*v(30) + a(119) = rconst(119)*v(38)*v(61) + a(120) = rconst(120)*v(38)*v(58) + a(121) = rconst(121)*v(38)*v(62) + a(122) = rconst(122)*v(51) + a(123) = rconst(123)*v(51)*v(61) + a(124) = rconst(124)*v(51)*v(58) + a(125) = rconst(125)*v(51)*v(62) + a(126) = rconst(126)*v(35)*v(60) + a(127) = rconst(127)*v(29)*v(60) + a(128) = rconst(128)*v(36)*v(60) + a(129) = rconst(129)*v(35)*v(63) + a(130) = rconst(130)*v(29)*v(63) + a(131) = rconst(131)*v(36)*v(63) + a(132) = rconst(132)*v(35) + a(133) = rconst(133)*v(29) + a(134) = rconst(134)*v(36) + a(135) = rconst(135)*v(34)*v(61) + a(136) = rconst(136)*v(34)*v(62) + a(137) = rconst(137)*v(34)*v(46) + a(138) = rconst(138)*v(34)*v(61) + a(139) = rconst(139)*v(39)*v(60) + a(140) = rconst(140)*v(39)*v(55) + a(141) = rconst(141)*v(39)*v(50) + a(142) = rconst(142)*v(39)*v(39) + a(143) = rconst(143)*v(19)*v(61) + a(144) = rconst(144)*v(11)*v(61) + a(145) = rconst(145)*v(28)*v(60) + a(146) = rconst(146)*v(28)*v(55) + a(147) = rconst(147)*v(45)*v(63) + a(148) = rconst(148)*v(45)*v(62) + a(149) = rconst(149)*v(45)*v(55) + a(150) = rconst(150)*v(45)*v(61) + a(151) = rconst(151)*v(45)*v(54) + a(152) = rconst(152)*v(50) + a(153) = rconst(153)*v(50)*v(56) + a(154) = rconst(154)*v(50)*v(58) + a(155) = rconst(155)*v(50)*v(63) + a(156) = rconst(156)*v(50)*v(55) + a(157) = rconst(157)*v(50)*v(61) + a(158) = rconst(158)*v(50)*f(4) + a(159) = rconst(159)*v(27) + a(160) = rconst(160)*v(27)*v(60) + a(161) = rconst(161)*v(27)*v(55) + a(162) = rconst(162)*v(54) + a(163) = rconst(163)*v(54)*v(56) + a(164) = rconst(164)*v(54)*v(60) + a(165) = rconst(165)*v(54)*v(63) + a(166) = rconst(166)*v(49)*v(54) + +! aggregate function + a_var(1) = a(45)+a(162) + a_var(2) = 0.52*a(81)+0.22*a(83)+0.39*a(120)+0.46*a(124) + a_var(3) = 0.4*a(73)+0.09*a(83)+0.16*a(84) + a_var(4) = a(151)+a(157)+a(163)+a(164)+a(165)+a(166) + a_var(5) = 0.15*a(142) + a_var(6) = a(8)-a(10)-a(11)-a(12) + a_var(7) = -a(65) + a_var(8) = -a(45)+a(152) + a_var(9) = -a(47)+0.2*a(64) + a_var(10) = a(69)-a(70) + a_var(11) = 0.27*a(143)-a(144) + a_var(12) = -a(89) + a_var(13) = -a(9)-a(30)+a(31)+a(32)+a(147) + a_var(14) = -a(6)+a(39)-a(42)-a(43) + a_var(15) = -a(90) + a_var(16) = 0.4*a(92)+a(93)-a(94) + a_var(17) = -a(5)-a(28)+a(34)-a(36) + a_var(18) = 0.8*a(89)+0.45*a(90)-a(91) + a_var(19) = 0.965*a(138)-a(143) + a_var(20) = 1.06*a(83)+2.26*a(84)+a(85)+2.23*a(86)+1.98*a(98) & + +0.42*a(99)+1.98*a(101)+1.68*a(102)+a(104)+1.98 & + *a(106)+a(108)+1.25*a(114)+a(116)-a(118) + a_var(21) = -a(54)-a(56)+a(62) + a_var(22) = -a(81)-a(82) + a_var(23) = -a(48)+0.34*a(63)+0.03*a(83)+0.04*a(84) + a_var(24) = -a(3)+a(23)-a(26)+a(35)+a(164) + a_var(25) = -a(53)-a(55)+a(61)+a(149) + a_var(26) = 0.12*a(89)+0.05*a(90)-a(92)-a(93) + a_var(27) = a(158)-a(159)-a(160)-a(161) + a_var(28) = a(144)-a(145)-a(146) + a_var(29) = a(121)-a(127)-a(130)-a(133) + a_var(30) = -a(75)+1.1*a(90)-a(118)+1.86*a(125)+0.18*a(126)+1.6 & + *a(127)+2*a(130)+2*a(133) + a_var(31) = -a(44)+a(49)+a(50)+a(51)+a(52)+a(66)+a(78)+a(80) & + +0.24*a(81)+0.31*a(83)+0.3*a(84)+2*a(95)+a(96)+0.69 & + *a(97)+0.07*a(120)+0.33*a(122)+0.16*a(124)+0.64 & + *a(125)+0.59*a(128)+a(166) + a_var(32) = 0.95*a(91)+0.3*a(92)-a(95)-a(96)-a(97) + a_var(33) = -a(4)+a(24)-a(27)+0.3*a(41)+2*a(42)+a(52)+a(68) & + +a(80)+a(93)+0.07*a(125)+a(136)+a(148)+a(163) + a_var(34) = -a(135)-a(136)-a(137)-a(138) + a_var(35) = a(119)-a(126)-a(129)-a(132) + a_var(36) = 0.5*a(123)-a(128)-a(131)-a(134) + a_var(37) = -a(83)-a(85)-a(87) + a_var(38) = -a(119)-a(120)-a(121) + a_var(39) = a(135)+a(136)-a(139)-a(140)-a(141)-2*a(142) + a_var(40) = a(79)+a(82)+a(85)+a(86)+0.08*a(89)+0.5*a(90)+0.6 & + *a(92)+a(95)+0.03*a(97)+0.4*a(98)+0.4*a(101)+0.34 & + *a(102)-a(105)+0.4*a(106)-a(109)-a(113)+0.24*a(114) & + -a(117)+0.08*a(119)+0.2*a(120)+0.2*a(123)+0.07*a(124) & + +0.93*a(125) + a_var(41) = -a(76)-a(77)+0.07*a(84)+0.23*a(86)+0.74*a(98)+0.74 & + *a(101)+0.62*a(102)+0.74*a(106)+0.57*a(114)+0.15 & + *a(115)+0.03*a(122)+0.09*a(124)+0.63*a(128)+0.5 & + *a(134) + a_var(42) = -a(84)-a(86)-a(88) + a_var(43) = -a(78)-a(79)-a(80)+0.04*a(83)+0.07*a(84)+0.8*a(90) & + +0.2*a(97)+0.19*a(99)+0.15*a(115)+0.85*a(124)+0.34 & + *a(128) + a_var(44) = a(47)+0.5*a(56)-a(58)-a(60)-a(62)-a(64)+0.06*a(83) & + +0.05*a(84)+0.1*a(98)+0.1*a(101)+0.08*a(102)+0.1 & + *a(106)+0.06*a(114) + a_var(45) = 0.73*a(143)-a(147)-a(148)-a(149)-a(150)-a(151) + a_var(46) = a(1)+0.89*a(2)+a(7)+a(10)+a(11)-a(13)-a(14)-a(15) & + -a(16)-a(17)-a(137) + a_var(47) = a(87)+a(88)+a(100)-a(104)-a(108)-a(112)-a(116) + a_var(48) = a(54)+0.5*a(56)+a(58)+a(60)+0.8*a(64)+a(65)-a(66) & + -a(67)-a(68)+0.22*a(82)+0.47*a(83)+1.03*a(84)+a(85) & + +1.77*a(86)+0.03*a(97)+0.3*a(98)+0.04*a(99)+0.3 & + *a(101)+0.25*a(102)+0.5*a(104)+0.3*a(106)+0.5*a(108) & + +0.21*a(114)+0.5*a(116)+0.15*a(120)+0.07*a(122)+0.02 & + *a(124)+0.28*a(125)+0.8*a(127)+0.55*a(128)+a(133)+0.5 & + *a(134) + a_var(49) = a(48)-a(49)-a(50)-a(51)-a(52)+a(53)+0.3*a(55)+a(57) & + +a(59)+0.66*a(63)+a(81)+1.56*a(82)+0.57*a(83)+a(85) & + +a(95)+0.7*a(97)+a(103)+0.5*a(104)+a(107)+0.5*a(108) & + +0.7*a(115)+0.5*a(116)+0.6*a(120)+0.2*a(122)+0.15 & + *a(124)+0.28*a(125)+0.63*a(126)+0.25*a(128)+a(139)+2 & + *a(140)+a(141)+a(145)+2*a(146)+a(156)+a(161)-a(166) + a_var(50) = a(137)+0.035*a(138)+a(139)+a(140)+1.85*a(142)+a(145) & + +a(146)+a(147)+a(148)+a(149)+a(150)+a(151)-a(152) & + -a(153)-a(154)-a(155)-a(156)-a(157)-a(158)+a(159) + a_var(51) = 0.65*a(120)-a(122)-a(123)-a(124)-a(125)+0.91*a(126) & + +0.2*a(127)+a(132) + a_var(52) = a(67)+a(68)-a(69)+a(70)-a(71)-a(72)-a(73)-a(74) & + +a(76)+a(78)+a(79)+a(80)+0.13*a(83)+0.19*a(84)+a(95) & + +a(96)+0.62*a(97)+a(103)+a(107)+0.7*a(115)+0.2*a(120) & + +0.97*a(122)+0.5*a(123)+0.11*a(124)+0.07*a(125) + a_var(53) = -a(98)-a(99)+a(110)+a(111)+a(129)+a(131) + a_var(54) = a(141)-a(151)+a(153)+a(154)+a(155)+a(156)+a(160) & + +a(161)-a(162)-a(163)-a(164)-a(165)-a(166) + a_var(55) = a(46)+0.7*a(55)-a(57)-a(59)-a(61)-a(63)+a(66)+a(71) & + +a(72)+a(74)+a(76)+0.07*a(83)+0.1*a(84)+0.7*a(122) & + +0.05*a(124)+a(137)+0.035*a(138)-a(140)+0.73*a(143) & + -a(146)-a(149)+a(152)-a(156)-a(161)+a(162) + a_var(56) = -a(1)+0.89*a(2)+a(4)+a(5)+a(6)-a(15)-a(16)+a(17) & + +a(18)-a(19)-a(24)+a(25)+a(26)+a(28)+a(33)-a(34) & + -a(35)+a(36)+2*a(37)-a(39)+2*a(40)+0.7*a(41)+a(43) & + +a(57)+a(58)+a(59)+a(60)-a(69)+a(70)+a(71)+a(72)+0.95 & + *a(91)-a(94)+a(101)+0.84*a(102)+a(103)+1.5*a(104) & + +a(105)+a(106)+a(107)+1.5*a(108)+a(109)+0.5*a(116) & + +0.91*a(126)+1.2*a(127)+a(128)+a(139)+a(145)-a(153) & + +a(160)-a(163) + a_var(57) = 0.05*a(91)+a(94)-a(100)-a(101)+0.16*a(102)+0.5 & + *a(104)+0.5*a(108)+a(112)+0.5*a(116)+0.93*a(125)+0.09 & + *a(126)+0.8*a(127)+a(130)+a(133) + a_var(58) = -a(7)-a(8)+a(13)-a(14)-a(18)-a(19)-a(20)-a(21)+0.4 & + *a(73)-a(81)-a(83)-a(84)-a(97)-a(120)-a(124)-a(154) + a_var(59) = a(75)+0.03*a(83)+0.09*a(84)+0.77*a(99)-a(102)-a(106) & + -a(110)-a(114) + a_var(60) = a(1)+0.11*a(2)+a(3)+a(15)-a(17)-a(18)-a(23)-a(33) & + -a(37)+a(38)-a(57)-a(58)-a(71)-a(91)-a(102)-a(103) & + -a(104)-a(105)-a(126)-a(127)-a(128)-a(139)-a(145) & + +a(153)-a(160)-a(164) + a_var(61) = a(3)+a(4)+2*a(9)+2*a(12)-a(20)+a(21)-a(22)-a(23) & + -a(24)-a(25)-a(26)-a(27)-a(28)-a(29)-a(30)+a(33)+0.7 & + *a(41)-a(44)-a(45)-a(46)-a(47)-a(48)-a(51)+a(53) & + +a(54)-0.7*a(55)-0.5*a(56)-a(65)-a(67)-a(75)-a(77) & + -a(79)+0.12*a(81)-a(82)+0.33*a(83)+0.6*a(84)-a(85) & + -a(86)-a(89)-a(90)-a(92)-a(95)+0.08*a(97)+a(98)-0.77 & + *a(99)-a(100)-a(119)+0.27*a(120)-a(123)+0.27*a(124) & + -a(135)-a(138)-a(143)-a(144)-a(150)+a(155)-a(157) + a_var(62) = -a(2)+a(6)+a(16)+a(19)-a(25)+a(27)-a(37)-a(38)-a(39) & + -2*a(40)-a(41)+a(43)-a(52)-a(59)-a(60)-a(68)-a(72) & + -a(80)-a(87)-a(88)-a(93)-a(106)-a(107)-a(108)-a(109) & + -a(121)-a(125)-a(136)-a(148) + a_var(63) = a(5)+a(20)-a(21)+a(22)+a(25)-a(29)+a(30)-2*a(31)-2 & + *a(32)-a(33)-a(34)-a(35)+a(36)-a(41)+a(44)+a(45) & + +a(48)+2*a(49)+a(51)+a(52)+a(53)+a(54)+a(57)+a(58) & + +a(59)+a(60)-a(61)-a(62)+0.32*a(63)+0.6*a(64)+a(65) & + +a(66)-a(73)+a(78)+0.22*a(81)+a(82)+0.26*a(83)+0.22 & + *a(84)+a(85)+a(86)+0.2*a(89)+0.55*a(90)+0.95*a(91) & + +0.6*a(92)+2*a(95)+a(96)+0.76*a(97)+0.9*a(98)+0.9 & + *a(101)+0.76*a(102)+0.5*a(104)+0.9*a(106)+0.5*a(108) & + -a(110)-a(111)-a(112)-a(113)+0.54*a(114)+0.07*a(120) & + +0.33*a(122)+0.1*a(124)+0.93*a(125)+0.91*a(126)+0.8 & + *a(127)+a(128)-a(129)-a(130)-a(131)+0.965*a(138) & + +a(140)+0.27*a(143)+a(146)-a(147)-a(155)+a(156) & + +a(161)-a(165)+a(166) + a_var(64) = a(77)+0.11*a(84)-a(103)-a(107)-a(111)-a(115) + return + end subroutine cbmz_v02r06_dydt + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_jacob( nvardum, tdum, v, jvs, f, rconst ) +! +! computes jacobian for mechanism-version-regime = cbmz_v02r06 +! + use module_data_cbmz + implicit none + +! subr parameters +! nvardum = number of variable species [input] + integer nvardum +! tdum = time [input] + real tdum +! v = concentrations of variable species [input] + real v(nvar_r06_kpp) +! jvs = non-zero jacobian elements [output] + real jvs(lu_nonzero_v_r06_kpp) +! f = concentrations of fixed species [input] + real f(nfixed_kppmax) +! rconst = reaction rate constants [input] + real rconst(nreact_r06_kpp) + +! local variables +! b(i,j) = d[reaction_rate(i)] / d[species_conc(j)] + real b(nreact_r06_kpp,nvar_r06_kpp) + +! computation of b(i,j) = da(i)/dv(j) + b(1,56) = rconst(1) + b(2,62) = rconst(2) + b(3,24) = rconst(3) + b(4,33) = rconst(4) + b(5,17) = rconst(5) + b(6,14) = rconst(6) + b(7,58) = rconst(7) + b(8,58) = rconst(8) + b(9,13) = rconst(9) + b(10,6) = rconst(10)*f(4) + b(11,6) = rconst(11)*f(5) + b(12,6) = rconst(12)*f(2) + b(13,46) = rconst(13)*f(4) + b(14,46) = rconst(14)*v(58) + b(14,58) = rconst(14)*v(46) + b(15,46) = rconst(15)*v(56) + b(15,56) = rconst(15)*v(46) + b(16,46) = rconst(16)*v(56) + b(16,56) = rconst(16)*v(46) + b(17,46) = rconst(17)*v(60) + b(17,60) = rconst(17)*v(46) + b(18,58) = rconst(18)*v(60) + b(18,60) = rconst(18)*v(58) + b(19,56) = rconst(19)*v(58) + b(19,58) = rconst(19)*v(56) + b(20,58) = rconst(20)*v(61) + b(20,61) = rconst(20)*v(58) + b(21,58) = rconst(21)*v(63) + b(21,63) = rconst(21)*v(58) + b(22,61) = rconst(22)*f(3) + b(23,60) = rconst(23)*v(61) + b(23,61) = rconst(23)*v(60) + b(24,56) = rconst(24)*v(61) + b(24,61) = rconst(24)*v(56) + b(25,61) = rconst(25)*v(62) + b(25,62) = rconst(25)*v(61) + b(26,24) = rconst(26)*v(61) + b(26,61) = rconst(26)*v(24) + b(27,33) = rconst(27)*v(61) + b(27,61) = rconst(27)*v(33) + b(28,17) = rconst(28)*v(61) + b(28,61) = rconst(28)*v(17) + b(29,61) = rconst(29)*v(63) + b(29,63) = rconst(29)*v(61) + b(30,13) = rconst(30)*v(61) + b(30,61) = rconst(30)*v(13) + b(31,63) = rconst(31)*2*v(63) + b(32,63) = rconst(32)*2*v(63)*f(2) + b(33,60) = rconst(33)*v(63) + b(33,63) = rconst(33)*v(60) + b(34,56) = rconst(34)*v(63) + b(34,63) = rconst(34)*v(56) + b(35,56) = rconst(35)*v(63) + b(35,63) = rconst(35)*v(56) + b(36,17) = rconst(36) + b(37,60) = rconst(37)*v(62) + b(37,62) = rconst(37)*v(60) + b(38,56) = rconst(38)*v(62) + b(38,62) = rconst(38)*v(56) + b(39,56) = rconst(39)*v(62) + b(39,62) = rconst(39)*v(56) + b(40,62) = rconst(40)*2*v(62) + b(41,62) = rconst(41)*v(63) + b(41,63) = rconst(41)*v(62) + b(42,14) = rconst(42)*f(2) + b(43,14) = rconst(43) + b(44,31) = rconst(44)*v(61) + b(44,61) = rconst(44)*v(31) + b(45,8) = rconst(45)*v(61) + b(45,61) = rconst(45)*v(8) + b(46,61) = rconst(46)*f(1) + b(47,9) = rconst(47)*v(61) + b(47,61) = rconst(47)*v(9) + b(48,23) = rconst(48)*v(61) + b(48,61) = rconst(48)*v(23) + b(49,49) = rconst(49) + b(50,49) = rconst(50) + b(51,49) = rconst(51)*v(61) + b(51,61) = rconst(51)*v(49) + b(52,49) = rconst(52)*v(62) + b(52,62) = rconst(52)*v(49) + b(53,25) = rconst(53) + b(54,21) = rconst(54) + b(55,25) = rconst(55)*v(61) + b(55,61) = rconst(55)*v(25) + b(56,21) = rconst(56)*v(61) + b(56,61) = rconst(56)*v(21) + b(57,55) = rconst(57)*v(60) + b(57,60) = rconst(57)*v(55) + b(58,44) = rconst(58)*v(60) + b(58,60) = rconst(58)*v(44) + b(59,55) = rconst(59)*v(62) + b(59,62) = rconst(59)*v(55) + b(60,44) = rconst(60)*v(62) + b(60,62) = rconst(60)*v(44) + b(61,55) = rconst(61)*v(63) + b(61,63) = rconst(61)*v(55) + b(62,44) = rconst(62)*v(63) + b(62,63) = rconst(62)*v(44) + b(63,55) = rconst(63) + b(64,44) = rconst(64) + b(65,7) = rconst(65)*v(61) + b(65,61) = rconst(65)*v(7) + b(66,48) = rconst(66) + b(67,48) = rconst(67)*v(61) + b(67,61) = rconst(67)*v(48) + b(68,48) = rconst(68)*v(62) + b(68,62) = rconst(68)*v(48) + b(69,52) = rconst(69)*v(56) + b(69,56) = rconst(69)*v(52) + b(70,10) = rconst(70) + b(71,52) = rconst(71)*v(60) + b(71,60) = rconst(71)*v(52) + b(72,52) = rconst(72)*v(62) + b(72,62) = rconst(72)*v(52) + b(73,52) = rconst(73)*v(63) + b(73,63) = rconst(73)*v(52) + b(74,52) = rconst(74) + b(75,30) = rconst(75)*v(61) + b(75,61) = rconst(75)*v(30) + b(76,41) = rconst(76) + b(77,41) = rconst(77)*v(61) + b(77,61) = rconst(77)*v(41) + b(78,43) = rconst(78) + b(79,43) = rconst(79)*v(61) + b(79,61) = rconst(79)*v(43) + b(80,43) = rconst(80)*v(62) + b(80,62) = rconst(80)*v(43) + b(81,22) = rconst(81)*v(58) + b(81,58) = rconst(81)*v(22) + b(82,22) = rconst(82)*v(61) + b(82,61) = rconst(82)*v(22) + b(83,37) = rconst(83)*v(58) + b(83,58) = rconst(83)*v(37) + b(84,42) = rconst(84)*v(58) + b(84,58) = rconst(84)*v(42) + b(85,37) = rconst(85)*v(61) + b(85,61) = rconst(85)*v(37) + b(86,42) = rconst(86)*v(61) + b(86,61) = rconst(86)*v(42) + b(87,37) = rconst(87)*v(62) + b(87,62) = rconst(87)*v(37) + b(88,42) = rconst(88)*v(62) + b(88,62) = rconst(88)*v(42) + b(89,12) = rconst(89)*v(61) + b(89,61) = rconst(89)*v(12) + b(90,15) = rconst(90)*v(61) + b(90,61) = rconst(90)*v(15) + b(91,18) = rconst(91)*v(60) + b(91,60) = rconst(91)*v(18) + b(92,26) = rconst(92)*v(61) + b(92,61) = rconst(92)*v(26) + b(93,26) = rconst(93)*v(62) + b(93,62) = rconst(93)*v(26) + b(94,16) = rconst(94)*v(56) + b(94,56) = rconst(94)*v(16) + b(95,32) = rconst(95)*v(61) + b(95,61) = rconst(95)*v(32) + b(96,32) = rconst(96) + b(97,32) = rconst(97)*v(58) + b(97,58) = rconst(97)*v(32) + b(98,53) = rconst(98) + b(99,53) = rconst(99)*v(61) + b(99,61) = rconst(99)*v(53) + b(100,57) = rconst(100)*v(61) + b(100,61) = rconst(100)*v(57) + b(101,57) = rconst(101) + b(102,59) = rconst(102)*v(60) + b(102,60) = rconst(102)*v(59) + b(103,60) = rconst(103)*v(64) + b(103,64) = rconst(103)*v(60) + b(104,47) = rconst(104)*v(60) + b(104,60) = rconst(104)*v(47) + b(105,40) = rconst(105)*v(60) + b(105,60) = rconst(105)*v(40) + b(106,59) = rconst(106)*v(62) + b(106,62) = rconst(106)*v(59) + b(107,62) = rconst(107)*v(64) + b(107,64) = rconst(107)*v(62) + b(108,47) = rconst(108)*v(62) + b(108,62) = rconst(108)*v(47) + b(109,40) = rconst(109)*v(62) + b(109,62) = rconst(109)*v(40) + b(110,59) = rconst(110)*v(63) + b(110,63) = rconst(110)*v(59) + b(111,63) = rconst(111)*v(64) + b(111,64) = rconst(111)*v(63) + b(112,47) = rconst(112)*v(63) + b(112,63) = rconst(112)*v(47) + b(113,40) = rconst(113)*v(63) + b(113,63) = rconst(113)*v(40) + b(114,59) = rconst(114) + b(115,64) = rconst(115) + b(116,47) = rconst(116) + b(117,40) = rconst(117) + b(118,20) = rconst(118)*v(30) + b(118,30) = rconst(118)*v(20) + b(119,38) = rconst(119)*v(61) + b(119,61) = rconst(119)*v(38) + b(120,38) = rconst(120)*v(58) + b(120,58) = rconst(120)*v(38) + b(121,38) = rconst(121)*v(62) + b(121,62) = rconst(121)*v(38) + b(122,51) = rconst(122) + b(123,51) = rconst(123)*v(61) + b(123,61) = rconst(123)*v(51) + b(124,51) = rconst(124)*v(58) + b(124,58) = rconst(124)*v(51) + b(125,51) = rconst(125)*v(62) + b(125,62) = rconst(125)*v(51) + b(126,35) = rconst(126)*v(60) + b(126,60) = rconst(126)*v(35) + b(127,29) = rconst(127)*v(60) + b(127,60) = rconst(127)*v(29) + b(128,36) = rconst(128)*v(60) + b(128,60) = rconst(128)*v(36) + b(129,35) = rconst(129)*v(63) + b(129,63) = rconst(129)*v(35) + b(130,29) = rconst(130)*v(63) + b(130,63) = rconst(130)*v(29) + b(131,36) = rconst(131)*v(63) + b(131,63) = rconst(131)*v(36) + b(132,35) = rconst(132) + b(133,29) = rconst(133) + b(134,36) = rconst(134) + b(135,34) = rconst(135)*v(61) + b(135,61) = rconst(135)*v(34) + b(136,34) = rconst(136)*v(62) + b(136,62) = rconst(136)*v(34) + b(137,34) = rconst(137)*v(46) + b(137,46) = rconst(137)*v(34) + b(138,34) = rconst(138)*v(61) + b(138,61) = rconst(138)*v(34) + b(139,39) = rconst(139)*v(60) + b(139,60) = rconst(139)*v(39) + b(140,39) = rconst(140)*v(55) + b(140,55) = rconst(140)*v(39) + b(141,39) = rconst(141)*v(50) + b(141,50) = rconst(141)*v(39) + b(142,39) = rconst(142)*2*v(39) + b(143,19) = rconst(143)*v(61) + b(143,61) = rconst(143)*v(19) + b(144,11) = rconst(144)*v(61) + b(144,61) = rconst(144)*v(11) + b(145,28) = rconst(145)*v(60) + b(145,60) = rconst(145)*v(28) + b(146,28) = rconst(146)*v(55) + b(146,55) = rconst(146)*v(28) + b(147,45) = rconst(147)*v(63) + b(147,63) = rconst(147)*v(45) + b(148,45) = rconst(148)*v(62) + b(148,62) = rconst(148)*v(45) + b(149,45) = rconst(149)*v(55) + b(149,55) = rconst(149)*v(45) + b(150,45) = rconst(150)*v(61) + b(150,61) = rconst(150)*v(45) + b(151,45) = rconst(151)*v(54) + b(151,54) = rconst(151)*v(45) + b(152,50) = rconst(152) + b(153,50) = rconst(153)*v(56) + b(153,56) = rconst(153)*v(50) + b(154,50) = rconst(154)*v(58) + b(154,58) = rconst(154)*v(50) + b(155,50) = rconst(155)*v(63) + b(155,63) = rconst(155)*v(50) + b(156,50) = rconst(156)*v(55) + b(156,55) = rconst(156)*v(50) + b(157,50) = rconst(157)*v(61) + b(157,61) = rconst(157)*v(50) + b(158,50) = rconst(158)*f(4) + b(159,27) = rconst(159) + b(160,27) = rconst(160)*v(60) + b(160,60) = rconst(160)*v(27) + b(161,27) = rconst(161)*v(55) + b(161,55) = rconst(161)*v(27) + b(162,54) = rconst(162) + b(163,54) = rconst(163)*v(56) + b(163,56) = rconst(163)*v(54) + b(164,54) = rconst(164)*v(60) + b(164,60) = rconst(164)*v(54) + b(165,54) = rconst(165)*v(63) + b(165,63) = rconst(165)*v(54) + b(166,49) = rconst(166)*v(54) + b(166,54) = rconst(166)*v(49) + +! construct the jacobian terms from b's + jvs(1) = 0 + jvs(2) = b(45,8) + jvs(3) = b(162,54) + jvs(4) = b(45,61) + jvs(5) = 0 + jvs(6) = 0.52*b(81,22) + jvs(7) = 0.22*b(83,37) + jvs(8) = 0.39*b(120,38) + jvs(9) = 0.46*b(124,51) + jvs(10) = 0.52*b(81,58)+0.22*b(83,58)+0.39*b(120,58)+0.46 & + *b(124,58) + jvs(11) = 0 + jvs(12) = 0.09*b(83,37) + jvs(13) = 0.16*b(84,42) + jvs(14) = 0.4*b(73,52) + jvs(15) = 0.09*b(83,58)+0.16*b(84,58) + jvs(16) = 0.4*b(73,63) + jvs(17) = 0 + jvs(18) = b(151,45) + jvs(19) = b(166,49) + jvs(20) = b(157,50) + jvs(21) = b(151,54)+b(163,54)+b(164,54)+b(165,54)+b(166,54) + jvs(22) = b(163,56) + jvs(23) = b(164,60) + jvs(24) = b(157,61) + jvs(25) = b(165,63) + jvs(26) = 0 + jvs(27) = 0.15*b(142,39) + jvs(28) = -b(10,6)-b(11,6)-b(12,6) + jvs(29) = b(8,58) + jvs(30) = -b(65,7) + jvs(31) = -b(65,61) + jvs(32) = -b(45,8) + jvs(33) = b(152,50) + jvs(34) = -b(45,61) + jvs(35) = -b(47,9) + jvs(36) = 0.2*b(64,44) + jvs(37) = -b(47,61) + jvs(38) = -b(70,10) + jvs(39) = b(69,52) + jvs(40) = b(69,56) + jvs(41) = -b(144,11) + jvs(42) = 0.27*b(143,19) + jvs(43) = 0.27*b(143,61)-b(144,61) + jvs(44) = -b(89,12) + jvs(45) = -b(89,61) + jvs(46) = -b(9,13)-b(30,13) + jvs(47) = b(147,45) + jvs(48) = -b(30,61) + jvs(49) = b(31,63)+b(32,63)+b(147,63) + jvs(50) = -b(6,14)-b(42,14)-b(43,14) + jvs(51) = b(39,56) + jvs(52) = b(39,62) + jvs(53) = -b(90,15) + jvs(54) = -b(90,61) + jvs(55) = -b(94,16) + jvs(56) = 0.4*b(92,26)+b(93,26) + jvs(57) = -b(94,56) + jvs(58) = 0.4*b(92,61) + jvs(59) = b(93,62) + jvs(60) = -b(5,17)-b(28,17)-b(36,17) + jvs(61) = b(34,56) + jvs(62) = -b(28,61) + jvs(63) = b(34,63) + jvs(64) = 0.8*b(89,12) + jvs(65) = 0.45*b(90,15) + jvs(66) = -b(91,18) + jvs(67) = -b(91,60) + jvs(68) = 0.8*b(89,61)+0.45*b(90,61) + jvs(69) = -b(143,19) + jvs(70) = 0.965*b(138,34) + jvs(71) = 0.965*b(138,61)-b(143,61) + jvs(72) = -b(118,20) + jvs(73) = -b(118,30) + jvs(74) = 1.06*b(83,37)+b(85,37) + jvs(75) = 2.26*b(84,42)+2.23*b(86,42) + jvs(76) = b(104,47)+b(108,47)+b(116,47) + jvs(77) = 1.98*b(98,53)+0.42*b(99,53) + jvs(78) = 1.98*b(101,57) + jvs(79) = 1.06*b(83,58)+2.26*b(84,58) + jvs(80) = 1.68*b(102,59)+1.98*b(106,59)+1.25*b(114,59) + jvs(81) = 1.68*b(102,60)+b(104,60) + jvs(82) = b(85,61)+2.23*b(86,61)+0.42*b(99,61) + jvs(83) = 1.98*b(106,62)+b(108,62) + jvs(84) = -b(54,21)-b(56,21) + jvs(85) = b(62,44) + jvs(86) = -b(56,61) + jvs(87) = b(62,63) + jvs(88) = -b(81,22)-b(82,22) + jvs(89) = -b(81,58) + jvs(90) = -b(82,61) + jvs(91) = -b(48,23) + jvs(92) = 0.03*b(83,37) + jvs(93) = 0.04*b(84,42) + jvs(94) = 0.34*b(63,55) + jvs(95) = 0.03*b(83,58)+0.04*b(84,58) + jvs(96) = -b(48,61) + jvs(97) = -b(3,24)-b(26,24) + jvs(98) = b(164,54) + jvs(99) = b(35,56) + jvs(100) = b(23,60)+b(164,60) + jvs(101) = b(23,61)-b(26,61) + jvs(102) = b(35,63) + jvs(103) = -b(53,25)-b(55,25) + jvs(104) = b(149,45) + jvs(105) = b(61,55)+b(149,55) + jvs(106) = -b(55,61) + jvs(107) = b(61,63) + jvs(108) = 0.12*b(89,12) + jvs(109) = 0.05*b(90,15) + jvs(110) = -b(92,26)-b(93,26) + jvs(111) = 0.12*b(89,61)+0.05*b(90,61)-b(92,61) + jvs(112) = -b(93,62) + jvs(113) = -b(159,27)-b(160,27)-b(161,27) + jvs(114) = b(158,50) + jvs(115) = -b(161,55) + jvs(116) = -b(160,60) + jvs(117) = b(144,11) + jvs(118) = 0 + jvs(119) = -b(145,28)-b(146,28) + jvs(120) = 0 + jvs(121) = -b(146,55) + jvs(122) = -b(145,60) + jvs(123) = b(144,61) + jvs(124) = -b(127,29)-b(130,29)-b(133,29) + jvs(125) = b(121,38) + jvs(126) = -b(127,60) + jvs(127) = b(121,62) + jvs(128) = -b(130,63) + jvs(129) = 1.1*b(90,15) + jvs(130) = -b(118,20) + jvs(131) = 1.6*b(127,29)+2*b(130,29)+2*b(133,29) + jvs(132) = -b(75,30)-b(118,30) + jvs(133) = 0.18*b(126,35) + jvs(134) = 0 + jvs(135) = 0 + jvs(136) = 0 + jvs(137) = 0 + jvs(138) = 1.86*b(125,51) + jvs(139) = 0 + jvs(140) = 0 + jvs(141) = 0 + jvs(142) = 0 + jvs(143) = 0.18*b(126,60)+1.6*b(127,60) + jvs(144) = -b(75,61)+1.1*b(90,61) + jvs(145) = 1.86*b(125,62) + jvs(146) = 2*b(130,63) + jvs(147) = 0.24*b(81,22) + jvs(148) = -b(44,31) + jvs(149) = 2*b(95,32)+b(96,32)+0.69*b(97,32) + jvs(150) = 0.59*b(128,36) + jvs(151) = 0.31*b(83,37) + jvs(152) = 0.07*b(120,38) + jvs(153) = 0.3*b(84,42) + jvs(154) = b(78,43)+b(80,43) + jvs(155) = b(66,48) + jvs(156) = b(49,49)+b(50,49)+b(51,49)+b(52,49)+b(166,49) + jvs(157) = 0.33*b(122,51)+0.16*b(124,51)+0.64*b(125,51) + jvs(158) = b(166,54) + jvs(159) = 0.24*b(81,58)+0.31*b(83,58)+0.3*b(84,58)+0.69 & + *b(97,58)+0.07*b(120,58)+0.16*b(124,58) + jvs(160) = 0.59*b(128,60) + jvs(161) = -b(44,61)+b(51,61)+2*b(95,61) + jvs(162) = b(52,62)+b(80,62)+0.64*b(125,62) + jvs(163) = 0.95*b(91,18) + jvs(164) = 0.3*b(92,26) + jvs(165) = -b(95,32)-b(96,32)-b(97,32) + jvs(166) = -b(97,58) + jvs(167) = 0.95*b(91,60) + jvs(168) = 0.3*b(92,61)-b(95,61) + jvs(169) = 0 + jvs(170) = 2*b(42,14) + jvs(171) = b(93,26) + jvs(172) = -b(4,33)-b(27,33) + jvs(173) = b(136,34) + jvs(174) = b(80,43) + jvs(175) = b(148,45) + jvs(176) = b(68,48) + jvs(177) = b(52,49) + jvs(178) = 0.07*b(125,51) + jvs(179) = b(163,54) + jvs(180) = b(24,56)+b(163,56) + jvs(181) = b(24,61)-b(27,61) + jvs(182) = 0.3*b(41,62)+b(52,62)+b(68,62)+b(80,62)+b(93,62)+0.07 & + *b(125,62)+b(136,62)+b(148,62) + jvs(183) = 0.3*b(41,63) + jvs(184) = -b(135,34)-b(136,34)-b(137,34)-b(138,34) + jvs(185) = -b(137,46) + jvs(186) = -b(135,61)-b(138,61) + jvs(187) = -b(136,62) + jvs(188) = -b(126,35)-b(129,35)-b(132,35) + jvs(189) = b(119,38) + jvs(190) = -b(126,60) + jvs(191) = b(119,61) + jvs(192) = -b(129,63) + jvs(193) = -b(128,36)-b(131,36)-b(134,36) + jvs(194) = 0.5*b(123,51) + jvs(195) = -b(128,60) + jvs(196) = 0.5*b(123,61) + jvs(197) = -b(131,63) + jvs(198) = -b(83,37)-b(85,37)-b(87,37) + jvs(199) = -b(83,58) + jvs(200) = -b(85,61) + jvs(201) = -b(87,62) + jvs(202) = -b(119,38)-b(120,38)-b(121,38) + jvs(203) = -b(120,58) + jvs(204) = -b(119,61) + jvs(205) = -b(121,62) + jvs(206) = b(135,34)+b(136,34) + jvs(207) = -b(139,39)-b(140,39)-b(141,39)-2*b(142,39) + jvs(208) = 0 + jvs(209) = -b(141,50) + jvs(210) = -b(140,55) + jvs(211) = -b(139,60) + jvs(212) = b(135,61) + jvs(213) = b(136,62) + jvs(214) = 0.08*b(89,12) + jvs(215) = 0.5*b(90,15) + jvs(216) = b(82,22) + jvs(217) = 0.6*b(92,26) + jvs(218) = b(95,32)+0.03*b(97,32) + jvs(219) = b(85,37) + jvs(220) = 0.08*b(119,38)+0.2*b(120,38) + jvs(221) = -b(105,40)-b(109,40)-b(113,40)-b(117,40) + jvs(222) = b(86,42) + jvs(223) = b(79,43) + jvs(224) = 0.2*b(123,51)+0.07*b(124,51)+0.93*b(125,51) + jvs(225) = 0.4*b(98,53) + jvs(226) = 0.4*b(101,57) + jvs(227) = 0.03*b(97,58)+0.2*b(120,58)+0.07*b(124,58) + jvs(228) = 0.34*b(102,59)+0.4*b(106,59)+0.24*b(114,59) + jvs(229) = 0.34*b(102,60)-b(105,60) + jvs(230) = b(79,61)+b(82,61)+b(85,61)+b(86,61)+0.08*b(89,61)+0.5 & + *b(90,61)+0.6*b(92,61)+b(95,61)+0.08*b(119,61)+0.2 & + *b(123,61) + jvs(231) = 0.4*b(106,62)-b(109,62)+0.93*b(125,62) + jvs(232) = -b(113,63) + jvs(233) = 0.63*b(128,36)+0.5*b(134,36) + jvs(234) = -b(76,41)-b(77,41) + jvs(235) = 0.07*b(84,42)+0.23*b(86,42) + jvs(236) = 0.03*b(122,51)+0.09*b(124,51) + jvs(237) = 0.74*b(98,53) + jvs(238) = 0.74*b(101,57) + jvs(239) = 0.07*b(84,58)+0.09*b(124,58) + jvs(240) = 0.62*b(102,59)+0.74*b(106,59)+0.57*b(114,59) + jvs(241) = 0.62*b(102,60)+0.63*b(128,60) + jvs(242) = -b(77,61)+0.23*b(86,61) + jvs(243) = 0.74*b(106,62) + jvs(244) = 0 + jvs(245) = 0.15*b(115,64) + jvs(246) = -b(84,42)-b(86,42)-b(88,42) + jvs(247) = -b(84,58) + jvs(248) = -b(86,61) + jvs(249) = -b(88,62) + jvs(250) = 0.8*b(90,15) + jvs(251) = 0.2*b(97,32) + jvs(252) = 0.34*b(128,36) + jvs(253) = 0.04*b(83,37) + jvs(254) = 0.07*b(84,42) + jvs(255) = -b(78,43)-b(79,43)-b(80,43) + jvs(256) = 0.85*b(124,51) + jvs(257) = 0.19*b(99,53) + jvs(258) = 0.04*b(83,58)+0.07*b(84,58)+0.2*b(97,58)+0.85 & + *b(124,58) + jvs(259) = 0.34*b(128,60) + jvs(260) = -b(79,61)+0.8*b(90,61)+0.19*b(99,61) + jvs(261) = -b(80,62) + jvs(262) = 0 + jvs(263) = 0.15*b(115,64) + jvs(264) = b(47,9) + jvs(265) = 0.5*b(56,21) + jvs(266) = 0.06*b(83,37) + jvs(267) = 0.05*b(84,42) + jvs(268) = -b(58,44)-b(60,44)-b(62,44)-b(64,44) + jvs(269) = 0.1*b(98,53) + jvs(270) = 0.1*b(101,57) + jvs(271) = 0.06*b(83,58)+0.05*b(84,58) + jvs(272) = 0.08*b(102,59)+0.1*b(106,59)+0.06*b(114,59) + jvs(273) = -b(58,60)+0.08*b(102,60) + jvs(274) = b(47,61)+0.5*b(56,61) + jvs(275) = -b(60,62)+0.1*b(106,62) + jvs(276) = -b(62,63) + jvs(277) = 0.73*b(143,19) + jvs(278) = 0 + jvs(279) = -b(147,45)-b(148,45)-b(149,45)-b(150,45)-b(151,45) + jvs(280) = 0 + jvs(281) = -b(151,54) + jvs(282) = -b(149,55) + jvs(283) = 0.73*b(143,61)-b(150,61) + jvs(284) = -b(148,62) + jvs(285) = -b(147,63) + jvs(286) = b(10,6)+b(11,6) + jvs(287) = -b(137,34) + jvs(288) = -b(13,46)-b(14,46)-b(15,46)-b(16,46)-b(17,46) & + -b(137,46) + jvs(289) = b(1,56)-b(15,56)-b(16,56) + jvs(290) = b(7,58)-b(14,58) + jvs(291) = -b(17,60) + jvs(292) = 0 + jvs(293) = 0.89*b(2,62) + jvs(294) = b(87,37) + jvs(295) = b(88,42) + jvs(296) = -b(104,47)-b(108,47)-b(112,47)-b(116,47) + jvs(297) = b(100,57) + jvs(298) = 0 + jvs(299) = -b(104,60) + jvs(300) = b(100,61) + jvs(301) = b(87,62)+b(88,62)-b(108,62) + jvs(302) = -b(112,63) + jvs(303) = b(65,7) + jvs(304) = b(54,21)+0.5*b(56,21) + jvs(305) = 0.22*b(82,22) + jvs(306) = 0.8*b(127,29)+b(133,29) + jvs(307) = 0.03*b(97,32) + jvs(308) = 0.55*b(128,36)+0.5*b(134,36) + jvs(309) = 0.47*b(83,37)+b(85,37) + jvs(310) = 0.15*b(120,38) + jvs(311) = 1.03*b(84,42)+1.77*b(86,42) + jvs(312) = b(58,44)+b(60,44)+0.8*b(64,44) + jvs(313) = 0.5*b(104,47)+0.5*b(108,47)+0.5*b(116,47) + jvs(314) = -b(66,48)-b(67,48)-b(68,48) + jvs(315) = 0.07*b(122,51)+0.02*b(124,51)+0.28*b(125,51) + jvs(316) = 0.3*b(98,53)+0.04*b(99,53) + jvs(317) = 0.3*b(101,57) + jvs(318) = 0.47*b(83,58)+1.03*b(84,58)+0.03*b(97,58)+0.15 & + *b(120,58)+0.02*b(124,58) + jvs(319) = 0.25*b(102,59)+0.3*b(106,59)+0.21*b(114,59) + jvs(320) = b(58,60)+0.25*b(102,60)+0.5*b(104,60)+0.8*b(127,60) & + +0.55*b(128,60) + jvs(321) = 0.5*b(56,61)+b(65,61)-b(67,61)+0.22*b(82,61)+b(85,61) & + +1.77*b(86,61)+0.04*b(99,61) + jvs(322) = b(60,62)-b(68,62)+0.3*b(106,62)+0.5*b(108,62)+0.28 & + *b(125,62) + jvs(323) = 0 + jvs(324) = b(81,22)+1.56*b(82,22) + jvs(325) = b(48,23) + jvs(326) = b(53,25)+0.3*b(55,25) + jvs(327) = b(161,27) + jvs(328) = b(145,28)+2*b(146,28) + jvs(329) = b(95,32)+0.7*b(97,32) + jvs(330) = 0 + jvs(331) = 0.63*b(126,35) + jvs(332) = 0.25*b(128,36) + jvs(333) = 0.57*b(83,37)+b(85,37) + jvs(334) = 0.6*b(120,38) + jvs(335) = b(139,39)+2*b(140,39)+b(141,39) + jvs(336) = 0 + jvs(337) = 0 + jvs(338) = 0 + jvs(339) = 0.5*b(104,47)+0.5*b(108,47)+0.5*b(116,47) + jvs(340) = -b(49,49)-b(50,49)-b(51,49)-b(52,49)-b(166,49) + jvs(341) = b(141,50)+b(156,50) + jvs(342) = 0.2*b(122,51)+0.15*b(124,51)+0.28*b(125,51) + jvs(343) = -b(166,54) + jvs(344) = b(57,55)+b(59,55)+0.66*b(63,55)+2*b(140,55)+2 & + *b(146,55)+b(156,55)+b(161,55) + jvs(345) = 0 + jvs(346) = 0 + jvs(347) = b(81,58)+0.57*b(83,58)+0.7*b(97,58)+0.6*b(120,58) & + +0.15*b(124,58) + jvs(348) = b(57,60)+b(103,60)+0.5*b(104,60)+0.63*b(126,60)+0.25 & + *b(128,60)+b(139,60)+b(145,60) + jvs(349) = b(48,61)-b(51,61)+0.3*b(55,61)+1.56*b(82,61)+b(85,61) & + +b(95,61) + jvs(350) = -b(52,62)+b(59,62)+b(107,62)+0.5*b(108,62)+0.28 & + *b(125,62) + jvs(351) = 0 + jvs(352) = b(103,64)+b(107,64)+0.7*b(115,64) + jvs(353) = b(159,27) + jvs(354) = b(145,28)+b(146,28) + jvs(355) = b(137,34)+0.035*b(138,34) + jvs(356) = b(139,39)+b(140,39)+1.85*b(142,39) + jvs(357) = b(147,45)+b(148,45)+b(149,45)+b(150,45)+b(151,45) + jvs(358) = b(137,46) + jvs(359) = -b(152,50)-b(153,50)-b(154,50)-b(155,50)-b(156,50) & + -b(157,50)-b(158,50) + jvs(360) = b(151,54) + jvs(361) = b(140,55)+b(146,55)+b(149,55)-b(156,55) + jvs(362) = -b(153,56) + jvs(363) = -b(154,58) + jvs(364) = b(139,60)+b(145,60) + jvs(365) = 0.035*b(138,61)+b(150,61)-b(157,61) + jvs(366) = b(148,62) + jvs(367) = b(147,63)-b(155,63) + jvs(368) = 0.2*b(127,29) + jvs(369) = 0.91*b(126,35)+b(132,35) + jvs(370) = 0.65*b(120,38) + jvs(371) = -b(122,51)-b(123,51)-b(124,51)-b(125,51) + jvs(372) = 0.65*b(120,58)-b(124,58) + jvs(373) = 0.91*b(126,60)+0.2*b(127,60) + jvs(374) = -b(123,61) + jvs(375) = -b(125,62) + jvs(376) = 0 + jvs(377) = b(70,10) + jvs(378) = b(95,32)+b(96,32)+0.62*b(97,32) + jvs(379) = 0.13*b(83,37) + jvs(380) = 0.2*b(120,38) + jvs(381) = b(76,41) + jvs(382) = 0.19*b(84,42) + jvs(383) = b(78,43)+b(79,43)+b(80,43) + jvs(384) = b(67,48)+b(68,48) + jvs(385) = 0.97*b(122,51)+0.5*b(123,51)+0.11*b(124,51)+0.07 & + *b(125,51) + jvs(386) = -b(69,52)-b(71,52)-b(72,52)-b(73,52)-b(74,52) + jvs(387) = 0 + jvs(388) = -b(69,56) + jvs(389) = 0 + jvs(390) = 0.13*b(83,58)+0.19*b(84,58)+0.62*b(97,58)+0.2 & + *b(120,58)+0.11*b(124,58) + jvs(391) = 0 + jvs(392) = -b(71,60)+b(103,60) + jvs(393) = b(67,61)+b(79,61)+b(95,61)+0.5*b(123,61) + jvs(394) = b(68,62)-b(72,62)+b(80,62)+b(107,62)+0.07*b(125,62) + jvs(395) = -b(73,63) + jvs(396) = b(103,64)+b(107,64)+0.7*b(115,64) + jvs(397) = b(129,35) + jvs(398) = b(131,36) + jvs(399) = 0 + jvs(400) = 0 + jvs(401) = -b(98,53)-b(99,53) + jvs(402) = 0 + jvs(403) = b(110,59) + jvs(404) = 0 + jvs(405) = -b(99,61) + jvs(406) = 0 + jvs(407) = b(110,63)+b(111,63)+b(129,63)+b(131,63) + jvs(408) = b(111,64) + jvs(409) = b(160,27)+b(161,27) + jvs(410) = b(141,39) + jvs(411) = -b(151,45) + jvs(412) = 0 + jvs(413) = -b(166,49) + jvs(414) = b(141,50)+b(153,50)+b(154,50)+b(155,50)+b(156,50) + jvs(415) = 0 + jvs(416) = -b(151,54)-b(162,54)-b(163,54)-b(164,54)-b(165,54) & + -b(166,54) + jvs(417) = b(156,55)+b(161,55) + jvs(418) = b(153,56)-b(163,56) + jvs(419) = 0 + jvs(420) = b(154,58) + jvs(421) = b(160,60)-b(164,60) + jvs(422) = 0 + jvs(423) = 0 + jvs(424) = b(155,63)-b(165,63) + jvs(425) = 0 + jvs(426) = 0.73*b(143,19) + jvs(427) = 0.7*b(55,25) + jvs(428) = -b(161,27) + jvs(429) = -b(146,28) + jvs(430) = b(137,34)+0.035*b(138,34) + jvs(431) = 0.07*b(83,37) + jvs(432) = -b(140,39) + jvs(433) = b(76,41) + jvs(434) = 0.1*b(84,42) + jvs(435) = -b(149,45) + jvs(436) = b(137,46) + jvs(437) = b(66,48) + jvs(438) = b(152,50)-b(156,50) + jvs(439) = 0.7*b(122,51)+0.05*b(124,51) + jvs(440) = b(71,52)+b(72,52)+b(74,52) + jvs(441) = 0 + jvs(442) = b(162,54) + jvs(443) = -b(57,55)-b(59,55)-b(61,55)-b(63,55)-b(140,55) & + -b(146,55)-b(149,55)-b(156,55)-b(161,55) + jvs(444) = 0 + jvs(445) = 0 + jvs(446) = 0.07*b(83,58)+0.1*b(84,58)+0.05*b(124,58) + jvs(447) = 0 + jvs(448) = -b(57,60)+b(71,60) + jvs(449) = b(46,61)+0.7*b(55,61)+0.035*b(138,61)+0.73*b(143,61) + jvs(450) = -b(59,62)+b(72,62) + jvs(451) = -b(61,63) + jvs(452) = 0 + jvs(453) = b(70,10) + jvs(454) = b(6,14)+b(43,14) + jvs(455) = -b(94,16) + jvs(456) = b(5,17)+b(28,17)+b(36,17) + jvs(457) = 0.95*b(91,18) + jvs(458) = b(26,24) + jvs(459) = 0 + jvs(460) = b(160,27) + jvs(461) = b(145,28) + jvs(462) = 1.2*b(127,29) + jvs(463) = b(4,33) + jvs(464) = 0 + jvs(465) = 0.91*b(126,35) + jvs(466) = b(128,36) + jvs(467) = 0 + jvs(468) = b(139,39) + jvs(469) = b(105,40)+b(109,40) + jvs(470) = 0 + jvs(471) = 0 + jvs(472) = b(58,44)+b(60,44) + jvs(473) = 0 + jvs(474) = -b(15,46)-b(16,46)+b(17,46) + jvs(475) = 1.5*b(104,47)+1.5*b(108,47)+0.5*b(116,47) + jvs(476) = 0 + jvs(477) = 0 + jvs(478) = -b(153,50) + jvs(479) = 0 + jvs(480) = -b(69,52)+b(71,52)+b(72,52) + jvs(481) = 0 + jvs(482) = -b(163,54) + jvs(483) = b(57,55)+b(59,55) + jvs(484) = -b(1,56)-b(15,56)-b(16,56)-b(19,56)-b(24,56)-b(34,56) & + -b(35,56)-b(39,56)-b(69,56)-b(94,56)-b(153,56) & + -b(163,56) + jvs(485) = b(101,57) + jvs(486) = b(18,58)-b(19,58) + jvs(487) = 0.84*b(102,59)+b(106,59) + jvs(488) = b(17,60)+b(18,60)+b(33,60)+2*b(37,60)+b(57,60) & + +b(58,60)+b(71,60)+0.95*b(91,60)+0.84*b(102,60) & + +b(103,60)+1.5*b(104,60)+b(105,60)+0.91*b(126,60)+1.2 & + *b(127,60)+b(128,60)+b(139,60)+b(145,60)+b(160,60) + jvs(489) = -b(24,61)+b(25,61)+b(26,61)+b(28,61) + jvs(490) = 0.89*b(2,62)+b(25,62)+2*b(37,62)-b(39,62)+2*b(40,62) & + +0.7*b(41,62)+b(59,62)+b(60,62)+b(72,62)+b(106,62) & + +b(107,62)+1.5*b(108,62)+b(109,62) + jvs(491) = b(33,63)-b(34,63)-b(35,63)+0.7*b(41,63) + jvs(492) = b(103,64)+b(107,64) + jvs(493) = b(94,16) + jvs(494) = 0.05*b(91,18) + jvs(495) = 0 + jvs(496) = 0.8*b(127,29)+b(130,29)+b(133,29) + jvs(497) = 0.09*b(126,35) + jvs(498) = 0 + jvs(499) = 0.5*b(104,47)+0.5*b(108,47)+b(112,47)+0.5*b(116,47) + jvs(500) = 0.93*b(125,51) + jvs(501) = b(94,56) + jvs(502) = -b(100,57)-b(101,57) + jvs(503) = 0 + jvs(504) = 0.16*b(102,59) + jvs(505) = 0.05*b(91,60)+0.16*b(102,60)+0.5*b(104,60)+0.09 & + *b(126,60)+0.8*b(127,60) + jvs(506) = -b(100,61) + jvs(507) = 0.5*b(108,62)+0.93*b(125,62) + jvs(508) = b(112,63)+b(130,63) + jvs(509) = 0 + jvs(510) = -b(81,22) + jvs(511) = -b(97,32) + jvs(512) = -b(83,37) + jvs(513) = -b(120,38) + jvs(514) = -b(84,42) + jvs(515) = b(13,46)-b(14,46) + jvs(516) = -b(154,50) + jvs(517) = -b(124,51) + jvs(518) = 0.4*b(73,52) + jvs(519) = 0 + jvs(520) = 0 + jvs(521) = 0 + jvs(522) = -b(19,56) + jvs(523) = 0 + jvs(524) = -b(7,58)-b(8,58)-b(14,58)-b(18,58)-b(19,58)-b(20,58) & + -b(21,58)-b(81,58)-b(83,58)-b(84,58)-b(97,58) & + -b(120,58)-b(124,58)-b(154,58) + jvs(525) = 0 + jvs(526) = -b(18,60) + jvs(527) = -b(20,61) + jvs(528) = 0 + jvs(529) = -b(21,63)+0.4*b(73,63) + jvs(530) = 0 + jvs(531) = b(75,30) + jvs(532) = 0 + jvs(533) = 0.03*b(83,37) + jvs(534) = 0 + jvs(535) = 0.09*b(84,42) + jvs(536) = 0 + jvs(537) = 0 + jvs(538) = 0.77*b(99,53) + jvs(539) = 0 + jvs(540) = 0.03*b(83,58)+0.09*b(84,58) + jvs(541) = -b(102,59)-b(106,59)-b(110,59)-b(114,59) + jvs(542) = -b(102,60) + jvs(543) = b(75,61)+0.77*b(99,61) + jvs(544) = -b(106,62) + jvs(545) = -b(110,63) + jvs(546) = 0 + jvs(547) = -b(91,18) + jvs(548) = b(3,24) + jvs(549) = -b(160,27) + jvs(550) = -b(145,28) + jvs(551) = -b(127,29) + jvs(552) = 0 + jvs(553) = -b(126,35) + jvs(554) = -b(128,36) + jvs(555) = 0 + jvs(556) = -b(139,39) + jvs(557) = -b(105,40) + jvs(558) = 0 + jvs(559) = 0 + jvs(560) = -b(58,44) + jvs(561) = b(15,46)-b(17,46) + jvs(562) = -b(104,47) + jvs(563) = b(153,50) + jvs(564) = 0 + jvs(565) = -b(71,52) + jvs(566) = 0 + jvs(567) = -b(164,54) + jvs(568) = -b(57,55) + jvs(569) = b(1,56)+b(15,56)+b(38,56)+b(153,56) + jvs(570) = 0 + jvs(571) = -b(18,58) + jvs(572) = -b(102,59) + jvs(573) = -b(17,60)-b(18,60)-b(23,60)-b(33,60)-b(37,60) & + -b(57,60)-b(58,60)-b(71,60)-b(91,60)-b(102,60) & + -b(103,60)-b(104,60)-b(105,60)-b(126,60)-b(127,60) & + -b(128,60)-b(139,60)-b(145,60)-b(160,60)-b(164,60) + jvs(574) = -b(23,61) + jvs(575) = 0.11*b(2,62)-b(37,62)+b(38,62) + jvs(576) = -b(33,63) + jvs(577) = -b(103,64) + jvs(578) = 2*b(12,6) + jvs(579) = -b(65,7) + jvs(580) = -b(45,8) + jvs(581) = -b(47,9) + jvs(582) = -b(144,11) + jvs(583) = -b(89,12) + jvs(584) = 2*b(9,13)-b(30,13) + jvs(585) = -b(90,15) + jvs(586) = -b(28,17) + jvs(587) = -b(143,19) + jvs(588) = b(54,21)-0.5*b(56,21) + jvs(589) = 0.12*b(81,22)-b(82,22) + jvs(590) = -b(48,23) + jvs(591) = b(3,24)-b(26,24) + jvs(592) = b(53,25)-0.7*b(55,25) + jvs(593) = -b(92,26) + jvs(594) = -b(75,30) + jvs(595) = -b(44,31) + jvs(596) = -b(95,32)+0.08*b(97,32) + jvs(597) = b(4,33)-b(27,33) + jvs(598) = -b(135,34)-b(138,34) + jvs(599) = 0 + jvs(600) = 0 + jvs(601) = 0.33*b(83,37)-b(85,37) + jvs(602) = -b(119,38)+0.27*b(120,38) + jvs(603) = -b(77,41) + jvs(604) = 0.6*b(84,42)-b(86,42) + jvs(605) = -b(79,43) + jvs(606) = 0 + jvs(607) = -b(150,45) + jvs(608) = 0 + jvs(609) = 0 + jvs(610) = -b(67,48) + jvs(611) = -b(51,49) + jvs(612) = b(155,50)-b(157,50) + jvs(613) = -b(123,51)+0.27*b(124,51) + jvs(614) = b(98,53)-0.77*b(99,53) + jvs(615) = 0 + jvs(616) = 0 + jvs(617) = -b(24,56) + jvs(618) = -b(100,57) + jvs(619) = -b(20,58)+b(21,58)+0.12*b(81,58)+0.33*b(83,58)+0.6 & + *b(84,58)+0.08*b(97,58)+0.27*b(120,58)+0.27*b(124,58) + jvs(620) = 0 + jvs(621) = -b(23,60)+b(33,60) + jvs(622) = -b(20,61)-b(22,61)-b(23,61)-b(24,61)-b(25,61) & + -b(26,61)-b(27,61)-b(28,61)-b(29,61)-b(30,61)-b(44,61) & + -b(45,61)-b(46,61)-b(47,61)-b(48,61)-b(51,61)-0.7 & + *b(55,61)-0.5*b(56,61)-b(65,61)-b(67,61)-b(75,61) & + -b(77,61)-b(79,61)-b(82,61)-b(85,61)-b(86,61)-b(89,61) & + -b(90,61)-b(92,61)-b(95,61)-0.77*b(99,61)-b(100,61) & + -b(119,61)-b(123,61)-b(135,61)-b(138,61)-b(143,61) & + -b(144,61)-b(150,61)-b(157,61) + jvs(623) = -b(25,62)+0.7*b(41,62) + jvs(624) = b(21,63)-b(29,63)+b(33,63)+0.7*b(41,63)+b(155,63) + jvs(625) = 0 + jvs(626) = b(6,14)+b(43,14) + jvs(627) = -b(93,26) + jvs(628) = b(27,33) + jvs(629) = -b(136,34) + jvs(630) = -b(87,37) + jvs(631) = -b(121,38) + jvs(632) = -b(109,40) + jvs(633) = -b(88,42) + jvs(634) = -b(80,43) + jvs(635) = -b(60,44) + jvs(636) = -b(148,45) + jvs(637) = b(16,46) + jvs(638) = -b(108,47) + jvs(639) = -b(68,48) + jvs(640) = -b(52,49) + jvs(641) = 0 + jvs(642) = -b(125,51) + jvs(643) = -b(72,52) + jvs(644) = 0 + jvs(645) = 0 + jvs(646) = -b(59,55) + jvs(647) = b(16,56)+b(19,56)-b(38,56)-b(39,56) + jvs(648) = 0 + jvs(649) = b(19,58) + jvs(650) = -b(106,59) + jvs(651) = -b(37,60) + jvs(652) = -b(25,61)+b(27,61) + jvs(653) = -b(2,62)-b(25,62)-b(37,62)-b(38,62)-b(39,62)-2 & + *b(40,62)-b(41,62)-b(52,62)-b(59,62)-b(60,62)-b(68,62) & + -b(72,62)-b(80,62)-b(87,62)-b(88,62)-b(93,62) & + -b(106,62)-b(107,62)-b(108,62)-b(109,62)-b(121,62) & + -b(125,62)-b(136,62)-b(148,62) + jvs(654) = -b(41,63) + jvs(655) = -b(107,64) + jvs(656) = b(65,7) + jvs(657) = b(45,8) + jvs(658) = 0.2*b(89,12) + jvs(659) = b(30,13) + jvs(660) = 0.55*b(90,15) + jvs(661) = b(5,17)+b(36,17) + jvs(662) = 0.95*b(91,18) + jvs(663) = 0.27*b(143,19) + jvs(664) = b(54,21) + jvs(665) = 0.22*b(81,22)+b(82,22) + jvs(666) = b(48,23) + jvs(667) = b(53,25) + jvs(668) = 0.6*b(92,26) + jvs(669) = b(161,27) + jvs(670) = b(146,28) + jvs(671) = 0.8*b(127,29)-b(130,29) + jvs(672) = b(44,31) + jvs(673) = 2*b(95,32)+b(96,32)+0.76*b(97,32) + jvs(674) = 0.965*b(138,34) + jvs(675) = 0.91*b(126,35)-b(129,35) + jvs(676) = b(128,36)-b(131,36) + jvs(677) = 0.26*b(83,37)+b(85,37) + jvs(678) = 0.07*b(120,38) + jvs(679) = b(140,39) + jvs(680) = -b(113,40) + jvs(681) = 0.22*b(84,42)+b(86,42) + jvs(682) = b(78,43) + jvs(683) = b(58,44)+b(60,44)-b(62,44)+0.6*b(64,44) + jvs(684) = -b(147,45) + jvs(685) = 0 + jvs(686) = 0.5*b(104,47)+0.5*b(108,47)-b(112,47) + jvs(687) = b(66,48) + jvs(688) = 2*b(49,49)+b(51,49)+b(52,49)+b(166,49) + jvs(689) = -b(155,50)+b(156,50) + jvs(690) = 0.33*b(122,51)+0.1*b(124,51)+0.93*b(125,51) + jvs(691) = -b(73,52) + jvs(692) = 0.9*b(98,53) + jvs(693) = -b(165,54)+b(166,54) + jvs(694) = b(57,55)+b(59,55)-b(61,55)+0.32*b(63,55)+b(140,55) & + +b(146,55)+b(156,55)+b(161,55) + jvs(695) = -b(34,56)-b(35,56) + jvs(696) = 0.9*b(101,57) + jvs(697) = b(20,58)-b(21,58)+0.22*b(81,58)+0.26*b(83,58)+0.22 & + *b(84,58)+0.76*b(97,58)+0.07*b(120,58)+0.1*b(124,58) + jvs(698) = 0.76*b(102,59)+0.9*b(106,59)-b(110,59)+0.54*b(114,59) + jvs(699) = -b(33,60)+b(57,60)+b(58,60)+0.95*b(91,60)+0.76 & + *b(102,60)+0.5*b(104,60)+0.91*b(126,60)+0.8*b(127,60) & + +b(128,60) + jvs(700) = b(20,61)+b(22,61)+b(25,61)-b(29,61)+b(30,61)+b(44,61) & + +b(45,61)+b(48,61)+b(51,61)+b(65,61)+b(82,61)+b(85,61) & + +b(86,61)+0.2*b(89,61)+0.55*b(90,61)+0.6*b(92,61)+2 & + *b(95,61)+0.965*b(138,61)+0.27*b(143,61) + jvs(701) = b(25,62)-b(41,62)+b(52,62)+b(59,62)+b(60,62)+0.9 & + *b(106,62)+0.5*b(108,62)+0.93*b(125,62) + jvs(702) = -b(21,63)-b(29,63)-2*b(31,63)-2*b(32,63)-b(33,63) & + -b(34,63)-b(35,63)-b(41,63)-b(61,63)-b(62,63)-b(73,63) & + -b(110,63)-b(111,63)-b(112,63)-b(113,63)-b(129,63) & + -b(130,63)-b(131,63)-b(147,63)-b(155,63)-b(165,63) + jvs(703) = -b(111,64) + jvs(704) = b(77,41) + jvs(705) = 0.11*b(84,42) + jvs(706) = 0 + jvs(707) = 0 + jvs(708) = 0 + jvs(709) = 0.11*b(84,58) + jvs(710) = 0 + jvs(711) = -b(103,60) + jvs(712) = b(77,61) + jvs(713) = -b(107,62) + jvs(714) = -b(111,63) + jvs(715) = -b(103,64)-b(107,64)-b(111,64)-b(115,64) + return + end subroutine cbmz_v02r06_jacob + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_decomp( n, v, ier, & + lu_crow_v, lu_diag_v, lu_icol_v ) +! +! computes l-u-decomposition of sparse jacobian +! for mechanism-version-regime = cbmz_v02r06 +! + use module_data_cbmz + implicit none + +! subr parameters +! n = number of variable species [input] + integer n +! ier = status flag [output] +! 0 = success other = failure [output] + integer ier + +! v = non-zero elements of the sparse jacobian [input] + real v(lu_nonzero_v_r06_kpp) + + integer lu_crow_v(nvar_r06_kpp + 1) + integer lu_diag_v(nvar_r06_kpp + 1) + integer lu_icol_v(lu_nonzero_v_r06_kpp) + +! local variables + integer k, kk, j, jj + real a, w(nvar_r06_kpp + 1) + + ier = 0 + do k=1,n + if ( v( lu_diag_v(k) ) .eq. 0. ) then + ier = k + return + end if + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + w( lu_icol_v(kk) ) = v(kk) + end do + do kk = lu_crow_v(k), lu_diag_v(k)-1 + j = lu_icol_v(kk) + a = -w(j) / v( lu_diag_v(j) ) + w(j) = -a + do jj = lu_diag_v(j)+1, lu_crow_v(j+1)-1 + w( lu_icol_v(jj) ) = w( lu_icol_v(jj) ) + a*v(jj) + end do + end do + do kk = lu_crow_v(k), lu_crow_v(k+1)-1 + v(kk) = w( lu_icol_v(kk) ) + end do + end do + return + end subroutine cbmz_v02r06_decomp + + +!----------------------------------------------------------------------------- + subroutine cbmz_v02r06_solve( jvs, x ) +! +! does back-solve for mechanism-version-regime = cbmz_v02r06 +! + implicit none + +! subr parameters +! jvs = the non-zero elements of the l-u-decomposition +! of the augmented jacobian [input] + real jvs(*) +! x = the right-hand side of the linear equation set being solved [on input] +! x = concentrations of variable species [on output] + real x(*) + + + x(18) = x(18)-jvs(64)*x(12)-jvs(65)*x(15) + x(26) = x(26)-jvs(108)*x(12)-jvs(109)*x(15) + x(28) = x(28)-jvs(117)*x(11)-jvs(118)*x(19) + x(30) = x(30)-jvs(129)*x(15)-jvs(130)*x(20)-jvs(131)*x(29) + x(31) = x(31)-jvs(147)*x(22) + x(32) = x(32)-jvs(163)*x(18)-jvs(164)*x(26) + x(33) = x(33)-jvs(170)*x(14)-jvs(171)*x(26) + x(39) = x(39)-jvs(206)*x(34) + x(40) = x(40)-jvs(214)*x(12)-jvs(215)*x(15)-jvs(216)*x(22) & + -jvs(217)*x(26)-jvs(218)*x(32)-jvs(219)*x(37)-jvs(220) & + *x(38) + x(41) = x(41)-jvs(233)*x(36) + x(43) = x(43)-jvs(250)*x(15)-jvs(251)*x(32)-jvs(252)*x(36) & + -jvs(253)*x(37)-jvs(254)*x(42) + x(44) = x(44)-jvs(264)*x(9)-jvs(265)*x(21)-jvs(266)*x(37) & + -jvs(267)*x(42) + x(45) = x(45)-jvs(277)*x(19)-jvs(278)*x(34) + x(46) = x(46)-jvs(286)*x(6)-jvs(287)*x(34) + x(47) = x(47)-jvs(294)*x(37)-jvs(295)*x(42) + x(48) = x(48)-jvs(303)*x(7)-jvs(304)*x(21)-jvs(305)*x(22) & + -jvs(306)*x(29)-jvs(307)*x(32)-jvs(308)*x(36)-jvs(309) & + *x(37)-jvs(310)*x(38)-jvs(311)*x(42)-jvs(312)*x(44) & + -jvs(313)*x(47) + x(49) = x(49)-jvs(324)*x(22)-jvs(325)*x(23)-jvs(326)*x(25) & + -jvs(327)*x(27)-jvs(328)*x(28)-jvs(329)*x(32)-jvs(330) & + *x(34)-jvs(331)*x(35)-jvs(332)*x(36)-jvs(333)*x(37) & + -jvs(334)*x(38)-jvs(335)*x(39)-jvs(336)*x(42)-jvs(337) & + *x(45)-jvs(338)*x(46)-jvs(339)*x(47) + x(50) = x(50)-jvs(353)*x(27)-jvs(354)*x(28)-jvs(355)*x(34) & + -jvs(356)*x(39)-jvs(357)*x(45)-jvs(358)*x(46) + x(51) = x(51)-jvs(368)*x(29)-jvs(369)*x(35)-jvs(370)*x(38) + x(52) = x(52)-jvs(377)*x(10)-jvs(378)*x(32)-jvs(379)*x(37) & + -jvs(380)*x(38)-jvs(381)*x(41)-jvs(382)*x(42)-jvs(383) & + *x(43)-jvs(384)*x(48)-jvs(385)*x(51) + x(53) = x(53)-jvs(397)*x(35)-jvs(398)*x(36)-jvs(399)*x(38) & + -jvs(400)*x(51) + x(54) = x(54)-jvs(409)*x(27)-jvs(410)*x(39)-jvs(411)*x(45) & + -jvs(412)*x(46)-jvs(413)*x(49)-jvs(414)*x(50)-jvs(415) & + *x(51) + x(55) = x(55)-jvs(426)*x(19)-jvs(427)*x(25)-jvs(428)*x(27) & + -jvs(429)*x(28)-jvs(430)*x(34)-jvs(431)*x(37)-jvs(432) & + *x(39)-jvs(433)*x(41)-jvs(434)*x(42)-jvs(435)*x(45) & + -jvs(436)*x(46)-jvs(437)*x(48)-jvs(438)*x(50)-jvs(439) & + *x(51)-jvs(440)*x(52)-jvs(441)*x(53)-jvs(442)*x(54) + x(56) = x(56)-jvs(453)*x(10)-jvs(454)*x(14)-jvs(455)*x(16) & + -jvs(456)*x(17)-jvs(457)*x(18)-jvs(458)*x(24)-jvs(459) & + *x(26)-jvs(460)*x(27)-jvs(461)*x(28)-jvs(462)*x(29) & + -jvs(463)*x(33)-jvs(464)*x(34)-jvs(465)*x(35)-jvs(466) & + *x(36)-jvs(467)*x(38)-jvs(468)*x(39)-jvs(469)*x(40) & + -jvs(470)*x(42)-jvs(471)*x(43)-jvs(472)*x(44)-jvs(473) & + *x(45)-jvs(474)*x(46)-jvs(475)*x(47)-jvs(476)*x(48) & + -jvs(477)*x(49)-jvs(478)*x(50)-jvs(479)*x(51)-jvs(480) & + *x(52)-jvs(481)*x(53)-jvs(482)*x(54)-jvs(483)*x(55) + x(57) = x(57)-jvs(493)*x(16)-jvs(494)*x(18)-jvs(495)*x(26) & + -jvs(496)*x(29)-jvs(497)*x(35)-jvs(498)*x(38)-jvs(499) & + *x(47)-jvs(500)*x(51)-jvs(501)*x(56) + x(58) = x(58)-jvs(510)*x(22)-jvs(511)*x(32)-jvs(512)*x(37) & + -jvs(513)*x(38)-jvs(514)*x(42)-jvs(515)*x(46)-jvs(516) & + *x(50)-jvs(517)*x(51)-jvs(518)*x(52)-jvs(519)*x(53) & + -jvs(520)*x(54)-jvs(521)*x(55)-jvs(522)*x(56)-jvs(523) & + *x(57) + x(59) = x(59)-jvs(531)*x(30)-jvs(532)*x(35)-jvs(533)*x(37) & + -jvs(534)*x(38)-jvs(535)*x(42)-jvs(536)*x(47)-jvs(537) & + *x(51)-jvs(538)*x(53)-jvs(539)*x(57)-jvs(540)*x(58) + x(60) = x(60)-jvs(547)*x(18)-jvs(548)*x(24)-jvs(549)*x(27) & + -jvs(550)*x(28)-jvs(551)*x(29)-jvs(552)*x(34)-jvs(553) & + *x(35)-jvs(554)*x(36)-jvs(555)*x(38)-jvs(556)*x(39) & + -jvs(557)*x(40)-jvs(558)*x(42)-jvs(559)*x(43)-jvs(560) & + *x(44)-jvs(561)*x(46)-jvs(562)*x(47)-jvs(563)*x(50) & + -jvs(564)*x(51)-jvs(565)*x(52)-jvs(566)*x(53)-jvs(567) & + *x(54)-jvs(568)*x(55)-jvs(569)*x(56)-jvs(570)*x(57) & + -jvs(571)*x(58)-jvs(572)*x(59) + x(61) = x(61)-jvs(578)*x(6)-jvs(579)*x(7)-jvs(580)*x(8)-jvs(581) & + *x(9)-jvs(582)*x(11)-jvs(583)*x(12)-jvs(584)*x(13) & + -jvs(585)*x(15)-jvs(586)*x(17)-jvs(587)*x(19)-jvs(588) & + *x(21)-jvs(589)*x(22)-jvs(590)*x(23)-jvs(591)*x(24) & + -jvs(592)*x(25)-jvs(593)*x(26)-jvs(594)*x(30)-jvs(595) & + *x(31)-jvs(596)*x(32)-jvs(597)*x(33)-jvs(598)*x(34) & + -jvs(599)*x(35)-jvs(600)*x(36)-jvs(601)*x(37)-jvs(602) & + *x(38)-jvs(603)*x(41)-jvs(604)*x(42)-jvs(605)*x(43) & + -jvs(606)*x(44)-jvs(607)*x(45)-jvs(608)*x(46)-jvs(609) & + *x(47)-jvs(610)*x(48)-jvs(611)*x(49)-jvs(612)*x(50) & + -jvs(613)*x(51)-jvs(614)*x(53)-jvs(615)*x(54)-jvs(616) & + *x(55)-jvs(617)*x(56)-jvs(618)*x(57)-jvs(619)*x(58) & + -jvs(620)*x(59)-jvs(621)*x(60) + x(62) = x(62)-jvs(626)*x(14)-jvs(627)*x(26)-jvs(628)*x(33) & + -jvs(629)*x(34)-jvs(630)*x(37)-jvs(631)*x(38)-jvs(632) & + *x(40)-jvs(633)*x(42)-jvs(634)*x(43)-jvs(635)*x(44) & + -jvs(636)*x(45)-jvs(637)*x(46)-jvs(638)*x(47)-jvs(639) & + *x(48)-jvs(640)*x(49)-jvs(641)*x(50)-jvs(642)*x(51) & + -jvs(643)*x(52)-jvs(644)*x(53)-jvs(645)*x(54)-jvs(646) & + *x(55)-jvs(647)*x(56)-jvs(648)*x(57)-jvs(649)*x(58) & + -jvs(650)*x(59)-jvs(651)*x(60)-jvs(652)*x(61) + x(63) = x(63)-jvs(656)*x(7)-jvs(657)*x(8)-jvs(658)*x(12) & + -jvs(659)*x(13)-jvs(660)*x(15)-jvs(661)*x(17)-jvs(662) & + *x(18)-jvs(663)*x(19)-jvs(664)*x(21)-jvs(665)*x(22) & + -jvs(666)*x(23)-jvs(667)*x(25)-jvs(668)*x(26)-jvs(669) & + *x(27)-jvs(670)*x(28)-jvs(671)*x(29)-jvs(672)*x(31) & + -jvs(673)*x(32)-jvs(674)*x(34)-jvs(675)*x(35)-jvs(676) & + *x(36)-jvs(677)*x(37)-jvs(678)*x(38)-jvs(679)*x(39) & + -jvs(680)*x(40)-jvs(681)*x(42)-jvs(682)*x(43)-jvs(683) & + *x(44)-jvs(684)*x(45)-jvs(685)*x(46)-jvs(686)*x(47) & + -jvs(687)*x(48)-jvs(688)*x(49)-jvs(689)*x(50)-jvs(690) & + *x(51)-jvs(691)*x(52)-jvs(692)*x(53)-jvs(693)*x(54) & + -jvs(694)*x(55)-jvs(695)*x(56)-jvs(696)*x(57)-jvs(697) & + *x(58)-jvs(698)*x(59)-jvs(699)*x(60)-jvs(700)*x(61) & + -jvs(701)*x(62) + x(64) = x(64)-jvs(704)*x(41)-jvs(705)*x(42)-jvs(706)*x(51) & + -jvs(707)*x(53)-jvs(708)*x(57)-jvs(709)*x(58)-jvs(710) & + *x(59)-jvs(711)*x(60)-jvs(712)*x(61)-jvs(713)*x(62) & + -jvs(714)*x(63) + x(64) = x(64)/jvs(715) + x(63) = (x(63)-jvs(703)*x(64))/(jvs(702)) + x(62) = (x(62)-jvs(654)*x(63)-jvs(655)*x(64))/(jvs(653)) + x(61) = (x(61)-jvs(623)*x(62)-jvs(624)*x(63)-jvs(625)*x(64))/ & + (jvs(622)) + x(60) = (x(60)-jvs(574)*x(61)-jvs(575)*x(62)-jvs(576)*x(63) & + -jvs(577)*x(64))/(jvs(573)) + x(59) = (x(59)-jvs(542)*x(60)-jvs(543)*x(61)-jvs(544)*x(62) & + -jvs(545)*x(63)-jvs(546)*x(64))/(jvs(541)) + x(58) = (x(58)-jvs(525)*x(59)-jvs(526)*x(60)-jvs(527)*x(61) & + -jvs(528)*x(62)-jvs(529)*x(63)-jvs(530)*x(64))/(jvs(524)) + x(57) = (x(57)-jvs(503)*x(58)-jvs(504)*x(59)-jvs(505)*x(60) & + -jvs(506)*x(61)-jvs(507)*x(62)-jvs(508)*x(63)-jvs(509) & + *x(64))/(jvs(502)) + x(56) = (x(56)-jvs(485)*x(57)-jvs(486)*x(58)-jvs(487)*x(59) & + -jvs(488)*x(60)-jvs(489)*x(61)-jvs(490)*x(62)-jvs(491) & + *x(63)-jvs(492)*x(64))/(jvs(484)) + x(55) = (x(55)-jvs(444)*x(56)-jvs(445)*x(57)-jvs(446)*x(58) & + -jvs(447)*x(59)-jvs(448)*x(60)-jvs(449)*x(61)-jvs(450) & + *x(62)-jvs(451)*x(63)-jvs(452)*x(64))/(jvs(443)) + x(54) = (x(54)-jvs(417)*x(55)-jvs(418)*x(56)-jvs(419)*x(57) & + -jvs(420)*x(58)-jvs(421)*x(60)-jvs(422)*x(61)-jvs(423) & + *x(62)-jvs(424)*x(63)-jvs(425)*x(64))/(jvs(416)) + x(53) = (x(53)-jvs(402)*x(58)-jvs(403)*x(59)-jvs(404)*x(60) & + -jvs(405)*x(61)-jvs(406)*x(62)-jvs(407)*x(63)-jvs(408) & + *x(64))/(jvs(401)) + x(52) = (x(52)-jvs(387)*x(53)-jvs(388)*x(56)-jvs(389)*x(57) & + -jvs(390)*x(58)-jvs(391)*x(59)-jvs(392)*x(60)-jvs(393) & + *x(61)-jvs(394)*x(62)-jvs(395)*x(63)-jvs(396)*x(64))/ & + (jvs(386)) + x(51) = (x(51)-jvs(372)*x(58)-jvs(373)*x(60)-jvs(374)*x(61) & + -jvs(375)*x(62)-jvs(376)*x(63))/(jvs(371)) + x(50) = (x(50)-jvs(360)*x(54)-jvs(361)*x(55)-jvs(362)*x(56) & + -jvs(363)*x(58)-jvs(364)*x(60)-jvs(365)*x(61)-jvs(366) & + *x(62)-jvs(367)*x(63))/(jvs(359)) + x(49) = (x(49)-jvs(341)*x(50)-jvs(342)*x(51)-jvs(343)*x(54) & + -jvs(344)*x(55)-jvs(345)*x(56)-jvs(346)*x(57)-jvs(347) & + *x(58)-jvs(348)*x(60)-jvs(349)*x(61)-jvs(350)*x(62) & + -jvs(351)*x(63)-jvs(352)*x(64))/(jvs(340)) + x(48) = (x(48)-jvs(315)*x(51)-jvs(316)*x(53)-jvs(317)*x(57) & + -jvs(318)*x(58)-jvs(319)*x(59)-jvs(320)*x(60)-jvs(321) & + *x(61)-jvs(322)*x(62)-jvs(323)*x(63))/(jvs(314)) + x(47) = (x(47)-jvs(297)*x(57)-jvs(298)*x(58)-jvs(299)*x(60) & + -jvs(300)*x(61)-jvs(301)*x(62)-jvs(302)*x(63))/(jvs(296)) + x(46) = (x(46)-jvs(289)*x(56)-jvs(290)*x(58)-jvs(291)*x(60) & + -jvs(292)*x(61)-jvs(293)*x(62))/(jvs(288)) + x(45) = (x(45)-jvs(280)*x(46)-jvs(281)*x(54)-jvs(282)*x(55) & + -jvs(283)*x(61)-jvs(284)*x(62)-jvs(285)*x(63))/(jvs(279)) + x(44) = (x(44)-jvs(269)*x(53)-jvs(270)*x(57)-jvs(271)*x(58) & + -jvs(272)*x(59)-jvs(273)*x(60)-jvs(274)*x(61)-jvs(275) & + *x(62)-jvs(276)*x(63))/(jvs(268)) + x(43) = (x(43)-jvs(256)*x(51)-jvs(257)*x(53)-jvs(258)*x(58) & + -jvs(259)*x(60)-jvs(260)*x(61)-jvs(261)*x(62)-jvs(262) & + *x(63)-jvs(263)*x(64))/(jvs(255)) + x(42) = (x(42)-jvs(247)*x(58)-jvs(248)*x(61)-jvs(249)*x(62))/ & + (jvs(246)) + x(41) = (x(41)-jvs(235)*x(42)-jvs(236)*x(51)-jvs(237)*x(53) & + -jvs(238)*x(57)-jvs(239)*x(58)-jvs(240)*x(59)-jvs(241) & + *x(60)-jvs(242)*x(61)-jvs(243)*x(62)-jvs(244)*x(63) & + -jvs(245)*x(64))/(jvs(234)) + x(40) = (x(40)-jvs(222)*x(42)-jvs(223)*x(43)-jvs(224)*x(51) & + -jvs(225)*x(53)-jvs(226)*x(57)-jvs(227)*x(58)-jvs(228) & + *x(59)-jvs(229)*x(60)-jvs(230)*x(61)-jvs(231)*x(62) & + -jvs(232)*x(63))/(jvs(221)) + x(39) = (x(39)-jvs(208)*x(46)-jvs(209)*x(50)-jvs(210)*x(55) & + -jvs(211)*x(60)-jvs(212)*x(61)-jvs(213)*x(62))/(jvs(207)) + x(38) = (x(38)-jvs(203)*x(58)-jvs(204)*x(61)-jvs(205)*x(62))/ & + (jvs(202)) + x(37) = (x(37)-jvs(199)*x(58)-jvs(200)*x(61)-jvs(201)*x(62))/ & + (jvs(198)) + x(36) = (x(36)-jvs(194)*x(51)-jvs(195)*x(60)-jvs(196)*x(61) & + -jvs(197)*x(63))/(jvs(193)) + x(35) = (x(35)-jvs(189)*x(38)-jvs(190)*x(60)-jvs(191)*x(61) & + -jvs(192)*x(63))/(jvs(188)) + x(34) = (x(34)-jvs(185)*x(46)-jvs(186)*x(61)-jvs(187)*x(62))/ & + (jvs(184)) + x(33) = (x(33)-jvs(173)*x(34)-jvs(174)*x(43)-jvs(175)*x(45) & + -jvs(176)*x(48)-jvs(177)*x(49)-jvs(178)*x(51)-jvs(179) & + *x(54)-jvs(180)*x(56)-jvs(181)*x(61)-jvs(182)*x(62) & + -jvs(183)*x(63))/(jvs(172)) + x(32) = (x(32)-jvs(166)*x(58)-jvs(167)*x(60)-jvs(168)*x(61) & + -jvs(169)*x(62))/(jvs(165)) + x(31) = (x(31)-jvs(149)*x(32)-jvs(150)*x(36)-jvs(151)*x(37) & + -jvs(152)*x(38)-jvs(153)*x(42)-jvs(154)*x(43)-jvs(155) & + *x(48)-jvs(156)*x(49)-jvs(157)*x(51)-jvs(158)*x(54) & + -jvs(159)*x(58)-jvs(160)*x(60)-jvs(161)*x(61)-jvs(162) & + *x(62))/(jvs(148)) + x(30) = (x(30)-jvs(133)*x(35)-jvs(134)*x(37)-jvs(135)*x(38) & + -jvs(136)*x(42)-jvs(137)*x(47)-jvs(138)*x(51)-jvs(139) & + *x(53)-jvs(140)*x(57)-jvs(141)*x(58)-jvs(142)*x(59) & + -jvs(143)*x(60)-jvs(144)*x(61)-jvs(145)*x(62)-jvs(146) & + *x(63))/(jvs(132)) + x(29) = (x(29)-jvs(125)*x(38)-jvs(126)*x(60)-jvs(127)*x(62) & + -jvs(128)*x(63))/(jvs(124)) + x(28) = (x(28)-jvs(120)*x(34)-jvs(121)*x(55)-jvs(122)*x(60) & + -jvs(123)*x(61))/(jvs(119)) + x(27) = (x(27)-jvs(114)*x(50)-jvs(115)*x(55)-jvs(116)*x(60))/ & + (jvs(113)) + x(26) = (x(26)-jvs(111)*x(61)-jvs(112)*x(62))/(jvs(110)) + x(25) = (x(25)-jvs(104)*x(45)-jvs(105)*x(55)-jvs(106)*x(61) & + -jvs(107)*x(63))/(jvs(103)) + x(24) = (x(24)-jvs(98)*x(54)-jvs(99)*x(56)-jvs(100)*x(60) & + -jvs(101)*x(61)-jvs(102)*x(63))/(jvs(97)) + x(23) = (x(23)-jvs(92)*x(37)-jvs(93)*x(42)-jvs(94)*x(55)-jvs(95) & + *x(58)-jvs(96)*x(61))/(jvs(91)) + x(22) = (x(22)-jvs(89)*x(58)-jvs(90)*x(61))/(jvs(88)) + x(21) = (x(21)-jvs(85)*x(44)-jvs(86)*x(61)-jvs(87)*x(63))/ & + (jvs(84)) + x(20) = (x(20)-jvs(73)*x(30)-jvs(74)*x(37)-jvs(75)*x(42)-jvs(76) & + *x(47)-jvs(77)*x(53)-jvs(78)*x(57)-jvs(79)*x(58)-jvs(80) & + *x(59)-jvs(81)*x(60)-jvs(82)*x(61)-jvs(83)*x(62))/ & + (jvs(72)) + x(19) = (x(19)-jvs(70)*x(34)-jvs(71)*x(61))/(jvs(69)) + x(18) = (x(18)-jvs(67)*x(60)-jvs(68)*x(61))/(jvs(66)) + x(17) = (x(17)-jvs(61)*x(56)-jvs(62)*x(61)-jvs(63)*x(63))/ & + (jvs(60)) + x(16) = (x(16)-jvs(56)*x(26)-jvs(57)*x(56)-jvs(58)*x(61)-jvs(59) & + *x(62))/(jvs(55)) + x(15) = (x(15)-jvs(54)*x(61))/(jvs(53)) + x(14) = (x(14)-jvs(51)*x(56)-jvs(52)*x(62))/(jvs(50)) + x(13) = (x(13)-jvs(47)*x(45)-jvs(48)*x(61)-jvs(49)*x(63))/ & + (jvs(46)) + x(12) = (x(12)-jvs(45)*x(61))/(jvs(44)) + x(11) = (x(11)-jvs(42)*x(19)-jvs(43)*x(61))/(jvs(41)) + x(10) = (x(10)-jvs(39)*x(52)-jvs(40)*x(56))/(jvs(38)) + x(9) = (x(9)-jvs(36)*x(44)-jvs(37)*x(61))/(jvs(35)) + x(8) = (x(8)-jvs(33)*x(50)-jvs(34)*x(61))/(jvs(32)) + x(7) = (x(7)-jvs(31)*x(61))/(jvs(30)) + x(6) = (x(6)-jvs(29)*x(58))/(jvs(28)) + x(5) = (x(5)-jvs(27)*x(39))/(jvs(26)) + x(4) = (x(4)-jvs(18)*x(45)-jvs(19)*x(49)-jvs(20)*x(50)-jvs(21) & + *x(54)-jvs(22)*x(56)-jvs(23)*x(60)-jvs(24)*x(61)-jvs(25) & + *x(63))/(jvs(17)) + x(3) = (x(3)-jvs(12)*x(37)-jvs(13)*x(42)-jvs(14)*x(52)-jvs(15) & + *x(58)-jvs(16)*x(63))/(jvs(11)) + x(2) = (x(2)-jvs(6)*x(22)-jvs(7)*x(37)-jvs(8)*x(38)-jvs(9)*x(51) & + -jvs(10)*x(58))/(jvs(5)) + x(1) = (x(1)-jvs(2)*x(8)-jvs(3)*x(54)-jvs(4)*x(61))/(jvs(1)) + return + end subroutine cbmz_v02r06_solve + + +!----------------------------------------------------------------------- + end module module_cbmz_rodas_prep diff --git a/wrfv2_fire/chem/module_chem_utilities.F b/wrfv2_fire/chem/module_chem_utilities.F new file mode 100644 index 00000000..95c23395 --- /dev/null +++ b/wrfv2_fire/chem/module_chem_utilities.F @@ -0,0 +1,165 @@ +MODULE module_chem_utilities + USE module_domain + USE module_model_constants + USE module_state_description + USE module_configure + +CONTAINS + SUBROUTINE chem_prep ( config_flags, & ! input + u, v, p, pb, alt, ph, & ! input + phb, t, moist, n_moist, & ! input + rho, p_phy , & ! output + u_phy, v_phy, p8w, t_phy, t8w, & ! output + z, z_at_w, dz8w, & ! output + fzm, fzp, & ! params + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: n_moist + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN) :: moist + + + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT( OUT) :: u_phy, & + v_phy, & + p_phy, & + p8w, & + t_phy, & + t8w, & + rho, & + z, & + dz8w, & + z_at_w + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: pb, & + p, & + u, & + v, & + alt, & + ph, & + phb, & + t + + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i, j, k + REAL :: w1, w2, z0, z1, z2 + +!----------------------------------------------------------------------- + +! set up loop bounds for this grid's boundary conditions + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) + + k_start = kts + k_end = min( kte, kde-1 ) + +! compute thermodynamics and velocities at pressure points + do j = j_start,j_end + do k = k_start, k_end + do i = i_start, i_end + + p_phy(i,k,j) = p(i,k,j) + pb(i,k,j) + t_phy(i,k,j) = (t(i,k,j)+t0)*(p_phy(i,k,j)/p1000mb)**rcp + rho(i,k,j) = 1./alt(i,k,j)*(1.+moist(i,k,j,P_QV)) + u_phy(i,k,j) = 0.5*(u(i,k,j)+u(i+1,k,j)) + v_phy(i,k,j) = 0.5*(v(i,k,j)+v(i,k,j+1)) + + enddo + enddo + enddo + +! compute z at w points + + do j = j_start,j_end + do k = k_start, kte + do i = i_start, i_end + z_at_w(i,k,j) = (phb(i,k,j)+ph(i,k,j))/g + enddo + enddo + enddo + + do j = j_start,j_end + do k = k_start, kte-1 + do i = i_start, i_end + dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j) + enddo + enddo + enddo + + do j = j_start,j_end + do i = i_start, i_end + dz8w(i,kte,j) = 0. + enddo + enddo + +! compute z at p points (average of z at w points) + do j = j_start,j_end + do k = k_start, k_end + do i = i_start, i_end + z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) ) + enddo + enddo + enddo + +! interp t and p at w points + + do j = j_start,j_end + do k = 2, k_end + do i = i_start, i_end + p8w(i,k,j) = fzm(k)*p_phy(i,k,j)+fzp(k)*p_phy(i,k-1,j) + t8w(i,k,j) = fzm(k)*t_phy(i,k,j)+fzp(k)*t_phy(i,k-1,j) + enddo + enddo + enddo + +! extrapolate p and t to surface and top. +! we'll use an extrapolation in z for now + + do j = j_start,j_end + do i = i_start, i_end + +! bottom + + z0 = z_at_w(i,1,j) + z1 = z(i,1,j) + z2 = z(i,2,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 + p8w(i,1,j) = w1*p_phy(i,1,j)+w2*p_phy(i,2,j) + t8w(i,1,j) = w1*t_phy(i,1,j)+w2*t_phy(i,2,j) + +! top + + z0 = z_at_w(i,kte,j) + z1 = z(i,k_end,j) + z2 = z(i,k_end-1,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 + +! p8w(i,kde,j) = w1*p_phy(i,kde-1,j)+w2*p_phy(i,kde-2,j) +!!! bug fix extrapolate ln(p) so p is positive definite + p8w(i,kde,j) = exp(w1*log(p_phy(i,kde-1,j))+w2*log(p_phy(i,kde-2,j))) + t8w(i,kde,j) = w1*t_phy(i,kde-1,j)+w2*t_phy(i,kde-2,j) + + enddo + enddo +END SUBROUTINE chem_prep +END MODULE module_chem_utilities diff --git a/wrfv2_fire/chem/module_cmu_bulkaqchem.F b/wrfv2_fire/chem/module_cmu_bulkaqchem.F new file mode 100644 index 00000000..74598c77 --- /dev/null +++ b/wrfv2_fire/chem/module_cmu_bulkaqchem.F @@ -0,0 +1,2482 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + + module module_cmu_bulkaqchem + + + use module_peg_util, only: peg_error_fatal, peg_message + + + implicit none + + + contains + + + +!********************************************************************** +! +! revised aqueous-phase chemistry module for the 3-d acid deposition model +! +!********************************************************************** +! +! last modification : june 2, 1998 by s. pandis +! the algorithm was modified to speed up execution. two major changes +! (1) a bulk aqueous-phase chemistry approach is used and the +! results are distributed over the particle spectrum according +! to water content +! (2) the water content is assumed to be constant (an input to the code) +! +! ****** for bulk ****** +! +!----------------------------------------------------------------------- +! +! This code was obtained from S. Pandis in July 2003. +! It was converted to Fortran-90 and adapted for use in WRF-chem with +! the MOSAIC aerosol modules by R. Easter (PNNL) in July 2005. +! +! 27-oct-2005 rce +! switched from svode (single prec) to dvode (double prec) solver +! changes in fullequil & aqratesa to make the ph calc more robust, +! and do a graceful exit (?) when it fails +! 01-nov-2005 rce +! this version is completely double precision, including arguments +! 09-dec-2005 rce +! when iradical_in=100/101/102, the aqueous radical species are +! calculated directly by dvode, and hybrd is not used +! when idecomp_hmsa_hso5 > 0 & iradical_in = 100/1/2 +! aqueous so5- is transferred to gas so2 +! aqueous so4- is transferred to aerosol so4= +! (this is in addition to the previous actions +! when idecomp_hmsa_hso5 > 0: +! aqueous hso5 is transferred to gas so2 +! aqueous hmsa is transferred to gas so2 & hcho) +! 15-may-2006 rce +! deleted the call to hybrd, so iradical_in>0 results in iradical=100 +!----------------------------------------------------------------------- + + + + +!---------------------------------------------------------------------- + subroutine aqoperator1( & + istat_fatal, istat_warn, & + tbeg_sec, tend_sec, & + gas, aerosol, gas_aqfrac, & + temp, p, lwc, rh, & + co2_mixrat_in, photo_in, iradical_in, idecomp_hmsa_hso5, iaq, & + yaq_beg, yaq_end, ph_cmuaq_cur ) + + use module_data_cmu_bulkaqchem, only: & + akeq, akhen, & + co2_mixrat, iradical, & + kaqx_hmsa, kaqx_hso5m, kaqx_siv, & + mdiag_fullequil, mdiag_hybrd, & + mdiag_negconc, mdiag_rsrate, mdiag_svode, & + meqn1, meqn1max, naers, ngas, & + na4, naa, nac, nahmsa, nahso5, nan, nar, nas, & + ng4, nga, ngc, ngh2o2, nghcho, nghcooh, ngn, ngso2, & + photo, & + rideal, & + wh2o2, wh2so4, whcho, whcl, whcooh, whno3, & + wnh3, wso2, wmol + +! +!.....inputs +! +! tbeg_sec : start of integration (in sec) +! tend_sec : end of integration time (in sec) +! +! gas(ngas) : gas-phase concentration vector (in ppm) +! aerosol(naers) : aqueous (aerosol) species concentration (in ug/m3) +! +! temp : temperature (in k) +! p : pressure (in atm) +! lwc : liquid water content (in g/m3) +! rh : relative humidity (in 0-1 scale) +! iradical_in : flag: 1/0 means aqueous free radical chemistry is on/off +! photo_in : factor applied to aqueous photochemical rates +! +! idecomp_hmsa_hso5 : flag -- if > 0, then hso5 is decomposed to so2, +! and hmsa is decomposed to so2 & hcho, at end of integration. +! If 0, hso5 and hmsa are left as is. +! iaq : flag: 1 at first call, 0 there after +! +!.....outputs +! gas(ngas) : updated gas-phase concentrations (in ppm) +! aerosol(naers) : updated aqueous species concentration (in ug/m3) +! iaq : flag set to zero +! +! yaq_beg(meqn1max) : initial yaq values computed from initial gas & aerosol +! yaq_end(meqn1max) : final yaq values +! ph_cmuaq_cur : final ph values +! +!.....variables +! gcon(ngas) : gas-phase concentrations (in ppm) (through rpar to rates) +! +! +!.....differential equations are solved for the following species +! +! total gas aqueous +!----------------------------------------------------------------------- +! 1. formaldehyde total 1. so2 1. s(iv) +! 2. formic acid total 2. h2o2 2. h2o2(aq) +! 3. nh3 3. nitrate +! 4. chloride +! 5. ammonium +! 6. sulfate +! 7. hso5- +! 8. hmsa +! +! +!.....y matrix structure everything is (ug/m3) +! only 11 odes are solved for the whole distribution +! +! yaq(1) = total formaldehyde +! yaq(2) = total formic acid +! yaq(3) = so2 (g) +! yaq(4) = h2o2 (g) +! yaq(5) = nh3 (g) +! yaq(6) = so2 (aq) +! yaq(7) = h2o2 (aq) +! yaq(8) = nitrate (aq) +! yaq(9) = chloride (aq) +! yaq(10) = ammonium (aq) +! yaq(11) = sulfate (aq) +! yaq(12) = hso5- (aq) +! yaq(13) = hmsa (aq) +! + +! arguments + integer istat_fatal, istat_warn + integer iradical_in, idecomp_hmsa_hso5, iaq + double precision tbeg_sec, tend_sec + double precision temp, p, lwc, rh + double precision co2_mixrat_in, photo_in + double precision gas(ngas), aerosol(naers) + double precision gas_aqfrac(ngas) + double precision yaq_beg(meqn1max), yaq_end(meqn1max), ph_cmuaq_cur + +! local variables + integer i, isp + integer icount, iprint, negconc_count + + double precision & + ammonold, chlorold, crustal, & + dammon, dchlor, dhmsa, dhso5, dnit, dsulf, & + fammon, fh2o2, fh2so4, fhcho, fhcl, fhcooh, fhno3, fso2, & + hmsaold, hso5old, & + pres, & + salt, sodium, stime, stout, sulfateold, & + tnitold, watcont, watvap, & + whchowhmsa, wso2whmsa, wso2whso5, wso2wsiv, & + yaq_h2so4_g, yaq_hcl_g, yaq_hno3_g + double precision & + duma, dumb, dumhion, vlwc + double precision gascon(ngas) + double precision yaq(meqn1max) + + integer ipar(8) + double precision rpar(8+ngas) + +! +! initialization (only on first call) +! (calculation of sectional diameters (which isn't really needed), +! and loading of molec. weights (which is needed)) +! + if (iaq .eq. 1) then + call dropinit + iaq = 0 + endif + + mdiag_fullequil = 1 + mdiag_hybrd = 1 + mdiag_negconc = 1 + mdiag_rsrate = 1 + mdiag_svode = 1 + +! +! calc temperature dependent parameters +! + pres = p ! pressure in atm + call constants(temp) + +! +! zero the yaq matrix +! + do i=1, meqn1max + yaq(i)=0.0 + enddo + + watcont = lwc + +! for iradical_in<0, set iradical=0 +! for iradical_in>0, set iradical=100 except when iradical_in=101,102 + iradical = iradical_in + if (iradical .gt. 0) then + if ((iradical .ne. 101) .and. & + (iradical .ne. 102)) iradical = 100 + else + iradical = 0 + end if + + photo = photo_in + co2_mixrat = co2_mixrat_in + + meqn1 = 13 +! if (iradical .eq. 100) meqn1 = 20 + if (iradical .gt. 0) meqn1 = 20 + + icount=0 +! iprint=20 + +! +! transfer of all gas-phase concentrations to gascon and then +! through rpar to rates +! + do i=1, ngas + gascon(i) = gas(i) + gas_aqfrac(i) = 0.0 + enddo +! +! unit conversion factors +! + fso2=1000.*pres*wso2/(rideal*temp) !so2 conver. factor from ppm to ug/m3 + fh2o2=1000.*pres*wh2o2/(rideal*temp) !h2o2 conver. factor from ppm to ug/m3 + fhcho=1000.*pres*whcho/(rideal*temp) !hcho conver. factor from ppm to ug/m3 + fhcooh=1000.*pres*whcooh/(rideal*temp) !hcooh conver. factor from ppm to ug/m3 + fammon=1000.*pres*wnh3/(rideal*temp) !nh3 conver. factor from ppm to ug/m3 +! +! +! *** beginning of aqueous-phase calculation +! loading of the concentrations in the yaq vector +! +! the total formaldehyde/formic acid are transferred as gas-phase species +! (they are not included in the aqueous or aerosol matrices) + yaq(1) = gas(nghcho)*fhcho ! total hcho (ug/m3) + yaq(2) = gas(nghcooh)*fhcooh ! total hcooh (ug/m3) +! +! gas-phase species +! + yaq(3) = gas(ngso2)*fso2 ! total so2 (ug/m3) + yaq(4) = gas(ngh2o2)*fh2o2 ! total h2o2 (ug/m3) + yaq(5) = gas(nga) *fammon ! nh3(g) in ug/m3 + +! +! aqueous-phase species +! +! "aerosol" array holds the bulk aqueous chemical concentrations +! (in ug/m3-of-air), so there is no "activation" or summing over sections +! +! ** the droplets are assumed to by without so2 or +! h2o2 in the beginning of a timestep ** +! (this is done to avoid carrying the s(iv)/h2o2 concentrations +! in the 3d simulation ** + yaq(6) = 1.e-10 ! so2 (aq) in ug/m3 + yaq(7) = 1.e-10 ! h2o2 (aq) in ug/m3 + + yaq(8) = aerosol(nan) ! nitrate (aq) in ug/m3 + yaq(9) = aerosol(nac) ! chloride (aq) in ug/m3 + yaq(10) = aerosol(naa) ! ammonium (aq) in ug/m3 + yaq(11) = aerosol(na4) ! sulfate (aq) in ug/m3 + yaq(12) = aerosol(nahso5) ! hso5- in ug/m3 + yaq(13) = aerosol(nahmsa) ! hmsa in ug/m3 + +! +! save the old aqueous-phase concentrations before the integration +! + tnitold = yaq(8) + chlorold = yaq(9) + ammonold = yaq(10) + sulfateold = yaq(11) + hso5old = yaq(12) + hmsaold = yaq(13) +! +! calculation of the dissolution of the available h2so4, hno3 and hcl +! to the droplets/particles. we assume that the timescale of dissolution +! is small and that all hno3 and hcl are dissolved (zero vapor pressure) +! + fh2so4=1000.*wh2so4*pres/(rideal*temp) !h2so4 conver. factor from ppm to ug/m3 + fhno3 =1000.*whno3*pres/(rideal*temp) !hno3 conver. factor from ppm to ug/m3 + fhcl =1000.*whcl*pres/(rideal*temp) !hcl conver. factor from ppm to ug/m3 +! + yaq_h2so4_g = gas(ng4)*fh2so4 ! h2so4(g) (in ug/m3) + yaq_hno3_g = gas(ngn)*fhno3 ! hno3(g) (in ug/m3) + yaq_hcl_g = gas(ngc)*fhcl ! hcl(g) (in ug/m3) +! +! ** transfer the gas-phase h2so4, hno3 and hcl to aqueous phase ** +! (and account for molec-weight differences) + gas(ng4) = 0.0 ! all h2so4 is dissolved + gas(ngn) = 0.0 ! all hno3 is dissolved + gas(ngc) = 0.0 ! all hcl is dissolved + yaq(11) = yaq(11) + (yaq_h2so4_g/wh2so4)*wmol(2) ! so4-- increase + yaq(8) = yaq(8) + (yaq_hno3_g/whno3)*wmol(4) ! no3- increase + yaq(9) = yaq(9) + (yaq_hcl_g/whcl)*wmol(15) ! cl- increase + +! +!.....the yaq matrix has been initialized +! + +! test to be removed +! write(27,*)' initial values of the yaqs' +! write(27,*)lwc,rh,temp +! do i = 1, 11 +! write(27,*)i, yaq(i) +! enddo + +! +! variables for integration +! + stime = tbeg_sec ! in seconds + stout = tend_sec ! in seconds +! +! calculation of sodium (needed for the integration routine) +! + sodium = aerosol(nas) +! +! calculate crustal species concentration inside droplets +! (it is used in the aqueous-phase chemistry calculation to +! estimate fe and mn concentrations +! + crustal = aerosol(nar) + salt = aerosol(nas) + +! +! save yaq to yaq_beg +! + do i = 1, 13 + yaq_beg(i) = yaq(i) + end do + +! +! load ipar, rpar +! + ipar(1) = icount + ipar(2) = iprint + ipar(3) = 0 + ipar(4) = 0 + ipar(5) = 0 + ipar(6) = 0 + ipar(7) = 0 + ipar(8) = 0 + + rpar(1) = temp + rpar(2) = pres + rpar(3) = watcont + rpar(4) = watvap + rpar(5) = crustal + rpar(6) = salt + rpar(7) = sodium + rpar(8) = ph_cmuaq_cur + do i = 1, ngas + rpar(8+i) = gascon(i) + end do + +! +! integrate +! + call aqintegr1( meqn1, yaq, stime, stout, rpar, ipar ) + +! +! unload ipar, rpar +! + ph_cmuaq_cur = rpar(8) + +! +! calculate the differences +! + dnit = yaq(8) - tnitold + dchlor = yaq(9) - chlorold + dammon = yaq(10) - ammonold + dsulf = yaq(11) - sulfateold + dhso5 = yaq(12) - hso5old + dhmsa = yaq(13) - hmsaold + +! +! transfer new aqueous concentrations back to aerosol array +! + aerosol(nan) = yaq(8) ! nitrate (aq) in ug/m3 + aerosol(nac) = yaq(9) ! chloride (aq) in ug/m3 + aerosol(naa) = yaq(10) ! ammonium (aq) in ug/m3 + aerosol(na4) = yaq(11) ! sulfate (aq) in ug/m3 + aerosol(nahso5) = yaq(12) ! hso5 (aq) in ug/m3 + aerosol(nahmsa) = yaq(13) ! hmsa (aq) in ug/m3 + +! +! check if the algorithm resulted in negative concentrations +! report the corrections at the warning file +! + negconc_count = 0 + do isp=1, naers + if (aerosol(isp) .lt. 0.0) then + negconc_count = negconc_count + 1 + if (mdiag_negconc .gt. 0) then +! write(2,*)'negative concentration at', stime +! write(2,*)'species=',isp, aerosol(isp) + if (negconc_count .eq. 1) write(6,*) & + '*** module_cmuaq_bulk aqoperator1 neg conc at t', stime + write(6,*) ' isp, conc', isp, aerosol(isp) + end if + aerosol(isp)=1.e-12 + endif + enddo + +! +! return gas yaq results to their original matrices +! +! ** gas-phase species ** +! important : the dissolved s(iv) and h2o2 are transferred +! back to the gas phase +! (this change is applied to "gas" but not to "yaq") +! + gas(nghcho) = yaq(1)/fhcho ! total hcho (ppm) + gas(nghcooh) = yaq(2)/fhcooh ! total hcooh (ppm) + + wso2wsiv = wso2/wmol(kaqx_siv) +! gas(ngso2) = (yaq(3)+yaq(6)*0.7901)/fso2 ! so2(g) (ppm) + gas(ngso2) = (yaq(3)+yaq(6)*wso2wsiv)/fso2 ! so2(g) (ppm) + gas_aqfrac(ngso2) = (yaq(6)*wso2wsiv) / (yaq(3)+yaq(6)*wso2wsiv) + + gas(ngh2o2) = (yaq(4)+yaq(7))/fh2o2 ! h2o2(g) (ppm) + gas_aqfrac(ngh2o2) = yaq(7) / (yaq(4)+yaq(7)) + + gas(nga) = yaq(5)/fammon ! nh3(g) (ppm) + +! +! gas fractions [gas/(gas+aqueous)] for hcho and hcooh +! hcho expression is from subr aqratesa (duma here = hc1 there) +! hcooh expression is from subr electro (duma here = dform there) +! + vlwc = lwc*1.0e-6 ! (liter-h2o)/(liter-air) + + duma = rideal*temp*vlwc*akhen(7) + gas_aqfrac(nghcho) = duma/(duma + 1.0) + + dumb = max( 0.0d0, min( 14.0d0, ph_cmuaq_cur ) ) + dumhion = 10.0**(-dumb) + duma = rideal*temp*vlwc*akhen(8)*(1.+akeq(13)/dumhion) + gas_aqfrac(nghcooh) = duma/(duma + 1.0) + + +! +! if idecomp_hmsa_hso5 > 0, then +! aqueous hso5 is transferred to gas so2 +! aqueous hmsa is transferred to gas so2 & hcho +! (this change is applied to 'gas' & 'aerosol' but not to 'yaq') +! also, if idecomp_hmsa_hso5 > 0 & iradical = 100/1/2 +! aqueous so5- is transferred to gas so2 +! aqueous so4- is transferred to aerosol so4= +! + if (idecomp_hmsa_hso5 .gt. 0) then + wso2whso5 = wso2/wmol(kaqx_hso5m) + wso2whmsa = wso2/wmol(kaqx_hmsa) + whchowhmsa = whcho/wmol(kaqx_hmsa) + gas(ngso2) = gas(ngso2) + & + (yaq(12)*wso2whso5 + yaq(13)*wso2whmsa)/fso2 + gas(nghcho) = gas(nghcho) + yaq(13)*whchowhmsa/fhcho + aerosol(nahso5) = 0.0 + aerosol(nahmsa) = 0.0 + end if + if ( (idecomp_hmsa_hso5 .gt. 0) .and. & + (iabs(iradical-101) .le. 1) ) then + gas(ngso2) = gas(ngso2) + (yaq(19)*wso2/wmol(25))/fso2 + aerosol(na4) = aerosol(na4) + (yaq(18)*wmol(2)/wmol(24)) + end if + +! +! save yaq to yaq_end +! + do i = 1, 13 + yaq_end(i) = yaq(i) + end do + +! +! istat_fatal = fatal error status +! (ipar(3) .ne. 0) --> svode had problems --> 10s digit = -1 +! (ipar(7) .ne. 0) --> fullequil had problems --> 100s digit = -2 +! istat_warn = warning status +! (ipar(5) .ne. 0) --> hybrd had problems --> 10s digit = +1 +! (negconc_count .ne. 0) --> 100s digit = +2 +! + istat_fatal = 0 + if (ipar(3) .ne. 0) istat_fatal = istat_fatal - 10 + if (ipar(7) .ne. 0) istat_fatal = istat_fatal - 200 + + istat_warn = 0 + if (ipar(5) .ne. 0) istat_warn = istat_warn + 10 + if (negconc_count .ne. 0) istat_warn = istat_warn + 200 + +! +! the code neglects the change in the size distribution shape +! of the nonvolatile aerosol components because of the sulfate +! production. the change in the sulfate distribution is calculated +! using the distribution functions while the change in the +! distribution of the volatile inorganic aerosol components will +! calculated by the aerosol module after cloud evaporation +! +! +!.....end of code + return + end subroutine aqoperator1 + + + +!---------------------------------------------------------------------- +! +! this routine prepares the necessary variables for the call +! to the stiff ode integrator (svode) +! its interface to the main code is the same as with the +! assymptotic solver so one can interchange solvers easily +! +! last modification: june 13, 1998 by s.p. +! +!---------------------------------------------------------------------- + subroutine aqintegr1( neqa, y, stime, stout, rpar, ipar ) + + use module_data_cmu_bulkaqchem, only: & + iopt, itask, itol, liw1, lrw1, & + mdiag_svode, meqn1, meqn1max, mf, & + tola, tolr, worki, workr + + use module_cmu_dvode_solver, only: dvode + +! arguments + integer neqa, ipar(*) + double precision y(meqn1max), stime, stout, rpar(*) + +! local variables + integer i, istate, liw, lrw + integer iwork(30+meqn1max) + double precision rwork(22+9*meqn1max+2*meqn1max**2) + double precision atol(meqn1max),rtol(meqn1max) + +! + do i=1, meqn1 + atol(i) = tola ! absolute tolerance in ug/m3 + rtol(i) = tolr ! relative tolerance + if (i .gt. 13) atol(i) = 1.0e-20 + enddo + lrw = lrw1 ! dimension of double precision work vector + liw = liw1 ! dimension of integer work vector + iwork(6) = worki ! steps allowed + rwork(6) = workr ! maximum step in seconds + +! +! ready for the call to svode +! + istate = 1 + + call dvode( fex1, neqa, y, stime, stout, itol, rtol, atol, itask, & + istate, iopt, rwork, lrw, iwork, liw, jex, mf, & + rpar, ipar ) + + if (istate .ne. 2) then +! write(*,*) '*** aqintegr1 -- svode failed' +! write(*,*) ' stime, istate =', stime, istate +! stop + + if (mdiag_svode .gt. 0) then + write(6,*) & + '*** module_cmuaq_bulk, aubr aqintegr1 -- ' // & + 'svode failed, istate =', istate + end if + ipar(3) = ipar(3) + 1 + ipar(4) = istate + endif +! + do i=1, meqn1 + if (y(i) .lt. 0.0) y(i) = 1.e-20 + enddo +! + return + end subroutine aqintegr1 + + + +!---------------------------------------------------------------------- + subroutine fex1( neq, t, y, f, rpar, ipar ) + + use module_data_cmu_bulkaqchem, only: meqn1, meqn1max + +! arguments + integer neq, ipar(*) + double precision t, y(meqn1max), f(meqn1max), rpar(*) + +! local variables + double precision a(meqn1max),b(meqn1max) + + + call aqratesa( meqn1, t, y, a, b, f, rpar, ipar ) + + return + end subroutine fex1 + + + +!---------------------------------------------------------------------- + subroutine jex( neq, t, y, ml, mu, pd, nrowpd, rpar, ipar ) + integer neq, ml, mu, nrowpd, ipar(*) + double precision t, y(neq), pd(nrowpd,neq), rpar(*) + call peg_error_fatal( -1, & + '*** module_cmuaq_bulk, subr jex -- should not be here ***' ) + end subroutine jex + + + +!---------------------------------------------------------------------- +! +! last modification : feb. 15, 1995 by s. pandis +!************************************************************************* +! aqrates.for +!************************************************************************* +! this routine calculates the rates of change of the y's at time tmin +! for the aqueous-phase species +! it does bulk-phase chemistry +! +! + subroutine aqratesa( neq, t, yaq, aqprod, aqdest, yaqprime, & + rpar, ipar ) + + use module_data_cmu_bulkaqchem, only: & + akeq, akhen, akre, avdiam, & + caratio, chyd, cmet, co2_mixrat, con, & + epsfcn, factor, firon, fman, gcon, gmol, & + iradical, ldfjac, lr, & + maxfev, meqn1, meqn1max, ml, mode, mu, & + mdiag_hybrd, mdiag_rsrate, & + ngas, ngch3o2, nghno2, ngho2, & + ngno, ngno2, ngno3, ngo3, ngoh, ngpan, & + nprint, numfunc, & + pres_cmuaq_cur, & + rad, rideal, & + temp_cmuaq_cur, & + wh2o2, whcho, whcooh, wnh3, wso2, wmol, wvol, & + xtol + +! arguments + integer neq, ipar(*) + double precision t, yaq(meqn1max), yaqprime(meqn1max) + double precision aqprod(meqn1max), aqdest(meqn1max) + double precision rpar(*) + +! local variables + integer nfev, info, i, j, n + integer icount, iprint + + double precision spres(22) + double precision c(46) + double precision fgl(21), flg(21), gfgl(21), gflg(21), rp(28), rl(28) + double precision dp(49), dl(49), rr(120) + double precision x(numfunc) + double precision fvec(numfunc),diag(numfunc),fjac(ldfjac,numfunc),r(lr) + double precision qtf(numfunc),wa1(numfunc),wa2(numfunc),wa3(numfunc) + double precision wa4(numfunc) + + double precision, parameter :: one=1. +! + double precision hc1, hc2, wl, wlm, tlwc, vlwc, hyd, arytm, hno2, af + double precision ah, chen + double precision rsrate, sulfrate, sulfrateb + double precision form + double precision ph, pres + double precision qsat + double precision tmin, temp + double precision watvap, watcont, crustal, salt, sodium + ! lwc,wat. vapor in g/m3 + ! crustal species concentration inside droplets (ug/m3) + ! na concentration inside droplets (ug/m3) + double precision dum + double precision gascon(ngas) + + +! +! unload ipar, rpar values +! + icount = ipar(1) + iprint = ipar(2) + temp = rpar(1) + pres = rpar(2) + watcont = rpar(3) + watvap = rpar(4) + crustal = rpar(5) + salt = rpar(6) + sodium = rpar(7) + ph = rpar(8) + do i = 1, ngas + gascon(i) = rpar(8+i) + end do + + temp_cmuaq_cur = temp + pres_cmuaq_cur = pres + +! +! calculation of the temperature for this time (temp) +! (assuming linear temperature change for each operator stepp) +! + tmin = t !in seconds + n = numfunc + + call qsaturation (temp, qsat) ! qsat is in ug/m3 +! +! zero the rate of change vectors +! + do i=1, meqn1 + yaqprime(i)=0.0 + aqprod(i)=0.0 + aqdest(i)=0.0 + enddo +! +! set dummy ph to zero for printing only +! + ph=0.0 +! +! find total lwc +! + tlwc = watcont*1.e6 ! in ug/m3 + vlwc=tlwc*1.e-12 ! vol/vol +! +! check for negative values +! +!sp do i=1, meqn1 +!sp if (yaq(i) .le. 0.) yaq(i)=1.e-20 +!sp enddo +! +! reconstruct the matrices using the available yaq values +! +! ** gas phase concentrations (in ppm) ** +! (some are assumed to remain constant during the aqueous-phase +! chemical processes, the rest are updated) +! note : all hcho and hcooh are still in the gas-phase +! + spres(1) = yaq(3)*rideal*temp/(1000.*wso2*pres) ! so2 (g) + spres(2) = 1.e-20 ! h2so4 (g) + spres(3) = gascon(nghno2) ! hno2 (g) + spres(4) = 1.e-20 ! hno3 (g) [it has already dissolved] +! spres(5) = 350. ! co2 (g) + spres(5) = co2_mixrat ! 2004-nov-15 rce + spres(6) = yaq(4)*rideal*temp/(1000.*wh2o2*pres) ! h2o2 (g) + hc1=rideal*temp*vlwc*akhen(7) + hc2=rideal*temp/(1000.*whcho*pres) + spres(7) = yaq(1)*hc2/(hc1+1.) ! hcho (g) + spres(8) = yaq(2)*rideal*temp/(1000.*whcooh*pres) ! hcooh (g) + spres(9) = gascon(ngno) ! no (g) + spres(10) = gascon(ngno2) ! no2 (g) + spres(11) = gascon(ngo3) ! o3 (g) + spres(12) = gascon(ngpan) ! pan (g) + spres(13) = 1.e-20 ! ch3coooh (g) + spres(14) = 1.e-20 ! ch3ooh (g) + spres(15) = 1.e-20 ! hcl (g) [it has already dissolved] + spres(16) = gascon(ngoh) ! oh (g) + spres(17) = gascon(ngho2) ! ho2 (g) + spres(18) = gascon(ngno3) ! no3 (g) + spres(19) = yaq(5)*rideal*temp/(1000.*wnh3*pres) ! nh3 (g) + spres(20) = gascon(ngch3o2) ! ch3o2 (g) + spres(21) = 1.e-20 ! ch3oh (g) + spres(22) = watvap*rideal*temp/(1000.*18.*pres) ! h2o (g) +! +! calculation of gcon vector (gas-phase concentrations in mole/l) +! + do 5 i=1,22 +! gcon(i) = spres(i)*1.e-6/(0.08206*temp) + gcon(i) = spres(i)*1.e-6/(rideal*temp) +5 continue +! +! ** radius and lwc for the section +! + rad = 0.5*avdiam ! in m + wl = watcont ! in g/m3 + wvol= wl*1.e-6 ! in vol/vol + wlm = wl*1.e6 ! in ug/m3 +! +! loading of all metal species +! note : na+ is an input. the rest of the metal species are +! calculated as a fraction of the crustal aerosol mass. +! + cmet(1) = firon*crustal*1000./(55.85*wlm) ! fe(3+) mol/l + cmet(2) = fman*crustal*1000./(54.9*wlm) ! mn(2+) mol/l + cmet(3) = salt*1000./(23.*wlm) ! na(+) mol/l + cmet(4) = caratio*crustal*1000./(40.08*wlm) ! ca(2+) mol/l +! +! do not let the fe(3+) and mn(2+) concentrations exceed a +! certain limit because they cause extreme stiffness due to +! the reaction s(iv)->s(vi) +! +! if (cmet(1) .gt. 1.0e-5) cmet(1)=1.0e-5 +! if (cmet(2) .gt. 1.0e-5) cmet(2)=1.0e-5 +! +! loading of the main aqueous concentrations (in m) +! + con(1) = yaq(6)*1000./(wmol(1)*wlm) ! s(iv) + if (con(1) .lt. 1.e-20) con(1)=1.e-20 + con(2) = yaq(11)*1000./(wmol(2)*wlm) ! s(vi) + con(3) = 0. ! n(iii) (determined later) + con(4) = yaq(8)*1000./(wmol(4)*wlm) ! n(v) + con(5) = 0. ! co2 (determined later) + con(6) = yaq(7)*1000./(wmol(6)*wlm) ! h2o2 + if (con(6) .lt. 1.e-20) con(6)=1.e-20 + con(7) = akhen(7)*spres(7)*1.e-6 ! hcho + con(8) = 0. ! hcooh (determined later) + con(9) = 1.0e-6*akhen(9)*spres(9) ! no + con(10) = 1.0e-6*akhen(10)*spres(10) ! no2 + con(11) = 1.0e-6*akhen(11)*spres(11) ! o3 + con(12) = 1.0e-6*akhen(12)*spres(12) ! pan + con(13) = 1.0e-6*akhen(13)*spres(13) ! ch3coooh + con(14) = 1.0e-6*akhen(14)*spres(14) ! ch3ooh + con(15) = yaq(9)*1000./(wmol(15)*wlm) ! hcl + con(16) = 0. ! oh (determined later) + con(17) = 0. ! ho2 (determined later) + con(18) = 0. ! no3 (determined later) + con(19) = yaq(10)*1000./(wmol(19)*wlm) ! nh3 + con(20) = 1.0e-6*akhen(20)*spres(20) ! ch3o2 + con(21) = 1.0e-6*akhen(21)*spres(21) ! ch3oh + con(22) = 0. ! cl (determined later) + con(23) = 0. ! cloh- (determined later) + con(24) = 0. ! so4- (determined later) + con(25) = 0. ! so5- (determined later) + con(26) = yaq(12)*1000./(wmol(26)*wlm) ! hso5- + con(27) = yaq(13)*1000./(wmol(27)*wlm) ! hoch2so3- + con(28) = 0. ! co3- (determined later) +! +! set a minimum concentration (to avoid divisions by zero) +! + do i=1, 28 + if (con(i) .lt. 1.0e-20) con(i)=1.0e-20 + enddo + +! +! 27-oct-2005 rce - previously there was a bug here and the code +! would continue on even if fullequil failed +! +! calculation of ph and volatile concentrations (co2, n(iii), hcooh) +! (solve the system of equations) +! if ipar(7)>0, this means that fullequil has failed +! and it's time to shut down the integration +! do this by setting the yaqprime=0, which hopefully will allow +! the integrator to complete +! + if (ipar(7) .le. 0) & + call fullequil(con,spres,cmet,akeq,akhen,vlwc,temp,hyd,ipar) + if (ipar(7) .gt. 0) then + do i = 1, meqn1 + yaqprime(i) = 0.0 + end do + ph=30.0 + return + end if + ph=-log10(hyd) + +! when iradical = 100/101/102, the radical species are computed +! by directly by dvode rather than by hybrd +! the con's for radicals are loaded here (after call to fullequil) +! as that more closely follows the approach with hybrd + if (iabs(iradical-101) .le. 1) then + con(16) = yaq(14)*1000./(wmol(16)*wlm) ! oh (mw = 17) + con(17) = yaq(15)*1000./(wmol(17)*wlm) ! ho2 (mw = 33) + con(18) = yaq(16)*1000./(wmol(18)*wlm) ! no3 (mw = 62) + con(23) = yaq(17)*1000./(wmol(23)*wlm) ! cloh- (mw = 52.5) + con(24) = yaq(18)*1000./(wmol(24)*wlm) ! so4- (mw = 96) + con(25) = yaq(19)*1000./(wmol(25)*wlm) ! so5- (mw = 122) + con(28) = yaq(20)*1000./(wmol(28)*wlm) ! co3- (mw = 60) + dum = 1.0d-35 + con(16) = max( con(16), dum ) + con(17) = max( con(17), dum ) + con(18) = max( con(18), dum ) + con(23) = max( con(23), dum ) + con(24) = max( con(24), dum ) + con(25) = max( con(25), dum ) + con(28) = max( con(28), dum ) + end if + +! + ah = rideal*temp*vlwc*akhen(3)*(1.+akeq(7)/hyd)/pres + hno2=spres(3)/(1.+ah) + con(3)=akhen(3)*(1.+akeq(7)/hyd)*1.e-6*hno2 +! + chen=akhen(5)*(1.+akeq(8)/hyd+akeq(8)*akeq(9)/hyd**2) + con(5)=chen*spres(5)*1.e-6 ! [co2 t]aq m +! + af=rideal*temp*vlwc*akhen(8)*(1.+akeq(13)/hyd)/pres + form=spres(8)/(1.+af) ! new hcooh(g) ppm + con(8)=akhen(8)*(1.+akeq(13)/hyd)*1.e-6*form +! +! we calculate the ionic species concentrations +! + call values(hyd, con, cmet, akeq, c) +! +! bypass the radical calculation by hybrd if necessary +! + if (iradical .eq. 0) go to 270 + if (iabs(iradical-101) .le. 1) go to 280 +! +! this is where the call to hybrd was made when +! the aqueous radical species were treated as steady state +! now we treate iradical.gt.0 same as iradical=100 +! + go to 280 +! +! set the radical concentrations to zero +! +270 continue +! if (info .eq. 2 .or. info .eq. 3 & +! .or. info .eq. 4 .or. info .eq. 5 .or. iradical .eq. 0) then + con(16)=1.e-25 + con(17)=1.e-25 + con(18)=1.e-25 + con(23)=1.e-25 + con(24)=1.e-25 + con(25)=1.e-25 + con(28)=1.e-25 +! endif +! +! pseudo-steady-state approximation for cl radical +! not used because it is of secondary importance +!sp call values(hyd, con, cmet, akeq,c) +!sp call react(c,cmet,con,akre,rr,arytm) +!sp pro=rr(23)+rr(49)+rr(96) +!sp if (con(22) .le. 0.0)then +!sp con(22) = 1.e-20 +!sp go to 20 +!sp endif +!sp destr=(rr(24)+rr(25)+rr(26)+rr(27)+rr(28)+rr(29)+rr(30)+rr(42)+ +!sp & rr(56)+rr(61)+rr(69)+rr(109))/con(22) +!sp if (destr .eq. 0.0)then +!sp con(22)= 1.e-10 +!sp go to 20 +!sp endif +!sp con(22)=pro/destr +!sp 20 continue +! + +280 continue + call values(hyd, con, cmet, akeq,c) +! +! final calculation of reaction rates +! + call react(c,cmet,con,akre,rr,arytm) +! +! calculation of net production and consumption rates +! + call addit(rr, arytm, rp, rl) +! +! calculation of mass transfer rates +! + call mass(wvol,rad,temp,gcon,con,c,akeq,akhen,fgl,flg,gfgl,gflg) +! +! calculation of net rates of change +! + call differ(rp,rl,fgl,flg,gfgl,gflg,dp,dl) +! +! calculation of right hand sides of the derivatives +! +! ** gas-phase species ** +! (rates in ug/m3 air s) + yaqprime(1) = 1.e9*wvol*wmol(7)*(rp(7)-rl(7)) ! hcho t + aqprod(1) = 1.e9*wvol*wmol(7)*rp(7) + aqdest(1) = 1.e9*wvol*wmol(7)*rl(7) +! + yaqprime(2) = 1.e9*wvol*wmol(8)*(rp(8)-rl(8)) ! hcooh t + aqprod(2) = 1.e9*wvol*wmol(8)*rp(8) + aqdest(2) = 1.e9*wvol*wmol(8)*rl(8) +! + yaqprime(3) = 1.e9*gmol(1)*(dp(29)-dl(29)) ! so2(g) + aqprod(3) = 1.e9*gmol(1)*dp(29) + aqdest(3) = 1.e9*gmol(1)*dl(29) +! + yaqprime(4) = 1.e9*gmol(6)*(dp(34)-dl(34)) ! h2o2(g) + aqprod(4) = 1.e9*gmol(6)*dp(34) + aqdest(4) = 1.e9*gmol(6)*dl(34) +! + yaqprime(5) = 1.e9*gmol(19)*(dp(47)-dl(47)) ! nh3(g) + aqprod(5) = 1.e9*gmol(19)*dp(47) + aqdest(5) = 1.e9*gmol(19)*dl(47) +! +! ** aqueous-phase species ** +! + yaqprime(6)= 1.e9*wvol*wmol(1)*(dp(1)-dl(1)) ! s(iv) + aqprod(6) = 1.e9*wvol*wmol(1)*dp(1) + aqdest(6) = 1.e9*wvol*wmol(1)*dl(1) +! + yaqprime(7)= 1.e9*wvol*wmol(6)*(dp(6)-dl(6)) ! h2o2 + aqprod(7) = 1.e9*wvol*wmol(6)*dp(6) + aqdest(7) = 1.e9*wvol*wmol(6)*dl(6) +! + yaqprime(8)= 1.e9*wvol*wmol(4)*(dp(4)-dl(4)) ! n(v) + aqprod(8) = 1.e9*wvol*wmol(4)*dp(4) + aqdest(8) = 1.e9*wvol*wmol(4)*dl(4) +! + yaqprime(9)= 1.e9*wvol*wmol(15)*(dp(15)-dl(15)) ! cl- + aqprod(9) = 1.e9*wvol*wmol(15)*dp(15) + aqdest(9) = 1.e9*wvol*wmol(15)*dl(15) +! + yaqprime(10)= 1.e9*wvol*wmol(19)*(dp(19)-dl(19)) ! nh4+ + aqprod(10) = 1.e9*wvol*wmol(19)*dp(19) + aqdest(10) = 1.e9*wvol*wmol(19)*dl(19) +! + yaqprime(11)= 1.e9*wvol*wmol(2)*(dp(2)-dl(2)) ! s(vi) + aqprod(11) = 1.e9*wvol*wmol(2)*dp(2) + aqdest(11) = 1.e9*wvol*wmol(2)*dl(2) +! + yaqprime(12)= 1.e9*wvol*wmol(26)*(dp(26)-dl(26)) ! hso5- + aqprod(12) = 1.e9*wvol*wmol(26)*dp(26) + aqdest(12) = 1.e9*wvol*wmol(26)*dl(26) +! + yaqprime(13)= 1.e9*wvol*wmol(27)*(dp(27)-dl(27)) ! hmsa + aqprod(13) = 1.e9*wvol*wmol(27)*dp(27) + aqdest(13) = 1.e9*wvol*wmol(27)*dl(27) +! + if (iabs(iradical-101) .le. 1) then +! + yaqprime(14)= 1.e9*wvol*wmol(16)*(dp(16)-dl(16)) ! oh(aq) + aqprod(14) = 1.e9*wvol*wmol(16)*dp(16) + aqdest(14) = 1.e9*wvol*wmol(16)*dl(16) +! + yaqprime(15)= 1.e9*wvol*wmol(17)*(dp(17)-dl(17)) ! ho2(aq) + aqprod(15) = 1.e9*wvol*wmol(17)*dp(17) + aqdest(15) = 1.e9*wvol*wmol(17)*dl(17) +! + yaqprime(16)= 1.e9*wvol*wmol(18)*(dp(18)-dl(18)) ! no3(aq) + aqprod(16) = 1.e9*wvol*wmol(18)*dp(18) + aqdest(16) = 1.e9*wvol*wmol(18)*dl(18) +! + yaqprime(17)= 1.e9*wvol*wmol(23)*(dp(23)-dl(23)) ! cloh-(aq) + aqprod(17) = 1.e9*wvol*wmol(23)*dp(23) + aqdest(17) = 1.e9*wvol*wmol(23)*dl(23) +! + yaqprime(18)= 1.e9*wvol*wmol(24)*(dp(24)-dl(24)) ! so4-(aq) + aqprod(18) = 1.e9*wvol*wmol(24)*dp(24) + aqdest(18) = 1.e9*wvol*wmol(24)*dl(24) +! + yaqprime(19)= 1.e9*wvol*wmol(25)*(dp(25)-dl(25)) ! so5-(aq) + aqprod(19) = 1.e9*wvol*wmol(25)*dp(25) + aqdest(19) = 1.e9*wvol*wmol(25)*dl(25) +! + yaqprime(20)= 1.e9*wvol*wmol(28)*(dp(28)-dl(28)) ! co3-(aq) + aqprod(20) = 1.e9*wvol*wmol(28)*dp(28) + aqdest(20) = 1.e9*wvol*wmol(28)*dl(28) + end if +! +! calculation of appropriate destruction rate +! + do 50 i=1, meqn1 + if (yaq(i) .le. 1.e-20) then + aqdest(i) = 0.0 + go to 50 + endif + aqdest(i) = aqdest(i)/yaq(i) + 50 continue +! +! change to avoid divisions by zero in integration +! + do i=1,meqn1 + if (aqdest(i) .le. 1.e-18) aqdest(i)=1.e-18 + enddo + +! +! calculation of characteristic times (used for debugging) +! +!db tsm=100. +!db do 110 i=1, meqn1 +! +!db if (aqdest(i) .le. 1.e-10) go to 110 +!db tchar=1./aqdest(i) +! +!db if (tchar .lt. 0.01)then +!db write(80,*)tmin,i,yaq(i),yaqprime(i),tchar +!db write(6,*) i,yaq(i),yprime(i) +!db endif +! +!db if (tchar .lt. tsm) then +!db tsm=tchar +!db endif +! +!db110 continue + +! +! mass balance for sulfur +! original sulfrate calc includes so2(g), so2(aq), so4=, hso5-, hmsa +! and does not always balance +! sulfrateb calc also includes so4-, so5- and gives a closer balance +! +! sulfrate=yaqprime(3)/gmol(1)+yaqprime(6)/wmol(1)+ & +! yaqprime(11)/wmol(2) +! rsrate=sulfrate/(abs(yaqprime(3))+abs(yaqprime(11)) + & +! abs(yaqprime(6))) +! if (abs(rsrate) .ge. 0.01) then +! write(80, *)'problem at ',tmin/60. +! write(80, *) yaqprime(3),yaqprime(6),yaqprime(11) +! write(80, *) rsrate +! write(80, *)'************************' +! endif + sulfrate = (yaqprime( 3)/gmol( 1)) + (yaqprime( 6)/wmol( 1)) + & + (yaqprime(11)/wmol( 2)) + (yaqprime(12)/wmol(26)) + & + (yaqprime(13)/wmol(27)) + sulfrateb = sulfrate + & + 1.0e9*wvol*(rp(24) - rl(24) + rp(25) - rl(25)) + rsrate = abs(yaqprime( 3)/gmol( 1)) + abs(yaqprime( 6)/wmol( 1)) + & + abs(yaqprime(11)/wmol( 2)) + abs(yaqprime(12)/wmol(26)) + & + abs(yaqprime(13)/wmol(27)) + rsrate = max(rsrate, 1.0d-30) + if (mdiag_rsrate .gt. 0) then + if (abs(sulfrateb/rsrate) .ge. 1.0e-5) then + write(6,*) + write(6,'(a,1p,3e11.2)') & + 'aqratesa sulfbal prob - rerr, rerrb, t =', & + (sulfrate/rsrate), (sulfrateb/rsrate), tmin + write(6,'(a,1p,e15.6/4e15.6)') & + 'yaqprime/wmol so2,siv,svi,hso5-,hmsa =', & + (yaqprime(3)/gmol(1)), (yaqprime(6)/wmol(1)), & + (yaqprime(11)/wmol(2)), (yaqprime(12)/wmol(26)), & + (yaqprime(13)/wmol(27)) + write(6,*) + end if + end if + +! +! diagnostic output +! + icount=icount+1 + if (icount .ge. iprint)then +!rce write(6,120)tmin/60.,yaq(11) !,ph,rsrate,x(1)*1.e12,yaq(13) +!rce write(79,*)tmin/60.,ph +! printing of all reaction rates for debugging +!sp write(3,*)tmin/60.,'****(um/hr)*******' +!sp do i=1,109 +!sp write(3,*)i,rr(i)*1.e6*3600. +!sp enddo + icount=0 + endif +!120 format(1x,2(1x,f8.4)) +120 format( 'aqratesa - tmin, yaq(11)=so4', 2(1x,f8.4) ) + +! +! load ipar, rpar values +! + ipar(1) = icount + rpar(8) = ph + +! write(*,'(a,1p,8e10.2 )') 'xxx t,yaq1-7 ', t, (yaq(i), i=1,7) +! write(*,'(a,1p,8e10.2 )') 'xxx t,yaq8-13', t, (yaq(i), i=8,13) +! write(*,'(a,1p,8e10.2 )') 'xxx t,rad-con', t, & +! (con(i), i=16,18), (con(i), i=23,25), (con(i), i=28,28) +! dum = 1.e9*wvol +! write(*,'(a,1p,8e10.2/)') 'xxx t,rad-yaq', t, & +! (con(i)*wmol(i)*dum, i=16,18), (con(i)*wmol(i)*dum, i=23,25), & +! (con(i)*wmol(i)*dum, i=28,28) + + return + end subroutine aqratesa + + + + +!************************************************************************ +! this routine calculates the the steady state species concentrations +!************************************************************************ + subroutine steady(radius,temp,c,con,gcon,akeq,akhen,akre) +! +!..inputs: +! radius : droplet radius in m +! temp : temperature (in k) +! c(46) : the concentrations of the rest of the aqueous-phase species +! gcon(22) : gas-phase concentrations +! akeq,akhen,akre : reaction constants +!..outputs: +! x(8) the values of the steady state species concentrations +! + +! arguments + double precision radius, temp + double precision c(46),gcon(22),akeq(17),akhen(21),akre(120) + double precision con(28) + +! local variables + integer icount + double precision a1, a2, a3, a4, acc, airl + double precision dg, ho2, o2 + double precision kn,n,ikn,kmt + double precision rideal + double precision x(8) +! +! airl is the mean free path of air. later we have to substitute +! the numerical value given here by a function of temperature +! airl=65x10-9 m + airl=65.e-9 +! kn is the knudsen number + kn=airl/radius + ikn=1.0/kn +! acc is the accomodation coefficient assumed the same here for +! all the species + acc=0.01 +! n is the coefficient entering the flux expression + n=1.0/(1.+((1.33+0.71*ikn)/(1.+ikn)+4.*(1.-acc) & + /(3.*acc))*kn) +! dg is the gas phase diffusivity assumed here the same for all +! the gases. dg=1.x10-5 m**2/sec + dg=1.0e-5 +! rideal is the gas constant in [atm/K/(mol/liter)] + rideal=0.082058 + kmt=(3.0*n*dg)/(radius*radius) +! +! iteration loop +! + do icount=1,2 + +! +! no3 calculation +! + x(3)=(kmt*gcon(18))/(akre(43)*c(8)+akre(45)+akre(46)*c(29)+ & + akre(47)*c(30) +akre(48)*c(14)+ & + akre(49)*c(27)+akre(54)*c(18)+akre(59)*c(19)+akre(71)*c(35)+ & + akre(109)*c(2)+kmt/(akhen(18)*rideal*temp)) + con(18)=x(3) +! +! so4- calculation +! + x(5)=(akre(109)*c(2)*x(3)+2.*akre(86)*c(40)*c(40)) & + /(akre(89)*c(41)+akre(92)*c(2)+ & + akre(93)*c(3)+akre(94)*c(29)+akre(95)*c(30)+ & + akre(96)*c(45)+akre(97)*c(14)+akre(98)*c(8)+ & + akre(99)*c(12)+akre(100)*c(19)+akre(101)*c(27)+ & + akre(102)*c(18)+akre(108)*c(35)) + c(39)=x(5) + con(24)=c(39) +! + a1=c(46)/(akeq(15)+c(46)) + a2=akeq(15)/(akeq(15)+c(46)) +! +! ho2 calculation +! + x(2)=((akre(48)*c(14)+akre(54)*c(18)+akre(59)*c(19)+ & + akre(71)*c(35)) * x(3)+ & + (akre(97)*c(14)+akre(100)*c(19)+akre(102)*c(18)+ & + akre(108)*c(35))*x(5)+ & + 2.0*akre(14)*c(45)*c(22)+ & + akre(28)*c(14)*c(36)+akre(29)*c(14)*c(37)+akre(55)*c(18)*c(22)+ & + akre(56)*c(18)*c(36)+akre(61)*c(19)*c(36)+akre(69)*c(35)*c(36)+ & + akre(65)*c(25)+akre(15)*c(22)*c(15)+akre(58)*c(19)*c(22)+ & + kmt*gcon(17) +akre(5)*c(14)*c(28)+akre(11)*c(22)*c(28)+ & + akre(20)*c(14)*c(44)+akre(50)*c(17)*c(28)+akre(52)*c(18)*c(28)+ & + akre(57)*c(19)*c(28)+akre(60)*c(19)*c(44)+akre(67)*c(35)*c(28)+ & + akre(68)*c(35)*c(44)+akre(84)*c(18)*c(40)+ & + akre(85)*c(19)*c(40))/ & + (a1*(akre(3)*c(28)+2.*akre(6)*c(29)+2.*akre(7)*c(30)+ & + akre(9)*c(14)+akre(12)*c(22)+akre(25)*c(36)+ & + akre(27)*c(37)+akre(46)*x(3)+akre(63)*c(34)+ & + akre(94)*c(39)+akre(107)*c(3))+ & + a2*(akre(4)*c(28)+2.*akre(8)*c(30)+akre(10)*c(14)+ & + akre(13)*c(22)+akre(18)*c(12)+akre(19)*c(44)+akre(26)*c(36)+ & + akre(47)*x(3)+akre(64)*c(34)+akre(83)*c(40)+akre(95)*c(39)) & + +(kmt*a1)/(akhen(17)*rideal*temp)) +! + ho2=(x(2)*c(46))/(akeq(15)+c(46)) + o2=(x(2)*akeq(15))/(akeq(15)+c(46)) + c(29)=ho2 + c(30)=o2 + con(17)=c(29)+c(30) +! + a3=(akre(21)*akre(22)*c(27))/(akre(22)+akre(23)*c(46)) + a4=(akre(22)*akre(24)*c(37))/(akre(22)+akre(23)*c(46)) +! +! oh calculation +! + x(1)=(2.*akre(1)*c(14)+akre(15)*c(15)*c(22)+akre(30)*c(45)* & + c(36)+ & + akre(35)*c(7)+akre(36)*c(8)+akre(44)*c(10)+akre(55)*c(18)*c(22)+ & + akre(58)*c(19)*c(22)+akre(65)*c(25)+kmt*gcon(16)+a4+ & + (akre(9)*c(14)+akre(12)*c(22)+akre(107)*c(3))*ho2+ & + (akre(10)*c(14)+akre(13)*c(22))*o2+akre(96)*c(45)*x(5))/ & + (akre(3)*ho2+akre(4)*o2+akre(5)*c(14)+akre(11)*c(22)+ & + akre(17)*c(12)+akre(21)*c(27)+akre(33)*c(20)+akre(34)*c(21)+ & + akre(37)*c(7)+akre(38)*c(8)+akre(50)*c(17)+akre(52)*c(18)+ & + akre(57)*c(19)+akre(66)*c(25)+akre(67)*c(35)+akre(80)*c(3)+ & + akre(81)*c(2)+akre(88)*c(41)+akre(115)*c(42)+ & + kmt/(akhen(16)*rideal*temp)-a3) + c(28)=x(1) + con(16)=c(28) +! +! cloh- calculation +! + x(4)=(akre(21)*c(27)*x(1)+akre(24)*c(37))/(akre(22)+ & + akre(23)*c(46)) + c(38)=x(4) + con(23)=c(38) +! +! co3- calculation +! + x(7)=(akre(17)*c(12)*x(1)+akre(99)*c(12)*x(5)+akre(18)*c(12)*o2)/ & + (akre(19)*o2+akre(20)*c(14)+akre(41)*c(8)+akre(60)*c(19)+ & + akre(68)*c(35)) + c(44)=x(7) + con(28)=c(44) +! +! so5- calculation +! + x(6)=(akre(116)*c(2)*c(36)+(akre(80)*c(3)+akre(81)*c(2)+ & + akre(88)*c(41)+akre(115)*c(42))*x(1)+(akre(89)*c(41)+ & + akre(92)*c(2)+akre(93)*c(3))*x(5))/ & + (akre(83)*o2+akre(84)*c(18)+akre(85)*c(19)+2.*akre(86)*c(40)) + c(40)=x(6) + con(25)=c(40) + + enddo +! + + + return + end subroutine steady + + + + +! *********************************************************************** +! the routine fullequil solves the electroneutrality equation +! using bisection method when the concentrations of [c], n(iii) +! and hcooh are unknown. +! inputs in the sub are con(28),spres(21),cmet(4),akeq(17),akhen(21). +! output is the value of [h+] +! the routine electro gives values of the electroneutrality equation. +! inputs in the sub are x=[h+],con(28),cmet(4),akeq(17). +! output is the value of f ( f(x)=0.0 at the solution) +! *********************************************************************** + + subroutine fullequil(acon,aspres,acmet,aakeq,aakhen,awv, & + atemp,axsol,ipar) + + use module_data_cmu_bulkaqchem, only: mdiag_fullequil + +! arguments + integer ipar(*) + double precision acon(28), aspres(21), acmet(4), aakeq(17), aakhen(21) + double precision awv, atemp, axsol + +! local variables + integer i, k, ntry + integer ipass_01, idum_01 + double precision aa, bb, error, f, fa, fm, rtol, x, xm + double precision wv, temp, xsol + double precision con(28), spres(21), cmet(4), akeq(17), akhen(21) +! +! change variables to double precision to avoid low ph errors +! + ipass_01 = 1 + idum_01 = 0 +300 continue + + do k=1,28 + con(k)=acon(k) + enddo +! + do k=1,21 + spres(k)=aspres(k) + akhen(k)=aakhen(k) + enddo +! + do k=1,4 + cmet(k)=acmet(k) + enddo +! + do k=1,17 + akeq(k)=aakeq(k) + enddo +! + wv=awv + temp=atemp +! +! we find the initial interval [aa,bb] for the bisection method +! new version (31/10/87) + x=10.0d0**(-14) + call electro(x,fa,con,spres,cmet,akeq,akhen,wv,temp) + aa=x + +! do 1035 i=-14,1 + do 1035 i = -(14+idum_01), (1+idum_01) + x=10.0d0**i + call electro(x,f,con,spres,cmet,akeq,akhen,wv,temp) + if (f*fa .ge. 0.0d0) then + aa=x + fa=f + else + bb=x +! fb=f + go to 1040 + end if +1035 continue + +! 27-oct-2005 rce - previously there was a bug here and the code +! continued on to label 1040 after reporting the "mistake in fullequil" +! Now the code tries a greater range of initial ph values, +! then gives up if it fails. +! +! unable to find 2 initial hion values that bracket the "solution" +! if ipass_01 = 1, try again + if (ipass_01 .eq. 1) then + write(6,*) & + '*** module_cmuaq_bulk - mistake in fullequil with ipass_01 = 1' + ipass_01 = 2 + idum_01 = 5 + goto 300 + else if (ipass_01 .eq. 2) then + write(6,*) & + '*** module_cmuaq_bulk - mistake in fullequil with ipass_01 = 2' + ipass_01 = 3 + idum_01 = 10 + goto 300 + end if + +! otherwise, report the error and exit + ipar(7) = ipar(7) + 1 + if (mdiag_fullequil .gt. 0) then + write(6,*) & + '*** module_cmuaq_bulk - mistake in fullequil - con, cmet =' + write(6,*) con, cmet + return + end if + +1040 continue +! +! bisection method for the solution of the equation +! rtol : relative tolerance + ntry=0 +! 02-nov-2005 rce - smaller rtol for h+ makes dvode run faster +! rtol=0.00001d0 + rtol=1.0d-8 +1050 error= dabs(bb-aa)/aa + ntry=ntry+1 + if (error .le. rtol) then + xsol=(aa+bb)/2.0d0 + axsol=xsol ! single precision + return + end if + xm=(aa+bb)/2.0d0 + call electro(xm,fm,con,spres,cmet,akeq,akhen,wv,temp) + if (fa*fm .gt. 0.0d0) then + aa=xm + fa=fm + else + bb=xm +! fb=fm + end if + go to 1050 + end subroutine fullequil + + + + +! *********************************************************************** +! routine that gives values of the electroneutrality equation +! called by fullequil +! *********************************************************************** + + subroutine electro(x,f,con,spres,cmet,zkeq,zkhen,wv,temp) + + use module_data_cmu_bulkaqchem, only: & + mprescribe_ph, rideal, xprescribe_ph + +! arguments +! +! original subr arguments were akeq & akhen +! renamed them to zkeq & zkhen +! to avoid conflict with module_data_cmu_bulkaqchem +! + double precision x, f, wv, temp + double precision con(28),spres(21),cmet(4),zkeq(17),zkhen(21) + +! local variables + double precision bparam, cparam, cl, dfac, dform, diak + double precision f1, f2, f3, f4, f5, form, hcl, hno2 + double precision cc(46) +! + cc(2)=(zkeq(1)*con(1)*x)/(x*x+zkeq(1)*x+zkeq(1)*zkeq(2)) ! hso3- + cc(3)=(zkeq(1)*zkeq(2)*con(1))/(x*x+zkeq(1)*x+zkeq(1)*zkeq(2)) ! so3-- + cc(5)=(zkeq(3)*con(2)*x)/(x*x+zkeq(3)*x+zkeq(3)*zkeq(4)) ! hso4- + cc(6)=(zkeq(3)*zkeq(4)*con(2))/(x*x+zkeq(3)*x+zkeq(3)*zkeq(4)) ! so4-- +! +! ** no2- calculation from equilibrium ** + dfac=rideal*temp*wv*zkhen(3)*(1.+zkeq(7)/x) + hno2 = spres(3)/(1.+dfac) ! new hno2(g) in ppm + cc(8)=zkhen(3)*1.e-6*(zkeq(7)/x)*hno2 +! + cc(10)=(zkeq(6)*con(4))/(x+zkeq(6)) ! no3- +! +! ** co2 equilibrium (constant gas co2 concentration) ** + cc(12)= zkeq(8)*zkhen(5)*spres(5)*1.e-6/x + cc(13)= zkeq(9)*cc(12)/x +! + cc(15)=(zkeq(5)*con(6))/(x+zkeq(5)) ! ho2- +! +! ** hcoo- equilibrium (partitioning with gas-phase) ** + dform=rideal*temp*wv*zkhen(8)*(1.+zkeq(13)/x) + form=spres(8)/(1.+dform) ! new hcooh + cc(19)=zkhen(8)*1.e-6*(zkeq(13)/x)*form +! + cc(30)=(zkeq(15)*con(17))/(x+zkeq(15)) ! o2- + cc(38)=con(23) ! cloh- + cc(39)=con(24) ! so4- + cc(40)=con(25) ! so5- + cc(41)=con(26) ! hso5- + cc(42)=(x*con(27))/(x+zkeq(17)) ! hoch2so3- + cc(43)=(zkeq(17)*con(27))/(x+zkeq(17)) ! -och2so3- + cc(44)=con(28) ! co3- + cc(45)=zkeq(11)/x ! oh- + + bparam=zkeq(16)+con(15)-con(22) + cparam=zkeq(16)*con(22) + diak=bparam*bparam+4.0*cparam + if (diak .le. 0.) diak=1.0e-20 + cl=(-bparam+(diak)**0.5)/2.0 + hcl=(x*(con(15)-con(22)+cl))/(x+zkeq(14)) + cc(27)=(zkeq(14)*hcl)/x ! cl- + cc(36)=(zkeq(14)*cl*hcl)/(zkeq(16)*x) ! cl2- + + cc(33)=(zkeq(10)*x*con(19))/(zkeq(11)+zkeq(10)*x) ! nh4+ + cc(46)=x ! h+ + + f1=cc(2)+2.0*cc(3)+cc(5)+2.0*cc(6)+cc(8)+cc(10) + f2=cc(12)+2.0*cc(13)+cc(15)+cc(19)+cc(27)+cc(30) + f3=cc(36)+cc(38)+cc(39)+cc(40)+cc(41)+cc(42) + f4=2.0*cc(43)+cc(44)+cc(45)-cc(33)-cc(46) + f5=-3.0*cmet(1)-2.0*cmet(2)-cmet(3)-2.0*cmet(4) + + f=f1+f2+f3+f4+f5 + + if (mprescribe_ph .gt. 0) then + f = 10.0**(-xprescribe_ph) - x + end if + + return + end subroutine electro + + + +!---------------------------------------------------------------------- +! +! routines used by the aqeous-phase module +! +! 1. dropinit : initialization + + subroutine dropinit + + use module_data_cmu_bulkaqchem, only: & + amol, gmol, & + wmol, wh2o2, wh2so4, whcho, whcl, whcooh, whno3, wnh3, wso2 + + +! local variables + + +! +! loading of molecular weights +! + wso2 = 64. + wh2o2 = 34. + whcho = 30. + whcooh = 46. + wnh3 = 17. + whno3 = 63. + whcl = 36.5 + wh2so4 = 98. +! +! molecular weights +! + wmol(1)= 81.0e0 + wmol(2)= 96.0e0 + wmol(3)= 47.0e0 + wmol(4)= 62.0e0 + wmol(5)= 62.0e0 + wmol(6)= 34.0e0 + wmol(7)= 48.0e0 ! was previously 60.0e0 + wmol(8)= 46.0e0 + wmol(9)= 30.0e0 + wmol(10)=46.0e0 + wmol(11)=48.0e0 + wmol(12)=121.0e0 + wmol(13)=76.0e0 + wmol(14)=48.0e0 + wmol(15)=35.5e0 + wmol(16)=17.0e0 + wmol(17)=33.0e0 + wmol(18)=62.0e0 + wmol(19)=18.0e0 + wmol(20)=47.0e0 + wmol(21)=32.0e0 + wmol(22)=35.5e0 + wmol(23)=52.50e0 + wmol(24)=96.0e0 + wmol(25)=112.0e0 + wmol(26)=113.0e0 + wmol(27)=111.0e0 + wmol(28)=60.00e0 + wmol(29)=18.0e0 +! + amol(1)= 55.85e0 + amol(2)= 55.0e0 + amol(3)= 23.0e0 +! + gmol(1)=64.0 + gmol(2)=98.08 + gmol(3)=47.02 + gmol(4)=63.02 + gmol(5)=44.01 + gmol(6)=34.02 +! 09-nov-2005 rce - set gmol(6) == wh2o2 to conserve h2o2 + gmol(6)=34.0 + gmol(7)=30.03 + gmol(8)=46.00 + gmol(9)=30.01 + gmol(10)=46.01 + gmol(11)=48.00 + gmol(12)=121.05 + gmol(13)=76.00 + gmol(14)=48.00 + gmol(15)=36.50 + gmol(16)=17.00 + gmol(17)=33.01 + gmol(18)=62.01 + gmol(19)=17.00 + gmol(20)=47.00 + gmol(21)=32.00 + gmol(22)=18.00 + + return + end subroutine dropinit + + + +!---------------------------------------------------------------------- + subroutine qsaturation(temp,qsat) +! +! this routine calculates the saturation mass concentration (in ug/m3) +! over liquid water for a temperature temp (k) +! + +! arguments + double precision temp,qsat + +! local variables + double precision psat, t ! these should be double precision ? + double precision rideal,a0,a1,a2,a3,a4,a5,a6,esat,csat +! + t = temp-273.15 ! in c + rideal = 0.082058d0 ! gas constant in [atm/K/(mol/liter)] + a0 = 6.107799961d-0 + a1 = 4.436518521d-1 + a2 = 1.428945805d-2 + a3 = 2.650648471d-4 + a4 = 3.031240396d-6 + a5 = 2.034080948d-8 + a6 = 6.136820929d-11 +! + esat=a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+a6*t))))) ! in mb + psat = esat/(1000.0*1.01325) ! in atm + csat = psat/(rideal*temp) ! in mole/l + qsat = 18000.0d0*csat*1.e6 ! in ug/m3 +! write(6,*)t,esat/1000.,qsat + return + end subroutine qsaturation + + + + +! s u b r o u t i n e s f o r d r o p l e t p r o g r a m +!************************************************************************ +! this routine calculates the 20 equilibrium costants {akeq}, the 20 +! henry's law costants {akhen} and the 120 reaction rate costants {akre} +! with only input the temperature (temp). +! included in the routine are the corresponding enthalpies +! {dheq,dhhen,dhre} and the costants at 298 k {bkeq,bkhen,bkre}. +!************************************************************************ + + subroutine constants(temp) + + use module_data_cmu_bulkaqchem, only: akeq, akhen, akre, & + maqurxn_all, maqurxn_sulf1, mopt_eqrt_cons + +! arguments + double precision temp + +! local variable + integer i, iusei +! dimension akeq(17),akhen(21),akre(120) + double precision, save :: dheq(17),dhhen(21),dhre(120) + double precision, save :: bkeq(17),bkhen(21),bkre(120) + + data dheq/1960.,1500.,0.,2720.,-3730.,8700.,-1260., & + -1000.,-1760., & + -450.,-6710.,4020.,-20.,6900.,0.e0,0.,0./ + data bkeq/1.23e-2,6.61e-8,1.e3,1.02e-2,2.2e-12,15.4,5.1e-4, & + 4.46e-7,4.68e-11,1.75e-5,1.0e-14,1.82e3,1.78e-4,1.74e6,3.5e-5, & + 5.26e-6,2.0e-12/ + data dhhen/3120.,0.0,4780.,8700.,2420.,6620., & + 6460.e0,5740.e0,1480.e0, & + 2500.e0,2300.e0,5910.e0,6170.e0,5610.e0,2020.e0,5280.e0, & + 6640.e0,8700.e0,3400.e0, & + 5600.e0,4900.e0/ + data bkhen/1.23e0,0.0e0,49.e0,2.1e5,3.4e-2,7.45e4,6.3e3, & + 3.5e3,1.9e-3, & + 0.01e0,1.13e-2,2.9e0,473.e0,227.e0,727.e0,25.e0,2000.e0,2.1e5, & + 75.e0,6.e0,220.e0/ + + + data dhre/0.0e0,0.0e0,-1500.e0,-1500.e0,-1700.e0,-2365.e0, & + -1500.e0,0.0e0,0.0e0, & + 0.0e0,0.0e0,0.0e0,-1500.e0,0.0e0,-2520.e0,0.0e0,-1910.e0, & + 0.0e0,-1500.e0,-2820.e0, & + -1500.e0,0.0e0,0.0e0,0.0e0,-1500.e0,-1500.e0,-1500.e0, & + -3370.e0,0.0e0,-2160.e0, & + -1500.e0,-1500.e0,-1500.e0,-1500.e0,0.0e0,0.0e0,-1500.e0, & + -1500.e0,-6693.e0,-6950.e0, & + 0.0e0,-1500.e0,-1500.e0,0.0e0,0.0e0,-1500.e0,-1500.e0, & + -2800.e0,-1500.e0,-1500.e0, & + 0.0e0,-1500.e0,-5180.e0,-3200.e0,0.0e0,-4300.e0,-1500.e0, & + 0.0e0,-1500.e0,-3400.e0, & + -2600.e0,0.0e0,-3000.e0,-1600.e0,0.0e0,-1700.e0,-1500.e0, & + -4500.e0,-4400.e0,-1800.e0, & + -2800.e0,0.0e0,-5530.e0,-5280.e0,-4430.e0,-13700.e0, & + -11000.e0,-13700e0,-11000.e0, & + -1500.e0,-1500.e0,-3100.e0,-1500.e0,-5300.e0,-4000.e0, & + -1500.e0,-4755.e0,-1900.e0, & + 0.0e0,-6650.e0,-7050.e0,-1500.e0,-1500.e0,-1500.e0, & + -1500.e0,-1500.e0,-2000.e0, & + -1500.e0,-2100.e0,-1500.e0,-1500.e0,-2700.e0,0.0e0, & + -3800.e0,-4000.e0,0.0e0,0.0e0, & + -1800.e0,0.0e0,0.0e0,0.0e0,-6100.e0,-4900.e0, & + -4500.e0,-1500.e0,-1500.e0, & + -2000.e0,0.e0,-1800.e0,120.e0/ + + + data bkre/2.5e-6,2.0e-5,7.0e9,1.0e10,2.7e7, & + 8.6e5,1.0e8,0.3e0,0.5e0, & + 0.13e0,2.0e9,1.0e4,1.5e9,70.e0,2.8e6,7.8e-3,1.5e7, & + 1.5e6,4.0e8,8.0e5, & + 4.3e9,6.1e9,2.1e10,1.3e3,4.5e9,1.0e9,3.1e9, & + 1.4e5,4.5e7,7.3e6, & + 2.0e8,1.0e8,2.0e10,1.3e9,3.7e-5,6.3e-6,1.0e9, & + 1.0e10,6.3e3,5.0e5, & + 4.0e5,2.5e8,1.2e9,1.0e-7,1.0e-5,4.5e9,1.0e9, & + 1.0e6,1.0e8,2.0e9, & + 0.1e0,1.6e8,4.6e-6,2.1e5,5.0e0,6.7e3,2.5e9,100.0e0, & + 6.0e7,1.1e5,1.9e6, & + 4.0e-4,7.6e5,5.0e7,5.4e-7,2.7e7,4.5e8,2.6e3, & + 3.5e3,1.9e7,1.0e6, & + 2.4e4,3.7e5,1.5e9,1.3e6,4.7e0,0.82e0,5.0e3,1.0e7, & + 4.6e9,4.2e9,3.0e5, & + 1.0e8,200.e0,1.4e4,2.e8,7.5e7,1.7e7,1.e5,0.31e0, & + 1.8e-3,1.3e9,5.3e8, & + 5.0e9,5.0e9,8.0e7,1.2e7,8.8e8,9.1e6,1.7e8, & + 2.0e8,1.4e6,6.7e-3, & + 1.9e7,5.0e7,6.0e2,1.0e6,2.5e7,1.0e8,2.0e6, & + 1.42e2,4.77e3,2.94e2, & + 3.6e3,1.4e9,3.4e8, & + 2.5e4,1.0e5,2.5e7,120.e0/ + + +! when mopt_eqrt_cons=20, set s(iv)+h2o2 rxn rate constant +! to that used in mtcrm and testaqu22 + if (mopt_eqrt_cons .eq. 20) then + bkre(75) = 4.19e7 + dhre(75) = -1950.0 + end if + + do 1020 i=1,17 + akeq(i)=bkeq(i)*exp(dheq(i)*(1.0/temp-1.0/298.0)) + 1020 continue + do 1025 i=1,21 + akhen(i)=bkhen(i)*exp(dhhen(i)*(1.0/temp-1.0/298.0)) + 1025 continue + do 1030 i=1,120 + akre(i)=bkre(i)*exp(dhre(i)*(1.0/temp-1.0/298.0)) + 1030 continue + +! turn reactions on/off selectively + do i = 1, 120 + iusei = 0 + if (maqurxn_all .gt. 0) iusei = 1 + if (maqurxn_sulf1 .gt. 0) then + if ((i .ge. 72) .and. (i .le. 75)) iusei = 1 + end if + if (iusei .le. 0) akre(i) = 0.0 + if (iusei .le. 0) bkre(i) = 0.0 + end do + + return + end subroutine constants + + + + +!************************************************************************* +! this routine calculates the values of the concentrations +! of all the 46 species that appear in our aqueous phase mechanism. +! it has as inputs the values of [h+],con(28),cmet(3),akeq(17) and as +! outputs the values of cc(46) +!************************************************************************* + + subroutine values(x,con,cmet,akeq,cc) + +! arguments + double precision x + double precision con(28),cmet(4),akeq(17),cc(46) + +! local variables + double precision bparam,cparam,diak,cl,hcl +! +! species in the aqueous phase mechanism +! cc (1 - 46) +! 1.) so2*h2o 24.) ch3c(o)ooh +! 2.) hso3(-) 25.) ch3ooh +! 3.) so3(2-) 26.) hcl +! 4.) h2so4 27.) cl(-) +! 5.) hso4(-) 28.) oh +! 6.) so4(2-) 29.) ho2 +! 7.) hno2 30.) o2(-) +! 8.) no2(-) 31.) no3 +! 9.) hno3 32.) nh4oh +! 10.) no3(-) 33.) nh4(+) +! 11.) co2*h2o 34.) ch3o2 +! 12.) hco3(-) 35.) ch3oh +! 13.) co3(2-) 36.) cl2(-) +! 14.) h2o2 37.) cl +! 15.) ho2(-) 38.) cloh(-) +! 16.) hcho 39.) so4(-) +! 17.) h2c(oh)2 40.) so5(-) +! 18.) hcooh 41.) hso5(-) +! 19.) hcoo(-) 42.) hoch2so3(-) +! 20.) no 43.) och2so3(2-) +! 21.) no2 44.) co3(-) +! 22.) o3 45.) oh(-) +! 23.) pan 46.) h(+) +! +! con(1-28) +! +! 1.) so2(g) 15.) hcl(g) +! 2.) h2so4(g) 16.) oh(g) +! 3.) hno2(g) 17.) ho2(g) +! 4.) hno3(g) 18.) no3(g) +! 5.) co2(g) 19.) nh3(g) +! 6.) h2o2(g) 20.) ch3o2(g) +! 7.) hcho(g) 21.) ch3oh(g) +! 8.) hcooh(g) 22.) cl2(-), cl +! 9.) no(g) 23.) cloh(-) +! 10.) no2(g) 24.) so4(-) +! 11.) o3(g) 25.) so5(-) +! 12.) pan(g) 26.) hso5(-) +! 13.) ch3c(o)ooh(g) 27.) hoch2so3(-),och2so3(2-) +! 14.) ch3ooh(g) 28.) co3(-) +! + bparam=akeq(16)+con(15)-con(22) + cparam=akeq(16)*con(22) + diak=bparam*bparam+4.0d0*cparam + if (diak .le. 0.0d0) diak=1.0d-30 + cl=(-bparam+(diak)**0.5d0)/2.0d0 + hcl=(x*(con(15)-con(22)+cl))/(x+akeq(14)) + + cc(1)=(con(1)*x*x)/(x*x+akeq(1)*x+akeq(1)*akeq(2)) + cc(2)=(akeq(1)*con(1)*x)/(x*x+akeq(1)*x+akeq(1)*akeq(2)) + cc(3)=(akeq(1)*akeq(2)*con(1))/(x*x+akeq(1)*x+akeq(1)*akeq(2)) + + cc(4)=(con(2)*x*x)/(x*x+akeq(3)*x+akeq(3)*akeq(4)) + cc(5)=(akeq(3)*con(2)*x)/(x*x+akeq(3)*x+akeq(3)*akeq(4)) + cc(6)=(akeq(3)*akeq(4)*con(2))/(x*x+akeq(3)*x+akeq(3)*akeq(4)) + + cc(7)=(x*con(3))/(x+akeq(7)) + cc(8)=(akeq(7)*con(3))/(x+akeq(7)) + + cc(9)=(x*con(4))/(x+akeq(6)) + cc(10)=(akeq(6)*con(4))/(x+akeq(6)) + + cc(11)=(x*x*con(5))/(x*x+akeq(8)*x+akeq(8)*akeq(9)) + cc(12)=(akeq(8)*con(5)*x)/(x*x+akeq(8)*x+akeq(8)*akeq(9)) + cc(13)=(akeq(8)*akeq(9)*con(5))/(x*x+akeq(8)*x+akeq(8)*akeq(9)) + + cc(14)=(x*con(6))/(x+akeq(5)) + cc(15)=(akeq(5)*con(6))/(x+akeq(5)) + + cc(16)=con(7)/(1.0d0+akeq(12)) + cc(17)=(akeq(12)*con(7))/(1.0d0+akeq(12)) + + cc(18)=(x*con(8))/(x+akeq(13)) + cc(19)=(akeq(13)*con(8))/(x+akeq(13)) + + cc(20)=con(9) + + cc(21)=con(10) + + cc(22)=con(11) + + cc(23)=con(12) + + cc(24)=con(13) + + cc(25)=con(14) + + cc(26)=hcl + cc(27)=(akeq(14)*hcl)/x + + cc(28)=con(16) + + cc(29)=(x*con(17))/(x+akeq(15)) + cc(30)=(akeq(15)*con(17))/(x+akeq(15)) + + cc(31)=con(18) + + cc(32)=(akeq(11)*con(19))/(akeq(11)+akeq(10)*x) + cc(33)=(akeq(10)*x*con(19))/(akeq(11)+akeq(10)*x) + + cc(34)=con(20) + + cc(35)=con(21) + + cc(36)=(akeq(14)*cl*hcl)/(akeq(16)*x) + cc(37)=cl + + cc(38)=con(23) + cc(39)=con(24) + cc(40)=con(25) + cc(41)=con(26) + cc(42)=(x*con(27))/(x+akeq(17)) + cc(43)=(akeq(17)*con(27))/(x+akeq(17)) + cc(44)=con(28) + cc(45)=akeq(11)/x + cc(46)=x + + return + end subroutine values + + + + +!************************************************************************ +! this program contains the routine react which calculates +! the rates of all the reactions taking place in the aqueous phase. +! inputs in the sub are the 46 concentrations ,the 3 metal concentrations +! the 28 main species concentrations and the 120 reaction constants. +! output is the matrix of the 120 reaction rates. +!************************************************************************ + + subroutine react(c,cmet,con,zkre,rr,arytm) + + use module_data_cmu_bulkaqchem, only: chlorine, kiron, photo, & + mopt_eqrt_cons + +! arguments +! +! original argument was akre +! renamed it to zkre +! to avoid conflict with module_data_cmu_bulkaqchem +! +! dimension c(46),cmet(4),con(28),zkre(120),rr(120) + double precision c(46),cmet(4),con(28),zkre(120),rr(120) + double precision arytm + +! local variables + double precision ph, r1, r2, r3, r4, r5, sn + + + rr(1)=zkre(1)*c(14)*photo + rr(2)=zkre(2)*c(22)*photo + rr(3)=zkre(3)*c(28)*c(29) + rr(4)=zkre(4)*c(28)*c(30) + rr(5)=zkre(5)*c(28)*c(14) + rr(6)=zkre(6)*c(29)*c(29) + rr(7)=zkre(7)*c(29)*c(30) + rr(8)=zkre(8)*c(30)*c(30) + rr(9)=zkre(9)*c(29)*c(14) + rr(10)=zkre(10)*c(30)*c(14) + rr(11)=zkre(11)*c(28)*c(22) + rr(12)=zkre(12)*c(29)*c(22) + rr(13)=zkre(13)*c(30)*c(22) + rr(14)=zkre(14)*c(45)*c(22) + rr(15)=zkre(15)*c(15)*c(22) + if (c(22) .le. 0.0d0) c(22)=1.0d-30 + rr(16)=zkre(16)*c(14)*(c(22)**0.5) + + rr(17)=zkre(17)*c(12)*c(28) + rr(18)=zkre(18)*c(12)*c(30) + rr(19)=zkre(19)*c(44)*c(30) + rr(20)=zkre(20)*c(44)*c(14) + rr(21)=zkre(21)*c(27)*c(28)*chlorine + rr(22)=zkre(22)*c(38)*chlorine + rr(23)=zkre(23)*c(46)*c(38)*chlorine + rr(24)=zkre(24)*c(37)*chlorine + rr(25)=zkre(25)*c(29)*c(36)*chlorine + rr(26)=zkre(26)*c(30)*c(36)*chlorine + rr(27)=zkre(27)*c(29)*c(37)*chlorine + rr(28)=zkre(28)*c(14)*c(36)*chlorine + rr(29)=zkre(29)*c(37)*c(14)*chlorine + rr(30)=zkre(30)*c(45)*c(36)*chlorine + + rr(31)=zkre(31)*c(20)*c(21) + rr(32)=zkre(32)*c(21)*c(21) + rr(33)=zkre(33)*c(20)*c(28) + rr(34)=zkre(34)*c(21)*c(28) + rr(35)=zkre(35)*c(7)*photo + rr(36)=zkre(36)*c(8)*photo + rr(37)=zkre(37)*c(7)*c(28) + rr(38)=zkre(38)*c(8)*c(28) + rr(39)=zkre(39)*c(46)*c(14)*c(7) + rr(40)=zkre(40)*c(8)*c(22) + rr(41)=zkre(41)*c(8)*c(44) + rr(42)=zkre(42)*c(8)*c(36)*chlorine + rr(43)=zkre(43)*c(8)*c(31) + rr(44)=zkre(44)*c(10)*photo + rr(45)=zkre(45)*c(31)*photo + rr(46)=zkre(46)*c(31)*c(29) + rr(47)=zkre(47)*c(31)*c(30) + rr(48)=zkre(48)*c(31)*c(14) + rr(49)=zkre(49)*c(31)*c(27)*chlorine + rr(50)=zkre(50)*c(17)*c(28) + rr(51)=zkre(51)*c(17)*c(22) + rr(52)=zkre(52)*c(18)*c(28) + rr(53)=zkre(53)*c(18)*c(14) + rr(54)=zkre(54)*c(18)*c(31) + rr(55)=zkre(55)*c(18)*c(22) + rr(56)=zkre(56)*c(18)*c(36)*chlorine + rr(57)=zkre(57)*c(19)*c(28) + rr(58)=zkre(58)*c(19)*c(22) + rr(59)=zkre(59)*c(19)*c(31) + rr(60)=zkre(60)*c(19)*c(44) + rr(61)=zkre(61)*c(19)*c(36)*chlorine + rr(62)=zkre(62)*c(23) + rr(63)=zkre(63)*c(34)*c(29) + rr(64)=zkre(64)*c(34)*c(30) + rr(65)=zkre(65)*c(25)*photo + rr(66)=zkre(66)*c(25)*c(28) + rr(67)=zkre(67)*c(35)*c(28) + rr(68)=zkre(68)*c(35)*c(44) + rr(69)=zkre(69)*c(35)*c(36)*chlorine + rr(70)=zkre(70)*c(25)*c(28) + rr(71)=zkre(71)*c(35)*c(31) + + rr(72)=(zkre(72)*c(1)+zkre(73)*c(2)+zkre(74)*c(3))*c(22) + rr(73)=(zkre(75)*c(14)*c(1))/(1.0d0+16.0d0*c(46)) +! when mopt_eqrt_cons=20, calc s(iv)+h2o2 rxn rate +! same as in mtcrm and testaqu22 + if (mopt_eqrt_cons .eq. 20) then + rr(73)=(zkre(75)*c(14)*c(2)*c(46))/(1.0d0+16.0d0*c(46)) + end if +! +! rate expressions for the metal catalysed oxidation of s(iv) +! +! ** phenomenological expression by martin et al. (1991) ** + ph=-log10(c(46)) + if (kiron .eq. 1) then +! + if (ph .le. 3.0) rr(74)=6.*cmet(1)*con(1)/c(46) + if (ph .gt. 3.0 .and. ph .le. 4.5) & + rr(74) = 1.e9*con(1)*cmet(1)*cmet(1) + if (ph .gt. 4.5 .and. ph .le. 6.5) rr(74) = 1.0e-3*con(1) + if (ph .gt. 6.5) rr(74)=1.0e-4*con(1) + endif + +! ** expression by martin (1984) ** + if (kiron .eq. 2) then + if ((c(46) .ge. 1.0d-4).and.(con(1) .ge. 1.0d-5)) then + r1=(zkre(76)*cmet(2)*cmet(2))/c(46) + r2=(zkre(77)*cmet(1)*con(1)/c(46)) + if (cmet(2) .le. 0.0d0) cmet(2)=1.0d-30 + r3=r2*(1.0d0+(1.7d3*cmet(2)**1.5)/(6.3d-6+cmet(1))) + rr(74)=r1+r3 + go to 1300 + end if + + if (cmet(1)*cmet(2) .lt. 1.0d-15) then + sn=1.0d0 + else + sn=3.0d0 + end if + + if ((c(46) .ge. 1.0d-4).and.(con(1) .lt. 1.0d-5)) then + rr(74)=sn*(zkre(78)*cmet(2)*c(2)+zkre(77)*cmet(1)*con(1)/c(46)) + go to 1300 + end if + + if ((c(46) .lt. 1.0d-4).and.(con(1) .ge. 1.0d-5)) then + r4=zkre(76)*cmet(2)*cmet(2)/c(46) + r5=zkre(79)*cmet(1)*con(1)*con(1) + rr(74)=r4+r5 + go to 1300 + end if + + rr(74)=zkre(78)*cmet(2)*c(2) + +1300 continue + endif + +! 09-nov-2005 rce - if rate constants 76,77,78,79 are all zero, set rr(74)=0. +! This allows ANY/ALL rxns to be turned on/off in subr constants. + if (abs(zkre(76)+zkre(77)+zkre(78)+zkre(79)) .le. 1.0e-37) rr(74)=0.0 + +! ** end of martin's expression ** + + rr(75)=zkre(80)*c(3)*c(28) + rr(76)=zkre(81)*c(2)*c(28) + rr(77)=zkre(82)*c(40)*c(2)+zkre(117)*c(40)*c(3) + rr(78)=zkre(83)*c(40)*c(30) + rr(79)=zkre(84)*c(40)*c(18) + rr(80)=zkre(85)*c(40)*c(19) + rr(81)=zkre(86)*c(40)*c(40) + rr(82)=zkre(87)*c(41)*c(2)*c(46) + rr(83)=zkre(88)*c(41)*c(28) + rr(84)=zkre(89)*c(41)*c(39) + rr(85)=zkre(90)*c(41)*c(8) + rr(86)=zkre(91)*c(41)*c(27) + rr(87)=zkre(92)*c(39)*c(2) + rr(88)=zkre(93)*c(39)*c(3) + rr(89)=zkre(94)*c(39)*c(29) + rr(90)=zkre(95)*c(39)*c(30) + rr(91)=zkre(96)*c(39)*c(45) + rr(92)=zkre(97)*c(39)*c(14) + rr(93)=zkre(98)*c(39)*c(8) + rr(94)=zkre(99)*c(39)*c(12) + rr(95)=zkre(100)*c(39)*c(19) + rr(96)=zkre(101)*c(39)*c(27) + rr(97)=zkre(102)*c(39)*c(18) + rr(98)=zkre(103)*c(23)*c(2)/c(46) + rr(99)=zkre(104)*c(2)*c(25)*c(46) + rr(100)=(zkre(105)*c(46)+zkre(106))*c(2)*c(24) + rr(101)=zkre(107)*c(29)*c(3)+zkre(118)*c(3)*c(30) + rr(102)=zkre(108)*c(39)*c(35) + rr(103)=zkre(109)*c(2)*c(31) + rr(104)=zkre(110)*con(1)*c(21) + + if (c(46) .ge. 1.0d-3) then + rr(105)=zkre(111)*con(3)*con(1)*c(46)**0.5d0 + arytm=1.0d0 + else + rr(105)=zkre(112)*c(8)*c(2)*c(46) + arytm=0.0d0 + end if + + rr(106)=zkre(113)*c(16)*c(2)+zkre(119)*c(16)*c(3) + rr(107)=zkre(114)*c(42)*c(45) + rr(108)=zkre(115)*c(42)*c(28) + rr(109)=zkre(116)*c(2)*c(36)*chlorine+ & + zkre(116)*c(3)*c(36)*chlorine + + return + end subroutine react + + + + +!************************************************************************ +! this program contains the routine mass which calculates the mass +! fluxes for the mass balances. +! inputs : wl, radius, temp, gcon(21), con(28), akeq(17),akhen(21) +! outputs : fgl(21),flg(21) +!************************************************************************ + + subroutine mass(wl,radius,temp,gcon,con,c,akeq,akhen,fgl,flg, & + gfgl,gflg) + +! arguments + double precision wl, radius, temp + double precision gcon(22), con(28), c(46), akeq(17), akhen(21) + double precision fgl(21), flg(21), gfgl(21), gflg(21) + +! local variables + integer i + double precision acc, airl, dg, rideal +! ekhen(i) is the effective henry's law constant +! dimension ekhen(21) + double precision ekhen(21) + double precision kn,n,ikn,kmt + + + ekhen(1)=akhen(1)*(1.d0+akeq(1)/c(46)+akeq(1)*akeq(2)/c(46)**2) + ekhen(2)=1.0d30 + ekhen(3)=akhen(3)*(1.d0+akeq(7)/c(46)) + ekhen(4)=akhen(4)*(1.d0+akeq(6)/c(46)) + ekhen(5)=akhen(5)*(1.d0+akeq(8)/c(46)+akeq(8)*akeq(9)/c(46)**2) + ekhen(6)=akhen(6)*(1.d0+akeq(5)/c(46)) + ekhen(7)=akhen(7)*((1.d0+akeq(12))/akeq(12)) + ekhen(8)=akhen(8)*(1.d0+akeq(13)/c(46)) + ekhen(9)=akhen(9) + ekhen(10)=akhen(10) + ekhen(11)=akhen(11) + ekhen(12)=akhen(12) + ekhen(13)=akhen(13) + ekhen(14)=akhen(14) + ekhen(15)=akhen(15)*(1.d0+akeq(14)/c(46)+(akeq(14)*c(37))/ & + (akeq(16)*c(46))) + ekhen(16)=akhen(16) + ekhen(17)=akhen(17)*(1.d0+akeq(15)/c(46)) + ekhen(18)=akhen(18) + ekhen(19)=akhen(19)*(1.d0+akeq(10)/c(45)) + ekhen(20)=akhen(20) + ekhen(21)=akhen(21) + +! airl is the mean free path of air. later we have to substitute +! the numerical value given here by a function of temperature +! airl=65x10-9 m + airl=65.d-9 +! kn is the knudsen number + kn=airl/radius + ikn=1.d0/kn +! acc is the accomodation coefficient assumed the same here for +! all the species + acc=0.1d0 +! n is the coefficient entering the flux expression + n=1.d0/(1.d0+((1.33d0+0.71d0*ikn)/(1.d0+ikn)+4.d0*(1.d0-acc) & + /(3.d0*acc))*kn) +! dg is the gas phase diffusivity assumed here the same for all +! the gases.we shall probably have to change it later. +! dg=1.x10-5 m**2/sec + dg=1.0d-5 +! rideal is the gas constant in [atm/K/(mol/liter)] + rideal=0.082058d0 + kmt=(3.0d0*n*dg)/(radius*radius) + + do 1500 i=1,21 + fgl(i)=kmt*gcon(i) + flg(i)=(kmt*con(i))/(ekhen(i)*rideal*temp) + gfgl(i)=fgl(i)*wl + gflg(i)=flg(i)*wl +1500 continue + + + + return + end subroutine mass + + + + +!*********************************************************************** +! this routine calculates the differentials dc(i)/dt for the 28 +! main species in the aqueous phase and the 21 species in the gas phase. +! units for all rates are (mol/lt.s) +! note that there are no reaction terms for the gas phase. +! revised 23 nov 1988 +!*********************************************************************** +! + subroutine differ(rp,rl,fgl,flg,gfgl,gflg,dp,dl) + +! arguments + double precision rp(28),rl(28),fgl(21),flg(21),gfgl(21),gflg(21) + double precision dp(49),dl(49) + +! local variables + integer i + + + do 1510 i=1,21 + dp(i)=rp(i)+fgl(i) + dl(i)=rl(i)+flg(i) +1510 continue + + do 1520 i=22,28 + dp(i)=rp(i) + dl(i)=rl(i) +1520 continue + + do 1530 i=29,49 + dp(i)=gflg(i-28) + dl(i)=gfgl(i-28) +1530 continue + + + return + end subroutine differ + + + + +! *********************************************************************** +! the routine addit sums up the rates of +! the 120 reactions to give the rates for the 28 main species. +! input : the 120 reaction rates from the sub react +! output : the 28 formation and destruction rates +! revised 23 nov 1988 +! *********************************************************************** + + subroutine addit(rr,arytm,rp,rl) + +! arguments + double precision arytm + double precision rr(120),rp(28),rl(28) + + +! +! ** s(iv) ** +! + rp(1)=rr(107) + rl(1)=+rr(72)+rr(73)+rr(74)+rr(98)+rr(101)+rr(105)*arytm & + +rr(76)+rr(77)+rr(82)+rr(87)+rr(99)+rr(100)+2.0d0*rr(103) & + +rr(104)+2.0d0*rr(105)*(1.0d0-arytm)+rr(106)+rr(109) & + +rr(75)+rr(88) +! +! ** s(vi) ** +! + rp(2)= rr(72)+rr(73)+rr(74)+rr(98)+rr(101)+rr(105)*arytm & + +rr(85) & + +2.d0*rr(82)+rr(84)+rr(86)+rr(87)+rr(88)+rr(89)+rr(90) & + +rr(91)+rr(92)+rr(93)+rr(94)+rr(95)+rr(96)+rr(97)+rr(99) & + +rr(100)+rr(102)+rr(103)+rr(104) + rl(2)=0.0d0 +! +! ** n(iii) ** +! + rp(3)=2.0d0*rr(31)+rr(32)+rr(33)+2.0d0*rr(104) + rl(3)=rr(35)+rr(37)+rr(39)+rr(105)*arytm+rr(36)+rr(38)+rr(40) & + +rr(41)+rr(42)+rr(43)+rr(85)+rr(93)+rr(105)*(1.0d0-arytm) +! +! ** n(v) ** +! + rp(4)=rr(32)+rr(34)+rr(39)+rr(40)+rr(43)+rr(46)+rr(47)+rr(48)+ & + rr(49)+rr(54)+rr(59)+rr(62)+rr(71)+rr(85)+rr(103) + rl(4)=rr(44) +! +! ** co2 ** +! + rp(5)=rr(52)+rr(54)+rr(55)+rr(56)+rr(57)+rr(58)+rr(59)+ & + rr(60)+rr(61)+rr(79)+rr(80)+rr(95)+rr(97)+rr(19)+rr(20)+rr(60)+ & + rr(68)+rr(41) + rl(5)=rr(17)+rr(18)+rr(94) +! +! ** h2o2 ** +! + rp(6)=rr(2)+rr(6)+rr(7)+rr(8)+rr(18) + rl(6)=rr(1)+rr(5)+rr(9)+rr(10)+rr(16)+rr(20)+rr(29)+rr(39)+ & + rr(48)+rr(53)+rr(73)+rr(92)+rr(15)+rr(28) +! +! ** hcho ** +! + rp(7)= rr(65)+rr(67)+rr(68)+rr(69)+rr(70)+rr(71)+rr(102)+rr(107) & + +rr(108) + rl(7)= rr(106)+rr(50)+rr(51) +! +! ** hcooh ** +! + rp(8)=rr(50) + rl(8)=rr(52)+rr(53)+rr(54)+rr(55)+rr(56)+rr(79)+rr(97)+rr(57)+ & + rr(58)+rr(59)+rr(60)+rr(61)+rr(80)+rr(95) +! +! ** no ** +! + rp(9)=rr(35)+rr(36)+rr(45) + rl(9)=rr(31)+rr(33) +! +! ** no2 ** +! + rp(10)=rr(37)+rr(38)+rr(41)+rr(42)+rr(43)+rr(44)+rr(93) + rl(10)=rr(31)+2.0d0*rr(32)+rr(34)+2.0d0*rr(104) +! +! ** o3 ** +! + rp(11)=0.0d0 + rl(11)=rr(2)+rr(11)+rr(12)+rr(13)+rr(14)+rr(15)+rr(16)+rr(40)+ & + rr(51)+rr(55)+rr(58)+rr(72) +! +! ** pan ** +! + rp(12)=0.0d0 + rl(12)=rr(62)+rr(98) +! +! ** ch3coooh ** +! + rp(13)=0.0d0 + rl(13)=rr(100) +! +! ** ch3ooh ** +! + rp(14)=rr(63)+rr(64) + rl(14)=rr(65)+rr(66)+rr(70)+rr(99) +! +! ** hcl ** +! + rp(15)=rr(22)+2.d0*rr(25)+2.d0*rr(26)+rr(27)+rr(29)+2.d0*rr(30) & + +2.d0*rr(42)+2.d0*rr(56)+2.d0*rr(61)+ & + 2.d0*rr(69)+2.d0*rr(109)+2.d0*rr(28) + rl(15)=rr(21)+rr(49)+rr(86)+rr(96) +! +! ** oh ** +! + rp(16)=2.0d0*rr(1)+rr(9)+rr(10)+rr(12)+ & + rr(13)+rr(15)+rr(22)+rr(30)+rr(35)+rr(36)+rr(44)+rr(55)+rr(58)+ & + rr(65)+rr(91)+rr(101) + rl(16)=rr(3)+rr(4)+rr(5)+rr(11)+rr(17)+rr(21)+rr(33)+rr(34)+ & + rr(37)+rr(38)+rr(50)+rr(52)+rr(57)+rr(66)+rr(67)+rr(75)+rr(76)+ & + rr(83)+rr(108) +! +! ** ho2 ** +! + rp(17)=rr(5)+rr(11)+rr(20)+rr(28)+rr(29)+rr(48)+rr(50)+rr(52)+ & + rr(54)+rr(55)+rr(56)+rr(57)+rr(59)+rr(60)+rr(61)+rr(65)+ & + rr(67)+rr(68)+rr(69)+rr(71)+rr(79)+rr(92)+rr(95)+rr(97)+ & + rr(102)+rr(14)+rr(14)+rr(15)+rr(58)+rr(80) + rl(17)=rr(3)+2.0d0*rr(6)+rr(7)+rr(9)+rr(12)+rr(25)+rr(27)+rr(46) & + +rr(63)+rr(89)+rr(101)+rr(4)+rr(7)+2.0d0*rr(8)+rr(10)+rr(13) & + +rr(18)+rr(19)+rr(26)+rr(47)+rr(64)+rr(78)+rr(90) +! +! ** no3 ** +! + rp(18)=0.0d0 + rl(18)= rr(43)+rr(45)+rr(46)+rr(47)+rr(48)+rr(49)+rr(54)+ & + rr(59)+rr(71)+rr(103) +! +! ** nh3 ** +! + rp(19)=0.0d0 + rl(19)=0.0d0 +! +! ** ch3o2 ** +! + rp(20)=rr(66) + rl(20)=rr(63)+rr(64) +! +! ** ch3oh ** +! + rp(21)=0.0d0 + rl(21)=rr(67)+rr(68)+rr(69)+rr(71)+rr(102) +! +! ** cl2-, cl ** +! + rp(22)=rr(49)+rr(96)+rr(23) + rl(22)=rr(25)+rr(26)+rr(28)+rr(30)+rr(42)+rr(56)+rr(61)+ & + rr(69)+rr(109)+rr(24)+rr(27)+rr(29) +! +! ** cloh- ** +! + rp(23)=rr(21)+rr(24) + rl(23)=rr(22)+rr(23) +! +! ** so4- ** +! + rp(24)=2.d0*rr(81)+rr(103) + rl(24)= rr(84)+rr(87)+rr(88)+rr(89)+rr(90)+rr(91)+ & + rr(92)+rr(93)+rr(94)+rr(95)+rr(96)+rr(97)+rr(102) +! +! ** so5- ** +! + rp(25)=rr(75)+rr(76)+rr(83)+rr(84)+rr(87)+rr(88)+rr(108)+rr(109) + rl(25)=rr(78)+rr(79)+rr(80)+2.0d0*rr(81) +! +! ** hso5- ** +! + rp(26)=rr(77)+rr(78)+rr(79)+rr(80) + rl(26)=+rr(82)+rr(83)+rr(84)+rr(85)+rr(86) +! +! ** hoch2so3- ** +! + rp(27)=rr(106) + rl(27)=rr(107)+rr(108) +! +! ** co3- ** +! + rp(28)=rr(17)+rr(18)+rr(94) + rl(28)=rr(19)+rr(20)+rr(41)+rr(60)+rr(68) + + return + end subroutine addit +!---------------------------------------------------------------------- + + + + end module module_cmu_bulkaqchem diff --git a/wrfv2_fire/chem/module_cmu_dvode_solver.F b/wrfv2_fire/chem/module_cmu_dvode_solver.F new file mode 100644 index 00000000..d3db438e --- /dev/null +++ b/wrfv2_fire/chem/module_cmu_dvode_solver.F @@ -0,0 +1,4741 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + +! 27-oct-2005 rce - do not declare functions that are in the module +!----------------------------------------------------------------------- +! module_cmu_dvode_solver - from vode.f & vode_subs.f on 27-oct-2005 +! (vode.f - downloaded from www.netlib.org on 28-jul-2004) +! (vode_subs.f - created on 28-jul-2004 +! by downloading following from www.netlib.org +! 1. daxpy, dcopy, ddot, dnrm2, dscal, idamax from blas +! 2. dgbfa, dbgsl, dgefa, dgesl from linpack) +! +! first converted to lowercase +! then converted to fortran-90 +! then converted to module +! for this step, had to comment out declarations of any +! functions that are part of the module +! also changed common block names to reduce potential for conflicts +! dvod01 --> dvod_cmn01 +! dvod02 --> dvod_cmn02 +!----------------------------------------------------------------------- + + module module_cmu_dvode_solver + + + + contains + + + +!----------------------------------------------------------------------- +! vode.f - downloaded from www.netlib.org on 28-jul-2004 +!----------------------------------------------------------------------- + +!deck dvode + subroutine dvode (f, neq, y, t, tout, itol, rtol, atol, itask, & + istate, iopt, rwork, lrw, iwork, liw, jac, mf, & + rpar, ipar) + external f, jac + double precision y, t, tout, rtol, atol, rwork, rpar + integer neq, itol, itask, istate, iopt, lrw, iwork, liw, & + mf, ipar + dimension y(*), rtol(*), atol(*), rwork(lrw), iwork(liw), & + rpar(*), ipar(*) +!----------------------------------------------------------------------- +! dvode: variable-coefficient ordinary differential equation solver, +! with fixed-leading-coefficient implementation. +! this version is in double precision. +! +! dvode solves the initial value problem for stiff or nonstiff +! systems of first order odes, +! dy/dt = f(t,y) , or, in component form, +! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(neq)) (i = 1,...,neq). +! dvode is a package based on the episode and episodeb packages, and +! on the odepack user interface standard, with minor modifications. +!----------------------------------------------------------------------- +! authors: +! peter n. brown and alan c. hindmarsh +! center for applied scientific computing, l-561 +! lawrence livermore national laboratory +! livermore, ca 94551 +! and +! george d. byrne +! illinois institute of technology +! chicago, il 60616 +!----------------------------------------------------------------------- +! references: +! +! 1. p. n. brown, g. d. byrne, and a. c. hindmarsh, 'vode: a variable +! coefficient ode solver,' siam j. sci. stat. comput., 10 (1989), +! pp. 1038-1051. also, llnl report ucrl-98412, june 1988. +! 2. g. d. byrne and a. c. hindmarsh, 'a polyalgorithm for the +! numerical solution of ordinary differential equations,' +! acm trans. math. software, 1 (1975), pp. 71-96. +! 3. a. c. hindmarsh and g. d. byrne, 'episode: an effective package +! for the integration of systems of ordinary differential +! equations,' llnl report ucid-30112, rev. 1, april 1977. +! 4. g. d. byrne and a. c. hindmarsh, 'episodeb: an experimental +! package for the integration of systems of ordinary differential +! equations with banded jacobians,' llnl report ucid-30132, april +! 1976. +! 5. a. c. hindmarsh, 'odepack, a systematized collection of ode +! solvers,' in scientific computing, r. s. stepleman et al., eds., +! north-holland, amsterdam, 1983, pp. 55-64. +! 6. k. r. jackson and r. sacks-davis, 'an alternative implementation +! of variable step-size multistep formulas for stiff odes,' acm +! trans. math. software, 6 (1980), pp. 295-318. +!----------------------------------------------------------------------- +! summary of usage. +! +! communication between the user and the dvode package, for normal +! situations, is summarized here. this summary describes only a subset +! of the full set of options available. see the full description for +! details, including optional communication, nonstandard options, +! and instructions for special situations. see also the example +! problem (with program and output) following this summary. +! +! a. first provide a subroutine of the form: +! subroutine f (neq, t, y, ydot, rpar, ipar) +! double precision t, y(neq), ydot(neq), rpar +! which supplies the vector function f by loading ydot(i) with f(i). +! +! b. next determine (or guess) whether or not the problem is stiff. +! stiffness occurs when the jacobian matrix df/dy has an eigenvalue +! whose real part is negative and large in magnitude, compared to the +! reciprocal of the t span of interest. if the problem is nonstiff, +! use a method flag mf = 10. if it is stiff, there are four standard +! choices for mf (21, 22, 24, 25), and dvode requires the jacobian +! matrix in some form. in these cases (mf .gt. 0), dvode will use a +! saved copy of the jacobian matrix. if this is undesirable because of +! storage limitations, set mf to the corresponding negative value +! (-21, -22, -24, -25). (see full description of mf below.) +! the jacobian matrix is regarded either as full (mf = 21 or 22), +! or banded (mf = 24 or 25). in the banded case, dvode requires two +! half-bandwidth parameters ml and mu. these are, respectively, the +! widths of the lower and upper parts of the band, excluding the main +! diagonal. thus the band consists of the locations (i,j) with +! i-ml .le. j .le. i+mu, and the full bandwidth is ml+mu+1. +! +! c. if the problem is stiff, you are encouraged to supply the jacobian +! directly (mf = 21 or 24), but if this is not feasible, dvode will +! compute it internally by difference quotients (mf = 22 or 25). +! if you are supplying the jacobian, provide a subroutine of the form: +! subroutine jac (neq, t, y, ml, mu, pd, nrowpd, rpar, ipar) +! double precision t, y(neq), pd(nrowpd,neq), rpar +! which supplies df/dy by loading pd as follows: +! for a full jacobian (mf = 21), load pd(i,j) with df(i)/dy(j), +! the partial derivative of f(i) with respect to y(j). (ignore the +! ml and mu arguments in this case.) +! for a banded jacobian (mf = 24), load pd(i-j+mu+1,j) with +! df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of +! pd from the top down. +! in either case, only nonzero elements need be loaded. +! +! d. write a main program which calls subroutine dvode once for +! each point at which answers are desired. this should also provide +! for possible use of logical unit 6 for output of error messages +! by dvode. on the first call to dvode, supply arguments as follows: +! f = name of subroutine for right-hand side vector f. +! this name must be declared external in calling program. +! neq = number of first order odes. +! y = array of initial values, of length neq. +! t = the initial value of the independent variable. +! tout = first point where output is desired (.ne. t). +! itol = 1 or 2 according as atol (below) is a scalar or array. +! rtol = relative tolerance parameter (scalar). +! atol = absolute tolerance parameter (scalar or array). +! the estimated local error in y(i) will be controlled so as +! to be roughly less (in magnitude) than +! ewt(i) = rtol*abs(y(i)) + atol if itol = 1, or +! ewt(i) = rtol*abs(y(i)) + atol(i) if itol = 2. +! thus the local error test passes if, in each component, +! either the absolute error is less than atol (or atol(i)), +! or the relative error is less than rtol. +! use rtol = 0.0 for pure absolute error control, and +! use atol = 0.0 (or atol(i) = 0.0) for pure relative error +! control. caution: actual (global) errors may exceed these +! local tolerances, so choose them conservatively. +! itask = 1 for normal computation of output values of y at t = tout. +! istate = integer flag (input and output). set istate = 1. +! iopt = 0 to indicate no optional input used. +! rwork = real work array of length at least: +! 20 + 16*neq for mf = 10, +! 22 + 9*neq + 2*neq**2 for mf = 21 or 22, +! 22 + 11*neq + (3*ml + 2*mu)*neq for mf = 24 or 25. +! lrw = declared length of rwork (in user's dimension statement). +! iwork = integer work array of length at least: +! 30 for mf = 10, +! 30 + neq for mf = 21, 22, 24, or 25. +! if mf = 24 or 25, input in iwork(1),iwork(2) the lower +! and upper half-bandwidths ml,mu. +! liw = declared length of iwork (in user's dimension statement). +! jac = name of subroutine for jacobian matrix (mf = 21 or 24). +! if used, this name must be declared external in calling +! program. if not used, pass a dummy name. +! mf = method flag. standard values are: +! 10 for nonstiff (adams) method, no jacobian used. +! 21 for stiff (bdf) method, user-supplied full jacobian. +! 22 for stiff method, internally generated full jacobian. +! 24 for stiff method, user-supplied banded jacobian. +! 25 for stiff method, internally generated banded jacobian. +! rpar,ipar = user-defined real and integer arrays passed to f and jac. +! note that the main program must declare arrays y, rwork, iwork, +! and possibly atol, rpar, and ipar. +! +! e. the output from the first call (or any call) is: +! y = array of computed values of y(t) vector. +! t = corresponding value of independent variable (normally tout). +! istate = 2 if dvode was successful, negative otherwise. +! -1 means excess work done on this call. (perhaps wrong mf.) +! -2 means excess accuracy requested. (tolerances too small.) +! -3 means illegal input detected. (see printed message.) +! -4 means repeated error test failures. (check all input.) +! -5 means repeated convergence failures. (perhaps bad +! jacobian supplied or wrong choice of mf or tolerances.) +! -6 means error weight became zero during problem. (solution +! component i vanished, and atol or atol(i) = 0.) +! +! f. to continue the integration after a successful return, simply +! reset tout and call dvode again. no other parameters need be reset. +! +!----------------------------------------------------------------------- +! example problem +! +! the following is a simple example problem, with the coding +! needed for its solution by dvode. the problem is from chemical +! kinetics, and consists of the following three rate equations: +! dy1/dt = -.04*y1 + 1.e4*y2*y3 +! dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 +! dy3/dt = 3.e7*y2**2 +! on the interval from t = 0.0 to t = 4.e10, with initial conditions +! y1 = 1.0, y2 = y3 = 0. the problem is stiff. +! +! the following coding solves this problem with dvode, using mf = 21 +! and printing results at t = .4, 4., ..., 4.e10. it uses +! itol = 2 and atol much smaller for y2 than y1 or y3 because +! y2 has much smaller values. +! at the end of the run, statistical quantities of interest are +! printed. (see optional output in the full description below.) +! to generate fortran source code, replace c in column 1 with a blank +! in the coding below. +! +! external fex, jex +! double precision atol, rpar, rtol, rwork, t, tout, y +! dimension y(3), atol(3), rwork(67), iwork(33) +! neq = 3 +! y(1) = 1.0d0 +! y(2) = 0.0d0 +! y(3) = 0.0d0 +! t = 0.0d0 +! tout = 0.4d0 +! itol = 2 +! rtol = 1.d-4 +! atol(1) = 1.d-8 +! atol(2) = 1.d-14 +! atol(3) = 1.d-6 +! itask = 1 +! istate = 1 +! iopt = 0 +! lrw = 67 +! liw = 33 +! mf = 21 +! do 40 iout = 1,12 +! call dvode(fex,neq,y,t,tout,itol,rtol,atol,itask,istate, +! 1 iopt,rwork,lrw,iwork,liw,jex,mf,rpar,ipar) +! write(6,20)t,y(1),y(2),y(3) +! 20 format(' at t =',d12.4,' y =',3d14.6) +! if (istate .lt. 0) go to 80 +! 40 tout = tout*10. +! write(6,60) iwork(11),iwork(12),iwork(13),iwork(19), +! 1 iwork(20),iwork(21),iwork(22) +! 60 format(/' no. steps =',i4,' no. f-s =',i4, +! 1 ' no. j-s =',i4,' no. lu-s =',i4/ +! 2 ' no. nonlinear iterations =',i4/ +! 3 ' no. nonlinear convergence failures =',i4/ +! 4 ' no. error test failures =',i4/) +! stop +! 80 write(6,90)istate +! 90 format(///' error halt: istate =',i3) +! stop +! end +! +! subroutine fex (neq, t, y, ydot, rpar, ipar) +! double precision rpar, t, y, ydot +! dimension y(neq), ydot(neq) +! ydot(1) = -.04d0*y(1) + 1.d4*y(2)*y(3) +! ydot(3) = 3.d7*y(2)*y(2) +! ydot(2) = -ydot(1) - ydot(3) +! return +! end +! +! subroutine jex (neq, t, y, ml, mu, pd, nrpd, rpar, ipar) +! double precision pd, rpar, t, y +! dimension y(neq), pd(nrpd,neq) +! pd(1,1) = -.04d0 +! pd(1,2) = 1.d4*y(3) +! pd(1,3) = 1.d4*y(2) +! pd(2,1) = .04d0 +! pd(2,3) = -pd(1,3) +! pd(3,2) = 6.d7*y(2) +! pd(2,2) = -pd(1,2) - pd(3,2) +! return +! end +! +! the following output was obtained from the above program on a +! cray-1 computer with the cft compiler. +! +! at t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 +! at t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 +! at t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 +! at t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 +! at t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 +! at t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 +! at t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 +! at t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 +! at t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 +! at t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 +! at t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 +! at t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 +! +! no. steps = 595 no. f-s = 832 no. j-s = 13 no. lu-s = 112 +! no. nonlinear iterations = 831 +! no. nonlinear convergence failures = 0 +! no. error test failures = 22 +!----------------------------------------------------------------------- +! full description of user interface to dvode. +! +! the user interface to dvode consists of the following parts. +! +! i. the call sequence to subroutine dvode, which is a driver +! routine for the solver. this includes descriptions of both +! the call sequence arguments and of user-supplied routines. +! following these descriptions is +! * a description of optional input available through the +! call sequence, +! * a description of optional output (in the work arrays), and +! * instructions for interrupting and restarting a solution. +! +! ii. descriptions of other routines in the dvode package that may be +! (optionally) called by the user. these provide the ability to +! alter error message handling, save and restore the internal +! common, and obtain specified derivatives of the solution y(t). +! +! iii. descriptions of common blocks to be declared in overlay +! or similar environments. +! +! iv. description of two routines in the dvode package, either of +! which the user may replace with his own version, if desired. +! these relate to the measurement of errors. +! +!----------------------------------------------------------------------- +! part i. call sequence. +! +! the call sequence parameters used for input only are +! f, neq, tout, itol, rtol, atol, itask, iopt, lrw, liw, jac, mf, +! and those used for both input and output are +! y, t, istate. +! the work arrays rwork and iwork are also used for conditional and +! optional input and optional output. (the term output here refers +! to the return from subroutine dvode to the user's calling program.) +! +! the legality of input parameters will be thoroughly checked on the +! initial call for the problem, but not checked thereafter unless a +! change in input parameters is flagged by istate = 3 in the input. +! +! the descriptions of the call arguments are as follows. +! +! f = the name of the user-supplied subroutine defining the +! ode system. the system must be put in the first-order +! form dy/dt = f(t,y), where f is a vector-valued function +! of the scalar t and the vector y. subroutine f is to +! compute the function f. it is to have the form +! subroutine f (neq, t, y, ydot, rpar, ipar) +! double precision t, y(neq), ydot(neq), rpar +! where neq, t, and y are input, and the array ydot = f(t,y) +! is output. y and ydot are arrays of length neq. +! subroutine f should not alter y(1),...,y(neq). +! f must be declared external in the calling program. +! +! subroutine f may access user-defined real and integer +! work arrays rpar and ipar, which are to be dimensioned +! in the main program. +! +! if quantities computed in the f routine are needed +! externally to dvode, an extra call to f should be made +! for this purpose, for consistent and accurate results. +! if only the derivative dy/dt is needed, use dvindy instead. +! +! neq = the size of the ode system (number of first order +! ordinary differential equations). used only for input. +! neq may not be increased during the problem, but +! can be decreased (with istate = 3 in the input). +! +! y = a real array for the vector of dependent variables, of +! length neq or more. used for both input and output on the +! first call (istate = 1), and only for output on other calls. +! on the first call, y must contain the vector of initial +! values. in the output, y contains the computed solution +! evaluated at t. if desired, the y array may be used +! for other purposes between calls to the solver. +! +! this array is passed as the y argument in all calls to +! f and jac. +! +! t = the independent variable. in the input, t is used only on +! the first call, as the initial point of the integration. +! in the output, after each call, t is the value at which a +! computed solution y is evaluated (usually the same as tout). +! on an error return, t is the farthest point reached. +! +! tout = the next value of t at which a computed solution is desired. +! used only for input. +! +! when starting the problem (istate = 1), tout may be equal +! to t for one call, then should .ne. t for the next call. +! for the initial t, an input value of tout .ne. t is used +! in order to determine the direction of the integration +! (i.e. the algebraic sign of the step sizes) and the rough +! scale of the problem. integration in either direction +! (forward or backward in t) is permitted. +! +! if itask = 2 or 5 (one-step modes), tout is ignored after +! the first call (i.e. the first call with tout .ne. t). +! otherwise, tout is required on every call. +! +! if itask = 1, 3, or 4, the values of tout need not be +! monotone, but a value of tout which backs up is limited +! to the current internal t interval, whose endpoints are +! tcur - hu and tcur. (see optional output, below, for +! tcur and hu.) +! +! itol = an indicator for the type of error control. see +! description below under atol. used only for input. +! +! rtol = a relative error tolerance parameter, either a scalar or +! an array of length neq. see description below under atol. +! input only. +! +! atol = an absolute error tolerance parameter, either a scalar or +! an array of length neq. input only. +! +! the input parameters itol, rtol, and atol determine +! the error control performed by the solver. the solver will +! control the vector e = (e(i)) of estimated local errors +! in y, according to an inequality of the form +! rms-norm of ( e(i)/ewt(i) ) .le. 1, +! where ewt(i) = rtol(i)*abs(y(i)) + atol(i), +! and the rms-norm (root-mean-square norm) here is +! rms-norm(v) = sqrt(sum v(i)**2 / neq). here ewt = (ewt(i)) +! is a vector of weights which must always be positive, and +! the values of rtol and atol should all be non-negative. +! the following table gives the types (scalar/array) of +! rtol and atol, and the corresponding form of ewt(i). +! +! itol rtol atol ewt(i) +! 1 scalar scalar rtol*abs(y(i)) + atol +! 2 scalar array rtol*abs(y(i)) + atol(i) +! 3 array scalar rtol(i)*abs(y(i)) + atol +! 4 array array rtol(i)*abs(y(i)) + atol(i) +! +! when either of these parameters is a scalar, it need not +! be dimensioned in the user's calling program. +! +! if none of the above choices (with itol, rtol, and atol +! fixed throughout the problem) is suitable, more general +! error controls can be obtained by substituting +! user-supplied routines for the setting of ewt and/or for +! the norm calculation. see part iv below. +! +! if global errors are to be estimated by making a repeated +! run on the same problem with smaller tolerances, then all +! components of rtol and atol (i.e. of ewt) should be scaled +! down uniformly. +! +! itask = an index specifying the task to be performed. +! input only. itask has the following values and meanings. +! 1 means normal computation of output values of y(t) at +! t = tout (by overshooting and interpolating). +! 2 means take one step only and return. +! 3 means stop at the first internal mesh point at or +! beyond t = tout and return. +! 4 means normal computation of output values of y(t) at +! t = tout but without overshooting t = tcrit. +! tcrit must be input as rwork(1). tcrit may be equal to +! or beyond tout, but not behind it in the direction of +! integration. this option is useful if the problem +! has a singularity at or beyond t = tcrit. +! 5 means take one step, without passing tcrit, and return. +! tcrit must be input as rwork(1). +! +! note: if itask = 4 or 5 and the solver reaches tcrit +! (within roundoff), it will return t = tcrit (exactly) to +! indicate this (unless itask = 4 and tout comes before tcrit, +! in which case answers at t = tout are returned first). +! +! istate = an index used for input and output to specify the +! the state of the calculation. +! +! in the input, the values of istate are as follows. +! 1 means this is the first call for the problem +! (initializations will be done). see note below. +! 2 means this is not the first call, and the calculation +! is to continue normally, with no change in any input +! parameters except possibly tout and itask. +! (if itol, rtol, and/or atol are changed between calls +! with istate = 2, the new values will be used but not +! tested for legality.) +! 3 means this is not the first call, and the +! calculation is to continue normally, but with +! a change in input parameters other than +! tout and itask. changes are allowed in +! neq, itol, rtol, atol, iopt, lrw, liw, mf, ml, mu, +! and any of the optional input except h0. +! (see iwork description for ml and mu.) +! note: a preliminary call with tout = t is not counted +! as a first call here, as no initialization or checking of +! input is done. (such a call is sometimes useful to include +! the initial conditions in the output.) +! thus the first call for which tout .ne. t requires +! istate = 1 in the input. +! +! in the output, istate has the following values and meanings. +! 1 means nothing was done, as tout was equal to t with +! istate = 1 in the input. +! 2 means the integration was performed successfully. +! -1 means an excessive amount of work (more than mxstep +! steps) was done on this call, before completing the +! requested task, but the integration was otherwise +! successful as far as t. (mxstep is an optional input +! and is normally 500.) to continue, the user may +! simply reset istate to a value .gt. 1 and call again. +! (the excess work step counter will be reset to 0.) +! in addition, the user may increase mxstep to avoid +! this error return. (see optional input below.) +! -2 means too much accuracy was requested for the precision +! of the machine being used. this was detected before +! completing the requested task, but the integration +! was successful as far as t. to continue, the tolerance +! parameters must be reset, and istate must be set +! to 3. the optional output tolsf may be used for this +! purpose. (note: if this condition is detected before +! taking any steps, then an illegal input return +! (istate = -3) occurs instead.) +! -3 means illegal input was detected, before taking any +! integration steps. see written message for details. +! note: if the solver detects an infinite loop of calls +! to the solver with illegal input, it will cause +! the run to stop. +! -4 means there were repeated error test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! the problem may have a singularity, or the input +! may be inappropriate. +! -5 means there were repeated convergence test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! this may be caused by an inaccurate jacobian matrix, +! if one is being used. +! -6 means ewt(i) became zero for some i during the +! integration. pure relative error control (atol(i)=0.0) +! was requested on a variable which has now vanished. +! the integration was successful as far as t. +! +! note: since the normal output value of istate is 2, +! it does not need to be reset for normal continuation. +! also, since a negative input value of istate will be +! regarded as illegal, a negative output value requires the +! user to change it, and possibly other input, before +! calling the solver again. +! +! iopt = an integer flag to specify whether or not any optional +! input is being used on this call. input only. +! the optional input is listed separately below. +! iopt = 0 means no optional input is being used. +! default values will be used in all cases. +! iopt = 1 means optional input is being used. +! +! rwork = a real working array (double precision). +! the length of rwork must be at least +! 20 + nyh*(maxord + 1) + 3*neq + lwm where +! nyh = the initial value of neq, +! maxord = 12 (if meth = 1) or 5 (if meth = 2) (unless a +! smaller value is given as an optional input), +! lwm = length of work space for matrix-related data: +! lwm = 0 if miter = 0, +! lwm = 2*neq**2 + 2 if miter = 1 or 2, and mf.gt.0, +! lwm = neq**2 + 2 if miter = 1 or 2, and mf.lt.0, +! lwm = neq + 2 if miter = 3, +! lwm = (3*ml+2*mu+2)*neq + 2 if miter = 4 or 5, and mf.gt.0, +! lwm = (2*ml+mu+1)*neq + 2 if miter = 4 or 5, and mf.lt.0. +! (see the mf description for meth and miter.) +! thus if maxord has its default value and neq is constant, +! this length is: +! 20 + 16*neq for mf = 10, +! 22 + 16*neq + 2*neq**2 for mf = 11 or 12, +! 22 + 16*neq + neq**2 for mf = -11 or -12, +! 22 + 17*neq for mf = 13, +! 22 + 18*neq + (3*ml+2*mu)*neq for mf = 14 or 15, +! 22 + 17*neq + (2*ml+mu)*neq for mf = -14 or -15, +! 20 + 9*neq for mf = 20, +! 22 + 9*neq + 2*neq**2 for mf = 21 or 22, +! 22 + 9*neq + neq**2 for mf = -21 or -22, +! 22 + 10*neq for mf = 23, +! 22 + 11*neq + (3*ml+2*mu)*neq for mf = 24 or 25. +! 22 + 10*neq + (2*ml+mu)*neq for mf = -24 or -25. +! the first 20 words of rwork are reserved for conditional +! and optional input and optional output. +! +! the following word in rwork is a conditional input: +! rwork(1) = tcrit = critical value of t which the solver +! is not to overshoot. required if itask is +! 4 or 5, and ignored otherwise. (see itask.) +! +! lrw = the length of the array rwork, as declared by the user. +! (this will be checked by the solver.) +! +! iwork = an integer work array. the length of iwork must be at least +! 30 if miter = 0 or 3 (mf = 10, 13, 20, 23), or +! 30 + neq otherwise (abs(mf) = 11,12,14,15,21,22,24,25). +! the first 30 words of iwork are reserved for conditional and +! optional input and optional output. +! +! the following 2 words in iwork are conditional input: +! iwork(1) = ml these are the lower and upper +! iwork(2) = mu half-bandwidths, respectively, of the +! banded jacobian, excluding the main diagonal. +! the band is defined by the matrix locations +! (i,j) with i-ml .le. j .le. i+mu. ml and mu +! must satisfy 0 .le. ml,mu .le. neq-1. +! these are required if miter is 4 or 5, and +! ignored otherwise. ml and mu may in fact be +! the band parameters for a matrix to which +! df/dy is only approximately equal. +! +! liw = the length of the array iwork, as declared by the user. +! (this will be checked by the solver.) +! +! note: the work arrays must not be altered between calls to dvode +! for the same problem, except possibly for the conditional and +! optional input, and except for the last 3*neq words of rwork. +! the latter space is used for internal scratch space, and so is +! available for use by the user outside dvode between calls, if +! desired (but not for use by f or jac). +! +! jac = the name of the user-supplied routine (miter = 1 or 4) to +! compute the jacobian matrix, df/dy, as a function of +! the scalar t and the vector y. it is to have the form +! subroutine jac (neq, t, y, ml, mu, pd, nrowpd, +! rpar, ipar) +! double precision t, y(neq), pd(nrowpd,neq), rpar +! where neq, t, y, ml, mu, and nrowpd are input and the array +! pd is to be loaded with partial derivatives (elements of the +! jacobian matrix) in the output. pd must be given a first +! dimension of nrowpd. t and y have the same meaning as in +! subroutine f. +! in the full matrix case (miter = 1), ml and mu are +! ignored, and the jacobian is to be loaded into pd in +! columnwise manner, with df(i)/dy(j) loaded into pd(i,j). +! in the band matrix case (miter = 4), the elements +! within the band are to be loaded into pd in columnwise +! manner, with diagonal lines of df/dy loaded into the rows +! of pd. thus df(i)/dy(j) is to be loaded into pd(i-j+mu+1,j). +! ml and mu are the half-bandwidth parameters. (see iwork). +! the locations in pd in the two triangular areas which +! correspond to nonexistent matrix elements can be ignored +! or loaded arbitrarily, as they are overwritten by dvode. +! jac need not provide df/dy exactly. a crude +! approximation (possibly with a smaller bandwidth) will do. +! in either case, pd is preset to zero by the solver, +! so that only the nonzero elements need be loaded by jac. +! each call to jac is preceded by a call to f with the same +! arguments neq, t, and y. thus to gain some efficiency, +! intermediate quantities shared by both calculations may be +! saved in a user common block by f and not recomputed by jac, +! if desired. also, jac may alter the y array, if desired. +! jac must be declared external in the calling program. +! subroutine jac may access user-defined real and integer +! work arrays, rpar and ipar, whose dimensions are set by the +! user in the main program. +! +! mf = the method flag. used only for input. the legal values of +! mf are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, +! -11, -12, -14, -15, -21, -22, -24, -25. +! mf is a signed two-digit integer, mf = jsv*(10*meth + miter). +! jsv = sign(mf) indicates the jacobian-saving strategy: +! jsv = 1 means a copy of the jacobian is saved for reuse +! in the corrector iteration algorithm. +! jsv = -1 means a copy of the jacobian is not saved +! (valid only for miter = 1, 2, 4, or 5). +! meth indicates the basic linear multistep method: +! meth = 1 means the implicit adams method. +! meth = 2 means the method based on backward +! differentiation formulas (bdf-s). +! miter indicates the corrector iteration method: +! miter = 0 means functional iteration (no jacobian matrix +! is involved). +! miter = 1 means chord iteration with a user-supplied +! full (neq by neq) jacobian. +! miter = 2 means chord iteration with an internally +! generated (difference quotient) full jacobian +! (using neq extra calls to f per df/dy value). +! miter = 3 means chord iteration with an internally +! generated diagonal jacobian approximation +! (using 1 extra call to f per df/dy evaluation). +! miter = 4 means chord iteration with a user-supplied +! banded jacobian. +! miter = 5 means chord iteration with an internally +! generated banded jacobian (using ml+mu+1 extra +! calls to f per df/dy evaluation). +! if miter = 1 or 4, the user must supply a subroutine jac +! (the name is arbitrary) as described above under jac. +! for other values of miter, a dummy argument can be used. +! +! rpar user-specified array used to communicate real parameters +! to user-supplied subroutines. if rpar is a vector, then +! it must be dimensioned in the user's main program. if it +! is unused or it is a scalar, then it need not be +! dimensioned. +! +! ipar user-specified array used to communicate integer parameter +! to user-supplied subroutines. the comments on dimensioning +! rpar apply to ipar. +!----------------------------------------------------------------------- +! optional input. +! +! the following is a list of the optional input provided for in the +! call sequence. (see also part ii.) for each such input variable, +! this table lists its name as used in this documentation, its +! location in the call sequence, its meaning, and the default value. +! the use of any of this input requires iopt = 1, and in that +! case all of this input is examined. a value of zero for any +! of these optional input variables will cause the default value to be +! used. thus to use a subset of the optional input, simply preload +! locations 5 to 10 in rwork and iwork to 0.0 and 0 respectively, and +! then set those of interest to nonzero values. +! +! name location meaning and default value +! +! h0 rwork(5) the step size to be attempted on the first step. +! the default value is determined by the solver. +! +! hmax rwork(6) the maximum absolute step size allowed. +! the default value is infinite. +! +! hmin rwork(7) the minimum absolute step size allowed. +! the default value is 0. (this lower bound is not +! enforced on the final step before reaching tcrit +! when itask = 4 or 5.) +! +! maxord iwork(5) the maximum order to be allowed. the default +! value is 12 if meth = 1, and 5 if meth = 2. +! if maxord exceeds the default value, it will +! be reduced to the default value. +! if maxord is changed during the problem, it may +! cause the current order to be reduced. +! +! mxstep iwork(6) maximum number of (internally defined) steps +! allowed during one call to the solver. +! the default value is 500. +! +! mxhnil iwork(7) maximum number of messages printed (per problem) +! warning that t + h = t on a step (h = step size). +! this must be positive to result in a non-default +! value. the default value is 10. +! +!----------------------------------------------------------------------- +! optional output. +! +! as optional additional output from dvode, the variables listed +! below are quantities related to the performance of dvode +! which are available to the user. these are communicated by way of +! the work arrays, but also have internal mnemonic names as shown. +! except where stated otherwise, all of this output is defined +! on any successful return from dvode, and on any return with +! istate = -1, -2, -4, -5, or -6. on an illegal input return +! (istate = -3), they will be unchanged from their existing values +! (if any), except possibly for tolsf, lenrw, and leniw. +! on any error return, output relevant to the error will be defined, +! as noted below. +! +! name location meaning +! +! hu rwork(11) the step size in t last used (successfully). +! +! hcur rwork(12) the step size to be attempted on the next step. +! +! tcur rwork(13) the current value of the independent variable +! which the solver has actually reached, i.e. the +! current internal mesh point in t. in the output, +! tcur will always be at least as far from the +! initial value of t as the current argument t, +! but may be farther (if interpolation was done). +! +! tolsf rwork(14) a tolerance scale factor, greater than 1.0, +! computed when a request for too much accuracy was +! detected (istate = -3 if detected at the start of +! the problem, istate = -2 otherwise). if itol is +! left unaltered but rtol and atol are uniformly +! scaled up by a factor of tolsf for the next call, +! then the solver is deemed likely to succeed. +! (the user may also ignore tolsf and alter the +! tolerance parameters in any other way appropriate.) +! +! nst iwork(11) the number of steps taken for the problem so far. +! +! nfe iwork(12) the number of f evaluations for the problem so far. +! +! nje iwork(13) the number of jacobian evaluations so far. +! +! nqu iwork(14) the method order last used (successfully). +! +! nqcur iwork(15) the order to be attempted on the next step. +! +! imxer iwork(16) the index of the component of largest magnitude in +! the weighted local error vector ( e(i)/ewt(i) ), +! on an error return with istate = -4 or -5. +! +! lenrw iwork(17) the length of rwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! leniw iwork(18) the length of iwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! nlu iwork(19) the number of matrix lu decompositions so far. +! +! nni iwork(20) the number of nonlinear (newton) iterations so far. +! +! ncfn iwork(21) the number of convergence failures of the nonlinear +! solver so far. +! +! netf iwork(22) the number of error test failures of the integrator +! so far. +! +! the following two arrays are segments of the rwork array which +! may also be of interest to the user as optional output. +! for each array, the table below gives its internal name, +! its base address in rwork, and its description. +! +! name base address description +! +! yh 21 the nordsieck history array, of size nyh by +! (nqcur + 1), where nyh is the initial value +! of neq. for j = 0,1,...,nqcur, column j+1 +! of yh contains hcur**j/factorial(j) times +! the j-th derivative of the interpolating +! polynomial currently representing the +! solution, evaluated at t = tcur. +! +! acor lenrw-neq+1 array of size neq used for the accumulated +! corrections on each step, scaled in the output +! to represent the estimated local error in y +! on the last step. this is the vector e in +! the description of the error control. it is +! defined only on a successful return from dvode. +! +!----------------------------------------------------------------------- +! interrupting and restarting +! +! if the integration of a given problem by dvode is to be +! interrrupted and then later continued, such as when restarting +! an interrupted run or alternating between two or more ode problems, +! the user should save, following the return from the last dvode call +! prior to the interruption, the contents of the call sequence +! variables and internal common blocks, and later restore these +! values before the next dvode call for that problem. to save +! and restore the common blocks, use subroutine dvsrco, as +! described below in part ii. +! +! in addition, if non-default values for either lun or mflag are +! desired, an extra call to xsetun and/or xsetf should be made just +! before continuing the integration. see part ii below for details. +! +!----------------------------------------------------------------------- +! part ii. other routines callable. +! +! the following are optional calls which the user may make to +! gain additional capabilities in conjunction with dvode. +! (the routines xsetun and xsetf are designed to conform to the +! slatec error handling package.) +! +! form of call function +! call xsetun(lun) set the logical unit number, lun, for +! output of messages from dvode, if +! the default is not desired. +! the default value of lun is 6. +! +! call xsetf(mflag) set a flag to control the printing of +! messages by dvode. +! mflag = 0 means do not print. (danger: +! this risks losing valuable information.) +! mflag = 1 means print (the default). +! +! either of the above calls may be made at +! any time and will take effect immediately. +! +! call dvsrco(rsav,isav,job) saves and restores the contents of +! the internal common blocks used by +! dvode. (see part iii below.) +! rsav must be a real array of length 49 +! or more, and isav must be an integer +! array of length 40 or more. +! job=1 means save common into rsav/isav. +! job=2 means restore common from rsav/isav. +! dvsrco is useful if one is +! interrupting a run and restarting +! later, or alternating between two or +! more problems solved with dvode. +! +! call dvindy(,,,,,) provide derivatives of y, of various +! (see below.) orders, at a specified point t, if +! desired. it may be called only after +! a successful return from dvode. +! +! the detailed instructions for using dvindy are as follows. +! the form of the call is: +! +! call dvindy (t, k, rwork(21), nyh, dky, iflag) +! +! the input parameters are: +! +! t = value of independent variable where answers are desired +! (normally the same as the t last returned by dvode). +! for valid results, t must lie between tcur - hu and tcur. +! (see optional output for tcur and hu.) +! k = integer order of the derivative desired. k must satisfy +! 0 .le. k .le. nqcur, where nqcur is the current order +! (see optional output). the capability corresponding +! to k = 0, i.e. computing y(t), is already provided +! by dvode directly. since nqcur .ge. 1, the first +! derivative dy/dt is always available with dvindy. +! rwork(21) = the base address of the history array yh. +! nyh = column length of yh, equal to the initial value of neq. +! +! the output parameters are: +! +! dky = a real array of length neq containing the computed value +! of the k-th derivative of y(t). +! iflag = integer flag, returned as 0 if k and t were legal, +! -1 if k was illegal, and -2 if t was illegal. +! on an error return, a message is also written. +!----------------------------------------------------------------------- +! part iii. common blocks. +! if dvode is to be used in an overlay situation, the user +! must declare, in the primary overlay, the variables in: +! (1) the call sequence to dvode, +! (2) the two internal common blocks +! /dvod_cmn01/ of length 81 (48 double precision words +! followed by 33 integer words), +! /dvod_cmn02/ of length 9 (1 double precision word +! followed by 8 integer words), +! +! if dvode is used on a system in which the contents of internal +! common blocks are not preserved between calls, the user should +! declare the above two common blocks in his main program to insure +! that their contents are preserved. +! +!----------------------------------------------------------------------- +! part iv. optionally replaceable solver routines. +! +! below are descriptions of two routines in the dvode package which +! relate to the measurement of errors. either routine can be +! replaced by a user-supplied version, if desired. however, since such +! a replacement may have a major impact on performance, it should be +! done only when absolutely necessary, and only with great caution. +! (note: the means by which the package version of a routine is +! superseded by the user's version may be system-dependent.) +! +! (a) dewset. +! the following subroutine is called just before each internal +! integration step, and sets the array of error weights, ewt, as +! described under itol/rtol/atol above: +! subroutine dewset (neq, itol, rtol, atol, ycur, ewt) +! where neq, itol, rtol, and atol are as in the dvode call sequence, +! ycur contains the current dependent variable vector, and +! ewt is the array of weights set by dewset. +! +! if the user supplies this subroutine, it must return in ewt(i) +! (i = 1,...,neq) a positive quantity suitable for comparison with +! errors in y(i). the ewt array returned by dewset is passed to the +! dvnorm routine (see below.), and also used by dvode in the computation +! of the optional output imxer, the diagonal jacobian approximation, +! and the increments for difference quotient jacobians. +! +! in the user-supplied version of dewset, it may be desirable to use +! the current values of derivatives of y. derivatives up to order nq +! are available from the history array yh, described above under +! optional output. in dewset, yh is identical to the ycur array, +! extended to nq + 1 columns with a column length of nyh and scale +! factors of h**j/factorial(j). on the first call for the problem, +! given by nst = 0, nq is 1 and h is temporarily set to 1.0. +! nyh is the initial value of neq. the quantities nq, h, and nst +! can be obtained by including in dewset the statements: +! double precision rvod, h, hu +! common /dvod_cmn01/ rvod(48), ivod(33) +! common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! nq = ivod(28) +! h = rvod(21) +! thus, for example, the current value of dy/dt can be obtained as +! ycur(nyh+i)/h (i=1,...,neq) (and the division by h is +! unnecessary when nst = 0). +! +! (b) dvnorm. +! the following is a real function routine which computes the weighted +! root-mean-square norm of a vector v: +! d = dvnorm (n, v, w) +! where: +! n = the length of the vector, +! v = real array of length n containing the vector, +! w = real array of length n containing weights, +! d = sqrt( (1/n) * sum(v(i)*w(i))**2 ). +! dvnorm is called with n = neq and with w(i) = 1.0/ewt(i), where +! ewt is as set by subroutine dewset. +! +! if the user supplies this function, it should return a non-negative +! value of dvnorm suitable for use in the error control in dvode. +! none of the arguments should be altered by dvnorm. +! for example, a user-supplied dvnorm routine might: +! -substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +! -ignore some components of v in the norm, with the effect of +! suppressing the error control on those components of y. +!----------------------------------------------------------------------- +! revision history (yyyymmdd) +! 19890615 date written. initial release. +! 19890922 added interrupt/restart ability, minor changes throughout. +! 19910228 minor revisions in line format, prologue, etc. +! 19920227 modifications by d. pang: +! (1) applied subgennam to get generic intrinsic names. +! (2) changed intrinsic names to generic in comments. +! (3) added *deck lines before each routine. +! 19920721 names of routines and labeled common blocks changed, so as +! to be unique in combined single/double precision code (ach). +! 19920722 minor revisions to prologue (ach). +! 19920831 conversion to double precision done (ach). +! 19921106 fixed minor bug: etaq,etaqm1 in dvstep save statement (ach). +! 19921118 changed lunsav/mflgsv to ixsav (ach). +! 19941222 removed mf overwrite; attached sign to h in estimated second +! deriv. in dvhin; misc. comment changes throughout (ach). +! 19970515 minor corrections to comments in prologue, dvjac (ach). +! 19981111 corrected block b by adding final line, go to 200 (ach). +! 20020430 various upgrades (ach): use odepack error handler package. +! replaced d1mach by dumach. various changes to main +! prologue and other routine prologues. +!----------------------------------------------------------------------- +! other routines in the dvode package. +! +! in addition to subroutine dvode, the dvode package includes the +! following subroutines and function routines: +! dvhin computes an approximate step size for the initial step. +! dvindy computes an interpolated value of the y vector at t = tout. +! dvstep is the core integrator, which does one step of the +! integration and the associated error control. +! dvset sets all method coefficients and test constants. +! dvnlsd solves the underlying nonlinear system -- the corrector. +! dvjac computes and preprocesses the jacobian matrix j = df/dy +! and the newton iteration matrix p = i - (h/l1)*j. +! dvsol manages solution of linear system in chord iteration. +! dvjust adjusts the history array on a change of order. +! dewset sets the error weight vector ewt before each step. +! dvnorm computes the weighted r.m.s. norm of a vector. +! dvsrco is a user-callable routine to save and restore +! the contents of the internal common blocks. +! dacopy is a routine to copy one two-dimensional array to another. +! dgefa and dgesl are routines from linpack for solving full +! systems of linear algebraic equations. +! dgbfa and dgbsl are routines from linpack for solving banded +! linear systems. +! daxpy, dscal, and dcopy are basic linear algebra modules (blas). +! dumach sets the unit roundoff of the machine. +! xerrwd, xsetun, xsetf, ixsav, and iumach handle the printing of all +! error messages and warnings. xerrwd is machine-dependent. +! note: dvnorm, dumach, ixsav, and iumach are function routines. +! all the others are subroutines. +! +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block dvod_cmn02 -------------------- +! + double precision hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! external dvnlsd + logical ihit + double precision atoli, big, ewti, four, h0, hmax, hmx, hun, one, & + pt2, rh, rtoli, size, tcrit, tnext, tolsf, tp, two, zero + integer i, ier, iflag, imxer, jco, kgo, leniw, lenj, lenp, lenrw, & + lenwm, lf0, mband, mfa, ml, mord, mu, mxhnl0, mxstp0, niter, & + nslast + character*80 msg +! +! type declaration for function subroutines called --------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision dumach, dvnorm +! + dimension mord(2) +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to dvode. +!----------------------------------------------------------------------- + save mord, mxhnl0, mxstp0 + save zero, one, two, four, pt2, hun +!----------------------------------------------------------------------- +! the following internal common blocks contain variables which are +! communicated between subroutines in the dvode package, or which are +! to be saved between calls to dvode. +! in each block, real variables precede integers. +! the block /dvod_cmn01/ appears in subroutines dvode, dvindy, dvstep, +! dvset, dvnlsd, dvjac, dvsol, dvjust and dvsrco. +! the block /dvod_cmn02/ appears in subroutines dvode, dvindy, dvstep, +! dvnlsd, dvjac, and dvsrco. +! +! the variables stored in the internal common blocks are as follows: +! +! acnrm = weighted r.m.s. norm of accumulated correction vectors. +! ccmxj = threshhold on drc for updating the jacobian. (see drc.) +! conp = the saved value of tq(5). +! crate = estimated corrector convergence rate constant. +! drc = relative change in h*rl1 since last dvjac call. +! el = real array of integration coefficients. see dvset. +! eta = saved tentative ratio of new to old h. +! etamax = saved maximum value of eta to be allowed. +! h = the step size. +! hmin = the minimum absolute value of the step size h to be used. +! hmxi = inverse of the maximum absolute value of h to be used. +! hmxi = 0.0 is allowed and corresponds to an infinite hmax. +! hnew = the step size to be attempted on the next step. +! hscal = stepsize in scaling of yh array. +! prl1 = the saved value of rl1. +! rc = ratio of current h*rl1 to value on last dvjac call. +! rl1 = the reciprocal of the coefficient el(1). +! tau = real vector of past nq step sizes, length 13. +! tq = a real vector of length 5 in which dvset stores constants +! used for the convergence test, the error test, and the +! selection of h at a new order. +! tn = the independent variable, updated on each step taken. +! uround = the machine unit roundoff. the smallest positive real number +! such that 1.0 + uround .ne. 1.0 +! icf = integer flag for convergence failure in dvnlsd: +! 0 means no failures. +! 1 means convergence failure with out of date jacobian +! (recoverable error). +! 2 means convergence failure with current jacobian or +! singular matrix (unrecoverable error). +! init = saved integer flag indicating whether initialization of the +! problem has been done (init = 1) or not. +! ipup = saved flag to signal updating of newton matrix. +! jcur = output flag from dvjac showing jacobian status: +! jcur = 0 means j is not current. +! jcur = 1 means j is current. +! jstart = integer flag used as input to dvstep: +! 0 means perform the first step. +! 1 means take a new step continuing from the last. +! -1 means take the next step with a new value of maxord, +! hmin, hmxi, n, meth, miter, and/or matrix parameters. +! on return, dvstep sets jstart = 1. +! jsv = integer flag for jacobian saving, = sign(mf). +! kflag = a completion code from dvstep with the following meanings: +! 0 the step was succesful. +! -1 the requested error could not be achieved. +! -2 corrector convergence could not be achieved. +! -3, -4 fatal error in vnls (can not occur here). +! kuth = input flag to dvstep showing whether h was reduced by the +! driver. kuth = 1 if h was reduced, = 0 otherwise. +! l = integer variable, nq + 1, current order plus one. +! lmax = maxord + 1 (used for dimensioning). +! locjs = a pointer to the saved jacobian, whose storage starts at +! wm(locjs), if jsv = 1. +! lyh, lewt, lacor, lsavf, lwm, liwm = saved integer pointers +! to segments of rwork and iwork. +! maxord = the maximum order of integration method to be allowed. +! meth/miter = the method flags. see mf. +! msbj = the maximum number of steps between j evaluations, = 50. +! mxhnil = saved value of optional input mxhnil. +! mxstep = saved value of optional input mxstep. +! n = the number of first-order odes, = neq. +! newh = saved integer to flag change of h. +! newq = the method order to be used on the next step. +! nhnil = saved counter for occurrences of t + h = t. +! nq = integer variable, the current integration method order. +! nqnyh = saved value of nq*nyh. +! nqwait = a counter controlling the frequency of order changes. +! an order change is about to be considered if nqwait = 1. +! nslj = the number of steps taken as of the last jacobian update. +! nslp = saved value of nst as of last newton matrix update. +! nyh = saved value of the initial value of neq. +! hu = the step size in t last used. +! ncfn = number of nonlinear convergence failures so far. +! netf = the number of error test failures of the integrator so far. +! nfe = the number of f evaluations for the problem so far. +! nje = the number of jacobian evaluations so far. +! nlu = the number of matrix lu decompositions so far. +! nni = number of nonlinear iterations so far. +! nqu = the method order last used. +! nst = the number of steps taken for the problem so far. +!----------------------------------------------------------------------- + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data mord(1) /12/, mord(2) /5/, mxstp0 /500/, mxhnl0 /10/ + data zero /0.0d0/, one /1.0d0/, two /2.0d0/, four /4.0d0/, & + pt2 /0.2d0/, hun /100.0d0/ +!----------------------------------------------------------------------- +! block a. +! this code block is executed on every call. +! it tests istate and itask for legality and branches appropriately. +! if istate .gt. 1 but the flag init shows that initialization has +! not yet been done, an error return occurs. +! if istate = 1 and tout = t, return immediately. +!----------------------------------------------------------------------- + if (istate .lt. 1 .or. istate .gt. 3) go to 601 + if (itask .lt. 1 .or. itask .gt. 5) go to 602 + if (istate .eq. 1) go to 10 + if (init .ne. 1) go to 603 + if (istate .eq. 2) go to 200 + go to 20 + 10 init = 0 + if (tout .eq. t) return +!----------------------------------------------------------------------- +! block b. +! the next code block is executed for the initial call (istate = 1), +! or for a continuation call with parameter changes (istate = 3). +! it contains checking of all input and various initializations. +! +! first check legality of the non-optional input neq, itol, iopt, +! mf, ml, and mu. +!----------------------------------------------------------------------- + 20 if (neq .le. 0) go to 604 + if (istate .eq. 1) go to 25 + if (neq .gt. n) go to 605 + 25 n = neq + if (itol .lt. 1 .or. itol .gt. 4) go to 606 + if (iopt .lt. 0 .or. iopt .gt. 1) go to 607 + jsv = sign(1,mf) + mfa = abs(mf) + meth = mfa/10 + miter = mfa - 10*meth + if (meth .lt. 1 .or. meth .gt. 2) go to 608 + if (miter .lt. 0 .or. miter .gt. 5) go to 608 + if (miter .le. 3) go to 30 + ml = iwork(1) + mu = iwork(2) + if (ml .lt. 0 .or. ml .ge. n) go to 609 + if (mu .lt. 0 .or. mu .ge. n) go to 610 + 30 continue +! next process and check the optional input. --------------------------- + if (iopt .eq. 1) go to 40 + maxord = mord(meth) + mxstep = mxstp0 + mxhnil = mxhnl0 + if (istate .eq. 1) h0 = zero + hmxi = zero + hmin = zero + go to 60 + 40 maxord = iwork(5) + if (maxord .lt. 0) go to 611 + if (maxord .eq. 0) maxord = 100 + maxord = min(maxord,mord(meth)) + mxstep = iwork(6) + if (mxstep .lt. 0) go to 612 + if (mxstep .eq. 0) mxstep = mxstp0 + mxhnil = iwork(7) + if (mxhnil .lt. 0) go to 613 + if (mxhnil .eq. 0) mxhnil = mxhnl0 + if (istate .ne. 1) go to 50 + h0 = rwork(5) + if ((tout - t)*h0 .lt. zero) go to 614 + 50 hmax = rwork(6) + if (hmax .lt. zero) go to 615 + hmxi = zero + if (hmax .gt. zero) hmxi = one/hmax + hmin = rwork(7) + if (hmin .lt. zero) go to 616 +!----------------------------------------------------------------------- +! set work array pointers and check lengths lrw and liw. +! pointers to segments of rwork and iwork are named by prefixing l to +! the name of the segment. e.g., the segment yh starts at rwork(lyh). +! segments of rwork (in order) are denoted yh, wm, ewt, savf, acor. +! within wm, locjs is the location of the saved jacobian (jsv .gt. 0). +!----------------------------------------------------------------------- + 60 lyh = 21 + if (istate .eq. 1) nyh = n + lwm = lyh + (maxord + 1)*nyh + jco = max(0,jsv) + if (miter .eq. 0) lenwm = 0 + if (miter .eq. 1 .or. miter .eq. 2) then + lenwm = 2 + (1 + jco)*n*n + locjs = n*n + 3 + endif + if (miter .eq. 3) lenwm = 2 + n + if (miter .eq. 4 .or. miter .eq. 5) then + mband = ml + mu + 1 + lenp = (mband + ml)*n + lenj = mband*n + lenwm = 2 + lenp + jco*lenj + locjs = lenp + 3 + endif + lewt = lwm + lenwm + lsavf = lewt + n + lacor = lsavf + n + lenrw = lacor + n - 1 + iwork(17) = lenrw + liwm = 1 + leniw = 30 + n + if (miter .eq. 0 .or. miter .eq. 3) leniw = 30 + iwork(18) = leniw + if (lenrw .gt. lrw) go to 617 + if (leniw .gt. liw) go to 618 +! check rtol and atol for legality. ------------------------------------ + rtoli = rtol(1) + atoli = atol(1) + do 70 i = 1,n + if (itol .ge. 3) rtoli = rtol(i) + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + if (rtoli .lt. zero) go to 619 + if (atoli .lt. zero) go to 620 + 70 continue + if (istate .eq. 1) go to 100 +! if istate = 3, set flag to signal parameter changes to dvstep. ------- + jstart = -1 + if (nq .le. maxord) go to 90 +! maxord was reduced below nq. copy yh(*,maxord+2) into savf. --------- + call dcopy (n, rwork(lwm), 1, rwork(lsavf), 1) +! reload wm(1) = rwork(lwm), since lwm may have changed. --------------- + 90 if (miter .gt. 0) rwork(lwm) = sqrt(uround) + go to 200 +!----------------------------------------------------------------------- +! block c. +! the next block is for the initial call only (istate = 1). +! it contains all remaining initializations, the initial call to f, +! and the calculation of the initial step size. +! the error weights in ewt are inverted after being loaded. +!----------------------------------------------------------------------- + 100 uround = dumach() + tn = t + if (itask .ne. 4 .and. itask .ne. 5) go to 110 + tcrit = rwork(1) + if ((tcrit - tout)*(tout - t) .lt. zero) go to 625 + if (h0 .ne. zero .and. (t + h0 - tcrit)*h0 .gt. zero) & + h0 = tcrit - t + 110 jstart = 0 + if (miter .gt. 0) rwork(lwm) = sqrt(uround) + ccmxj = pt2 + msbj = 50 + nhnil = 0 + nst = 0 + nje = 0 + nni = 0 + ncfn = 0 + netf = 0 + nlu = 0 + nslj = 0 + nslast = 0 + hu = zero + nqu = 0 +! initial call to f. (lf0 points to yh(*,2).) ------------------------- + lf0 = lyh + nyh + call f (n, t, y, rwork(lf0), rpar, ipar) + nfe = 1 +! load the initial value vector in yh. --------------------------------- + call dcopy (n, y, 1, rwork(lyh), 1) +! load and invert the ewt array. (h is temporarily set to 1.0.) ------- + nq = 1 + h = one + call dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 120 i = 1,n + if (rwork(i+lewt-1) .le. zero) go to 621 + 120 rwork(i+lewt-1) = one/rwork(i+lewt-1) + if (h0 .ne. zero) go to 180 +! call dvhin to set initial step size h0 to be attempted. -------------- + call dvhin (n, t, rwork(lyh), rwork(lf0), f, rpar, ipar, tout, & + uround, rwork(lewt), itol, atol, y, rwork(lacor), h0, & + niter, ier) + nfe = nfe + niter + if (ier .ne. 0) go to 622 +! adjust h0 if necessary to meet hmax bound. --------------------------- + 180 rh = abs(h0)*hmxi + if (rh .gt. one) h0 = h0/rh +! load h with h0 and scale yh(*,2) by h0. ------------------------------ + h = h0 + call dscal (n, h0, rwork(lf0), 1) + go to 270 +!----------------------------------------------------------------------- +! block d. +! the next code block is for continuation calls only (istate = 2 or 3) +! and is to check stop conditions before taking a step. +!----------------------------------------------------------------------- + 200 nslast = nst + kuth = 0 + go to (210, 250, 220, 230, 240), itask + 210 if ((tn - tout)*h .lt. zero) go to 250 + call dvindy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 220 tp = tn - hu*(one + hun*uround) + if ((tp - tout)*h .gt. zero) go to 623 + if ((tn - tout)*h .lt. zero) go to 250 + go to 400 + 230 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. zero) go to 624 + if ((tcrit - tout)*h .lt. zero) go to 625 + if ((tn - tout)*h .lt. zero) go to 245 + call dvindy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 240 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. zero) go to 624 + 245 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx + if (ihit) go to 400 + tnext = tn + hnew*(one + four*uround) + if ((tnext - tcrit)*h .le. zero) go to 250 + h = (tcrit - tn)*(one - four*uround) + kuth = 1 +!----------------------------------------------------------------------- +! block e. +! the next block is normally executed for all calls and contains +! the call to the one-step core integrator dvstep. +! +! this is a looping point for the integration steps. +! +! first check for too many steps being taken, update ewt (if not at +! start of problem), check for too much accuracy being requested, and +! check for h below the roundoff level in t. +!----------------------------------------------------------------------- + 250 continue + if ((nst-nslast) .ge. mxstep) go to 500 + call dewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 260 i = 1,n + if (rwork(i+lewt-1) .le. zero) go to 510 + 260 rwork(i+lewt-1) = one/rwork(i+lewt-1) + 270 tolsf = uround*dvnorm (n, rwork(lyh), rwork(lewt)) + if (tolsf .le. one) go to 280 + tolsf = tolsf*two + if (nst .eq. 0) go to 626 + go to 520 + 280 if ((tn + h) .ne. tn) go to 290 + nhnil = nhnil + 1 + if (nhnil .gt. mxhnil) go to 290 + msg = 'dvode-- warning: internal t (=r1) and h (=r2) are' + call xerrwd (msg, 50, 101, 1, 0, 0, 0, 0, zero, zero) + msg=' such that in the machine, t + h = t on the next step ' + call xerrwd (msg, 60, 101, 1, 0, 0, 0, 0, zero, zero) + msg = ' (h = step size). solver will continue anyway' + call xerrwd (msg, 50, 101, 1, 0, 0, 0, 2, tn, h) + if (nhnil .lt. mxhnil) go to 290 + msg = 'dvode-- above warning has been issued i1 times. ' + call xerrwd (msg, 50, 102, 1, 0, 0, 0, 0, zero, zero) + msg = ' it will not be issued again for this problem' + call xerrwd (msg, 50, 102, 1, 1, mxhnil, 0, 0, zero, zero) + 290 continue +!----------------------------------------------------------------------- +! call dvstep (y, yh, nyh, yh, ewt, savf, vsav, acor, +! wm, iwm, f, jac, f, dvnlsd, rpar, ipar) +!----------------------------------------------------------------------- + call dvstep (y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), & + rwork(lsavf), y, rwork(lacor), rwork(lwm), iwork(liwm), & + f, jac, f, dvnlsd, rpar, ipar) + kgo = 1 - kflag +! branch on kflag. note: in this version, kflag can not be set to -3. +! kflag .eq. 0, -1, -2 + go to (300, 530, 540), kgo +!----------------------------------------------------------------------- +! block f. +! the following block handles the case of a successful return from the +! core integrator (kflag = 0). test for stop conditions. +!----------------------------------------------------------------------- + 300 init = 1 + kuth = 0 + go to (310, 400, 330, 340, 350), itask +! itask = 1. if tout has been reached, interpolate. ------------------- + 310 if ((tn - tout)*h .lt. zero) go to 250 + call dvindy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 +! itask = 3. jump to exit if tout was reached. ------------------------ + 330 if ((tn - tout)*h .ge. zero) go to 400 + go to 250 +! itask = 4. see if tout or tcrit was reached. adjust h if necessary. + 340 if ((tn - tout)*h .lt. zero) go to 345 + call dvindy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 + 345 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx + if (ihit) go to 400 + tnext = tn + hnew*(one + four*uround) + if ((tnext - tcrit)*h .le. zero) go to 250 + h = (tcrit - tn)*(one - four*uround) + kuth = 1 + go to 250 +! itask = 5. see if tcrit was reached and jump to exit. --------------- + 350 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx +!----------------------------------------------------------------------- +! block g. +! the following block handles all successful returns from dvode. +! if itask .ne. 1, y is loaded from yh and t is set accordingly. +! istate is set to 2, and the optional output is loaded into the work +! arrays before returning. +!----------------------------------------------------------------------- + 400 continue + call dcopy (n, rwork(lyh), 1, y, 1) + t = tn + if (itask .ne. 4 .and. itask .ne. 5) go to 420 + if (ihit) t = tcrit + 420 istate = 2 + rwork(11) = hu + rwork(12) = hnew + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = newq + iwork(19) = nlu + iwork(20) = nni + iwork(21) = ncfn + iwork(22) = netf + return +!----------------------------------------------------------------------- +! block h. +! the following block handles all unsuccessful returns other than +! those for illegal input. first the error message routine is called. +! if there was an error test or convergence test failure, imxer is set. +! then y is loaded from yh, and t is set to tn. +! the optional output is loaded into the work arrays before returning. +!----------------------------------------------------------------------- +! the maximum number of steps was taken before reaching tout. ---------- + 500 msg = 'dvode-- at current t (=r1), mxstep (=i1) steps ' + call xerrwd (msg, 50, 201, 1, 0, 0, 0, 0, zero, zero) + msg = ' taken on this call before reaching tout ' + call xerrwd (msg, 50, 201, 1, 1, mxstep, 0, 1, tn, zero) + istate = -1 + go to 580 +! ewt(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 ewti = rwork(lewt+i-1) + msg = 'dvode-- at t (=r1), ewt(i1) has become r2 .le. 0.' + call xerrwd (msg, 50, 202, 1, 1, i, 0, 2, tn, ewti) + istate = -6 + go to 580 +! too much accuracy requested for machine precision. ------------------- + 520 msg = 'dvode-- at t (=r1), too much accuracy requested ' + call xerrwd (msg, 50, 203, 1, 0, 0, 0, 0, zero, zero) + msg = ' for precision of machine: see tolsf (=r2) ' + call xerrwd (msg, 50, 203, 1, 0, 0, 0, 2, tn, tolsf) + rwork(14) = tolsf + istate = -2 + go to 580 +! kflag = -1. error test failed repeatedly or with abs(h) = hmin. ----- + 530 msg = 'dvode-- at t(=r1) and step size h(=r2), the error' + call xerrwd (msg, 50, 204, 1, 0, 0, 0, 0, zero, zero) + msg = ' test failed repeatedly or with abs(h) = hmin' + call xerrwd (msg, 50, 204, 1, 0, 0, 0, 2, tn, h) + istate = -4 + go to 560 +! kflag = -2. convergence failed repeatedly or with abs(h) = hmin. ---- + 540 msg = 'dvode-- at t (=r1) and step size h (=r2), the ' + call xerrwd (msg, 50, 205, 1, 0, 0, 0, 0, zero, zero) + msg = ' corrector convergence failed repeatedly ' + call xerrwd (msg, 50, 205, 1, 0, 0, 0, 0, zero, zero) + msg = ' or with abs(h) = hmin ' + call xerrwd (msg, 30, 205, 1, 0, 0, 0, 2, tn, h) + istate = -5 +! compute imxer if relevant. ------------------------------------------- + 560 big = zero + imxer = 1 + do 570 i = 1,n + size = abs(rwork(i+lacor-1)*rwork(i+lewt-1)) + if (big .ge. size) go to 570 + big = size + imxer = i + 570 continue + iwork(16) = imxer +! set y vector, t, and optional output. -------------------------------- + 580 continue + call dcopy (n, rwork(lyh), 1, y, 1) + t = tn + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nlu + iwork(20) = nni + iwork(21) = ncfn + iwork(22) = netf + return +!----------------------------------------------------------------------- +! block i. +! the following block handles all error returns due to illegal input +! (istate = -3), as detected before calling the core integrator. +! first the error message routine is called. if the illegal input +! is a negative istate, the run is aborted (apparent infinite loop). +!----------------------------------------------------------------------- + 601 msg = 'dvode-- istate (=i1) illegal ' + call xerrwd (msg, 30, 1, 1, 1, istate, 0, 0, zero, zero) + if (istate .lt. 0) go to 800 + go to 700 + 602 msg = 'dvode-- itask (=i1) illegal ' + call xerrwd (msg, 30, 2, 1, 1, itask, 0, 0, zero, zero) + go to 700 + 603 msg='dvode-- istate (=i1) .gt. 1 but dvode not initialized ' + call xerrwd (msg, 60, 3, 1, 1, istate, 0, 0, zero, zero) + go to 700 + 604 msg = 'dvode-- neq (=i1) .lt. 1 ' + call xerrwd (msg, 30, 4, 1, 1, neq, 0, 0, zero, zero) + go to 700 + 605 msg = 'dvode-- istate = 3 and neq increased (i1 to i2) ' + call xerrwd (msg, 50, 5, 1, 2, n, neq, 0, zero, zero) + go to 700 + 606 msg = 'dvode-- itol (=i1) illegal ' + call xerrwd (msg, 30, 6, 1, 1, itol, 0, 0, zero, zero) + go to 700 + 607 msg = 'dvode-- iopt (=i1) illegal ' + call xerrwd (msg, 30, 7, 1, 1, iopt, 0, 0, zero, zero) + go to 700 + 608 msg = 'dvode-- mf (=i1) illegal ' + call xerrwd (msg, 30, 8, 1, 1, mf, 0, 0, zero, zero) + go to 700 + 609 msg = 'dvode-- ml (=i1) illegal: .lt.0 or .ge.neq (=i2)' + call xerrwd (msg, 50, 9, 1, 2, ml, neq, 0, zero, zero) + go to 700 + 610 msg = 'dvode-- mu (=i1) illegal: .lt.0 or .ge.neq (=i2)' + call xerrwd (msg, 50, 10, 1, 2, mu, neq, 0, zero, zero) + go to 700 + 611 msg = 'dvode-- maxord (=i1) .lt. 0 ' + call xerrwd (msg, 30, 11, 1, 1, maxord, 0, 0, zero, zero) + go to 700 + 612 msg = 'dvode-- mxstep (=i1) .lt. 0 ' + call xerrwd (msg, 30, 12, 1, 1, mxstep, 0, 0, zero, zero) + go to 700 + 613 msg = 'dvode-- mxhnil (=i1) .lt. 0 ' + call xerrwd (msg, 30, 13, 1, 1, mxhnil, 0, 0, zero, zero) + go to 700 + 614 msg = 'dvode-- tout (=r1) behind t (=r2) ' + call xerrwd (msg, 40, 14, 1, 0, 0, 0, 2, tout, t) + msg = ' integration direction is given by h0 (=r1) ' + call xerrwd (msg, 50, 14, 1, 0, 0, 0, 1, h0, zero) + go to 700 + 615 msg = 'dvode-- hmax (=r1) .lt. 0.0 ' + call xerrwd (msg, 30, 15, 1, 0, 0, 0, 1, hmax, zero) + go to 700 + 616 msg = 'dvode-- hmin (=r1) .lt. 0.0 ' + call xerrwd (msg, 30, 16, 1, 0, 0, 0, 1, hmin, zero) + go to 700 + 617 continue + msg='dvode-- rwork length needed, lenrw (=i1), exceeds lrw (=i2)' + call xerrwd (msg, 60, 17, 1, 2, lenrw, lrw, 0, zero, zero) + go to 700 + 618 continue + msg='dvode-- iwork length needed, leniw (=i1), exceeds liw (=i2)' + call xerrwd (msg, 60, 18, 1, 2, leniw, liw, 0, zero, zero) + go to 700 + 619 msg = 'dvode-- rtol(i1) is r1 .lt. 0.0 ' + call xerrwd (msg, 40, 19, 1, 1, i, 0, 1, rtoli, zero) + go to 700 + 620 msg = 'dvode-- atol(i1) is r1 .lt. 0.0 ' + call xerrwd (msg, 40, 20, 1, 1, i, 0, 1, atoli, zero) + go to 700 + 621 ewti = rwork(lewt+i-1) + msg = 'dvode-- ewt(i1) is r1 .le. 0.0 ' + call xerrwd (msg, 40, 21, 1, 1, i, 0, 1, ewti, zero) + go to 700 + 622 continue + msg='dvode-- tout (=r1) too close to t(=r2) to start integration' + call xerrwd (msg, 60, 22, 1, 0, 0, 0, 2, tout, t) + go to 700 + 623 continue + msg='dvode-- itask = i1 and tout (=r1) behind tcur - hu (= r2) ' + call xerrwd (msg, 60, 23, 1, 1, itask, 0, 2, tout, tp) + go to 700 + 624 continue + msg='dvode-- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) ' + call xerrwd (msg, 60, 24, 1, 0, 0, 0, 2, tcrit, tn) + go to 700 + 625 continue + msg='dvode-- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) ' + call xerrwd (msg, 60, 25, 1, 0, 0, 0, 2, tcrit, tout) + go to 700 + 626 msg = 'dvode-- at start of problem, too much accuracy ' + call xerrwd (msg, 50, 26, 1, 0, 0, 0, 0, zero, zero) + msg=' requested for precision of machine: see tolsf (=r1) ' + call xerrwd (msg, 60, 26, 1, 0, 0, 0, 1, tolsf, zero) + rwork(14) = tolsf + go to 700 + 627 msg='dvode-- trouble from dvindy. itask = i1, tout = r1. ' + call xerrwd (msg, 60, 27, 1, 1, itask, 0, 1, tout, zero) +! + 700 continue + istate = -3 + return +! + 800 msg = 'dvode-- run aborted: apparent infinite loop ' + call xerrwd (msg, 50, 303, 2, 0, 0, 0, 0, zero, zero) + return +!----------------------- end of subroutine dvode ----------------------- + end subroutine dvode +!deck dvhin + subroutine dvhin (n, t0, y0, ydot, f, rpar, ipar, tout, uround, & + ewt, itol, atol, y, temp, h0, niter, ier) + external f + double precision t0, y0, ydot, rpar, tout, uround, ewt, atol, y, & + temp, h0 + integer n, ipar, itol, niter, ier + dimension y0(*), ydot(*), ewt(*), atol(*), y(*), & + temp(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- n, t0, y0, ydot, f, rpar, ipar, tout, uround, +! ewt, itol, atol, y, temp +! call sequence output -- h0, niter, ier +! common block variables accessed -- none +! +! subroutines called by dvhin: f +! function routines called by dvhi: dvnorm +!----------------------------------------------------------------------- +! this routine computes the step size, h0, to be attempted on the +! first step, when the user has not supplied a value for this. +! +! first we check that tout - t0 differs significantly from zero. then +! an iteration is done to approximate the initial second derivative +! and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. +! a bias factor of 1/2 is applied to the resulting h. +! the sign of h0 is inferred from the initial values of tout and t0. +! +! communication with dvhin is done with the following variables: +! +! n = size of ode system, input. +! t0 = initial value of independent variable, input. +! y0 = vector of initial conditions, input. +! ydot = vector of initial first derivatives, input. +! f = name of subroutine for right-hand side f(t,y), input. +! rpar, ipar = dummy names for user's real and integer work arrays. +! tout = first output value of independent variable +! uround = machine unit roundoff +! ewt, itol, atol = error weights and tolerance parameters +! as described in the driver routine, input. +! y, temp = work arrays of length n. +! h0 = step size to be attempted, output. +! niter = number of iterations (and of f evaluations) to compute h0, +! output. +! ier = the error flag, returned with the value +! ier = 0 if no trouble occurred, or +! ier = -1 if tout and t0 are considered too close to proceed. +!----------------------------------------------------------------------- +! +! type declarations for local variables -------------------------------- +! + double precision afi, atoli, delyi, h, half, hg, hlb, hnew, hrat, & + hub, hun, pt1, t1, tdist, tround, two, yddnrm + integer i, iter +! +! type declaration for function subroutines called --------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision dvnorm +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save half, hun, pt1, two + data half /0.5d0/, hun /100.0d0/, pt1 /0.1d0/, two /2.0d0/ +! + niter = 0 + tdist = abs(tout - t0) + tround = uround*max(abs(t0),abs(tout)) + if (tdist .lt. two*tround) go to 100 +! +! set a lower bound on h based on the roundoff level in t0 and tout. --- + hlb = hun*tround +! set an upper bound on h based on tout-t0 and the initial y and ydot. - + hub = pt1*tdist + atoli = atol(1) + do 10 i = 1, n + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + delyi = pt1*abs(y0(i)) + atoli + afi = abs(ydot(i)) + if (afi*hub .gt. delyi) hub = delyi/afi + 10 continue +! +! set initial guess for h as geometric mean of upper and lower bounds. - + iter = 0 + hg = sqrt(hlb*hub) +! if the bounds have crossed, exit with the mean value. ---------------- + if (hub .lt. hlb) then + h0 = hg + go to 90 + endif +! +! looping point for iteration. ----------------------------------------- + 50 continue +! estimate the second derivative as a difference quotient in f. -------- + h = sign (hg, tout - t0) + t1 = t0 + h + do 60 i = 1, n + 60 y(i) = y0(i) + h*ydot(i) + call f (n, t1, y, temp, rpar, ipar) + do 70 i = 1, n + 70 temp(i) = (temp(i) - ydot(i))/h + yddnrm = dvnorm (n, temp, ewt) +! get the corresponding new value of h. -------------------------------- + if (yddnrm*hub*hub .gt. two) then + hnew = sqrt(two/yddnrm) + else + hnew = sqrt(hg*hub) + endif + iter = iter + 1 +!----------------------------------------------------------------------- +! test the stopping conditions. +! stop if the new and previous h values differ by a factor of .lt. 2. +! stop if four iterations have been done. also, stop with previous h +! if hnew/hg .gt. 2 after first iteration, as this probably means that +! the second derivative value is bad because of cancellation error. +!----------------------------------------------------------------------- + if (iter .ge. 4) go to 80 + hrat = hnew/hg + if ( (hrat .gt. half) .and. (hrat .lt. two) ) go to 80 + if ( (iter .ge. 2) .and. (hnew .gt. two*hg) ) then + hnew = hg + go to 80 + endif + hg = hnew + go to 50 +! +! iteration done. apply bounds, bias factor, and sign. then exit. ---- + 80 h0 = hnew*half + if (h0 .lt. hlb) h0 = hlb + if (h0 .gt. hub) h0 = hub + 90 h0 = sign(h0, tout - t0) + niter = iter + ier = 0 + return +! error return for tout - t0 too small. -------------------------------- + 100 ier = -1 + return +!----------------------- end of subroutine dvhin ----------------------- + end subroutine dvhin +!deck dvindy + subroutine dvindy (t, k, yh, ldyh, dky, iflag) + double precision t, yh, dky + integer k, ldyh, iflag + dimension yh(ldyh,*), dky(*) +!----------------------------------------------------------------------- +! call sequence input -- t, k, yh, ldyh +! call sequence output -- dky, iflag +! common block variables accessed: +! /dvod_cmn01/ -- h, tn, uround, l, n, nq +! /dvod_cmn02/ -- hu +! +! subroutines called by dvindy: dscal, xerrwd +! function routines called by dvindy: none +!----------------------------------------------------------------------- +! dvindy computes interpolated values of the k-th derivative of the +! dependent variable vector y, and stores it in dky. this routine +! is called within the package with k = 0 and t = tout, but may +! also be called by the user for any k up to the current order. +! (see detailed instructions in the usage documentation.) +!----------------------------------------------------------------------- +! the computed values in dky are gotten by interpolation using the +! nordsieck history array yh. this array corresponds uniquely to a +! vector-valued polynomial of degree nqcur or less, and dky is set +! to the k-th derivative of this polynomial at t. +! the formula for dky is: +! q +! dky(i) = sum c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1) +! j=k +! where c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur. +! the quantities nq = nqcur, l = nq+1, n, tn, and h are +! communicated by common. the above sum is done in reverse order. +! iflag is returned negative if either k or t is out of bounds. +! +! discussion above and comments in driver explain all variables. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block dvod_cmn02 -------------------- +! + double precision hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + double precision c, hun, r, s, tfuzz, tn1, tp, zero + integer i, ic, j, jb, jb2, jj, jj1, jp1 + character*80 msg +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save hun, zero +! + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data hun /100.0d0/, zero /0.0d0/ +! + iflag = 0 + if (k .lt. 0 .or. k .gt. nq) go to 80 + tfuzz = hun*uround*(tn + hu) + tp = tn - hu - tfuzz + tn1 = tn + tfuzz + if ((t-tp)*(t-tn1) .gt. zero) go to 90 +! + s = (t - tn)/h + ic = 1 + if (k .eq. 0) go to 15 + jj1 = l - k + do 10 jj = jj1, nq + 10 ic = ic*jj + 15 c = real(ic) + do 20 i = 1, n + 20 dky(i) = c*yh(i,l) + if (k .eq. nq) go to 55 + jb2 = nq - k + do 50 jb = 1, jb2 + j = nq - jb + jp1 = j + 1 + ic = 1 + if (k .eq. 0) go to 35 + jj1 = jp1 - k + do 30 jj = jj1, j + 30 ic = ic*jj + 35 c = real(ic) + do 40 i = 1, n + 40 dky(i) = c*yh(i,jp1) + s*dky(i) + 50 continue + if (k .eq. 0) return + 55 r = h**(-k) + call dscal (n, r, dky, 1) + return +! + 80 msg = 'dvindy-- k (=i1) illegal ' + call xerrwd (msg, 30, 51, 1, 1, k, 0, 0, zero, zero) + iflag = -1 + return + 90 msg = 'dvindy-- t (=r1) illegal ' + call xerrwd (msg, 30, 52, 1, 0, 0, 0, 1, t, zero) + msg=' t not in interval tcur - hu (= r1) to tcur (=r2) ' + call xerrwd (msg, 60, 52, 1, 0, 0, 0, 2, tp, tn) + iflag = -2 + return +!----------------------- end of subroutine dvindy ---------------------- + end subroutine dvindy +!deck dvstep + subroutine dvstep (y, yh, ldyh, yh1, ewt, savf, vsav, acor, & + wm, iwm, f, jac, psol, vnls, rpar, ipar) + external f, jac, psol, vnls + double precision y, yh, yh1, ewt, savf, vsav, acor, wm, rpar + integer ldyh, iwm, ipar + dimension y(*), yh(ldyh,*), yh1(*), ewt(*), savf(*), vsav(*), & + acor(*), wm(*), iwm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, yh1, ewt, savf, vsav, +! acor, wm, iwm, f, jac, psol, vnls, rpar, ipar +! call sequence output -- yh, acor, wm, iwm +! common block variables accessed: +! /dvod_cmn01/ acnrm, el(13), h, hmin, hmxi, hnew, hscal, rc, tau(13), +! tq(5), tn, jcur, jstart, kflag, kuth, +! l, lmax, maxord, n, newq, nq, nqwait +! /dvod_cmn02/ hu, ncfn, netf, nfe, nqu, nst +! +! subroutines called by dvstep: f, daxpy, dcopy, dscal, +! dvjust, vnls, dvset +! function routines called by dvstep: dvnorm +!----------------------------------------------------------------------- +! dvstep performs one step of the integration of an initial value +! problem for a system of ordinary differential equations. +! dvstep calls subroutine vnls for the solution of the nonlinear system +! arising in the time step. thus it is independent of the problem +! jacobian structure and the type of nonlinear system solution method. +! dvstep returns a completion flag kflag (in common). +! a return with kflag = -1 or -2 means either abs(h) = hmin or 10 +! consecutive failures occurred. on a return with kflag negative, +! the values of tn and the yh array are as of the beginning of the last +! step, and h is the last step size attempted. +! +! communication with dvstep is done with the following variables: +! +! y = an array of length n used for the dependent variable vector. +! yh = an ldyh by lmax array containing the dependent variables +! and their approximate scaled derivatives, where +! lmax = maxord + 1. yh(i,j+1) contains the approximate +! j-th derivative of y(i), scaled by h**j/factorial(j) +! (j = 0,1,...,nq). on entry for the first step, the first +! two columns of yh must be set from the initial values. +! ldyh = a constant integer .ge. n, the first dimension of yh. +! n is the number of odes in the system. +! yh1 = a one-dimensional array occupying the same space as yh. +! ewt = an array of length n containing multiplicative weights +! for local error measurements. local errors in y(i) are +! compared to 1.0/ewt(i) in various error tests. +! savf = an array of working storage, of length n. +! also used for input of yh(*,maxord+2) when jstart = -1 +! and maxord .lt. the current order nq. +! vsav = a work array of length n passed to subroutine vnls. +! acor = a work array of length n, used for the accumulated +! corrections. on a successful return, acor(i) contains +! the estimated one-step local error in y(i). +! wm,iwm = real and integer work arrays associated with matrix +! operations in vnls. +! f = dummy name for the user supplied subroutine for f. +! jac = dummy name for the user supplied jacobian subroutine. +! psol = dummy name for the subroutine passed to vnls, for +! possible use there. +! vnls = dummy name for the nonlinear system solving subroutine, +! whose real name is dependent on the method used. +! rpar, ipar = dummy names for user's real and integer work arrays. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block dvod_cmn02 -------------------- +! + double precision hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + double precision addon, bias1,bias2,bias3, cnquot, ddn, dsm, dup, & + etacf, etamin, etamx1, etamx2, etamx3, etamxf, & + etaq, etaqm1, etaqp1, flotl, one, onepsm, & + r, thresh, told, zero + integer i, i1, i2, iback, j, jb, kfc, kfh, mxncf, ncf, nflag +! +! type declaration for function subroutines called --------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision dvnorm +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save addon, bias1, bias2, bias3, & + etacf, etamin, etamx1, etamx2, etamx3, etamxf, etaq, etaqm1, & + kfc, kfh, mxncf, onepsm, thresh, one, zero +!----------------------------------------------------------------------- + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data kfc/-3/, kfh/-7/, mxncf/10/ + data addon /1.0d-6/, bias1 /6.0d0/, bias2 /6.0d0/, & + bias3 /10.0d0/, etacf /0.25d0/, etamin /0.1d0/, & + etamxf /0.2d0/, etamx1 /1.0d4/, etamx2 /10.0d0/, & + etamx3 /10.0d0/, onepsm /1.00001d0/, thresh /1.5d0/ + data one/1.0d0/, zero/0.0d0/ +! + kflag = 0 + told = tn + ncf = 0 + jcur = 0 + nflag = 0 + if (jstart .gt. 0) go to 20 + if (jstart .eq. -1) go to 100 +!----------------------------------------------------------------------- +! on the first call, the order is set to 1, and other variables are +! initialized. etamax is the maximum ratio by which h can be increased +! in a single step. it is normally 10, but is larger during the +! first step to compensate for the small initial h. if a failure +! occurs (in corrector convergence or error test), etamax is set to 1 +! for the next increase. +!----------------------------------------------------------------------- + lmax = maxord + 1 + nq = 1 + l = 2 + nqnyh = nq*ldyh + tau(1) = h + prl1 = one + rc = zero + etamax = etamx1 + nqwait = 2 + hscal = h + go to 200 +!----------------------------------------------------------------------- +! take preliminary actions on a normal continuation step (jstart.gt.0). +! if the driver changed h, then eta must be reset and newh set to 1. +! if a change of order was dictated on the previous step, then +! it is done here and appropriate adjustments in the history are made. +! on an order decrease, the history array is adjusted by dvjust. +! on an order increase, the history array is augmented by a column. +! on a change of step size h, the history array yh is rescaled. +!----------------------------------------------------------------------- + 20 continue + if (kuth .eq. 1) then + eta = min(eta,h/hscal) + newh = 1 + endif + 50 if (newh .eq. 0) go to 200 + if (newq .eq. nq) go to 150 + if (newq .lt. nq) then + call dvjust (yh, ldyh, -1) + nq = newq + l = nq + 1 + nqwait = l + go to 150 + endif + if (newq .gt. nq) then + call dvjust (yh, ldyh, 1) + nq = newq + l = nq + 1 + nqwait = l + go to 150 + endif +!----------------------------------------------------------------------- +! the following block handles preliminaries needed when jstart = -1. +! if n was reduced, zero out part of yh to avoid undefined references. +! if maxord was reduced to a value less than the tentative order newq, +! then nq is set to maxord, and a new h ratio eta is chosen. +! otherwise, we take the same preliminary actions as for jstart .gt. 0. +! in any case, nqwait is reset to l = nq + 1 to prevent further +! changes in order for that many steps. +! the new h ratio eta is limited by the input h if kuth = 1, +! by hmin if kuth = 0, and by hmxi in any case. +! finally, the history array yh is rescaled. +!----------------------------------------------------------------------- + 100 continue + lmax = maxord + 1 + if (n .eq. ldyh) go to 120 + i1 = 1 + (newq + 1)*ldyh + i2 = (maxord + 1)*ldyh + if (i1 .gt. i2) go to 120 + do 110 i = i1, i2 + 110 yh1(i) = zero + 120 if (newq .le. maxord) go to 140 + flotl = real(lmax) + if (maxord .lt. nq-1) then + ddn = dvnorm (n, savf, ewt)/tq(1) + eta = one/((bias1*ddn)**(one/flotl) + addon) + endif + if (maxord .eq. nq .and. newq .eq. nq+1) eta = etaq + if (maxord .eq. nq-1 .and. newq .eq. nq+1) then + eta = etaqm1 + call dvjust (yh, ldyh, -1) + endif + if (maxord .eq. nq-1 .and. newq .eq. nq) then + ddn = dvnorm (n, savf, ewt)/tq(1) + eta = one/((bias1*ddn)**(one/flotl) + addon) + call dvjust (yh, ldyh, -1) + endif + eta = min(eta,one) + nq = maxord + l = lmax + 140 if (kuth .eq. 1) eta = min(eta,abs(h/hscal)) + if (kuth .eq. 0) eta = max(eta,hmin/abs(hscal)) + eta = eta/max(one,abs(hscal)*hmxi*eta) + newh = 1 + nqwait = l + if (newq .le. maxord) go to 50 +! rescale the history array for a change in h by a factor of eta. ------ + 150 r = one + do 180 j = 2, l + r = r*eta + call dscal (n, r, yh(1,j), 1 ) + 180 continue + h = hscal*eta + hscal = h + rc = rc*eta + nqnyh = nq*ldyh +!----------------------------------------------------------------------- +! this section computes the predicted values by effectively +! multiplying the yh array by the pascal triangle matrix. +! dvset is called to calculate all integration coefficients. +! rc is the ratio of new to old values of the coefficient h/el(2)=h/l1. +!----------------------------------------------------------------------- + 200 tn = tn + h + i1 = nqnyh + 1 + do 220 jb = 1, nq + i1 = i1 - ldyh + do 210 i = i1, nqnyh + 210 yh1(i) = yh1(i) + yh1(i+ldyh) + 220 continue + call dvset + rl1 = one/el(2) + rc = rc*(rl1/prl1) + prl1 = rl1 +! +! call the nonlinear system solver. ------------------------------------ +! + call vnls (y, yh, ldyh, vsav, savf, ewt, acor, iwm, wm, & + f, jac, psol, nflag, rpar, ipar) +! + if (nflag .eq. 0) go to 450 +!----------------------------------------------------------------------- +! the vnls routine failed to achieve convergence (nflag .ne. 0). +! the yh array is retracted to its values before prediction. +! the step size h is reduced and the step is retried, if possible. +! otherwise, an error exit is taken. +!----------------------------------------------------------------------- + ncf = ncf + 1 + ncfn = ncfn + 1 + etamax = one + tn = told + i1 = nqnyh + 1 + do 430 jb = 1, nq + i1 = i1 - ldyh + do 420 i = i1, nqnyh + 420 yh1(i) = yh1(i) - yh1(i+ldyh) + 430 continue + if (nflag .lt. -1) go to 680 + if (abs(h) .le. hmin*onepsm) go to 670 + if (ncf .eq. mxncf) go to 670 + eta = etacf + eta = max(eta,hmin/abs(h)) + nflag = -1 + go to 150 +!----------------------------------------------------------------------- +! the corrector has converged (nflag = 0). the local error test is +! made and control passes to statement 500 if it fails. +!----------------------------------------------------------------------- + 450 continue + dsm = acnrm/tq(2) + if (dsm .gt. one) go to 500 +!----------------------------------------------------------------------- +! after a successful step, update the yh and tau arrays and decrement +! nqwait. if nqwait is then 1 and nq .lt. maxord, then acor is saved +! for use in a possible order increase on the next step. +! if etamax = 1 (a failure occurred this step), keep nqwait .ge. 2. +!----------------------------------------------------------------------- + kflag = 0 + nst = nst + 1 + hu = h + nqu = nq + do 470 iback = 1, nq + i = l - iback + 470 tau(i+1) = tau(i) + tau(1) = h + do 480 j = 1, l + call daxpy (n, el(j), acor, 1, yh(1,j), 1 ) + 480 continue + nqwait = nqwait - 1 + if ((l .eq. lmax) .or. (nqwait .ne. 1)) go to 490 + call dcopy (n, acor, 1, yh(1,lmax), 1 ) + conp = tq(5) + 490 if (etamax .ne. one) go to 560 + if (nqwait .lt. 2) nqwait = 2 + newq = nq + newh = 0 + eta = one + hnew = h + go to 690 +!----------------------------------------------------------------------- +! the error test failed. kflag keeps track of multiple failures. +! restore tn and the yh array to their previous values, and prepare +! to try the step again. compute the optimum step size for the +! same order. after repeated failures, h is forced to decrease +! more rapidly. +!----------------------------------------------------------------------- + 500 kflag = kflag - 1 + netf = netf + 1 + nflag = -2 + tn = told + i1 = nqnyh + 1 + do 520 jb = 1, nq + i1 = i1 - ldyh + do 510 i = i1, nqnyh + 510 yh1(i) = yh1(i) - yh1(i+ldyh) + 520 continue + if (abs(h) .le. hmin*onepsm) go to 660 + etamax = one + if (kflag .le. kfc) go to 530 +! compute ratio of new h to current h at the current order. ------------ + flotl = real(l) + eta = one/((bias2*dsm)**(one/flotl) + addon) + eta = max(eta,hmin/abs(h),etamin) + if ((kflag .le. -2) .and. (eta .gt. etamxf)) eta = etamxf + go to 150 +!----------------------------------------------------------------------- +! control reaches this section if 3 or more consecutive failures +! have occurred. it is assumed that the elements of the yh array +! have accumulated errors of the wrong order. the order is reduced +! by one, if possible. then h is reduced by a factor of 0.1 and +! the step is retried. after a total of 7 consecutive failures, +! an exit is taken with kflag = -1. +!----------------------------------------------------------------------- + 530 if (kflag .eq. kfh) go to 660 + if (nq .eq. 1) go to 540 + eta = max(etamin,hmin/abs(h)) + call dvjust (yh, ldyh, -1) + l = nq + nq = nq - 1 + nqwait = l + go to 150 + 540 eta = max(etamin,hmin/abs(h)) + h = h*eta + hscal = h + tau(1) = h + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + do 550 i = 1, n + 550 yh(i,2) = h*savf(i) + nqwait = 10 + go to 200 +!----------------------------------------------------------------------- +! if nqwait = 0, an increase or decrease in order by one is considered. +! factors etaq, etaqm1, etaqp1 are computed by which h could +! be multiplied at order q, q-1, or q+1, respectively. +! the largest of these is determined, and the new order and +! step size set accordingly. +! a change of h or nq is made only if h increases by at least a +! factor of thresh. if an order change is considered and rejected, +! then nqwait is set to 2 (reconsider it after 2 steps). +!----------------------------------------------------------------------- +! compute ratio of new h to current h at the current order. ------------ + 560 flotl = real(l) + etaq = one/((bias2*dsm)**(one/flotl) + addon) + if (nqwait .ne. 0) go to 600 + nqwait = 2 + etaqm1 = zero + if (nq .eq. 1) go to 570 +! compute ratio of new h to current h at the current order less one. --- + ddn = dvnorm (n, yh(1,l), ewt)/tq(1) + etaqm1 = one/((bias1*ddn)**(one/(flotl - one)) + addon) + 570 etaqp1 = zero + if (l .eq. lmax) go to 580 +! compute ratio of new h to current h at current order plus one. ------- + cnquot = (tq(5)/conp)*(h/tau(2))**l + do 575 i = 1, n + 575 savf(i) = acor(i) - cnquot*yh(i,lmax) + dup = dvnorm (n, savf, ewt)/tq(3) + etaqp1 = one/((bias3*dup)**(one/(flotl + one)) + addon) + 580 if (etaq .ge. etaqp1) go to 590 + if (etaqp1 .gt. etaqm1) go to 620 + go to 610 + 590 if (etaq .lt. etaqm1) go to 610 + 600 eta = etaq + newq = nq + go to 630 + 610 eta = etaqm1 + newq = nq - 1 + go to 630 + 620 eta = etaqp1 + newq = nq + 1 + call dcopy (n, acor, 1, yh(1,lmax), 1) +! test tentative new h against thresh, etamax, and hmxi, then exit. ---- + 630 if (eta .lt. thresh .or. etamax .eq. one) go to 640 + eta = min(eta,etamax) + eta = eta/max(one,abs(h)*hmxi*eta) + newh = 1 + hnew = h*eta + go to 690 + 640 newq = nq + newh = 0 + eta = one + hnew = h + go to 690 +!----------------------------------------------------------------------- +! all returns are made through this section. +! on a successful return, etamax is reset and acor is scaled. +!----------------------------------------------------------------------- + 660 kflag = -1 + go to 720 + 670 kflag = -2 + go to 720 + 680 if (nflag .eq. -2) kflag = -3 + if (nflag .eq. -3) kflag = -4 + go to 720 + 690 etamax = etamx3 + if (nst .le. 10) etamax = etamx2 + 700 r = one/tq(2) + call dscal (n, r, acor, 1) + 720 jstart = 1 + return +!----------------------- end of subroutine dvstep ---------------------- + end subroutine dvstep +!deck dvset + subroutine dvset +!----------------------------------------------------------------------- +! call sequence communication: none +! common block variables accessed: +! /dvod_cmn01/ -- el(13), h, tau(13), tq(5), l(= nq + 1), +! meth, nq, nqwait +! +! subroutines called by dvset: none +! function routines called by dvset: none +!----------------------------------------------------------------------- +! dvset is called by dvstep and sets coefficients for use there. +! +! for each order nq, the coefficients in el are calculated by use of +! the generating polynomial lambda(x), with coefficients el(i). +! lambda(x) = el(1) + el(2)*x + ... + el(nq+1)*(x**nq). +! for the backward differentiation formulas, +! nq-1 +! lambda(x) = (1 + x/xi*(nq)) * product (1 + x/xi(i) ) . +! i = 1 +! for the adams formulas, +! nq-1 +! (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , +! i = 1 +! lambda(-1) = 0, lambda(0) = 1, +! where c is a normalization constant. +! in both cases, xi(i) is defined by +! h*xi(i) = t sub n - t sub (n-i) +! = h + tau(1) + tau(2) + ... tau(i-1). +! +! +! in addition to variables described previously, communication +! with dvset uses the following: +! tau = a vector of length 13 containing the past nq values +! of h. +! el = a vector of length 13 in which vset stores the +! coefficients for the corrector formula. +! tq = a vector of length 5 in which vset stores constants +! used for the convergence test, the error test, and the +! selection of h at a new order. +! meth = the basic method indicator. +! nq = the current order. +! l = nq + 1, the length of the vector stored in el, and +! the number of columns of the yh array being used. +! nqwait = a counter controlling the frequency of order changes. +! an order change is about to be considered if nqwait = 1. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + double precision ahatn0, alph0, cnqm1, cortes, csum, elp, em, & + em0, floti, flotl, flotnq, hsum, one, rxi, rxis, s, six, & + t1, t2, t3, t4, t5, t6, two, xi, zero + integer i, iback, j, jp1, nqm1, nqm2 +! + dimension em(13) +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save cortes, one, six, two, zero +! + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data cortes /0.1d0/ + data one /1.0d0/, six /6.0d0/, two /2.0d0/, zero /0.0d0/ +! + flotl = real(l) + nqm1 = nq - 1 + nqm2 = nq - 2 + go to (100, 200), meth +! +! set coefficients for adams methods. ---------------------------------- + 100 if (nq .ne. 1) go to 110 + el(1) = one + el(2) = one + tq(1) = one + tq(2) = two + tq(3) = six*tq(2) + tq(5) = one + go to 300 + 110 hsum = h + em(1) = one + flotnq = flotl - one + do 115 i = 2, l + 115 em(i) = zero + do 150 j = 1, nqm1 + if ((j .ne. nqm1) .or. (nqwait .ne. 1)) go to 130 + s = one + csum = zero + do 120 i = 1, nqm1 + csum = csum + s*em(i)/real(i+1) + 120 s = -s + tq(1) = em(nqm1)/(flotnq*csum) + 130 rxi = h/hsum + do 140 iback = 1, j + i = (j + 2) - iback + 140 em(i) = em(i) + em(i-1)*rxi + hsum = hsum + tau(j) + 150 continue +! compute integral from -1 to 0 of polynomial and of x times it. ------- + s = one + em0 = zero + csum = zero + do 160 i = 1, nq + floti = real(i) + em0 = em0 + s*em(i)/floti + csum = csum + s*em(i)/(floti+one) + 160 s = -s +! in el, form coefficients of normalized integrated polynomial. -------- + s = one/em0 + el(1) = one + do 170 i = 1, nq + 170 el(i+1) = s*em(i)/real(i) + xi = hsum/h + tq(2) = xi*em0/csum + tq(5) = xi/el(l) + if (nqwait .ne. 1) go to 300 +! for higher order control constant, multiply polynomial by 1+x/xi(q). - + rxi = one/xi + do 180 iback = 1, nq + i = (l + 1) - iback + 180 em(i) = em(i) + em(i-1)*rxi +! compute integral of polynomial. -------------------------------------- + s = one + csum = zero + do 190 i = 1, l + csum = csum + s*em(i)/real(i+1) + 190 s = -s + tq(3) = flotl*em0/csum + go to 300 +! +! set coefficients for bdf methods. ------------------------------------ + 200 do 210 i = 3, l + 210 el(i) = zero + el(1) = one + el(2) = one + alph0 = -one + ahatn0 = -one + hsum = h + rxi = one + rxis = one + if (nq .eq. 1) go to 240 + do 230 j = 1, nqm2 +! in el, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ + hsum = hsum + tau(j) + rxi = h/hsum + jp1 = j + 1 + alph0 = alph0 - one/real(jp1) + do 220 iback = 1, jp1 + i = (j + 3) - iback + 220 el(i) = el(i) + el(i-1)*rxi + 230 continue + alph0 = alph0 - one/real(nq) + rxis = -el(2) - alph0 + hsum = hsum + tau(nqm1) + rxi = h/hsum + ahatn0 = -el(2) - rxi + do 235 iback = 1, nq + i = (nq + 2) - iback + 235 el(i) = el(i) + el(i-1)*rxis + 240 t1 = one - ahatn0 + alph0 + t2 = one + real(nq)*t1 + tq(2) = abs(alph0*t2/t1) + tq(5) = abs(t2/(el(l)*rxi/rxis)) + if (nqwait .ne. 1) go to 300 + cnqm1 = rxis/el(l) + t3 = alph0 + one/real(nq) + t4 = ahatn0 + rxi + elp = t3/(one - t4 + t3) + tq(1) = abs(elp/cnqm1) + hsum = hsum + tau(nq) + rxi = h/hsum + t5 = alph0 - one/real(nq+1) + t6 = ahatn0 - rxi + elp = t2/(one - t6 + t5) + tq(3) = abs(elp*rxi*(flotl + one)*t5) + 300 tq(4) = cortes*tq(2) + return +!----------------------- end of subroutine dvset ----------------------- + end subroutine dvset +!deck dvjust + subroutine dvjust (yh, ldyh, iord) + double precision yh + integer ldyh, iord + dimension yh(ldyh,*) +!----------------------------------------------------------------------- +! call sequence input -- yh, ldyh, iord +! call sequence output -- yh +! common block input -- nq, meth, lmax, hscal, tau(13), n +! common block variables accessed: +! /dvod_cmn01/ -- hscal, tau(13), lmax, meth, n, nq, +! +! subroutines called by dvjust: daxpy +! function routines called by dvjust: none +!----------------------------------------------------------------------- +! this subroutine adjusts the yh array on reduction of order, +! and also when the order is increased for the stiff option (meth = 2). +! communication with dvjust uses the following: +! iord = an integer flag used when meth = 2 to indicate an order +! increase (iord = +1) or an order decrease (iord = -1). +! hscal = step size h used in scaling of nordsieck array yh. +! (if iord = +1, dvjust assumes that hscal = tau(1).) +! see references 1 and 2 for details. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + double precision alph0, alph1, hsum, one, prod, t1, xi,xiold, zero + integer i, iback, j, jp1, lp1, nqm1, nqm2, nqp1 +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save one, zero +! + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data one /1.0d0/, zero /0.0d0/ +! + if ((nq .eq. 2) .and. (iord .ne. 1)) return + nqm1 = nq - 1 + nqm2 = nq - 2 + go to (100, 200), meth +!----------------------------------------------------------------------- +! nonstiff option... +! check to see if the order is being increased or decreased. +!----------------------------------------------------------------------- + 100 continue + if (iord .eq. 1) go to 180 +! order decrease. ------------------------------------------------------ + do 110 j = 1, lmax + 110 el(j) = zero + el(2) = one + hsum = zero + do 130 j = 1, nqm2 +! construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- + hsum = hsum + tau(j) + xi = hsum/hscal + jp1 = j + 1 + do 120 iback = 1, jp1 + i = (j + 3) - iback + 120 el(i) = el(i)*xi + el(i-1) + 130 continue +! construct coefficients of integrated polynomial. --------------------- + do 140 j = 2, nqm1 + 140 el(j+1) = real(nq)*el(j)/real(j) +! subtract correction terms from yh array. ----------------------------- + do 170 j = 3, nq + do 160 i = 1, n + 160 yh(i,j) = yh(i,j) - yh(i,l)*el(j) + 170 continue + return +! order increase. ------------------------------------------------------ +! zero out next column in yh array. ------------------------------------ + 180 continue + lp1 = l + 1 + do 190 i = 1, n + 190 yh(i,lp1) = zero + return +!----------------------------------------------------------------------- +! stiff option... +! check to see if the order is being increased or decreased. +!----------------------------------------------------------------------- + 200 continue + if (iord .eq. 1) go to 300 +! order decrease. ------------------------------------------------------ + do 210 j = 1, lmax + 210 el(j) = zero + el(3) = one + hsum = zero + do 230 j = 1,nqm2 +! construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + hsum = hsum + tau(j) + xi = hsum/hscal + jp1 = j + 1 + do 220 iback = 1, jp1 + i = (j + 4) - iback + 220 el(i) = el(i)*xi + el(i-1) + 230 continue +! subtract correction terms from yh array. ----------------------------- + do 250 j = 3,nq + do 240 i = 1, n + 240 yh(i,j) = yh(i,j) - yh(i,l)*el(j) + 250 continue + return +! order increase. ------------------------------------------------------ + 300 do 310 j = 1, lmax + 310 el(j) = zero + el(3) = one + alph0 = -one + alph1 = one + prod = one + xiold = one + hsum = hscal + if (nq .eq. 1) go to 340 + do 330 j = 1, nqm1 +! construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + jp1 = j + 1 + hsum = hsum + tau(jp1) + xi = hsum/hscal + prod = prod*xi + alph0 = alph0 - one/real(jp1) + alph1 = alph1 + one/xi + do 320 iback = 1, jp1 + i = (j + 4) - iback + 320 el(i) = el(i)*xiold + el(i-1) + xiold = xi + 330 continue + 340 continue + t1 = (-alph0 - alph1)/prod +! load column l + 1 in yh array. --------------------------------------- + lp1 = l + 1 + do 350 i = 1, n + 350 yh(i,lp1) = t1*yh(i,lmax) +! add correction terms to yh array. ------------------------------------ + nqp1 = nq + 1 + do 370 j = 3, nqp1 + call daxpy (n, el(j), yh(1,lp1), 1, yh(1,j), 1 ) + 370 continue + return +!----------------------- end of subroutine dvjust ---------------------- + end subroutine dvjust +!deck dvnlsd + subroutine dvnlsd (y, yh, ldyh, vsav, savf, ewt, acor, iwm, wm, & + f, jac, pdum, nflag, rpar, ipar) + external f, jac, pdum + double precision y, yh, vsav, savf, ewt, acor, wm, rpar + integer ldyh, iwm, nflag, ipar + dimension y(*), yh(ldyh,*), vsav(*), savf(*), ewt(*), acor(*), & + iwm(*), wm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, savf, ewt, acor, iwm, wm, +! f, jac, nflag, rpar, ipar +! call sequence output -- yh, acor, wm, iwm, nflag +! common block variables accessed: +! /dvod_cmn01/ acnrm, crate, drc, h, rc, rl1, tq(5), tn, icf, +! jcur, meth, miter, n, nslp +! /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! subroutines called by dvnlsd: f, daxpy, dcopy, dscal, dvjac, dvsol +! function routines called by dvnlsd: dvnorm +!----------------------------------------------------------------------- +! subroutine dvnlsd is a nonlinear system solver, which uses functional +! iteration or a chord (modified newton) method. for the chord method +! direct linear algebraic system solvers are used. subroutine dvnlsd +! then handles the corrector phase of this integration package. +! +! communication with dvnlsd is done with the following variables. (for +! more details, please see the comments in the driver subroutine.) +! +! y = the dependent variable, a vector of length n, input. +! yh = the nordsieck (taylor) array, ldyh by lmax, input +! and output. on input, it contains predicted values. +! ldyh = a constant .ge. n, the first dimension of yh, input. +! vsav = unused work array. +! savf = a work array of length n. +! ewt = an error weight vector of length n, input. +! acor = a work array of length n, used for the accumulated +! corrections to the predicted y vector. +! wm,iwm = real and integer work arrays associated with matrix +! operations in chord iteration (miter .ne. 0). +! f = dummy name for user supplied routine for f. +! jac = dummy name for user supplied jacobian routine. +! pdum = unused dummy subroutine name. included for uniformity +! over collection of integrators. +! nflag = input/output flag, with values and meanings as follows: +! input +! 0 first call for this time step. +! -1 convergence failure in previous call to dvnlsd. +! -2 error test failure in dvstep. +! output +! 0 successful completion of nonlinear solver. +! -1 convergence failure or singular matrix. +! -2 unrecoverable error in matrix preprocessing +! (cannot occur here). +! -3 unrecoverable error in solution (cannot occur +! here). +! rpar, ipar = dummy names for user's real and integer work arrays. +! +! ipup = own variable flag with values and meanings as follows: +! 0, do not update the newton matrix. +! miter .ne. 0, update newton matrix, because it is the +! initial step, order was changed, the error +! test failed, or an update is indicated by +! the scalar rc or step counter nst. +! +! for more details, see comments in driver subroutine. +!----------------------------------------------------------------------- +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block dvod_cmn02 -------------------- +! + double precision hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + double precision ccmax, crdown, cscale, dcon, del, delp, one, & + rdiv, two, zero + integer i, ierpj, iersl, m, maxcor, msbp +! +! type declaration for function subroutines called --------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision dvnorm +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save ccmax, crdown, maxcor, msbp, rdiv, one, two, zero +! + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data ccmax /0.3d0/, crdown /0.3d0/, maxcor /3/, msbp /20/, & + rdiv /2.0d0/ + data one /1.0d0/, two /2.0d0/, zero /0.0d0/ +!----------------------------------------------------------------------- +! on the first step, on a change of method order, or after a +! nonlinear convergence failure with nflag = -2, set ipup = miter +! to force a jacobian update when miter .ne. 0. +!----------------------------------------------------------------------- + if (jstart .eq. 0) nslp = 0 + if (nflag .eq. 0) icf = 0 + if (nflag .eq. -2) ipup = miter + if ( (jstart .eq. 0) .or. (jstart .eq. -1) ) ipup = miter +! if this is functional iteration, set crate .eq. 1 and drop to 220 + if (miter .eq. 0) then + crate = one + go to 220 + endif +!----------------------------------------------------------------------- +! rc is the ratio of new to old values of the coefficient h/el(2)=h/l1. +! when rc differs from 1 by more than ccmax, ipup is set to miter +! to force dvjac to be called, if a jacobian is involved. +! in any case, dvjac is called at least every msbp steps. +!----------------------------------------------------------------------- + drc = abs(rc-one) + if (drc .gt. ccmax .or. nst .ge. nslp+msbp) ipup = miter +!----------------------------------------------------------------------- +! up to maxcor corrector iterations are taken. a convergence test is +! made on the r.m.s. norm of each correction, weighted by the error +! weight vector ewt. the sum of the corrections is accumulated in the +! vector acor(i). the yh array is not altered in the corrector loop. +!----------------------------------------------------------------------- + 220 m = 0 + delp = zero + call dcopy (n, yh(1,1), 1, y, 1 ) + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + if (ipup .le. 0) go to 250 +!----------------------------------------------------------------------- +! if indicated, the matrix p = i - h*rl1*j is reevaluated and +! preprocessed before starting the corrector iteration. ipup is set +! to 0 as an indicator that this has been done. +!----------------------------------------------------------------------- + call dvjac (y, yh, ldyh, ewt, acor, savf, wm, iwm, f, jac, ierpj, & + rpar, ipar) + ipup = 0 + rc = one + drc = zero + crate = one + nslp = nst +! if matrix is singular, take error return to force cut in step size. -- + if (ierpj .ne. 0) go to 430 + 250 do 260 i = 1,n + 260 acor(i) = zero +! this is a looping point for the corrector iteration. ----------------- + 270 if (miter .ne. 0) go to 350 +!----------------------------------------------------------------------- +! in the case of functional iteration, update y directly from +! the result of the last function evaluation. +!----------------------------------------------------------------------- + do 280 i = 1,n + 280 savf(i) = rl1*(h*savf(i) - yh(i,2)) + do 290 i = 1,n + 290 y(i) = savf(i) - acor(i) + del = dvnorm (n, y, ewt) + do 300 i = 1,n + 300 y(i) = yh(i,1) + savf(i) + call dcopy (n, savf, 1, acor, 1) + go to 400 +!----------------------------------------------------------------------- +! in the case of the chord method, compute the corrector error, +! and solve the linear system with that as right-hand side and +! p as coefficient matrix. the correction is scaled by the factor +! 2/(1+rc) to account for changes in h*rl1 since the last dvjac call. +!----------------------------------------------------------------------- + 350 do 360 i = 1,n + 360 y(i) = (rl1*h)*savf(i) - (rl1*yh(i,2) + acor(i)) + call dvsol (wm, iwm, y, iersl) + nni = nni + 1 + if (iersl .gt. 0) go to 410 + if (meth .eq. 2 .and. rc .ne. one) then + cscale = two/(one + rc) + call dscal (n, cscale, y, 1) + endif + del = dvnorm (n, y, ewt) + call daxpy (n, one, y, 1, acor, 1) + do 380 i = 1,n + 380 y(i) = yh(i,1) + acor(i) +!----------------------------------------------------------------------- +! test for convergence. if m .gt. 0, an estimate of the convergence +! rate constant is stored in crate, and this is used in the test. +!----------------------------------------------------------------------- + 400 if (m .ne. 0) crate = max(crdown*crate,del/delp) + dcon = del*min(one,crate)/tq(4) + if (dcon .le. one) go to 450 + m = m + 1 + if (m .eq. maxcor) go to 410 + if (m .ge. 2 .and. del .gt. rdiv*delp) go to 410 + delp = del + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + go to 270 +! + 410 if (miter .eq. 0 .or. jcur .eq. 1) go to 430 + icf = 1 + ipup = miter + go to 220 +! + 430 continue + nflag = -1 + icf = 2 + ipup = miter + return +! +! return for successful step. ------------------------------------------ + 450 nflag = 0 + jcur = 0 + icf = 0 + if (m .eq. 0) acnrm = del + if (m .gt. 0) acnrm = dvnorm (n, acor, ewt) + return +!----------------------- end of subroutine dvnlsd ---------------------- + end subroutine dvnlsd +!deck dvjac + subroutine dvjac (y, yh, ldyh, ewt, ftem, savf, wm, iwm, f, jac, & + ierpj, rpar, ipar) + external f, jac + double precision y, yh, ewt, ftem, savf, wm, rpar + integer ldyh, iwm, ierpj, ipar + dimension y(*), yh(ldyh,*), ewt(*), ftem(*), savf(*), & + wm(*), iwm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, ewt, ftem, savf, wm, iwm, +! f, jac, rpar, ipar +! call sequence output -- wm, iwm, ierpj +! common block variables accessed: +! /dvod_cmn01/ ccmxj, drc, h, rl1, tn, uround, icf, jcur, locjs, +! miter, msbj, n, nslj +! /dvod_cmn02/ nfe, nst, nje, nlu +! +! subroutines called by dvjac: f, jac, dacopy, dcopy, dgbfa, dgefa, +! dscal +! function routines called by dvjac: dvnorm +!----------------------------------------------------------------------- +! dvjac is called by dvnlsd to compute and process the matrix +! p = i - h*rl1*j , where j is an approximation to the jacobian. +! here j is computed by the user-supplied routine jac if +! miter = 1 or 4, or by finite differencing if miter = 2, 3, or 5. +! if miter = 3, a diagonal approximation to j is used. +! if jsv = -1, j is computed from scratch in all cases. +! if jsv = 1 and miter = 1, 2, 4, or 5, and if the saved value of j is +! considered acceptable, then p is constructed from the saved j. +! j is stored in wm and replaced by p. if miter .ne. 3, p is then +! subjected to lu decomposition in preparation for later solution +! of linear systems with p as coefficient matrix. this is done +! by dgefa if miter = 1 or 2, and by dgbfa if miter = 4 or 5. +! +! communication with dvjac is done with the following variables. (for +! more details, please see the comments in the driver subroutine.) +! y = vector containing predicted values on entry. +! yh = the nordsieck array, an ldyh by lmax array, input. +! ldyh = a constant .ge. n, the first dimension of yh, input. +! ewt = an error weight vector of length n. +! savf = array containing f evaluated at predicted y, input. +! wm = real work space for matrices. in the output, it contains +! the inverse diagonal matrix if miter = 3 and the lu +! decomposition of p if miter is 1, 2 , 4, or 5. +! storage of matrix elements starts at wm(3). +! storage of the saved jacobian starts at wm(locjs). +! wm also contains the following matrix-related data: +! wm(1) = sqrt(uround), used in numerical jacobian step. +! wm(2) = h*rl1, saved for later use if miter = 3. +! iwm = integer work space containing pivot information, +! starting at iwm(31), if miter is 1, 2, 4, or 5. +! iwm also contains band parameters ml = iwm(1) and +! mu = iwm(2) if miter is 4 or 5. +! f = dummy name for the user supplied subroutine for f. +! jac = dummy name for the user supplied jacobian subroutine. +! rpar, ipar = dummy names for user's real and integer work arrays. +! rl1 = 1/el(2) (input). +! ierpj = output error flag, = 0 if no trouble, 1 if the p +! matrix is found to be singular. +! jcur = output flag to indicate whether the jacobian matrix +! (or approximation) is now current. +! jcur = 0 means j is not current. +! jcur = 1 means j is current. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block dvod_cmn02 -------------------- +! + double precision hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + double precision con, di, fac, hrl1, one, pt1, r, r0, srur, thou, & + yi, yj, yjj, zero + integer i, i1, i2, ier, ii, j, j1, jj, jok, lenp, mba, mband, & + meb1, meband, ml, ml3, mu, np1 +! +! type declaration for function subroutines called --------------------- +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision dvnorm +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this subroutine. +!----------------------------------------------------------------------- + save one, pt1, thou, zero +!----------------------------------------------------------------------- + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /dvod_cmn02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data one /1.0d0/, thou /1000.0d0/, zero /0.0d0/, pt1 /0.1d0/ +! + ierpj = 0 + hrl1 = h*rl1 +! see whether j should be evaluated (jok = -1) or not (jok = 1). ------- + jok = jsv + if (jsv .eq. 1) then + if (nst .eq. 0 .or. nst .gt. nslj+msbj) jok = -1 + if (icf .eq. 1 .and. drc .lt. ccmxj) jok = -1 + if (icf .eq. 2) jok = -1 + endif +! end of setting jok. -------------------------------------------------- +! + if (jok .eq. -1 .and. miter .eq. 1) then +! if jok = -1 and miter = 1, call jac to evaluate jacobian. ------------ + nje = nje + 1 + nslj = nst + jcur = 1 + lenp = n*n + do 110 i = 1,lenp + 110 wm(i+2) = zero + call jac (n, tn, y, 0, 0, wm(3), n, rpar, ipar) + if (jsv .eq. 1) call dcopy (lenp, wm(3), 1, wm(locjs), 1) + endif +! + if (jok .eq. -1 .and. miter .eq. 2) then +! if miter = 2, make n calls to f to approximate the jacobian. --------- + nje = nje + 1 + nslj = nst + jcur = 1 + fac = dvnorm (n, savf, ewt) + r0 = thou*abs(h)*uround*real(n)*fac + if (r0 .eq. zero) r0 = one + srur = wm(1) + j1 = 2 + do 230 j = 1,n + yj = y(j) + r = max(srur*abs(yj),r0/ewt(j)) + y(j) = y(j) + r + fac = one/r + call f (n, tn, y, ftem, rpar, ipar) + do 220 i = 1,n + 220 wm(i+j1) = (ftem(i) - savf(i))*fac + y(j) = yj + j1 = j1 + n + 230 continue + nfe = nfe + n + lenp = n*n + if (jsv .eq. 1) call dcopy (lenp, wm(3), 1, wm(locjs), 1) + endif +! + if (jok .eq. 1 .and. (miter .eq. 1 .or. miter .eq. 2)) then + jcur = 0 + lenp = n*n + call dcopy (lenp, wm(locjs), 1, wm(3), 1) + endif +! + if (miter .eq. 1 .or. miter .eq. 2) then +! multiply jacobian by scalar, add identity, and do lu decomposition. -- + con = -hrl1 + call dscal (lenp, con, wm(3), 1) + j = 3 + np1 = n + 1 + do 250 i = 1,n + wm(j) = wm(j) + one + 250 j = j + np1 + nlu = nlu + 1 + call dgefa (wm(3), n, n, iwm(31), ier) + if (ier .ne. 0) ierpj = 1 + return + endif +! end of code block for miter = 1 or 2. -------------------------------- +! + if (miter .eq. 3) then +! if miter = 3, construct a diagonal approximation to j and p. --------- + nje = nje + 1 + jcur = 1 + wm(2) = hrl1 + r = rl1*pt1 + do 310 i = 1,n + 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) + call f (n, tn, y, wm(3), rpar, ipar) + nfe = nfe + 1 + do 320 i = 1,n + r0 = h*savf(i) - yh(i,2) + di = pt1*r0 - h*(wm(i+2) - savf(i)) + wm(i+2) = one + if (abs(r0) .lt. uround/ewt(i)) go to 320 + if (abs(di) .eq. zero) go to 330 + wm(i+2) = pt1*r0/di + 320 continue + return + 330 ierpj = 1 + return + endif +! end of code block for miter = 3. ------------------------------------- +! +! set constants for miter = 4 or 5. ------------------------------------ + ml = iwm(1) + mu = iwm(2) + ml3 = ml + 3 + mband = ml + mu + 1 + meband = mband + ml + lenp = meband*n +! + if (jok .eq. -1 .and. miter .eq. 4) then +! if jok = -1 and miter = 4, call jac to evaluate jacobian. ------------ + nje = nje + 1 + nslj = nst + jcur = 1 + do 410 i = 1,lenp + 410 wm(i+2) = zero + call jac (n, tn, y, ml, mu, wm(ml3), meband, rpar, ipar) + if (jsv .eq. 1) & + call dacopy (mband, n, wm(ml3), meband, wm(locjs), mband) + endif +! + if (jok .eq. -1 .and. miter .eq. 5) then +! if miter = 5, make ml+mu+1 calls to f to approximate the jacobian. --- + nje = nje + 1 + nslj = nst + jcur = 1 + mba = min(mband,n) + meb1 = meband - 1 + srur = wm(1) + fac = dvnorm (n, savf, ewt) + r0 = thou*abs(h)*uround*real(n)*fac + if (r0 .eq. zero) r0 = one + do 560 j = 1,mba + do 530 i = j,n,mband + yi = y(i) + r = max(srur*abs(yi),r0/ewt(i)) + 530 y(i) = y(i) + r + call f (n, tn, y, ftem, rpar, ipar) + do 550 jj = j,n,mband + y(jj) = yh(jj,1) + yjj = y(jj) + r = max(srur*abs(yjj),r0/ewt(jj)) + fac = one/r + i1 = max(jj-mu,1) + i2 = min(jj+ml,n) + ii = jj*meb1 - ml + 2 + do 540 i = i1,i2 + 540 wm(ii+i) = (ftem(i) - savf(i))*fac + 550 continue + 560 continue + nfe = nfe + mba + if (jsv .eq. 1) & + call dacopy (mband, n, wm(ml3), meband, wm(locjs), mband) + endif +! + if (jok .eq. 1) then + jcur = 0 + call dacopy (mband, n, wm(locjs), mband, wm(ml3), meband) + endif +! +! multiply jacobian by scalar, add identity, and do lu decomposition. + con = -hrl1 + call dscal (lenp, con, wm(3), 1 ) + ii = mband + 2 + do 580 i = 1,n + wm(ii) = wm(ii) + one + 580 ii = ii + meband + nlu = nlu + 1 + call dgbfa (wm(3), meband, n, ml, mu, iwm(31), ier) + if (ier .ne. 0) ierpj = 1 + return +! end of code block for miter = 4 or 5. -------------------------------- +! +!----------------------- end of subroutine dvjac ----------------------- + end subroutine dvjac +!deck dacopy + subroutine dacopy (nrow, ncol, a, nrowa, b, nrowb) + double precision a, b + integer nrow, ncol, nrowa, nrowb + dimension a(nrowa,ncol), b(nrowb,ncol) +!----------------------------------------------------------------------- +! call sequence input -- nrow, ncol, a, nrowa, nrowb +! call sequence output -- b +! common block variables accessed -- none +! +! subroutines called by dacopy: dcopy +! function routines called by dacopy: none +!----------------------------------------------------------------------- +! this routine copies one rectangular array, a, to another, b, +! where a and b may have different row dimensions, nrowa and nrowb. +! the data copied consists of nrow rows and ncol columns. +!----------------------------------------------------------------------- + integer ic +! + do 20 ic = 1,ncol + call dcopy (nrow, a(1,ic), 1, b(1,ic), 1) + 20 continue +! + return +!----------------------- end of subroutine dacopy ---------------------- + end subroutine dacopy +!deck dvsol + subroutine dvsol (wm, iwm, x, iersl) + double precision wm, x + integer iwm, iersl + dimension wm(*), iwm(*), x(*) +!----------------------------------------------------------------------- +! call sequence input -- wm, iwm, x +! call sequence output -- x, iersl +! common block variables accessed: +! /dvod_cmn01/ -- h, rl1, miter, n +! +! subroutines called by dvsol: dgesl, dgbsl +! function routines called by dvsol: none +!----------------------------------------------------------------------- +! this routine manages the solution of the linear system arising from +! a chord iteration. it is called if miter .ne. 0. +! if miter is 1 or 2, it calls dgesl to accomplish this. +! if miter = 3 it updates the coefficient h*rl1 in the diagonal +! matrix, and then computes the solution. +! if miter is 4 or 5, it calls dgbsl. +! communication with dvsol uses the following variables: +! wm = real work space containing the inverse diagonal matrix if +! miter = 3 and the lu decomposition of the matrix otherwise. +! storage of matrix elements starts at wm(3). +! wm also contains the following matrix-related data: +! wm(1) = sqrt(uround) (not used here), +! wm(2) = hrl1, the previous value of h*rl1, used if miter = 3. +! iwm = integer work space containing pivot information, starting at +! iwm(31), if miter is 1, 2, 4, or 5. iwm also contains band +! parameters ml = iwm(1) and mu = iwm(2) if miter is 4 or 5. +! x = the right-hand side vector on input, and the solution vector +! on output, of length n. +! iersl = output flag. iersl = 0 if no trouble occurred. +! iersl = 1 if a singular matrix arose with miter = 3. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block dvod_cmn01 -------------------- +! + double precision acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + integer i, meband, ml, mu + double precision di, hrl1, one, phrl1, r, zero +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save one, zero +! + common /dvod_cmn01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data one /1.0d0/, zero /0.0d0/ +! + iersl = 0 + go to (100, 100, 300, 400, 400), miter + 100 call dgesl (wm(3), n, n, iwm(31), x, 0) + return +! + 300 phrl1 = wm(2) + hrl1 = h*rl1 + wm(2) = hrl1 + if (hrl1 .eq. phrl1) go to 330 + r = hrl1/phrl1 + do 320 i = 1,n + di = one - r*(one - one/wm(i+2)) + if (abs(di) .eq. zero) go to 390 + 320 wm(i+2) = one/di +! + 330 do 340 i = 1,n + 340 x(i) = wm(i+2)*x(i) + return + 390 iersl = 1 + return +! + 400 ml = iwm(1) + mu = iwm(2) + meband = 2*ml + mu + 1 + call dgbsl (wm(3), meband, n, ml, mu, iwm(31), x, 0) + return +!----------------------- end of subroutine dvsol ----------------------- + end subroutine dvsol +!deck dvsrco + subroutine dvsrco (rsav, isav, job) + double precision rsav + integer isav, job + dimension rsav(*), isav(*) +!----------------------------------------------------------------------- +! call sequence input -- rsav, isav, job +! call sequence output -- rsav, isav +! common block variables accessed -- all of /dvod_cmn01/ and /dvod_cmn02/ +! +! subroutines/functions called by dvsrco: none +!----------------------------------------------------------------------- +! this routine saves or restores (depending on job) the contents of the +! common blocks dvod_cmn01 and dvod_cmn02, which are used internally by dvode. +! +! rsav = real array of length 49 or more. +! isav = integer array of length 41 or more. +! job = flag indicating to save or restore the common blocks: +! job = 1 if common is to be saved (written to rsav/isav). +! job = 2 if common is to be restored (read from rsav/isav). +! a call with job = 2 presumes a prior call with job = 1. +!----------------------------------------------------------------------- + double precision rvod1, rvod2 + integer ivod1, ivod2 + integer i, leniv1, leniv2, lenrv1, lenrv2 +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save lenrv1, leniv1, lenrv2, leniv2 +! + common /dvod_cmn01/ rvod1(48), ivod1(33) + common /dvod_cmn02/ rvod2(1), ivod2(8) + data lenrv1/48/, leniv1/33/, lenrv2/1/, leniv2/8/ +! + if (job .eq. 2) go to 100 + do 10 i = 1,lenrv1 + 10 rsav(i) = rvod1(i) + do 15 i = 1,lenrv2 + 15 rsav(lenrv1+i) = rvod2(i) +! + do 20 i = 1,leniv1 + 20 isav(i) = ivod1(i) + do 25 i = 1,leniv2 + 25 isav(leniv1+i) = ivod2(i) +! + return +! + 100 continue + do 110 i = 1,lenrv1 + 110 rvod1(i) = rsav(i) + do 115 i = 1,lenrv2 + 115 rvod2(i) = rsav(lenrv1+i) +! + do 120 i = 1,leniv1 + 120 ivod1(i) = isav(i) + do 125 i = 1,leniv2 + 125 ivod2(i) = isav(leniv1+i) +! + return +!----------------------- end of subroutine dvsrco ---------------------- + end subroutine dvsrco +!deck dewset + subroutine dewset (n, itol, rtol, atol, ycur, ewt) +!***begin prologue dewset +!***subsidiary +!***purpose set error weight vector. +!***type double precision (sewset-s, dewset-d) +!***author hindmarsh, alan c., (llnl) +!***description +! +! this subroutine sets the error weight vector ewt according to +! ewt(i) = rtol(i)*abs(ycur(i)) + atol(i), i = 1,...,n, +! with the subscript on rtol and/or atol possibly replaced by 1 above, +! depending on the value of itol. +! +!***see also dlsode +!***routines called (none) +!***revision history (yymmdd) +! 791129 date written +! 890501 modified prologue to slatec/ldoc format. (fnf) +! 890503 minor cosmetic changes. (fnf) +! 930809 renamed to allow single/double precision versions. (ach) +!***end prologue dewset +!**end + integer n, itol + integer i + double precision rtol, atol, ycur, ewt + dimension rtol(*), atol(*), ycur(n), ewt(n) +! +!***first executable statement dewset + go to (10, 20, 30, 40), itol + 10 continue + do 15 i = 1,n + 15 ewt(i) = rtol(1)*abs(ycur(i)) + atol(1) + return + 20 continue + do 25 i = 1,n + 25 ewt(i) = rtol(1)*abs(ycur(i)) + atol(i) + return + 30 continue + do 35 i = 1,n + 35 ewt(i) = rtol(i)*abs(ycur(i)) + atol(1) + return + 40 continue + do 45 i = 1,n + 45 ewt(i) = rtol(i)*abs(ycur(i)) + atol(i) + return +!----------------------- end of subroutine dewset ---------------------- + end subroutine dewset +!deck dvnorm + double precision function dvnorm (n, v, w) +!***begin prologue dvnorm +!***subsidiary +!***purpose weighted root-mean-square vector norm. +!***type double precision (svnorm-s, dvnorm-d) +!***author hindmarsh, alan c., (llnl) +!***description +! +! this function routine computes the weighted root-mean-square norm +! of the vector of length n contained in the array v, with weights +! contained in the array w of length n: +! dvnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 ) +! +!***see also dlsode +!***routines called (none) +!***revision history (yymmdd) +! 791129 date written +! 890501 modified prologue to slatec/ldoc format. (fnf) +! 890503 minor cosmetic changes. (fnf) +! 930809 renamed to allow single/double precision versions. (ach) +!***end prologue dvnorm +!**end + integer n, i + double precision v, w, sum + dimension v(n), w(n) +! +!***first executable statement dvnorm + sum = 0.0d0 + do 10 i = 1,n + 10 sum = sum + (v(i)*w(i))**2 + dvnorm = sqrt(sum/n) + return +!----------------------- end of function dvnorm ------------------------ + end function dvnorm +!deck xerrwd + subroutine xerrwd (msg, nmes, nerr, level, ni, i1, i2, nr, r1, r2) +!***begin prologue xerrwd +!***subsidiary +!***purpose write error message with values. +!***category r3c +!***type double precision (xerrwv-s, xerrwd-d) +!***author hindmarsh, alan c., (llnl) +!***description +! +! subroutines xerrwd, xsetf, xsetun, and the function routine ixsav, +! as given here, constitute a simplified version of the slatec error +! handling package. +! +! all arguments are input arguments. +! +! msg = the message (character array). +! nmes = the length of msg (number of characters). +! nerr = the error number (not used). +! level = the error level.. +! 0 or 1 means recoverable (control returns to caller). +! 2 means fatal (run is aborted--see note below). +! ni = number of integers (0, 1, or 2) to be printed with message. +! i1,i2 = integers to be printed, depending on ni. +! nr = number of reals (0, 1, or 2) to be printed with message. +! r1,r2 = reals to be printed, depending on nr. +! +! note.. this routine is machine-dependent and specialized for use +! in limited context, in the following ways.. +! 1. the argument msg is assumed to be of type character, and +! the message is printed with a format of (1x,a). +! 2. the message is assumed to take only one line. +! multi-line messages are generated by repeated calls. +! 3. if level = 2, control passes to the statement stop +! to abort the run. this statement may be machine-dependent. +! 4. r1 and r2 are assumed to be in double precision and are printed +! in d21.13 format. +! +!***routines called ixsav +!***revision history (yymmdd) +! 920831 date written +! 921118 replaced mflgsv/lunsav by ixsav. (ach) +! 930329 modified prologue to slatec format. (fnf) +! 930407 changed msg from character*1 array to variable. (fnf) +! 930922 minor cosmetic change. (fnf) +!***end prologue xerrwd +! +!*internal notes: +! +! for a different default logical unit number, ixsav (or a subsidiary +! routine that it calls) will need to be modified. +! for a different run-abort command, change the statement following +! statement 100 at the end. +!----------------------------------------------------------------------- +! subroutines called by xerrwd.. none +! function routine called by xerrwd.. ixsav +!----------------------------------------------------------------------- +!**end +! +! declare arguments. +! + double precision r1, r2 + integer nmes, nerr, level, ni, i1, i2, nr + character*(*) msg +! +! declare local variables. +! +! 27-oct-2005 rce - do not declare functions that are in the module +! integer lunit, ixsav, mesflg + integer lunit, mesflg +! +! get logical unit number and message print flag. +! +!***first executable statement xerrwd + lunit = ixsav (1, 0, .false.) + mesflg = ixsav (2, 0, .false.) + if (mesflg .eq. 0) go to 100 +! +! write the message. +! + write (lunit,10) msg + 10 format(1x,a) + if (ni .eq. 1) write (lunit, 20) i1 + 20 format(6x,'in above message, i1 =',i10) + if (ni .eq. 2) write (lunit, 30) i1,i2 + 30 format(6x,'in above message, i1 =',i10,3x,'i2 =',i10) + if (nr .eq. 1) write (lunit, 40) r1 + 40 format(6x,'in above message, r1 =',d21.13) + if (nr .eq. 2) write (lunit, 50) r1,r2 + 50 format(6x,'in above, r1 =',d21.13,3x,'r2 =',d21.13) +! +! abort the run if level = 2. +! + 100 if (level .ne. 2) return + stop +!----------------------- end of subroutine xerrwd ---------------------- + end subroutine xerrwd +!deck xsetf + subroutine xsetf (mflag) +!***begin prologue xsetf +!***purpose reset the error print control flag. +!***category r3a +!***type all (xsetf-a) +!***keywords error control +!***author hindmarsh, alan c., (llnl) +!***description +! +! xsetf sets the error print control flag to mflag: +! mflag=1 means print all messages (the default). +! mflag=0 means no printing. +! +!***see also xerrwd, xerrwv +!***references (none) +!***routines called ixsav +!***revision history (yymmdd) +! 921118 date written +! 930329 added slatec format prologue. (fnf) +! 930407 corrected see also section. (fnf) +! 930922 made user-callable, and other cosmetic changes. (fnf) +!***end prologue xsetf +! +! subroutines called by xsetf.. none +! function routine called by xsetf.. ixsav +!----------------------------------------------------------------------- +!**end +! 27-oct-2005 rce - do not declare functions that are in the module +! integer mflag, junk, ixsav + integer mflag, junk +! +!***first executable statement xsetf + if (mflag .eq. 0 .or. mflag .eq. 1) junk = ixsav (2,mflag,.true.) + return +!----------------------- end of subroutine xsetf ----------------------- + end subroutine xsetf +!deck xsetun + subroutine xsetun (lun) +!***begin prologue xsetun +!***purpose reset the logical unit number for error messages. +!***category r3b +!***type all (xsetun-a) +!***keywords error control +!***description +! +! xsetun sets the logical unit number for error messages to lun. +! +!***author hindmarsh, alan c., (llnl) +!***see also xerrwd, xerrwv +!***references (none) +!***routines called ixsav +!***revision history (yymmdd) +! 921118 date written +! 930329 added slatec format prologue. (fnf) +! 930407 corrected see also section. (fnf) +! 930922 made user-callable, and other cosmetic changes. (fnf) +!***end prologue xsetun +! +! subroutines called by xsetun.. none +! function routine called by xsetun.. ixsav +!----------------------------------------------------------------------- +!**end +! 27-oct-2005 rce - do not declare functions that are in the module +! integer lun, junk, ixsav + integer lun, junk +! +!***first executable statement xsetun + if (lun .gt. 0) junk = ixsav (1,lun,.true.) + return +!----------------------- end of subroutine xsetun ---------------------- + end subroutine xsetun +!deck ixsav + integer function ixsav (ipar, ivalue, iset) +!***begin prologue ixsav +!***subsidiary +!***purpose save and recall error message control parameters. +!***category r3c +!***type all (ixsav-a) +!***author hindmarsh, alan c., (llnl) +!***description +! +! ixsav saves and recalls one of two error message parameters: +! lunit, the logical unit number to which messages are printed, and +! mesflg, the message print flag. +! this is a modification of the slatec library routine j4save. +! +! saved local variables.. +! lunit = logical unit number for messages. the default is obtained +! by a call to iumach (may be machine-dependent). +! mesflg = print control flag.. +! 1 means print all messages (the default). +! 0 means no printing. +! +! on input.. +! ipar = parameter indicator (1 for lunit, 2 for mesflg). +! ivalue = the value to be set for the parameter, if iset = .true. +! iset = logical flag to indicate whether to read or write. +! if iset = .true., the parameter will be given +! the value ivalue. if iset = .false., the parameter +! will be unchanged, and ivalue is a dummy argument. +! +! on return.. +! ixsav = the (old) value of the parameter. +! +!***see also xerrwd, xerrwv +!***routines called iumach +!***revision history (yymmdd) +! 921118 date written +! 930329 modified prologue to slatec format. (fnf) +! 930915 added iumach call to get default output unit. (ach) +! 930922 minor cosmetic changes. (fnf) +! 010425 type declaration for iumach added. (ach) +!***end prologue ixsav +! +! subroutines called by ixsav.. none +! function routine called by ixsav.. iumach +!----------------------------------------------------------------------- +!**end + logical iset + integer ipar, ivalue +!----------------------------------------------------------------------- +! 27-oct-2005 rce - do not declare functions that are in the module +! integer iumach, lunit, mesflg + integer lunit, mesflg +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this routine. +!----------------------------------------------------------------------- + save lunit, mesflg + data lunit/-1/, mesflg/1/ +! +!***first executable statement ixsav + if (ipar .eq. 1) then + if (lunit .eq. -1) lunit = iumach() + ixsav = lunit + if (iset) lunit = ivalue + endif +! + if (ipar .eq. 2) then + ixsav = mesflg + if (iset) mesflg = ivalue + endif +! + return +!----------------------- end of function ixsav ------------------------- + end function ixsav +!deck iumach + integer function iumach() +!***begin prologue iumach +!***purpose provide standard output unit number. +!***category r1 +!***type integer (iumach-i) +!***keywords machine constants +!***author hindmarsh, alan c., (llnl) +!***description +! *usage: +! integer lout, iumach +! lout = iumach() +! +! *function return values: +! lout : the standard logical unit for fortran output. +! +!***references (none) +!***routines called (none) +!***revision history (yymmdd) +! 930915 date written +! 930922 made user-callable, and other cosmetic changes. (fnf) +!***end prologue iumach +! +!*internal notes: +! the built-in value of 6 is standard on a wide range of fortran +! systems. this may be machine-dependent. +!**end +!***first executable statement iumach + iumach = 6 +! + return +!----------------------- end of function iumach ------------------------ + end function iumach +!deck dumach + double precision function dumach () +!***begin prologue dumach +!***purpose compute the unit roundoff of the machine. +!***category r1 +!***type double precision (rumach-s, dumach-d) +!***keywords machine constants +!***author hindmarsh, alan c., (llnl) +!***description +! *usage: +! double precision a, dumach +! a = dumach() +! +! *function return values: +! a : the unit roundoff of the machine. +! +! *description: +! the unit roundoff is defined as the smallest positive machine +! number u such that 1.0 + u .ne. 1.0. this is computed by dumach +! in a machine-independent manner. +! +!***references (none) +!***routines called dumsum +!***revision history (yyyymmdd) +! 19930216 date written +! 19930818 added slatec-format prologue. (fnf) +! 20030707 added dumsum to force normal storage of comp. (ach) +!***end prologue dumach +! + double precision u, comp +!***first executable statement dumach + u = 1.0d0 + 10 u = u*0.5d0 + call dumsum(1.0d0, u, comp) + if (comp .ne. 1.0d0) go to 10 + dumach = u*2.0d0 + return +!----------------------- end of function dumach ------------------------ + end function dumach + subroutine dumsum(a,b,c) +! routine to force normal storing of a + b, for dumach. + double precision a, b, c + c = a + b + return + end subroutine dumsum + +!----------------------------------------------------------------------- +! vode_subs.f - created on 28-jul-2004 +! by downloading following from www.netlib.org +! 1. daxpy, dcopy, ddot, dnrm2, dscal, idamax from blas +! 2. dgbfa, dbgsl, dgefa, dgesl from linpack +! +! 27-oct-2005 rce - change '1' dimensions in subr dgefa & dgesl +!----------------------------------------------------------------------- + + +!----------------------------------------------------------------------- + subroutine daxpy(n,da,dx,incx,dy,incy) +! +! constant times a vector plus a vector. +! uses unrolled loops for increments equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +! + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end subroutine daxpy + + +!----------------------------------------------------------------------- + subroutine dcopy(n,dx,incx,dy,incy) +! +! copies a vector, x, to a vector, y. +! uses unrolled loops for increments equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +! + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end subroutine dcopy + + + double precision function ddot(n,dx,incx,dy,incy) +! +! forms the dot product of two vectors. +! uses unrolled loops for increments equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +! + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + & + dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end function ddot + + +!----------------------------------------------------------------------- + double precision function dnrm2 ( n, x, incx ) +! .. scalar arguments .. + integer incx, n +! .. array arguments .. + double precision x( * ) +! .. +! +! dnrm2 returns the euclidean norm of a vector via the function +! name, so that +! +! dnrm2 := sqrt( x'*x ) +! +! +! +! -- this version written on 25-october-1982. +! modified on 14-october-1993 to inline the call to dlassq. +! sven hammarling, nag ltd. +! +! +! .. parameters .. + double precision one , zero + parameter ( one = 1.0d+0, zero = 0.0d+0 ) +! .. local scalars .. + integer ix + double precision absxi, norm, scale, ssq +! .. intrinsic functions .. + intrinsic abs, sqrt +! .. +! .. executable statements .. + if( n.lt.1 .or. incx.lt.1 )then + norm = zero + else if( n.eq.1 )then + norm = abs( x( 1 ) ) + else + scale = zero + ssq = one +! the following loop is equivalent to this call to the lapack +! auxiliary routine: +! call dlassq( n, x, incx, scale, ssq ) +! + do 10, ix = 1, 1 + ( n - 1 )*incx, incx + if( x( ix ).ne.zero )then + absxi = abs( x( ix ) ) + if( scale.lt.absxi )then + ssq = one + ssq*( scale/absxi )**2 + scale = absxi + else + ssq = ssq + ( absxi/scale )**2 + end if + end if + 10 continue + norm = scale * sqrt( ssq ) + end if +! + dnrm2 = norm + return +! +! end of dnrm2. +! + end function dnrm2 + + +!----------------------------------------------------------------------- + subroutine dscal(n,da,dx,incx) +! +! scales a vector by a constant. +! uses unrolled loops for increment equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 3/93 to return if incx .le. 0. +! modified 12/3/93, array(1) declarations changed to array(*) +! + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +! + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +! +! code for increment not equal to 1 +! + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +! +! code for increment equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end subroutine dscal + + +!----------------------------------------------------------------------- + integer function idamax(n,dx,incx) +! +! finds the index of element having max. absolute value. +! jack dongarra, linpack, 3/11/78. +! modified 3/93 to return if incx .le. 0. +! modified 12/3/93, array(1) declarations changed to array(*) +! + double precision dx(*),dmax + integer i,incx,ix,n +! + idamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + idamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +! +! code for increment not equal to 1 +! + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + do 10 i = 2,n + if(dabs(dx(ix)).le.dmax) go to 5 + idamax = i + dmax = dabs(dx(ix)) + 5 ix = ix + incx + 10 continue + return +! +! code for increment equal to 1 +! + 20 dmax = dabs(dx(1)) + do 30 i = 2,n + if(dabs(dx(i)).le.dmax) go to 30 + idamax = i + dmax = dabs(dx(i)) + 30 continue + return + end function idamax + + +!----------------------------------------------------------------------- + subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) + integer lda,n,ml,mu,ipvt(1),info + double precision abd(lda,1) +! +! dgbfa factors a double precision band matrix by elimination. +! +! dgbfa is usually called by dgbco, but it can be called +! directly with a saving in time if rcond is not needed. +! +! on entry +! +! abd double precision(lda, n) +! contains the matrix in band storage. the columns +! of the matrix are stored in the columns of abd and +! the diagonals of the matrix are stored in rows +! ml+1 through 2*ml+mu+1 of abd . +! see the comments below for details. +! +! lda integer +! the leading dimension of the array abd . +! lda must be .ge. 2*ml + mu + 1 . +! +! n integer +! the order of the original matrix. +! +! ml integer +! number of diagonals below the main diagonal. +! 0 .le. ml .lt. n . +! +! mu integer +! number of diagonals above the main diagonal. +! 0 .le. mu .lt. n . +! more efficient if ml .le. mu . +! on return +! +! abd an upper triangular matrix in band storage and +! the multipliers which were used to obtain it. +! the factorization can be written a = l*u where +! l is a product of permutation and unit lower +! triangular matrices and u is upper triangular. +! +! ipvt integer(n) +! an integer vector of pivot indices. +! +! info integer +! = 0 normal value. +! = k if u(k,k) .eq. 0.0 . this is not an error +! condition for this subroutine, but it does +! indicate that dgbsl will divide by zero if +! called. use rcond in dgbco for a reliable +! indication of singularity. +! +! band storage +! +! if a is a band matrix, the following program segment +! will set up the input. +! +! ml = (band width below the diagonal) +! mu = (band width above the diagonal) +! m = ml + mu + 1 +! do 20 j = 1, n +! i1 = max0(1, j-mu) +! i2 = min0(n, j+ml) +! do 10 i = i1, i2 +! k = i - j + m +! abd(k,j) = a(i,j) +! 10 continue +! 20 continue +! +! this uses rows ml+1 through 2*ml+mu+1 of abd . +! in addition, the first ml rows in abd are used for +! elements generated during the triangularization. +! the total number of rows needed in abd is 2*ml+mu+1 . +! the ml+mu by ml+mu upper left triangle and the +! ml by ml lower right triangle are not referenced. +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas daxpy,dscal,idamax +! fortran max0,min0 +! +! internal variables +! + double precision t +! 27-oct-2005 rce - do not declare functions that are in the module +! integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 + integer i, i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 +! +! + m = ml + mu + 1 + info = 0 +! +! zero initial fill-in columns +! + j0 = mu + 2 + j1 = min0(n,m) - 1 + if (j1 .lt. j0) go to 30 + do 20 jz = j0, j1 + i0 = m + 1 - jz + do 10 i = i0, ml + abd(i,jz) = 0.0d0 + 10 continue + 20 continue + 30 continue + jz = j1 + ju = 0 +! +! gaussian elimination with partial pivoting +! + nm1 = n - 1 + if (nm1 .lt. 1) go to 130 + do 120 k = 1, nm1 + kp1 = k + 1 +! +! zero next fill-in column +! + jz = jz + 1 + if (jz .gt. n) go to 50 + if (ml .lt. 1) go to 50 + do 40 i = 1, ml + abd(i,jz) = 0.0d0 + 40 continue + 50 continue +! +! find l = pivot index +! + lm = min0(ml,n-k) + l = idamax(lm+1,abd(m,k),1) + m - 1 + ipvt(k) = l + k - m +! +! zero pivot implies this column already triangularized +! + if (abd(l,k) .eq. 0.0d0) go to 100 +! +! interchange if necessary +! + if (l .eq. m) go to 60 + t = abd(l,k) + abd(l,k) = abd(m,k) + abd(m,k) = t + 60 continue +! +! compute multipliers +! + t = -1.0d0/abd(m,k) + call dscal(lm,t,abd(m+1,k),1) +! +! row elimination with column indexing +! + ju = min0(max0(ju,mu+ipvt(k)),n) + mm = m + if (ju .lt. kp1) go to 90 + do 80 j = kp1, ju + l = l - 1 + mm = mm - 1 + t = abd(l,j) + if (l .eq. mm) go to 70 + abd(l,j) = abd(mm,j) + abd(mm,j) = t + 70 continue + call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) + 80 continue + 90 continue + go to 110 + 100 continue + info = k + 110 continue + 120 continue + 130 continue + ipvt(n) = n + if (abd(m,n) .eq. 0.0d0) info = n + return + end subroutine dgbfa + + +!----------------------------------------------------------------------- + subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) + integer lda,n,ml,mu,ipvt(1),job + double precision abd(lda,1),b(1) +! +! dgbsl solves the double precision band system +! a * x = b or trans(a) * x = b +! using the factors computed by dgbco or dgbfa. +! +! on entry +! +! abd double precision(lda, n) +! the output from dgbco or dgbfa. +! +! lda integer +! the leading dimension of the array abd . +! +! n integer +! the order of the original matrix. +! +! ml integer +! number of diagonals below the main diagonal. +! +! mu integer +! number of diagonals above the main diagonal. +! +! ipvt integer(n) +! the pivot vector from dgbco or dgbfa. +! +! b double precision(n) +! the right hand side vector. +! +! job integer +! = 0 to solve a*x = b , +! = nonzero to solve trans(a)*x = b , where +! trans(a) is the transpose. +! +! on return +! +! b the solution vector x . +! +! error condition +! +! a division by zero will occur if the input factor contains a +! zero on the diagonal. technically this indicates singularity +! but it is often caused by improper arguments or improper +! setting of lda . it will not occur if the subroutines are +! called correctly and if dgbco has set rcond .gt. 0.0 +! or dgbfa has set info .eq. 0 . +! +! to compute inverse(a) * c where c is a matrix +! with p columns +! call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) +! if (rcond is too small) go to ... +! do 10 j = 1, p +! call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) +! 10 continue +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas daxpy,ddot +! fortran min0 +! +! internal variables +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision ddot,t + double precision t + integer k,kb,l,la,lb,lm,m,nm1 +! + m = mu + ml + 1 + nm1 = n - 1 + if (job .ne. 0) go to 50 +! +! job = 0 , solve a * x = b +! first solve l*y = b +! + if (ml .eq. 0) go to 30 + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + lm = min0(ml,n-k) + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + 10 continue + call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) + 20 continue + 30 continue +! +! now solve u*x = y +! + do 40 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/abd(m,k) + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = -b(k) + call daxpy(lm,t,abd(la,k),1,b(lb),1) + 40 continue + go to 100 + 50 continue +! +! job = nonzero, solve trans(a) * x = b +! first solve trans(u)*y = b +! + do 60 k = 1, n + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = ddot(lm,abd(la,k),1,b(lb),1) + b(k) = (b(k) - t)/abd(m,k) + 60 continue +! +! now solve trans(l)*x = y +! + if (ml .eq. 0) go to 90 + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + lm = min0(ml,n-k) + b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + return + end subroutine dgbsl + + +!----------------------------------------------------------------------- + subroutine dgefa(a,lda,n,ipvt,info) +! 27-oct-2005 rce - change '1' dimensions +! integer lda,n,ipvt(1),info + integer lda,n,ipvt(n),info +! double precision a(lda,1) + double precision a(lda,n) +! +! dgefa factors a double precision matrix by gaussian elimination. +! +! dgefa is usually called by dgeco, but it can be called +! directly with a saving in time if rcond is not needed. +! (time for dgeco) = (1 + 9/n)*(time for dgefa) . +! +! on entry +! +! a double precision(lda, n) +! the matrix to be factored. +! +! lda integer +! the leading dimension of the array a . +! +! n integer +! the order of the matrix a . +! +! on return +! +! a an upper triangular matrix and the multipliers +! which were used to obtain it. +! the factorization can be written a = l*u where +! l is a product of permutation and unit lower +! triangular matrices and u is upper triangular. +! +! ipvt integer(n) +! an integer vector of pivot indices. +! +! info integer +! = 0 normal value. +! = k if u(k,k) .eq. 0.0 . this is not an error +! condition for this subroutine, but it does +! indicate that dgesl or dgedi will divide by zero +! if called. use rcond in dgeco for a reliable +! indication of singularity. +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas daxpy,dscal,idamax +! +! internal variables +! + double precision t +! 27-oct-2005 rce - do not declare functions that are in the module +! integer idamax,j,k,kp1,l,nm1 + integer j,k,kp1,l,nm1 +! +! +! gaussian elimination with partial pivoting +! + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +! +! find l = pivot index +! + l = idamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +! +! zero pivot implies this column already triangularized +! + if (a(l,k) .eq. 0.0d0) go to 40 +! +! interchange if necessary +! + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +! +! compute multipliers +! + t = -1.0d0/a(k,k) + call dscal(n-k,t,a(k+1,k),1) +! +! row elimination with column indexing +! + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (a(n,n) .eq. 0.0d0) info = n + return + end subroutine dgefa + + +!----------------------------------------------------------------------- + subroutine dgesl(a,lda,n,ipvt,b,job) +! 27-oct-2005 rce - change '1' dimensions +! integer lda,n,ipvt(1),job + integer lda,n,ipvt(n),job +! double precision a(lda,1),b(1) + double precision a(lda,n),b(n) +! +! dgesl solves the double precision system +! a * x = b or trans(a) * x = b +! using the factors computed by dgeco or dgefa. +! +! on entry +! +! a double precision(lda, n) +! the output from dgeco or dgefa. +! +! lda integer +! the leading dimension of the array a . +! +! n integer +! the order of the matrix a . +! +! ipvt integer(n) +! the pivot vector from dgeco or dgefa. +! +! b double precision(n) +! the right hand side vector. +! +! job integer +! = 0 to solve a*x = b , +! = nonzero to solve trans(a)*x = b where +! trans(a) is the transpose. +! +! on return +! +! b the solution vector x . +! +! error condition +! +! a division by zero will occur if the input factor contains a +! zero on the diagonal. technically this indicates singularity +! but it is often caused by improper arguments or improper +! setting of lda . it will not occur if the subroutines are +! called correctly and if dgeco has set rcond .gt. 0.0 +! or dgefa has set info .eq. 0 . +! +! to compute inverse(a) * c where c is a matrix +! with p columns +! call dgeco(a,lda,n,ipvt,rcond,z) +! if (rcond is too small) go to ... +! do 10 j = 1, p +! call dgesl(a,lda,n,ipvt,c(1,j),0) +! 10 continue +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas daxpy,ddot +! +! internal variables +! +! 27-oct-2005 rce - do not declare functions that are in the module +! double precision ddot,t + double precision t + integer k,kb,l,nm1 +! + nm1 = n - 1 + if (job .ne. 0) go to 50 +! +! job = 0 , solve a * x = b +! first solve l*y = b +! + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + 10 continue + call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) + 20 continue + 30 continue +! +! now solve u*x = y +! + do 40 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/a(k,k) + t = -b(k) + call daxpy(k-1,t,a(1,k),1,b(1),1) + 40 continue + go to 100 + 50 continue +! +! job = nonzero, solve trans(a) * x = b +! first solve trans(u)*y = b +! + do 60 k = 1, n + t = ddot(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + 60 continue +! +! now solve trans(l)*x = y +! + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + return + end subroutine dgesl + + + + end module module_cmu_dvode_solver + diff --git a/wrfv2_fire/chem/module_cmu_svode_solver.F b/wrfv2_fire/chem/module_cmu_svode_solver.F new file mode 100644 index 00000000..30f19daf --- /dev/null +++ b/wrfv2_fire/chem/module_cmu_svode_solver.F @@ -0,0 +1,4513 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + + module module_cmu_svode_solver + + + use module_peg_util, only: peg_error_fatal + + + contains + + +!----------------------------------------------------------------------- +! rce 2003-jul-01 - obtained from s.pandis +! rce 2005-jan-21 - converted to a module. Renamed svod01&2 common blocks +! to svode_cmn_01&2 to make their name more unique. +! In xerrwv, changed msg to char*(nmes) to eliminate compiler warnings. +!----------------------------------------------------------------------- + +!* ====================================================================== +!* nist guide to available math software. +!* fullsource for module svode from package ode. +!* retrieved from netlib on tue jun 16 20:57:19 1998. +!* ====================================================================== + +!*deck svode + subroutine svode (f, neq, y, t, tout, itol, rtol, atol, itask, & + istate, iopt, rwork, lrw, iwork, liw, jac, mf, & + rpar, ipar) + external f, jac + real y, t, tout, rtol, atol, rwork, rpar + integer neq, itol, itask, istate, iopt, lrw, iwork, liw, & + mf, ipar + dimension y(*), rtol(*), atol(*), rwork(lrw), iwork(liw), & + rpar(*), ipar(*) +!----------------------------------------------------------------------- +! svode.. variable-coefficient ordinary differential equation solver, +! with fixed-leading-coefficient implementation. +! this version is in single precision. +! +! svode solves the initial value problem for stiff or nonstiff +! systems of first order odes, +! dy/dt = f(t,y) , or, in component form, +! dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(neq)) (i = 1,...,neq). +! svode is a package based on the episode and episodeb packages, and +! on the odepack user interface standard, with minor modifications. +!----------------------------------------------------------------------- +! revision history (yymmdd) +! 890615 date written +! 890922 added interrupt/restart ability, minor changes throughout. +! 910228 minor revisions in line format, prologue, etc. +! 920227 modifications by d. pang: +! (1) applied subgennam to get generic intrinsic names. +! (2) changed intrinsic names to generic in comments. +! (3) added *deck lines before each routine. +! 920721 names of routines and labeled common blocks changed, so as +! to be unique in combined single/double precision code (ach). +! 920722 minor revisions to prologue (ach). +! 921106 fixed minor bug: etaq,etaqm1 in svstep save statement (ach). +! 921118 changed lunsav/mflgsv to ixsav (ach). +! 941222 removed mf overwrite; attached sign to h in estimated second +! derivative in svhin; misc. comment corrections throughout. +! 970515 minor corrections to comments in prologue, svjac. +!----------------------------------------------------------------------- +! references.. +! +! 1. p. n. brown, g. d. byrne, and a. c. hindmarsh, "vode: a variable +! coefficient ode solver," siam j. sci. stat. comput., 10 (1989), +! pp. 1038-1051. also, llnl report ucrl-98412, june 1988. +! 2. g. d. byrne and a. c. hindmarsh, "a polyalgorithm for the +! numerical solution of ordinary differential equations," +! acm trans. math. software, 1 (1975), pp. 71-96. +! 3. a. c. hindmarsh and g. d. byrne, "episode: an effective package +! for the integration of systems of ordinary differential +! equations," llnl report ucid-30112, rev. 1, april 1977. +! 4. g. d. byrne and a. c. hindmarsh, "episodeb: an experimental +! package for the integration of systems of ordinary differential +! equations with banded jacobians," llnl report ucid-30132, april +! 1976. +! 5. a. c. hindmarsh, "odepack, a systematized collection of ode +! solvers," in scientific computing, r. s. stepleman et al., eds., +! north-holland, amsterdam, 1983, pp. 55-64. +! 6. k. r. jackson and r. sacks-davis, "an alternative implementation +! of variable step-size multistep formulas for stiff odes," acm +! trans. math. software, 6 (1980), pp. 295-318. +!----------------------------------------------------------------------- +! authors.. +! +! peter n. brown and alan c. hindmarsh +! center for applied scientific computing, l-561 +! lawrence livermore national laboratory +! livermore, ca 94551 +! and +! george d. byrne +! illinois institute of technology +! chicago, il 60616 +!----------------------------------------------------------------------- +! summary of usage. +! +! communication between the user and the svode package, for normal +! situations, is summarized here. this summary describes only a subset +! of the full set of options available. see the full description for +! details, including optional communication, nonstandard options, +! and instructions for special situations. see also the example +! problem (with program and output) following this summary. +! +! a. first provide a subroutine of the form.. +! +! subroutine f (neq, t, y, ydot, rpar, ipar) +! real t, y, ydot, rpar +! dimension y(neq), ydot(neq) +! +! which supplies the vector function f by loading ydot(i) with f(i). +! +! b. next determine (or guess) whether or not the problem is stiff. +! stiffness occurs when the jacobian matrix df/dy has an eigenvalue +! whose real part is negative and large in magnitude, compared to the +! reciprocal of the t span of interest. if the problem is nonstiff, +! use a method flag mf = 10. if it is stiff, there are four standard +! choices for mf (21, 22, 24, 25), and svode requires the jacobian +! matrix in some form. in these cases (mf .gt. 0), svode will use a +! saved copy of the jacobian matrix. if this is undesirable because of +! storage limitations, set mf to the corresponding negative value +! (-21, -22, -24, -25). (see full description of mf below.) +! the jacobian matrix is regarded either as full (mf = 21 or 22), +! or banded (mf = 24 or 25). in the banded case, svode requires two +! half-bandwidth parameters ml and mu. these are, respectively, the +! widths of the lower and upper parts of the band, excluding the main +! diagonal. thus the band consists of the locations (i,j) with +! i-ml .le. j .le. i+mu, and the full bandwidth is ml+mu+1. +! +! c. if the problem is stiff, you are encouraged to supply the jacobian +! directly (mf = 21 or 24), but if this is not feasible, svode will +! compute it internally by difference quotients (mf = 22 or 25). +! if you are supplying the jacobian, provide a subroutine of the form.. +! +! subroutine jac (neq, t, y, ml, mu, pd, nrowpd, rpar, ipar) +! real t, y, pd, rpar +! dimension y(neq), pd(nrowpd,neq) +! +! which supplies df/dy by loading pd as follows.. +! for a full jacobian (mf = 21), load pd(i,j) with df(i)/dy(j), +! the partial derivative of f(i) with respect to y(j). (ignore the +! ml and mu arguments in this case.) +! for a banded jacobian (mf = 24), load pd(i-j+mu+1,j) with +! df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of +! pd from the top down. +! in either case, only nonzero elements need be loaded. +! +! d. write a main program which calls subroutine svode once for +! each point at which answers are desired. this should also provide +! for possible use of logical unit 6 for output of error messages +! by svode. on the first call to svode, supply arguments as follows.. +! f = name of subroutine for right-hand side vector f. +! this name must be declared external in calling program. +! neq = number of first order ode-s. +! y = array of initial values, of length neq. +! t = the initial value of the independent variable. +! tout = first point where output is desired (.ne. t). +! itol = 1 or 2 according as atol (below) is a scalar or array. +! rtol = relative tolerance parameter (scalar). +! atol = absolute tolerance parameter (scalar or array). +! the estimated local error in y(i) will be controlled so as +! to be roughly less (in magnitude) than +! ewt(i) = rtol*abs(y(i)) + atol if itol = 1, or +! ewt(i) = rtol*abs(y(i)) + atol(i) if itol = 2. +! thus the local error test passes if, in each component, +! either the absolute error is less than atol (or atol(i)), +! or the relative error is less than rtol. +! use rtol = 0.0 for pure absolute error control, and +! use atol = 0.0 (or atol(i) = 0.0) for pure relative error +! control. caution.. actual (global) errors may exceed these +! local tolerances, so choose them conservatively. +! itask = 1 for normal computation of output values of y at t = tout. +! istate = integer flag (input and output). set istate = 1. +! iopt = 0 to indicate no optional input used. +! rwork = real work array of length at least.. +! 20 + 16*neq for mf = 10, +! 22 + 9*neq + 2*neq**2 for mf = 21 or 22, +! 22 + 11*neq + (3*ml + 2*mu)*neq for mf = 24 or 25. +! lrw = declared length of rwork (in user's dimension statement). +! iwork = integer work array of length at least.. +! 30 for mf = 10, +! 30 + neq for mf = 21, 22, 24, or 25. +! if mf = 24 or 25, input in iwork(1),iwork(2) the lower +! and upper half-bandwidths ml,mu. +! liw = declared length of iwork (in user's dimension statement). +! jac = name of subroutine for jacobian matrix (mf = 21 or 24). +! if used, this name must be declared external in calling +! program. if not used, pass a dummy name. +! mf = method flag. standard values are.. +! 10 for nonstiff (adams) method, no jacobian used. +! 21 for stiff (bdf) method, user-supplied full jacobian. +! 22 for stiff method, internally generated full jacobian. +! 24 for stiff method, user-supplied banded jacobian. +! 25 for stiff method, internally generated banded jacobian. +! rpar,ipar = user-defined real and integer arrays passed to f and jac. +! note that the main program must declare arrays y, rwork, iwork, +! and possibly atol, rpar, and ipar. +! +! e. the output from the first call (or any call) is.. +! y = array of computed values of y(t) vector. +! t = corresponding value of independent variable (normally tout). +! istate = 2 if svode was successful, negative otherwise. +! -1 means excess work done on this call. (perhaps wrong mf.) +! -2 means excess accuracy requested. (tolerances too small.) +! -3 means illegal input detected. (see printed message.) +! -4 means repeated error test failures. (check all input.) +! -5 means repeated convergence failures. (perhaps bad +! jacobian supplied or wrong choice of mf or tolerances.) +! -6 means error weight became zero during problem. (solution +! component i vanished, and atol or atol(i) = 0.) +! +! f. to continue the integration after a successful return, simply +! reset tout and call svode again. no other parameters need be reset. +! +!----------------------------------------------------------------------- +! example problem +! +! the following is a simple example problem, with the coding +! needed for its solution by svode. the problem is from chemical +! kinetics, and consists of the following three rate equations.. +! dy1/dt = -.04*y1 + 1.e4*y2*y3 +! dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 +! dy3/dt = 3.e7*y2**2 +! on the interval from t = 0.0 to t = 4.e10, with initial conditions +! y1 = 1.0, y2 = y3 = 0. the problem is stiff. +! +! the following coding solves this problem with svode, using mf = 21 +! and printing results at t = .4, 4., ..., 4.e10. it uses +! itol = 2 and atol much smaller for y2 than y1 or y3 because +! y2 has much smaller values. +! at the end of the run, statistical quantities of interest are +! printed. (see optional output in the full description below.) +! to generate fortran source code, replace c in column 1 with a blank +! in the coding below. +! +! external fex, jex +! real atol, rpar, rtol, rwork, t, tout, y +! dimension y(3), atol(3), rwork(67), iwork(33) +! neq = 3 +! y(1) = 1.0e0 +! y(2) = 0.0e0 +! y(3) = 0.0e0 +! t = 0.0e0 +! tout = 0.4e0 +! itol = 2 +! rtol = 1.e-4 +! atol(1) = 1.e-8 +! atol(2) = 1.e-14 +! atol(3) = 1.e-6 +! itask = 1 +! istate = 1 +! iopt = 0 +! lrw = 67 +! liw = 33 +! mf = 21 +! do 40 iout = 1,12 +! call svode(fex,neq,y,t,tout,itol,rtol,atol,itask,istate, +! 1 iopt,rwork,lrw,iwork,liw,jex,mf,rpar,ipar) +! write(6,20)t,y(1),y(2),y(3) +! 20 format(' at t =',e12.4,' y =',3e14.6) +! if (istate .lt. 0) go to 80 +! 40 tout = tout*10. +! write(6,60) iwork(11),iwork(12),iwork(13),iwork(19), +! 1 iwork(20),iwork(21),iwork(22) +! 60 format(/' no. steps =',i4,' no. f-s =',i4, +! 1 ' no. j-s =',i4,' no. lu-s =',i4/ +! 2 ' no. nonlinear iterations =',i4/ +! 3 ' no. nonlinear convergence failures =',i4/ +! 4 ' no. error test failures =',i4/) +! stop +! 80 write(6,90)istate +! 90 format(///' error halt.. istate =',i3) +! stop +! end +! +! subroutine fex (neq, t, y, ydot, rpar, ipar) +! real rpar, t, y, ydot +! dimension y(neq), ydot(neq) +! ydot(1) = -.04e0*y(1) + 1.e4*y(2)*y(3) +! ydot(3) = 3.e7*y(2)*y(2) +! ydot(2) = -ydot(1) - ydot(3) +! return +! end +! +! subroutine jex (neq, t, y, ml, mu, pd, nrpd, rpar, ipar) +! real pd, rpar, t, y +! dimension y(neq), pd(nrpd,neq) +! pd(1,1) = -.04e0 +! pd(1,2) = 1.e4*y(3) +! pd(1,3) = 1.e4*y(2) +! pd(2,1) = .04e0 +! pd(2,3) = -pd(1,3) +! pd(3,2) = 6.e7*y(2) +! pd(2,2) = -pd(1,2) - pd(3,2) +! return +! end +! +! the following output was obtained from the above program on a +! cray-1 computer with the cft compiler. +! +! at t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 +! at t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 +! at t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 +! at t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 +! at t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 +! at t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 +! at t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 +! at t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 +! at t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 +! at t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 +! at t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 +! at t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 +! +! no. steps = 595 no. f-s = 832 no. j-s = 13 no. lu-s = 112 +! no. nonlinear iterations = 831 +! no. nonlinear convergence failures = 0 +! no. error test failures = 22 +!----------------------------------------------------------------------- +! full description of user interface to svode. +! +! the user interface to svode consists of the following parts. +! +! i. the call sequence to subroutine svode, which is a driver +! routine for the solver. this includes descriptions of both +! the call sequence arguments and of user-supplied routines. +! following these descriptions is +! * a description of optional input available through the +! call sequence, +! * a description of optional output (in the work arrays), and +! * instructions for interrupting and restarting a solution. +! +! ii. descriptions of other routines in the svode package that may be +! (optionally) called by the user. these provide the ability to +! alter error message handling, save and restore the internal +! common, and obtain specified derivatives of the solution y(t). +! +! iii. descriptions of common blocks to be declared in overlay +! or similar environments. +! +! iv. description of two routines in the svode package, either of +! which the user may replace with his own version, if desired. +! these relate to the measurement of errors. +! +!----------------------------------------------------------------------- +! part i. call sequence. +! +! the call sequence parameters used for input only are +! f, neq, tout, itol, rtol, atol, itask, iopt, lrw, liw, jac, mf, +! and those used for both input and output are +! y, t, istate. +! the work arrays rwork and iwork are also used for conditional and +! optional input and optional output. (the term output here refers +! to the return from subroutine svode to the user's calling program.) +! +! the legality of input parameters will be thoroughly checked on the +! initial call for the problem, but not checked thereafter unless a +! change in input parameters is flagged by istate = 3 in the input. +! +! the descriptions of the call arguments are as follows. +! +! f = the name of the user-supplied subroutine defining the +! ode system. the system must be put in the first-order +! form dy/dt = f(t,y), where f is a vector-valued function +! of the scalar t and the vector y. subroutine f is to +! compute the function f. it is to have the form +! subroutine f (neq, t, y, ydot, rpar, ipar) +! real t, y, ydot, rpar +! dimension y(neq), ydot(neq) +! where neq, t, and y are input, and the array ydot = f(t,y) +! is output. y and ydot are arrays of length neq. +! (in the dimension statement above, neq can be replaced by +! * to make y and ydot assumed size arrays.) +! subroutine f should not alter y(1),...,y(neq). +! f must be declared external in the calling program. +! +! subroutine f may access user-defined real and integer +! work arrays rpar and ipar, which are to be dimensioned +! in the main program. +! +! if quantities computed in the f routine are needed +! externally to svode, an extra call to f should be made +! for this purpose, for consistent and accurate results. +! if only the derivative dy/dt is needed, use svindy instead. +! +! neq = the size of the ode system (number of first order +! ordinary differential equations). used only for input. +! neq may not be increased during the problem, but +! can be decreased (with istate = 3 in the input). +! +! y = a real array for the vector of dependent variables, of +! length neq or more. used for both input and output on the +! first call (istate = 1), and only for output on other calls. +! on the first call, y must contain the vector of initial +! values. in the output, y contains the computed solution +! evaluated at t. if desired, the y array may be used +! for other purposes between calls to the solver. +! +! this array is passed as the y argument in all calls to +! f and jac. +! +! t = the independent variable. in the input, t is used only on +! the first call, as the initial point of the integration. +! in the output, after each call, t is the value at which a +! computed solution y is evaluated (usually the same as tout). +! on an error return, t is the farthest point reached. +! +! tout = the next value of t at which a computed solution is desired. +! used only for input. +! +! when starting the problem (istate = 1), tout may be equal +! to t for one call, then should .ne. t for the next call. +! for the initial t, an input value of tout .ne. t is used +! in order to determine the direction of the integration +! (i.e. the algebraic sign of the step sizes) and the rough +! scale of the problem. integration in either direction +! (forward or backward in t) is permitted. +! +! if itask = 2 or 5 (one-step modes), tout is ignored after +! the first call (i.e. the first call with tout .ne. t). +! otherwise, tout is required on every call. +! +! if itask = 1, 3, or 4, the values of tout need not be +! monotone, but a value of tout which backs up is limited +! to the current internal t interval, whose endpoints are +! tcur - hu and tcur. (see optional output, below, for +! tcur and hu.) +! +! itol = an indicator for the type of error control. see +! description below under atol. used only for input. +! +! rtol = a relative error tolerance parameter, either a scalar or +! an array of length neq. see description below under atol. +! input only. +! +! atol = an absolute error tolerance parameter, either a scalar or +! an array of length neq. input only. +! +! the input parameters itol, rtol, and atol determine +! the error control performed by the solver. the solver will +! control the vector e = (e(i)) of estimated local errors +! in y, according to an inequality of the form +! rms-norm of ( e(i)/ewt(i) ) .le. 1, +! where ewt(i) = rtol(i)*abs(y(i)) + atol(i), +! and the rms-norm (root-mean-square norm) here is +! rms-norm(v) = sqrt(sum v(i)**2 / neq). here ewt = (ewt(i)) +! is a vector of weights which must always be positive, and +! the values of rtol and atol should all be non-negative. +! the following table gives the types (scalar/array) of +! rtol and atol, and the corresponding form of ewt(i). +! +! itol rtol atol ewt(i) +! 1 scalar scalar rtol*abs(y(i)) + atol +! 2 scalar array rtol*abs(y(i)) + atol(i) +! 3 array scalar rtol(i)*abs(y(i)) + atol +! 4 array array rtol(i)*abs(y(i)) + atol(i) +! +! when either of these parameters is a scalar, it need not +! be dimensioned in the user's calling program. +! +! if none of the above choices (with itol, rtol, and atol +! fixed throughout the problem) is suitable, more general +! error controls can be obtained by substituting +! user-supplied routines for the setting of ewt and/or for +! the norm calculation. see part iv below. +! +! if global errors are to be estimated by making a repeated +! run on the same problem with smaller tolerances, then all +! components of rtol and atol (i.e. of ewt) should be scaled +! down uniformly. +! +! itask = an index specifying the task to be performed. +! input only. itask has the following values and meanings. +! 1 means normal computation of output values of y(t) at +! t = tout (by overshooting and interpolating). +! 2 means take one step only and return. +! 3 means stop at the first internal mesh point at or +! beyond t = tout and return. +! 4 means normal computation of output values of y(t) at +! t = tout but without overshooting t = tcrit. +! tcrit must be input as rwork(1). tcrit may be equal to +! or beyond tout, but not behind it in the direction of +! integration. this option is useful if the problem +! has a singularity at or beyond t = tcrit. +! 5 means take one step, without passing tcrit, and return. +! tcrit must be input as rwork(1). +! +! note.. if itask = 4 or 5 and the solver reaches tcrit +! (within roundoff), it will return t = tcrit (exactly) to +! indicate this (unless itask = 4 and tout comes before tcrit, +! in which case answers at t = tout are returned first). +! +! istate = an index used for input and output to specify the +! the state of the calculation. +! +! in the input, the values of istate are as follows. +! 1 means this is the first call for the problem +! (initializations will be done). see note below. +! 2 means this is not the first call, and the calculation +! is to continue normally, with no change in any input +! parameters except possibly tout and itask. +! (if itol, rtol, and/or atol are changed between calls +! with istate = 2, the new values will be used but not +! tested for legality.) +! 3 means this is not the first call, and the +! calculation is to continue normally, but with +! a change in input parameters other than +! tout and itask. changes are allowed in +! neq, itol, rtol, atol, iopt, lrw, liw, mf, ml, mu, +! and any of the optional input except h0. +! (see iwork description for ml and mu.) +! note.. a preliminary call with tout = t is not counted +! as a first call here, as no initialization or checking of +! input is done. (such a call is sometimes useful to include +! the initial conditions in the output.) +! thus the first call for which tout .ne. t requires +! istate = 1 in the input. +! +! in the output, istate has the following values and meanings. +! 1 means nothing was done, as tout was equal to t with +! istate = 1 in the input. +! 2 means the integration was performed successfully. +! -1 means an excessive amount of work (more than mxstep +! steps) was done on this call, before completing the +! requested task, but the integration was otherwise +! successful as far as t. (mxstep is an optional input +! and is normally 500.) to continue, the user may +! simply reset istate to a value .gt. 1 and call again. +! (the excess work step counter will be reset to 0.) +! in addition, the user may increase mxstep to avoid +! this error return. (see optional input below.) +! -2 means too much accuracy was requested for the precision +! of the machine being used. this was detected before +! completing the requested task, but the integration +! was successful as far as t. to continue, the tolerance +! parameters must be reset, and istate must be set +! to 3. the optional output tolsf may be used for this +! purpose. (note.. if this condition is detected before +! taking any steps, then an illegal input return +! (istate = -3) occurs instead.) +! -3 means illegal input was detected, before taking any +! integration steps. see written message for details. +! note.. if the solver detects an infinite loop of calls +! to the solver with illegal input, it will cause +! the run to stop. +! -4 means there were repeated error test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! the problem may have a singularity, or the input +! may be inappropriate. +! -5 means there were repeated convergence test failures on +! one attempted step, before completing the requested +! task, but the integration was successful as far as t. +! this may be caused by an inaccurate jacobian matrix, +! if one is being used. +! -6 means ewt(i) became zero for some i during the +! integration. pure relative error control (atol(i)=0.0) +! was requested on a variable which has now vanished. +! the integration was successful as far as t. +! +! note.. since the normal output value of istate is 2, +! it does not need to be reset for normal continuation. +! also, since a negative input value of istate will be +! regarded as illegal, a negative output value requires the +! user to change it, and possibly other input, before +! calling the solver again. +! +! iopt = an integer flag to specify whether or not any optional +! input is being used on this call. input only. +! the optional input is listed separately below. +! iopt = 0 means no optional input is being used. +! default values will be used in all cases. +! iopt = 1 means optional input is being used. +! +! rwork = a real working array (single precision). +! the length of rwork must be at least +! 20 + nyh*(maxord + 1) + 3*neq + lwm where +! nyh = the initial value of neq, +! maxord = 12 (if meth = 1) or 5 (if meth = 2) (unless a +! smaller value is given as an optional input), +! lwm = length of work space for matrix-related data.. +! lwm = 0 if miter = 0, +! lwm = 2*neq**2 + 2 if miter = 1 or 2, and mf.gt.0, +! lwm = neq**2 + 2 if miter = 1 or 2, and mf.lt.0, +! lwm = neq + 2 if miter = 3, +! lwm = (3*ml+2*mu+2)*neq + 2 if miter = 4 or 5, and mf.gt.0, +! lwm = (2*ml+mu+1)*neq + 2 if miter = 4 or 5, and mf.lt.0. +! (see the mf description for meth and miter.) +! thus if maxord has its default value and neq is constant, +! this length is.. +! 20 + 16*neq for mf = 10, +! 22 + 16*neq + 2*neq**2 for mf = 11 or 12, +! 22 + 16*neq + neq**2 for mf = -11 or -12, +! 22 + 17*neq for mf = 13, +! 22 + 18*neq + (3*ml+2*mu)*neq for mf = 14 or 15, +! 22 + 17*neq + (2*ml+mu)*neq for mf = -14 or -15, +! 20 + 9*neq for mf = 20, +! 22 + 9*neq + 2*neq**2 for mf = 21 or 22, +! 22 + 9*neq + neq**2 for mf = -21 or -22, +! 22 + 10*neq for mf = 23, +! 22 + 11*neq + (3*ml+2*mu)*neq for mf = 24 or 25. +! 22 + 10*neq + (2*ml+mu)*neq for mf = -24 or -25. +! the first 20 words of rwork are reserved for conditional +! and optional input and optional output. +! +! the following word in rwork is a conditional input.. +! rwork(1) = tcrit = critical value of t which the solver +! is not to overshoot. required if itask is +! 4 or 5, and ignored otherwise. (see itask.) +! +! lrw = the length of the array rwork, as declared by the user. +! (this will be checked by the solver.) +! +! iwork = an integer work array. the length of iwork must be at least +! 30 if miter = 0 or 3 (mf = 10, 13, 20, 23), or +! 30 + neq otherwise (abs(mf) = 11,12,14,15,21,22,24,25). +! the first 30 words of iwork are reserved for conditional and +! optional input and optional output. +! +! the following 2 words in iwork are conditional input.. +! iwork(1) = ml these are the lower and upper +! iwork(2) = mu half-bandwidths, respectively, of the +! banded jacobian, excluding the main diagonal. +! the band is defined by the matrix locations +! (i,j) with i-ml .le. j .le. i+mu. ml and mu +! must satisfy 0 .le. ml,mu .le. neq-1. +! these are required if miter is 4 or 5, and +! ignored otherwise. ml and mu may in fact be +! the band parameters for a matrix to which +! df/dy is only approximately equal. +! +! liw = the length of the array iwork, as declared by the user. +! (this will be checked by the solver.) +! +! note.. the work arrays must not be altered between calls to svode +! for the same problem, except possibly for the conditional and +! optional input, and except for the last 3*neq words of rwork. +! the latter space is used for internal scratch space, and so is +! available for use by the user outside svode between calls, if +! desired (but not for use by f or jac). +! +! jac = the name of the user-supplied routine (miter = 1 or 4) to +! compute the jacobian matrix, df/dy, as a function of +! the scalar t and the vector y. it is to have the form +! subroutine jac (neq, t, y, ml, mu, pd, nrowpd, +! rpar, ipar) +! real t, y, pd, rpar +! dimension y(neq), pd(nrowpd, neq) +! where neq, t, y, ml, mu, and nrowpd are input and the array +! pd is to be loaded with partial derivatives (elements of the +! jacobian matrix) in the output. pd must be given a first +! dimension of nrowpd. t and y have the same meaning as in +! subroutine f. (in the dimension statement above, neq can +! be replaced by * to make y and pd assumed size arrays.) +! in the full matrix case (miter = 1), ml and mu are +! ignored, and the jacobian is to be loaded into pd in +! columnwise manner, with df(i)/dy(j) loaded into pd(i,j). +! in the band matrix case (miter = 4), the elements +! within the band are to be loaded into pd in columnwise +! manner, with diagonal lines of df/dy loaded into the rows +! of pd. thus df(i)/dy(j) is to be loaded into pd(i-j+mu+1,j). +! ml and mu are the half-bandwidth parameters. (see iwork). +! the locations in pd in the two triangular areas which +! correspond to nonexistent matrix elements can be ignored +! or loaded arbitrarily, as they are overwritten by svode. +! jac need not provide df/dy exactly. a crude +! approximation (possibly with a smaller bandwidth) will do. +! in either case, pd is preset to zero by the solver, +! so that only the nonzero elements need be loaded by jac. +! each call to jac is preceded by a call to f with the same +! arguments neq, t, and y. thus to gain some efficiency, +! intermediate quantities shared by both calculations may be +! saved in a user common block by f and not recomputed by jac, +! if desired. also, jac may alter the y array, if desired. +! jac must be declared external in the calling program. +! subroutine jac may access user-defined real and integer +! work arrays, rpar and ipar, whose dimensions are set by the +! user in the main program. +! +! mf = the method flag. used only for input. the legal values of +! mf are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, +! -11, -12, -14, -15, -21, -22, -24, -25. +! mf is a signed two-digit integer, mf = jsv*(10*meth + miter). +! jsv = sign(mf) indicates the jacobian-saving strategy.. +! jsv = 1 means a copy of the jacobian is saved for reuse +! in the corrector iteration algorithm. +! jsv = -1 means a copy of the jacobian is not saved +! (valid only for miter = 1, 2, 4, or 5). +! meth indicates the basic linear multistep method.. +! meth = 1 means the implicit adams method. +! meth = 2 means the method based on backward +! differentiation formulas (bdf-s). +! miter indicates the corrector iteration method.. +! miter = 0 means functional iteration (no jacobian matrix +! is involved). +! miter = 1 means chord iteration with a user-supplied +! full (neq by neq) jacobian. +! miter = 2 means chord iteration with an internally +! generated (difference quotient) full jacobian +! (using neq extra calls to f per df/dy value). +! miter = 3 means chord iteration with an internally +! generated diagonal jacobian approximation +! (using 1 extra call to f per df/dy evaluation). +! miter = 4 means chord iteration with a user-supplied +! banded jacobian. +! miter = 5 means chord iteration with an internally +! generated banded jacobian (using ml+mu+1 extra +! calls to f per df/dy evaluation). +! if miter = 1 or 4, the user must supply a subroutine jac +! (the name is arbitrary) as described above under jac. +! for other values of miter, a dummy argument can be used. +! +! rpar user-specified array used to communicate real parameters +! to user-supplied subroutines. if rpar is a vector, then +! it must be dimensioned in the user's main program. if it +! is unused or it is a scalar, then it need not be +! dimensioned. +! +! ipar user-specified array used to communicate integer parameter +! to user-supplied subroutines. the comments on dimensioning +! rpar apply to ipar. +!----------------------------------------------------------------------- +! optional input. +! +! the following is a list of the optional input provided for in the +! call sequence. (see also part ii.) for each such input variable, +! this table lists its name as used in this documentation, its +! location in the call sequence, its meaning, and the default value. +! the use of any of this input requires iopt = 1, and in that +! case all of this input is examined. a value of zero for any +! of these optional input variables will cause the default value to be +! used. thus to use a subset of the optional input, simply preload +! locations 5 to 10 in rwork and iwork to 0.0 and 0 respectively, and +! then set those of interest to nonzero values. +! +! name location meaning and default value +! +! h0 rwork(5) the step size to be attempted on the first step. +! the default value is determined by the solver. +! +! hmax rwork(6) the maximum absolute step size allowed. +! the default value is infinite. +! +! hmin rwork(7) the minimum absolute step size allowed. +! the default value is 0. (this lower bound is not +! enforced on the final step before reaching tcrit +! when itask = 4 or 5.) +! +! maxord iwork(5) the maximum order to be allowed. the default +! value is 12 if meth = 1, and 5 if meth = 2. +! if maxord exceeds the default value, it will +! be reduced to the default value. +! if maxord is changed during the problem, it may +! cause the current order to be reduced. +! +! mxstep iwork(6) maximum number of (internally defined) steps +! allowed during one call to the solver. +! the default value is 500. +! +! mxhnil iwork(7) maximum number of messages printed (per problem) +! warning that t + h = t on a step (h = step size). +! this must be positive to result in a non-default +! value. the default value is 10. +! +!----------------------------------------------------------------------- +! optional output. +! +! as optional additional output from svode, the variables listed +! below are quantities related to the performance of svode +! which are available to the user. these are communicated by way of +! the work arrays, but also have internal mnemonic names as shown. +! except where stated otherwise, all of this output is defined +! on any successful return from svode, and on any return with +! istate = -1, -2, -4, -5, or -6. on an illegal input return +! (istate = -3), they will be unchanged from their existing values +! (if any), except possibly for tolsf, lenrw, and leniw. +! on any error return, output relevant to the error will be defined, +! as noted below. +! +! name location meaning +! +! hu rwork(11) the step size in t last used (successfully). +! +! hcur rwork(12) the step size to be attempted on the next step. +! +! tcur rwork(13) the current value of the independent variable +! which the solver has actually reached, i.e. the +! current internal mesh point in t. in the output, +! tcur will always be at least as far from the +! initial value of t as the current argument t, +! but may be farther (if interpolation was done). +! +! tolsf rwork(14) a tolerance scale factor, greater than 1.0, +! computed when a request for too much accuracy was +! detected (istate = -3 if detected at the start of +! the problem, istate = -2 otherwise). if itol is +! left unaltered but rtol and atol are uniformly +! scaled up by a factor of tolsf for the next call, +! then the solver is deemed likely to succeed. +! (the user may also ignore tolsf and alter the +! tolerance parameters in any other way appropriate.) +! +! nst iwork(11) the number of steps taken for the problem so far. +! +! nfe iwork(12) the number of f evaluations for the problem so far. +! +! nje iwork(13) the number of jacobian evaluations so far. +! +! nqu iwork(14) the method order last used (successfully). +! +! nqcur iwork(15) the order to be attempted on the next step. +! +! imxer iwork(16) the index of the component of largest magnitude in +! the weighted local error vector ( e(i)/ewt(i) ), +! on an error return with istate = -4 or -5. +! +! lenrw iwork(17) the length of rwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! leniw iwork(18) the length of iwork actually required. +! this is defined on normal returns and on an illegal +! input return for insufficient storage. +! +! nlu iwork(19) the number of matrix lu decompositions so far. +! +! nni iwork(20) the number of nonlinear (newton) iterations so far. +! +! ncfn iwork(21) the number of convergence failures of the nonlinear +! solver so far. +! +! netf iwork(22) the number of error test failures of the integrator +! so far. +! +! the following two arrays are segments of the rwork array which +! may also be of interest to the user as optional output. +! for each array, the table below gives its internal name, +! its base address in rwork, and its description. +! +! name base address description +! +! yh 21 the nordsieck history array, of size nyh by +! (nqcur + 1), where nyh is the initial value +! of neq. for j = 0,1,...,nqcur, column j+1 +! of yh contains hcur**j/factorial(j) times +! the j-th derivative of the interpolating +! polynomial currently representing the +! solution, evaluated at t = tcur. +! +! acor lenrw-neq+1 array of size neq used for the accumulated +! corrections on each step, scaled in the output +! to represent the estimated local error in y +! on the last step. this is the vector e in +! the description of the error control. it is +! defined only on a successful return from svode. +! +!----------------------------------------------------------------------- +! interrupting and restarting +! +! if the integration of a given problem by svode is to be +! interrrupted and then later continued, such as when restarting +! an interrupted run or alternating between two or more ode problems, +! the user should save, following the return from the last svode call +! prior to the interruption, the contents of the call sequence +! variables and internal common blocks, and later restore these +! values before the next svode call for that problem. to save +! and restore the common blocks, use subroutine svsrco, as +! described below in part ii. +! +! in addition, if non-default values for either lun or mflag are +! desired, an extra call to xsetun and/or xsetf should be made just +! before continuing the integration. see part ii below for details. +! +!----------------------------------------------------------------------- +! part ii. other routines callable. +! +! the following are optional calls which the user may make to +! gain additional capabilities in conjunction with svode. +! (the routines xsetun and xsetf are designed to conform to the +! slatec error handling package.) +! +! form of call function +! call xsetun(lun) set the logical unit number, lun, for +! output of messages from svode, if +! the default is not desired. +! the default value of lun is 6. +! +! call xsetf(mflag) set a flag to control the printing of +! messages by svode. +! mflag = 0 means do not print. (danger.. +! this risks losing valuable information.) +! mflag = 1 means print (the default). +! +! either of the above calls may be made at +! any time and will take effect immediately. +! +! call svsrco(rsav,isav,job) saves and restores the contents of +! the internal common blocks used by +! svode. (see part iii below.) +! rsav must be a real array of length 49 +! or more, and isav must be an integer +! array of length 40 or more. +! job=1 means save common into rsav/isav. +! job=2 means restore common from rsav/isav. +! svsrco is useful if one is +! interrupting a run and restarting +! later, or alternating between two or +! more problems solved with svode. +! +! call svindy(,,,,,) provide derivatives of y, of various +! (see below.) orders, at a specified point t, if +! desired. it may be called only after +! a successful return from svode. +! +! the detailed instructions for using svindy are as follows. +! the form of the call is.. +! +! call svindy (t, k, rwork(21), nyh, dky, iflag) +! +! the input parameters are.. +! +! t = value of independent variable where answers are desired +! (normally the same as the t last returned by svode). +! for valid results, t must lie between tcur - hu and tcur. +! (see optional output for tcur and hu.) +! k = integer order of the derivative desired. k must satisfy +! 0 .le. k .le. nqcur, where nqcur is the current order +! (see optional output). the capability corresponding +! to k = 0, i.e. computing y(t), is already provided +! by svode directly. since nqcur .ge. 1, the first +! derivative dy/dt is always available with svindy. +! rwork(21) = the base address of the history array yh. +! nyh = column length of yh, equal to the initial value of neq. +! +! the output parameters are.. +! +! dky = a real array of length neq containing the computed value +! of the k-th derivative of y(t). +! iflag = integer flag, returned as 0 if k and t were legal, +! -1 if k was illegal, and -2 if t was illegal. +! on an error return, a message is also written. +!----------------------------------------------------------------------- +! part iii. common blocks. +! if svode is to be used in an overlay situation, the user +! must declare, in the primary overlay, the variables in.. +! (1) the call sequence to svode, +! (2) the two internal common blocks +! /svode_cmn_01/ of length 81 (48 single precision words +! followed by 33 integer words), +! /svode_cmn_02/ of length 9 (1 single precision word +! followed by 8 integer words), +! +! if svode is used on a system in which the contents of internal +! common blocks are not preserved between calls, the user should +! declare the above two common blocks in his main program to insure +! that their contents are preserved. +! +!----------------------------------------------------------------------- +! part iv. optionally replaceable solver routines. +! +! below are descriptions of two routines in the svode package which +! relate to the measurement of errors. either routine can be +! replaced by a user-supplied version, if desired. however, since such +! a replacement may have a major impact on performance, it should be +! done only when absolutely necessary, and only with great caution. +! (note.. the means by which the package version of a routine is +! superseded by the user's version may be system-dependent.) +! +! (a) sewset. +! the following subroutine is called just before each internal +! integration step, and sets the array of error weights, ewt, as +! described under itol/rtol/atol above.. +! subroutine sewset (neq, itol, rtol, atol, ycur, ewt) +! where neq, itol, rtol, and atol are as in the svode call sequence, +! ycur contains the current dependent variable vector, and +! ewt is the array of weights set by sewset. +! +! if the user supplies this subroutine, it must return in ewt(i) +! (i = 1,...,neq) a positive quantity suitable for comparison with +! errors in y(i). the ewt array returned by sewset is passed to the +! svnorm routine (see below.), and also used by svode in the computation +! of the optional output imxer, the diagonal jacobian approximation, +! and the increments for difference quotient jacobians. +! +! in the user-supplied version of sewset, it may be desirable to use +! the current values of derivatives of y. derivatives up to order nq +! are available from the history array yh, described above under +! optional output. in sewset, yh is identical to the ycur array, +! extended to nq + 1 columns with a column length of nyh and scale +! factors of h**j/factorial(j). on the first call for the problem, +! given by nst = 0, nq is 1 and h is temporarily set to 1.0. +! nyh is the initial value of neq. the quantities nq, h, and nst +! can be obtained by including in sewset the statements.. +! real rvod, h, hu +! common /svode_cmn_01/ rvod(48), ivod(33) +! common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! nq = ivod(28) +! h = rvod(21) +! thus, for example, the current value of dy/dt can be obtained as +! ycur(nyh+i)/h (i=1,...,neq) (and the division by h is +! unnecessary when nst = 0). +! +! (b) svnorm. +! the following is a real function routine which computes the weighted +! root-mean-square norm of a vector v.. +! d = svnorm (n, v, w) +! where.. +! n = the length of the vector, +! v = real array of length n containing the vector, +! w = real array of length n containing weights, +! d = sqrt( (1/n) * sum(v(i)*w(i))**2 ). +! svnorm is called with n = neq and with w(i) = 1.0/ewt(i), where +! ewt is as set by subroutine sewset. +! +! if the user supplies this function, it should return a non-negative +! value of svnorm suitable for use in the error control in svode. +! none of the arguments should be altered by svnorm. +! for example, a user-supplied svnorm routine might.. +! -substitute a max-norm of (v(i)*w(i)) for the rms-norm, or +! -ignore some components of v in the norm, with the effect of +! suppressing the error control on those components of y. +!----------------------------------------------------------------------- +! other routines in the svode package. +! +! in addition to subroutine svode, the svode package includes the +! following subroutines and function routines.. +! svhin computes an approximate step size for the initial step. +! svindy computes an interpolated value of the y vector at t = tout. +! svstep is the core integrator, which does one step of the +! integration and the associated error control. +! svset sets all method coefficients and test constants. +! svnlsd solves the underlying nonlinear system -- the corrector. +! svjac computes and preprocesses the jacobian matrix j = df/dy +! and the newton iteration matrix p = i - (h/l1)*j. +! svsol manages solution of linear system in chord iteration. +! svjust adjusts the history array on a change of order. +! sewset sets the error weight vector ewt before each step. +! svnorm computes the weighted r.m.s. norm of a vector. +! svsrco is a user-callable routine to save and restore +! the contents of the internal common blocks. +! sacopy is a routine to copy one two-dimensional array to another. +! sgefa and sgesl are routines from linpack for solving full +! systems of linear algebraic equations. +! sgbfa and sgbsl are routines from linpack for solving banded +! linear systems. +! saxpy, sscal, and scopy are basic linear algebra modules (blas). +! r1mach sets the unit roundoff of the machine. +! xerrwv, xsetun, xsetf, and ixsav handle the printing of all +! error messages and warnings. xerrwv is machine-dependent. +! note.. svnorm, r1mach, and ixsav are function routines. +! all the others are subroutines. +! +! the intrinsic and external routines used by the svode package are.. +! abs, max, min, real, sign, sqrt, and write. +! +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block svode_cmn_02 -------------------- +! + real hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! +! external svnlsd ! rce 2005-jan-21 - module conversion + logical ihit + real atoli, big, ewti, four, h0, hmax, hmx, hun, one, & + pt2, rh, rtoli, size, tcrit, tnext, tolsf, tp, two, zero + integer i, ier, iflag, imxer, jco, kgo, leniw, lenj, lenp, lenrw, & + lenwm, lf0, mband, mfa, ml, mord, mu, mxhnl0, mxstp0, niter, & + nslast + character*80 msg +! +! type declaration for function subroutines called --------------------- +! +! real r1mach, svnorm ! rce 2005-jan-21 - module conversion +! + dimension mord(2) +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to svode. +!----------------------------------------------------------------------- + save mord, mxhnl0, mxstp0 + save zero, one, two, four, pt2, hun +!----------------------------------------------------------------------- +! the following internal common blocks contain variables which are +! communicated between subroutines in the svode package, or which are +! to be saved between calls to svode. +! in each block, real variables precede integers. +! the block /svode_cmn_01/ appears in subroutines svode, svindy, svstep, +! svset, svnlsd, svjac, svsol, svjust and svsrco. +! the block /svode_cmn_02/ appears in subroutines svode, svindy, svstep, +! svnlsd, svjac, and svsrco. +! +! the variables stored in the internal common blocks are as follows.. +! +! acnrm = weighted r.m.s. norm of accumulated correction vectors. +! ccmxj = threshhold on drc for updating the jacobian. (see drc.) +! conp = the saved value of tq(5). +! crate = estimated corrector convergence rate constant. +! drc = relative change in h*rl1 since last svjac call. +! el = real array of integration coefficients. see svset. +! eta = saved tentative ratio of new to old h. +! etamax = saved maximum value of eta to be allowed. +! h = the step size. +! hmin = the minimum absolute value of the step size h to be used. +! hmxi = inverse of the maximum absolute value of h to be used. +! hmxi = 0.0 is allowed and corresponds to an infinite hmax. +! hnew = the step size to be attempted on the next step. +! hscal = stepsize in scaling of yh array. +! prl1 = the saved value of rl1. +! rc = ratio of current h*rl1 to value on last svjac call. +! rl1 = the reciprocal of the coefficient el(1). +! tau = real vector of past nq step sizes, length 13. +! tq = a real vector of length 5 in which svset stores constants +! used for the convergence test, the error test, and the +! selection of h at a new order. +! tn = the independent variable, updated on each step taken. +! uround = the machine unit roundoff. the smallest positive real number +! such that 1.0 + uround .ne. 1.0 +! icf = integer flag for convergence failure in svnlsd.. +! 0 means no failures. +! 1 means convergence failure with out of date jacobian +! (recoverable error). +! 2 means convergence failure with current jacobian or +! singular matrix (unrecoverable error). +! init = saved integer flag indicating whether initialization of the +! problem has been done (init = 1) or not. +! ipup = saved flag to signal updating of newton matrix. +! jcur = output flag from svjac showing jacobian status.. +! jcur = 0 means j is not current. +! jcur = 1 means j is current. +! jstart = integer flag used as input to svstep.. +! 0 means perform the first step. +! 1 means take a new step continuing from the last. +! -1 means take the next step with a new value of maxord, +! hmin, hmxi, n, meth, miter, and/or matrix parameters. +! on return, svstep sets jstart = 1. +! jsv = integer flag for jacobian saving, = sign(mf). +! kflag = a completion code from svstep with the following meanings.. +! 0 the step was succesful. +! -1 the requested error could not be achieved. +! -2 corrector convergence could not be achieved. +! -3, -4 fatal error in vnls (can not occur here). +! kuth = input flag to svstep showing whether h was reduced by the +! driver. kuth = 1 if h was reduced, = 0 otherwise. +! l = integer variable, nq + 1, current order plus one. +! lmax = maxord + 1 (used for dimensioning). +! locjs = a pointer to the saved jacobian, whose storage starts at +! wm(locjs), if jsv = 1. +! lyh, lewt, lacor, lsavf, lwm, liwm = saved integer pointers +! to segments of rwork and iwork. +! maxord = the maximum order of integration method to be allowed. +! meth/miter = the method flags. see mf. +! msbj = the maximum number of steps between j evaluations, = 50. +! mxhnil = saved value of optional input mxhnil. +! mxstep = saved value of optional input mxstep. +! n = the number of first-order odes, = neq. +! newh = saved integer to flag change of h. +! newq = the method order to be used on the next step. +! nhnil = saved counter for occurrences of t + h = t. +! nq = integer variable, the current integration method order. +! nqnyh = saved value of nq*nyh. +! nqwait = a counter controlling the frequency of order changes. +! an order change is about to be considered if nqwait = 1. +! nslj = the number of steps taken as of the last jacobian update. +! nslp = saved value of nst as of last newton matrix update. +! nyh = saved value of the initial value of neq. +! hu = the step size in t last used. +! ncfn = number of nonlinear convergence failures so far. +! netf = the number of error test failures of the integrator so far. +! nfe = the number of f evaluations for the problem so far. +! nje = the number of jacobian evaluations so far. +! nlu = the number of matrix lu decompositions so far. +! nni = number of nonlinear iterations so far. +! nqu = the method order last used. +! nst = the number of steps taken for the problem so far. +!----------------------------------------------------------------------- + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data mord(1) /12/, mord(2) /5/, mxstp0 /500/, mxhnl0 /10/ + data zero /0.0e0/, one /1.0e0/, two /2.0e0/, four /4.0e0/, & + pt2 /0.2e0/, hun /100.0e0/ +!----------------------------------------------------------------------- +! block a. +! this code block is executed on every call. +! it tests istate and itask for legality and branches appropriately. +! if istate .gt. 1 but the flag init shows that initialization has +! not yet been done, an error return occurs. +! if istate = 1 and tout = t, return immediately. +!----------------------------------------------------------------------- + if (istate .lt. 1 .or. istate .gt. 3) go to 601 + if (itask .lt. 1 .or. itask .gt. 5) go to 602 + if (istate .eq. 1) go to 10 + if (init .ne. 1) go to 603 + if (istate .eq. 2) go to 200 + go to 20 + 10 init = 0 + if (tout .eq. t) return +!----------------------------------------------------------------------- +! block b. +! the next code block is executed for the initial call (istate = 1), +! or for a continuation call with parameter changes (istate = 3). +! it contains checking of all input and various initializations. +! +! first check legality of the non-optional input neq, itol, iopt, +! mf, ml, and mu. +!----------------------------------------------------------------------- + 20 if (neq .le. 0) go to 604 + if (istate .eq. 1) go to 25 + if (neq .gt. n) go to 605 + 25 n = neq + if (itol .lt. 1 .or. itol .gt. 4) go to 606 + if (iopt .lt. 0 .or. iopt .gt. 1) go to 607 + jsv = sign(1,mf) + mfa = abs(mf) + meth = mfa/10 + miter = mfa - 10*meth + if (meth .lt. 1 .or. meth .gt. 2) go to 608 + if (miter .lt. 0 .or. miter .gt. 5) go to 608 + if (miter .le. 3) go to 30 + ml = iwork(1) + mu = iwork(2) + if (ml .lt. 0 .or. ml .ge. n) go to 609 + if (mu .lt. 0 .or. mu .ge. n) go to 610 + 30 continue +! next process and check the optional input. --------------------------- + if (iopt .eq. 1) go to 40 + maxord = mord(meth) + mxstep = mxstp0 + mxhnil = mxhnl0 + if (istate .eq. 1) h0 = zero + hmxi = zero + hmin = zero + go to 60 + 40 maxord = iwork(5) + if (maxord .lt. 0) go to 611 + if (maxord .eq. 0) maxord = 100 + maxord = min(maxord,mord(meth)) + mxstep = iwork(6) + if (mxstep .lt. 0) go to 612 + if (mxstep .eq. 0) mxstep = mxstp0 + mxhnil = iwork(7) + if (mxhnil .lt. 0) go to 613 + if (mxhnil .eq. 0) mxhnil = mxhnl0 + if (istate .ne. 1) go to 50 + h0 = rwork(5) + if ((tout - t)*h0 .lt. zero) go to 614 + 50 hmax = rwork(6) + if (hmax .lt. zero) go to 615 + hmxi = zero + if (hmax .gt. zero) hmxi = one/hmax + hmin = rwork(7) + if (hmin .lt. zero) go to 616 +!----------------------------------------------------------------------- +! set work array pointers and check lengths lrw and liw. +! pointers to segments of rwork and iwork are named by prefixing l to +! the name of the segment. e.g., the segment yh starts at rwork(lyh). +! segments of rwork (in order) are denoted yh, wm, ewt, savf, acor. +! within wm, locjs is the location of the saved jacobian (jsv .gt. 0). +!----------------------------------------------------------------------- + 60 lyh = 21 + if (istate .eq. 1) nyh = n + lwm = lyh + (maxord + 1)*nyh + jco = max(0,jsv) + if (miter .eq. 0) lenwm = 0 + if (miter .eq. 1 .or. miter .eq. 2) then + lenwm = 2 + (1 + jco)*n*n + locjs = n*n + 3 + endif + if (miter .eq. 3) lenwm = 2 + n + if (miter .eq. 4 .or. miter .eq. 5) then + mband = ml + mu + 1 + lenp = (mband + ml)*n + lenj = mband*n + lenwm = 2 + lenp + jco*lenj + locjs = lenp + 3 + endif + lewt = lwm + lenwm + lsavf = lewt + n + lacor = lsavf + n + lenrw = lacor + n - 1 + iwork(17) = lenrw + liwm = 1 + leniw = 30 + n + if (miter .eq. 0 .or. miter .eq. 3) leniw = 30 + iwork(18) = leniw + if (lenrw .gt. lrw) go to 617 + if (leniw .gt. liw) go to 618 +! check rtol and atol for legality. ------------------------------------ + rtoli = rtol(1) + atoli = atol(1) + do 70 i = 1,n + if (itol .ge. 3) rtoli = rtol(i) + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + if (rtoli .lt. zero) go to 619 + if (atoli .lt. zero) go to 620 + 70 continue + if (istate .eq. 1) go to 100 +! if istate = 3, set flag to signal parameter changes to svstep. ------- + jstart = -1 + if (nq .le. maxord) go to 90 +! maxord was reduced below nq. copy yh(*,maxord+2) into savf. --------- + call scopy (n, rwork(lwm), 1, rwork(lsavf), 1) +! reload wm(1) = rwork(lwm), since lwm may have changed. --------------- + 90 if (miter .gt. 0) rwork(lwm) = sqrt(uround) +!----------------------------------------------------------------------- +! block c. +! the next block is for the initial call only (istate = 1). +! it contains all remaining initializations, the initial call to f, +! and the calculation of the initial step size. +! the error weights in ewt are inverted after being loaded. +!----------------------------------------------------------------------- + 100 uround = r1mach(4) + tn = t + if (itask .ne. 4 .and. itask .ne. 5) go to 110 + tcrit = rwork(1) + if ((tcrit - tout)*(tout - t) .lt. zero) go to 625 + if (h0 .ne. zero .and. (t + h0 - tcrit)*h0 .gt. zero) & + h0 = tcrit - t + 110 jstart = 0 + if (miter .gt. 0) rwork(lwm) = sqrt(uround) + ccmxj = pt2 + msbj = 50 + nhnil = 0 + nst = 0 + nje = 0 + nni = 0 + ncfn = 0 + netf = 0 + nlu = 0 + nslj = 0 + nslast = 0 + hu = zero + nqu = 0 +! initial call to f. (lf0 points to yh(*,2).) ------------------------- + lf0 = lyh + nyh + call f (n, t, y, rwork(lf0), rpar, ipar) + nfe = 1 +! load the initial value vector in yh. --------------------------------- + call scopy (n, y, 1, rwork(lyh), 1) +! load and invert the ewt array. (h is temporarily set to 1.0.) ------- + nq = 1 + h = one + call sewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 120 i = 1,n + if (rwork(i+lewt-1) .le. zero) go to 621 + 120 rwork(i+lewt-1) = one/rwork(i+lewt-1) + if (h0 .ne. zero) go to 180 +! call svhin to set initial step size h0 to be attempted. -------------- + call svhin (n, t, rwork(lyh), rwork(lf0), f, rpar, ipar, tout, & + uround, rwork(lewt), itol, atol, y, rwork(lacor), h0, & + niter, ier) + nfe = nfe + niter + if (ier .ne. 0) go to 622 +! adjust h0 if necessary to meet hmax bound. --------------------------- + 180 rh = abs(h0)*hmxi + if (rh .gt. one) h0 = h0/rh +! load h with h0 and scale yh(*,2) by h0. ------------------------------ + h = h0 + call sscal (n, h0, rwork(lf0), 1) + go to 270 +!----------------------------------------------------------------------- +! block d. +! the next code block is for continuation calls only (istate = 2 or 3) +! and is to check stop conditions before taking a step. +!----------------------------------------------------------------------- + 200 nslast = nst + kuth = 0 + go to (210, 250, 220, 230, 240), itask + 210 if ((tn - tout)*h .lt. zero) go to 250 + call svindy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 220 tp = tn - hu*(one + hun*uround) + if ((tp - tout)*h .gt. zero) go to 623 + if ((tn - tout)*h .lt. zero) go to 250 + go to 400 + 230 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. zero) go to 624 + if ((tcrit - tout)*h .lt. zero) go to 625 + if ((tn - tout)*h .lt. zero) go to 245 + call svindy (tout, 0, rwork(lyh), nyh, y, iflag) + if (iflag .ne. 0) go to 627 + t = tout + go to 420 + 240 tcrit = rwork(1) + if ((tn - tcrit)*h .gt. zero) go to 624 + 245 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx + if (ihit) go to 400 + tnext = tn + hnew*(one + four*uround) + if ((tnext - tcrit)*h .le. zero) go to 250 + h = (tcrit - tn)*(one - four*uround) + kuth = 1 +!----------------------------------------------------------------------- +! block e. +! the next block is normally executed for all calls and contains +! the call to the one-step core integrator svstep. +! +! this is a looping point for the integration steps. +! +! first check for too many steps being taken, update ewt (if not at +! start of problem), check for too much accuracy being requested, and +! check for h below the roundoff level in t. +!----------------------------------------------------------------------- + 250 continue + if ((nst-nslast) .ge. mxstep) go to 500 + call sewset (n, itol, rtol, atol, rwork(lyh), rwork(lewt)) + do 260 i = 1,n + if (rwork(i+lewt-1) .le. zero) go to 510 + 260 rwork(i+lewt-1) = one/rwork(i+lewt-1) + 270 tolsf = uround*svnorm (n, rwork(lyh), rwork(lewt)) + if (tolsf .le. one) go to 280 + tolsf = tolsf*two + if (nst .eq. 0) go to 626 + go to 520 + 280 if ((tn + h) .ne. tn) go to 290 + nhnil = nhnil + 1 + if (nhnil .gt. mxhnil) go to 290 + msg = 'svode-- warning..internal t (=r1) and h (=r2) are' + call xerrwv (msg, 50, 101, 1, 0, 0, 0, 0, zero, zero) + msg=' such that in the machine, t + h = t on the next step ' + call xerrwv (msg, 60, 101, 1, 0, 0, 0, 0, zero, zero) + msg = ' (h = step size). solver will continue anyway' + call xerrwv (msg, 50, 101, 1, 0, 0, 0, 2, tn, h) + if (nhnil .lt. mxhnil) go to 290 + msg = 'svode-- above warning has been issued i1 times. ' + call xerrwv (msg, 50, 102, 1, 0, 0, 0, 0, zero, zero) + msg = ' it will not be issued again for this problem' + call xerrwv (msg, 50, 102, 1, 1, mxhnil, 0, 0, zero, zero) + 290 continue +!----------------------------------------------------------------------- +! call svstep (y, yh, nyh, yh, ewt, savf, vsav, acor, +! wm, iwm, f, jac, f, svnlsd, rpar, ipar) +!----------------------------------------------------------------------- + call svstep (y, rwork(lyh), nyh, rwork(lyh), rwork(lewt), & + rwork(lsavf), y, rwork(lacor), rwork(lwm), iwork(liwm), & + f, jac, f, svnlsd, rpar, ipar) + kgo = 1 - kflag +! branch on kflag. note..in this version, kflag can not be set to -3. +! kflag .eq. 0, -1, -2 + go to (300, 530, 540), kgo +!----------------------------------------------------------------------- +! block f. +! the following block handles the case of a successful return from the +! core integrator (kflag = 0). test for stop conditions. +!----------------------------------------------------------------------- + 300 init = 1 + kuth = 0 + go to (310, 400, 330, 340, 350), itask +! itask = 1. if tout has been reached, interpolate. ------------------- + 310 if ((tn - tout)*h .lt. zero) go to 250 + call svindy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 +! itask = 3. jump to exit if tout was reached. ------------------------ + 330 if ((tn - tout)*h .ge. zero) go to 400 + go to 250 +! itask = 4. see if tout or tcrit was reached. adjust h if necessary. + 340 if ((tn - tout)*h .lt. zero) go to 345 + call svindy (tout, 0, rwork(lyh), nyh, y, iflag) + t = tout + go to 420 + 345 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx + if (ihit) go to 400 + tnext = tn + hnew*(one + four*uround) + if ((tnext - tcrit)*h .le. zero) go to 250 + h = (tcrit - tn)*(one - four*uround) + kuth = 1 + go to 250 +! itask = 5. see if tcrit was reached and jump to exit. --------------- + 350 hmx = abs(tn) + abs(h) + ihit = abs(tn - tcrit) .le. hun*uround*hmx +!----------------------------------------------------------------------- +! block g. +! the following block handles all successful returns from svode. +! if itask .ne. 1, y is loaded from yh and t is set accordingly. +! istate is set to 2, and the optional output is loaded into the work +! arrays before returning. +!----------------------------------------------------------------------- + 400 continue + call scopy (n, rwork(lyh), 1, y, 1) + t = tn + if (itask .ne. 4 .and. itask .ne. 5) go to 420 + if (ihit) t = tcrit + 420 istate = 2 + rwork(11) = hu + rwork(12) = hnew + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = newq + iwork(19) = nlu + iwork(20) = nni + iwork(21) = ncfn + iwork(22) = netf + return +!----------------------------------------------------------------------- +! block h. +! the following block handles all unsuccessful returns other than +! those for illegal input. first the error message routine is called. +! if there was an error test or convergence test failure, imxer is set. +! then y is loaded from yh, and t is set to tn. +! the optional output is loaded into the work arrays before returning. +!----------------------------------------------------------------------- +! the maximum number of steps was taken before reaching tout. ---------- + 500 msg = 'svode-- at current t (=r1), mxstep (=i1) steps ' + call xerrwv (msg, 50, 201, 1, 0, 0, 0, 0, zero, zero) + msg = ' taken on this call before reaching tout ' + call xerrwv (msg, 50, 201, 1, 1, mxstep, 0, 1, tn, zero) + istate = -1 + go to 580 +! ewt(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 ewti = rwork(lewt+i-1) + msg = 'svode-- at t (=r1), ewt(i1) has become r2 .le. 0.' + call xerrwv (msg, 50, 202, 1, 1, i, 0, 2, tn, ewti) + istate = -6 + go to 580 +! too much accuracy requested for machine precision. ------------------- + 520 msg = 'svode-- at t (=r1), too much accuracy requested ' + call xerrwv (msg, 50, 203, 1, 0, 0, 0, 0, zero, zero) + msg = ' for precision of machine.. see tolsf (=r2) ' + call xerrwv (msg, 50, 203, 1, 0, 0, 0, 2, tn, tolsf) + rwork(14) = tolsf + istate = -2 + go to 580 +! kflag = -1. error test failed repeatedly or with abs(h) = hmin. ----- + 530 msg = 'svode-- at t(=r1) and step size h(=r2), the error' + call xerrwv (msg, 50, 204, 1, 0, 0, 0, 0, zero, zero) + msg = ' test failed repeatedly or with abs(h) = hmin' + call xerrwv (msg, 50, 204, 1, 0, 0, 0, 2, tn, h) + istate = -4 + go to 560 +! kflag = -2. convergence failed repeatedly or with abs(h) = hmin. ---- + 540 msg = 'svode-- at t (=r1) and step size h (=r2), the ' + call xerrwv (msg, 50, 205, 1, 0, 0, 0, 0, zero, zero) + msg = ' corrector convergence failed repeatedly ' + call xerrwv (msg, 50, 205, 1, 0, 0, 0, 0, zero, zero) + msg = ' or with abs(h) = hmin ' + call xerrwv (msg, 30, 205, 1, 0, 0, 0, 2, tn, h) + istate = -5 +! compute imxer if relevant. ------------------------------------------- + 560 big = zero + imxer = 1 + do 570 i = 1,n + size = abs(rwork(i+lacor-1)*rwork(i+lewt-1)) + if (big .ge. size) go to 570 + big = size + imxer = i + 570 continue + iwork(16) = imxer +! set y vector, t, and optional output. -------------------------------- + 580 continue + call scopy (n, rwork(lyh), 1, y, 1) + t = tn + rwork(11) = hu + rwork(12) = h + rwork(13) = tn + iwork(11) = nst + iwork(12) = nfe + iwork(13) = nje + iwork(14) = nqu + iwork(15) = nq + iwork(19) = nlu + iwork(20) = nni + iwork(21) = ncfn + iwork(22) = netf + return +!----------------------------------------------------------------------- +! block i. +! the following block handles all error returns due to illegal input +! (istate = -3), as detected before calling the core integrator. +! first the error message routine is called. if the illegal input +! is a negative istate, the run is aborted (apparent infinite loop). +!----------------------------------------------------------------------- + 601 msg = 'svode-- istate (=i1) illegal ' + call xerrwv (msg, 30, 1, 1, 1, istate, 0, 0, zero, zero) + if (istate .lt. 0) go to 800 + go to 700 + 602 msg = 'svode-- itask (=i1) illegal ' + call xerrwv (msg, 30, 2, 1, 1, itask, 0, 0, zero, zero) + go to 700 + 603 msg='svode-- istate (=i1) .gt. 1 but svode not initialized ' + call xerrwv (msg, 60, 3, 1, 1, istate, 0, 0, zero, zero) + go to 700 + 604 msg = 'svode-- neq (=i1) .lt. 1 ' + call xerrwv (msg, 30, 4, 1, 1, neq, 0, 0, zero, zero) + go to 700 + 605 msg = 'svode-- istate = 3 and neq increased (i1 to i2) ' + call xerrwv (msg, 50, 5, 1, 2, n, neq, 0, zero, zero) + go to 700 + 606 msg = 'svode-- itol (=i1) illegal ' + call xerrwv (msg, 30, 6, 1, 1, itol, 0, 0, zero, zero) + go to 700 + 607 msg = 'svode-- iopt (=i1) illegal ' + call xerrwv (msg, 30, 7, 1, 1, iopt, 0, 0, zero, zero) + go to 700 + 608 msg = 'svode-- mf (=i1) illegal ' + call xerrwv (msg, 30, 8, 1, 1, mf, 0, 0, zero, zero) + go to 700 + 609 msg = 'svode-- ml (=i1) illegal.. .lt.0 or .ge.neq (=i2)' + call xerrwv (msg, 50, 9, 1, 2, ml, neq, 0, zero, zero) + go to 700 + 610 msg = 'svode-- mu (=i1) illegal.. .lt.0 or .ge.neq (=i2)' + call xerrwv (msg, 50, 10, 1, 2, mu, neq, 0, zero, zero) + go to 700 + 611 msg = 'svode-- maxord (=i1) .lt. 0 ' + call xerrwv (msg, 30, 11, 1, 1, maxord, 0, 0, zero, zero) + go to 700 + 612 msg = 'svode-- mxstep (=i1) .lt. 0 ' + call xerrwv (msg, 30, 12, 1, 1, mxstep, 0, 0, zero, zero) + go to 700 + 613 msg = 'svode-- mxhnil (=i1) .lt. 0 ' + call xerrwv (msg, 30, 13, 1, 1, mxhnil, 0, 0, zero, zero) + go to 700 + 614 msg = 'svode-- tout (=r1) behind t (=r2) ' + call xerrwv (msg, 40, 14, 1, 0, 0, 0, 2, tout, t) + msg = ' integration direction is given by h0 (=r1) ' + call xerrwv (msg, 50, 14, 1, 0, 0, 0, 1, h0, zero) + go to 700 + 615 msg = 'svode-- hmax (=r1) .lt. 0.0 ' + call xerrwv (msg, 30, 15, 1, 0, 0, 0, 1, hmax, zero) + go to 700 + 616 msg = 'svode-- hmin (=r1) .lt. 0.0 ' + call xerrwv (msg, 30, 16, 1, 0, 0, 0, 1, hmin, zero) + go to 700 + 617 continue + msg='svode-- rwork length needed, lenrw (=i1), exceeds lrw (=i2)' + call xerrwv (msg, 60, 17, 1, 2, lenrw, lrw, 0, zero, zero) + go to 700 + 618 continue + msg='svode-- iwork length needed, leniw (=i1), exceeds liw (=i2)' + call xerrwv (msg, 60, 18, 1, 2, leniw, liw, 0, zero, zero) + go to 700 + 619 msg = 'svode-- rtol(i1) is r1 .lt. 0.0 ' + call xerrwv (msg, 40, 19, 1, 1, i, 0, 1, rtoli, zero) + go to 700 + 620 msg = 'svode-- atol(i1) is r1 .lt. 0.0 ' + call xerrwv (msg, 40, 20, 1, 1, i, 0, 1, atoli, zero) + go to 700 + 621 ewti = rwork(lewt+i-1) + msg = 'svode-- ewt(i1) is r1 .le. 0.0 ' + call xerrwv (msg, 40, 21, 1, 1, i, 0, 1, ewti, zero) + go to 700 + 622 continue + msg='svode-- tout (=r1) too close to t(=r2) to start integration' + call xerrwv (msg, 60, 22, 1, 0, 0, 0, 2, tout, t) + go to 700 + 623 continue + msg='svode-- itask = i1 and tout (=r1) behind tcur - hu (= r2) ' + call xerrwv (msg, 60, 23, 1, 1, itask, 0, 2, tout, tp) + go to 700 + 624 continue + msg='svode-- itask = 4 or 5 and tcrit (=r1) behind tcur (=r2) ' + call xerrwv (msg, 60, 24, 1, 0, 0, 0, 2, tcrit, tn) + go to 700 + 625 continue + msg='svode-- itask = 4 or 5 and tcrit (=r1) behind tout (=r2) ' + call xerrwv (msg, 60, 25, 1, 0, 0, 0, 2, tcrit, tout) + go to 700 + 626 msg = 'svode-- at start of problem, too much accuracy ' + call xerrwv (msg, 50, 26, 1, 0, 0, 0, 0, zero, zero) + msg=' requested for precision of machine.. see tolsf (=r1) ' + call xerrwv (msg, 60, 26, 1, 0, 0, 0, 1, tolsf, zero) + rwork(14) = tolsf + go to 700 + 627 msg='svode-- trouble from svindy. itask = i1, tout = r1. ' + call xerrwv (msg, 60, 27, 1, 1, itask, 0, 1, tout, zero) +! + 700 continue + istate = -3 + return +! + 800 msg = 'svode-- run aborted.. apparent infinite loop ' + call xerrwv (msg, 50, 303, 2, 0, 0, 0, 0, zero, zero) + return +!----------------------- end of subroutine svode ----------------------- + end subroutine svode +!*deck svhin + subroutine svhin (n, t0, y0, ydot, f, rpar, ipar, tout, uround, & + ewt, itol, atol, y, temp, h0, niter, ier) + external f + real t0, y0, ydot, rpar, tout, uround, ewt, atol, y, & + temp, h0 + integer n, ipar, itol, niter, ier + dimension y0(*), ydot(*), ewt(*), atol(*), y(*), & + temp(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- n, t0, y0, ydot, f, rpar, ipar, tout, uround, +! ewt, itol, atol, y, temp +! call sequence output -- h0, niter, ier +! common block variables accessed -- none +! +! subroutines called by svhin.. f +! function routines called by svhin.. svnorm +!----------------------------------------------------------------------- +! this routine computes the step size, h0, to be attempted on the +! first step, when the user has not supplied a value for this. +! +! first we check that tout - t0 differs significantly from zero. then +! an iteration is done to approximate the initial second derivative +! and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. +! a bias factor of 1/2 is applied to the resulting h. +! the sign of h0 is inferred from the initial values of tout and t0. +! +! communication with svhin is done with the following variables.. +! +! n = size of ode system, input. +! t0 = initial value of independent variable, input. +! y0 = vector of initial conditions, input. +! ydot = vector of initial first derivatives, input. +! f = name of subroutine for right-hand side f(t,y), input. +! rpar, ipar = dummy names for user's real and integer work arrays. +! tout = first output value of independent variable +! uround = machine unit roundoff +! ewt, itol, atol = error weights and tolerance parameters +! as described in the driver routine, input. +! y, temp = work arrays of length n. +! h0 = step size to be attempted, output. +! niter = number of iterations (and of f evaluations) to compute h0, +! output. +! ier = the error flag, returned with the value +! ier = 0 if no trouble occurred, or +! ier = -1 if tout and t0 are considered too close to proceed. +!----------------------------------------------------------------------- +! +! type declarations for local variables -------------------------------- +! + real afi, atoli, delyi, h, half, hg, hlb, hnew, hrat, & + hub, hun, pt1, t1, tdist, tround, two, yddnrm + integer i, iter +! +! type declaration for function subroutines called --------------------- +! +! real svnorm ! rce 2005-jan-21 - module conversion +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save half, hun, pt1, two + data half /0.5e0/, hun /100.0e0/, pt1 /0.1e0/, two /2.0e0/ +! + niter = 0 + tdist = abs(tout - t0) + tround = uround*max(abs(t0),abs(tout)) + if (tdist .lt. two*tround) go to 100 +! +! set a lower bound on h based on the roundoff level in t0 and tout. --- + hlb = hun*tround +! set an upper bound on h based on tout-t0 and the initial y and ydot. - + hub = pt1*tdist + atoli = atol(1) + do 10 i = 1, n + if (itol .eq. 2 .or. itol .eq. 4) atoli = atol(i) + delyi = pt1*abs(y0(i)) + atoli + afi = abs(ydot(i)) + if (afi*hub .gt. delyi) hub = delyi/afi + 10 continue +! +! set initial guess for h as geometric mean of upper and lower bounds. - + iter = 0 + hg = sqrt(hlb*hub) +! if the bounds have crossed, exit with the mean value. ---------------- + if (hub .lt. hlb) then + h0 = hg + go to 90 + endif +! +! looping point for iteration. ----------------------------------------- + 50 continue +! estimate the second derivative as a difference quotient in f. -------- + h = sign (hg, tout - t0) + t1 = t0 + h + do 60 i = 1, n + 60 y(i) = y0(i) + h*ydot(i) + call f (n, t1, y, temp, rpar, ipar) + do 70 i = 1, n + 70 temp(i) = (temp(i) - ydot(i))/h + yddnrm = svnorm (n, temp, ewt) +! get the corresponding new value of h. -------------------------------- + if (yddnrm*hub*hub .gt. two) then + hnew = sqrt(two/yddnrm) + else + hnew = sqrt(hg*hub) + endif + iter = iter + 1 +!----------------------------------------------------------------------- +! test the stopping conditions. +! stop if the new and previous h values differ by a factor of .lt. 2. +! stop if four iterations have been done. also, stop with previous h +! if hnew/hg .gt. 2 after first iteration, as this probably means that +! the second derivative value is bad because of cancellation error. +!----------------------------------------------------------------------- + if (iter .ge. 4) go to 80 + hrat = hnew/hg + if ( (hrat .gt. half) .and. (hrat .lt. two) ) go to 80 + if ( (iter .ge. 2) .and. (hnew .gt. two*hg) ) then + hnew = hg + go to 80 + endif + hg = hnew + go to 50 +! +! iteration done. apply bounds, bias factor, and sign. then exit. ---- + 80 h0 = hnew*half + if (h0 .lt. hlb) h0 = hlb + if (h0 .gt. hub) h0 = hub + 90 h0 = sign(h0, tout - t0) + niter = iter + ier = 0 + return +! error return for tout - t0 too small. -------------------------------- + 100 ier = -1 + return +!----------------------- end of subroutine svhin ----------------------- + end subroutine svhin +!*deck svindy + subroutine svindy (t, k, yh, ldyh, dky, iflag) + real t, yh, dky + integer k, ldyh, iflag + dimension yh(ldyh,*), dky(*) +!----------------------------------------------------------------------- +! call sequence input -- t, k, yh, ldyh +! call sequence output -- dky, iflag +! common block variables accessed.. +! /svode_cmn_01/ -- h, tn, uround, l, n, nq +! /svode_cmn_02/ -- hu +! +! subroutines called by svindy.. sscal, xerrwv +! function routines called by svindy.. none +!----------------------------------------------------------------------- +! svindy computes interpolated values of the k-th derivative of the +! dependent variable vector y, and stores it in dky. this routine +! is called within the package with k = 0 and t = tout, but may +! also be called by the user for any k up to the current order. +! (see detailed instructions in the usage documentation.) +!----------------------------------------------------------------------- +! the computed values in dky are gotten by interpolation using the +! nordsieck history array yh. this array corresponds uniquely to a +! vector-valued polynomial of degree nqcur or less, and dky is set +! to the k-th derivative of this polynomial at t. +! the formula for dky is.. +! q +! dky(i) = sum c(j,k) * (t - tn)**(j-k) * h**(-j) * yh(i,j+1) +! j=k +! where c(j,k) = j*(j-1)*...*(j-k+1), q = nqcur, tn = tcur, h = hcur. +! the quantities nq = nqcur, l = nq+1, n, tn, and h are +! communicated by common. the above sum is done in reverse order. +! iflag is returned negative if either k or t is out of bounds. +! +! discussion above and comments in driver explain all variables. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block svode_cmn_02 -------------------- +! + real hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + real c, hun, r, s, tfuzz, tn1, tp, zero + integer i, ic, j, jb, jb2, jj, jj1, jp1 + character*80 msg +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save hun, zero +! + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data hun /100.0e0/, zero /0.0e0/ +! + iflag = 0 + if (k .lt. 0 .or. k .gt. nq) go to 80 + tfuzz = hun*uround*(tn + hu) + tp = tn - hu - tfuzz + tn1 = tn + tfuzz + if ((t-tp)*(t-tn1) .gt. zero) go to 90 +! + s = (t - tn)/h + ic = 1 + if (k .eq. 0) go to 15 + jj1 = l - k + do 10 jj = jj1, nq + 10 ic = ic*jj + 15 c = real(ic) + do 20 i = 1, n + 20 dky(i) = c*yh(i,l) + if (k .eq. nq) go to 55 + jb2 = nq - k + do 50 jb = 1, jb2 + j = nq - jb + jp1 = j + 1 + ic = 1 + if (k .eq. 0) go to 35 + jj1 = jp1 - k + do 30 jj = jj1, j + 30 ic = ic*jj + 35 c = real(ic) + do 40 i = 1, n + 40 dky(i) = c*yh(i,jp1) + s*dky(i) + 50 continue + if (k .eq. 0) return + 55 r = h**(-k) + call sscal (n, r, dky, 1) + return +! + 80 msg = 'svindy-- k (=i1) illegal ' + call xerrwv (msg, 30, 51, 1, 1, k, 0, 0, zero, zero) + iflag = -1 + return + 90 msg = 'svindy-- t (=r1) illegal ' + call xerrwv (msg, 30, 52, 1, 0, 0, 0, 1, t, zero) + msg=' t not in interval tcur - hu (= r1) to tcur (=r2) ' + call xerrwv (msg, 60, 52, 1, 0, 0, 0, 2, tp, tn) + iflag = -2 + return +!----------------------- end of subroutine svindy ---------------------- + end subroutine svindy +!*deck svstep + subroutine svstep (y, yh, ldyh, yh1, ewt, savf, vsav, acor, & + wm, iwm, f, jac, psol, vnls, rpar, ipar) + external f, jac, psol, vnls + real y, yh, yh1, ewt, savf, vsav, acor, wm, rpar + integer ldyh, iwm, ipar + dimension y(*), yh(ldyh,*), yh1(*), ewt(*), savf(*), vsav(*), & + acor(*), wm(*), iwm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, yh1, ewt, savf, vsav, +! acor, wm, iwm, f, jac, psol, vnls, rpar, ipar +! call sequence output -- yh, acor, wm, iwm +! common block variables accessed.. +! /svode_cmn_01/ acnrm, el(13), h, hmin, hmxi, hnew, hscal, rc, tau(13), +! tq(5), tn, jcur, jstart, kflag, kuth, +! l, lmax, maxord, n, newq, nq, nqwait +! /svode_cmn_02/ hu, ncfn, netf, nfe, nqu, nst +! +! subroutines called by svstep.. f, saxpy, scopy, sscal, +! svjust, vnls, svset +! function routines called by svstep.. svnorm +!----------------------------------------------------------------------- +! svstep performs one step of the integration of an initial value +! problem for a system of ordinary differential equations. +! svstep calls subroutine vnls for the solution of the nonlinear system +! arising in the time step. thus it is independent of the problem +! jacobian structure and the type of nonlinear system solution method. +! svstep returns a completion flag kflag (in common). +! a return with kflag = -1 or -2 means either abs(h) = hmin or 10 +! consecutive failures occurred. on a return with kflag negative, +! the values of tn and the yh array are as of the beginning of the last +! step, and h is the last step size attempted. +! +! communication with svstep is done with the following variables.. +! +! y = an array of length n used for the dependent variable vector. +! yh = an ldyh by lmax array containing the dependent variables +! and their approximate scaled derivatives, where +! lmax = maxord + 1. yh(i,j+1) contains the approximate +! j-th derivative of y(i), scaled by h**j/factorial(j) +! (j = 0,1,...,nq). on entry for the first step, the first +! two columns of yh must be set from the initial values. +! ldyh = a constant integer .ge. n, the first dimension of yh. +! n is the number of odes in the system. +! yh1 = a one-dimensional array occupying the same space as yh. +! ewt = an array of length n containing multiplicative weights +! for local error measurements. local errors in y(i) are +! compared to 1.0/ewt(i) in various error tests. +! savf = an array of working storage, of length n. +! also used for input of yh(*,maxord+2) when jstart = -1 +! and maxord .lt. the current order nq. +! vsav = a work array of length n passed to subroutine vnls. +! acor = a work array of length n, used for the accumulated +! corrections. on a successful return, acor(i) contains +! the estimated one-step local error in y(i). +! wm,iwm = real and integer work arrays associated with matrix +! operations in vnls. +! f = dummy name for the user supplied subroutine for f. +! jac = dummy name for the user supplied jacobian subroutine. +! psol = dummy name for the subroutine passed to vnls, for +! possible use there. +! vnls = dummy name for the nonlinear system solving subroutine, +! whose real name is dependent on the method used. +! rpar, ipar = dummy names for user's real and integer work arrays. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block svode_cmn_02 -------------------- +! + real hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + real addon, bias1,bias2,bias3, cnquot, ddn, dsm, dup, & + etacf, etamin, etamx1, etamx2, etamx3, etamxf, & + etaq, etaqm1, etaqp1, flotl, one, onepsm, & + r, thresh, told, zero + integer i, i1, i2, iback, j, jb, kfc, kfh, mxncf, ncf, nflag +! +! type declaration for function subroutines called --------------------- +! +! real svnorm ! rce 2005-jan-21 - module conversion +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save addon, bias1, bias2, bias3, & + etacf, etamin, etamx1, etamx2, etamx3, etamxf, etaq, etaqm1, & + kfc, kfh, mxncf, onepsm, thresh, one, zero +!----------------------------------------------------------------------- + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data kfc/-3/, kfh/-7/, mxncf/10/ + data addon /1.0e-6/, bias1 /6.0e0/, bias2 /6.0e0/, & + bias3 /10.0e0/, etacf /0.25e0/, etamin /0.1e0/, & + etamxf /0.2e0/, etamx1 /1.0e4/, etamx2 /10.0e0/, & + etamx3 /10.0e0/, onepsm /1.00001e0/, thresh /1.5e0/ + data one/1.0e0/, zero/0.0e0/ +! + kflag = 0 + told = tn + ncf = 0 + jcur = 0 + nflag = 0 + if (jstart .gt. 0) go to 20 + if (jstart .eq. -1) go to 100 +!----------------------------------------------------------------------- +! on the first call, the order is set to 1, and other variables are +! initialized. etamax is the maximum ratio by which h can be increased +! in a single step. it is normally 10, but is larger during the +! first step to compensate for the small initial h. if a failure +! occurs (in corrector convergence or error test), etamax is set to 1 +! for the next increase. +!----------------------------------------------------------------------- + lmax = maxord + 1 + nq = 1 + l = 2 + nqnyh = nq*ldyh + tau(1) = h + prl1 = one + rc = zero + etamax = etamx1 + nqwait = 2 + hscal = h + go to 200 +!----------------------------------------------------------------------- +! take preliminary actions on a normal continuation step (jstart.gt.0). +! if the driver changed h, then eta must be reset and newh set to 1. +! if a change of order was dictated on the previous step, then +! it is done here and appropriate adjustments in the history are made. +! on an order decrease, the history array is adjusted by svjust. +! on an order increase, the history array is augmented by a column. +! on a change of step size h, the history array yh is rescaled. +!----------------------------------------------------------------------- + 20 continue + if (kuth .eq. 1) then + eta = min(eta,h/hscal) + newh = 1 + endif + 50 if (newh .eq. 0) go to 200 + if (newq .eq. nq) go to 150 + if (newq .lt. nq) then + call svjust (yh, ldyh, -1) + nq = newq + l = nq + 1 + nqwait = l + go to 150 + endif + if (newq .gt. nq) then + call svjust (yh, ldyh, 1) + nq = newq + l = nq + 1 + nqwait = l + go to 150 + endif +!----------------------------------------------------------------------- +! the following block handles preliminaries needed when jstart = -1. +! if n was reduced, zero out part of yh to avoid undefined references. +! if maxord was reduced to a value less than the tentative order newq, +! then nq is set to maxord, and a new h ratio eta is chosen. +! otherwise, we take the same preliminary actions as for jstart .gt. 0. +! in any case, nqwait is reset to l = nq + 1 to prevent further +! changes in order for that many steps. +! the new h ratio eta is limited by the input h if kuth = 1, +! by hmin if kuth = 0, and by hmxi in any case. +! finally, the history array yh is rescaled. +!----------------------------------------------------------------------- + 100 continue + lmax = maxord + 1 + if (n .eq. ldyh) go to 120 + i1 = 1 + (newq + 1)*ldyh + i2 = (maxord + 1)*ldyh + if (i1 .gt. i2) go to 120 + do 110 i = i1, i2 + 110 yh1(i) = zero + 120 if (newq .le. maxord) go to 140 + flotl = real(lmax) + if (maxord .lt. nq-1) then + ddn = svnorm (n, savf, ewt)/tq(1) + eta = one/((bias1*ddn)**(one/flotl) + addon) + endif + if (maxord .eq. nq .and. newq .eq. nq+1) eta = etaq + if (maxord .eq. nq-1 .and. newq .eq. nq+1) then + eta = etaqm1 + call svjust (yh, ldyh, -1) + endif + if (maxord .eq. nq-1 .and. newq .eq. nq) then + ddn = svnorm (n, savf, ewt)/tq(1) + eta = one/((bias1*ddn)**(one/flotl) + addon) + call svjust (yh, ldyh, -1) + endif + eta = min(eta,one) + nq = maxord + l = lmax + 140 if (kuth .eq. 1) eta = min(eta,abs(h/hscal)) + if (kuth .eq. 0) eta = max(eta,hmin/abs(hscal)) + eta = eta/max(one,abs(hscal)*hmxi*eta) + newh = 1 + nqwait = l + if (newq .le. maxord) go to 50 +! rescale the history array for a change in h by a factor of eta. ------ + 150 r = one + do 180 j = 2, l + r = r*eta + call sscal (n, r, yh(1,j), 1 ) + 180 continue + h = hscal*eta + hscal = h + rc = rc*eta + nqnyh = nq*ldyh +!----------------------------------------------------------------------- +! this section computes the predicted values by effectively +! multiplying the yh array by the pascal triangle matrix. +! svset is called to calculate all integration coefficients. +! rc is the ratio of new to old values of the coefficient h/el(2)=h/l1. +!----------------------------------------------------------------------- + 200 tn = tn + h + i1 = nqnyh + 1 + do 220 jb = 1, nq + i1 = i1 - ldyh + do 210 i = i1, nqnyh + 210 yh1(i) = yh1(i) + yh1(i+ldyh) + 220 continue + call svset + rl1 = one/el(2) + rc = rc*(rl1/prl1) + prl1 = rl1 +! +! call the nonlinear system solver. ------------------------------------ +! + call vnls (y, yh, ldyh, vsav, savf, ewt, acor, iwm, wm, & + f, jac, psol, nflag, rpar, ipar) +! + if (nflag .eq. 0) go to 450 +!----------------------------------------------------------------------- +! the vnls routine failed to achieve convergence (nflag .ne. 0). +! the yh array is retracted to its values before prediction. +! the step size h is reduced and the step is retried, if possible. +! otherwise, an error exit is taken. +!----------------------------------------------------------------------- + ncf = ncf + 1 + ncfn = ncfn + 1 + etamax = one + tn = told + i1 = nqnyh + 1 + do 430 jb = 1, nq + i1 = i1 - ldyh + do 420 i = i1, nqnyh + 420 yh1(i) = yh1(i) - yh1(i+ldyh) + 430 continue + if (nflag .lt. -1) go to 680 + if (abs(h) .le. hmin*onepsm) go to 670 + if (ncf .eq. mxncf) go to 670 + eta = etacf + eta = max(eta,hmin/abs(h)) + nflag = -1 + go to 150 +!----------------------------------------------------------------------- +! the corrector has converged (nflag = 0). the local error test is +! made and control passes to statement 500 if it fails. +!----------------------------------------------------------------------- + 450 continue + dsm = acnrm/tq(2) + if (dsm .gt. one) go to 500 +!----------------------------------------------------------------------- +! after a successful step, update the yh and tau arrays and decrement +! nqwait. if nqwait is then 1 and nq .lt. maxord, then acor is saved +! for use in a possible order increase on the next step. +! if etamax = 1 (a failure occurred this step), keep nqwait .ge. 2. +!----------------------------------------------------------------------- + kflag = 0 + nst = nst + 1 + hu = h + nqu = nq + do 470 iback = 1, nq + i = l - iback + 470 tau(i+1) = tau(i) + tau(1) = h + do 480 j = 1, l + call saxpy (n, el(j), acor, 1, yh(1,j), 1 ) + 480 continue + nqwait = nqwait - 1 + if ((l .eq. lmax) .or. (nqwait .ne. 1)) go to 490 + call scopy (n, acor, 1, yh(1,lmax), 1 ) + conp = tq(5) + 490 if (etamax .ne. one) go to 560 + if (nqwait .lt. 2) nqwait = 2 + newq = nq + newh = 0 + eta = one + hnew = h + go to 690 +!----------------------------------------------------------------------- +! the error test failed. kflag keeps track of multiple failures. +! restore tn and the yh array to their previous values, and prepare +! to try the step again. compute the optimum step size for the +! same order. after repeated failures, h is forced to decrease +! more rapidly. +!----------------------------------------------------------------------- + 500 kflag = kflag - 1 + netf = netf + 1 + nflag = -2 + tn = told + i1 = nqnyh + 1 + do 520 jb = 1, nq + i1 = i1 - ldyh + do 510 i = i1, nqnyh + 510 yh1(i) = yh1(i) - yh1(i+ldyh) + 520 continue + if (abs(h) .le. hmin*onepsm) go to 660 + etamax = one + if (kflag .le. kfc) go to 530 +! compute ratio of new h to current h at the current order. ------------ + flotl = real(l) + eta = one/((bias2*dsm)**(one/flotl) + addon) + eta = max(eta,hmin/abs(h),etamin) + if ((kflag .le. -2) .and. (eta .gt. etamxf)) eta = etamxf + go to 150 +!----------------------------------------------------------------------- +! control reaches this section if 3 or more consecutive failures +! have occurred. it is assumed that the elements of the yh array +! have accumulated errors of the wrong order. the order is reduced +! by one, if possible. then h is reduced by a factor of 0.1 and +! the step is retried. after a total of 7 consecutive failures, +! an exit is taken with kflag = -1. +!----------------------------------------------------------------------- + 530 if (kflag .eq. kfh) go to 660 + if (nq .eq. 1) go to 540 + eta = max(etamin,hmin/abs(h)) + call svjust (yh, ldyh, -1) + l = nq + nq = nq - 1 + nqwait = l + go to 150 + 540 eta = max(etamin,hmin/abs(h)) + h = h*eta + hscal = h + tau(1) = h + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + do 550 i = 1, n + 550 yh(i,2) = h*savf(i) + nqwait = 10 + go to 200 +!----------------------------------------------------------------------- +! if nqwait = 0, an increase or decrease in order by one is considered. +! factors etaq, etaqm1, etaqp1 are computed by which h could +! be multiplied at order q, q-1, or q+1, respectively. +! the largest of these is determined, and the new order and +! step size set accordingly. +! a change of h or nq is made only if h increases by at least a +! factor of thresh. if an order change is considered and rejected, +! then nqwait is set to 2 (reconsider it after 2 steps). +!----------------------------------------------------------------------- +! compute ratio of new h to current h at the current order. ------------ + 560 flotl = real(l) + etaq = one/((bias2*dsm)**(one/flotl) + addon) + if (nqwait .ne. 0) go to 600 + nqwait = 2 + etaqm1 = zero + if (nq .eq. 1) go to 570 +! compute ratio of new h to current h at the current order less one. --- + ddn = svnorm (n, yh(1,l), ewt)/tq(1) + etaqm1 = one/((bias1*ddn)**(one/(flotl - one)) + addon) + 570 etaqp1 = zero + if (l .eq. lmax) go to 580 +! compute ratio of new h to current h at current order plus one. ------- + cnquot = (tq(5)/conp)*(h/tau(2))**l + do 575 i = 1, n + 575 savf(i) = acor(i) - cnquot*yh(i,lmax) + dup = svnorm (n, savf, ewt)/tq(3) + etaqp1 = one/((bias3*dup)**(one/(flotl + one)) + addon) + 580 if (etaq .ge. etaqp1) go to 590 + if (etaqp1 .gt. etaqm1) go to 620 + go to 610 + 590 if (etaq .lt. etaqm1) go to 610 + 600 eta = etaq + newq = nq + go to 630 + 610 eta = etaqm1 + newq = nq - 1 + go to 630 + 620 eta = etaqp1 + newq = nq + 1 + call scopy (n, acor, 1, yh(1,lmax), 1) +! test tentative new h against thresh, etamax, and hmxi, then exit. ---- + 630 if (eta .lt. thresh .or. etamax .eq. one) go to 640 + eta = min(eta,etamax) + eta = eta/max(one,abs(h)*hmxi*eta) + newh = 1 + hnew = h*eta + go to 690 + 640 newq = nq + newh = 0 + eta = one + hnew = h + go to 690 +!----------------------------------------------------------------------- +! all returns are made through this section. +! on a successful return, etamax is reset and acor is scaled. +!----------------------------------------------------------------------- + 660 kflag = -1 + go to 720 + 670 kflag = -2 + go to 720 + 680 if (nflag .eq. -2) kflag = -3 + if (nflag .eq. -3) kflag = -4 + go to 720 + 690 etamax = etamx3 + if (nst .le. 10) etamax = etamx2 + 700 r = one/tq(2) + call sscal (n, r, acor, 1) + 720 jstart = 1 + return +!----------------------- end of subroutine svstep ---------------------- + end subroutine svstep +!*deck svset + subroutine svset +!----------------------------------------------------------------------- +! call sequence communication.. none +! common block variables accessed.. +! /svode_cmn_01/ -- el(13), h, tau(13), tq(5), l(= nq + 1), +! meth, nq, nqwait +! +! subroutines called by svset.. none +! function routines called by svset.. none +!----------------------------------------------------------------------- +! svset is called by svstep and sets coefficients for use there. +! +! for each order nq, the coefficients in el are calculated by use of +! the generating polynomial lambda(x), with coefficients el(i). +! lambda(x) = el(1) + el(2)*x + ... + el(nq+1)*(x**nq). +! for the backward differentiation formulas, +! nq-1 +! lambda(x) = (1 + x/xi*(nq)) * product (1 + x/xi(i) ) . +! i = 1 +! for the adams formulas, +! nq-1 +! (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , +! i = 1 +! lambda(-1) = 0, lambda(0) = 1, +! where c is a normalization constant. +! in both cases, xi(i) is defined by +! h*xi(i) = t sub n - t sub (n-i) +! = h + tau(1) + tau(2) + ... tau(i-1). +! +! +! in addition to variables described previously, communication +! with svset uses the following.. +! tau = a vector of length 13 containing the past nq values +! of h. +! el = a vector of length 13 in which vset stores the +! coefficients for the corrector formula. +! tq = a vector of length 5 in which vset stores constants +! used for the convergence test, the error test, and the +! selection of h at a new order. +! meth = the basic method indicator. +! nq = the current order. +! l = nq + 1, the length of the vector stored in el, and +! the number of columns of the yh array being used. +! nqwait = a counter controlling the frequency of order changes. +! an order change is about to be considered if nqwait = 1. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + real ahatn0, alph0, cnqm1, cortes, csum, elp, em, & + em0, floti, flotl, flotnq, hsum, one, rxi, rxis, s, six, & + t1, t2, t3, t4, t5, t6, two, xi, zero + integer i, iback, j, jp1, nqm1, nqm2 +! + dimension em(13) +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save cortes, one, six, two, zero +! + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data cortes /0.1e0/ + data one /1.0e0/, six /6.0e0/, two /2.0e0/, zero /0.0e0/ +! + flotl = real(l) + nqm1 = nq - 1 + nqm2 = nq - 2 + go to (100, 200), meth +! +! set coefficients for adams methods. ---------------------------------- + 100 if (nq .ne. 1) go to 110 + el(1) = one + el(2) = one + tq(1) = one + tq(2) = two + tq(3) = six*tq(2) + tq(5) = one + go to 300 + 110 hsum = h + em(1) = one + flotnq = flotl - one + do 115 i = 2, l + 115 em(i) = zero + do 150 j = 1, nqm1 + if ((j .ne. nqm1) .or. (nqwait .ne. 1)) go to 130 + s = one + csum = zero + do 120 i = 1, nqm1 + csum = csum + s*em(i)/real(i+1) + 120 s = -s + tq(1) = em(nqm1)/(flotnq*csum) + 130 rxi = h/hsum + do 140 iback = 1, j + i = (j + 2) - iback + 140 em(i) = em(i) + em(i-1)*rxi + hsum = hsum + tau(j) + 150 continue +! compute integral from -1 to 0 of polynomial and of x times it. ------- + s = one + em0 = zero + csum = zero + do 160 i = 1, nq + floti = real(i) + em0 = em0 + s*em(i)/floti + csum = csum + s*em(i)/(floti+one) + 160 s = -s +! in el, form coefficients of normalized integrated polynomial. -------- + s = one/em0 + el(1) = one + do 170 i = 1, nq + 170 el(i+1) = s*em(i)/real(i) + xi = hsum/h + tq(2) = xi*em0/csum + tq(5) = xi/el(l) + if (nqwait .ne. 1) go to 300 +! for higher order control constant, multiply polynomial by 1+x/xi(q). - + rxi = one/xi + do 180 iback = 1, nq + i = (l + 1) - iback + 180 em(i) = em(i) + em(i-1)*rxi +! compute integral of polynomial. -------------------------------------- + s = one + csum = zero + do 190 i = 1, l + csum = csum + s*em(i)/real(i+1) + 190 s = -s + tq(3) = flotl*em0/csum + go to 300 +! +! set coefficients for bdf methods. ------------------------------------ + 200 do 210 i = 3, l + 210 el(i) = zero + el(1) = one + el(2) = one + alph0 = -one + ahatn0 = -one + hsum = h + rxi = one + rxis = one + if (nq .eq. 1) go to 240 + do 230 j = 1, nqm2 +! in el, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ + hsum = hsum + tau(j) + rxi = h/hsum + jp1 = j + 1 + alph0 = alph0 - one/real(jp1) + do 220 iback = 1, jp1 + i = (j + 3) - iback + 220 el(i) = el(i) + el(i-1)*rxi + 230 continue + alph0 = alph0 - one/real(nq) + rxis = -el(2) - alph0 + hsum = hsum + tau(nqm1) + rxi = h/hsum + ahatn0 = -el(2) - rxi + do 235 iback = 1, nq + i = (nq + 2) - iback + 235 el(i) = el(i) + el(i-1)*rxis + 240 t1 = one - ahatn0 + alph0 + t2 = one + real(nq)*t1 + tq(2) = abs(alph0*t2/t1) + tq(5) = abs(t2/(el(l)*rxi/rxis)) + if (nqwait .ne. 1) go to 300 + cnqm1 = rxis/el(l) + t3 = alph0 + one/real(nq) + t4 = ahatn0 + rxi + elp = t3/(one - t4 + t3) + tq(1) = abs(elp/cnqm1) + hsum = hsum + tau(nq) + rxi = h/hsum + t5 = alph0 - one/real(nq+1) + t6 = ahatn0 - rxi + elp = t2/(one - t6 + t5) + tq(3) = abs(elp*rxi*(flotl + one)*t5) + 300 tq(4) = cortes*tq(2) + return +!----------------------- end of subroutine svset ----------------------- + end subroutine svset +!*deck svjust + subroutine svjust (yh, ldyh, iord) + real yh + integer ldyh, iord + dimension yh(ldyh,*) +!----------------------------------------------------------------------- +! call sequence input -- yh, ldyh, iord +! call sequence output -- yh +! common block input -- nq, meth, lmax, hscal, tau(13), n +! common block variables accessed.. +! /svode_cmn_01/ -- hscal, tau(13), lmax, meth, n, nq, +! +! subroutines called by svjust.. saxpy +! function routines called by svjust.. none +!----------------------------------------------------------------------- +! this subroutine adjusts the yh array on reduction of order, +! and also when the order is increased for the stiff option (meth = 2). +! communication with svjust uses the following.. +! iord = an integer flag used when meth = 2 to indicate an order +! increase (iord = +1) or an order decrease (iord = -1). +! hscal = step size h used in scaling of nordsieck array yh. +! (if iord = +1, svjust assumes that hscal = tau(1).) +! see references 1 and 2 for details. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + real alph0, alph1, hsum, one, prod, t1, xi,xiold, zero + integer i, iback, j, jp1, lp1, nqm1, nqm2, nqp1 +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save one, zero +! + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data one /1.0e0/, zero /0.0e0/ +! + if ((nq .eq. 2) .and. (iord .ne. 1)) return + nqm1 = nq - 1 + nqm2 = nq - 2 + go to (100, 200), meth +!----------------------------------------------------------------------- +! nonstiff option... +! check to see if the order is being increased or decreased. +!----------------------------------------------------------------------- + 100 continue + if (iord .eq. 1) go to 180 +! order decrease. ------------------------------------------------------ + do 110 j = 1, lmax + 110 el(j) = zero + el(2) = one + hsum = zero + do 130 j = 1, nqm2 +! construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- + hsum = hsum + tau(j) + xi = hsum/hscal + jp1 = j + 1 + do 120 iback = 1, jp1 + i = (j + 3) - iback + 120 el(i) = el(i)*xi + el(i-1) + 130 continue +! construct coefficients of integrated polynomial. --------------------- + do 140 j = 2, nqm1 + 140 el(j+1) = real(nq)*el(j)/real(j) +! subtract correction terms from yh array. ----------------------------- + do 170 j = 3, nq + do 160 i = 1, n + 160 yh(i,j) = yh(i,j) - yh(i,l)*el(j) + 170 continue + return +! order increase. ------------------------------------------------------ +! zero out next column in yh array. ------------------------------------ + 180 continue + lp1 = l + 1 + do 190 i = 1, n + 190 yh(i,lp1) = zero + return +!----------------------------------------------------------------------- +! stiff option... +! check to see if the order is being increased or decreased. +!----------------------------------------------------------------------- + 200 continue + if (iord .eq. 1) go to 300 +! order decrease. ------------------------------------------------------ + do 210 j = 1, lmax + 210 el(j) = zero + el(3) = one + hsum = zero + do 230 j = 1,nqm2 +! construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + hsum = hsum + tau(j) + xi = hsum/hscal + jp1 = j + 1 + do 220 iback = 1, jp1 + i = (j + 4) - iback + 220 el(i) = el(i)*xi + el(i-1) + 230 continue +! subtract correction terms from yh array. ----------------------------- + do 250 j = 3,nq + do 240 i = 1, n + 240 yh(i,j) = yh(i,j) - yh(i,l)*el(j) + 250 continue + return +! order increase. ------------------------------------------------------ + 300 do 310 j = 1, lmax + 310 el(j) = zero + el(3) = one + alph0 = -one + alph1 = one + prod = one + xiold = one + hsum = hscal + if (nq .eq. 1) go to 340 + do 330 j = 1, nqm1 +! construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + jp1 = j + 1 + hsum = hsum + tau(jp1) + xi = hsum/hscal + prod = prod*xi + alph0 = alph0 - one/real(jp1) + alph1 = alph1 + one/xi + do 320 iback = 1, jp1 + i = (j + 4) - iback + 320 el(i) = el(i)*xiold + el(i-1) + xiold = xi + 330 continue + 340 continue + t1 = (-alph0 - alph1)/prod +! load column l + 1 in yh array. --------------------------------------- + lp1 = l + 1 + do 350 i = 1, n + 350 yh(i,lp1) = t1*yh(i,lmax) +! add correction terms to yh array. ------------------------------------ + nqp1 = nq + 1 + do 370 j = 3, nqp1 + call saxpy (n, el(j), yh(1,lp1), 1, yh(1,j), 1 ) + 370 continue + return +!----------------------- end of subroutine svjust ---------------------- + end subroutine svjust +!*deck svnlsd + subroutine svnlsd (y, yh, ldyh, vsav, savf, ewt, acor, iwm, wm, & + f, jac, pdum, nflag, rpar, ipar) + external f, jac, pdum + real y, yh, vsav, savf, ewt, acor, wm, rpar + integer ldyh, iwm, nflag, ipar + dimension y(*), yh(ldyh,*), vsav(*), savf(*), ewt(*), acor(*), & + iwm(*), wm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, savf, ewt, acor, iwm, wm, +! f, jac, nflag, rpar, ipar +! call sequence output -- yh, acor, wm, iwm, nflag +! common block variables accessed.. +! /svode_cmn_01/ acnrm, crate, drc, h, rc, rl1, tq(5), tn, icf, +! jcur, meth, miter, n, nslp +! /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! subroutines called by svnlsd.. f, saxpy, scopy, sscal, svjac, svsol +! function routines called by svnlsd.. svnorm +!----------------------------------------------------------------------- +! subroutine svnlsd is a nonlinear system solver, which uses functional +! iteration or a chord (modified newton) method. for the chord method +! direct linear algebraic system solvers are used. subroutine svnlsd +! then handles the corrector phase of this integration package. +! +! communication with svnlsd is done with the following variables. (for +! more details, please see the comments in the driver subroutine.) +! +! y = the dependent variable, a vector of length n, input. +! yh = the nordsieck (taylor) array, ldyh by lmax, input +! and output. on input, it contains predicted values. +! ldyh = a constant .ge. n, the first dimension of yh, input. +! vsav = unused work array. +! savf = a work array of length n. +! ewt = an error weight vector of length n, input. +! acor = a work array of length n, used for the accumulated +! corrections to the predicted y vector. +! wm,iwm = real and integer work arrays associated with matrix +! operations in chord iteration (miter .ne. 0). +! f = dummy name for user supplied routine for f. +! jac = dummy name for user supplied jacobian routine. +! pdum = unused dummy subroutine name. included for uniformity +! over collection of integrators. +! nflag = input/output flag, with values and meanings as follows.. +! input +! 0 first call for this time step. +! -1 convergence failure in previous call to svnlsd. +! -2 error test failure in svstep. +! output +! 0 successful completion of nonlinear solver. +! -1 convergence failure or singular matrix. +! -2 unrecoverable error in matrix preprocessing +! (cannot occur here). +! -3 unrecoverable error in solution (cannot occur +! here). +! rpar, ipar = dummy names for user's real and integer work arrays. +! +! ipup = own variable flag with values and meanings as follows.. +! 0, do not update the newton matrix. +! miter .ne. 0, update newton matrix, because it is the +! initial step, order was changed, the error +! test failed, or an update is indicated by +! the scalar rc or step counter nst. +! +! for more details, see comments in driver subroutine. +!----------------------------------------------------------------------- +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block svode_cmn_02 -------------------- +! + real hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + real ccmax, crdown, cscale, dcon, del, delp, one, & + rdiv, two, zero + integer i, ierpj, iersl, m, maxcor, msbp +! +! type declaration for function subroutines called --------------------- +! +! real svnorm ! rce 2005-jan-21 - module conversion +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save ccmax, crdown, maxcor, msbp, rdiv, one, two, zero +! + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data ccmax /0.3e0/, crdown /0.3e0/, maxcor /3/, msbp /20/, & + rdiv /2.0e0/ + data one /1.0e0/, two /2.0e0/, zero /0.0e0/ +!----------------------------------------------------------------------- +! on the first step, on a change of method order, or after a +! nonlinear convergence failure with nflag = -2, set ipup = miter +! to force a jacobian update when miter .ne. 0. +!----------------------------------------------------------------------- + if (jstart .eq. 0) nslp = 0 + if (nflag .eq. 0) icf = 0 + if (nflag .eq. -2) ipup = miter + if ( (jstart .eq. 0) .or. (jstart .eq. -1) ) ipup = miter +! if this is functional iteration, set crate .eq. 1 and drop to 220 + if (miter .eq. 0) then + crate = one + go to 220 + endif +!----------------------------------------------------------------------- +! rc is the ratio of new to old values of the coefficient h/el(2)=h/l1. +! when rc differs from 1 by more than ccmax, ipup is set to miter +! to force svjac to be called, if a jacobian is involved. +! in any case, svjac is called at least every msbp steps. +!----------------------------------------------------------------------- + drc = abs(rc-one) + if (drc .gt. ccmax .or. nst .ge. nslp+msbp) ipup = miter +!----------------------------------------------------------------------- +! up to maxcor corrector iterations are taken. a convergence test is +! made on the r.m.s. norm of each correction, weighted by the error +! weight vector ewt. the sum of the corrections is accumulated in the +! vector acor(i). the yh array is not altered in the corrector loop. +!----------------------------------------------------------------------- + 220 m = 0 + delp = zero + call scopy (n, yh(1,1), 1, y, 1 ) + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + if (ipup .le. 0) go to 250 +!----------------------------------------------------------------------- +! if indicated, the matrix p = i - h*rl1*j is reevaluated and +! preprocessed before starting the corrector iteration. ipup is set +! to 0 as an indicator that this has been done. +!----------------------------------------------------------------------- + call svjac (y, yh, ldyh, ewt, acor, savf, wm, iwm, f, jac, ierpj, & + rpar, ipar) + ipup = 0 + rc = one + drc = zero + crate = one + nslp = nst +! if matrix is singular, take error return to force cut in step size. -- + if (ierpj .ne. 0) go to 430 + 250 do 260 i = 1,n + 260 acor(i) = zero +! this is a looping point for the corrector iteration. ----------------- + 270 if (miter .ne. 0) go to 350 +!----------------------------------------------------------------------- +! in the case of functional iteration, update y directly from +! the result of the last function evaluation. +!----------------------------------------------------------------------- + do 280 i = 1,n + 280 savf(i) = rl1*(h*savf(i) - yh(i,2)) + do 290 i = 1,n + 290 y(i) = savf(i) - acor(i) + del = svnorm (n, y, ewt) + do 300 i = 1,n + 300 y(i) = yh(i,1) + savf(i) + call scopy (n, savf, 1, acor, 1) + go to 400 +!----------------------------------------------------------------------- +! in the case of the chord method, compute the corrector error, +! and solve the linear system with that as right-hand side and +! p as coefficient matrix. the correction is scaled by the factor +! 2/(1+rc) to account for changes in h*rl1 since the last svjac call. +!----------------------------------------------------------------------- + 350 do 360 i = 1,n + 360 y(i) = (rl1*h)*savf(i) - (rl1*yh(i,2) + acor(i)) + call svsol (wm, iwm, y, iersl) + nni = nni + 1 + if (iersl .gt. 0) go to 410 + if (meth .eq. 2 .and. rc .ne. one) then + cscale = two/(one + rc) + call sscal (n, cscale, y, 1) + endif + del = svnorm (n, y, ewt) + call saxpy (n, one, y, 1, acor, 1) + do 380 i = 1,n + 380 y(i) = yh(i,1) + acor(i) +!----------------------------------------------------------------------- +! test for convergence. if m .gt. 0, an estimate of the convergence +! rate constant is stored in crate, and this is used in the test. +!----------------------------------------------------------------------- + 400 if (m .ne. 0) crate = max(crdown*crate,del/delp) + dcon = del*min(one,crate)/tq(4) + if (dcon .le. one) go to 450 + m = m + 1 + if (m .eq. maxcor) go to 410 + if (m .ge. 2 .and. del .gt. rdiv*delp) go to 410 + delp = del + call f (n, tn, y, savf, rpar, ipar) + nfe = nfe + 1 + go to 270 +! + 410 if (miter .eq. 0 .or. jcur .eq. 1) go to 430 + icf = 1 + ipup = miter + go to 220 +! + 430 continue + nflag = -1 + icf = 2 + ipup = miter + return +! +! return for successful step. ------------------------------------------ + 450 nflag = 0 + jcur = 0 + icf = 0 + if (m .eq. 0) acnrm = del + if (m .gt. 0) acnrm = svnorm (n, acor, ewt) + return +!----------------------- end of subroutine svnlsd ---------------------- + end subroutine svnlsd +!*deck svjac + subroutine svjac (y, yh, ldyh, ewt, ftem, savf, wm, iwm, f, jac, & + ierpj, rpar, ipar) + external f, jac + real y, yh, ewt, ftem, savf, wm, rpar + integer ldyh, iwm, ierpj, ipar + dimension y(*), yh(ldyh,*), ewt(*), ftem(*), savf(*), & + wm(*), iwm(*), rpar(*), ipar(*) +!----------------------------------------------------------------------- +! call sequence input -- y, yh, ldyh, ewt, ftem, savf, wm, iwm, +! f, jac, rpar, ipar +! call sequence output -- wm, iwm, ierpj +! common block variables accessed.. +! /svode_cmn_01/ ccmxj, drc, h, rl1, tn, uround, icf, jcur, locjs, +! miter, msbj, n, nslj +! /svode_cmn_02/ nfe, nst, nje, nlu +! +! subroutines called by svjac.. f, jac, sacopy, scopy, sgbfa, sgefa, +! sscal +! function routines called by svjac.. svnorm +!----------------------------------------------------------------------- +! svjac is called by svnlsd to compute and process the matrix +! p = i - h*rl1*j , where j is an approximation to the jacobian. +! here j is computed by the user-supplied routine jac if +! miter = 1 or 4, or by finite differencing if miter = 2, 3, or 5. +! if miter = 3, a diagonal approximation to j is used. +! if jsv = -1, j is computed from scratch in all cases. +! if jsv = 1 and miter = 1, 2, 4, or 5, and if the saved value of j is +! considered acceptable, then p is constructed from the saved j. +! j is stored in wm and replaced by p. if miter .ne. 3, p is then +! subjected to lu decomposition in preparation for later solution +! of linear systems with p as coefficient matrix. this is done +! by sgefa if miter = 1 or 2, and by sgbfa if miter = 4 or 5. +! +! communication with svjac is done with the following variables. (for +! more details, please see the comments in the driver subroutine.) +! y = vector containing predicted values on entry. +! yh = the nordsieck array, an ldyh by lmax array, input. +! ldyh = a constant .ge. n, the first dimension of yh, input. +! ewt = an error weight vector of length n. +! savf = array containing f evaluated at predicted y, input. +! wm = real work space for matrices. in the output, it contains +! the inverse diagonal matrix if miter = 3 and the lu +! decomposition of p if miter is 1, 2 , 4, or 5. +! storage of matrix elements starts at wm(3). +! storage of the saved jacobian starts at wm(locjs). +! wm also contains the following matrix-related data.. +! wm(1) = sqrt(uround), used in numerical jacobian step. +! wm(2) = h*rl1, saved for later use if miter = 3. +! iwm = integer work space containing pivot information, +! starting at iwm(31), if miter is 1, 2, 4, or 5. +! iwm also contains band parameters ml = iwm(1) and +! mu = iwm(2) if miter is 4 or 5. +! f = dummy name for the user supplied subroutine for f. +! jac = dummy name for the user supplied jacobian subroutine. +! rpar, ipar = dummy names for user's real and integer work arrays. +! rl1 = 1/el(2) (input). +! ierpj = output error flag, = 0 if no trouble, 1 if the p +! matrix is found to be singular. +! jcur = output flag to indicate whether the jacobian matrix +! (or approximation) is now current. +! jcur = 0 means j is not current. +! jcur = 1 means j is current. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for labeled common block svode_cmn_02 -------------------- +! + real hu + integer ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! +! type declarations for local variables -------------------------------- +! + real con, di, fac, hrl1, one, pt1, r, r0, srur, thou, & + yi, yj, yjj, zero + integer i, i1, i2, ier, ii, j, j1, jj, jok, lenp, mba, mband, & + meb1, meband, ml, ml3, mu, np1 +! +! type declaration for function subroutines called --------------------- +! +! real svnorm ! rce 2005-jan-21 - module conversion +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this subroutine. +!----------------------------------------------------------------------- + save one, pt1, thou, zero +!----------------------------------------------------------------------- + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh + common /svode_cmn_02/ hu, ncfn, netf, nfe, nje, nlu, nni, nqu, nst +! + data one /1.0e0/, thou /1000.0e0/, zero /0.0e0/, pt1 /0.1e0/ +! + ierpj = 0 + hrl1 = h*rl1 +! see whether j should be evaluated (jok = -1) or not (jok = 1). ------- + jok = jsv + if (jsv .eq. 1) then + if (nst .eq. 0 .or. nst .gt. nslj+msbj) jok = -1 + if (icf .eq. 1 .and. drc .lt. ccmxj) jok = -1 + if (icf .eq. 2) jok = -1 + endif +! end of setting jok. -------------------------------------------------- +! + if (jok .eq. -1 .and. miter .eq. 1) then +! if jok = -1 and miter = 1, call jac to evaluate jacobian. ------------ + nje = nje + 1 + nslj = nst + jcur = 1 + lenp = n*n + do 110 i = 1,lenp + 110 wm(i+2) = zero + call jac (n, tn, y, 0, 0, wm(3), n, rpar, ipar) + if (jsv .eq. 1) call scopy (lenp, wm(3), 1, wm(locjs), 1) + endif +! + if (jok .eq. -1 .and. miter .eq. 2) then +! if miter = 2, make n calls to f to approximate the jacobian. --------- + nje = nje + 1 + nslj = nst + jcur = 1 + fac = svnorm (n, savf, ewt) + r0 = thou*abs(h)*uround*real(n)*fac + if (r0 .eq. zero) r0 = one + srur = wm(1) + j1 = 2 + do 230 j = 1,n + yj = y(j) + r = max(srur*abs(yj),r0/ewt(j)) + y(j) = y(j) + r + fac = one/r + call f (n, tn, y, ftem, rpar, ipar) + do 220 i = 1,n + 220 wm(i+j1) = (ftem(i) - savf(i))*fac + y(j) = yj + j1 = j1 + n + 230 continue + nfe = nfe + n + lenp = n*n + if (jsv .eq. 1) call scopy (lenp, wm(3), 1, wm(locjs), 1) + endif +! + if (jok .eq. 1 .and. (miter .eq. 1 .or. miter .eq. 2)) then + jcur = 0 + lenp = n*n + call scopy (lenp, wm(locjs), 1, wm(3), 1) + endif +! + if (miter .eq. 1 .or. miter .eq. 2) then +! multiply jacobian by scalar, add identity, and do lu decomposition. -- + con = -hrl1 + call sscal (lenp, con, wm(3), 1) + j = 3 + np1 = n + 1 + do 250 i = 1,n + wm(j) = wm(j) + one + 250 j = j + np1 + nlu = nlu + 1 + call sgefa (wm(3), n, n, iwm(31), ier) + if (ier .ne. 0) ierpj = 1 + return + endif +! end of code block for miter = 1 or 2. -------------------------------- +! + if (miter .eq. 3) then +! if miter = 3, construct a diagonal approximation to j and p. --------- + nje = nje + 1 + jcur = 1 + wm(2) = hrl1 + r = rl1*pt1 + do 310 i = 1,n + 310 y(i) = y(i) + r*(h*savf(i) - yh(i,2)) + call f (n, tn, y, wm(3), rpar, ipar) + nfe = nfe + 1 + do 320 i = 1,n + r0 = h*savf(i) - yh(i,2) + di = pt1*r0 - h*(wm(i+2) - savf(i)) + wm(i+2) = one + if (abs(r0) .lt. uround/ewt(i)) go to 320 + if (abs(di) .eq. zero) go to 330 + wm(i+2) = pt1*r0/di + 320 continue + return + 330 ierpj = 1 + return + endif +! end of code block for miter = 3. ------------------------------------- +! +! set constants for miter = 4 or 5. ------------------------------------ + ml = iwm(1) + mu = iwm(2) + ml3 = ml + 3 + mband = ml + mu + 1 + meband = mband + ml + lenp = meband*n +! + if (jok .eq. -1 .and. miter .eq. 4) then +! if jok = -1 and miter = 4, call jac to evaluate jacobian. ------------ + nje = nje + 1 + nslj = nst + jcur = 1 + do 410 i = 1,lenp + 410 wm(i+2) = zero + call jac (n, tn, y, ml, mu, wm(ml3), meband, rpar, ipar) + if (jsv .eq. 1) & + call sacopy (mband, n, wm(ml3), meband, wm(locjs), mband) + endif +! + if (jok .eq. -1 .and. miter .eq. 5) then +! if miter = 5, make ml+mu+1 calls to f to approximate the jacobian. --- + nje = nje + 1 + nslj = nst + jcur = 1 + mba = min(mband,n) + meb1 = meband - 1 + srur = wm(1) + fac = svnorm (n, savf, ewt) + r0 = thou*abs(h)*uround*real(n)*fac + if (r0 .eq. zero) r0 = one + do 560 j = 1,mba + do 530 i = j,n,mband + yi = y(i) + r = max(srur*abs(yi),r0/ewt(i)) + 530 y(i) = y(i) + r + call f (n, tn, y, ftem, rpar, ipar) + do 550 jj = j,n,mband + y(jj) = yh(jj,1) + yjj = y(jj) + r = max(srur*abs(yjj),r0/ewt(jj)) + fac = one/r + i1 = max(jj-mu,1) + i2 = min(jj+ml,n) + ii = jj*meb1 - ml + 2 + do 540 i = i1,i2 + 540 wm(ii+i) = (ftem(i) - savf(i))*fac + 550 continue + 560 continue + nfe = nfe + mba + if (jsv .eq. 1) & + call sacopy (mband, n, wm(ml3), meband, wm(locjs), mband) + endif +! + if (jok .eq. 1) then + jcur = 0 + call sacopy (mband, n, wm(locjs), mband, wm(ml3), meband) + endif +! +! multiply jacobian by scalar, add identity, and do lu decomposition. + con = -hrl1 + call sscal (lenp, con, wm(3), 1 ) + ii = mband + 2 + do 580 i = 1,n + wm(ii) = wm(ii) + one + 580 ii = ii + meband + nlu = nlu + 1 + call sgbfa (wm(3), meband, n, ml, mu, iwm(31), ier) + if (ier .ne. 0) ierpj = 1 + return +! end of code block for miter = 4 or 5. -------------------------------- +! +!----------------------- end of subroutine svjac ----------------------- + end subroutine svjac +!*deck sacopy + subroutine sacopy (nrow, ncol, a, nrowa, b, nrowb) + real a, b + integer nrow, ncol, nrowa, nrowb + dimension a(nrowa,ncol), b(nrowb,ncol) +!----------------------------------------------------------------------- +! call sequence input -- nrow, ncol, a, nrowa, nrowb +! call sequence output -- b +! common block variables accessed -- none +! +! subroutines called by sacopy.. scopy +! function routines called by sacopy.. none +!----------------------------------------------------------------------- +! this routine copies one rectangular array, a, to another, b, +! where a and b may have different row dimensions, nrowa and nrowb. +! the data copied consists of nrow rows and ncol columns. +!----------------------------------------------------------------------- + integer ic +! + do 20 ic = 1,ncol + call scopy (nrow, a(1,ic), 1, b(1,ic), 1) + 20 continue +! + return +!----------------------- end of subroutine sacopy ---------------------- + end subroutine sacopy +!*deck svsol + subroutine svsol (wm, iwm, x, iersl) + real wm, x + integer iwm, iersl + dimension wm(*), iwm(*), x(*) +!----------------------------------------------------------------------- +! call sequence input -- wm, iwm, x +! call sequence output -- x, iersl +! common block variables accessed.. +! /svode_cmn_01/ -- h, rl1, miter, n +! +! subroutines called by svsol.. sgesl, sgbsl +! function routines called by svsol.. none +!----------------------------------------------------------------------- +! this routine manages the solution of the linear system arising from +! a chord iteration. it is called if miter .ne. 0. +! if miter is 1 or 2, it calls sgesl to accomplish this. +! if miter = 3 it updates the coefficient h*rl1 in the diagonal +! matrix, and then computes the solution. +! if miter is 4 or 5, it calls sgbsl. +! communication with svsol uses the following variables.. +! wm = real work space containing the inverse diagonal matrix if +! miter = 3 and the lu decomposition of the matrix otherwise. +! storage of matrix elements starts at wm(3). +! wm also contains the following matrix-related data.. +! wm(1) = sqrt(uround) (not used here), +! wm(2) = hrl1, the previous value of h*rl1, used if miter = 3. +! iwm = integer work space containing pivot information, starting at +! iwm(31), if miter is 1, 2, 4, or 5. iwm also contains band +! parameters ml = iwm(1) and mu = iwm(2) if miter is 4 or 5. +! x = the right-hand side vector on input, and the solution vector +! on output, of length n. +! iersl = output flag. iersl = 0 if no trouble occurred. +! iersl = 1 if a singular matrix arose with miter = 3. +!----------------------------------------------------------------------- +! +! type declarations for labeled common block svode_cmn_01 -------------------- +! + real acnrm, ccmxj, conp, crate, drc, el, & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau, tq, tn, uround + integer icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! +! type declarations for local variables -------------------------------- +! + integer i, meband, ml, mu + real di, hrl1, one, phrl1, r, zero +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save one, zero +! + common /svode_cmn_01/ acnrm, ccmxj, conp, crate, drc, el(13), & + eta, etamax, h, hmin, hmxi, hnew, hscal, prl1, & + rc, rl1, tau(13), tq(5), tn, uround, & + icf, init, ipup, jcur, jstart, jsv, kflag, kuth, & + l, lmax, lyh, lewt, lacor, lsavf, lwm, liwm, & + locjs, maxord, meth, miter, msbj, mxhnil, mxstep, & + n, newh, newq, nhnil, nq, nqnyh, nqwait, nslj, & + nslp, nyh +! + data one /1.0e0/, zero /0.0e0/ +! + iersl = 0 + go to (100, 100, 300, 400, 400), miter + 100 call sgesl (wm(3), n, n, iwm(31), x, 0) + return +! + 300 phrl1 = wm(2) + hrl1 = h*rl1 + wm(2) = hrl1 + if (hrl1 .eq. phrl1) go to 330 + r = hrl1/phrl1 + do 320 i = 1,n + di = one - r*(one - one/wm(i+2)) + if (abs(di) .eq. zero) go to 390 + 320 wm(i+2) = one/di +! + 330 do 340 i = 1,n + 340 x(i) = wm(i+2)*x(i) + return + 390 iersl = 1 + return +! + 400 ml = iwm(1) + mu = iwm(2) + meband = 2*ml + mu + 1 + call sgbsl (wm(3), meband, n, ml, mu, iwm(31), x, 0) + return +!----------------------- end of subroutine svsol ----------------------- + end subroutine svsol +!*deck svsrco + subroutine svsrco (rsav, isav, job) + real rsav + integer isav, job + dimension rsav(*), isav(*) +!----------------------------------------------------------------------- +! call sequence input -- rsav, isav, job +! call sequence output -- rsav, isav +! common block variables accessed -- all of /svode_cmn_01/ and /svode_cmn_02/ +! +! subroutines/functions called by svsrco.. none +!----------------------------------------------------------------------- +! this routine saves or restores (depending on job) the contents of the +! common blocks svode_cmn_01 and svode_cmn_02, which are used internally by svode. +! +! rsav = real array of length 49 or more. +! isav = integer array of length 41 or more. +! job = flag indicating to save or restore the common blocks.. +! job = 1 if common is to be saved (written to rsav/isav). +! job = 2 if common is to be restored (read from rsav/isav). +! a call with job = 2 presumes a prior call with job = 1. +!----------------------------------------------------------------------- + real rvod1, rvod2 + integer ivod1, ivod2 + integer i, leniv1, leniv2, lenrv1, lenrv2 +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this integrator. +!----------------------------------------------------------------------- + save lenrv1, leniv1, lenrv2, leniv2 +! + common /svode_cmn_01/ rvod1(48), ivod1(33) + common /svode_cmn_02/ rvod2(1), ivod2(8) + data lenrv1/48/, leniv1/33/, lenrv2/1/, leniv2/8/ +! + if (job .eq. 2) go to 100 + do 10 i = 1,lenrv1 + 10 rsav(i) = rvod1(i) + do 15 i = 1,lenrv2 + 15 rsav(lenrv1+i) = rvod2(i) +! + do 20 i = 1,leniv1 + 20 isav(i) = ivod1(i) + do 25 i = 1,leniv2 + 25 isav(leniv1+i) = ivod2(i) +! + return +! + 100 continue + do 110 i = 1,lenrv1 + 110 rvod1(i) = rsav(i) + do 115 i = 1,lenrv2 + 115 rvod2(i) = rsav(lenrv1+i) +! + do 120 i = 1,leniv1 + 120 ivod1(i) = isav(i) + do 125 i = 1,leniv2 + 125 ivod2(i) = isav(leniv1+i) +! + return +!----------------------- end of subroutine svsrco ---------------------- + end subroutine svsrco +!*deck sewset + subroutine sewset (n, itol, rtol, atol, ycur, ewt) + real rtol, atol, ycur, ewt + integer n, itol + dimension rtol(*), atol(*), ycur(n), ewt(n) +!----------------------------------------------------------------------- +! call sequence input -- n, itol, rtol, atol, ycur +! call sequence output -- ewt +! common block variables accessed -- none +! +! subroutines/functions called by sewset.. none +!----------------------------------------------------------------------- +! this subroutine sets the error weight vector ewt according to +! ewt(i) = rtol(i)*abs(ycur(i)) + atol(i), i = 1,...,n, +! with the subscript on rtol and/or atol possibly replaced by 1 above, +! depending on the value of itol. +!----------------------------------------------------------------------- + integer i +! + go to (10, 20, 30, 40), itol + 10 continue + do 15 i = 1, n + 15 ewt(i) = rtol(1)*abs(ycur(i)) + atol(1) + return + 20 continue + do 25 i = 1, n + 25 ewt(i) = rtol(1)*abs(ycur(i)) + atol(i) + return + 30 continue + do 35 i = 1, n + 35 ewt(i) = rtol(i)*abs(ycur(i)) + atol(1) + return + 40 continue + do 45 i = 1, n + 45 ewt(i) = rtol(i)*abs(ycur(i)) + atol(i) + return +!----------------------- end of subroutine sewset ---------------------- + end subroutine sewset +!*deck svnorm + real function svnorm (n, v, w) + real v, w + integer n + dimension v(n), w(n) +!----------------------------------------------------------------------- +! call sequence input -- n, v, w +! call sequence output -- none +! common block variables accessed -- none +! +! subroutines/functions called by svnorm.. none +!----------------------------------------------------------------------- +! this function routine computes the weighted root-mean-square norm +! of the vector of length n contained in the array v, with weights +! contained in the array w of length n.. +! svnorm = sqrt( (1/n) * sum( v(i)*w(i) )**2 ) +!----------------------------------------------------------------------- + real sum + integer i +! + sum = 0.0e0 + do 10 i = 1, n + 10 sum = sum + (v(i)*w(i))**2 + svnorm = sqrt(sum/real(n)) + return +!----------------------- end of function svnorm ------------------------ + end function svnorm +!*deck r1mach + real function r1mach (idum) + integer idum +!----------------------------------------------------------------------- +! this routine computes the unit roundoff of the machine. +! this is defined as the smallest positive machine number +! u such that 1.0 + u .ne. 1.0 +! +! subroutines/functions called by r1mach.. none +!----------------------------------------------------------------------- + real u, comp + u = 1.0e0 + 10 u = u*0.5e0 + comp = 1.0e0 + u + if (comp .ne. 1.0e0) go to 10 + r1mach = u*2.0e0 + return +!----------------------- end of function r1mach ------------------------ + end function r1mach +!*deck xerrwv + subroutine xerrwv (msg, nmes, nerr, level, ni, i1, i2, nr, r1, r2) + real r1, r2 + integer nmes, nerr, level, ni, i1, i2, nr +! character*1 msg(nmes) ! rce 2005-jan-21 - module conversion + character*(nmes) msg +!----------------------------------------------------------------------- +! subroutines xerrwv, xsetf, xsetun, and the function routine ixsav, +! as given here, constitute a simplified version of the slatec error +! handling package. +! written by a. c. hindmarsh and p. n. brown at llnl. +! version of 18 november, 1992. +! this version is in single precision. +! +! all arguments are input arguments. +! +! msg = the message (character array). +! nmes = the length of msg (number of characters). +! nerr = the error number (not used). +! level = the error level.. +! 0 or 1 means recoverable (control returns to caller). +! 2 means fatal (run is aborted--see note below). +! ni = number of integers (0, 1, or 2) to be printed with message. +! i1,i2 = integers to be printed, depending on ni. +! nr = number of reals (0, 1, or 2) to be printed with message. +! r1,r2 = reals to be printed, depending on nr. +! +! note.. this routine is machine-dependent and specialized for use +! in limited context, in the following ways.. +! 1. the argument msg is assumed to be of type character, and +! the message is printed with a format of (1x,80a1). +! 2. the message is assumed to take only one line. +! multi-line messages are generated by repeated calls. +! 3. if level = 2, control passes to the statement stop +! to abort the run. this statement may be machine-dependent. +! 4. r1 and r2 are assumed to be in single precision and are printed +! in e21.13 format. +! +! for a different default logical unit number, change the data +! statement in function routine ixsav. +! for a different run-abort command, change the statement following +! statement 100 at the end. +!----------------------------------------------------------------------- +! subroutines called by xerrwv.. none +! function routine called by xerrwv.. ixsav +!----------------------------------------------------------------------- +! +! integer i, lunit, ixsav, mesflg ! rce 2005-jan-21 - module conversion + integer i, lunit, mesflg +! +! get logical unit number and message print flag. ---------------------- + lunit = ixsav (1, 0, .false.) + mesflg = ixsav (2, 0, .false.) + if (mesflg .eq. 0) go to 100 +! write the message. --------------------------------------------------- +! write (lunit,10) (msg(i),i=1,nmes) ! rce 2005-jan-21 - module conversion + write (lunit,10) msg + 10 format(1x,80a1) + if (ni .eq. 1) write (lunit, 20) i1 + 20 format(6x,'in above message, i1 =',i10) + if (ni .eq. 2) write (lunit, 30) i1,i2 + 30 format(6x,'in above message, i1 =',i10,3x,'i2 =',i10) + if (nr .eq. 1) write (lunit, 40) r1 + 40 format(6x,'in above message, r1 =',e21.13) + if (nr .eq. 2) write (lunit, 50) r1,r2 + 50 format(6x,'in above, r1 =',e21.13,3x,'r2 =',e21.13) +! +! rce 2005-may-05 - do not write to unit 2 +! +! added by sp (writing of error messages in unit 2) +! +! write (2,10) (msg(i),i=1,nmes) ! rce 2005-jan-21 - module conversion +! write (2,10) msg +! if (ni .eq. 1) write (2, 20) i1 +! if (ni .eq. 2) write (2, 30) i1,i2 +! if (nr .eq. 1) write (2, 40) r1 +! if (nr .eq. 2) write (2, 50) r1,r2 +! +! abort the run if level = 2. ------------------------------------------ + 100 if (level .ne. 2) return +! rce 2005-may-05 - use peg_error_fatal +! stop + call peg_error_fatal( -1, & + '*** fatal error - module_svode_solver, subr xerrwv' ) +!----------------------- end of subroutine xerrwv ---------------------- + end subroutine xerrwv +!*deck xsetun + subroutine xsetun (lun) +!----------------------------------------------------------------------- +! this routine resets the logical unit number for messages. +! +! subroutines called by xsetun.. none +! function routine called by xsetun.. ixsav +!----------------------------------------------------------------------- +! integer lun, junk, ixsav ! rce 2005-jan-21 - module conversion + integer lun, junk +! + if (lun .gt. 0) junk = ixsav (1,lun,.true.) + return +!----------------------- end of subroutine xsetun ---------------------- + end subroutine xsetun +!*deck xsetf + subroutine xsetf (mflag) +!----------------------------------------------------------------------- +! this routine resets the print control flag mflag. +! +! subroutines called by xsetf.. none +! function routine called by xsetf.. ixsav +!----------------------------------------------------------------------- +! integer mflag, junk, ixsav ! rce 2005-jan-21 - module conversion + integer mflag, junk +! + if (mflag .eq. 0 .or. mflag .eq. 1) junk = ixsav (2,mflag,.true.) + return +!----------------------- end of subroutine xsetf ----------------------- + end subroutine xsetf +!*deck ixsav + integer function ixsav (ipar, ivalue, iset) + logical iset + integer ipar, ivalue +!----------------------------------------------------------------------- +! ixsav saves and recalls one of two error message parameters: +! lunit, the logical unit number to which messages are printed, and +! mesflg, the message print flag. +! this is a modification of the slatec library routine j4save. +! +! saved local variables.. +! lunit = logical unit number for messages. +! the default is 6 (machine-dependent). +! mesflg = print control flag.. +! 1 means print all messages (the default). +! 0 means no printing. +! +! on input.. +! ipar = parameter indicator (1 for lunit, 2 for mesflg). +! ivalue = the value to be set for the parameter, if iset = .true. +! iset = logical flag to indicate whether to read or write. +! if iset = .true., the parameter will be given +! the value ivalue. if iset = .false., the parameter +! will be unchanged, and ivalue is a dummy argument. +! +! on return.. +! ixsav = the (old) value of the parameter. +! +! subroutines/functions called by ixsav.. none +!----------------------------------------------------------------------- + integer lunit, mesflg +!----------------------------------------------------------------------- +! the following fortran-77 declaration is to cause the values of the +! listed (local) variables to be saved between calls to this routine. +!----------------------------------------------------------------------- + save lunit, mesflg + data lunit/6/, mesflg/1/ +! + if (ipar .eq. 1) then + ixsav = lunit + if (iset) lunit = ivalue + endif +! + if (ipar .eq. 2) then + ixsav = mesflg + if (iset) mesflg = ivalue + endif +! + return +!----------------------- end of function ixsav ------------------------- + end function ixsav +! routines selected from blas and used by vode + + subroutine scopy(n,sx,incx,sy,incy) +! +! copies a vector, x, to a vector, y. +! uses unrolled loops for increments equal to 1. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + real sx(*),sy(*) + integer i,incx,incy,ix,iy,m,mp1,n +! + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + sy(iy) = sx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + sy(i) = sx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + sy(i) = sx(i) + sy(i + 1) = sx(i + 1) + sy(i + 2) = sx(i + 2) + sy(i + 3) = sx(i + 3) + sy(i + 4) = sx(i + 4) + sy(i + 5) = sx(i + 5) + sy(i + 6) = sx(i + 6) + 50 continue + return + end subroutine scopy + + + + + subroutine sscal(n,sa,sx,incx) +! +! scales a vector by a constant. +! uses unrolled loops for increment equal to 1. +! jack dongarra, linpack, 3/11/78. +! modified 3/93 to return if incx .le. 0. +! modified 12/3/93, array(1) declarations changed to array(*) +! + real sa,sx(*) + integer i,incx,m,mp1,n,nincx +! + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +! +! code for increment not equal to 1 +! + nincx = n*incx + do 10 i = 1,nincx,incx + sx(i) = sa*sx(i) + 10 continue + return + +! code for increment equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + sx(i) = sa*sx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + sx(i) = sa*sx(i) + sx(i + 1) = sa*sx(i + 1) + sx(i + 2) = sa*sx(i + 2) + sx(i + 3) = sa*sx(i + 3) + sx(i + 4) = sa*sx(i + 4) + 50 continue + return + end subroutine sscal + + + + subroutine saxpy(n,sa,sx,incx,sy,incy) +! +! constant times a vector plus a vector. +! uses unrolled loop for increments equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + real sx(*),sy(*),sa + integer i,incx,incy,ix,iy,m,mp1,n +! + if(n.le.0)return + if (sa .eq. 0.0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + sy(iy) = sy(iy) + sa*sx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + sy(i) = sy(i) + sa*sx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + sy(i) = sy(i) + sa*sx(i) + sy(i + 1) = sy(i + 1) + sa*sx(i + 1) + sy(i + 2) = sy(i + 2) + sa*sx(i + 2) + sy(i + 3) = sy(i + 3) + sa*sx(i + 3) + 50 continue + return + end subroutine saxpy + + +! linpack routines used by svode + + +!* ====================================================================== +!* nist guide to available math software. +!* fullsource for module sgefa from package linpack. +!* retrieved from netlib on wed jun 17 08:00:19 1998. +!* ====================================================================== + subroutine sgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(*),info + real a(lda,*) +! +! sgefa factors a real matrix by gaussian elimination. +! +! sgefa is usually called by sgeco, but it can be called +! directly with a saving in time if rcond is not needed. +! (time for sgeco) = (1 + 9/n)*(time for sgefa) . +! +! on entry +! +! a real(lda, n) +! the matrix to be factored. +! +! lda integer +! the leading dimension of the array a . +! +! n integer +! the order of the matrix a . +! +! on return +! +! a an upper triangular matrix and the multipliers +! which were used to obtain it. +! the factorization can be written a = l*u where +! l is a product of permutation and unit lower +! triangular matrices and u is upper triangular. +! +! ipvt integer(n) +! an integer vector of pivot indices. +! +! info integer +! = 0 normal value. +! = k if u(k,k) .eq. 0.0 . this is not an error +! condition for this subroutine, but it does +! indicate that sgesl or sgedi will divide by zero +! if called. use rcond in sgeco for a reliable +! indication of singularity. +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas saxpy,sscal,isamax +! +! internal variables +! + real t +! integer isamax,j,k,kp1,l,nm1 ! rce 2005-jan-21 - module conversion + integer j,k,kp1,l,nm1 +! +! +! gaussian elimination with partial pivoting +! + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +! +! find l = pivot index +! + l = isamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +! +! zero pivot implies this column already triangularized +! + if (a(l,k) .eq. 0.0e0) go to 40 +! +! interchange if necessary +! + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +! +! compute multipliers +! + t = -1.0e0/a(k,k) + call sscal(n-k,t,a(k+1,k),1) +! +! row elimination with column indexing +! + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call saxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (a(n,n) .eq. 0.0e0) info = n + return + end subroutine sgefa + + + integer function isamax(n,sx,incx) +! +! finds the index of element having max. absolute value. +! jack dongarra, linpack, 3/11/78. +! modified 3/93 to return if incx .le. 0. +! modified 12/3/93, array(1) declarations changed to array(*) +! + real sx(*),smax + integer i,incx,ix,n +! + isamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + isamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +! +! code for increment not equal to 1 +! + ix = 1 + smax = abs(sx(1)) + ix = ix + incx + do 10 i = 2,n + if(abs(sx(ix)).le.smax) go to 5 + isamax = i + smax = abs(sx(ix)) + 5 ix = ix + incx + 10 continue + return +! +! code for increment equal to 1 +! + 20 smax = abs(sx(1)) + do 30 i = 2,n + if(abs(sx(i)).le.smax) go to 30 + isamax = i + smax = abs(sx(i)) + 30 continue + return + end function isamax + + + + +!* ====================================================================== +!* nist guide to available math software. +!* fullsource for module sgbfa from package linpack. +!* retrieved from netlib on wed jun 17 08:01:13 1998. +!* ====================================================================== + subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info) + integer lda,n,ml,mu,ipvt(1),info + real abd(lda,1) +! +! sgbfa factors a real band matrix by elimination. +! +! sgbfa is usually called by sgbco, but it can be called +! directly with a saving in time if rcond is not needed. +! +! on entry +! +! abd real(lda, n) +! contains the matrix in band storage. the columns +! of the matrix are stored in the columns of abd and +! the diagonals of the matrix are stored in rows +! ml+1 through 2*ml+mu+1 of abd . +! see the comments below for details. +! +! lda integer +! the leading dimension of the array abd . +! lda must be .ge. 2*ml + mu + 1 . +! +! n integer +! the order of the original matrix. +! +! ml integer +! number of diagonals below the main diagonal. +! 0 .le. ml .lt. n . +! +! mu integer +! number of diagonals above the main diagonal. +! 0 .le. mu .lt. n . +! more efficient if ml .le. mu . +! on return +! +! abd an upper triangular matrix in band storage and +! the multipliers which were used to obtain it. +! the factorization can be written a = l*u where +! l is a product of permutation and unit lower +! triangular matrices and u is upper triangular. +! +! ipvt integer(n) +! an integer vector of pivot indices. +! +! info integer +! = 0 normal value. +! = k if u(k,k) .eq. 0.0 . this is not an error +! condition for this subroutine, but it does +! indicate that sgbsl will divide by zero if +! called. use rcond in sgbco for a reliable +! indication of singularity. +! +! band storage +! +! if a is a band matrix, the following program segment +! will set up the input. +! +! ml = (band width below the diagonal) +! mu = (band width above the diagonal) +! m = ml + mu + 1 +! do 20 j = 1, n +! i1 = max0(1, j-mu) +! i2 = min0(n, j+ml) +! do 10 i = i1, i2 +! k = i - j + m +! abd(k,j) = a(i,j) +! 10 continue +! 20 continue +! +! this uses rows ml+1 through 2*ml+mu+1 of abd . +! in addition, the first ml rows in abd are used for +! elements generated during the triangularization. +! the total number of rows needed in abd is 2*ml+mu+1 . +! the ml+mu by ml+mu upper left triangle and the +! ml by ml lower right triangle are not referenced. +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas saxpy,sscal,isamax +! fortran max0,min0 +! +! internal variables +! + real t +! integer i,isamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 ! rce 2005-jan-21 - module conversion + integer i, i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 +! +! + m = ml + mu + 1 + info = 0 +! +! zero initial fill-in columns +! + j0 = mu + 2 + j1 = min0(n,m) - 1 + if (j1 .lt. j0) go to 30 + do 20 jz = j0, j1 + i0 = m + 1 - jz + do 10 i = i0, ml + abd(i,jz) = 0.0e0 + 10 continue + 20 continue + 30 continue + jz = j1 + ju = 0 +! +! gaussian elimination with partial pivoting +! + nm1 = n - 1 + if (nm1 .lt. 1) go to 130 + do 120 k = 1, nm1 + kp1 = k + 1 +! +! zero next fill-in column +! + jz = jz + 1 + if (jz .gt. n) go to 50 + if (ml .lt. 1) go to 50 + do 40 i = 1, ml + abd(i,jz) = 0.0e0 + 40 continue + 50 continue +! +! find l = pivot index +! + lm = min0(ml,n-k) + l = isamax(lm+1,abd(m,k),1) + m - 1 + ipvt(k) = l + k - m +! +! zero pivot implies this column already triangularized +! + if (abd(l,k) .eq. 0.0e0) go to 100 +! +! interchange if necessary +! + if (l .eq. m) go to 60 + t = abd(l,k) + abd(l,k) = abd(m,k) + abd(m,k) = t + 60 continue +! +! compute multipliers +! + t = -1.0e0/abd(m,k) + call sscal(lm,t,abd(m+1,k),1) +! +! row elimination with column indexing +! + ju = min0(max0(ju,mu+ipvt(k)),n) + mm = m + if (ju .lt. kp1) go to 90 + do 80 j = kp1, ju + l = l - 1 + mm = mm - 1 + t = abd(l,j) + if (l .eq. mm) go to 70 + abd(l,j) = abd(mm,j) + abd(mm,j) = t + 70 continue + call saxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) + 80 continue + 90 continue + go to 110 + 100 continue + info = k + 110 continue + 120 continue + 130 continue + ipvt(n) = n + if (abd(m,n) .eq. 0.0e0) info = n + return + end subroutine sgbfa + + + + + +!* ====================================================================== +!* nist guide to available math software. +!* fullsource for module sgesl from package linpack. +!* retrieved from netlib on wed jun 17 08:01:47 1998. +!* ====================================================================== + subroutine sgesl(a,lda,n,ipvt,b,job) + integer lda,n,ipvt(*),job + real a(lda,*),b(*) +! +! sgesl solves the real system +! a * x = b or trans(a) * x = b +! using the factors computed by sgeco or sgefa. +! +! on entry +! +! a real(lda, n) +! the output from sgeco or sgefa. +! +! lda integer +! the leading dimension of the array a . +! +! n integer +! the order of the matrix a . +! +! ipvt integer(n) +! the pivot vector from sgeco or sgefa. +! +! b real(n) +! the right hand side vector. +! +! job integer +! = 0 to solve a*x = b , +! = nonzero to solve trans(a)*x = b where +! trans(a) is the transpose. +! +! on return +! +! b the solution vector x . +! +! error condition +! +! a division by zero will occur if the input factor contains a +! zero on the diagonal. technically this indicates singularity +! but it is often caused by improper arguments or improper +! setting of lda . it will not occur if the subroutines are +! called correctly and if sgeco has set rcond .gt. 0.0 +! or sgefa has set info .eq. 0 . +! +! to compute inverse(a) * c where c is a matrix +! with p columns +! call sgeco(a,lda,n,ipvt,rcond,z) +! if (rcond is too small) go to ... +! do 10 j = 1, p +! call sgesl(a,lda,n,ipvt,c(1,j),0) +! 10 continue +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas saxpy,sdot +! +! internal variables +! +! real sdot,t ! rce 2005-jan-21 - module conversion + real t + integer k,kb,l,nm1 +! + nm1 = n - 1 + if (job .ne. 0) go to 50 +! +! job = 0 , solve a * x = b +! first solve l*y = b +! + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + 10 continue + call saxpy(n-k,t,a(k+1,k),1,b(k+1),1) + 20 continue + 30 continue +! +! now solve u*x = y +! + do 40 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/a(k,k) + t = -b(k) + call saxpy(k-1,t,a(1,k),1,b(1),1) + 40 continue + go to 100 + 50 continue +! +! job = nonzero, solve trans(a) * x = b +! first solve trans(u)*y = b +! + do 60 k = 1, n + t = sdot(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + 60 continue +! +! now solve trans(l)*x = y +! + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + b(k) = b(k) + sdot(n-k,a(k+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + return + end subroutine sgesl + + real function sdot(n,sx,incx,sy,incy) +! +! forms the dot product of two vectors. +! uses unrolled loops for increments equal to one. +! jack dongarra, linpack, 3/11/78. +! modified 12/3/93, array(1) declarations changed to array(*) +! + real sx(*),sy(*),stemp + integer i,incx,incy,ix,iy,m,mp1,n +! + stemp = 0.0e0 + sdot = 0.0e0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +! +! code for unequal increments or equal increments +! not equal to 1 +! + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + stemp = stemp + sx(ix)*sy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + sdot = stemp + return +! +! code for both increments equal to 1 +! +! +! clean-up loop +! + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + stemp = stemp + sx(i)*sy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) + & + sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4) + 50 continue + 60 sdot = stemp + return + end function sdot + + subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job) + integer lda,n,ml,mu,ipvt(1),job + real abd(lda,1),b(1) +! +! sgbsl solves the real band system +! a * x = b or trans(a) * x = b +! using the factors computed by sgbco or sgbfa. +! +! on entry +! +! abd real(lda, n) +! the output from sgbco or sgbfa. +! +! lda integer +! the leading dimension of the array abd . +! +! n integer +! the order of the original matrix. +! +! ml integer +! number of diagonals below the main diagonal. +! +! mu integer +! number of diagonals above the main diagonal. +! +! ipvt integer(n) +! the pivot vector from sgbco or sgbfa. +! +! b real(n) +! the right hand side vector. +! +! job integer +! = 0 to solve a*x = b , +! = nonzero to solve trans(a)*x = b , where +! trans(a) is the transpose. +! +! on return +! +! b the solution vector x . +! +! error condition +! +! a division by zero will occur if the input factor contains a +! zero on the diagonal. technically this indicates singularity +! but it is often caused by improper arguments or improper +! setting of lda . it will not occur if the subroutines are +! called correctly and if sgbco has set rcond .gt. 0.0 +! or sgbfa has set info .eq. 0 . +! +! to compute inverse(a) * c where c is a matrix +! with p columns +! call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z) +! if (rcond is too small) go to ... +! do 10 j = 1, p +! call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) +! 10 continue +! +! linpack. this version dated 08/14/78 . +! cleve moler, university of new mexico, argonne national lab. +! +! subroutines and functions +! +! blas saxpy,sdot +! fortran min0 +! +! internal variables +! +! real sdot,t ! rce 2005-jan-21 - module conversion + real t + integer k,kb,l,la,lb,lm,m,nm1 +! + m = mu + ml + 1 + nm1 = n - 1 + if (job .ne. 0) go to 50 +! +! job = 0 , solve a * x = b +! first solve l*y = b +! + if (ml .eq. 0) go to 30 + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + lm = min0(ml,n-k) + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + 10 continue + call saxpy(lm,t,abd(m+1,k),1,b(k+1),1) + 20 continue + 30 continue +! +! now solve u*x = y +! + do 40 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/abd(m,k) + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = -b(k) + call saxpy(lm,t,abd(la,k),1,b(lb),1) + 40 continue + go to 100 + 50 continue +! +! job = nonzero, solve trans(a) * x = b +! first solve trans(u)*y = b +! + do 60 k = 1, n + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = sdot(lm,abd(la,k),1,b(lb),1) + b(k) = (b(k) - t)/abd(m,k) + 60 continue +! +! now solve trans(l)*x = y +! + if (ml .eq. 0) go to 90 + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + lm = min0(ml,n-k) + b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + return + end subroutine sgbsl + + + end module module_cmu_svode_solver diff --git a/wrfv2_fire/chem/module_ctrans_aqchem.F b/wrfv2_fire/chem/module_ctrans_aqchem.F new file mode 100755 index 00000000..d8698eb1 --- /dev/null +++ b/wrfv2_fire/chem/module_ctrans_aqchem.F @@ -0,0 +1,1945 @@ +MODULE module_ctrans_aqchem +!*********************************************************************** +! Portions of Models-3/CMAQ software were developed or based on * +! information from various groups: Federal Government employees, * +! contractors working on a United States Government contract, and * +! non-Federal sources (including research institutions). These * +! research institutions have given the Government permission to * +! use, prepare derivative works, and distribute copies of their * +! work in Models-3/CMAQ to the public and to permit others to do * +! so. EPA therefore grants similar permissions for use of the * +! Models-3/CMAQ software, but users are requested to provide copies * +! of derivative works to the Government without restrictions as to * +! use by others. Users are responsible for acquiring their own * +! copies of commercial software associated with Models-3/CMAQ and * +! for complying with vendor requirements. Software copyrights by * +! the MCNC Environmental Modeling Center are used with their * +! permissions subject to the above restrictions. * +!*********************************************************************** + +! RCS file, release, date & time of last delta, author, state, [and locker] +! $Header: /project/work/rep/CCTM/src/cloud/cloud_radm/aqchem.F,v 1.19 2002/12/12 20:08:47 sjr Exp $ + +! what(1) key, module and SID; SCCS file; date and time of last delta: +! + +CONTAINS + SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & + WCAVG, WTAVG, AIRM, ALFA0, ALFA2, ALFA3, GAS, & + AEROSOL, GASWDEP, AERWDEP, HPWDEP ) + +!----------------------------------------------------------------------- +! +! DESCRIPTION: +! Compute concentration changes in cloud due to aqueous chemistry, +! scavenging and wet deposition amounts. +! +! Revision History: +! No Date Who What +! -- -------- --- ----------------------------------------- +! 0 / /86 CW BEGIN PROGRAM - Walceks's Original Code +! 1 / /86 RB INCORPORATE INTO RADM +! 2 03/23/87 DH REFORMAT +! 3 04/11/88 SJR STREAMLINED CODE - ADDED COMMENTS +! 4 08/27/88 SJR COMMENTS, MODIFIED FOR RPM +! 4a 03/15/96 FSB Scanned hard copy to develop Models3 +! Version. +! 5 04/24/96 FSB Made into Models3 Format +! 6 02/18/97 SJR Revisions to link with Models3 +! 7 08/12/97 SJR Revised for new concentration units (moles/mole) +! and new treatment of nitrate and nitric acid +! 8 01/15/98 sjr revised to add new aitken mode scavenging +! and aerosol number scavenging +! 9 12/15/98 David Wong at LM: +! -- change division of XL, TEMP to multiplication of XL, TEMP +! reciprocal, respectively +! -- change / TOTOX / TSIV to / ( TOTOX * TSIV ) +! 10 03/18/99 David Wong at LM: +! -- removed "* 1.0" redundant calculation at TEMP1 calculation +! 11 04/27/00 sjr Added aerosol surface area as modeled species +! +! Reference: +! Walcek & Taylor, 1986, A theoretical Method for computing +! vertical distributions of acidity and sulfate within cumulus +! clouds, J. Atmos Sci., Vol. 43, no. 4 pp 339 - 355 +! +! Called by: AQMAP +! +! Calls the following subroutines: none +! +! Calls the following functions: HLCONST +! +! ARGUMENTS TYPE I/O DESCRIPTION +! --------- ---- ------------ -------------------------------- +! GAS(ngas) real input&output Concentration for species i=1,11 +! GASWDEP(ngas) real output wet deposition for species +! (1) = SO2 conc (mol/mol of S02) +! (2) = HNO3 conc (mol/mol of HNO3) +! (3) = N2O5 conc (mol/mol of N2O5) +! (4) = CO2 conc (mol/mol of CO2) +! (5) = NH3 conc (mol/mol of NH3) +! (6) = H2O2 conc (mol/mol of H2O2) +! (7) = O3 conc (mol/mol of O3) +! (8) = FOA conc (mol/mol of FOA) +! (9) = MHP conc (mol/mol of MHP) +! (10)= PAA conc (mol/mol of PAA) +! (11)= H2SO4 conc (mol/mol of H2SO4) +! +! AEROSOL(naer) real input&output Concentration for species i=1,21 +! AERWDEP(naer) real output wet deposition for species +! (1) = SO4AKN conc (mol/mol) +! (2) = SO4ACC conc (mol/mol) +! (3) = NH4AKN conc (mol/mol) +! (4) = NH4ACC conc (mol/mol) +! (5) = NO3AKN conc (mol/mol) +! (6) = NO3ACC conc (mol/mol) +! (7) = NO3COR conc (mol/mol) +! (8) = ORGAKN conc (mol/mol) +! (9) = ORGACC conc (mol/mol) +! (10)= PRIAKN conc (mol/mol) +! (11)= PRIACC conc (mol/mol) +! (12)= PRICOR conc (mol/mol) +! (13)= CACO3 conc (mol/mol) +! (14)= MGCO3 conc (mol/mol) +! (15)= NACL conc (mol/mol) +! (16)= A3FE conc (mol/mol) +! (17)= B2MN conc (mol/mol) +! (18)= KCL conc (mol/mol) +! (19)= NUMAKN conc (#/mol) +! (20)= NUMACC conc (#/mol) +! (21)= NUMCOR conc (#/mol) +! (22)= SRFAKN conc (m2/mol) +! (23)= SRFACC conc (m2/mol) +! +!----------------------------------------------------------------------- + + IMPLICIT NONE + + + +! INCLUDE 'CONST.EXT' ! constants +! INCLUDE FILE CONST.EXT +! Contains: Fundamental constants for air quality modeling +! Dependent Upon: none +! Revision History: +! Adapted 6/92 by CJC from ROM's PI.EXT. +! 3/1/93 John McHenry - include constants needed by LCM aqueous chemistry +! 9/93 by John McHenry - include additional constants needed for FMEM clouds +! and aqueous chemistry + +! 3/4/96 Dr. Francis S. Binkowski - reflect current Models3 view that MKS +! units should be used wherever possible and that sources be documented. +! Some variables have been added, names changed, and values revised. + +! 3/7/96 - add universal gas constant and compute gas constant in chemical +! form. TWOPI is now calculated rather than input. + +! 3/13/96 - group declarations and parameter statements +! 9/13/96 - include more physical constants +! 12/24/96 - eliminate silly EPSILON, AMISS +! 1/06/97 - eliminate most derived constants - YOJ +! 1/17/97 (comments only) to provide numerical values as reference - DWB + +! FSB References: + +! CRC76, CRC Handbook of Chemistry and Physics (76th Ed), +! CRC Press, 1995 +! Hobbs, P.V. Basic Physical Chemistry for the Atmospheric Sciences, +! Cambridge Univ. Press, 206 pp, 1995. +! Snyder, J.P., Map Projections-A Working Manual, U.S. Geological Survey +! Paper 1395 U.S.GPO, Washington, DC, 1987. +! Stull, R. B., An Introduction to Bounday Layer Meteorology, Kluwer, +! Dordrecht, 1988 +!....................................................................... + + +! Geometric Constants: + + REAL*8 PI ! pi (single precision 3.141593) + PARAMETER ( PI = 3.14159265358979324 ) + + REAL PI180 ! pi/180 [ rad/deg ] + PARAMETER ( PI180 = PI / 180.0 ) + +! Geodetic Constants: + + REAL REARTH ! radius of the earth [ m ] + ! FSB: radius of sphere having same surface area as + ! Clarke ellipsoid of 1866 ( Source: Snyder, 1987) + PARAMETER ( REARTH = 6370997.0 ) + + REAL SIDAY ! length of a sidereal day [ sec ] + ! FSB: Source: CRC76 pp. 14-6 + PARAMETER ( SIDAY = 86164.09 ) + + REAL GRAV ! mean gravitational acceleration [ m/sec**2 ] + ! FSB: Value is mean of polar and equatorial values. + ! Source: CRC Handbook (76th Ed) pp. 14-6 + PARAMETER ( GRAV = 9.80622 ) + + REAL DG2M ! latitude degrees to meters + PARAMETER ( DG2M = REARTH * PI180 ) + +! Solar Constant: + REAL SOLCNST ! Solar constant [ W/m**2 ], p14-2 CRC76 + PARAMETER ( SOLCNST = 1373.0 ) + +! Fundamental Constants: ( Source: CRC76, pp. 1-1 to 1-6) + + REAL AVO ! Avogadro's Constant [ number/mol ] + PARAMETER ( AVO = 6.0221367E23 ) + + REAL RGASUNIV ! universal gas constant [ J/mol-K ] + PARAMETER ( RGASUNIV = 8.314510 ) + + REAL STDATMPA ! standard atmosphere [ Pa ] + PARAMETER ( STDATMPA = 101325.0 ) + + REAL STDTEMP ! Standard Temperature [ K ] + PARAMETER ( STDTEMP = 273.15 ) + + REAL STFBLZ ! Stefan-Boltzmann [ W/(m**2 K**4) ] + PARAMETER ( STFBLZ = 5.67051E-8 ) + +! FSB Non-MKS + + REAL MOLVOL ! Molar volume at STP [ L/mol ] Non MKS units + PARAMETER ( MOLVOL = 22.41410 ) + +! Atmospheric Constants: + + REAL MWAIR ! mean molecular weight for dry air [ g/mol ] + ! FSB: 78.06% N2, 21% O2, and 0.943% A on a mole + ! fraction basis ( Source : Hobbs, 1995) pp. 69-70 + PARAMETER ( MWAIR = 28.9628 ) + + REAL RDGAS ! dry-air gas constant [ J / kg-K ] + PARAMETER ( RDGAS = 1.0E3 * RGASUNIV / MWAIR ) ! 287.07548994 + + REAL MWWAT ! mean molecular weight for water vapor [ g/mol ] + PARAMETER ( MWWAT = 18.0153 ) + + REAL RWVAP ! gas constant for water vapor [ J/kg-K ] + PARAMETER ( RWVAP = 1.0E3 * RGASUNIV / MWWAT ) ! 461.52492604 + +! FSB NOTE: CPD, CVD, CPWVAP and CVWVAP are calculated assuming dry air and +! water vapor are classical ideal gases, i.e. vibration does not contribute +! to internal energy. + + REAL CPD ! specific heat of dry air at constant pressure [ J/kg-K ] + PARAMETER ( CPD = 7.0 * RDGAS / 2.0 ) ! 1004.7642148 + + REAL CVD ! specific heat of dry air at constant volume [ J/kg-K ] + PARAMETER ( CVD = 5.0 * RDGAS / 2.0 ) ! 717.68872485 + + REAL CPWVAP ! specific heat for water vapor at constant pressure [ J/kg-K ] + PARAMETER ( CPWVAP = 4.0 * RWVAP ) ! 1846.0997042 + + REAL CVWVAP ! specific heat for water vapor at constant volume [ J/kg-K ] + PARAMETER ( CVWVAP = 3.0 * RWVAP ) ! 1384.5747781 + + REAL VP0 ! vapor press of water at 0 C [ Pa ] Source: CRC76 pp. 6-15 + PARAMETER ( VP0 = 611.29 ) + +! FSB The following values are taken from p. 641 of Stull (1988): + + REAL LV0 ! latent heat of vaporization of water at 0 C [ J/kg ] + PARAMETER ( LV0 = 2.501E6 ) + + REAL DLVDT ! Rate of change of latent heat of vaporization with + ! respect to temperature [ J/kg-K ] + PARAMETER ( DLVDT = 2370.0 ) + + REAL LF0 ! latent heat of fusion of water at 0 C [ J/kg ] + PARAMETER ( LF0 = 3.34E5 ) + +!....................................................................... +! INCLUDE 'PARMS3.EXT' ! I/O parameters definitions +! INCLUDE 'AQ_PARAMS2.EXT' ! aqueous chemistry shared parameters + + +! Aqeuous species pointers INCLUDE File + +!...........PARAMETERS and their descriptions: + + INTEGER NGAS ! number of gas phase species for AQCHEM + PARAMETER ( NGAS = 11 ) + + INTEGER NAER ! number of aerosol species for AQCHEM + PARAMETER ( NAER = 23 ) + +!...pointers for the AQCHEM array GAS + + INTEGER LSO2 ! local pointer to SO2 + PARAMETER ( LSO2 = 1 ) + + INTEGER LHNO3 ! local pointer to HNO3 + PARAMETER ( LHNO3 = 2 ) + + INTEGER LN2O5 ! local pointer to N2O5 + PARAMETER ( LN2O5 = 3 ) + + INTEGER LCO2 ! local pointer to CO2 + PARAMETER ( LCO2 = 4 ) + + INTEGER LNH3 ! local pointer to NH3 + PARAMETER ( LNH3 = 5 ) + + INTEGER LH2O2 ! local pointer to H2O2 + PARAMETER ( LH2O2 = 6 ) + + INTEGER LO3 ! local pointer to O3 + PARAMETER ( LO3 = 7 ) + + INTEGER LFOA ! local pointer to FOA + PARAMETER ( LFOA = 8 ) + + INTEGER LMHP ! local pointer to MHP + PARAMETER ( LMHP = 9 ) + + INTEGER LPAA ! local pointer to PAA + PARAMETER ( LPAA = 10 ) + + INTEGER LH2SO4 ! local pointer to H2SO4 + PARAMETER ( LH2SO4 = 11 ) + +!...pointers for the AQCHEM array AEROSOL + + INTEGER LSO4AKN ! local pointer to SO4I aerosol + PARAMETER ( LSO4AKN = 1 ) + + INTEGER LSO4ACC ! local pointer to SO4 aerosol + PARAMETER ( LSO4ACC = 2 ) + + INTEGER LNH4AKN ! local pointer to NH4I aerosol + PARAMETER ( LNH4AKN = 3 ) + + INTEGER LNH4ACC ! local pointer to NH4 aerosol + PARAMETER ( LNH4ACC = 4 ) + + INTEGER LNO3AKN ! local pointer to NO3I aerosol + PARAMETER ( LNO3AKN = 5 ) + + INTEGER LNO3ACC ! local pointer to NO3 aerosol + PARAMETER ( LNO3ACC = 6 ) + + INTEGER LNO3COR ! local pointer to course aerosol nitrate + PARAMETER ( LNO3COR = 7 ) + + INTEGER LORGAKN ! local pointer to organic I aerosol + PARAMETER ( LORGAKN = 8 ) + + INTEGER LORGACC ! local pointer to organic aerosol + PARAMETER ( LORGACC = 9 ) + + INTEGER LPRIAKN ! local pointer to primary I aerosol + PARAMETER ( LPRIAKN = 10 ) + + INTEGER LPRIACC ! local pointer to primary aerosol + PARAMETER ( LPRIACC = 11 ) + + INTEGER LPRICOR ! local pointer to primary I aerosol + PARAMETER ( LPRICOR = 12 ) + + INTEGER LCACO3 ! local pointer to CaCO3 aerosol + PARAMETER ( LCACO3 = 13 ) + + INTEGER LMGCO3 ! local pointer to MgCO3 aerosol + PARAMETER ( LMGCO3 = 14 ) + + INTEGER LNACL ! local pointer to NaCl aerosol + PARAMETER ( LNACL = 15 ) + + INTEGER LA3FE ! local pointer to Fe+++ aerosol + PARAMETER ( LA3FE = 16 ) + + INTEGER LB2MN ! local pointer to Mn++ aerosol + PARAMETER ( LB2MN = 17 ) + + INTEGER LKCL ! local pointer to NaCl aerosol + PARAMETER ( LKCL = 18 ) + + INTEGER LNUMAKN ! local pointer to # Aitken aerosol + PARAMETER ( LNUMAKN = 19 ) + + INTEGER LNUMACC ! local pointer to # accumulation aerosol + PARAMETER ( LNUMACC = 20 ) + + INTEGER LNUMCOR ! local pointer to # coarse aerosol + PARAMETER ( LNUMCOR = 21 ) + + INTEGER LSRFAKN ! local pointer to sfc area Aitken aerosol + PARAMETER ( LSRFAKN = 22 ) + + INTEGER LSRFACC ! local pntr to sfc area accumulation aerosol + PARAMETER ( LSRFACC = 23 ) + +!...surrogate names, their background values, and units +!... for AQCHEM's GAS species + + CHARACTER*16 SGRGAS( NGAS ) ! surrogate name for gases + SAVE SGRGAS + + REAL BGNDGAS( NGAS ) ! background values for each gas + SAVE BGNDGAS + + CHARACTER*16 BUNTSGAS( NGAS ) ! units of bkgnd values + SAVE BUNTSGAS + + DATA SGRGAS( 1 ), BGNDGAS( 1 ) /'SO2 ', 0.0 / + DATA SGRGAS( 2 ), BGNDGAS( 2 ) /'HNO3 ', 0.0 / + DATA SGRGAS( 3 ), BGNDGAS( 3 ) /'N2O5 ', 0.0 / + DATA SGRGAS( 4 ), BGNDGAS( 4 ) /'CO2 ', 340.0 / + DATA SGRGAS( 5 ), BGNDGAS( 5 ) /'NH3 ', 0.0 / + DATA SGRGAS( 6 ), BGNDGAS( 6 ) /'H2O2 ', 0.0 / + DATA SGRGAS( 7 ), BGNDGAS( 7 ) /'O3 ', 0.0 / + DATA SGRGAS( 8 ), BGNDGAS( 8 ) /'FOA ', 0.0 / + DATA SGRGAS( 9 ), BGNDGAS( 9 ) /'MHP ', 0.0 / + DATA SGRGAS( 10 ), BGNDGAS( 10 ) /'PAA ', 0.0 / + DATA SGRGAS( 11 ), BGNDGAS( 11 ) /'H2SO4 ', 0.0 / + + DATA BUNTSGAS( 1 ) / 'ppm' / + DATA BUNTSGAS( 2 ) / 'ppm' / + DATA BUNTSGAS( 3 ) / 'ppm' / + DATA BUNTSGAS( 4 ) / 'ppm' / + DATA BUNTSGAS( 5 ) / 'ppm' / + DATA BUNTSGAS( 6 ) / 'ppm' / + DATA BUNTSGAS( 7 ) / 'ppm' / + DATA BUNTSGAS( 8 ) / 'ppm' / + DATA BUNTSGAS( 9 ) / 'ppm' / + DATA BUNTSGAS( 10 ) / 'ppm' / + DATA BUNTSGAS( 11 ) / 'ppm' / + +!...surrogate names, their background values, units, and molecular weights +!... for AQCHEM's AEROSOL species + + CHARACTER*16 SGRAER( NAER ) ! surrogate name for aerosols + SAVE SGRAER + + REAL SGRAERMW( NAER ) ! molecular weight for aerosol species + SAVE SGRAERMW + + CHARACTER*16 BUNTSAER( NAER ) ! units of bkgnd values + SAVE BUNTSAER + + REAL BGNDAER( NAER ) ! bkground vals each aerosols + SAVE BGNDAER + + DATA SGRAER( 1 ), SGRAERMW( 1 ) / 'SO4_AITKEN ' , 96.0 / + DATA SGRAER( 2 ), SGRAERMW( 2 ) / 'SO4_ACCUM ' , 96.0 / + DATA SGRAER( 3 ), SGRAERMW( 3 ) / 'NH4_AITKEN ' , 18.0 / + DATA SGRAER( 4 ), SGRAERMW( 4 ) / 'NH4_ACCUM ' , 18.0 / + DATA SGRAER( 5 ), SGRAERMW( 5 ) / 'NO3_AITKEN ' , 62.0 / + DATA SGRAER( 6 ), SGRAERMW( 6 ) / 'NO3_ACCUM ' , 62.0 / + DATA SGRAER( 7 ), SGRAERMW( 7 ) / 'NO3_COARSE ' , 62.0 / + DATA SGRAER( 8 ), SGRAERMW( 8 ) / 'ORG_AITKEN ' , 120.0 / + DATA SGRAER( 9 ), SGRAERMW( 9 ) / 'ORG_ACCUM ' , 120.0 / + DATA SGRAER( 10 ), SGRAERMW( 10 ) / 'PRI_AITKEN ' , 200.0 / + DATA SGRAER( 11 ), SGRAERMW( 11 ) / 'PRI_ACCUM ' , 200.0 / + DATA SGRAER( 12 ), SGRAERMW( 12 ) / 'PRI_COARSE ' , 100.0 / + DATA SGRAER( 13 ), SGRAERMW( 13 ) / 'CACO3 ' , 100.1 / + DATA SGRAER( 14 ), SGRAERMW( 14 ) / 'MGCO3 ' , 84.3 / + DATA SGRAER( 15 ), SGRAERMW( 15 ) / 'NACL ' , 58.4 / + DATA SGRAER( 16 ), SGRAERMW( 16 ) / 'A3FE ' , 55.8 / + DATA SGRAER( 17 ), SGRAERMW( 17 ) / 'B2MN ' , 54.9 / + DATA SGRAER( 18 ), SGRAERMW( 18 ) / 'KCL ' , 74.6 / + DATA SGRAER( 19 ), SGRAERMW( 19 ) / 'NUM_AITKEN ' , 1.0 / + DATA SGRAER( 20 ), SGRAERMW( 20 ) / 'NUM_ACCUM ' , 1.0 / + DATA SGRAER( 21 ), SGRAERMW( 21 ) / 'NUM_COARSE ' , 1.0 / + DATA SGRAER( 22 ), SGRAERMW( 22 ) / 'SRF_AITKEN ' , 1.0 / + DATA SGRAER( 23 ), SGRAERMW( 23 ) / 'SRF_ACCUM ' , 1.0 / + + DATA BGNDAER( 1 ), BUNTSAER( 1 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 2 ), BUNTSAER( 2 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 3 ), BUNTSAER( 3 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 4 ), BUNTSAER( 4 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 5 ), BUNTSAER( 5 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 6 ), BUNTSAER( 6 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 7 ), BUNTSAER( 7 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 8 ), BUNTSAER( 8 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 9 ), BUNTSAER( 9 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 10 ), BUNTSAER( 10 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 11 ), BUNTSAER( 11 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 12 ), BUNTSAER( 12 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 13 ), BUNTSAER( 13 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 14 ), BUNTSAER( 14 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 15 ), BUNTSAER( 15 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 16 ), BUNTSAER( 16 ) / 0.010, 'ug/m3' / + DATA BGNDAER( 17 ), BUNTSAER( 17 ) / 0.005, 'ug/m3' / + DATA BGNDAER( 18 ), BUNTSAER( 18 ) / 0.0, 'ug/m3' / + DATA BGNDAER( 19 ), BUNTSAER( 19 ) / 0.0, '#/m3' / + DATA BGNDAER( 20 ), BUNTSAER( 20 ) / 0.0, '#/m3' / + DATA BGNDAER( 21 ), BUNTSAER( 21 ) / 0.0, '#/m3' / + DATA BGNDAER( 22 ), BUNTSAER( 22 ) / 0.0, 'm2/m3' / + DATA BGNDAER( 23 ), BUNTSAER( 23 ) / 0.0, 'm2/m3' / + CHARACTER*120 XMSG ! Exit status message + DATA XMSG / ' ' / + +!...........PARAMETERS and their descriptions: + + INTEGER NUMOX ! number of oxidizing reactions + PARAMETER ( NUMOX = 5 ) + + REAL H2ODENS ! density of water at 20 C and 1 ATM + PARAMETER ( H2ODENS = 1000.0 ) ! (kg/m3) + + INTEGER NLIQS ! number of liquid phase species + PARAMETER ( NLIQS = 33 ) + + REAL ONETHIRD ! 1/3 + PARAMETER ( ONETHIRD = 1.0 / 3.0 ) + + REAL TWOTHIRDS ! 2/3 + PARAMETER ( TWOTHIRDS = 2.0 / 3.0 ) + + REAL CONCMIN ! minimum concentration + PARAMETER ( CONCMIN = 1.0E-30 ) + + REAL SEC2HR ! convert seconds to hours + PARAMETER ( SEC2HR = 1.0 / 3600.0 ) + +!...........ARGUMENTS and their descriptions + + INTEGER JDATE ! current model date, coded YYYYDDD + INTEGER JTIME ! current model time, coded HHMMSS + + REAL AIRM ! total air mass in cloudy layers (mol/m2) + REAL ALFA0 ! scav coef for aitken aerosol number + REAL ALFA2 ! scav coef for aitken aerosol sfc area + REAL ALFA3 ! scav coef for aitken aerosol mass + REAL HPWDEP ! hydrogen wet deposition (mm mol/liter) + REAL PRCRATE ! precip rate (mm/hr) + REAL PRES_PA ! pressure (Pa) + REAL TAUCLD ! timestep for cloud (s) + REAL TEMP ! temperature (K) + REAL WCAVG ! liquid water content (kg/m3) + REAL WTAVG ! total water content (kg/m3) + REAL GAS ( NGAS ) ! gas phase concentrations (mol/molV) + REAL AEROSOL( NAER ) ! aerosol concentrations (mol/molV) + REAL GASWDEP( NGAS ) ! gas phase wet deposition array (mm mol/liter) + REAL AERWDEP( NAER ) ! aerosol wet deposition array (mm mol/liter) + +!...........LOCAL VARIABLES (scalars) and their descriptions: + + CHARACTER*16 PNAME ! driver program name + DATA PNAME / 'AQCHEM' / + SAVE PNAME + + INTEGER I20C ! loop counter for do loop 20 + INTEGER I30C ! loop counter for do loop 30 + INTEGER ITERAT ! # iterations of aqueaous chemistry solver + INTEGER I7777C ! aqueous chem iteration counter + INTEGER ICNTAQ ! aqueous chem iteration counter + INTEGER LIQ ! loop counter for liquid species + INTEGER IOX ! index over oxidation reactions + + REAL atrah + REAL DEPSUM + REAL BETASO4 + REAL A ! iron's anion concentration + REAL AC ! H+ concentration in cloudwater (mol/liter) + REAL ACT1 ! activity corretion factor!single ions + REAL ACT2 ! activity factor correction!double ions + REAL ACTB ! + REAL AE ! guess for H+ conc in cloudwater (mol/liter) + REAL B ! manganese's anion concentration + REAL PRES_ATM ! pressure (Atm) + REAL BB ! lower limit guess of cloudwater pH + REAL CA ! Calcium conc in cloudwater (mol/liter) + REAL CAA ! inital Calcium in cloudwater (mol/liter) + REAL NO3CORA ! initial NO3COR in cloudwater (mol/liter) + REAL CL ! Cl- conc in cloudwater (mol/liter) + REAL CLA ! initial Cl in cloudwater (mol/liter) + REAL CO2H ! Henry's Law constant for CO2 + REAL CO21 ! First dissociation constant for CO2 + REAL CO22 ! Second dissociation constant for CO2 + REAL CO212 ! CO21*CO22 + REAL CO212H ! CO2H*CO21*CO22 + REAL CO21H ! CO2H*CO21 + REAL CO2L ! CO2 conc in cloudwater (mol/liter) + REAL CO3 ! CO3= conc in cloudwater (mol/liter) + REAL CO3A ! initial CO3 in cloudwater (mol/liter) + REAL CTHK1 ! cloud thickness (m) + REAL DTRMV ! + REAL DTS6 ! + REAL EBETASO4T ! EXP( -BETASO4 * TAUCLD ) + REAL EALFA0T ! EXP( -ALFA0 * TAUCLD ) + REAL EALFA2T ! EXP( -ALFA2 * TAUCLD ) + REAL EALFA3T ! EXP( -ALFA3 * TAUCLD ) + REAL FA ! functional value ?? + REAL FB ! functional value ?? + REAL FE ! Fe+++ conc in cloudwater (mol/liter) + REAL FEA ! initial Fe in cloudwater (mol/liter) + REAL FNH3 ! frac weight of NH3 to total ammonia + REAL FNH4ACC ! frac weight of NH4 acc to total ammonia + REAL FHNO3 ! frac weight of HNO3 to total NO3 + REAL FNO3ACC ! frac weight of NO3 acc to total NO3 + REAL FNO3COR ! frac weight of NO3 cor to total NO3 + REAL FRACACC ! frac ACC that was from accum mode + REAL FRACCOR ! frac NO3 that was from coarse mode + REAL FRACLIQ ! fraction of water in liquid form + REAL FOA1 ! First dissociation constant for FOA + REAL FOAH ! Henry's Law constant for FOA + REAL FOA1H ! FOAH*FOA1 + REAL FOAL ! FOA conc in cloudwater (mol/liter) + REAL FTST ! + REAL GM ! + REAL GM1 ! + REAL GM1LOG ! + REAL GM2 ! activity correction factor + REAL GM2LOG ! + REAL HA ! + REAL HB ! + REAL H2OW ! + REAL H2O2H ! Henry's Law Constant for H2O2 + REAL H2O2L ! H2O2 conc in cloudwater (mol/liter) + REAL HCO2 ! HCO2 conc in cloudwater (mol/liter) + REAL HCO3 ! HCO3 conc in cloudwater (mol/liter) + REAL HNO3H ! Henry's Law Constant for HNO3 + REAL HNO31 ! First dissociation constant for HNO3 + REAL HNO31H ! + REAL HNO3L ! HNO3 conc in cloudwater (mol/liter) + REAL HSO3 ! HSO3 conc in cloudwater (mol/liter) + REAL HSO4 ! HSO4 concn in cloudwater (mol/liter) + REAL HTST ! + REAL K ! K conc in cloudwater (mol/liter) + REAL KA ! initial K in cloudwater (mol/liter) + REAL LGTEMP ! log of TEMP + REAL M3NEW ! accumulation mode mass at time t + REAL M3OLD ! accumulation mode mass at time 0 + REAL MG ! + REAL MGA ! inital Mg in cloudwater (mol/liter) + REAL MHPH ! Henry's Law Constant for MHP + REAL MHPL ! MHP conc in cloudwater (mol/liter) + REAL MN ! Mn++ conc in cloudwater (mol/liter) + REAL MNA ! initial Mn in cloudwater (mol/liter) + REAL NA ! Na conc in cloudwater (mol/liter) + REAL NAA ! initial Na in cloudwater (mol/liter) + REAL NH31 ! First dissociation constant for NH3 + REAL NH3H ! Henry's Law Constant for NH3 + REAL NH3DH20 ! + REAL NH31HDH ! + REAL NH3L ! NH3 conc in cloudwater (mol/liter) + REAL NH4 ! NH4+ conc in cloudwater (mol/liter) + REAL NH4AKNA ! init NH4 akn conc in cloudwater (mol/liter) + REAL NH4ACCA ! init NH4 acc conc in cloudwater (mol/liter) + REAL NITAER ! total aerosol nitrate + REAL NO3 ! NO3 conc in cloudwater (mol/liter) + REAL NO3ACCA ! init NO3 acc conc in cloudwater (mol/liter) + REAL NO3AKNA ! init NO3 akn conc in cloudwater (mol/liter) + REAL O3H ! Henry's Law Constant for O3 + REAL O3L ! O3 conc in cloudwater (mol/liter) + REAL OH ! OH conc in cloudwater (mol/liter) + REAL ORGN ! ORGANIC aerosol in cloudwater (mol/liter) + REAL ORGACCA ! init ORG ACC aerosol in cloudwater (mol/liter) + REAL ORGAKNA ! init ORG AKN aerosol in cloudwater (mol/liter) + REAL PAAH ! Henry's Law Constant for PAA + REAL PAAL ! PAA conc in cloudwater (mol/liter) + REAL PCO20 ! total CO2 partial pressure (atm) + REAL PCO2F ! gas only CO2 partial pressure (atm) + REAL PFOA0 ! total ORGANIC acid partial pressure (atm) + REAL PFOAF ! gas only ORGANIC ACID partial press (atm) + REAL PH2O20 ! total H2O2 partial pressure (atm) + REAL PH2O2F ! gas only H2O2 partial pressure (atm) + REAL PHNO30 ! total HNO3 partial pressure (atm) + REAL PHNO3F ! gas only HNO3 partial pressure (atm) + REAL PMHP0 ! total MHP partial pressure (atm) + REAL PMHPF ! gas only MHP partial pressure (atm) + REAL PNH30 ! total NH3 partial pressure (atm) + REAL PNH3F ! gas only NH3 partial pressure (atm) + REAL PO30 ! total O3 partial pressure (atm) + REAL PO3F ! gas only O3 partial pressure (atm) + REAL PPAA0 ! total PAA partial pressure (atm) + REAL PPAAF ! gas only PAA partial pressure (atm) + REAL PRIM ! PRIMARY acc+akn aerosol in cloudwater (mol/liter) + REAL PRIMCOR ! PRIMARY coarse aerosol in cloudwater (mol/liter) + REAL PRIACCA ! init PRI ACC aerosol in cloudwater (mol/liter) + REAL PRIAKNA ! init PRI AKN aerosol in cloudwater (mol/liter) + REAL PRICORA ! init PRI COR aerosol in cloudwater (mol/liter) + REAL PSO20 ! total SO2 partial pressure (atm) + REAL PSO2F ! gas only SO2 partial pressure (atm) + REAL RATE ! + REAL RECIPA1 ! + REAL RECIPA2 ! + REAL RECIPAP1 ! one over pressure (/atm) + REAL RH2O2 ! + REAL RMHP ! + REAL RPAA ! + REAL RT ! gas const * temperature (liter atm/mol) + REAL SCVEFF ! Scavenging efficiency (%) + DATA SCVEFF / 100.0 / ! currently set to 100% + SAVE SCVEFF + REAL SIV ! dissolved so2 in cloudwater (mol/liter) + REAL SK6 ! + REAL SK6TS6 ! + REAL SO21 ! First dissociation constant for SO2 + REAL SO22 ! Second dissociation constant for SO2 + REAL SO2H ! Henry's Law Constant for SO2 + REAL SO212 ! SO21*SO22 + REAL SO212H ! SO21*SO22*SO2H + REAL SO21H ! SO21*SO2H + REAL SO2L ! SO2 conc in cloudwater (mol/liter) + REAL SO3 ! SO3= conc in cloudwater (mol/liter) + REAL SO4 ! SO4= conc in cloudwater (mol/liter) + REAL STION ! ionic strength + REAL TAC ! + REAL TEMP1 ! + REAL TIMEW ! cloud chemistry clock (sec) + REAL TOTOX ! + REAL TOTAMM ! total ammonium + REAL TOTNIT ! total nitrate + REAL TS6 ! SO4 conc in cloudwater (mol/liter) + REAL TS6AKNA ! init SO4 akn conc in cloudwater (mol/liter) + REAL TS6ACCA ! init SO4 acc conc in cloudwater (mol/liter) + REAL TSIV ! + REAL TST ! + REAL WETFAC ! converts mol/l to mm-mol/l based on precip + REAL XC1 ! (/mm) + REAL XC2 ! (liter-atm/mol/mm) + REAL XL ! conversion factor (liter-atm/mol) + REAL ONE_OVER_XL ! 1.0 / XL + REAL PRES_ATM_OVER_XL ! PRES_ATM / XL + REAL XLCO2 ! + REAL XLH2O2 ! + REAL XLHNO3 ! + REAL XLMHP ! + REAL XLNH3 ! + REAL XLO3 ! + REAL XLPAA ! + REAL XLSO2 ! + +!...........LOCAL VARIABLES (arrays) and their descriptions: + + REAL LIQUID( NLIQS ) ! wet deposition array (mm mol/liter) + REAL WETDEP( NLIQS ) ! wet deposition array (mm mol/liter) + REAL DSIVDT( 0:NUMOX ) ! rate of so2 oxid incloud (mol/liter/sec) + REAL DS4 ( 0:NUMOX ) ! S(IV) oxidized over timestep DTW(0) + REAL*8 DTW ( 0:NUMOX ) ! cloud chemistry timestep (sec) + + REAL ONE_OVER_TEMP ! 1.0 / TEMP + +!...........EXTERNAL FUNCTIONS and their descriptions: + +! REAL HLCONST +! EXTERNAL HLCONST + +!********************************************************************* +! begin body of subroutine AQCHEM + + ONE_OVER_TEMP = 1.0 / TEMP + +!...check for bad temperature, cloud air mass, or pressure + + IF ( TEMP .LE. 0.0 ) THEN + IF ( AIRM .LE. 0.0 ) THEN + IF ( PRES_PA .LE. 0.0 ) THEN +! XMSG = 'MET DATA ERROR' +!cc CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + write(0,*)TEMP,AIRM,PRES_PA + CALL wrf_error_fatal ( ' met data error in aqchem') + END IF + END IF + END IF + +!...compute several conversion factors + + ICNTAQ = 0 + ITERAT = 0 + RT = ( MOLVOL / STDTEMP ) * TEMP ! R * T (liter atm / mol) + PRES_ATM = PRES_PA / STDATMPA ! pressure (atm) + CTHK1 = AIRM * RT / ( PRES_ATM * 1000.0 ) ! cloud thickness (m) + XL = WCAVG * RT / H2ODENS ! conversion factor (l-atm/mol) + ONE_OVER_XL = 1.0 / XL + PRES_ATM_OVER_XL = PRES_ATM / XL + TST = 0.999 + GM = SCVEFF / 100.0 + ACT1 = 1.0 + ACT2 = 1.0 + GM2 = 1.0 + TIMEW = 0.0 + RECIPAP1 = 1.0 / PRES_ATM + XC1 = 1.0 / ( WCAVG * CTHK1 ) + XC2 = RT / ( 1000.0 * CTHK1 ) + FRACLIQ = WCAVG / WTAVG + gaswdep=0. + aerwdep=0. + +!...set equilibrium constants as a function of temperature +!... Henry's law constants + + SO2H = HLCONST( 'SO2 ', TEMP, .FALSE., 0.0 ) + CO2H = HLCONST( 'CO2 ', TEMP, .FALSE., 0.0 ) + NH3H = HLCONST( 'NH3 ', TEMP, .FALSE., 0.0 ) + H2O2H = HLCONST( 'H2O2 ', TEMP, .FALSE., 0.0 ) + O3H = HLCONST( 'O3 ', TEMP, .FALSE., 0.0 ) + HNO3H = HLCONST( 'HNO3 ', TEMP, .FALSE., 0.0 ) + MHPH = HLCONST( 'METHYLHYDROPEROX', TEMP, .FALSE., 0.0 ) + PAAH = HLCONST( 'PEROXYACETIC_ACI', TEMP, .FALSE., 0.0 ) + FOAH = HLCONST( 'FORMIC_ACID ', TEMP, .FALSE., 0.0 ) + atraH = HLCONST( 'ATRA ', TEMP, .true., 1.0e-4 ) + + TEMP1 = ONE_OVER_TEMP - 1.0 / 298.0 + +!...dissociation constants + + FOA1 = 1.80E-04 * EXP( -2.00E+01 * TEMP1 ) ! Martell and Smith (1977) + SK6 = 1.02E-02 * EXP( 2.72E+03 * TEMP1 ) ! Smith and Martell (1976) + SO21 = 1.30E-02 * EXP( 1.96E+03 * TEMP1 ) ! Smith and Martell (1976) + SO22 = 6.60E-08 * EXP( 1.50E+03 * TEMP1 ) ! Smith and Martell (1976) + CO21 = 4.30E-07 * EXP( -1.00E+03 * TEMP1 ) ! Smith and Martell (1976) + CO22 = 4.68E-11 * EXP( -1.76E+03 * TEMP1 ) ! Smith and Martell (1976) + H2OW = 1.00E-14 * EXP( -6.71E+03 * TEMP1 ) ! Smith and Martell (1976) + NH31 = 1.70E-05 * EXP( -4.50E+02 * TEMP1 ) ! Smith and Martell (1976) + HNO31 = 1.54E+01 * EXP( 8.70E+03 * TEMP1 ) ! Schwartz (1984) + +!...Kinetic oxidation rates +!... From Chamedies (1982) + + RH2O2 = 8.0E+04 * EXP( -3650.0 * TEMP1 ) + +!...From Kok + + RMHP = 1.75E+07 * EXP( -3801.0 * TEMP1 ) + RPAA = 3.64E+07 * EXP( -3994.0 * TEMP1 ) + +!...make initializations + + DO LIQ = 1, NLIQS + WETDEP( LIQ ) = 0.0 + END DO + + DO IOX = 0, NUMOX + DSIVDT( IOX ) = 0.0 + DTW ( IOX ) = 0.0 + DS4 ( IOX ) = 0.0 + END DO + +!...compute the initial accumulation aerosol 3rd moment + + M3OLD = ( AEROSOL( LSO4ACC ) * SGRAERMW( LSO4ACC ) / 1.8e6 & + + AEROSOL( LNH4ACC ) * SGRAERMW( LNH4ACC ) / 1.8e6 & + + AEROSOL( LNO3ACC ) * SGRAERMW( LNO3ACC ) / 1.8e6 & + + AEROSOL( LORGACC ) * SGRAERMW( LORGACC ) / 2.0e6 & + + AEROSOL( LPRIACC ) * SGRAERMW( LPRIACC ) / 2.2e6 ) +!cc & * 6.0 / PI ! cancels out in division at end of subroutine + +!...compute fractional weights for several species + + NITAER = AEROSOL( LNO3ACC ) + AEROSOL( LNO3COR ) + IF ( NITAER .GT. 0.0 ) THEN + FRACACC = AEROSOL( LNO3ACC ) / NITAER + FRACCOR = AEROSOL( LNO3COR ) / NITAER + ELSE + FRACACC = 1.0 + FRACCOR = 0.0 + END IF + + TOTNIT = GAS( LHNO3 ) + AEROSOL( LNO3ACC ) + AEROSOL( LNO3COR ) + IF ( TOTNIT .GT. 0.0 ) THEN + FHNO3 = GAS( LHNO3 ) / TOTNIT + FNO3ACC = AEROSOL( LNO3ACC ) / TOTNIT + FNO3COR = AEROSOL( LNO3COR ) / TOTNIT + ELSE + FHNO3 = 1.0 + FNO3ACC = 0.0 + FNO3COR = 0.0 + END IF + + TOTAMM = GAS( LNH3 ) + AEROSOL( LNH4ACC ) + IF ( TOTAMM .GT. 0.0 ) THEN + FNH3 = GAS( LNH3 ) / TOTAMM + FNH4ACC = AEROSOL( LNH4ACC ) / TOTAMM + ELSE + FNH3 = 1.0 + FNH4ACC = 0.0 + END IF + +!...initial concentration from accumulation-mode aerosol loading (mol/liter) +!... an assumption is made that all of the accumulation-mode +!... aerosol mass in incorporated into the cloud droplets + + TS6ACCA = ( AEROSOL( LSO4ACC ) & + + GAS ( LH2SO4 ) ) * PRES_ATM_OVER_XL + NO3ACCA = AEROSOL( LNO3ACC ) * PRES_ATM_OVER_XL + NH4ACCA = AEROSOL( LNH4ACC ) * PRES_ATM_OVER_XL + ORGACCA = AEROSOL( LORGACC ) * PRES_ATM_OVER_XL + PRIACCA = AEROSOL( LPRIACC ) * PRES_ATM_OVER_XL + +!...initial concentration from coarse-mode aerosol loading (mol/liter) +!... an assumption is made that all of the coarse-mode +!... aerosol mass in incorporated into the cloud droplets + + CLA = ( AEROSOL( LNACL ) & + + AEROSOL( LKCL ) ) * PRES_ATM_OVER_XL + NO3CORA = AEROSOL( LNO3COR ) * PRES_ATM_OVER_XL + CAA = AEROSOL( LCACO3 ) * PRES_ATM_OVER_XL + MGA = AEROSOL( LMGCO3 ) * PRES_ATM_OVER_XL + NAA = AEROSOL( LNACL ) * PRES_ATM_OVER_XL + KA = AEROSOL( LKCL ) * PRES_ATM_OVER_XL + FEA = AEROSOL( LA3FE ) * PRES_ATM_OVER_XL + MNA = AEROSOL( LB2MN ) * PRES_ATM_OVER_XL + CO3A = ( AEROSOL( LCACO3 ) & + + AEROSOL( LMGCO3 ) ) * PRES_ATM_OVER_XL + PRICORA = AEROSOL( LPRICOR ) * PRES_ATM_OVER_XL + +!...set constant factors that will be used in later multiplications (moles/atm) + + XLH2O2 = H2O2H * XL + XLO3 = O3H * XL + XLMHP = MHPH * XL + XLPAA = PAAH * XL + XLSO2 = SO2H * XL + XLNH3 = NH3H * XL + XLHNO3 = HNO3H * XL + XLCO2 = CO2H * XL + + SO212 = SO21 * SO22 + SO21H = SO21 * SO2H + SO212H = SO212 * SO2H + CO212 = CO21 * CO22 + CO21H = CO21 * CO2H + CO212H = CO22 * CO21H + NH3DH20 = NH31 / H2OW + NH31HDH = NH3H * NH3DH20 + FOA1H = FOA1 * FOAH + HNO31H = HNO31 * HNO3H + +!...If kinetic calculations are made, return to this point + + I20C = 0 +20 CONTINUE + + I20C = I20C + 1 + IF ( I20C .GE. 1000 ) THEN + XMSG = 'EXCESSIVE LOOPING AT I20C' +!cc CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + +!...set aitken-mode aerosol loading (mol/liter) + + NO3AKNA = AEROSOL( LNO3AKN ) * PRES_ATM_OVER_XL & + * ( 1.0 - EXP( -ALFA3 * TIMEW ) ) + NH4AKNA = AEROSOL( LNH4AKN ) * PRES_ATM_OVER_XL & + * ( 1.0 - EXP( -ALFA3 * TIMEW ) ) + TS6AKNA = AEROSOL( LSO4AKN ) * PRES_ATM_OVER_XL & + * ( 1.0 - EXP( -ALFA3 * TIMEW ) ) + ORGAKNA = AEROSOL( LORGAKN ) * PRES_ATM_OVER_XL & + * ( 1.0 - EXP( -ALFA3 * TIMEW ) ) + PRIAKNA = AEROSOL( LPRIAKN ) * PRES_ATM_OVER_XL & + * ( 1.0 - EXP( -ALFA3 * TIMEW ) ) + +!...Initial gas phase partial pressures (atm) +!... = initial partial pressure - amount deposited partial pressure + + PSO20 = GAS( LSO2 ) * PRES_ATM & + + DS4( 0 ) * XL & + - ( WETDEP( 8 ) + WETDEP( 9 ) + WETDEP( 10 ) ) * XC2 + PNH30 = GAS( LNH3 ) * PRES_ATM & + + ( NH4ACCA + NH4AKNA ) * XL & + - ( WETDEP( 2 ) + WETDEP( 15 ) ) * XC2 + PHNO30 = ( GAS( LHNO3 ) + 2.0 * GAS( LN2O5 ) ) * PRES_ATM & + + ( NO3ACCA + NO3CORA + NO3AKNA ) * XL & + - ( WETDEP( 14 ) + WETDEP( 32 ) ) * XC2 + PH2O20 = GAS( LH2O2 ) * PRES_ATM - WETDEP( 17 ) * XC2 + PO30 = GAS( LO3 ) * PRES_ATM - WETDEP( 18 ) * XC2 + PFOA0 = GAS( LFOA ) * PRES_ATM & + - ( WETDEP( 22 ) + WETDEP( 23 ) ) * XC2 + PMHP0 = GAS( LMHP ) * PRES_ATM - WETDEP( 24 ) * XC2 + PPAA0 = GAS( LPAA ) * PRES_ATM - WETDEP( 25 ) * XC2 + PCO20 = GAS( LCO2 ) * PRES_ATM & + + CO3A * XL & + - ( WETDEP( 11 ) + WETDEP( 12 ) + WETDEP( 13 ) ) * XC2 + +!...don't allow gas concentrations to go below zero + + PSO20 = MAX( PSO20, 0.0 ) + PNH30 = MAX( PNH30, 0.0 ) + PH2O20 = MAX( PH2O20, 0.0 ) + PO30 = MAX( PO30, 0.0 ) + PFOA0 = MAX( PFOA0, 0.0 ) + PMHP0 = MAX( PMHP0, 0.0 ) + PPAA0 = MAX( PPAA0, 0.0 ) + PCO20 = MAX( PCO20, 0.0 ) + PHNO30 = MAX( PHNO30, 0.0 ) + +!...Molar concentrations of soluble aerosols +!... = Initial amount - amount deposited (mol/liter) + + TS6 = TS6ACCA + TS6AKNA & + - ( WETDEP( 6 ) + WETDEP( 7 ) ) * XC1 & + - DS4( 0 ) + CL = CLA - WETDEP( 16 ) * XC1 + CA = CAA - WETDEP( 3 ) * XC1 + MG = MGA - WETDEP( 29 ) * XC1 + NA = NAA - WETDEP( 4 ) * XC1 + K = KA - WETDEP( 30 ) * XC1 + FE = FEA - WETDEP( 19 ) * XC1 + MN = MNA - WETDEP( 20 ) * XC1 + ORGN = ORGACCA + ORGAKNA - WETDEP( 27 ) * XC1 + PRIM = PRIACCA + PRIAKNA - WETDEP( 28 ) * XC1 + PRIMCOR = PRICORA - WETDEP( 33 ) * XC1 + A = 3.0 * FE + B = 2.0 * MN + +!...don't allow aerosol concentrations to go below zero + + TS6 = MAX( TS6, 0.0 ) + CL = MAX( CL, 0.0 ) + CA = MAX( CA, 0.0 ) + MG = MAX( MG, 0.0 ) + NA = MAX( NA, 0.0 ) + K = MAX( K, 0.0 ) + FE = MAX( FE, 0.0 ) + MN = MAX( MN, 0.0 ) + ORGN = MAX( ORGN, 0.0 ) + PRIM = MAX( PRIM, 0.0 ) + PRIMCOR = MAX( PRIMCOR, 0.0 ) + A = MAX( A, 0.0 ) + B = MAX( B, 0.0 ) + + SK6TS6 = SK6 * TS6 + +!...find solution of the equation using a method of reiterative +!... bisections Make initial guesses for pH: between .01 to 10. + + HA = 0.01 + HB = 10.0 + + I7777C = 0 +7777 CONTINUE + + I7777C = I7777C + 1 + IF ( I7777C .GE. 1000 ) THEN + XMSG = 'EXCESSIVE LOOPING AT I7777C' +!cc CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + + HA = MAX( HA - 0.8, 0.1 ) + HB = MIN( HB + 0.8, 9.9 ) + AE = 10.0**( -HA ) + + RECIPA1 = 1.0 / ( AE * ACT1 ) + RECIPA2 = 1.0 / ( AE * AE * ACT2 ) + +!...calculate final gas phase partial pressure of SO2, NH3, HNO3 +!... HCOOH, and CO2 (atm) + + PSO2F = PSO20 / ( 1.0 + XLSO2 * ( 1.0 + SO21 * RECIPA1 & + + SO212 * RECIPA2 ) ) + + PNH3F = PNH30 / ( 1.0 + XLNH3 * ( 1.0 + NH3DH20 * AE ) ) + + PFOAF = PFOA0 / ( 1.0 + XL * ( FOAH + FOA1H * RECIPA1 ) ) + + PHNO3F = PHNO30 / ( 1.0 + XLHNO3 * ( 1.0 + HNO31 * RECIPA1 ) ) + + PCO2F = PCO20 / ( 1.0 + XLCO2 * ( 1.0 + CO21 * RECIPA1 & + + CO212 * RECIPA2 ) ) + +!...calculate liquid phase concentrations (moles/liter) + + SO4 = SK6TS6 / ( AE * GM2 + SK6 ) + HSO4 = TS6 - SO4 + SO3 = SO212H * PSO2F * RECIPA2 + HSO3 = SO21H * PSO2F * RECIPA1 + CO3 = CO212H * PCO2F * RECIPA2 + HCO3 = CO21H * PCO2F * RECIPA1 + OH = H2OW * RECIPA1 + NH4 = NH31HDH * PNH3F * AE + HCO2 = FOA1H * PFOAF * RECIPA1 + NO3 = HNO31H * PHNO3F * RECIPA1 + +!...compute functional value + + FA = AE + NH4 + 2.0 * (CA + MG - CO3 - SO3 - SO4 ) - OH - HCO3 & + - HSO3 - NO3 - HSO4 - HCO2 + +!...Start iteration and bisection ****************<<<<<<< + + I30C = 0 +30 CONTINUE + + I30C = I30C + 1 + IF ( I30C .GE. 1000 ) THEN + XMSG = 'EXCESSIVE LOOPING AT I30C' +!cc CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + + BB = ( HA + HB ) / 2.0 + AE = 10.0**( -BB ) + + ICNTAQ = ICNTAQ + 1 + IF ( ICNTAQ .GE. 3000 ) THEN + XMSG = 'Maximum AQCHEM total iterations exceeded' +!cc CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + + RECIPA1 = 1.0 / ( AE * ACT1 ) + RECIPA2 = 1.0 / ( AE * AE * ACT2 ) + +!...calculate final gas phase partial pressure of SO2, NH3, HNO3 +!... HCOOH, and CO2 (atm) + + PSO2F = PSO20 / ( 1.0 + XLSO2 & + * ( 1.0 + SO21 * RECIPA1 + SO212 * RECIPA2 ) ) + + PNH3F = PNH30 / ( 1.0 + XLNH3 * ( 1.0 + NH3DH20 * AE ) ) + + PHNO3F = PHNO30 / ( 1.0 + XLHNO3 * ( 1.0 + HNO31 * RECIPA1 ) ) + + PFOAF = PFOA0 / ( 1.0 + XL * ( FOAH + FOA1H * RECIPA1 ) ) + + PCO2F = PCO20 / ( 1.0 + XLCO2 * ( 1.0 + CO21 * RECIPA1 & + + CO212 * RECIPA2 ) ) + +!...calculate liquid phase concentrations (moles/liter) + + SO4 = SK6TS6 / ( AE * GM2 + SK6 ) + HSO4 = TS6 - SO4 + SO3 = SO212H * PSO2F * RECIPA2 + HSO3 = SO21H * PSO2F * RECIPA1 + CO3 = CO212H * PCO2F * RECIPA2 + HCO3 = CO21H * PCO2F * RECIPA1 + OH = H2OW * RECIPA1 + NH4 = NH31HDH * PNH3F * AE + HCO2 = FOA1H * PFOAF * RECIPA1 + NO3 = HNO31H * PHNO3F * RECIPA1 + +!...compute functional value + + FB = AE + NH4 + 2.0 * ( CA + MG - CO3 - SO3 - SO4 ) - OH - HCO3 & + - HSO3 - NO3 - HSO4 - HCO2 + +!...Calculate and check the sign of the product of the two functional values + + FTST = FA * FB + IF ( FTST .LE. 0.0 ) THEN + HB = BB + ELSE + HA = BB + FA = FB + END IF + +!...Check convergence of solutions + + HTST = HA / HB + IF ( HTST .LE. TST ) GO TO 30 + +!...end of zero-finding routine ****************<<<<<<<<<<<< + +!...compute Ionic strength and activity coefficient by the Davies equation + + STION = 0.5 * (AE + NH4 + OH + HCO3 + HSO3 & + + 4.0 * (SO4 + CO3 + SO3 + CA + MG + MN) & + + NO3 + HSO4 + 9.0 * FE + NA + K + CL + A + B + HCO2) + GM1LOG = -0.509 * ( SQRT( STION ) & + / ( 1.0 + SQRT( STION ) ) - 0.2 * STION ) + GM2LOG = GM1LOG * 4.0 + GM1 = 10.0**GM1LOG + GM2 = MAX( 10.0**GM2LOG, 1.0E-30 ) + ACTB = ACT1 + ACT1 = MAX( GM1 * GM1, 1.0E-30 ) + ACT2 = MAX( GM1 * GM1 * GM2, 1.0E-30 ) + +!...check for convergence and possibly go to 7777, to recompute +!... Gas and liquid phase concentrations + + TAC = ABS( ACTB - ACT1 ) / ACTB + IF ( TAC .GE. 1.0E-2 ) GO TO 7777 + +!...return an error if the pH is not in range + +!cc IF ( ( HA .LT. 0.02 ) .OR. ( HA .GT. 9.49 ) ) THEN + IF ( ( HA .LT. 0.1 ) .OR. ( HA .GT. 9.9 ) ) THEN + print *, ha +! XMSG = 'PH VALUE OUT OF RANGE' +!CC CALL M3EXIT ( PNAME, JDATE, JTIME, XMSG, XSTAT2 ) + END IF + +!...Make those concentration calculations which can be made outside +!... of the function. + + SO2L = SO2H * PSO2F + AC = 10.0**( -BB ) + SIV = SO3 + HSO3 + SO2L + +!...Calculate final gas phase concentrations of oxidants (atm) + + PH2O2F = ( PH2O20 + XL * DS4( 1 ) ) / ( 1.0 + XLH2O2 ) + PO3F = ( PO30 + XL * DS4( 2 ) ) / ( 1.0 + XLO3 ) + PMHPF = ( PMHP0 + XL * DS4( 4 ) ) / ( 1.0 + XLMHP ) + PPAAF = ( PPAA0 + XL * DS4( 5 ) ) / ( 1.0 + XLPAA ) + + PH2O2F = MAX( PH2O2F, 0.0 ) + PO3F = MAX( PO3F, 0.0 ) + PMHPF = MAX( PMHPF, 0.0 ) + PPAAF = MAX( PPAAF, 0.0 ) + +!...Calculate liquid phase concentrations of oxidants (moles/liter) + + H2O2L = PH2O2F * H2O2H + O3L = PO3F * O3H + MHPL = PMHPF * MHPH + PAAL = PPAAF * PAAH + FOAL = PFOAF * FOAH + NH3L = PNH3F * NH3H + CO2L = PCO2F * CO2H + HNO3L = PHNO3F * HNO3H + +!...load the liquid concentration array with current values + + LIQUID( 1 ) = AC + LIQUID( 2 ) = NH4 + LIQUID( 3 ) = CA + LIQUID( 4 ) = NA + LIQUID( 5 ) = OH + LIQUID( 6 ) = SO4 + LIQUID( 7 ) = HSO4 + LIQUID( 8 ) = SO3 + LIQUID( 9 ) = HSO3 + LIQUID( 10 ) = SO2L + LIQUID( 11 ) = CO3 + LIQUID( 12 ) = HCO3 + LIQUID( 13 ) = CO2L + LIQUID( 14 ) = NO3 + LIQUID( 15 ) = NH3L + LIQUID( 16 ) = CL + LIQUID( 17 ) = H2O2L + LIQUID( 18 ) = O3L + LIQUID( 19 ) = FE + LIQUID( 20 ) = MN + LIQUID( 21 ) = A + LIQUID( 22 ) = FOAL + LIQUID( 23 ) = HCO2 + LIQUID( 24 ) = MHPL + LIQUID( 25 ) = PAAL + LIQUID( 26 ) = 0.0 + LIQUID( 27 ) = ORGN + LIQUID( 28 ) = PRIM + LIQUID( 29 ) = MG + LIQUID( 30 ) = K + LIQUID( 31 ) = B + LIQUID( 32 ) = HNO3L + LIQUID( 33 ) = PRIMCOR + +!...if the maximum cloud lifetime has not been reached, the compute +!... the next timestep. + + IF ( TIMEW .LT. TAUCLD ) THEN + +!...make kinetics calculations +!... note: DS4(i) and DSIV(I) are negative numbers! + + DTRMV = 300.0 + IF ( ( CTHK1 .GT. 1.0E-10 ) .AND. ( PRCRATE .GT. 1.0E-10 ) ) & + DTRMV = 3.6 * WTAVG * 1000.0 * CTHK1 / PRCRATE ! <<HSO3+H : Smith and Martell (1976) + DATA LHSO3, B( 2), D( 2) / 2, 6.60E-08, 1.50E+03 / ! HSO3<=>SO3+H : Smith and Martell (1976) + DATA LHNO2, B( 3), D( 3) / 3, 5.10E-04, -1.26E+03 / ! HNO2(aq)<=>NO2+H : Schwartz and White (1981) + DATA LHNO3, B( 4), D( 4) / 4, 1.54E+01, 8.70E+03 / ! HNO3(aq)<=>NO3+H : Schwartz (1984) + DATA LCO2, B( 5), D( 5) / 5, 4.30E-07, -1.00E+03 / ! CO2*H2O<=>HCO3+H : Smith and Martell (1976) + DATA LHCO3, B( 6), D( 6) / 6, 4.68E-11, -1.76E+03 / ! HCO3<=>CO3+H : Smith and Martell (1976) + DATA LH2O2, B( 7), D( 7) / 7, 2.20E-12, -3.73E+03 / ! H2O2(aq)<=>HO2+H : Smith and Martell (1976) + DATA LHCHO, B( 8), D( 8) / 8, 2.53E+03, 4.02E+03 / ! HCHO(aq)<=>H2C(OH)2 : Le Hanaf (1968) + DATA LHCOOH, B( 9), D( 9) / 9, 1.80E-04, -2.00E+01 / ! HCOOH(aq)<=>HCOO+H : Martell and Smith (1977) + DATA LHO2, B( 10), D( 10) / 10, 3.50E-05, 0.00E+00 / ! HO2(aq)<=>H+O2 : Perrin (1982) + DATA LNH4OH, B( 11), D( 11) / 11, 1.70E-05, -4.50E+02 / ! NH4*OH<=>NH4+OH : Smith and Martell (1976) + DATA LH2O, B( 12), D( 12) / 12, 1.00E-14, -6.71E+03 / ! H2O<=>H+OH : Smith and Martell (1976) + +!...........EXTERNAL FUNCTIONS and their descriptions: + +! INTEGER INDEX1 +! INTEGER TRIMLEN ! string length, excl. trailing blanks + +! EXTERNAL TRIMLEN + +!----------------------------------------------------------------------- +! begin body of subroutine HLCONST + + SPC = INDEX1( NAME, MXSPCS, SUBNAME ) + +!...error if species not found in table + + IF ( SPC .LE. 0 ) THEN +! XMSG = NAME( 1:TRIMLEN( NAME ) ) // ' not found in Henry''s '// +! & ' Law Constant table in routine HLCONST.' +!CC CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT2 ) + END IF + +!...compute the Henry's Law Constant + + TFAC = ( 298.0 - TEMP) / ( 298.0 * TEMP ) + KH = A( SPC ) * EXP( E( SPC ) * TFAC ) + HLCONST = KH + +!...compute the effective Henry's law constants + + IF ( EFFECTIVE ) THEN + + IF ( HPLUS .LE. 0.0 ) THEN +! XMSG = 'Negative or Zero [H+] concentration specified ' // +! & 'in HLCONST ' +!CC CALL M3EXIT ( PNAME, 0, 0, XMSG, XSTAT2 ) + END IF + + HPLUSI = 1.0 / HPLUS + HPLUS2I = HPLUSI * HPLUSI + + CHECK_NAME: SELECT CASE ( NAME( 1:TRIMLEN( NAME ) ) ) + + CASE ('SO2') ! SO2H2O <=> HSO3- + H+ + ! & HSO3- <=> SO3= + H+ + + AKEQ1 = B( LSO2 ) * EXP( D( LSO2 ) * TFAC ) + AKEQ2 = B( LHSO3 ) * EXP( D( LHSO3 ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI + AKEQ1 * AKEQ2 * HPLUS2I ) + + CASE ('HNO2') ! HNO2(aq) <=> NO2- + H+ + + AKEQ1 = B( LHNO2 ) * EXP( D( LHNO2 ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI ) + + CASE ('HNO3') ! HNO3(aq) <=> NO3- + H+ + + AKEQ1 = B( LHNO3 ) * EXP( D( LHNO3 ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI ) + + CASE ('CO2') ! CO2H2O <=> HCO3- + H+ + ! & HCO3- <=> CO3= + H+ + + AKEQ1 = B( LCO2 ) * EXP( D( LCO2 ) * TFAC ) + AKEQ2 = B( LHCO3 ) * EXP( D( LHCO3 ) * TFAC ) + HLCONST = KH & + * ( 1.0 + AKEQ1 * HPLUSI + AKEQ1 * AKEQ2 * HPLUS2I ) + + CASE ('H2O2') ! H2O2(aq) <=> HO2- + H+ + + AKEQ1 = B( LH2O2 ) * EXP( D( LH2O2 ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI ) + + CASE ('FORMALDEHYDE') ! HCHO(aq) <=> H2C(OH)2(aq) + + AKEQ1 = B( LHCHO ) * EXP( D( LHCHO ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 ) + + CASE ('FORMIC_ACID') ! HCOOH(aq) <=> HCOO- + H+ + + AKEQ1 = B( LHCOOH ) * EXP( D( LHCOOH ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI ) + + CASE ('HO2') ! HO2(aq) <=> H+ + O2- + + AKEQ1 = B( LHO2 ) * EXP( D( LHO2 ) * TFAC ) + HLCONST = KH * ( 1.0 + AKEQ1 * HPLUSI ) + + CASE ('NH3') ! NH4OH <=> NH4+ + OH- + + AKEQ1 = B( LNH4OH ) * EXP( D( LNH4OH ) * TFAC ) + AKEQ2 = B( LH2O ) * EXP( D( LH2O ) * TFAC ) + OHION = AKEQ2 * HPLUSI + HLCONST = KH * ( 1.0 + AKEQ1 / OHION ) + + END SELECT CHECK_NAME + + END IF + +! RETURN +END FUNCTION HLCONST +!......................................................................... +! Version "@(#)$Header: /env/proj/archive/cvs/ioapi/./ioapi/src/index1.f,v 1.2 2000/11/28 21:22:49 smith_w Exp $" +! EDSS/Models-3 I/O API. Copyright (C) 1992-1999 MCNC +! Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1 +! See file "LGPL.txt" for conditions of use. +!......................................................................... + + INTEGER FUNCTION INDEX1 (NAME, N, NLIST) + +!*********************************************************************** +! subroutine body starts at line 46 +! +! FUNCTION: +! +! Searches for NAME in list NLIST and returns the subscript +! (1...N) at which it is found, or returns 0 when NAME not +! found in NLIST +! +! PRECONDITIONS REQUIRED: none +! +! SUBROUTINES AND FUNCTIONS CALLED: none +! +! REVISION HISTORY: +! +! 5/88 Modified for ROMNET +! 9/94 Modified for Models-3 by CJC +! +!*********************************************************************** + + IMPLICIT NONE + +!....... Arguments and their descriptions: + + CHARACTER*(*) NAME ! Character string being searched for + INTEGER N ! Length of array to be searched + CHARACTER*(*) NLIST(*) ! array to be searched + +!....... Local variable: + + INTEGER I ! loop counter + +!..................................................................... +!....... begin body of INDEX1() + + DO 100 I = 1, N + + IF ( NAME .EQ. NLIST( I ) ) THEN ! Found NAME in NLIST + INDEX1 = I + RETURN + ENDIF + +100 CONTINUE + + INDEX1 = 0 ! not found + RETURN + +END FUNCTION INDEX1 + +END MODULE module_ctrans_aqchem diff --git a/wrfv2_fire/chem/module_ctrans_grell.F b/wrfv2_fire/chem/module_ctrans_grell.F new file mode 100755 index 00000000..910f9f4a --- /dev/null +++ b/wrfv2_fire/chem/module_ctrans_grell.F @@ -0,0 +1,1707 @@ +!WRF:MODEL_LAYER:PHYSICS +! + +MODULE module_ctrans_grell +!USE module_data_radm2 +USE module_cu_gd +USE module_dep_simple +!USE module_ctrans_aqchem +! USE module_configure +! USE module_state_description +! Mole weight +! REAL :: WTM(NUMCHEM_radm) +! DATA WTM / 64.,96.,46.,30.,48.,63.,34.,44.,30.,48.,62., & +! 76.,46.,60.,17.,108.,62.,121.,44.,72.,114.,30., & +! 28.,28.,42.,56.,92.,106.,75.,147.,47.,79.,72., & +! 58.,72.,87.,119.,108.,68.,17.,33. / + +CONTAINS + +!------------------------------------------------------------- + SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & + id,config_flags,rho_phy,RAINCV,chem, & + U,V,t_phy,moist,dz8w,p_phy, & + XLV,CP,G,r_v,z,cu_co_ten, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description +!------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------- + INTEGER, INTENT(IN ) :: & + id, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + + INTEGER, INTENT(IN ) :: ITIMESTEP + + REAL, INTENT(IN ) :: XLV, R_v + REAL, INTENT(IN ) :: CP,G + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme,num_moist ) , & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + U, & + V, & + t_phy, & + z, & + p_phy, & + dz8w, & + rho_phy +! +! on output for control only, purely diagnostic +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + cu_co_ten + + +! + REAL, INTENT(IN ) :: DT, DX +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ), & + INTENT(INOUT) :: & + chem + + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN) :: RAINCV + +! LOCAL VARS + real, dimension (its:ite,kts:kte) :: & + OUTT,OUTQ,OUTQC + real, dimension (its:ite) :: & + pret, ter11 + +! +! basic environmental input includes moisture convergence (mconv) +! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off +! convection for this call only and at that particular gridpoint +! + real, dimension (its:ite,kts:kte) :: & + T,TN,q,qo,PO,P,US,VS,hstary + real, dimension (its:ite,kts:kte,num_chem) :: & + tracer,tracert + real, dimension (its:ite) :: & + Z1,PSUR,AAEQ + integer, dimension (its:ite) :: & + ktop + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER :: nv,i,j,k,ICLDCK,ipr,jpr,npr + REAL :: tcrit,dp,dq,epsilc + INTEGER :: itf,jtf,ktf,iopt + epsilc=1.e-30 +! return +! ipr=111 +! jpr=40 +! if(itimestep.lt.34.or.itimestep.gt.36)ipr=0 +! if(itimestep.lt.34.or.itimestep.gt.36)jpr=0 +! ipr=61 +! jpr=60 + ipr=0 + jpr=0 + npr=p_co + tcrit=258. + iopt=0 + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) + jtf=MIN(jte,jde-1) +! +! +! DO J = jts,jtf +! DO I=ITS,ITF +! if(raincv(i,j).gt.0.)then +! ipr=i +! jpr=j +! go to 123 +! endif +! ENDDO +! ENDDO +123 continue +! print *,ipr,jpr + DO 100 J = jts,jtf + if(j.eq.jpr)print *,'dt = ',dt + DO I=ITS,ITF + ktop(i)=0 + PSUR(I)=p_phy(I,kts,J)*.01 + TER11(I)=z(i,kts,j) + aaeq(i)=0. +! +! rainrate is input for this transport/wet-deposition routine +! + pret(i)=raincv(i,j)/dt + if(pret(i).le.0.)aaeq(i)=20. + ENDDO + DO K=kts,ktf + DO I=ITS,ITF + po(i,k)=p_phy(i,k,j)*.01 + P(I,K)=PO(i,k) + US(I,K) =u(i,k,j) + VS(I,K) =v(i,k,j) + T(I,K)=t_phy(i,k,j) + q(I,K)=moist(i,k,j,p_qv) + IF(Q(I,K).LT.1.E-08)Q(I,K)=1.E-08 + ENDDO + ENDDO + do nv=1,num_chem + DO K=kts,ktf + DO I=ITS,ITF + tracer(i,k,nv)=max(epsilc,chem(i,k,j,nv)) + tracert(i,k,nv)=0. + ENDDO + ENDDO + ENDDO + DO K=kts,ktf + DO I=ITS,ITF + cu_co_ten(i,k,j)=0. +! hstary(i,k)=hstar4(nv)*exp(dhr(nv)*(1./t(i,k)-1./298.)) + if(i.eq.ipr.and.j.eq.jpr)then + print *,k,pret(i),tracer(i,k,npr),p(i,k),z(i,k,j) + endif + ENDDO + ENDDO +! ENDDO +! +!---- CALL CUMULUS PARAMETERIZATION +! + CALL CUP_ct(ktop,tracer,j,AAEQ,T,Q,TER11,PRET,P,tracert, & + hstary,DT,PSUR,US,VS,tcrit, & + xlv,r_v,cp,g,ipr,jpr,npr,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + do nv=1,num_chem + DO I=its,itf + if(pret(i).le.0.)then + DO K=kts,ktf + tracert(i,k,nv)=0. + ENDDO + endif + enddo + enddo + CALL neg_check_ct(pret,ktop,epsilc,dt,tracer,tracert,iopt,num_chem, & + its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j) + do nv=1,num_chem + DO I=its,itf + if(pret(i).gt.0.)then + DO K=kts,ktf + chem(i,k,j,nv)=max(epsilc,chem(i,k,j,nv)+tracert(i,k,nv)*dt) + if(nv.eq.npr)then + cu_co_ten(i,k,j)=tracert(i,k,npr)*dt + if(i.eq.ipr.and.j.eq.jpr)print *,k,chem(i,k,j,nv),cu_co_ten(i,k,j) + endif + ENDDO + else + DO K=kts,ktf + tracert(i,k,nv)=0. + if(nv.eq.npr)cu_co_ten(i,k,j)=0. + enddo + endif + ENDDO + ENDDO + + + 100 continue + + END SUBROUTINE GRELLDRVCT + + + SUBROUTINE CUP_ct(ktop,tracer,J,AAEQ,T,Q,Z1, & + PRE,P,tracert,hstary,DTIME,PSUR,US,VS,TCRIT, & + xl,rv,cp,g,ipr,jpr,npr,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + integer & + ,intent (in ) :: & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,ipr,jpr,npr + integer, intent (in ) :: & + j + ! + ! + ! + !tracert = output temp tendency (per s) + ! pre = input precip + real, dimension (its:ite,kts:kte,num_chem) & + ,intent (inout ) :: & + tracert,tracer + real, dimension (its:ite) & + ,intent (inout ) :: & + pre + integer, dimension (its:ite) & + ,intent (inout ) :: & + ktop + integer, dimension (its:ite) :: & + kbcon + ! + ! basic environmental input includes moisture convergence (mconv) + ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off + ! convection for this call only and at that particular gridpoint + ! + real, dimension (its:ite,kts:kte) & + ,intent (in ) :: & + T,P,US,VS,HSTARY + real, dimension (its:ite,kts:kte) & + ,intent (inout) :: & + Q + real, dimension (its:ite) & + ,intent (in ) :: & + Z1,PSUR,AAEQ + + + real & + ,intent (in ) :: & + dtime,tcrit,xl,cp,rv,g + + + real, dimension (its:ite,1:3) :: & + edtc +! +! +! +!***************** the following are your basic environmental +! variables. They carry a "_cup" if they are +! on model cloud levels (staggered). They carry +! an "o"-ending (z becomes zo), if they are the forced +! variables. They are preceded by x (z becomes xz) +! to indicate modification by some typ of cloud +! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (Kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels +! +! + ! hcd = moist static energy in downdraft + ! zd normalized downdraft mass flux + ! dby = buoancy term + ! entr = entrainment rate + ! zd = downdraft normalized mass flux + ! entr= entrainment rate + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! mentr_rate = entrainment rate + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (I2) + ! entr= entrainment rate + ! z1 = terrain elevation + ! entr = downdraft entrainment rate + ! jmin = downdraft originating level + ! kdet = level above ground where downdraft start detraining + ! psur = surface pressure + ! z1 = terrain elevation + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! kbcon = LFC of parcel from k22 + ! k22 = updraft originating level + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + ! mentr_rate = entrainment rate + + real, dimension (its:ite,kts:kte) :: & + he,hes,qes,z,pwdper, & + + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & + + dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all, & + + ! cd = detrainment function for updraft + ! cdd = detrainment function for downdraft + + cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC + + ! edt = epsilon + ! edt = epsilon + real, dimension (its:ite) :: & + edt,HKB,QKB, & + XMB,PWAV,PWEV,BU,cap_max,cap_max_increment + real, dimension (its:ite,kts:kte,num_chem) :: & + tr_c,tr_up,tr_dd,tre_cup,tr_pw,tr_pwd + real, dimension (its:ite,num_chem) :: & + trkb + integer, dimension (its:ite) :: & + kzdown,KDET,K22,KB,JMIN,kstabi,kstabm, & !-lxz + ierr,KBMAX + + integer :: & + ki,I,K,KK + real :: & + day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate, & + zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop, & + dh,cap_maxs + + integer :: itf,jtf,ktf + + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) + jtf=MIN(jte,jde-1) + +!sms$distribute end + day=86400. +! +!--- specify entrainmentrate and detrainmentrate +! + radius=12000. +! +!--- gross entrainment rate (these may be changed later on in the +!--- program, depending what your detrainment is!!) +! + entr_rate=.2/radius +! +!--- entrainment of mass +! + mentrd_rate=0. + mentr_rate=entr_rate +! +!--- initial detrainmentrates +! + do k=kts,ktf + do i=its,itf + cd(i,k)=0.1*entr_rate + cdd(i,k)=0. + clw_all(i,k)=0. + enddo + enddo +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! base mass flux +! + edtmax=.8 + edtmin=.2 +! +!--- minimum depth (m), clouds must have +! + depth_min=500. +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! + cap_maxs=175. +!sms$to_local(grid_dh: <1, mix :size>, <2, mjx :size>) begin + DO 7 i=its,itf + kbmax(i)=1 + cap_max_increment(i)=0. + edt(i)=0. + kstabm(i)=ktf-1 + IERR(i)=0 + if(aaeq(i).ne.0.)then + ierr(i)=20 + endif + 7 CONTINUE + do i=its,itf + cap_max(i)=cap_maxs + enddo +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=4000. +! +!--- height(m) above which no downdrafts are allowed to originate +! + zcutdown=3000. +! +!--- depth(m) over which downdraft detrains all its mass +! + z_detr=1250. +! + mbdt=dtime*4.E-03 +! +!--- calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,p,z1, & + psur,ierr,tcrit,0,xl,cp, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1,xl,rv,cp, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + call cup_env_clev_tr(tracer,tre_cup,num_chem,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then +! + do k=kts,ktf-2 + if(z_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! +! +!--- level where detrainment for downdraft starts +! + do k=kts,ktf + if(z_cup(i,k).gt.z_detr+z1(i))then + kdet(i)=k + go to 26 + endif + enddo + 26 continue +! + endif + enddo +! +! +! +!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22 +! + CALL cup_MAXIMI(HE_CUP,3,KBMAX,K22,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + DO 36 i=its,itf + IF(ierr(I).eq.0.)THEN + IF(K22(I).GE.KBMAX(i))ierr(i)=2 + endif + 36 CONTINUE +! +!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE - KBCON +! + call cup_kbcon(cap_max_increment,1,k22,kbcon,he_cup,hes_cup, & + ierr,kbmax,p_cup,cap_max, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- increase detrainment in stable layers +! + CALL cup_minimi(HEs_cup,Kbcon,kstabm,kstabi,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + do i=its,itf + IF(ierr(I).eq.0.)THEN + if(kstabm(i)-1.gt.kstabi(i))then + do k=kstabi(i),kstabm(i)-1 + cd(i,k)=cd(i,k-1)+1.5*entr_rate + if(cd(i,k).gt.10.0*entr_rate)cd(i,k)=10.0*entr_rate + enddo + ENDIF + ENDIF + ENDDO +! +!--- calculate incloud moist static energy +! + call cup_up_he(k22,hkb,z_cup,cd,mentr_rate,he_cup,hc, & + kbcon,ierr,dby,he,hes_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + +!--- DETERMINE CLOUD TOP - KTOP +! + call cup_ktop(1,dby,kbcon,ktop,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + DO 37 i=its,itf + kzdown(i)=0 + if(ierr(i).eq.0)then + zktop=(z_cup(i,ktop(i))-z1(i))*.6 + zktop=min(zktop+z1(i),zcutdown+z1(i)) + do k=kts,ktf + if(z_cup(i,k).gt.zktop)then + kzdown(i)=k + go to 37 + endif + enddo + endif + 37 CONTINUE +! +!--- DOWNDRAFT ORIGINATING LEVEL - JMIN +! + call cup_minimi(HEs_cup,K22,kzdown,JMIN,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + DO 100 i=its,ite + IF(ierr(I).eq.0.)THEN +! +!--- check whether it would have buoyancy, if there where +!--- no entrainment/detrainment +! +101 continue + if(jmin(i)-1.lt.KDET(I))kdet(i)=jmin(i)-1 + if(jmin(i).ge.Ktop(I)-1)jmin(i)=ktop(i)-2 + ki=jmin(i) + hcd(i,ki)=hes_cup(i,ki) + DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) + dh=dz*(HCD(i,Ki)-hes_cup(i,ki)) + dh=0. +! + do k=ki-1,1,-1 + hcd(i,k)=hes_cup(i,jmin(i)) + DZ=Z_cup(i,K+1)-Z_cup(i,K) + dh=dh+dz*(HCD(i,K)-hes_cup(i,k)) + if(dh.gt.0.)then + jmin(i)=jmin(i)-1 + if(jmin(i).gt.3)then + go to 101 + else if(jmin(i).le.3)then + ierr(i)=9 + go to 100 + endif + endif + enddo + + IF(JMIN(I).LE.3)then + ierr(i)=4 + endif + + ENDIF +100 continue +! +! - Must have at least depth_min m between cloud convective base +! and cloud top. +! + do i=its,itf + IF(ierr(I).eq.0.)THEN + IF(-z_cup(I,KBCON(I))+z_cup(I,KTOP(I)).LT.depth_min)then + ierr(i)=6 + endif + endif + enddo + +! +!c--- normalized updraft mass flux profile +! + call cup_up_nms(zu,z_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!c--- normalized downdraft mass flux profile,also work on bottom detrainment +!--- in this routine +! + call cup_dd_nms(zd,z_cup,cdd,mentrd_rate,jmin,ierr, & + 0,kdet,z1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- downdraft moist static energy +! + call cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,mentrd_rate, & + jmin,ierr,he,dbyd,he_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- calculate moisture properties of downdraft +! + call cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup, & + pwd,q_cup,z_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, & + pwev,bu,qrcd,q,he,t_cup,2,xl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- calculate moisture properties of updraft +! + call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & + kbcon,ktop,cd,dby,mentr_rate,clw_all, & + q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR +! + call cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pwev,edtmax,edtmin,3,edtc, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + do i=its,itf + if(ierr(i).eq.0)then + edt(i)=edtc(i,2) + endif + enddo +! +! massflux from precip and normalized cloud properties +! + pwdper=0. + do i=its,itf + + if(ierr(i).gt.0)pre(i)=0. + if(ierr(i).eq.0)then + xmb(i)=pre(i)/(pwav(i)+edt(i)*pwev(i)) +! +!--- percent of that that is evaporated (pwd is negative) +! + if(i.eq.ipr.and.j.eq.jpr)then + print *,'xmb,edt,pwav = ',xmb(i),edt(i),pwav(i) + print *,'k,pwdper(i,k),pw,pwd(i,k)',z1(i) + endif + do k=1,ktop(i) + pwdper(i,k)=-edt(i)*pwd(i,k)/pwav(i) + if(i.eq.ipr.and.j.eq.jpr)then + print *,k,pwdper(i,k),pw(i,k),pwd(i,k) + endif + enddo + endif + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!!!!! NOW WE HAVE EVREYTHING TO CALCULATE TRACER TRANSPORT AND WET DEPOSITION !!! +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!--- calculate incloud tracer distribution +! + if(j.eq.jpr)print *,'calling up_tracer' + call cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up,tr_pw, & + tr_c,hstary,pw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22,& + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) + if(j.eq.jpr)print *,'called up_tracer' + call cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & + tr_pw,tr_pwd,jmin,cdd,mentrd_rate,zd,pwdper,k22, & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + if(j.eq.jpr)print *,'called dd_tracer' + + +! + if(j.eq.jpr)then + i=ipr + print *,'in 250 loop ',edt(ipr),ierr(ipr) +! if(ierr(i).eq.0.or.ierr(i).eq.3)then + print *,k22(I),kbcon(i),ktop(i),jmin(i) + print *,edt(i) + do k=kts,ktf + print *,k,z(i,k),he(i,k),hes(i,k) + enddo + do k=1,ktop(i)+1 + print *,zu(i,k),zd(i,k),pw(i,k),pwd(i,k) + enddo + print *,'tr_up(i,k,6),tr_dd(i,k,6),tr_pw(i,k,6),tr_pwd(i,k,6)' + do k=1,ktop(i)+1 + print *,tr_up(i,k,npr),tr_dd(i,k,npr),tr_pw(i,k,npr),tr_pwd(i,k,npr) + enddo + endif +! endif +! +!--- calculate transport tendencies +! +!--- 1. in bottom layer +! + call cup_dellabot_tr(ipr,jpr,tre_cup,ierr,z_cup,p,tr_dd,edt, & + zd,cdd,tracer,tracert,j,mentrd_rate,z,g,xmb, & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +! +!--- 2. everywhere else +! + + call cup_dellas_tr(ierr,z_cup,p_cup,tr_dd,edt,zd,cdd, & + tracer,tracert,j,mentrd_rate,zu,g,xmb, & + cd,tr_up,ktop,k22,kbcon,mentr_rate,jmin,tre_cup,kdet, & + k22,ipr,jpr,npr,'deep',num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + if(j.eq.jpr)then + i=ipr + do k=kts,ktf + print *,k,tracer(i,k,npr),tracert(i,k,npr) + enddo + endif +! +! may need more below for wet deposition...... +! +! +! call cup_output_wd ( & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte) + + END SUBROUTINE CUP_CT + + SUBROUTINE cup_dellabot_tr(ipr,jpr,tre_cup,ierr,z_cup,p_cup, & + tr_dd,edt,zd,cdd,tracer,tracert,j,mentrd_rate,z,g,xmb, & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + integer & + ,intent (in ) :: & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, intent (in ) :: & + j,ipr,jpr + ! + ! ierr error value, maybe modified in this routine + ! + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (out ) :: & + tracert + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (in ) :: & + tre_cup,tracer,tr_dd + real, dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,p_cup,zd,cdd,z + real, dimension (its:ite) & + ,intent (in ) :: & + edt,xmb + real & + ,intent (in ) :: & + g,mentrd_rate + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +! +! local variables in this routine +! + + integer i + real detdo,detdo1,detdo2,entdo,dp,dz,subin, & + totmas +! + integer :: itf, ktf, nv, npr + npr=24 + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) +! +! + if(j.eq.jpr)print *,'in cup dellabot ' + tracert=0. + do 100 i=its,itf + if(ierr(i).ne.0)go to 100 + dz=z_cup(i,2)-z_cup(i,1) + DP=100.*(p_cup(i,1)-P_cup(i,2)) + detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ + detdo2=edt(i)*zd(i,1) + entdo=edt(i)*zd(i,2)*mentrd_rate*dz + subin=-EDT(I)*zd(i,2) + detdo=detdo1+detdo2-entdo+subin + do nv=1,num_chem + tracert(I,1,nv)=(detdo1*.5*(tr_dd(i,1,nv)+tr_dd(i,2,nv)) & + +detdo2*tr_dd(i,1,nv) & + +subin*tre_cup(i,2,nv) & + -entdo*tracer(i,1,nv))*g/dp*xmb(i) + enddo + if(j.eq.jpr.and.i.eq.ipr)print *,'in cup dellabot ',tracert(I,1,npr), & + detdo1,detdo2,subin,entdo,tr_dd(i,1,npr),tr_dd(i,2,npr),tracer(i,1,npr) + 100 CONTINUE + + END SUBROUTINE cup_dellabot_tr + + + SUBROUTINE cup_dellas_tr(ierr,z_cup,p_cup,tr_dd,edt,zd,cdd, & + tracer,tracert,j,mentrd_rate,zu,g,xmb, & + cd,tr_up,ktop,k22,kbcon,mentr_rate,jmin,tre_cup,kdet,kpbl, & + ipr,jpr,npr,name,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + integer & + ,intent (in ) :: & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, intent (in ) :: & + j,ipr,jpr,npr + ! + ! ierr error value, maybe modified in this routine + ! + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (inout ) :: & + tracert + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (in ) :: & + tr_up,tr_dd,tre_cup,tracer + real, dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,p_cup,zd,cdd,cd,zu + real, dimension (its:ite) & + ,intent (in ) :: & + edt,xmb + real & + ,intent (in ) :: & + g,mentrd_rate,mentr_rate + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop,k22,jmin,kdet,kpbl + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + character *(*), intent (in) :: & + name +! +! local variables in this routine +! + + integer i,k,nv + real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup, & + detup,subdown,entdoj,entupk,detupk,totmas +! + integer :: itf, ktf +! npr=24 + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) +! +! + i=ipr + if(j.eq.jpr)then + print *,'in dellas kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)' + print *,kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i) + endif + do nv=1,num_chem + DO K=kts+1,kte + do i=its,itf + tracert(i,k,nv)=0. + enddo + enddo + enddo +! + DO 100 k=kts+1,ktf-1 + DO 100 i=its,ite + IF(ierr(i).ne.0)GO TO 100 + IF(K.Gt.KTOP(I))GO TO 100 +! +!--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT +!--- WITH ZD CALCULATIONS IN SOUNDD. +! + DZ=Z_cup(I,K+1)-Z_cup(I,K) + detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1) + entdo=edt(i)*mentrd_rate*dz*zd(i,k+1) + subin=zu(i,k+1)-zd(i,k+1)*edt(i) + entup=0. + detup=0. + if(k.ge.kbcon(i).and.k.lt.ktop(i))then + entup=mentr_rate*dz*zu(i,k) + detup=CD(i,K+1)*DZ*ZU(i,k) + endif + subdown=(zu(i,k)-zd(i,k)*edt(i)) + entdoj=0. + entupk=0. + detupk=0. +! + if(k.eq.jmin(i))then + entdoj=edt(i)*zd(i,k) + endif + + if(k.eq.k22(i)-1)then + entupk=zu(i,kpbl(i)) + endif + + if(k.gt.kdet(i))then + detdo=0. + endif + + if(k.eq.ktop(i)-0)then + detupk=zu(i,ktop(i)) + subin=0. + endif + if(k.lt.kbcon(i))then + detup=0. + endif +!C +!C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT +!C + totmas=subin-subdown+detup-entup-entdo+ & + detdo-entupk-entdoj+detupk + if(j.eq.jpr.and.i.eq.ipr)print *,'k,totmas,sui,sud = ',k, & + totmas,subin,subdown +! if(j.eq.jpr.and.i.eq.ipr)print *,'updr stuff = ',detup, +! 1 entup,entupk,detupk +! if(j.eq.jpr.and.i.eq.ipr)print *,'dddr stuff = ',entdo, +! 1 detdo,entdoj + if(abs(totmas).gt.1.e-6)then + print *,'*********************',i,j,k,totmas,name + print *,kpbl(i),k22(i),kbcon(i),ktop(i) +!c print *,'updr stuff = ',subin, +!c 1 subdown,detup,entup,entupk,detupk +!c print *,'dddr stuff = ',entdo, +!c 1 detdo,entdoj + CALL wrf_error_fatal ( 'cup_dellas_tr: TOTMAS > CRITICAL VALUE') + endif + dp=100.*(p_cup(i,k-1)-p_cup(i,k)) + do nv=1,num_chem +! tracert(i,k,nv)=(subin*tre_cup(i,k+1,nv) & +! -subdown*tre_cup(i,k,nv) & + tracert(i,k,nv)=(subin*tracer(i,k+1,nv) & + -subdown*tracer(i,k,nv) & + +detup*.5*(tr_up(i,K+1,nv)+tr_up(i,K,nv)) & + +detdo*.5*(tr_dd(i,K+1,nv)+tr_dd(i,K,nv)) & + -entup*tracer(i,k,nv) & + -entdo*tracer(i,k,nv) & + -entupk*tre_cup(i,k22(i),nv) & + -entdoj*tre_cup(i,jmin(i),nv) & + +detupk*tr_up(i,ktop(i),nv) & + )*g/dp*xmb(i) + enddo + if(i.eq.ipr.and.j.eq.jpr)then + print *,k,tracert(i,k,npr),subin*tre_cup(i,k+1,npr),subdown*tre_cup(i,k,npr), & + detdo*.5*(tr_dd(i,K+1,npr)+tr_dd(i,K,npr)) + print *,k,detup*.5*(tr_up(i,K+1,npr)+tr_up(i,K,npr)),detupk*tr_up(i,ktop(i),npr), & + entup*tracer(i,k,npr),entdo*tracer(i,k,npr) + print *,k,entupk*tre_cup(i,k,npr),detupk,tr_up(i,ktop(i),npr) + endif + + 100 CONTINUE + + END SUBROUTINE cup_dellas_tr + SUBROUTINE cup_env_clev_tr(tracer,tre_cup,num_chem,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + implicit none + integer & + ,intent (in ) :: & + num_chem,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, dimension (its:ite) & + ,intent (in) :: & + ierr + + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (in ) :: & + tracer + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (out ) :: & + tre_cup +! +! local variables in this routine +! + + integer :: & + i,k,nv,itf,ktf + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) + do nv=1,num_chem + do k=kts+1,ktf + do i=its,ite + if(ierr(i).eq.0)then + tre_cup(i,k,nv)=.5*(tracer(i,k-1,nv)+tracer(i,k,nv)) + endif + enddo + enddo + enddo + do nv=1,num_chem + do i=its,ite + if(ierr(i).eq.0)then + tre_cup(i,kts,nv)=tracer(i,kts,nv) + endif + enddo + enddo + + +END subroutine cup_env_clev_tr + + + SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & + tr_pw,tr_c,hstary,cupclw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22, & + num_cc,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) + USE module_configure + USE module_state_description + USE module_ctrans_aqchem + implicit none +! Aqeuous species pointers INCLUDE File + +!...........PARAMETERS and their descriptions: + + INTEGER NGAS ! number of gas phase species for AQCHEM + PARAMETER ( NGAS = 11 ) + + INTEGER NAER ! number of aerosol species for AQCHEM + PARAMETER ( NAER = 23 ) + +!...pointers for the AQCHEM array GAS + + INTEGER LSO2 ! local pointer to SO2 + PARAMETER ( LSO2 = 1 ) + + INTEGER LHNO3 ! local pointer to HNO3 + PARAMETER ( LHNO3 = 2 ) + + INTEGER LN2O5 ! local pointer to N2O5 + PARAMETER ( LN2O5 = 3 ) + INTEGER LCO2 ! local pointer to CO2 + PARAMETER ( LCO2 = 4 ) + + INTEGER LNH3 ! local pointer to NH3 + PARAMETER ( LNH3 = 5 ) + + INTEGER LH2O2 ! local pointer to H2O2 + PARAMETER ( LH2O2 = 6 ) + + INTEGER LO3 ! local pointer to O3 + PARAMETER ( LO3 = 7 ) + + INTEGER LFOA ! local pointer to FOA + PARAMETER ( LFOA = 8 ) + + INTEGER LMHP ! local pointer to MHP + PARAMETER ( LMHP = 9 ) + + INTEGER LPAA ! local pointer to PAA + PARAMETER ( LPAA = 10 ) + + INTEGER LH2SO4 ! local pointer to H2SO4 + PARAMETER ( LH2SO4 = 11 ) + +!...pointers for the AQCHEM array AEROSOL + + INTEGER LSO4AKN ! local pointer to SO4I aerosol + PARAMETER ( LSO4AKN = 1 ) + + INTEGER LSO4ACC ! local pointer to SO4 aerosol + PARAMETER ( LSO4ACC = 2 ) + + INTEGER LNH4AKN ! local pointer to NH4I aerosol + PARAMETER ( LNH4AKN = 3 ) + + INTEGER LNH4ACC ! local pointer to NH4 aerosol + PARAMETER ( LNH4ACC = 4 ) + + INTEGER LNO3AKN ! local pointer to NO3I aerosol + PARAMETER ( LNO3AKN = 5 ) + + INTEGER LNO3ACC ! local pointer to NO3 aerosol + PARAMETER ( LNO3ACC = 6 ) + + INTEGER LNO3COR ! local pointer to course aerosol nitrate + PARAMETER ( LNO3COR = 7 ) + + INTEGER LORGAKN ! local pointer to organic I aerosol + PARAMETER ( LORGAKN = 8 ) + + INTEGER LORGACC ! local pointer to organic aerosol + PARAMETER ( LORGACC = 9 ) + + INTEGER LPRIAKN ! local pointer to primary I aerosol + PARAMETER ( LPRIAKN = 10 ) + + INTEGER LPRIACC ! local pointer to primary aerosol + PARAMETER ( LPRIACC = 11 ) + + INTEGER LPRICOR ! local pointer to primary I aerosol + PARAMETER ( LPRICOR = 12 ) + + INTEGER LCACO3 ! local pointer to CaCO3 aerosol + PARAMETER ( LCACO3 = 13 ) + + INTEGER LMGCO3 ! local pointer to MgCO3 aerosol + PARAMETER ( LMGCO3 = 14 ) + + INTEGER LNACL ! local pointer to NaCl aerosol + PARAMETER ( LNACL = 15 ) + + INTEGER LA3FE ! local pointer to Fe+++ aerosol + PARAMETER ( LA3FE = 16 ) + + INTEGER LB2MN ! local pointer to Mn++ aerosol + PARAMETER ( LB2MN = 17 ) + + INTEGER LKCL ! local pointer to NaCl aerosol + PARAMETER ( LKCL = 18 ) + + INTEGER LNUMAKN ! local pointer to # Aitken aerosol + PARAMETER ( LNUMAKN = 19 ) + + INTEGER LNUMACC ! local pointer to # accumulation aerosol + PARAMETER ( LNUMACC = 20 ) + + INTEGER LNUMCOR ! local pointer to # coarse aerosol + PARAMETER ( LNUMCOR = 21 ) + + INTEGER LSRFAKN ! local pointer to sfc area Aitken aerosol + PARAMETER ( LSRFAKN = 22 ) + + INTEGER LSRFACC ! local pntr to sfc area accumulation aerosol + PARAMETER ( LSRFACC = 23 ) + + +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + num_cc,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,ipr,jpr,j,npr + real, dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,cd,zu,p,hstary,t + real, dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cupclw,clw_all + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (inout ) :: & + tr_up,tr_c,tr_pw + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (in ) :: & + tre_cup,tracer + real, dimension (its:ite) & + ,intent (in ) :: & + pre + + ! entr= entrainment rate + real & + ,intent (in ) :: & + mentr_rate,tcrit + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop,k22 + ! ierr error value, maybe modified in this routine + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +! local variables in this routine +! + real :: conc_equi,conc_mxr,partialp,taucld + + integer :: & + iall,i,k,iwd,nv + real :: & + dh,qrch,c0,dz,radius,airm,dens + integer :: & + itf,ktf,iaer,igas +! +! aerosol scavenging coeffs for aitken mode +! + real alfa0,alfa2,alfa3 +! output variables +! hpwdep h+ deposition + real, dimension (ngas) :: gas,gaswdep + real, dimension (naer) :: aerosol,aerwdep + real hpwdep + alfa0=0. + alfa2=0. + alfa3=0. + gas(lco2)=340. + taucld=1800. + qrch=0. + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) + +! + iall=0 + c0=.002 + iwd=0 +! +!--- no precip for small clouds +! + if(mentr_rate.gt.0.)then + radius=.2/mentr_rate + if(radius.lt.900.)c0=0. +! if(radius.lt.900.)iall=0 + endif + do nv=1,num_chem + do k=kts,ktf + do i=its,itf + tr_pw(i,k,nv)=0. + tr_up(i,k,nv)=tre_cup(i,k,nv) + tr_c(i,k,nv)=0. + enddo + enddo + enddo + do nv=1,num_chem + do i=its,itf + if(ierr(i).eq.0.)then + do k=k22(i),kbcon(i)-1 + tr_up(i,k,nv)=tre_cup(i,k22(i),nv) + enddo + endif + enddo + enddo + if(j.eq.jpr)print *,'p_so2,o_o3 = ',p_so2,p_o3 + DO 100 k=kts+1,kte-1 + DO 100 i=its,itf + AEROSOL=0. + GAS=0. + IF(ierr(i).ne.0)GO TO 100 + IF(K.Lt.KBCON(I))GO TO 100 + IF(K.Gt.KTOP(I)+1)GO TO 100 + DZ=Z_cup(i,K)-Z_cup(i,K-1) + if(cupclw(i,k).le.0.)cupclw(i,k)=0. + if(clw_all(i,k).le.0.)clw_all(i,k)=0. +! +!------ 1. steady state plume equation, for what could +!------ be in cloud before anything happens (kg/kg) +!------ tr_up would be the concentration if tr would be conserved +! +! + do nv=1,num_chem + if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)print *,k,tr_up(i,K-1,nv),tr_up(i,K,nv),tr_pw(i,k-1,nv),clw_all(i,k),cupclw(i,k) + tr_up(i,K,nv)=(tr_up(i,K-1,nv)*(1.-.5*CD(i,K)*DZ)+mentr_rate* & + DZ*tracer(i,K-1,nv))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) + enddo +! +! sources or sinks due to aq chem +! + + dens=1000.*p(i,k)*100./t(i,k)/287./28.9628 + airm=dens*dz +!...gas concentrations (ppm) + + GAS( LCO2 ) = 370.0 + GAS( LFOA ) = 0.0 ! ??? + GAS( LMHP ) = 0.0 ! ??? + + GAS( LSO2 ) = tr_up(i,k,p_so2) + GAS( LH2SO4 ) = tr_up(i,k,p_sulf) + GAS( LNH3 ) = tr_up(i,k,p_nh3) + GAS( LH2O2 ) = tr_up(i,k,p_h2o2) + + GAS( LO3 ) = tr_up(i,k,p_o3) + GAS( LPAA ) = tr_up(i,k,p_paa) + GAS( LHNO3 ) = tr_up(i,k,p_hno3) + GAS( LN2O5 ) = tr_up(i,k,p_n2o5) +!...convert to mol/mol + + DO IGAS=1,NGAS + GAS( IGAS ) = GAS( IGAS ) * 1.0E-6 + END DO + +!...aerosol concentrations (ug/m3) + +! AEROSOL( LSO4ACC ) = 20.0 +! AEROSOL( LNH4ACC ) = 6.65 +! AEROSOL( LNO3ACC ) = 10.0 +! AEROSOL( LNACL ) = 1.71 +!! AEROSOL( LA3FE ) = 0.5 +! AEROSOL( LB2MN ) = 0.02 +! AEROSOL( LNO3COR ) = 0.0 + AEROSOL( LORGACC ) = 0.0 + AEROSOL( LPRIACC ) = 0.0 +! AEROSOL( LCACO3 ) = 3.05 +! AEROSOL( LMGCO3 ) = 0.0 + + AEROSOL( LSO4ACC ) = tr_up(i,k,p_so4aj) + AEROSOL( LNH4ACC ) = tr_up(i,k,p_nh4aj) + AEROSOL( LNO3ACC ) = tr_up(i,k,p_no3aj) + AEROSOL( LNACL ) = 0. + AEROSOL( LA3FE ) = .5 + AEROSOL( LB2MN ) = .02 + AEROSOL( LNO3COR ) = 0. +! AEROSOL( LORGACC ) = tr_up(i,k,) + tr_up(i,k,) + tr_up(i,k,) +! AEROSOL( LPRIACC ) = tr_up(i,k,) + tr_up(i,k,) + AEROSOL( LCACO3 ) = 0. + AEROSOL( LMGCO3 ) = 0. + + +!...convert to mol/mol +! + +! DO IAER=1,NAER +! AEROSOL( IAER ) = AEROSOL( IAER ) * 1.0E-6 * CTHK1 +! & / ( SGRAERMW( IAER ) * AIRM ) +! END DO + DO IAER=1,NAER + AEROSOL( IAER ) = AEROSOL( IAER ) * 1.0E-6 + END DO +! first clw is water, second is total + + GASWDEP=0. + AERWDEP=0. + HPWDEP=0. +! if(clw_all(i,k).gt.1.e-12)then +! if(cupclw(i,k).gt.1.e-12)then +! CALL AQCHEM (t(i,k),p(i,k)*100.,taucld,cupclw(i,k)/3600., & +! clw_all(i,k)*dens,clw_all(i,k)*dens,airm,ALFA0,ALFA2,ALFA3,GAS, & +! AEROSOL, GASWDEP, AERWDEP, HPWDEP ) +! endif +! endif + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! FOLLOWING FOR WET DEPOSITION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do nv=1,num_chem + tr_c(i,k,nv)=0. + tr_pw(i,k,nv)=c0*dz*tr_C(I,K,nv)*zu(i,k) + if(tr_c(i,k,nv).le.0.)then + tr_c(i,k,nv)=0. + endif + enddo +! +!--- iall.eq.1, if all cloudwater goes to rain +! + if(iall.eq.1)then + tr_c(i,k,nv)=0. + tr_pw(i,k,nv)=(tr_c(I,K,nv)-QRCH)*zu(i,k) + if(tr_pw(i,k,nv).lt.0.)tr_pw(i,k,nv)=0. + endif + +! +!----- set next level +! tr_up(I,K,nv)=tr_c(I,K,nv)+qrch + tr_up(i,k,p_so2)=gas(lso2)*1.e6 + tr_up(i,k,p_sulf)=gas(lh2so4)*1.e6 + tr_up(i,k,p_nh3)=gas(lnh3)*1.e6 + tr_up(i,k,p_h2o2)=gas(lh2o2)*1.e6 + + tr_up(i,k,p_o3)=gas(lo3)*1.e6 + tr_up(i,k,p_paa)=gas(lpaa)*1.e6 + tr_up(i,k,p_hno3)=gas(lhno3)*1.e6 + tr_up(i,k,p_n2o5)=gas(ln2o5)*1.e6 + tr_up(i,k,p_so4aj)=AEROSOL( LSO4ACC )*1.e6 + tr_up(i,k,p_nh4aj)=AEROSOL( LNH4ACC )*1.e6 + tr_up(i,k,p_no3aj)=AEROSOL( LNO3ACC ) *1.e6 + + tr_pw(i,k,p_so2)=gaswdep(lso2)*1.e6 + tr_pw(i,k,p_sulf)=gaswdep(lh2so4)*1.e6 + tr_pw(i,k,p_nh3)=gaswdep(lnh3)*1.e6 + tr_pw(i,k,p_h2o2)=gaswdep(lh2o2)*1.e6 + + tr_pw(i,k,p_o3)=gaswdep(lo3)*1.e6 + tr_pw(i,k,p_paa)=gaswdep(lpaa)*1.e6 + tr_pw(i,k,p_hno3)=gaswdep(lhno3)*1.e6 + tr_pw(i,k,p_n2o5)=gaswdep(ln2o5)*1.e6 + tr_pw(i,k,p_so4aj)=AERwdep( LSO4ACC )*1.e6 + tr_pw(i,k,p_nh4aj)=AERwdep( LNH4ACC )*1.e6 + tr_pw(i,k,p_no3aj)=AERwdep( LNO3ACC ) *1.e6 + if(i.eq.ipr.and.j.eq.jpr)then + write(6,*)'a',tr_up(i,k,npr),tracer(i,K-1,npr),tr_pw(i,k,npr) + endif + + 100 CONTINUE + + +END subroutine cup_up_tracer + + + + SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & + tr_pw,tr_pwd,jmin,cdd,entr,zd,pwdper,k22, & + numch,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + USE module_configure + USE module_state_description + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + numch,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real, dimension (its:ite,kts:kte) & + ,intent (in ) :: & + pwdper,zd,cdd,qrcd,z_cup + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (inout ) :: & + tr_dd,tr_pwd,tr_up + real, dimension (its:ite,kts:kte,1:num_chem) & + ,intent (in ) :: & + tre_cup,tracer,tr_pw + real, dimension (its:ite,1:num_chem) :: pwav + + ! entr= entrainment rate + real & + ,intent (in ) :: & + entr + integer, dimension (its:ite) & + ,intent (in ) :: & + jmin + ! ierr error value, maybe modified in this routine + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,k22 +! local variables in this routine +! + + integer :: & + iall,i,k,nv,ki + real :: & + dh,qrch,c0,dz,radius + integer :: & + itf,ktf + logical iaer (num_chem) + iaer = .false. + + iaer(p_so4aj) = .true. + iaer(p_nh4aj) = .true. + iaer(p_no3aj) = .true. + + itf=MIN(ite,ide-1) + ktf=MIN(kte,kde-1) +! + qrch=0. + do nv=1,num_chem + do k=kts+1,kte + do i=its,ite + tr_dd(i,k,nv)=0. + tr_pwd(i,k,nv)=0. + enddo + enddo + do i=its,ite + pwav(i,nv)=0. + IF(ierr(I).eq.0)then + do k=kts,ktf + pwav(i,nv)=pwav(i,nv)+tr_pw(i,k,nv) + enddo + endif + enddo + enddo +! +!--- in downdraft, do only transport of tracers, other +!--- than evaporation of part of the rainwater (see below) +! +! + do 100 i=its,ite + IF(ierr(I).eq.0)then +! +!--- assume no gas takeup by rain during falling +!--- for now +! +! + do nv=1,num_chem + tr_dd(i,jmin(i),nv)=tre_cup(i,jmin(i),nv) + enddo + do ki=jmin(i)-1,1,-1 + DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) + do nv=1,num_chem + tr_pwd(i,jmin(i),nv)=0. + tr_dd(i,Ki,nv)=(tr_dd(i,Ki+1,nv)*(1.-.5*CDD(i,Ki)*DZ) & + +entr*DZ*tracer(i,Ki,nv) & + )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ) +! +!--- if tracer conserved +! + qrch=tr_dd(i,Ki,nv) +! +!--- part of dissolved liquid phase material that is being evaporated +! need percentage of rainwater that evaporates at level +! pwdper +! qcd=qcd+pwdper +! +! tr_pwd(i,ki,nv)=pwdper(i,ki)*pwav(i,nv) + if(iaer(nv))then + tr_pwd(i,ki,nv)=0. + else + tr_pwd(i,ki,nv)=pwdper(i,ki)*pwav(i,nv) + endif + tr_dd(i,ki,nv)=qrch+tr_pwd(i,ki,nv) + enddo +! +!--- end loop over nv + enddo + endif +100 continue + +END subroutine cup_dd_tracer + + + + + SUBROUTINE neg_check_ct(pret,ktop,epsilc,dt,q,outq,iopt,num_chem, & + its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j) + + INTEGER, INTENT(IN ) :: iopt,num_chem,its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j + + real, dimension (its:ite,kts:kte,num_chem ) , & + intent(inout ) :: & + q,outq + real, dimension (its:ite ) , & + intent(in ) :: & + pret + integer, dimension (its:ite ) , & + intent(in ) :: & + ktop + real & + ,intent (in ) :: & + dt,epsilc + real :: tracermin,tracermax,thresh,qmem,qmemf,qmem2,qtest,qmem1 +! +! check whether routine produces negative q's. This can happen, since +! tendencies are calculated based on forced q's. This should have no +! influence on conservation properties, it scales linear through all +! tendencies. Use iopt=0 to test for each tracer seperately, iopt=1 +! for a more severe limitation... +! + thresh=epsilc +! thresh=1.e-30 + if(iopt.eq.0)then + do nv=1,num_chem + do 100 i=its,itf + if(pret(i).le.0.)go to 100 + tracermin=q(i,kts,nv) + tracermax=q(i,kts,nv) + do k=kts+1,kte-1 + tracermin=min(tracermin,q(i,k,nv)) + tracermax=max(tracermax,q(i,k,nv)) + enddo + tracermin=max(tracermin,thresh) + qmemf=1. +! +! first check for minimum restriction +! + do k=kts,ktop(i) +! +! tracer tendency +! + qmem=outq(i,k,nv) +! +! only necessary if there is a tendency +! + if(qmem.lt.0.)then + qtest=q(i,k,nv)+outq(i,k,nv)*dt + if(qtest.lt.tracermin)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=outq(i,k,nv) + qmem2=(tracermin-q(i,k,nv))/dt + qmemf=min(qmemf,qmem2/qmem1) + if(qmemf.gt.1.)print *,'something wrong in negct_1',qmem2,qmem1 + if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)then + print *,k,qtest,qmem2,qmem1,qmemf + endif + qmemf=max(qmemf,0.) + endif + endif + enddo + do k=kts,ktop(i) + outq(i,k,nv)=outq(i,k,nv)*qmemf + enddo +! +! now check max +! + qmemf=1. + do k=kts,ktop(i) +! +! tracer tendency +! + qmem=outq(i,k,nv) +! +! only necessary if there is a tendency +! + if(qmem.gt.0.)then + qtest=q(i,k,nv)+outq(i,k,nv)*dt + if(qtest.gt.tracermax)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=outq(i,k,nv) + qmem2=(tracermax-q(i,k,nv))/dt + qmemf=min(qmemf,qmem2/qmem1) + if(qmemf.gt.1.)print *,'something wrong in negct_2',qmem2,qmem1 + if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)then + print *,'2',k,qtest,qmem2,qmem1,qmemf + endif + qmemf=max(qmemf,0.) + endif + endif + enddo + do k=kts,ktop(i) + outq(i,k,nv)=outq(i,k,nv)*qmemf + enddo + 100 continue + enddo +! +! ELSE +! + elseif(iopt.eq.1)then + do i=its,itf + qmemf=1. + do k=kts,ktop(i) + do nv=1,num_chem +! +! tracer tendency +! + qmem=outq(i,k,nv) +! +! only necessary if tendency is larger than zero +! + if(qmem.lt.0.)then + qtest=q(i,k,nv)+outq(i,k,nv)*dt + if(qtest.lt.thresh)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=outq(i,k,nv) + qmem2=(thresh-q(i,k,nv))/dt + qmemf=min(qmemf,qmem2/qmem1) + qmemf=max(0.,qmemf) + endif + endif + enddo + enddo + do nv=1,num_chem + do k=kts,ktop(i) + outq(i,k,nv)=outq(i,k,nv)*qmemf + enddo + enddo + enddo + endif + + END SUBROUTINE neg_check_ct + + +!------------------------------------------------------- +END MODULE module_ctrans_grell diff --git a/wrfv2_fire/chem/module_data_cbmz.F b/wrfv2_fire/chem/module_data_cbmz.F new file mode 100644 index 00000000..cc9c6ef9 --- /dev/null +++ b/wrfv2_fire/chem/module_data_cbmz.F @@ -0,0 +1,211 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! CBMZ module: see module_cbmz.F for information and terms of use +!********************************************************************************** +! file module_data_cbmf.f - new on 17-nov-2003 +!----------------------------------------------------------------------------- + + module module_data_cbmz + + + integer nfixed_kppmax + parameter (nfixed_kppmax = 20) + + integer nreact_kppmax + parameter (nreact_kppmax = 256) + + real avognumkpp + parameter (avognumkpp = 6.02252e23) ! molecules/mole + + + integer nvar_r01_kpp, nfix_r01_kpp, nreact_r01_kpp, & + lu_nonzero_v_r01_kpp + parameter ( nvar_r01_kpp = 28 ) + parameter ( nfix_r01_kpp = 5 ) + parameter ( nreact_r01_kpp = 74 ) + parameter ( lu_nonzero_v_r01_kpp = 194 ) + + integer nvar_r02_kpp, nfix_r02_kpp, nreact_r02_kpp, & + lu_nonzero_v_r02_kpp + parameter ( nvar_r02_kpp = 48 ) + parameter ( nfix_r02_kpp = 5 ) + parameter ( nreact_r02_kpp = 118 ) + parameter ( lu_nonzero_v_r02_kpp = 459 ) + + integer nvar_r03_kpp, nfix_r03_kpp, nreact_r03_kpp, & + lu_nonzero_v_r03_kpp + parameter ( nvar_r03_kpp = 53 ) + parameter ( nfix_r03_kpp = 5 ) + parameter ( nreact_r03_kpp = 134 ) + parameter ( lu_nonzero_v_r03_kpp = 564 ) + + integer nvar_r04_kpp, nfix_r04_kpp, nreact_r04_kpp, & + lu_nonzero_v_r04_kpp + parameter ( nvar_r04_kpp = 39 ) + parameter ( nfix_r04_kpp = 5 ) + parameter ( nreact_r04_kpp = 106 ) + parameter ( lu_nonzero_v_r04_kpp = 334 ) + + integer nvar_r05_kpp, nfix_r05_kpp, nreact_r05_kpp, & + lu_nonzero_v_r05_kpp + parameter ( nvar_r05_kpp = 59 ) + parameter ( nfix_r05_kpp = 5 ) + parameter ( nreact_r05_kpp = 150 ) + parameter ( lu_nonzero_v_r05_kpp = 606 ) + + integer nvar_r06_kpp, nfix_r06_kpp, nreact_r06_kpp, & + lu_nonzero_v_r06_kpp + parameter ( nvar_r06_kpp = 64 ) + parameter ( nfix_r06_kpp = 5 ) + parameter ( nreact_r06_kpp = 166 ) + parameter ( lu_nonzero_v_r06_kpp = 715 ) + + + integer & + ino_z, ino2_z, ino3_z, & + in2o5_z, ihono_z, ihno3_z, & + ihno4_z, io3_z, io1d_z, & + io3p_z, ioh_z, iho2_z, & + ih2o2_z, ico_z, iso2_z, & + ih2so4_z, inh3_z, ihcl_z, & + ich4_z, ic2h6_z, ich3o2_z, & + iethp_z, ihcho_z, ich3oh_z, & + ic2h5oh_z, ich3ooh_z, iethooh_z, & + iald2_z, ihcooh_z, ipar_z, & + iaone_z, imgly_z, ieth_z, & + iolet_z, iolei_z, itol_z, & + ixyl_z, icres_z, ito2_z, & + icro_z, iopen_z, ionit_z, & + ipan_z, ircooh_z, irooh_z, & + ic2o3_z, iro2_z, iano2_z, & + inap_z, ixo2_z, ixpar_z, & + iisop_z, iisoprd_z, iisopp_z, & + iisopn_z, iisopo2_z, idms_z, & + imsa_z, idmso_z, idmso2_z, & + ich3so2h_z, ich3sch2oo_z, ich3so2_z, & + ich3so3_z, ich3so2oo_z, ich3so2ch2oo_z, & + imtf_z, & + ih2o_z, io2_z, in2_z, & + ih2_z + + parameter ( & + ino_z=01, ino2_z=02, ino3_z=03, & + in2o5_z=04, ihono_z=05, ihno3_z=06, & + ihno4_z=07, io3_z=08, io1d_z=09, & + io3p_z=10, ioh_z=11, iho2_z=12, & + ih2o2_z=13, ico_z=14, iso2_z=15, & + ih2so4_z=16, inh3_z=17, ihcl_z=18, & + ich4_z=19, ic2h6_z=20, ich3o2_z=21, & + iethp_z=22, ihcho_z=23, ich3oh_z=24, & + ic2h5oh_z=25, ich3ooh_z=26, iethooh_z=27, & + iald2_z=28, ihcooh_z=29, ipar_z=30, & + iaone_z=31, imgly_z=32, ieth_z=33, & + iolet_z=34, iolei_z=35, itol_z=36, & + ixyl_z=37, icres_z=38, ito2_z=39, & + icro_z=40, iopen_z=41, ionit_z=42, & + ipan_z=43, ircooh_z=44, irooh_z=45, & + ic2o3_z=46, iro2_z=47, iano2_z=48, & + inap_z=49, ixo2_z=50, ixpar_z=51, & + iisop_z=52, iisoprd_z=53, iisopp_z=54, & + iisopn_z=55, iisopo2_z=56, idms_z=57, & + imsa_z=58, idmso_z=59, idmso2_z=60, & + ich3so2h_z=61, ich3sch2oo_z=62, ich3so2_z=63, & + ich3so3_z=64, ich3so2oo_z=65, ich3so2ch2oo_z=66, & + imtf_z=67, & + ih2o_z=68, io2_z=69, in2_z=70, & + ih2_z=71 ) + + + integer ngas_z + parameter (ngas_z=71) + + character(len=12), save :: name_z(ngas_z) = (/ & + 'no ', 'no2 ', 'no3 ', & + 'n2o5 ', 'hono ', 'hno3 ', & + 'hno4 ', 'o3 ', 'o1d ', & + 'o3p ', 'oh ', 'ho2 ', & + 'h2o2 ', 'co ', 'so2 ', & + 'h2so4 ', 'nh3 ', 'hcl ', & + 'ch4 ', 'c2h6 ', 'ch3o2 ', & + 'ethp ', 'hcho ', 'ch3oh ', & + 'c2h5oh ', 'ch3ooh ', 'ethooh ', & + 'ald2 ', 'hcooh ', 'par ', & + 'aone ', 'mgly ', 'eth ', & + 'olet ', 'olei ', 'tol ', & + 'xyl ', 'cres ', 'to2 ', & + 'cro ', 'open ', 'onit ', & + 'pan ', 'rcooh ', 'rooh ', & + 'c2o3 ', 'ro2 ', 'ano2 ', & + 'nap ', 'xo2 ', 'xpar ', & + 'isop ', 'isoprd ', 'isopp ', & + 'isopn ', 'isopo2 ', 'dms ', & + 'msa ', 'dmso ', 'dmso2 ', & + 'ch3so2h ', 'ch3sch2oo ', 'ch3so2 ', & + 'ch3so3 ', 'ch3so2oo ', 'ch3so2ch2oo ', & + 'mtf ', & + 'h2o ', 'o2 ', 'n2 ', & + 'h2 ' /) + + +! photolyzing species reactions + integer & + jphoto_no2, jphoto_no3, jphoto_hono, & + jphoto_hno3, jphoto_hno4, jphoto_n2o5, & + jphoto_o3a, jphoto_o3b, jphoto_h2o2, & + jphoto_hchoa, jphoto_hchob, jphoto_ch3ooh, & + jphoto_ethooh, jphoto_ald2, jphoto_aone, & + jphoto_mgly, jphoto_open, jphoto_rooh, & + jphoto_onit, jphoto_isoprd + parameter ( & + jphoto_no2=1, jphoto_no3=2, jphoto_hono=3, & + jphoto_hno3=4, jphoto_hno4=5, jphoto_n2o5=6, & + jphoto_o3a=7, jphoto_o3b=8, jphoto_h2o2=9, & + jphoto_hchoa=10, jphoto_hchob=11, jphoto_ch3ooh=12, & + jphoto_ethooh=13, jphoto_ald2=14, jphoto_aone=15, & + jphoto_mgly=16, jphoto_open=17, jphoto_rooh=18, & + jphoto_onit=19, jphoto_isoprd=20 ) + + +! +! parameter statements from cbmz_local.h +! + + integer ngas_m1, nrxn_m1, ngas_m2, nrxn_m2, & + ngas_m3, nrxn_m3, ngas_m4, nrxn_m4 + parameter(ngas_m1 = 31, nrxn_m1 = 74, & ! background troposphere + ngas_m2 = 19, nrxn_m2 = 53, & ! urban + ngas_m3 = 5, nrxn_m3 = 16, & ! rural continental + ngas_m4 = 11, nrxn_m4 = 32) ! remote marine + + integer ngas_tot + parameter(ngas_tot= ngas_m1 + ngas_m2 + ngas_m3 + ngas_m4) + + integer ngas_r1, ngas_r2, ngas_r3, ngas_r4, ngas_r5, ngas_r6 + parameter(ngas_r1 = ngas_m1) ! regime 1 + parameter(ngas_r2 = ngas_m1 + ngas_m2) ! regime 2 + parameter(ngas_r3 = ngas_m1 + ngas_m2 + ngas_m3) ! regime 3 + parameter(ngas_r4 = ngas_m1 + ngas_m4) ! regime 4 + parameter(ngas_r5 = ngas_m1 + ngas_m2 + ngas_m4) ! regime 5 + parameter(ngas_r6 = ngas_m1 + ngas_m2 + ngas_m3 + ngas_m4)! regime 6 + + integer nperox + parameter(nperox=10) ! total number of alkylperoxy radicals + + integer nphoto + parameter(nphoto=20) ! total number of photolysis rxn rates + + +! permutation reactions of alkyl/acyl peroxy radicals + integer & + jch3o2, jethp, jro2, jc2o3, jano2, & + jnap, jisopp, jisopn, jisopo2, jxo2 + parameter ( & + jch3o2=1, jethp=2, jro2=3, jc2o3=4, jano2=5, & + jnap=6, jisopp=7, jisopn=8, jisopo2=9, jxo2=10 ) + + + end module module_data_cbmz diff --git a/wrfv2_fire/chem/module_data_cmu_bulkaqchem.F b/wrfv2_fire/chem/module_data_cmu_bulkaqchem.F new file mode 100644 index 00000000..dd84f65b --- /dev/null +++ b/wrfv2_fire/chem/module_data_cmu_bulkaqchem.F @@ -0,0 +1,400 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + + module module_data_cmu_bulkaqchem + + + implicit none + + + +!----------------------------------------------------------------------- +! aerpar.inc +!----------------------------------------------------------------------- +!****************************************************************** +! aerosol parameters +!****************************************************************** +! +! useful constants +! + double precision pi, pi6 + parameter (pi = 3.14159) + parameter (pi6 = pi/6.0) + + double precision rho + parameter (rho = 1.4e12) ! particle density [ug/m^3] +! +! aerosol components in the aerosol concentration vector +! + integer nas, nah, naa, nan, nac, na4, naw, nae, nao, nar + integer nahso5, nahmsa, naspec + parameter (nas = 1) ! sodium + parameter (nah = 2) ! hydrogen + parameter (naa = 3) ! ammonium + parameter (nan = 4) ! nitrate + parameter (nac = 5) ! chloride + parameter (na4 = 6) ! sulfate + parameter (naw = 7) ! water + parameter (nae = 8) ! elemental carbon + parameter (nao = 9) ! organics + parameter (nar = 10) ! crustal + parameter (nahso5 = 11) ! hso5- + parameter (nahmsa = 12) ! hmsa + parameter (naspec = 12) ! number of aerosol species +! +! condensible gas-phase components in local arrays +! + integer ngca, ngcn, ngcc, ngc4, ngco, ngcspec + parameter (ngca = 1) ! ammonia + parameter (ngcn = 2) ! nitric acid + parameter (ngcc = 3) ! hydrochloric acid + parameter (ngc4 = 4) ! gas-phase sulfate + parameter (ngco = 5) ! gas-phase organics + parameter (ngcspec = 5) ! number of condensible gas-phase species +! +! condensible gas-phase components in global gas-phase array +! +! this must be customized to have the correct addresses +! + integer nga, ngn, ngc, ng4, ngo, ngspec + parameter (nga = 1) ! ammonia + parameter (ngn = 2) ! nitric acid + parameter (ngc = 3) ! hydrochloric acid + parameter (ng4 = 4) ! gas-phase sulfate + parameter (ngo = 5) ! gas-phase organics + parameter (ngspec = 5) ! number of condensible gas-phase species +! +! total number of gas phase species so we know where the aerosol starts +! + integer ngtotal, ngas, naers +! parameter (ngtotal = 50) + parameter (ngtotal = 26) ! 2004-nov-15 rce + parameter (ngas=ngtotal) + parameter (naers=naspec) + + + +!----------------------------------------------------------------------- +! droppar.inc +!----------------------------------------------------------------------- +! updated droppar.inc for the bulk model +! last update : 10 june 1998 +!************************************************************************* +! droppar.inc +!************************************************************************* +! +! aqueous-phase parameters and variables +! +! aqueous-phase components +! +! important : all components have the same positions in +! both aerosol and aqueous matrices +! never change this convention because aqmain +! depends on it +! + integer ksod, khyd, kamm, knit, kchl, ksvi, kwat, kec, koc, kcru + parameter (ksod = nas) ! na(+) + parameter (khyd = nah) ! h(+) + parameter (kamm = naa) ! nh4(+) + parameter (knit = nan) ! no3(-) + parameter (kchl = nac) ! cl(-) + parameter (ksvi = na4) ! s(vi) + parameter (kwat = naw) ! h2o + parameter (kec = nae) ! ec + parameter (koc = nao) ! oc + parameter (kcru = nar) ! crustal +! parameter (khso5 = 1) ! hso5- +! parameter (khmsa = 2) ! hmsa +! parameter (kform = 3) ! formic acid +! +! gases in local array +! +! incorrect ******* to be fixed ************* + integer ngso2, ngh2o2, nghcho, nghcooh + integer nghno2, ngno, ngno2, ngo3, ngpan, ngoh, ngho2, ngno3 + integer ngch3o2, ngch3o2h, ngch3oh, ngch3co3h + parameter (ngso2 = 11) + parameter (ngh2o2 = 12) + parameter (nghcho = 13) + parameter (nghcooh = 14) + parameter (nghno2 = 15) + parameter (ngno = 16) + parameter (ngno2 = 17) + parameter (ngo3 = 18) + parameter (ngpan = 19) + parameter (ngoh = 20) + parameter (ngho2 = 21) + parameter (ngno3 = 22) + parameter (ngch3o2 = 23) + parameter (ngch3o2h = 24) + parameter (ngch3oh = 25) + parameter (ngch3co3h = 26) +! +! number of equations for aqueous-phase chemistry solution +! + integer meqn1max + parameter (meqn1max = 20) + integer, save :: meqn1 = meqn1max +! +! activation diameter (dry) +! + double precision dactiv + parameter (dactiv = 0.7e-6) ! in m +! +! +! +! wet diameter +! + double precision avdiam + parameter (avdiam = 20.e-6) +! +! choice of expression for iron chemistry +! = 0 (no iron/manganese chemistry) +! kiron = 1 (phenomenological, martin et al., 1991) +! = 2 (martin, 1984) +! + integer kiron +! parameter (kiron = 1) ! was 1 +! parameter (kiron = 0) ! rce 2004-mar-24 - turn off metal chem + parameter (kiron = 1) ! rce 2005-jan-17 - turn it back on +! +! choice of turning on or off radical chemisty +! (it is better to turn it off during the night) +! + integer, save :: iradical +! parameter (iradical = 0) ! rce 2004-nov-15 - now a common var + +! +! choice of turning off chlorine chemistry +! + double precision chlorine + parameter (chlorine = 0.0) +! +! parameter for scaling of photolysis rates +! + double precision, save :: photo +! parameter (photo = 1.0) +! parameter (photo = 0.0) ! rce 2004-mar-24 - turn off photo chem + ! rce 2004-nov-15 - now a common var +! +! fraction of crustal material that is alkaline +! + double precision caratio +! parameter (caratio = 0.05) ! was 0.1 +! rce 2005-jul-14 - reduce caratio to .001 to get lower ph +! with 0.05 value, ca=.05*oin, and the initial aerosol is alkaline + parameter (caratio = 0.001) +! +! +! +! fraction of liquid water content that goes to each s.r. section +! + double precision frac1, frac2 + parameter (frac1 = 0.8) ! fraction of lwc in sect. 1 + parameter (frac2 = 0.2) ! fraction of lwc in sect. 2 +! +! +! assumption : fe(3+) and mn(2+) = 0.003%, 0.001% of crustal mass +! + double precision firon, fman +! parameter (firon = 0.00003) +! parameter (fman = 0.00001) +! parameter (firon = 0.0) ! rce 2004-mar-24 - turn off metal chem +! parameter (fman = 0.0) ! rce 2004-mar-24 - turn off metal chem + parameter (firon = 0.00003) ! rce 2005-jan-17 - turn it back on + parameter (fman = 0.00001) ! rce 2005-jan-17 - turn it back on + +! co2 mixing ratio (ppm) + double precision, save :: co2_mixrat + +! common / aqcmu_cmn11 / iradical, photo, co2_mixrat + + +!----------------------------------------------------------------------- +! dropcom.inc +!----------------------------------------------------------------------- +! +! common groups and corresponding matrices for aqueous-phase module +! + double precision, save :: akeq(17), akhen(21), akre(120) + double precision, save :: wso2, wh2o2, whcho, whcooh, wnh3, whno3, whcl, wh2so4 + double precision, save :: wmol(29), amol(3), gmol(22) +! common / drop / diameter, dd, daer +! common / mw / wso2, wh2o2, whcho, whcooh, wnh3, whno3, whcl, wh2so4 +! common /aqrates2/akeq,akhen,akre +! common /aqrates3/wmol,amol,gmol + + double precision, save :: gcon(22), con(28), cmet(4), rad, wvol, chyd, & + temp_cmuaq_cur, pres_cmuaq_cur +! common / sstate / gcon, con, cmet, rad, wvol, chyd, & +! temp_cmuaq_cur, pres_cmuaq_cur + + + +!----------------------------------------------------------------------- +! math.inc +!----------------------------------------------------------------------- +! include file for svode parameters and non-changing values +! input to hybrid.f + +! integer itol,itask,istate,iopt,mf,worki,lrw1,liw1 + integer itol,itask,iopt,mf,worki,lrw1,liw1 + double precision tola,tolr,workr + integer numfunc, mode, nprint, maxfev, ml, mu, lr,ldfjac + double precision factor, epsfcn, xtol + +! for svode + parameter (itol = 4) +! parameter (tola = 1.e-4) ! was 1.e-3 + parameter (tola = 1.e-6) ! 17-may-2006 rce - need smaller tola + parameter (tolr = 1.e-5) ! was 1.e-3 + parameter (itask = 1) +! parameter (istate = 1) ! rce 2004-mar-18 - istate is a variable + parameter (iopt = 1) + parameter (mf = 22) + parameter (worki = 100000) ! maximum steps allowed + parameter (workr = 300.0) +! for bulk + parameter (lrw1 = 22+9*meqn1max+2*meqn1max**2) + parameter (liw1 = 30+meqn1max) +! +! where +! itol: 4=use arrays for tolerances +! tola: absolute tolerance in ug/m3 +! tolr: relative tolerance +! itask: 1 for normal computation of output values of y at t = tout. +! istate: integer flag (input and output). set istate = 1. +! iopt: 0 to indicate no optional input used. +! rwork: double precision work array of length at least.. +! 20 + 16*neq for mf = 10, +! 22 + 9*neq + 2*neq**2 for mf = 21 or 22, +! 22 + 11*neq + (3*ml + 2*mu)*neq for mf = 24 or 25. +! lrw: declared length of rwork (in user's dimension statement). +! iwork: integer work array of length at least.. +! 30 for mf = 10, +! 30 + neq for mf = 21, 22, 24, or 25. +! if mf = 24 or 25, input in iwork(1),iwork(2) the lower +! and upper half-bandwidths ml,mu. +! liw: declared length of iwork (in user's dimension statement). +! mf: method flag. standard values are.. +! 10 for nonstiff (adams) method, no jacobian used. +! 21 for stiff (bdf) method, user-supplied full jacobian. +! 22 for stiff method, internally generated full jacobian. +! 24 for stiff method, user-supplied banded jacobian. +! 25 for stiff method, internally generated banded jacobian. +! iopt: 1 = some optional parameters used +! here: workr: rwork(6) (max absolute step size allowed - +! default value is infinite.) +! worki: iwork(6) (maximum number of (internally defined) +! steps allowed during one call to the +! solver. the default value is 500.) + +! for hybrid.f + + parameter (numfunc = 7) +! parameter (xtol = 0.1e0**3) + parameter (xtol = 1.0e-3) + parameter (maxfev = 300*(numfunc+1) ) + parameter (ml = numfunc - 1, mu = numfunc -1) + parameter (epsfcn = 0.0e0, factor = 100., mode = 2) + parameter (nprint = 0) + parameter (lr = numfunc*(numfunc+1)/2, ldfjac = numfunc) +! +! numfunc : number of functions and variables +! xtol : termination occurs when the rel error between two consecutive +! iterates is at most xtol +! maxfev : termination occurs when the number of calls to fcn is at least maxfev +! ml : specifies the number of subdiagonals within the band of the +! jacobian matrix. if the jacobian is not banded, set ml to at +! least n -1. +! mu : specifies the number of superdiagonals within the band of the +! jacobian matrix. if the jacobian is not banded, set mu to at +! least n -1. +! epsfcn : used in determining a suitable step length for the +! forward-difference approximation +! factor : used in determining the initial step bound +! mode : if 1, the variables will be scaled internally; if 2, the +! scaling is specified by the input diag. +! nprint : input variable that enables controlled +! printing of iterates if it is positive. in this case, +! fcn is called with iflag = 0 at the beginning of the first +! iteration and every nprint iterations thereafter and +! immediately prior to return, with x and fvec available +! for printing. if nprint is not positive, no special calls +! of fcn with iflag = 0 are made. + + + +!----------------------------------------------------------------------- +! etest_cmn71.inc +!----------------------------------------------------------------------- +! +! maqurxn_all - if positive, all reactions are enabled. +! If zero/negative, all reactions rates are zeroed. +! maqurxn_sulf1 - if positive, 4 primary sulfur reactions are enabled. +! This has no effect when maqurxn_all=1. +! When maqurxn_all=0 & maqurxn_sulf1=1, only the 4 primary +! sulfur reactions (rxns 72-75) are enabled. +! +! mopt_eqrt_cons - if =20, certain equilib. constants and reaction rates +! are modified to allow closer comparison with +! other cloud chemistry codes +! mequlib_h2o2_ho2m - currently not used +! mgasrxn - currently not used +! +! mdiag_fullequil - if positive, warning messages from subr. fullequil +! are enabled +! mdiag_hybrd - if positive, warning messages from subr. hybrd are enabled +! mdiag_negconc - if positive, warning messages from subr. aqoperator1 +! about negative concentrations are enabled +! mdiag_rsrate - if positive, warning messages from subr. aqratesa +! about sulfur mass balance are enabled. This diagnostic is somewhat +! misleading as some reactions do not conserve sulfur. +! mdiag_svode - if positive, warning messages from subr. svode are enabled +! +! mprescribe_ph - if positive, cloudwater ph is set to xprescribe_ph +! + integer, save :: maqurxn_all = 1 + integer, save :: maqurxn_sulf1 = 0 + integer, save :: mopt_eqrt_cons = 0 + integer, save :: mequlib_h2o2_ho2m = 0 + integer, save :: mgasrxn = 0 + integer, save :: mdiag_fullequil = 1 + integer, save :: mdiag_hybrd = 1 + integer, save :: mdiag_negconc = 1 + integer, save :: mdiag_rsrate = 1 + integer, save :: mdiag_svode = 1 + integer, save :: mprescribe_ph = 0 + double precision, save :: xprescribe_ph = 4.5 + +! common / etest_cmn71 / & +! maqurxn_all, maqurxn_sulf1, mequlib_h2o2_ho2m, & +! mgasrxn, mopt_eqrt_cons, mprescribe_ph, mdiagaa, & +! xprescribe_ph + + +! gas constant in [atm/K/(mol/liter)] + double precision rideal + parameter (rideal = 0.082058e0) + +! indices to wmol array, for molecular weights of aqueous species + integer kaqx_siv, kaqx_svi, kaqx_no3m, kaqx_h2o2, & + kaqx_clm, kaqx_nh4p, kaqx_hso5m, kaqx_hmsa + parameter(kaqx_siv = 1) + parameter(kaqx_svi = 2) + parameter(kaqx_no3m = 4) + parameter(kaqx_h2o2 = 6) + parameter(kaqx_clm = 15) + parameter(kaqx_nh4p = 19) + parameter (kaqx_hso5m = 26) + parameter (kaqx_hmsa = 27) + + + + end module module_data_cmu_bulkaqchem diff --git a/wrfv2_fire/chem/module_data_mosaic_asect.F b/wrfv2_fire/chem/module_data_mosaic_asect.F new file mode 100644 index 00000000..50449656 --- /dev/null +++ b/wrfv2_fire/chem/module_data_mosaic_asect.F @@ -0,0 +1,399 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_data_mosaic_asect + + + implicit none + + +!----------------------------------------------------------------------- +! +! The variables in this module provide a means of organizing and accessing +! aerosol species in the "chem" array by their chemical component, +! size bin (or mode), "type", and "phase" +! +! Their purpose is to allow flexible coding of process modules, +! compared to "hard-coding" using the chem array p_xxx indices +! (e.g., p_so4_a01, p_so4_a02, ...; p_num_a01, ...) +! +!----------------------------------------------------------------------- +! +! rce & sg 2004-dec-03 - added phase and type capability, +! which changed this module almost completely +! +!----------------------------------------------------------------------- +! +! maxd_atype = maximum allowable number of aerosol types +! maxd_asize = maximum allowable number of aerosol size bins +! maxd_acomp = maximum allowable number of chemical components +! in each aerosol size bin +! maxd_aphase = maximum allowable number of aerosol phases +! (gas, cloud, ice, rain, ...) +! +! ntype_aer = number of aerosol types +! The aerosol type will allow treatment of an externally mixed +! aerosol. The current MOSAIC code has only 1 type, with the implicit +! assumption of internal mixing. Eventually, multiple types +! could treat fresh primary BC/OC, fresh SO4 from nucleation, +! aged BC/OC/SO4/... mixture, soil dust, sea salt, ... +! +! nphase_aer = number of aerosol phases +! +! ai_phase = phase (p) index for interstitial (unactivated) aerosol particles +! cw_phase = phase (p) index for aerosol particles in cloud water +! ci_phase = phase (p) index for aerosol particles in cloud ice +! rn_phase = phase (p) index for aerosol particles in rain +! sn_phase = phase (p) index for aerosol particles in snow +! gr_phase = phase (p) index for aerosol particles in graupel +! [Note: the value of "xx_phase" will be between 1 and nphase_aer +! for phases that are active in a simulation. The others +! will have non-positive values.] +! +! nsize_aer(t) = number of aerosol size bins for aerosol type t +! +! ncomp_aer(t) = number of "regular" chemical components for aerosol type t +! ncomp_plustracer_aer(t) = number of "regular" plus "tracer" +! chemical components for aerosol type t +! [Note: only "regular" components are used for calculating +! aerosol physical (mass, volume) and chemical properties. +! "Tracer" components are optional, and can be used to track source +! regions, source mechanisms, etc.] +! [Note: for aerosol type t, all phases have the same number of size +! bins, and all size bins have the same number of +! both regular and tracer components.] +! +! ntot_mastercomp_aer = number of aerosol chemical components defined +! in the "master component list". +! [Note: each aerosol type will use some but not necessarily all +! of the components in the "master component list".] +! +! mastercompptr_aer(c,t) = the position/index/i.d. in the +! "master component list" for chemical component c of aerosol type t. +! (1=sulfate, others to be defined by user.) +! +! massptr_aer(c,s,t,p) = the position/index in the chem array for mixing- +! ratio for chemical component c, size bin s, type t, and phase p. +! +! lptr_so4_aer(s,t,p) = the position/index in the chem array for mixing- +! ratio for sulfate for aerosol size bin s, type t, and phase p +! (similar lptr's are defined for no3, cl, msa, co3, +! nh4, na, ca, oin, oc, bc, ...) +! [Note: the massptr_aer allow you to loop over all species of +! an aerosol type. The lptr_so4_aer, etc., allow you to access +! a specific chemical component.] +! +! waterptr_aer(s,t) = the position/index in the chem array for mixing- +! ratio of aerosol water content for size bin s, type t. +! [Note: water content is only carried for the interstitial aerosol +! phase, so there is no p dimension.] +! +! hyswptr_aer(s,t) = the position/index in the chem array for mixing- +! ratio of aerosol "hysteresis water" content for size bin s, type t. +! This is used to determine if aerosol is in the dry or wet state, when +! the ambient RH is between the crystallization and deliquescence RH. +! [Note: hysteresis water content is only carried for the +! interstitial aerosol phase, so there is no p dimension.] +! +! numptr_aer(s,t,p) = the position/index in the chem array for mixing- +! ratio of particle number for size bin s, type t, and phase p. +! +! mprognum_aer(s,t,p) - if positive, number mixing-ratio for size s, type t, +! and phase p will be prognosed. Otherwise, it is diagnosed using +! mass mixing-ratio add assumed/prescribed size. +! +! mixing ratio (moles-water/mole-air) for water +! associated with aerosol size bin s and type t +! +! +! mastercompindx_so4_aer = the position/index in the +! "master component list" for sulfate. +! (similar lptr's are defined for no3, cl, msa, co3, +! nh4, na, ca, oin, oc, bc, ...) +! [Note: the mastercompindx_xxx_aer are used primarily in +! initialization routines, and generally aren't needed elsewhere.] +! +!----------------------------------------------------------------------- +! +! dens_mastercomp_aer(mc) = dry density (g/cm^3) of component mc +! of the master component list. +! dens_aer(c,t) = dry density (g/cm^3) of aerosol chemical component +! c of type t +! [Note: dens_aer(c,t) == dens_mastercomp_aer(mastercompptr_aer(c,t)) +! The dens_mastercomp_aer is used in some initialization routines. +! The dens_aer is used in most other places because of convenience.] +! +! mw_mastercomp_aer(mc) = molecular weight (g/mole) of component mc +! of the master component list. +! mw_aer(c,t) = molecular weight (g/mole) of aerosol chemical component +! c of type t +! [Note: mw_aer(c,t) == mw_mastercomp_aer(mastercompptr_aer(c,t)) ] +! +! name_mastercomp_aer(mc) = name of component mc of the +! master component list (e.g., "sulfate", "nitrate", ...). +! name_aer(c,t) = molecular weight (g/mole) of aerosol chemical component +! c of type t +! [Note: name_aer(c,t) == name_mastercomp_aer(mastercompptr_aer(c,t)) ] +! +! hygro_mastercomp_aer(mc) = bulk hygroscopicity (--) at dilute conditions +! (RH near 100%) of component mc of the master component list. +! hygro_aer(c,t) = bulk hygroscopicity (--) at dilute conditions +! (RH near 100%) of aerosol chemical component c of type t +! [For definition of bulk hygroscopicity, +! see Abdul-Razzak and Ghan, 2004, J Geophys Res, V105, p. 6837-6844.] +! [Note: hygro_aer(c,t) == hygro_mastercomp_aer(mastercompptr_aer(c,t)) ] +! +!----------------------------------------------------------------------- +! +! volumlo_sect(s,t) = 1-particle volume (cm^3) at lower boundary of section m +! volumhi_sect(s,t) = 1-particle volume (cm^3) at upper boundary of section m +! volumcen_sect(s,t)= 1-particle volume (cm^3) at "center" of section m +! +! dlo_sect(s,t) = 1-particle diameter (cm) at lower boundary of section m +! dhi_sect(s,t) = 1-particle diameter (cm) at upper boundary of section m +! dcen_sect(s,t) = 1-particle diameter (cm) at "center" section m +! +! [Note: the "center" values are defined as follows: +! volumcen_sect == 0.5*(volumlo_sect + volumhi_sect) +! == (pi/6) * (dcen_sect**3) ] +! +!----------------------------------------------------------------------- +! +! msectional - if positive, each aerosol size bin is a section. +! if equals 10, use jacobson moving center +! if equals 20, use tzivion mass-number advection +! if zero/negative, each size bin is a mode (aitken, accumulation, ...) +! +! maerosolincw - if positive, both unactivated/interstitial and activated +! aerosol species are simulated. if zero/negative, only the +! unactivated are simulated. [maerosolincw>0 only when cw_phase>0] +! +! maerocoag - if positive, aerosol coagulation is done. +! If zero/negative, it is skipped. +! (This is not yet implemented in WRF-Chem.) +! +! maerchem - if positive, aerosol gas-particle condensation/evaporation +! of inorganic species is done. If zero/negative, it is skipped. +! (This is not yet implemented in WRF-Chem.) +! +! maerchem_boxtest_output - if positive, "boxtest" output is done from +! the aerchemistry routine. If zero/negative, it is skipped. +! (This is not yet implemented in WRF-Chem.) +! +! maeroptical - if positive, aerosol optical properties are calculated. +! If zero/negative, it is skipped. +! (This is not yet implemented in WRF-Chem.) +! +!----------------------------------------------------------------------- + + integer, parameter :: maxd_atype = 1 + integer, parameter :: maxd_asize = 8 + integer, parameter :: maxd_acomp = 12 + integer, parameter :: maxd_aphase = 2 + + integer, save :: ai_phase = -999888777 + integer, save :: cw_phase = -999888777 + integer, save :: ci_phase = -999888777 + integer, save :: rn_phase = -999888777 + integer, save :: sn_phase = -999888777 + integer, save :: gr_phase = -999888777 + + integer, save :: ntype_aer = 0 ! number of types + integer, save :: ntot_mastercomp_aer = 0 ! number of master components + integer, save :: nphase_aer = 0 ! number of phases + + integer, save :: & + nsize_aer( maxd_atype ), & ! number of size bins + ncomp_aer( maxd_atype ), & ! number of chemical components + ncomp_plustracer_aer( maxd_atype ), & + mastercompptr_aer(maxd_acomp, maxd_atype), & ! mastercomp index + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + ! index for mixing ratio + waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water + hyswptr_aer( maxd_asize, maxd_atype ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + ! index for the number mixing ratio + mprognum_aer(maxd_asize,maxd_atype,maxd_aphase) + + +! these indices give the location in the "mastercomp list" of +! the different aerosol chemical (or tracer) components + integer, save :: mastercompindx_so4_aer = -999888777 + integer, save :: mastercompindx_no3_aer = -999888777 + integer, save :: mastercompindx_cl_aer = -999888777 + integer, save :: mastercompindx_msa_aer = -999888777 + integer, save :: mastercompindx_co3_aer = -999888777 + integer, save :: mastercompindx_nh4_aer = -999888777 + integer, save :: mastercompindx_na_aer = -999888777 + integer, save :: mastercompindx_ca_aer = -999888777 + integer, save :: mastercompindx_oin_aer = -999888777 + integer, save :: mastercompindx_oc_aer = -999888777 + integer, save :: mastercompindx_bc_aer = -999888777 + + + real, save :: & + dens_aer( maxd_acomp, maxd_atype ), & + dens_mastercomp_aer( maxd_acomp ), & + mw_mastercomp_aer( maxd_acomp ), & + mw_aer( maxd_acomp, maxd_atype ), & + hygro_mastercomp_aer( maxd_acomp ), & + hygro_aer( maxd_acomp, maxd_atype ) + +! added by Yang Zhang + real, save :: & + volumcen_sect( maxd_asize, maxd_atype ), & + volumlo_sect( maxd_asize, maxd_atype ), & + volumhi_sect( maxd_asize, maxd_atype ), & + dcen_sect( maxd_asize, maxd_atype ), & + dlo_sect( maxd_asize, maxd_atype ), & + dhi_sect( maxd_asize, maxd_atype ), & + sigmag_aer(maxd_asize, maxd_atype) + + character*10, save :: & + name_mastercomp_aer( maxd_acomp ), & + name_aer( maxd_acomp, maxd_atype ) + + integer, save :: & + lptr_so4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_msa_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_no3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_cl_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_co3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_na_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_ca_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oin_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oc_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bc_aer(maxd_asize, maxd_atype, maxd_aphase) + +! rce 11-sep-2004 - eliminated all of the "..._wrfch" pointers +! so now there is only one set of pointers ("..._amode") +! sg/rce nov-2004 - totally new pointer system - "..._aer" + + +! molecular weights (g/mol) + real, parameter :: mw_so4_aer = 96.066 + real, parameter :: mw_no3_aer = 62.007 + real, parameter :: mw_cl_aer = 35.450 + real, parameter :: mw_msa_aer = 96.109 + real, parameter :: mw_co3_aer = 60.007 + real, parameter :: mw_nh4_aer = 18.042 + real, parameter :: mw_na_aer = 22.990 + real, parameter :: mw_ca_aer = 40.080 + real, parameter :: mw_oin_aer = 1.0 + real, parameter :: mw_oc_aer = 1.0 + real, parameter :: mw_bc_aer = 1.0 + real, parameter :: mw_water_aer = 18.016 + +! dry densities (g/cm3) + real, parameter :: dens_so4_aer = 1.80 + real, parameter :: dens_no3_aer = 1.80 + real, parameter :: dens_cl_aer = 2.20 + real, parameter :: dens_msa_aer = 1.80 + real, parameter :: dens_co3_aer = 2.60 + real, parameter :: dens_nh4_aer = 1.80 + real, parameter :: dens_na_aer = 2.20 + real, parameter :: dens_ca_aer = 2.60 + real, parameter :: dens_oin_aer = 2.60 + real, parameter :: dens_oc_aer = 1.00 + real, parameter :: dens_bc_aer = 1.70 + +! water density (g/cm3) +! real, parameter :: dens_water_asize = 1.0 + real, parameter :: dens_water_aer = 1.0 + +! hygroscopicities (dimensionless) + real, parameter :: hygro_so4_aer = 0.5 + real, parameter :: hygro_no3_aer = 0.5 + real, parameter :: hygro_ca_aer = 0.1 + real, parameter :: hygro_co3_aer = 0.1 + real, parameter :: hygro_nh4_aer = 0.5 + real, parameter :: hygro_msa_aer = 0.58 + real, parameter :: hygro_cl_aer = 1.16 + real, parameter :: hygro_na_aer = 1.16 + real, parameter :: hygro_oin_aer = 0.14 + real, parameter :: hygro_oc_aer = 0.14 + real, parameter :: hygro_bc_aer = 1.e-6 + + + integer, save :: & + msectional, maerosolincw, & + maerocoag, maerchem, maeroptical, maerchem_boxtest_output + + +!----------------------------------------------------------------------- +! the following arrays are used during "column calculations" within +! mosaic modules +! +! aqvoldry_sub(n,k,m) = dry-volume (cm^3-aerosol/mole-air) for mode n, +! layer k, subarea m +! aqmassdry_sub(n,k,m) = dry-mass (g-aerosol/mole-air) for mode n, ... +! adrydens_sub(n,k,m) = dry-density (g-aerosol/cm^3-aerosol) for mode n, ... +! == amassdry_sub/avoldry_sub +! awetdens_sub(n,k,m) = wet-density (g-aerosol/cm^3-aerosol) for mode n, ... +! +! admeandry_sub(n,k,m) = current mean dry-diameter (cm) +! for unactivated aerosol in mode n, layer k, subarea m. +! (Used in sectional code) +! admeanwet_sub(n,k,m) = current mean wet-diameter (cm) +! for unactivated aerosol in mode n, layer k, subarea m. +! (Used in sectional code) +! +! awetdens_sfc(n,i,j) = wet-density for mode n and k=1. This value is +! saved after the second pass thru subr. aerosol_wetsize +! for use in subr. bounds +! admeanwet_sfc(n,i,j) = mean wet-diameter for mode n and k=1. +! This value is saved after the second pass thru +! subr. aerosol_wetsize for use in subr. bounds +! +! +! following are used in aerosol growth routine and are locally +! defined for the current layer (k) and subarea (m) +! drymass_pregrow(n) = dry-mass (g/mole-air) for section n +! before the aerosol growth +! drymass_aftgrow(n) = dry-mass (g/mole-air) for section n +! after the growth but before inter-section transfer +! drydens_pregrow(n) = dry-density (g/cm3) for section n +! before the aerosol growth +! drydens_aftgrow(n) = dry-density (g/cm3) for section n +! after the growth but before inter-section transfer +! +!----------------------------------------------------------------------- + +! integer, parameter :: imaxd_asize = 78 +! integer, parameter :: jmaxd_asize = 28 + integer, parameter :: kmaxd_asize = 100 + integer, parameter :: nsubareamaxd_asize = 5 + +! rce 22-jul-2006 - added maxd_atype dimension to following 6 arrays +! and changed avoldry_sub,amassdry_sub to aqvoldry_sub,aqmassdry_sub + real, save :: aqvoldry_sub( maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + real, save :: aqmassdry_sub(maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + real, save :: adrydens_sub( maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + real, save :: awetdens_sub( maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + real, save :: admeandry_sub(maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + real, save :: admeanwet_sub(maxd_asize,maxd_atype,kmaxd_asize,nsubareamaxd_asize) + +! real, save :: awetdens_sfc(maxd_asize,imaxd_asize,jmaxd_asize) +! real, save :: admeanwet_sfc(maxd_asize,imaxd_asize,jmaxd_asize) + + real, save :: drymass_pregrow(maxd_asize,maxd_atype) + real, save :: drydens_pregrow(maxd_asize,maxd_atype) + real, save :: drymass_aftgrow(maxd_asize,maxd_atype) + real, save :: drydens_aftgrow(maxd_asize,maxd_atype) + +! table lookup of aerosol impaction/interception +! scavenging rates + real dlndg_nimptblgrow + integer nimptblgrow_mind, nimptblgrow_maxd + parameter (nimptblgrow_mind=-7, nimptblgrow_maxd=12) + real scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype), & + scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + + + end module module_data_mosaic_asect diff --git a/wrfv2_fire/chem/module_data_mosaic_other.F b/wrfv2_fire/chem/module_data_mosaic_other.F new file mode 100644 index 00000000..d5110441 --- /dev/null +++ b/wrfv2_fire/chem/module_data_mosaic_other.F @@ -0,0 +1,100 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** +! file module_data_mosaic_other.f +!----------------------------------------------------------------------- + + module module_data_mosaic_other + + +! rce 11-sep-2004 changes +! increased lmaxd,l2maxd +! initialize khno3,...,ktemp,ltot,ltot2 with bogus values; +! added aboxtest_... variables +! no initialization of name() +! rce 06-may-2005 - increased lmaxd from 184 (no cw) to 283 (cw); +! added rcldwtr_sub + + + integer, parameter :: imaxd=1, jmaxd=1, kmaxd=100 + + integer, parameter :: lmaxd=283, l2maxd=283 + + integer, parameter :: nsubareamaxd = 1 + +! rce 2005-mar-09 - added k_pegbegin +! k_pegbegin = starting k index for pegasus arrays + integer, parameter :: k_pegbegin = 1 + + + integer, save :: khno3 = -999888777 + integer, save :: kh2so4 = -999888777 + integer, save :: knh3 = -999888777 + integer, save :: khcl = -999888777 + integer, save :: ko3 = -999888777 + integer, save :: kh2o = -999888777 + integer, save :: ktemp = -999888777 + +! rce 2005-apr-12 - added for cldchem - kso2, kh2o2, khcho, khcooh, +! koh, kho2, kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh + integer, save :: kso2 = -999888777 + integer, save :: kh2o2 = -999888777 + integer, save :: khcho = -999888777 + integer, save :: khcooh = -999888777 + integer, save :: koh = -999888777 + integer, save :: kho2 = -999888777 + integer, save :: kno3 = -999888777 + integer, save :: kno = -999888777 + integer, save :: kno2 = -999888777 + integer, save :: khono = -999888777 + integer, save :: kpan = -999888777 + integer, save :: kch3o2 = -999888777 + integer, save :: kch3oh = -999888777 + integer, save :: kch3ooh = -999888777 + +! the following values are correct for wrfchem simulations + integer, save :: lunerr=-1, lunout=-1 + + integer, save :: ltot=+999888777, ltot2=+999888777 + + integer, save :: itot, jtot, ktot + integer, save :: isvode, jsvode, ksvode, msvode + integer, save :: iymdcur, ihmscur + integer, save :: ncorecnt + integer, save :: nsubareas + + + real, parameter :: pi = 3.14159265 + + real, save :: afracsubarea(kmaxd,nsubareamaxd) + real, save :: cairclm(kmaxd) + real, save :: ptotclm(kmaxd) + real, save :: rclm(kmaxd,l2maxd) + real, save :: relhumclm(kmaxd) + real, save :: rcldwtr_sub(kmaxd,nsubareamaxd) + real, save :: rsub(l2maxd,kmaxd,nsubareamaxd) + real, save :: t + + + character(len=20), save :: name(l2maxd) + + +! control variables for box-model testing +! the following values are correct for wrfchem simulations + integer, save :: aboxtest_testmode = 0 + integer, save :: aboxtest_units_convert = 1 + integer, save :: aboxtest_rh_method = 1 + integer, save :: aboxtest_map_method = 1 + integer, save :: aboxtest_gases_fixed = 0 + + real, save :: aboxtest_min_temp = 233.0 + real, save :: aboxtest_min_relhum = 0.05 + real, save :: aboxtest_max_relhum = 0.98 + + + end module module_data_mosaic_other diff --git a/wrfv2_fire/chem/module_data_mosaic_therm.F b/wrfv2_fire/chem/module_data_mosaic_therm.F new file mode 100644 index 00000000..4e3f1e58 --- /dev/null +++ b/wrfv2_fire/chem/module_data_mosaic_therm.F @@ -0,0 +1,395 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_data_mosaic_therm + + + + implicit none + + + +! mosaic.h (mosaic.21.0) +! 05-feb-07 wig - converted reals to double +! 10-jan-07 raz - compatible with mosaic.21.0 +! 19-dec-05 raz - compatible with mosaic.16.4 +! 27-apr-05 raz - compatible with mosaic.14.3 +! 07-jan-05 raz - updated and cleaned up variable lists +! 08-jul-03 raz - updated many variables +! 07-aug-02 rce - this is rahul's latest version from freshair +! 19-aug-02 raz - declared mass_soluble_a and kg as real +! 07-oct-02 raz - declared zc and za as integer +! 09-oct-02 raz - explicitly declared all variables +! 29-oct-02 raz - defined naercomp as the total number of aerosol compounds +!---------------------------------------------------------------------- + +! nbin_a_maxd = maximum num of aerosol bins and is used to dimension arrays + integer, parameter :: nbin_a_maxd = 8 +! nbin_a = number of bins that are used in a run +! (nbin_a is set at run time, and must be <= nbin_a_maxd) + integer, save :: nbin_a = 999888777 + +! mosaic-specific parameters + integer ngas_ioa, ngas_soa, ngas_volatile, & + naer, naercomp, nelectrolyte, nsalt, & + nsoluble, ncation, nanion + parameter(ngas_ioa = 5) ! inorganic volatile aerosol species that have a gaseous counterpart + parameter(ngas_soa = 8) ! volatile soa species that have a gaseous counterpart + parameter(ngas_volatile = ngas_ioa + ngas_soa) + parameter(naer = 19) ! num of chemical species per bin (inorg + oc + bc + oin + soa) + parameter(naercomp = 34) ! num of electrolytes + oc, bc, oin, & soa + parameter(nelectrolyte = 22) ! num of electrolytes + parameter(nsalt = 15) ! num of soluble salts + parameter(nsoluble = 20) ! num of soluble electrolytes + parameter(ncation = 4) ! num of cations + parameter(nanion = 5) ! num of anions + + integer nrxn_aer_gl, nrxn_aer_ll, nrxn_aer_sg, nrxn_aer_sl + parameter(nrxn_aer_gl = 4) ! num of gas-liquid equilibria + parameter(nrxn_aer_ll = 3) ! num of liquid-liquid equilibria + parameter(nrxn_aer_sg = 2) ! num of solid-gas equilibria + parameter(nrxn_aer_sl = nsalt)! num of solid-liquid equilibria + + integer mmodal, msection, & + mon, moff, myes, mno + parameter(mmodal = 1) ! modal size distribution framework + parameter(msection= 2) ! sectional size distribution framework + parameter(mon = 1) ! flag: on + parameter(moff = 0) ! flag:off + parameter(myes = mon) ! flag: yes or true + parameter(mno = moff) ! flag: no or false + + + integer jtotal, jsolid, jliquid + parameter(jsolid = 1) + parameter(jliquid= 2) + parameter(jtotal = 3) + + integer jhyst_lo, jhyst_up + parameter(jhyst_lo = 0) ! lower hysteresis leg + parameter(jhyst_up = 1) ! upper hysteresis leg + + integer no_aerosol, all_solid, all_liquid, mixed + parameter(no_aerosol = 0) ! flag + parameter(all_solid = 1) ! flag + parameter(all_liquid = 2) ! flag + parameter(mixed = 3) ! flag + + integer soluble, insoluble + parameter(soluble = 1) ! flag + parameter(insoluble = 2) ! flag + + real(kind=8) mass_cutoff + parameter(mass_cutoff = 1.d-15) ! ng/m^3 + + +!---------------------------------------------------------------------- +! mosaic species indices +! +! gas + integer, save :: & + ih2so4_g, ihno3_g, ihcl_g, inh3_g, & + imsa_g, & + iaro1_g, iaro2_g, ialk1_g, iole1_g, & + iapi1_g, iapi2_g, ilim1_g, ilim2_g + +! aerosol generic + integer, save :: & + iso4_a, ino3_a, icl_a, inh4_a, ico3_a, & + imsa_a, ina_a, ica_a, ioc_a, ibc_a, & + ioin_a, iaro1_a, iaro2_a, ialk1_a, iole1_a, & + iapi1_a, iapi2_a, ilim1_a, ilim2_a + +! aerosol elecctrolytes/compounds + integer, save :: & + jnh4so4, jlvcite, jnh4hso4, jnh4no3, jnh4cl, & + jna2so4, jna3hso4, jnahso4, jnano3, jnacl, & + jcaso4, jcano3, jcacl2, jcaco3, jh2so4, & + jhno3, jhcl, jhhso4, & + jnh4msa, jnamsa, jcamsa2, jmsa, & + joc, jbc, join, jaro1, jaro2, & + jalk1, jole1, japi1, japi2, jlim1, & + jlim2, jh2o + +! aerosol ions + integer, save :: & + jc_h, jc_nh4, jc_na, jc_ca, & + ja_hso4, ja_so4, ja_no3, ja_cl, ja_msa ! , ja_co3 + + +!---------------------------------------------------------------------- +! mosaic variables + integer, save :: & + iclm_aer, & ! i-location + jclm_aer, & ! j-location + kclm_aer, & ! k-location + kclm_aer_calcbgn, & ! k-loc for calc. to begin + kclm_aer_calcend, & ! k-loc for calc. to end + mclm_aer, & ! m-subarea + mgas_aer_xfer, & ! flag: mon, moff + mdynamic_solver, & ! flag: masteem, masceem + msize_framework, & ! flag: mmodal, msectional + jaerosolstate(nbin_a_maxd), & ! flag: no_aerosol, all_solid, all_liquid, mixed + jphase(nbin_a_maxd), & ! phase index: jtotal, jsolid, jliquid + jhyst_leg(nbin_a_maxd), & ! hysteresis leg: jhyst_up, jhyst_lo + iprint_input, & ! flag: mon, moff + lunerr_aer, & ! + ncorecnt_aer ! + +! NOTE: Some of the following informational output defaults are overridden in +! module_mosaic_driver.F based on the internal MOSAIC debug_level setting. + integer, save :: istat_mosaic_fe1 + ! "fatal error status" for current problem (grid cell) + ! negative value means a fatal error has occured + integer, save :: nfe1_mosaic_cur = 0 + ! fatal error count for current host-code time step + integer, save :: nfe1_mosaic_tot = 0 + ! fatal error count for all time steps + integer, save :: iprint_mosaic_fe1 = 1 + ! turns on/off output of fatal error diagnostics & counts + ! if iprint_mosaic_fe1 >= 10, mosaic_aerchem_error_dump + ! is called for each fatal error + integer, save :: iprint_mosaic_perform_stats = 1 + ! turns on/off output of mosaic performance statistics + integer, save :: iprint_mosaic_diag1 = 1 + ! turns on/off output of other warnings & diagnostics + integer, save :: iprint_mosaic_input_ok = 1 + ! turns on/off output of mosaic initial values + ! when a serious error occurs + + + real(kind=8), save :: & + num_a(nbin_a_maxd), & ! #/cc(air) + dpgn_a(nbin_a_maxd), & ! cm + dp_dry_a(nbin_a_maxd), & ! cm + dp_wet_a(nbin_a_maxd), & ! cm + area_dry_a(nbin_a_maxd), & ! cm^2/cc(air) + area_wet_a(nbin_a_maxd), & ! cm^2/cc(air) + mass_dry_salt(nbin_a_maxd), & ! g/cc(air) + mass_dry_a(nbin_a_maxd), & ! g/cc(air) + mass_wet_a(nbin_a_maxd), & ! g/cc(air) + mass_soluble_a(nbin_a_maxd), & ! ng/cc(air) + vol_dry_a(nbin_a_maxd), & ! cc/cc(air) + vol_wet_a(nbin_a_maxd), & ! cc/cc(air) + dens_dry_a(nbin_a_maxd), & ! g/cc + dens_wet_a(nbin_a_maxd), & ! g/cc + sigmag_a(nbin_a_maxd), & ! - + water_a(nbin_a_maxd), & ! kg(water)/m^3(air) + water_a_hyst(nbin_a_maxd), & ! kg(water)/m^3(air) hysteresis (at 60% rh) + water_a_up(nbin_a_maxd), & ! kg(water)/m^3(air) at 60% rh + ph(nbin_a_maxd), & ! ph + aer(naer,3,nbin_a_maxd), & ! nmol/m^3 + aer_sum(3,nbin_a_maxd), & ! nmol/m^3 + aer_percent(naer,3,nbin_a_maxd), & ! % + comp_a(naercomp), & ! g/cc(air) + electrolyte(nelectrolyte,3,nbin_a_maxd), & ! nmol/m^3 + electrolyte_sum(nelectrolyte,nbin_a_maxd), & ! nmol/m^3 + epercent(nelectrolyte,3,nbin_a_maxd), & ! % + gas(ngas_volatile), & ! nmol/m^3 + ah2o, & ! - + ah2o_a(nbin_a_maxd), & ! - + dpmv(nbin_a_maxd), & ! + volume_a(nbin_a_maxd), & ! + volume_bin(nbin_a_maxd), & ! dry volume of one particle + kelvin(nbin_a_maxd), & ! kelvin factor + kel(ngas_volatile,nbin_a_maxd), & ! kelvin factor for condensing species + kelvin_nh4no3, & ! - + kelvin_nh4cl, & ! - + total_species(ngas_volatile) ! + + +!---------------------------------------------------------------------- +! astem variables + integer, save :: & + idry_case3a(nbin_a_maxd), & ! mYES, mNO + ieqblm_bin(nbin_a_maxd), & ! myes, mno + ieqblm_astem, & ! myes, mno + nastem_call, & ! + nastem_fail, & ! + isteps_astem, & ! + nsteps_astem, & ! + nsteps_astem_max, & ! + nmax_ASTEM, & ! + integrate(ngas_volatile,3,nbin_a_maxd) ! mYES, mNO + + + real(kind=8), save :: & + po_soa(ngas_volatile), & ! pascal + sat_soa(ngas_volatile), & ! nmol/m^3(air) + x_soa(naer), & ! soa mole fraction + sfc_a(ngas_volatile), & ! nmol/m^3 + Heff(ngas_volatile,nbin_a_maxd), & ! + kg(ngas_volatile,nbin_a_maxd), & ! 1/s + df_gas_s(ngas_volatile,nbin_a_maxd), & ! nmol/m^3 (g-g*) = driving force) + df_gas_l(ngas_volatile,nbin_a_maxd), & ! nmol/m^3 (g-g*) = driving force) + flux_s(ngas_volatile,nbin_a_maxd), & ! nmol/m^3/s + flux_l(ngas_volatile,nbin_a_maxd), & ! nmol/m^3/s + sumkg_h2so4, & ! 1/s + sumkg_msa, & ! 1/s + sumkg_nh3, & ! 1/s + sumkg_hno3, & ! 1/s + sumkg_hcl, & ! 1/s + delta_nh3_max(nbin_a_maxd), & ! nmol/m^3 + delta_hno3_max(nbin_a_maxd), & ! nmol/m^3 + delta_hcl_max(nbin_a_maxd), & ! nmol/m^3 + keq_nh4no3, & ! - + keq_nh4cl, & ! - + volatile_s(ngas_volatile,nbin_a_maxd), & ! nmol/m^3 + phi_volatile_s(ngas_volatile,nbin_a_maxd), & ! relative dr. force = (g-g*)/g + phi_volatile_l(ngas_volatile,nbin_a_maxd), & ! relative dr. force = (g-g*)/g + phi_nh4no3_s, & ! relative dr. force: 0 to 1 + phi_nh4cl_s, & ! relative dr. force: 0 to 1 + sum_vdf_s(ngas_volatile), & ! (nmol/m^3)^2 + sum_vol_s(ngas_volatile), & ! nmol/m^3 + sum_bin_s(ngas_volatile), & ! number of bins that have flux_s(iv) < 0 + avg_df_gas_s(ngas_volatile), & ! nmol/m^3 + h_s_i_m(ngas_volatile,nbin_a_maxd), & ! s + alpha_gas(ngas_volatile), & ! - adaptive + alpha_astem, & ! 0.01 to 0.05 + rtol_eqb_astem, & ! 0.01 to 0.03 + ptol_mol_astem, & ! 0.01 to 1.0 + nsteps_astem_avg ! + +!---------------------------------------------------------------------- +! mesa variables + integer, save :: & + jsalt_index(nsalt), & + jsulf_poor(211), & + jsulf_rich(71), & + jsalt_present(nsalt), & + nmax_mesa, & + nmesa_call, & + nmesa_fail, & + iter_mesa(nbin_a_maxd), & + niter_mesa, & + niter_mesa_max + + + real(kind=8), save :: & + eleliquid(nelectrolyte), & + flux_sl(nsalt), & + phi_salt(nsalt), & + phi_salt_old(nsalt), & + phi_bar(nsalt), & + alpha_salt(nsalt), & + sat_ratio(nsalt), & + hsalt(nsalt), & + hsalt_max, & + frac_salt_liq(nsalt), & + frac_salt_solid(nsalt), & + growth_factor(nbin_a_maxd), & + d_mdrh(63,4), & ! mdrh(t) poly coeffs + mdrh(nbin_a_maxd), & + mdrh_t(63), & + molality0(nelectrolyte), & + rtol_mesa, & + niter_mesa_avg + + +!---------------------------------------------------------------------- +! mosaic physico-chemical constants + character(len=8), save :: & + ename(nelectrolyte), & ! electrolyte names + aer_name(naer), & ! generic aerosol species name + gas_name(ngas_volatile) ! gas species name + + character(len=6), save :: & + phasestate(4) + + + real(kind=8), save :: & + t_k, & ! temperature (k) + p_atm, & ! pressure (atm) + rh_pc, & ! relative humidity (%) + cair_mol_cc, & ! air conc in mol/cc + cair_mol_m3, & ! air conc in mol/m^3 + conv1a, & + conv1b, & + conv2a, & + conv2b, & + mw_electrolyte(nelectrolyte), & ! molecular wt of electrolytes + mw_aer_mac(naer), & ! molecular wt of generic species + mw_comp_a(naercomp), & ! molecular wt of compounds + mw_c(ncation), & ! molecular wt of cations + mw_a(nanion), & ! molecular wt of anions + dens_electrolyte(nelectrolyte), & ! g/cc + dens_aer_mac(naer), & ! g/cc + dens_comp_a(naercomp), & ! g/cc (density of compounds) + partial_molar_vol(ngas_volatile), & ! cc/mol + sigma_water, & ! water surface tension (n/m) + sigma_soln(nbin_a_maxd), & ! solution surface tension (n/m) + keq_gl(nrxn_aer_gl), & ! gas-liq eqblm const + keq_ll(nrxn_aer_ll), & ! liq-liq eqblm const + keq_sg(nrxn_aer_sg), & ! solid-gas eqbln const + keq_sl(nrxn_aer_sl), & ! solid-liq eqblm const + kp_nh3, & ! + kp_nh4no3, & ! + kp_nh4cl ! + + + complex, save :: & + ref_index_a(naercomp), & ! refractive index of compounds + ri_avg_a(nbin_a_maxd) ! vol avg ref index of bin + + +!---------------------------------------------------------------------- +! mosaic activity coefficient models parameters + + real(kind=8), save :: & + mc(ncation,nbin_a_maxd), & ! mol/kg(water) + ma(nanion,nbin_a_maxd), & ! mol/kg(water) + msulf, & ! + zc(ncation), & ! real charge + za(nanion), & ! real charge + gam(nelectrolyte,nbin_a_maxd), & + gam_ratio(nbin_a_maxd), & + log_gamz(nelectrolyte,nelectrolyte), & + log_gam(nelectrolyte), & + activity(nelectrolyte,nbin_a_maxd), & + xeq_a(nanion), & + xeq_c(ncation), & + na_ma(nanion), & + nc_mc(ncation), & + a_zsr(6,nelectrolyte), & ! binary molality polynomial coeffs + b_zsr(nelectrolyte), & ! binary molality coeff + aw_min(nelectrolyte), & ! minimum frh at which molality polynomial can be used + b_mtem(6,nelectrolyte,nelectrolyte) ! mtem poly coeffs + + +!---------------------------------------------------------------------- +! mosaic massbalance variables + real(kind=8), save :: & + tot_so4_in, & + tot_no3_in, & + tot_cl_in, & + tot_nh4_in, & + tot_na_in, & + tot_ca_in, & + tot_so4_out, & + tot_no3_out, & + tot_cl_out, & + tot_nh4_out, & + tot_na_out, & + tot_ca_out, & + diff_so4, & + diff_no3, & + diff_cl, & + diff_nh4, & + diff_na, & + diff_ca, & + reldiff_so4, & + reldiff_no3, & + reldiff_cl, & + reldiff_nh4, & + reldiff_na, & + reldiff_ca +!---------------------------------------------------------------------- + + + + end module module_data_mosaic_therm diff --git a/wrfv2_fire/chem/module_data_racm.F b/wrfv2_fire/chem/module_data_racm.F new file mode 100644 index 00000000..ababa0f5 --- /dev/null +++ b/wrfv2_fire/chem/module_data_racm.F @@ -0,0 +1,862 @@ + MODULE module_data_racm + +! **************************************************************** + +! Global Header File + +! Generated by KPP - symbolic chemistry Kinetics PreProcessor +! KPP is developed at CGRER labs University of Iowa by +! Valeriu Damian & Adrian Sandu + +! File : racm_kpp_seulex.h +! Time : Thu Apr 15 16:55:52 2004 + +! **************************************************************** + + IMPLICIT NONE + + REAL epsilc_racm + PARAMETER (epsilc_racm=1.E-12) +! NPHOT - The number of photolytic reactions + INTEGER nphot + PARAMETER (nphot=23) + +! NSPEC - The number of species involved + INTEGER nspec + + PARAMETER (nspec=77) +! NVAR - The number of Variable species + INTEGER nvar + PARAMETER (nvar=73) +! NVARACT - The number of Active species + INTEGER nvaract + PARAMETER (nvaract=69) +! NRAD - The number of Radical species + INTEGER nrad + PARAMETER (nrad=1) +! NFIX - The number of Fixed species + INTEGER nfix + PARAMETER (nfix=4) +! NREACT - The number of reactions + + INTEGER nreact + PARAMETER (nreact=237) +! NVARST - Starting of variables in conc. vect. + INTEGER nvarst + PARAMETER (nvarst=0) +! NRADST - Starting of radicals in conc. vect. + INTEGER nradst + + PARAMETER (nradst=73) +! NFIXST - Starting of fixed in conc. vect. + INTEGER nfixst + PARAMETER (nfixst=73) +! NONZERO_V - Number of nonzero variable elements + INTEGER nonzero_v + PARAMETER (nonzero_v=925) +! LU_NONZERO_V - Number of nonzero variable LU elements + INTEGER lu_nonzero_v + PARAMETER (lu_nonzero_v=1051) +! NONZERO_R - Number of nonzero radical elements + + INTEGER nonzero_r + PARAMETER (nonzero_r=0) +! CNVAR - (NVAR+1) The number of elements in compressed row format + INTEGER cnvar + PARAMETER (cnvar=nvar+1) +! CNRAD - (NRAD+1) The number of elements in compressed row format + INTEGER cnrad + PARAMETER (cnrad=nrad+1) +! NLOOKAT - number of species to look at + INTEGER nlookat + PARAMETER (nlookat=77) +! NMASS - number of atoms to check mass balance + INTEGER nmass + PARAMETER (nmass=0) +! NX - X grid dimension + INTEGER nx + PARAMETER (nx=0) +! NY - Y grid dimension + INTEGER ny + + PARAMETER (ny=0) +! NZ - Z grid dimension + INTEGER nz + PARAMETER (nz=0) +! MAX_XYZ - maximum grid dimension + INTEGER max_xyz + PARAMETER (max_xyz=0) +! NS - number of species to transport + INTEGER ns + PARAMETER (ns=0) +! PI - Value of pi + REAL*8 pi + PARAMETER (pi=3.14159265358979) + +! Declaration for global variables + + + +! VAR - Concentrations of variable species (global) + REAL*8 var(nvar) +! RAD - Concentrations of radical species (global) + REAL*8 rad(nrad) +! FIX - Concentrations of fixed species (global) + REAL*8 fix(nfix) +!RS EQUIVALENCE (c(1+nvarst),var(1)) +!RS EQUIVALENCE (c(1+nradst),rad(1)) +!RS EQUIVALENCE (c(1+nfixst),fix(1)) + +!RS commonBs which have to be checked for WRF + +!RS To be eliminated later +!RS +! TIME - current integration time +!RS REAL*8 time +!RS COMMON /gdata/time +! SUN - light intensity +!RS REAL*8 sun +!RS COMMON /gdata/sun +! C_DEFAULT - Default concentration for all species +!RS REAL*8 c_default(nspec) +!RS COMMON /gdata/c_default +! C - Concentration for all species +!RS REAL*8 c(nspec) +!RS COMMON /gdata/c +! TSTART - integration start time +!RS REAL*8 tstart +!RS COMMON /gdata/tstart +! TEND - integration end time +!RS REAL*8 tend +!RS +!RS COMMON /gdata/tend +! SMASS - names of atoms for mass balance +!RS CHARACTER*12 smass(1) +!RS COMMON /chargdata/smass +! TEMP - temperature +! REAL*8 temp +!RS COMMON /gdata/temp +! PRES -pressure + REAL*8 pres +!RS COMMON /gdata/pres +! DT - integration step + +!RS REAL*8 dt +!RS COMMON /gdata/dt +! LOOKAT - indexes of species to look at +!RS INTEGER lookat(77) +!RS COMMON /intgdata/lookat + +! SLOOKAT - names of species to look at +!RS CHARACTER*12 slookat(77) +!RS COMMON /chargdata/slookat +! NMONITOR - number of species to monitor +!RS INTEGER nmonitor +!RS PARAMETER (nmonitor=3) +! MONITOR - indexes of species to monitor +!RS INTEGER monitor(3) +!RS COMMON /intgdata/monitor +! SMONITOR - names of species to monitor + +!RS CHARACTER*12 smonitor(3) +!RS COMMON /chargdata/smonitor + + + + +!RS COMMON blocks which ARE WRF compatible +! RTOLS - (scalar) relative tolerance +!RS REAL*8 rtols +!RS COMMON /gdata/rtols +! ATOL - Absolute tolerance +!RS REAL*8 atol(nspec) +!RS COMMON /gdata/atol +! RTOL - Relative tolerance +!RS REAL*8 rtol(nspec) +!RS COMMON /gdata/rtol +! STEPMIN - minimum allowed intergation step + REAL*8 stepmin +!RS COMMON /gdata/stepmin +! STEPMAX - maximum allowed integration step + REAL*8 stepmax +!RS COMMON /gdata/stepmax +! CFACTOR - Conversion factor + REAL*8 cfactor +!RS COMMON /gdata/cfactor +! TRANS - indexes of species to transport +!RS INTEGER trans(1) +!RS COMMON /intgdata/trans +! STRANS - names of species to transport +!RS CHARACTER*12 strans(1) +!RS COMMON /chargdata/strans +! SEQN - equation names + CHARACTER*55 seqn(237) +!RS COMMON /chargdata/seqn + INTEGER isnotautonom + + +!RS END +! Indeces declaration for variable species + + INTEGER i_sulf + PARAMETER (i_sulf=1) + INTEGER i_co2 + PARAMETER (i_co2=2) + INTEGER i_ora1 + PARAMETER (i_ora1=3) + INTEGER i_ora2 + PARAMETER (i_ora2=4) + INTEGER i_so2 + PARAMETER (i_so2=5) + INTEGER i_o1d + PARAMETER (i_o1d=6) + INTEGER i_hc5 + PARAMETER (i_hc5=7) + INTEGER i_tol + PARAMETER (i_tol=8) + INTEGER i_xyl + PARAMETER (i_xyl=9) + INTEGER i_n2o5 + PARAMETER (i_n2o5=10) + INTEGER i_hc8 + PARAMETER (i_hc8=11) + INTEGER i_hc3 + PARAMETER (i_hc3=12) + INTEGER i_eth + PARAMETER (i_eth=13) + INTEGER i_ch4 + PARAMETER (i_ch4=14) + INTEGER i_udd + PARAMETER (i_udd=15) + INTEGER i_hno4 + PARAMETER (i_hno4=16) + INTEGER i_op1 + PARAMETER (i_op1=17) + INTEGER i_hono + PARAMETER (i_hono=18) + INTEGER i_h2o2 + PARAMETER (i_h2o2=19) + INTEGER i_pho + PARAMETER (i_pho=20) + INTEGER i_addt + PARAMETER (i_addt=21) + INTEGER i_addx + PARAMETER (i_addx=22) + INTEGER i_hket + PARAMETER (i_hket=23) + INTEGER i_ete + PARAMETER (i_ete=24) + INTEGER i_addc + PARAMETER (i_addc=25) + INTEGER i_paa + PARAMETER (i_paa=26) + INTEGER i_hno3 + PARAMETER (i_hno3=27) + INTEGER i_co + PARAMETER (i_co=28) + INTEGER i_api + PARAMETER (i_api=29) + INTEGER i_lim + PARAMETER (i_lim=30) + INTEGER i_pan + PARAMETER (i_pan=31) + INTEGER i_csl + PARAMETER (i_csl=32) + INTEGER i_dien + PARAMETER (i_dien=33) + INTEGER i_gly + PARAMETER (i_gly=34) + INTEGER i_tpan + PARAMETER (i_tpan=35) + INTEGER i_etep + PARAMETER (i_etep=36) + + INTEGER i_iso + PARAMETER (i_iso=37) + INTEGER i_oltp + PARAMETER (i_oltp=38) + INTEGER i_olip + PARAMETER (i_olip=39) + INTEGER i_mgly + PARAMETER (i_mgly=40) + INTEGER i_cslp + PARAMETER (i_cslp=41) + INTEGER i_ket + PARAMETER (i_ket=42) + INTEGER i_limp + PARAMETER (i_limp=43) + INTEGER i_hc5p + PARAMETER (i_hc5p=44) + INTEGER i_hc8p + PARAMETER (i_hc8p=45) + INTEGER i_tolp + PARAMETER (i_tolp=46) + INTEGER i_xylp + PARAMETER (i_xylp=47) + INTEGER i_hcho + PARAMETER (i_hcho=48) + INTEGER i_apip + PARAMETER (i_apip=49) + INTEGER i_isop + PARAMETER (i_isop=50) + INTEGER i_macr + PARAMETER (i_macr=51) + INTEGER i_hc3p + PARAMETER (i_hc3p=52) + INTEGER i_ald + PARAMETER (i_ald=53) + INTEGER i_dcb + PARAMETER (i_dcb=54) + INTEGER i_tco3 + PARAMETER (i_tco3=55) + INTEGER i_xo2 + PARAMETER (i_xo2=56) + INTEGER i_olt + PARAMETER (i_olt=57) + INTEGER i_oli + PARAMETER (i_oli=58) + INTEGER i_olnn + PARAMETER (i_olnn=59) + INTEGER i_olnd + PARAMETER (i_olnd=60) + INTEGER i_ethp + PARAMETER (i_ethp=61) + INTEGER i_o3p + PARAMETER (i_o3p=62) + INTEGER i_o3 + PARAMETER (i_o3=63) + INTEGER i_ketp + PARAMETER (i_ketp=64) + INTEGER i_mo2 + PARAMETER (i_mo2=65) + INTEGER i_aco3 + PARAMETER (i_aco3=66) + INTEGER i_ho + PARAMETER (i_ho=67) + INTEGER i_onit + PARAMETER (i_onit=68) + INTEGER i_ho2 + + PARAMETER (i_ho2=69) + INTEGER i_no3 + PARAMETER (i_no3=70) + INTEGER i_op2 + PARAMETER (i_op2=71) + INTEGER i_no + PARAMETER (i_no=72) + INTEGER i_no2 + PARAMETER (i_no2=73) + +! Indexes declaration for radical species + INTEGER ir_addt + PARAMETER (ir_addt=1) + INTEGER ir_addx + PARAMETER (ir_addx=2) + INTEGER ir_addc + PARAMETER (ir_addc=3) + INTEGER ir_etep + PARAMETER (ir_etep=4) + INTEGER ir_oltp + PARAMETER (ir_oltp=5) + INTEGER ir_olip + PARAMETER (ir_olip=6) + INTEGER ir_cslp + PARAMETER (ir_cslp=7) + INTEGER ir_limp + PARAMETER (ir_limp=8) + INTEGER ir_hc5p + PARAMETER (ir_hc5p=9) + INTEGER ir_hc8p + PARAMETER (ir_hc8p=10) + INTEGER ir_tolp + PARAMETER (ir_tolp=11) + INTEGER ir_xylp + PARAMETER (ir_xylp=12) + INTEGER ir_apip + PARAMETER (ir_apip=13) + INTEGER ir_isop + PARAMETER (ir_isop=14) + INTEGER ir_hc3p + + PARAMETER (ir_hc3p=15) + INTEGER ir_ethp + PARAMETER (ir_ethp=16) + INTEGER ir_o3p + PARAMETER (ir_o3p=17) + INTEGER ir_tco3 + PARAMETER (ir_tco3=18) + INTEGER ir_mo2 + + PARAMETER (ir_mo2=19) + INTEGER ir_o1d + PARAMETER (ir_o1d=20) + INTEGER ir_olnn + PARAMETER (ir_olnn=21) + INTEGER ir_olnd + PARAMETER (ir_olnd=22) + INTEGER ir_rpho + PARAMETER (ir_rpho=23) + INTEGER ir_xo2 + PARAMETER (ir_xo2=24) + INTEGER ir_ketp + PARAMETER (ir_ketp=25) + +! Indexes declaration for fixed species + + INTEGER i_h2o + PARAMETER (i_h2o=1) + INTEGER i_n2 + PARAMETER (i_n2=2) + INTEGER i_o2 + PARAMETER (i_o2=3) + INTEGER i_h2 + PARAMETER (i_h2=4) + +! User defined variables + + + REAL*8 stepstart +!RS COMMON /gdata/stepstart + +! End user defined variables + +! **************************************************************** + +! Sparse Data Header File + +! Generated by KPP - symbolic chemistry Kinetics PreProcessor +! KPP is developed at CGRER labs University of Iowa by +! Valeriu Damian & Adrian Sandu + + +! File : racm_kpp_seulex_s.h +! Time : Thu Apr 15 16:55:52 2004 +! Working directory : /home/haas/Chemie/kpp_1.2/kpp-1.2/examples/racm +! Equation file : racm_kpp_seulex.k +! Output root filename : racm_kpp_seulex + +! **************************************************************** + + + +! Sparse data + +!RS! IROW_V - row indexes for the Jacobian of variables +!RS INTEGER irow_v(nonzero_v) +!RS COMMON /sdata/irow_v +!RS! ICOL_V - column indexes for the Jacobian of variables +!RS INTEGER icol_v(nonzero_v) +!RS COMMON /sdata/icol_v +!RS! CROW_V - compressed row indexes for the Jacobian of variables +!RS INTEGER crow_v(cnvar) +!RS COMMON /sdata/crow_v +!RS! DIAG_V - diagonal indexes for the Jacobian of variables +!RS INTEGER diag_v(cnvar) +!RS COMMON /sdata/diag_v +!RS! LU_IROW_V - row indexes for the LU Jacobian of variables +!RS INTEGER lu_irow_v(lu_nonzero_v) +!RS COMMON /sdata/lu_irow_v +!RS! LU_ICOL_V - column indexes for the LU Jacobian of variables + INTEGER lu_icol_v(1051) +!RS +!RS COMMON /sdata/lu_icol_v +!RS! LU_CROW_V - compressed row indexes for the LU Jacobian of variables + INTEGER lu_crow_v(74) +!RS COMMON /sdata/lu_crow_v +!RS! LU_DIAG_V - diagonal indexes for the LU Jacobian of variables + INTEGER lu_diag_v(74) +!RS COMMON /sdata/lu_diag_v +!RS! IROW_R - row indexes for the Jacobian of radicals + INTEGER irow_r(nonzero_r+1) +!RS COMMON /sdata/irow_r +!RS! ICOL_R - column indexes for the Jacobian of radicals + INTEGER icol_r(nonzero_r+1) +!RS COMMON /sdata/icol_r +!RS! CROW_R - compressed row indexes for the Jacobian of radicals + INTEGER crow_r(cnrad) +!RS COMMON /sdata/crow_r +!RS! DIAG_R - diagonal indexes for the Jacobian of radicals + INTEGER diag_r(cnrad) +!RS COMMON /sdata/diag_r + + + INTEGER i + + DATA cfactor/1/ + + +!RS DATA lookat/1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, & +!RS 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, & +!RS 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, & +!RS 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, & +!RS 69, 70, 71, 72, 73, 74, 75, 76, 77/ +!RS +!RS +!RS DATA slookat/'SULF', 'CO2', 'ORA1', 'ORA2', 'SO2', 'O1D', 'HC5', 'TOL', & +!RS 'XYL', 'N2O5', 'HC8', 'HC3', 'ETH', 'CH4', 'UDD', 'HNO4', 'OP1', & +!RS 'HONO', 'H2O2', 'PHO', 'ADDT', 'ADDX', 'HKET', 'ETE', 'ADDC', 'PAA', & +!RS 'HNO3', 'CO', 'API', 'LIM', 'PAN', 'CSL', 'DIEN', 'GLY', 'TPAN', & +!RS 'ETEP', 'ISO', 'OLTP', 'OLIP', 'MGLY', 'CSLP', 'KET', 'LIMP', 'HC5P', & +!RS 'HC8P', 'TOLP', 'XYLP', 'HCHO', 'APIP', 'ISOP', 'MACR', 'HC3P', 'ALD', & +!RS 'DCB', 'TCO3', 'XO2', 'OLT', 'OLI', 'OLNN', 'OLND', 'ETHP', 'O3P', & +!RS 'O3', 'KETP', 'MO2', 'ACO3', 'HO', 'ONIT', 'HO2', 'NO3', 'OP2', 'NO', & +!RS 'NO2', 'H2O', 'N2', 'O2', 'H2'/ + + +!RS DATA monitor/63, 72, 73/ + + +!RS DATA smonitor/'O3', 'NO', 'NO2'/ + + + + + + DATA (seqn(i),i=1,24)/' NO2 --> O3P + NO ' & + , ' O3 --> O1D + O2 ', & + ' O3 --> O3P + O2 ', & + ' HONO --> HO + NO ', & + ' HNO3 --> HO + NO2 ', & + ' HNO4 --> 0HO + 1HO2 + 0NO3 + 1NO2', & + ' NO3 --> NO + O2 ', & + ' NO3 --> O3P + NO2 ', & + ' H2O2 --> 2HO ', & + ' HCHO --> CO + H2 ', & + ' HCHO --> CO + 2HO2 ', & + ' ALD --> CO + MO2 + HO2', & + ' OP1 --> HCHO + HO + HO2', & + ' OP2 --> ALD + HO + HO2', & + ' PAA --> MO2 + HO ', & + ' KET --> ETHP + ACO3', & + ' GLY --> 2CO + 0HCHO + 1H2', & + ' GLY --> 2CO + 0HCHO + 1HO2 + 0H2', & + ' MGLY --> CO + ACO3 + HO2', & + ' DCB --> TCO3 + HO2 ', & + ' ONIT --> 1KET + 0ALD + HO2 + NO2', & + ' MACR --> CO + HCHO + ACO3 + HO2', & + ' HKET --> HCHO + ACO3 + HO2', & + ' O3P + O2 --> O3 '/ + + DATA (seqn(i),i=25,48)/ & + ' O3P + O3 --> 2O2 ', & + ' O1D + N2 --> O3P + N2 ', & + ' O1D + O2 --> O3P + O2 ', & + ' O1D + H2O --> 2HO ', & + ' O3 + HO --> HO2 + O2 ', & + ' O3 + HO2 --> HO + 2O2 ', & + ' HO + HO2 --> H2O + O2 ', & + ' H2O2 + HO --> HO2 + H2O ', & + ' 2HO2 --> H2O2 + O2 ', & + ' 2HO2 + H2O --> H2O2 + H2O + O2', & + ' O3P + NO --> NO2 ', & + ' O3P + NO2 --> NO + O2 ', & + ' O3P + NO2 --> NO3 ', & + ' HO + NO --> HONO ', & + ' HO + NO2 --> HNO3 ', & + ' HO + NO3 --> HO2 + NO2 ', & + ' HO2 + NO --> HO + NO2 ', & + ' HO2 + NO2 --> HNO4 ', & + ' HNO4 --> HO2 + NO2 ', & + ' HO2 + NO3 --> 0HNO3 + 1HO + 1NO2 + O2', & + ' HONO + HO --> NO2 + H2O ', & + ' HNO3 + HO --> NO3 + H2O ', & + ' HNO4 + HO --> NO2 + H2O + O2', & + ' O3 + NO --> NO2 + O2 '/ + + DATA (seqn(i),i=49,72)/ & + ' O3 + NO2 --> NO3 + O2 ', & + ' 2NO + O2 --> 2NO2 ', & + ' NO3 + NO --> 2NO2 ', & + ' NO3 + NO2 --> NO + NO2 + O2', & + ' NO3 + NO2 --> N2O5 ', & + ' N2O5 --> NO3 + NO2 ', & + ' 2NO3 --> 2NO2 + O2 ', & + ' HO + H2 --> HO2 + H2O ', & + ' SO2 + HO --> SULF + HO2 ', & + ' CO + HO --> CO2 + HO2 ', & + ' ISO + O3P --> 0CO + 0HCHO + 0DCB + 0XO2 + 1OLT + 0HO', & + ' MACR + O3P --> ALD ', & + ' CH4 + HO --> MO2 + H2O ', & + ' ETH + HO --> ETHP + H2O ', & + ' HC3 + HO --> 0ORA1 + 0CO + 0GLY + 0HCHO + 1HC3P + 0', & + ' HC5 + HO --> 0KET + 1HC5P + 0HO2 + H2O', & + ' HC8 + HO --> 0HKET + 1HC8P + 0ALD + 0HO2 + H2O', & + ' ETE + HO --> ETEP ', & + ' OLT + HO --> OLTP ', & + ' OLI + HO --> OLIP ', & + ' DIEN + HO --> ISOP ', & + ' ISO + HO --> ISOP ', & + ' API + HO --> APIP ', & + ' LIM + HO --> LIMP '/ + + DATA (seqn(i),i=73,96)/ & + ' TOL + HO --> 1ADDT + 0XO2 + 0HO2', & + ' XYL + HO --> 1ADDX + 0XO2 + 0HO2', & + ' CSL + HO --> 0PHO + 1ADDC + 0XO2 + 0HO2', & + ' HCHO + HO --> CO + HO2 + H2O', & + ' ALD + HO --> ACO3 + H2O ', & + ' KET + HO --> KETP + H2O ', & + ' HKET + HO --> MGLY + HO2 + H2O', & + ' GLY + HO --> 2CO + HO2 + H2O', & + ' MGLY + HO --> CO + ACO3 + H2O', & + ' MACR + HO --> 0HKET + 0CO + 0MGLY + 0HCHO + 1TCO3 + ', & + ' DCB + HO --> 0UDD + 0GLY + 0MGLY + 0TCO3 + 0XO2 + 0', & + ' UDD + HO --> 0KET + 1ALD + HO2', & + ' OP1 + HO --> 0HCHO + 1MO2 + 0HO', & + ' HO + OP2 --> 0KET + 0HC3P + 0ALD + 0XO2 + 0HO', & + ' PAA + HO --> 0HCHO + 0XO2 + 1ACO3 + 0HO2', & + ' PAN + HO --> HCHO + XO2 + NO3 + H2O', & + ' TPAN + HO --> 1HKET + 0PAN + 0HCHO + XO2 + 0HO2 + 1N', & + ' HO + ONIT --> HC3P + NO2 + H2O', & + ' HCHO + NO3 --> HNO3 + CO + HO2', & + ' ALD + NO3 --> HNO3 + ACO3', & + ' GLY + NO3 --> HNO3 + 2CO + HO2', & + ' MGLY + NO3 --> HNO3 + CO + ACO3', & + ' MACR + NO3 --> 0HNO3 + 1CO + 0TCO3 + 1OLNN', & + ' DCB + NO3 --> 0HNO3 + 0GLY + 0MGLY + 0KET + 0ALD + 0'/ + + + DATA (seqn(i),i=97,120)/ & + ' CSL + NO3 --> PHO + HNO3 ', & + ' ETE + NO3 --> 1OLNN + 0OLND', & + ' OLT + NO3 --> 0OLNN + 1OLND', & + ' OLI + NO3 --> 0OLNN + 1OLND', & + ' DIEN + NO3 --> 1MACR + 1OLNN + 0OLND', & + ' ISO + NO3 --> 1MACR + 1OLNN + 0OLND', & + ' API + NO3 --> 0OLNN + 1OLND', & + ' LIM + NO3 --> 0OLNN + 1OLND', & + ' TPAN + NO3 --> 0PAN + 0HCHO + XO2 + 1ONIT + 1NO3 + 0N', & + ' ETE + O3 --> 0ORA1 + 0CO + HCHO + 0HO + 0HO2 + 0H2', & + ' OLT + O3 --> 0ORA1 + 0ORA2 + 0ETH + 0CH4 + 0H2O2 + ', & + ' OLI + O3 --> 0ORA2 + 0ETH + 0CH4 + 0H2O2 + 0CO + 0K', & + ' DIEN + O3 --> 0ORA1 + 0H2O2 + 0CO + 1HCHO + 0MACR + ', & + ' ISO + O3 --> 0ORA1 + 0H2O2 + 0CO + 1HCHO + 0MACR + ', & + ' API + O3 --> 0H2O2 + 0CO + 1KET + 1ALD + 0ETHP + 0K', & + ' LIM + O3 --> 0ORA1 + 0ORA2 + 0H2O2 + 0CO + 0HCHO + ', & + ' MACR + O3 --> 0ORA1 + 0ORA2 + 1CO + 1MGLY + 0HCHO + ', & + ' DCB + O3 --> 0ORA1 + 0ORA2 + 0PAA + 1CO + 0GLY + 1M', & + ' TPAN + O3 --> 0ORA1 + 0CO + 0PAN + 1HCHO + 1ACO3 + 0', & + ' PHO + NO2 --> 0CSL + ONIT', & + ' PHO + HO2 --> CSL ', & + ' ADDT + NO2 --> HONO + CSL ', & + ' ADDT + O2 --> 0CSL + 1TOLP + 0HO2', & + ' ADDT + O3 --> CSL + HO '/ + + DATA (seqn(i),i=121,144)/ & + ' ADDX + NO2 --> HONO + CSL ', & + ' ADDX + O2 --> 0CSL + 1XYLP + 0HO2', & + ' ADDX + O3 --> CSL + HO ', & + ' ADDC + NO2 --> HONO + CSL ', & + ' ADDC + O2 --> 0CSL + 1CSLP + 0HO2', & + ' ADDC + O3 --> CSL + HO ', & + ' ACO3 + NO2 --> PAN ', & + ' PAN --> ACO3 + NO2 ', & + ' TCO3 + NO2 --> TPAN ', & + ' TPAN --> TCO3 + NO2 ', & + ' MO2 + NO --> HCHO + HO2 + NO2', & + ' ETHP + NO --> ALD + HO2 + NO2', & + ' HC3P + NO --> 0GLY + 1KET + 0HCHO + 0ALD + 0XO2 + 0E', & + ' HC5P + NO --> 1KET + 0HCHO + 0ALD + 0XO2 + 0ETHP + 0', & + ' HC8P + NO --> 1KET + 0ALD + 0XO2 + 0ETHP + 0ONIT + 1', & + ' ETEP + NO --> 2HCHO + 0ALD + HO2 + NO2', & + ' OLTP + NO --> 0KET + HCHO + 1ALD + HO2 + NO2', & + ' OLIP + NO --> 0KET + 2ALD + HO2 + NO2', & + ' ISOP + NO --> 1HCHO + 0MACR + 0OLT + 0ONIT + 1HO2 + ', & + ' APIP + NO --> 1KET + 1ALD + 0ONIT + 1HO2 + 1NO2', & + ' LIMP + NO --> 0HCHO + 0MACR + 0OLI + 0ONIT + 1HO2 + ', & + ' TOLP + NO --> 1GLY + 1MGLY + 0DCB + 0ONIT + 1HO2 + 1', & + ' XYLP + NO --> 0GLY + 1MGLY + 1DCB + 0ONIT + 1HO2 + 1', & + ' CSLP + NO --> GLY + MGLY + HO2 + NO2'/ + + DATA (seqn(i),i=145,168)/ & + ' ACO3 + NO --> MO2 + NO2 ', & + ' TCO3 + NO --> HCHO + ACO3 + NO2', & + ' KETP + NO --> 1MGLY + 0ALD + 0XO2 + 0ACO3 + 1HO2 + N', & + ' OLNN + NO --> ONIT + HO2 + NO2', & + ' OLND + NO --> 0KET + 0HCHO + 1ALD + 2NO2', & + ' MO2 + HO2 --> OP1 ', & + ' ETHP + HO2 --> OP2 ', & + ' HC3P + HO2 --> OP2 ', & + ' HC5P + HO2 --> OP2 ', & + ' HC8P + HO2 --> OP2 ', & + ' ETEP + HO2 --> OP2 ', & + ' OLTP + HO2 --> OP2 ', & + ' OLIP + HO2 --> OP2 ', & + ' ISOP + HO2 --> OP2 ', & + ' APIP + HO2 --> OP2 ', & + ' LIMP + HO2 --> OP2 ', & + ' TOLP + HO2 --> OP2 ', & + ' XYLP + HO2 --> OP2 ', & + ' CSLP + HO2 --> OP2 ', & + ' ACO3 + HO2 --> PAA ', & + ' ACO3 + HO2 --> ORA2 + O3 ', & + ' TCO3 + HO2 --> OP2 ', & + ' TCO3 + HO2 --> ORA2 + O3 ', & + ' KETP + HO2 --> OP2 '/ + + DATA (seqn(i),i=169,192)/ & + ' OLNN + HO2 --> ONIT ', & + ' OLND + HO2 --> ONIT ', & + ' 2MO2 --> 1HCHO + 1HO2', & + ' ETHP + MO2 --> 1HCHO + 1ALD + HO2', & + ' HC3P + MO2 --> 0GLY + 0MGLY + 0KET + 1HCHO + 1ALD + 0', & + ' HC5P + MO2 --> 0KET + 1HCHO + 1ALD + 0XO2 + 0ETHP + 0', & + ' HC8P + MO2 --> 0KET + 1HCHO + 0ALD + 0XO2 + 0ETHP + 1', & + ' ETEP + MO2 --> 2HCHO + 0ALD + HO2', & + ' OLTP + MO2 --> 0KET + 1HCHO + 1ALD + HO2', & + ' OLIP + MO2 --> 0KET + 1HCHO + 1ALD + HO2', & + ' ISOP + MO2 --> 1HCHO + 1MACR + 0OLT + 0OLI + HO2', & + ' APIP + MO2 --> KET + HCHO + ALD + 2HO2', & + ' LIMP + MO2 --> 1HCHO + 1MACR + 0OLI + 2HO2', & + ' TOLP + MO2 --> 1GLY + 0MGLY + HCHO + DCB + HO2', & + ' XYLP + MO2 --> 0GLY + 1MGLY + HCHO + DCB + HO2', & + ' CSLP + MO2 --> GLY + MGLY + HCHO + 2HO2', & + ' MO2 + ACO3 --> HCHO + MO2 + HO2', & + ' MO2 + ACO3 --> ORA2 + HCHO', & + ' TCO3 + MO2 --> 2HCHO + ACO3 + HO2', & + ' TCO3 + MO2 --> ORA2 + HCHO', & + ' KETP + MO2 --> 0HKET + 0MGLY + 1HCHO + 0ALD + 0XO2 + ', & + ' OLNN + MO2 --> 1HCHO + ONIT + HO2', & + ' OLND + MO2 --> 0KET + 1HCHO + 1ALD + 0ONIT + 0HO2 + 0', & + ' ETHP + ACO3 --> 0ORA2 + ALD + 0MO2 + 0HO2'/ + + DATA (seqn(i),i=193,216)/ & + 'HC3P + ACO3 --> 0ORA2 + 0GLY + 0MGLY + 0KET + 0HCHO + ', & + 'HC5P + ACO3 --> 0ORA2 + 0KET + 0HCHO + 1ALD + 0XO2 + 0', & + 'HC8P + ACO3 --> 0ORA2 + 1KET + 0ALD + 0XO2 + 0ETHP + 1', & + 'ETEP + ACO3 --> 0ORA2 + 1HCHO + 1ALD + 0MO2 + 0HO2', & + 'OLTP + ACO3 --> 0ORA2 + 0KET + 1HCHO + 1ALD + 1MO2 + 1', & + 'OLIP + ACO3 --> 0ORA2 + 1KET + 1ALD + 1MO2 + 1HO2', & + 'ISOP + ACO3 --> 0ORA2 + 0HCHO + 1MACR + 0OLT + 1MO2 + ', & + ' APIP + ACO3 --> KET + ALD + MO2 + HO2', & + 'LIMP + ACO3 --> 0HCHO + 1MACR + 0OLI + MO2 + HO2', & + ' TOLP + ACO3 --> 1GLY + 0MGLY + DCB + MO2 + HO2', & + ' XYLP + ACO3 --> 0GLY + 1MGLY + DCB + MO2 + HO2', & + ' CSLP + ACO3 --> GLY + MGLY + MO2 + HO2', & + ' 2ACO3 --> 2MO2 ', & + ' TCO3 + ACO3 --> HCHO + MO2 + ACO3', & + 'KETP + ACO3 --> 0ORA2 + 1MGLY + 0KET + 0ALD + 0XO2 + 0', & + ' OLNN + ACO3 --> 0ORA2 + 0MO2 + ONIT + 0HO2', & + 'OLND + ACO3 --> 0ORA2 + 0KET + 0HCHO + 1ALD + 1MO2 + 0', & + ' 2OLNN --> 2ONIT + HO2', & + 'OLNN + OLND --> 0KET + 0HCHO + 1ALD + 2ONIT + 0HO2 + 0', & + ' 2OLND --> 0KET + 1HCHO + 1ALD + ONIT + NO2', & + ' MO2 + NO3 --> HCHO + HO2 + NO2', & + ' ETHP + NO3 --> ALD + HO2 + NO2', & + ' HC3P + NO3 --> 0GLY + 1KET + 0HCHO + 0ALD + 0XO2 + 0E', & + ' HC5P + NO3 --> 1KET + 0HCHO + 0ALD + 0XO2 + 0ETHP + 0'/ + + DATA (seqn(i),i=217,237)/ & + ' HC8P + NO3 --> 1KET + 0ALD + 1XO2 + 0ETHP + 1HO2 + NO', & + ' ETEP + NO3 --> 2HCHO + 0ALD + HO2 + NO2', & + ' OLTP + NO3 --> 0KET + HCHO + 1ALD + HO2 + NO2', & + ' OLIP + NO3 --> 0KET + 2ALD + HO2 + NO2', & + ' ISOP + NO3 --> 1HCHO + 1MACR + 0OLT + HO2 + NO2', & + ' APIP + NO3 --> KET + ALD + HO2 + NO2', & + ' LIMP + NO3 --> 0HCHO + 1MACR + 0OLI + HO2 + NO2', & + ' TOLP + NO3 --> 1GLY + 1MGLY + 0DCB + HO2 + NO2', & + ' XYLP + NO3 --> 1GLY + 1MGLY + DCB + HO2 + NO2', & + ' CSLP + NO3 --> GLY + MGLY + HO2 + NO2', & + ' ACO3 + NO3 --> MO2 + NO2 ', & + ' TCO3 + NO3 --> HCHO + ACO3 + NO2', & + ' KETP + NO3 --> 1MGLY + 0ALD + 0XO2 + 0ACO3 + 1HO2 + N', & + ' OLNN + NO3 --> ONIT + HO2 + NO2', & + ' OLND + NO3 --> 0KET + 0HCHO + 1ALD + 2NO2', & + ' XO2 + HO2 --> OP2 ', & + ' XO2 + MO2 --> HCHO + HO2 ', & + ' XO2 + ACO3 --> MO2 ', & + ' 2XO2 --> O2 ', & + ' XO2 + NO --> NO2 ', & + ' XO2 + NO3 --> NO2 '/ + + + + + DATA (lu_icol_v(i),i=1,252)/1, 5, 67, 2, 28, 67, 3, 12, 24, 30, 33, 35, & + 37, 51, 54, 57, 63, 67, 4, 30, 36, 38, 39, 44, 45, 50, 51, 52, 54, 55, & + 57, 58, 59, 60, 61, 63, 64, 65, 66, 69, 5, 67, 6, 63, 7, 67, 8, 67, 9, & + 67, 10, 70, 73, 11, 67, 12, 67, 13, 57, 58, 63, 67, 14, 57, 58, 63, & + 67, 15, 54, 67, 16, 67, 69, 73, 17, 65, 67, 69, 18, 21, 22, 25, 67, & + 72, 73, 19, 29, 30, 33, 37, 57, 58, 63, 67, 69, 20, 32, 67, 69, 70, & + 73, 8, 21, 63, 67, 73, 9, 22, 63, 67, 73, 11, 23, 35, 51, 64, 65, 67, & + 24, 63, 67, 70, 25, 32, 63, 67, 73, 26, 54, 63, 66, 67, 69, 27, 32, & + 34, 40, 48, 51, 53, 54, 67, 69, 70, 73, 12, 24, 28, 29, 30, 33, 34, & + 35, 37, 40, 48, 51, 53, 54, 57, 58, 62, 63, 67, 70, 29, 63, 67, 70, & + 30, 63, 67, 70, 31, 35, 63, 66, 67, 70, 73, 20, 21, 22, 25, 32, 63, & + 67, 69, 70, 73, 33, 63, 67, 70, 12, 34, 41, 46, 47, 52, 54, 63, 65, & + 66, 67, 70, 72, 35, 55, 63, 67, 70, 73, 24, 36, 63, 65, 66, 67, 69, & + 70, 72, 37, 62, 63, 67, 70, 38, 57, 65, 66, 67, 69, 70, 72, 39, 58, & + 65, 66, 67, 69, 70, 72, 23, 35, 40, 41, 46, 47, 51, 52, 54/ + + DATA (lu_icol_v(i),i=253,504)/55, 63, 64, 65, 66, 67, 70, 72, 73, 25, & + 32, 41, 63, 65, 66, 67, 69, 70, 72, 73, 7, 15, 29, 38, 39, 42, 44, 45, & + 49, 52, 54, 57, 58, 59, 60, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, & + 30, 43, 63, 65, 66, 67, 69, 70, 72, 7, 44, 65, 66, 67, 69, 70, 72, 11, & + 45, 65, 66, 67, 69, 70, 72, 21, 46, 63, 65, 66, 67, 69, 70, 72, 73, & + 22, 47, 63, 65, 66, 67, 69, 70, 72, 73, 12, 17, 23, 24, 26, 30, 31, & + 33, 34, 35, 36, 37, 38, 39, 41, 43, 44, 45, 46, 47, 48, 49, 50, 51, & + 52, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 69, 70, & + 72, 73, 29, 49, 63, 65, 66, 67, 69, 70, 72, 33, 37, 50, 62, 63, 65, & + 66, 67, 69, 70, 72, 30, 33, 37, 43, 50, 51, 62, 63, 65, 66, 67, 69, & + 70, 72, 12, 52, 65, 66, 67, 68, 69, 70, 71, 72, 11, 12, 15, 29, 36, & + 38, 39, 44, 45, 49, 51, 52, 53, 54, 57, 58, 59, 60, 61, 62, 63, 64, & + 65, 66, 67, 68, 69, 70, 71, 72, 37, 46, 47, 54, 62, 63, 65, 66, 67, & + 69, 70, 72, 73, 35, 51, 54, 55, 62, 63, 65, 66, 67, 69, 70, 72, 73, 8, & + 9, 26, 31, 32, 33, 35, 37, 44, 45, 51, 52, 54, 55, 56, 62, 63, 64, 65/ + + DATA (lu_icol_v(i),i=505,756)/66, 67, 68, 69, 70, 71, 72, 73, 30, 33, & + 37, 50, 57, 62, 63, 65, 66, 67, 69, 70, 72, 43, 50, 58, 62, 63, 65, & + 66, 67, 69, 70, 72, 24, 29, 30, 33, 37, 51, 57, 58, 59, 60, 62, 63, & + 65, 66, 67, 69, 70, 72, 24, 29, 30, 33, 37, 57, 58, 59, 60, 62, 63, & + 65, 66, 67, 69, 70, 72, 13, 29, 30, 42, 44, 45, 49, 52, 54, 57, 58, & + 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 6, 33, 37, & + 51, 62, 63, 65, 66, 67, 69, 70, 72, 73, 21, 22, 24, 25, 29, 30, 32, & + 33, 35, 37, 51, 54, 55, 57, 58, 62, 63, 65, 66, 67, 69, 70, 72, 73, & + 29, 30, 33, 37, 42, 44, 45, 49, 52, 54, 57, 58, 59, 60, 62, 63, 64, & + 65, 66, 67, 68, 69, 70, 71, 72, 73, 14, 17, 26, 33, 36, 37, 38, 39, & + 41, 43, 44, 45, 46, 47, 49, 50, 52, 53, 54, 55, 56, 57, 58, 59, 60, & + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 23, 26, 31, 33, & + 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 49, 50, 51, 52, & + 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, & + 70, 71, 72, 73, 5, 6, 7, 8, 9, 11, 12, 13, 14, 15, 16, 17, 18, 19, 21, & + 22/ + + DATA (lu_icol_v(i),i=757,1008)/23, 24, 25, 26, 27, 28, 29, 30, 31, 32, & + 33, 34, 35, 37, 40, 41, 42, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, & + 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & + 71, 72, 73, 20, 32, 35, 43, 44, 45, 46, 47, 49, 50, 52, 55, 59, 60, & + 62, 63, 65, 66, 67, 68, 69, 70, 71, 72, 73, 5, 7, 8, 9, 11, 12, 15, & + 16, 17, 19, 20, 21, 22, 23, 24, 25, 26, 28, 29, 30, 32, 33, 34, 35, & + 36, 37, 38, 39, 40, 41, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, & + 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & + 71, 72, 73, 10, 16, 24, 27, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, & + 39, 40, 41, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, & + 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, & + 36, 38, 39, 41, 43, 44, 45, 46, 47, 49, 50, 51, 52, 55, 56, 57, 58, & + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 18, 21, 22, 25, & + 32, 36, 38, 39, 41, 43, 44, 45, 46, 47, 49, 50, 52, 55, 56, 57, 58, & + 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 10, 16, & + 18, 20, 21/ + + DATA (lu_icol_v(i),i=1009,1051)/22, 25, 27, 31, 32, 34, 35, 36, 38, 39, & + 40, 41, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, & + 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73/ + + + DATA lu_crow_v/1, 4, 7, 19, 41, 43, 45, 47, 49, 51, 54, 56, 58, 63, 68, & + 71, 75, 79, 86, 96, 102, 107, 112, 119, 123, 128, 134, 146, 166, 170, & + 174, 181, 191, 195, 208, 214, 223, 228, 236, 244, 262, 273, 298, 307, & + 315, 323, 333, 343, 386, 395, 406, 420, 430, 460, 473, 486, 513, 526, & + 537, 555, 572, 598, 611, 635, 661, 699, 741, 804, 829, 890, 938, 968, & + 1004, 1052/ + + + DATA lu_diag_v/1, 4, 7, 19, 41, 43, 45, 47, 49, 51, 54, 56, 58, 63, 68, & + 71, 75, 79, 86, 96, 103, 108, 113, 119, 123, 128, 134, 148, 166, 170, & + 174, 185, 191, 196, 208, 215, 223, 228, 236, 246, 264, 278, 299, 308, & + 316, 324, 334, 363, 387, 397, 411, 421, 442, 463, 476, 500, 517, 528, & + 545, 563, 585, 602, 627, 651, 690, 733, 797, 823, 885, 934, 965, 1002, & + 1051, 1052/ + +!MODULE_DATA_RACM + END MODULE module_data_racm diff --git a/wrfv2_fire/chem/module_data_radm2.F b/wrfv2_fire/chem/module_data_radm2.F new file mode 100755 index 00000000..be594a88 --- /dev/null +++ b/wrfv2_fire/chem/module_data_radm2.F @@ -0,0 +1,174 @@ +!WRF:MODEL_LAYER:CHEMICS +! + MODULE module_data_radm2 + IMPLICIT NONE + REAL, PARAMETER :: epsilc = 1.E-16 + +!--- for radm solver +! .. Parameters .. + INTEGER, PARAMETER :: ldiag = 18, lpred = 39, lss = 2, & + lump = 4, naqre = 70, nreacj = 21, nreack = 140, & + ntroe = 7, numchem_radm = 41 + INTEGER, PARAMETER :: lspec = lpred + lss + INTEGER, DIMENSION(1:NTROE) :: itroe = (/11, 22, 10, 15, 21, 24, 28/) +! +! +! + INTEGER, PARAMETER :: lso2=1 + INTEGER, PARAMETER :: lsulf=2 + INTEGER, PARAMETER :: lno2=3 + INTEGER, PARAMETER :: lno=4 + INTEGER, PARAMETER :: lo3=5 + INTEGER, PARAMETER :: lhno3=6 + INTEGER, PARAMETER :: lh2o2=7 + INTEGER, PARAMETER :: lald=8 + INTEGER, PARAMETER :: lhcho=9 + INTEGER, PARAMETER :: lop1=10 + INTEGER, PARAMETER :: lop2=11 + INTEGER, PARAMETER :: lpaa=12 + INTEGER, PARAMETER :: lora1=13 + + INTEGER, PARAMETER :: lora2=14 + INTEGER, PARAMETER :: lnh3=15 + INTEGER, PARAMETER :: ln2o5=16 + INTEGER, PARAMETER :: lno3=17 + INTEGER, PARAMETER :: lpan=18 + INTEGER, PARAMETER :: lhc3=19 + INTEGER, PARAMETER :: lhc5=20 + INTEGER, PARAMETER :: lhc8=21 + + INTEGER, PARAMETER :: leth=22 + INTEGER, PARAMETER :: lco=23 + INTEGER, PARAMETER :: lol2=24 + INTEGER, PARAMETER :: lolt=25 + INTEGER, PARAMETER :: loli=26 + INTEGER, PARAMETER :: ltol=27 + INTEGER, PARAMETER :: lxyl=28 + INTEGER, PARAMETER :: laco3=29 + + INTEGER, PARAMETER :: ltpan=30 + INTEGER, PARAMETER :: lhono=31 + INTEGER, PARAMETER :: lhno4=32 + INTEGER, PARAMETER :: lket=33 + INTEGER, PARAMETER :: lgly=34 + INTEGER, PARAMETER :: lmgly=35 + INTEGER, PARAMETER :: ldcb=36 + INTEGER, PARAMETER :: lonit=37 + + INTEGER, PARAMETER :: lcsl=38 + INTEGER, PARAMETER :: liso=39 + INTEGER, PARAMETER :: lho=40 + INTEGER, PARAMETER :: lho2=41 +! parameters for timestep, integration + INTEGER, DIMENSION(1:lpred) :: intgrt = (/1, 1, 1, 0, 1, & + 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, & + 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1 /) +! INTEGER, DIMENSION(1:lspec) :: qdtc = (/0, 0, 1, 0, 1, & +! 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, & +! 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, & +! 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, & +! 0, 0, 0, 0, 0, 0 /) + INTEGER, DIMENSION(1:lspec) :: qdtc = (/1, 1, 1, 0, 1, & + 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, & + 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 0, 0 /) +! max, min values, + INTEGER :: itrdu +! + REAL, DIMENSION(1:lspec) :: cmin =(/(1.E-16,itrdu=1,lspec)/) +! + REAL, DIMENSION(1:lspec) :: cmax=(/1., 1., 1., 1., .2, & + 3., .05, .01, .01, .01, .05, .01, .05, .05,.05, & + 1., 1., 1., 1., 1., 1., 1., 1., 1., 1., & + 1., 1., 1., 1., 1., 1., 1., 1.,.0001, .1, & + 1., .001, .01, .01, .01, .01/) + +! +! +! + INTEGER, PARAMETER :: lo3p=1 + INTEGER, PARAMETER :: lo1d=2 + INTEGER, PARAMETER :: ltco3=3 + INTEGER, PARAMETER :: lhc3p=4 + INTEGER, PARAMETER :: lhc5p=5 + INTEGER, PARAMETER :: lhc8p=6 + + INTEGER, PARAMETER :: lol2p=7 + INTEGER, PARAMETER :: loltp=8 + INTEGER, PARAMETER :: lolip=9 + INTEGER, PARAMETER :: ltolp=10 + INTEGER, PARAMETER :: lxylp=11 + INTEGER, PARAMETER :: lethp=12 + INTEGER, PARAMETER :: lketp=13 + INTEGER, PARAMETER :: loln=14 + + INTEGER, PARAMETER :: lxo2=15 + INTEGER, PARAMETER :: lxno2=16 + INTEGER, PARAMETER :: lxho=17 + INTEGER, PARAMETER :: lmo2=18 +! +! + INTEGER, PARAMETER :: lnox=1 + INTEGER, PARAMETER :: lhox=2 + INTEGER, PARAMETER :: lpao3=3 + INTEGER, PARAMETER :: ln2n3=4 +! .. + REAL, PARAMETER :: ch4=1.7 + REAL, PARAMETER :: co2=350. + REAL, PARAMETER :: n2=7.81E5 + REAL, PARAMETER :: o2=2.09E5 + REAL, PARAMETER :: pi=3.141592654 + +! .. + REAL :: afac(2), & + bfac(2), const(3), eor(nreack), & + thafac(nreack), & + xk0300(ntroe), & + xkf300(ntroe), xmtroe(ntroe), xntroe(ntroe) + +! .. +! .. Data Statements .. + DATA thafac/0.00, 6.50E-12, 1.80E-11, 3.20E-11, 2.20E-10, 2.00E-12, & + 1.60E-12, 1.10E-14, 3.70E-12, 4*0.00, 3.30E-12, 0.00, 3.30E-19, & + 1.40E-13, 1.70E-11, 2.50E-14, 2.50E-12, 2*0.00, 2.00E-21, 2*0.00, & + 1.30E-12, 4.60E-11, 2*0.00, 6.95E-18, 1.37E-17, 1.59E-11, 1.73E-11, & + 3.64E-11, 2.15E-12, 5.32E-12, 1.07E-11, 2.10E-12, 1.89E-11, 4.00E-11, & + 9.00E-12, 6.87E-12, 1.20E-11, 1.15E-11, 1.70E-11, 2.80E-11, 1.00E-11, & + 1.00E-11, 1.00E-11, 6.85E-18, 1.55E-11, 2.55E-11, 2.80E-12, 1.95E+16, & + 4.70E-12, 1.95E+16, 4.20E-12, 4.20E-12, 0.00, 4.20E-12, 0.00, & + 4.20E-12, 0.00, 10*4.20E-12, 6.00E-13, 1.40E-12, 6.00E-13, 1.40E-12, & + 1.40E-12, 2.20E-11, 2.00E-12, 1.00E-11, 3.23E-11, 5.81E-13, 1.20E-14, & + 1.32E-14, 7.29E-15, 1.23E-14, 14*7.70E-14, 1.90E-13, 1.40E-13, & + 4.20E-14, 3.40E-14, 2.90E-14, 1.40E-13, 1.40E-13, 1.70E-14, 1.70E-14, & + 9.60E-13, 1.70E-14, 1.70E-14, 9.60E-13, 3.40E-13, 1.00E-13, 8.40E-14, & + 7.20E-14, 3.40E-13, 3.40E-13, 4.20E-14, 4.20E-14, 1.19E-12, 4.20E-14, & + 4.20E-14, 1.19E-12, 7.70E-14, 1.70E-14, 4.20E-14, 3.60E-16, 4.20E-12, & + 4.20E-12, 7.70E-14, 1.70E-14, 4.20E-14, 3.60E-16, 0.00, 1.70E-14, & + 4.20E-14, 3.60E-16/ +! .. +! constants for RADM2 rate coefficients + DATA eor/0., -120., -110., -70., 0., 1400., 940., 500., -240., 0., 0., & + 0., 0., 200., 0., -530., 2500., -150., 1230., 0., 0., 0., 0., 0., 0., & + -380., -230., 0., 0., 1280., 444., 540., 380., 380., -411., -504., & + -549., -322., -116., 0., 0., -256., 745., 0., 0., 0., 0., 0., 0., & + 444., 540., -409., -181., 13543., 0., 13543., -180., -180., 0., -180., & + 0., -180., 0., -180., -180., -180., -180., -180., -180., -180., -180., & + -180., -180., 2058., 1900., 2058., 1900., 1900., 0., 2923., 1895., & + 975., 0., 2633., 2105., 1136., 2013., -1300., -1300., -1300., -1300., & + -1300., -1300., -1300., -1300., -1300., -1300., -1300., -1300., & + -1300., -1300., 25* -220., -1300., -220., -220., -220., -180., -180., & + -1300., -220., -220., 0., 0., -220., -220., -220./ + + DATA xk0300/1.8E-31, 2.2E-30, 1.8E-31, 7.E-31, 2.2E-30, 2.6E-30, 3.E-31/ + DATA xntroe/3.2, 4.3, 3.2, 2.6, 4.3, 3.2, 3.3/ + DATA xkf300/4.7E-12, 1.5E-12, 4.7E-12, 1.5E-11, 1.5E-12, 2.4E-11, & + 1.5E-12/ + DATA xmtroe/1.4, 0.5, 1.4, 2*.5, 1.3, 0./ + DATA afac/2.1E-27, 1.1E-27/ + DATA bfac/10900., 11200./ + DATA const/7.34E21, 4.4E17, 3.23E33/ + + END MODULE module_data_radm2 diff --git a/wrfv2_fire/chem/module_data_sorgam.F b/wrfv2_fire/chem/module_data_sorgam.F new file mode 100644 index 00000000..cd784a3d --- /dev/null +++ b/wrfv2_fire/chem/module_data_sorgam.F @@ -0,0 +1,1148 @@ + +MODULE module_data_sorgam + USE module_data_radm2 +! +! param.inc start + IMPLICIT NONE + INTEGER NP !bs maximum expected value of N + PARAMETER (NP = 8) +! integer numaer +! parameter (numaer=50) + + INTEGER MAXITS !bs maximum number of iterations + PARAMETER (MAXITS = 100) + + REAL TOLF !bs convergence criterion on function values + PARAMETER (TOLF = 1.E-09) + + REAL TOLMIN !bs criterion whether superios convergence to + PARAMETER (TOLMIN = 1.E-12) !bs a minimum of fmin has occurred + + REAL TOLX !bs convergence criterion on delta_x + PARAMETER (TOLX = 1.E-10) + + REAL STPMX !bs scaled maximum step length allowed + PARAMETER (STPMX = 100.) + + + REAL c303, c302 + PARAMETER (c303=19.83,c302=5417.4) + + INTEGER lcva, lcvb, lspcv, ldesn + PARAMETER (lcva=4,lcvb=4,lspcv=lcva+lcvb) + PARAMETER (ldesn=13) +!mh ldesn is number of deposition species +!mh true number of deposited species may be larger since there +!mh are species which are deposited with the same rate + + INTEGER laerdvc, lnonaerdvc, l1ae, laero, imodes, aspec + PARAMETER (laerdvc=34,lnonaerdvc=8+lspcv) + PARAMETER (l1ae=laerdvc+lnonaerdvc) + PARAMETER (laero=4,imodes=4,aspec=1) +! LAERDVC number of advected aerosol dynamic parameters for a given +! component species +!ia L1AE advected parameters+non-advected parameters +!ia LAERO number of aerosol component species +!ia imodes number of aerosol modes +!ia ASPEC number of gas phase comp. that are added dynamically +!ia currently only sulfate (=1) +!bs +!bs * BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** +!bs + INTEGER aemiss + PARAMETER (aemiss=4) +!bs * AEMISS # of aerosol species with emissions link to gas phase +!bs currently ECI, ECJ, BCI, BCJ + INTEGER ldroga + PARAMETER (ldroga=11) + INTEGER ldrogb + PARAMETER (ldrogb=6) + INTEGER ldrog + PARAMETER (ldrog=ldroga+ldrogb) +!bs * LDROGA # of anthropogenic organic aerosol precursor gases (DR +!bs * LDROGB # of biogenic organic aerosol precursor gases (DROG) +!bs * LSPCV # of condensable organic vapor interacting between gas +!bs aerosol phase with SORGAM +!bs +! maxd_atype = maximum allowable number of aerosol types +! maxd_asize = maximum allowable number of aerosol size bins +! maxd_acomp = maximum allowable number of chemical components +! in each aerosol size bin +! maxd_aphase = maximum allowable number of aerosol phases (gas, cloud, ice, rain, ...) +! +! ntype_aer = number of aerosol types +! nsize_aer(t) = number of aerosol size bins for aerosol type t. each bin w/ same set of components +! nphase_aer = number of aerosol phases +! +! msectional - if positive, moving-center sectional code is utilized, +! and each mode is actually a section. +! maerosolincw - if positive, both unactivated/interstitial and activated +! aerosol species are simulated. if zero/negative, only the +! unactivated are simulated. +! +! ncomp_aer(t) = number of chemical components for aerosol type t +! ncomp_aer_nontracer(t) = number of "non-tracer" chemical components while in gchm code +! mastercompptr_aer(c,t) = mastercomp type/i.d. for chemical component c +! (1=sulfate, others to be defined) and aerosol type t. +! massptr_aer(c,s,t,p) = gchm r-array index for the mixing ratio +! (moles-x/mole-air) for chemical component c in size bin s for type t and phase p +! +! waterptr_aer(s,t) = mixing ratio (moles-water/mole-air) for water +! associated with aerosol size bin s and type t +! hygroptr_aer(s,t) = gchm r-array index for the bulk hygroscopicity of the size bin and type +! numptr_aer(s,t,p) = gchm r-array index for the number mixing ratio +! (particles/mole-air) for aerosol size bin s, type t, and phase p +! If zero or negative, then number is not being simulated. +! +! mprognum_aer(s,t,p) - if positive, number mixing-ratio for size s, type t, +! and phase p will be prognosed. Otherwise, no. +! +! ntot_mastercomp_aer = number of aerosol chemical components defined +! dens_mastercomp_aer(mc) = dry density (g/cm^3) of aerosol master chemical component type c +! mw_mastercomp_aer(mc) = molecular weight of aerosol master chemical component type mc +! name_mastercomp_aer(mc) = name of aerosol master chemical component type mc +! mc=mastercompptr_aer(c,t) +! dens_aer(c,t) = dry density (g/cm^3) of aerosol chemical component type c and type t +! mw_aer(c,t) = molecular weight of aerosol chemical component type c and type t +! name_aer(c,t) = name of aerosol chemical component type c and type t +! +! lptr_so4_aer(s,t,p) = gchm r-array index for the +! mixing ratio for sulfate associated with aerosol size bin s, type t, and phase p +! (similar for msa, oc, bc, nacl, dust) +! +!----------------------------------------------------------------------- +! +! volumcen_sect(s,t)= volume (cm^3) at center of section m +! volumlo_sect(s,t) = volume (cm^3) at lower boundary of section m +! volumhi_sect(s,t) = volume (cm^3) at upper boundary of section m +! +! dlo_sect(s,t) = diameter (cm) at lower boundary of section m +! dhi_sect(s,t) = diameter (cm) at upper boundary of section m +! dcen_sect(s,t) = volume arithmetic-mean diameter (cm) of section m +! (corresponds to volumcen_sect == 0.5*(volumlo_sect + volumhi_sect) +! +!----------------------------------------------------------------------- +! nov-04 sg ! replaced amode with aer and expanded aerosol dimension to include type and phase + + integer, parameter :: maxd_atype = 3 + integer, parameter :: maxd_asize = 1 + integer, parameter :: maxd_acomp = 17 + integer, parameter :: maxd_aphase = 2 + integer, save :: ai_phase ! interstitial phase of aerosol + integer, save :: cw_phase ! cloud water phase of aerosol + integer, save :: ci_phase ! cloud ice phase of aerosol + integer, save :: cr_phase ! rain phase of aerosol + integer, save :: cs_phase ! snow phase of aerosol + integer, save :: cg_phase ! graupel phase of aerosol + + integer, save :: ntype_aer = 0 ! number of types + integer, save :: ntot_mastercomp_aer = 0 ! number of master components + integer, save :: nphase_aer = 0 ! number of phases + + integer, save :: & + msectional, maerosolincw, & + nsize_aer( maxd_atype ), & ! number of size bins + ncomp_aer( maxd_atype ), & ! number of chemical components + ncomp_aer_nontracer( maxd_atype ), & + mastercompptr_aer(maxd_acomp, maxd_atype), & ! mastercomp index + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & ! index for mixing ratio + waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water + hygroptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol hygroscopicity + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & ! index for the number mixing ratio + mprognum_aer(maxd_asize,maxd_atype,maxd_aphase) + + real, save :: & + dens_aer( maxd_acomp, maxd_atype ), & + dens_mastercomp_aer( maxd_acomp ), & + mw_mastercomp_aer( maxd_acomp ), & + mw_aer( maxd_acomp, maxd_atype ), & + hygro_mastercomp_aer( maxd_acomp ), & + hygro_aer( maxd_acomp, maxd_atype ) + character*10, save :: & + name_mastercomp_aer( maxd_acomp ), & + name_aer( maxd_acomp, maxd_atype ) + + real, save :: & + volumcen_sect( maxd_asize, maxd_atype ), & + volumlo_sect( maxd_asize, maxd_atype ), & + volumhi_sect( maxd_asize, maxd_atype ), & + dcen_sect( maxd_asize, maxd_atype ), & + dlo_sect( maxd_asize, maxd_atype ), & + dhi_sect( maxd_asize, maxd_atype ), & + sigmag_aer(maxd_asize, maxd_atype) + + integer, save :: & + lptr_so4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_nh4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_no3_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgaro1_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgaro2_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgalk_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgole_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgba1_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgba2_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgba3_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgba4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_orgpa_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_ec_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_p25_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_anth_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_seas_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_soil_aer(maxd_asize,maxd_atype,maxd_aphase) + + +! molecular weights (g/mol) + real, parameter :: mw_so4_aer = 96.066 + real, parameter :: mw_no3_aer = 62.007 + real, parameter :: mw_seas_aer = 58.440 + real, parameter :: mw_ca_aer = 40.080 + real, parameter :: mw_co3_aer = 60.007 + real, parameter :: mw_nh4_aer = 18.042 + real, parameter :: mw_oc_aer = 1.0 + real, parameter :: mw_ec_aer = 1.0 + real, parameter :: mw_water_aer = 18.016 + +! dry densities (g/cm3) + real, parameter :: dens_so4_aer = 1.80 + real, parameter :: dens_no3_aer = 1.80 + real, parameter :: dens_seas_aer = 2.20 + real, parameter :: dens_nh4_aer = 1.80 + real, parameter :: dens_oc_aer = 1.00 + real, parameter :: dens_ec_aer = 1.70 + real, parameter :: dens_ca_aer = 2.20 + +! water density (g/cm3) + real, parameter :: dens_water_aer = 1.0 + +! hygroscopicity (dimensionless) + real, parameter :: hygro_so4_aer = 0.5 + real, parameter :: hygro_no3_aer = 0.5 + real, parameter :: hygro_seas_aer = 1.16 + real, parameter :: hygro_nh4_aer = 0.5 + real, parameter :: hygro_oc_aer = 0.14 + real, parameter :: hygro_ec_aer = 1.e-6 + real, parameter :: hygro_ca_aer = 0.1 + real, parameter :: hygro_co3_aer = 0.1 +! param.inc stop + +! ////////////////////////////////////////////////////////////////////// +! FSB include file + +! *** declare and set flag for organic aerosol production method +! *** Two method are available: + +! *** The method of Pandis,Harley, Cass, and Seinfeld, 1992, +! Secondary aerosol formation and transport, Atmos. Environ., 26A, +! pp 2453-2466 +! Bowman et al. Atmospheric Environment +! Vol 29, pp 579-589, 1995. +! *** and +! *** The method of Odum, Hoffmann, Bowman, Collins, Flagen and +! Seinfeld, 1996, Gas/particle partitioning and secondary organic ae +! yields, Environ. Sci, Technol, 30, pp 2580-2585. + + + ! 1 = Pandis et al. 1992 method is used + INTEGER orgaer + ! 2 = Pankow 1994/Odum et al. 1996 method is +! *** +! switch for organic aerosol method + PARAMETER (orgaer=2) + +! *** information about visibility variables +! number of visibility variables + INTEGER n_ae_vis_spc + PARAMETER (n_ae_vis_spc=2) + +! index for visual range in deciview + INTEGER idcvw + PARAMETER (idcvw=1) +! index for extinction [ 1/km ] + INTEGER ibext + PARAMETER (ibext=2) + + +! *** set up indices for array CBLK + +! index for Accumulation mode sulfate aeroso + INTEGER vso4aj + PARAMETER (vso4aj=1) + +! index for Aitken mode sulfate concentraton + INTEGER vso4ai + PARAMETER (vso4ai=2) + +! index for Accumulation mode aerosol ammoni + INTEGER vnh4aj + PARAMETER (vnh4aj=3) + +! index for Aitken mode ammonium concentrati + INTEGER vnh4ai + PARAMETER (vnh4ai=4) + +! index for Accumulation mode aerosol nitrat + INTEGER vno3aj + PARAMETER (vno3aj=5) + +! index for Aitken mode nitrate concentratio + INTEGER vno3ai + PARAMETER (vno3ai=6) + +! index for Accumulation mode anthropogen + INTEGER vorgaro1j + PARAMETER (vorgaro1j=7) + +! index for Aitken mode anthropogenic org + INTEGER vorgaro1i + PARAMETER (vorgaro1i=8) + +! index for Accumulation mode anthropogen + INTEGER vorgaro2j + PARAMETER (vorgaro2j=9) + +! index for Aitken mode anthropogenic org + INTEGER vorgaro2i + PARAMETER (vorgaro2i=10) + +! index for Accumulation mode anthropogen + INTEGER vorgalk1j + PARAMETER (vorgalk1j=11) + +! index for Aitken mode anthropogenic org + INTEGER vorgalk1i + PARAMETER (vorgalk1i=12) + +! index for Accumulation mode anthropogen + INTEGER vorgole1j + PARAMETER (vorgole1j=13) + +! index for Aitken mode anthropogenic org + INTEGER vorgole1i + PARAMETER (vorgole1i=14) + +! index for Accumulation mode biogenic aero + INTEGER vorgba1j + PARAMETER (vorgba1j=15) + +! index for Aitken mode biogenic aerosol co + INTEGER vorgba1i + PARAMETER (vorgba1i=16) + +! index for Accumulation mode biogenic aero + INTEGER vorgba2j + PARAMETER (vorgba2j=17) + +! index for Aitken mode biogenic aerosol co + INTEGER vorgba2i + PARAMETER (vorgba2i=18) + +! index for Accumulation mode biogenic aero + INTEGER vorgba3j + PARAMETER (vorgba3j=19) + +! index for Aitken mode biogenic aerosol co + INTEGER vorgba3i + PARAMETER (vorgba3i=20) + +! index for Accumulation mode biogenic aero + INTEGER vorgba4j + PARAMETER (vorgba4j=21) + +! index for Aitken mode biogenic aerosol co + INTEGER vorgba4i + PARAMETER (vorgba4i=22) + +! index for Accumulation mode primary anthro + INTEGER vorgpaj + PARAMETER (vorgpaj=23) + +! index for Aitken mode primary anthropogeni + INTEGER vorgpai + PARAMETER (vorgpai=24) + +! index for Accumulation mode aerosol elemen + INTEGER vecj + PARAMETER (vecj=25) + +! index for Aitken mode elemental carbon + INTEGER veci + PARAMETER (veci=26) + +! index for Accumulation mode primary PM2.5 + INTEGER vp25aj + PARAMETER (vp25aj=27) + +! index for Aitken mode primary PM2.5 concen + INTEGER vp25ai + PARAMETER (vp25ai=28) + +! index for coarse mode anthropogenic aeroso + INTEGER vantha + PARAMETER (vantha=29) + +! index for coarse mode marine aerosol conce + INTEGER vseas + PARAMETER (vseas=30) + +! index for coarse mode soil-derived aerosol + INTEGER vsoila + PARAMETER (vsoila=31) + +! index for Aitken mode number + INTEGER vnu0 + PARAMETER (vnu0=32) + +! index for accum mode number + INTEGER vac0 + PARAMETER (vac0=33) + +! index for coarse mode number + INTEGER vcorn + PARAMETER (vcorn=34) + +! index for Accumulation mode aerosol water + INTEGER vh2oaj + PARAMETER (vh2oaj=35) + +! index for Aitken mode aerosol water concen + INTEGER vh2oai + PARAMETER (vh2oai=36) + +! index for Aitken mode 3'rd moment + INTEGER vnu3 + PARAMETER (vnu3=37) + +! index for Accumulation mode 3'rd moment + INTEGER vac3 + PARAMETER (vac3=38) + +! index for coarse mode 3rd moment + INTEGER vcor3 + PARAMETER (vcor3=39) + +! index for sulfuric acid vapor concentratio + INTEGER vsulf + PARAMETER (vsulf=40) + +! index for nitric acid vapor concentration + INTEGER vhno3 + PARAMETER (vhno3=41) + +! index for ammonia gas concentration + INTEGER vnh3 + PARAMETER (vnh3=42) + +! index for cond. vapor from aromatics + INTEGER vcvaro1 + PARAMETER (vcvaro1=43) + +! index for cond. vapor from aromatics + INTEGER vcvaro2 + PARAMETER (vcvaro2=44) + +! index for cond. vapor from anth. alkane + INTEGER vcvalk1 + PARAMETER (vcvalk1=45) + +! index for cond. vapor from anth. olefin + INTEGER vcvole1 + PARAMETER (vcvole1=46) + +! index for cond. vapor from biogenics + INTEGER vcvapi1 + PARAMETER (vcvapi1=47) + +! index for cond. vapor from biogenics + INTEGER vcvapi2 + PARAMETER (vcvapi2=48) + +! index for cond. vapor from biogenics + INTEGER vcvlim1 + PARAMETER (vcvlim1=49) + +! index for cond. vapor from biogenics + INTEGER vcvlim2 + PARAMETER (vcvlim2=50) + +! COMMON /CBLKINDCS/ +! & VSO4AJ,VSO4AI,VNH4AJ,VNH4AI,VNO3AJ,VNO3AI, +! & VORGAJ,VORGAI, VORGPAJ,VORGPAI, +! & VORGBAJ,VORGBAI,VECJ,VECI, +! & VP25AJ,VP25AI,VANTHA,VSEAS,VSOILA, +! & VNU0,VAC0,VCORN, +! & VH2OAJ,VH2OAI, +! & VNU3,VAC3,VCOR3, +! & VSULF,VHNO3,VNH3 + +! *** set up species dimension and indices for sedimentation +! velocity array VSED + +! number of sedimentation velocities + INTEGER naspcssed + PARAMETER (naspcssed=6) + +! index for Aitken mode number + INTEGER vsnnuc + PARAMETER (vsnnuc=1) + +! index for Accumulation mode number + INTEGER vsnacc + PARAMETER (vsnacc=2) + +! index for coarse mode number + INTEGER vsncor + PARAMETER (vsncor=3) + +! index for Aitken mode mass + INTEGER vsmnuc + PARAMETER (vsmnuc=4) + +! index for accumulation mode mass + INTEGER vsmacc + PARAMETER (vsmacc=5) + +! index for coarse mass + INTEGER vsmcor + PARAMETER (vsmcor=6) + +! *** set up species dimension and indices for deposition +! velocity array VDEP + +! number of deposition velocities + INTEGER naspcsdep + PARAMETER (naspcsdep=7) + +! index for Aitken mode number + INTEGER vdnnuc + PARAMETER (vdnnuc=1) + +! index for accumulation mode number + INTEGER vdnacc + PARAMETER (vdnacc=2) + +! index for coarse mode number + INTEGER vdncor + PARAMETER (vdncor=3) + +! index for Aitken mode mass + INTEGER vdmnuc + PARAMETER (vdmnuc=4) + +! index for accumulation mode + INTEGER vdmacc + PARAMETER (vdmacc=5) + +! index for fine mode mass (Aitken + accumulatio + INTEGER vdmfine + PARAMETER (vdmfine=6) + +! index for coarse mode mass + INTEGER vdmcor + PARAMETER (vdmcor=7) + +! *** END AEROSTUFF.EXT +!bs +!BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * ! +!BS * * ! +!BS * include file used in SORGAM routines * ! +!BS * * ! +!BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * BS * ! +!bs +!bs +!bs * species pointer for condensable vapor production +!bs +!bs XYL + OH + INTEGER pxyl + PARAMETER (pxyl=1) +!bs TOL + OH + INTEGER ptol + PARAMETER (ptol=2) +!bs CSL + OH + INTEGER pcsl1 + PARAMETER (pcsl1=3) +!bs CSL + NO + INTEGER pcsl2 + PARAMETER (pcsl2=4) +!bs HC8 + OH + INTEGER phc8 + PARAMETER (phc8=5) +!bs OLI + OH + INTEGER poli1 + PARAMETER (poli1=6) +!bs OLI + NO + INTEGER poli2 + PARAMETER (poli2=7) +!bs OLI + O3 + INTEGER poli3 + PARAMETER (poli3=8) +!bs OLT + OH + INTEGER polt1 + PARAMETER (polt1=9) +!bs OLT + NO + INTEGER polt2 + PARAMETER (polt2=10) +!bs OLT + O3 + INTEGER polt3 + PARAMETER (polt3=11) +!bs API + OH + INTEGER papi1 + PARAMETER (papi1=12) +!bs API + NO + INTEGER papi2 + PARAMETER (papi2=13) +!bs API + O3 + INTEGER papi3 + PARAMETER (papi3=14) +!bs LIM + OH + INTEGER plim1 + PARAMETER (plim1=15) +!bs LIM + NO + INTEGER plim2 + PARAMETER (plim2=16) +!bs LIM + O3 + INTEGER plim3 + PARAMETER (plim3=17) +!bs +!bs * Number of lumped condensable vapors in SORGAM +!bs +!bs INTEGER NACV !bs # of anth. cond. vapors +!bs PARAMETER (NACV = 2) +!bs INTEGER NBCV !bs # of bio. cond. vapors +!bs PARAMETER (NBCV = 1) +!bs INTEGER NCV !bs total # of cond. vapor +!bs PARAMETER (NCV = NACV + NBCV) +!bs +!bs * species pointer for SOA species +!bs + INTEGER psoaaro1 + PARAMETER (psoaaro1=1) + INTEGER psoaaro2 + PARAMETER (psoaaro2=2) + INTEGER psoaalk1 + PARAMETER (psoaalk1=3) + INTEGER psoaole1 + PARAMETER (psoaole1=4) + INTEGER psoaapi1 + PARAMETER (psoaapi1=5) + INTEGER psoaapi2 + PARAMETER (psoaapi2=6) + INTEGER psoalim1 + PARAMETER (psoalim1=7) + INTEGER psoalim2 + PARAMETER (psoalim2=8) +!bs +!bs * end of AERO_SOA.EXT * +!bs + +! *** include file for aerosol routines + + +!.................................................................... + +! CONTAINS: Fundamental constants for air quality modeling + +! DEPENDENT UPON: none + +! REVISION HISTORY: + +! Adapted 6/92 by CJC from ROM's PI.EXT. + +! Revised 3/1/93 John McHenry to include constants needed by +! LCM aqueous chemistry +! Revised 9/93 by John McHenry to include additional constants +! needed for FMEM clouds and aqueous chemistry + +! Revised 3/4/96 by Dr. Francis S. Binkowski to reflect current +! Models3 view that MKS units should be used wherever possible, +! and that sources be documentated. Some variables have been added +! names changed, and values revised. + +! Revised 3/7/96 to have universal gas constant input and compute +! gas constant is chemical form. TWOPI is now calculated rather than + +! Revised 3/13/96 to group declarations and parameter statements. + +! Revised 9/13/96 to include more physical constants. +! Revised 12/24/96 eliminate silly EPSILON, AMISS + +! Revised 1/06/97 to eliminate most derived constants + +! FSB REFERENCES: + +! CRC76, CRC Handbook of Chemistry and Physics (76th Ed), +! CRC Press, 1995 +! Hobbs, P.V. Basic Physical Chemistry for the Atmospheric Scien +! Cambridge Univ. Press, 206 pp, 1995. +! Snyder, J.P., Map Projections-A Working Manual, U.S. Geological +! Paper 1395 U.S.GPO, Washington, DC, 1987. +! Stull, R. B., An Introduction to Bounday Layer Meteorology, Klu +! Dordrecht, 1988 + +! Geometric Constants: + + REAL*8 & ! PI (single precision 3.141593) + pirs + PARAMETER (pirs=3.14159265358979324) +! REAL PIRS ! PI (single precision 3.141593) +! PARAMETER ( PIRS = 3.141593 ) +! Fundamental Constants: ( Source: CRC76, pp 1-1 to 1-6) + +! Avogadro's Constant [ 1/mol ] + REAL avo + PARAMETER (avo=6.0221367E23) + +! universal gas constant [ J/mol-K ] + REAL rgasuniv + PARAMETER (rgasuniv=8.314510) + +! standard atmosphere [ Pa ] + REAL stdatmpa + PARAMETER (stdatmpa=101325.0) + +! Standard Temperature [ K ] + REAL stdtemp + PARAMETER (stdtemp=273.15) + +! Stefan-Boltzmann [ W/(m**2 K**4) ] + REAL stfblz + PARAMETER (stfblz=5.67051E-8) + + +! mean gravitational acceleration [ m/sec**2 ] + REAL grav + PARAMETER (grav=9.80622) +! FSB Non MKS qualtities: + +! Molar volume at STP [ L/mol ] Non MKS units + REAL molvol + PARAMETER (molvol=22.41410) + + +! Atmospheric Constants: + +! FSB 78.06% N2, 21% O2 and 0.943% A on a mole + REAL mwair + ! fraction basis. ( Source : Hobbs, 1995) pp 69- +! mean molecular weight for dry air [ g/mol ] + PARAMETER (mwair=28.9628) + +! dry-air gas constant [ J / kg-K ] + REAL rdgas + PARAMETER (rdgas=1.0E3*rgasuniv/mwair) + +! 3*PI + REAL threepi + PARAMETER (threepi=3.0*pirs) + +! 6/PI + REAL f6dpi + PARAMETER (f6dpi=6.0/pirs) + +! 1.0e9 * 6/PIRS + REAL f6dpi9 + PARAMETER (f6dpi9=1.0E9*f6dpi) + +! 1.0e-9 * 6/PIRS + REAL f6dpim9 + PARAMETER (f6dpim9=1.0E-9*f6dpi) + +! SQRT( PI ) + REAL sqrtpi + PARAMETER (sqrtpi=1.7724539) + +! SQRT( 2 ) + REAL sqrt2 + PARAMETER (sqrt2=1.4142135623731) + +! ln( sqrt( 2 ) ) + REAL lgsqt2 + PARAMETER (lgsqt2=0.34657359027997) + +! 1/ln( sqrt( 2 ) ) + REAL dlgsqt2 + PARAMETER (dlgsqt2=1.0/lgsqt2) + +! 1/3 + REAL one3 + PARAMETER (one3=1.0/3.0) + +! 2/3 + REAL two3 + PARAMETER (two3=2.0/3.0) + + +! *** physical constants: + +! Boltzmann's Constant [ J / K] + REAL boltz + PARAMETER (boltz=rgasuniv/avo) + + +! *** component densities [ kg/m**3 ] : + + +! bulk density of aerosol sulfate + REAL rhoso4 + PARAMETER (rhoso4=1.8E3) + +! bulk density of aerosol ammonium + REAL rhonh4 + PARAMETER (rhonh4=1.8E3) + +! bulk density of aerosol nitrate + REAL rhono3 + PARAMETER (rhono3=1.8E3) + +! bulk density of aerosol water + REAL rhoh2o + PARAMETER (rhoh2o=1.0E3) + +! bulk density for aerosol organics + REAL rhoorg + PARAMETER (rhoorg=1.0E3) + +! bulk density for aerosol soil dust + REAL rhosoil + PARAMETER (rhosoil=2.6E3) + +! bulk density for marine aerosol + REAL rhoseas + PARAMETER (rhoseas=2.2E3) + +! bulk density for anthropogenic aerosol + REAL rhoanth + PARAMETER (rhoanth=2.2E3) + +! *** Factors for converting aerosol mass concentration [ ug m**-3] to +! to 3rd moment concentration [ m**3 m^-3] + + REAL so4fac + PARAMETER (so4fac=f6dpim9/rhoso4) + + REAL nh4fac + PARAMETER (nh4fac=f6dpim9/rhonh4) + + REAL h2ofac + PARAMETER (h2ofac=f6dpim9/rhoh2o) + + REAL no3fac + PARAMETER (no3fac=f6dpim9/rhono3) + + REAL orgfac + PARAMETER (orgfac=f6dpim9/rhoorg) + + REAL soilfac + PARAMETER (soilfac=f6dpim9/rhosoil) + + REAL seasfac + PARAMETER (seasfac=f6dpim9/rhoseas) + + REAL anthfac + PARAMETER (anthfac=f6dpim9/rhoanth) + +! starting standard surface pressure [ Pa ] + REAL pss0 + PARAMETER (pss0=101325.0) + +! starting standard surface temperature [ K ] + REAL tss0 + PARAMETER (tss0=288.15) + +! initial sigma-G for nucleimode + REAL sginin + PARAMETER (sginin=1.70) + +! initial sigma-G for accumulation mode + REAL sginia + PARAMETER (sginia=2.00) + +! initial sigma-G for coarse mode + REAL sginic + PARAMETER (sginic=2.5) + +! initial mean diameter for nuclei mode [ m ] + REAL dginin + PARAMETER (dginin=0.01E-6) + +! initial mean diameter for accumulation mode [ m + REAL dginia + PARAMETER (dginia=0.07E-6) + +! initial mean diameter for coarse mode [ m ] + REAL dginic + PARAMETER (dginic=1.0E-6) + + + +!................ end AERO3box.EXT ............................... +!/////////////////////////////////////////////////////////////////////// + + + + + +! LOGICAL diagnostics +! *** Scalar variables for fixed standard deviations. + +! Flag for writing diagnostics to file +! nuclei mode exp( log^2( sigmag )/8 ) + REAL en1 +! accumulation mode exp( log^2( sigmag ) + REAL ea1 + + REAL ec1 +! coarse mode exp( log^2( sigmag )/8 ) +! nuclei **4 + REAL esn04 +! accumulation + REAL esa04 + + REAL esc04 +! coarse +! nuclei **5 + REAL esn05 + + REAL esa05 +! accumulation +! nuclei **8 + REAL esn08 +! accumulation + REAL esa08 + + REAL esc08 +! coarse +! nuclei **9 + REAL esn09 + + REAL esa09 +! accumulation +! nuclei **12 + REAL esn12 +! accumulation + REAL esa12 + + REAL esc12 +! coarse mode +! nuclei **16 + REAL esn16 +! accumulation + REAL esa16 + + REAL esc16 +! coarse +! nuclei **20 + REAL esn20 +! accumulation + REAL esa20 + + REAL esc20 +! coarse +! nuclei **25 + REAL esn25 + + REAL esa25 +! accumulation +! nuclei **24 + REAL esn24 +! accumulation + REAL esa24 + + REAL esc24 +! coarse +! nuclei **28 + REAL esn28 +! accumulation + REAL esa28 + + REAL esc28 +! coarse +! nuclei **32 + REAL esn32 +! accumulation + REAL esa32 + + REAL esc32 +! coarese +! nuclei **36 + REAL esn36 +! accumulation + REAL esa36 + + REAL esc36 +! coarse +! nuclei **49 + REAL esn49 + + REAL esa49 +! accumulation +! nuclei **52 + REAL esn52 + + REAL esa52 +! accumulation +! nuclei **64 + REAL esn64 +! accumulation + REAL esa64 + + REAL esc64 +! coarse + + REAL esn100 +! nuclei **100 +! nuclei **(-20) + REAL esnm20 +! accumulation + REAL esam20 + + REAL escm20 +! coarse +! nuclei **(-32) + REAL esnm32 +! accumulation + REAL esam32 + + REAL escm32 +! coarse +! log(sginin) + REAL xxlsgn +! log(sginia) + REAL xxlsga + + REAL xxlsgc +! log(sginic ) +! log(sginin ) ** 2 + REAL l2sginin +! log(sginia ) ** 2 + REAL l2sginia + + REAL l2sginic + + +! *** set up COMMON blocks for esg's: + + + +! log(sginic ) ** 2 + +! *** SET NUCLEATION FLAG: + + ! INUCL = 0, Kerminen & Wexler Mechanism + INTEGER inucl + ! INUCL = 1, Youngblood and Kreidenweis mech + ! INUCL = 2, Kulmala et al. mechanism +! Flag for Choice of nucleation Mechanism + PARAMETER (inucl=2) + +! *** Set flag for sedimentation velocities: + + LOGICAL icoarse + PARAMETER (icoarse=.FALSE.) ! *** END AERO_INTERNAL.EXT +! *** Diameters and standard deviations for emissions +! the diameters are the volume (mass) geometric mean diameters + +! *** Aitken mode: +! special factor to compute mass transfer + REAL dgvem_i + PARAMETER (dgvem_i=0.03E-6) ! [ m ] + REAL sgem_i + PARAMETER (sgem_i=1.7) + +! *** Accumulation mode: + REAL dgvem_j + PARAMETER (dgvem_j=0.3E-6) ! [ m ] + REAL sgem_j + PARAMETER (sgem_j=2.0) + +! *** Coarse mode + REAL dgvem_c + PARAMETER (dgvem_c=6.0E-6) ! [ m ] <<< Corrected 11/19/97 + REAL sgem_c + PARAMETER (sgem_c=2.2) + +! *** factors for getting number emissions rate from mass emissions rate +! Aitken mode + REAL factnumn +! accumulation mode + REAL factnuma + + REAL factnumc +! coarse mode + REAL facatkn_min, facacc_min + PARAMETER (facatkn_min=0.04,facacc_min=1.0-facatkn_min) + REAL conmin,xxm3 + PARAMETER (conmin=epsilc) +! [ ug/m**3 ] ! changed 1/6/98 + REAL*8 & ! factor to set minimum for Aitken mode number + nummin_i + REAL*8 & ! factor to set minimum for accumulation mode nu + nummin_j + REAL*8 & + nummin_c +! factor to set minimum for coarse mode number +!bs +!bs REAL ALPHSULF ! Accommodation coefficient for sulfuric acid +!bs PARAMETER ( ALPHSULF = 0.05 ) ! my be set to one in future +!bs +!bs REAL DIFFSULF ! molecular diffusivity for sulfuric acid [ m**2 +!bs PARAMETER( DIFFSULF = 0.08E-4 ) ! may be changed in future +!bs +!bs * 23/03/99 updates of ALPHSULF and DIFFSULF adopted fro new code fro +!bs * DIFFSULF is calculated from Reid, Prausnitz, and Poling, The prope +!bs * of gases and liquids, 4th edition, McGraw-Hill, 1987, pp 587-588. +!bs * Equation (11-4.4) was used. +!bs * The value is at T = 273.16 K and P = 1.01325E05 Pa +!bs * Temperature dependence is included for DIFFSULF via DIFFCORR (see +!bs +! Accommodation coefficient for sulfuric + REAL alphsulf + PARAMETER (alphsulf=1.0) +!bs updated from code of FSB +! molecular weight for sulfuric acid [ kg/mole ] MKS + REAL mwh2so4 + PARAMETER (mwh2so4=98.07354E-3) +!cia corrected error 24/11/97 +! molecular diffusivity for sulfuric acid [ m**2 /se + REAL diffsulf + PARAMETER (diffsulf=9.362223E-06) +!bs updated from code of FSB +!bs Accomodation coefficient for organic + REAL alphaorg + PARAMETER (alphaorg=1.0) !bs Kleeman et al. '99 propose alpha +!bs Bowman et al. '97 uses alpha = 1. +!bs mean molecular weight of organics [k + REAL mworg + PARAMETER (mworg=175.0E-03) +!bs +!bs * DIFFORG is calculated from the same formula as DIFFSULF. +!bs * An average elemental composition of C=8, O=3, N=1, H=17 is asuumed +!bs * to calculate DIFFORG at T = 273.16K and P = 1.01325E05 Pa. +!bs * Temepratur dependence is included below. +!bs molecular diffusivity for organics [ + REAL difforg + PARAMETER (difforg=5.151174E-06) +! *** CCONC is the factor for near-continuum condensation. +! ccofm * sqrt( ta ) + REAL cconc + PARAMETER (cconc=2.0*pirs*diffsulf) +!bs * factor for NC condensation for organics +! [ m**2 / sec ] + REAL cconc_org + PARAMETER (cconc_org=2.0*pirs*difforg) +! [ m**2 / sec ] +!bs analogue to CCOFM but for organics + REAL ccofm_org +! FSB CCOFM is the accommodation coefficient +! times the mean molecular velocity for h2so4 without the temperatu +! after some algebra + +!bs CCOFM_ORG * sqrt(TA) +! set to a value below + REAL ccofm +! minimum aerosol sulfate concentration + REAL aeroconcmin + PARAMETER (aeroconcmin=0.0001) + + + +END Module module_data_sorgam diff --git a/wrfv2_fire/chem/module_dep_simple.F b/wrfv2_fire/chem/module_dep_simple.F new file mode 100755 index 00000000..07e54ed4 --- /dev/null +++ b/wrfv2_fire/chem/module_dep_simple.F @@ -0,0 +1,1469 @@ + MODULE module_dep_simple +! +! many of these parameters will depend on the RADM mechanism! +! if you change it, lets talk about it and get it done!!! +! + + INTEGER, PARAMETER :: dep_seasons = 5 , nlu = 25, & + nseason = 1, nseasons = 2 +! +! following currently hardwired to USGS +! + INTEGER, PARAMETER :: isice_temp=24,iswater_temp=16 + character, parameter :: mminlu='USGS' +! + INTEGER :: ixxxlu(nlu) + REAL :: kpart(nlu), & + rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons), & + rgso(nlu,dep_seasons), rgss(nlu,dep_seasons), & + ri(nlu,dep_seasons), rlu(nlu,dep_seasons) +! +! NO MORE THAN 1000 SPECIES FOR DEPOSITION +! + REAL, DIMENSION (1:1000) :: dratio,hstar,hstar4,f0,dhr,scpr23 +! .. Default Accessibility .. + PUBLIC + logical, allocatable :: is_aerosol(:) ! true if field is aerosol (any phase) +! .. + CONTAINS + subroutine wesely_driver(id,ktau,dtstep, & + config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_model_constants + USE module_configure + USE module_state_description + USE module_data_sorgam +! USE module_data_radm2 +! USE module_data_racm + + INTEGER, INTENT(IN ) :: id,julday, & + numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, INTENT(IN ) :: & + dtstep,gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! deposition velocities +! + REAL, DIMENSION( its:ite, jts:jte, num_chem ), & + INTENT(INOUT ) :: ddvel +! +! input from met model +! + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT ) :: & + tsk, & + gsw, & + vegfra, & + pbl, & + rmol, & + ust, & + xlat, & + xlong, & + znt + +!--- deposition and emissions stuff +! .. +! .. Local Scalars .. + REAL :: clwchem,dvfog,dvpart,rad,rhchem,ta,ustar,vegfrac,z1,zntt + INTEGER :: iland, iprt, iseason, jce, jcs, n, nr, ipr,jpr,nvr + LOGICAL :: highnh3, rainflag, vegflag, wetflag +! .. +! .. Local Arrays .. + REAL :: p(kts:kte-1), srfres(numgas),ddvel0d(numgas) +! +! necessary for aerosols (module dependent) +! + real :: aer_res(its:ite,jts:jte),rcx(numgas) + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + +! .. +! .. Intrinsic Functions .. + INTRINSIC max, min +! .. + CALL wrf_debug(15,'in dry_dep_wesely') + iseason = 1 + if(julday.lt.90.or.julday.gt.270)then + iseason=2 + CALL wrf_debug(15,'setting iseason to 2') + endif + do 100 j=jts,jte + do 100 i=its,ite + iprt=0 + iland = ivgtyp(i,j) + ta = tsk(i,j) + rad = gsw(i,j) + vegfrac = vegfra(i,j) + pa = .01*p_phy(i,kts,j) + clwchem = moist(i,kts,j,p_qc) + ustar = ust(i,j) + zntt = znt(i,j) + + z1 = z_at_w(i,kts+1,j)-z_at_w(i,kts,j) + +! Set logical default values + rainflag = .FALSE. + wetflag = .FALSE. + highnh3 = .FALSE. + if(p_qr.gt.1)then + if(moist(i,kts,j,p_qr).gt.0.)rainflag = .true. + endif + rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) + rhchem = MAX(5.,RHCHEM) + if (rhchem >= 95.) wetflag = .true. + + if(chem(i,kts,j,p_nh3).gt.2.*chem(i,kts,j,p_so2))highnh3 = .true. + +!--- deposition + +! if(snowc(i,j).gt.0.)iseason=4 + CALL rc(rcx,ta,rad,rhchem,iland,iseason,numgas, & + wetflag,rainflag,highnh3,iprt,p_o3,p_so2,p_nh3) + srfres=0. + DO n = 1, numgas-2 + srfres(n) = rcx(n) + END DO + CALL deppart(rmol(i,j),ustar,rhchem,clwchem,iland,dvpart,dvfog) + ddvel0d=0. + aer_res(i,j)=0. + CALL landusevg(ddvel0d,ustar,rmol(i,j),zntt,z1,dvpart,iland, & + numgas,srfres,aer_res(i,j),p_sulf) + +!wig: CMBZ doe snot have Ho and HO2 last so need to copy all species +! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) + ddvel(i,j,1:numgas)=ddvel0d(1:numgas) + +100 continue +! +! For the additional CBMZ species, assign similar RADM counter parts for +! now. Short lived species get a zero velocity since dry dep should be +! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate +! + if ( (config_flags%chem_opt == CBMZ ) .or. & + (config_flags%chem_opt == CBMZ_BB ) .or. & + (config_flags%chem_opt == CBMZ_MOSAIC_4BIN_AQ) .or. & + (config_flags%chem_opt == CBMZ_MOSAIC_8BIN_AQ) .or. & + (config_flags%chem_opt == CBMZ_MOSAIC_4BIN) .or. & + (config_flags%chem_opt == CBMZ_MOSAIC_8BIN) ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_sulf) = ddvel(i,j,p_hno3) + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + ddvel(i,j,p_ch3o2) = 0 + ddvel(i,j,p_ethp) = 0 + ddvel(i,j,p_ch3oh) = ddvel(i,j,p_hcho) + ddvel(i,j,p_c2h5oh) = ddvel(i,j,p_hcho) + ddvel(i,j,p_par) = ddvel(i,j,p_hc5) + ddvel(i,j,p_to2) = 0 + ddvel(i,j,p_cro) = 0 + ddvel(i,j,p_open) = ddvel(i,j,p_xyl) + ddvel(i,j,p_op3) = ddvel(i,j,p_op2) + ddvel(i,j,p_c2o3) = 0 + ddvel(i,j,p_ro2) = 0 + ddvel(i,j,p_ano2) = 0 + ddvel(i,j,p_nap) = 0 + ddvel(i,j,p_xo2) = 0 + ddvel(i,j,p_xpar) = 0 + ddvel(i,j,p_isoprd) = 0 + ddvel(i,j,p_isopp) = 0 + ddvel(i,j,p_isopn) = 0 + ddvel(i,j,p_isopo2) = 0 + if( config_flags%chem_opt == CBMZ ) then + ddvel(i,j,p_dms) = 0 + ddvel(i,j,p_msa) = ddvel(i,j,p_hno3) + ddvel(i,j,p_dmso) = 0 + ddvel(i,j,p_dmso2) = 0 + ddvel(i,j,p_ch3so2h) = 0 + ddvel(i,j,p_ch3sch2oo) = 0 + ddvel(i,j,p_ch3so2) = 0 + ddvel(i,j,p_ch3so3) = 0 + ddvel(i,j,p_ch3so2oo) = 0 + ddvel(i,j,p_ch3so2ch2oo) = 0 + ddvel(i,j,p_mtf) = 0 + end if + end do + end do + end if + +END SUBROUTINE wesely_driver + +! ********************************************************************** +! ************************** SUBROUTINE RC *************************** +! ********************************************************************** + SUBROUTINE rc(rcx,t,rad,rh,iland,iseason,numgas, & + wetflag,rainflag,highnh3,iprt,p_o3,p_so2,p_nh3) +! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING +! TO THE MODEL OF +! M. L. WESELY, +! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 +! WITH SOME ADDITIONS ACCORDING TO +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODYFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +!---------------------------------------------------------------------- +! .. Scalar Arguments .. + REAL :: rad, rh, t + INTEGER :: iland, iseason, numgas + LOGICAL :: highnh3, rainflag, wetflag + real :: rcx(numgas) +! .. + INTEGER :: iprt,p_o3,p_so2,p_nh3 +! .. +! .. Local Scalars .. + REAL :: rclx, rdc, resice, rgsx, rluo1, rluo2, rlux, rmx, rs, rsmx, & + tc, rdtheta, z + INTEGER :: n +! .. +! .. Local Arrays .. + REAL :: hstary(numgas) +! .. +! .. Intrinsic Functions .. + INTRINSIC exp +! .. + DO n = 1, numgas + rcx(n) = 1. + END DO + + tc = t - 273.15 + rdtheta = 0. + + z = 200./(rad+0.1) + +!!! HARDWIRE VALUES FOR TESTING +! z=0.4727409 +! tc=22.76083 +! t=tc+273.15 +! rad = 412.8426 +! rainflag=.false. +! wetflag=.false. + + IF ((tc<=0.) .OR. (tc>=40.)) THEN + rs = 9999. + ELSE + rs = ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) + END IF + rdc = 100*(1.+1000./(rad+10))/(1+1000.*rdtheta) + rluo1 = 1./(1./3000.+1./3./rlu(iland,iseason)) + rluo2 = 1./(1./1000.+1./3./rlu(iland,iseason)) + resice = 1000.*exp(-tc-4.) + + DO n = 1, numgas + IF (hstar(n)==0.) GO TO 10 + hstary(n) = hstar(n)*exp(dhr(n)*(1./t-1./298.)) + rmx = 1./(hstary(n)/3000.+100.*f0(n)) + rsmx = rs*dratio(n) + rmx + rclx = 1./(hstary(n)/1.E+5/rcls(iland,iseason)+f0(n)/rclo(iland, & + iseason)) + resice + rgsx = 1./(hstary(n)/1.E+5/rgss(iland,iseason)+f0(n)/rgso(iland, & + iseason)) + resice + rlux = rlu(iland,iseason)/(1.E-5*hstary(n)+f0(n)) + resice + IF (wetflag) THEN + rlux = 1./(1./3./rlu(iland,iseason)+1.E-7*hstary(n)+f0(n)/rluo1) + END IF + IF (rainflag) THEN + rlux = 1./(1./3./rlu(iland,iseason)+1.E-7*hstary(n)+f0(n)/rluo2) + END IF + rcx(n) = 1./(1./rsmx+1./rlux+1./(rdc+rclx)+1./(rac(iland, & + iseason)+rgsx)) + IF (rcx(n)<1.) rcx(n) = 1. +10 END DO + +! SPECIAL TREATMENT FOR OZONE + hstary(p_o3) = hstar(p_o3)*exp(dhr(p_o3)*(1./t-1./298.)) + rmx = 1./(hstary(p_o3)/3000.+100.*f0(p_o3)) + rsmx = rs*dratio(p_o3) + rmx + rlux = rlu(iland,iseason)/(1.E-5*hstary(p_o3)+f0(p_o3)) + resice + rclx = rclo(iland,iseason) + resice + rgsx = rgso(iland,iseason) + resice + IF (wetflag) rlux = rluo1 + IF (rainflag) rlux = rluo2 + rcx(p_o3) = 1./(1./rsmx+1./rlux+1./(rdc+rclx)+1./(rac(iland, & + iseason)+rgsx)) + IF (rcx(p_o3)<1.) rcx(p_o3) = 1. + +! SPECIAL TREATMENT FOR SO2 (Wesely) +! HSTARY(P_SO2)=HSTAR(P_SO2)*EXP(DHR(P_SO2)*(1./T-1./298.)) +! RMX=1./(HSTARY(P_SO2)/3000.+100.*F0(P_SO2)) +! RSMX=RS*DRATIO(P_SO2)+RMX +! RLUX=RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+F0(P_SO2)) +! & +RESICE +! RCLX=RCLS(ILAND,ISEASON)+RESICE +! RGSX=RGSS(ILAND,ISEASON)+RESICE +! IF ((wetflag).OR.(RAINFLAG)) THEN +! IF (ILAND.EQ.1) THEN +! RLUX=50. +! ELSE +! RLUX=100. +! END IF +! END IF +! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) +! & +1./(RAC(ILAND,ISEASON)+RGSX)) +! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. + +! SO2 according to Erisman et al. 1994 +! R_STOM + rsmx = rs*dratio(p_so2) +! R_EXT + IF (tc>(-1.)) THEN + IF (rh<81.3) THEN + rlux = 25000.*exp(-0.0693*rh) + ELSE + rlux = 0.58E12*exp(-0.278*rh) + END IF + END IF + IF (((wetflag) .OR. (rainflag)) .AND. (tc>(-1.))) THEN + rlux = 1. + END IF + IF ((tc>=(-5.)) .AND. (tc<=(-1.))) THEN + rlux = 200. + END IF + IF (tc<(-5.)) THEN + rlux = 500. + END IF +! INSTEAD OF R_INC R_CL and R_DC of Wesely are used + rclx = rcls(iland,iseason) +! DRY SURFACE + rgsx = 1000. +! WET SURFACE + IF ((wetflag) .OR. (rainflag)) THEN + IF (highnh3) THEN + rgsx = 0. + ELSE + rgsx = 500. + END IF + END IF +! WATER + IF (iland==iswater_temp) THEN + rgsx = 0. + END IF +! SNOW + IF ((iseason==4) .OR. (iland==isice_temp)) THEN + IF (tc>2.) THEN + rgsx = 0. + END IF + IF ((tc>=(-1.)) .AND. (tc<=2.)) THEN + rgsx = 70.*(2.-tc) + END IF + IF (tc<(-1.)) THEN + rgsx = 500. + END IF + END IF +! TOTAL SURFACE RESISTENCE + IF ((iseason/=4) .AND. (ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & + (iland/=isice_temp)) THEN + rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) + ELSE + rcx(p_so2) = rgsx + END IF + IF (rcx(p_so2)<1.) rcx(p_so2) = 1. +! NH3 according to Erisman et al. 1994 +! R_STOM + rsmx = rs*dratio(p_nh3) +! GRASSLAND (PASTURE DURING GRAZING) + IF (ixxxlu(iland)==3) THEN + IF (iseason==1) THEN +! SUMMER + rcx(p_nh3) = 1000. + END IF + IF ((iseason==2) .OR. (iseason==3) .OR. (iseason==5)) THEN +! WINTER, NO SNOW + IF (tc>-1.) THEN + IF (rad/=0.) THEN + rcx(p_nh3) = 50. + ELSE + rcx(p_nh3) = 100. + END IF + IF ((wetflag) .OR. (rainflag)) THEN + rcx(p_nh3) = 20. + END IF + END IF + IF ((tc>=(-5.)) .AND. (tc<=-1.)) THEN + rcx(p_nh3) = 200. + END IF + IF (tc<(-5.)) THEN + rcx(p_nh3) = 500. + END IF + END IF + END IF +! AGRICULTURAL LAND (CROPS AND UNGRAZED PASTURE) + IF (ixxxlu(iland)==2) THEN + IF (iseason==1) THEN +! SUMMER + IF (rad/=0.) THEN + rcx(p_nh3) = rsmx + ELSE + rcx(p_nh3) = 200. + END IF + IF ((wetflag) .OR. (rainflag)) THEN + rcx(p_nh3) = 50. + END IF + END IF + IF ((iseason==2) .OR. (iseason==3) .OR. (iseason==5)) THEN +! WINTER, NO SNOW + IF (tc>-1.) THEN + IF (rad/=0.) THEN + rcx(p_nh3) = rsmx + ELSE + rcx(p_nh3) = 300. + END IF + IF ((wetflag) .OR. (rainflag)) THEN + rcx(p_nh3) = 100. + END IF + END IF + IF ((tc>=(-5.)) .AND. (tc<=-1.)) THEN + rcx(p_nh3) = 200. + END IF + IF (tc<(-5.)) THEN + rcx(p_nh3) = 500. + END IF + END IF + END IF +! SEMI-NATURAL ECOSYSTEMS AND FORESTS + IF ((ixxxlu(iland)==4) .OR. (ixxxlu(iland)==5) .OR. (ixxxlu( & + iland)==6)) THEN + IF (rad/=0.) THEN + rcx(p_nh3) = 500. + ELSE + rcx(p_nh3) = 1000. + END IF + IF ((wetflag) .OR. (rainflag)) THEN + IF (highnh3) THEN + rcx(p_nh3) = 100. + ELSE + rcx(p_nh3) = 0. + END IF + END IF + IF ((iseason==2) .OR. (iseason==3) .OR. (iseason==5)) THEN +! WINTER, NO SNOW + IF ((tc>=(-5.)) .AND. (tc<=-1.)) THEN + rcx(p_nh3) = 200. + END IF + IF (tc<(-5.)) THEN + rcx(p_nh3) = 500. + END IF + END IF + END IF +! WATER + IF (iland==iswater_temp) THEN + rcx(p_nh3) = 0. + END IF +! URBAN AND DESERT (SOIL SURFACES) + IF (ixxxlu(iland)==1) THEN + IF ( .NOT. wetflag) THEN + rcx(p_nh3) = 50. + ELSE + rcx(p_nh3) = 0. + END IF + END IF +! SNOW COVERED SURFACES OR PERMANENT ICE + IF ((iseason==4) .OR. (iland==isice_temp)) THEN + IF (tc>2.) THEN + rcx(p_nh3) = 0. + END IF + IF ((tc>=(-1.)) .AND. (tc<=2.)) THEN + rcx(p_nh3) = 70.*(2.-tc) + END IF + IF (tc<(-1.)) THEN + rcx(p_nh3) = 500. + END IF + END IF + IF (rcx(p_nh3)<1.) rcx(p_nh3) = 1. + + END SUBROUTINE rc +! ********************************************************************** +! ************************ SUBROUTINE DEPPART ************************** +! ********************************************************************** + SUBROUTINE deppart(rmol,ustar,rh,clw,iland,dvpart,dvfog) +! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES +! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF +! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 +! WRITTEN BY WINFRIED SEIDL, APRIL 1997 +! MODIFIED BY WINFRIED SEIDL, MARCH 2000 +! FOR MM5 VERSION 3 +! ---------------------------------------------------------------------- +! .. Scalar Arguments .. + REAL :: clw, dvfog, dvpart, rh, rmol, ustar + INTEGER :: iland +! .. +! .. Intrinsic Functions .. + INTRINSIC exp +! .. + dvpart = ustar/kpart(iland) + IF (rmol<0.) THEN +! INSTABLE LAYERING CORRECTION + dvpart = dvpart*(1.+(-300.*rmol)**0.66667) + END IF + IF (rh>80.) THEN +! HIGH RELATIVE HUMIDITY CORRECTION +! ACCORDING TO J. W. ERISMAN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 + dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) + END IF + +! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO +! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE +! J. GEOPHYS. RES. 95D (1990), 18501-18515 + dvfog = 0.06*clw + IF (ixxxlu(iland)==5) THEN +! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI +! A. T. VERMEULEN ET AL. +! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 + dvfog = dvfog + 0.195*ustar*ustar + END IF + + END SUBROUTINE deppart + SUBROUTINE landusevg(vgs,ustar,rmol,z0,zz,dvparx,iland,numgas, & + srfres,aer_res,p_sulf) +! This subroutine calculates the species specific deposition velocit +! as a function of the local meteorology and land use. The depositi +! Velocity is also landuse specific. +! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) +! A Dry Deposition Module for Regional Acid Deposition +! EPA report under agreement DW89930060-01 +! Revised version by Darrell Winner (January 1991) +! Environmental Engineering Science 138-78 +! California Institute of Technology +! Pasadena, CA 91125 +! Modified by Winfried Seidl (August 1997) +! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung +! Garmisch-Partenkirchen, D-82467 +! for use of Wesely and Erisman surface resistances +! Inputs: +! Ustar : The grid average friction velocity (m/s) +! Rmol : Reciprocal of the Monin-Obukhov length (1/m) +! Z0 : Surface roughness height for the grid square (m) +! SrfRes : Array of landuse/atmospheric/species resistances (s/m) +! Slist : Array of chemical species codes +! Dvparx : Array of surface deposition velocity of fine aerosol p +! Outputs: +! Vgs : Array of species and landuse specific deposition +! velocities (m/s) +! Vg : Cell-average deposition velocity by species (m/s) +! Variables used: +! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac +! Zr : Reference Height (m) +! Iatmo : Parameter specifying the stabilty class (Function of +! Z0 : Surface roughness height (m) +! karman : Von Karman constant (from module_model_constants) + USE module_model_constants, only: karman +! Local Variables +! .. Scalar Arguments .. + REAL :: dvparx, rmol, ustar, z0, zz + real :: aer_res, polint + INTEGER :: iland, numgas, p_sulf +! .. +! .. Array Arguments .. + REAL :: srfres(numgas), vgs(numgas) +! .. +! .. Local Scalars .. + REAL :: vgp, vgpart, zr + INTEGER :: jspec +! .. +! .. Local Arrays .. + REAL :: vgspec(numgas) +! .. +! Set the reference height (10.0 m) + zr = 10.0 + +! CALCULATE THE DEPOSITION VELOCITY without any surface +! resistance term, i.e. 1 / (ra + rb) + CALL depvel(numgas,rmol,zr,z0,ustar,vgspec,vgpart,aer_res) + +! Calculate the deposition velocity for each species +! and grid cell by looping through all the possibile combinations +! of the two + + vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) + +! Loop through the various species + + DO jspec = 1, numgas + +! Add in the surface resistance term, rc (SrfRes) + + vgs(jspec) = 1.0/(1.0/vgspec(jspec)+srfres(jspec)) + END DO + vgs(p_sulf) = vgp + + CALL cellvg(vgs,ustar,zz,zr,rmol,numgas) + + RETURN + END SUBROUTINE landusevg + + SUBROUTINE cellvg(vgtemp,ustar,dz,zr,rmol,nspec) +! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE +! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE +! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (February 1991) +!.....PROGRAM VARIABLES... +! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT +! USTAR - FRICTION VELOCITY +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! DZ - CELL HEIGHT +! CELLVG - CELL AVERAGE DEPOSITION VELOCITY +! VK - VON KARMAN CONSTANT + USE module_model_constants, only: karman +! Local Variables +! .. Scalar Arguments .. + REAL :: dz, rmol, ustar, zr + INTEGER :: nspec +! .. +! .. Array Arguments .. + REAL :: vgtemp(nspec) +! .. +! .. Local Scalars .. + REAL :: a, fac, pdz, pzr, vk + INTEGER :: nss +! .. +! .. Intrinsic Functions .. + INTRINSIC alog, sqrt +! .. +! Set the von Karman constant + vk = karman + +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE + + + DO nss = 1, nspec + IF (rmol<0) THEN + pdz = sqrt(1.0-9.0*dz*rmol) + pzr = sqrt(1.0-9.0*zr*rmol) + fac = ((pdz-1.0)/(pzr-1.0))*((pzr+1.0)/(pdz+1.0)) + a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) + ELSE IF (rmol==0) THEN + a = 0.74*(dz*alog(dz/zr)-dz+zr) + ELSE + a = 0.74*(dz*alog(dz/zr)-dz+zr) + (2.35*rmol)*(dz-zr)**2 + END IF + +! CALCULATE THE DEPOSITION VELOCITIY + + vgtemp(nss) = vgtemp(nss)/(1.0+vgtemp(nss)*a/(vk*ustar*(dz-zr))) + END DO + + RETURN + END SUBROUTINE cellvg + SUBROUTINE depvel(numgas,rmol,zr,z0,ustar,depv,vgpart,aer_res) +! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT +! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE +! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. +! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) +! Modified by Darrell A. Winner (Feb. 1991) +! by Winfried Seidl (Aug. 1997) +!.....PROGRAM VARIABLES... +! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH +! ZR - REFERENCE HEIGHT +! Z0 - SURFACE ROUGHNESS HEIGHT +! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact +! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED +! DEPVEL - POLLUTANT DEPOSITION VELOCITY +! Vk - VON KARMAN CONSTANT +! USTAR - FRICTION VELOCITY U* +! POLINT - POLLUTANT INTEGRAL +! AER_RES - AERODYNAMIC RESISTANCE +!.....REFERENCES... +! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL +! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, +! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. +!.....RESTRICTIONS... +! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV +! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE +! SURFACE LAYER, A HEIGHT OF O(30M). +! 2. ALL INPUT UNITS MUST BE CONSISTENT +! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION +! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED +! ON THE WORK OF BUSINGER ET AL.(1971). +! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT +! THE SAME FOR THE CASES L<0 AND L>0. + USE module_model_constants, only: karman +! Local Variables +! .. Scalar Arguments .. + REAL :: rmol, ustar, vgpart, z0, zr, aer_res + INTEGER :: numgas +! .. +! .. Array Arguments .. + REAL :: depv(numgas) +! .. +! .. Local Scalars .. + REAL :: ao, ar, polint, vk + INTEGER :: l +! .. +! .. Intrinsic Functions .. + INTRINSIC alog +! .. +! Set the von Karman constant + vk = karman + +! Calculate the diffusion correction factor +! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 +! SCPR23 = 1.10 + +! DETERMINE THE STABILITY BASED ON THE CONDITIONS +! 1/L < 0 UNSTABLE +! 1/L = 0 NEUTRAL +! 1/L > 0 STABLE + + if(abs(rmol) < 1.E-6 ) rmol = 0. + + IF (rmol<0) THEN + ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 + ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 + polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) + ELSE IF (rmol==0.) THEN + polint = 0.74*alog(zr/z0) + ELSE + polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) + END IF + +! CALCULATE THE Maximum DEPOSITION VELOCITY + + DO l = 1, numgas + depv(l) = ustar*vk/(2.0*scpr23(l)+polint) + END DO + vgpart = ustar*vk/polint + aer_res = polint/(karman*max(ustar,1.0e-4)) + + RETURN + END SUBROUTINE depvel + + SUBROUTINE dep_init(id,config_flags,numgas) + USE module_model_constants + USE module_configure + USE module_state_description + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags +! .. +! .. Scalar Arguments .. + integer, intent(in) :: id, numgas + +! .. +! .. Local Scalars .. + REAL :: sc + INTEGER :: iland, iseason, l + integer :: iprt +! .. +! .. Local Arrays .. + REAL :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & + dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & + dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & + dat7(nlu,dep_seasons), dvj(numgas) +! .. +! .. Make sure that the model is being run with a soil model. Otherwise, +! iland will be zero in deppart, which will try to pull non-exisant +! array locations. + call nl_get_sf_surface_physics(id,l) + if( l == 0 ) & + call wrf_error_fatal("ERROR: Cannot use dry deposition without using a soil model.") + +! .. +! .. Data Statements .. +! RI for stomatal resistance +! data ((ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & + DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & + 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & + 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & + 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & + 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & + 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & + 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & + 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & + 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & + 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & + 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & + 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ +! .. + IF (nlu/=25) THEN + call wrf_debug(0, 'number of land use classifications not correct ') + CALL wrf_error_fatal ( "LAND USE CLASSIFICATIONS NOT 25") + END IF + IF (dep_seasons/=5) THEN + call wrf_debug(0, 'number of dep_seasons not correct ') + CALL wrf_error_fatal ( "DEP_SEASONS NOT 5") + END IF + +! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF +! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 + +! Seasonal categories: +! 1: midsummer with lush vegetation +! 2: autumn with unharvested cropland +! 3: late autumn with frost, no snow +! 4: winter, snow on ground and subfreezing +! 5: transitional spring with partially green short annuals + +! Land use types: +! USGS type Wesely type +! 1: Urban and built-up land 1 +! 2: Dryland cropland and pasture 2 +! 3: Irrigated cropland and pasture 2 +! 4: Mix. dry/irrg. cropland and pasture 2 +! 5: Cropland/grassland mosaic 2 +! 6: Cropland/woodland mosaic 4 +! 7: Grassland 3 +! 8: Shrubland 3 +! 9: Mixed shrubland/grassland 3 +! 10: Savanna 3, always summer +! 11: Deciduous broadleaf forest 4 +! 12: Deciduous needleleaf forest 5, autumn and winter modi +! 13: Evergreen broadleaf forest 4, always summer +! 14: Evergreen needleleaf forest 5 +! 15: Mixed Forest 6 +! 16: Water Bodies 7 +! 17: Herbaceous wetland 9 +! 18: Wooded wetland 6 +! 19: Barren or sparsely vegetated 8 +! 20: Herbaceous Tundra 9 +! 21: Wooded Tundra 6 +! 22: Mixed Tundra 6 +! 23: Bare Ground Tundra 8 +! 24: Snow or Ice -, always winter +! 25: No data 8 + + +! Order of data: +! | +! | seasonal category +! \|/ +! ---> landuse type +! 1 2 3 4 5 6 7 8 9 +! RLU for outer surfaces in the upper canopy + DO iseason = 1, dep_seasons + DO iland = 1, nlu + ri(iland,iseason) = dat1(iland,iseason) + END DO + END DO +! data ((rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & + 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & + 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rlu(iland,iseason) = dat2(iland,iseason) + END DO + END DO +! RAC for transfer that depends on canopy height and density +! data ((rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & + DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & + 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & + 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & + 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & + 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & + 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & + 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & + 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & + 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & + 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & + 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & + 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & + 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & + 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rac(iland,iseason) = dat3(iland,iseason) + END DO + END DO +! RGSS for ground surface SO2 +! data ((rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & + DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & + 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & + 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & + 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & + 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & + 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & + 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & + 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & + 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & + 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & + 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & + 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & + 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & + 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rgss(iland,iseason) = dat4(iland,iseason) + END DO + END DO +! RGSO for ground surface O3 +! data ((rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & + DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & + 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & + 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & + 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & + 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & + 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & + 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & + 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & + 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & + 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & + 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & + 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & + 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & + 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rgso(iland,iseason) = dat5(iland,iseason) + END DO + END DO +! RCLS for exposed surfaces in the lower canopy SO2 +! data ((rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & + 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & + 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & + 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & + 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & + 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & + 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & + 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & + 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & + 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & + 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & + 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rcls(iland,iseason) = dat6(iland,iseason) + END DO + END DO +! RCLO for exposed surfaces in the lower canopy O3 +! data ((rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & + DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & + 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & + 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & + 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & + 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & + 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & + 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & + 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & + 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & + 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & + 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & + 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & + 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ + DO iseason = 1, dep_seasons + DO iland = 1, nlu + rclo(iland,iseason) = dat7(iland,iseason) + END DO + END DO + DO l = 1, numgas + hstar(l) = 0. + hstar4(l) = 0. + dhr(l) = 0. + f0(l) = 0. + dvj(l) = 99. + END DO + +! HENRY''S LAW COEFFICIENTS +! Effective Henry''s law coefficient at pH 7 +! [KH298]=mole/(l atm) + + hstar(p_no2) = 6.40E-3 + hstar(p_no) = 1.90E-3 + hstar(p_pan) = 2.97E+0 + hstar(p_o3) = 1.13E-2 + hstar(p_hcho) = 2.97E+3 + hstar(p_aco3) = 1.14E+1 + hstar(p_tpan) = 2.97E+0 + hstar(p_hono) = 3.47E+5 + hstar(p_no3) = 1.50E+1 + hstar(p_hno4) = 2.00E+13 + hstar(p_h2o2) = 7.45E+4 + hstar(p_co) = 8.20E-3 + hstar(p_ald) = 1.14E+1 + hstar(p_op1) = 2.21E+2 + hstar(p_op2) = 1.68E+6 + hstar(p_paa) = 4.73E+2 + hstar(p_ket) = 3.30E+1 + hstar(p_gly) = 1.40E+6 + hstar(p_mgly) = 3.71E+3 + hstar(p_dcb) = 1.40E+6 + hstar(p_onit) = 1.13E+0 + hstar(p_so2) = 2.53E+5 + hstar(p_eth) = 2.00E-3 + hstar(p_hc3) = 1.42E-3 + hstar(p_hc5) = 1.13E-3 + hstar(p_hc8) = 1.42E-3 + hstar(p_olt) = 4.76E-3 + hstar(p_oli) = 1.35E-3 + hstar(p_tol) = 1.51E-1 + hstar(p_csl) = 4.00E+5 + hstar(p_xyl) = 1.45E-1 + hstar(p_iso) = 4.76E-3 + hstar(p_hno3) = 2.69E+13 + hstar(p_ora1) = 9.85E+6 + hstar(p_ora2) = 9.63E+5 + hstar(p_nh3) = 1.04E+4 + hstar(p_n2o5) = 1.00E+10 + if(p_ol2.gt.1)hstar(p_ol2) = 4.67E-3 +! +! FOLLOWING FOR RACM +! + if(p_ete.gt.1)then + HSTAR(p_ETE )=4.67E-3 + HSTAR(p_API )=4.76E-3 + HSTAR(p_LIM )=4.76E-3 + HSTAR(p_DIEN)=4.76E-3 + HSTAR(p_CH4 )=1.50E-3 + HSTAR(p_CO2 )=1.86E-1 + HSTAR(p_MACR)=1.14E+1 + HSTAR(p_UDD )=1.40E+6 + HSTAR(p_HKET)=7.80E+3 + DHR(p_ETE )= 0. + DHR(p_API )= 0. + DHR(p_LIM )= 0. + DHR(p_DIEN)= 0. + DHR(p_CH4 )= 0. + DHR(p_CO2 )= 1636. + DHR(p_MACR)= 6266. + DHR(p_UDD )= 0. + DHR(p_HKET)= 0. + F0(p_ETE )=0. + F0(p_API )=0. + F0(p_LIM )=0. + F0(p_DIEN)=0. + F0(p_CH4 )=0. + F0(p_CO2 )=0. + F0(p_MACR)=0. + F0(p_UDD )=0. + F0(p_HKET)=0. + DVJ(p_ETE )=0.189 + DVJ(p_API )=0.086 + DVJ(p_LIM )=0.086 + DVJ(p_DIEN)=0.136 + DVJ(p_CH4 )=0.250 + DVJ(p_CO2 )=0.151 + DVJ(p_MACR)=0.120 + DVJ(p_UDD )=0.092 + DVJ(p_HKET)=0.116 + endif +! -DH/R (for temperature correction) +! [-DH/R]=K + + dhr(p_no2) = 2500. + dhr(p_no) = 1480. + dhr(p_pan) = 5760. + dhr(p_o3) = 2300. + dhr(p_hcho) = 7190. + dhr(p_aco3) = 6266. + dhr(p_tpan) = 5760. + dhr(p_hono) = 3775. + dhr(p_no3) = 0. + dhr(p_hno4) = 0. + dhr(p_h2o2) = 6615. + dhr(p_co) = 0. + dhr(p_ald) = 6266. + dhr(p_op1) = 5607. + dhr(p_op2) = 10240. + dhr(p_paa) = 6170. + dhr(p_ket) = 5773. + dhr(p_gly) = 0. + dhr(p_mgly) = 7541. + dhr(p_dcb) = 0. + dhr(p_onit) = 5487. + dhr(p_so2) = 5816. + dhr(p_eth) = 0. + dhr(p_hc3) = 0. + dhr(p_hc5) = 0. + dhr(p_hc8) = 0. + dhr(p_olt) = 0. + dhr(p_oli) = 0. + dhr(p_tol) = 0. + dhr(p_csl) = 0. + dhr(p_xyl) = 0. + dhr(p_iso) = 0. + dhr(p_hno3) = 8684. + dhr(p_ora1) = 5716. + dhr(p_ora2) = 8374. + dhr(p_nh3) = 3660. + dhr(p_n2o5) = 0. + if(p_ol2.gt.1)dhr(p_ol2) = 0. +! REACTIVITY FACTORS +! [f0]=1 + + f0(p_no2) = 0.1 + f0(p_no) = 0. + f0(p_pan) = 0.1 + f0(p_o3) = 1. + f0(p_hcho) = 0. + f0(p_aco3) = 1. + f0(p_tpan) = 0.1 + f0(p_hono) = 0.1 + f0(p_no3) = 1. + f0(p_hno4) = 0.1 + f0(p_h2o2) = 1. + f0(p_co) = 0. + f0(p_ald) = 0. + f0(p_op1) = 0.1 + f0(p_op2) = 0.1 + f0(p_paa) = 0.1 + f0(p_ket) = 0. + f0(p_gly) = 0. + f0(p_mgly) = 0. + f0(p_dcb) = 0. + f0(p_onit) = 0. + f0(p_so2) = 0. + f0(p_eth) = 0. + f0(p_hc3) = 0. + f0(p_hc5) = 0. + f0(p_hc8) = 0. + f0(p_olt) = 0. + f0(p_oli) = 0. + f0(p_tol) = 0. + f0(p_csl) = 0. + f0(p_xyl) = 0. + f0(p_iso) = 0. + f0(p_hno3) = 0. + f0(p_ora1) = 0. + f0(p_ora2) = 0. + f0(p_nh3) = 0. + f0(p_n2o5) = 1. + if(p_ol2.gt.1)f0(p_ol2) = 0. +! DIFFUSION COEFFICIENTS +! [DV]=cm2/s (assumed: 1/SQRT(molar mass) when not known) + + dvj(p_no2) = 0.147 + dvj(p_no) = 0.183 + dvj(p_pan) = 0.091 + dvj(p_o3) = 0.175 + dvj(p_hcho) = 0.183 + dvj(p_aco3) = 0.115 + dvj(p_tpan) = 0.082 + dvj(p_hono) = 0.153 + dvj(p_no3) = 0.127 + dvj(p_hno4) = 0.113 + dvj(p_h2o2) = 0.171 + dvj(p_co) = 0.189 + dvj(p_ald) = 0.151 + dvj(p_op1) = 0.144 + dvj(p_op2) = 0.127 + dvj(p_paa) = 0.115 + dvj(p_ket) = 0.118 + dvj(p_gly) = 0.131 + dvj(p_mgly) = 0.118 + dvj(p_dcb) = 0.107 + dvj(p_onit) = 0.092 + dvj(p_so2) = 0.126 + dvj(p_eth) = 0.183 + dvj(p_hc3) = 0.151 + dvj(p_hc5) = 0.118 + dvj(p_hc8) = 0.094 + dvj(p_olt) = 0.154 + dvj(p_oli) = 0.121 + dvj(p_tol) = 0.104 + dvj(p_csl) = 0.096 + dvj(p_xyl) = 0.097 + dvj(p_iso) = 0.121 + dvj(p_hno3) = 0.126 + dvj(p_ora1) = 0.153 + dvj(p_ora2) = 0.124 + dvj(p_nh3) = 0.227 + dvj(p_n2o5) = 0.110 + dvj(p_ho) = 0.243 + dvj(p_ho2) = 0.174 + if(p_ol2.gt.1)dvj(p_ol2) = 0.189 + DO l = 1, numgas + hstar4(l) = hstar(l) ! preliminary +! Correction of diff. coeff + dvj(l) = dvj(l)*(293.15/298.15)**1.75 + sc = 0.15/dvj(l) ! Schmidt Number at 20°C + dratio(l) = 0.242/dvj(l) ! ! of water vapor and gas at +! Ratio of diffusion coeffi + scpr23(l) = (sc/0.72)**(2./3.) ! (Schmidt # / Prandtl #)** + END DO + + + +! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF +! J. W. ERISMAN, A. VAN PUL AND P. WYERS +! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 + +! vd = (u* / k) * CORRECTION FACTORS + +! CONSTANT K FOR LANDUSE TYPES: +! urban and built-up land + kpart(1) = 500. +! dryland cropland and pasture + kpart(2) = 500. +! irrigated cropland and pasture + kpart(3) = 500. +! mixed dryland/irrigated cropland and past + kpart(4) = 500. +! cropland/grassland mosaic + kpart(5) = 500. +! cropland/woodland mosaic + kpart(6) = 100. +! grassland + kpart(7) = 500. +! shrubland + kpart(8) = 500. +! mixed shrubland/grassland + kpart(9) = 500. +! savanna + kpart(10) = 500. +! deciduous broadleaf forest + kpart(11) = 100. +! deciduous needleleaf forest + kpart(12) = 100. +! evergreen broadleaf forest + kpart(13) = 100. +! evergreen needleleaf forest + kpart(14) = 100. +! mixed forest + kpart(15) = 100. +! water bodies + kpart(16) = 500. +! herbaceous wetland + kpart(17) = 500. +! wooded wetland + kpart(18) = 500. +! barren or sparsely vegetated + kpart(19) = 500. +! herbaceous tundra + kpart(20) = 500. +! wooded tundra + kpart(21) = 100. +! mixed tundra + kpart(22) = 500. +! bare ground tundra + kpart(23) = 500. +! snow or ice + kpart(24) = 500. +! Comments: + kpart(25) = 500. +! Erisman et al. (1994) give +! k = 500 for low vegetation and k = 100 for forests. + +! For desert k = 500 is taken according to measurements +! on bare soil by +! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) +! Vertical Flux Measurements of the Submicronic Aerosol Particles +! and Parametrisation of the Dry Deposition Velocity +! in: Biosphere-Atmosphere Exchange of Pollutants +! and Trace Substances +! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 +! pp. 381-390 + +! For coniferous forest the Erisman value of k = 100 is taken. +! Measurements of Erisman et al. (1997) in a coniferous forest +! in the Netherlands, lead to values of k between 20 and 38 +! (Atmospheric Environment 31 (1997), 321-332). +! However, these high values of vd may be reached during +! instable cases. The eddy correlation measurements +! of Gallagher et al. (1997) made during the same experiment +! show for stable cases (L>0) values of k between 200 and 250 +! at minimum (Atmospheric Environment 31 (1997), 359-373). +! Fontan et al. (1997) found k = 250 in a forest +! of maritime pine in southwestern France. + +! For gras, model calculations of Davidson et al. support +! the value of 500. +! C. I. Davidson, J. M. Miller and M. A. Pleskov +! The Influence of Surface Structure on Predicted Particles +! Dry Deposition to Natural Gras Canopies +! Water, Air, and Soil Pollution 18 (1982) 25-43 + +! Snow covered surface: The experiment of Ibrahim et al. (1983) +! gives k = 436 for 0.7 um diameter particles. +! The deposition velocity of Milford and Davidson (1987) +! gives k = 154 for continental sulfate aerosol. +! M. Ibrahim, L. A. Barrie and F. Fanaki +! Atmospheric Environment 17 (1983), 781-788 + +! J. B. Milford and C. I. Davidson +! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere +! - A Review +! JAPCA 37 (1987), 125-134 +! no data +! WRITE (0,*) ' return from rcread ' +! ********************************************************* + +! Simplified landuse scheme for deposition and biogenic emission +! subroutines +! (ISWATER and ISICE are already defined elsewhere, +! therefore water and ice are not considered here) + +! 1 urban or bare soil +! 2 agricultural +! 3 grassland +! 4 deciduous forest +! 5 coniferous and mixed forest +! 6 other natural landuse categories + + + IF (mminlu=='OLD ') THEN + ixxxlu(1) = 1 + ixxxlu(2) = 2 + ixxxlu(3) = 3 + ixxxlu(4) = 4 + ixxxlu(5) = 5 + ixxxlu(6) = 5 + ixxxlu(7) = 0 + ixxxlu(8) = 6 + ixxxlu(9) = 1 + ixxxlu(10) = 6 + ixxxlu(11) = 0 + ixxxlu(12) = 4 + ixxxlu(13) = 6 + END IF + IF (mminlu=='USGS') THEN + ixxxlu(1) = 1 + ixxxlu(2) = 2 + ixxxlu(3) = 2 + ixxxlu(4) = 2 + ixxxlu(5) = 2 + ixxxlu(6) = 4 + ixxxlu(7) = 3 + ixxxlu(8) = 6 + ixxxlu(9) = 3 + ixxxlu(10) = 6 + ixxxlu(11) = 4 + ixxxlu(12) = 5 + ixxxlu(13) = 4 + ixxxlu(14) = 5 + ixxxlu(15) = 5 + ixxxlu(16) = 0 + ixxxlu(17) = 6 + ixxxlu(18) = 4 + ixxxlu(19) = 1 + ixxxlu(20) = 6 + ixxxlu(21) = 4 + ixxxlu(22) = 6 + ixxxlu(23) = 1 + ixxxlu(24) = 0 + ixxxlu(25) = 1 + END IF + IF (mminlu=='SiB ') THEN + ixxxlu(1) = 4 + ixxxlu(2) = 4 + ixxxlu(3) = 4 + ixxxlu(4) = 5 + ixxxlu(5) = 5 + ixxxlu(6) = 6 + ixxxlu(7) = 3 + ixxxlu(8) = 6 + ixxxlu(9) = 6 + ixxxlu(10) = 6 + ixxxlu(11) = 1 + ixxxlu(12) = 2 + ixxxlu(13) = 6 + ixxxlu(14) = 1 + ixxxlu(15) = 0 + ixxxlu(16) = 0 + ixxxlu(17) = 1 + END IF + RETURN + END SUBROUTINE dep_init + END MODULE module_dep_simple diff --git a/wrfv2_fire/chem/module_emissions_anthropogenics.F b/wrfv2_fire/chem/module_emissions_anthropogenics.F new file mode 100755 index 00000000..3e81b4ba --- /dev/null +++ b/wrfv2_fire/chem/module_emissions_anthropogenics.F @@ -0,0 +1,279 @@ +MODULE module_emissions_anthropogenics +!WRF:MODEL_LAYER:CHEMICS +! +CONTAINS +! +! currently this only adds in the emissions... +! this may be done differently for different chemical mechanisms +! in the future. aerosols are already added somewhere else.... +! + subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,chem, & + e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl, & + e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2, & + e_pm25,e_pm10,e_nh3, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_data_radm2 + IMPLICIT NONE + +! .. Parameters .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, INTENT(IN ) :: & + dtstep +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! emissions arrays +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: & + e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt,& + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_pm25,e_pm10,e_nh3 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: rho_phy + +! +! +! + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + dz8w + integer i,j,k + real :: conv_rho +!--- deposition and emissions stuff + + +! .. +! .. +! .. Intrinsic Functions .. + + call wrf_debug(15,'add_anhropogenics') +! +! add emissions +! + do 100 j=jts,jte + do 100 i=its,ite + + DO k=kts,min(config_flags%kemit,kte-1) + conv_rho=4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (i <= CHEM_DBG_I .and. i >= CHEM_DBG_I) .and. & + (j <= CHEM_DBG_J .and. j >= CHEM_DBG_J) .and. & + (k <= CHEM_DBG_K .and. k >= CHEM_DBG_K) ) then + print* + print*,"Converted emissions for RADM2:" + print*,"e_csl=",e_csl(i,k,j)*conv_rho + print*,"e_iso=",e_iso(i,k,j)*conv_rho + print*,"e_so2=",e_so2(i,k,j)*conv_rho + print*,"e_no=",e_no(i,k,j)*conv_rho + print*,"e_ald=",e_ald(i,k,j)*conv_rho + print*,"e_hcho=",e_hcho(i,k,j)*conv_rho + print*,"e_ora2=",e_ora2(i,k,j)*conv_rho + print*,"e_nh3=",e_nh3(i,k,j)*conv_rho + print*,"e_hc3=",e_hc3(i,k,j)*conv_rho + print*,"e_hc5=",e_hc5(i,k,j)*conv_rho + print*,"e_hc8=",e_hc8(i,k,j)*conv_rho + print*,"e_eth=",e_eth(i,k,j)*conv_rho + print*,"e_co=",e_co(i,k,j)*conv_rho + print*,"e_ol2=",e_ol2(i,k,j)*conv_rho + print*,"e_olt=",e_olt(i,k,j)*conv_rho + print*,"e_oli=",e_oli(i,k,j)*conv_rho + print*,"e_tol=",e_tol(i,k,j)*conv_rho + print*,"e_xyl=",e_xyl(i,k,j)*conv_rho + print*,"e_ket=",e_ket(i,k,j)*conv_rho + end if +#endif + + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +e_csl(i,k,j)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +e_iso(i,k,j)*conv_rho + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +e_so2(i,k,j)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +e_no(i,k,j)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +e_ald(i,k,j)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +e_hcho(i,k,j)*conv_rho + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +e_ora2(i,k,j)*conv_rho + chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) & + +e_nh3(i,k,j)*conv_rho + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +e_hc3(i,k,j)*conv_rho + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +e_hc5(i,k,j)*conv_rho + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +e_hc8(i,k,j)*conv_rho + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +e_eth(i,k,j)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +e_co(i,k,j)*conv_rho + if(p_ol2.gt.1)chem(i,k,j,p_ol2) = chem(i,k,j,p_ol2) & + +e_ol2(i,k,j)*conv_rho + if(p_ete.gt.1)chem(i,k,j,p_ete) = chem(i,k,j,p_ete) & + +e_ol2(i,k,j)*conv_rho + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +e_olt(i,k,j)*conv_rho + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +e_oli(i,k,j)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +e_tol(i,k,j)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +e_xyl(i,k,j)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +e_ket(i,k,j)*conv_rho + END DO + 100 continue + + END subroutine add_anthropogenics +! +! + subroutine add_biogenics(id,dtstep,dz8w,config_flags,rho_phy,chem, & + e_bio,ne_area, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + USE module_data_radm2 + USE module_aerosols_sorgam + IMPLICIT NONE + INTEGER, INTENT(IN ) :: id,ne_area, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, INTENT(IN ) :: & + dtstep + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, jms:jme,ne_area ), & + INTENT(IN ) :: & + e_bio + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no + +! +! +! + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + rho_phy,dz8w + integer i,j,k,n + real :: conv_rho +!--- deposition and emissions stuff +! .. Parameters .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags +! return + bioem_select: SELECT CASE(config_flags%bio_emiss_opt) + CASE (GUNTHER1) + CALL wrf_debug(15,'adding biogenic emissions: Gunther1') +! DO n = 1, numgas-2 + do 100 j=jts,jte + do 100 i=its,ite + conv_rho=dtstep/(dz8w(i,kts,j)*60.) + chem(i,kts,j,p_iso)=chem(i,kts,j,p_iso)+ & + e_bio(i,j,p_iso-1)*conv_rho + chem(i,kts,j,p_oli)=chem(i,kts,j,p_oli)+ & + e_bio(i,j,p_oli-1)*conv_rho + chem(i,kts,j,p_xyl)=chem(i,kts,j,p_xyl)+ & + e_bio(i,j,p_xyl-1)*conv_rho + chem(i,kts,j,p_hc3)=chem(i,kts,j,p_hc3)+ & + e_bio(i,j,p_hc3-1)*conv_rho + chem(i,kts,j,p_olt)=chem(i,kts,j,p_olt)+ & + e_bio(i,j,p_olt-1)*conv_rho + chem(i,kts,j,p_ket)=chem(i,kts,j,p_ket)+ & + e_bio(i,j,p_ket-1)*conv_rho + chem(i,kts,j,p_ald)=chem(i,kts,j,p_ald)+ & + e_bio(i,j,p_ald-1)*conv_rho + chem(i,kts,j,p_hcho)=chem(i,kts,j,p_hcho)+ & + e_bio(i,j,p_hcho-1)*conv_rho + chem(i,kts,j,p_eth)=chem(i,kts,j,p_eth)+ & + e_bio(i,j,p_eth-1)*conv_rho + chem(i,kts,j,p_ora2)=chem(i,kts,j,p_ora2)+ & + e_bio(i,j,p_ora2-1)*conv_rho + chem(i,kts,j,p_co)=chem(i,kts,j,p_co)+ & + e_bio(i,j,p_co-1)*conv_rho + chem(i,kts,j,p_no)=chem(i,kts,j,p_no)+ & + e_bio(i,j,p_no-1)*conv_rho +! +! RADM only +! + if(p_ol2.gt.1)chem(i,kts,j,p_ol2)=chem(i,kts,j,p_ol2)+ & + e_bio(i,j,p_ol2-1)*conv_rho + 100 continue +! enddo + CASE (BEIS311) + CALL wrf_debug(100,'adding biogenic emissions: beis3.1.1') + do j=jts,jte + do i=its,ite + conv_rho=4.828e-4/rho_phy(i,kts,j)*dtstep/(dz8w(i,kts,j)*60.) + chem(i,kts,j,p_iso)=chem(i,kts,j,p_iso)+ & + ebio_iso(i,j)*conv_rho + chem(i,kts,j,p_oli)=chem(i,kts,j,p_oli)+ & + ebio_oli(i,j)*conv_rho + chem(i,kts,j,p_xyl)=chem(i,kts,j,p_xyl)+ & + ebio_xyl(i,j)*conv_rho + chem(i,kts,j,p_hc3)=chem(i,kts,j,p_hc3)+ & + ebio_hc3(i,j)*conv_rho + chem(i,kts,j,p_olt)=chem(i,kts,j,p_olt)+ & + ebio_olt(i,j)*conv_rho + chem(i,kts,j,p_ket)=chem(i,kts,j,p_ket)+ & + ebio_ket(i,j)*conv_rho + chem(i,kts,j,p_ald)=chem(i,kts,j,p_ald)+ & + ebio_ald(i,j)*conv_rho + chem(i,kts,j,p_hcho)=chem(i,kts,j,p_hcho)+ & + ebio_hcho(i,j)*conv_rho + chem(i,kts,j,p_eth)=chem(i,kts,j,p_eth)+ & + ebio_eth(i,j)*conv_rho + chem(i,kts,j,p_ora2)=chem(i,kts,j,p_ora2)+ & + ebio_ora2(i,j)*conv_rho + chem(i,kts,j,p_co)=chem(i,kts,j,p_co)+ & + ebio_co(i,j)*conv_rho + chem(i,kts,j,p_no)=chem(i,kts,j,p_no)+ & + ebio_no(i,j)*conv_rho +! +! RADM only +! + if(p_ol2.gt.1)chem(i,kts,j,p_ol2)=chem(i,kts,j,p_ol2)+ & + ebio_ete(i,j)*conv_rho +! +! RACM only +! + if(p_api.gt.1)chem(i,kts,j,p_api)=chem(i,kts,j,p_api)+ & + ebio_api(i,j)*conv_rho + if(p_lim.gt.1)chem(i,kts,j,p_lim)=chem(i,kts,j,p_lim)+ & + ebio_lim(i,j)*conv_rho + if(p_ete.gt.1)chem(i,kts,j,p_ete)=chem(i,kts,j,p_ete)+ & + ebio_ete(i,j)*conv_rho + enddo + enddo + CASE DEFAULT + + END SELECT bioem_select + END subroutine add_biogenics + + +END MODULE module_emissions_anthropogenics diff --git a/wrfv2_fire/chem/module_fastj_data.F b/wrfv2_fire/chem/module_fastj_data.F new file mode 100755 index 00000000..2c7ca2c3 --- /dev/null +++ b/wrfv2_fire/chem/module_fastj_data.F @@ -0,0 +1,11964 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! Fast-J module: see module_phot_fastj.F for information and terms of use +!********************************************************************************** +! file module_fastj_jvcmn.f +! based on fastj include file jv_cmn.h +!----------------------------------------------------------------------- +! Parameters +! NB Number of levels in CTM plus one for above model top +! NC Number of levels in the fundamental Fast-J grid +! NS Maximum number of species which require J-values calculating +! NW Maximum number of wavelength bins that can be used +! NP Maximum number of aerosol/cloud types that can be used +! NH Maximum number of Herzberg X-sections that can be used +! MX Number of aerosol/cloud types supplied from CTM +!----------------------------------------------------------------------- + module module_fastj_data + +!jdf use module_fastj_cmnh, only: double, kmaxd, jppj + USE module_data_mosaic_other, only : kmaxd +!jdf + integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: jppj=14 !Number of photolytic reactions supplied +!jdf + + INTEGER NB, NC !values set in fastj_driver, don't confuse + !this nc with the one in module_fastj_mie + INTEGER, PARAMETER :: NS=15, NW=15, NP=21, NH=7, MX=3 + +!titls variables + CHARACTER*55 TITLE0(3) + CHARACTER*20 TITLEA(NP) + CHARACTER*7 TITLEJ(3,NS) +! atmos variables + REAL(kind=double), dimension(KMAXD+1) :: TJ, DM, DO3, DBC, Z + REAL(kind=double), dimension(KMAXD+2) :: PJ + REAL(kind=double), dimension(MX,KMAXD+1) :: AER + REAL(kind=double), dimension(KMAXD+1,KMAXD+1) :: AMF + REAL(kind=double) :: RAD,RFLECT,SZA,U0,TANHT,ZZHT +! ccwvl variables + REAL(kind=double), dimension(NW) :: WL, FL, QBC + REAL(kind=double), dimension(NW+1) :: WBIN, QRAYL + REAL(kind=double), dimension(NW,3) :: QO2, QO3, Q1D + REAL(kind=double), dimension(NW,2,NS-3) :: QQQ + REAL(kind=double), dimension(3,NS) :: TQQ + REAL(kind=double), dimension(4,NP) :: WAA, QAA, RAA, SSA + REAL(kind=double), dimension(8,4,NP) :: PAA + REAL(kind=double), dimension(NW, kmaxd) :: FFF + REAL(kind=double), dimension(NS) :: VALJ + INTEGER, dimension(MX) :: MIEDX + INTEGER :: NJVAL,NW1,NW2,NAA,NLBATM +! clim variables + REAL(kind=double), dimension(51,18,12) :: TREF, OREF + REAL(kind=double), dimension(51) :: BREF +! jcntr variables + REAL(kind=double) :: dtaumax,szamax +! jvals variables + REAL(kind=double), dimension(kmaxd,jppj) :: zj + REAL(kind=double), dimension(NW,3) :: zpdep + REAL(kind=double), dimension(jppj) :: jfacta + INTEGER, dimension(NS) :: jpdep + INTEGER, dimension(jppj) :: jind + INTEGER :: npdep + CHARACTER*7, dimension(jppj) :: jlabel +! jvsub variables + REAL(kind=double) :: dtausub,dsubdiv + INTEGER, dimension(2*(KMAXD+1)) :: jadsub + ! herz variables + REAL(kind=double) :: hzo2,hzo3 + REAL(kind=double), dimension(NH) :: hztoa + REAL(kind=double), dimension(kmaxd) :: fhz + INTEGER :: nhz + INTEGER, dimension(nh) :: hzind + CHARACTER*7, dimension(nh) :: hzlab + REAL(kind=double), dimension(nh) :: hztmp + +! data declarations +! from inphot2 + data RAD, ZZHT, dtaumax, dsubdiv & +!jdf / 0.6375D+09, 0.5000D+06, 0.1000D+01, 0.1000D+02/ +!jdf needed to reduce dsubdiv, otherwise too many vertical subdivisions for clouds +!wig doubled dtaumax to reduce instances when layer subdivision occurs + / 0.6375D+09, 0.5000D+06, 0.2000D+01, 0.2000D+01/ + data dtausub, szamax & + / 0.1000D+01, 0.9800D+02/ + +! from set_aer2 + data MIEDX & + / & + 15, 10, 14 & + / + data BREF & + / & + 0.1000D-09, 0.1000D-09, 0.1000D-09, 0.1000D-09, & + 0.1000D-09, 0.1000D-09, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + +! from rd_js2 + data jfacta & + / & + 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01 & + / + data jlabel & + / & + 'NO2 ', 'O3 ', 'O3_1d ', & + 'H2O2 ', 'HCHO_a ', 'HCHO_b ', & + 'MeOOH ', 'NO3_X ', 'NO3_L ', & + 'HONO ', 'N2O5 ', 'HONO2 ', & + 'HO2NO2 ', 'C2H5O2 ' & + / + +! from rd_tjpl2 + data TITLE0(1) & + / & + ' jv_spec.dat FAST J-code for Troposphere std J' & + / + data NJVAL,NWWW,NW1,NW2 & + / & + 15, 7, 1, 7 & + / + data (WBIN(IW),IW=1, 8) & + / & + 289.00, 298.25, 307.45, 312.45, & + 320.30, 345.00, 412.45, 850.00 & + / + data (WL(IW),IW=1, 7) & + / & + 294., 303., 310., 316., & + 333., 380., 574. & + / + data (FL(IW),IW=1, 7) & + / & + 0.7352E+15, 0.7332E+15, 0.5022E+15, 0.8709E+15, & + 0.3786E+16, 0.1544E+17, 0.2110E+18 & + / + data (QRAYL(IW),IW=1, 7) & + / & + 0.618E-25, 0.543E-25, 0.492E-25, 0.454E-25, & + 0.363E-25, 0.209E-25, 0.383E-26 & + / + data (QBC(IW),IW=1, 7) & + / & + 10.08, 9.96, 9.87, 9.79, & + 9.58, 9.00, 6.50 & + / + data (TITLEJ(KTMP,1), KTMP=1,3) & + / & + 'O2 ', 'O2 ', 'O2 ' & + / + data (TITLEJ(KTMP,2), KTMP=1,3) & + / & + 'O3 ', 'O3 ', 'O3 ' & + / + data (TITLEJ(KTMP,3), KTMP=1,3) & + / & + 'O3_1d ', 'O3_1d ', 'O3_1d ' & + / + data (TQQ(KTMP,1), KTMP=1,3) & + / & + 180., 260., 300. & + / + data (TQQ(KTMP,2), KTMP=1,3) & + / & + 180., 260., 300. & + / + data (TQQ(KTMP,3), KTMP=1,3) & + / & + 180., 260., 300. & + / + data (QO2(IW, 1), IW=1, 7) & + / & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00 & + / + data (QO2(IW, 2), IW=1, 7) & + / & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00 & + / + data (QO2(IW, 3), IW=1, 7) & + / & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00 & + / + data (QO3(IW, 1), IW=1, 7) & + / & + 0.8693E-18, 0.2365E-18, 0.8722E-19, & + 0.3694E-19, 0.4295E-20, 0.1804E-22, & + 0.1630E-20 & + / + data (QO3(IW, 2), IW=1, 7) & + / & + 0.9189E-18, 0.2571E-18, 0.9673E-19, & + 0.4141E-19, 0.5457E-20, 0.2775E-22, & + 0.1630E-20 & + / + data (QO3(IW, 3), IW=1, 7) & + / & + 0.9574E-18, 0.2777E-18, 0.1075E-18, & + 0.4725E-19, 0.6782E-20, 0.4824E-22, & + 0.1630E-20 & + / + data (Q1D(IW, 1), IW=1, 7) & + / & + 0.9500E+00, 0.9330E+00, 0.4270E+00, & + 0.6930E-01, 0.6060E-01, 0.0000E+00, & + 0.0000E+00 & + / + data (Q1D(IW, 2), IW=1, 7) & + / & + 0.9500E+00, 0.9420E+00, 0.4890E+00, & + 0.1360E+00, 0.7110E-01, 0.0000E+00, & + 0.0000E+00 & + / + data (Q1D(IW, 3), IW=1, 7) & + / & + 0.9500E+00, 0.9550E+00, 0.5870E+00, & + 0.2370E+00, 0.8570E-01, 0.0000E+00, & + 0.0000E+00 & + / + data (TITLEJ(1,JTMP), JTMP=4,15) & + / & + 'H2O2 ', 'HCHO_a ', 'HCHO_b ', 'MeOOH ', & + 'NO2 ', 'NO3_X ', 'NO3_L ', 'N2O5 ', & + 'HONO ', 'HONO2 ', 'HO2NO2 ', 'C2H5O2 ' & + / + data (TITLEJ(2,JTMP), JTMP=4,15) & + / & + 'H2O2 ', 'HCHO_a ', 'HCHO_b ', 'MeOOH ', & + 'NO2 ', 'NO3_X ', 'NO3_L ', 'N2O5 ', & + 'HONO ', 'HONO2 ', 'HO2NO2 ', 'C2H5O2 ' & + / + data (TQQ(1,JTMP), JTMP= 4,15) & + / & + 200., 223., 223., 200., & + 200., 200., 200., 225., & + 200., 200., 200., 200. & + / + data (TQQ(2,JTMP), JTMP= 4,15) & + / & + 300., 293., 293., 300., & + 300., 300., 300., 300., & + 300., 300., 300., 300. & + / + data (QQQ(IW,1, 1), IW=1, 7) & + / & + 0.88510E-20, 0.50080E-20, 0.32150E-20, 0.21160E-20, & + 0.80100E-21, 0.20880E-22, 0.00000E+00 & + / + data (QQQ(IW,1, 2), IW=1, 7) & + / & + 0.00000E+00, 0.19420E-19, 0.12740E-19, 0.19710E-19, & + 0.43550E-20, 0.50740E-25, 0.00000E+00 & + / + data (QQQ(IW,1, 3), IW=1, 7) & + / & + 0.00000E+00, 0.63870E-20, 0.43920E-20, 0.90270E-20, & + 0.10410E-19, 0.19490E-21, 0.00000E+00 & + / + data (QQQ(IW,1, 4), IW=1, 7) & + / & + 0.58830E-20, 0.35730E-20, 0.24370E-20, 0.17560E-20, & + 0.74280E-21, 0.42360E-22, 0.00000E+00 & + / + data (QQQ(IW,1, 5), IW=1, 7) & + / & + 0.10480E-18, 0.14940E-18, 0.18980E-18, 0.22950E-18, & + 0.33910E-18, 0.42300E-18, 0.40470E-21 & + / + data (QQQ(IW,1, 6), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.74310E-18 & + / + data (QQQ(IW,1, 7), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.95730E-19 & + / + data (QQQ(IW,1, 8), IW=1, 7) & + / & + 0.41300E-19, 0.19980E-19, 0.11670E-19, 0.72500E-20, & + 0.22960E-20, 0.11630E-21, 0.00000E+00 & + / + data (QQQ(IW,1, 9), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.12000E-19, 0.34690E-19, & + 0.10900E-18, 0.86450E-19, 0.00000E+00 & + / + data (QQQ(IW,1,10), IW=1, 7) & + / & + 0.37060E-20, 0.13770E-20, 0.54510E-21, 0.21020E-21, & + 0.21540E-22, 0.87680E-25, 0.00000E+00 & + / + data (QQQ(IW,1,11), IW=1, 7) & + / & + 0.28690E-19, 0.11020E-19, 0.52220E-20, 0.27940E-20, & + 0.23010E-21, 0.00000E+00, 0.00000E+00 & + / + data (QQQ(IW,1,12), IW=1, 7) & + / & + 0.47500E-18, 0.12130E-19, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.00000E+00 & + / + data (QQQ(IW,2, 1), IW=1, 7) & + / & + 0.98180E-20, 0.57350E-20, 0.37970E-20, 0.25850E-20, & + 0.10490E-20, 0.26990E-22, 0.00000E+00 & + / + data (QQQ(IW,2, 2), IW=1, 7) & + / & + 0.00000E+00, 0.18470E-19, 0.13040E-19, 0.18960E-19, & + 0.39490E-20, 0.44400E-25, 0.00000E+00 & + / + data (QQQ(IW,2, 3), IW=1, 7) & + / & + 0.00000E+00, 0.60770E-20, 0.45000E-20, 0.87150E-20, & + 0.94340E-20, 0.18920E-21, 0.00000E+00 & + / + data (QQQ(IW,2, 4), IW=1, 7) & + / & + 0.58830E-20, 0.35730E-20, 0.24370E-20, 0.17560E-20, & + 0.74280E-21, 0.42360E-22, 0.00000E+00 & + / + data (QQQ(IW,2, 5), IW=1, 7) & + / & + 0.10390E-18, 0.14620E-18, 0.18450E-18, 0.22230E-18, & + 0.32560E-18, 0.41500E-18, 0.40200E-21 & + / + data (QQQ(IW,2, 6), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.74310E-18 & + / + data (QQQ(IW,2, 7), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.95730E-19 & + / + data (QQQ(IW,2, 8), IW=1, 7) & + / & + 0.57180E-19, 0.33170E-19, 0.22230E-19, 0.15520E-19, & + 0.64090E-20, 0.54290E-21, 0.00000E+00 & + / + data (QQQ(IW,2, 9), IW=1, 7) & + / & + 0.00000E+00, 0.00000E+00, 0.12000E-19, 0.34690E-19, & + 0.10900E-18, 0.86450E-19, 0.00000E+00 & + / + data (QQQ(IW,2,10), IW=1, 7) & + / & + 0.47470E-20, 0.19230E-20, 0.83140E-21, 0.35890E-21, & + 0.47640E-22, 0.26670E-24, 0.00000E+00 & + / + data (QQQ(IW,2,11), IW=1, 7) & + / & + 0.28690E-19, 0.11020E-19, 0.52220E-20, 0.27940E-20, & + 0.23010E-21, 0.00000E+00, 0.00000E+00 & + / + data (QQQ(IW,2,12), IW=1, 7) & + / & + 0.47500E-18, 0.12130E-19, 0.00000E+00, 0.00000E+00, & + 0.00000E+00, 0.00000E+00, 0.00000E+00 & + / + data TITLE0(2) & + / & + ' =============================================' & + / + data TITLE0(3) & + / & + ' NW-SCATTER ' & + / + data NAA & + / & + 21 & + / + data (TITLEA(jtmp), jtmp=1, 21) & + / & + 'RAYLE = Rayleigh ph', 'ISOTR = isotropic ', & + 'ABSRB = fully absor', 'S_Bkg = backgrnd str', & + 'S_Vol = volcanic str', 'W_H01 = water haze (', & + 'W_H04 = water haze (', 'W_C02 = water cloud ', & + 'W_C04 = water cloud ', 'W_C08 = water cloud ', & + 'W_C13 = water cloud ', 'W_L06 = water cloud ', & + 'Ice-H = hexagonal ic', 'Ice-I = irregular ic', & + 'Mdust 0.15 = mineral', 'Mdust 0.25 = mineral', & + 'Mdust 0.4 = mineral ', 'Mdust 0.8 = mineral ', & + 'Mdust 1.5 = mineral ', 'Mdust 2.5 = mineral ', & + 'Mdust 4.0 = mineral ' & + / + data ((WAA(ktmp,jtmp), ktmp=1, 4), jtmp=1,21) & + / & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03, & + 0.3000D+03, 0.4000D+03, 0.6000D+03, 0.9990D+03 & + / + data ((QAA(ktmp,jtmp), ktmp=1, 4), jtmp=1,21) & + / & + 0.1235D+03, 0.3910D+02, 0.7700D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.2754D+01, 0.2402D+01, 0.1645D+01, 0.7449D+00, & + 0.2644D+01, 0.2560D+01, 0.2222D+01, 0.1532D+01, & + 0.2844D+01, 0.2350D+01, 0.1404D+01, 0.5034D+00, & + 0.2300D+01, 0.2474D+01, 0.2672D+01, 0.2957D+01, & + 0.2141D+01, 0.2178D+01, 0.2229D+01, 0.2307D+01, & + 0.2083D+01, 0.2106D+01, 0.2135D+01, 0.2192D+01, & + 0.2054D+01, 0.2064D+01, 0.2088D+01, 0.2124D+01, & + 0.2044D+01, 0.2053D+01, 0.2072D+01, 0.2098D+01, & + 0.2062D+01, 0.2075D+01, 0.2100D+01, 0.2142D+01, & + 0.2000D+01, 0.2000D+01, 0.2000D+01, 0.2000D+01, & + 0.2000D+01, 0.2000D+01, 0.2000D+01, 0.2000D+01, & + 0.3004D+01, 0.2476D+01, 0.1277D+01, 0.3595D+00, & + 0.2941D+01, 0.3105D+01, 0.2614D+01, 0.1243D+01, & + 0.2607D+01, 0.2824D+01, 0.3116D+01, 0.2477D+01, & + 0.2346D+01, 0.2434D+01, 0.2642D+01, 0.3040D+01, & + 0.2223D+01, 0.2273D+01, 0.2371D+01, 0.2575D+01, & + 0.2158D+01, 0.2192D+01, 0.2256D+01, 0.2372D+01, & + 0.2115D+01, 0.2140D+01, 0.2185D+01, 0.2264D+01 & + / + data ((RAA(ktmp,jtmp), ktmp=1, 4), jtmp=1,21) & + / & + 0.1000D-02, 0.1000D-02, 0.1000D-02, 0.1000D-02, & + 0.1000D-02, 0.1000D-02, 0.1000D-02, 0.1000D-02, & + 0.1000D-02, 0.1000D-02, 0.1000D-02, 0.1000D-02, & + 0.2210D+00, 0.2210D+00, 0.2210D+00, 0.2210D+00, & + 0.3860D+00, 0.3860D+00, 0.3860D+00, 0.3860D+00, & + 0.2500D+00, 0.2500D+00, 0.2500D+00, 0.2500D+00, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.3000D+01, 0.3000D+01, 0.3000D+01, 0.3000D+01, & + 0.6000D+01, 0.6000D+01, 0.6000D+01, 0.6000D+01, & + 0.1200D+02, 0.1200D+02, 0.1200D+02, 0.1200D+02, & + 0.2000D+02, 0.2000D+02, 0.2000D+02, 0.2000D+02, & + 0.1000D+02, 0.1000D+02, 0.1000D+02, 0.1000D+02, & + 0.6700D+02, 0.6700D+02, 0.6700D+02, 0.6700D+02, & + 0.5000D+02, 0.5000D+02, 0.5000D+02, 0.5000D+02, & + 0.1500D+00, 0.1500D+00, 0.1500D+00, 0.1500D+00, & + 0.2500D+00, 0.2500D+00, 0.2500D+00, 0.2500D+00, & + 0.4000D+00, 0.4000D+00, 0.4000D+00, 0.4000D+00, & + 0.8000D+00, 0.8000D+00, 0.8000D+00, 0.8000D+00, & + 0.1500D+01, 0.1500D+01, 0.1500D+01, 0.1500D+01, & + 0.2500D+01, 0.2500D+01, 0.2500D+01, 0.2500D+01, & + 0.4000D+01, 0.4000D+01, 0.4000D+01, 0.4000D+01 & + / + data ((SSA(ktmp,jtmp), ktmp=1, 4), jtmp=1,21) & + / & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.1000D+01, 0.1000D+01, 0.1000D+01, 0.1000D+01, & + 0.8840D+00, 0.9370D+00, 0.9790D+00, 0.9580D+00, & + 0.8200D+00, 0.9130D+00, 0.9800D+00, 0.9740D+00, & + 0.7390D+00, 0.8600D+00, 0.9710D+00, 0.9750D+00, & + 0.6400D+00, 0.7630D+00, 0.9360D+00, 0.9570D+00, & + 0.5790D+00, 0.6760D+00, 0.8900D+00, 0.9130D+00, & + 0.5560D+00, 0.6160D+00, 0.8420D+00, 0.8690D+00, & + 0.5500D+00, 0.5770D+00, 0.7860D+00, 0.8190D+00 & + / + data (PAA(itmp, 1, 1),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.5000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 2, 1),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.5000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 3, 1),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.5000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 4, 1),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.5000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 1, 2),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 2, 2),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 3, 2),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 4, 2),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 1, 3),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 2, 3),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 3, 3),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 4, 3),itmp=1,8) & + / & + 0.1000D+01, 0.0000D+00, 0.0000D+00, 0.0000D+00, & + 0.0000D+00, 0.0000D+00, 0.0000D+00, 0.0000D+00 & + / + data (PAA(itmp, 1, 4),itmp=1,8) & + / & + 0.1000D+01, 0.2157D+01, 0.2767D+01, 0.2627D+01, & + 0.2457D+01, 0.2098D+01, 0.1792D+01, 0.1518D+01 & + / + data (PAA(itmp, 2, 4),itmp=1,8) & + / & + 0.1000D+01, 0.2146D+01, 0.2641D+01, 0.2422D+01, & + 0.2122D+01, 0.1709D+01, 0.1357D+01, 0.1070D+01 & + / + data (PAA(itmp, 3, 4),itmp=1,8) & + / & + 0.1000D+01, 0.2076D+01, 0.2377D+01, 0.2023D+01, & + 0.1608D+01, 0.1177D+01, 0.8460D+00, 0.5990D+00 & + / + data (PAA(itmp, 4, 4),itmp=1,8) & + / & + 0.1000D+01, 0.1877D+01, 0.1920D+01, 0.1412D+01, & + 0.9700D+00, 0.6140D+00, 0.3880D+00, 0.2380D+00 & + / + data (PAA(itmp, 1, 5),itmp=1,8) & + / & + 0.1000D+01, 0.2152D+01, 0.2901D+01, 0.2856D+01, & + 0.2971D+01, 0.2772D+01, 0.2709D+01, 0.2587D+01 & + / + data (PAA(itmp, 2, 5),itmp=1,8) & + / & + 0.1000D+01, 0.2142D+01, 0.2810D+01, 0.2706D+01, & + 0.2691D+01, 0.2421D+01, 0.2254D+01, 0.2066D+01 & + / + data (PAA(itmp, 3, 5),itmp=1,8) & + / & + 0.1000D+01, 0.2127D+01, 0.2673D+01, 0.2488D+01, & + 0.2308D+01, 0.1963D+01, 0.1698D+01, 0.1461D+01 & + / + data (PAA(itmp, 4, 5),itmp=1,8) & + / & + 0.1000D+01, 0.2076D+01, 0.2458D+01, 0.2165D+01, & + 0.1841D+01, 0.1449D+01, 0.1142D+01, 0.8980D+00 & + / + data (PAA(itmp, 1, 6),itmp=1,8) & + / & + 0.1000D+01, 0.2454D+01, 0.3376D+01, 0.3624D+01, & + 0.3608D+01, 0.3300D+01, 0.2911D+01, 0.2526D+01 & + / + data (PAA(itmp, 2, 6),itmp=1,8) & + / & + 0.1000D+01, 0.2431D+01, 0.3235D+01, 0.3355D+01, & + 0.3108D+01, 0.2686D+01, 0.2180D+01, 0.1690D+01 & + / + data (PAA(itmp, 3, 6),itmp=1,8) & + / & + 0.1000D+01, 0.2328D+01, 0.2789D+01, 0.2593D+01, & + 0.2062D+01, 0.1492D+01, 0.1013D+01, 0.6320D+00 & + / + data (PAA(itmp, 4, 6),itmp=1,8) & + / & + 0.1000D+01, 0.1916D+01, 0.1870D+01, 0.1233D+01, & + 0.7040D+00, 0.3380D+00, 0.1540D+00, 0.6200D-01 & + / + data (PAA(itmp, 1, 7),itmp=1,8) & + / & + 0.1000D+01, 0.2433D+01, 0.3625D+01, 0.4104D+01, & + 0.4645D+01, 0.5020D+01, 0.5409D+01, 0.5802D+01 & + / + data (PAA(itmp, 2, 7),itmp=1,8) & + / & + 0.1000D+01, 0.2341D+01, 0.3475D+01, 0.3863D+01, & + 0.4330D+01, 0.4589D+01, 0.4878D+01, 0.5125D+01 & + / + data (PAA(itmp, 3, 7),itmp=1,8) & + / & + 0.1000D+01, 0.2325D+01, 0.3334D+01, 0.3624D+01, & + 0.3896D+01, 0.3939D+01, 0.3968D+01, 0.3964D+01 & + / + data (PAA(itmp, 4, 7),itmp=1,8) & + / & + 0.1000D+01, 0.2434D+01, 0.3393D+01, 0.3685D+01, & + 0.3709D+01, 0.3528D+01, 0.3213D+01, 0.2903D+01 & + / + data (PAA(itmp, 1, 8),itmp=1,8) & + / & + 0.1000D+01, 0.2544D+01, 0.3886D+01, 0.4572D+01, & + 0.5256D+01, 0.5933D+01, 0.6530D+01, 0.7291D+01 & + / + data (PAA(itmp, 2, 8),itmp=1,8) & + / & + 0.1000D+01, 0.2513D+01, 0.3834D+01, 0.4480D+01, & + 0.5160D+01, 0.5785D+01, 0.6356D+01, 0.7044D+01 & + / + data (PAA(itmp, 3, 8),itmp=1,8) & + / & + 0.1000D+01, 0.2483D+01, 0.3767D+01, 0.4359D+01, & + 0.4998D+01, 0.5542D+01, 0.6054D+01, 0.6639D+01 & + / + data (PAA(itmp, 4, 8),itmp=1,8) & + / & + 0.1000D+01, 0.2395D+01, 0.3597D+01, 0.4063D+01, & + 0.4648D+01, 0.5052D+01, 0.5478D+01, 0.5857D+01 & + / + data (PAA(itmp, 1, 9),itmp=1,8) & + / & + 0.1000D+01, 0.2596D+01, 0.3973D+01, 0.4725D+01, & + 0.5406D+01, 0.6129D+01, 0.6751D+01, 0.7607D+01 & + / + data (PAA(itmp, 2, 9),itmp=1,8) & + / & + 0.1000D+01, 0.2571D+01, 0.3936D+01, 0.4660D+01, & + 0.5345D+01, 0.6056D+01, 0.6670D+01, 0.7492D+01 & + / + data (PAA(itmp, 3, 9),itmp=1,8) & + / & + 0.1000D+01, 0.2557D+01, 0.3902D+01, 0.4596D+01, & + 0.5263D+01, 0.5923D+01, 0.6507D+01, 0.7267D+01 & + / + data (PAA(itmp, 4, 9),itmp=1,8) & + / & + 0.1000D+01, 0.2499D+01, 0.3799D+01, 0.4418D+01, & + 0.5081D+01, 0.5667D+01, 0.6213D+01, 0.6851D+01 & + / + data (PAA(itmp, 1, 10),itmp=1,8) & + / & + 0.1000D+01, 0.2619D+01, 0.4013D+01, 0.4798D+01, & + 0.5476D+01, 0.6232D+01, 0.6870D+01, 0.7780D+01 & + / + data (PAA(itmp, 2, 10),itmp=1,8) & + / & + 0.1000D+01, 0.2611D+01, 0.3999D+01, 0.4773D+01, & + 0.5451D+01, 0.6194D+01, 0.6826D+01, 0.7716D+01 & + / + data (PAA(itmp, 3, 10),itmp=1,8) & + / & + 0.1000D+01, 0.2589D+01, 0.3965D+01, 0.4712D+01, & + 0.5394D+01, 0.6121D+01, 0.6744D+01, 0.7599D+01 & + / + data (PAA(itmp, 4, 10),itmp=1,8) & + / & + 0.1000D+01, 0.2563D+01, 0.3917D+01, 0.4625D+01, & + 0.5302D+01, 0.5992D+01, 0.6593D+01, 0.7385D+01 & + / + data (PAA(itmp, 1, 11),itmp=1,8) & + / & + 0.1000D+01, 0.2627D+01, 0.4026D+01, 0.4822D+01, & + 0.5499D+01, 0.6264D+01, 0.6907D+01, 0.7833D+01 & + / + data (PAA(itmp, 2, 11),itmp=1,8) & + / & + 0.1000D+01, 0.2620D+01, 0.4014D+01, 0.4800D+01, & + 0.5477D+01, 0.6234D+01, 0.6872D+01, 0.7783D+01 & + / + data (PAA(itmp, 3, 11),itmp=1,8) & + / & + 0.1000D+01, 0.2604D+01, 0.3990D+01, 0.4755D+01, & + 0.5435D+01, 0.6178D+01, 0.6807D+01, 0.7690D+01 & + / + data (PAA(itmp, 4, 11),itmp=1,8) & + / & + 0.1000D+01, 0.2585D+01, 0.3955D+01, 0.4691D+01, & + 0.5368D+01, 0.6077D+01, 0.6688D+01, 0.7520D+01 & + / + data (PAA(itmp, 1, 12),itmp=1,8) & + / & + 0.1000D+01, 0.2613D+01, 0.4002D+01, 0.4779D+01, & + 0.5458D+01, 0.6205D+01, 0.6839D+01, 0.7735D+01 & + / + data (PAA(itmp, 2, 12),itmp=1,8) & + / & + 0.1000D+01, 0.2601D+01, 0.3984D+01, 0.4745D+01, & + 0.5425D+01, 0.6158D+01, 0.6785D+01, 0.7657D+01 & + / + data (PAA(itmp, 3, 12),itmp=1,8) & + / & + 0.1000D+01, 0.2580D+01, 0.3947D+01, 0.4679D+01, & + 0.5359D+01, 0.6070D+01, 0.6684D+01, 0.7514D+01 & + / + data (PAA(itmp, 4, 12),itmp=1,8) & + / & + 0.1000D+01, 0.2545D+01, 0.3884D+01, 0.4568D+01, & + 0.5244D+01, 0.5909D+01, 0.6496D+01, 0.7250D+01 & + / + data (PAA(itmp, 1, 13),itmp=1,8) & + / & + 0.1000D+01, 0.2435D+01, 0.3712D+01, 0.4756D+01, & + 0.5960D+01, 0.6908D+01, 0.7865D+01, 0.8954D+01 & + / + data (PAA(itmp, 2, 13),itmp=1,8) & + / & + 0.1000D+01, 0.2435D+01, 0.3712D+01, 0.4756D+01, & + 0.5960D+01, 0.6908D+01, 0.7865D+01, 0.8954D+01 & + / + data (PAA(itmp, 3, 13),itmp=1,8) & + / & + 0.1000D+01, 0.2435D+01, 0.3712D+01, 0.4756D+01, & + 0.5960D+01, 0.6908D+01, 0.7865D+01, 0.8954D+01 & + / + data (PAA(itmp, 4, 13),itmp=1,8) & + / & + 0.1000D+01, 0.2435D+01, 0.3712D+01, 0.4756D+01, & + 0.5960D+01, 0.6908D+01, 0.7865D+01, 0.8954D+01 & + / + data (PAA(itmp, 1, 14),itmp=1,8) & + / & + 0.1000D+01, 0.2257D+01, 0.3164D+01, 0.4096D+01, & + 0.5088D+01, 0.6018D+01, 0.6897D+01, 0.7794D+01 & + / + data (PAA(itmp, 2, 14),itmp=1,8) & + / & + 0.1000D+01, 0.2257D+01, 0.3164D+01, 0.4096D+01, & + 0.5088D+01, 0.6018D+01, 0.6897D+01, 0.7794D+01 & + / + data (PAA(itmp, 3, 14),itmp=1,8) & + / & + 0.1000D+01, 0.2257D+01, 0.3164D+01, 0.4096D+01, & + 0.5088D+01, 0.6018D+01, 0.6897D+01, 0.7794D+01 & + / + data (PAA(itmp, 4, 14),itmp=1,8) & + / & + 0.1000D+01, 0.2257D+01, 0.3164D+01, 0.4096D+01, & + 0.5088D+01, 0.6018D+01, 0.6897D+01, 0.7794D+01 & + / + data (PAA(itmp, 1, 15),itmp=1,8) & + / & + 0.1000D+01, 0.2030D+01, 0.2363D+01, 0.2082D+01, & + 0.1710D+01, 0.1290D+01, 0.9410D+00, 0.6380D+00 & + / + data (PAA(itmp, 2, 15),itmp=1,8) & + / & + 0.1000D+01, 0.1988D+01, 0.2151D+01, 0.1735D+01, & + 0.1248D+01, 0.8090D+00, 0.5030D+00, 0.2790D+00 & + / + data (PAA(itmp, 3, 15),itmp=1,8) & + / & + 0.1000D+01, 0.1816D+01, 0.1675D+01, 0.1075D+01, & + 0.6040D+00, 0.2810D+00, 0.1320D+00, 0.4900D-01 & + / + data (PAA(itmp, 4, 15),itmp=1,8) & + / & + 0.1000D+01, 0.1320D+01, 0.9940D+00, 0.3770D+00, & + 0.1260D+00, 0.3100D-01, 0.8000D-02, 0.1000D-02 & + / + data (PAA(itmp, 1, 16),itmp=1,8) & + / & + 0.1000D+01, 0.2046D+01, 0.2643D+01, 0.2593D+01, & + 0.2634D+01, 0.2406D+01, 0.2244D+01, 0.1944D+01 & + / + data (PAA(itmp, 2, 16),itmp=1,8) & + / & + 0.1000D+01, 0.2021D+01, 0.2486D+01, 0.2264D+01, & + 0.2047D+01, 0.1671D+01, 0.1362D+01, 0.1039D+01 & + / + data (PAA(itmp, 3, 16),itmp=1,8) & + / & + 0.1000D+01, 0.2026D+01, 0.2296D+01, 0.1926D+01, & + 0.1470D+01, 0.1013D+01, 0.6680D+00, 0.4030D+00 & + / + data (PAA(itmp, 4, 16),itmp=1,8) & + / & + 0.1000D+01, 0.1824D+01, 0.1689D+01, 0.1087D+01, & + 0.6110D+00, 0.2860D+00, 0.1340D+00, 0.5000D-01 & + / + data (PAA(itmp, 1, 17),itmp=1,8) & + / & + 0.1000D+01, 0.2192D+01, 0.3070D+01, 0.3393D+01, & + 0.3903D+01, 0.4021D+01, 0.4248D+01, 0.4168D+01 & + / + data (PAA(itmp, 2, 17),itmp=1,8) & + / & + 0.1000D+01, 0.2027D+01, 0.2711D+01, 0.2679D+01, & + 0.2900D+01, 0.2734D+01, 0.2723D+01, 0.2478D+01 & + / + data (PAA(itmp, 3, 17),itmp=1,8) & + / & + 0.1000D+01, 0.2017D+01, 0.2537D+01, 0.2306D+01, & + 0.2136D+01, 0.1761D+01, 0.1466D+01, 0.1151D+01 & + / + data (PAA(itmp, 4, 17),itmp=1,8) & + / & + 0.1000D+01, 0.2036D+01, 0.2286D+01, 0.1903D+01, & + 0.1428D+01, 0.9660D+00, 0.6230D+00, 0.3680D+00 & + / + data (PAA(itmp, 1, 18),itmp=1,8) & + / & + 0.1000D+01, 0.2517D+01, 0.3780D+01, 0.4729D+01, & + 0.5755D+01, 0.6524D+01, 0.7339D+01, 0.7903D+01 & + / + data (PAA(itmp, 2, 18),itmp=1,8) & + / & + 0.1000D+01, 0.2295D+01, 0.3320D+01, 0.3800D+01, & + 0.4578D+01, 0.4913D+01, 0.5482D+01, 0.5662D+01 & + / + data (PAA(itmp, 3, 18),itmp=1,8) & + / & + 0.1000D+01, 0.2023D+01, 0.2830D+01, 0.2805D+01, & + 0.3279D+01, 0.3178D+01, 0.3418D+01, 0.3275D+01 & + / + data (PAA(itmp, 4, 18),itmp=1,8) & + / & + 0.1000D+01, 0.2019D+01, 0.2618D+01, 0.2441D+01, & + 0.2414D+01, 0.2106D+01, 0.1895D+01, 0.1610D+01 & + / + data (PAA(itmp, 1, 19),itmp=1,8) & + / & + 0.1000D+01, 0.2705D+01, 0.4250D+01, 0.5641D+01, & + 0.7023D+01, 0.8293D+01, 0.9539D+01, 0.1066D+02 & + / + data (PAA(itmp, 2, 19),itmp=1,8) & + / & + 0.1000D+01, 0.2539D+01, 0.3821D+01, 0.4771D+01, & + 0.5881D+01, 0.6738D+01, 0.7733D+01, 0.8463D+01 & + / + data (PAA(itmp, 3, 19),itmp=1,8) & + / & + 0.1000D+01, 0.2240D+01, 0.3259D+01, 0.3544D+01, & + 0.4375D+01, 0.4592D+01, 0.5292D+01, 0.5471D+01 & + / + data (PAA(itmp, 4, 19),itmp=1,8) & + / & + 0.1000D+01, 0.2083D+01, 0.2944D+01, 0.3008D+01, & + 0.3555D+01, 0.3538D+01, 0.3852D+01, 0.3789D+01 & + / + data (PAA(itmp, 1, 20),itmp=1,8) & + / & + 0.1000D+01, 0.2780D+01, 0.4476D+01, 0.6085D+01, & + 0.7664D+01, 0.9186D+01, 0.1067D+02, 0.1210D+02 & + / + data (PAA(itmp, 2, 20),itmp=1,8) & + / & + 0.1000D+01, 0.2678D+01, 0.4164D+01, 0.5458D+01, & + 0.6813D+01, 0.8046D+01, 0.9325D+01, 0.1046D+02 & + / + data (PAA(itmp, 3, 20),itmp=1,8) & + / & + 0.1000D+01, 0.2391D+01, 0.3526D+01, 0.4044D+01, & + 0.5035D+01, 0.5527D+01, 0.6483D+01, 0.6961D+01 & + / + data (PAA(itmp, 4, 20),itmp=1,8) & + / & + 0.1000D+01, 0.2268D+01, 0.3300D+01, 0.3634D+01, & + 0.4458D+01, 0.4720D+01, 0.5401D+01, 0.5624D+01 & + / + data (PAA(itmp, 1, 21),itmp=1,8) & + / & + 0.1000D+01, 0.2809D+01, 0.4574D+01, 0.6281D+01, & + 0.7960D+01, 0.9607D+01, 0.1122D+02, 0.1281D+02 & + / + data (PAA(itmp, 2, 21),itmp=1,8) & + / & + 0.1000D+01, 0.2761D+01, 0.4405D+01, 0.5941D+01, & + 0.7485D+01, 0.8974D+01, 0.1046D+02, 0.1188D+02 & + / + data (PAA(itmp, 3, 21),itmp=1,8) & + / & + 0.1000D+01, 0.2505D+01, 0.3744D+01, 0.4488D+01, & + 0.5599D+01, 0.6354D+01, 0.7485D+01, 0.8238D+01 & + / + data (PAA(itmp, 4, 21),itmp=1,8) & + / & + 0.1000D+01, 0.2413D+01, 0.3563D+01, 0.4133D+01, & + 0.5118D+01, 0.5652D+01, 0.6582D+01, 0.7097D+01 & + / + data NHZ, HZO2, HZO3, QRAYL( 8) & + / & + 5, 0.8150D-23, 0.4400D-18, 0.3290D-24 & + / + data hzlab & + / & + 'O2 ', 'H1211 ', 'H2402 ', 'CCl4 ', 'F11 ', & + ' ', ' ' & + / + data hztmp & + / & + 0.1670D-09, 0.2760D-04, 0.2750D-04, & + 0.1310D-04, 0.7240D-05, & + 0.0000D00, 0.0000D00 & + / +! from rd_prof2 + + + data (OREF( 1, 1, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2400D-01, 0.2500D-01, 0.2400D-01, 0.2500D-01, & + 0.2600D-01, 0.2600D-01, 0.2500D-01, 0.2400D-01 & + / + data (OREF( 1, 2, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2400D-01, 0.2500D-01, 0.2400D-01, 0.2500D-01, & + 0.2600D-01, 0.2600D-01, 0.2500D-01, 0.2400D-01 & + / + data (OREF( 1, 3, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2400D-01, 0.2500D-01, 0.2400D-01, 0.2400D-01, & + 0.2500D-01, 0.2400D-01, 0.2400D-01, 0.2400D-01 & + / + data (OREF( 1, 4, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2400D-01, 0.2400D-01, 0.2400D-01, 0.2400D-01, & + 0.2400D-01, 0.2400D-01, 0.2400D-01, 0.2400D-01 & + / + data (OREF( 1, 5, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2400D-01, 0.2400D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1, 6, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2600D-01, 0.2600D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1, 7, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2500D-01, 0.2600D-01, 0.2600D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2400D-01, 0.2400D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1, 8, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01, & + 0.2400D-01, 0.2400D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1, 9, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2600D-01, 0.2600D-01, 0.2600D-01, & + 0.2600D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2600D-01 & + / + data (OREF( 1,10, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2600D-01, 0.2600D-01, 0.2500D-01, & + 0.2600D-01, 0.2600D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2600D-01, 0.2600D-01 & + / + data (OREF( 1,11, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1,12, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1,13, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2600D-01, 0.2600D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2600D-01, 0.2600D-01 & + / + data (OREF( 1,14, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01, & + 0.2400D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2600D-01, 0.2500D-01 & + / + data (OREF( 1,15, mtmp), mtmp=1,12) & + / & + 0.2400D-01, 0.2300D-01, 0.2300D-01, 0.2400D-01, & + 0.2400D-01, 0.2400D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2400D-01 & + / + data (OREF( 1,16, mtmp), mtmp=1,12) & + / & + 0.2400D-01, 0.2300D-01, 0.2200D-01, 0.2300D-01, & + 0.2300D-01, 0.2400D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1,17, mtmp), mtmp=1,12) & + / & + 0.2400D-01, 0.2300D-01, 0.2200D-01, 0.2200D-01, & + 0.2300D-01, 0.2300D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 1,18, mtmp), mtmp=1,12) & + / & + 0.2400D-01, 0.2300D-01, 0.2200D-01, 0.2200D-01, & + 0.2300D-01, 0.2300D-01, 0.2500D-01, 0.2500D-01, & + 0.2500D-01, 0.2500D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 2, 1, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3600D-01, 0.3500D-01, 0.3600D-01, & + 0.3200D-01, 0.3200D-01, 0.3200D-01, 0.3400D-01, & + 0.3500D-01, 0.3400D-01, 0.3400D-01, 0.3200D-01 & + / + data (OREF( 2, 2, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3600D-01, 0.3500D-01, 0.3600D-01, & + 0.3200D-01, 0.3200D-01, 0.3200D-01, 0.3400D-01, & + 0.3500D-01, 0.3400D-01, 0.3400D-01, 0.3200D-01 & + / + data (OREF( 2, 3, mtmp), mtmp=1,12) & + / & + 0.3300D-01, 0.3300D-01, 0.3300D-01, 0.3200D-01, & + 0.3200D-01, 0.3200D-01, 0.3200D-01, 0.3200D-01, & + 0.3300D-01, 0.3100D-01, 0.3100D-01, 0.3100D-01 & + / + data (OREF( 2, 4, mtmp), mtmp=1,12) & + / & + 0.3300D-01, 0.3400D-01, 0.3400D-01, 0.3300D-01, & + 0.3100D-01, 0.3100D-01, 0.3100D-01, 0.3200D-01, & + 0.3200D-01, 0.3100D-01, 0.3100D-01, 0.3200D-01 & + / + data (OREF( 2, 5, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3500D-01, 0.3500D-01, 0.3500D-01, & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3300D-01, & + 0.3200D-01, 0.3200D-01, 0.3300D-01, 0.3400D-01 & + / + data (OREF( 2, 6, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3500D-01, 0.3500D-01, 0.3500D-01, & + 0.3500D-01, 0.3500D-01, 0.3400D-01, 0.3300D-01, & + 0.3300D-01, 0.3300D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2, 7, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3200D-01, & + 0.3200D-01, 0.3200D-01, 0.3300D-01, 0.3300D-01 & + / + data (OREF( 2, 8, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3200D-01, & + 0.3200D-01, 0.3200D-01, 0.3300D-01, 0.3300D-01 & + / + data (OREF( 2, 9, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3500D-01, 0.3500D-01, 0.3500D-01, & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3300D-01, & + 0.3200D-01, 0.3300D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2,10, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3500D-01, 0.3400D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3300D-01, & + 0.3300D-01, 0.3400D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2,11, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3200D-01, & + 0.3200D-01, 0.3300D-01, 0.3300D-01, 0.3200D-01, & + 0.3300D-01, 0.3300D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2,12, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3300D-01, & + 0.3300D-01, 0.3300D-01, 0.3300D-01, 0.3200D-01, & + 0.3200D-01, 0.3300D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2,13, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3500D-01, 0.3500D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3400D-01, 0.3300D-01, & + 0.3300D-01, 0.3400D-01, 0.3500D-01, 0.3500D-01 & + / + data (OREF( 2,14, mtmp), mtmp=1,12) & + / & + 0.3300D-01, 0.3300D-01, 0.3300D-01, 0.3300D-01, & + 0.3200D-01, 0.3300D-01, 0.3300D-01, 0.3300D-01, & + 0.3300D-01, 0.3400D-01, 0.3400D-01, 0.3400D-01 & + / + data (OREF( 2,15, mtmp), mtmp=1,12) & + / & + 0.3100D-01, 0.3000D-01, 0.3000D-01, 0.3100D-01, & + 0.3100D-01, 0.3200D-01, 0.3300D-01, 0.3300D-01, & + 0.3300D-01, 0.3400D-01, 0.3300D-01, 0.3200D-01 & + / + data (OREF( 2,16, mtmp), mtmp=1,12) & + / & + 0.3200D-01, 0.3000D-01, 0.2800D-01, 0.2900D-01, & + 0.3000D-01, 0.3200D-01, 0.3300D-01, 0.3300D-01, & + 0.3400D-01, 0.3300D-01, 0.3300D-01, 0.3300D-01 & + / + data (OREF( 2,17, mtmp), mtmp=1,12) & + / & + 0.3200D-01, 0.2900D-01, 0.2700D-01, 0.2800D-01, & + 0.3000D-01, 0.3100D-01, 0.3300D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3300D-01 & + / + data (OREF( 2,18, mtmp), mtmp=1,12) & + / & + 0.3200D-01, 0.2900D-01, 0.2700D-01, 0.2800D-01, & + 0.3000D-01, 0.3100D-01, 0.3300D-01, 0.3400D-01, & + 0.3400D-01, 0.3400D-01, 0.3300D-01, 0.3300D-01 & + / + data (OREF( 3, 1, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.3600D-01, 0.3700D-01, 0.3700D-01, & + 0.4000D-01, 0.4000D-01, 0.4100D-01, 0.3800D-01, & + 0.3700D-01, 0.3800D-01, 0.3900D-01, 0.4100D-01 & + / + data (OREF( 3, 2, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.3600D-01, 0.3700D-01, 0.3700D-01, & + 0.4000D-01, 0.4000D-01, 0.4100D-01, 0.3800D-01, & + 0.3700D-01, 0.3800D-01, 0.3900D-01, 0.4100D-01 & + / + data (OREF( 3, 3, mtmp), mtmp=1,12) & + / & + 0.4000D-01, 0.3900D-01, 0.3900D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.4100D-01, 0.4100D-01, & + 0.4000D-01, 0.4200D-01, 0.4200D-01, 0.4200D-01 & + / + data (OREF( 3, 4, mtmp), mtmp=1,12) & + / & + 0.4000D-01, 0.3900D-01, 0.3800D-01, 0.3900D-01, & + 0.4100D-01, 0.4100D-01, 0.4200D-01, 0.4100D-01, & + 0.4100D-01, 0.4200D-01, 0.4200D-01, 0.4100D-01 & + / + data (OREF( 3, 5, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3900D-01, 0.4000D-01, 0.4000D-01, & + 0.4000D-01, 0.4100D-01, 0.4000D-01, 0.3900D-01 & + / + data (OREF( 3, 6, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.3900D-01 & + / + data (OREF( 3, 7, mtmp), mtmp=1,12) & + / & + 0.3900D-01, 0.3800D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3800D-01, 0.3900D-01, 0.4000D-01, & + 0.4000D-01, 0.4100D-01, 0.3900D-01, 0.3900D-01 & + / + data (OREF( 3, 8, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3900D-01, 0.3900D-01, 0.4000D-01, & + 0.4100D-01, 0.4100D-01, 0.4000D-01, 0.3900D-01 & + / + data (OREF( 3, 9, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.3700D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3800D-01, 0.3900D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.3800D-01 & + / + data (OREF( 3,10, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3800D-01, 0.3800D-01, 0.3900D-01, & + 0.3900D-01, 0.3900D-01, 0.3800D-01, 0.3800D-01 & + / + data (OREF( 3,11, mtmp), mtmp=1,12) & + / & + 0.3900D-01, 0.3900D-01, 0.4000D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.3900D-01 & + / + data (OREF( 3,12, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3800D-01, 0.3900D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.4100D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.3800D-01 & + / + data (OREF( 3,13, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.3700D-01, 0.3800D-01, 0.3800D-01, & + 0.3800D-01, 0.3900D-01, 0.3900D-01, 0.4000D-01, & + 0.3900D-01, 0.3900D-01, 0.3800D-01, 0.3700D-01 & + / + data (OREF( 3,14, mtmp), mtmp=1,12) & + / & + 0.4000D-01, 0.4000D-01, 0.4000D-01, 0.4000D-01, & + 0.4000D-01, 0.4000D-01, 0.3900D-01, 0.4000D-01, & + 0.3900D-01, 0.3900D-01, 0.3800D-01, 0.3800D-01 & + / + data (OREF( 3,15, mtmp), mtmp=1,12) & + / & + 0.4100D-01, 0.4300D-01, 0.4300D-01, 0.4200D-01, & + 0.4200D-01, 0.4100D-01, 0.4000D-01, 0.4000D-01, & + 0.3900D-01, 0.3900D-01, 0.4000D-01, 0.4000D-01 & + / + data (OREF( 3,16, mtmp), mtmp=1,12) & + / & + 0.4100D-01, 0.4300D-01, 0.4600D-01, 0.4400D-01, & + 0.4300D-01, 0.4100D-01, 0.4000D-01, 0.3900D-01, & + 0.3900D-01, 0.4000D-01, 0.4000D-01, 0.4000D-01 & + / + data (OREF( 3,17, mtmp), mtmp=1,12) & + / & + 0.4100D-01, 0.4400D-01, 0.4600D-01, 0.4500D-01, & + 0.4300D-01, 0.4200D-01, 0.4000D-01, 0.3800D-01, & + 0.3800D-01, 0.3900D-01, 0.4000D-01, 0.4000D-01 & + / + data (OREF( 3,18, mtmp), mtmp=1,12) & + / & + 0.4100D-01, 0.4400D-01, 0.4600D-01, 0.4500D-01, & + 0.4300D-01, 0.4200D-01, 0.4000D-01, 0.3800D-01, & + 0.3800D-01, 0.3900D-01, 0.4000D-01, 0.4000D-01 & + / + data (OREF( 4, 1, mtmp), mtmp=1,12) & + / & + 0.2800D-01, 0.2300D-01, 0.2600D-01, 0.2400D-01, & + 0.5000D-01, 0.4700D-01, 0.5000D-01, 0.3700D-01, & + 0.2800D-01, 0.3200D-01, 0.3900D-01, 0.5100D-01 & + / + data (OREF( 4, 2, mtmp), mtmp=1,12) & + / & + 0.2800D-01, 0.2300D-01, 0.2600D-01, 0.2400D-01, & + 0.5000D-01, 0.4700D-01, 0.5000D-01, 0.3700D-01, & + 0.2800D-01, 0.3200D-01, 0.3900D-01, 0.5100D-01 & + / + data (OREF( 4, 3, mtmp), mtmp=1,12) & + / & + 0.4400D-01, 0.3900D-01, 0.4000D-01, 0.4800D-01, & + 0.5000D-01, 0.4700D-01, 0.5000D-01, 0.5100D-01, & + 0.4600D-01, 0.5800D-01, 0.6100D-01, 0.5900D-01 & + / + data (OREF( 4, 4, mtmp), mtmp=1,12) & + / & + 0.4500D-01, 0.3800D-01, 0.3500D-01, 0.4000D-01, & + 0.5600D-01, 0.5600D-01, 0.5900D-01, 0.5300D-01, & + 0.5400D-01, 0.6200D-01, 0.6200D-01, 0.5200D-01 & + / + data (OREF( 4, 5, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3000D-01, 0.2900D-01, 0.3000D-01, & + 0.3300D-01, 0.3600D-01, 0.4300D-01, 0.4700D-01, & + 0.4900D-01, 0.5100D-01, 0.4400D-01, 0.3900D-01 & + / + data (OREF( 4, 6, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3000D-01, 0.3000D-01, 0.2900D-01, & + 0.3000D-01, 0.3100D-01, 0.3400D-01, 0.4400D-01, & + 0.4500D-01, 0.4500D-01, 0.3800D-01, 0.3600D-01 & + / + data (OREF( 4, 7, mtmp), mtmp=1,12) & + / & + 0.3800D-01, 0.3400D-01, 0.3300D-01, 0.3200D-01, & + 0.3300D-01, 0.3500D-01, 0.3600D-01, 0.4700D-01, & + 0.4800D-01, 0.5000D-01, 0.4200D-01, 0.4100D-01 & + / + data (OREF( 4, 8, mtmp), mtmp=1,12) & + / & + 0.3500D-01, 0.3300D-01, 0.3100D-01, 0.3200D-01, & + 0.3400D-01, 0.3700D-01, 0.3900D-01, 0.4800D-01, & + 0.5100D-01, 0.5300D-01, 0.4300D-01, 0.3900D-01 & + / + data (OREF( 4, 9, mtmp), mtmp=1,12) & + / & + 0.2800D-01, 0.2700D-01, 0.3000D-01, 0.2900D-01, & + 0.3100D-01, 0.3400D-01, 0.3700D-01, 0.4500D-01, & + 0.4700D-01, 0.4600D-01, 0.3700D-01, 0.3200D-01 & + / + data (OREF( 4,10, mtmp), mtmp=1,12) & + / & + 0.2900D-01, 0.2900D-01, 0.3300D-01, 0.3400D-01, & + 0.3200D-01, 0.3200D-01, 0.3400D-01, 0.4100D-01, & + 0.4200D-01, 0.3700D-01, 0.3200D-01, 0.3200D-01 & + / + data (OREF( 4,11, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.3700D-01, 0.4300D-01, 0.4900D-01, & + 0.4700D-01, 0.4400D-01, 0.4200D-01, 0.4800D-01, & + 0.4600D-01, 0.4300D-01, 0.3700D-01, 0.3700D-01 & + / + data (OREF( 4,12, mtmp), mtmp=1,12) & + / & + 0.3300D-01, 0.3400D-01, 0.3900D-01, 0.4300D-01, & + 0.4300D-01, 0.4300D-01, 0.4200D-01, 0.4900D-01, & + 0.4600D-01, 0.4400D-01, 0.3600D-01, 0.3400D-01 & + / + data (OREF( 4,13, mtmp), mtmp=1,12) & + / & + 0.2500D-01, 0.2600D-01, 0.2900D-01, 0.3400D-01, & + 0.3500D-01, 0.3600D-01, 0.3700D-01, 0.4400D-01, & + 0.4000D-01, 0.3700D-01, 0.2900D-01, 0.2700D-01 & + / + data (OREF( 4,14, mtmp), mtmp=1,12) & + / & + 0.4400D-01, 0.4600D-01, 0.4600D-01, 0.4700D-01, & + 0.4900D-01, 0.4300D-01, 0.4000D-01, 0.4400D-01, & + 0.4200D-01, 0.3900D-01, 0.3200D-01, 0.3600D-01 & + / + data (OREF( 4,15, mtmp), mtmp=1,12) & + / & + 0.5600D-01, 0.6900D-01, 0.6700D-01, 0.6100D-01, & + 0.6000D-01, 0.5100D-01, 0.4500D-01, 0.4400D-01, & + 0.4000D-01, 0.3900D-01, 0.4500D-01, 0.4800D-01 & + / + data (OREF( 4,16, mtmp), mtmp=1,12) & + / & + 0.5200D-01, 0.7100D-01, 0.8800D-01, 0.7400D-01, & + 0.6700D-01, 0.5500D-01, 0.4400D-01, 0.4000D-01, & + 0.3600D-01, 0.4300D-01, 0.4500D-01, 0.4400D-01 & + / + data (OREF( 4,17, mtmp), mtmp=1,12) & + / & + 0.5200D-01, 0.7400D-01, 0.9300D-01, 0.8300D-01, & + 0.7200D-01, 0.6400D-01, 0.4400D-01, 0.3600D-01, & + 0.3400D-01, 0.3800D-01, 0.4500D-01, 0.4400D-01 & + / + data (OREF( 4,18, mtmp), mtmp=1,12) & + / & + 0.5200D-01, 0.7400D-01, 0.9300D-01, 0.8300D-01, & + 0.7200D-01, 0.6400D-01, 0.4400D-01, 0.3600D-01, & + 0.3400D-01, 0.3800D-01, 0.4500D-01, 0.4400D-01 & + / + data (OREF( 5, 1, mtmp), mtmp=1,12) & + / & + 0.4500D-01, 0.4000D-01, 0.4600D-01, 0.4000D-01, & + 0.7800D-01, 0.7100D-01, 0.7700D-01, 0.5600D-01, & + 0.3900D-01, 0.4100D-01, 0.5600D-01, 0.7800D-01 & + / + data (OREF( 5, 2, mtmp), mtmp=1,12) & + / & + 0.4500D-01, 0.4000D-01, 0.4600D-01, 0.4000D-01, & + 0.7800D-01, 0.7100D-01, 0.7700D-01, 0.5600D-01, & + 0.3900D-01, 0.4100D-01, 0.5600D-01, 0.7800D-01 & + / + data (OREF( 5, 3, mtmp), mtmp=1,12) & + / & + 0.6700D-01, 0.5900D-01, 0.6100D-01, 0.7600D-01, & + 0.7800D-01, 0.7100D-01, 0.7700D-01, 0.8000D-01, & + 0.7000D-01, 0.9200D-01, 0.9200D-01, 0.9000D-01 & + / + data (OREF( 5, 4, mtmp), mtmp=1,12) & + / & + 0.6500D-01, 0.5300D-01, 0.4600D-01, 0.5500D-01, & + 0.8600D-01, 0.8600D-01, 0.9200D-01, 0.8500D-01, & + 0.8700D-01, 0.1010D+00, 0.9500D-01, 0.7900D-01 & + / + data (OREF( 5, 5, mtmp), mtmp=1,12) & + / & + 0.4300D-01, 0.3300D-01, 0.3100D-01, 0.3200D-01, & + 0.3900D-01, 0.4800D-01, 0.6100D-01, 0.7200D-01, & + 0.7800D-01, 0.8100D-01, 0.6400D-01, 0.5200D-01 & + / + data (OREF( 5, 6, mtmp), mtmp=1,12) & + / & + 0.3700D-01, 0.2800D-01, 0.2800D-01, 0.2700D-01, & + 0.3000D-01, 0.3400D-01, 0.4100D-01, 0.6100D-01, & + 0.6600D-01, 0.6500D-01, 0.5000D-01, 0.4400D-01 & + / + data (OREF( 5, 7, mtmp), mtmp=1,12) & + / & + 0.4100D-01, 0.3200D-01, 0.3000D-01, 0.2900D-01, & + 0.3200D-01, 0.3500D-01, 0.3900D-01, 0.5800D-01, & + 0.6300D-01, 0.6500D-01, 0.5200D-01, 0.4700D-01 & + / + data (OREF( 5, 8, mtmp), mtmp=1,12) & + / & + 0.3300D-01, 0.2800D-01, 0.2600D-01, 0.2700D-01, & + 0.3100D-01, 0.3500D-01, 0.4000D-01, 0.5600D-01, & + 0.6200D-01, 0.6500D-01, 0.4800D-01, 0.4000D-01 & + / + data (OREF( 5, 9, mtmp), mtmp=1,12) & + / & + 0.2000D-01, 0.1900D-01, 0.2300D-01, 0.2200D-01, & + 0.2500D-01, 0.3000D-01, 0.3500D-01, 0.5100D-01, & + 0.5400D-01, 0.5000D-01, 0.3600D-01, 0.2800D-01 & + / + data (OREF( 5,10, mtmp), mtmp=1,12) & + / & + 0.2100D-01, 0.2100D-01, 0.2800D-01, 0.3200D-01, & + 0.2700D-01, 0.2800D-01, 0.3200D-01, 0.4300D-01, & + 0.4500D-01, 0.3600D-01, 0.2800D-01, 0.2700D-01 & + / + data (OREF( 5,11, mtmp), mtmp=1,12) & + / & + 0.3400D-01, 0.3400D-01, 0.4600D-01, 0.5800D-01, & + 0.5700D-01, 0.5200D-01, 0.4900D-01, 0.5700D-01, & + 0.5300D-01, 0.4700D-01, 0.3600D-01, 0.3500D-01 & + / + data (OREF( 5,12, mtmp), mtmp=1,12) & + / & + 0.2900D-01, 0.3300D-01, 0.4400D-01, 0.5500D-01, & + 0.5700D-01, 0.5500D-01, 0.5200D-01, 0.6200D-01, & + 0.5600D-01, 0.5000D-01, 0.3500D-01, 0.3100D-01 & + / + data (OREF( 5,13, mtmp), mtmp=1,12) & + / & + 0.2700D-01, 0.3200D-01, 0.4200D-01, 0.5000D-01, & + 0.5100D-01, 0.4900D-01, 0.4500D-01, 0.5600D-01, & + 0.4700D-01, 0.4100D-01, 0.2500D-01, 0.2500D-01 & + / + data (OREF( 5,14, mtmp), mtmp=1,12) & + / & + 0.7100D-01, 0.8300D-01, 0.8500D-01, 0.8500D-01, & + 0.8300D-01, 0.6600D-01, 0.5500D-01, 0.6200D-01, & + 0.5500D-01, 0.4800D-01, 0.3500D-01, 0.4800D-01 & + / + data (OREF( 5,15, mtmp), mtmp=1,12) & + / & + 0.1020D+00, 0.1360D+00, 0.1360D+00, 0.1230D+00, & + 0.1130D+00, 0.8800D-01, 0.7100D-01, 0.6800D-01, & + 0.5700D-01, 0.5400D-01, 0.6600D-01, 0.7600D-01 & + / + data (OREF( 5,16, mtmp), mtmp=1,12) & + / & + 0.9400D-01, 0.1490D+00, 0.1880D+00, 0.1600D+00, & + 0.1360D+00, 0.1020D+00, 0.7400D-01, 0.6400D-01, & + 0.5300D-01, 0.6500D-01, 0.7300D-01, 0.6900D-01 & + / + data (OREF( 5,17, mtmp), mtmp=1,12) & + / & + 0.9400D-01, 0.1560D+00, 0.2100D+00, 0.1930D+00, & + 0.1640D+00, 0.1310D+00, 0.8100D-01, 0.5600D-01, & + 0.4800D-01, 0.5600D-01, 0.7300D-01, 0.6900D-01 & + / + data (OREF( 5,18, mtmp), mtmp=1,12) & + / & + 0.9400D-01, 0.1560D+00, 0.2100D+00, 0.1930D+00, & + 0.1640D+00, 0.1310D+00, 0.8100D-01, 0.5600D-01, & + 0.4800D-01, 0.5600D-01, 0.7300D-01, 0.6900D-01 & + / + data (OREF( 6, 1, mtmp), mtmp=1,12) & + / & + 0.1360D+00, 0.1420D+00, 0.1480D+00, 0.1350D+00, & + 0.1460D+00, 0.1310D+00, 0.1410D+00, 0.1290D+00, & + 0.1100D+00, 0.9600D-01, 0.1180D+00, 0.1400D+00 & + / + data (OREF( 6, 2, mtmp), mtmp=1,12) & + / & + 0.1360D+00, 0.1420D+00, 0.1480D+00, 0.1350D+00, & + 0.1460D+00, 0.1310D+00, 0.1410D+00, 0.1290D+00, & + 0.1100D+00, 0.9600D-01, 0.1180D+00, 0.1400D+00 & + / + data (OREF( 6, 3, mtmp), mtmp=1,12) & + / & + 0.1340D+00, 0.1280D+00, 0.1320D+00, 0.1490D+00, & + 0.1460D+00, 0.1310D+00, 0.1410D+00, 0.1500D+00, & + 0.1330D+00, 0.1570D+00, 0.1420D+00, 0.1460D+00 & + / + data (OREF( 6, 4, mtmp), mtmp=1,12) & + / & + 0.1230D+00, 0.1080D+00, 0.9800D-01, 0.1080D+00, & + 0.1430D+00, 0.1450D+00, 0.1520D+00, 0.1560D+00, & + 0.1640D+00, 0.1780D+00, 0.1510D+00, 0.1380D+00 & + / + data (OREF( 6, 5, mtmp), mtmp=1,12) & + / & + 0.8700D-01, 0.6900D-01, 0.6500D-01, 0.6700D-01, & + 0.8000D-01, 0.9600D-01, 0.1160D+00, 0.1400D+00, & + 0.1510D+00, 0.1530D+00, 0.1210D+00, 0.1010D+00 & + / + data (OREF( 6, 6, mtmp), mtmp=1,12) & + / & + 0.6700D-01, 0.5200D-01, 0.5000D-01, 0.5100D-01, & + 0.5900D-01, 0.7000D-01, 0.8600D-01, 0.1130D+00, & + 0.1230D+00, 0.1200D+00, 0.1000D+00, 0.8000D-01 & + / + data (OREF( 6, 7, mtmp), mtmp=1,12) & + / & + 0.5700D-01, 0.4500D-01, 0.4300D-01, 0.4300D-01, & + 0.4600D-01, 0.5000D-01, 0.5700D-01, 0.8000D-01, & + 0.9300D-01, 0.9400D-01, 0.8500D-01, 0.6900D-01 & + / + data (OREF( 6, 8, mtmp), mtmp=1,12) & + / & + 0.4200D-01, 0.3600D-01, 0.3400D-01, 0.3400D-01, & + 0.3700D-01, 0.4100D-01, 0.4500D-01, 0.6300D-01, & + 0.7200D-01, 0.7300D-01, 0.6000D-01, 0.5000D-01 & + / + data (OREF( 6, 9, mtmp), mtmp=1,12) & + / & + 0.2700D-01, 0.2600D-01, 0.3000D-01, 0.3000D-01, & + 0.3200D-01, 0.3700D-01, 0.4300D-01, 0.5600D-01, & + 0.6000D-01, 0.5400D-01, 0.4300D-01, 0.3400D-01 & + / + data (OREF( 6,10, mtmp), mtmp=1,12) & + / & + 0.2600D-01, 0.2700D-01, 0.3400D-01, 0.3900D-01, & + 0.3600D-01, 0.3900D-01, 0.4500D-01, 0.5200D-01, & + 0.5200D-01, 0.4200D-01, 0.3400D-01, 0.3200D-01 & + / + data (OREF( 6,11, mtmp), mtmp=1,12) & + / & + 0.3600D-01, 0.3700D-01, 0.5000D-01, 0.6800D-01, & + 0.7200D-01, 0.7100D-01, 0.7000D-01, 0.6900D-01, & + 0.6400D-01, 0.5300D-01, 0.4100D-01, 0.3800D-01 & + / + data (OREF( 6,12, mtmp), mtmp=1,12) & + / & + 0.3900D-01, 0.4600D-01, 0.6600D-01, 0.8800D-01, & + 0.9600D-01, 0.9000D-01, 0.8000D-01, 0.8200D-01, & + 0.7200D-01, 0.6000D-01, 0.4100D-01, 0.3800D-01 & + / + data (OREF( 6,13, mtmp), mtmp=1,12) & + / & + 0.7500D-01, 0.9200D-01, 0.1120D+00, 0.1210D+00, & + 0.1190D+00, 0.1010D+00, 0.8200D-01, 0.8800D-01, & + 0.7500D-01, 0.6300D-01, 0.4300D-01, 0.5500D-01 & + / + data (OREF( 6,14, mtmp), mtmp=1,12) & + / & + 0.1530D+00, 0.1900D+00, 0.1970D+00, 0.1910D+00, & + 0.1750D+00, 0.1360D+00, 0.1040D+00, 0.1080D+00, & + 0.9400D-01, 0.8400D-01, 0.6900D-01, 0.1000D+00 & + / + data (OREF( 6,15, mtmp), mtmp=1,12) & + / & + 0.2120D+00, 0.2770D+00, 0.2920D+00, 0.2680D+00, & + 0.2370D+00, 0.1840D+00, 0.1470D+00, 0.1380D+00, & + 0.1150D+00, 0.1090D+00, 0.1250D+00, 0.1500D+00 & + / + data (OREF( 6,16, mtmp), mtmp=1,12) & + / & + 0.2010D+00, 0.3180D+00, 0.3890D+00, 0.3510D+00, & + 0.2920D+00, 0.2180D+00, 0.1640D+00, 0.1430D+00, & + 0.1180D+00, 0.1290D+00, 0.1500D+00, 0.1420D+00 & + / + data (OREF( 6,17, mtmp), mtmp=1,12) & + / & + 0.2010D+00, 0.3360D+00, 0.4500D+00, 0.4370D+00, & + 0.3790D+00, 0.2850D+00, 0.1890D+00, 0.1340D+00, & + 0.1150D+00, 0.1220D+00, 0.1500D+00, 0.1420D+00 & + / + data (OREF( 6,18, mtmp), mtmp=1,12) & + / & + 0.2010D+00, 0.3360D+00, 0.4500D+00, 0.4370D+00, & + 0.3790D+00, 0.2850D+00, 0.1890D+00, 0.1340D+00, & + 0.1150D+00, 0.1220D+00, 0.1500D+00, 0.1420D+00 & + / + data (OREF( 7, 1, mtmp), mtmp=1,12) & + / & + 0.3230D+00, 0.3390D+00, 0.3400D+00, 0.3110D+00, & + 0.2810D+00, 0.2560D+00, 0.2740D+00, 0.2920D+00, & + 0.2690D+00, 0.2430D+00, 0.2680D+00, 0.2970D+00 & + / + data (OREF( 7, 2, mtmp), mtmp=1,12) & + / & + 0.3230D+00, 0.3390D+00, 0.3400D+00, 0.3110D+00, & + 0.2810D+00, 0.2560D+00, 0.2740D+00, 0.2920D+00, & + 0.2690D+00, 0.2430D+00, 0.2680D+00, 0.2970D+00 & + / + data (OREF( 7, 3, mtmp), mtmp=1,12) & + / & + 0.2820D+00, 0.2730D+00, 0.2730D+00, 0.2900D+00, & + 0.2810D+00, 0.2560D+00, 0.2740D+00, 0.2960D+00, & + 0.2800D+00, 0.3150D+00, 0.2730D+00, 0.2850D+00 & + / + data (OREF( 7, 4, mtmp), mtmp=1,12) & + / & + 0.2520D+00, 0.2290D+00, 0.2140D+00, 0.2250D+00, & + 0.2570D+00, 0.2660D+00, 0.2790D+00, 0.3060D+00, & + 0.3270D+00, 0.3470D+00, 0.2850D+00, 0.2700D+00 & + / + data (OREF( 7, 5, mtmp), mtmp=1,12) & + / & + 0.1880D+00, 0.1610D+00, 0.1540D+00, 0.1590D+00, & + 0.1820D+00, 0.2060D+00, 0.2370D+00, 0.2770D+00, & + 0.2970D+00, 0.2980D+00, 0.2480D+00, 0.2130D+00 & + / + data (OREF( 7, 6, mtmp), mtmp=1,12) & + / & + 0.1370D+00, 0.1150D+00, 0.1120D+00, 0.1170D+00, & + 0.1320D+00, 0.1570D+00, 0.1860D+00, 0.2110D+00, & + 0.2320D+00, 0.2250D+00, 0.2020D+00, 0.1590D+00 & + / + data (OREF( 7, 7, mtmp), mtmp=1,12) & + / & + 0.9700D-01, 0.8200D-01, 0.7900D-01, 0.8200D-01, & + 0.8600D-01, 0.8900D-01, 0.1020D+00, 0.1180D+00, & + 0.1460D+00, 0.1440D+00, 0.1470D+00, 0.1160D+00 & + / + data (OREF( 7, 8, mtmp), mtmp=1,12) & + / & + 0.6600D-01, 0.6000D-01, 0.5800D-01, 0.5800D-01, & + 0.5800D-01, 0.5900D-01, 0.6200D-01, 0.7300D-01, & + 0.8500D-01, 0.8400D-01, 0.8500D-01, 0.7300D-01 & + / + data (OREF( 7, 9, mtmp), mtmp=1,12) & + / & + 0.5300D-01, 0.5200D-01, 0.5500D-01, 0.5500D-01, & + 0.5600D-01, 0.5800D-01, 0.6300D-01, 0.6600D-01, & + 0.7000D-01, 0.6200D-01, 0.6200D-01, 0.5700D-01 & + / + data (OREF( 7,10, mtmp), mtmp=1,12) & + / & + 0.4700D-01, 0.4800D-01, 0.5500D-01, 0.6200D-01, & + 0.6200D-01, 0.6700D-01, 0.7600D-01, 0.7100D-01, & + 0.6900D-01, 0.5900D-01, 0.5600D-01, 0.5200D-01 & + / + data (OREF( 7,11, mtmp), mtmp=1,12) & + / & + 0.4800D-01, 0.5100D-01, 0.6300D-01, 0.8600D-01, & + 0.1000D+00, 0.1060D+00, 0.1090D+00, 0.9000D-01, & + 0.8500D-01, 0.6500D-01, 0.5700D-01, 0.5100D-01 & + / + data (OREF( 7,12, mtmp), mtmp=1,12) & + / & + 0.7500D-01, 0.8700D-01, 0.1190D+00, 0.1560D+00, & + 0.1710D+00, 0.1590D+00, 0.1400D+00, 0.1200D+00, & + 0.1050D+00, 0.8600D-01, 0.7000D-01, 0.6800D-01 & + / + data (OREF( 7,13, mtmp), mtmp=1,12) & + / & + 0.1950D+00, 0.2320D+00, 0.2650D+00, 0.2710D+00, & + 0.2610D+00, 0.2160D+00, 0.1700D+00, 0.1570D+00, & + 0.1370D+00, 0.1170D+00, 0.1070D+00, 0.1430D+00 & + / + data (OREF( 7,14, mtmp), mtmp=1,12) & + / & + 0.3310D+00, 0.4100D+00, 0.4240D+00, 0.4060D+00, & + 0.3670D+00, 0.2950D+00, 0.2290D+00, 0.2100D+00, & + 0.1840D+00, 0.1720D+00, 0.1740D+00, 0.2360D+00 & + / + data (OREF( 7,15, mtmp), mtmp=1,12) & + / & + 0.4310D+00, 0.5260D+00, 0.5650D+00, 0.5350D+00, & + 0.4730D+00, 0.3850D+00, 0.3200D+00, 0.2910D+00, & + 0.2510D+00, 0.2410D+00, 0.2660D+00, 0.3200D+00 & + / + data (OREF( 7,16, mtmp), mtmp=1,12) & + / & + 0.4160D+00, 0.6020D+00, 0.7010D+00, 0.6650D+00, & + 0.5670D+00, 0.4530D+00, 0.3680D+00, 0.3250D+00, & + 0.2800D+00, 0.2810D+00, 0.3260D+00, 0.3150D+00 & + / + data (OREF( 7,17, mtmp), mtmp=1,12) & + / & + 0.4160D+00, 0.6370D+00, 0.8090D+00, 0.8050D+00, & + 0.7190D+00, 0.5600D+00, 0.4210D+00, 0.3350D+00, & + 0.2970D+00, 0.2900D+00, 0.3260D+00, 0.3150D+00 & + / + data (OREF( 7,18, mtmp), mtmp=1,12) & + / & + 0.4160D+00, 0.6370D+00, 0.8090D+00, 0.8050D+00, & + 0.7190D+00, 0.5600D+00, 0.4210D+00, 0.3350D+00, & + 0.2970D+00, 0.2900D+00, 0.3260D+00, 0.3150D+00 & + / + data (OREF( 8, 1, mtmp), mtmp=1,12) & + / & + 0.6090D+00, 0.5980D+00, 0.5850D+00, 0.5270D+00, & + 0.5140D+00, 0.4890D+00, 0.5200D+00, 0.5840D+00, & + 0.5380D+00, 0.5560D+00, 0.5690D+00, 0.6500D+00 & + / + data (OREF( 8, 2, mtmp), mtmp=1,12) & + / & + 0.6090D+00, 0.5980D+00, 0.5850D+00, 0.5270D+00, & + 0.5140D+00, 0.4890D+00, 0.5200D+00, 0.5840D+00, & + 0.5380D+00, 0.5560D+00, 0.5690D+00, 0.6500D+00 & + / + data (OREF( 8, 3, mtmp), mtmp=1,12) & + / & + 0.5650D+00, 0.5240D+00, 0.5030D+00, 0.5190D+00, & + 0.5140D+00, 0.4890D+00, 0.5200D+00, 0.5700D+00, & + 0.5830D+00, 0.6800D+00, 0.6080D+00, 0.6170D+00 & + / + data (OREF( 8, 4, mtmp), mtmp=1,12) & + / & + 0.5020D+00, 0.4490D+00, 0.4210D+00, 0.4360D+00, & + 0.4720D+00, 0.5060D+00, 0.5440D+00, 0.5920D+00, & + 0.6450D+00, 0.7050D+00, 0.5970D+00, 0.5480D+00 & + / + data (OREF( 8, 5, mtmp), mtmp=1,12) & + / & + 0.3760D+00, 0.3320D+00, 0.3240D+00, 0.3360D+00, & + 0.3760D+00, 0.4110D+00, 0.4680D+00, 0.5130D+00, & + 0.5520D+00, 0.5600D+00, 0.4870D+00, 0.4200D+00 & + / + data (OREF( 8, 6, mtmp), mtmp=1,12) & + / & + 0.2620D+00, 0.2310D+00, 0.2270D+00, 0.2390D+00, & + 0.2670D+00, 0.3090D+00, 0.3540D+00, 0.3670D+00, & + 0.4040D+00, 0.3940D+00, 0.3680D+00, 0.2970D+00 & + / + data (OREF( 8, 7, mtmp), mtmp=1,12) & + / & + 0.1730D+00, 0.1520D+00, 0.1470D+00, 0.1530D+00, & + 0.1600D+00, 0.1640D+00, 0.1850D+00, 0.1850D+00, & + 0.2290D+00, 0.2290D+00, 0.2440D+00, 0.2000D+00 & + / + data (OREF( 8, 8, mtmp), mtmp=1,12) & + / & + 0.1100D+00, 0.1030D+00, 0.1010D+00, 0.1000D+00, & + 0.9800D-01, 0.9600D-01, 0.9900D-01, 0.9400D-01, & + 0.1150D+00, 0.1150D+00, 0.1320D+00, 0.1180D+00 & + / + data (OREF( 8, 9, mtmp), mtmp=1,12) & + / & + 0.9200D-01, 0.9200D-01, 0.9400D-01, 0.9600D-01, & + 0.9500D-01, 0.9600D-01, 0.1010D+00, 0.8900D-01, & + 0.9600D-01, 0.8600D-01, 0.1000D+00, 0.9500D-01 & + / + data (OREF( 8,10, mtmp), mtmp=1,12) & + / & + 0.8200D-01, 0.8400D-01, 0.9200D-01, 0.1010D+00, & + 0.1030D+00, 0.1110D+00, 0.1220D+00, 0.1040D+00, & + 0.1010D+00, 0.8600D-01, 0.9300D-01, 0.8800D-01 & + / + data (OREF( 8,11, mtmp), mtmp=1,12) & + / & + 0.8100D-01, 0.8600D-01, 0.1010D+00, 0.1290D+00, & + 0.1500D+00, 0.1610D+00, 0.1670D+00, 0.1310D+00, & + 0.1230D+00, 0.9300D-01, 0.9500D-01, 0.8500D-01 & + / + data (OREF( 8,12, mtmp), mtmp=1,12) & + / & + 0.1590D+00, 0.1770D+00, 0.2210D+00, 0.2730D+00, & + 0.2940D+00, 0.2750D+00, 0.2460D+00, 0.1980D+00, & + 0.1750D+00, 0.1430D+00, 0.1450D+00, 0.1460D+00 & + / + data (OREF( 8,13, mtmp), mtmp=1,12) & + / & + 0.4130D+00, 0.4720D+00, 0.5170D+00, 0.5140D+00, & + 0.4950D+00, 0.4190D+00, 0.3440D+00, 0.2860D+00, & + 0.2540D+00, 0.2220D+00, 0.2530D+00, 0.3200D+00 & + / + data (OREF( 8,14, mtmp), mtmp=1,12) & + / & + 0.6630D+00, 0.7880D+00, 0.8130D+00, 0.7780D+00, & + 0.7130D+00, 0.6050D+00, 0.4950D+00, 0.4040D+00, & + 0.3630D+00, 0.3480D+00, 0.4130D+00, 0.5170D+00 & + / + data (OREF( 8,15, mtmp), mtmp=1,12) & + / & + 0.8150D+00, 0.9110D+00, 0.9780D+00, 0.9530D+00, & + 0.8700D+00, 0.7590D+00, 0.6630D+00, 0.5740D+00, & + 0.5170D+00, 0.5030D+00, 0.5610D+00, 0.6640D+00 & + / + data (OREF( 8,16, mtmp), mtmp=1,12) & + / & + 0.7960D+00, 0.1004D+01, 0.1104D+01, 0.1086D+01, & + 0.9860D+00, 0.8690D+00, 0.7600D+00, 0.6750D+00, & + 0.6140D+00, 0.5910D+00, 0.6700D+00, 0.6670D+00 & + / + data (OREF( 8,17, mtmp), mtmp=1,12) & + / & + 0.7960D+00, 0.1065D+01, 0.1229D+01, 0.1230D+01, & + 0.1138D+01, 0.9780D+00, 0.8410D+00, 0.7500D+00, & + 0.6930D+00, 0.6430D+00, 0.6700D+00, 0.6670D+00 & + / + data (OREF( 8,18, mtmp), mtmp=1,12) & + / & + 0.7960D+00, 0.1065D+01, 0.1229D+01, 0.1230D+01, & + 0.1138D+01, 0.9780D+00, 0.8410D+00, 0.7500D+00, & + 0.6930D+00, 0.6430D+00, 0.6700D+00, 0.6670D+00 & + / + data (OREF( 9, 1, mtmp), mtmp=1,12) & + / & + 0.1048D+01, 0.9660D+00, 0.9220D+00, 0.8200D+00, & + 0.9000D+00, 0.8910D+00, 0.9430D+00, 0.1026D+01, & + 0.9370D+00, 0.1067D+01, 0.1096D+01, 0.1278D+01 & + / + data (OREF( 9, 2, mtmp), mtmp=1,12) & + / & + 0.1048D+01, 0.9660D+00, 0.9220D+00, 0.8200D+00, & + 0.9000D+00, 0.8910D+00, 0.9430D+00, 0.1026D+01, & + 0.9370D+00, 0.1067D+01, 0.1096D+01, 0.1278D+01 & + / + data (OREF( 9, 3, mtmp), mtmp=1,12) & + / & + 0.1053D+01, 0.9440D+00, 0.8780D+00, 0.8900D+00, & + 0.9000D+00, 0.8910D+00, 0.9430D+00, 0.1024D+01, & + 0.1092D+01, 0.1315D+01, 0.1239D+01, 0.1225D+01 & + / + data (OREF( 9, 4, mtmp), mtmp=1,12) & + / & + 0.9430D+00, 0.8330D+00, 0.7810D+00, 0.8050D+00, & + 0.8510D+00, 0.9330D+00, 0.1020D+01, 0.1081D+01, & + 0.1178D+01, 0.1319D+01, 0.1172D+01, 0.1048D+01 & + / + data (OREF( 9, 5, mtmp), mtmp=1,12) & + / & + 0.7090D+00, 0.6390D+00, 0.6340D+00, 0.6600D+00, & + 0.7270D+00, 0.7780D+00, 0.8800D+00, 0.9090D+00, & + 0.9770D+00, 0.9970D+00, 0.9020D+00, 0.7850D+00 & + / + data (OREF( 9, 6, mtmp), mtmp=1,12) & + / & + 0.4870D+00, 0.4420D+00, 0.4390D+00, 0.4620D+00, & + 0.5110D+00, 0.5790D+00, 0.6460D+00, 0.6360D+00, & + 0.6920D+00, 0.6770D+00, 0.6430D+00, 0.5370D+00 & + / + data (OREF( 9, 7, mtmp), mtmp=1,12) & + / & + 0.3200D+00, 0.2870D+00, 0.2800D+00, 0.2890D+00, & + 0.3020D+00, 0.3140D+00, 0.3440D+00, 0.3250D+00, & + 0.3870D+00, 0.3900D+00, 0.4100D+00, 0.3570D+00 & + / + data (OREF( 9, 8, mtmp), mtmp=1,12) & + / & + 0.1970D+00, 0.1850D+00, 0.1810D+00, 0.1800D+00, & + 0.1800D+00, 0.1790D+00, 0.1860D+00, 0.1610D+00, & + 0.1970D+00, 0.2040D+00, 0.2270D+00, 0.2100D+00 & + / + data (OREF( 9, 9, mtmp), mtmp=1,12) & + / & + 0.1630D+00, 0.1610D+00, 0.1670D+00, 0.1690D+00, & + 0.1690D+00, 0.1720D+00, 0.1800D+00, 0.1600D+00, & + 0.1730D+00, 0.1580D+00, 0.1790D+00, 0.1710D+00 & + / + data (OREF( 9,10, mtmp), mtmp=1,12) & + / & + 0.1490D+00, 0.1510D+00, 0.1660D+00, 0.1790D+00, & + 0.1810D+00, 0.1900D+00, 0.2040D+00, 0.1840D+00, & + 0.1820D+00, 0.1520D+00, 0.1670D+00, 0.1590D+00 & + / + data (OREF( 9,11, mtmp), mtmp=1,12) & + / & + 0.1590D+00, 0.1660D+00, 0.1900D+00, 0.2280D+00, & + 0.2520D+00, 0.2610D+00, 0.2670D+00, 0.2290D+00, & + 0.2130D+00, 0.1680D+00, 0.1800D+00, 0.1660D+00 & + / + data (OREF( 9,12, mtmp), mtmp=1,12) & + / & + 0.3270D+00, 0.3500D+00, 0.4040D+00, 0.4690D+00, & + 0.4910D+00, 0.4670D+00, 0.4290D+00, 0.3530D+00, & + 0.3180D+00, 0.2700D+00, 0.3040D+00, 0.3080D+00 & + / + data (OREF( 9,13, mtmp), mtmp=1,12) & + / & + 0.7630D+00, 0.8430D+00, 0.8940D+00, 0.8780D+00, & + 0.8450D+00, 0.7410D+00, 0.6350D+00, 0.5140D+00, & + 0.4650D+00, 0.4180D+00, 0.5230D+00, 0.6280D+00 & + / + data (OREF( 9,14, mtmp), mtmp=1,12) & + / & + 0.1183D+01, 0.1354D+01, 0.1389D+01, 0.1331D+01, & + 0.1239D+01, 0.1098D+01, 0.9390D+00, 0.7330D+00, & + 0.6740D+00, 0.6580D+00, 0.8330D+00, 0.9820D+00 & + / + data (OREF( 9,15, mtmp), mtmp=1,12) & + / & + 0.1387D+01, 0.1459D+01, 0.1557D+01, 0.1542D+01, & + 0.1446D+01, 0.1329D+01, 0.1203D+01, 0.1021D+01, & + 0.9510D+00, 0.9360D+00, 0.1044D+01, 0.1212D+01 & + / + data (OREF( 9,16, mtmp), mtmp=1,12) & + / & + 0.1359D+01, 0.1538D+01, 0.1622D+01, 0.1634D+01, & + 0.1566D+01, 0.1476D+01, 0.1353D+01, 0.1211D+01, & + 0.1145D+01, 0.1090D+01, 0.1203D+01, 0.1219D+01 & + / + data (OREF( 9,17, mtmp), mtmp=1,12) & + / & + 0.1359D+01, 0.1633D+01, 0.1724D+01, 0.1725D+01, & + 0.1642D+01, 0.1540D+01, 0.1442D+01, 0.1383D+01, & + 0.1312D+01, 0.1194D+01, 0.1203D+01, 0.1219D+01 & + / + data (OREF( 9,18, mtmp), mtmp=1,12) & + / & + 0.1359D+01, 0.1633D+01, 0.1724D+01, 0.1725D+01, & + 0.1642D+01, 0.1540D+01, 0.1442D+01, 0.1383D+01, & + 0.1312D+01, 0.1194D+01, 0.1203D+01, 0.1219D+01 & + / + data (OREF(10, 1, mtmp), mtmp=1,12) & + / & + 0.1822D+01, 0.1689D+01, 0.1574D+01, 0.1435D+01, & + 0.1564D+01, 0.1589D+01, 0.1657D+01, 0.1532D+01, & + 0.1429D+01, 0.1652D+01, 0.1926D+01, 0.2177D+01 & + / + data (OREF(10, 2, mtmp), mtmp=1,12) & + / & + 0.1822D+01, 0.1689D+01, 0.1574D+01, 0.1435D+01, & + 0.1564D+01, 0.1589D+01, 0.1657D+01, 0.1532D+01, & + 0.1429D+01, 0.1652D+01, 0.1926D+01, 0.2177D+01 & + / + data (OREF(10, 3, mtmp), mtmp=1,12) & + / & + 0.1852D+01, 0.1698D+01, 0.1582D+01, 0.1556D+01, & + 0.1564D+01, 0.1589D+01, 0.1657D+01, 0.1688D+01, & + 0.1780D+01, 0.2110D+01, 0.2151D+01, 0.2110D+01 & + / + data (OREF(10, 4, mtmp), mtmp=1,12) & + / & + 0.1694D+01, 0.1534D+01, 0.1464D+01, 0.1493D+01, & + 0.1523D+01, 0.1648D+01, 0.1781D+01, 0.1864D+01, & + 0.1945D+01, 0.2143D+01, 0.2022D+01, 0.1845D+01 & + / + data (OREF(10, 5, mtmp), mtmp=1,12) & + / & + 0.1333D+01, 0.1229D+01, 0.1229D+01, 0.1281D+01, & + 0.1396D+01, 0.1486D+01, 0.1627D+01, 0.1625D+01, & + 0.1683D+01, 0.1702D+01, 0.1609D+01, 0.1446D+01 & + / + data (OREF(10, 6, mtmp), mtmp=1,12) & + / & + 0.9370D+00, 0.8700D+00, 0.8720D+00, 0.9190D+00, & + 0.1010D+01, 0.1124D+01, 0.1222D+01, 0.1224D+01, & + 0.1278D+01, 0.1238D+01, 0.1170D+01, 0.1011D+01 & + / + data (OREF(10, 7, mtmp), mtmp=1,12) & + / & + 0.6390D+00, 0.5830D+00, 0.5730D+00, 0.5960D+00, & + 0.6300D+00, 0.6670D+00, 0.7190D+00, 0.7450D+00, & + 0.8150D+00, 0.8000D+00, 0.7740D+00, 0.6990D+00 & + / + data (OREF(10, 8, mtmp), mtmp=1,12) & + / & + 0.4180D+00, 0.3930D+00, 0.3860D+00, 0.3890D+00, & + 0.3980D+00, 0.4110D+00, 0.4270D+00, 0.4490D+00, & + 0.4960D+00, 0.5040D+00, 0.4790D+00, 0.4490D+00 & + / + data (OREF(10, 9, mtmp), mtmp=1,12) & + / & + 0.3460D+00, 0.3400D+00, 0.3530D+00, 0.3610D+00, & + 0.3680D+00, 0.3830D+00, 0.3960D+00, 0.4360D+00, & + 0.4490D+00, 0.4140D+00, 0.3940D+00, 0.3710D+00 & + / + data (OREF(10,10, mtmp), mtmp=1,12) & + / & + 0.3270D+00, 0.3270D+00, 0.3560D+00, 0.3850D+00, & + 0.3930D+00, 0.4100D+00, 0.4310D+00, 0.4710D+00, & + 0.4610D+00, 0.3970D+00, 0.3690D+00, 0.3530D+00 & + / + data (OREF(10,11, mtmp), mtmp=1,12) & + / & + 0.3680D+00, 0.3710D+00, 0.4120D+00, 0.4760D+00, & + 0.5100D+00, 0.5200D+00, 0.5220D+00, 0.5400D+00, & + 0.5100D+00, 0.4350D+00, 0.4030D+00, 0.3830D+00 & + / + data (OREF(10,12, mtmp), mtmp=1,12) & + / & + 0.6500D+00, 0.6670D+00, 0.7280D+00, 0.8090D+00, & + 0.8330D+00, 0.7990D+00, 0.7470D+00, 0.7070D+00, & + 0.6560D+00, 0.5920D+00, 0.6040D+00, 0.6230D+00 & + / + data (OREF(10,13, mtmp), mtmp=1,12) & + / & + 0.1247D+01, 0.1340D+01, 0.1386D+01, 0.1350D+01, & + 0.1300D+01, 0.1168D+01, 0.1032D+01, 0.9250D+00, & + 0.8600D+00, 0.8140D+00, 0.9270D+00, 0.1072D+01 & + / + data (OREF(10,14, mtmp), mtmp=1,12) & + / & + 0.1795D+01, 0.2023D+01, 0.2046D+01, 0.1951D+01, & + 0.1819D+01, 0.1637D+01, 0.1440D+01, 0.1220D+01, & + 0.1153D+01, 0.1159D+01, 0.1350D+01, 0.1533D+01 & + / + data (OREF(10,15, mtmp), mtmp=1,12) & + / & + 0.2030D+01, 0.2158D+01, 0.2301D+01, 0.2246D+01, & + 0.2099D+01, 0.1937D+01, 0.1772D+01, 0.1569D+01, & + 0.1499D+01, 0.1509D+01, 0.1583D+01, 0.1795D+01 & + / + data (OREF(10,16, mtmp), mtmp=1,12) & + / & + 0.1972D+01, 0.2195D+01, 0.2368D+01, 0.2377D+01, & + 0.2266D+01, 0.2113D+01, 0.1935D+01, 0.1772D+01, & + 0.1714D+01, 0.1650D+01, 0.1753D+01, 0.1780D+01 & + / + data (OREF(10,17, mtmp), mtmp=1,12) & + / & + 0.1972D+01, 0.2329D+01, 0.2432D+01, 0.2456D+01, & + 0.2303D+01, 0.2145D+01, 0.1990D+01, 0.1963D+01, & + 0.1875D+01, 0.1706D+01, 0.1753D+01, 0.1780D+01 & + / + data (OREF(10,18, mtmp), mtmp=1,12) & + / & + 0.1972D+01, 0.2329D+01, 0.2432D+01, 0.2456D+01, & + 0.2303D+01, 0.2145D+01, 0.1990D+01, 0.1963D+01, & + 0.1875D+01, 0.1706D+01, 0.1753D+01, 0.1780D+01 & + / + data (OREF(11, 1, mtmp), mtmp=1,12) & + / & + 0.2954D+01, 0.2824D+01, 0.2609D+01, 0.2458D+01, & + 0.2547D+01, 0.2620D+01, 0.2691D+01, 0.2055D+01, & + 0.1986D+01, 0.2244D+01, 0.3059D+01, 0.3285D+01 & + / + data (OREF(11, 2, mtmp), mtmp=1,12) & + / & + 0.2954D+01, 0.2824D+01, 0.2609D+01, 0.2458D+01, & + 0.2547D+01, 0.2620D+01, 0.2691D+01, 0.2055D+01, & + 0.1986D+01, 0.2244D+01, 0.3059D+01, 0.3285D+01 & + / + data (OREF(11, 3, mtmp), mtmp=1,12) & + / & + 0.2970D+01, 0.2828D+01, 0.2679D+01, 0.2571D+01, & + 0.2547D+01, 0.2620D+01, 0.2691D+01, 0.2556D+01, & + 0.2612D+01, 0.3000D+01, 0.3300D+01, 0.3227D+01 & + / + data (OREF(11, 4, mtmp), mtmp=1,12) & + / & + 0.2795D+01, 0.2616D+01, 0.2546D+01, 0.2573D+01, & + 0.2546D+01, 0.2688D+01, 0.2843D+01, 0.2955D+01, & + 0.2937D+01, 0.3140D+01, 0.3133D+01, 0.2955D+01 & + / + data (OREF(11, 5, mtmp), mtmp=1,12) & + / & + 0.2335D+01, 0.2192D+01, 0.2197D+01, 0.2284D+01, & + 0.2467D+01, 0.2628D+01, 0.2779D+01, 0.2734D+01, & + 0.2723D+01, 0.2720D+01, 0.2661D+01, 0.2476D+01 & + / + data (OREF(11, 6, mtmp), mtmp=1,12) & + / & + 0.1715D+01, 0.1617D+01, 0.1629D+01, 0.1716D+01, & + 0.1873D+01, 0.2056D+01, 0.2192D+01, 0.2267D+01, & + 0.2281D+01, 0.2190D+01, 0.2052D+01, 0.1823D+01 & + / + data (OREF(11, 7, mtmp), mtmp=1,12) & + / & + 0.1236D+01, 0.1142D+01, 0.1132D+01, 0.1181D+01, & + 0.1261D+01, 0.1349D+01, 0.1437D+01, 0.1624D+01, & + 0.1678D+01, 0.1608D+01, 0.1454D+01, 0.1338D+01 & + / + data (OREF(11, 8, mtmp), mtmp=1,12) & + / & + 0.8750D+00, 0.8230D+00, 0.8120D+00, 0.8270D+00, & + 0.8590D+00, 0.9070D+00, 0.9420D+00, 0.1137D+01, & + 0.1182D+01, 0.1171D+01, 0.1004D+01, 0.9460D+00 & + / + data (OREF(11, 9, mtmp), mtmp=1,12) & + / & + 0.7360D+00, 0.7210D+00, 0.7480D+00, 0.7710D+00, & + 0.7950D+00, 0.8370D+00, 0.8610D+00, 0.1079D+01, & + 0.1080D+01, 0.1000D+01, 0.8500D+00, 0.7970D+00 & + / + data (OREF(11,10, mtmp), mtmp=1,12) & + / & + 0.7080D+00, 0.7020D+00, 0.7580D+00, 0.8220D+00, & + 0.8480D+00, 0.8850D+00, 0.9190D+00, 0.1130D+01, & + 0.1095D+01, 0.9710D+00, 0.8030D+00, 0.7680D+00 & + / + data (OREF(11,11, mtmp), mtmp=1,12) & + / & + 0.8080D+00, 0.7920D+00, 0.8610D+00, 0.9790D+00, & + 0.1039D+01, 0.1057D+01, 0.1050D+01, 0.1224D+01, & + 0.1170D+01, 0.1048D+01, 0.8680D+00, 0.8410D+00 & + / + data (OREF(11,12, mtmp), mtmp=1,12) & + / & + 0.1210D+01, 0.1202D+01, 0.1260D+01, 0.1364D+01, & + 0.1391D+01, 0.1343D+01, 0.1267D+01, 0.1381D+01, & + 0.1309D+01, 0.1233D+01, 0.1120D+01, 0.1172D+01 & + / + data (OREF(11,13, mtmp), mtmp=1,12) & + / & + 0.1882D+01, 0.1975D+01, 0.1998D+01, 0.1939D+01, & + 0.1867D+01, 0.1710D+01, 0.1548D+01, 0.1600D+01, & + 0.1528D+01, 0.1510D+01, 0.1496D+01, 0.1677D+01 & + / + data (OREF(11,14, mtmp), mtmp=1,12) & + / & + 0.2460D+01, 0.2757D+01, 0.2738D+01, 0.2589D+01, & + 0.2399D+01, 0.2167D+01, 0.1950D+01, 0.1896D+01, & + 0.1838D+01, 0.1900D+01, 0.1936D+01, 0.2129D+01 & + / + data (OREF(11,15, mtmp), mtmp=1,12) & + / & + 0.2690D+01, 0.2992D+01, 0.3192D+01, 0.3031D+01, & + 0.2779D+01, 0.2515D+01, 0.2298D+01, 0.2191D+01, & + 0.2138D+01, 0.2208D+01, 0.2121D+01, 0.2345D+01 & + / + data (OREF(11,16, mtmp), mtmp=1,12) & + / & + 0.2572D+01, 0.2956D+01, 0.3367D+01, 0.3313D+01, & + 0.3052D+01, 0.2703D+01, 0.2417D+01, 0.2284D+01, & + 0.2247D+01, 0.2212D+01, 0.2249D+01, 0.2269D+01 & + / + data (OREF(11,17, mtmp), mtmp=1,12) & + / & + 0.2572D+01, 0.3130D+01, 0.3381D+01, 0.3444D+01, & + 0.3111D+01, 0.2736D+01, 0.2398D+01, 0.2383D+01, & + 0.2274D+01, 0.2088D+01, 0.2249D+01, 0.2269D+01 & + / + data (OREF(11,18, mtmp), mtmp=1,12) & + / & + 0.2572D+01, 0.3130D+01, 0.3381D+01, 0.3444D+01, & + 0.3111D+01, 0.2736D+01, 0.2398D+01, 0.2383D+01, & + 0.2274D+01, 0.2088D+01, 0.2249D+01, 0.2269D+01 & + / + data (OREF(12, 1, mtmp), mtmp=1,12) & + / & + 0.3837D+01, 0.3720D+01, 0.3521D+01, 0.3344D+01, & + 0.3463D+01, 0.3567D+01, 0.3612D+01, 0.2564D+01, & + 0.2527D+01, 0.2850D+01, 0.4050D+01, 0.4145D+01 & + / + data (OREF(12, 2, mtmp), mtmp=1,12) & + / & + 0.3837D+01, 0.3720D+01, 0.3521D+01, 0.3344D+01, & + 0.3463D+01, 0.3567D+01, 0.3612D+01, 0.2564D+01, & + 0.2527D+01, 0.2850D+01, 0.4050D+01, 0.4145D+01 & + / + data (OREF(12, 3, mtmp), mtmp=1,12) & + / & + 0.3890D+01, 0.3788D+01, 0.3663D+01, 0.3527D+01, & + 0.3463D+01, 0.3567D+01, 0.3612D+01, 0.3361D+01, & + 0.3383D+01, 0.3864D+01, 0.4293D+01, 0.4143D+01 & + / + data (OREF(12, 4, mtmp), mtmp=1,12) & + / & + 0.3810D+01, 0.3625D+01, 0.3561D+01, 0.3627D+01, & + 0.3600D+01, 0.3702D+01, 0.3851D+01, 0.3964D+01, & + 0.3896D+01, 0.4126D+01, 0.4155D+01, 0.3976D+01 & + / + data (OREF(12, 5, mtmp), mtmp=1,12) & + / & + 0.3366D+01, 0.3206D+01, 0.3209D+01, 0.3320D+01, & + 0.3578D+01, 0.3807D+01, 0.3941D+01, 0.3869D+01, & + 0.3818D+01, 0.3802D+01, 0.3715D+01, 0.3516D+01 & + / + data (OREF(12, 6, mtmp), mtmp=1,12) & + / & + 0.2737D+01, 0.2627D+01, 0.2648D+01, 0.2764D+01, & + 0.2969D+01, 0.3198D+01, 0.3345D+01, 0.3476D+01, & + 0.3458D+01, 0.3328D+01, 0.3124D+01, 0.2857D+01 & + / + data (OREF(12, 7, mtmp), mtmp=1,12) & + / & + 0.2240D+01, 0.2115D+01, 0.2108D+01, 0.2190D+01, & + 0.2318D+01, 0.2456D+01, 0.2566D+01, 0.2838D+01, & + 0.2870D+01, 0.2755D+01, 0.2523D+01, 0.2379D+01 & + / + data (OREF(12, 8, mtmp), mtmp=1,12) & + / & + 0.1844D+01, 0.1752D+01, 0.1737D+01, 0.1775D+01, & + 0.1848D+01, 0.1948D+01, 0.2003D+01, 0.2282D+01, & + 0.2321D+01, 0.2288D+01, 0.2054D+01, 0.1971D+01 & + / + data (OREF(12, 9, mtmp), mtmp=1,12) & + / & + 0.1632D+01, 0.1590D+01, 0.1635D+01, 0.1695D+01, & + 0.1755D+01, 0.1840D+01, 0.1872D+01, 0.2187D+01, & + 0.2175D+01, 0.2044D+01, 0.1837D+01, 0.1753D+01 & + / + data (OREF(12,10, mtmp), mtmp=1,12) & + / & + 0.1592D+01, 0.1561D+01, 0.1656D+01, 0.1785D+01, & + 0.1850D+01, 0.1920D+01, 0.1967D+01, 0.2265D+01, & + 0.2203D+01, 0.2010D+01, 0.1763D+01, 0.1709D+01 & + / + data (OREF(12,11, mtmp), mtmp=1,12) & + / & + 0.1763D+01, 0.1711D+01, 0.1816D+01, 0.2010D+01, & + 0.2111D+01, 0.2147D+01, 0.2133D+01, 0.2374D+01, & + 0.2299D+01, 0.2125D+01, 0.1862D+01, 0.1831D+01 & + / + data (OREF(12,12, mtmp), mtmp=1,12) & + / & + 0.2247D+01, 0.2202D+01, 0.2256D+01, 0.2386D+01, & + 0.2414D+01, 0.2358D+01, 0.2264D+01, 0.2462D+01, & + 0.2373D+01, 0.2286D+01, 0.2111D+01, 0.2198D+01 & + / + data (OREF(12,13, mtmp), mtmp=1,12) & + / & + 0.2912D+01, 0.2978D+01, 0.2965D+01, 0.2883D+01, & + 0.2798D+01, 0.2633D+01, 0.2463D+01, 0.2623D+01, & + 0.2550D+01, 0.2553D+01, 0.2470D+01, 0.2689D+01 & + / + data (OREF(12,14, mtmp), mtmp=1,12) & + / & + 0.3415D+01, 0.3728D+01, 0.3638D+01, 0.3437D+01, & + 0.3218D+01, 0.2967D+01, 0.2760D+01, 0.2837D+01, & + 0.2790D+01, 0.2896D+01, 0.2858D+01, 0.3065D+01 & + / + data (OREF(12,15, mtmp), mtmp=1,12) & + / & + 0.3524D+01, 0.3991D+01, 0.4184D+01, 0.3898D+01, & + 0.3575D+01, 0.3252D+01, 0.3010D+01, 0.2970D+01, & + 0.2937D+01, 0.3075D+01, 0.2929D+01, 0.3120D+01 & + / + data (OREF(12,16, mtmp), mtmp=1,12) & + / & + 0.3301D+01, 0.3816D+01, 0.4424D+01, 0.4232D+01, & + 0.3825D+01, 0.3329D+01, 0.2978D+01, 0.2859D+01, & + 0.2852D+01, 0.2889D+01, 0.2894D+01, 0.2935D+01 & + / + data (OREF(12,17, mtmp), mtmp=1,12) & + / & + 0.3301D+01, 0.3977D+01, 0.4339D+01, 0.4350D+01, & + 0.3822D+01, 0.3290D+01, 0.2822D+01, 0.2789D+01, & + 0.2684D+01, 0.2541D+01, 0.2894D+01, 0.2935D+01 & + / + data (OREF(12,18, mtmp), mtmp=1,12) & + / & + 0.3301D+01, 0.3977D+01, 0.4339D+01, 0.4350D+01, & + 0.3822D+01, 0.3290D+01, 0.2822D+01, 0.2789D+01, & + 0.2684D+01, 0.2541D+01, 0.2894D+01, 0.2935D+01 & + / + data (OREF(13, 1, mtmp), mtmp=1,12) & + / & + 0.4110D+01, 0.3985D+01, 0.3962D+01, 0.3720D+01, & + 0.4022D+01, 0.4120D+01, 0.4112D+01, 0.3033D+01, & + 0.2985D+01, 0.3466D+01, 0.4597D+01, 0.4500D+01 & + / + data (OREF(13, 2, mtmp), mtmp=1,12) & + / & + 0.4110D+01, 0.3985D+01, 0.3962D+01, 0.3720D+01, & + 0.4022D+01, 0.4120D+01, 0.4112D+01, 0.3033D+01, & + 0.2985D+01, 0.3466D+01, 0.4597D+01, 0.4500D+01 & + / + data (OREF(13, 3, mtmp), mtmp=1,12) & + / & + 0.4282D+01, 0.4210D+01, 0.4167D+01, 0.4114D+01, & + 0.4022D+01, 0.4120D+01, 0.4112D+01, 0.3907D+01, & + 0.3942D+01, 0.4605D+01, 0.4868D+01, 0.4588D+01 & + / + data (OREF(13, 4, mtmp), mtmp=1,12) & + / & + 0.4407D+01, 0.4205D+01, 0.4144D+01, 0.4313D+01, & + 0.4404D+01, 0.4408D+01, 0.4531D+01, 0.4603D+01, & + 0.4619D+01, 0.4946D+01, 0.4831D+01, 0.4607D+01 & + / + data (OREF(13, 5, mtmp), mtmp=1,12) & + / & + 0.4114D+01, 0.3966D+01, 0.3960D+01, 0.4074D+01, & + 0.4404D+01, 0.4674D+01, 0.4777D+01, 0.4709D+01, & + 0.4714D+01, 0.4721D+01, 0.4477D+01, 0.4250D+01 & + / + data (OREF(13, 6, mtmp), mtmp=1,12) & + / & + 0.3874D+01, 0.3796D+01, 0.3816D+01, 0.3926D+01, & + 0.4122D+01, 0.4333D+01, 0.4442D+01, 0.4540D+01, & + 0.4543D+01, 0.4424D+01, 0.4193D+01, 0.3962D+01 & + / + data (OREF(13, 7, mtmp), mtmp=1,12) & + / & + 0.3741D+01, 0.3619D+01, 0.3618D+01, 0.3718D+01, & + 0.3864D+01, 0.4007D+01, 0.4095D+01, 0.4181D+01, & + 0.4209D+01, 0.4112D+01, 0.3995D+01, 0.3876D+01 & + / + data (OREF(13, 8, mtmp), mtmp=1,12) & + / & + 0.3597D+01, 0.3463D+01, 0.3442D+01, 0.3515D+01, & + 0.3638D+01, 0.3782D+01, 0.3845D+01, 0.3858D+01, & + 0.3902D+01, 0.3864D+01, 0.3849D+01, 0.3776D+01 & + / + data (OREF(13, 9, mtmp), mtmp=1,12) & + / & + 0.3352D+01, 0.3261D+01, 0.3320D+01, 0.3443D+01, & + 0.3560D+01, 0.3687D+01, 0.3716D+01, 0.3787D+01, & + 0.3783D+01, 0.3624D+01, 0.3635D+01, 0.3546D+01 & + / + data (OREF(13,10, mtmp), mtmp=1,12) & + / & + 0.3296D+01, 0.3215D+01, 0.3350D+01, 0.3570D+01, & + 0.3700D+01, 0.3804D+01, 0.3858D+01, 0.3913D+01, & + 0.3842D+01, 0.3599D+01, 0.3543D+01, 0.3489D+01 & + / + data (OREF(13,11, mtmp), mtmp=1,12) & + / & + 0.3508D+01, 0.3408D+01, 0.3550D+01, 0.3820D+01, & + 0.3963D+01, 0.4030D+01, 0.4020D+01, 0.4013D+01, & + 0.3935D+01, 0.3723D+01, 0.3657D+01, 0.3627D+01 & + / + data (OREF(13,12, mtmp), mtmp=1,12) & + / & + 0.3953D+01, 0.3880D+01, 0.3941D+01, 0.4090D+01, & + 0.4117D+01, 0.4073D+01, 0.3991D+01, 0.3979D+01, & + 0.3888D+01, 0.3782D+01, 0.3804D+01, 0.3896D+01 & + / + data (OREF(13,13, mtmp), mtmp=1,12) & + / & + 0.4507D+01, 0.4517D+01, 0.4467D+01, 0.4375D+01, & + 0.4303D+01, 0.4167D+01, 0.4032D+01, 0.4029D+01, & + 0.3959D+01, 0.3933D+01, 0.4040D+01, 0.4290D+01 & + / + data (OREF(13,14, mtmp), mtmp=1,12) & + / & + 0.4813D+01, 0.5030D+01, 0.4852D+01, 0.4627D+01, & + 0.4462D+01, 0.4272D+01, 0.4117D+01, 0.4078D+01, & + 0.4028D+01, 0.4114D+01, 0.4312D+01, 0.4552D+01 & + / + data (OREF(13,15, mtmp), mtmp=1,12) & + / & + 0.4619D+01, 0.5133D+01, 0.5205D+01, 0.4826D+01, & + 0.4538D+01, 0.4281D+01, 0.4084D+01, 0.3954D+01, & + 0.3932D+01, 0.4112D+01, 0.4202D+01, 0.4301D+01 & + / + data (OREF(13,16, mtmp), mtmp=1,12) & + / & + 0.4242D+01, 0.4741D+01, 0.5360D+01, 0.4970D+01, & + 0.4505D+01, 0.4039D+01, 0.3739D+01, 0.3575D+01, & + 0.3598D+01, 0.3753D+01, 0.3834D+01, 0.3955D+01 & + / + data (OREF(13,17, mtmp), mtmp=1,12) & + / & + 0.4242D+01, 0.4803D+01, 0.5119D+01, 0.4942D+01, & + 0.4278D+01, 0.3788D+01, 0.3364D+01, 0.3276D+01, & + 0.3221D+01, 0.3210D+01, 0.3834D+01, 0.3955D+01 & + / + data (OREF(13,18, mtmp), mtmp=1,12) & + / & + 0.4242D+01, 0.4803D+01, 0.5119D+01, 0.4942D+01, & + 0.4278D+01, 0.3788D+01, 0.3364D+01, 0.3276D+01, & + 0.3221D+01, 0.3210D+01, 0.3834D+01, 0.3955D+01 & + / + data (OREF(14, 1, mtmp), mtmp=1,12) & + / & + 0.4052D+01, 0.3894D+01, 0.4082D+01, 0.3775D+01, & + 0.4316D+01, 0.4387D+01, 0.4329D+01, 0.3511D+01, & + 0.3421D+01, 0.4120D+01, 0.4856D+01, 0.4553D+01 & + / + data (OREF(14, 2, mtmp), mtmp=1,12) & + / & + 0.4052D+01, 0.3894D+01, 0.4082D+01, 0.3775D+01, & + 0.4316D+01, 0.4387D+01, 0.4329D+01, 0.3511D+01, & + 0.3421D+01, 0.4120D+01, 0.4856D+01, 0.4553D+01 & + / + data (OREF(14, 3, mtmp), mtmp=1,12) & + / & + 0.4388D+01, 0.4321D+01, 0.4347D+01, 0.4408D+01, & + 0.4316D+01, 0.4387D+01, 0.4329D+01, 0.4254D+01, & + 0.4340D+01, 0.5222D+01, 0.5177D+01, 0.4762D+01 & + / + data (OREF(14, 4, mtmp), mtmp=1,12) & + / & + 0.4784D+01, 0.4553D+01, 0.4458D+01, 0.4714D+01, & + 0.4958D+01, 0.4846D+01, 0.4928D+01, 0.4932D+01, & + 0.5131D+01, 0.5601D+01, 0.5290D+01, 0.5026D+01 & + / + data (OREF(14, 5, mtmp), mtmp=1,12) & + / & + 0.4755D+01, 0.4623D+01, 0.4568D+01, 0.4631D+01, & + 0.4970D+01, 0.5237D+01, 0.5306D+01, 0.5275D+01, & + 0.5408D+01, 0.5478D+01, 0.5082D+01, 0.4864D+01 & + / + data (OREF(14, 6, mtmp), mtmp=1,12) & + / & + 0.5123D+01, 0.5089D+01, 0.5071D+01, 0.5106D+01, & + 0.5201D+01, 0.5338D+01, 0.5382D+01, 0.5401D+01, & + 0.5475D+01, 0.5429D+01, 0.5266D+01, 0.5153D+01 & + / + data (OREF(14, 7, mtmp), mtmp=1,12) & + / & + 0.5566D+01, 0.5486D+01, 0.5481D+01, 0.5551D+01, & + 0.5627D+01, 0.5691D+01, 0.5717D+01, 0.5480D+01, & + 0.5546D+01, 0.5544D+01, 0.5704D+01, 0.5651D+01 & + / + data (OREF(14, 8, mtmp), mtmp=1,12) & + / & + 0.5882D+01, 0.5742D+01, 0.5735D+01, 0.5817D+01, & + 0.5929D+01, 0.6028D+01, 0.6071D+01, 0.5647D+01, & + 0.5724D+01, 0.5707D+01, 0.6090D+01, 0.6053D+01 & + / + data (OREF(14, 9, mtmp), mtmp=1,12) & + / & + 0.5687D+01, 0.5572D+01, 0.5663D+01, 0.5836D+01, & + 0.5957D+01, 0.6052D+01, 0.6062D+01, 0.5700D+01, & + 0.5735D+01, 0.5597D+01, 0.5977D+01, 0.5910D+01 & + / + data (OREF(14,10, mtmp), mtmp=1,12) & + / & + 0.5587D+01, 0.5488D+01, 0.5679D+01, 0.5956D+01, & + 0.6114D+01, 0.6208D+01, 0.6261D+01, 0.5894D+01, & + 0.5850D+01, 0.5612D+01, 0.5893D+01, 0.5830D+01 & + / + data (OREF(14,11, mtmp), mtmp=1,12) & + / & + 0.5700D+01, 0.5616D+01, 0.5799D+01, 0.6087D+01, & + 0.6250D+01, 0.6338D+01, 0.6355D+01, 0.5944D+01, & + 0.5889D+01, 0.5668D+01, 0.5941D+01, 0.5867D+01 & + / + data (OREF(14,12, mtmp), mtmp=1,12) & + / & + 0.5909D+01, 0.5877D+01, 0.5981D+01, 0.6141D+01, & + 0.6177D+01, 0.6162D+01, 0.6125D+01, 0.5739D+01, & + 0.5663D+01, 0.5532D+01, 0.5848D+01, 0.5861D+01 & + / + data (OREF(14,13, mtmp), mtmp=1,12) & + / & + 0.6206D+01, 0.6169D+01, 0.6143D+01, 0.6104D+01, & + 0.6094D+01, 0.6022D+01, 0.5953D+01, 0.5622D+01, & + 0.5551D+01, 0.5432D+01, 0.5805D+01, 0.6032D+01 & + / + data (OREF(14,14, mtmp), mtmp=1,12) & + / & + 0.6233D+01, 0.6299D+01, 0.6085D+01, 0.5920D+01, & + 0.5897D+01, 0.5824D+01, 0.5747D+01, 0.5428D+01, & + 0.5344D+01, 0.5322D+01, 0.5846D+01, 0.6106D+01 & + / + data (OREF(14,15, mtmp), mtmp=1,12) & + / & + 0.5709D+01, 0.6163D+01, 0.6065D+01, 0.5686D+01, & + 0.5538D+01, 0.5428D+01, 0.5313D+01, 0.4994D+01, & + 0.4947D+01, 0.5105D+01, 0.5549D+01, 0.5534D+01 & + / + data (OREF(14,16, mtmp), mtmp=1,12) & + / & + 0.5211D+01, 0.5616D+01, 0.6063D+01, 0.5508D+01, & + 0.5077D+01, 0.4751D+01, 0.4573D+01, 0.4325D+01, & + 0.4349D+01, 0.4617D+01, 0.4839D+01, 0.5054D+01 & + / + data (OREF(14,17, mtmp), mtmp=1,12) & + / & + 0.5211D+01, 0.5559D+01, 0.5719D+01, 0.5287D+01, & + 0.4553D+01, 0.4218D+01, 0.3945D+01, 0.3763D+01, & + 0.3773D+01, 0.3946D+01, 0.4839D+01, 0.5054D+01 & + / + data (OREF(14,18, mtmp), mtmp=1,12) & + / & + 0.5211D+01, 0.5559D+01, 0.5719D+01, 0.5287D+01, & + 0.4553D+01, 0.4218D+01, 0.3945D+01, 0.3763D+01, & + 0.3773D+01, 0.3946D+01, 0.4839D+01, 0.5054D+01 & + / + data (OREF(15, 1, mtmp), mtmp=1,12) & + / & + 0.4175D+01, 0.3941D+01, 0.4215D+01, 0.3916D+01, & + 0.4611D+01, 0.4665D+01, 0.4601D+01, 0.4134D+01, & + 0.4009D+01, 0.4901D+01, 0.5197D+01, 0.4691D+01 & + / + data (OREF(15, 2, mtmp), mtmp=1,12) & + / & + 0.4175D+01, 0.3941D+01, 0.4215D+01, 0.3916D+01, & + 0.4611D+01, 0.4665D+01, 0.4601D+01, 0.4134D+01, & + 0.4009D+01, 0.4901D+01, 0.5197D+01, 0.4691D+01 & + / + data (OREF(15, 3, mtmp), mtmp=1,12) & + / & + 0.4725D+01, 0.4624D+01, 0.4582D+01, 0.4651D+01, & + 0.4611D+01, 0.4665D+01, 0.4601D+01, 0.4584D+01, & + 0.4743D+01, 0.5783D+01, 0.5580D+01, 0.5086D+01 & + / + data (OREF(15, 4, mtmp), mtmp=1,12) & + / & + 0.5463D+01, 0.5199D+01, 0.4964D+01, 0.5117D+01, & + 0.5386D+01, 0.5202D+01, 0.5222D+01, 0.5156D+01, & + 0.5576D+01, 0.6177D+01, 0.5892D+01, 0.5695D+01 & + / + data (OREF(15, 5, mtmp), mtmp=1,12) & + / & + 0.5842D+01, 0.5677D+01, 0.5456D+01, 0.5322D+01, & + 0.5482D+01, 0.5659D+01, 0.5701D+01, 0.5738D+01, & + 0.6021D+01, 0.6204D+01, 0.5961D+01, 0.5921D+01 & + / + data (OREF(15, 6, mtmp), mtmp=1,12) & + / & + 0.6559D+01, 0.6505D+01, 0.6356D+01, 0.6204D+01, & + 0.6064D+01, 0.6108D+01, 0.6104D+01, 0.6113D+01, & + 0.6284D+01, 0.6391D+01, 0.6487D+01, 0.6564D+01 & + / + data (OREF(15, 7, mtmp), mtmp=1,12) & + / & + 0.7222D+01, 0.7201D+01, 0.7155D+01, 0.7105D+01, & + 0.6973D+01, 0.6858D+01, 0.6819D+01, 0.6527D+01, & + 0.6688D+01, 0.6851D+01, 0.7248D+01, 0.7241D+01 & + / + data (OREF(15, 8, mtmp), mtmp=1,12) & + / & + 0.7794D+01, 0.7746D+01, 0.7807D+01, 0.7814D+01, & + 0.7750D+01, 0.7621D+01, 0.7606D+01, 0.7171D+01, & + 0.7323D+01, 0.7356D+01, 0.7870D+01, 0.7849D+01 & + / + data (OREF(15, 9, mtmp), mtmp=1,12) & + / & + 0.7735D+01, 0.7724D+01, 0.7923D+01, 0.8051D+01, & + 0.7998D+01, 0.7889D+01, 0.7866D+01, 0.7463D+01, & + 0.7569D+01, 0.7510D+01, 0.7929D+01, 0.7866D+01 & + / + data (OREF(15,10, mtmp), mtmp=1,12) & + / & + 0.7529D+01, 0.7559D+01, 0.7863D+01, 0.8068D+01, & + 0.8115D+01, 0.8089D+01, 0.8135D+01, 0.7737D+01, & + 0.7762D+01, 0.7612D+01, 0.7895D+01, 0.7737D+01 & + / + data (OREF(15,11, mtmp), mtmp=1,12) & + / & + 0.7299D+01, 0.7403D+01, 0.7650D+01, 0.7850D+01, & + 0.7979D+01, 0.8044D+01, 0.8108D+01, 0.7681D+01, & + 0.7674D+01, 0.7476D+01, 0.7724D+01, 0.7480D+01 & + / + data (OREF(15,12, mtmp), mtmp=1,12) & + / & + 0.7111D+01, 0.7243D+01, 0.7462D+01, 0.7637D+01, & + 0.7715D+01, 0.7725D+01, 0.7728D+01, 0.7276D+01, & + 0.7228D+01, 0.7068D+01, 0.7289D+01, 0.7106D+01 & + / + data (OREF(15,13, mtmp), mtmp=1,12) & + / & + 0.7060D+01, 0.7045D+01, 0.7177D+01, 0.7306D+01, & + 0.7418D+01, 0.7406D+01, 0.7379D+01, 0.6960D+01, & + 0.6868D+01, 0.6600D+01, 0.6834D+01, 0.6948D+01 & + / + data (OREF(15,14, mtmp), mtmp=1,12) & + / & + 0.6879D+01, 0.6882D+01, 0.6765D+01, 0.6802D+01, & + 0.6962D+01, 0.6964D+01, 0.6922D+01, 0.6483D+01, & + 0.6317D+01, 0.6101D+01, 0.6525D+01, 0.6755D+01 & + / + data (OREF(15,15, mtmp), mtmp=1,12) & + / & + 0.6305D+01, 0.6687D+01, 0.6486D+01, 0.6276D+01, & + 0.6325D+01, 0.6306D+01, 0.6216D+01, 0.5788D+01, & + 0.5642D+01, 0.5671D+01, 0.6164D+01, 0.6115D+01 & + / + data (OREF(15,16, mtmp), mtmp=1,12) & + / & + 0.5851D+01, 0.6275D+01, 0.6426D+01, 0.5884D+01, & + 0.5566D+01, 0.5324D+01, 0.5203D+01, 0.4896D+01, & + 0.4834D+01, 0.5115D+01, 0.5422D+01, 0.5655D+01 & + / + data (OREF(15,17, mtmp), mtmp=1,12) & + / & + 0.5851D+01, 0.6205D+01, 0.6205D+01, 0.5565D+01, & + 0.4820D+01, 0.4592D+01, 0.4394D+01, 0.4099D+01, & + 0.4113D+01, 0.4415D+01, 0.5422D+01, 0.5655D+01 & + / + data (OREF(15,18, mtmp), mtmp=1,12) & + / & + 0.5851D+01, 0.6205D+01, 0.6205D+01, 0.5565D+01, & + 0.4820D+01, 0.4592D+01, 0.4394D+01, 0.4099D+01, & + 0.4113D+01, 0.4415D+01, 0.5422D+01, 0.5655D+01 & + / + data (OREF(16, 1, mtmp), mtmp=1,12) & + / & + 0.4487D+01, 0.4140D+01, 0.4381D+01, 0.4154D+01, & + 0.4923D+01, 0.4971D+01, 0.4939D+01, 0.4856D+01, & + 0.4709D+01, 0.5734D+01, 0.5610D+01, 0.4930D+01 & + / + data (OREF(16, 2, mtmp), mtmp=1,12) & + / & + 0.4487D+01, 0.4140D+01, 0.4381D+01, 0.4154D+01, & + 0.4923D+01, 0.4971D+01, 0.4939D+01, 0.4856D+01, & + 0.4709D+01, 0.5734D+01, 0.5610D+01, 0.4930D+01 & + / + data (OREF(16, 3, mtmp), mtmp=1,12) & + / & + 0.5283D+01, 0.5123D+01, 0.4893D+01, 0.4867D+01, & + 0.4923D+01, 0.4971D+01, 0.4939D+01, 0.4905D+01, & + 0.5159D+01, 0.6277D+01, 0.6065D+01, 0.5555D+01 & + / + data (OREF(16, 4, mtmp), mtmp=1,12) & + / & + 0.6390D+01, 0.6110D+01, 0.5657D+01, 0.5538D+01, & + 0.5705D+01, 0.5491D+01, 0.5440D+01, 0.5321D+01, & + 0.5978D+01, 0.6677D+01, 0.6606D+01, 0.6561D+01 & + / + data (OREF(16, 5, mtmp), mtmp=1,12) & + / & + 0.7263D+01, 0.7035D+01, 0.6570D+01, 0.6126D+01, & + 0.5949D+01, 0.5969D+01, 0.5993D+01, 0.6127D+01, & + 0.6564D+01, 0.6885D+01, 0.7053D+01, 0.7314D+01 & + / + data (OREF(16, 6, mtmp), mtmp=1,12) & + / & + 0.8008D+01, 0.7878D+01, 0.7543D+01, 0.7137D+01, & + 0.6687D+01, 0.6636D+01, 0.6609D+01, 0.6677D+01, & + 0.6959D+01, 0.7269D+01, 0.7744D+01, 0.8029D+01 & + / + data (OREF(16, 7, mtmp), mtmp=1,12) & + / & + 0.8506D+01, 0.8537D+01, 0.8424D+01, 0.8203D+01, & + 0.7791D+01, 0.7453D+01, 0.7365D+01, 0.7272D+01, & + 0.7570D+01, 0.7927D+01, 0.8456D+01, 0.8459D+01 & + / + data (OREF(16, 8, mtmp), mtmp=1,12) & + / & + 0.9077D+01, 0.9181D+01, 0.9328D+01, 0.9193D+01, & + 0.8855D+01, 0.8409D+01, 0.8327D+01, 0.8268D+01, & + 0.8520D+01, 0.8619D+01, 0.8977D+01, 0.8945D+01 & + / + data (OREF(16, 9, mtmp), mtmp=1,12) & + / & + 0.9183D+01, 0.9370D+01, 0.9696D+01, 0.9687D+01, & + 0.9349D+01, 0.8953D+01, 0.8903D+01, 0.8838D+01, & + 0.9026D+01, 0.9077D+01, 0.9206D+01, 0.9130D+01 & + / + data (OREF(16,10, mtmp), mtmp=1,12) & + / & + 0.8836D+01, 0.9100D+01, 0.9524D+01, 0.9550D+01, & + 0.9393D+01, 0.9195D+01, 0.9239D+01, 0.9181D+01, & + 0.9297D+01, 0.9278D+01, 0.9232D+01, 0.8933D+01 & + / + data (OREF(16,11, mtmp), mtmp=1,12) & + / & + 0.8141D+01, 0.8539D+01, 0.8852D+01, 0.8894D+01, & + 0.8957D+01, 0.8968D+01, 0.9087D+01, 0.9001D+01, & + 0.9050D+01, 0.8891D+01, 0.8775D+01, 0.8300D+01 & + / + data (OREF(16,12, mtmp), mtmp=1,12) & + / & + 0.7534D+01, 0.7896D+01, 0.8260D+01, 0.8450D+01, & + 0.8588D+01, 0.8613D+01, 0.8640D+01, 0.8421D+01, & + 0.8407D+01, 0.8219D+01, 0.8009D+01, 0.7584D+01 & + / + data (OREF(16,13, mtmp), mtmp=1,12) & + / & + 0.7151D+01, 0.7210D+01, 0.7577D+01, 0.7927D+01, & + 0.8181D+01, 0.8207D+01, 0.8186D+01, 0.7923D+01, & + 0.7797D+01, 0.7362D+01, 0.7137D+01, 0.7100D+01 & + / + data (OREF(16,14, mtmp), mtmp=1,12) & + / & + 0.6863D+01, 0.6887D+01, 0.6955D+01, 0.7273D+01, & + 0.7609D+01, 0.7628D+01, 0.7572D+01, 0.7190D+01, & + 0.6916D+01, 0.6467D+01, 0.6465D+01, 0.6639D+01 & + / + data (OREF(16,15, mtmp), mtmp=1,12) & + / & + 0.6457D+01, 0.6775D+01, 0.6554D+01, 0.6626D+01, & + 0.6883D+01, 0.6881D+01, 0.6762D+01, 0.6322D+01, & + 0.6029D+01, 0.5857D+01, 0.6142D+01, 0.6130D+01 & + / + data (OREF(16,16, mtmp), mtmp=1,12) & + / & + 0.6168D+01, 0.6694D+01, 0.6514D+01, 0.6133D+01, & + 0.5981D+01, 0.5755D+01, 0.5626D+01, 0.5293D+01, & + 0.5080D+01, 0.5285D+01, 0.5612D+01, 0.5802D+01 & + / + data (OREF(16,17, mtmp), mtmp=1,12) & + / & + 0.6168D+01, 0.6708D+01, 0.6573D+01, 0.5796D+01, & + 0.5096D+01, 0.4922D+01, 0.4720D+01, 0.4306D+01, & + 0.4269D+01, 0.4631D+01, 0.5612D+01, 0.5802D+01 & + / + data (OREF(16,18, mtmp), mtmp=1,12) & + / & + 0.6168D+01, 0.6708D+01, 0.6573D+01, 0.5796D+01, & + 0.5096D+01, 0.4922D+01, 0.4720D+01, 0.4306D+01, & + 0.4269D+01, 0.4631D+01, 0.5612D+01, 0.5802D+01 & + / + data (OREF(17, 1, mtmp), mtmp=1,12) & + / & + 0.5011D+01, 0.4535D+01, 0.4643D+01, 0.4473D+01, & + 0.5290D+01, 0.5348D+01, 0.5352D+01, 0.5458D+01, & + 0.5286D+01, 0.6352D+01, 0.6067D+01, 0.5393D+01 & + / + data (OREF(17, 2, mtmp), mtmp=1,12) & + / & + 0.5011D+01, 0.4535D+01, 0.4643D+01, 0.4473D+01, & + 0.5290D+01, 0.5348D+01, 0.5352D+01, 0.5458D+01, & + 0.5286D+01, 0.6352D+01, 0.6067D+01, 0.5393D+01 & + / + data (OREF(17, 3, mtmp), mtmp=1,12) & + / & + 0.5965D+01, 0.5767D+01, 0.5346D+01, 0.5173D+01, & + 0.5290D+01, 0.5348D+01, 0.5352D+01, 0.5279D+01, & + 0.5679D+01, 0.6792D+01, 0.6618D+01, 0.6154D+01 & + / + data (OREF(17, 4, mtmp), mtmp=1,12) & + / & + 0.7258D+01, 0.7004D+01, 0.6413D+01, 0.6038D+01, & + 0.6024D+01, 0.5770D+01, 0.5708D+01, 0.5678D+01, & + 0.6541D+01, 0.7257D+01, 0.7343D+01, 0.7374D+01 & + / + data (OREF(17, 5, mtmp), mtmp=1,12) & + / & + 0.8374D+01, 0.8138D+01, 0.7564D+01, 0.6911D+01, & + 0.6460D+01, 0.6336D+01, 0.6363D+01, 0.6648D+01, & + 0.7213D+01, 0.7634D+01, 0.8069D+01, 0.8429D+01 & + / + data (OREF(17, 6, mtmp), mtmp=1,12) & + / & + 0.9065D+01, 0.8891D+01, 0.8465D+01, 0.7920D+01, & + 0.7275D+01, 0.7149D+01, 0.7113D+01, 0.7291D+01, & + 0.7693D+01, 0.8164D+01, 0.8811D+01, 0.9119D+01 & + / + data (OREF(17, 7, mtmp), mtmp=1,12) & + / & + 0.9433D+01, 0.9470D+01, 0.9293D+01, 0.8970D+01, & + 0.8399D+01, 0.7916D+01, 0.7828D+01, 0.7962D+01, & + 0.8395D+01, 0.8887D+01, 0.9372D+01, 0.9338D+01 & + / + data (OREF(17, 8, mtmp), mtmp=1,12) & + / & + 0.9957D+01, 0.1014D+02, 0.1025D+02, 0.9972D+01, & + 0.9471D+01, 0.8867D+01, 0.8792D+01, 0.9059D+01, & + 0.9409D+01, 0.9573D+01, 0.9720D+01, 0.9673D+01 & + / + data (OREF(17, 9, mtmp), mtmp=1,12) & + / & + 0.1012D+02, 0.1046D+02, 0.1073D+02, 0.1052D+02, & + 0.1002D+02, 0.9527D+01, 0.9520D+01, 0.9739D+01, & + 0.9990D+01, 0.1009D+02, 0.9950D+01, 0.9870D+01 & + / + data (OREF(17,10, mtmp), mtmp=1,12) & + / & + 0.9660D+01, 0.1011D+02, 0.1050D+02, 0.1032D+02, & + 0.1004D+02, 0.9793D+01, 0.9875D+01, 0.1009D+02, & + 0.1027D+02, 0.1028D+02, 0.9944D+01, 0.9592D+01 & + / + data (OREF(17,11, mtmp), mtmp=1,12) & + / & + 0.8715D+01, 0.9324D+01, 0.9627D+01, 0.9546D+01, & + 0.9564D+01, 0.9540D+01, 0.9690D+01, 0.9867D+01, & + 0.9954D+01, 0.9800D+01, 0.9363D+01, 0.8788D+01 & + / + data (OREF(17,12, mtmp), mtmp=1,12) & + / & + 0.7870D+01, 0.8413D+01, 0.8836D+01, 0.9016D+01, & + 0.9186D+01, 0.9212D+01, 0.9248D+01, 0.9256D+01, & + 0.9282D+01, 0.9063D+01, 0.8481D+01, 0.7920D+01 & + / + data (OREF(17,13, mtmp), mtmp=1,12) & + / & + 0.7262D+01, 0.7432D+01, 0.7986D+01, 0.8466D+01, & + 0.8776D+01, 0.8794D+01, 0.8758D+01, 0.8690D+01, & + 0.8547D+01, 0.8009D+01, 0.7402D+01, 0.7249D+01 & + / + data (OREF(17,14, mtmp), mtmp=1,12) & + / & + 0.6858D+01, 0.6948D+01, 0.7258D+01, 0.7803D+01, & + 0.8197D+01, 0.8182D+01, 0.8098D+01, 0.7863D+01, & + 0.7519D+01, 0.6880D+01, 0.6481D+01, 0.6590D+01 & + / + data (OREF(17,15, mtmp), mtmp=1,12) & + / & + 0.6543D+01, 0.6824D+01, 0.6736D+01, 0.7094D+01, & + 0.7475D+01, 0.7439D+01, 0.7287D+01, 0.6932D+01, & + 0.6530D+01, 0.6141D+01, 0.6139D+01, 0.6143D+01 & + / + data (OREF(17,16, mtmp), mtmp=1,12) & + / & + 0.6425D+01, 0.6946D+01, 0.6624D+01, 0.6507D+01, & + 0.6506D+01, 0.6277D+01, 0.6119D+01, 0.5816D+01, & + 0.5476D+01, 0.5529D+01, 0.5806D+01, 0.5956D+01 & + / + data (OREF(17,17, mtmp), mtmp=1,12) & + / & + 0.6425D+01, 0.7089D+01, 0.6851D+01, 0.6084D+01, & + 0.5509D+01, 0.5401D+01, 0.5167D+01, 0.4650D+01, & + 0.4535D+01, 0.4880D+01, 0.5806D+01, 0.5956D+01 & + / + data (OREF(17,18, mtmp), mtmp=1,12) & + / & + 0.6425D+01, 0.7089D+01, 0.6851D+01, 0.6084D+01, & + 0.5509D+01, 0.5401D+01, 0.5167D+01, 0.4650D+01, & + 0.4535D+01, 0.4880D+01, 0.5806D+01, 0.5956D+01 & + / + data (OREF(18, 1, mtmp), mtmp=1,12) & + / & + 0.5664D+01, 0.5090D+01, 0.4996D+01, 0.4851D+01, & + 0.5704D+01, 0.5785D+01, 0.5813D+01, 0.5849D+01, & + 0.5652D+01, 0.6670D+01, 0.6493D+01, 0.6012D+01 & + / + data (OREF(18, 2, mtmp), mtmp=1,12) & + / & + 0.5664D+01, 0.5090D+01, 0.4996D+01, 0.4851D+01, & + 0.5704D+01, 0.5785D+01, 0.5813D+01, 0.5849D+01, & + 0.5652D+01, 0.6670D+01, 0.6493D+01, 0.6012D+01 & + / + data (OREF(18, 3, mtmp), mtmp=1,12) & + / & + 0.6632D+01, 0.6453D+01, 0.5918D+01, 0.5580D+01, & + 0.5704D+01, 0.5785D+01, 0.5813D+01, 0.5687D+01, & + 0.6269D+01, 0.7278D+01, 0.7143D+01, 0.6765D+01 & + / + data (OREF(18, 4, mtmp), mtmp=1,12) & + / & + 0.7865D+01, 0.7694D+01, 0.7121D+01, 0.6598D+01, & + 0.6358D+01, 0.6049D+01, 0.6041D+01, 0.6254D+01, & + 0.7247D+01, 0.7869D+01, 0.7966D+01, 0.7950D+01 & + / + data (OREF(18, 5, mtmp), mtmp=1,12) & + / & + 0.8903D+01, 0.8737D+01, 0.8250D+01, 0.7578D+01, & + 0.7006D+01, 0.6783D+01, 0.6827D+01, 0.7305D+01, & + 0.7938D+01, 0.8374D+01, 0.8797D+01, 0.8988D+01 & + / + data (OREF(18, 6, mtmp), mtmp=1,12) & + / & + 0.9541D+01, 0.9386D+01, 0.9008D+01, 0.8493D+01, & + 0.7833D+01, 0.7660D+01, 0.7623D+01, 0.7939D+01, & + 0.8442D+01, 0.8972D+01, 0.9494D+01, 0.9625D+01 & + / + data (OREF(18, 7, mtmp), mtmp=1,12) & + / & + 0.9923D+01, 0.9925D+01, 0.9711D+01, 0.9387D+01, & + 0.8824D+01, 0.8309D+01, 0.8268D+01, 0.8575D+01, & + 0.9103D+01, 0.9623D+01, 0.9901D+01, 0.9799D+01 & + / + data (OREF(18, 8, mtmp), mtmp=1,12) & + / & + 0.1041D+02, 0.1058D+02, 0.1053D+02, 0.1015D+02, & + 0.9645D+01, 0.9086D+01, 0.9090D+01, 0.9510D+01, & + 0.9922D+01, 0.1013D+02, 0.1010D+02, 0.1005D+02 & + / + data (OREF(18, 9, mtmp), mtmp=1,12) & + / & + 0.1051D+02, 0.1090D+02, 0.1095D+02, 0.1053D+02, & + 0.1005D+02, 0.9676D+01, 0.9771D+01, 0.1010D+02, & + 0.1037D+02, 0.1043D+02, 0.1017D+02, 0.1011D+02 & + / + data (OREF(18,10, mtmp), mtmp=1,12) & + / & + 0.1001D+02, 0.1053D+02, 0.1072D+02, 0.1038D+02, & + 0.1010D+02, 0.9941D+01, 0.1009D+02, 0.1039D+02, & + 0.1058D+02, 0.1051D+02, 0.1006D+02, 0.9765D+01 & + / + data (OREF(18,11, mtmp), mtmp=1,12) & + / & + 0.9093D+01, 0.9766D+01, 0.9969D+01, 0.9830D+01, & + 0.9836D+01, 0.9812D+01, 0.9970D+01, 0.1022D+02, & + 0.1032D+02, 0.1013D+02, 0.9543D+01, 0.9028D+01 & + / + data (OREF(18,12, mtmp), mtmp=1,12) & + / & + 0.8234D+01, 0.8865D+01, 0.9235D+01, 0.9372D+01, & + 0.9535D+01, 0.9549D+01, 0.9592D+01, 0.9730D+01, & + 0.9792D+01, 0.9551D+01, 0.8783D+01, 0.8219D+01 & + / + data (OREF(18,13, mtmp), mtmp=1,12) & + / & + 0.7527D+01, 0.7833D+01, 0.8481D+01, 0.8950D+01, & + 0.9207D+01, 0.9178D+01, 0.9123D+01, 0.9218D+01, & + 0.9088D+01, 0.8547D+01, 0.7751D+01, 0.7532D+01 & + / + data (OREF(18,14, mtmp), mtmp=1,12) & + / & + 0.6991D+01, 0.7176D+01, 0.7756D+01, 0.8404D+01, & + 0.8706D+01, 0.8620D+01, 0.8514D+01, 0.8473D+01, & + 0.8133D+01, 0.7403D+01, 0.6734D+01, 0.6767D+01 & + / + data (OREF(18,15, mtmp), mtmp=1,12) & + / & + 0.6641D+01, 0.6909D+01, 0.7101D+01, 0.7687D+01, & + 0.8056D+01, 0.7942D+01, 0.7776D+01, 0.7598D+01, & + 0.7181D+01, 0.6605D+01, 0.6296D+01, 0.6270D+01 & + / + data (OREF(18,16, mtmp), mtmp=1,12) & + / & + 0.6658D+01, 0.7048D+01, 0.6803D+01, 0.7008D+01, & + 0.7094D+01, 0.6843D+01, 0.6660D+01, 0.6463D+01, & + 0.6078D+01, 0.5924D+01, 0.6085D+01, 0.6203D+01 & + / + data (OREF(18,17, mtmp), mtmp=1,12) & + / & + 0.6658D+01, 0.7327D+01, 0.7035D+01, 0.6416D+01, & + 0.6027D+01, 0.5993D+01, 0.5723D+01, 0.5154D+01, & + 0.4962D+01, 0.5220D+01, 0.6085D+01, 0.6203D+01 & + / + data (OREF(18,18, mtmp), mtmp=1,12) & + / & + 0.6658D+01, 0.7327D+01, 0.7035D+01, 0.6416D+01, & + 0.6027D+01, 0.5993D+01, 0.5723D+01, 0.5154D+01, & + 0.4962D+01, 0.5220D+01, 0.6085D+01, 0.6203D+01 & + / + data (OREF(19, 1, mtmp), mtmp=1,12) & + / & + 0.6171D+01, 0.5664D+01, 0.5400D+01, 0.5249D+01, & + 0.6130D+01, 0.6217D+01, 0.6235D+01, 0.6021D+01, & + 0.5889D+01, 0.6811D+01, 0.6770D+01, 0.6477D+01 & + / + data (OREF(19, 2, mtmp), mtmp=1,12) & + / & + 0.6171D+01, 0.5664D+01, 0.5400D+01, 0.5249D+01, & + 0.6130D+01, 0.6217D+01, 0.6235D+01, 0.6021D+01, & + 0.5889D+01, 0.6811D+01, 0.6770D+01, 0.6477D+01 & + / + data (OREF(19, 3, mtmp), mtmp=1,12) & + / & + 0.6993D+01, 0.6967D+01, 0.6531D+01, 0.6060D+01, & + 0.6130D+01, 0.6217D+01, 0.6235D+01, 0.6050D+01, & + 0.6802D+01, 0.7610D+01, 0.7438D+01, 0.7084D+01 & + / + data (OREF(19, 4, mtmp), mtmp=1,12) & + / & + 0.8000D+01, 0.8000D+01, 0.7675D+01, 0.7182D+01, & + 0.6731D+01, 0.6338D+01, 0.6421D+01, 0.6919D+01, & + 0.7890D+01, 0.8304D+01, 0.8247D+01, 0.8051D+01 & + / + data (OREF(19, 5, mtmp), mtmp=1,12) & + / & + 0.8808D+01, 0.8786D+01, 0.8571D+01, 0.8097D+01, & + 0.7564D+01, 0.7283D+01, 0.7353D+01, 0.7982D+01, & + 0.8554D+01, 0.8863D+01, 0.9013D+01, 0.8887D+01 & + / + data (OREF(19, 6, mtmp), mtmp=1,12) & + / & + 0.9397D+01, 0.9332D+01, 0.9133D+01, 0.8810D+01, & + 0.8312D+01, 0.8118D+01, 0.8068D+01, 0.8474D+01, & + 0.8986D+01, 0.9402D+01, 0.9573D+01, 0.9456D+01 & + / + data (OREF(19, 7, mtmp), mtmp=1,12) & + / & + 0.9848D+01, 0.9828D+01, 0.9645D+01, 0.9413D+01, & + 0.8998D+01, 0.8540D+01, 0.8547D+01, 0.8932D+01, & + 0.9451D+01, 0.9846D+01, 0.9845D+01, 0.9695D+01 & + / + data (OREF(19, 8, mtmp), mtmp=1,12) & + / & + 0.1032D+02, 0.1039D+02, 0.1015D+02, 0.9775D+01, & + 0.9397D+01, 0.9019D+01, 0.9118D+01, 0.9524D+01, & + 0.9901D+01, 0.1008D+02, 0.9941D+01, 0.9930D+01 & + / + data (OREF(19, 9, mtmp), mtmp=1,12) & + / & + 0.1036D+02, 0.1063D+02, 0.1036D+02, 0.9885D+01, & + 0.9574D+01, 0.9424D+01, 0.9613D+01, 0.9882D+01, & + 0.1009D+02, 0.1010D+02, 0.9853D+01, 0.9877D+01 & + / + data (OREF(19,10, mtmp), mtmp=1,12) & + / & + 0.9911D+01, 0.1030D+02, 0.1019D+02, 0.9820D+01, & + 0.9649D+01, 0.9641D+01, 0.9845D+01, 0.1008D+02, & + 0.1021D+02, 0.1006D+02, 0.9655D+01, 0.9524D+01 & + / + data (OREF(19,11, mtmp), mtmp=1,12) & + / & + 0.9205D+01, 0.9740D+01, 0.9759D+01, 0.9615D+01, & + 0.9630D+01, 0.9648D+01, 0.9819D+01, 0.1002D+02, & + 0.1009D+02, 0.9885D+01, 0.9321D+01, 0.8988D+01 & + / + data (OREF(19,12, mtmp), mtmp=1,12) & + / & + 0.8507D+01, 0.9082D+01, 0.9296D+01, 0.9353D+01, & + 0.9452D+01, 0.9464D+01, 0.9547D+01, 0.9740D+01, & + 0.9814D+01, 0.9588D+01, 0.8855D+01, 0.8382D+01 & + / + data (OREF(19,13, mtmp), mtmp=1,12) & + / & + 0.7834D+01, 0.8254D+01, 0.8845D+01, 0.9137D+01, & + 0.9233D+01, 0.9155D+01, 0.9129D+01, 0.9332D+01, & + 0.9266D+01, 0.8852D+01, 0.8107D+01, 0.7843D+01 & + / + data (OREF(19,14, mtmp), mtmp=1,12) & + / & + 0.7217D+01, 0.7504D+01, 0.8295D+01, 0.8804D+01, & + 0.8855D+01, 0.8684D+01, 0.8601D+01, 0.8737D+01, & + 0.8531D+01, 0.7902D+01, 0.7164D+01, 0.7110D+01 & + / + data (OREF(19,15, mtmp), mtmp=1,12) & + / & + 0.6745D+01, 0.7036D+01, 0.7580D+01, 0.8205D+01, & + 0.8337D+01, 0.8102D+01, 0.7959D+01, 0.8004D+01, & + 0.7748D+01, 0.7126D+01, 0.6596D+01, 0.6478D+01 & + / + data (OREF(19,16, mtmp), mtmp=1,12) & + / & + 0.6801D+01, 0.7037D+01, 0.7055D+01, 0.7524D+01, & + 0.7495D+01, 0.7158D+01, 0.6977D+01, 0.6981D+01, & + 0.6712D+01, 0.6384D+01, 0.6404D+01, 0.6463D+01 & + / + data (OREF(19,17, mtmp), mtmp=1,12) & + / & + 0.6801D+01, 0.7385D+01, 0.7144D+01, 0.6751D+01, & + 0.6493D+01, 0.6447D+01, 0.6165D+01, 0.5678D+01, & + 0.5447D+01, 0.5594D+01, 0.6404D+01, 0.6463D+01 & + / + data (OREF(19,18, mtmp), mtmp=1,12) & + / & + 0.6801D+01, 0.7385D+01, 0.7144D+01, 0.6751D+01, & + 0.6493D+01, 0.6447D+01, 0.6165D+01, 0.5678D+01, & + 0.5447D+01, 0.5594D+01, 0.6404D+01, 0.6463D+01 & + / + data (OREF(20, 1, mtmp), mtmp=1,12) & + / & + 0.6287D+01, 0.6081D+01, 0.5792D+01, 0.5613D+01, & + 0.6520D+01, 0.6570D+01, 0.6530D+01, 0.5988D+01, & + 0.6056D+01, 0.6854D+01, 0.6788D+01, 0.6525D+01 & + / + data (OREF(20, 2, mtmp), mtmp=1,12) & + / & + 0.6287D+01, 0.6081D+01, 0.5792D+01, 0.5613D+01, & + 0.6520D+01, 0.6570D+01, 0.6530D+01, 0.5988D+01, & + 0.6056D+01, 0.6854D+01, 0.6788D+01, 0.6525D+01 & + / + data (OREF(20, 3, mtmp), mtmp=1,12) & + / & + 0.6857D+01, 0.7114D+01, 0.7060D+01, 0.6558D+01, & + 0.6520D+01, 0.6570D+01, 0.6530D+01, 0.6284D+01, & + 0.7129D+01, 0.7664D+01, 0.7348D+01, 0.6911D+01 & + / + data (OREF(20, 4, mtmp), mtmp=1,12) & + / & + 0.7587D+01, 0.7822D+01, 0.7956D+01, 0.7716D+01, & + 0.7143D+01, 0.6642D+01, 0.6811D+01, 0.7490D+01, & + 0.8246D+01, 0.8372D+01, 0.8039D+01, 0.7593D+01 & + / + data (OREF(20, 5, mtmp), mtmp=1,12) & + / & + 0.8177D+01, 0.8335D+01, 0.8498D+01, 0.8409D+01, & + 0.8072D+01, 0.7780D+01, 0.7868D+01, 0.8517D+01, & + 0.8861D+01, 0.8896D+01, 0.8627D+01, 0.8190D+01 & + / + data (OREF(20, 6, mtmp), mtmp=1,12) & + / & + 0.8712D+01, 0.8786D+01, 0.8842D+01, 0.8821D+01, & + 0.8624D+01, 0.8436D+01, 0.8347D+01, 0.8736D+01, & + 0.9122D+01, 0.9252D+01, 0.8999D+01, 0.8685D+01 & + / + data (OREF(20, 7, mtmp), mtmp=1,12) & + / & + 0.9210D+01, 0.9209D+01, 0.9125D+01, 0.9041D+01, & + 0.8860D+01, 0.8514D+01, 0.8539D+01, 0.8887D+01, & + 0.9272D+01, 0.9414D+01, 0.9171D+01, 0.9018D+01 & + / + data (OREF(20, 8, mtmp), mtmp=1,12) & + / & + 0.9668D+01, 0.9600D+01, 0.9227D+01, 0.8956D+01, & + 0.8787D+01, 0.8646D+01, 0.8804D+01, 0.9079D+01, & + 0.9316D+01, 0.9383D+01, 0.9222D+01, 0.9295D+01 & + / + data (OREF(20, 9, mtmp), mtmp=1,12) & + / & + 0.9711D+01, 0.9719D+01, 0.9160D+01, 0.8804D+01, & + 0.8747D+01, 0.8830D+01, 0.9059D+01, 0.9169D+01, & + 0.9243D+01, 0.9208D+01, 0.9064D+01, 0.9231D+01 & + / + data (OREF(20,10, mtmp), mtmp=1,12) & + / & + 0.9416D+01, 0.9503D+01, 0.9078D+01, 0.8808D+01, & + 0.8809D+01, 0.8952D+01, 0.9171D+01, 0.9256D+01, & + 0.9277D+01, 0.9122D+01, 0.8868D+01, 0.8958D+01 & + / + data (OREF(20,11, mtmp), mtmp=1,12) & + / & + 0.8988D+01, 0.9214D+01, 0.9010D+01, 0.8895D+01, & + 0.8929D+01, 0.9017D+01, 0.9217D+01, 0.9324D+01, & + 0.9340D+01, 0.9148D+01, 0.8743D+01, 0.8647D+01 & + / + data (OREF(20,12, mtmp), mtmp=1,12) & + / & + 0.8551D+01, 0.8923D+01, 0.8924D+01, 0.8879D+01, & + 0.8875D+01, 0.8901D+01, 0.9066D+01, 0.9264D+01, & + 0.9322D+01, 0.9156D+01, 0.8641D+01, 0.8308D+01 & + / + data (OREF(20,13, mtmp), mtmp=1,12) & + / & + 0.8038D+01, 0.8503D+01, 0.8874D+01, 0.8862D+01, & + 0.8740D+01, 0.8638D+01, 0.8702D+01, 0.8948D+01, & + 0.8989D+01, 0.8816D+01, 0.8349D+01, 0.8046D+01 & + / + data (OREF(20,14, mtmp), mtmp=1,12) & + / & + 0.7458D+01, 0.7821D+01, 0.8670D+01, 0.8769D+01, & + 0.8482D+01, 0.8243D+01, 0.8236D+01, 0.8475D+01, & + 0.8524D+01, 0.8214D+01, 0.7661D+01, 0.7518D+01 & + / + data (OREF(20,15, mtmp), mtmp=1,12) & + / & + 0.6829D+01, 0.7180D+01, 0.8042D+01, 0.8425D+01, & + 0.8123D+01, 0.7753D+01, 0.7669D+01, 0.7916D+01, & + 0.7997D+01, 0.7550D+01, 0.6990D+01, 0.6715D+01 & + / + data (OREF(20,16, mtmp), mtmp=1,12) & + / & + 0.6795D+01, 0.6936D+01, 0.7343D+01, 0.7892D+01, & + 0.7499D+01, 0.7014D+01, 0.6871D+01, 0.7137D+01, & + 0.7170D+01, 0.6798D+01, 0.6700D+01, 0.6645D+01 & + / + data (OREF(20,17, mtmp), mtmp=1,12) & + / & + 0.6795D+01, 0.7241D+01, 0.7183D+01, 0.7019D+01, & + 0.6733D+01, 0.6539D+01, 0.6285D+01, 0.6044D+01, & + 0.5858D+01, 0.5928D+01, 0.6700D+01, 0.6645D+01 & + / + data (OREF(20,18, mtmp), mtmp=1,12) & + / & + 0.6795D+01, 0.7241D+01, 0.7183D+01, 0.7019D+01, & + 0.6733D+01, 0.6539D+01, 0.6285D+01, 0.6044D+01, & + 0.5858D+01, 0.5928D+01, 0.6700D+01, 0.6645D+01 & + / + data (OREF(21, 1, mtmp), mtmp=1,12) & + / & + 0.5940D+01, 0.6155D+01, 0.6101D+01, 0.5930D+01, & + 0.6850D+01, 0.6823D+01, 0.6678D+01, 0.5806D+01, & + 0.6073D+01, 0.6638D+01, 0.6448D+01, 0.6111D+01 & + / + data (OREF(21, 2, mtmp), mtmp=1,12) & + / & + 0.5940D+01, 0.6155D+01, 0.6101D+01, 0.5930D+01, & + 0.6850D+01, 0.6823D+01, 0.6678D+01, 0.5806D+01, & + 0.6073D+01, 0.6638D+01, 0.6448D+01, 0.6111D+01 & + / + data (OREF(21, 3, mtmp), mtmp=1,12) & + / & + 0.6268D+01, 0.6792D+01, 0.7299D+01, 0.7005D+01, & + 0.6850D+01, 0.6823D+01, 0.6678D+01, 0.6342D+01, & + 0.7111D+01, 0.7319D+01, 0.6835D+01, 0.6299D+01 & + / + data (OREF(21, 4, mtmp), mtmp=1,12) & + / & + 0.6756D+01, 0.7180D+01, 0.7794D+01, 0.8027D+01, & + 0.7567D+01, 0.6978D+01, 0.7179D+01, 0.7784D+01, & + 0.8148D+01, 0.7959D+01, 0.7357D+01, 0.6727D+01 & + / + data (OREF(21, 5, mtmp), mtmp=1,12) & + / & + 0.7178D+01, 0.7478D+01, 0.7969D+01, 0.8341D+01, & + 0.8398D+01, 0.8192D+01, 0.8234D+01, 0.8686D+01, & + 0.8682D+01, 0.8375D+01, 0.7739D+01, 0.7122D+01 & + / + data (OREF(21, 6, mtmp), mtmp=1,12) & + / & + 0.7651D+01, 0.7846D+01, 0.8117D+01, 0.8397D+01, & + 0.8575D+01, 0.8436D+01, 0.8294D+01, 0.8573D+01, & + 0.8728D+01, 0.8509D+01, 0.7944D+01, 0.7541D+01 & + / + data (OREF(21, 7, mtmp), mtmp=1,12) & + / & + 0.8141D+01, 0.8176D+01, 0.8195D+01, 0.8254D+01, & + 0.8311D+01, 0.8110D+01, 0.8132D+01, 0.8375D+01, & + 0.8557D+01, 0.8431D+01, 0.8057D+01, 0.7936D+01 & + / + data (OREF(21, 8, mtmp), mtmp=1,12) & + / & + 0.8556D+01, 0.8387D+01, 0.7969D+01, 0.7834D+01, & + 0.7864D+01, 0.7934D+01, 0.8107D+01, 0.8213D+01, & + 0.8283D+01, 0.8233D+01, 0.8102D+01, 0.8251D+01 & + / + data (OREF(21, 9, mtmp), mtmp=1,12) & + / & + 0.8630D+01, 0.8392D+01, 0.7703D+01, 0.7516D+01, & + 0.7676D+01, 0.7924D+01, 0.8139D+01, 0.8084D+01, & + 0.8031D+01, 0.7975D+01, 0.7949D+01, 0.8235D+01 & + / + data (OREF(21,10, mtmp), mtmp=1,12) & + / & + 0.8499D+01, 0.8289D+01, 0.7693D+01, 0.7559D+01, & + 0.7709D+01, 0.7951D+01, 0.8146D+01, 0.8082D+01, & + 0.8016D+01, 0.7886D+01, 0.7804D+01, 0.8073D+01 & + / + data (OREF(21,11, mtmp), mtmp=1,12) & + / & + 0.8330D+01, 0.8243D+01, 0.7892D+01, 0.7822D+01, & + 0.7874D+01, 0.8022D+01, 0.8237D+01, 0.8249D+01, & + 0.8213D+01, 0.8059D+01, 0.7843D+01, 0.7953D+01 & + / + data (OREF(21,12, mtmp), mtmp=1,12) & + / & + 0.8184D+01, 0.8298D+01, 0.8124D+01, 0.8002D+01, & + 0.7909D+01, 0.7956D+01, 0.8191D+01, 0.8360D+01, & + 0.8387D+01, 0.8292D+01, 0.8048D+01, 0.7869D+01 & + / + data (OREF(21,13, mtmp), mtmp=1,12) & + / & + 0.7944D+01, 0.8350D+01, 0.8411D+01, 0.8116D+01, & + 0.7824D+01, 0.7725D+01, 0.7883D+01, 0.8123D+01, & + 0.8262D+01, 0.8341D+01, 0.8249D+01, 0.7939D+01 & + / + data (OREF(21,14, mtmp), mtmp=1,12) & + / & + 0.7539D+01, 0.7918D+01, 0.8586D+01, 0.8194D+01, & + 0.7650D+01, 0.7390D+01, 0.7465D+01, 0.7739D+01, & + 0.8047D+01, 0.8161D+01, 0.8006D+01, 0.7796D+01 & + / + data (OREF(21,15, mtmp), mtmp=1,12) & + / & + 0.6814D+01, 0.7225D+01, 0.8218D+01, 0.8133D+01, & + 0.7424D+01, 0.6980D+01, 0.6958D+01, 0.7328D+01, & + 0.7793D+01, 0.7730D+01, 0.7364D+01, 0.6904D+01 & + / + data (OREF(21,16, mtmp), mtmp=1,12) & + / & + 0.6601D+01, 0.6721D+01, 0.7517D+01, 0.7867D+01, & + 0.7033D+01, 0.6436D+01, 0.6345D+01, 0.6820D+01, & + 0.7277D+01, 0.7073D+01, 0.6908D+01, 0.6684D+01 & + / + data (OREF(21,17, mtmp), mtmp=1,12) & + / & + 0.6601D+01, 0.6886D+01, 0.7100D+01, 0.7076D+01, & + 0.6586D+01, 0.6186D+01, 0.5991D+01, 0.6059D+01, & + 0.6087D+01, 0.6169D+01, 0.6908D+01, 0.6684D+01 & + / + data (OREF(21,18, mtmp), mtmp=1,12) & + / & + 0.6601D+01, 0.6886D+01, 0.7100D+01, 0.7076D+01, & + 0.6586D+01, 0.6186D+01, 0.5991D+01, 0.6059D+01, & + 0.6087D+01, 0.6169D+01, 0.6908D+01, 0.6684D+01 & + / + data (OREF(22, 1, mtmp), mtmp=1,12) & + / & + 0.5094D+01, 0.5688D+01, 0.6286D+01, 0.6260D+01, & + 0.7170D+01, 0.7024D+01, 0.6735D+01, 0.5610D+01, & + 0.5857D+01, 0.5967D+01, 0.5653D+01, 0.5220D+01 & + / + data (OREF(22, 2, mtmp), mtmp=1,12) & + / & + 0.5094D+01, 0.5688D+01, 0.6286D+01, 0.6260D+01, & + 0.7170D+01, 0.7024D+01, 0.6735D+01, 0.5610D+01, & + 0.5857D+01, 0.5967D+01, 0.5653D+01, 0.5220D+01 & + / + data (OREF(22, 3, mtmp), mtmp=1,12) & + / & + 0.5288D+01, 0.5925D+01, 0.7013D+01, 0.7386D+01, & + 0.7170D+01, 0.7024D+01, 0.6735D+01, 0.6214D+01, & + 0.6604D+01, 0.6451D+01, 0.5871D+01, 0.5320D+01 & + / + data (OREF(22, 4, mtmp), mtmp=1,12) & + / & + 0.5632D+01, 0.6110D+01, 0.7023D+01, 0.7936D+01, & + 0.8082D+01, 0.7532D+01, 0.7597D+01, 0.7599D+01, & + 0.7435D+01, 0.6957D+01, 0.6232D+01, 0.5601D+01 & + / + data (OREF(22, 5, mtmp), mtmp=1,12) & + / & + 0.5959D+01, 0.6303D+01, 0.6932D+01, 0.7717D+01, & + 0.8426D+01, 0.8503D+01, 0.8328D+01, 0.8241D+01, & + 0.7844D+01, 0.7220D+01, 0.6461D+01, 0.5876D+01 & + / + data (OREF(22, 6, mtmp), mtmp=1,12) & + / & + 0.6357D+01, 0.6598D+01, 0.6948D+01, 0.7413D+01, & + 0.7951D+01, 0.7930D+01, 0.7729D+01, 0.7832D+01, & + 0.7698D+01, 0.7192D+01, 0.6574D+01, 0.6218D+01 & + / + data (OREF(22, 7, mtmp), mtmp=1,12) & + / & + 0.6765D+01, 0.6828D+01, 0.6894D+01, 0.7035D+01, & + 0.7257D+01, 0.7200D+01, 0.7210D+01, 0.7343D+01, & + 0.7318D+01, 0.7013D+01, 0.6667D+01, 0.6593D+01 & + / + data (OREF(22, 8, mtmp), mtmp=1,12) & + / & + 0.7082D+01, 0.6895D+01, 0.6548D+01, 0.6521D+01, & + 0.6661D+01, 0.6840D+01, 0.6978D+01, 0.6959D+01, & + 0.6913D+01, 0.6796D+01, 0.6723D+01, 0.6894D+01 & + / + data (OREF(22, 9, mtmp), mtmp=1,12) & + / & + 0.7165D+01, 0.6834D+01, 0.6247D+01, 0.6191D+01, & + 0.6439D+01, 0.6723D+01, 0.6877D+01, 0.6731D+01, & + 0.6628D+01, 0.6572D+01, 0.6625D+01, 0.6935D+01 & + / + data (OREF(22,10, mtmp), mtmp=1,12) & + / & + 0.7142D+01, 0.6804D+01, 0.6269D+01, 0.6238D+01, & + 0.6446D+01, 0.6694D+01, 0.6834D+01, 0.6694D+01, & + 0.6604D+01, 0.6515D+01, 0.6542D+01, 0.6868D+01 & + / + data (OREF(22,11, mtmp), mtmp=1,12) & + / & + 0.7130D+01, 0.6887D+01, 0.6548D+01, 0.6522D+01, & + 0.6587D+01, 0.6750D+01, 0.6939D+01, 0.6893D+01, & + 0.6837D+01, 0.6730D+01, 0.6643D+01, 0.6848D+01 & + / + data (OREF(22,12, mtmp), mtmp=1,12) & + / & + 0.7224D+01, 0.7131D+01, 0.6903D+01, 0.6767D+01, & + 0.6647D+01, 0.6711D+01, 0.6957D+01, 0.7078D+01, & + 0.7085D+01, 0.7043D+01, 0.6983D+01, 0.6937D+01 & + / + data (OREF(22,13, mtmp), mtmp=1,12) & + / & + 0.7330D+01, 0.7545D+01, 0.7310D+01, 0.6899D+01, & + 0.6573D+01, 0.6507D+01, 0.6708D+01, 0.6916D+01, & + 0.7101D+01, 0.7342D+01, 0.7556D+01, 0.7296D+01 & + / + data (OREF(22,14, mtmp), mtmp=1,12) & + / & + 0.7250D+01, 0.7540D+01, 0.7728D+01, 0.6999D+01, & + 0.6434D+01, 0.6217D+01, 0.6335D+01, 0.6588D+01, & + 0.7054D+01, 0.7560D+01, 0.7932D+01, 0.7712D+01 & + / + data (OREF(22,15, mtmp), mtmp=1,12) & + / & + 0.6636D+01, 0.7051D+01, 0.7782D+01, 0.7124D+01, & + 0.6270D+01, 0.5870D+01, 0.5886D+01, 0.6257D+01, & + 0.7019D+01, 0.7520D+01, 0.7617D+01, 0.7008D+01 & + / + data (OREF(22,16, mtmp), mtmp=1,12) & + / & + 0.6189D+01, 0.6399D+01, 0.7410D+01, 0.7183D+01, & + 0.6046D+01, 0.5464D+01, 0.5418D+01, 0.5934D+01, & + 0.6855D+01, 0.7150D+01, 0.6992D+01, 0.6532D+01 & + / + data (OREF(22,17, mtmp), mtmp=1,12) & + / & + 0.6189D+01, 0.6305D+01, 0.6866D+01, 0.6770D+01, & + 0.5888D+01, 0.5332D+01, 0.5206D+01, 0.5498D+01, & + 0.6025D+01, 0.6287D+01, 0.6992D+01, 0.6532D+01 & + / + data (OREF(22,18, mtmp), mtmp=1,12) & + / & + 0.6189D+01, 0.6305D+01, 0.6866D+01, 0.6770D+01, & + 0.5888D+01, 0.5332D+01, 0.5206D+01, 0.5498D+01, & + 0.6025D+01, 0.6287D+01, 0.6992D+01, 0.6532D+01 & + / + data (OREF(23, 1, mtmp), mtmp=1,12) & + / & + 0.4074D+01, 0.4874D+01, 0.6180D+01, 0.6443D+01, & + 0.7296D+01, 0.7036D+01, 0.6564D+01, 0.5325D+01, & + 0.5392D+01, 0.5047D+01, 0.4656D+01, 0.4174D+01 & + / + data (OREF(23, 2, mtmp), mtmp=1,12) & + / & + 0.4074D+01, 0.4874D+01, 0.6180D+01, 0.6443D+01, & + 0.7296D+01, 0.7036D+01, 0.6564D+01, 0.5325D+01, & + 0.5392D+01, 0.5047D+01, 0.4656D+01, 0.4174D+01 & + / + data (OREF(23, 3, mtmp), mtmp=1,12) & + / & + 0.4216D+01, 0.4832D+01, 0.6270D+01, 0.7427D+01, & + 0.7296D+01, 0.7036D+01, 0.6564D+01, 0.5836D+01, & + 0.5757D+01, 0.5343D+01, 0.4753D+01, 0.4257D+01 & + / + data (OREF(23, 4, mtmp), mtmp=1,12) & + / & + 0.4484D+01, 0.4920D+01, 0.5912D+01, 0.7364D+01, & + 0.8326D+01, 0.7961D+01, 0.7730D+01, 0.6937D+01, & + 0.6347D+01, 0.5706D+01, 0.4991D+01, 0.4466D+01 & + / + data (OREF(23, 5, mtmp), mtmp=1,12) & + / & + 0.4758D+01, 0.5078D+01, 0.5691D+01, 0.6698D+01, & + 0.7987D+01, 0.8392D+01, 0.7953D+01, 0.7303D+01, & + 0.6631D+01, 0.5832D+01, 0.5127D+01, 0.4677D+01 & + / + data (OREF(23, 6, mtmp), mtmp=1,12) & + / & + 0.5078D+01, 0.5313D+01, 0.5640D+01, 0.6156D+01, & + 0.6909D+01, 0.7006D+01, 0.6778D+01, 0.6727D+01, & + 0.6371D+01, 0.5721D+01, 0.5201D+01, 0.4950D+01 & + / + data (OREF(23, 7, mtmp), mtmp=1,12) & + / & + 0.5379D+01, 0.5456D+01, 0.5525D+01, 0.5691D+01, & + 0.5984D+01, 0.6033D+01, 0.6034D+01, 0.6083D+01, & + 0.5914D+01, 0.5538D+01, 0.5290D+01, 0.5259D+01 & + / + data (OREF(23, 8, mtmp), mtmp=1,12) & + / & + 0.5586D+01, 0.5429D+01, 0.5197D+01, 0.5235D+01, & + 0.5414D+01, 0.5618D+01, 0.5702D+01, 0.5619D+01, & + 0.5516D+01, 0.5377D+01, 0.5356D+01, 0.5513D+01 & + / + data (OREF(23, 9, mtmp), mtmp=1,12) & + / & + 0.5657D+01, 0.5342D+01, 0.4949D+01, 0.4976D+01, & + 0.5226D+01, 0.5468D+01, 0.5550D+01, 0.5381D+01, & + 0.5280D+01, 0.5235D+01, 0.5322D+01, 0.5595D+01 & + / + data (OREF(23,10, mtmp), mtmp=1,12) & + / & + 0.5687D+01, 0.5347D+01, 0.4977D+01, 0.5010D+01, & + 0.5214D+01, 0.5418D+01, 0.5497D+01, 0.5342D+01, & + 0.5267D+01, 0.5216D+01, 0.5293D+01, 0.5590D+01 & + / + data (OREF(23,11, mtmp), mtmp=1,12) & + / & + 0.5741D+01, 0.5472D+01, 0.5227D+01, 0.5236D+01, & + 0.5305D+01, 0.5454D+01, 0.5597D+01, 0.5528D+01, & + 0.5473D+01, 0.5407D+01, 0.5389D+01, 0.5602D+01 & + / + data (OREF(23,12, mtmp), mtmp=1,12) & + / & + 0.5967D+01, 0.5768D+01, 0.5571D+01, 0.5460D+01, & + 0.5354D+01, 0.5427D+01, 0.5644D+01, 0.5719D+01, & + 0.5711D+01, 0.5697D+01, 0.5726D+01, 0.5766D+01 & + / + data (OREF(23,13, mtmp), mtmp=1,12) & + / & + 0.6345D+01, 0.6353D+01, 0.5944D+01, 0.5550D+01, & + 0.5276D+01, 0.5247D+01, 0.5450D+01, 0.5616D+01, & + 0.5795D+01, 0.6092D+01, 0.6464D+01, 0.6282D+01 & + / + data (OREF(23,14, mtmp), mtmp=1,12) & + / & + 0.6581D+01, 0.6735D+01, 0.6430D+01, 0.5593D+01, & + 0.5145D+01, 0.4997D+01, 0.5123D+01, 0.5330D+01, & + 0.5833D+01, 0.6565D+01, 0.7342D+01, 0.7152D+01 & + / + data (OREF(23,15, mtmp), mtmp=1,12) & + / & + 0.6203D+01, 0.6570D+01, 0.6841D+01, 0.5789D+01, & + 0.5003D+01, 0.4702D+01, 0.4734D+01, 0.5039D+01, & + 0.5923D+01, 0.6893D+01, 0.7478D+01, 0.6811D+01 & + / + data (OREF(23,16, mtmp), mtmp=1,12) & + / & + 0.5588D+01, 0.5923D+01, 0.6909D+01, 0.6082D+01, & + 0.4874D+01, 0.4387D+01, 0.4372D+01, 0.4822D+01, & + 0.6030D+01, 0.6871D+01, 0.6804D+01, 0.6121D+01 & + / + data (OREF(23,17, mtmp), mtmp=1,12) & + / & + 0.5588D+01, 0.5581D+01, 0.6416D+01, 0.6106D+01, & + 0.4903D+01, 0.4292D+01, 0.4225D+01, 0.4621D+01, & + 0.5631D+01, 0.6167D+01, 0.6804D+01, 0.6121D+01 & + / + data (OREF(23,18, mtmp), mtmp=1,12) & + / & + 0.5588D+01, 0.5581D+01, 0.6416D+01, 0.6106D+01, & + 0.4903D+01, 0.4292D+01, 0.4225D+01, 0.4621D+01, & + 0.5631D+01, 0.6167D+01, 0.6804D+01, 0.6121D+01 & + / + data (OREF(24, 1, mtmp), mtmp=1,12) & + / & + 0.3169D+01, 0.3893D+01, 0.5441D+01, 0.6177D+01, & + 0.6888D+01, 0.6636D+01, 0.5880D+01, 0.4759D+01, & + 0.4609D+01, 0.4093D+01, 0.3680D+01, 0.3257D+01 & + / + data (OREF(24, 2, mtmp), mtmp=1,12) & + / & + 0.3169D+01, 0.3893D+01, 0.5441D+01, 0.6177D+01, & + 0.6888D+01, 0.6636D+01, 0.5880D+01, 0.4759D+01, & + 0.4609D+01, 0.4093D+01, 0.3680D+01, 0.3257D+01 & + / + data (OREF(24, 3, mtmp), mtmp=1,12) & + / & + 0.3311D+01, 0.3801D+01, 0.5095D+01, 0.6573D+01, & + 0.6888D+01, 0.6636D+01, 0.5880D+01, 0.5034D+01, & + 0.4692D+01, 0.4272D+01, 0.3743D+01, 0.3359D+01 & + / + data (OREF(24, 4, mtmp), mtmp=1,12) & + / & + 0.3535D+01, 0.3878D+01, 0.4697D+01, 0.6106D+01, & + 0.7509D+01, 0.7473D+01, 0.6872D+01, 0.5742D+01, & + 0.5105D+01, 0.4527D+01, 0.3913D+01, 0.3532D+01 & + / + data (OREF(24, 5, mtmp), mtmp=1,12) & + / & + 0.3771D+01, 0.4031D+01, 0.4507D+01, 0.5393D+01, & + 0.6705D+01, 0.7206D+01, 0.6700D+01, 0.5973D+01, & + 0.5316D+01, 0.4582D+01, 0.4011D+01, 0.3710D+01 & + / + data (OREF(24, 6, mtmp), mtmp=1,12) & + / & + 0.4021D+01, 0.4216D+01, 0.4453D+01, 0.4872D+01, & + 0.5548D+01, 0.5679D+01, 0.5514D+01, 0.5453D+01, & + 0.5061D+01, 0.4462D+01, 0.4077D+01, 0.3923D+01 & + / + data (OREF(24, 7, mtmp), mtmp=1,12) & + / & + 0.4223D+01, 0.4297D+01, 0.4338D+01, 0.4476D+01, & + 0.4739D+01, 0.4821D+01, 0.4828D+01, 0.4861D+01, & + 0.4660D+01, 0.4325D+01, 0.4159D+01, 0.4155D+01 & + / + data (OREF(24, 8, mtmp), mtmp=1,12) & + / & + 0.4334D+01, 0.4224D+01, 0.4094D+01, 0.4158D+01, & + 0.4320D+01, 0.4485D+01, 0.4525D+01, 0.4466D+01, & + 0.4359D+01, 0.4236D+01, 0.4224D+01, 0.4345D+01 & + / + data (OREF(24, 9, mtmp), mtmp=1,12) & + / & + 0.4375D+01, 0.4134D+01, 0.3928D+01, 0.3993D+01, & + 0.4195D+01, 0.4364D+01, 0.4390D+01, 0.4277D+01, & + 0.4203D+01, 0.4168D+01, 0.4233D+01, 0.4433D+01 & + / + data (OREF(24,10, mtmp), mtmp=1,12) & + / & + 0.4406D+01, 0.4149D+01, 0.3950D+01, 0.4012D+01, & + 0.4180D+01, 0.4321D+01, 0.4354D+01, 0.4251D+01, & + 0.4201D+01, 0.4172D+01, 0.4231D+01, 0.4447D+01 & + / + data (OREF(24,11, mtmp), mtmp=1,12) & + / & + 0.4452D+01, 0.4261D+01, 0.4133D+01, 0.4162D+01, & + 0.4230D+01, 0.4349D+01, 0.4441D+01, 0.4393D+01, & + 0.4342D+01, 0.4298D+01, 0.4282D+01, 0.4440D+01 & + / + data (OREF(24,12, mtmp), mtmp=1,12) & + / & + 0.4668D+01, 0.4499D+01, 0.4389D+01, 0.4324D+01, & + 0.4255D+01, 0.4328D+01, 0.4493D+01, 0.4547D+01, & + 0.4515D+01, 0.4490D+01, 0.4512D+01, 0.4574D+01 & + / + data (OREF(24,13, mtmp), mtmp=1,12) & + / & + 0.5090D+01, 0.5006D+01, 0.4634D+01, 0.4357D+01, & + 0.4171D+01, 0.4173D+01, 0.4345D+01, 0.4489D+01, & + 0.4598D+01, 0.4818D+01, 0.5128D+01, 0.5025D+01 & + / + data (OREF(24,14, mtmp), mtmp=1,12) & + / & + 0.5431D+01, 0.5483D+01, 0.4998D+01, 0.4326D+01, & + 0.4042D+01, 0.3958D+01, 0.4068D+01, 0.4246D+01, & + 0.4638D+01, 0.5295D+01, 0.6021D+01, 0.5879D+01 & + / + data (OREF(24,15, mtmp), mtmp=1,12) & + / & + 0.5293D+01, 0.5550D+01, 0.5459D+01, 0.4477D+01, & + 0.3905D+01, 0.3710D+01, 0.3741D+01, 0.3987D+01, & + 0.4736D+01, 0.5741D+01, 0.6424D+01, 0.5880D+01 & + / + data (OREF(24,16, mtmp), mtmp=1,12) & + / & + 0.4807D+01, 0.5164D+01, 0.5762D+01, 0.4787D+01, & + 0.3810D+01, 0.3460D+01, 0.3455D+01, 0.3817D+01, & + 0.4915D+01, 0.5917D+01, 0.6070D+01, 0.5298D+01 & + / + data (OREF(24,17, mtmp), mtmp=1,12) & + / & + 0.4807D+01, 0.4842D+01, 0.5592D+01, 0.5009D+01, & + 0.3868D+01, 0.3351D+01, 0.3310D+01, 0.3714D+01, & + 0.4793D+01, 0.5611D+01, 0.6070D+01, 0.5298D+01 & + / + data (OREF(24,18, mtmp), mtmp=1,12) & + / & + 0.4807D+01, 0.4842D+01, 0.5592D+01, 0.5009D+01, & + 0.3868D+01, 0.3351D+01, 0.3310D+01, 0.3714D+01, & + 0.4793D+01, 0.5611D+01, 0.6070D+01, 0.5298D+01 & + / + data (OREF(25, 1, mtmp), mtmp=1,12) & + / & + 0.2449D+01, 0.2952D+01, 0.4313D+01, 0.5453D+01, & + 0.5977D+01, 0.5827D+01, 0.4831D+01, 0.3985D+01, & + 0.3676D+01, 0.3229D+01, 0.2839D+01, 0.2533D+01 & + / + data (OREF(25, 2, mtmp), mtmp=1,12) & + / & + 0.2449D+01, 0.2952D+01, 0.4313D+01, 0.5453D+01, & + 0.5977D+01, 0.5827D+01, 0.4831D+01, 0.3985D+01, & + 0.3676D+01, 0.3229D+01, 0.2839D+01, 0.2533D+01 & + / + data (OREF(25, 3, mtmp), mtmp=1,12) & + / & + 0.2612D+01, 0.2941D+01, 0.3822D+01, 0.5155D+01, & + 0.5977D+01, 0.5827D+01, 0.4831D+01, 0.4005D+01, & + 0.3624D+01, 0.3351D+01, 0.2918D+01, 0.2661D+01 & + / + data (OREF(25, 4, mtmp), mtmp=1,12) & + / & + 0.2805D+01, 0.3045D+01, 0.3582D+01, 0.4584D+01, & + 0.5951D+01, 0.6195D+01, 0.5367D+01, 0.4367D+01, & + 0.3929D+01, 0.3536D+01, 0.3058D+01, 0.2816D+01 & + / + data (OREF(25, 5, mtmp), mtmp=1,12) & + / & + 0.3010D+01, 0.3200D+01, 0.3497D+01, 0.4084D+01, & + 0.5046D+01, 0.5442D+01, 0.5041D+01, 0.4572D+01, & + 0.4106D+01, 0.3568D+01, 0.3147D+01, 0.2973D+01 & + / + data (OREF(25, 6, mtmp), mtmp=1,12) & + / & + 0.3201D+01, 0.3344D+01, 0.3473D+01, 0.3731D+01, & + 0.4176D+01, 0.4279D+01, 0.4212D+01, 0.4226D+01, & + 0.3921D+01, 0.3478D+01, 0.3216D+01, 0.3138D+01 & + / + data (OREF(25, 7, mtmp), mtmp=1,12) & + / & + 0.3323D+01, 0.3385D+01, 0.3387D+01, 0.3476D+01, & + 0.3658D+01, 0.3726D+01, 0.3746D+01, 0.3800D+01, & + 0.3638D+01, 0.3402D+01, 0.3289D+01, 0.3297D+01 & + / + data (OREF(25, 8, mtmp), mtmp=1,12) & + / & + 0.3361D+01, 0.3295D+01, 0.3242D+01, 0.3306D+01, & + 0.3427D+01, 0.3528D+01, 0.3537D+01, 0.3545D+01, & + 0.3464D+01, 0.3375D+01, 0.3345D+01, 0.3424D+01 & + / + data (OREF(25, 9, mtmp), mtmp=1,12) & + / & + 0.3365D+01, 0.3214D+01, 0.3155D+01, 0.3228D+01, & + 0.3369D+01, 0.3461D+01, 0.3452D+01, 0.3429D+01, & + 0.3390D+01, 0.3362D+01, 0.3375D+01, 0.3496D+01 & + / + data (OREF(25,10, mtmp), mtmp=1,12) & + / & + 0.3375D+01, 0.3224D+01, 0.3168D+01, 0.3235D+01, & + 0.3358D+01, 0.3440D+01, 0.3442D+01, 0.3418D+01, & + 0.3394D+01, 0.3373D+01, 0.3381D+01, 0.3504D+01 & + / + data (OREF(25,11, mtmp), mtmp=1,12) & + / & + 0.3381D+01, 0.3304D+01, 0.3279D+01, 0.3319D+01, & + 0.3383D+01, 0.3468D+01, 0.3516D+01, 0.3507D+01, & + 0.3460D+01, 0.3424D+01, 0.3377D+01, 0.3459D+01 & + / + data (OREF(25,12, mtmp), mtmp=1,12) & + / & + 0.3517D+01, 0.3442D+01, 0.3429D+01, 0.3411D+01, & + 0.3383D+01, 0.3451D+01, 0.3561D+01, 0.3609D+01, & + 0.3551D+01, 0.3495D+01, 0.3469D+01, 0.3514D+01 & + / + data (OREF(25,13, mtmp), mtmp=1,12) & + / & + 0.3838D+01, 0.3754D+01, 0.3527D+01, 0.3395D+01, & + 0.3298D+01, 0.3319D+01, 0.3450D+01, 0.3583D+01, & + 0.3596D+01, 0.3684D+01, 0.3831D+01, 0.3789D+01 & + / + data (OREF(25,14, mtmp), mtmp=1,12) & + / & + 0.4122D+01, 0.4123D+01, 0.3702D+01, 0.3303D+01, & + 0.3172D+01, 0.3136D+01, 0.3221D+01, 0.3383D+01, & + 0.3600D+01, 0.4021D+01, 0.4444D+01, 0.4344D+01 & + / + data (OREF(25,15, mtmp), mtmp=1,12) & + / & + 0.4141D+01, 0.4282D+01, 0.4023D+01, 0.3362D+01, & + 0.3037D+01, 0.2932D+01, 0.2954D+01, 0.3155D+01, & + 0.3642D+01, 0.4391D+01, 0.4881D+01, 0.4538D+01 & + / + data (OREF(25,16, mtmp), mtmp=1,12) & + / & + 0.3949D+01, 0.4237D+01, 0.4345D+01, 0.3564D+01, & + 0.2944D+01, 0.2729D+01, 0.2724D+01, 0.3004D+01, & + 0.3763D+01, 0.4600D+01, 0.4961D+01, 0.4247D+01 & + / + data (OREF(25,17, mtmp), mtmp=1,12) & + / & + 0.3949D+01, 0.4127D+01, 0.4548D+01, 0.3781D+01, & + 0.2944D+01, 0.2591D+01, 0.2555D+01, 0.2911D+01, & + 0.3750D+01, 0.4721D+01, 0.4961D+01, 0.4247D+01 & + / + data (OREF(25,18, mtmp), mtmp=1,12) & + / & + 0.3949D+01, 0.4127D+01, 0.4548D+01, 0.3781D+01, & + 0.2944D+01, 0.2591D+01, 0.2555D+01, 0.2911D+01, & + 0.3750D+01, 0.4721D+01, 0.4961D+01, 0.4247D+01 & + / + data (OREF(26, 1, mtmp), mtmp=1,12) & + / & + 0.1907D+01, 0.2218D+01, 0.3250D+01, 0.4424D+01, & + 0.4781D+01, 0.4713D+01, 0.3741D+01, 0.3195D+01, & + 0.2834D+01, 0.2534D+01, 0.2189D+01, 0.1984D+01 & + / + data (OREF(26, 2, mtmp), mtmp=1,12) & + / & + 0.1907D+01, 0.2218D+01, 0.3250D+01, 0.4424D+01, & + 0.4781D+01, 0.4713D+01, 0.3741D+01, 0.3195D+01, & + 0.2834D+01, 0.2534D+01, 0.2189D+01, 0.1984D+01 & + / + data (OREF(26, 3, mtmp), mtmp=1,12) & + / & + 0.2079D+01, 0.2283D+01, 0.2809D+01, 0.3822D+01, & + 0.4781D+01, 0.4713D+01, 0.3741D+01, 0.3070D+01, & + 0.2755D+01, 0.2624D+01, 0.2285D+01, 0.2127D+01 & + / + data (OREF(26, 4, mtmp), mtmp=1,12) & + / & + 0.2244D+01, 0.2405D+01, 0.2716D+01, 0.3340D+01, & + 0.4420D+01, 0.4721D+01, 0.3936D+01, 0.3223D+01, & + 0.2987D+01, 0.2755D+01, 0.2405D+01, 0.2264D+01 & + / + data (OREF(26, 5, mtmp), mtmp=1,12) & + / & + 0.2419D+01, 0.2555D+01, 0.2714D+01, 0.3051D+01, & + 0.3665D+01, 0.3921D+01, 0.3652D+01, 0.3414D+01, & + 0.3134D+01, 0.2777D+01, 0.2488D+01, 0.2400D+01 & + / + data (OREF(26, 6, mtmp), mtmp=1,12) & + / & + 0.2565D+01, 0.2668D+01, 0.2717D+01, 0.2847D+01, & + 0.3098D+01, 0.3164D+01, 0.3169D+01, 0.3220D+01, & + 0.3015D+01, 0.2721D+01, 0.2557D+01, 0.2528D+01 & + / + data (OREF(26, 7, mtmp), mtmp=1,12) & + / & + 0.2633D+01, 0.2682D+01, 0.2657D+01, 0.2707D+01, & + 0.2820D+01, 0.2867D+01, 0.2897D+01, 0.2950D+01, & + 0.2838D+01, 0.2691D+01, 0.2619D+01, 0.2634D+01 & + / + data (OREF(26, 8, mtmp), mtmp=1,12) & + / & + 0.2622D+01, 0.2588D+01, 0.2583D+01, 0.2642D+01, & + 0.2727D+01, 0.2778D+01, 0.2769D+01, 0.2815D+01, & + 0.2763D+01, 0.2705D+01, 0.2665D+01, 0.2714D+01 & + / + data (OREF(26, 9, mtmp), mtmp=1,12) & + / & + 0.2602D+01, 0.2516D+01, 0.2550D+01, 0.2623D+01, & + 0.2716D+01, 0.2754D+01, 0.2726D+01, 0.2761D+01, & + 0.2749D+01, 0.2727D+01, 0.2706D+01, 0.2769D+01 & + / + data (OREF(26,10, mtmp), mtmp=1,12) & + / & + 0.2595D+01, 0.2522D+01, 0.2556D+01, 0.2623D+01, & + 0.2710D+01, 0.2750D+01, 0.2734D+01, 0.2762D+01, & + 0.2756D+01, 0.2739D+01, 0.2713D+01, 0.2768D+01 & + / + data (OREF(26,11, mtmp), mtmp=1,12) & + / & + 0.2574D+01, 0.2575D+01, 0.2618D+01, 0.2662D+01, & + 0.2721D+01, 0.2780D+01, 0.2797D+01, 0.2808D+01, & + 0.2766D+01, 0.2734D+01, 0.2672D+01, 0.2697D+01 & + / + data (OREF(26,12, mtmp), mtmp=1,12) & + / & + 0.2641D+01, 0.2639D+01, 0.2690D+01, 0.2706D+01, & + 0.2707D+01, 0.2767D+01, 0.2836D+01, 0.2867D+01, & + 0.2793D+01, 0.2719D+01, 0.2665D+01, 0.2691D+01 & + / + data (OREF(26,13, mtmp), mtmp=1,12) & + / & + 0.2857D+01, 0.2796D+01, 0.2689D+01, 0.2659D+01, & + 0.2625D+01, 0.2657D+01, 0.2754D+01, 0.2859D+01, & + 0.2804D+01, 0.2794D+01, 0.2831D+01, 0.2822D+01 & + / + data (OREF(26,14, mtmp), mtmp=1,12) & + / & + 0.3055D+01, 0.3041D+01, 0.2728D+01, 0.2534D+01, & + 0.2508D+01, 0.2503D+01, 0.2566D+01, 0.2700D+01, & + 0.2777D+01, 0.2994D+01, 0.3185D+01, 0.3111D+01 & + / + data (OREF(26,15, mtmp), mtmp=1,12) & + / & + 0.3125D+01, 0.3204D+01, 0.2913D+01, 0.2526D+01, & + 0.2379D+01, 0.2335D+01, 0.2350D+01, 0.2505D+01, & + 0.2769D+01, 0.3250D+01, 0.3535D+01, 0.3329D+01 & + / + data (OREF(26,16, mtmp), mtmp=1,12) & + / & + 0.3136D+01, 0.3346D+01, 0.3172D+01, 0.2630D+01, & + 0.2286D+01, 0.2171D+01, 0.2164D+01, 0.2368D+01, & + 0.2819D+01, 0.3412D+01, 0.3811D+01, 0.3251D+01 & + / + data (OREF(26,17, mtmp), mtmp=1,12) & + / & + 0.3136D+01, 0.3405D+01, 0.3539D+01, 0.2783D+01, & + 0.2234D+01, 0.2014D+01, 0.1980D+01, 0.2267D+01, & + 0.2825D+01, 0.3723D+01, 0.3811D+01, 0.3251D+01 & + / + data (OREF(26,18, mtmp), mtmp=1,12) & + / & + 0.3136D+01, 0.3405D+01, 0.3539D+01, 0.2783D+01, & + 0.2234D+01, 0.2014D+01, 0.1980D+01, 0.2267D+01, & + 0.2825D+01, 0.3723D+01, 0.3811D+01, 0.3251D+01 & + / + data (OREF(27, 1, mtmp), mtmp=1,12) & + / & + 0.1524D+01, 0.1746D+01, 0.2456D+01, 0.3283D+01, & + 0.3528D+01, 0.3472D+01, 0.2794D+01, 0.2505D+01, & + 0.2193D+01, 0.2034D+01, 0.1740D+01, 0.1590D+01 & + / + data (OREF(27, 2, mtmp), mtmp=1,12) & + / & + 0.1524D+01, 0.1746D+01, 0.2456D+01, 0.3283D+01, & + 0.3528D+01, 0.3472D+01, 0.2794D+01, 0.2505D+01, & + 0.2193D+01, 0.2034D+01, 0.1740D+01, 0.1590D+01 & + / + data (OREF(27, 3, mtmp), mtmp=1,12) & + / & + 0.1684D+01, 0.1826D+01, 0.2177D+01, 0.2853D+01, & + 0.3528D+01, 0.3472D+01, 0.2794D+01, 0.2374D+01, & + 0.2160D+01, 0.2094D+01, 0.1834D+01, 0.1728D+01 & + / + data (OREF(27, 4, mtmp), mtmp=1,12) & + / & + 0.1816D+01, 0.1936D+01, 0.2143D+01, 0.2560D+01, & + 0.3262D+01, 0.3413D+01, 0.2885D+01, 0.2453D+01, & + 0.2335D+01, 0.2177D+01, 0.1930D+01, 0.1838D+01 & + / + data (OREF(27, 5, mtmp), mtmp=1,12) & + / & + 0.1960D+01, 0.2066D+01, 0.2165D+01, 0.2387D+01, & + 0.2797D+01, 0.2938D+01, 0.2775D+01, 0.2608D+01, & + 0.2437D+01, 0.2185D+01, 0.1995D+01, 0.1947D+01 & + / + data (OREF(27, 6, mtmp), mtmp=1,12) & + / & + 0.2073D+01, 0.2156D+01, 0.2174D+01, 0.2250D+01, & + 0.2413D+01, 0.2456D+01, 0.2493D+01, 0.2490D+01, & + 0.2350D+01, 0.2146D+01, 0.2052D+01, 0.2046D+01 & + / + data (OREF(27, 7, mtmp), mtmp=1,12) & + / & + 0.2112D+01, 0.2156D+01, 0.2124D+01, 0.2156D+01, & + 0.2240D+01, 0.2282D+01, 0.2314D+01, 0.2313D+01, & + 0.2233D+01, 0.2139D+01, 0.2105D+01, 0.2126D+01 & + / + data (OREF(27, 8, mtmp), mtmp=1,12) & + / & + 0.2079D+01, 0.2057D+01, 0.2073D+01, 0.2132D+01, & + 0.2202D+01, 0.2237D+01, 0.2220D+01, 0.2239D+01, & + 0.2205D+01, 0.2169D+01, 0.2145D+01, 0.2181D+01 & + / + data (OREF(27, 9, mtmp), mtmp=1,12) & + / & + 0.2051D+01, 0.1990D+01, 0.2060D+01, 0.2136D+01, & + 0.2210D+01, 0.2227D+01, 0.2189D+01, 0.2221D+01, & + 0.2220D+01, 0.2203D+01, 0.2189D+01, 0.2229D+01 & + / + data (OREF(27,10, mtmp), mtmp=1,12) & + / & + 0.2044D+01, 0.1997D+01, 0.2066D+01, 0.2134D+01, & + 0.2206D+01, 0.2227D+01, 0.2201D+01, 0.2227D+01, & + 0.2229D+01, 0.2217D+01, 0.2200D+01, 0.2229D+01 & + / + data (OREF(27,11, mtmp), mtmp=1,12) & + / & + 0.2022D+01, 0.2044D+01, 0.2111D+01, 0.2157D+01, & + 0.2210D+01, 0.2256D+01, 0.2259D+01, 0.2250D+01, & + 0.2216D+01, 0.2192D+01, 0.2150D+01, 0.2158D+01 & + / + data (OREF(27,12, mtmp), mtmp=1,12) & + / & + 0.2067D+01, 0.2085D+01, 0.2157D+01, 0.2184D+01, & + 0.2195D+01, 0.2250D+01, 0.2299D+01, 0.2285D+01, & + 0.2213D+01, 0.2144D+01, 0.2111D+01, 0.2135D+01 & + / + data (OREF(27,13, mtmp), mtmp=1,12) & + / & + 0.2236D+01, 0.2186D+01, 0.2124D+01, 0.2132D+01, & + 0.2122D+01, 0.2158D+01, 0.2239D+01, 0.2286D+01, & + 0.2210D+01, 0.2169D+01, 0.2199D+01, 0.2204D+01 & + / + data (OREF(27,14, mtmp), mtmp=1,12) & + / & + 0.2377D+01, 0.2372D+01, 0.2116D+01, 0.2004D+01, & + 0.2019D+01, 0.2029D+01, 0.2083D+01, 0.2161D+01, & + 0.2177D+01, 0.2292D+01, 0.2425D+01, 0.2352D+01 & + / + data (OREF(27,15, mtmp), mtmp=1,12) & + / & + 0.2402D+01, 0.2492D+01, 0.2238D+01, 0.1977D+01, & + 0.1904D+01, 0.1890D+01, 0.1904D+01, 0.2002D+01, & + 0.2150D+01, 0.2463D+01, 0.2637D+01, 0.2468D+01 & + / + data (OREF(27,16, mtmp), mtmp=1,12) & + / & + 0.2435D+01, 0.2598D+01, 0.2422D+01, 0.2039D+01, & + 0.1825D+01, 0.1760D+01, 0.1755D+01, 0.1887D+01, & + 0.2163D+01, 0.2551D+01, 0.2814D+01, 0.2447D+01 & + / + data (OREF(27,17, mtmp), mtmp=1,12) & + / & + 0.2435D+01, 0.2675D+01, 0.2697D+01, 0.2139D+01, & + 0.1763D+01, 0.1609D+01, 0.1581D+01, 0.1792D+01, & + 0.2150D+01, 0.2779D+01, 0.2814D+01, 0.2447D+01 & + / + data (OREF(27,18, mtmp), mtmp=1,12) & + / & + 0.2435D+01, 0.2675D+01, 0.2697D+01, 0.2139D+01, & + 0.1763D+01, 0.1609D+01, 0.1581D+01, 0.1792D+01, & + 0.2150D+01, 0.2779D+01, 0.2814D+01, 0.2447D+01 & + / + data (OREF(28, 1, mtmp), mtmp=1,12) & + / & + 0.1241D+01, 0.1423D+01, 0.1869D+01, 0.2320D+01, & + 0.2491D+01, 0.2430D+01, 0.2050D+01, 0.1935D+01, & + 0.1704D+01, 0.1656D+01, 0.1413D+01, 0.1295D+01 & + / + data (OREF(28, 2, mtmp), mtmp=1,12) & + / & + 0.1241D+01, 0.1423D+01, 0.1869D+01, 0.2320D+01, & + 0.2491D+01, 0.2430D+01, 0.2050D+01, 0.1935D+01, & + 0.1704D+01, 0.1656D+01, 0.1413D+01, 0.1295D+01 & + / + data (OREF(28, 3, mtmp), mtmp=1,12) & + / & + 0.1379D+01, 0.1492D+01, 0.1757D+01, 0.2152D+01, & + 0.2491D+01, 0.2430D+01, 0.2050D+01, 0.1851D+01, & + 0.1731D+01, 0.1692D+01, 0.1497D+01, 0.1419D+01 & + / + data (OREF(28, 4, mtmp), mtmp=1,12) & + / & + 0.1481D+01, 0.1579D+01, 0.1742D+01, 0.2041D+01, & + 0.2416D+01, 0.2407D+01, 0.2128D+01, 0.1915D+01, & + 0.1861D+01, 0.1739D+01, 0.1569D+01, 0.1502D+01 & + / + data (OREF(28, 5, mtmp), mtmp=1,12) & + / & + 0.1595D+01, 0.1686D+01, 0.1762D+01, 0.1933D+01, & + 0.2220D+01, 0.2274D+01, 0.2189D+01, 0.2030D+01, & + 0.1924D+01, 0.1733D+01, 0.1615D+01, 0.1584D+01 & + / + data (OREF(28, 6, mtmp), mtmp=1,12) & + / & + 0.1686D+01, 0.1759D+01, 0.1768D+01, 0.1825D+01, & + 0.1948D+01, 0.1978D+01, 0.2028D+01, 0.1952D+01, & + 0.1853D+01, 0.1705D+01, 0.1658D+01, 0.1662D+01 & + / + data (OREF(28, 7, mtmp), mtmp=1,12) & + / & + 0.1709D+01, 0.1749D+01, 0.1719D+01, 0.1746D+01, & + 0.1818D+01, 0.1861D+01, 0.1893D+01, 0.1830D+01, & + 0.1770D+01, 0.1707D+01, 0.1702D+01, 0.1727D+01 & + / + data (OREF(28, 8, mtmp), mtmp=1,12) & + / & + 0.1667D+01, 0.1649D+01, 0.1672D+01, 0.1732D+01, & + 0.1798D+01, 0.1830D+01, 0.1810D+01, 0.1785D+01, & + 0.1763D+01, 0.1739D+01, 0.1738D+01, 0.1770D+01 & + / + data (OREF(28, 9, mtmp), mtmp=1,12) & + / & + 0.1639D+01, 0.1584D+01, 0.1663D+01, 0.1742D+01, & + 0.1810D+01, 0.1820D+01, 0.1780D+01, 0.1784D+01, & + 0.1787D+01, 0.1774D+01, 0.1783D+01, 0.1814D+01 & + / + data (OREF(28,10, mtmp), mtmp=1,12) & + / & + 0.1638D+01, 0.1596D+01, 0.1670D+01, 0.1740D+01, & + 0.1805D+01, 0.1819D+01, 0.1789D+01, 0.1792D+01, & + 0.1796D+01, 0.1788D+01, 0.1797D+01, 0.1820D+01 & + / + data (OREF(28,11, mtmp), mtmp=1,12) & + / & + 0.1625D+01, 0.1644D+01, 0.1713D+01, 0.1759D+01, & + 0.1806D+01, 0.1846D+01, 0.1842D+01, 0.1805D+01, & + 0.1777D+01, 0.1762D+01, 0.1750D+01, 0.1758D+01 & + / + data (OREF(28,12, mtmp), mtmp=1,12) & + / & + 0.1668D+01, 0.1683D+01, 0.1756D+01, 0.1786D+01, & + 0.1796D+01, 0.1846D+01, 0.1887D+01, 0.1826D+01, & + 0.1763D+01, 0.1708D+01, 0.1710D+01, 0.1738D+01 & + / + data (OREF(28,13, mtmp), mtmp=1,12) & + / & + 0.1817D+01, 0.1771D+01, 0.1721D+01, 0.1737D+01, & + 0.1734D+01, 0.1771D+01, 0.1843D+01, 0.1830D+01, & + 0.1758D+01, 0.1713D+01, 0.1774D+01, 0.1783D+01 & + / + data (OREF(28,14, mtmp), mtmp=1,12) & + / & + 0.1921D+01, 0.1930D+01, 0.1704D+01, 0.1619D+01, & + 0.1646D+01, 0.1664D+01, 0.1713D+01, 0.1732D+01, & + 0.1728D+01, 0.1794D+01, 0.1933D+01, 0.1855D+01 & + / + data (OREF(28,15, mtmp), mtmp=1,12) & + / & + 0.1877D+01, 0.1999D+01, 0.1798D+01, 0.1592D+01, & + 0.1548D+01, 0.1548D+01, 0.1562D+01, 0.1606D+01, & + 0.1697D+01, 0.1904D+01, 0.2019D+01, 0.1852D+01 & + / + data (OREF(28,16, mtmp), mtmp=1,12) & + / & + 0.1866D+01, 0.2002D+01, 0.1916D+01, 0.1641D+01, & + 0.1486D+01, 0.1446D+01, 0.1445D+01, 0.1515D+01, & + 0.1693D+01, 0.1928D+01, 0.2037D+01, 0.1828D+01 & + / + data (OREF(28,17, mtmp), mtmp=1,12) & + / & + 0.1866D+01, 0.2037D+01, 0.2036D+01, 0.1698D+01, & + 0.1433D+01, 0.1311D+01, 0.1291D+01, 0.1433D+01, & + 0.1655D+01, 0.2013D+01, 0.2037D+01, 0.1828D+01 & + / + data (OREF(28,18, mtmp), mtmp=1,12) & + / & + 0.1866D+01, 0.2037D+01, 0.2036D+01, 0.1698D+01, & + 0.1433D+01, 0.1311D+01, 0.1291D+01, 0.1433D+01, & + 0.1655D+01, 0.2013D+01, 0.2037D+01, 0.1828D+01 & + / + data (OREF(29, 1, mtmp), mtmp=1,12) & + / & + 0.1007D+01, 0.1157D+01, 0.1442D+01, 0.1685D+01, & + 0.1805D+01, 0.1743D+01, 0.1531D+01, 0.1488D+01, & + 0.1328D+01, 0.1332D+01, 0.1145D+01, 0.1052D+01 & + / + data (OREF(29, 2, mtmp), mtmp=1,12) & + / & + 0.1007D+01, 0.1157D+01, 0.1442D+01, 0.1685D+01, & + 0.1805D+01, 0.1743D+01, 0.1531D+01, 0.1488D+01, & + 0.1328D+01, 0.1332D+01, 0.1145D+01, 0.1052D+01 & + / + data (OREF(29, 3, mtmp), mtmp=1,12) & + / & + 0.1127D+01, 0.1217D+01, 0.1415D+01, 0.1647D+01, & + 0.1805D+01, 0.1743D+01, 0.1531D+01, 0.1444D+01, & + 0.1379D+01, 0.1359D+01, 0.1219D+01, 0.1163D+01 & + / + data (OREF(29, 4, mtmp), mtmp=1,12) & + / & + 0.1206D+01, 0.1286D+01, 0.1413D+01, 0.1628D+01, & + 0.1826D+01, 0.1756D+01, 0.1601D+01, 0.1502D+01, & + 0.1480D+01, 0.1389D+01, 0.1274D+01, 0.1225D+01 & + / + data (OREF(29, 5, mtmp), mtmp=1,12) & + / & + 0.1297D+01, 0.1374D+01, 0.1431D+01, 0.1563D+01, & + 0.1766D+01, 0.1774D+01, 0.1734D+01, 0.1593D+01, & + 0.1523D+01, 0.1381D+01, 0.1305D+01, 0.1288D+01 & + / + data (OREF(29, 6, mtmp), mtmp=1,12) & + / & + 0.1369D+01, 0.1433D+01, 0.1435D+01, 0.1477D+01, & + 0.1570D+01, 0.1592D+01, 0.1649D+01, 0.1541D+01, & + 0.1470D+01, 0.1359D+01, 0.1338D+01, 0.1349D+01 & + / + data (OREF(29, 7, mtmp), mtmp=1,12) & + / & + 0.1381D+01, 0.1416D+01, 0.1389D+01, 0.1410D+01, & + 0.1472D+01, 0.1515D+01, 0.1546D+01, 0.1455D+01, & + 0.1410D+01, 0.1365D+01, 0.1374D+01, 0.1401D+01 & + / + data (OREF(29, 8, mtmp), mtmp=1,12) & + / & + 0.1333D+01, 0.1319D+01, 0.1348D+01, 0.1405D+01, & + 0.1466D+01, 0.1494D+01, 0.1473D+01, 0.1426D+01, & + 0.1412D+01, 0.1396D+01, 0.1406D+01, 0.1433D+01 & + / + data (OREF(29, 9, mtmp), mtmp=1,12) & + / & + 0.1307D+01, 0.1259D+01, 0.1342D+01, 0.1419D+01, & + 0.1480D+01, 0.1486D+01, 0.1444D+01, 0.1431D+01, & + 0.1436D+01, 0.1427D+01, 0.1450D+01, 0.1474D+01 & + / + data (OREF(29,10, mtmp), mtmp=1,12) & + / & + 0.1309D+01, 0.1272D+01, 0.1349D+01, 0.1418D+01, & + 0.1475D+01, 0.1484D+01, 0.1453D+01, 0.1438D+01, & + 0.1443D+01, 0.1439D+01, 0.1465D+01, 0.1483D+01 & + / + data (OREF(29,11, mtmp), mtmp=1,12) & + / & + 0.1302D+01, 0.1319D+01, 0.1389D+01, 0.1433D+01, & + 0.1475D+01, 0.1508D+01, 0.1501D+01, 0.1448D+01, & + 0.1425D+01, 0.1416D+01, 0.1423D+01, 0.1430D+01 & + / + data (OREF(29,12, mtmp), mtmp=1,12) & + / & + 0.1343D+01, 0.1355D+01, 0.1427D+01, 0.1457D+01, & + 0.1467D+01, 0.1513D+01, 0.1545D+01, 0.1462D+01, & + 0.1408D+01, 0.1363D+01, 0.1383D+01, 0.1411D+01 & + / + data (OREF(29,13, mtmp), mtmp=1,12) & + / & + 0.1474D+01, 0.1431D+01, 0.1390D+01, 0.1411D+01, & + 0.1414D+01, 0.1450D+01, 0.1514D+01, 0.1467D+01, & + 0.1400D+01, 0.1358D+01, 0.1428D+01, 0.1440D+01 & + / + data (OREF(29,14, mtmp), mtmp=1,12) & + / & + 0.1553D+01, 0.1568D+01, 0.1366D+01, 0.1303D+01, & + 0.1339D+01, 0.1361D+01, 0.1406D+01, 0.1389D+01, & + 0.1373D+01, 0.1411D+01, 0.1540D+01, 0.1463D+01 & + / + data (OREF(29,15, mtmp), mtmp=1,12) & + / & + 0.1478D+01, 0.1610D+01, 0.1441D+01, 0.1278D+01, & + 0.1254D+01, 0.1265D+01, 0.1279D+01, 0.1287D+01, & + 0.1342D+01, 0.1481D+01, 0.1560D+01, 0.1407D+01 & + / + data (OREF(29,16, mtmp), mtmp=1,12) & + / & + 0.1441D+01, 0.1562D+01, 0.1521D+01, 0.1316D+01, & + 0.1207D+01, 0.1185D+01, 0.1187D+01, 0.1214D+01, & + 0.1329D+01, 0.1473D+01, 0.1501D+01, 0.1382D+01 & + / + data (OREF(29,17, mtmp), mtmp=1,12) & + / & + 0.1441D+01, 0.1558D+01, 0.1556D+01, 0.1350D+01, & + 0.1161D+01, 0.1065D+01, 0.1051D+01, 0.1145D+01, & + 0.1285D+01, 0.1484D+01, 0.1501D+01, 0.1382D+01 & + / + data (OREF(29,18, mtmp), mtmp=1,12) & + / & + 0.1441D+01, 0.1558D+01, 0.1556D+01, 0.1350D+01, & + 0.1161D+01, 0.1065D+01, 0.1051D+01, 0.1145D+01, & + 0.1285D+01, 0.1484D+01, 0.1501D+01, 0.1382D+01 & + / + data (OREF(30, 1, mtmp), mtmp=1,12) & + / & + 0.8120D+00, 0.9310D+00, 0.1127D+01, 0.1271D+01, & + 0.1355D+01, 0.1295D+01, 0.1169D+01, 0.1144D+01, & + 0.1037D+01, 0.1057D+01, 0.9210D+00, 0.8500D+00 & + / + data (OREF(30, 2, mtmp), mtmp=1,12) & + / & + 0.8120D+00, 0.9310D+00, 0.1127D+01, 0.1271D+01, & + 0.1355D+01, 0.1295D+01, 0.1169D+01, 0.1144D+01, & + 0.1037D+01, 0.1057D+01, 0.9210D+00, 0.8500D+00 & + / + data (OREF(30, 3, mtmp), mtmp=1,12) & + / & + 0.9170D+00, 0.9850D+00, 0.1128D+01, 0.1275D+01, & + 0.1355D+01, 0.1295D+01, 0.1169D+01, 0.1126D+01, & + 0.1088D+01, 0.1081D+01, 0.9870D+00, 0.9490D+00 & + / + data (OREF(30, 4, mtmp), mtmp=1,12) & + / & + 0.9790D+00, 0.1042D+01, 0.1135D+01, 0.1289D+01, & + 0.1409D+01, 0.1332D+01, 0.1227D+01, 0.1177D+01, & + 0.1168D+01, 0.1107D+01, 0.1029D+01, 0.9970D+00 & + / + data (OREF(30, 5, mtmp), mtmp=1,12) & + / & + 0.1053D+01, 0.1116D+01, 0.1155D+01, 0.1252D+01, & + 0.1396D+01, 0.1384D+01, 0.1367D+01, 0.1254D+01, & + 0.1206D+01, 0.1102D+01, 0.1051D+01, 0.1045D+01 & + / + data (OREF(30, 6, mtmp), mtmp=1,12) & + / & + 0.1109D+01, 0.1163D+01, 0.1159D+01, 0.1185D+01, & + 0.1253D+01, 0.1269D+01, 0.1329D+01, 0.1223D+01, & + 0.1169D+01, 0.1086D+01, 0.1077D+01, 0.1093D+01 & + / + data (OREF(30, 7, mtmp), mtmp=1,12) & + / & + 0.1112D+01, 0.1143D+01, 0.1117D+01, 0.1133D+01, & + 0.1184D+01, 0.1225D+01, 0.1253D+01, 0.1160D+01, & + 0.1127D+01, 0.1094D+01, 0.1107D+01, 0.1133D+01 & + / + data (OREF(30, 8, mtmp), mtmp=1,12) & + / & + 0.1062D+01, 0.1051D+01, 0.1083D+01, 0.1137D+01, & + 0.1191D+01, 0.1214D+01, 0.1192D+01, 0.1141D+01, & + 0.1133D+01, 0.1121D+01, 0.1135D+01, 0.1157D+01 & + / + data (OREF(30, 9, mtmp), mtmp=1,12) & + / & + 0.1037D+01, 0.9970D+00, 0.1082D+01, 0.1155D+01, & + 0.1208D+01, 0.1209D+01, 0.1167D+01, 0.1147D+01, & + 0.1153D+01, 0.1147D+01, 0.1176D+01, 0.1193D+01 & + / + data (OREF(30,10, mtmp), mtmp=1,12) & + / & + 0.1040D+01, 0.1011D+01, 0.1089D+01, 0.1154D+01, & + 0.1204D+01, 0.1207D+01, 0.1175D+01, 0.1153D+01, & + 0.1158D+01, 0.1157D+01, 0.1192D+01, 0.1203D+01 & + / + data (OREF(30,11, mtmp), mtmp=1,12) & + / & + 0.1035D+01, 0.1053D+01, 0.1122D+01, 0.1165D+01, & + 0.1201D+01, 0.1229D+01, 0.1218D+01, 0.1162D+01, & + 0.1142D+01, 0.1137D+01, 0.1153D+01, 0.1156D+01 & + / + data (OREF(30,12, mtmp), mtmp=1,12) & + / & + 0.1071D+01, 0.1083D+01, 0.1153D+01, 0.1184D+01, & + 0.1195D+01, 0.1235D+01, 0.1260D+01, 0.1173D+01, & + 0.1125D+01, 0.1087D+01, 0.1110D+01, 0.1137D+01 & + / + data (OREF(30,13, mtmp), mtmp=1,12) & + / & + 0.1184D+01, 0.1144D+01, 0.1114D+01, 0.1140D+01, & + 0.1148D+01, 0.1183D+01, 0.1238D+01, 0.1176D+01, & + 0.1115D+01, 0.1075D+01, 0.1137D+01, 0.1151D+01 & + / + data (OREF(30,14, mtmp), mtmp=1,12) & + / & + 0.1245D+01, 0.1261D+01, 0.1083D+01, 0.1041D+01, & + 0.1083D+01, 0.1108D+01, 0.1148D+01, 0.1112D+01, & + 0.1090D+01, 0.1109D+01, 0.1214D+01, 0.1145D+01 & + / + data (OREF(30,15, mtmp), mtmp=1,12) & + / & + 0.1169D+01, 0.1292D+01, 0.1141D+01, 0.1015D+01, & + 0.1011D+01, 0.1029D+01, 0.1042D+01, 0.1028D+01, & + 0.1059D+01, 0.1154D+01, 0.1210D+01, 0.1080D+01 & + / + data (OREF(30,16, mtmp), mtmp=1,12) & + / & + 0.1124D+01, 0.1234D+01, 0.1202D+01, 0.1044D+01, & + 0.9730D+00, 0.9670D+00, 0.9700D+00, 0.9690D+00, & + 0.1043D+01, 0.1136D+01, 0.1131D+01, 0.1058D+01 & + / + data (OREF(30,17, mtmp), mtmp=1,12) & + / & + 0.1124D+01, 0.1205D+01, 0.1206D+01, 0.1066D+01, & + 0.9330D+00, 0.8590D+00, 0.8500D+00, 0.9110D+00, & + 0.1004D+01, 0.1121D+01, 0.1131D+01, 0.1058D+01 & + / + data (OREF(30,18, mtmp), mtmp=1,12) & + / & + 0.1124D+01, 0.1205D+01, 0.1206D+01, 0.1066D+01, & + 0.9330D+00, 0.8590D+00, 0.8500D+00, 0.9110D+00, & + 0.1004D+01, 0.1121D+01, 0.1131D+01, 0.1058D+01 & + / + data (OREF(31, 1, mtmp), mtmp=1,12) & + / & + 0.6540D+00, 0.7480D+00, 0.8830D+00, 0.9680D+00, & + 0.1026D+01, 0.9720D+00, 0.8980D+00, 0.8780D+00, & + 0.8100D+00, 0.8350D+00, 0.7390D+00, 0.6860D+00 & + / + data (OREF(31, 2, mtmp), mtmp=1,12) & + / & + 0.6540D+00, 0.7480D+00, 0.8830D+00, 0.9680D+00, & + 0.1026D+01, 0.9720D+00, 0.8980D+00, 0.8780D+00, & + 0.8100D+00, 0.8350D+00, 0.7390D+00, 0.6860D+00 & + / + data (OREF(31, 3, mtmp), mtmp=1,12) & + / & + 0.7460D+00, 0.7950D+00, 0.8970D+00, 0.9910D+00, & + 0.1026D+01, 0.9720D+00, 0.8980D+00, 0.8780D+00, & + 0.8560D+00, 0.8580D+00, 0.7980D+00, 0.7740D+00 & + / + data (OREF(31, 4, mtmp), mtmp=1,12) & + / & + 0.7940D+00, 0.8430D+00, 0.9100D+00, 0.1018D+01, & + 0.1092D+01, 0.1022D+01, 0.9440D+00, 0.9220D+00, & + 0.9200D+00, 0.8820D+00, 0.8300D+00, 0.8110D+00 & + / + data (OREF(31, 5, mtmp), mtmp=1,12) & + / & + 0.8540D+00, 0.9060D+00, 0.9310D+00, 0.1000D+01, & + 0.1102D+01, 0.1080D+01, 0.1077D+01, 0.9890D+00, & + 0.9540D+00, 0.8800D+00, 0.8450D+00, 0.8480D+00 & + / + data (OREF(31, 6, mtmp), mtmp=1,12) & + / & + 0.8980D+00, 0.9430D+00, 0.9340D+00, 0.9500D+00, & + 0.9970D+00, 0.1009D+01, 0.1070D+01, 0.9710D+00, & + 0.9300D+00, 0.8690D+00, 0.8660D+00, 0.8850D+00 & + / + data (OREF(31, 7, mtmp), mtmp=1,12) & + / & + 0.8950D+00, 0.9210D+00, 0.8970D+00, 0.9090D+00, & + 0.9510D+00, 0.9880D+00, 0.1014D+01, 0.9260D+00, & + 0.9020D+00, 0.8770D+00, 0.8910D+00, 0.9160D+00 & + / + data (OREF(31, 8, mtmp), mtmp=1,12) & + / & + 0.8450D+00, 0.8370D+00, 0.8700D+00, 0.9190D+00, & + 0.9660D+00, 0.9850D+00, 0.9640D+00, 0.9140D+00, & + 0.9090D+00, 0.9010D+00, 0.9150D+00, 0.9320D+00 & + / + data (OREF(31, 9, mtmp), mtmp=1,12) & + / & + 0.8210D+00, 0.7900D+00, 0.8720D+00, 0.9400D+00, & + 0.9850D+00, 0.9820D+00, 0.9420D+00, 0.9190D+00, & + 0.9250D+00, 0.9220D+00, 0.9530D+00, 0.9640D+00 & + / + data (OREF(31,10, mtmp), mtmp=1,12) & + / & + 0.8250D+00, 0.8020D+00, 0.8790D+00, 0.9390D+00, & + 0.9810D+00, 0.9810D+00, 0.9500D+00, 0.9240D+00, & + 0.9290D+00, 0.9300D+00, 0.9690D+00, 0.9750D+00 & + / + data (OREF(31,11, mtmp), mtmp=1,12) & + / & + 0.8220D+00, 0.8400D+00, 0.9060D+00, 0.9460D+00, & + 0.9780D+00, 0.1000D+01, 0.9870D+00, 0.9320D+00, & + 0.9160D+00, 0.9130D+00, 0.9320D+00, 0.9330D+00 & + / + data (OREF(31,12, mtmp), mtmp=1,12) & + / & + 0.8520D+00, 0.8640D+00, 0.9310D+00, 0.9600D+00, & + 0.9720D+00, 0.1007D+01, 0.1027D+01, 0.9410D+00, & + 0.8990D+00, 0.8670D+00, 0.8900D+00, 0.9140D+00 & + / + data (OREF(31,13, mtmp), mtmp=1,12) & + / & + 0.9480D+00, 0.9120D+00, 0.8900D+00, 0.9200D+00, & + 0.9310D+00, 0.9630D+00, 0.1011D+01, 0.9440D+00, & + 0.8880D+00, 0.8510D+00, 0.9030D+00, 0.9180D+00 & + / + data (OREF(31,14, mtmp), mtmp=1,12) & + / & + 0.9960D+00, 0.1011D+01, 0.8560D+00, 0.8300D+00, & + 0.8750D+00, 0.9010D+00, 0.9360D+00, 0.8910D+00, & + 0.8660D+00, 0.8720D+00, 0.9550D+00, 0.8940D+00 & + / + data (OREF(31,15, mtmp), mtmp=1,12) & + / & + 0.9260D+00, 0.1036D+01, 0.9010D+00, 0.8050D+00, & + 0.8130D+00, 0.8360D+00, 0.8480D+00, 0.8210D+00, & + 0.8360D+00, 0.8990D+00, 0.9390D+00, 0.8300D+00 & + / + data (OREF(31,16, mtmp), mtmp=1,12) & + / & + 0.8790D+00, 0.9790D+00, 0.9490D+00, 0.8250D+00, & + 0.7830D+00, 0.7870D+00, 0.7910D+00, 0.7730D+00, & + 0.8180D+00, 0.8780D+00, 0.8570D+00, 0.8130D+00 & + / + data (OREF(31,17, mtmp), mtmp=1,12) & + / & + 0.8790D+00, 0.9350D+00, 0.9390D+00, 0.8400D+00, & + 0.7480D+00, 0.6920D+00, 0.6860D+00, 0.7250D+00, & + 0.7860D+00, 0.8530D+00, 0.8570D+00, 0.8130D+00 & + / + data (OREF(31,18, mtmp), mtmp=1,12) & + / & + 0.8790D+00, 0.9350D+00, 0.9390D+00, 0.8400D+00, & + 0.7480D+00, 0.6920D+00, 0.6860D+00, 0.7250D+00, & + 0.7860D+00, 0.8530D+00, 0.8570D+00, 0.8130D+00 & + / + data (OREF(32, 1, mtmp), mtmp=1,12) & + / & + 0.4384D+00, 0.5014D+00, 0.5919D+00, 0.6489D+00, & + 0.6877D+00, 0.6516D+00, 0.6019D+00, 0.5885D+00, & + 0.5430D+00, 0.5597D+00, 0.4954D+00, 0.4598D+00 & + / + data (OREF(32, 2, mtmp), mtmp=1,12) & + / & + 0.4384D+00, 0.5014D+00, 0.5919D+00, 0.6489D+00, & + 0.6877D+00, 0.6516D+00, 0.6019D+00, 0.5885D+00, & + 0.5430D+00, 0.5597D+00, 0.4954D+00, 0.4598D+00 & + / + data (OREF(32, 3, mtmp), mtmp=1,12) & + / & + 0.5001D+00, 0.5329D+00, 0.6013D+00, 0.6643D+00, & + 0.6877D+00, 0.6516D+00, 0.6019D+00, 0.5885D+00, & + 0.5738D+00, 0.5751D+00, 0.5349D+00, 0.5188D+00 & + / + data (OREF(32, 4, mtmp), mtmp=1,12) & + / & + 0.5322D+00, 0.5651D+00, 0.6100D+00, 0.6824D+00, & + 0.7320D+00, 0.6851D+00, 0.6328D+00, 0.6180D+00, & + 0.6167D+00, 0.5912D+00, 0.5564D+00, 0.5436D+00 & + / + data (OREF(32, 5, mtmp), mtmp=1,12) & + / & + 0.5725D+00, 0.6073D+00, 0.6241D+00, 0.6703D+00, & + 0.7387D+00, 0.7239D+00, 0.7219D+00, 0.6629D+00, & + 0.6395D+00, 0.5899D+00, 0.5664D+00, 0.5684D+00 & + / + data (OREF(32, 6, mtmp), mtmp=1,12) & + / & + 0.6019D+00, 0.6321D+00, 0.6261D+00, 0.6368D+00, & + 0.6683D+00, 0.6764D+00, 0.7172D+00, 0.6509D+00, & + 0.6234D+00, 0.5825D+00, 0.5805D+00, 0.5932D+00 & + / + data (OREF(32, 7, mtmp), mtmp=1,12) & + / & + 0.5999D+00, 0.6174D+00, 0.6013D+00, 0.6093D+00, & + 0.6375D+00, 0.6623D+00, 0.6797D+00, 0.6207D+00, & + 0.6046D+00, 0.5879D+00, 0.5973D+00, 0.6140D+00 & + / + data (OREF(32, 8, mtmp), mtmp=1,12) & + / & + 0.5664D+00, 0.5611D+00, 0.5832D+00, 0.6160D+00, & + 0.6475D+00, 0.6603D+00, 0.6462D+00, 0.6127D+00, & + 0.6093D+00, 0.6040D+00, 0.6133D+00, 0.6247D+00 & + / + data (OREF(32, 9, mtmp), mtmp=1,12) & + / & + 0.5503D+00, 0.5296D+00, 0.5845D+00, 0.6301D+00, & + 0.6603D+00, 0.6583D+00, 0.6314D+00, 0.6160D+00, & + 0.6200D+00, 0.6180D+00, 0.6388D+00, 0.6462D+00 & + / + data (OREF(32,10, mtmp), mtmp=1,12) & + / & + 0.5530D+00, 0.5376D+00, 0.5892D+00, 0.6294D+00, & + 0.6576D+00, 0.6576D+00, 0.6368D+00, 0.6194D+00, & + 0.6227D+00, 0.6234D+00, 0.6495D+00, 0.6536D+00 & + / + data (OREF(32,11, mtmp), mtmp=1,12) & + / & + 0.5510D+00, 0.5631D+00, 0.6073D+00, 0.6341D+00, & + 0.6556D+00, 0.6703D+00, 0.6616D+00, 0.6247D+00, & + 0.6140D+00, 0.6120D+00, 0.6247D+00, 0.6254D+00 & + / + data (OREF(32,12, mtmp), mtmp=1,12) & + / & + 0.5711D+00, 0.5792D+00, 0.6241D+00, 0.6435D+00, & + 0.6516D+00, 0.6750D+00, 0.6884D+00, 0.6308D+00, & + 0.6026D+00, 0.5812D+00, 0.5966D+00, 0.6127D+00 & + / + data (OREF(32,13, mtmp), mtmp=1,12) & + / & + 0.6355D+00, 0.6113D+00, 0.5966D+00, 0.6167D+00, & + 0.6241D+00, 0.6455D+00, 0.6777D+00, 0.6328D+00, & + 0.5952D+00, 0.5704D+00, 0.6053D+00, 0.6154D+00 & + / + data (OREF(32,14, mtmp), mtmp=1,12) & + / & + 0.6676D+00, 0.6777D+00, 0.5738D+00, 0.5564D+00, & + 0.5865D+00, 0.6040D+00, 0.6274D+00, 0.5973D+00, & + 0.5805D+00, 0.5845D+00, 0.6402D+00, 0.5993D+00 & + / + data (OREF(32,15, mtmp), mtmp=1,12) & + / & + 0.6207D+00, 0.6945D+00, 0.6040D+00, 0.5396D+00, & + 0.5450D+00, 0.5604D+00, 0.5684D+00, 0.5503D+00, & + 0.5604D+00, 0.6026D+00, 0.6294D+00, 0.5564D+00 & + / + data (OREF(32,16, mtmp), mtmp=1,12) & + / & + 0.5892D+00, 0.6562D+00, 0.6361D+00, 0.5530D+00, & + 0.5249D+00, 0.5275D+00, 0.5302D+00, 0.5182D+00, & + 0.5483D+00, 0.5885D+00, 0.5745D+00, 0.5450D+00 & + / + data (OREF(32,17, mtmp), mtmp=1,12) & + / & + 0.5892D+00, 0.6267D+00, 0.6294D+00, 0.5631D+00, & + 0.5014D+00, 0.4639D+00, 0.4598D+00, 0.4860D+00, & + 0.5269D+00, 0.5718D+00, 0.5745D+00, 0.5450D+00 & + / + data (OREF(32,18, mtmp), mtmp=1,12) & + / & + 0.5892D+00, 0.6267D+00, 0.6294D+00, 0.5631D+00, & + 0.5014D+00, 0.4639D+00, 0.4598D+00, 0.4860D+00, & + 0.5269D+00, 0.5718D+00, 0.5745D+00, 0.5450D+00 & + / + data (OREF(33, 1, mtmp), mtmp=1,12) & + / & + 0.2939D+00, 0.3361D+00, 0.3968D+00, 0.4350D+00, & + 0.4610D+00, 0.4367D+00, 0.4035D+00, 0.3945D+00, & + 0.3640D+00, 0.3752D+00, 0.3321D+00, 0.3082D+00 & + / + data (OREF(33, 2, mtmp), mtmp=1,12) & + / & + 0.2939D+00, 0.3361D+00, 0.3968D+00, 0.4350D+00, & + 0.4610D+00, 0.4367D+00, 0.4035D+00, 0.3945D+00, & + 0.3640D+00, 0.3752D+00, 0.3321D+00, 0.3082D+00 & + / + data (OREF(33, 3, mtmp), mtmp=1,12) & + / & + 0.3352D+00, 0.3572D+00, 0.4030D+00, 0.4453D+00, & + 0.4610D+00, 0.4367D+00, 0.4035D+00, 0.3945D+00, & + 0.3846D+00, 0.3855D+00, 0.3586D+00, 0.3478D+00 & + / + data (OREF(33, 4, mtmp), mtmp=1,12) & + / & + 0.3568D+00, 0.3788D+00, 0.4089D+00, 0.4574D+00, & + 0.4907D+00, 0.4592D+00, 0.4242D+00, 0.4143D+00, & + 0.4134D+00, 0.3963D+00, 0.3729D+00, 0.3644D+00 & + / + data (OREF(33, 5, mtmp), mtmp=1,12) & + / & + 0.3837D+00, 0.4071D+00, 0.4183D+00, 0.4493D+00, & + 0.4952D+00, 0.4853D+00, 0.4839D+00, 0.4444D+00, & + 0.4287D+00, 0.3954D+00, 0.3797D+00, 0.3810D+00 & + / + data (OREF(33, 6, mtmp), mtmp=1,12) & + / & + 0.4035D+00, 0.4237D+00, 0.4197D+00, 0.4269D+00, & + 0.4480D+00, 0.4534D+00, 0.4808D+00, 0.4363D+00, & + 0.4179D+00, 0.3905D+00, 0.3891D+00, 0.3977D+00 & + / + data (OREF(33, 7, mtmp), mtmp=1,12) & + / & + 0.4021D+00, 0.4138D+00, 0.4030D+00, 0.4084D+00, & + 0.4273D+00, 0.4439D+00, 0.4556D+00, 0.4161D+00, & + 0.4053D+00, 0.3941D+00, 0.4004D+00, 0.4116D+00 & + / + data (OREF(33, 8, mtmp), mtmp=1,12) & + / & + 0.3797D+00, 0.3761D+00, 0.3909D+00, 0.4129D+00, & + 0.4341D+00, 0.4426D+00, 0.4332D+00, 0.4107D+00, & + 0.4084D+00, 0.4048D+00, 0.4111D+00, 0.4188D+00 & + / + data (OREF(33, 9, mtmp), mtmp=1,12) & + / & + 0.3689D+00, 0.3550D+00, 0.3918D+00, 0.4224D+00, & + 0.4426D+00, 0.4412D+00, 0.4233D+00, 0.4129D+00, & + 0.4156D+00, 0.4143D+00, 0.4282D+00, 0.4332D+00 & + / + data (OREF(33,10, mtmp), mtmp=1,12) & + / & + 0.3707D+00, 0.3604D+00, 0.3950D+00, 0.4219D+00, & + 0.4408D+00, 0.4408D+00, 0.4269D+00, 0.4152D+00, & + 0.4174D+00, 0.4179D+00, 0.4354D+00, 0.4381D+00 & + / + data (OREF(33,11, mtmp), mtmp=1,12) & + / & + 0.3693D+00, 0.3774D+00, 0.4071D+00, 0.4251D+00, & + 0.4394D+00, 0.4493D+00, 0.4435D+00, 0.4188D+00, & + 0.4116D+00, 0.4102D+00, 0.4188D+00, 0.4192D+00 & + / + data (OREF(33,12, mtmp), mtmp=1,12) & + / & + 0.3828D+00, 0.3882D+00, 0.4183D+00, 0.4314D+00, & + 0.4367D+00, 0.4525D+00, 0.4615D+00, 0.4228D+00, & + 0.4039D+00, 0.3896D+00, 0.3999D+00, 0.4107D+00 & + / + data (OREF(33,13, mtmp), mtmp=1,12) & + / & + 0.4260D+00, 0.4098D+00, 0.3999D+00, 0.4134D+00, & + 0.4183D+00, 0.4327D+00, 0.4543D+00, 0.4242D+00, & + 0.3990D+00, 0.3824D+00, 0.4057D+00, 0.4125D+00 & + / + data (OREF(33,14, mtmp), mtmp=1,12) & + / & + 0.4475D+00, 0.4543D+00, 0.3846D+00, 0.3729D+00, & + 0.3932D+00, 0.4048D+00, 0.4206D+00, 0.4004D+00, & + 0.3891D+00, 0.3918D+00, 0.4291D+00, 0.4017D+00 & + / + data (OREF(33,15, mtmp), mtmp=1,12) & + / & + 0.4161D+00, 0.4655D+00, 0.4048D+00, 0.3617D+00, & + 0.3653D+00, 0.3756D+00, 0.3810D+00, 0.3689D+00, & + 0.3756D+00, 0.4039D+00, 0.4219D+00, 0.3729D+00 & + / + data (OREF(33,16, mtmp), mtmp=1,12) & + / & + 0.3950D+00, 0.4399D+00, 0.4264D+00, 0.3707D+00, & + 0.3518D+00, 0.3536D+00, 0.3554D+00, 0.3473D+00, & + 0.3676D+00, 0.3945D+00, 0.3851D+00, 0.3653D+00 & + / + data (OREF(33,17, mtmp), mtmp=1,12) & + / & + 0.3950D+00, 0.4201D+00, 0.4219D+00, 0.3774D+00, & + 0.3361D+00, 0.3109D+00, 0.3082D+00, 0.3258D+00, & + 0.3532D+00, 0.3833D+00, 0.3851D+00, 0.3653D+00 & + / + data (OREF(33,18, mtmp), mtmp=1,12) & + / & + 0.3950D+00, 0.4201D+00, 0.4219D+00, 0.3774D+00, & + 0.3361D+00, 0.3109D+00, 0.3082D+00, 0.3258D+00, & + 0.3532D+00, 0.3833D+00, 0.3851D+00, 0.3653D+00 & + / + data (OREF(34, 1, mtmp), mtmp=1,12) & + / & + 0.1970D+00, 0.2253D+00, 0.2660D+00, 0.2916D+00, & + 0.3090D+00, 0.2928D+00, 0.2705D+00, 0.2644D+00, & + 0.2440D+00, 0.2515D+00, 0.2226D+00, 0.2066D+00 & + / + data (OREF(34, 2, mtmp), mtmp=1,12) & + / & + 0.1970D+00, 0.2253D+00, 0.2660D+00, 0.2916D+00, & + 0.3090D+00, 0.2928D+00, 0.2705D+00, 0.2644D+00, & + 0.2440D+00, 0.2515D+00, 0.2226D+00, 0.2066D+00 & + / + data (OREF(34, 3, mtmp), mtmp=1,12) & + / & + 0.2247D+00, 0.2394D+00, 0.2702D+00, 0.2985D+00, & + 0.3090D+00, 0.2928D+00, 0.2705D+00, 0.2644D+00, & + 0.2578D+00, 0.2584D+00, 0.2404D+00, 0.2331D+00 & + / + data (OREF(34, 4, mtmp), mtmp=1,12) & + / & + 0.2391D+00, 0.2539D+00, 0.2741D+00, 0.3066D+00, & + 0.3289D+00, 0.3078D+00, 0.2843D+00, 0.2777D+00, & + 0.2771D+00, 0.2657D+00, 0.2500D+00, 0.2443D+00 & + / + data (OREF(34, 5, mtmp), mtmp=1,12) & + / & + 0.2572D+00, 0.2729D+00, 0.2804D+00, 0.3012D+00, & + 0.3319D+00, 0.3253D+00, 0.3244D+00, 0.2979D+00, & + 0.2873D+00, 0.2651D+00, 0.2545D+00, 0.2554D+00 & + / + data (OREF(34, 6, mtmp), mtmp=1,12) & + / & + 0.2705D+00, 0.2840D+00, 0.2813D+00, 0.2861D+00, & + 0.3003D+00, 0.3039D+00, 0.3223D+00, 0.2925D+00, & + 0.2801D+00, 0.2617D+00, 0.2608D+00, 0.2666D+00 & + / + data (OREF(34, 7, mtmp), mtmp=1,12) & + / & + 0.2696D+00, 0.2774D+00, 0.2702D+00, 0.2738D+00, & + 0.2864D+00, 0.2976D+00, 0.3054D+00, 0.2789D+00, & + 0.2717D+00, 0.2641D+00, 0.2684D+00, 0.2759D+00 & + / + data (OREF(34, 8, mtmp), mtmp=1,12) & + / & + 0.2545D+00, 0.2521D+00, 0.2620D+00, 0.2768D+00, & + 0.2910D+00, 0.2967D+00, 0.2904D+00, 0.2753D+00, & + 0.2738D+00, 0.2714D+00, 0.2756D+00, 0.2807D+00 & + / + data (OREF(34, 9, mtmp), mtmp=1,12) & + / & + 0.2473D+00, 0.2379D+00, 0.2626D+00, 0.2831D+00, & + 0.2967D+00, 0.2958D+00, 0.2837D+00, 0.2768D+00, & + 0.2786D+00, 0.2777D+00, 0.2870D+00, 0.2904D+00 & + / + data (OREF(34,10, mtmp), mtmp=1,12) & + / & + 0.2485D+00, 0.2416D+00, 0.2647D+00, 0.2828D+00, & + 0.2955D+00, 0.2955D+00, 0.2861D+00, 0.2783D+00, & + 0.2798D+00, 0.2801D+00, 0.2919D+00, 0.2937D+00 & + / + data (OREF(34,11, mtmp), mtmp=1,12) & + / & + 0.2476D+00, 0.2530D+00, 0.2729D+00, 0.2849D+00, & + 0.2946D+00, 0.3012D+00, 0.2973D+00, 0.2807D+00, & + 0.2759D+00, 0.2750D+00, 0.2807D+00, 0.2810D+00 & + / + data (OREF(34,12, mtmp), mtmp=1,12) & + / & + 0.2566D+00, 0.2602D+00, 0.2804D+00, 0.2891D+00, & + 0.2928D+00, 0.3033D+00, 0.3093D+00, 0.2834D+00, & + 0.2708D+00, 0.2611D+00, 0.2681D+00, 0.2753D+00 & + / + data (OREF(34,13, mtmp), mtmp=1,12) & + / & + 0.2855D+00, 0.2747D+00, 0.2681D+00, 0.2771D+00, & + 0.2804D+00, 0.2901D+00, 0.3045D+00, 0.2843D+00, & + 0.2675D+00, 0.2563D+00, 0.2720D+00, 0.2765D+00 & + / + data (OREF(34,14, mtmp), mtmp=1,12) & + / & + 0.3000D+00, 0.3045D+00, 0.2578D+00, 0.2500D+00, & + 0.2635D+00, 0.2714D+00, 0.2819D+00, 0.2684D+00, & + 0.2608D+00, 0.2626D+00, 0.2876D+00, 0.2693D+00 & + / + data (OREF(34,15, mtmp), mtmp=1,12) & + / & + 0.2789D+00, 0.3120D+00, 0.2714D+00, 0.2425D+00, & + 0.2449D+00, 0.2518D+00, 0.2554D+00, 0.2473D+00, & + 0.2518D+00, 0.2708D+00, 0.2828D+00, 0.2500D+00 & + / + data (OREF(34,16, mtmp), mtmp=1,12) & + / & + 0.2647D+00, 0.2949D+00, 0.2858D+00, 0.2485D+00, & + 0.2358D+00, 0.2370D+00, 0.2382D+00, 0.2328D+00, & + 0.2464D+00, 0.2644D+00, 0.2581D+00, 0.2449D+00 & + / + data (OREF(34,17, mtmp), mtmp=1,12) & + / & + 0.2647D+00, 0.2816D+00, 0.2828D+00, 0.2530D+00, & + 0.2253D+00, 0.2084D+00, 0.2066D+00, 0.2184D+00, & + 0.2367D+00, 0.2569D+00, 0.2581D+00, 0.2449D+00 & + / + data (OREF(34,18, mtmp), mtmp=1,12) & + / & + 0.2647D+00, 0.2816D+00, 0.2828D+00, 0.2530D+00, & + 0.2253D+00, 0.2084D+00, 0.2066D+00, 0.2184D+00, & + 0.2367D+00, 0.2569D+00, 0.2581D+00, 0.2449D+00 & + / + data (OREF(35, 1, mtmp), mtmp=1,12) & + / & + 0.1320D+00, 0.1510D+00, 0.1783D+00, 0.1954D+00, & + 0.2071D+00, 0.1962D+00, 0.1813D+00, 0.1773D+00, & + 0.1635D+00, 0.1686D+00, 0.1492D+00, 0.1385D+00 & + / + data (OREF(35, 2, mtmp), mtmp=1,12) & + / & + 0.1320D+00, 0.1510D+00, 0.1783D+00, 0.1954D+00, & + 0.2071D+00, 0.1962D+00, 0.1813D+00, 0.1773D+00, & + 0.1635D+00, 0.1686D+00, 0.1492D+00, 0.1385D+00 & + / + data (OREF(35, 3, mtmp), mtmp=1,12) & + / & + 0.1506D+00, 0.1605D+00, 0.1811D+00, 0.2001D+00, & + 0.2071D+00, 0.1962D+00, 0.1813D+00, 0.1773D+00, & + 0.1728D+00, 0.1732D+00, 0.1611D+00, 0.1563D+00 & + / + data (OREF(35, 4, mtmp), mtmp=1,12) & + / & + 0.1603D+00, 0.1702D+00, 0.1837D+00, 0.2055D+00, & + 0.2205D+00, 0.2063D+00, 0.1906D+00, 0.1861D+00, & + 0.1857D+00, 0.1781D+00, 0.1676D+00, 0.1637D+00 & + / + data (OREF(35, 5, mtmp), mtmp=1,12) & + / & + 0.1724D+00, 0.1829D+00, 0.1880D+00, 0.2019D+00, & + 0.2225D+00, 0.2180D+00, 0.2174D+00, 0.1997D+00, & + 0.1926D+00, 0.1777D+00, 0.1706D+00, 0.1712D+00 & + / + data (OREF(35, 6, mtmp), mtmp=1,12) & + / & + 0.1813D+00, 0.1904D+00, 0.1886D+00, 0.1918D+00, & + 0.2013D+00, 0.2037D+00, 0.2160D+00, 0.1960D+00, & + 0.1878D+00, 0.1754D+00, 0.1748D+00, 0.1787D+00 & + / + data (OREF(35, 7, mtmp), mtmp=1,12) & + / & + 0.1807D+00, 0.1859D+00, 0.1811D+00, 0.1835D+00, & + 0.1920D+00, 0.1995D+00, 0.2047D+00, 0.1870D+00, & + 0.1821D+00, 0.1771D+00, 0.1799D+00, 0.1849D+00 & + / + data (OREF(35, 8, mtmp), mtmp=1,12) & + / & + 0.1706D+00, 0.1690D+00, 0.1756D+00, 0.1855D+00, & + 0.1950D+00, 0.1989D+00, 0.1946D+00, 0.1845D+00, & + 0.1835D+00, 0.1819D+00, 0.1847D+00, 0.1882D+00 & + / + data (OREF(35, 9, mtmp), mtmp=1,12) & + / & + 0.1658D+00, 0.1595D+00, 0.1761D+00, 0.1898D+00, & + 0.1989D+00, 0.1983D+00, 0.1902D+00, 0.1855D+00, & + 0.1868D+00, 0.1861D+00, 0.1924D+00, 0.1946D+00 & + / + data (OREF(35,10, mtmp), mtmp=1,12) & + / & + 0.1666D+00, 0.1619D+00, 0.1775D+00, 0.1896D+00, & + 0.1981D+00, 0.1981D+00, 0.1918D+00, 0.1866D+00, & + 0.1876D+00, 0.1878D+00, 0.1956D+00, 0.1968D+00 & + / + data (OREF(35,11, mtmp), mtmp=1,12) & + / & + 0.1660D+00, 0.1696D+00, 0.1829D+00, 0.1910D+00, & + 0.1975D+00, 0.2019D+00, 0.1993D+00, 0.1882D+00, & + 0.1849D+00, 0.1843D+00, 0.1882D+00, 0.1884D+00 & + / + data (OREF(35,12, mtmp), mtmp=1,12) & + / & + 0.1720D+00, 0.1744D+00, 0.1880D+00, 0.1938D+00, & + 0.1962D+00, 0.2033D+00, 0.2073D+00, 0.1900D+00, & + 0.1815D+00, 0.1750D+00, 0.1797D+00, 0.1845D+00 & + / + data (OREF(35,13, mtmp), mtmp=1,12) & + / & + 0.1914D+00, 0.1841D+00, 0.1797D+00, 0.1857D+00, & + 0.1880D+00, 0.1944D+00, 0.2041D+00, 0.1906D+00, & + 0.1793D+00, 0.1718D+00, 0.1823D+00, 0.1853D+00 & + / + data (OREF(35,14, mtmp), mtmp=1,12) & + / & + 0.2011D+00, 0.2041D+00, 0.1728D+00, 0.1676D+00, & + 0.1767D+00, 0.1819D+00, 0.1890D+00, 0.1799D+00, & + 0.1748D+00, 0.1761D+00, 0.1928D+00, 0.1805D+00 & + / + data (OREF(35,15, mtmp), mtmp=1,12) & + / & + 0.1870D+00, 0.2092D+00, 0.1819D+00, 0.1625D+00, & + 0.1641D+00, 0.1688D+00, 0.1712D+00, 0.1658D+00, & + 0.1688D+00, 0.1815D+00, 0.1896D+00, 0.1676D+00 & + / + data (OREF(35,16, mtmp), mtmp=1,12) & + / & + 0.1775D+00, 0.1977D+00, 0.1916D+00, 0.1666D+00, & + 0.1581D+00, 0.1589D+00, 0.1597D+00, 0.1561D+00, & + 0.1652D+00, 0.1773D+00, 0.1730D+00, 0.1641D+00 & + / + data (OREF(35,17, mtmp), mtmp=1,12) & + / & + 0.1775D+00, 0.1888D+00, 0.1896D+00, 0.1696D+00, & + 0.1510D+00, 0.1397D+00, 0.1385D+00, 0.1464D+00, & + 0.1587D+00, 0.1722D+00, 0.1730D+00, 0.1641D+00 & + / + data (OREF(35,18, mtmp), mtmp=1,12) & + / & + 0.1775D+00, 0.1888D+00, 0.1896D+00, 0.1696D+00, & + 0.1510D+00, 0.1397D+00, 0.1385D+00, 0.1464D+00, & + 0.1587D+00, 0.1722D+00, 0.1730D+00, 0.1641D+00 & + / + data (OREF(36, 1, mtmp), mtmp=1,12) & + / & + 0.8851D-01, 0.1012D+00, 0.1195D+00, 0.1310D+00, & + 0.1389D+00, 0.1315D+00, 0.1215D+00, 0.1188D+00, & + 0.1096D+00, 0.1130D+00, 0.1000D+00, 0.9284D-01 & + / + data (OREF(36, 2, mtmp), mtmp=1,12) & + / & + 0.8851D-01, 0.1012D+00, 0.1195D+00, 0.1310D+00, & + 0.1389D+00, 0.1315D+00, 0.1215D+00, 0.1188D+00, & + 0.1096D+00, 0.1130D+00, 0.1000D+00, 0.9284D-01 & + / + data (OREF(36, 3, mtmp), mtmp=1,12) & + / & + 0.1010D+00, 0.1076D+00, 0.1214D+00, 0.1341D+00, & + 0.1389D+00, 0.1315D+00, 0.1215D+00, 0.1188D+00, & + 0.1158D+00, 0.1161D+00, 0.1080D+00, 0.1047D+00 & + / + data (OREF(36, 4, mtmp), mtmp=1,12) & + / & + 0.1075D+00, 0.1141D+00, 0.1232D+00, 0.1378D+00, & + 0.1478D+00, 0.1383D+00, 0.1278D+00, 0.1248D+00, & + 0.1245D+00, 0.1194D+00, 0.1123D+00, 0.1098D+00 & + / + data (OREF(36, 5, mtmp), mtmp=1,12) & + / & + 0.1156D+00, 0.1226D+00, 0.1260D+00, 0.1353D+00, & + 0.1491D+00, 0.1462D+00, 0.1458D+00, 0.1338D+00, & + 0.1291D+00, 0.1191D+00, 0.1144D+00, 0.1148D+00 & + / + data (OREF(36, 6, mtmp), mtmp=1,12) & + / & + 0.1215D+00, 0.1276D+00, 0.1264D+00, 0.1286D+00, & + 0.1349D+00, 0.1366D+00, 0.1448D+00, 0.1314D+00, & + 0.1259D+00, 0.1176D+00, 0.1172D+00, 0.1198D+00 & + / + data (OREF(36, 7, mtmp), mtmp=1,12) & + / & + 0.1211D+00, 0.1246D+00, 0.1214D+00, 0.1230D+00, & + 0.1287D+00, 0.1337D+00, 0.1372D+00, 0.1253D+00, & + 0.1221D+00, 0.1187D+00, 0.1206D+00, 0.1240D+00 & + / + data (OREF(36, 8, mtmp), mtmp=1,12) & + / & + 0.1144D+00, 0.1133D+00, 0.1177D+00, 0.1244D+00, & + 0.1307D+00, 0.1333D+00, 0.1305D+00, 0.1237D+00, & + 0.1230D+00, 0.1219D+00, 0.1238D+00, 0.1261D+00 & + / + data (OREF(36, 9, mtmp), mtmp=1,12) & + / & + 0.1111D+00, 0.1069D+00, 0.1180D+00, 0.1272D+00, & + 0.1333D+00, 0.1329D+00, 0.1275D+00, 0.1244D+00, & + 0.1252D+00, 0.1248D+00, 0.1290D+00, 0.1305D+00 & + / + data (OREF(36,10, mtmp), mtmp=1,12) & + / & + 0.1117D+00, 0.1085D+00, 0.1190D+00, 0.1271D+00, & + 0.1328D+00, 0.1328D+00, 0.1286D+00, 0.1250D+00, & + 0.1257D+00, 0.1259D+00, 0.1311D+00, 0.1320D+00 & + / + data (OREF(36,11, mtmp), mtmp=1,12) & + / & + 0.1112D+00, 0.1137D+00, 0.1226D+00, 0.1280D+00, & + 0.1324D+00, 0.1353D+00, 0.1336D+00, 0.1261D+00, & + 0.1240D+00, 0.1236D+00, 0.1261D+00, 0.1263D+00 & + / + data (OREF(36,12, mtmp), mtmp=1,12) & + / & + 0.1153D+00, 0.1169D+00, 0.1260D+00, 0.1299D+00, & + 0.1315D+00, 0.1363D+00, 0.1390D+00, 0.1274D+00, & + 0.1217D+00, 0.1173D+00, 0.1204D+00, 0.1237D+00 & + / + data (OREF(36,13, mtmp), mtmp=1,12) & + / & + 0.1283D+00, 0.1234D+00, 0.1204D+00, 0.1245D+00, & + 0.1260D+00, 0.1303D+00, 0.1368D+00, 0.1278D+00, & + 0.1202D+00, 0.1152D+00, 0.1222D+00, 0.1242D+00 & + / + data (OREF(36,14, mtmp), mtmp=1,12) & + / & + 0.1348D+00, 0.1368D+00, 0.1158D+00, 0.1123D+00, & + 0.1184D+00, 0.1219D+00, 0.1267D+00, 0.1206D+00, & + 0.1172D+00, 0.1180D+00, 0.1292D+00, 0.1210D+00 & + / + data (OREF(36,15, mtmp), mtmp=1,12) & + / & + 0.1253D+00, 0.1402D+00, 0.1219D+00, 0.1089D+00, & + 0.1100D+00, 0.1131D+00, 0.1148D+00, 0.1111D+00, & + 0.1131D+00, 0.1217D+00, 0.1271D+00, 0.1123D+00 & + / + data (OREF(36,16, mtmp), mtmp=1,12) & + / & + 0.1190D+00, 0.1325D+00, 0.1284D+00, 0.1117D+00, & + 0.1060D+00, 0.1065D+00, 0.1071D+00, 0.1046D+00, & + 0.1107D+00, 0.1188D+00, 0.1160D+00, 0.1100D+00 & + / + data (OREF(36,17, mtmp), mtmp=1,12) & + / & + 0.1190D+00, 0.1265D+00, 0.1271D+00, 0.1137D+00, & + 0.1012D+00, 0.9365D-01, 0.9284D-01, 0.9812D-01, & + 0.1064D+00, 0.1154D+00, 0.1160D+00, 0.1100D+00 & + / + data (OREF(36,18, mtmp), mtmp=1,12) & + / & + 0.1190D+00, 0.1265D+00, 0.1271D+00, 0.1137D+00, & + 0.1012D+00, 0.9365D-01, 0.9284D-01, 0.9812D-01, & + 0.1064D+00, 0.1154D+00, 0.1160D+00, 0.1100D+00 & + / + data (OREF(37, 1, mtmp), mtmp=1,12) & + / & + 0.5933D-01, 0.6786D-01, 0.8010D-01, 0.8781D-01, & + 0.9308D-01, 0.8818D-01, 0.8146D-01, 0.7965D-01, & + 0.7348D-01, 0.7575D-01, 0.6704D-01, 0.6223D-01 & + / + data (OREF(37, 2, mtmp), mtmp=1,12) & + / & + 0.5933D-01, 0.6786D-01, 0.8010D-01, 0.8781D-01, & + 0.9308D-01, 0.8818D-01, 0.8146D-01, 0.7965D-01, & + 0.7348D-01, 0.7575D-01, 0.6704D-01, 0.6223D-01 & + / + data (OREF(37, 3, mtmp), mtmp=1,12) & + / & + 0.6768D-01, 0.7212D-01, 0.8137D-01, 0.8990D-01, & + 0.9308D-01, 0.8818D-01, 0.8146D-01, 0.7965D-01, & + 0.7765D-01, 0.7784D-01, 0.7239D-01, 0.7022D-01 & + / + data (OREF(37, 4, mtmp), mtmp=1,12) & + / & + 0.7203D-01, 0.7648D-01, 0.8255D-01, 0.9235D-01, & + 0.9906D-01, 0.9271D-01, 0.8564D-01, 0.8364D-01, & + 0.8346D-01, 0.8001D-01, 0.7530D-01, 0.7357D-01 & + / + data (OREF(37, 5, mtmp), mtmp=1,12) & + / & + 0.7747D-01, 0.8219D-01, 0.8446D-01, 0.9072D-01, & + 0.9997D-01, 0.9798D-01, 0.9770D-01, 0.8972D-01, & + 0.8654D-01, 0.7983D-01, 0.7666D-01, 0.7693D-01 & + / + data (OREF(37, 6, mtmp), mtmp=1,12) & + / & + 0.8146D-01, 0.8555D-01, 0.8473D-01, 0.8618D-01, & + 0.9045D-01, 0.9153D-01, 0.9707D-01, 0.8809D-01, & + 0.8437D-01, 0.7883D-01, 0.7856D-01, 0.8029D-01 & + / + data (OREF(37, 7, mtmp), mtmp=1,12) & + / & + 0.8119D-01, 0.8355D-01, 0.8137D-01, 0.8246D-01, & + 0.8627D-01, 0.8963D-01, 0.9199D-01, 0.8400D-01, & + 0.8183D-01, 0.7956D-01, 0.8083D-01, 0.8310D-01 & + / + data (OREF(37, 8, mtmp), mtmp=1,12) & + / & + 0.7666D-01, 0.7593D-01, 0.7892D-01, 0.8337D-01, & + 0.8763D-01, 0.8936D-01, 0.8745D-01, 0.8292D-01, & + 0.8246D-01, 0.8174D-01, 0.8301D-01, 0.8455D-01 & + / + data (OREF(37, 9, mtmp), mtmp=1,12) & + / & + 0.7448D-01, 0.7167D-01, 0.7911D-01, 0.8527D-01, & + 0.8936D-01, 0.8909D-01, 0.8546D-01, 0.8337D-01, & + 0.8391D-01, 0.8364D-01, 0.8645D-01, 0.8745D-01 & + / + data (OREF(37,10, mtmp), mtmp=1,12) & + / & + 0.7484D-01, 0.7276D-01, 0.7974D-01, 0.8518D-01, & + 0.8899D-01, 0.8899D-01, 0.8618D-01, 0.8382D-01, & + 0.8428D-01, 0.8437D-01, 0.8791D-01, 0.8845D-01 & + / + data (OREF(37,11, mtmp), mtmp=1,12) & + / & + 0.7457D-01, 0.7620D-01, 0.8219D-01, 0.8582D-01, & + 0.8872D-01, 0.9072D-01, 0.8954D-01, 0.8455D-01, & + 0.8310D-01, 0.8283D-01, 0.8455D-01, 0.8464D-01 & + / + data (OREF(37,12, mtmp), mtmp=1,12) & + / & + 0.7729D-01, 0.7838D-01, 0.8446D-01, 0.8709D-01, & + 0.8818D-01, 0.9135D-01, 0.9317D-01, 0.8537D-01, & + 0.8156D-01, 0.7865D-01, 0.8074D-01, 0.8292D-01 & + / + data (OREF(37,13, mtmp), mtmp=1,12) & + / & + 0.8600D-01, 0.8273D-01, 0.8074D-01, 0.8346D-01, & + 0.8446D-01, 0.8736D-01, 0.9172D-01, 0.8564D-01, & + 0.8056D-01, 0.7720D-01, 0.8192D-01, 0.8328D-01 & + / + data (OREF(37,14, mtmp), mtmp=1,12) & + / & + 0.9036D-01, 0.9172D-01, 0.7765D-01, 0.7530D-01, & + 0.7938D-01, 0.8174D-01, 0.8491D-01, 0.8083D-01, & + 0.7856D-01, 0.7911D-01, 0.8664D-01, 0.8110D-01 & + / + data (OREF(37,15, mtmp), mtmp=1,12) & + / & + 0.8400D-01, 0.9398D-01, 0.8174D-01, 0.7303D-01, & + 0.7375D-01, 0.7584D-01, 0.7693D-01, 0.7448D-01, & + 0.7584D-01, 0.8156D-01, 0.8518D-01, 0.7530D-01 & + / + data (OREF(37,16, mtmp), mtmp=1,12) & + / & + 0.7974D-01, 0.8881D-01, 0.8609D-01, 0.7484D-01, & + 0.7103D-01, 0.7140D-01, 0.7176D-01, 0.7012D-01, & + 0.7421D-01, 0.7965D-01, 0.7775D-01, 0.7375D-01 & + / + data (OREF(37,17, mtmp), mtmp=1,12) & + / & + 0.7974D-01, 0.8482D-01, 0.8518D-01, 0.7620D-01, & + 0.6786D-01, 0.6278D-01, 0.6223D-01, 0.6577D-01, & + 0.7130D-01, 0.7738D-01, 0.7775D-01, 0.7375D-01 & + / + data (OREF(37,18, mtmp), mtmp=1,12) & + / & + 0.7974D-01, 0.8482D-01, 0.8518D-01, 0.7620D-01, & + 0.6786D-01, 0.6278D-01, 0.6223D-01, 0.6577D-01, & + 0.7130D-01, 0.7738D-01, 0.7775D-01, 0.7375D-01 & + / + data (OREF(38, 1, mtmp), mtmp=1,12) & + / & + 0.3977D-01, 0.4549D-01, 0.5370D-01, 0.5886D-01, & + 0.6239D-01, 0.5911D-01, 0.5461D-01, 0.5339D-01, & + 0.4926D-01, 0.5078D-01, 0.4494D-01, 0.4172D-01 & + / + data (OREF(38, 2, mtmp), mtmp=1,12) & + / & + 0.3977D-01, 0.4549D-01, 0.5370D-01, 0.5886D-01, & + 0.6239D-01, 0.5911D-01, 0.5461D-01, 0.5339D-01, & + 0.4926D-01, 0.5078D-01, 0.4494D-01, 0.4172D-01 & + / + data (OREF(38, 3, mtmp), mtmp=1,12) & + / & + 0.4536D-01, 0.4834D-01, 0.5455D-01, 0.6026D-01, & + 0.6239D-01, 0.5911D-01, 0.5461D-01, 0.5339D-01, & + 0.5205D-01, 0.5218D-01, 0.4853D-01, 0.4707D-01 & + / + data (OREF(38, 4, mtmp), mtmp=1,12) & + / & + 0.4828D-01, 0.5126D-01, 0.5534D-01, 0.6190D-01, & + 0.6640D-01, 0.6215D-01, 0.5740D-01, 0.5607D-01, & + 0.5595D-01, 0.5363D-01, 0.5047D-01, 0.4932D-01 & + / + data (OREF(38, 5, mtmp), mtmp=1,12) & + / & + 0.5193D-01, 0.5509D-01, 0.5661D-01, 0.6081D-01, & + 0.6701D-01, 0.6567D-01, 0.6549D-01, 0.6014D-01, & + 0.5801D-01, 0.5351D-01, 0.5138D-01, 0.5157D-01 & + / + data (OREF(38, 6, mtmp), mtmp=1,12) & + / & + 0.5461D-01, 0.5734D-01, 0.5680D-01, 0.5777D-01, & + 0.6063D-01, 0.6136D-01, 0.6507D-01, 0.5905D-01, & + 0.5655D-01, 0.5284D-01, 0.5266D-01, 0.5382D-01 & + / + data (OREF(38, 7, mtmp), mtmp=1,12) & + / & + 0.5443D-01, 0.5601D-01, 0.5455D-01, 0.5528D-01, & + 0.5783D-01, 0.6008D-01, 0.6166D-01, 0.5631D-01, & + 0.5485D-01, 0.5333D-01, 0.5418D-01, 0.5570D-01 & + / + data (OREF(38, 8, mtmp), mtmp=1,12) & + / & + 0.5138D-01, 0.5090D-01, 0.5290D-01, 0.5588D-01, & + 0.5874D-01, 0.5990D-01, 0.5862D-01, 0.5558D-01, & + 0.5528D-01, 0.5479D-01, 0.5564D-01, 0.5667D-01 & + / + data (OREF(38, 9, mtmp), mtmp=1,12) & + / & + 0.4993D-01, 0.4804D-01, 0.5303D-01, 0.5716D-01, & + 0.5990D-01, 0.5972D-01, 0.5728D-01, 0.5588D-01, & + 0.5625D-01, 0.5607D-01, 0.5795D-01, 0.5862D-01 & + / + data (OREF(38,10, mtmp), mtmp=1,12) & + / & + 0.5017D-01, 0.4877D-01, 0.5345D-01, 0.5710D-01, & + 0.5965D-01, 0.5965D-01, 0.5777D-01, 0.5619D-01, & + 0.5649D-01, 0.5655D-01, 0.5892D-01, 0.5929D-01 & + / + data (OREF(38,11, mtmp), mtmp=1,12) & + / & + 0.4999D-01, 0.5108D-01, 0.5509D-01, 0.5753D-01, & + 0.5947D-01, 0.6081D-01, 0.6002D-01, 0.5667D-01, & + 0.5570D-01, 0.5552D-01, 0.5667D-01, 0.5674D-01 & + / + data (OREF(38,12, mtmp), mtmp=1,12) & + / & + 0.5181D-01, 0.5254D-01, 0.5661D-01, 0.5838D-01, & + 0.5911D-01, 0.6124D-01, 0.6245D-01, 0.5722D-01, & + 0.5467D-01, 0.5272D-01, 0.5412D-01, 0.5558D-01 & + / + data (OREF(38,13, mtmp), mtmp=1,12) & + / & + 0.5765D-01, 0.5546D-01, 0.5412D-01, 0.5595D-01, & + 0.5661D-01, 0.5856D-01, 0.6148D-01, 0.5740D-01, & + 0.5400D-01, 0.5175D-01, 0.5491D-01, 0.5582D-01 & + / + data (OREF(38,14, mtmp), mtmp=1,12) & + / & + 0.6057D-01, 0.6148D-01, 0.5205D-01, 0.5047D-01, & + 0.5321D-01, 0.5479D-01, 0.5692D-01, 0.5418D-01, & + 0.5266D-01, 0.5303D-01, 0.5807D-01, 0.5436D-01 & + / + data (OREF(38,15, mtmp), mtmp=1,12) & + / & + 0.5631D-01, 0.6300D-01, 0.5479D-01, 0.4895D-01, & + 0.4944D-01, 0.5084D-01, 0.5157D-01, 0.4993D-01, & + 0.5084D-01, 0.5467D-01, 0.5710D-01, 0.5047D-01 & + / + data (OREF(38,16, mtmp), mtmp=1,12) & + / & + 0.5345D-01, 0.5953D-01, 0.5771D-01, 0.5017D-01, & + 0.4761D-01, 0.4786D-01, 0.4810D-01, 0.4701D-01, & + 0.4974D-01, 0.5339D-01, 0.5211D-01, 0.4944D-01 & + / + data (OREF(38,17, mtmp), mtmp=1,12) & + / & + 0.5345D-01, 0.5686D-01, 0.5710D-01, 0.5108D-01, & + 0.4549D-01, 0.4208D-01, 0.4172D-01, 0.4409D-01, & + 0.4780D-01, 0.5187D-01, 0.5211D-01, 0.4944D-01 & + / + data (OREF(38,18, mtmp), mtmp=1,12) & + / & + 0.5345D-01, 0.5686D-01, 0.5710D-01, 0.5108D-01, & + 0.4549D-01, 0.4208D-01, 0.4172D-01, 0.4409D-01, & + 0.4780D-01, 0.5187D-01, 0.5211D-01, 0.4944D-01 & + / + data (OREF(39, 1, mtmp), mtmp=1,12) & + / & + 0.2666D-01, 0.3049D-01, 0.3599D-01, 0.3946D-01, & + 0.4182D-01, 0.3962D-01, 0.3660D-01, 0.3579D-01, & + 0.3302D-01, 0.3404D-01, 0.3012D-01, 0.2796D-01 & + / + data (OREF(39, 2, mtmp), mtmp=1,12) & + / & + 0.2666D-01, 0.3049D-01, 0.3599D-01, 0.3946D-01, & + 0.4182D-01, 0.3962D-01, 0.3660D-01, 0.3579D-01, & + 0.3302D-01, 0.3404D-01, 0.3012D-01, 0.2796D-01 & + / + data (OREF(39, 3, mtmp), mtmp=1,12) & + / & + 0.3041D-01, 0.3241D-01, 0.3656D-01, 0.4040D-01, & + 0.4182D-01, 0.3962D-01, 0.3660D-01, 0.3579D-01, & + 0.3489D-01, 0.3497D-01, 0.3253D-01, 0.3155D-01 & + / + data (OREF(39, 4, mtmp), mtmp=1,12) & + / & + 0.3237D-01, 0.3436D-01, 0.3709D-01, 0.4150D-01, & + 0.4451D-01, 0.4166D-01, 0.3848D-01, 0.3758D-01, & + 0.3750D-01, 0.3595D-01, 0.3383D-01, 0.3306D-01 & + / + data (OREF(39, 5, mtmp), mtmp=1,12) & + / & + 0.3481D-01, 0.3693D-01, 0.3795D-01, 0.4076D-01, & + 0.4492D-01, 0.4402D-01, 0.4390D-01, 0.4031D-01, & + 0.3889D-01, 0.3587D-01, 0.3444D-01, 0.3457D-01 & + / + data (OREF(39, 6, mtmp), mtmp=1,12) & + / & + 0.3660D-01, 0.3844D-01, 0.3807D-01, 0.3872D-01, & + 0.4064D-01, 0.4113D-01, 0.4362D-01, 0.3958D-01, & + 0.3791D-01, 0.3542D-01, 0.3530D-01, 0.3607D-01 & + / + data (OREF(39, 7, mtmp), mtmp=1,12) & + / & + 0.3648D-01, 0.3754D-01, 0.3656D-01, 0.3705D-01, & + 0.3876D-01, 0.4027D-01, 0.4133D-01, 0.3775D-01, & + 0.3677D-01, 0.3575D-01, 0.3632D-01, 0.3734D-01 & + / + data (OREF(39, 8, mtmp), mtmp=1,12) & + / & + 0.3444D-01, 0.3412D-01, 0.3546D-01, 0.3746D-01, & + 0.3938D-01, 0.4015D-01, 0.3929D-01, 0.3726D-01, & + 0.3705D-01, 0.3673D-01, 0.3730D-01, 0.3799D-01 & + / + data (OREF(39, 9, mtmp), mtmp=1,12) & + / & + 0.3347D-01, 0.3220D-01, 0.3554D-01, 0.3832D-01, & + 0.4015D-01, 0.4003D-01, 0.3840D-01, 0.3746D-01, & + 0.3771D-01, 0.3758D-01, 0.3885D-01, 0.3929D-01 & + / + data (OREF(39,10, mtmp), mtmp=1,12) & + / & + 0.3363D-01, 0.3269D-01, 0.3583D-01, 0.3828D-01, & + 0.3999D-01, 0.3999D-01, 0.3872D-01, 0.3766D-01, & + 0.3787D-01, 0.3791D-01, 0.3950D-01, 0.3974D-01 & + / + data (OREF(39,11, mtmp), mtmp=1,12) & + / & + 0.3351D-01, 0.3424D-01, 0.3693D-01, 0.3856D-01, & + 0.3987D-01, 0.4076D-01, 0.4023D-01, 0.3799D-01, & + 0.3734D-01, 0.3722D-01, 0.3799D-01, 0.3803D-01 & + / + data (OREF(39,12, mtmp), mtmp=1,12) & + / & + 0.3473D-01, 0.3522D-01, 0.3795D-01, 0.3913D-01, & + 0.3962D-01, 0.4105D-01, 0.4186D-01, 0.3836D-01, & + 0.3665D-01, 0.3534D-01, 0.3628D-01, 0.3726D-01 & + / + data (OREF(39,13, mtmp), mtmp=1,12) & + / & + 0.3864D-01, 0.3718D-01, 0.3628D-01, 0.3750D-01, & + 0.3795D-01, 0.3925D-01, 0.4121D-01, 0.3848D-01, & + 0.3620D-01, 0.3469D-01, 0.3681D-01, 0.3742D-01 & + / + data (OREF(39,14, mtmp), mtmp=1,12) & + / & + 0.4060D-01, 0.4121D-01, 0.3489D-01, 0.3383D-01, & + 0.3567D-01, 0.3673D-01, 0.3815D-01, 0.3632D-01, & + 0.3530D-01, 0.3554D-01, 0.3893D-01, 0.3644D-01 & + / + data (OREF(39,15, mtmp), mtmp=1,12) & + / & + 0.3775D-01, 0.4223D-01, 0.3673D-01, 0.3281D-01, & + 0.3314D-01, 0.3408D-01, 0.3457D-01, 0.3347D-01, & + 0.3408D-01, 0.3665D-01, 0.3828D-01, 0.3383D-01 & + / + data (OREF(39,16, mtmp), mtmp=1,12) & + / & + 0.3583D-01, 0.3991D-01, 0.3868D-01, 0.3363D-01, & + 0.3192D-01, 0.3208D-01, 0.3224D-01, 0.3151D-01, & + 0.3334D-01, 0.3579D-01, 0.3493D-01, 0.3314D-01 & + / + data (OREF(39,17, mtmp), mtmp=1,12) & + / & + 0.3583D-01, 0.3811D-01, 0.3828D-01, 0.3424D-01, & + 0.3049D-01, 0.2821D-01, 0.2796D-01, 0.2955D-01, & + 0.3204D-01, 0.3477D-01, 0.3493D-01, 0.3314D-01 & + / + data (OREF(39,18, mtmp), mtmp=1,12) & + / & + 0.3583D-01, 0.3811D-01, 0.3828D-01, 0.3424D-01, & + 0.3049D-01, 0.2821D-01, 0.2796D-01, 0.2955D-01, & + 0.3204D-01, 0.3477D-01, 0.3493D-01, 0.3314D-01 & + / + data (OREF(40, 1, mtmp), mtmp=1,12) & + / & + 0.1787D-01, 0.2044D-01, 0.2413D-01, 0.2645D-01, & + 0.2803D-01, 0.2656D-01, 0.2454D-01, 0.2399D-01, & + 0.2213D-01, 0.2282D-01, 0.2019D-01, 0.1874D-01 & + / + data (OREF(40, 2, mtmp), mtmp=1,12) & + / & + 0.1787D-01, 0.2044D-01, 0.2413D-01, 0.2645D-01, & + 0.2803D-01, 0.2656D-01, 0.2454D-01, 0.2399D-01, & + 0.2213D-01, 0.2282D-01, 0.2019D-01, 0.1874D-01 & + / + data (OREF(40, 3, mtmp), mtmp=1,12) & + / & + 0.2038D-01, 0.2172D-01, 0.2451D-01, 0.2708D-01, & + 0.2803D-01, 0.2656D-01, 0.2454D-01, 0.2399D-01, & + 0.2339D-01, 0.2344D-01, 0.2180D-01, 0.2115D-01 & + / + data (OREF(40, 4, mtmp), mtmp=1,12) & + / & + 0.2170D-01, 0.2303D-01, 0.2486D-01, 0.2782D-01, & + 0.2984D-01, 0.2792D-01, 0.2579D-01, 0.2519D-01, & + 0.2514D-01, 0.2410D-01, 0.2268D-01, 0.2216D-01 & + / + data (OREF(40, 5, mtmp), mtmp=1,12) & + / & + 0.2333D-01, 0.2476D-01, 0.2544D-01, 0.2732D-01, & + 0.3011D-01, 0.2951D-01, 0.2943D-01, 0.2702D-01, & + 0.2607D-01, 0.2404D-01, 0.2309D-01, 0.2317D-01 & + / + data (OREF(40, 6, mtmp), mtmp=1,12) & + / & + 0.2454D-01, 0.2577D-01, 0.2552D-01, 0.2596D-01, & + 0.2724D-01, 0.2757D-01, 0.2924D-01, 0.2653D-01, & + 0.2541D-01, 0.2374D-01, 0.2366D-01, 0.2418D-01 & + / + data (OREF(40, 7, mtmp), mtmp=1,12) & + / & + 0.2445D-01, 0.2517D-01, 0.2451D-01, 0.2484D-01, & + 0.2598D-01, 0.2700D-01, 0.2771D-01, 0.2530D-01, & + 0.2465D-01, 0.2396D-01, 0.2435D-01, 0.2503D-01 & + / + data (OREF(40, 8, mtmp), mtmp=1,12) & + / & + 0.2309D-01, 0.2287D-01, 0.2377D-01, 0.2511D-01, & + 0.2639D-01, 0.2691D-01, 0.2634D-01, 0.2497D-01, & + 0.2484D-01, 0.2462D-01, 0.2500D-01, 0.2547D-01 & + / + data (OREF(40, 9, mtmp), mtmp=1,12) & + / & + 0.2243D-01, 0.2159D-01, 0.2383D-01, 0.2568D-01, & + 0.2691D-01, 0.2683D-01, 0.2574D-01, 0.2511D-01, & + 0.2527D-01, 0.2519D-01, 0.2604D-01, 0.2634D-01 & + / + data (OREF(40,10, mtmp), mtmp=1,12) & + / & + 0.2254D-01, 0.2191D-01, 0.2402D-01, 0.2566D-01, & + 0.2680D-01, 0.2680D-01, 0.2596D-01, 0.2525D-01, & + 0.2538D-01, 0.2541D-01, 0.2648D-01, 0.2664D-01 & + / + data (OREF(40,11, mtmp), mtmp=1,12) & + / & + 0.2246D-01, 0.2295D-01, 0.2476D-01, 0.2585D-01, & + 0.2672D-01, 0.2732D-01, 0.2697D-01, 0.2547D-01, & + 0.2503D-01, 0.2495D-01, 0.2547D-01, 0.2549D-01 & + / + data (OREF(40,12, mtmp), mtmp=1,12) & + / & + 0.2328D-01, 0.2361D-01, 0.2544D-01, 0.2623D-01, & + 0.2656D-01, 0.2751D-01, 0.2806D-01, 0.2571D-01, & + 0.2456D-01, 0.2369D-01, 0.2432D-01, 0.2497D-01 & + / + data (OREF(40,13, mtmp), mtmp=1,12) & + / & + 0.2590D-01, 0.2492D-01, 0.2432D-01, 0.2514D-01, & + 0.2544D-01, 0.2631D-01, 0.2762D-01, 0.2579D-01, & + 0.2426D-01, 0.2325D-01, 0.2467D-01, 0.2508D-01 & + / + data (OREF(40,14, mtmp), mtmp=1,12) & + / & + 0.2721D-01, 0.2762D-01, 0.2339D-01, 0.2268D-01, & + 0.2391D-01, 0.2462D-01, 0.2558D-01, 0.2435D-01, & + 0.2366D-01, 0.2383D-01, 0.2609D-01, 0.2443D-01 & + / + data (OREF(40,15, mtmp), mtmp=1,12) & + / & + 0.2530D-01, 0.2831D-01, 0.2462D-01, 0.2200D-01, & + 0.2221D-01, 0.2284D-01, 0.2317D-01, 0.2243D-01, & + 0.2284D-01, 0.2456D-01, 0.2566D-01, 0.2268D-01 & + / + data (OREF(40,16, mtmp), mtmp=1,12) & + / & + 0.2402D-01, 0.2675D-01, 0.2593D-01, 0.2254D-01, & + 0.2139D-01, 0.2150D-01, 0.2161D-01, 0.2112D-01, & + 0.2235D-01, 0.2399D-01, 0.2342D-01, 0.2221D-01 & + / + data (OREF(40,17, mtmp), mtmp=1,12) & + / & + 0.2402D-01, 0.2555D-01, 0.2566D-01, 0.2295D-01, & + 0.2044D-01, 0.1891D-01, 0.1874D-01, 0.1981D-01, & + 0.2148D-01, 0.2331D-01, 0.2342D-01, 0.2221D-01 & + / + data (OREF(40,18, mtmp), mtmp=1,12) & + / & + 0.2402D-01, 0.2555D-01, 0.2566D-01, 0.2295D-01, & + 0.2044D-01, 0.1891D-01, 0.1874D-01, 0.1981D-01, & + 0.2148D-01, 0.2331D-01, 0.2342D-01, 0.2221D-01 & + / + data (OREF(41, 1, mtmp), mtmp=1,12) & + / & + 0.1198D-01, 0.1370D-01, 0.1617D-01, 0.1773D-01, & + 0.1879D-01, 0.1780D-01, 0.1645D-01, 0.1608D-01, & + 0.1484D-01, 0.1529D-01, 0.1354D-01, 0.1256D-01 & + / + data (OREF(41, 2, mtmp), mtmp=1,12) & + / & + 0.1198D-01, 0.1370D-01, 0.1617D-01, 0.1773D-01, & + 0.1879D-01, 0.1780D-01, 0.1645D-01, 0.1608D-01, & + 0.1484D-01, 0.1529D-01, 0.1354D-01, 0.1256D-01 & + / + data (OREF(41, 3, mtmp), mtmp=1,12) & + / & + 0.1366D-01, 0.1456D-01, 0.1643D-01, 0.1815D-01, & + 0.1879D-01, 0.1780D-01, 0.1645D-01, 0.1608D-01, & + 0.1568D-01, 0.1571D-01, 0.1462D-01, 0.1418D-01 & + / + data (OREF(41, 4, mtmp), mtmp=1,12) & + / & + 0.1454D-01, 0.1544D-01, 0.1667D-01, 0.1865D-01, & + 0.2000D-01, 0.1872D-01, 0.1729D-01, 0.1689D-01, & + 0.1685D-01, 0.1615D-01, 0.1520D-01, 0.1485D-01 & + / + data (OREF(41, 5, mtmp), mtmp=1,12) & + / & + 0.1564D-01, 0.1659D-01, 0.1705D-01, 0.1832D-01, & + 0.2018D-01, 0.1978D-01, 0.1973D-01, 0.1811D-01, & + 0.1747D-01, 0.1612D-01, 0.1548D-01, 0.1553D-01 & + / + data (OREF(41, 6, mtmp), mtmp=1,12) & + / & + 0.1645D-01, 0.1727D-01, 0.1711D-01, 0.1740D-01, & + 0.1826D-01, 0.1848D-01, 0.1960D-01, 0.1778D-01, & + 0.1703D-01, 0.1592D-01, 0.1586D-01, 0.1621D-01 & + / + data (OREF(41, 7, mtmp), mtmp=1,12) & + / & + 0.1639D-01, 0.1687D-01, 0.1643D-01, 0.1665D-01, & + 0.1742D-01, 0.1810D-01, 0.1857D-01, 0.1696D-01, & + 0.1652D-01, 0.1606D-01, 0.1632D-01, 0.1678D-01 & + / + data (OREF(41, 8, mtmp), mtmp=1,12) & + / & + 0.1548D-01, 0.1533D-01, 0.1593D-01, 0.1683D-01, & + 0.1769D-01, 0.1804D-01, 0.1766D-01, 0.1674D-01, & + 0.1665D-01, 0.1650D-01, 0.1676D-01, 0.1707D-01 & + / + data (OREF(41, 9, mtmp), mtmp=1,12) & + / & + 0.1504D-01, 0.1447D-01, 0.1597D-01, 0.1722D-01, & + 0.1804D-01, 0.1799D-01, 0.1725D-01, 0.1683D-01, & + 0.1694D-01, 0.1689D-01, 0.1745D-01, 0.1766D-01 & + / + data (OREF(41,10, mtmp), mtmp=1,12) & + / & + 0.1511D-01, 0.1469D-01, 0.1610D-01, 0.1720D-01, & + 0.1797D-01, 0.1797D-01, 0.1740D-01, 0.1692D-01, & + 0.1702D-01, 0.1703D-01, 0.1775D-01, 0.1786D-01 & + / + data (OREF(41,11, mtmp), mtmp=1,12) & + / & + 0.1506D-01, 0.1539D-01, 0.1659D-01, 0.1733D-01, & + 0.1791D-01, 0.1832D-01, 0.1808D-01, 0.1707D-01, & + 0.1678D-01, 0.1672D-01, 0.1707D-01, 0.1709D-01 & + / + data (OREF(41,12, mtmp), mtmp=1,12) & + / & + 0.1560D-01, 0.1582D-01, 0.1705D-01, 0.1758D-01, & + 0.1780D-01, 0.1844D-01, 0.1881D-01, 0.1724D-01, & + 0.1647D-01, 0.1588D-01, 0.1630D-01, 0.1674D-01 & + / + data (OREF(41,13, mtmp), mtmp=1,12) & + / & + 0.1736D-01, 0.1670D-01, 0.1630D-01, 0.1685D-01, & + 0.1705D-01, 0.1764D-01, 0.1852D-01, 0.1729D-01, & + 0.1626D-01, 0.1559D-01, 0.1654D-01, 0.1681D-01 & + / + data (OREF(41,14, mtmp), mtmp=1,12) & + / & + 0.1824D-01, 0.1852D-01, 0.1568D-01, 0.1520D-01, & + 0.1603D-01, 0.1650D-01, 0.1714D-01, 0.1632D-01, & + 0.1586D-01, 0.1597D-01, 0.1749D-01, 0.1637D-01 & + / + data (OREF(41,15, mtmp), mtmp=1,12) & + / & + 0.1696D-01, 0.1898D-01, 0.1650D-01, 0.1474D-01, & + 0.1489D-01, 0.1531D-01, 0.1553D-01, 0.1504D-01, & + 0.1531D-01, 0.1647D-01, 0.1720D-01, 0.1520D-01 & + / + data (OREF(41,16, mtmp), mtmp=1,12) & + / & + 0.1610D-01, 0.1793D-01, 0.1738D-01, 0.1511D-01, & + 0.1434D-01, 0.1441D-01, 0.1449D-01, 0.1416D-01, & + 0.1498D-01, 0.1608D-01, 0.1570D-01, 0.1489D-01 & + / + data (OREF(41,17, mtmp), mtmp=1,12) & + / & + 0.1610D-01, 0.1713D-01, 0.1720D-01, 0.1539D-01, & + 0.1370D-01, 0.1267D-01, 0.1256D-01, 0.1328D-01, & + 0.1440D-01, 0.1562D-01, 0.1570D-01, 0.1489D-01 & + / + data (OREF(41,18, mtmp), mtmp=1,12) & + / & + 0.1610D-01, 0.1713D-01, 0.1720D-01, 0.1539D-01, & + 0.1370D-01, 0.1267D-01, 0.1256D-01, 0.1328D-01, & + 0.1440D-01, 0.1562D-01, 0.1570D-01, 0.1489D-01 & + / + data (OREF(42, 1, mtmp), mtmp=1,12) & + / & + 0.8029D-02, 0.9183D-02, 0.1084D-01, 0.1188D-01, & + 0.1260D-01, 0.1193D-01, 0.1103D-01, 0.1078D-01, & + 0.9945D-02, 0.1025D-01, 0.9073D-02, 0.8422D-02 & + / + data (OREF(42, 2, mtmp), mtmp=1,12) & + / & + 0.8029D-02, 0.9183D-02, 0.1084D-01, 0.1188D-01, & + 0.1260D-01, 0.1193D-01, 0.1103D-01, 0.1078D-01, & + 0.9945D-02, 0.1025D-01, 0.9073D-02, 0.8422D-02 & + / + data (OREF(42, 3, mtmp), mtmp=1,12) & + / & + 0.9159D-02, 0.9760D-02, 0.1101D-01, 0.1217D-01, & + 0.1260D-01, 0.1193D-01, 0.1103D-01, 0.1078D-01, & + 0.1051D-01, 0.1053D-01, 0.9797D-02, 0.9503D-02 & + / + data (OREF(42, 4, mtmp), mtmp=1,12) & + / & + 0.9748D-02, 0.1035D-01, 0.1117D-01, 0.1250D-01, & + 0.1341D-01, 0.1255D-01, 0.1159D-01, 0.1132D-01, & + 0.1130D-01, 0.1083D-01, 0.1019D-01, 0.9957D-02 & + / + data (OREF(42, 5, mtmp), mtmp=1,12) & + / & + 0.1048D-01, 0.1112D-01, 0.1143D-01, 0.1228D-01, & + 0.1353D-01, 0.1326D-01, 0.1322D-01, 0.1214D-01, & + 0.1171D-01, 0.1080D-01, 0.1037D-01, 0.1041D-01 & + / + data (OREF(42, 6, mtmp), mtmp=1,12) & + / & + 0.1103D-01, 0.1158D-01, 0.1147D-01, 0.1166D-01, & + 0.1224D-01, 0.1239D-01, 0.1314D-01, 0.1192D-01, & + 0.1142D-01, 0.1067D-01, 0.1063D-01, 0.1087D-01 & + / + data (OREF(42, 7, mtmp), mtmp=1,12) & + / & + 0.1099D-01, 0.1131D-01, 0.1101D-01, 0.1116D-01, & + 0.1168D-01, 0.1213D-01, 0.1245D-01, 0.1137D-01, & + 0.1107D-01, 0.1077D-01, 0.1094D-01, 0.1125D-01 & + / + data (OREF(42, 8, mtmp), mtmp=1,12) & + / & + 0.1037D-01, 0.1028D-01, 0.1068D-01, 0.1128D-01, & + 0.1186D-01, 0.1209D-01, 0.1184D-01, 0.1122D-01, & + 0.1116D-01, 0.1106D-01, 0.1123D-01, 0.1144D-01 & + / + data (OREF(42, 9, mtmp), mtmp=1,12) & + / & + 0.1008D-01, 0.9699D-02, 0.1071D-01, 0.1154D-01, & + 0.1209D-01, 0.1206D-01, 0.1157D-01, 0.1128D-01, & + 0.1136D-01, 0.1132D-01, 0.1170D-01, 0.1184D-01 & + / + data (OREF(42,10, mtmp), mtmp=1,12) & + / & + 0.1013D-01, 0.9846D-02, 0.1079D-01, 0.1153D-01, & + 0.1204D-01, 0.1204D-01, 0.1166D-01, 0.1134D-01, & + 0.1141D-01, 0.1142D-01, 0.1190D-01, 0.1197D-01 & + / + data (OREF(42,11, mtmp), mtmp=1,12) & + / & + 0.1009D-01, 0.1031D-01, 0.1112D-01, 0.1161D-01, & + 0.1201D-01, 0.1228D-01, 0.1212D-01, 0.1144D-01, & + 0.1125D-01, 0.1121D-01, 0.1144D-01, 0.1145D-01 & + / + data (OREF(42,12, mtmp), mtmp=1,12) & + / & + 0.1046D-01, 0.1061D-01, 0.1143D-01, 0.1179D-01, & + 0.1193D-01, 0.1236D-01, 0.1261D-01, 0.1155D-01, & + 0.1104D-01, 0.1064D-01, 0.1093D-01, 0.1122D-01 & + / + data (OREF(42,13, mtmp), mtmp=1,12) & + / & + 0.1164D-01, 0.1120D-01, 0.1093D-01, 0.1130D-01, & + 0.1143D-01, 0.1182D-01, 0.1241D-01, 0.1159D-01, & + 0.1090D-01, 0.1045D-01, 0.1109D-01, 0.1127D-01 & + / + data (OREF(42,14, mtmp), mtmp=1,12) & + / & + 0.1223D-01, 0.1241D-01, 0.1051D-01, 0.1019D-01, & + 0.1074D-01, 0.1106D-01, 0.1149D-01, 0.1094D-01, & + 0.1063D-01, 0.1071D-01, 0.1172D-01, 0.1098D-01 & + / + data (OREF(42,15, mtmp), mtmp=1,12) & + / & + 0.1137D-01, 0.1272D-01, 0.1106D-01, 0.9883D-02, & + 0.9981D-02, 0.1026D-01, 0.1041D-01, 0.1008D-01, & + 0.1026D-01, 0.1104D-01, 0.1153D-01, 0.1019D-01 & + / + data (OREF(42,16, mtmp), mtmp=1,12) & + / & + 0.1079D-01, 0.1202D-01, 0.1165D-01, 0.1013D-01, & + 0.9613D-02, 0.9662D-02, 0.9711D-02, 0.9490D-02, & + 0.1004D-01, 0.1078D-01, 0.1052D-01, 0.9981D-02 & + / + data (OREF(42,17, mtmp), mtmp=1,12) & + / & + 0.1079D-01, 0.1148D-01, 0.1153D-01, 0.1031D-01, & + 0.9183D-02, 0.8496D-02, 0.8422D-02, 0.8901D-02, & + 0.9650D-02, 0.1047D-01, 0.1052D-01, 0.9981D-02 & + / + data (OREF(42,18, mtmp), mtmp=1,12) & + / & + 0.1079D-01, 0.1148D-01, 0.1153D-01, 0.1031D-01, & + 0.9183D-02, 0.8496D-02, 0.8422D-02, 0.8901D-02, & + 0.9650D-02, 0.1047D-01, 0.1052D-01, 0.9981D-02 & + / + data (OREF(43, 1, mtmp), mtmp=1,12) & + / & + 0.5382D-02, 0.6156D-02, 0.7267D-02, 0.7966D-02, & + 0.8444D-02, 0.7999D-02, 0.7390D-02, 0.7226D-02, & + 0.6666D-02, 0.6872D-02, 0.6082D-02, 0.5646D-02 & + / + data (OREF(43, 2, mtmp), mtmp=1,12) & + / & + 0.5382D-02, 0.6156D-02, 0.7267D-02, 0.7966D-02, & + 0.8444D-02, 0.7999D-02, 0.7390D-02, 0.7226D-02, & + 0.6666D-02, 0.6872D-02, 0.6082D-02, 0.5646D-02 & + / + data (OREF(43, 3, mtmp), mtmp=1,12) & + / & + 0.6139D-02, 0.6543D-02, 0.7382D-02, 0.8156D-02, & + 0.8444D-02, 0.7999D-02, 0.7390D-02, 0.7226D-02, & + 0.7045D-02, 0.7061D-02, 0.6567D-02, 0.6370D-02 & + / + data (OREF(43, 4, mtmp), mtmp=1,12) & + / & + 0.6534D-02, 0.6938D-02, 0.7489D-02, 0.8378D-02, & + 0.8987D-02, 0.8411D-02, 0.7769D-02, 0.7588D-02, & + 0.7571D-02, 0.7259D-02, 0.6831D-02, 0.6674D-02 & + / + data (OREF(43, 5, mtmp), mtmp=1,12) & + / & + 0.7028D-02, 0.7456D-02, 0.7662D-02, 0.8230D-02, & + 0.9069D-02, 0.8888D-02, 0.8863D-02, 0.8139D-02, & + 0.7851D-02, 0.7242D-02, 0.6954D-02, 0.6979D-02 & + / + data (OREF(43, 6, mtmp), mtmp=1,12) & + / & + 0.7390D-02, 0.7761D-02, 0.7687D-02, 0.7818D-02, & + 0.8205D-02, 0.8304D-02, 0.8806D-02, 0.7991D-02, & + 0.7654D-02, 0.7152D-02, 0.7127D-02, 0.7283D-02 & + / + data (OREF(43, 7, mtmp), mtmp=1,12) & + / & + 0.7366D-02, 0.7580D-02, 0.7382D-02, 0.7481D-02, & + 0.7826D-02, 0.8131D-02, 0.8345D-02, 0.7621D-02, & + 0.7423D-02, 0.7217D-02, 0.7333D-02, 0.7538D-02 & + / + data (OREF(43, 8, mtmp), mtmp=1,12) & + / & + 0.6954D-02, 0.6888D-02, 0.7160D-02, 0.7563D-02, & + 0.7950D-02, 0.8106D-02, 0.7933D-02, 0.7522D-02, & + 0.7481D-02, 0.7415D-02, 0.7530D-02, 0.7670D-02 & + / + data (OREF(43, 9, mtmp), mtmp=1,12) & + / & + 0.6757D-02, 0.6502D-02, 0.7176D-02, 0.7736D-02, & + 0.8106D-02, 0.8082D-02, 0.7752D-02, 0.7563D-02, & + 0.7613D-02, 0.7588D-02, 0.7843D-02, 0.7933D-02 & + / + data (OREF(43,10, mtmp), mtmp=1,12) & + / & + 0.6790D-02, 0.6600D-02, 0.7234D-02, 0.7728D-02, & + 0.8073D-02, 0.8073D-02, 0.7818D-02, 0.7604D-02, & + 0.7645D-02, 0.7654D-02, 0.7975D-02, 0.8024D-02 & + / + data (OREF(43,11, mtmp), mtmp=1,12) & + / & + 0.6765D-02, 0.6913D-02, 0.7456D-02, 0.7785D-02, & + 0.8049D-02, 0.8230D-02, 0.8123D-02, 0.7670D-02, & + 0.7538D-02, 0.7514D-02, 0.7670D-02, 0.7678D-02 & + / + data (OREF(43,12, mtmp), mtmp=1,12) & + / & + 0.7012D-02, 0.7111D-02, 0.7662D-02, 0.7901D-02, & + 0.7999D-02, 0.8287D-02, 0.8452D-02, 0.7744D-02, & + 0.7399D-02, 0.7135D-02, 0.7324D-02, 0.7522D-02 & + / + data (OREF(43,13, mtmp), mtmp=1,12) & + / & + 0.7802D-02, 0.7506D-02, 0.7324D-02, 0.7571D-02, & + 0.7662D-02, 0.7925D-02, 0.8320D-02, 0.7769D-02, & + 0.7308D-02, 0.7004D-02, 0.7431D-02, 0.7555D-02 & + / + data (OREF(43,14, mtmp), mtmp=1,12) & + / & + 0.8197D-02, 0.8320D-02, 0.7045D-02, 0.6831D-02, & + 0.7201D-02, 0.7415D-02, 0.7703D-02, 0.7333D-02, & + 0.7127D-02, 0.7176D-02, 0.7859D-02, 0.7357D-02 & + / + data (OREF(43,15, mtmp), mtmp=1,12) & + / & + 0.7621D-02, 0.8526D-02, 0.7415D-02, 0.6625D-02, & + 0.6691D-02, 0.6880D-02, 0.6979D-02, 0.6757D-02, & + 0.6880D-02, 0.7399D-02, 0.7728D-02, 0.6831D-02 & + / + data (OREF(43,16, mtmp), mtmp=1,12) & + / & + 0.7234D-02, 0.8057D-02, 0.7810D-02, 0.6790D-02, & + 0.6444D-02, 0.6477D-02, 0.6510D-02, 0.6362D-02, & + 0.6732D-02, 0.7226D-02, 0.7053D-02, 0.6691D-02 & + / + data (OREF(43,17, mtmp), mtmp=1,12) & + / & + 0.7234D-02, 0.7695D-02, 0.7728D-02, 0.6913D-02, & + 0.6156D-02, 0.5695D-02, 0.5646D-02, 0.5967D-02, & + 0.6469D-02, 0.7020D-02, 0.7053D-02, 0.6691D-02 & + / + data (OREF(43,18, mtmp), mtmp=1,12) & + / & + 0.7234D-02, 0.7695D-02, 0.7728D-02, 0.6913D-02, & + 0.6156D-02, 0.5695D-02, 0.5646D-02, 0.5967D-02, & + 0.6469D-02, 0.7020D-02, 0.7053D-02, 0.6691D-02 & + / + data (OREF(44, 1, mtmp), mtmp=1,12) & + / & + 0.3608D-02, 0.4126D-02, 0.4871D-02, 0.5340D-02, & + 0.5660D-02, 0.5362D-02, 0.4954D-02, 0.4844D-02, & + 0.4468D-02, 0.4606D-02, 0.4077D-02, 0.3784D-02 & + / + data (OREF(44, 2, mtmp), mtmp=1,12) & + / & + 0.3608D-02, 0.4126D-02, 0.4871D-02, 0.5340D-02, & + 0.5660D-02, 0.5362D-02, 0.4954D-02, 0.4844D-02, & + 0.4468D-02, 0.4606D-02, 0.4077D-02, 0.3784D-02 & + / + data (OREF(44, 3, mtmp), mtmp=1,12) & + / & + 0.4115D-02, 0.4386D-02, 0.4948D-02, 0.5467D-02, & + 0.5660D-02, 0.5362D-02, 0.4954D-02, 0.4844D-02, & + 0.4722D-02, 0.4733D-02, 0.4402D-02, 0.4270D-02 & + / + data (OREF(44, 4, mtmp), mtmp=1,12) & + / & + 0.4380D-02, 0.4650D-02, 0.5020D-02, 0.5616D-02, & + 0.6024D-02, 0.5638D-02, 0.5208D-02, 0.5086D-02, & + 0.5075D-02, 0.4866D-02, 0.4579D-02, 0.4474D-02 & + / + data (OREF(44, 5, mtmp), mtmp=1,12) & + / & + 0.4711D-02, 0.4998D-02, 0.5136D-02, 0.5517D-02, & + 0.6079D-02, 0.5958D-02, 0.5941D-02, 0.5456D-02, & + 0.5263D-02, 0.4855D-02, 0.4661D-02, 0.4678D-02 & + / + data (OREF(44, 6, mtmp), mtmp=1,12) & + / & + 0.4954D-02, 0.5202D-02, 0.5152D-02, 0.5241D-02, & + 0.5500D-02, 0.5566D-02, 0.5903D-02, 0.5357D-02, & + 0.5130D-02, 0.4794D-02, 0.4777D-02, 0.4882D-02 & + / + data (OREF(44, 7, mtmp), mtmp=1,12) & + / & + 0.4937D-02, 0.5081D-02, 0.4948D-02, 0.5015D-02, & + 0.5246D-02, 0.5450D-02, 0.5594D-02, 0.5108D-02, & + 0.4976D-02, 0.4838D-02, 0.4915D-02, 0.5053D-02 & + / + data (OREF(44, 8, mtmp), mtmp=1,12) & + / & + 0.4661D-02, 0.4617D-02, 0.4799D-02, 0.5070D-02, & + 0.5329D-02, 0.5434D-02, 0.5318D-02, 0.5042D-02, & + 0.5015D-02, 0.4970D-02, 0.5048D-02, 0.5141D-02 & + / + data (OREF(44, 9, mtmp), mtmp=1,12) & + / & + 0.4529D-02, 0.4358D-02, 0.4810D-02, 0.5186D-02, & + 0.5434D-02, 0.5417D-02, 0.5197D-02, 0.5070D-02, & + 0.5103D-02, 0.5086D-02, 0.5257D-02, 0.5318D-02 & + / + data (OREF(44,10, mtmp), mtmp=1,12) & + / & + 0.4551D-02, 0.4424D-02, 0.4849D-02, 0.5180D-02, & + 0.5412D-02, 0.5412D-02, 0.5241D-02, 0.5097D-02, & + 0.5125D-02, 0.5130D-02, 0.5346D-02, 0.5379D-02 & + / + data (OREF(44,11, mtmp), mtmp=1,12) & + / & + 0.4535D-02, 0.4634D-02, 0.4998D-02, 0.5219D-02, & + 0.5395D-02, 0.5517D-02, 0.5445D-02, 0.5141D-02, & + 0.5053D-02, 0.5037D-02, 0.5141D-02, 0.5147D-02 & + / + data (OREF(44,12, mtmp), mtmp=1,12) & + / & + 0.4700D-02, 0.4766D-02, 0.5136D-02, 0.5296D-02, & + 0.5362D-02, 0.5555D-02, 0.5666D-02, 0.5191D-02, & + 0.4959D-02, 0.4783D-02, 0.4910D-02, 0.5042D-02 & + / + data (OREF(44,13, mtmp), mtmp=1,12) & + / & + 0.5230D-02, 0.5031D-02, 0.4910D-02, 0.5075D-02, & + 0.5136D-02, 0.5312D-02, 0.5577D-02, 0.5208D-02, & + 0.4899D-02, 0.4695D-02, 0.4981D-02, 0.5064D-02 & + / + data (OREF(44,14, mtmp), mtmp=1,12) & + / & + 0.5494D-02, 0.5577D-02, 0.4722D-02, 0.4579D-02, & + 0.4827D-02, 0.4970D-02, 0.5164D-02, 0.4915D-02, & + 0.4777D-02, 0.4810D-02, 0.5268D-02, 0.4932D-02 & + / + data (OREF(44,15, mtmp), mtmp=1,12) & + / & + 0.5108D-02, 0.5715D-02, 0.4970D-02, 0.4441D-02, & + 0.4485D-02, 0.4612D-02, 0.4678D-02, 0.4529D-02, & + 0.4612D-02, 0.4959D-02, 0.5180D-02, 0.4579D-02 & + / + data (OREF(44,16, mtmp), mtmp=1,12) & + / & + 0.4849D-02, 0.5401D-02, 0.5235D-02, 0.4551D-02, & + 0.4319D-02, 0.4342D-02, 0.4364D-02, 0.4264D-02, & + 0.4513D-02, 0.4844D-02, 0.4728D-02, 0.4485D-02 & + / + data (OREF(44,17, mtmp), mtmp=1,12) & + / & + 0.4849D-02, 0.5158D-02, 0.5180D-02, 0.4634D-02, & + 0.4126D-02, 0.3817D-02, 0.3784D-02, 0.4000D-02, & + 0.4336D-02, 0.4706D-02, 0.4728D-02, 0.4485D-02 & + / + data (OREF(44,18, mtmp), mtmp=1,12) & + / & + 0.4849D-02, 0.5158D-02, 0.5180D-02, 0.4634D-02, & + 0.4126D-02, 0.3817D-02, 0.3784D-02, 0.4000D-02, & + 0.4336D-02, 0.4706D-02, 0.4728D-02, 0.4485D-02 & + / + data (OREF(45, 1, mtmp), mtmp=1,12) & + / & + 0.2418D-02, 0.2766D-02, 0.3265D-02, 0.3580D-02, & + 0.3794D-02, 0.3594D-02, 0.3321D-02, 0.3247D-02, & + 0.2995D-02, 0.3088D-02, 0.2733D-02, 0.2537D-02 & + / + data (OREF(45, 2, mtmp), mtmp=1,12) & + / & + 0.2418D-02, 0.2766D-02, 0.3265D-02, 0.3580D-02, & + 0.3794D-02, 0.3594D-02, 0.3321D-02, 0.3247D-02, & + 0.2995D-02, 0.3088D-02, 0.2733D-02, 0.2537D-02 & + / + data (OREF(45, 3, mtmp), mtmp=1,12) & + / & + 0.2759D-02, 0.2940D-02, 0.3317D-02, 0.3665D-02, & + 0.3794D-02, 0.3594D-02, 0.3321D-02, 0.3247D-02, & + 0.3165D-02, 0.3173D-02, 0.2951D-02, 0.2862D-02 & + / + data (OREF(45, 4, mtmp), mtmp=1,12) & + / & + 0.2936D-02, 0.3117D-02, 0.3365D-02, 0.3764D-02, & + 0.4038D-02, 0.3779D-02, 0.3491D-02, 0.3409D-02, & + 0.3402D-02, 0.3262D-02, 0.3069D-02, 0.2999D-02 & + / + data (OREF(45, 5, mtmp), mtmp=1,12) & + / & + 0.3158D-02, 0.3350D-02, 0.3443D-02, 0.3698D-02, & + 0.4075D-02, 0.3994D-02, 0.3983D-02, 0.3657D-02, & + 0.3528D-02, 0.3254D-02, 0.3125D-02, 0.3136D-02 & + / + data (OREF(45, 6, mtmp), mtmp=1,12) & + / & + 0.3321D-02, 0.3487D-02, 0.3454D-02, 0.3513D-02, & + 0.3687D-02, 0.3731D-02, 0.3957D-02, 0.3591D-02, & + 0.3439D-02, 0.3213D-02, 0.3202D-02, 0.3273D-02 & + / + data (OREF(45, 7, mtmp), mtmp=1,12) & + / & + 0.3310D-02, 0.3406D-02, 0.3317D-02, 0.3361D-02, & + 0.3517D-02, 0.3653D-02, 0.3750D-02, 0.3424D-02, & + 0.3335D-02, 0.3243D-02, 0.3295D-02, 0.3387D-02 & + / + data (OREF(45, 8, mtmp), mtmp=1,12) & + / & + 0.3125D-02, 0.3095D-02, 0.3217D-02, 0.3398D-02, & + 0.3572D-02, 0.3642D-02, 0.3565D-02, 0.3380D-02, & + 0.3361D-02, 0.3332D-02, 0.3384D-02, 0.3446D-02 & + / + data (OREF(45, 9, mtmp), mtmp=1,12) & + / & + 0.3036D-02, 0.2921D-02, 0.3225D-02, 0.3476D-02, & + 0.3642D-02, 0.3631D-02, 0.3483D-02, 0.3398D-02, & + 0.3421D-02, 0.3409D-02, 0.3524D-02, 0.3565D-02 & + / + data (OREF(45,10, mtmp), mtmp=1,12) & + / & + 0.3051D-02, 0.2966D-02, 0.3250D-02, 0.3472D-02, & + 0.3628D-02, 0.3628D-02, 0.3513D-02, 0.3417D-02, & + 0.3435D-02, 0.3439D-02, 0.3583D-02, 0.3605D-02 & + / + data (OREF(45,11, mtmp), mtmp=1,12) & + / & + 0.3040D-02, 0.3106D-02, 0.3350D-02, 0.3498D-02, & + 0.3617D-02, 0.3698D-02, 0.3650D-02, 0.3446D-02, & + 0.3387D-02, 0.3376D-02, 0.3446D-02, 0.3450D-02 & + / + data (OREF(45,12, mtmp), mtmp=1,12) & + / & + 0.3151D-02, 0.3195D-02, 0.3443D-02, 0.3550D-02, & + 0.3594D-02, 0.3724D-02, 0.3798D-02, 0.3480D-02, & + 0.3324D-02, 0.3206D-02, 0.3291D-02, 0.3380D-02 & + / + data (OREF(45,13, mtmp), mtmp=1,12) & + / & + 0.3506D-02, 0.3372D-02, 0.3291D-02, 0.3402D-02, & + 0.3443D-02, 0.3561D-02, 0.3739D-02, 0.3491D-02, & + 0.3284D-02, 0.3147D-02, 0.3339D-02, 0.3395D-02 & + / + data (OREF(45,14, mtmp), mtmp=1,12) & + / & + 0.3683D-02, 0.3739D-02, 0.3165D-02, 0.3069D-02, & + 0.3236D-02, 0.3332D-02, 0.3461D-02, 0.3295D-02, & + 0.3202D-02, 0.3225D-02, 0.3531D-02, 0.3306D-02 & + / + data (OREF(45,15, mtmp), mtmp=1,12) & + / & + 0.3424D-02, 0.3831D-02, 0.3332D-02, 0.2977D-02, & + 0.3006D-02, 0.3091D-02, 0.3136D-02, 0.3036D-02, & + 0.3091D-02, 0.3324D-02, 0.3472D-02, 0.3069D-02 & + / + data (OREF(45,16, mtmp), mtmp=1,12) & + / & + 0.3250D-02, 0.3620D-02, 0.3509D-02, 0.3051D-02, & + 0.2895D-02, 0.2910D-02, 0.2925D-02, 0.2858D-02, & + 0.3025D-02, 0.3247D-02, 0.3169D-02, 0.3006D-02 & + / + data (OREF(45,17, mtmp), mtmp=1,12) & + / & + 0.3250D-02, 0.3458D-02, 0.3472D-02, 0.3106D-02, & + 0.2766D-02, 0.2559D-02, 0.2537D-02, 0.2681D-02, & + 0.2907D-02, 0.3154D-02, 0.3169D-02, 0.3006D-02 & + / + data (OREF(45,18, mtmp), mtmp=1,12) & + / & + 0.3250D-02, 0.3458D-02, 0.3472D-02, 0.3106D-02, & + 0.2766D-02, 0.2559D-02, 0.2537D-02, 0.2681D-02, & + 0.2907D-02, 0.3154D-02, 0.3169D-02, 0.3006D-02 & + / + data (OREF(46, 1, mtmp), mtmp=1,12) & + / & + 0.1621D-02, 0.1854D-02, 0.2189D-02, 0.2399D-02, & + 0.2543D-02, 0.2409D-02, 0.2226D-02, 0.2176D-02, & + 0.2008D-02, 0.2070D-02, 0.1832D-02, 0.1700D-02 & + / + data (OREF(46, 2, mtmp), mtmp=1,12) & + / & + 0.1621D-02, 0.1854D-02, 0.2189D-02, 0.2399D-02, & + 0.2543D-02, 0.2409D-02, 0.2226D-02, 0.2176D-02, & + 0.2008D-02, 0.2070D-02, 0.1832D-02, 0.1700D-02 & + / + data (OREF(46, 3, mtmp), mtmp=1,12) & + / & + 0.1849D-02, 0.1971D-02, 0.2223D-02, 0.2456D-02, & + 0.2543D-02, 0.2409D-02, 0.2226D-02, 0.2176D-02, & + 0.2122D-02, 0.2127D-02, 0.1978D-02, 0.1919D-02 & + / + data (OREF(46, 4, mtmp), mtmp=1,12) & + / & + 0.1968D-02, 0.2090D-02, 0.2256D-02, 0.2523D-02, & + 0.2707D-02, 0.2533D-02, 0.2340D-02, 0.2285D-02, & + 0.2280D-02, 0.2186D-02, 0.2057D-02, 0.2010D-02 & + / + data (OREF(46, 5, mtmp), mtmp=1,12) & + / & + 0.2117D-02, 0.2246D-02, 0.2308D-02, 0.2479D-02, & + 0.2732D-02, 0.2677D-02, 0.2670D-02, 0.2451D-02, & + 0.2365D-02, 0.2181D-02, 0.2095D-02, 0.2102D-02 & + / + data (OREF(46, 6, mtmp), mtmp=1,12) & + / & + 0.2226D-02, 0.2337D-02, 0.2315D-02, 0.2355D-02, & + 0.2471D-02, 0.2501D-02, 0.2652D-02, 0.2407D-02, & + 0.2305D-02, 0.2154D-02, 0.2147D-02, 0.2194D-02 & + / + data (OREF(46, 7, mtmp), mtmp=1,12) & + / & + 0.2218D-02, 0.2283D-02, 0.2223D-02, 0.2253D-02, & + 0.2357D-02, 0.2449D-02, 0.2513D-02, 0.2295D-02, & + 0.2236D-02, 0.2174D-02, 0.2209D-02, 0.2271D-02 & + / + data (OREF(46, 8, mtmp), mtmp=1,12) & + / & + 0.2095D-02, 0.2075D-02, 0.2157D-02, 0.2278D-02, & + 0.2394D-02, 0.2442D-02, 0.2390D-02, 0.2266D-02, & + 0.2253D-02, 0.2233D-02, 0.2268D-02, 0.2310D-02 & + / + data (OREF(46, 9, mtmp), mtmp=1,12) & + / & + 0.2035D-02, 0.1958D-02, 0.2161D-02, 0.2330D-02, & + 0.2442D-02, 0.2434D-02, 0.2335D-02, 0.2278D-02, & + 0.2293D-02, 0.2285D-02, 0.2362D-02, 0.2390D-02 & + / + data (OREF(46,10, mtmp), mtmp=1,12) & + / & + 0.2045D-02, 0.1988D-02, 0.2179D-02, 0.2328D-02, & + 0.2432D-02, 0.2432D-02, 0.2355D-02, 0.2290D-02, & + 0.2303D-02, 0.2305D-02, 0.2402D-02, 0.2417D-02 & + / + data (OREF(46,11, mtmp), mtmp=1,12) & + / & + 0.2038D-02, 0.2082D-02, 0.2246D-02, 0.2345D-02, & + 0.2424D-02, 0.2479D-02, 0.2447D-02, 0.2310D-02, & + 0.2271D-02, 0.2263D-02, 0.2310D-02, 0.2313D-02 & + / + data (OREF(46,12, mtmp), mtmp=1,12) & + / & + 0.2112D-02, 0.2142D-02, 0.2308D-02, 0.2380D-02, & + 0.2409D-02, 0.2496D-02, 0.2546D-02, 0.2333D-02, & + 0.2228D-02, 0.2149D-02, 0.2206D-02, 0.2266D-02 & + / + data (OREF(46,13, mtmp), mtmp=1,12) & + / & + 0.2350D-02, 0.2261D-02, 0.2206D-02, 0.2280D-02, & + 0.2308D-02, 0.2387D-02, 0.2506D-02, 0.2340D-02, & + 0.2201D-02, 0.2109D-02, 0.2238D-02, 0.2275D-02 & + / + data (OREF(46,14, mtmp), mtmp=1,12) & + / & + 0.2469D-02, 0.2506D-02, 0.2122D-02, 0.2057D-02, & + 0.2169D-02, 0.2233D-02, 0.2320D-02, 0.2209D-02, & + 0.2147D-02, 0.2161D-02, 0.2367D-02, 0.2216D-02 & + / + data (OREF(46,15, mtmp), mtmp=1,12) & + / & + 0.2295D-02, 0.2568D-02, 0.2233D-02, 0.1995D-02, & + 0.2015D-02, 0.2072D-02, 0.2102D-02, 0.2035D-02, & + 0.2072D-02, 0.2228D-02, 0.2328D-02, 0.2057D-02 & + / + data (OREF(46,16, mtmp), mtmp=1,12) & + / & + 0.2179D-02, 0.2427D-02, 0.2352D-02, 0.2045D-02, & + 0.1941D-02, 0.1951D-02, 0.1961D-02, 0.1916D-02, & + 0.2028D-02, 0.2176D-02, 0.2124D-02, 0.2015D-02 & + / + data (OREF(46,17, mtmp), mtmp=1,12) & + / & + 0.2179D-02, 0.2318D-02, 0.2328D-02, 0.2082D-02, & + 0.1854D-02, 0.1715D-02, 0.1700D-02, 0.1797D-02, & + 0.1948D-02, 0.2114D-02, 0.2124D-02, 0.2015D-02 & + / + data (OREF(46,18, mtmp), mtmp=1,12) & + / & + 0.2179D-02, 0.2318D-02, 0.2328D-02, 0.2082D-02, & + 0.1854D-02, 0.1715D-02, 0.1700D-02, 0.1797D-02, & + 0.1948D-02, 0.2114D-02, 0.2124D-02, 0.2015D-02 & + / + data (OREF(47, 1, mtmp), mtmp=1,12) & + / & + 0.1087D-02, 0.1243D-02, 0.1467D-02, 0.1608D-02, & + 0.1705D-02, 0.1615D-02, 0.1492D-02, 0.1459D-02, & + 0.1346D-02, 0.1387D-02, 0.1228D-02, 0.1140D-02 & + / + data (OREF(47, 2, mtmp), mtmp=1,12) & + / & + 0.1087D-02, 0.1243D-02, 0.1467D-02, 0.1608D-02, & + 0.1705D-02, 0.1615D-02, 0.1492D-02, 0.1459D-02, & + 0.1346D-02, 0.1387D-02, 0.1228D-02, 0.1140D-02 & + / + data (OREF(47, 3, mtmp), mtmp=1,12) & + / & + 0.1240D-02, 0.1321D-02, 0.1490D-02, 0.1647D-02, & + 0.1705D-02, 0.1615D-02, 0.1492D-02, 0.1459D-02, & + 0.1422D-02, 0.1426D-02, 0.1326D-02, 0.1286D-02 & + / + data (OREF(47, 4, mtmp), mtmp=1,12) & + / & + 0.1319D-02, 0.1401D-02, 0.1512D-02, 0.1691D-02, & + 0.1814D-02, 0.1698D-02, 0.1569D-02, 0.1532D-02, & + 0.1529D-02, 0.1465D-02, 0.1379D-02, 0.1348D-02 & + / + data (OREF(47, 5, mtmp), mtmp=1,12) & + / & + 0.1419D-02, 0.1505D-02, 0.1547D-02, 0.1662D-02, & + 0.1831D-02, 0.1794D-02, 0.1789D-02, 0.1643D-02, & + 0.1585D-02, 0.1462D-02, 0.1404D-02, 0.1409D-02 & + / + data (OREF(47, 6, mtmp), mtmp=1,12) & + / & + 0.1492D-02, 0.1567D-02, 0.1552D-02, 0.1578D-02, & + 0.1657D-02, 0.1677D-02, 0.1778D-02, 0.1613D-02, & + 0.1545D-02, 0.1444D-02, 0.1439D-02, 0.1470D-02 & + / + data (OREF(47, 7, mtmp), mtmp=1,12) & + / & + 0.1487D-02, 0.1530D-02, 0.1490D-02, 0.1510D-02, & + 0.1580D-02, 0.1642D-02, 0.1685D-02, 0.1539D-02, & + 0.1499D-02, 0.1457D-02, 0.1480D-02, 0.1522D-02 & + / + data (OREF(47, 8, mtmp), mtmp=1,12) & + / & + 0.1404D-02, 0.1391D-02, 0.1446D-02, 0.1527D-02, & + 0.1605D-02, 0.1637D-02, 0.1602D-02, 0.1519D-02, & + 0.1510D-02, 0.1497D-02, 0.1520D-02, 0.1549D-02 & + / + data (OREF(47, 9, mtmp), mtmp=1,12) & + / & + 0.1364D-02, 0.1313D-02, 0.1449D-02, 0.1562D-02, & + 0.1637D-02, 0.1632D-02, 0.1565D-02, 0.1527D-02, & + 0.1537D-02, 0.1532D-02, 0.1583D-02, 0.1602D-02 & + / + data (OREF(47,10, mtmp), mtmp=1,12) & + / & + 0.1371D-02, 0.1333D-02, 0.1461D-02, 0.1560D-02, & + 0.1630D-02, 0.1630D-02, 0.1578D-02, 0.1535D-02, & + 0.1544D-02, 0.1545D-02, 0.1610D-02, 0.1620D-02 & + / + data (OREF(47,11, mtmp), mtmp=1,12) & + / & + 0.1366D-02, 0.1396D-02, 0.1505D-02, 0.1572D-02, & + 0.1625D-02, 0.1662D-02, 0.1640D-02, 0.1549D-02, & + 0.1522D-02, 0.1517D-02, 0.1549D-02, 0.1550D-02 & + / + data (OREF(47,12, mtmp), mtmp=1,12) & + / & + 0.1416D-02, 0.1436D-02, 0.1547D-02, 0.1595D-02, & + 0.1615D-02, 0.1673D-02, 0.1706D-02, 0.1564D-02, & + 0.1494D-02, 0.1441D-02, 0.1479D-02, 0.1519D-02 & + / + data (OREF(47,13, mtmp), mtmp=1,12) & + / & + 0.1575D-02, 0.1515D-02, 0.1479D-02, 0.1529D-02, & + 0.1547D-02, 0.1600D-02, 0.1680D-02, 0.1569D-02, & + 0.1475D-02, 0.1414D-02, 0.1500D-02, 0.1525D-02 & + / + data (OREF(47,14, mtmp), mtmp=1,12) & + / & + 0.1655D-02, 0.1680D-02, 0.1422D-02, 0.1379D-02, & + 0.1454D-02, 0.1497D-02, 0.1555D-02, 0.1480D-02, & + 0.1439D-02, 0.1449D-02, 0.1587D-02, 0.1485D-02 & + / + data (OREF(47,15, mtmp), mtmp=1,12) & + / & + 0.1539D-02, 0.1721D-02, 0.1497D-02, 0.1338D-02, & + 0.1351D-02, 0.1389D-02, 0.1409D-02, 0.1364D-02, & + 0.1389D-02, 0.1494D-02, 0.1560D-02, 0.1379D-02 & + / + data (OREF(47,16, mtmp), mtmp=1,12) & + / & + 0.1461D-02, 0.1627D-02, 0.1577D-02, 0.1371D-02, & + 0.1301D-02, 0.1308D-02, 0.1314D-02, 0.1284D-02, & + 0.1359D-02, 0.1459D-02, 0.1424D-02, 0.1351D-02 & + / + data (OREF(47,17, mtmp), mtmp=1,12) & + / & + 0.1461D-02, 0.1554D-02, 0.1560D-02, 0.1396D-02, & + 0.1243D-02, 0.1150D-02, 0.1140D-02, 0.1205D-02, & + 0.1306D-02, 0.1417D-02, 0.1424D-02, 0.1351D-02 & + / + data (OREF(47,18, mtmp), mtmp=1,12) & + / & + 0.1461D-02, 0.1554D-02, 0.1560D-02, 0.1396D-02, & + 0.1243D-02, 0.1150D-02, 0.1140D-02, 0.1205D-02, & + 0.1306D-02, 0.1417D-02, 0.1424D-02, 0.1351D-02 & + / + data (OREF(48, 1, mtmp), mtmp=1,12) & + / & + 0.7284D-03, 0.8331D-03, 0.9835D-03, 0.1078D-02, & + 0.1143D-02, 0.1083D-02, 0.1000D-02, 0.9779D-03, & + 0.9022D-03, 0.9300D-03, 0.8231D-03, 0.7640D-03 & + / + data (OREF(48, 2, mtmp), mtmp=1,12) & + / & + 0.7284D-03, 0.8331D-03, 0.9835D-03, 0.1078D-02, & + 0.1143D-02, 0.1083D-02, 0.1000D-02, 0.9779D-03, & + 0.9022D-03, 0.9300D-03, 0.8231D-03, 0.7640D-03 & + / + data (OREF(48, 3, mtmp), mtmp=1,12) & + / & + 0.8309D-03, 0.8855D-03, 0.9991D-03, 0.1104D-02, & + 0.1143D-02, 0.1083D-02, 0.1000D-02, 0.9779D-03, & + 0.9534D-03, 0.9556D-03, 0.8888D-03, 0.8621D-03 & + / + data (OREF(48, 4, mtmp), mtmp=1,12) & + / & + 0.8843D-03, 0.9389D-03, 0.1014D-02, 0.1134D-02, & + 0.1216D-02, 0.1138D-02, 0.1051D-02, 0.1027D-02, & + 0.1025D-02, 0.9823D-03, 0.9244D-03, 0.9033D-03 & + / + data (OREF(48, 5, mtmp), mtmp=1,12) & + / & + 0.9512D-03, 0.1009D-02, 0.1037D-02, 0.1114D-02, & + 0.1227D-02, 0.1203D-02, 0.1200D-02, 0.1102D-02, & + 0.1063D-02, 0.9801D-03, 0.9411D-03, 0.9445D-03 & + / + data (OREF(48, 6, mtmp), mtmp=1,12) & + / & + 0.1000D-02, 0.1050D-02, 0.1040D-02, 0.1058D-02, & + 0.1110D-02, 0.1124D-02, 0.1192D-02, 0.1081D-02, & + 0.1036D-02, 0.9679D-03, 0.9645D-03, 0.9857D-03 & + / + data (OREF(48, 7, mtmp), mtmp=1,12) & + / & + 0.9968D-03, 0.1026D-02, 0.9991D-03, 0.1012D-02, & + 0.1059D-02, 0.1100D-02, 0.1129D-02, 0.1031D-02, & + 0.1005D-02, 0.9768D-03, 0.9924D-03, 0.1020D-02 & + / + data (OREF(48, 8, mtmp), mtmp=1,12) & + / & + 0.9411D-03, 0.9322D-03, 0.9690D-03, 0.1024D-02, & + 0.1076D-02, 0.1097D-02, 0.1074D-02, 0.1018D-02, & + 0.1012D-02, 0.1004D-02, 0.1019D-02, 0.1038D-02 & + / + data (OREF(48, 9, mtmp), mtmp=1,12) & + / & + 0.9144D-03, 0.8799D-03, 0.9712D-03, 0.1047D-02, & + 0.1097D-02, 0.1094D-02, 0.1049D-02, 0.1024D-02, & + 0.1030D-02, 0.1027D-02, 0.1061D-02, 0.1074D-02 & + / + data (OREF(48,10, mtmp), mtmp=1,12) & + / & + 0.9189D-03, 0.8932D-03, 0.9790D-03, 0.1046D-02, & + 0.1093D-02, 0.1093D-02, 0.1058D-02, 0.1029D-02, & + 0.1035D-02, 0.1036D-02, 0.1079D-02, 0.1086D-02 & + / + data (OREF(48,11, mtmp), mtmp=1,12) & + / & + 0.9155D-03, 0.9356D-03, 0.1009D-02, 0.1054D-02, & + 0.1089D-02, 0.1114D-02, 0.1099D-02, 0.1038D-02, & + 0.1020D-02, 0.1017D-02, 0.1038D-02, 0.1039D-02 & + / + data (OREF(48,12, mtmp), mtmp=1,12) & + / & + 0.9489D-03, 0.9623D-03, 0.1037D-02, 0.1069D-02, & + 0.1083D-02, 0.1122D-02, 0.1144D-02, 0.1048D-02, & + 0.1001D-02, 0.9656D-03, 0.9913D-03, 0.1018D-02 & + / + data (OREF(48,13, mtmp), mtmp=1,12) & + / & + 0.1056D-02, 0.1016D-02, 0.9913D-03, 0.1025D-02, & + 0.1037D-02, 0.1073D-02, 0.1126D-02, 0.1051D-02, & + 0.9890D-03, 0.9478D-03, 0.1006D-02, 0.1022D-02 & + / + data (OREF(48,14, mtmp), mtmp=1,12) & + / & + 0.1109D-02, 0.1126D-02, 0.9534D-03, 0.9244D-03, & + 0.9746D-03, 0.1004D-02, 0.1042D-02, 0.9924D-03, & + 0.9645D-03, 0.9712D-03, 0.1064D-02, 0.9957D-03 & + / + data (OREF(48,15, mtmp), mtmp=1,12) & + / & + 0.1031D-02, 0.1154D-02, 0.1004D-02, 0.8966D-03, & + 0.9055D-03, 0.9311D-03, 0.9445D-03, 0.9144D-03, & + 0.9311D-03, 0.1001D-02, 0.1046D-02, 0.9244D-03 & + / + data (OREF(48,16, mtmp), mtmp=1,12) & + / & + 0.9790D-03, 0.1090D-02, 0.1057D-02, 0.9189D-03, & + 0.8721D-03, 0.8765D-03, 0.8810D-03, 0.8609D-03, & + 0.9111D-03, 0.9779D-03, 0.9545D-03, 0.9055D-03 & + / + data (OREF(48,17, mtmp), mtmp=1,12) & + / & + 0.9790D-03, 0.1041D-02, 0.1046D-02, 0.9356D-03, & + 0.8331D-03, 0.7707D-03, 0.7640D-03, 0.8075D-03, & + 0.8754D-03, 0.9501D-03, 0.9545D-03, 0.9055D-03 & + / + data (OREF(48,18, mtmp), mtmp=1,12) & + / & + 0.9790D-03, 0.1041D-02, 0.1046D-02, 0.9356D-03, & + 0.8331D-03, 0.7707D-03, 0.7640D-03, 0.8075D-03, & + 0.8754D-03, 0.9501D-03, 0.9545D-03, 0.9055D-03 & + / + data (OREF(49, 1, mtmp), mtmp=1,12) & + / & + 0.4883D-03, 0.5584D-03, 0.6592D-03, 0.7227D-03, & + 0.7660D-03, 0.7257D-03, 0.6704D-03, 0.6555D-03, & + 0.6047D-03, 0.6234D-03, 0.5517D-03, 0.5122D-03 & + / + data (OREF(49, 2, mtmp), mtmp=1,12) & + / & + 0.4883D-03, 0.5584D-03, 0.6592D-03, 0.7227D-03, & + 0.7660D-03, 0.7257D-03, 0.6704D-03, 0.6555D-03, & + 0.6047D-03, 0.6234D-03, 0.5517D-03, 0.5122D-03 & + / + data (OREF(49, 3, mtmp), mtmp=1,12) & + / & + 0.5570D-03, 0.5935D-03, 0.6697D-03, 0.7399D-03, & + 0.7660D-03, 0.7257D-03, 0.6704D-03, 0.6555D-03, & + 0.6391D-03, 0.6406D-03, 0.5958D-03, 0.5779D-03 & + / + data (OREF(49, 4, mtmp), mtmp=1,12) & + / & + 0.5928D-03, 0.6294D-03, 0.6794D-03, 0.7600D-03, & + 0.8153D-03, 0.7630D-03, 0.7048D-03, 0.6884D-03, & + 0.6869D-03, 0.6585D-03, 0.6197D-03, 0.6055D-03 & + / + data (OREF(49, 5, mtmp), mtmp=1,12) & + / & + 0.6376D-03, 0.6764D-03, 0.6951D-03, 0.7466D-03, & + 0.8227D-03, 0.8063D-03, 0.8041D-03, 0.7384D-03, & + 0.7122D-03, 0.6570D-03, 0.6309D-03, 0.6331D-03 & + / + data (OREF(49, 6, mtmp), mtmp=1,12) & + / & + 0.6704D-03, 0.7040D-03, 0.6973D-03, 0.7093D-03, & + 0.7443D-03, 0.7533D-03, 0.7988D-03, 0.7249D-03, & + 0.6943D-03, 0.6488D-03, 0.6465D-03, 0.6607D-03 & + / + data (OREF(49, 7, mtmp), mtmp=1,12) & + / & + 0.6682D-03, 0.6876D-03, 0.6697D-03, 0.6786D-03, & + 0.7100D-03, 0.7376D-03, 0.7570D-03, 0.6913D-03, & + 0.6734D-03, 0.6548D-03, 0.6652D-03, 0.6839D-03 & + / + data (OREF(49, 8, mtmp), mtmp=1,12) & + / & + 0.6309D-03, 0.6249D-03, 0.6495D-03, 0.6861D-03, & + 0.7212D-03, 0.7354D-03, 0.7197D-03, 0.6824D-03, & + 0.6786D-03, 0.6727D-03, 0.6831D-03, 0.6958D-03 & + / + data (OREF(49, 9, mtmp), mtmp=1,12) & + / & + 0.6129D-03, 0.5898D-03, 0.6510D-03, 0.7018D-03, & + 0.7354D-03, 0.7331D-03, 0.7033D-03, 0.6861D-03, & + 0.6906D-03, 0.6884D-03, 0.7115D-03, 0.7197D-03 & + / + data (OREF(49,10, mtmp), mtmp=1,12) & + / & + 0.6159D-03, 0.5988D-03, 0.6562D-03, 0.7010D-03, & + 0.7324D-03, 0.7324D-03, 0.7093D-03, 0.6898D-03, & + 0.6936D-03, 0.6943D-03, 0.7234D-03, 0.7279D-03 & + / + data (OREF(49,11, mtmp), mtmp=1,12) & + / & + 0.6137D-03, 0.6271D-03, 0.6764D-03, 0.7063D-03, & + 0.7302D-03, 0.7466D-03, 0.7369D-03, 0.6958D-03, & + 0.6839D-03, 0.6816D-03, 0.6958D-03, 0.6966D-03 & + / + data (OREF(49,12, mtmp), mtmp=1,12) & + / & + 0.6361D-03, 0.6451D-03, 0.6951D-03, 0.7167D-03, & + 0.7257D-03, 0.7518D-03, 0.7667D-03, 0.7025D-03, & + 0.6712D-03, 0.6473D-03, 0.6645D-03, 0.6824D-03 & + / + data (OREF(49,13, mtmp), mtmp=1,12) & + / & + 0.7078D-03, 0.6809D-03, 0.6645D-03, 0.6869D-03, & + 0.6951D-03, 0.7190D-03, 0.7548D-03, 0.7048D-03, & + 0.6630D-03, 0.6353D-03, 0.6742D-03, 0.6854D-03 & + / + data (OREF(49,14, mtmp), mtmp=1,12) & + / & + 0.7436D-03, 0.7548D-03, 0.6391D-03, 0.6197D-03, & + 0.6533D-03, 0.6727D-03, 0.6988D-03, 0.6652D-03, & + 0.6465D-03, 0.6510D-03, 0.7130D-03, 0.6674D-03 & + / + data (OREF(49,15, mtmp), mtmp=1,12) & + / & + 0.6913D-03, 0.7735D-03, 0.6727D-03, 0.6010D-03, & + 0.6070D-03, 0.6241D-03, 0.6331D-03, 0.6129D-03, & + 0.6241D-03, 0.6712D-03, 0.7010D-03, 0.6197D-03 & + / + data (OREF(49,16, mtmp), mtmp=1,12) & + / & + 0.6562D-03, 0.7309D-03, 0.7085D-03, 0.6159D-03, & + 0.5846D-03, 0.5876D-03, 0.5905D-03, 0.5771D-03, & + 0.6107D-03, 0.6555D-03, 0.6398D-03, 0.6070D-03 & + / + data (OREF(49,17, mtmp), mtmp=1,12) & + / & + 0.6562D-03, 0.6981D-03, 0.7010D-03, 0.6271D-03, & + 0.5584D-03, 0.5166D-03, 0.5122D-03, 0.5413D-03, & + 0.5868D-03, 0.6368D-03, 0.6398D-03, 0.6070D-03 & + / + data (OREF(49,18, mtmp), mtmp=1,12) & + / & + 0.6562D-03, 0.6981D-03, 0.7010D-03, 0.6271D-03, & + 0.5584D-03, 0.5166D-03, 0.5122D-03, 0.5413D-03, & + 0.5868D-03, 0.6368D-03, 0.6398D-03, 0.6070D-03 & + / + data (OREF(50, 1, mtmp), mtmp=1,12) & + / & + 0.3273D-03, 0.3743D-03, 0.4419D-03, 0.4844D-03, & + 0.5135D-03, 0.4864D-03, 0.4494D-03, 0.4394D-03, & + 0.4054D-03, 0.4179D-03, 0.3698D-03, 0.3433D-03 & + / + data (OREF(50, 2, mtmp), mtmp=1,12) & + / & + 0.3273D-03, 0.3743D-03, 0.4419D-03, 0.4844D-03, & + 0.5135D-03, 0.4864D-03, 0.4494D-03, 0.4394D-03, & + 0.4054D-03, 0.4179D-03, 0.3698D-03, 0.3433D-03 & + / + data (OREF(50, 3, mtmp), mtmp=1,12) & + / & + 0.3733D-03, 0.3979D-03, 0.4489D-03, 0.4959D-03, & + 0.5135D-03, 0.4864D-03, 0.4494D-03, 0.4394D-03, & + 0.4284D-03, 0.4294D-03, 0.3994D-03, 0.3873D-03 & + / + data (OREF(50, 4, mtmp), mtmp=1,12) & + / & + 0.3974D-03, 0.4219D-03, 0.4554D-03, 0.5095D-03, & + 0.5465D-03, 0.5115D-03, 0.4724D-03, 0.4614D-03, & + 0.4604D-03, 0.4414D-03, 0.4154D-03, 0.4059D-03 & + / + data (OREF(50, 5, mtmp), mtmp=1,12) & + / & + 0.4274D-03, 0.4534D-03, 0.4659D-03, 0.5005D-03, & + 0.5515D-03, 0.5405D-03, 0.5390D-03, 0.4949D-03, & + 0.4774D-03, 0.4404D-03, 0.4229D-03, 0.4244D-03 & + / + data (OREF(50, 6, mtmp), mtmp=1,12) & + / & + 0.4494D-03, 0.4719D-03, 0.4674D-03, 0.4754D-03, & + 0.4990D-03, 0.5050D-03, 0.5355D-03, 0.4859D-03, & + 0.4654D-03, 0.4349D-03, 0.4334D-03, 0.4429D-03 & + / + data (OREF(50, 7, mtmp), mtmp=1,12) & + / & + 0.4479D-03, 0.4609D-03, 0.4489D-03, 0.4549D-03, & + 0.4759D-03, 0.4944D-03, 0.5075D-03, 0.4634D-03, & + 0.4514D-03, 0.4389D-03, 0.4459D-03, 0.4584D-03 & + / + data (OREF(50, 8, mtmp), mtmp=1,12) & + / & + 0.4229D-03, 0.4189D-03, 0.4354D-03, 0.4599D-03, & + 0.4834D-03, 0.4929D-03, 0.4824D-03, 0.4574D-03, & + 0.4549D-03, 0.4509D-03, 0.4579D-03, 0.4664D-03 & + / + data (OREF(50, 9, mtmp), mtmp=1,12) & + / & + 0.4109D-03, 0.3954D-03, 0.4364D-03, 0.4704D-03, & + 0.4929D-03, 0.4914D-03, 0.4714D-03, 0.4599D-03, & + 0.4629D-03, 0.4614D-03, 0.4769D-03, 0.4824D-03 & + / + data (OREF(50,10, mtmp), mtmp=1,12) & + / & + 0.4129D-03, 0.4014D-03, 0.4399D-03, 0.4699D-03, & + 0.4909D-03, 0.4909D-03, 0.4754D-03, 0.4624D-03, & + 0.4649D-03, 0.4654D-03, 0.4849D-03, 0.4879D-03 & + / + data (OREF(50,11, mtmp), mtmp=1,12) & + / & + 0.4114D-03, 0.4204D-03, 0.4534D-03, 0.4734D-03, & + 0.4894D-03, 0.5005D-03, 0.4939D-03, 0.4664D-03, & + 0.4584D-03, 0.4569D-03, 0.4664D-03, 0.4669D-03 & + / + data (OREF(50,12, mtmp), mtmp=1,12) & + / & + 0.4264D-03, 0.4324D-03, 0.4659D-03, 0.4804D-03, & + 0.4864D-03, 0.5040D-03, 0.5140D-03, 0.4709D-03, & + 0.4499D-03, 0.4339D-03, 0.4454D-03, 0.4574D-03 & + / + data (OREF(50,13, mtmp), mtmp=1,12) & + / & + 0.4744D-03, 0.4564D-03, 0.4454D-03, 0.4604D-03, & + 0.4659D-03, 0.4819D-03, 0.5060D-03, 0.4724D-03, & + 0.4444D-03, 0.4259D-03, 0.4519D-03, 0.4594D-03 & + / + data (OREF(50,14, mtmp), mtmp=1,12) & + / & + 0.4984D-03, 0.5060D-03, 0.4284D-03, 0.4154D-03, & + 0.4379D-03, 0.4509D-03, 0.4684D-03, 0.4459D-03, & + 0.4334D-03, 0.4364D-03, 0.4779D-03, 0.4474D-03 & + / + data (OREF(50,15, mtmp), mtmp=1,12) & + / & + 0.4634D-03, 0.5185D-03, 0.4509D-03, 0.4029D-03, & + 0.4069D-03, 0.4184D-03, 0.4244D-03, 0.4109D-03, & + 0.4184D-03, 0.4499D-03, 0.4699D-03, 0.4154D-03 & + / + data (OREF(50,16, mtmp), mtmp=1,12) & + / & + 0.4399D-03, 0.4899D-03, 0.4749D-03, 0.4129D-03, & + 0.3919D-03, 0.3939D-03, 0.3959D-03, 0.3868D-03, & + 0.4094D-03, 0.4394D-03, 0.4289D-03, 0.4069D-03 & + / + data (OREF(50,17, mtmp), mtmp=1,12) & + / & + 0.4399D-03, 0.4679D-03, 0.4699D-03, 0.4204D-03, & + 0.3743D-03, 0.3463D-03, 0.3433D-03, 0.3628D-03, & + 0.3934D-03, 0.4269D-03, 0.4289D-03, 0.4069D-03 & + / + data (OREF(50,18, mtmp), mtmp=1,12) & + / & + 0.4399D-03, 0.4679D-03, 0.4699D-03, 0.4204D-03, & + 0.3743D-03, 0.3463D-03, 0.3433D-03, 0.3628D-03, & + 0.3934D-03, 0.4269D-03, 0.4289D-03, 0.4069D-03 & + / + data (OREF(51, 1, mtmp), mtmp=1,12) & + / & + 0.2194D-03, 0.2509D-03, 0.2962D-03, 0.3247D-03, & + 0.3442D-03, 0.3261D-03, 0.3012D-03, 0.2945D-03, & + 0.2717D-03, 0.2801D-03, 0.2479D-03, 0.2301D-03 & + / + data (OREF(51, 2, mtmp), mtmp=1,12) & + / & + 0.2194D-03, 0.2509D-03, 0.2962D-03, 0.3247D-03, & + 0.3442D-03, 0.3261D-03, 0.3012D-03, 0.2945D-03, & + 0.2717D-03, 0.2801D-03, 0.2479D-03, 0.2301D-03 & + / + data (OREF(51, 3, mtmp), mtmp=1,12) & + / & + 0.2503D-03, 0.2667D-03, 0.3009D-03, 0.3324D-03, & + 0.3442D-03, 0.3261D-03, 0.3012D-03, 0.2945D-03, & + 0.2872D-03, 0.2878D-03, 0.2677D-03, 0.2596D-03 & + / + data (OREF(51, 4, mtmp), mtmp=1,12) & + / & + 0.2664D-03, 0.2828D-03, 0.3053D-03, 0.3415D-03, & + 0.3663D-03, 0.3428D-03, 0.3167D-03, 0.3093D-03, & + 0.3086D-03, 0.2959D-03, 0.2784D-03, 0.2721D-03 & + / + data (OREF(51, 5, mtmp), mtmp=1,12) & + / & + 0.2865D-03, 0.3039D-03, 0.3123D-03, 0.3355D-03, & + 0.3697D-03, 0.3623D-03, 0.3613D-03, 0.3318D-03, & + 0.3200D-03, 0.2952D-03, 0.2835D-03, 0.2845D-03 & + / + data (OREF(51, 6, mtmp), mtmp=1,12) & + / & + 0.3012D-03, 0.3163D-03, 0.3133D-03, 0.3187D-03, & + 0.3345D-03, 0.3385D-03, 0.3589D-03, 0.3257D-03, & + 0.3120D-03, 0.2915D-03, 0.2905D-03, 0.2969D-03 & + / + data (OREF(51, 7, mtmp), mtmp=1,12) & + / & + 0.3002D-03, 0.3090D-03, 0.3009D-03, 0.3049D-03, & + 0.3190D-03, 0.3314D-03, 0.3402D-03, 0.3106D-03, & + 0.3026D-03, 0.2942D-03, 0.2989D-03, 0.3073D-03 & + / + data (OREF(51, 8, mtmp), mtmp=1,12) & + / & + 0.2835D-03, 0.2808D-03, 0.2919D-03, 0.3083D-03, & + 0.3241D-03, 0.3304D-03, 0.3234D-03, 0.3066D-03, & + 0.3049D-03, 0.3023D-03, 0.3069D-03, 0.3127D-03 & + / + data (OREF(51, 9, mtmp), mtmp=1,12) & + / & + 0.2754D-03, 0.2650D-03, 0.2925D-03, 0.3153D-03, & + 0.3304D-03, 0.3294D-03, 0.3160D-03, 0.3083D-03, & + 0.3103D-03, 0.3093D-03, 0.3197D-03, 0.3234D-03 & + / + data (OREF(51,10, mtmp), mtmp=1,12) & + / & + 0.2768D-03, 0.2690D-03, 0.2949D-03, 0.3150D-03, & + 0.3291D-03, 0.3291D-03, 0.3187D-03, 0.3100D-03, & + 0.3116D-03, 0.3120D-03, 0.3251D-03, 0.3271D-03 & + / + data (OREF(51,11, mtmp), mtmp=1,12) & + / & + 0.2758D-03, 0.2818D-03, 0.3039D-03, 0.3173D-03, & + 0.3281D-03, 0.3355D-03, 0.3311D-03, 0.3127D-03, & + 0.3073D-03, 0.3063D-03, 0.3127D-03, 0.3130D-03 & + / + data (OREF(51,12, mtmp), mtmp=1,12) & + / & + 0.2858D-03, 0.2898D-03, 0.3123D-03, 0.3220D-03, & + 0.3261D-03, 0.3378D-03, 0.3445D-03, 0.3157D-03, & + 0.3016D-03, 0.2908D-03, 0.2986D-03, 0.3066D-03 & + / + data (OREF(51,13, mtmp), mtmp=1,12) & + / & + 0.3180D-03, 0.3059D-03, 0.2986D-03, 0.3086D-03, & + 0.3123D-03, 0.3231D-03, 0.3392D-03, 0.3167D-03, & + 0.2979D-03, 0.2855D-03, 0.3029D-03, 0.3080D-03 & + / + data (OREF(51,14, mtmp), mtmp=1,12) & + / & + 0.3341D-03, 0.3392D-03, 0.2872D-03, 0.2784D-03, & + 0.2935D-03, 0.3023D-03, 0.3140D-03, 0.2989D-03, & + 0.2905D-03, 0.2925D-03, 0.3204D-03, 0.2999D-03 & + / + data (OREF(51,15, mtmp), mtmp=1,12) & + / & + 0.3106D-03, 0.3475D-03, 0.3023D-03, 0.2700D-03, & + 0.2727D-03, 0.2804D-03, 0.2845D-03, 0.2754D-03, & + 0.2804D-03, 0.3016D-03, 0.3150D-03, 0.2784D-03 & + / + data (OREF(51,16, mtmp), mtmp=1,12) & + / & + 0.2949D-03, 0.3284D-03, 0.3184D-03, 0.2768D-03, & + 0.2627D-03, 0.2640D-03, 0.2654D-03, 0.2593D-03, & + 0.2744D-03, 0.2945D-03, 0.2875D-03, 0.2727D-03 & + / + data (OREF(51,17, mtmp), mtmp=1,12) & + / & + 0.2949D-03, 0.3137D-03, 0.3150D-03, 0.2818D-03, & + 0.2509D-03, 0.2321D-03, 0.2301D-03, 0.2432D-03, & + 0.2637D-03, 0.2861D-03, 0.2875D-03, 0.2727D-03 & + / + data (OREF(51,18, mtmp), mtmp=1,12) & + / & + 0.2949D-03, 0.3137D-03, 0.3150D-03, 0.2818D-03, & + 0.2509D-03, 0.2321D-03, 0.2301D-03, 0.2432D-03, & + 0.2637D-03, 0.2861D-03, 0.2875D-03, 0.2727D-03 & + / + data (TREF( 1, 1, mtmp), mtmp=1,12) & + / & + 0.2564D+03, 0.2533D+03, 0.2525D+03, 0.2487D+03, & + 0.2473D+03, 0.2451D+03, 0.2462D+03, 0.2445D+03, & + 0.2449D+03, 0.2460D+03, 0.2515D+03, 0.2527D+03 & + / + data (TREF( 1, 2, mtmp), mtmp=1,12) & + / & + 0.2621D+03, 0.2596D+03, 0.2569D+03, 0.2539D+03, & + 0.2522D+03, 0.2504D+03, 0.2502D+03, 0.2494D+03, & + 0.2501D+03, 0.2520D+03, 0.2566D+03, 0.2594D+03 & + / + data (TREF( 1, 3, mtmp), mtmp=1,12) & + / & + 0.2685D+03, 0.2675D+03, 0.2654D+03, 0.2633D+03, & + 0.2615D+03, 0.2602D+03, 0.2593D+03, 0.2588D+03, & + 0.2600D+03, 0.2616D+03, 0.2647D+03, 0.2668D+03 & + / + data (TREF( 1, 4, mtmp), mtmp=1,12) & + / & + 0.2736D+03, 0.2739D+03, 0.2728D+03, 0.2713D+03, & + 0.2697D+03, 0.2687D+03, 0.2679D+03, 0.2677D+03, & + 0.2686D+03, 0.2699D+03, 0.2713D+03, 0.2723D+03 & + / + data (TREF( 1, 5, mtmp), mtmp=1,12) & + / & + 0.2802D+03, 0.2807D+03, 0.2798D+03, 0.2781D+03, & + 0.2763D+03, 0.2752D+03, 0.2746D+03, 0.2744D+03, & + 0.2750D+03, 0.2762D+03, 0.2776D+03, 0.2788D+03 & + / + data (TREF( 1, 6, mtmp), mtmp=1,12) & + / & + 0.2872D+03, 0.2877D+03, 0.2869D+03, 0.2849D+03, & + 0.2831D+03, 0.2815D+03, 0.2807D+03, 0.2806D+03, & + 0.2810D+03, 0.2823D+03, 0.2839D+03, 0.2858D+03 & + / + data (TREF( 1, 7, mtmp), mtmp=1,12) & + / & + 0.2917D+03, 0.2922D+03, 0.2918D+03, 0.2903D+03, & + 0.2888D+03, 0.2872D+03, 0.2864D+03, 0.2865D+03, & + 0.2871D+03, 0.2881D+03, 0.2894D+03, 0.2910D+03 & + / + data (TREF( 1, 8, mtmp), mtmp=1,12) & + / & + 0.2934D+03, 0.2936D+03, 0.2938D+03, 0.2934D+03, & + 0.2925D+03, 0.2914D+03, 0.2906D+03, 0.2907D+03, & + 0.2913D+03, 0.2920D+03, 0.2926D+03, 0.2934D+03 & + / + data (TREF( 1, 9, mtmp), mtmp=1,12) & + / & + 0.2932D+03, 0.2934D+03, 0.2939D+03, 0.2941D+03, & + 0.2938D+03, 0.2929D+03, 0.2920D+03, 0.2919D+03, & + 0.2924D+03, 0.2927D+03, 0.2930D+03, 0.2933D+03 & + / + data (TREF( 1,10, mtmp), mtmp=1,12) & + / & + 0.2928D+03, 0.2931D+03, 0.2937D+03, 0.2943D+03, & + 0.2943D+03, 0.2938D+03, 0.2931D+03, 0.2931D+03, & + 0.2933D+03, 0.2934D+03, 0.2934D+03, 0.2931D+03 & + / + data (TREF( 1,11, mtmp), mtmp=1,12) & + / & + 0.2912D+03, 0.2916D+03, 0.2926D+03, 0.2940D+03, & + 0.2949D+03, 0.2953D+03, 0.2951D+03, 0.2953D+03, & + 0.2952D+03, 0.2945D+03, 0.2935D+03, 0.2921D+03 & + / + data (TREF( 1,12, mtmp), mtmp=1,12) & + / & + 0.2862D+03, 0.2867D+03, 0.2882D+03, 0.2906D+03, & + 0.2928D+03, 0.2950D+03, 0.2957D+03, 0.2958D+03, & + 0.2950D+03, 0.2930D+03, 0.2902D+03, 0.2875D+03 & + / + data (TREF( 1,13, mtmp), mtmp=1,12) & + / & + 0.2790D+03, 0.2792D+03, 0.2813D+03, 0.2848D+03, & + 0.2884D+03, 0.2921D+03, 0.2942D+03, 0.2943D+03, & + 0.2922D+03, 0.2884D+03, 0.2841D+03, 0.2804D+03 & + / + data (TREF( 1,14, mtmp), mtmp=1,12) & + / & + 0.2699D+03, 0.2702D+03, 0.2730D+03, 0.2777D+03, & + 0.2824D+03, 0.2866D+03, 0.2897D+03, 0.2896D+03, & + 0.2859D+03, 0.2808D+03, 0.2753D+03, 0.2716D+03 & + / + data (TREF( 1,15, mtmp), mtmp=1,12) & + / & + 0.2620D+03, 0.2623D+03, 0.2653D+03, 0.2704D+03, & + 0.2761D+03, 0.2812D+03, 0.2844D+03, 0.2835D+03, & + 0.2787D+03, 0.2728D+03, 0.2670D+03, 0.2635D+03 & + / + data (TREF( 1,16, mtmp), mtmp=1,12) & + / & + 0.2566D+03, 0.2565D+03, 0.2586D+03, 0.2631D+03, & + 0.2698D+03, 0.2764D+03, 0.2799D+03, 0.2782D+03, & + 0.2731D+03, 0.2664D+03, 0.2607D+03, 0.2575D+03 & + / + data (TREF( 1,17, mtmp), mtmp=1,12) & + / & + 0.2523D+03, 0.2515D+03, 0.2530D+03, 0.2562D+03, & + 0.2637D+03, 0.2709D+03, 0.2747D+03, 0.2728D+03, & + 0.2675D+03, 0.2607D+03, 0.2554D+03, 0.2530D+03 & + / + data (TREF( 1,18, mtmp), mtmp=1,12) & + / & + 0.2498D+03, 0.2490D+03, 0.2509D+03, 0.2528D+03, & + 0.2608D+03, 0.2672D+03, 0.2708D+03, 0.2693D+03, & + 0.2640D+03, 0.2568D+03, 0.2525D+03, 0.2512D+03 & + / + data (TREF( 2, 1, mtmp), mtmp=1,12) & + / & + 0.2511D+03, 0.2483D+03, 0.2476D+03, 0.2446D+03, & + 0.2434D+03, 0.2413D+03, 0.2422D+03, 0.2407D+03, & + 0.2408D+03, 0.2419D+03, 0.2469D+03, 0.2487D+03 & + / + data (TREF( 2, 2, mtmp), mtmp=1,12) & + / & + 0.2564D+03, 0.2542D+03, 0.2519D+03, 0.2493D+03, & + 0.2481D+03, 0.2463D+03, 0.2461D+03, 0.2454D+03, & + 0.2459D+03, 0.2474D+03, 0.2515D+03, 0.2544D+03 & + / + data (TREF( 2, 3, mtmp), mtmp=1,12) & + / & + 0.2621D+03, 0.2613D+03, 0.2596D+03, 0.2575D+03, & + 0.2561D+03, 0.2547D+03, 0.2538D+03, 0.2533D+03, & + 0.2543D+03, 0.2557D+03, 0.2585D+03, 0.2607D+03 & + / + data (TREF( 2, 4, mtmp), mtmp=1,12) & + / & + 0.2670D+03, 0.2673D+03, 0.2664D+03, 0.2646D+03, & + 0.2630D+03, 0.2618D+03, 0.2611D+03, 0.2607D+03, & + 0.2616D+03, 0.2629D+03, 0.2645D+03, 0.2657D+03 & + / + data (TREF( 2, 5, mtmp), mtmp=1,12) & + / & + 0.2735D+03, 0.2742D+03, 0.2733D+03, 0.2713D+03, & + 0.2692D+03, 0.2678D+03, 0.2672D+03, 0.2670D+03, & + 0.2676D+03, 0.2690D+03, 0.2707D+03, 0.2720D+03 & + / + data (TREF( 2, 6, mtmp), mtmp=1,12) & + / & + 0.2803D+03, 0.2809D+03, 0.2800D+03, 0.2779D+03, & + 0.2758D+03, 0.2741D+03, 0.2733D+03, 0.2733D+03, & + 0.2738D+03, 0.2753D+03, 0.2770D+03, 0.2789D+03 & + / + data (TREF( 2, 7, mtmp), mtmp=1,12) & + / & + 0.2847D+03, 0.2851D+03, 0.2847D+03, 0.2832D+03, & + 0.2817D+03, 0.2803D+03, 0.2796D+03, 0.2797D+03, & + 0.2802D+03, 0.2813D+03, 0.2825D+03, 0.2839D+03 & + / + data (TREF( 2, 8, mtmp), mtmp=1,12) & + / & + 0.2864D+03, 0.2866D+03, 0.2867D+03, 0.2863D+03, & + 0.2856D+03, 0.2847D+03, 0.2841D+03, 0.2842D+03, & + 0.2846D+03, 0.2852D+03, 0.2857D+03, 0.2863D+03 & + / + data (TREF( 2, 9, mtmp), mtmp=1,12) & + / & + 0.2864D+03, 0.2866D+03, 0.2870D+03, 0.2872D+03, & + 0.2869D+03, 0.2862D+03, 0.2854D+03, 0.2855D+03, & + 0.2858D+03, 0.2861D+03, 0.2863D+03, 0.2865D+03 & + / + data (TREF( 2,10, mtmp), mtmp=1,12) & + / & + 0.2861D+03, 0.2863D+03, 0.2868D+03, 0.2873D+03, & + 0.2874D+03, 0.2869D+03, 0.2861D+03, 0.2863D+03, & + 0.2864D+03, 0.2866D+03, 0.2865D+03, 0.2864D+03 & + / + data (TREF( 2,11, mtmp), mtmp=1,12) & + / & + 0.2845D+03, 0.2848D+03, 0.2856D+03, 0.2866D+03, & + 0.2874D+03, 0.2878D+03, 0.2874D+03, 0.2877D+03, & + 0.2875D+03, 0.2870D+03, 0.2862D+03, 0.2853D+03 & + / + data (TREF( 2,12, mtmp), mtmp=1,12) & + / & + 0.2795D+03, 0.2798D+03, 0.2810D+03, 0.2832D+03, & + 0.2853D+03, 0.2873D+03, 0.2878D+03, 0.2880D+03, & + 0.2871D+03, 0.2853D+03, 0.2830D+03, 0.2808D+03 & + / + data (TREF( 2,13, mtmp), mtmp=1,12) & + / & + 0.2719D+03, 0.2720D+03, 0.2739D+03, 0.2773D+03, & + 0.2808D+03, 0.2843D+03, 0.2863D+03, 0.2864D+03, & + 0.2843D+03, 0.2808D+03, 0.2769D+03, 0.2736D+03 & + / + data (TREF( 2,14, mtmp), mtmp=1,12) & + / & + 0.2636D+03, 0.2637D+03, 0.2660D+03, 0.2704D+03, & + 0.2748D+03, 0.2790D+03, 0.2820D+03, 0.2819D+03, & + 0.2784D+03, 0.2736D+03, 0.2687D+03, 0.2654D+03 & + / + data (TREF( 2,15, mtmp), mtmp=1,12) & + / & + 0.2569D+03, 0.2571D+03, 0.2592D+03, 0.2638D+03, & + 0.2689D+03, 0.2739D+03, 0.2770D+03, 0.2763D+03, & + 0.2717D+03, 0.2664D+03, 0.2613D+03, 0.2583D+03 & + / + data (TREF( 2,16, mtmp), mtmp=1,12) & + / & + 0.2522D+03, 0.2522D+03, 0.2536D+03, 0.2575D+03, & + 0.2636D+03, 0.2698D+03, 0.2731D+03, 0.2716D+03, & + 0.2666D+03, 0.2607D+03, 0.2557D+03, 0.2530D+03 & + / + data (TREF( 2,17, mtmp), mtmp=1,12) & + / & + 0.2483D+03, 0.2477D+03, 0.2488D+03, 0.2516D+03, & + 0.2585D+03, 0.2653D+03, 0.2690D+03, 0.2670D+03, & + 0.2618D+03, 0.2557D+03, 0.2510D+03, 0.2490D+03 & + / + data (TREF( 2,18, mtmp), mtmp=1,12) & + / & + 0.2458D+03, 0.2451D+03, 0.2468D+03, 0.2488D+03, & + 0.2560D+03, 0.2621D+03, 0.2657D+03, 0.2638D+03, & + 0.2586D+03, 0.2522D+03, 0.2481D+03, 0.2472D+03 & + / + data (TREF( 3, 1, mtmp), mtmp=1,12) & + / & + 0.2419D+03, 0.2397D+03, 0.2391D+03, 0.2368D+03, & + 0.2358D+03, 0.2336D+03, 0.2340D+03, 0.2327D+03, & + 0.2328D+03, 0.2338D+03, 0.2381D+03, 0.2404D+03 & + / + data (TREF( 3, 2, mtmp), mtmp=1,12) & + / & + 0.2458D+03, 0.2443D+03, 0.2425D+03, 0.2403D+03, & + 0.2394D+03, 0.2374D+03, 0.2371D+03, 0.2364D+03, & + 0.2368D+03, 0.2380D+03, 0.2416D+03, 0.2444D+03 & + / + data (TREF( 3, 3, mtmp), mtmp=1,12) & + / & + 0.2502D+03, 0.2497D+03, 0.2483D+03, 0.2462D+03, & + 0.2450D+03, 0.2434D+03, 0.2425D+03, 0.2421D+03, & + 0.2429D+03, 0.2441D+03, 0.2467D+03, 0.2489D+03 & + / + data (TREF( 3, 4, mtmp), mtmp=1,12) & + / & + 0.2546D+03, 0.2550D+03, 0.2543D+03, 0.2521D+03, & + 0.2502D+03, 0.2487D+03, 0.2480D+03, 0.2476D+03, & + 0.2484D+03, 0.2499D+03, 0.2518D+03, 0.2532D+03 & + / + data (TREF( 3, 5, mtmp), mtmp=1,12) & + / & + 0.2608D+03, 0.2616D+03, 0.2608D+03, 0.2584D+03, & + 0.2558D+03, 0.2541D+03, 0.2535D+03, 0.2533D+03, & + 0.2540D+03, 0.2557D+03, 0.2577D+03, 0.2593D+03 & + / + data (TREF( 3, 6, mtmp), mtmp=1,12) & + / & + 0.2672D+03, 0.2678D+03, 0.2669D+03, 0.2645D+03, & + 0.2622D+03, 0.2605D+03, 0.2597D+03, 0.2597D+03, & + 0.2603D+03, 0.2619D+03, 0.2638D+03, 0.2657D+03 & + / + data (TREF( 3, 7, mtmp), mtmp=1,12) & + / & + 0.2714D+03, 0.2718D+03, 0.2713D+03, 0.2698D+03, & + 0.2684D+03, 0.2672D+03, 0.2667D+03, 0.2667D+03, & + 0.2671D+03, 0.2681D+03, 0.2692D+03, 0.2705D+03 & + / + data (TREF( 3, 8, mtmp), mtmp=1,12) & + / & + 0.2732D+03, 0.2734D+03, 0.2734D+03, 0.2731D+03, & + 0.2726D+03, 0.2720D+03, 0.2715D+03, 0.2717D+03, & + 0.2718D+03, 0.2722D+03, 0.2726D+03, 0.2731D+03 & + / + data (TREF( 3, 9, mtmp), mtmp=1,12) & + / & + 0.2735D+03, 0.2736D+03, 0.2738D+03, 0.2740D+03, & + 0.2740D+03, 0.2734D+03, 0.2728D+03, 0.2730D+03, & + 0.2731D+03, 0.2734D+03, 0.2735D+03, 0.2737D+03 & + / + data (TREF( 3,10, mtmp), mtmp=1,12) & + / & + 0.2733D+03, 0.2734D+03, 0.2737D+03, 0.2740D+03, & + 0.2742D+03, 0.2738D+03, 0.2731D+03, 0.2734D+03, & + 0.2734D+03, 0.2736D+03, 0.2736D+03, 0.2736D+03 & + / + data (TREF( 3,11, mtmp), mtmp=1,12) & + / & + 0.2718D+03, 0.2718D+03, 0.2722D+03, 0.2729D+03, & + 0.2736D+03, 0.2739D+03, 0.2736D+03, 0.2740D+03, & + 0.2737D+03, 0.2733D+03, 0.2728D+03, 0.2723D+03 & + / + data (TREF( 3,12, mtmp), mtmp=1,12) & + / & + 0.2667D+03, 0.2667D+03, 0.2675D+03, 0.2692D+03, & + 0.2711D+03, 0.2730D+03, 0.2734D+03, 0.2738D+03, & + 0.2729D+03, 0.2713D+03, 0.2695D+03, 0.2679D+03 & + / + data (TREF( 3,13, mtmp), mtmp=1,12) & + / & + 0.2587D+03, 0.2586D+03, 0.2602D+03, 0.2633D+03, & + 0.2665D+03, 0.2699D+03, 0.2718D+03, 0.2720D+03, & + 0.2700D+03, 0.2668D+03, 0.2633D+03, 0.2606D+03 & + / + data (TREF( 3,14, mtmp), mtmp=1,12) & + / & + 0.2513D+03, 0.2511D+03, 0.2530D+03, 0.2568D+03, & + 0.2608D+03, 0.2648D+03, 0.2678D+03, 0.2679D+03, & + 0.2645D+03, 0.2604D+03, 0.2559D+03, 0.2531D+03 & + / + data (TREF( 3,15, mtmp), mtmp=1,12) & + / & + 0.2460D+03, 0.2461D+03, 0.2474D+03, 0.2512D+03, & + 0.2556D+03, 0.2603D+03, 0.2635D+03, 0.2629D+03, & + 0.2587D+03, 0.2541D+03, 0.2497D+03, 0.2473D+03 & + / + data (TREF( 3,16, mtmp), mtmp=1,12) & + / & + 0.2421D+03, 0.2422D+03, 0.2430D+03, 0.2462D+03, & + 0.2514D+03, 0.2571D+03, 0.2602D+03, 0.2588D+03, & + 0.2541D+03, 0.2492D+03, 0.2451D+03, 0.2428D+03 & + / + data (TREF( 3,17, mtmp), mtmp=1,12) & + / & + 0.2388D+03, 0.2385D+03, 0.2394D+03, 0.2418D+03, & + 0.2477D+03, 0.2539D+03, 0.2572D+03, 0.2552D+03, & + 0.2504D+03, 0.2453D+03, 0.2413D+03, 0.2396D+03 & + / + data (TREF( 3,18, mtmp), mtmp=1,12) & + / & + 0.2364D+03, 0.2359D+03, 0.2375D+03, 0.2397D+03, & + 0.2456D+03, 0.2513D+03, 0.2547D+03, 0.2525D+03, & + 0.2477D+03, 0.2426D+03, 0.2386D+03, 0.2378D+03 & + / + data (TREF( 4, 1, mtmp), mtmp=1,12) & + / & + 0.2332D+03, 0.2318D+03, 0.2307D+03, 0.2284D+03, & + 0.2268D+03, 0.2243D+03, 0.2241D+03, 0.2230D+03, & + 0.2234D+03, 0.2242D+03, 0.2283D+03, 0.2315D+03 & + / + data (TREF( 4, 2, mtmp), mtmp=1,12) & + / & + 0.2356D+03, 0.2346D+03, 0.2328D+03, 0.2304D+03, & + 0.2291D+03, 0.2268D+03, 0.2261D+03, 0.2254D+03, & + 0.2260D+03, 0.2271D+03, 0.2308D+03, 0.2341D+03 & + / + data (TREF( 4, 3, mtmp), mtmp=1,12) & + / & + 0.2385D+03, 0.2383D+03, 0.2370D+03, 0.2346D+03, & + 0.2330D+03, 0.2311D+03, 0.2301D+03, 0.2295D+03, & + 0.2303D+03, 0.2318D+03, 0.2347D+03, 0.2371D+03 & + / + data (TREF( 4, 4, mtmp), mtmp=1,12) & + / & + 0.2420D+03, 0.2426D+03, 0.2418D+03, 0.2394D+03, & + 0.2373D+03, 0.2355D+03, 0.2347D+03, 0.2343D+03, & + 0.2352D+03, 0.2370D+03, 0.2392D+03, 0.2406D+03 & + / + data (TREF( 4, 5, mtmp), mtmp=1,12) & + / & + 0.2473D+03, 0.2481D+03, 0.2473D+03, 0.2447D+03, & + 0.2421D+03, 0.2403D+03, 0.2397D+03, 0.2396D+03, & + 0.2404D+03, 0.2423D+03, 0.2443D+03, 0.2458D+03 & + / + data (TREF( 4, 6, mtmp), mtmp=1,12) & + / & + 0.2529D+03, 0.2536D+03, 0.2526D+03, 0.2502D+03, & + 0.2479D+03, 0.2463D+03, 0.2457D+03, 0.2458D+03, & + 0.2464D+03, 0.2479D+03, 0.2497D+03, 0.2514D+03 & + / + data (TREF( 4, 7, mtmp), mtmp=1,12) & + / & + 0.2570D+03, 0.2575D+03, 0.2569D+03, 0.2554D+03, & + 0.2541D+03, 0.2533D+03, 0.2528D+03, 0.2530D+03, & + 0.2531D+03, 0.2538D+03, 0.2549D+03, 0.2561D+03 & + / + data (TREF( 4, 8, mtmp), mtmp=1,12) & + / & + 0.2590D+03, 0.2592D+03, 0.2592D+03, 0.2588D+03, & + 0.2584D+03, 0.2581D+03, 0.2576D+03, 0.2578D+03, & + 0.2578D+03, 0.2580D+03, 0.2583D+03, 0.2588D+03 & + / + data (TREF( 4, 9, mtmp), mtmp=1,12) & + / & + 0.2594D+03, 0.2595D+03, 0.2597D+03, 0.2599D+03, & + 0.2599D+03, 0.2595D+03, 0.2588D+03, 0.2590D+03, & + 0.2591D+03, 0.2594D+03, 0.2595D+03, 0.2596D+03 & + / + data (TREF( 4,10, mtmp), mtmp=1,12) & + / & + 0.2593D+03, 0.2593D+03, 0.2595D+03, 0.2599D+03, & + 0.2600D+03, 0.2597D+03, 0.2590D+03, 0.2593D+03, & + 0.2593D+03, 0.2595D+03, 0.2595D+03, 0.2595D+03 & + / + data (TREF( 4,11, mtmp), mtmp=1,12) & + / & + 0.2577D+03, 0.2578D+03, 0.2580D+03, 0.2584D+03, & + 0.2591D+03, 0.2595D+03, 0.2593D+03, 0.2597D+03, & + 0.2594D+03, 0.2590D+03, 0.2585D+03, 0.2581D+03 & + / + data (TREF( 4,12, mtmp), mtmp=1,12) & + / & + 0.2528D+03, 0.2527D+03, 0.2531D+03, 0.2543D+03, & + 0.2562D+03, 0.2583D+03, 0.2590D+03, 0.2593D+03, & + 0.2584D+03, 0.2567D+03, 0.2551D+03, 0.2537D+03 & + / + data (TREF( 4,13, mtmp), mtmp=1,12) & + / & + 0.2451D+03, 0.2449D+03, 0.2460D+03, 0.2485D+03, & + 0.2516D+03, 0.2551D+03, 0.2573D+03, 0.2574D+03, & + 0.2554D+03, 0.2522D+03, 0.2491D+03, 0.2468D+03 & + / + data (TREF( 4,14, mtmp), mtmp=1,12) & + / & + 0.2383D+03, 0.2380D+03, 0.2395D+03, 0.2428D+03, & + 0.2463D+03, 0.2502D+03, 0.2533D+03, 0.2534D+03, & + 0.2502D+03, 0.2464D+03, 0.2424D+03, 0.2400D+03 & + / + data (TREF( 4,15, mtmp), mtmp=1,12) & + / & + 0.2337D+03, 0.2338D+03, 0.2349D+03, 0.2382D+03, & + 0.2419D+03, 0.2461D+03, 0.2492D+03, 0.2487D+03, & + 0.2448D+03, 0.2409D+03, 0.2370D+03, 0.2349D+03 & + / + data (TREF( 4,16, mtmp), mtmp=1,12) & + / & + 0.2303D+03, 0.2306D+03, 0.2315D+03, 0.2346D+03, & + 0.2387D+03, 0.2435D+03, 0.2463D+03, 0.2450D+03, & + 0.2408D+03, 0.2367D+03, 0.2331D+03, 0.2311D+03 & + / + data (TREF( 4,17, mtmp), mtmp=1,12) & + / & + 0.2276D+03, 0.2277D+03, 0.2289D+03, 0.2316D+03, & + 0.2363D+03, 0.2414D+03, 0.2442D+03, 0.2423D+03, & + 0.2380D+03, 0.2338D+03, 0.2301D+03, 0.2284D+03 & + / + data (TREF( 4,18, mtmp), mtmp=1,12) & + / & + 0.2256D+03, 0.2254D+03, 0.2273D+03, 0.2301D+03, & + 0.2349D+03, 0.2399D+03, 0.2427D+03, 0.2405D+03, & + 0.2361D+03, 0.2321D+03, 0.2280D+03, 0.2269D+03 & + / + data (TREF( 5, 1, mtmp), mtmp=1,12) & + / & + 0.2280D+03, 0.2273D+03, 0.2246D+03, 0.2217D+03, & + 0.2186D+03, 0.2155D+03, 0.2142D+03, 0.2132D+03, & + 0.2137D+03, 0.2148D+03, 0.2197D+03, 0.2255D+03 & + / + data (TREF( 5, 2, mtmp), mtmp=1,12) & + / & + 0.2286D+03, 0.2282D+03, 0.2259D+03, 0.2228D+03, & + 0.2200D+03, 0.2171D+03, 0.2154D+03, 0.2145D+03, & + 0.2152D+03, 0.2167D+03, 0.2215D+03, 0.2265D+03 & + / + data (TREF( 5, 3, mtmp), mtmp=1,12) & + / & + 0.2301D+03, 0.2301D+03, 0.2287D+03, 0.2258D+03, & + 0.2232D+03, 0.2207D+03, 0.2190D+03, 0.2181D+03, & + 0.2190D+03, 0.2213D+03, 0.2252D+03, 0.2284D+03 & + / + data (TREF( 5, 4, mtmp), mtmp=1,12) & + / & + 0.2319D+03, 0.2323D+03, 0.2314D+03, 0.2289D+03, & + 0.2265D+03, 0.2245D+03, 0.2234D+03, 0.2229D+03, & + 0.2240D+03, 0.2264D+03, 0.2290D+03, 0.2305D+03 & + / + data (TREF( 5, 5, mtmp), mtmp=1,12) & + / & + 0.2347D+03, 0.2354D+03, 0.2345D+03, 0.2321D+03, & + 0.2299D+03, 0.2283D+03, 0.2278D+03, 0.2279D+03, & + 0.2289D+03, 0.2307D+03, 0.2324D+03, 0.2334D+03 & + / + data (TREF( 5, 6, mtmp), mtmp=1,12) & + / & + 0.2388D+03, 0.2395D+03, 0.2386D+03, 0.2363D+03, & + 0.2345D+03, 0.2335D+03, 0.2332D+03, 0.2335D+03, & + 0.2340D+03, 0.2351D+03, 0.2363D+03, 0.2375D+03 & + / + data (TREF( 5, 7, mtmp), mtmp=1,12) & + / & + 0.2426D+03, 0.2431D+03, 0.2425D+03, 0.2410D+03, & + 0.2401D+03, 0.2396D+03, 0.2393D+03, 0.2396D+03, & + 0.2396D+03, 0.2400D+03, 0.2407D+03, 0.2416D+03 & + / + data (TREF( 5, 8, mtmp), mtmp=1,12) & + / & + 0.2444D+03, 0.2446D+03, 0.2446D+03, 0.2443D+03, & + 0.2440D+03, 0.2438D+03, 0.2432D+03, 0.2435D+03, & + 0.2434D+03, 0.2436D+03, 0.2438D+03, 0.2441D+03 & + / + data (TREF( 5, 9, mtmp), mtmp=1,12) & + / & + 0.2447D+03, 0.2448D+03, 0.2451D+03, 0.2453D+03, & + 0.2454D+03, 0.2450D+03, 0.2442D+03, 0.2445D+03, & + 0.2445D+03, 0.2448D+03, 0.2448D+03, 0.2449D+03 & + / + data (TREF( 5,10, mtmp), mtmp=1,12) & + / & + 0.2446D+03, 0.2447D+03, 0.2449D+03, 0.2453D+03, & + 0.2454D+03, 0.2452D+03, 0.2445D+03, 0.2447D+03, & + 0.2447D+03, 0.2449D+03, 0.2448D+03, 0.2448D+03 & + / + data (TREF( 5,11, mtmp), mtmp=1,12) & + / & + 0.2433D+03, 0.2434D+03, 0.2435D+03, 0.2437D+03, & + 0.2444D+03, 0.2450D+03, 0.2448D+03, 0.2451D+03, & + 0.2447D+03, 0.2442D+03, 0.2437D+03, 0.2433D+03 & + / + data (TREF( 5,12, mtmp), mtmp=1,12) & + / & + 0.2392D+03, 0.2392D+03, 0.2392D+03, 0.2398D+03, & + 0.2415D+03, 0.2438D+03, 0.2447D+03, 0.2449D+03, & + 0.2438D+03, 0.2421D+03, 0.2407D+03, 0.2397D+03 & + / + data (TREF( 5,13, mtmp), mtmp=1,12) & + / & + 0.2328D+03, 0.2325D+03, 0.2329D+03, 0.2346D+03, & + 0.2372D+03, 0.2407D+03, 0.2432D+03, 0.2431D+03, & + 0.2410D+03, 0.2381D+03, 0.2355D+03, 0.2339D+03 & + / + data (TREF( 5,14, mtmp), mtmp=1,12) & + / & + 0.2271D+03, 0.2269D+03, 0.2277D+03, 0.2301D+03, & + 0.2330D+03, 0.2364D+03, 0.2395D+03, 0.2393D+03, & + 0.2365D+03, 0.2333D+03, 0.2301D+03, 0.2284D+03 & + / + data (TREF( 5,15, mtmp), mtmp=1,12) & + / & + 0.2234D+03, 0.2235D+03, 0.2247D+03, 0.2273D+03, & + 0.2301D+03, 0.2333D+03, 0.2358D+03, 0.2352D+03, & + 0.2321D+03, 0.2293D+03, 0.2261D+03, 0.2245D+03 & + / + data (TREF( 5,16, mtmp), mtmp=1,12) & + / & + 0.2204D+03, 0.2210D+03, 0.2227D+03, 0.2257D+03, & + 0.2287D+03, 0.2320D+03, 0.2339D+03, 0.2326D+03, & + 0.2293D+03, 0.2263D+03, 0.2233D+03, 0.2214D+03 & + / + data (TREF( 5,17, mtmp), mtmp=1,12) & + / & + 0.2183D+03, 0.2189D+03, 0.2213D+03, 0.2250D+03, & + 0.2285D+03, 0.2320D+03, 0.2335D+03, 0.2317D+03, & + 0.2281D+03, 0.2246D+03, 0.2213D+03, 0.2193D+03 & + / + data (TREF( 5,18, mtmp), mtmp=1,12) & + / & + 0.2167D+03, 0.2169D+03, 0.2199D+03, 0.2242D+03, & + 0.2282D+03, 0.2322D+03, 0.2338D+03, 0.2315D+03, & + 0.2277D+03, 0.2241D+03, 0.2198D+03, 0.2180D+03 & + / + data (TREF( 6, 1, mtmp), mtmp=1,12) & + / & + 0.2278D+03, 0.2276D+03, 0.2232D+03, 0.2187D+03, & + 0.2137D+03, 0.2095D+03, 0.2065D+03, 0.2052D+03, & + 0.2058D+03, 0.2077D+03, 0.2147D+03, 0.2248D+03 & + / + data (TREF( 6, 2, mtmp), mtmp=1,12) & + / & + 0.2268D+03, 0.2267D+03, 0.2238D+03, 0.2194D+03, & + 0.2147D+03, 0.2106D+03, 0.2074D+03, 0.2061D+03, & + 0.2067D+03, 0.2095D+03, 0.2162D+03, 0.2242D+03 & + / + data (TREF( 6, 3, mtmp), mtmp=1,12) & + / & + 0.2270D+03, 0.2270D+03, 0.2251D+03, 0.2216D+03, & + 0.2177D+03, 0.2142D+03, 0.2115D+03, 0.2101D+03, & + 0.2112D+03, 0.2149D+03, 0.2203D+03, 0.2250D+03 & + / + data (TREF( 6, 4, mtmp), mtmp=1,12) & + / & + 0.2262D+03, 0.2263D+03, 0.2250D+03, 0.2225D+03, & + 0.2200D+03, 0.2177D+03, 0.2162D+03, 0.2156D+03, & + 0.2170D+03, 0.2202D+03, 0.2232D+03, 0.2249D+03 & + / + data (TREF( 6, 5, mtmp), mtmp=1,12) & + / & + 0.2253D+03, 0.2257D+03, 0.2249D+03, 0.2229D+03, & + 0.2215D+03, 0.2204D+03, 0.2201D+03, 0.2204D+03, & + 0.2214D+03, 0.2232D+03, 0.2241D+03, 0.2246D+03 & + / + data (TREF( 6, 6, mtmp), mtmp=1,12) & + / & + 0.2267D+03, 0.2272D+03, 0.2265D+03, 0.2249D+03, & + 0.2239D+03, 0.2236D+03, 0.2238D+03, 0.2244D+03, & + 0.2247D+03, 0.2252D+03, 0.2255D+03, 0.2259D+03 & + / + data (TREF( 6, 7, mtmp), mtmp=1,12) & + / & + 0.2289D+03, 0.2293D+03, 0.2289D+03, 0.2280D+03, & + 0.2274D+03, 0.2274D+03, 0.2273D+03, 0.2278D+03, & + 0.2276D+03, 0.2277D+03, 0.2278D+03, 0.2282D+03 & + / + data (TREF( 6, 8, mtmp), mtmp=1,12) & + / & + 0.2301D+03, 0.2302D+03, 0.2303D+03, 0.2302D+03, & + 0.2301D+03, 0.2300D+03, 0.2295D+03, 0.2298D+03, & + 0.2296D+03, 0.2296D+03, 0.2296D+03, 0.2299D+03 & + / + data (TREF( 6, 9, mtmp), mtmp=1,12) & + / & + 0.2302D+03, 0.2303D+03, 0.2306D+03, 0.2309D+03, & + 0.2310D+03, 0.2308D+03, 0.2301D+03, 0.2303D+03, & + 0.2302D+03, 0.2303D+03, 0.2303D+03, 0.2303D+03 & + / + data (TREF( 6,10, mtmp), mtmp=1,12) & + / & + 0.2301D+03, 0.2302D+03, 0.2304D+03, 0.2307D+03, & + 0.2309D+03, 0.2309D+03, 0.2302D+03, 0.2304D+03, & + 0.2303D+03, 0.2303D+03, 0.2302D+03, 0.2301D+03 & + / + data (TREF( 6,11, mtmp), mtmp=1,12) & + / & + 0.2292D+03, 0.2294D+03, 0.2295D+03, 0.2296D+03, & + 0.2301D+03, 0.2306D+03, 0.2305D+03, 0.2307D+03, & + 0.2301D+03, 0.2297D+03, 0.2292D+03, 0.2290D+03 & + / + data (TREF( 6,12, mtmp), mtmp=1,12) & + / & + 0.2270D+03, 0.2271D+03, 0.2269D+03, 0.2269D+03, & + 0.2280D+03, 0.2299D+03, 0.2308D+03, 0.2309D+03, & + 0.2297D+03, 0.2283D+03, 0.2273D+03, 0.2269D+03 & + / + data (TREF( 6,13, mtmp), mtmp=1,12) & + / & + 0.2234D+03, 0.2234D+03, 0.2230D+03, 0.2235D+03, & + 0.2252D+03, 0.2281D+03, 0.2303D+03, 0.2301D+03, & + 0.2282D+03, 0.2260D+03, 0.2243D+03, 0.2236D+03 & + / + data (TREF( 6,14, mtmp), mtmp=1,12) & + / & + 0.2202D+03, 0.2203D+03, 0.2204D+03, 0.2214D+03, & + 0.2234D+03, 0.2259D+03, 0.2283D+03, 0.2279D+03, & + 0.2257D+03, 0.2235D+03, 0.2215D+03, 0.2207D+03 & + / + data (TREF( 6,15, mtmp), mtmp=1,12) & + / & + 0.2175D+03, 0.2180D+03, 0.2193D+03, 0.2210D+03, & + 0.2231D+03, 0.2250D+03, 0.2266D+03, 0.2259D+03, & + 0.2237D+03, 0.2218D+03, 0.2196D+03, 0.2184D+03 & + / + data (TREF( 6,16, mtmp), mtmp=1,12) & + / & + 0.2149D+03, 0.2159D+03, 0.2187D+03, 0.2218D+03, & + 0.2241D+03, 0.2258D+03, 0.2267D+03, 0.2254D+03, & + 0.2230D+03, 0.2208D+03, 0.2180D+03, 0.2161D+03 & + / + data (TREF( 6,17, mtmp), mtmp=1,12) & + / & + 0.2130D+03, 0.2143D+03, 0.2183D+03, 0.2231D+03, & + 0.2260D+03, 0.2280D+03, 0.2284D+03, 0.2266D+03, & + 0.2236D+03, 0.2203D+03, 0.2170D+03, 0.2143D+03 & + / + data (TREF( 6,18, mtmp), mtmp=1,12) & + / & + 0.2115D+03, 0.2124D+03, 0.2170D+03, 0.2227D+03, & + 0.2265D+03, 0.2295D+03, 0.2301D+03, 0.2279D+03, & + 0.2244D+03, 0.2204D+03, 0.2160D+03, 0.2129D+03 & + / + data (TREF( 7, 1, mtmp), mtmp=1,12) & + / & + 0.2303D+03, 0.2299D+03, 0.2246D+03, 0.2184D+03, & + 0.2117D+03, 0.2062D+03, 0.2016D+03, 0.1997D+03, & + 0.2003D+03, 0.2040D+03, 0.2138D+03, 0.2273D+03 & + / + data (TREF( 7, 2, mtmp), mtmp=1,12) & + / & + 0.2286D+03, 0.2282D+03, 0.2247D+03, 0.2192D+03, & + 0.2128D+03, 0.2074D+03, 0.2028D+03, 0.2009D+03, & + 0.2017D+03, 0.2065D+03, 0.2157D+03, 0.2261D+03 & + / + data (TREF( 7, 3, mtmp), mtmp=1,12) & + / & + 0.2276D+03, 0.2273D+03, 0.2249D+03, 0.2209D+03, & + 0.2161D+03, 0.2115D+03, 0.2079D+03, 0.2061D+03, & + 0.2076D+03, 0.2131D+03, 0.2200D+03, 0.2259D+03 & + / + data (TREF( 7, 4, mtmp), mtmp=1,12) & + / & + 0.2248D+03, 0.2244D+03, 0.2228D+03, 0.2204D+03, & + 0.2181D+03, 0.2153D+03, 0.2135D+03, 0.2129D+03, & + 0.2147D+03, 0.2187D+03, 0.2218D+03, 0.2238D+03 & + / + data (TREF( 7, 5, mtmp), mtmp=1,12) & + / & + 0.2204D+03, 0.2202D+03, 0.2195D+03, 0.2184D+03, & + 0.2178D+03, 0.2171D+03, 0.2169D+03, 0.2175D+03, & + 0.2186D+03, 0.2201D+03, 0.2203D+03, 0.2202D+03 & + / + data (TREF( 7, 6, mtmp), mtmp=1,12) & + / & + 0.2178D+03, 0.2179D+03, 0.2177D+03, 0.2172D+03, & + 0.2171D+03, 0.2175D+03, 0.2180D+03, 0.2187D+03, & + 0.2190D+03, 0.2189D+03, 0.2183D+03, 0.2178D+03 & + / + data (TREF( 7, 7, mtmp), mtmp=1,12) & + / & + 0.2170D+03, 0.2171D+03, 0.2171D+03, 0.2170D+03, & + 0.2170D+03, 0.2174D+03, 0.2176D+03, 0.2181D+03, & + 0.2179D+03, 0.2176D+03, 0.2170D+03, 0.2169D+03 & + / + data (TREF( 7, 8, mtmp), mtmp=1,12) & + / & + 0.2165D+03, 0.2166D+03, 0.2168D+03, 0.2169D+03, & + 0.2171D+03, 0.2172D+03, 0.2170D+03, 0.2173D+03, & + 0.2171D+03, 0.2168D+03, 0.2165D+03, 0.2165D+03 & + / + data (TREF( 7, 9, mtmp), mtmp=1,12) & + / & + 0.2163D+03, 0.2164D+03, 0.2166D+03, 0.2168D+03, & + 0.2171D+03, 0.2173D+03, 0.2170D+03, 0.2172D+03, & + 0.2170D+03, 0.2167D+03, 0.2163D+03, 0.2163D+03 & + / + data (TREF( 7,10, mtmp), mtmp=1,12) & + / & + 0.2162D+03, 0.2163D+03, 0.2165D+03, 0.2167D+03, & + 0.2170D+03, 0.2172D+03, 0.2169D+03, 0.2171D+03, & + 0.2168D+03, 0.2165D+03, 0.2162D+03, 0.2161D+03 & + / + data (TREF( 7,11, mtmp), mtmp=1,12) & + / & + 0.2161D+03, 0.2163D+03, 0.2163D+03, 0.2164D+03, & + 0.2167D+03, 0.2171D+03, 0.2172D+03, 0.2173D+03, & + 0.2168D+03, 0.2162D+03, 0.2158D+03, 0.2158D+03 & + / + data (TREF( 7,12, mtmp), mtmp=1,12) & + / & + 0.2166D+03, 0.2168D+03, 0.2165D+03, 0.2163D+03, & + 0.2166D+03, 0.2176D+03, 0.2182D+03, 0.2182D+03, & + 0.2172D+03, 0.2164D+03, 0.2158D+03, 0.2160D+03 & + / + data (TREF( 7,13, mtmp), mtmp=1,12) & + / & + 0.2175D+03, 0.2178D+03, 0.2171D+03, 0.2167D+03, & + 0.2172D+03, 0.2187D+03, 0.2198D+03, 0.2195D+03, & + 0.2182D+03, 0.2170D+03, 0.2165D+03, 0.2169D+03 & + / + data (TREF( 7,14, mtmp), mtmp=1,12) & + / & + 0.2178D+03, 0.2183D+03, 0.2180D+03, 0.2179D+03, & + 0.2190D+03, 0.2204D+03, 0.2215D+03, 0.2209D+03, & + 0.2194D+03, 0.2181D+03, 0.2173D+03, 0.2175D+03 & + / + data (TREF( 7,15, mtmp), mtmp=1,12) & + / & + 0.2162D+03, 0.2172D+03, 0.2186D+03, 0.2196D+03, & + 0.2212D+03, 0.2225D+03, 0.2232D+03, 0.2223D+03, & + 0.2207D+03, 0.2192D+03, 0.2176D+03, 0.2168D+03 & + / + data (TREF( 7,16, mtmp), mtmp=1,12) & + / & + 0.2135D+03, 0.2150D+03, 0.2187D+03, 0.2218D+03, & + 0.2239D+03, 0.2250D+03, 0.2254D+03, 0.2241D+03, & + 0.2220D+03, 0.2198D+03, 0.2170D+03, 0.2148D+03 & + / + data (TREF( 7,17, mtmp), mtmp=1,12) & + / & + 0.2112D+03, 0.2133D+03, 0.2185D+03, 0.2239D+03, & + 0.2267D+03, 0.2282D+03, 0.2283D+03, 0.2266D+03, & + 0.2236D+03, 0.2201D+03, 0.2163D+03, 0.2128D+03 & + / + data (TREF( 7,18, mtmp), mtmp=1,12) & + / & + 0.2096D+03, 0.2112D+03, 0.2174D+03, 0.2238D+03, & + 0.2275D+03, 0.2300D+03, 0.2302D+03, 0.2282D+03, & + 0.2246D+03, 0.2201D+03, 0.2153D+03, 0.2110D+03 & + / + data (TREF( 8, 1, mtmp), mtmp=1,12) & + / & + 0.2323D+03, 0.2313D+03, 0.2257D+03, 0.2180D+03, & + 0.2102D+03, 0.2037D+03, 0.1981D+03, 0.1960D+03, & + 0.1969D+03, 0.2025D+03, 0.2154D+03, 0.2304D+03 & + / + data (TREF( 8, 2, mtmp), mtmp=1,12) & + / & + 0.2306D+03, 0.2296D+03, 0.2256D+03, 0.2192D+03, & + 0.2117D+03, 0.2053D+03, 0.2000D+03, 0.1978D+03, & + 0.1991D+03, 0.2059D+03, 0.2177D+03, 0.2290D+03 & + / + data (TREF( 8, 3, mtmp), mtmp=1,12) & + / & + 0.2290D+03, 0.2281D+03, 0.2252D+03, 0.2209D+03, & + 0.2154D+03, 0.2101D+03, 0.2058D+03, 0.2040D+03, & + 0.2062D+03, 0.2134D+03, 0.2217D+03, 0.2279D+03 & + / + data (TREF( 8, 4, mtmp), mtmp=1,12) & + / & + 0.2249D+03, 0.2241D+03, 0.2222D+03, 0.2200D+03, & + 0.2177D+03, 0.2147D+03, 0.2126D+03, 0.2122D+03, & + 0.2143D+03, 0.2191D+03, 0.2223D+03, 0.2244D+03 & + / + data (TREF( 8, 5, mtmp), mtmp=1,12) & + / & + 0.2183D+03, 0.2177D+03, 0.2171D+03, 0.2166D+03, & + 0.2167D+03, 0.2161D+03, 0.2160D+03, 0.2167D+03, & + 0.2179D+03, 0.2193D+03, 0.2189D+03, 0.2186D+03 & + / + data (TREF( 8, 6, mtmp), mtmp=1,12) & + / & + 0.2121D+03, 0.2118D+03, 0.2120D+03, 0.2126D+03, & + 0.2134D+03, 0.2140D+03, 0.2146D+03, 0.2154D+03, & + 0.2158D+03, 0.2154D+03, 0.2140D+03, 0.2129D+03 & + / + data (TREF( 8, 7, mtmp), mtmp=1,12) & + / & + 0.2076D+03, 0.2074D+03, 0.2078D+03, 0.2086D+03, & + 0.2091D+03, 0.2098D+03, 0.2104D+03, 0.2109D+03, & + 0.2108D+03, 0.2101D+03, 0.2090D+03, 0.2082D+03 & + / + data (TREF( 8, 8, mtmp), mtmp=1,12) & + / & + 0.2049D+03, 0.2049D+03, 0.2051D+03, 0.2055D+03, & + 0.2059D+03, 0.2065D+03, 0.2068D+03, 0.2072D+03, & + 0.2070D+03, 0.2063D+03, 0.2054D+03, 0.2050D+03 & + / + data (TREF( 8, 9, mtmp), mtmp=1,12) & + / & + 0.2040D+03, 0.2041D+03, 0.2042D+03, 0.2044D+03, & + 0.2048D+03, 0.2056D+03, 0.2059D+03, 0.2062D+03, & + 0.2060D+03, 0.2051D+03, 0.2043D+03, 0.2039D+03 & + / + data (TREF( 8,10, mtmp), mtmp=1,12) & + / & + 0.2040D+03, 0.2041D+03, 0.2042D+03, 0.2043D+03, & + 0.2047D+03, 0.2055D+03, 0.2059D+03, 0.2061D+03, & + 0.2058D+03, 0.2050D+03, 0.2042D+03, 0.2039D+03 & + / + data (TREF( 8,11, mtmp), mtmp=1,12) & + / & + 0.2049D+03, 0.2050D+03, 0.2050D+03, 0.2052D+03, & + 0.2054D+03, 0.2059D+03, 0.2064D+03, 0.2064D+03, & + 0.2061D+03, 0.2053D+03, 0.2047D+03, 0.2046D+03 & + / + data (TREF( 8,12, mtmp), mtmp=1,12) & + / & + 0.2084D+03, 0.2085D+03, 0.2083D+03, 0.2083D+03, & + 0.2081D+03, 0.2081D+03, 0.2084D+03, 0.2085D+03, & + 0.2079D+03, 0.2074D+03, 0.2071D+03, 0.2077D+03 & + / + data (TREF( 8,13, mtmp), mtmp=1,12) & + / & + 0.2139D+03, 0.2143D+03, 0.2136D+03, 0.2129D+03, & + 0.2128D+03, 0.2126D+03, 0.2125D+03, 0.2123D+03, & + 0.2117D+03, 0.2115D+03, 0.2116D+03, 0.2127D+03 & + / + data (TREF( 8,14, mtmp), mtmp=1,12) & + / & + 0.2172D+03, 0.2180D+03, 0.2176D+03, 0.2170D+03, & + 0.2176D+03, 0.2181D+03, 0.2179D+03, 0.2172D+03, & + 0.2164D+03, 0.2157D+03, 0.2157D+03, 0.2163D+03 & + / + data (TREF( 8,15, mtmp), mtmp=1,12) & + / & + 0.2163D+03, 0.2176D+03, 0.2191D+03, 0.2198D+03, & + 0.2212D+03, 0.2222D+03, 0.2225D+03, 0.2215D+03, & + 0.2201D+03, 0.2185D+03, 0.2172D+03, 0.2165D+03 & + / + data (TREF( 8,16, mtmp), mtmp=1,12) & + / & + 0.2131D+03, 0.2153D+03, 0.2194D+03, 0.2224D+03, & + 0.2243D+03, 0.2254D+03, 0.2259D+03, 0.2247D+03, & + 0.2224D+03, 0.2198D+03, 0.2168D+03, 0.2144D+03 & + / + data (TREF( 8,17, mtmp), mtmp=1,12) & + / & + 0.2102D+03, 0.2129D+03, 0.2192D+03, 0.2247D+03, & + 0.2272D+03, 0.2288D+03, 0.2292D+03, 0.2276D+03, & + 0.2243D+03, 0.2202D+03, 0.2159D+03, 0.2117D+03 & + / + data (TREF( 8,18, mtmp), mtmp=1,12) & + / & + 0.2082D+03, 0.2108D+03, 0.2183D+03, 0.2250D+03, & + 0.2283D+03, 0.2307D+03, 0.2310D+03, 0.2292D+03, & + 0.2251D+03, 0.2200D+03, 0.2148D+03, 0.2096D+03 & + / + data (TREF( 9, 1, mtmp), mtmp=1,12) & + / & + 0.2334D+03, 0.2315D+03, 0.2254D+03, 0.2165D+03, & + 0.2072D+03, 0.2002D+03, 0.1943D+03, 0.1924D+03, & + 0.1941D+03, 0.2020D+03, 0.2184D+03, 0.2332D+03 & + / + data (TREF( 9, 2, mtmp), mtmp=1,12) & + / & + 0.2319D+03, 0.2301D+03, 0.2254D+03, 0.2180D+03, & + 0.2093D+03, 0.2024D+03, 0.1967D+03, 0.1946D+03, & + 0.1969D+03, 0.2059D+03, 0.2204D+03, 0.2314D+03 & + / + data (TREF( 9, 3, mtmp), mtmp=1,12) & + / & + 0.2298D+03, 0.2282D+03, 0.2248D+03, 0.2199D+03, & + 0.2138D+03, 0.2080D+03, 0.2035D+03, 0.2019D+03, & + 0.2050D+03, 0.2138D+03, 0.2234D+03, 0.2293D+03 & + / + data (TREF( 9, 4, mtmp), mtmp=1,12) & + / & + 0.2252D+03, 0.2239D+03, 0.2217D+03, 0.2194D+03, & + 0.2171D+03, 0.2138D+03, 0.2115D+03, 0.2114D+03, & + 0.2142D+03, 0.2196D+03, 0.2230D+03, 0.2249D+03 & + / + data (TREF( 9, 5, mtmp), mtmp=1,12) & + / & + 0.2177D+03, 0.2167D+03, 0.2161D+03, 0.2159D+03, & + 0.2163D+03, 0.2156D+03, 0.2153D+03, 0.2163D+03, & + 0.2177D+03, 0.2192D+03, 0.2186D+03, 0.2181D+03 & + / + data (TREF( 9, 6, mtmp), mtmp=1,12) & + / & + 0.2095D+03, 0.2090D+03, 0.2094D+03, 0.2105D+03, & + 0.2117D+03, 0.2124D+03, 0.2130D+03, 0.2139D+03, & + 0.2144D+03, 0.2139D+03, 0.2121D+03, 0.2106D+03 & + / + data (TREF( 9, 7, mtmp), mtmp=1,12) & + / & + 0.2027D+03, 0.2024D+03, 0.2031D+03, 0.2042D+03, & + 0.2052D+03, 0.2061D+03, 0.2070D+03, 0.2076D+03, & + 0.2076D+03, 0.2067D+03, 0.2051D+03, 0.2038D+03 & + / + data (TREF( 9, 8, mtmp), mtmp=1,12) & + / & + 0.1985D+03, 0.1985D+03, 0.1988D+03, 0.1993D+03, & + 0.2001D+03, 0.2011D+03, 0.2021D+03, 0.2026D+03, & + 0.2024D+03, 0.2013D+03, 0.1999D+03, 0.1990D+03 & + / + data (TREF( 9, 9, mtmp), mtmp=1,12) & + / & + 0.1971D+03, 0.1972D+03, 0.1973D+03, 0.1975D+03, & + 0.1982D+03, 0.1995D+03, 0.2006D+03, 0.2011D+03, & + 0.2008D+03, 0.1995D+03, 0.1981D+03, 0.1972D+03 & + / + data (TREF( 9,10, mtmp), mtmp=1,12) & + / & + 0.1971D+03, 0.1972D+03, 0.1973D+03, 0.1975D+03, & + 0.1982D+03, 0.1994D+03, 0.2006D+03, 0.2010D+03, & + 0.2007D+03, 0.1994D+03, 0.1981D+03, 0.1972D+03 & + / + data (TREF( 9,11, mtmp), mtmp=1,12) & + / & + 0.1984D+03, 0.1984D+03, 0.1985D+03, 0.1989D+03, & + 0.1994D+03, 0.2003D+03, 0.2013D+03, 0.2015D+03, & + 0.2012D+03, 0.2001D+03, 0.1990D+03, 0.1985D+03 & + / + data (TREF( 9,12, mtmp), mtmp=1,12) & + / & + 0.2035D+03, 0.2035D+03, 0.2034D+03, 0.2037D+03, & + 0.2037D+03, 0.2034D+03, 0.2039D+03, 0.2041D+03, & + 0.2038D+03, 0.2033D+03, 0.2027D+03, 0.2030D+03 & + / + data (TREF( 9,13, mtmp), mtmp=1,12) & + / & + 0.2114D+03, 0.2117D+03, 0.2112D+03, 0.2107D+03, & + 0.2105D+03, 0.2096D+03, 0.2091D+03, 0.2091D+03, & + 0.2089D+03, 0.2089D+03, 0.2091D+03, 0.2101D+03 & + / + data (TREF( 9,14, mtmp), mtmp=1,12) & + / & + 0.2164D+03, 0.2172D+03, 0.2169D+03, 0.2162D+03, & + 0.2167D+03, 0.2167D+03, 0.2160D+03, 0.2155D+03, & + 0.2150D+03, 0.2144D+03, 0.2145D+03, 0.2151D+03 & + / + data (TREF( 9,15, mtmp), mtmp=1,12) & + / & + 0.2158D+03, 0.2175D+03, 0.2190D+03, 0.2194D+03, & + 0.2208D+03, 0.2218D+03, 0.2219D+03, 0.2210D+03, & + 0.2196D+03, 0.2178D+03, 0.2164D+03, 0.2156D+03 & + / + data (TREF( 9,16, mtmp), mtmp=1,12) & + / & + 0.2120D+03, 0.2149D+03, 0.2194D+03, 0.2221D+03, & + 0.2240D+03, 0.2253D+03, 0.2259D+03, 0.2247D+03, & + 0.2222D+03, 0.2190D+03, 0.2157D+03, 0.2129D+03 & + / + data (TREF( 9,17, mtmp), mtmp=1,12) & + / & + 0.2083D+03, 0.2120D+03, 0.2192D+03, 0.2246D+03, & + 0.2270D+03, 0.2288D+03, 0.2293D+03, 0.2278D+03, & + 0.2240D+03, 0.2191D+03, 0.2143D+03, 0.2096D+03 & + / + data (TREF( 9,18, mtmp), mtmp=1,12) & + / & + 0.2059D+03, 0.2095D+03, 0.2183D+03, 0.2252D+03, & + 0.2281D+03, 0.2306D+03, 0.2310D+03, 0.2292D+03, & + 0.2245D+03, 0.2185D+03, 0.2128D+03, 0.2070D+03 & + / + data (TREF(10, 1, mtmp), mtmp=1,12) & + / & + 0.2340D+03, 0.2311D+03, 0.2242D+03, 0.2141D+03, & + 0.2030D+03, 0.1959D+03, 0.1901D+03, 0.1885D+03, & + 0.1917D+03, 0.2022D+03, 0.2223D+03, 0.2353D+03 & + / + data (TREF(10, 2, mtmp), mtmp=1,12) & + / & + 0.2326D+03, 0.2299D+03, 0.2243D+03, 0.2160D+03, & + 0.2058D+03, 0.1986D+03, 0.1930D+03, 0.1912D+03, & + 0.1949D+03, 0.2064D+03, 0.2234D+03, 0.2332D+03 & + / + data (TREF(10, 3, mtmp), mtmp=1,12) & + / & + 0.2302D+03, 0.2280D+03, 0.2239D+03, 0.2185D+03, & + 0.2116D+03, 0.2054D+03, 0.2007D+03, 0.1996D+03, & + 0.2039D+03, 0.2145D+03, 0.2251D+03, 0.2303D+03 & + / + data (TREF(10, 4, mtmp), mtmp=1,12) & + / & + 0.2256D+03, 0.2240D+03, 0.2215D+03, 0.2189D+03, & + 0.2162D+03, 0.2125D+03, 0.2101D+03, 0.2104D+03, & + 0.2141D+03, 0.2202D+03, 0.2238D+03, 0.2255D+03 & + / + data (TREF(10, 5, mtmp), mtmp=1,12) & + / & + 0.2183D+03, 0.2173D+03, 0.2165D+03, 0.2161D+03, & + 0.2162D+03, 0.2153D+03, 0.2148D+03, 0.2161D+03, & + 0.2180D+03, 0.2197D+03, 0.2190D+03, 0.2187D+03 & + / + data (TREF(10, 6, mtmp), mtmp=1,12) & + / & + 0.2101D+03, 0.2095D+03, 0.2100D+03, 0.2109D+03, & + 0.2121D+03, 0.2126D+03, 0.2131D+03, 0.2142D+03, & + 0.2149D+03, 0.2145D+03, 0.2125D+03, 0.2111D+03 & + / + data (TREF(10, 7, mtmp), mtmp=1,12) & + / & + 0.2033D+03, 0.2030D+03, 0.2036D+03, 0.2047D+03, & + 0.2060D+03, 0.2069D+03, 0.2079D+03, 0.2086D+03, & + 0.2087D+03, 0.2077D+03, 0.2060D+03, 0.2045D+03 & + / + data (TREF(10, 8, mtmp), mtmp=1,12) & + / & + 0.1992D+03, 0.1990D+03, 0.1994D+03, 0.2000D+03, & + 0.2011D+03, 0.2024D+03, 0.2038D+03, 0.2043D+03, & + 0.2041D+03, 0.2028D+03, 0.2013D+03, 0.2000D+03 & + / + data (TREF(10, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1978D+03, 0.1981D+03, 0.1984D+03, & + 0.1993D+03, 0.2009D+03, 0.2025D+03, 0.2030D+03, & + 0.2027D+03, 0.2011D+03, 0.1997D+03, 0.1983D+03 & + / + data (TREF(10,10, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1979D+03, 0.1981D+03, 0.1985D+03, & + 0.1994D+03, 0.2010D+03, 0.2026D+03, 0.2030D+03, & + 0.2027D+03, 0.2012D+03, 0.1997D+03, 0.1983D+03 & + / + data (TREF(10,11, mtmp), mtmp=1,12) & + / & + 0.1991D+03, 0.1988D+03, 0.1990D+03, 0.1997D+03, & + 0.2007D+03, 0.2019D+03, 0.2032D+03, 0.2036D+03, & + 0.2032D+03, 0.2019D+03, 0.2005D+03, 0.1994D+03 & + / + data (TREF(10,12, mtmp), mtmp=1,12) & + / & + 0.2034D+03, 0.2032D+03, 0.2032D+03, 0.2038D+03, & + 0.2045D+03, 0.2046D+03, 0.2052D+03, 0.2056D+03, & + 0.2053D+03, 0.2045D+03, 0.2036D+03, 0.2032D+03 & + / + data (TREF(10,13, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2109D+03, 0.2104D+03, 0.2102D+03, & + 0.2105D+03, 0.2099D+03, 0.2097D+03, 0.2098D+03, & + 0.2096D+03, 0.2092D+03, 0.2090D+03, 0.2094D+03 & + / + data (TREF(10,14, mtmp), mtmp=1,12) & + / & + 0.2157D+03, 0.2164D+03, 0.2161D+03, 0.2155D+03, & + 0.2161D+03, 0.2164D+03, 0.2160D+03, 0.2156D+03, & + 0.2149D+03, 0.2139D+03, 0.2137D+03, 0.2140D+03 & + / + data (TREF(10,15, mtmp), mtmp=1,12) & + / & + 0.2150D+03, 0.2169D+03, 0.2185D+03, 0.2188D+03, & + 0.2202D+03, 0.2214D+03, 0.2216D+03, 0.2208D+03, & + 0.2191D+03, 0.2169D+03, 0.2152D+03, 0.2142D+03 & + / + data (TREF(10,16, mtmp), mtmp=1,12) & + / & + 0.2107D+03, 0.2143D+03, 0.2191D+03, 0.2216D+03, & + 0.2236D+03, 0.2253D+03, 0.2259D+03, 0.2246D+03, & + 0.2216D+03, 0.2178D+03, 0.2141D+03, 0.2109D+03 & + / + data (TREF(10,17, mtmp), mtmp=1,12) & + / & + 0.2063D+03, 0.2110D+03, 0.2189D+03, 0.2242D+03, & + 0.2266D+03, 0.2288D+03, 0.2294D+03, 0.2276D+03, & + 0.2231D+03, 0.2175D+03, 0.2121D+03, 0.2070D+03 & + / + data (TREF(10,18, mtmp), mtmp=1,12) & + / & + 0.2033D+03, 0.2080D+03, 0.2178D+03, 0.2249D+03, & + 0.2276D+03, 0.2303D+03, 0.2306D+03, 0.2286D+03, & + 0.2231D+03, 0.2162D+03, 0.2098D+03, 0.2037D+03 & + / + data (TREF(11, 1, mtmp), mtmp=1,12) & + / & + 0.2344D+03, 0.2308D+03, 0.2230D+03, 0.2119D+03, & + 0.1997D+03, 0.1926D+03, 0.1871D+03, 0.1861D+03, & + 0.1907D+03, 0.2041D+03, 0.2265D+03, 0.2366D+03 & + / + data (TREF(11, 2, mtmp), mtmp=1,12) & + / & + 0.2332D+03, 0.2299D+03, 0.2233D+03, 0.2140D+03, & + 0.2029D+03, 0.1956D+03, 0.1901D+03, 0.1891D+03, & + 0.1942D+03, 0.2082D+03, 0.2267D+03, 0.2345D+03 & + / + data (TREF(11, 3, mtmp), mtmp=1,12) & + / & + 0.2307D+03, 0.2281D+03, 0.2233D+03, 0.2172D+03, & + 0.2095D+03, 0.2030D+03, 0.1984D+03, 0.1981D+03, & + 0.2038D+03, 0.2158D+03, 0.2270D+03, 0.2313D+03 & + / + data (TREF(11, 4, mtmp), mtmp=1,12) & + / & + 0.2265D+03, 0.2246D+03, 0.2218D+03, 0.2186D+03, & + 0.2152D+03, 0.2110D+03, 0.2087D+03, 0.2097D+03, & + 0.2144D+03, 0.2211D+03, 0.2248D+03, 0.2266D+03 & + / + data (TREF(11, 5, mtmp), mtmp=1,12) & + / & + 0.2201D+03, 0.2190D+03, 0.2180D+03, 0.2170D+03, & + 0.2164D+03, 0.2151D+03, 0.2146D+03, 0.2162D+03, & + 0.2187D+03, 0.2206D+03, 0.2201D+03, 0.2203D+03 & + / + data (TREF(11, 6, mtmp), mtmp=1,12) & + / & + 0.2129D+03, 0.2124D+03, 0.2127D+03, 0.2131D+03, & + 0.2138D+03, 0.2141D+03, 0.2145D+03, 0.2156D+03, & + 0.2165D+03, 0.2162D+03, 0.2145D+03, 0.2136D+03 & + / + data (TREF(11, 7, mtmp), mtmp=1,12) & + / & + 0.2073D+03, 0.2069D+03, 0.2075D+03, 0.2083D+03, & + 0.2094D+03, 0.2103D+03, 0.2111D+03, 0.2117D+03, & + 0.2119D+03, 0.2109D+03, 0.2094D+03, 0.2082D+03 & + / + data (TREF(11, 8, mtmp), mtmp=1,12) & + / & + 0.2039D+03, 0.2035D+03, 0.2040D+03, 0.2047D+03, & + 0.2058D+03, 0.2071D+03, 0.2083D+03, 0.2087D+03, & + 0.2085D+03, 0.2073D+03, 0.2060D+03, 0.2047D+03 & + / + data (TREF(11, 9, mtmp), mtmp=1,12) & + / & + 0.2030D+03, 0.2026D+03, 0.2030D+03, 0.2036D+03, & + 0.2047D+03, 0.2061D+03, 0.2075D+03, 0.2079D+03, & + 0.2075D+03, 0.2062D+03, 0.2050D+03, 0.2036D+03 & + / + data (TREF(11,10, mtmp), mtmp=1,12) & + / & + 0.2035D+03, 0.2031D+03, 0.2034D+03, 0.2041D+03, & + 0.2052D+03, 0.2067D+03, 0.2079D+03, 0.2083D+03, & + 0.2079D+03, 0.2066D+03, 0.2054D+03, 0.2039D+03 & + / + data (TREF(11,11, mtmp), mtmp=1,12) & + / & + 0.2042D+03, 0.2038D+03, 0.2041D+03, 0.2051D+03, & + 0.2063D+03, 0.2075D+03, 0.2086D+03, 0.2089D+03, & + 0.2085D+03, 0.2073D+03, 0.2061D+03, 0.2046D+03 & + / + data (TREF(11,12, mtmp), mtmp=1,12) & + / & + 0.2069D+03, 0.2065D+03, 0.2067D+03, 0.2076D+03, & + 0.2087D+03, 0.2092D+03, 0.2098D+03, 0.2101D+03, & + 0.2097D+03, 0.2088D+03, 0.2077D+03, 0.2068D+03 & + / + data (TREF(11,13, mtmp), mtmp=1,12) & + / & + 0.2119D+03, 0.2119D+03, 0.2115D+03, 0.2117D+03, & + 0.2126D+03, 0.2127D+03, 0.2128D+03, 0.2129D+03, & + 0.2125D+03, 0.2115D+03, 0.2108D+03, 0.2106D+03 & + / + data (TREF(11,14, mtmp), mtmp=1,12) & + / & + 0.2155D+03, 0.2162D+03, 0.2159D+03, 0.2156D+03, & + 0.2166D+03, 0.2174D+03, 0.2174D+03, 0.2171D+03, & + 0.2160D+03, 0.2144D+03, 0.2136D+03, 0.2136D+03 & + / + data (TREF(11,15, mtmp), mtmp=1,12) & + / & + 0.2144D+03, 0.2166D+03, 0.2181D+03, 0.2185D+03, & + 0.2201D+03, 0.2217D+03, 0.2221D+03, 0.2212D+03, & + 0.2190D+03, 0.2163D+03, 0.2142D+03, 0.2130D+03 & + / + data (TREF(11,16, mtmp), mtmp=1,12) & + / & + 0.2097D+03, 0.2140D+03, 0.2190D+03, 0.2213D+03, & + 0.2234D+03, 0.2256D+03, 0.2262D+03, 0.2247D+03, & + 0.2210D+03, 0.2166D+03, 0.2125D+03, 0.2092D+03 & + / + data (TREF(11,17, mtmp), mtmp=1,12) & + / & + 0.2048D+03, 0.2107D+03, 0.2190D+03, 0.2240D+03, & + 0.2266D+03, 0.2292D+03, 0.2297D+03, 0.2276D+03, & + 0.2223D+03, 0.2157D+03, 0.2100D+03, 0.2047D+03 & + / + data (TREF(11,18, mtmp), mtmp=1,12) & + / & + 0.2016D+03, 0.2076D+03, 0.2180D+03, 0.2248D+03, & + 0.2275D+03, 0.2306D+03, 0.2308D+03, 0.2284D+03, & + 0.2221D+03, 0.2141D+03, 0.2073D+03, 0.2012D+03 & + / + data (TREF(12, 1, mtmp), mtmp=1,12) & + / & + 0.2350D+03, 0.2309D+03, 0.2225D+03, 0.2105D+03, & + 0.1980D+03, 0.1911D+03, 0.1860D+03, 0.1859D+03, & + 0.1917D+03, 0.2078D+03, 0.2308D+03, 0.2377D+03 & + / + data (TREF(12, 2, mtmp), mtmp=1,12) & + / & + 0.2340D+03, 0.2302D+03, 0.2229D+03, 0.2128D+03, & + 0.2012D+03, 0.1940D+03, 0.1889D+03, 0.1889D+03, & + 0.1952D+03, 0.2115D+03, 0.2304D+03, 0.2358D+03 & + / + data (TREF(12, 3, mtmp), mtmp=1,12) & + / & + 0.2316D+03, 0.2287D+03, 0.2232D+03, 0.2163D+03, & + 0.2080D+03, 0.2014D+03, 0.1970D+03, 0.1978D+03, & + 0.2048D+03, 0.2181D+03, 0.2291D+03, 0.2326D+03 & + / + data (TREF(12, 4, mtmp), mtmp=1,12) & + / & + 0.2279D+03, 0.2259D+03, 0.2225D+03, 0.2185D+03, & + 0.2143D+03, 0.2098D+03, 0.2075D+03, 0.2095D+03, & + 0.2153D+03, 0.2224D+03, 0.2261D+03, 0.2281D+03 & + / + data (TREF(12, 5, mtmp), mtmp=1,12) & + / & + 0.2225D+03, 0.2214D+03, 0.2199D+03, 0.2182D+03, & + 0.2167D+03, 0.2150D+03, 0.2146D+03, 0.2167D+03, & + 0.2198D+03, 0.2218D+03, 0.2216D+03, 0.2224D+03 & + / + data (TREF(12, 6, mtmp), mtmp=1,12) & + / & + 0.2166D+03, 0.2162D+03, 0.2161D+03, 0.2159D+03, & + 0.2160D+03, 0.2159D+03, 0.2162D+03, 0.2175D+03, & + 0.2185D+03, 0.2183D+03, 0.2170D+03, 0.2168D+03 & + / + data (TREF(12, 7, mtmp), mtmp=1,12) & + / & + 0.2120D+03, 0.2118D+03, 0.2122D+03, 0.2128D+03, & + 0.2136D+03, 0.2141D+03, 0.2146D+03, 0.2151D+03, & + 0.2153D+03, 0.2145D+03, 0.2135D+03, 0.2127D+03 & + / + data (TREF(12, 8, mtmp), mtmp=1,12) & + / & + 0.2092D+03, 0.2088D+03, 0.2094D+03, 0.2103D+03, & + 0.2113D+03, 0.2121D+03, 0.2128D+03, 0.2130D+03, & + 0.2128D+03, 0.2120D+03, 0.2112D+03, 0.2101D+03 & + / + data (TREF(12, 9, mtmp), mtmp=1,12) & + / & + 0.2086D+03, 0.2081D+03, 0.2087D+03, 0.2095D+03, & + 0.2106D+03, 0.2116D+03, 0.2124D+03, 0.2125D+03, & + 0.2123D+03, 0.2113D+03, 0.2106D+03, 0.2093D+03 & + / + data (TREF(12,10, mtmp), mtmp=1,12) & + / & + 0.2093D+03, 0.2088D+03, 0.2093D+03, 0.2104D+03, & + 0.2115D+03, 0.2125D+03, 0.2132D+03, 0.2133D+03, & + 0.2130D+03, 0.2121D+03, 0.2113D+03, 0.2098D+03 & + / + data (TREF(12,11, mtmp), mtmp=1,12) & + / & + 0.2099D+03, 0.2095D+03, 0.2100D+03, 0.2113D+03, & + 0.2125D+03, 0.2133D+03, 0.2139D+03, 0.2139D+03, & + 0.2136D+03, 0.2127D+03, 0.2118D+03, 0.2104D+03 & + / + data (TREF(12,12, mtmp), mtmp=1,12) & + / & + 0.2111D+03, 0.2108D+03, 0.2112D+03, 0.2124D+03, & + 0.2138D+03, 0.2143D+03, 0.2146D+03, 0.2147D+03, & + 0.2143D+03, 0.2134D+03, 0.2123D+03, 0.2112D+03 & + / + data (TREF(12,13, mtmp), mtmp=1,12) & + / & + 0.2140D+03, 0.2139D+03, 0.2137D+03, 0.2144D+03, & + 0.2157D+03, 0.2164D+03, 0.2166D+03, 0.2166D+03, & + 0.2159D+03, 0.2144D+03, 0.2134D+03, 0.2129D+03 & + / + data (TREF(12,14, mtmp), mtmp=1,12) & + / & + 0.2159D+03, 0.2166D+03, 0.2164D+03, 0.2164D+03, & + 0.2180D+03, 0.2194D+03, 0.2198D+03, 0.2193D+03, & + 0.2178D+03, 0.2155D+03, 0.2142D+03, 0.2139D+03 & + / + data (TREF(12,15, mtmp), mtmp=1,12) & + / & + 0.2141D+03, 0.2166D+03, 0.2181D+03, 0.2185D+03, & + 0.2205D+03, 0.2227D+03, 0.2233D+03, 0.2221D+03, & + 0.2194D+03, 0.2161D+03, 0.2135D+03, 0.2122D+03 & + / + data (TREF(12,16, mtmp), mtmp=1,12) & + / & + 0.2092D+03, 0.2142D+03, 0.2191D+03, 0.2211D+03, & + 0.2236D+03, 0.2263D+03, 0.2269D+03, 0.2250D+03, & + 0.2207D+03, 0.2156D+03, 0.2111D+03, 0.2078D+03 & + / + data (TREF(12,17, mtmp), mtmp=1,12) & + / & + 0.2043D+03, 0.2112D+03, 0.2195D+03, 0.2239D+03, & + 0.2268D+03, 0.2299D+03, 0.2303D+03, 0.2278D+03, & + 0.2217D+03, 0.2142D+03, 0.2082D+03, 0.2032D+03 & + / + data (TREF(12,18, mtmp), mtmp=1,12) & + / & + 0.2011D+03, 0.2084D+03, 0.2189D+03, 0.2250D+03, & + 0.2280D+03, 0.2314D+03, 0.2316D+03, 0.2287D+03, & + 0.2217D+03, 0.2125D+03, 0.2056D+03, 0.1997D+03 & + / + data (TREF(13, 1, mtmp), mtmp=1,12) & + / & + 0.2363D+03, 0.2318D+03, 0.2226D+03, 0.2100D+03, & + 0.1978D+03, 0.1913D+03, 0.1868D+03, 0.1877D+03, & + 0.1946D+03, 0.2131D+03, 0.2352D+03, 0.2392D+03 & + / + data (TREF(13, 2, mtmp), mtmp=1,12) & + / & + 0.2354D+03, 0.2312D+03, 0.2232D+03, 0.2122D+03, & + 0.2007D+03, 0.1938D+03, 0.1893D+03, 0.1905D+03, & + 0.1982D+03, 0.2160D+03, 0.2342D+03, 0.2376D+03 & + / + data (TREF(13, 3, mtmp), mtmp=1,12) & + / & + 0.2332D+03, 0.2299D+03, 0.2238D+03, 0.2159D+03, & + 0.2070D+03, 0.2006D+03, 0.1967D+03, 0.1988D+03, & + 0.2071D+03, 0.2211D+03, 0.2317D+03, 0.2344D+03 & + / + data (TREF(13, 4, mtmp), mtmp=1,12) & + / & + 0.2298D+03, 0.2277D+03, 0.2236D+03, 0.2187D+03, & + 0.2135D+03, 0.2088D+03, 0.2068D+03, 0.2098D+03, & + 0.2167D+03, 0.2241D+03, 0.2278D+03, 0.2301D+03 & + / + data (TREF(13, 5, mtmp), mtmp=1,12) & + / & + 0.2253D+03, 0.2242D+03, 0.2221D+03, 0.2195D+03, & + 0.2171D+03, 0.2150D+03, 0.2148D+03, 0.2175D+03, & + 0.2211D+03, 0.2233D+03, 0.2236D+03, 0.2251D+03 & + / + data (TREF(13, 6, mtmp), mtmp=1,12) & + / & + 0.2204D+03, 0.2200D+03, 0.2196D+03, 0.2187D+03, & + 0.2181D+03, 0.2177D+03, 0.2181D+03, 0.2195D+03, & + 0.2206D+03, 0.2205D+03, 0.2199D+03, 0.2203D+03 & + / + data (TREF(13, 7, mtmp), mtmp=1,12) & + / & + 0.2165D+03, 0.2164D+03, 0.2168D+03, 0.2171D+03, & + 0.2175D+03, 0.2176D+03, 0.2179D+03, 0.2183D+03, & + 0.2184D+03, 0.2180D+03, 0.2174D+03, 0.2170D+03 & + / + data (TREF(13, 8, mtmp), mtmp=1,12) & + / & + 0.2140D+03, 0.2137D+03, 0.2145D+03, 0.2155D+03, & + 0.2163D+03, 0.2166D+03, 0.2168D+03, 0.2168D+03, & + 0.2167D+03, 0.2163D+03, 0.2159D+03, 0.2149D+03 & + / + data (TREF(13, 9, mtmp), mtmp=1,12) & + / & + 0.2134D+03, 0.2129D+03, 0.2138D+03, 0.2150D+03, & + 0.2160D+03, 0.2164D+03, 0.2166D+03, 0.2165D+03, & + 0.2164D+03, 0.2159D+03, 0.2155D+03, 0.2142D+03 & + / + data (TREF(13,10, mtmp), mtmp=1,12) & + / & + 0.2141D+03, 0.2136D+03, 0.2145D+03, 0.2159D+03, & + 0.2168D+03, 0.2173D+03, 0.2175D+03, 0.2173D+03, & + 0.2171D+03, 0.2166D+03, 0.2162D+03, 0.2148D+03 & + / + data (TREF(13,11, mtmp), mtmp=1,12) & + / & + 0.2145D+03, 0.2142D+03, 0.2151D+03, 0.2166D+03, & + 0.2177D+03, 0.2181D+03, 0.2182D+03, 0.2179D+03, & + 0.2177D+03, 0.2171D+03, 0.2165D+03, 0.2151D+03 & + / + data (TREF(13,12, mtmp), mtmp=1,12) & + / & + 0.2149D+03, 0.2147D+03, 0.2154D+03, 0.2170D+03, & + 0.2184D+03, 0.2188D+03, 0.2188D+03, 0.2185D+03, & + 0.2182D+03, 0.2173D+03, 0.2164D+03, 0.2151D+03 & + / + data (TREF(13,13, mtmp), mtmp=1,12) & + / & + 0.2163D+03, 0.2162D+03, 0.2162D+03, 0.2174D+03, & + 0.2192D+03, 0.2201D+03, 0.2203D+03, 0.2200D+03, & + 0.2191D+03, 0.2173D+03, 0.2161D+03, 0.2153D+03 & + / + data (TREF(13,14, mtmp), mtmp=1,12) & + / & + 0.2169D+03, 0.2176D+03, 0.2174D+03, 0.2179D+03, & + 0.2200D+03, 0.2219D+03, 0.2225D+03, 0.2218D+03, & + 0.2198D+03, 0.2170D+03, 0.2152D+03, 0.2147D+03 & + / + data (TREF(13,15, mtmp), mtmp=1,12) & + / & + 0.2145D+03, 0.2171D+03, 0.2185D+03, 0.2191D+03, & + 0.2217D+03, 0.2243D+03, 0.2251D+03, 0.2237D+03, & + 0.2204D+03, 0.2164D+03, 0.2132D+03, 0.2119D+03 & + / + data (TREF(13,16, mtmp), mtmp=1,12) & + / & + 0.2096D+03, 0.2149D+03, 0.2195D+03, 0.2214D+03, & + 0.2244D+03, 0.2276D+03, 0.2283D+03, 0.2260D+03, & + 0.2209D+03, 0.2151D+03, 0.2101D+03, 0.2071D+03 & + / + data (TREF(13,17, mtmp), mtmp=1,12) & + / & + 0.2047D+03, 0.2123D+03, 0.2203D+03, 0.2241D+03, & + 0.2275D+03, 0.2310D+03, 0.2314D+03, 0.2285D+03, & + 0.2216D+03, 0.2132D+03, 0.2070D+03, 0.2024D+03 & + / + data (TREF(13,18, mtmp), mtmp=1,12) & + / & + 0.2016D+03, 0.2098D+03, 0.2201D+03, 0.2254D+03, & + 0.2289D+03, 0.2326D+03, 0.2328D+03, 0.2295D+03, & + 0.2216D+03, 0.2113D+03, 0.2046D+03, 0.1992D+03 & + / + data (TREF(14, 1, mtmp), mtmp=1,12) & + / & + 0.2387D+03, 0.2335D+03, 0.2236D+03, 0.2102D+03, & + 0.1986D+03, 0.1927D+03, 0.1893D+03, 0.1912D+03, & + 0.1995D+03, 0.2197D+03, 0.2399D+03, 0.2416D+03 & + / + data (TREF(14, 2, mtmp), mtmp=1,12) & + / & + 0.2377D+03, 0.2330D+03, 0.2241D+03, 0.2123D+03, & + 0.2010D+03, 0.1948D+03, 0.1913D+03, 0.1939D+03, & + 0.2030D+03, 0.2218D+03, 0.2383D+03, 0.2401D+03 & + / + data (TREF(14, 3, mtmp), mtmp=1,12) & + / & + 0.2355D+03, 0.2318D+03, 0.2249D+03, 0.2160D+03, & + 0.2066D+03, 0.2005D+03, 0.1975D+03, 0.2011D+03, & + 0.2107D+03, 0.2250D+03, 0.2347D+03, 0.2369D+03 & + / + data (TREF(14, 4, mtmp), mtmp=1,12) & + / & + 0.2324D+03, 0.2299D+03, 0.2252D+03, 0.2192D+03, & + 0.2130D+03, 0.2081D+03, 0.2067D+03, 0.2109D+03, & + 0.2187D+03, 0.2262D+03, 0.2301D+03, 0.2327D+03 & + / + data (TREF(14, 5, mtmp), mtmp=1,12) & + / & + 0.2284D+03, 0.2272D+03, 0.2245D+03, 0.2210D+03, & + 0.2176D+03, 0.2150D+03, 0.2152D+03, 0.2185D+03, & + 0.2226D+03, 0.2249D+03, 0.2260D+03, 0.2281D+03 & + / + data (TREF(14, 6, mtmp), mtmp=1,12) & + / & + 0.2241D+03, 0.2238D+03, 0.2229D+03, 0.2214D+03, & + 0.2201D+03, 0.2193D+03, 0.2198D+03, 0.2214D+03, & + 0.2227D+03, 0.2229D+03, 0.2229D+03, 0.2240D+03 & + / + data (TREF(14, 7, mtmp), mtmp=1,12) & + / & + 0.2206D+03, 0.2205D+03, 0.2209D+03, 0.2210D+03, & + 0.2209D+03, 0.2208D+03, 0.2209D+03, 0.2212D+03, & + 0.2214D+03, 0.2213D+03, 0.2212D+03, 0.2211D+03 & + / + data (TREF(14, 8, mtmp), mtmp=1,12) & + / & + 0.2181D+03, 0.2180D+03, 0.2191D+03, 0.2201D+03, & + 0.2206D+03, 0.2206D+03, 0.2204D+03, 0.2203D+03, & + 0.2203D+03, 0.2203D+03, 0.2202D+03, 0.2192D+03 & + / + data (TREF(14, 9, mtmp), mtmp=1,12) & + / & + 0.2173D+03, 0.2170D+03, 0.2184D+03, 0.2199D+03, & + 0.2206D+03, 0.2205D+03, 0.2203D+03, 0.2200D+03, & + 0.2201D+03, 0.2201D+03, 0.2199D+03, 0.2185D+03 & + / + data (TREF(14,10, mtmp), mtmp=1,12) & + / & + 0.2178D+03, 0.2176D+03, 0.2189D+03, 0.2205D+03, & + 0.2213D+03, 0.2213D+03, 0.2210D+03, 0.2207D+03, & + 0.2207D+03, 0.2206D+03, 0.2204D+03, 0.2187D+03 & + / + data (TREF(14,11, mtmp), mtmp=1,12) & + / & + 0.2181D+03, 0.2180D+03, 0.2193D+03, 0.2212D+03, & + 0.2220D+03, 0.2220D+03, 0.2217D+03, 0.2213D+03, & + 0.2212D+03, 0.2209D+03, 0.2205D+03, 0.2188D+03 & + / + data (TREF(14,12, mtmp), mtmp=1,12) & + / & + 0.2182D+03, 0.2182D+03, 0.2192D+03, 0.2212D+03, & + 0.2224D+03, 0.2226D+03, 0.2224D+03, 0.2219D+03, & + 0.2215D+03, 0.2206D+03, 0.2198D+03, 0.2184D+03 & + / + data (TREF(14,13, mtmp), mtmp=1,12) & + / & + 0.2187D+03, 0.2188D+03, 0.2190D+03, 0.2207D+03, & + 0.2226D+03, 0.2237D+03, 0.2237D+03, 0.2231D+03, & + 0.2220D+03, 0.2200D+03, 0.2186D+03, 0.2177D+03 & + / + data (TREF(14,14, mtmp), mtmp=1,12) & + / & + 0.2183D+03, 0.2192D+03, 0.2191D+03, 0.2200D+03, & + 0.2228D+03, 0.2250D+03, 0.2255D+03, 0.2245D+03, & + 0.2221D+03, 0.2189D+03, 0.2165D+03, 0.2159D+03 & + / + data (TREF(14,15, mtmp), mtmp=1,12) & + / & + 0.2155D+03, 0.2183D+03, 0.2195D+03, 0.2204D+03, & + 0.2238D+03, 0.2269D+03, 0.2277D+03, 0.2259D+03, & + 0.2220D+03, 0.2173D+03, 0.2134D+03, 0.2122D+03 & + / + data (TREF(14,16, mtmp), mtmp=1,12) & + / & + 0.2107D+03, 0.2163D+03, 0.2205D+03, 0.2223D+03, & + 0.2261D+03, 0.2298D+03, 0.2306D+03, 0.2278D+03, & + 0.2220D+03, 0.2152D+03, 0.2098D+03, 0.2072D+03 & + / + data (TREF(14,17, mtmp), mtmp=1,12) & + / & + 0.2060D+03, 0.2140D+03, 0.2214D+03, 0.2248D+03, & + 0.2288D+03, 0.2329D+03, 0.2333D+03, 0.2299D+03, & + 0.2221D+03, 0.2126D+03, 0.2063D+03, 0.2025D+03 & + / + data (TREF(14,18, mtmp), mtmp=1,12) & + / & + 0.2028D+03, 0.2117D+03, 0.2213D+03, 0.2259D+03, & + 0.2300D+03, 0.2343D+03, 0.2345D+03, 0.2308D+03, & + 0.2219D+03, 0.2105D+03, 0.2039D+03, 0.1993D+03 & + / + data (TREF(15, 1, mtmp), mtmp=1,12) & + / & + 0.2420D+03, 0.2360D+03, 0.2250D+03, 0.2110D+03, & + 0.2001D+03, 0.1949D+03, 0.1927D+03, 0.1959D+03, & + 0.2057D+03, 0.2272D+03, 0.2448D+03, 0.2448D+03 & + / + data (TREF(15, 2, mtmp), mtmp=1,12) & + / & + 0.2408D+03, 0.2354D+03, 0.2256D+03, 0.2129D+03, & + 0.2018D+03, 0.1964D+03, 0.1942D+03, 0.1984D+03, & + 0.2090D+03, 0.2283D+03, 0.2426D+03, 0.2431D+03 & + / + data (TREF(15, 3, mtmp), mtmp=1,12) & + / & + 0.2384D+03, 0.2342D+03, 0.2264D+03, 0.2164D+03, & + 0.2066D+03, 0.2009D+03, 0.1990D+03, 0.2043D+03, & + 0.2152D+03, 0.2293D+03, 0.2379D+03, 0.2398D+03 & + / + data (TREF(15, 4, mtmp), mtmp=1,12) & + / & + 0.2353D+03, 0.2325D+03, 0.2269D+03, 0.2199D+03, & + 0.2127D+03, 0.2077D+03, 0.2069D+03, 0.2125D+03, & + 0.2211D+03, 0.2285D+03, 0.2327D+03, 0.2356D+03 & + / + data (TREF(15, 5, mtmp), mtmp=1,12) & + / & + 0.2316D+03, 0.2303D+03, 0.2270D+03, 0.2226D+03, & + 0.2181D+03, 0.2151D+03, 0.2157D+03, 0.2197D+03, & + 0.2242D+03, 0.2267D+03, 0.2287D+03, 0.2314D+03 & + / + data (TREF(15, 6, mtmp), mtmp=1,12) & + / & + 0.2277D+03, 0.2273D+03, 0.2261D+03, 0.2240D+03, & + 0.2219D+03, 0.2208D+03, 0.2215D+03, 0.2234D+03, & + 0.2247D+03, 0.2253D+03, 0.2262D+03, 0.2277D+03 & + / + data (TREF(15, 7, mtmp), mtmp=1,12) & + / & + 0.2243D+03, 0.2244D+03, 0.2247D+03, 0.2245D+03, & + 0.2239D+03, 0.2235D+03, 0.2236D+03, 0.2240D+03, & + 0.2242D+03, 0.2245D+03, 0.2249D+03, 0.2249D+03 & + / + data (TREF(15, 8, mtmp), mtmp=1,12) & + / & + 0.2218D+03, 0.2219D+03, 0.2232D+03, 0.2243D+03, & + 0.2245D+03, 0.2242D+03, 0.2237D+03, 0.2235D+03, & + 0.2237D+03, 0.2241D+03, 0.2243D+03, 0.2231D+03 & + / + data (TREF(15, 9, mtmp), mtmp=1,12) & + / & + 0.2208D+03, 0.2208D+03, 0.2226D+03, 0.2243D+03, & + 0.2247D+03, 0.2243D+03, 0.2237D+03, 0.2233D+03, & + 0.2236D+03, 0.2240D+03, 0.2240D+03, 0.2222D+03 & + / + data (TREF(15,10, mtmp), mtmp=1,12) & + / & + 0.2210D+03, 0.2210D+03, 0.2228D+03, 0.2247D+03, & + 0.2252D+03, 0.2248D+03, 0.2243D+03, 0.2238D+03, & + 0.2240D+03, 0.2243D+03, 0.2241D+03, 0.2222D+03 & + / + data (TREF(15,11, mtmp), mtmp=1,12) & + / & + 0.2212D+03, 0.2214D+03, 0.2232D+03, 0.2252D+03, & + 0.2258D+03, 0.2254D+03, 0.2249D+03, 0.2243D+03, & + 0.2243D+03, 0.2243D+03, 0.2240D+03, 0.2221D+03 & + / + data (TREF(15,12, mtmp), mtmp=1,12) & + / & + 0.2212D+03, 0.2214D+03, 0.2229D+03, 0.2251D+03, & + 0.2261D+03, 0.2261D+03, 0.2256D+03, 0.2249D+03, & + 0.2245D+03, 0.2237D+03, 0.2229D+03, 0.2214D+03 & + / + data (TREF(15,13, mtmp), mtmp=1,12) & + / & + 0.2212D+03, 0.2213D+03, 0.2220D+03, 0.2240D+03, & + 0.2261D+03, 0.2271D+03, 0.2269D+03, 0.2260D+03, & + 0.2246D+03, 0.2225D+03, 0.2210D+03, 0.2200D+03 & + / + data (TREF(15,14, mtmp), mtmp=1,12) & + / & + 0.2201D+03, 0.2212D+03, 0.2211D+03, 0.2226D+03, & + 0.2259D+03, 0.2283D+03, 0.2287D+03, 0.2273D+03, & + 0.2246D+03, 0.2209D+03, 0.2180D+03, 0.2172D+03 & + / + data (TREF(15,15, mtmp), mtmp=1,12) & + / & + 0.2170D+03, 0.2201D+03, 0.2210D+03, 0.2223D+03, & + 0.2265D+03, 0.2300D+03, 0.2308D+03, 0.2286D+03, & + 0.2241D+03, 0.2187D+03, 0.2140D+03, 0.2129D+03 & + / + data (TREF(15,16, mtmp), mtmp=1,12) & + / & + 0.2124D+03, 0.2182D+03, 0.2218D+03, 0.2238D+03, & + 0.2284D+03, 0.2326D+03, 0.2334D+03, 0.2302D+03, & + 0.2235D+03, 0.2158D+03, 0.2098D+03, 0.2078D+03 & + / + data (TREF(15,17, mtmp), mtmp=1,12) & + / & + 0.2078D+03, 0.2160D+03, 0.2225D+03, 0.2257D+03, & + 0.2306D+03, 0.2353D+03, 0.2358D+03, 0.2318D+03, & + 0.2229D+03, 0.2125D+03, 0.2060D+03, 0.2031D+03 & + / + data (TREF(15,18, mtmp), mtmp=1,12) & + / & + 0.2046D+03, 0.2139D+03, 0.2223D+03, 0.2265D+03, & + 0.2314D+03, 0.2363D+03, 0.2367D+03, 0.2323D+03, & + 0.2223D+03, 0.2099D+03, 0.2035D+03, 0.1998D+03 & + / + data (TREF(16, 1, mtmp), mtmp=1,12) & + / & + 0.2454D+03, 0.2385D+03, 0.2265D+03, 0.2118D+03, & + 0.2016D+03, 0.1971D+03, 0.1962D+03, 0.2008D+03, & + 0.2121D+03, 0.2347D+03, 0.2497D+03, 0.2482D+03 & + / + data (TREF(16, 2, mtmp), mtmp=1,12) & + / & + 0.2441D+03, 0.2379D+03, 0.2270D+03, 0.2135D+03, & + 0.2028D+03, 0.1982D+03, 0.1973D+03, 0.2032D+03, & + 0.2153D+03, 0.2350D+03, 0.2469D+03, 0.2463D+03 & + / + data (TREF(16, 3, mtmp), mtmp=1,12) & + / & + 0.2416D+03, 0.2367D+03, 0.2280D+03, 0.2169D+03, & + 0.2067D+03, 0.2016D+03, 0.2008D+03, 0.2079D+03, & + 0.2199D+03, 0.2337D+03, 0.2413D+03, 0.2429D+03 & + / + data (TREF(16, 4, mtmp), mtmp=1,12) & + / & + 0.2385D+03, 0.2353D+03, 0.2289D+03, 0.2208D+03, & + 0.2126D+03, 0.2075D+03, 0.2075D+03, 0.2144D+03, & + 0.2238D+03, 0.2310D+03, 0.2356D+03, 0.2388D+03 & + / + data (TREF(16, 5, mtmp), mtmp=1,12) & + / & + 0.2351D+03, 0.2335D+03, 0.2295D+03, 0.2243D+03, & + 0.2188D+03, 0.2154D+03, 0.2164D+03, 0.2212D+03, & + 0.2260D+03, 0.2287D+03, 0.2316D+03, 0.2348D+03 & + / + data (TREF(16, 6, mtmp), mtmp=1,12) & + / & + 0.2315D+03, 0.2310D+03, 0.2294D+03, 0.2266D+03, & + 0.2238D+03, 0.2224D+03, 0.2233D+03, 0.2255D+03, & + 0.2269D+03, 0.2279D+03, 0.2296D+03, 0.2315D+03 & + / + data (TREF(16, 7, mtmp), mtmp=1,12) & + / & + 0.2281D+03, 0.2283D+03, 0.2285D+03, 0.2279D+03, & + 0.2269D+03, 0.2264D+03, 0.2264D+03, 0.2269D+03, & + 0.2272D+03, 0.2279D+03, 0.2288D+03, 0.2289D+03 & + / + data (TREF(16, 8, mtmp), mtmp=1,12) & + / & + 0.2255D+03, 0.2259D+03, 0.2275D+03, 0.2286D+03, & + 0.2284D+03, 0.2278D+03, 0.2270D+03, 0.2268D+03, & + 0.2272D+03, 0.2280D+03, 0.2284D+03, 0.2270D+03 & + / + data (TREF(16, 9, mtmp), mtmp=1,12) & + / & + 0.2243D+03, 0.2246D+03, 0.2269D+03, 0.2288D+03, & + 0.2290D+03, 0.2282D+03, 0.2272D+03, 0.2268D+03, & + 0.2272D+03, 0.2281D+03, 0.2282D+03, 0.2261D+03 & + / + data (TREF(16,10, mtmp), mtmp=1,12) & + / & + 0.2242D+03, 0.2245D+03, 0.2268D+03, 0.2290D+03, & + 0.2292D+03, 0.2285D+03, 0.2276D+03, 0.2271D+03, & + 0.2274D+03, 0.2282D+03, 0.2281D+03, 0.2257D+03 & + / + data (TREF(16,11, mtmp), mtmp=1,12) & + / & + 0.2243D+03, 0.2248D+03, 0.2271D+03, 0.2293D+03, & + 0.2296D+03, 0.2289D+03, 0.2281D+03, 0.2275D+03, & + 0.2276D+03, 0.2278D+03, 0.2275D+03, 0.2254D+03 & + / + data (TREF(16,12, mtmp), mtmp=1,12) & + / & + 0.2243D+03, 0.2247D+03, 0.2266D+03, 0.2290D+03, & + 0.2299D+03, 0.2297D+03, 0.2290D+03, 0.2281D+03, & + 0.2275D+03, 0.2268D+03, 0.2261D+03, 0.2246D+03 & + / + data (TREF(16,13, mtmp), mtmp=1,12) & + / & + 0.2238D+03, 0.2241D+03, 0.2251D+03, 0.2275D+03, & + 0.2297D+03, 0.2306D+03, 0.2303D+03, 0.2290D+03, & + 0.2274D+03, 0.2252D+03, 0.2234D+03, 0.2224D+03 & + / + data (TREF(16,14, mtmp), mtmp=1,12) & + / & + 0.2222D+03, 0.2234D+03, 0.2234D+03, 0.2254D+03, & + 0.2294D+03, 0.2319D+03, 0.2321D+03, 0.2303D+03, & + 0.2272D+03, 0.2231D+03, 0.2196D+03, 0.2188D+03 & + / + data (TREF(16,15, mtmp), mtmp=1,12) & + / & + 0.2188D+03, 0.2220D+03, 0.2228D+03, 0.2246D+03, & + 0.2297D+03, 0.2335D+03, 0.2342D+03, 0.2316D+03, & + 0.2264D+03, 0.2202D+03, 0.2148D+03, 0.2139D+03 & + / + data (TREF(16,16, mtmp), mtmp=1,12) & + / & + 0.2144D+03, 0.2202D+03, 0.2233D+03, 0.2255D+03, & + 0.2311D+03, 0.2358D+03, 0.2366D+03, 0.2329D+03, & + 0.2253D+03, 0.2166D+03, 0.2100D+03, 0.2087D+03 & + / + data (TREF(16,17, mtmp), mtmp=1,12) & + / & + 0.2100D+03, 0.2183D+03, 0.2238D+03, 0.2269D+03, & + 0.2326D+03, 0.2380D+03, 0.2385D+03, 0.2339D+03, & + 0.2240D+03, 0.2126D+03, 0.2060D+03, 0.2041D+03 & + / + data (TREF(16,18, mtmp), mtmp=1,12) & + / & + 0.2066D+03, 0.2161D+03, 0.2234D+03, 0.2272D+03, & + 0.2329D+03, 0.2386D+03, 0.2391D+03, 0.2340D+03, & + 0.2228D+03, 0.2095D+03, 0.2033D+03, 0.2007D+03 & + / + data (TREF(17, 1, mtmp), mtmp=1,12) & + / & + 0.2489D+03, 0.2410D+03, 0.2275D+03, 0.2124D+03, & + 0.2028D+03, 0.1990D+03, 0.1993D+03, 0.2054D+03, & + 0.2181D+03, 0.2414D+03, 0.2536D+03, 0.2512D+03 & + / + data (TREF(17, 2, mtmp), mtmp=1,12) & + / & + 0.2475D+03, 0.2404D+03, 0.2282D+03, 0.2141D+03, & + 0.2038D+03, 0.1999D+03, 0.2004D+03, 0.2080D+03, & + 0.2213D+03, 0.2409D+03, 0.2506D+03, 0.2495D+03 & + / + data (TREF(17, 3, mtmp), mtmp=1,12) & + / & + 0.2452D+03, 0.2396D+03, 0.2296D+03, 0.2178D+03, & + 0.2072D+03, 0.2026D+03, 0.2031D+03, 0.2120D+03, & + 0.2248D+03, 0.2380D+03, 0.2447D+03, 0.2463D+03 & + / + data (TREF(17, 4, mtmp), mtmp=1,12) & + / & + 0.2422D+03, 0.2385D+03, 0.2311D+03, 0.2222D+03, & + 0.2131D+03, 0.2079D+03, 0.2089D+03, 0.2171D+03, & + 0.2269D+03, 0.2339D+03, 0.2389D+03, 0.2425D+03 & + / + data (TREF(17, 5, mtmp), mtmp=1,12) & + / & + 0.2391D+03, 0.2372D+03, 0.2324D+03, 0.2265D+03, & + 0.2201D+03, 0.2162D+03, 0.2179D+03, 0.2233D+03, & + 0.2284D+03, 0.2314D+03, 0.2352D+03, 0.2389D+03 & + / + data (TREF(17, 6, mtmp), mtmp=1,12) & + / & + 0.2357D+03, 0.2351D+03, 0.2328D+03, 0.2297D+03, & + 0.2261D+03, 0.2244D+03, 0.2257D+03, 0.2281D+03, & + 0.2297D+03, 0.2310D+03, 0.2336D+03, 0.2359D+03 & + / + data (TREF(17, 7, mtmp), mtmp=1,12) & + / & + 0.2323D+03, 0.2326D+03, 0.2325D+03, 0.2317D+03, & + 0.2303D+03, 0.2296D+03, 0.2296D+03, 0.2302D+03, & + 0.2307D+03, 0.2318D+03, 0.2332D+03, 0.2333D+03 & + / + data (TREF(17, 8, mtmp), mtmp=1,12) & + / & + 0.2298D+03, 0.2303D+03, 0.2320D+03, 0.2332D+03, & + 0.2327D+03, 0.2318D+03, 0.2308D+03, 0.2307D+03, & + 0.2313D+03, 0.2325D+03, 0.2331D+03, 0.2314D+03 & + / + data (TREF(17, 9, mtmp), mtmp=1,12) & + / & + 0.2285D+03, 0.2291D+03, 0.2317D+03, 0.2338D+03, & + 0.2337D+03, 0.2325D+03, 0.2312D+03, 0.2309D+03, & + 0.2316D+03, 0.2329D+03, 0.2330D+03, 0.2306D+03 & + / + data (TREF(17,10, mtmp), mtmp=1,12) & + / & + 0.2282D+03, 0.2288D+03, 0.2316D+03, 0.2339D+03, & + 0.2338D+03, 0.2327D+03, 0.2315D+03, 0.2311D+03, & + 0.2317D+03, 0.2327D+03, 0.2326D+03, 0.2300D+03 & + / + data (TREF(17,11, mtmp), mtmp=1,12) & + / & + 0.2282D+03, 0.2289D+03, 0.2316D+03, 0.2339D+03, & + 0.2340D+03, 0.2330D+03, 0.2320D+03, 0.2314D+03, & + 0.2315D+03, 0.2320D+03, 0.2317D+03, 0.2294D+03 & + / + data (TREF(17,12, mtmp), mtmp=1,12) & + / & + 0.2279D+03, 0.2286D+03, 0.2309D+03, 0.2335D+03, & + 0.2341D+03, 0.2338D+03, 0.2328D+03, 0.2318D+03, & + 0.2312D+03, 0.2304D+03, 0.2298D+03, 0.2283D+03 & + / + data (TREF(17,13, mtmp), mtmp=1,12) & + / & + 0.2269D+03, 0.2275D+03, 0.2288D+03, 0.2316D+03, & + 0.2339D+03, 0.2348D+03, 0.2342D+03, 0.2326D+03, & + 0.2307D+03, 0.2283D+03, 0.2264D+03, 0.2255D+03 & + / + data (TREF(17,14, mtmp), mtmp=1,12) & + / & + 0.2247D+03, 0.2261D+03, 0.2264D+03, 0.2291D+03, & + 0.2336D+03, 0.2361D+03, 0.2361D+03, 0.2338D+03, & + 0.2303D+03, 0.2258D+03, 0.2217D+03, 0.2211D+03 & + / + data (TREF(17,15, mtmp), mtmp=1,12) & + / & + 0.2212D+03, 0.2244D+03, 0.2252D+03, 0.2278D+03, & + 0.2337D+03, 0.2378D+03, 0.2382D+03, 0.2351D+03, & + 0.2293D+03, 0.2223D+03, 0.2163D+03, 0.2157D+03 & + / + data (TREF(17,16, mtmp), mtmp=1,12) & + / & + 0.2170D+03, 0.2227D+03, 0.2253D+03, 0.2280D+03, & + 0.2346D+03, 0.2398D+03, 0.2405D+03, 0.2362D+03, & + 0.2277D+03, 0.2180D+03, 0.2110D+03, 0.2105D+03 & + / + data (TREF(17,17, mtmp), mtmp=1,12) & + / & + 0.2128D+03, 0.2210D+03, 0.2254D+03, 0.2286D+03, & + 0.2355D+03, 0.2414D+03, 0.2420D+03, 0.2367D+03, & + 0.2256D+03, 0.2132D+03, 0.2066D+03, 0.2059D+03 & + / + data (TREF(17,18, mtmp), mtmp=1,12) & + / & + 0.2095D+03, 0.2189D+03, 0.2246D+03, 0.2284D+03, & + 0.2353D+03, 0.2417D+03, 0.2422D+03, 0.2364D+03, & + 0.2238D+03, 0.2097D+03, 0.2037D+03, 0.2024D+03 & + / + data (TREF(18, 1, mtmp), mtmp=1,12) & + / & + 0.2524D+03, 0.2434D+03, 0.2277D+03, 0.2126D+03, & + 0.2036D+03, 0.2002D+03, 0.2017D+03, 0.2095D+03, & + 0.2236D+03, 0.2468D+03, 0.2563D+03, 0.2539D+03 & + / + data (TREF(18, 2, mtmp), mtmp=1,12) & + / & + 0.2512D+03, 0.2431D+03, 0.2290D+03, 0.2148D+03, & + 0.2048D+03, 0.2016D+03, 0.2035D+03, 0.2129D+03, & + 0.2272D+03, 0.2460D+03, 0.2536D+03, 0.2526D+03 & + / + data (TREF(18, 3, mtmp), mtmp=1,12) & + / & + 0.2494D+03, 0.2431D+03, 0.2315D+03, 0.2192D+03, & + 0.2085D+03, 0.2043D+03, 0.2064D+03, 0.2169D+03, & + 0.2301D+03, 0.2423D+03, 0.2483D+03, 0.2503D+03 & + / + data (TREF(18, 4, mtmp), mtmp=1,12) & + / & + 0.2470D+03, 0.2427D+03, 0.2341D+03, 0.2246D+03, & + 0.2146D+03, 0.2095D+03, 0.2118D+03, 0.2212D+03, & + 0.2309D+03, 0.2376D+03, 0.2432D+03, 0.2472D+03 & + / + data (TREF(18, 5, mtmp), mtmp=1,12) & + / & + 0.2441D+03, 0.2417D+03, 0.2360D+03, 0.2296D+03, & + 0.2223D+03, 0.2182D+03, 0.2206D+03, 0.2266D+03, & + 0.2317D+03, 0.2351D+03, 0.2400D+03, 0.2441D+03 & + / + data (TREF(18, 6, mtmp), mtmp=1,12) & + / & + 0.2408D+03, 0.2398D+03, 0.2368D+03, 0.2334D+03, & + 0.2291D+03, 0.2273D+03, 0.2289D+03, 0.2315D+03, & + 0.2333D+03, 0.2353D+03, 0.2387D+03, 0.2412D+03 & + / + data (TREF(18, 7, mtmp), mtmp=1,12) & + / & + 0.2374D+03, 0.2376D+03, 0.2369D+03, 0.2361D+03, & + 0.2342D+03, 0.2335D+03, 0.2336D+03, 0.2343D+03, & + 0.2350D+03, 0.2366D+03, 0.2385D+03, 0.2386D+03 & + / + data (TREF(18, 8, mtmp), mtmp=1,12) & + / & + 0.2348D+03, 0.2357D+03, 0.2372D+03, 0.2385D+03, & + 0.2376D+03, 0.2366D+03, 0.2355D+03, 0.2355D+03, & + 0.2363D+03, 0.2379D+03, 0.2386D+03, 0.2368D+03 & + / + data (TREF(18, 9, mtmp), mtmp=1,12) & + / & + 0.2337D+03, 0.2348D+03, 0.2376D+03, 0.2399D+03, & + 0.2394D+03, 0.2379D+03, 0.2364D+03, 0.2362D+03, & + 0.2372D+03, 0.2387D+03, 0.2388D+03, 0.2362D+03 & + / + data (TREF(18,10, mtmp), mtmp=1,12) & + / & + 0.2334D+03, 0.2345D+03, 0.2376D+03, 0.2400D+03, & + 0.2396D+03, 0.2382D+03, 0.2366D+03, 0.2364D+03, & + 0.2373D+03, 0.2386D+03, 0.2384D+03, 0.2356D+03 & + / + data (TREF(18,11, mtmp), mtmp=1,12) & + / & + 0.2331D+03, 0.2344D+03, 0.2373D+03, 0.2396D+03, & + 0.2394D+03, 0.2382D+03, 0.2368D+03, 0.2363D+03, & + 0.2367D+03, 0.2373D+03, 0.2370D+03, 0.2347D+03 & + / + data (TREF(18,12, mtmp), mtmp=1,12) & + / & + 0.2326D+03, 0.2337D+03, 0.2361D+03, 0.2387D+03, & + 0.2393D+03, 0.2389D+03, 0.2376D+03, 0.2364D+03, & + 0.2358D+03, 0.2351D+03, 0.2343D+03, 0.2331D+03 & + / + data (TREF(18,13, mtmp), mtmp=1,12) & + / & + 0.2310D+03, 0.2319D+03, 0.2336D+03, 0.2368D+03, & + 0.2392D+03, 0.2401D+03, 0.2390D+03, 0.2370D+03, & + 0.2350D+03, 0.2324D+03, 0.2301D+03, 0.2296D+03 & + / + data (TREF(18,14, mtmp), mtmp=1,12) & + / & + 0.2283D+03, 0.2298D+03, 0.2307D+03, 0.2343D+03, & + 0.2391D+03, 0.2416D+03, 0.2411D+03, 0.2383D+03, & + 0.2344D+03, 0.2294D+03, 0.2247D+03, 0.2245D+03 & + / + data (TREF(18,15, mtmp), mtmp=1,12) & + / & + 0.2247D+03, 0.2277D+03, 0.2287D+03, 0.2326D+03, & + 0.2392D+03, 0.2434D+03, 0.2435D+03, 0.2397D+03, & + 0.2332D+03, 0.2254D+03, 0.2188D+03, 0.2188D+03 & + / + data (TREF(18,16, mtmp), mtmp=1,12) & + / & + 0.2209D+03, 0.2259D+03, 0.2281D+03, 0.2319D+03, & + 0.2395D+03, 0.2452D+03, 0.2456D+03, 0.2406D+03, & + 0.2310D+03, 0.2202D+03, 0.2132D+03, 0.2138D+03 & + / + data (TREF(18,17, mtmp), mtmp=1,12) & + / & + 0.2169D+03, 0.2244D+03, 0.2275D+03, 0.2313D+03, & + 0.2396D+03, 0.2463D+03, 0.2467D+03, 0.2406D+03, & + 0.2281D+03, 0.2148D+03, 0.2085D+03, 0.2092D+03 & + / + data (TREF(18,18, mtmp), mtmp=1,12) & + / & + 0.2136D+03, 0.2226D+03, 0.2263D+03, 0.2302D+03, & + 0.2389D+03, 0.2462D+03, 0.2467D+03, 0.2399D+03, & + 0.2257D+03, 0.2108D+03, 0.2053D+03, 0.2056D+03 & + / + data (TREF(19, 1, mtmp), mtmp=1,12) & + / & + 0.2567D+03, 0.2465D+03, 0.2284D+03, 0.2138D+03, & + 0.2053D+03, 0.2026D+03, 0.2052D+03, 0.2148D+03, & + 0.2297D+03, 0.2520D+03, 0.2590D+03, 0.2573D+03 & + / + data (TREF(19, 2, mtmp), mtmp=1,12) & + / & + 0.2558D+03, 0.2466D+03, 0.2305D+03, 0.2165D+03, & + 0.2070D+03, 0.2045D+03, 0.2078D+03, 0.2189D+03, & + 0.2337D+03, 0.2510D+03, 0.2566D+03, 0.2564D+03 & + / + data (TREF(19, 3, mtmp), mtmp=1,12) & + / & + 0.2545D+03, 0.2473D+03, 0.2341D+03, 0.2216D+03, & + 0.2109D+03, 0.2073D+03, 0.2110D+03, 0.2230D+03, & + 0.2360D+03, 0.2467D+03, 0.2523D+03, 0.2549D+03 & + / + data (TREF(19, 4, mtmp), mtmp=1,12) & + / & + 0.2524D+03, 0.2474D+03, 0.2376D+03, 0.2277D+03, & + 0.2171D+03, 0.2122D+03, 0.2159D+03, 0.2262D+03, & + 0.2356D+03, 0.2417D+03, 0.2480D+03, 0.2526D+03 & + / + data (TREF(19, 5, mtmp), mtmp=1,12) & + / & + 0.2497D+03, 0.2467D+03, 0.2400D+03, 0.2334D+03, & + 0.2252D+03, 0.2210D+03, 0.2243D+03, 0.2307D+03, & + 0.2357D+03, 0.2395D+03, 0.2455D+03, 0.2499D+03 & + / + data (TREF(19, 6, mtmp), mtmp=1,12) & + / & + 0.2464D+03, 0.2450D+03, 0.2411D+03, 0.2376D+03, & + 0.2328D+03, 0.2309D+03, 0.2329D+03, 0.2356D+03, & + 0.2376D+03, 0.2402D+03, 0.2446D+03, 0.2470D+03 & + / + data (TREF(19, 7, mtmp), mtmp=1,12) & + / & + 0.2431D+03, 0.2431D+03, 0.2418D+03, 0.2410D+03, & + 0.2388D+03, 0.2380D+03, 0.2382D+03, 0.2391D+03, & + 0.2401D+03, 0.2421D+03, 0.2445D+03, 0.2444D+03 & + / + data (TREF(19, 8, mtmp), mtmp=1,12) & + / & + 0.2407D+03, 0.2418D+03, 0.2430D+03, 0.2443D+03, & + 0.2431D+03, 0.2419D+03, 0.2408D+03, 0.2411D+03, & + 0.2422D+03, 0.2440D+03, 0.2447D+03, 0.2428D+03 & + / + data (TREF(19, 9, mtmp), mtmp=1,12) & + / & + 0.2398D+03, 0.2414D+03, 0.2442D+03, 0.2465D+03, & + 0.2457D+03, 0.2439D+03, 0.2422D+03, 0.2424D+03, & + 0.2436D+03, 0.2453D+03, 0.2453D+03, 0.2425D+03 & + / + data (TREF(19,10, mtmp), mtmp=1,12) & + / & + 0.2395D+03, 0.2411D+03, 0.2445D+03, 0.2468D+03, & + 0.2460D+03, 0.2443D+03, 0.2425D+03, 0.2426D+03, & + 0.2437D+03, 0.2452D+03, 0.2449D+03, 0.2420D+03 & + / + data (TREF(19,11, mtmp), mtmp=1,12) & + / & + 0.2390D+03, 0.2407D+03, 0.2437D+03, 0.2458D+03, & + 0.2454D+03, 0.2440D+03, 0.2424D+03, 0.2421D+03, & + 0.2426D+03, 0.2434D+03, 0.2430D+03, 0.2408D+03 & + / + data (TREF(19,12, mtmp), mtmp=1,12) & + / & + 0.2381D+03, 0.2395D+03, 0.2420D+03, 0.2445D+03, & + 0.2451D+03, 0.2446D+03, 0.2430D+03, 0.2418D+03, & + 0.2412D+03, 0.2405D+03, 0.2396D+03, 0.2387D+03 & + / + data (TREF(19,13, mtmp), mtmp=1,12) & + / & + 0.2358D+03, 0.2371D+03, 0.2391D+03, 0.2427D+03, & + 0.2452D+03, 0.2459D+03, 0.2444D+03, 0.2421D+03, & + 0.2400D+03, 0.2372D+03, 0.2345D+03, 0.2346D+03 & + / + data (TREF(19,14, mtmp), mtmp=1,12) & + / & + 0.2325D+03, 0.2341D+03, 0.2357D+03, 0.2404D+03, & + 0.2455D+03, 0.2478D+03, 0.2466D+03, 0.2433D+03, & + 0.2391D+03, 0.2337D+03, 0.2285D+03, 0.2288D+03 & + / + data (TREF(19,15, mtmp), mtmp=1,12) & + / & + 0.2289D+03, 0.2314D+03, 0.2330D+03, 0.2384D+03, & + 0.2455D+03, 0.2497D+03, 0.2493D+03, 0.2449D+03, & + 0.2378D+03, 0.2291D+03, 0.2223D+03, 0.2229D+03 & + / + data (TREF(19,16, mtmp), mtmp=1,12) & + / & + 0.2254D+03, 0.2295D+03, 0.2315D+03, 0.2366D+03, & + 0.2453D+03, 0.2513D+03, 0.2514D+03, 0.2457D+03, & + 0.2350D+03, 0.2233D+03, 0.2165D+03, 0.2181D+03 & + / + data (TREF(19,17, mtmp), mtmp=1,12) & + / & + 0.2219D+03, 0.2282D+03, 0.2301D+03, 0.2348D+03, & + 0.2447D+03, 0.2520D+03, 0.2523D+03, 0.2452D+03, & + 0.2313D+03, 0.2173D+03, 0.2115D+03, 0.2137D+03 & + / + data (TREF(19,18, mtmp), mtmp=1,12) & + / & + 0.2188D+03, 0.2269D+03, 0.2284D+03, 0.2328D+03, & + 0.2436D+03, 0.2516D+03, 0.2520D+03, 0.2442D+03, & + 0.2285D+03, 0.2130D+03, 0.2079D+03, 0.2101D+03 & + / + data (TREF(20, 1, mtmp), mtmp=1,12) & + / & + 0.2632D+03, 0.2521D+03, 0.2322D+03, 0.2181D+03, & + 0.2106D+03, 0.2090D+03, 0.2129D+03, 0.2237D+03, & + 0.2386D+03, 0.2585D+03, 0.2635D+03, 0.2632D+03 & + / + data (TREF(20, 2, mtmp), mtmp=1,12) & + / & + 0.2620D+03, 0.2520D+03, 0.2344D+03, 0.2207D+03, & + 0.2121D+03, 0.2107D+03, 0.2155D+03, 0.2278D+03, & + 0.2418D+03, 0.2568D+03, 0.2611D+03, 0.2622D+03 & + / + data (TREF(20, 3, mtmp), mtmp=1,12) & + / & + 0.2603D+03, 0.2524D+03, 0.2382D+03, 0.2255D+03, & + 0.2152D+03, 0.2126D+03, 0.2180D+03, 0.2308D+03, & + 0.2425D+03, 0.2516D+03, 0.2569D+03, 0.2605D+03 & + / + data (TREF(20, 4, mtmp), mtmp=1,12) & + / & + 0.2579D+03, 0.2523D+03, 0.2417D+03, 0.2315D+03, & + 0.2206D+03, 0.2162D+03, 0.2213D+03, 0.2320D+03, & + 0.2404D+03, 0.2461D+03, 0.2530D+03, 0.2580D+03 & + / + data (TREF(20, 5, mtmp), mtmp=1,12) & + / & + 0.2552D+03, 0.2515D+03, 0.2443D+03, 0.2374D+03, & + 0.2287D+03, 0.2246D+03, 0.2286D+03, 0.2350D+03, & + 0.2398D+03, 0.2441D+03, 0.2509D+03, 0.2554D+03 & + / + data (TREF(20, 6, mtmp), mtmp=1,12) & + / & + 0.2520D+03, 0.2501D+03, 0.2458D+03, 0.2422D+03, & + 0.2369D+03, 0.2351D+03, 0.2374D+03, 0.2401D+03, & + 0.2422D+03, 0.2454D+03, 0.2504D+03, 0.2528D+03 & + / + data (TREF(20, 7, mtmp), mtmp=1,12) & + / & + 0.2491D+03, 0.2488D+03, 0.2472D+03, 0.2463D+03, & + 0.2438D+03, 0.2431D+03, 0.2434D+03, 0.2443D+03, & + 0.2455D+03, 0.2480D+03, 0.2506D+03, 0.2505D+03 & + / + data (TREF(20, 8, mtmp), mtmp=1,12) & + / & + 0.2471D+03, 0.2483D+03, 0.2492D+03, 0.2503D+03, & + 0.2489D+03, 0.2476D+03, 0.2466D+03, 0.2471D+03, & + 0.2483D+03, 0.2502D+03, 0.2510D+03, 0.2491D+03 & + / + data (TREF(20, 9, mtmp), mtmp=1,12) & + / & + 0.2464D+03, 0.2483D+03, 0.2510D+03, 0.2530D+03, & + 0.2518D+03, 0.2499D+03, 0.2483D+03, 0.2487D+03, & + 0.2501D+03, 0.2518D+03, 0.2516D+03, 0.2489D+03 & + / + data (TREF(20,10, mtmp), mtmp=1,12) & + / & + 0.2462D+03, 0.2481D+03, 0.2515D+03, 0.2533D+03, & + 0.2523D+03, 0.2504D+03, 0.2486D+03, 0.2490D+03, & + 0.2503D+03, 0.2517D+03, 0.2513D+03, 0.2485D+03 & + / + data (TREF(20,11, mtmp), mtmp=1,12) & + / & + 0.2456D+03, 0.2474D+03, 0.2504D+03, 0.2520D+03, & + 0.2515D+03, 0.2500D+03, 0.2482D+03, 0.2481D+03, & + 0.2489D+03, 0.2496D+03, 0.2493D+03, 0.2472D+03 & + / + data (TREF(20,12, mtmp), mtmp=1,12) & + / & + 0.2442D+03, 0.2457D+03, 0.2482D+03, 0.2504D+03, & + 0.2510D+03, 0.2504D+03, 0.2485D+03, 0.2473D+03, & + 0.2469D+03, 0.2463D+03, 0.2454D+03, 0.2448D+03 & + / + data (TREF(20,13, mtmp), mtmp=1,12) & + / & + 0.2411D+03, 0.2424D+03, 0.2449D+03, 0.2485D+03, & + 0.2512D+03, 0.2517D+03, 0.2498D+03, 0.2472D+03, & + 0.2452D+03, 0.2425D+03, 0.2395D+03, 0.2400D+03 & + / + data (TREF(20,14, mtmp), mtmp=1,12) & + / & + 0.2370D+03, 0.2385D+03, 0.2409D+03, 0.2465D+03, & + 0.2515D+03, 0.2536D+03, 0.2520D+03, 0.2483D+03, & + 0.2439D+03, 0.2383D+03, 0.2327D+03, 0.2334D+03 & + / + data (TREF(20,15, mtmp), mtmp=1,12) & + / & + 0.2333D+03, 0.2353D+03, 0.2375D+03, 0.2442D+03, & + 0.2516D+03, 0.2557D+03, 0.2549D+03, 0.2500D+03, & + 0.2424D+03, 0.2332D+03, 0.2264D+03, 0.2274D+03 & + / + data (TREF(20,16, mtmp), mtmp=1,12) & + / & + 0.2302D+03, 0.2333D+03, 0.2352D+03, 0.2417D+03, & + 0.2511D+03, 0.2572D+03, 0.2570D+03, 0.2508D+03, & + 0.2394D+03, 0.2271D+03, 0.2207D+03, 0.2230D+03 & + / + data (TREF(20,17, mtmp), mtmp=1,12) & + / & + 0.2272D+03, 0.2322D+03, 0.2332D+03, 0.2390D+03, & + 0.2502D+03, 0.2578D+03, 0.2578D+03, 0.2501D+03, & + 0.2352D+03, 0.2208D+03, 0.2157D+03, 0.2190D+03 & + / + data (TREF(20,18, mtmp), mtmp=1,12) & + / & + 0.2244D+03, 0.2311D+03, 0.2311D+03, 0.2364D+03, & + 0.2488D+03, 0.2573D+03, 0.2576D+03, 0.2491D+03, & + 0.2320D+03, 0.2163D+03, 0.2120D+03, 0.2155D+03 & + / + data (TREF(21, 1, mtmp), mtmp=1,12) & + / & + 0.2715D+03, 0.2597D+03, 0.2386D+03, 0.2249D+03, & + 0.2189D+03, 0.2186D+03, 0.2239D+03, 0.2357D+03, & + 0.2496D+03, 0.2663D+03, 0.2696D+03, 0.2712D+03 & + / + data (TREF(21, 2, mtmp), mtmp=1,12) & + / & + 0.2695D+03, 0.2589D+03, 0.2404D+03, 0.2269D+03, & + 0.2197D+03, 0.2196D+03, 0.2259D+03, 0.2389D+03, & + 0.2513D+03, 0.2633D+03, 0.2668D+03, 0.2695D+03 & + / + data (TREF(21, 3, mtmp), mtmp=1,12) & + / & + 0.2667D+03, 0.2581D+03, 0.2435D+03, 0.2307D+03, & + 0.2211D+03, 0.2197D+03, 0.2267D+03, 0.2398D+03, & + 0.2497D+03, 0.2567D+03, 0.2620D+03, 0.2667D+03 & + / + data (TREF(21, 4, mtmp), mtmp=1,12) & + / & + 0.2633D+03, 0.2571D+03, 0.2463D+03, 0.2357D+03, & + 0.2249D+03, 0.2211D+03, 0.2276D+03, 0.2381D+03, & + 0.2453D+03, 0.2505D+03, 0.2579D+03, 0.2633D+03 & + / + data (TREF(21, 5, mtmp), mtmp=1,12) & + / & + 0.2604D+03, 0.2560D+03, 0.2488D+03, 0.2416D+03, & + 0.2325D+03, 0.2287D+03, 0.2334D+03, 0.2395D+03, & + 0.2439D+03, 0.2487D+03, 0.2561D+03, 0.2606D+03 & + / + data (TREF(21, 6, mtmp), mtmp=1,12) & + / & + 0.2576D+03, 0.2550D+03, 0.2507D+03, 0.2469D+03, & + 0.2414D+03, 0.2398D+03, 0.2422D+03, 0.2447D+03, & + 0.2468D+03, 0.2507D+03, 0.2561D+03, 0.2584D+03 & + / + data (TREF(21, 7, mtmp), mtmp=1,12) & + / & + 0.2553D+03, 0.2546D+03, 0.2530D+03, 0.2517D+03, & + 0.2492D+03, 0.2486D+03, 0.2490D+03, 0.2499D+03, & + 0.2512D+03, 0.2539D+03, 0.2566D+03, 0.2565D+03 & + / + data (TREF(21, 8, mtmp), mtmp=1,12) & + / & + 0.2538D+03, 0.2549D+03, 0.2557D+03, 0.2563D+03, & + 0.2548D+03, 0.2536D+03, 0.2526D+03, 0.2533D+03, & + 0.2546D+03, 0.2565D+03, 0.2573D+03, 0.2555D+03 & + / + data (TREF(21, 9, mtmp), mtmp=1,12) & + / & + 0.2533D+03, 0.2553D+03, 0.2579D+03, 0.2592D+03, & + 0.2578D+03, 0.2559D+03, 0.2545D+03, 0.2551D+03, & + 0.2565D+03, 0.2581D+03, 0.2578D+03, 0.2553D+03 & + / + data (TREF(21,10, mtmp), mtmp=1,12) & + / & + 0.2531D+03, 0.2552D+03, 0.2584D+03, 0.2596D+03, & + 0.2583D+03, 0.2564D+03, 0.2548D+03, 0.2554D+03, & + 0.2567D+03, 0.2580D+03, 0.2575D+03, 0.2549D+03 & + / + data (TREF(21,11, mtmp), mtmp=1,12) & + / & + 0.2524D+03, 0.2542D+03, 0.2571D+03, 0.2581D+03, & + 0.2574D+03, 0.2559D+03, 0.2542D+03, 0.2543D+03, & + 0.2552D+03, 0.2559D+03, 0.2555D+03, 0.2537D+03 & + / + data (TREF(21,12, mtmp), mtmp=1,12) & + / & + 0.2506D+03, 0.2520D+03, 0.2545D+03, 0.2562D+03, & + 0.2568D+03, 0.2560D+03, 0.2541D+03, 0.2530D+03, & + 0.2528D+03, 0.2523D+03, 0.2514D+03, 0.2511D+03 & + / + data (TREF(21,13, mtmp), mtmp=1,12) & + / & + 0.2465D+03, 0.2478D+03, 0.2506D+03, 0.2543D+03, & + 0.2568D+03, 0.2571D+03, 0.2549D+03, 0.2523D+03, & + 0.2505D+03, 0.2479D+03, 0.2448D+03, 0.2455D+03 & + / + data (TREF(21,14, mtmp), mtmp=1,12) & + / & + 0.2415D+03, 0.2429D+03, 0.2461D+03, 0.2523D+03, & + 0.2572D+03, 0.2591D+03, 0.2571D+03, 0.2532D+03, & + 0.2487D+03, 0.2431D+03, 0.2373D+03, 0.2381D+03 & + / + data (TREF(21,15, mtmp), mtmp=1,12) & + / & + 0.2375D+03, 0.2391D+03, 0.2421D+03, 0.2499D+03, & + 0.2573D+03, 0.2612D+03, 0.2601D+03, 0.2549D+03, & + 0.2470D+03, 0.2376D+03, 0.2309D+03, 0.2321D+03 & + / + data (TREF(21,16, mtmp), mtmp=1,12) & + / & + 0.2350D+03, 0.2371D+03, 0.2391D+03, 0.2469D+03, & + 0.2568D+03, 0.2628D+03, 0.2624D+03, 0.2558D+03, & + 0.2438D+03, 0.2314D+03, 0.2255D+03, 0.2282D+03 & + / + data (TREF(21,17, mtmp), mtmp=1,12) & + / & + 0.2326D+03, 0.2361D+03, 0.2367D+03, 0.2436D+03, & + 0.2558D+03, 0.2635D+03, 0.2633D+03, 0.2552D+03, & + 0.2396D+03, 0.2251D+03, 0.2207D+03, 0.2248D+03 & + / + data (TREF(21,18, mtmp), mtmp=1,12) & + / & + 0.2303D+03, 0.2353D+03, 0.2342D+03, 0.2405D+03, & + 0.2544D+03, 0.2630D+03, 0.2632D+03, 0.2544D+03, & + 0.2362D+03, 0.2205D+03, 0.2171D+03, 0.2216D+03 & + / + data (TREF(22, 1, mtmp), mtmp=1,12) & + / & + 0.2795D+03, 0.2672D+03, 0.2454D+03, 0.2322D+03, & + 0.2278D+03, 0.2289D+03, 0.2353D+03, 0.2479D+03, & + 0.2603D+03, 0.2735D+03, 0.2756D+03, 0.2791D+03 & + / + data (TREF(22, 2, mtmp), mtmp=1,12) & + / & + 0.2768D+03, 0.2656D+03, 0.2468D+03, 0.2337D+03, & + 0.2278D+03, 0.2290D+03, 0.2366D+03, 0.2500D+03, & + 0.2604D+03, 0.2694D+03, 0.2722D+03, 0.2766D+03 & + / + data (TREF(22, 3, mtmp), mtmp=1,12) & + / & + 0.2726D+03, 0.2636D+03, 0.2488D+03, 0.2362D+03, & + 0.2275D+03, 0.2272D+03, 0.2355D+03, 0.2485D+03, & + 0.2563D+03, 0.2615D+03, 0.2669D+03, 0.2725D+03 & + / + data (TREF(22, 4, mtmp), mtmp=1,12) & + / & + 0.2682D+03, 0.2615D+03, 0.2508D+03, 0.2401D+03, & + 0.2294D+03, 0.2265D+03, 0.2340D+03, 0.2441D+03, & + 0.2499D+03, 0.2546D+03, 0.2624D+03, 0.2681D+03 & + / + data (TREF(22, 5, mtmp), mtmp=1,12) & + / & + 0.2650D+03, 0.2601D+03, 0.2530D+03, 0.2457D+03, & + 0.2365D+03, 0.2330D+03, 0.2383D+03, 0.2439D+03, & + 0.2477D+03, 0.2530D+03, 0.2609D+03, 0.2653D+03 & + / + data (TREF(22, 6, mtmp), mtmp=1,12) & + / & + 0.2625D+03, 0.2595D+03, 0.2553D+03, 0.2514D+03, & + 0.2458D+03, 0.2444D+03, 0.2469D+03, 0.2490D+03, & + 0.2513D+03, 0.2557D+03, 0.2613D+03, 0.2633D+03 & + / + data (TREF(22, 7, mtmp), mtmp=1,12) & + / & + 0.2609D+03, 0.2599D+03, 0.2583D+03, 0.2568D+03, & + 0.2542D+03, 0.2538D+03, 0.2542D+03, 0.2550D+03, & + 0.2565D+03, 0.2594D+03, 0.2621D+03, 0.2620D+03 & + / + data (TREF(22, 8, mtmp), mtmp=1,12) & + / & + 0.2599D+03, 0.2609D+03, 0.2616D+03, 0.2616D+03, & + 0.2601D+03, 0.2589D+03, 0.2581D+03, 0.2589D+03, & + 0.2603D+03, 0.2621D+03, 0.2628D+03, 0.2612D+03 & + / + data (TREF(22, 9, mtmp), mtmp=1,12) & + / & + 0.2596D+03, 0.2616D+03, 0.2639D+03, 0.2645D+03, & + 0.2630D+03, 0.2611D+03, 0.2599D+03, 0.2607D+03, & + 0.2622D+03, 0.2635D+03, 0.2632D+03, 0.2609D+03 & + / + data (TREF(22,10, mtmp), mtmp=1,12) & + / & + 0.2594D+03, 0.2616D+03, 0.2645D+03, 0.2649D+03, & + 0.2635D+03, 0.2615D+03, 0.2602D+03, 0.2610D+03, & + 0.2624D+03, 0.2635D+03, 0.2629D+03, 0.2606D+03 & + / + data (TREF(22,11, mtmp), mtmp=1,12) & + / & + 0.2588D+03, 0.2604D+03, 0.2631D+03, 0.2633D+03, & + 0.2627D+03, 0.2611D+03, 0.2596D+03, 0.2599D+03, & + 0.2609D+03, 0.2615D+03, 0.2611D+03, 0.2596D+03 & + / + data (TREF(22,12, mtmp), mtmp=1,12) & + / & + 0.2565D+03, 0.2577D+03, 0.2602D+03, 0.2613D+03, & + 0.2620D+03, 0.2611D+03, 0.2591D+03, 0.2581D+03, & + 0.2583D+03, 0.2579D+03, 0.2569D+03, 0.2569D+03 & + / + data (TREF(22,13, mtmp), mtmp=1,12) & + / & + 0.2517D+03, 0.2528D+03, 0.2560D+03, 0.2595D+03, & + 0.2620D+03, 0.2620D+03, 0.2596D+03, 0.2569D+03, & + 0.2554D+03, 0.2531D+03, 0.2499D+03, 0.2509D+03 & + / + data (TREF(22,14, mtmp), mtmp=1,12) & + / & + 0.2459D+03, 0.2471D+03, 0.2510D+03, 0.2577D+03, & + 0.2624D+03, 0.2639D+03, 0.2617D+03, 0.2576D+03, & + 0.2533D+03, 0.2477D+03, 0.2419D+03, 0.2428D+03 & + / + data (TREF(22,15, mtmp), mtmp=1,12) & + / & + 0.2417D+03, 0.2429D+03, 0.2466D+03, 0.2552D+03, & + 0.2625D+03, 0.2661D+03, 0.2648D+03, 0.2594D+03, & + 0.2513D+03, 0.2420D+03, 0.2355D+03, 0.2367D+03 & + / + data (TREF(22,16, mtmp), mtmp=1,12) & + / & + 0.2397D+03, 0.2408D+03, 0.2431D+03, 0.2520D+03, & + 0.2621D+03, 0.2678D+03, 0.2672D+03, 0.2604D+03, & + 0.2483D+03, 0.2358D+03, 0.2306D+03, 0.2335D+03 & + / + data (TREF(22,17, mtmp), mtmp=1,12) & + / & + 0.2380D+03, 0.2400D+03, 0.2403D+03, 0.2482D+03, & + 0.2612D+03, 0.2687D+03, 0.2684D+03, 0.2601D+03, & + 0.2440D+03, 0.2298D+03, 0.2262D+03, 0.2308D+03 & + / + data (TREF(22,18, mtmp), mtmp=1,12) & + / & + 0.2362D+03, 0.2394D+03, 0.2376D+03, 0.2450D+03, & + 0.2598D+03, 0.2685D+03, 0.2685D+03, 0.2595D+03, & + 0.2406D+03, 0.2252D+03, 0.2227D+03, 0.2279D+03 & + / + data (TREF(23, 1, mtmp), mtmp=1,12) & + / & + 0.2855D+03, 0.2732D+03, 0.2516D+03, 0.2392D+03, & + 0.2361D+03, 0.2383D+03, 0.2455D+03, 0.2581D+03, & + 0.2688D+03, 0.2786D+03, 0.2800D+03, 0.2852D+03 & + / + data (TREF(23, 2, mtmp), mtmp=1,12) & + / & + 0.2823D+03, 0.2710D+03, 0.2525D+03, 0.2402D+03, & + 0.2356D+03, 0.2378D+03, 0.2461D+03, 0.2591D+03, & + 0.2674D+03, 0.2736D+03, 0.2763D+03, 0.2821D+03 & + / + data (TREF(23, 3, mtmp), mtmp=1,12) & + / & + 0.2771D+03, 0.2680D+03, 0.2537D+03, 0.2415D+03, & + 0.2338D+03, 0.2344D+03, 0.2435D+03, 0.2557D+03, & + 0.2614D+03, 0.2651D+03, 0.2706D+03, 0.2769D+03 & + / + data (TREF(23, 4, mtmp), mtmp=1,12) & + / & + 0.2719D+03, 0.2649D+03, 0.2547D+03, 0.2443D+03, & + 0.2343D+03, 0.2321D+03, 0.2401D+03, 0.2492D+03, & + 0.2537D+03, 0.2581D+03, 0.2659D+03, 0.2717D+03 & + / + data (TREF(23, 5, mtmp), mtmp=1,12) & + / & + 0.2683D+03, 0.2631D+03, 0.2565D+03, 0.2494D+03, & + 0.2405D+03, 0.2376D+03, 0.2429D+03, 0.2478D+03, & + 0.2512D+03, 0.2567D+03, 0.2646D+03, 0.2686D+03 & + / + data (TREF(23, 6, mtmp), mtmp=1,12) & + / & + 0.2662D+03, 0.2627D+03, 0.2589D+03, 0.2551D+03, & + 0.2498D+03, 0.2486D+03, 0.2510D+03, 0.2528D+03, & + 0.2550D+03, 0.2597D+03, 0.2652D+03, 0.2669D+03 & + / + data (TREF(23, 7, mtmp), mtmp=1,12) & + / & + 0.2650D+03, 0.2636D+03, 0.2622D+03, 0.2606D+03, & + 0.2581D+03, 0.2579D+03, 0.2582D+03, 0.2590D+03, & + 0.2606D+03, 0.2634D+03, 0.2660D+03, 0.2659D+03 & + / + data (TREF(23, 8, mtmp), mtmp=1,12) & + / & + 0.2645D+03, 0.2652D+03, 0.2657D+03, 0.2652D+03, & + 0.2638D+03, 0.2627D+03, 0.2621D+03, 0.2629D+03, & + 0.2643D+03, 0.2660D+03, 0.2666D+03, 0.2653D+03 & + / + data (TREF(23, 9, mtmp), mtmp=1,12) & + / & + 0.2642D+03, 0.2661D+03, 0.2678D+03, 0.2678D+03, & + 0.2663D+03, 0.2645D+03, 0.2636D+03, 0.2645D+03, & + 0.2659D+03, 0.2670D+03, 0.2667D+03, 0.2647D+03 & + / + data (TREF(23,10, mtmp), mtmp=1,12) & + / & + 0.2641D+03, 0.2660D+03, 0.2684D+03, 0.2682D+03, & + 0.2667D+03, 0.2649D+03, 0.2639D+03, 0.2648D+03, & + 0.2661D+03, 0.2670D+03, 0.2664D+03, 0.2644D+03 & + / + data (TREF(23,11, mtmp), mtmp=1,12) & + / & + 0.2635D+03, 0.2649D+03, 0.2672D+03, 0.2668D+03, & + 0.2662D+03, 0.2646D+03, 0.2633D+03, 0.2638D+03, & + 0.2649D+03, 0.2654D+03, 0.2650D+03, 0.2638D+03 & + / + data (TREF(23,12, mtmp), mtmp=1,12) & + / & + 0.2612D+03, 0.2620D+03, 0.2643D+03, 0.2650D+03, & + 0.2657D+03, 0.2646D+03, 0.2627D+03, 0.2618D+03, & + 0.2623D+03, 0.2621D+03, 0.2611D+03, 0.2614D+03 & + / + data (TREF(23,13, mtmp), mtmp=1,12) & + / & + 0.2560D+03, 0.2568D+03, 0.2602D+03, 0.2635D+03, & + 0.2658D+03, 0.2656D+03, 0.2631D+03, 0.2606D+03, & + 0.2594D+03, 0.2573D+03, 0.2543D+03, 0.2554D+03 & + / + data (TREF(23,14, mtmp), mtmp=1,12) & + / & + 0.2498D+03, 0.2509D+03, 0.2553D+03, 0.2620D+03, & + 0.2663D+03, 0.2676D+03, 0.2653D+03, 0.2613D+03, & + 0.2571D+03, 0.2518D+03, 0.2464D+03, 0.2473D+03 & + / + data (TREF(23,15, mtmp), mtmp=1,12) & + / & + 0.2457D+03, 0.2465D+03, 0.2507D+03, 0.2598D+03, & + 0.2667D+03, 0.2699D+03, 0.2684D+03, 0.2631D+03, & + 0.2552D+03, 0.2462D+03, 0.2403D+03, 0.2415D+03 & + / + data (TREF(23,16, mtmp), mtmp=1,12) & + / & + 0.2442D+03, 0.2446D+03, 0.2471D+03, 0.2566D+03, & + 0.2665D+03, 0.2718D+03, 0.2709D+03, 0.2643D+03, & + 0.2524D+03, 0.2405D+03, 0.2361D+03, 0.2389D+03 & + / + data (TREF(23,17, mtmp), mtmp=1,12) & + / & + 0.2433D+03, 0.2439D+03, 0.2441D+03, 0.2528D+03, & + 0.2659D+03, 0.2730D+03, 0.2724D+03, 0.2644D+03, & + 0.2485D+03, 0.2348D+03, 0.2322D+03, 0.2370D+03 & + / + data (TREF(23,18, mtmp), mtmp=1,12) & + / & + 0.2420D+03, 0.2434D+03, 0.2415D+03, 0.2496D+03, & + 0.2648D+03, 0.2730D+03, 0.2728D+03, 0.2640D+03, & + 0.2453D+03, 0.2305D+03, 0.2289D+03, 0.2345D+03 & + / + data (TREF(24, 1, mtmp), mtmp=1,12) & + / & + 0.2892D+03, 0.2774D+03, 0.2567D+03, 0.2454D+03, & + 0.2433D+03, 0.2463D+03, 0.2537D+03, 0.2659D+03, & + 0.2747D+03, 0.2813D+03, 0.2827D+03, 0.2891D+03 & + / + data (TREF(24, 2, mtmp), mtmp=1,12) & + / & + 0.2857D+03, 0.2748D+03, 0.2573D+03, 0.2460D+03, & + 0.2425D+03, 0.2453D+03, 0.2538D+03, 0.2660D+03, & + 0.2720D+03, 0.2758D+03, 0.2787D+03, 0.2855D+03 & + / + data (TREF(24, 3, mtmp), mtmp=1,12) & + / & + 0.2798D+03, 0.2709D+03, 0.2575D+03, 0.2463D+03, & + 0.2398D+03, 0.2411D+03, 0.2502D+03, 0.2610D+03, & + 0.2648D+03, 0.2674D+03, 0.2729D+03, 0.2796D+03 & + / + data (TREF(24, 4, mtmp), mtmp=1,12) & + / & + 0.2740D+03, 0.2671D+03, 0.2578D+03, 0.2481D+03, & + 0.2391D+03, 0.2376D+03, 0.2455D+03, 0.2533D+03, & + 0.2565D+03, 0.2607D+03, 0.2682D+03, 0.2738D+03 & + / + data (TREF(24, 5, mtmp), mtmp=1,12) & + / & + 0.2702D+03, 0.2649D+03, 0.2590D+03, 0.2526D+03, & + 0.2444D+03, 0.2420D+03, 0.2471D+03, 0.2510D+03, & + 0.2540D+03, 0.2596D+03, 0.2670D+03, 0.2706D+03 & + / + data (TREF(24, 6, mtmp), mtmp=1,12) & + / & + 0.2681D+03, 0.2644D+03, 0.2612D+03, 0.2579D+03, & + 0.2529D+03, 0.2521D+03, 0.2542D+03, 0.2555D+03, & + 0.2577D+03, 0.2624D+03, 0.2675D+03, 0.2689D+03 & + / + data (TREF(24, 7, mtmp), mtmp=1,12) & + / & + 0.2673D+03, 0.2656D+03, 0.2644D+03, 0.2629D+03, & + 0.2607D+03, 0.2606D+03, 0.2609D+03, 0.2614D+03, & + 0.2630D+03, 0.2658D+03, 0.2681D+03, 0.2680D+03 & + / + data (TREF(24, 8, mtmp), mtmp=1,12) & + / & + 0.2671D+03, 0.2674D+03, 0.2676D+03, 0.2669D+03, & + 0.2656D+03, 0.2647D+03, 0.2643D+03, 0.2650D+03, & + 0.2664D+03, 0.2678D+03, 0.2684D+03, 0.2674D+03 & + / + data (TREF(24, 9, mtmp), mtmp=1,12) & + / & + 0.2668D+03, 0.2683D+03, 0.2695D+03, 0.2689D+03, & + 0.2675D+03, 0.2659D+03, 0.2653D+03, 0.2662D+03, & + 0.2675D+03, 0.2683D+03, 0.2680D+03, 0.2665D+03 & + / + data (TREF(24,10, mtmp), mtmp=1,12) & + / & + 0.2667D+03, 0.2683D+03, 0.2700D+03, 0.2692D+03, & + 0.2679D+03, 0.2661D+03, 0.2655D+03, 0.2665D+03, & + 0.2677D+03, 0.2683D+03, 0.2678D+03, 0.2663D+03 & + / + data (TREF(24,11, mtmp), mtmp=1,12) & + / & + 0.2664D+03, 0.2673D+03, 0.2691D+03, 0.2683D+03, & + 0.2677D+03, 0.2662D+03, 0.2652D+03, 0.2657D+03, & + 0.2669D+03, 0.2673D+03, 0.2669D+03, 0.2661D+03 & + / + data (TREF(24,12, mtmp), mtmp=1,12) & + / & + 0.2641D+03, 0.2644D+03, 0.2665D+03, 0.2669D+03, & + 0.2675D+03, 0.2664D+03, 0.2647D+03, 0.2640D+03, & + 0.2647D+03, 0.2646D+03, 0.2637D+03, 0.2642D+03 & + / + data (TREF(24,13, mtmp), mtmp=1,12) & + / & + 0.2591D+03, 0.2596D+03, 0.2630D+03, 0.2659D+03, & + 0.2679D+03, 0.2676D+03, 0.2652D+03, 0.2629D+03, & + 0.2621D+03, 0.2604D+03, 0.2575D+03, 0.2587D+03 & + / + data (TREF(24,14, mtmp), mtmp=1,12) & + / & + 0.2530D+03, 0.2538D+03, 0.2586D+03, 0.2650D+03, & + 0.2688D+03, 0.2698D+03, 0.2675D+03, 0.2637D+03, & + 0.2600D+03, 0.2552D+03, 0.2502D+03, 0.2510D+03 & + / + data (TREF(24,15, mtmp), mtmp=1,12) & + / & + 0.2492D+03, 0.2497D+03, 0.2543D+03, 0.2633D+03, & + 0.2695D+03, 0.2722D+03, 0.2706D+03, 0.2657D+03, & + 0.2583D+03, 0.2500D+03, 0.2448D+03, 0.2459D+03 & + / + data (TREF(24,16, mtmp), mtmp=1,12) & + / & + 0.2484D+03, 0.2481D+03, 0.2508D+03, 0.2604D+03, & + 0.2698D+03, 0.2744D+03, 0.2733D+03, 0.2671D+03, & + 0.2560D+03, 0.2450D+03, 0.2414D+03, 0.2441D+03 & + / + data (TREF(24,17, mtmp), mtmp=1,12) & + / & + 0.2482D+03, 0.2476D+03, 0.2480D+03, 0.2570D+03, & + 0.2696D+03, 0.2759D+03, 0.2752D+03, 0.2678D+03, & + 0.2527D+03, 0.2400D+03, 0.2382D+03, 0.2429D+03 & + / + data (TREF(24,18, mtmp), mtmp=1,12) & + / & + 0.2475D+03, 0.2473D+03, 0.2456D+03, 0.2540D+03, & + 0.2689D+03, 0.2764D+03, 0.2759D+03, 0.2678D+03, & + 0.2498D+03, 0.2361D+03, 0.2353D+03, 0.2410D+03 & + / + data (TREF(25, 1, mtmp), mtmp=1,12) & + / & + 0.2902D+03, 0.2794D+03, 0.2605D+03, 0.2507D+03, & + 0.2493D+03, 0.2527D+03, 0.2601D+03, 0.2714D+03, & + 0.2785D+03, 0.2824D+03, 0.2836D+03, 0.2904D+03 & + / + data (TREF(25, 2, mtmp), mtmp=1,12) & + / & + 0.2865D+03, 0.2764D+03, 0.2604D+03, 0.2506D+03, & + 0.2482D+03, 0.2513D+03, 0.2596D+03, 0.2704D+03, & + 0.2746D+03, 0.2766D+03, 0.2794D+03, 0.2865D+03 & + / + data (TREF(25, 3, mtmp), mtmp=1,12) & + / & + 0.2805D+03, 0.2721D+03, 0.2599D+03, 0.2502D+03, & + 0.2450D+03, 0.2467D+03, 0.2553D+03, 0.2645D+03, & + 0.2666D+03, 0.2684D+03, 0.2737D+03, 0.2802D+03 & + / + data (TREF(25, 4, mtmp), mtmp=1,12) & + / & + 0.2744D+03, 0.2678D+03, 0.2595D+03, 0.2511D+03, & + 0.2435D+03, 0.2427D+03, 0.2499D+03, 0.2560D+03, & + 0.2582D+03, 0.2621D+03, 0.2691D+03, 0.2742D+03 & + / + data (TREF(25, 5, mtmp), mtmp=1,12) & + / & + 0.2704D+03, 0.2653D+03, 0.2602D+03, 0.2547D+03, & + 0.2475D+03, 0.2458D+03, 0.2502D+03, 0.2531D+03, & + 0.2556D+03, 0.2611D+03, 0.2678D+03, 0.2709D+03 & + / + data (TREF(25, 6, mtmp), mtmp=1,12) & + / & + 0.2683D+03, 0.2646D+03, 0.2620D+03, 0.2592D+03, & + 0.2548D+03, 0.2542D+03, 0.2560D+03, 0.2569D+03, & + 0.2590D+03, 0.2634D+03, 0.2680D+03, 0.2692D+03 & + / + data (TREF(25, 7, mtmp), mtmp=1,12) & + / & + 0.2676D+03, 0.2658D+03, 0.2647D+03, 0.2635D+03, & + 0.2615D+03, 0.2615D+03, 0.2617D+03, 0.2621D+03, & + 0.2636D+03, 0.2661D+03, 0.2682D+03, 0.2682D+03 & + / + data (TREF(25, 8, mtmp), mtmp=1,12) & + / & + 0.2676D+03, 0.2676D+03, 0.2675D+03, 0.2667D+03, & + 0.2655D+03, 0.2647D+03, 0.2645D+03, 0.2652D+03, & + 0.2664D+03, 0.2675D+03, 0.2681D+03, 0.2675D+03 & + / + data (TREF(25, 9, mtmp), mtmp=1,12) & + / & + 0.2674D+03, 0.2684D+03, 0.2689D+03, 0.2681D+03, & + 0.2668D+03, 0.2654D+03, 0.2651D+03, 0.2660D+03, & + 0.2671D+03, 0.2677D+03, 0.2675D+03, 0.2665D+03 & + / + data (TREF(25,10, mtmp), mtmp=1,12) & + / & + 0.2673D+03, 0.2684D+03, 0.2694D+03, 0.2683D+03, & + 0.2671D+03, 0.2656D+03, 0.2653D+03, 0.2662D+03, & + 0.2672D+03, 0.2677D+03, 0.2673D+03, 0.2663D+03 & + / + data (TREF(25,11, mtmp), mtmp=1,12) & + / & + 0.2670D+03, 0.2675D+03, 0.2687D+03, 0.2677D+03, & + 0.2672D+03, 0.2660D+03, 0.2653D+03, 0.2658D+03, & + 0.2669D+03, 0.2672D+03, 0.2669D+03, 0.2665D+03 & + / + data (TREF(25,12, mtmp), mtmp=1,12) & + / & + 0.2649D+03, 0.2650D+03, 0.2667D+03, 0.2668D+03, & + 0.2674D+03, 0.2664D+03, 0.2649D+03, 0.2643D+03, & + 0.2651D+03, 0.2651D+03, 0.2643D+03, 0.2649D+03 & + / + data (TREF(25,13, mtmp), mtmp=1,12) & + / & + 0.2604D+03, 0.2606D+03, 0.2638D+03, 0.2665D+03, & + 0.2682D+03, 0.2678D+03, 0.2656D+03, 0.2635D+03, & + 0.2629D+03, 0.2616D+03, 0.2591D+03, 0.2601D+03 & + / + data (TREF(25,14, mtmp), mtmp=1,12) & + / & + 0.2549D+03, 0.2556D+03, 0.2603D+03, 0.2662D+03, & + 0.2695D+03, 0.2702D+03, 0.2680D+03, 0.2646D+03, & + 0.2613D+03, 0.2572D+03, 0.2529D+03, 0.2535D+03 & + / + data (TREF(25,15, mtmp), mtmp=1,12) & + / & + 0.2518D+03, 0.2522D+03, 0.2567D+03, 0.2651D+03, & + 0.2706D+03, 0.2729D+03, 0.2713D+03, 0.2667D+03, & + 0.2601D+03, 0.2528D+03, 0.2486D+03, 0.2494D+03 & + / + data (TREF(25,16, mtmp), mtmp=1,12) & + / & + 0.2517D+03, 0.2512D+03, 0.2539D+03, 0.2629D+03, & + 0.2714D+03, 0.2753D+03, 0.2742D+03, 0.2686D+03, & + 0.2584D+03, 0.2488D+03, 0.2462D+03, 0.2487D+03 & + / + data (TREF(25,17, mtmp), mtmp=1,12) & + / & + 0.2523D+03, 0.2512D+03, 0.2516D+03, 0.2601D+03, & + 0.2718D+03, 0.2773D+03, 0.2765D+03, 0.2698D+03, & + 0.2560D+03, 0.2449D+03, 0.2440D+03, 0.2483D+03 & + / + data (TREF(25,18, mtmp), mtmp=1,12) & + / & + 0.2522D+03, 0.2515D+03, 0.2498D+03, 0.2577D+03, & + 0.2716D+03, 0.2782D+03, 0.2776D+03, 0.2703D+03, & + 0.2539D+03, 0.2418D+03, 0.2417D+03, 0.2470D+03 & + / + data (TREF(26, 1, mtmp), mtmp=1,12) & + / & + 0.2884D+03, 0.2789D+03, 0.2624D+03, 0.2546D+03, & + 0.2538D+03, 0.2573D+03, 0.2642D+03, 0.2744D+03, & + 0.2803D+03, 0.2822D+03, 0.2828D+03, 0.2889D+03 & + / + data (TREF(26, 2, mtmp), mtmp=1,12) & + / & + 0.2846D+03, 0.2756D+03, 0.2615D+03, 0.2537D+03, & + 0.2522D+03, 0.2556D+03, 0.2631D+03, 0.2724D+03, & + 0.2756D+03, 0.2763D+03, 0.2784D+03, 0.2848D+03 & + / + data (TREF(26, 3, mtmp), mtmp=1,12) & + / & + 0.2787D+03, 0.2712D+03, 0.2604D+03, 0.2525D+03, & + 0.2489D+03, 0.2510D+03, 0.2586D+03, 0.2660D+03, & + 0.2671D+03, 0.2683D+03, 0.2729D+03, 0.2787D+03 & + / + data (TREF(26, 4, mtmp), mtmp=1,12) & + / & + 0.2728D+03, 0.2670D+03, 0.2595D+03, 0.2527D+03, & + 0.2469D+03, 0.2468D+03, 0.2529D+03, 0.2573D+03, & + 0.2586D+03, 0.2622D+03, 0.2684D+03, 0.2729D+03 & + / + data (TREF(26, 5, mtmp), mtmp=1,12) & + / & + 0.2687D+03, 0.2642D+03, 0.2597D+03, 0.2554D+03, & + 0.2496D+03, 0.2484D+03, 0.2519D+03, 0.2537D+03, & + 0.2558D+03, 0.2608D+03, 0.2668D+03, 0.2695D+03 & + / + data (TREF(26, 6, mtmp), mtmp=1,12) & + / & + 0.2665D+03, 0.2632D+03, 0.2608D+03, 0.2588D+03, & + 0.2550D+03, 0.2546D+03, 0.2560D+03, 0.2564D+03, & + 0.2584D+03, 0.2624D+03, 0.2665D+03, 0.2676D+03 & + / + data (TREF(26, 7, mtmp), mtmp=1,12) & + / & + 0.2658D+03, 0.2640D+03, 0.2628D+03, 0.2620D+03, & + 0.2602D+03, 0.2602D+03, 0.2604D+03, 0.2607D+03, & + 0.2620D+03, 0.2642D+03, 0.2662D+03, 0.2664D+03 & + / + data (TREF(26, 8, mtmp), mtmp=1,12) & + / & + 0.2659D+03, 0.2656D+03, 0.2651D+03, 0.2645D+03, & + 0.2635D+03, 0.2629D+03, 0.2627D+03, 0.2634D+03, & + 0.2642D+03, 0.2651D+03, 0.2658D+03, 0.2656D+03 & + / + data (TREF(26, 9, mtmp), mtmp=1,12) & + / & + 0.2658D+03, 0.2664D+03, 0.2663D+03, 0.2655D+03, & + 0.2645D+03, 0.2633D+03, 0.2632D+03, 0.2641D+03, & + 0.2647D+03, 0.2652D+03, 0.2652D+03, 0.2648D+03 & + / + data (TREF(26,10, mtmp), mtmp=1,12) & + / & + 0.2657D+03, 0.2664D+03, 0.2667D+03, 0.2656D+03, & + 0.2646D+03, 0.2635D+03, 0.2634D+03, 0.2642D+03, & + 0.2649D+03, 0.2652D+03, 0.2650D+03, 0.2646D+03 & + / + data (TREF(26,11, mtmp), mtmp=1,12) & + / & + 0.2654D+03, 0.2655D+03, 0.2662D+03, 0.2652D+03, & + 0.2648D+03, 0.2639D+03, 0.2634D+03, 0.2639D+03, & + 0.2646D+03, 0.2649D+03, 0.2648D+03, 0.2647D+03 & + / + data (TREF(26,12, mtmp), mtmp=1,12) & + / & + 0.2634D+03, 0.2633D+03, 0.2646D+03, 0.2647D+03, & + 0.2652D+03, 0.2646D+03, 0.2632D+03, 0.2627D+03, & + 0.2633D+03, 0.2634D+03, 0.2627D+03, 0.2632D+03 & + / + data (TREF(26,13, mtmp), mtmp=1,12) & + / & + 0.2594D+03, 0.2598D+03, 0.2626D+03, 0.2650D+03, & + 0.2664D+03, 0.2661D+03, 0.2641D+03, 0.2622D+03, & + 0.2616D+03, 0.2608D+03, 0.2587D+03, 0.2592D+03 & + / + data (TREF(26,14, mtmp), mtmp=1,12) & + / & + 0.2550D+03, 0.2558D+03, 0.2600D+03, 0.2653D+03, & + 0.2680D+03, 0.2687D+03, 0.2666D+03, 0.2634D+03, & + 0.2606D+03, 0.2575D+03, 0.2541D+03, 0.2542D+03 & + / + data (TREF(26,15, mtmp), mtmp=1,12) & + / & + 0.2529D+03, 0.2536D+03, 0.2575D+03, 0.2649D+03, & + 0.2696D+03, 0.2717D+03, 0.2701D+03, 0.2659D+03, & + 0.2600D+03, 0.2541D+03, 0.2511D+03, 0.2516D+03 & + / + data (TREF(26,16, mtmp), mtmp=1,12) & + / & + 0.2537D+03, 0.2537D+03, 0.2558D+03, 0.2635D+03, & + 0.2710D+03, 0.2745D+03, 0.2735D+03, 0.2683D+03, & + 0.2593D+03, 0.2514D+03, 0.2499D+03, 0.2520D+03 & + / + data (TREF(26,17, mtmp), mtmp=1,12) & + / & + 0.2550D+03, 0.2548D+03, 0.2547D+03, 0.2617D+03, & + 0.2720D+03, 0.2768D+03, 0.2761D+03, 0.2700D+03, & + 0.2580D+03, 0.2489D+03, 0.2488D+03, 0.2525D+03 & + / + data (TREF(26,18, mtmp), mtmp=1,12) & + / & + 0.2557D+03, 0.2560D+03, 0.2540D+03, 0.2602D+03, & + 0.2724D+03, 0.2782D+03, 0.2777D+03, 0.2712D+03, & + 0.2569D+03, 0.2471D+03, 0.2477D+03, 0.2521D+03 & + / + data (TREF(27, 1, mtmp), mtmp=1,12) & + / & + 0.2838D+03, 0.2760D+03, 0.2624D+03, 0.2573D+03, & + 0.2570D+03, 0.2610D+03, 0.2673D+03, 0.2759D+03, & + 0.2807D+03, 0.2798D+03, 0.2797D+03, 0.2845D+03 & + / + data (TREF(27, 2, mtmp), mtmp=1,12) & + / & + 0.2800D+03, 0.2725D+03, 0.2606D+03, 0.2553D+03, & + 0.2551D+03, 0.2590D+03, 0.2655D+03, 0.2726D+03, & + 0.2747D+03, 0.2741D+03, 0.2753D+03, 0.2804D+03 & + / + data (TREF(27, 3, mtmp), mtmp=1,12) & + / & + 0.2749D+03, 0.2684D+03, 0.2588D+03, 0.2533D+03, & + 0.2520D+03, 0.2547D+03, 0.2609D+03, 0.2657D+03, & + 0.2657D+03, 0.2664D+03, 0.2701D+03, 0.2749D+03 & + / + data (TREF(27, 4, mtmp), mtmp=1,12) & + / & + 0.2695D+03, 0.2643D+03, 0.2576D+03, 0.2528D+03, & + 0.2495D+03, 0.2504D+03, 0.2550D+03, 0.2569D+03, & + 0.2573D+03, 0.2606D+03, 0.2660D+03, 0.2699D+03 & + / + data (TREF(27, 5, mtmp), mtmp=1,12) & + / & + 0.2654D+03, 0.2613D+03, 0.2574D+03, 0.2546D+03, & + 0.2504D+03, 0.2501D+03, 0.2524D+03, 0.2524D+03, & + 0.2543D+03, 0.2588D+03, 0.2640D+03, 0.2665D+03 & + / + data (TREF(27, 6, mtmp), mtmp=1,12) & + / & + 0.2630D+03, 0.2601D+03, 0.2579D+03, 0.2567D+03, & + 0.2537D+03, 0.2535D+03, 0.2542D+03, 0.2540D+03, & + 0.2558D+03, 0.2594D+03, 0.2631D+03, 0.2643D+03 & + / + data (TREF(27, 7, mtmp), mtmp=1,12) & + / & + 0.2623D+03, 0.2606D+03, 0.2592D+03, 0.2588D+03, & + 0.2574D+03, 0.2573D+03, 0.2573D+03, 0.2574D+03, & + 0.2584D+03, 0.2602D+03, 0.2622D+03, 0.2630D+03 & + / + data (TREF(27, 8, mtmp), mtmp=1,12) & + / & + 0.2628D+03, 0.2621D+03, 0.2610D+03, 0.2607D+03, & + 0.2600D+03, 0.2594D+03, 0.2593D+03, 0.2598D+03, & + 0.2602D+03, 0.2608D+03, 0.2617D+03, 0.2624D+03 & + / + data (TREF(27, 9, mtmp), mtmp=1,12) & + / & + 0.2633D+03, 0.2630D+03, 0.2622D+03, 0.2615D+03, & + 0.2609D+03, 0.2599D+03, 0.2601D+03, 0.2608D+03, & + 0.2608D+03, 0.2611D+03, 0.2615D+03, 0.2621D+03 & + / + data (TREF(27,10, mtmp), mtmp=1,12) & + / & + 0.2631D+03, 0.2630D+03, 0.2626D+03, 0.2616D+03, & + 0.2608D+03, 0.2600D+03, 0.2602D+03, 0.2609D+03, & + 0.2610D+03, 0.2612D+03, 0.2615D+03, 0.2620D+03 & + / + data (TREF(27,11, mtmp), mtmp=1,12) & + / & + 0.2622D+03, 0.2620D+03, 0.2619D+03, 0.2609D+03, & + 0.2607D+03, 0.2603D+03, 0.2601D+03, 0.2604D+03, & + 0.2606D+03, 0.2609D+03, 0.2610D+03, 0.2615D+03 & + / + data (TREF(27,12, mtmp), mtmp=1,12) & + / & + 0.2598D+03, 0.2598D+03, 0.2605D+03, 0.2605D+03, & + 0.2610D+03, 0.2609D+03, 0.2598D+03, 0.2593D+03, & + 0.2594D+03, 0.2597D+03, 0.2593D+03, 0.2596D+03 & + / + data (TREF(27,13, mtmp), mtmp=1,12) & + / & + 0.2562D+03, 0.2569D+03, 0.2592D+03, 0.2614D+03, & + 0.2625D+03, 0.2625D+03, 0.2607D+03, 0.2589D+03, & + 0.2583D+03, 0.2580D+03, 0.2564D+03, 0.2562D+03 & + / + data (TREF(27,14, mtmp), mtmp=1,12) & + / & + 0.2528D+03, 0.2540D+03, 0.2577D+03, 0.2624D+03, & + 0.2646D+03, 0.2653D+03, 0.2632D+03, 0.2602D+03, & + 0.2578D+03, 0.2559D+03, 0.2538D+03, 0.2529D+03 & + / + data (TREF(27,15, mtmp), mtmp=1,12) & + / & + 0.2520D+03, 0.2534D+03, 0.2565D+03, 0.2626D+03, & + 0.2667D+03, 0.2687D+03, 0.2671D+03, 0.2630D+03, & + 0.2579D+03, 0.2539D+03, 0.2524D+03, 0.2523D+03 & + / + data (TREF(27,16, mtmp), mtmp=1,12) & + / & + 0.2540D+03, 0.2552D+03, 0.2563D+03, 0.2621D+03, & + 0.2685D+03, 0.2718D+03, 0.2709D+03, 0.2660D+03, & + 0.2582D+03, 0.2525D+03, 0.2526D+03, 0.2541D+03 & + / + data (TREF(27,17, mtmp), mtmp=1,12) & + / & + 0.2563D+03, 0.2580D+03, 0.2569D+03, 0.2615D+03, & + 0.2701D+03, 0.2744D+03, 0.2739D+03, 0.2685D+03, & + 0.2583D+03, 0.2519D+03, 0.2530D+03, 0.2558D+03 & + / + data (TREF(27,18, mtmp), mtmp=1,12) & + / & + 0.2578D+03, 0.2608D+03, 0.2575D+03, 0.2609D+03, & + 0.2714D+03, 0.2763D+03, 0.2760D+03, 0.2704D+03, & + 0.2587D+03, 0.2518D+03, 0.2532D+03, 0.2563D+03 & + / + data (TREF(28, 1, mtmp), mtmp=1,12) & + / & + 0.2760D+03, 0.2707D+03, 0.2599D+03, 0.2583D+03, & + 0.2593D+03, 0.2649D+03, 0.2708D+03, 0.2774D+03, & + 0.2793D+03, 0.2733D+03, 0.2727D+03, 0.2764D+03 & + / + data (TREF(28, 2, mtmp), mtmp=1,12) & + / & + 0.2727D+03, 0.2671D+03, 0.2573D+03, 0.2553D+03, & + 0.2577D+03, 0.2630D+03, 0.2683D+03, 0.2719D+03, & + 0.2710D+03, 0.2678D+03, 0.2688D+03, 0.2728D+03 & + / + data (TREF(28, 3, mtmp), mtmp=1,12) & + / & + 0.2687D+03, 0.2633D+03, 0.2549D+03, 0.2522D+03, & + 0.2547D+03, 0.2590D+03, 0.2635D+03, 0.2638D+03, & + 0.2612D+03, 0.2613D+03, 0.2645D+03, 0.2686D+03 & + / + data (TREF(28, 4, mtmp), mtmp=1,12) & + / & + 0.2642D+03, 0.2593D+03, 0.2533D+03, 0.2508D+03, & + 0.2512D+03, 0.2540D+03, 0.2566D+03, 0.2541D+03, & + 0.2530D+03, 0.2564D+03, 0.2610D+03, 0.2646D+03 & + / + data (TREF(28, 5, mtmp), mtmp=1,12) & + / & + 0.2601D+03, 0.2561D+03, 0.2527D+03, 0.2516D+03, & + 0.2498D+03, 0.2510D+03, 0.2514D+03, 0.2484D+03, & + 0.2500D+03, 0.2546D+03, 0.2589D+03, 0.2614D+03 & + / + data (TREF(28, 6, mtmp), mtmp=1,12) & + / & + 0.2577D+03, 0.2548D+03, 0.2529D+03, 0.2528D+03, & + 0.2509D+03, 0.2513D+03, 0.2506D+03, 0.2489D+03, & + 0.2509D+03, 0.2542D+03, 0.2575D+03, 0.2591D+03 & + / + data (TREF(28, 7, mtmp), mtmp=1,12) & + / & + 0.2576D+03, 0.2557D+03, 0.2541D+03, 0.2540D+03, & + 0.2532D+03, 0.2532D+03, 0.2526D+03, 0.2520D+03, & + 0.2528D+03, 0.2542D+03, 0.2562D+03, 0.2581D+03 & + / + data (TREF(28, 8, mtmp), mtmp=1,12) & + / & + 0.2596D+03, 0.2579D+03, 0.2561D+03, 0.2555D+03, & + 0.2553D+03, 0.2548D+03, 0.2548D+03, 0.2549D+03, & + 0.2546D+03, 0.2547D+03, 0.2561D+03, 0.2585D+03 & + / + data (TREF(28, 9, mtmp), mtmp=1,12) & + / & + 0.2614D+03, 0.2596D+03, 0.2576D+03, 0.2564D+03, & + 0.2563D+03, 0.2556D+03, 0.2562D+03, 0.2567D+03, & + 0.2558D+03, 0.2557D+03, 0.2568D+03, 0.2594D+03 & + / + data (TREF(28,10, mtmp), mtmp=1,12) & + / & + 0.2610D+03, 0.2594D+03, 0.2577D+03, 0.2562D+03, & + 0.2560D+03, 0.2556D+03, 0.2565D+03, 0.2569D+03, & + 0.2559D+03, 0.2558D+03, 0.2569D+03, 0.2593D+03 & + / + data (TREF(28,11, mtmp), mtmp=1,12) & + / & + 0.2587D+03, 0.2574D+03, 0.2563D+03, 0.2549D+03, & + 0.2550D+03, 0.2552D+03, 0.2555D+03, 0.2557D+03, & + 0.2551D+03, 0.2553D+03, 0.2560D+03, 0.2577D+03 & + / + data (TREF(28,12, mtmp), mtmp=1,12) & + / & + 0.2549D+03, 0.2545D+03, 0.2546D+03, 0.2543D+03, & + 0.2550D+03, 0.2553D+03, 0.2545D+03, 0.2540D+03, & + 0.2538D+03, 0.2543D+03, 0.2543D+03, 0.2546D+03 & + / + data (TREF(28,13, mtmp), mtmp=1,12) & + / & + 0.2506D+03, 0.2513D+03, 0.2535D+03, 0.2557D+03, & + 0.2564D+03, 0.2566D+03, 0.2549D+03, 0.2533D+03, & + 0.2527D+03, 0.2533D+03, 0.2526D+03, 0.2511D+03 & + / + data (TREF(28,14, mtmp), mtmp=1,12) & + / & + 0.2475D+03, 0.2492D+03, 0.2529D+03, 0.2573D+03, & + 0.2587D+03, 0.2595D+03, 0.2574D+03, 0.2544D+03, & + 0.2524D+03, 0.2523D+03, 0.2519D+03, 0.2495D+03 & + / + data (TREF(28,15, mtmp), mtmp=1,12) & + / & + 0.2480D+03, 0.2504D+03, 0.2529D+03, 0.2579D+03, & + 0.2613D+03, 0.2633D+03, 0.2616D+03, 0.2574D+03, & + 0.2530D+03, 0.2514D+03, 0.2523D+03, 0.2512D+03 & + / + data (TREF(28,16, mtmp), mtmp=1,12) & + / & + 0.2517D+03, 0.2547D+03, 0.2543D+03, 0.2582D+03, & + 0.2637D+03, 0.2666D+03, 0.2659D+03, 0.2613D+03, & + 0.2543D+03, 0.2515D+03, 0.2541D+03, 0.2550D+03 & + / + data (TREF(28,17, mtmp), mtmp=1,12) & + / & + 0.2555D+03, 0.2600D+03, 0.2567D+03, 0.2586D+03, & + 0.2660D+03, 0.2695D+03, 0.2692D+03, 0.2646D+03, & + 0.2561D+03, 0.2530D+03, 0.2562D+03, 0.2580D+03 & + / + data (TREF(28,18, mtmp), mtmp=1,12) & + / & + 0.2583D+03, 0.2651D+03, 0.2589D+03, 0.2588D+03, & + 0.2681D+03, 0.2718D+03, 0.2718D+03, 0.2674D+03, & + 0.2581D+03, 0.2550D+03, 0.2577D+03, 0.2594D+03 & + / + data (TREF(29, 1, mtmp), mtmp=1,12) & + / & + 0.2695D+03, 0.2650D+03, 0.2561D+03, 0.2545D+03, & + 0.2549D+03, 0.2591D+03, 0.2635D+03, 0.2683D+03, & + 0.2692D+03, 0.2650D+03, 0.2659D+03, 0.2702D+03 & + / + data (TREF(29, 2, mtmp), mtmp=1,12) & + / & + 0.2665D+03, 0.2617D+03, 0.2535D+03, 0.2518D+03, & + 0.2535D+03, 0.2576D+03, 0.2616D+03, 0.2639D+03, & + 0.2626D+03, 0.2607D+03, 0.2627D+03, 0.2670D+03 & + / + data (TREF(29, 3, mtmp), mtmp=1,12) & + / & + 0.2625D+03, 0.2578D+03, 0.2506D+03, 0.2485D+03, & + 0.2508D+03, 0.2544D+03, 0.2579D+03, 0.2577D+03, & + 0.2554D+03, 0.2559D+03, 0.2590D+03, 0.2628D+03 & + / + data (TREF(29, 4, mtmp), mtmp=1,12) & + / & + 0.2580D+03, 0.2535D+03, 0.2480D+03, 0.2466D+03, & + 0.2477D+03, 0.2505D+03, 0.2526D+03, 0.2502D+03, & + 0.2493D+03, 0.2522D+03, 0.2559D+03, 0.2588D+03 & + / + data (TREF(29, 5, mtmp), mtmp=1,12) & + / & + 0.2539D+03, 0.2502D+03, 0.2469D+03, 0.2468D+03, & + 0.2461D+03, 0.2478D+03, 0.2480D+03, 0.2453D+03, & + 0.2467D+03, 0.2503D+03, 0.2537D+03, 0.2556D+03 & + / + data (TREF(29, 6, mtmp), mtmp=1,12) & + / & + 0.2521D+03, 0.2496D+03, 0.2480D+03, 0.2482D+03, & + 0.2471D+03, 0.2478D+03, 0.2470D+03, 0.2454D+03, & + 0.2470D+03, 0.2496D+03, 0.2521D+03, 0.2535D+03 & + / + data (TREF(29, 7, mtmp), mtmp=1,12) & + / & + 0.2527D+03, 0.2513D+03, 0.2504D+03, 0.2500D+03, & + 0.2492D+03, 0.2488D+03, 0.2482D+03, 0.2475D+03, & + 0.2479D+03, 0.2491D+03, 0.2509D+03, 0.2527D+03 & + / + data (TREF(29, 8, mtmp), mtmp=1,12) & + / & + 0.2546D+03, 0.2535D+03, 0.2523D+03, 0.2513D+03, & + 0.2508D+03, 0.2499D+03, 0.2497D+03, 0.2495D+03, & + 0.2489D+03, 0.2493D+03, 0.2508D+03, 0.2533D+03 & + / + data (TREF(29, 9, mtmp), mtmp=1,12) & + / & + 0.2558D+03, 0.2543D+03, 0.2527D+03, 0.2514D+03, & + 0.2512D+03, 0.2505D+03, 0.2509D+03, 0.2512D+03, & + 0.2503D+03, 0.2502D+03, 0.2514D+03, 0.2540D+03 & + / + data (TREF(29,10, mtmp), mtmp=1,12) & + / & + 0.2551D+03, 0.2535D+03, 0.2518D+03, 0.2507D+03, & + 0.2507D+03, 0.2506D+03, 0.2516D+03, 0.2520D+03, & + 0.2513D+03, 0.2509D+03, 0.2517D+03, 0.2537D+03 & + / + data (TREF(29,11, mtmp), mtmp=1,12) & + / & + 0.2530D+03, 0.2516D+03, 0.2503D+03, 0.2494D+03, & + 0.2499D+03, 0.2504D+03, 0.2511D+03, 0.2516D+03, & + 0.2514D+03, 0.2511D+03, 0.2512D+03, 0.2523D+03 & + / + data (TREF(29,12, mtmp), mtmp=1,12) & + / & + 0.2500D+03, 0.2495D+03, 0.2493D+03, 0.2492D+03, & + 0.2499D+03, 0.2503D+03, 0.2500D+03, 0.2499D+03, & + 0.2501D+03, 0.2502D+03, 0.2500D+03, 0.2499D+03 & + / + data (TREF(29,13, mtmp), mtmp=1,12) & + / & + 0.2468D+03, 0.2473D+03, 0.2491D+03, 0.2508D+03, & + 0.2512D+03, 0.2513D+03, 0.2497D+03, 0.2483D+03, & + 0.2477D+03, 0.2486D+03, 0.2484D+03, 0.2473D+03 & + / + data (TREF(29,14, mtmp), mtmp=1,12) & + / & + 0.2443D+03, 0.2458D+03, 0.2491D+03, 0.2525D+03, & + 0.2534D+03, 0.2539D+03, 0.2517D+03, 0.2487D+03, & + 0.2466D+03, 0.2473D+03, 0.2476D+03, 0.2460D+03 & + / + data (TREF(29,15, mtmp), mtmp=1,12) & + / & + 0.2449D+03, 0.2471D+03, 0.2493D+03, 0.2533D+03, & + 0.2561D+03, 0.2577D+03, 0.2558D+03, 0.2519D+03, & + 0.2478D+03, 0.2470D+03, 0.2483D+03, 0.2477D+03 & + / + data (TREF(29,16, mtmp), mtmp=1,12) & + / & + 0.2476D+03, 0.2504D+03, 0.2500D+03, 0.2536D+03, & + 0.2585D+03, 0.2614D+03, 0.2604D+03, 0.2562D+03, & + 0.2501D+03, 0.2480D+03, 0.2502D+03, 0.2507D+03 & + / + data (TREF(29,17, mtmp), mtmp=1,12) & + / & + 0.2507D+03, 0.2544D+03, 0.2512D+03, 0.2536D+03, & + 0.2607D+03, 0.2646D+03, 0.2640D+03, 0.2598D+03, & + 0.2526D+03, 0.2500D+03, 0.2524D+03, 0.2533D+03 & + / + data (TREF(29,18, mtmp), mtmp=1,12) & + / & + 0.2529D+03, 0.2585D+03, 0.2527D+03, 0.2536D+03, & + 0.2625D+03, 0.2668D+03, 0.2664D+03, 0.2626D+03, & + 0.2547D+03, 0.2520D+03, 0.2538D+03, 0.2544D+03 & + / + data (TREF(30, 1, mtmp), mtmp=1,12) & + / & + 0.2633D+03, 0.2593D+03, 0.2520D+03, 0.2500D+03, & + 0.2495D+03, 0.2519D+03, 0.2547D+03, 0.2577D+03, & + 0.2578D+03, 0.2566D+03, 0.2592D+03, 0.2644D+03 & + / + data (TREF(30, 2, mtmp), mtmp=1,12) & + / & + 0.2606D+03, 0.2564D+03, 0.2497D+03, 0.2477D+03, & + 0.2484D+03, 0.2508D+03, 0.2535D+03, 0.2548D+03, & + 0.2535D+03, 0.2537D+03, 0.2567D+03, 0.2615D+03 & + / + data (TREF(30, 3, mtmp), mtmp=1,12) & + / & + 0.2564D+03, 0.2523D+03, 0.2463D+03, 0.2445D+03, & + 0.2459D+03, 0.2484D+03, 0.2512D+03, 0.2511D+03, & + 0.2495D+03, 0.2506D+03, 0.2536D+03, 0.2572D+03 & + / + data (TREF(30, 4, mtmp), mtmp=1,12) & + / & + 0.2517D+03, 0.2475D+03, 0.2427D+03, 0.2421D+03, & + 0.2434D+03, 0.2460D+03, 0.2478D+03, 0.2462D+03, & + 0.2457D+03, 0.2479D+03, 0.2508D+03, 0.2530D+03 & + / + data (TREF(30, 5, mtmp), mtmp=1,12) & + / & + 0.2477D+03, 0.2442D+03, 0.2410D+03, 0.2417D+03, & + 0.2419D+03, 0.2439D+03, 0.2443D+03, 0.2424D+03, & + 0.2437D+03, 0.2461D+03, 0.2484D+03, 0.2496D+03 & + / + data (TREF(30, 6, mtmp), mtmp=1,12) & + / & + 0.2465D+03, 0.2444D+03, 0.2430D+03, 0.2436D+03, & + 0.2432D+03, 0.2441D+03, 0.2435D+03, 0.2422D+03, & + 0.2433D+03, 0.2451D+03, 0.2469D+03, 0.2477D+03 & + / + data (TREF(30, 7, mtmp), mtmp=1,12) & + / & + 0.2477D+03, 0.2471D+03, 0.2468D+03, 0.2462D+03, & + 0.2452D+03, 0.2445D+03, 0.2438D+03, 0.2430D+03, & + 0.2432D+03, 0.2442D+03, 0.2458D+03, 0.2473D+03 & + / + data (TREF(30, 8, mtmp), mtmp=1,12) & + / & + 0.2493D+03, 0.2491D+03, 0.2487D+03, 0.2473D+03, & + 0.2462D+03, 0.2449D+03, 0.2444D+03, 0.2440D+03, & + 0.2432D+03, 0.2439D+03, 0.2455D+03, 0.2478D+03 & + / + data (TREF(30, 9, mtmp), mtmp=1,12) & + / & + 0.2497D+03, 0.2488D+03, 0.2478D+03, 0.2465D+03, & + 0.2461D+03, 0.2452D+03, 0.2454D+03, 0.2455D+03, & + 0.2446D+03, 0.2448D+03, 0.2460D+03, 0.2481D+03 & + / + data (TREF(30,10, mtmp), mtmp=1,12) & + / & + 0.2486D+03, 0.2472D+03, 0.2458D+03, 0.2452D+03, & + 0.2454D+03, 0.2456D+03, 0.2465D+03, 0.2470D+03, & + 0.2467D+03, 0.2462D+03, 0.2464D+03, 0.2476D+03 & + / + data (TREF(30,11, mtmp), mtmp=1,12) & + / & + 0.2469D+03, 0.2456D+03, 0.2443D+03, 0.2440D+03, & + 0.2448D+03, 0.2457D+03, 0.2467D+03, 0.2476D+03, & + 0.2480D+03, 0.2471D+03, 0.2466D+03, 0.2468D+03 & + / + data (TREF(30,12, mtmp), mtmp=1,12) & + / & + 0.2452D+03, 0.2445D+03, 0.2442D+03, 0.2443D+03, & + 0.2450D+03, 0.2455D+03, 0.2457D+03, 0.2460D+03, & + 0.2466D+03, 0.2463D+03, 0.2458D+03, 0.2453D+03 & + / + data (TREF(30,13, mtmp), mtmp=1,12) & + / & + 0.2433D+03, 0.2436D+03, 0.2449D+03, 0.2460D+03, & + 0.2462D+03, 0.2461D+03, 0.2447D+03, 0.2435D+03, & + 0.2429D+03, 0.2439D+03, 0.2442D+03, 0.2438D+03 & + / + data (TREF(30,14, mtmp), mtmp=1,12) & + / & + 0.2415D+03, 0.2428D+03, 0.2454D+03, 0.2477D+03, & + 0.2483D+03, 0.2484D+03, 0.2460D+03, 0.2431D+03, & + 0.2408D+03, 0.2420D+03, 0.2431D+03, 0.2426D+03 & + / + data (TREF(30,15, mtmp), mtmp=1,12) & + / & + 0.2419D+03, 0.2439D+03, 0.2457D+03, 0.2488D+03, & + 0.2509D+03, 0.2522D+03, 0.2500D+03, 0.2463D+03, & + 0.2425D+03, 0.2424D+03, 0.2438D+03, 0.2438D+03 & + / + data (TREF(30,16, mtmp), mtmp=1,12) & + / & + 0.2434D+03, 0.2456D+03, 0.2454D+03, 0.2488D+03, & + 0.2532D+03, 0.2561D+03, 0.2548D+03, 0.2511D+03, & + 0.2460D+03, 0.2441D+03, 0.2455D+03, 0.2456D+03 & + / + data (TREF(30,17, mtmp), mtmp=1,12) & + / & + 0.2452D+03, 0.2477D+03, 0.2449D+03, 0.2483D+03, & + 0.2552D+03, 0.2597D+03, 0.2586D+03, 0.2550D+03, & + 0.2490D+03, 0.2464D+03, 0.2475D+03, 0.2476D+03 & + / + data (TREF(30,18, mtmp), mtmp=1,12) & + / & + 0.2466D+03, 0.2503D+03, 0.2454D+03, 0.2480D+03, & + 0.2566D+03, 0.2619D+03, 0.2610D+03, 0.2575D+03, & + 0.2510D+03, 0.2481D+03, 0.2487D+03, 0.2483D+03 & + / + data (TREF(31, 1, mtmp), mtmp=1,12) & + / & + 0.2571D+03, 0.2536D+03, 0.2480D+03, 0.2456D+03, & + 0.2441D+03, 0.2446D+03, 0.2458D+03, 0.2471D+03, & + 0.2465D+03, 0.2483D+03, 0.2525D+03, 0.2586D+03 & + / + data (TREF(31, 2, mtmp), mtmp=1,12) & + / & + 0.2546D+03, 0.2511D+03, 0.2458D+03, 0.2437D+03, & + 0.2432D+03, 0.2440D+03, 0.2454D+03, 0.2458D+03, & + 0.2444D+03, 0.2466D+03, 0.2507D+03, 0.2560D+03 & + / + data (TREF(31, 3, mtmp), mtmp=1,12) & + / & + 0.2503D+03, 0.2468D+03, 0.2420D+03, 0.2405D+03, & + 0.2411D+03, 0.2424D+03, 0.2444D+03, 0.2445D+03, & + 0.2436D+03, 0.2453D+03, 0.2482D+03, 0.2516D+03 & + / + data (TREF(31, 4, mtmp), mtmp=1,12) & + / & + 0.2454D+03, 0.2416D+03, 0.2374D+03, 0.2376D+03, & + 0.2390D+03, 0.2414D+03, 0.2430D+03, 0.2422D+03, & + 0.2422D+03, 0.2437D+03, 0.2457D+03, 0.2472D+03 & + / + data (TREF(31, 5, mtmp), mtmp=1,12) & + / & + 0.2415D+03, 0.2382D+03, 0.2351D+03, 0.2366D+03, & + 0.2377D+03, 0.2400D+03, 0.2405D+03, 0.2395D+03, & + 0.2406D+03, 0.2420D+03, 0.2432D+03, 0.2437D+03 & + / + data (TREF(31, 6, mtmp), mtmp=1,12) & + / & + 0.2409D+03, 0.2393D+03, 0.2381D+03, 0.2390D+03, & + 0.2393D+03, 0.2405D+03, 0.2399D+03, 0.2390D+03, & + 0.2396D+03, 0.2407D+03, 0.2416D+03, 0.2420D+03 & + / + data (TREF(31, 7, mtmp), mtmp=1,12) & + / & + 0.2427D+03, 0.2429D+03, 0.2433D+03, 0.2423D+03, & + 0.2411D+03, 0.2402D+03, 0.2394D+03, 0.2386D+03, & + 0.2384D+03, 0.2394D+03, 0.2406D+03, 0.2419D+03 & + / + data (TREF(31, 8, mtmp), mtmp=1,12) & + / & + 0.2441D+03, 0.2446D+03, 0.2451D+03, 0.2433D+03, & + 0.2417D+03, 0.2400D+03, 0.2392D+03, 0.2385D+03, & + 0.2375D+03, 0.2386D+03, 0.2402D+03, 0.2424D+03 & + / + data (TREF(31, 9, mtmp), mtmp=1,12) & + / & + 0.2436D+03, 0.2432D+03, 0.2429D+03, 0.2416D+03, & + 0.2409D+03, 0.2400D+03, 0.2399D+03, 0.2398D+03, & + 0.2390D+03, 0.2394D+03, 0.2405D+03, 0.2422D+03 & + / + data (TREF(31,10, mtmp), mtmp=1,12) & + / & + 0.2420D+03, 0.2410D+03, 0.2398D+03, 0.2397D+03, & + 0.2401D+03, 0.2405D+03, 0.2414D+03, 0.2421D+03, & + 0.2422D+03, 0.2414D+03, 0.2412D+03, 0.2416D+03 & + / + data (TREF(31,11, mtmp), mtmp=1,12) & + / & + 0.2409D+03, 0.2395D+03, 0.2383D+03, 0.2387D+03, & + 0.2397D+03, 0.2409D+03, 0.2423D+03, 0.2436D+03, & + 0.2446D+03, 0.2432D+03, 0.2419D+03, 0.2412D+03 & + / + data (TREF(31,12, mtmp), mtmp=1,12) & + / & + 0.2403D+03, 0.2396D+03, 0.2391D+03, 0.2394D+03, & + 0.2401D+03, 0.2407D+03, 0.2413D+03, 0.2421D+03, & + 0.2431D+03, 0.2424D+03, 0.2415D+03, 0.2407D+03 & + / + data (TREF(31,13, mtmp), mtmp=1,12) & + / & + 0.2398D+03, 0.2399D+03, 0.2407D+03, 0.2412D+03, & + 0.2412D+03, 0.2409D+03, 0.2397D+03, 0.2386D+03, & + 0.2380D+03, 0.2392D+03, 0.2400D+03, 0.2402D+03 & + / + data (TREF(31,14, mtmp), mtmp=1,12) & + / & + 0.2387D+03, 0.2398D+03, 0.2418D+03, 0.2430D+03, & + 0.2431D+03, 0.2429D+03, 0.2403D+03, 0.2374D+03, & + 0.2350D+03, 0.2368D+03, 0.2385D+03, 0.2391D+03 & + / + data (TREF(31,15, mtmp), mtmp=1,12) & + / & + 0.2390D+03, 0.2406D+03, 0.2422D+03, 0.2443D+03, & + 0.2458D+03, 0.2466D+03, 0.2443D+03, 0.2408D+03, & + 0.2373D+03, 0.2378D+03, 0.2394D+03, 0.2400D+03 & + / + data (TREF(31,16, mtmp), mtmp=1,12) & + / & + 0.2392D+03, 0.2408D+03, 0.2409D+03, 0.2441D+03, & + 0.2480D+03, 0.2509D+03, 0.2492D+03, 0.2460D+03, & + 0.2418D+03, 0.2402D+03, 0.2408D+03, 0.2405D+03 & + / + data (TREF(31,17, mtmp), mtmp=1,12) & + / & + 0.2398D+03, 0.2410D+03, 0.2387D+03, 0.2430D+03, & + 0.2497D+03, 0.2548D+03, 0.2533D+03, 0.2501D+03, & + 0.2454D+03, 0.2428D+03, 0.2427D+03, 0.2418D+03 & + / + data (TREF(31,18, mtmp), mtmp=1,12) & + / & + 0.2404D+03, 0.2421D+03, 0.2381D+03, 0.2424D+03, & + 0.2508D+03, 0.2569D+03, 0.2556D+03, 0.2524D+03, & + 0.2473D+03, 0.2443D+03, 0.2435D+03, 0.2422D+03 & + / + data (TREF(32, 1, mtmp), mtmp=1,12) & + / & + 0.2498D+03, 0.2474D+03, 0.2455D+03, 0.2421D+03, & + 0.2376D+03, 0.2336D+03, 0.2320D+03, 0.2298D+03, & + 0.2275D+03, 0.2359D+03, 0.2442D+03, 0.2525D+03 & + / + data (TREF(32, 2, mtmp), mtmp=1,12) & + / & + 0.2478D+03, 0.2455D+03, 0.2434D+03, 0.2396D+03, & + 0.2358D+03, 0.2315D+03, 0.2311D+03, 0.2305D+03, & + 0.2297D+03, 0.2367D+03, 0.2436D+03, 0.2507D+03 & + / + data (TREF(32, 3, mtmp), mtmp=1,12) & + / & + 0.2417D+03, 0.2400D+03, 0.2382D+03, 0.2358D+03, & + 0.2334D+03, 0.2309D+03, 0.2320D+03, 0.2333D+03, & + 0.2348D+03, 0.2377D+03, 0.2403D+03, 0.2434D+03 & + / + data (TREF(32, 4, mtmp), mtmp=1,12) & + / & + 0.2363D+03, 0.2341D+03, 0.2320D+03, 0.2324D+03, & + 0.2325D+03, 0.2327D+03, 0.2341D+03, 0.2353D+03, & + 0.2366D+03, 0.2374D+03, 0.2376D+03, 0.2385D+03 & + / + data (TREF(32, 5, mtmp), mtmp=1,12) & + / & + 0.2323D+03, 0.2303D+03, 0.2283D+03, 0.2300D+03, & + 0.2319D+03, 0.2336D+03, 0.2342D+03, 0.2351D+03, & + 0.2357D+03, 0.2354D+03, 0.2349D+03, 0.2343D+03 & + / + data (TREF(32, 6, mtmp), mtmp=1,12) & + / & + 0.2332D+03, 0.2332D+03, 0.2327D+03, 0.2330D+03, & + 0.2335D+03, 0.2339D+03, 0.2343D+03, 0.2349D+03, & + 0.2355D+03, 0.2350D+03, 0.2343D+03, 0.2334D+03 & + / + data (TREF(32, 7, mtmp), mtmp=1,12) & + / & + 0.2347D+03, 0.2359D+03, 0.2371D+03, 0.2357D+03, & + 0.2342D+03, 0.2329D+03, 0.2329D+03, 0.2328D+03, & + 0.2329D+03, 0.2332D+03, 0.2334D+03, 0.2336D+03 & + / + data (TREF(32, 8, mtmp), mtmp=1,12) & + / & + 0.2354D+03, 0.2372D+03, 0.2390D+03, 0.2369D+03, & + 0.2347D+03, 0.2326D+03, 0.2320D+03, 0.2315D+03, & + 0.2310D+03, 0.2319D+03, 0.2328D+03, 0.2337D+03 & + / + data (TREF(32, 9, mtmp), mtmp=1,12) & + / & + 0.2333D+03, 0.2341D+03, 0.2348D+03, 0.2340D+03, & + 0.2333D+03, 0.2325D+03, 0.2325D+03, 0.2328D+03, & + 0.2332D+03, 0.2331D+03, 0.2328D+03, 0.2327D+03 & + / + data (TREF(32,10, mtmp), mtmp=1,12) & + / & + 0.2325D+03, 0.2328D+03, 0.2333D+03, 0.2332D+03, & + 0.2330D+03, 0.2328D+03, 0.2334D+03, 0.2340D+03, & + 0.2349D+03, 0.2340D+03, 0.2333D+03, 0.2325D+03 & + / + data (TREF(32,11, mtmp), mtmp=1,12) & + / & + 0.2320D+03, 0.2314D+03, 0.2310D+03, 0.2320D+03, & + 0.2328D+03, 0.2338D+03, 0.2355D+03, 0.2373D+03, & + 0.2390D+03, 0.2370D+03, 0.2348D+03, 0.2326D+03 & + / + data (TREF(32,12, mtmp), mtmp=1,12) & + / & + 0.2328D+03, 0.2327D+03, 0.2329D+03, 0.2333D+03, & + 0.2334D+03, 0.2335D+03, 0.2347D+03, 0.2359D+03, & + 0.2371D+03, 0.2358D+03, 0.2342D+03, 0.2328D+03 & + / + data (TREF(32,13, mtmp), mtmp=1,12) & + / & + 0.2343D+03, 0.2349D+03, 0.2355D+03, 0.2351D+03, & + 0.2343D+03, 0.2333D+03, 0.2331D+03, 0.2333D+03, & + 0.2328D+03, 0.2330D+03, 0.2334D+03, 0.2339D+03 & + / + data (TREF(32,14, mtmp), mtmp=1,12) & + / & + 0.2343D+03, 0.2349D+03, 0.2357D+03, 0.2354D+03, & + 0.2350D+03, 0.2343D+03, 0.2323D+03, 0.2303D+03, & + 0.2282D+03, 0.2300D+03, 0.2317D+03, 0.2336D+03 & + / + data (TREF(32,15, mtmp), mtmp=1,12) & + / & + 0.2341D+03, 0.2355D+03, 0.2365D+03, 0.2373D+03, & + 0.2377D+03, 0.2383D+03, 0.2363D+03, 0.2341D+03, & + 0.2320D+03, 0.2324D+03, 0.2326D+03, 0.2328D+03 & + / + data (TREF(32,16, mtmp), mtmp=1,12) & + / & + 0.2321D+03, 0.2334D+03, 0.2348D+03, 0.2376D+03, & + 0.2404D+03, 0.2432D+03, 0.2420D+03, 0.2402D+03, & + 0.2381D+03, 0.2359D+03, 0.2332D+03, 0.2306D+03 & + / + data (TREF(32,17, mtmp), mtmp=1,12) & + / & + 0.2310D+03, 0.2307D+03, 0.2296D+03, 0.2369D+03, & + 0.2437D+03, 0.2503D+03, 0.2482D+03, 0.2458D+03, & + 0.2433D+03, 0.2393D+03, 0.2356D+03, 0.2317D+03 & + / + data (TREF(32,18, mtmp), mtmp=1,12) & + / & + 0.2319D+03, 0.2299D+03, 0.2277D+03, 0.2362D+03, & + 0.2441D+03, 0.2523D+03, 0.2499D+03, 0.2476D+03, & + 0.2454D+03, 0.2418D+03, 0.2382D+03, 0.2342D+03 & + / + data (TREF(33, 1, mtmp), mtmp=1,12) & + / & + 0.2425D+03, 0.2403D+03, 0.2380D+03, 0.2348D+03, & + 0.2317D+03, 0.2287D+03, 0.2263D+03, 0.2241D+03, & + 0.2219D+03, 0.2295D+03, 0.2372D+03, 0.2448D+03 & + / + data (TREF(33, 2, mtmp), mtmp=1,12) & + / & + 0.2406D+03, 0.2385D+03, 0.2364D+03, 0.2340D+03, & + 0.2317D+03, 0.2293D+03, 0.2277D+03, 0.2261D+03, & + 0.2247D+03, 0.2307D+03, 0.2368D+03, 0.2427D+03 & + / + data (TREF(33, 3, mtmp), mtmp=1,12) & + / & + 0.2359D+03, 0.2337D+03, 0.2317D+03, 0.2310D+03, & + 0.2304D+03, 0.2297D+03, 0.2301D+03, 0.2303D+03, & + 0.2305D+03, 0.2332D+03, 0.2355D+03, 0.2381D+03 & + / + data (TREF(33, 4, mtmp), mtmp=1,12) & + / & + 0.2304D+03, 0.2276D+03, 0.2248D+03, 0.2271D+03, & + 0.2294D+03, 0.2318D+03, 0.2326D+03, 0.2332D+03, & + 0.2339D+03, 0.2338D+03, 0.2335D+03, 0.2330D+03 & + / + data (TREF(33, 5, mtmp), mtmp=1,12) & + / & + 0.2266D+03, 0.2242D+03, 0.2215D+03, 0.2249D+03, & + 0.2283D+03, 0.2318D+03, 0.2323D+03, 0.2328D+03, & + 0.2331D+03, 0.2319D+03, 0.2310D+03, 0.2295D+03 & + / + data (TREF(33, 6, mtmp), mtmp=1,12) & + / & + 0.2278D+03, 0.2271D+03, 0.2265D+03, 0.2280D+03, & + 0.2296D+03, 0.2312D+03, 0.2311D+03, 0.2310D+03, & + 0.2310D+03, 0.2300D+03, 0.2293D+03, 0.2286D+03 & + / + data (TREF(33, 7, mtmp), mtmp=1,12) & + / & + 0.2309D+03, 0.2325D+03, 0.2343D+03, 0.2325D+03, & + 0.2308D+03, 0.2289D+03, 0.2284D+03, 0.2279D+03, & + 0.2274D+03, 0.2278D+03, 0.2284D+03, 0.2289D+03 & + / + data (TREF(33, 8, mtmp), mtmp=1,12) & + / & + 0.2312D+03, 0.2337D+03, 0.2362D+03, 0.2334D+03, & + 0.2305D+03, 0.2274D+03, 0.2264D+03, 0.2254D+03, & + 0.2243D+03, 0.2259D+03, 0.2275D+03, 0.2289D+03 & + / + data (TREF(33, 9, mtmp), mtmp=1,12) & + / & + 0.2287D+03, 0.2298D+03, 0.2311D+03, 0.2300D+03, & + 0.2284D+03, 0.2269D+03, 0.2265D+03, 0.2261D+03, & + 0.2257D+03, 0.2265D+03, 0.2272D+03, 0.2277D+03 & + / + data (TREF(33,10, mtmp), mtmp=1,12) & + / & + 0.2263D+03, 0.2261D+03, 0.2257D+03, 0.2266D+03, & + 0.2275D+03, 0.2281D+03, 0.2291D+03, 0.2302D+03, & + 0.2313D+03, 0.2300D+03, 0.2283D+03, 0.2267D+03 & + / + data (TREF(33,11, mtmp), mtmp=1,12) & + / & + 0.2263D+03, 0.2254D+03, 0.2244D+03, 0.2260D+03, & + 0.2276D+03, 0.2293D+03, 0.2315D+03, 0.2340D+03, & + 0.2364D+03, 0.2335D+03, 0.2303D+03, 0.2273D+03 & + / + data (TREF(33,12, mtmp), mtmp=1,12) & + / & + 0.2284D+03, 0.2279D+03, 0.2274D+03, 0.2278D+03, & + 0.2285D+03, 0.2292D+03, 0.2311D+03, 0.2327D+03, & + 0.2344D+03, 0.2356D+03, 0.2307D+03, 0.2289D+03 & + / + data (TREF(33,13, mtmp), mtmp=1,12) & + / & + 0.2311D+03, 0.2311D+03, 0.2309D+03, 0.2300D+03, & + 0.2293D+03, 0.2286D+03, 0.2277D+03, 0.2271D+03, & + 0.2265D+03, 0.2280D+03, 0.2296D+03, 0.2312D+03 & + / + data (TREF(33,14, mtmp), mtmp=1,12) & + / & + 0.2323D+03, 0.2327D+03, 0.2330D+03, 0.2319D+03, & + 0.2310D+03, 0.2296D+03, 0.2267D+03, 0.2242D+03, & + 0.2215D+03, 0.2250D+03, 0.2283D+03, 0.2317D+03 & + / + data (TREF(33,15, mtmp), mtmp=1,12) & + / & + 0.2325D+03, 0.2333D+03, 0.2339D+03, 0.2336D+03, & + 0.2338D+03, 0.2331D+03, 0.2302D+03, 0.2276D+03, & + 0.2248D+03, 0.2272D+03, 0.2294D+03, 0.2317D+03 & + / + data (TREF(33,16, mtmp), mtmp=1,12) & + / & + 0.2301D+03, 0.2303D+03, 0.2305D+03, 0.2330D+03, & + 0.2357D+03, 0.2378D+03, 0.2360D+03, 0.2337D+03, & + 0.2317D+03, 0.2310D+03, 0.2305D+03, 0.2298D+03 & + / + data (TREF(33,17, mtmp), mtmp=1,12) & + / & + 0.2279D+03, 0.2260D+03, 0.2247D+03, 0.2306D+03, & + 0.2367D+03, 0.2428D+03, 0.2405D+03, 0.2384D+03, & + 0.2364D+03, 0.2340D+03, 0.2316D+03, 0.2293D+03 & + / + data (TREF(33,18, mtmp), mtmp=1,12) & + / & + 0.2263D+03, 0.2240D+03, 0.2219D+03, 0.2294D+03, & + 0.2372D+03, 0.2448D+03, 0.2425D+03, 0.2402D+03, & + 0.2380D+03, 0.2348D+03, 0.2315D+03, 0.2284D+03 & + / + data (TREF(34, 1, mtmp), mtmp=1,12) & + / & + 0.2350D+03, 0.2327D+03, 0.2304D+03, 0.2280D+03, & + 0.2251D+03, 0.2227D+03, 0.2205D+03, 0.2181D+03, & + 0.2157D+03, 0.2229D+03, 0.2302D+03, 0.2373D+03 & + / + data (TREF(34, 2, mtmp), mtmp=1,12) & + / & + 0.2329D+03, 0.2308D+03, 0.2288D+03, 0.2278D+03, & + 0.2265D+03, 0.2253D+03, 0.2234D+03, 0.2214D+03, & + 0.2192D+03, 0.2245D+03, 0.2298D+03, 0.2351D+03 & + / + data (TREF(34, 3, mtmp), mtmp=1,12) & + / & + 0.2281D+03, 0.2261D+03, 0.2242D+03, 0.2258D+03, & + 0.2273D+03, 0.2290D+03, 0.2281D+03, 0.2272D+03, & + 0.2262D+03, 0.2275D+03, 0.2289D+03, 0.2302D+03 & + / + data (TREF(34, 4, mtmp), mtmp=1,12) & + / & + 0.2225D+03, 0.2200D+03, 0.2175D+03, 0.2221D+03, & + 0.2266D+03, 0.2309D+03, 0.2305D+03, 0.2302D+03, & + 0.2297D+03, 0.2281D+03, 0.2266D+03, 0.2251D+03 & + / + data (TREF(34, 5, mtmp), mtmp=1,12) & + / & + 0.2190D+03, 0.2167D+03, 0.2146D+03, 0.2196D+03, & + 0.2247D+03, 0.2295D+03, 0.2290D+03, 0.2290D+03, & + 0.2286D+03, 0.2260D+03, 0.2236D+03, 0.2212D+03 & + / + data (TREF(34, 6, mtmp), mtmp=1,12) & + / & + 0.2203D+03, 0.2200D+03, 0.2198D+03, 0.2216D+03, & + 0.2235D+03, 0.2253D+03, 0.2254D+03, 0.2257D+03, & + 0.2258D+03, 0.2240D+03, 0.2221D+03, 0.2202D+03 & + / + data (TREF(34, 7, mtmp), mtmp=1,12) & + / & + 0.2231D+03, 0.2254D+03, 0.2278D+03, 0.2256D+03, & + 0.2235D+03, 0.2213D+03, 0.2214D+03, 0.2214D+03, & + 0.2215D+03, 0.2212D+03, 0.2210D+03, 0.2206D+03 & + / + data (TREF(34, 8, mtmp), mtmp=1,12) & + / & + 0.2233D+03, 0.2264D+03, 0.2293D+03, 0.2256D+03, & + 0.2219D+03, 0.2182D+03, 0.2180D+03, 0.2177D+03, & + 0.2174D+03, 0.2183D+03, 0.2193D+03, 0.2203D+03 & + / + data (TREF(34, 9, mtmp), mtmp=1,12) & + / & + 0.2204D+03, 0.2220D+03, 0.2238D+03, 0.2215D+03, & + 0.2193D+03, 0.2171D+03, 0.2175D+03, 0.2178D+03, & + 0.2181D+03, 0.2182D+03, 0.2184D+03, 0.2185D+03 & + / + data (TREF(34,10, mtmp), mtmp=1,12) & + / & + 0.2175D+03, 0.2178D+03, 0.2181D+03, 0.2182D+03, & + 0.2183D+03, 0.2184D+03, 0.2202D+03, 0.2219D+03, & + 0.2238D+03, 0.2215D+03, 0.2193D+03, 0.2172D+03 & + / + data (TREF(34,11, mtmp), mtmp=1,12) & + / & + 0.2181D+03, 0.2177D+03, 0.2175D+03, 0.2183D+03, & + 0.2193D+03, 0.2202D+03, 0.2233D+03, 0.2263D+03, & + 0.2293D+03, 0.2256D+03, 0.2219D+03, 0.2183D+03 & + / + data (TREF(34,12, mtmp), mtmp=1,12) & + / & + 0.2215D+03, 0.2214D+03, 0.2215D+03, 0.2212D+03, & + 0.2209D+03, 0.2206D+03, 0.2231D+03, 0.2254D+03, & + 0.2277D+03, 0.2316D+03, 0.2235D+03, 0.2214D+03 & + / + data (TREF(34,13, mtmp), mtmp=1,12) & + / & + 0.2254D+03, 0.2257D+03, 0.2258D+03, 0.2240D+03, & + 0.2220D+03, 0.2202D+03, 0.2202D+03, 0.2200D+03, & + 0.2198D+03, 0.2216D+03, 0.2235D+03, 0.2253D+03 & + / + data (TREF(34,14, mtmp), mtmp=1,12) & + / & + 0.2293D+03, 0.2289D+03, 0.2286D+03, 0.2261D+03, & + 0.2235D+03, 0.2211D+03, 0.2190D+03, 0.2167D+03, & + 0.2146D+03, 0.2197D+03, 0.2246D+03, 0.2296D+03 & + / + data (TREF(34,15, mtmp), mtmp=1,12) & + / & + 0.2305D+03, 0.2302D+03, 0.2297D+03, 0.2282D+03, & + 0.2266D+03, 0.2251D+03, 0.2226D+03, 0.2200D+03, & + 0.2175D+03, 0.2220D+03, 0.2265D+03, 0.2311D+03 & + / + data (TREF(34,16, mtmp), mtmp=1,12) & + / & + 0.2280D+03, 0.2272D+03, 0.2262D+03, 0.2276D+03, & + 0.2289D+03, 0.2303D+03, 0.2281D+03, 0.2262D+03, & + 0.2242D+03, 0.2258D+03, 0.2274D+03, 0.2289D+03 & + / + data (TREF(34,17, mtmp), mtmp=1,12) & + / & + 0.2233D+03, 0.2213D+03, 0.2191D+03, 0.2245D+03, & + 0.2298D+03, 0.2352D+03, 0.2329D+03, 0.2308D+03, & + 0.2288D+03, 0.2277D+03, 0.2266D+03, 0.2255D+03 & + / + data (TREF(34,18, mtmp), mtmp=1,12) & + / & + 0.2203D+03, 0.2183D+03, 0.2156D+03, 0.2230D+03, & + 0.2302D+03, 0.2374D+03, 0.2350D+03, 0.2327D+03, & + 0.2304D+03, 0.2280D+03, 0.2253D+03, 0.2226D+03 & + / + data (TREF(35, 1, mtmp), mtmp=1,12) & + / & + 0.2270D+03, 0.2251D+03, 0.2231D+03, 0.2214D+03, & + 0.2200D+03, 0.2181D+03, 0.2156D+03, 0.2132D+03, & + 0.2113D+03, 0.2172D+03, 0.2232D+03, 0.2292D+03 & + / + data (TREF(35, 2, mtmp), mtmp=1,12) & + / & + 0.2249D+03, 0.2233D+03, 0.2216D+03, 0.2214D+03, & + 0.2213D+03, 0.2215D+03, 0.2192D+03, 0.2169D+03, & + 0.2147D+03, 0.2188D+03, 0.2229D+03, 0.2269D+03 & + / + data (TREF(35, 3, mtmp), mtmp=1,12) & + / & + 0.2204D+03, 0.2187D+03, 0.2171D+03, 0.2206D+03, & + 0.2242D+03, 0.2277D+03, 0.2259D+03, 0.2242D+03, & + 0.2223D+03, 0.2222D+03, 0.2221D+03, 0.2220D+03 & + / + data (TREF(35, 4, mtmp), mtmp=1,12) & + / & + 0.2148D+03, 0.2127D+03, 0.2108D+03, 0.2171D+03, & + 0.2232D+03, 0.2296D+03, 0.2283D+03, 0.2270D+03, & + 0.2256D+03, 0.2227D+03, 0.2198D+03, 0.2169D+03 & + / + data (TREF(35, 5, mtmp), mtmp=1,12) & + / & + 0.2116D+03, 0.2099D+03, 0.2086D+03, 0.2140D+03, & + 0.2195D+03, 0.2252D+03, 0.2249D+03, 0.2244D+03, & + 0.2242D+03, 0.2205D+03, 0.2167D+03, 0.2132D+03 & + / + data (TREF(35, 6, mtmp), mtmp=1,12) & + / & + 0.2132D+03, 0.2136D+03, 0.2142D+03, 0.2160D+03, & + 0.2178D+03, 0.2196D+03, 0.2201D+03, 0.2208D+03, & + 0.2213D+03, 0.2185D+03, 0.2157D+03, 0.2128D+03 & + / + data (TREF(35, 7, mtmp), mtmp=1,12) & + / & + 0.2164D+03, 0.2192D+03, 0.2220D+03, 0.2195D+03, & + 0.2171D+03, 0.2147D+03, 0.2153D+03, 0.2160D+03, & + 0.2166D+03, 0.2156D+03, 0.2148D+03, 0.2138D+03 & + / + data (TREF(35, 8, mtmp), mtmp=1,12) & + / & + 0.2166D+03, 0.2200D+03, 0.2233D+03, 0.2192D+03, & + 0.2151D+03, 0.2111D+03, 0.2115D+03, 0.2117D+03, & + 0.2119D+03, 0.2123D+03, 0.2127D+03, 0.2132D+03 & + / + data (TREF(35, 9, mtmp), mtmp=1,12) & + / & + 0.2134D+03, 0.2156D+03, 0.2177D+03, 0.2148D+03, & + 0.2124D+03, 0.2099D+03, 0.2107D+03, 0.2113D+03, & + 0.2119D+03, 0.2116D+03, 0.2115D+03, 0.2113D+03 & + / + data (TREF(35,10, mtmp), mtmp=1,12) & + / & + 0.2107D+03, 0.2114D+03, 0.2119D+03, 0.2114D+03, & + 0.2112D+03, 0.2110D+03, 0.2132D+03, 0.2154D+03, & + 0.2176D+03, 0.2148D+03, 0.2124D+03, 0.2100D+03 & + / + data (TREF(35,11, mtmp), mtmp=1,12) & + / & + 0.2115D+03, 0.2118D+03, 0.2119D+03, 0.2122D+03, & + 0.2126D+03, 0.2130D+03, 0.2165D+03, 0.2199D+03, & + 0.2233D+03, 0.2191D+03, 0.2152D+03, 0.2112D+03 & + / + data (TREF(35,12, mtmp), mtmp=1,12) & + / & + 0.2153D+03, 0.2159D+03, 0.2166D+03, 0.2157D+03, & + 0.2147D+03, 0.2137D+03, 0.2163D+03, 0.2191D+03, & + 0.2220D+03, 0.2237D+03, 0.2171D+03, 0.2147D+03 & + / + data (TREF(35,13, mtmp), mtmp=1,12) & + / & + 0.2201D+03, 0.2208D+03, 0.2213D+03, 0.2185D+03, & + 0.2157D+03, 0.2128D+03, 0.2132D+03, 0.2136D+03, & + 0.2142D+03, 0.2160D+03, 0.2178D+03, 0.2196D+03 & + / + data (TREF(35,14, mtmp), mtmp=1,12) & + / & + 0.2247D+03, 0.2246D+03, 0.2242D+03, 0.2206D+03, & + 0.2169D+03, 0.2131D+03, 0.2116D+03, 0.2099D+03, & + 0.2086D+03, 0.2140D+03, 0.2196D+03, 0.2251D+03 & + / + data (TREF(35,15, mtmp), mtmp=1,12) & + / & + 0.2281D+03, 0.2270D+03, 0.2256D+03, 0.2228D+03, & + 0.2198D+03, 0.2168D+03, 0.2148D+03, 0.2127D+03, & + 0.2108D+03, 0.2170D+03, 0.2234D+03, 0.2295D+03 & + / + data (TREF(35,16, mtmp), mtmp=1,12) & + / & + 0.2259D+03, 0.2242D+03, 0.2222D+03, 0.2223D+03, & + 0.2222D+03, 0.2220D+03, 0.2204D+03, 0.2187D+03, & + 0.2171D+03, 0.2206D+03, 0.2241D+03, 0.2276D+03 & + / + data (TREF(35,17, mtmp), mtmp=1,12) & + / & + 0.2189D+03, 0.2172D+03, 0.2148D+03, 0.2190D+03, & + 0.2228D+03, 0.2268D+03, 0.2250D+03, 0.2233D+03, & + 0.2216D+03, 0.2216D+03, 0.2213D+03, 0.2209D+03 & + / + data (TREF(35,18, mtmp), mtmp=1,12) & + / & + 0.2160D+03, 0.2134D+03, 0.2114D+03, 0.2173D+03, & + 0.2231D+03, 0.2292D+03, 0.2270D+03, 0.2251D+03, & + 0.2231D+03, 0.2215D+03, 0.2195D+03, 0.2181D+03 & + / + data (TREF(36, 1, mtmp), mtmp=1,12) & + / & + 0.2182D+03, 0.2174D+03, 0.2165D+03, 0.2166D+03, & + 0.2166D+03, 0.2165D+03, 0.2143D+03, 0.2122D+03, & + 0.2101D+03, 0.2132D+03, 0.2162D+03, 0.2192D+03 & + / + data (TREF(36, 2, mtmp), mtmp=1,12) & + / & + 0.2164D+03, 0.2156D+03, 0.2149D+03, 0.2165D+03, & + 0.2179D+03, 0.2193D+03, 0.2173D+03, 0.2153D+03, & + 0.2133D+03, 0.2146D+03, 0.2159D+03, 0.2172D+03 & + / + data (TREF(36, 3, mtmp), mtmp=1,12) & + / & + 0.2122D+03, 0.2113D+03, 0.2105D+03, 0.2153D+03, & + 0.2202D+03, 0.2250D+03, 0.2234D+03, 0.2216D+03, & + 0.2198D+03, 0.2176D+03, 0.2154D+03, 0.2131D+03 & + / + data (TREF(36, 4, mtmp), mtmp=1,12) & + / & + 0.2076D+03, 0.2063D+03, 0.2050D+03, 0.2121D+03, & + 0.2193D+03, 0.2264D+03, 0.2250D+03, 0.2237D+03, & + 0.2223D+03, 0.2178D+03, 0.2133D+03, 0.2089D+03 & + / + data (TREF(36, 5, mtmp), mtmp=1,12) & + / & + 0.2056D+03, 0.2047D+03, 0.2039D+03, 0.2098D+03, & + 0.2158D+03, 0.2217D+03, 0.2213D+03, 0.2209D+03, & + 0.2203D+03, 0.2157D+03, 0.2111D+03, 0.2064D+03 & + / + data (TREF(36, 6, mtmp), mtmp=1,12) & + / & + 0.2082D+03, 0.2091D+03, 0.2099D+03, 0.2117D+03, & + 0.2137D+03, 0.2156D+03, 0.2163D+03, 0.2169D+03, & + 0.2175D+03, 0.2142D+03, 0.2108D+03, 0.2075D+03 & + / + data (TREF(36, 7, mtmp), mtmp=1,12) & + / & + 0.2119D+03, 0.2147D+03, 0.2175D+03, 0.2152D+03, & + 0.2129D+03, 0.2106D+03, 0.2115D+03, 0.2123D+03, & + 0.2132D+03, 0.2118D+03, 0.2105D+03, 0.2091D+03 & + / + data (TREF(36, 8, mtmp), mtmp=1,12) & + / & + 0.2123D+03, 0.2155D+03, 0.2189D+03, 0.2152D+03, & + 0.2115D+03, 0.2077D+03, 0.2080D+03, 0.2083D+03, & + 0.2086D+03, 0.2087D+03, 0.2088D+03, 0.2089D+03 & + / + data (TREF(36, 9, mtmp), mtmp=1,12) & + / & + 0.2096D+03, 0.2116D+03, 0.2136D+03, 0.2113D+03, & + 0.2090D+03, 0.2068D+03, 0.2073D+03, 0.2079D+03, & + 0.2083D+03, 0.2081D+03, 0.2078D+03, 0.2075D+03 & + / + data (TREF(36,10, mtmp), mtmp=1,12) & + / & + 0.2073D+03, 0.2078D+03, 0.2084D+03, 0.2081D+03, & + 0.2078D+03, 0.2075D+03, 0.2096D+03, 0.2115D+03, & + 0.2136D+03, 0.2113D+03, 0.2091D+03, 0.2068D+03 & + / + data (TREF(36,11, mtmp), mtmp=1,12) & + / & + 0.2080D+03, 0.2083D+03, 0.2086D+03, 0.2087D+03, & + 0.2088D+03, 0.2088D+03, 0.2122D+03, 0.2155D+03, & + 0.2189D+03, 0.2152D+03, 0.2115D+03, 0.2076D+03 & + / + data (TREF(36,12, mtmp), mtmp=1,12) & + / & + 0.2114D+03, 0.2123D+03, 0.2132D+03, 0.2118D+03, & + 0.2105D+03, 0.2091D+03, 0.2119D+03, 0.2147D+03, & + 0.2175D+03, 0.2178D+03, 0.2129D+03, 0.2106D+03 & + / + data (TREF(36,13, mtmp), mtmp=1,12) & + / & + 0.2162D+03, 0.2169D+03, 0.2176D+03, 0.2142D+03, & + 0.2108D+03, 0.2075D+03, 0.2082D+03, 0.2091D+03, & + 0.2099D+03, 0.2117D+03, 0.2137D+03, 0.2156D+03 & + / + data (TREF(36,14, mtmp), mtmp=1,12) & + / & + 0.2213D+03, 0.2208D+03, 0.2203D+03, 0.2157D+03, & + 0.2111D+03, 0.2063D+03, 0.2056D+03, 0.2047D+03, & + 0.2039D+03, 0.2098D+03, 0.2158D+03, 0.2218D+03 & + / + data (TREF(36,15, mtmp), mtmp=1,12) & + / & + 0.2250D+03, 0.2237D+03, 0.2223D+03, 0.2179D+03, & + 0.2133D+03, 0.2089D+03, 0.2076D+03, 0.2063D+03, & + 0.2050D+03, 0.2122D+03, 0.2193D+03, 0.2263D+03 & + / + data (TREF(36,16, mtmp), mtmp=1,12) & + / & + 0.2233D+03, 0.2216D+03, 0.2198D+03, 0.2177D+03, & + 0.2155D+03, 0.2131D+03, 0.2122D+03, 0.2113D+03, & + 0.2105D+03, 0.2153D+03, 0.2202D+03, 0.2250D+03 & + / + data (TREF(36,17, mtmp), mtmp=1,12) & + / & + 0.2173D+03, 0.2154D+03, 0.2133D+03, 0.2146D+03, & + 0.2159D+03, 0.2172D+03, 0.2163D+03, 0.2156D+03, & + 0.2149D+03, 0.2164D+03, 0.2179D+03, 0.2193D+03 & + / + data (TREF(36,18, mtmp), mtmp=1,12) & + / & + 0.2144D+03, 0.2121D+03, 0.2101D+03, 0.2131D+03, & + 0.2162D+03, 0.2192D+03, 0.2182D+03, 0.2174D+03, & + 0.2165D+03, 0.2165D+03, 0.2166D+03, 0.2165D+03 & + / + data (TREF(37, 1, mtmp), mtmp=1,12) & + / & + 0.2091D+03, 0.2096D+03, 0.2100D+03, 0.2121D+03, & + 0.2140D+03, 0.2160D+03, 0.2140D+03, 0.2119D+03, & + 0.2100D+03, 0.2097D+03, 0.2092D+03, 0.2087D+03 & + / + data (TREF(37, 2, mtmp), mtmp=1,12) & + / & + 0.2075D+03, 0.2079D+03, 0.2084D+03, 0.2117D+03, & + 0.2149D+03, 0.2181D+03, 0.2163D+03, 0.2144D+03, & + 0.2126D+03, 0.2108D+03, 0.2090D+03, 0.2072D+03 & + / + data (TREF(37, 3, mtmp), mtmp=1,12) & + / & + 0.2040D+03, 0.2041D+03, 0.2040D+03, 0.2102D+03, & + 0.2164D+03, 0.2225D+03, 0.2210D+03, 0.2194D+03, & + 0.2178D+03, 0.2132D+03, 0.2086D+03, 0.2041D+03 & + / + data (TREF(37, 4, mtmp), mtmp=1,12) & + / & + 0.2005D+03, 0.2000D+03, 0.1995D+03, 0.2075D+03, & + 0.2153D+03, 0.2233D+03, 0.2220D+03, 0.2206D+03, & + 0.2192D+03, 0.2132D+03, 0.2071D+03, 0.2010D+03 & + / + data (TREF(37, 5, mtmp), mtmp=1,12) & + / & + 0.1999D+03, 0.1998D+03, 0.1999D+03, 0.2061D+03, & + 0.2123D+03, 0.2185D+03, 0.2180D+03, 0.2174D+03, & + 0.2167D+03, 0.2112D+03, 0.2056D+03, 0.2000D+03 & + / + data (TREF(37, 6, mtmp), mtmp=1,12) & + / & + 0.2037D+03, 0.2049D+03, 0.2063D+03, 0.2082D+03, & + 0.2102D+03, 0.2124D+03, 0.2129D+03, 0.2135D+03, & + 0.2142D+03, 0.2103D+03, 0.2064D+03, 0.2025D+03 & + / + data (TREF(37, 7, mtmp), mtmp=1,12) & + / & + 0.2080D+03, 0.2108D+03, 0.2135D+03, 0.2116D+03, & + 0.2097D+03, 0.2078D+03, 0.2086D+03, 0.2095D+03, & + 0.2104D+03, 0.2087D+03, 0.2070D+03, 0.2052D+03 & + / + data (TREF(37, 8, mtmp), mtmp=1,12) & + / & + 0.2088D+03, 0.2118D+03, 0.2148D+03, 0.2118D+03, & + 0.2088D+03, 0.2058D+03, 0.2059D+03, 0.2060D+03, & + 0.2062D+03, 0.2060D+03, 0.2058D+03, 0.2057D+03 & + / + data (TREF(37, 9, mtmp), mtmp=1,12) & + / & + 0.2070D+03, 0.2085D+03, 0.2102D+03, 0.2085D+03, & + 0.2070D+03, 0.2054D+03, 0.2055D+03, 0.2055D+03, & + 0.2056D+03, 0.2056D+03, 0.2054D+03, 0.2054D+03 & + / + data (TREF(37,10, mtmp), mtmp=1,12) & + / & + 0.2054D+03, 0.2055D+03, 0.2057D+03, 0.2055D+03, & + 0.2055D+03, 0.2054D+03, 0.2070D+03, 0.2085D+03, & + 0.2101D+03, 0.2085D+03, 0.2070D+03, 0.2054D+03 & + / + data (TREF(37,11, mtmp), mtmp=1,12) & + / & + 0.2059D+03, 0.2060D+03, 0.2061D+03, 0.2060D+03, & + 0.2058D+03, 0.2057D+03, 0.2088D+03, 0.2118D+03, & + 0.2148D+03, 0.2118D+03, 0.2088D+03, 0.2058D+03 & + / + data (TREF(37,12, mtmp), mtmp=1,12) & + / & + 0.2086D+03, 0.2095D+03, 0.2104D+03, 0.2087D+03, & + 0.2069D+03, 0.2052D+03, 0.2080D+03, 0.2107D+03, & + 0.2134D+03, 0.2139D+03, 0.2096D+03, 0.2078D+03 & + / + data (TREF(37,13, mtmp), mtmp=1,12) & + / & + 0.2130D+03, 0.2135D+03, 0.2142D+03, 0.2103D+03, & + 0.2064D+03, 0.2025D+03, 0.2037D+03, 0.2049D+03, & + 0.2063D+03, 0.2082D+03, 0.2103D+03, 0.2124D+03 & + / + data (TREF(37,14, mtmp), mtmp=1,12) & + / & + 0.2180D+03, 0.2174D+03, 0.2168D+03, 0.2111D+03, & + 0.2056D+03, 0.2000D+03, 0.2000D+03, 0.1999D+03, & + 0.1998D+03, 0.2061D+03, 0.2123D+03, 0.2185D+03 & + / + data (TREF(37,15, mtmp), mtmp=1,12) & + / & + 0.2219D+03, 0.2206D+03, 0.2192D+03, 0.2131D+03, & + 0.2071D+03, 0.2011D+03, 0.2005D+03, 0.2000D+03, & + 0.1996D+03, 0.2075D+03, 0.2153D+03, 0.2233D+03 & + / + data (TREF(37,16, mtmp), mtmp=1,12) & + / & + 0.2210D+03, 0.2193D+03, 0.2177D+03, 0.2132D+03, & + 0.2086D+03, 0.2041D+03, 0.2040D+03, 0.2041D+03, & + 0.2041D+03, 0.2102D+03, 0.2164D+03, 0.2225D+03 & + / + data (TREF(37,17, mtmp), mtmp=1,12) & + / & + 0.2162D+03, 0.2144D+03, 0.2125D+03, 0.2107D+03, & + 0.2090D+03, 0.2072D+03, 0.2075D+03, 0.2079D+03, & + 0.2084D+03, 0.2116D+03, 0.2149D+03, 0.2181D+03 & + / + data (TREF(37,18, mtmp), mtmp=1,12) & + / & + 0.2140D+03, 0.2120D+03, 0.2100D+03, 0.2096D+03, & + 0.2092D+03, 0.2088D+03, 0.2091D+03, 0.2096D+03, & + 0.2101D+03, 0.2121D+03, 0.2139D+03, 0.2160D+03 & + / + data (TREF(38, 1, mtmp), mtmp=1,12) & + / & + 0.1999D+03, 0.2018D+03, 0.2036D+03, 0.2075D+03, & + 0.2115D+03, 0.2154D+03, 0.2136D+03, 0.2118D+03, & + 0.2100D+03, 0.2062D+03, 0.2022D+03, 0.1983D+03 & + / + data (TREF(38, 2, mtmp), mtmp=1,12) & + / & + 0.1986D+03, 0.2003D+03, 0.2019D+03, 0.2069D+03, & + 0.2120D+03, 0.2169D+03, 0.2152D+03, 0.2135D+03, & + 0.2119D+03, 0.2069D+03, 0.2020D+03, 0.1972D+03 & + / + data (TREF(38, 3, mtmp), mtmp=1,12) & + / & + 0.1958D+03, 0.1966D+03, 0.1976D+03, 0.2052D+03, & + 0.2125D+03, 0.2201D+03, 0.2186D+03, 0.2172D+03, & + 0.2156D+03, 0.2087D+03, 0.2019D+03, 0.1950D+03 & + / + data (TREF(38, 4, mtmp), mtmp=1,12) & + / & + 0.1934D+03, 0.1937D+03, 0.1942D+03, 0.2028D+03, & + 0.2115D+03, 0.2201D+03, 0.2188D+03, 0.2174D+03, & + 0.2161D+03, 0.2084D+03, 0.2008D+03, 0.1930D+03 & + / + data (TREF(38, 5, mtmp), mtmp=1,12) & + / & + 0.1942D+03, 0.1950D+03, 0.1959D+03, 0.2023D+03, & + 0.2089D+03, 0.2153D+03, 0.2146D+03, 0.2138D+03, & + 0.2132D+03, 0.2066D+03, 0.2002D+03, 0.1936D+03 & + / + data (TREF(38, 6, mtmp), mtmp=1,12) & + / & + 0.1992D+03, 0.2009D+03, 0.2027D+03, 0.2048D+03, & + 0.2068D+03, 0.2090D+03, 0.2096D+03, 0.2102D+03, & + 0.2108D+03, 0.2064D+03, 0.2020D+03, 0.1975D+03 & + / + data (TREF(38, 7, mtmp), mtmp=1,12) & + / & + 0.2041D+03, 0.2069D+03, 0.2095D+03, 0.2080D+03, & + 0.2065D+03, 0.2049D+03, 0.2058D+03, 0.2067D+03, & + 0.2077D+03, 0.2056D+03, 0.2035D+03, 0.2013D+03 & + / + data (TREF(38, 8, mtmp), mtmp=1,12) & + / & + 0.2053D+03, 0.2080D+03, 0.2108D+03, 0.2085D+03, & + 0.2062D+03, 0.2040D+03, 0.2039D+03, 0.2038D+03, & + 0.2038D+03, 0.2034D+03, 0.2029D+03, 0.2026D+03 & + / + data (TREF(38, 9, mtmp), mtmp=1,12) & + / & + 0.2046D+03, 0.2056D+03, 0.2067D+03, 0.2059D+03, & + 0.2050D+03, 0.2041D+03, 0.2037D+03, 0.2033D+03, & + 0.2029D+03, 0.2031D+03, 0.2032D+03, 0.2034D+03 & + / + data (TREF(38,10, mtmp), mtmp=1,12) & + / & + 0.2037D+03, 0.2034D+03, 0.2030D+03, 0.2031D+03, & + 0.2033D+03, 0.2034D+03, 0.2045D+03, 0.2056D+03, & + 0.2067D+03, 0.2058D+03, 0.2050D+03, 0.2041D+03 & + / + data (TREF(38,11, mtmp), mtmp=1,12) & + / & + 0.2039D+03, 0.2039D+03, 0.2037D+03, 0.2034D+03, & + 0.2029D+03, 0.2026D+03, 0.2053D+03, 0.2080D+03, & + 0.2108D+03, 0.2085D+03, 0.2062D+03, 0.2040D+03 & + / + data (TREF(38,12, mtmp), mtmp=1,12) & + / & + 0.2058D+03, 0.2067D+03, 0.2077D+03, 0.2056D+03, & + 0.2034D+03, 0.2014D+03, 0.2041D+03, 0.2068D+03, & + 0.2095D+03, 0.2099D+03, 0.2064D+03, 0.2049D+03 & + / + data (TREF(38,13, mtmp), mtmp=1,12) & + / & + 0.2096D+03, 0.2102D+03, 0.2107D+03, 0.2064D+03, & + 0.2020D+03, 0.1975D+03, 0.1992D+03, 0.2009D+03, & + 0.2027D+03, 0.2048D+03, 0.2069D+03, 0.2090D+03 & + / + data (TREF(38,14, mtmp), mtmp=1,12) & + / & + 0.2146D+03, 0.2139D+03, 0.2132D+03, 0.2066D+03, & + 0.2002D+03, 0.1936D+03, 0.1943D+03, 0.1951D+03, & + 0.1958D+03, 0.2023D+03, 0.2088D+03, 0.2153D+03 & + / + data (TREF(38,15, mtmp), mtmp=1,12) & + / & + 0.2187D+03, 0.2174D+03, 0.2161D+03, 0.2084D+03, & + 0.2008D+03, 0.1931D+03, 0.1934D+03, 0.1938D+03, & + 0.1941D+03, 0.2028D+03, 0.2114D+03, 0.2201D+03 & + / + data (TREF(38,16, mtmp), mtmp=1,12) & + / & + 0.2186D+03, 0.2171D+03, 0.2156D+03, 0.2088D+03, & + 0.2018D+03, 0.1950D+03, 0.1958D+03, 0.1967D+03, & + 0.1976D+03, 0.2051D+03, 0.2126D+03, 0.2200D+03 & + / + data (TREF(38,17, mtmp), mtmp=1,12) & + / & + 0.2152D+03, 0.2135D+03, 0.2118D+03, 0.2069D+03, & + 0.2020D+03, 0.1971D+03, 0.1986D+03, 0.2003D+03, & + 0.2019D+03, 0.2069D+03, 0.2119D+03, 0.2170D+03 & + / + data (TREF(38,18, mtmp), mtmp=1,12) & + / & + 0.2136D+03, 0.2118D+03, 0.2100D+03, 0.2061D+03, & + 0.2022D+03, 0.1983D+03, 0.2000D+03, 0.2018D+03, & + 0.2036D+03, 0.2076D+03, 0.2114D+03, 0.2154D+03 & + / + data (TREF(39, 1, mtmp), mtmp=1,12) & + / & + 0.1907D+03, 0.1940D+03, 0.1973D+03, 0.2031D+03, & + 0.2090D+03, 0.2148D+03, 0.2132D+03, 0.2116D+03, & + 0.2100D+03, 0.2026D+03, 0.1952D+03, 0.1879D+03 & + / + data (TREF(39, 2, mtmp), mtmp=1,12) & + / & + 0.1898D+03, 0.1926D+03, 0.1955D+03, 0.2022D+03, & + 0.2090D+03, 0.2157D+03, 0.2142D+03, 0.2126D+03, & + 0.2111D+03, 0.2031D+03, 0.1951D+03, 0.1872D+03 & + / + data (TREF(39, 3, mtmp), mtmp=1,12) & + / & + 0.1875D+03, 0.1894D+03, 0.1913D+03, 0.2000D+03, & + 0.2088D+03, 0.2176D+03, 0.2163D+03, 0.2149D+03, & + 0.2136D+03, 0.2043D+03, 0.1952D+03, 0.1858D+03 & + / + data (TREF(39, 4, mtmp), mtmp=1,12) & + / & + 0.1863D+03, 0.1875D+03, 0.1888D+03, 0.1982D+03, & + 0.2076D+03, 0.2171D+03, 0.2157D+03, 0.2143D+03, & + 0.2130D+03, 0.2037D+03, 0.1945D+03, 0.1853D+03 & + / + data (TREF(39, 5, mtmp), mtmp=1,12) & + / & + 0.1887D+03, 0.1901D+03, 0.1918D+03, 0.1986D+03, & + 0.2053D+03, 0.2121D+03, 0.2113D+03, 0.2104D+03, & + 0.2096D+03, 0.2021D+03, 0.1947D+03, 0.1872D+03 & + / + data (TREF(39, 6, mtmp), mtmp=1,12) & + / & + 0.1947D+03, 0.1968D+03, 0.1991D+03, 0.2013D+03, & + 0.2035D+03, 0.2057D+03, 0.2063D+03, 0.2067D+03, & + 0.2073D+03, 0.2024D+03, 0.1975D+03, 0.1925D+03 & + / + data (TREF(39, 7, mtmp), mtmp=1,12) & + / & + 0.2002D+03, 0.2029D+03, 0.2056D+03, 0.2044D+03, & + 0.2032D+03, 0.2021D+03, 0.2030D+03, 0.2039D+03, & + 0.2049D+03, 0.2025D+03, 0.2000D+03, 0.1974D+03 & + / + data (TREF(39, 8, mtmp), mtmp=1,12) & + / & + 0.2018D+03, 0.2043D+03, 0.2068D+03, 0.2052D+03, & + 0.2037D+03, 0.2021D+03, 0.2019D+03, 0.2016D+03, & + 0.2013D+03, 0.2007D+03, 0.2000D+03, 0.1995D+03 & + / + data (TREF(39, 9, mtmp), mtmp=1,12) & + / & + 0.2021D+03, 0.2026D+03, 0.2033D+03, 0.2032D+03, & + 0.2030D+03, 0.2028D+03, 0.2019D+03, 0.2011D+03, & + 0.2002D+03, 0.2007D+03, 0.2010D+03, 0.2013D+03 & + / + data (TREF(39,10, mtmp), mtmp=1,12) & + / & + 0.2019D+03, 0.2011D+03, 0.2003D+03, 0.2006D+03, & + 0.2010D+03, 0.2013D+03, 0.2020D+03, 0.2026D+03, & + 0.2033D+03, 0.2031D+03, 0.2029D+03, 0.2028D+03 & + / + data (TREF(39,11, mtmp), mtmp=1,12) & + / & + 0.2018D+03, 0.2017D+03, 0.2014D+03, 0.2007D+03, & + 0.2000D+03, 0.1994D+03, 0.2018D+03, 0.2043D+03, & + 0.2068D+03, 0.2052D+03, 0.2037D+03, 0.2021D+03 & + / + data (TREF(39,12, mtmp), mtmp=1,12) & + / & + 0.2031D+03, 0.2039D+03, 0.2049D+03, 0.2025D+03, & + 0.2000D+03, 0.1975D+03, 0.2002D+03, 0.2029D+03, & + 0.2056D+03, 0.2060D+03, 0.2032D+03, 0.2021D+03 & + / + data (TREF(39,13, mtmp), mtmp=1,12) & + / & + 0.2063D+03, 0.2067D+03, 0.2073D+03, 0.2024D+03, & + 0.1975D+03, 0.1925D+03, 0.1947D+03, 0.1969D+03, & + 0.1991D+03, 0.2013D+03, 0.2035D+03, 0.2057D+03 & + / + data (TREF(39,14, mtmp), mtmp=1,12) & + / & + 0.2113D+03, 0.2105D+03, 0.2096D+03, 0.2021D+03, & + 0.1946D+03, 0.1871D+03, 0.1886D+03, 0.1902D+03, & + 0.1918D+03, 0.1985D+03, 0.2054D+03, 0.2121D+03 & + / + data (TREF(39,15, mtmp), mtmp=1,12) & + / & + 0.2156D+03, 0.2143D+03, 0.2130D+03, 0.2037D+03, & + 0.1945D+03, 0.1852D+03, 0.1864D+03, 0.1875D+03, & + 0.1888D+03, 0.1982D+03, 0.2075D+03, 0.2170D+03 & + / + data (TREF(39,16, mtmp), mtmp=1,12) & + / & + 0.2162D+03, 0.2148D+03, 0.2135D+03, 0.2043D+03, & + 0.1951D+03, 0.1859D+03, 0.1875D+03, 0.1894D+03, & + 0.1913D+03, 0.1999D+03, 0.2087D+03, 0.2176D+03 & + / + data (TREF(39,17, mtmp), mtmp=1,12) & + / & + 0.2142D+03, 0.2126D+03, 0.2111D+03, 0.2031D+03, & + 0.1951D+03, 0.1870D+03, 0.1898D+03, 0.1926D+03, & + 0.1955D+03, 0.2021D+03, 0.2090D+03, 0.2158D+03 & + / + data (TREF(39,18, mtmp), mtmp=1,12) & + / & + 0.2132D+03, 0.2116D+03, 0.2100D+03, 0.2026D+03, & + 0.1952D+03, 0.1877D+03, 0.1909D+03, 0.1941D+03, & + 0.1973D+03, 0.2031D+03, 0.2090D+03, 0.2148D+03 & + / + data (TREF(40, 1, mtmp), mtmp=1,12) & + / & + 0.1707D+03, 0.1861D+03, 0.1909D+03, 0.1989D+03, & + 0.2067D+03, 0.2142D+03, 0.2128D+03, 0.2113D+03, & + 0.2098D+03, 0.1992D+03, 0.1882D+03, 0.1776D+03 & + / + data (TREF(40, 2, mtmp), mtmp=1,12) & + / & + 0.1807D+03, 0.1847D+03, 0.1889D+03, 0.1974D+03, & + 0.2062D+03, 0.2146D+03, 0.2131D+03, 0.2117D+03, & + 0.2102D+03, 0.1993D+03, 0.1881D+03, 0.1777D+03 & + / + data (TREF(40, 3, mtmp), mtmp=1,12) & + / & + 0.1798D+03, 0.1823D+03, 0.1847D+03, 0.1949D+03, & + 0.2049D+03, 0.2151D+03, 0.2140D+03, 0.2127D+03, & + 0.2114D+03, 0.2000D+03, 0.1883D+03, 0.1770D+03 & + / + data (TREF(40, 4, mtmp), mtmp=1,12) & + / & + 0.1791D+03, 0.1818D+03, 0.1834D+03, 0.1939D+03, & + 0.2039D+03, 0.2138D+03, 0.2126D+03, 0.2113D+03, & + 0.2099D+03, 0.1991D+03, 0.1882D+03, 0.1773D+03 & + / + data (TREF(40, 5, mtmp), mtmp=1,12) & + / & + 0.1832D+03, 0.1856D+03, 0.1877D+03, 0.1949D+03, & + 0.2020D+03, 0.2090D+03, 0.2081D+03, 0.2071D+03, & + 0.2060D+03, 0.1977D+03, 0.1894D+03, 0.1810D+03 & + / + data (TREF(40, 6, mtmp), mtmp=1,12) & + / & + 0.1905D+03, 0.1931D+03, 0.1956D+03, 0.1977D+03, & + 0.2000D+03, 0.2023D+03, 0.2028D+03, 0.2034D+03, & + 0.2040D+03, 0.1986D+03, 0.1933D+03, 0.1878D+03 & + / + data (TREF(40, 7, mtmp), mtmp=1,12) & + / & + 0.1965D+03, 0.1992D+03, 0.2019D+03, 0.2010D+03, & + 0.2001D+03, 0.1992D+03, 0.2001D+03, 0.2012D+03, & + 0.2021D+03, 0.1995D+03, 0.1966D+03, 0.1938D+03 & + / + data (TREF(40, 8, mtmp), mtmp=1,12) & + / & + 0.1985D+03, 0.2008D+03, 0.2030D+03, 0.2021D+03, & + 0.2012D+03, 0.2002D+03, 0.1999D+03, 0.1994D+03, & + 0.1990D+03, 0.1982D+03, 0.1973D+03, 0.1964D+03 & + / + data (TREF(40, 9, mtmp), mtmp=1,12) & + / & + 0.1995D+03, 0.1998D+03, 0.2002D+03, 0.2007D+03, & + 0.2010D+03, 0.2015D+03, 0.2002D+03, 0.1989D+03, & + 0.1978D+03, 0.1983D+03, 0.1988D+03, 0.1994D+03 & + / + data (TREF(40,10, mtmp), mtmp=1,12) & + / & + 0.2002D+03, 0.1989D+03, 0.1978D+03, 0.1983D+03, & + 0.1988D+03, 0.1994D+03, 0.1996D+03, 0.2000D+03, & + 0.2002D+03, 0.2006D+03, 0.2010D+03, 0.2015D+03 & + / + data (TREF(40,11, mtmp), mtmp=1,12) & + / & + 0.1999D+03, 0.1994D+03, 0.1990D+03, 0.1982D+03, & + 0.1973D+03, 0.1965D+03, 0.1986D+03, 0.2008D+03, & + 0.2029D+03, 0.2021D+03, 0.2012D+03, 0.2003D+03 & + / + data (TREF(40,12, mtmp), mtmp=1,12) & + / & + 0.2002D+03, 0.2012D+03, 0.2022D+03, 0.1995D+03, & + 0.1966D+03, 0.1938D+03, 0.1966D+03, 0.1992D+03, & + 0.2019D+03, 0.2018D+03, 0.2001D+03, 0.1991D+03 & + / + data (TREF(40,13, mtmp), mtmp=1,12) & + / & + 0.2028D+03, 0.2034D+03, 0.2040D+03, 0.1986D+03, & + 0.1932D+03, 0.1878D+03, 0.1905D+03, 0.1931D+03, & + 0.1956D+03, 0.1977D+03, 0.2000D+03, 0.2023D+03 & + / + data (TREF(40,14, mtmp), mtmp=1,12) & + / & + 0.2078D+03, 0.2070D+03, 0.2061D+03, 0.1977D+03, & + 0.1893D+03, 0.1810D+03, 0.1832D+03, 0.1856D+03, & + 0.1877D+03, 0.1949D+03, 0.2019D+03, 0.2088D+03 & + / + data (TREF(40,15, mtmp), mtmp=1,12) & + / & + 0.2126D+03, 0.2112D+03, 0.2098D+03, 0.1992D+03, & + 0.1884D+03, 0.1775D+03, 0.1792D+03, 0.1818D+03, & + 0.1834D+03, 0.1939D+03, 0.2039D+03, 0.2139D+03 & + / + data (TREF(40,16, mtmp), mtmp=1,12) & + / & + 0.2138D+03, 0.2127D+03, 0.2114D+03, 0.1999D+03, & + 0.1886D+03, 0.1767D+03, 0.1798D+03, 0.1825D+03, & + 0.1847D+03, 0.1951D+03, 0.2052D+03, 0.2152D+03 & + / + data (TREF(40,17, mtmp), mtmp=1,12) & + / & + 0.2131D+03, 0.2117D+03, 0.2102D+03, 0.1992D+03, & + 0.1883D+03, 0.1776D+03, 0.1811D+03, 0.1849D+03, & + 0.1888D+03, 0.1973D+03, 0.2059D+03, 0.2145D+03 & + / + data (TREF(40,18, mtmp), mtmp=1,12) & + / & + 0.2128D+03, 0.2114D+03, 0.2098D+03, 0.1990D+03, & + 0.1884D+03, 0.1780D+03, 0.1816D+03, 0.1863D+03, & + 0.1908D+03, 0.1987D+03, 0.2065D+03, 0.2143D+03 & + / + data (TREF(41, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(41, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(41, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(41, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(41, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(41, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(41, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(41, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(41, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(41,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(41,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(41,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(41,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(41,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(41,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(41,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(41,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(41,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(42, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(42, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(42, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(42, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(42, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(42, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(42, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(42, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(42, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(42,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(42,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(42,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(42,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(42,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(42,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(42,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(42,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(42,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(43, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(43, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(43, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(43, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(43, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(43, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(43, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(43, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(43, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(43,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(43,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(43,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(43,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(43,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(43,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(43,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(43,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(43,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(44, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(44, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(44, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(44, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(44, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(44, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(44, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(44, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(44, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(44,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(44,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(44,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(44,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(44,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(44,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(44,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(44,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(44,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(45, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(45, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(45, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(45, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(45, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(45, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(45, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(45, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(45, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(45,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(45,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(45,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(45,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(45,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(45,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(45,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(45,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(45,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(46, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(46, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(46, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(46, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(46, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(46, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(46, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(46, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(46, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(46,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(46,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(46,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(46,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(46,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(46,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(46,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(46,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(46,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(47, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(47, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(47, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(47, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(47, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(47, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(47, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(47, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(47, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(47,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(47,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(47,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(47,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(47,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(47,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(47,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(47,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(47,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(48, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(48, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(48, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(48, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(48, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(48, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(48, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(48, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(48, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(48,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(48,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(48,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(48,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(48,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(48,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(48,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(48,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(48,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(49, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(49, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(49, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(49, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(49, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(49, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(49, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(49, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(49, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(49,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(49,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(49,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(49,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(49,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(49,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(49,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(49,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(49,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(50, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(50, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(50, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(50, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(50, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(50, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(50, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(50, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(50, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(50,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(50,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(50,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(50,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(50,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(50,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(50,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(50,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(50,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + data (TREF(51, 1, mtmp), mtmp=1,12) & + / & + 0.1704D+03, 0.1817D+03, 0.1871D+03, 0.1960D+03, & + 0.2050D+03, 0.2142D+03, 0.2125D+03, 0.2107D+03, & + 0.2091D+03, 0.1960D+03, 0.1833D+03, 0.1600D+03 & + / + data (TREF(51, 2, mtmp), mtmp=1,12) & + / & + 0.1690D+03, 0.1804D+03, 0.1854D+03, 0.1951D+03, & + 0.2045D+03, 0.2141D+03, 0.2125D+03, 0.2107D+03, & + 0.2089D+03, 0.1960D+03, 0.1833D+03, 0.1590D+03 & + / + data (TREF(51, 3, mtmp), mtmp=1,12) & + / & + 0.1662D+03, 0.1778D+03, 0.1819D+03, 0.1925D+03, & + 0.2036D+03, 0.2143D+03, 0.2125D+03, 0.2109D+03, & + 0.2092D+03, 0.1962D+03, 0.1834D+03, 0.1702D+03 & + / + data (TREF(51, 4, mtmp), mtmp=1,12) & + / & + 0.1747D+03, 0.1775D+03, 0.1813D+03, 0.1913D+03, & + 0.2019D+03, 0.2125D+03, 0.2110D+03, 0.2089D+03, & + 0.2071D+03, 0.1951D+03, 0.1832D+03, 0.1713D+03 & + / + data (TREF(51, 5, mtmp), mtmp=1,12) & + / & + 0.1792D+03, 0.1825D+03, 0.1865D+03, 0.1934D+03, & + 0.2005D+03, 0.2076D+03, 0.2059D+03, 0.2048D+03, & + 0.2032D+03, 0.1939D+03, 0.1848D+03, 0.1756D+03 & + / + data (TREF(51, 6, mtmp), mtmp=1,12) & + / & + 0.1872D+03, 0.1903D+03, 0.1938D+03, 0.1963D+03, & + 0.1986D+03, 0.2009D+03, 0.2011D+03, 0.2011D+03, & + 0.2012D+03, 0.1954D+03, 0.1897D+03, 0.1839D+03 & + / + data (TREF(51, 7, mtmp), mtmp=1,12) & + / & + 0.1938D+03, 0.1965D+03, 0.1993D+03, 0.1986D+03, & + 0.1979D+03, 0.1974D+03, 0.1983D+03, 0.1991D+03, & + 0.1998D+03, 0.1969D+03, 0.1939D+03, 0.1911D+03 & + / + data (TREF(51, 8, mtmp), mtmp=1,12) & + / & + 0.1963D+03, 0.1984D+03, 0.2007D+03, 0.1999D+03, & + 0.1991D+03, 0.1984D+03, 0.1981D+03, 0.1977D+03, & + 0.1973D+03, 0.1962D+03, 0.1953D+03, 0.1943D+03 & + / + data (TREF(51, 9, mtmp), mtmp=1,12) & + / & + 0.1979D+03, 0.1980D+03, 0.1983D+03, 0.1989D+03, & + 0.1993D+03, 0.1998D+03, 0.1986D+03, 0.1974D+03, & + 0.1962D+03, 0.1967D+03, 0.1971D+03, 0.1976D+03 & + / + data (TREF(51,10, mtmp), mtmp=1,12) & + / & + 0.1987D+03, 0.1975D+03, 0.1962D+03, 0.1967D+03, & + 0.1971D+03, 0.1976D+03, 0.1978D+03, 0.1980D+03, & + 0.1984D+03, 0.1988D+03, 0.1993D+03, 0.1998D+03 & + / + data (TREF(51,11, mtmp), mtmp=1,12) & + / & + 0.1981D+03, 0.1977D+03, 0.1973D+03, 0.1963D+03, & + 0.1953D+03, 0.1942D+03, 0.1964D+03, 0.1985D+03, & + 0.2007D+03, 0.1998D+03, 0.1991D+03, 0.1984D+03 & + / + data (TREF(51,12, mtmp), mtmp=1,12) & + / & + 0.1983D+03, 0.1990D+03, 0.1998D+03, 0.1970D+03, & + 0.1939D+03, 0.1910D+03, 0.1938D+03, 0.1966D+03, & + 0.1993D+03, 0.1988D+03, 0.1980D+03, 0.1975D+03 & + / + data (TREF(51,13, mtmp), mtmp=1,12) & + / & + 0.2010D+03, 0.2011D+03, 0.2012D+03, 0.1954D+03, & + 0.1897D+03, 0.1839D+03, 0.1872D+03, 0.1904D+03, & + 0.1938D+03, 0.1963D+03, 0.1986D+03, 0.2009D+03 & + / + data (TREF(51,14, mtmp), mtmp=1,12) & + / & + 0.2062D+03, 0.2047D+03, 0.2031D+03, 0.1940D+03, & + 0.1847D+03, 0.1756D+03, 0.1791D+03, 0.1826D+03, & + 0.1864D+03, 0.1934D+03, 0.2006D+03, 0.2077D+03 & + / + data (TREF(51,15, mtmp), mtmp=1,12) & + / & + 0.2108D+03, 0.2090D+03, 0.2071D+03, 0.1950D+03, & + 0.1830D+03, 0.1711D+03, 0.1748D+03, 0.1774D+03, & + 0.1812D+03, 0.1913D+03, 0.2021D+03, 0.2128D+03 & + / + data (TREF(51,16, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2109D+03, 0.2093D+03, 0.1961D+03, & + 0.1831D+03, 0.1705D+03, 0.1651D+03, 0.1775D+03, & + 0.1818D+03, 0.1921D+03, 0.2031D+03, 0.2141D+03 & + / + data (TREF(51,17, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2107D+03, 0.2089D+03, 0.1960D+03, & + 0.1831D+03, 0.1701D+03, 0.1676D+03, 0.1803D+03, & + 0.1854D+03, 0.1951D+03, 0.2047D+03, 0.2143D+03 & + / + data (TREF(51,18, mtmp), mtmp=1,12) & + / & + 0.2125D+03, 0.2106D+03, 0.2090D+03, 0.1961D+03, & + 0.1831D+03, 0.1577D+03, 0.1691D+03, 0.1817D+03, & + 0.1872D+03, 0.1962D+03, 0.2052D+03, 0.2142D+03 & + / + + end module module_fastj_data diff --git a/wrfv2_fire/chem/module_fastj_mie.F b/wrfv2_fire/chem/module_fastj_mie.F new file mode 100755 index 00000000..3bf4440f --- /dev/null +++ b/wrfv2_fire/chem/module_fastj_mie.F @@ -0,0 +1,2484 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! Module to Compute Aerosol Optical Properties +! * Primary investigator: James C. Barnard +! * Co-investigators: Rahul A. Zaveri, Richard C. Easter, William I. Gustafson Jr. +! Last update: September 2005 +! +! Contact: +! Jerome D. Fast, PhD +! Staff Scientist +! Pacific Northwest National Laboratory +! P.O. Box 999, MSIN K9-30 +! Richland, WA, 99352 +! Phone: (509) 372-6116 +! Email: Jerome.Fast@pnl.gov +! +! Please report any bugs or problems to Jerome Fast, the WRF-chem implmentation +! team leader for PNNL +! +! Terms of Use: +! 1) This module may not be included in commerical package or used for any +! commercial applications without the consent of the PNNL contact. +! 2) This module is provided to the WRF modeling community; however, no portion +! of it can be used separately or in another code without the consent of the +! PNNL contact. +! 3) This module may be used for research, educational, and non-profit purposes +! only. Any other usage must be first approved by the PNNL contact. +! 4) Publications resulting from the usage of this module must use one the +! reference below for proper acknowledgment. +! +! Note that the aerosol optical properites are currently tied to the use of Fast-J +! and MOSAIC. Future modifications will make the calculations more generic so the +! code is not tied to the photolysis scheme and the code can be used for both +! modal and sectional treatments. +! +! References: +! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. Barnard, E.G. +! Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution of ozone, particulates, +! and aerosol direct radiative forcing in the vicinity of Houston using a fully- +! coupled meteorology-chemistry-aerosol model, Submitted to J. Geophys. Res. +! +! Contact Jerome Fast for updates on the status of manuscripts under review. +! +! Additional information: +! * www.pnl.gov/atmos_sciences/Jdf/wrfchem.html +! +! Support: +! Funding for adapting Fast-J was provided by the U.S. Department of Energy +! under the auspices of Atmospheric Science Program of the Office of Biological +! and Environmental Research the PNNL Laboratory Research and Directed Research +! and Development program. +!********************************************************************************** + module module_fastj_mie + + +! rce 2005-apr-22 - want lunerr = -1 for wrf-chem 3d; +! also, define lunerr here, and it's available everywhere + integer, parameter :: lunerr = -1 + + + contains + +!*********************************************************************** +! <1.> subr mieaer +! Purpose: calculate aerosol optical depth, single scattering albedo, +! asymmetry factor, extinction, Legendre coefficients, and average aerosol +! size. parameterizes aerosol coefficients using chebychev polynomials +! requires double precision on 32-bit machines +! uses Wiscombe's (1979) mie scattering code +! INPUT +! id -- grid id number +! iclm, jclm -- i,j of grid column being processed +! nbin_a -- number of bins +! number_bin(nbin_a,kmaxd) -- number density in layer, #/cm^3 +! radius_wet(nbin_a,kmaxd) -- wet radius, cm +! refindx(nbin_a,kmaxd) --volume averaged complex index of refraction +! dz -- depth of individual cells in column, m +! isecfrm0 - time from start of run, sec +! lpar -- number of grid cells in vertical (via module_fastj_cmnh) +! kmaxd -- predefined maximum allowed levels from module_data_mosaic_other +! passed here via module_fastj_cmnh +! OUTPUT: saved in module_fastj_cmnmie +! real tauaer ! aerosol optical depth +! waer ! aerosol single scattering albedo +! gaer ! aerosol asymmetery factor +! extaer ! aerosol extinction +! l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,...... +! sizeaer ! average wet radius +!---------------------------------------------------------------------- + subroutine mieaer( & + id, iclm, jclm, nbin_a, & + number_bin, radius_wet, refindx, & + dz, isecfrm0, lpar, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + + USE module_data_mosaic_other, only : kmaxd + USE module_data_mosaic_therm, ONLY: nbin_a_maxd + USE module_peg_util, only: peg_message + + IMPLICIT NONE +! subr arguments +!jdf + integer,parameter :: nspint = 4 ! Num of spectral intervals across + ! solar spectrum for FAST-J + integer, intent(in) :: lpar + real, dimension (nspint, kmaxd+1),intent(out) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1),intent(out) :: l2,l3,l4,l5,l6,l7 + real, dimension (nspint),save :: wavmid !cm + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + integer, intent(in) :: id, iclm, jclm, nbin_a, isecfrm0 + real, intent(in), dimension(nbin_a_maxd, kmaxd) :: number_bin + real, intent(inout), dimension(nbin_a_maxd, kmaxd) :: radius_wet + complex, intent(in) :: refindx(nbin_a_maxd, kmaxd) + real, intent(in) :: dz(lpar) + +!local variables + real weighte, weights +! various bookeeping variables + integer ltype ! total number of indicies of refraction + parameter (ltype = 1) ! bracket refractive indices based on information from Rahul, 2002/11/07 + real x + real thesum ! for normalizing things + real sizem ! size in microns + integer kcallmieaer +! + integer m, j, nc, klevel + real pext ! parameterized specific extinction (cm2/g) + real pasm ! parameterized asymmetry factor + real ppmom2 ! 2 Lengendre expansion coefficient (numbered 0,1,2,...) + real ppmom3 ! 3 ... + real ppmom4 ! 4 ... + real ppmom5 ! 5 ... + real ppmom6 ! 6 ... + real ppmom7 ! 7 ... + + integer ns ! Spectral loop index + integer i ! Longitude loop index + integer k ! Level loop index + real pscat !scattering cross section + + integer prefr,prefi,nrefr,nrefi,nr,ni + save nrefr,nrefi + parameter (prefr=7,prefi=7) + + complex*16 sforw,sback,tforw(2),tback(2) + integer numang,nmom,ipolzn,momdim + real*8 pmom(0:7,1) + logical perfct,anyang,prnt(2) + logical first + integer, parameter :: nsiz=200,nlog=30,ncoef=50 +! + real p2(nsiz),p3(nsiz),p4(nsiz),p5(nsiz) + real p6(nsiz),p7(nsiz) +! + real*8 xmu(1) + data xmu/1./,anyang/.false./ + data numang/0/ + complex*16 s1(1),s2(1) + data first/.true./ + save first + real*8 mimcut + data perfct/.false./,mimcut/0.0/ + data nmom/7/,ipolzn/0/,momdim/7/ + data prnt/.false.,.false./ +! coefficients for parameterizing aerosol radiative properties +! in terms of refractive index and wet radius + real extp(ncoef,prefr,prefi,nspint) ! specific extinction + real albp(ncoef,prefr,prefi,nspint) ! single scat alb + real asmp(ncoef,prefr,prefi,nspint) ! asymmetry factor + real ascat(ncoef,prefr,prefi,nspint) ! scattering efficiency, JCB 2004/02/09 + real pmom2(ncoef,prefr,prefi,nspint) ! phase function expansion, #2 + real pmom3(ncoef,prefr,prefi,nspint) ! phase function expansion, #3 + real pmom4(ncoef,prefr,prefi,nspint) ! phase function expansion, #4 + real pmom5(ncoef,prefr,prefi,nspint) ! phase function expansion, #5 + real pmom6(ncoef,prefr,prefi,nspint) ! phase function expansion, #6 + real pmom7(ncoef,prefr,prefi,nspint) ! phase function expansion, #7 + + save :: extp,albp,asmp,ascat,pmom2,pmom3,pmom4,pmom5,pmom6,pmom7 +!-------------- + real cext(ncoef),casm(ncoef),cpmom2(ncoef) + real cscat(ncoef) ! JCB 2004/02/09 + real cpmom3(ncoef),cpmom4(ncoef),cpmom5(ncoef) + real cpmom6(ncoef),cpmom7(ncoef) + integer itab,jtab + real ttab,utab + +! nsiz = number of wet particle sizes +! crefin = complex refractive index + integer n + real*8 thesize ! 2 pi radpart / waveleng = size parameter + real*8 qext(nsiz) ! array of extinction efficiencies + real*8 qsca(nsiz) ! array of scattering efficiencies + real*8 gqsc(nsiz) ! array of asymmetry factor * scattering efficiency + real asymm(nsiz) ! array of asymmetry factor + real scat(nsiz) ! JCB 2004/02/09 +! specabs = absorption coeff / unit dry mass +! specscat = scattering coeff / unit dry mass + complex*16 crefin,crefd,crefw + save crefw + real, save :: rmin,rmax ! min, max aerosol size bin + data rmin /0.005e-4/ ! rmin in cm. 5e-3 microns min allowable size + data rmax /50.e-4 / ! rmax in cm. 50 microns, big particle, max allowable size + + real bma,bpa + + real, save :: xrmin,xrmax,xr + real rs(nsiz) ! surface mode radius (cm) + real xrad ! normalized aerosol radius + real ch(ncoef) ! chebychev polynomial + + real, save :: rhoh2o ! density of liquid water (g/cm3) + data rhoh2o/1./ + + real refr ! real part of refractive index + real refi ! imaginary part of refractive index + real qextr4(nsiz) ! extinction, real*4 + + real refrmin ! minimum of real part of refractive index + real refrmax ! maximum of real part of refractive index + real refimin ! minimum of imag part of refractive index + real refimax ! maximum of imag part of refractive index + real drefr ! increment in real part of refractive index + real drefi ! increment in imag part of refractive index + real, save :: refrtab(prefr) ! table of real refractive indices for aerosols + real, save :: refitab(prefi) ! table of imag refractive indices for aerosols + complex specrefndx(ltype) ! refractivr indices + real pie,third + + integer irams, jrams +! diagnostic declarations + integer kcallmieaer2 + integer ibin + character*150 msg + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!ec diagnostics +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!ec run_out.25 has aerosol physical parameter info for bins 1-8 +!ec and vertical cells 1 to kmaxd. +! ilaporte = 33 +! jlaporte = 34 + if (iclm .eq. CHEM_DBG_I) then + if (jclm .eq. CHEM_DBG_J) then +! initial entry + if (kcallmieaer2 .eq. 0) then + write(*,9099)iclm, jclm + 9099 format('for cell i = ', i3, 2x, 'j = ', i3) + write(*,9100) + 9100 format( & + 'isecfrm0', 3x, 'i', 3x, 'j', 3x,'k', 3x, & + 'ibin', 3x, & + 'refindx(ibin,k)', 3x, & + 'radius_wet(ibin,k)', 3x, & + 'number_bin(ibin,k)' & + ) + end if +!ec output for run_out.25 + do k = 1, lpar + do ibin = 1, nbin_a + write(*, 9120) & + isecfrm0,iclm, jclm, k, ibin, & + refindx(ibin,k), & + radius_wet(ibin,k), & + number_bin(ibin,k) +9120 format( i7,3(2x,i4),2x,i4, 4x, 4(e14.6,2x)) + end do + end do + kcallmieaer2 = kcallmieaer2 + 1 + end if + end if +!ec end print of aerosol physical parameter diagnostics +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +#endif +! +! assign fast-J wavelength, these values are in cm +! wavmid(1)=0.30e-4 +! wavmid(2)=0.40e-4 +! wavmid(3)=0.60e-4 +! wavmid(4)=0.999e-04 +! + pie=4.*atan(1.) + third=1./3. + if(first)then + first=.false. + +! parameterize aerosol radiative properties in terms of +! relative humidity, surface mode wet radius, aerosol species, +! and wavelength + +! first find min,max of real and imaginary parts of refractive index + +! real and imaginary parts of water refractive index + + crefw=cmplx(1.33,0.0) + refrmin=real(crefw) + refrmax=real(crefw) +! change Rahul's imaginary part of the refractive index from positive to negative + refimin=-imag(crefw) + refimax=-imag(crefw) + +! aerosol mode loop + specrefndx(1)=cmplx(1.82,-0.74) ! max values from Rahul, 7 Nov 2002 +! + + do i=1,ltype ! loop over all possible refractive indices + +! real and imaginary parts of aerosol refractive index + + refrmin=amin1(refrmin,real(specrefndx(ltype))) + refrmax=amax1(refrmax,real(specrefndx(ltype))) + refimin=amin1(refimin,aimag(specrefndx(ltype))) + refimax=amax1(refimax,aimag(specrefndx(ltype))) + + enddo + + drefr=(refrmax-refrmin) + if(drefr.gt.1.e-4)then + nrefr=prefr + drefr=drefr/(nrefr-1) + else + nrefr=1 + endif + + drefi=(refimax-refimin) + if(drefi.gt.1.e-4)then + nrefi=prefi + drefi=drefi/(nrefi-1) + else + nrefi=1 + endif + + +! + bma=0.5*alog(rmax/rmin) ! JCB + bpa=0.5*alog(rmax*rmin) ! JCB + xrmin=alog(rmin) + xrmax=alog(rmax) + +! wavelength loop + + do 200 ns=1,nspint + +! calibrate parameterization with range of refractive indices + + do 120 nr=1,nrefr + do 120 ni=1,nrefi + + refrtab(nr)=refrmin+(nr-1)*drefr + refitab(ni)=refimin+(ni-1)*drefi + crefd=cmplx(refrtab(nr),refitab(ni)) + +! mie calculations of optical efficiencies + + do n=1,nsiz + xr=cos(pie*(float(n)-0.5)/float(nsiz)) + rs(n)=exp(xr*bma+bpa) + + +! size parameter and weighted refractive index + + thesize=2.*pie*rs(n)/wavmid(ns) + thesize=min(thesize,10000.d0) + + call miev0(thesize,crefd,perfct,mimcut,anyang, & + numang,xmu,nmom,ipolzn,momdim,prnt, & + qext(n),qsca(n),gqsc(n),pmom,sforw,sback,s1, & + s2,tforw,tback ) + qextr4(n)=qext(n) +! qabs(n)=qext(n)-qsca(n) ! not necessary anymore JCB 2004/02/09 + scat(n)=qsca(n) ! JCB 2004/02/09 + asymm(n)=gqsc(n)/qsca(n) ! assume always greater than zero +! coefficients of phase function expansion; note modification by JCB of miev0 coefficients + p2(n)=pmom(2,1)/pmom(0,1)*5.0 + p3(n)=pmom(3,1)/pmom(0,1)*7.0 + p4(n)=pmom(4,1)/pmom(0,1)*9.0 + p5(n)=pmom(5,1)/pmom(0,1)*11.0 + p6(n)=pmom(6,1)/pmom(0,1)*13.0 + p7(n)=pmom(7,1)/pmom(0,1)*15.0 + enddo + 100 continue +! + call fitcurv(rs,qextr4,extp(1,nr,ni,ns),ncoef,nsiz) + call fitcurv(rs,scat,ascat(1,nr,ni,ns),ncoef,nsiz) ! JCB 2004/02/07 - scattering efficiency + call fitcurv(rs,asymm,asmp(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p2,pmom2(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p3,pmom3(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p4,pmom4(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p5,pmom5(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p6,pmom6(1,nr,ni,ns),ncoef,nsiz) + call fitcurv_nolog(rs,p7,pmom7(1,nr,ni,ns),ncoef,nsiz) + + 120 continue + 200 continue + + + endif +! begin level loop + do 2000 klevel=1,lpar +! sum densities for normalization + thesum=0.0 + do m=1,nbin_a + thesum=thesum+number_bin(m,klevel) + enddo +! Begin spectral loop + do 1000 ns=1,nspint + +! aerosol optical properties + + tauaer(ns,klevel)=0. + waer(ns,klevel)=0. + gaer(ns,klevel)=0. + sizeaer(ns,klevel)=0.0 + extaer(ns,klevel)=0.0 + l2(ns,klevel)=0.0 + l3(ns,klevel)=0.0 + l4(ns,klevel)=0.0 + l5(ns,klevel)=0.0 + l6(ns,klevel)=0.0 + l7(ns,klevel)=0.0 + if(thesum.le.1e-21)goto 1000 ! set everything = 0 if no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005 + +! loop over the bins + do m=1,nbin_a ! nbin_a is number of bins +! check to see if there's any aerosol + if(number_bin(m,klevel).le.1e-21)goto 70 ! no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005 +! here's the size + sizem=radius_wet(m,klevel) ! radius in cm +! check limits of particle size +! rce 2004-dec-07 - use klevel in write statements + if(radius_wet(m,klevel).le.rmin)then + radius_wet(m,klevel)=rmin + write( msg, '(a, 5i4,1x, e11.4)' ) & + 'FASTJ mie: radius_wet set to rmin,' // & + 'id,i,j,k,m,rm(m,k)', id, iclm, jclm, klevel, m, radius_wet(m,klevel) + call peg_message( lunerr, msg ) +! write(6,'('' particle size too small '')') + endif +! + if(radius_wet(m,klevel).gt.rmax)then + write( msg, '(a, 5i4,1x, e11.4)' ) & + 'FASTJ mie: radius_wet set to rmax,' // & + 'id,i,j,k,m,rm(m,k)', & + id, iclm, jclm, klevel, m, radius_wet(m,klevel) + call peg_message( lunerr, msg ) + radius_wet(m,klevel)=rmax +! write(6,'('' particle size too large '')') + endif +! + x=alog(radius_wet(m,klevel)) ! radius in cm +! + crefin=refindx(m,klevel) + refr=real(crefin) +! change Rahul's imaginary part of the index of refraction from positive to negative + refi=-imag(crefin) +! + xrad=x + + thesize=2.0*pie*exp(x)/wavmid(ns) +! normalize size parameter + xrad=(2*xrad-xrmax-xrmin)/(xrmax-xrmin) +! retain this diagnostic code + if(abs(refr).gt.10.0.or.abs(refr).le.0.001)then + write ( msg, '(a,1x, e14.5)' ) & + 'FASTJ mie /refr/ outside range 1e-3 - 10 ' // & + 'refr= ', refr + call peg_message( lunerr, msg ) +! print *,'refr=',refr + call exit(1) + endif + if(abs(refi).gt.10.)then + write ( msg, '(a,1x, e14.5)' ) & + 'FASTJ mie /refi/ >10 ' // & + 'refi', refi + call peg_message( lunerr, msg ) +! print *,'refi=',refi + call exit(1) + endif + +! interpolate coefficients linear in refractive index +! first call calcs itab,jtab,ttab,utab + itab=0 + call binterp(extp(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cext) + +! JCB 2004/02/09 -- new code for scattering cross section + call binterp(ascat(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cscat) + call binterp(asmp(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,casm) + call binterp(pmom2(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom2) + call binterp(pmom3(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom3) + call binterp(pmom4(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom4) + call binterp(pmom5(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom5) + call binterp(pmom6(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom6) + call binterp(pmom7(1,1,1,ns),ncoef,nrefr,nrefi, & + refr,refi,refrtab,refitab,itab,jtab, & + ttab,utab,cpmom7) + +! chebyshev polynomials + + ch(1)=1. + ch(2)=xrad + do nc=3,ncoef + ch(nc)=2.*xrad*ch(nc-1)-ch(nc-2) + enddo +! parameterized optical properties + + pext=0.5*cext(1) + do nc=2,ncoef + pext=pext+ch(nc)*cext(nc) + enddo + pext=exp(pext) + +! JCB 2004/02/09 -- for scattering efficiency + pscat=0.5*cscat(1) + do nc=2,ncoef + pscat=pscat+ch(nc)*cscat(nc) + enddo + pscat=exp(pscat) +! + pasm=0.5*casm(1) + do nc=2,ncoef + pasm=pasm+ch(nc)*casm(nc) + enddo + pasm=exp(pasm) +! + ppmom2=0.5*cpmom2(1) + do nc=2,ncoef + ppmom2=ppmom2+ch(nc)*cpmom2(nc) + enddo + if(ppmom2.le.0.0)ppmom2=0.0 +! + ppmom3=0.5*cpmom3(1) + do nc=2,ncoef + ppmom3=ppmom3+ch(nc)*cpmom3(nc) + enddo +! ppmom3=exp(ppmom3) ! no exponentiation required + if(ppmom3.le.0.0)ppmom3=0.0 +! + ppmom4=0.5*cpmom4(1) + do nc=2,ncoef + ppmom4=ppmom4+ch(nc)*cpmom4(nc) + enddo + if(ppmom4.le.0.0.or.sizem.le.0.03e-04)ppmom4=0.0 +! + ppmom5=0.5*cpmom5(1) + do nc=2,ncoef + ppmom5=ppmom5+ch(nc)*cpmom5(nc) + enddo + if(ppmom5.le.0.0.or.sizem.le.0.03e-04)ppmom5=0.0 +! + ppmom6=0.5*cpmom6(1) + do nc=2,ncoef + ppmom6=ppmom6+ch(nc)*cpmom6(nc) + enddo + if(ppmom6.le.0.0.or.sizem.le.0.03e-04)ppmom6=0.0 +! + ppmom7=0.5*cpmom7(1) + do nc=2,ncoef + ppmom7=ppmom7+ch(nc)*cpmom7(nc) + enddo + if(ppmom7.le.0.0.or.sizem.le.0.03e-04)ppmom7=0.0 +! +! weights: + weighte=pext*pie*exp(x)**2 ! JCB, extinction cross section + weights=pscat*pie*exp(x)**2 ! JCB, scattering cross section + tauaer(ns,klevel)=tauaer(ns,klevel)+weighte*number_bin(m,klevel) ! must be multiplied by deltaZ + extaer(ns,klevel)=extaer(ns,klevel)+pext*number_bin(m,klevel) + sizeaer(ns,klevel)=sizeaer(ns,klevel)+exp(x)*10000.0* & + number_bin(m,klevel) + waer(ns,klevel)=waer(ns,klevel)+weights*number_bin(m,klevel) !JCB + gaer(ns,klevel)=gaer(ns,klevel)+pasm*weights* & + number_bin(m,klevel) !JCB +! need weighting by scattering cross section ? JCB 2004/02/09 + l2(ns,klevel)=l2(ns,klevel)+weights*ppmom2*number_bin(m,klevel) + l3(ns,klevel)=l3(ns,klevel)+weights*ppmom3*number_bin(m,klevel) + l4(ns,klevel)=l4(ns,klevel)+weights*ppmom4*number_bin(m,klevel) + l5(ns,klevel)=l5(ns,klevel)+weights*ppmom5*number_bin(m,klevel) + l6(ns,klevel)=l6(ns,klevel)+weights*ppmom6*number_bin(m,klevel) + l7(ns,klevel)=l7(ns,klevel)+weights*ppmom7*number_bin(m,klevel) + + end do ! end of nbin_a loop +! take averages - weighted by cross section - new code JCB 2004/02/09 + extaer(ns,klevel)=extaer(ns,klevel)/thesum + sizeaer(ns,klevel)=sizeaer(ns,klevel)/thesum + gaer(ns,klevel)=gaer(ns,klevel)/waer(ns,klevel) ! JCB removed *3 factor 2/9/2004 +! because factor is applied in subroutine opmie, file zz01fastj_mod.f + l2(ns,klevel)=l2(ns,klevel)/waer(ns,klevel) + l3(ns,klevel)=l3(ns,klevel)/waer(ns,klevel) + l4(ns,klevel)=l4(ns,klevel)/waer(ns,klevel) + l5(ns,klevel)=l5(ns,klevel)/waer(ns,klevel) + l6(ns,klevel)=l6(ns,klevel)/waer(ns,klevel) + l7(ns,klevel)=l7(ns,klevel)/waer(ns,klevel) +! this must be last!! JCB 2007/02/09 + waer(ns,klevel)=waer(ns,klevel)/tauaer(ns,klevel) ! JCB + + 70 continue ! bail out if no aerosol;go on to next wavelength bin + + 1000 continue ! end of wavelength loop + + +2000 continue ! end of klevel loop +! +! before returning, multiply tauaer by depth of individual cells. +! tauaer is in cm, dz in m; multiply dz by 100 to convert from m to cm. + do ns = 1, nspint + do klevel = 1, lpar + tauaer(ns,klevel) = tauaer(ns,klevel) * dz(klevel)* 100. + end do + end do + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!ec fastj diagnostics +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!ec run_out.30 has aerosol optical info for cells 1 to kmaxd. +! ilaporte = 33 +! jlaporte = 34 + if (iclm .eq. CHEM_DBG_I) then + if (jclm .eq. CHEM_DBG_J) then +! initial entry + if (kcallmieaer .eq. 0) then + write(*,909) CHEM_DBG_I, CHEM_DBG_J + 909 format( ' for cell i = ', i3, ' j = ', i3) + write(*,910) + 910 format( & + 'isecfrm0', 3x, 'i', 3x, 'j', 3x,'k', 3x, & + 'dzmfastj', 8x, & + 'tauaer(1,k)',1x, 'tauaer(2,k)',1x,'tauaer(3,k)',3x, & + 'tauaer(4,k)',5x, & + 'waer(1,k)', 7x, 'waer(2,k)', 7x,'waer(3,k)', 7x, & + 'waer(4,k)', 7x, & + 'gaer(1,k)', 7x, 'gaer(2,k)', 7x,'gaer(3,k)', 7x, & + 'gaer(4,k)', 7x, & + 'extaer(1,k)',5x, 'extaer(2,k)',5x,'extaer(3,k)',5x, & + 'extaer(4,k)',5x, & + 'sizeaer(1,k)',4x, 'sizeaer(2,k)',4x,'sizeaer(3,k)',4x, & + 'sizeaer(4,k)' ) + end if +!ec output for run_out.30 + do k = 1, lpar + write(*, 912) & + isecfrm0,iclm, jclm, k, & + dz(k) , & + (tauaer(n,k), n=1,4), & + (waer(n,k), n=1,4), & + (gaer(n,k), n=1,4), & + (extaer(n,k), n=1,4), & + (sizeaer(n,k), n=1,4) + 912 format( i7,3(2x,i4),2x,21(e14.6,2x)) + end do + kcallmieaer = kcallmieaer + 1 + end if + end if +!ec end print of fastj diagnostics +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +#endif + + return + end subroutine mieaer +!**************************************************************** + subroutine fitcurv(rs,yin,coef,ncoef,maxm) + +! fit y(x) using Chebychev polynomials +! wig 7-Sep-2004: Removed dependency on pre-determined maximum +! array size and replaced with f90 array info. + + USE module_peg_util, only: peg_message + + IMPLICIT NONE +! integer nmodes, nrows, maxm, ncoef +! parameter (nmodes=500,nrows=8) + integer, intent(in) :: maxm, ncoef + +! real rs(nmodes),yin(nmodes),coef(ncoef) +! real x(nmodes),y(nmodes) + real, dimension(ncoef) :: coef + real, dimension(:) :: rs, yin + real x(size(rs)),y(size(yin)) + + integer m + real xmin, xmax + character*80 msg + +!!$ if(maxm.gt.nmodes)then +!!$ write ( msg, '(a, 1x,i6)' ) & +!!$ 'FASTJ mie nmodes too small in fitcurv, ' // & +!!$ 'maxm ', maxm +!!$ call peg_message( lunerr, msg ) +!!$! write(*,*)'nmodes too small in fitcurv',maxm +!!$ call exit(1) +!!$ endif + + do 100 m=1,maxm + x(m)=alog(rs(m)) + y(m)=alog(yin(m)) + 100 continue + + xmin=x(1) + xmax=x(maxm) + do 110 m=1,maxm + x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin) + 110 continue + + call chebft(coef,ncoef,maxm,y) + + return + end subroutine fitcurv +!************************************************************** + subroutine fitcurv_nolog(rs,yin,coef,ncoef,maxm) + +! fit y(x) using Chebychev polynomials +! wig 7-Sep-2004: Removed dependency on pre-determined maximum +! array size and replaced with f90 array info. + + USE module_peg_util, only: peg_message + IMPLICIT NONE + +! integer nmodes, nrows, maxm, ncoef +! parameter (nmodes=500,nrows=8) + integer, intent(in) :: maxm, ncoef + +! real rs(nmodes),yin(nmodes),coef(ncoef) + real, dimension(:) :: rs, yin + real, dimension(ncoef) :: coef(ncoef) + real x(size(rs)),y(size(yin)) + + integer m + real xmin, xmax + character*80 msg + +!!$ if(maxm.gt.nmodes)then +!!$ write ( msg, '(a,1x, i6)' ) & +!!$ 'FASTJ mie nmodes too small in fitcurv ' // & +!!$ 'maxm ', maxm +!!$ call peg_message( lunerr, msg ) +!!$! write(*,*)'nmodes too small in fitcurv',maxm +!!$ call exit(1) +!!$ endif + + do 100 m=1,maxm + x(m)=alog(rs(m)) + y(m)=yin(m) ! note, no "alog" here + 100 continue + + xmin=x(1) + xmax=x(maxm) + do 110 m=1,maxm + x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin) + 110 continue + + call chebft(coef,ncoef,maxm,y) + + return + end subroutine fitcurv_nolog +!************************************************************************ + subroutine chebft(c,ncoef,n,f) +! given a function f with values at zeroes x_k of Chebychef polynomial +! T_n(x), calculate coefficients c_j such that +! f(x)=sum(k=1,n) c_k t_(k-1)(y) - 0.5*c_1 +! where y=(x-0.5*(xmax+xmin))/(0.5*(xmax-xmin)) +! See Numerical Recipes, pp. 148-150. + + IMPLICIT NONE + real pi + integer ncoef, n + parameter (pi=3.14159265) + real c(ncoef),f(n) + +! local variables + real fac, thesum + integer j, k + + fac=2./n + do j=1,ncoef + thesum=0 + do k=1,n + thesum=thesum+f(k)*cos((pi*(j-1))*((k-0.5)/n)) + enddo + c(j)=fac*thesum + enddo + return + end subroutine chebft +!************************************************************************* + subroutine binterp(table,km,im,jm,x,y,xtab,ytab,ix,jy,t,u,out) + +! bilinear interpolation of table +! + implicit none + integer im,jm,km + real table(km,im,jm),xtab(im),ytab(jm),out(km) + integer i,ix,ip1,j,jy,jp1,k + real x,dx,t,y,dy,u,tu, tuc,tcu,tcuc + + if(ix.gt.0)go to 30 + if(im.gt.1)then + do i=1,im + if(x.lt.xtab(i))go to 10 + enddo + 10 ix=max0(i-1,1) + ip1=min0(ix+1,im) + dx=(xtab(ip1)-xtab(ix)) + if(abs(dx).gt.1.e-20)then + t=(x-xtab(ix))/(xtab(ix+1)-xtab(ix)) + else + t=0 + endif + else + ix=1 + ip1=1 + t=0 + endif + if(jm.gt.1)then + do j=1,jm + if(y.lt.ytab(j))go to 20 + enddo + 20 jy=max0(j-1,1) + jp1=min0(jy+1,jm) + dy=(ytab(jp1)-ytab(jy)) + if(abs(dy).gt.1.e-20)then + u=(y-ytab(jy))/dy + else + u=0 + endif + else + jy=1 + jp1=1 + u=0 + endif + 30 continue + jp1=min(jy+1,jm) + ip1=min(ix+1,im) + tu=t*u + tuc=t-tu + tcuc=1-tuc-u + tcu=u-tu + do k=1,km + out(k)=tcuc*table(k,ix,jy)+tuc*table(k,ip1,jy) & + +tu*table(k,ip1,jp1)+tcu*table(k,ix,jp1) + enddo + return + end subroutine binterp +!*************************************************************** + subroutine miev0 ( xx, crefin, perfct, mimcut, anyang, & + numang, xmu, nmom, ipolzn, momdim, prnt, & + qext, qsca, gqsc, pmom, sforw, sback, s1, & + s2, tforw, tback ) +! +! computes mie scattering and extinction efficiencies; asymmetry +! factor; forward- and backscatter amplitude; scattering +! amplitudes for incident polarization parallel and perpendicular +! to the plane of scattering, as functions of scattering angle; +! coefficients in the legendre polynomial expansions of either the +! unpolarized phase function or the polarized phase matrix; +! and some quantities needed in polarized radiative transfer. +! +! calls : biga, ckinmi, small1, small2, testmi, miprnt, +! lpcoef, errmsg +! +! i n t e r n a l v a r i a b l e s +! ----------------------------------- +! +! an,bn mie coefficients little-a-sub-n, little-b-sub-n +! ( ref. 1, eq. 16 ) +! anm1,bnm1 mie coefficients little-a-sub-(n-1), +! little-b-sub-(n-1); used in -gqsc- sum +! anp coeffs. in s+ expansion ( ref. 2, p. 1507 ) +! bnp coeffs. in s- expansion ( ref. 2, p. 1507 ) +! anpm coeffs. in s+ expansion ( ref. 2, p. 1507 ) +! when mu is replaced by - mu +! bnpm coeffs. in s- expansion ( ref. 2, p. 1507 ) +! when mu is replaced by - mu +! calcmo(k) true, calculate moments for k-th phase quantity +! (derived from -ipolzn-; used only in 'lpcoef') +! cbiga(n) bessel function ratio capital-a-sub-n (ref. 2, eq. 2) +! ( complex version ) +! cior complex index of refraction with negative +! imaginary part (van de hulst convention) +! cioriv 1 / cior +! coeff ( 2n + 1 ) / ( n ( n + 1 ) ) +! fn floating point version of index in loop performing +! mie series summation +! lita,litb(n) mie coefficients -an-, -bn-, saved in arrays for +! use in calculating legendre moments *pmom* +! maxtrm max. possible no. of terms in mie series +! mm + 1 and - 1, alternately. +! mim magnitude of imaginary refractive index +! mre real part of refractive index +! maxang max. possible value of input variable -numang- +! nangd2 (numang+1)/2 ( no. of angles in 0-90 deg; anyang=f ) +! noabs true, sphere non-absorbing (determined by -mimcut-) +! np1dn ( n + 1 ) / n +! npquan highest-numbered phase quantity for which moments are +! to be calculated (the largest digit in -ipolzn- +! if ipolzn .ne. 0) +! ntrm no. of terms in mie series +! pass1 true on first entry, false thereafter; for self-test +! pin(j) angular function little-pi-sub-n ( ref. 2, eq. 3 ) +! at j-th angle +! pinm1(j) little-pi-sub-(n-1) ( see -pin- ) at j-th angle +! psinm1 ricatti-bessel function psi-sub-(n-1), argument -xx- +! psin ricatti-bessel function psi-sub-n of argument -xx- +! ( ref. 1, p. 11 ff. ) +! rbiga(n) bessel function ratio capital-a-sub-n (ref. 2, eq. 2) +! ( real version, for when imag refrac index = 0 ) +! rioriv 1 / mre +! rn 1 / n +! rtmp (real) temporary variable +! sp(j) s+ for j-th angle ( ref. 2, p. 1507 ) +! sm(j) s- for j-th angle ( ref. 2, p. 1507 ) +! sps(j) s+ for (numang+1-j)-th angle ( anyang=false ) +! sms(j) s- for (numang+1-j)-th angle ( anyang=false ) +! taun angular function little-tau-sub-n ( ref. 2, eq. 4 ) +! at j-th angle +! tcoef n ( n+1 ) ( 2n+1 ) (for summing tforw,tback series) +! twonp1 2n + 1 +! yesang true if scattering amplitudes are to be calculated +! zetnm1 ricatti-bessel function zeta-sub-(n-1) of argument +! -xx- ( ref. 2, eq. 17 ) +! zetn ricatti-bessel function zeta-sub-n of argument -xx- +! +! ---------------------------------------------------------------------- +! -------- i / o specifications for subroutine miev0 ----------------- +! ---------------------------------------------------------------------- + implicit none + logical anyang, perfct, prnt(*) + integer ipolzn, momdim, numang, nmom + real*8 gqsc, mimcut, pmom( 0:momdim, * ), qext, qsca, & + xmu(*), xx + complex*16 crefin, sforw, sback, s1(*), s2(*), tforw(*), & + tback(*) + integer maxang,mxang2,maxtrm + real*8 onethr +! ---------------------------------------------------------------------- +! + parameter ( maxang = 501, mxang2 = maxang/2 + 1 ) +! +! ** note -- maxtrm = 10100 is neces- +! ** sary to do some of the test probs, +! ** but 1100 is sufficient for most +! ** conceivable applications + parameter ( maxtrm = 1100 ) + parameter ( onethr = 1./3. ) +! + logical anysav, calcmo(4), noabs, ok, pass1, persav, yesang + integer npquan + integer i,j,n,nmosav,iposav,numsav,ntrm,nangd2 + real*8 mim, mimsav, mre, mm, np1dn + real*8 rioriv,xmusav,xxsav,sq,fn,rn,twonp1,tcoef, coeff + real*8 xinv,psinm1,chinm1,psin,chin,rtmp,taun + real*8 rbiga( maxtrm ), pin( maxang ), pinm1( maxang ) + complex*16 an, bn, anm1, bnm1, anp, bnp, anpm, bnpm, cresav, & + cior, cioriv, ctmp, zet, zetnm1, zetn + complex*16 cbiga( maxtrm ), lita( maxtrm ), litb( maxtrm ), & + sp( maxang ), sm( maxang ), sps( mxang2 ), sms( mxang2 ) + equivalence ( cbiga, rbiga ) + save pass1 + sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 + data pass1 / .true. / +! +! + if ( pass1 ) then +! ** save certain user input values + xxsav = xx + cresav = crefin + mimsav = mimcut + persav = perfct + anysav = anyang + nmosav = nmom + iposav = ipolzn + numsav = numang + xmusav = xmu( 1 ) +! ** reset input values for test case + xx = 10.0 + crefin = ( 1.5, - 0.1 ) + perfct = .false. + mimcut = 0.0 + anyang = .true. + numang = 1 + xmu( 1 )= - 0.7660444 + nmom = 1 + ipolzn = - 1 +! + end if +! ** check input and calculate +! ** certain variables from input +! + 10 call ckinmi( numang, maxang, xx, perfct, crefin, momdim, & + nmom, ipolzn, anyang, xmu, calcmo, npquan ) +! + if ( perfct .and. xx .le. 0.1 ) then +! ** use totally-reflecting +! ** small-particle limit +! + call small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw, & + sback, s1, s2, tforw, tback, lita, litb ) + ntrm = 2 + go to 200 + end if +! + if ( .not.perfct ) then +! + cior = crefin + if ( dimag( cior ) .gt. 0.0 ) cior = dconjg( cior ) + mre = dble( cior ) + mim = - dimag( cior ) + noabs = mim .le. mimcut + cioriv = 1.0 / cior + rioriv = 1.0 / mre +! + if ( xx * dmax1( 1.d0, cdabs(cior) ) .le. 0.d1 ) then +! +! ** use general-refractive-index +! ** small-particle limit +! ** ( ref. 2, p. 1508 ) +! + call small2 ( xx, cior, .not.noabs, numang, xmu, qext, & + qsca, gqsc, sforw, sback, s1, s2, tforw, & + tback, lita, litb ) + ntrm = 2 + go to 200 + end if +! + end if +! + nangd2 = ( numang + 1 ) / 2 + yesang = numang .gt. 0 +! ** estimate number of terms in mie series +! ** ( ref. 2, p. 1508 ) + if ( xx.le.8.0 ) then + ntrm = xx + 4. * xx**onethr + 1. + else if ( xx.lt.4200. ) then + ntrm = xx + 4.05 * xx**onethr + 2. + else + ntrm = xx + 4. * xx**onethr + 2. + end if + if ( ntrm+1 .gt. maxtrm ) & + call errmsg( 'miev0--parameter maxtrm too small', .true. ) +! +! ** calculate logarithmic derivatives of +! ** j-bessel-fcn., big-a-sub-(1 to ntrm) + if ( .not.perfct ) & + call biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga ) +! +! ** initialize ricatti-bessel functions +! ** (psi,chi,zeta)-sub-(0,1) for upward +! ** recurrence ( ref. 1, eq. 19 ) + xinv = 1.0 / xx + psinm1 = dsin( xx ) + chinm1 = dcos( xx ) + psin = psinm1 * xinv - chinm1 + chin = chinm1 * xinv + psinm1 + zetnm1 = dcmplx( psinm1, chinm1 ) + zetn = dcmplx( psin, chin ) +! ** initialize previous coeffi- +! ** cients for -gqsc- series + anm1 = ( 0.0, 0.0 ) + bnm1 = ( 0.0, 0.0 ) +! ** initialize angular function little-pi +! ** and sums for s+, s- ( ref. 2, p. 1507 ) + if ( anyang ) then + do 60 j = 1, numang + pinm1( j ) = 0.0 + pin( j ) = 1.0 + sp ( j ) = ( 0.0, 0.0 ) + sm ( j ) = ( 0.0, 0.0 ) + 60 continue + else + do 70 j = 1, nangd2 + pinm1( j ) = 0.0 + pin( j ) = 1.0 + sp ( j ) = ( 0.0, 0.0 ) + sm ( j ) = ( 0.0, 0.0 ) + sps( j ) = ( 0.0, 0.0 ) + sms( j ) = ( 0.0, 0.0 ) + 70 continue + end if +! ** initialize mie sums for efficiencies, etc. + qsca = 0.0 + gqsc = 0.0 + sforw = ( 0., 0. ) + sback = ( 0., 0. ) + tforw( 1 ) = ( 0., 0. ) + tback( 1 ) = ( 0., 0. ) +! +! +! --------- loop to sum mie series ----------------------------------- +! + mm = + 1.0 + do 100 n = 1, ntrm +! ** compute various numerical coefficients + fn = n + rn = 1.0 / fn + np1dn = 1.0 + rn + twonp1 = 2 * n + 1 + coeff = twonp1 / ( fn * ( n + 1 ) ) + tcoef = twonp1 * ( fn * ( n + 1 ) ) +! +! ** calculate mie series coefficients + if ( perfct ) then +! ** totally-reflecting case +! + an = ( ( fn*xinv ) * psin - psinm1 ) / & + ( ( fn*xinv ) * zetn - zetnm1 ) + bn = psin / zetn +! + else if ( noabs ) then +! ** no-absorption case +! + an = ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & + / ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) + bn = ( ( mre * rbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & + / ( ( mre * rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) + else +! ** absorptive case +! + an = ( ( cioriv * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & + /( ( cioriv * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) + bn = ( ( cior * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 ) & + /( ( cior * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 ) + qsca = qsca + twonp1 * ( sq( an ) + sq( bn ) ) +! + end if +! ** save mie coefficients for *pmom* calculation + lita( n ) = an + litb( n ) = bn +! ** increment mie sums for non-angle- +! ** dependent quantities +! + sforw = sforw + twonp1 * ( an + bn ) + tforw( 1 ) = tforw( 1 ) + tcoef * ( an - bn ) + sback = sback + ( mm * twonp1 ) * ( an - bn ) + tback( 1 ) = tback( 1 ) + ( mm * tcoef ) * ( an + bn ) + gqsc = gqsc + ( fn - rn ) * dble( anm1 * dconjg( an ) & + + bnm1 * dconjg( bn ) ) & + + coeff * dble( an * dconjg( bn ) ) +! + if ( yesang ) then +! ** put mie coefficients in form +! ** needed for computing s+, s- +! ** ( ref. 2, p. 1507 ) + anp = coeff * ( an + bn ) + bnp = coeff * ( an - bn ) +! ** increment mie sums for s+, s- +! ** while upward recursing +! ** angular functions little pi +! ** and little tau + if ( anyang ) then +! ** arbitrary angles +! +! ** vectorizable loop + do 80 j = 1, numang + rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j ) + taun = fn * rtmp - pinm1( j ) + sp( j ) = sp( j ) + anp * ( pin( j ) + taun ) + sm( j ) = sm( j ) + bnp * ( pin( j ) - taun ) + pinm1( j ) = pin( j ) + pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp + 80 continue +! + else +! ** angles symmetric about 90 degrees + anpm = mm * anp + bnpm = mm * bnp +! ** vectorizable loop + do 90 j = 1, nangd2 + rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j ) + taun = fn * rtmp - pinm1( j ) + sp ( j ) = sp ( j ) + anp * ( pin( j ) + taun ) + sms( j ) = sms( j ) + bnpm * ( pin( j ) + taun ) + sm ( j ) = sm ( j ) + bnp * ( pin( j ) - taun ) + sps( j ) = sps( j ) + anpm * ( pin( j ) - taun ) + pinm1( j ) = pin( j ) + pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp + 90 continue +! + end if + end if +! ** update relevant quantities for next +! ** pass through loop + mm = - mm + anm1 = an + bnm1 = bn +! ** upward recurrence for ricatti-bessel +! ** functions ( ref. 1, eq. 17 ) +! + zet = ( twonp1 * xinv ) * zetn - zetnm1 + zetnm1 = zetn + zetn = zet + psinm1 = psin + psin = dble( zetn ) + 100 continue +! +! ---------- end loop to sum mie series -------------------------------- +! +! + qext = 2. / xx**2 * dble( sforw ) + if ( perfct .or. noabs ) then + qsca = qext + else + qsca = 2. / xx**2 * qsca + end if +! + gqsc = 4. / xx**2 * gqsc + sforw = 0.5 * sforw + sback = 0.5 * sback + tforw( 2 ) = 0.5 * ( sforw + 0.25 * tforw( 1 ) ) + tforw( 1 ) = 0.5 * ( sforw - 0.25 * tforw( 1 ) ) + tback( 2 ) = 0.5 * ( sback + 0.25 * tback( 1 ) ) + tback( 1 ) = 0.5 * ( - sback + 0.25 * tback( 1 ) ) +! + if ( yesang ) then +! ** recover scattering amplitudes +! ** from s+, s- ( ref. 1, eq. 11 ) + if ( anyang ) then +! ** vectorizable loop + do 110 j = 1, numang + s1( j ) = 0.5 * ( sp( j ) + sm( j ) ) + s2( j ) = 0.5 * ( sp( j ) - sm( j ) ) + 110 continue +! + else +! ** vectorizable loop + do 120 j = 1, nangd2 + s1( j ) = 0.5 * ( sp( j ) + sm( j ) ) + s2( j ) = 0.5 * ( sp( j ) - sm( j ) ) + 120 continue +! ** vectorizable loop + do 130 j = 1, nangd2 + s1( numang+1 - j ) = 0.5 * ( sps( j ) + sms( j ) ) + s2( numang+1 - j ) = 0.5 * ( sps( j ) - sms( j ) ) + 130 continue + end if +! + end if +! ** calculate legendre moments + 200 if ( nmom.gt.0 ) & + call lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan, & + lita, litb, pmom ) +! + if ( dimag(crefin) .gt. 0.0 ) then +! ** take complex conjugates +! ** of scattering amplitudes + sforw = dconjg( sforw ) + sback = dconjg( sback ) + do 210 i = 1, 2 + tforw( i ) = dconjg( tforw(i) ) + tback( i ) = dconjg( tback(i) ) + 210 continue +! + do 220 j = 1, numang + s1( j ) = dconjg( s1(j) ) + s2( j ) = dconjg( s2(j) ) + 220 continue +! + end if +! + if ( pass1 ) then +! ** compare test case results with +! ** correct answers and abort if bad +! + call testmi ( qext, qsca, gqsc, sforw, sback, s1, s2, & + tforw, tback, pmom, momdim, ok ) + if ( .not. ok ) then + prnt(1) = .false. + prnt(2) = .false. + call miprnt( prnt, xx, perfct, crefin, numang, xmu, qext, & + qsca, gqsc, nmom, ipolzn, momdim, calcmo, & + pmom, sforw, sback, tforw, tback, s1, s2 ) + call errmsg( 'miev0 -- self-test failed', .true. ) + end if +! ** restore user input values + xx = xxsav + crefin = cresav + mimcut = mimsav + perfct = persav + anyang = anysav + nmom = nmosav + ipolzn = iposav + numang = numsav + xmu(1) = xmusav + pass1 = .false. + go to 10 +! + end if +! + if ( prnt(1) .or. prnt(2) ) & + call miprnt( prnt, xx, perfct, crefin, numang, xmu, qext, & + qsca, gqsc, nmom, ipolzn, momdim, calcmo, & + pmom, sforw, sback, tforw, tback, s1, s2 ) +! + return +! + end subroutine miev0 +!**************************************************************************** + subroutine ckinmi( numang, maxang, xx, perfct, crefin, momdim, & + nmom, ipolzn, anyang, xmu, calcmo, npquan ) +! +! check for bad input to 'miev0' and calculate -calcmo,npquan- +! + implicit none + logical perfct, anyang, calcmo(*) + integer numang, maxang, momdim, nmom, ipolzn, npquan + real*8 xx, xmu(*) + integer i,l,j,ip + complex*16 crefin +! + character*4 string + logical inperr +! + inperr = .false. +! + if ( numang.gt.maxang ) then + call errmsg( 'miev0--parameter maxang too small', .true. ) + inperr = .true. + end if + if ( numang.lt.0 ) call wrtbad( 'numang', inperr ) + if ( xx.lt.0. ) call wrtbad( 'xx', inperr ) + if ( .not.perfct .and. dble(crefin).le.0. ) & + call wrtbad( 'crefin', inperr ) + if ( momdim.lt.1 ) call wrtbad( 'momdim', inperr ) +! + if ( nmom.ne.0 ) then + if ( nmom.lt.0 .or. nmom.gt.momdim ) call wrtbad('nmom',inperr) + if ( iabs(ipolzn).gt.4444 ) call wrtbad( 'ipolzn', inperr ) + npquan = 0 + do 5 l = 1, 4 + calcmo( l ) = .false. + 5 continue + if ( ipolzn.ne.0 ) then +! ** parse out -ipolzn- into its digits +! ** to find which phase quantities are +! ** to have their moments calculated +! + write( string, '(i4)' ) iabs(ipolzn) + do 10 j = 1, 4 + ip = ichar( string(j:j) ) - ichar( '0' ) + if ( ip.ge.1 .and. ip.le.4 ) calcmo( ip ) = .true. + if ( ip.eq.0 .or. (ip.ge.5 .and. ip.le.9) ) & + call wrtbad( 'ipolzn', inperr ) + npquan = max0( npquan, ip ) + 10 continue + end if + end if +! + if ( anyang ) then +! ** allow for slight imperfections in +! ** computation of cosine + do 20 i = 1, numang + if ( xmu(i).lt.-1.00001 .or. xmu(i).gt.1.00001 ) & + call wrtbad( 'xmu', inperr ) + 20 continue + else + do 22 i = 1, ( numang + 1 ) / 2 + if ( xmu(i).lt.-0.00001 .or. xmu(i).gt.1.00001 ) & + call wrtbad( 'xmu', inperr ) + 22 continue + end if +! + if ( inperr ) & + call errmsg( 'miev0--input error(s). aborting...', .true. ) +! + if ( xx.gt.20000.0 .or. dble(crefin).gt.10.0 .or. & + dabs( dimag(crefin) ).gt.10.0 ) call errmsg( & + 'miev0--xx or crefin outside tested range', .false. ) +! + return + end subroutine ckinmi +!*********************************************************************** + subroutine lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan, & + a, b, pmom ) +! +! calculate legendre polynomial expansion coefficients (also +! called moments) for phase quantities ( ref. 5 formulation ) +! +! input: ntrm number terms in mie series +! nmom, ipolzn, momdim 'miev0' arguments +! calcmo flags calculated from -ipolzn- +! npquan defined in 'miev0' +! a, b mie series coefficients +! +! output: pmom legendre moments ('miev0' argument) +! +! *** notes *** +! +! (1) eqs. 2-5 are in error in dave, appl. opt. 9, +! 1888 (1970). eq. 2 refers to m1, not m2; eq. 3 refers to +! m2, not m1. in eqs. 4 and 5, the subscripts on the second +! term in square brackets should be interchanged. +! +! (2) the general-case logic in this subroutine works correctly +! in the two-term mie series case, but subroutine 'lpco2t' +! is called instead, for speed. +! +! (3) subroutine 'lpco1t', to do the one-term case, is never +! called within the context of 'miev0', but is included for +! complete generality. +! +! (4) some improvement in speed is obtainable by combining the +! 310- and 410-loops, if moments for both the third and fourth +! phase quantities are desired, because the third phase quantity +! is the real part of a complex series, while the fourth phase +! quantity is the imaginary part of that very same series. but +! most users are not interested in the fourth phase quantity, +! which is related to circular polarization, so the present +! scheme is usually more efficient. +! + implicit none + logical calcmo(*) + integer ipolzn, momdim, nmom, ntrm, npquan + real*8 pmom( 0:momdim, * ) + complex*16 a(*), b(*) +! +! ** specification of local variables +! +! am(m) numerical coefficients a-sub-m-super-l +! in dave, eqs. 1-15, as simplified in ref. 5. +! +! bi(i) numerical coefficients b-sub-i-super-l +! in dave, eqs. 1-15, as simplified in ref. 5. +! +! bidel(i) 1/2 bi(i) times factor capital-del in dave +! +! cm,dm() arrays c and d in dave, eqs. 16-17 (mueller form), +! calculated using recurrence derived in ref. 5 +! +! cs,ds() arrays c and d in ref. 4, eqs. a5-a6 (sekera form), +! calculated using recurrence derived in ref. 5 +! +! c,d() either -cm,dm- or -cs,ds-, depending on -ipolzn- +! +! evenl true for even-numbered moments; false otherwise +! +! idel 1 + little-del in dave +! +! maxtrm max. no. of terms in mie series +! +! maxmom max. no. of non-zero moments +! +! nummom number of non-zero moments +! +! recip(k) 1 / k +! + integer maxtrm,maxmom,mxmom2,maxrcp + parameter ( maxtrm = 1102, maxmom = 2*maxtrm, mxmom2 = maxmom/2, & + maxrcp = 4*maxtrm + 2 ) + real*8 am( 0:maxtrm ), bi( 0:mxmom2 ), bidel( 0:mxmom2 ), & + recip( maxrcp ) + complex*16 cm( maxtrm ), dm( maxtrm ), cs( maxtrm ), ds( maxtrm ), & + c( maxtrm ), d( maxtrm ) + integer k,j,l,nummom,ld2,idel,m,i,mmax,imax + real*8 thesum + equivalence ( c, cm ), ( d, dm ) + logical pass1, evenl + save pass1, recip + data pass1 / .true. / +! +! + if ( pass1 ) then +! + do 1 k = 1, maxrcp + recip( k ) = 1.0 / k + 1 continue + pass1 = .false. +! + end if +! + do 5 j = 1, max0( 1, npquan ) + do 5 l = 0, nmom + pmom( l, j ) = 0.0 + 5 continue +! + if ( ntrm.eq.1 ) then + call lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) + return + else if ( ntrm.eq.2 ) then + call lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) + return + end if +! + if ( ntrm+2 .gt. maxtrm ) & + call errmsg( 'lpcoef--parameter maxtrm too small', .true. ) +! +! ** calculate mueller c, d arrays + cm( ntrm+2 ) = ( 0., 0. ) + dm( ntrm+2 ) = ( 0., 0. ) + cm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * b( ntrm ) + dm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * a( ntrm ) + cm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * a( ntrm ) & + + ( 1. - recip(ntrm) ) * b( ntrm-1 ) + dm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * b( ntrm ) & + + ( 1. - recip(ntrm) ) * a( ntrm-1 ) +! + do 10 k = ntrm-1, 2, -1 + cm( k ) = cm( k+2 ) - ( 1. + recip(k+1) ) * b( k+1 ) & + + ( recip(k) + recip(k+1) ) * a( k ) & + + ( 1. - recip(k) ) * b( k-1 ) + dm( k ) = dm( k+2 ) - ( 1. + recip(k+1) ) * a( k+1 ) & + + ( recip(k) + recip(k+1) ) * b( k ) & + + ( 1. - recip(k) ) * a( k-1 ) + 10 continue + cm( 1 ) = cm( 3 ) + 1.5 * ( a( 1 ) - b( 2 ) ) + dm( 1 ) = dm( 3 ) + 1.5 * ( b( 1 ) - a( 2 ) ) +! + if ( ipolzn.ge.0 ) then +! + do 20 k = 1, ntrm + 2 + c( k ) = ( 2*k - 1 ) * cm( k ) + d( k ) = ( 2*k - 1 ) * dm( k ) + 20 continue +! + else +! ** compute sekera c and d arrays + cs( ntrm+2 ) = ( 0., 0. ) + ds( ntrm+2 ) = ( 0., 0. ) + cs( ntrm+1 ) = ( 0., 0. ) + ds( ntrm+1 ) = ( 0., 0. ) +! + do 30 k = ntrm, 1, -1 + cs( k ) = cs( k+2 ) + ( 2*k + 1 ) * ( cm( k+1 ) - b( k ) ) + ds( k ) = ds( k+2 ) + ( 2*k + 1 ) * ( dm( k+1 ) - a( k ) ) + 30 continue +! + do 40 k = 1, ntrm + 2 + c( k ) = ( 2*k - 1 ) * cs( k ) + d( k ) = ( 2*k - 1 ) * ds( k ) + 40 continue +! + end if +! +! + if( ipolzn.lt.0 ) nummom = min0( nmom, 2*ntrm - 2 ) + if( ipolzn.ge.0 ) nummom = min0( nmom, 2*ntrm ) + if ( nummom .gt. maxmom ) & + call errmsg( 'lpcoef--parameter maxtrm too small', .true. ) +! +! ** loop over moments + do 500 l = 0, nummom + ld2 = l / 2 + evenl = mod( l,2 ) .eq. 0 +! ** calculate numerical coefficients +! ** a-sub-m and b-sub-i in dave +! ** double-sums for moments + if( l.eq.0 ) then +! + idel = 1 + do 60 m = 0, ntrm + am( m ) = 2.0 * recip( 2*m + 1 ) + 60 continue + bi( 0 ) = 1.0 +! + else if( evenl ) then +! + idel = 1 + do 70 m = ld2, ntrm + am( m ) = ( 1. + recip( 2*m-l+1 ) ) * am( m ) + 70 continue + do 75 i = 0, ld2-1 + bi( i ) = ( 1. - recip( l-2*i ) ) * bi( i ) + 75 continue + bi( ld2 ) = ( 2. - recip( l ) ) * bi( ld2-1 ) +! + else +! + idel = 2 + do 80 m = ld2, ntrm + am( m ) = ( 1. - recip( 2*m+l+2 ) ) * am( m ) + 80 continue + do 85 i = 0, ld2 + bi( i ) = ( 1. - recip( l+2*i+1 ) ) * bi( i ) + 85 continue +! + end if +! ** establish upper limits for sums +! ** and incorporate factor capital- +! ** del into b-sub-i + mmax = ntrm - idel + if( ipolzn.ge.0 ) mmax = mmax + 1 + imax = min0( ld2, mmax - ld2 ) + if( imax.lt.0 ) go to 600 + do 90 i = 0, imax + bidel( i ) = bi( i ) + 90 continue + if( evenl ) bidel( 0 ) = 0.5 * bidel( 0 ) +! +! ** perform double sums just for +! ** phase quantities desired by user + if( ipolzn.eq.0 ) then +! + do 110 i = 0, imax +! ** vectorizable loop (cray) + thesum = 0.0 + do 100 m = ld2, mmax - i + thesum = thesum + am( m ) * & + ( dble( c(m-i+1) * dconjg( c(m+i+idel) ) ) & + + dble( d(m-i+1) * dconjg( d(m+i+idel) ) ) ) + 100 continue + pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum + 110 continue + pmom( l,1 ) = 0.5 * pmom( l,1 ) + go to 500 +! + end if +! + if ( calcmo(1) ) then + do 160 i = 0, imax +! ** vectorizable loop (cray) + thesum = 0.0 + do 150 m = ld2, mmax - i + thesum = thesum + am( m ) * & + dble( c(m-i+1) * dconjg( c(m+i+idel) ) ) + 150 continue + pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum + 160 continue + end if +! +! + if ( calcmo(2) ) then + do 210 i = 0, imax +! ** vectorizable loop (cray) + thesum = 0.0 + do 200 m = ld2, mmax - i + thesum = thesum + am( m ) * & + dble( d(m-i+1) * dconjg( d(m+i+idel) ) ) + 200 continue + pmom( l,2 ) = pmom( l,2 ) + bidel( i ) * thesum + 210 continue + end if +! +! + if ( calcmo(3) ) then + do 310 i = 0, imax +! ** vectorizable loop (cray) + thesum = 0.0 + do 300 m = ld2, mmax - i + thesum = thesum + am( m ) * & + ( dble( c(m-i+1) * dconjg( d(m+i+idel) ) ) & + + dble( c(m+i+idel) * dconjg( d(m-i+1) ) ) ) + 300 continue + pmom( l,3 ) = pmom( l,3 ) + bidel( i ) * thesum + 310 continue + pmom( l,3 ) = 0.5 * pmom( l,3 ) + end if +! +! + if ( calcmo(4) ) then + do 410 i = 0, imax +! ** vectorizable loop (cray) + thesum = 0.0 + do 400 m = ld2, mmax - i + thesum = thesum + am( m ) * & + ( dimag( c(m-i+1) * dconjg( d(m+i+idel) ) ) & + + dimag( c(m+i+idel) * dconjg( d(m-i+1) ) )) + 400 continue + pmom( l,4 ) = pmom( l,4 ) + bidel( i ) * thesum + 410 continue + pmom( l,4 ) = - 0.5 * pmom( l,4 ) + end if +! + 500 continue +! +! + 600 return + end subroutine lpcoef +!********************************************************************* + subroutine lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) +! +! calculate legendre polynomial expansion coefficients (also +! called moments) for phase quantities in special case where +! no. terms in mie series = 1 +! +! input: nmom, ipolzn, momdim 'miev0' arguments +! calcmo flags calculated from -ipolzn- +! a(1), b(1) mie series coefficients +! +! output: pmom legendre moments +! + implicit none + logical calcmo(*) + integer ipolzn, momdim, nmom,nummom,l + real*8 pmom( 0:momdim, * ),sq,a1sq,b1sq + complex*16 a(*), b(*), ctmp, a1b1c + sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 +! +! + a1sq = sq( a(1) ) + b1sq = sq( b(1) ) + a1b1c = a(1) * dconjg( b(1) ) +! + if( ipolzn.lt.0 ) then +! + if( calcmo(1) ) pmom( 0,1 ) = 2.25 * b1sq + if( calcmo(2) ) pmom( 0,2 ) = 2.25 * a1sq + if( calcmo(3) ) pmom( 0,3 ) = 2.25 * dble( a1b1c ) + if( calcmo(4) ) pmom( 0,4 ) = 2.25 *dimag( a1b1c ) +! + else +! + nummom = min0( nmom, 2 ) +! ** loop over moments + do 100 l = 0, nummom +! + if( ipolzn.eq.0 ) then + if( l.eq.0 ) pmom( l,1 ) = 1.5 * ( a1sq + b1sq ) + if( l.eq.1 ) pmom( l,1 ) = 1.5 * dble( a1b1c ) + if( l.eq.2 ) pmom( l,1 ) = 0.15 * ( a1sq + b1sq ) + go to 100 + end if +! + if( calcmo(1) ) then + if( l.eq.0 ) pmom( l,1 ) = 2.25 * ( a1sq + b1sq / 3. ) + if( l.eq.1 ) pmom( l,1 ) = 1.5 * dble( a1b1c ) + if( l.eq.2 ) pmom( l,1 ) = 0.3 * b1sq + end if +! + if( calcmo(2) ) then + if( l.eq.0 ) pmom( l,2 ) = 2.25 * ( b1sq + a1sq / 3. ) + if( l.eq.1 ) pmom( l,2 ) = 1.5 * dble( a1b1c ) + if( l.eq.2 ) pmom( l,2 ) = 0.3 * a1sq + end if +! + if( calcmo(3) ) then + if( l.eq.0 ) pmom( l,3 ) = 3.0 * dble( a1b1c ) + if( l.eq.1 ) pmom( l,3 ) = 0.75 * ( a1sq + b1sq ) + if( l.eq.2 ) pmom( l,3 ) = 0.3 * dble( a1b1c ) + end if +! + if( calcmo(4) ) then + if( l.eq.0 ) pmom( l,4 ) = - 1.5 * dimag( a1b1c ) + if( l.eq.1 ) pmom( l,4 ) = 0.0 + if( l.eq.2 ) pmom( l,4 ) = 0.3 * dimag( a1b1c ) + end if +! + 100 continue +! + end if +! + return + end subroutine lpco1t +!******************************************************************** + subroutine lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom ) +! +! calculate legendre polynomial expansion coefficients (also +! called moments) for phase quantities in special case where +! no. terms in mie series = 2 +! +! input: nmom, ipolzn, momdim 'miev0' arguments +! calcmo flags calculated from -ipolzn- +! a(1-2), b(1-2) mie series coefficients +! +! output: pmom legendre moments +! + implicit none + logical calcmo(*) + integer ipolzn, momdim, nmom,l,nummom + real*8 pmom( 0:momdim, * ),sq,pm1,pm2,a2sq,b2sq + complex*16 a(*), b(*) + complex*16 a2c, b2c, ctmp, ca, cac, cat, cb, cbc, cbt, cg, ch + sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 +! +! + ca = 3. * a(1) - 5. * b(2) + cat= 3. * b(1) - 5. * a(2) + cac = dconjg( ca ) + a2sq = sq( a(2) ) + b2sq = sq( b(2) ) + a2c = dconjg( a(2) ) + b2c = dconjg( b(2) ) +! + if( ipolzn.lt.0 ) then +! ** loop over sekera moments + nummom = min0( nmom, 2 ) + do 50 l = 0, nummom +! + if( calcmo(1) ) then + if( l.eq.0 ) pmom( l,1 ) = 0.25 * ( sq(cat) + & + (100./3.) * b2sq ) + if( l.eq.1 ) pmom( l,1 ) = (5./3.) * dble( cat * b2c ) + if( l.eq.2 ) pmom( l,1 ) = (10./3.) * b2sq + end if +! + if( calcmo(2) ) then + if( l.eq.0 ) pmom( l,2 ) = 0.25 * ( sq(ca) + & + (100./3.) * a2sq ) + if( l.eq.1 ) pmom( l,2 ) = (5./3.) * dble( ca * a2c ) + if( l.eq.2 ) pmom( l,2 ) = (10./3.) * a2sq + end if +! + if( calcmo(3) ) then + if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cat*cac + & + (100./3.)*b(2)*a2c ) + if( l.eq.1 ) pmom( l,3 ) = 5./6. * dble( b(2)*cac + & + cat*a2c ) + if( l.eq.2 ) pmom( l,3 ) = 10./3. * dble( b(2) * a2c ) + end if +! + if( calcmo(4) ) then + if( l.eq.0 ) pmom( l,4 ) = -0.25 * dimag( cat*cac + & + (100./3.)*b(2)*a2c ) + if( l.eq.1 ) pmom( l,4 ) = -5./6. * dimag( b(2)*cac + & + cat*a2c ) + if( l.eq.2 ) pmom( l,4 ) = -10./3. * dimag( b(2) * a2c ) + end if +! + 50 continue +! + else +! + cb = 3. * b(1) + 5. * a(2) + cbt= 3. * a(1) + 5. * b(2) + cbc = dconjg( cb ) + cg = ( cbc*cbt + 10.*( cac*a(2) + b2c*cat) ) / 3. + ch = 2.*( cbc*a(2) + b2c*cbt ) +! +! ** loop over mueller moments + nummom = min0( nmom, 4 ) + do 100 l = 0, nummom +! + if( ipolzn.eq.0 .or. calcmo(1) ) then + if( l.eq.0 ) pm1 = 0.25 * sq(ca) + sq(cb) / 12. & + + (5./3.) * dble(ca*b2c) + 5.*b2sq + if( l.eq.1 ) pm1 = dble( cb * ( cac/6. + b2c ) ) + if( l.eq.2 ) pm1 = sq(cb)/30. + (20./7.) * b2sq & + + (2./3.) * dble( ca * b2c ) + if( l.eq.3 ) pm1 = (2./7.) * dble( cb * b2c ) + if( l.eq.4 ) pm1 = (40./63.) * b2sq + if ( calcmo(1) ) pmom( l,1 ) = pm1 + end if +! + if( ipolzn.eq.0 .or. calcmo(2) ) then + if( l.eq.0 ) pm2 = 0.25*sq(cat) + sq(cbt) / 12. & + + (5./3.) * dble(cat*a2c) + 5.*a2sq + if( l.eq.1 ) pm2 = dble( cbt * ( dconjg(cat)/6. + a2c) ) + if( l.eq.2 ) pm2 = sq(cbt)/30. + (20./7.) * a2sq & + + (2./3.) * dble( cat * a2c ) + if( l.eq.3 ) pm2 = (2./7.) * dble( cbt * a2c ) + if( l.eq.4 ) pm2 = (40./63.) * a2sq + if ( calcmo(2) ) pmom( l,2 ) = pm2 + end if +! + if( ipolzn.eq.0 ) then + pmom( l,1 ) = 0.5 * ( pm1 + pm2 ) + go to 100 + end if +! + if( calcmo(3) ) then + if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cac*cat + cg + & + 20.*b2c*a(2) ) + if( l.eq.1 ) pmom( l,3 ) = dble( cac*cbt + cbc*cat + & + 3.*ch ) / 12. + if( l.eq.2 ) pmom( l,3 ) = 0.1 * dble( cg + (200./7.) * & + b2c * a(2) ) + if( l.eq.3 ) pmom( l,3 ) = dble( ch ) / 14. + if( l.eq.4 ) pmom( l,3 ) = 40./63. * dble( b2c * a(2) ) + end if +! + if( calcmo(4) ) then + if( l.eq.0 ) pmom( l,4 ) = 0.25 * dimag( cac*cat + cg + & + 20.*b2c*a(2) ) + if( l.eq.1 ) pmom( l,4 ) = dimag( cac*cbt + cbc*cat + & + 3.*ch ) / 12. + if( l.eq.2 ) pmom( l,4 ) = 0.1 * dimag( cg + (200./7.) * & + b2c * a(2) ) + if( l.eq.3 ) pmom( l,4 ) = dimag( ch ) / 14. + if( l.eq.4 ) pmom( l,4 ) = 40./63. * dimag( b2c * a(2) ) + end if +! + 100 continue +! + end if +! + return + end subroutine lpco2t +!********************************************************************* + subroutine biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga ) +! +! calculate logarithmic derivatives of j-bessel-function +! +! input : cior, xx, ntrm, noabs, yesang (defined in 'miev0') +! +! output : rbiga or cbiga (defined in 'miev0') +! +! internal variables : +! +! confra value of lentz continued fraction for -cbiga(ntrm)-, +! used to initialize downward recurrence. +! down = true, use down-recurrence. false, do not. +! f1,f2,f3 arithmetic statement functions used in determining +! whether to use up- or down-recurrence +! ( ref. 2, eqs. 6-8 ) +! mre real refractive index +! mim imaginary refractive index +! rezinv 1 / ( mre * xx ); temporary variable for recurrence +! zinv 1 / ( cior * xx ); temporary variable for recurrence +! + implicit none + logical down, noabs, yesang + integer ntrm,n + real*8 mre, mim, rbiga(*), xx, rezinv, rtmp, f1,f2,f3 +! complex*16 cior, ctmp, confra, cbiga(*), zinv + complex*16 cior, ctmp, cbiga(*), zinv + f1( mre ) = - 8.0 + mre**2 * ( 26.22 + mre * ( - 0.4474 & + + mre**3 * ( 0.00204 - 0.000175 * mre ) ) ) + f2( mre ) = 3.9 + mre * ( - 10.8 + 13.78 * mre ) + f3( mre ) = - 15.04 + mre * ( 8.42 + 16.35 * mre ) +! +! ** decide whether 'biga' can be +! ** calculated by up-recurrence + mre = dble( cior ) + mim = dabs( dimag( cior ) ) + if ( mre.lt.1.0 .or. mre.gt.10.0 .or. mim.gt.10.0 ) then + down = .true. + else if ( yesang ) then + down = .true. + if ( mim*xx .lt. f2( mre ) ) down = .false. + else + down = .true. + if ( mim*xx .lt. f1( mre ) ) down = .false. + end if +! + zinv = 1.0 / ( cior * xx ) + rezinv = 1.0 / ( mre * xx ) +! + if ( down ) then +! ** compute initial high-order 'biga' using +! ** lentz method ( ref. 1, pp. 17-20 ) +! + ctmp = confra( ntrm, zinv, xx ) +! +! *** downward recurrence for 'biga' +! *** ( ref. 1, eq. 22 ) + if ( noabs ) then +! ** no-absorption case + rbiga( ntrm ) = dble( ctmp ) + do 25 n = ntrm, 2, - 1 + rbiga( n-1 ) = (n*rezinv) & + - 1.0 / ( (n*rezinv) + rbiga( n ) ) + 25 continue +! + else +! ** absorptive case + cbiga( ntrm ) = ctmp + do 30 n = ntrm, 2, - 1 + cbiga( n-1 ) = (n*zinv) - 1.0 / ( (n*zinv) + cbiga( n ) ) + 30 continue +! + end if +! + else +! *** upward recurrence for 'biga' +! *** ( ref. 1, eqs. 20-21 ) + if ( noabs ) then +! ** no-absorption case + rtmp = dsin( mre*xx ) + rbiga( 1 ) = - rezinv & + + rtmp / ( rtmp*rezinv - dcos( mre*xx ) ) + do 40 n = 2, ntrm + rbiga( n ) = - ( n*rezinv ) & + + 1.0 / ( ( n*rezinv ) - rbiga( n-1 ) ) + 40 continue +! + else +! ** absorptive case + ctmp = cdexp( - dcmplx(0.d0,2.d0) * cior * xx ) + cbiga( 1 ) = - zinv + (1.-ctmp) / ( zinv * (1.-ctmp) - & + dcmplx(0.d0,1.d0)*(1.+ctmp) ) + do 50 n = 2, ntrm + cbiga( n ) = - (n*zinv) + 1.0 / ((n*zinv) - cbiga( n-1 )) + 50 continue + end if +! + end if +! + return + end subroutine biga +!********************************************************************** + complex*16 function confra( n, zinv, xx ) +! +! compute bessel function ratio capital-a-sub-n from its +! continued fraction using lentz method ( ref. 1, pp. 17-20 ) +! +! zinv = reciprocal of argument of capital-a +! +! i n t e r n a l v a r i a b l e s +! ------------------------------------ +! +! cak term in continued fraction expansion of capital-a +! ( ref. 1, eq. 25 ) +! capt factor used in lentz iteration for capital-a +! ( ref. 1, eq. 27 ) +! cdenom denominator in -capt- ( ref. 1, eq. 28b ) +! cnumer numerator in -capt- ( ref. 1, eq. 28a ) +! cdtd product of two successive denominators of -capt- +! factors ( ref. 1, eq. 34c ) +! cntn product of two successive numerators of -capt- +! factors ( ref. 1, eq. 34b ) +! eps1 ill-conditioning criterion +! eps2 convergence criterion +! kk subscript k of -cak- ( ref. 1, eq. 25b ) +! kount iteration counter ( used only to prevent runaway ) +! maxit max. allowed no. of iterations +! mm + 1 and - 1, alternately +! + implicit none + integer n,maxit,mm,kk,kount + real*8 xx,eps1,eps2 + complex*16 zinv + complex*16 cak, capt, cdenom, cdtd, cnumer, cntn +! data eps1 / 1.e - 2 /, eps2 / 1.e - 8 / + data eps1 / 1.d-2 /, eps2 / 1.d-8 / + data maxit / 10000 / +! +! *** ref. 1, eqs. 25a, 27 + confra = ( n + 1 ) * zinv + mm = - 1 + kk = 2 * n + 3 + cak = ( mm * kk ) * zinv + cdenom = cak + cnumer = cdenom + 1.0 / confra + kount = 1 +! + 20 kount = kount + 1 + if ( kount.gt.maxit ) & + call errmsg( 'confra--iteration failed to converge$', .true.) +! +! *** ref. 2, eq. 25b + mm = - mm + kk = kk + 2 + cak = ( mm * kk ) * zinv +! *** ref. 2, eq. 32 + if ( cdabs( cnumer/cak ).le.eps1 & + .or. cdabs( cdenom/cak ).le.eps1 ) then +! +! ** ill-conditioned case -- stride +! ** two terms instead of one +! +! *** ref. 2, eqs. 34 + cntn = cak * cnumer + 1.0 + cdtd = cak * cdenom + 1.0 + confra = ( cntn / cdtd ) * confra +! *** ref. 2, eq. 25b + mm = - mm + kk = kk + 2 + cak = ( mm * kk ) * zinv +! *** ref. 2, eqs. 35 + cnumer = cak + cnumer / cntn + cdenom = cak + cdenom / cdtd + kount = kount + 1 + go to 20 +! + else +! ** well-conditioned case +! +! *** ref. 2, eqs. 26, 27 + capt = cnumer / cdenom + confra = capt * confra +! ** check for convergence +! ** ( ref. 2, eq. 31 ) +! + if ( dabs( dble(capt) - 1.0 ).ge.eps2 & + .or. dabs( dimag(capt) ) .ge.eps2 ) then +! +! *** ref. 2, eqs. 30a-b + cnumer = cak + 1.0 / cnumer + cdenom = cak + 1.0 / cdenom + go to 20 + end if + end if +! + return +! + end function confra +!******************************************************************** + subroutine miprnt( prnt, xx, perfct, crefin, numang, xmu, & + qext, qsca, gqsc, nmom, ipolzn, momdim, & + calcmo, pmom, sforw, sback, tforw, tback, & + s1, s2 ) +! +! print scattering quantities of a single particle +! + implicit none + logical perfct, prnt(*), calcmo(*) + integer ipolzn, momdim, nmom, numang,i,m,j + real*8 gqsc, pmom( 0:momdim, * ), qext, qsca, xx, xmu(*) + real*8 fi1,fi2,fnorm + complex*16 crefin, sforw, sback, tforw(*), tback(*), s1(*), s2(*) + character*22 fmt +! +! + if ( perfct ) write ( *, '(''1'',10x,a,1p,e11.4)' ) & + 'perfectly conducting case, size parameter =', xx + if ( .not.perfct ) write ( *, '(''1'',10x,3(a,1p,e11.4))' ) & + 'refractive index: real ', dble(crefin), & + ' imag ', dimag(crefin), ', size parameter =', xx +! + if ( prnt(1) .and. numang.gt.0 ) then +! + write ( *, '(/,a)' ) & + ' cos(angle) ------- s1 --------- ------- s2 ---------'// & + ' --- s1*conjg(s2) --- i1=s1**2 i2=s2**2 (i1+i2)/2'// & + ' deg polzn' + do 10 i = 1, numang + fi1 = dble( s1(i) ) **2 + dimag( s1(i) )**2 + fi2 = dble( s2(i) ) **2 + dimag( s2(i) )**2 + write( *, '( i4, f10.6, 1p,10e11.3 )' ) & + i, xmu(i), s1(i), s2(i), s1(i)*dconjg(s2(i)), & + fi1, fi2, 0.5*(fi1+fi2), (fi2-fi1)/(fi2+fi1) + 10 continue +! + end if +! +! + if ( prnt(2) ) then +! + write ( *, '(/,a,9x,a,17x,a,17x,a,/,(0p,f7.2, 1p,6e12.3) )' ) & + ' angle', 's-sub-1', 't-sub-1', 't-sub-2', & + 0.0, sforw, tforw(1), tforw(2), & + 180., sback, tback(1), tback(2) + write ( *, '(/,4(a,1p,e11.4))' ) & + ' efficiency factors, extinction:', qext, & + ' scattering:', qsca, & + ' absorption:', qext-qsca, & + ' rad. pressure:', qext-gqsc +! + if ( nmom.gt.0 ) then +! + write( *, '(/,a)' ) ' normalized moments of :' + if ( ipolzn.eq.0 ) write ( *, '(''+'',27x,a)' ) 'phase fcn' + if ( ipolzn.gt.0 ) write ( *, '(''+'',33x,a)' ) & + 'm1 m2 s21 d21' + if ( ipolzn.lt.0 ) write ( *, '(''+'',33x,a)' ) & + 'r1 r2 r3 r4' +! + fnorm = 4. / ( xx**2 * qsca ) + do 20 m = 0, nmom + write ( *, '(a,i4)' ) ' moment no.', m + do 20 j = 1, 4 + if( calcmo(j) ) then + write( fmt, 98 ) 24 + (j-1)*13 + write ( *,fmt ) fnorm * pmom(m,j) + end if + 20 continue + end if +! + end if +! + return +! + 98 format( '( ''+'', t', i2, ', 1p,e13.4 )' ) + end subroutine miprnt +!************************************************************************** + subroutine small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw, & + sback, s1, s2, tforw, tback, a, b ) +! +! small-particle limit of mie quantities in totally reflecting +! limit ( mie series truncated after 2 terms ) +! +! a,b first two mie coefficients, with numerator and +! denominator expanded in powers of -xx- ( a factor +! of xx**3 is missing but is restored before return +! to calling program ) ( ref. 2, p. 1508 ) +! + implicit none + integer numang,j + real*8 gqsc, qext, qsca, xx, xmu(*) + real*8 twothr,fivthr,fivnin,sq,rtmp + complex*16 a( 2 ), b( 2 ), sforw, sback, s1(*), s2(*), & + tforw(*), tback(*) +! + parameter ( twothr = 2./3., fivthr = 5./3., fivnin = 5./9. ) + complex*16 ctmp + sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 +! +! + a( 1 ) = dcmplx ( 0.d0, twothr * ( 1. - 0.2 * xx**2 ) ) & + / dcmplx ( 1.d0 - 0.5 * xx**2, twothr * xx**3 ) +! + b( 1 ) = dcmplx ( 0.d0, - ( 1. - 0.1 * xx**2 ) / 3. ) & + / dcmplx ( 1.d0 + 0.5 * xx**2, - xx**3 / 3. ) +! + a( 2 ) = dcmplx ( 0.d0, xx**2 / 30. ) + b( 2 ) = dcmplx ( 0.d0, - xx**2 / 45. ) +! + qsca = 6. * xx**4 * ( sq( a(1) ) + sq( b(1) ) & + + fivthr * ( sq( a(2) ) + sq( b(2) ) ) ) + qext = qsca + gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) ) & + + ( b(1) + fivnin * a(2) ) * dconjg( b(2) ) ) +! + rtmp = 1.5 * xx**3 + sforw = rtmp * ( a(1) + b(1) + fivthr * ( a(2) + b(2) ) ) + sback = rtmp * ( a(1) - b(1) - fivthr * ( a(2) - b(2) ) ) + tforw( 1 ) = rtmp * ( b(1) + fivthr * ( 2.*b(2) - a(2) ) ) + tforw( 2 ) = rtmp * ( a(1) + fivthr * ( 2.*a(2) - b(2) ) ) + tback( 1 ) = rtmp * ( b(1) - fivthr * ( 2.*b(2) + a(2) ) ) + tback( 2 ) = rtmp * ( a(1) - fivthr * ( 2.*a(2) + b(2) ) ) +! + do 10 j = 1, numang + s1( j ) = rtmp * ( a(1) + b(1) * xmu(j) + fivthr * & + ( a(2) * xmu(j) + b(2) * ( 2.*xmu(j)**2 - 1. )) ) + s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr * & + ( b(2) * xmu(j) + a(2) * ( 2.*xmu(j)**2 - 1. )) ) + 10 continue +! ** recover actual mie coefficients + a( 1 ) = xx**3 * a( 1 ) + a( 2 ) = xx**3 * a( 2 ) + b( 1 ) = xx**3 * b( 1 ) + b( 2 ) = xx**3 * b( 2 ) +! + return + end subroutine small1 +!************************************************************************* + subroutine small2 ( xx, cior, calcqe, numang, xmu, qext, qsca, & + gqsc, sforw, sback, s1, s2, tforw, tback, & + a, b ) +! +! small-particle limit of mie quantities for general refractive +! index ( mie series truncated after 2 terms ) +! +! a,b first two mie coefficients, with numerator and +! denominator expanded in powers of -xx- ( a factor +! of xx**3 is missing but is restored before return +! to calling program ) ( ref. 2, p. 1508 ) +! +! ciorsq square of refractive index +! + implicit none + logical calcqe + integer numang,j + real*8 gqsc, qext, qsca, xx, xmu(*) + real*8 twothr,fivthr,sq,rtmp + complex*16 a( 2 ), b( 2 ), cior, sforw, sback, s1(*), s2(*), & + tforw(*), tback(*) +! + parameter ( twothr = 2./3., fivthr = 5./3. ) + complex*16 ctmp, ciorsq + sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2 +! +! + ciorsq = cior**2 + ctmp = dcmplx( 0.d0, twothr ) * ( ciorsq - 1.0 ) + a(1) = ctmp * ( 1.0 - 0.1 * xx**2 + (ciorsq/350. + 1./280.)*xx**4) & + / ( ciorsq + 2.0 + ( 1.0 - 0.7 * ciorsq ) * xx**2 & + - ( ciorsq**2/175. - 0.275 * ciorsq + 0.25 ) * xx**4 & + + xx**3 * ctmp * ( 1.0 - 0.1 * xx**2 ) ) +! + b(1) = (xx**2/30.) * ctmp * ( 1.0 + (ciorsq/35. - 1./14.) *xx**2 ) & + / ( 1.0 - ( ciorsq/15. - 1./6. ) * xx**2 ) +! + a(2) = ( 0.1 * xx**2 ) * ctmp * ( 1.0 - xx**2 / 14. ) & + / ( 2. * ciorsq + 3. - ( ciorsq/7. - 0.5 ) * xx**2 ) +! + qsca = 6. * xx**4 * ( sq(a(1)) + sq(b(1)) + fivthr * sq(a(2)) ) + gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) ) ) + qext = qsca + if ( calcqe ) qext = 6. * xx * dble( a(1) + b(1) + fivthr * a(2) ) +! + rtmp = 1.5 * xx**3 + sforw = rtmp * ( a(1) + b(1) + fivthr * a(2) ) + sback = rtmp * ( a(1) - b(1) - fivthr * a(2) ) + tforw( 1 ) = rtmp * ( b(1) - fivthr * a(2) ) + tforw( 2 ) = rtmp * ( a(1) + 2. * fivthr * a(2) ) + tback( 1 ) = tforw( 1 ) + tback( 2 ) = rtmp * ( a(1) - 2. * fivthr * a(2) ) +! + do 10 j = 1, numang + s1( j ) = rtmp * ( a(1) + ( b(1) + fivthr * a(2) ) * xmu(j) ) + s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr * a(2) & + * ( 2. * xmu(j)**2 - 1. ) ) + 10 continue +! ** recover actual mie coefficients + a( 1 ) = xx**3 * a( 1 ) + a( 2 ) = xx**3 * a( 2 ) + b( 1 ) = xx**3 * b( 1 ) + b( 2 ) = ( 0., 0. ) +! + return + end subroutine small2 +!*********************************************************************** + subroutine testmi ( qext, qsca, gqsc, sforw, sback, s1, s2, & + tforw, tback, pmom, momdim, ok ) +! +! compare mie code test case results with correct answers +! and return ok=false if even one result is inaccurate. +! +! the test case is : mie size parameter = 10 +! refractive index = 1.5 - 0.1 i +! scattering angle = 140 degrees +! 1 sekera moment +! +! results for this case may be found among the test cases +! at the end of reference (1). +! +! *** note *** when running on some computers, esp. in single +! precision, the 'accur' criterion below may have to be relaxed. +! however, if 'accur' must be set larger than 10**-3 for some +! size parameters, your computer is probably not accurate +! enough to do mie computations for those size parameters. +! + implicit none + integer momdim,m,n + real*8 qext, qsca, gqsc, pmom( 0:momdim, * ) + complex*16 sforw, sback, s1(*), s2(*), tforw(*), tback(*) + logical ok, wrong +! + real*8 accur, testqe, testqs, testgq, testpm( 0:1 ) + complex*16 testsf, testsb,tests1,tests2,testtf(2), testtb(2) + data testqe / 2.459791 /, testqs / 1.235144 /, & + testgq / 1.139235 /, testsf / ( 61.49476, -3.177994 ) /, & + testsb / ( 1.493434, 0.2963657 ) /, & + tests1 / ( -0.1548380, -1.128972) /, & + tests2 / ( 0.05669755, 0.5425681) /, & + testtf / ( 12.95238, -136.6436 ), ( 48.54238, 133.4656 ) /, & + testtb / ( 41.88414, -15.57833 ), ( 43.37758, -15.28196 )/, & + testpm / 227.1975, 183.6898 / + real*8 calc,exact +! data accur / 1.e-5 / + data accur / 1.e-4 / + wrong( calc, exact ) = dabs( (calc - exact) / exact ) .gt. accur +! +! + ok = .true. + if ( wrong( qext,testqe ) ) & + call tstbad( 'qext', abs((qext - testqe) / testqe), ok ) + if ( wrong( qsca,testqs ) ) & + call tstbad( 'qsca', abs((qsca - testqs) / testqs), ok ) + if ( wrong( gqsc,testgq ) ) & + call tstbad( 'gqsc', abs((gqsc - testgq) / testgq), ok ) +! + if ( wrong( dble(sforw), dble(testsf) ) .or. & + wrong( dimag(sforw), dimag(testsf) ) ) & + call tstbad( 'sforw', cdabs((sforw - testsf) / testsf), ok ) +! + if ( wrong( dble(sback), dble(testsb) ) .or. & + wrong( dimag(sback), dimag(testsb) ) ) & + call tstbad( 'sback', cdabs((sback - testsb) / testsb), ok ) +! + if ( wrong( dble(s1(1)), dble(tests1) ) .or. & + wrong( dimag(s1(1)), dimag(tests1) ) ) & + call tstbad( 's1', cdabs((s1(1) - tests1) / tests1), ok ) +! + if ( wrong( dble(s2(1)), dble(tests2) ) .or. & + wrong( dimag(s2(1)), dimag(tests2) ) ) & + call tstbad( 's2', cdabs((s2(1) - tests2) / tests2), ok ) +! + do 20 n = 1, 2 + if ( wrong( dble(tforw(n)), dble(testtf(n)) ) .or. & + wrong( dimag(tforw(n)), dimag(testtf(n)) ) ) & + call tstbad( 'tforw', cdabs( (tforw(n) - testtf(n)) / & + testtf(n) ), ok ) + if ( wrong( dble(tback(n)), dble(testtb(n)) ) .or. & + wrong( dimag(tback(n)), dimag(testtb(n)) ) ) & + call tstbad( 'tback', cdabs( (tback(n) - testtb(n)) / & + testtb(n) ), ok ) + 20 continue +! + do 30 m = 0, 1 + if ( wrong( pmom(m,1), testpm(m) ) ) & + call tstbad( 'pmom', dabs( (pmom(m,1)-testpm(m)) / & + testpm(m) ), ok ) + 30 continue +! + return +! + end subroutine testmi +!************************************************************************** + subroutine errmsg( messag, fatal ) +! +! print out a warning or error message; abort if error +! + USE module_peg_util, only: peg_message, peg_error_fatal + + implicit none + logical fatal, once + character*80 msg + character*(*) messag + integer maxmsg, nummsg + save maxmsg, nummsg, once + data nummsg / 0 /, maxmsg / 100 /, once / .false. / +! +! + if ( fatal ) then +! write ( *, '(2a)' ) ' ******* error >>>>>> ', messag +! stop + write( msg, '(a)' ) & + 'FASTJ mie fatal error ' // & + messag + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if +! + nummsg = nummsg + 1 + if ( nummsg.gt.maxmsg ) then +! if ( .not.once ) write ( *,99 ) + if ( .not.once )then + write( msg, '(a)' ) & + 'FASTJ mie: too many warning messages -- no longer printing ' + call peg_message( lunerr, msg ) + end if + once = .true. + else + msg = 'FASTJ mie warning ' // messag + call peg_message( lunerr, msg ) +! write ( *, '(2a)' ) ' ******* warning >>>>>> ', messag + endif +! + return +! +! 99 format( ///,' >>>>>> too many warning messages -- ', & +! 'they will no longer be printed <<<<<<<', /// ) + end subroutine errmsg +!******************************************************************** + subroutine wrtbad ( varnam, erflag ) +! +! write names of erroneous variables +! +! input : varnam = name of erroneous variable to be written +! ( character, any length ) +! +! output : erflag = logical flag, set true by this routine +! ---------------------------------------------------------------------- + USE module_peg_util, only: peg_message + + implicit none + character*(*) varnam + logical erflag + integer maxmsg, nummsg + character*80 msg + save nummsg, maxmsg + data nummsg / 0 /, maxmsg / 50 / +! +! + nummsg = nummsg + 1 +! write ( *, '(3a)' ) ' **** input variable ', varnam, & +! ' in error ****' + msg = 'FASTJ mie input variable in error ' // varnam + call peg_message( lunerr, msg ) + erflag = .true. + if ( nummsg.eq.maxmsg ) & + call errmsg ( 'too many input variable errors. aborting...$', .true. ) + return +! + end subroutine wrtbad +!****************************************************************** + subroutine tstbad( varnam, relerr, ok ) +! +! write name (-varnam-) of variable failing self-test and its +! percent error from the correct value. return ok = false. +! + implicit none + character*(*) varnam + logical ok + real*8 relerr +! +! + ok = .false. + write( *, '(/,3a,1p,e11.2,a)' ) & + ' output variable ', varnam,' differed by', 100.*relerr, & + ' per cent from correct value. self-test failed.' + return +! + end subroutine tstbad +!----------------------------------------------------------------------- + end module module_fastj_mie diff --git a/wrfv2_fire/chem/module_hetn2o5.F b/wrfv2_fire/chem/module_hetn2o5.F new file mode 100755 index 00000000..8589d8f0 --- /dev/null +++ b/wrfv2_fire/chem/module_hetn2o5.F @@ -0,0 +1,357 @@ +MODULE module_hetn2o5 + + +!temporary: +! from dentener and crutzen for 5S, 160E on 100mb levels startin at 1000mb + REAL, PARAMETER, DIMENSION(10) :: & + kheti = (/4.2e-5, 3.8e-5, 1.e-5,3.e-6,4.e-6, 2.e-6,3.e-6,5.e-6,1.3e-5,1.8e-5/) + + !kheta: on aerosol + REAL, SAVE, DIMENSION(120) :: kheta + + LOGICAL :: do_aerosol=.TRUE. + + +! sticking coefficients for cloud water and cloud ice + + REAL , PARAMETER, PRIVATE :: gammacldw = 0.05, & + gammacldi = 0.03 !cms check ! + + REAL , PARAMETER, PRIVATE :: rhograul = 400. ,& + rhoice = 917. + + REAL, PARAMETER, PRIVATE :: pi = 3.1415926 + + + ! D_g: diffusivity of species in gas phase in m^2/s + REAL, PARAMETER, PRIVATE :: D_g = 0.1E-6 + !in Match this is 1.e-5 (Schwartz ?!) + + + + + ! abar_c: mass mean radius for cloud drops in m + REAL, PARAMETER, PRIVATE :: abar_c = 10.E-6 + + + + ! RSTAR2 : universal gas constant in J/(kmol K) + REAL, PARAMETER, PRIVATE :: RSTAR2 = 8314. + + + ! parameters from Lin scheme + REAL , PARAMETER, PRIVATE :: xnor = 8.0e6 + REAL , PARAMETER, PRIVATE :: xnos = 3.0e6 + REAL , PARAMETER, PRIVATE :: xnog = 4.0e6 + + + + CONTAINS + SUBROUTINE hetn2o5calc(hetn2o5, rho, T, QC, QR, QI, QS, QG, & + rhowater, rhosnow, M_n2o5, & + P_QI,P_QS,P_QG, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + + IMPLICIT NONE + + + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte , & + P_QI,P_QS,P_QG + + + REAL, DIMENSION( its:ite , kts:kte , jts:jte), & + INTENT(INOUT ) :: hetn2o5 + + + + REAL, INTENT(IN ) :: rhosnow, & + rhowater, & + M_n2o5 + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + QC, & + QR, & + QI, & + QS, & + QG, & + rho, & + T + + +!local vars + + REAL :: orho, tmp1 + + + ! mass mean radii of the different hydrometeors + REAL :: & + abar_r, abar_i, abar_s, abar_g + + + ! nu_th: thermal velocity of species in m/s + REAL :: nu_th + + ! tau_Dg: gas diffusion timescale + ! tau_i : timescale for mass transfer across interface of hydrometeor + REAL :: tau_i, tau_Dg + + + ! L : water contents in cloud drops, rain drops, hail stones,... + ! in (cm^3 H_2O / cm^3 air) + REAL :: L + + + ! loss rates: + REAL :: kc, kr, ki, ks, kg + + + INTEGER :: i,j,k + + +!---- + + j_loop: DO j = jts, jte + i_loop: DO i = its, ite + + DO k = kts, kte + orho = 1./rho(i,k,j) + + + + kc = 0. + kr = 0. + ki = 0. + ks = 0. + kg = 0. + + + + !! abar_c + + + IF(QR(i,k,j) .GT. 1.e-12) THEN + tmp1=sqrt(pi*rhowater*xnor*orho/QR(i,k,j)) + !!xlambdar1Dr(k)=sqrt(tmp1) + abar_r = 2./MAX(sqrt(tmp1), 1.E-8 ) !if abar is large, kt becomes small + ENDIF + + +!!$ IF(QI(i,k,j) .GT. 1.e-8) THEN +!!$ tmp1=sqrt(pi*rhoice*xnoi*orho/QI(i,k,j)) +!!$ !!xlambdar1Di(k)=sqrt(tmp1) +!!$ abar_i = 2./MAX(sqrt(tmp1), 1.E-8 ) +!!$ ENDIF + + + abar_i = abar_c + + IF(QS(i,k,j) .GT. 1.e-12) THEN + tmp1=sqrt(pi*rhosnow*xnos*orho/QS(i,k,j)) + !!xlambdar1Ds(k)=sqrt(tmp1) + abar_s = 2./MAX(sqrt(tmp1), 1.E-8 ) + ENDIF + + + + IF(QG(i,k,j) .GT. 1.e-12) THEN + tmp1=sqrt(pi*rhograul*xnog*orho/QG(i,k,j)) + !!xlambdar1Dg(k)=sqrt(tmp1) + abar_g = 2./MAX(sqrt(tmp1), 1.E-8 ) + ENDIF + + + + +! calculate thermal velocity of species + nu_th = SQRT(8*RSTAR2*T(i,k,j)/(pi*M_n2o5)) + + + +! calculate timescales + !cloud droplets + IF(QC(i,k,j) .GT. 1.e-12) THEN + tau_i = (4.*abar_c) / (3.* nu_th * gammacldw) + tau_Dg = (abar_c**2) / (3.* D_g) + + L = (rho(i,k,j) / rhowater) * QC(i,k,j) + kc = L/(tau_i + tau_Dg) + ENDIF + + !rain + IF(QR(i,k,j) .GT. 1.e-12) THEN + tau_i = (4.*abar_r) / (3.* nu_th * gammacldw) + tau_Dg = (abar_r**2) / (3.* D_g) + + L = (rho(i,k,j) / rhowater) * QR(i,k,j) + kr = L/(tau_i + tau_Dg) + ENDIF + + !cloud ice + IF(QI(i,k,j) .GT. 1.e-12) THEN + tau_i = (4.*abar_i) / (3.* nu_th * gammacldi) + tau_Dg = (abar_i**2) / (3.* D_g) + + L = (rho(i,k,j) / rhowater) * QI(i,k,j) + ki = L/(tau_i + tau_Dg) + ENDIF + + !snow + IF(QS(i,k,j).GT. 1.e-12) THEN + tau_i = (4.*abar_s) / (3.* nu_th * gammacldi) + tau_Dg = (abar_s**2) / (3.* D_g) + + L = (rho(i,k,j) / rhowater) * QS(i,k,j) + ks = L/(tau_i + tau_Dg) + ENDIF + + !graupel + IF(QG(i,k,j).GT. 1.e-12) THEN + tau_i = (4.*abar_g) / (3.* nu_th * gammacldi) + tau_Dg = (abar_g**2) / (3.* D_g) + + L = (rho(i,k,j) / rhowater) * QG(i,k,j) + kg = L/(tau_i + tau_Dg) + ENDIF + + + +!!HERE THE VENTILATION COEFF SHOULD BE INCLUDED AND IT PROBABLY DOES NOT HAPPEN ON ICE!! + +!! hetn2o5(i,k,j) = kc + kr + ki + ks + kg + + + + + + hetn2o5(i,k,j) = kc + kr + kheta(k) !!+ kg + !hetn2o5(i,k,j) = 0. !n2o5_test + + + ENDDO + + ENDDO i_loop + ENDDO j_loop + + END SUBROUTINE hetn2o5calc + + + + + +!----------------------------------------------------------------- + + SUBROUTINE hetn2o5_ini( pb, pp, z, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + +#ifdef DM_PARALLEL + USE module_dm +#endif + + IMPLICIT NONE + + + INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme), & + INTENT(IN ) :: z, pb, pp + + REAL, DIMENSION(10) :: pin !moguntia + + + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + +!local + + REAL, DIMENSION(kms:kme) :: zloc, ploc + + INTEGER :: k, kk, l_low, l_up + REAL :: m, b, dp + + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + IF (.NOT. do_aerosol) RETURN + +!currently not really necessary +dm_on_monitor: IF ( wrf_dm_on_monitor() ) THEN + + kheta(:) = 0. + + + + pin(kms)=1000. + DO k=2,10 + pin(k)=pin(k-1)-100. + ENDDO + + + DO k=kms,kme + + zloc(k) = z(its,k,jts) + ploc(k) = pb(its,k,jts) + pp(its,k,jts) + + IF ( zloc(k) .GT. 1.e6 .OR. zloc(k) .LT. 0. ) THEN + CALL wrf_error_fatal ("STOP: hetn2o5_ini") + ENDIF + + ENDDO + + DO k=kms,kme + IF ( ploc(k) .GT. 1.e5 ) THEN + kheta(k) = kheti(1) + ELSE + + l_low = 11.-CEILING(ploc(k)/1.e4) + l_up=l_low+1 + + + dp=ploc(k)/100. - pin(l_up) + m=(kheti(l_low)-kheti(l_up))/100. + kheta(k)=kheti(l_up) + m*dp + + + + !print *,l_low + !print *, ploc(k), pin(l_low), pin(l_up) + !print *, " ", kheti(l_low),kheti(l_up), kheta(k) + + + + END IF + + + ENDDO + + + + +ENDIF dm_on_monitor + + DM_BCAST_MACRO( kheta ) + + + + END SUBROUTINE hetn2o5_ini + + +END MODULE module_hetn2o5 + + + + + + diff --git a/wrfv2_fire/chem/module_input_chem_bioemiss.F b/wrfv2_fire/chem/module_input_chem_bioemiss.F new file mode 100644 index 00000000..e4cc2a82 --- /dev/null +++ b/wrfv2_fire/chem/module_input_chem_bioemiss.F @@ -0,0 +1,227 @@ +!dis +!dis Open Source License/Disclaimer, Forecast Systems Laboratory +!dis NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305 +!dis +!dis This software is distributed under the Open Source Definition, +!dis which may be found at http://www.opensource.org/osd.html. +!dis +!dis In particular, redistribution and use in source and binary forms, +!dis with or without modification, are permitted provided that the +!dis following conditions are met: +!dis +!dis - Redistributions of source code must retain this notice, this +!dis list of conditions and the following disclaimer. +!dis +!dis - Redistributions in binary form must provide access to this +!dis notice, this list of conditions and the following disclaimer, and +!dis the underlying source code. +!dis +!dis - All modifications to this software must be clearly documented, +!dis and are solely the responsibility of the agent making the +!dis modifications. +!dis +!dis - If significant modifications or enhancements are made to this +!dis software, the FSL Software Policy Manager +!dis (softwaremgr@fsl.noaa.gov) should be notified. +!dis +!dis THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN +!dis AND ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES +!dis GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND +!dis AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS +!dis OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME +!dis NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND +!dis DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS. +!dis +!dis + +!WRF:PACKAGE:IO + +MODULE module_input_chem_bioemiss + + USE module_io_domain + USE module_domain + USE module_driver_constants + USE module_state_description + USE module_configure + USE module_date_time + USE module_wrf_error + USE module_timing + USE module_data_radm2 + USE module_aerosols_sorgam + USE module_get_file_names + + +CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE input_ext_chem_beis3_file (grid) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + + TYPE(domain) :: grid + + INTEGER :: i,j,n,numfil,status,system + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + REAL, ALLOCATABLE, DIMENSION(:,:) :: emiss + + + +! Number of reference emission and LAI files to open + PARAMETER(numfil=19) + + CHARACTER (LEN=80) :: message + + TYPE (grid_config_rec_type) :: config_flags + +! Normalized biogenic emissions for standard conditions (moles compound/km^2/hr) +! REAL, DIMENSION(i,j) :: & +! sebio_iso,sebio_oli,sebio_api,sebio_lim,sebio_xyl, & +! sebio_hc3,sebio_ete,sebio_olt,sebio_ket,sebio_ald, & +! sebio_hcho,sebio_eth,sebio_ora2,sebio_co,sebio_nr, & +! noag_grow,noag_nongrow,nononag + +! Leaf area index for isoprene +! REAL, DIMENSION(i,j) :: slai + +! Filenames of reference emissions and LAI + CHARACTER*100 onefil + CHARACTER*12 emfil(numfil) + DATA emfil/'ISO','OLI','API','LIM','XYL','HC3','ETE','OLT', & + 'KET','ALD','HCHO','ETH','ORA2','CO','NR', & + 'NOAG_GROW','NOAG_NONGROW','NONONAG','ISOP'/ + +!!!!!------------------------------------------------------------------- + + ! Get grid dimensions + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + WRITE( message , FMT='(A,4I5)' ) ' DIMS: ',ids,ide-1,jds,jde-1 + CALL wrf_message ( message ) + + ALLOCATE( emiss(ids:ide-1,jds:jde-1) ) + + +! Loop over the file names + DO n=1,numfil + +! Remove scratch unzipped file + status=system('rm -f scratem*') + +! All reference emissions except NO + IF(n.LE.15)THEN + onefil='../../run/BIOREF_'// & + TRIM(ADJUSTL(emfil(n)))//'.gz' +! NO reference emissions + ELSE IF(n.GE.16.AND.n.LE.18)THEN + onefil='../../run/AVG_'// & + TRIM(ADJUSTL(emfil(n)))//'.gz' +! LAI + ELSE + onefil='../../run/LAI_'// & + TRIM(ADJUSTL(emfil(n)))//'S.gz' + ENDIF + +! Copy selected file to scratch + status=system('cp '//TRIM(ADJUSTL(onefil))//' scratem.gz') + +! Unzip scratch + status=system('gunzip scratem') + +! Open scratch and read into appropriate array + OPEN(26,FILE='scratem',FORM='FORMATTED') + IF(n.EQ. 1) then + READ(26,'(12E9.2)') emiss + grid%sebio_iso(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 2)then + READ(26,'(12E9.2)') emiss + grid%sebio_oli(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 3)then + READ(26,'(12E9.2)') emiss + grid%sebio_api(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 4)then + READ(26,'(12E9.2)') emiss + grid%sebio_lim(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 5)then + READ(26,'(12E9.2)') emiss + grid%sebio_xyl(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 6)then + READ(26,'(12E9.2)') emiss + grid%sebio_hc3(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 7)then + READ(26,'(12E9.2)') emiss + grid%sebio_ete(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 8)then + READ(26,'(12E9.2)') emiss + grid%sebio_olt(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ. 9)then + READ(26,'(12E9.2)') emiss + grid%sebio_ket(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.10)then + READ(26,'(12E9.2)') emiss + grid%sebio_ald(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.11)then + READ(26,'(12E9.2)') emiss + grid%sebio_hcho(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.12)then + READ(26,'(12E9.2)') emiss + grid%sebio_eth(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.13)then + READ(26,'(12E9.2)') emiss + grid%sebio_ora2(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.14)then + READ(26,'(12E9.2)') emiss + grid%sebio_co(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.15)then + READ(26,'(12E9.2)') emiss + grid%sebio_nr(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.16)then + READ(26,'(12E9.2)') emiss + grid%noag_grow(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.17)then + READ(26,'(12E9.2)') emiss + grid%noag_nongrow(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.18)then + READ(26,'(12E9.2)') emiss + grid%nononag(ids:ide-1,jds:jde-1) = emiss + ENDIF + IF(n.EQ.19)then + READ(26,'(12E9.2)') emiss + grid%slai(ids:ide-1,jds:jde-1) = emiss + ENDIF + CLOSE(26) + + ENDDO +! End of loop over file names + + DEALLOCATE( emiss ) + +END SUBROUTINE input_ext_chem_beis3_file +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +END MODULE module_input_chem_bioemiss + diff --git a/wrfv2_fire/chem/module_input_chem_data.F b/wrfv2_fire/chem/module_input_chem_data.F new file mode 100755 index 00000000..30231dfa --- /dev/null +++ b/wrfv2_fire/chem/module_input_chem_data.F @@ -0,0 +1,2757 @@ +!dis +!dis Open Source License/Disclaimer, Forecast Systems Laboratory +!dis NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305 +!dis +!dis This software is distributed under the Open Source Definition, +!dis which may be found at http://www.opensource.org/osd.html. +!dis +!dis In particular, redistribution and use in source and binary forms, +!dis with or without modification, are permitted provided that the +!dis following conditions are met: +!dis +!dis - Redistributions of source code must retain this notice, this +!dis list of conditions and the following disclaimer. +!dis +!dis - Redistributions in binary form must provide access to this +!dis notice, this list of conditions and the following disclaimer, and +!dis the underlying source code. +!dis +!dis - All modifications to this software must be clearly documented, +!dis and are solely the responsibility of the agent making the +!dis modifications. +!dis +!dis - If significant modifications or enhancements are made to this +!dis software, the FSL Software Policy Manager +!dis (softwaremgr@fsl.noaa.gov) should be notified. +!dis +!dis THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN +!dis AND ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES +!dis GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND +!dis AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS +!dis OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME +!dis NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND +!dis DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS. +!dis +!dis + +!WRF:PACKAGE:IO + + +!CPP directives to control ic/bc conditions... +!(The directive in module_mosaic_initmixrats also needs to be set.) +! CASENAME = 0 Uses Texas August 2004 case values and profiles +! 1 Uses same concentrations as TX, but uses different +! profiles depending on the species. (NEAQS2004 case) +#define CASENAME 0 + + +MODULE module_input_chem_data + + USE module_io_domain + USE module_domain + USE module_driver_constants + USE module_state_description + USE module_configure + USE module_date_time + USE module_wrf_error + USE module_timing + USE module_data_radm2 + USE module_aerosols_sorgam + USE module_data_sorgam + USE module_utility + USE module_get_file_names + + + IMPLICIT NONE + +! REAL :: grav = 9.8104 + REAL, PARAMETER :: mwso4 = 96.0576 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Initial atmospheric chemistry profile data + INTEGER :: k_loop ! Used for loop index + INTEGER :: lo ! number of chemicals in inital profile + INTEGER :: logg ! number of final chemical species (nch-1) + INTEGER :: kx ! number of vertical levels in temp profile + INTEGER :: kxm1 + + PARAMETER( kx=16, kxm1=kx-1, logg=100, lo=34) + + INTEGER, DIMENSION(logg) :: iref + + REAL, DIMENSION(logg) :: fracref + REAL, DIMENSION(kx) :: dens + REAL, DIMENSION(kx+1) :: zfa + REAL, DIMENSION(kx+1) :: zfa_bdy + REAL, DIMENSION(lo ,kx) :: xl + REAL :: so4vaptoaer + DATA so4vaptoaer/.999/ + + CHARACTER (LEN=4), DIMENSION(logg) :: ggnam + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! The idealized profile is converted from the NALROM chemistry model. +! +! The variable "iref" is the reference index +! "fracref" is the reference fraction correpsonding to iref +! +! For example: WRF-Chem species number 1 is SO2. iref(1) is 12, and XL(12,K) +! is the profile for SO2. +! +! Note: NALROM calculates lumped OX (XL(1) =O3+NO2+HNO3+...) and a +! lumped NOX (XL(2)=NO+NO2+NO3+2N2O5+HO2NO2+HONO). But XL(33) is +! strictly O3, and XL(34)=NOx=(NO+NO2 only). +! +! Short-lived species are initialized to steady-state equilibrium - +! since they are short-lived. The short-lived species within a lumped category +! (Ox , NOx, or NO3+N2O5 in our case) would be renormalized to the lumped class +! after the steady-state equilibrium concentrations are determined. +! +! The following is a list of long-lived species +! +! NAMEL( 1)='OX ' +! NAMEL( 2)='NOX ' +! NAMEL( 3)='HNO3 ' +! NAMEL( 4)='H2O2 ' +! NAMEL( 5)='CH3OOH ' +! NAMEL( 6)='CO ' +! NAMEL( 7)='ISOPRENE ' +! NAMEL( 8)='CH2O ' +! NAMEL( 9)='CH3CHO ' +! NAMEL(10)='PAN ' +! NAMEL(11)='OTHER ALKA' +! NAMEL(12)='SO2 ' +! NAMEL(13)='BUTANE ' +! NAMEL(14)='ETHENE ' +! NAMEL(15)='PROPENE+ ' +! NAMEL(16)='PPN ' +! NAMEL(17)='MEK ' +! NAMEL(18)='RCHO ' +! NAMEL(19)='SO4= ' +! NAMEL(20)='MVK ' +! NAMEL(21)='MACR ' +! NAMEL(22)='HAC ' +! NAMEL(23)='MGLY ' +! NAMEL(24)='HPAN ' +! NAMEL(25)='MPAN ' +! NAMEL(26)='PROPANE ' +! NAMEL(27)='ACETYLENE ' +! NAMEL(28)='OH ' +! NAMEL(29)='HO2 ' +! NAMEL(30)='NO3+N2O5 ' +! NAMEL(31)='HO2NO2 ' +! NAMEL(32)='SUM RO2 ' +! NAMEL(33)='OZONE ' +! NAMEL(34)='NOX ' +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1 + + + DATA iref/12,19,2,2,1,3,4,9,8,5,5,32,6,6,6,30,30,10,26,13,11,6,6, & + 14,15,15,23,23,32,16,23,31,17,5*23,7,28,29,59*7/ + + DATA fracref/1.,1.,.75,.25,6*1.,.5,.5,6.25E-4,7.5E-4,6.25E-5,.1, & + .9,4*1.,8.E-3,3*1.,.5,1.,1.,.5,12*1.,59*1./ + + DATA ggnam/ 'SO2 ','SULF','NO2 ','NO ','O3 ','HNO3', & + 'H2O2','ALD ','HCHO','OP1 ','OP2 ','PAA ', & + 'ORA1','ORA2','NH3 ','N2O5','NO3 ','PAN ', & + 'HC3 ','HC5 ','HC8 ','ETH ','CO ','OL2 ', & + 'OLT ','OLI ','TOL ','XYL ','ACO3','TPAN', & + 'HONO','HNO4','KET ','GLY ','MGLY','DCB ', & + 'ONIT','CSL ','ISO ','HO ','HO2 ',59*'JUNK' / + + DATA dens/ 2.738E+18, 5.220E+18, 7.427E+18, 9.202E+18, & + 1.109E+19, 1.313E+19, 1.525E+19, 1.736E+19, & + 1.926E+19, 2.074E+19, 2.188E+19, 2.279E+19, & + 2.342E+19, 2.384E+19, 2.414E+19, 2.434E+19 / + +! Profile heights in meters +! DATA ZFA/ 0., 85., 212., 385., 603., 960., 1430., 2010., & +! 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & +! 21000./ +#if ( ! EM_CORE == 0 ) + DATA ZFA_BDY/ 0., 85., 212., 385., 603., 960., 1430., 2010., & + 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & + 21000./ + +! Profile heights in meters + DATA ZFA/ 0., 85., 212., 385., 603., 960., 1430., 2010., & + 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & + 21000./ +#endif +#if ( ! NMM_CORE == 0 ) + + DATA ZFA_BDY/ 0., 85., 212., 385., 603., 960., 1430., 2010., & + 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & + 21000./ + +! Profile pressure in hpa + DATA ZFA/ 100000., 98500., 98000., 96000., 94000., 90000., 85000., 75000., & + 71000., 65000., 52000., 48000., 45000., 30000., 25000., 20000., & + 5000./ +#endif + +!wig: To match the xl profile to the correct species, match WRF's p_ +! flag with iref(p_-1) to get the value of the first index in xl, +! e.g. p_o3=6, iref(6-1)=1, so xl(1,:) is the ozone profile. +! See gasprofile_init_pnnl for an explination of what height +! each index represents. + DATA (xl(1,k_loop),k_loop=1,kx) & + / 1.68E-07, 1.68E-07, 5.79E-08, 5.24E-08, 5.26E-08, & + 5.16E-08, 4.83E-08, 4.50E-08, 4.16E-08, 3.80E-08, 3.56E-08, & + 3.35E-08, 3.15E-08, 3.08E-08, 3.06E-08, 3.00E-08/ + + DATA (xl(2,k_loop),k_loop=1,kx) & + / 4.06E-10, 4.06E-10, 2.16E-10, 1.37E-10, 9.47E-11, & + 6.95E-11, 5.31E-11, 4.19E-11, 3.46E-11, 3.01E-11, 2.71E-11, & + 2.50E-11, 2.35E-11, 2.26E-11, 2.20E-11, 2.16E-11/ + + DATA (xl(3,k_loop),k_loop=1,kx) & + / 9.84E-10, 9.84E-10, 5.66E-10, 4.24E-10, 3.26E-10, & + 2.06E-10, 1.12E-10, 7.33E-11, 7.03E-11, 7.52E-11, 7.96E-11, & + 7.56E-11, 7.27E-11, 7.07E-11, 7.00E-11, 7.00E-11/ + + DATA (xl(4,k_loop),k_loop=1,kx) & + / 8.15E-10, 8.15E-10, 8.15E-10, 8.15E-10, 8.15E-10, & + 8.65E-10, 1.07E-09, 1.35E-09, 1.47E-09, 1.47E-09, 1.47E-09, & + 1.47E-09, 1.45E-09, 1.43E-09, 1.40E-09, 1.38E-09/ + + DATA (xl(5,k_loop),k_loop=1,kx) & + / 4.16E-10, 4.16E-10, 4.16E-10, 4.16E-10, 4.16E-10, & + 4.46E-10, 5.57E-10, 1.11E-09, 1.63E-09, 1.63E-09, 1.63E-09, & + 1.63E-09, 1.61E-09, 1.59E-09, 1.57E-09, 1.54E-09/ + +! CO is 70 ppbv at top, 80 throughout troposphere + DATA (xl(6,k_loop),k_loop=1,kx) / 7.00E-08, kxm1*8.00E-08/ + + DATA (xl(7,k_loop),k_loop=1,kx) & + / 8.33E-29, 8.33E-29, 8.33E-29, 8.33E-29, 8.33E-29, & + 1.33E-28, 3.54E-28, 1.85E-28, 1.29E-29, 1.03E-30, 1.72E-31, & + 7.56E-32, 1.22E-31, 2.14E-31, 2.76E-31, 2.88E-31/ + + DATA (xl(8,k_loop),k_loop=1,kx) & + / 9.17E-11, 9.17E-11, 9.17E-11, 9.17E-11, 9.17E-11, & + 1.03E-10, 1.55E-10, 2.68E-10, 4.47E-10, 4.59E-10, 4.72E-10, & + 4.91E-10, 5.05E-10, 5.13E-10, 5.14E-10, 5.11E-10/ + DATA (xl(9,k_loop),k_loop=1,kx) & + / 7.10E-12, 7.10E-12, 7.10E-12, 7.10E-12, 7.10E-12, & + 7.36E-12, 1.02E-11, 2.03E-11, 2.98E-11, 3.01E-11, 3.05E-11, & + 3.08E-11, 3.08E-11, 3.06E-11, 3.03E-11, 2.99E-11/ + DATA (xl(10,k_loop),k_loop=1,kx) & + / 4.00E-11, 4.00E-11, 4.00E-11, 3.27E-11, 2.51E-11, & + 2.61E-11, 2.20E-11, 1.69E-11, 1.60E-11, 1.47E-11, 1.37E-11, & + 1.30E-11, 1.24E-11, 1.20E-11, 1.18E-11, 1.17E-11/ + DATA (xl(11,k_loop),k_loop=1,kx) & + / 1.15E-16, 1.15E-16, 2.46E-15, 2.30E-14, 1.38E-13, & + 6.25E-13, 2.31E-12, 7.32E-12, 1.87E-11, 3.68E-11, 6.10E-11, & + 9.05E-11, 1.22E-10, 1.50E-10, 1.70E-10, 1.85E-10/ + DATA (xl(12,k_loop),k_loop=1,kx) & + / 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, & + 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, & + 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10, 1.00E-10/ + DATA (xl(13,k_loop),k_loop=1,kx) & + / 1.26E-11, 1.26E-11, 2.02E-11, 2.50E-11, 3.02E-11, & + 4.28E-11, 6.62E-11, 1.08E-10, 1.54E-10, 2.15E-10, 2.67E-10, & + 3.24E-10, 3.67E-10, 3.97E-10, 4.16E-10, 4.31E-10/ + DATA (xl(14,k_loop),k_loop=1,kx) & + / 1.15E-16, 1.15E-16, 2.46E-15, 2.30E-14, 1.38E-13, & + 6.25E-13, 2.31E-12, 7.32E-12, 1.87E-11, 3.68E-11, 6.10E-11, & + 9.05E-11, 1.22E-10, 1.50E-10, 1.70E-10, 1.85E-10/ + DATA (xl(15,k_loop),k_loop=1,kx) & + / 1.00E-20, 1.00E-20, 6.18E-20, 4.18E-18, 1.23E-16, & + 2.13E-15, 2.50E-14, 2.21E-13, 1.30E-12, 4.66E-12, 1.21E-11, & + 2.54E-11, 4.47E-11, 6.63E-11, 8.37E-11, 9.76E-11/ + DATA (xl(16,k_loop),k_loop=1,kx) & + / 1.23E-11, 1.23E-11, 1.23E-11, 1.23E-11, 1.23E-11, & + 1.20E-11, 9.43E-12, 3.97E-12, 1.19E-12, 1.11E-12, 9.93E-13, & + 8.66E-13, 7.78E-13, 7.26E-13, 7.04E-13, 6.88E-13/ + DATA (xl(17,k_loop),k_loop=1,kx) & + / 1.43E-12, 1.43E-12, 1.43E-12, 1.43E-12, 1.43E-12, & + 1.50E-12, 2.64E-12, 8.90E-12, 1.29E-11, 1.30E-11, 1.32E-11, & + 1.32E-11, 1.31E-11, 1.30E-11, 1.29E-11, 1.27E-11/ + DATA (xl(18,k_loop),k_loop=1,kx) & + / 3.61E-13, 3.61E-13, 3.61E-13, 3.61E-13, 3.61E-13, & + 3.58E-13, 5.22E-13, 1.75E-12, 2.59E-12, 2.62E-12, 2.64E-12, & + 2.66E-12, 2.65E-12, 2.62E-12, 2.60E-12, 2.57E-12/ + DATA (xl(19,k_loop),k_loop=1,kx) & + / 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, & + 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, & + 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11, 5.00E-11/ + + DATA (xl(20,k_loop),k_loop=1,kx)/kx*1.E-20/ + DATA (xl(21,k_loop),k_loop=1,kx)/kx*1.E-20/ + DATA (xl(22,k_loop),k_loop=1,kx)/kx*1.E-20/ + DATA (xl(23,k_loop),k_loop=1,kx)/kx*1.E-20/ + DATA (xl(24,k_loop),k_loop=1,kx)/kx*1.E-20/ + DATA (xl(25,k_loop),k_loop=1,kx)/kx*1.E-20/ + +! Propane - Gregory PEM-West A 25 ppt median marine boundary layer + DATA (xl(26,k_loop),k_loop=1,kx) & + /5.00E-13, 1.24E-12, 2.21E-12, 3.27E-12, 4.71E-12, & + 6.64E-12, 9.06E-12, 1.19E-11, 1.47E-11, 1.72E-11, & + 1.93E-11, 2.11E-11, 2.24E-11, 2.34E-11, 2.42E-11, 2.48E-11/ +! Acetylene - Gregory PEM-West A 53 ppt median marine boundary layer + DATA (xl(27,k_loop),k_loop=1,kx) & + /1.00E-12, 2.48E-12, 4.42E-12, 6.53E-12, 9.42E-12, & + 1.33E-11, 1.81E-11, 2.37E-11, 2.95E-11, 3.44E-11, & + 3.85E-11, 4.22E-11, 4.49E-11, 4.69E-11, 4.84E-11, 4.95E-11/ +! OH + DATA (xl(28,k_loop),k_loop=1,kx) & + / 9.80E+06, 9.80E+06, 4.89E+06, 2.42E+06, 1.37E+06, & + 9.18E+05, 7.29E+05, 6.26E+05, 5.01E+05, 4.33E+05, 4.05E+05, & + 3.27E+05, 2.54E+05, 2.03E+05, 1.74E+05, 1.52E+05/ +! HO2 + DATA (xl(29,k_loop),k_loop=1,kx) & + / 5.74E+07, 5.74E+07, 7.42E+07, 8.38E+07, 8.87E+07, & + 9.76E+07, 1.15E+08, 1.34E+08, 1.46E+08, 1.44E+08, 1.40E+08, & + 1.36E+08, 1.31E+08, 1.28E+08, 1.26E+08, 1.26E+08/ +! NO3+N2O5 + DATA (xl(30,k_loop),k_loop=1,kx) & + / 5.52E+05, 5.52E+05, 3.04E+05, 2.68E+05, 2.32E+05, & + 1.66E+05, 1.57E+05, 1.72E+05, 1.98E+05, 2.22E+05, 2.43E+05, & + 2.75E+05, 3.00E+05, 3.18E+05, 3.32E+05, 3.39E+05/ +! HO2NO2 + DATA (xl(31,k_loop),k_loop=1,kx) & + / 7.25E+07, 7.25E+07, 6.36E+07, 5.55E+07, 4.94E+07, & + 3.66E+07, 2.01E+07, 9.57E+06, 4.75E+06, 2.37E+06, 1.62E+06, & + 9.86E+05, 7.05E+05, 5.63E+05, 4.86E+05, 4.41E+05/ +! Sum of RO2 & + DATA (xl(32,k_loop),k_loop=1,kx) & + / 9.14E+06, 9.14E+06, 1.46E+07, 2.14E+07, 2.76E+07, & + 3.62E+07, 5.47E+07, 1.19E+08, 2.05E+08, 2.25E+08, 2.39E+08, & + 2.58E+08, 2.82E+08, 2.99E+08, 3.08E+08, 3.15E+08/ +! O3 <--This is not the O3 used for RADM2 or CBMZ (wig) + DATA (xl(33,k_loop),k_loop=1,kx) & + / 8.36E+11, 8.36E+11, 4.26E+11, 4.96E+11, 6.05E+11, & + 6.93E+11, 7.40E+11, 7.74E+11, 7.82E+11, 7.75E+11, 7.69E+11, & + 7.59E+11, 7.54E+11, 7.50E+11, 7.47E+11, 7.45E+11/ +! NOx (NO+NO2) + DATA (xl(34,k_loop),k_loop=1,kx) & + / 1.94E+09, 1.94E+09, 1.53E+09, 1.24E+09, 1.04E+09, & + 8.96E+08, 7.94E+08, 7.11E+08, 6.44E+08, 6.00E+08, 5.70E+08, & + 5.49E+08, 5.35E+08, 5.28E+08, 5.24E+08, 5.23E+08/ + +CONTAINS + +SUBROUTINE input_ext_chem_file (si_grid) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + + TYPE(domain) :: si_grid + + INTEGER :: i , j , k, l, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + INTEGER :: si_jday + INTEGER :: dat_jday,dat_year,dat_month,dat_day,dat_hour,dat_min,dat_sec + INTEGER :: time_loop_max , time_loop + INTEGER, DIMENSION(2) :: num_steps + INTEGER :: fid, ierr, rc + INTEGER :: status_next_var + INTEGER :: debug_level + INTEGER :: si_year,si_month,si_day,si_hour,si_min,si_sec + INTEGER :: total_time_sec , file_counter +#if ( ! NMM_CORE == 0 ) + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: pint + REAL, ALLOCATABLE, DIMENSION(:,:) :: pdsl +#endif + + LOGICAL :: input_from_file , need_new_file + + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: si_zsigf, si_zsig + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ch_zsigf, ch_zsig, ozone + REAL :: ext_time, dat_time + REAL :: wgt0,wgt_time1,wgt_time2 + + CHARACTER (LEN=80) :: inpname, message + CHARACTER (LEN=19) :: date_string + CHARACTER (LEN=19) :: extract_date, use_date, current_date_char + CHARACTER*80 :: timestr + + TYPE (grid_config_rec_type) :: config_flags + TYPE(domain) , POINTER :: null_domain, chem_grid, chgrid + TYPE(domain) , POINTER :: chem_grid2, chgrid2 +! TYPE(ESMF_Time) :: CurrTime + + ! Interface block for routine that passes pointers and needs to know that they + ! are receiving pointers. + + + CALL model_to_grid_config_rec ( si_grid%id , model_config_rec , config_flags ) + ! After current_date has been set, fill in the julgmt stuff. + + CALL geth_julgmt ( config_flags%julyr , config_flags%julday , config_flags%gmt ) + + WRITE ( extract_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + model_config_rec%start_year (si_grid%id) , & + model_config_rec%start_month (si_grid%id) , & + model_config_rec%start_day (si_grid%id) , & + model_config_rec%start_hour (si_grid%id) , & + model_config_rec%start_minute(si_grid%id) , & + model_config_rec%start_second(si_grid%id) + + write(message,'(A,A)') 'Subroutine input_chem: finding data at date/time: ',extract_date + CALL wrf_message ( TRIM(message) ) + + + ! And here is an instance of using the information in the NAMELIST. + + CALL nl_get_debug_level ( 1,debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + + ! Allocated and configure the mother domain. Since we are in the nesting down + ! mode, we know a) we got a nest, and b) we only got 1 nest. + + NULLIFY( null_domain ) + + CALL wrf_debug ( 100 , 'wrfchem:input_chem: calling alloc_and_configure_domain 1' ) + ! Note that this is *not* the intended use of alloc_and_configure_domain() + ! It does not seem to hurt anything, yet... + +! if( si_grid%id .EQ. 1) then + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = chem_grid , & + parent = null_domain , & + kid = -1 ) + +! else +! CALL alloc_and_configure_domain ( domain_id = 2 , & +! grid = chem_grid , & +! parent = parent_grid , & +! kid = 1 ) +! endif + + + + CALL wrf_debug ( 100 , 'wrfchem:input_chem: set pointer for domain 1' ) + chgrid => chem_grid + + ! Get a list of available file names to try. This fills up the eligible_file_name + ! array with number_of_eligible_files entries. This routine issues a nonstandard + ! call (system). + + file_counter = 1 + need_new_file = .FALSE. + + CALL unix_ls ( 'wrf_chem_input' , chem_grid%id ) + write(message,'(A,A)') 'number of eligible files ', number_of_eligible_files + CALL wrf_message( TRIM(message) ) + +! ! Open the input data (chemin_d01_000000) for reading. +! CALL wrf_debug ( 100 , 'subroutine input_chem: calling open_r_dataset for wrfout' ) +! CALL construct_filename ( inpname , 'chemin' , chgrid%id, 2 , 0 , 6 ) + + CALL construct_filename2a (inpname , chgrid%input_chem_inname, chgrid%id , 2, extract_date) + write(message,'(A,A)') 'Subroutine input_chem: Opening data file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + + CALL open_r_dataset ( fid, TRIM(inpname) , chgrid, config_flags, "DATASET=INPUT", ierr ) + + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'subroutine chemin: error opening ',TRIM(inpname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + ! How many data time levels in the input file? + + num_steps = -1 + time_loop_max = 0 + CALL wrf_debug ( 100, 'subroutine input_chem: find time_loop_max' ) + + ! Which times are in this file, and more importantly, are any of them the + ! ones that we want? We need to loop over times in each files, loop + ! over files. + + get_the_right_time : DO +! CALL ext_ncd_get_next_time ( fid, date_string, status_next_var ) + CALL wrf_get_next_time ( fid, date_string, status_next_var ) + + write(message,'(6A)') 'Subroutine input_chem: file date/time = ',date_string,' status = ', status_next_var + CALL wrf_message ( TRIM(message) ) + + IF ( status_next_var == 0 ) THEN + CALL wrf_debug ( 100 , 'input_ext_chem_file: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) ) + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + time_loop_max = time_loop_max + 1 + IF ( time_loop_max .GT. number_of_eligible_files ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program input_chem_data: opening too many files' + CALL WRF_ERROR_FATAL ( wrf_err_message ) + END IF + + IF ( time_loop_max .EQ. number_of_eligible_files ) THEN + num_steps(1) = time_loop_max + num_steps(2) = time_loop_max+1 + use_date = date_string + wgt_time1 = dat_time + + EXIT get_the_right_time + END IF + CYCLE get_the_right_time + ELSE +! ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN +! CYCLE get_the_right_time +! ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN +! EXIT get_the_right_time +! ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN +! WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),' .' +! CALL WRF_ERROR_FATAL ( wrf_err_message ) +! END IF + +! For now, the input date and time MUST match +! +! Put the time check here and set num_steps + + num_steps(1) = time_loop_max + num_steps(2) = time_loop_max+1 + use_date = date_string + wgt_time1 = dat_time + + EXIT get_the_right_time + + ENDIF + if( num_steps(2) == time_loop_max ) then + wgt_time2 = dat_time + endif + END DO get_the_right_time + + num_steps(2) = MIN(num_steps(2),time_loop_max) + +! wgt0 = (ext_time - wgt_time1) / (wgt_time2 - wgt_time1) + wgt0 = 0. + +! Make sure the right date and time for the chemin data has been found + + write(message,'(A,A20,A,I9)') 'Subroutine input_chem: use_date, num_steps(1) = ',use_date,num_steps(1) + if( num_steps(1) > 0 ) then + write(message,'(A,A)') 'Subroutine input_chem: extracting data at date/time: ',use_date + CALL wrf_message ( TRIM( message ) ) + else + WRITE( wrf_err_message, FMT='(A)' ) 'subroutine input_chem: error finding chemin date/time #2' + CALL WRF_ERROR_FATAL ( wrf_err_message ) + endif + + ! There has to be a more elegant way to get to the beginning of the file, but this will do. + + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + + CALL construct_filename2a (inpname , chgrid%input_chem_inname, chgrid%id , 2, extract_date) + write(message,'(A,A)') 'Subroutine input_chem: Opening data file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + + CALL open_r_dataset ( fid, TRIM(inpname) , chgrid , config_flags , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'subroutine chemin: error opening ',TRIM(inpname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + ! We know how many time periods to process (right now - all of them), we have the input data + ! (re-)opened, so we begin. + + big_time_loop_thingy : DO time_loop = 1 , time_loop_max + + CALL wrf_debug ( 100 , 'input_chem: calling input_history' ) + CALL input_history ( fid , chgrid , config_flags, ierr ) + CALL wrf_debug ( 100 , 'input_chem: back from input_history' ) + + IF( time_loop .EQ. num_steps(1) ) THEN + + ! Get grid dimensions + CALL get_ijk_from_grid ( si_grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ! Get scalar grid point heights + ALLOCATE( si_zsigf(ims:ime,kms:kme,jms:jme) ) + ALLOCATE( ch_zsigf(ims:ime,kms:kme,jms:jme) ) + ALLOCATE( si_zsig(ims:ime,kms:kme,jms:jme) ) + ALLOCATE( ch_zsig(ims:ime,kms:kme,jms:jme) ) +#if ( EM_CORE == 1 ) + si_zsigf = (si_grid%em_ph_1 + si_grid%em_phb) / grav + ch_zsigf = ( chgrid%em_ph_1 + chgrid%em_phb) / grav +#endif + +#if ( NMM_CORE == 1 ) + + ! Get scalar grid point heights + ALLOCATE( pint(ips:ipe,kps:kpe,jps:jpe) ) + ALLOCATE( pdsl(ips:ipe,jps:jpe) ) + + IF(chgrid%sigma.EQ. 1)THEN + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=chgrid%nmm_pd(i,j) + ENDDO + ENDDO + ELSE + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=chgrid%nmm_res(i,j)*chgrid%nmm_pd(i,j) + enddo + enddO + ENDIF +!! +!!!!! SHOULD PINT,Z,W BE REDEFINED IF RESTRT? +! + do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + pint(i,k,j)=si_grid%nmm_eta1(k)*chgrid%nmm_pdtop+si_grid%nmm_eta2(k)*pdsl(i,j)+chgrid%nmm_pt + ch_zsigf(i,k,j)=pint(i,k,j) + ENDDO + ENDDO + ENDDO + + CALL wrf_debug (0, message) + + IF(si_grid%sigma.EQ. 1)THEN + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=si_grid%nmm_pd(i,j) + ENDDO + ENDDO + ELSE + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=si_grid%nmm_res(i,j)*si_grid%nmm_pd(i,j) + enddo + enddO + ENDIF +! write(message,'(1e15.6,i6)') pdsl(ips,jps), si_grid%sigma +!! +!!!!! SHOULD PINT,Z,W BE REDEFINED IF RESTRT? +! + do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + pint(i,k,j)=si_grid%nmm_eta1(k)*si_grid%nmm_pdtop+si_grid%nmm_eta2(k)*pdsl(i,j)+si_grid%nmm_pt +! if (i.EQ. ips .and. j .EQ. jps) then +! print *,k,pint(i,k,j),si_grid%nmm_eta1(k),si_grid%nmm_pdtop,si_grid%nmm_eta2(k),pdsl(i,j),si_grid%nmm_pt +! endif + si_zsigf(i,k,j)=pint(i,k,j) + ENDDO + ENDDO + ENDDO + +! write(message,'(4e15.6)') si_zsigf(1,1:4,1) +! CALL wrf_error_fatal (message) + + DEALLOCATE( pint); DEALLOCATE( pdsl ) +#endif + + + do k=1,kde-1 + si_zsig(:,k,:) = 0.5 * ( si_zsigf(:,k,:) + si_zsigf(:,k+1,:) ) + ch_zsig(:,k,:) = 0.5 * ( ch_zsigf(:,k,:) + ch_zsigf(:,k+1,:) ) + enddo + si_zsig(:,kde,:) = 0.5 * ( 3. * si_zsigf(:,kde,:) - si_zsigf(:,kde-1,:) ) + ch_zsig(:,kde,:) = 0.5 * ( 3. * ch_zsigf(:,kde,:) - ch_zsigf(:,kde-1,:) ) + + ! check size of si_grid vs chgrid + + IF( size(si_grid%chem,1) .NE. ime-ims+1 .OR. & + size(si_grid%chem,2) .NE. kme-kms+1 .OR. & + size(si_grid%chem,3) .NE. jme-jms+1 .OR. & + size(si_grid%chem,4) .NE. num_chem ) then + + CALL wrf_debug (100, ' SI grid dimensions ' ) + write(message,'(4i8.8)') size(si_grid%chem,1),size(si_grid%chem,2), & + size(si_grid%chem,3),size(si_grid%chem,4) + CALL wrf_debug (100, message) + CALL wrf_debug (100, ' Input data dimensions ' ) + write(message,'(4i8.8)') ime-ims+1,kme-kms+1,jme-jms+1,num_chem + CALL wrf_debug (100, message) + write(wrf_err_message,'(A)') 'ERROR IN MODULE_INPUT_CHEM: bad dimensions in input data ' + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + ! Fill top level to prevent spurious interpolation results (no extrapolation) + chgrid%chem(:,kde,:,:) = chgrid%chem(:,kde-1,:,:) + + ! Interpolate the chemistry data to the SI grid (holding place for time interpolation) + + call vinterp_chem(ims, ime, jms, jme, kms, kme, kme, num_chem, ch_zsig, si_zsig, & + chgrid%chem, si_grid%chem, .false.) + + if(wgt0 == 0.) EXIT big_time_loop_thingy + ENDIF + + IF( time_loop .EQ. num_steps(2) ) THEN + +! ! input chemistry sigma levels +! ch_zsigf = ( chgrid%em_ph_1 + chgrid%em_phb) / grav +! do k=1,kde-1 +! ch_zsig(:,k,:) = 0.5 * ( ch_zsigf(:,k,:) + ch_zsigf(:,k+1,:) ) +! enddo +! ch_zsig(:,kde,:) = 0.5 * ( 3. * ch_zsigf(:,kde,:) - ch_zsigf(:,kde-1,:) ) + +! ! Fill top level to prevent spurious interpolation results (no extrapolation) +! chgrid%chem(:,kde,:,:) = chgrid%chem(:,kde-1,:,:) + +! ! Interpolate the chemistry data to the temp chgrid2 structure + +! call vinterp_chem(ims, ime, jms, jme, kms, kme, kme, num_chem, ch_zsig, si_zsig, & +! chgrid%chem, chgrid2%chem, .false.) + +! ! use linear interpolation in time to get new chem arrays +! si_grid%chem = (1. - wgt0) * si_grid%chem + & +! wgt0 * chgrid2%chem + + DEALLOCATE( si_zsigf); DEALLOCATE( si_zsig ) + DEALLOCATE( ch_zsigf); DEALLOCATE( ch_zsig ) + + EXIT big_time_loop_thingy + ENDIF + END DO big_time_loop_thingy + +! Check for errors in chemin data set + + do l=2,num_chem + do j=jds,jde + do k=kds,kde + do i=ids,ide + si_grid%chem(i,k,j,l) = MAX(si_grid%chem(i,k,j,l),epsilc) + enddo + enddo + enddo + enddo + + +! Close chemin data set + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + +! free memory + CALL domain_destroy( chem_grid ) + + CALL wrf_debug ( 100,' input_ext_chem_data: exit subroutine ') + + RETURN + + END SUBROUTINE input_ext_chem_file +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE vinterp_chem(nx1, nx2, ny1, ny2, nz1, nz_in, nz_out, nch, z_in, z_out, & + data_in, data_out, extrapolate) + + ! Interpolates columns of chemistry data from one set of height surfaces to + ! another + + INTEGER, INTENT(IN) :: nx1, nx2 + INTEGER, INTENT(IN) :: ny1, ny2 + INTEGER, INTENT(IN) :: nz1 + INTEGER, INTENT(IN) :: nz_in + INTEGER, INTENT(IN) :: nz_out + INTEGER, INTENT(IN) :: nch + REAL, INTENT(IN) :: z_in (nx1:nx2,nz1:nz_in ,ny1:ny2) + REAL, INTENT(IN) :: z_out(nx1:nx2,nz1:nz_out,ny1:ny2) + REAL, INTENT(IN) :: data_in (nx1:nx2,nz1:nz_in ,ny1:ny2,nch) + REAL, INTENT(OUT) :: data_out(nx1:nx2,nz1:nz_out,ny1:ny2,nch) + LOGICAL, INTENT(IN) :: extrapolate + + INTEGER :: i,j,l + INTEGER :: k,kk + REAL :: desired_z + REAL :: dvaldz + REAL :: wgt0 + +! Loop over the number of chemical species + chem_loop: DO l = 2, nch + + data_out(:,:,:,l) = -99999.9 + + DO j = ny1, ny2 + DO i = nx1, nx2 + + output_loop: DO k = nz1, nz_out +#if ( EM_CORE == 1 ) + + desired_z = z_out(i,k,j) + IF (desired_z .LT. z_in(i,1,j)) THEN + + IF ((desired_z - z_in(i,1,j)).LT. 0.0001) THEN + data_out(i,k,j,l) = data_in(i,1,j,l) + ELSE + IF (extrapolate) THEN + ! Extrapolate downward because desired height level is below + ! the lowest level in our input data. Extrapolate using simple + ! 1st derivative of value with respect to height for the bottom 2 + ! input layers. + + ! Add a check to make sure we are not using the gradient of + ! a very thin layer + + IF ( (z_in(i,1,j) - z_in(i,2,j)) .GT. 0.001) THEN + dvaldz = (data_in(i,1,j,l) - data_in(i,2,j,l)) / & + (z_in(i,1,j) - z_in(i,2,j) ) + ELSE + dvaldz = (data_in(i,1,j,l) - data_in(i,3,j,l)) / & + (z_in(i,1,j) - z_in(i,3,j) ) + ENDIF + data_out(i,k,j,l) = MAX( data_in(i,1,j,l) + & + dvaldz * (desired_z-z_in(i,1,j)), 0.) + ELSE + data_out(i,k,j,l) = data_in(i,1,j,l) + ENDIF + ENDIF + ELSE IF (desired_z .GT. z_in(i,nz_in,j)) THEN + IF ( (z_in(i,nz_in,j) - desired_z) .LT. 0.0001) THEN + data_out(i,k,j,l) = data_in(i,nz_in,j,l) + ELSE + IF (extrapolate) THEN + ! Extrapolate upward + IF ( (z_in(i,nz_in-1,j)-z_in(i,nz_in,j)) .GT. 0.0005) THEN + dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-1,j,l)) / & + (z_in(i,nz_in,j) - z_in(i,nz_in-1,j)) + ELSE + dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-2,j,l)) / & + (z_in(i,nz_in,j) - z_in(i,nz_in-2,j)) + ENDIF + data_out(i,k,j,l) = MAX( data_in(i,nz_in,j,l) + & + dvaldz * (desired_z-z_in(i,nz_in,j)), 0.) + ELSE + data_out(i,k,j,l) = data_in(i,nz_in,j,l) + ENDIF + ENDIF + ELSE + ! We can trap between two levels and linearly interpolate + + input_loop: DO kk = 1, nz_in-1 + IF (desired_z .EQ. z_in(i,kk,j) )THEN + data_out(i,k,j,l) = data_in(i,kk,j,l) + EXIT input_loop + ELSE IF ( (desired_z .GT. z_in(i,kk,j)) .AND. & + (desired_z .LT. z_in(i,kk+1,j)) ) THEN + wgt0 = (desired_z - z_in(i,kk+1,j)) / & + (z_in(i,kk,j)-z_in(i,kk+1,j)) + data_out(i,k,j,l) = MAX( wgt0*data_in(i,kk,j,l) + & + (1.-wgt0)*data_in(i,kk+1,j,l), 0.) + EXIT input_loop + ENDIF + ENDDO input_loop + + ENDIF +#endif +#if ( NMM_CORE == 1 ) + + desired_z = z_out(i,k,j) + IF (desired_z .GT. z_in(i,1,j)) THEN + + IF ((desired_z - z_in(i,1,j)).GT. 0.0001) THEN + data_out(i,k,j,l) = data_in(i,1,j,l) + ELSE + IF (extrapolate) THEN + ! Extrapolate upward because desired pressure level is above + ! the highest level in our input data. Extrapolate using simple + ! 1st derivative of value with respect to height for the bottom 2 + ! input layers. + + ! Add a check to make sure we are not using the gradient of + ! a very thin layer + + IF ( (z_in(i,1,j) - z_in(i,2,j)) .LT. 0.001) THEN + dvaldz = (data_in(i,2,j,l) - data_in(i,1,j,l)) / & + (z_in(i,2,j) - z_in(i,1,j) ) + ELSE + dvaldz = (data_in(i,3,j,l) - data_in(i,1,j,l)) / & + (z_in(i,3,j) - z_in(i,1,j) ) + ENDIF + data_out(i,k,j,l) = MAX( data_in(i,1,j,l) + & + dvaldz * (desired_z-z_in(i,1,j)), 0.) + ELSE + data_out(i,k,j,l) = data_in(i,1,j,l) + ENDIF + ENDIF + ELSE IF (desired_z .LT. z_in(i,nz_in,j)) THEN + IF ( (z_in(i,nz_in,j) - desired_z) .LT. 0.0001) THEN + data_out(i,k,j,l) = data_in(i,nz_in,j,l) + ELSE + IF (extrapolate) THEN + ! Extrapolate upward + IF ( (z_in(i,nz_in-1,j)-z_in(i,nz_in,j)) .LT. 0.0005) THEN + dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-1,j,l)) / & + (z_in(i,nz_in,j) - z_in(i,nz_in-1,j)) + ELSE + dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-2,j,l)) / & + (z_in(i,nz_in,j) - z_in(i,nz_in-2,j)) + ENDIF + data_out(i,k,j,l) = MAX( data_in(i,nz_in,j,l) + & + dvaldz * (z_in(i,nz_in,j) - desired_z), 0.) + ELSE + data_out(i,k,j,l) = data_in(i,nz_in,j,l) + ENDIF + ENDIF + ELSE + ! We can trap between two levels and linearly interpolate + + input_loop: DO kk = 1, nz_in-1 + IF (desired_z .EQ. z_in(i,kk,j) )THEN + data_out(i,k,j,l) = data_in(i,kk,j,l) + EXIT input_loop + ELSE IF ( (desired_z .LT. z_in(i,kk,j)) .AND. & + (desired_z .GT. z_in(i,kk+1,j)) ) THEN + wgt0 = (desired_z - z_in(i,kk+1,j)) / & + (z_in(i,kk,j)-z_in(i,kk+1,j)) + data_out(i,k,j,l) = MAX( wgt0*data_in(i,kk,j,l) + & + (1.-wgt0)*data_in(i,kk+1,j,l), 0.) + EXIT input_loop + ENDIF + ENDDO input_loop + + ENDIF +#endif + ENDDO output_loop + ENDDO + ENDDO + ENDDO chem_loop + + RETURN + END SUBROUTINE vinterp_chem +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SUBROUTINE input_chem_profile (si_grid) + + IMPLICIT NONE + + TYPE(domain) :: si_grid + + INTEGER :: i , j , k, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + INTEGER :: fid, ierr, numgas + INTEGER :: debug_level + + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: si_zsigf, si_zsig + +#if ( ! NMM_CORE == 0 ) + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: pint + REAL, ALLOCATABLE, DIMENSION(:,:) :: pdsl +#endif + + CHARACTER (LEN=80) :: inpname, message + + write(message,'(A)') 'Subroutine input_chem_profile: ' + CALL wrf_message ( TRIM(message) ) + + ! And here is an instance of using the information in the NAMELIST. + + CALL nl_get_debug_level ( 1,debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + ! Get grid dimensions + CALL get_ijk_from_grid ( si_grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ! Get scalar grid point heights + ALLOCATE( si_zsigf(ims:ime,kms:kme,jms:jme) ) + ALLOCATE( si_zsig(ims:ime,kms:kme,jms:jme) ) + +#if ( ! EM_CORE == 0 ) + write(message,'(A)') 'WRF_EM_CORE ' + si_zsigf = (si_grid%em_ph_1 + si_grid%em_phb) / grav +#endif +#if ( ! NMM_CORE == 0 ) + ! Get scalar grid point heights + ALLOCATE( pint(ims:ime,kms:kme,jms:jme) ) + ALLOCATE( pdsl(ims:ime,jms:jme) ) + + write(message,'(A)') 'WRF_NMM_CORE ' + CALL wrf_message ( message ) + + IF(si_grid%sigma.EQ. 1)THEN + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=si_grid%nmm_pd(i,j) + ENDDO + ENDDO + ELSE + do j=jps,jpe + do i=ips,ipe + pdsl(i,j)=si_grid%nmm_res(i,j)*si_grid%nmm_pd(i,j) + enddo + enddO + ENDIF +!! +!!*** +!! +!! +!!!!! SHOULD PINT,Z,W BE REDEFINED IF RESTRT? +! +! print *,' ips=',ips,' ipe=',ipe +! print *,' jps=',jps,' jpe=',jpe +! print *,' kps=',kps,' kpe=',kpe +! print *,' sigma=',si_grid%sigma +! print *,' pdtop=',si_grid%nmm_pdtop,' pt=',si_grid%nmm_pt + + do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + pint(i,k,j)=si_grid%nmm_eta1(k)*si_grid%nmm_pdtop+si_grid%nmm_eta2(k)*pdsl(i,j)+si_grid%nmm_pt + si_zsigf(i,k,j)=pint(i,k,j) + ENDDO + ENDDO + ENDDO +! do k=kps,kpe +! print *,k,pint(1,k,1),si_grid%nmm_eta1(k),si_grid%nmm_pdtop,si_grid%nmm_eta2(k),pdsl(1,1),si_grid%nmm_pt +! enddo +! +! si_zsigf = si_grid%z +#endif + +! si_zsigf = (si_grid%em_ph_1 + si_grid%em_phb) / grav + + do k=1,kde-1 + si_zsig(:,k,:) = 0.5 * ( si_zsigf(:,k,:) + si_zsigf(:,k+1,:) ) + enddo + si_zsig(:,kde,:) = 0.5 * ( 3. * si_zsigf(:,kde,:) - si_zsigf(:,kde-1,:) ) + + ! An alternative ozone profile option for initialization + if( si_grid%gas_ic_opt == GAS_IC_PNNL ) & + call gasprofile_init_pnnl + + ! Determine the index of the last gas species + numgas = get_last_gas(si_grid%chem_opt) + + ! Interpolate the chemistry data to the SI grid. These values should typically + ! be set to match the values in bdy_chem_value_tracer so that the boundaries + ! and interior match each other. + IF ( si_grid%chem_opt == CHEM_TRACER ) THEN + si_grid%chem(ims:ime,kms:kme,jms:jme,1:numgas) = 0.0001 +! si_grid%chem(ims:ime,kms:kme,jms:jme,p_so2) = 0.0001 + si_grid%chem(ims:ime,kms:kme,jms:jme,p_co ) = 0.08 + ELSE + CALL make_chem_profile (ims, ime, jms, jme, kms, kme, num_chem, numgas, & + si_zsig, si_grid%chem) + END IF + + CALL wrf_debug ( 100,' input_chem_profile: exit subroutine ') + + DEALLOCATE( si_zsigf ); DEALLOCATE( si_zsig ) +#if ( ! NMM_CORE == 0 ) + DEALLOCATE( pdsl ); DEALLOCATE( pint ) +#endif + RETURN + + END SUBROUTINE input_chem_profile +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE make_chem_profile ( nx1, nx2, ny1, ny2, nz1, nz2, nch, numgas, & + zgrid, chem ) + IMPLICIT NONE + + INTEGER, INTENT(IN) :: nx1, ny1, nz1 + INTEGER, INTENT(IN) :: nx2, ny2, nz2 + INTEGER, INTENT(IN) :: nch, numgas + !REAL, INTENT(IN), DIMENSION(nx1:nx2,nz1:nz2,ny1:ny2) :: zgrid + REAL, DIMENSION(nx1:nx2,nz1:nz2,ny1:ny2) :: zgrid + + CHARACTER (LEN=80) :: message + INTEGER :: i, j, k, l, is + + REAL, DIMENSION(nx1:nx2,nz1:kx ,ny1:ny2,lo+1):: chprof + REAL, DIMENSION(nx1:nx2,nz1:kx ,ny1:ny2) :: zprof + + REAL, DIMENSION(nx1:nx2,nz1:nz2,ny1:ny2,nch) :: chem + REAL, DIMENSION(nx1:nx2,nz1:nz2,ny1:ny2,lo ) :: stor +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Check the number of species + + if( nch .NE. num_chem) then + message = ' Input_chem_profile: wrong number of chemical species' +! CALL WRF_ERROR_FATAL ( message ) + endif + + ! Vertically flip the chemistry data as it is given top down and + ! heights are bottom up. Fill temp 3D chemical and profile array, + ! keep chem slot 1 open as vinterp_chem assumes there is no data. + DO j=ny1,ny2 + DO k= 1,kx + DO i=nx1,nx2 + chprof(i,k,j,2:lo+1) = xl(1:lo,kx-k+1) + zprof(i,k,j) = 0.5*(zfa(k)+zfa(k+1)) + ENDDO + ENDDO + ENDDO +! +! return xl to previous value for next time... +! 34 chemicals (lo), 16 vertical levels (kx) +! DO i=lo-6,lo +! xl(i,1:kx)=xl(i,1:kx)*dens(1:kx) +! ENDDO + +! Change number concentrations to mixing ratios for short-lived NALROM species + do k=1,kx + chprof(:,k,:,lo-5:lo+1) = chprof(:,k,:,lo-5:lo+1)/dens(k) + end do + + ! Interpolate temp 3D chemical and profile array to WRF grid + call vinterp_chem(nx1, nx2, ny1, ny2, nz1, kx, nz2, lo, zprof, zgrid, & + chprof, chem, .false.) + + ! place interpolated data into temp storage array + stor(nx1:nx2,nz1:nz2,ny1:ny2,1:lo) = chem(nx1:nx2,nz1:nz2,ny1:ny2,2:lo+1) + + ! Here is where the chemistry profile is constructed + !chem(:,:,:,1) = stor(:,:,:,1) * 0. + chem(nx1:nx2,nz1:nz2,ny1:ny2,1) = -999. + +! DO l=2,nch + DO l=2,numgas + is=iref(l-1) + DO j=ny1,ny2 + DO k=nz1,nz2 + DO i=nx1,nx2 + chem(i,k,j,l)=fracref(l-1)*stor(i,k,j,is)*1.E6 + ENDDO + ENDDO + ENDDO + ENDDO + + RETURN + END SUBROUTINE make_chem_profile +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! this is a kludge routine as of now.... +! + SUBROUTINE bdy_chem_value_sorgam (chem, z, nch, config_flags, & + alt,convfac,g) + USE module_data_sorgam + USE module_aerosols_sorgam + IMPLICIT NONE + + REAL, intent(OUT) :: chem + REAL, intent(IN) :: z ! 3D height array + INTEGER, intent(IN) :: nch ! index number of chemical species + REAL, INTENT(IN ) :: alt, convfac + real, INTENT (IN) :: g + TYPE (grid_config_rec_type), intent(in) :: config_flags + + INTEGER :: i, k, l + REAL, DIMENSION(lo+1,1:kx):: cprof ! chemical profile, diff. index order + + REAL, DIMENSION(1:kx):: zprof + REAL, DIMENSION(lo ) :: stor + REAL :: wgt0 + + real :: chemsulf_radm,chem_so4aj,chem_so4ai + real tempfac + REAL :: splitfac + !between gas and aerosol phase + +!factor for splitting initial conc. of SO4 +!3rd moment i-mode [3rd moment/m^3] + REAL :: m3nuc +!3rd MOMENT j-mode [3rd moment/m^3] + REAL :: m3acc +! REAL ESN36 + REAL :: m3cor + DATA splitfac/.98/ + +! +! method for bc calculation is determined by aer_bc_opt +! + if (config_flags%aer_bc_opt == AER_BC_PNNL) then + call sorgam_set_aer_bc_pnnl( chem, z, nch ) + return + else if (config_flags%aer_bc_opt == AER_BC_DEFAULT) then + continue + else + call wrf_error_fatal( & + "bdy_chem_value_sorgam -- unable to parse aer_bc_opt" ) + end if + +! do default calculation of sorgam aerosol bc values + chem=conmin +! tempfac=(t+t0)*((p+pb)/p1000mb)**rcp +! convfac=(p+pb)/rgasuniv/tempfac +! +!--- units for advection.... +! + if(nch.eq.p_nu0)chem=1.e8*alt + if(nch.eq.p_ac0)chem=1.e8*alt + if(nch.eq.p_nh4aj)chem=10.e-5*alt + if(nch.eq.p_nh4ai)chem=10.e-5*alt + if(nch.eq.p_no3aj)chem=10.e-5*alt + if(nch.eq.p_no3ai)chem=10.e-5*alt +! +! recalculate sulf profile for aerosols +! + if ( nch .eq. p_so4aj.or.nch.eq.p_so4ai & + .or.nch .eq. p_nu0 .or.nch.eq.p_ac0 & + .or.nch .eq. p_corn ) then + + ! Vertically flip the chemistry data as it is given top down + ! and heights in zfa are bottom up + ! Fill chemical profile array cprof + ! Keep chem slot 1 open as vinterp_chem assumes there is no data + ! (this isn't really needed in this subr) + ! Convert species 28-34 (lo-6:lo) from (molecules/cm3) to (mol/mol) + DO k = 1,kx + zprof(k) = 0.5*(zfa_bdy(k)+zfa_bdy(k+1)) + DO l = 1,lo-7 + cprof(l+1,k) = xl(l,kx+1-k) + END DO +! Fix number concentrations to mixing ratios for short-lived NALROM species + DO l = lo-6,lo + cprof(l+1,k) = xl(l,kx+1-k)/dens(kx+1-k) + ENDDO + ENDDO + + ! Interpolate temp 1D chemical profile array to WRF field + IF (z .LT. zprof(1)) THEN + stor(1:lo) = cprof(2:lo+1,1) + ELSE IF (z .GT. zprof(kx)) THEN + stor(1:lo) = cprof(2:lo+1,kx) + ELSE + ! We can trap between two levels and linearly interpolate + input_loop: DO k = 1, kx-1 + IF (z .EQ. zprof(k) )THEN + stor(1:lo) = cprof(2:lo+1,k) + EXIT input_loop + ELSE IF ( (z .GT. zprof(k)) .AND. & + (z .LT. zprof(k+1)) ) THEN + wgt0 = (z - zprof(k+1)) / & + (zprof(k) - zprof(k+1)) + stor(1:lo) = MAX( wgt0 *cprof(2:lo+1,k ) + & + (1.-wgt0)*cprof(2:lo+1,k+1), 0.) + EXIT input_loop + ENDIF + ENDDO input_loop + ENDIF + + ! Here is where the chemistry value is constructed + chemsulf_radm = fracref(p_sulf-1)*stor( iref(p_sulf-1) )*1.E6 +! +! now have sulf +! + chem_so4aj=chemsulf_radm*CONVFAC*MWSO4*splitfac*so4vaptoaer + chem_so4ai=chemsulf_radm*CONVFAC*MWSO4*(1.-splitfac)*so4vaptoaer + if(nch.eq.p_so4aj)chem=chem_so4aj*alt + if(nch.eq.p_so4ai)chem=chem_so4ai*alt + m3nuc=so4fac*chem_so4ai+conmin*(nh4fac+no3fac+orgfac*9+2*anthfac) + m3acc=so4fac*chem_so4aj+conmin*(nh4fac+no3fac+orgfac*9+2*anthfac) + m3cor=conmin*(soilfac+seasfac+anthfac) +! +! compute values for aerosol input data +! + if(nch.eq.p_nu0.or.nch.eq.p_ac0.or.nch.eq.p_corn)then + xxlsgn = log(sginin) + xxlsga = log(sginia) + xxlsgc = log(sginic) + + l2sginin = xxlsgn**2 + l2sginia = xxlsga**2 + l2sginic = xxlsgc**2 + + en1 = exp(0.125*l2sginin) + ea1 = exp(0.125*l2sginia) + ec1 = exp(0.125*l2sginic) + + + esn04 = en1**4 + esa04 = ea1**4 + esc04 = ec1**4 + + esn05 = esn04*en1 + esa05 = esa04*ea1 + + esn08 = esn04*esn04 + esa08 = esa04*esa04 + esc08 = esc04*esc04 + + esn09 = esn04*esn05 + esa09 = esa04*esa05 + + esn12 = esn04*esn04*esn04 + esa12 = esa04*esa04*esa04 + esc12 = esc04*esc04*esc04 + + esn16 = esn08*esn08 + esa16 = esa08*esa08 + esc16 = esc08*esc08 + + esn20 = esn16*esn04 + esa20 = esa16*esa04 + esc20 = esc16*esc04 + + esn24 = esn12*esn12 + esa24 = esa12*esa12 + esc24 = esc12*esc12 + + esn25 = esn16*esn09 + esa25 = esa16*esa09 + + esn28 = esn20*esn08 + esa28 = esa20*esa08 + esc28 = esc20*esc08 + + + esn32 = esn16*esn16 + esa32 = esa16*esa16 + esc32 = esc16*esc16 + + esn36 = esn16*esn20 + esa36 = esa16*esa20 + esc36 = esc16*esc20 + endif +! +! Units are something like number concentration +! + if(nch.eq.p_nu0)chem=m3nuc/((dginin**3)*esn36)*alt + if(nch.eq.p_ac0)chem=m3acc/((dginia**3)*esa36)*alt + if(nch.eq.p_corn)chem=m3cor/((dginic**3)*esc36)*alt + endif + + + END SUBROUTINE bdy_chem_value_sorgam + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE bdy_chem_value_tracer ( chem, nch ) + +! This subroutine is called to set the boundary values of chemistry +! species when chem_opt==CHEM_TRACER. Typically, the boundary values +! here should be set to match those in input_chem_profile so that the +! interior and boundary values are the same. +! William.Gustafson@pnl.gov; 16-Jun-2005 + + IMPLICIT NONE + + REAL, intent(OUT) :: chem + INTEGER, intent(IN) :: nch ! index number of chemical species +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if( nch .ne. p_co ) then + chem = 0.0001 + else if( nch == p_co ) then + chem = 0.08 + else + chem = conmin + end if + + END SUBROUTINE bdy_chem_value_tracer +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE bdy_chem_value_racm ( chem, z, nch, numgas,p_co2 ) + + IMPLICIT NONE + + REAL, intent(OUT) :: chem + REAL, intent(IN) :: z ! 3D height array + INTEGER, intent(IN) :: nch,p_co2 ! index number of chemical species + INTEGER, intent(IN) :: numgas ! index number of last gas species + + INTEGER :: i, k, irefcur + + REAL, DIMENSION(kx):: cprof ! chemical profile, diff. index order + + REAL, DIMENSION(1:kx):: zprof + REAL :: stor + REAL :: wgt0 + + CHARACTER (LEN=80) :: message +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Check the number of species +! if((nch-1).gt.logg)return + if (nch.eq.p_co2)then + chem=370. + return + endif + if (nch.eq.p_co2+1)then + chem=1.7 + return + endif + if (nch.ge.p_co2+2)return + + +! if( nch .GT. logg+1) then + if( nch .GT. numgas) then + message = ' Input_chem_profile: wrong number of chemical species' + return +! CALL WRF_ERROR_FATAL ( message ) + endif + + ! Vertically flip the chemistry data as it is given top down + ! and heights in zfa are bottom up + ! Fill 1D chemical profile array cprof + ! Convert species 28-34 (lo-6:lo) from (molecules/cm3) to (mol/mol) + irefcur = iref(nch-1) + DO k = 1,kx + zprof(k) = 0.5*(zfa_bdy(k)+zfa_bdy(k+1)) + if (irefcur .lt. lo-6) then + cprof(k) = xl(irefcur,kx+1-k) + else + cprof(k) = xl(irefcur,kx+1-k)/dens(kx+1-k) + end if + ENDDO + + ! Interpolate temp 3D chemical profile array to WRF field + IF (z .LT. zprof(1)) THEN + stor = cprof(1) + ELSE IF (z .GT. zprof(kx)) THEN + stor = cprof(kx) + ELSE + ! We can trap between two levels and linearly interpolate + input_loop: DO k = 1, kx-1 + IF (z .EQ. zprof(k) )THEN + stor = cprof(k) + EXIT input_loop + ELSE IF ( (z .GT. zprof(k)) .AND. & + (z .LT. zprof(k+1)) ) THEN + wgt0 = (z - zprof(k+1)) / & + (zprof(k) - zprof(k+1)) + stor = MAX( wgt0 *cprof(k ) + & + (1.-wgt0)*cprof(k+1), 0.) + EXIT input_loop + ENDIF + ENDDO input_loop + ENDIF + + ! Here is where the chemistry value is constructed + chem = fracref(nch-1)*stor*1.E6 + + ! special code for sulfate/h2so4 + if(nch.eq.p_sulf.and.p_nu0.gt.1)then + chem=chem*(1.-so4vaptoaer) + endif + + RETURN + END SUBROUTINE bdy_chem_value_racm + SUBROUTINE bdy_chem_value ( chem, z, nch, numgas ) + + IMPLICIT NONE + + REAL, intent(OUT) :: chem + REAL, intent(IN) :: z ! 3D height array + INTEGER, intent(IN) :: nch ! index number of chemical species + INTEGER, intent(IN) :: numgas ! index number of last gas species + + INTEGER :: i, k, irefcur + + REAL, DIMENSION(kx):: cprof ! chemical profile, diff. index order + + REAL, DIMENSION(1:kx):: zprof + REAL :: stor + REAL :: wgt0 + + CHARACTER (LEN=80) :: message +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Check the number of species +! if((nch-1).gt.logg)return + +! if( nch .GT. logg+1) then + if( nch .GT. numgas) then + message = ' Input_chem_profile: wrong number of chemical species' + return +! CALL WRF_ERROR_FATAL ( message ) + endif + + ! Vertically flip the chemistry data as it is given top down + ! and heights in zfa are bottom up + ! Fill 1D chemical profile array cprof + ! Convert species 28-34 (lo-6:lo) from (molecules/cm3) to (mol/mol) + irefcur = iref(nch-1) + DO k = 1,kx + zprof(k) = 0.5*(zfa_bdy(k)+zfa_bdy(k+1)) + if (irefcur .lt. lo-6) then + cprof(k) = xl(irefcur,kx+1-k) + else + cprof(k) = xl(irefcur,kx+1-k)/dens(kx+1-k) + end if + ENDDO + + ! Interpolate temp 3D chemical profile array to WRF field + IF (z .LT. zprof(1)) THEN + stor = cprof(1) + ELSE IF (z .GT. zprof(kx)) THEN + stor = cprof(kx) + ELSE + ! We can trap between two levels and linearly interpolate + input_loop: DO k = 1, kx-1 + IF (z .EQ. zprof(k) )THEN + stor = cprof(k) + EXIT input_loop + ELSE IF ( (z .GT. zprof(k)) .AND. & + (z .LT. zprof(k+1)) ) THEN + wgt0 = (z - zprof(k+1)) / & + (zprof(k) - zprof(k+1)) + stor = MAX( wgt0 *cprof(k ) + & + (1.-wgt0)*cprof(k+1), 0.) + EXIT input_loop + ENDIF + ENDDO input_loop + ENDIF + + ! Here is where the chemistry value is constructed + chem = fracref(nch-1)*stor*1.E6 + + ! special code for sulfate/h2so4 + if(nch.eq.p_sulf.and.p_nu0.gt.1)then + chem=chem*(1.-so4vaptoaer) + endif + + RETURN + END SUBROUTINE bdy_chem_value +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#if (EM_CORE == 1 ) + SUBROUTINE flow_dep_bdy_chem ( chem, & + chem_bxs,chem_btxs, & + chem_bxe,chem_btxe, & + chem_bys,chem_btys, & + chem_bye,chem_btye, & + dt, & + spec_bdy_width,z, & + have_bcs_chem, & + u, v, config_flags, alt, & + t,pb,p,t0,p1000mb,rcp,ph,phb,g, & + spec_zone, ic, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets zero gradient conditions for outflow and a set profile value +! for inflow in the boundary specified region. Note that field must be unstaggered. +! The velocities, u and v, will only be used to check their sign (coupled vels OK) +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone,spec_bdy_width,ic + REAL, INTENT(IN ) :: dt + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: chem + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width), INTENT(IN ) :: chem_bxs, chem_bxe, chem_btxs, chem_btxe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width), INTENT(IN ) :: chem_bys, chem_bye, chem_btys, chem_btye + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: z + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: alt + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + ph,phb,t,pb,p + real, INTENT (IN) :: g,rcp,t0,p1000mb + TYPE( grid_config_rec_type ) config_flags + + INTEGER :: i, j, k, numgas + INTEGER :: ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: i_inner, j_inner + INTEGER :: b_dist + integer :: itestbc, i_bdy_method + real tempfac,convfac + real :: chem_bv_def + logical :: have_bcs_chem + + chem_bv_def = conmin + numgas = get_last_gas(config_flags%chem_opt) + itestbc=0 + if(p_nu0.gt.1)itestbc=1 + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + +! i_bdy_method determines which "bdy_chem_value" routine to use +! 1=radm2 or racm gas for p_so2 <= ic <= p_ho2 +! 2=sorgam aerosol for p_so4aj <= ic <= p_corn +! 3=cbmz gas for p_hcl <= ic <= p_isopo2 +! OR p_dms <= ic <= p_mtf +! 4=mosaic aerosol for p_so4_a01 <= ic <= p_num_a01 +! OR p_so4_a02 <= ic <= p_num_a02 +! OR ... +! 5=tracer mode +! 0=none for all other ic values +! (note: some cbmz packages use dms,...,mtf while others do not) +! (note: different mosaic packages use different number of sections) + i_bdy_method = 0 + if ((ic .ge. p_so2) .and. (ic .le. p_ho2)) then + i_bdy_method = 1 + + if (config_flags%chem_opt == RACM_KPP .or. & + config_flags%chem_opt == RACMSORG_KPP .or. & + config_flags%chem_opt == RACM_MIM_KPP .or. & + config_flags%chem_opt == RACMSORG_KPP ) then + i_bdy_method = 9 + end if + + + else if ((ic .ge. p_so4aj) .and. (ic .le. p_corn)) then + i_bdy_method = 2 + else if ((ic .ge. p_hcl) .and. (ic .le. p_isopo2)) then + i_bdy_method = 3 + else if ((ic .ge. p_dms) .and. (ic .le. p_mtf)) then + i_bdy_method = 3 + else if ((ic .ge. p_so4_a01) .and. (ic .le. p_num_a01)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a02) .and. (ic .le. p_num_a02)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a03) .and. (ic .le. p_num_a03)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a04) .and. (ic .le. p_num_a04)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a05) .and. (ic .le. p_num_a05)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a06) .and. (ic .le. p_num_a06)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a07) .and. (ic .le. p_num_a07)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a08) .and. (ic .le. p_num_a08)) then + i_bdy_method = 4 + else if (config_flags%chem_opt == CHEM_TRACER) then + i_bdy_method = 5 + end if + if (have_bcs_chem) i_bdy_method =6 + if (ic .lt. param_first_scalar) i_bdy_method = 0 + +!---------------------------------------------------------------------- +! if (i_bdy_method .eq. 1) then +! print 90010, '_bdy_radm2 for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 2) then +! print 90010, '_bdy_sorgam for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 3) then +! print 90010, '_bdy_cbmz for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 4) then +! print 90010, '_bdy_mosaic for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 5) then +! print 90010, '_bdy_tracer for ic=', ic, i_bdy_method +! else +! print 90010, '_bdy_NONE** for ic=', ic, i_bdy_method +! end if +!90010 format( a, 2(1x,i5) ) +!90020 format( a, 1p, 2e12.2 ) +!---------------------------------------------------------------------- + +! if(ic.eq.p_O3)THEN +! write(0,*)'in flow_chem ',jts,jbs,spec_zone +! write(0,*)'in flow_chem ',its,ibs,b_dist,i_bdy_method,ic +! endif + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + DO k = kts, ktf + DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(v(i,k,j) .lt. 0.)THEN + chem(i,k,j) = chem(i_inner,k,jbs+spec_zone) +! if(j.eq.jts+1.and.k.eq.kts.and.ic.eq.p_o3)then +! write(0,*)'Yflow',i,j,k,i_bdy_method +! write(0,*)chem(i_inner,k,jbs+spec_zone),v(i,k,j) +! endif + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, config_flags, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_bys(i,k,1),chem_btys(i,k,1),dt,ic) +! if(k.eq.kts.and.ic.eq.p_o3)then +! write(0,*)'Ygcm',i,j,k,i_bdy_method +! write(0,*)chem(i,k,j),chem_bys(i,k,1),chem_btys(i,k,1),dt +! endif + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + DO k = kts, ktf + DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(v(i,k,j+1) .gt. 0.)THEN + chem(i,k,j) = chem(i_inner,k,jbe-spec_zone) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, config_flags, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_bye(i,k,1),chem_btye(i,k,1),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i,k,j) .lt. 0.)THEN + chem(i,k,j) = chem(ibs+spec_zone,k,j_inner) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, config_flags, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_bxs(i,k,1),chem_btxs(i,k,1),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i+1,k,j) .gt. 0.)THEN + chem(i,k,j) = chem(ibe-spec_zone,k,j_inner) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, config_flags,numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_bxe(i,k,1),chem_btxe(i,k,1),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE flow_dep_bdy_chem +#else + SUBROUTINE flow_dep_bdy_chem ( chem, chem_b,chem_bt,dt, & + spec_bdy_width,z, & + ijds, ijde,have_bcs_chem, & + u, v, config_flags, alt, & + t,pb,p,t0,p1000mb,rcp,ph,phb,g, & + spec_zone, ic, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets zero gradient conditions for outflow and a set profile value +! for inflow in the boundary specified region. Note that field must be unstaggered. +! The velocities, u and v, will only be used to check their sign (coupled vels OK) +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: ijds,ijde + INTEGER, INTENT(IN ) :: spec_zone,spec_bdy_width,ic + REAL, INTENT(IN ) :: dt + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: chem + REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: chem_b + REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: chem_bt + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: z + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: alt + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + ph,phb,t,pb,p + real, INTENT (IN) :: g,rcp,t0,p1000mb + TYPE( grid_config_rec_type ) config_flags + + INTEGER :: i, j, k, numgas + INTEGER :: ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: i_inner, j_inner + INTEGER :: b_dist + integer :: itestbc, i_bdy_method + real tempfac,convfac + real :: chem_bv_def + logical :: have_bcs_chem + + chem_bv_def = conmin + numgas = get_last_gas(config_flags%chem_opt) + itestbc=0 + if(p_nu0.gt.1)itestbc=1 + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + +! i_bdy_method determines which "bdy_chem_value" routine to use +! 1=radm2 or racm gas for p_so2 <= ic <= p_ho2 +! 2=sorgam aerosol for p_so4aj <= ic <= p_corn +! 3=cbmz gas for p_hcl <= ic <= p_isopo2 +! OR p_dms <= ic <= p_mtf +! 4=mosaic aerosol for p_so4_a01 <= ic <= p_num_a01 +! OR p_so4_a02 <= ic <= p_num_a02 +! OR ... +! 5=tracer mode +! 0=none for all other ic values +! (note: some cbmz packages use dms,...,mtf while others do not) +! (note: different mosaic packages use different number of sections) + i_bdy_method = 0 + if ((ic .ge. p_so2) .and. (ic .le. p_ho2)) then + i_bdy_method = 1 + + if (config_flags%chem_opt == RACM_KPP .or. & + config_flags%chem_opt == RACMSORG_KPP .or. & + config_flags%chem_opt == RACM_MIM_KPP .or. & + config_flags%chem_opt == RACMSORG_KPP ) then + i_bdy_method = 9 + end if + + + else if ((ic .ge. p_so4aj) .and. (ic .le. p_corn)) then + i_bdy_method = 2 + else if ((ic .ge. p_hcl) .and. (ic .le. p_isopo2)) then + i_bdy_method = 3 + else if ((ic .ge. p_dms) .and. (ic .le. p_mtf)) then + i_bdy_method = 3 + else if ((ic .ge. p_so4_a01) .and. (ic .le. p_num_a01)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a02) .and. (ic .le. p_num_a02)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a03) .and. (ic .le. p_num_a03)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a04) .and. (ic .le. p_num_a04)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a05) .and. (ic .le. p_num_a05)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a06) .and. (ic .le. p_num_a06)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a07) .and. (ic .le. p_num_a07)) then + i_bdy_method = 4 + else if ((ic .ge. p_so4_a08) .and. (ic .le. p_num_a08)) then + i_bdy_method = 4 + else if (config_flags%chem_opt == CHEM_TRACER) then + i_bdy_method = 5 + end if + if (have_bcs_chem) i_bdy_method =6 + if (ic .lt. param_first_scalar) i_bdy_method = 0 + +!---------------------------------------------------------------------- +! if (i_bdy_method .eq. 1) then +! print 90010, '_bdy_radm2 for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 2) then +! print 90010, '_bdy_sorgam for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 3) then +! print 90010, '_bdy_cbmz for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 4) then +! print 90010, '_bdy_mosaic for ic=', ic, i_bdy_method +! else if (i_bdy_method .eq. 5) then +! print 90010, '_bdy_tracer for ic=', ic, i_bdy_method +! else +! print 90010, '_bdy_NONE** for ic=', ic, i_bdy_method +! end if +!90010 format( a, 2(1x,i5) ) +!90020 format( a, 1p, 2e12.2 ) +!---------------------------------------------------------------------- + +! if(ic.eq.p_O3)THEN +! write(0,*)'in flow_chem ',jts,jbs,spec_zone +! write(0,*)'in flow_chem ',its,ibs,b_dist,i_bdy_method,ic +! endif + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + DO k = kts, ktf + DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(v(i,k,j) .lt. 0.)THEN + chem(i,k,j) = chem(i_inner,k,jbs+spec_zone) +! if(j.eq.jts+1.and.k.eq.kts.and.ic.eq.p_o3)then +! write(0,*)'Yflow',i,j,k,i_bdy_method +! write(0,*)chem(i_inner,k,jbs+spec_zone),v(i,k,j) +! endif + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_YSB),chem_bt(i,k,1,P_YSB),dt,ic) +! if(k.eq.kts.and.ic.eq.p_o3)then +! write(0,*)'Ygcm',i,j,k,i_bdy_method +! write(0,*)chem(i,k,j),chem_b(i,k,1,P_YSB),chem_bt(i,k,1,P_YSB),dt +! endif + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + DO k = kts, ktf + DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(v(i,k,j+1) .gt. 0.)THEN + chem(i,k,j) = chem(i_inner,k,jbe-spec_zone) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_YEB),chem_bt(i,k,1,P_YEB),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i,k,j) .lt. 0.)THEN + chem(i,k,j) = chem(ibs+spec_zone,k,j_inner) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_XSB),chem_bt(i,k,1,P_XSB),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i+1,k,j) .gt. 0.)THEN + chem(i,k,j) = chem(ibe-spec_zone,k,j_inner) + ELSE + if (i_bdy_method .eq. 1) then + CALL bdy_chem_value ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 9) then + CALL bdy_chem_value_racm ( & + chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) + else if (i_bdy_method .eq. 2) then + tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp + convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac + CALL bdy_chem_value_sorgam ( & + chem(i,k,j), z(i,k,j), ic, config_flags, & + alt(i,k,j),convfac,g) + else if (i_bdy_method .eq. 3) then + CALL bdy_chem_value_cbmz ( & + chem(i,k,j), z(i,k,j), ic, numgas ) + else if (i_bdy_method .eq. 4) then + CALL bdy_chem_value_mosaic ( & + chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) + else if (i_bdy_method .eq. 5) then + CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 6) then + CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_XEB),chem_bt(i,k,1,P_XEB),dt,ic) + else + chem(i,k,j) = chem_bv_def + endif + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE flow_dep_bdy_chem +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE bdy_chem_value_gcm ( chem, chem_b, chem_bt, dt,ic) + + IMPLICIT NONE + + REAL, intent(OUT) :: chem + REAL, intent(IN) :: chem_b + REAL, intent(IN) :: chem_bt + REAL, intent(IN) :: dt + INTEGER, intent(IN) :: ic + + + CHARACTER (LEN=80) :: message +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! if( nch .GT. numgas) then +! message = ' Input_chem_profile: wrong number of chemical species' +! return +! CALL WRF_ERROR_FATAL ( message ) +! endif + + + !print*,'before',chem,chem_bt ,dt, ic + + chem=max(epsilc,chem_b + chem_bt * dt) + !print*,'after',chem + RETURN + END SUBROUTINE bdy_chem_value_gcm +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE cv_mmdd_jday ( YY, MM, DD, JDAY) +! +! Subroutine to compute the julian day given the month and day +! +! + INTEGER, INTENT(IN ) :: YY, MM, DD + INTEGER, INTENT(OUT) :: JDAY + + INTEGER, DIMENSION(12) :: imon, imon_a + INTEGER :: i + + DATA imon_a /0,31,59,90,120,151,181,212,243,273,304,334/ +! +!..... Check for leap year. +! + do i=1,12 + imon(i) = imon_a(i) + enddo + if(YY .eq. (YY/4)*4) then + do i=3,12 + imon(i) = imon(i) + 1 + enddo + endif +! +!..... Convert month, day to julian day. +! + jday = imon(mm) + dd + + + END SUBROUTINE cv_mmdd_jday + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer FUNCTION get_last_gas(chem_opt) + implicit none + integer, intent(in) :: chem_opt + + ! Determine the index of the last gas species, which depends + ! upon the gas mechanism. + + select case (chem_opt) + case (0) + get_last_gas = 0 + case (RADM2,RADM2_KPP,RADM2SORG,RADM2SORG_KPP,RACM,RACMSORG,RACM_KPP,RACMSORG_KPP, RACM_MIM_KPP, RADM2SORG_AQ,RACMSORG_AQ) + get_last_gas = p_ho2 + + case (CBMZ) + get_last_gas = p_mtf + + case (CBMZ_BB,CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ) + get_last_gas = p_isopo2 + + case (CHEM_TRACER) + get_last_gas = p_co + + case default + call wrf_error_fatal("get_last_gas: could not decipher chem_opt value") + + end select + + END FUNCTION get_last_gas +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!**************************************************************** +! * +! SUBROUTINE TO SET AEROSOL BC VALUES USING THE * +! aer_bc_opt == aer_bc_pnnl OPTION. * +! * +! wig 22-Apr-2004, original routine * +! rce 25-apr-2004 - changed name to * +! "sorgam_set_aer_bc_pnnl" * +! wig 7-May-2004, added height dependance * +! * +! CALLS THE FOLLOWING SUBROUTINES: NONE * +! * +! CALLED BY: bdy_chem_value_sorgam * +! * +!**************************************************************** + SUBROUTINE sorgam_set_aer_bc_pnnl( chem, z, nch ) + USE module_data_sorgam + implicit none + + INTEGER,INTENT(IN ) :: nch + real,intent(in ) :: z + REAL,INTENT(INOUT ) :: chem + + REAL :: mult, & + m3acc, m3cor, m3nuc, & + bv_so4ai, bv_so4aj, & + bv_nh4ai, bv_nh4aj, & + bv_no3ai, bv_no3aj, & + bv_eci, bv_ecj, & + bv_p25i, bv_p25j, & + bv_orgpai,bv_orgpaj, & + bv_antha, bv_seas, bv_soila + +! +! Determine height multiplier... +! This should mimic the calculation in sorgam_init_aer_ic_pnnl, +! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic +!!$! Height(m) Multiplier +!!$! --------- ---------- +!!$! <=2000 1.0 +!!$! 2000=5000 0.25 +!!$! +!!$! which translates to: +!!$! 2000 2000. & +!!$ .and. z <= 3000. ) then +!!$ mult = 1.0 - 0.0005*(z-2000.) +!!$ elseif( z > 3000. & +!!$ .and. z <= 5000. ) then +!!$ mult = 0.5 - 1.25e-4*(z-3000.) +!!$ else +!!$ mult = 0.25 +!!$ end if +! Updated aerosol profile multiplier 1-Apr-2005: +! Height(m) Multiplier +! --------- ---------- +! <=2000 1.0 +! 2000=5000 0.125 +! +! which translates to: +! 2000 2000. & + .and. z <= 3000. ) then + mult = 1.0 - 0.00075*(z-2000.) + elseif( z > 3000. & + .and. z <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(z-3000.) + else + mult = 0.125 + end if + +! These should match what is in sorgam_init_aer_ic_pnnl. +! Boundary values as of 2-Dec-2004: + bv_so4aj = mult*2.375 + bv_so4ai = mult*0.179 + bv_nh4aj = mult*0.9604 + bv_nh4ai = mult*0.0196 + bv_no3aj = mult*0.0650 + bv_no3ai = mult*0.0050 + bv_ecj = mult*0.1630 + bv_eci = mult*0.0120 + bv_p25j = mult*0.6350 + bv_p25i = mult*0.0490 + bv_orgpaj = mult*0.9300 + bv_orgpai = mult*0.0700 + bv_antha = mult*2.2970 + bv_seas = mult*0.2290 + bv_soila = conmin + +! m3... calculations should match the very end of module_aerosols_sorgam.F +!... i-mode (note that the 8 SOA species have bv=conmin) + m3nuc = so4fac*bv_so4ai + nh4fac*bv_nh4ai + & + no3fac*bv_no3ai + & + orgfac*8.0*conmin + orgfac*bv_orgpai + & + anthfac*bv_p25i + anthfac*bv_eci + +!... j-mode (note that the 8 SOA species have bv=conmin) + m3acc = so4fac*bv_so4aj + nh4fac*bv_nh4aj + & + no3fac*bv_no3aj + & + orgfac*8.0*conmin + orgfac*bv_orgpaj + & + anthfac*bv_p25j + anthfac*bv_ecj + +!...c-mode + m3cor = soilfac*bv_soila + seasfac*bv_seas + & + anthfac*bv_antha + +! Cannot set_sulf here because it is a "radm2" species whose bc value +! is set via bdy_chem_value. Instead, xl(iref(p_sulf-1),:) is set to +! the value conmin in subroutine gasprofile_init_pnnl +! if( nch == p_sulf ) chem = conmin !as per rce's 0 recommendation + + if( nch == p_so4aj ) chem = bv_so4aj + if( nch == p_so4ai ) chem = bv_so4ai + if( nch == p_nh4aj ) chem = bv_nh4aj + if( nch == p_nh4ai ) chem = bv_nh4ai + if( nch == p_no3aj ) chem = bv_no3aj + if( nch == p_no3ai ) chem = bv_no3ai + if( nch == p_ecj ) chem = bv_ecj + if( nch == p_eci ) chem = bv_eci + if( nch == p_p25j ) chem = bv_p25j + if( nch == p_p25i ) chem = bv_p25i + if( nch == p_orgpaj ) chem = bv_orgpaj + if( nch == p_orgpai ) chem = bv_orgpai + + if( nch == p_orgaro1j) chem = conmin + if( nch == p_orgaro1i) chem = conmin + if( nch == p_orgaro2j) chem = conmin + if( nch == p_orgaro2i) chem = conmin + if( nch == p_orgalk1j) chem = conmin + if( nch == p_orgalk1i) chem = conmin + if( nch == p_orgole1j) chem = conmin + if( nch == p_orgole1i) chem = conmin + if( nch == p_orgba1j ) chem = conmin + if( nch == p_orgba1i ) chem = conmin + if( nch == p_orgba2j ) chem = conmin + if( nch == p_orgba2i ) chem = conmin + if( nch == p_orgba3j ) chem = conmin + if( nch == p_orgba3i ) chem = conmin + if( nch == p_orgba4j ) chem = conmin + if( nch == p_orgba4i ) chem = conmin + + if( nch == p_antha ) chem = bv_antha + if( nch == p_soila ) chem = bv_soila + if( nch == p_seas ) chem = bv_seas + + if( nch == p_nu0 ) chem = m3nuc/((dginin**3)*esn36) + if( nch == p_ac0 ) chem = m3acc/((dginia**3)*esa36) + if( nch == p_corn ) chem = m3cor/((dginic**3)*esc36) + + END SUBROUTINE sorgam_set_aer_bc_pnnl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!**************************************************************** +! * +! SUBROUTINE TO OVERWRITE THE PREDEFINED OZONE PROFILE * +! WHEN gas_ic_opt == gas_ic_pnnl * +! OR gas_bc_opt == gas_bc_pnnl * +! * +! wig, 21-Apr-2004 * +! rce 25-apr-2004 - changed name to * +! "gasprofile_init_pnnl" * +! * +! CALLS THE FOLLOWING SUBROUTINES: NONE * +! * +! CALLED BY: chem_init * +! input_chem_profile * +! * +!**************************************************************** + SUBROUTINE gasprofile_init_pnnl + use module_data_sorgam,only: conmin + implicit none + integer :: k + + call wrf_debug ( 500 , 'wrfchem:gasprofile_init_pnnl' ) +! print*,'gasprofile_init_pnnl redefining o3 and sulf profiles.' + +! Original O3 profile values: +! / 1.68E-07, 1.68E-07, 5.79E-08, 5.24E-08, 5.26E-08, & +! 5.16E-08, 4.83E-08, 4.50E-08, 4.16E-08, 3.80E-08, 3.56E-08, & +! 3.35E-08, 3.15E-08, 3.08E-08, 3.06E-08, 3.00E-08/ + +! Note that heights associated with 2nd index of xl correspond to upside-down +! zfa values that have been "de-staggered". +! Height = 0.5*(zfa(1:kx) + zfa(2:kx+1)) and then flipped: +! / 18500., 14050., 11150., 9355., 7705., 6120., 4675., 3430., +! 2430., 1720., 1195., 781.5, 494., 298.5, 148.5, 42.5 + + if( p_o3 > 1 ) then +#if (CASENAME == 0) + !Rounded to closest level: + xl(iref(p_o3-1),11:16) = 4.00e-8 !40 ppbv below 1 km + xl(iref(p_o3-1),3:10) = 6.50e-8 !65 ppbv > 2 km and < stratosphere + ! Changed from 70 ppbv 1-Apr-2005 +#endif +#if (CASENAME == 1) + xl(iref(p_o3-1),11:16) = 3.50e-8 !35 ppbv below 1 km + xl(iref(p_o3-1),3:10) = 6.00e-8 !60 ppbv > 2 km and < stratosphere +#endif + end if + +#if (CASENAME == 1) +! so2 profile based on mirage 2 output, used for neaqs case, 7-20-05 egc +! decreased by one magnitude, 27-oct-2005 wig + if( p_so2 > 1 ) then + xl(iref(p_so2-1), 1:2) = 0.035e-10 + xl(iref(p_so2-1), 3) = 0.081e-10 + xl(iref(p_so2-1), 4:8) = 0.10e-10 + xl(iref(p_so2-1), 9) = 0.60e-10 + xl(iref(p_so2-1), 10) = 1.1e-10 + xl(iref(p_so2-1), 11) = 1.46e-10 + xl(iref(p_so2-1), 12) = 1.74e-10 + xl(iref(p_so2-1), 13) = 1.94e-10 + xl(iref(p_so2-1), 14) = 2.80e-10 + xl(iref(p_so2-1), 15:16) = 3.0e-10 + end if +#endif + + if( p_sulf > 1 ) then + xl(iref(p_sulf-1),:) = conmin + end if + + end SUBROUTINE gasprofile_init_pnnl + +#ifdef CHEM_DBG_I +!----------------------------------------------------------------------- +subroutine chem_dbg(i,j,k,dtstep,itimestep, & + dz8w,t_phy,p_phy,rho_phy,chem, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3, & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_no2,e_ch3oh,e_c2h5oh,e_iso, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kemit, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_n2o5, & + ph_o2 ) + + IMPLICIT NONE + INTEGER, INTENT(IN ) :: i,j,k, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kemit + real, intent(in ) :: dtstep + integer, intent(in ) :: itimestep + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: dz8w,t_phy,p_phy,rho_phy + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), & + INTENT(IN ) :: & + e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt, & + e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_pm25,e_pm10,e_nh3, & + e_no2,e_ch3oh,e_c2h5oh,e_iso, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ), OPTIONAL :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_n2o5, & + ph_o2 + + integer :: n + real :: conva,convg + + print*,"itimestep =",itimestep + + print*,"MET DATA AT (i,k,j):",i,k,j + print*,"t_phy,p_phy,rho_phy=",t_phy(i,k,j),p_phy(i,k,j),rho_phy(i,k,j) + + if(dz8w(i,k,j) /= 0.) then + conva = dtstep/(dz8w(i,k,j)*60.) + convg = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + print*,"ADJUSTED EMISSIONS (PPM) AT (i,k,j):",i,k,j + print*,"dtstep,dz8w(i,k,j):",dtstep,dz8w(i,k,j) + print*,"e_pm25 i,j:",e_pm25i(i,k,j)*conva, & + e_pm25j(i,k,j)*conva + print*,"e_ec i,j:",e_eci(i,k,j)*conva, & + e_ecj(i,k,j)*conva + print*,"e_org i,j:",e_orgi(i,k,j)*conva, & + e_orgj(i,k,j)*conva + print*,"e_so2:",e_so2(i,k,j)*convg + print*,"e_no:",e_no(i,k,j)*convg + print*,"e_co:",e_co(i,k,j)*convg + print*,"e_eth:",e_eth(i,k,j)*convg + print*,"e_hc3:",e_hc3(i,k,j)*convg + print*,"e_hc5:",e_hc5(i,k,j)*convg + print*,"e_hc8:",e_hc8(i,k,j)*convg + print*,"e_xyl:",e_xyl(i,k,j)*convg + print*,"e_ol2:",e_ol2(i,k,j)*convg + print*,"e_olt:",e_olt(i,k,j)*convg + print*,"e_oli:",e_oli(i,k,j)*convg + print*,"e_tol:",e_tol(i,k,j)*convg + print*,"e_csl:",e_csl(i,k,j)*convg + print*,"e_hcho:",e_hcho(i,k,j)*convg + print*,"e_ald:",e_ald(i,k,j)*convg + print*,"e_ket:",e_ket(i,k,j)*convg + print*,"e_ora2:",e_ora2(i,k,j)*convg + print*,"e_pm25:",e_pm25(i,k,j)*conva + print*,"e_pm10:",e_pm10(i,k,j)*conva + print*,"e_nh3:",e_nh3(i,k,j)*convg + print*,"e_no2:",e_no2(i,k,j)*convg + print*,"e_ch3oh:",e_ch3oh(i,k,j)*convg + print*,"e_c2h5oh:",e_c2h5oh(i,k,j)*convg + print*,"e_iso:",e_iso(i,k,j)*convg + print*,"e_so4 f,c:",e_so4j(i,k,j)*conva, & + e_so4c(i,k,j)*conva + print*,"e_no3 f,c:",e_no3j(i,k,j)*conva, & + e_no3c(i,k,j)*conva + print*,"e_orgc:",e_orgc(i,k,j)*conva + print*,"e_ecc:",e_ecc(i,k,j)*conva + print* + else + print*,"dz8w=0 so cannot show adjusted emissions" + end if + print*,"CHEM_DBG PRINT (PPM or ug/m^3) AT (i,k,j):",i,k,j + do n=1,num_chem + print*,n,chem(i,k,j,n) + end do + if( present(ph_macr) ) then + print*,"PHOTOLYSIS DATA:" + print*,"ph_macr:",ph_macr(i,:,j) + print*,"ph_o31d:",ph_o31d(i,:,j) + print*,"ph_o33p:",ph_o33p(i,:,j) + print*,"ph_no2:",ph_no2(i,:,j) + print*,"ph_no3o2:",ph_no3o2(i,:,j) + print*,"ph_no3o:",ph_no3o(i,:,j) + print*,"ph_hno2:",ph_hno2(i,:,j) + print*,"ph_hno3:",ph_hno3(i,:,j) + print*,"ph_hno4:",ph_hno4(i,:,j) + print*,"ph_h2o2:",ph_h2o2(i,:,j) + print*,"ph_ch2or:",ph_ch2or(i,:,j) + print*,"ph_ch2om:",ph_ch2om(i,:,j) + print*,"ph_ch3cho:",ph_ch3cho(i,:,j) + print*,"ph_ch3coch3:",ph_ch3coch3(i,:,j) + print*,"ph_ch3coc2h5:",ph_ch3coc2h5(i,:,j) + print*,"ph_hcocho:",ph_hcocho(i,:,j) + print*,"ph_ch3cocho:",ph_ch3cocho(i,:,j) + print*,"ph_hcochest:",ph_hcochest(i,:,j) + print*,"ph_ch3o2h:",ph_ch3o2h(i,:,j) + print*,"ph_ch3coo2h:",ph_ch3coo2h(i,:,j) + print*,"ph_ch3ono2:",ph_ch3ono2(i,:,j) + print*,"ph_hcochob:",ph_hcochob(i,:,j) + print*,"ph_n2o5:",ph_n2o5(i,:,j) + print*,"ph_o2:",ph_o2(i,:,j) + end if + print* +end subroutine chem_dbg +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE med_read_bin_chem_emiss ( grid , config_flags ,intime, itime_max) + ! Driver layer +! USE module_domain +! USE module_io_domain +! USE module_timing + ! Model layer +! USE module_configure + USE module_bc_time_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif +! USE module_date_time +! USE module_utility + + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + !INTEGER , INTENT(IN) :: start_step , step , end_step +! Type (ESMF_Time ) :: start_time, stop_time, CurrTime +! TYPE(WRFU_TimeInterval) :: time_interval + + + ! Local data + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + LOGICAL :: emiss_opened + INTEGER :: intime, itime,itime_max, ierr , open_status , fid + REAL :: time, btime, bfrq + REAL, ALLOCATABLE :: dumc0(:,:,:) + CHARACTER (LEN=256) :: message + CHARACTER (LEN=80) :: bdyname + + CHARACTER (LEN=9 ),DIMENSION(30) :: ename + INTEGER :: nv,i , j , k, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + +#include + + write(message, '(A,I9)') 'call read emissions', intime + call wrf_message( TRIM( message ) ) + + IF(intime == 0 ) THEN + CALL construct_filename1 ( bdyname , '../../run/wrfem12k_00to12z' , grid%id , 2 ) + + IF (wrf_dm_on_monitor()) THEN + open (91,file=bdyname,form='unformatted') + ENDIf + write(message, '(A,A)') ' OPENED FILE: ',bdyname + call wrf_message( TRIM( message ) ) + ENDIF + IF(intime == 12 ) THEN + CALL construct_filename1 ( bdyname , '../../run/wrfem12k_12to24z' , grid%id , 2 ) + + IF (wrf_dm_on_monitor()) THEN + open (91,file=bdyname,form='unformatted') + ENDIf + write(message, '(A,A)') ' OPENED FILE: ',bdyname + call wrf_message( TRIM( message ) ) + ENDIF + CALL wrf_debug( 100 , 'med_read_bin_chem_emiss: calling emissions' ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ALLOCATE (dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1)) + + write(message, '(A,6I6)') ' I am reading emissions, dims: =',ids, ide-1, jds, jde-1, kds, grid%kemit + call wrf_message( TRIM( message ) ) + + IF(intime == 0 .or. intime == 12) then + read(91)nv + read(91)ename + write(message, '(A,I10)') ' Number of emissions: ',nv + call wrf_message( TRIM( message ) ) + +! write(message, '(A,30A10)') ' Array names : ',ename +! call wrf_message( TRIM( message ) ) + ENDIF + read(91)itime + write(message, '(A,I8,A,I8)') ' EMISSIONS INPUT FILE TIME PERIOD (GMT): ',itime-1,' TO ',itime + call wrf_message( TRIM( message ) ) + + read(91)dumc0 + grid%e_so2(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_no(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_ald(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_hcho(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_ora2(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_nh3(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_hc3(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_hc5(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_hc8(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_eth(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_co(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_ol2(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_olt(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_oli(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_tol(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_xyl(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_ket(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_csl(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_iso(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_pm25i(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_pm25j(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_so4i(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_so4j(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_no3i(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_no3j(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_orgi(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_orgj(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_eci(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_ecj(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + read(91)dumc0 + grid%e_pm10(ids:ide-1,kds:grid%kemit,jds:jde-1)=dumc0 + + DEALLOCATE ( dumc0 ) + RETURN +END SUBROUTINE med_read_bin_chem_emiss + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +END MODULE module_input_chem_data + diff --git a/wrfv2_fire/chem/module_mixactivate_wrappers.F b/wrfv2_fire/chem/module_mixactivate_wrappers.F new file mode 100644 index 00000000..9d9bed52 --- /dev/null +++ b/wrfv2_fire/chem/module_mixactivate_wrappers.F @@ -0,0 +1,229 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + +!---------------------------------------------------------------------- +! This module contains interface wrapper routines to couple the aerosol +! modules with mixactivate in the physics directory. Due to compiling +! dependencies, these cannot be placed in module_mixactivate. +!---------------------------------------------------------------------- + +MODULE module_mixactivate_wrappers + +CONTAINS + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine mosaic_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + rho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & + qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem + use module_data_mosaic_asect + use module_mixactivate, only: mixactivate + +! wrapper to call mixactivate for mosaic description of aerosol + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + idrydep_onoff + + real, intent(in) :: dtstep + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + rho_phy, t_phy, w, & + z, dz8w, p_at_w, t_at_w, exch_h + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old + + real, intent(in), & + dimension( its:ite, jts:jte, num_chem ) :: ddvel + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi + + LOGICAL, intent(in) :: f_qc, f_qi + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource,& + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + type(grid_config_rec_type), intent(in) :: config_flags +! local vars + real qsrflx(ims:ime, jms:jme, num_chem) ! dry deposition flux of aerosol + real sumhygro,sumvol + integer i,j,k,l,m,n + real hygro( its:ite, kts:kte, jts:jte,maxd_asize, maxd_atype ) ! bulk + + +! calculate volume-weighted bulk hygroscopicity for each type and size + + do 100 j=jts,jte + do 100 k=kts,kte + do 100 i=its,ite + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumhygro=0 + sumvol=0 + do l=1,ncomp_aer(n) + sumhygro = sumhygro+hygro_aer(l,n)* & + chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + sumvol = sumvol+chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + end do ! comp + hygro(i,k,j,m,n)=sumhygro/sumvol + end do ! size + end do ! type + 100 continue + +! check arguments of mixactivate for consistency between send, receive +! 06-nov-2005 rce - id & ktau added to arg list + call mixactivate( msectional, & + chem, num_chem, qv, qc, qi, qndrop3d, & + t_phy, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dcen_sect, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + id, ktau, dtstep, & + f_qc, f_qi ) + + end subroutine mosaic_mixactivate + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine sorgam_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + rho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & + qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem + use module_data_sorgam + use module_mixactivate, only: mixactivate + +! wrapper to call mixactivate for sorgam description of aerosol + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + idrydep_onoff + + real, intent(in) :: dtstep + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + rho_phy, t_phy, w, & + z, dz8w, p_at_w, t_at_w, exch_h + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old + + real, intent(in), & + dimension( its:ite, jts:jte, num_chem ) :: ddvel + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi + + LOGICAL, intent(in) :: f_qc, f_qi + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + type(grid_config_rec_type), intent(in) :: config_flags + +! local vars + real qsrflx(ims:ime, jms:jme, num_chem) ! dry deposition flux of aerosol + real sumhygro,sumvol + integer i,j,k,l,m,n + real hygro( its:ite, kts:kte, jts:jte,maxd_asize, maxd_atype ) + +! calculate volume-weighted bulk hygroscopicity for each type and size + + do 100 j=jts,jte + do 100 k=kts,kte + do 100 i=its,ite + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumhygro=0 + sumvol=0 + do l=1,ncomp_aer(n) + sumhygro = sumhygro+hygro_aer(l,n)* & + chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + sumvol = sumvol+chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + end do ! comp + hygro(i,k,j,m,n)=sumhygro/sumvol + end do ! size + end do ! type + 100 continue + + +! check arguments of mixactivate for consistency between send, receive +! 06-nov-2005 rce - id & ktau added to arg list + call mixactivate( msectional, & + chem, num_chem, qv, qc, qi, qndrop3d, & + t_phy, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dcen_sect, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + id, ktau, dtstep, & + f_qc, f_qi ) + + end subroutine sorgam_mixactivate + + +END MODULE module_mixactivate_wrappers diff --git a/wrfv2_fire/chem/module_mosaic_addemiss.F b/wrfv2_fire/chem/module_mosaic_addemiss.F new file mode 100644 index 00000000..e55d1022 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_addemiss.F @@ -0,0 +1,894 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** +MODULE module_mosaic_addemiss +!WRF:MODEL_LAYER:CHEMICS + +! rce 2005-feb-18 - one fix for indices of volumcen_sect, [now (isize,itype)] +! rce 2005-jan-14 - added subr mosaic_seasalt_emiss (and a call to it) +! rce 2004-dec-03 - many changes associated with the new aerosol "pointer" +! variables in module_data_mosaic_asect + + + + integer, parameter :: mosaic_addemiss_active = 1 + ! only do emissions when this is positive + ! (when it is negative, emissions tendencies are zero) + + integer, parameter :: mosaic_addemiss_masscheck = -1 + ! only do emissions masscheck calcs when this is positive + + integer, parameter :: mosaic_seasalt_emiss_active = 1 + ! only do seasalt emissions when this is positive + + +CONTAINS + + + +!---------------------------------------------------------------------- + subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & + config_flags, chem, & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! adds emissions for mosaic aerosol species +! (i.e., emissions tendencies over time dtstep are applied +! to the aerosol concentrations) +! + + USE module_configure, only: grid_config_rec_type + USE module_state_description, only: num_chem, param_first_scalar, & + emiss_inpt_default, emiss_inpt_pnnl_rs, emiss_inpt_pnnl_cm + USE module_data_mosaic_asect + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! 10-m wind speed components (m/s) + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: u10, v10, xland + +! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! aerosol emissions arrays ((ug/m3)*m/s) +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc + +! 1/(dry air density) and layer thickness (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: alt, dz8w + +! local variables + integer i, j, k, l, n + integer iphase, itype + integer p1st + + real, parameter :: efact1 = 1.0 + real :: aem_so4, aem_no3, aem_cl, aem_msa, aem_co3, aem_nh4, & + aem_na, aem_ca, aem_oin, aem_oc, aem_bc, aem_num + real dum, fact + + +! fraction of sorgam i/aitken mode emissions that go to each +! of the mosaic 8 "standard" sections + real, save :: fr8b_aem_sorgam_i(8) = & + (/ 0.965, 0.035, 0.000, 0.000, & + 0.000, 0.000, 0.000, 0.000 /) + +! fraction of sorgam j/accum mode emissions that go to each +! of the mosaic 8 "standard" sections + real, save :: fr8b_aem_sorgam_j(8) = & + (/ 0.026, 0.147, 0.350, 0.332, & + 0.125, 0.019, 0.001, 0.000/) + +! fraction of sorgam coarse mode emissions that go to each +! of the mosaic 8 "standard" sections + real, save :: fr8b_aem_sorgam_c(8) = & + (/ 0.000, 0.000, 0.000, 0.002, & + 0.021, 0.110, 0.275, 0.592 /) + +! fraction of mosaic fine (< 2.5 um) emissions that go to each +! of the mosaic 8 "standard" sections +!wig 1-Apr-2005, Updated fractional breakdown between bins. (See also +! bdy_chem_value_mosaic and mosaic_init_wrf_mixrats_opt2 +! in module_mosaic_initmixrats.F.) Note that the values +! here no longer match the other two subroutines. +!rce 10-may-2005, changed fr8b_aem_mosaic_f & fr8b_aem_mosaic_c +! to values determined by jdf + real, save :: fr8b_aem_mosaic_f(8) = & + (/ 0.060, 0.045, 0.245, 0.400, 0.100, 0.150, 0., 0./) !10-may-2005 +! (/ 0.100, 0.045, 0.230, 0.375, 0.100, 0.150, 0., 0./) !1-Apr-2005 values +! (/ 0.0275, 0.0426, 0.2303, 0.3885, 0.1100, 0.2011, 0., 0./) !15-Nov-2004 values +! (/ 0.01, 0.05, 0.145, 0.60, 0.145, 0.05, 0.00, 0.00 /) +! (/ 0.04, 0.10, 0.35, 0.29, 0.15, 0.07, 0.0, 0.0 /) + +! fraction of mosaic coarse (> 2.5 um) emissions that go to each +! of the mosaic 8 "standard" sections + real, save :: fr8b_aem_mosaic_c(8) = & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /) ! 10-may-2005 +! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.933, 0.067 /) ! as of apr-2005 +! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.16, 0.84 /) ! "old" + +! following 5 arrays correspond to the above "fr8b_" arrays +! but are set at run time base on input (namelist) parameters: +! only the sorgam or mosaic arrays are non-zero, depending on +! emiss_inpt_opt +! when nsize_aer=4 (=number of sections), the values are +! calculated by adding two of the 8-section values + real :: fr_aem_sorgam_i(8) + real :: fr_aem_sorgam_j(8) + real :: fr_aem_sorgam_c(8) + real :: fr_aem_mosaic_f(8) + real :: fr_aem_mosaic_c(8) + double precision :: chem_sum(num_chem) + + character*80 msg + + +! *** currently only works with ntype_aer = 1 + itype = 1 + iphase = ai_phase + + +! +! compute factors used for apportioning either +! the MADE-SORGAM emissions (i=aitken, j=accum, c=coarse modes) OR +! the MOSAIC emission (f=fine (< 2.5 um), c=coarse (> 2.5 um)) +! to each size section +! +! note: the fr8b_aer_xxxxxx_y values are specific to the mosaic 8 bin +! structure with dlo_sect(1)=0.039 um and dhi_sect(8)=10.0 um, +! also, the fr8b_aem_sorgam_y are specific for the assumed +! dgvem_i/j/c used in the sorgam code +! also, the fr8b_aem_mosaic_y values are specific for the assumed (by us) +! size distribution for fine and coarse primary emissions +! +! when there are 4 bins (nsize_aer=4), each of these "wider" bins +! corresponds to 2 of the "narrower" bins of the 8 bin structure +! +! note: if fr_aem_sorgam_y > 0, then fr_aem_mosaic_y = 0, and vice-versa +! + if ((nsize_aer(itype) .ne. 4) .and. (nsize_aer(itype) .ne. 8)) then + write(msg,'(a,i5)') & + 'subr mosaic_addemiss - nsize_aer(itype) must be ' // & + '4 or 8 but = ', & + nsize_aer(itype) + call wrf_error_fatal( msg ) + end if + + fr_aem_sorgam_i(:) = 0.0 + fr_aem_sorgam_j(:) = 0.0 + fr_aem_sorgam_c(:) = 0.0 + fr_aem_mosaic_f(:) = 0.0 + fr_aem_mosaic_c(:) = 0.0 + + emiss_inpt_select_1: SELECT CASE( config_flags%emiss_inpt_opt ) + + CASE( emiss_inpt_default, emiss_inpt_pnnl_rs ) + if (nsize_aer(itype) .eq. 8) then + fr_aem_sorgam_i(:) = fr8b_aem_sorgam_i(:) + fr_aem_sorgam_j(:) = fr8b_aem_sorgam_j(:) + fr_aem_sorgam_c(:) = fr8b_aem_sorgam_c(:) + else if (nsize_aer(itype) .eq. 4) then + do n = 1, nsize_aer(itype) + fr_aem_sorgam_i(n) = fr8b_aem_sorgam_i(2*n-1) & + + fr8b_aem_sorgam_i(2*n) + fr_aem_sorgam_j(n) = fr8b_aem_sorgam_j(2*n-1) & + + fr8b_aem_sorgam_j(2*n) + fr_aem_sorgam_c(n) = fr8b_aem_sorgam_c(2*n-1) & + + fr8b_aem_sorgam_c(2*n) + end do + end if + + CASE( emiss_inpt_pnnl_cm ) + if (nsize_aer(itype) .eq. 8) then + fr_aem_mosaic_f(:) = fr8b_aem_mosaic_f(:) + fr_aem_mosaic_c(:) = fr8b_aem_mosaic_c(:) + else if (nsize_aer(itype) .eq. 4) then + do n = 1, nsize_aer(itype) + fr_aem_mosaic_f(n) = fr8b_aem_mosaic_f(2*n-1) & + + fr8b_aem_mosaic_f(2*n) + fr_aem_mosaic_c(n) = fr8b_aem_mosaic_c(2*n-1) & + + fr8b_aem_mosaic_c(2*n) + end do + end if + + CASE DEFAULT + return + + END SELECT emiss_inpt_select_1 + +! when mosaic_addemiss_active <= 0, set fr's to zero, +! which causes the changes to chem(...) to be zero + if (mosaic_addemiss_active <= 0) then + fr_aem_sorgam_i(:) = 0.0 + fr_aem_sorgam_j(:) = 0.0 + fr_aem_sorgam_c(:) = 0.0 + fr_aem_mosaic_f(:) = 0.0 + fr_aem_mosaic_c(:) = 0.0 + end if + + +! do mass check initial calc + if (mosaic_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 1, 'mosaic_ademiss', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 14, & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + e_ecc,e_ecc,e_ecc,e_ecc,e_ecc,e_ecc,e_ecc ) + + p1st = param_first_scalar + +! +! apply emissions at each section and grid point +! + do 1900 n = 1, nsize_aer(itype) + + do 1830 j = jts, jte + do 1820 k = kts, min(config_flags%kemit,kte-1) + do 1810 i = its, ite + +! compute mass emissions [(ug/m3)*m/s] for each species +! using the apportioning fractions + aem_so4 = fr_aem_mosaic_f(n)*e_so4j(i,k,j) & + + fr_aem_mosaic_c(n)*e_so4c(i,k,j) + + aem_no3 = fr_aem_mosaic_f(n)*e_no3j(i,k,j) & + + fr_aem_mosaic_c(n)*e_no3c(i,k,j) + + aem_oc = fr_aem_mosaic_f(n)*e_orgj(i,k,j) & + + fr_aem_mosaic_c(n)*e_orgc(i,k,j) & + + fr_aem_sorgam_i(n)*e_orgi(i,k,j) & + + fr_aem_sorgam_j(n)*e_orgj(i,k,j) + + aem_bc = fr_aem_mosaic_f(n)*e_ecj(i,k,j) & + + fr_aem_mosaic_c(n)*e_ecc(i,k,j) & + + fr_aem_sorgam_i(n)*e_eci(i,k,j) & + + fr_aem_sorgam_j(n)*e_ecj(i,k,j) + + aem_oin = fr_aem_mosaic_f(n)*e_pm25j(i,k,j) & + + fr_aem_mosaic_c(n)*e_pm10(i,k,j) & + + fr_aem_sorgam_i(n)*e_pm25i(i,k,j) & + + fr_aem_sorgam_j(n)*e_pm25j(i,k,j) & + + fr_aem_sorgam_c(n)*e_pm10(i,k,j) + +! emissions for these species are currently zero + aem_nh4 = 0.0 + aem_na = 0.0 + aem_cl = 0.0 + aem_ca = 0.0 + aem_co3 = 0.0 + aem_msa = 0.0 + +! compute number emissions +! first sum the mass-emissions/density + aem_num = & + (aem_so4/dens_so4_aer) + (aem_no3/dens_no3_aer) + & + (aem_cl /dens_cl_aer ) + (aem_msa/dens_msa_aer) + & + (aem_co3/dens_co3_aer) + (aem_nh4/dens_nh4_aer) + & + (aem_na /dens_na_aer ) + (aem_ca /dens_ca_aer ) + & + (aem_oin/dens_oin_aer) + (aem_oc /dens_oc_aer ) + & + (aem_bc /dens_bc_aer ) + +! then multiply by 1.0e-6 to convert ug to g +! and divide by particle volume at center of section (cm3) + aem_num = aem_num*1.0e-6/volumcen_sect(n,itype) + +! apply the emissions and convert from flux to mixing ratio +! fact = (dtstep/dz8w(i,k,j))*(28.966/1000.) + fact = (dtstep/dz8w(i,k,j))*alt(i,k,j) + +! rce 22-nov-2004 - change to using the "..._aer" species pointers + l = lptr_so4_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_so4*fact + + l = lptr_no3_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_no3*fact + + l = lptr_cl_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_cl*fact + + l = lptr_msa_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_msa*fact + + l = lptr_co3_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_co3*fact + + l = lptr_nh4_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_nh4*fact + + l = lptr_na_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_na*fact + + l = lptr_ca_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_ca*fact + + l = lptr_oin_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oin*fact + + l = lptr_oc_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oc*fact + + l = lptr_bc_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_bc*fact + + l = numptr_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_num*fact + +1810 continue +1820 continue +1830 continue + +1900 continue + + +! do mass check final calc + if (mosaic_addemiss_masscheck > 0) call addemiss_masscheck( & + id, config_flags, 2, 'mosaic_ademiss', & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + 14, & + e_pm10,e_pm25,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj, & + e_so4j,e_so4c,e_no3j,e_no3c,e_orgc,e_ecc, & + e_ecc,e_ecc,e_ecc,e_ecc,e_ecc,e_ecc,e_ecc ) + + +! do seasalt emissions + if (mosaic_seasalt_emiss_active > 0) & + call mosaic_seasalt_emiss( & + id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + return + + + END subroutine mosaic_addemiss + + + +!---------------------------------------------------------------------- + subroutine mosaic_seasalt_emiss( & + id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! adds seasalt emissions for mosaic aerosol species +! (i.e., seasalt emissions tendencies over time dtstep are applied +! to the aerosol mixing ratios) +! + + USE module_configure, only: grid_config_rec_type + USE module_state_description, only: num_chem, param_first_scalar + USE module_data_mosaic_asect + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! 10-m wind speed components (m/s) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: u10, v10, xland + +! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! alt = 1.0/(dry air density) in (m3/kg) +! dz8w = layer thickness in (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: alt, dz8w + +! local variables + integer i, j, k, l, l_na, l_cl, n + integer iphase, itype + integer p1st + + real dum, dumdlo, dumdhi, dumoceanfrac, dumspd10 + real factaa, factbb, fracna, fraccl + + real :: ssemfact_numb( maxd_asize, maxd_atype ) + real :: ssemfact_mass( maxd_asize, maxd_atype ) + + +! for now just do itype=1 + itype = 1 + iphase = ai_phase + +! compute emissions factors for each size bin +! (limit emissions to dp > 0.1 micrometer) + do n = 1, nsize_aer(itype) + dumdlo = max( dlo_sect(n,itype), 0.1e-4 ) + dumdhi = max( dhi_sect(n,itype), 0.1e-4 ) + call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, & + ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype) ) + +! convert mass emissions factor from (g/m2/s) to (ug/m2/s) + ssemfact_mass(n,itype) = ssemfact_mass(n,itype)*1.0e6 + end do + + +! loop over i,j and apply seasalt emissions + k = kts + do 1830 j = jts, jte + do 1820 i = its, ite + + !Skip this point if over land. xland=1 for land and 2 for water. + !Also, there is no way to differentiate fresh from salt water. + !Currently, this assumes all water is salty. + if( xland(i,j) < 1.5 ) cycle + + !wig: As far as I can tell, only real.exe knows the fractional breakdown + ! of land use. So, in wrf.exe, dumoceanfrac will always be 1. + dumoceanfrac = 1. !fraction of grid i,j that is salt water + dumspd10 = dumoceanfrac* & + ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) ) + +! factaa is (s*m2/kg-air) +! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air +! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air + factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j) + + factbb = factaa * dumspd10 + +! apportion seasalt mass emissions assumming that seasalt is pure nacl + fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) + fraccl = 1.0 - fracna + + do 1810 n = 1, nsize_aer(itype) + +! only apply emissions if bin has both na and cl species + l_na = lptr_na_aer(n,itype,iphase) + l_cl = lptr_cl_aer(n,itype,iphase) + if ((l_na >= p1st) .and. (l_cl >= p1st)) then + + chem(i,k,j,l_na) = chem(i,k,j,l_na) + & + factbb * ssemfact_mass(n,itype) * fracna + + chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + & + factbb * ssemfact_mass(n,itype) * fraccl + + l = numptr_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & + factbb * ssemfact_numb(n,itype) + + end if +1810 continue + +1820 continue +1830 continue + + return + + END subroutine mosaic_seasalt_emiss + + + +!c---------------------------------------------------------------------- +!c following is from gong06b.f in +!c /net/cirrus/files1/home/rce/oldfiles1/box/seasaltg +!c---------------------------------------------------------------------- + subroutine seasalt_emitfactors_1bin( ireduce_smallr_emit, & + dpdrylo_cm, dpdryhi_cm, & + emitfact_numb, emitfact_surf, emitfact_mass ) +!c +!c computes seasalt emissions factors for a specifed +!c dry particle size range +!c dpdrylo_cm = lower dry diameter (cm) +!c dpdryhi_cm = upper dry diameter (cm) +!c +!c number and mass emissions are then computed as +!c number emissions (#/m2/s) == emitfact_numb * (spd10*3.41) +!c dry-sfc emissions (cm2/m2/s) == emitfact_surf * (spd10*3.41) +!c dry-mass emissions (g/m2/s) == emitfact_mass * (spd10*3.41) +!c +!c where spd10 = 10 m windspeed in m/s +!c +!c uses bubble emissions formula (eqn 5a) from +!c Gong et al. [JGR, 1997, p 3805-3818] +!c +!c *** for rdry < rdry_star, this formula overpredicts emissions. +!c A strictly ad hoc correction is applied to the formula, +!c based on sea-salt size measurements of +!c O'Dowd et al. [Atmos Environ, 1997, p 73-80] +!c +!c *** the correction is only applied when ireduce_smallr_emit > 0 +!c + implicit none + +!c subr arguments + integer ireduce_smallr_emit + real dpdrylo_cm, dpdryhi_cm, & + emitfact_numb, emitfact_surf, emitfact_mass + +!c local variables + integer isub_bin, nsub_bin + + real alnrdrylo + real drydens, drydens_43pi_em12, x_4pi_em8 + real dum, dumadjust, dumb, dumexpb + real dumsum_na, dumsum_ma, dumsum_sa + real drwet, dlnrdry + real df0drwet, df0dlnrdry, df0dlnrdry_star + real relhum + real rdry, rdrylo, rdryhi, rdryaa, rdrybb + real rdrylowermost, rdryuppermost, rdry_star + real rwet, rwetaa, rwetbb + real rdry_cm, rwet_cm + real sigmag_star + real xmdry, xsdry + + real pi + parameter (pi = 3.1415936536) + +!c c1-c4 are constants for seasalt hygroscopic growth parameterization +!c in Eqn 3 and Table 2 of Gong et al. [1997] + real c1, c2, c3, c4, onethird + parameter (c1 = 0.7674) + parameter (c2 = 3.079) + parameter (c3 = 2.573e-11) + parameter (c4 = -1.424) + parameter (onethird = 1.0/3.0) + + +!c dry particle density (g/cm3) + drydens = 2.165 +!c factor for radius (micrometers) to mass (g) + drydens_43pi_em12 = drydens*(4.0/3.0)*pi*1.0e-12 +!c factor for radius (micrometers) to surface (cm2) + x_4pi_em8 = 4.0*pi*1.0e-8 +!c bubble emissions formula assume 80% RH + relhum = 0.80 + +!c rdry_star = dry radius (micrometers) below which the +!c dF0/dr emission formula is adjusted downwards + rdry_star = 0.1 + if (ireduce_smallr_emit .le. 0) rdry_star = -1.0e20 +!c sigmag_star = geometric standard deviation used for +!c rdry < rdry_star + sigmag_star = 1.9 + +!c initialize sums + dumsum_na = 0.0 + dumsum_sa = 0.0 + dumsum_ma = 0.0 + +!c rdrylowermost, rdryuppermost = lower and upper +!c dry radii (micrometers) for overall integration + rdrylowermost = dpdrylo_cm*0.5e4 + rdryuppermost = dpdryhi_cm*0.5e4 + +!c +!c "section 1" +!c integrate over rdry > rdry_star, where the dF0/dr emissions +!c formula is applicable +!c (when ireduce_smallr_emit <= 0, rdry_star = -1.0e20, +!c and the entire integration is done here) +!c + if (rdryuppermost .le. rdry_star) goto 2000 + +!c rdrylo, rdryhi = lower and upper dry radii (micrometers) +!c for this part of the integration + rdrylo = max( rdrylowermost, rdry_star ) + rdryhi = rdryuppermost + + nsub_bin = 1000 + + alnrdrylo = log( rdrylo ) + dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin + +!c compute rdry, rwet (micrometers) at lowest size + rdrybb = exp( alnrdrylo ) + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + do 1900 isub_bin = 1, nsub_bin + +!c rdry, rwet at sub_bin lower boundary are those +!c at upper boundary of previous sub_bin + rdryaa = rdrybb + rwetaa = rwetbb + +!c compute rdry, rwet (micrometers) at sub_bin upper boundary + dum = alnrdrylo + isub_bin*dlnrdry + rdrybb = exp( dum ) + + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + +!c geometric mean rdry, rwet (micrometers) for sub_bin + rdry = sqrt(rdryaa * rdrybb) + rwet = sqrt(rwetaa * rwetbb) + drwet = rwetbb - rwetaa + +!c xmdry is dry mass in g + xmdry = drydens_43pi_em12 * (rdry**3.0) + +!c xsdry is dry surface in cm2 + xsdry = x_4pi_em8 * (rdry**2.0) + +!c dumb is "B" in Gong's Eqn 5a +!c df0drwet is "dF0/dr" in Gong's Eqn 5a + dumb = ( 0.380 - log10(rwet) ) / 0.650 + dumexpb = exp( -dumb*dumb) + df0drwet = 1.373 * (rwet**(-3.0)) * & + (1.0 + 0.057*(rwet**1.05)) * & + (10.0**(1.19*dumexpb)) + + dumsum_na = dumsum_na + drwet*df0drwet + dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry + dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry + +1900 continue + + +!c +!c "section 2" +!c integrate over rdry < rdry_star, where the dF0/dr emissions +!c formula is just an extrapolation and predicts too many emissions +!c +!c 1. compute dF0/dln(rdry) = (dF0/drwet)*(drwet/dlnrdry) +!c at rdry_star +!c 2. for rdry < rdry_star, assume dF0/dln(rdry) is lognormal, +!c with the same lognormal parameters observed in +!c O'Dowd et al. [1997] +!c +2000 if (rdrylowermost .ge. rdry_star) goto 3000 + +!c compute dF0/dln(rdry) at rdry_star + rdryaa = 0.99*rdry_star + rdry_cm = rdryaa*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetaa = rwet_cm*1.0e4 + + rdrybb = 1.01*rdry_star + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + rwet = 0.5*(rwetaa + rwetbb) + dumb = ( 0.380 - log10(rwet) ) / 0.650 + dumexpb = exp( -dumb*dumb) + df0drwet = 1.373 * (rwet**(-3.0)) * & + (1.0 + 0.057*(rwet**1.05)) * & + (10.0**(1.19*dumexpb)) + + drwet = rwetbb - rwetaa + dlnrdry = log( rdrybb/rdryaa ) + df0dlnrdry_star = df0drwet * (drwet/dlnrdry) + + +!c rdrylo, rdryhi = lower and upper dry radii (micrometers) +!c for this part of the integration + rdrylo = rdrylowermost + rdryhi = min( rdryuppermost, rdry_star ) + + nsub_bin = 1000 + + alnrdrylo = log( rdrylo ) + dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin + + do 2900 isub_bin = 1, nsub_bin + +!c geometric mean rdry (micrometers) for sub_bin + dum = alnrdrylo + (isub_bin-0.5)*dlnrdry + rdry = exp( dum ) + +!c xmdry is dry mass in g + xmdry = drydens_43pi_em12 * (rdry**3.0) + +!c xsdry is dry surface in cm2 + xsdry = x_4pi_em8 * (rdry**2.0) + +!c dumadjust is adjustment factor to reduce dF0/dr + dum = log( rdry/rdry_star ) / log( sigmag_star ) + dumadjust = exp( -0.5*dum*dum ) + + df0dlnrdry = df0dlnrdry_star * dumadjust + + dumsum_na = dumsum_na + dlnrdry*df0dlnrdry + dumsum_ma = dumsum_ma + dlnrdry*df0dlnrdry*xmdry + dumsum_sa = dumsum_sa + dlnrdry*df0dlnrdry*xsdry + +2900 continue + + +!c +!c all done +!c +3000 emitfact_numb = dumsum_na + emitfact_mass = dumsum_ma + emitfact_surf = dumsum_sa + + return + end subroutine seasalt_emitfactors_1bin + + + +END MODULE module_mosaic_addemiss + + + +!---------------------------------------------------------------------- + subroutine addemiss_masscheck( id, config_flags, iflagaa, fromwhere, & + dtstep, efact1, dz8w, chem, chem_sum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + nemit, & + e01, e02, e03, e04, e05, e06, e07, e08, e09, e10, & + e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21 ) +! +! produces test diagnostics for "addemiss" routines +! +! 1. computes {sum over i,j,k ( chem * dz8w )} before and after +! emissions tendencies are added to chem, +! then prints (sum_after - sum_before)/(dtstep*efact1) +! 2. computes {sum over i,j,k ( e_xxx )}, then prints them +! the two should be equal +! + + USE module_configure, only: grid_config_rec_type + USE module_state_description, only: num_chem + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, iflagaa, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + nemit + + REAL, INTENT(IN ) :: dtstep, efact1 + +! trace species mixing ratios + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + +! trace species integrals + DOUBLE PRECISION, DIMENSION( num_chem ), & + INTENT(INOUT ) :: chem_sum + +! layer thickness (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: dz8w + +! emissions +! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + REAL, DIMENSION( ims:ime , kms:config_flags%kemit , jms:jme ), & + INTENT(IN ) :: & + e01, e02, e03, e04, e05, e06, e07, e08, e09, e10, & + e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21 + + character(len=*), intent(in) :: fromwhere + +! local variables + integer, parameter :: nemit_maxd = 21 + integer :: i, j, k, l + double precision :: chem_sum_prev + real :: fact + real :: emit_sum(nemit_maxd) + + +! compute column integral, summed over i-j grids +! compute {sum over i,j,k ( chem * dz8w ) } +! on second pass (iflagaa==2), subtract the pass-one sum + do 1900 l = 1, num_chem + + chem_sum_prev = chem_sum(l) + chem_sum(l) = 0.0 + + do j = jts, jte + do k = kts, kte-1 + do i = its, ite + chem_sum(l) = chem_sum(l) + dble( chem(i,k,j,l)*dz8w(i,k,j) ) + end do + end do + end do + + if (iflagaa == 2) chem_sum(l) = (chem_sum(l) - chem_sum_prev) + +1900 continue + + if (iflagaa /= 2) return + + +! compute {sum over i,j,k ( e_xxx ) } + emit_sum(:) = 0.0 + + do 2900 l = 1, min(nemit,nemit_maxd) + do j = jts, jte + do k = kts, min(config_flags%kemit,kte-1) + do i = its, ite + if (l== 1) emit_sum(l) = emit_sum(l) + e01(i,k,j) + if (l== 2) emit_sum(l) = emit_sum(l) + e02(i,k,j) + if (l== 3) emit_sum(l) = emit_sum(l) + e03(i,k,j) + if (l== 4) emit_sum(l) = emit_sum(l) + e04(i,k,j) + if (l== 5) emit_sum(l) = emit_sum(l) + e05(i,k,j) + if (l== 6) emit_sum(l) = emit_sum(l) + e06(i,k,j) + if (l== 7) emit_sum(l) = emit_sum(l) + e07(i,k,j) + if (l== 8) emit_sum(l) = emit_sum(l) + e08(i,k,j) + if (l== 9) emit_sum(l) = emit_sum(l) + e09(i,k,j) + if (l==10) emit_sum(l) = emit_sum(l) + e10(i,k,j) + + if (l==11) emit_sum(l) = emit_sum(l) + e11(i,k,j) + if (l==12) emit_sum(l) = emit_sum(l) + e12(i,k,j) + if (l==13) emit_sum(l) = emit_sum(l) + e13(i,k,j) + if (l==14) emit_sum(l) = emit_sum(l) + e14(i,k,j) + if (l==15) emit_sum(l) = emit_sum(l) + e15(i,k,j) + if (l==16) emit_sum(l) = emit_sum(l) + e16(i,k,j) + if (l==17) emit_sum(l) = emit_sum(l) + e17(i,k,j) + if (l==18) emit_sum(l) = emit_sum(l) + e18(i,k,j) + if (l==19) emit_sum(l) = emit_sum(l) + e19(i,k,j) + if (l==20) emit_sum(l) = emit_sum(l) + e20(i,k,j) + + if (l==21) emit_sum(l) = emit_sum(l) + e21(i,k,j) + end do + end do + end do +2900 continue + +! output the chem_sum and emit_sum + print 9110, fromwhere, its, ite, jts, jte + print 9100, 'chem_sum' + fact = 1.0/(dtstep*efact1) + print 9120, (l, fact*chem_sum(l), l=1,num_chem) + print 9100, 'emit_sum' + print 9120, (l, emit_sum(l), l=1,min(nemit,nemit_maxd)) + +9100 format( a ) +9110 format( / 'addemiss_masscheck output, fromwhere = ', a / & + 'its, ite, jts, jte =', 4i5 ) +9120 format( 5( i5, 1pe11.3 ) ) + + + return + END subroutine addemiss_masscheck + diff --git a/wrfv2_fire/chem/module_mosaic_cloudchem.F b/wrfv2_fire/chem/module_mosaic_cloudchem.F new file mode 100644 index 00000000..e9465daa --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_cloudchem.F @@ -0,0 +1,1732 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + + module module_mosaic_cloudchem + + + + integer, parameter :: l_so4_aqyy = 1 + integer, parameter :: l_no3_aqyy = 2 + integer, parameter :: l_cl_aqyy = 3 + integer, parameter :: l_nh4_aqyy = 4 + integer, parameter :: l_na_aqyy = 5 + integer, parameter :: l_oin_aqyy = 6 + integer, parameter :: l_bc_aqyy = 7 + integer, parameter :: l_oc_aqyy = 8 + + integer, parameter :: nyyy = 8 + + + + contains + + + +!----------------------------------------------------------------------- + subroutine mosaic_cloudchem_driver( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use module_state_description, only: & + num_moist, num_chem, p_qc + + use module_configure, only: grid_config_rec_type + + use module_data_mosaic_asect, only: cw_phase, nphase_aer + + use module_data_mosaic_other, only: k_pegbegin, name + + use module_mosaic_driver, only: mapaer_tofrom_host + + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte +! id - domain index +! ktau - time step number +! ktauc - gas and aerosol chemistry time step number +! numgas_aqfrac - last dimension of gas_aqfrac + +! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for 'domain' +! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for 'memory' +! Most arrays that are arguments to chem_driver +! are dimensioned with these spatial indices. +! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for 'tile' +! chem_driver and routines under it do calculations +! over these spatial indices. + + type(grid_config_rec_type), intent(in) :: config_flags +! config_flags - configuration and control parameters + + real, intent(in) :: & + dtstepc +! dtstepc - time step for gas and aerosol chemistry(s) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + p_phy, t_phy, rho_phy, alt, cldfra, ph_no2 +! p_phy - air pressure (Pa) +! t_phy - temperature (K) +! rho_phy - moist air density (kg/m^3) +! alt - dry air specific volume (m^3/kg) +! cldfra - cloud fractional area (0-1) +! ph_no2 - no2 photolysis rate (1/min) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist +! moist - mixing ratios of moisture species (water vapor, +! cloud water, ...) (kg/kg for mass species, #/kg for number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem +! chem - mixing ratios of trace gas and aerosol species (ppm for gases, +! ug/kg for aerosol mass species, #/kg for aerosol number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, numgas_aqfrac ) :: & + gas_aqfrac +! gas_aqfrac - fraction (0-1) of gas that is dissolved in cloud water + + +! local variables + integer :: it, jt, kt, kpeg, k_pegshift, l, mpeg + integer :: icase + integer :: igaschem_onoff, iphotol_onoff, iradical_onoff + + real :: gas_aqfrac_box(numgas_aqfrac) + real :: ph_aq_box + real, parameter :: qcldwtr_cutoff = 1.0e-6 + real :: qcldwtr + + +! check that cw_phase is active + if ((cw_phase .le. 0) .or. (cw_phase .gt. nphase_aer)) then + print *, '*** mosaic_cloudchem_driver - cw_phase not active' + return + end if + + print 93010, 'entering mosaic_cloudchem_driver - ktau =', ktau + + icase = 0 + +! iphotol_onoff = 1 if photolysis rate calcs are on; 0 if off + iphotol_onoff = 0 + if (config_flags%phot_opt .gt. 0) iphotol_onoff = 1 +! igaschem_onoff = 1 if gas-phase chemistry is on; 0 if off + igaschem_onoff = 0 + if (config_flags%gaschem_onoff .gt. 0) igaschem_onoff = 1 + +! iradical_onoff turns aqueous radical chemistry on/off +! set iradical_onoff=0 if either photolysis or gas-phase chem are off + if ((igaschem_onoff .le. 0) .or. (iphotol_onoff .le. 0)) then + iradical_onoff = 0 + else + iradical_onoff = 1 + end if +! following line turns aqueous radical chem off unconditionally + iradical_onoff = 0 + + + do 3920 jt = jts, jte + do 3910 it = its, ite + + do 3800 kt = kts, kte-1 + + qcldwtr = moist(it,kt,jt,p_qc) + if (qcldwtr .le. qcldwtr_cutoff) goto 3800 + + + k_pegshift = k_pegbegin - kts + kpeg = kt + k_pegshift + mpeg = 1 + icase = icase + 1 + +! detailed dump for debugging + if (ktau .eq. -13579) then +! if ((ktau .eq. 30) .and. (it .eq. 23) .and. & +! (jt .eq. 1) .and. (kt .eq. 11)) then + call mosaic_cloudchem_dumpaa( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + qcldwtr_cutoff, & + it, jt, kt ) + end if + +! map from wrf-chem 3d arrays to pegasus clm & sub arrays + call mapaer_tofrom_host( 0, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, kt, kt, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + +! make call '1box' cloudchem routine +! print 93010, 'calling mosaic_cloudchem_1 at ijk =', it, jt, kt + call mosaic_cloudchem_1box( & + id, ktau, ktauc, dtstepc, & + iphotol_onoff, iradical_onoff, & + ph_no2(it,kt,jt), & + ph_aq_box, gas_aqfrac_box, & + numgas_aqfrac, it, jt, kt, kpeg, mpeg, icase ) + +! map back to wrf-chem 3d arrays + call mapaer_tofrom_host( 1, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, kt, kt, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + + gas_aqfrac(it,kt,jt,:) = gas_aqfrac_box(:) + + +3800 continue + +3910 continue +3920 continue + + print 93010, 'leaving mosaic_cloudchem_driver - ktau =', ktau, icase +93010 format( a, 8(1x,i6) ) + + return + end subroutine mosaic_cloudchem_driver + + + +!----------------------------------------------------------------------- + subroutine mosaic_cloudchem_1box( & + id, ktau, ktauc, dtstepc, & + iphotol_onoff, iradical_onoff, & + photol_no2_box, & + ph_aq_box, gas_aqfrac_box, & + numgas_aqfrac, it, jt, kt, kpeg, mpeg, icase ) + + use module_state_description, only: & + num_moist, num_chem + + use module_data_mosaic_asect, only: & + msectional, & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_cl_aer, lptr_co3_aer, & + lptr_msa_aer, lptr_nh4_aer, lptr_na_aer, lptr_ca_aer, & + lptr_oin_aer, lptr_bc_aer, lptr_oc_aer + + use module_data_mosaic_other, only: & + l2maxd, ltot2, rsub + + use module_data_cmu_bulkaqchem, only: & + meqn1max + + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, it, jt, kt, kpeg, mpeg, & + icase, iphotol_onoff, iradical_onoff + + real, intent(in) :: & + dtstepc, photol_no2_box + + real, intent(inout) :: ph_aq_box + + real, intent(inout), dimension( numgas_aqfrac ) :: gas_aqfrac_box + +! local variables + integer :: iphase + integer :: icase_in, idecomp_hmsa_hso5, & + iradical_in, istat_aqop + + integer :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real :: co2_mixrat_in + real :: ph_cmuaq_cur + real :: photol_no2_in + + real :: yaq_beg(meqn1max), yaq_end(meqn1max) + real :: rbox(l2maxd), rbox_sv1(l2maxd) + real :: rbulk_cwaer(nyyy,2) + + real, dimension( maxd_asize, maxd_atype ) :: fr_partit_cw + + +! +! set the lptr_yyy_cwaer +! + iphase = cw_phase + lptr_yyy_cwaer(:,:,l_so4_aqyy) = lptr_so4_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_no3_aqyy) = lptr_no3_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_cl_aqyy ) = lptr_cl_aer( :,:,iphase) + lptr_yyy_cwaer(:,:,l_nh4_aqyy) = lptr_nh4_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_na_aqyy ) = lptr_na_aer( :,:,iphase) + lptr_yyy_cwaer(:,:,l_oin_aqyy) = lptr_oin_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_bc_aqyy ) = lptr_bc_aer( :,:,iphase) + lptr_yyy_cwaer(:,:,l_oc_aqyy ) = lptr_oc_aer( :,:,iphase) + +! +! xfer from rsub to rbox +! + rbox(1:ltot2) = max( 0.0, rsub(1:ltot2,kpeg,mpeg) ) + rbox_sv1(1:ltot2) = rbox(1:ltot2) + +! +! +! do bulk cloud-water chemistry +! +! + icase_in = icase + iradical_in = 1 + idecomp_hmsa_hso5 = 1 + + co2_mixrat_in = 350.0 + + photol_no2_in = photol_no2_box + +! turn off aqueous phase photolytic and radical chemistry +! if either of the iphotol_onoff and iradical_onoff flags are 0 + if ((iphotol_onoff .le. 0) .or. (iradical_onoff .le. 0)) then + photol_no2_in = 0.0 + iradical_in = 0 + end if + +#if defined ( ccboxtest_box_testing_active) +! following is for off-line box testing only + call ccboxtest_extra_args_aa( 'get', & + co2_mixrat_in, iradical_in, & + idecomp_hmsa_hso5, icase_in ) +#endif + + gas_aqfrac_box(:) = 0.0 + + +! make call to interface_to_aqoperator1 + call interface_to_aqoperator1( & + istat_aqop, & + dtstepc, & + rbox, gas_aqfrac_box, & + rbulk_cwaer, lptr_yyy_cwaer, & + co2_mixrat_in, photol_no2_in, & + iradical_in, idecomp_hmsa_hso5, & + yaq_beg, yaq_end, ph_cmuaq_cur, & + numgas_aqfrac, id, it, jt, kt, kpeg, mpeg, ktau, icase_in ) + + ph_aq_box = ph_cmuaq_cur + + +#if defined ( ccboxtest_box_testing_active) +! following is for off-line box testing only + call ccboxtest_extra_args_bb( 'put', & + yaq_beg, yaq_end, ph_cmuaq_cur ) +#endif + + +! +! +! calculate fraction of cloud-water associated with each activated aerosol bin +! +! + call partition_cldwtr( & + rbox, fr_partit_cw, & + it, jt, kt, kpeg, mpeg, icase_in ) + +! +! +! distribute changes in bulk cloud-water composition among size bins +! +! + call distribute_bulk_changes( & + rbox, rbox_sv1, fr_partit_cw, & + rbulk_cwaer, lptr_yyy_cwaer, & + it, jt, kt, kpeg, mpeg, icase_in ) + + +! +! xfer back to rsub +! + rsub(1:ltot2,kpeg,mpeg) = max( 0.0, rbox(1:ltot2) ) + + +! +! do move-sections +! + if (msectional .lt. 1000000000) then + call cloudchem_apply_move_sections( & + rbox, rbox_sv1, & + it, jt, kt, kpeg, mpeg, icase_in ) + end if + + + + return + end subroutine mosaic_cloudchem_1box + + + +!----------------------------------------------------------------------- + subroutine interface_to_aqoperator1( & + istat_aqop, & + dtstepc, & + rbox, gas_aqfrac_box, & + rbulk_cwaer, lptr_yyy_cwaer, & + co2_mixrat_in, photol_no2_in, iradical_in, idecomp_hmsa_hso5, & + yaq_beg, yaq_end, ph_cmuaq_cur, & + numgas_aqfrac, id, it, jt, kt, kpeg, mpeg, ktau, icase ) + + use module_state_description, only: & + num_chem, param_first_scalar, p_qc, & + p_nh3, p_hno3, p_hcl, p_sulf, p_hcho, & + p_ora1, p_so2, p_h2o2, p_o3, p_ho, & + p_ho2, p_no3, p_no, p_no2, p_hono, & + p_pan, p_ch3o2, p_ch3oh, p_op1 + + use module_data_cmu_bulkaqchem, only: & + meqn1max, naers, ngas, & + na4, naa, nac, nae, nah, nahmsa, nahso5, & + nan, nao, nar, nas, naw, & + ng4, nga, ngc, ngch3co3h, ngch3o2, ngch3o2h, ngch3oh, & + ngh2o2, nghcho, nghcooh, nghno2, ngho2, & + ngn, ngno, ngno2, ngno3, ngo3, ngoh, ngpan, ngso2 + + use module_cmu_bulkaqchem, only: aqoperator1 + + use module_data_mosaic_asect, only: & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_cl_aer, lptr_co3_aer, & + lptr_msa_aer, lptr_nh4_aer, lptr_na_aer, lptr_ca_aer, & + lptr_oin_aer, lptr_bc_aer, lptr_oc_aer, & + mw_cl_aer, mw_na_aer, mw_nh4_aer, mw_no3_aer, mw_so4_aer + + use module_data_mosaic_other, only: & + aboxtest_units_convert, cairclm, & + ktemp, l2maxd, ptotclm, rcldwtr_sub + + + implicit none + +! subr arguments + integer, intent(in) :: & + iradical_in, idecomp_hmsa_hso5, & + numgas_aqfrac, id, it, jt, kt, kpeg, mpeg, ktau, icase + integer, intent(inout) :: & + istat_aqop + + integer, intent(in) :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real, intent(in) :: & + dtstepc, co2_mixrat_in, & + photol_no2_in + + real, intent(inout) :: ph_cmuaq_cur + + real, intent(inout), dimension( 1:l2maxd ) :: rbox + + real, intent(inout), dimension( nyyy, 2 ) :: rbulk_cwaer + + real, intent(inout), dimension( 1:numgas_aqfrac ) :: gas_aqfrac_box + + real, intent(inout), dimension( meqn1max ) :: yaq_beg, yaq_end + + +! local variables + integer :: i, iphase, isize, itype + integer :: iaq, istat_fatal, istat_warn + integer :: l, lunxx, lyyy + integer :: p1st + + real, parameter :: eps=0.622 ! (mw h2o)/(mw air) + + + real :: cair_moleperm3 + real :: dum, dumb + real :: factgas, factlwc, factpatm, factphoto + real :: factaerbc, factaercl, factaerna, factaernh4, & + factaerno3, factaeroc, factaeroin, factaerso4 + real :: lwc + real :: p_atm, photo_in + real :: rh + real :: temp, tstep_beg_sec, tstep_end_sec + real :: totsulf_beg, totsulf_end + real :: gas(ngas), aerosol(naers) + real :: gas_aqfrac_cmu(ngas) + + double precision tstep_beg_sec_dp, tstep_end_sec_dp, & + temp_dp, p_atm_dp, lwc_dp, rh_dp, & + co2_mixrat_in_dp, photo_in_dp, ph_cmuaq_cur_dp + double precision gas_dp(ngas), gas_aqfrac_cmu_dp(ngas), & + aerosol_dp(naers), yaq_beg_dp(meqn1max), yaq_end_dp(meqn1max) + + + + p1st = param_first_scalar + +! +! units conversion factors +! 'cmuaq-bulk' value = pegasus value X factor +! +! [pres in atmospheres] = [pres in dynes/cm2] * factpatm + factpatm = 1.0/1.01325e6 +! [cldwtr in g-h2o/m3-air] = [cldwtr in mole-h2o/mole-air] * factlwc + factlwc = 28.966*eps*1.0e6*cairclm(kpeg) +! [aq photolysis rate scaling factor in --] = [jno2 in 1/min] * factphoto + factphoto = 1.6 + +! [gas in ppm] = [gas in mole/mole-air] * factgas + factgas = 1.0e6 + +! [aerosol in ug/m3-air] = [aerosol in mole/mole-air] * factaer + dum = cairclm(kpeg)*1.0e12 + factaerso4 = dum*mw_so4_aer + factaerno3 = dum*mw_no3_aer + factaercl = dum*mw_cl_aer + factaernh4 = dum*mw_nh4_aer + factaerna = dum*mw_na_aer + factaeroin = dum + factaeroc = dum + factaerbc = dum + +! rce 2005-jul-11 - use same molecular weights here as in cmu code +! factaerso4 = dum*96.0 +! factaerno3 = dum*62.0 +! factaercl = dum*35.5 +! factaernh4 = dum*18.0 +! factaerna = dum*23.0 + +! If aboxtest_units_convert=10, turn off units conversions both here +! and in module_mosaic. This is for testing, to allow exact agreements. + if (aboxtest_units_convert .eq. 10) then + factpatm = 1.0 + factlwc = 1.0 + factphoto = 1.0 + factgas = 1.0 + factaerso4 = 1.0 + factaerno3 = 1.0 + factaercl = 1.0 + factaernh4 = 1.0 + factaerna = 1.0 + factaeroin = 1.0 + factaeroc = 1.0 + factaerbc = 1.0 + end if + +! +! map from rbox to gas,aerosol +! + temp = rbox(ktemp) + + lwc = rcldwtr_sub(kpeg,mpeg) * factlwc + p_atm = ptotclm(kpeg) * factpatm + +! rce 2005-jul-11 - set p_atm so that cmu code's cair will match cairclm + p_atm = cairclm(kpeg)*1.0e3*0.082058e0*temp + + photo_in = photol_no2_in * factphoto + + rh = 1.0 + iaq = 1 + + tstep_beg_sec = 0.0 + tstep_end_sec = dtstepc + +! map gases and convert to ppm + gas(:) = 0.0 + + gas(nga ) = rbox(p_nh3 ) * factgas + gas(ngn ) = rbox(p_hno3 ) * factgas + gas(ngc ) = rbox(p_hcl ) * factgas + gas(ng4 ) = rbox(p_sulf ) * factgas + + gas(nghcho ) = rbox(p_hcho ) * factgas + gas(nghcooh ) = rbox(p_ora1 ) * factgas + gas(ngso2 ) = rbox(p_so2 ) * factgas + gas(ngh2o2 ) = rbox(p_h2o2 ) * factgas + gas(ngo3 ) = rbox(p_o3 ) * factgas + gas(ngoh ) = rbox(p_ho ) * factgas + gas(ngho2 ) = rbox(p_ho2 ) * factgas + gas(ngno3 ) = rbox(p_no3 ) * factgas + + gas(ngno ) = rbox(p_no ) * factgas + gas(ngno2 ) = rbox(p_no2 ) * factgas + gas(nghno2 ) = rbox(p_hono ) * factgas + gas(ngpan ) = rbox(p_pan ) * factgas + gas(ngch3o2 ) = rbox(p_ch3o2 ) * factgas + gas(ngch3oh ) = rbox(p_ch3oh ) * factgas + gas(ngch3o2h) = rbox(p_op1 ) * factgas + +! compute bulk activated-aerosol mixing ratios + aerosol(:) = 0.0 + rbulk_cwaer(:,:) = 0.0 + + iphase = cw_phase + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + + do lyyy = 1, nyyy + + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) rbulk_cwaer(lyyy,1) = rbulk_cwaer(lyyy,1) + rbox(l) + + end do + + end do + end do + +! map them to 'aerosol' array and convert to ug/m3 + aerosol(na4) = rbulk_cwaer(l_so4_aqyy,1) * factaerso4 + aerosol(nan) = rbulk_cwaer(l_no3_aqyy,1) * factaerno3 + aerosol(nac) = rbulk_cwaer(l_cl_aqyy, 1) * factaercl + aerosol(naa) = rbulk_cwaer(l_nh4_aqyy,1) * factaernh4 + aerosol(nas) = rbulk_cwaer(l_na_aqyy, 1) * factaerna + aerosol(nar) = rbulk_cwaer(l_oin_aqyy,1) * factaeroin + aerosol(nae) = rbulk_cwaer(l_bc_aqyy, 1) * factaerbc + aerosol(nao) = rbulk_cwaer(l_oc_aqyy, 1) * factaeroc + + +! +! make call to aqoperator1 +! +#if defined ( ccboxtest_box_testing_active) + lunxx = 87 + lunxx = -1 + if (lunxx .gt. 0) then + write(lunxx,*) + write(lunxx,*) + write(lunxx,*) 'interface_to_aqoperator1 - icase, irad, idecomp' + write(lunxx,9870) icase, iradical_in, idecomp_hmsa_hso5 + write(lunxx,*) 'it, jt, kt, kpeg, mpeg, ktau' + write(lunxx,9870) it, jt, kt, kpeg, mpeg, ktau + write(lunxx,*) 'temp, p_atm, lwc, photo, co2' + write(lunxx,9875) temp, p_atm, lwc, photo_in, co2_mixrat_in + write(lunxx,*) 'ptot, cair, rcldwtr_clm, dt_sec' + write(lunxx,9875) ptotclm(kpeg), cairclm(kpeg), & + rcldwtr_sub(kpeg,mpeg), (tstep_end_sec-tstep_beg_sec) + write(lunxx,*) 'gas (1=nh3, 2=hno3, 3=hcl, 4=h2so4, 11=so2, 12=h2o2, 18=o3)' + write(lunxx,9875) gas + write(lunxx,*) 'rbox(nh3, hno3, hcl, h2so4, so2, h2o2, o3)' + write(lunxx,9875) rbox(p_nh3), rbox(p_hno3), rbox(p_hcl), & + rbox(p_sulf), rbox(p_so2), rbox(p_h2o2), rbox(p_o3) + write(lunxx,*) 'aerosol (1=na, 3=nh4, 4=no3, 5=cl, 6=so4, 8=ec, 9=oc, 10=crus)' + write(lunxx,9875) aerosol + write(lunxx,*) 'rbulk_cwaer (1=so4, 2=no3, 3-cl, 4=nh4, 5=na, 6=oin, 7=bc, 8=oc)' + write(lunxx,9875) rbulk_cwaer(:,1) +! if (icase .ge. 3) then +! write(*,*) & +! '*** stopping in interface_to_aqop1 at icase =', icase +! stop +! end if + end if +9870 format( 8i5 ) +9875 format( 5(1pe14.6) ) +#endif + +#if 0 +! Print outs for debugging of aqoperator1... wig, 26-Oct-2005 +!!$ if( (id == 1 .and. ktau >= 207 ) .or. & +!!$ (id == 2 .and. ktau >= 610 ) .or. & +!!$ (id == 3 .and. ktau >= 1830 ) ) then + write(6,'(a)') '---Begin input for aqoperator1---' + write(6,'(a,4i)') 'id, it, jt, kt =', id, it, jt, kt + write(6,'(a,1p,2e20.12)') 'tstep_beg_sec, tstep_end_sec = ',tstep_beg_sec, tstep_end_sec + do l=1,ngas + write(6,'("gas(",i2,") = ",1p,1e20.12)') l, gas(l) + end do + do l=1,naers + write(6,'("aerosol(",i2,") = ",1p,1e20.12)') l, aerosol(l) + end do + write(6,'(a,1p,4e20.12)') "temp, p_atm, lwc, rh = ", temp, p_atm, lwc, rh + write(6,'(a,1p,2e20.12)') "co2_mixrat_in, photo_in = ", co2_mixrat_in, photo_in + write(6,'(a,3i)') " iradical_in, idecomp_hmsa_hso5, iaq = ", iradical_in, idecomp_hmsa_hso5, iaq + write(6,'(a)') "---End input for aqoperator1---" +!!$ end if +#endif + + +! convert arguments to double prec + tstep_beg_sec_dp = 0.0d0 + if (tstep_beg_sec .ne. 0.0) tstep_beg_sec_dp = tstep_beg_sec + tstep_end_sec_dp = 0.0d0 + if (tstep_end_sec .ne. 0.0) tstep_end_sec_dp = tstep_end_sec + temp_dp = 0.0d0 + if (temp .ne. 0.0) temp_dp = temp + p_atm_dp = 0.0d0 + if (p_atm .ne. 0.0) p_atm_dp = p_atm + lwc_dp = 0.0d0 + if (lwc .ne. 0.0) lwc_dp = lwc + rh_dp = 0.0d0 + if (rh .ne. 0.0) rh_dp = rh + co2_mixrat_in_dp = 0.0d0 + if (co2_mixrat_in .ne. 0.0) co2_mixrat_in_dp = co2_mixrat_in + photo_in_dp = 0.0d0 + if (photo_in .ne. 0.0) photo_in_dp = photo_in + ph_cmuaq_cur_dp = 0.0d0 + if (ph_cmuaq_cur .ne. 0.0) ph_cmuaq_cur_dp = ph_cmuaq_cur + + do i = 1, ngas + gas_dp(i) = 0.0d0 + if (gas(i) .ne. 0.0) gas_dp(i) = gas(i) + end do + do i = 1, naers + aerosol_dp(i) = 0.0d0 + if (aerosol(i) .ne. 0.0) aerosol_dp(i) = aerosol(i) + end do + do i = 1, ngas + gas_aqfrac_cmu_dp(i) = 0.0d0 + if (gas_aqfrac_cmu(i) .ne. 0.0) gas_aqfrac_cmu_dp(i) = gas_aqfrac_cmu(i) + end do + do i = 1, meqn1max + yaq_beg_dp(i) = 0.0d0 + if (yaq_beg(i) .ne. 0.0) yaq_beg_dp(i) = yaq_beg(i) + end do + do i = 1, meqn1max + yaq_end_dp(i) = 0.0d0 + if (yaq_end(i) .ne. 0.0) yaq_end_dp(i) = yaq_end(i) + end do + + +! total sulfur species conc as sulfate (ug/m3) + cair_moleperm3 = 1.0e3*p_atm_dp/(0.082058e0*temp_dp) + totsulf_beg = ( aerosol_dp(na4)/96. & + + aerosol_dp(nahso5)/113. + aerosol_dp(nahmsa)/111. & + + (gas_dp(ngso2) + gas_dp(ng4))*cair_moleperm3 )*96.0 + +! call aqoperator1( & +! istat_fatal, istat_warn, & +! tstep_beg_sec, tstep_end_sec, & +! gas, aerosol, gas_aqfrac_cmu, & +! temp, p_atm, lwc, rh, & +! co2_mixrat_in, photo_in, iradical_in, idecomp_hmsa_hso5, iaq, & +! yaq_beg, yaq_end, ph_cmuaq_cur ) + + call aqoperator1( & + istat_fatal, istat_warn, & + tstep_beg_sec_dp, tstep_end_sec_dp, & + gas_dp, aerosol_dp, gas_aqfrac_cmu_dp, & + temp_dp, p_atm_dp, lwc_dp, rh_dp, & + co2_mixrat_in_dp, photo_in_dp, iradical_in, idecomp_hmsa_hso5, iaq, & + yaq_beg_dp, yaq_end_dp, ph_cmuaq_cur_dp ) + + totsulf_end = ( aerosol_dp(na4)/96. & + + aerosol_dp(nahso5)/113. + aerosol_dp(nahmsa)/111. & + + (gas_dp(ngso2) + gas_dp(ng4))*cair_moleperm3 )*96.0 + + +! convert arguments back to single prec + tstep_beg_sec = tstep_beg_sec_dp + tstep_end_sec = tstep_end_sec_dp + temp = temp_dp + p_atm = p_atm_dp + lwc = lwc_dp + rh = rh_dp +! co2_mixrat_in = co2_mixrat_in_dp ! this has intent(in) +! photo_in = photo_in_dp ! this has intent(in) + ph_cmuaq_cur = ph_cmuaq_cur_dp + + do i = 1, ngas + gas(i) = gas_dp(i) + end do + do i = 1, naers + aerosol(i) = aerosol_dp(i) + end do + do i = 1, ngas + gas_aqfrac_cmu(i) = gas_aqfrac_cmu_dp(i) + end do + do i = 1, meqn1max + yaq_beg(i) = yaq_beg_dp(i) + end do + do i = 1, meqn1max + yaq_end(i) = yaq_end_dp(i) + end do + + +! +! warning message when status flags are non-zero +! + istat_aqop = 0 + if (istat_fatal .ne. 0) then + write(6,*) & + '*** mosaic_cloudchem_driver, subr interface_to_aqoperator1' + write(6,'(a,4i5,2i10)') & + ' id,it,jt,kt, istat_fatal, warn =', & + id, it, jt, kt, istat_fatal, istat_warn + istat_aqop = -10 + end if + +! +! warning message when sulfur mass balance error exceeds the greater +! of (1.0e-3 ug/m3) OR (1.0e-3 X total sulfur mixing ratio) +! + dum = totsulf_end - totsulf_beg + dumb = max( totsulf_beg, totsulf_end ) + if (abs(dum) .gt. max(1.0e-3,1.0e-3*dumb)) then + write(6,*) & + '*** mosaic_cloudchem_driver, sulfur balance warning' + write(6,'(a,4i5,1p,3e12.4)') & + ' id,it,jt,kt, total_sulfur_beg, _end, _error =', & + id, it, jt, kt, totsulf_beg, totsulf_end, dum + end if + +! +! map from gas,aerosol to rbox +! + rbox(p_nh3 ) = gas(nga ) / factgas + rbox(p_hno3 ) = gas(ngn ) / factgas + rbox(p_hcl ) = gas(ngc ) / factgas + rbox(p_sulf ) = gas(ng4 ) / factgas + + rbox(p_hcho ) = gas(nghcho ) / factgas + rbox(p_ora1 ) = gas(nghcooh ) / factgas + rbox(p_so2 ) = gas(ngso2 ) / factgas + rbox(p_h2o2 ) = gas(ngh2o2 ) / factgas + rbox(p_o3 ) = gas(ngo3 ) / factgas + rbox(p_ho ) = gas(ngoh ) / factgas + rbox(p_ho2 ) = gas(ngho2 ) / factgas + rbox(p_no3 ) = gas(ngno3 ) / factgas + + rbox(p_no ) = gas(ngno ) / factgas + rbox(p_no2 ) = gas(ngno2 ) / factgas + rbox(p_hono ) = gas(nghno2 ) / factgas + rbox(p_pan ) = gas(ngpan ) / factgas + rbox(p_ch3o2 ) = gas(ngch3o2 ) / factgas + rbox(p_ch3oh ) = gas(ngch3oh ) / factgas + rbox(p_op1 ) = gas(ngch3o2h) / factgas + + gas_aqfrac_box(:) = 0.0 + + if (p_nh3 .le. numgas_aqfrac) & + gas_aqfrac_box(p_nh3 ) = gas_aqfrac_cmu(nga ) + if (p_hno3 .le. numgas_aqfrac) & + gas_aqfrac_box(p_hno3 ) = gas_aqfrac_cmu(ngn ) + if (p_hcl .le. numgas_aqfrac) & + gas_aqfrac_box(p_hcl ) = gas_aqfrac_cmu(ngc ) + if (p_sulf .le. numgas_aqfrac) & + gas_aqfrac_box(p_sulf ) = gas_aqfrac_cmu(ng4 ) + + if (p_hcho .le. numgas_aqfrac) & + gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) + if (p_ora1 .le. numgas_aqfrac) & + gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) + if (p_so2 .le. numgas_aqfrac) & + gas_aqfrac_box(p_so2 ) = gas_aqfrac_cmu(ngso2 ) + if (p_h2o2 .le. numgas_aqfrac) & + gas_aqfrac_box(p_h2o2 ) = gas_aqfrac_cmu(ngh2o2 ) + if (p_o3 .le. numgas_aqfrac) & + gas_aqfrac_box(p_o3 ) = gas_aqfrac_cmu(ngo3 ) + if (p_ho .le. numgas_aqfrac) & + gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) + if (p_ho2 .le. numgas_aqfrac) & + gas_aqfrac_box(p_ho2 ) = gas_aqfrac_cmu(ngho2 ) + if (p_no3 .le. numgas_aqfrac) & + gas_aqfrac_box(p_no3 ) = gas_aqfrac_cmu(ngno3 ) + + if (p_no .le. numgas_aqfrac) & + gas_aqfrac_box(p_no ) = gas_aqfrac_cmu(ngno ) + if (p_no2 .le. numgas_aqfrac) & + gas_aqfrac_box(p_no2 ) = gas_aqfrac_cmu(ngno2 ) + if (p_hono .le. numgas_aqfrac) & + gas_aqfrac_box(p_hono ) = gas_aqfrac_cmu(nghno2 ) + if (p_pan .le. numgas_aqfrac) & + gas_aqfrac_box(p_pan ) = gas_aqfrac_cmu(ngpan ) + if (p_ch3o2 .le. numgas_aqfrac) & + gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) + if (p_ch3oh .le. numgas_aqfrac) & + gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) + if (p_op1 .le. numgas_aqfrac) & + gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) + + rbulk_cwaer(l_so4_aqyy,2) = aerosol(na4) / factaerso4 + rbulk_cwaer(l_no3_aqyy,2) = aerosol(nan) / factaerno3 + rbulk_cwaer(l_cl_aqyy, 2) = aerosol(nac) / factaercl + rbulk_cwaer(l_nh4_aqyy,2) = aerosol(naa) / factaernh4 + rbulk_cwaer(l_na_aqyy, 2) = aerosol(nas) / factaerna + rbulk_cwaer(l_oin_aqyy,2) = aerosol(nar) / factaeroin + rbulk_cwaer(l_bc_aqyy, 2) = aerosol(nae) / factaerbc + rbulk_cwaer(l_oc_aqyy, 2) = aerosol(nao) / factaeroc + + +#if defined ( ccboxtest_box_testing_active) + lunxx = 87 + lunxx = -1 + if (lunxx .gt. 0) then + write(lunxx,*) + write(lunxx,*) 'interface_to_aqoperator1 - after call' + write(lunxx,*) 'gas (1=nh3, 2=hno3, 3=hcl, 4=h2so4, 11=so2, 12=h2o2, 18=o3)' + write(lunxx,9875) gas + write(lunxx,*) 'rbox(nh3, hno3, hcl, h2so4, so2, h2o2, o3)' + write(lunxx,9875) rbox(p_nh3), rbox(p_hno3), rbox(p_hcl), & + rbox(p_sulf), rbox(p_so2), rbox(p_h2o2), rbox(p_o3) + write(lunxx,*) 'aerosol (1=na, 3=nh4, 4=no3, 5=cl, 6=so4, 8=ec, 9=oc, 10=crus)' + write(lunxx,9875) aerosol + write(lunxx,*) 'rbulk_cwaer (1=so4, 2=no3, 3-cl, 4=nh4, 5=na, 6=oin, 7=bc, 8=oc)' + write(lunxx,9875) rbulk_cwaer(:,2) + write(lunxx,*) 'ph_cmuaq_cur' + write(lunxx,9875) ph_cmuaq_cur + if (icase .ge. 10) then + write(*,*) & + '*** stopping in interface_to_aqop1 at icase =', icase + stop + end if + end if +#endif + + + return + end subroutine interface_to_aqoperator1 + + + +!----------------------------------------------------------------------- + subroutine partition_cldwtr( & + rbox, fr_partit_cw, & + it, jt, kt, kpeg, mpeg, icase ) + + use module_data_mosaic_asect, only: & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, ncomp_aer, & + massptr_aer, numptr_aer, & + dens_aer, mw_aer, volumlo_sect, volumhi_sect + + use module_data_mosaic_other, only: & + aboxtest_units_convert, cairclm, & + ktemp, l2maxd, ptotclm, rcldwtr_sub + + + implicit none + +! subr arguments + integer, intent(in) :: it, jt, kt, kpeg, mpeg, icase + + real, intent(inout), dimension( 1:l2maxd ) :: rbox + + real, intent(inout), dimension( maxd_asize, maxd_atype ) :: & + fr_partit_cw + +! local variables + integer :: iphase, isize, itype + integer :: jdone_mass, jdone_numb, jpos, jpos_mass, jpos_numb + integer :: l, ll, lunxx + integer :: p1st + + real, parameter :: partit_wght_mass = 0.5 + + real :: dum, duma, dumb, dumc, dummass, dumnumb, dumvolu + real :: tmass, tnumb, umass, unumb, wmass, wnumb + real, dimension( maxd_asize, maxd_atype ) :: fmass, fnumb, xmass, xnumb + + + + iphase = cw_phase + tmass = 0.0 + tnumb = 0.0 + umass = 0.0 + unumb = 0.0 + +! compute +! xmass, xnumb = mass, number mixing ratio for a bin +! tmass, tnumb = sum over all bins of xmass, xnumb +! umass, unumb = max over all bins of xmass, xnumb +! set xmass, xnumb = 0.0 if bin mass, numb < 1.0e-37 +! constrain xnumb so that mean particle volume is +! within bin boundaries + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + dummass = 0.0 + dumvolu = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + if (l .ge. p1st) then + dum = max( 0.0, rbox(l) )*mw_aer(ll,itype) + dummass = dummass + dum + dumvolu = dumvolu + dum/dens_aer(ll,itype) + end if + end do + + l = numptr_aer(isize,itype,iphase) + dumnumb = max( 0.0, rbox(l) ) + if (dumnumb .gt. dumvolu/volumlo_sect(isize,itype)) then + dumnumb = dumvolu/volumlo_sect(isize,itype) + rbox(l) = dumnumb + else if (dumnumb .lt. dumvolu/volumhi_sect(isize,itype)) then + dumnumb = dumvolu/volumhi_sect(isize,itype) + rbox(l) = dumnumb + end if + + if (dummass .lt. 1.0e-37) dummass = 0.0 + xmass(isize,itype) = dummass + if (dumnumb .lt. 1.0e-37) dumnumb = 0.0 + xnumb(isize,itype) = dumnumb + + tmass = tmass + xmass(isize,itype) + tnumb = tnumb + xnumb(isize,itype) + umass = max( umass, xmass(isize,itype) ) + unumb = max( unumb, xnumb(isize,itype) ) + end do + end do + +! compute +! fmass, fnumb = fraction of total mass, number that is in a bin +! if tmass<1e-35 and umass>0, set fmass=1 for bin with largest xmass +! if tmass<1e-35 and umass=0, set fmass=0 for all + jdone_mass = 0 + jdone_numb = 0 + jpos_mass = 0 + jpos_numb = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + fmass(isize,itype) = 0.0 + if (tmass .ge. 1.0e-35) then + fmass(isize,itype) = xmass(isize,itype)/tmass + else if (umass .gt. 0.0) then + if ( (jdone_mass .eq. 0) .and. & + (xmass(isize,itype) .eq. umass) ) then + jdone_mass = 1 + fmass(isize,itype) = 1.0 + end if + end if + if (fmass(isize,itype) .gt. 0) jpos_mass = jpos_mass + 1 + + fnumb(isize,itype) = 0.0 + if (tnumb .ge. 1.0e-35) then + fnumb(isize,itype) = xnumb(isize,itype)/tnumb + else if (unumb .gt. 0.0) then + if ( (jdone_numb .eq. 0) .and. & + (xnumb(isize,itype) .eq. unumb) ) then + jdone_numb = 1 + fnumb(isize,itype) = 1.0 + end if + end if + if (fnumb(isize,itype) .gt. 0) jpos_numb = jpos_numb + 1 + end do + end do + +! if only 1 bin has fmass or fnumb > 0, set value to 1.0 exactly + if ((jpos_mass .eq. 1) .or. (jpos_numb .eq. 1)) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if (jpos_mass .eq. 1) then + if (fmass(isize,itype) .gt. 0) fmass(isize,itype) = 1.0 + end if + if (jpos_numb .eq. 1) then + if (fnumb(isize,itype) .gt. 0) fnumb(isize,itype) = 1.0 + end if + end do + end do + end if + +! +! compute fr_partit_cw as weighted average of fmass & fnumb, except +! if tmass<1e-35 and umass=0, use only fnumb +! if tnumb<1e-35 and unumb=0, use only fmass +! if tmass,tnumb<1e-35 and umass,unumb=0, +! set fr_partit_cw=1 for center bin of itype=1 +! + fr_partit_cw(:,:) = 0.0 + if ((jpos_mass .eq. 0) .and. (jpos_numb .eq. 0)) then + itype = 1 + isize = (nsize_aer(itype)+1)/2 + fr_partit_cw(isize,itype) = 1.0 + + else if (jpos_mass .eq. 0) then + fr_partit_cw(:,:) = fnumb(:,:) + + else if (jpos_numb .eq. 0) then + fr_partit_cw(:,:) = fmass(:,:) + + else + wmass = max( 0.0, min( 1.0, partit_wght_mass ) ) + wnumb = 1.0 - wmass + fr_partit_cw(:,:) = wmass*fmass(:,:) + wnumb*fnumb(:,:) + + jpos = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if (fr_partit_cw(isize,itype) .gt. 0.0) jpos = jpos + 1 + end do + end do + +! if only 1 bin has fr_partit_cw > 0, set value to 1.0 exactly + if (jpos .eq. 1) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if (fr_partit_cw(isize,itype) .gt. 0.0) & + fr_partit_cw(isize,itype) = 1.0 + end do + end do + end if + end if + + +#if defined ( ccboxtest_box_testing_active) +! diagnostics when lunxx > 0 + lunxx = 86 + lunxx = -1 + if (lunxx .gt. 0) then + if (icase .le. 9) then + write(lunxx,9800) + write(lunxx,9800) + write(lunxx,9800) & + 'partition_cldwtr - icase, jpos, jpos_mass, jpos_numb' + write(lunxx,9810) icase, jpos, jpos_mass, jpos_numb + write(lunxx,9800) 'tmass, umass, wmass' + write(lunxx,9820) tmass, umass, wmass + write(lunxx,9800) 'tnumb, unumb, wnumb' + write(lunxx,9820) tnumb, unumb, wnumb + write(lunxx,9800) 'xmass, fmass, xnumb, fnumb, fr_partit_cw' + duma = 0.0 + dumb = 0.0 + dumc = 0.0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + write(lunxx,9820) xmass(isize,itype), fmass(isize,itype), & + xnumb(isize,itype), fnumb(isize,itype), & + fr_partit_cw(isize,itype) + duma = duma + fmass(isize,itype) + dumb = dumb + fnumb(isize,itype) + dumc = dumc + fr_partit_cw(isize,itype) + end do + end do + write(lunxx,9800) & + 'sum_fmass-1.0, sum_fnumb-1.0, sum_fr_partit-1.0' + write(lunxx,9820) (duma-1.0), (dumb-1.0), (dumc-1.0) + if (icase .eq. -2) then + write(*,*) '*** stopping in partition_cldwtr at icase =', icase + stop + end if +9800 format( a ) +9810 format( 5i10 ) +9820 format( 5(1pe10.2) ) + end if + end if +#endif + + + return + end subroutine partition_cldwtr + + + +!----------------------------------------------------------------------- + subroutine distribute_bulk_changes( & + rbox, rbox_sv1, fr_partit_cw, & + rbulk_cwaer, lptr_yyy_cwaer, & + it, jt, kt, kpeg, mpeg, icase ) + + use module_state_description, only: & + param_first_scalar + + use module_data_mosaic_asect, only: & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_cl_aer, lptr_co3_aer, & + lptr_msa_aer, lptr_nh4_aer, lptr_na_aer, lptr_ca_aer, & + lptr_oin_aer, lptr_bc_aer, lptr_oc_aer + + use module_data_mosaic_other, only: l2maxd, lunout, name + + + implicit none + +! subr arguments + integer, intent(in) :: it, jt, kt, kpeg, mpeg, icase + + integer, intent(in) :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real, intent(inout), dimension( 1:l2maxd ) :: rbox, rbox_sv1 + + real, intent(in), dimension( maxd_asize, maxd_atype ) :: & + fr_partit_cw + + real, intent(in), dimension( nyyy, 2 ) :: rbulk_cwaer + + +! local variables + integer :: iphase, isize, itype + integer :: idone, icount, ncount + integer :: jpos, jpos_sv + integer :: l, lunxx, lunxxaa, lunxxbb, lyyy + integer :: p1st + + real :: duma, dumb, dumc + real :: fr, frsum_cur + real :: fr_cur(maxd_asize,maxd_atype) + real :: del_r_current, del_r_remain + real :: del_rbulk_cwaer(nyyy) + + + p1st = param_first_scalar + + do lyyy = 1, nyyy + del_rbulk_cwaer(lyyy) = rbulk_cwaer(lyyy,2) - rbulk_cwaer(lyyy,1) + end do + + iphase = cw_phase + + + jpos = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if (fr_partit_cw(isize,itype) .gt. 0) jpos = jpos + 1 + end do + end do + jpos_sv = jpos + +! +! distribution is trivial when only 1 bin has fr_partit_cw > 0 +! + if (jpos_sv .eq. 1) then + do lyyy = 1, nyyy + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + fr = fr_partit_cw(isize,itype) + if (fr .eq. 1.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) rbox(l) = rbulk_cwaer(lyyy,2) + end if + end do + end do + + end do + goto 7900 + end if + + + do 3900 lyyy = 1, nyyy + +! +! distribution is simple when del_rbulk_cwaer(lyyy) >= 0 +! + if (del_rbulk_cwaer(lyyy) .eq. 0.0) then + goto 3900 + else if (del_rbulk_cwaer(lyyy) .gt. 0.0) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + fr = fr_partit_cw(isize,itype) + if (fr .gt. 0.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) then + rbox(l) = rbox(l) + fr*del_rbulk_cwaer(lyyy) + end if + end if + end do + end do + + goto 3900 + end if + +! +! distribution is complicated when del_rbulk_cwaer(lyyy) < 0, +! because you cannot produce any negative mixrats +! + del_r_remain = del_rbulk_cwaer(lyyy) + fr_cur(:,:) = fr_partit_cw(:,:) + + ncount = max( 1, jpos_sv*2 ) + icount = 0 + +! iteration loop + do while (icount .le. ncount) + + icount = icount + 1 + del_r_current = del_r_remain + jpos = 0 + frsum_cur = 0.0 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + + fr = fr_cur(isize,itype) + + if (fr .gt. 0.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) then + duma = fr*del_r_current + dumb = rbox(l) + duma + if (dumb .gt. 0.0) then + jpos = jpos + 1 + else if (dumb .eq. 0.0) then + fr_cur(isize,itype) = 0.0 + else + duma = -rbox(l) + dumb = 0.0 + fr_cur(isize,itype) = 0.0 + end if + del_r_remain = del_r_remain - duma + rbox(l) = dumb + frsum_cur = frsum_cur + fr_cur(isize,itype) + else + fr_cur(isize,itype) = 0.0 + end if + end if + + end do ! isize = 1, nsize_aer + end do ! itype = 1, ntype_aer + +! done if jpos = jpos_sv, because bins reached zero mixrat + if (jpos .eq. jpos_sv) then + idone = 1 +! del_r_remain starts as negative, so done if non-negative + else if (del_r_remain .ge. 0.0) then + idone = 2 +! del_r_remain starts as negative, so done if non-negative + else if (abs(del_r_remain) .le. 1.0e-7*abs(del_rbulk_cwaer(lyyy))) then + idone = 3 +! done if all bins have fr_cur = 0 + else if (frsum_cur .le. 0.0) then + idone = 4 +! same thing basically + else if (jpos .le. 0) then + idone = 5 + else + idone = 0 + end if + +! check for done, and (conditionally) print message + if (idone .gt. 0) then + lunxxaa = 6 +#if defined ( ccboxtest_box_testing_active) + lunxxaa = 86 +#endif + if ((lunxxaa .gt. 0) .and. (icount .gt. (1+jpos_sv)/2)) then + write(lunxxaa,9800) & + 'distribute_bulk_changes - icount>jpos_sv/2 - i,j,k' + write(lunxxaa,9810) it, jt, kt + write(lunxxaa,9800) 'icase, lyyy, idone, icount, jpos, jpos_sv' + write(lunxxaa,9810) icase, lyyy, idone, icount, jpos, jpos_sv + end if + goto 3900 + end if + +! rescale fr_cur for next iteration + fr_cur(:,:) = fr_cur(:,:)/frsum_cur + + end do ! while (icount .le. ncount) + + +! icount > ncount, so print message + lunxxbb = 6 +#if defined ( ccboxtest_box_testing_active) + lunxxbb = 86 +#endif + if (lunxxbb .gt. 0) then + write(lunxxbb,9800) + write(lunxxbb,9800) & + 'distribute_bulk_changes - icount>ncount - i,j,k' + write(lunxxbb,9810) it, jt, kt + write(lunxxbb,9800) 'icase, lyyy, icount, ncount, jpos_sv, jpos' + write(lunxxbb,9810) icase, lyyy, icount, ncount, jpos_sv, jpos + write(lunxxbb,9800) 'rbulk_cwaer(1), del_rbulk_cwaer, del_r_remain, frsum_cur, (frsum_cur-1.0)' + write(lunxxbb,9820) rbulk_cwaer(lyyy,1), del_rbulk_cwaer(lyyy), & + del_r_remain, frsum_cur, (frsum_cur-1.0) + end if +9800 format( a ) +9810 format( 7i10 ) +9820 format( 7(1pe10.2) ) +9840 format( 2i3, 5(1pe14.6) ) + + +3900 continue + +7900 continue + + +#if defined ( ccboxtest_box_testing_active) +! diagnostics for testing + lunxx = 88 + lunxx = -1 + if (lunxx .gt. 0) then + icount = 0 + do lyyy = 1, nyyy + duma = del_rbulk_cwaer(lyyy) + if ( abs(duma) .gt. & + max( 1.0e-35, 1.0e-5*abs(rbulk_cwaer(lyyy,1)) ) ) then + icount = icount + 1 + if (icount .eq. 1) write(lunxx,9800) + if (icount .eq. 1) write(lunxx,9800) + write(lunxx,9800) + write(lunxx,9801) 'distribute_bulk_changes - ',name(lptr_yyy_cwaer(1,1,lyyy)), ' - icase, lyyy' + write(lunxx,9810) icase, lyyy + write(lunxx,9800) ' tp sz rbox_sv1, rbox, del_rbox, del_rbox/del_rbulk_cwaer, (...-fr_partit_cw)' + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + l = lptr_yyy_cwaer(isize,itype,lyyy) + dumb = rbox(l) - rbox_sv1(l) + dumc = dumb/max( abs(duma), 1.0e-35 ) + if (duma .lt. 0.0) dumc = -dumc + write(lunxx,9840) itype, isize, rbox_sv1(l), rbox(l), & + dumb, dumc, (dumc-fr_partit_cw(isize,itype)) + end do + end do + end if + end do + if (icase .ge. 5) then + write(*,*) & + '*** stop in distribute_bulk_changes diags, icase =', icase + stop + end if + end if +#endif + + + return + end subroutine distribute_bulk_changes + + + +!----------------------------------------------------------------------- + subroutine cloudchem_apply_move_sections( & + rbox, rbox_sv1, & + it, jt, kt, kpeg, mpeg, icase ) + + use module_state_description, only: & + param_first_scalar + + use module_data_mosaic_asect, only: & + msectional, & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, ncomp_aer, & + massptr_aer, numptr_aer, mw_aer, dens_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_cl_aer, lptr_co3_aer, & + lptr_msa_aer, lptr_nh4_aer, lptr_na_aer, lptr_ca_aer, & + lptr_oin_aer, lptr_bc_aer, lptr_oc_aer, & + drymass_aftgrow, drymass_pregrow, & + drydens_aftgrow, drydens_pregrow + + use module_data_mosaic_other, only: l2maxd, name, rsub + + use module_mosaic_movesect, only: move_sections + + + implicit none + +! subr arguments + integer, intent(in) :: it, jt, kt, kpeg, mpeg, icase + + real, intent(inout), dimension( 1:l2maxd ) :: rbox, rbox_sv1 + + +! local variables + integer :: idum_msect + integer :: iphase, isize, itype + integer :: l, ll, lunxx + integer :: p1st + integer :: lptr_dum(maxd_asize,maxd_atype) + + real :: densdefault + real :: dmaft, dmpre, dvaft, dvpre + real :: duma, dumb, dumc + real :: smallmassbb + + + p1st = param_first_scalar + iphase = cw_phase + +! +! compute drymass before and after growth +! set drydens = -1.0, so it will be calculated +! + densdefault = 2.0 + smallmassbb = 1.0e-30 + + do 1800 itype = 1, ntype_aer + do 1800 isize = 1, nsize_aer(itype) + dmaft = 0.0 + dmpre = 0.0 + dvaft = 0.0 + dvpre = 0.0 + + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + if (l .ge. p1st) then + duma = mw_aer(ll,itype) + dmaft = dmaft + duma*rbox(l) + dmpre = dmpre + duma*rbox_sv1(l) + + duma = duma/dens_aer(ll,itype) + dvaft = dvaft + duma*rbox(l) + dvpre = dvpre + duma*rbox_sv1(l) + end if + end do + + drymass_aftgrow(isize,itype) = dmaft + drymass_pregrow(isize,itype) = dmpre + + if (min(dmaft,dvaft) .le. smallmassbb) then + drydens_aftgrow(isize,itype) = densdefault + else + drydens_aftgrow(isize,itype) = dmaft/dvaft + end if + if (min(dmpre,dvpre) .le. smallmassbb) then + drydens_pregrow(isize,itype) = densdefault + else + drydens_pregrow(isize,itype) = dmpre/dvpre + end if + +1800 continue + + +! apply move sections routine +! (and conditionally turn on movesect diagnostics) + idum_msect = msectional + +#if defined ( ccboxtest_box_testing_active ) + lunxx = 88 + lunxx = -1 + if (lunxx .gt. 0) then + if (msectional .lt. 7000) msectional = msectional + 7000 + end if +#endif + + call move_sections( 2, it, jt, kpeg, mpeg ) + + msectional = idum_msect + + +#if defined ( ccboxtest_box_testing_active) +! diagnostics for testing + if (lunxx .gt. 0) then + do ll = 1, 4 + if (ll .eq. 1) then + lptr_dum(:,:) = lptr_so4_aer(:,:,iphase) + else if (ll .eq. 2) then + lptr_dum(:,:) = lptr_nh4_aer(:,:,iphase) + else if (ll .eq. 3) then + lptr_dum(:,:) = lptr_oin_aer(:,:,iphase) + else if (ll .eq. 4) then + lptr_dum(:,:) = numptr_aer(:,:,iphase) + end if + + if (ll .eq. 1) write(lunxx,9800) + if (ll .eq. 1) write(lunxx,9800) + write(lunxx,9800) + write(lunxx,9800) + write(lunxx,9801) 'cloudchem_apply_move_sections - ', & + name(lptr_dum(1,1)), ' - icase, ll' + write(lunxx,9810) icase, ll + write(lunxx,9800) ' tp sz rbox_sv1, rbox, rsub' + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + l = lptr_dum(isize,itype) + dumb = rbox(l) - rbox_sv1(l) + dumc = dumb/max( abs(duma), 1.0e-35 ) + if (duma .lt. 0.0) dumc = -dumc + write(lunxx,9840) itype, isize, rbox_sv1(l), rbox(l), & + rsub(l,kpeg,mpeg) + end do + end do + end do + + if (icase .ge. 5) then + write(*,*) & + '*** stop in cloudchem_apply_move_sections diags, icase =', & + icase + stop + end if + end if +9800 format( a ) +9801 format( 3a ) +9810 format( 7i10 ) +9820 format( 7(1pe10.2) ) +9840 format( 2i3, 5(1pe14.6) ) +#endif + + + return + end subroutine cloudchem_apply_move_sections + + + +!----------------------------------------------------------------------- + subroutine mosaic_cloudchem_dumpaa( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + qcldwtr_cutoff, & + itcur, jtcur, ktcur ) + + use module_state_description, only: & + num_moist, num_chem, p_qc + + use module_configure, only: grid_config_rec_type + + use module_data_mosaic_asect + + use module_data_mosaic_other, only: k_pegbegin, name + + use module_mosaic_driver, only: mapaer_tofrom_host + + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + itcur, jtcur, ktcur +! id - domain index +! ktau - time step number +! ktauc - gas and aerosol chemistry time step number +! numgas_aqfrac - last dimension of gas_aqfrac + +! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for 'domain' +! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for 'memory' +! Most arrays that are arguments to chem_driver +! are dimensioned with these spatial indices. +! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for 'tile' +! chem_driver and routines under it do calculations +! over these spatial indices. + + type(grid_config_rec_type), intent(in) :: config_flags +! config_flags - configuration and control parameters + + real, intent(in) :: & + dtstepc, qcldwtr_cutoff +! dtstepc - time step for gas and aerosol chemistry(s) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + p_phy, t_phy, rho_phy, alt, cldfra, ph_no2 +! p_phy - air pressure (Pa) +! t_phy - temperature (K) +! rho_phy - moist air density (kg/m^3) +! alt - dry air specific volume (m^3/kg) +! cldfra - cloud fractional area (0-1) +! ph_no2 - no2 photolysis rate (1/min) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist +! moist - mixing ratios of moisture species (water vapor, +! cloud water, ...) (kg/kg for mass species, #/kg for number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem +! chem - mixing ratios of trace gas and aerosol species (ppm for gases, +! ug/kg for aerosol mass species, #/kg for aerosol number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, numgas_aqfrac ) :: & + gas_aqfrac +! gas_aqfrac - fraction (0-1) of gas that is dissolved in cloud water + + +! local variables + integer :: it, jt, kt, l, ll, n + integer :: isize, itype + + real :: dumai, dumcw + real :: qcldwtr + + + it = itcur + jt = jtcur + kt = ktcur + + write(*,*) + write(*,*) + write(*,*) + write(*,9100) + write(*,9102) ktau, it, jt, kt +9100 format( 7('----------') ) +9102 format( & + 'mosaic_cloudchem_dumpaa - ktau, i, j, k =', 4i5 ) + + itype = 1 + do 2900 isize = 1, nsize_aer(itype) + + write(*,9110) isize +9110 format( / 'isize =', i3 / & + ' k cldwtr mass-ai numb-ai mass-cw numb-cw' ) + + do 2800 kt = kte-1, kts, -1 + + dumai = 0.0 + dumcw = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,1) + dumai = dumai + chem(it,kt,jt,l) + l = massptr_aer(ll,isize,itype,2) + dumcw = dumcw + chem(it,kt,jt,l) + end do + write(*,9120) kt, & + moist(it,kt,jt,p_qc), & + dumai, chem(it,kt,jt,numptr_aer(isize,itype,1)), & + dumcw, chem(it,kt,jt,numptr_aer(isize,itype,2)) +9120 format( i3, 1p, e10.2, 2(3x, 2e10.2) ) + +2800 continue +2900 continue + + write(*,*) + write(*,9100) + write(*,*) + +! map from wrf-chem 3d arrays to pegasus clm & sub arrays + kt = ktcur + if ((ktau .eq. 30) .and. (it .eq. 23) .and. & + (jt .eq. 1) .and. (kt .eq. 11)) then + qcldwtr = moist(it,kt,jt,p_qc) + write(*,*) + write(*,*) + write(*,9102) ktau, it, jt, kt + write(*,*) + write( *, '(3(1pe10.2,3x,a))' ) & + (chem(it,kt,jt,l), name(l)(1:10), l=1,num_chem) + write(*,*) + write( *, '(3(1pe10.2,3x,a))' ) & + p_phy(it,kt,jt), 'p_phy ', & + t_phy(it,kt,jt), 't_phy ', & + rho_phy(it,kt,jt), 'rho_phy ', & + alt(it,kt,jt), 'alt ', & + qcldwtr, 'qcldwtr ', & + qcldwtr_cutoff, 'qcldwtrcut' + write(*,*) + write(*,9100) + write(*,*) + end if + + + return + end subroutine mosaic_cloudchem_dumpaa + + + +!----------------------------------------------------------------------- + end module module_mosaic_cloudchem diff --git a/wrfv2_fire/chem/module_mosaic_coag.F b/wrfv2_fire/chem/module_mosaic_coag.F new file mode 100644 index 00000000..4536b6bc --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_coag.F @@ -0,0 +1,1128 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_coag + + + + use module_peg_util + + + + implicit none + + + + contains + + + +!----------------------------------------------------------------------- + subroutine mosaic_coag_1clm( istat_coag, & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_in, & + dtchem, dtcoag_in, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte ) +! +! calculates aerosol particle coagulation for grid points in +! the i=it, j=jt vertical column +! over timestep dtcoag_in +! +! uses a version of subr. coagsolv (see additional disclaimer below) +! that was obtained from mark jacobson in june 2003, +! and then modified to work with mosaic aerosol routines +! + use module_data_mosaic_asect + use module_data_mosaic_other + use module_state_description, only: param_first_scalar + +! subr arguments + integer, intent(inout) :: istat_coag ! =0 if no problems + integer, intent(in) :: & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_in, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte + real, intent(in) :: dtchem, dtcoag_in + +! NOTE - much information is passed via arrays in +! module_data_mosaic_asect and module_data_mosaic_other +! +! rsub (inout) - aerosol mixing ratios +! aqmassdry_sub, aqvoldry_sub (inout) - +! aerosol dry-mass and dry-volume mixing ratios +! adrydens_sub (inout) - aerosol dry density +! rsub(ktemp,:,:), ptotclm, cairclm (in) - +! air temperature, pressure, and molar density + + +! local variables + integer, parameter :: coag_method = 1 + integer, parameter :: ncomp_coag_maxd = maxd_acomp + 3 + + integer :: k, l, ll, lla, llb, llx, m + integer :: isize, itype, iphase + integer :: iconform_numb + integer :: idiagbb, idiag_coag_onoff, iok + integer :: lunout_coag + integer :: ncomp_coag, nsize, nsubstep_coag, ntau_coag + integer,save :: ncountaa(10), ncountbb(0:ncomp_coag_maxd) + integer :: p1st + + real, parameter :: densdefault = 2.0 + real, parameter :: factsafe = 1.00001 + real, parameter :: onethird = 1.0/3.0 + real, parameter :: piover6 = pi/6.0 + real, parameter :: smallmassbb = 1.0e-30 + + real :: cair_box + real :: dtcoag + real :: duma, dumb, dumc + real :: patm_box + real :: temp_box + real :: xxdens, xxmass, xxnumb, xxvolu + real :: xxmasswet, xxvoluwet + + real :: dpdry(maxd_asize), dpwet(maxd_asize), denswet(maxd_asize) + real :: num_distrib(maxd_asize) + real :: sumnew(ncomp_coag_maxd), sumold(ncomp_coag_maxd) + real :: vol_distrib(maxd_asize,ncomp_coag_maxd) + real :: xxvolubb(maxd_asize) + + character(len=120) :: msg + + + + istat_coag = 0 + + lunout_coag = 6 + if (lunout .gt. 0) lunout_coag = lunout + + +! when dtcoag_in > dtchem, do not perform coagulation calcs +! on every chemistry time step + ntau_coag = nint( dtcoag_in/dtchem ) + ntau_coag = max( 1, ntau_coag ) + if (mod(ktau,ntau_coag) .ne. 0) return + dtcoag = dtchem*ntau_coag + + +! set variables that do not change + idiagbb = idiagbb_in + +! NOTE - code currently just does 1 type + itype = 1 + iphase = ai_phase + nsize = nsize_aer(itype) + ncomp_coag = ncomp_plustracer_aer(itype) + 3 + + +! loop over subareas (currently only 1) and vertical levels + do 2900 m = 1, nsubareas + + do 2800 k = kclm_calcbgn, kclm_calcend + + +! temporary diagnostics + if ((it .eq. its) .and. & + (jt .eq. jts) .and. (k .eq. kclm_calcbgn)) then + ncountaa(:) = 0 + ncountbb(:) = 0 + end if + + + ncountaa(1) = ncountaa(1) + 1 + if (afracsubarea(k,m) .lt. 1.e-4) goto 2700 + + cair_box = cairclm(k) + temp_box = rsub(ktemp,k,m) + patm_box = ptotclm(k)/1.01325e6 + + nsubstep_coag = 1 + idiag_coag_onoff = -1 + +! do initial calculation of dry mass, volume, and density, +! and initial number conforming (as needed) + vol_distrib(:,:) = 0.0 + sumold(:) = 0.0 + do isize = 1, nsize + l = numptr_aer(isize,itype,iphase) + xxnumb = rsub(l,k,m) + xxmass = aqmassdry_sub(isize,itype,k,m) + xxvolu = aqvoldry_sub( isize,itype,k,m) + xxdens = adrydens_sub( isize,itype,k,m) + iconform_numb = 1 + + duma = max( abs(xxmass), abs(xxvolu*xxdens), 0.1*smallmassbb ) + dumb = abs(xxmass - xxvolu*xxdens)/duma + if ( (xxdens .lt. 0.1) .or. (xxdens .gt. 20.0) & + .or. (dumb .gt. 1.0e-4) ) then +! (exception) case of drydensity not valid, or mass /= volu*dens +! so compute dry mass and volume from rsub + ncountaa(2) = ncountaa(2) + 1 + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,4e10.2)') 'coagaa-2a', & + ktau, it, jt, k, isize, xxmass, xxvolu, xxdens + xxmass = 0.0 + xxvolu = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + if (l .ge. p1st) then + duma = max( 0.0, rsub(l,k,m) )*mw_aer(ll,itype) + xxmass = xxmass + duma + xxvolu = xxvolu + duma/dens_aer(ll,itype) + end if + end do + if (xxmass .gt. 0.99*smallmassbb) then + xxdens = xxmass/xxvolu + xxvolu = xxmass/xxdens + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,4e10.2)') 'coagaa-2b', & + ktau, it, jt, k, isize, xxmass, xxvolu, xxdens + end if + end if + + if (xxmass .le. 1.01*smallmassbb) then +! when drymass extremely small, use default density and bin center size, +! and zero out water + ncountaa(3) = ncountaa(3) + 1 + xxdens = densdefault + xxvolu = xxmass/xxdens + xxnumb = xxmass/(volumcen_sect(isize,itype)*xxdens) + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + l = waterptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + iconform_numb = 0 + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,4e10.2)') 'coagaa-2c', & + ktau, it, jt, k, isize, xxmass, xxvolu, xxdens + else + xxvolu = xxmass/xxdens + end if + +! check for mean dry-size 'safely' within bounds, and conform number if not + if (iconform_numb .gt. 0) then + if (xxnumb .gt. & + xxvolu/(factsafe*volumlo_sect(isize,itype))) then + ncountaa(4) = ncountaa(4) + 1 + duma = xxnumb + xxnumb = xxvolu/(factsafe*volumlo_sect(isize,itype)) + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,3e12.4)') 'coagcc-4 ', & + ktau, it, jt, k, isize, xxvolu, duma, xxnumb + else if (xxnumb .lt. & + xxvolu*factsafe/volumhi_sect(isize,itype)) then + ncountaa(5) = ncountaa(5) + 1 + duma = xxnumb + xxnumb = xxvolu*factsafe/volumhi_sect(isize,itype) + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,3e12.4)') 'coagcc-5 ', & + ktau, it, jt, k, isize, xxvolu, duma, xxnumb + end if + end if + +! load numb, mass, volu, dens back into mosaic_asect arrays + l = numptr_aer(isize,itype,iphase) + rsub(l,k,m) = xxnumb + adrydens_sub( isize,itype,k,m) = xxdens + aqmassdry_sub(isize,itype,k,m) = xxmass + aqvoldry_sub( isize,itype,k,m) = xxvolu + +! +! load coagsolv arrays with number, mass, and volume mixing ratios +! +! *** NOTE *** +! num_distrib must be (#/cm3) +! vol_distrib units do not matter - they can be either masses or volumes, +! and either mixing ratios or concentrations +! (e.g., g/cm3-air, ug/kg-air, cm3/cm3-air, cm3/kg-air, ...) +! + num_distrib(isize) = xxnumb*cair_box + + do ll = 1, ncomp_plustracer_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + duma = 0.0 + if (l .ge. p1st) duma = max( 0.0, rsub(l,k,m) ) + vol_distrib(isize,ll) = duma + sumold(ll) = sumold(ll) + duma + end do + + do llx = 1, 3 + ll = (ncomp_coag-3) + llx + duma = 0.0 + if (llx .eq. 1) then + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) duma = max( 0.0, rsub(l,k,m) ) + else if (llx .eq. 2) then + l = waterptr_aer(isize,itype) + if (l .ge. p1st) duma = max( 0.0, rsub(l,k,m) ) + else + duma = max( 0.0, aqvoldry_sub( isize,itype,k,m) ) + end if + vol_distrib(isize,ll) = duma + sumold(ll) = sumold(ll) + duma + end do + +! calculate dry and wet diameters and wet density + if (xxmass .le. 1.01*smallmassbb) then + dpdry(isize) = dcen_sect(isize,itype) + dpwet(isize) = dpdry(isize) + denswet(isize) = xxdens + else + dpdry(isize) = (xxvolu/(xxnumb*piover6))**onethird + dpdry(isize) = max( dpdry(isize), dlo_sect(isize,itype) ) + l = waterptr_aer(isize,itype) + if (l .ge. p1st) then + duma = max( 0.0, rsub(l,k,m) )*mw_water_aer + xxmasswet = xxmass + duma + xxvoluwet = xxvolu + duma/dens_water_aer + dpwet(isize) = (xxvoluwet/(xxnumb*piover6))**onethird + dpwet(isize) = min( dpwet(isize), 30.0*dhi_sect(isize,itype) ) + denswet(isize) = (xxmasswet/xxvoluwet) + else + dpwet(isize) = dpdry(isize) + denswet(isize) = xxdens + end if + end if + end do + + +! +! make call to coagulation routine +! + call coagsolv( & + nsize, maxd_asize, ncomp_coag, ncomp_coag_maxd, & + temp_box, patm_box, dtcoag, nsubstep_coag, & + lunout_coag, idiag_coag_onoff, iok, & + dpdry, dpwet, denswet, num_distrib, vol_distrib ) + + if (iok .lt. 0) then + msg = '*** subr mosaic_coag_1clm -- fatal error in coagsolv' + call peg_message( lunout, msg ) + call peg_error_fatal( lunout, msg ) + else if (iok .gt. 0) then + ncountaa(6) = ncountaa(6) + 1 + goto 2700 + end if + + +! +! unload coagsolv arrays +! + sumnew(:) = 0.0 + do isize = 1, nsize + do ll = 1, ncomp_coag + sumnew(ll) = sumnew(ll) + max( 0.0, vol_distrib(isize,ll) ) + end do + + l = numptr_aer(isize,itype,iphase) + rsub(l,k,m) = max( 0.0, num_distrib(isize)/cair_box ) + +! unload mass mixing ratios into rsub; also calculate dry mass and volume + xxmass = 0.0 + xxvolu = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + if (l .ge. p1st) then + duma = max( 0.0, vol_distrib(isize,ll) ) + rsub(l,k,m) = duma + duma = duma*mw_aer(ll,itype) + xxmass = xxmass + duma + xxvolu = xxvolu + duma/dens_aer(ll,itype) + end if + end do + aqmassdry_sub(isize,itype,k,m) = xxmass + xxvolubb(isize) = xxvolu + + ll = (ncomp_coag-3) + 1 + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = max( 0.0, vol_distrib(isize,ll) ) + + ll = (ncomp_coag-3) + 2 + l = waterptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = max( 0.0, vol_distrib(isize,ll) ) + + ll = (ncomp_coag-3) + 3 + aqvoldry_sub( isize,itype,k,m) = max( 0.0, vol_distrib(isize,ll) ) + end do + + +! check for mass and volume conservation + do ll = 1, ncomp_coag + duma = max( sumold(ll), sumnew(ll), 1.0e-35 ) + if (abs(sumold(ll)-sumnew(ll)) .gt. 1.0e-6*duma) then + ncountbb(ll) = ncountbb(ll) + 1 + ncountbb(0) = ncountbb(0) + 1 + end if + end do + + +! +! calculate new dry density, +! and check for new mean dry-size within bounds +! + do isize = 1, nsize + + xxmass = aqmassdry_sub(isize,itype,k,m) + xxvolu = aqvoldry_sub( isize,itype,k,m) + l = numptr_aer(isize,itype,iphase) + xxnumb = rsub(l,k,m) + iconform_numb = 1 + +! do a cautious calculation of density, using volume from coagsolv + if (xxmass .le. smallmassbb) then + ncountaa(8) = ncountaa(8) + 1 + xxdens = densdefault + xxvolu = xxmass/xxdens + xxnumb = xxmass/(volumcen_sect(isize,itype)*xxdens) + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + l = waterptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + iconform_numb = 0 + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,4e10.2)') 'coagaa-7a', & + ktau, it, jt, k, isize, xxmass, xxvolu, xxdens + else if (xxmass .gt. 1000.0*xxvolu) then +! in this case, density is too large. setting density=1000 forces +! next IF block while avoiding potential divide by zero or overflow + xxdens = 1000.0 + else + xxdens = xxmass/xxvolu + end if + + if ((xxdens .lt. 0.1) .or. (xxdens .gt. 20.0)) then +! (exception) case -- new dry density is unrealistic, +! so use dry volume from rsub instead of that from coagsolv + ncountaa(7) = ncountaa(7) + 1 + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,4e10.2)') 'coagaa-7b', & + ktau, it, jt, k, isize, xxmass, xxvolu, xxdens + xxvolu = xxvolubb(isize) + xxdens = xxmass/xxvolu + if (idiagbb .ge. 200) & + write(*,'(a,26x,1p,4e10.2)') 'coagaa-7c', & + xxmass, xxvolu, xxdens + end if + +! check for mean size ok, and conform number if not + if (iconform_numb .gt. 0) then + if (xxnumb .gt. xxvolu/volumlo_sect(isize,itype)) then + ncountaa(9) = ncountaa(9) + 1 + duma = xxnumb + xxnumb = xxvolu/volumlo_sect(isize,itype) + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,3e12.4)') 'coagcc-9 ', & + ktau, it, jt, k, isize, xxvolu, duma, xxnumb + else if (xxnumb .lt. xxvolu/volumhi_sect(isize,itype)) then + ncountaa(10) = ncountaa(10) + 1 + duma = xxnumb + xxnumb = xxvolu/volumhi_sect(isize,itype) + if (idiagbb .ge. 200) & + write(*,'(a,i10,4i4,1p,3e12.4)') 'coagcc-10', & + ktau, it, jt, k, isize, xxvolu, duma, xxnumb + end if + end if + +! load number, mass, volume, dry-density back into arrays + l = numptr_aer(isize,itype,iphase) + rsub(l,k,m) = xxnumb + adrydens_sub( isize,itype,k,m) = xxdens + aqmassdry_sub(isize,itype,k,m) = xxmass + aqvoldry_sub( isize,itype,k,m) = xxvolu + + end do + + +2700 continue + +! temporary diagnostics + if ((idiagbb .ge. 100) .and. & + (it .eq. ite) .and. & + (jt .eq. jte) .and. (k .eq. kclm_calcend)) then + write(msg,93030) 'coagbb ncntaa ', ncountaa(1:10) + call peg_message( lunerr, msg ) + if (ncountbb(0) .gt. 0) then + do llx = 1, (ncomp_coag+9)/10 + llb = llx*10 + lla = llb - 9 + llb = min( llb, ncomp_coag) + write(msg,93032) 'coagbb ncntbb', & + mod(llx,10), ncountbb(lla:llb) + call peg_message( lunerr, msg ) + end do + end if + end if +93020 format( a, 1p, 10e10.2 ) +93030 format( a, 1p, 10i10 ) +93032 format( a, 1p, i1, 10i10 ) + + +2800 continue ! k levels + +2900 continue ! subareas + + + return + end subroutine mosaic_coag_1clm + + +!---------------------------------------------------------------------- + subroutine coagsolv( & + nbin, nbin_maxd, ncomp, ncomp_maxd, & + tkelvin_inp, patm_inp, deltat_inp, nsubstep, & + lunout, idiag_onoff, iok, & + dpdry_inp, dpwet_inp, denswet_inp, & + num_distrib_inp, vol_distrib_inp ) + + implicit none + +! +! ********************************************************************* +! ***************** written by mark jacobson (1993) ******************* +! *** (c) copyright, 1993 by mark z. jacobson *** +! *** this version modified december, 2001 *** +! *** (650) 723-6836 *** +! ********************************************************************* +! +! cccccc ooooo a gggggg ssssss ooooo l v v +! c o o a a g s o o l v v +! c o o a a g ggg sssss o o l v v +! c o o aaaaaaa g g s o o l v v +! cccccc ooooo a a gggggg ssssss ooooo lllllll v +! +! ********************************************************************* +! the use of this module implies that the user agrees not to sell the +! module or any portion of it, not to remove the copyright notice from it, +! and not to change the name of the module, "coagsolv". users may +! modify the module as needed or incorporate it into a larger model. +! any special requests with regard to this module may be directed to +! jacobson@stanford.edu. +! ********************************************************************* +! +! ********************************************************************* +! * this is a box-model version of "coagsolv," a semi-implicit * +! * aerosol coagulation solver. the solver is exactly volume * +! * conserving, unconditionally stable (regardless of time step), * +! * and noniterative. * +! * * +! * this program calculates brownian coagulation kernels and solves * +! * self-coagulation among any number of size bins, one * +! * particle type and any number of volume fractions. * +! * * +! * the program is set up as a box-model. * +! * * +! * the volume ratio of adjacent size bins can be any number > 1 * +! * * +! * the scheme can be used to solve coagulation with any size bin * +! * structure. * +! * * +! * the initial size distribution here is monomer or lognormal * +! * (ifsmoluc = 1 or 0) with a fixed size bin structure * +! * * +! ********************************************************************* +! * references * +! ********************************************************************* +! * semi-implicit scheme using movable or variable bins and with * +! * any volume ratio (vrat) > 1 * +! * * +! * jacobson m. z., turco r. p., jensen, e. j. and toon o. b. (1994) * +! * modeling coagulation among particles of different compostion * +! * and size. atmos. environ. 28a, 1327 - 1338. * +! * * +! * jacobson m. z. (1999) fundamentals of atmospheric modeling. * +! * cambridge university press, new york, 656 pp. * +! * * +! ********************************************************************* +! * semi-implicit scheme using fixed bins with volume ratio >,= 2 * +! * * +! * toon o. b., turco r. p., westphal d., malone r. and liu m. s. * +! * (1988) a multidimensional model for aerosols: description of * +! * computational analogs. j. atmos. sci. 45, 2123 - 2143 * +! * * +! ********************************************************************* +! * orig semi-implicit scheme using fixed bins with volume ratio = 2 * +! * * +! * turco r. p., hamill p., toon o. b., whitten r. c. and kiang c. s. * +! * (1979) the nasa-ames research center stratospheric aerosol * +! * model: i physical processes and computational analogs. nasa * +! * tech. publ. (tp) 1362, iii-94. * +! ********************************************************************* +! +! modified by y. zhang for incorporation into pnnl's mirage +! june-july, 2003 +! +! ********************************************************************* +! +! modified by r.c. easter for incorporation into pnnl's wrf-chem +! feb 2005 (a) +! added "_inp" to all subr arguments +! added iradmaxd_inp & lunout +! define iradmaxd, iaertymaxd, iaeromaxd locally +! no include statements +! changed real*16 to real*8 +! feb 2005 (b) +! in coagsolv, distrib_inp is 2-d array that holds both number and +! volume concentrations; distrib is initialized from it; +! the "fracnaer" stuff is gone +! feb 2005 (c) +! change distrib & cc2 to be 2-d arrays (which simplifies indexing!); +! iaeromaxd and iaero are gone; +! deleted many commented-out lines in coagsolv +! feb 2005 (d) +! changed cc2(i,1) to be number instead of all-species volume; +! prod term for number distrib now follows jgr-2002 article +! [multiply by volume(j), divide by volume(k)] +! apr 2006 (a) +! considerable cleanup (mostly cosmetic) +! pass in the bin sizes directly, rather than vrat & dmin_um +! pass in dry and wet sizes separately +! pass in/out number and volume distributions in separate arrays +! +! ********************************************************************* + + +! IN arguments + integer nbin ! actual number of size bins + integer nbin_maxd ! size-bin dimension for input (argument) arrays + integer ncomp ! actual number of aerosol volume components + integer ncomp_maxd ! volume-component dimension for input (argument) arrays + integer lunout ! logical unit for warning & diagnostic output + integer idiag_onoff ! if positive, write some mass-conservation diagnostics + integer nsubstep ! number of time sub-steps for the integration + + real tkelvin_inp ! air temperature (K) + real patm_inp ! air pressure (atm) + real deltat_inp ! integration time (s) + real dpdry_inp(nbin_maxd) ! bin dry diameter (cm) + real dpwet_inp(nbin_maxd) ! bin wet (ambient) diameter (cm) + real denswet_inp(nbin_maxd) ! bin wet (ambient) density (g/cm3) + +! IN-OUT arguments + real num_distrib_inp(nbin_maxd) +! num_distrib_inp(i) = number concentration for bin i (#/cm3) + real vol_distrib_inp(nbin_maxd,ncomp_maxd) +! vol_distrib_inp(i,j) = volume concentration for bin i, +! component j (cm3/cm3) + +! OUT arguments + integer iok ! status flag (0=success, anything else=failure) + +! +! NOTE -- The sectional representation is based on dry particle size. +! Dry sizes are used to calculate the receiving bin indices and product fractions +! for each (bin-i1, bin-i2) coagulation combination. +! Wet sizes and densities are used to calculate the coagulation rate coefficients. +! +! NOTE -- Units for num_distrib and vol_distrib +! num_distrib units MUST BE (#/cm3) +! vol_distrib units do not really matter. They can be either masses +! or volumes, and either mixing ratios or concentrations, +! (e.g., g/cm3-air, ug/kg-air, cm3/m3-air, cm3/kg-air, ...). +! Use whatever is convenient. +! + +! +! local variables +! + integer iradmaxd_wrk, iaertymaxd_wrk + parameter (iradmaxd_wrk=16) + parameter (iaertymaxd_wrk=32) + + integer irad + integer iaerty +! irad == nbin = actual number of size bins +! iradmaxd_wrk = size-bin dimension for local (working) arrays +! +! (iaerty-1) == ncomp = actual number of aerosol volume components +! iaertymaxd_wrk = volume-component dimension for local (working) arrays +! +! iaerty = 1 --> calc number concentration only +! > 1 --> calc number concentration + (iaerty-1) volume concentrations + + integer i, isubstep, j, jaer, jb, k, kout + + integer jbinik(iradmaxd_wrk,iradmaxd_wrk,iradmaxd_wrk) + integer jbins(iradmaxd_wrk,iradmaxd_wrk) + + real*8 aknud, aloss, amu, avg, & + boltg, bpm, & + cbr, consmu, cpi, & + deltat, deltp1, deltr, & + divis, dti1, dti2, & + finkhi, finklow, fourpi, fourrsq, & + ggr, gmfp, & + onepi, & + patm, pmfp, prod, & + radi, radiust, radj, ratior, & + rgas2, rho3, rsuma, rsumsq, & + sumdc, sumnaft, sumnbef, & + term1, term2, third, tk, tkelvin, tworad, & + viscosk, vk1, voltota, vthermg, & + wtair + + real*8 cc2(iradmaxd_wrk,iaertymaxd_wrk), & + conc(iradmaxd_wrk), & + denav(iradmaxd_wrk) , & + difcof(iradmaxd_wrk), & + distrib(iradmaxd_wrk,iaertymaxd_wrk), & + fink(iradmaxd_wrk,iradmaxd_wrk,iradmaxd_wrk), & + floss(iradmaxd_wrk,iradmaxd_wrk), & + radius(iradmaxd_wrk), & + radwet(iradmaxd_wrk), & + rrate(iradmaxd_wrk,iradmaxd_wrk), & + sumdp(iradmaxd_wrk), & + sumvt(iradmaxd_wrk), & + tvolfin(iaertymaxd_wrk), & + tvolinit(iaertymaxd_wrk), & + volume(iradmaxd_wrk), & + volwet(iradmaxd_wrk), & + vthermp(iradmaxd_wrk) + + +! ********************************************************************* +! set some parameters +! ********************************************************************* + irad = nbin + iaerty = ncomp + 1 + + kout = lunout + + if (irad .gt. iradmaxd_wrk) then + write(lunout,*) '*** coagsolv: irad > iradmaxd_wrk: ', & + irad, iradmaxd_wrk + iok = -1 + return + endif + if (iaerty .gt. iaertymaxd_wrk) then + write(lunout,*) '*** coagsolv: iaerty > iaertymaxd_wrk: ', & + iaerty, iaertymaxd_wrk + iok = -2 + return + endif +! +! tkelvin = temperature (k) +! denav = particle density (g cm-3) +! patm = air pressure (atm) +! + tkelvin = tkelvin_inp + patm = patm_inp + do i = 1, irad + denav(i) = denswet_inp(i) + end do + +! +! deltat_inp = total integration time (s) +! deltat = individual time step (s) +! nsubstep = number of time steps +! + deltat = deltat_inp/nsubstep + +! +! boltg = boltzmann's 1.38054e-16 (erg k-1 = g cm**2 sec-1 k-1) +! wtair = molecular weight of air (g mol-1) +! avg = avogadro's number (molec. mol-1) +! rgas2 = gas constant (l-atm mol-1 k-1) +! amu = dynamic viscosity of air (g cm-1 sec-1) +! est value at 20 c = 1.815e-04 +! rho3 = air density (g cm-3) +! viscosk = kinematic viscosity = amu / denair = (cm**2 sec-1) +! vthermg = mean thermal velocity of air molecules (cm sec-1) +! gmfp = mean free path of an air molecule = 2 x viscosk / +! thermal velocity of air molecules (gmfp units of cm) +! + tk = tkelvin + third = 1. / 3. + onepi = 3.14159265358979 + fourpi = 4. * onepi + boltg = 1.38054e-16 + wtair = 28.966 + avg = 6.02252e+23 + rgas2 = 0.08206 + consmu = 1.8325e-04 * (296.16 + 120.0) + amu = (consmu / (tk + 120.)) * (tk / 296.16)**1.5 + rho3 = patm * wtair * 0.001 / (rgas2 * tk) + viscosk = amu / rho3 + vthermg = sqrt(8. * boltg * tk * avg / (onepi * wtair)) + gmfp = 2.0 * viscosk / vthermg + +! +! ********************************************************************* +! * set volume ratio size bin grid * +! ********************************************************************* +! + cpi = fourpi / 3. + + do 30 j = 1, irad + radius( j) = dpdry_inp(j) * 0.5 + volume( j) = cpi * radius(j) * radius(j) * radius(j) + radwet( j) = dpwet_inp(j) * 0.5 + volwet( j) = cpi * radwet(j) * radwet(j) * radwet(j) + 30 continue + +! +! ********************************************************************* +! * determine bins where coagulated terms go * +! ********************************************************************* +! finklow = volume fraction of i+j going to lower (k ) bin +! finkhi = volume fraction of i+j going to higher (k+1) bin +! fink(i,j,k) = volume fraction of i+j going to bin k +! floss = simplified fink term used in loss rates +! no self-coagulation loss out of largest bin +! jbins(i,k) = number of production terms into bin k from bin i +! jbinik(i,k,jb) = identifies each bin j that coagulates with bin i +! to produce bin k +! + do 35 i = 1, irad + do 34 j = 1, irad + jbins(i,j) = 0 + floss(i,j) = 0. + do 33 k = 1, irad + jbinik(i,j,k) = 0 + fink( i,j,k) = 0. + 33 continue + 34 continue + 35 continue + + do 40 i = 1, irad + do 39 j = 1, irad + voltota = volume(i) + volume(j) + if (voltota.ge.volume(irad)) then + + if (i.eq.irad) then + floss(i,j) = 0.0 + else + floss(i,j) = 1.0 + endif + + if (j.lt.irad) then + jbins(i,irad) = jbins(i,irad) + 1 + jb = jbins(i,irad) + jbinik(i,irad,jb) = j + fink( i,jb,irad) = 1.0 + endif + + else + do 45 k = 1, irad - 1 + vk1 = volume(k+1) + if (voltota.ge.volume(k).and.voltota.lt.vk1) then + finklow = ((vk1 - voltota)/(vk1 - volume(k))) & + * volume(k) / voltota + finkhi = 1. - finklow + + if (i.lt.k) then + floss(i,j) = 1. + elseif (i.eq.k) then + floss(i,j) = finkhi + endif + + if (j.lt.k) then + jbins(i,k) = jbins(i,k) + 1 + jb = jbins(i,k) + jbinik(i,k,jb) = j + fink( i,jb,k) = finklow + endif + + jbins(i,k+1) = jbins(i,k+1) + 1 + jb = jbins(i,k+1) + jbinik(i,k+1,jb) = j + fink( i,jb,k+1) = finkhi + + endif + 45 continue + endif + + do 38 k = 1, irad + if (jbins(i,k).gt.irad) then + write(21,*)'coagsolv: jbins > irad: ',jbins(i,k),i,k + iok = -3 + return + endif + 38 continue + + 39 continue + 40 continue + +! +! *********************************************************************** +! initialize size distribution +! +! copy initial number concentration (#/cm3-air) and volume concentrations +! (cm3/cm3-air) from num/vol_distrib_inp (real*4) to distrib (real*8) +! *********************************************************************** + do i = 1, irad + distrib(i,1) = num_distrib_inp(i) + end do + + do jaer = 2, iaerty + do i = 1, irad + distrib(i,jaer) = vol_distrib_inp(i,jaer-1) + end do + end do + + +! +! ********************************************************************* +! coagulation kernel from fuchs equations +! ********************************************************************* +! difcof = brownian particle diffus coef (cm**2 sec-1) +! = boltg * t * bpm / (6 * pi * mu * r(i)) +! = 5.25e-04 (diam = 0.01um); 6.23e-7 (diam = 0.5 um) seinfeld p.325. +! vthermp = avg thermal vel of particle (cm sec-1) +! = (8 * boltg * t / (pi * masmolec)**0.5 +! pmfp = mean free path of particle (cm) +! = 8 * di / (pi * vthermp) +! bpm = correction for particle shape and for effects of low mean +! free path of air. (toon et al., 1989, physical processes in +! polar stratospheric ice clouds, jgr 94, 11,359. f1 and f2 are +! included in the expression below (shape effects correction) +! = 1 + kn[a + bexp(-c/kn)] +! deltp1 = if particles with mean free path pmfp leave the surface of +! an absorbing sphere in all directions, each being probably +! equal, then deltp1 is the mean distance from the surface of the +! sphere reached by particles after covering a distance pmfp. (cm). +! cbr = coag kernel (cm3 partic-1 s-1) due to brownian motion (fuchs, 1964) +! rrate = coag kernal (cm3 partic-1 s-1) * time step (s) +! +! *** use the wet (ambient) radius and volume here *** + do 145 i = 1, irad + radiust = radwet(i) + tworad = radiust + radiust + fourrsq = 4. * radiust * radiust + aknud = gmfp / radiust + bpm = 1. + aknud * (1.257 + 0.42*exp(-1.1/aknud)) + difcof(i) = boltg * tk * bpm / (6. * onepi * radiust * amu) + +! use bin-varied aerosol density from mirage +! vthermp(i) = sqrt(8. * boltg * tk / (onepi*denav * volume(i))) + vthermp(i) = sqrt(8. * boltg * tk / (onepi*denav(i) * & + volwet(i))) + sumvt(i) = vthermp(i) * vthermp(i) + pmfp = 8. * difcof(i) / (onepi * vthermp(i)) + dti1 = tworad + pmfp + dti2 = (fourrsq + pmfp * pmfp)**1.5 + divis = 0.166667 / (radiust * pmfp) + deltp1 = divis * (dti1 * dti1 * dti1 - dti2) - tworad + sumdp(i) = deltp1 * deltp1 + 145 continue + +!yy write(kout,9165) + do 155 i = 1, irad + do 154 j = 1, irad + radi = radwet(i) + radj = radwet(j) + rsuma = radi + radj + rsumsq = rsuma * rsuma + ratior = radi / radj + sumdc = difcof(i) + difcof(j) + ggr = sqrt(sumvt(i) + sumvt(j)) + deltr = sqrt(sumdp(i) + sumdp(j)) + term1 = rsuma / (rsuma + deltr) + term2 = 4. * sumdc / (rsuma * ggr) + cbr = fourpi * rsuma * sumdc / (term1 + term2) + rrate(i,j) = cbr * deltat +!yy write(kout,9190) (2.0e4*radius(i)), (2.0e4*radius(j)), cbr + 154 continue + 155 continue + +9165 format(16x,'coagulation coefficients (cm**3 #-1 sec-1)'/ & + 'diam1_um diam2_um brownian ') +9190 format(1pe15.7,7(1x,1pe15.7)) + + +! +! ********************************************************************* +! ****************** solve coagulation equations ********************** +! ********************************************************************* +! +! ********************************************************************* +! inialize new arrays +! ********************************************************************* +! distrib = initial conc (# cm-3 for num conc.; cm3 cm-3 for volume fractions) +! cc2 = initial, final volume conc (cm3 cm-3) for all particle types. +! conc = initial, final number conc (# cm-3) for number distribution +! volume = volume (cm3 #-1) of particles in bin +! +! + + do i = 1, irad +! cc2( i,1) = distrib(i,1) * volume(i) + cc2( i,1) = distrib(i,1) + conc(i) = distrib(i,1) + end do + + do jaer = 2, iaerty + do i = 1, irad + cc2(i,jaer) = distrib(i,jaer) + end do + end do + +! ********************************************************************* +! solve coagulation over several time steps +! ********************************************************************* +! + do 700 isubstep = 1, nsubstep +! + do 485 jaer = 1, iaerty + do 484 k = 1, irad +! +! production terms +! + prod = 0. + if (k.gt.1) then + if (jaer .eq. 1) then + do 465 i = 1, k + do 464 jb = 1, jbins(i,k) + j = jbinik(i,k,jb) + prod = prod + fink(i,jb,k)*rrate(i,j)* & + cc2(j,jaer)*volume(j)*conc(i) + 464 continue + 465 continue + prod = prod/volume(k) + else + do 469 i = 1, k + do 468 jb = 1, jbins(i,k) + j = jbinik(i,k,jb) + prod = prod + & + fink(i,jb,k)*rrate(i,j)*cc2(j,jaer)*conc(i) + 468 continue + 469 continue + endif + endif +! +! loss terms +! + aloss = 0. + if (k.lt.irad) then + do 475 j = 1, irad + aloss = aloss + floss(k,j) * rrate(k,j) * conc(j) + 475 continue + endif +! +! final concentrations +! + cc2(k,jaer) = (cc2(k,jaer) + prod) / (1. + aloss) + 484 continue + 485 continue +! +! put updated number concentration into conc array + do i = 1, irad + conc(i) = cc2(i,1) + end do + + 700 continue + + +! +! ********************************************************* +! ** put the advanced concentration back on the grid ** +! (copy them from the real*8 working array to the +! real*4 caller arrays) +! ********************************************************* +! + do i = 1, irad + num_distrib_inp(i) = cc2(i,1) + end do + do jaer = 2, iaerty + do i = 1, irad + vol_distrib_inp(i,jaer-1) = cc2(i,jaer) + end do + end do + +! +! if no diagnostics, then return +! + iok = 0 + if (idiag_onoff .le. 0) return + +! +! ********************************************************************* +! ************* check whether mass is conserved *********** +! ********************************************************************* +! tvolinit = initial volume conc (cm3 cm-3), summed over all bins +! tvolfin = final volume conc (cm3 cm-3), summed over all bins +! sumnbef = summed number conc (# cm-3) before coagulation +! sumnaft = summed number conc (# cm-3) after coagulation +! + do jaer = 1, iaerty + tvolinit(jaer) = 0. + tvolfin( jaer) = 0. + end do + + sumnbef = 0. + sumnaft = 0. +! +! distrib(jaer=1, i=1:nrad) = initial total number conc in # cm-3 +! cc2 (jaer=1, i=1:nrad) = final total number conc in # cm-3 +! + do i = 1, irad + tvolinit(1) = tvolinit(1) + distrib(i,1) * volume(i) + tvolfin( 1) = tvolfin( 1) + cc2( i,1) * volume(i) + sumnbef = sumnbef + distrib(i,1) + sumnaft = sumnaft + cc2( i,1) + end do + +! +! distrib(jaer=2:iaerty, i=1:nrad) = initial component volume conc in cm3 cm-3 +! cc2 (jaer=2:iaerty, i=1:nrad) = initial component volume conc in cm3 cm-3 +! + do jaer = 2, iaerty + do i = 1, irad + tvolinit(jaer) = tvolinit(jaer) + distrib(i,jaer) + tvolfin( jaer) = tvolfin( jaer) + cc2( i,jaer) + end do + end do + + write(kout,*) + write(kout,9434) sumnbef, sumnaft, & + tvolinit(1)*1.0e+12,tvolfin(1)*1.0e+12 + + write(kout,9435) sumnaft-sumnbef + write(kout,9439) tvolinit(1) / tvolfin(1) + + do jaer = 2, iaerty + if (abs(tvolfin(jaer)) .gt. 0.0) then + write(kout,9440) jaer-1, tvolinit(jaer) / tvolfin(jaer) + else + write(kout,9441) jaer-1, tvolinit(jaer), tvolfin(jaer) + end if + end do + +9434 format('# bef, aft; vol bef, aft =',/4(1pe16.10,1x)/) +9435 format('total partic change in # cm-3 = ',1pe17.10) +9439 format('total partic vol bef / vol aft = ',1pe17.10, & + ': if 1.0 -> exact vol conserv') +9440 format('vol comp',i4,' vol bef / vol aft = ',1pe17.10, & + ': if 1.0 -> exact vol conserv') +9441 format('vol comp',i4,' vol bef, vol aft = ',2(1pe17.10)) + + +! +! ************************** print results **************************** +! distrib = initial conc in # cm-3 for total particle (jaer=1, i=1,nrad) +! conc = final conc in # cm-3 for total particle (jaer=1, i=1,nrad) +! + + +! +! ********************************************************************* +! end of program coagsolv.f +! ********************************************************************* +! + return + end subroutine coagsolv + + + + + +!----------------------------------------------------------------------- + + + + end module module_mosaic_coag diff --git a/wrfv2_fire/chem/module_mosaic_csuesat.F b/wrfv2_fire/chem/module_mosaic_csuesat.F new file mode 100644 index 00000000..73a64524 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_csuesat.F @@ -0,0 +1,126 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_csuesat + +!----------------------------------------------------------------------- + + implicit none + + integer, parameter :: nebins=149, nebinsi=110 + + real, save :: estbar(nebins+1), esitbar(nebinsi+1) + + real, save :: tmin = -1.0 + real, save :: tmini = -1.0 + + + + contains + + + +!----------------------------------------------------------------------- +! following funcs from pegasus file csuesat01.f (timestamp = 09-apr-2002) +!----------------------------------------------------------------------- +! file csuesat01.f - from stratcld.F,v on 8-oct-97 +! routines and common blocks renamed to allow running either +! standalone gchm or coupled gchm-ccm2 +!----------------------------------------------------------------------- + + +!----------------------------------------------------------------------- + real function esat_gchm( t ) + +! saturation vapor pressure (dynes/cm2) with respect to water + + real t + real av + integer it + + if (tmin .lt. 0.0) then + call init_csuesat + endif + + it=max0(1,min0(ifix(t-tmin),nebins)) + av=amax1(amin1(t-tmin-float(it),1.),0.) + esat_gchm=estbar(it)*(1.-av)+estbar(it+1)*av + return + end function esat_gchm + + +!----------------------------------------------------------------------- + real function esati_gchm( t ) + +! saturation vapor pressure (dynes/cm2) with respect to ice + + real t + real av + integer it + + if (tmin .lt. 0.0) then + call init_csuesat + endif + + it=max0(1,min0(ifix(t-tmini),nebinsi)) + av=amax1(amin1(t-tmini-float(it),1.),0.) + esati_gchm=esitbar(it)*(1.-av)+esitbar(it+1)*av + return + end function esati_gchm + + +!----------------------------------------------------------------------- + subroutine init_csuesat + +! calculate table of saturation vapor pressure (dynes/cm2) with respect +! to water(estbar) and ice (esitbar) + + integer jd, k + real a0, a2, a3, a3dtf, a4, a5, a6, arg, ax + real t, tf, tinver, z1, z2 + + a0=5.75185606e10 + ax=-20.947031 + a2=-3.56654 + a3=-2.018890949 + tf=273.16 + a3dtf=a3/tf + tmini=163. + t=tmini + + do 3 k=1,nebinsi+1 + t=t+1. + tinver=1./t + arg=ax*tf*tinver+a2*alog(tf*tinver)+a3*t/tf + esitbar(k)=a0*exp(arg)*1.e3 +3 continue + + a0=7.95357242e+10 + ax=-18.1972839 + a2=5.02808 + a3=-70242.1852 + a4=-26.1205253 + a5=58.0691913 + a6=-8.03945282 + tf=373.16 + tmin=163. + t=tmin + + do 4 jd=1,nebins+1 + t=t+1. + z1=exp(a4*t/tf) + z2=exp(a6*tf/t) + arg=ax*tf/t+a2*alog(tf/t)+a3*z1+a5*z2 +4 estbar(jd)=a0*exp(arg)*1.e3 + + return + end subroutine init_csuesat + + +!----------------------------------------------------------------------- + end module module_mosaic_csuesat diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F new file mode 100644 index 00000000..25e7bb61 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -0,0 +1,2365 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! Aerosol Option: MOSAIC (Model for Simulating Aerosol Interactions & Chemistry) +! * Primary investigator: Rahul A. Zaveri +! * Co-investigator: Richard C. Easter, William I. Gustafson Jr. +! Last update: September 2005 +! +! Contains: +! ASTEEM (Adaptive Step Time-split Explicit Euler Method): Solves the dynamic +! dynamic partitioning of semi-volatile species between gas and particle phases. +! MESA (Multicomponent Equilibrium Solver for Aerosols): Solves the multi- +! component solid-liquid equilibria within the aerosol phase. +! MTEM (Multicomponent Taylor Expansion Method): Computes the multicomponent +! activity coefficients of electrolytes in aqueous atmospheric aerosols. +! +! Contacts: +! Rahul A. Zaveri, PhD Jerome D. Fast, PhD +! Senior Research Scientist Staff Scientist +! Pacific Northwest National Laboratory Pacific Northwest National Laboratory +! P.O. Box 999, MSIN K9-30 P.O. Box 999, MSIN K9-30 +! Richland, WA 99352 Richland, WA, 99352 +! Phone: (509) 372-6159 Phone: (509) 372-6116 +! Email: Rahul.Zaveri@pnl.gov Email: Jerome.Fast@pnl.gov +! +! Please report any bugs or problems to Rahul Zaveri, the primary author of the +! code, or Jerome Fast, the WRF-chem implementation team leader for PNNL +! +! Terms of Use: +! 1) MOSAIC and its sub-modules ASTEEM, MESA, and MTEM may not be included in +! any commercial package or used for any commercial applications without the +! primary author's prior consent. +! 2) The MOSAIC source code is provided to the WRF modeling community; however, +! no portion of MOSAIC can be used separately or in another code without the +! primary author's prior consent. +! 3) The MOSAIC source code may be used for research, educational, and non-profit +! purposes only. Any other usage must be first approved by the primary author. +! 4) Publications resulting from the usage of MOSAIC must use one or more of the +! references below (depending on the application) for proper acknowledgment. +! +! References: +! * Zaveri R.A., R.C. Easter, and A.S. Wexler (2005), A new method for multi- +! component activity coefficients of electrolytes in aqueous atmospheric +! aerosols, J. Geophys. Res., 110, D02201, doi:10.1029/2004JD004681. +! * Zaveri R.A., R.C. Easter, and L.K. Peters (2005), A computationally efficient +! multicomponent equilibrium solver for aerosols (MESA), In review, +! J. Geophys. Res. +! * Zaveri R.A., R.C. Easter, J.D. Fast, and L.K. Peters (2005), A new model +! for simulating aerosol interactions and chemistry (MOSAIC), Manuscript in +! preparation. To be submitted to J. Geophys. Res. +! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. Barnard, E.G. +! Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution of ozone, particulates, +! and aerosol direct radiative forcing in the vicinity of Houston using a fully- +! coupled meteorology-chemistry-aerosol model, Submitted to J. Geophys. Res. +! +! Contact Jerome Fast for updates on the status of manuscripts under review. The +! third paper will be the main reference for MOSAIC when published. +! +! Note that the version of MESA currently in WRF-chem does not contain some of +! the code associated with the numerical speed described in the second paper - +! a revised version of MESA will be included in the next release of MOSAIC. +! +! Additional information: +! * www.pnl.gov/atmos_sciences/raz +! * www.pnl.gov/atmos_sciences/Jdf/wrfchem.html +! +! Support: +! Funding for developing and evaluating MOSAIC was provided by the U.S. Department +! of Energy under the auspices of Atmospheric Science Program of the Office of +! Biological and Environmental Research, the NASA Earth Sciences Enterprise under +! grant NAGW 3367, and PNNL Laboratory Directed Research and Development program. +!********************************************************************************** + module module_mosaic_driver + + +! +! *** NOTE - when the cw species are NOT in the registry, then +! then the p_xxx_cwnn variables are not in module_state_description, +! and the following cpp directive should be commented out +! +#define cw_species_are_in_registry + + + contains + +!----------------------------------------------------------------------- +! +! rce 2005-feb-18 - one fix involving dcen_sect indices [now (isize,itype)] +! +! rce 2004-dec-03 - many changes associated with the new aerosol "pointer" +! variables in module_data_mosaic_asect +! nov-04 sg ! replaced amode with aer and expanded aerosol dimension +! to include type and phase +! +! rce 11-sep-2004 - numerous changes +! eliminated use of the _wrfch pointers (lptr_xxx_a_wrfch, +! lwaterptr_wrfch, numptr_wrfch); use only the _aer pointers now +! aboxtest_... variables are now in module_data_mosaic_other +! +!----------------------------------------------------------------------- + + subroutine mosaic_aerchem_driver( & + id, ktau, dtstep, ktauc, dtstepc, config_flags, & + t_phy, rho_phy, p_phy, & + moist, chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + use module_configure, only: grid_config_rec_type, & + p_qv, & + p_so2, p_ho2, p_so4aj, p_corn, p_hcl, p_mtf, & + p_so4_a01, p_water_a01, p_num_a01, & + p_so4_a04, p_water_a04, p_num_a04 + + use module_state_description, only: num_moist, num_chem + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_mosaic_therm, only: aerchemistry, print_mosaic_stats, & + iprint_mosaic_fe1, iprint_mosaic_perform_stats, & + iprint_mosaic_diag1, iprint_mosaic_input_ok + use module_mosaic_newnuc, only: mosaic_newnuc_1clm + use module_mosaic_coag, only: mosaic_coag_1clm + use module_peg_util, only: peg_error_fatal, peg_message + + implicit none + +!----------------------------------------------------------------------- +! DESCRIPTION +! +! mosaic_aerchem_driver is the interface between wrf-chem and the +! mosaic aerosol-chemistry routine cat computes condensation/evaporation +! of trace gases to/from aerosol particles (AP). It currently treats +! water vapor and the 4 inorganic trace gases (nh3, h2so4, hno3, and hcl). +! The aerosol-chemistry routine can work with either a sectional +! (multiple size bins) or modal (multiple modes) representation. +! +! In both cases, condensation/evaporation to/from each bins/mode is +! first computed. For sectional representation, AP mass and number +! are then transferred between size bins as a result of AP +! positive/negative growth. Either a moving-center or two-moment +! algorithm can be used to compute this transfer. +! +! mosaic_aerchem_driver is organized as follows +! loop over j and i +! call mapaer_tofrom_host to map 1 column of gas and aerosol mixing +! ratios from the chem array to the rsub array (and convert units) +! call aerchemistry to do the aerosol chemistry calculations +! for timestep = dtstepc +! call mapaer_tofrom_host to map 1 column of gas and aerosol mixing +! ratios from the rsub array back to the chem array +! +!----------------------------------------------------------------------- + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte +! id - domain index +! ktau - time step number +! ktauc - gas and aerosol chemistry time step number + +! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for "domain" +! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for "memory" +! Most arrays that are arguments to chem_driver +! are dimensioned with these spatial indices. +! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" +! chem_driver and routines under it do calculations +! over these spatial indices. + + real, intent(in) :: dtstep, dtstepc +! dtstep - main model time step (s) +! dtstepc - time step for gas and aerosol chemistry(s) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + t_phy, rho_phy, p_phy +! t_phy - temperature (K) +! rho_phy - air density (kg/m^3) +! p_phy - air pressure (Pa) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist +! moist - mixing ratios of moisture species (water vapor, +! cloud water, ...) (kg/kg for mass species, #/kg for number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem +! chem - mixing ratios of trace gase (ppm) and aerosol species +! (ug/kg for mass species, #/kg for number species) + + type(grid_config_rec_type), intent(in) :: config_flags +! config_flags - configuration and control parameters + +!----------------------------------------------------------------------- +! local variables + integer :: i, idum, istat, it, j, jt, k, l, n + integer :: k_pegshift, kclm_calcbgn, kclm_calcend + integer :: ktmaps, ktmape + integer :: levdbg_err, levdbg_info + integer :: i_force_dump, mode_force_dump + integer :: idiagaa_dum, idiagbb_dum, ijcount_dum + integer, parameter :: debug_level=0 + integer, parameter :: aercoag_onoff = 1 + integer, parameter :: aernewnuc_onoff = 1 + + real :: dtchem, dtcoag, dtnuc + real :: dum + real :: rsub0(l2maxd,kmaxd,nsubareamaxd) + + character*100 msg + + + if (debug_level .ge. 15) then +!rcetestc diagnostics -------------------------------------------------- +! if (kte .eq. -99887766) then + if (ktauc .le. 2) then + print 93010, ' ' + print 93010, 'rcetestc diagnostics from mosaic_aerchem_driver' + print 93010, 'id, chem_opt, ktau, ktauc ', & + id, config_flags%chem_opt, ktau, ktauc + print 93020, 'dtstep, dtstepc ', & + dtstep, dtstepc + print 93010, 'ims/e, j, k', ims, ime, jms, jme, kms, kme + print 93010, 'its/e, j, k', its, ite, jts, jte, kts, kte + print 93010, 'num_chem, p_so2, p_ho2 ', num_chem, p_so2, p_ho2 + print 93010, 'p_so4aj, p_corn, p_hcl, p_mtf', p_so4aj, p_corn, p_hcl, p_mtf + print 93010, 'p_so4_a01, p_water, p_num_a01', p_so4_a01, p_water_a01, p_num_a01 + print 93010, 'p_so4_a04, p_water, p_num_a04', p_so4_a04, p_water_a04, p_num_a04 + + k = kts + print 93020, 't, p, rho, qv at its/kts /jts', t_phy(its,k,jts), & + p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv) + k = (kts + kte - 1)/2 + print 93020, 't, p, rho, qv at its/ktmi/jts', t_phy(its,k,jts), & + p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv) + k = kte-1 + print 93020, 't, p, rho, qv at its/kte-/jts', t_phy(its,k,jts), & + p_phy(its,k,jts), rho_phy(its,k,jts), moist(its,k,jts,p_qv) +93010 format( a, 8(1x,i6) ) +93020 format( a, 8(1p,e14.6) ) + end if +! end if +!rcetestc diagnostics -------------------------------------------------- + end if + +! The default values for these informational printout settings are set +! in module_data_mosaic_therm.F. + if (debug_level .lt. 15) then + iprint_mosaic_fe1 = 1 + iprint_mosaic_perform_stats = 0 + iprint_mosaic_diag1 = 0 + iprint_mosaic_input_ok = 0 + end if + + +! ktmaps,ktmape = first/last wrf kt for which aer chem is done + ktmaps = kts + ktmape = kte-1 + +! rce 2005-mar-09 - added kclm_calcbgn/end +! kclm_calcbgn,kclm_calcend = first/last pegasus array k +! for which aer chem is done + k_pegshift = k_pegbegin - kts + kclm_calcbgn = kts + k_pegshift + kclm_calcend = (kte-1) + k_pegshift + +! set some variables to their wrf-chem "standard" values + mode_force_dump = 0 + levdbg_err = 0 + levdbg_info = 15 + +! eventually iymdcur & ihmscur should be set to the correct date/time +! using wrf timing routines + dum = dtstep*(ktau-1) + iymdcur = 1 + ifix( dum/86400.0 ) + dum = mod( dum, 86400.0 ) + ihmscur = nint( dum ) + + t = dtstep*(ktau-1) + ncorecnt = ktau - 1 + +#if defined ( aboxtest_box_testing_active ) +! *** start of "box testing" code section *** +! these code lines should be inactive when running wrf-chem +! +! get values for some "box test" variables + call aboxtest_get_extra_args( 20, & + iymdcur, ihmscur, & + idum, idum, idum, idum, idum, idum, idum, & + t, dum ) +! *** end of "box testing" code section *** +#endif + + +! set "pegasus" grid size variables + itot = ite + jtot = jte + nsubareas = 1 + + ijcount_dum = 0 + + call print_mosaic_stats( 0 ) + + + do 2920 jt = jts, jte + do 2910 it = its, ite + + ijcount_dum = ijcount_dum + 1 + dtchem = dtstepc + + +! mode_force_dump selects a detailed dump of gaschem at either +! first ijk grid, first ij column, all ijk, or no ijk + i_force_dump = 0 +! if (mode_force_dump .eq. 10) then +! if ((it.eq.its) .and. (jt.eq.jts)) i_force_dump = 1 +! else if (mode_force_dump .eq. 100) then +! i_force_dump = 1 +! else if (mode_force_dump .eq. 77) then +! if ( (it .eq. (its+ite)/2) .and. & +! (jt .eq. (jts+jte)/2) ) i_force_dump = 1 +! end if + + +! print 93010, 'calling mapaeraa - it, jt =', it, jt + call mapaer_tofrom_host( 0, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, ktmaps,ktmape, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + +!rce 22-jul-2006 - save initial mixrats + rsub0(:,:,:) = rsub(:,:,:) + + idiagaa_dum = 0 + idiagbb_dum = 110 +!rce 29-apr-2004 - following is for debugging texas 16 km run +! if ((its.eq.38) .and. (jts.eq.38) & +! .and. (ktau.eq.240)) idiagaa_dum = 1 +! if ((it .eq.45) .and. (jt .eq.71) & +! .and. (ktau.eq.240)) idiagaa_dum = 1 +! if ( ijcount_dum > 169 .and. ktau > 2579 ) then !fastj crash +! if ( ijcount_dum > 300 .and. ktau > 2969 ) then !madronovich crash +! idiagaa_dum = 111 +! i_force_dump = 1 +! end if + +! if (ijcount_dum .le. 1) i_force_dump = 1 +! i_force_dump = 0 + + if (i_force_dump > 0) call aerchem_debug_dump( 1, it, jt, dtchem ) + +! if ((it .eq.45) .and. (jt .eq.71) & +! .and. (ktau.eq.240)) then +! call aerchem_debug_dump( 1, it, jt, dtchem ) +! call aerchem_debug_dump( 3, it, jt, dtchem ) +! end if + + if (idiagaa_dum > 0) & + print 93010, 'calling aerchem - it,jt,maerchem =', it, jt, maerchem +! print 93010, 'calling aerchem - it,jt,maerchem =', it, jt, maerchem + call aerchemistry( it, jt, kclm_calcbgn, kclm_calcend, & + dtchem, idiagaa_dum ) + +! note units for aerosol is now ug/m3 + + call wrf_debug(300,"mosaic_aerchem_driver: back from aerchemistry") + if ((it .eq.45) .and. (jt .eq.71) & + .and. (ktau.eq.240)) then + call aerchem_debug_dump( 3, it, jt, dtchem ) + end if + + if (i_force_dump > 0) call aerchem_debug_dump( 3, it, jt, dtchem ) + + + if (aernewnuc_onoff > 0) then + if (idiagaa_dum > 0) print 93010, 'calling mosaic_newnuc_1clm' + dtnuc = dtchem + call mosaic_newnuc_1clm( istat, & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_dum, dtchem, dtnuc, rsub0, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte ) + end if + + + if (aercoag_onoff > 0) then + if (idiagaa_dum > 0) print 93010, 'calling mosaic_coag_1clm' + dtcoag = dtchem + call mosaic_coag_1clm( istat, & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_dum, dtchem, dtcoag, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte ) + end if + + + if (idiagaa_dum > 0) & + print 93010, 'calling mapaerbb' + call mapaer_tofrom_host( 1, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, ktmaps,ktmape, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + +! print 93010, 'backfrm mapaerbb', it, jt +2910 continue +2920 continue + + +! rce 2005-apr-30 - added 2 calls to print_mosaic_stats + call print_mosaic_stats( 1 ) + print 93010, 'leaving mosaic_aerchem_driver - ktau =', ktau + + return + end subroutine mosaic_aerchem_driver + + +!----------------------------------------------------------------------- + subroutine sum_pm_mosaic ( & + alt, chem, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_state_description, only: num_chem + USE module_data_mosaic_asect + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: alt + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10 + + INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase + + imax = min(ite,ide-1) + jmax = min(jte,jde-1) + kmax = kte-1 +! +! Sum over bins with center diameter < 2.5e-4 cm for pm2_5_dry, +! pm2_5_dry_ec, and pm2_5_water. All bins go into pm10 +! + pm2_5_dry(its:ite,kts:kte,jts:jte) = 0. + pm2_5_dry_ec(its:ite,kts:kte,jts:jte) = 0. + pm2_5_water(its:ite,kts:kte,jts:jte) = 0. + pm10(its:ite,kts:kte,jts:jte) = 0. + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + if (dcen_sect(n,itype) .le. 2.5e-4) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) & + + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + + pm2_5_water(i,k,j) = pm2_5_water(i,k,j) & + + chem(i,k,j,waterptr_aer(n,itype)) + + pm10(i,k,j) = pm10(i,k,j) + pm2_5_dry(i,k,j) + enddo + enddo + enddo + else + do j=jts,jmax + do k=kts,kmax + do i=its,imax + pm10(i,k,j) = pm10(i,k,j) & + + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + enddo + enddo + enddo + endif + enddo ! size + enddo ! type + enddo ! phase + + !Convert the units from mixing ratio to concentration (ug m^-3) + pm2_5_dry(its:imax,kts:kmax,jts:jmax) = pm2_5_dry(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + pm2_5_water(its:imax,kts:kmax,jts:jmax) = pm2_5_water(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + + end subroutine sum_pm_mosaic + +! ---------------------------------------------------------------------- + subroutine mapaer_tofrom_host( imap, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, ktmaps,ktmape, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + + use module_configure, only: & + p_qv, p_qc, p_sulf, p_hno3, p_hcl, p_nh3, p_o3, & + p_so2, p_h2o2, p_hcho, p_ora1, p_ho, p_ho2, p_no3, & + p_no, p_no2, p_hono, p_pan, p_ch3o2, p_ch3oh, p_op1 + use module_state_description, only: param_first_scalar + use module_data_mosaic_asect + use module_data_mosaic_other + use module_mosaic_csuesat, only: esat_gchm + use module_peg_util, only: peg_error_fatal, peg_message + + implicit none + +! subr arguments + +! imap determines mapping direction (chem-->rsub if <=0, rsub-->chem if >0) + integer, intent(in) :: imap +! wrf array dimensions + integer, intent(in) :: num_moist, num_chem + integer, intent(in) :: ims, ime, jms, jme, kms, kme + integer, intent(in) :: its, ite, jts, jte, kts, kte +! do mapping for wrf i,k,j grid points = [it,ktmaps:ktmape,jt] + integer, intent(in) :: it, jt, ktmaps, ktmape +! + real, intent(in), dimension( ims:ime, kms:kme, jms:jme ) :: & + t_phy, rho_phy, p_phy + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + + +! local variables + integer ido_l, idum, iphase, itype, & + k, k1, k2, kt, kt1, kt2, k_pegshift, l, n + integer p1st + real dum, dumesat, dumrsat, dumrelhum, onemeps + real factdens, factpres, factmoist, factgas, & + factaerso4, factaerno3, factaercl, factaermsa, & + factaerco3, factaernh4, factaerna, factaerca, & + factaeroin, factaeroc, factaerbc, & + factaerhysw, factaerwater, factaernum + + real, parameter :: eps=0.622 + + character*80 msg + + +! +! units conversion factors +! wrf-chem value = pegasus value X factor +! + factdens = 28.966e3 ! moleair/cm3 --> kgair/m3 + factpres = 0.1 ! dyne/cm2 --> pa + factmoist = eps ! moleh2o/moleair --> kgh2o/kgair + factgas = 1.0e6 ! mole/moleair --> ppm + +!wig 9-Nov-2004: Change to converting from concentration to converting +! from mixing ratio. +! factaernum = 40.9 ! #/moleair --> #/m3 at STP +!! at 1 atm & 298 k, 1 m3 = 40.9 moleair, 1 liter = 0.0409 moleair + factaernum = 1000./28.966 ! 1 kg air = (1000/28.966) moleair + + dum = factaernum*1.0e6 ! g/moleair --> ug/m3 at STP + factaerso4 = dum*mw_so4_aer + factaerno3 = dum*mw_no3_aer + factaercl = dum*mw_cl_aer + factaermsa = dum*mw_msa_aer + factaerco3 = dum*mw_co3_aer + factaernh4 = dum*mw_nh4_aer + factaerna = dum*mw_na_aer + factaerca = dum*mw_ca_aer + factaeroin = dum + factaeroc = dum + factaerbc = dum + factaerhysw = dum*mw_water_aer + factaerwater = dum*mw_water_aer + +! If aboxtest_units_convert=10, turn off units conversions both here +! and in module_mosaic. This is for testing, to allow exact agreements. + if (aboxtest_units_convert .eq. 10) then + factdens = 1.0 + factpres = 1.0 + factmoist = 1.0 + factgas = 1.0 + factaernum = 1.0 + factaerso4 = 1.0 + factaerno3 = 1.0 + factaercl = 1.0 + factaermsa = 1.0 + factaerco3 = 1.0 + factaernh4 = 1.0 + factaerna = 1.0 + factaerca = 1.0 + factaeroin = 1.0 + factaeroc = 1.0 + factaerbc = 1.0 + factaerhysw = 1.0 + factaerwater = 1.0 + end if + + +! rce 2005-mar-09 - set ktot in mapaer_tofrom_host; +! use k_pegshift for calc of ktot and k (=k_peg) +! k_pegshift = k index shift between wrf-chem and pegasus arrays + k_pegshift = k_pegbegin - kts + +! set ktot = highest k index for pegasus arrays +! since kts=1 and k_pegbegin=1, get k_pegshift=0 and ktot=kte-1 + ktot = (kte-1) + k_pegshift +! *** check that ktot and kte <= kmaxd *** + if ((kte > kmaxd) .or. (ktot > kmaxd) .or. (ktot <= 0)) then + write( msg, '(a,4i5)' ) & + '*** subr mapaer_tofrom_host -- ' // & + 'ktot, kmaxd, kts, kte', ktot, kmaxd, kts, kte + call peg_message( lunerr, msg ) + msg = '*** subr mosaic_aerchem_driver -- ' // & + 'kte>kmaxd OR ktot>kmaxd OR ktot<=0' + call peg_error_fatal( lunerr, msg ) + end if + +! rce 2005-apr-28 - changed mapping loops to improve memory access +! now do rsub(l,k1:k2,m) <--> chem(it,kt1:kt2,jt,l) for each species + kt1 = ktmaps + kt2 = ktmape + k1 = kt1 + k_pegshift + k2 = kt2 + k_pegshift + + if (imap .gt. 0) goto 2000 + +! +! imap==0 -- map species and state variables from host arrays +! to rsub, cairclm, ptotclm + +! first zero everything (except relhumclm) + rsub(:,:,:) = 0.0 + cairclm(:) = 0.0 + ptotclm(:) = 0.0 + afracsubarea(:,:) = 0.0 + relhumclm(:) = aboxtest_min_relhum + rcldwtr_sub(:,:) = 0.0 + + adrydens_sub( :,:,:,:) = 0.0 + aqmassdry_sub(:,:,:,:) = 0.0 + aqvoldry_sub( :,:,:,:) = 0.0 + +! map gas and aerosol mixing ratios based on aboxtest_map_method +! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx +! 2 - map 181 pegasus species using rsub(l) = chem(l+1) +! 3 - do 2 followed by 1 +! other - same as 1 +! (2 and 3 are for box test purposes) + if ((aboxtest_map_method .eq. 2) .or. & + (aboxtest_map_method .eq. 3)) then + do l = 2, num_chem + rsub(l,k1:k2,1) = chem(it,kt1:kt2,jt,l)/factgas + end do + end if + + p1st = param_first_scalar + if (aboxtest_map_method .ne. 2) then + if (p_sulf .ge. p1st) & + rsub(kh2so4,k1:k2,1) = chem(it,kt1:kt2,jt,p_sulf)/factgas + if (p_hno3 .ge. p1st) & + rsub(khno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_hno3)/factgas + if (p_hcl .ge. p1st) & + rsub(khcl,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcl)/factgas + if (p_nh3 .ge. p1st) & + rsub(knh3,k1:k2,1) = chem(it,kt1:kt2,jt,p_nh3)/factgas + +! rce 2005-apr-12 - added following species for cldchem, here and below: +! ko3, kso2, kh2o2, khcho, khcooh, koh, kho2, +! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh + if (p_o3 .ge. p1st) & + rsub(ko3,k1:k2,1) = chem(it,kt1:kt2,jt,p_o3)/factgas + if (p_so2 .ge. p1st) & + rsub(kso2,k1:k2,1) = chem(it,kt1:kt2,jt,p_so2)/factgas + if (p_h2o2 .ge. p1st) & + rsub(kh2o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_h2o2)/factgas + if (p_hcho .ge. p1st) & + rsub(khcho,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcho)/factgas + if (p_ora1 .ge. p1st) & + rsub(khcooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ora1)/factgas + if (p_ho .ge. p1st) & + rsub(koh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho)/factgas + if (p_ho2 .ge. p1st) & + rsub(kho2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ho2)/factgas + if (p_no3 .ge. p1st) & + rsub(kno3,k1:k2,1) = chem(it,kt1:kt2,jt,p_no3)/factgas + if (p_no .ge. p1st) & + rsub(kno,k1:k2,1) = chem(it,kt1:kt2,jt,p_no)/factgas + if (p_no2 .ge. p1st) & + rsub(kno2,k1:k2,1) = chem(it,kt1:kt2,jt,p_no2)/factgas + if (p_hono .ge. p1st) & + rsub(khono,k1:k2,1) = chem(it,kt1:kt2,jt,p_hono)/factgas + if (p_pan .ge. p1st) & + rsub(kpan,k1:k2,1) = chem(it,kt1:kt2,jt,p_pan)/factgas + if (p_ch3o2 .ge. p1st) & + rsub(kch3o2,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3o2)/factgas + if (p_ch3oh .ge. p1st) & + rsub(kch3oh,k1:k2,1) = chem(it,kt1:kt2,jt,p_ch3oh)/factgas + if (p_op1 .ge. p1st) & + rsub(kch3ooh,k1:k2,1) = chem(it,kt1:kt2,jt,p_op1)/factgas + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase))/factaerso4 + rsub(numptr_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase))/factaernum + + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase))/factaerno3 + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase))/factaercl + if (lptr_msa_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase))/factaermsa + if (lptr_co3_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase))/factaerco3 + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase))/factaernh4 + if (lptr_na_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_na_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase))/factaerna + if (lptr_ca_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase))/factaerca + if (lptr_oin_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase))/factaeroin + if (lptr_oc_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase))/factaeroc + if (lptr_bc_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase))/factaerbc + if (hyswptr_aer(n,itype) .ge. p1st) & + rsub(hyswptr_aer(n,itype),k1:k2,1) = & + chem(it,kt1:kt2,jt,hyswptr_aer(n,itype))/factaerhysw + if (waterptr_aer(n,itype) .ge. p1st) & + rsub(waterptr_aer(n,itype),k1:k2,1) = & + chem(it,kt1:kt2,jt,waterptr_aer(n,itype))/factaerwater + end do ! size + end do ! type + end do ! phase + end if + +! map state variables + afracsubarea(k1:k2,1) = 1.0 + rsub(ktemp,k1:k2,1) = t_phy(it,kt1:kt2,jt) + rsub(kh2o,k1:k2,1) = moist(it,kt1:kt2,jt,p_qv)/factmoist + cairclm(k1:k2) = rho_phy(it,kt1:kt2,jt)/factdens + ptotclm(k1:k2) = p_phy(it,kt1:kt2,jt)/factpres + if (p_qc .ge. p1st) & + rcldwtr_sub(k1:k2,1) = moist(it,kt1:kt2,jt,p_qc)/factmoist + +! compute or get relative humidity, based on aboxtest_rh_method +! 1 - compute from water vapor, temperature, and pressure +! 2 - get from test driver via aboxtest_get_extra_args with iflag=30 +! 3 - do both, and use the relhum from test driver +! other positive - same as 1 +! 0 or negative - set to aboxtest_min_relhum + +#if defined ( aboxtest_box_testing_active ) +! *** start of "box testing" code section *** +! these code lines should be inactive when running wrf-chem +! +! get relhumclm from box test driver + if ((aboxtest_rh_method .eq. 2) .or. & + (aboxtest_rh_method .eq. 3)) then + do kt = ktmaps, ktmape + k = kt + k_pegshift + call aboxtest_get_extra_args( 30, & + it, jt, k, idum, idum, idum, idum, idum, idum, & + relhumclm(k), dum ) + end do + end if +! *** end of "box testing" code section *** +#endif + +! compute relhumclm from water vapor, temperature, and pressure +! *** force relhum to between aboxtest_min/max_relhum + if ((aboxtest_rh_method .gt. 0) .and. & + (aboxtest_rh_method .ne. 2)) then + do kt = ktmaps, ktmape + k = kt + k_pegshift + onemeps = 1.0 - 0.622 + dumesat = esat_gchm( rsub(ktemp,k,1) ) + dumrsat = dumesat / (ptotclm(k) - onemeps*dumesat) + dumrelhum = rsub(kh2o,k,1) / max( dumrsat, 1.e-20 ) + dumrelhum = max( 0.0, min( 0.99, dumrelhum ) ) + + if (aboxtest_rh_method .eq. 3) then +! write(msg,9720) k, relhumclm(k), dumrelhum, & +! (dumrelhum-relhumclm(k)) +!9720 format( 'k,rh1,rh2,2-1', i4, 3f14.10 ) +! call peg_message( lunerr, msg ) + continue + else + relhumclm(k) = dumrelhum + end if + relhumclm(k) = max( relhumclm(k), aboxtest_min_relhum ) + relhumclm(k) = min( relhumclm(k), aboxtest_max_relhum ) + end do + end if + +! *** force temperature to be > aboxtest_min_temp + do kt = ktmaps, ktmape + k = kt + k_pegshift + rsub(ktemp,k,1) = & + max( rsub(ktemp,k,1), aboxtest_min_temp ) + end do + + return + + +! +! imap==1 -- map species from rsub back to host arrays +! (map gas and aerosol mixing ratios based on aboxtest_map_method as above) +! +! when aboxtest_gases_fixed==10, leave gases (h2so4,hno3,...) unchanged +! +2000 continue +! map gas and aerosol mixing ratios based on aboxtest_map_method +! 1 - map aerosol species and h2so4/hno3/hcl/nh3 using the p_xxx +! 2 - map 181 pegasus species using rsub(l) = chem(l+1) +! 3 - do 2 followed by 1 +! other - same as 1 +! (2 and 3 are for box test purposes) + if ((aboxtest_map_method .eq. 2) .or. & + (aboxtest_map_method .eq. 3)) then + do l = 2, num_chem + ido_l = 1 + if (aboxtest_gases_fixed .eq. 10) then + if ((l .eq. kh2so4 ) .or. (l .eq. khno3 ) .or. & + (l .eq. khcl ) .or. (l .eq. knh3 ) .or. & + (l .eq. ko3 ) .or. & + (l .eq. kso2 ) .or. (l .eq. kh2o2 ) .or. & + (l .eq. khcho ) .or. (l .eq. khcooh ) .or. & + (l .eq. koh ) .or. (l .eq. kho2 ) .or. & + (l .eq. kno3 ) .or. (l .eq. kno ) .or. & + (l .eq. kno2 ) .or. (l .eq. khono ) .or. & + (l .eq. kpan ) .or. (l .eq. kch3o2 ) .or. & + (l .eq. kch3oh ) .or. (l .eq. kch3ooh)) then + ido_l = 0 + end if + end if + if (ido_l .gt. 0) then + chem(it,kt1:kt2,jt,l) = rsub(l,k1:k2,1)*factgas + end if + end do + end if + + p1st = param_first_scalar + if (aboxtest_map_method .ne. 2) then + if (aboxtest_gases_fixed .ne. 10) then + if (p_sulf .ge. p1st) & + chem(it,kt1:kt2,jt,p_sulf) = rsub(kh2so4,k1:k2,1)*factgas + if (p_hno3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_hno3) = rsub(khno3,k1:k2,1)*factgas + if (p_hcl .ge. p1st) & + chem(it,kt1:kt2,jt,p_hcl) = rsub(khcl,k1:k2,1)*factgas + if (p_nh3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_nh3) = rsub(knh3,k1:k2,1)*factgas + + if (p_o3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_o3) = rsub(ko3,k1:k2,1)*factgas + if (p_so2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_so2) = rsub(kso2,k1:k2,1)*factgas + if (p_h2o2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_h2o2) = rsub(kh2o2,k1:k2,1)*factgas + if (p_hcho .ge. p1st) & + chem(it,kt1:kt2,jt,p_hcho) = rsub(khcho,k1:k2,1)*factgas + if (p_ora1 .ge. p1st) & + chem(it,kt1:kt2,jt,p_ora1) = rsub(khcooh,k1:k2,1)*factgas + if (p_ho .ge. p1st) & + chem(it,kt1:kt2,jt,p_ho) = rsub(koh,k1:k2,1)*factgas + if (p_ho2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_ho2) = rsub(kho2,k1:k2,1)*factgas + if (p_no3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_no3) = rsub(kno3,k1:k2,1)*factgas + if (p_no .ge. p1st) & + chem(it,kt1:kt2,jt,p_no) = rsub(kno,k1:k2,1)*factgas + if (p_no2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_no2) = rsub(kno2,k1:k2,1)*factgas + if (p_hono .ge. p1st) & + chem(it,kt1:kt2,jt,p_hono) = rsub(khono,k1:k2,1)*factgas + if (p_pan .ge. p1st) & + chem(it,kt1:kt2,jt,p_pan) = rsub(kpan,k1:k2,1)*factgas + if (p_ch3o2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_ch3o2) = rsub(kch3o2,k1:k2,1)*factgas + if (p_ch3oh .ge. p1st) & + chem(it,kt1:kt2,jt,p_ch3oh) = rsub(kch3oh,k1:k2,1)*factgas + if (p_op1 .ge. p1st) & + chem(it,kt1:kt2,jt,p_op1) = rsub(kch3ooh,k1:k2,1)*factgas + end if + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + chem(it,kt1:kt2,jt,lptr_so4_aer(n,itype,iphase)) = & + rsub(lptr_so4_aer(n,itype,iphase),k1:k2,1)*factaerso4 + chem(it,kt1:kt2,jt,numptr_aer(n,itype,iphase)) = & + rsub(numptr_aer(n,itype,iphase),k1:k2,1)*factaernum + + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_no3_aer(n,itype,iphase)) = & + rsub(lptr_no3_aer(n,itype,iphase),k1:k2,1)*factaerno3 + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_cl_aer(n,itype,iphase)) = & + rsub(lptr_cl_aer(n,itype,iphase),k1:k2,1)*factaercl + if (lptr_msa_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_msa_aer(n,itype,iphase)) = & + rsub(lptr_msa_aer(n,itype,iphase),k1:k2,1)*factaermsa + if (lptr_co3_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_co3_aer(n,itype,iphase)) = & + rsub(lptr_co3_aer(n,itype,iphase),k1:k2,1)*factaerco3 + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_nh4_aer(n,itype,iphase)) = & + rsub(lptr_nh4_aer(n,itype,iphase),k1:k2,1)*factaernh4 + if (lptr_na_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_na_aer(n,itype,iphase)) = & + rsub(lptr_na_aer(n,itype,iphase),k1:k2,1)*factaerna + if (lptr_ca_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_ca_aer(n,itype,iphase)) = & + rsub(lptr_ca_aer(n,itype,iphase),k1:k2,1)*factaerca + if (lptr_oin_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_oin_aer(n,itype,iphase)) = & + rsub(lptr_oin_aer(n,itype,iphase),k1:k2,1)*factaeroin + if (lptr_oc_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_oc_aer(n,itype,iphase)) = & + rsub(lptr_oc_aer(n,itype,iphase),k1:k2,1)*factaeroc + if (lptr_bc_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bc_aer(n,itype,iphase)) = & + rsub(lptr_bc_aer(n,itype,iphase),k1:k2,1)*factaerbc + if (hyswptr_aer(n,itype) .ge. p1st) & + chem(it,kt1:kt2,jt,hyswptr_aer(n,itype)) = & + rsub(hyswptr_aer(n,itype),k1:k2,1)*factaerhysw + if (waterptr_aer(n,itype) .ge. p1st) & + chem(it,kt1:kt2,jt,waterptr_aer(n,itype)) = & + rsub(waterptr_aer(n,itype),k1:k2,1)*factaerwater + end do ! size + end do ! type + end do ! phase + end if + + + return + + end subroutine mapaer_tofrom_host + + +!----------------------------------------------------------------------- +! *** note - eventually is_aerosol will be a subr argument + subroutine init_data_mosaic_asect( is_aerosol ) +! subroutine init_data_mosaic_asect( ) + + use module_data_mosaic_asect + use module_data_mosaic_other, only: lunerr, lunout, & + aboxtest_testmode, aboxtest_units_convert, & + aboxtest_rh_method, aboxtest_map_method, & + aboxtest_gases_fixed, aboxtest_min_temp, & + aboxtest_min_relhum, aboxtest_max_relhum + use module_data_mosaic_therm, only: nbin_a, nbin_a_maxd + use module_mosaic_csuesat, only: init_csuesat + use module_mosaic_movesect, only: move_sections, test_move_sections + use module_peg_util, only: peg_error_fatal + + + use module_configure, only: & + p_so4_a01, p_so4_a02, p_so4_a03, p_so4_a04, & + p_so4_a05, p_so4_a06, p_so4_a07, p_so4_a08 +#if defined ( cw_species_are_in_registry ) + use module_configure, only: & + p_so4_cw01, p_no3_cw01, p_cl_cw01, p_nh4_cw01, p_na_cw01, & + p_so4_cw02, p_no3_cw02, p_cl_cw02, p_nh4_cw02, p_na_cw02, & + p_so4_cw03, p_no3_cw03, p_cl_cw03, p_nh4_cw03, p_na_cw03, & + p_so4_cw04, p_no3_cw04, p_cl_cw04, p_nh4_cw04, p_na_cw04, & + p_so4_cw05, p_no3_cw05, p_cl_cw05, p_nh4_cw05, p_na_cw05, & + p_so4_cw06, p_no3_cw06, p_cl_cw06, p_nh4_cw06, p_na_cw06, & + p_so4_cw07, p_no3_cw07, p_cl_cw07, p_nh4_cw07, p_na_cw07, & + p_so4_cw08, p_no3_cw08, p_cl_cw08, p_nh4_cw08, p_na_cw08, & + p_oin_cw01, p_oc_cw01, p_bc_cw01, p_num_cw01, & + p_oin_cw02, p_oc_cw02, p_bc_cw02, p_num_cw02, & + p_oin_cw03, p_oc_cw03, p_bc_cw03, p_num_cw03, & + p_oin_cw04, p_oc_cw04, p_bc_cw04, p_num_cw04, & + p_oin_cw05, p_oc_cw05, p_bc_cw05, p_num_cw05, & + p_oin_cw06, p_oc_cw06, p_bc_cw06, p_num_cw06, & + p_oin_cw07, p_oc_cw07, p_bc_cw07, p_num_cw07, & + p_oin_cw08, p_oc_cw08, p_bc_cw08, p_num_cw08 +#endif + + use module_state_description, only: param_first_scalar, num_chem + + implicit none + +! *** note - eventually is_aerosol will be a subr argument + logical, intent(out) :: is_aerosol(num_chem) + +! local variables + integer idum, itype, l, ldum, n, nhi, nsize_aer_dum + real dum + real, parameter :: pi = 3.14159265 + +! +! set some "pegasus" control variables +! + msectional = 20 + maerocoag = -2 + maerchem = 1 + maeroptical = 1 + maerchem_boxtest_output = -1 + +! +! set ntype_aer = 1 +! + ntype_aer = 1 + +! +! set number of aerosol bins using the wrf-chem sulfate pointers +! + nsize_aer(:) = 0 + itype=1 + if (p_so4_a01 .ge. param_first_scalar) nsize_aer(itype) = 1 + if (p_so4_a02 .ge. param_first_scalar) nsize_aer(itype) = 2 + if (p_so4_a03 .ge. param_first_scalar) nsize_aer(itype) = 3 + if (p_so4_a04 .ge. param_first_scalar) nsize_aer(itype) = 4 + if (p_so4_a05 .ge. param_first_scalar) nsize_aer(itype) = 5 + if (p_so4_a06 .ge. param_first_scalar) nsize_aer(itype) = 6 + if (p_so4_a07 .ge. param_first_scalar) nsize_aer(itype) = 7 + if (p_so4_a08 .ge. param_first_scalar) nsize_aer(itype) = 8 + + if (nsize_aer(itype) .le. 0) then + call peg_error_fatal( lunerr, & + 'init_data_mosaic_asect - nsize_aer = 0' ) + else if (nsize_aer(itype) .gt. maxd_asize) then + call peg_error_fatal( lunerr, & + 'init_data_mosaic_asect - nsize_aer > maxd_asize' ) + end if + +! +! set nbin_a to total number of aerosol bins (for all types) +! + nbin_a = 0 + do itype = 1, ntype_aer + nbin_a = nbin_a + nsize_aer(itype) + end do + if (nbin_a .gt. nbin_a_maxd) then + call peg_error_fatal( lunerr, & + 'init_data_mosaic_asect - nbin_a > nbin_a_maxd' ) + end if + +! +! set nphase_aer (number of active aerosol species phases), +! the xx_phase, and maerosolincw +! + nphase_aer = 0 + maerosolincw = 0 + if (nsize_aer(1) .gt. 0) then + nphase_aer = 1 + ai_phase = 1 + +#if defined ( cw_species_are_in_registry ) + if (p_so4_cw01 .ge. param_first_scalar) then + nphase_aer = 2 + cw_phase = 2 + maerosolincw = 1 + end if +#endif + end if + + +#if defined ( aboxtest_box_testing_active ) +! *** start of "box testing" code section *** +! these code lines should be inactive when running wrf-chem +! +! set some variables to "box test" values + call aboxtest_get_extra_args( 10, & + msectional, maerosolincw, maerocoag, & + maerchem, maeroptical, maerchem_boxtest_output, & + lunerr, lunout, idum, dum, dum ) + call aboxtest_get_extra_args( 11, & + aboxtest_testmode, aboxtest_units_convert, & + aboxtest_rh_method, aboxtest_map_method, & + aboxtest_gases_fixed, nsize_aer_dum, & + idum, idum, idum, dum, dum ) + + itype = 1 + if (nsize_aer_dum > 0) nsize_aer(itype) = nsize_aer_dum + + aboxtest_min_temp = 0.0 + aboxtest_min_relhum = 0.0 + aboxtest_max_relhum = 1.0 +! *** end of "box testing" code section *** +#endif + + +! +! set master aerosol chemical types +! + ntot_mastercomp_aer = 11 + + l = 1 + mastercompindx_so4_aer = l + name_mastercomp_aer( l ) = 'sulfate' + dens_mastercomp_aer( l ) = dens_so4_aer + mw_mastercomp_aer( l ) = mw_so4_aer + hygro_mastercomp_aer(l ) = hygro_so4_aer + + l = 2 + mastercompindx_no3_aer = l + name_mastercomp_aer( l ) = 'nitrate' + dens_mastercomp_aer( l ) = dens_no3_aer + mw_mastercomp_aer( l ) = mw_no3_aer + hygro_mastercomp_aer(l ) = hygro_no3_aer + + l = 3 + mastercompindx_cl_aer = l + name_mastercomp_aer( l ) = 'chloride' + dens_mastercomp_aer( l ) = dens_cl_aer + mw_mastercomp_aer( l ) = mw_cl_aer + hygro_mastercomp_aer(l ) = hygro_cl_aer + + l = 4 + mastercompindx_msa_aer = l + name_mastercomp_aer( l ) = 'msa' + dens_mastercomp_aer( l ) = dens_msa_aer + mw_mastercomp_aer( l ) = mw_msa_aer + hygro_mastercomp_aer(l ) = hygro_msa_aer + + l = 5 + mastercompindx_co3_aer = l + name_mastercomp_aer( l ) = 'carbonate' + dens_mastercomp_aer( l ) = dens_co3_aer + mw_mastercomp_aer( l ) = mw_co3_aer + hygro_mastercomp_aer(l ) = hygro_co3_aer + + l = 6 + mastercompindx_nh4_aer = l + name_mastercomp_aer( l ) = 'ammonium' + dens_mastercomp_aer( l ) = dens_nh4_aer + mw_mastercomp_aer( l ) = mw_nh4_aer + hygro_mastercomp_aer(l ) = hygro_nh4_aer + + l = 7 + mastercompindx_na_aer = l + name_mastercomp_aer( l ) = 'sodium' + dens_mastercomp_aer( l ) = dens_na_aer + mw_mastercomp_aer( l ) = mw_na_aer + hygro_mastercomp_aer(l ) = hygro_na_aer + + l = 8 + mastercompindx_ca_aer = l + name_mastercomp_aer( l ) = 'calcium' + dens_mastercomp_aer( l ) = dens_ca_aer + mw_mastercomp_aer( l ) = mw_ca_aer + hygro_mastercomp_aer(l ) = hygro_ca_aer + + l = 9 + mastercompindx_oin_aer = l + name_mastercomp_aer( l ) = 'otherinorg' + dens_mastercomp_aer( l ) = dens_oin_aer + mw_mastercomp_aer( l ) = mw_oin_aer + hygro_mastercomp_aer(l ) = hygro_oin_aer + + l = 10 + mastercompindx_oc_aer = l + name_mastercomp_aer( l ) = 'organic-c' + dens_mastercomp_aer( l ) = dens_oc_aer + mw_mastercomp_aer( l ) = mw_oc_aer + hygro_mastercomp_aer(l ) = hygro_oc_aer + + l = 11 + mastercompindx_bc_aer = l + name_mastercomp_aer( l ) = 'black-c' + dens_mastercomp_aer( l ) = dens_bc_aer + mw_mastercomp_aer( l ) = mw_bc_aer + hygro_mastercomp_aer(l ) = hygro_bc_aer + + +! +! set section size arrays +! + do itype = 1, ntype_aer + nhi = nsize_aer(itype) + dlo_sect(1,itype) = 3.90625e-6 + dhi_sect(nhi,itype) = 10.0e-4 + + dum = alog( dhi_sect(nhi,itype)/dlo_sect(1,itype) ) / nhi + do n = 2, nhi + dlo_sect(n,itype) = dlo_sect(1,itype) * exp( (n-1)*dum ) + dhi_sect(n-1,itype) = dlo_sect(n,itype) + end do + do n = 1, nhi + dcen_sect(n,itype) = sqrt( dlo_sect(n,itype)*dhi_sect(n,itype) ) + volumlo_sect(n,itype) = (pi/6.) * (dlo_sect(n,itype)**3) + volumhi_sect(n,itype) = (pi/6.) * (dhi_sect(n,itype)**3) + volumcen_sect(n,itype) = (pi/6.) * (dcen_sect(n,itype)**3) + sigmag_aer(n,itype) = (dhi_sect(n,itype)/dlo_sect(n,itype))**0.289 + end do + end do + +! +! set pointers to wrf chem-array species +! + call init_data_mosaic_ptr( is_aerosol ) + +! +! csuesat initialization +! + call init_csuesat + +! +! move_sect initialization (and testing) +! +! subr move_sections( iflag, iclm, jclm, k, m ) + call move_sections( -1, 1, 1, 1, 1 ) + + call test_move_sections( 1, 1, 1, 1, 1 ) + + + end subroutine init_data_mosaic_asect + + +!----------------------------------------------------------------------- + subroutine init_data_mosaic_ptr( is_aerosol ) + + use module_configure + use module_state_description, only: param_first_scalar,num_chem + use module_data_mosaic_asect + use module_data_mosaic_other, only: & + kh2so4, khno3, khcl, knh3, ko3, kh2o, ktemp, & + kso2, kh2o2, khcho, khcooh, koh, kho2, & + kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh, & + lmaxd, l2maxd, ltot, ltot2, lunout, lunerr, name + use module_peg_util, only: peg_error_fatal, peg_message + use module_mosaic_wetscav, only: initwet + + implicit none + +! subr arguments + logical, intent(out) :: is_aerosol(num_chem) +! local variables + integer l, ll, n, p1st + integer iaddto_ncomp, iaddto_ncomp_plustracer + integer l_mastercomp, lptr_dum + integer mcindx_dum + integer isize, itype, iphase + integer nphasetxt, nsizetxt, nspectxt, ntypetxt + integer ncomp_dum(maxd_asize,maxd_aphase) + integer ncomp_plustracer_dum(maxd_asize,maxd_aphase) + + integer y_so4, y_no3, y_cl, y_msa, y_co3, y_nh4, y_na, & + y_ca, y_oin, y_oc, y_bc, y_hysw, y_water, y_num + integer y_cw_so4, y_cw_no3, y_cw_cl, y_cw_msa, y_cw_co3, & + y_cw_nh4, y_cw_na, & + y_cw_ca, y_cw_oin, y_cw_oc, y_cw_bc, y_cw_num + + character*200 msg + character*8 phasetxt, sizetxt, spectxt, typetxt + + + p1st = param_first_scalar +! +! set up pointers to aerosol species in the wrf-chem "chem" array +! note: lptr=1 points to the first chem species which is "unused" +! + itype=1 + lptr_so4_aer(:,itype,:) = 1 + lptr_no3_aer(:,itype,:) = 1 + lptr_cl_aer(:,itype,:) = 1 + lptr_msa_aer(:,itype,:) = 1 + lptr_co3_aer(:,itype,:) = 1 + lptr_nh4_aer(:,itype,:) = 1 + lptr_na_aer(:,itype,:) = 1 + lptr_ca_aer(:,itype,:) = 1 + lptr_oin_aer(:,itype,:) = 1 + lptr_oc_aer(:,itype,:) = 1 + lptr_bc_aer(:,itype,:) = 1 + hyswptr_aer(:,itype) = 1 + waterptr_aer(:,itype) = 1 + numptr_aer(:,itype,:) = 1 + + + if (nsize_aer(itype) .ge. 1) then + lptr_so4_aer(01,itype,ai_phase) = p_so4_a01 + lptr_no3_aer(01,itype,ai_phase) = p_no3_a01 + lptr_cl_aer(01,itype,ai_phase) = p_cl_a01 + lptr_msa_aer(01,itype,ai_phase) = p_msa_a01 + lptr_co3_aer(01,itype,ai_phase) = p_co3_a01 + lptr_nh4_aer(01,itype,ai_phase) = p_nh4_a01 + lptr_na_aer(01,itype,ai_phase) = p_na_a01 + lptr_ca_aer(01,itype,ai_phase) = p_ca_a01 + lptr_oin_aer(01,itype,ai_phase) = p_oin_a01 + lptr_oc_aer(01,itype,ai_phase) = p_oc_a01 + lptr_bc_aer(01,itype,ai_phase) = p_bc_a01 + hyswptr_aer(01,itype) = p_hysw_a01 + waterptr_aer(01,itype) = p_water_a01 + numptr_aer(01,itype,ai_phase) = p_num_a01 + end if + + if (nsize_aer(itype) .ge. 2) then + lptr_so4_aer(02,itype,ai_phase) = p_so4_a02 + lptr_no3_aer(02,itype,ai_phase) = p_no3_a02 + lptr_cl_aer(02,itype,ai_phase) = p_cl_a02 + lptr_msa_aer(02,itype,ai_phase) = p_msa_a02 + lptr_co3_aer(02,itype,ai_phase) = p_co3_a02 + lptr_nh4_aer(02,itype,ai_phase) = p_nh4_a02 + lptr_na_aer(02,itype,ai_phase) = p_na_a02 + lptr_ca_aer(02,itype,ai_phase) = p_ca_a02 + lptr_oin_aer(02,itype,ai_phase) = p_oin_a02 + lptr_oc_aer(02,itype,ai_phase) = p_oc_a02 + lptr_bc_aer(02,itype,ai_phase) = p_bc_a02 + hyswptr_aer(02,itype) = p_hysw_a02 + waterptr_aer(02,itype) = p_water_a02 + numptr_aer(02,itype,ai_phase) = p_num_a02 + end if + + if (nsize_aer(itype) .ge. 3) then + lptr_so4_aer(03,itype,ai_phase) = p_so4_a03 + lptr_no3_aer(03,itype,ai_phase) = p_no3_a03 + lptr_cl_aer(03,itype,ai_phase) = p_cl_a03 + lptr_msa_aer(03,itype,ai_phase) = p_msa_a03 + lptr_co3_aer(03,itype,ai_phase) = p_co3_a03 + lptr_nh4_aer(03,itype,ai_phase) = p_nh4_a03 + lptr_na_aer(03,itype,ai_phase) = p_na_a03 + lptr_ca_aer(03,itype,ai_phase) = p_ca_a03 + lptr_oin_aer(03,itype,ai_phase) = p_oin_a03 + lptr_oc_aer(03,itype,ai_phase) = p_oc_a03 + lptr_bc_aer(03,itype,ai_phase) = p_bc_a03 + hyswptr_aer(03,itype) = p_hysw_a03 + waterptr_aer(03,itype) = p_water_a03 + numptr_aer(03,itype,ai_phase) = p_num_a03 + end if + + if (nsize_aer(itype) .ge. 4) then + lptr_so4_aer(04,itype,ai_phase) = p_so4_a04 + lptr_no3_aer(04,itype,ai_phase) = p_no3_a04 + lptr_cl_aer(04,itype,ai_phase) = p_cl_a04 + lptr_msa_aer(04,itype,ai_phase) = p_msa_a04 + lptr_co3_aer(04,itype,ai_phase) = p_co3_a04 + lptr_nh4_aer(04,itype,ai_phase) = p_nh4_a04 + lptr_na_aer(04,itype,ai_phase) = p_na_a04 + lptr_ca_aer(04,itype,ai_phase) = p_ca_a04 + lptr_oin_aer(04,itype,ai_phase) = p_oin_a04 + lptr_oc_aer(04,itype,ai_phase) = p_oc_a04 + lptr_bc_aer(04,itype,ai_phase) = p_bc_a04 + hyswptr_aer(04,itype) = p_hysw_a04 + waterptr_aer(04,itype) = p_water_a04 + numptr_aer(04,itype,ai_phase) = p_num_a04 + end if + + if (nsize_aer(itype) .ge. 5) then + lptr_so4_aer(05,itype,ai_phase) = p_so4_a05 + lptr_no3_aer(05,itype,ai_phase) = p_no3_a05 + lptr_cl_aer(05,itype,ai_phase) = p_cl_a05 + lptr_msa_aer(05,itype,ai_phase) = p_msa_a05 + lptr_co3_aer(05,itype,ai_phase) = p_co3_a05 + lptr_nh4_aer(05,itype,ai_phase) = p_nh4_a05 + lptr_na_aer(05,itype,ai_phase) = p_na_a05 + lptr_ca_aer(05,itype,ai_phase) = p_ca_a05 + lptr_oin_aer(05,itype,ai_phase) = p_oin_a05 + lptr_oc_aer(05,itype,ai_phase) = p_oc_a05 + lptr_bc_aer(05,itype,ai_phase) = p_bc_a05 + hyswptr_aer(05,itype) = p_hysw_a05 + waterptr_aer(05,itype) = p_water_a05 + numptr_aer(05,itype,ai_phase) = p_num_a05 + end if + + if (nsize_aer(itype) .ge. 6) then + lptr_so4_aer(06,itype,ai_phase) = p_so4_a06 + lptr_no3_aer(06,itype,ai_phase) = p_no3_a06 + lptr_cl_aer(06,itype,ai_phase) = p_cl_a06 + lptr_msa_aer(06,itype,ai_phase) = p_msa_a06 + lptr_co3_aer(06,itype,ai_phase) = p_co3_a06 + lptr_nh4_aer(06,itype,ai_phase) = p_nh4_a06 + lptr_na_aer(06,itype,ai_phase) = p_na_a06 + lptr_ca_aer(06,itype,ai_phase) = p_ca_a06 + lptr_oin_aer(06,itype,ai_phase) = p_oin_a06 + lptr_oc_aer(06,itype,ai_phase) = p_oc_a06 + lptr_bc_aer(06,itype,ai_phase) = p_bc_a06 + hyswptr_aer(06,itype) = p_hysw_a06 + waterptr_aer(06,itype) = p_water_a06 + numptr_aer(06,itype,ai_phase) = p_num_a06 + end if + + if (nsize_aer(itype) .ge. 7) then + lptr_so4_aer(07,itype,ai_phase) = p_so4_a07 + lptr_no3_aer(07,itype,ai_phase) = p_no3_a07 + lptr_cl_aer(07,itype,ai_phase) = p_cl_a07 + lptr_msa_aer(07,itype,ai_phase) = p_msa_a07 + lptr_co3_aer(07,itype,ai_phase) = p_co3_a07 + lptr_nh4_aer(07,itype,ai_phase) = p_nh4_a07 + lptr_na_aer(07,itype,ai_phase) = p_na_a07 + lptr_ca_aer(07,itype,ai_phase) = p_ca_a07 + lptr_oin_aer(07,itype,ai_phase) = p_oin_a07 + lptr_oc_aer(07,itype,ai_phase) = p_oc_a07 + lptr_bc_aer(07,itype,ai_phase) = p_bc_a07 + hyswptr_aer(07,itype) = p_hysw_a07 + waterptr_aer(07,itype) = p_water_a07 + numptr_aer(07,itype,ai_phase) = p_num_a07 + end if + + if (nsize_aer(itype) .ge. 8) then + lptr_so4_aer(08,itype,ai_phase) = p_so4_a08 + lptr_no3_aer(08,itype,ai_phase) = p_no3_a08 + lptr_cl_aer(08,itype,ai_phase) = p_cl_a08 + lptr_msa_aer(08,itype,ai_phase) = p_msa_a08 + lptr_co3_aer(08,itype,ai_phase) = p_co3_a08 + lptr_nh4_aer(08,itype,ai_phase) = p_nh4_a08 + lptr_na_aer(08,itype,ai_phase) = p_na_a08 + lptr_ca_aer(08,itype,ai_phase) = p_ca_a08 + lptr_oin_aer(08,itype,ai_phase) = p_oin_a08 + lptr_oc_aer(08,itype,ai_phase) = p_oc_a08 + lptr_bc_aer(08,itype,ai_phase) = p_bc_a08 + hyswptr_aer(08,itype) = p_hysw_a08 + waterptr_aer(08,itype) = p_water_a08 + numptr_aer(08,itype,ai_phase) = p_num_a08 + end if + + +#if defined ( cw_species_are_in_registry ) +! this code is "active" only when cw species are in the registry + if (nsize_aer(itype) .ge. 1) then + if (cw_phase .gt. 0) then + lptr_so4_aer(01,itype,cw_phase) = p_so4_cw01 + lptr_no3_aer(01,itype,cw_phase) = p_no3_cw01 + lptr_cl_aer(01,itype,cw_phase) = p_cl_cw01 + lptr_msa_aer(01,itype,cw_phase) = p_msa_cw01 + lptr_co3_aer(01,itype,cw_phase) = p_co3_cw01 + lptr_nh4_aer(01,itype,cw_phase) = p_nh4_cw01 + lptr_na_aer(01,itype,cw_phase) = p_na_cw01 + lptr_ca_aer(01,itype,cw_phase) = p_ca_cw01 + lptr_oin_aer(01,itype,cw_phase) = p_oin_cw01 + lptr_oc_aer(01,itype,cw_phase) = p_oc_cw01 + lptr_bc_aer(01,itype,cw_phase) = p_bc_cw01 + numptr_aer(01,itype,cw_phase) = p_num_cw01 + end if + end if + + if (nsize_aer(itype) .ge. 2) then + if (cw_phase .gt. 0) then + lptr_so4_aer(02,itype,cw_phase) = p_so4_cw02 + lptr_no3_aer(02,itype,cw_phase) = p_no3_cw02 + lptr_cl_aer(02,itype,cw_phase) = p_cl_cw02 + lptr_msa_aer(02,itype,cw_phase) = p_msa_cw02 + lptr_co3_aer(02,itype,cw_phase) = p_co3_cw02 + lptr_nh4_aer(02,itype,cw_phase) = p_nh4_cw02 + lptr_na_aer(02,itype,cw_phase) = p_na_cw02 + lptr_ca_aer(02,itype,cw_phase) = p_ca_cw02 + lptr_oin_aer(02,itype,cw_phase) = p_oin_cw02 + lptr_oc_aer(02,itype,cw_phase) = p_oc_cw02 + lptr_bc_aer(02,itype,cw_phase) = p_bc_cw02 + numptr_aer(02,itype,cw_phase) = p_num_cw02 + end if + end if + + if (nsize_aer(itype) .ge. 3) then + if (cw_phase .gt. 0) then + lptr_so4_aer(03,itype,cw_phase) = p_so4_cw03 + lptr_no3_aer(03,itype,cw_phase) = p_no3_cw03 + lptr_cl_aer(03,itype,cw_phase) = p_cl_cw03 + lptr_msa_aer(03,itype,cw_phase) = p_msa_cw03 + lptr_co3_aer(03,itype,cw_phase) = p_co3_cw03 + lptr_nh4_aer(03,itype,cw_phase) = p_nh4_cw03 + lptr_na_aer(03,itype,cw_phase) = p_na_cw03 + lptr_ca_aer(03,itype,cw_phase) = p_ca_cw03 + lptr_oin_aer(03,itype,cw_phase) = p_oin_cw03 + lptr_oc_aer(03,itype,cw_phase) = p_oc_cw03 + lptr_bc_aer(03,itype,cw_phase) = p_bc_cw03 + numptr_aer(03,itype,cw_phase) = p_num_cw03 + end if + end if + + if (nsize_aer(itype) .ge. 4) then + if (cw_phase .gt. 0) then + lptr_so4_aer(04,itype,cw_phase) = p_so4_cw04 + lptr_no3_aer(04,itype,cw_phase) = p_no3_cw04 + lptr_cl_aer(04,itype,cw_phase) = p_cl_cw04 + lptr_msa_aer(04,itype,cw_phase) = p_msa_cw04 + lptr_co3_aer(04,itype,cw_phase) = p_co3_cw04 + lptr_nh4_aer(04,itype,cw_phase) = p_nh4_cw04 + lptr_na_aer(04,itype,cw_phase) = p_na_cw04 + lptr_ca_aer(04,itype,cw_phase) = p_ca_cw04 + lptr_oin_aer(04,itype,cw_phase) = p_oin_cw04 + lptr_oc_aer(04,itype,cw_phase) = p_oc_cw04 + lptr_bc_aer(04,itype,cw_phase) = p_bc_cw04 + numptr_aer(04,itype,cw_phase) = p_num_cw04 + end if + end if + + if (nsize_aer(itype) .ge. 5) then + if (cw_phase .gt. 0) then + lptr_so4_aer(05,itype,cw_phase) = p_so4_cw05 + lptr_no3_aer(05,itype,cw_phase) = p_no3_cw05 + lptr_cl_aer(05,itype,cw_phase) = p_cl_cw05 + lptr_msa_aer(05,itype,cw_phase) = p_msa_cw05 + lptr_co3_aer(05,itype,cw_phase) = p_co3_cw05 + lptr_nh4_aer(05,itype,cw_phase) = p_nh4_cw05 + lptr_na_aer(05,itype,cw_phase) = p_na_cw05 + lptr_ca_aer(05,itype,cw_phase) = p_ca_cw05 + lptr_oin_aer(05,itype,cw_phase) = p_oin_cw05 + lptr_oc_aer(05,itype,cw_phase) = p_oc_cw05 + lptr_bc_aer(05,itype,cw_phase) = p_bc_cw05 + numptr_aer(05,itype,cw_phase) = p_num_cw05 + end if + end if + + if (nsize_aer(itype) .ge. 6) then + if (cw_phase .gt. 0) then + lptr_so4_aer(06,itype,cw_phase) = p_so4_cw06 + lptr_no3_aer(06,itype,cw_phase) = p_no3_cw06 + lptr_cl_aer(06,itype,cw_phase) = p_cl_cw06 + lptr_msa_aer(06,itype,cw_phase) = p_msa_cw06 + lptr_co3_aer(06,itype,cw_phase) = p_co3_cw06 + lptr_nh4_aer(06,itype,cw_phase) = p_nh4_cw06 + lptr_na_aer(06,itype,cw_phase) = p_na_cw06 + lptr_ca_aer(06,itype,cw_phase) = p_ca_cw06 + lptr_oin_aer(06,itype,cw_phase) = p_oin_cw06 + lptr_oc_aer(06,itype,cw_phase) = p_oc_cw06 + lptr_bc_aer(06,itype,cw_phase) = p_bc_cw06 + numptr_aer(06,itype,cw_phase) = p_num_cw06 + end if + end if + + if (nsize_aer(itype) .ge. 7) then + if (cw_phase .gt. 0) then + lptr_so4_aer(07,itype,cw_phase) = p_so4_cw07 + lptr_no3_aer(07,itype,cw_phase) = p_no3_cw07 + lptr_cl_aer(07,itype,cw_phase) = p_cl_cw07 + lptr_msa_aer(07,itype,cw_phase) = p_msa_cw07 + lptr_co3_aer(07,itype,cw_phase) = p_co3_cw07 + lptr_nh4_aer(07,itype,cw_phase) = p_nh4_cw07 + lptr_na_aer(07,itype,cw_phase) = p_na_cw07 + lptr_ca_aer(07,itype,cw_phase) = p_ca_cw07 + lptr_oin_aer(07,itype,cw_phase) = p_oin_cw07 + lptr_oc_aer(07,itype,cw_phase) = p_oc_cw07 + lptr_bc_aer(07,itype,cw_phase) = p_bc_cw07 + numptr_aer(07,itype,cw_phase) = p_num_cw07 + end if + end if + + if (nsize_aer(itype) .ge. 8) then + if (cw_phase .gt. 0) then + lptr_so4_aer(08,itype,cw_phase) = p_so4_cw08 + lptr_no3_aer(08,itype,cw_phase) = p_no3_cw08 + lptr_cl_aer(08,itype,cw_phase) = p_cl_cw08 + lptr_msa_aer(08,itype,cw_phase) = p_msa_cw08 + lptr_co3_aer(08,itype,cw_phase) = p_co3_cw08 + lptr_nh4_aer(08,itype,cw_phase) = p_nh4_cw08 + lptr_na_aer(08,itype,cw_phase) = p_na_cw08 + lptr_ca_aer(08,itype,cw_phase) = p_ca_cw08 + lptr_oin_aer(08,itype,cw_phase) = p_oin_cw08 + lptr_oc_aer(08,itype,cw_phase) = p_oc_cw08 + lptr_bc_aer(08,itype,cw_phase) = p_bc_cw08 + numptr_aer(08,itype,cw_phase) = p_num_cw08 + end if + end if +#endif + + +! +! define the massptr_aer and mastercompptr_aer pointers +! and the name() species names +! + +! first initialize + do l = 1, l2maxd + write( name(l), '(a,i4.4,15x)' ) 'r', l + end do + massptr_aer(:,:,:,:) = -999888777 + mastercompptr_aer(:,:) = -999888777 + + do 2800 itype = 1, ntype_aer + + if (itype .eq. 1) then + typetxt = ' ' + ntypetxt = 1 + if (ntype_aer .gt. 1) then + typetxt = '_t1' + ntypetxt = 3 + end if + else if (itype .le. 9) then + write(typetxt,'(a,i1)') '_t', itype + ntypetxt = 3 + else if (itype .le. 99) then + write(typetxt,'(a,i2)') '_t', itype + ntypetxt = 4 + else + typetxt = '_t?' + ntypetxt = 3 + end if + + ncomp_dum(:,:) = 0 + ncomp_plustracer_dum(:,:) = 0 + + do 2700 isize = 1, nsize_aer(itype) + n =isize + + if (isize .le. 9) then + write(sizetxt,'(i1)') isize + nsizetxt = 1 + else if (isize .le. 99) then + write(sizetxt,'(i2)') isize + nsizetxt = 2 + else if (isize .le. 999) then + write(sizetxt,'(i3)') isize + nsizetxt = 3 + else + sizetxt = 's?' + nsizetxt = 2 + end if + + + do 2600 iphase = 1, nphase_aer + + if (iphase .eq. ai_phase) then + phasetxt = 'a' + nphasetxt = 1 + else if (iphase .eq. cw_phase) then + phasetxt = 'cw' + nphasetxt = 2 + else + phasetxt = 'p?' + nphasetxt = 2 + end if + + + do 2500 l_mastercomp = -2, ntot_mastercomp_aer + + iaddto_ncomp = 1 + iaddto_ncomp_plustracer = 1 + + if (l_mastercomp .eq. -2) then + iaddto_ncomp = 0 + iaddto_ncomp_plustracer = 0 + lptr_dum = numptr_aer(n,itype,iphase) + mcindx_dum = -2 + spectxt = 'numb_' + nspectxt = 5 + + else if (l_mastercomp .eq. -1) then + if (iphase .ne. ai_phase) goto 2500 + iaddto_ncomp = 0 + iaddto_ncomp_plustracer = 0 + lptr_dum = waterptr_aer(n,itype) + mcindx_dum = -1 + spectxt = 'water_' + nspectxt = 6 + + else if (l_mastercomp .eq. 0) then + if (iphase .ne. ai_phase) goto 2500 + iaddto_ncomp = 0 + iaddto_ncomp_plustracer = 0 + lptr_dum = hyswptr_aer(n,itype) + mcindx_dum = 0 + spectxt = 'hysw_' + nspectxt = 5 + + else if (l_mastercomp .eq. mastercompindx_so4_aer) then + lptr_dum = lptr_so4_aer(n,itype,iphase) + mcindx_dum = mastercompindx_so4_aer + spectxt = 'so4_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_no3_aer) then + lptr_dum = lptr_no3_aer(n,itype,iphase) + mcindx_dum = mastercompindx_no3_aer + spectxt = 'no3_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_cl_aer) then + lptr_dum = lptr_cl_aer(n,itype,iphase) + mcindx_dum = mastercompindx_cl_aer + spectxt = 'cl_' + nspectxt = 3 + + else if (l_mastercomp .eq. mastercompindx_msa_aer) then + lptr_dum = lptr_msa_aer(n,itype,iphase) + mcindx_dum = mastercompindx_msa_aer + spectxt = 'msa_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_co3_aer) then + lptr_dum = lptr_co3_aer(n,itype,iphase) + mcindx_dum = mastercompindx_co3_aer + spectxt = 'co3_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_nh4_aer) then + lptr_dum = lptr_nh4_aer(n,itype,iphase) + mcindx_dum = mastercompindx_nh4_aer + spectxt = 'nh4_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_na_aer) then + lptr_dum = lptr_na_aer(n,itype,iphase) + mcindx_dum = mastercompindx_na_aer + spectxt = 'na_' + nspectxt = 3 + + else if (l_mastercomp .eq. mastercompindx_ca_aer) then + lptr_dum = lptr_ca_aer(n,itype,iphase) + mcindx_dum = mastercompindx_ca_aer + spectxt = 'ca_' + nspectxt = 3 + + else if (l_mastercomp .eq. mastercompindx_oin_aer) then + lptr_dum = lptr_oin_aer(n,itype,iphase) + mcindx_dum = mastercompindx_oin_aer + spectxt = 'oin_' + nspectxt = 4 + + else if (l_mastercomp .eq. mastercompindx_oc_aer) then + lptr_dum = lptr_oc_aer(n,itype,iphase) + mcindx_dum = mastercompindx_oc_aer + spectxt = 'oc_' + nspectxt = 3 + + else if (l_mastercomp .eq. mastercompindx_bc_aer) then + lptr_dum = lptr_bc_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bc_aer + spectxt = 'bc_' + nspectxt = 3 + + else + goto 2500 + end if + + + if (lptr_dum .gt. lmaxd) then +! rce 2005-mar-14 - added check for lptr_dum > lmaxd + write( msg, '(a,3(1x,i4))' ) 'itype, isize, iphase =', & + itype, isize, iphase + call peg_message( lunout, msg ) + write( msg, '(a,3(1x,i4))' ) 'l_mastercomp, lptr_dum, lmaxd =', & + l_mastercomp, lptr_dum, lmaxd + call peg_message( lunout, msg ) + msg = '*** subr init_data_mosaic_ptr error - lptr_dum > lmaxd' + call peg_error_fatal( lunerr, msg ) + + else if (lptr_dum .ge. p1st) then + + ncomp_dum(isize,iphase) = ncomp_dum(isize,iphase) + iaddto_ncomp + ncomp_plustracer_dum(isize,iphase) = & + ncomp_plustracer_dum(isize,iphase) + iaddto_ncomp_plustracer + + name(lptr_dum) = & + spectxt(1:nspectxt) // phasetxt(1:nphasetxt) // & + sizetxt(1:nsizetxt) // typetxt(1:ntypetxt) + + if (l_mastercomp .eq. -2) then +! (numptr_aer is already set) + mprognum_aer(n,itype,iphase) = 1 + + else if (l_mastercomp .eq. -1) then +! (waterptr_aer is already set) + continue + + else if (l_mastercomp .eq. 0) then +! (hyswptr_aer is already set) + continue + + else if (l_mastercomp .gt. 0) then + ll = ncomp_plustracer_dum(isize,iphase) + massptr_aer(ll,n,itype,iphase) = lptr_dum + mastercompptr_aer(ll,itype) = mcindx_dum + + name_aer(ll,itype) = name_mastercomp_aer(mcindx_dum) + dens_aer(ll,itype) = dens_mastercomp_aer(mcindx_dum) + mw_aer(ll,itype) = mw_mastercomp_aer(mcindx_dum) + hygro_aer(ll,itype) = hygro_mastercomp_aer(mcindx_dum) + + end if + + end if + +2500 continue ! l_mastercomp = -1, ntot_mastercomp_aer + +2600 continue ! iphase = 1, nphase_aer + +2700 continue ! isize = 1, nsize_aer(itype) + + +! now set ncomp_aer and ncomp_plustracer_aer, +! *** and check that the values computed for each size and phase all match + ncomp_aer(itype) = ncomp_dum(1,ai_phase) + ncomp_plustracer_aer(itype) = ncomp_plustracer_dum(1,ai_phase) + + do iphase = 1, nphase_aer + do isize = 1, nsize_aer(itype) + if (ncomp_aer(itype) .ne. ncomp_dum(isize,iphase)) then + msg = '*** subr init_data_mosaic_ptr - ' // & + 'ncomp_aer .ne. ncomp_dum' + call peg_message( lunerr, msg ) + write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase + call peg_message( lunerr, msg ) + write(msg,9350) 'ncomp_aer, ncomp_dum =', & + ncomp_aer(itype), ncomp_dum(isize,iphase) + call peg_error_fatal( lunerr, msg ) + end if + if (ncomp_plustracer_aer(itype) .ne. & + ncomp_plustracer_dum(isize,iphase)) then + msg = '*** subr init_data_mosaic_ptr - ' // & + 'ncomp_plustracer_aer .ne. ncomp_plustracer_dum' + call peg_message( lunerr, msg ) + write(msg,9350) 'isize, itype, iphase =', isize, itype, iphase + call peg_message( lunerr, msg ) + write(msg,9350) & + 'ncomp_plustracer_aer, ncomp_plustracer_dum =', & + ncomp_plustracer_aer(itype), & + ncomp_plustracer_dum(isize,iphase) + call peg_error_fatal( lunerr, msg ) + end if + end do + end do + + +2800 continue ! itype = 1, ntype_aer + + +9320 format( a, i1, i1, a, 8x ) + +! +! output wrfch pointers +! +9350 format( a, 32(1x,i4) ) + msg = ' ' + call peg_message( lunout, msg ) + msg = 'output from subr init_data_mosaic_ptr' + call peg_message( lunout, msg ) + write(msg,9350) 'nphase_aer = ', nphase_aer + call peg_message( lunout, msg ) + + do iphase=1,nphase_aer + + write(msg,9350) 'iphase = ', iphase + call peg_message( lunout, msg ) + write(msg,9350) 'ntype_aer = ', ntype_aer + call peg_message( lunout, msg ) + + do itype=1,ntype_aer + + write(msg,9350) 'itype = ', itype + call peg_message( lunout, msg ) + write(msg,9350) 'nsize_aer = ', nsize_aer(itype) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_so4_aer ', & + (lptr_so4_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_no3_aer ', & + (lptr_no3_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_cl_aer ', & + (lptr_cl_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_msa_aer ', & + (lptr_msa_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_co3_aer ', & + (lptr_co3_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_nh4_aer ', & + (lptr_nh4_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_na_aer ', & + (lptr_na_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_ca_aer ', & + (lptr_ca_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_oin_aer ', & + (lptr_oin_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_oc_aer ', & + (lptr_oc_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'lptr_bc_aer ', & + (lptr_bc_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'hyswptr_aer', & + (hyswptr_aer(n,itype), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'waterptr_aer ', & + (waterptr_aer(n,itype), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'numptr_aer ', & + (numptr_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + + + do ll = 1, ncomp_plustracer_aer(itype) + write(msg,9350) 'massptr_aer(), ll', & + (massptr_aer(ll,n,itype,iphase), n=1,nsize_aer(itype)), ll + call peg_message( lunout, msg ) + end do + end do ! type + end do ! phase + +! +! check aerosol species pointers for "validity" +! + do iphase=1,nphase_aer + do itype=1,ntype_aer + y_so4 = 0 + y_no3 = 0 + y_cl = 0 + y_msa = 0 + y_co3 = 0 + y_nh4 = 0 + y_na = 0 + y_ca = 0 + y_oin = 0 + y_oc = 0 + y_bc = 0 + y_hysw = 0 + y_water = 0 + y_num = 0 + + do n = 1, nsize_aer(itype) + if (lptr_so4_aer(n,itype,iphase) .ge. p1st) y_so4 = y_so4 + 1 + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) y_no3 = y_no3 + 1 + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) y_cl = y_cl + 1 + if (lptr_msa_aer(n,itype,iphase) .ge. p1st) y_msa = y_msa + 1 + if (lptr_co3_aer(n,itype,iphase) .ge. p1st) y_co3 = y_co3 + 1 + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) y_nh4 = y_nh4 + 1 + if (lptr_na_aer(n,itype,iphase) .ge. p1st) y_na = y_na + 1 + if (lptr_ca_aer(n,itype,iphase) .ge. p1st) y_ca = y_ca + 1 + if (lptr_oin_aer(n,itype,iphase) .ge. p1st) y_oin = y_oin + 1 + if (lptr_oc_aer(n,itype,iphase) .ge. p1st) y_oc = y_oc + 1 + if (lptr_bc_aer(n,itype,iphase) .ge. p1st) y_bc = y_bc + 1 + if (hyswptr_aer(n,itype) .ge. p1st) y_hysw = y_hysw + 1 + if (waterptr_aer(n,itype) .ge. p1st) y_water = y_water + 1 + if (numptr_aer(n,itype,iphase) .ge. p1st) y_num = y_num + 1 + + end do + +! these must be defined for all aerosol bins + if (y_so4 .ne. nsize_aer(itype)) then + msg = '*** subr init_data_mosaic_ptr - ptr error for so4' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if (y_water .ne. nsize_aer(itype)) then + msg = '*** subr init_data_mosaic_ptr - ptr error for water' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if (y_num .ne. nsize_aer(itype)) then + msg = '*** subr init_data_mosaic_ptr - ptr error for num' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + end if + + +! these must be defined for all aerosol bins +! or else undefined for all aerosol bins + if ((y_no3 .ne. 0) .and. & + (y_no3 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for no3' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_cl .ne. 0) .and. & + (y_cl .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for cl' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_msa .ne. 0) .and. & + (y_msa .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for msa' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_co3 .ne. 0) .and. & + (y_co3 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for co3' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_nh4 .ne. 0) .and. & + (y_nh4 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for nh4' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_na .ne. 0) .and. & + (y_na .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for na' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_ca .ne. 0) .and. & + (y_ca .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for ca' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_oin .ne. 0) .and. & + (y_oin .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for oin' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_oc .ne. 0) .and. & + (y_oc .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for oc' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_bc .ne. 0) .and. & + (y_bc .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for bc' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + else if ((y_hysw .ne. 0) .and. & + (y_hysw .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for hysw' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + end if + + enddo ! type + enddo ! phase +! +! set pointers for gases +! rce 2004-dec-02 - gases not required to be present +! + if (p_sulf .ge. p1st) then + kh2so4 = p_sulf +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for h2so4' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_hno3 .ge. p1st) then + khno3 = p_hno3 +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for hno3' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_hcl .ge. p1st) then + khcl = p_hcl +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for hcl' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_nh3 .ge. p1st) then + knh3 = p_nh3 +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for nh3' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_o3 .ge. p1st) then + ko3 = p_o3 +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for o3' +! call peg_error_fatal( lunerr, msg ) + end if + +! rce 2005-apr-12 - added following species for cldchem, here and below: +! kso2, kh2o2, khcho, khcooh, koh, kho2, +! kno3, kno, kno2, khono, kpan, kch3o2, kch3oh, kch3ooh + if (p_so2 .ge. p1st) kso2 = p_so2 + if (p_h2o2 .ge. p1st) kh2o2 = p_h2o2 + if (p_hcho .ge. p1st) khcho = p_hcho + if (p_ora1 .ge. p1st) khcooh = p_ora1 + if (p_ho .ge. p1st) koh = p_ho + if (p_ho2 .ge. p1st) kho2 = p_ho2 + if (p_no3 .ge. p1st) kno3 = p_no3 + if (p_no .ge. p1st) kno = p_no + if (p_no2 .ge. p1st) kno2 = p_no2 + if (p_hono .ge. p1st) khono = p_hono + if (p_pan .ge. p1st) kpan = p_pan + if (p_ch3o2 .ge. p1st) kch3o2 = p_ch3o2 + if (p_ch3oh .ge. p1st) kch3oh = p_ch3oh + if (p_op1 .ge. p1st) kch3ooh = p_op1 + +! +! calc ltot, ltot2, kh2o, ktemp +! + is_aerosol(:) = .false. + ltot = 0 + ltot = max( ltot, kh2so4 ) + ltot = max( ltot, khno3 ) + ltot = max( ltot, khcl ) + ltot = max( ltot, knh3 ) + ltot = max( ltot, ko3 ) + ltot = max( ltot, kso2 ) + ltot = max( ltot, kh2o2 ) + ltot = max( ltot, khcho ) + ltot = max( ltot, khcooh ) + ltot = max( ltot, koh ) + ltot = max( ltot, kho2 ) + ltot = max( ltot, kno3 ) + ltot = max( ltot, kno ) + ltot = max( ltot, kno2 ) + ltot = max( ltot, khono ) + ltot = max( ltot, kpan ) + ltot = max( ltot, kch3o2 ) + ltot = max( ltot, kch3oh ) + ltot = max( ltot, kch3ooh ) + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_plustracer_aer(itype) + ltot = max( ltot, massptr_aer(ll,n,itype,iphase) ) + is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. + end do + ltot = max( ltot, hyswptr_aer(n,itype) ) + ltot = max( ltot, waterptr_aer(n,itype) ) + ltot = max( ltot, numptr_aer(n,itype,iphase) ) + l = hyswptr_aer(n,itype) + if (l .ge. p1st) is_aerosol(l)=.true. + l = waterptr_aer(n,itype) + if (l .ge. p1st) is_aerosol(l)=.true. + l = numptr_aer(n,itype,iphase) + if (l .ge. p1st) is_aerosol(l)=.true. + end do + end do + end do + + kh2o = ltot + 1 + ktemp = ltot + 2 + ltot2 = ktemp + + write( msg, '(a,4(1x,i4))' ) 'ltot, ltot2, lmaxd, l2maxd =', & + ltot, ltot2, lmaxd, l2maxd + call peg_message( lunout, msg ) + if ((ltot .gt. lmaxd) .or. (ltot2 .gt. l2maxd)) then + msg = '*** subr init_data_mosaic_ptr - ltot/ltot2 too big' + call peg_error_fatal( lunerr, msg ) + end if + + if (p_sulf .ge. p1st) name(kh2so4 ) = 'h2so4' + if (p_hno3 .ge. p1st) name(khno3 ) = 'hno3' + if (p_hcl .ge. p1st) name(khcl ) = 'hcl' + if (p_nh3 .ge. p1st) name(knh3 ) = 'nh3' + if (p_o3 .ge. p1st) name(ko3 ) = 'o3' + if (p_so2 .ge. p1st) name(kso2 ) = 'so2' + if (p_h2o2 .ge. p1st) name(kh2o2 ) = 'h2o2' + if (p_hcho .ge. p1st) name(khcho ) = 'hcho' + if (p_ora1 .ge. p1st) name(khcooh ) = 'hcooh' + if (p_ho .ge. p1st) name(koh ) = 'oh' + if (p_ho2 .ge. p1st) name(kho2 ) = 'ho2' + if (p_no3 .ge. p1st) name(kno3 ) = 'no3' + if (p_no .ge. p1st) name(kno ) = 'no' + if (p_no2 .ge. p1st) name(kno2 ) = 'no2' + if (p_hono .ge. p1st) name(khono ) = 'hono' + if (p_pan .ge. p1st) name(kpan ) = 'pan' + if (p_ch3o2 .ge. p1st) name(kch3o2 ) = 'ch3o2' + if (p_ch3oh .ge. p1st) name(kch3oh ) = 'ch3oh' + if (p_op1 .ge. p1st) name(kch3ooh) = 'ch3ooh' + name(ktemp) = 'temp' + name(kh2o) = 'h2o' + + call initwet( & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, & + dcen_sect, sigmag_aer, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, & + nimptblgrow_maxd, dlndg_nimptblgrow) + + return + end subroutine init_data_mosaic_ptr + + +!----------------------------------------------------------------------- + subroutine aerchem_debug_dump( & + iflag, iclm, jclm, dtchem ) + + use module_data_mosaic_asect + use module_data_mosaic_other + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com9a' + + integer iflag, iclm, jclm + real dtchem + +! local variables + integer ientryno + save ientryno + integer iphase, itype, k, l, m, n + + real dtchem_sv1 + save dtchem_sv1 + real rsub_sv1(l2maxd,kmaxd,nsubareamaxd) + + data ientryno / -13579 / + + +! check for bypass based on some control variable ? + + +! do initial output when ientryno = -13579 + if (ientryno .ne. -13579) goto 1000 + + ientryno = +1 + +95010 format( a ) +95020 format( 8( 1x, i8 ) ) +95030 format( 4( 1pe18.10 ) ) + + print 95010, 'aerchem_debug_dump start' + print 95020, ltot, ltot2, itot, jtot, ktot + print 95010, (name(l), l=1,ltot2) + + print 95020, maerocoag, maerchem, maeroptical + print 95020, msectional, maerosolincw + do iphase = 1, nphase_aer + do itype=1,ntype_aer + print 95020, iphase, itype, nsize_aer(itype), & + ncomp_plustracer_aer(itype) + + do n = 1, ncomp_plustracer_aer(itype) + print 95010, & + name_aer(n,itype) + print 95030, & + dens_aer(n,itype), mw_aer(n,itype) + end do + + do n = 1, nsize_aer(itype) + print 95020, & + ncomp_plustracer_aer(n), ncomp_aer(n), & + waterptr_aer(n,itype), numptr_aer(n,itype,iphase), & + mprognum_aer(n,itype,iphase) + print 95020, & + (mastercompptr_aer(l,itype), massptr_aer(l,n,itype,iphase), & + l=1,ncomp_plustracer_aer(itype)) + print 95030, & + volumcen_sect(n,itype), volumlo_sect(n,itype), & + volumhi_sect(n,itype), dcen_sect(n,itype), & + dlo_sect(n,itype), dhi_sect(n,itype) + print 95020, & + lptr_so4_aer(n,itype,iphase), lptr_msa_aer(n,itype,iphase), & + lptr_no3_aer(n,itype,iphase), lptr_cl_aer(n,itype,iphase), & + lptr_co3_aer(n,itype,iphase), lptr_nh4_aer(n,itype,iphase), & + lptr_na_aer(n,itype,iphase), lptr_ca_aer(n,itype,iphase), & + lptr_oin_aer(n,itype,iphase), lptr_oc_aer(n,itype,iphase), & + lptr_bc_aer(n,itype,iphase), hyswptr_aer(n,itype) + end do ! size + end do ! type + end do ! phase + print 95010, 'aerchem_debug_dump end' + +! +! test iflag +! +1000 continue + if (iflag .eq. 1) goto 1010 + if (iflag .eq. 2) goto 2000 + if (iflag .eq. 3) goto 3000 + return + +! +! iflag=1 -- save initial values +! AND FOR NOW do output too +! +1010 continue + dtchem_sv1 = dtchem + do m = 1, nsubareas + do k = 1, ktot + do l = 1, ltot2 + rsub_sv1(l,k,m) = rsub(l,k,m) + end do + end do + end do + + print 95010, 'aerchem_debug_dump start' + do m = 1, nsubareas + do k = 1, ktot + print 95020, iymdcur, ihmscur, & + iclm, jclm, k, m, nsubareas, iflag + print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), & + ptotclm(k), afracsubarea(k,m) + print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2) + end do + end do + print 95010, 'aerchem_debug_dump end' + + return + +! +! iflag=2 -- save intermediate values before doing move_sections +! (this is deactivated for now) +! +2000 continue + return + + +! +! iflag=3 -- do output +! +3000 continue + print 95010, 'aerchem_debug_dump start' + do m = 1, nsubareas + do k = 1, ktot + print 95020, iymdcur, ihmscur, & + iclm, jclm, k, m, nsubareas, iflag + print 95030, t, dtchem_sv1, cairclm(k), relhumclm(k), & + ptotclm(k), afracsubarea(k,m) + print 95030, (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2) + end do + end do + print 95010, 'aerchem_debug_dump end' + + + return + end subroutine aerchem_debug_dump + + + +!----------------------------------------------------------------------- + end module module_mosaic_driver diff --git a/wrfv2_fire/chem/module_mosaic_drydep.F b/wrfv2_fire/chem/module_mosaic_drydep.F new file mode 100644 index 00000000..802794f4 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_drydep.F @@ -0,0 +1,510 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_drydep + + +! rce 2005-feb-18 - several fixes for indices of dlo/hi_sect, volumlo/hi_sect, +! which are now (isize,itype) + +! rce 2004-dec-03 - many changes associated with the new aerosol "pointer" +! variables in module_data_mosaic_asect + + + contains + + +!----------------------------------------------------------------------- + subroutine mosaic_drydep_driver( & + id, ktau, dtstep, config_flags, & + gmt, julday, & + t_phy, rho_phy, p_phy, & + ust, aer_res, & + moist, chem, ddvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use module_configure, only: grid_config_rec_type, num_moist, num_chem + use module_state_description, only: param_first_scalar + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_mosaic_driver, only: mapaer_tofrom_host + use module_peg_util, only: peg_error_fatal + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, julday + + integer, intent(in) :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + real, intent(in) :: dtstep, gmt + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + t_phy, rho_phy, p_phy + + real, intent(in), & + dimension( ims:ime, jms:jme ) :: & + ust + + real, intent(in), & + dimension( its:ite, jts:jte ) :: & + aer_res + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + + real, intent(inout), & + dimension( its:ite, jts:jte, 1:num_chem ) :: & + ddvel + + type(grid_config_rec_type), intent(in) :: config_flags + + +! local variables + integer idum, jdum + integer it, jt, kt + integer iphase, itype + integer ktmaps, ktmape + integer ll, l1, n + integer levdbg_err, levdbg_info + + integer idiagaa_dum, ijcount_dum + + real dum + real vdep_aer(maxd_asize,maxd_atype,maxd_aphase) + + character*100 msg + + +!!rcetestdd diagnostics -------------------------------------------------- +! print 93010, ' ' +! print 93010, 'rcetestdd diagnostics from mosaic_drydep_driver' +! print 93010, 'id, chem_opt, ktau, julday ', & +! id, config_flags%chem_opt, ktau, julday +! print 93010, 'ims/e, j, k', ims, ime, jms, jme, kms, kme +! print 93010, 'its/e, j, k', its, ite, jts, jte, kts, kte +! +! do jdum = 0, 2 +! do idum = 0, 2 +! jt = jts + ((jte-jts)/2)*jdum +! it = its + ((ite-its)/2)*idum +!if (idum .eq. 2) it = ite +!if (jdum .eq. 2) jt = jte +! kt = kts +! print 93050, 'it, jt, t, p, ust, aer_res', it, jt, & +! t_phy(it,kt,jt), p_phy(it,kt,jt), ust(it,jt), aer_res(it,jt) +! end do +! end do +! +!93010 format( a, 8(1x,i6) ) +!93020 format( a, 8(1p,e14.6) ) +!93050 format( a, 2(1x,i4), 8(1p,e14.6) ) +!!rcetestdd diagnostics -------------------------------------------------- + + +! ktmaps,ktmape = first/last wrf kt for which depvel is calculated +! ktot = number of levels at which depvel is calculated + ktmaps = kts + ktmape = kts + ktot = 1 + + +! set some variables to their wrf-chem "standard" values + lunerr = -1 + lunout = -1 + levdbg_err = 0 + levdbg_info = 15 + + iymdcur = 20030822 + ihmscur = 0 + dum = gmt*3600.0 + dtstep*(ktau-1) + dum = mod( dum, 86400.0 ) + ihmscur = nint( dum ) + + t = dtstep*(ktau-1) + ncorecnt = ktau - 1 + +! reset some variables to "box test" values +! (*** aboxtest_get_extra_args is for "box testing" only +! and should be not be called from wrf-chem ***) +! call aboxtest_get_extra_args( 20, & +! iymdcur, ihmscur, & +! aboxtest_units_convert, aboxtest_rh_method, & +! aboxtest_map_method, aboxtest_gases_fixed, & +! lunerr, lunout, t, dum ) + + +! set "pegasus" grid size variables + itot = ite + jtot = jte + nsubareas = 1 + + ijcount_dum = 0 + + + do 2920 jt = jts, jte + do 2910 it = its, ite + + ijcount_dum = ijcount_dum + 1 + + + call mapaer_tofrom_host( 0, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + it, jt, ktmaps,ktmape, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) + + +! compute deposition velocities + idiagaa_dum = 1 + idiagaa_dum = 0 + if ((jt.ne.jts) .and. (jt.ne.jte) .and. & + (jt.ne.(jts+jte)/2)) idiagaa_dum = 0 + if ((it.ne.its) .and. (it.ne.ite) .and. & + (it.ne.(its+ite)/2)) idiagaa_dum = 0 + + call mosaic_drydep_1clm( idiagaa_dum, it, jt, & + ust(it,jt), aer_res(it,jt), vdep_aer ) + + +! rce 23-nov-2004 - change to using the "..._aer" species pointers + do iphase = 1, nphase_aer + do itype = 1, ntype_aer + do n = 1, nsize_aer(itype) + do ll = -2, ncomp_plustracer_aer(itype) + if (ll .eq. -2) then + l1 = numptr_aer(n,itype,iphase) + else if (ll .eq. -1) then + l1 = -1 + if (iphase .eq. ai_phase) l1 = waterptr_aer(n,itype) + else if (ll .eq. 0) then + l1 = -1 + if (iphase .eq. ai_phase) l1 = hyswptr_aer(n,itype) + else + l1 = massptr_aer(ll,n,itype,iphase) + end if + if (l1 .ge. param_first_scalar) then + ddvel(it,jt,l1) = vdep_aer(n,itype,iphase) + end if + end do + end do + end do + end do + + +2910 continue +2920 continue +! print 93010, 'leaving mosaic_drydep_driver' + + + return + end subroutine mosaic_drydep_driver + + +!----------------------------------------------------------------------- + subroutine mosaic_drydep_1clm( idiagaa, it, jt, & + ustar_in, depresist_a_in, vdep_aer ) + + use module_configure, only: grid_config_rec_type + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_mosaic_driver, only: mapaer_tofrom_host + use module_peg_util, only: peg_error_fatal + + implicit none + +! subr arguments + integer, intent(in) :: idiagaa, it, jt + +! friction velocity (m/s) + real, intent(in) :: ustar_in +! aerodynamic resistance (s/m) + real, intent(in) :: depresist_a_in + +! deposition velocities (m/s) + real, intent(inout) :: vdep_aer(maxd_asize,maxd_atype,maxd_aphase) + +! local variables + real, parameter :: densdefault = 2.0 + real, parameter :: smallmassaa = 1.0e-20 + real, parameter :: smallmassbb = 1.0e-30 + real, parameter :: piover6 = pi/6.0 + real, parameter :: onethird = 1.0/3.0 + + integer iphase, itype, k, ll, l1, m, n + + real airdens, airkinvisc + real depresist_a, depresist_unstabpblfact + real depresist_d0, depresist_d3 + real depvel_a0, depvel_a3 + real drydens, drydp, drymass, dryvol + real dum, dumalnsg, dumfact, dummass + real freepath + real rnum + real temp + real ustar + real vsettl_0, vsettl_3 + real wetdgnum, wetdens, wetdp, wetmass, wetvol + + +! if (idiagaa>0) print *, ' ' + k = 1 + m = 1 + +! temperature (K) + temp = rsub(ktemp,k,m) +! air density (g/cm^3) +! airdens = cairclm(1)*xmwair + airdens = cairclm(1)*28.966 +! air kinematic viscosity (cm^2/s) + airkinvisc = ( 1.8325e-4 * (416.16/(temp+120.0)) * & + ((temp/296.16)**1.5) ) / airdens +! air molecular freepath (cm) + freepath = 7.39758e-4 * airkinvisc / sqrt(temp) +! friction velocity (cm/s) + ustar = ustar_in * 100.0 +! aerodynamic resistance (s/cm) + depresist_a = depresist_a_in * 0.01 + +! enhancement factor for unstable pbl + depresist_unstabpblfact = 1.0 + + +! initialize vdep_aer + vdep_aer(:,:,:) = 0.0 + +! *** for now, just calc vdep_aer for iphase = ai_phase + iphase = ai_phase + +! calculate vdep_aer + do 2900 itype = 1, ntype_aer + do 2800 n = 1, nsize_aer(itype) + + dryvol = 0.0 + drymass = 0.0 + do ll = 1, ncomp_aer(itype) + l1 = massptr_aer(ll,n,itype,iphase) + dummass = rsub(l1,k,m)*mw_aer(ll,itype) + drymass = drymass + dummass + dryvol = dryvol + dummass/dens_aer(ll,itype) + end do + + l1 = waterptr_aer(n,itype) + dummass = rsub(l1,k,m)*mw_water_aer + wetmass = drymass + dummass + wetvol = dryvol + dummass/dens_water_aer + + l1 = numptr_aer(n,itype,iphase) + rnum = rsub(l1,k,m) + + if (drymass .le. smallmassbb) then + drydp = dcen_sect(n,itype) + drydens = densdefault + wetdp = drydp + wetdens = drydens + goto 1900 + end if + +!jdf if (drymass .le. smallmassbb) then + if (drymass .le. smallmassaa) then + wetmass = drymass + wetvol = dryvol + end if + drydens = drymass/dryvol + wetdens = wetmass/wetvol + + + if (rnum .ge. dryvol/volumlo_sect(n,itype)) then + drydp = dlo_sect(n,itype) + else if (rnum .le. dryvol/volumhi_sect(n,itype)) then + drydp = dhi_sect(n,itype) + else + drydp = (dryvol/(piover6*rnum))**onethird + end if + +!jdf dumfact = (wetvol/dryvol)**onethird +!jdf dumfact = min( dumfact, 10.0 ) + if(abs(wetvol).gt.(1000.*abs(dryvol))) then + dumfact=10.0 + else + dumfact=abs(wetvol/dryvol)**onethird + dumfact=max(1.0,min(dumfact,10.0)) + endif +!jdf + wetdp = drydp*dumfact + +1900 continue + + +! +! get surface resistance and settling velocity for mass (moment 3) +! and number (moment 0) +! + dumalnsg = log( 1.0 ) + wetdgnum = wetdp * exp( -1.5*dumalnsg*dumalnsg ) + call aerosol_depvel_2( & + wetdgnum, dumalnsg, wetdens, & + temp, airdens, airkinvisc, freepath, & + ustar, depresist_unstabpblfact, & + depresist_d0, vsettl_0, & + depresist_d3, vsettl_3 ) + +! +! compute overall deposition velocity (binkowski/shankar eqn a33) +! + dum = depresist_a + depresist_d3 + & + depresist_a*depresist_d3*vsettl_3 + depvel_a3 = vsettl_3 + (1./dum) + + dum = depresist_a + depresist_d0 + & + depresist_a*depresist_d0*vsettl_0 + depvel_a0 = vsettl_0 + (1./dum) + +! cm/s --> m/s + vdep_aer(n,itype,iphase) = depvel_a3 * 0.01 + + +! +! diagnostic output +! + if (idiagaa>0) print 9310, it, jt, n, itype, iphase, & + dcen_sect(n,itype), drydp, wetdp, & + drydens, wetdens, vdep_aer(n,itype,iphase), & + vsettl_3, depresist_d3, depresist_a +9310 format( 'aerdep', 2i4, 3i3, 1p, 3e10.2, & + 2x, 0p, 2f5.2, 2x, 1p, 4e10.2 ) + + +2800 continue +2900 continue + + + return + end subroutine mosaic_drydep_1clm + + +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + subroutine aerosol_depvel_2( & + dgnum, alnsg, aerodens, & + temp, airdens, airkinvisc, freepath, & + ustar, depresist_unstabpblfact, & + depresist_d0, vsettl_0, & + depresist_d3, vsettl_3 ) +! +! computes the surface layer resistance term and the +! gravitational settling velocity term for the 3rd moment +! of a log-normal aerosol mode +! +! input parameters +! dgnum - geometric mean diameter for aerosol number (cm) +! alnsg - natural logarithm of the geometric standard deviation +! for aerosol number +! aerodens - aerosol density (dgnum and aerodens are for the +! actual wet distribution) +! temp - temperature (K) +! airdens - air density (g/cm^3) +! airkinvisc - air kinematic viscosity (cm^2/s) +! freepath - air molecular freepath (cm) +! ustar - friction velocity (cm/s) +! depresist_unstabpblfact = weseley et al. 1985 factor for increasing +! depvel in unstable pbl -- either +! 1. + (-0.3*zi/L)**0.667 OR +! 1. + 0.24*((wstar/ustar)**2) +! output parameters +! depresist_d3 - surface layer resistance for 3rd (mass) moment (s/cm) +! vsettl_3 - gravitational settling velocity for 3rd moment (cm/s) +! depresist_d0 - surface layer resistance for 0th (number) moment (s/cm) +! vsettl_0 - gravitational settling velocity for 0th moment (cm/s) +! + + implicit none + + real dgnum, alnsg, aerodens, & + temp, airdens, airkinvisc, freepath, & + ustar, depresist_unstabpblfact, & + depresist_d0, vsettl_0, & + depresist_d3, vsettl_3 + + real aerodiffus_0, schmidt_0, stokes_0, facdepresist_d0 + real aerodiffus_3, schmidt_3, stokes_3, facdepresist_d3 + common / aerosol_depvel_cmn01 / & + aerodiffus_0, schmidt_0, stokes_0, facdepresist_d0, & + aerodiffus_3, schmidt_3, stokes_3, facdepresist_d3 + + real xknudsen, xknudsenfact, alnsg2, duma, dumb, & + vsettl_dgnum, aerodiffus_dgnum + + real pi + parameter (pi = 3.1415926536) +! gravity = gravitational acceleration in cm/s^2 + real gravity + parameter (gravity = 980.616) +! boltzmann constant in erg/deg-K + real boltzmann + parameter (boltzmann = 1.3807e-16) + + xknudsen = 2.*freepath/dgnum + xknudsenfact = xknudsen*1.246 + alnsg2 = alnsg*alnsg + + vsettl_dgnum = (gravity*aerodens*dgnum*dgnum)/ & + (18.*airkinvisc*airdens) + vsettl_0 = vsettl_dgnum * & + ( exp(2.*alnsg2) + xknudsenfact*exp(0.5*alnsg2) ) + vsettl_3 = vsettl_dgnum * & + ( exp(8.*alnsg2) + xknudsenfact*exp(3.5*alnsg2) ) + + aerodiffus_dgnum = (boltzmann*temp)/ & + (3.*pi*airkinvisc*airdens*dgnum) + aerodiffus_0 = aerodiffus_dgnum * & + ( exp(+0.5*alnsg2) + xknudsenfact*exp(+2.*alnsg2) ) + aerodiffus_3 = aerodiffus_dgnum * & + ( exp(-2.5*alnsg2) + xknudsenfact*exp(-4.*alnsg2) ) + + schmidt_0 = airkinvisc/aerodiffus_0 + schmidt_3 = airkinvisc/aerodiffus_3 + + stokes_0 = ustar*ustar*vsettl_0/(gravity*airkinvisc) + stokes_3 = ustar*ustar*vsettl_3/(gravity*airkinvisc) + + duma = (schmidt_0**(-0.66666666)) + & + (10.**(-3./max(0.03,stokes_0))) +! dumb = duma*ustar*(1. + 0.24*wstaroverustar*wstaroverustar) + dumb = duma*ustar*depresist_unstabpblfact + depresist_d0 = 1./max( dumb, 1.e-20 ) + facdepresist_d0 = duma + + duma = (schmidt_3**(-0.66666666)) + & + (10.**(-3./max(0.03,stokes_3))) +! dumb = duma*ustar*(1. + 0.24*wstaroverustar*wstaroverustar) + dumb = duma*ustar*depresist_unstabpblfact + depresist_d3 = 1./max( dumb, 1.e-20 ) + facdepresist_d3 = duma + + return + end subroutine aerosol_depvel_2 + + +!----------------------------------------------------------------------- + end module module_mosaic_drydep diff --git a/wrfv2_fire/chem/module_mosaic_initmixrats.F b/wrfv2_fire/chem/module_mosaic_initmixrats.F new file mode 100644 index 00000000..9673755b --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_initmixrats.F @@ -0,0 +1,1468 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** +!CPP directives to control ic/bc conditions... +!(The directive in module_input_chem_data also needs to be set.) +! CASENAME = 0 Uses Texas August 2004 case values and profiles +! 1 Uses same concentrations as TX, but uses different +! profiles depending on the species. (NEAQS2004 case) +#define CASENAME 0 + + module module_mosaic_initmixrats + +! rce 2005-feb-18 - several fixes for indices of dlo/hi_sect, volumlo/hi_sect, +! which are now (isize,itype) + +! rce 2004-dec-03 - many changes associated with the new aerosol "pointer" +! variables in module_data_mosaic_asect + + USE module_state_description + + integer, parameter :: mosaic_init_wrf_mixrats_flagaa = 1 + ! turns subr mosaic_init_wrf_mixrats on/off + + contains + + +!----------------------------------------------------------------------- + subroutine mosaic_init_wrf_mixrats( & + iflagaa, config_flags, & + chem, alt, z_at_w, g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! +! initializes the species and number mixing ratios for each section +! +! this top level routine simply calls other routines depending on value +! of config_flags%aer_ic_opt +! + use module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem, param_first_scalar, & + aer_ic_pnnl + use module_data_mosaic_asect + use module_data_mosaic_other + use module_peg_util, only: peg_message, peg_error_fatal + + implicit none + + +! subr arguments + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + iflagaa, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + alt, z_at_w + real, intent(in) :: g + +! local variables + integer :: i, ic, j, k + + if (config_flags%aer_ic_opt == aer_ic_pnnl) then + call mosaic_init_wrf_mixrats_opt2( & + iflagaa, config_flags, & + chem, z_at_w, g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + else + call mosaic_init_wrf_mixrats_opt1( & + iflagaa, config_flags, & + chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end if + +! Aerosol species are returned from above in concentration units. Convert +! them to mixing ratio for use in advection, etc. + do ic = p_so4_a01,num_chem + do j = jts,jte + do k = kts,kte-1 + do i = its,ite + chem(i,k,j,ic) = chem(i,k,j,ic)*alt(i,k,j) + end do + end do + end do + end do + +! Fill the top z-staggered location to prevent trouble during advection. + do ic = p_so4_a01,num_chem + do j = jts,jte + do i = its,ite + chem(i,kte,j,ic) = chem(i,kte-1,j,ic) + end do + end do + end do + + return + end subroutine mosaic_init_wrf_mixrats + + +!----------------------------------------------------------------------- + subroutine mosaic_init_wrf_mixrats_opt1( & + iflagaa, config_flags, & + chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! +! initializes the species and number mixing ratios for each section +! based on user-specified lognormal modes that span the size distribution +! +! rce 11-sep-2004 - eliminated use of the _wrfch pointers (lptr_xxx_a_wrfch, +! lwaterptr_wrfch, numptr_wrfch); use only the _amode pointers now; +! added l1dum +! + use module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem, param_first_scalar + use module_data_mosaic_asect + use module_data_mosaic_other + use module_peg_util, only: peg_message, peg_error_fatal + + implicit none + +! subr arguments + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + iflagaa, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + +! local variables + integer i, j, k, l, ll, l1, l3, l1dum, m, mdum, nsm + integer it, jt, kt + + real dum, dumdp, dumrsfc, dumvol, & + xlo, xhi, & + dumvol1p, & + pdummb, zdumkm, zscalekm, zfactor + + real vtot_nsm_ofmode(maxd_asize) + real dumarr(maxd_acomp+5) + + real erfc + +! double precision fracnum, fracvol, tlo, thi + real fracvol, tlo, thi + + integer nmaxd_nsm + parameter (nmaxd_nsm = 4) + + integer iphase, itype, ntot_nsm + integer iiprof_nsm(nmaxd_nsm) + integer lldum_so4, lldum_nh4, lldum_oc, lldum_bc, & + lldum_oin, lldum_na, lldum_cl, lldum_hysw + + real sx_nsm(nmaxd_nsm), sxr2_nsm(nmaxd_nsm), & + x0_nsm(nmaxd_nsm), x3_nsm(nmaxd_nsm), & + rtot_nsm(maxd_acomp,nmaxd_nsm), & + vtot_nsm(nmaxd_nsm), xntot_nsm(nmaxd_nsm) + + real dgnum_nsm(nmaxd_nsm), sigmag_nsm(nmaxd_nsm) + real aaprof_nsm(maxd_acomp+1,nmaxd_nsm) + real bbprof_nsm(nmaxd_nsm) + + character*80 msg + character*10 dumname + + +! check for on/off + if (mosaic_init_wrf_mixrats_flagaa .le. 0) return + + +! *** currently only works for ntype_aer = 1 + itype = 1 + iphase = ai_phase + m = 1 + +! set values for initialization modes + iiprof_nsm(:) = 1 + aaprof_nsm(:,:) = 0.0 + bbprof_nsm(:) = 0.0 + + ntot_nsm = 4 + ntot_nsm = min( ntot_nsm, nsize_aer(itype) ) + + lldum_so4 = 0 + lldum_nh4 = 0 + lldum_oc = 0 + lldum_bc = 0 + lldum_oin = 0 + lldum_na = 0 + lldum_cl = 0 + lldum_hysw = 0 + + do ll = 1, ncomp_plustracer_aer(itype) + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_so4_aer(m,itype,iphase)) lldum_so4 = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_nh4_aer(m,itype,iphase)) lldum_nh4 = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_oc_aer(m,itype,iphase)) lldum_oc = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_bc_aer(m,itype,iphase)) lldum_bc = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_oin_aer(m,itype,iphase)) lldum_oin = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_na_aer(m,itype,iphase)) lldum_na = ll + if (massptr_aer(ll,m,itype,iphase) .eq. & + lptr_cl_aer(m,itype,iphase)) lldum_cl = ll + end do + if (hyswptr_aer(m,itype) .gt. 0) & + lldum_hysw = ncomp_plustracer_aer(itype) + 1 + + msg = ' ' + if (lldum_so4 .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_so4 = 0' + if (lldum_nh4 .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_nh4 = 0' + if (lldum_oc .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_oc = 0' + if (lldum_bc .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_bc = 0' + if (lldum_oin .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_oin = 0' + if (lldum_na .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_na = 0' + if (lldum_cl .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_cl = 0' + if (lldum_hysw .le. 0) & + msg = '*** subr mosaic_init_wrf_mixrats - lldum_hysw = 0' + if (msg .ne. ' ') call peg_error_fatal( lunerr, msg ) + + + do nsm = 1, ntot_nsm + + if (nsm .eq. 1) then +! accum mode with so4, nh4, oc, bc + dgnum_nsm( nsm) = 0.15e-4 + sigmag_nsm(nsm) = 2.0 + aaprof_nsm(lldum_so4,nsm) = 0.50 + aaprof_nsm(lldum_nh4,nsm) = aaprof_nsm(lldum_so4,nsm) & + * (mw_nh4_aer/mw_so4_aer) + aaprof_nsm(lldum_oc,nsm) = 0.25 + aaprof_nsm(lldum_bc,nsm) = 0.05 + aaprof_nsm(lldum_hysw,nsm) = aaprof_nsm(lldum_so4,nsm) * 0.2 + + else if (nsm .eq. 2) then +! aitken mode with so4, nh4, oc, bc + dgnum_nsm( nsm) = 0.03e-4 + sigmag_nsm(nsm) = 2.0 + aaprof_nsm(lldum_so4,nsm) = 0.50 * 0.020 + aaprof_nsm(lldum_nh4,nsm) = aaprof_nsm(lldum_so4,nsm) & + * (mw_nh4_aer/mw_so4_aer) + aaprof_nsm(lldum_oc,nsm) = 0.25 * 0.020 + aaprof_nsm(lldum_bc,nsm) = 0.05 * 0.020 + aaprof_nsm(lldum_hysw,nsm) = aaprof_nsm(lldum_so4,nsm) * 0.2 + + else if (nsm .eq. 3) then +! coarse dust mode with oin + dgnum_nsm( nsm) = 1.0e-4 + sigmag_nsm(nsm) = 2.0 + aaprof_nsm(lldum_oin,nsm) = 0.5 + aaprof_nsm(lldum_hysw,nsm) = aaprof_nsm( 9,nsm) * 1.0e-3 + + else if (nsm .eq. 4) then +! coarse seasalt mode with na, cl + dgnum_nsm( nsm) = 2.0e-4 + sigmag_nsm(nsm) = 2.0 + aaprof_nsm(lldum_cl,nsm) = 0.1 + aaprof_nsm(lldum_na,nsm) = aaprof_nsm(lldum_cl,nsm) & + * (mw_na_aer/mw_cl_aer) + aaprof_nsm(lldum_hysw,nsm) = aaprof_nsm(lldum_cl,nsm) * 0.2 + + end if + + end do + +! when iflagaa = 1/2/3/4, use only the nsm-mode = iflagaa + if (iflagaa .gt. 0) then + do nsm = 1, ntot_nsm + if (nsm .ne. iflagaa) aaprof_nsm(:,nsm) = 0.0 + end do + end if + + + +! +! do the initialization now +! + +! calculate mode parameters + do nsm = 1, ntot_nsm + sx_nsm(nsm) = alog( sigmag_nsm(nsm) ) + sxr2_nsm(nsm) = sx_nsm(nsm) * sqrt(2.0) + x0_nsm(nsm) = alog( dgnum_nsm(nsm) ) + x3_nsm(nsm) = x0_nsm(nsm) + 3.0*sx_nsm(nsm)*sx_nsm(nsm) + end do + +! initialize rclm array to zero + rclm(:,:) = 0. +! rclmsvaa(:,:) = 0. + +! +! loop over all vertical levels +! +! do 12900 k = 1, ktot + do 12900 k = 1, 1 + +! pdummb = 1013.*scord(k) +! zdumkm = ptoz( pdummb ) * 1.e-3 + zdumkm = 0.0 + + +! for each species and nsm mode, define total mixing ratio +! (for all sizes) at level k +! +! iiprof_nsm = +1 gives constant mixing ratio +! aaprof_nsm(l,nsm) = constant mixing ratio (ppb) +! iiprof_nsm = +2 gives exponential profile +! aaprof_nsm(l,nsm) = surface mixing ratio (ppb) +! bbprof_nsm(l) = scale height (km) +! iiprof_nsm = +3 gives linear profile (then zero at z > zscalekm) +! aaprof_nsm(l,nsm) = surface mixing ratio (ppb) +! bbprof_nsm(l) = height (km) at which mixing ratio = 0 + + do nsm = 1, ntot_nsm + + if (iiprof_nsm(nsm) .eq. 2) then + zscalekm = bbprof_nsm(nsm) + zfactor = exp( -zdumkm/zscalekm ) + else if (iiprof_nsm(nsm) .eq. 3) then + zscalekm = bbprof_nsm(nsm) + zfactor = max( 0., (1. - zdumkm/zscalekm) ) + else + zfactor = 1.0 + end if + + do ll = 1, ncomp_plustracer_aer(itype) + 1 + rtot_nsm(ll,nsm) = aaprof_nsm(ll,nsm) * zfactor + end do + + end do + +! compute total volume and number mixing ratios for each nsm mode +! rtot_nsm is ug/m3, 1.0e-6*rtot is g/m3, vtot_nsm is cm3/m3 + do nsm = 1, ntot_nsm + dumvol = 0. + do ll = 1, ncomp_aer(itype) + dum = 1.0e-6*rtot_nsm(ll,nsm)/dens_aer(ll,itype) + dumvol = dumvol + max( 0., dum ) + end do + vtot_nsm(nsm) = dumvol + end do + +! now compute species and number mixing ratios for each bin + do 12700 m = 1, nsize_aer(itype) + + vtot_nsm_ofmode(m) = 0.0 + + do 12500 nsm = 1, ntot_nsm + +! for nsm_mode = n, compute fraction of number and volume +! that is in bin m + xlo = alog( dlo_sect(m,itype) ) + xhi = alog( dhi_sect(m,itype) ) + + tlo = (xlo - x3_nsm(nsm))/sxr2_nsm(nsm) + thi = (xhi - x3_nsm(nsm))/sxr2_nsm(nsm) + if (tlo .ge. 0.) then +! fracvol = 0.5*( erfc(tlo) - erfc(thi) ) + fracvol = 0.5*( erfc_num_recipes(tlo) - erfc_num_recipes(thi) ) + else +! fracvol = 0.5*( erfc(-thi) - erfc(-tlo) ) + fracvol = 0.5*( erfc_num_recipes(-thi) - erfc_num_recipes(-tlo) ) + end if + fracvol = max( fracvol, 0.0 ) + + vtot_nsm_ofmode(m) = vtot_nsm_ofmode(m) + vtot_nsm(nsm)*fracvol + +! now load that fraction of species-mixing-ratio +! into the appropriate rclm location + do ll = 1, ncomp_plustracer_aer(itype) + rclm( k, massptr_aer(ll,m,itype,iphase) ) = & + rclm( k, massptr_aer(ll,m,itype,iphase) ) + & + fracvol*rtot_nsm(ll,nsm) + end do + + if ((iphase .eq. ai_phase) .and. & + (lldum_hysw .gt. 0) .and. & + (hyswptr_aer(m,itype) .gt. 0)) then + + rclm( k, hyswptr_aer(m,itype) ) = & + rclm( k, hyswptr_aer(m,itype) ) + & + fracvol*rtot_nsm(lldum_hysw,nsm) + end if + +12500 continue + +! now compute number from volume + dum = sqrt( dlo_sect(m,itype)*dhi_sect(m,itype) ) + dumvol1p = (pi/6.0)*(dum**3) + rclm( k, numptr_aer(m,itype,iphase) ) = vtot_nsm_ofmode(m)/dumvol1p + +! set water = hyswatr + if ((iphase .eq. ai_phase) .and. & + (lldum_hysw .gt. 0) .and. & + (hyswptr_aer(m,itype) .gt. 0) .and. & + (waterptr_aer(m,itype) .gt. 0)) then + + rclm( k, waterptr_aer(m,itype) ) = & + rclm( k, hyswptr_aer(m,itype) ) + end if + +12700 continue + +12900 continue + + +! +! do diagnostic output +! + +! temporary +! temporary + + dumarr(:) = 0.0 + msg = ' ' + call peg_message( lunout, msg ) + msg = '*** subr mosaic_init_wrf_mixrats_opt1 results' + call peg_message( lunout, msg ) + msg = ' mass in ug/m3 number in #/m3 volume in cm3/m3' + call peg_message( lunout, msg ) + msg = ' ' + call peg_message( lunout, msg ) + msg = ' mode l l1 species conc' + call peg_message( lunout, msg ) + + do 14390 mdum = 1, nsize_aer(itype)+1 + m = min( mdum, nsize_aer(itype) ) + msg = ' ' + call peg_message( lunout, msg ) + do 14350 l = 1, ncomp_plustracer_aer(itype)+4 + + if (l .le. ncomp_plustracer_aer(itype)) then + l1 = massptr_aer(l,m,itype,iphase) + dumname = name_aer(l,itype) + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+1) then + l1 = hyswptr_aer(m,itype) + dumname = 'hystwatr' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+2) then + l1 = waterptr_aer(m,itype) + dumname = 'water' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+3) then + l1 = numptr_aer(m,itype,iphase) + dumname = 'number' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+4) then + l1 = 0 + dumname = 'volume' + dum = vtot_nsm_ofmode(m) + else + dumname = '=BADBAD=' + l1 = -1 + dum = -1.0 + end if + + l1dum = l1 + if (aboxtest_testmode .gt. 0) l1dum = max( l1-1, 0 ) + + if (mdum .le. nsize_aer(itype)) then + dumarr(l) = dumarr(l) + dum + write(msg,9620) m, l, l1dum, dumname, dum + else + write(msg,9625) l, dumname, dumarr(l) + end if + call peg_message( lunout, msg ) + +14350 continue +14390 continue + +9620 format( 3i4, 2x, a, 3(1pe12.3) ) +9625 format( ' sum', i4, ' -', 2x, a, 3(1pe12.3) ) + + +! +! load the chem array +! + do 16390 m = 1, nsize_aer(itype) + do 16350 l = 1, 15 + + if (l .eq. 1) then + l1 = lptr_so4_aer(m,itype,iphase) + else if (l .eq. 2) then + l1 = lptr_no3_aer(m,itype,iphase) + else if (l .eq. 3) then + l1 = lptr_cl_aer(m,itype,iphase) + else if (l .eq. 4) then + l1 = lptr_msa_aer(m,itype,iphase) + else if (l .eq. 5) then + l1 = lptr_co3_aer(m,itype,iphase) + else if (l .eq. 6) then + l1 = lptr_nh4_aer(m,itype,iphase) + else if (l .eq. 7) then + l1 = lptr_na_aer(m,itype,iphase) + else if (l .eq. 8) then + l1 = lptr_ca_aer(m,itype,iphase) + else if (l .eq. 9) then + l1 = lptr_oin_aer(m,itype,iphase) + else if (l .eq. 10) then + l1 = lptr_oc_aer(m,itype,iphase) + else if (l .eq. 11) then + l1 = lptr_bc_aer(m,itype,iphase) + else if (l .eq. 12) then + l1 = hyswptr_aer(m,itype) + else if (l .eq. 13) then + l1 = waterptr_aer(m,itype) + else if (l .eq. 14) then + l1 = numptr_aer(m,itype,iphase) + else + goto 16350 + end if + l3 = l1 + + if ((l1 .gt. 0) .and. (l1 .le. lmaxd) .and. & + (l3 .ge. param_first_scalar)) then + do it = its, ite +! *** note: not sure what the kt limits should be here + do kt = kts, kte-1 + do jt = jts, jte + chem(it,kt,jt,l3) = rclm(1,l1) + end do + end do + end do + end if + +16350 continue +16390 continue + + +! all done + return + end subroutine mosaic_init_wrf_mixrats_opt1 + + +!----------------------------------------------------------------------- +!wig 10-May-2004, added phb, ph, g + subroutine mosaic_init_wrf_mixrats_opt2( & + iflagaa, config_flags, & + chem, z_at_w, g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! +! provides initial values for mosaic aerosol species (mass and number +! mixing ratio) for "Texas August 2000" simulations +! modified to use different profiles for different aerosols for NEAQS case, egc 7/2005 +! currently all the initial values are uniform in x, y, AND z +! +! rce 11-sep-2004 - eliminated use of the _wrfch pointers (lptr_xxx_a_wrfch, +! lwaterptr_wrfch, numptr_wrfch); use only the _amode pointers now +! + use module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem, param_first_scalar + use module_data_mosaic_asect + use module_data_mosaic_other + use module_peg_util, only: peg_message, peg_error_fatal + + implicit none + +! subr arguments + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + iflagaa, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + z_at_w + real :: g + +! local variables + integer l, l1, l3, m, mdum + integer iphase, itype + integer it, jt, kt + +!wig 10-May-2004, added mult + real dum, dumvol1p, mult + real qcoar, qfine, qval + + real :: vtot_ofmode(maxd_asize) + real :: dumarr(maxd_acomp+5) + real :: fr_coar(8), fr_fine(8) + +!wig 01-Apr-2005, Updated fractional breakdown between bins. (See also +! bdy_chem_value_mosaic in this file and mosaic_addemiss in +! module_mosaic_addemiss.F) Note that the values here no +! longer match those in mosaic_addemiss. +!rce 10-May-2005, changed fr8b_coar to values determined by jdf + real, save :: fr8b_coar(8) = & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /) ! 10-May-2005 +! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.933, 0.067 /) ! 01-Apr-2005 +! (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.16, 0.84 /) ! "old" + + real, save :: fr8b_fine(8) = & + (/ 0.006, 0.024, 0.231, 0.341, 0.140, 0.258, 0., 0./) !5-Apr-2005 values +! (/ 0.0275, 0.0426, 0.2303, 0.3885, 0.1100, 0.2011, 0., 0./) !15-Nov-2004 values +! (/ 0.01, 0.05, 0.145, 0.60, 0.145, 0.05, 0.00, 0.00 /) +! (/ 0.04, 0.10, 0.35, 0.29, 0.15, 0.07, 0.00, 0.00 /) + + real :: qfine_so4, qfine_no3, qfine_cl, qfine_msa, & + qfine_co3, qfine_nh4, qfine_na, qfine_ca, qfine_oin, & + qfine_oc, qfine_bc, qfine_hysw, qfine_watr, qfine_vol + real :: qcoar_so4, qcoar_no3, qcoar_cl, qcoar_msa, & + qcoar_co3, qcoar_nh4, qcoar_na, qcoar_ca, qcoar_oin, & + qcoar_oc, qcoar_bc, qcoar_hysw, qcoar_watr, qcoar_vol + +!wig 10-May-2004, added z + real, dimension( ims:ime, kms:kme, jms:jme ) :: z + + character*80 msg + character*10 dumname + + +! *** currently only works for ntype_aer = 1 + itype = 1 + iphase = ai_phase + m = 1 + +!wig 10-May-2004, block begin... +! calculate the mid-level heights + do jt = jts, min(jte,jde-1) + do kt = kts, kte-1 + do it = its, min(ite,ide-1) + z(it,kt,jt) = (z_at_w(it,kt,jt)+z_at_w(it,kt+1,jt))*0.5 + end do + end do + end do +!wig 10-May-2004, ...end block + +! set the partitioning fractions for either 8 or 4 bins + if (nsize_aer(itype) == 8) then + fr_coar(:) = fr8b_coar(:) + fr_fine(:) = fr8b_fine(:) + else if (nsize_aer(itype) == 4) then + do m = 1, nsize_aer(itype) + fr_coar(m) = fr8b_coar(2*m) + fr8b_coar(2*m-1) + fr_fine(m) = fr8b_fine(2*m) + fr8b_fine(2*m-1) + end do + else + write(msg,'(a,i5)') & + 'subr mosaic_init_wrf_mixrats_opt2' // & + ' - nsize_aer(itype) must be 4 or 8 but = ', nsize_aer(itype) + call peg_error_fatal( lunout, msg ) + end if + +! +! compute initial values (currently uniform in x, y, AND z) +! load them into the chem array +! also load them into the rclm array for diagnostic output +! + rclm(:,:) = 0.0 + vtot_ofmode(:) = 0.0 + +! Set values for fine and coarse mass concentrations, and +! compute fine/coarse volume concentrations. These are also set in +! bdy_chem_value_mosaic, below. +! (these are latest values from 1-Apr-2005 discussions) +! +! rce 10-may-2005 - changed qfine_cl, _na, _oin to values determined by jdf + qfine_so4 = 2.14 + qcoar_so4 = 0.242 + qfine_no3 = 0.11 + qcoar_no3 = 0.03 +! qfine_cl = 0.3 + qfine_cl = 0.14 ! 10-May-2005 + qcoar_cl = 0.139 + qfine_msa = 0.0 + qcoar_msa = 0.0 + qfine_co3 = 0.0 + qcoar_co3 = 0.0 + qfine_nh4 = 0.83 + qcoar_nh4 = 0.10 +! qfine_na = 0.2 + qfine_na = 0.1 ! 10-May-2005 + qcoar_na = 0.09 + qfine_ca = 0.0 + qcoar_ca = 0.0 +! qfine_oin = 6.2 + qfine_oin = 3.48 ! 10-May-2005 + qcoar_oin = 0.35 + qfine_oc = 1.00 + qcoar_oc = 1.50 + qfine_bc = 0.2 + qcoar_bc = 0.075 + qfine_hysw = 0.0 + qcoar_hysw = 0.0 + qfine_watr = 0.0 + qcoar_watr = 0.0 + +!!$! old values from 23-Apr-2004: +!!$ qfine_so4 = 2.554 +!!$ qcoar_so4 = 0.242 +!!$ qfine_no3 = 0.07 +!!$ qcoar_no3 = 0.03 +!!$ qfine_cl = 0.324 +!!$ qcoar_cl = 0.139 +!!$ qfine_msa = 0.0 +!!$ qcoar_msa = 0.0 +!!$ qfine_co3 = 0.0 +!!$ qcoar_co3 = 0.0 +!!$ qfine_nh4 = 0.98 +!!$ qcoar_nh4 = 0.10 +!!$ qfine_na = 0.21 +!!$ qcoar_na = 0.09 +!!$ qfine_ca = 0.0 +!!$ qcoar_ca = 0.0 +!!$ qfine_oin = 0.15 +!!$ qcoar_oin = 0.35 +!!$ qfine_oc = 1.00 +!!$ qcoar_oc = 1.50 +!!$ qfine_bc = 0.175 +!!$ qcoar_bc = 0.075 +!!$ qfine_hysw = 0.0 +!!$ qcoar_hysw = 0.0 +!!$ qfine_watr = 0.0 +!!$ qcoar_watr = 0.0 + + +! qfine_so4 ... are ug/m3 so 1.0e-6 factor gives g/m3 +! dens_so4 ... are g/cm3; qfine_vol ... are cm3/m3 + qfine_vol = 1.0e-6 * ( & + (qfine_so4/dens_so4_aer) + (qfine_no3/dens_no3_aer) + & + (qfine_cl /dens_cl_aer ) + (qfine_msa/dens_msa_aer) + & + (qfine_co3/dens_co3_aer) + (qfine_nh4/dens_nh4_aer) + & + (qfine_na /dens_na_aer ) + (qfine_ca /dens_ca_aer ) + & + (qfine_oin/dens_oin_aer) + (qfine_oc /dens_oc_aer ) + & + (qfine_bc /dens_bc_aer ) ) + qcoar_vol = 1.0e-6 * ( & + (qcoar_so4/dens_so4_aer) + (qcoar_no3/dens_no3_aer) + & + (qcoar_cl /dens_cl_aer ) + (qcoar_msa/dens_msa_aer) + & + (qcoar_co3/dens_co3_aer) + (qcoar_nh4/dens_nh4_aer) + & + (qcoar_na /dens_na_aer ) + (qcoar_ca /dens_ca_aer ) + & + (qcoar_oin/dens_oin_aer) + (qcoar_oc /dens_oc_aer ) + & + (qcoar_bc /dens_bc_aer ) ) + + do 2900 m = 1, nsize_aer(itype) + do 2800 l = 1, 15 + + if (l .eq. 1) then + l1 = lptr_so4_aer(m,itype,iphase) + qfine = qfine_so4 + qcoar = qcoar_so4 + else if (l .eq. 2) then + l1 = lptr_no3_aer(m,itype,iphase) + qfine = qfine_no3 + qcoar = qcoar_no3 + else if (l .eq. 3) then + l1 = lptr_cl_aer(m,itype,iphase) + qfine = qfine_cl + qcoar = qcoar_cl + else if (l .eq. 4) then + l1 = lptr_msa_aer(m,itype,iphase) + qfine = qfine_msa + qcoar = qcoar_msa + else if (l .eq. 5) then + l1 = lptr_co3_aer(m,itype,iphase) + qfine = qfine_co3 + qcoar = qcoar_co3 + else if (l .eq. 6) then + l1 = lptr_nh4_aer(m,itype,iphase) + qfine = qfine_nh4 + qcoar = qcoar_nh4 + else if (l .eq. 7) then + l1 = lptr_na_aer(m,itype,iphase) + qfine = qfine_na + qcoar = qcoar_na + else if (l .eq. 8) then + l1 = lptr_ca_aer(m,itype,iphase) + qfine = qfine_ca + qcoar = qcoar_ca + else if (l .eq. 9) then + l1 = lptr_oin_aer(m,itype,iphase) + qfine = qfine_oin + qcoar = qcoar_oin + else if (l .eq. 10) then + l1 = lptr_oc_aer(m,itype,iphase) + qfine = qfine_oc + qcoar = qcoar_oc + else if (l .eq. 11) then + l1 = lptr_bc_aer(m,itype,iphase) + qfine = qfine_bc + qcoar = qcoar_bc + else if (l .eq. 12) then + l1 = hyswptr_aer(m,itype) + qfine = qfine_hysw + qcoar = qcoar_hysw + else if (l .eq. 13) then + l1 = waterptr_aer(m,itype) + qfine = qfine_watr + qcoar = qcoar_watr + else if (l .eq. 14) then + l1 = numptr_aer(m,itype,iphase) + dumvol1p = sqrt(volumlo_sect(m,itype)*volumhi_sect(m,itype)) + qfine = qfine_vol/dumvol1p + qcoar = qcoar_vol/dumvol1p + vtot_ofmode(m) = & + qfine_vol*fr_fine(m) + qcoar_vol*fr_coar(m) + else + goto 2800 + end if + l3 = l1 + + if ((l1 .gt. 0) .and. (l1 .le. lmaxd) .and. & + (l3 .ge. param_first_scalar)) then + qval = qfine*fr_fine(m) + qcoar*fr_coar(m) + rclm(1,l1) = qval + + do jt = jts, min(jte,jde-1) + do kt = kts, kte-1 + do it = its, min(ite,ide-1) + +!wig 28-May-2004, begin block... +! Determine height multiplier... +! This should mimic the calculation in sorgam_set_aer_bc_pnnl, +! sorgam_init_aer_ic_pnnl, bdy_chem_value_mosaic +!!$! Height(m) Multiplier +!!$! --------- ---------- +!!$! <=2000 1.0 +!!$! 2000=5000 0.25 +!!$! +!!$! which translates to: +!!$! 2000 2000. & +!!$ .and. z(it,kt,jt) <= 3000. ) then +!!$ mult = 1.0 - 0.0005*(z(it,kt,jt)-2000.) +!!$ elseif( z(it,kt,jt) > 3000. & +!!$ .and. z(it,kt,jt) <= 5000. ) then +!!$ mult = 0.5 - 1.25e-4*(z(it,kt,jt)-3000.) +!!$ else +!!$ mult = 0.25 +!!$ end if +! Updated 1-Apr-2005: +#if (CASENAME == 1) +! further updated 7-20-05 egc: species specific profiles based on MIRAG2 output + mult = 1.0 + if ( (l3 == 1) .or. (l3 == 2) .or. (l3 == 6) ) then +! so4, no3 and nh4 aerosol profiles + if ( z(it,kt,jt) <= 1000. ) then + mult = 1.0 + elseif( z(it,kt,jt) > 1000. & + .and. z(it,kt,jt) <= 4000. ) then + mult = 1.0 - 2.367e-4*(z(it,kt,jt)-1000.) + elseif( z(it,kt,jt) > 4000. & + .and. z(it,kt,jt) <= 5500. ) then + mult = 0.29 - 4.0e-5*(z(it,kt,jt)-4000.) + else + mult = 0.23 + end if + else if ( ( l3 == 3) .or. (l3 ==7) ) then +! na and cl aerosol profiles + if ( z(it,kt,jt) <= 100. ) then + mult = 1.0 + elseif( z(it,kt,jt) > 100. & + .and. z(it,kt,jt) <= 265. ) then + mult = 1.0 - 2.9e-3*(z(it,kt,jt)-100.) + elseif( z(it,kt,jt) > 265. & + .and. z(it,kt,jt) <= 2000. ) then + mult = 0.52 - 2.94e-4*(z(it,kt,jt)-265.) + elseif( z(it,kt,jt) > 2000. & + .and. z(it,kt,jt) <= 7000. ) then + mult = 0.01 + else + mult = 1.e-10 + end if + else if ( l3 == 10) then +! oc aerosol profile + if ( z(it,kt,jt) <= 600. ) then + mult = 1.0 + elseif( z(it,kt,jt) > 600. & + .and. z(it,kt,jt) <= 3389. ) then + mult = 1.0 - 2.04e-4*(z(it,kt,jt)-600.) + elseif( z(it,kt,jt) > 3389. & + .and. z(it,kt,jt) <= 8840. ) then + mult = 0.43 - 7.045e-5*(z(it,kt,jt)-3389.) + else + mult = 0.046 + end if + else if ( l3 == 11) then +! bc aerosol profile + if ( z(it,kt,jt) <= 100. ) then + mult = 1.0 + elseif( z(it,kt,jt) > 100. & + .and. z(it,kt,jt) <= 3400. ) then + mult = 1.0 - 2.51e-4*(z(it,kt,jt)-100.) + elseif( z(it,kt,jt) > 3400. & + .and. z(it,kt,jt) <= 8400. ) then + mult = 0.172 -2.64e-5*(z(it,kt,jt)-3400.) + else + mult = 0.04 + end if + else if ( l3 == 9) then +! oin aerosol profile + if ( z(it,kt,jt) <= 1580. ) then + mult = 1.0 + 1.77e-4 *z(it,kt,jt) + elseif( z(it,kt,jt) > 1580. & + .and. z(it,kt,jt) <= 5280. ) then + mult = 1.28 - 2.65e-4*(z(it,kt,jt)-1580.) + else + mult = 0.30 + end if + else +! generic profile for other other species (which should have groundlevel values=0) +#endif +! Height(m) Multiplier +! --------- ---------- +! <=2000 1.0 +! 2000=5000 0.125 +! +! which translates to: +! 2000 2000. & + .and. z(it,kt,jt) <= 3000. ) then + mult = 1.0 - 0.00075*(z(it,kt,jt)-2000.) + elseif( z(it,kt,jt) > 3000. & + .and. z(it,kt,jt) <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(z(it,kt,jt)-3000.) + else + mult = 0.125 + end if +#if (CASENAME == 1) + end if !close l3 comparison block +#endif + + chem(it,kt,jt,l3) = mult*rclm(1,l1) +!wig 28-May-2004, ...end block +! chem(it,kt,jt,l3) = rclm(1,l1) + end do + end do + end do + end if + + +2800 continue +2900 continue + +! +! do diagnostic output +! + dumarr(:) = 0.0 + msg = ' ' + call peg_message( lunout, msg ) + msg = '*** subr mosaic_init_wrf_mixrats_opt2 results' + call peg_message( lunout, msg ) + msg = ' mass in ug/m3 number in #/m3 volume in cm3/m3' + call peg_message( lunout, msg ) + msg = ' ' + call peg_message( lunout, msg ) + msg = ' mode l l1 species conc' + call peg_message( lunout, msg ) + + do 3190 mdum = 1, nsize_aer(itype)+1 + m = min( mdum, nsize_aer(itype) ) + msg = ' ' + call peg_message( lunout, msg ) + do 3150 l = 1, ncomp_plustracer_aer(itype)+4 + + if (l .le. ncomp_plustracer_aer(itype)) then + l1 = massptr_aer(l,m,itype,iphase) + dumname = name_aer(l,itype) + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+1) then + l1 = hyswptr_aer(m,itype) + dumname = 'hystwatr' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+2) then + l1 = waterptr_aer(m,itype) + dumname = 'water' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+3) then + l1 = numptr_aer(m,itype,iphase) + dumname = 'number' + dum = rclm(1,l1) + else if (l .eq. ncomp_plustracer_aer(itype)+4) then + l1 = 0 + dumname = 'volume' + dum = vtot_ofmode(m) + else + dumname = '=BADBAD=' + l1 = -1 + dum = -1.0 + end if + + if (mdum .le. nsize_aer(itype)) then + dumarr(l) = dumarr(l) + dum + write(msg,9620) m, l, l1, dumname, dum + else + write(msg,9625) l, dumname, dumarr(l) + end if + call peg_message( lunout, msg ) + +3150 continue +3190 continue + +9620 format( 3i4, 2x, a, 3(1pe12.3) ) +9625 format( ' sum', i4, ' -', 2x, a, 3(1pe12.3) ) + + +! all done + return + end subroutine mosaic_init_wrf_mixrats_opt2 + + +!----------------------------------------------------------------------- + real function erfc_num_recipes( x ) +! +! from press et al, numerical recipes, 1990, page 164 +! + implicit none + real x + double precision erfc_dbl, dum, t, zz + + zz = abs(x) + t = 1.0/(1.0 + 0.5*zz) + +! erfc_num_recipes = +! & t*exp( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + +! & t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + +! & t*(-1.13520398 + +! & t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) + + dum = ( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + & + t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + & + t*(-1.13520398 + & + t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) + + erfc_dbl = t * exp(dum) + if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl + + erfc_num_recipes = erfc_dbl + + return + end function erfc_num_recipes + + +!----------------------------------------------------------------------- + end module module_mosaic_initmixrats + + + + +!----------------------------------------------------------------------- + subroutine bdy_chem_value_mosaic ( chem_bv, alt, zz, nch, config_flags ) +! +! provides boundary values for the mosaic aerosol species +! +! it is outside of the module declaration because of potential +! module1 --> module2 --> module1 use conflicts +! +! rce 11-sep-2004 - eliminated use of the _wrfch pointers (lptr_xxx_a_wrfch, +! lwaterptr_wrfch, numptr_wrfch); use only the _amode pointers now +! + use module_configure, only: grid_config_rec_type + use module_state_description, only: param_first_scalar, & + aer_bc_pnnl + use module_data_mosaic_asect + use module_data_mosaic_other + implicit none + +! arguments + REAL, intent(OUT) :: chem_bv ! boundary value for chem(-,-,-,nch) + REAL, intent(IN) :: alt ! inverse density + REAL, intent(IN) :: zz ! height + INTEGER, intent(IN) :: nch ! index number of chemical species + TYPE (grid_config_rec_type), intent(in) :: config_flags + +! local variables + integer :: iphase, itype, m + logical :: foundit + + real, parameter :: chem_bv_def = 1.0e-20 +!wig 10-May-2004, added mult + real :: dumvol1p, mult + real :: qcoar, qfine, qval + + real :: fr_coar(8), fr_fine(8) + +!wig 1-Apr-2005, Updated fractional breakdown between bins. (See also +! mosaic_init_wrf_mixrats_opt2, above, and mosaic_addemiss +! in module_mosaic_addemiss.F). Note that these values no +! longer match those in mosaic_addemiss. + real, save :: fr8b_coar(8) = & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /) ! 10-May-2005 +! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.933, 0.067 /) ! 01-Apr-2005 +! (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.16, 0.84 /) + real, save :: fr8b_fine(8) = & + (/ 0.006, 0.024, 0.231, 0.341, 0.140, 0.258, 0., 0./) !5-Apr-2005 values +! (/ 0.0275, 0.0426, 0.2303, 0.3885, 0.1100, 0.2011, 0., 0./) !15-Nov-2004 values +! (/ 0.01, 0.05, 0.145, 0.60, 0.145, 0.05, 0.00, 0.00 /) +! (/ 0.04, 0.10, 0.35, 0.29, 0.15, 0.07, 0.00, 0.00 /) + + real :: qfine_so4, qfine_no3, qfine_cl, qfine_msa, & + qfine_co3, qfine_nh4, qfine_na, qfine_ca, qfine_oin, & + qfine_oc, qfine_bc, qfine_hysw, qfine_watr, qfine_vol + real :: qcoar_so4, qcoar_no3, qcoar_cl, qcoar_msa, & + qcoar_co3, qcoar_nh4, qcoar_na, qcoar_ca, qcoar_oin, & + qcoar_oc, qcoar_bc, qcoar_hysw, qcoar_watr, qcoar_vol + + character*80 msg + + + +! when aer_bc_opt /= aer_bc_pnnl, +! just chem_bv=near-zero for all species + chem_bv = chem_bv_def + if (config_flags%aer_bc_opt /= aer_bc_pnnl) return + if (nch < param_first_scalar) return + + +! *** currently only works for ntype_aer = 1 + itype = 1 + iphase = ai_phase + m = 1 !This is here for size, but is overridden by loop below. + + +! +! following is for aer_bc_opt == aer_bc_pnnl +! when boundary values are set for Texas August 2000 simulations +! +! set the partitioning fractions for either 8 or 4 bins + if (nsize_aer(itype) == 8) then + fr_coar(:) = fr8b_coar(:) + fr_fine(:) = fr8b_fine(:) + else if (nsize_aer(itype) == 4) then + do m = 1, nsize_aer(itype) + fr_coar(m) = fr8b_coar(2*m) + fr8b_coar(2*m-1) + fr_fine(m) = fr8b_fine(2*m) + fr8b_fine(2*m-1) + end do + else + write(msg,'(a,i5)') & + 'subr bdy_chem_value_mosaic' // & + ' - nsize_aer(itype) must be 4 or 8 but = ', nsize_aer(itype) + call wrf_error_fatal( msg ) + end if + +! Determine height multiplier... +! This should mimic the calculation in sorgam_set_aer_bc_pnnl, +! sorgam_init_aer_ic_pnnl, and mosaic_init_wrf_mixrats_opt2 +!!$! Height(m) Multiplier +!!$! --------- ---------- +!!$! <=2000 1.0 +!!$! 2000=5000 0.25 +!!$! +!!$! which translates to: +!!$! 2000 2000. & +!!$ .and. zz <= 3000. ) then +!!$ mult = 1.0 - 0.0005*(zz-2000.) +!!$ elseif( zz > 3000. & +!!$ .and. zz <= 5000. ) then +!!$ mult = 0.5 - 1.25e-4*(zz-3000.) +!!$ else +!!$ mult = 0.25 +!!$ end if +#if (CASENAME == 1) + mult = 1.0 + SIZE_LOOP : do m=1,nsize_aer(itype) + if( ( nch .eq. lptr_so4_aer(m,itype,iphase) ) .or. & + (nch .eq. lptr_no3_aer(m,itype,iphase) ) .or. & + (nch .eq. lptr_nh4_aer(m,itype,iphase) ) )then +! so4, no3 and nh4 aerosol profiles + if ( zz <= 1000. ) then + mult = 1.0 + elseif( zz > 1000. & + .and. zz <= 4000. ) then + mult = 1.0 - 2.367e-4*(zz-1000.) + elseif( zz > 4000. & + .and. zz <= 5500. ) then + mult = 0.29 - 4.0e-5*(zz-4000.) + else + mult = 0.23 + end if + exit SIZE_LOOP + else if ( (nch .eq. lptr_na_aer(m,itype,iphase) ) .or. & + (nch .eq. lptr_cl_aer(m,itype,iphase) ) ) then +! na and cl aerosol profiles + if ( zz <= 100. ) then + mult = 1.0 + elseif( zz > 100. & + .and. zz <= 265. ) then + mult = 1.0 - 2.9e-3*(zz-100.) + elseif( zz > 265. & + .and. zz <= 2000. ) then + mult = 0.52 - 2.94e-4*(zz-265.) + elseif( zz > 2000. & + .and. zz <= 7000. ) then + mult = 0.01 + else + mult = 1.e-10 + end if + exit SIZE_LOOP + else if (nch .eq. lptr_oc_aer(m,itype,iphase) ) then +! oc aerosol profile + if ( zz <= 600. ) then + mult = 1.0 + elseif( zz > 600. & + .and. zz <= 3389. ) then + mult = 1.0 - 2.04e-4*(zz-600.) + elseif( zz > 3389. & + .and. zz <= 8840. ) then + mult = 0.43 - 7.045e-5*(zz-3389.) + else + mult = 0.046 + end if + exit SIZE_LOOP + else if (nch .eq. lptr_bc_aer(m,itype,iphase) ) then +! bc aerosol profile + if ( zz <= 100. ) then + mult = 1.0 + elseif( zz > 100. & + .and. zz <= 3400. ) then + mult = 1.0 - 2.51e-4*(zz-100.) + elseif( zz > 3400. & + .and. zz <= 8400. ) then + mult = 0.172 -2.64e-5*(zz-3400.) + else + mult = 0.04 + end if + exit SIZE_LOOP + else if (nch .eq. lptr_oin_aer(m,itype,iphase)) then +! oin aerosol profile + if ( zz <= 1580. ) then + mult = 1.0 + 1.77e-4 *zz + elseif( zz > 1580. & + .and. zz <= 5280. ) then + mult = 1.28 - 2.65e-4*(zz-1580.) + else + mult = 0.30 + end if + exit SIZE_LOOP + else +! generic profile +#endif +! Updated aerosol profile multiplier 1-Apr-2005: +! Height(m) Multiplier +! --------- ---------- +! <=2000 1.0 +! 2000=5000 0.125 +! +! which translates to: +! 2000 2000. & + .and. zz <= 3000. ) then + mult = 1.0 - 0.00075*(zz-2000.) + elseif( zz > 3000. & + .and. zz <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(zz-3000.) + else + mult = 0.125 + end if +#if (CASENAME == 1) + end if ! end nc block comparison + end do SIZE_LOOP +#endif +! Set values for fine and coarse mass concentrations, and +! compute fine/coarse volume concentrations. These are also set in +! mosaic_init_wrf_mixrats_opt2. +! (these are latest values from 1-Apr-2005 discussions) +!wig 10-May-2004, added height multiplier (mult*) to each species... + qfine_so4 = mult*2.14 + qcoar_so4 = mult*0.242 + qfine_no3 = mult*0.11 + qcoar_no3 = mult*0.03 +! qfine_cl = mult*0.3 + qfine_cl = mult*0.14 ! 10-May-2005 + qcoar_cl = mult*0.139 + qfine_msa = mult*0.0 + qcoar_msa = mult*0.0 + qfine_co3 = mult*0.0 + qcoar_co3 = mult*0.0 + qfine_nh4 = mult*0.83 + qcoar_nh4 = mult*0.10 +! qfine_na = mult*0.2 + qfine_na = mult*0.1 ! 10-May-2005 + qcoar_na = mult*0.09 + qfine_ca = mult*0.0 + qcoar_ca = mult*0.0 +! qfine_oin = mult*6.2 + qfine_oin = 3.48 ! 10-May-2005 + qcoar_oin = mult*0.35 + qfine_oc = mult*1.00 + qcoar_oc = mult*1.50 + qfine_bc = mult*0.2 + qcoar_bc = mult*0.075 + qfine_hysw = mult*0.0 + qcoar_hysw = mult*0.0 + qfine_watr = mult*0.0 + qcoar_watr = mult*0.0 +!!$! old values from 23-Apr-2004: +!!$ qfine_so4 = mult*2.554 +!!$ qcoar_so4 = mult*0.242 +!!$ qfine_no3 = mult*0.07 +!!$ qcoar_no3 = mult*0.03 +!!$ qfine_cl = mult*0.324 +!!$ qcoar_cl = mult*0.139 +!!$ qfine_msa = mult*0.0 +!!$ qcoar_msa = mult*0.0 +!!$ qfine_co3 = mult*0.0 +!!$ qcoar_co3 = mult*0.0 +!!$ qfine_nh4 = mult*0.98 +!!$ qcoar_nh4 = mult*0.10 +!!$ qfine_na = mult*0.21 +!!$ qcoar_na = mult*0.09 +!!$ qfine_ca = mult*0.0 +!!$ qcoar_ca = mult*0.0 +!!$ qfine_oin = mult*0.15 +!!$ qcoar_oin = mult*0.35 +!!$ qfine_oc = mult*1.00 +!!$ qcoar_oc = mult*1.50 +!!$ qfine_bc = mult*0.175 +!!$ qcoar_bc = mult*0.075 +!!$ qfine_hysw = mult*0.0 +!!$ qcoar_hysw = mult*0.0 +!!$ qfine_watr = mult*0.0 +!!$ qcoar_watr = mult*0.0 + + +! qfine_so4 ... are ug/m3 so 1.0e-6 factor gives g/m3 +! dens_so4 ... are g/cm3; qfine_vol ... are cm3/m3 + qfine_vol = 1.0e-6 * ( & + (qfine_so4/dens_so4_aer) + (qfine_no3/dens_no3_aer) + & + (qfine_cl /dens_cl_aer ) + (qfine_msa/dens_msa_aer) + & + (qfine_co3/dens_co3_aer) + (qfine_nh4/dens_nh4_aer) + & + (qfine_na /dens_na_aer ) + (qfine_ca /dens_ca_aer ) + & + (qfine_oin/dens_oin_aer) + (qfine_oc /dens_oc_aer ) + & + (qfine_bc /dens_bc_aer ) ) + qcoar_vol = 1.0e-6 * ( & + (qcoar_so4/dens_so4_aer) + (qcoar_no3/dens_no3_aer) + & + (qcoar_cl /dens_cl_aer ) + (qcoar_msa/dens_msa_aer) + & + (qcoar_co3/dens_co3_aer) + (qcoar_nh4/dens_nh4_aer) + & + (qcoar_na /dens_na_aer ) + (qcoar_ca /dens_ca_aer ) + & + (qcoar_oin/dens_oin_aer) + (qcoar_oc /dens_oc_aer ) + & + (qcoar_bc /dens_bc_aer ) ) + + qfine = -1.0e30 + qcoar = -1.0e30 + +! identify the species by checking "nch" against the "lptr_xxx_a_amode(m)" + do 2900 m = 1, nsize_aer(itype) + + if (nch .eq. lptr_so4_aer(m,itype,iphase)) then + qfine = qfine_so4 + qcoar = qcoar_so4 + else if (nch .eq. lptr_no3_aer(m,itype,iphase)) then + qfine = qfine_no3 + qcoar = qcoar_no3 + else if (nch .eq. lptr_cl_aer(m,itype,iphase)) then + qfine = qfine_cl + qcoar = qcoar_cl + else if (nch .eq. lptr_msa_aer(m,itype,iphase)) then + qfine = qfine_msa + qcoar = qcoar_msa + else if (nch .eq. lptr_co3_aer(m,itype,iphase)) then + qfine = qfine_co3 + qcoar = qcoar_co3 + else if (nch .eq. lptr_nh4_aer(m,itype,iphase)) then + qfine = qfine_nh4 + qcoar = qcoar_nh4 + else if (nch .eq. lptr_na_aer(m,itype,iphase)) then + qfine = qfine_na + qcoar = qcoar_na + else if (nch .eq. lptr_ca_aer(m,itype,iphase)) then + qfine = qfine_ca + qcoar = qcoar_ca + else if (nch .eq. lptr_oin_aer(m,itype,iphase)) then + qfine = qfine_oin + qcoar = qcoar_oin + else if (nch .eq. lptr_oc_aer(m,itype,iphase)) then + qfine = qfine_oc + qcoar = qcoar_oc + else if (nch .eq. lptr_bc_aer(m,itype,iphase)) then + qfine = qfine_bc + qcoar = qcoar_bc + else if (nch .eq. hyswptr_aer(m,itype)) then + qfine = qfine_hysw + qcoar = qcoar_hysw + else if (nch .eq. waterptr_aer(m,itype)) then + qfine = qfine_watr + qcoar = qcoar_watr + else if (nch .eq. numptr_aer(m,itype,iphase)) then + dumvol1p = sqrt(volumlo_sect(m,itype)*volumhi_sect(m,itype)) + qfine = qfine_vol/dumvol1p + qcoar = qcoar_vol/dumvol1p + end if + + if ((qfine >= 0.0) .and. (qcoar >= 0.0)) then + qval = qfine*fr_fine(m) + qcoar*fr_coar(m) + chem_bv = qval*alt + goto 2910 + end if + +2900 continue +2910 continue + + return + end subroutine bdy_chem_value_mosaic + + diff --git a/wrfv2_fire/chem/module_mosaic_movesect.F b/wrfv2_fire/chem/module_mosaic_movesect.F new file mode 100644 index 00000000..fd6c9ce3 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_movesect.F @@ -0,0 +1,1857 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_movesect + + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_peg_util + + +! +! if apply_n1_inflow = 1, then subr move_sections_apply_n1_inflow +! applies an ad_hoc correction to bin 1 to account for growth of +! smaller particles (which are not simulated when aernucnew_onoff=0) +! growing into bin 1 +! if apply_n1_inflow = other, this correction is not applied +! + integer, parameter :: apply_n1_inflow = 0 + + contains + + + +!----------------------------------------------------------------------- +! +! zz08movesect.f - created 24-nov-01 from scm movebin code +! 04-dec-01 rce - added code to treat bins that had state="no_aerosol" +! 10-dec-01 rce - diagnostic writes to fort.96 deleted +! 08-aug-02 rce - this is latest version from freshair scaqs-aerosol code +! 03-aug-02 rce - bypass this routine when msectional=701 +! output nnewsave values to lunout when msectional=702 +! 29-aug-03 rce - use nspec_amode_nontracer in first "do ll" loop +! 12-nov-03 rce - two approaches now available +! jacobson moving-center (old) - when msectional=10 +! tzivion mass-number advection (new) - when msectional=20 +! 28-jan-04 rce - eliminated the move_sections_old code +! (no reason to keep it) +! +! rce 2004-dec-03 - many changes associated with the new aerosol "pointer" +! variables in module_data_mosaic_asect +! rce 2005-feb-17 - fixes involving drydens_pre/aftgrow, drymass_..., +! & mw_aer. All are dimensioned (isize,itype) but were being used +! as (itype). In old compiler, this was OK, and treated as (itype,1). +! In new compiler, this caused an error. +! Also, in subr test_move_sections, set iphase based on iflag. +!----------------------------------------------------------------------- + + +!----------------------------------------------------------------------- + subroutine move_sections( iflag, iclm, jclm, k, m) +! +! routine transfers aerosol number and mass between sections +! to account for continuous aerosol growth +! this routine is called after the gas condensation module (MOSAIC) or +! aqueous chemistry module has increased the mass within sections +! +! moving-center algorithm or mass-number advection algorithm is used, +! depending on value of mod(msectional,100) +! section mean diameter is given by +! vtot = ntot * (pi/6) * (dmean**3) +! where vtot and ntot are total dry-volume and number for the section +! if dmean is outside the section boundaries (dlo_sect & dhi_sect), then +! all the mass and number in the section are transfered to the +! section with dlo_sect(nnew) < dmean < dhi_sect(nnew) +! +! mass mixing ratios (mole/mole-air or g/mole-air) are in +! rsub(massptr_aer(ll,n,itype,iphase),k,m) +! number mixing ratios (particles/mole-air) are in +! rsub(numptr_aer(n,itype,iphase),k,m) +! these values are over-written with new values +! the following are also updated: +! adrydens_sub(n,itype,k,m), admeandry_sub(n,itype,k,m), +! awetdens_sub(n,itype,k,m), admeanwet_sub(n,itype,k,m) +! +! particle sizes are in cm +! +! input parameters +! iflag = 1 - do transfer after trace-gas condensation/evaporation +! = 2 - do transfer after aqueous chemistry +! = -1/-2 - do some "first entry" tasks for the iflag=+1/+2 cases +! iclm, jclm, k = current i,j,k indices +! m = current subarea index +! drymass_pregrow(n,itype) = dry-mass (g/mole-air) for section n +! before the growth +! drymass_aftgrow(n,itype) = dry-mass (g/mole-air) for section n +! after the growth but before inter-section transfer +! drydens_pregrow(n,itype) = dry-density (g/cm3) for section n +! before the growth +! drydens_aftgrow(n,itype) = dry-density (g/cm3) for section n +! after the growth but before inter-section transfer +! (drymass_pregrow and drydens_pregrow are not used by the moving-center +! algorithm, but would be needed for other sectional algorithms) +! +! this routine is the top level module for the post-october-2003 code +! and will do either moving-center or mass-number advection +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, k, m + +! local variables + integer idiag_movesect, iphase, itype, & + l, ll, llhysw, llwater, lnew, lold, l3, & + method_movesect, n, nnew, nold + integer nnewsave(2,maxd_asize) + + real densdefault, densh2o, smallmassaa, smallmassbb + real delta_water_conform1, delta_numb_conform1 + + real drydenspp(maxd_asize), drydensxx0(maxd_asize), & + drydensxx(maxd_asize), drydensyy(maxd_asize) + real drymasspp(maxd_asize), drymassxx0(maxd_asize), & + drymassxx(maxd_asize), drymassyy(maxd_asize) + real dryvolxx(maxd_asize), dryvolyy(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize), & + rmassyy(maxd_acomp+2,maxd_asize) + real rnumbpp(maxd_asize), rnumbxx0(maxd_asize), & + rnumbxx(maxd_asize), rnumbyy(maxd_asize) + real specdensxx(maxd_acomp), specmwxx(maxd_acomp) + real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize) + real wetvolxx(maxd_asize), wetvolyy(maxd_asize) + real wetmassxx(maxd_asize), wetmassyy(maxd_asize) + + character*160 msg + + +! +! check for valid inputs +! + if (msectional .le. 0) return + if (ntype_aer .le. 0) return + if (nphase_aer .le. 0) return + +! +! run diagnostic tests +! (these will only be run for certain values of idiag_movesect +! rce 2004-nov-29 - to avoid recursion, test_move_sections +! is now called from mosaic_driver +! +! call test_move_sections( iflag, iclm, jclm, k, m ) + + +! get "method_movesect" from digits 1-2 of msectional (treat 1-9 as 10) + method_movesect = mod( msectional, 100 ) + if (method_movesect .le. 10) method_movesect = 10 + +! get "idiag_movesect" from digits 3-4 of msectional + idiag_movesect = mod( msectional, 10000 )/100 + + if ((method_movesect .eq. 10) .or. & + (method_movesect .eq. 11) .or. & + (method_movesect .eq. 20) .or. & + (method_movesect .eq. 21) .or. & + (method_movesect .eq. 30) .or. & + (method_movesect .eq. 31)) then + continue + else if ((method_movesect .eq. 19) .or. & + (method_movesect .eq. 29) .or. & + (method_movesect .eq. 39)) then + return + else + msg = '*** subr move_sections error - ' // & + 'illegal value for msectional' + call peg_error_fatal( lunerr, msg ) + end if + + if (iabs(iflag) .eq. 1) then + iphase = ai_phase + else if (iabs(iflag) .eq. 2) then + iphase = cw_phase + if (nphase_aer .lt. 2) then + msg = '*** subr move_sections error - ' // & + 'iflag=2 (after aqueous chemistry) but nphase_aer < 2' + call peg_error_fatal( lunerr, msg ) + else if (cw_phase .ne. 2) then + msg = '*** subr move_sections error - ' // & + 'iflag=2 (after aqueous chemistry) but cw_phase .ne. 2' + call peg_error_fatal( lunerr, msg ) + end if + else + msg = '*** subr move_sections error - ' // & + 'iabs(iflag) must be 1 or 2' + call peg_error_fatal( lunerr, msg ) + end if + + +! when iflag=-1/-2, call move_sections_checkptrs then return +! if ((ncorecnt .le. 0) .and. (k .le. 1)) then + if (iflag .le. 0) then + write(msg,9040) 'method', method_movesect + call peg_message( lunout, msg ) + write(msg,9040) 'idiag ', idiag_movesect + call peg_message( lunout, msg ) + call move_sections_checkptrs( iflag, iclm, jclm, k, m ) + return + end if +9040 format( '*** subr move_sections - ', a, ' =', i6 ) + +! diagnostics + if (idiag_movesect .eq. 70) then + msg = ' ' + call peg_message( lunout, msg ) + write(msg,9060) iclm, jclm, k, m, msectional + call peg_message( lunout, msg ) + end if +9060 format( '*** subr move_sections diagnostics i,j,k,m,msect =', 4i4, i6 ) + + + densdefault = 2.0 + densh2o = 1.0 + +! if bin mass mixrat < smallmassaa (1.e-20 g/mol), then assume no growth +! AND no water AND conform number so that size is within bin limits + smallmassaa = 1.0e-20 +! if bin mass OR volume mixrat < smallmassbb (1.e-30 g/mol), then +! assume default density to avoid divide by zero + smallmassbb = 1.0e-30 + + +! process each type, one at a time + do 1900 itype = 1, ntype_aer + + if (nsize_aer(itype) .le. 0) goto 1900 + + call move_sections_initial_conform( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drydenspp, drymasspp, rnumbpp, & + drydensxx0, drymassxx0, rnumbxx0, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + specmwxx, specdensxx ) + + if (method_movesect .le. 19) then + call move_sections_calc_movingcenter( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + xferfracvol, xferfracnum ) + else + call move_sections_calc_masnumadvect( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + drydenspp, drymasspp, rnumbpp, & + drydensxx0, drymassxx0, rnumbxx0, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + xferfracvol, xferfracnum ) + end if + + call move_sections_apply_moves( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drydenspp, drymasspp, rnumbpp, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy, & + xferfracvol, xferfracnum ) + +! rce 08-nov-2004 - this call is new (and perhaps temporary) +! rce 05-jul-2005 - do n1_inflow for aerchem growth but not for cldchem + if ((apply_n1_inflow .eq. 1) .and. & + (iphase .eq. ai_phase)) then + call move_sections_apply_n1_inflow( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy, & + xferfracvol, xferfracnum, & + specmwxx, specdensxx ) + end if + +! call move_sections_final_conform( & +! iflag, iclm, jclm, k, m, iphase, itype ) + +1900 continue + + return + end subroutine move_sections + + +!----------------------------------------------------------------------- + subroutine move_sections_initial_conform( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drydenspp, drymasspp, rnumbpp, & + drydensxx0, drymassxx0, rnumbxx0, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + specmwxx, specdensxx ) + +! +! routine does some initial tasks for the section movement +! load rmassxx & rnumbxx from rsub +! load specmwxx & specdensxx +! set drymassxx & dryvolxx from drymass_aftgrow & drydens_aftgrow, +! OR compute them from rmassxx, specmwxx, specdensxx if need be +! set wetmassxx & wetvolxx from dry values & water mass +! conform rnumbxx so that the mean particle size of each section +! (= dryvolxx/rnumbxx) is within the section limits +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + real densdefault, densh2o, smallmassaa, smallmassbb + real delta_water_conform1, delta_numb_conform1 + real drydenspp(maxd_asize), drydensxx0(maxd_asize), & + drydensxx(maxd_asize) + real drymasspp(maxd_asize), drymassxx0(maxd_asize), & + drymassxx(maxd_asize) + real dryvolxx(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize) + real rnumbpp(maxd_asize), rnumbxx0(maxd_asize), & + rnumbxx(maxd_asize) + real specdensxx(maxd_acomp), specmwxx(maxd_acomp) + real wetvolxx(maxd_asize) + real wetmassxx(maxd_asize) + + +! local variables + integer l, ll, lnew, lold, l3, n, nnew, nold + + real dummass, dumnum, dumnum_at_dhi, dumnum_at_dlo, dumr, & + dumvol, dumvol1p, dumwatrmass + + +! assure positive definite + do l = 1, ltot2 + rsub(l,k,m) = max( 0., rsub(l,k,m) ) + end do + +! load mixrats into working arrays and assure positive definite + llhysw = ncomp_plustracer_aer(itype) + 1 + llwater = ncomp_plustracer_aer(itype) + 2 + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_plustracer_aer(itype) + l = massptr_aer(ll,n,itype,iphase) + rmassxx(ll,n) = rsub(l,k,m) + end do + rmassxx(llhysw,n) = 0. + l = 0 + if (iphase .eq. ai_phase) l = hyswptr_aer(n,itype) + if (l .gt. 0) rmassxx(llhysw,n) = rsub(l,k,m) + rmassxx(llwater,n) = 0. + l = 0 + if (iphase .eq. ai_phase) l = waterptr_aer(n,itype) + if (l .gt. 0) rmassxx(llwater,n) = rsub(l,k,m) + + rnumbxx(n) = rsub(numptr_aer(n,itype,iphase),k,m) + rnumbxx0(n) = rnumbxx(n) + rnumbpp(n) = rnumbxx(n) + + drydenspp(n) = drydens_pregrow(n,itype) + drymasspp(n) = drymass_pregrow(n,itype) + + drydensxx(n) = drydens_aftgrow(n,itype) + drymassxx(n) = drymass_aftgrow(n,itype) + drydensxx0(n) = drydensxx(n) + drymassxx0(n) = drymassxx(n) + end do + +! load specmw and specdens also + do ll = 1, ncomp_plustracer_aer(itype) + specmwxx(ll) = mw_aer(ll,itype) + specdensxx(ll) = dens_aer(ll,itype) + end do + + delta_water_conform1 = 0.0 + delta_numb_conform1 = 0.0 + + + do 1390 n = 1, nsize_aer(itype) + +! +! if drydens_aftgrow < 0.1, then bin had state="no_aerosol" +! compute volume using default dry-densities, set water=0, +! and conform the number +! also do this if mass is extremely small (below smallmassaa) +! OR if drydens_aftgrow > 20 (which is unrealistic) +! + if ( (drydensxx(n) .lt. 0.1) .or. & + (drydensxx(n) .gt. 20.0) .or. & + (drymassxx(n) .le. smallmassaa) ) then + dummass = 0. + dumvol = 0. + do ll = 1, ncomp_aer(itype) + dumr = rmassxx(ll,n)*specmwxx(ll) + dummass = dummass + dumr + dumvol = dumvol + dumr/specdensxx(ll) + end do + drymassxx(n) = dummass + if (min(dummass,dumvol) .le. smallmassbb) then + drydensxx(n) = densdefault + dumvol = dummass/densdefault + dumnum = dummass/(volumcen_sect(n,itype)*densdefault) + else + drydensxx(n) = dummass/dumvol + dumnum = rnumbxx(n) + dumnum_at_dhi = dumvol/volumhi_sect(n,itype) + dumnum_at_dlo = dumvol/volumlo_sect(n,itype) + dumnum = max( dumnum_at_dhi, min( dumnum_at_dlo, dumnum ) ) + end if + delta_numb_conform1 = delta_numb_conform1 + dumnum - rnumbxx(n) + rnumbxx(n) = dumnum + rnumbpp(n) = rnumbxx(n) + delta_water_conform1 = delta_water_conform1 - rmassxx(llwater,n) + rmassxx(llwater,n) = 0. + end if + +! load dry/wet mass and volume into "xx" arrays +! which hold values before inter-mode transferring + dryvolxx(n) = drymassxx(n)/drydensxx(n) + dumwatrmass = rmassxx(llwater,n)*mw_water_aer + wetmassxx(n) = drymassxx(n) + dumwatrmass + wetvolxx(n) = dryvolxx(n) + dumwatrmass/densh2o + +1390 continue + + return + end subroutine move_sections_initial_conform + + +!----------------------------------------------------------------------- + subroutine move_sections_calc_movingcenter( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + xferfracvol, xferfracnum ) +! +! routine calculates section movements for the moving-center approach +! +! material in section n will be transfered to section nnewsave(1,n) +! +! the nnewsave are calculated here +! the actual transfer is done in another routine +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + integer nnewsave(2,maxd_asize) + real densdefault, densh2o, smallmassaa, smallmassbb + real drydensxx(maxd_asize) + real drymassxx(maxd_asize) + real dryvolxx(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize) + real rnumbxx(maxd_asize) + real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize) + real wetmassxx(maxd_asize) + real wetvolxx(maxd_asize) + +! local variables + integer ll, n, ndum, nnew, nold + real dumnum, dumvol, dumvol1p, sixoverpi, third + character*160 msg + + + sixoverpi = 6.0/pi + third = 1.0/3.0 + +! +! compute mean size after growth (and corresponding section) +! particles in section n will be transferred to section nnewsave(1,n) +! + do 1390 n = 1, nsize_aer(itype) + + nnew = n + +! don't bother to transfer bins whose mass is extremely small + if (drymassxx(n) .le. smallmassaa) goto 1290 + + dumvol = dryvolxx(n) + dumnum = rnumbxx(n) + +! check for number so small that particle volume is +! above that of largest section + if (dumnum .le. dumvol/volumhi_sect(nsize_aer(itype),itype)) then + nnew = nsize_aer(itype) + goto 1290 +! or below that of smallest section + else if (dumnum .ge. dumvol/volumlo_sect(1,itype)) then + nnew = 1 + goto 1290 + end if + +! dumvol1p is mean particle volume (cm3) for the section + dumvol1p = dumvol/dumnum + if (dumvol1p .gt. volumhi_sect(n,itype)) then + do while ( (nnew .lt. nsize_aer(itype)) .and. & + (dumvol1p .gt. volumhi_sect(nnew,itype)) ) + nnew = nnew + 1 + end do + + else if (dumvol1p .lt. volumlo_sect(n,itype)) then + do while ( (nnew .gt. 1) .and. & + (dumvol1p .lt. volumlo_sect(nnew,itype)) ) + nnew = nnew - 1 + end do + + end if + +1290 nnewsave(1,n) = nnew + nnewsave(2,n) = 0 + + xferfracvol(1,n) = 1.0 + xferfracvol(2,n) = 0.0 + xferfracnum(1,n) = 1.0 + xferfracnum(2,n) = 0.0 + +1390 continue + + +! diagnostic output +! output nnewsave values when msectional=7xxx + if (idiag_movesect .eq. 70) then + ndum = 0 + do n = 1, nsize_aer(itype) + if (nnewsave(1,n) .ne. n) ndum = ndum + 1 + end do + if (ndum .gt. 0) then + write(msg,97751) 'YES', iclm, jclm, k, m, & + ndum, (nnewsave(1,n), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + else + write(msg,97751) 'NO ', iclm, jclm, k, m, & + ndum, (nnewsave(1,n), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + end if + end if +97751 format( 'movesect', a, 4i3, 3x, i3, 3x, 14i3 ) + + return + end subroutine move_sections_calc_movingcenter + + +!----------------------------------------------------------------------- + subroutine move_sections_calc_masnumadvect( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + drydenspp, drymasspp, rnumbpp, & + drydensxx0, drymassxx0, rnumbxx0, & + drydensxx, drymassxx, dryvolxx, rmassxx, rnumbxx, & + wetmassxx, wetvolxx, & + xferfracvol, xferfracnum ) +! +! routine calculates section movements for the mass-number-advection approach +! +! material in section n will be transfered to sections +! nnewsave(1,n) and nnewsave(2,n) +! the fractions of mass/volume transfered to each are +! xferfracvol(1,n) and xferfracvol(2,n) +! the fractions of number transfered to each are +! xferfracnum(1,n) and xferfracnum(2,n) +! +! the nnewsave, xferfracvol, and xferfracnum are calculated here +! the actual transfer is done in another routine +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + integer nnewsave(2,maxd_asize) + + real densdefault, densh2o, smallmassaa, smallmassbb + real drydenspp(maxd_asize), drydensxx0(maxd_asize), & + drydensxx(maxd_asize) + real drymasspp(maxd_asize), drymassxx0(maxd_asize), & + drymassxx(maxd_asize) + real dryvolxx(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize) + real rnumbpp(maxd_asize), rnumbxx0(maxd_asize), & + rnumbxx(maxd_asize) + real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize) + real wetvolxx(maxd_asize) + real wetmassxx(maxd_asize) + +! local variables + integer ierr, n, nnew, nnew2 + integer iforce_movecenter(maxd_asize) + + real dum1, dum2, dum3 + real dumaa, dumbb, dumgamma, dumratio + real dumfracnum, dumfracvol + real dumntot + real dumv + real dumvbar_aft, dumvbar_pre + real dumvcutlo_nnew_pre, dumvcuthi_nnew_pre + real dumvlo_pre, dumvhi_pre, dumvdel_pre + real dumvtot_aft, dumvtot_pre + real dumzlo, dumzhi + real sixoverpi, third + + character*4 dumch4 + character*1 dumch1 + character*160 msg + + + sixoverpi = 6.0/pi + third = 1.0/3.0 + +! +! compute mean size after growth (and corresponding section) +! some of the particles in section n will be transferred to section nnewsave(1,n) +! +! if the aftgrow mass is extremely small, +! OR if the aftgrow mean size is outside of +! [dlo_sect(1,itype), dhi_sect(nsize_aer(itype),itype)] +! then use the moving-center method_movesect for this bin +! (don't try to compute the pregrow within-bin distribution) +! + do 3900 n = 1, nsize_aer(itype) + + nnew = n + iforce_movecenter(n) = 0 + + xferfracvol(1,n) = 1.0 + xferfracvol(2,n) = 0.0 + xferfracnum(1,n) = 1.0 + xferfracnum(2,n) = 0.0 + + dumvtot_aft = -1.0 + dumvtot_pre = -1.0 + dumvbar_aft = -1.0 + dumvbar_pre = -1.0 + dumvlo_pre = -1.0 + dumvhi_pre = -1.0 + dumgamma = -1.0 + dumratio = -1.0 + dumvcutlo_nnew_pre = volumlo_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft) + dumvcuthi_nnew_pre = volumhi_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft) + dumfracvol = -1.0 + dumfracnum = -1.0 + +! don't bother to transfer bins whose mass is extremely small + if (drymassxx(n) .le. smallmassaa) then + iforce_movecenter(n) = 1 + goto 1290 + end if + + dumvtot_aft = dryvolxx(n) + dumntot = rnumbxx(n) + +! check for particle volume above that of largest section +! or below that of smallest section + if (dumntot .le. dumvtot_aft/volumhi_sect(nsize_aer(itype),itype)) then + nnew = nsize_aer(itype) + iforce_movecenter(n) = 2 + goto 1290 + else if (dumntot .ge. dumvtot_aft/volumlo_sect(1,itype)) then + nnew = 1 + iforce_movecenter(n) = 3 + goto 1290 + end if + +! dumvbar_aft is mean particle volume (cm3) for the section +! find the section that encloses this volume + dumvbar_aft = dumvtot_aft/dumntot + if (dumvbar_aft .gt. volumhi_sect(n,itype)) then + do while ( (nnew .lt. nsize_aer(itype)) .and. & + (dumvbar_aft .gt. volumhi_sect(nnew,itype)) ) + nnew = nnew + 1 + end do + + else if (dumvbar_aft .lt. volumlo_sect(n,itype)) then + do while ( (nnew .gt. 1) .and. & + (dumvbar_aft .lt. volumlo_sect(nnew,itype)) ) + nnew = nnew - 1 + end do + + end if + +1290 nnewsave(1,n) = nnew + nnewsave(2,n) = 0 + + if (iforce_movecenter(n) .gt. 0) goto 3700 + + +! if drydenspp (pregrow) < 0.1 (because bin had state="no_aerosol" before +! growth was computed, so its initial mass was very small) +! then use the moving-center method_movesect for this bin +! (don't try to compute the pregrow within-bin distribution) +! also do this if pregrow mass is extremely small (below smallmassaa) +! OR if drydenspp > 20 (unphysical) + if ( (drydenspp(n) .lt. 0.1) .or. & + (drydenspp(n) .gt. 20.0) .or. & + (drymasspp(n) .le. smallmassaa) ) then + iforce_movecenter(n) = 11 + goto 3700 + end if + + dumvtot_pre = drymasspp(n)/drydenspp(n) + + dumvlo_pre = volumlo_sect(n,itype) + dumvhi_pre = volumhi_sect(n,itype) + dumvdel_pre = dumvhi_pre - dumvlo_pre + +! if the pregrow mean size is outside of OR very close to the bin limits, +! then use moving-center approach for this bin + dumv = dumvhi_pre - 0.01*dumvdel_pre + if (dumntot .le. dumvtot_pre/dumv) then + iforce_movecenter(n) = 12 + goto 3700 + end if + dumv = dumvlo_pre + 0.01*dumvdel_pre + if (dumntot .ge. dumvtot_pre/dumv) then + iforce_movecenter(n) = 13 + goto 3700 + end if + +! calculate the pregrow within-section size distribution + dumvbar_pre = dumvtot_pre/dumntot + dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0 + dumratio = dumvbar_pre/dumvlo_pre + + if (dumratio .le. (1.0001 + dumgamma/3.0)) then + dumv = dumvlo_pre + 3.0*(dumvbar_pre-dumvlo_pre) + dumvhi_pre = min( dumvhi_pre, dumv ) + dumvdel_pre = dumvhi_pre - dumvlo_pre + dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0 + dumratio = dumvbar_pre/dumvlo_pre + else if (dumratio .ge. (0.9999 + dumgamma*2.0/3.0)) then + dumv = dumvhi_pre + 3.0*(dumvbar_pre-dumvhi_pre) + dumvlo_pre = max( dumvlo_pre, dumv ) + dumvdel_pre = dumvhi_pre - dumvlo_pre + dumgamma = (dumvhi_pre/dumvlo_pre) - 1.0 + dumratio = dumvbar_pre/dumvlo_pre + end if + + dumbb = (dumratio - 1.0 - 0.5*dumgamma)*12.0/dumgamma + dumaa = 1.0 - 0.5*dumbb + +! calculate pregrow volumes corresponding to the nnew +! section boundaries + dumvcutlo_nnew_pre = volumlo_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft) + dumvcuthi_nnew_pre = volumhi_sect(nnew,itype)*(dumvbar_pre/dumvbar_aft) + +! if the [dumvlo_pre, dumvhi_pre] falls completely within +! the [dumvcutlo_nnew_pre, dumvcuthi_nnew_pre] interval, +! then all mass and number go to nnew + if (nnew .eq. 1) then + if (dumvhi_pre .le. dumvcuthi_nnew_pre) then + iforce_movecenter(n) = 21 + else + nnew2 = nnew + 1 + end if + else if (nnew .eq. nsize_aer(itype)) then + if (dumvlo_pre .ge. dumvcutlo_nnew_pre) then + iforce_movecenter(n) = 22 + else + nnew2 = nnew - 1 + end if + else + if ((dumvlo_pre .ge. dumvcutlo_nnew_pre) .and. & + (dumvhi_pre .le. dumvcuthi_nnew_pre)) then + iforce_movecenter(n) = 23 + else if (dumvlo_pre .lt. dumvcutlo_nnew_pre) then + nnew2 = nnew - 1 + else + nnew2 = nnew + 1 + end if + end if + if (iforce_movecenter(n) .gt. 0) goto 3700 + +! calculate the fraction of ntot and vtot that are within +! the [dumvcutlo_nnew_pre, dumvcuthi_nnew_pre] interval + dumzlo = (dumvcutlo_nnew_pre - dumvlo_pre)/dumvdel_pre + dumzhi = (dumvcuthi_nnew_pre - dumvlo_pre)/dumvdel_pre + dumzlo = max( dumzlo, 0.0 ) + dumzhi = min( dumzhi, 1.0 ) + dum1 = dumzhi - dumzlo + dum2 = (dumzhi**2 - dumzlo**2)*0.5 + dum3 = (dumzhi**3 - dumzlo**3)/3.0 + dumfracnum = dumaa*dum1 + dumbb*dum2 + dumfracvol = (dumvlo_pre/dumvbar_pre) * (dumaa*dum1 + & + (dumaa*dumgamma + dumbb)*dum2 + (dumbb*dumgamma)*dum3) + + if ((dumfracnum .le. 0.0) .or. (dumfracvol .le. 0.0)) then + iforce_movecenter(n) = 31 + nnewsave(1,n) = nnew2 + else if ((dumfracnum .ge. 1.0) .or. (dumfracvol .ge. 1.0)) then + iforce_movecenter(n) = 32 + end if + if (iforce_movecenter(n) .gt. 0) goto 3700 + + nnewsave(2,n) = nnew2 + + xferfracvol(1,n) = dumfracvol + xferfracvol(2,n) = 1.0 - dumfracvol + xferfracnum(1,n) = dumfracnum + xferfracnum(2,n) = 1.0 - dumfracnum + +3700 continue + +! output nnewsave values when msectional=7xxx + if (idiag_movesect .ne. 70) goto 3800 + + if (nnewsave(2,n) .eq. 0) then + if (nnewsave(1,n) .eq. 0) then + dumch4 = 'NO X' + else if (nnewsave(1,n) .eq. n) then + dumch4 = 'NO A' + else + dumch4 = 'YESA' + end if + else if (nnewsave(1,n) .eq. 0) then + if (nnewsave(2,n) .eq. n) then + dumch4 = 'NO B' + else + dumch4 = 'YESB' + end if + else if (nnewsave(2,n) .eq. n) then + if (nnewsave(1,n) .eq. n) then + dumch4 = 'NO Y' + else + dumch4 = 'YESC' + end if + else if (nnewsave(1,n) .eq. n) then + dumch4 = 'YESD' + else + dumch4 = 'YESE' + end if + + dumch1 = '+' + if (drymasspp(n) .gt. drymassxx(n)) dumch1 = '-' + + msg = ' ' + call peg_message( lunout, msg ) + write(msg,97010) dumch1, dumch4, iclm, jclm, k, m, & + n, nnewsave(1,n), nnewsave(2,n), iforce_movecenter(n) + call peg_message( lunout, msg ) + write(msg,97020) 'pre mass, dens ', & + drymasspp(n), drydenspp(n) + call peg_message( lunout, msg ) + write(msg,97020) 'aft mass, dens, numb', & + drymassxx(n), drydensxx(n), rnumbxx(n) + call peg_message( lunout, msg ) + if ((drydensxx(n) .ne. drydensxx0(n)) .or. & + (drymassxx(n) .ne. drymassxx0(n)) .or. & + (rnumbxx(n) .ne. rnumbxx0(n) )) then + write(msg,97020) 'aft0 mas, dens, numb', & + drymassxx0(n), drydensxx0(n), rnumbxx0(n) + call peg_message( lunout, msg ) + end if + write(msg,97020) 'vlop0, vbarp, vhip0', & + volumlo_sect(n,itype), dumvbar_pre, volumhi_sect(n,itype) + call peg_message( lunout, msg ) + write(msg,97020) 'vlop , vbarp, vhip ', & + dumvlo_pre, dumvbar_pre, dumvhi_pre + call peg_message( lunout, msg ) + write(msg,97020) 'vloax, vbarax, vhiax', & + dumvcutlo_nnew_pre, dumvbar_pre, dumvcuthi_nnew_pre + call peg_message( lunout, msg ) + write(msg,97020) 'vloa0, vbara, vhia0', & + volumlo_sect(nnew,itype), dumvbar_aft, volumhi_sect(nnew,itype) + call peg_message( lunout, msg ) + write(msg,97020) 'dumfrvol, num, ratio', & + dumfracvol, dumfracnum, dumratio + call peg_message( lunout, msg ) + write(msg,97020) 'frvol,num1; vol,num2', & + xferfracvol(1,n), xferfracnum(1,n), & + xferfracvol(2,n), xferfracnum(2,n) + call peg_message( lunout, msg ) + +97010 format( 'movesect', 2a, 7x, 4i3, 4x, & + 'n,nnews', 3i3, 4x, 'iforce', i3.2 ) +97020 format( a, 1p, 4e13.4 ) + +3800 continue + +! +! check for legal combinations of nnewsave(1,n) & nnewsave(2,n) +! error if +! nnew1 == nnew2 +! both are non-zero AND iabs(nnew1-nnew2) != 1 + ierr = 0 + if (nnewsave(1,n) .eq. nnewsave(2,n)) then + ierr = 1 + else if (nnewsave(1,n)*nnewsave(2,n) .ne. 0) then + if (iabs(nnewsave(1,n)-nnewsave(2,n)) .ne. 1) ierr = 1 + end if + if (ierr .gt. 0) then + write(msg,97010) 'E', 'RROR', iclm, jclm, k, m, & + n, nnewsave(1,n), nnewsave(2,n), iforce_movecenter(n) + call peg_message( lunout, msg ) + end if + + +! if method_movesect == 30-31 then force moving center +! this is just for testing purposes + if ((method_movesect .ge. 30) .and. (method_movesect .le. 39)) then + nnewsave(1,n) = nnew + nnewsave(2,n) = 0 + xferfracvol(1,n) = 1.0 + xferfracvol(2,n) = 0.0 + xferfracnum(1,n) = 1.0 + xferfracnum(2,n) = 0.0 + end if + +3900 continue + + return + end subroutine move_sections_calc_masnumadvect + + +!----------------------------------------------------------------------- + subroutine move_sections_apply_moves( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drydenspp, drymasspp, rnumbpp, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy, & + xferfracvol, xferfracnum ) +! +! routine performs the actual transfer of aerosol number and mass +! between sections +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + integer nnewsave(2,maxd_asize) + + real densdefault, densh2o, smallmassaa, smallmassbb + real delta_water_conform1, delta_numb_conform1 + real drydenspp(maxd_asize) + real drymasspp(maxd_asize) + real drymassxx(maxd_asize), drymassyy(maxd_asize) + real dryvolxx(maxd_asize), dryvolyy(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize), & + rmassyy(maxd_acomp+2,maxd_asize) + real rnumbpp(maxd_asize) + real rnumbxx(maxd_asize), rnumbyy(maxd_asize) + real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize) + real wetvolxx(maxd_asize), wetvolyy(maxd_asize) + real wetmassxx(maxd_asize), wetmassyy(maxd_asize) + +! local variables + integer jj, l, ll, n, ndum, nnew, nold + integer jja, jjb, jjc + + real delta_numb_conform2, & + dumbot, dumnum, dumnum_at_dhi, dumnum_at_dlo, & + dumvol, dumvol1p, dumxfvol, dumxfnum, sixoverpi, third + real dumpp(maxd_asize), dumxx(maxd_asize), dumyy(maxd_asize), & + dumout(maxd_asize) + + character*160 msg + character*8 dumch8 + character*4 dumch4 + + + sixoverpi = 6.0/pi + third = 1.0/3.0 + +! +! initialize "yy" arrays that hold values after inter-mode transferring +! "yy" = "xx" for sections that do not move at all +! "yy" = 0.0 for sections that do move (partially or completely) +! + do 1900 n = 1, nsize_aer(itype) + + if ( (nnewsave(1,n) .eq. n) .and. & + (nnewsave(2,n) .eq. 0) ) then +! if nnew == n, then material in section n will not be transferred, and +! section n will contain its initial material plus any material +! transferred from other sections +! so initialize "yy" arrays with "xx" values + drymassyy(n) = drymassxx(n) + dryvolyy(n) = dryvolxx(n) + wetmassyy(n) = wetmassxx(n) + wetvolyy(n) = wetvolxx(n) + rnumbyy(n) = rnumbxx(n) + do ll = 1, ncomp_plustracer_aer(itype) + 2 + rmassyy(ll,n) = rmassxx(ll,n) + end do + + else +! if nnew .ne. n, then material in section n will be transferred, and +! section n will only contain material that is transferred from +! other sections +! so initialize "yy" arrays to zero + drymassyy(n) = 0.0 + dryvolyy(n) = 0.0 + wetmassyy(n) = 0.0 + wetvolyy(n) = 0.0 + rnumbyy(n) = 0.0 + do ll = 1, ncomp_plustracer_aer(itype) + 2 + rmassyy(ll,n) = 0.0 + end do + + end if + +1900 continue + +! +! do the transfer of mass and number +! + do 2900 nold = 1, nsize_aer(itype) + + if ( (nnewsave(1,nold) .eq. nold) .and. & + (nnewsave(2,nold) .eq. 0 ) ) goto 2900 + + do 2800 jj = 1, 2 + + nnew = nnewsave(jj,nold) + if (nnew .le. 0) goto 2800 + + dumxfvol = xferfracvol(jj,nold) + dumxfnum = xferfracnum(jj,nold) + + do ll = 1, ncomp_plustracer_aer(itype) + 2 + rmassyy(ll,nnew) = rmassyy(ll,nnew) + rmassxx(ll,nold)*dumxfvol + end do + rnumbyy(nnew) = rnumbyy(nnew) + rnumbxx(nold)*dumxfnum + + drymassyy(nnew) = drymassyy(nnew) + drymassxx(nold)*dumxfvol + dryvolyy(nnew) = dryvolyy(nnew) + dryvolxx(nold)*dumxfvol + wetmassyy(nnew) = wetmassyy(nnew) + wetmassxx(nold)*dumxfvol + wetvolyy(nnew) = wetvolyy(nnew) + wetvolxx(nold)*dumxfvol + +2800 continue + +2900 continue + +! +! transfer among sections is completed +! - check for conservation of mass/volume/number +! - conform number again +! - compute/store densities and mean sizes +! - if k=1, save values for use by dry deposition routine +! - copy new mixrats back to rsub array +! + call move_sections_conserve_check( & + 1, iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy ) + + delta_numb_conform2 = 0.0 + + do 3900 n = 1, nsize_aer(itype) + + dumvol = dryvolyy(n) + if (min(drymassyy(n),dumvol) .le. smallmassbb) then + dumvol = drymassyy(n)/densdefault + dumnum = drymassyy(n)/(volumlo_sect(n,itype)*densdefault) + delta_numb_conform2 = delta_numb_conform2 + dumnum - rnumbyy(n) + rnumbyy(n) = dumnum + adrydens_sub(n,itype,k,m) = densdefault + awetdens_sub(n,itype,k,m) = densdefault + admeandry_sub(n,itype,k,m) = dcen_sect(n,itype) + admeanwet_sub(n,itype,k,m) = dcen_sect(n,itype) + else + dumnum = rnumbyy(n) + dumnum_at_dhi = dumvol/volumhi_sect(n,itype) + dumnum_at_dlo = dumvol/volumlo_sect(n,itype) + dumnum = max( dumnum_at_dhi, min( dumnum_at_dlo, dumnum ) ) + delta_numb_conform2 = delta_numb_conform2 + dumnum - rnumbyy(n) + rnumbyy(n) = dumnum + adrydens_sub(n,itype,k,m) = drymassyy(n)/dumvol + dumvol1p = dumvol/dumnum + admeandry_sub(n,itype,k,m) = (dumvol1p*sixoverpi)**third + awetdens_sub(n,itype,k,m) = wetmassyy(n)/wetvolyy(n) + dumvol1p = wetvolyy(n)/dumnum + admeanwet_sub(n,itype,k,m) = min( 100.*dcen_sect(n,itype), & + (dumvol1p*sixoverpi)**third ) + end if + aqvoldry_sub(n,itype,k,m) = dumvol + aqmassdry_sub(n,itype,k,m) = drymassyy(n) + +! if (k .eq. 1) then +! awetdens_sfc(n,itype,iclm,jclm) = awetdens_sub(n,itype,k,m) +! admeanwet_sfc(n,itype,iclm,jclm) = admeanwet_sub(n,itype,k,m) +! end if + + do ll = 1, ncomp_plustracer_aer(itype) + l = massptr_aer(ll,n,itype,iphase) + rsub(l,k,m) = rmassyy(ll,n) + end do + l = 0 + if (iphase .eq. ai_phase) then + l = waterptr_aer(n,itype) + if (l .gt. 0) rsub(l,k,m) = rmassyy(llwater,n) + l = hyswptr_aer(n,itype) + if (l .gt. 0) rsub(l,k,m) = rmassyy(llhysw,n) + end if + rsub(numptr_aer(n,itype,iphase),k,m) = rnumbyy(n) + +3900 continue + + delta_numb_conform1 = delta_numb_conform1 + delta_numb_conform2 + + call move_sections_conserve_check( & + 2, iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy ) + + +! diagnostic output +! output nnewsave values when msectional=7xxx + if (idiag_movesect .ne. 70) goto 4900 + + ndum = 0 + do n = 1, nsize_aer(itype) + if (nnewsave(1,n)+nnewsave(2,n) .ne. n) ndum = ndum + 1 + end do +! if (ndum .gt. 0) then +! write(msg,97010) 'SOME', iclm, jclm, k, m, & +! ndum, (nnewsave(1,n), nnewsave(2,n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) +! else +! write(msg,97010) 'NONE', iclm, jclm, k, m, & +! ndum, (nnewsave(1,n), nnewsave(2,n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) +! end if + + dumch4 = 'NONE' + if (ndum .gt. 0) dumch4 = 'SOME' + msg = ' ' + call peg_message( lunout, msg ) + write(msg,97010) dumch4, iclm, jclm, k, m, ndum + call peg_message( lunout, msg ) + do jjb = 1, nsize_aer(itype), 10 + jjc = min( jjb+9, nsize_aer(itype) ) + write(msg,97011) (nnewsave(1,n), nnewsave(2,n), n=jjb,jjc) + call peg_message( lunout, msg ) + end do + +! write(msg,97020) 'rnumbold', (rnumbxx(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) +! write(msg,97020) 'rnumbnew', (rnumbyy(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) + +! write(msg,97020) 'drvolold', (dryvolxx(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) +! write(msg,97020) 'drvolnew', (dryvolyy(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) + + dumbot = log( volumhi_sect(1,itype)/volumlo_sect(1,itype) ) + do n = 1, nsize_aer(itype) + dumpp(n) = -9.99 + dumxx(n) = -9.99 + dumyy(n) = -9.99 + if ( (drydenspp(n) .gt. 0.5) .and. & + (drymasspp(n) .gt. smallmassaa) ) then + dumvol = drymasspp(n)/drydenspp(n) + if ((rnumbpp(n) .ge. 1.0e-35) .and. & + (dumvol .ge. 1.0e-35)) then + dumvol1p = dumvol/rnumbpp(n) + dumpp(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot + end if + end if + if ((rnumbxx(n) .ge. 1.0e-35) .and. & + (dryvolxx(n) .ge. 1.0e-35)) then + dumvol1p = dryvolxx(n)/rnumbxx(n) + dumxx(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot + end if + if ((rnumbyy(n) .ge. 1.0e-35) .and. & + (dryvolyy(n) .ge. 1.0e-35)) then + dumvol1p = dryvolyy(n)/rnumbyy(n) + dumyy(n) = 1.0 + log(dumvol1p/volumlo_sect(1,itype))/dumbot + end if + end do + +! write(msg,97030) 'lnvolold', (dumxx(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) +! write(msg,97030) 'lnvolnew', (dumyy(n), n=1,nsize_aer(itype)) +! call peg_message( lunout, msg ) + + do jja = 1, 7 + if (jja .eq. 1) then + dumch8 = 'rnumbold' + dumout(:) = rnumbxx(:) + else if (jja .eq. 2) then + dumch8 = 'rnumbnew' + dumout(:) = rnumbyy(:) + else if (jja .eq. 3) then + dumch8 = 'drvolold' + dumout(:) = dryvolxx(:) + else if (jja .eq. 4) then + dumch8 = 'drvolnew' + dumout(:) = dryvolyy(:) + else if (jja .eq. 5) then + dumch8 = 'lnvolold' + dumout(:) = dumxx(:) + else if (jja .eq. 6) then + dumch8 = 'lnvolnew' + dumout(:) = dumyy(:) + else if (jja .eq. 7) then + dumch8 = 'lnvolpre' + dumout(:) = dumpp(:) + end if + do jjb = 1, nsize_aer(itype), 10 + jjc = min( jjb+9, nsize_aer(itype) ) + if (jja .le. 4) then + write(msg,97020) dumch8, (dumout(n), n=jjb,jjc) + else + write(msg,97030) dumch8, (dumout(n), n=jjb,jjc) + end if + call peg_message( lunout, msg ) + dumch8 = ' ' + end do + end do + +!97010 format( / 'movesectapply', a, 4i3, 3x, i3 / 5x, 10(3x,2i3) ) +!97020 format( a, 1p, 10e9.1 / (( 8x, 1p, 10e9.1 )) ) +!97030 format( a, 10f9.3 / (( 8x, 10f9.3 )) ) +97010 format( 'movesectapply', a, 4i3, 3x, i3 ) +97011 format( 5x, 10(3x,2i3) ) +97020 format( a, 1p, 10e9.1 ) +97030 format( a, 10f9.3 ) + +4900 continue + return + end subroutine move_sections_apply_moves + + +!----------------------------------------------------------------------- +! rce 08-nov-2004 - this routine is new (and perhaps temporary) +! + subroutine move_sections_apply_n1_inflow( & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy, & + xferfracvol, xferfracnum, & + specmwxx, specdensxx ) +! +! routine applies an ad_hoc correction to bin 1 to account for +! growth of smaller particles (which are not simulated) growing into +! bin 1 +! the correction to particle number balances the loss of particles from +! bin 1 to larger bins by growth +! the correction to mass assumes that the particles coming into bin 1 +! are slightly larger than dlo_sect(1) +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + integer nnewsave(2,maxd_asize) + + real densdefault, densh2o, smallmassaa, smallmassbb + real delta_water_conform1, delta_numb_conform1 + real drymassxx(maxd_asize), drymassyy(maxd_asize) + real dryvolxx(maxd_asize), dryvolyy(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize), & + rmassyy(maxd_acomp+2,maxd_asize) + real rnumbxx(maxd_asize), rnumbyy(maxd_asize) + real xferfracvol(2,maxd_asize), xferfracnum(2,maxd_asize) + real wetvolxx(maxd_asize), wetvolyy(maxd_asize) + real wetmassxx(maxd_asize), wetmassyy(maxd_asize) + real specdensxx(maxd_acomp), specmwxx(maxd_acomp) + + +! local variables + integer jj, l, ll, n, nnew, nold + + real deltanum, deltavol, dumvol1p, dumxfvol, dumxfnum + + +! +! compute fraction of number transferred out of bin 1 by growth +! + nold = 1 + n = nold + if ( (nnewsave(1,nold) .eq. nold) .and. & + (nnewsave(2,nold) .eq. 0 ) ) goto 3900 + + dumxfnum = 0.0 + do 2800 jj = 1, 2 + nnew = nnewsave(jj,nold) + if (nnew .le. 0) goto 2800 + if (nnew .eq. nold) goto 2800 + dumxfnum = dumxfnum + xferfracnum(jj,nold) +2800 continue + +! +! compute "inflow" change to number and volume +! number change matches that lost by growth +! volume change assume inflow particles slightly bigger then dlo_sect +! + dumvol1p = 0.95*volumlo_sect(n,itype) + 0.05*volumhi_sect(n,itype) + deltanum = dumxfnum*rnumbxx(n) + deltavol = deltanum*dumvol1p + if (dumxfnum .le. 0.0) goto 3900 + if (deltanum .le. 0.0) goto 3900 + if (deltavol .le. 0.0) goto 3900 + +! +! increment the number and masses +! if the old dryvol (dryvolxx) > smallmassbb, then compute mass increment for +! each species from the old masses (rmassxx) +! otherwise only increment the first mass species +! + if (dryvolxx(n) .gt. smallmassbb) then + dumxfvol = deltavol/dryvolxx(n) + do ll = 1, ncomp_plustracer_aer(itype) + 2 + rmassyy(ll,n) = rmassyy(ll,n) + dumxfvol*rmassxx(ll,n) + end do + else + ll = 1 + rmassyy(ll,n) = rmassyy(ll,n) + deltavol*specdensxx(ll)/specmwxx(ll) + end if + rnumbyy(n) = rnumbyy(n) + deltanum + +! +! transfer results into rsub +! + do ll = 1, ncomp_plustracer_aer(itype) + l = massptr_aer(ll,n,itype,iphase) + rsub(l,k,m) = rmassyy(ll,n) + end do + if (iphase .eq. ai_phase) then + l = waterptr_aer(n,itype) + if (l .gt. 0) rsub(l,k,m) = rmassyy(llwater,n) + l = hyswptr_aer(n,itype) + if (l .gt. 0) rsub(l,k,m) = rmassyy(llhysw,n) + end if + rsub(numptr_aer(n,itype,iphase),k,m) = rnumbyy(n) + + +3900 continue + return + end subroutine move_sections_apply_n1_inflow + + +!----------------------------------------------------------------------- + subroutine move_sections_conserve_check( ipass, & + iflag, iclm, jclm, k, m, iphase, itype, & + method_movesect, idiag_movesect, llhysw, llwater, nnewsave, & + densdefault, densh2o, smallmassaa, smallmassbb, & + delta_water_conform1, delta_numb_conform1, & + drymassxx, dryvolxx, rmassxx, rnumbxx, wetmassxx, wetvolxx, & + drymassyy, dryvolyy, rmassyy, rnumbyy, wetmassyy, wetvolyy ) +! +! routine checks for conservation of number, mass, and volume +! by the move_sections algorithm +! +! ipass = 1 +! initialize all thesum(jj,ll) to zero +! computes thesum(1,ll) from rmassxx, rnumbxx, ... +! computes thesum(2,ll) from rmassyy, rnumbyy, ... +! compares thesum(1,ll) with thesum(2,ll) +! computes thesum(3,ll) from rsub before section movement +! ipass = 2 +! computes thesum(4,ll) from rsub after section movement +! compares thesum(3,ll) with thesum(4,ll) +! +! currently only implemented for condensational growth (iflag=1) +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer ipass, iflag, iclm, jclm, iphase, itype, k, & + m, method_movesect, idiag_movesect, llhysw, llwater + integer nnewsave(2,maxd_asize) + real densdefault, densh2o, smallmassaa, smallmassbb + real delta_water_conform1, delta_numb_conform1 + real drymassxx(maxd_asize), drymassyy(maxd_asize) + real dryvolxx(maxd_asize), dryvolyy(maxd_asize) + real rmassxx(maxd_acomp+2,maxd_asize), & + rmassyy(maxd_acomp+2,maxd_asize) + real rnumbxx(maxd_asize), rnumbyy(maxd_asize) + real wetvolxx(maxd_asize), wetvolyy(maxd_asize) + real wetmassxx(maxd_asize), wetmassyy(maxd_asize) + +! local variables + integer jj, l, ll, llworst, llworstb, n + integer nerr, nerrmax + save nerr, nerrmax + data nerr, nerrmax / 0, 999 / + + real dumbot, dumtop, dumtoler, dumerr, dumworst, dumworstb + real duma, dumb, dumc, dume + real thesum(4,maxd_acomp+7) + save thesum + + character*8 dumname(maxd_acomp+7) + character*160 msg + + + if (ipass .eq. 2) goto 2000 + + do ll = 1, ncomp_plustracer_aer(itype)+7 + do jj = 1, 4 + thesum(jj,ll) = 0.0 + end do + end do + + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_plustracer_aer(itype)+2 + thesum(1,ll) = thesum(1,ll) + rmassxx(ll,n) + thesum(2,ll) = thesum(2,ll) + rmassyy(ll,n) + end do + ll = ncomp_plustracer_aer(itype)+3 + thesum(1,ll) = thesum(1,ll) + rnumbxx(n) + thesum(2,ll) = thesum(2,ll) + rnumbyy(n) + ll = ncomp_plustracer_aer(itype)+4 + thesum(1,ll) = thesum(1,ll) + drymassxx(n) + thesum(2,ll) = thesum(2,ll) + drymassyy(n) + ll = ncomp_plustracer_aer(itype)+5 + thesum(1,ll) = thesum(1,ll) + dryvolxx(n) + thesum(2,ll) = thesum(2,ll) + dryvolyy(n) + ll = ncomp_plustracer_aer(itype)+6 + thesum(1,ll) = thesum(1,ll) + wetmassxx(n) + thesum(2,ll) = thesum(2,ll) + wetmassyy(n) + ll = ncomp_plustracer_aer(itype)+7 + thesum(1,ll) = thesum(1,ll) + wetvolxx(n) + thesum(2,ll) = thesum(2,ll) + wetvolyy(n) + end do + + +2000 continue +! +! calc sum over bins for each species +! for water, account for loss in initial conform (delta_water_conform1) +! + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_plustracer_aer(itype)+3 + if (ll .le. ncomp_plustracer_aer(itype)) then + l = massptr_aer(ll,n,itype,iphase) + else if (ll .eq. ncomp_plustracer_aer(itype)+1) then + l = 0 + if (iphase .eq. ai_phase) l = hyswptr_aer(n,itype) + else if (ll .eq. ncomp_plustracer_aer(itype)+2) then + l = 0 + if (iphase .eq. ai_phase) l = waterptr_aer(n,itype) + else + l = numptr_aer(n,itype,iphase) + end if + if (l .gt. 0) & + thesum(ipass+2,ll) = thesum(ipass+2,ll) + rsub(l,k,m) + end do + end do + if (ipass .eq. 2) then + ll = ncomp_plustracer_aer(itype)+2 + thesum(3,ll) = thesum(3,ll) + delta_water_conform1 + ll = ncomp_plustracer_aer(itype)+3 + thesum(3,ll) = thesum(3,ll) + delta_numb_conform1 + end if + +! +! now compare either sum1-sum2 or sum3-sum4 +! on ipass=1, jj=1, so compare sum1 & sum2 +! on ipass=2, jj=3, so compare sum3 & sum4 +! + do ll = 1, ncomp_plustracer_aer(itype)+7 + dumname(ll) = ' ' + write(dumname(ll),'(i4.4)') ll + if (ll .le. ncomp_plustracer_aer(itype)) dumname(ll) = & + name(massptr_aer(ll,1,itype,iphase))(1:4) + if (ll .eq. ncomp_plustracer_aer(itype)+1) dumname(ll) = 'hysw' + if (ll .eq. ncomp_plustracer_aer(itype)+2) dumname(ll) = 'watr' + if (ll .eq. ncomp_plustracer_aer(itype)+3) dumname(ll) = 'numb' + if (ll .eq. ncomp_plustracer_aer(itype)+4) dumname(ll) = 'drymass' + if (ll .eq. ncomp_plustracer_aer(itype)+5) dumname(ll) = 'dryvol' + if (ll .eq. ncomp_plustracer_aer(itype)+6) dumname(ll) = 'wetmass' + if (ll .eq. ncomp_plustracer_aer(itype)+7) dumname(ll) = 'wetvol' + end do + + jj = 2*ipass - 1 + dumworst = 0.0 + dumworstb = 0.0 + llworst = 0 + llworstb = 0 + do ll = 1, ncomp_plustracer_aer(itype)+7 + dumtop = thesum(jj+1,ll) - thesum(jj,ll) + dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-35 ) + dumerr = dumtop/dumbot + +! rce 21-jul-2006 - encountered some cases when delta_*_conform1 is negative +! and large in magnitude relative to thesum, which causes the mass +! conservation to be less accurate due to roundoff +! following section recomputes relative error with delta_*_conform1 +! added onto each of thesum +! also increased dumtoler slightly + if (ipass .eq. 2) then + dumc = 1.0 + if (ll .eq. ncomp_plustracer_aer(itype)+2) then + dumc = delta_water_conform1 + else if (ll .eq. ncomp_plustracer_aer(itype)+3) then + dumc = delta_numb_conform1 + end if + if (dumc .lt. 0.0) then + duma = thesum(3,ll) - dumc + dumb = thesum(4,ll) - dumc + dumtop = dumb - duma + dumbot = max( abs(duma), abs(dumb), 1.0e-35 ) + dume = dumtop/dumbot + if (abs(dume) .lt. abs(dumerr)) dumerr = dume + end if + end if + + if (abs(dumerr) .gt. abs(dumworst)) then + llworstb = llworst + dumworstb = dumworst + llworst = ll + dumworst = dumerr + end if + end do + + dumtoler = 1.0e-6 + if (abs(dumworst) .gt. dumtoler) then + nerr = nerr + 1 + if (nerr .le. nerrmax) then + msg = ' ' + call peg_message( lunout, msg ) + write(msg,97110) iclm, jclm, k, m, ipass, llworst + call peg_message( lunout, msg ) + write(msg,97120) ' nnew(1,n)', & + (nnewsave(1,n), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,97120) ' nnew(2,n)', & + (nnewsave(2,n), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + + ll = llworst + if (ll .eq. 0) ll = ncomp_plustracer_aer(itype)+2 + write(msg,97130) 'name/relerr/thesum', jj, '/thesum', jj+1, & + dumname(ll), dumworst, thesum(jj,ll), thesum(jj+1,ll) + call peg_message( lunout, msg ) + + if ( (ll .eq. ncomp_plustracer_aer(itype)+3) .and. & + (abs(dumworstb) .gt. dumtoler) ) then + ll = max( 1, llworstb ) + dumtop = thesum(jj+1,ll) - thesum(jj,ll) + dumbot = max( abs(thesum(jj,ll)), abs(thesum(jj+1,ll)), 1.0e-35 ) + dumerr = dumtop/dumbot + write(msg,97130) 'name/relerr/thesum', jj, '/thesum', jj+1, & + dumname(ll), dumerr, thesum(jj,ll), thesum(jj+1,ll) + call peg_message( lunout, msg ) + end if + end if + end if + +97110 format( 'movesect conserve ERROR - i/j/k/m/pass/llworst', & + 4i3, 2x, 2i3 ) +97120 format( a, 64i3 ) +97130 format( a, i1, a, i1, 2x, a, 1p, 3e16.7 ) + + return + end subroutine move_sections_conserve_check + + +!----------------------------------------------------------------------- + subroutine test_move_sections( iflag_test, iclm, jclm, k, m ) +! +! routine runs tests on move_sections, using a matrix of +! pregrow and aftgrow masses for each section +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer iflag_test, iclm, jclm, k, m + +! local variables + integer idiag_movesect, iflag, ii, iphase, itype, jj, & + l, ll, n, nn + integer ientryno + save ientryno + data ientryno / 0 / + + real dumnumb, dumvolpre, dumvolaft + real dumsv_rsub(l2maxd) + real dumsv_drymass_pregrow(maxd_asize,maxd_atype) + real dumsv_drymass_aftgrow(maxd_asize,maxd_atype) + real dumsv_drydens_pregrow(maxd_asize,maxd_atype) + real dumsv_drydens_aftgrow(maxd_asize,maxd_atype) + + character*160 msg + + integer maxvolfactpre, maxvolfactaft + parameter (maxvolfactpre=15, maxvolfactaft=23) + + real dumvolfactpre(maxvolfactpre) + data dumvolfactpre / & + 2.0, 0.0, 1.0e-20, 0.5, 0.9, & + 1.0, 1.01, 1.1, 2.0, 4.0, 7.9, 7.99, 8.0, & + 8.1, 16.0 / + + real dumvolfactaft(maxvolfactaft) + data dumvolfactaft / & + 4.0, 0.0, 1.0e-20, 0.01, 0.02, 0.05, 0.1, 0.5, 0.9, & + 1.0, 1.01, 1.1, 2.0, 4.0, 7.9, 7.99, 8.0, & + 8.1, 16.0, 32., 64., 128., 256. / + + +! +! check for valid inputs +! and first entry +! + if (msectional .le. 0) return + if (nsize_aer(1) .le. 0) return + + idiag_movesect = mod( msectional, 10000 )/100 + if (idiag_movesect .ne. 70) return + + ientryno = ientryno + 1 + if (ientryno .gt. 2) return + +! +! save rsub and drymass/dens_aft/pregrow +! + do l = 1, ltot2 + dumsv_rsub(l) = rsub(l,k,m) + end do + do itype = 1, ntype_aer + do n = 1, nsize_aer(itype) + dumsv_drymass_pregrow(n,itype) = drymass_pregrow(n,itype) + dumsv_drymass_aftgrow(n,itype) = drymass_aftgrow(n,itype) + dumsv_drydens_pregrow(n,itype) = drydens_pregrow(n,itype) + dumsv_drydens_aftgrow(n,itype) = drydens_aftgrow(n,itype) + end do + end do + +! +! make test calls to move_sections +! + do 3900 iflag = 1, 1 + + iphase = ai_phase + if (iabs(iflag) .eq. 2) iphase = cw_phase + + do 3800 itype = 1, ntype_aer + + do 2900 nn = 1, nsize_aer(itype) + + do 2800 ii = 1, maxvolfactpre + + do 2700 jj = 1, maxvolfactaft + +! zero out rsub and dryxxx_yyygrow arrays + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_plustracer_aer(itype) + rsub(massptr_aer(ll,n,itype,iphase),k,m) = 0.0 + end do + l = 0 + if (iphase .eq. ai_phase) l = waterptr_aer(n,itype) + if (l .gt. 0) rsub(l,k,m) = 0.0 + l = numptr_aer(n,itype,iphase) + if (l .gt. 0) rsub(l,k,m) = 0.0 + drymass_pregrow(n,itype) = 0.0 + drymass_aftgrow(n,itype) = 0.0 + drydens_pregrow(n,itype) = -1.0 + drydens_aftgrow(n,itype) = -1.0 + end do + +! fill in values for section nn + n = nn + dumnumb = 1.0e7 + rsub(numptr_aer(n,itype,iphase),k,m) = dumnumb + ll = 1 + l = massptr_aer(ll,n,itype,iphase) + + dumvolpre = volumlo_sect(n,itype)*dumvolfactpre(ii)*dumnumb + drydens_pregrow(n,itype) = dens_aer(ll,itype) + drymass_pregrow(n,itype) = dumvolpre*drydens_pregrow(n,itype) + if (ii .eq. 1) drydens_pregrow(n,itype) = -1.0 + + dumvolaft = volumlo_sect(n,itype)*dumvolfactaft(jj)*dumnumb + drydens_aftgrow(n,itype) = dens_aer(ll,itype) + drymass_aftgrow(n,itype) = dumvolaft*drydens_aftgrow(n,itype) + if (jj .eq. 1) drydens_aftgrow(n,itype) = -1.0 + + rsub(l,k,m) = drymass_aftgrow(n,itype)/mw_aer(ll,itype) + + msg = ' ' + call peg_message( lunout, msg ) + write(msg,98010) nn, ii, jj + call peg_message( lunout, msg ) + write(msg,98011) dumvolfactpre(ii), dumvolfactaft(jj) + call peg_message( lunout, msg ) + +! make test call to move_sections + call move_sections( iflag, iclm, jclm, k, m ) + + msg = ' ' + call peg_message( lunout, msg ) + write(msg,98010) nn, ii, jj + call peg_message( lunout, msg ) + write(msg,98011) dumvolfactpre(ii), dumvolfactaft(jj) + call peg_message( lunout, msg ) + +2700 continue +2800 continue +2900 continue + +3800 continue +3900 continue + +98010 format( 'test_move_sections output - nn, ii, jj =', 3i3 ) +98011 format( 'volfactpre, volfactaft =', 1p, 2e12.4 ) + +! +! restore rsub and drymass/dens_aft/pregrow +! + do l = 1, ltot2 + rsub(l,k,m) = dumsv_rsub(l) + end do + do itype = 1, ntype_aer + do n = 1, nsize_aer(itype) + drymass_pregrow(n,itype) = dumsv_drymass_pregrow(n,itype) + drymass_aftgrow(n,itype) = dumsv_drymass_aftgrow(n,itype) + drydens_pregrow(n,itype) = dumsv_drydens_pregrow(n,itype) + drydens_aftgrow(n,itype) = dumsv_drydens_aftgrow(n,itype) + end do + end do + + return + end subroutine test_move_sections + + +!----------------------------------------------------------------------- + subroutine move_sections_checkptrs( iflag, iclm, jclm, k, m ) +! +! checks for valid number and water pointers +! + implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr parameters + integer iflag, iclm, jclm, k, m + +! local variables + integer l, itype, iphase, n, ndum + character*160 msg + + do 1900 itype = 1, ntype_aer + do 1800 iphase = 1, nphase_aer + + ndum = 0 + do n = 1, nsize_aer(itype) + l = numptr_aer(n,itype,iphase) + if ((l .le. 0) .or. (l .gt. ltot2)) then + msg = '*** subr move_sections error - ' // & + 'numptr_amode not defined' + call peg_message( lunerr, msg ) + write(msg,9030) 'mode, numptr =', n, l + call peg_message( lunerr, msg ) + write(msg,9030) 'iphase, itype =', iphase, itype + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if +! checks involving nspec_amode and nspec_amode_nontracer +! being the same for all sections are no longer needed + l = 0 + if (iphase .eq. ai_phase) l = waterptr_aer(n,itype) + if ((l .gt. 0) .and. (l .le. ltot2)) ndum = ndum + 1 + end do + if ((ndum .ne. 0) .and. (ndum .ne. nsize_aer(itype))) then + msg = '*** subr move_sections error - ' // & + 'waterptr_aer must be on/off for all modes' + call peg_message( lunerr, msg ) + write(msg,9030) 'iphase, itype =', iphase, itype + call peg_message( lunerr, msg ) + call peg_error_fatal( lunerr, msg ) + end if +9030 format( a, 2(1x,i6) ) + +1800 continue +1900 continue + + return + end subroutine move_sections_checkptrs + + + + end module module_mosaic_movesect diff --git a/wrfv2_fire/chem/module_mosaic_newnuc.F b/wrfv2_fire/chem/module_mosaic_newnuc.F new file mode 100644 index 00000000..1a503c16 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_newnuc.F @@ -0,0 +1,1066 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_newnuc + + + + use module_peg_util + + + + implicit none + + + + contains + + + +!----------------------------------------------------------------------- + subroutine mosaic_newnuc_1clm( istat_newnuc, & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_in, & + dtchem, dtnuc_in, rsub0, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte ) +! +! calculates new particle nucleation for grid points in +! the i=it, j=jt vertical column over timestep dtnuc_in +! works with mosaic sectional aerosol packages +! +! when newnuc_method = 1 (internal parameter), uses +! h2so4-nh3-h2o ternary nucleation from napari et al., 2002 +! *** this option is currently disabled because the ternary +! parameterization was recently shown to be invalid +! when newnuc_method = 2 (internal parameter), uses +! h2so4-h2o binary nucleation from wexler et al., 1994 +! + use module_data_mosaic_asect + use module_data_mosaic_other + use module_state_description, only: param_first_scalar + +! subr arguments + integer, intent(inout) :: istat_newnuc ! =0 if no problems + integer, intent(in) :: & + it, jt, kclm_calcbgn, kclm_calcend, & + idiagbb_in, & + id, ktau, ktauc, its, ite, jts, jte, kts, kte + real, intent(in) :: dtchem, dtnuc_in + real, intent(in) :: rsub0(l2maxd,kmaxd,nsubareamaxd) +! rsub0 holds mixrat values before the aerchemistry calcs + +! NOTE - much information is passed via arrays in +! module_data_mosaic_asect and module_data_mosaic_other +! +! rsub (inout) - trace gas and aerosol mixing ratios +! aqmassdry_sub, aqvoldry_sub (inout) - +! aerosol dry-mass and dry-volume mixing ratios +! adrydens_sub (inout) - aerosol dry density +! rsub(ktemp,:,:), cairclm, relhumclm (in) - +! air temperature, molar density, and relative humidity + + +! local variables + integer, parameter :: newnuc_method = 2 + + integer :: k, l, ll, m + integer :: isize, itype, iphase + integer :: iconform_numb + integer :: idiagbb + integer :: nsize, ntau_nuc + integer :: ncount(10) + integer :: p1st + + real, parameter :: densdefault = 2.0 + real, parameter :: smallmassbb = 1.0e-30 + +! nh4hso4 values for a_zsr and b_zsr + real, parameter :: a_zsr_xx1 = 1.15510 + real, parameter :: a_zsr_xx2 = -3.20815 + real, parameter :: a_zsr_xx3 = 2.71141 + real, parameter :: a_zsr_xx4 = 2.01155 + real, parameter :: a_zsr_xx5 = -4.71014 + real, parameter :: a_zsr_xx6 = 2.04616 + real, parameter :: b_zsr_xx = 29.4779 + + real :: aw + real :: cair_box + real :: dens_nh4so4a, dtnuc + real :: duma, dumb, dumc + real :: rh_box + real :: qh2so4_avg, qh2so4_cur, qh2so4_del + real :: qnh3_avg, qnh3_cur, qnh3_del + real :: qnuma_del, qso4a_del, qnh4a_del + real :: temp_box + real :: xxdens, xxmass, xxnumb, xxvolu + + real,save :: dumveca(10), dumvecb(10), dumvecc(10), dumvecd(10), dumvece(10) + real :: volumlo_nuc(maxd_asize), volumhi_nuc(maxd_asize) + + character(len=100) :: msg + + + +! check newnuc_method + istat_newnuc = 0 + if (newnuc_method .ne. 2) then + if ((it .eq. its) .and. (jt .eq. jts)) & + call peg_message( lunerr, & + '*** mosaic_newnuc_1clm -- illegal newnuc_method' ) + istat_newnuc = -1 + return + end if + + +! when dtnuc_in > dtchem, do not perform nucleation calcs +! on every chemistry time step + ntau_nuc = nint( dtnuc_in/dtchem ) + ntau_nuc = max( 1, ntau_nuc ) + if (mod(ktau,ntau_nuc) .ne. 0) return + dtnuc = dtchem*ntau_nuc + + +! set variables that do not change + idiagbb = idiagbb_in + + itype = 1 + iphase = ai_phase + nsize = nsize_aer(itype) + volumlo_nuc(1:nsize) = volumlo_sect(1:nsize,itype) + volumhi_nuc(1:nsize) = volumhi_sect(1:nsize,itype) + + +! loop over subareas (currently only 1) and vertical levels + do 2900 m = 1, nsubareas + + do 2800 k = kclm_calcbgn, kclm_calcend + + +! initialize diagnostics + if ((it .eq. its) .and. & + (jt .eq. jts) .and. (k .eq. kclm_calcbgn)) then + dumveca(:) = 0.0 ! current grid param values + dumvecb(:) = +1.0e35 ! param minimums + dumvecc(:) = -1.0e35 ! param maximums + dumvecd(:) = 0.0 ! param averages + dumvece(:) = 0.0 ! param values for highest qnuma_del + ncount(:) = 0 + end if + + + ncount(1) = ncount(1) + 1 + if (afracsubarea(k,m) .lt. 1.e-4) goto 2700 + + cair_box = cairclm(k) + temp_box = rsub(ktemp,k,m) + rh_box = relhumclm(k) + + qh2so4_cur = max(0.0,rsub(kh2so4,k,m)) + qnh3_cur = max(0.0,rsub(knh3,k,m)) + qh2so4_avg = 0.5*( qh2so4_cur + max(0.0,rsub0(kh2so4,k,m)) ) + qnh3_avg = 0.5*( qnh3_cur + max(0.0,rsub0(knh3,k,m)) ) + + qh2so4_del = 0.0 + qnh3_del = 0.0 + qnuma_del = 0.0 + qso4a_del = 0.0 + qnh4a_del = 0.0 + + dens_nh4so4a = dens_so4_aer + + isize = 0 + +! make call to nucleation routine + if (newnuc_method .eq. 1) then + call ternary_nuc_mosaic_1box( & + dtnuc, temp_box, rh_box, cair_box, & + qh2so4_avg, qh2so4_cur, qnh3_avg, qnh3_cur, & + nsize, maxd_asize, volumlo_nuc, volumhi_nuc, & + isize, qnuma_del, qso4a_del, qnh4a_del, & + qh2so4_del, qnh3_del, dens_nh4so4a ) + else if (newnuc_method .eq. 2) then + call wexler_nuc_mosaic_1box( & + dtnuc, temp_box, rh_box, cair_box, & + qh2so4_avg, qh2so4_cur, qnh3_avg, qnh3_cur, & + nsize, maxd_asize, volumlo_nuc, volumhi_nuc, & + isize, qnuma_del, qso4a_del, qnh4a_del, & + qh2so4_del, qnh3_del, dens_nh4so4a ) + else + istat_newnuc = -1 + return + end if + + +! temporary diagnostics + dumveca(1) = temp_box + dumveca(2) = rh_box + dumveca(3) = rsub(kso2,k,m) + dumveca(4) = qh2so4_avg + dumveca(5) = qnh3_avg + dumveca(6) = qnuma_del + do l = 1, 6 + dumvecb(l) = min( dumvecb(l), dumveca(l) ) + dumvecc(l) = max( dumvecc(l), dumveca(l) ) + dumvecd(l) = dumvecd(l) + dumveca(l) + if (qnuma_del .gt. dumvece(6)) dumvece(l) = dumveca(l) + end do + + +! check for zero new particles + if (qnuma_del .le. 0.0) goto 2700 + +! check for valid isize + if (isize .ne. 1) ncount(3) = ncount(3) + 1 + if ((isize .lt. 1) .or. (isize .gt. nsize)) then + write(msg,93010) 'newnucxx bad isize_nuc' , it, jt, k, & + isize, nsize + call peg_message( lunerr, msg ) + goto 2700 + end if +93010 format( a, 3i3, 1p, 9e10.2 ) + + + ncount(2) = ncount(2) + 1 + +! update gas and aerosol so4 and nh3/nh4 mixing ratios + rsub(kh2so4,k,m) = max( 0.0, rsub(kh2so4,k,m) + qh2so4_del ) + rsub(knh3, k,m) = max( 0.0, rsub(knh3, k,m) + qnh3_del ) + + l = lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) then + rsub(l,k,m) = rsub(l,k,m) + qso4a_del + end if + l = lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) then + rsub(l,k,m) = rsub(l,k,m) + qnh4a_del + end if + l = numptr_aer(isize,itype,iphase) + rsub(l,k,m) = rsub(l,k,m) + qnuma_del + xxnumb = rsub(l,k,m) + +! update aerosol water, using mosaic parameterizations for nh4hso4 +! duma = (mole-salt)/(mole-salt+water) +! dumb = (mole-salt)/(kg-water) +! dumc = (mole-water)/(mole-salt) + l = waterptr_aer(isize,itype) + if ((rh_box .gt. 0.10) .and. (l .ge. p1st)) then + aw = min( rh_box, 0.98 ) + if (aw .lt. 0.97) then + duma = a_zsr_xx1 + & + aw*( a_zsr_xx2 + & + aw*( a_zsr_xx3 + & + aw*( a_zsr_xx4 + & + aw*( a_zsr_xx5 + & + aw* a_zsr_xx6 )))) + else + dumb = -b_zsr_xx*log(aw) + dumb = max( dumb, 0.5 ) + duma = 1.0/(1.0 + 55.509/dumb) + end if + duma = max( duma, 0.01 ) + dumc = (1.0 - duma)/duma + rsub(l,k,m) = rsub(l,k,m) + qso4a_del*dumc + end if + + +! +! update dry mass, density, and volume, +! and check for mean dry-size within bounds +! + xxmass = aqmassdry_sub(isize,itype,k,m) + xxdens = adrydens_sub( isize,itype,k,m) + iconform_numb = 1 + + if ((xxdens .lt. 0.1) .or. (xxdens .gt. 20.0)) then +! (exception) case of drydensity not valid + continue + else +! (normal) case of drydensity valid (which means drymass is valid also) +! so increment mass and volume with the so4 & nh4 deltas, then calc density + xxvolu = xxmass/xxdens + duma = qso4a_del*mw_so4_aer + qnh4a_del*mw_nh4_aer + xxmass = xxmass + duma + xxvolu = xxvolu + duma/dens_nh4so4a + if (xxmass .le. smallmassbb) then +! do this to force calc of dry mass, volume from rsub + xxdens = 0.001 + else if (xxmass .gt. 1000.0*xxvolu) then +! in this case, density is too large. setting density=1000 forces +! next IF block while avoiding potential divide by zero or overflow + xxdens = 1000.0 + else + xxdens = xxmass/xxvolu + end if + end if + + if ((xxdens .lt. 0.1) .or. (xxdens .gt. 20.0)) then +! (exception) case of drydensity not valid (or drymass extremely small), +! so compute from dry mass, volume from rsub + ncount(4) = ncount(4) + 1 + xxmass = 0.0 + xxvolu = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,iphase) + if (l .ge. p1st) then + duma = max( 0.0, rsub(l,k,m) )*mw_aer(ll,itype) + xxmass = xxmass + duma + xxvolu = xxvolu + duma/dens_aer(ll,itype) + end if + end do + end if + + if (xxmass .le. smallmassbb) then +! when drymass extremely small, use default density and bin center size, +! and zero out water + ncount(5) = ncount(5) + 1 + xxdens = densdefault + xxvolu = xxmass/xxdens + xxnumb = xxmass/(volumcen_sect(isize,itype)*xxdens) + iconform_numb = 0 + l = waterptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = 0.0 + else + xxdens = xxmass/xxvolu + end if + + if (iconform_numb .gt. 0) then +! check for mean dry-size within bounds, and conform number if not + if (xxnumb .gt. xxvolu/volumlo_sect(isize,itype)) then + ncount(6) = ncount(6) + 1 + xxnumb = xxvolu/volumlo_sect(isize,itype) + else if (xxnumb .lt. xxvolu/volumhi_sect(isize,itype)) then + ncount(7) = ncount(7) + 1 + xxnumb = xxvolu/volumhi_sect(isize,itype) + end if + end if + +! load dry mass, density, volume, and (possibly conformed) number + l = numptr_aer(isize,itype,iphase) + rsub(l,k,m) = xxnumb + adrydens_sub( isize,itype,k,m) = xxdens + aqmassdry_sub(isize,itype,k,m) = xxmass + aqvoldry_sub( isize,itype,k,m) = xxvolu + + +2700 continue + +! temporary diagnostics + if ((idiagbb .ge. 100) .and. & + (it .eq. ite) .and. & + (jt .eq. jte) .and. (k .eq. kclm_calcend)) then + if (idiagbb .ge. 110) then + write(msg,93020) 'newnucbb mins ', dumvecb(1:6) + call peg_message( lunerr, msg ) + write(msg,93020) 'newnucbb maxs ', dumvecc(1:6) + call peg_message( lunerr, msg ) + duma = max( 1, ncount(1) ) + write(msg,93020) 'newnucbb avgs ', dumvecd(1:6)/duma + call peg_message( lunerr, msg ) + write(msg,93020) 'newnucbb hinuc', dumvece(1:6) + call peg_message( lunerr, msg ) + write(msg,93020) 'newnucbb dtnuc', dtnuc + call peg_message( lunerr, msg ) + end if + write(msg,93030) 'newnucbb ncnt ', ncount(1:7) + call peg_message( lunerr, msg ) + end if +93020 format( a, 1p, 10e10.2 ) +93030 format( a, 1p, 10i10 ) + + +2800 continue ! k levels + +2900 continue ! subareas + + + return + end subroutine mosaic_newnuc_1clm + + +!----------------------------------------------------------------------- +! note - subrs ternary_nuc_mosaic_1box, ternary_nuc_napari, wexler_nuc_mosaic_1box +! taken from ternucl04.f90 on 22-jul-2006 +!----------------------------------------------------------------------- + subroutine ternary_nuc_mosaic_1box( & + dtnuc, temp_in, rh_in, cair, & + qh2so4_avg, qh2so4_cur, qnh3_avg, qnh3_cur, & + nsize, maxd_asize, volumlo_sect, volumhi_sect, & + isize_nuc, qnuma_del, qso4a_del, qnh4a_del, & + qh2so4_del, qnh3_del, dens_nh4so4a ) +!....................................................................... +! +! calculates new particle production from h2so4-nh3-h2o ternary nucleation +! over timestep dtnuc, using nucleation rates from the +! napari et al. (2002) parameterization +! +! the new particles are "grown" to the lower-bound size of the host code's +! smallest size bin. (this "growth" is purely ad hoc, and would not be +! necessary if the host code's size bins extend down to ~1 nm.) +! if the h2so4 and nh3 mass mixing ratios (mixrats) of the grown new +! particles exceed the current gas mixrats, the new particle production +! is reduced so that the new particle mass mixrats match the gas mixrats. +! +! revision history +! coded by rc easter, pnnl, 20-mar-2006 +! +! key routines called: subr ternary_nuc_napari +! +! references: +! napari, i., m. noppel, h. vehkamaki, and m. kulmala, +! parameterization of ternary nucleation rates for +! h2so4-nh3-h2o vapors. j. geophys. res., 107, 4381, 2002. +! +!....................................................................... + implicit none + +! subr arguments (in) + real, intent(in) :: dtnuc ! nucleation time step (s) + real, intent(in) :: temp_in ! temperature, in k + real, intent(in) :: rh_in ! relative humidity, as fraction + real, intent(in) :: cair ! dry-air molar density (mole/cm3) + + real, intent(in) :: qh2so4_avg, qh2so4_cur ! gas h2so4 mixing ratios (mole/mole-air) + real, intent(in) :: qnh3_avg, qnh3_cur ! gas nh3 mixing ratios (mole/mole-air) + ! qxxx_cur = current value (at end of condensation) + ! qxxx_avg = average value (from start to end of condensation) + + integer, intent(in) :: nsize ! number of aerosol size bins + integer, intent(in) :: maxd_asize ! dimension for volumlo_sect, ... + real, intent(in) :: volumlo_sect(maxd_asize) ! dry volume at lower bnd of bin (cm3) + real, intent(in) :: volumhi_sect(maxd_asize) ! dry volume at upper bnd of bin (cm3) + +! subr arguments (out) + integer, intent(out) :: isize_nuc ! size bin into which new particles go + real, intent(out) :: qnuma_del ! change to aerosol number mixing ratio (#/mole-air) + real, intent(out) :: qso4a_del ! change to aerosol so4 mixing ratio (mole/mole-air) + real, intent(out) :: qnh4a_del ! change to aerosol nh4 mixing ratio (mole/mole-air) + real, intent(out) :: qh2so4_del ! change to gas h2so4 mixing ratio (mole/mole-air) + real, intent(out) :: qnh3_del ! change to gas nh3 mixing ratio (mole/mole-air) + ! aerosol changes are > 0; gas changes are < 0 + +! subr arguments (inout) + real, intent(inout) :: dens_nh4so4a ! dry-density of the new nh4-so4 aerosol mass (g/cm3) + ! use 'in' value only if it is between 1.6-2.0 g/cm3 + +! subr arguments (out) passed via common block +! these are used to duplicate the outputs of yang zhang's original test driver +! they are not really needed in wrf-chem, so just make them local + real :: ratenuclt ! j = ternary nucleation rate from napari param. (cm-3 s-1) + real :: rateloge ! ln (j) + real :: cnum_h2so4 ! number of h2so4 molecules in the critical nucleus + real :: cnum_nh3 ! number of nh3 molecules in the critical nucleus + real :: cnum_tot ! total number of molecules in the critical nucleus + real :: radius_cluster ! the radius of cluster (nm) + +! common / ternary_nuc_yzhang_cmn01 / & +! ratenuclt, rateloge, & +! cnum_h2so4, cnum_nh3, cnum_tot, radius_cluster + + +! local variables + integer i + integer, save :: icase = 0, icase_reldiffmax = 0 + + real, parameter :: pi = 3.1415926536 + real, parameter :: avogad = 6.022e23 ! avogadro number (molecules/mole) + real, parameter :: mw_air = 28.966 ! dry-air mean molecular weight (g/mole) + +! dry densities (g/cm3) molecular weights of aerosol +! ammsulf, ammbisulf, and sulfacid (from mosaic dens_electrolyte values) + real, parameter :: dens_ammsulf = 1.769 + real, parameter :: dens_ammbisulf = 1.78 + real, parameter :: dens_sulfacid = 1.841 + +! molecular weights (g/mole) of aerosol ammsulf, ammbisulf, and sulfacid +! for ammbisulf and sulfacid, use 114 & 96 here rather than 115 & 98 +! because we don't keep track of aerosol hion mass + real, parameter :: mw_ammsulf = 132.0 + real, parameter :: mw_ammbisulf = 114.0 + real, parameter :: mw_sulfacid = 96.0 +! molecular weights of aerosol sulfate and ammonium + real, parameter :: mw_so4a = 96.0 + real, parameter :: mw_nh4a = 18.0 + + real, save :: reldiffmax = 0.0 + + real dens_part ! "grown" single-particle dry density (g/cm3) + real duma, dumb, dumc, dume + real dum_m1, dum_m2, dum_m3, dum_n1, dum_n2, dum_n3 + real fogas, foso4a, fonh4a, fonuma + real freduce ! reduction factor applied to nucleation rate + ! due to limited availability of h2so4 & nh3 gases + real freducea, freduceb + real gramaero_per_moleso4a ! (g dry aerosol)/(mole aerosol so4) + real mass_part ! "grown" single-particle mass (g) + real molenh4a_per_moleso4a ! (mole aerosol nh4)/(mole aerosol so4) + real nh3conc_in ! mixing ratio of nh3 for nucl. calc., pptv + real so4vol_in ! concentration of h2so4 for nucl. calc., molecules cm-3 + real qmolnh4a_del_max ! max production of aerosol nh4 over dtnuc (mole/mole-air) + real qmolso4a_del_max ! max production of aerosol so4 over dtnuc (mole/mole-air) + real vol_cluster ! critical-cluster volume (cm3) + real vol_part ! "grown" single-particle volume (cm3) + + +! +! if h2so4 vapor < 4.0e-16 mole/moleair ~= 1.0e4 molecules/cm3, +! exit with new particle formation = 0 +! + isize_nuc = 1 + qnuma_del = 0.0 + qso4a_del = 0.0 + qnh4a_del = 0.0 + qh2so4_del = 0.0 + qnh3_del = 0.0 + if (qh2so4_avg .le. 4.0e-16) return + if (qh2so4_cur .le. 4.0e-16) return + + +! +! make call to napari parameterization routine +! + +! convert nh3 from mole/mole-air to ppt +! qnh3_cur = nh3conc(m)*1.0e-12 + nh3conc_in = qnh3_avg/1.0e-12 + +! convert h2so4 from mole/mole-air to molecules/cm3 +! qh2so4_cur = (so4vol(k)/avogad) / cair + so4vol_in = (qh2so4_avg) * cair * avogad + + call ternary_nuc_napari( & + temp_in, rh_in, nh3conc_in, so4vol_in, & + ratenuclt, rateloge, & + cnum_h2so4, cnum_nh3, cnum_tot, radius_cluster ) + +! if nucleation rate is less than 0.1 particle/cm3/day, +! exit with new particle formation = 0 + if (ratenuclt .le. 1.0e-6) return + + +! determine size bin into which the new particles go +! (probably it will always be bin #1, but ...) + vol_cluster = (pi*4.0/3.0)* (radius_cluster**3) * 1.0e-21 + isize_nuc = 1 + vol_part = volumlo_sect(1) + if (vol_cluster .le. volumlo_sect(1)) then + continue + else if (vol_cluster .ge. volumhi_sect(nsize)) then + isize_nuc = nsize + vol_part = volumhi_sect(nsize) + else + do i = 1, nsize + if (vol_cluster .lt. volumhi_sect(i)) then + isize_nuc = i + vol_part = vol_cluster + vol_part = min( vol_part, volumhi_sect(i) ) + vol_part = max( vol_part, volumlo_sect(i) ) + exit + end if + end do + end if + + +! +! determine composition and density of the "grown particles" +! the grown particles are assumed to be liquid +! (since critical clusters contain water) +! so any (nh4/so4) molar ratio between 0 and 2 is allowed +! assume that the grown particles will have +! (nh4/so4 molar ratio) = min( 2, (nh3/h2so4 gas molar ratio) ) +! + if (qnh3_cur .ge. qh2so4_cur) then +! combination of ammonium sulfate and ammonium bisulfate +! dum_n1 & dum_n2 = mole fractions of the ammsulf & ammbisulf + dum_n1 = (qnh3_cur/qh2so4_cur) - 1.0 + dum_n1 = max( 0.0, min( 1.0, dum_n1 ) ) + dum_n2 = 1.0 - dum_n1 + dum_n3 = 0.0 + else +! combination of ammonium bisulfate and sulfuric acid +! dum_n2 & dum_n3 = mole fractions of the ammbisulf & sulfacid + dum_n1 = 0.0 + dum_n2 = (qnh3_cur/qh2so4_cur) + dum_n2 = max( 0.0, min( 1.0, dum_n2 ) ) + dum_n3 = 1.0 - dum_n2 + end if + + dum_m1 = dum_n1*mw_ammsulf + dum_m2 = dum_n2*mw_ammbisulf + dum_m3 = dum_n3*mw_sulfacid + dens_part = (dum_m1 + dum_m2 + dum_m3)/ & + ((dum_m1/dens_ammsulf) + (dum_m2/dens_ammbisulf) & + + (dum_m3/dens_sulfacid)) +! 25-jul-2006 - use 'in' value only if it is between 1.6-2.0 g/cm3 + if (abs(dens_nh4so4a-1.8) .le. 0.2) then + dens_part = dens_nh4so4a + else + dens_nh4so4a = dens_part + end if + mass_part = vol_part*dens_part + molenh4a_per_moleso4a = 2.0*dum_n1 + dum_n2 ! (mole aerosol nh4)/(mole aerosol so4) + gramaero_per_moleso4a = dum_m1 + dum_m2 + dum_m3 ! (g dry aerosol)/(mole aerosol so4) + + +! max production of aerosol dry mass (g-aero/cm3-air) + duma = max( 0.0, (ratenuclt*dtnuc*mass_part) ) +! max production of aerosol so4 (mole-so4a/cm3-air) + dumc = duma/gramaero_per_moleso4a +! max production of aerosol so4 (mole-so4a/mole-air) + dume = dumc/cair +! max production of aerosol so4 (mole/mole-air) +! based on ratenuclt and mass_part + qmolso4a_del_max = dume + +! check if max production exceeds available h2so4 vapor + freducea = 1.0 + if (qmolso4a_del_max .gt. qh2so4_cur) then + freducea = qh2so4_cur/qmolso4a_del_max + end if + +! check if max production exceeds available nh3 vapor + freduceb = 1.0 + if (molenh4a_per_moleso4a .ge. 1.0e-10) then +! max production of aerosol nh4 (ppm) based on ratenuclt and mass_part + qmolnh4a_del_max = qmolso4a_del_max*molenh4a_per_moleso4a + if (qmolnh4a_del_max .gt. qnh3_cur) then + freduceb = qnh3_cur/qmolnh4a_del_max + end if + end if + freduce = min( freducea, freduceb ) + +! if adjusted nucleation rate is less than 0.1 particle/cm3/day, +! exit with new particle formation = 0 + if (freduce*ratenuclt .le. 1.0e-6) return + + +! note: suppose that at this point, freduce = 1.0 (no gas-available +! constraints) and molenh4a_per_moleso4a < 2.0 +! then it would be possible to condense "additional" nh3 and have +! (nh3/h2so4 gas molar ratio) < (nh4/so4 aerosol molar ratio) <= 2 +! one could do some additional calculations of +! dens_part & molenh4a_per_moleso4a to realize this +! however, the particle "growing" is a crude approximate way to get +! the new particles to the host code's minimum particle size, +! so are such refinements worth the effort? + + +! changes to h2so4 & nh3 gas (in mole/mole-air), limited by amounts available + duma = 0.9999 + qh2so4_del = min( duma*qh2so4_cur, freduce*qmolso4a_del_max ) + qnh3_del = min( duma*qnh3_cur, qh2so4_del*molenh4a_per_moleso4a ) + qh2so4_del = -qh2so4_del + qnh3_del = -qnh3_del + +! changes to so4 & nh4 aerosol (in mole/mole-air) + qso4a_del = -qh2so4_del + qnh4a_del = -qnh3_del +! change to aerosol number (in #/mole-air) + qnuma_del = (qso4a_del*mw_so4a + qnh4a_del*mw_nh4a)/mass_part + + + return + end subroutine ternary_nuc_mosaic_1box + + + +!----------------------------------------------------------------------- + subroutine ternary_nuc_napari( & + temp_in, rh_in, nh3conc_in, so4vol_in, & + ratenuclt, rateloge, & + cnum_h2so4, cnum_nh3, cnum_tot, radius_cluster ) +!********************************************************************* +! purpose: calculate ternary nucleation rates based on * +! napari et al. (2002) parameterization * +! * +! revision history: * +! coded by yang zhang, ncsu, nov. 25, 2004 * +! * +! 14-mar-2006 rce - yang sent this on 10-mar-2005; * +! converted to lowercase; * +! moved the nucleation rate calcs * +! from the main program unit to this subr; * +! added temporary variables log_rh, log_nh3conc, log_so4vol; * +! in the nuc subr, apply limits to the input parameters; * +! converted to f90; * +! * +! reference: * +! napari, i., m, noppel, h. vehkamaki, . and . m. kulmala, * +! parameterization of ternary nucleation rates for * +! h2so4-nh3-h2o vapors. j. geophys. res., 107, 4381, 2002b. * +! * +! note: * +! advantage of this parameterization * +! this parameterization reproduces the ternary nucleation * +! rates obtained from the full model within the range of * +! one order of magnitude, with a cpu saving by a factor * +! of 10e5. * +! * +! limitations / assumptions of this parameterization * +! 1. the limits of validity are * +! t = 240-300 k, rh=0.05-0.95 * +! [h2so4]=10e4-10e9 cm-3 (4e-4 - 40 ppt at stp) * +! [nh3]=0.1-100 ppt, * +! j=10e-5 - 10e6 cm-3 s-1 * +! 2. it cannot be used to obtain binary h2o-h2so4 or h2o-nh3 * +! limit, due to the logarithmic dependencies on rh, * +! [h2so4], and [nh3] * +! 3. the fit is the worst at high temperatures ( > 298 k) * +! and low nucleation rates ( < 0.01 cm-3 s-1), but it is * +! more accurate at significant nucleation rates (0.01-0.1 * +! cm-3 s-1), thus adequate for simulating ternary * +! nucleation in the atmosphere * +! * +!********************************************************************* + + implicit none + +! subr arguments (in) + real, intent(in) :: temp_in ! temperature, in k + real, intent(in) :: rh_in ! relative humidity, as fraction + real, intent(in) :: nh3conc_in ! mixing ratio of nh3, pptv + real, intent(in) :: so4vol_in ! concentration of h2so4, cm-3 + +! subr arguments (out) + real, intent(out) :: ratenuclt ! ternary nucleation rate, j, cm-3 s-1 + real, intent(out) :: rateloge ! ln (j) + + real, intent(out) :: cnum_h2so4 ! number of h2so4 molecules + ! in the critical nucleus + real, intent(out) :: cnum_nh3 ! number of nh3 molecules + ! in the critical nucleus + real, intent(out) :: cnum_tot ! total number of molecules + ! in the critical nucleus + real, intent(out) :: radius_cluster ! the radius of cluster, nm + +! local variables + integer ncoeff + parameter ( ncoeff = 4 ) ! total fitting coefficients at each t + ! corresponds to 3rd order polynomial + integer npoly + parameter ( npoly = 20 ) ! total number of polynomial functions + + integer n ! loop index for functions of polynomial + +! polynomial functions + real f ( npoly ) + +! coefficients of polynomials + real a ( ncoeff, npoly ) + + real temp, rh, nh3conc, so4vol ! bounded values of the input args + real log_rh, log_nh3conc, log_so4vol + +! coefficients of polynomials fi(t), i = 1, 20 + data a / -0.355297, -33.8449, 0.34536, -8.24007e-4, & + 3.13735, -0.772861, 5.61204e-3, -9.74576e-6, & + 19.0359, -0.170957, 4.79808e-4, -4.14699e-7, & + 1.07605, 1.48932, -7.96052e-3, 7.61229e-6, & + 6.0916, -1.25378, 9.39836e-3, -1.74927e-5, & + 0.31176, 1.64009, -3.43852e-3, -1.09753e-5, & + -2.00738e-2, -0.752115, 5.25813e-3, -8.98038e-6, & + 0.165536, 3.26623, -4.89703e-2, 1.46967e-4, & + 6.52645, -0.258002, 1.43456e-3, -2.02036e-6, & + 3.68024, -0.204098, 1.06259e-3, -1.2656e-6 , & + -6.6514e-2, -7.82382, 1.22938e-2, 6.18554e-5, & + 0.65874, 0.190542, -1.65718e-3, 3.41744e-6, & + 5.99321e-2, 5.96475, -3.62432e-2, 4.93337e-5, & + -0.732731, -1.84179e-2, 1.47186e-4, -2.37711e-7, & + 0.728429, 3.64736, -2.7422e-2, 4.93478e-5, & + 41.3016, -0.35752, 9.04383e-4, -5.73788e-7, & + -0.160336, 8.89881e-3, -5.39514e-5, 8.39522e-8, & + 8.57868, -0.112358, 4.72626e-4, -6.48365e-7, & + 5.30167e-2, -1.98815, 1.57827e-2, -2.93564e-5, & + -2.32736, 2.34646e-2, -7.6519e-5, 8.0459e-8 / + + +! +! apply limits to input parameters +! + temp = max( 240.15, min (300.15, temp_in ) ) + rh = max( 0.05, min (0.95, rh_in ) ) + so4vol = max( 1.0e4, min (1.0e9, so4vol_in ) ) + nh3conc = max( 0.1, min (100.0, nh3conc_in ) ) + +! +! calculate the functions of polynomials, fi(t), i = 1, npoly +! at temperature j +! + do n = 1, npoly + f ( n ) = a ( 1, n ) + a ( 2, n ) * temp & + + a ( 3, n ) * ( temp ) ** 2.0 & + + a ( 4, n ) * ( temp ) ** 3.0 + end do + +! +! calculate ln (j) +! + log_rh = log ( rh ) + log_nh3conc = log ( nh3conc ) + log_so4vol = log ( so4vol ) + rateloge = -84.7551 & + + f ( 1 ) / log_so4vol & + + f ( 2 ) * ( log_so4vol ) & + + f ( 3 ) * ( log_so4vol ) **2.0 & + + f ( 4 ) * ( log_nh3conc ) & + + f ( 5 ) * ( log_nh3conc ) **2.0 & + + f ( 6 ) * rh & + + f ( 7 ) * ( log_rh ) & + + f ( 8 ) * ( log_nh3conc / & + log_so4vol ) & + + f ( 9 ) * ( log_nh3conc * & + log_so4vol ) & + + f ( 10 ) * rh * & + ( log_so4vol ) & + + f ( 11 ) * ( rh / & + log_so4vol ) & + + f ( 12 ) * ( rh * & + log_nh3conc ) & + + f ( 13 ) * ( log_rh / & + log_so4vol ) & + + f ( 14 ) * ( log_rh * & + log_nh3conc ) & + + f ( 15 ) * (( log_nh3conc ) ** 2.0 & + / log_so4vol ) & + + f ( 16 ) * ( log_so4vol * & + ( log_nh3conc ) ** 2.0 ) & + + f ( 17 ) * (( log_so4vol ) ** 2.0 * & + log_nh3conc ) & + + f ( 18 ) * ( rh * & + ( log_nh3conc ) ** 2.0 ) & + + f ( 19 ) * ( rh * log_nh3conc & + / log_so4vol ) & + + f ( 20 ) * (( log_so4vol ) ** 2.0 * & + ( log_nh3conc ) ** 2.0 ) + + ratenuclt = exp ( rateloge ) +! +! calculate number of molecules and critical radius of the cluster +! + cnum_h2so4 = 38.1645 + 0.774106 * rateloge & + + 0.00298879 * ( rateloge ) ** 2.0 & + - 0.357605 * temp & + - 0.00366358 * temp * rateloge & + + 0.0008553 * ( temp ) ** 2.0 + + cnum_nh3 = 26.8982 + 0.682905 * rateloge & + + 0.00357521 * ( rateloge ) ** 2.0 & + - 0.265748 * temp & + - 0.00341895 * temp * rateloge & + + 0.000673454 * ( temp ) ** 2.0 + + cnum_tot = 79.3484 + 1.7384 * rateloge & + + 0.00711403 * ( rateloge ) ** 2.0 & + - 0.744993 * temp & + - 0.00820608 * temp * rateloge & + + 0.0017855 * ( temp ) ** 2.0 + + radius_cluster = 0.141027 - 0.00122625 * rateloge & + - 7.82211e-6 * ( rateloge ) ** 2.0 & + - 0.00156727 * temp & + - 0.00003076 * temp * rateloge & + + 0.0000108375 * ( temp ) ** 2.0 + + return + end subroutine ternary_nuc_napari + + + +!----------------------------------------------------------------------- + subroutine wexler_nuc_mosaic_1box( & + dtnuc, temp_in, rh_in, cair, & + qh2so4_avg, qh2so4_cur, qnh3_avg, qnh3_cur, & + nsize, maxd_asize, volumlo_sect, volumhi_sect, & + isize_nuc, qnuma_del, qso4a_del, qnh4a_del, & + qh2so4_del, qnh3_del, dens_nh4so4a ) +!....................................................................... +! +! calculates new particle production from h2so4-h2o binary nucleation +! over timestep dtnuc, using the wexler et al. (1994) parameterization +! +! the size of new particles is the lower-bound size of the host code's +! smallest size bin. their composition is so4 and nh4, since the nuclei +! would incorporate nh3 as they grow from ~1 nm to the lower-bound size. +! (the new particle composition can be forced to pure so4 by setting +! the qnh3_avg & qnh3_cur input arguments to 0.0). +! +! revision history +! coded by rc easter, pnnl, 20-mar-2006 +! +! key routines called: none +! +! references: +! wexler, a. s., f. w. lurmann, and j. h. seinfeld, +! modelling urban and regional aerosols -- i. model development, +! atmos. environ., 28, 531-546, 1994. +! +!....................................................................... + implicit none + +! subr arguments (in) + real, intent(in) :: dtnuc ! nucleation time step (s) + real, intent(in) :: temp_in ! temperature, in k + real, intent(in) :: rh_in ! relative humidity, as fraction + real, intent(in) :: cair ! dry-air molar density (mole-air/cm3) + + real, intent(in) :: qh2so4_avg, qh2so4_cur ! gas h2so4 mixing ratios (ppm) + real, intent(in) :: qnh3_avg, qnh3_cur ! gas nh3 mixing ratios (ppm) + ! qxxx_cur = current value (at end of condensation) + ! qxxx_avg = average value (from start to end of condensation) + + integer, intent(in) :: nsize ! number of aerosol size bins + integer, intent(in) :: maxd_asize ! dimension for volumlo_sect, ... + real, intent(in) :: volumlo_sect(maxd_asize) ! dry volume at lower bnd of bin (cm3) + real, intent(in) :: volumhi_sect(maxd_asize) ! dry volume at upper bnd of bin (cm3) + +! subr arguments (out) + integer, intent(out) :: isize_nuc ! size bin into which new particles go + real, intent(out) :: qnuma_del ! change to aerosol number mixing ratio (#/kg) + real, intent(out) :: qso4a_del ! change to aerosol so4 mixing ratio (ug/kg) + real, intent(out) :: qnh4a_del ! change to aerosol nh4 mixing ratio (ug/kg) + real, intent(out) :: qh2so4_del ! change to gas h2so4 mixing ratio (ppm) + real, intent(out) :: qnh3_del ! change to gas nh3 mixing ratio (ppm) + ! aerosol changes are > 0; gas changes are < 0 + +! subr arguments (inout) + real, intent(inout) :: dens_nh4so4a ! dry-density of the new nh4-so4 aerosol mass (g/cm3) + ! use 'in' value only if it is between 1.6-2.0 g/cm3 + +! local variables + integer i + integer, save :: icase = 0, icase_reldiffmax = 0 + + real, parameter :: pi = 3.1415926536 + real, parameter :: avogad = 6.022e23 ! avogadro number (molecules/mole) + real, parameter :: mw_air = 28.966 ! dry-air mean molecular weight (g/mole) + +! dry densities (g/cm3) molecular weights of aerosol +! ammsulf, ammbisulf, and sulfacid (from mosaic dens_electrolyte values) + real, parameter :: dens_ammsulf = 1.769 + real, parameter :: dens_ammbisulf = 1.78 + real, parameter :: dens_sulfacid = 1.841 + +! molecular weights (g/mole) of aerosol ammsulf, ammbisulf, and sulfacid +! for ammbisulf and sulfacid, use 114 & 96 here rather than 115 & 98 +! because we don't keep track of aerosol hion mass + real, parameter :: mw_ammsulf = 132.0 + real, parameter :: mw_ammbisulf = 114.0 + real, parameter :: mw_sulfacid = 96.0 +! molecular weights of aerosol sulfate and ammonium + real, parameter :: mw_so4a = 96.0 + real, parameter :: mw_nh4a = 18.0 + + real, save :: reldiffmax = 0.0 + + real ch2so4_crit ! critical h2so4 conc (ug/m3) + real dens_part ! "grown" single-particle dry density (g/cm3) + real duma, dumb, dumc, dume + real dum_m1, dum_m2, dum_m3, dum_n1, dum_n2, dum_n3 + real fogas, foso4a, fonh4a, fonuma + real mass_part ! "grown" single-particle mass (g) + real molenh4a_per_moleso4a ! (mole aerosol nh4)/(mole aerosol so4) + real qh2so4_crit ! critical h2so4 mixrat (ppm) + real qh2so4_avail ! amount of h2so4 available for new particles (ppm) + real vol_part ! "grown" single-particle volume (cm3) + + +! +! initialization output arguments with "zero nucleation" values +! + isize_nuc = 1 + qnuma_del = 0.0 + qso4a_del = 0.0 + qnh4a_del = 0.0 + qh2so4_del = 0.0 + qnh3_del = 0.0 + +! +! calculate critical h2so4 concentration (ug/m3) and mixing ratio (mole/mole-air) +! + ch2so4_crit = 0.16 * exp( 0.1*temp_in - 3.5*rh_in - 27.7 ) +! ch2so4 = (ug-h2so4/m3-air) +! ch2so4*1.0e-12/mwh2so4 = (mole-h2so4/cm3-air) + qh2so4_crit = (ch2so4_crit*1.0e-12/98.0)/cair + qh2so4_avail = qh2so4_cur - qh2so4_crit + +! if "available" h2so4 vapor < 4.0e-18 mole/mole-air ~= 1.0e2 molecules/cm3, +! exit with new particle formation = 0 + if (qh2so4_avail .le. 4.0e-18) then + return + end if + +! determine size bin into which the new particles go + isize_nuc = 1 + vol_part = volumlo_sect(1) + +! +! determine composition and density of the "grown particles" +! the grown particles are assumed to be liquid +! (since critical clusters contain water) +! so any (nh4/so4) molar ratio between 0 and 2 is allowed +! assume that the grown particles will have +! (nh4/so4 molar ratio) = min( 2, (nh3/h2so4 gas molar ratio) ) +! + if (qnh3_cur .ge. qh2so4_avail) then +! combination of ammonium sulfate and ammonium bisulfate +! dum_n1 & dum_n2 = mole fractions of the ammsulf & ammbisulf + dum_n1 = (qnh3_cur/qh2so4_avail) - 1.0 + dum_n1 = max( 0.0, min( 1.0, dum_n1 ) ) + dum_n2 = 1.0 - dum_n1 + dum_n3 = 0.0 + else +! combination of ammonium bisulfate and sulfuric acid +! dum_n2 & dum_n3 = mole fractions of the ammbisulf & sulfacid + dum_n1 = 0.0 + dum_n2 = (qnh3_cur/qh2so4_avail) + dum_n2 = max( 0.0, min( 1.0, dum_n2 ) ) + dum_n3 = 1.0 - dum_n2 + end if + + dum_m1 = dum_n1*mw_ammsulf + dum_m2 = dum_n2*mw_ammbisulf + dum_m3 = dum_n3*mw_sulfacid + dens_part = (dum_m1 + dum_m2 + dum_m3)/ & + ((dum_m1/dens_ammsulf) + (dum_m2/dens_ammbisulf) & + + (dum_m3/dens_sulfacid)) +! 25-jul-2006 - use 'in' value only if it is between 1.6-2.0 g/cm3 + if (abs(dens_nh4so4a-1.8) .le. 0.2) then + dens_part = dens_nh4so4a + else + dens_nh4so4a = dens_part + end if + mass_part = vol_part*dens_part + molenh4a_per_moleso4a = 2.0*dum_n1 + dum_n2 + + +! changes to h2so4 & nh3 gas (in mole/mole-air), limited by amounts available + duma = 0.9999 + qh2so4_del = min( duma*qh2so4_cur, qh2so4_avail ) + qnh3_del = min( duma*qnh3_cur, qh2so4_del*molenh4a_per_moleso4a ) + qh2so4_del = -qh2so4_del + qnh3_del = -qnh3_del + +! changes to so4 & nh4 aerosol (in mole/mole-air) + qso4a_del = -qh2so4_del + qnh4a_del = -qnh3_del +! change to aerosol number (in #/mole-air) + qnuma_del = (qso4a_del*mw_so4a + qnh4a_del*mw_nh4a)/mass_part + + + return + end subroutine wexler_nuc_mosaic_1box + + + + +!----------------------------------------------------------------------- + + + + end module module_mosaic_newnuc diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F new file mode 100644 index 00000000..88e440d8 --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -0,0 +1,13048 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + module module_mosaic_therm + + + + use module_data_mosaic_therm + use module_peg_util + + + + implicit none + + intrinsic max, min + + contains + + + +! zz01aerchemistry.f (mosaic.21.0) +! 05-feb-07 wig - converted to double +! 10-jan-07 raz - contains major revisions and updates. new module ASTEM replaces ASTEEM. +! 04-aug-06 raz - fixed bugs in asteem_flux_mix_case3a and asteem_flux_mix_case3b +! revised treatment of kelvin effect. +! 06-jun-06 rce - changed dens_aer_mac(ica_a) & (ico3_a) from 2.5 to 2.6 +! 31-may-06 rce - got latest version from +! nirvana:/home/zaveri/rahul/pegasus/pegasus.3.1.1/src +! in subr map_mosaic_species, turned off mapping +! of soa species +! 18-may-06 raz - major revisions in asteem and minor changes in mesa +! 22-jan-06 raz - revised nh4no3 and nh4cl condensation algorithm +! 07-jan-06 raz - improved asteem algorithm +! 28-apr-05 raz - reversed calls to form_cacl2 and form_nacl +! fixed caco3 error in subr. electrolytes_to_ions +! renamed dens_aer to dens_aer_mac; mw_aer to mw_aer_mac +! 27-apr-05 raz - updated dry_mass calculation approach in mesa_convergence +! 22-apr-05 raz - fixed caso4 mass balance problem and updated algorithm to +! calculate phi_volatile for nh3, hno3, and hcl. +! 20-apr-05 raz - updated asceem +! 19-apr-05 raz - updated the algorithm to constrain the nh4 concentration +! during simultaneous nh3, hno3, and hcl integration such +! that it does not exceed the max possible value for a given bin +! 14-apr-05 raz - fixed asteem_flux_wet_case3 and asteem_flux_dry_case3c +! 11-jan-05 raz - major updates to many subroutines +! 18-nov-04 rce - make sure that acos argument is between +/-1.0 +! 28-jan-04 rce - added subr aerchem_boxtest_output; +! eliminated some unnecessary 'include v33com-' +! 01-dec-03 rce - added 'implicit none' to many routines; +! eliminated some unnecessary 'include v33com-' +! 05-oct-03 raz - added hysteresis treatment +! 02-sep-03 raz - implemented asteem +! 10-jul-03 raz - changed ix to ixd in interp. subrs fast*_up and fast*_lo +! 08-jul-03 raz - implemented asteem (adaptive step time-split +! explicit euler method) +! 26-jun-03 raz - updated almost all the subrs. this version contains +! options for rigorous and fast solvers (including lsode solver) +! +! 07-oct-02 raz - made zx and zm integers in activity coeff subs. +! 16-sep-02 raz - updated many subrs to treat calcium salts +! 19-aug-02 raz - inlcude v33com9a in subr aerosolmtc +! 14-aug-02 rce - '(msectional.eq.0)' changed to '(msectional.le.0)' +! 07-aug-02 rce - this is rahul's latest version from freshair +! after adding 'real mean_molecular_speed' wherever it is used +! 01-apr-02 raz - made final tests and gave the code to jerome +! +! 04--14-dec-01 rce - several minor changes during initial testing/debug +! in 3d los angeles simulation +! (see earlier versions for details about these changes) +!----------------------------------------------------------------------- +!23456789012345678901234567890123456789012345678901234567890123456789012 + +!*********************************************************************** +! interface to mosaic +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine aerchemistry( iclm, jclm, kclm_calcbgn, kclm_calcend, & + dtchem_sngl, idiagaa ) + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_mosaic_movesect, only: move_sections + +! implicit none +! include 'v33com' +! include 'v33com2' +! include 'v33com3' +! include 'mosaic.h' +! subr arguments + integer iclm, jclm, kclm_calcbgn, kclm_calcend, idiagaa + real dtchem_sngl +! local variables + real(kind=8) :: dtchem + integer k, m + + + + dtchem = dtchem_sngl + + lunerr_aer = lunerr + ncorecnt_aer = ncorecnt + +! special output for solver testing + call aerchem_boxtest_output( 1, iclm, jclm, 0, 0, dtchem ) + + iclm_aer = iclm + jclm_aer = jclm + kclm_aer_calcbgn = kclm_calcbgn + kclm_aer_calcend = kclm_calcend + + + do 200 m = 1, nsubareas + mclm_aer = m + + do 100 k = kclm_aer_calcbgn, kclm_aer_calcend + + kclm_aer = k + if (afracsubarea(k,m) .lt. 1.e-4) goto 100 + + istat_mosaic_fe1 = 1 + + call mosaic( k, m, dtchem ) + + if (istat_mosaic_fe1 .lt. 0) then + nfe1_mosaic_cur = nfe1_mosaic_cur + 1 + nfe1_mosaic_tot = nfe1_mosaic_tot + 1 + if (iprint_mosaic_fe1 .gt. 0) then + write(6,*) 'mosaic aerchemistry fatal error - i/j/k/m =', & + iclm_aer, jclm_aer, kclm_aer, mclm_aer + call print_input + if (iprint_mosaic_fe1 .ge. 10) & + call mosaic_aerchem_error_dump( 0, 0, lunerr_aer, & + 'aerchemistry fatal error' ) + end if + goto 100 + end if + + call specialoutaa( iclm, jclm, k, m, 'befor_movesect' ) + call move_sections( 1, iclm, jclm, k, m) + call specialoutaa( iclm, jclm, k, m, 'after_movesect' ) + +100 continue ! k levels + +200 continue ! subareas + + +! special output for solver testing + call aerchem_boxtest_output( 3, iclm, jclm, 0, 0, dtchem ) + + return + end subroutine aerchemistry + + + + + + + + + + +!*********************************************************************** +! mosaic (model for simulating aerosol interactions and chemistry) +! +! author: rahul a. zaveri +! update: dec 2004 +!----------------------------------------------------------------------- + subroutine mosaic(k, m, dtchem) + + use module_data_mosaic_asect + use module_data_mosaic_other + +! implicit none +! include 'v33com' +! include 'v33com3' +! include 'mosaic.h' +! subr arguments + integer k, m + real(kind=8) dtchem +! local variables + real(kind=8) yh2o, dumdum + integer iclm_debug, jclm_debug, kclm_debug, ncnt_debug +! data iclm_debug /28/ +! data jclm_debug /1/ +! data kclm_debug /9/ +! data ncnt_debug /6/ + iclm_debug=-28; jclm_debug=1; kclm_debug=9; ncnt_debug=6 + + + + if(iclm_aer .eq. iclm_debug .and. & + jclm_aer .eq. jclm_debug .and. & + kclm_aer .eq. kclm_debug .and. & + ncorecnt_aer .eq. ncnt_debug)then + dumdum = 0.0 + endif + + +! overwrite inputs + if(1.eq.0)then + call hijack_input(k,m) + endif + + + t_k = rsub(ktemp,k,m) ! update temperature = k + p_atm = ptotclm(k) /1.032d6 ! update pressure = atm + yh2o = rsub(kh2o,k,m) ! mol(h2o)/mol(air) + rh_pc = 100.*relhumclm(k) ! rh (%) + ah2o = relhumclm(k) ! fractional rh + + + call load_mosaic_parameters ! sets up indices and other stuff once per simulation + + call initialize_mosaic_variables + + call update_thermodynamic_constants ! update t and rh dependent constants + + call map_mosaic_species(k, m, 0) + + + call overall_massbal_in ! save input mass over all bins + iprint_input = myes ! reset to default + + + call mosaic_dynamic_solver( dtchem ) + if (istat_mosaic_fe1 .lt. 0) return + + + call overall_massbal_out(0) ! check mass balance after integration + + call map_mosaic_species(k, m, 1) + +! write(6,*)' done ijk', iclm_aer, jclm_aer, kclm_aer + + return + end subroutine mosaic + + + + + + + + + + + + +!*********************************************************************** +! interface to asceem and asteem dynamic gas-particle exchange solvers +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mosaic_dynamic_solver( dtchem ) +! implicit none +! include 'v33com' +! include 'mosaic.h' +! subr arguments + real(kind=8) dtchem +! local variables + integer ibin, iv, k, m + real(kind=8) xt, dumdum +! real(kind=8) aerosol_water_up ! mosaic func + + +! if(iclm_aer .eq. 21 .and. & +! jclm_aer .eq. 17 .and. & +! kclm_aer .eq. 3 .and. & +! ncorecnt_aer .eq. 4)then +! dumdum = 0.0 +! endif + + + do 500 ibin = 1, nbin_a + + call check_aerosol_mass(ibin) + if(jaerosolstate(ibin) .eq. no_aerosol)goto 500 + + call conform_electrolytes(jtotal,ibin,xt) ! conforms aer(jtotal) to a valid aerosol + + call check_aerosol_mass(ibin) ! check mass again after conform_electrolytes + if(jaerosolstate(ibin) .eq. no_aerosol)goto 500 ! ignore this bin + + call conform_aerosol_number(ibin) ! adjusts number conc so that it conforms with bin mass and diameter + +500 continue + + + +! box +! call initial_aer_print_box ! box + + call save_pregrow_props + + call specialoutaa( iclm_aer, jclm_aer, kclm_aer, 77, & + 'after_conform' ) +! +!------------------------------------- +! do dynamic gas-aerosol mass transfer + + if(mgas_aer_xfer .eq. mon)then + + call astem(dtchem) + + endif + +!------------------------------------- +! box +! grows or shrinks size depending on mass increase or decrease +! +! do ibin = 1, nbin_a +! if(jaerosolstate(ibin) .ne. no_aerosol)then +! call conform_particle_size(ibin) ! box +! endif +! enddo + + + + do 600 ibin = 1, nbin_a + if(jaerosolstate(ibin).eq.no_aerosol) goto 600 + + if(jhyst_leg(ibin) .eq. jhyst_lo)then + water_a_hyst(ibin) = 0.0 + elseif(jhyst_leg(ibin) .eq. jhyst_up)then + water_a_up(ibin) = aerosol_water_up(ibin) ! at 60% rh + water_a_hyst(ibin) = water_a_up(ibin) + endif + + call calc_dry_n_wet_aerosol_props(ibin) ! compute final mass and density +600 continue + + return + end subroutine mosaic_dynamic_solver + + + + + + + + + + + + + + + subroutine hijack_input(k, m) + + use module_data_mosaic_asect + use module_data_mosaic_other + +! implicit none +! include 'v33com' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' +! include 'mosaic.h' +! subr arguments + integer k, m +! local variables + integer ibin, igas, iphase, isize, itype + real(kind=8) t_kdum, p_atmdum, rhdum, cairclmdum + real(kind=8) gasdum(4), aerdum(14,8) + + + + +! read inputs---------------- + open(92, file = 'box.txt') + + read(92,*)t_kdum, p_atmdum, rhdum, cairclmdum +! do igas = 1, 4 + read(92,*)gasdum(1),gasdum(2),gasdum(3),gasdum(4) +! enddo + + do ibin = 1, nbin_a + read(92,*)aerdum(1,ibin),aerdum(2,ibin),aerdum(3,ibin), & + aerdum(4,ibin),aerdum(5,ibin),aerdum(6,ibin), & + aerdum(7,ibin),aerdum(8,ibin),aerdum(9,ibin), & + aerdum(10,ibin),aerdum(11,ibin),aerdum(12,ibin), & + aerdum(13,ibin),aerdum(14,ibin) + enddo + + close(92) +!---------------------------- + + + + rsub(ktemp,k,m) = t_kdum ! update temperature = k + ptotclm(k) = p_atmdum*1.032d6! update pressure = atm + relhumclm(k) = rhdum/100.0 ! fractional rh + cairclm(k) = cairclmdum ! mol/cc + + +! 3-d +! calculate air conc in mol/m^3 + cair_mol_m3 = cairclm(k)*1.e6 ! cairclm(k) is in mol/cc + cair_mol_cc = cairclm(k) + +! 3-d +! define conversion factors + conv1a = cair_mol_m3*1.e9 ! converts q/mol(air) to nq/m^3 (q = mol or g) + conv1b = 1./conv1a ! converts nq/m^3 to q/mol(air) + conv2a = cair_mol_m3*18.*1.e-3 ! converts mol(h2o)/mol(air) to kg(h2o)/m^3(air) + conv2b = 1./conv2a ! converts kg(h2o)/m^3(air) to mol(h2o)/mol(air) + + +! read rsub (mol/mol(air)) +! gas + rsub(kh2so4,k,m) = gasdum(1) + rsub(khno3,k,m) = gasdum(2) + rsub(khcl,k,m) = gasdum(3) + rsub(knh3,k,m) = gasdum(4) + + +! aerosol: rsub [mol/mol (air) or g/mol(air)] + iphase = ai_phase + ibin = 0 + do 10 itype = 1, ntype_aer + do 10 isize = 1, nsize_aer(itype) + ibin = ibin + 1 + + rsub(lptr_so4_aer(isize,itype,iphase),k,m) = aerdum(1,ibin) + rsub(lptr_no3_aer(isize,itype,iphase),k,m) = aerdum(2,ibin) + rsub(lptr_cl_aer(isize,itype,iphase),k,m) = aerdum(3,ibin) + rsub(lptr_nh4_aer(isize,itype,iphase),k,m) = aerdum(4,ibin) + rsub(lptr_oc_aer(isize,itype,iphase),k,m) = aerdum(5,ibin) + rsub(lptr_co3_aer(isize,itype,iphase),k,m) = aerdum(6,ibin) + rsub(lptr_msa_aer(isize,itype,iphase),k,m) = aerdum(7,ibin) + rsub(lptr_bc_aer(isize,itype,iphase),k,m) = aerdum(8,ibin) + rsub(lptr_na_aer(isize,itype,iphase),k,m) = aerdum(9,ibin) + rsub(lptr_ca_aer(isize,itype,iphase),k,m) = aerdum(10,ibin) + rsub(lptr_oin_aer(isize,itype,iphase),k,m) = aerdum(11,ibin) + + rsub(hyswptr_aer(isize,itype),k,m) = aerdum(12,ibin) ! kg/m^3(air) + rsub(waterptr_aer(isize,itype),k,m) = aerdum(13,ibin) ! kg/m^3(air) + rsub(numptr_aer(isize,itype,iphase),k,m) = aerdum(14,ibin) ! num_a is in #/cc +10 continue + + return + end subroutine hijack_input + + + + + +!*********************************************************************** +! intializes all the mosaic variables to zero or their default values. +! +! author: rahul a. zaveri +! update: jun 2003 +!----------------------------------------------------------------------- + subroutine initialize_mosaic_variables +! implicit none +! include 'mosaic.h' +! local variables + integer iaer, ibin, iv, ja, jc, je + + + + do iv = 1, ngas_ioa + gas(iv) = 0.0 + enddo + +! initialize to zero + do ibin = 1, nbin_a + + num_a(ibin) = 0.0 + mass_dry_a(ibin) = 0.0 + mass_soluble_a(ibin) = 0.0 + + do iaer = 1, naer + aer(iaer,jtotal,ibin) = 0.0 + aer(iaer,jsolid,ibin) = 0.0 + aer(iaer,jliquid,ibin) = 0.0 + enddo + + do je = 1, nelectrolyte + electrolyte(je,jtotal,ibin) = 0.0 + electrolyte(je,jsolid,ibin) = 0.0 + electrolyte(je,jliquid,ibin) = 0.0 + activity(je,ibin) = 0.0 + gam(je,ibin) = 0.0 + enddo + + gam_ratio(ibin) = 0.0 + + do iv = 1, ngas_ioa + flux_s(iv,ibin) = 0.0 + flux_l(iv,ibin) = 0.0 + kg(iv,ibin) = 0.0 + phi_volatile_s(iv,ibin) = 0.0 + phi_volatile_l(iv,ibin) = 0.0 + df_gas_s(iv,ibin) = 0.0 + df_gas_l(iv,ibin) = 0.0 + volatile_s(iv,ibin) = 0.0 + enddo + + + jaerosolstate(ibin) = -1 ! initialize to default value + jphase(ibin) = 0 + + do jc = 1, ncation + mc(jc,ibin) = 0.0 + enddo + + do ja = 1, nanion + ma(ja,ibin) = 0.0 + enddo + + enddo ! ibin + + + return + end subroutine initialize_mosaic_variables + + + + + + +!*********************************************************************** +! maps rsub(k,l,m) to and from mosaic arrays: gas and aer +! +! author: rahul a. zaveri +! update: nov 2001 +!------------------------------------------------------------------------- + subroutine map_mosaic_species(k, m, imap) + + use module_data_mosaic_asect + use module_data_mosaic_other + use module_state_description, only: param_first_scalar + +! implicit none + +! include 'v33com' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' + +! subr arguments + integer k, m, imap +! local variables + integer ibin, iphase, isize, itsi, itype, l, p1st + + +! if a species index is less than this value, then the species is not defined + p1st = param_first_scalar + +! 3-d +! calculate air conc in mol/m^3 + cair_mol_m3 = cairclm(k)*1.e6 ! cairclm(k) is in mol/cc + cair_mol_cc = cairclm(k) + +! 3-d +! define conversion factors + conv1a = cair_mol_m3*1.d9 ! converts q/mol(air) to nq/m^3 (q = mol or g) + conv1b = 1.d0/conv1a ! converts nq/m^3 to q/mol(air) + conv2a = cair_mol_m3*18.*1.d-3 ! converts mol(h2o)/mol(air) to kg(h2o)/m^3(air) + conv2b = 1.d0/conv2a ! converts kg(h2o)/m^3(air) to mol(h2o)/mol(air) + + +! box +! conv1 = 1.d15/avogad ! converts (molec/cc) to (nmol/m^3) +! conv2 = 1.d0/conv1 ! converts (nmol/m^3) to (molec/cc) +! kaerstart = ngas_max + + + if(imap.eq.0)then ! map rsub (mol/mol(air)) into aer (nmol/m^3) +! gas + if (kh2so4 .ge. p1st) then + gas(ih2so4_g) = rsub(kh2so4,k,m)*conv1a ! nmol/m^3 + else + gas(ih2so4_g) = 0.0 + end if + if (khno3 .ge. p1st) then + gas(ihno3_g) = rsub(khno3,k,m)*conv1a + else + gas(ihno3_g) = 0.0 + end if + if (khcl .ge. p1st) then + gas(ihcl_g) = rsub(khcl,k,m)*conv1a + else + gas(ihcl_g) = 0.0 + end if + if (knh3 .ge. p1st) then + gas(inh3_g) = rsub(knh3,k,m)*conv1a + else + gas(inh3_g) = 0.0 + end if + +! soa gas-phase species -- currently deactivated +! if (karo1 .ge. p1st) then +! gas(iaro1_g) = rsub(karo1,k,m)*conv1a +! else + gas(iaro1_g) = 0.0 +! end if +! if (karo2 .ge. p1st) then +! gas(iaro2_g) = rsub(karo2,k,m)*conv1a +! else + gas(iaro2_g) = 0.0 +! end if +! if (kalk1 .ge. p1st) then +! gas(ialk1_g) = rsub(kalk1,k,m)*conv1a +! else + gas(ialk1_g) = 0.0 +! end if +! if (kole1 .ge. p1st) then +! gas(iole1_g) = rsub(kole1,k,m)*conv1a +! else + gas(iole1_g) = 0.0 +! end if +! if (kapi1 .ge. p1st) then +! gas(iapi1_g) = rsub(kapi1,k,m)*conv1a +! else + gas(iapi1_g) = 0.0 +! end if +! if (kapi2 .ge. p1st) then +! gas(iapi2_g) = rsub(kapi2,k,m)*conv1a +! else + gas(iapi2_g) = 0.0 +! end if +! if (klim1 .ge. p1st) then +! gas(ilim1_g) = rsub(klim1,k,m)*conv1a +! else + gas(ilim1_g) = 0.0 +! end if +! if (klim2 .ge. p1st) then +! gas(ilim2_g) = rsub(klim2,k,m)*conv1a +! else + gas(ilim2_g) = 0.0 +! end if + + +! aerosol + iphase = ai_phase + ibin = 0 + do 10 itype = 1, ntype_aer + do 10 isize = 1, nsize_aer(itype) + ibin = ibin + 1 + +! aer array units are nmol/(m^3 air) + +! rce 18-nov-2004 - always map so4 and number, +! but only map other species when (lptr_xxx .ge. p1st) +! rce 11-may-2006 - so4 mapping now optional + l = lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iso4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iso4_a,jtotal,ibin)=0.0 + end if + + l = lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ino3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ino3_a,jtotal,ibin)=0.0 + end if + + l = lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(icl_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(icl_a,jtotal,ibin)=0.0 + end if + + l = lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(inh4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(inh4_a,jtotal,ibin)=0.0 + end if + + l = lptr_oc_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ioc_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ioc_a,jtotal,ibin)=0.0 + end if + + l = lptr_bc_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibc_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibc_a,jtotal,ibin)=0.0 + end if + + l = lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ina_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ina_a,jtotal,ibin)=0.0 + end if + + l = lptr_oin_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ioin_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ioin_a,jtotal,ibin)=0.0 + end if + + l = lptr_msa_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(imsa_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(imsa_a,jtotal,ibin)=0.0 + end if + + l = lptr_co3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ico3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ico3_a,jtotal,ibin)=0.0 + end if + + l = lptr_ca_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ica_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ica_a,jtotal,ibin)=0.0 + end if + +! soa aerosol-phase species -- currently deactivated +! l = lptr_aro1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iaro1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iaro1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_aro2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iaro2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iaro2_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_alk1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ialk1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ialk1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_ole1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iole1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iole1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_api1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iapi1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iapi1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_api2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iapi2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iapi2_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_lim1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ilim1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ilim1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_lim2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ilim2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ilim2_a,jtotal,ibin)=0.0 +! end if + +! water_a and water_a_hyst units are kg/(m^3 air) + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) then + water_a_hyst(ibin)=rsub(l,k,m)*conv2a + else + water_a_hyst(ibin)=0.0 + end if + +! water_a units are kg/(m^3 air) + l = waterptr_aer(isize,itype) + if (l .ge. p1st) then + water_a(ibin)=rsub(l,k,m)*conv2a + else + water_a(ibin)=0.0 + end if + +! num_a units are #/(cm^3 air) + l = numptr_aer(isize,itype,iphase) + num_a(ibin) = rsub(l,k,m)*cair_mol_cc + +! other bin parameters (fixed for now) + sigmag_a(ibin) = 1.02 + +10 continue + + + + +!--------------------------------------------------------------------- + + + else ! map aer & gas (nmol/m^3) back into rsub (mol/mol(air)) + + + +! gas + if (kh2so4 .ge. p1st) & + rsub(kh2so4,k,m) = gas(ih2so4_g)*conv1b + if (khno3 .ge. p1st) & + rsub(khno3,k,m) = gas(ihno3_g)*conv1b + if (khcl .ge. p1st) & + rsub(khcl,k,m) = gas(ihcl_g)*conv1b + if (knh3 .ge. p1st) & + rsub(knh3,k,m) = gas(inh3_g)*conv1b + +! soa gas-phase species -- currently deactivated +! if (karo1 .ge. p1st) & +! rsub(karo1,k,m) = gas(iaro1_g)*conv1b +! if (karo2 .ge. p1st) & +! rsub(karo2,k,m) = gas(iaro2_g)*conv1b +! if (kalk1 .ge. p1st) & +! rsub(kalk1,k,m) = gas(ialk1_g)*conv1b +! if (kole1 .ge. p1st) & +! rsub(kole1,k,m) = gas(iole1_g)*conv1b +! if (kapi1 .ge. p1st) & +! rsub(kapi1,k,m) = gas(iapi1_g)*conv1b +! if (kapi2 .ge. p1st) & +! rsub(kapi2,k,m) = gas(iapi2_g)*conv1b +! if (klim1 .ge. p1st) & +! rsub(klim1,k,m) = gas(ilim1_g)*conv1b +! if (klim2 .ge. p1st) & +! rsub(klim2,k,m) = gas(ilim2_g)*conv1b + +! aerosol + iphase = ai_phase + ibin = 0 + do 20 itype = 1, ntype_aer + do 20 isize = 1, nsize_aer(itype) + ibin = ibin + 1 + + +! rce 18-nov-2004 - always map so4 and number, +! but only map other species when (lptr_xxx .ge. p1st) + l = lptr_so4_aer(isize,itype,iphase) + rsub(l,k,m) = aer(iso4_a,jtotal,ibin)*conv1b + + l = lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ino3_a,jtotal,ibin)*conv1b + + l = lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(icl_a,jtotal,ibin)*conv1b + + l = lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(inh4_a,jtotal,ibin)*conv1b + + l = lptr_oc_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ioc_a,jtotal,ibin)*conv1b + + l = lptr_bc_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibc_a,jtotal,ibin)*conv1b + + l = lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ina_a,jtotal,ibin)*conv1b + + l = lptr_oin_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ioin_a,jtotal,ibin)*conv1b + + l = lptr_msa_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(imsa_a,jtotal,ibin)*conv1b + + l = lptr_co3_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ico3_a,jtotal,ibin)*conv1b + + l = lptr_ca_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ica_a,jtotal,ibin)*conv1b + +! soa aerosol-phase species -- currently deactivated +! l = lptr_aro1_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(iaro1_a,jtotal,ibin)*conv1b + +! l = lptr_aro2_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(iaro2_a,jtotal,ibin)*conv1b + +! l = lptr_alk1_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(ialk1_a,jtotal,ibin)*conv1b + +! l = lptr_ole1_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(iole1_a,jtotal,ibin)*conv1b + +! l = lptr_api1_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(iapi1_a,jtotal,ibin)*conv1b + +! l = lptr_api2_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(iapi2_a,jtotal,ibin)*conv1b + +! l = lptr_lim1_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(ilim1_a,jtotal,ibin)*conv1b + +! l = lptr_lim2_aer(isize,itype,iphase) +! if (l .ge. p1st) rsub(l,k,m) = aer(ilim2_a,jtotal,ibin)*conv1b + + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = water_a_hyst(ibin)*conv2b + + l = waterptr_aer(isize,itype) + if (l .ge. p1st) rsub(l,k,m) = water_a(ibin)*conv2b + + l = numptr_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = num_a(ibin)/cair_mol_cc + + + drymass_aftgrow(isize,itype) = mass_dry_a(ibin)/cair_mol_cc ! g/mol-air + if(jaerosolstate(ibin) .eq. no_aerosol) then + drydens_aftgrow(isize,itype) = -1. + else + drydens_aftgrow(isize,itype) = dens_dry_a(ibin) ! g/cc + end if + +20 continue + + endif + + return + end subroutine map_mosaic_species + + + + + + subroutine isize_itype_from_ibin( ibin, isize, itype ) +! +! inside of mosaic, the '2d' (isize,itype) indexing is replaced +! by '1d' (ibin) indexing +! this routine gives (isize,itype) corresponding to (ibin) +! + use module_data_mosaic_asect + use module_data_mosaic_other, only: lunerr +! implicit none + +! subr arguments + integer ibin, isize, itype +! local variables + integer jdum_bin, jdum_size, jdum_type + character*80 msg + + isize = -999888777 + itype = -999888777 + + jdum_bin = 0 + do jdum_type = 1, ntype_aer + do jdum_size = 1, nsize_aer(jdum_type) + jdum_bin = jdum_bin + 1 + if (ibin .eq. jdum_bin) then + isize = jdum_size + itype = jdum_type + end if + end do + end do + + if (isize .le. 0) then + write(msg,'(a,1x,i5)') & + '*** subr isize_itype_from_ibin - bad ibin =', ibin + call peg_error_fatal( lunerr, msg ) + end if + + return + end subroutine isize_itype_from_ibin + + + + + subroutine overall_massbal_in + + use module_data_mosaic_asect + use module_data_mosaic_other + +! implicit none +! include 'mosaic.h' + integer ibin + + tot_so4_in = gas(ih2so4_g) + tot_no3_in = gas(ihno3_g) + tot_cl_in = gas(ihcl_g) + tot_nh4_in = gas(inh3_g) + tot_na_in = 0.0 + tot_ca_in = 0.0 + + + do ibin = 1, nbin_a + tot_so4_in = tot_so4_in + aer(iso4_a,jtotal,ibin) + tot_no3_in = tot_no3_in + aer(ino3_a,jtotal,ibin) + tot_cl_in = tot_cl_in + aer(icl_a, jtotal,ibin) + tot_nh4_in = tot_nh4_in + aer(inh4_a,jtotal,ibin) + tot_na_in = tot_na_in + aer(ina_a,jtotal,ibin) + tot_ca_in = tot_ca_in + aer(ica_a,jtotal,ibin) + enddo + + + total_species(inh3_g) = tot_nh4_in + total_species(ihno3_g)= tot_no3_in + total_species(ihcl_g) = tot_cl_in + + + return + end subroutine overall_massbal_in + + + + subroutine overall_massbal_out(mbin) +! implicit none +! include 'v33com' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' +! include 'mosaic.h' + +! subr. agrument + integer mbin +! local variables + integer ibin + + + + tot_so4_out = gas(ih2so4_g) + tot_no3_out = gas(ihno3_g) + tot_cl_out = gas(ihcl_g) + tot_nh4_out = gas(inh3_g) + tot_na_out = 0.0 + tot_ca_out = 0.0 + + do ibin = 1, nbin_a + tot_so4_out = tot_so4_out + aer(iso4_a,jtotal,ibin) + tot_no3_out = tot_no3_out + aer(ino3_a,jtotal,ibin) + tot_cl_out = tot_cl_out + aer(icl_a,jtotal,ibin) + tot_nh4_out = tot_nh4_out + aer(inh4_a,jtotal,ibin) + tot_na_out = tot_na_out + aer(ina_a,jtotal,ibin) + tot_ca_out = tot_ca_out + aer(ica_a,jtotal,ibin) + enddo + + diff_so4 = tot_so4_out - tot_so4_in + diff_no3 = tot_no3_out - tot_no3_in + diff_cl = tot_cl_out - tot_cl_in + diff_nh4 = tot_nh4_out - tot_nh4_in + diff_na = tot_na_out - tot_na_in + diff_ca = tot_ca_out - tot_ca_in + + + reldiff_so4 = 0.0 + if(tot_so4_in .gt. 1.e-25 .or. tot_so4_out .gt. 1.e-25)then + reldiff_so4 = diff_so4/max(tot_so4_in, tot_so4_out) + endif + + reldiff_no3 = 0.0 + if(tot_no3_in .gt. 1.e-25 .or. tot_no3_out .gt. 1.e-25)then + reldiff_no3 = diff_no3/max(tot_no3_in, tot_no3_out) + endif + + reldiff_cl = 0.0 + if(tot_cl_in .gt. 1.e-25 .or. tot_cl_out .gt. 1.e-25)then + reldiff_cl = diff_cl/max(tot_cl_in, tot_cl_out) + endif + + reldiff_nh4 = 0.0 + if(tot_nh4_in .gt. 1.e-25 .or. tot_nh4_out .gt. 1.e-25)then + reldiff_nh4 = diff_nh4/max(tot_nh4_in, tot_nh4_out) + endif + + reldiff_na = 0.0 + if(tot_na_in .gt. 1.e-25 .or. tot_na_out .gt. 1.e-25)then + reldiff_na = diff_na/max(tot_na_in, tot_na_out) + endif + + reldiff_ca = 0.0 + if(tot_ca_in .gt. 1.e-25 .or. tot_ca_out .gt. 1.e-25)then + reldiff_ca = diff_ca/max(tot_ca_in, tot_ca_out) + endif + + + + if( abs(reldiff_so4) .gt. 1.e-4 .or. & + abs(reldiff_no3) .gt. 1.e-4 .or. & + abs(reldiff_cl) .gt. 1.e-4 .or. & + abs(reldiff_nh4) .gt. 1.e-4 .or. & + abs(reldiff_na) .gt. 1.e-4 .or. & + abs(reldiff_ca) .gt. 1.e-4)then + + + if (iprint_mosaic_diag1 .gt. 0) then + if (iprint_input .eq. myes) then + write(6,*)'*** mbin = ', mbin, ' isteps = ', isteps_ASTEM + write(6,*)'reldiff_so4 = ', reldiff_so4 + write(6,*)'reldiff_no3 = ', reldiff_no3 + write(6,*)'reldiff_cl = ', reldiff_cl + write(6,*)'reldiff_nh4 = ', reldiff_nh4 + write(6,*)'reldiff_na = ', reldiff_na + write(6,*)'reldiff_ca = ', reldiff_ca + call print_input + iprint_input = mno + endif + endif + + endif + + + return + end subroutine overall_massbal_out + + + + + + + + subroutine print_input + + use module_data_mosaic_asect + use module_data_mosaic_other + +! implicit none +! include 'v33com' +! include 'v33com3' +! include 'v33com9a' +! include 'v33com9b' +! include 'mosaic.h' +! subr arguments + integer k, m +! local variables + integer ibin, iphase, isize, itype + integer ipasstmp, luntmp + + +! check for print_input allowed and not already done + if (iprint_mosaic_input_ok .le. 0) return + if (iprint_input .ne. myes) return + iprint_input = mno + + k = kclm_aer + m = mclm_aer + + + tot_so4_out = gas(ih2so4_g) + tot_no3_out = gas(ihno3_g) + tot_cl_out = gas(ihcl_g) + tot_nh4_out = gas(inh3_g) + tot_na_out = 0.0 + tot_ca_out = 0.0 + + do ibin = 1, nbin_a + tot_so4_out = tot_so4_out + aer(iso4_a,jtotal,ibin) + tot_no3_out = tot_no3_out + aer(ino3_a,jtotal,ibin) + tot_cl_out = tot_cl_out + aer(icl_a,jtotal,ibin) + tot_nh4_out = tot_nh4_out + aer(inh4_a,jtotal,ibin) + tot_na_out = tot_na_out + aer(ina_a,jtotal,ibin) + tot_ca_out = tot_ca_out + aer(ica_a,jtotal,ibin) + enddo + + diff_so4 = tot_so4_out - tot_so4_in + diff_no3 = tot_no3_out - tot_no3_in + diff_cl = tot_cl_out - tot_cl_in + diff_nh4 = tot_nh4_out - tot_nh4_in + diff_na = tot_na_out - tot_na_in + diff_ca = tot_ca_out - tot_ca_in + + + reldiff_so4 = 0.0 + if(tot_so4_in .gt. 1.e-25 .or. tot_so4_out .gt. 1.e-25)then + reldiff_so4 = diff_so4/max(tot_so4_in, tot_so4_out) + endif + + reldiff_no3 = 0.0 + if(tot_no3_in .gt. 1.e-25 .or. tot_no3_out .gt. 1.e-25)then + reldiff_no3 = diff_no3/max(tot_no3_in, tot_no3_out) + endif + + reldiff_cl = 0.0 + if(tot_cl_in .gt. 1.e-25 .or. tot_cl_out .gt. 1.e-25)then + reldiff_cl = diff_cl/max(tot_cl_in, tot_cl_out) + endif + + reldiff_nh4 = 0.0 + if(tot_nh4_in .gt. 1.e-25 .or. tot_nh4_out .gt. 1.e-25)then + reldiff_nh4 = diff_nh4/max(tot_nh4_in, tot_nh4_out) + endif + + reldiff_na = 0.0 + if(tot_na_in .gt. 1.e-25 .or. tot_na_out .gt. 1.e-25)then + reldiff_na = diff_na/max(tot_na_in, tot_na_out) + endif + + reldiff_ca = 0.0 + if(tot_ca_in .gt. 1.e-25 .or. tot_ca_out .gt. 1.e-25)then + reldiff_ca = diff_ca/max(tot_ca_in, tot_ca_out) + endif + + + do 2900 ipasstmp = 1, 2 + + if (ipasstmp .eq. 1) then + luntmp = 6 ! write to standard output + else + luntmp = 67 ! write to fort.67 +! goto 2900 ! skip this + endif + +! write to monitor screen + write(luntmp,*)'+++++++++++++++++++++++++++++++++++++++++' + write(luntmp,*)'i j k n = ', iclm_aer, jclm_aer, kclm_aer, & + ncorecnt_aer + write(luntmp,*)'relative so4 mass bal = ', reldiff_so4 + write(luntmp,*)'relative no3 mass bal = ', reldiff_no3 + write(luntmp,*)'relative cl mass bal = ', reldiff_cl + write(luntmp,*)'relative nh4 mass bal = ', reldiff_nh4 + write(luntmp,*)'relative na mass bal = ', reldiff_na + write(luntmp,*)'relative ca mass bal = ', reldiff_ca + write(luntmp,*)'inputs:' + write(luntmp,*)'t (k), p (atm), rh (%), cair (mol/cc) = ' + write(luntmp,44) t_k, p_atm, rh_pc, cairclm(k) + write(luntmp,*)'gas h2so4, hno3, hcl, nh3 (mol/mol)' + write(luntmp,44)rsub(kh2so4,k,m), rsub(khno3,k,m), & + rsub(khcl,k,m), rsub(knh3,k,m) + + + iphase = ai_phase + ibin = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + ibin = ibin + 1 + + write(luntmp,44) rsub(lptr_so4_aer(ibin,itype,iphase),k,m), & + rsub(lptr_no3_aer(ibin,itype,iphase),k,m), & + rsub(lptr_cl_aer(ibin,itype,iphase),k,m), & + rsub(lptr_nh4_aer(ibin,itype,iphase),k,m), & + rsub(lptr_oc_aer(ibin,itype,iphase),k,m), & ! ng/m^3(air) + rsub(lptr_co3_aer(ibin,itype,iphase),k,m), & + rsub(lptr_msa_aer(ibin,itype,iphase),k,m), & + rsub(lptr_bc_aer(ibin,itype,iphase),k,m), & ! ng/m^3(air) + rsub(lptr_na_aer(ibin,itype,iphase),k,m), & + rsub(lptr_ca_aer(ibin,itype,iphase),k,m), & + rsub(lptr_oin_aer(ibin,itype,iphase),k,m), & + rsub(hyswptr_aer(ibin,itype),k,m), & + rsub(waterptr_aer(ibin,itype),k,m), & + rsub(numptr_aer(ibin,itype,iphase),k,m) + enddo + enddo + + write(luntmp,*)'+++++++++++++++++++++++++++++++++++++++++' + +2900 continue + + +44 format(14e20.10) + +!c stop + + return + end subroutine print_input + + + + + + + + + + + + + + + + + + +!*********************************************************************** +! checks if aerosol mass is too low to be of any significance +! and determine jaerosolstate +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine check_aerosol_mass(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iaer + real(kind=8) drymass, aer_H + + mass_dry_a(ibin) = 0.0 + + aer_H = (2.*aer(iso4_a,jtotal,ibin) + & + aer(ino3_a,jtotal,ibin) + & + aer(icl_a,jtotal,ibin) + & + aer(imsa_a,jtotal,ibin) + & + 2.*aer(ico3_a,jtotal,ibin))- & + (2.*aer(ica_a,jtotal,ibin) + & + aer(ina_a,jtotal,ibin) + & + aer(inh4_a,jtotal,ibin)) + + + do iaer = 1, naer + mass_dry_a(ibin) = mass_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer) ! ng/m^3(air) + enddo + mass_dry_a(ibin) = mass_dry_a(ibin) + aer_H + + drymass = mass_dry_a(ibin) ! ng/m^3(air) + mass_dry_a(ibin) = mass_dry_a(ibin)*1.e-15 ! g/cc(air) + + if(drymass .lt. mass_cutoff)then ! bin mass is too small + jaerosolstate(ibin) = no_aerosol + jphase(ibin) = 0 + if(drymass .eq. 0.)num_a(ibin) = 0.0 + endif + + return + end subroutine check_aerosol_mass + + + + + + + + + + + +!*********************************************************************** +! checks and conforms number according to the mass and bin size range +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine conform_aerosol_number(ibin) + + use module_data_mosaic_asect + +! implicit none +! include 'v33com' +! include 'v33com3' +! include 'v33com9a' +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer je, l, iaer, isize, itype + real(kind=8) num_at_dlo, num_at_dhi, numold + real(kind=8) aer_H + + vol_dry_a(ibin) = 0.0 ! initialize to 0.0 + + if(jaerosolstate(ibin) .eq. no_aerosol) return + + aer_H = (2.*aer(iso4_a,jtotal,ibin) + & + aer(ino3_a,jtotal,ibin) + & + aer(icl_a,jtotal,ibin) + & + aer(imsa_a,jtotal,ibin) + & + 2.*aer(ico3_a,jtotal,ibin))- & + (2.*aer(ica_a,jtotal,ibin) + & + aer(ina_a,jtotal,ibin) + & + aer(inh4_a,jtotal,ibin)) + + do iaer = 1, naer + vol_dry_a(ibin) = vol_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer)/dens_aer_mac(iaer) ! ng/m^3(air) + enddo + vol_dry_a(ibin) = vol_dry_a(ibin) + aer_H + + vol_dry_a(ibin) = vol_dry_a(ibin)*1.e-15 ! cc(aer)/cc(air) + +! conform number + call isize_itype_from_ibin( ibin, isize, itype ) + num_at_dlo = vol_dry_a(ibin)/volumlo_sect(isize,itype) + num_at_dhi = vol_dry_a(ibin)/volumhi_sect(isize,itype) + + numold = num_a(ibin) + num_a(ibin) = min(num_a(ibin), num_at_dlo) ! #/cc(air) + num_a(ibin) = max(num_a(ibin), num_at_dhi) ! #/cc(air) + +! if (numold .ne. num_a(ibin)) then +! write(*,*) 'conform number - i, vol, mass, numold/new', ibin, +! & vol_dry_a(ibin), mass_dry_temp, numold, num_a(ibin) +! write(*,*) 'conform i,j,k', iclm_aer, jclm_aer, kclm_aer +! if (nsubareas .gt. 0) then +! write(*,'(a,1pe14.4)') (name(l), rsub(l,kclm_aer,1), l=1,ltot2) +! else +! write(*,'(a,1pe14.4)') (name(l), rclm(kclm_aer,l), l=1,ltot2) +! end if +! stop +! end if + + return + end subroutine conform_aerosol_number + + + + + +!*********************************************************************** +! determines phase state of an aerosol bin. includes kelvin effect. +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine aerosol_phase_state(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer js, je, iaer, iv, iter_kelvin + real(kind=8) ah2o_a_new, rel_err +! real(kind=8) aerosol_water_up, bin_molality ! mosaic func + real(kind=8) kelvin_toler, term + real(kind=8) aer_H + + + ah2o = rh_pc*0.01 + ah2o_a(ibin) = ah2o + kelvin(ibin) = 1.0 + do iv = 1, ngas_volatile + kel(iv,ibin) = 1.0 + enddo + + if(rh_pc .le. 99)then + kelvin_toler = 1.e-2 + else + kelvin_toler = 1.e-6 + endif + +! calculate dry mass and dry volume of a bin + mass_dry_a(ibin) = 0.0 ! initialize to 0.0 + vol_dry_a(ibin) = 0.0 ! initialize to 0.0 + + aer_H = (2.*aer(iso4_a,jtotal,ibin) + & + aer(ino3_a,jtotal,ibin) + & + aer(icl_a,jtotal,ibin) + & + aer(imsa_a,jtotal,ibin) + & + 2.*aer(ico3_a,jtotal,ibin))- & + (2.*aer(ica_a,jtotal,ibin) + & + aer(ina_a,jtotal,ibin) + & + aer(inh4_a,jtotal,ibin)) + + do iaer = 1, naer + mass_dry_a(ibin) = mass_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer) ! ng/m^3(air) + vol_dry_a(ibin) = vol_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer)/dens_aer_mac(iaer) ! ncc/m^3(air) + enddo + mass_dry_a(ibin) = mass_dry_a(ibin) + aer_H + vol_dry_a(ibin) = vol_dry_a(ibin) + aer_H + + mass_dry_a(ibin) = mass_dry_a(ibin)*1.e-15 ! g/cc(air) + vol_dry_a(ibin) = vol_dry_a(ibin)*1.e-15 ! cc(aer)/cc(air) or m^3/m^3(air) + +! wet mass and wet volume + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + + + water_a_up(ibin) = aerosol_water_up(ibin) ! for hysteresis curve determination + + iter_kelvin = 0 + +10 iter_kelvin = iter_kelvin + 1 + do je = 1, nelectrolyte + molality0(je) = bin_molality(je,ibin) ! compute ah2o dependent binary molalities + enddo + + call mesa(ibin) + if(jaerosolstate(ibin) .eq. all_solid)then + return + endif + if (istat_mosaic_fe1 .lt. 0) return + +! new wet mass and wet volume + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + + call calculate_kelvin(ibin) + + ah2o_a_new = rh_pc*0.01/kelvin(ibin) + + rel_err = abs( (ah2o_a_new - ah2o_a(ibin))/ah2o_a(ibin)) + + if(rel_err .gt. kelvin_toler .and. iter_kelvin.le.20)then + ah2o_a(ibin) = ah2o_a_new + goto 10 + endif + + if(jaerosolstate(ibin) .eq. all_liquid)jhyst_leg(ibin) = jhyst_up + +! now compute kelvin effect terms for condensing species (nh3, hno3, and hcl) + do iv = 1, ngas_volatile + term = 4.*sigma_soln(ibin)*partial_molar_vol(iv)/ & + (8.3144e7*T_K*DpmV(ibin)) + kel(iv,ibin) = 1. + term*(1. + 0.5*term*(1. + term/3.)) + enddo + + + return + end subroutine aerosol_phase_state + + + + + + +!*********************************************************************** +! computes kelvin effect term (kelvin => 1.0) +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine calculate_kelvin(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) term + + + + volume_a(ibin) = vol_wet_a(ibin) ! [cc/cc(air)] + dpmv(ibin)=(6.*volume_a(ibin)/(num_a(ibin)*3.1415926))**(1./3.) ! [cm] + sigma_soln(ibin) = sigma_water + 49.0*(1. - ah2o_a(ibin)) ! [dyn/cm] + term = 72.*sigma_soln(ibin)/(8.3144e7*t_k*dpmv(ibin)) ! [-] +! kelvin(ibin) = exp(term) + kelvin(ibin) = 1. + term*(1. + 0.5*term*(1. + term/3.)) + + + return + end subroutine calculate_kelvin + + + + + + + + + + + + + + + +!*********************************************************************** +! mesa: multicomponent equilibrium solver for aerosols. +! computes equilibrum solid and liquid phases by integrating +! pseudo-transient dissolution and precipitation reactions +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mesa(ibin) ! touch +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin + +! local variables + integer idissolved, j_index, jdum, js + real(kind=8) crh, solids, sum_soluble, sum_insoluble, xt +! real(kind=8) aerosol_water ! mosaic func +! real(kind=8) drh_mutual ! mosaic func + real(kind=8) h_ion + + + call calculate_xt(ibin,jtotal,xt) + + crh = 0.1 + +! step 1: check if ah2o is below crh (crystallization or efflorescence point) + if(ah2o_a(ibin).lt.crh .and. (xt.gt.1.0 .or. xt.lt.0.))then + jaerosolstate(ibin) = all_solid + jphase(ibin) = jsolid + jhyst_leg(ibin) = jhyst_lo + call adjust_solid_aerosol(ibin) + return + endif + + +! step 2: check for supersaturation/metastable state + if(water_a_hyst(ibin) .gt. 0.5*water_a_up(ibin))then + + call do_full_deliquescence(ibin) + + sum_soluble = 0.0 + do js = 1, nsoluble + sum_soluble = sum_soluble + electrolyte(js,jtotal,ibin) + enddo + + solids = electrolyte(jcaso4,jtotal,ibin) + & + electrolyte(jcaco3,jtotal,ibin) + & + aer(ioin_a ,jtotal,ibin) + + + if(sum_soluble .lt. 1.e-15 .and. solids .gt. 0.0)then + + jaerosolstate(ibin) = all_solid ! no soluble material present + jphase(ibin) = jsolid + call adjust_solid_aerosol(ibin) + +! new wet mass and wet volume + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + return + + elseif(sum_soluble .gt. 0.0 .and. solids .eq. 0.0)then + + jaerosolstate(ibin) = all_liquid + jhyst_leg(ibin) = jhyst_up + jphase(ibin) = jliquid + water_a(ibin) = aerosol_water(jtotal,ibin) + + if(water_a(ibin) .lt. 0.0)then + jaerosolstate(ibin) = all_solid ! no soluble material present + jphase(ibin) = jsolid + jhyst_leg(ibin) = jhyst_lo + call adjust_solid_aerosol(ibin) + else + call adjust_liquid_aerosol(ibin) + call compute_activities(ibin) + endif + +! new wet mass and wet volume + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + return + + endif + + endif + + + + +! step 3: diagnose mdrh + if(xt .lt. 1. .and. xt .gt. 0. )goto 10 ! excess sulfate domain - no mdrh exists + + jdum = 0 + do js = 1, nsalt + jsalt_present(js) = 0 ! default value - salt absent + + if(epercent(js,jtotal,ibin) .gt. ptol_mol_astem)then + jsalt_present(js) = 1 ! salt present + jdum = jdum + jsalt_index(js) + endif + enddo + + if(jdum .eq. 0)then + jaerosolstate(ibin) = all_solid ! no significant soluble material present + jphase(ibin) = jsolid + call adjust_solid_aerosol(ibin) + return + endif + + if(xt .ge. 2.0 .or. xt .lt. 0.0)then + j_index = jsulf_poor(jdum) + else + j_index = jsulf_rich(jdum) + endif + + mdrh(ibin) = mdrh_t(j_index) + + if(ah2o_a(ibin)*100. .lt. mdrh(ibin)) then + jaerosolstate(ibin) = all_solid + jphase(ibin) = jsolid + jhyst_leg(ibin) = jhyst_lo + call adjust_solid_aerosol(ibin) + return + endif + + +! step 4: none of the above means it must be sub-saturated or mixed-phase +10 call do_full_deliquescence(ibin) + call mesa_ptc(ibin) ! determines jaerosolstate(ibin) + if (istat_mosaic_fe1 .lt. 0) return + + + + return + end subroutine mesa + + + + + + + + +!*********************************************************************** +! this subroutine completely deliquesces an aerosol and partitions +! all the soluble electrolytes into the liquid phase and insoluble +! ones into the solid phase. it also calculates the corresponding +! aer(js,jliquid,ibin) and aer(js,jsolid,ibin) generic species +! concentrations +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine do_full_deliquescence(ibin) ! touch +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer js + + + + +! partition all electrolytes into liquid phase + do js = 1, nelectrolyte + electrolyte(js,jsolid,ibin) = 0.0 + electrolyte(js,jliquid,ibin) = electrolyte(js,jtotal,ibin) + enddo +! +! except these electrolytes, which always remain in the solid phase + electrolyte(jcaco3,jsolid,ibin) = electrolyte(jcaco3,jtotal,ibin) + electrolyte(jcaso4,jsolid,ibin) = electrolyte(jcaso4,jtotal,ibin) + electrolyte(jcaco3,jliquid,ibin)= 0.0 + electrolyte(jcaso4,jliquid,ibin)= 0.0 + + +! partition all the generic aer species into solid and liquid phases +! solid phase + aer(iso4_a,jsolid,ibin) = electrolyte(jcaso4,jsolid,ibin) + aer(ino3_a,jsolid,ibin) = 0.0 + aer(icl_a, jsolid,ibin) = 0.0 + aer(inh4_a,jsolid,ibin) = 0.0 + aer(ioc_a, jsolid,ibin) = aer(ioc_a,jtotal,ibin) + aer(imsa_a,jsolid,ibin) = 0.0 + aer(ico3_a,jsolid,ibin) = aer(ico3_a,jtotal,ibin) + aer(ina_a, jsolid,ibin) = 0.0 + aer(ica_a, jsolid,ibin) = electrolyte(jcaco3,jsolid,ibin) + & + electrolyte(jcaso4,jsolid,ibin) + aer(ibc_a, jsolid,ibin) = aer(ibc_a,jtotal,ibin) + aer(ioin_a,jsolid,ibin) = aer(ioin_a,jtotal,ibin) + aer(iaro1_a,jsolid,ibin)= aer(iaro1_a,jtotal,ibin) + aer(iaro2_a,jsolid,ibin)= aer(iaro2_a,jtotal,ibin) + aer(ialk1_a,jsolid,ibin)= aer(ialk1_a,jtotal,ibin) + aer(iole1_a,jsolid,ibin)= aer(iole1_a,jtotal,ibin) + aer(iapi1_a,jsolid,ibin)= aer(iapi1_a,jtotal,ibin) + aer(iapi2_a,jsolid,ibin)= aer(iapi2_a,jtotal,ibin) + aer(ilim1_a,jsolid,ibin)= aer(ilim1_a,jtotal,ibin) + aer(ilim2_a,jsolid,ibin)= aer(ilim2_a,jtotal,ibin) + +! liquid-phase + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jtotal,ibin) - & + electrolyte(jcaso4,jsolid,ibin) + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jtotal,ibin) + aer(icl_a, jliquid,ibin) = aer(icl_a,jtotal,ibin) + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jtotal,ibin) + aer(ioc_a, jliquid,ibin) = 0.0 + aer(imsa_a,jliquid,ibin) = aer(imsa_a,jtotal,ibin) + aer(ico3_a,jliquid,ibin) = 0.0 + aer(ina_a, jliquid,ibin) = aer(ina_a,jtotal,ibin) + aer(ica_a, jliquid,ibin) = electrolyte(jcano3,jtotal,ibin) + & + electrolyte(jcacl2,jtotal,ibin) + aer(ibc_a, jliquid,ibin) = 0.0 + aer(ioin_a,jliquid,ibin) = 0.0 + aer(iaro1_a,jliquid,ibin)= 0.0 + aer(iaro2_a,jliquid,ibin)= 0.0 + aer(ialk1_a,jliquid,ibin)= 0.0 + aer(iole1_a,jliquid,ibin)= 0.0 + aer(iapi1_a,jliquid,ibin)= 0.0 + aer(iapi2_a,jliquid,ibin)= 0.0 + aer(ilim1_a,jliquid,ibin)= 0.0 + aer(ilim2_a,jliquid,ibin)= 0.0 + + return + end subroutine do_full_deliquescence + + + + + + + + + + + + + + + + + + + + + + +!*********************************************************************** +! mesa: multicomponent equilibrium solver for aerosol-phase +! computes equilibrum solid and liquid phases by integrating +! pseudo-transient dissolution and precipitation reactions +! +! author: rahul a. zaveri +! update: jan 2005 +! reference: zaveri r.a., r.c. easter, and l.k. peters, jgr, 2005b +!----------------------------------------------------------------------- + subroutine mesa_ptc(ibin) ! touch +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iaer, iconverge, iconverge_flux, iconverge_mass, & + idissolved, itdum, js, je, jp + real(kind=8) tau_p(nsalt), tau_d(nsalt) + real(kind=8) frac_solid, sumflux, hsalt_min, alpha, xt, dumdum, & + h_ion + real(kind=8) phi_prod, alpha_fac, sum_dum + real(kind=8) aer_H +! function +! real(kind=8) aerosol_water + + + +! initialize + itdum = 0 ! initialize time + hsalt_max = 1.e25 + + + + do js = 1, nsalt + hsalt(js) = 0.0 + sat_ratio(js) = 0.0 + phi_salt(js) = 0.0 + flux_sl(js) = 0.0 + enddo + + + do js = 1, nsalt + jsalt_present(js) = 0 ! default value - salt absent + if(epercent(js,jtotal,ibin) .gt. 1.0)then + jsalt_present(js) = 1 ! salt present + endif + enddo + + + mass_dry_a(ibin) = 0.0 + + aer_H = (2.*aer(iso4_a,jtotal,ibin) + & + aer(ino3_a,jtotal,ibin) + & + aer(icl_a,jtotal,ibin) + & + aer(imsa_a,jtotal,ibin) + & + 2.*aer(ico3_a,jtotal,ibin))- & + (2.*aer(ica_a,jtotal,ibin) + & + aer(ina_a,jtotal,ibin) + & + aer(inh4_a,jtotal,ibin)) + + do iaer = 1, naer + mass_dry_a(ibin) = mass_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer) ! [ng/m^3(air)] + vol_dry_a(ibin) = vol_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer)/dens_aer_mac(iaer) ! ncc/m^3(air) + enddo + mass_dry_a(ibin) = mass_dry_a(ibin) + aer_H + vol_dry_a(ibin) = vol_dry_a(ibin) + aer_H + + mass_dry_a(ibin) = mass_dry_a(ibin)*1.e-15 ! [g/cc(air)] + vol_dry_a(ibin) = vol_dry_a(ibin)*1.e-15 ! [cc(aer)/cc(air)] + + mass_dry_salt(ibin) = 0.0 ! soluble salts only + do je = 1, nsalt + mass_dry_salt(ibin) = mass_dry_salt(ibin) + & + electrolyte(je,jtotal,ibin)*mw_electrolyte(je)*1.e-15 ! g/cc(air) + enddo + +! call mesa_check_complete_dissolution(ibin, & +! mdissolved, & +! iconverge_flux) +! if (istat_mosaic_fe1 .lt. 0) return +! if(mdissolved .eq. myes .or. iconverge_flux .eq. myes)then +! return +! endif + + + nmesa_call = nmesa_call + 1 + +!----begin pseudo time continuation loop------------------------------- + + do 500 itdum = 1, nmax_mesa + + +! compute new salt fluxes + call mesa_flux_salt(ibin) + if (istat_mosaic_fe1 .lt. 0) return + + +! check convergence + call mesa_convergence_criterion(ibin, & + iconverge_mass, & + iconverge_flux, & + idissolved) + + if(iconverge_mass .eq. myes)then + iter_mesa(ibin) = iter_mesa(ibin) + itdum + niter_mesa = niter_mesa + itdum + niter_mesa_max = max(niter_mesa_max, itdum) + jaerosolstate(ibin) = all_solid + call adjust_solid_aerosol(ibin) + jhyst_leg(ibin) = jhyst_lo + growth_factor(ibin) = 1.0 + return + elseif(iconverge_flux .eq. myes)then + iter_mesa(ibin) = iter_mesa(ibin)+ itdum + niter_mesa = niter_mesa + itdum + niter_mesa_max = max(niter_mesa_max, itdum) + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + if(idissolved .eq. myes)then + jaerosolstate(ibin) = all_liquid +! jhyst_leg(ibin) = jhyst_up ! do this later (to avoid tripping kelvin iterations) + else + jaerosolstate(ibin) = mixed + jhyst_leg(ibin) = jhyst_lo + endif + +! calculate epercent(jsolid) composition in mixed-phase aerosol + sum_dum = 0.0 + jp = jsolid + do je = 1, nelectrolyte + electrolyte(je,jp,ibin) = max(0.D0,electrolyte(je,jp,ibin)) ! remove -ve + sum_dum = sum_dum + electrolyte(je,jp,ibin) + enddo + electrolyte_sum(jp,ibin) = sum_dum + if(sum_dum .eq. 0.)sum_dum = 1.0 + do je = 1, nelectrolyte + epercent(je,jp,ibin) = 100.*electrolyte(je,jp,ibin)/sum_dum + enddo + + return + endif + + +! calculate hsalt(js) ! time step + hsalt_min = 1.e25 + do js = 1, nsalt + + phi_prod = phi_salt(js) * phi_salt_old(js) + + if(itdum .gt. 1 .and. phi_prod .gt. 0.0)then + phi_bar(js) = (abs(phi_salt(js))-abs(phi_salt_old(js)))/ & + alpha_salt(js) + else + phi_bar(js) = 0.0 ! oscillating, or phi_salt and/or phi_salt_old may be zero + endif + + if(phi_bar(js) .lt. 0.0)then ! good. phi getting lower. maybe able to take bigger alphas + phi_bar(js) = max(phi_bar(js), -10.0D0) + alpha_fac = 3.0*exp(phi_bar(js)) + alpha_salt(js) = min(alpha_fac*abs(phi_salt(js)), 0.9D0) + elseif(phi_bar(js) .gt. 0.0)then ! bad - phi is getting bigger. so be conservative with alpha + alpha_salt(js) = min(abs(phi_salt(js)), 0.5D0) + else ! very bad - phi is oscillating. be very conservative + alpha_salt(js) = min(abs(phi_salt(js))/3.0, 0.5D0) + endif + +! alpha_salt(js) = max(alpha_salt(js), 0.01D0) + + phi_salt_old(js) = phi_salt(js) ! update old array + + + if(flux_sl(js) .gt. 0.)then + + tau_p(js) = eleliquid(js)/flux_sl(js) ! precipitation time scale + if(tau_p(js) .eq. 0.0)then + hsalt(js) = 1.e25 + flux_sl(js) = 0.0 + phi_salt(js)= 0.0 + else + hsalt(js) = alpha_salt(js)*tau_p(js) + endif + + elseif(flux_sl(js) .lt. 0.)then + + tau_p(js) = -eleliquid(js)/flux_sl(js) ! precipitation time scale + tau_d(js) = -electrolyte(js,jsolid,ibin)/flux_sl(js) ! dissolution time scale + if(tau_p(js) .eq. 0.0)then + hsalt(js) = alpha_salt(js)*tau_d(js) + else + hsalt(js) = alpha_salt(js)*min(tau_p(js),tau_d(js)) + endif + + else + + hsalt(js) = 1.e25 + + endif + + hsalt_min = min(hsalt(js), hsalt_min) + + enddo + +!--------------------------------- + +! integrate electrolyte(solid) + do js = 1, nsalt + electrolyte(js,jsolid,ibin) = & + electrolyte(js,jsolid,ibin) + & + hsalt(js) * flux_sl(js) + enddo + + +! compute aer(solid) from electrolyte(solid) + call electrolytes_to_ions(jsolid,ibin) + + +! compute new electrolyte(liquid) from mass balance + do iaer = 1, naer + aer(iaer,jliquid,ibin) = aer(iaer,jtotal,ibin) - & + aer(iaer,jsolid,ibin) + enddo + +!--------------------------------- + + + +500 continue ! end time continuation loop +!-------------------------------------------------------------------- + nmesa_fail = nmesa_fail + 1 + iter_mesa(ibin) = iter_mesa(ibin) + itdum + niter_mesa = niter_mesa + itdum + jaerosolstate(ibin) = mixed + jhyst_leg(ibin) = jhyst_lo + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + return + end subroutine mesa_ptc + + + + + + + + + + +!*********************************************************************** +! part of mesa: checks if particle is completely deliquesced at the +! current rh +! +! author: rahul a. zaveri +! update: feb 2005 +!----------------------------------------------------------------------- + subroutine mesa_check_complete_dissolution(ibin, & + mdissolved, & + iconverge_flux) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, mdissolved, iconverge_flux, je, js, iaer +! local variables + real(kind=8) sumflux, aer_sav(naer,3,nbin_a), & + electrolyte_sav(nelectrolyte,3,nbin_a), crustal_solids + + +! save current solid-liquid arrays + do je = 1, nelectrolyte + electrolyte_sav(je,jsolid,ibin) =electrolyte(je,jsolid,ibin) + electrolyte_sav(je,jliquid,ibin)=electrolyte(je,jliquid,ibin) + enddo + + do iaer = 1, naer + aer_sav(iaer,jsolid,ibin) =aer(iaer,jsolid,ibin) + aer_sav(iaer,jliquid,ibin)=aer(iaer,jliquid,ibin) + enddo + + call do_full_deliquescence(ibin) + + do js = 1, nsalt + sat_ratio(js) = 0.0 + phi_salt(js) = 0.0 + flux_sl(js) = 0.0 + enddo + + +! compute new salt fluxes + call mesa_flux_salt(ibin) + if (istat_mosaic_fe1 .lt. 0) return + + +! check if all the fluxes are zero + sumflux = 0.0 + do js = 1, nsalt + sumflux = sumflux + abs(flux_sl(js)) + enddo + + crustal_solids = electrolyte(jcaco3,jsolid,ibin) + & + electrolyte(jcaso4,jsolid,ibin) + & + aer(ioin_a,jsolid,ibin) + if(sumflux .eq. 0.0 .and. crustal_solids.eq.0.)then ! it is completely dissolved + + jaerosolstate(ibin) = all_liquid + jphase(ibin) = jliquid + mdissolved = myes + iconverge_flux = myes + + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + elseif(sumflux .eq. 0.0)then + + jaerosolstate(ibin) = mixed + jphase(ibin) = jliquid + iconverge_flux = myes + mdissolved = mno + jhyst_leg(ibin) = jhyst_lo + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) or m^3/m^3(air) + growth_factor(ibin) = mass_wet_a(ibin)/mass_dry_a(ibin) ! mass growth factor + + else ! restore saved solid-liquid arrays + + do je = 1, nelectrolyte + electrolyte(je,jsolid,ibin) =electrolyte_sav(je,jsolid,ibin) + electrolyte(je,jliquid,ibin)=electrolyte_sav(je,jliquid,ibin) + enddo + do iaer = 1, naer + aer(iaer,jsolid,ibin) =aer_sav(iaer,jsolid,ibin) + aer(iaer,jliquid,ibin)=aer_sav(iaer,jliquid,ibin) + enddo + mdissolved = mno + iconverge_flux = mno + + endif + + + return + end subroutine mesa_check_complete_dissolution + + + + + + + + + + + + + + + +!*********************************************************************** +! part of mesa: calculates solid-liquid fluxes of soluble salts +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mesa_flux_salt(ibin) ! touch +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer js + real(kind=8) xt, calcium, sum_salt + + +! compute activities and water content + call ions_to_electrolytes(jliquid,ibin,xt) + if (istat_mosaic_fe1 .lt. 0) return + call compute_activities(ibin) + activity(jna3hso4,ibin) = 0.0 + + if(water_a(ibin) .le. 0.0)then + do js = 1, nsalt + flux_sl(js) = 0.0 + enddo + return + endif + + + call mesa_estimate_eleliquid(ibin,xt) + + calcium = aer(ica_a,jliquid,ibin) + + +! calculate % electrolyte composition in the solid and liquid phases + sum_salt = 0.0 + do js = 1, nsalt + sum_salt = sum_salt + electrolyte(js,jsolid,ibin) + enddo + electrolyte_sum(jsolid,ibin) = sum_salt + if(sum_salt .eq. 0.0)sum_salt = 1.0 + do js = 1, nsalt + frac_salt_solid(js) = electrolyte(js,jsolid,ibin)/sum_salt + frac_salt_liq(js) = epercent(js,jliquid,ibin)/100. + enddo + + + +! compute salt fluxes + do js = 1, nsalt ! soluble solid salts + +! compute new saturation ratio + sat_ratio(js) = activity(js,ibin)/keq_sl(js) +! compute relative driving force + phi_salt(js) = (sat_ratio(js) - 1.0)/max(sat_ratio(js),1.0D0) + +! check if too little solid-phase salt is trying to dissolve + if(sat_ratio(js) .lt. 1.00 .and. & + frac_salt_solid(js) .lt. 0.01 .and. & + frac_salt_solid(js) .gt. 0.0)then + call mesa_dissolve_small_salt(ibin,js) + call mesa_estimate_eleliquid(ibin,xt) + sat_ratio(js) = activity(js,ibin)/keq_sl(js) + endif + +! compute flux + flux_sl(js) = sat_ratio(js) - 1.0 + +! apply heaviside function + if( (sat_ratio(js) .lt. 1.0 .and. & + electrolyte(js,jsolid,ibin) .eq. 0.0) .or. & + (calcium .gt. 0.0 .and. frac_salt_liq(js).lt.0.01).or. & + (calcium .gt. 0.0 .and. jsalt_present(js).eq.0) )then + flux_sl(js) = 0.0 + phi_salt(js)= 0.0 + endif + + enddo + + +! force cacl2 and cano3 fluxes to zero + sat_ratio(jcano3) = 1.0 + phi_salt(jcano3) = 0.0 + flux_sl(jcano3) = 0.0 + + sat_ratio(jcacl2) = 1.0 + phi_salt(jcacl2) = 0.0 + flux_sl(jcacl2) = 0.0 + + + return + end subroutine mesa_flux_salt + + + + + + + + + + + + +!*********************************************************************** +! part of mesa: calculates liquid electrolytes from ions +! +! notes: +! - this subroutine is to be used for liquid-phase or total-phase only +! - this sub transfers caso4 and caco3 from liquid to solid phase +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mesa_estimate_eleliquid(ibin,xt) ! touch +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, jp + real(kind=8) xt +! local variables + integer iaer, je, jc, ja, icase + real(kind=8) store(naer), sum_dum, sum_naza, sum_nczc, sum_na_nh4, & + f_nh4, f_na, xh, xb, xl, xs, xt_d, xna_d, xnh4_d, & + xdum, dum, cat_net + real(kind=8) nc(ncation), na(nanion) + real(kind=8) dum_ca, dum_no3, dum_cl, cano3, cacl2 + + + +! remove negative concentrations, if any + do iaer = 1, naer + aer(iaer,jliquid,ibin) = max(0.0D0, aer(iaer,jliquid,ibin)) + enddo + + +! calculate sulfate ratio + call calculate_xt(ibin,jliquid,xt) + + if(xt .ge. 2.0 .or. xt.lt.0.)then + icase = 1 ! near neutral (acidity is caused by hcl and/or hno3) + else + icase = 2 ! acidic (acidity is caused by excess so4) + endif + + +! initialize to zero + do je = 1, nelectrolyte + eleliquid(je) = 0.0 + enddo +! +!--------------------------------------------------------- +! initialize moles of ions depending on the sulfate domain + + jp = jliquid + + if(icase.eq.1)then ! xt >= 2 : sulfate poor domain + + dum_ca = aer(ica_a,jp,ibin) + dum_no3 = aer(ino3_a,jp,ibin) + dum_cl = aer(icl_a,jp,ibin) + + cano3 = min(dum_ca, 0.5*dum_no3) + dum_ca = max(0.D0, dum_ca - cano3) + dum_no3 = max(0.D0, dum_no3 - 2.*cano3) + + cacl2 = min(dum_ca, 0.5*dum_cl) + dum_ca = max(0.D0, dum_ca - cacl2) + dum_cl = max(0.D0, dum_cl - 2.*cacl2) + + na(ja_hso4)= 0.0 + na(ja_so4) = aer(iso4_a,jp,ibin) + na(ja_no3) = aer(ino3_a,jp,ibin) + na(ja_cl) = aer(icl_a, jp,ibin) + na(ja_msa) = aer(imsa_a,jp,ibin) + + nc(jc_ca) = aer(ica_a, jp,ibin) + nc(jc_na) = aer(ina_a, jp,ibin) + nc(jc_nh4) = aer(inh4_a,jp,ibin) + + cat_net = & + ( 2.d0*na(ja_so4)+na(ja_no3)+na(ja_cl)+na(ja_msa) ) - & + ( nc(jc_h)+2.d0*nc(jc_ca) +nc(jc_nh4)+nc(jc_na) ) + + if(cat_net .lt. 0.0)then + + nc(jc_h) = 0.0 + + else ! cat_net must be 0.0 or positive + + nc(jc_h) = cat_net + + endif + + +! now compute equivalent fractions + sum_naza = 0.0 + do ja = 1, nanion + sum_naza = sum_naza + na(ja)*za(ja) + enddo + + sum_nczc = 0.0 + do jc = 1, ncation + sum_nczc = sum_nczc + nc(jc)*zc(jc) + enddo + + if(sum_naza .eq. 0. .or. sum_nczc .eq. 0.)then + if (iprint_mosaic_diag1 .gt. 0) then + write(6,*)'subroutine mesa_estimate_eleliquid' + write(6,*)'ionic concentrations are zero' + write(6,*)'sum_naza = ', sum_naza + write(6,*)'sum_nczc = ', sum_nczc + endif + return + endif + + do ja = 1, nanion + xeq_a(ja) = na(ja)*za(ja)/sum_naza + enddo + + do jc = 1, ncation + xeq_c(jc) = nc(jc)*zc(jc)/sum_nczc + enddo + + na_ma(ja_so4) = na(ja_so4) *mw_a(ja_so4) + na_ma(ja_no3) = na(ja_no3) *mw_a(ja_no3) + na_ma(ja_cl) = na(ja_cl) *mw_a(ja_cl) + na_ma(ja_hso4)= na(ja_hso4)*mw_a(ja_hso4) + na_Ma(ja_msa) = na(ja_msa) *MW_a(ja_msa) + + nc_mc(jc_ca) = nc(jc_ca) *mw_c(jc_ca) + nc_mc(jc_na) = nc(jc_na) *mw_c(jc_na) + nc_mc(jc_nh4) = nc(jc_nh4)*mw_c(jc_nh4) + nc_mc(jc_h) = nc(jc_h) *mw_c(jc_h) + + +! now compute electrolyte moles + eleliquid(jna2so4) = (xeq_c(jc_na) *na_ma(ja_so4) + & + xeq_a(ja_so4)*nc_mc(jc_na))/ & + mw_electrolyte(jna2so4) + + eleliquid(jnahso4) = (xeq_c(jc_na) *na_ma(ja_hso4) + & + xeq_a(ja_hso4)*nc_mc(jc_na))/ & + mw_electrolyte(jnahso4) + + eleliquid(jnamsa) = (xeq_c(jc_na) *na_ma(ja_msa) + & + xeq_a(ja_msa)*nc_mc(jc_na))/ & + mw_electrolyte(jnamsa) + + eleliquid(jnano3) = (xeq_c(jc_na) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_na))/ & + mw_electrolyte(jnano3) + + eleliquid(jnacl) = (xeq_c(jc_na) *na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_na))/ & + mw_electrolyte(jnacl) + + eleliquid(jnh4so4) = (xeq_c(jc_nh4)*na_ma(ja_so4) + & + xeq_a(ja_so4)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4so4) + + eleliquid(jnh4hso4)= (xeq_c(jc_nh4)*na_ma(ja_hso4) + & + xeq_a(ja_hso4)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4hso4) + + eleliquid(jnh4msa) = (xeq_c(jc_nh4) *na_ma(ja_msa) + & + xeq_a(ja_msa)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4msa) + + eleliquid(jnh4no3) = (xeq_c(jc_nh4)*na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4no3) + + eleliquid(jnh4cl) = (xeq_c(jc_nh4)*na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4cl) + + eleliquid(jcano3) = (xeq_c(jc_ca) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_ca))/ & + mw_electrolyte(jcano3) + + eleliquid(jcamsa2) = (xeq_c(jc_ca) *na_ma(ja_msa) + & + xeq_a(ja_msa)*nc_mc(jc_ca))/ & + mw_electrolyte(jcamsa2) + + eleliquid(jcacl2) = (xeq_c(jc_ca) *na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_ca))/ & + mw_electrolyte(jcacl2) + + eleliquid(jh2so4) = (xeq_c(jc_h) *na_ma(ja_hso4) + & + xeq_a(ja_hso4)*nc_mc(jc_h))/ & + mw_electrolyte(jh2so4) + + eleliquid(jhno3) = (xeq_c(jc_h) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_h))/ & + mw_electrolyte(jhno3) + + eleliquid(jhcl) = (xeq_c(jc_h) *na_ma(ja_cl) + & + xeq_a(ja_cl)*nc_mc(jc_h))/ & + mw_electrolyte(jhcl) + + eleliquid(jmsa) = (xeq_c(jc_h) *na_ma(ja_msa) + & + xeq_a(ja_msa)*nc_mc(jc_h))/ & + mw_electrolyte(jmsa) + +!-------------------------------------------------------------------- + + elseif(icase.eq.2)then ! xt < 2 : sulfate rich domain + + jp = jliquid + + store(iso4_a) = aer(iso4_a,jp,ibin) + store(imsa_a) = aer(imsa_a,jp,ibin) + store(inh4_a) = aer(inh4_a,jp,ibin) + store(ina_a) = aer(ina_a, jp,ibin) + store(ica_a) = aer(ica_a, jp,ibin) + + call form_camsa2(store,jp,ibin) + + sum_na_nh4 = store(ina_a) + store(inh4_a) + if(sum_na_nh4 .gt. 0.0)then + f_nh4 = store(inh4_a)/sum_na_nh4 + f_na = store(ina_a)/sum_na_nh4 + else + f_nh4 = 0.0 + f_na = 0.0 + endif + +! first form msa electrolytes + if(sum_na_nh4 .gt. store(imsa_a))then + eleliquid(jnh4msa) = f_nh4*store(imsa_a) + eleliquid(jnamsa) = f_na *store(imsa_a) + store(inh4_a)= store(inh4_a)-eleliquid(jnh4msa) ! remaining nh4 + store(ina_a) = store(ina_a) -eleliquid(jnamsa) ! remaining na + else + eleliquid(jnh4msa) = store(inh4_a) + eleliquid(jnamsa) = store(ina_a) + eleliquid(jmsa) = store(imsa_a) - sum_na_nh4 + store(inh4_a)= 0.0 ! remaining nh4 + store(ina_a) = 0.0 ! remaining na + endif + + if(store(iso4_a).eq.0.0)goto 10 + + xt_d = xt + xna_d = 1. + 0.5*aer(ina_a,jp,ibin)/aer(iso4_a,jp,ibin) + xdum = aer(iso4_a,jp,ibin) - aer(inh4_a,jp,ibin) + + dum = 2.d0*aer(iso4_a,jp,ibin) - aer(ina_a,jp,ibin) + if(aer(inh4_a,jp,ibin) .gt. 0.0 .and. dum .gt. 0.0)then + xnh4_d = 2.*aer(inh4_a,jp,ibin)/ & + (2.*aer(iso4_a,jp,ibin) - aer(ina_a,jp,ibin)) + else + xnh4_d = 0.0 + endif + + + if(aer(inh4_a,jp,ibin) .gt. 0.0)then + + + if(xt_d .ge. xna_d)then + eleliquid(jna2so4) = 0.5*aer(ina_a,jp,ibin) + + if(xnh4_d .ge. 5./3.)then + eleliquid(jnh4so4) = 1.5*aer(ina_a,jp,ibin) & + - 3.*xdum - aer(inh4_a,jp,ibin) + eleliquid(jlvcite) = 2.*xdum + aer(inh4_a,jp,ibin) & + - aer(ina_a,jp,ibin) + elseif(xnh4_d .ge. 1.5)then + eleliquid(jnh4so4) = aer(inh4_a,jp,ibin)/5. + eleliquid(jlvcite) = aer(inh4_a,jp,ibin)/5. + elseif(xnh4_d .ge. 1.0)then + eleliquid(jnh4so4) = aer(inh4_a,jp,ibin)/6. + eleliquid(jlvcite) = aer(inh4_a,jp,ibin)/6. + eleliquid(jnh4hso4)= aer(inh4_a,jp,ibin)/6. + endif + + elseif(xt_d .gt. 1.0)then + eleliquid(jnh4so4) = aer(inh4_a,jp,ibin)/6. + eleliquid(jlvcite) = aer(inh4_a,jp,ibin)/6. + eleliquid(jnh4hso4) = aer(inh4_a,jp,ibin)/6. + eleliquid(jna2so4) = aer(ina_a,jp,ibin)/3. + eleliquid(jnahso4) = aer(ina_a,jp,ibin)/3. + elseif(xt_d .le. 1.0)then + eleliquid(jna2so4) = aer(ina_a,jp,ibin)/4. + eleliquid(jnahso4) = aer(ina_a,jp,ibin)/2. + eleliquid(jlvcite) = aer(inh4_a,jp,ibin)/6. + eleliquid(jnh4hso4) = aer(inh4_a,jp,ibin)/2. + endif + + else + + if(xt_d .gt. 1.0)then + eleliquid(jna2so4) = aer(ina_a,jp,ibin) - aer(iso4_a,jp,ibin) + eleliquid(jnahso4) = 2.*aer(iso4_a,jp,ibin) - & + aer(ina_a,jp,ibin) + else + eleliquid(jna2so4) = aer(ina_a,jp,ibin)/4. + eleliquid(jnahso4) = aer(ina_a,jp,ibin)/2. + endif + + + endif + + + + endif +!--------------------------------------------------------- +! +! calculate % composition +10 sum_dum = 0.0 + do je = 1, nelectrolyte + sum_dum = sum_dum + eleliquid(je) + enddo + + electrolyte_sum(jp,ibin) = sum_dum + + if(sum_dum .eq. 0.)sum_dum = 1.0 + do je = 1, nelectrolyte + epercent(je,jp,ibin) = 100.*eleliquid(je)/sum_dum + enddo + + + return + end subroutine mesa_estimate_eleliquid + + + + + + + + + + +!*********************************************************************** +! part of mesa: completely dissolves small amounts of soluble salts +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mesa_dissolve_small_salt(ibin,js) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, js, jp + + jp = jsolid + + + if(js .eq. jnh4so4)then + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jlvcite)then + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + & + 3.*electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jnh4hso4)then + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jna2so4)then + aer(ina_a,jliquid,ibin) = aer(ina_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jna3hso4)then + aer(ina_a,jliquid,ibin) = aer(ina_a,jliquid,ibin) + & + 3.*electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jnahso4)then + aer(ina_a,jliquid,ibin) = aer(ina_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + return + endif + + + if(js .eq. jnh4no3)then + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + aer(ino3_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + 2.*electrolyte(jcano3,jp,ibin) + & + electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jhno3,jp,ibin) + return + endif + + + if(js .eq. jnh4cl)then + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + aer(icl_a,jp,ibin) = electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jcacl2,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + electrolyte(jhcl,jp,ibin) + return + endif + + + if(js .eq. jnano3)then + aer(ina_a,jliquid,ibin) = aer(ina_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(ino3_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + 2.*electrolyte(jcano3,jp,ibin) + & + electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jhno3,jp,ibin) + return + endif + + + if(js .eq. jnacl)then + aer(ina_a,jliquid,ibin) = aer(ina_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(icl_a,jp,ibin) = electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jcacl2,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + electrolyte(jhcl,jp,ibin) + return + endif + + + if(js .eq. jcano3)then + aer(ica_a,jliquid,ibin) = aer(ica_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ica_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jcano3,jp,ibin) + & + electrolyte(jcacl2,jp,ibin) + & + electrolyte(jcaco3,jp,ibin) + & + electrolyte(jcamsa2,jp,ibin) + + aer(ino3_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + 2.*electrolyte(jcano3,jp,ibin) + & + electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jhno3,jp,ibin) + return + endif + + + if(js .eq. jcacl2)then + aer(ica_a,jliquid,ibin) = aer(ica_a,jliquid,ibin) + & + electrolyte(js,jsolid,ibin) + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) + & + 2.*electrolyte(js,jsolid,ibin) + + electrolyte(js,jsolid,ibin) = 0.0 + + aer(ica_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jcano3,jp,ibin) + & + electrolyte(jcacl2,jp,ibin) + & + electrolyte(jcaco3,jp,ibin) + & + electrolyte(jcamsa2,jp,ibin) + + aer(icl_a,jp,ibin) = electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jcacl2,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + electrolyte(jhcl,jp,ibin) + return + endif + + + + return + end subroutine mesa_dissolve_small_salt + + + + + + +!*********************************************************************** +! part of mesa: checks mesa convergence +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine mesa_convergence_criterion(ibin, & ! touch + iconverge_mass, & + iconverge_flux, & + idissolved) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, iconverge_mass, iconverge_flux, idissolved +! local variables + integer je, js, iaer + real(kind=8) mass_solid, mass_solid_salt, frac_solid, xt, h_ion, & + crustal_solids, sumflux + + + idissolved = mno ! default = not completely dissolved + +! check mass convergence + iconverge_mass = mno ! default value = no convergence + +! call electrolytes_to_ions(jsolid,ibin) +! mass_solid = 0.0 +! do iaer = 1, naer +! mass_solid = mass_solid + & +! aer(iaer,jsolid,ibin)*mw_aer_mac(iaer)*1.e-15 ! g/cc(air) +! enddo + + mass_solid_salt = 0.0 + do je = 1, nsalt + mass_solid_salt = mass_solid_salt + & + electrolyte(je,jsolid,ibin)*mw_electrolyte(je)*1.e-15 ! g/cc(air) + enddo + + + +! frac_solid = mass_solid/mass_dry_a(ibin) + + frac_solid = mass_solid_salt/mass_dry_salt(ibin) + + if(frac_solid .ge. 0.98)then + iconverge_mass = myes + return + endif + + + +! check relative driving force convergence + iconverge_flux = myes + do js = 1, nsalt + if(abs(phi_salt(js)).gt. rtol_mesa)then + iconverge_flux = mno + return + endif + enddo + + + +! check if all the fluxes are zero + + sumflux = 0.0 + do js = 1, nsalt + sumflux = sumflux + abs(flux_sl(js)) + enddo + + crustal_solids = electrolyte(jcaco3,jsolid,ibin) + & + electrolyte(jcaso4,jsolid,ibin) + & + aer(ioin_a,jsolid,ibin) + + if(sumflux .eq. 0.0 .and. crustal_solids .eq. 0.0)then + idissolved = myes + endif + + + + return + end subroutine mesa_convergence_criterion + + + + + + + + +!*********************************************************************** +! called when aerosol bin is completely solid. +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine adjust_solid_aerosol(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iaer, je + + + jphase(ibin) = jsolid + jhyst_leg(ibin) = jhyst_lo ! lower curve + water_a(ibin) = 0.0 + +! transfer aer(jtotal) to aer(jsolid) + do iaer = 1, naer + aer(iaer, jsolid, ibin) = aer(iaer,jtotal,ibin) + aer(iaer, jliquid,ibin) = 0.0 + enddo + +! transfer electrolyte(jtotal) to electrolyte(jsolid) + do je = 1, nelectrolyte + electrolyte(je,jliquid,ibin) = 0.0 + epercent(je,jliquid,ibin) = 0.0 + electrolyte(je,jsolid,ibin) = electrolyte(je,jtotal,ibin) + epercent(je,jsolid,ibin) = epercent(je,jtotal,ibin) + enddo + +! update aer(jtotal) that may have been affected above + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + +! update electrolyte(jtotal) + do je = 1, nelectrolyte + electrolyte(je,jtotal,ibin) = electrolyte(je,jsolid,ibin) + epercent(je,jtotal,ibin) = epercent(je,jsolid,ibin) + enddo + + return + end subroutine adjust_solid_aerosol + + + + + + + + + +!*********************************************************************** +! called when aerosol bin is completely liquid. +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine adjust_liquid_aerosol(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer je + + + + + jphase(ibin) = jliquid + jhyst_leg(ibin) = jhyst_up ! upper curve + +! partition all electrolytes into liquid phase + do je = 1, nelectrolyte + electrolyte(je,jsolid,ibin) = 0.0 + epercent(je,jsolid,ibin) = 0.0 + electrolyte(je,jliquid,ibin) = electrolyte(je,jtotal,ibin) + epercent(je,jliquid,ibin) = epercent(je,jtotal,ibin) + enddo +! except these electrolytes, which always remain in the solid phase + electrolyte(jcaco3,jsolid,ibin) = electrolyte(jcaco3,jtotal,ibin) + electrolyte(jcaso4,jsolid,ibin) = electrolyte(jcaso4,jtotal,ibin) + epercent(jcaco3,jsolid,ibin) = epercent(jcaco3,jtotal,ibin) + epercent(jcaso4,jsolid,ibin) = epercent(jcaso4,jtotal,ibin) + electrolyte(jcaco3,jliquid,ibin)= 0.0 + electrolyte(jcaso4,jliquid,ibin)= 0.0 + epercent(jcaco3,jliquid,ibin) = 0.0 + epercent(jcaso4,jliquid,ibin) = 0.0 + + +! partition all the aer species into +! solid phase + aer(iso4_a,jsolid,ibin) = electrolyte(jcaso4,jsolid,ibin) + aer(ino3_a,jsolid,ibin) = 0.0 + aer(icl_a,jsolid,ibin) = 0.0 + aer(inh4_a,jsolid,ibin) = 0.0 + aer(ioc_a,jsolid,ibin) = aer(ioc_a,jtotal,ibin) + aer(imsa_a,jsolid,ibin) = 0.0 + aer(ico3_a,jsolid,ibin) = aer(ico3_a,jtotal,ibin) + aer(ina_a,jsolid,ibin) = 0.0 + aer(ica_a,jsolid,ibin) = electrolyte(jcaco3,jsolid,ibin) + & + electrolyte(jcaso4,jsolid,ibin) + aer(ibc_a,jsolid,ibin) = aer(ibc_a,jtotal,ibin) + aer(ioin_a,jsolid,ibin) = aer(ioin_a,jtotal,ibin) + aer(iaro1_a,jsolid,ibin)= aer(iaro1_a,jtotal,ibin) + aer(iaro2_a,jsolid,ibin)= aer(iaro2_a,jtotal,ibin) + aer(ialk1_a,jsolid,ibin)= aer(ialk1_a,jtotal,ibin) + aer(iole1_a,jsolid,ibin)= aer(iole1_a,jtotal,ibin) + aer(iapi1_a,jsolid,ibin)= aer(iapi1_a,jtotal,ibin) + aer(iapi2_a,jsolid,ibin)= aer(iapi2_a,jtotal,ibin) + aer(ilim1_a,jsolid,ibin)= aer(ilim1_a,jtotal,ibin) + aer(ilim2_a,jsolid,ibin)= aer(ilim2_a,jtotal,ibin) + +! liquid-phase + aer(iso4_a,jliquid,ibin) = aer(iso4_a,jtotal,ibin) - & + aer(iso4_a,jsolid,ibin) + aer(iso4_a,jliquid,ibin) = max(0.D0, aer(iso4_a,jliquid,ibin)) + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jtotal,ibin) + aer(icl_a,jliquid,ibin) = aer(icl_a,jtotal,ibin) + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jtotal,ibin) + aer(ioc_a,jliquid,ibin) = 0.0 + aer(imsa_a,jliquid,ibin) = aer(imsa_a,jtotal,ibin) + aer(ico3_a,jliquid,ibin) = 0.0 + aer(ina_a,jliquid,ibin) = aer(ina_a,jtotal,ibin) + aer(ica_a,jliquid,ibin) = aer(ica_a,jtotal,ibin) - & + aer(ica_a,jsolid,ibin) + aer(ica_a,jliquid,ibin) = max(0.D0, aer(ica_a,jliquid,ibin)) + aer(ibc_a,jliquid,ibin) = 0.0 + aer(ioin_a,jliquid,ibin) = 0.0 + aer(iaro1_a,jliquid,ibin)= 0.0 + aer(iaro2_a,jliquid,ibin)= 0.0 + aer(ialk1_a,jliquid,ibin)= 0.0 + aer(iole1_a,jliquid,ibin)= 0.0 + aer(iapi1_a,jliquid,ibin)= 0.0 + aer(iapi2_a,jliquid,ibin)= 0.0 + aer(ilim1_a,jliquid,ibin)= 0.0 + aer(ilim2_a,jliquid,ibin)= 0.0 + + return + end subroutine adjust_liquid_aerosol + + + + + + + +! end of mesa package +!======================================================================= + + + + + + + + +!*********************************************************************** +! ASTEM: Adaptive Step Time-Split Euler Method +! +! author: Rahul A. Zaveri +! update: jan 2007 +!----------------------------------------------------------------------- + subroutine ASTEM(dtchem) +! implicit none +! include 'chemistry.com' +! include 'mosaic.h' +! subr arguments + real(kind=8) dtchem +! local variables + integer ibin + real(kind=8) dumdum + +! logical first +! save first +! data first/.true./ + + integer, save :: iclm_debug, jclm_debug, kclm_debug, ncnt_debug + data iclm_debug /25/ + data jclm_debug /1/ + data kclm_debug /9/ + data ncnt_debug /2/ + + + + if(iclm_aer .eq. iclm_debug .and. & + jclm_aer .eq. jclm_debug .and. & + kclm_aer .eq. kclm_debug .and. & + ncorecnt_aer .eq. ncnt_debug)then + dumdum = 0.0 + endif + + + +! update ASTEM call counter + nASTEM_call = nASTEM_call + 1 + +! reset input print flag + iprint_input = mYES + + + + +! compute aerosol phase state before starting integration + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + call aerosol_phase_state(ibin) + if (istat_mosaic_fe1 .lt. 0) return + call calc_dry_n_wet_aerosol_props(ibin) + endif + enddo + + +! if(first)then +! first=.false. +! call print_aer(0) ! BOX +! endif + + +! compute new gas-aerosol mass transfer coefficients + call aerosolmtc + if (istat_mosaic_fe1 .lt. 0) return + +! condense h2so4, msa, and nh3 only + call ASTEM_non_volatiles(dtchem) ! analytical solution + if (istat_mosaic_fe1 .lt. 0) return + +! condense inorganic semi-volatile gases hno3, hcl, nh3, and co2 + call ASTEM_semi_volatiles(dtchem) ! semi-implicit + explicit euler + if (istat_mosaic_fe1 .lt. 0) return + +! condense secondary organic gases (8 sorgam species) +! call ASTEM_secondary_organics(dtchem) ! semi-implicit euler +! if (istat_mosaic_fe1 .lt. 0) return + + +! template for error status checking +! if (iprint_mosaic_fe1 .gt. 0) then +! write(6,*)'error in computing dtmax for soa' +! write(6,*)'mosaic fatal error in astem_soa_dtmax' +! endif +! stop +! istat_mosaic_fe1 = -1800 +! return +! endif + + + + return + end subroutine astem + + + + + + + + + + subroutine print_mosaic_stats( iflag1 ) +! implicit none +! include 'mosaic.h' +! subr arguments + integer iflag1 +! local variables + integer ibin + real(kind=8) p_mesa_fails, p_astem_fails, dumcnt + + + if (iflag1 .le. 0) goto 2000 + +! print mesa and astem statistics + + dumcnt = float(max(nmesa_call,1)) + p_mesa_fails = 100.*float(nmesa_fail)/dumcnt + niter_mesa_avg = float(niter_mesa)/dumcnt + + dumcnt = float(max(nastem_call,1)) + p_astem_fails = 100.*float(nastem_fail)/dumcnt + nsteps_astem_avg = float(nsteps_astem)/dumcnt + + + if (iprint_mosaic_perform_stats .gt. 0) then + write(6,*)'------------------------------------------------' + write(6,*)' astem performance statistics' + write(6,*)'number of astem calls=', nastem_call + write(6,*)'percent astem fails =', nastem_fail + write(6,*)'avg steps per dtchem =', nsteps_astem_avg + write(6,*)'max steps per dtchem =', nsteps_astem_max + write(6,*)' ' + write(6,*)' mesa performance statistics' + write(6,*)'number of mesa calls =', nmesa_call + write(6,*)'total mesa fails =', nmesa_fail + write(6,*)'percent mesa fails =', p_mesa_fails + write(6,*)'avg iterations/call =', niter_mesa_avg + write(6,*)'max iterations/call =', niter_mesa_max + write(6,*)' ' + endif + + if (iprint_mosaic_fe1 .gt. 0) then + if ((nfe1_mosaic_cur .gt. 0) .or. & + (iprint_mosaic_fe1 .ge. 100)) then + write(6,*)'-----------------------------------------' + write(6,*)'mosaic failure count (current step) =', & + nfe1_mosaic_cur + write(6,*)'mosaic failure count (all step tot) =', & + nfe1_mosaic_tot + write(6,*)' ' + endif + endif + + if (nfe1_mosaic_tot .gt. 9999) then + write(6,'(a)') "MOSAIC FAILURE COUNT > 9999 -- SOMETHING IS SERIOUSLY WRONG !!!" + call peg_error_fatal( lunerr_aer, & + "---> MOSAIC FAILURE COUNT > 9999 -- SOMETHING IS SERIOUSLY WRONG !!!" ) + endif + +2000 continue + +! reset counters + nfe1_mosaic_cur = 0 + + nmesa_call = 0 + nmesa_fail = 0 + niter_mesa = 0.0 + niter_mesa_max = 0 + + nastem_call = 0 + nastem_fail = 0 + + nsteps_astem = 0.0 + nsteps_astem_max = 0.0 + + + return + end subroutine print_mosaic_stats + + + + + + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: integrates semi-volatile inorganic gases +! +! author: Rahul A. Zaveri +! update: jan 2007 +!----------------------------------------------------------------------- + subroutine ASTEM_semi_volatiles(dtchem) +! implicit none +! include 'chemistry.com' +! include 'mosaic.h' +! subr arguments + real(kind=8) dtchem +! local variables + integer ibin, iv, jp + real(kind=8) dtmax, t_new, t_old, t_out, xt + real(kind=8) sum1, sum2, sum3, sum4, sum4a, sum4b, h_flux_s + + +! initialize time + t_old = 0.0 + t_out = dtchem + +! reset ASTEM time steps and MESA iterations counters to zero + isteps_ASTEM = 0 + do ibin = 1, nbin_a + iter_MESA(ibin) = 0 + enddo + +!-------------------------------- +! overall integration loop begins over dtchem seconds + +10 isteps_ASTEM = isteps_ASTEM + 1 + +! compute new fluxes + phi_nh4no3_s = 0.0 + phi_nh4cl_s = 0.0 + ieqblm_ASTEM = mYES ! reset to default + + do 501 ibin = 1, nbin_a + + idry_case3a(ibin) = mNO ! reset to default +! default fluxes and other stuff + do iv = 1, ngas_ioa + sfc_a(iv) = gas(iv) + df_gas_s(iv,ibin) = 0.0 + df_gas_l(iv,ibin) = 0.0 + flux_s(iv,ibin) = 0.0 + flux_l(iv,ibin) = 0.0 + Heff(iv,ibin) = 0.0 + volatile_s(iv,ibin) = 0.0 + phi_volatile_s(iv,ibin) = 0.0 + phi_volatile_l(iv,ibin) = 0.0 + integrate(iv,jsolid,ibin) = mNO ! reset to default + integrate(iv,jliquid,ibin) = mNO ! reset to default + enddo + + + if(jaerosolstate(ibin) .eq. all_solid)then + jphase(ibin) = jsolid + call ASTEM_flux_dry(ibin) + elseif(jaerosolstate(ibin) .eq. all_liquid)then + jphase(ibin) = jliquid + call ASTEM_flux_wet(ibin) + elseif(jaerosolstate(ibin) .eq. mixed)then + + if( electrolyte(jnh4no3,jsolid,ibin).gt. 0.0 .or. & + electrolyte(jnh4cl, jsolid,ibin).gt. 0.0 )then + call ASTEM_flux_mix(ibin) ! jphase(ibin) will be determined in this subr. + else + jphase(ibin) = jliquid + call ASTEM_flux_wet(ibin) + endif + + endif + +501 continue + + if(ieqblm_ASTEM .eq. mYES)goto 30 ! all bins have reached eqblm, so quit. + +!------------------------- + + +! calculate maximum possible internal time-step +11 call ASTEM_calculate_dtmax(dtchem, dtmax) + t_new = t_old + dtmax ! update time + if(t_new .gt. t_out)then ! check if the new time step is too large + dtmax = t_out - t_old + t_new = t_out*1.01 + endif + + +!------------------------------------------ +! do internal time-step (dtmax) integration + + do 20 iv = 2, 4 + + sum1 = 0.0 + sum2 = 0.0 + sum3 = 0.0 + sum4 = 0.0 + sum4a= 0.0 + sum4b= 0.0 + + do 21 ibin = 1, nbin_a + if(jaerosolstate(ibin) .eq. no_aerosol)goto 21 + + jp = jliquid + sum1 = sum1 + aer(iv,jp,ibin)/ & + (1. + dtmax*kg(iv,ibin)*Heff(iv,ibin)*integrate(iv,jp,ibin)) + + sum2 = sum2 + kg(iv,ibin)*integrate(iv,jp,ibin)/ & + (1. + dtmax*kg(iv,ibin)*Heff(iv,ibin)*integrate(iv,jp,ibin)) + + jp = jsolid + sum3 = sum3 + aer(iv,jp,ibin) + + if(flux_s(iv,ibin) .gt. 0.)then + h_flux_s = dtmax*flux_s(iv,ibin) + sum4a = sum4a + h_flux_s + aer(iv,jp,ibin) = aer(iv,jp,ibin) + h_flux_s + elseif(flux_s(iv,ibin) .lt. 0.)then + h_flux_s = min(h_s_i_m(iv,ibin),dtmax)*flux_s(iv,ibin) + sum4b = sum4b + h_flux_s + aer(iv,jp,ibin) = aer(iv,jp,ibin) + h_flux_s + aer(iv,jp,ibin) = max(aer(iv,jp,ibin), 0.0D0) + endif + +21 continue + + sum4 = sum4a + sum4b + + +! first update gas concentration + gas(iv) = (total_species(iv) - (sum1 + sum3 + sum4) )/ & + (1. + dtmax*sum2) + gas(iv) = max(gas(iv), 0.0D0) + +! if(gas(iv) .lt. 0.)write(6,*) gas(iv) + +! now update aer concentration in the liquid phase + do 22 ibin = 1, nbin_a + + if(integrate(iv,jliquid,ibin) .eq. mYES)then + aer(iv,jliquid,ibin) = & + (aer(iv,jliquid,ibin) + dtmax*kg(iv,ibin)*gas(iv))/ & + (1. + dtmax*kg(iv,ibin)*Heff(iv,ibin)) + + endif + +22 continue + + +20 continue +!------------------------------------------ +! sub-step integration done + + +!------------------------------------------ +! now update aer(jtotal) and update internal phase equilibrium +! also do integration of species by mass balance if necessary + + do 40 ibin = 1, nbin_a + if(jaerosolstate(ibin) .eq. no_aerosol)goto 40 + + if(jphase(ibin) .eq. jsolid)then + call form_electrolytes(jsolid,ibin,XT) ! degas excess nh3 (if present) + elseif(jphase(ibin) .eq. jliquid)then + call form_electrolytes(jliquid,ibin,XT) ! degas excess nh3 (if present) + elseif(jphase(ibin) .eq. jtotal)then + call form_electrolytes(jsolid,ibin,XT) ! degas excess nh3 (if present) + call form_electrolytes(jliquid,ibin,XT) ! degas excess nh3 (if present) + endif + +!======================== +! now update jtotal + do iv = 2, ngas_ioa + aer(iv,jtotal,ibin)=aer(iv,jsolid,ibin)+aer(iv,jliquid,ibin) + enddo +!======================== + + + call form_electrolytes(jtotal,ibin,XT) ! for MDRH diagnosis + + + +! update internal phase equilibrium + if(jhyst_leg(ibin) .eq. jhyst_lo)then + call ASTEM_update_phase_eqblm(ibin) + else + call do_full_deliquescence(ibin) ! simply do liquid <-- total + endif + + +40 continue +!------------------------------------------ + +! update time + t_old = t_new + + + if(isteps_astem .ge. nmax_astem)then + nastem_fail = nastem_fail + 1 + write(6,*)'ASTEM internal steps exceeded', nmax_astem + if(iprint_input .eq. mYES)then + write(67,*)'ASTEM internal steps exceeded', nmax_astem + call print_input + iprint_input = mNO + endif + goto 30 + elseif(t_new .lt. t_out)then + goto 10 + endif + + +! check if end of dtchem reached + if(t_new .lt. 0.9999*t_out) goto 10 + +30 nsteps_astem = nsteps_astem + isteps_astem ! cumulative steps + nsteps_astem_max = max(nsteps_astem_max, isteps_astem) ! max steps in a dtchem time-step + +!================================================ +! end of overall integration loop over dtchem seconds + + + +! call subs to calculate fluxes over mixed-phase particles to update H+ ions, +! which were wiped off during update_phase_eqblm +! do ibin = 1, nbin_a +! +! if(jaerosolstate(ibin) .eq. mixed)then +! if( electrolyte(jnh4no3,jsolid,ibin).gt. 0.0 .or. & +! electrolyte(jnh4cl, jsolid,ibin).gt. 0.0 )then +! call ASTEM_flux_mix(ibin) ! jphase(ibin) will be determined in this subr. +! else +! jphase(ibin) = jliquid +! call ASTEM_flux_wet(ibin) +! endif +! endif +! +! enddo + + + + return + end subroutine ASTEM_semi_volatiles + + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: computes max time step for gas-aerosol integration +! +! author: Rahul A. Zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine ASTEM_calculate_dtmax(dtchem, dtmax) +! implicit none +! include 'mosaic.h' +! subr arguments + real(kind=8) dtchem, dtmax +! local variables + integer ibin, iv + real(kind=8) alpha, h_gas, h_sub_max, & + h_gas_i(ngas_ioa), h_gas_l, h_gas_s, & + sum_kg_phi, sumflux_s + + + h_sub_max = 150.0 ! sec + + +! set alpha_gas + do ibin = 1, nbin_a + do iv = 2, ngas_ioa + + if(flux_s(iv,ibin) .gt. 0.0)then + + alpha_gas(iv) = max( abs(phi_volatile_s(iv,ibin)), & + alpha_ASTEM ) + alpha_gas(iv) = min(alpha_gas(iv), 0.5D0) + + endif + + enddo + enddo + + + + + +! gas-side + +! solid-phase +! calculate h_gas_i and h_gas_l + + h_gas_s = 2.e16 + + do 5 iv = 2, ngas_ioa + h_gas_i(iv) = 1.e16 + sumflux_s = 0.0 + do ibin = 1, nbin_a + if(flux_s(iv,ibin) .gt. 0.0)then + sumflux_s = sumflux_s + flux_s(iv,ibin) + endif + enddo + + if(sumflux_s .gt. 0.0)then + h_gas_i(iv) = alpha_gas(iv)*gas(iv)/sumflux_s + h_gas_s = min(h_gas_s, h_gas_i(iv)) + endif + +5 continue + + +! liquid-phase +! calculate h_gas_s and h_gas_l + + h_gas_l = 2.e16 + + do 6 iv = 2, ngas_ioa + h_gas_i(iv) = 1.e16 + sum_kg_phi = 0.0 + do ibin = 1, nbin_a + if(integrate(iv,jliquid,ibin) .eq. mYES)then + sum_kg_phi = sum_kg_phi + & + abs(phi_volatile_l(iv,ibin))*kg(iv,ibin) + endif + enddo + + if(sum_kg_phi .gt. 0.0)then + h_gas_i(iv) = alpha_astem/sum_kg_phi + h_gas_l = min(h_gas_l, h_gas_i(iv)) + endif + +6 continue + + h_gas = min(h_gas_s, h_gas_l) + h_gas = min(h_gas, h_sub_max) + + + + +! aerosol-side: solid-phase + +! first load volatile_solid array + do ibin = 1, nbin_a + + volatile_s(ino3_a,ibin) = electrolyte(jnh4no3,jsolid,ibin) + volatile_s(inh4_a,ibin) = electrolyte(jnh4cl,jsolid,ibin) + & + electrolyte(jnh4no3,jsolid,ibin) + + if(idry_case3a(ibin) .eq. mYES)then + volatile_s(icl_a,ibin) = aer(icl_a,jsolid,ibin) + else + volatile_s(icl_a,ibin) = electrolyte(jnh4cl,jsolid,ibin) + endif + + enddo + + +! next calculate weighted avg_df_gas_s + do iv = 2, ngas_ioa + + sum_bin_s(iv) = 0.0 + sum_vdf_s(iv) = 0.0 + sum_vol_s(iv) = 0.0 + + do ibin = 1, nbin_a + if(flux_s(iv,ibin) .lt. 0.)then ! aer -> gas + sum_bin_s(iv) = sum_bin_s(iv) + 1.0 + sum_vdf_s(iv) = sum_vdf_s(iv) + & + volatile_s(iv,ibin)*df_gas_s(iv,ibin) + sum_vol_s(iv) = sum_vol_s(iv) + volatile_s(iv,ibin) + endif + enddo + + if(sum_vol_s(iv) .gt. 0.0)then + avg_df_gas_s(iv) = sum_vdf_s(iv)/sum_vol_s(iv) + else + avg_df_gas_s(iv) = 1.0 ! never used, but set to 1.0 just to be safe + endif + + enddo + + +! calculate h_s_i_m + + + do 20 ibin = 1, nbin_a + + if(jaerosolstate(ibin) .eq. no_aerosol) goto 20 + + do 10 iv = 2, ngas_ioa + + if(flux_s(iv,ibin) .lt. 0.)then ! aer -> gas + + alpha = abs(avg_df_gas_s(iv))/ & + (volatile_s(iv,ibin)*sum_bin_s(iv)) + alpha = min(alpha, 1.0D0) + + if(idry_case3a(ibin) .eq. mYES)alpha = 1.0D0 + + h_s_i_m(iv,ibin) = & + -alpha*volatile_s(iv,ibin)/flux_s(iv,ibin) + + endif + +10 continue + + +20 continue + + + dtmax = min(dtchem, h_gas) + + + if(dtmax .eq. 0.0)then + write(6,*)' dtmax = ', dtmax + write(67,*)' dtmax = ', dtmax + call print_input + iprint_input = mNO + stop + endif + + return + end subroutine astem_calculate_dtmax + + + + + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: updates solid-liquid partitioning after each gas-aerosol +! mass transfer step +! +! author: Rahul A. Zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine ASTEM_update_phase_eqblm(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer jdum, js, j_index + real(kind=8) XT + + + +! calculate overall sulfate ratio + call calculate_XT(ibin,jtotal,XT) ! calc updated XT + +! now diagnose MDRH + if(XT .lt. 1. .and. XT .gt. 0. )goto 10 ! excess sulfate domain - no MDRH exists + + jdum = 0 + do js = 1, nsalt + jsalt_present(js) = 0 ! default value - salt absent + + if(epercent(js,jtotal,ibin) .gt. ptol_mol_astem)then + jsalt_present(js) = 1 ! salt present + jdum = jdum + jsalt_index(js) + endif + enddo + + if(jdum .eq. 0)then + jaerosolstate(ibin) = all_solid ! no significant soluble material present + jphase(ibin) = jsolid + call adjust_solid_aerosol(ibin) + return + endif + + if(XT .ge. 2.0 .or. XT .lt. 0.0)then + j_index = jsulf_poor(jdum) + else + j_index = jsulf_rich(jdum) + endif + + MDRH(ibin) = MDRH_T(j_index) + + if(aH2O*100. .lt. MDRH(ibin)) then + jaerosolstate(ibin) = all_solid + jphase(ibin) = jsolid + call adjust_solid_aerosol(ibin) + return + endif + + +! none of the above means it must be sub-saturated or mixed-phase +10 if(jphase(ibin) .eq. jsolid)then + call do_full_deliquescence(ibin) + call MESA_PTC(ibin) + else + call MESA_PTC(ibin) + endif + + + + return + end subroutine ASTEM_update_phase_eqblm + + + + + + + + + + + + +!================================================================== +! +! LIQUID PARTICLES +! +!*********************************************************************** +! part of ASTEM: computes fluxes over wet aerosols +! +! author: Rahul A. Zaveri +! update: Jan 2007 +!----------------------------------------------------------------------- + subroutine ASTEM_flux_wet(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iv, iadjust, iadjust_intermed + real(kind=8) xt, g_nh3_hno3, g_nh3_hcl, a_nh4_no3, a_nh4_cl + + + + call ions_to_electrolytes(jliquid,ibin,XT) ! for water content calculation + call compute_activities(ibin) + + if(water_a(ibin) .eq. 0.0)then + write(6,*)'Water is zero in liquid phase' + write(6,*)'Stopping in ASTEM_flux_wet' + stop + endif + +!------------------------------------------------------------------- +! CASE 1: caco3 > 0 absorb acids (and indirectly degas co2) + + if(electrolyte(jcaco3,jsolid,ibin) .gt. 0.0)then + call ASTEM_flux_wet_case1(ibin) + return + endif + +!------------------------------------------------------------------- +! CASE 2: Sulfate-Rich Domain + + if(XT.lt.1.9999 .and. XT.ge.0.)then + call ASTEM_flux_wet_case2(ibin) + return + endif + +!------------------------------------------------------------------- + + if( (gas(inh3_g)+aer(inh4_a,jliquid,ibin)) .lt. 1.e-25)goto 10 ! no ammonia in the system + +!------------------------------------------------------------------- +! CASE 3: nh4no3 and/or nh4cl maybe active +! do some small adjustments (if needed) before deciding case 3 + + iadjust = mNO ! default + iadjust_intermed = mNO ! default + +! nh4no3 + g_nh3_hno3 = gas(inh3_g)*gas(ihno3_g) + a_nh4_no3 = aer(inh4_a,jliquid,ibin)*aer(ino3_a,jliquid,ibin) + + if(g_nh3_hno3 .gt. 0. .and. a_nh4_no3 .eq. 0.)then + call absorb_tiny_nh4no3(ibin) + iadjust = mYES + iadjust_intermed = mYES + endif + + if(iadjust_intermed .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + iadjust_intermed = mNO ! reset + endif + +! nh4cl + g_nh3_hcl = gas(inh3_g)*gas(ihcl_g) + a_nh4_cl = aer(inh4_a,jliquid,ibin)*aer(icl_a,jliquid,ibin) + + if(g_nh3_hcl .gt. 0. .and. a_nh4_cl .eq. 0.)then + call absorb_tiny_nh4cl(ibin) + iadjust = mYES + iadjust_intermed = mYES + endif + + if(iadjust_intermed .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + endif + + if(iadjust .eq. mYES)then + call compute_activities(ibin) ! update after adjustments + endif + + +! all adjustments done... + +!-------- + kelvin_nh4no3 = kel(inh3_g,ibin)*kel(ihno3_g,ibin) + Keq_nh4no3 = kelvin_nh4no3*activity(jnh4no3,ibin)*Kp_nh4no3 ! = [NH3]s * [HNO3]s + + kelvin_nh4cl = kel(inh3_g,ibin)*kel(ihcl_g,ibin) + Keq_nh4cl = kelvin_nh4cl*activity(jnh4cl,ibin)*Kp_nh4cl ! = [NH3]s * [HCl]s + + call ASTEM_flux_wet_case3(ibin) + + return + + +!------------------------------------------------------------------- +! CASE 4: ammonia = 0. hno3 and hcl exchange may happen here +! do small adjustments (if needed) before deciding case 4 + +10 iadjust = mNO ! default + iadjust_intermed = mNO ! default + +! hno3 + if(gas(ihno3_g).gt.0. .and. aer(ino3_a,jliquid,ibin).eq.0. .and. & + aer(icl_a,jliquid,ibin) .gt. 0.0)then + call absorb_tiny_hno3(ibin) ! and degas tiny hcl + iadjust = mYES + iadjust_intermed = mYES + endif + + if(iadjust_intermed .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + iadjust_intermed = mNO ! reset + endif + +! hcl + if(gas(ihcl_g).gt.0. .and. aer(icl_a,jliquid,ibin).eq.0. .and. & + aer(ino3_a,jliquid,ibin) .gt. 0.0)then + call absorb_tiny_hcl(ibin) ! and degas tiny hno3 + iadjust = mYES + iadjust_intermed = mYES + endif + + if(iadjust_intermed .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + endif + + if(iadjust .eq. mYES)then + call compute_activities(ibin) ! update after adjustments + endif + +! all adjustments done... + + call ASTEM_flux_wet_case4(ibin) + + + return + end subroutine ASTEM_flux_wet + + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: subroutines for flux_wet cases +! +! author: Rahul A. Zaveri +! update: Jan 2007 +!----------------------------------------------------------------------- + +! CASE 1: CaCO3 > 0 absorb all acids (and indirectly degas co2) + + subroutine ASTEM_flux_wet_case1(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iv + + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + +! same as dry case1 + if(gas(ihno3_g) .gt. 1.e-5)then + sfc_a(ihno3_g) = 0.0 + df_gas_s(ihno3_g,ibin) = gas(ihno3_g) + phi_volatile_s(ihno3_g,ibin) = 1.0 + flux_s(ihno3_g,ibin) = kg(ihno3_g,ibin)*df_gas_s(ihno3_g,ibin) + integrate(ihno3_g,jsolid,ibin) = mYES + jphase(ibin) = jsolid + ieqblm_ASTEM = mNO + endif + + if(gas(ihcl_g) .gt. 1.e-5)then + sfc_a(ihcl_g) = 0.0 + df_gas_s(ihcl_g,ibin) = gas(ihcl_g) + phi_volatile_s(ihcl_g,ibin) = 1.0 + flux_s(ihcl_g,ibin) = kg(ihcl_g,ibin)*df_gas_s(ihcl_g,ibin) + integrate(ihcl_g,jsolid,ibin) = mYES + jphase(ibin) = jsolid + ieqblm_ASTEM = mNO + endif + + return + end subroutine ASTEM_flux_wet_case1 + + + +!-------------------------------------------------------------------- +! CASE 2: Sulfate-Rich Domain + + subroutine ASTEM_flux_wet_case2(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) dum_hno3, dum_hcl, dum_nh3 + + + sfc_a(inh3_g) = kel(inh3_g,ibin)* & + gam_ratio(ibin)*mc(jc_nh4,ibin)*Keq_ll(3)/ & + (mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + + sfc_a(ihno3_g) = kel(ihno3_g,ibin)* & + mc(jc_h,ibin)*ma(ja_no3,ibin)*gam(jhno3,ibin)**2/ & + Keq_gl(3) + + sfc_a(ihcl_g) = kel(ihcl_g,ibin)* & + mc(jc_h,ibin)*ma(ja_cl,ibin)*gam(jhcl,ibin)**2/ & + Keq_gl(4) + + dum_hno3 = max(sfc_a(ihno3_g), gas(ihno3_g)) + dum_hcl = max(sfc_a(ihcl_g), gas(ihcl_g)) + dum_nh3 = max(sfc_a(inh3_g), gas(inh3_g)) + + +! compute relative driving forces + if(dum_hno3 .gt. 0.0)then + df_gas_l(ihno3_g,ibin) = gas(ihno3_g) - sfc_a(ihno3_g) + phi_volatile_l(ihno3_g,ibin)= df_gas_l(ihno3_g,ibin)/dum_hno3 + else + phi_volatile_l(ihno3_g,ibin)= 0.0 + endif + + if(dum_hcl .gt. 0.0)then + df_gas_l(ihcl_g,ibin) = gas(ihcl_g) - sfc_a(ihcl_g) + phi_volatile_l(ihcl_g,ibin) = df_gas_l(ihcl_g,ibin)/dum_hcl + else + phi_volatile_l(ihcl_g,ibin) = 0.0 + endif + + if(dum_nh3 .gt. 0.0)then + df_gas_l(inh3_g,ibin) = gas(inh3_g) - sfc_a(inh3_g) + phi_volatile_l(inh3_g,ibin) = df_gas_l(inh3_g,ibin)/dum_nh3 + else + phi_volatile_l(inh3_g,ibin) = 0.0 + endif + + + if(phi_volatile_l(ihno3_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(ihcl_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(inh3_g,ibin) .le. rtol_eqb_astem)then + + return + + endif + + +! compute Heff + if(dum_hno3 .gt. 0.0)then + Heff(ihno3_g,ibin)= & + kel(ihno3_g,ibin)*gam(jhno3,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(3)) + integrate(ihno3_g,jliquid,ibin)= mYES + ieqblm_ASTEM = mNO + endif + + if(dum_hcl .gt. 0.0)then + Heff(ihcl_g,ibin)= & + kel(ihcl_g,ibin)*gam(jhcl,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(4)) + integrate(ihcl_g,jliquid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + if(dum_nh3 .gt. 0.0)then + Heff(inh3_g,ibin) = & + kel(inh3_g,ibin)*gam_ratio(ibin)*1.e-9*Keq_ll(3)/ & + (water_a(ibin)*mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + integrate(inh3_g,jliquid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + + return + end subroutine ASTEM_flux_wet_case2 + + + + + + + + +!--------------------------------------------------------------------- +! CASE 3: nh4no3 and/or nh4cl may be active + + subroutine ASTEM_flux_wet_case3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c, dum_hno3, dum_hcl, dum_nh3 +! function +! real(kind=8) quadratic + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihno3_g,ibin)*gas(ihno3_g) & + + kg(ihcl_g,ibin)*gas(ihcl_g) + c = -(kg(ihno3_g,ibin)*Keq_nh4no3 + kg(ihcl_g,ibin)*Keq_nh4cl) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihno3_g) = Keq_nh4no3/max(sfc_a(inh3_g),1.D-20) + sfc_a(ihcl_g) = Keq_nh4cl/max(sfc_a(inh3_g),1.D-20) + + +! diagnose mH+ + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + elseif(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + call equilibrate_acids(ibin) ! hno3 and/or hcl may be > 0 in the gas phase + mc(jc_h,ibin) = max(mc(jc_h,ibin), sqrt(Keq_ll(3))) + + sfc_a(inh3_g) = kel(inh3_g,ibin)* & + gam_ratio(ibin)*mc(jc_nh4,ibin)*Keq_ll(3)/ & + (mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + + sfc_a(ihno3_g) = kel(ihno3_g,ibin)* & + mc(jc_h,ibin)*ma(ja_no3,ibin)*gam(jhno3,ibin)**2/ & + Keq_gl(3) + sfc_a(ihcl_g) = kel(ihcl_g,ibin)* & + mc(jc_h,ibin)*ma(ja_cl,ibin)*gam(jhcl,ibin)**2/ & + Keq_gl(4) + endif + + + + dum_hno3 = max(sfc_a(ihno3_g), gas(ihno3_g)) + dum_hcl = max(sfc_a(ihcl_g), gas(ihcl_g)) + dum_nh3 = max(sfc_a(inh3_g), gas(inh3_g)) + +! compute relative driving forces + if(dum_hno3 .gt. 0.0)then + df_gas_l(ihno3_g,ibin) = gas(ihno3_g) - sfc_a(ihno3_g) + phi_volatile_l(ihno3_g,ibin)= df_gas_l(ihno3_g,ibin)/dum_hno3 + else + phi_volatile_l(ihno3_g,ibin)= 0.0 + endif + + if(dum_hcl .gt. 0.0)then + df_gas_l(ihcl_g,ibin) = gas(ihcl_g) - sfc_a(ihcl_g) + phi_volatile_l(ihcl_g,ibin) = df_gas_l(ihcl_g,ibin)/dum_hcl + else + phi_volatile_l(ihcl_g,ibin) = 0.0 + endif + + if(dum_nh3 .gt. 0.0)then + df_gas_l(inh3_g,ibin) = gas(inh3_g) - sfc_a(inh3_g) + phi_volatile_l(inh3_g,ibin) = df_gas_l(inh3_g,ibin)/dum_nh3 + else + phi_volatile_l(inh3_g,ibin) = 0.0 + endif + + + + if(phi_volatile_l(ihno3_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(ihcl_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(inh3_g,ibin) .le. rtol_eqb_astem)then + + return + + endif + + +! compute Heff + if(dum_hno3 .gt. 0.0)then + Heff(ihno3_g,ibin)= & + kel(ihno3_g,ibin)*gam(jhno3,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(3)) + integrate(ihno3_g,jliquid,ibin)= mYES + ieqblm_ASTEM = mNO + endif + + if(dum_hcl .gt. 0.0)then + Heff(ihcl_g,ibin)= & + kel(ihcl_g,ibin)*gam(jhcl,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(4)) + integrate(ihcl_g,jliquid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + if(dum_nh3 .gt. 0.0)then + Heff(inh3_g,ibin) = & + kel(inh3_g,ibin)*gam_ratio(ibin)*1.e-9*Keq_ll(3)/ & + (water_a(ibin)*mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + integrate(inh3_g,jliquid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + + + return + end subroutine ASTEM_flux_wet_case3 + + + + + + + + + +!-------------------------------------------------------------------- +! CASE 3a: only NH4NO3 (aq) active + + subroutine ASTEM_flux_wet_case3a(ibin) ! NH4NO3 (aq) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c, dum_hno3, dum_nh3 +! function +! real(kind=8) quadratic + + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihno3_g,ibin)*gas(ihno3_g) + c = -(kg(ihno3_g,ibin)*Keq_nh4no3) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihno3_g) = Keq_nh4no3/sfc_a(inh3_g) + + +! diagnose mH+ + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + +! compute Heff + dum_hno3 = max(sfc_a(ihno3_g), gas(ihno3_g)) + dum_nh3 = max(sfc_a(inh3_g), gas(inh3_g)) + +! compute relative driving forces + if(dum_hno3 .gt. 0.0)then + df_gas_l(ihno3_g,ibin) = gas(ihno3_g) - sfc_a(ihno3_g) + phi_volatile_l(ihno3_g,ibin)= df_gas_l(ihno3_g,ibin)/dum_hno3 + else + phi_volatile_l(ihno3_g,ibin)= 0.0 + endif + + if(dum_nh3 .gt. 0.0)then + df_gas_l(inh3_g,ibin) = gas(inh3_g) - sfc_a(inh3_g) + phi_volatile_l(inh3_g,ibin) = df_gas_l(inh3_g,ibin)/dum_nh3 + else + phi_volatile_l(inh3_g,ibin) = 0.0 + endif + + + if(phi_volatile_l(ihno3_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(inh3_g,ibin) .le. rtol_eqb_astem)then + + return + + endif + + +! compute Heff + Heff(ihno3_g,ibin)= & + kel(ihno3_g,ibin)*gam(jhno3,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(3)) + integrate(ihno3_g,jliquid,ibin)= mYES + + + Heff(inh3_g,ibin) = & + kel(inh3_g,ibin)*gam_ratio(ibin)*1.e-9*Keq_ll(3)/ & + (water_a(ibin)*mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + integrate(inh3_g,jliquid,ibin) = mYES + + + ieqblm_ASTEM = mNO + + + return + end subroutine ASTEM_flux_wet_case3a + + + + + + + + + +!-------------------------------------------------------------------- +! CASE 3b: only NH4Cl (aq) active + + subroutine ASTEM_flux_wet_case3b(ibin) ! NH4Cl (aq) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c, dum_hcl, dum_nh3 +! function +! real(kind=8) quadratic + + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihcl_g,ibin)*gas(ihcl_g) + c = -(kg(ihcl_g,ibin)*Keq_nh4cl) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihcl_g) = Keq_nh4cl /sfc_a(inh3_g) + + +! diagnose mH+ + if(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + +! compute Heff + dum_hcl = max(sfc_a(ihcl_g), gas(ihcl_g)) + dum_nh3 = max(sfc_a(inh3_g), gas(inh3_g)) + + +! compute relative driving forces + if(dum_hcl .gt. 0.0)then + df_gas_l(ihcl_g,ibin) = gas(ihcl_g) - sfc_a(ihcl_g) + phi_volatile_l(ihcl_g,ibin) = df_gas_l(ihcl_g,ibin)/dum_hcl + else + phi_volatile_l(ihcl_g,ibin) = 0.0 + endif + + if(dum_nh3 .gt. 0.0)then + df_gas_l(inh3_g,ibin) = gas(inh3_g) - sfc_a(inh3_g) + phi_volatile_l(inh3_g,ibin) = df_gas_l(inh3_g,ibin)/dum_nh3 + else + phi_volatile_l(inh3_g,ibin) = 0.0 + endif + + + + if(phi_volatile_l(ihcl_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(inh3_g,ibin) .le. rtol_eqb_astem)then + + return + + endif + + + +! compute Heff + Heff(ihcl_g,ibin)= & + kel(ihcl_g,ibin)*gam(jhcl,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(4)) + integrate(ihcl_g,jliquid,ibin) = mYES + + + Heff(inh3_g,ibin) = & + kel(inh3_g,ibin)*gam_ratio(ibin)*1.e-9*Keq_ll(3)/ & + (water_a(ibin)*mc(jc_h,ibin)*Keq_ll(2)*Keq_gl(2)) + integrate(inh3_g,jliquid,ibin) = mYES + + + ieqblm_ASTEM = mNO + + + + return + end subroutine ASTEM_flux_wet_case3b + + + + + + + + + +!----------------------------------------------------------------------- +! CASE 4: NH3 = 0 (in gas and aerosol). hno3 and hcl exchange may happen here + + subroutine ASTEM_flux_wet_case4(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) dum_numer, dum_denom, gas_eqb_ratio, dum_hno3, dum_hcl + + + dum_numer = kel(ihno3_g,ibin)*Keq_gl(4)*ma(ja_no3,ibin)* & + gam(jhno3,ibin)**2 + dum_denom = kel(ihcl_g,ibin)*Keq_gl(3)*ma(ja_cl ,ibin)* & + gam(jhcl,ibin)**2 + + + if(dum_denom .eq. 0.0 .or. dum_numer .eq. 0.0)then + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + return + endif + + gas_eqb_ratio = dum_numer/dum_denom ! Ce,hno3/Ce,hcl + + +! compute equilibrium surface concentrations + sfc_a(ihcl_g) = & + ( kg(ihno3_g,ibin)*gas(ihno3_g)+kg(ihcl_g,ibin)*gas(ihcl_g) )/ & + ( kg(ihcl_g,ibin) + gas_eqb_ratio*kg(ihno3_g,ibin) ) + sfc_a(ihno3_g)= gas_eqb_ratio*sfc_a(ihcl_g) + + +! diagnose mH+ + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + elseif(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + +! compute Heff + dum_hno3 = min(sfc_a(ihno3_g), gas(ihno3_g)) + dum_hcl = min(sfc_a(ihcl_g), gas(ihcl_g)) + +! compute relative driving forces + if(dum_hno3 .gt. 0.0)then + df_gas_l(ihno3_g,ibin) = gas(ihno3_g) - sfc_a(ihno3_g) + phi_volatile_l(ihno3_g,ibin)= df_gas_l(ihno3_g,ibin)/dum_hno3 + else + phi_volatile_l(ihno3_g,ibin)= 0.0 + endif + + if(dum_hcl .gt. 0.0)then + df_gas_l(ihcl_g,ibin) = gas(ihcl_g) - sfc_a(ihcl_g) + phi_volatile_l(ihcl_g,ibin)= df_gas_l(ihcl_g,ibin)/dum_hcl + else + phi_volatile_l(ihcl_g,ibin)= 0.0 + endif + + + if(phi_volatile_l(ihno3_g,ibin) .le. rtol_eqb_astem .and. & + phi_volatile_l(ihcl_g,ibin) .le. rtol_eqb_astem)then + + return + + endif + + + +! compute Heff + Heff(ihno3_g,ibin)= & + kel(ihno3_g,ibin)*gam(jhno3,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(3)) + integrate(ihno3_g,jliquid,ibin)= mYES + + + Heff(ihcl_g,ibin)= & + kel(ihcl_g,ibin)*gam(jhcl,ibin)**2*mc(jc_h,ibin)*1.e-9/ & + (water_a(ibin)*Keq_gl(4)) + integrate(ihcl_g,jliquid,ibin) = mYES + + + ieqblm_ASTEM = mNO + + + + return + end subroutine ASTEM_flux_wet_case4 + + + + + + + + + + + + + + +!=========================================================== +! +! DRY PARTICLES +! +!=========================================================== +!*********************************************************************** +! part of ASTEM: computes gas-aerosol fluxes over dry aerosols +! +! author: Rahul A. Zaveri +! update: dec 2006 +!----------------------------------------------------------------------- + subroutine ASTEM_flux_dry(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iv + real(kind=8) XT, prod_nh4no3, prod_nh4cl, volatile_cl + + + + + call calculate_XT(ibin,jsolid,XT) + +!----------------------------------------------------------------- +! CASE 1: caco3 > 0 absorb all acids (and indirectly degas co2) + + if(electrolyte(jcaco3,jsolid,ibin) .gt. 0.0)then + + call ASTEM_flux_dry_case1(ibin) + + return + endif + +!----------------------------------------------------------------- +! CASE 2: Sulfate-Rich Domain + + if(XT.lt.1.9999 .and. XT.ge.0.)then ! excess sulfate (acidic) + + call ASTEM_flux_dry_case2(ibin) + + return + endif + +!------------------------------------------------------------------- +! CASE 3: hno3 and hcl exchange may happen here and nh4cl may form/evaporate + + volatile_cl = electrolyte(jnacl,jsolid,ibin) + & + electrolyte(jcacl2,jsolid,ibin) + + + if(volatile_cl .gt. 0.0 .and. gas(ihno3_g).gt. 0.0 )then + + call ASTEM_flux_dry_case3a(ibin) + + prod_nh4cl = max( (gas(inh3_g)*gas(ihcl_g)-Keq_sg(2)), 0.0D0) + & + electrolyte(jnh4cl, jsolid,ibin) + + if(prod_nh4cl .gt. 0.0)then + call ASTEM_flux_dry_case3b(ibin) + endif + + return + endif + +!----------------------------------------------------------------- +! CASE 4: nh4no3 or nh4cl or both may be active + + prod_nh4no3 = max( (gas(inh3_g)*gas(ihno3_g)-Keq_sg(1)),0.D0) + & + electrolyte(jnh4no3,jsolid,ibin) + prod_nh4cl = max( (gas(inh3_g)*gas(ihcl_g) -Keq_sg(2)),0.D0) + & + electrolyte(jnh4cl, jsolid,ibin) + + if(prod_nh4no3 .gt. 0.0 .or. prod_nh4cl .gt. 0.0)then + call ASTEM_flux_dry_case4(ibin) + return + endif + +!----------------------------------------------------------------- + + return + end subroutine ASTEM_flux_dry + +!---------------------------------------------------------------------- + + + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: subroutines for flux_dry cases +! +! author: Rahul A. Zaveri +! update: dec 2006 +!----------------------------------------------------------------------- + +! CASE 1: caco3 > 0 absorb all acids (and indirectly degas co2) + + subroutine ASTEM_flux_dry_case1(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin + + + if(gas(ihno3_g) .gt. 1.e-5)then + sfc_a(ihno3_g) = 0.0 + df_gas_s(ihno3_g,ibin) = gas(ihno3_g) + phi_volatile_s(ihno3_g,ibin) = 1.0 + flux_s(ihno3_g,ibin) = kg(ihno3_g,ibin)*df_gas_s(ihno3_g,ibin) + integrate(ihno3_g,jsolid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + if(gas(ihcl_g) .gt. 1.e-5)then + sfc_a(ihcl_g) = 0.0 + df_gas_s(ihcl_g,ibin) = gas(ihcl_g) + phi_volatile_s(ihcl_g,ibin) = 1.0 + flux_s(ihcl_g,ibin) = kg(ihcl_g,ibin)*df_gas_s(ihcl_g,ibin) + integrate(ihcl_g,jsolid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + + return + end subroutine ASTEM_flux_dry_case1 + + + +!--------------------------------------------------------------------- +! CASE 2: Sulfate-Rich Domain + + subroutine ASTEM_flux_dry_case2(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin + + + if(gas(inh3_g).gt.1.e-5)then + sfc_a(inh3_g) = 0.0 + df_gas_s(inh3_g,ibin) = gas(inh3_g) + phi_volatile_s(inh3_g,ibin) = 1.0 + flux_s(inh3_g,ibin) = kg(inh3_g,ibin)*gas(inh3_g) + integrate(inh3_g,jsolid,ibin) = mYES + ieqblm_ASTEM = mNO + endif + + + return + end subroutine ASTEM_flux_dry_case2 + + + + +!--------------------------------------------------------------------- +! CASE 3a: degas hcl from nacl or cacl2 by flux_s balance with hno3 + + subroutine ASTEM_flux_dry_case3a(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin + + + if(gas(ihno3_g) .gt. 1.e-5)then + sfc_a(ihno3_g) = 0.0 + sfc_a(ihcl_g) = gas(ihcl_g) + aer(icl_a,jsolid,ibin) + + df_gas_s(ihno3_g,ibin) = gas(ihno3_g) + df_gas_s(ihcl_g,ibin) = -aer(icl_a,jsolid,ibin) + + flux_s(ihno3_g,ibin) = kg(ihno3_g,ibin)*gas(ihno3_g) + flux_s(ihcl_g,ibin) = -flux_s(ihno3_g,ibin) + + phi_volatile_s(ihno3_g,ibin) = 1.0 + phi_volatile_s(ihcl_g,ibin)=df_gas_s(ihcl_g,ibin)/sfc_a(ihcl_g) + + integrate(ihno3_g,jsolid,ibin) = mYES + integrate(ihcl_g,jsolid,ibin) = mYES + + idry_case3a(ibin) = mYES + ieqblm_ASTEM = mNO + endif + + return + end subroutine ASTEM_flux_dry_case3a + + + + +!--------------------------------------------------------------------- +! CASE 3b: nh4cl may form/evaporate here + + subroutine ASTEM_flux_dry_case3b(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iactive_nh4cl + real(kind=8) a, b, c +! function +! real(kind=8) quadratic + + +!------------------- +! set default values for flags + iactive_nh4cl = 1 + + +! compute relative driving force + phi_nh4cl_s = (gas(inh3_g)*gas(ihcl_g) - Keq_sg(2))/ & + max(gas(inh3_g)*gas(ihcl_g),Keq_sg(2)) + + +!------------------- +! now determine if nh4cl is active or significant +! nh4cl + if( abs(phi_nh4cl_s) .lt. rtol_eqb_ASTEM )then + iactive_nh4cl = 0 + elseif(gas(inh3_g)*gas(ihcl_g) .lt. Keq_sg(2) .and. & + epercent(jnh4cl, jsolid,ibin) .le. ptol_mol_ASTEM)then + iactive_nh4cl = 0 + if(epercent(jnh4cl, jsolid,ibin) .gt. 0.0)then + call degas_solid_nh4cl(ibin) + endif + endif + + +! check the outcome + if(iactive_nh4cl .eq. 0)return + + +!----------------- +! nh4cl is active + + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihcl_g,ibin)*gas(ihcl_g) + c = -(kg(ihcl_g,ibin)*Keq_sg(2)) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihcl_g) = Keq_sg(2)/sfc_a(inh3_g) + + df_gas_s(ihcl_g,ibin) = gas(ihcl_g) - sfc_a(ihcl_g) + df_gas_s(inh3_g,ibin) = gas(inh3_g) - sfc_a(inh3_g) + + flux_s(inh3_g,ibin) = kg(inh3_g,ibin)*df_gas_s(inh3_g,ibin) + flux_s(ihcl_g,ibin) = flux_s(ihcl_g,ibin) + flux_s(inh3_g,ibin) + + phi_volatile_s(inh3_g,ibin) = phi_nh4cl_s + + if(flux_s(ihcl_g,ibin) .gt. 0.0)then + df_gas_s(ihcl_g,ibin) = flux_s(ihcl_g,ibin)/kg(ihcl_g,ibin) ! recompute df_gas + phi_volatile_s(ihcl_g,ibin) = phi_nh4cl_s + else + sfc_a(ihcl_g) = gas(ihcl_g) + aer(icl_a,jsolid,ibin) + df_gas_s(ihcl_g,ibin) = -aer(icl_a,jsolid,ibin) + phi_volatile_s(ihcl_g,ibin)=df_gas_s(ihcl_g,ibin)/sfc_a(ihcl_g) ! not to be used + endif + + integrate(inh3_g,jsolid,ibin) = mYES + integrate(ihcl_g,jsolid,ibin) = mYES ! integrate HCl with explicit euler + + ieqblm_ASTEM = mNO + + return + end subroutine ASTEM_flux_dry_case3b + + + + +!--------------------------------------------------------------------- +! Case 4: NH4NO3 and/or NH4Cl may be active + + subroutine ASTEM_flux_dry_case4(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iactive_nh4no3, iactive_nh4cl, iactive + real(kind=8) a, b, c +! function +! real(kind=8) quadratic + + +!------------------- +! set default values for flags + iactive_nh4no3 = 1 + iactive_nh4cl = 2 + + +! compute diagnostic products and ratios + phi_nh4no3_s = (gas(inh3_g)*gas(ihno3_g) - Keq_sg(1))/ & + max(gas(inh3_g)*gas(ihno3_g),Keq_sg(1)) + phi_nh4cl_s = (gas(inh3_g)*gas(ihcl_g) - Keq_sg(2))/ & + max(gas(inh3_g)*gas(ihcl_g),Keq_sg(2)) + + +!------------------- +! now determine if nh4no3 and/or nh4cl are active or significant + +! nh4no3 + if( abs(phi_nh4no3_s) .lt. rtol_eqb_ASTEM )then + iactive_nh4no3 = 0 + elseif(gas(inh3_g)*gas(ihno3_g) .lt. Keq_sg(1) .and. & + epercent(jnh4no3,jsolid,ibin) .le. ptol_mol_ASTEM)then + iactive_nh4no3 = 0 + if(epercent(jnh4no3,jsolid,ibin) .gt. 0.0)then + call degas_solid_nh4no3(ibin) + endif + endif + +! nh4cl + if( abs(phi_nh4cl_s) .lt. rtol_eqb_ASTEM )then + iactive_nh4cl = 0 + elseif(gas(inh3_g)*gas(ihcl_g) .lt. Keq_sg(2) .and. & + epercent(jnh4cl, jsolid,ibin) .le. ptol_mol_ASTEM)then + iactive_nh4cl = 0 + if(epercent(jnh4cl, jsolid,ibin) .gt. 0.0)then + call degas_solid_nh4cl(ibin) + endif + endif + + + iactive = iactive_nh4no3 + iactive_nh4cl + +! check the outcome + if(iactive .eq. 0)return + + + goto (1,2,3),iactive + +!--------------------------------- +! only nh4no3 solid is active +1 call ASTEM_flux_dry_case4a(ibin) + + return + + +!----------------- +! only nh4cl solid is active +2 call ASTEM_flux_dry_case4b(ibin) + + return + + +!----------------- +! both nh4no3 and nh4cl are active +3 call ASTEM_flux_dry_case4ab(ibin) + + + + + return + end subroutine ASTEM_flux_dry_case4 + + + + + + + +!--------------------------------------------------------------------- +! Case 4a + + subroutine ASTEM_flux_dry_case4a(ibin) ! NH4NO3 solid +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c +! function +! real(kind=8) quadratic + + + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihno3_g,ibin)*gas(ihno3_g) + c = -(kg(ihno3_g,ibin)*Keq_sg(1)) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihno3_g) = Keq_sg(1)/sfc_a(inh3_g) + + integrate(ihno3_g,jsolid,ibin) = mYES + integrate(inh3_g,jsolid,ibin) = mYES + + df_gas_s(ihno3_g,ibin)=gas(ihno3_g)-sfc_a(ihno3_g) + df_gas_s(inh3_g,ibin) =gas(inh3_g) -sfc_a(inh3_g) + + phi_volatile_s(ihno3_g,ibin)= phi_nh4no3_s + phi_volatile_s(inh3_g,ibin) = phi_nh4no3_s + + flux_s(ihno3_g,ibin) = kg(ihno3_g,ibin)*df_gas_s(ihno3_g,ibin) + flux_s(inh3_g,ibin) = flux_s(ihno3_g,ibin) + + ieqblm_ASTEM = mNO + + return + end subroutine ASTEM_flux_dry_case4a + + + + +!--------------------------------------------------------- +! Case 4b + + subroutine ASTEM_flux_dry_case4b(ibin) ! NH4Cl solid +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c +! function +! real(kind=8) quadratic + + + a = kg(inh3_g,ibin) + b = - kg(inh3_g,ibin)*gas(inh3_g) & + + kg(ihcl_g,ibin)*gas(ihcl_g) + c = -(kg(ihcl_g,ibin)*Keq_sg(2)) + + sfc_a(inh3_g) = quadratic(a,b,c) + sfc_a(ihcl_g) = Keq_sg(2) /sfc_a(inh3_g) + + integrate(ihcl_g,jsolid,ibin) = mYES + integrate(inh3_g,jsolid,ibin) = mYES + + df_gas_s(ihcl_g,ibin) = gas(ihcl_g)-sfc_a(ihcl_g) + df_gas_s(inh3_g,ibin) = gas(inh3_g)-sfc_a(inh3_g) + + phi_volatile_s(ihcl_g,ibin) = phi_nh4cl_s + phi_volatile_s(inh3_g,ibin) = phi_nh4cl_s + + flux_s(ihcl_g,ibin) = kg(ihcl_g,ibin)*df_gas_s(ihcl_g,ibin) + flux_s(inh3_g,ibin) = flux_s(ihcl_g,ibin) + + ieqblm_ASTEM = mNO + + return + end subroutine ASTEM_flux_dry_case4b + + + + +!------------------------------------------------------------------- +! Case 4ab + + subroutine ASTEM_flux_dry_case4ab(ibin) ! NH4NO3 + NH4Cl (solid) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, b, c, & + flux_nh3_est, flux_nh3_max, ratio_flux +! function +! real(kind=8) quadratic + + call ASTEM_flux_dry_case4a(ibin) + call ASTEM_flux_dry_case4b(ibin) + + +! estimate nh3 flux and adjust hno3 and/or hcl if necessary + + flux_nh3_est = flux_s(ihno3_g,ibin)+flux_s(ihcl_g,ibin) + flux_nh3_max = kg(inh3_g,ibin)*gas(inh3_g) + + + if(flux_nh3_est .le. flux_nh3_max)then + + flux_s(inh3_g,ibin) = flux_nh3_est ! all ok - no adjustments needed + sfc_a(inh3_g) = gas(inh3_g) - & ! recompute sfc_a(ihno3_g) + flux_s(inh3_g,ibin)/kg(inh3_g,ibin) + phi_volatile_s(inh3_g,ibin) = max(abs(phi_nh4no3_s), & + abs(phi_nh4cl_s)) + + else ! reduce hno3 and hcl flux_ses as necessary so that nh3 flux_s = flux_s_nh3_max + + ratio_flux = flux_nh3_max/flux_nh3_est + flux_s(inh3_g,ibin) = flux_nh3_max + flux_s(ihno3_g,ibin)= flux_s(ihno3_g,ibin)*ratio_flux + flux_s(ihcl_g,ibin) = flux_s(ihcl_g,ibin) *ratio_flux + + sfc_a(inh3_g) = 0.0 + sfc_a(ihno3_g)= gas(ihno3_g) - & ! recompute sfc_a(ihno3_g) + flux_s(ihno3_g,ibin)/kg(ihno3_g,ibin) + sfc_a(ihcl_g) = gas(ihcl_g) - & ! recompute sfc_a(ihcl_g) + flux_s(ihcl_g,ibin)/kg(ihcl_g,ibin) + + df_gas_s(inh3_g,ibin) =gas(inh3_g) -sfc_a(inh3_g) + df_gas_s(ihno3_g,ibin)=gas(ihno3_g)-sfc_a(ihno3_g) + df_gas_s(ihcl_g,ibin) =gas(ihcl_g) -sfc_a(ihcl_g) + + phi_volatile_s(inh3_g,ibin) = max(abs(phi_nh4no3_s), & + abs(phi_nh4cl_s)) + + endif + + ieqblm_ASTEM = mNO + + return + end subroutine ASTEM_flux_dry_case4ab + + + + + + + + + + + +!======================================================================= +! +! MIXED-PHASE PARTICLES +! +!*********************************************************************** +! part of ASTEM: computes gas-aerosol fluxes over mixed-phase aerosols +! +! author: Rahul A. Zaveri +! update: apr 2006 +!----------------------------------------------------------------------- + + subroutine ASTEM_flux_mix(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iv, iadjust, iadjust_intermed + real(kind=8) XT, g_nh3_hno3, g_nh3_hcl, & + a_nh4_no3, a_nh4_cl, a_no3, a_cl, & + prod_nh4no3, prod_nh4cl + real(kind=8) volatile_cl + + + call ions_to_electrolytes(jliquid,ibin,XT) ! for water content calculation + call compute_activities(ibin) + + if(water_a(ibin) .eq. 0.0)then + write(6,*)'Water is zero in liquid phase' + write(6,*)'Stopping in ASTEM_flux_wet' + stop + endif + + + +!----------------------------------------------------------------- +! CASE 1: caco3 > 0 absorb all acids (and indirectly degas co2) + + if(epercent(jcaco3,jsolid,ibin) .gt. 0.0)then + jphase(ibin) = jliquid + call ASTEM_flux_wet_case1(ibin) + return + endif + +!----------------------------------------------------------------- +! CASE 2: Sulfate-Rich Domain + + if(XT.lt.1.9999 .and. XT.ge.0.)then ! excess sulfate (acidic) + jphase(ibin) = jliquid + call ASTEM_flux_wet_case2(ibin) + return + endif + +!------------------------------------------------------------------- +! CASE 3: nh4no3 or nh4cl or both may be active + + if( electrolyte(jnh4no3,jsolid,ibin).gt.0. .and. & + electrolyte(jnh4cl,jsolid,ibin) .gt.0. )then + jphase(ibin) = jsolid + call ASTEM_flux_dry_case4(ibin) + + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + elseif(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + return + + elseif( electrolyte(jnh4no3,jsolid,ibin).gt.0. )then +! do small adjustments for nh4cl aq + g_nh3_hcl= gas(inh3_g)*gas(ihcl_g) + a_nh4_cl = aer(inh4_a,jliquid,ibin)*aer(icl_a,jliquid,ibin) + + iadjust = mNO ! initialize + if(g_nh3_hcl .gt. 0.0 .and. a_nh4_cl .eq. 0.0)then + call absorb_tiny_nh4cl(ibin) + iadjust = mYES + elseif(g_nh3_hcl .eq. 0.0 .and. a_nh4_cl .gt. 0.0)then + call degas_tiny_nh4cl(ibin) + iadjust = mYES + endif + + if(iadjust .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + call compute_activities(ibin) ! update after adjustments + endif + + call ASTEM_flux_mix_case3a(ibin) ! nh4no3 solid + nh4cl aq + jphase(ibin) = jtotal + return + + elseif( electrolyte(jnh4cl,jsolid,ibin).gt.0.)then +! do small adjustments for nh4no3 aq + g_nh3_hno3= gas(inh3_g)*gas(ihno3_g) + a_nh4_no3 = aer(inh4_a,jliquid,ibin)*aer(ino3_a,jliquid,ibin) + + iadjust = mNO ! initialize + if(g_nh3_hno3 .gt. 0.0 .and. a_nh4_no3 .eq. 0.0)then + call absorb_tiny_nh4no3(ibin) + iadjust = mYES + elseif(g_nh3_hno3 .eq. 0.0 .and. a_nh4_no3 .gt. 0.0)then + call degas_tiny_nh4no3(ibin) + iadjust = mYES + endif + + if(iadjust .eq. mYES)then + call ions_to_electrolytes(jliquid,ibin,XT) ! update after adjustments + call compute_activities(ibin) ! update after adjustments + endif + + kelvin_nh4no3 = kel(inh3_g,ibin)*kel(ihno3_g,ibin) + Keq_nh4no3 = kelvin_nh4no3*activity(jnh4no3,ibin)*Kp_nh4no3 ! = [NH3]s * [HNO3]s + + call ASTEM_flux_mix_case3b(ibin) ! nh4cl solid + nh4no3 aq + jphase(ibin) = jtotal + return + endif + + + return + end subroutine ASTEM_flux_mix + +!---------------------------------------------------------------------- + + + + + + + + +!------------------------------------------------------------------ +! Mix Case 3a: NH4NO3 solid maybe active. NH4Cl aq maybe active + + subroutine ASTEM_flux_mix_case3a(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iactive_nh4no3, iactive_nh4cl + + +! set default values for flags + iactive_nh4no3 = mYES + iactive_nh4cl = mYES + + +! nh4no3 (solid) + phi_nh4no3_s = (gas(inh3_g)*gas(ihno3_g) - Keq_sg(1))/ & + max(gas(inh3_g)*gas(ihno3_g),Keq_sg(1)) + +! nh4cl (liquid) + kelvin_nh4cl = kel(inh3_g,ibin)*kel(ihcl_g,ibin) + Keq_nh4cl = kelvin_nh4cl*activity(jnh4cl,ibin)*Kp_nh4cl ! = [NH3]s * [HCl]s + + +!------------------- +! now determine if nh4no3 and/or nh4cl are active or significant +! nh4no3 solid + if( abs(phi_nh4no3_s) .le. rtol_eqb_ASTEM )then + iactive_nh4no3 = mNO + elseif(gas(inh3_g)*gas(ihno3_g) .lt. Keq_sg(1) .and. & + epercent(jnh4no3,jsolid,ibin) .le. ptol_mol_ASTEM)then + iactive_nh4no3 = mNO + if(epercent(jnh4no3,jsolid,ibin) .gt. 0.0)then + call degas_solid_nh4no3(ibin) + endif + endif + +! nh4cl aq + if( gas(inh3_g)*gas(ihcl_g).eq.0. .or. Keq_nh4cl.eq.0. )then + iactive_nh4cl = mNO + endif + + +!--------------------------------- + if(iactive_nh4no3 .eq. mYES)then + + jphase(ibin) = jsolid + call ASTEM_flux_dry_case4a(ibin) ! NH4NO3 (solid) + + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + elseif(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + endif + + + if(iactive_nh4cl .eq. mYES)then + + jphase(ibin) = jliquid + call ASTEM_flux_wet_case3b(ibin) ! NH4Cl (liquid) + + if(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + endif + + + if(iactive_nh4cl .eq. mYES .and. iactive_nh4no3 .eq. mYES)then + jphase(ibin) = jtotal + endif + + + + return + end subroutine ASTEM_flux_mix_case3a + + + + + + + + +!------------------------------------------------------------------ +! Mix Case 3b: NH4Cl solid maybe active. NH4NO3 aq may or maybe active + + subroutine ASTEM_flux_mix_case3b(ibin) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer iactive_nh4no3, iactive_nh4cl + + +! set default values for flags + iactive_nh4cl = mYES + iactive_nh4no3 = mYES + + +! nh4cl (solid) + phi_nh4cl_s = (gas(inh3_g)*gas(ihcl_g) - Keq_sg(2))/ & + max(gas(inh3_g)*gas(ihcl_g),Keq_sg(2)) + +! nh4no3 (liquid) + kelvin_nh4no3 = kel(inh3_g,ibin)*kel(ihno3_g,ibin) + Keq_nh4no3 = kelvin_nh4no3*activity(jnh4no3,ibin)*Kp_nh4no3 ! = [NH3]s * [HNO3]s + + +!------------------- +! now determine if nh4no3 and/or nh4cl are active or significant +! nh4cl (solid) + if( abs(phi_nh4cl_s) .le. rtol_eqb_ASTEM )then + iactive_nh4cl = mNO + elseif(gas(inh3_g)*gas(ihcl_g) .lt. Keq_sg(2) .and. & + epercent(jnh4cl,jsolid,ibin) .le. ptol_mol_ASTEM)then + iactive_nh4cl = mNO + if(epercent(jnh4cl,jsolid,ibin) .gt. 0.0)then + call degas_solid_nh4cl(ibin) + endif + endif + +! nh4no3 (liquid) + if( gas(inh3_g)*gas(ihno3_g).eq.0. .or. Keq_nh4no3.eq.0. )then + iactive_nh4no3 = mNO + endif + + +!--------------------------------- + if(iactive_nh4cl .eq. mYES)then + + jphase(ibin) = jsolid + call ASTEM_flux_dry_case4b(ibin) ! NH4Cl (solid) + + if(sfc_a(ihcl_g).gt.0.0 .and. ma(ja_cl,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(4)*sfc_a(ihcl_g)/ & + (kel(ihcl_g,ibin)*gam(jhcl,ibin)**2 * ma(ja_cl,ibin)) + elseif(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + endif + + + if(iactive_nh4no3 .eq. mYES)then + + jphase(ibin) = jliquid + call ASTEM_flux_wet_case3a(ibin) ! NH4NO3 (liquid) + + if(sfc_a(ihno3_g).gt.0.0 .and. ma(ja_no3,ibin).gt.0.0)then + mc(jc_h,ibin) = Keq_gl(3)*sfc_a(ihno3_g)/ & + (kel(ihno3_g,ibin)*gam(jhno3,ibin)**2 * ma(ja_no3,ibin)) + else + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + endif + + + if(iactive_nh4cl .eq. mYES .and. iactive_nh4no3 .eq. mYES)then + jphase(ibin) = jtotal + endif + + + + return + end subroutine ASTEM_flux_mix_case3b + + + + + + + + + + + +!*********************************************************************** +! part of ASTEM: condenses h2so4, msa, and nh3 analytically over dtchem [s] +! +! author: Rahul A. Zaveri +! update: jan 2007 +!----------------------------------------------------------------------- + + subroutine ASTEM_non_volatiles(dtchem) ! TOUCH +! implicit none +! include 'mosaic.h' +! subr arguments + real(kind=8) dtchem +! local variables + integer ibin, iupdate_phase_state + real(kind=8) decay_h2so4, decay_msa, & + delta_h2so4, delta_tmsa, delta_nh3, delta_hno3, delta_hcl, & + delta_so4(nbin_a), delta_msa(nbin_a), & + delta_nh4(nbin_a) + real(kind=8) XT + + + + + sumkg_h2so4 = 0.0 + sumkg_msa = 0.0 + sumkg_nh3 = 0.0 + sumkg_hno3 = 0.0 + sumkg_hcl = 0.0 + do ibin = 1, nbin_a + sumkg_h2so4 = sumkg_h2so4 + kg(ih2so4_g,ibin) + sumkg_msa = sumkg_msa + kg(imsa_g,ibin) + sumkg_nh3 = sumkg_nh3 + kg(inh3_g,ibin) + sumkg_hno3 = sumkg_hno3 + kg(ihno3_g,ibin) + sumkg_hcl = sumkg_hcl + kg(ihcl_g,ibin) + enddo + + + +!-------------------------------------- +! H2SO4 + if(gas(ih2so4_g) .gt. 1.e-14)then + +! integrate h2so4 condensation analytically + decay_h2so4 = exp(-sumkg_h2so4*dtchem) + delta_h2so4 = gas(ih2so4_g)*(1.0 - decay_h2so4) + gas(ih2so4_g) = gas(ih2so4_g)*decay_h2so4 + + +! now distribute delta_h2so4 to each bin and conform the particle (may degas by massbal) + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + delta_so4(ibin) = delta_h2so4*kg(ih2so4_g,ibin)/sumkg_h2so4 + aer(iso4_a,jtotal,ibin) = aer(iso4_a,jtotal,ibin) + & + delta_so4(ibin) + endif + enddo + + else + + delta_h2so4 = 0.0 + do ibin = 1, nbin_a + delta_so4(ibin) = 0.0 + enddo + + endif +! h2so4 condensation is now complete +!-------------------------------------- + + + +! MSA + if(gas(imsa_g) .gt. 1.e-14)then + +! integrate msa condensation analytically + decay_msa = exp(-sumkg_msa*dtchem) + delta_tmsa = gas(imsa_g)*(1.0 - decay_msa) + gas(imsa_g) = gas(imsa_g)*decay_msa + +! now distribute delta_msa to each bin and conform the particle (may degas by massbal) + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + delta_msa(ibin) = delta_tmsa*kg(imsa_g,ibin)/sumkg_msa + aer(imsa_a,jtotal,ibin) = aer(imsa_a,jtotal,ibin) + & + delta_msa(ibin) + endif + enddo + + else + + delta_tmsa = 0.0 + do ibin = 1, nbin_a + delta_msa(ibin) = 0.0 + enddo + + endif +! msa condensation is now complete +!------------------------------------- + + + +! compute max allowable nh3, hno3, and hcl condensation + delta_nh3 = gas(inh3_g) *(1.0 - exp(-sumkg_nh3*dtchem)) + delta_hno3= gas(ihno3_g)*(1.0 - exp(-sumkg_hno3*dtchem)) + delta_hcl = gas(ihcl_g) *(1.0 - exp(-sumkg_hcl*dtchem)) + +! compute max possible nh4 condensation for each bin + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + delta_nh3_max(ibin) = delta_nh3*kg(inh3_g,ibin)/sumkg_nh3 + delta_hno3_max(ibin)= delta_hno3*kg(ihno3_g,ibin)/sumkg_hno3 + delta_hcl_max(ibin) = delta_hcl*kg(ihcl_g,ibin)/sumkg_hcl + endif + enddo + + + if(delta_h2so4 .eq. 0.0 .and. delta_tmsa .eq. 0.0)then + iupdate_phase_state = mNO + goto 100 + endif + + +! now condense appropriate amounts of nh3 to each bin + do ibin = 1, nbin_a + + if(epercent(jnacl,jtotal,ibin) .eq. 0.0 .and. & + epercent(jcacl2,jtotal,ibin) .eq. 0.0 .and. & + epercent(jnano3,jtotal,ibin) .eq. 0.0 .and. & + epercent(jcano3,jtotal,ibin) .eq. 0.0 .and. & + epercent(jcaco3,jtotal,ibin) .eq. 0.0 .and. & + jaerosolstate(ibin) .ne. no_aerosol)then + + delta_nh4(ibin)=min( (2.*delta_so4(ibin)+delta_msa(ibin)), & + delta_nh3_max(ibin) ) + + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jtotal,ibin) + & ! update aer-phase + delta_nh4(ibin) + + gas(inh3_g) = gas(inh3_g) - delta_nh4(ibin) ! update gas-phase + + else + + delta_nh4(ibin) = 0.0 + + endif + + enddo + + iupdate_phase_state = mYES + + +! recompute phase equilibrium +100 if(iupdate_phase_state .eq. mYES)then + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + call conform_electrolytes(jtotal,ibin,XT) + call aerosol_phase_state(ibin) + endif + enddo + endif + + return + end subroutine ASTEM_non_volatiles + + + + + + + +!*********************************************************************** +! computes mass transfer coefficients for each condensing species for +! all the aerosol bins +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine aerosolmtc + + use module_data_mosaic_asect + +! implicit none +! include 'v33com9a' +! include 'mosaic.h' +! local variables + integer nghq + parameter (nghq = 2) ! gauss-hermite quadrature order + integer ibin, iq, iv + real(kind=8) tworootpi, root2, beta + parameter (tworootpi = 3.5449077, root2 = 1.4142135, beta = 2.0) + real(kind=8) cdum, dp, dp_avg, fkn, kn, lnsg, lndpgn, lndp, speed, & + sumghq + real(kind=8) xghq(nghq), wghq(nghq) ! quadrature abscissae and weights + real(kind=8) mw_vol(ngas_volatile), v_molar(ngas_volatile), & ! mw and molar vols of volatile species + freepath(ngas_volatile), accom(ngas_volatile), & + dg(ngas_volatile) ! keep local +! real(kind=8) fuchs_sutugin ! mosaic func +! real(kind=8) gas_diffusivity ! mosaic func +! real(kind=8) mean_molecular_speed ! mosaic func + + + + + +! molecular weights + mw_vol(ih2so4_g) = 98.0 + mw_vol(ihno3_g) = 63.0 + mw_vol(ihcl_g) = 36.5 + mw_vol(inh3_g) = 17.0 + mw_vol(imsa_g) = 96.0 + mw_vol(iaro1_g) = 150.0 + mw_vol(iaro2_g) = 150.0 + mw_vol(ialk1_g) = 140.0 + mw_vol(iole1_g) = 140.0 + mw_vol(iapi1_g) = 184.0 + mw_vol(iapi2_g) = 184.0 + mw_vol(ilim1_g) = 200.0 + mw_vol(ilim2_g) = 200.0 + + v_molar(ih2so4_g)= 42.88 + v_molar(ihno3_g) = 24.11 + v_molar(ihcl_g) = 21.48 + v_molar(inh3_g) = 14.90 + v_molar(imsa_g) = 58.00 + +! mass accommodation coefficients + accom(ih2so4_g) = 0.1 + accom(ihno3_g) = 0.1 + accom(ihcl_g) = 0.1 + accom(inh3_g) = 0.1 + accom(imsa_g) = 0.1 + accom(iaro1_g) = 0.1 + accom(iaro2_g) = 0.1 + accom(ialk1_g) = 0.1 + accom(iole1_g) = 0.1 + accom(iapi1_g) = 0.1 + accom(iapi2_g) = 0.1 + accom(ilim1_g) = 0.1 + accom(ilim2_g) = 0.1 + +! quadrature weights + xghq(1) = 0.70710678 + xghq(2) = -0.70710678 + wghq(1) = 0.88622693 + wghq(2) = 0.88622693 + + + +! calculate gas diffusivity and mean free path for condensing gases +! ioa + do iv = 1, ngas_ioa + speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s + dg(iv) = gas_diffusivity(t_k,p_atm,mw_vol(iv),v_molar(iv)) ! cm^2/s + freepath(iv) = 3.*dg(iv)/speed ! cm + enddo + +! soa + do iv = iaro1_g, ngas_volatile + speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s + dg(iv) = 0.02 ! cm^2/s + freepath(iv) = 3.*dg(iv)/speed + enddo + + +! calc mass transfer coefficients for gases over various aerosol bins + + if (msize_framework .eq. mmodal) then + +! for modal approach + do 10 ibin = 1, nbin_a + + if(jaerosolstate(ibin) .eq. no_aerosol)goto 10 + call calc_dry_n_wet_aerosol_props(ibin) + + dpgn_a(ibin) = dp_wet_a(ibin) ! cm + + lnsg = log(sigmag_a(ibin)) + lndpgn = log(dpgn_a(ibin)) + cdum = tworootpi*num_a(ibin)* & + exp(beta*lndpgn + 0.5*(beta*lnsg)**2) + + do 20 iv = 1, ngas_volatile + + sumghq = 0.0 + do 30 iq = 1, nghq ! sum over gauss-hermite quadrature points + lndp = lndpgn + beta*lnsg**2 + root2*lnsg*xghq(iq) + dp = exp(lndp) + kn = 2.*freepath(iv)/dp + fkn = fuchs_sutugin(kn,accom(iv)) + sumghq = sumghq + wghq(iq)*dp*fkn/(dp**beta) +30 continue + + kg(iv,ibin) = cdum*dg(iv)*sumghq ! 1/s +20 continue +10 continue + + elseif(msize_framework .eq. msection)then + +! for sectional approach + do 11 ibin = 1, nbin_a + + if(jaerosolstate(ibin) .eq. no_aerosol)goto 11 + + call calc_dry_n_wet_aerosol_props(ibin) + + dp_avg = dp_wet_a(ibin) + cdum = 6.283185*dp_avg*num_a(ibin) + + do 21 iv = 1, ngas_volatile + kn = 2.*freepath(iv)/dp_avg + fkn = fuchs_sutugin(kn,accom(iv)) + kg(iv,ibin) = cdum*dg(iv)*fkn ! 1/s +21 continue + +11 continue + + else + + if (iprint_mosaic_fe1 .gt. 0) then + write(6,*)'error in the choice of msize_framework' + write(6,*)'mosaic fatal error in subr. aerosolmtc' + endif +! stop + istat_mosaic_fe1 = -1900 + return + + endif + + + return + end subroutine aerosolmtc + + + + + + + + + + + + +!*********************************************************************** +! calculates dry and wet aerosol properties: density, refractive indices +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine calc_dry_n_wet_aerosol_props(ibin) + + use module_data_mosaic_asect + +! implicit none +! include 'v33com9a' +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer jc, je, iaer, isize, itype + real(kind=8) aer_H + complex(kind=8) ri_dum + + +! calculate dry mass and dry volume of a bin + mass_dry_a(ibin) = 0.0 ! initialize to 0.0 + vol_dry_a(ibin) = 0.0 ! initialize to 0.0 + area_dry_a(ibin) = 0.0 ! initialize to 0.0 + + if(jaerosolstate(ibin) .ne. no_aerosol)then + + aer_H = (2.*aer(iso4_a,jtotal,ibin) + & + aer(ino3_a,jtotal,ibin) + & + aer(icl_a,jtotal,ibin) + & + aer(imsa_a,jtotal,ibin) + & + 2.*aer(ico3_a,jtotal,ibin))- & + (2.*aer(ica_a,jtotal,ibin) + & + aer(ina_a,jtotal,ibin) + & + aer(inh4_a,jtotal,ibin)) + + do iaer = 1, naer + mass_dry_a(ibin) = mass_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer) ! ng/m^3(air) + vol_dry_a(ibin) = vol_dry_a(ibin) + & + aer(iaer,jtotal,ibin)*mw_aer_mac(iaer)/dens_aer_mac(iaer) ! ncc/m^3(air) + enddo + mass_dry_a(ibin) = mass_dry_a(ibin) + aer_H + vol_dry_a(ibin) = vol_dry_a(ibin) + aer_H + + mass_dry_a(ibin) = mass_dry_a(ibin)*1.e-15 ! g/cc(air) + vol_dry_a(ibin) = vol_dry_a(ibin)*1.e-15 ! cc(aer)/cc(air) + +! wet mass and wet volume + mass_wet_a(ibin) = mass_dry_a(ibin) + water_a(ibin)*1.e-3 ! g/cc(air) + vol_wet_a(ibin) = vol_dry_a(ibin) + water_a(ibin)*1.e-3 ! cc(aer)/cc(air) + +! calculate mean dry and wet particle densities + dens_dry_a(ibin) = mass_dry_a(ibin)/vol_dry_a(ibin) ! g/cc(aerosol) + dens_wet_a(ibin) = mass_wet_a(ibin)/vol_wet_a(ibin) ! g/cc(aerosol) + +! calculate mean dry and wet particle surface areas + area_dry_a(ibin)= 0.785398*num_a(ibin)*Dp_dry_a(ibin)**2 ! cm^2/cc(air) + area_wet_a(ibin)= 0.785398*num_a(ibin)*Dp_wet_a(ibin)**2 ! cm^2/cc(air) + +! calculate mean dry and wet particle diameters + dp_dry_a(ibin)=(1.90985*vol_dry_a(ibin)/num_a(ibin))**0.3333333 ! cm + dp_wet_a(ibin)=(1.90985*vol_wet_a(ibin)/num_a(ibin))**0.3333333 ! cm + +! calculate volume average refractive index +! load comp_a array + do je = 1, nelectrolyte + comp_a(je)=electrolyte(je,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + enddo + comp_a(joc) = aer(ioc_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbc) = aer(ibc_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(join) = aer(ioin_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jaro1)= aer(iaro1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jaro2)= aer(iaro2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jalk1)= aer(ialk1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jole1)= aer(iole1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(japi1)= aer(iapi1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(japi2)= aer(iapi2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jlim1)= aer(ilim1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jlim2)= aer(ilim2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jh2o) = water_a(ibin)*1.e-3 ! g/cc(air) + + ri_dum = (0.0,0.0) + do jc = 1, naercomp + ri_dum = ri_dum + ref_index_a(jc)*comp_a(jc)/dens_comp_a(jc) + enddo + + ri_avg_a(ibin) = ri_dum/vol_wet_a(ibin) + + else ! use defaults + + dens_dry_a(ibin) = 1.0 ! g/cc(aerosol) + dens_wet_a(ibin) = 1.0 ! g/cc(aerosol) + + call isize_itype_from_ibin( ibin, isize, itype ) + dp_dry_a(ibin) = dcen_sect(isize,itype) ! cm + dp_wet_a(ibin) = dcen_sect(isize,itype) ! cm + + ri_avg_a(ibin) = (1.5,0.0) + endif + + + return + end subroutine calc_dry_n_wet_aerosol_props + + + + + + + + + + + + + + + + + + + + +!*********************************************************************** +! computes activities +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine compute_activities(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer jp, ja + real(kind=8) xt, xmol(nelectrolyte), sum_elec, dumK, c_bal, a_c + real(kind=8) quad, aq, bq, cq, xq, dum +! function +! real(kind=8) aerosol_water + + + water_a(ibin) = aerosol_water(jliquid,ibin) ! kg/m^3(air) + if(water_a(ibin) .eq. 0.0)return + + + call calculate_xt(ibin,jliquid,xt) + + if(xt.gt.2.0 .or. xt.lt.0.)then +! sulfate poor: fully dissociated electrolytes + + +! anion molalities (mol/kg water) + ma(ja_so4,ibin) = 1.e-9*aer(iso4_a,jliquid,ibin)/water_a(ibin) + ma(ja_hso4,ibin) = 0.0 + ma(ja_no3,ibin) = 1.e-9*aer(ino3_a,jliquid,ibin)/water_a(ibin) + ma(ja_cl,ibin) = 1.e-9*aer(icl_a, jliquid,ibin)/water_a(ibin) + ma(ja_msa,ibin) = 1.e-9*aer(imsa_a,jliquid,ibin)/water_a(ibin) + +! cation molalities (mol/kg water) + mc(jc_ca,ibin) = 1.e-9*aer(ica_a, jliquid,ibin)/water_a(ibin) + mc(jc_nh4,ibin) = 1.e-9*aer(inh4_a,jliquid,ibin)/water_a(ibin) + mc(jc_na,ibin) = 1.e-9*aer(ina_a, jliquid,ibin)/water_a(ibin) + a_c = ( 2.d0*ma(ja_so4,ibin)+ & + ma(ja_no3,ibin)+ & + ma(ja_cl,ibin) + & + ma(ja_msa,ibin) ) - & + ( 2.d0*mc(jc_ca,ibin) + & + mc(jc_nh4,ibin)+ & + mc(jc_na,ibin) ) + mc(jc_h,ibin) = 0.5*a_c + sqrt(a_c**2 + 4.*Keq_ll(3)) + + if(mc(jc_h,ibin) .eq. 0.0)then + mc(jc_h,ibin) = sqrt(Keq_ll(3)) + endif + + + jp = jliquid + + + sum_elec = 2.*electrolyte(jnh4no3,jp,ibin) + & + 2.*electrolyte(jnh4cl,jp,ibin) + & + 3.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jnano3,jp,ibin) + & + 2.*electrolyte(jnacl,jp,ibin) + & + 3.*electrolyte(jcano3,jp,ibin) + & + 3.*electrolyte(jcacl2,jp,ibin) + & + 2.*electrolyte(jhno3,jp,ibin) + & + 2.*electrolyte(jhcl,jp,ibin) + + if(sum_elec .eq. 0.0)then + do ja = 1, nelectrolyte + gam(ja,ibin) = 1.0 + enddo + goto 10 + endif + + +! ionic mole fractions + xmol(jnh4no3) = 2.*electrolyte(jnh4no3,jp,ibin)/sum_elec + xmol(jnh4cl) = 2.*electrolyte(jnh4cl,jp,ibin) /sum_elec + xmol(jnh4so4) = 3.*electrolyte(jnh4so4,jp,ibin)/sum_elec + xmol(jna2so4) = 3.*electrolyte(jna2so4,jp,ibin)/sum_elec + xmol(jnano3) = 2.*electrolyte(jnano3,jp,ibin) /sum_elec + xmol(jnacl) = 2.*electrolyte(jnacl,jp,ibin) /sum_elec + xmol(jcano3) = 3.*electrolyte(jcano3,jp,ibin) /sum_elec + xmol(jcacl2) = 3.*electrolyte(jcacl2,jp,ibin) /sum_elec + xmol(jhno3) = 2.*electrolyte(jhno3,jp,ibin) /sum_elec + xmol(jhcl) = 2.*electrolyte(jhcl,jp,ibin) /sum_elec + + + ja = jnh4so4 + if(xmol(ja).gt.0.0)then + log_gam(ja) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jnh4so4,ibin) = mc(jc_nh4,ibin)**2*ma(ja_so4,ibin)* & + gam(jnh4so4,ibin)**3 + endif + + + + jA = jnh4no3 + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jnh4no3,ibin) = mc(jc_nh4,ibin)*ma(ja_no3,ibin)* & + gam(jnh4no3,ibin)**2 + endif + + + jA = jnh4cl + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jnh4cl,ibin) = mc(jc_nh4,ibin)*ma(ja_cl,ibin)* & + gam(jnh4cl,ibin)**2 + endif + + + jA = jna2so4 + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jna2so4,ibin) = mc(jc_na,ibin)**2*ma(ja_so4,ibin)* & + gam(jna2so4,ibin)**3 + endif + + + jA = jnano3 + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jnano3,ibin) = mc(jc_na,ibin)*ma(ja_no3,ibin)* & + gam(jnano3,ibin)**2 + endif + + + + jA = jnacl + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jnacl,ibin) = mc(jc_na,ibin)*ma(ja_cl,ibin)* & + gam(jnacl,ibin)**2 + endif + + + +! jA = jcano3 +! if(xmol(jA).gt.0.0)then +! gam(jA,ibin) = 1.0 +! activity(jcano3,ibin) = 1.0 +! endif + + + +! jA = jcacl2 +! if(xmol(jA).gt.0.0)then +! gam(jA,ibin) = 1.0 +! activity(jcacl2,ibin) = 1.0 +! endif + + jA = jcano3 + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jcano3,ibin) = mc(jc_ca,ibin)*ma(ja_no3,ibin)**2* & + gam(jcano3,ibin)**3 + endif + + + + jA = jcacl2 + if(xmol(jA).gt.0.0)then + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jcacl2,ibin) = mc(jc_ca,ibin)*ma(ja_cl,ibin)**2* & + gam(jcacl2,ibin)**3 + endif + + + jA = jhno3 + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jhno3,ibin) = mc(jc_h,ibin)*ma(ja_no3,ibin)* & + gam(jhno3,ibin)**2 + + + jA = jhcl + log_gam(jA) = xmol(jnh4no3)*log_gamZ(jA,jnh4no3) + & + xmol(jnh4cl) *log_gamZ(jA,jnh4cl) + & + xmol(jnh4so4)*log_gamZ(jA,jnh4so4) + & + xmol(jna2so4)*log_gamZ(jA,jna2so4) + & + xmol(jnano3) *log_gamZ(jA,jnano3) + & + xmol(jnacl) *log_gamZ(jA,jnacl) + & + xmol(jcano3) *log_gamZ(jA,jcano3) + & + xmol(jcacl2) *log_gamZ(jA,jcacl2) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + activity(jhcl,ibin) = mc(jc_h,ibin)*ma(ja_cl,ibin)* & + gam(jhcl,ibin)**2 + +!---- +10 gam(jlvcite,ibin) = 1.0 + + gam(jnh4hso4,ibin)= 1.0 + + gam(jnh4msa,ibin) = 1.0 + + gam(jna3hso4,ibin) = 1.0 + + gam(jnahso4,ibin) = 1.0 + + gam(jnamsa,ibin) = 1.0 + + activity(jlvcite,ibin) = 0.0 + + activity(jnh4hso4,ibin)= 0.0 + + activity(jnh4msa,ibin) = mc(jc_nh4,ibin)*ma(ja_msa,ibin)* & + gam(jnh4msa,ibin)**2 + + activity(jna3hso4,ibin)= 0.0 + + activity(jnahso4,ibin) = 0.0 + + activity(jnh4msa,ibin) = mc(jc_na,ibin)*ma(ja_msa,ibin)* & + gam(jnamsa,ibin)**2 + + gam_ratio(ibin) = gam(jnh4no3,ibin)**2/gam(jhno3,ibin)**2 + + + else +! SULFATE-RICH: solve for SO4= and HSO4- ions + + jp = jliquid + + sum_elec = 3.*electrolyte(jh2so4,jp,ibin) + & + 2.*electrolyte(jnh4hso4,jp,ibin) + & + 5.*electrolyte(jlvcite,jp,ibin) + & + 3.*electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jnahso4,jp,ibin) + & + 5.*electrolyte(jna3hso4,jp,ibin) + & + 3.*electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jhno3,jp,ibin) + & + 2.*electrolyte(jhcl,jp,ibin) + + + if(sum_elec .eq. 0.0)then + do jA = 1, nelectrolyte + gam(jA,ibin) = 1.0 + enddo + goto 20 + endif + + + xmol(jh2so4) = 3.*electrolyte(jh2so4,jp,ibin)/sum_elec + xmol(jnh4hso4)= 2.*electrolyte(jnh4hso4,jp,ibin)/sum_elec + xmol(jlvcite) = 5.*electrolyte(jlvcite,jp,ibin)/sum_elec + xmol(jnh4so4) = 3.*electrolyte(jnh4so4,jp,ibin)/sum_elec + xmol(jnahso4) = 2.*electrolyte(jnahso4,jp,ibin)/sum_elec + xmol(jna3hso4)= 5.*electrolyte(jna3hso4,jp,ibin)/sum_elec + xmol(jna2so4) = 3.*electrolyte(jna2so4,jp,ibin)/sum_elec + xmol(jhno3) = 2.*electrolyte(jhno3,jp,ibin)/sum_elec + xmol(jhcl) = 2.*electrolyte(jhcl,jp,ibin)/sum_elec + + +! 2H.SO4 + jA = jh2so4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! H.HSO4 + jA = jhhso4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! NH4HSO4 + jA = jnh4hso4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! LETOVICITE + jA = jlvcite + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! (NH4)2SO4 + jA = jnh4so4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! NaHSO4 + jA = jnahso4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! Na3H(SO4)2 + jA = jna3hso4 +! log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & +! xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & +! xmol(jlvcite) *log_gamZ(jA,jlvcite) + & +! xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & +! xmol(jnahso4) *log_gamZ(jA,jnahso4) + & +! xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & +! xmol(jna2so4) *log_gamZ(jA,jna2so4) + & +! xmol(jhno3) *log_gamZ(jA,jhno3) + & +! xmol(jhcl) *log_gamZ(jA,jhcl) +! gam(jA,ibin) = 10.**log_gam(jA) + gam(jA,ibin) = 1.0 + + +! Na2SO4 + jA = jna2so4 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! HNO3 + jA = jhno3 + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +! HCl + jA = jhcl + log_gam(jA) = xmol(jh2so4) *log_gamZ(jA,jh2so4) + & + xmol(jnh4hso4)*log_gamZ(jA,jnh4hso4)+ & + xmol(jlvcite) *log_gamZ(jA,jlvcite) + & + xmol(jnh4so4) *log_gamZ(jA,jnh4so4) + & + xmol(jnahso4) *log_gamZ(jA,jnahso4) + & + xmol(jna3hso4)*log_gamZ(jA,jna3hso4)+ & + xmol(jna2so4) *log_gamZ(jA,jna2so4) + & + xmol(jhno3) *log_gamZ(jA,jhno3) + & + xmol(jhcl) *log_gamZ(jA,jhcl) + gam(jA,ibin) = 10.**log_gam(jA) + + +20 gam(jnh4no3,ibin) = 1.0 + gam(jnh4cl,ibin) = 1.0 + gam(jnano3,ibin) = 1.0 + gam(jnacl,ibin) = 1.0 + gam(jcano3,ibin) = 1.0 + gam(jcacl2,ibin) = 1.0 + + gam(jnh4msa,ibin) = 1.0 + gam(jnamsa,ibin) = 1.0 + + + +! compute equilibrium pH +! cation molalities (mol/kg water) + mc(jc_ca,ibin) = 0.0 ! aqueous ca never exists in sulfate rich cases + mc(jc_nh4,ibin) = 1.e-9*aer(inh4_a,jliquid,ibin)/water_a(ibin) + mc(jc_na,ibin) = 1.e-9*aer(ina_a, jliquid,ibin)/water_a(ibin) + +! anion molalities (mol/kg water) + mSULF = 1.e-9*aer(iso4_a,jliquid,ibin)/water_a(ibin) + ma(ja_hso4,ibin) = 0.0 + ma(ja_so4,ibin) = 0.0 + ma(ja_no3,ibin) = 1.e-9*aer(ino3_a,jliquid,ibin)/water_a(ibin) + ma(ja_cl,ibin) = 1.e-9*aer(icl_a, jliquid,ibin)/water_a(ibin) + ma(ja_msa,ibin) = 1.e-9*aer(imsa_a,jliquid,ibin)/water_a(ibin) + + gam_ratio(ibin) = gam(jnh4hso4,ibin)**2/gam(jhhso4,ibin)**2 + dumK = Keq_ll(1)*gam(jhhso4,ibin)**2/gam(jh2so4,ibin)**3 + + c_bal = mc(jc_nh4,ibin) + mc(jc_na,ibin) & + - ma(ja_no3,ibin) - ma(ja_cl,ibin) - mSULF - ma(ja_msa,ibin) + + aq = 1.0 + bq = dumK + c_bal + cq = dumK*(c_bal - mSULF) + + +!--quadratic solution + if(bq .ne. 0.0)then + xq = 4.*(1./bq)*(cq/bq) + else + xq = 1.e+6 + endif + + if(abs(xq) .lt. 1.e-6)then + dum = xq*(0.5 + xq*(0.125 + xq*0.0625)) + quad = (-0.5*bq/aq)*dum + if(quad .lt. 0.)then + quad = -bq/aq - quad + endif + else + quad = 0.5*(-bq+sqrt(bq*bq - 4.*cq)) + endif +!--end of quadratic solution + + mc(jc_h,ibin) = max(quad, 1.D-7) + ma(ja_so4,ibin) = mSULF*dumK/(mc(jc_h,ibin) + dumK) + ma(ja_hso4,ibin)= mSULF - ma(ja_so4,ibin) + + + activity(jnh4so4,ibin) = mc(jc_nh4,ibin)**2*ma(ja_so4,ibin)* & + gam(jnh4so4,ibin)**3 + + activity(jlvcite,ibin) = mc(jc_nh4,ibin)**3*ma(ja_hso4,ibin)* & + ma(ja_so4,ibin) * gam(jlvcite,ibin)**5 + + activity(jnh4hso4,ibin)= mc(jc_nh4,ibin)*ma(ja_hso4,ibin)* & + gam(jnh4hso4,ibin)**2 + + activity(jnh4msa,ibin) = mc(jc_nh4,ibin)*ma(ja_msa,ibin)* & + gam(jnh4msa,ibin)**2 + + activity(jna2so4,ibin) = mc(jc_na,ibin)**2*ma(ja_so4,ibin)* & + gam(jna2so4,ibin)**3 + + activity(jnahso4,ibin) = mc(jc_na,ibin)*ma(ja_hso4,ibin)* & + gam(jnahso4,ibin)**2 + + activity(jnamsa,ibin) = mc(jc_na,ibin)*ma(ja_msa,ibin)* & + gam(jnamsa,ibin)**2 + +! activity(jna3hso4,ibin)= mc(jc_na,ibin)**3*ma(ja_hso4,ibin)* & +! ma(ja_so4,ibin)*gam(jna3hso4,ibin)**5 + + activity(jna3hso4,ibin)= 0.0 + + activity(jhno3,ibin) = mc(jc_h,ibin)*ma(ja_no3,ibin)* & + gam(jhno3,ibin)**2 + + activity(jhcl,ibin) = mc(jc_h,ibin)*ma(ja_cl,ibin)* & + gam(jhcl,ibin)**2 + + activity(jmsa,ibin) = mc(jc_h,ibin)*ma(ja_msa,ibin)* & + gam(jmsa,ibin)**2 + + +! sulfate-poor species + activity(jnh4no3,ibin) = 0.0 + + activity(jnh4cl,ibin) = 0.0 + + activity(jnano3,ibin) = 0.0 + + activity(jnacl,ibin) = 0.0 + + activity(jcano3,ibin) = 0.0 + + activity(jcacl2,ibin) = 0.0 + + + endif + + + + + return + end subroutine compute_activities + + + + + + + + + + + + +!*********************************************************************** +! computes mtem ternary parameters only once per transport time-step +! for a given ah2o (= rh) +! +! author: rahul a. zaveri +! update: jan 2005 +! reference: zaveri, r.a., r.c. easter, and a.s. wexler, +! a new method for multicomponent activity coefficients of electrolytes +! in aqueous atmospheric aerosols, j. geophys. res., 2005. +!----------------------------------------------------------------------- + subroutine mtem_compute_log_gamz +! implicit none +! include 'mosaic.h' +! local variables + integer ja +! functions +! real(kind=8) fnlog_gamz, bin_molality + + +! sulfate-poor species + ja = jhno3 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + + + ja = jhcl + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + + + ja = jnh4so4 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + + + ja = jnh4no3 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jnh4cl + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jna2so4 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + + + ja = jnano3 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jnacl + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jcano3 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jcacl2 + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnh4no3) = fnlog_gamz(ja,jnh4no3) + log_gamz(ja,jnh4cl) = fnlog_gamz(ja,jnh4cl) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jnano3) = fnlog_gamz(ja,jnano3) + log_gamz(ja,jnacl) = fnlog_gamz(ja,jnacl) + log_gamz(ja,jcano3) = fnlog_gamz(ja,jcano3) + log_gamz(ja,jcacl2) = fnlog_gamz(ja,jcacl2) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + +! sulfate-rich species + ja = jh2so4 + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jhhso4 + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jnh4hso4 + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jlvcite + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jnahso4 + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + + ja = jna3hso4 + log_gamz(ja,jh2so4) = fnlog_gamz(ja,jh2so4) + log_gamz(ja,jnh4hso4)= fnlog_gamz(ja,jnh4hso4) + log_gamz(ja,jlvcite) = fnlog_gamz(ja,jlvcite) + log_gamz(ja,jnh4so4) = fnlog_gamz(ja,jnh4so4) + log_gamz(ja,jnahso4) = fnlog_gamz(ja,jnahso4) + log_gamz(ja,jna3hso4)= fnlog_gamz(ja,jna3hso4) + log_gamz(ja,jna2so4) = fnlog_gamz(ja,jna2so4) + log_gamz(ja,jhno3) = fnlog_gamz(ja,jhno3) + log_gamz(ja,jhcl) = fnlog_gamz(ja,jhcl) + + return + end subroutine mtem_compute_log_gamz + + + + + + + + + + + + + + + + + + + + + + + + + + + + +!*********************************************************************** +! computes sulfate ratio +! +! author: rahul a. zaveri +! update: dec 1999 +!----------------------------------------------------------------------- + subroutine calculate_xt(ibin,jp,xt) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, jp + real(kind=8) xt + + + if( (aer(iso4_a,jp,ibin)+aer(imsa_a,jp,ibin)) .gt.0.0)then + xt = ( aer(inh4_a,jp,ibin) + & + & aer(ina_a,jp,ibin) + & + & 2.*aer(ica_a,jp,ibin) )/ & + & (aer(iso4_a,jp,ibin)+0.5*aer(imsa_a,jp,ibin)) + else + xt = -1.0 + endif + + + return + end subroutine calculate_xt + + + + + +!*********************************************************************** +! computes ions from electrolytes +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine electrolytes_to_ions(jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin +! local variables + real(kind=8) sum_dum + + + aer(iso4_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jna2so4,jp,ibin) + & + 2.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnh4so4,jp,ibin) + & + 2.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jh2so4,jp,ibin) + + aer(ino3_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + 2.*electrolyte(jcano3,jp,ibin) + & + electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jhno3,jp,ibin) + + aer(icl_a,jp,ibin) = electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jcacl2,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + electrolyte(jhcl,jp,ibin) + + aer(imsa_a,jp,ibin) = electrolyte(jnh4msa,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + & + 2.*electrolyte(jcamsa2,jp,ibin) + & + electrolyte(jmsa,jp,ibin) + + aer(ico3_a,jp,ibin) = electrolyte(jcaco3,jp,ibin) + + aer(ica_a,jp,ibin) = electrolyte(jcaso4,jp,ibin) + & + electrolyte(jcano3,jp,ibin) + & + electrolyte(jcacl2,jp,ibin) + & + electrolyte(jcaco3,jp,ibin) + & + electrolyte(jcamsa2,jp,ibin) + + aer(ina_a,jp,ibin) = electrolyte(jnano3,jp,ibin) + & + electrolyte(jnacl,jp,ibin) + & + 2.*electrolyte(jna2so4,jp,ibin) + & + 3.*electrolyte(jna3hso4,jp,ibin)+ & + electrolyte(jnahso4,jp,ibin) + & + electrolyte(jnamsa,jp,ibin) + + aer(inh4_a,jp,ibin) = electrolyte(jnh4no3,jp,ibin) + & + electrolyte(jnh4cl,jp,ibin) + & + 2.*electrolyte(jnh4so4,jp,ibin) + & + 3.*electrolyte(jlvcite,jp,ibin) + & + electrolyte(jnh4hso4,jp,ibin)+ & + electrolyte(jnh4msa,jp,ibin) + + + sum_dum = aer(ica_a,jp,ibin) + & + aer(ina_a,jp,ibin) + & + aer(inh4_a,jp,ibin)+ & + aer(iso4_a,jp,ibin)+ & + aer(ino3_a,jp,ibin)+ & + aer(icl_a,jp,ibin) + & + aer(imsa_a,jp,ibin)+ & + aer(ico3_a,jp,ibin) + + if(sum_dum .eq. 0.)sum_dum = 1.0 + aer_sum(jp,ibin) = sum_dum + + aer_percent(ica_a,jp,ibin) = 100.*aer(ica_a,jp,ibin)/sum_dum + aer_percent(ina_a,jp,ibin) = 100.*aer(ina_a,jp,ibin)/sum_dum + aer_percent(inh4_a,jp,ibin)= 100.*aer(inh4_a,jp,ibin)/sum_dum + aer_percent(iso4_a,jp,ibin)= 100.*aer(iso4_a,jp,ibin)/sum_dum + aer_percent(ino3_a,jp,ibin)= 100.*aer(ino3_a,jp,ibin)/sum_dum + aer_percent(icl_a,jp,ibin) = 100.*aer(icl_a,jp,ibin)/sum_dum + aer_percent(imsa_a,jp,ibin)= 100.*aer(imsa_a,jp,ibin)/sum_dum + aer_percent(ico3_a,jp,ibin)= 100.*aer(ico3_a,jp,ibin)/sum_dum + + + return + end subroutine electrolytes_to_ions + + + + + + + + + + +!*********************************************************************** +! combinatorial method for computing electrolytes from ions +! +! notes: +! - to be used for liquid-phase or total-phase only +! - transfers caso4 and caco3 from liquid to solid phase +! +! author: rahul a. zaveri (based on code provided by a.s. wexler +! update: apr 2005 +!----------------------------------------------------------------------- + subroutine ions_to_electrolytes(jp,ibin,xt) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, jp + real(kind=8) xt +! local variables + integer iaer, je, jc, ja, icase + real(kind=8) store(naer), sum_dum, sum_naza, sum_nczc, sum_na_nh4, & + f_nh4, f_na, xh, xb, xl, xs, cat_net, rem_nh4, rem_na + real(kind=8) nc(ncation), na(nanion) + + + + + if(jp .ne. jliquid)then + if (iprint_mosaic_fe1 .gt. 0) then + write(6,*)' jp must be jliquid' + write(6,*)' in ions_to_electrolytes sub' + write(6,*)' wrong jp = ', jp + write(6,*)' mosaic fatal error in ions_to_electrolytes' + endif +! stop + istat_mosaic_fe1 = -2000 + return + endif + +! remove negative concentrations, if any + do iaer = 1, naer + aer(iaer,jp,ibin) = max(0.0D0, aer(iaer,jp,ibin)) + enddo + + +! first transfer caso4 from liquid to solid phase (caco3 should not be present here) + store(ica_a) = aer(ica_a, jp,ibin) + store(iso4_a) = aer(iso4_a,jp,ibin) + + call form_caso4(store,jp,ibin) + + if(jp .eq. jliquid)then ! transfer caso4 from liquid to solid phase + aer(ica_a,jliquid,ibin) = aer(ica_a,jliquid,ibin) - & + electrolyte(jcaso4,jliquid,ibin) + + aer(iso4_a,jliquid,ibin)= aer(iso4_a,jliquid,ibin)- & + electrolyte(jcaso4,jliquid,ibin) + + aer(ica_a,jsolid,ibin) = aer(ica_a,jsolid,ibin) + & + electrolyte(jcaso4,jliquid,ibin) + + aer(iso4_a,jsolid,ibin) = aer(iso4_a,jsolid,ibin) + & + electrolyte(jcaso4,jliquid,ibin) + + electrolyte(jcaso4,jsolid,ibin)=electrolyte(jcaso4,jsolid,ibin) & + +electrolyte(jcaso4,jliquid,ibin) + electrolyte(jcaso4,jliquid,ibin)= 0.0 + endif + + +! calculate sulfate ratio + call calculate_xt(ibin,jp,xt) + + if(xt .ge. 1.9999 .or. xt.lt.0.)then + icase = 1 ! near neutral (acidity is caused by hcl and/or hno3) + else + icase = 2 ! acidic (acidity is caused by excess so4) + endif + + +! initialize to zero + do je = 1, nelectrolyte + electrolyte(je,jp,ibin) = 0.0 + enddo +! +!--------------------------------------------------------- +! initialize moles of ions depending on the sulfate domain + + if(icase.eq.1)then ! xt >= 2 : sulfate poor domain + + na(ja_hso4)= 0.0 + na(ja_so4) = aer(iso4_a,jp,ibin) + na(ja_no3) = aer(ino3_a,jp,ibin) + na(ja_cl) = aer(icl_a, jp,ibin) + na(ja_msa) = aer(imsa_a,jp,ibin) + + nc(jc_ca) = aer(ica_a, jp,ibin) + nc(jc_na) = aer(ina_a, jp,ibin) + nc(jc_nh4) = aer(inh4_a,jp,ibin) + + cat_net =& + ( 2.*na(ja_so4)+na(ja_no3)+na(ja_cl)+na(ja_msa) )- & + ( 2.*nc(jc_ca) +nc(jc_nh4)+nc(jc_na) ) + + if(cat_net .lt. 0.0)then + + nc(jc_h) = 0.0 + + else ! cat_net must be 0.0 or positive + + nc(jc_h) = cat_net + + endif + + +! now compute equivalent fractions + sum_naza = 0.0 + do ja = 1, nanion + sum_naza = sum_naza + na(ja)*za(ja) + enddo + + sum_nczc = 0.0 + do jc = 1, ncation + sum_nczc = sum_nczc + nc(jc)*zc(jc) + enddo + + if(sum_naza .eq. 0. .or. sum_nczc .eq. 0.)then + if (iprint_mosaic_diag1 .gt. 0) then + write(6,*)'mosaic ions_to_electrolytes' + write(6,*)'ionic concentrations are zero' + write(6,*)'sum_naza = ', sum_naza + write(6,*)'sum_nczc = ', sum_nczc + endif + return + endif + + do ja = 1, nanion + xeq_a(ja) = na(ja)*za(ja)/sum_naza + enddo + + do jc = 1, ncation + xeq_c(jc) = nc(jc)*zc(jc)/sum_nczc + enddo + + na_ma(ja_so4) = na(ja_so4) *mw_a(ja_so4) + na_ma(ja_no3) = na(ja_no3) *mw_a(ja_no3) + na_ma(ja_cl) = na(ja_cl) *mw_a(ja_cl) + na_ma(ja_msa) = na(ja_msa) *mw_a(ja_msa) + na_ma(ja_hso4)= na(ja_hso4)*mw_a(ja_hso4) + + nc_mc(jc_ca) = nc(jc_ca) *mw_c(jc_ca) + nc_mc(jc_na) = nc(jc_na) *mw_c(jc_na) + nc_mc(jc_nh4) = nc(jc_nh4)*mw_c(jc_nh4) + nc_mc(jc_h) = nc(jc_h) *mw_c(jc_h) + + +! now compute electrolyte moles + if(xeq_c(jc_na) .gt. 0. .and. xeq_a(ja_so4) .gt. 0.)then + electrolyte(jna2so4,jp,ibin) = (xeq_c(jc_na) *na_ma(ja_so4) + & + xeq_a(ja_so4)*nc_mc(jc_na))/ & + mw_electrolyte(jna2so4) + endif + + electrolyte(jnahso4,jp,ibin) = 0.0 + + if(xeq_c(jc_na) .gt. 0. .and. xeq_a(ja_msa) .gt. 0.)then + electrolyte(jnamsa,jp,ibin) = (xeq_c(jc_na) *na_Ma(ja_msa) + & + xeq_a(ja_msa)*nc_Mc(jc_na))/ & + mw_electrolyte(jnamsa) + endif + + if(xeq_c(jc_na) .gt. 0. .and. xeq_a(ja_no3) .gt. 0.)then + electrolyte(jnano3, jp,ibin) = (xeq_c(jc_na) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_na))/ & + mw_electrolyte(jnano3) + endif + + if(xeq_c(jc_na) .gt. 0. .and. xeq_a(ja_cl) .gt. 0.)then + electrolyte(jnacl, jp,ibin) = (xeq_c(jc_na) *na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_na))/ & + mw_electrolyte(jnacl) + endif + + if(xeq_c(jc_nh4) .gt. 0. .and. xeq_a(ja_so4) .gt. 0.)then + electrolyte(jnh4so4,jp,ibin) = (xeq_c(jc_nh4)*na_ma(ja_so4) + & + xeq_a(ja_so4)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4so4) + endif + + electrolyte(jnh4hso4,jp,ibin)= 0.0 + + if(xeq_c(jc_nh4) .gt. 0. .and. xeq_a(ja_msa) .gt. 0.)then + electrolyte(jnh4msa,jp,ibin) = (xeq_c(jc_nh4)*na_Ma(ja_msa) + & + xeq_a(ja_msa)*nc_Mc(jc_nh4))/ & + mw_electrolyte(jnh4msa) + endif + + if(xeq_c(jc_nh4) .gt. 0. .and. xeq_a(ja_no3) .gt. 0.)then + electrolyte(jnh4no3,jp,ibin) = (xeq_c(jc_nh4)*na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4no3) + endif + + if(xeq_c(jc_nh4) .gt. 0. .and. xeq_a(ja_cl) .gt. 0.)then + electrolyte(jnh4cl, jp,ibin) = (xeq_c(jc_nh4)*na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_nh4))/ & + mw_electrolyte(jnh4cl) + endif + + if(xeq_c(jc_ca) .gt. 0. .and. xeq_a(ja_no3) .gt. 0.0)then + electrolyte(jcano3, jp,ibin) = (xeq_c(jc_ca) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_ca))/ & + mw_electrolyte(jcano3) + endif + + if(xeq_c(jc_ca) .gt. 0. .and. xeq_a(ja_cl) .gt. 0.)then + electrolyte(jcacl2, jp,ibin) = (xeq_c(jc_ca) *na_ma(ja_cl) + & + xeq_a(ja_cl) *nc_mc(jc_ca))/ & + mw_electrolyte(jcacl2) + endif + + if(xeq_c(jc_ca) .gt. 0. .and. xeq_a(ja_msa) .gt. 0.)then + electrolyte(jcamsa2,jp,ibin) = (xeq_c(jc_ca) *na_Ma(ja_msa) + & + xeq_a(ja_msa) *nc_Mc(jc_ca))/ & + mw_electrolyte(jcamsa2) + endif + + electrolyte(jh2so4, jp,ibin) = 0.0 + + if(xeq_c(jc_h) .gt. 0. .and. xeq_a(ja_no3) .gt. 0.)then + electrolyte(jhno3, jp,ibin) = (xeq_c(jc_h) *na_ma(ja_no3) + & + xeq_a(ja_no3)*nc_mc(jc_h))/ & + mw_electrolyte(jhno3) + endif + + if(xeq_c(jc_h) .gt. 0. .and. xeq_a(ja_cl) .gt. 0.)then + electrolyte(jhcl, jp,ibin) = (xeq_c(jc_h) *na_ma(ja_cl) + & + xeq_a(ja_cl)*nc_mc(jc_h))/ & + mw_electrolyte(jhcl) + endif + + if(xeq_c(jc_h) .gt. 0. .and. xeq_a(ja_msa) .gt. 0.)then + electrolyte(jmsa,jp,ibin) = (xeq_c(jc_h) *na_ma(ja_msa) + & + xeq_a(ja_msa)*nc_mc(jc_h))/ & + mw_electrolyte(jmsa) + endif + +!-------------------------------------------------------------------- + + elseif(icase.eq.2)then ! xt < 2 : sulfate rich domain + + store(imsa_a) = aer(imsa_a,jp,ibin) + store(ica_a) = aer(ica_a, jp,ibin) + + call form_camsa2(store,jp,ibin) + + sum_na_nh4 = aer(ina_a,jp,ibin) + aer(inh4_a,jp,ibin) + + if(sum_na_nh4 .gt. 0.0)then + f_nh4 = aer(inh4_a,jp,ibin)/sum_na_nh4 + f_na = aer(ina_a,jp,ibin)/sum_na_nh4 + else + f_nh4 = 0.0 + f_na = 0.0 + endif + +! first form msa electrolytes + if(sum_na_nh4 .gt. store(imsa_a))then + electrolyte(jnamsa,jp,ibin) = f_na *store(imsa_a) + electrolyte(jnh4msa,jp,ibin) = f_nh4*store(imsa_a) + rem_na = aer(ina_a,jp,ibin) - electrolyte(jnamsa,jp,ibin) ! remaining na + rem_nh4= aer(inh4_a,jp,ibin)- electrolyte(jnh4msa,jp,ibin) ! remaining nh4 + else + electrolyte(jnamsa,jp,ibin) = aer(ina_a,jp,ibin) + electrolyte(jnh4msa,jp,ibin) = aer(inh4_a,jp,ibin) + electrolyte(jmsa,jp,ibin) = store(imsa_a) - sum_na_nh4 + rem_nh4 = 0.0 ! remaining nh4 + rem_na = 0.0 ! remaining na + endif + + +! recompute xt + if(aer(iso4_a,jp,ibin).gt.0.0)then + xt = (rem_nh4 + rem_na)/aer(iso4_a,jp,ibin) + else + goto 10 + endif + + if(xt .le. 1.0)then ! h2so4 + bisulfate + xh = (1.0 - xt) + xb = xt + electrolyte(jh2so4,jp,ibin) = xh*aer(iso4_a,jp,ibin) + electrolyte(jnh4hso4,jp,ibin) = xb*f_nh4*aer(iso4_a,jp,ibin) + electrolyte(jnahso4,jp,ibin) = xb*f_na *aer(iso4_a,jp,ibin) + elseif(xt .le. 1.5)then ! bisulfate + letovicite + xb = 3.0 - 2.0*xt + xl = xt - 1.0 + electrolyte(jnh4hso4,jp,ibin) = xb*f_nh4*aer(iso4_a,jp,ibin) + electrolyte(jnahso4,jp,ibin) = xb*f_na *aer(iso4_a,jp,ibin) + electrolyte(jlvcite,jp,ibin) = xl*f_nh4*aer(iso4_a,jp,ibin) + electrolyte(jna3hso4,jp,ibin) = xl*f_na *aer(iso4_a,jp,ibin) + else ! letovicite + sulfate + xl = 2.0 - xt + xs = 2.0*xt - 3.0 + electrolyte(jlvcite,jp,ibin) = xl*f_nh4*aer(iso4_a,jp,ibin) + electrolyte(jna3hso4,jp,ibin) = xl*f_na *aer(iso4_a,jp,ibin) + electrolyte(jnh4so4,jp,ibin) = xs*f_nh4*aer(iso4_a,jp,ibin) + electrolyte(jna2so4,jp,ibin) = xs*f_na *aer(iso4_a,jp,ibin) + endif + + electrolyte(jhno3,jp,ibin) = aer(ino3_a,jp,ibin) + electrolyte(jhcl,jp,ibin) = aer(icl_a,jp,ibin) + + endif +!--------------------------------------------------------- +! +! calculate % composition +10 sum_dum = 0.0 + do je = 1, nelectrolyte + sum_dum = sum_dum + electrolyte(je,jp,ibin) + enddo + + if(sum_dum .eq. 0.)sum_dum = 1.0 + electrolyte_sum(jp,ibin) = sum_dum + + do je = 1, nelectrolyte + epercent(je,jp,ibin) = 100.*electrolyte(je,jp,ibin)/sum_dum + enddo + + sum_dum = aer(ica_a,jp,ibin) + & + aer(ina_a,jp,ibin) + & + aer(inh4_a,jp,ibin)+ & + aer(iso4_a,jp,ibin)+ & + aer(ino3_a,jp,ibin)+ & + aer(icl_a,jp,ibin) + & + aer(imsa_a,jp,ibin)+ & + aer(ico3_a,jp,ibin) + + if(sum_dum .eq. 0.)sum_dum = 1.0 + aer_sum(jp,ibin) = sum_dum + + aer_percent(ica_a,jp,ibin) = 100.*aer(ica_a,jp,ibin)/sum_dum + aer_percent(ina_a,jp,ibin) = 100.*aer(ina_a,jp,ibin)/sum_dum + aer_percent(inh4_a,jp,ibin)= 100.*aer(inh4_a,jp,ibin)/sum_dum + aer_percent(iso4_a,jp,ibin)= 100.*aer(iso4_a,jp,ibin)/sum_dum + aer_percent(ino3_a,jp,ibin)= 100.*aer(ino3_a,jp,ibin)/sum_dum + aer_percent(icl_a,jp,ibin) = 100.*aer(icl_a,jp,ibin)/sum_dum + aer_percent(imsa_a,jp,ibin)= 100.*aer(imsa_a,jp,ibin)/sum_dum + aer_percent(ico3_a,jp,ibin)= 100.*aer(ico3_a,jp,ibin)/sum_dum + + + + return + end subroutine ions_to_electrolytes + + + + + + + + + + + + + + + + + + + + + + + + + + + +!*********************************************************************** +! conforms aerosol generic species to a valid electrolyte composition +! +! author: rahul a. zaveri +! update: june 2000 +!----------------------------------------------------------------------- + subroutine conform_electrolytes(jp,ibin,xt) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, jp + real(kind=8) xt +! local variables + integer i, ixt_case, je + real(kind=8) sum_dum, xna_prime, xnh4_prime, xt_prime + real(kind=8) store(naer) + +! remove negative concentrations, if any + do i=1,naer + aer(i,jp,ibin) = max(0.0D0, aer(i,jp,ibin)) + enddo + + + call calculate_xt(ibin,jp,xt) + + if(xt .ge. 1.9999 .or. xt.lt.0.)then + ixt_case = 1 ! near neutral (acidity is caused by hcl and/or hno3) + else + ixt_case = 2 ! acidic (acidity is caused by excess so4) + endif + +! initialize +! +! put total aer(*) into store(*) + store(iso4_a) = aer(iso4_a,jp,ibin) + store(ino3_a) = aer(ino3_a,jp,ibin) + store(icl_a) = aer(icl_a, jp,ibin) + store(imsa_a) = aer(imsa_a,jp,ibin) + store(ico3_a) = aer(ico3_a,jp,ibin) + store(inh4_a) = aer(inh4_a,jp,ibin) + store(ina_a) = aer(ina_a, jp,ibin) + store(ica_a) = aer(ica_a, jp,ibin) + + do je=1,nelectrolyte + electrolyte(je,jp,ibin) = 0.0 + enddo +! +!--------------------------------------------------------- +! + if(ixt_case.eq.1)then + +! xt >= 2 : sulfate deficient + + call form_caso4(store,jp,ibin) + call form_camsa2(store,jp,ibin) + call form_na2so4(store,jp,ibin) + call form_namsa(store,jp,ibin) + call form_cano3(store,jp,ibin) + call form_nano3(store,jp,ibin) + call form_nacl(store,jp,ibin) + call form_cacl2(store,jp,ibin) + call form_caco3(store,jp,ibin) + call form_nh4so4(store,jp,ibin) + call form_nh4msa(store,jp,ibin) + call form_nh4no3(store,jp,ibin) + call form_nh4cl(store,jp,ibin) + call form_msa(store,jp,ibin) + call degas_hno3(store,jp,ibin) + call degas_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + + elseif(ixt_case.eq.2)then + +! xt < 2 : sulfate enough or sulfate excess + + call form_caso4(store,jp,ibin) + call form_camsa2(store,jp,ibin) + call form_namsa(store,jp,ibin) + call form_nh4msa(store,jp,ibin) + call form_msa(store,jp,ibin) + + if(store(iso4_a).eq.0.0)goto 10 + + + xt_prime =(store(ina_a)+store(inh4_a))/ & + store(iso4_a) + xna_prime=0.5*store(ina_a)/store(iso4_a) + 1. + + if(xt_prime.ge.xna_prime)then + call form_na2so4(store,jp,ibin) + xnh4_prime = 0.0 + if(store(iso4_a).gt.1.e-15)then + xnh4_prime = store(inh4_a)/store(iso4_a) + endif + + if(xnh4_prime .ge. 1.5)then + call form_nh4so4_lvcite(store,jp,ibin) + else + call form_lvcite_nh4hso4(store,jp,ibin) + endif + + elseif(xt_prime.ge.1.)then + call form_nh4hso4(store,jp,ibin) + call form_na2so4_nahso4(store,jp,ibin) + elseif(xt_prime.lt.1.)then + call form_nahso4(store,jp,ibin) + call form_nh4hso4(store,jp,ibin) + call form_h2so4(store,jp,ibin) + endif + +10 call degas_hno3(store,jp,ibin) + call degas_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + + endif ! case 1, 2 + + +! re-calculate ions to eliminate round-off errors + call electrolytes_to_ions(jp, ibin) +!--------------------------------------------------------- +! +! calculate % composition + sum_dum = 0.0 + do je = 1, nelectrolyte + electrolyte(je,jp,ibin) = max(0.D0,electrolyte(je,jp,ibin)) ! remove -ve + sum_dum = sum_dum + electrolyte(je,jp,ibin) + enddo + + if(sum_dum .eq. 0.)sum_dum = 1.0 + electrolyte_sum(jp,ibin) = sum_dum + + do je = 1, nelectrolyte + epercent(je,jp,ibin) = 100.*electrolyte(je,jp,ibin)/sum_dum + enddo + + + sum_dum = aer(ica_a,jp,ibin) + & + aer(ina_a,jp,ibin) + & + aer(inh4_a,jp,ibin)+ & + aer(iso4_a,jp,ibin)+ & + aer(ino3_a,jp,ibin)+ & + aer(icl_a,jp,ibin) + & + aer(imsa_a,jp,ibin)+ & + aer(ico3_a,jp,ibin) + + if(sum_dum .eq. 0.)sum_dum = 1.0 + aer_sum(jp,ibin) = sum_dum + + aer_percent(ica_a,jp,ibin) = 100.*aer(ica_a,jp,ibin)/sum_dum + aer_percent(ina_a,jp,ibin) = 100.*aer(ina_a,jp,ibin)/sum_dum + aer_percent(inh4_a,jp,ibin)= 100.*aer(inh4_a,jp,ibin)/sum_dum + aer_percent(iso4_a,jp,ibin)= 100.*aer(iso4_a,jp,ibin)/sum_dum + aer_percent(ino3_a,jp,ibin)= 100.*aer(ino3_a,jp,ibin)/sum_dum + aer_percent(icl_a,jp,ibin) = 100.*aer(icl_a,jp,ibin)/sum_dum + aer_percent(imsa_a,jp,ibin)= 100.*aer(imsa_a,jp,ibin)/sum_dum + aer_percent(ico3_a,jp,ibin)= 100.*aer(ico3_a,jp,ibin)/sum_dum + + return + end subroutine conform_electrolytes + + + + + + + + + + + +!*********************************************************************** +! forms electrolytes from ions +! +! author: rahul a. zaveri +! update: june 2000 +!----------------------------------------------------------------------- + subroutine form_electrolytes(jp,ibin,xt) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin, jp + real(kind=8) xt +! local variables + integer i, ixt_case, j, je + real(kind=8) sum_dum, xna_prime, xnh4_prime, xt_prime + real(kind=8) store(naer) + +! remove negative concentrations, if any + do i=1,naer + aer(i,jp,ibin) = max(0.0D0, aer(i,jp,ibin)) + enddo + + + call calculate_xt(ibin,jp,xt) + + if(xt .ge. 1.9999 .or. xt.lt.0.)then + ixt_case = 1 ! near neutral (acidity is caused by hcl and/or hno3) + else + ixt_case = 2 ! acidic (acidity is caused by excess so4) + endif + +! initialize +! +! put total aer(*) into store(*) + store(iso4_a) = aer(iso4_a,jp,ibin) + store(ino3_a) = aer(ino3_a,jp,ibin) + store(icl_a) = aer(icl_a, jp,ibin) + store(imsa_a) = aer(imsa_a,jp,ibin) + store(ico3_a) = aer(ico3_a,jp,ibin) + store(inh4_a) = aer(inh4_a,jp,ibin) + store(ina_a) = aer(ina_a, jp,ibin) + store(ica_a) = aer(ica_a, jp,ibin) +! + do j=1,nelectrolyte + electrolyte(j,jp,ibin) = 0.0 + enddo +! +!--------------------------------------------------------- +! + if(ixt_case.eq.1)then + +! xt >= 2 : sulfate deficient + call form_caso4(store,jp,ibin) + call form_camsa2(store,jp,ibin) + call form_na2so4(store,jp,ibin) + call form_namsa(store,jp,ibin) + call form_cano3(store,jp,ibin) + call form_nano3(store,jp,ibin) + call form_nacl(store,jp,ibin) + call form_cacl2(store,jp,ibin) + call form_caco3(store,jp,ibin) + call form_nh4so4(store,jp,ibin) + call form_nh4msa(store,jp,ibin) + call form_nh4no3(store,jp,ibin) + call form_nh4cl(store,jp,ibin) + call form_msa(store,jp,ibin) + + if(jp .eq. jsolid)then + call degas_hno3(store,jp,ibin) + call degas_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + else + call form_hno3(store,jp,ibin) + call form_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + endif + + + + elseif(ixt_case.eq.2)then + +! xt < 2 : sulfate enough or sulfate excess + + call form_caso4(store,jp,ibin) + call form_camsa2(store,jp,ibin) + call form_namsa(store,jp,ibin) + call form_nh4msa(store,jp,ibin) + call form_msa(store,jp,ibin) + + if(store(iso4_a).eq.0.0)goto 10 + + + xt_prime =(store(ina_a)+store(inh4_a))/ & + store(iso4_a) + xna_prime=0.5*store(ina_a)/store(iso4_a) + 1. + + if(xt_prime.ge.xna_prime)then + call form_na2so4(store,jp,ibin) + xnh4_prime = 0.0 + if(store(iso4_a).gt.1.e-15)then + xnh4_prime = store(inh4_a)/store(iso4_a) + endif + + if(xnh4_prime .ge. 1.5)then + call form_nh4so4_lvcite(store,jp,ibin) + else + call form_lvcite_nh4hso4(store,jp,ibin) + endif + + elseif(xt_prime.ge.1.)then + call form_nh4hso4(store,jp,ibin) + call form_na2so4_nahso4(store,jp,ibin) + elseif(xt_prime.lt.1.)then + call form_nahso4(store,jp,ibin) + call form_nh4hso4(store,jp,ibin) + call form_h2so4(store,jp,ibin) + endif + +10 if(jp .eq. jsolid)then + call degas_hno3(store,jp,ibin) + call degas_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + else + call form_hno3(store,jp,ibin) + call form_hcl(store,jp,ibin) + call degas_nh3(store,jp,ibin) + endif + + endif ! case 1, 2 + + +! re-calculate ions to eliminate round-off errors + call electrolytes_to_ions(jp, ibin) +!--------------------------------------------------------- +! +! calculate % composition + sum_dum = 0.0 + do je = 1, nelectrolyte + electrolyte(je,jp,ibin) = max(0.D0,electrolyte(je,jp,ibin)) ! remove -ve + sum_dum = sum_dum + electrolyte(je,jp,ibin) + enddo + + if(sum_dum .eq. 0.)sum_dum = 1.0 + electrolyte_sum(jp,ibin) = sum_dum + + do je = 1, nelectrolyte + epercent(je,jp,ibin) = 100.*electrolyte(je,jp,ibin)/sum_dum + enddo + + sum_dum = aer(ica_a,jp,ibin) + & + aer(ina_a,jp,ibin) + & + aer(inh4_a,jp,ibin)+ & + aer(iso4_a,jp,ibin)+ & + aer(ino3_a,jp,ibin)+ & + aer(icl_a,jp,ibin) + & + aer(imsa_a,jp,ibin)+ & + aer(ico3_a,jp,ibin) + + if(sum_dum .eq. 0.)sum_dum = 1.0 + aer_sum(jp,ibin) = sum_dum + + aer_percent(ica_a,jp,ibin) = 100.*aer(ica_a,jp,ibin)/sum_dum + aer_percent(ina_a,jp,ibin) = 100.*aer(ina_a,jp,ibin)/sum_dum + aer_percent(inh4_a,jp,ibin)= 100.*aer(inh4_a,jp,ibin)/sum_dum + aer_percent(iso4_a,jp,ibin)= 100.*aer(iso4_a,jp,ibin)/sum_dum + aer_percent(ino3_a,jp,ibin)= 100.*aer(ino3_a,jp,ibin)/sum_dum + aer_percent(icl_a,jp,ibin) = 100.*aer(icl_a,jp,ibin)/sum_dum + aer_percent(imsa_a,jp,ibin)= 100.*aer(imsa_a,jp,ibin)/sum_dum + aer_percent(ico3_a,jp,ibin)= 100.*aer(ico3_a,jp,ibin)/sum_dum + + return + end subroutine form_electrolytes + + + + + + + + + + + + + + +!*********************************************************************** +! electrolyte formation subroutines +! +! author: rahul a. zaveri +! update: june 2000 +!----------------------------------------------------------------------- + subroutine form_caso4(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jcaso4,jp,ibin) = min(store(ica_a),store(iso4_a)) + store(ica_a) = store(ica_a) - electrolyte(jcaso4,jp,ibin) + store(iso4_a) = store(iso4_a) - electrolyte(jcaso4,jp,ibin) + store(ica_a) = max(0.D0, store(ica_a)) + store(iso4_a) = max(0.D0, store(iso4_a)) + + return + end subroutine form_caso4 + + + + subroutine form_camsa2(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jcamsa2,jp,ibin) = min(store(ica_a),0.5*store(imsa_a)) + store(ica_a) = store(ica_a) - electrolyte(jcamsa2,jp,ibin) + store(imsa_a) = store(imsa_a) - 2.d0*electrolyte(jcamsa2,jp,ibin) + store(ica_a) = max(0.D0, store(ica_a)) + store(imsa_a) = max(0.D0, store(imsa_a)) + + return + end subroutine form_camsa2 + + + + subroutine form_cano3(store,jp,ibin) ! ca(no3)2 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jcano3,jp,ibin) = min(store(ica_a),0.5*store(ino3_a)) + + store(ica_a) = store(ica_a) - electrolyte(jcano3,jp,ibin) + store(ino3_a) = store(ino3_a) - 2.*electrolyte(jcano3,jp,ibin) + store(ica_a) = max(0.D0, store(ica_a)) + store(ino3_a) = max(0.D0, store(ino3_a)) + + return + end subroutine form_cano3 + + + subroutine form_cacl2(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jcacl2,jp,ibin) = min(store(ica_a),0.5*store(icl_a)) + + store(ica_a) = store(ica_a) - electrolyte(jcacl2,jp,ibin) + store(icl_a) = store(icl_a) - 2.*electrolyte(jcacl2,jp,ibin) + store(ica_a) = max(0.D0, store(ica_a)) + store(icl_a) = max(0.D0, store(icl_a)) + + return + end subroutine form_cacl2 + + + subroutine form_caco3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + if(jp.eq.jtotal .or. jp.eq.jsolid)then + electrolyte(jcaco3,jp,ibin) = store(ica_a) + + aer(ico3_a,jp,ibin)= electrolyte(jcaco3,jp,ibin) ! force co3 = caco3 + + store(ica_a) = 0.0 + store(ico3_a)= 0.0 + endif + + return + end subroutine form_caco3 + + + subroutine form_na2so4(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jna2so4,jp,ibin) = min(.5*store(ina_a), & + store(iso4_a)) + store(ina_a) = store(ina_a) - 2.*electrolyte(jna2so4,jp,ibin) + store(iso4_a)= store(iso4_a) - electrolyte(jna2so4,jp,ibin) + store(ina_a) = max(0.D0, store(ina_a)) + store(iso4_a)= max(0.D0, store(iso4_a)) + + return + end subroutine form_na2so4 + + + + subroutine form_nahso4(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnahso4,jp,ibin) = min(store(ina_a), & + store(iso4_a)) + store(ina_a) = store(ina_a) - electrolyte(jnahso4,jp,ibin) + store(iso4_a) = store(iso4_a) - electrolyte(jnahso4,jp,ibin) + store(ina_a) = max(0.D0, store(ina_a)) + store(iso4_a) = max(0.D0, store(iso4_a)) + + return + end subroutine form_nahso4 + + + + subroutine form_namsa(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnamsa,jp,ibin) = min(store(ina_a), & + store(imsa_a)) + store(ina_a) = store(ina_a) - electrolyte(jnamsa,jp,ibin) + store(imsa_a) = store(imsa_a) - electrolyte(jnamsa,jp,ibin) + store(ina_a) = max(0.D0, store(ina_a)) + store(imsa_a) = max(0.D0, store(imsa_a)) + + return + end subroutine form_namsa + + + + subroutine form_nano3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnano3,jp,ibin)=min(store(ina_a),store(ino3_a)) + store(ina_a) = store(ina_a) - electrolyte(jnano3,jp,ibin) + store(ino3_a) = store(ino3_a) - electrolyte(jnano3,jp,ibin) + store(ina_a) = max(0.D0, store(ina_a)) + store(ino3_a) = max(0.D0, store(ino3_a)) + + return + end subroutine form_nano3 + + + + subroutine form_nacl(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnacl,jp,ibin) = store(ina_a) + + store(ina_a) = 0.0 + store(icl_a) = store(icl_a) - electrolyte(jnacl,jp,ibin) + + if(store(icl_a) .lt. 0.)then ! cl deficit in aerosol. take some from gas + aer(icl_a,jp,ibin)= aer(icl_a,jp,ibin)- store(icl_a) ! update aer(icl_a) + + if(jp .ne. jtotal)then + aer(icl_a,jtotal,ibin)= aer(icl_a,jliquid,ibin)+ & ! update for jtotal + aer(icl_a,jsolid,ibin) + endif + + gas(ihcl_g) = gas(ihcl_g) + store(icl_a) ! update gas(ihcl_g) + + if(gas(ihcl_g) .lt. 0.0)then + total_species(ihcl_g) = total_species(ihcl_g) - gas(ihcl_g) ! update total_species + tot_cl_in = tot_cl_in - gas(ihcl_g) ! update tot_cl_in + endif + + gas(ihcl_g) = max(0.D0, gas(ihcl_g)) ! restrict gas(ihcl_g) to >= 0. + store(icl_a) = 0. ! force store(icl_a) to 0. + + endif + + store(icl_a) = max(0.D0, store(icl_a)) + + return + end subroutine form_nacl + + + + subroutine form_nh4so4(store,jp,ibin) ! (nh4)2so4 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4so4,jp,ibin)= min(.5*store(inh4_a), & + store(iso4_a)) + store(inh4_a)= store(inh4_a) - 2.*electrolyte(jnh4so4,jp,ibin) + store(iso4_a)= store(iso4_a) - electrolyte(jnh4so4,jp,ibin) + store(inh4_a) = max(0.D0, store(inh4_a)) + store(iso4_a) = max(0.D0, store(iso4_a)) + + return + end subroutine form_nh4so4 + + + + subroutine form_nh4hso4(store,jp,ibin) ! nh4hso4 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4hso4,jp,ibin) = min(store(inh4_a), & + store(iso4_a)) + store(inh4_a)= store(inh4_a) - electrolyte(jnh4hso4,jp,ibin) + store(iso4_a)= store(iso4_a) - electrolyte(jnh4hso4,jp,ibin) + store(inh4_a) = max(0.D0, store(inh4_a)) + store(iso4_a) = max(0.D0, store(iso4_a)) + + return + end subroutine form_nh4hso4 + + + + subroutine form_nh4msa(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4msa,jp,ibin) = min(store(inh4_a), & + store(imsa_a)) + store(inh4_a) = store(inh4_a) - electrolyte(jnh4msa,jp,ibin) + store(imsa_a) = store(imsa_a) - electrolyte(jnh4msa,jp,ibin) + store(inh4_a) = max(0.D0, store(inh4_a)) + store(imsa_a) = max(0.D0, store(imsa_a)) + + return + end subroutine form_nh4msa + + + + subroutine form_nh4cl(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4cl,jp,ibin) = min(store(inh4_a), & + store(icl_a)) + store(inh4_a) = store(inh4_a) - electrolyte(jnh4cl,jp,ibin) + store(icl_a) = store(icl_a) - electrolyte(jnh4cl,jp,ibin) + store(inh4_a) = max(0.D0, store(inh4_a)) + store(icl_a) = max(0.D0, store(icl_a)) + + return + end subroutine form_nh4cl + + + + subroutine form_nh4no3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4no3,jp,ibin) = min(store(inh4_a), & + store(ino3_a)) + store(inh4_a) = store(inh4_a) - electrolyte(jnh4no3,jp,ibin) + store(ino3_a) = store(ino3_a) - electrolyte(jnh4no3,jp,ibin) + store(inh4_a) = max(0.D0, store(inh4_a)) + store(ino3_a) = max(0.D0, store(ino3_a)) + + return + end subroutine form_nh4no3 + + + + subroutine form_nh4so4_lvcite(store,jp,ibin) ! (nh4)2so4 + (nh4)3h(so4)2 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jnh4so4,jp,ibin)= 2.*store(inh4_a) - 3.*store(iso4_a) + electrolyte(jlvcite,jp,ibin)= 2.*store(iso4_a) - store(inh4_a) + electrolyte(jnh4so4,jp,ibin)= max(0.D0, & + electrolyte(jnh4so4,jp,ibin)) + electrolyte(jlvcite,jp,ibin)= max(0.D0, & + electrolyte(jlvcite,jp,ibin)) + store(inh4_a) = 0. + store(iso4_a) = 0. + + return + end subroutine form_nh4so4_lvcite + + + + subroutine form_lvcite_nh4hso4(store,jp,ibin) ! (nh4)3h(so4)2 + nh4hso4 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jlvcite,jp,ibin) = store(inh4_a) - store(iso4_a) + electrolyte(jnh4hso4,jp,ibin)= 3.*store(iso4_a) - 2.*store(inh4_a) + electrolyte(jlvcite,jp,ibin) = max(0.D0, & + electrolyte(jlvcite,jp,ibin)) + electrolyte(jnh4hso4,jp,ibin)= max(0.D0, & + electrolyte(jnh4hso4,jp,ibin)) + store(inh4_a) = 0. + store(iso4_a) = 0. + + return + end subroutine form_lvcite_nh4hso4 + + + + subroutine form_na2so4_nahso4(store,jp,ibin) ! na2so4 + nahso4 +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jna2so4,jp,ibin)= store(ina_a) - store(iso4_a) + electrolyte(jnahso4,jp,ibin)= 2.*store(iso4_a) - store(ina_a) + electrolyte(jna2so4,jp,ibin)= max(0.D0, & + electrolyte(jna2so4,jp,ibin)) + electrolyte(jnahso4,jp,ibin)= max(0.D0, & + electrolyte(jnahso4,jp,ibin)) + store(ina_a) = 0. + store(iso4_a) = 0. + +! write(6,*)'na2so4 + nahso4' + + return + end subroutine form_na2so4_nahso4 + + + + + subroutine form_h2so4(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jh2so4,jp,ibin) = max(0.0D0, store(iso4_a)) + store(iso4_a) = 0.0 + + return + end subroutine form_h2so4 + + + + + subroutine form_msa(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jmsa,jp,ibin) = max(0.0D0, store(imsa_a)) + store(imsa_a) = 0.0 + + return + end subroutine form_msa + + + + subroutine form_hno3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jhno3,jp,ibin) = max(0.0D0, store(ino3_a)) + store(ino3_a) = 0.0 + + return + end subroutine form_hno3 + + + + + subroutine form_hcl(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + electrolyte(jhcl,jp,ibin) = max(0.0D0, store(icl_a)) + store(icl_a) = 0.0 + + return + end subroutine form_hcl + + + + + subroutine degas_hno3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + store(ino3_a) = max(0.0D0, store(ino3_a)) + gas(ihno3_g) = gas(ihno3_g) + store(ino3_a) + aer(ino3_a,jp,ibin) = aer(ino3_a,jp,ibin) - store(ino3_a) + aer(ino3_a,jp,ibin) = max(0.0D0,aer(ino3_a,jp,ibin)) + +! also do it for jtotal + if(jp .ne. jtotal)then + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid, ibin) + & + aer(ino3_a,jliquid,ibin) + endif + + electrolyte(jhno3,jp,ibin) = 0.0 + store(ino3_a) = 0.0 + + return + end subroutine degas_hno3 + + + + subroutine degas_hcl(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + store(icl_a) = max(0.0D0, store(icl_a)) + gas(ihcl_g) = gas(ihcl_g) + store(icl_a) + aer(icl_a,jp,ibin) = aer(icl_a,jp,ibin) - store(icl_a) + aer(icl_a,jp,ibin) = max(0.0D0,aer(icl_a,jp,ibin)) + +! also do it for jtotal + if(jp .ne. jtotal)then + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid, ibin) + & + aer(icl_a,jliquid,ibin) + endif + + electrolyte(jhcl,jp,ibin) = 0.0 + store(icl_a) = 0.0 + + return + end subroutine degas_hcl + + + + subroutine degas_nh3(store,jp,ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) store(naer) + + store(inh4_a) = max(0.0D0, store(inh4_a)) + gas(inh3_g) = gas(inh3_g) + store(inh4_a) + aer(inh4_a,jp,ibin) = aer(inh4_a,jp,ibin) - store(inh4_a) + aer(inh4_a,jp,ibin) = max(0.0D0,aer(inh4_a,jp,ibin)) + +! also do it for jtotal + if(jp .ne. jtotal)then + aer(inh4_a,jtotal,ibin)= aer(inh4_a,jsolid, ibin) + & + aer(inh4_a,jliquid,ibin) + endif + + store(inh4_a) = 0.0 + + return + end subroutine degas_nh3 + + + + + + + + + + subroutine degas_acids(jp,ibin,xt) +! implicit none +! include 'mosaic.h' +! subr arguments + integer jp, ibin + real(kind=8) xt +! local variables + real(kind=8) ehno3, ehcl + + + + if(jp .ne. jliquid)then + if (iprint_mosaic_diag1 .gt. 0) then + write(6,*)'mosaic - error in degas_acids' + write(6,*)'wrong jp' + endif + endif + + ehno3 = electrolyte(jhno3,jp,ibin) + ehcl = electrolyte(jhcl,jp,ibin) + +! add to gas + gas(ihno3_g) = gas(ihno3_g) + ehno3 + gas(ihcl_g) = gas(ihcl_g) + ehcl + +! remove from aer + aer(ino3_a,jp,ibin) = aer(ino3_a,jp,ibin) - ehno3 + aer(icl_a, jp,ibin) = aer(icl_a, jp,ibin) - ehcl + +! update jtotal + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jliquid,ibin) + & + aer(ino3_a,jsolid, ibin) + + aer(icl_a,jtotal,ibin) = aer(icl_a,jliquid,ibin) + & + aer(icl_a,jsolid, ibin) + + electrolyte(jhno3,jp,ibin) = 0.0 + electrolyte(jhcl,jp,ibin) = 0.0 + + return + end subroutine degas_acids + + + + + + + + + + + + + + +!*********************************************************************** +! subroutines to evaporate solid volatile species +! +! author: rahul a. zaveri +! update: sep 2004 +!----------------------------------------------------------------------- +! +! nh4no3 (solid) + subroutine degas_solid_nh4no3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer jp + real(kind=8) a, b, c, xgas, xt +! real(kind=8) quadratic ! mosaic func + + + jp = jsolid + + a = 1.0 + b = gas(inh3_g) + gas(ihno3_g) + c = gas(inh3_g)*gas(ihno3_g) - keq_sg(1) + xgas = quadratic(a,b,c) + + if(xgas .ge. electrolyte(jnh4no3,jp,ibin))then ! degas all nh4no3 + + gas(inh3_g) = gas(inh3_g) + electrolyte(jnh4no3,jp,ibin) + gas(ihno3_g)= gas(ihno3_g) + electrolyte(jnh4no3,jp,ibin) + aer(inh4_a,jp,ibin) = aer(inh4_a,jp,ibin) - & + electrolyte(jnh4no3,jp,ibin) + aer(ino3_a,jp,ibin) = aer(ino3_a,jp,ibin) - & + electrolyte(jnh4no3,jp,ibin) + + else ! degas only xgas amount of nh4no3 + + gas(inh3_g) = gas(inh3_g) + xgas + gas(ihno3_g)= gas(ihno3_g) + xgas + aer(inh4_a,jp,ibin) = aer(inh4_a,jp,ibin) - xgas + aer(ino3_a,jp,ibin) = aer(ino3_a,jp,ibin) - xgas + endif + + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + & + aer(ino3_a,jliquid,ibin) + + return + end subroutine degas_solid_nh4no3 + + + + + + + + + +! nh4cl (solid) + subroutine degas_solid_nh4cl(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + integer jp + real(kind=8) a, b, c, xgas, xt +! real(kind=8) quadratic ! mosaic func + + + jp = jsolid + + a = 1.0 + b = gas(inh3_g) + gas(ihcl_g) + c = gas(inh3_g)*gas(ihcl_g) - keq_sg(2) + xgas = quadratic(a,b,c) + + if(xgas .ge. electrolyte(jnh4cl,jp,ibin))then ! degas all nh4cl + + gas(inh3_g) = gas(inh3_g) + electrolyte(jnh4cl,jp,ibin) + gas(ihcl_g) = gas(ihcl_g) + electrolyte(jnh4cl,jp,ibin) + aer(inh4_a,jp,ibin) = aer(inh4_a,jp,ibin) - & + electrolyte(jnh4cl,jp,ibin) + aer(icl_a,jp,ibin) = aer(icl_a,jp,ibin) - & + electrolyte(jnh4cl,jp,ibin) + + else ! degas only xgas amount of nh4cl + + gas(inh3_g) = gas(inh3_g) + xgas + gas(ihcl_g) = gas(ihcl_g) + xgas + aer(inh4_a,jp,ibin) = aer(inh4_a,jp,ibin) - xgas + aer(icl_a,jp,ibin) = aer(icl_a,jp,ibin) - xgas + + endif + + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + & + aer(icl_a,jliquid,ibin) + + return + end subroutine degas_solid_nh4cl + + + + + + + + + + + +!*********************************************************************** +! subroutines to absorb and degas small amounts of volatile species +! +! author: rahul a. zaveri +! update: jun 2002 +!----------------------------------------------------------------------- +! +! nh4no3 (liquid) + subroutine absorb_tiny_nh4no3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_aer, small_gas, small_amt + + small_gas = 0.01 * min(gas(inh3_g), gas(ihno3_g)) + small_aer = 0.01 * electrolyte_sum(jtotal,ibin) + if(small_aer .eq. 0.0)small_aer = small_gas + + small_amt = min(small_gas, small_aer) + + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + small_amt + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) + small_amt + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + & + aer(ino3_a,jliquid,ibin) + +! update gas + gas(inh3_g) = gas(inh3_g) - small_amt + gas(ihno3_g) = gas(ihno3_g) - small_amt + + return + end subroutine absorb_tiny_nh4no3 + + + + + + +!-------------------------------------------------------------------- +! nh4cl (liquid) + subroutine absorb_tiny_nh4cl(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_aer, small_gas, small_amt + + small_gas = 0.01 * min(gas(inh3_g), gas(ihcl_g)) + small_aer = 0.01 * electrolyte_sum(jtotal,ibin) + if(small_aer .eq. 0.0)small_aer = small_gas + + small_amt = min(small_gas, small_aer) + + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) + small_amt + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) + small_amt + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + & + aer(icl_a,jliquid,ibin) + +! update gas + gas(inh3_g) = gas(inh3_g) - small_amt + gas(ihcl_g) = gas(ihcl_g) - small_amt + + return + end subroutine absorb_tiny_nh4cl + + + + + + + + + + + + + +!-------------------------------------------------------------- +! nh4no3 (liquid) + subroutine degas_tiny_nh4no3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_amt + + small_amt = 0.01 * electrolyte(jnh4no3,jliquid,ibin) + + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) - small_amt + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) - small_amt + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + & + aer(ino3_a,jliquid,ibin) + +! update gas + gas(inh3_g) = gas(inh3_g) + small_amt + gas(ihno3_g) = gas(ihno3_g) + small_amt + + return + end subroutine degas_tiny_nh4no3 + + + + +!-------------------------------------------------------------------- +! liquid nh4cl (liquid) + subroutine degas_tiny_nh4cl(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_amt + + + small_amt = 0.01 * electrolyte(jnh4cl,jliquid,ibin) + + aer(inh4_a,jliquid,ibin) = aer(inh4_a,jliquid,ibin) - small_amt + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) - small_amt + +! update jtotal + aer(inh4_a,jtotal,ibin) = aer(inh4_a,jsolid,ibin) + & + aer(inh4_a,jliquid,ibin) + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + & + aer(icl_a,jliquid,ibin) + +! update gas + gas(inh3_g) = gas(inh3_g) + small_amt + gas(ihcl_g) = gas(ihcl_g) + small_amt + + return + end subroutine degas_tiny_nh4cl + + + + + + + +!-------------------------------------------------------------------- +! hcl (liquid) + subroutine absorb_tiny_hcl(ibin) ! and degas tiny hno3 +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_aer, small_amt, small_gas + + small_gas = 0.01 * gas(ihcl_g) + small_aer = 0.01 * aer(ino3_a,jliquid,ibin) + + small_amt = min(small_gas, small_aer) + +! absorb tiny hcl + aer(icl_a,jliquid,ibin)= aer(icl_a,jliquid,ibin) + small_amt + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + & + aer(icl_a,jliquid,ibin) + gas(ihcl_g) = gas(ihcl_g) - small_amt + +! degas tiny hno3 + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) - small_amt + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + & + aer(ino3_a,jliquid,ibin) + +! update gas + gas(ihno3_g) = gas(ihno3_g) + small_amt + + return + end subroutine absorb_tiny_hcl + + + +!-------------------------------------------------------------------- +! hno3 (liquid) + subroutine absorb_tiny_hno3(ibin) ! and degas tiny hcl +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) small_aer, small_amt, small_gas + + small_gas = 0.01 * gas(ihno3_g) + small_aer = 0.01 * aer(icl_a,jliquid,ibin) + + small_amt = min(small_gas, small_aer) + +! absorb tiny hno3 + aer(ino3_a,jliquid,ibin) = aer(ino3_a,jliquid,ibin) + small_amt + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jsolid,ibin) + & + aer(ino3_a,jliquid,ibin) + gas(ihno3_g) = gas(ihno3_g) - small_amt + +! degas tiny hcl + aer(icl_a,jliquid,ibin) = aer(icl_a,jliquid,ibin) - small_amt + aer(icl_a,jtotal,ibin) = aer(icl_a,jsolid,ibin) + & + aer(icl_a,jliquid,ibin) + +! update gas + gas(ihcl_g) = gas(ihcl_g) + small_amt + + return + end subroutine absorb_tiny_hno3 + + + + + + + + + +!*********************************************************************** +! subroutines to equilibrate volatile acids +! +! author: rahul a. zaveri +! update: may 2002 +!----------------------------------------------------------------------- + subroutine equilibrate_acids(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin + + + + if(gas(ihcl_g)*gas(ihno3_g) .gt. 0.)then + call equilibrate_hcl_and_hno3(ibin) + elseif(gas(ihcl_g) .gt. 0.)then + call equilibrate_hcl(ibin) + elseif(gas(ihno3_g) .gt. 0.)then + call equilibrate_hno3(ibin) + endif + + + return + end subroutine equilibrate_acids + + + + + + + + +! only hcl + subroutine equilibrate_hcl(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, aerh, aerhso4, aerso4, b, c, dum, kdash_hcl, mh, tcl, & + w, xt, z +! real(kind=8) quadratic ! mosaic func + + aerso4 = ma(ja_so4,ibin)*water_a(ibin)*1.e+9 + aerhso4= ma(ja_hso4,ibin)*water_a(ibin)*1.e+9 + + tcl = aer(icl_a,jliquid,ibin) + gas(ihcl_g) ! nmol/m^3(air) + kdash_hcl = keq_gl(4)*1.e+18/gam(jhcl,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + z = ( aer(ina_a, jliquid,ibin) + & ! nmol/m^3(air) + aer(inh4_a,jliquid,ibin) + & + 2.*aer(ica_a, jliquid,ibin) ) - & + (2.*aerso4 + & + aerhso4 + & + aer(ino3_a,jliquid,ibin) ) + + + w = water_a(ibin) ! kg/m^3(air) + + kdash_hcl = keq_gl(4)*1.e+18/gam(jhcl,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + a = 1.0 + b = (kdash_hcl*w + z/w)*1.e-9 + c = kdash_hcl*(z - tcl)*1.e-18 + + + dum = b*b - 4.*a*c + if (dum .lt. 0.) return ! no real root + + + if(c .lt. 0.)then + mh = quadratic(a,b,c) ! mol/kg(water) + aerh = mh*w*1.e+9 + aer(icl_a,jliquid,ibin) = aerh + z + else + mh = sqrt(keq_ll(3)) + endif + + call form_electrolytes(jliquid,ibin,xt) + +! update gas phase concentration + gas(ihcl_g) = tcl - aer(icl_a,jliquid,ibin) + + +! update the following molalities + ma(ja_so4,ibin) = 1.e-9*aerso4/water_a(ibin) + ma(ja_hso4,ibin) = 1.e-9*aerhso4/water_a(ibin) + ma(ja_no3,ibin) = 1.e-9*aer(ino3_a,jliquid,ibin)/water_a(ibin) + ma(ja_cl,ibin) = 1.e-9*aer(icl_a, jliquid,ibin)/water_a(ibin) + + mc(jc_h,ibin) = mh + mc(jc_ca,ibin) = 1.e-9*aer(ica_a, jliquid,ibin)/water_a(ibin) + mc(jc_nh4,ibin) = 1.e-9*aer(inh4_a,jliquid,ibin)/water_a(ibin) + mc(jc_na,ibin) = 1.e-9*aer(ina_a, jliquid,ibin)/water_a(ibin) + + +! update the following activities + activity(jhcl,ibin) = mc(jc_h,ibin) *ma(ja_cl,ibin) * & + gam(jhcl,ibin)**2 + + activity(jhno3,ibin) = mc(jc_h,ibin) *ma(ja_no3,ibin) * & + gam(jhno3,ibin)**2 + + activity(jnh4cl,ibin) = mc(jc_nh4,ibin)*ma(ja_cl,ibin) * & + gam(jnh4cl,ibin)**2 + + +! also update xyz(jtotal) + aer(icl_a,jtotal,ibin) = aer(icl_a,jliquid,ibin) + & + aer(icl_a,jsolid,ibin) + + electrolyte(jhcl,jtotal,ibin) = electrolyte(jhcl,jliquid,ibin) + + return + end subroutine equilibrate_hcl + + + + +! only hno3 + subroutine equilibrate_hno3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) a, aerh, aerhso4, aerso4, b, c, dum, kdash_hno3, mh, & + tno3, w, xt, z +! real(kind=8) quadratic ! mosaic func + + aerso4 = ma(ja_so4,ibin)*water_a(ibin)*1.e+9 + aerhso4= ma(ja_hso4,ibin)*water_a(ibin)*1.e+9 + + tno3 = aer(ino3_a,jliquid,ibin) + gas(ihno3_g) ! nmol/m^3(air) + kdash_hno3 = keq_gl(3)*1.e+18/gam(jhno3,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + z = ( aer(ina_a, jliquid,ibin) + & ! nmol/m^3(air) + aer(inh4_a,jliquid,ibin) + & + 2.*aer(ica_a, jliquid,ibin) ) - & + (2.*aerso4 + & + aerhso4 + & + aer(icl_a,jliquid,ibin) ) + + + w = water_a(ibin) ! kg/m^3(air) + + kdash_hno3 = keq_gl(3)*1.e+18/gam(jhno3,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + a = 1.0 + b = (kdash_hno3*w + z/w)*1.e-9 + c = kdash_hno3*(z - tno3)*1.e-18 + + dum = b*b - 4.*a*c + if (dum .lt. 0.) return ! no real root + + + + if(c .lt. 0.)then + mh = quadratic(a,b,c) ! mol/kg(water) + aerh = mh*w*1.e+9 + aer(ino3_a,jliquid,ibin) = aerh + z + else + mh = sqrt(keq_ll(3)) + endif + + call form_electrolytes(jliquid,ibin,xt) + +! update gas phase concentration + gas(ihno3_g)= tno3 - aer(ino3_a,jliquid,ibin) + + +! update the following molalities + ma(ja_so4,ibin) = 1.e-9*aerso4/water_a(ibin) + ma(ja_hso4,ibin) = 1.e-9*aerhso4/water_a(ibin) + ma(ja_no3,ibin) = 1.e-9*aer(ino3_a,jliquid,ibin)/water_a(ibin) + ma(ja_cl,ibin) = 1.e-9*aer(icl_a, jliquid,ibin)/water_a(ibin) + + mc(jc_h,ibin) = mh + mc(jc_ca,ibin) = 1.e-9*aer(ica_a, jliquid,ibin)/water_a(ibin) + mc(jc_nh4,ibin) = 1.e-9*aer(inh4_a,jliquid,ibin)/water_a(ibin) + mc(jc_na,ibin) = 1.e-9*aer(ina_a, jliquid,ibin)/water_a(ibin) + + +! update the following activities + activity(jhcl,ibin) = mc(jc_h,ibin) *ma(ja_cl,ibin) * & + gam(jhcl,ibin)**2 + + activity(jhno3,ibin) = mc(jc_h,ibin) *ma(ja_no3,ibin) * & + gam(jhno3,ibin)**2 + + activity(jnh4no3,ibin) = mc(jc_nh4,ibin)*ma(ja_no3,ibin) * & + gam(jnh4no3,ibin)**2 + + +! also update xyz(jtotal) + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jliquid,ibin) + & + aer(ino3_a,jsolid,ibin) + + electrolyte(jhno3,jtotal,ibin) = electrolyte(jhno3,jliquid,ibin) + + return + end subroutine equilibrate_hno3 + + + + + + + + + + +! both hcl and hno3 + subroutine equilibrate_hcl_and_hno3(ibin) +! implicit none +! include 'mosaic.h' +! subr arguments + integer ibin +! local variables + real(kind=8) aerh, aerhso4, aerso4, kdash_hcl, kdash_hno3, & + mh, p, q, r, tcl, tno3, w, xt, z +! real(kind=8) cubic ! mosaic func + + + aerso4 = ma(ja_so4,ibin)*water_a(ibin)*1.e+9 + aerhso4= ma(ja_hso4,ibin)*water_a(ibin)*1.e+9 + + tcl = aer(icl_a,jliquid,ibin) + gas(ihcl_g) ! nmol/m^3(air) + tno3 = aer(ino3_a,jliquid,ibin) + gas(ihno3_g) ! nmol/m^3(air) + + kdash_hcl = keq_gl(4)*1.e+18/gam(jhcl,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + kdash_hno3 = keq_gl(3)*1.e+18/gam(jhno3,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + + z = ( aer(ina_a, jliquid,ibin) + & ! nmol/m^3(air) + aer(inh4_a,jliquid,ibin) + & + 2.*aer(ica_a, jliquid,ibin) ) - & + (2.*aerso4 + aerhso4 ) + + + w = water_a(ibin) + + kdash_hcl = keq_gl(4)*1.e+18/gam(jhcl,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + kdash_hno3 = keq_gl(3)*1.e+18/gam(jhno3,ibin)**2 ! (nmol^2/kg^2)/(nmol/m^3(air)) + + p = (z/w + w*(kdash_hcl + kdash_hno3))*1.e-9 + + q = 1.e-18*kdash_hcl*kdash_hno3*w**2 + & + 1.e-18*z*(kdash_hcl + kdash_hno3) - & + 1.e-18*kdash_hcl*tcl - & + 1.e-18*kdash_hno3*tno3 + + r = 1.e-18*kdash_hcl*kdash_hno3*w*(z - tcl - tno3)*1.e-9 + + mh = cubic(p,q,r) + + if(mh .gt. 0.0)then + aerh = mh*w*1.e+9 + aer(ino3_a,jliquid,ibin) = kdash_hno3*w*w*tno3/ & + (aerh + kdash_hno3*w*w) + aer(icl_a, jliquid,ibin) = kdash_hcl*w*w*tcl/ & + (aerh + kdash_hcl*w*w) + else + mh = sqrt(keq_ll(3)) + endif + + call form_electrolytes(jliquid,ibin,xt) + +! update gas phase concentration + gas(ihno3_g)= tno3 - aer(ino3_a,jliquid,ibin) + gas(ihcl_g) = tcl - aer(icl_a,jliquid,ibin) + + +! update the following molalities + ma(ja_so4,ibin) = 1.e-9*aerso4/water_a(ibin) + ma(ja_hso4,ibin) = 1.e-9*aerhso4/water_a(ibin) + ma(ja_no3,ibin) = 1.e-9*aer(ino3_a,jliquid,ibin)/water_a(ibin) + ma(ja_cl,ibin) = 1.e-9*aer(icl_a, jliquid,ibin)/water_a(ibin) + + mc(jc_h,ibin) = mh + mc(jc_ca,ibin) = 1.e-9*aer(ica_a, jliquid,ibin)/water_a(ibin) + mc(jc_nh4,ibin) = 1.e-9*aer(inh4_a,jliquid,ibin)/water_a(ibin) + mc(jc_na,ibin) = 1.e-9*aer(ina_a, jliquid,ibin)/water_a(ibin) + + +! update the following activities + activity(jhcl,ibin) = mc(jc_h,ibin)*ma(ja_cl,ibin) * & + gam(jhcl,ibin)**2 + + activity(jhno3,ibin) = mc(jc_h,ibin)*ma(ja_no3,ibin) * & + gam(jhno3,ibin)**2 + + activity(jnh4no3,ibin) = mc(jc_nh4,ibin)*ma(ja_no3,ibin)* & + gam(jnh4no3,ibin)**2 + + activity(jnh4cl,ibin) = mc(jc_nh4,ibin)*ma(ja_cl,ibin) * & + gam(jnh4cl,ibin)**2 + + +! also update xyz(jtotal) + aer(icl_a,jtotal,ibin) = aer(icl_a,jliquid,ibin) + & + aer(icl_a,jsolid,ibin) + + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jliquid,ibin) + & + aer(ino3_a,jsolid,ibin) + + electrolyte(jhno3,jtotal,ibin) = electrolyte(jhno3,jliquid,ibin) + electrolyte(jhcl, jtotal,ibin) = electrolyte(jhcl, jliquid,ibin) + + return + end subroutine equilibrate_hcl_and_hno3 + + + + + + + + + + + + + +!*********************************************************************** +! called only once per entire simulation to load gas and aerosol +! indices, parameters, physico-chemical constants, polynomial coeffs, etc. +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine load_mosaic_parameters +! implicit none +! include 'v33com2' +! include 'mosaic.h' +! local variables + integer iaer, je, ja, j_index, ibin +! logical first +! save first +! data first/.true./ + logical, save :: first = .true. + + + + if(first)then + first=.false. + +!---------------------------------------------------------------- +! control settings + msize_framework = msection ! mmodal or msection + mgas_aer_xfer = myes ! myes, mno + +! astem parameters + nmax_astem = 200 ! max number of time steps in astem + alpha_astem = 0.5 ! choose a value between 0.01 and 1.0 + rtol_eqb_astem = 0.01 ! equilibrium tolerance in astem + ptol_mol_astem = 0.01 ! mol percent tolerance in astem + +! mesa parameters + nmax_mesa = 80 ! max number of iterations in mesa_ptc + rtol_mesa = 0.01 ! mesa equilibrium tolerance +!---------------------------------------------------------------- +! +! set gas and aerosol indices +! +! gas (local) + ih2so4_g = 1 ! ioa (inorganic aerosol) + ihno3_g = 2 ! ioa + ihcl_g = 3 ! ioa + inh3_g = 4 ! ioa + imsa_g = 5 ! ioa + iaro1_g = 6 ! soa (secondary organic aerosol) + iaro2_g = 7 ! soa + ialk1_g = 8 ! soa + iole1_g = 9 ! soa + iapi1_g = 10 ! soa + iapi2_g = 11 ! soa + ilim1_g = 12 ! soa + ilim2_g = 13 ! soa + +! ico2_g = 14 ! currently not used +! +! aerosol (local): used for total species + iso4_a = 1 ! <-> ih2so4_g + ino3_a = 2 ! <-> ihno3_g + icl_a = 3 ! <-> ihcl_g + inh4_a = 4 ! <-> inh3_g + imsa_a = 5 ! <-> imsa_g + iaro1_a = 6 ! <-> iaro1_g + iaro2_a = 7 ! <-> iaro2_g + ialk1_a = 8 ! <-> ialk1_g + iole1_a = 9 ! <-> iole1_g + iapi1_a = 10 ! <-> iapi1_g + iapi2_a = 11 ! <-> iapi2_g + ilim1_a = 12 ! <-> ilim1_g + ilim2_a = 13 ! <-> ilim2_g + ico3_a = 14 ! <-> ico2_g + ina_a = 15 + ica_a = 16 + ioin_a = 17 + ioc_a = 18 + ibc_a = 19 + + +! electrolyte indices (used for water content calculations) +! these indices are order sensitive + jnh4so4 = 1 ! soluble + jlvcite = 2 ! soluble + jnh4hso4 = 3 ! soluble + jnh4msa = 4 ! soluble new + jnh4no3 = 5 ! soluble + jnh4cl = 6 ! soluble + jna2so4 = 7 ! soluble + jna3hso4 = 8 ! soluble + jnahso4 = 9 ! soluble + jnamsa = 10 ! soluble new + jnano3 = 11 ! soluble + jnacl = 12 ! soluble + jcano3 = 13 ! soluble + jcacl2 = 14 ! soluble + jcamsa2 = 15 ! soluble new nsalt + jh2so4 = 16 ! soluble + jmsa = 17 ! soluble new + jhno3 = 18 ! soluble + jhcl = 19 ! soluble + jhhso4 = 20 ! soluble + jcaso4 = 21 ! insoluble + jcaco3 = 22 ! insoluble + joc = 23 ! insoluble - part of naercomp + jbc = 24 ! insoluble - part of naercomp + join = 25 ! insoluble - part of naercomp + jaro1 = 26 ! insoluble - part of naercomp + jaro2 = 27 ! insoluble - part of naercomp + jalk1 = 28 ! insoluble - part of naercomp + jole1 = 29 ! insoluble - part of naercomp + japi1 = 30 ! insoluble - part of naercomp + japi2 = 31 ! insoluble - part of naercomp + jlim1 = 32 ! insoluble - part of naercomp + jlim2 = 33 ! insoluble - part of naercomp + jh2o = 34 ! water - part of naercomp + + +! local aerosol ions +! cations + jc_h = 1 + jc_nh4 = 2 + jc_na = 3 + jc_ca = 4 +! +! anions + ja_hso4 = 1 + ja_so4 = 2 + ja_no3 = 3 + ja_cl = 4 + ja_msa = 5 +! ja_co3 = 6 + +!-------------------------------------------------------------------- +! phase state names +! phasestate(no_aerosol) = "NOAERO" +! phasestate(all_solid) = "SOLID " +! phasestate(all_liquid) = "LIQUID" +! phasestate(mixed) = "MIXED " + +! names of aer species + aer_name(iso4_a) = 'so4' + aer_name(ino3_a) = 'no3' + aer_name(icl_a) = 'cl ' + aer_name(inh4_a) = 'nh4' + aer_name(ioc_a) = 'oc ' + aer_name(imsa_a) = 'msa' + aer_name(ico3_a) = 'co3' + aer_name(ina_a) = 'na ' + aer_name(ica_a) = 'ca ' + aer_name(ibc_a) = 'bc ' + aer_name(ioin_a) = 'oin' + aer_name(iaro1_a)= 'aro1' + aer_name(iaro2_a)= 'aro2' + aer_name(ialk1_a)= 'alk1' + aer_name(iole1_a)= 'ole1' + aer_name(iapi1_a)= 'api1' + aer_name(iapi2_a)= 'api2' + aer_name(ilim1_a)= 'lim1' + aer_name(ilim2_a)= 'lim2' + +! names of gas species + gas_name(ih2so4_g) = 'h2so4' + gas_name(ihno3_g) = 'hno3 ' + gas_name(ihcl_g) = 'hcl ' + gas_name(inh3_g) = 'nh3 ' + gas_name(imsa_g) = "msa " + gas_name(iaro1_g) = "aro1 " + gas_name(iaro2_g) = "aro2 " + gas_name(ialk1_g) = "alk1 " + gas_name(iole1_g) = "ole1 " + gas_name(iapi1_g) = "api1 " + gas_name(iapi2_g) = "api2 " + gas_name(ilim1_g) = "lim1 " + gas_name(ilim2_g) = "lim2 " + +! names of electrolytes + ename(jnh4so4) = 'amso4' + ename(jlvcite) = '(nh4)3h(so4)2' + ename(jnh4hso4)= 'nh4hso4' + ename(jnh4msa) = "ch3so3nh4" + ename(jnh4no3) = 'nh4no3' + ename(jnh4cl) = 'nh4cl' + ename(jnacl) = 'nacl' + ename(jnano3) = 'nano3' + ename(jna2so4) = 'na2so4' + ename(jna3hso4)= 'na3h(so4)2' + ename(jnamsa) = "ch3so3na" + ename(jnahso4) = 'nahso4' + ename(jcaso4) = 'caso4' + ename(jcamsa2) = "(ch3so3)2ca" + ename(jcano3) = 'ca(no3)2' + ename(jcacl2) = 'cacl2' + ename(jcaco3) = 'caco3' + ename(jh2so4) = 'h2so4' + ename(jhhso4) = 'hhso4' + ename(jhno3) = 'hno3' + ename(jhcl) = 'hcl' + ename(jmsa) = "ch3so3h" + +! molecular weights of electrolytes + mw_electrolyte(jnh4so4) = 132.0 + mw_electrolyte(jlvcite) = 247.0 + mw_electrolyte(jnh4hso4)= 115.0 + mw_electrolyte(jnh4msa) = 113.0 + mw_electrolyte(jnh4no3) = 80.0 + mw_electrolyte(jnh4cl) = 53.5 + mw_electrolyte(jnacl) = 58.5 + mw_electrolyte(jnano3) = 85.0 + mw_electrolyte(jna2so4) = 142.0 + mw_electrolyte(jna3hso4)= 262.0 + mw_electrolyte(jnahso4) = 120.0 + mw_electrolyte(jnamsa) = 118.0 + mw_electrolyte(jcaso4) = 136.0 + mw_electrolyte(jcamsa2) = 230.0 + mw_electrolyte(jcano3) = 164.0 + mw_electrolyte(jcacl2) = 111.0 + mw_electrolyte(jcaco3) = 100.0 + mw_electrolyte(jh2so4) = 98.0 + mw_electrolyte(jhno3) = 63.0 + mw_electrolyte(jhcl) = 36.5 + mw_electrolyte(jmsa) = 96.0 + + +! molecular weights of ions [g/mol] + mw_c(jc_h) = 1.0 + mw_c(jc_nh4)= 18.0 + mw_c(jc_na) = 23.0 + mw_c(jc_ca) = 40.0 + + mw_a(ja_so4) = 96.0 + mw_a(ja_hso4)= 97.0 + mw_a(ja_no3) = 62.0 + mw_a(ja_cl) = 35.5 + MW_a(ja_msa) = 95.0 + + +! magnitude of the charges on ions + zc(jc_h) = 1 + zc(jc_nh4) = 1 + zc(jc_na) = 1 + zc(jc_ca) = 2 + + za(ja_hso4)= 1 + za(ja_so4) = 2 + za(ja_no3) = 1 + za(ja_cl) = 1 + za(ja_msa) = 1 + + +! densities of pure electrolytes in g/cc + dens_electrolyte(jnh4so4) = 1.8 + dens_electrolyte(jlvcite) = 1.8 + dens_electrolyte(jnh4hso4) = 1.8 + dens_electrolyte(jnh4msa) = 1.8 ! assumed same as nh4hso4 + dens_electrolyte(jnh4no3) = 1.8 + dens_electrolyte(jnh4cl) = 1.8 + dens_electrolyte(jnacl) = 2.2 + dens_electrolyte(jnano3) = 2.2 + dens_electrolyte(jna2so4) = 2.2 + dens_electrolyte(jna3hso4) = 2.2 + dens_electrolyte(jnahso4) = 2.2 + dens_electrolyte(jnamsa) = 2.2 ! assumed same as nahso4 + dens_electrolyte(jcaso4) = 2.6 + dens_electrolyte(jcamsa2) = 2.6 ! assumed same as caso4 + dens_electrolyte(jcano3) = 2.6 + dens_electrolyte(jcacl2) = 2.6 + dens_electrolyte(jcaco3) = 2.6 + dens_electrolyte(jh2so4) = 1.8 + dens_electrolyte(jhhso4) = 1.8 + dens_electrolyte(jhno3) = 1.8 + dens_electrolyte(jhcl) = 1.8 + dens_electrolyte(jmsa) = 1.8 ! assumed same as h2so4 + + +! densities of compounds in g/cc + dens_comp_a(jnh4so4) = 1.8 + dens_comp_a(jlvcite) = 1.8 + dens_comp_a(jnh4hso4) = 1.8 + dens_comp_a(jnh4msa) = 1.8 ! assumed same as nh4hso4 + dens_comp_a(jnh4no3) = 1.7 + dens_comp_a(jnh4cl) = 1.5 + dens_comp_a(jnacl) = 2.2 + dens_comp_a(jnano3) = 2.2 + dens_comp_a(jna2so4) = 2.2 + dens_comp_a(jna3hso4) = 2.2 + dens_comp_a(jnahso4) = 2.2 + dens_comp_a(jnamsa) = 2.2 ! assumed same as nahso4 + dens_comp_a(jcaso4) = 2.6 + dens_comp_a(jcamsa2) = 2.6 ! assumed same as caso4 + dens_comp_a(jcano3) = 2.6 + dens_comp_a(jcacl2) = 2.6 + dens_comp_a(jcaco3) = 2.6 + dens_comp_a(jh2so4) = 1.8 + dens_comp_a(jhhso4) = 1.8 + dens_comp_a(jhno3) = 1.8 + dens_comp_a(jhcl) = 1.8 + dens_comp_a(jmsa) = 1.8 ! assumed same as h2so4 + dens_comp_a(joc) = 1.0 + dens_comp_a(jbc) = 1.8 + dens_comp_a(join) = 2.6 + dens_comp_a(jaro1) = 1.0 + dens_comp_a(jaro2) = 1.0 + dens_comp_a(jalk1) = 1.0 + dens_comp_a(jole1) = 1.0 + dens_comp_a(japi1) = 1.0 + dens_comp_a(japi2) = 1.0 + dens_comp_a(jlim1) = 1.0 + dens_comp_a(jlim2) = 1.0 + dens_comp_a(jh2o) = 1.0 + + +! molecular weights of generic aerosol species + mw_aer_mac(iso4_a) = 96.0 + mw_aer_mac(ino3_a) = 62.0 + mw_aer_mac(icl_a) = 35.5 + mw_aer_mac(imsa_a) = 95.0 ! ch3so3 + mw_aer_mac(ico3_a) = 60.0 + mw_aer_mac(inh4_a) = 18.0 + mw_aer_mac(ina_a) = 23.0 + mw_aer_mac(ica_a) = 40.0 + mw_aer_mac(ioin_a) = 1.0 ! not used + mw_aer_mac(ibc_a) = 1.0 ! not used + mw_aer_mac(ioc_a) = 1.0 ! 200 assumed for primary organics + mw_aer_mac(iaro1_a)= 150.0 + mw_aer_mac(iaro2_a)= 150.0 + mw_aer_mac(ialk1_a)= 140.0 + mw_aer_mac(iole1_a)= 140.0 + mw_aer_mac(iapi1_a)= 184.0 + mw_aer_mac(iapi2_a)= 184.0 + mw_aer_mac(ilim1_a)= 200.0 + mw_aer_mac(ilim2_a)= 200.0 + +! molecular weights of compounds + mw_comp_a(jnh4so4) = 132.0 + mw_comp_a(jlvcite) = 247.0 + mw_comp_a(jnh4hso4)= 115.0 + mw_comp_a(jnh4msa) = 113.0 + mw_comp_a(jnh4no3) = 80.0 + mw_comp_a(jnh4cl) = 53.5 + mw_comp_a(jnacl) = 58.5 + mw_comp_a(jnano3) = 85.0 + mw_comp_a(jna2so4) = 142.0 + mw_comp_a(jna3hso4)= 262.0 + mw_comp_a(jnahso4) = 120.0 + mw_comp_a(jnamsa) = 118.0 + mw_comp_a(jcaso4) = 136.0 + mw_comp_a(jcamsa2) = 230.0 + mw_comp_a(jcano3) = 164.0 + mw_comp_a(jcacl2) = 111.0 + mw_comp_a(jcaco3) = 100.0 + mw_comp_a(jh2so4) = 98.0 + mw_comp_a(jhhso4) = 98.0 + mw_comp_a(jhno3) = 63.0 + mw_comp_a(jhcl) = 36.5 + mw_comp_a(jmsa) = 96.0 + mw_comp_a(joc) = 1.0 + mw_comp_a(jbc) = 1.0 + mw_comp_a(join) = 1.0 + mw_comp_a(jaro1) = 150.0 + mw_comp_a(jaro2) = 150.0 + mw_comp_a(jalk1) = 140.0 + mw_comp_a(jole1) = 140.0 + mw_comp_a(japi1) = 184.0 + mw_comp_a(japi2) = 184.0 + mw_comp_a(jlim1) = 200.0 + mw_comp_a(jlim2) = 200.0 + mw_comp_a(jh2o) = 18.0 + +! densities of generic aerosol species + dens_aer_mac(iso4_a) = 1.8 ! used + dens_aer_mac(ino3_a) = 1.8 ! used + dens_aer_mac(icl_a) = 2.2 ! used + dens_aer_mac(imsa_a) = 1.8 ! used + dens_aer_mac(ico3_a) = 2.6 ! used + dens_aer_mac(inh4_a) = 1.8 ! used + dens_aer_mac(ina_a) = 2.2 ! used + dens_aer_mac(ica_a) = 2.6 ! used + dens_aer_mac(ioin_a) = 2.6 ! used + dens_aer_mac(ioc_a) = 1.0 ! used + dens_aer_mac(ibc_a) = 1.7 ! used + dens_aer_mac(iaro1_a)= 1.0 + dens_aer_mac(iaro2_a)= 1.0 + dens_aer_mac(ialk1_a)= 1.0 + dens_aer_mac(iole1_a)= 1.0 + dens_aer_mac(iapi1_a)= 1.0 + dens_aer_mac(iapi2_a)= 1.0 + dens_aer_mac(ilim1_a)= 1.0 + dens_aer_mac(ilim2_a)= 1.0 + + +! partial molar volumes of condensing species + partial_molar_vol(ih2so4_g) = 51.83 + partial_molar_vol(ihno3_g) = 31.45 + partial_molar_vol(ihcl_g) = 20.96 + partial_molar_vol(inh3_g) = 24.03 + partial_molar_vol(imsa_g) = 53.33 + partial_molar_vol(iaro1_g) = 150.0 + partial_molar_vol(iaro2_g) = 150.0 + partial_molar_vol(ialk1_g) = 140.0 + partial_molar_vol(iole1_g) = 140.0 + partial_molar_vol(iapi1_g) = 184.0 + partial_molar_vol(iapi2_g) = 184.0 + partial_molar_vol(ilim1_g) = 200.0 + partial_molar_vol(ilim2_g) = 200.0 + + +! refractive index + ref_index_a(jnh4so4) = cmplx(1.52,0.) + ref_index_a(jlvcite) = cmplx(1.50,0.) + ref_index_a(jnh4hso4)= cmplx(1.47,0.) + ref_index_a(jnh4msa) = cmplx(1.50,0.) ! assumed + ref_index_a(jnh4no3) = cmplx(1.50,0.) + ref_index_a(jnh4cl) = cmplx(1.50,0.) + ref_index_a(jnacl) = cmplx(1.45,0.) + ref_index_a(jnano3) = cmplx(1.50,0.) + ref_index_a(jna2so4) = cmplx(1.50,0.) + ref_index_a(jna3hso4)= cmplx(1.50,0.) + ref_index_a(jnahso4) = cmplx(1.50,0.) + ref_index_a(jnamsa) = cmplx(1.50,0.) ! assumed + ref_index_a(jcaso4) = cmplx(1.56,0.006) + ref_index_a(jcamsa2) = cmplx(1.56,0.006) ! assumed + ref_index_a(jcano3) = cmplx(1.56,0.006) + ref_index_a(jcacl2) = cmplx(1.52,0.006) + ref_index_a(jcaco3) = cmplx(1.68,0.006) + ref_index_a(jh2so4) = cmplx(1.43,0.) + ref_index_a(jhhso4) = cmplx(1.43,0.) + ref_index_a(jhno3) = cmplx(1.50,0.) + ref_index_a(jhcl) = cmplx(1.50,0.) + ref_index_a(jmsa) = cmplx(1.43,0.) ! assumed + ref_index_a(joc) = cmplx(1.45,0.) + ref_index_a(jbc) = cmplx(1.82,0.74) + ref_index_a(join) = cmplx(1.55,0.006) + ref_index_a(jaro1) = cmplx(1.45,0.) + ref_index_a(jaro2) = cmplx(1.45,0.) + ref_index_a(jalk1) = cmplx(1.45,0.) + ref_index_a(jole1) = cmplx(1.45,0.) + ref_index_a(japi1) = cmplx(1.45,0.) + ref_index_a(japi2) = cmplx(1.45,0.) + ref_index_a(jlim1) = cmplx(1.45,0.) + ref_index_a(jlim2) = cmplx(1.45,0.) + ref_index_a(jh2o) = cmplx(1.33,0.) + +! jsalt_index + jsalt_index(jnh4so4) = 5 ! as + jsalt_index(jlvcite) = 2 ! lv + jsalt_index(jnh4hso4)= 1 ! ab + jsalt_index(jnh4no3) = 2 ! an + jsalt_index(jnh4cl) = 1 ! ac + jsalt_index(jna2so4) = 60 ! ss + jsalt_index(jnahso4) = 10 ! sb + jsalt_index(jnano3) = 40 ! sn + jsalt_index(jnacl) = 10 ! sc + jsalt_index(jcano3) = 120 ! cn + jsalt_index(jcacl2) = 80 ! cc + jsalt_index(jnh4msa) = 0 ! AM zero for now + jsalt_index(jnamsa) = 0 ! SM zero for now + jsalt_index(jcamsa2) = 0 ! CM zero for now + + +! aerosol indices +! ac = 1, an = 2, as = 5, sc = 10, sn = 40, ss = 60, cc = 80, cn = 120, +! ab = 1, lv = 2, sb = 10 +! +! sulfate-poor domain + jsulf_poor(1) = 1 ! ac + jsulf_poor(2) = 2 ! an + jsulf_poor(5) = 3 ! as + jsulf_poor(10) = 4 ! sc + jsulf_poor(40) = 5 ! sn + jsulf_poor(60) = 6 ! ss + jsulf_poor(80) = 7 ! cc + jsulf_poor(120) = 8 ! cn + jsulf_poor(3) = 9 ! an + ac + jsulf_poor(6) = 10 ! as + ac + jsulf_poor(7) = 11 ! as + an + jsulf_poor(8) = 12 ! as + an + ac + jsulf_poor(11) = 13 ! sc + ac + jsulf_poor(41) = 14 ! sn + ac + jsulf_poor(42) = 15 ! sn + an + jsulf_poor(43) = 16 ! sn + an + ac + jsulf_poor(50) = 17 ! sn + sc + jsulf_poor(51) = 18 ! sn + sc + ac + jsulf_poor(61) = 19 ! ss + ac + jsulf_poor(62) = 20 ! ss + an + jsulf_poor(63) = 21 ! ss + an + ac + jsulf_poor(65) = 22 ! ss + as + jsulf_poor(66) = 23 ! ss + as + ac + jsulf_poor(67) = 24 ! ss + as + an + jsulf_poor(68) = 25 ! ss + as + an + ac + jsulf_poor(70) = 26 ! ss + sc + jsulf_poor(71) = 27 ! ss + sc + ac + jsulf_poor(100) = 28 ! ss + sn + jsulf_poor(101) = 29 ! ss + sn + ac + jsulf_poor(102) = 30 ! ss + sn + an + jsulf_poor(103) = 31 ! ss + sn + an + ac + jsulf_poor(110) = 32 ! ss + sn + sc + jsulf_poor(111) = 33 ! ss + sn + sc + ac + jsulf_poor(81) = 34 ! cc + ac + jsulf_poor(90) = 35 ! cc + sc + jsulf_poor(91) = 36 ! cc + sc + ac + jsulf_poor(121) = 37 ! cn + ac + jsulf_poor(122) = 38 ! cn + an + jsulf_poor(123) = 39 ! cn + an + ac + jsulf_poor(130) = 40 ! cn + sc + jsulf_poor(131) = 41 ! cn + sc + ac + jsulf_poor(160) = 42 ! cn + sn + jsulf_poor(161) = 43 ! cn + sn + ac + jsulf_poor(162) = 44 ! cn + sn + an + jsulf_poor(163) = 45 ! cn + sn + an + ac + jsulf_poor(170) = 46 ! cn + sn + sc + jsulf_poor(171) = 47 ! cn + sn + sc + ac + jsulf_poor(200) = 48 ! cn + cc + jsulf_poor(201) = 49 ! cn + cc + ac + jsulf_poor(210) = 50 ! cn + cc + sc + jsulf_poor(211) = 51 ! cn + cc + sc + ac +! +! sulfate-rich domain + jsulf_rich(1) = 52 ! ab + jsulf_rich(2) = 53 ! lv + jsulf_rich(10) = 54 ! sb + jsulf_rich(3) = 55 ! ab + lv + jsulf_rich(7) = 56 ! as + lv + jsulf_rich(70) = 57 ! ss + sb + jsulf_rich(62) = 58 ! ss + lv + jsulf_rich(67) = 59 ! ss + as + lv + jsulf_rich(61) = 60 ! ss + ab + jsulf_rich(63) = 61 ! ss + lv + ab + jsulf_rich(11) = 62 ! sb + ab + jsulf_rich(71) = 63 ! ss + sb + ab + jsulf_rich(5) = 3 ! as + jsulf_rich(60) = 6 ! ss + jsulf_rich(65) = 22 ! ss + as + + + +! +! polynomial coefficients for binary molality (used in zsr equation) +! +! +! a_zsr for aw < 0.97 +! +! (nh4)2so4 + je = jnh4so4 + a_zsr(1,je) = 1.30894 + a_zsr(2,je) = -7.09922 + a_zsr(3,je) = 20.62831 + a_zsr(4,je) = -32.19965 + a_zsr(5,je) = 25.17026 + a_zsr(6,je) = -7.81632 + aw_min(je) = 0.1 +! +! (nh4)3h(so4)2 + je = jlvcite + a_zsr(1,je) = 1.10725 + a_zsr(2,je) = -5.17978 + a_zsr(3,je) = 12.29534 + a_zsr(4,je) = -16.32545 + a_zsr(5,je) = 11.29274 + a_zsr(6,je) = -3.19164 + aw_min(je) = 0.1 +! +! nh4hso4 + je = jnh4hso4 + a_zsr(1,je) = 1.15510 + a_zsr(2,je) = -3.20815 + a_zsr(3,je) = 2.71141 + a_zsr(4,je) = 2.01155 + a_zsr(5,je) = -4.71014 + a_zsr(6,je) = 2.04616 + aw_min(je) = 0.1 +! +! nh4msa (assumed same as nh4hso4) + je = jnh4msa + a_zsr(1,je) = 1.15510 + a_zsr(2,je) = -3.20815 + a_zsr(3,je) = 2.71141 + a_zsr(4,je) = 2.01155 + a_zsr(5,je) = -4.71014 + a_zsr(6,je) = 2.04616 + aw_min(je) = 0.1 +! +! nh4no3 + je = jnh4no3 + a_zsr(1,je) = 0.43507 + a_zsr(2,je) = 6.38220 + a_zsr(3,je) = -30.19797 + a_zsr(4,je) = 53.36470 + a_zsr(5,je) = -43.44203 + a_zsr(6,je) = 13.46158 + aw_min(je) = 0.1 +! +! nh4cl: revised on nov 13, 2003. based on chan and ha (1999) jgr. + je = jnh4cl + a_zsr(1,je) = 0.45309 + a_zsr(2,je) = 2.65606 + a_zsr(3,je) = -14.7730 + a_zsr(4,je) = 26.2936 + a_zsr(5,je) = -20.5735 + a_zsr(6,je) = 5.94255 + aw_min(je) = 0.1 +! +! nacl + je = jnacl + a_zsr(1,je) = 0.42922 + a_zsr(2,je) = -1.17718 + a_zsr(3,je) = 2.80208 + a_zsr(4,je) = -4.51097 + a_zsr(5,je) = 3.76963 + a_zsr(6,je) = -1.31359 + aw_min(je) = 0.1 +! +! nano3 + je = jnano3 + a_zsr(1,je) = 1.34966 + a_zsr(2,je) = -5.20116 + a_zsr(3,je) = 11.49011 + a_zsr(4,je) = -14.41380 + a_zsr(5,je) = 9.07037 + a_zsr(6,je) = -2.29769 + aw_min(je) = 0.1 +! +! na2so4 + je = jna2so4 + a_zsr(1,je) = 0.39888 + a_zsr(2,je) = -1.27150 + a_zsr(3,je) = 3.42792 + a_zsr(4,je) = -5.92632 + a_zsr(5,je) = 5.33351 + a_zsr(6,je) = -1.96541 + aw_min(je) = 0.1 +! +! na3h(so4)2 added on 1/14/2004 + je = jna3hso4 + a_zsr(1,je) = 0.31480 + a_zsr(2,je) = -1.01087 + a_zsr(3,je) = 2.44029 + a_zsr(4,je) = -3.66095 + a_zsr(5,je) = 2.77632 + a_zsr(6,je) = -0.86058 + aw_min(je) = 0.1 +! +! nahso4 + je = jnahso4 + a_zsr(1,je) = 0.62764 + a_zsr(2,je) = -1.63520 + a_zsr(3,je) = 4.62531 + a_zsr(4,je) = -10.06925 + a_zsr(5,je) = 10.33547 + a_zsr(6,je) = -3.88729 + aw_min(je) = 0.1 +! +! namsa (assumed same as nahso4) + je = jnamsa + a_zsr(1,je) = 0.62764 + a_zsr(2,je) = -1.63520 + a_zsr(3,je) = 4.62531 + a_zsr(4,je) = -10.06925 + a_zsr(5,je) = 10.33547 + a_zsr(6,je) = -3.88729 + aw_min(je) = 0.1 +! +! ca(no3)2 + je = jcano3 + a_zsr(1,je) = 0.38895 + a_zsr(2,je) = -1.16013 + a_zsr(3,je) = 2.16819 + a_zsr(4,je) = -2.23079 + a_zsr(5,je) = 1.00268 + a_zsr(6,je) = -0.16923 + aw_min(je) = 0.1 +! +! cacl2: kim and seinfeld + je = jcacl2 + a_zsr(1,je) = 0.29891 + a_zsr(2,je) = -1.31104 + a_zsr(3,je) = 3.68759 + a_zsr(4,je) = -5.81708 + a_zsr(5,je) = 4.67520 + a_zsr(6,je) = -1.53223 + aw_min(je) = 0.1 +! +! h2so4 + je = jh2so4 + a_zsr(1,je) = 0.32751 + a_zsr(2,je) = -1.00692 + a_zsr(3,je) = 2.59750 + a_zsr(4,je) = -4.40014 + a_zsr(5,je) = 3.88212 + a_zsr(6,je) = -1.39916 + aw_min(je) = 0.1 +! +! msa (assumed same as h2so4) + je = jmsa + a_zsr(1,je) = 0.32751 + a_zsr(2,je) = -1.00692 + a_zsr(3,je) = 2.59750 + a_zsr(4,je) = -4.40014 + a_zsr(5,je) = 3.88212 + a_zsr(6,je) = -1.39916 + aw_min(je) = 0.1 +! +! hhso4 + je = jhhso4 + a_zsr(1,je) = 0.32751 + a_zsr(2,je) = -1.00692 + a_zsr(3,je) = 2.59750 + a_zsr(4,je) = -4.40014 + a_zsr(5,je) = 3.88212 + a_zsr(6,je) = -1.39916 + aw_min(je) = 1.0 +! +! hno3 + je = jhno3 + a_zsr(1,je) = 0.75876 + a_zsr(2,je) = -3.31529 + a_zsr(3,je) = 9.26392 + a_zsr(4,je) = -14.89799 + a_zsr(5,je) = 12.08781 + a_zsr(6,je) = -3.89958 + aw_min(je) = 0.1 +! +! hcl + je = jhcl + a_zsr(1,je) = 0.31133 + a_zsr(2,je) = -0.79688 + a_zsr(3,je) = 1.93995 + a_zsr(4,je) = -3.31582 + a_zsr(5,je) = 2.93513 + a_zsr(6,je) = -1.07268 + aw_min(je) = 0.1 +! +! caso4 + je = jcaso4 + a_zsr(1,je) = 0.0 + a_zsr(2,je) = 0.0 + a_zsr(3,je) = 0.0 + a_zsr(4,je) = 0.0 + a_zsr(5,je) = 0.0 + a_zsr(6,je) = 0.0 + aw_min(je) = 1.0 +! +! ca(msa)2 (assumed same as ca(no3)2) + je = jcamsa2 + a_zsr(1,je) = 0.38895 + a_zsr(2,je) = -1.16013 + a_zsr(3,je) = 2.16819 + a_zsr(4,je) = -2.23079 + a_zsr(5,je) = 1.00268 + a_zsr(6,je) = -0.16923 + aw_min(je) = 0.1 +! +! caco3 + je = jcaco3 + a_zsr(1,je) = 0.0 + a_zsr(2,je) = 0.0 + a_zsr(3,je) = 0.0 + a_zsr(4,je) = 0.0 + a_zsr(5,je) = 0.0 + a_zsr(6,je) = 0.0 + aw_min(je) = 1.0 + + + +!------------------------------------------- +! b_zsr for aw => 0.97 to 0.99999 +! +! (nh4)2so4 + b_zsr(jnh4so4) = 28.0811 +! +! (nh4)3h(so4)2 + b_zsr(jlvcite) = 14.7178 +! +! nh4hso4 + b_zsr(jnh4hso4) = 29.4779 +! +! nh4msa + b_zsr(jnh4msa) = 29.4779 ! assumed same as nh4hso4 +! +! nh4no3 + b_zsr(jnh4no3) = 33.4049 +! +! nh4cl + b_zsr(jnh4cl) = 30.8888 +! +! nacl + b_zsr(jnacl) = 29.8375 +! +! nano3 + b_zsr(jnano3) = 32.2756 +! +! na2so4 + b_zsr(jna2so4) = 27.6889 +! +! na3h(so4)2 + b_zsr(jna3hso4) = 14.2184 +! +! nahso4 + b_zsr(jnahso4) = 28.3367 +! +! namsa + b_zsr(jnamsa) = 28.3367 ! assumed same as nahso4 +! +! ca(no3)2 + b_zsr(jcano3) = 18.3661 +! +! cacl2 + b_zsr(jcacl2) = 20.8792 +! +! h2so4 + b_zsr(jh2so4) = 26.7347 +! +! hhso4 + b_zsr(jhhso4) = 26.7347 +! +! hno3 + b_zsr(jhno3) = 28.8257 +! +! hcl + b_zsr(jhcl) = 27.7108 +! +! msa + b_zsr(jmsa) = 26.7347 ! assumed same as h2so4 +! +! caso4 + b_zsr(jcaso4) = 0.0 +! +! ca(msa)2 + b_zsr(jcamsa2) = 18.3661 ! assumed same as Ca(NO3)2 +! +! caco3 + b_zsr(jcaco3) = 0.0 + + + + + + + +!---------------------------------------------------------------- +! parameters for mtem mixing rule (zaveri, easter, and wexler, 2005) +! log_gamz(ja,je) a in e +!---------------------------------------------------------------- +! +! (nh4)2so4 in e + ja = jnh4so4 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.94685 + b_mtem(2,ja,je) = 17.3328 + b_mtem(3,ja,je) = -64.8441 + b_mtem(4,ja,je) = 122.7070 + b_mtem(5,ja,je) = -114.4373 + b_mtem(6,ja,je) = 41.6811 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -2.7503 + b_mtem(2,ja,je) = 4.3806 + b_mtem(3,ja,je) = -1.1110 + b_mtem(4,ja,je) = -1.7005 + b_mtem(5,ja,je) = -4.4207 + b_mtem(6,ja,je) = 5.1990 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -2.06952 + b_mtem(2,ja,je) = 7.1240 + b_mtem(3,ja,je) = -24.4274 + b_mtem(4,ja,je) = 51.1458 + b_mtem(5,ja,je) = -54.2056 + b_mtem(6,ja,je) = 22.0606 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -2.17361 + b_mtem(2,ja,je) = 15.9919 + b_mtem(3,ja,je) = -69.0952 + b_mtem(4,ja,je) = 139.8860 + b_mtem(5,ja,je) = -134.9890 + b_mtem(6,ja,je) = 49.8877 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -4.4370 + b_mtem(2,ja,je) = 24.0243 + b_mtem(3,ja,je) = -76.2437 + b_mtem(4,ja,je) = 128.6660 + b_mtem(5,ja,je) = -110.0900 + b_mtem(6,ja,je) = 37.7414 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = -1.5394 + b_mtem(2,ja,je) = 5.8671 + b_mtem(3,ja,je) = -22.7726 + b_mtem(4,ja,je) = 47.0547 + b_mtem(5,ja,je) = -47.8266 + b_mtem(6,ja,je) = 18.8489 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = -0.35750 + b_mtem(2,ja,je) = -3.82466 + b_mtem(3,ja,je) = 4.55462 + b_mtem(4,ja,je) = 5.05402 + b_mtem(5,ja,je) = -14.7476 + b_mtem(6,ja,je) = 8.8009 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = -2.15146 + b_mtem(2,ja,je) = 5.50205 + b_mtem(3,ja,je) = -19.1476 + b_mtem(4,ja,je) = 39.1880 + b_mtem(5,ja,je) = -39.9460 + b_mtem(6,ja,je) = 16.0700 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = -2.52604 + b_mtem(2,ja,je) = 9.76022 + b_mtem(3,ja,je) = -35.2540 + b_mtem(4,ja,je) = 71.2981 + b_mtem(5,ja,je) = -71.8207 + b_mtem(6,ja,je) = 28.0758 + +! +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -4.13219 + b_mtem(2,ja,je) = 13.8863 + b_mtem(3,ja,je) = -34.5387 + b_mtem(4,ja,je) = 56.5012 + b_mtem(5,ja,je) = -51.8702 + b_mtem(6,ja,je) = 19.6232 + +! +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -2.53482 + b_mtem(2,ja,je) = 12.3333 + b_mtem(3,ja,je) = -46.1020 + b_mtem(4,ja,je) = 90.4775 + b_mtem(5,ja,je) = -88.1254 + b_mtem(6,ja,je) = 33.4715 + +! +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -3.23425 + b_mtem(2,ja,je) = 18.7842 + b_mtem(3,ja,je) = -78.7807 + b_mtem(4,ja,je) = 161.517 + b_mtem(5,ja,je) = -154.940 + b_mtem(6,ja,je) = 56.2252 + +! +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -1.25316 + b_mtem(2,ja,je) = 7.40960 + b_mtem(3,ja,je) = -34.8929 + b_mtem(4,ja,je) = 72.8853 + b_mtem(5,ja,je) = -72.4503 + b_mtem(6,ja,je) = 27.7706 + + +!----------------- +! nh4no3 in e + ja = jnh4no3 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -3.5201 + b_mtem(2,ja,je) = 21.6584 + b_mtem(3,ja,je) = -72.1499 + b_mtem(4,ja,je) = 126.7000 + b_mtem(5,ja,je) = -111.4550 + b_mtem(6,ja,je) = 38.5677 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -2.2630 + b_mtem(2,ja,je) = -0.1518 + b_mtem(3,ja,je) = 17.0898 + b_mtem(4,ja,je) = -36.7832 + b_mtem(5,ja,je) = 29.8407 + b_mtem(6,ja,je) = -7.9314 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -1.3851 + b_mtem(2,ja,je) = -0.4462 + b_mtem(3,ja,je) = 8.4567 + b_mtem(4,ja,je) = -11.5988 + b_mtem(5,ja,je) = 2.9802 + b_mtem(6,ja,je) = 1.8132 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -1.7602 + b_mtem(2,ja,je) = 10.4044 + b_mtem(3,ja,je) = -35.5894 + b_mtem(4,ja,je) = 64.3584 + b_mtem(5,ja,je) = -57.8931 + b_mtem(6,ja,je) = 20.2141 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -3.24346 + b_mtem(2,ja,je) = 16.2794 + b_mtem(3,ja,je) = -48.7601 + b_mtem(4,ja,je) = 79.2246 + b_mtem(5,ja,je) = -65.8169 + b_mtem(6,ja,je) = 22.1500 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = -1.75658 + b_mtem(2,ja,je) = 7.71384 + b_mtem(3,ja,je) = -22.7984 + b_mtem(4,ja,je) = 39.1532 + b_mtem(5,ja,je) = -34.6165 + b_mtem(6,ja,je) = 12.1283 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = -0.97178 + b_mtem(2,ja,je) = 6.61964 + b_mtem(3,ja,je) = -26.2353 + b_mtem(4,ja,je) = 50.5259 + b_mtem(5,ja,je) = -47.6586 + b_mtem(6,ja,je) = 17.5074 + +! in cacl2 added on 12/22/2003 + je = jcacl2 + b_mtem(1,ja,je) = -0.41515 + b_mtem(2,ja,je) = 6.44101 + b_mtem(3,ja,je) = -26.4473 + b_mtem(4,ja,je) = 49.0718 + b_mtem(5,ja,je) = -44.2631 + b_mtem(6,ja,je) = 15.3771 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = -1.20644 + b_mtem(2,ja,je) = 5.70117 + b_mtem(3,ja,je) = -18.2783 + b_mtem(4,ja,je) = 31.7199 + b_mtem(5,ja,je) = -27.8703 + b_mtem(6,ja,je) = 9.7299 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = -0.680862 + b_mtem(2,ja,je) = 3.59456 + b_mtem(3,ja,je) = -10.7969 + b_mtem(4,ja,je) = 17.8434 + b_mtem(5,ja,je) = -15.3165 + b_mtem(6,ja,je) = 5.17123 + + +!---------- +! nh4cl in e + ja = jnh4cl + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.8850 + b_mtem(2,ja,je) = 20.6970 + b_mtem(3,ja,je) = -70.6810 + b_mtem(4,ja,je) = 124.3690 + b_mtem(5,ja,je) = -109.2880 + b_mtem(6,ja,je) = 37.5831 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -1.9386 + b_mtem(2,ja,je) = 1.3238 + b_mtem(3,ja,je) = 11.8500 + b_mtem(4,ja,je) = -28.1168 + b_mtem(5,ja,je) = 21.8543 + b_mtem(6,ja,je) = -5.1671 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -0.9559 + b_mtem(2,ja,je) = 0.8121 + b_mtem(3,ja,je) = 4.3644 + b_mtem(4,ja,je) = -8.9258 + b_mtem(5,ja,je) = 4.2362 + b_mtem(6,ja,je) = 0.2891 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 0.0377 + b_mtem(2,ja,je) = 6.0752 + b_mtem(3,ja,je) = -30.8641 + b_mtem(4,ja,je) = 63.3095 + b_mtem(5,ja,je) = -61.0070 + b_mtem(6,ja,je) = 22.1734 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -1.8336 + b_mtem(2,ja,je) = 12.8160 + b_mtem(3,ja,je) = -42.3388 + b_mtem(4,ja,je) = 71.1816 + b_mtem(5,ja,je) = -60.5708 + b_mtem(6,ja,je) = 20.5853 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = -0.1429 + b_mtem(2,ja,je) = 2.3561 + b_mtem(3,ja,je) = -10.4425 + b_mtem(4,ja,je) = 20.8951 + b_mtem(5,ja,je) = -20.7739 + b_mtem(6,ja,je) = 7.9355 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = 0.76235 + b_mtem(2,ja,je) = 3.08323 + b_mtem(3,ja,je) = -23.6772 + b_mtem(4,ja,je) = 53.7415 + b_mtem(5,ja,je) = -55.4043 + b_mtem(6,ja,je) = 21.2944 + +! in cacl2 (revised on 11/27/2003) + je = jcacl2 + b_mtem(1,ja,je) = 1.13864 + b_mtem(2,ja,je) = -0.340539 + b_mtem(3,ja,je) = -8.67025 + b_mtem(4,ja,je) = 22.8008 + b_mtem(5,ja,je) = -24.5181 + b_mtem(6,ja,je) = 9.3663 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 2.42532 + b_mtem(2,ja,je) = -14.1755 + b_mtem(3,ja,je) = 38.804 + b_mtem(4,ja,je) = -58.2437 + b_mtem(5,ja,je) = 43.5431 + b_mtem(6,ja,je) = -12.5824 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 0.330337 + b_mtem(2,ja,je) = 0.0778934 + b_mtem(3,ja,je) = -2.30492 + b_mtem(4,ja,je) = 4.73003 + b_mtem(5,ja,je) = -4.80849 + b_mtem(6,ja,je) = 1.78866 + + +!---------- +! na2so4 in e + ja = jna2so4 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.6982 + b_mtem(2,ja,je) = 22.9875 + b_mtem(3,ja,je) = -98.9840 + b_mtem(4,ja,je) = 198.0180 + b_mtem(5,ja,je) = -188.7270 + b_mtem(6,ja,je) = 69.0548 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -2.4844 + b_mtem(2,ja,je) = 6.5420 + b_mtem(3,ja,je) = -9.8998 + b_mtem(4,ja,je) = 11.3884 + b_mtem(5,ja,je) = -13.6842 + b_mtem(6,ja,je) = 7.7411 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -1.3325 + b_mtem(2,ja,je) = 13.0406 + b_mtem(3,ja,je) = -56.1935 + b_mtem(4,ja,je) = 107.1170 + b_mtem(5,ja,je) = -97.3721 + b_mtem(6,ja,je) = 34.3763 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -1.2832 + b_mtem(2,ja,je) = 12.8526 + b_mtem(3,ja,je) = -62.2087 + b_mtem(4,ja,je) = 130.3876 + b_mtem(5,ja,je) = -128.2627 + b_mtem(6,ja,je) = 48.0340 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -3.5384 + b_mtem(2,ja,je) = 21.3758 + b_mtem(3,ja,je) = -70.7638 + b_mtem(4,ja,je) = 121.1580 + b_mtem(5,ja,je) = -104.6230 + b_mtem(6,ja,je) = 36.0557 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = 0.2175 + b_mtem(2,ja,je) = -0.5648 + b_mtem(3,ja,je) = -8.0288 + b_mtem(4,ja,je) = 25.9734 + b_mtem(5,ja,je) = -32.3577 + b_mtem(6,ja,je) = 14.3924 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = -0.309617 + b_mtem(2,ja,je) = -1.82899 + b_mtem(3,ja,je) = -1.5505 + b_mtem(4,ja,je) = 13.3847 + b_mtem(5,ja,je) = -20.1284 + b_mtem(6,ja,je) = 9.93163 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = -0.259455 + b_mtem(2,ja,je) = -0.819366 + b_mtem(3,ja,je) = -4.28964 + b_mtem(4,ja,je) = 16.4305 + b_mtem(5,ja,je) = -21.8546 + b_mtem(6,ja,je) = 10.3044 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = -1.84257 + b_mtem(2,ja,je) = 7.85788 + b_mtem(3,ja,je) = -29.9275 + b_mtem(4,ja,je) = 61.7515 + b_mtem(5,ja,je) = -63.2308 + b_mtem(6,ja,je) = 24.9542 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -1.05891 + b_mtem(2,ja,je) = 2.84831 + b_mtem(3,ja,je) = -21.1827 + b_mtem(4,ja,je) = 57.5175 + b_mtem(5,ja,je) = -64.8120 + b_mtem(6,ja,je) = 26.1986 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -1.16584 + b_mtem(2,ja,je) = 8.50075 + b_mtem(3,ja,je) = -44.3420 + b_mtem(4,ja,je) = 97.3974 + b_mtem(5,ja,je) = -98.4549 + b_mtem(6,ja,je) = 37.6104 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -1.95805 + b_mtem(2,ja,je) = 6.62417 + b_mtem(3,ja,je) = -31.8072 + b_mtem(4,ja,je) = 77.8603 + b_mtem(5,ja,je) = -84.6458 + b_mtem(6,ja,je) = 33.4963 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -0.36045 + b_mtem(2,ja,je) = 3.55223 + b_mtem(3,ja,je) = -24.0327 + b_mtem(4,ja,je) = 54.4879 + b_mtem(5,ja,je) = -56.6531 + b_mtem(6,ja,je) = 22.4956 + + +!---------- +! nano3 in e + ja = jnano3 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.5888 + b_mtem(2,ja,je) = 17.6192 + b_mtem(3,ja,je) = -63.2183 + b_mtem(4,ja,je) = 115.3520 + b_mtem(5,ja,je) = -104.0860 + b_mtem(6,ja,je) = 36.7390 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -2.0669 + b_mtem(2,ja,je) = 1.4792 + b_mtem(3,ja,je) = 10.5261 + b_mtem(4,ja,je) = -27.0987 + b_mtem(5,ja,je) = 23.0591 + b_mtem(6,ja,je) = -6.0938 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -0.8325 + b_mtem(2,ja,je) = 3.9933 + b_mtem(3,ja,je) = -15.3789 + b_mtem(4,ja,je) = 30.4050 + b_mtem(5,ja,je) = -29.4204 + b_mtem(6,ja,je) = 11.0597 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -1.1233 + b_mtem(2,ja,je) = 8.3998 + b_mtem(3,ja,je) = -31.9002 + b_mtem(4,ja,je) = 60.1450 + b_mtem(5,ja,je) = -55.5503 + b_mtem(6,ja,je) = 19.7757 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -2.5386 + b_mtem(2,ja,je) = 13.9039 + b_mtem(3,ja,je) = -42.8467 + b_mtem(4,ja,je) = 69.7442 + b_mtem(5,ja,je) = -57.8988 + b_mtem(6,ja,je) = 19.4635 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = -0.4351 + b_mtem(2,ja,je) = 2.8311 + b_mtem(3,ja,je) = -11.4485 + b_mtem(4,ja,je) = 22.7201 + b_mtem(5,ja,je) = -22.4228 + b_mtem(6,ja,je) = 8.5792 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = -0.72060 + b_mtem(2,ja,je) = 5.64915 + b_mtem(3,ja,je) = -23.5020 + b_mtem(4,ja,je) = 46.0078 + b_mtem(5,ja,je) = -43.8075 + b_mtem(6,ja,je) = 16.1652 + +! in cacl2 + je = jcacl2 + b_mtem(1,ja,je) = 0.003928 + b_mtem(2,ja,je) = 3.54724 + b_mtem(3,ja,je) = -18.6057 + b_mtem(4,ja,je) = 38.1445 + b_mtem(5,ja,je) = -36.7745 + b_mtem(6,ja,je) = 13.4529 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = -1.1712 + b_mtem(2,ja,je) = 7.20907 + b_mtem(3,ja,je) = -22.9215 + b_mtem(4,ja,je) = 38.1257 + b_mtem(5,ja,je) = -32.0759 + b_mtem(6,ja,je) = 10.6443 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 0.738022 + b_mtem(2,ja,je) = -1.14313 + b_mtem(3,ja,je) = 0.32251 + b_mtem(4,ja,je) = 0.838679 + b_mtem(5,ja,je) = -1.81747 + b_mtem(6,ja,je) = 0.873986 + + +!---------- +! nacl in e + ja = jnacl + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -1.9525 + b_mtem(2,ja,je) = 16.6433 + b_mtem(3,ja,je) = -61.7090 + b_mtem(4,ja,je) = 112.9910 + b_mtem(5,ja,je) = -101.9370 + b_mtem(6,ja,je) = 35.7760 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -1.7525 + b_mtem(2,ja,je) = 3.0713 + b_mtem(3,ja,je) = 4.8063 + b_mtem(4,ja,je) = -17.5334 + b_mtem(5,ja,je) = 14.2872 + b_mtem(6,ja,je) = -3.0690 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -0.4021 + b_mtem(2,ja,je) = 5.2399 + b_mtem(3,ja,je) = -19.4278 + b_mtem(4,ja,je) = 33.0027 + b_mtem(5,ja,je) = -28.1020 + b_mtem(6,ja,je) = 9.5159 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 0.6692 + b_mtem(2,ja,je) = 4.1207 + b_mtem(3,ja,je) = -27.3314 + b_mtem(4,ja,je) = 59.3112 + b_mtem(5,ja,je) = -58.7998 + b_mtem(6,ja,je) = 21.7674 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -1.17444 + b_mtem(2,ja,je) = 10.9927 + b_mtem(3,ja,je) = -38.9013 + b_mtem(4,ja,je) = 66.8521 + b_mtem(5,ja,je) = -57.6564 + b_mtem(6,ja,je) = 19.7296 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = 1.17679 + b_mtem(2,ja,je) = -2.5061 + b_mtem(3,ja,je) = 0.8508 + b_mtem(4,ja,je) = 4.4802 + b_mtem(5,ja,je) = -8.4945 + b_mtem(6,ja,je) = 4.3182 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = 1.01450 + b_mtem(2,ja,je) = 2.10260 + b_mtem(3,ja,je) = -20.9036 + b_mtem(4,ja,je) = 49.1481 + b_mtem(5,ja,je) = -51.4867 + b_mtem(6,ja,je) = 19.9301 + +! in cacl2 (psc92: revised on 11/27/2003) + je = jcacl2 + b_mtem(1,ja,je) = 1.55463 + b_mtem(2,ja,je) = -3.20122 + b_mtem(3,ja,je) = -0.957075 + b_mtem(4,ja,je) = 12.103 + b_mtem(5,ja,je) = -17.221 + b_mtem(6,ja,je) = 7.50264 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 2.46187 + b_mtem(2,ja,je) = -12.6845 + b_mtem(3,ja,je) = 34.2383 + b_mtem(4,ja,je) = -51.9992 + b_mtem(5,ja,je) = 39.4934 + b_mtem(6,ja,je) = -11.7247 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 1.74915 + b_mtem(2,ja,je) = -4.65768 + b_mtem(3,ja,je) = 8.80287 + b_mtem(4,ja,je) = -12.2503 + b_mtem(5,ja,je) = 8.668751 + b_mtem(6,ja,je) = -2.50158 + + +!---------- +! ca(no3)2 in e + ja = jcano3 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -1.86260 + b_mtem(2,ja,je) = 11.6178 + b_mtem(3,ja,je) = -30.9069 + b_mtem(4,ja,je) = 41.7578 + b_mtem(5,ja,je) = -33.7338 + b_mtem(6,ja,je) = 12.7541 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -1.1798 + b_mtem(2,ja,je) = 25.9608 + b_mtem(3,ja,je) = -98.9373 + b_mtem(4,ja,je) = 160.2300 + b_mtem(5,ja,je) = -125.9540 + b_mtem(6,ja,je) = 39.5130 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -1.44384 + b_mtem(2,ja,je) = 13.6044 + b_mtem(3,ja,je) = -54.4300 + b_mtem(4,ja,je) = 100.582 + b_mtem(5,ja,je) = -91.2364 + b_mtem(6,ja,je) = 32.5970 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = -0.099114 + b_mtem(2,ja,je) = 2.84091 + b_mtem(3,ja,je) = -16.9229 + b_mtem(4,ja,je) = 37.4839 + b_mtem(5,ja,je) = -39.5132 + b_mtem(6,ja,je) = 15.8564 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = 0.055116 + b_mtem(2,ja,je) = 4.58610 + b_mtem(3,ja,je) = -27.6629 + b_mtem(4,ja,je) = 60.8288 + b_mtem(5,ja,je) = -61.4988 + b_mtem(6,ja,je) = 23.3136 + +! in cacl2 (psc92: revised on 11/27/2003) + je = jcacl2 + b_mtem(1,ja,je) = 1.57155 + b_mtem(2,ja,je) = -3.18486 + b_mtem(3,ja,je) = -3.35758 + b_mtem(4,ja,je) = 18.7501 + b_mtem(5,ja,je) = -24.5604 + b_mtem(6,ja,je) = 10.3798 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 1.04446 + b_mtem(2,ja,je) = -3.19066 + b_mtem(3,ja,je) = 2.44714 + b_mtem(4,ja,je) = 2.07218 + b_mtem(5,ja,je) = -6.43949 + b_mtem(6,ja,je) = 3.66471 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 1.05723 + b_mtem(2,ja,je) = -1.46826 + b_mtem(3,ja,je) = -1.0713 + b_mtem(4,ja,je) = 4.64439 + b_mtem(5,ja,je) = -6.32402 + b_mtem(6,ja,je) = 2.78202 + + +!---------- +! cacl2 in e + ja = jcacl2 + +! in nh4no3 (psc92: revised on 12/22/2003) + je = jnh4no3 + b_mtem(1,ja,je) = -1.43626 + b_mtem(2,ja,je) = 13.6598 + b_mtem(3,ja,je) = -38.2068 + b_mtem(4,ja,je) = 53.9057 + b_mtem(5,ja,je) = -44.9018 + b_mtem(6,ja,je) = 16.6120 + +! in nh4cl (psc92: revised on 11/27/2003) + je = jnh4cl + b_mtem(1,ja,je) = -0.603965 + b_mtem(2,ja,je) = 27.6027 + b_mtem(3,ja,je) = -104.258 + b_mtem(4,ja,je) = 163.553 + b_mtem(5,ja,je) = -124.076 + b_mtem(6,ja,je) = 37.4153 + +! in nano3 (psc92: revised on 12/22/2003) + je = jnano3 + b_mtem(1,ja,je) = 0.44648 + b_mtem(2,ja,je) = 8.8850 + b_mtem(3,ja,je) = -45.5232 + b_mtem(4,ja,je) = 89.3263 + b_mtem(5,ja,je) = -83.8604 + b_mtem(6,ja,je) = 30.4069 + +! in nacl (psc92: revised on 11/27/2003) + je = jnacl + b_mtem(1,ja,je) = 1.61927 + b_mtem(2,ja,je) = 0.247547 + b_mtem(3,ja,je) = -18.1252 + b_mtem(4,ja,je) = 45.2479 + b_mtem(5,ja,je) = -48.6072 + b_mtem(6,ja,je) = 19.2784 + +! in ca(no3)2 (psc92: revised on 11/27/2003) + je = jcano3 + b_mtem(1,ja,je) = 2.36667 + b_mtem(2,ja,je) = -0.123309 + b_mtem(3,ja,je) = -24.2723 + b_mtem(4,ja,je) = 65.1486 + b_mtem(5,ja,je) = -71.8504 + b_mtem(6,ja,je) = 28.3696 + +! in cacl2 (psc92: revised on 11/27/2003) + je = jcacl2 + b_mtem(1,ja,je) = 3.64023 + b_mtem(2,ja,je) = -12.1926 + b_mtem(3,ja,je) = 20.2028 + b_mtem(4,ja,je) = -16.0056 + b_mtem(5,ja,je) = 1.52355 + b_mtem(6,ja,je) = 2.44709 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 5.88794 + b_mtem(2,ja,je) = -29.7083 + b_mtem(3,ja,je) = 78.6309 + b_mtem(4,ja,je) = -118.037 + b_mtem(5,ja,je) = 88.932 + b_mtem(6,ja,je) = -26.1407 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 2.40628 + b_mtem(2,ja,je) = -6.16566 + b_mtem(3,ja,je) = 10.2851 + b_mtem(4,ja,je) = -12.9035 + b_mtem(5,ja,je) = 7.7441 + b_mtem(6,ja,je) = -1.74821 + + +!---------- +! hno3 in e + ja = jhno3 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -3.57598 + b_mtem(2,ja,je) = 21.5469 + b_mtem(3,ja,je) = -77.4111 + b_mtem(4,ja,je) = 144.136 + b_mtem(5,ja,je) = -132.849 + b_mtem(6,ja,je) = 47.9412 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -2.00209 + b_mtem(2,ja,je) = -3.48399 + b_mtem(3,ja,je) = 34.9906 + b_mtem(4,ja,je) = -68.6653 + b_mtem(5,ja,je) = 54.0992 + b_mtem(6,ja,je) = -15.1343 + +! in nh4cl revised on 12/22/2003 + je = jnh4cl + b_mtem(1,ja,je) = -0.63790 + b_mtem(2,ja,je) = -1.67730 + b_mtem(3,ja,je) = 10.1727 + b_mtem(4,ja,je) = -14.9097 + b_mtem(5,ja,je) = 7.67410 + b_mtem(6,ja,je) = -0.79586 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = 1.3446 + b_mtem(2,ja,je) = -2.5578 + b_mtem(3,ja,je) = 1.3464 + b_mtem(4,ja,je) = 2.90537 + b_mtem(5,ja,je) = -6.53014 + b_mtem(6,ja,je) = 3.31339 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = -0.546636 + b_mtem(2,ja,je) = 10.3127 + b_mtem(3,ja,je) = -39.9603 + b_mtem(4,ja,je) = 71.4609 + b_mtem(5,ja,je) = -63.4958 + b_mtem(6,ja,je) = 22.0679 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 1.35059 + b_mtem(2,ja,je) = 4.34557 + b_mtem(3,ja,je) = -35.8425 + b_mtem(4,ja,je) = 80.9868 + b_mtem(5,ja,je) = -81.6544 + b_mtem(6,ja,je) = 30.4841 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = 0.869414 + b_mtem(2,ja,je) = 2.98486 + b_mtem(3,ja,je) = -22.255 + b_mtem(4,ja,je) = 50.1863 + b_mtem(5,ja,je) = -51.214 + b_mtem(6,ja,je) = 19.2235 + +! in cacl2 (km) revised on 12/22/2003 + je = jcacl2 + b_mtem(1,ja,je) = 1.42800 + b_mtem(2,ja,je) = -1.78959 + b_mtem(3,ja,je) = -2.49075 + b_mtem(4,ja,je) = 10.1877 + b_mtem(5,ja,je) = -12.1948 + b_mtem(6,ja,je) = 4.64475 + +! in hno3 (added on 12/06/2004) + je = jhno3 + b_mtem(1,ja,je) = 0.22035 + b_mtem(2,ja,je) = 2.94973 + b_mtem(3,ja,je) = -12.1469 + b_mtem(4,ja,je) = 20.4905 + b_mtem(5,ja,je) = -17.3966 + b_mtem(6,ja,je) = 5.70779 + +! in hcl (added on 12/06/2004) + je = jhcl + b_mtem(1,ja,je) = 1.55503 + b_mtem(2,ja,je) = -3.61226 + b_mtem(3,ja,je) = 6.28265 + b_mtem(4,ja,je) = -8.69575 + b_mtem(5,ja,je) = 6.09372 + b_mtem(6,ja,je) = -1.80898 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 1.10783 + b_mtem(2,ja,je) = -1.3363 + b_mtem(3,ja,je) = -1.83525 + b_mtem(4,ja,je) = 7.47373 + b_mtem(5,ja,je) = -9.72954 + b_mtem(6,ja,je) = 4.12248 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -0.851026 + b_mtem(2,ja,je) = 12.2515 + b_mtem(3,ja,je) = -49.788 + b_mtem(4,ja,je) = 91.6215 + b_mtem(5,ja,je) = -81.4877 + b_mtem(6,ja,je) = 28.0002 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -3.09464 + b_mtem(2,ja,je) = 14.9303 + b_mtem(3,ja,je) = -43.0454 + b_mtem(4,ja,je) = 72.6695 + b_mtem(5,ja,je) = -65.2140 + b_mtem(6,ja,je) = 23.4814 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = 1.22973 + b_mtem(2,ja,je) = 2.82702 + b_mtem(3,ja,je) = -17.5869 + b_mtem(4,ja,je) = 28.9564 + b_mtem(5,ja,je) = -23.5814 + b_mtem(6,ja,je) = 7.91153 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = 1.64773 + b_mtem(2,ja,je) = 0.94188 + b_mtem(3,ja,je) = -19.1242 + b_mtem(4,ja,je) = 46.9887 + b_mtem(5,ja,je) = -50.9494 + b_mtem(6,ja,je) = 20.2169 + + +!---------- +! hcl in e + ja = jhcl + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.93783 + b_mtem(2,ja,je) = 20.5546 + b_mtem(3,ja,je) = -75.8548 + b_mtem(4,ja,je) = 141.729 + b_mtem(5,ja,je) = -130.697 + b_mtem(6,ja,je) = 46.9905 + +! in nh4no3 + je = jnh4no3 + b_mtem(1,ja,je) = -1.69063 + b_mtem(2,ja,je) = -1.85303 + b_mtem(3,ja,je) = 29.0927 + b_mtem(4,ja,je) = -58.7401 + b_mtem(5,ja,je) = 44.999 + b_mtem(6,ja,je) = -11.9988 + +! in nh4cl (revised on 11/15/2003) + je = jnh4cl + b_mtem(1,ja,je) = -0.2073 + b_mtem(2,ja,je) = -0.4322 + b_mtem(3,ja,je) = 6.1271 + b_mtem(4,ja,je) = -12.3146 + b_mtem(5,ja,je) = 8.9919 + b_mtem(6,ja,je) = -2.3388 + +! in nacl + je = jnacl + b_mtem(1,ja,je) = 2.95913 + b_mtem(2,ja,je) = -7.92254 + b_mtem(3,ja,je) = 13.736 + b_mtem(4,ja,je) = -15.433 + b_mtem(5,ja,je) = 7.40386 + b_mtem(6,ja,je) = -0.918641 + +! in nano3 + je = jnano3 + b_mtem(1,ja,je) = 0.893272 + b_mtem(2,ja,je) = 6.53768 + b_mtem(3,ja,je) = -32.3458 + b_mtem(4,ja,je) = 61.2834 + b_mtem(5,ja,je) = -56.4446 + b_mtem(6,ja,je) = 19.9202 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 3.14484 + b_mtem(2,ja,je) = 0.077019 + b_mtem(3,ja,je) = -31.4199 + b_mtem(4,ja,je) = 80.5865 + b_mtem(5,ja,je) = -85.392 + b_mtem(6,ja,je) = 32.6644 + +! in ca(no3)2 + je = jcano3 + b_mtem(1,ja,je) = 2.60432 + b_mtem(2,ja,je) = -0.55909 + b_mtem(3,ja,je) = -19.6671 + b_mtem(4,ja,je) = 53.3446 + b_mtem(5,ja,je) = -58.9076 + b_mtem(6,ja,je) = 22.9927 + +! in cacl2 (km) revised on 3/13/2003 and again on 11/27/2003 + je = jcacl2 + b_mtem(1,ja,je) = 2.98036 + b_mtem(2,ja,je) = -8.55365 + b_mtem(3,ja,je) = 15.2108 + b_mtem(4,ja,je) = -15.9359 + b_mtem(5,ja,je) = 7.41772 + b_mtem(6,ja,je) = -1.32143 + +! in hno3 (added on 12/06/2004) + je = jhno3 + b_mtem(1,ja,je) = 3.8533 + b_mtem(2,ja,je) = -16.9427 + b_mtem(3,ja,je) = 45.0056 + b_mtem(4,ja,je) = -69.6145 + b_mtem(5,ja,je) = 54.1491 + b_mtem(6,ja,je) = -16.6513 + +! in hcl (added on 12/06/2004) + je = jhcl + b_mtem(1,ja,je) = 2.56665 + b_mtem(2,ja,je) = -7.13585 + b_mtem(3,ja,je) = 14.8103 + b_mtem(4,ja,je) = -21.8881 + b_mtem(5,ja,je) = 16.6808 + b_mtem(6,ja,je) = -5.22091 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 2.50179 + b_mtem(2,ja,je) = -6.69364 + b_mtem(3,ja,je) = 11.6551 + b_mtem(4,ja,je) = -13.6897 + b_mtem(5,ja,je) = 7.36796 + b_mtem(6,ja,je) = -1.33245 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = 0.149955 + b_mtem(2,ja,je) = 11.8213 + b_mtem(3,ja,je) = -53.9164 + b_mtem(4,ja,je) = 101.574 + b_mtem(5,ja,je) = -91.4123 + b_mtem(6,ja,je) = 31.5487 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -2.36927 + b_mtem(2,ja,je) = 14.8359 + b_mtem(3,ja,je) = -44.3443 + b_mtem(4,ja,je) = 73.6229 + b_mtem(5,ja,je) = -65.3366 + b_mtem(6,ja,je) = 23.3250 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = 2.72993 + b_mtem(2,ja,je) = -0.23406 + b_mtem(3,ja,je) = -10.4103 + b_mtem(4,ja,je) = 13.1586 + b_mtem(5,ja,je) = -7.79925 + b_mtem(6,ja,je) = 2.30843 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = 3.51258 + b_mtem(2,ja,je) = -3.95107 + b_mtem(3,ja,je) = -11.0175 + b_mtem(4,ja,je) = 38.8617 + b_mtem(5,ja,je) = -48.1575 + b_mtem(6,ja,je) = 20.4717 + + +!---------- +! 2h.so4 in e + ja = jh2so4 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 0.76734 + b_mtem(2,ja,je) = -1.12263 + b_mtem(3,ja,je) = -9.08728 + b_mtem(4,ja,je) = 30.3836 + b_mtem(5,ja,je) = -38.4133 + b_mtem(6,ja,je) = 17.0106 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -2.03879 + b_mtem(2,ja,je) = 15.7033 + b_mtem(3,ja,je) = -58.7363 + b_mtem(4,ja,je) = 109.242 + b_mtem(5,ja,je) = -102.237 + b_mtem(6,ja,je) = 37.5350 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -3.10228 + b_mtem(2,ja,je) = 16.6920 + b_mtem(3,ja,je) = -59.1522 + b_mtem(4,ja,je) = 113.487 + b_mtem(5,ja,je) = -110.890 + b_mtem(6,ja,je) = 42.4578 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -3.43885 + b_mtem(2,ja,je) = 21.0372 + b_mtem(3,ja,je) = -84.7026 + b_mtem(4,ja,je) = 165.324 + b_mtem(5,ja,je) = -156.101 + b_mtem(6,ja,je) = 57.3101 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = 0.33164 + b_mtem(2,ja,je) = 6.55864 + b_mtem(3,ja,je) = -33.5876 + b_mtem(4,ja,je) = 65.1798 + b_mtem(5,ja,je) = -63.2046 + b_mtem(6,ja,je) = 24.1783 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = 3.06830 + b_mtem(2,ja,je) = -3.18408 + b_mtem(3,ja,je) = -19.6332 + b_mtem(4,ja,je) = 61.3657 + b_mtem(5,ja,je) = -73.4438 + b_mtem(6,ja,je) = 31.2334 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 2.58649 + b_mtem(2,ja,je) = 0.87921 + b_mtem(3,ja,je) = -39.3023 + b_mtem(4,ja,je) = 101.603 + b_mtem(5,ja,je) = -109.469 + b_mtem(6,ja,je) = 43.0188 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 1.54587 + b_mtem(2,ja,je) = -7.50976 + b_mtem(3,ja,je) = 12.8237 + b_mtem(4,ja,je) = -10.1452 + b_mtem(5,ja,je) = -0.541956 + b_mtem(6,ja,je) = 3.34536 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 0.829757 + b_mtem(2,ja,je) = -4.11316 + b_mtem(3,ja,je) = 3.67111 + b_mtem(4,ja,je) = 3.6833 + b_mtem(5,ja,je) = -11.2711 + b_mtem(6,ja,je) = 6.71421 + + +!---------- +! h.hso4 in e + ja = jhhso4 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 2.63953 + b_mtem(2,ja,je) = -6.01532 + b_mtem(3,ja,je) = 10.0204 + b_mtem(4,ja,je) = -12.4840 + b_mtem(5,ja,je) = 7.78853 + b_mtem(6,ja,je) = -2.12638 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -0.77412 + b_mtem(2,ja,je) = 14.1656 + b_mtem(3,ja,je) = -53.4087 + b_mtem(4,ja,je) = 93.2013 + b_mtem(5,ja,je) = -80.5723 + b_mtem(6,ja,je) = 27.1577 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -2.98882 + b_mtem(2,ja,je) = 14.4436 + b_mtem(3,ja,je) = -40.1774 + b_mtem(4,ja,je) = 67.5937 + b_mtem(5,ja,je) = -61.5040 + b_mtem(6,ja,je) = 22.3695 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -1.15502 + b_mtem(2,ja,je) = 8.12309 + b_mtem(3,ja,je) = -38.4726 + b_mtem(4,ja,je) = 80.8861 + b_mtem(5,ja,je) = -80.1644 + b_mtem(6,ja,je) = 30.4717 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = 1.99641 + b_mtem(2,ja,je) = -2.96061 + b_mtem(3,ja,je) = 5.54778 + b_mtem(4,ja,je) = -14.5488 + b_mtem(5,ja,je) = 14.8492 + b_mtem(6,ja,je) = -5.1389 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = 2.23816 + b_mtem(2,ja,je) = -3.20847 + b_mtem(3,ja,je) = -4.82853 + b_mtem(4,ja,je) = 20.9192 + b_mtem(5,ja,je) = -27.2819 + b_mtem(6,ja,je) = 11.8655 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 2.56907 + b_mtem(2,ja,je) = 1.13444 + b_mtem(3,ja,je) = -34.6853 + b_mtem(4,ja,je) = 87.9775 + b_mtem(5,ja,je) = -93.2330 + b_mtem(6,ja,je) = 35.9260 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 2.00024 + b_mtem(2,ja,je) = -4.80868 + b_mtem(3,ja,je) = 8.29222 + b_mtem(4,ja,je) = -11.0849 + b_mtem(5,ja,je) = 7.51262 + b_mtem(6,ja,je) = -2.07654 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 2.8009 + b_mtem(2,ja,je) = -6.98416 + b_mtem(3,ja,je) = 14.3146 + b_mtem(4,ja,je) = -22.0068 + b_mtem(5,ja,je) = 17.5557 + b_mtem(6,ja,je) = -5.84917 + + +!---------- +! nh4hso4 in e + ja = jnh4hso4 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 0.169160 + b_mtem(2,ja,je) = 2.15094 + b_mtem(3,ja,je) = -9.62904 + b_mtem(4,ja,je) = 18.2631 + b_mtem(5,ja,je) = -17.3333 + b_mtem(6,ja,je) = 6.19835 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -2.34457 + b_mtem(2,ja,je) = 12.8035 + b_mtem(3,ja,je) = -35.2513 + b_mtem(4,ja,je) = 53.6153 + b_mtem(5,ja,je) = -42.7655 + b_mtem(6,ja,je) = 13.7129 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -2.56109 + b_mtem(2,ja,je) = 11.1414 + b_mtem(3,ja,je) = -30.2361 + b_mtem(4,ja,je) = 50.0320 + b_mtem(5,ja,je) = -44.1586 + b_mtem(6,ja,je) = 15.5393 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -0.97315 + b_mtem(2,ja,je) = 7.06295 + b_mtem(3,ja,je) = -29.3032 + b_mtem(4,ja,je) = 57.6101 + b_mtem(5,ja,je) = -54.9020 + b_mtem(6,ja,je) = 20.2222 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -0.44450 + b_mtem(2,ja,je) = 3.33451 + b_mtem(3,ja,je) = -15.2791 + b_mtem(4,ja,je) = 30.1413 + b_mtem(5,ja,je) = -26.7710 + b_mtem(6,ja,je) = 8.78462 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -0.99780 + b_mtem(2,ja,je) = 4.69200 + b_mtem(3,ja,je) = -16.1219 + b_mtem(4,ja,je) = 29.3100 + b_mtem(5,ja,je) = -26.3383 + b_mtem(6,ja,je) = 9.20695 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -0.52694 + b_mtem(2,ja,je) = 7.02684 + b_mtem(3,ja,je) = -33.7508 + b_mtem(4,ja,je) = 70.0565 + b_mtem(5,ja,je) = -68.3226 + b_mtem(6,ja,je) = 25.2692 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 0.572926 + b_mtem(2,ja,je) = -2.04791 + b_mtem(3,ja,je) = 2.1134 + b_mtem(4,ja,je) = 0.246654 + b_mtem(5,ja,je) = -3.06019 + b_mtem(6,ja,je) = 1.98126 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 0.56514 + b_mtem(2,ja,je) = 0.22287 + b_mtem(3,ja,je) = -2.76973 + b_mtem(4,ja,je) = 4.54444 + b_mtem(5,ja,je) = -3.86549 + b_mtem(6,ja,je) = 1.13441 + + +!---------- +! (nh4)3h(so4)2 in e + ja = jlvcite + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = -1.44811 + b_mtem(2,ja,je) = 6.71815 + b_mtem(3,ja,je) = -25.0141 + b_mtem(4,ja,je) = 50.1109 + b_mtem(5,ja,je) = -50.0561 + b_mtem(6,ja,je) = 19.3370 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -3.41707 + b_mtem(2,ja,je) = 13.4496 + b_mtem(3,ja,je) = -34.8018 + b_mtem(4,ja,je) = 55.2987 + b_mtem(5,ja,je) = -48.1839 + b_mtem(6,ja,je) = 17.2444 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -2.54479 + b_mtem(2,ja,je) = 11.8501 + b_mtem(3,ja,je) = -39.7286 + b_mtem(4,ja,je) = 74.2479 + b_mtem(5,ja,je) = -70.4934 + b_mtem(6,ja,je) = 26.2836 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -2.30561 + b_mtem(2,ja,je) = 14.5806 + b_mtem(3,ja,je) = -55.1238 + b_mtem(4,ja,je) = 103.451 + b_mtem(5,ja,je) = -95.2571 + b_mtem(6,ja,je) = 34.2218 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -2.20809 + b_mtem(2,ja,je) = 13.6391 + b_mtem(3,ja,je) = -57.8246 + b_mtem(4,ja,je) = 117.907 + b_mtem(5,ja,je) = -112.154 + b_mtem(6,ja,je) = 40.3058 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -1.15099 + b_mtem(2,ja,je) = 6.32269 + b_mtem(3,ja,je) = -27.3860 + b_mtem(4,ja,je) = 55.4592 + b_mtem(5,ja,je) = -54.0100 + b_mtem(6,ja,je) = 20.3469 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -1.15678 + b_mtem(2,ja,je) = 8.28718 + b_mtem(3,ja,je) = -37.3231 + b_mtem(4,ja,je) = 76.6124 + b_mtem(5,ja,je) = -74.9307 + b_mtem(6,ja,je) = 28.0559 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 0.01502 + b_mtem(2,ja,je) = -3.1197 + b_mtem(3,ja,je) = 3.61104 + b_mtem(4,ja,je) = 3.05196 + b_mtem(5,ja,je) = -9.98957 + b_mtem(6,ja,je) = 6.04155 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = -1.06477 + b_mtem(2,ja,je) = 3.38801 + b_mtem(3,ja,je) = -12.5784 + b_mtem(4,ja,je) = 25.2823 + b_mtem(5,ja,je) = -25.4611 + b_mtem(6,ja,je) = 10.0754 + + +!---------- +! nahso4 in e + ja = jnahso4 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = 0.68259 + b_mtem(2,ja,je) = 0.71468 + b_mtem(3,ja,je) = -5.59003 + b_mtem(4,ja,je) = 11.0089 + b_mtem(5,ja,je) = -10.7983 + b_mtem(6,ja,je) = 3.82335 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -0.03956 + b_mtem(2,ja,je) = 4.52828 + b_mtem(3,ja,je) = -25.2557 + b_mtem(4,ja,je) = 54.4225 + b_mtem(5,ja,je) = -52.5105 + b_mtem(6,ja,je) = 18.6562 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -1.53503 + b_mtem(2,ja,je) = 8.27608 + b_mtem(3,ja,je) = -28.9539 + b_mtem(4,ja,je) = 55.2876 + b_mtem(5,ja,je) = -51.9563 + b_mtem(6,ja,je) = 18.6576 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -0.38793 + b_mtem(2,ja,je) = 7.14680 + b_mtem(3,ja,je) = -38.7201 + b_mtem(4,ja,je) = 84.3965 + b_mtem(5,ja,je) = -84.7453 + b_mtem(6,ja,je) = 32.1283 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -0.41982 + b_mtem(2,ja,je) = 4.26491 + b_mtem(3,ja,je) = -20.2351 + b_mtem(4,ja,je) = 42.6764 + b_mtem(5,ja,je) = -40.7503 + b_mtem(6,ja,je) = 14.2868 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -0.32912 + b_mtem(2,ja,je) = 1.80808 + b_mtem(3,ja,je) = -8.01286 + b_mtem(4,ja,je) = 15.5791 + b_mtem(5,ja,je) = -14.5494 + b_mtem(6,ja,je) = 5.27052 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = 0.10271 + b_mtem(2,ja,je) = 5.09559 + b_mtem(3,ja,je) = -30.3295 + b_mtem(4,ja,je) = 66.2975 + b_mtem(5,ja,je) = -66.3458 + b_mtem(6,ja,je) = 24.9443 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 0.608309 + b_mtem(2,ja,je) = -0.541905 + b_mtem(3,ja,je) = -2.52084 + b_mtem(4,ja,je) = 6.63297 + b_mtem(5,ja,je) = -7.24599 + b_mtem(6,ja,je) = 2.88811 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 1.98399 + b_mtem(2,ja,je) = -4.51562 + b_mtem(3,ja,je) = 8.36059 + b_mtem(4,ja,je) = -12.4948 + b_mtem(5,ja,je) = 9.67514 + b_mtem(6,ja,je) = -3.18004 + + +!---------- +! na3h(so4)2 in e + ja = jna3hso4 + +! in h2so4 + je = jh2so4 + b_mtem(1,ja,je) = -0.83214 + b_mtem(2,ja,je) = 4.99572 + b_mtem(3,ja,je) = -20.1697 + b_mtem(4,ja,je) = 41.4066 + b_mtem(5,ja,je) = -42.2119 + b_mtem(6,ja,je) = 16.4855 + +! in nh4hso4 + je = jnh4hso4 + b_mtem(1,ja,je) = -0.65139 + b_mtem(2,ja,je) = 3.52300 + b_mtem(3,ja,je) = -22.8220 + b_mtem(4,ja,je) = 56.2956 + b_mtem(5,ja,je) = -59.9028 + b_mtem(6,ja,je) = 23.1844 + +! in (nh4)3h(so4)2 + je = jlvcite + b_mtem(1,ja,je) = -1.31331 + b_mtem(2,ja,je) = 8.40835 + b_mtem(3,ja,je) = -38.1757 + b_mtem(4,ja,je) = 80.5312 + b_mtem(5,ja,je) = -79.8346 + b_mtem(6,ja,je) = 30.0219 + +! in (nh4)2so4 + je = jnh4so4 + b_mtem(1,ja,je) = -1.03054 + b_mtem(2,ja,je) = 8.08155 + b_mtem(3,ja,je) = -38.1046 + b_mtem(4,ja,je) = 78.7168 + b_mtem(5,ja,je) = -77.2263 + b_mtem(6,ja,je) = 29.1521 + +! in nahso4 + je = jnahso4 + b_mtem(1,ja,je) = -1.90695 + b_mtem(2,ja,je) = 11.6241 + b_mtem(3,ja,je) = -50.3175 + b_mtem(4,ja,je) = 105.884 + b_mtem(5,ja,je) = -103.258 + b_mtem(6,ja,je) = 37.6588 + +! in na3h(so4)2 + je = jna3hso4 + b_mtem(1,ja,je) = -0.34780 + b_mtem(2,ja,je) = 2.85363 + b_mtem(3,ja,je) = -17.6224 + b_mtem(4,ja,je) = 38.9220 + b_mtem(5,ja,je) = -39.8106 + b_mtem(6,ja,je) = 15.6055 + +! in na2so4 + je = jna2so4 + b_mtem(1,ja,je) = -0.75230 + b_mtem(2,ja,je) = 10.0140 + b_mtem(3,ja,je) = -50.5677 + b_mtem(4,ja,je) = 106.941 + b_mtem(5,ja,je) = -105.534 + b_mtem(6,ja,je) = 39.5196 + +! in hno3 + je = jhno3 + b_mtem(1,ja,je) = 0.057456 + b_mtem(2,ja,je) = -1.31264 + b_mtem(3,ja,je) = -1.94662 + b_mtem(4,ja,je) = 10.7024 + b_mtem(5,ja,je) = -14.9946 + b_mtem(6,ja,je) = 7.12161 + +! in hcl + je = jhcl + b_mtem(1,ja,je) = 0.637894 + b_mtem(2,ja,je) = -2.29719 + b_mtem(3,ja,je) = 0.765361 + b_mtem(4,ja,je) = 4.8748 + b_mtem(5,ja,je) = -9.25978 + b_mtem(6,ja,je) = 4.91773 +! +! +! +!---------------------------------------------------------- +! coefficients for %mdrh(t) = d1 + d2*t + d3*t^2 + d4*t^3 (t in kelvin) +! valid temperature range: 240 - 320 k +!---------------------------------------------------------- +! +! sulfate-poor systems +! ac + j_index = 1 + d_mdrh(j_index,1) = -58.00268351 + d_mdrh(j_index,2) = 2.031077573 + d_mdrh(j_index,3) = -0.008281218 + d_mdrh(j_index,4) = 1.00447e-05 + +! an + j_index = 2 + d_mdrh(j_index,1) = 1039.137773 + d_mdrh(j_index,2) = -11.47847095 + d_mdrh(j_index,3) = 0.047702786 + d_mdrh(j_index,4) = -6.77675e-05 + +! as + j_index = 3 + d_mdrh(j_index,1) = 115.8366357 + d_mdrh(j_index,2) = 0.491881663 + d_mdrh(j_index,3) = -0.00422807 + d_mdrh(j_index,4) = 7.29274e-06 + +! sc + j_index = 4 + d_mdrh(j_index,1) = 253.2424151 + d_mdrh(j_index,2) = -1.429957864 + d_mdrh(j_index,3) = 0.003727554 + d_mdrh(j_index,4) = -3.13037e-06 + +! sn + j_index = 5 + d_mdrh(j_index,1) = -372.4306506 + d_mdrh(j_index,2) = 5.3955633 + d_mdrh(j_index,3) = -0.019804438 + d_mdrh(j_index,4) = 2.25662e-05 + +! ss + j_index = 6 + d_mdrh(j_index,1) = 286.1271416 + d_mdrh(j_index,2) = -1.670787758 + d_mdrh(j_index,3) = 0.004431373 + d_mdrh(j_index,4) = -3.57757e-06 + +! cc + j_index = 7 + d_mdrh(j_index,1) = -1124.07059 + d_mdrh(j_index,2) = 14.26364209 + d_mdrh(j_index,3) = -0.054816822 + d_mdrh(j_index,4) = 6.70107e-05 + +! cn + j_index = 8 + d_mdrh(j_index,1) = 1855.413934 + d_mdrh(j_index,2) = -20.29219473 + d_mdrh(j_index,3) = 0.07807482 + d_mdrh(j_index,4) = -1.017887858e-4 + +! an + ac + j_index = 9 + d_mdrh(j_index,1) = 1761.176886 + d_mdrh(j_index,2) = -19.29811062 + d_mdrh(j_index,3) = 0.075676987 + d_mdrh(j_index,4) = -1.0116959e-4 + +! as + ac + j_index = 10 + d_mdrh(j_index,1) = 122.1074303 + d_mdrh(j_index,2) = 0.429692122 + d_mdrh(j_index,3) = -0.003928277 + d_mdrh(j_index,4) = 6.43275e-06 + +! as + an + j_index = 11 + d_mdrh(j_index,1) = 2424.634678 + d_mdrh(j_index,2) = -26.54031307 + d_mdrh(j_index,3) = 0.101625387 + d_mdrh(j_index,4) = -1.31544547798e-4 + +! as + an + ac + j_index = 12 + d_mdrh(j_index,1) = 2912.082599 + d_mdrh(j_index,2) = -31.8894185 + d_mdrh(j_index,3) = 0.121185849 + d_mdrh(j_index,4) = -1.556534623e-4 + +! sc + ac + j_index = 13 + d_mdrh(j_index,1) = 172.2596493 + d_mdrh(j_index,2) = -0.511006195 + d_mdrh(j_index,3) = 4.27244597e-4 + d_mdrh(j_index,4) = 4.12797e-07 + +! sn + ac + j_index = 14 + d_mdrh(j_index,1) = 1596.184935 + d_mdrh(j_index,2) = -16.37945565 + d_mdrh(j_index,3) = 0.060281218 + d_mdrh(j_index,4) = -7.6161e-05 + +! sn + an + j_index = 15 + d_mdrh(j_index,1) = 1916.072988 + d_mdrh(j_index,2) = -20.85594868 + d_mdrh(j_index,3) = 0.081140141 + d_mdrh(j_index,4) = -1.07954274796e-4 + +! sn + an + ac + j_index = 16 + d_mdrh(j_index,1) = 1467.165935 + d_mdrh(j_index,2) = -16.01166196 + d_mdrh(j_index,3) = 0.063505582 + d_mdrh(j_index,4) = -8.66722e-05 + +! sn + sc + j_index = 17 + d_mdrh(j_index,1) = 158.447059 + d_mdrh(j_index,2) = -0.628167358 + d_mdrh(j_index,3) = 0.002014448 + d_mdrh(j_index,4) = -3.13037e-06 + +! sn + sc + ac + j_index = 18 + d_mdrh(j_index,1) = 1115.892468 + d_mdrh(j_index,2) = -11.76936534 + d_mdrh(j_index,3) = 0.045577399 + d_mdrh(j_index,4) = -6.05779e-05 + +! ss + ac + j_index = 19 + d_mdrh(j_index,1) = 269.5432407 + d_mdrh(j_index,2) = -1.319963885 + d_mdrh(j_index,3) = 0.002592363 + d_mdrh(j_index,4) = -1.44479e-06 + +! ss + an + j_index = 20 + d_mdrh(j_index,1) = 2841.334784 + d_mdrh(j_index,2) = -31.1889487 + d_mdrh(j_index,3) = 0.118809274 + d_mdrh(j_index,4) = -1.53007e-4 + +! ss + an + ac + j_index = 21 + d_mdrh(j_index,1) = 2199.36914 + d_mdrh(j_index,2) = -24.11926569 + d_mdrh(j_index,3) = 0.092932361 + d_mdrh(j_index,4) = -1.21774e-4 + +! ss + as + j_index = 22 + d_mdrh(j_index,1) = 395.0051604 + d_mdrh(j_index,2) = -2.521101657 + d_mdrh(j_index,3) = 0.006139319 + d_mdrh(j_index,4) = -4.43756e-06 + +! ss + as + ac + j_index = 23 + d_mdrh(j_index,1) = 386.5150675 + d_mdrh(j_index,2) = -2.4632138 + d_mdrh(j_index,3) = 0.006139319 + d_mdrh(j_index,4) = -4.98796e-06 + +! ss + as + an + j_index = 24 + d_mdrh(j_index,1) = 3101.538491 + d_mdrh(j_index,2) = -34.19978105 + d_mdrh(j_index,3) = 0.130118605 + d_mdrh(j_index,4) = -1.66873e-4 + +! ss + as + an + ac + j_index = 25 + d_mdrh(j_index,1) = 2307.579403 + d_mdrh(j_index,2) = -25.43136774 + d_mdrh(j_index,3) = 0.098064728 + d_mdrh(j_index,4) = -1.28301e-4 + +! ss + sc + j_index = 26 + d_mdrh(j_index,1) = 291.8309602 + d_mdrh(j_index,2) = -1.828912974 + d_mdrh(j_index,3) = 0.005053148 + d_mdrh(j_index,4) = -4.57516e-06 + +! ss + sc + ac + j_index = 27 + d_mdrh(j_index,1) = 188.3914345 + d_mdrh(j_index,2) = -0.631345031 + d_mdrh(j_index,3) = 0.000622807 + d_mdrh(j_index,4) = 4.47196e-07 + +! ss + sn + j_index = 28 + d_mdrh(j_index,1) = -167.1252839 + d_mdrh(j_index,2) = 2.969828002 + d_mdrh(j_index,3) = -0.010637255 + d_mdrh(j_index,4) = 1.13175e-05 + +! ss + sn + ac + j_index = 29 + d_mdrh(j_index,1) = 1516.782768 + d_mdrh(j_index,2) = -15.7922661 + d_mdrh(j_index,3) = 0.058942209 + d_mdrh(j_index,4) = -7.5301e-05 + +! ss + sn + an + j_index = 30 + d_mdrh(j_index,1) = 1739.963163 + d_mdrh(j_index,2) = -19.06576022 + d_mdrh(j_index,3) = 0.07454963 + d_mdrh(j_index,4) = -9.94302e-05 + +! ss + sn + an + ac + j_index = 31 + d_mdrh(j_index,1) = 2152.104877 + d_mdrh(j_index,2) = -23.74998008 + d_mdrh(j_index,3) = 0.092256654 + d_mdrh(j_index,4) = -1.21953e-4 + +! ss + sn + sc + j_index = 32 + d_mdrh(j_index,1) = 221.9976265 + d_mdrh(j_index,2) = -1.311331272 + d_mdrh(j_index,3) = 0.004406089 + d_mdrh(j_index,4) = -5.88235e-06 + +! ss + sn + sc + ac + j_index = 33 + d_mdrh(j_index,1) = 1205.645615 + d_mdrh(j_index,2) = -12.71353459 + d_mdrh(j_index,3) = 0.048803922 + d_mdrh(j_index,4) = -6.41899e-05 + +! cc + ac + j_index = 34 + d_mdrh(j_index,1) = 506.6737879 + d_mdrh(j_index,2) = -3.723520818 + d_mdrh(j_index,3) = 0.010814242 + d_mdrh(j_index,4) = -1.21087e-05 + +! cc + sc + j_index = 35 + d_mdrh(j_index,1) = -1123.523841 + d_mdrh(j_index,2) = 14.08345977 + d_mdrh(j_index,3) = -0.053687823 + d_mdrh(j_index,4) = 6.52219e-05 + +! cc + sc + ac + j_index = 36 + d_mdrh(j_index,1) = -1159.98607 + d_mdrh(j_index,2) = 14.44309169 + d_mdrh(j_index,3) = -0.054841073 + d_mdrh(j_index,4) = 6.64259e-05 + +! cn + ac + j_index = 37 + d_mdrh(j_index,1) = 756.0747916 + d_mdrh(j_index,2) = -8.546826257 + d_mdrh(j_index,3) = 0.035798677 + d_mdrh(j_index,4) = -5.06629e-05 + +! cn + an + j_index = 38 + d_mdrh(j_index,1) = 338.668191 + d_mdrh(j_index,2) = -2.971223403 + d_mdrh(j_index,3) = 0.012294866 + d_mdrh(j_index,4) = -1.87558e-05 + +! cn + an + ac + j_index = 39 + d_mdrh(j_index,1) = -53.18033508 + d_mdrh(j_index,2) = 0.663911748 + d_mdrh(j_index,3) = 9.16326e-4 + d_mdrh(j_index,4) = -6.70354e-06 + +! cn + sc + j_index = 40 + d_mdrh(j_index,1) = 3623.831129 + d_mdrh(j_index,2) = -39.27226457 + d_mdrh(j_index,3) = 0.144559515 + d_mdrh(j_index,4) = -1.78159e-4 + +! cn + sc + ac + j_index = 41 + d_mdrh(j_index,1) = 3436.656743 + d_mdrh(j_index,2) = -37.16192684 + d_mdrh(j_index,3) = 0.136641377 + d_mdrh(j_index,4) = -1.68262e-4 + +! cn + sn + j_index = 42 + d_mdrh(j_index,1) = 768.608476 + d_mdrh(j_index,2) = -8.051517149 + d_mdrh(j_index,3) = 0.032342332 + d_mdrh(j_index,4) = -4.52224e-05 + +! cn + sn + ac + j_index = 43 + d_mdrh(j_index,1) = 33.58027951 + d_mdrh(j_index,2) = -0.308772182 + d_mdrh(j_index,3) = 0.004713639 + d_mdrh(j_index,4) = -1.19658e-05 + +! cn + sn + an + j_index = 44 + d_mdrh(j_index,1) = 57.80183041 + d_mdrh(j_index,2) = 0.215264604 + d_mdrh(j_index,3) = 4.11406e-4 + d_mdrh(j_index,4) = -4.30702e-06 + +! cn + sn + an + ac + j_index = 45 + d_mdrh(j_index,1) = -234.368984 + d_mdrh(j_index,2) = 2.721045204 + d_mdrh(j_index,3) = -0.006688341 + d_mdrh(j_index,4) = 2.31729e-06 + +! cn + sn + sc + j_index = 46 + d_mdrh(j_index,1) = 3879.080557 + d_mdrh(j_index,2) = -42.13562874 + d_mdrh(j_index,3) = 0.155235005 + d_mdrh(j_index,4) = -1.91387e-4 + +! cn + sn + sc + ac + j_index = 47 + d_mdrh(j_index,1) = 3600.576985 + d_mdrh(j_index,2) = -39.0283489 + d_mdrh(j_index,3) = 0.143710316 + d_mdrh(j_index,4) = -1.77167e-4 + +! cn + cc + j_index = 48 + d_mdrh(j_index,1) = -1009.729826 + d_mdrh(j_index,2) = 12.9145339 + d_mdrh(j_index,3) = -0.049811146 + d_mdrh(j_index,4) = 6.09563e-05 + +! cn + cc + ac + j_index = 49 + d_mdrh(j_index,1) = -577.0919514 + d_mdrh(j_index,2) = 8.020324227 + d_mdrh(j_index,3) = -0.031469556 + d_mdrh(j_index,4) = 3.82181e-05 + +! cn + cc + sc + j_index = 50 + d_mdrh(j_index,1) = -728.9983499 + d_mdrh(j_index,2) = 9.849458215 + d_mdrh(j_index,3) = -0.03879257 + d_mdrh(j_index,4) = 4.78844e-05 + +! cn + cc + sc + ac + j_index = 51 + d_mdrh(j_index,1) = -803.7026845 + d_mdrh(j_index,2) = 10.61881494 + d_mdrh(j_index,3) = -0.041402993 + d_mdrh(j_index,4) = 5.08084e-05 + +! +! sulfate-rich systems +! ab + j_index = 52 + d_mdrh(j_index,1) = -493.6190458 + d_mdrh(j_index,2) = 6.747053851 + d_mdrh(j_index,3) = -0.026955267 + d_mdrh(j_index,4) = 3.45118e-05 + +! lv + j_index = 53 + d_mdrh(j_index,1) = 53.37874093 + d_mdrh(j_index,2) = 1.01368249 + d_mdrh(j_index,3) = -0.005887513 + d_mdrh(j_index,4) = 8.94393e-06 + +! sb + j_index = 54 + d_mdrh(j_index,1) = 206.619047 + d_mdrh(j_index,2) = -1.342735684 + d_mdrh(j_index,3) = 0.003197691 + d_mdrh(j_index,4) = -1.93603e-06 + +! ab + lv + j_index = 55 + d_mdrh(j_index,1) = -493.6190458 + d_mdrh(j_index,2) = 6.747053851 + d_mdrh(j_index,3) = -0.026955267 + d_mdrh(j_index,4) = 3.45118e-05 + +! as + lv + j_index = 56 + d_mdrh(j_index,1) = 53.37874093 + d_mdrh(j_index,2) = 1.01368249 + d_mdrh(j_index,3) = -0.005887513 + d_mdrh(j_index,4) = 8.94393e-06 + +! ss + sb + j_index = 57 + d_mdrh(j_index,1) = 206.619047 + d_mdrh(j_index,2) = -1.342735684 + d_mdrh(j_index,3) = 0.003197691 + d_mdrh(j_index,4) = -1.93603e-06 + +! ss + lv + j_index = 58 + d_mdrh(j_index,1) = 41.7619047 + d_mdrh(j_index,2) = 1.303872053 + d_mdrh(j_index,3) = -0.007647908 + d_mdrh(j_index,4) = 1.17845e-05 + +! ss + as + lv + j_index = 59 + d_mdrh(j_index,1) = 41.7619047 + d_mdrh(j_index,2) = 1.303872053 + d_mdrh(j_index,3) = -0.007647908 + d_mdrh(j_index,4) = 1.17845e-05 + +! ss + ab + j_index = 60 + d_mdrh(j_index,1) = -369.7142842 + d_mdrh(j_index,2) = 5.512878771 + d_mdrh(j_index,3) = -0.02301948 + d_mdrh(j_index,4) = 3.0303e-05 + +! ss + lv + ab + j_index = 61 + d_mdrh(j_index,1) = -369.7142842 + d_mdrh(j_index,2) = 5.512878771 + d_mdrh(j_index,3) = -0.02301948 + d_mdrh(j_index,4) = 3.0303e-05 + +! sb + ab + j_index = 62 + d_mdrh(j_index,1) = -162.8095232 + d_mdrh(j_index,2) = 2.399326592 + d_mdrh(j_index,3) = -0.009336219 + d_mdrh(j_index,4) = 1.17845e-05 + +! ss + sb + ab + j_index = 63 + d_mdrh(j_index,1) = -735.4285689 + d_mdrh(j_index,2) = 8.885521857 + d_mdrh(j_index,3) = -0.033488456 + d_mdrh(j_index,4) = 4.12458e-05 + + + endif ! first + + return + end subroutine load_mosaic_parameters + + + + + + + + + + + +!*********************************************************************** +! updates all temperature dependent thermodynamic parameters +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine update_thermodynamic_constants +! implicit none +! include 'mosaic.h' +! local variables + integer iv, j_index, ibin, je + real(kind=8) tr, rt, term +! function +! real(kind=8) fn_keq, fn_po, drh_mutual, bin_molality + + + tr = 298.15 ! reference temperature + rt = 82.056*t_k/(1.e9*1.e6) ! [m^3 atm/nmol] + +! gas-liquid + keq_gl(1)= 1.0 ! kelvin effect (default) + keq_gl(2)= fn_keq(57.64d0 , 13.79d0, -5.39d0,t_k)*rt ! nh3(g) <=> nh3(l) + keq_gl(3)= fn_keq(2.63d6, 29.17d0, 16.83d0,t_k)*rt ! hno3(g) <=> no3- + h+ + keq_gl(4)= fn_keq(2.00d6, 30.20d0, 19.91d0,t_k)*rt ! hcl(g) <=> cl- + h+ + +! liquid-liquid + keq_ll(1)= fn_keq(1.0502d-2, 8.85d0, 25.14d0,t_k) ! hso4- <=> so4= + h+ + keq_ll(2)= fn_keq(1.805d-5, -1.50d0, 26.92d0,t_k) ! nh3(l) + h2o = nh4+ + oh- + keq_ll(3)= fn_keq(1.01d-14,-22.52d0, 26.92d0,t_k) ! h2o(l) <=> h+ + oh- + + + kp_nh3 = keq_ll(3)/(keq_ll(2)*keq_gl(2)) + kp_nh4no3= kp_nh3/keq_gl(3) + kp_nh4cl = kp_nh3/keq_gl(4) + + +! solid-gas + keq_sg(1)= fn_keq(4.72d-17,-74.38d0,6.12d0,t_k)/rt**2 ! nh4no3<=>nh3(g)+hno3(g) + keq_sg(2)= fn_keq(8.43d-17,-71.00d0,2.40d0,t_k)/rt**2 ! nh4cl <=>nh3(g)+hcl(g) + + +! solid-liquid + keq_sl(jnh4so4) = fn_keq(1.040d0,-2.65d0, 38.57d0, t_k) ! amso4(s) = 2nh4+ + so4= + keq_sl(jlvcite) = fn_keq(11.8d0, -5.19d0, 54.40d0, t_k) ! lvcite(s)= 3nh4+ + hso4- + so4= + keq_sl(jnh4hso4)= fn_keq(117.0d0,-2.87d0, 15.83d0, t_k) ! amhso4(s)= nh4+ + hso4- + keq_sl(jnh4msa) = 1.e15 ! NH4MSA(s)= NH4+ + MSA- + keq_sl(jnh4no3) = fn_keq(12.21d0,-10.4d0, 17.56d0, t_k) ! nh4no3(s)= nh4+ + no3- + keq_sl(jnh4cl) = fn_keq(17.37d0,-6.03d0, 16.92d0, t_k) ! nh4cl(s) = nh4+ + cl- + keq_sl(jna2so4) = fn_keq(0.491d0, 0.98d0, 39.75d0, t_k) ! na2so4(s)= 2na+ + so4= + keq_sl(jnahso4) = fn_keq(313.0d0, 0.8d0, 14.79d0, t_k) ! nahso4(s)= na+ + hso4- + keq_sl(jna3hso4)= 1.e15 ! na3h(so4)2(s) = 2na+ + hso4- + so4= + keq_sl(jnamsa) = 1.e15 ! NaMSA(s) = Na+ + MSA- + keq_sl(jnano3) = fn_keq(11.95d0,-8.22d0, 16.01d0, t_k) ! nano3(s) = na+ + no3- + keq_sl(jnacl) = fn_keq(38.28d0,-1.52d0, 16.89d0, t_k) ! nacl(s) = na+ + cl- + keq_sl(jcacl2) = fn_keq(8.0d11,32.84d0,44.79d0, t_k)*1.e5 ! cacl2(s) = ca++ + 2cl- + keq_sl(jcano3) = fn_keq(4.31d5, 7.83d0,42.01d0, t_k)*1.e5 ! ca(no3)2(s) = ca++ + 2no3- + keq_sl(jcamsa2) = 1.e15 ! CaMSA2(s)= Ca+ + 2MSA- + +! vapor pressures of soa species + po_soa(iaro1_g) = fn_po(5.7d-5, 156.0d0, t_k) ! [pascal] + po_soa(iaro2_g) = fn_po(1.6d-3, 156.0d0, t_k) ! [pascal] + po_soa(ialk1_g) = fn_po(5.0d-6, 156.0d0, t_k) ! [pascal] + po_soa(iole1_g) = fn_po(5.0d-6, 156.0d0, t_k) ! [pascal] + po_soa(iapi1_g) = fn_po(4.0d-6, 156.0d0, t_k) ! [pascal] + po_soa(iapi2_g) = fn_po(1.7d-4, 156.0d0, t_k) ! [pascal] + po_soa(ilim1_g) = fn_po(2.5d-5, 156.0d0, t_k) ! [pascal] + po_soa(ilim2_g) = fn_po(1.2d-4, 156.0d0, t_k) ! [pascal] + + do iv = iaro1_g, ngas_volatile + sat_soa(iv) = 1.e9*po_soa(iv)/(8.314*t_k) ! [nmol/m^3(air)] + enddo + +! water surface tension + term = (647.15 - t_k)/647.15 + sigma_water = 0.2358*term**1.256 * (1. - 0.625*term) ! surface tension of pure water in n/m + +! mdrh(t) + do j_index = 1, 63 + mdrh_t(j_index) = drh_mutual(j_index) + enddo + + + +! rh dependent parameters + do ibin = 1, nbin_a + ah2o_a(ibin) = ah2o ! initialize + enddo + + call mtem_compute_log_gamz ! function of ah2o and t + + + return + end subroutine update_thermodynamic_constants + + + + +!*********************************************************************** +! functions used in mosaic +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + + + +!---------------------------------------------------------- + real(kind=8) function fn_keq(keq_298, a, b, t) +! implicit none +! subr. arguments + real(kind=8) keq_298, a, b, t +! local variables + real(kind=8) tt + + + tt = 298.15/t + fn_keq = keq_298*exp(a*(tt-1.)+b*(1.+log(tt)-tt)) + + return + end function fn_keq +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- + real(kind=8) function fn_po(po_298, dh, t) ! touch +! implicit none +! subr. arguments + real(kind=8) po_298, dh, t +! local variables + + fn_po = po_298*exp(-(dh/8.314e-3)*(1./t - 3.354016435e-3)) + + return + end function fn_po +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- + real(kind=8) function drh_mutual(j_index) +! implicit none +! include 'mosaic.h' +! subr. arguments + integer j_index +! local variables + integer j + + + j = j_index + + if(j_index .eq. 7 .or. j_index .eq. 8 .or. & + (j_index.ge. 34 .and. j_index .le. 51))then + + drh_mutual = 10.0 ! cano3 or cacl2 containing mixtures + + else + + drh_mutual = d_mdrh(j,1) + t_k* & + (d_mdrh(j,2) + t_k* & + (d_mdrh(j,3) + t_k* & + d_mdrh(j,4) )) + 1.0 + + endif + + + return + end function drh_mutual +!---------------------------------------------------------- + + + + + + +!---------------------------------------------------------- +! zsr method at 60% rh +! + real(kind=8) function aerosol_water_up(ibin) ! kg (water)/m^3 (air) +! implicit none +! include 'mosaic.h' +! subr. arguments + integer ibin +! local variables + integer jp, je + real(kind=8) dum +! function +! real(kind=8) bin_molality_60 + + + jp = jtotal + dum = 0.0 + + do je = 1, (nsalt+4) ! include hno3 and hcl in water calculation + dum = dum + 1.e-9*electrolyte(je,jp,ibin)/bin_molality_60(je) + enddo + + aerosol_water_up = dum + + return + end function aerosol_water_up +!---------------------------------------------------------- + + + + + + +!---------------------------------------------------------- +! zsr method + real(kind=8) function aerosol_water(jp,ibin) ! kg (water)/m^3 (air) +! implicit none +! include 'mosaic.h' +! subr. arguments + integer jp, ibin +! local variables + integer je + real(kind=8) dum +! function +! real(kind=8) bin_molality + + + + dum = 0.0 + do je = 1, (nsalt+4) ! include hno3 and hcl in water calculation + dum = dum + 1.e-9*electrolyte(je,jp,ibin)/bin_molality(je,ibin) + enddo + + aerosol_water = dum + + if(aerosol_water .le. 0.0)then + if (iprint_mosaic_diag1 .gt. 0) then + write(6,*)'mosaic aerosol_water - water .le. 0' + write(6,*)'iclm jclm ibin jp = ', & + iclm_aer, jclm_aer, ibin, jp + write(6,*)'ah2o, water = ', ah2o, aerosol_water + write(6,*)'dry mass = ', mass_dry_a(ibin) + write(6,*)'soluble mass = ', mass_soluble_a(ibin) + write(6,*)'number = ', num_a(ibin) + do je = 1, nsoluble + write(6,44)ename(je), electrolyte(je,jp,ibin) + enddo + write(6,*)'error in water calculation' + write(6,*)'ibin = ', ibin + write(6,*)'water content cannot be negative or zero' + write(6,*)'setting jaerosolstate to all_solid' + endif + + call print_input + + jaerosolstate(ibin) = all_solid + jphase(ibin) = jsolid + jhyst_leg(ibin) = jhyst_lo + +!c write(6,*)'stopping execution in function aerosol_water' +!c stop + endif + +44 format(a7, 2x, e11.3) + + + return + end function aerosol_water +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- + real(kind=8) function bin_molality(je,ibin) +! implicit none +! include 'mosaic.h' +! subr. arguments + integer je, ibin +! local variables + real(kind=8) aw, xm + + + aw = max(ah2o_a(ibin), aw_min(je)) + aw = min(aw, 0.999999D0) + + + if(aw .lt. 0.97)then + + xm = a_zsr(1,je) + & + aw*(a_zsr(2,je) + & + aw*(a_zsr(3,je) + & + aw*(a_zsr(4,je) + & + aw*(a_zsr(5,je) + & + aw* a_zsr(6,je) )))) + + bin_molality = 55.509*xm/(1. - xm) + + else + + bin_molality = -b_zsr(je)*log(aw) + + endif + + + return + end function bin_molality +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- + real(kind=8) function bin_molality_60(je) +! implicit none +! include 'mosaic.h' +! subr. arguments + integer je +! local variables + real(kind=8) aw, xm + + + aw = 0.6 + + xm = a_zsr(1,je) + aw* & + (a_zsr(2,je) + aw* & + (a_zsr(3,je) + aw* & + (a_zsr(4,je) + aw* & + (a_zsr(5,je) + aw* & + a_zsr(6,je) )))) + + bin_molality_60 = 55.509*xm/(1. - xm) + + return + end function bin_molality_60 +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- + real(kind=8) function fnlog_gamz(ja,je) ! ja in je +! implicit none +! include 'mosaic.h' +! subr. arguments + integer ja, je +! local variables + real(kind=8) aw + + + aw = max(ah2o, aw_min(je)) + + fnlog_gamz = b_mtem(1,ja,je) + aw* & + (b_mtem(2,ja,je) + aw* & + (b_mtem(3,ja,je) + aw* & + (b_mtem(4,ja,je) + aw* & + (b_mtem(5,ja,je) + aw* & + b_mtem(6,ja,je) )))) + + return + end function fnlog_gamz +!---------------------------------------------------------- + + + + +!---------------------------------------------------------- + real(kind=8) function mean_molecular_speed(t, mw) ! in cm/s +! implicit none +! subr. arguments + real(kind=8) t, mw ! t(k) + + mean_molecular_speed = 1.455e4 * sqrt(t/mw) + + return + end function mean_molecular_speed +!---------------------------------------------------------- + + + + +!---------------------------------------------------------- + real(kind=8) function gas_diffusivity(t, p, mw, vm) ! in cm^2/s +! implicit none +! subr. arguments + real(kind=8) mw, vm, t, p ! t(k), p(atm) + + + gas_diffusivity = (1.0e-3 * t**1.75 * sqrt(1./mw + 0.035))/ & + (p * (vm**0.333333 + 2.7189)**2) + + + return + end function gas_diffusivity +!---------------------------------------------------------- + + + + +!---------------------------------------------------------- + real(kind=8) function fuchs_sutugin(rkn,a) +! implicit none +! subr. arguments + real(kind=8) rkn, a +! local variables + real(kind=8) rnum, denom + + + rnum = 0.75*a*(1. + rkn) + denom = rkn**2 + rkn + 0.283*rkn*a + 0.75*a + fuchs_sutugin = rnum/denom + + return + end function fuchs_sutugin +!---------------------------------------------------------- + + + + + +!---------------------------------------------------------- +! solution to x^3 + px^2 + qx + r = 0 +! + real(kind=8) function cubic( p, q, r ) +! implicit none +! subr arguments + real(kind=8), intent(in) :: p, q, r +! local variables + real(kind=8) a, b, d, m, n, third, y + real(kind=8) k, phi, thesign, x(3), duma + integer icase, kk + + third = 1.d0/3.d0 + + a = (1.d0/3.d0)*((3.d0*q) - (p*p)) + b = (1.d0/27.d0)*((2.d0*p*p*p) - (9.d0*p*q) + (27.d0*r)) + + d = ( ((a*a*a)/27.d0) + ((b*b)/4.d0) ) + + if(d .gt. 0.)then ! => 1 real and 2 complex roots + icase = 1 + elseif(d .eq. 0.)then ! => 3 real roots, atleast 2 identical + icase = 2 + else ! d < 0 => 3 distinct real roots + icase = 3 + endif + + + goto (1,2,3), icase + +! case 1: d > 0 +1 thesign = 1. + if(b .gt. 0.)then + b = -b + thesign = -1. + endif + + m = thesign*((-b/2.d0) + (sqrt(d)))**(third) + n = thesign*((-b/2.d0) - (sqrt(d)))**(third) + + cubic = real( (m) + (n) - (p/3.d0) ) + return + +! case 2: d = 0 +2 thesign = 1. + if(b .gt. 0.)then + b = -b + thesign = -1. + endif + + m = thesign*(-b/2.d0)**third + n = m + + x(1) = real( (m) + (n) - (p/3.d0) ) + x(2) = real( (-m/2.d0) + (-n/2.d0) - (p/3.d0) ) + x(2) = real( (-m/2.d0) + (-n/2.d0) - (p/3.d0) ) + + cubic = 0. + do kk = 1, 3 + if(x(kk).gt.cubic) cubic = x(kk) + enddo + return + +! case 3: d < 0 +3 if(b.gt.0.)then + thesign = -1. + elseif(b.lt.0.)then + thesign = 1. + endif + +! rce 18-nov-2004 -- make sure that acos argument is between +/-1.0 +! phi = acos(thesign*sqrt( (b*b/4.d0)/(-a*a*a/27.d0) )) ! radians + duma = thesign*sqrt( (b*b/4.d0)/(-a*a*a/27.d0) ) + duma = min( duma, +1.0D0 ) + duma = max( duma, -1.0D0 ) + phi = acos( duma ) ! radians + + + cubic = 0. + do kk = 1, 3 + k = kk-1 + y = 2.*sqrt(-a/3.)*cos(phi + 120.*k*0.017453293) + x(kk) = real((y) - (p/3.d0)) + if(x(kk).gt.cubic) cubic = x(kk) + enddo + return + + end function cubic +!---------------------------------------------------------- + + + + +!---------------------------------------------------------- + real(kind=8) function quadratic(a,b,c) +! implicit none +! subr. arguments + real(kind=8) a, b, c +! local variables + real(kind=8) x, dum, quad1, quad2 + + + if(b .ne. 0.0)then + x = 4.*(a/b)*(c/b) + else + x = 1.e+6 + endif + + if(abs(x) .lt. 1.e-6)then + dum = (0.5*x) + & + (0.125*x**2) + & + (0.0625*x**3) + + quadratic = (-0.5*b/a)*dum + + if(quadratic .lt. 0.)then + quadratic = -b/a - quadratic + endif + + else + quad1 = (-b+sqrt(b*b-4.*a*c))/(2.*a) + quad2 = (-b-sqrt(b*b-4.*a*c))/(2.*a) + + quadratic = max(quad1, quad2) + endif + + return + end function quadratic +!---------------------------------------------------------- + + + +!---------------------------------------------------------- +! currently not used + +! two roots of a quadratic equation + + subroutine quadratix(a,b,c, qx1,qx2) +! implicit none +! subr. arguments + real(kind=8) a, b, c, qx1, qx2 +! local variables + real(kind=8) x, dum + + + if(b .ne. 0.0)then + x = 4.*(a/b)*(c/b) + else + x = 1.e+6 + endif + + if(abs(x) .lt. 1.e-6)then + dum = (0.5*x) + & + (0.125*x**2) + & + (0.0625*x**3) + + qx1 = (-0.5*b/a)*dum + qx2 = -b/a - qx1 + + else + + qx1 = (-b+sqrt(b*b - 4.*a*c))/(2.*a) + qx2 = (-b-sqrt(b*b - 4.*a*c))/(2.*a) + + endif + + return + end subroutine quadratix + + +!===================================================================== + + + + + + + + + + + + + + + + + +!*********************************************************************** +! computes aerosol optical properties +! +! author: rahul a. zaveri +! update: jan 2005 +!----------------------------------------------------------------------- + subroutine aerosol_optical_properties(iclm, jclm, nz, refindx, & + radius_wet, number_bin) +! changed to use rsub instead of rclm 7-8-04 egc + use module_data_mosaic_asect + use module_data_mosaic_other + use module_state_description, only: param_first_scalar + +! implicit none + +! subr arguments + integer, intent(in ) :: iclm, jclm, nz + real, dimension (1:nbin_a_maxd, 1:kmaxd), intent(inout ) :: & + number_bin, radius_wet + complex, dimension (1:nbin_a_maxd, 1:kmaxd), intent(inout ) :: & + refindx + +! local variables + integer iaer, ibin, iphase, isize, itype, je, k, l, m + integer ilaporte, jlaporte + integer p1st + real(kind=8) xt + + +! if a species index is less than this value, then the species is not defined + p1st = param_first_scalar + +! fix number of subareas at 1 + nsubareas = 1 + + lunerr_aer = lunerr + ncorecnt_aer = ncorecnt + + call load_mosaic_parameters + + iclm_aer = iclm + jclm_aer = jclm + + do 110 m = 1, nsubareas + do 100 k = 1, nz + + mclm_aer = m + kclm_aer = k + + cair_mol_m3 = cairclm(k)*1.e6 ! cairclm(k) is in mol/cc + cair_mol_cc = cairclm(k) + + conv1a = cair_mol_m3*1.e9 ! converts q/mol(air) to nq/m^3 (q = mol or g) + conv1b = 1./conv1a ! converts nq/m^3 to q/mol(air) + conv2a = cair_mol_m3*18.*1.e-3 ! converts mol(h2o)/mol(air) to kg(h2o)/m^3(air) + conv2b = 1./conv2a ! converts kg(h2o)/m^3(air) to mol(h2o)/mol(air) + + +! initialize to zero + do ibin = 1, nbin_a + do iaer = 1, naer + aer(iaer,jtotal,ibin) = 0.0 + enddo + + do je = 1, nelectrolyte + electrolyte(je,jtotal,ibin) = 0.0 + enddo + + jaerosolstate(ibin) = -1 ! initialize to default value + + enddo + + +! rce 18-nov-2004 - map (transfer) aerosol mass/water/number from rsub +! to mosaic arrays (aer, watr_a, num_a) +! always map so4 and number, +! but only map other species when (lptr_xxx .ge. p1st) +! (the mapping is identical to that done in mapgasaerspecies) + + iphase = ai_phase + ibin = 0 + do 90 itype = 1, ntype_aer + do 90 isize = 1, nsize_aer(itype) + ibin = ibin + 1 + +! aer array units are nmol/(m^3 air) + l = lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iso4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iso4_a,jtotal,ibin)=0.0 + end if + + l = lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ino3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ino3_a,jtotal,ibin)=0.0 + end if + + l = lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(icl_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(icl_a,jtotal,ibin)=0.0 + end if + + l = lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(inh4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(inh4_a,jtotal,ibin)=0.0 + end if + + l = lptr_oc_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ioc_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ioc_a,jtotal,ibin)=0.0 + end if + + l = lptr_bc_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibc_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibc_a,jtotal,ibin)=0.0 + end if + + l = lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ina_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ina_a,jtotal,ibin)=0.0 + end if + + l = lptr_oin_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ioin_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ioin_a,jtotal,ibin)=0.0 + end if + + l = lptr_msa_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(imsa_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(imsa_a,jtotal,ibin)=0.0 + end if + + l = lptr_co3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ico3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ico3_a,jtotal,ibin)=0.0 + end if + + l = lptr_ca_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ica_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ica_a,jtotal,ibin)=0.0 + end if + +! soa aerosol-phase species -- currently deactivated +! l = lptr_aro1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iaro1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iaro1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_aro2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iaro2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iaro2_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_alk1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ialk1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ialk1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_ole1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iole1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iole1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_api1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iapi1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iapi1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_api2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(iapi2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(iapi2_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_lim1_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ilim1_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ilim1_a,jtotal,ibin)=0.0 +! end if + +! l = lptr_lim2_aer(isize,itype,iphase) +! if (l .ge. p1st) then +! aer(ilim2_a,jtotal,ibin)=rsub(l,k,m)*conv1a +! else + aer(ilim2_a,jtotal,ibin)=0.0 +! end if + +! water_a and water_a_hyst units are kg/(m^3 air) + l = hyswptr_aer(isize,itype) + if (l .ge. p1st) then + water_a_hyst(ibin)=rsub(l,k,m)*conv2a + else + water_a_hyst(ibin)=0.0 + end if + +! water_a units are kg/(m^3 air) + l = waterptr_aer(isize,itype) + if (l .ge. p1st) then + water_a(ibin)=rsub(l,k,m)*conv2a + else + water_a(ibin)=0.0 + end if + +! num_a units are #/(cm^3 air) + l = numptr_aer(isize,itype,iphase) + num_a(ibin) = rsub(l,k,m)*cair_mol_cc + + + call check_aerosol_mass(ibin) + if(jaerosolstate(ibin) .eq. no_aerosol)goto 90 ! ignore this bin + call conform_electrolytes(jtotal,ibin,xt) ! conforms aer(jtotal) to a valid aerosol + call check_aerosol_mass(ibin) ! check mass again after conform_electrolytes + if(jaerosolstate(ibin) .eq. no_aerosol)goto 90 ! ignore this bin + call conform_aerosol_number(ibin) ! adjusts number conc so that it conforms with bin mass and diameter + call calc_dry_n_wet_aerosol_props(ibin) ! calc dp_wet, ref index + + + + refindx(ibin,k) = ri_avg_a(ibin) ! vol avg ref index + radius_wet(ibin,k) = dp_wet_a(ibin)/2.0 ! wet radius (cm) + number_bin(ibin,k) = num_a(ibin) ! #/cc air + +90 continue + +100 continue ! k levels +110 continue ! m subareas + + + return + end subroutine aerosol_optical_properties + + + + + + + + + + +!*********************************************************************** +! save aerosol drymass and drydens before aerosol mass transfer is +! calculated this subr is called from within subr mosaic_dynamic_solver, +! after the initial calls to check_aerosol_mass, conform_electrolytes, +! conform_aerosol_number, and aerosol_phase_state, but before the mass +! transfer is calculated +! +! author: richard c. easter +!----------------------------------------------------------------------- + subroutine save_pregrow_props + + use module_data_mosaic_asect + use module_data_mosaic_other + +! implicit none +! include 'v33com' +! include 'v33com9a' +! include 'v33com9b' +! include 'mosaic.h' + +! subr arguments (none) + +! local variables + integer ibin, isize, itype + + +! air conc in mol/cm^3 + cair_mol_cc = cairclm(kclm_aer) + +! compute then save drymass and drydens for each bin + do ibin = 1, nbin_a + + call calc_dry_n_wet_aerosol_props( ibin ) + + call isize_itype_from_ibin( ibin, isize, itype ) + drymass_pregrow(isize,itype) = mass_dry_a(ibin)/cair_mol_cc ! g/mol(air) + if(jaerosolstate(ibin) .eq. no_aerosol) then + drydens_pregrow(isize,itype) = -1. + else + drydens_pregrow(isize,itype) = dens_dry_a(ibin) ! g/cc + end if + + end do + + return + end subroutine save_pregrow_props + + + + + + + +!*********************************************************************** +! special output +! +! author: richard c. easter +!----------------------------------------------------------------------- + subroutine specialoutaa( iclm, jclm, kclm, msub, fromwhere ) + +! implicit none + + integer iclm, jclm, kclm, msub + character*(*) fromwhere + + return + end subroutine specialoutaa + + + + +!*********************************************************************** +! box model test output +! +! author: richard c. easter +!----------------------------------------------------------------------- + subroutine aerchem_boxtest_output( & + iflag, iclm, jclm, kclm, msub, dtchem ) + + use module_data_mosaic_asect + use module_data_mosaic_other +! implicit none + +! include 'v33com' +! include 'v33com2' +! include 'v33com9a' + + integer iflag, iclm, jclm, kclm, msub + real(kind=8) dtchem + +! local variables + integer lun + parameter (lun=83) + integer, save :: ientryno = -13579 + integer icomp, iphase, isize, itype, k, l, m, n + + real(kind=8) dtchem_sv1 + save dtchem_sv1 + real(kind=8) rsub_sv1(l2maxd,kmaxd,nsubareamaxd) + + +! bypass unless maerchem_boxtest_output > 0 + if (maerchem_boxtest_output .le. 0) return + + + +! +! *** currently this only works for ntype_aer = 1 +! + itype = 1 + iphase = ai_phase + +! do initial output + if (ientryno .ne. -13579) goto 1000 + + ientryno = +1 + call peg_message( lunerr, '***' ) + call peg_message( lunerr, '*** doing initial aerchem_boxtest_output' ) + call peg_message( lunerr, '***' ) + + write(lun) ltot, ltot2, itot, jtot, ktot + write(lun) (name(l), l=1,ltot2) + + write(lun) maerocoag, maerchem, maeroptical + write(lun) msectional, maerosolincw + + write(lun) nsize_aer(itype), ntot_mastercomp_aer + + do icomp = 1, ntot_mastercomp_aer + write(lun) & + name_mastercomp_aer(icomp) + write(lun) & + dens_mastercomp_aer(icomp), mw_mastercomp_aer(icomp) + end do + + do isize = 1, nsize_aer(itype) + write(lun) & + ncomp_plustracer_aer(itype), & + ncomp_aer(itype), & + waterptr_aer(isize,itype), & + numptr_aer(isize,itype,iphase), & + mprognum_aer(isize,itype,iphase) + write(lun) & + ( mastercompptr_aer(l,itype), & + massptr_aer(l,isize,itype,iphase), & + l=1,ncomp_plustracer_aer(itype) ) + write(lun) & + volumcen_sect(isize,itype), & + volumlo_sect(isize,itype), & + volumhi_sect(isize,itype), & + dcen_sect(isize,itype), & + dlo_sect(isize,itype), & + dhi_sect(isize,itype) + write(lun) & + lptr_so4_aer(isize,itype,iphase), & + lptr_msa_aer(isize,itype,iphase), & + lptr_no3_aer(isize,itype,iphase), & + lptr_cl_aer(isize,itype,iphase), & + lptr_co3_aer(isize,itype,iphase), & + lptr_nh4_aer(isize,itype,iphase), & + lptr_na_aer(isize,itype,iphase), & + lptr_ca_aer(isize,itype,iphase), & + lptr_oin_aer(isize,itype,iphase), & + lptr_oc_aer(isize,itype,iphase), & + lptr_bc_aer(isize,itype,iphase), & + hyswptr_aer(isize,itype) + end do + +! +! test iflag +! +1000 continue + if (iflag .eq. 1) goto 1010 + if (iflag .eq. 2) goto 2000 + if (iflag .eq. 3) goto 3000 + return + +! +! iflag=1 -- save initial values +! +1010 continue + dtchem_sv1 = dtchem + do m = 1, nsubareas + do k = 1, ktot + do l = 1, ltot2 + rsub_sv1(l,k,m) = rsub(l,k,m) + end do + end do + end do + + return + +! +! iflag=2 -- save intermediate values before doing move_sections +! (this is deactivated for now) +! +2000 continue + return + + +! +! iflag=3 -- do output +! +3000 continue + do m = 1, nsubareas + do k = 1, ktot + + write(lun) iymdcur, ihmscur, iclm, jclm, k, m, nsubareas + write(lun) t, dtchem_sv1, cairclm(k), relhumclm(k), & + ptotclm(k), afracsubarea(k,m) + + write(lun) (rsub_sv1(l,k,m), rsub(l,k,m), l=1,ltot2) + + end do + end do + + + return + end subroutine aerchem_boxtest_output + + + +!*********************************************************************** +! 'debugging' output when mosaic encounters 'fatal error' situation +! +! author: richard c. easter +!----------------------------------------------------------------------- + subroutine mosaic_aerchem_error_dump( istop, ibin, luna, msga ) +! +! dumps current column information when a fatal computational error occurs +! when istop>0, the simulation is halted +! + use module_data_mosaic_asect + use module_data_mosaic_other +! implicit none + +! arguments + integer istop, ibin, luna + character*(*) msga + +! local variables + integer icomp, iphase, isize, itype, k, l, lunb, m, n + real(kind=8) dtchem_sv1 + + +! +! *** currently this only works for ntype_aer = 1 +! + itype = 1 + + + lunb = luna + if (lunb .le. 0) lunb = 6 + +9000 format( a ) +9010 format( 7i10 ) +9020 format( 3(1pe19.11) ) + + write(lunb,9000) + write(lunb,9000) 'begin mosaic_aerchem_error_dump - msga =' + write(lunb,9000) msga + write(lunb,9000) 'i, j, k, msub,ibin =' + write(lunb,9010) iclm_aer, jclm_aer, kclm_aer, mclm_aer, ibin + + write(lunb,9010) ltot, ltot2, itot, jtot, ktot + write(lunb,9000) (name(l), l=1,ltot2) + + write(lunb,9010) maerocoag, maerchem, maeroptical + write(lunb,9010) msectional, maerosolincw + + write(lunb,9010) nsize_aer(itype), ntot_mastercomp_aer + + do icomp = 1, ntot_mastercomp_aer + write(lunb,9000) & + name_mastercomp_aer(icomp) + write(lunb,9020) & + dens_mastercomp_aer(icomp), mw_mastercomp_aer(icomp) + end do + + do isize = 1, nsize_aer(itype) + write(lunb,9010) & + ncomp_plustracer_aer(itype), & + ncomp_aer(itype), & + waterptr_aer(isize,itype), & + numptr_aer(isize,itype,iphase), & + mprognum_aer(isize,itype,iphase) + write(lunb,9010) & + ( mastercompptr_aer(l,itype), & + massptr_aer(l,isize,itype,iphase), & + l=1,ncomp_plustracer_aer(itype) ) + write(lunb,9020) & + volumcen_sect(isize,itype), & + volumlo_sect(isize,itype), & + volumhi_sect(isize,itype), & + dcen_sect(isize,itype), & + dlo_sect(isize,itype), & + dhi_sect(isize,itype) + write(lunb,9010) & + lptr_so4_aer(isize,itype,iphase), & + lptr_msa_aer(isize,itype,iphase), & + lptr_no3_aer(isize,itype,iphase), & + lptr_cl_aer(isize,itype,iphase), & + lptr_co3_aer(isize,itype,iphase), & + lptr_nh4_aer(isize,itype,iphase), & + lptr_na_aer(isize,itype,iphase), & + lptr_ca_aer(isize,itype,iphase), & + lptr_oin_aer(isize,itype,iphase), & + lptr_oc_aer(isize,itype,iphase), & + lptr_bc_aer(isize,itype,iphase), & + hyswptr_aer(isize,itype) + end do + + + dtchem_sv1 = -1.0 + do m = 1, nsubareas + do k = 1, ktot + + write(lunb,9010) iymdcur, ihmscur, iclm_aer, jclm_aer, k, m, nsubareas + write(lunb,9020) t, dtchem_sv1, cairclm(k), relhumclm(k), & + ptotclm(k), afracsubarea(k,m) + + write(lunb,9020) (rsub(l,k,m), l=1,ltot2) + + end do + end do + + write(lunb,9000) 'end mosaic_aerchem_error_dump' + + + if (istop .gt. 0) call peg_error_fatal( luna, msga ) + + return + end subroutine mosaic_aerchem_error_dump +!----------------------------------------------------------------------- + + end module module_mosaic_therm diff --git a/wrfv2_fire/chem/module_mosaic_wetscav.F b/wrfv2_fire/chem/module_mosaic_wetscav.F new file mode 100644 index 00000000..c7760b9b --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_wetscav.F @@ -0,0 +1,1524 @@ +MODULE module_mosaic_wetscav + +CONTAINS + +!=========================================================================== +!=========================================================================== + subroutine wetscav_cbmz_mosaic (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + use module_data_mosaic_asect + +!---------------------------------------------------------------------- + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + + call wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end subroutine wetscav_cbmz_mosaic + + + +!=========================================================================== +!=========================================================================== + subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_model_constants + USE module_model_constants, only: g,rhowater, mwdry + USE module_dep_simple, only: is_aerosol + + IMPLICIT NONE + +!====================================================================== + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! input from meteorology +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + integer, intent(in) :: maxd_atype + integer, intent(in) :: maxd_asize + integer, intent(in) :: maxd_acomp + integer, intent(in) :: maxd_aphase + integer, intent(in) :: ai_phase, cw_phase + integer, intent(in) :: ntype_aer + integer, intent(in) :: nsize_aer( maxd_atype ), & ! number of size bins + ncomp_aer( maxd_atype ), & ! number of chemical components + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase), & ! index for mixing ratio + waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ) ! index for the number mixing ratio + real, intent(in) :: dens_aer( maxd_acomp, maxd_atype ), & ! material density (g/cm3) + dens_water_aer ! water density (g/m3) + + real, intent(in) :: dlndg_nimptblgrow + integer, intent(in) :: nimptblgrow_mind, nimptblgrow_maxd + real, intent(in) :: scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype), & + scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + +! +! LOCAL VAR +! + integer :: i,j,k,l,m,n + integer :: lmasscw,lnumcw + real scale + logical :: isprx(ims:ime,kms:kme,jms:jme) + + real :: pdel(ims:ime,kms:kme,jms:jme) + real :: delpf(kms:kme) + real :: delpfhalf + real :: dump + real :: fac_pwght_ls(kms:kme) ! + real :: fapincld, fapoutcld, faptot + real :: fapmin_ls ! + real :: fapx(ims:ime,kms:kme,jms:jme) + real :: fracscav + real :: pf_above, pf_below, pdel_fac + real :: pf_ls(kms:kme) + real :: pfoutcld + real :: pfsmall_ls ! l-s precip fluxes (kg/m2/s) smaller than this + ! are ignored (treated as zero) + real :: pfsmall_min + real :: pfx(ims:ime,kms:kme,jms:jme) + real :: pfx_inrain(ims:ime,kms:kme,jms:jme) + real :: sumfa, sumpf, sumpffa + REAL :: dqdt( ims:ime, kms:kme, jms:jme, num_chem ) + logical dotend(num_chem) + + dotend(:) = .false. + dqdt(:,:,:,:) = 0.0 + qsrflx(:,:,:) = 0.0 + + +! scavenging cloud-phase aerosol assuming precip falls to surface + do 100 j=jts,jte + do k=kts,kte-1 + pdel(:,k,j)=p8w(:,k,j)-p8w(:,k+1,j) + end do + pdel(:,kte,j)=pdel(:,kte-1,j) + do 100 k=kts,kte + do 100 i=its,ite + scale=max((1.-dtstepc*qlsink(i,k,j)),0.) + if(scale.gt.1.)then + print *,'qlsink,scale=',qlsink(i,k,j),scale,' i,k,j=',i,k,j + scale=1. + endif + if (qlsink(i,k,j) > 0.0) then + pdel_fac = pdel(i,k,j)/(g*mwdry) + do n=1,ntype_aer + do m=1,nsize_aer(n) + do l=1,ncomp_aer(n) + lmasscw=massptr_aer(l,m,n,cw_phase) + qsrflx(i,j,lmasscw)=qsrflx(i,j,lmasscw)+chem(i,k,j,lmasscw)*(scale-1.)*pdel_fac + chem(i,k,j,lmasscw)=chem(i,k,j,lmasscw)*scale + end do ! comp + lnumcw=numptr_aer(m,n,cw_phase) + qsrflx(i,j,lnumcw)=qsrflx(i,j,lnumcw)+chem(i,k,j,lnumcw)*(scale-1.)*pdel_fac + chem(i,k,j,lnumcw)=chem(i,k,j,lnumcw)*scale + end do ! size + end do ! type + end if ! qlsink > 0 + 100 continue + + +! scavenging of gases in cloud-water + do 290 l = param_first_scalar, min( num_chem, numgas_aqfrac ) + if ( is_aerosol(l) ) goto 290 + do 270 j = jts,jte + do 270 k = kts,kte + do 270 i = its,ite + fracscav = dtstepc*qlsink(i,k,j)*gas_aqfrac(i,k,j,l) + if (fracscav > 0.0) then + fracscav = max( 0.0, min( 1.0, fracscav ) ) + scale = 1.0 - fracscav + pdel_fac = pdel(i,k,j)/(g*mwdry) + qsrflx(i,j,l) = qsrflx(i,j,l)+chem(i,k,j,l)*(scale-1.)*pdel_fac + chem(i,k,j,l) = chem(i,k,j,l)*scale + end if +270 continue +290 continue + + +! below-cloud scavenging + +! precip rates -- 1.0 kgwtr/m2/s = 1.0e-3 m3wtr/m2/s = 1.0e-3 m/s +! 7.06e-5 kg/m2/s = 7.06e-8 m/s = 0.01 inch/h +! 3.17e-5 kg/m2/s = 3.17e-8 m/s = 1 m/y = global annual average +! 1.00e-7 kg/m2/s = 1.00e-10 m/s is a very small precip rate! + + fapmin_ls = 1.0e-3 + pfsmall_ls = 1.0e-7 + + isprx(:,:,:) = .false. + pfx(:,:,:) = 0.0 + pfx_inrain(:,:,:) = 0.0 + fapx(:,:,:) = 0.0 + + + do 5900 j=jts,jte + do 5900 i=its,ite + +!---------------------------------------------------------------------- +! compute l-s precip rates +! +! pf_ls(k) = precip flux at center of level + pf_below = 0.0 + do k = kte,kts,-1 + pf_above = pf_below + pf_below = precr(i,k,j) + preci(i,k,j) + precs(i,k,j) + precg(i,k,j) ! total precip rate + if (pf_below < pfsmall_ls) pf_below = 0.0 + delpf(k) = pf_below - pf_above + pf_ls(k) = 0.5*(pf_below + pf_above) + if (pf_ls(k) < pfsmall_ls) pf_ls(k) = 0.0 + end do + +! compute fac_pwght_ls which is an average of cloud fractional area in and +! above the current level, weighted by precip production in each level +! basically this reflect the cloud area at levels where precip is produced + do k = kte, kts,-1 + if (k == kte) then +! compute change from (k-1/k) interface to level k center + delpfhalf = 0.5*delpf(k) + if (delpfhalf > 0.0) then + fac_pwght_ls(k) = max( cldfra(i,k,j), fapmin_ls ) + sumpffa = delpfhalf * fac_pwght_ls(k) + sumpf = delpfhalf + else + fac_pwght_ls(k) = fapmin_ls + sumpffa = 0.0 + sumpf = 0.0 + end if + else +! compute change from level (k+1) center to (k+1/k) interface + delpfhalf = 0.5*delpf(k+1) + if (delpfhalf > 0.0) then + sumpffa = sumpffa + delpfhalf*max( cldfra(i,k+1,j), fapmin_ls ) + sumpf = sumpf + delpfhalf + fac_pwght_ls(k) = max( (sumpffa/sumpf), fapmin_ls ) + else + fac_pwght_ls(k) = fac_pwght_ls(k+1) + sumpffa = max( (sumpffa + delpfhalf*fac_pwght_ls(k)), 0.0 ) + sumpf = max( (sumpf + delpfhalf), 0.0 ) + end if +! compute change from (k-1/k) interface to level k center + delpfhalf = 0.5*delpf(k) + if (delpfhalf > 0.0) then + sumpffa = sumpffa + delpfhalf*max( cldfra(i,k,j), fapmin_ls ) + sumpf = sumpf + delpfhalf + fac_pwght_ls(k) = max( (sumpffa/sumpf), fapmin_ls ) + else +! here, fac_pwght_ls(k) is unchanged from its value computed just above + sumpffa = max( (sumpffa + delpfhalf*fac_pwght_ls(k)), 0.0 ) + sumpf = max( (sumpf + delpfhalf), 0.0 ) + end if + end if + end do + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! do the scavenging +! +!---------------------------------------------------------------------- +! loop through levels +! + do 4900 k = kte, kts,-1 + + +!---------------------------------------------------------------------- +! for each cloud/precip type (ls, dp, sh), compute +! fapx = fractional area with precip +! pfx = precip flux based on entire grid-cell area (kg/m2/s) +! pfx_inrain = precip flux within the precip fractional area (kg/m2/s) +! + sumpf = 0.0 + sumfa = 0.0 + +! l-s cloud +! assume faptot = total (in + out-of-cloud) precip area +! = 0.5*fac_pwght_ls(k) +! then fapincld = in-cloud precip area +! = min( faptot, cloud area ) +! fapoutcld = out-of-cloud precip area +! = max( 0.0, faptot-fapincld ) +! also pfoutcld = out-of-cloud precip flux = fraction of total precip flux +! = pf_ls(k)*(fapoutcld/faptot) + if (pf_ls(k) > 0.0) then + faptot= 0.5*fac_pwght_ls(k) + fapincld = min( faptot, cldfra(i,k,j) ) + fapoutcld = max( 0.0, faptot-fapincld ) + pfoutcld = pf_ls(k)*(fapoutcld/faptot) + if (pfoutcld >= pfsmall_ls) then + isprx(i,k,j) = .true. + pfx(i,k,j) = pfoutcld + fapx(i,k,j) = fapoutcld + pfx_inrain(i,k,j) = pf_ls(k)/faptot + sumpf = sumpf + pfx(i,k,j) + sumfa = sumfa + fapx(i,k,j) + end if + end if + +4900 continue ! "k = 1, pver" + +5900 continue ! "i = 1, ncol" + + + call aerimpactscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte, num_chem, & + ntype_aer, nsize_aer, ncomp_aer, massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, & + nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + dtstepc, t_phy, p_phy, pdel, chem, & + isprx, fapx, pfx, pfx_inrain, & + dqdt, dotend, qsrflx ) + + call gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte, num_chem, & + dtstepc, t_phy, p_phy, pdel, chem, & + isprx, fapx, pfx, pfx_inrain, & + dqdt, dotend, qsrflx ) + +! update chem + + do n=1,num_chem + if(dotend(n))then + do 6000 j=jts,jte + do 6000 k=kts,kte + do 6000 i=its,ite + chem(i,k,j,n) = chem(i,k,j,n) + dqdt(i,k,j,n)*dtstepc + 6000 continue + end if + end do + + end subroutine wetscav + + + +!=========================================================================== +!=========================================================================== +subroutine aerimpactscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_chem, & + ntype_aer, nsize_aer, ncomp_aer, massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + deltat, t, pmid, pdel, chem, & + isprx, fapx, pfx, pfx_inrain, & + dqdt, dotend, qsrflx ) + + +!----------------------------------------------------------------------- +! +! Purpose: +! Does below cloud scavenging of aerosols through impaction-interception +! +! Removal rates for aersol number, (surface - still to do), and volume +! are computed for each mode using precalculated lookup tables. +! The tables account for variables in wet-dgnum, wet density, +! air temperature, and air pressure. +! +! Authors: R. Easter +! +!----------------------------------------------------------------------- + USE module_model_constants, only: g,rhowater, mwdry + + implicit none + +!----------------------------------------------------------------------- +! +! Input arguments +! +! abbreviations & acronyms +! TMR = tracer mixing ratio +! l-s = large scale +! + integer, intent(in) :: num_chem ! number of chemical species + integer, intent(in) :: ims,ime ! column dimension + integer, intent(in) :: kms,kme ! level dimension + integer, intent(in) :: jms,jme ! column dimension + integer, intent(in) :: its,ite ! column identifier + integer, intent(in) :: kts,kte ! level identifier + integer, intent(in) :: jts,jte ! column identifier + real, intent(in) :: deltat ! model timestep + + real, intent(in) :: t(ims:ime,kts:kte,jms:jme) ! temperature + real, intent(in) :: pmid(ims:ime,kts:kte,jms:jme) ! pressure at model levels + real, intent(in) :: pdel(ims:ime,kts:kte,jms:jme) ! pressure thickness of levels + real, intent(in) :: chem(ims:ime,kts:kte,jms:jme,num_chem) ! chem array + + logical, intent(in) :: isprx(ims:ime,kts:kte,jms:jme) ! true if precip at i,k + real, intent(in) :: fapx(ims:ime,kts:kte,jms:jme) ! frac. area for precip + real, intent(in) :: pfx(ims:ime,kts:kte,jms:jme) ! grid-avg precip + ! flux (kg/m2/s) + real, intent(in) :: pfx_inrain(ims:ime,kts:kte,jms:jme) ! in-rain-area precip flux (kg/m2/s) + + real, intent(inout) :: dqdt(ims:ime,kts:kte,jms:jme,num_chem) ! TMR tendency array + logical, intent(inout) :: dotend(num_chem) ! flag for doing scav + real, intent(inout) :: qsrflx(ims:ime,jms:jme,num_chem) ! column tracer tendencies + integer, intent(in) :: maxd_atype + integer, intent(in) :: maxd_asize + integer, intent(in) :: maxd_acomp + integer, intent(in) :: maxd_aphase + integer, intent(in) :: ai_phase + integer, intent(in) :: ntype_aer + integer, intent(in) :: nsize_aer( maxd_atype ), & ! number of size bins + ncomp_aer( maxd_atype ), & ! number of chemical components + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase), & ! index for mixing ratio + waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ) ! index for the number mixing ratio + real, intent(in) :: dens_aer( maxd_acomp, maxd_atype ), & ! material density (g/cm3) + dens_water_aer ! water density (g/m3) + + real, intent(in) :: dlndg_nimptblgrow + integer, intent(in) :: nimptblgrow_mind, nimptblgrow_maxd + real, intent(in) :: scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype), & + scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + +!--------------------------Local Variables------------------------------ + + integer :: i,j ! Work index + integer :: jgrow, jp ! Work index + integer :: k ! Work index + integer :: l, ll, m, n ! Work index + + logical :: ispr_anywhere + + real :: dumfhi, dumflo + real :: dumimpactamt0, dumimpactamt3, dumimpactamtsum + real :: dumimpactratea0, dumimpactratea3 + real :: dumimpactrateb0, dumimpactrateb3 + real :: dumdgratio, dumrate, dumwetdens + real :: dumlogdens, dumlogptot, dumlogtemp + real :: dumscavratenum, dumscavratevol + real :: pdel_fac + real :: pf_to_prmmh + real :: scavimptbl1, scavimptbl2, scavimptbl3, scavimptbl4 + real :: xgrow + real third + data third/0.333333/ + real vaerosol, vaerosol_wet + real dry_mass + +!----------------------------------------------------------------------- +! + +! if (ncol .ne. -987654321) return + +! precip rates -- 1.0 kgwtr/m2/s = 1.0e-3 m3wtr/m2/s = 1.0e-3 m/s +! = 1.0 mm/s = 3600 mm/h + + ispr_anywhere = .false. + + do 5900 i = its,ite + do 5900 j = jts,jte + + do 4900 k = kte,kts,-1 + +! skip this level if no precip + if ( isprx(i,k,j) ) then + ispr_anywhere = .true. + else + goto 4900 + end if + + + dumlogtemp = log( t(i,k,j) ) +! dumlogptot = log( pressure in dynes/cm2 ) + dumlogptot = log( 10.0*pmid(i,k,j) ) + +! compute removal amounts for each aerosol mode + do 3900 n=1,ntype_aer + do 3900 m=1,nsize_aer(n) + vaerosol=0. + dry_mass=0 + do l=1,ncomp_aer(n) + dry_mass=dry_mass+chem(i,k,j,massptr_aer(l,m,n,ai_phase)) + vaerosol=vaerosol+chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + end do +! The vaerosol units here (cm3/Gg-air) are unusual. vaerosol & vaerosol_wet +! are temporary variables used only to compute density, so it's no problem. + +! If no aerosol is present at this size and type, there is nothing +! to scavenge so go onto the next size bin. wig, 25-Oct-2005 + if( vaerosol < 1e-20 ) goto 3900 + +! wet volume + vaerosol_wet=vaerosol+chem(i,k,j,waterptr_aer(m,n))/dens_water_aer +! dumwetdens = wet aerosol density in g/cm3 + dumwetdens = (dry_mass+chem(i,k,j,waterptr_aer(m,n)))/vaerosol_wet + dumlogdens = log( dumwetdens ) + dumimpactamt3 = 0 + dumimpactamt0 = 0 +! +! compute impaction scavenging removal amount for volume +! +! interpolate table values using log of (actual-wet-size)/(base-dry-size) + dumdgratio = (vaerosol_wet/vaerosol)**third + + if ((dumdgratio .ge. 0.99) .and. (dumdgratio .le. 1.01)) then + scavimptbl1 = scavimptblvol(1,0,m,n) + scavimptbl2 = scavimptblvol(2,0,m,n) + scavimptbl3 = scavimptblvol(3,0,m,n) + scavimptbl4 = scavimptblvol(4,0,m,n) + + else + xgrow = log( dumdgratio ) / dlndg_nimptblgrow + jgrow = int( xgrow ) + if (xgrow .lt. 0.) jgrow = jgrow - 1 + if (jgrow .lt. nimptblgrow_mind) then + jgrow = nimptblgrow_mind + xgrow = jgrow + else + jgrow = min( jgrow, nimptblgrow_maxd-1 ) + end if + + dumfhi = xgrow - jgrow + dumflo = 1. - dumfhi + + scavimptbl1 = dumflo*scavimptblvol(1,jgrow,m,n) + & + dumfhi*scavimptblvol(1,jgrow+1,m,n) + + scavimptbl2 = dumflo*scavimptblvol(2,jgrow,m,n) + & + dumfhi*scavimptblvol(2,jgrow+1,m,n) + + scavimptbl3 = dumflo*scavimptblvol(3,jgrow,m,n) + & + dumfhi*scavimptblvol(3,jgrow+1,m,n) + + scavimptbl4 = dumflo*scavimptblvol(4,jgrow,m,n) + & + dumfhi*scavimptblvol(4,jgrow+1,m,n) + end if + +! apply temperature and pressure corrections + dumimpactratea3 = exp( scavimptbl1 + scavimptbl2*dumlogtemp + & + scavimptbl3*dumlogptot + scavimptbl4*dumlogdens ) + +! dumimpactratea3 = impaction scav rate (1/h) for precip = 1 mm/h +! dumimpactrateb3 = impaction scav rate (1/s) for precip = pfx_inrain +! (dumimpactratea3/3600) = impaction scav rate (1/s) for precip = 1 mm/h +! (pfx_inrain*3600) = in-rain-area precip rate (mm/h) +! dumimpactrateb3 = (dumimpactratea3/3600) * (pfx_inrain*3600) +! dumimpactamt3 = fraction of aerosol removed from entire grid cell +! in time deltat + dumimpactamtsum = 0.0 + dumimpactrateb3 = dumimpactratea3 * pfx_inrain(i,k,j) + dumimpactamt3 = (1. - exp(-deltat*dumimpactrateb3)) * fapx(i,k,j) + dumimpactamtsum = dumimpactamtsum + dumimpactamt3 + dumimpactamt3 = min( dumimpactamtsum, 1.0 ) + +! diagnostic output +! dump = 10.0*pmid(i,k) +! call calc_1_impact_rate( dgncur_awet(i,k,j,m,n), & +! sigmag_amode(n), dumwetdens, & +! t(i,k), dump, & +! dumscavratenum, dumscavratevol, lun ) +! +! dumr = -9.99e35 +! if (dumscavratevol > 1.0e-35) & +! dumr = (dumimpactratea3/dumscavratevol) - 1.0 +! write(lun,9440) nstep, lchnk, i, k, jp, & +! (dumtemp-273.16), dumpress*.001 +! write(lun,9442) 'rhowet, dgnwet, dgratio, xgrow', & +! dumwetdens, dgncur_awet(i,k,n), dumdgratio, xgrow +! write(lun,9442) 'exa&approx vol rt, relerr, amt', & +! dumscavratevol, dumimpactratea3, dumr, dumimpactamt3 +! write(lun,9442) 'pfx_inrain(1:3) ', & +! (pfx_inrain(jp,i,k), jp=1,3) +! write(lun,9442) 'fapx(1:3) ', & +! (fapx(jp,i,k), jp=1,3) +!9440 format( / 'ns,lc,i,k,jp, T(C), p(mb)', i6, 2i4, 2i3, 2f7.1 ) +!9442 format( a, 4(1pe11.3) ) +! end diagnostic output + + +! +! compute impaction scavenging removal amount to number +! + if (numptr_aer(m,n,ai_phase) .le. 0) then + dumimpactamt0 = dumimpactamt3 + goto 3700 + end if + +! interpolate table values using log of (actual-wet-size)/(base-dry-size) + if ((dumdgratio .ge. 0.99) .and. (dumdgratio .le. 1.01)) then + scavimptbl1 = scavimptblnum(1,0,m,n) + scavimptbl2 = scavimptblnum(2,0,m,n) + scavimptbl3 = scavimptblnum(3,0,m,n) + scavimptbl4 = scavimptblnum(4,0,m,n) + + else + scavimptbl1 = dumflo*scavimptblnum(1,jgrow,m,n) + & + dumfhi*scavimptblnum(1,jgrow+1,m,n) + + scavimptbl2 = dumflo*scavimptblnum(2,jgrow,m,n) + & + dumfhi*scavimptblnum(2,jgrow+1,m,n) + + scavimptbl3 = dumflo*scavimptblnum(3,jgrow,m,n) + & + dumfhi*scavimptblnum(3,jgrow+1,m,n) + + scavimptbl4 = dumflo*scavimptblnum(4,jgrow,m,n) + & + dumfhi*scavimptblnum(4,jgrow+1,m,n) + end if + +! apply temperature and pressure corrections + dumimpactratea0 = exp( scavimptbl1 + scavimptbl2*dumlogtemp + & + scavimptbl3*dumlogptot + scavimptbl4*dumlogdens ) + + dumimpactamt0 = 0.0 + dumimpactrateb0 = dumimpactratea0 * pfx_inrain(i,k,j) + dumimpactamt0 = dumimpactamt0 + & + (1. - exp( -deltat*dumimpactrateb0 )) * fapx(i,k,j) + dumimpactamt0 = min( dumimpactamt0, 1.0 ) + +! diagnostic output +! dumr = -9.99e35 +! if (dumscavratenum > 1.0e-35) & +! dumr = (dumimpactratea0/dumscavratenum) - 1.0 +! write(lun,9442) 'exa&approx num rt, relerr, amt', & +! dumscavratenum, dumimpactratea0, dumr, dumimpactamt0 +! end diagnostic output + + +3700 continue + +! +! compute tendencies +! + pdel_fac = pdel(i,k,j)/(g*mwdry) + dumrate = -dumimpactamt3/(deltat*(1.0 + 1.0e-8)) + do ll = 1, ncomp_aer(n) + l = massptr_aer(ll,m,n,ai_phase) + dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + end do + l = waterptr_aer(m,n) + if (l > 0) then + dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + end if + if (numptr_aer(m,n,ai_phase) .gt. 0) then + dumrate = -dumimpactamt0/(deltat*(1.0 + 1.0e-8)) + l = numptr_aer(m,n,ai_phase) + dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + end if + + + +3900 continue ! "n = 1, ntot_amode" + +4900 continue ! "k = 1, pver" + +5900 continue ! "i = 1, ncol" + + +! set dotend's + if ( ispr_anywhere ) then + do n=1,ntype_aer + do m=1,nsize_aer(n) + do ll = 1, ncomp_aer(n) + dotend(massptr_aer(ll,m,n,ai_phase)) = .true. + end do + if (waterptr_aer(m,n) > 0) dotend(waterptr_aer(m,n)) = .true. + if (numptr_aer(m,n,ai_phase) > 0) dotend(numptr_aer(m,n,ai_phase)) = .true. + end do + end do + end if + + + return +end subroutine aerimpactscav + + + +!=========================================================================== +!=========================================================================== + subroutine initwet(ntype_aer, nsize_aer, ncomp_aer, massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, dcen_sect, sigmag_aer, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow) +!----------------------------------------------------------------------- +! +! Purpose: +! Computes lookup table for aerosol impaction/interception scavenging rates +! +! Authors: R. Easter +! +!----------------------------------------------------------------------- + implicit none + + integer, intent(in) :: maxd_atype + integer, intent(in) :: maxd_asize + integer, intent(in) :: maxd_acomp + integer, intent(in) :: maxd_aphase + integer, intent(in) :: ntype_aer + integer, intent(in) :: nsize_aer( maxd_atype ) ! number of size bins + integer, intent(in) :: ncomp_aer( maxd_atype ) ! number of chemical components + integer, intent(in) :: massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase) ! index for mixing ratio + integer, intent(in) :: waterptr_aer( maxd_asize, maxd_atype ) ! index for aerosol water + integer, intent(in) :: numptr_aer( maxd_asize, maxd_atype, maxd_aphase ) ! index for the number mixing ratio + real, intent(in) :: dens_aer( maxd_acomp, maxd_atype ) ! material density (g/cm3) + real, intent(in) :: dens_water_aer ! water density (g/m3) + real, intent(in) :: dcen_sect( maxd_asize, maxd_atype ) ! mean particle diameter (cm) + real, intent(in) :: sigmag_aer(maxd_asize, maxd_atype) + + real, intent(out) :: dlndg_nimptblgrow + integer, intent(in) :: nimptblgrow_mind, nimptblgrow_maxd + real, intent(out) :: scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + real, intent(out) :: scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + +! local variables + integer nnfit_maxd + parameter (nnfit_maxd=27) + + integer i, j, m, n, jgrow, jdens, jpress, jtemp, ll, mode, nnfit + integer lunerr + + real dg0, press, rhodryaero, rhowetaero, rmserr, & + scavratenum, scavratevol, sigmag, & + temp, wetdiaratio, wetvolratio + real aafitnum(4), xxfitnum(4,nnfit_maxd), yyfitnum(nnfit_maxd) + real aafitvol(4), xxfitvol(4,nnfit_maxd), yyfitvol(nnfit_maxd) + + + lunerr = 6 + dlndg_nimptblgrow = log( 1.25d00 ) + + do 7900 n=1,ntype_aer + do 7900 m=1,nsize_aer(n) + + sigmag = sigmag_aer(m,n) + + rhodryaero = dens_aer(m,n) + + do 7800 jgrow = nimptblgrow_mind, nimptblgrow_maxd + + wetdiaratio = exp( jgrow*dlndg_nimptblgrow ) + dg0 = dcen_sect(m,n)*wetdiaratio + + wetvolratio = exp( jgrow*dlndg_nimptblgrow*3. ) + rhowetaero = 1.0 + (rhodryaero-1.0)/wetvolratio + rhowetaero = min( rhowetaero, rhodryaero ) + +! +! compute impaction scavenging rates at 9 temp-press pairs and save +! + nnfit = 0 + + do 5900 jtemp = -1, 1 + temp = 273.16 + 25.*jtemp + + do 5900 jpress = -1, 1 + press = 0.75e6 + 0.25e6*jpress + + do 5900 jdens = 0, 2 + rhowetaero = rhodryaero**(0.5*jdens) + + call calc_1_impact_rate( & + dg0, sigmag, rhowetaero, temp, press, & + scavratenum, scavratevol, lunerr ) + + nnfit = nnfit + 1 + if (nnfit .gt. nnfit_maxd) then + write(lunerr,9110) + call exit(1) + end if +9110 format( '*** subr. aerosol_impact_setup -- nnfit too big' ) + + xxfitnum(1,nnfit) = 1. + xxfitnum(2,nnfit) = log( temp ) + xxfitnum(3,nnfit) = log( press ) + xxfitnum(4,nnfit) = log( rhowetaero ) + yyfitnum(nnfit) = log( scavratenum ) + + xxfitvol(1,nnfit) = 1. + xxfitvol(2,nnfit) = log( temp ) + xxfitvol(3,nnfit) = log( press ) + xxfitvol(4,nnfit) = log( rhowetaero ) + yyfitvol(nnfit) = log( scavratevol ) + +5900 continue + +! +! do linear regression +! log(scavrate) = a1 + a2*log(temp) + a3*log(press) + a4*log(wetdens) +! + call mlinft( xxfitnum, yyfitnum, aafitnum, nnfit, 4, 4, rmserr ) + call mlinft( xxfitvol, yyfitvol, aafitvol, nnfit, 4, 4, rmserr ) + + do i = 1, 4 + scavimptblnum(i,jgrow,m,n) = aafitnum(i) + scavimptblvol(i,jgrow,m,n) = aafitvol(i) + end do + + +7800 continue +7900 continue + + return + end subroutine initwet + + + +!=========================================================================== +!=========================================================================== + subroutine calc_1_impact_rate( & + dg0, sigmag, rhoaero, temp, press, & + scavratenum, scavratevol, lunerr ) +! +! routine computes a single impaction scavenging rate +! for precipitation rate of 1 mm/h +! +! dg0 = geometric mean diameter of aerosol number size distrib. (cm) +! sigmag = geometric standard deviation of size distrib. +! rhoaero = density of aerosol particles (g/cm^3) +! temp = temperature (K) +! press = pressure (dyne/cm^2) +! scavratenum = number scavenging rate (1/h) +! scavratevol = volume or mass scavenging rate (1/h) +! lunerr = logical unit for error message +! + implicit none + +! subr. parameters + integer lunerr + real dg0, sigmag, rhoaero, temp, press, scavratenum, scavratevol + +! local variables + integer nrainsvmax + parameter (nrainsvmax=50) + real rrainsv(nrainsvmax), xnumrainsv(nrainsvmax),& + vfallrainsv(nrainsvmax) + + integer naerosvmax + parameter (naerosvmax=51) + real aaerosv(naerosvmax), & + ynumaerosv(naerosvmax), yvolaerosv(naerosvmax) + + integer i, ja, jr, na, nr + real a, aerodiffus, aeromass, ag0, airdynvisc, airkinvisc + real anumsum, avolsum, boltzmann, cair, chi + real d, dr, dum, dumfuchs, dx + real ebrown, eimpact, eintercept, etotal, freepath, gravity + real pi, precip, precipmmhr, precipsum + real r, rainsweepout, reynolds, rhi, rhoair, rhowater, rlo, rnumsum + real scavsumnum, scavsumnumbb + real scavsumvol, scavsumvolbb + real schmidt, sqrtreynolds, sstar, stokes, sx + real taurelax, vfall, vfallstp + real x, xg0, xg3, xhi, xlo, xmuwaterair + + + rlo = .005 + rhi = .250 + dr = 0.005 + nr = 1 + nint( (rhi-rlo)/dr ) + if (nr .gt. nrainsvmax) then + write(lunerr,9110) + call exit(1) + end if +9110 format( '*** subr. calc_1_impact_rate -- nr > nrainsvmax' ) + + precipmmhr = 1.0 + precip = precipmmhr/36000. ! cm/s + + ag0 = dg0/2. + sx = log( sigmag ) + xg0 = log( ag0 ) + xg3 = xg0 + 3.*sx*sx + + xlo = xg3 - 4.*sx + xhi = xg3 + 4.*sx + dx = 0.2*sx + + dx = max( 0.2*sx, 0.01 ) + xlo = xg3 - max( 4.*sx, 2.*dx ) + xhi = xg3 + max( 4.*sx, 2.*dx ) + + na = 1 + nint( (xhi-xlo)/dx ) + if (na .gt. naerosvmax) then + write(lunerr,9120) + call exit(1) + end if +9120 format( '*** subr. calc_1_impact_rate -- na > naerosvmax' ) + +! air molar density + cair = press/(8.31436e7*temp) +! air mass density + rhoair = 28.966*cair +! molecular freepath + freepath = 2.8052e-10/cair +! boltzmann constant + boltzmann = 1.3807e-16 +! water density + rhowater = 1.0 +! gravity + gravity = 980.616 +! air dynamic viscosity + airdynvisc = 1.8325e-4 * (416.16/(temp+120.)) * & + ((temp/296.16)**1.5) +! air kinemaic viscosity + airkinvisc = airdynvisc/rhoair +! ratio of water viscosity to air viscosity (from Slinn) + xmuwaterair = 60.0 + + pi = 3.1415926536 + +! +! compute rain drop number concentrations +! rrainsv = raindrop radius (cm) +! xnumrainsv = raindrop number concentration (#/cm^3) +! (number in the bin, not number density) +! vfallrainsv = fall velocity (cm/s) +! + precipsum = 0. + do i = 1, nr + r = rlo + (i-1)*dr + rrainsv(i) = r + xnumrainsv(i) = exp( -r/2.7e-2 ) + + d = 2.*r + if (d .le. 0.007) then + vfallstp = 2.88e5 * d**2. + else if (d .le. 0.025) then + vfallstp = 2.8008e4 * d**1.528 + else if (d .le. 0.1) then + vfallstp = 4104.9 * d**1.008 + else if (d .le. 0.25) then + vfallstp = 1812.1 * d**0.638 + else + vfallstp = 1069.8 * d**0.235 + end if + + vfall = vfallstp * sqrt(1.204e-3/rhoair) + vfallrainsv(i) = vfall + precipsum = precipsum + vfall*(r**3)*xnumrainsv(i) + end do + precipsum = precipsum*pi*1.333333 + + rnumsum = 0. + do i = 1, nr + xnumrainsv(i) = xnumrainsv(i)*(precip/precipsum) + rnumsum = rnumsum + xnumrainsv(i) + end do + +! +! compute aerosol concentrations +! aaerosv = particle radius (cm) +! fnumaerosv = fraction of total number in the bin (--) +! fvolaerosv = fraction of total volume in the bin (--) +! + anumsum = 0. + avolsum = 0. + do i = 1, na + x = xlo + (i-1)*dx + a = exp( x ) + aaerosv(i) = a + dum = (x - xg0)/sx + ynumaerosv(i) = exp( -0.5*dum*dum ) + yvolaerosv(i) = ynumaerosv(i)*1.3333*pi*a*a*a + anumsum = anumsum + ynumaerosv(i) + avolsum = avolsum + yvolaerosv(i) + end do + + do i = 1, na + ynumaerosv(i) = ynumaerosv(i)/anumsum + yvolaerosv(i) = yvolaerosv(i)/avolsum + end do + + +! +! compute scavenging +! + scavsumnum = 0. + scavsumvol = 0. +! +! outer loop for rain drop radius +! + do 5900 jr = 1, nr + + r = rrainsv(jr) + vfall = vfallrainsv(jr) + + reynolds = r * vfall / airkinvisc + sqrtreynolds = sqrt( reynolds ) + +! +! inner loop for aerosol particle radius +! + scavsumnumbb = 0. + scavsumvolbb = 0. + + do 5500 ja = 1, na + + a = aaerosv(ja) + + chi = a/r + + dum = freepath/a + dumfuchs = 1. + 1.246*dum + 0.42*dum*exp(-0.87/dum) + taurelax = 2.*rhoaero*a*a*dumfuchs/(9.*rhoair*airkinvisc) + + aeromass = 4.*pi*a*a*a*rhoaero/3. + aerodiffus = boltzmann*temp*taurelax/aeromass + + schmidt = airkinvisc/aerodiffus + stokes = vfall*taurelax/r + + ebrown = 4.*(1. + 0.4*sqrtreynolds*(schmidt**0.3333333)) / & + (reynolds*schmidt) + + dum = (1. + 2.*xmuwaterair*chi) / & + (1. + xmuwaterair/sqrtreynolds) + eintercept = 4.*chi*(chi + dum) + + dum = log( 1. + reynolds ) + sstar = (1.2 + dum/12.) / (1. + dum) + eimpact = 0. + if (stokes .gt. sstar) then + dum = stokes - sstar + eimpact = (dum/(dum+0.6666667)) ** 1.5 + end if + + etotal = ebrown + eintercept + eimpact + etotal = min( etotal, 1.0 ) + + rainsweepout = xnumrainsv(jr)*4.*pi*r*r*vfall + + scavsumnumbb = scavsumnumbb + rainsweepout*etotal*ynumaerosv(ja) + scavsumvolbb = scavsumvolbb + rainsweepout*etotal*yvolaerosv(ja) + +5500 continue + + scavsumnum = scavsumnum + scavsumnumbb + scavsumvol = scavsumvol + scavsumvolbb +5900 continue + + scavratenum = scavsumnum*3600. + scavratevol = scavsumvol*3600. + + + + return + end subroutine calc_1_impact_rate + + + +!=========================================================================== +!=========================================================================== +subroutine gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_chem, & + deltat, t, pmid, pdel, & + chem, & + isprx, fapx, pfx, pfx_inrain, & + dqdt, dotend, qsrflx ) + + +!----------------------------------------------------------------------- +! +! Purpose: +! Does below cloud scavenging of gases by rain +! +! Currently does +! Irreversible uptake of h2so4 and msa +! Reactive uptake of so2 and h2o2. This is assumed to be rate limited +! by the mass transfer to rain (and not by aqueous reaction) +! +! Authors: R. Easter +! +!----------------------------------------------------------------------- + USE module_model_constants, only: g,rhowater, mwdry + use module_configure, only: p_so2, p_h2o2, p_sulf, p_msa, & + p_hno3, p_hcl, p_nh3, param_first_scalar + + implicit none + +!----------------------------------------------------------------------- +! +! Input arguments +! +! abbreviations & acronyms +! TMR = tracer mixing ratio +! l-s = large scale +! dp-cnv = deep convective +! sh-cnv = shallow convective +! + integer, intent(in) :: num_chem ! number of chemical species + integer, intent(in) :: ims,ime ! column dimension + integer, intent(in) :: kms,kme ! level dimension + integer, intent(in) :: jms,jme ! column dimension + integer, intent(in) :: its,ite ! column identifier + integer, intent(in) :: kts,kte ! level identifier + integer, intent(in) :: jts,jte ! column identifier + real, intent(in) :: deltat ! model timestep + + real, intent(in) :: t(ims:ime,kms:kme,jms:jme) ! temperature + real, intent(in) :: pmid(ims:ime,kms:kme,jms:jme) ! pressure at model levels + real, intent(in) :: pdel(ims:ime,kms:kme,jms:jme) ! pressure thickness of levels + real, intent(in) :: chem(ims:ime,kms:kme,jms:jme,num_chem) ! TMR array including chemistry + + logical, intent(in) :: isprx(ims:ime,kms:kme,jms:jme) ! true if precip at i,k + real, intent(in) :: fapx(ims:ime,kms:kme,jms:jme) ! frac. area for precip + real, intent(in) :: pfx(ims:ime,kms:kme,jms:jme) ! grid-avg precip + ! flux (kg/m2/s) + real, intent(in) :: pfx_inrain(ims:ime,kms:kme,jms:jme) ! precip flux (kg/m2/s) + + real, intent(out) :: dqdt(ims:ime,kms:kme,jms:jme,num_chem) ! TMR tendency array + logical, intent(inout) :: dotend(num_chem) ! flag for doing scav + real, intent(inout) :: qsrflx(ims:ime,jms:jme,num_chem) + ! process-specific column tracer tendencies + ! (1=all wet removal from this routine) + +!--------------------------Local Variables------------------------------ + + integer :: i, j, k ! x, y, z work index + integer :: jp ! precip type index + integer :: p1st + logical :: ispr_anywhere + + integer, parameter :: ng = 7 + integer, parameter :: ig_so2 = 1 + integer, parameter :: ig_h2o2 = 2 + integer, parameter :: ig_h2so4 = 3 + integer, parameter :: ig_msa = 4 + integer, parameter :: ig_hno3 = 5 + integer, parameter :: ig_hcl = 6 + integer, parameter :: ig_nh3 = 7 + integer :: ig, lg, lg_ptr(ng) + + real :: amtscav(ng), amtscav_sub(ng) + real :: fracgas(ng) + real :: fracscav(ng), fracscav_sub(ng) + real :: deltatinv + real :: dum, dumamt, dumprecipmmh, dumpress, dumtemp + real :: pdel_dt_fac + real :: r_gc(ng) + real :: scavrate_hno3 + real :: scavrate(ng), scavrate_factor(ng) + +!----------------------------------------------------------------------- +! + +! if (ncol .ne. -987654321) return + +! precip rates -- 1.0 kgwtr/m2/s = 1.0e-3 m3wtr/m2/s = 1.0e-3 m/s +! = 1.0 mm/s = 3600 mm/h + + ispr_anywhere = .false. + deltatinv = 1.0/(deltat*(1.0d0 + 1.0d-15)) + + p1st = param_first_scalar + + lg_ptr(ig_so2 ) = p_so2 + lg_ptr(ig_h2o2 ) = p_h2o2 + lg_ptr(ig_h2so4) = p_sulf + lg_ptr(ig_msa ) = p_msa + lg_ptr(ig_hno3 ) = p_hno3 + lg_ptr(ig_hcl ) = p_hcl + lg_ptr(ig_nh3 ) = p_nh3 + + scavrate_factor(ig_so2 ) = 1.08 + scavrate_factor(ig_h2o2 ) = 1.38 + scavrate_factor(ig_h2so4) = 0.80 + scavrate_factor(ig_msa ) = 0.80 + scavrate_factor(ig_hno3 ) = 1.00 + scavrate_factor(ig_hcl ) = 1.15 + scavrate_factor(ig_nh3 ) = 1.59 + + + do 5900 j = jts,jte + do 5900 i = its,ite + + do 4900 k = kts,kte + +! skip this level if no precip + if ( isprx(i,k,j) ) then + ispr_anywhere = .true. + else + goto 4900 + end if + + +! skip this level if below freezing + dumtemp = t(i,k,j) + if (dumtemp .le. 273.16) goto 4900 + dumpress = 10.0*pmid(i,k,j) + + do ig = 1, ng + fracscav(ig) = 0.0 + fracgas(ig) = 1.0 + lg = lg_ptr(ig) + if (lg .ge. p1st) then + r_gc(ig) = max( chem(i,k,j,lg), 0.0 ) +! activate this after gas_aqfrac is added to arguments +! if (lg .le. numgas_aqfrac) & +! fracgas(ig) = gas_aqfrac(lg) + else + r_gc(ig) = 0.0 + end if + end do + + if ( .not. isprx(i,k,j) ) goto 3600 + +! precip rate in mm/h over rainy portion of the subarea + dumprecipmmh = pfx_inrain(i,k,j)*3600.0 + +! rain scavenging rate for hno3 (power law fit to schwarz and levine, +! with temperature and pressure adjustments) -- units are (1/s) + scavrate_hno3 = 6.262e-5*(dumprecipmmh**0.7366) & + * ((dumtemp/298.0)**1.12) & + * ((1.013e6/dumpress)**.75) + + do ig = 1, ng + scavrate(ig) = scavrate_hno3*scavrate_factor(ig) + fracscav_sub(ig) = (1. - exp(-scavrate(ig)*deltat)) & + *fracgas(ig)*fapx(i,k,j) + amtscav_sub(ig) = r_gc(ig)*min( fracscav_sub(ig), 1.0 ) + end do + +! for so2 & h2o2, assume aqueous oxidation is fast, so reactive +! uptake is limited by the smaller of the two mass transfer rates + dumamt = min( amtscav_sub(ig_so2), amtscav_sub(ig_h2o2) ) + fracscav_sub(ig_so2 ) = dumamt/max( r_gc(ig_so2 ), 1.0e-30 ) + fracscav_sub(ig_h2o2) = dumamt/max( r_gc(ig_h2o2), 1.0e-30 ) + amtscav_sub(ig_so2 ) = r_gc(ig_so2 )*min( fracscav_sub(ig_so2 ), 1.0 ) + amtscav_sub(ig_h2o2) = r_gc(ig_h2o2)*min( fracscav_sub(ig_h2o2), 1.0 ) + +! for nh3, limit uptake by uptake of all acid gases combined + dumamt = 2.0*amtscav_sub(ig_so2) & + + 2.0*amtscav_sub(ig_h2so4) + amtscav_sub(ig_msa) & + + amtscav_sub(ig_hno3) + amtscav_sub(ig_hcl) + dumamt = min( dumamt, amtscav_sub(ig_nh3) ) + fracscav_sub(ig_nh3) = dumamt/max( r_gc(ig_nh3), 1.0e-30 ) + amtscav_sub(ig_nh3 ) = r_gc(ig_nh3 )*min( fracscav_sub(ig_nh3 ), 1.0 ) + + do ig = 1, ng + fracscav(ig) = fracscav(ig) + fracscav_sub(ig) + end do + +! diagnostic output +! write(lun,9440) nstep, lchnk, i, k, jp, & +! (dumtemp-273.16), dumpress*.001 +! write(lun,9442) 'pfx, pfx_inrain, fapx ', & +! pfx(jp,i,k), pfx_inrain(jp,i,k), fapx(jp,i,k) +! write(lun,9442) 'scavrate_so2, h2o2, msa, h2so4 ', & +! scavrate(ig_so2), scavrate(ig_h2o2), & +! scavrate(ig_msa), scavrate(ig_h2so4) +! write(lun,9442) 'rso2gc, rso2g, rh2o2gc, rh2o2g ', & +! r_gc(ig_so2), r_gc(ig_so2)*fracgas(ig)so2), & +! r_gc(ig_h2o2), r_gc(ig_h2o2)*fracgas(ig)h2o2), +! write(lun,9442) 'amtscav_sub so2, h2o2 ', & +! amtscav_sub(ig_so2), amtscav_sub(ig_h2o2) +! write(lun,9442) 'fracscav_sub so2, h2o2, msa, h2so4 ', & +! fracscav_sub(ig_so2), fracscav_sub(ig_h2o2), & +! fracscav_sub(ig_msa), fracscav_sub(ig_h2so4) +!9440 format( / 'ns,lc,i,k,jp, T(C), p(mb)', i6, 2i4, 2i3, 2f7.1 ) +!9442 format( a, 4(1pe11.3) ) +! end diagnostic output + + +3600 continue + +! +! compute tendencies +! + pdel_dt_fac = (pdel(i,k,j)/(g*mwdry))*deltatinv + + do ig = 1, ng + fracscav(ig) = min( fracscav(ig), 1.0 ) + amtscav(ig) = fracscav(ig)*r_gc(ig) + lg = lg_ptr(ig) + if (lg .ge. p1st) then + dqdt(i,k,j,lg) = -deltatinv*amtscav(ig) + qsrflx(i,j,lg) = qsrflx(i,j,lg) + pdel_dt_fac*amtscav(ig) + end if + end do + +4900 continue ! "k = 1, pver" + +5900 continue ! "i = 1, ncol" + + +! set dotend's + if ( ispr_anywhere ) then + do ig = 1, ng + if (lg_ptr(ig) .ge. p1st) dotend(lg_ptr(ig)) = .true. + end do + end if + + + return +end subroutine gasrainscav + + + +!=========================================================================== +!=========================================================================== + subroutine mlinft( x, y, a, n, m, mmaxd, rmserr ) +! +! fits y = a(1)*x(1) + a(2)*x(2) + ... + a(m)*x(m) +! +! x - array containing x values +! x(i,k) is parameter i, observation k +! y - array containing y values +! y(k) is observation +! a - array !ontaining the regression coefficients +! n - number of observations +! m - number of parameters +! mmaxd - first dimension of the x array +! rmserr - root mean square residual +! rmserr = sqrt( avg-sq-err ) +! avg-sq-err = (sum of residuals squared)/(number of values) +! residual = y - (a1*x1 + a2*x2 + ... + am*xm) +! + implicit none + +! subr. parameters + integer n, m, mmaxd + real x(mmaxd,n), y(n), a(mmaxd), rmserr + +! local variables + integer i, j, jflag, k + real aa(10,10), bb(10), errsq, resid, ydum + + if (n .le. 1) then + a(1) = 1.e30 + rmserr = 0. + return + end if + + do 2900 i = 1, m + do 2100 j = 1, m + aa(i,j) = 0.0 +2100 continue + bb(i) = 0.0 + + do 2500 k = 1, n + do 2300 j = 1, m + aa(i,j) = aa(i,j) + x(i,k)*x(j,k) +2300 continue + bb(i) = bb(i) + x(i,k)*y(k) +2500 continue + +2900 continue + +! do 4100 i = 1, m +! write(13,9300) i, (aa(i,j), j=1,m), bb(i) +!4100 continue +!9300 format( i5, 5f15.2 ) + +! subr linsolv( a, x, b, n, m1, m2, jflag ) + call linsolv( aa, a, bb, m, 10, 10, jflag ) + + + errsq = 0. + do 3300 k = 1, n + ydum = 0.0 + do 3100 i = 1, m + ydum = ydum + a(i)*x(i,k) +3100 continue + resid = ydum - y(k) + errsq = errsq + resid*resid +3300 continue + rmserr = sqrt( errsq/n ) + + return + end subroutine mlinft + + + +!=========================================================================== +!=========================================================================== + subroutine linsolv( a, x, b, n, m1, m2, jflag ) +! +! solves linear eqn system a*x = b using gaussian-elimination +! with partial pivoting +! +! n = order of the system +! m1, m2 = fortran dimensions of a array +! jflag = completion flag +! 1 - system solved successfully +! 0 - system is singular or close to it, and could not be solved. +! computation was halted to avoid overflow or divide by zero. +! +! *** note *** rsmall should be defined as close to but somewhat larger +! than the smallest single precision real on the computer. +! +! initial coding on 29-aug-86 by r.c. easter +! change on 4-feb-89 by r.c.easter -- added jflag to parameter list +! and checking for singularity +! + implicit none + +! subr. parameters + integer n, m1, m2, jflag + real a(m1,m2), x(n), b(n) + +! local variables + integer i, imax, iup, j, k + real amax, asmall, dmy, rsmall + parameter (rsmall = 1.0e-16) + + jflag = 0 + +! +! reduce coef. matrix to upper triangular form +! + do 1900 k = 1, n +! +! find pivot element, and +! move pivot row into row k if necessary +! + imax = k + amax = abs( a(imax,k) ) + do 1200 i = k+1, n + if (abs(a(i,k)) .gt. amax) then + imax = i + amax = abs(a(i,k)) + end if +1200 continue + if (amax .eq. 0.) return + + if (imax .ne. k) then + do 1400 j = k, n + dmy = a(imax,j) + a(imax,j) = a(k,j) + a(k,j) = dmy +1400 continue + dmy = b(imax) + b(imax) = b(k) + b(k) = dmy + end if + +! +! reduce +! + asmall = abs(a(k,k)) + do 1700 i = k+1, n + if (a(i,k) .ne. 0.0) then + if (asmall .le. abs(rsmall*a(i,k))) return + dmy = a(i,k)/a(k,k) + a(i,k) = 0.0 + do 1600 j = k+1, n + a(i,j) = a(i,j) - dmy*a(k,j) +1600 continue + b(i) = b(i) - dmy*b(k) + end if +1700 continue + +1900 continue + +! +! backsolve +! + do 2900 iup = 1, n + i = n + 1 - iup + dmy = b(i) + do 2500 j = i+1, n + dmy = dmy - a(i,j)*x(j) +2500 continue + asmall = abs(a(i,i)) + if (abs(a(i,i)) .le. abs(rsmall*dmy)) return + x(i) = dmy/a(i,i) +2900 continue + + jflag = 1 + + return + end subroutine linsolv + +END MODULE module_mosaic_wetscav diff --git a/wrfv2_fire/chem/module_peg_util.F b/wrfv2_fire/chem/module_peg_util.F new file mode 100644 index 00000000..4328e3f2 --- /dev/null +++ b/wrfv2_fire/chem/module_peg_util.F @@ -0,0 +1,82 @@ +!#********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! miscellaneous debuging routines for CBMZ and MOSAIC +!********************************************************************************** + module module_peg_util + + + contains + + +!----------------------------------------------------------------------- + subroutine peg_debugmsg( lun, level, str ) +! +! when lun > 0, writes "str" to unit "lun" +! when lun <= 0, passes "str" on to wrf_debug +! + implicit none +! subr arguments + integer, intent(in) :: lun, level + character(len=*), intent(in) :: str +! local variables + integer n + + n = max( 1, len_trim(str) ) + if (lun .gt. 0) then + write(lun,'(a)') str(1:n) + else + call wrf_debug( level, str(1:n) ) + end if + return + end subroutine peg_debugmsg + + +!----------------------------------------------------------------------- + subroutine peg_message( lun, str ) +! +! when lun > 0, writes "str" to unit "lun" +! when lun <= 0, passes "str" on to wrf_message +! + implicit none +! subr arguments + integer, intent(in) :: lun + character(len=*), intent(in) :: str +! local variables + integer n + + n = max( 1, len_trim(str) ) + if (lun .gt. 0) then + write(lun,'(a)') str(1:n) + else + call wrf_message( str(1:n) ) + end if + return + end subroutine peg_message + + +!----------------------------------------------------------------------- + subroutine peg_error_fatal( lun, str ) +! +! when lun > 0, writes "str" to unit "lun" +! then (always) passes "str" on to wrf_error_fatal +! + implicit none +! subr arguments + integer, intent(in) :: lun + character(len=*), intent(in) :: str +! local variables + integer n + + n = max( 1, len_trim(str) ) + if (lun .gt. 0) write(lun,'(a)') str(1:n) + call wrf_error_fatal( str(1:n) ) + return + end subroutine peg_error_fatal + + +!----------------------------------------------------------------------- + end module module_peg_util diff --git a/wrfv2_fire/chem/module_phot_fastj.F b/wrfv2_fire/chem/module_phot_fastj.F new file mode 100644 index 00000000..fee2e69b --- /dev/null +++ b/wrfv2_fire/chem/module_phot_fastj.F @@ -0,0 +1,3420 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! Photolysis Option: Fast-J +! * Primary investigators: Elaine G. Chapman and James C. Barnard +! * Co-investigators: Jerome D. Fast, William I. Gustafson Jr. +! Last update: September 2005 +! +! Contact: +! Jerome D. Fast, PhD +! Staff Scientist +! Pacific Northwest National Laboratory +! P.O. Box 999, MSIN K9-30 +! Richland, WA, 99352 +! Phone: (509) 372-6116 +! Email: Jerome.Fast@pnl.gov +! +! The original Fast-J code was provided by Oliver Wild (Univ. of Calif. Irvine); +! however, substantial modifications were necessary to make it compatible with +! WRF-chem and to include the effect of prognostic aerosols on photolysis rates. +! +! Please report any bugs or problems to Jerome Fast, the WRF-chem implmentation +! team leader for PNNL +! +! References: +! * Wild, O., X. Zhu, M.J. Prather, (2000), Accurate simulation of in- and below +! cloud photolysis in tropospheric chemical models, J. Atmos. Chem., 37, 245-282. +! * Barnard, J.C., E.G. Chapman, J.D. Fast, J.R. Schmelzer, J.R. Schulsser, and +! R.E. Shetter (2004), An evaluation of the FAST-J photolysis model for +! predicting nitrogen dioxide photolysis rates under clear and cloudy sky +! conditions, Atmos. Environ., 38, 3393-3403. +! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C. Barnard, E.G. +! Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution of ozone, particulates, +! and aerosol direct radiative forcing in the vicinity of Houston using a fully- +! coupled meteorology-chemistry-aerosol model, Submitted to J. Geophys. Res. +! +! Contact Jerome Fast for updates on the status of manuscripts under review. +! +! Additional information: +! * www.pnl.gov/atmos_sciences/Jdf/wrfchem.html +! +! Support: +! Funding for adapting Fast-J was provided by the U.S. Department of Energy +! under the auspices of Atmospheric Science Program of the Office of Biological +! and Environmental Research the PNNL Laboratory Research and Directed Research +! and Development program. +!********************************************************************************** + +!WRF:MODEL_LAYER:CHEMISTRY +! + module module_phot_fastj + integer, parameter :: lunerr = -1 + + contains +!*********************************************************************** + subroutine fastj_driver(id,ktau,dtstep,config_flags, & + gmt,julday,t_phy,moist,p8w,p_phy, & + chem,rho_phy,dz8w,xlat,xlong,z_at_w, & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + USE module_configure + USE module_state_description + USE module_data_mosaic_therm, only: nbin_a, nbin_a_maxd + USE module_data_mosaic_asect + USE module_data_mosaic_other + USE module_fastj_mie + USE module_mosaic_therm, only: aerosol_optical_properties + USE module_mosaic_driver, only: mapaer_tofrom_host + USE module_fastj_data, only: nb, nc + + implicit none +!jdf +! integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 + integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer,save :: lpar !Number of levels in CTM + integer,save :: jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1),save :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1),save :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / + integer nphoto_fastj + parameter (nphoto_fastj = 14) + integer & + lfastj_no2, lfastj_o3a, lfastj_o3b, lfastj_h2o2, & + lfastj_hchoa, lfastj_hchob, lfastj_ch3ooh, lfastj_no3x, & + lfastj_no3l, lfastj_hono, lfastj_n2o5, lfastj_hno3, & + lfastj_hno4 + parameter( lfastj_no2 = 1 ) + parameter( lfastj_o3a = 2 ) + parameter( lfastj_o3b = 3 ) + parameter( lfastj_h2o2 = 4 ) + parameter( lfastj_hchoa = 5 ) + parameter( lfastj_hchob = 6 ) + parameter( lfastj_ch3ooh= 7 ) + parameter( lfastj_no3x = 8 ) + parameter( lfastj_no3l = 9 ) + parameter( lfastj_hono = 10 ) + parameter( lfastj_n2o5 = 11 ) + parameter( lfastj_hno3 = 12 ) + parameter( lfastj_hno4 = 13 ) +!jdf + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + p8w, & + rho_phy, & + z_at_w + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: xlat, & + xlong + REAL, INTENT(IN ) :: & + dtstep,gmt + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + +!local variables + + integer iclm, jclm + + real number_bin(nbin_a_maxd,kmaxd) !These have to be the full kmaxd to + real radius_wet(nbin_a_maxd,kmaxd) !match arrays in MOSAIC routines. + complex refindx(nbin_a_maxd,kmaxd) + + integer i,j, k, nsub, isecfrm0, ixhour + real xtime, xhour, xmin, gmtp, tmidh + real sla, slo + real psfc + + real cos_sza + real, dimension(kts:kte-1) :: temp, ozone, dz + real, dimension(0:kte-1) :: pbnd + real, dimension(kts:kte-1) :: cloudmr, airdensity, relhum + real, dimension(kts:kte) :: zatw + + real valuej(kte-1,nphoto_fastj) + + logical processingAerosols + +! set "pegasus" grid size variables +! itot = ite +! jtot = jte + lpar = kte - 1 + jpnl = kte - 1 + nb = lpar + 1 !for module module_fastj_data + nc = 2*nb !ditto, and don't confuse this with nc in module_fastj_mie + nsubareas = 1 + if ((kte-1 > kmaxd) .or. (lpar <= 0)) then + write( wrf_err_message, '(a,4i5)' ) & + '*** subr fastj_driver -- ' // & + 'lpar, kmaxd, kts, kte', lpar, kmaxd, kts, kte + call wrf_message( trim(wrf_err_message) ) + wrf_err_message = '*** subr fastj_driver -- ' // & + 'kte-1>kmaxd OR lpar<=0' + call wrf_error_fatal( wrf_err_message ) + end if + +! Determine if aerosol data is provided in the chem array. Currently, +! only MOSAIC will work. The Mie routine does not know how to handle +! SORGAM aerosols. + select case (config_flags%chem_opt) + case ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & + CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) + processingAerosols = .true. + case default + processingAerosols = .false. + end select + +! Set nbin_a = ntot_amode and check nbin_a <= nbin_a_maxd. +! This duplicates the same assignment and check in module_mosaic_therm.F, +! but photolysis is called before aeorosols so this must be set too. +! +! rce 2004-dec-07 -- nbin_a is initialized elsewhere +!!$ nbin_a = ntot_amode +!!$ if ((nbin_a .gt. nbin_a_maxd) .or. (nbin_a .le. 0)) then +!!$ write( wrf_err_message, '(a,2(1x,i4))' ) & +!!$ '*** subr fastj_driver -- nbin_a, nbin_a_maxd =', & +!!$ nbin_a, nbin_a_maxd +!!$ call wrf_message( wrf_err_message ) +!!$ call wrf_error_fatal( & +!!$ '*** subr fastj_driver -- BAD VALUE for nbin_a' ) +!!$ end if + +! determine current time of day in Greenwich Mean Time at middle +! of current time step, tmidh. do this by computing the number of minutes +! from beginning of run to middle of current time step + xtime=(ktau-1)*dtstep/60. + dtstep/120. + ixhour = ifix(gmt + 0.01) + ifix(xtime/60.) + xhour=float(ixhour) !current hour + xmin = 60.*gmt + (xtime-xhour*60) + gmtp=mod(xhour,24.) + tmidh= gmtp + xmin/60. + isecfrm0 = ifix ( (ktau-1) * dtstep ) + +! execute for each i,j column and each nsub subarea + do nsub = 1, nsubareas + do jclm = jts, jte + do iclm = its, ite + + do k = kts, lpar + dz(k) = dz8w(iclm, k, jclm) ! cell depth (m) + end do + + if( processingAerosols ) then +! take chem data and extract 1 column to create rsub(l,k,m) array + call mapaer_tofrom_host( 0, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + iclm, jclm, kts,lpar, & + num_moist, num_chem, moist, chem, & + t_phy, p_phy, rho_phy ) +! generate aerosol optical properties for cells in this column +! subroutine is located in file module_mosaic_therm + call aerosol_optical_properties(iclm, jclm, lpar, refindx, & + radius_wet, number_bin) +! execute mie code , located in file module_fastj_mie + CALL wrf_debug(250,'fastj_driver: calling mieaer') + call mieaer( & + id, iclm, jclm, nbin_a, & + number_bin, radius_wet, refindx, & + dz, isecfrm0, lpar, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + end if + +! set lat, long + sla = xlat(iclm,jclm) + slo = xlong(iclm,jclm) +! set column pressures, temperature, and ozone + psfc = p8w(iclm,1,jclm) * 10. ! convert pascals to dynes/cm2 + do k = kts, lpar + pbnd(k) = p8w(iclm,k+1,jclm) *10. ! convert pascals to dynes/cm2 + temp(k) = t_phy(iclm,k,jclm) + ozone(k) = chem(iclm,k,jclm,p_o3) / 1.0e6 ! ppm->mol/mol air + cloudmr(k) = moist(iclm,k,jclm,p_qc)/0.622 + airdensity(k) = rho_phy(iclm,k,jclm)/28.966e3 + relhum(k) = MIN( .95, moist(iclm,k,jclm,p_qv) / & + (3.80*exp(17.27*(t_phy(iclm,k,jclm)-273.)/ & + (t_phy(iclm,k,jclm)-36.))/(.01*p_phy(iclm,k,jclm)))) + relhum(k) = MAX(.001,relhum(k)) + zatw(k)=z_at_w(iclm,k,jclm) + end do + zatw(lpar+1)=z_at_w(iclm,lpar+1,jclm) +! call interface_fastj + CALL wrf_debug(250,'fastj_driver: calling interface_fastj') + call interface_fastj(tmidh,sla,slo,julday, & + pbnd, psfc, temp, ozone, & + dz, cloudmr, airdensity, relhum, zatw, & + iclm, jclm, lpar, jpnl, & + isecfrm0, valuej, cos_sza, processingAerosols, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +! put column photolysis rates (valuej) into wrf photolysis (i,k,j) arrays + CALL wrf_debug(250,'fastj_driver: calling mapJrates_tofrom_host') + call mapJrates_tofrom_host( 0, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + iclm, jclm, kts,lpar, & + valuej, & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5 ) +! put the aerosol optical properties into the wrf arrays (this is hard- +! coded to 4 spectral bins, nspint) + do k=kts,kte-1 + tauaer1(iclm,k,jclm) = tauaer(1,k) + tauaer2(iclm,k,jclm) = tauaer(2,k) + tauaer3(iclm,k,jclm) = tauaer(3,k) + tauaer4(iclm,k,jclm) = tauaer(4,k) + gaer1(iclm,k,jclm) = gaer(1,k) + gaer2(iclm,k,jclm) = gaer(2,k) + gaer3(iclm,k,jclm) = gaer(3,k) + gaer4(iclm,k,jclm) = gaer(4,k) + waer1(iclm,k,jclm) = waer(1,k) + waer2(iclm,k,jclm) = waer(2,k) + waer3(iclm,k,jclm) = waer(3,k) + waer4(iclm,k,jclm) = waer(4,k) + end do + + end do + end do + end do + + return + end subroutine fastj_driver + +!----------------------------------------------------------------------- + subroutine mapJrates_tofrom_host( iflag, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + iclm, jclm, ktmaps,ktmape, & + valuej, & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5 ) + + USE module_data_cbmz + + implicit none +!jdf + integer nphoto_fastj + parameter (nphoto_fastj = 14) + integer & + lfastj_no2, lfastj_o3a, lfastj_o3b, lfastj_h2o2, & + lfastj_hchoa, lfastj_hchob, lfastj_ch3ooh, lfastj_no3x, & + lfastj_no3l, lfastj_hono, lfastj_n2o5, lfastj_hno3, & + lfastj_hno4 + parameter( lfastj_no2 = 1 ) + parameter( lfastj_o3a = 2 ) + parameter( lfastj_o3b = 3 ) + parameter( lfastj_h2o2 = 4 ) + parameter( lfastj_hchoa = 5 ) + parameter( lfastj_hchob = 6 ) + parameter( lfastj_ch3ooh= 7 ) + parameter( lfastj_no3x = 8 ) + parameter( lfastj_no3l = 9 ) + parameter( lfastj_hono = 10 ) + parameter( lfastj_n2o5 = 11 ) + parameter( lfastj_hno3 = 12 ) + parameter( lfastj_hno4 = 13 ) +!jdf + INTEGER, INTENT(IN ) :: iflag, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + iclm, jclm, ktmaps, ktmape + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5 + + REAL, DIMENSION( kte-1,nphoto_fastj ), INTENT(INOUT) :: valuej + +! local variables + real ft + integer kt + + ft = 60. + + if (iflag .gt. 0) go to 2000 +! flag is <=0, put pegasus column J rates (in 1/sec) into WRF arrays (in 1/min) + do kt = ktmaps, ktmape + ph_no2(iclm,kt,jclm) = valuej(kt,lfastj_no2) * ft + ph_no3o(iclm,kt,jclm) = valuej(kt,lfastj_no3x) * ft + ph_no3o2(iclm,kt,jclm) = valuej(kt,lfastj_no3l) * ft + ph_o33p(iclm,kt,jclm) = valuej(kt,lfastj_o3a) * ft + ph_o31d(iclm,kt,jclm) = valuej(kt,lfastj_o3b) * ft + ph_hno2(iclm,kt,jclm) = valuej(kt,lfastj_hono) * ft + ph_hno3(iclm,kt,jclm) = valuej(kt,lfastj_hno3) * ft + ph_hno4(iclm,kt,jclm) = valuej(kt,lfastj_hno4) * ft + ph_h2o2(iclm,kt,jclm) = valuej(kt,lfastj_h2o2) * ft + ph_ch3o2h(iclm,kt,jclm) = valuej(kt,lfastj_ch3ooh) * ft + ph_ch2or(iclm,kt,jclm) = valuej(kt,lfastj_hchoa) * ft + ph_ch2om(iclm,kt,jclm) = valuej(kt,lfastj_hchob) * ft + ph_n2o5(iclm,kt,jclm) = valuej(kt,lfastj_n2o5) * ft + + ph_o2(iclm,kt,jclm) = 0.0 + ph_ch3cho(iclm,kt,jclm) = 0.0 + ph_ch3coch3(iclm,kt,jclm) = 0.0 + ph_ch3coc2h5(iclm,kt,jclm) = 0.0 + ph_hcocho(iclm,kt,jclm) = 0.0 + ph_ch3cocho(iclm,kt,jclm) = 0.0 + ph_hcochest(iclm,kt,jclm) = 0.0 + ph_ch3coo2h(iclm,kt,jclm) = 0.0 + ph_ch3ono2(iclm,kt,jclm) = 0.0 + ph_hcochob(iclm,kt,jclm) = 0.0 + + end do + return !finished peg-> wrf mapping + +2000 continue +! iflag > 0 ; put wrf ph_xxx Jrates (1/min) into pegasus column valuej (1/sec) + do kt = ktmaps, ktmape + valuej(kt,lfastj_no2) = ph_no2(iclm,kt,jclm) / ft + valuej(kt,lfastj_no3x) = ph_no3o(iclm,kt,jclm) / ft + valuej(kt,lfastj_no3l) = ph_no3o2(iclm,kt,jclm)/ ft + valuej(kt,lfastj_o3a) = ph_o33p(iclm,kt,jclm) / ft + valuej(kt,lfastj_o3b) = ph_o31d(iclm,kt,jclm) / ft + valuej(kt,lfastj_hono) = ph_hno2(iclm,kt,jclm) / ft + valuej(kt,lfastj_hno3) = ph_hno3(iclm,kt,jclm) / ft + valuej(kt,lfastj_hno4) = ph_hno4(iclm,kt,jclm) / ft + valuej(kt,lfastj_h2o2) = ph_h2o2(iclm,kt,jclm) / ft + valuej(kt,lfastj_ch3ooh) = ph_ch3o2h(iclm,kt,jclm)/ft + valuej(kt,lfastj_hchoa) = ph_ch2or(iclm,kt,jclm)/ ft + valuej(kt,lfastj_hchob) = ph_ch2om(iclm,kt,jclm)/ ft + valuej(kt,lfastj_n2o5) = ph_n2o5(iclm,kt,jclm) / ft + end do + + return !finished wrf->peg mapping + + end subroutine mapJrates_tofrom_host +!----------------------------------------------------------------------- + + + +!*********************************************************************** + subroutine interface_fastj(tmidh,sla,slo,julian_day, & + pbnd, psfc, temp, ozone, & + dz, cloudmr, airdensity, relhum, zatw, & + isvode, jsvode, lpar, jpnl, & + isecfrm0, valuej, cos_sza, processingAerosols, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------------------------------- +! sets parameters for fastj call. +! inputs +! tmidh -- GMT time in decimal hours at which to calculate +! photolysis rates +! sla -- latitude, decimal degrees in real*8 +! slo -- negative of the longitude, decimal degrees in real*8 +! julian_day -- day of the year in julian days +! pbnd(0:lpar) = pressure at top boundary of cell k (dynes/cm^2). +! psfc = surface pressure (dynes/cm^2). +! temp(lpar)= mid-cell temperature values (deg K) +! ozone(lpar) = mid-cell ozone mixing ratios +! surface_albedo -- broadband albedo (dimensionless) +! isecfrm0 -- elapsed time from start of simulation in seconds. +! isvode,jsvode -- current column i,j. +! +! lpar -- vertical extent of column (from module_fastj_cmnh) +! +! outputs +! cos_sza -- cosine of solar zenith angle. +! valuej(lpar,nphoto_fastj-1) -- array of photolysis rates, s-1. +! +! +! local variables +! surface_pressure_mb -- surface pressure (mb). equal to col_press_mb(1). +! col_press_mb(lpar) -- for the column, grid cell boundary pressures +! (not at cell centers) up until the bottom pressure for the +! top cell (mb). +! col_temp_K(lpar+1) -- for the column, grid cell center temperature (deg K) +! col_ozone(lpar+1) -- for the column, grid cell center ozone mixing +! ratios (dimensionless) +! col_optical_depth(lpar+1) -- for the column, grid cell center cloud +! optical depths (dimensionless).SET TO ZERO IN THIS VERSION +! tauaer_550 -- aerosol optical thickness at 550 nm. +! note: photolysis rates are calculated at centers of model layers +! the pressures are given at the boundaries defining +! the top and bottom of the layers +! so the number of pressure values is equal +! to the (number of layers) + 1 ; the last pressure is set = 0 in fastj code. +! pressures from the surface up to the bottom of the top (lpar<=kmaxd) cell +! ******** pressure 2 +! layer 1 - temperature,optical depth, and O3 given here +! ******** pressure 1 +! the optical depth is appropriate for the layer depth +! conversion factor: 1 dyne/cm2 = 0.001 mb +!----------------------------------------------------------------- + USE module_data_mosaic_other, only : kmaxd + USE module_peg_util, only: peg_message, peg_error_fatal + + IMPLICIT NONE + +!jdf + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 + integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nphoto_fastj + parameter (nphoto_fastj = 14) + integer & + lfastj_no2, lfastj_o3a, lfastj_o3b, lfastj_h2o2, & + lfastj_hchoa, lfastj_hchob, lfastj_ch3ooh, lfastj_no3x, & + lfastj_no3l, lfastj_hono, lfastj_n2o5, lfastj_hno3, & + lfastj_hno4 + parameter( lfastj_no2 = 1 ) + parameter( lfastj_o3a = 2 ) + parameter( lfastj_o3b = 3 ) + parameter( lfastj_h2o2 = 4 ) + parameter( lfastj_hchoa = 5 ) + parameter( lfastj_hchob = 6 ) + parameter( lfastj_ch3ooh= 7 ) + parameter( lfastj_no3x = 8 ) + parameter( lfastj_no3l = 9 ) + parameter( lfastj_hono = 10 ) + parameter( lfastj_n2o5 = 11 ) + parameter( lfastj_hno3 = 12 ) + parameter( lfastj_hno4 = 13 ) + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + real pbnd(0:lpar), psfc + real temp(lpar), ozone(lpar), surface_albedo + real dz(lpar), cloudmr(lpar), airdensity(lpar), relhum(lpar), zatw(lpar+1) + integer isecfrm0, isvode, jsvode + + real cos_sza + integer,parameter :: lunout=41 + + real valuej(lpar,nphoto_fastj) + + real hl,rhl,factor1,part1,part2,cfrac,rhfrac + real emziohl(lpar+1),clwp(lpar) +!ec material to check output + real valuej_no3rate(lpar) + + real*8 lat,lon + real*8 jvalue(lpar,nphoto_fastj) + real sza + real tau1 + real tmidh, sla, slo + + integer julian_day,iozone1 + integer,parameter :: nfastj_rxns = 14 + integer k, l + + real surface_pressure_mb, tauaer_550, & + col_press_mb,col_temp_K,col_ozone,col_optical_depth + dimension col_press_mb(lpar+2),col_temp_K(lpar+1), & + col_ozone(lpar+1),col_optical_depth(lpar+1) + character*80 msg + +! define logical processingAerosols +! if processingAerosols = true, uses values calculated in subroutine +! mieaer for variables & arrays in common block mie. +! if processingAerosols = false, sets all variables & arrays in common +! block mie to zero. (JCB-revised Fast-J requires common block mie info, +! regardless of whether aerosols are present or not. Original Wild Fast-J +! did not use common block mie info.) + + logical processingAerosols + +! set lat and longitude as real*8 for consistency with fastj code. +! variables lat and lon previously declared as reals + lat = sla + lon = slo +! +! cloud optical depths currently treated by using fractional cloudiness +! based on relative humidity. cloudmr set up to use cloud liquid water +! but hooks into microphysics need to be tested - for now set cloudmr=0 +! +! parameters to calculate 'typical' liquid cloudwater path values for +! non convective clouds based on approximations in NCAR's CCM2 +! 0.18 = reference liquid water concentration (gh2o/m3) +! hl = liquid water scale height (m) +! + hl=1080.+2000.0*cos(lat*0.017454329) + rhl=1.0/hl + do k =1, lpar+1 + emziohl(k)=exp(-zatw(k)*rhl) + enddo + do k =1, lpar + clwp(k)=0.18*hl*(emziohl(k)-emziohl(k+1)) + enddo +! assume radius of cloud droplets is constant at 10 microns (0.001 cm) and +! that density of water is constant at 1 g2ho/cm3 +! factor1=3./2./0.001/1. + factor1=1500.0 + do k =1, lpar + col_optical_depth(k) = 0.0 + cfrac=0.0 + cloudmr(k)=0.0 + if(cloudmr(k).gt.0.0) cfrac=1.0 +! 18.0*airdensity converts mole h2o/mole air to g h2o/cm3, part1 is in g h2o/cm2 + part1=cloudmr(k)*cfrac*18.0*airdensity(k)*dz(k)*100.0 + if(relhum(k).lt.0.8) then + rhfrac=0.0 + elseif(relhum(k).le.1.0.and.relhum(k).ge.0.8) then +! rhfrac=(relhum(k)-0.8)/(1.0-0.8) + rhfrac=(relhum(k)-0.8)/0.2 + else + rhfrac=1.0 + endif + if(rhfrac.ge.0.01) then +! factor 1.0e4 converts clwp of g h2o/m2 to g h2o/cm2 + part2=rhfrac*clwp(k)/1.e4 + else + part2=0.0 + endif + if(cfrac.gt.0) part2=0.0 + col_optical_depth(k) = factor1*(part1+part2) +! col_optical_depth(k) = 0.0 +! if(isvode.eq.33.and.jsvode.eq.34) & +! print*,'jdf opt',isvode,jsvode,k,col_optical_depth(k), & +! cfrac,rhfrac,relhum(k),clwp(k) + end do + col_optical_depth(lpar+1) = 0.0 + if (.not.processingAerosols) then +! set common block mie variables to 0 if + call set_common_mie(lpar, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + end if ! processingAerosols=false + +! set pressure, temperature, ozone of each cell in the column +! set iozone1 = lpar to allow replacement of climatological ozone with model +! predicted ozone to top of chemistry column; standard fastj climatological o3 +! thereafter. + surface_pressure_mb = psfc * 0.001 + tau1 = tmidh + col_press_mb(1) = psfc * 0.001 + iozone1 = lpar + do k =1, lpar + col_press_mb(k+1) = pbnd(k) * 0.001 + col_temp_K(k) = temp(k) + col_ozone(k) = ozone(k) + end do + +! surface_albedo=0.055 +!jdf + surface_albedo=0.05 + +! set aerosol parameters needed by Fast-J + if (processingAerosols) then + tauaer_550 = 0.0 ! needed parameters already calculated by subroutine + ! mieaer and passed into proper parts of fastj code + ! via module_fastj_cmnmie + else + tauaer_550 = 0.05 ! no aerosols, assume typical constant aerosol optical thickness + end if + + CALL wrf_debug(250,'interface_fastj: calling fastj') + call fastj(isvode,jsvode,lat,lon,surface_pressure_mb,surface_albedo, & + julian_day, tau1, & + col_press_mb, col_temp_K, col_optical_depth, col_ozone, & + iozone1,tauaer_550,jvalue,sza,lpar,jpnl, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + + cos_sza = cosd(sza) + + +! array jvalue (real*8) is returned from fastj. array valuej(unspecified +! real, default of real*4) is sent on to +! other chemistry subroutines + do k = 1, lpar + valuej(k, lfastj_no2) = jvalue(k,lfastj_no2) + valuej(k, lfastj_o3a) = jvalue(k,lfastj_o3a) + valuej(k, lfastj_o3b) = jvalue(k,lfastj_o3b) + valuej(k, lfastj_h2o2) = jvalue(k,lfastj_h2o2) + valuej(k, lfastj_hchoa) = jvalue(k,lfastj_hchoa) + valuej(k, lfastj_hchob) = jvalue(k,lfastj_hchob) + valuej(k, lfastj_ch3ooh) = jvalue(k,lfastj_ch3ooh) + valuej(k, lfastj_no3x) = jvalue(k,lfastj_no3x) + valuej(k, lfastj_no3l) = jvalue(k,lfastj_no3l) + valuej(k, lfastj_hono) = jvalue(k,lfastj_hono) + valuej(k, lfastj_n2o5) = jvalue(k,lfastj_n2o5) + valuej(k, lfastj_hno3) = jvalue(k,lfastj_hno3) + valuej(k, lfastj_hno4) = jvalue(k,lfastj_hno4) + end do +! diagnostic output and zeroed value if negative photolysis rates returned + do k = 1, lpar + valuej(k,nphoto_fastj)=0.0 + do l = 1, nphoto_fastj-1 + if (valuej(k,l) .lt. 0) then + write( msg, '(a,i8,4i4,1x,e11.4)' ) & + 'FASTJ negative Jrate ' // & + 'tsec i j k l J(k,l)', isecfrm0,isvode,jsvode,k,l,valuej(k,l) + call peg_message( lunerr, msg ) + valuej(k,l) = 0.0 +! following code used if want run stopped with negative Jrate +! msg = '*** subr interface_fastj -- ' // & +! 'Negative J rate returned from Fast-J' +! call peg_error_fatal( lunerr, msg ) + end if + end do + end do +! compute overall no3 photolysis rate +! wig: commented out since it is not used anywhere +! do k = 1, lpar +! valuej_no3rate(k) = & +! valuej(k, lfastj_no3x) + valuej(k,lfastj_no3l) +! end do +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!EC FOLLOWING PRINT LOOP SHOULD BE ELIMINATED FROM FINAL WRF CODE +! print outs of aerosol optical properties are performed +! in mie subroutines. now output jrates. +! write(27,909) +! 909 format( & +! 'isecfrm0',2x, 'i', 2x, 'j',2x 'k',3x, 'cos_sza',7x, & +! 'no2',13x,'o3a', 13x,'o3b',13x, & +! 'h2o2' , 12x, 'hchoa',11x,'hchob', 11x,'ch3ooh',10x,'no3', & +! 13x,'hono',12x,'n2o5',12x, 'hno3',12x,'hno4') +! +! do k = 1, lpar +! write(27, 911) isecfrm0,isvode,jsvode,k, cos_sza, & +! valuej(k, lfastj_no2), & +! valuej(k, lfastj_o3a) , & +! valuej(k, lfastj_o3b), & +! valuej(k, lfastj_h2o2), & +! valuej(k, lfastj_hchoa), & +! valuej(k, lfastj_hchob) , & +! valuej(k, lfastj_ch3ooh), & +! valuej_no3rate(k), & +! valuej(k, lfastj_hono), & +! valuej(k, lfastj_n2o5), & +! valuej(k, lfastj_hno3) , & +! valuej(k, lfastj_hno4) +! +!911 format(i7,3(2x,i4),2x,f7.4, 2x, & +! 12(e14.6,2x)) +! end do +!EC END PRINT LOOP. +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + return + end subroutine interface_fastj +!*********************************************************************** + subroutine set_common_mie(lpar, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +! for use when aerosols are not included in a model run. sets variables +! in common block mie to zero, except for wavelengths. +! OUTPUT: in module_fastj_cmnmie +! wavmid ! fast-J wavelengths (cm) +! tauaer ! aerosol optical depth +! waer ! aerosol single scattering albedo +! gaer ! aerosol asymmetery factor +! extaer ! aerosol extinction +! l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,...... +! sizeaer ! average wet radius +! INPUTS +! lpar = total number of vertical layers in chemistry model. Passed +! via module_fastf_cmnh +! NB = total vertical layers + 1 considered by FastJ (lpar+1=kmaxd+1). +! passed via module_fast j_data +!------------------------------------------------------------------------ + + USE module_data_mosaic_other, only : kmaxd + + IMPLICIT NONE +!jdf + integer lpar ! Number of levels in CTM + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + +! LOCAL VARIABLES + integer klevel ! vertical level index + integer ns ! spectral loop index + + +! aerosol optical properties: set everything = 0 when no aerosol + do 1000 ns=1,nspint + do 1000 klevel = 1, lpar + tauaer(ns,klevel)=0. + waer(ns,klevel)=0. + gaer(ns,klevel)=0. + sizeaer(ns,klevel)=0.0 + extaer(ns,klevel)=0.0 + l2(ns,klevel)=0.0 + l3(ns,klevel)=0.0 + l4(ns,klevel)=0.0 + l5(ns,klevel)=0.0 + l6(ns,klevel)=0.0 + l7(ns,klevel)=0.0 +1000 continue + + return + end subroutine set_common_mie +!*********************************************************************** + subroutine fastj(isvode,jsvode,lat,lon,surface_pressure,surface_albedo, & + julian_day,tau1, pressure, temperature, optical_depth, my_ozone1, & + iozone1,tauaer_550_1,jvalue,SZA_dum,lpar,jpnl, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +! input: +! lat = latitute; must be real*8 +! lon = longitude; must be real*8 +! surface_pressure (mb); real*4 +! surface_albedo (broadband albedo); real*4 +! julian_day; integer +! tau1 = time of calculation (GMT); real*4 +! pressure (mb) = vector of pressure values, pressure(NB); +! real*4; NB is the number of model layers; +! pressure (NB+1) is defined as 0 mb in model +! temperature (degree K)= vector of temperature values, temperature(NB); +! real*4 +! optical_depth (dimensionless) = vector of cloud optical depths, +! optical_depth(NB); real*4 +! my_ozone1 (volume mixing ratio) = ozone at layer center +! ozone(iozone); real*4; if iozone1 <= NB-1, then climatology is +! used in the upper layers +! tauaer_550; real*4 aerosol optical thickness @ 550 nm +! input note: NB is the number of model layers -- photolysis rates are calculated +! at layer centers while pressures are given at the boundaries defining +! the top and bottom of the layers. The number of pressure values = +! (number of layers) + 1 ; see below +! ******** pressure 2 +! layer 1 - optical depth, O3, and temperature given here +! ******** pressure 1 +! temperature and o3 are defined at the layer center. optical depth is +! appropriate for the layer depth. +! output: +! jvalue = photolysis rates, an array of dimension jvalue(jpnl,jppj) where +! jpnl = # of models level at which photolysis rates are calculated +! note: level 1 = first level of model (adjacent to ground) +! jppj = # of chemical species for which photolysis rates are calculated; +! this is fixed and is not easy to change on the fly +! jpnl land jppl are defined in the common block "cmn_h.f" +! SZA_dum = solar zenith angle +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 +! following specific for fastj +! jppj will be gas phase mechanism dependent + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution +! The vertical level variables are set in fastj_driver. + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry +! following should be available from other wrf modules and passed into +! photodriver + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD + real(kind=double) my_ozone(kmaxd) !real*8 version of ozone mixing ratios + real tauaer_550 + integer iozone + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point + save :: nslat, nslon + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + + integer julian_day + real surface_pressure,surface_albedo,pressure(lpar+2), & + temperature(lpar+1) + real optical_depth(lpar+1) + real tau1 + real*8 pi_fastj,lat,lon,timej,jvalue(lpar,jppj) + integer isvode,jsvode + + integer iozone1,i + real my_ozone1(lpar+1) + + real tauaer_550_1 + real sza_dum + + integer ientryno_fastj + save ientryno_fastj + data ientryno_fastj / 0 / + + + +! Just focus on one column + nslat = 1 + nslon = 1 + pi_fastj=3.141592653589793D0 +! + +! JCB - note that pj(NB+1) = p and is defined such elsewhere + do i=1,lpar+1 + pj(i)=pressure(i) + T(nslon,nslat,i)=temperature(i) + OD(nslon,nslat,i)=optical_depth(i) + enddo +! surface albedo + SA(nslon,nslat)=surface_albedo +! + iozone=iozone1 + do i=1,iozone1 + my_ozone(i)=my_ozone1(i) + enddo +! + tau_fastj=tau1 ! fix time + iday_fastj=julian_day +! fix optical depth for situations where aerosols not considered + tauaer_550=tauaer_550_1 +! + month_fastj=int(dble(iday_fastj)*12.d0/365.d0)+1 ! Approximately + xgrd(nslon)=lon*pi_fastj/180.d0 + ygrd(nslat)=lat*pi_fastj/180.d0 + ydgrd(nslat)=lat + +! Initial call to Fast-J to set things up--done only once + if (ientryno_fastj .eq. 0) then + call inphot2 + ientryno_fastj = 1 + end if +! +! Now call fastj as appropriate + timej=0.0 ! manually set offset to zero (JCB: 14 November 2001) + call photoj(isvode,jsvode,jvalue,timej,nslat,nslon,iozone,tauaer_550, & + my_ozone,p,t,od,sa,lpar,jpnl, & + xgrd,ygrd,tau_fastj,month_fastj,iday_fastj,ydgrd, & + sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + sza_dum=SZA + + return + end subroutine fastj +!********************************************************************** +!---(pphot.f)-------generic CTM shell from UCIrvine (p-code 4.0, 7/99) +!---------PPHOT calculates photolysis rates with the Fast-J scheme +!---------subroutines: inphot, photoj, Fast-J schemes... +!----------------------------------------------------------------------- +! + subroutine inphot2 +!----------------------------------------------------------------------- +! Routine to initialise photolysis rate data, called directly from the +! cinit routine in ASAD. Currently use it to read the JPL spectral data +! and standard O3 and T profiles and to set the appropriate reaction index. +!----------------------------------------------------------------------- +! +! iph Channel number for reading all data files +! rad Radius of Earth (cm) +! zzht Effective scale height above top of atmosphere (cm) +! dtaumax Maximum opt.depth above which a new level should be inserted +! dtausub No. of opt.depths at top of cloud requiring subdivision +! dsubdiv Number of additional levels to add at top of cloud +! szamax Solar zenith angle cut-off, above which to skip calculation +! +!----------------------------------------------------------------------- +! + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year +!jdf +! +! Set labels of photolysis rates required +!ec032504 CALL RD_JS(iph,path_fastj_ratjd) +! call rd_js2 +! +! Read in JPL spectral data set +!ec032504 CALL RD_TJPL(iph,path_fastj_jvspec) + call rd_tjpl2 +! +! Read in T & O3 climatology +!ec032504 CALL RD_PROF(iph,path_fastj_jvatms) +! call rd_prof2 +! +! Select Aerosol/Cloud types to be used +! call set_aer2 + + return + end subroutine inphot2 +!************************************************************************* + + subroutine photoj(isvode,jsvode,zpj,timej,nslat,nslon,iozone,tauaer_550_1, & + my_ozone,p,t,od,sa,lpar,jpnl,xgrd,ygrd,tau_fastj,month_fastj,iday_fastj, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------------------------------------- +!----jv_trop.f: new FAST J-Value code, troposphere only (mjprather 6/96) +!---- uses special wavelength quadrature spectral data (jv_spec.dat) +!--- that includes only 289 nm - 800 nm (later a single 205 nm add-on) +!--- uses special compact Mie code based on Feautrier/Auer/Prather vers. +!----------------------------------------------------------------------- +! +! zpj External array providing J-values to main CTM code +! timej Offset in hours from start of timestep to time J-values +! required for - take as half timestep for mid-step Js. +! solf Solar distance factor, for scaling; normally given by: +! 1.0-(0.034*cos(real(iday_fastj-186)*2.0*pi_fastj/365.)) +! +!----------basic common blocks:----------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD + real(kind=double) my_ozone(kmaxd) !real*8 version of ozone mixing ratios + real tauaer_550_1 + integer iozone + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + real*8 zpj(lpar,jppj),timej,solf + real*8 pi_fastj + + integer i,j + integer isvode,jsvode + +!----------------------------------------------------------------------- +! + do i=1,jpnl + do j=1,jppj + zj(i,j)=0.D0 + zpj(i,j)=0.D0 + enddo + enddo +! +!---Calculate new solar zenith angle + CALL SOLAR2(timej,nslat,nslon, & + xgrd,ygrd,tau_fastj,month_fastj,iday_fastj) + if(SZA.gt.szamax) go to 10 +! +!---Set up profiles on model levels + CALL SET_PROF(isvode,jsvode,nslat,nslon,iozone,tauaer_550_1, & + my_ozone,p,t,od,sa,lpar,jpnl,month_fastj,ydgrd) +! +!---Print out atmosphere + if(iprint.ne.0)CALL PRTATM(3,nslat,nslon,tau_fastj,month_fastj,ydgrd) ! code change jcb +! call prtatm(0) +! +!----------------------------------------------------------------------- + CALL JVALUE(isvode,jsvode,lpar,jpnl, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------------------------------------- +!---Print solar flux terms +! WRITE(6,'(A16,I5,20I9)') ' wave (beg/end)',(i,i=1,jpnl) +! DO j=NW1,NW2 +! WRITE(6,'(2F8.2,20F9.6)') WBIN(j),WBIN(j+1), +! $ (FFF(j,i)/FL(j),i=1,jpnl) +! ENDDO +! +!---Include variation in distance to sun + pi_fastj=3.1415926536d0 + solf=1.d0-(0.034d0*cos(dble(iday_fastj-186)*2.d0 & + *pi_fastj/365.d0)) + if(iprint.ne.0)then +! write(6,'('' solf = '', f10.5)')solf + write(*,'('' solf = '', f10.5)')solf + endif +! solf=1.d0 ! code change jcb +!----------------------------------------------------------------------- + CALL JRATET(solf,nslat,nslon,p,t,od,sa,lpar,jpnl) +!----------------------------------------------------------------------- +! + +! "zj" updated in JRATET - pass this back to ASAD as "zpj" + do i=1,jpnl + do j=1,jppj + zpj(i,j)= zj(i,j) + enddo + enddo + +! +!---Output selected values + 10 if((.not.ldeg45.and.nslon.eq.37.and.nslat.eq.36).or. & + (ldeg45.and.nslon.eq.19.and.nslat.eq.18)) then + i=min(jppj,8) +! write(6,1000)iday_fastj,tau_fastj+timej,sza,jlabel(i),zpj(1,i) + endif +! + return +! 1000 format(' Photolysis on day ',i4,' at ',f4.1,' hrs: SZA = ',f7.3, & +! ' J',a7,'= ',1pE10.3) + end subroutine photoj + +!************************************************************************* + subroutine set_prof(isvode,jsvode,nslat,nslon,iozone,tauaer_550, & + my_ozone,p,t,od,sa,lpar,jpnl,month_fastj,ydgrd) +!----------------------------------------------------------------------- +! Routine to set up atmospheric profiles required by Fast-J using a +! doubled version of the level scheme used in the CTM. First pressure +! and z* altitude are defined, then O3 and T are taken from the supplied +! climatology and integrated to the CTM levels (may be overwritten with +! values directly from the CTM, if desired) and then black carbon and +! aerosol profiles are constructed. +! Oliver (04/07/99) +!----------------------------------------------------------------------- +! +! pj Pressure at boundaries of model levels (hPa) +! z Altitude of boundaries of model levels (cm) +! odcol Optical depth at each model level +! masfac Conversion factor for pressure to column density +! +! TJ Temperature profile on model grid +! DM Air column for each model level (molecules.cm-2) +! DO3 Ozone column for each model level (molecules.cm-2) +! DBC Mass of Black Carbon at each model level (g.cm-3) ! .....! +! PSTD Approximate pressures of levels for supplied climatology +! +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD + real(kind=double) my_ozone(kmaxd) !real*8 version of ozone mixing ratios + real tauaer_550 + integer iozone + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point +!jdf + real*8 pstd(52),oref2(51),tref2(51),bref2(51) + real*8 odcol(lpar),dlogp,f0,t0,b0,pb,pc,xc,masfac,scaleh + real vis, aerd1, aerd2 + + integer i, k, l, m + integer isvode,jsvode + + pj(NB+1) = 0.d0 ! define top level + +! +! Set up cloud and surface properties + call CLDSRF(isvode,jsvode,odcol,nslat,nslon,p,t,od,sa,lpar,jpnl) + +! Mass factor - delta-Pressure (mbars) to delta-Column (molecules.cm-2) + masfac=100.d0*6.022d+23/(28.97d0*9.8d0*10.d0) +! +! Set up pressure levels for O3/T climatology - assume that value +! given for each 2 km z* level applies from 1 km below to 1 km above, +! so select pressures at these boundaries. Surface level values at +! 1000 mb are assumed to extend down to the actual P(nslon,nslat). +! + pstd(1) = max(pj(1),1000.d0) + pstd(2) = 1000.d0*10.d0**(-1.d0/16.d0) + dlogp = 10.d0**(-2.d0/16.d0) + do i=3,51 + pstd(i) = pstd(i-1)*dlogp + enddo + pstd(52) = 0.d0 +! +! Select appropriate monthly and latitudinal profiles + m = max(1,min(12,month_fastj)) + l = max(1,min(18,(int(ydgrd(nslat))+99)/10)) +! +! Temporary arrays for climatology data + do i=1,51 + oref2(i)=oref(i,l,m) + tref2(i)=tref(i,l,m) + bref2(i)=bref(i) + enddo +! +! Apportion O3 and T on supplied climatology z* levels onto CTM levels +! with mass (pressure) weighting, assuming constant mixing ratio and +! temperature half a layer on either side of the point supplied. +! + do i = 1,NB + F0 = 0.d0 + T0 = 0.d0 + B0 = 0.d0 + do k = 1,51 + PC = min(pj(i),pstd(k)) + PB = max(pj(i+1),pstd(k+1)) + if(PC.gt.PB) then + XC = (PC-PB)/(pj(i)-pj(i+1)) + F0 = F0 + oref2(k)*XC + T0 = T0 + tref2(k)*XC + B0 = B0 + bref2(k)*XC + endif + enddo + TJ(i) = T0 + DO3(i)= F0*1.d-6 + DBC(i)= B0 + enddo +! +! Insert model values here to replace or supplement climatology. +! Note that CTM temperature is always used in x-section calculations +! (see JRATET); TJ is used in actinic flux calculation only. +! + do i=1,lpar ! JCB code change; just use climatlogy for upper levels + if(i.le.iozone)DO3(i) = my_ozone(i) ! Volume Mixing Ratio +! TJ(i) = T(nslon,nslat,I) ! Kelvin +! JCB - overwrite climatology +! TJ(i) = (T(nslon,nslat,i)+T(nslon,nslat,i+1))/2. ! JCB - take midpoint +! code change - now take temperature as appropriate for midpoint of layer + TJ(i)=T(nslon,nslat,i) + enddo + if(lpar+1.le.iozone)then + DO3(lpar+1) = my_ozone(lpar+1) ! Above top of model (or use climatology) + endif +! TJ(lpar+1) = my_temp(lpar) ! Above top of model (or use climatology) +!wig 26-Aug-2000: Comment out following line so that climatology is used for +! above the model top. +! TJ(lpar+1) = T(nslon,nslat,NB) ! JCB - just use climatology or given temperature +! JCB read in O3 +! +! +! Calculate effective altitudes using scale height at each level + z(1) = 0.d0 + do i=1,lpar + scaleh=1.3806d-19*masfac*TJ(i) + z(i+1) = z(i)-(log(pj(i+1)/pj(i))*scaleh) + enddo +! +! Add Aerosol Column - include aerosol types here. Currently use soot +! water and ice; assume black carbon x-section of 10 m2/g, independent +! of wavelength; assume limiting temperature for ice of -40 deg C. + + do i=1,lpar +! AER(1,i) = DBC(i)*10.d0*(z(i+1)-z(i)) ! DBC must be g/m^3 +! calculate AER(1,i) according to aerosol density - use trap rule + vis=23.0 + call aeroden(z(i)/100000.,vis,aerd1) ! convert cm to km + call aeroden(z(i+1)/100000.,vis,aerd2) +! trap rule used here; convert cm to km; divide by 100000. + AER(1,i)=(z(i+1)-z(i))/100000.*(aerd1+aerd2)/2./4287.55*tauaer_550 +! write(6,*)i,z(i)/100000.,aerd1,aerd2,tauaer_550,AER(1,i) +! + if(T(nslon,nslat,I).gt.233.d0) then + AER(2,i) = odcol(i) + AER(3,i) = 0.d0 + else + AER(2,i) = 0.d0 + AER(3,i) = odcol(i) + endif + enddo + do k=1,MX + AER(k,lpar+1) = 0.d0 ! just set equal to zero + enddo + + AER(1,lpar+1)=2.0*AER(1,lpar) ! kludge +! +! Calculate column quantities for Fast-J + do i=1,NB + DM(i) = (PJ(i)-PJ(i+1))*masfac + DO3(i) = DO3(i)*DM(i) + enddo +! + end subroutine set_prof + +!****************************************************************** +! SUBROUTINE CLDSRF(odcol) + SUBROUTINE CLDSRF(isvode,jsvode,odcol,nslat,nslon,p,t,od,sa, & + lpar,jpnl) +!----------------------------------------------------------------------- +! Routine to set cloud and surface properties +!----------------------------------------------------------------------- +! rflect Surface albedo (Lambertian) +! odmax Maximum allowed optical depth, above which they are scaled +! odcol Optical depth at each model level +! odsum Column optical depth +! nlbatm Level of lower photolysis boundary - usually surface +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD +!jdf + integer i, j, k + integer isvode, jsvode + real*8 odcol(lpar), odsum, odmax, odtot +! +! Default lower photolysis boundary as bottom of level 1 + nlbatm = 1 +! +! Set surface albedo + RFLECT = dble(SA(nslon,nslat)) + RFLECT = max(0.d0,min(1.d0,RFLECT)) +! +! Zero aerosol column + do k=1,MX + do i=1,NB + AER(k,i) = 0.d0 + enddo + enddo +! +! Scale optical depths as appropriate - limit column to 'odmax' + odmax = 200.d0 + odsum = 0.d0 + do i=1,lpar + odcol(i) = dble(OD(nslon,nslat,i)) + odsum = odsum + odcol(i) +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf odcol',odcol(i),odsum + enddo + if(odsum.gt.odmax) then + odsum = odmax/odsum + do i=1,lpar + odcol(i) = odcol(i)*odsum + enddo + odsum = odmax + endif +! Set sub-division switch if appropriate + odtot=0.d0 + jadsub(nb)=0 + jadsub(nb-1)=0 + do i=nb-1,1,-1 + k=2*i + jadsub(k)=0 + jadsub(k-1)=0 + odtot=odtot+odcol(i) + if(odcol(i).gt.0.d0.and.dtausub.gt.0.d0) then + if(odtot.le.dtausub) then + jadsub(k)=1 + jadsub(k-1)=1 +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf in cldsf1',i,k,jadsub(k) + elseif(odtot.gt.dtausub) then + jadsub(k)=1 + jadsub(k-1)=0 + do j=1,2*(i-1) + jadsub(j)=0 + enddo +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf in cldsf2',i,k,jadsub(k) + go to 20 + endif + endif + enddo + 20 continue +! + return + end SUBROUTINE CLDSRF + +!******************************************************************** + subroutine solar2(timej,nslat,nslon, & + xgrd,ygrd,tau_fastj,month_fastj,iday_fastj) +!----------------------------------------------------------------------- +! Routine to set up SZA for given lat, lon and time +!----------------------------------------------------------------------- +! timej Offset in hours from start of timestep to time J-values +! required for - take as half timestep for mid-step Js. +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point +!jdf + real*8 pi_fastj, pi180, loct, timej + real*8 sindec, soldek, cosdec, sinlat, sollat, coslat, cosz +! + pi_fastj=3.141592653589793D0 + pi180=pi_fastj/180.d0 + sindec=0.3978d0*sin(0.9863d0*(dble(iday_fastj)-80.d0)*pi180) + soldek=asin(sindec) + cosdec=cos(soldek) + sinlat=sin(ygrd(nslat)) + sollat=asin(sinlat) + coslat=cos(sollat) +! + loct = (((tau_fastj+timej)*15.d0)-180.d0)*pi180 + xgrd(nslon) + cosz = cosdec*coslat*cos(loct) + sindec*sinlat + sza = acos(cosz)/pi180 + U0 = cos(SZA*pi180) +! + return + end subroutine solar2 + +!********************************************************************** + + + SUBROUTINE JRATET(SOLF,nslat,nslon,p,t,od,sa,lpar,jpnl) +!----------------------------------------------------------------------- +! Calculate and print J-values. Note that the loop in this routine +! only covers the jpnl levels actually needed by the CTM. +!----------------------------------------------------------------------- +! +! FFF Actinic flux at each level for each wavelength bin +! QQQ Cross sections for species (read in in RD_TJPL) +! SOLF Solar distance factor, for scaling; normally given by: +! 1.0-(0.034*cos(real(iday_fastj-186)*2.0*pi_fastj/365.)) +! Assumes aphelion day 186, perihelion day 3. +! TQQ Temperatures at which QQQ cross sections supplied +! +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD +!jdf + integer i, j, k + real*8 qo2tot, qo3tot, qo31d, qo33p, qqqt +! real*8 xseco2, xseco3, xsec1d, solf, tfact + real*8 solf, tfact +! + do I=1,jpnl + VALJ(1) = 0.d0 + VALJ(2) = 0.d0 + VALJ(3) = 0.d0 + do K=NW1,NW2 ! Using model 'T's here + QO2TOT= xseco2(K,dble(T(nslon,nslat,I))) + VALJ(1) = VALJ(1) + QO2TOT*FFF(K,I) + QO3TOT= xseco3(K,dble(T(nslon,nslat,I))) + QO31D = xsec1d(K,dble(T(nslon,nslat,I)))*QO3TOT + QO33P = QO3TOT - QO31D + VALJ(2) = VALJ(2) + QO33P*FFF(K,I) + VALJ(3) = VALJ(3) + QO31D*FFF(K,I) + enddo +!------Calculate remaining J-values with T-dep X-sections + do J=4,NJVAL + VALJ(J) = 0.d0 + TFACT = 0.d0 + if(TQQ(2,J).gt.TQQ(1,J)) TFACT = max(0.d0,min(1.d0, & + (T(nslon,nslat,I)-TQQ(1,J))/(TQQ(2,J)-TQQ(1,J)) )) + do K=NW1,NW2 + QQQT = QQQ(K,1,J-3) + (QQQ(K,2,J-3) - QQQ(K,1,J-3))*TFACT + VALJ(J) = VALJ(J) + QQQT*FFF(K,I) +!------Additional code for pressure dependencies +! if(jpdep(J).ne.0) then +! VALJ(J) = VALJ(J) + QQQT*FFF(K,I)* +! $ (zpdep(K,L)*(pj(i)+pj(i+1))*0.5d0) +! endif + enddo + enddo + do j=1,jppj + zj(i,j)=VALJ(jind(j))*jfacta(j)*SOLF + enddo +! Herzberg bin + do j=1,nhz + zj(i,hzind(j))=hztoa(j)*fhz(i)*SOLF + enddo + enddo + return + end SUBROUTINE JRATET + +!********************************************************************* + + + SUBROUTINE PRTATM(N,nslat,nslon,tau_fastj,month_fastj,ydgrd) +!----------------------------------------------------------------------- +! Print out the atmosphere and calculate appropriate columns +! N=1 Print out column totals only +! N=2 Print out full columns +! N=3 Print out full columns and climatology +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nslat ! Latitude of current profile point + integer nslon ! Longitude of current profile point +!jdf + integer n, i, k, l, m + real*8 COLO3(NB),COLO2(NB),COLAX(MX,NB),ZKM,ZSTAR,PJC + real*8 climat(9),masfac,dlogp + if(N.eq.0) return +!---Calculate columns, for diagnostic output only: + COLO3(NB) = DO3(NB) + COLO2(NB) = DM(NB)*0.20948d0 + do K=1,MX + COLAX(K,NB) = AER(K,NB) + enddo + do I=NB-1,1,-1 + COLO3(i) = COLO3(i+1)+DO3(i) + COLO2(i) = COLO2(i+1)+DM(i)*0.20948d0 + do K=1,MX + COLAX(k,i) = COLAX(k,i+1)+AER(k,i) + enddo + enddo + write(*,1200) ' Tau=',tau_fastj,' SZA=',sza + write(*,1200) ' O3-column(DU)=',COLO3(1)/2.687d16, & + ' column aerosol @1000nm=',(COLAX(K,1),K=1,MX) +!---Print out atmosphere + if(N.gt.1) then + write(*,1000) (' AER-X ','col-AER',k=1,mx) + do I=NB,1,-1 + PJC = PJ(I) + ZKM =1.d-5*Z(I) + ZSTAR = 16.d0*DLOG10(1013.d0/PJC) + write(*,1100) I,ZKM,ZSTAR,DM(I),DO3(I),1.d6*DO3(I)/DM(I), & + TJ(I),PJC,COLO3(I),COLO2(I),(AER(K,I),COLAX(K,I),K=1,MX) + enddo + endif +! +!---Print out climatology + if(N.gt.2) then + do i=1,9 + climat(i)=0.d0 + enddo + m = max(1,min(12,month_fastj)) + l = max(1,min(18,(int(ydgrd(nslat))+99)/10)) + masfac=100.d0*6.022d+23/(28.97d0*9.8d0*10.d0) + write(*,*) 'Specified Climatology' + write(*,1000) + do i=51,1,-1 + dlogp=10.d0**(-1.d0/16.d0) + PJC = 1000.d0*dlogp**(2*i-2) + climat(1) = 16.d0*DLOG10(1000.D0/PJC) + climat(2) = climat(1) + climat(3) = PJC*(1.d0/dlogp-dlogp)*masfac + if(i.eq.1) climat(3)=PJC*(1.d0-dlogp)*masfac + climat(4)=climat(3)*oref(i,l,m)*1.d-6 + climat(5)=oref(i,l,m) + climat(6)=tref(i,l,m) + climat(7)=PJC + climat(8)=climat(8)+climat(4) + climat(9)=climat(9)+climat(3)*0.20948d0 + write(*,1100) I,(climat(k),k=1,9) + enddo + write(*,1200) ' O3-column(DU)=',climat(8)/2.687d16 + endif + return + 1000 format(5X,'Zkm',3X,'Z*',8X,'M',8X,'O3',6X,'f-O3',5X,'T',7X,'P',6x, & + 'col-O3',3X,'col-O2',2X,10(a7,2x)) + 1100 format(1X,I2,0P,2F6.2,1P,2E10.3,0P,F7.3,F8.2,F10.4,1P,10E9.2) + 1200 format(A,F8.1,A,10(1pE10.3)) + end SUBROUTINE PRTATM + + SUBROUTINE JVALUE(isvode,jsvode,lpar,jpnl, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------------------------------------- +! Calculate the actinic flux at each level for the current SZA value. +! quit when SZA > 98.0 deg ==> tangent height = 63 km +! or 99. 80 km +!----------------------------------------------------------------------- +! +! AVGF Attenuation of beam at each level for each wavelength +! FFF Actinic flux at each desired level +! FHZ Actinic flux in Herzberg bin +! WAVE Effective wavelength of each wavelength bin +! XQO2 Absorption cross-section of O2 +! XQO3 Absorption cross-section of O3 +! +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + USE module_peg_util, only: peg_message +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + real(kind=double), dimension(ipar_fastj,jpar) :: P , SA + real(kind=double), dimension(ipar_fastj,jpar,kmaxd+1) :: T, OD + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / +!jdf + integer j, k +! real*8 wave, xseco3, xseco2 + real*8 wave + real*8 AVGF(lpar),XQO3(NB),XQO2(NB) +! diagnostics for error situations +! integer lunout +! parameter (lunout = 41) + integer isvode,jsvode + character*80 msg +! + do J=1,jpnl + do K=NW1,NW2 + FFF(K,J) = 0.d0 + enddo + FHZ(J) = 0.d0 + enddo +! +!---SZA check + if(SZA.gt.szamax) GOTO 99 +! +!---Calculate spherical weighting functions + CALL SPHERE(lpar) +! +!---Loop over all wavelength bins + do K=NW1,NW2 + WAVE = WL(K) + do J=1,NB + XQO3(J) = xseco3(K,dble(TJ(J))) + enddo + do J=1,NB + XQO2(J) = xseco2(K,dble(TJ(J))) + enddo +!----------------------------------------- + CALL OPMIE(isvode,jsvode,K,WAVE,XQO2,XQO3,AVGF,lpar,jpnl, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------- + do J=1,jpnl + FFF(K,J) = FFF(K,J) + FL(K)*AVGF(J) +! diagnostic + if ( FFF(K,J) .lt. 0) then + write( msg, '(a,2i4,e14.6)' ) & + 'FASTJ neg actinic flux ' // & + 'k j FFF(K,J) ', k, j, fff(k,j) + call peg_message( lunerr, msg ) + end if +! end diagnostic + enddo + enddo +! +!---Herzberg continuum bin above 10 km, if required + if(NHZ.gt.0) then + K=NW2+1 + WAVE = 204.d0 + do J=1,NB + XQO3(J) = HZO3 + XQO2(J) = HZO2 + enddo + CALL OPMIE(isvode,jsvode,K,WAVE,XQO2,XQO3,AVGF,lpar,jpnl, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) + do J=1,jpnl + if(z(j).gt.1.d6) FHZ(J)=AVGF(J) + enddo + endif +! + 99 continue + 1000 format(' SZA=',f6.1,' Reflectvty=',f6.3,' OD=',10(1pe10.3)) + + return + end SUBROUTINE JVALUE + + FUNCTION xseco3(K,TTT) +!----------------------------------------------------------------------- +! Cross-sections for O3 for all processes interpolated across 3 temps +!----------------------------------------------------------------------- + + USE module_fastj_data + + integer k +! real*8 ttt, flint, xseco3 + real*8 ttt, xseco3 + xseco3 = & + flint(TTT,TQQ(1,2),TQQ(2,2),TQQ(3,2),QO3(K,1),QO3(K,2),QO3(K,3)) + return + end FUNCTION xseco3 + + FUNCTION xsec1d(K,TTT) +!----------------------------------------------------------------------- +! Quantum yields for O3 --> O2 + O(1D) interpolated across 3 temps +!----------------------------------------------------------------------- + + USE module_fastj_data + + integer k +! real*8 ttt, flint, xsec1d + real*8 ttt, xsec1d + xsec1d = & + flint(TTT,TQQ(1,3),TQQ(2,3),TQQ(3,3),Q1D(K,1),Q1D(K,2),Q1D(K,3)) + return + end FUNCTION xsec1d + + FUNCTION xseco2(K,TTT) +!----------------------------------------------------------------------- +! Cross-sections for O2 interpolated across 3 temps; No S_R Bands yet! +!----------------------------------------------------------------------- + + USE module_fastj_data + + integer k +! real*8 ttt, flint, xseco2 + real*8 ttt, xseco2 + xseco2 = & + flint(TTT,TQQ(1,1),TQQ(2,1),TQQ(3,1),QO2(K,1),QO2(K,2),QO2(K,3)) + return + end FUNCTION xseco2 + + REAL*8 FUNCTION flint (TINT,T1,T2,T3,F1,F2,F3) +!----------------------------------------------------------------------- +! Three-point linear interpolation function +!----------------------------------------------------------------------- + real*8 TINT,T1,T2,T3,F1,F2,F3 + IF (TINT .LE. T2) THEN + IF (TINT .LE. T1) THEN + flint = F1 + ELSE + flint = F1 + (F2 - F1)*(TINT -T1)/(T2 -T1) + ENDIF + ELSE + IF (TINT .GE. T3) THEN + flint = F3 + ELSE + flint = F2 + (F3 - F2)*(TINT -T2)/(T3 -T2) + ENDIF + ENDIF + return + end FUNCTION flint + + SUBROUTINE SPHERE(lpar) +!----------------------------------------------------------------------- +! Calculation of spherical geometry; derive tangent heights, slant path +! lengths and air mass factor for each layer. Not called when +! SZA > 98 degrees. Beyond 90 degrees, include treatment of emergent +! beam (where tangent height is below altitude J-value desired at). +!----------------------------------------------------------------------- +! +! GMU MU, cos(solar zenith angle) +! RZ Distance from centre of Earth to each point (cm) +! RQ Square of radius ratios +! TANHT Tangent height for the current SZA +! XL Slant path between points +! AMF Air mass factor for slab between level and level above +! +!----------------------------------------------------------------------- + + USE module_fastj_data + +!jdf + integer lpar +!jdf + integer i, j, k, ii + real*8 airmas, gmu, xmu1, xmu2, xl, diff + REAL*8 Ux,H,RZ(NB),RQ(NB),ZBYR +! +! Inlined air mass factor function for top of atmosphere + AIRMAS(Ux,H) = (1.0d0+H)/SQRT(Ux*Ux+2.0d0*H*(1.0d0- & + 0.6817d0*EXP(-57.3d0*ABS(Ux)/SQRT(1.0d0+5500.d0*H))/ & + (1.0d0+0.625d0*H))) +! + GMU = U0 + RZ(1)=RAD+Z(1) + ZBYR = ZZHT/RAD + DO 2 II=2,NB + RZ(II) = RAD + Z(II) + RQ(II-1) = (RZ(II-1)/RZ(II))**2 + 2 CONTINUE + IF (GMU.LT.0.0D0) THEN + TANHT = RZ(nlbatm)/DSQRT(1.0D0-GMU**2) + ELSE + TANHT = RZ(nlbatm) + ENDIF +! +! Go up from the surface calculating the slant paths between each level +! and the level above, and deriving the appropriate Air Mass Factor + DO 16 J=1,NB + DO K=1,NB + AMF(K,J)=0.D0 + ENDDO +! +! Air Mass Factors all zero if below the tangent height + IF (RZ(J).LT.TANHT) GOTO 16 +! Ascend from layer J calculating AMFs + XMU1=ABS(GMU) + DO 12 I=J,lpar + XMU2=DSQRT(1.0D0-RQ(I)*(1.0D0-XMU1**2)) + XL=RZ(I+1)*XMU2-RZ(I)*XMU1 + AMF(I,J)=XL/(RZ(I+1)-RZ(I)) + XMU1=XMU2 + 12 CONTINUE +! Use function and scale height to provide AMF above top of model + AMF(NB,J)=AIRMAS(XMU1,ZBYR) +! +! Twilight case - Emergent Beam + IF (GMU.GE.0.0D0) GOTO 16 + XMU1=ABS(GMU) +! Descend from layer J + DO 14 II=J-1,1,-1 + DIFF=RZ(II+1)*DSQRT(1.0D0-XMU1**2)-RZ(II) + if(II.eq.1) DIFF=max(DIFF,0.d0) ! filter +! Tangent height below current level - beam passes through twice + IF (DIFF.LT.0.0D0) THEN + XMU2=DSQRT(1.0D0-(1.0D0-XMU1**2)/RQ(II)) + XL=ABS(RZ(II+1)*XMU1-RZ(II)*XMU2) + AMF(II,J)=2.d0*XL/(RZ(II+1)-RZ(II)) + XMU1=XMU2 +! Lowest level intersected by emergent beam + ELSE + XL=RZ(II+1)*XMU1*2.0D0 +! WTING=DIFF/(RZ(II+1)-RZ(II)) +! AMF(II,J)=(1.0D0-WTING)*2.D0**XL/(RZ(II+1)-RZ(II)) + AMF(II,J)=XL/(RZ(II+1)-RZ(II)) + GOTO 16 + ENDIF + 14 CONTINUE +! + 16 CONTINUE + RETURN + END SUBROUTINE SPHERE + + + SUBROUTINE OPMIE(isvode,jsvode,KW,WAVEL,XQO2,XQO3,FMEAN,lpar,jpnl, & + ydgrd,sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) +!----------------------------------------------------------------------- +! NEW Mie code for J's, only uses 8-term expansion, 4-Gauss pts +! Currently allow up to NP aerosol phase functions (at all altitudes) to +! be associated with optical depth AER(1:NC) = aerosol opt.depth @ 1000 nm +! +! Pick Mie-wavelength with phase function and Qext: +! +! 01 RAYLE = Rayleigh phase +! 02 ISOTR = isotropic +! 03 ABSRB = fully absorbing 'soot', wavelength indep. +! 04 S_Bkg = backgrnd stratospheric sulfate (n=1.46,log-norm:r=.09um/sigma=.6) +! 05 S_Vol = volcanic stratospheric sulfate (n=1.46,log-norm:r=.08um/sigma=.8) +! 06 W_H01 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.1um /alpha=2) +! 07 W_H04 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.4um /alpha=2) +! 08 W_C02 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=2.0um /alpha=6) +! 09 W_C04 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=4.0um /alpha=6) +! 10 W_C08 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=8.0um /alpha=6) +! 11 W_C13 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=13.3um /alpha=6) +! 12 W_L06 = water cloud (Lacis) (n=1.335, r-mode=5.5um / alpha=11/3) +! 13 Ice-H = hexagonal ice cloud (Mishchenko) +! 14 Ice-I = irregular ice cloud (Mishchenko) +! +! Choice of aerosol index MIEDX is made in SET_AER; optical depths are +! apportioned to the AER array in SET_PROF +! +!----------------------------------------------------------------------- +! FUNCTION RAYLAY(WAVE)---RAYLEIGH CROSS-SECTION for wave > 170 nm +! WSQI = 1.E6/(WAVE*WAVE) +! REFRM1 = 1.0E-6*(64.328+29498.1/(146.-WSQI)+255.4/(41.-WSQI)) +! RAYLAY = 5.40E-21*(REFRM1*WSQI)**2 +!----------------------------------------------------------------------- +! +! DTAUX Local optical depth of each CTM level +! PIRAY Contribution of Rayleigh scattering to extinction +! PIAER Contribution of Aerosol scattering to extinction +! TTAU Optical depth of air vertically above each point (to top of atm) +! FTAU Attenuation of solar beam +! POMEGA Scattering phase function +! FMEAN Mean actinic flux at desired levels +! +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + USE module_peg_util, only: peg_message, peg_error_fatal +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year + integer nspint ! Num of spectral intervals across solar + parameter ( nspint = 4 ) ! spectrum for FAST-J + real, dimension (nspint),save :: wavmid !cm + real, dimension (nspint, kmaxd+1) :: sizeaer,extaer,waer,gaer,tauaer + real, dimension (nspint, kmaxd+1) :: l2,l3,l4,l5,l6,l7 + data wavmid & + / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 / + INTEGER NL, N__, M__ + PARAMETER (NL=500, N__=2*NL, M__=4) !wig increased nl from 350 to 500, 31-Oct-2005 + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer jndlev(lpar),jaddlv(nc),jaddto(nc+1) + integer KW,km,i,j,k,l,ix,j1 + integer isvode,jsvode + real*8 QXMIE(MX),XLAER(MX),SSALB(MX) + real*8 xlo2,xlo3,xlray,xltau,zk,taudn,tauup,zk2 + real*8 WAVEL,XQO2(NB),XQO3(NB),FMEAN(lpar),POMEGAJ(2*M__,NC+1) + real*8 DTAUX(NB),PIRAY(NB),PIAER(MX,NB),TTAU(NC+1),FTAU(NC+1) + real*8 ftaulog,dttau,dpomega(2*M__) + real*8 ftaulog2,dttau2,dpomega2(2*M__) +! JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ + real*8 PIAER_MX1(NB) +! BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + character*80 msg +! +!---Pick nearest Mie wavelength, no interpolation-------------- + KM=1 + if( WAVEL .gt. 355.d0 ) KM=2 + if( WAVEL .gt. 500.d0 ) KM=3 +! if( WAVEL .gt. 800.d0 ) KM=4 !drop the 1000 nm wavelength +! +!---For Mie code scale extinction at 1000 nm to wavelength WAVEL (QXMIE) +! define angstrom exponent +! JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ + ang=log(QAA(1,MIEDX(1))/QAA(4,MIEDX(1)))/log(300./999.) + do I=1,MX +! QAA is extinction efficiency + QXMIE(I) = QAA(KM,MIEDX(I))/QAA(4,MIEDX(I)) +! scale to 550 nm using angstrom relationship +! note that this gives QXMIE at 550.0 nm = 1.0, aerosol optical thickness +! is defined at 550 nm +! convention -- I = 1 is aerosol, I > 1 are clouds + if(I.eq.1) QXMIE(I) = (WAVEL/550.0)**ang + SSALB(I) = SSA(KM,MIEDX(I)) ! single scattering albedo + enddo +! BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB +! +!---Reinitialize arrays + do j=1,nc+1 + ttau(j)=0.d0 + ftau(j)=0.d0 + enddo +! +!---Set up total optical depth over each CTM level, DTAUX + J1 = NLBATM + do J=J1,NB + XLO3=DO3(J)*XQO3(J) + XLO2=DM(J)*XQO2(J)*0.20948d0 + XLRAY=DM(J)*QRAYL(KW) +! Zero absorption for testing purposes +! call NOABS(XLO3,XLO2,XLRAY,AER(1,j),RFLECT) + do I=1,MX +! I is aerosol type, j is level, AER(I,J)*QXMIE(I) is the layer aerosol optical thickness +! at 1000 nm , AER(I,J), times extinction efficiency for the layer (normalized to be one at 1000 nm) +! therefore xlaer(i) is the layer optical depth at the wavelength index KM + XLAER(I)=AER(I,J)*QXMIE(I) + enddo +! Total optical depth from all elements + DTAUX(J)=XLO3+XLO2+XLRAY + do I=1,MX + DTAUX(J)=DTAUX(J)+XLAER(I) +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf xlaer',& +! i,j,km,dtaux(j),xlaer(i),aer(i,j),qxmie(i),xlo3,xlo2,xlray + enddo +! JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ +! add in new aerosol information from Mie code +! layer aerosol optical thickness at wavelength index KM, layer j +! tauaer(km,j)=0.0 + dtaux(j)=dtaux(j)+tauaer(km,j) +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf dtaux',& +! j,km,dtaux(j),tauaer(km,j) +! BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB +! Fractional extinction for Rayleigh scattering and each aerosol type + PIRAY(J)=XLRAY/DTAUX(J) + do I=1,MX + PIAER(I,J)=SSALB(I)*XLAER(I)/DTAUX(J) + enddo +! JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ +! note the level is now important + PIAER_MX1(J)=waer(km,j)*tauaer(km,j)/DTAUX(J) +! BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + enddo ! of the level "j" loop +! +!---Define the scattering phase fn. with mix of Rayleigh(1) & Mie(MIEDX) +! No. of quadrature pts fixed at 4 (M__), expansion of phase fn @ 8 + N = M__ + MFIT = 2*M__ + do j=j1,NB ! jcb: layer index + do i=1,MFIT + pomegaj(i,j) = PIRAY(J)*PAA(I,KM,1) ! jcb: paa are the expansion coefficients of the phase function + do k=1,MX ! jcb: mx is # of aerosols + pomegaj(i,j) = pomegaj(i,j) + PIAER(K,J)*PAA(I,KM,MIEDX(K)) + enddo + enddo +! JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ +! i is the # of coefficients, KM is the wavelength index, j is the level +! note the level in now relevant because we allow aerosol properties to +! vary by level + pomegaj(1,j) = pomegaj(1,j) + PIAER_MX1(J)*1.0 ! 1.0 is l0 + pomegaj(2,j) = pomegaj(2,j) + PIAER_MX1(J)*gaer(KM,j)*3.0 ! the three converts gear to l1 + pomegaj(3,j) = pomegaj(3,j) + PIAER_MX1(J)*l2(KM,j) + pomegaj(4,j) = pomegaj(4,j) + PIAER_MX1(J)*l3(KM,j) + pomegaj(5,j) = pomegaj(5,j) + PIAER_MX1(J)*l4(KM,j) + pomegaj(6,j) = pomegaj(6,j) + PIAER_MX1(J)*l5(KM,j) + pomegaj(7,j) = pomegaj(7,j) + PIAER_MX1(J)*l6(KM,j) + pomegaj(8,j) = pomegaj(7,j) + PIAER_MX1(J)*l7(KM,j) +! BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + + enddo +! +!---Calculate attenuated incident beam EXP(-TTAU/U0) and flux on surface + do J=J1,NB + if(AMF(J,J).gt.0.0D0) then + XLTAU=0.0D0 + do I=1,NB + XLTAU=XLTAU + DTAUX(I)*AMF(I,J) + enddo + if(XLTAU.gt.450.d0) then ! for compilers with no underflow trapping + FTAU(j)=0.d0 + else + FTAU(J)=DEXP(-XLTAU) + endif + else + FTAU(J)=0.0D0 + endif + enddo + if(U0.gt.0.D0) then + ZFLUX = U0*FTAU(J1)*RFLECT/(1.d0+RFLECT) + else + ZFLUX = 0.d0 + endif +! +!------------------------------------------------------------------------ +! Take optical properties on CTM layers and convert to a photolysis +! level grid corresponding to layer centres and boundaries. This is +! required so that J-values can be calculated for the centre of CTM +! layers; the index of these layers is kept in the jndlev array. +!------------------------------------------------------------------------ +! +! Set lower boundary and levels to calculate J-values at + J1=2*J1-1 + do j=1,lpar + jndlev(j)=2*j + enddo +! +! Calculate column optical depths above each level, TTAU + TTAU(NC+1)=0.0D0 + do J=NC,J1,-1 + I=(J+1)/2 + TTAU(J)=TTAU(J+1) + 0.5d0*DTAUX(I) + jaddlv(j)=int(0.5d0*DTAUX(I)/dtaumax) +! Subdivide cloud-top levels if required + if(jadsub(j).gt.0) then + jadsub(j)=min(jaddlv(j)+1,nint(dtausub))*(nint(dsubdiv)-1) + jaddlv(j)=jaddlv(j)+jadsub(j) + endif +! if(isvode.eq.8.and.jsvode.eq.1) print*,'jdf in opmie',& +! j,jadsub(j),jaddlv(j),ttau(j),dtaux(i) + enddo +! +! Calculate attenuated beam, FTAU, level boundaries then level centres + FTAU(NC+1)=1.0D0 + do J=NC-1,J1,-2 + I=(J+1)/2 + FTAU(J)=FTAU(I) + enddo + do J=NC,J1,-2 + FTAU(J)=sqrt(FTAU(J+1)*FTAU(J-1)) + enddo +! +! Calculate scattering properties, level centres then level boundaries +! using an inverse interpolation to give correctly-weighted values + do j=NC,J1,-2 + do i=1,MFIT + pomegaj(i,j) = pomegaj(i,j/2) + enddo + enddo + do j=J1+2,nc,2 + taudn = ttau(j-1)-ttau(j) + tauup = ttau(j)-ttau(j+1) + do i=1,MFIT + pomegaj(i,j) = (pomegaj(i,j-1)*taudn + & + pomegaj(i,j+1)*tauup) / (taudn+tauup) + enddo + enddo +! Define lower and upper boundaries + do i=1,MFIT + pomegaj(i,J1) = pomegaj(i,J1+1) + pomegaj(i,nc+1) = pomegaj(i,nc) + enddo +! +!------------------------------------------------------------------------ +! Calculate cumulative total and define levels we want J-values at. +! Sum upwards for levels, and then downwards for Mie code readjustments. +! +! jaddlv(i) Number of new levels to add between (i) and (i+1) +! jaddto(i) Total number of new levels to add to and above level (i) +! jndlev(j) Level needed for J-value for CTM layer (j) +! +!------------------------------------------------------------------------ +! +! Reinitialize level arrays + do j=1,nc+1 + jaddto(j)=0 + enddo +! + jaddto(J1)=jaddlv(J1) + do j=J1+1,nc + jaddto(j)=jaddto(j-1)+jaddlv(j) + enddo + if((jaddto(nc)+nc).gt.nl) then +! print*,'jdf mie',isvode,jsvode,jaddto(nc),nc,nl + write ( msg, '(a, 2i6)' ) & + 'FASTJ Max NL exceeded ' // & + 'jaddto(nc)+nc NL', jaddto(nc)+nc,NL + call peg_message( lunerr, msg ) + msg = 'FASTJ subr OPMIE error. Max NL exceeded' + call peg_error_fatal( lunerr, msg ) +! write(6,1500) jaddto(nc)+nc, 'NL',NL +! stop + endif + do i=1,lpar + jndlev(i)=jndlev(i)+jaddto(jndlev(i)-1) + enddo + jaddto(nc)=jaddlv(nc) + do j=nc-1,J1,-1 + jaddto(j)=jaddto(j+1)+jaddlv(j) + enddo +! +!---------------------SET UP FOR MIE CODE------------------------------- +! +! Transpose the ascending TTAU grid to a descending ZTAU grid. +! Double the resolution - TTAU points become the odd points on the +! ZTAU grid, even points needed for asymm phase fn soln, contain 'h'. +! Odd point added at top of grid for unattenuated beam (Z='inf') +! +! Surface: TTAU(1) now use ZTAU(2*NC+1) +! Top: TTAU(NC) now use ZTAU(3) +! Infinity: now use ZTAU(1) +! +! Mie scattering code only used from surface to level NC +!------------------------------------------------------------------------ +! +! Initialise all Fast-J optical property arrays + do k=1,N__ + do i=1,MFIT + pomega(i,k) = 0.d0 + enddo + ztau(k) = 0.d0 + fz(k) = 0.d0 + enddo +! +! Ascend through atmosphere transposing grid and adding extra points + do j=J1,nc+1 + k = 2*(nc+1-j)+2*jaddto(j)+1 + ztau(k)= ttau(j) + fz(k) = ftau(j) + do i=1,MFIT + pomega(i,k) = pomegaj(i,j) + enddo + enddo +! +! Check profiles if desired +! ND = 2*(NC+jaddto(J1)-J1) + 3 +! if(kw.eq.1) call CH_PROF +! +!------------------------------------------------------------------------ +! Insert new levels, working downwards from the top of the atmosphere +! to the surface (down in 'j', up in 'k'). This allows ztau and pomega +! to be incremented linearly (in a +ve sense), and the flux fz to be +! attenuated top-down (avoiding problems where lower level fluxes are +! zero). +! +! zk fractional increment in level +! dttau change in ttau per increment (linear, positive) +! dpomega change in pomega per increment (linear) +! ftaulog change in ftau per increment (exponential, normally < 1) +! +!------------------------------------------------------------------------ +! + do j=nc,J1,-1 + zk = 0.5d0/(1.d0+dble(jaddlv(j)-jadsub(j))) + dttau = (ttau(j)-ttau(j+1))*zk + do i=1,MFIT + dpomega(i) = (pomegaj(i,j)-pomegaj(i,j+1))*zk + enddo +! Filter attenuation factor - set minimum at 1.0d-05 + if(ftau(j+1).eq.0.d0) then + ftaulog=0.d0 + else + ftaulog = ftau(j)/ftau(j+1) + if(ftaulog.lt.1.d-150) then + ftaulog=1.0d-05 + else + ftaulog=exp(log(ftaulog)*zk) + endif + endif + k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1 + l = 0 +! Additional subdivision of first level if required + if(jadsub(j).ne.0) then + l=jadsub(j)/nint(dsubdiv-1) + zk2=1.d0/dsubdiv + dttau2=dttau*zk2 + ftaulog2=ftaulog**zk2 + do i=1,MFIT + dpomega2(i)=dpomega(i)*zk2 + enddo + do ix=1,2*(jadsub(j)+l) + ztau(k+1) = ztau(k) + dttau2 + fz(k+1) = fz(k)*ftaulog2 + do i=1,MFIT + pomega(i,k+1) = pomega(i,k) + dpomega2(i) + enddo + k = k+1 + enddo + endif + l = 2*(jaddlv(j)-jadsub(j)-l)+1 +! +! Add values at all intermediate levels + do ix=1,l + ztau(k+1) = ztau(k) + dttau + fz(k+1) = fz(k)*ftaulog + do i=1,MFIT + pomega(i,k+1) = pomega(i,k) + dpomega(i) + enddo + k = k+1 + enddo +! +! Alternate method to attenuate fluxes, fz, using 2nd-order finite +! difference scheme - just need to comment in section below +! ix = 2*(jaddlv(j)-jadsub(j))+1 +! if(l.le.0) then +! l=k-ix-1 +! else +! l=k-ix +! endif +! call efold(ftau(j+1),ftau(j),ix+1,fz(l)) +! if(jadsub(j).ne.0) then +! k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1 +! ix=2*(jadsub(j)+(jadsub(j)/nint(dsubdiv-1))) +! call efold(ftau(j+1),fz(k+ix),ix,fz(k)) +! endif +! + enddo +! +!---Update total number of levels and check doesn't exceed N__ + ND = 2*(NC+jaddto(J1)-J1) + 3 + if(nd.gt.N__) then + write ( msg, '(a, 2i6)' ) & + 'FASTJ Max N__ exceeded ' // & + 'ND N__', ND, N__ + call peg_message( lunerr, msg ) + msg = 'FASTJ subr OPMIE error. Max N__ exceeded' + call peg_error_fatal( lunerr, msg ) +! write(6,1500) ND, 'N__',N__ +! stop + endif +! +!---Add boundary/ground layer to ensure no negative J's caused by +!---too large a TTAU-step in the 2nd-order lower b.c. + ZTAU(ND+1) = ZTAU(ND)*1.000005d0 + ZTAU(ND+2) = ZTAU(ND)*1.000010d0 + zk=max(abs(U0),0.01d0) + zk=dexp(-ZTAU(ND)*5.d-6/zk) + FZ(ND+1) = FZ(ND)*zk + FZ(ND+2) = FZ(ND+1)*zk + do I=1,MFIT + POMEGA(I,ND+1) = POMEGA(I,ND) + POMEGA(I,ND+2) = POMEGA(I,ND) + enddo + ND = ND+2 +! + ZU0 = U0 + ZREFL = RFLECT +! +!----------------------------------------- + CALL MIESCT(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU,ZFLUX, & + ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +!----------------------------------------- +! Accumulate attenuation for selected levels + l=2*(NC+jaddto(J1))+3 + do j=1,lpar + k=l-(2*jndlev(j)) + if(k.gt.ND-2) then + FMEAN(j) = 0.d0 + else + FMEAN(j) = FJ(k) + endif + enddo +! + return + 1000 format(1x,i3,3(2x,1pe10.4),1x,i3) + 1300 format(1x,50(i3)) + 1500 format(' Too many levels in photolysis code: need ',i3,' but ',a, & + ' dimensioned as ',i3) + END SUBROUTINE OPMIE + +!********************************************************************* + subroutine EFOLD (F0, F1, N, F) +!----------------------------------------------------------------------- +!--- calculate the e-fold between two boundaries, given the value +!--- at both boundaries F0(x=0) = top, F1(x=1) = bottom. +!--- presume that F(x) proportional to exp[-A*x] for x=0 to x=1 +!--- d2F/dx2 = A*A*F and thus expect F1 = F0 * exp[-A] +!--- alternatively, could define A = ln[F0/F1] +!--- let X = A*x, d2F/dX2 = F +!--- assume equal spacing (not necessary, but makes this easier) +!--- with N-1 intermediate points (and N layers of thickness dX = A/N) +!--- +!--- 2nd-order finite difference: (F(i-1) - 2F(i) + F(i+1)) / dX*dX = F(i) +!--- let D = 1 / dX*dX: +! +! 1 | 1 0 0 0 0 0 | | F0 | +! | | | 0 | +! 2 | -D 2D+1 -D 0 0 0 | | 0 | +! | | | 0 | +! 3 | 0 -D 2D+1 -D 0 0 | | 0 | +! | | | 0 | +! | 0 0 -D 2D+1 -D 0 | | 0 | +! | | | 0 | +! N | 0 0 0 -D 2D+1 -D | | 0 | +! | | | 0 | +! N+1 | 0 0 0 0 0 1 | | F1 | +! +!----------------------------------------------------------------------- +! Advantage of scheme over simple attenuation factor: conserves total +! number of photons - very useful when using scheme for heating rates. +! Disadvantage: although reproduces e-folds very well for small flux +! differences, starts to drift off when many orders of magnitude are +! involved. +!----------------------------------------------------------------------- + implicit none + real*8 F0,F1,F(250) !F(N+1) + integer N + integer I + real*8 A,DX,D,DSQ,DDP1, B(101),R(101) +! + if(F0.eq.0.d0) then + do I=1,N + F(I)=0.d0 + enddo + return + elseif(F1.eq.0.d0) then + A = DLOG(F0/1.d-250) + else + A = DLOG(F0/F1) + endif +! + DX = float(N)/A + D = DX*DX + DSQ = D*D + DDP1 = D+D+1.d0 +! + B(2) = DDP1 + R(2) = +D*F0 + do I=3,N + B(I) = DDP1 - DSQ/B(I-1) + R(I) = +D*R(I-1)/B(I-1) + enddo + F(N+1) = F1 + do I=N,2,-1 + F(I) = (R(I) + D*F(I+1))/B(I) + enddo + F(1) = F0 + return + end subroutine EFOLD + + + subroutine CH_PROF(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & + ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +!----------------------------------------------------------------------- +! Check profiles to be passed to MIESCT +!----------------------------------------------------------------------- + + USE module_peg_util, only: peg_message + + implicit none +!jdf + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + INTEGER NL, N__, M__ + PARAMETER (NL=350, N__=2*NL, M__=4) + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer i,j + character*80 msg +! write(6,1100) 'lev','ztau','fz ','pomega( )' + do i=1,ND + if(ztau(i).ne.0.d0) then + write ( msg, '(a, i3, 2(1x,1pe9.3))' ) & + 'FASTJ subr CH_PROF ztau ne 0. check pomega. ' // & + 'k ztau(k) fz(k) ', i,ztau(i),fz(i) + call peg_message( lunerr, msg ) +! write(6,1200) i,ztau(i),fz(i),(pomega(j,i),j=1,8) + endif + enddo + return + 1100 format(1x,a3,4(a9,2x)) + 1200 format(1x,i3,11(1x,1pe9.3)) + end subroutine CH_PROF + + + SUBROUTINE MIESCT(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & + ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +! SUBROUTINE MIESCT +!----------------------------------------------------------------------- +! This is an adaption of the Prather radiative transfer code, (mjp, 10/95) +! Prather, 1974, Astrophys. J. 192, 787-792. +! Sol'n of inhomogeneous Rayleigh scattering atmosphere. +! (original Rayleigh w/ polarization) +! Cochran and Trafton, 1978, Ap.J., 219, 756-762. +! Raman scattering in the atmospheres of the major planets. +! (first use of anisotropic code) +! Jacob, Gottlieb and Prather, 1989, J.Geophys.Res., 94, 12975-13002. +! Chemistry of a polluted cloudy boundary layer, +! (documentation of extension to anisotropic scattering) +! +! takes atmospheric structure and source terms from std J-code +! ALSO limited to 4 Gauss points, only calculates mean field! +! +! mean rad. field ONLY (M=1) +! initialize variables FIXED/UNUSED in this special version: +! FTOP = 1.0 = astrophysical flux (unit of pi) at SZA, -ZU0, use for scaling +! FBOT = 0.0 = external isotropic flux on lower boundary +! SISOTP = 0.0 = Specific Intensity of isotropic radiation incident from top +! +! SUBROUTINES: MIESCT needs 'jv_mie.cmn' +! BLKSLV needs 'jv_mie.cmn' +! GEN (ID) needs 'jv_mie.cmn' +! LEGND0 (X,PL,N) +! MATIN4 (A) +! GAUSSP (N,XPT,XWT) +!----------------------------------------------------------------------- + +! INCLUDE 'jv_mie.h' + + implicit none +!jdf + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + INTEGER NL, N__, M__ + PARAMETER (NL=350, N__=2*NL, M__=4) + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer i, id, im + real*8 cmeq1 +!----------------------------------------------------------------------- +!---fix scattering to 4 Gauss pts = 8-stream + CALL GAUSSP (N,EMU,WT) +!---solve eqn of R.T. only for first-order M=1 +! ZFLUX = (ZU0*FZ(ND)*ZREFL+FBOT)/(1.0d0+ZREFL) + ZFLUX = (ZU0*FZ(ND)*ZREFL)/(1.0d0+ZREFL) + M=1 + DO I=1,N + CALL LEGND0 (EMU(I),PM0,MFIT) + DO IM=M,MFIT + PM(I,IM) = PM0(IM) + ENDDO + ENDDO +! + CMEQ1 = 0.25D0 + CALL LEGND0 (-ZU0,PM0,MFIT) + DO IM=M,MFIT + PM0(IM) = CMEQ1*PM0(IM) + ENDDO +! +! CALL BLKSLV + CALL BLKSLV(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU,ZFLUX, & + ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +! + DO ID=1,ND,2 + FJ(ID) = 4.0d0*FJ(ID) + FZ(ID) + ENDDO + + RETURN + END SUBROUTINE MIESCT + + SUBROUTINE BLKSLV(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & + ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +!----------------------------------------------------------------------- +! Solves the block tri-diagonal system: +! A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = H(I) +!----------------------------------------------------------------------- +! INCLUDE 'jv_mie.h' + + implicit none +!jdf + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + INTEGER NL, N__, M__ + PARAMETER (NL=350, N__=2*NL, M__=4) + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer i, j, k, id + real*8 thesum +!-----------UPPER BOUNDARY ID=1 + CALL GEN(1,ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU,ZFLUX, & + ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) + CALL MATIN4 (B) + DO I=1,N + RR(I,1) = 0.0d0 + DO J=1,N + THESUM = 0.0d0 + DO K=1,N + THESUM = THESUM - B(I,K)*CC(K,J) + ENDDO + DD(I,J,1) = THESUM + RR(I,1) = RR(I,1) + B(I,J)*H(J) + ENDDO + ENDDO +!----------CONTINUE THROUGH ALL DEPTH POINTS ID=2 TO ID=ND-1 + DO ID=2,ND-1 + CALL GEN(ID,ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU,ZFLUX, & + ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) + DO I=1,N + DO J=1,N + B(I,J) = B(I,J) + A(I)*DD(I,J,ID-1) + ENDDO + H(I) = H(I) - A(I)*RR(I,ID-1) + ENDDO + CALL MATIN4 (B) + DO I=1,N + RR(I,ID) = 0.0d0 + DO J=1,N + RR(I,ID) = RR(I,ID) + B(I,J)*H(J) + DD(I,J,ID) = - B(I,J)*C1(J) + ENDDO + ENDDO + ENDDO +!---------FINAL DEPTH POINT: ND + CALL GEN(ND,ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU,ZFLUX, & + ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) + DO I=1,N + DO J=1,N + THESUM = 0.0d0 + DO K=1,N + THESUM = THESUM + AA(I,K)*DD(K,J,ND-1) + ENDDO + B(I,J) = B(I,J) + THESUM + H(I) = H(I) - AA(I,J)*RR(J,ND-1) + ENDDO + ENDDO + CALL MATIN4 (B) + DO I=1,N + RR(I,ND) = 0.0d0 + DO J=1,N + RR(I,ND) = RR(I,ND) + B(I,J)*H(J) + ENDDO + ENDDO +!-----------BACK SOLUTION + DO ID=ND-1,1,-1 + DO I=1,N + DO J=1,N + RR(I,ID) = RR(I,ID) + DD(I,J,ID)*RR(J,ID+1) + ENDDO + ENDDO + ENDDO +!----------MEAN J & H + DO ID=1,ND,2 + FJ(ID) = 0.0d0 + DO I=1,N + FJ(ID) = FJ(ID) + RR(I,ID)*WT(I) + ENDDO + ENDDO + DO ID=2,ND,2 + FJ(ID) = 0.0d0 + DO I=1,N + FJ(ID) = FJ(ID) + RR(I,ID)*WT(I)*EMU(I) + ENDDO + ENDDO +! Output fluxes for testing purposes +! CALL CH_FLUX +! CALL CH_FLUX(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & +! ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +! + RETURN + END SUBROUTINE BLKSLV + + + SUBROUTINE CH_FLUX(ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & + ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +!----------------------------------------------------------------------- +! Diagnostic routine to check fluxes at each level - makes most sense +! when running a conservative atmosphere (zero out absorption in +! OPMIE by calling the NOABS routine below) +!----------------------------------------------------------------------- + +! INCLUDE 'jv_mie.h' + IMPLICIT NONE +!jdf + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + INTEGER NL, N__, M__ + PARAMETER (NL=350, N__=2*NL, M__=4) + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer I,ID + real*8 FJCHEK(N__),FZMEAN +! +! Odd (h) levels held as actinic flux, so recalculate irradiances + DO ID=1,ND,2 + FJCHEK(ID) = 0.0d0 + DO I=1,N + FJCHEK(ID) = FJCHEK(ID) + RR(I,ID)*WT(I)*EMU(i) + ENDDO + ENDDO +! +! Even (j) levels are already held as irradiances + DO ID=2,ND,2 + DO I=1,N + FJCHEK(ID) = FJ(ID) + ENDDO + ENDDO +! +! Output Downward and Upward fluxes down through atmosphere +! WRITE(6,1200) + WRITE(34,1200) + DO ID=2,ND,2 + FZMEAN=sqrt(FZ(ID)*FZ(ID-1)) +! WRITE(6,1000) ID, ZU0*FZMEAN-2.0*(FJCHEK(id)-FJCHEK(id-1)), & + WRITE(34,1000) ID, ZU0*FZMEAN-2.0*(FJCHEK(id)-FJCHEK(id-1)), & + 2.0*(FJCHEK(id)+FJCHEK(id-1)), & + 2.0*(FJCHEK(id)+FJCHEK(id-1))/ & + (ZU0*FZMEAN-2.0*(FJCHEK(id)-FJCHEK(id-1))) + ENDDO + RETURN + 1000 FORMAT(1x,i3,1p,2E12.4,1x,0p,f9.4) + 1200 FORMAT(1x,'Lev',3x,'Downward',4x,'Upward',7x,'Ratio') + END SUBROUTINE CH_FLUX + + SUBROUTINE NOABS(XLO3,XLO2,XLRAY,BCAER,RFLECT) +!----------------------------------------------------------------------- +! Zero out absorption terms to check scattering code. Leave a little +! Rayleigh to provide a minimal optical depth, and set surface albedo +! to unity. +!----------------------------------------------------------------------- + IMPLICIT NONE + real*8 XLO3,XLO2,XLRAY,BCAER,RFLECT + XLO3=0.d0 + XLO2=0.d0 + XLRAY=XLRAY*1.d-10 + BCAER=0.d0 + RFLECT=1.d0 + RETURN + END SUBROUTINE NOABS + + SUBROUTINE GEN(ID,ND,N,M,MFIT,POMEGA,PM,PM0,FZ,WT,EMU,ZTAU, & + ZFLUX,ZREFL,FJ,A,C1,H,V1,B,AA,CC,S,W,U1,DD,RR,RADIUS,ZU0) +!----------------------------------------------------------------------- +! Generates coefficient matrices for the block tri-diagonal system: +! A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = H(I) +!----------------------------------------------------------------------- + +! INCLUDE 'jv_mie.h' + IMPLICIT NONE +!jdf + integer, parameter :: single = 4 !compiler dependent value real*4 + integer, parameter :: double = 8 !compiler dependent value real*8 + INTEGER NL, N__, M__ + PARAMETER (NL=350, N__=2*NL, M__=4) + REAL(kind=double), dimension(M__) :: A,C1,H,V1,WT,EMU + REAL(kind=double), dimension(M__,M__) :: B,AA,CC,S,W,U1 + REAL(kind=double), dimension(M__,2*M__) :: PM + REAL(kind=double), dimension(2*M__) :: PM0 + REAL(kind=double), dimension(2*M__,N__) :: POMEGA + REAL(kind=double), dimension(N__) :: ZTAU, FZ, FJ + REAL(kind=double), dimension(M__,M__,N__) :: DD + REAL(kind=double), dimension(M__,N__) :: RR + REAL(kind=double) :: ZREFL,ZFLUX,RADIUS,ZU0 + INTEGER ND,N,M,MFIT +!jdf + integer id, id0, id1, im, i, j, k, mstart + real*8 sum0, sum1, sum2, sum3 + real*8 deltau, d1, d2, surfac +!--------------------------------------------- + IF(ID.EQ.1 .OR. ID.EQ.ND) THEN +!---------calculate generic 2nd-order terms for boundaries + ID0 = ID + ID1 = ID+1 + IF(ID.GE.ND) ID1 = ID-1 + DO 10 I=1,N + SUM0 = 0.0d0 + SUM1 = 0.0d0 + SUM2 = 0.0d0 + SUM3 = 0.0d0 + DO IM=M,MFIT,2 + SUM0 = SUM0 + POMEGA(IM,ID0)*PM(I,IM)*PM0(IM) + SUM2 = SUM2 + POMEGA(IM,ID1)*PM(I,IM)*PM0(IM) + ENDDO + DO IM=M+1,MFIT,2 + SUM1 = SUM1 + POMEGA(IM,ID0)*PM(I,IM)*PM0(IM) + SUM3 = SUM3 + POMEGA(IM,ID1)*PM(I,IM)*PM0(IM) + ENDDO + H(I) = 0.5d0*(SUM0*FZ(ID0) + SUM2*FZ(ID1)) + A(I) = 0.5d0*(SUM1*FZ(ID0) + SUM3*FZ(ID1)) + DO J=1,I + SUM0 = 0.0d0 + SUM1 = 0.0d0 + SUM2 = 0.0d0 + SUM3 = 0.0d0 + DO IM=M,MFIT,2 + SUM0 = SUM0 + POMEGA(IM,ID0)*PM(I,IM)*PM(J,IM) + SUM2 = SUM2 + POMEGA(IM,ID1)*PM(I,IM)*PM(J,IM) + ENDDO + DO IM=M+1,MFIT,2 + SUM1 = SUM1 + POMEGA(IM,ID0)*PM(I,IM)*PM(J,IM) + SUM3 = SUM3 + POMEGA(IM,ID1)*PM(I,IM)*PM(J,IM) + ENDDO + S(I,J) = - SUM2*WT(J) + S(J,I) = - SUM2*WT(I) + W(I,J) = - SUM1*WT(J) + W(J,I) = - SUM1*WT(I) + U1(I,J) = - SUM3*WT(J) + U1(J,I) = - SUM3*WT(I) + SUM0 = 0.5d0*(SUM0 + SUM2) + B(I,J) = - SUM0*WT(J) + B(J,I) = - SUM0*WT(I) + ENDDO + S(I,I) = S(I,I) + 1.0d0 + W(I,I) = W(I,I) + 1.0d0 + U1(I,I) = U1(I,I) + 1.0d0 + B(I,I) = B(I,I) + 1.0d0 + 10 CONTINUE + DO I=1,N + SUM0 = 0.0d0 + DO J=1,N + SUM0 = SUM0 + S(I,J)*A(J)/EMU(J) + ENDDO + C1(I) = SUM0 + ENDDO + DO I=1,N + DO J=1,N + SUM0 = 0.0d0 + SUM2 = 0.0d0 + DO K=1,N + SUM0 = SUM0 + S(J,K)*W(K,I)/EMU(K) + SUM2 = SUM2 + S(J,K)*U1(K,I)/EMU(K) + ENDDO + A(J) = SUM0 + V1(J) = SUM2 + ENDDO + DO J=1,N + W(J,I) = A(J) + U1(J,I) = V1(J) + ENDDO + ENDDO + IF (ID.EQ.1) THEN +!-------------upper boundary, 2nd-order, C-matrix is full (CC) + DELTAU = ZTAU(2) - ZTAU(1) + D2 = 0.25d0*DELTAU + DO I=1,N + D1 = EMU(I)/DELTAU + DO J=1,N + B(I,J) = B(I,J) + D2*W(I,J) + CC(I,J) = D2*U1(I,J) + ENDDO + B(I,I) = B(I,I) + D1 + CC(I,I) = CC(I,I) - D1 +! H(I) = H(I) + 2.0d0*D2*C1(I) + D1*SISOTP + H(I) = H(I) + 2.0d0*D2*C1(I) + A(I) = 0.0d0 + ENDDO + ELSE +!-------------lower boundary, 2nd-order, A-matrix is full (AA) + DELTAU = ZTAU(ND) - ZTAU(ND-1) + D2 = 0.25d0*DELTAU + SURFAC = 4.0d0*ZREFL/(1.0d0 + ZREFL) + DO I=1,N + D1 = EMU(I)/DELTAU + H(I) = H(I) - 2.0d0*D2*C1(I) + SUM0 = 0.0d0 + DO J=1,N + SUM0 = SUM0 + W(I,J) + ENDDO + SUM0 = D1 + D2*SUM0 + SUM1 = SURFAC*SUM0 + DO J=1,N + B(I,J) = B(I,J) + D2*W(I,J) - SUM1*EMU(J)*WT(J) + ENDDO + B(I,I) = B(I,I) + D1 + H(I) = H(I) + SUM0*ZFLUX + DO J=1,N + AA(I,J) = - D2*U1(I,J) + ENDDO + AA(I,I) = AA(I,I) + D1 + C1(I) = 0.0d0 + ENDDO + ENDIF +!------------intermediate points: can be even or odd, A & C diagonal + ELSE + DELTAU = ZTAU(ID+1) - ZTAU(ID-1) + MSTART = M + MOD(ID+1,2) + DO I=1,N + A(I) = EMU(I)/DELTAU + C1(I) = -A(I) + SUM0 = 0.0d0 + DO IM=MSTART,MFIT,2 + SUM0 = SUM0 + POMEGA(IM,ID)*PM(I,IM)*PM0(IM) + ENDDO + H(I) = SUM0*FZ(ID) + DO J=1,I + SUM0 = 0.0d0 + DO IM=MSTART,MFIT,2 + SUM0 = SUM0 + POMEGA(IM,ID)*PM(I,IM)*PM(J,IM) + ENDDO + B(I,J) = - SUM0*WT(J) + B(J,I) = - SUM0*WT(I) + ENDDO + B(I,I) = B(I,I) + 1.0d0 + ENDDO + ENDIF + RETURN + END SUBROUTINE GEN + + SUBROUTINE LEGND0 (X,PL,N) +!---Calculates ORDINARY LEGENDRE fns of X (real) +!--- from P[0] = PL(1) = 1, P[1] = X, .... P[N-1] = PL(N) + IMPLICIT NONE + INTEGER N,I + REAL*8 X,PL(N),DEN +!---Always does PL(2) = P[1] + PL(1) = 1.D0 + PL(2) = X + DO I=3,N + DEN = (I-1) + PL(I) = PL(I-1)*X*(2.d0-1.D0/DEN) - PL(I-2)*(1.d0-1.D0/DEN) + ENDDO + RETURN + END SUBROUTINE LEGND0 + + SUBROUTINE MATIN4 (A) +!----------------------------------------------------------------------- +! invert 4x4 matrix A(4,4) in place with L-U decomposition (mjp, old...) +!----------------------------------------------------------------------- + IMPLICIT NONE + REAL*8 A(4,4) +!---SETUP L AND U + A(2,1) = A(2,1)/A(1,1) + A(2,2) = A(2,2)-A(2,1)*A(1,2) + A(2,3) = A(2,3)-A(2,1)*A(1,3) + A(2,4) = A(2,4)-A(2,1)*A(1,4) + A(3,1) = A(3,1)/A(1,1) + A(3,2) = (A(3,2)-A(3,1)*A(1,2))/A(2,2) + A(3,3) = A(3,3)-A(3,1)*A(1,3)-A(3,2)*A(2,3) + A(3,4) = A(3,4)-A(3,1)*A(1,4)-A(3,2)*A(2,4) + A(4,1) = A(4,1)/A(1,1) + A(4,2) = (A(4,2)-A(4,1)*A(1,2))/A(2,2) + A(4,3) = (A(4,3)-A(4,1)*A(1,3)-A(4,2)*A(2,3))/A(3,3) + A(4,4) = A(4,4)-A(4,1)*A(1,4)-A(4,2)*A(2,4)-A(4,3)*A(3,4) +!---INVERT L + A(4,3) = -A(4,3) + A(4,2) = -A(4,2)-A(4,3)*A(3,2) + A(4,1) = -A(4,1)-A(4,2)*A(2,1)-A(4,3)*A(3,1) + A(3,2) = -A(3,2) + A(3,1) = -A(3,1)-A(3,2)*A(2,1) + A(2,1) = -A(2,1) +!---INVERT U + A(4,4) = 1.D0/A(4,4) + A(3,4) = -A(3,4)*A(4,4)/A(3,3) + A(3,3) = 1.D0/A(3,3) + A(2,4) = -(A(2,3)*A(3,4)+A(2,4)*A(4,4))/A(2,2) + A(2,3) = -A(2,3)*A(3,3)/A(2,2) + A(2,2) = 1.D0/A(2,2) + A(1,4) = -(A(1,2)*A(2,4)+A(1,3)*A(3,4)+A(1,4)*A(4,4))/A(1,1) + A(1,3) = -(A(1,2)*A(2,3)+A(1,3)*A(3,3))/A(1,1) + A(1,2) = -A(1,2)*A(2,2)/A(1,1) + A(1,1) = 1.D0/A(1,1) +!---MULTIPLY (U-INVERSE)*(L-INVERSE) + A(1,1) = A(1,1)+A(1,2)*A(2,1)+A(1,3)*A(3,1)+A(1,4)*A(4,1) + A(1,2) = A(1,2)+A(1,3)*A(3,2)+A(1,4)*A(4,2) + A(1,3) = A(1,3)+A(1,4)*A(4,3) + A(2,1) = A(2,2)*A(2,1)+A(2,3)*A(3,1)+A(2,4)*A(4,1) + A(2,2) = A(2,2)+A(2,3)*A(3,2)+A(2,4)*A(4,2) + A(2,3) = A(2,3)+A(2,4)*A(4,3) + A(3,1) = A(3,3)*A(3,1)+A(3,4)*A(4,1) + A(3,2) = A(3,3)*A(3,2)+A(3,4)*A(4,2) + A(3,3) = A(3,3)+A(3,4)*A(4,3) + A(4,1) = A(4,4)*A(4,1) + A(4,2) = A(4,4)*A(4,2) + A(4,3) = A(4,4)*A(4,3) + RETURN + END SUBROUTINE MATIN4 + + SUBROUTINE GAUSSP (N,XPT,XWT) +!----------------------------------------------------------------------- +! Loads in pre-set Gauss points for 4 angles from 0 to +1 in cos(theta)=mu +!----------------------------------------------------------------------- + IMPLICIT NONE + INTEGER N,I + REAL*8 XPT(N),XWT(N) + REAL*8 GPT4(4),GWT4(4) + DATA GPT4/.06943184420297D0,.33000947820757D0,.66999052179243D0, & + .93056815579703D0/ + DATA GWT4/.17392742256873D0,.32607257743127D0,.32607257743127D0, & + .17392742256873D0/ + N = 4 + DO I=1,N + XPT(I) = GPT4(I) + XWT(I) = GWT4(I) + ENDDO + RETURN + END SUBROUTINE GAUSSP +! + subroutine aeroden(zz,v,aerd) + +! purpose: find number density of boundary layer aerosols, aerd, +! at a given altitude, zz, and for a specified visibility +! input: +! zz altitude (km) +! v visibility for a horizontal surface path (km) +! output: +! aerd aerosol density at altitude z + +! the vertical distribution of the boundary layer aerosol density is +! based on the 5s vertical profile models for 5 and 23 km visibility. +! above 5 km, the aden05 and aden23 models are the same +! below 5 km, the models differ as follows; +! aden05 0.99 km scale height (94% of extinction occurs below 5 km) +! aden23 1.45 km scale heigth (80% of extinction occurs below 5 km) +! + + implicit none + integer mz, nz + parameter (mz=33) + real v,aerd + real*8 zz ! compatability with fastj + real alt, aden05, aden23, aer05,aer23 + dimension alt(mz),aden05(mz),aden23(mz) +!jdf dimension zbaer(*),dbaer(*) + + real z, f, wth + integer k, kp + save alt,aden05,aden23,nz + + + data nz/mz/ + + data alt/ & + 0.0, 1.0, 2.0, 3.0, 4.0, & + 5.0, 6.0, 7.0, 8.0, 9.0, & + 10.0, 11.0, 12.0, 13.0, 14.0, & + 15.0, 16.0, 17.0, 18.0, 19.0, & + 20.0, 21.0, 22.0, 23.0, 24.0, & + 25.0, 30.0, 35.0, 40.0, 45.0, & + 50.0, 70.0, 100.0/ + data aden05/ & + 1.378E+04, 5.030E+03, 1.844E+03, 6.731E+02, 2.453E+02, & + 8.987E+01, 6.337E+01, 5.890E+01, 6.069E+01, 5.818E+01, & + 5.675E+01, 5.317E+01, 5.585E+01, 5.156E+01, 5.048E+01, & + 4.744E+01, 4.511E+01, 4.458E+01, 4.314E+01, 3.634E+01, & + 2.667E+01, 1.933E+01, 1.455E+01, 1.113E+01, 8.826E+00, & + 7.429E+00, 2.238E+00, 5.890E-01, 1.550E-01, 4.082E-02, & + 1.078E-02, 5.550E-05, 1.969E-08/ + data aden23/ & + 2.828E+03, 1.244E+03, 5.371E+02, 2.256E+02, 1.192E+02, & + 8.987E+01, 6.337E+01, 5.890E+01, 6.069E+01, 5.818E+01, & + 5.675E+01, 5.317E+01, 5.585E+01, 5.156E+01, 5.048E+01, & + 4.744E+01, 4.511E+01, 4.458E+01, 4.314E+01, 3.634E+01, & + 2.667E+01, 1.933E+01, 1.455E+01, 1.113E+01, 8.826E+00, & + 7.429E+00, 2.238E+00, 5.890E-01, 1.550E-01, 4.082E-02, & + 1.078E-02, 5.550E-05, 1.969E-08/ +! + z=max(0.,min(100.,real(zz))) + aerd=0. + if(z.gt.alt(nz)) return + + call locate(alt,nz,z,k) + kp=k+1 + f=(z-alt(k))/(alt(kp)-alt(k)) + + if(min(aden05(k),aden05(kp),aden23(k),aden23(kp)).le.0.) then + aer05=aden05(k)*(1.-f)+aden05(kp)*f + aer23=aden23(k)*(1.-f)+aden23(kp)*f + else + aer05=aden05(k)*(aden05(kp)/aden05(k))**f + aer23=aden23(k)*(aden23(kp)/aden23(k))**f + endif + + wth=(1./v-1/5.)/(1./23.-1./5.) + wth=max(0.,min(1.,wth)) + + aerd=(1.-wth)*aer05+wth*aer23 + +! write(*,*) 'aeroden k,kp,z,aer05(k),aer05(kp),f,aerd' +! write(*,'(2i5,1p5e11.3)') k,kp,z,aden05(k),aden05(kp),f,aerd + + return + end subroutine aeroden +!======================================================================= + subroutine locate(xx,n,x,j) +! +! purpose: given an array xx of length n, and given a value X, returns +! a value J such that X is between xx(j) and xx(j+1). xx must +! be monotonic, either increasing of decreasing. this function +! returns j=1 or j=n-1 if x is out of range. +!c +! input: +! xx monitonic table +! n size of xx +! x single floating point value perhaps within the range of xx +! +! output: +! function returns index value j, such that +! +! for an increasing table +! +! xx(j) .lt. x .le. xx(j+1), +! j=1 for x .lt. xx(1) +! j=n-1 for x .gt. xx(n) +! +! for a decreasing table +! xx(j) .le. x .lt. xx(j+1) +! j=n-1 for x .lt. xx(n) +! j=1 for x .gt. xx(1) +! + implicit none + integer j,n + real x,xx(n) + integer jl,jm,ju + +! . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + + if(x.eq.xx(1)) then + j=1 + return + endif + if(x.eq.xx(n)) then + j=n-1 + return + endif + jl=1 + ju=n +10 if(ju-jl.gt.1) then + jm=(ju+jl)/2 + if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then + jl=jm + else + ju=jm + endif + goto 10 + endif + j=jl + return + end subroutine locate +!************************************************************************ + subroutine rd_tjpl2 +!----------------------------------------------------------------------- +! set wavelength bins, solar fluxes, Rayleigh parameters, temperature- +! dependent cross sections and Rayleigh/aerosol scattering phase functions +! with temperature dependences. Current data originates from JPL 2000 +!----------------------------------------------------------------------- +! +! NJVAL Number of species to calculate J-values for +! NWWW Number of wavelength bins, from NW1:NW2 +! WBIN Boundaries of wavelength bins +! WL Centres of wavelength bins - 'effective wavelength' +! FL Solar flux incident on top of atmosphere (cm-2.s-1) +! QRAYL Rayleigh parameters (effective cross-section) (cm2) +! QBC Black Carbon absorption extinct. (specific cross-sect.) (m2/g) +! QO2 O2 cross-sections +! QO3 O3 cross-sections +! Q1D O3 => O(1D) quantum yield +! TQQ Temperature for supplied cross sections +! QQQ Supplied cross sections in each wavelength bin (cm2) +! NAA Number of categories for scattering phase functions +! QAA Aerosol scattering phase functions +! NK Number of wavelengths at which functions supplied (set as 4) +! WAA Wavelengths for the NK supplied phase functions +! PAA Phase function: first 8 terms of expansion +! RAA Effective radius associated with aerosol type +! SSA Single scattering albedo +! +! npdep Number of pressure dependencies +! zpdep Pressure dependencies by wavelength bin +! jpdep Index of cross sections requiring pressure dependence +! lpdep Label for pressure dependence +! +!----------------------------------------------------------------------- + + USE module_data_mosaic_other, only : kmaxd + USE module_fastj_data + USE module_peg_util, only: peg_message, peg_error_fatal + + IMPLICIT NONE +!jdf +! Print Fast-J diagnostics if iprint /= 0 + integer, parameter :: iprint = 0 + integer, parameter :: single = 4 !compiler dependent value real*4 +! integer, parameter :: double = 8 !compiler dependent value real*8 + integer,parameter :: ipar_fastj=1,jpar=1 +! integer,parameter :: jppj=14 !Number of photolytic reactions supplied + logical,parameter :: ldeg45=.false. !Logical flag for degraded CTM resolution + integer lpar !Number of levels in CTM + integer jpnl !Number of levels requiring chemistry + real(kind=double), dimension(ipar_fastj) :: xgrd ! Longitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ygrd ! Latitude (midpoint, radians) + real(kind=double), dimension(jpar) :: ydgrd ! Latitude (midpoint, degrees) + real(kind=double), dimension(kmaxd+1) :: etaa ! Eta(a) value for level boundaries + real(kind=double), dimension(kmaxd+1) :: etab ! Eta(b) value for level boundaries + real(kind=double) :: tau_fastj ! Time of Day (hours, GMT) + integer month_fastj ! Number of month (1-12) + integer iday_fastj ! Day of year +!jdf + integer i, j, k + character*7 lpdep(3) + character*80 msg + + if(NJVAL.gt.NS) then +! fastj input files are not set up for current situation + write ( msg, '(a, 2i6)' ) & + 'FASTJ # xsect supplied > max allowed ' // & + 'NJVAL NS ', NJVAL, NS + call peg_message( lunerr, msg ) + msg = & + 'FASTJ Setup Error: # xsect supplied > max allowed. Increase NS' + call peg_error_fatal( lunerr, msg ) +! write(6,300) NJVAL,NS +! stop + endif + + if(NAA.gt.NP) then + write ( msg, '(a, 2i6)' ) & + 'FASTJ # aerosol/cloud types > NP ' // & + 'NAA NP ', NAA ,NP + call peg_message( lunerr, msg ) + msg = & + 'FASTJ Setup Error: Too many phase functions supplied. Increase NP' + call peg_error_fatal( lunerr, msg ) +! write(6,350) NAA +! stop + endif +!---Zero index arrays + do j=1,jppj + jind(j)=0 + enddo + do j=1,NJVAL + jpdep(j)=0 + enddo + do j=1,nh + hzind(j)=0 + enddo +! +!---Set mapping index + do j=1,NJVAL + do k=1,jppj + if(jlabel(k).eq.titlej(1,j)) jind(k)=j +! write(6,*)k,jind(k) ! jcb +! write(6,*)jlabel(k),titlej(1,j) ! jcb + enddo + do k=1,npdep + if(lpdep(k).eq.titlej(1,j)) jpdep(j)=k + enddo + enddo + do k=1,jppj + if(jfacta(k).eq.0.d0) then +! write(6,*) 'Not using photolysis reaction ',k + write ( msg, '(a, i6)' ) & + 'FASTJ Not using photolysis reaction ' , k + call peg_message( lunerr, msg ) + end if + if(jind(k).eq.0) then + if(jfacta(k).eq.0.d0) then + jind(k)=1 + else + write ( msg, '(a, i6)' ) & + 'FASTJ Which J-rate for photolysis reaction ' , k + call peg_message( lunerr, msg ) +! write(6,*) 'Which J-rate for photolysis reaction ',k,' ?' +! stop + msg = 'FASTJ subr rd_tjpl2 Unknown Jrate. Incorrect FASTJ setup' + call peg_error_fatal( lunerr, msg ) + endif + endif + enddo +! Herzberg index + i=0 + do j=1,nhz + do k=1,jppj + if(jlabel(k).eq.hzlab(j)) then + i=i+1 + hzind(i)=k + hztoa(i)=hztmp(j)*jfacta(k) + endif + enddo + enddo + nhz=i + if(nhz.eq.0) then + if(iprint.ne.0) then + write ( msg, '(a)' ) & + 'FASTJ Not using Herzberg bin ' + call peg_message( lunerr, msg ) +! write(6,400) + end if + else + if(iprint.ne.0) then + write ( msg, '(a)' ) & + 'FASTJ Using Herzberg bin for: ' + call peg_message( lunerr, msg ) + write( msg, '(a,10a7)' ) & + 'FASTJ ', (jlabel(hzind(i)),i=1,nhz) +! write(6,420) (jlabel(hzind(i)),i=1,nhz) + end if + endif + +! 300 format(' Number of x-sections supplied to Fast-J: ',i3,/, & +! ' Maximum number allowed (NS) only set to: ',i3, & +! ' - increase in jv_cmn.h',/, & +! 'RESULTS WILL BE IN ERROR' ) +! 350 format(' Too many phase functions supplied; increase NP to ',i2, & +! /,'RESULTS WILL BE IN ERROR' ) +! 400 format(' Not using Herzberg bin') +! 420 format(' Using Herzberg bin for: ',10a7) + + + return + end subroutine rd_tjpl2 +!******************************************************************** + + +end module module_phot_fastj diff --git a/wrfv2_fire/chem/module_phot_mad.F b/wrfv2_fire/chem/module_phot_mad.F new file mode 100755 index 00000000..efc4aea2 --- /dev/null +++ b/wrfv2_fire/chem/module_phot_mad.F @@ -0,0 +1,3233 @@ + + MODULE module_phot_mad + ! preliminary fixed values for T, p, O3 and caer + ! use values in correct units!! + ! so3t(kl,i) - ozone cross sect. temperature dependence coefficients + ! wl(kl) - array of nominal center wavelengths of spectral intervals + ! f(kl) - extraterrestrial solar irradiance + ! xs(kl,nr) - cross sections for nr species. + ! xqy(kl,nr) - quantum yields. some are read, others are computed. + ! schumann-runge - part a + ! schumann-runge parameters - part b + ! ozone temperature coefficients for xsection + ! ----------------------------------------------------------------------- + ! read stand profiles + ! aerosol + ! close (incvol) + ! wavelengths and extraterrestrial irradiance + ! ----------------------------------------------------- + ! wave_length + ! WAVE LENGTHS USED BY PHOTOLYSIS PROGRAMS + ! FILE CREATED AUGUST 19, 1994 + ! FROM MADRONICH 1989 DATA FILE + ! et_flux + ! EXTRA-TERRESTIAL IRRADIANCE + ! FILE CREATED AUGUST 19, 1994 + ! FROM MADRONICH 1989 DATA FILE + ! ----------------------------------------------------------------------- + ! current jindex assignments - if calculation order changes + ! these change - subroutine yield must be changed! + ! process jindex notes + ! wavelength none center values, modified wmo grid + ! e.t.irradian none photons per bin, not per nm + ! absorption cross sections: + ! o2 absorp 1 schumman-runge corrected in srband + ! o3 -> 1d 2 at 275 k. correct t-dep in subgrid + ! o3 -> 3p 3 at 275 k. correct t-dep in subgrid + ! no2 4 + ! no3 -> no+o2 5 + ! no3 -> no2+o 6 + ! hno2 7 + ! hno3 8 + ! hno4 9 + ! h2o2 10 + ! ch2o -> rad 11 + ! ch2o -> mol 12 + ! ch3cho 13 + ! ch3coch3 14 + ! ch3coc2h5 15 + ! hcocho proc a 16 + ! ch3cocho 17 + ! hcoch=chcho 18 estimate, no reliable measurement + ! ch3o2h 19 + ! ch3coo2h 20 actually use 0.28*(h2o2 value) + ! ch3ono2 21 + ! hcocho proc b 22 + ! quantum yields: + ! no2 4 + ! ch2o -> rad 11 + ! ch2o -> mol 12 + ! ch3cho 13 + ! hcoch=chcho 18 (energetic threshold) + ! cross section and quantum yield data. this section assigns + ! yields for ntp air. yields are read from data file + ! some yields are temperature and/or pressure dependent:ch3cho, ch2o_b, + ! o3. + ! for ch2o_b and ch3cho, the data read above are stp values. these will + ! be + ! corrected in subgrid for t & ad dependence, after the altitude + ! dependent + ! values of t and ad are computed at each layer or level as appropriate. + ! the o3->o(1d) yield is also calculated later, in subgrid. + ! ----------------------------------------------------- + ! o2 cross section + ! ----------------------------------------------------- + ! o3 -> o1d cross section + ! ----------------------------------------------------- + ! o3 -> o3p cross section + ! ----------------------------------------------------- + ! no2 cross section + ! no2 quantum yield + ! ----------------------------------------------------- + ! no3 -> no + o2 cross section + ! no3 -> no + o2 quantum yield + ! ----------------------------------------------------- + ! no3 -> no2 + o cross section + ! no3 -> no2 + o quantum yield + ! ----------------------------------------------------- + ! hono cross section + ! hono cross quantum yield + ! ----------------------------------------------------- + ! hno3 cross section + ! hno3 cross quantum yield + ! HNO3 CROSS SECTION TEMPERATURE DEPENDENCE + ! ----------------------------------------------------- + ! hno4 cross section + ! hno4 cross quantum yield + ! ----------------------------------------------------- + ! h2o2 cross section + ! h2o2 cross quantum yield + ! ----------------------------------------------------- + ! hcho -> ho2 cross section + ! hcho -> ho2 quantum yield + ! ----------------------------------------------------- + ! hcho -> h2 cross section + ! hcho -> h2 quantum yield + ! ----------------------------------------------------- + ! ch3cho cross section + ! ch3cho (ntp) quantum yield + ! ----------------------------------------------------- + ! ch3coch3 cross section + ! ch3coch3 quantum yield + ! ----------------------------------------------------- + ! ch3coc2h5 cross section + ! ch3coc2h5 quantum yield + ! ----------------------------------------------------- + ! hcocho proc a cross section + ! hcocho a quantum yield + ! ----------------------------------------------------- + ! ch3cocho cross section + ! ch3cocho quantum yield + ! ----------------------------------------------------- + ! dcb cross section + ! dcb quantum yield + ! ----------------------------------------------------- + ! ch3o2h cross section + ! ch3o2h cross quantum yield + ! ----------------------------------------------------- + ! ch3coo2h cross section + ! ch3coo2h cross quantum yield + ! ----------------------------------------------------- + ! ch3ono2 cross section + ! ch3ono2 cross quantum yield + ! ----------------------------------------------------- + ! hcocho proc b cross section + ! hcocho b quantum yield + ! macr cross section + ! macr quantum yield + ! .. Parameters .. + INTEGER, PARAMETER :: kl0 = 30, kl1 = 130 + INTEGER, PARAMETER :: kldif = (kl1-kl0+1)*3 + INTEGER, PARAMETER :: nabv = 10, nj = 200, nreakj = 23 + INTEGER, PARAMETER :: mj = 2*nj - 2 + ! .. Local Scalars .. + INTEGER :: ip, kl + ! .. Local Arrays .. + REAL :: aerstd(51), airstd(51), albedoph(130), caabv(nabv), fext(130), & + o3abv(nabv), o3std(51), pabv(nabv), so3tx(70,3), sra(11,9), srb(11,5), & + tabv(nabv), tstd(51), txs(130,nreakj), wl(130), xqy(130,23), & + xs(130,nreakj), zabv(nabv), zstd(51) + ! .. Data Statements .. + DATA zabv/21., 22., 23., 24., 25., 30., 35., 40., 45., 50./ + DATA tabv/215.19, 215.19, 215.19, 215.19, 215.19, 217.39, 227.80, & + 243.19, 258.50, 265.70/ + DATA pabv/1.57E18, 1.34E18, 1.14E18, 9.76E17, 8.33E17, 3.83E17, 1.76E17, & + 8.31E16, 4.09E16, 2.14E16/ + DATA o3abv/4.88E12, 4.86E12, 4.73E12, 4.54E12, 4.32E12, 2.52E12, & + 1.40E12, 6.07E11, 2.03E11, 6.61E10/ + DATA caabv/1.64E-3, 1.23E-3, 9.45E-4, 7.49E-4, 6.30E-4, 1.90E-4, & + 5.00E-5, 1.32E-5, 3.46E-6, 9.14E-7/ + DATA zstd/0., 1., 2., 3., 4., 5., 6., 7., 8., 9., 10., 11., 12., 13., & + 14., 15., 16., 17., 18., 19., 20., 21., 22., 23., 24., 25., 26., 27., & + 28., 29., 30., 31., 32., 33., 34., 35., 36., 37., 38., 39., 40., 41., & + 42., 43., 44., 45., 46., 47., 48., 49., 50./ + DATA ((sra(kl,ip),ip=1,9),kl=1,11)/ -2.158311E+01, -4.164652E-01, & + 5.266362E-02, 1.655877E-02, 0., 0., 0., 0., 0., -2.184813E+01, & + -4.753880E-01, 4.519945E-02, 3.228313E-02, 3.079373E-03, 0., 0., 0., & + 0., -2.200507E+01, -4.628729E-01, -5.022541E-02, 2.545036E-02, & + 5.791406E-02, 1.179966E-02, -8.296876E-03, -3.238368E-03, & + -3.069686E-04, -2.205527E+01, -4.400848E-01, -5.687308E-03, & + 3.712279E-02, 6.025527E-03, 0., 0., 0., 0., -2.205261E+01, & + -5.707936E-01, -3.330207E-02, 5.959032E-02, 1.510540E-02, & + 1.000376E-03, 0., 0., 0., -2.228000E+01, -3.960759E-01, -2.995798E-02, & + 4.918104E-02, 9.269080E-03, -1.173411E-03, -2.599386E-04, 0., 0., & + -2.275796E+01, -2.054719E-01, -1.094205E-02, 2.079595E-02, & + 3.769638E-03, 0., 0., 0., 0., -2.297610E+01, -5.823677E-02, & + -1.007612E-01, 2.404666E-02, 4.761876E-02, 4.169606E-03, & + -7.126663E-03, -2.263652E-03, -1.971653E-04, -2.506084E+01, & + 3.442774E-02, -2.212047E-04, 6.186041E-07, -6.284394E-10, 0., 0., 0., & + 0., -2.313436E+01, 1.177283E-04, 0., 0., 0., 0., 0., 0., 0., & + -2.312205E+01, 0., 0., 0., 0., 0., 0., 0., 0./ + DATA ((srb(kl,ip),ip=1,5),kl=1,11)/ -2.431640E+03, 4.729722E+02, & + -3.452121E+01, 1.120677E+00, -1.365618E-02, -3.701955E+01, & + 3.623290E+00, -8.929223E-02, 0., 0., -1.086239E+03, 1.981847E+02, & + -1.359057E+01, 4.155845E-01, -4.788462E-03, -1.213108E+03, & + 2.277459E+02, -1.612207E+01, 5.101389E-01, -6.090518E-03, & + -8.334575E+01, 7.944254E+00, -1.898894E-01, 0., 0., -2.139117E+02, & + 2.612729E+01, -1.036749E+00, 1.317695E-02, 0., -3.281301E+02, & + 4.307004E+01, -1.870019E+00, 2.674331E-02, 0., 3.033416E+03, & + -5.978911E+02, 4.370384E+01, -1.406715E+00, 1.683967E-02, & + -2.535815E+00, 0., 0., 0., 0., -4.474937E+00, 0., 0., 0., 0., & + -2.996639E+00, 0., 0., 0., 0./ + DATA ((so3tx(kl,ip),kl=33,61),ip=1,3)/9.630E+00, 8.320E+00, 6.880E+00, & + 5.370E+00, 3.960E+00, 2.710E+00, 1.750E+00, 1.060E+00, 5.960E-01, & + 3.330E-01, 2.400E-01, 2.100E-01, 1.800E-01, 1.600E-01, 1.400E-01, & + 1.200E-01, 1.050E-01, 9.000E-02, 8.000E-02, 7.000E-02, 6.000E-02, & + 5.500E-02, 4.000E-02, 2.190E-02, 1.010E-02, 5.080E-03, 2.120E-03, & + 8.290E-04, 2.940E-04, 1.190E-03, 3.640E-04, 2.460E-04, 1.030E-03, & + 1.690E-03, 1.450E-03, 8.940E-04, 7.830E-04, 4.940E-04, 3.550E-04, & + 2.950E-04, 2.750E-04, 2.500E-04, 2.300E-04, 2.080E-04, 1.860E-04, & + 1.640E-04, 1.450E-04, 1.280E-04, 1.121E-04, 1.000E-04, 9.200E-05, & + 7.500E-05, 4.830E-05, 3.430E-05, 1.820E-05, 8.850E-06, 4.270E-06, & + 5.300E-06, -1.740E-05, 2.470E-06, 1.170E-05, 1.260E-06, -6.860E-06, & + -2.890E-06, 3.590E-06, 2.000E-06, 3.660E-06, 2.600E-06, 2.170E-06, & + 1.950E-06, 1.380E-06, 1.650E-06, 1.550E-06, 1.460E-06, 1.340E-06, & + 1.210E-06, 1.130E-06, 1.060E-06, 9.400E-07, 8.700E-07, 7.500E-07, & + 5.200E-07, 2.660E-07, 1.630E-07, 1.260E-07, 8.710E-08, 3.500E-08/ + DATA aerstd/2.40E-1, 1.06E-1, 4.56E-2, 1.91E-2, 1.01E-2, 7.63E-3, & + 5.38E-3, 5.00E-3, 5.15E-3, 4.94E-3, 4.82E-3, 4.51E-3, 4.74E-3, & + 4.37E-3, 4.28E-3, 4.03E-3, 3.83E-3, 3.78E-3, 3.88E-3, 3.08E-3, & + 2.26E-3, 1.64E-3, 1.23E-3, 9.45E-4, 7.49E-4, 6.30E-4, 5.50E-4, & + 4.21E-4, 3.22E-4, 2.48E-4, 1.90E-4, 1.45E-4, 1.11E-4, 8.51E-5, & + 6.52E-5, 5.00E-5, 3.83E-5, 2.93E-5, 2.25E-5, 1.72E-5, 1.32E-5, & + 1.01E-5, 7.72E-6, 5.91E-6, 4.53E-6, 3.46E-6, 2.66E-6, 2.04E-6, & + 1.56E-6, 1.19E-6, 9.14E-7/ + DATA (wl(kl),kl=1,130)/1.861E+02, 1.878E+02, 1.896E+02, 1.914E+02, & + 1.933E+02, 1.952E+02, 1.971E+02, 1.990E+02, 2.010E+02, 2.031E+02, & + 2.052E+02, 2.073E+02, 2.094E+02, 2.117E+02, 2.139E+02, 2.162E+02, & + 2.186E+02, 2.210E+02, 2.235E+02, 2.260E+02, 2.286E+02, 2.313E+02, & + 2.340E+02, 2.367E+02, 2.396E+02, 2.425E+02, 2.454E+02, 2.485E+02, & + 2.516E+02, 2.548E+02, 2.582E+02, 2.615E+02, 2.650E+02, 2.685E+02, & + 2.722E+02, 2.759E+02, 2.798E+02, 2.837E+02, 2.878E+02, 2.920E+02, & + 2.963E+02, 3.005E+02, 3.030E+02, 3.040E+02, 3.050E+02, 3.060E+02, & + 3.070E+02, 3.080E+02, 3.090E+02, 3.100E+02, 3.110E+02, 3.120E+02, & + 3.130E+02, 3.140E+02, 3.160E+02, 3.200E+02, 3.250E+02, 3.300E+02, & + 3.350E+02, 3.400E+02, 3.450E+02, 3.500E+02, 3.550E+02, 3.600E+02, & + 3.650E+02, 3.700E+02, 3.750E+02, 3.800E+02, 3.850E+02, 3.900E+02, & + 3.950E+02, 4.000E+02, 4.050E+02, 4.100E+02, 4.150E+02, 4.200E+02, & + 4.250E+02, 4.300E+02, 4.350E+02, 4.400E+02, 4.450E+02, 4.500E+02, & + 4.550E+02, 4.600E+02, 4.650E+02, 4.700E+02, 4.750E+02, 4.800E+02, & + 4.850E+02, 4.900E+02, 4.950E+02, 5.000E+02, 5.050E+02, 5.100E+02, & + 5.150E+02, 5.200E+02, 5.250E+02, 5.300E+02, 5.350E+02, 5.400E+02, & + 5.450E+02, 5.500E+02, 5.550E+02, 5.600E+02, 5.650E+02, 5.700E+02, & + 5.750E+02, 5.800E+02, 5.850E+02, 5.900E+02, 5.950E+02, 6.000E+02, & + 6.050E+02, 6.100E+02, 6.150E+02, 6.200E+02, 6.250E+02, 6.300E+02, & + 6.350E+02, 6.400E+02, 6.448E+02, 6.510E+02, 6.600E+02, 6.700E+02, & + 6.800E+02, 6.900E+02, 7.000E+02, 7.100E+02, 7.200E+02, 7.300E+02/ + DATA (fext(kl),kl=1,130)/3.620E+11, 4.730E+11, 5.610E+11, 6.630E+11, & + 6.900E+11, 9.560E+11, 1.150E+12, 1.270E+12, 1.520E+12, 1.780E+12, & + 2.200E+12, 2.690E+12, 4.540E+12, 7.140E+12, 8.350E+12, 8.390E+12, & + 1.080E+13, 1.180E+13, 1.600E+13, 1.340E+13, 1.410E+13, 1.570E+13, & + 1.380E+13, 1.600E+13, 1.450E+13, 2.200E+13, 1.990E+13, 1.970E+13, & + 1.940E+13, 2.910E+13, 4.950E+13, 4.530E+13, 1.070E+14, 1.200E+14, & + 1.100E+14, 1.040E+14, 8.240E+13, 1.520E+14, 2.150E+14, 3.480E+14, & + 3.396E+14, 2.730E+14, 9.109E+13, 8.745E+13, 9.577E+13, 8.507E+13, & + 9.383E+13, 1.030E+14, 9.722E+13, 7.751E+13, 1.277E+14, 1.087E+14, & + 1.102E+14, 1.184E+14, 3.153E+14, 5.930E+14, 6.950E+14, 8.150E+14, & + 7.810E+14, 8.350E+14, 8.140E+14, 8.530E+14, 9.170E+14, 8.380E+14, & + 1.040E+15, 1.100E+15, 9.790E+14, 1.130E+15, 8.890E+14, 1.140E+15, & + 9.170E+14, 1.690E+15, 1.700E+15, 1.840E+15, 1.870E+15, 1.950E+15, & + 1.810E+15, 1.670E+15, 1.980E+15, 2.020E+15, 2.180E+15, 2.360E+15, & + 2.310E+15, 2.390E+15, 2.380E+15, 2.390E+15, 2.440E+15, 2.510E+15, & + 2.300E+15, 2.390E+15, 2.480E+15, 2.400E+15, 2.460E+15, 2.490E+15, & + 2.320E+15, 2.390E+15, 2.420E+15, 2.550E+15, 2.510E+15, 2.490E+15, & + 2.550E+15, 2.530E+15, 2.540E+15, 2.500E+15, 2.570E+15, 2.580E+15, & + 2.670E+15, 2.670E+15, 2.700E+15, 2.620E+15, 2.690E+15, 2.630E+15, & + 2.680E+15, 2.660E+15, 2.590E+15, 2.690E+15, 2.610E+15, 2.620E+15, & + 2.620E+15, 2.630E+15, 2.392E+15, 3.998E+15, 5.115E+15, 5.225E+15, & + 5.215E+15, 5.105E+15, 5.140E+15, 5.010E+15, 4.930E+15, 4.895E+15/ + DATA (xs(kl,1),kl=1,130)/7.040E-24, 7.360E-24, 7.640E-24, 7.870E-24, & + 8.040E-24, 8.140E-24, 8.170E-24, 8.130E-24, 8.010E-24, 7.840E-24, & + 7.630E-24, 7.330E-24, 6.990E-24, 6.450E-24, 5.810E-24, 5.230E-24, & + 4.710E-24, 4.260E-24, 3.800E-24, 3.350E-24, 2.900E-24, 2.450E-24, & + 2.050E-24, 1.690E-24, 1.300E-24, 9.300E-25, 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., & + 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ + DATA (xs(kl,2),kl=1,130)/0.622E-18, 0.576E-18, 0.526E-18, 0.476E-18, & + 0.428E-18, 0.383E-18, 0.347E-18, 0.323E-18, 0.314E-18, 0.326E-18, & + 0.364E-18, 0.434E-18, 0.542E-18, 0.699E-18, 0.921E-18, 0.119E-17, & + 0.155E-17, 0.199E-17, 0.256E-17, 0.323E-17, 0.400E-17, 0.483E-17, & + 0.579E-17, 0.686E-17, 0.797E-17, 0.900E-17, 0.100E-16, 0.108E-16, & + 0.113E-16, 0.115E-16, 0.112E-16, 0.106E-16, 0.963E-17, 0.836E-17, & + 0.695E-17, 0.545E-17, 0.404E-17, 0.280E-17, 0.183E-17, 0.112E-17, & + 0.647E-18, 0.369E-18, 0.270E-18, 0.238E-18, 0.203E-18, 0.183E-18, & + 0.161E-18, 0.139E-18, 0.122E-18, 0.105E-18, 0.939E-19, 0.825E-19, & + 0.711E-19, 0.653E-19, 0.486E-19, 0.276E-19, 0.137E-19, 0.707E-20, & + 0.330E-20, 0.152E-20, 0.816E-21, 0.266E-21, 0.109E-21, 0.549E-22, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.291E-22, 0.314E-22, 0.399E-22, & + 0.654E-22, 0.683E-22, 0.866E-22, 0.125E-21, 0.149E-21, 0.171E-21, & + 0.212E-21, 0.357E-21, 0.368E-21, 0.406E-21, 0.489E-21, 0.711E-21, & + 0.843E-21, 0.828E-21, 0.909E-21, 0.122E-20, 0.162E-20, 0.158E-20, & + 0.160E-20, 0.178E-20, 0.207E-20, 0.255E-20, 0.274E-20, 0.288E-20, & + 0.307E-20, 0.317E-20, 0.336E-20, 0.388E-20, 0.431E-20, 0.467E-20, & + 0.475E-20, 0.455E-20, 0.435E-20, 0.442E-20, 0.461E-20, 0.489E-20, & + 0.484E-20, 0.454E-20, 0.424E-20, 0.390E-20, 0.360E-20, 0.343E-20, & + 0.317E-20, 0.274E-20, 0.261E-20, 0.240E-20, 0.207E-20, 0.172E-20, & + 0.137E-20, 0.111E-20, 0.913E-21, 0.793E-21, 0.640E-21, 0.514E-21/ + DATA (xs(kl,3),kl=1,130)/0.622E-18, 0.576E-18, 0.526E-18, 0.476E-18, & + 0.428E-18, 0.383E-18, 0.347E-18, 0.323E-18, 0.314E-18, 0.326E-18, & + 0.364E-18, 0.434E-18, 0.542E-18, 0.699E-18, 0.921E-18, 0.119E-17, & + 0.155E-17, 0.199E-17, 0.256E-17, 0.323E-17, 0.400E-17, 0.483E-17, & + 0.579E-17, 0.686E-17, 0.797E-17, 0.900E-17, 0.100E-16, 0.108E-16, & + 0.113E-16, 0.115E-16, 0.112E-16, 0.106E-16, 0.963E-17, 0.836E-17, & + 0.695E-17, 0.545E-17, 0.404E-17, 0.280E-17, 0.183E-17, 0.112E-17, & + 0.647E-18, 0.369E-18, 0.270E-18, 0.238E-18, 0.203E-18, 0.183E-18, & + 0.161E-18, 0.139E-18, 0.122E-18, 0.105E-18, 0.939E-19, 0.825E-19, & + 0.711E-19, 0.653E-19, 0.486E-19, 0.276E-19, 0.137E-19, 0.707E-20, & + 0.330E-20, 0.152E-20, 0.816E-21, 0.266E-21, 0.109E-21, 0.549E-22, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.291E-22, 0.314E-22, 0.399E-22, & + 0.654E-22, 0.683E-22, 0.866E-22, 0.125E-21, 0.149E-21, 0.171E-21, & + 0.212E-21, 0.357E-21, 0.368E-21, 0.406E-21, 0.489E-21, 0.711E-21, & + 0.843E-21, 0.828E-21, 0.909E-21, 0.122E-20, 0.162E-20, 0.158E-20, & + 0.160E-20, 0.178E-20, 0.207E-20, 0.255E-20, 0.274E-20, 0.288E-20, & + 0.307E-20, 0.317E-20, 0.336E-20, 0.388E-20, 0.431E-20, 0.467E-20, & + 0.475E-20, 0.455E-20, 0.435E-20, 0.442E-20, 0.461E-20, 0.489E-20, & + 0.484E-20, 0.454E-20, 0.424E-20, 0.390E-20, 0.360E-20, 0.343E-20, & + 0.317E-20, 0.274E-20, 0.261E-20, 0.240E-20, 0.207E-20, 0.172E-20, & + 0.137E-20, 0.111E-20, 0.913E-21, 0.793E-21, 0.640E-21, 0.514E-21/ + DATA (xs(kl,4),kl=1,130)/0.259E-18, 0.272E-18, 0.286E-18, 0.273E-18, & + 0.251E-18, 0.244E-18, 0.246E-18, 0.246E-18, 0.282E-18, 0.415E-18, & + 0.448E-18, 0.445E-18, 0.464E-18, 0.487E-18, 0.482E-18, 0.502E-18, & + 0.444E-18, 0.471E-18, 0.377E-18, 0.393E-18, 0.274E-18, 0.278E-18, & + 0.169E-18, 0.162E-18, 0.882E-19, 0.747E-19, 0.391E-19, 0.275E-19, & + 0.201E-19, 0.197E-19, 0.211E-19, 0.236E-19, 0.270E-19, 0.325E-19, & + 0.379E-19, 0.503E-19, 0.588E-19, 0.700E-19, 0.815E-19, 0.972E-19, & + 0.115E-18, 0.128E-18, 0.154E-18, 0.159E-18, 0.158E-18, 0.156E-18, & + 0.164E-18, 0.166E-18, 0.182E-18, 0.184E-18, 0.192E-18, 0.204E-18, & + 0.204E-18, 0.202E-18, 0.224E-18, 0.248E-18, 0.281E-18, 0.313E-18, & + 0.343E-18, 0.380E-18, 0.407E-18, 0.431E-18, 0.472E-18, 0.483E-18, & + 0.517E-18, 0.532E-18, 0.551E-18, 0.564E-18, 0.576E-18, 0.593E-18, & + 0.585E-18, 0.602E-18, 0.578E-18, 0.600E-18, 0.565E-18, 0.581E-18, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA ((xqy(kl,ip),kl=kl0,kl1),ip=1,3)/kldif*1./ + DATA (xqy(kl,4),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 0.999000, 0.998000, 0.997000, 0.996500, 0.996000, 0.996000, 0.996000, & + 0.996000, 0.995000, 0.995000, 0.995000, 0.995000, 0.995000, 0.994000, & + 0.994000, 0.994000, 0.993000, 0.992000, 0.991000, 0.990000, 0.989000, & + 0.988000, 0.987000, 0.986000, 0.984000, 0.983000, 0.981000, 0.979000, & + 0.975000, 0.969000, 0.960000, 0.927000, 0.694000, 0.355000, 0.134000, & + 0.060000, 0.018000, 0.000900, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,5),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.160E-19, 0.240E-19, 0.520E-19, 0.760E-19, & + 0.110E-18, 0.136E-18, 0.170E-18, 0.198E-18, 0.220E-18, 0.288E-18, & + 0.358E-18, 0.396E-18, 0.502E-18, 0.598E-18, 0.694E-18, 0.716E-18, & + 0.828E-18, 0.984E-18, 0.110E-17, 0.114E-17, 0.125E-17, 0.153E-17, & + 0.156E-17, 0.168E-17, 0.169E-17, 0.217E-17, 0.229E-17, 0.208E-17, & + 0.213E-17, 0.261E-17, 0.299E-17, 0.329E-17, 0.278E-17, 0.281E-17, & + 0.307E-17, 0.334E-17, 0.322E-17, 0.554E-17, 0.441E-17, 0.314E-17, & + 0.365E-17, 0.188E-17, 0.233E-17, 0.473E-17, 0.100E-16, 0.584E-17, & + 0.180E-17, 0.135E-17, 0.822E-18, 0.640E-18, 0.777E-17, 0.134E-17, & + 0.337E-18, 0.175E-19, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,5),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.038000, & + 0.191000, 0.326000, 0.311000, 0.272000, 0.233000, 0.194000, 0.156000, & + 0.117000, 0.078000, 0.039000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,6),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.160E-19, 0.240E-19, 0.520E-19, 0.760E-19, & + 0.110E-18, 0.136E-18, 0.170E-18, 0.198E-18, 0.220E-18, 0.288E-18, & + 0.358E-18, 0.396E-18, 0.502E-18, 0.598E-18, 0.694E-18, 0.716E-18, & + 0.828E-18, 0.984E-18, 0.110E-17, 0.114E-17, 0.125E-17, 0.153E-17, & + 0.156E-17, 0.168E-17, 0.169E-17, 0.217E-17, 0.229E-17, 0.208E-17, & + 0.213E-17, 0.261E-17, 0.299E-17, 0.329E-17, 0.278E-17, 0.281E-17, & + 0.307E-17, 0.334E-17, 0.322E-17, 0.554E-17, 0.441E-17, 0.314E-17, & + 0.365E-17, 0.188E-17, 0.233E-17, 0.473E-17, 0.100E-16, 0.584E-17, & + 0.180E-17, 0.135E-17, 0.822E-18, 0.640E-18, 0.777E-17, 0.134E-17, & + 0.337E-18, 0.175E-19, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,6),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 0.962000, & + 0.809000, 0.661000, 0.578000, 0.506000, 0.433000, 0.361000, 0.289000, & + 0.217000, 0.144000, 0.072000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,7),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.130E-19, 0.190E-19, 0.280E-19, & + 0.220E-19, 0.360E-19, 0.340E-19, 0.536E-19, 0.534E-19, 0.111E-18, & + 0.786E-19, 0.189E-18, 0.116E-18, 0.130E-18, 0.279E-18, 0.954E-19, & + 0.179E-18, 0.260E-18, 0.590E-19, 0.101E-18, 0.176E-18, 0.304E-19, & + 0.775E-20, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,7),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,8),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.127E-16, & + 0.114E-16, 0.100E-16, 0.847E-17, 0.679E-17, 0.518E-17, 0.382E-17, & + 0.270E-17, 0.182E-17, 0.120E-17, 0.730E-18, 0.451E-18, 0.283E-18, & + 0.195E-18, 0.134E-18, 0.102E-18, 0.802E-19, 0.650E-19, 0.518E-19, & + 0.414E-19, 0.321E-19, 0.265E-19, 0.230E-19, 0.209E-19, 0.199E-19, & + 0.196E-19, 0.195E-19, 0.193E-19, 0.188E-19, 0.180E-19, 0.170E-19, & + 0.152E-19, 0.134E-19, 0.113E-19, 0.924E-20, 0.719E-20, 0.532E-20, & + 0.371E-20, 0.249E-20, 0.188E-20, 0.167E-20, 0.150E-20, 0.133E-20, & + 0.119E-20, 0.105E-20, 0.932E-21, 0.814E-21, 0.721E-21, 0.628E-21, & + 0.547E-21, 0.465E-21, 0.362E-21, 0.197E-21, 0.975E-22, 0.452E-22, & + 0.222E-22, 0.110E-22, 0.604E-23, 0.420E-23, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,8),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (txs(kl,8),kl=1,130)/0.000000, 0.000000, 0.000000, 1.700000, & + 1.650000, 1.660000, 1.690000, 1.740000, 1.770000, 1.850000, 1.970000, & + 2.080000, 2.170000, 2.170000, 2.210000, 2.150000, 2.060000, 1.960000, & + 1.840000, 1.780000, 1.800000, 1.860000, 1.900000, 1.970000, 1.970000, & + 1.970000, 1.880000, 1.750000, 1.610000, 1.440000, 1.340000, 1.230000, & + 1.180000, 1.140000, 1.120000, 1.140000, 1.140000, 1.180000, 1.220000, & + 1.250000, 1.450000, 1.490000, 1.560000, 1.640000, 1.690000, 1.780000, & + 1.870000, 1.940000, 2.040000, 2.150000, 2.270000, 2.380000, 2.620000, & + 2.700000, 2.920000, 3.100000, 3.240000, 3.520000, 3.770000, 3.910000, & + 4.230000, 4.700000, 5.150000, 5.250000, 5.740000, 6.450000, 6.700000, & + 7.160000, 7.550000, 8.160000, 9.750000, 9.930000, 9.600000, 10.50000, & + 10.80000, 11.80000, 11.80000, 9.300000, 12.10000, 11.90000, 9.300000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,9),kl=1,130)/0.000E+00, 0.000E+00, 0.100E-16, 0.980E-17, & + 0.918E-17, 0.828E-17, 0.723E-17, 0.618E-17, 0.517E-17, 0.426E-17, & + 0.352E-17, 0.292E-17, 0.245E-17, 0.205E-17, 0.175E-17, 0.151E-17, & + 0.131E-17, 0.115E-17, 0.102E-17, 0.916E-18, 0.827E-18, 0.752E-18, & + 0.687E-18, 0.631E-18, 0.578E-18, 0.529E-18, 0.484E-18, 0.439E-18, & + 0.396E-18, 0.353E-18, 0.311E-18, 0.271E-18, 0.231E-18, 0.194E-18, & + 0.158E-18, 0.125E-18, 0.946E-19, 0.694E-19, 0.485E-19, 0.325E-19, & + 0.210E-19, 0.135E-19, 0.104E-19, 0.938E-20, 0.846E-20, 0.763E-20, & + 0.689E-20, 0.623E-20, 0.564E-20, 0.511E-20, 0.463E-20, 0.420E-20, & + 0.382E-20, 0.347E-20, 0.287E-20, 0.191E-20, 0.101E-20, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,9),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,10),kl=1,130)/0.000E+00, 0.000E+00, 0.695E-18, 0.635E-18, & + 0.586E-18, 0.547E-18, 0.515E-18, 0.488E-18, 0.462E-18, 0.436E-18, & + 0.412E-18, 0.388E-18, 0.365E-18, 0.341E-18, 0.318E-18, 0.295E-18, & + 0.272E-18, 0.250E-18, 0.229E-18, 0.209E-18, 0.190E-18, 0.172E-18, & + 0.155E-18, 0.140E-18, 0.126E-18, 0.112E-18, 0.999E-19, 0.881E-19, & + 0.774E-19, 0.675E-19, 0.582E-19, 0.500E-19, 0.425E-19, 0.358E-19, & + 0.298E-19, 0.247E-19, 0.201E-19, 0.164E-19, 0.131E-19, 0.105E-19, & + 0.828E-20, 0.658E-20, 0.573E-20, 0.543E-20, 0.514E-20, 0.486E-20, & + 0.460E-20, 0.435E-20, 0.412E-20, 0.390E-20, 0.369E-20, 0.349E-20, & + 0.330E-20, 0.312E-20, 0.279E-20, 0.220E-20, 0.160E-20, 0.130E-20, & + 0.100E-20, 0.700E-21, 0.500E-21, 0.400E-21, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,10),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,11),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.293E-21, 0.342E-21, 0.102E-20, 0.456E-21, 0.527E-21, 0.537E-21, & + 0.347E-21, 0.759E-21, 0.628E-21, 0.974E-21, 0.104E-20, 0.219E-20, & + 0.228E-20, 0.357E-20, 0.374E-20, 0.584E-20, 0.651E-20, 0.102E-19, & + 0.114E-19, 0.176E-19, 0.180E-19, 0.259E-19, 0.227E-19, 0.275E-19, & + 0.318E-19, 0.160E-19, 0.245E-19, 0.637E-19, 0.426E-19, 0.399E-19, & + 0.186E-19, 0.131E-19, 0.310E-19, 0.182E-19, 0.596E-20, 0.111E-19, & + 0.911E-20, 0.457E-19, 0.423E-19, 0.142E-19, 0.243E-19, 0.178E-19, & + 0.129E-20, 0.213E-19, 0.661E-20, 0.139E-20, 0.827E-20, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,11),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.264091, & + 0.288940, 0.297038, 0.295059, 0.289384, 0.285483, 0.288087, 0.301000, & + 0.326819, 0.366764, 0.420506, 0.485961, 0.559106, 0.633887, 0.702103, & + 0.733457, 0.740762, 0.747845, 0.753000, 0.754000, 0.754800, 0.754000, & + 0.753000, 0.752000, 0.751000, 0.749500, 0.745000, 0.739600, 0.731700, & + 0.723300, 0.690300, 0.593100, 0.458100, 0.305000, 0.122300, 0.003429, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,12),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.293E-21, 0.342E-21, 0.102E-20, 0.456E-21, 0.527E-21, 0.537E-21, & + 0.347E-21, 0.759E-21, 0.628E-21, 0.974E-21, 0.104E-20, 0.219E-20, & + 0.228E-20, 0.357E-20, 0.374E-20, 0.584E-20, 0.651E-20, 0.102E-19, & + 0.114E-19, 0.176E-19, 0.180E-19, 0.259E-19, 0.227E-19, 0.275E-19, & + 0.318E-19, 0.160E-19, 0.245E-19, 0.637E-19, 0.426E-19, 0.399E-19, & + 0.186E-19, 0.131E-19, 0.310E-19, 0.182E-19, 0.596E-20, 0.111E-19, & + 0.911E-20, 0.457E-19, 0.423E-19, 0.142E-19, 0.243E-19, 0.178E-19, & + 0.129E-20, 0.213E-19, 0.661E-20, 0.139E-20, 0.827E-20, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,12),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.492085, & + 0.483681, 0.483325, 0.487471, 0.492514, 0.495532, 0.493893, 0.485473, & + 0.468839, 0.443373, 0.409405, 0.368400, 0.323132, 0.307820, 0.294564, & + 0.280920, 0.266885, 0.253277, 0.249000, 0.247000, 0.245600, 0.248000, & + 0.251000, 0.254000, 0.257000, 0.260200, 0.264500, 0.269000, 0.273500, & + 0.278900, 0.310300, 0.394100, 0.508100, 0.676100, 0.759300, 0.636100, & + 0.501500, 0.373400, 0.229000, 0.103600, 0.005906, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,13),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.593E-21, 0.548E-21, & + 0.552E-21, 0.513E-21, 0.480E-21, 0.482E-21, 0.482E-21, 0.482E-21, & + 0.536E-21, 0.593E-21, 0.734E-21, 0.948E-21, 0.125E-20, 0.171E-20, & + 0.234E-20, 0.321E-20, 0.434E-20, 0.582E-20, 0.770E-20, 0.991E-20, & + 0.127E-19, 0.159E-19, 0.200E-19, 0.237E-19, 0.287E-19, 0.326E-19, & + 0.376E-19, 0.408E-19, 0.444E-19, 0.463E-19, 0.466E-19, 0.465E-19, & + 0.432E-19, 0.406E-19, 0.372E-19, 0.348E-19, 0.342E-19, 0.342E-19, & + 0.336E-19, 0.333E-19, 0.314E-19, 0.293E-19, 0.276E-19, 0.253E-19, & + 0.247E-19, 0.243E-19, 0.210E-19, 0.169E-19, 0.108E-19, 0.651E-20, & + 0.314E-20, 0.138E-20, 0.224E-21, 0.947E-22, 0.425E-22, 0.229E-22, & + 0.275E-23, 0.192E-23, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,13),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.310000, & + 0.349300, 0.377900, 0.430300, 0.501600, 0.566200, 0.561500, 0.541100, & + 0.512100, 0.473200, 0.430000, 0.392000, 0.376000, 0.360000, 0.344000, & + 0.328000, 0.312000, 0.296000, 0.279800, 0.262500, 0.245000, 0.227500, & + 0.210000, 0.175000, 0.109300, 0.051880, 0.006266, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,14),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 1.003E-20, 1.873E-21, & + 1.408E-21, 1.084E-21, 1.030E-21, 1.071E-21, 1.176E-21, 1.371E-21, & + 1.690E-21, 2.153E-21, 2.779E-21, 3.561E-21, 4.575E-21, 5.906E-21, & + 7.585E-21, 9.622E-21, 1.212E-20, 1.516E-20, 1.863E-20, 2.252E-20, & + 2.676E-20, 3.143E-20, 3.616E-20, 4.058E-20, 4.475E-20, 4.774E-20, & + 5.029E-20, 5.065E-20, 5.049E-20, 4.790E-20, 4.415E-20, 3.940E-20, & + 3.308E-20, 2.717E-20, 2.371E-20, 2.244E-20, 2.106E-20, 1.953E-20, & + 1.801E-20, 1.663E-20, 1.538E-20, 1.408E-20, 1.277E-20, 1.173E-20, & + 1.081E-20, 9.675E-21, 7.783E-21, 4.712E-21, 2.078E-21, 7.065E-22, & + 1.973E-22, 5.745E-23, 2.137E-23, 8.235E-24, 5.686E-24, 2.157E-24, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,14),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.766400, 0.779200, 0.792800, 0.776000, & + 0.720000, 0.672000, 0.620200, 0.586900, 0.551800, 0.457500, 0.355000, & + 0.270000, 0.205500, 0.145000, 0.120000, 0.110000, 0.100000, 0.090000, & + 0.080000, 0.070000, 0.060000, 0.050000, 0.047800, 0.045600, 0.043400, & + 0.041200, 0.036800, 0.028000, 0.030500, 0.033000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,15),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.234E-19, 0.685E-20, & + 0.215E-20, 0.168E-20, 0.159E-20, 0.164E-20, 0.181E-20, 0.203E-20, & + 0.230E-20, 0.268E-20, 0.320E-20, 0.387E-20, 0.471E-20, 0.582E-20, & + 0.728E-20, 0.913E-20, 0.115E-19, 0.145E-19, 0.180E-19, 0.222E-19, & + 0.267E-19, 0.321E-19, 0.374E-19, 0.430E-19, 0.479E-19, 0.525E-19, & + 0.555E-19, 0.576E-19, 0.575E-19, 0.555E-19, 0.518E-19, 0.460E-19, & + 0.388E-19, 0.319E-19, 0.269E-19, 0.251E-19, 0.233E-19, 0.217E-19, & + 0.202E-19, 0.188E-19, 0.173E-19, 0.158E-19, 0.142E-19, 0.128E-19, & + 0.114E-19, 0.101E-19, 0.796E-20, 0.463E-20, 0.196E-20, 0.705E-21, & + 0.207E-21, 0.545E-22, 0.145E-22, 0.431E-23, 0.471E-23, 0.157E-23, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,15),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.766400, 0.779200, 0.792800, 0.776000, & + 0.720000, 0.672000, 0.620200, 0.586900, 0.551800, 0.457500, 0.355000, & + 0.270000, 0.205500, 0.145000, 0.120000, 0.110000, 0.100000, 0.090000, & + 0.080000, 0.070000, 0.060000, 0.050000, 0.047800, 0.045600, 0.043400, & + 0.041200, 0.036800, 0.028000, 0.030500, 0.033000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,16),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.340E-20, 0.401E-20, 0.486E-20, 0.573E-20, 0.662E-20, 0.754E-20, & + 0.906E-20, 0.112E-19, 0.133E-19, 0.162E-19, 0.202E-19, 0.224E-19, & + 0.248E-19, 0.276E-19, 0.289E-19, 0.318E-19, 0.322E-19, 0.321E-19, & + 0.338E-19, 0.343E-19, 0.307E-19, 0.290E-19, 0.275E-19, 0.272E-19, & + 0.272E-19, 0.272E-19, 0.272E-19, 0.273E-19, 0.280E-19, 0.283E-19, & + 0.268E-19, 0.249E-19, 0.212E-19, 0.151E-19, 0.127E-19, 0.142E-19, & + 0.229E-19, 0.358E-20, 0.000E+00, 0.000E+00, 0.286E-21, 0.208E-20, & + 0.344E-20, 0.764E-20, 0.107E-19, 0.159E-19, 0.166E-19, 0.303E-19, & + 0.263E-19, 0.336E-19, 0.366E-19, 0.456E-19, 0.643E-19, 0.546E-19, & + 0.922E-19, 0.677E-19, 0.599E-19, 0.117E-18, 0.715E-19, 0.730E-19, & + 0.201E-18, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,16),kl=1,130)/0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, & + 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000, 0.029000/ + DATA (xs(kl,17),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.131E-19, 0.142E-19, 0.156E-19, & + 0.174E-19, 0.189E-19, 0.205E-19, 0.219E-19, 0.233E-19, 0.252E-19, & + 0.269E-19, 0.285E-19, 0.313E-19, 0.338E-19, 0.362E-19, 0.394E-19, & + 0.427E-19, 0.450E-19, 0.486E-19, 0.476E-19, 0.479E-19, 0.465E-19, & + 0.420E-19, 0.371E-19, 0.352E-19, 0.344E-19, 0.336E-19, 0.316E-19, & + 0.296E-19, 0.276E-19, 0.256E-19, 0.237E-19, 0.227E-19, 0.218E-19, & + 0.208E-19, 0.199E-19, 0.182E-19, 0.151E-19, 0.938E-20, 0.652E-20, & + 0.482E-20, 0.323E-20, 0.300E-20, 0.394E-20, 0.560E-20, 0.695E-20, & + 0.108E-19, 0.148E-19, 0.191E-19, 0.243E-19, 0.322E-19, 0.403E-19, & + 0.473E-19, 0.566E-19, 0.692E-19, 0.846E-19, 0.968E-19, 0.103E-18, & + 0.102E-18, 0.101E-18, 0.106E-18, 0.104E-18, 0.994E-19, 0.813E-19, & + 0.395E-19, 0.109E-19, 0.327E-20, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,17),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 0.990000, 0.990000, 0.990000, & + 0.980000, 0.980000, 0.980000, 0.980000, 0.970000, 0.970000, 0.970000, & + 0.960000, 0.960000, 0.940000, 0.920000, 0.880000, 0.825000, 0.750000, & + 0.660000, 0.560000, 0.480000, 0.400000, 0.320000, 0.250000, 0.200000, & + 0.150000, 0.120000, 0.100000, 0.080000, 0.060000, 0.050000, 0.040000, & + 0.030000, 0.020000, 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, & + 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, 0.005000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,18),kl=1,130)/0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, 0.790E-19, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,18),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 0.500000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,19),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.320E-18, 0.268E-18, 0.226E-18, 0.193E-18, & + 0.167E-18, 0.147E-18, 0.129E-18, 0.115E-18, 0.102E-18, 0.899E-19, & + 0.797E-19, 0.708E-19, 0.623E-19, 0.548E-19, 0.483E-19, 0.422E-19, & + 0.369E-19, 0.321E-19, 0.278E-19, 0.242E-19, 0.209E-19, 0.180E-19, & + 0.154E-19, 0.131E-19, 0.111E-19, 0.925E-20, 0.763E-20, 0.622E-20, & + 0.501E-20, 0.402E-20, 0.352E-20, 0.333E-20, 0.316E-20, 0.299E-20, & + 0.283E-20, 0.268E-20, 0.254E-20, 0.240E-20, 0.227E-20, 0.215E-20, & + 0.204E-20, 0.193E-20, 0.172E-20, 0.138E-20, 0.105E-20, 0.801E-21, & + 0.612E-21, 0.467E-21, 0.356E-21, 0.270E-21, 0.206E-21, 0.160E-21, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,19),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,20),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.898E-19, & + 0.841E-19, 0.784E-19, 0.148E-18, 0.138E-18, 0.129E-18, 0.122E-18, & + 0.114E-18, 0.107E-18, 0.998E-19, 0.932E-19, 0.868E-19, 0.807E-19, & + 0.748E-19, 0.690E-19, 0.633E-19, 0.579E-19, 0.529E-19, 0.480E-19, & + 0.433E-19, 0.390E-19, 0.349E-19, 0.313E-19, 0.278E-19, 0.247E-19, & + 0.217E-19, 0.190E-19, 0.162E-19, 0.138E-19, 0.118E-19, 0.991E-20, & + 0.829E-20, 0.690E-20, 0.566E-20, 0.452E-20, 0.361E-20, 0.288E-20, & + 0.229E-20, 0.181E-20, 0.157E-20, 0.147E-20, 0.138E-20, 0.131E-20, & + 0.125E-20, 0.118E-20, 0.112E-20, 0.106E-20, 0.100E-20, 0.947E-21, & + 0.893E-21, 0.838E-21, 0.743E-21, 0.581E-21, 0.428E-21, 0.332E-21, & + 0.262E-21, 0.192E-21, 0.141E-21, 0.910E-22, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,20),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,21),kl=1,130)/0.180E-16, 0.181E-16, 0.179E-16, 0.174E-16, & + 0.167E-16, 0.159E-16, 0.146E-16, 0.133E-16, 0.118E-16, 0.101E-16, & + 0.850E-17, 0.695E-17, 0.540E-17, 0.411E-17, 0.301E-17, 0.215E-17, & + 0.163E-17, 0.105E-17, 0.754E-18, 0.524E-18, 0.382E-18, 0.272E-18, & + 0.202E-18, 0.152E-18, 0.112E-18, 0.876E-19, 0.677E-19, 0.596E-19, & + 0.541E-19, 0.510E-19, 0.489E-19, 0.469E-19, 0.448E-19, 0.419E-19, & + 0.377E-19, 0.336E-19, 0.285E-19, 0.238E-19, 0.190E-19, 0.145E-19, & + 0.106E-19, 0.752E-20, 0.610E-20, 0.553E-20, 0.496E-20, 0.457E-20, & + 0.418E-20, 0.380E-20, 0.341E-20, 0.302E-20, 0.279E-20, 0.256E-20, & + 0.232E-20, 0.209E-20, 0.171E-20, 0.110E-20, 0.644E-21, 0.416E-21, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,21),kl=1,130)/1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, & + 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000, 1.000000/ + DATA (xs(kl,22),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.340E-20, 0.401E-20, 0.486E-20, 0.573E-20, 0.662E-20, 0.754E-20, & + 0.906E-20, 0.112E-19, 0.133E-19, 0.162E-19, 0.202E-19, 0.224E-19, & + 0.248E-19, 0.276E-19, 0.289E-19, 0.318E-19, 0.322E-19, 0.321E-19, & + 0.338E-19, 0.343E-19, 0.307E-19, 0.290E-19, 0.275E-19, 0.272E-19, & + 0.272E-19, 0.272E-19, 0.272E-19, 0.273E-19, 0.280E-19, 0.283E-19, & + 0.268E-19, 0.249E-19, 0.212E-19, 0.151E-19, 0.127E-19, 0.142E-19, & + 0.229E-19, 0.358E-20, 0.000E+00, 0.000E+00, 0.286E-21, 0.208E-20, & + 0.344E-20, 0.764E-20, 0.107E-19, 0.159E-19, 0.166E-19, 0.303E-19, & + 0.263E-19, 0.336E-19, 0.366E-19, 0.456E-19, 0.643E-19, 0.546E-19, & + 0.922E-19, 0.677E-19, 0.599E-19, 0.117E-18, 0.715E-19, 0.730E-19, & + 0.201E-18, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,22),kl=1,130)/0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, 0.400000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + DATA (xs(kl,23),kl=1,130)/0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.164E-20, & + 0.211E-20, 0.227E-20, 0.264E-20, 0.340E-20, 0.465E-20, 0.598E-20, & + 0.803E-20, 0.986E-20, 0.118E-19, 0.137E-19, 0.160E-19, 0.189E-19, & + 0.228E-19, 0.275E-19, 0.307E-19, 0.321E-19, 0.335E-19, 0.349E-19, & + 0.363E-19, 0.378E-19, 0.393E-19, 0.407E-19, 0.421E-19, 0.435E-19, & + 0.449E-19, 0.462E-19, 0.487E-19, 0.527E-19, 0.564E-19, 0.589E-19, & + 0.616E-19, 0.556E-19, 0.553E-19, 0.543E-19, 0.365E-19, 0.318E-19, & + 0.316E-19, 0.156E-19, 0.428E-20, 0.113E-20, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, & + 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00, 0.000E+00/ + DATA (xqy(kl,23),kl=1,130)/0.019894, 0.019716, 0.019528, 0.019339, & + 0.019140, 0.018941, 0.018742, 0.018543, 0.018333, 0.018113, 0.017893, & + 0.017673, 0.017453, 0.017212, 0.016982, 0.016741, 0.016531, 0.016238, & + 0.015976, 0.015714, 0.015442, 0.015159, 0.014876, 0.014593, 0.014290, & + 0.013986, 0.013682, 0.013357, 0.013032, 0.012697, 0.012341, 0.011995, & + 0.011629, 0.011314, 0.010874, 0.010487, 0.010078, 0.009670, 0.009240, & + 0.008800, 0.008350, 0.007910, 0.007648, 0.007543, 0.007438, 0.007333, & + 0.007229, 0.007124, 0.007019, 0.006914, 0.006810, 0.006705, 0.006600, & + 0.006495, 0.006286, 0.005867, 0.005343, 0.004819, 0.004295, 0.003772, & + 0.003248, 0.002724, 0.002200, 0.001676, 0.001153, 0.000629, 0.000105, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, & + 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000, 0.000000/ + ! END MODULE module_data_photmad +! + CONTAINS + subroutine madronich1_driver(id,ktau,dtstep,config_flags,haveaer, & + gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & + chem,rho_phy,dz8w, & + xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + pm2_5_dry,pm2_5_water,uvrad, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + USE module_model_constants + USE module_data_radm2 + implicit none + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water,gd_cloud,gd_cloud2 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + aerwrf , & + rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + xlat, & + xlong + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT ) :: uvrad + REAL, INTENT(IN ) :: & + dtstep,gmt + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + LOGICAL, INTENT(IN) :: haveaer +! +! +! LOCAL VAR + + INTEGER :: ki,i,j,k,ixhour,n,iprt +! photolysis input +! + real tt(kts:kte),o33(kts:kte),rhoa(kts:kte),aerext(kts:kte),qll(kts:kte), & + phizz(kts:kte),phot1(nreakj-1,kts:kte) + real :: xtime,xhour,xmin,gmtp,uvb_dd1,uvb_du1,uvb_dir1 + real :: zenith,zenita,azimuth,dobsi + real :: bext340,bexth2o,ctr + integer :: naerspec +! print *,'gmt,julday in madronich1= ',gmt,julday + xtime=ktau*dtstep/60. + ixhour=ifix(gmt+.01)+ifix(xtime/60.) + xhour=float(ixhour) + xmin=60.*gmt+(xtime-xhour*60.) + gmtp=mod(xhour,24.) + gmtp=gmtp+xmin/60. +! print *,'gmtp = ',gmtp,xhour,xmin + do 100 j=jts,jte + do 100 i=its,ite +! write(0,*)i,j + do k=kts,kte + do n=1,nreakj-1 + phot1(n,k)=0. + END DO + END DO + iprt = 0 + zenith=0. + zenita=0. + azimuth=0. + call calc_zenith(xlat(i,j),-xlong(i,j),julday,gmtp,azimuth,zenith) +! if nighttime, skip radiative transfer calculation + if(zenith.eq.90.) zenith = 89.9 + if(zenith.ge.90.) go to 199 + zenita = cos(zenith*pi/180.) + if(zenith.gt.75.) zenita=1./chap(zenith) +! photmad berechnet photolysefrequenzen nach Madronich in folgender Reihenfolge + +! o2 absorp 1 schumman-runge corrected in srband +! o3 -> 1d 2 at 275 k. correct t-dep in subgrid +! o3 -> 3p 3 at 275 k. correct t-dep in subgrid +! no2 4 +! no3 -> no+o2 5 +! no3 -> no2+o 6 +! hno2 7 +! hno3 8 +! hno4 9 +! h2o2 10 +! ch2o -> rad 11 +! ch2o -> mol 12 +! ch3cho 13 +! ch3coch3 14 +! ch3coc2h5 15 +! hcocho proc a 16 +! ch3cocho 17 +! hcoch=chcho 18 estimate, no reliable measurement +! ch3o2h 19 +! ch3coo2h 20 actually use 0.28*(h2o2 value) +! ch3ono2 21 +! hcocho proc b 22 + do k=kts,kte-1 + aerext(k+1)=aerwrf(i,k+1,j) +! +!--- if you have aerosols +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + bext340=5.E-6 + bexth2o=5.E-6 + if(haveaer.and.ktau.gt.1)then + +! dry aerosol mass +!rf check ki (or ki+1 or ki-1 ?) + aerext(k)=pm2_5_dry(i,k,j)*bext340+ & + pm2_5_water(i,k,j)*bexth2o + aerext(k)=aerext(k)*1.E3 +! if(i.eq.70.and.j.eq.70) write(06,*) 'aerext',k,aerext(k) + + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + qll(k+1)=0. + tt(k+1) = t_phy(i,k,j) + rhoa(k+1) = rho_phy(i,k,j) + o33(k+1) = max(1.e-3,chem(i,k,j,p_o3)) + qll(k+1) = 1.e3*(moist(i,k,j,p_qc)+moist(i,k,j,p_qi)+ & + gd_cloud(i,k,j)+gd_cloud2(i,k,j)) & + *rho_phy(i,k,j) + if(qll(k+1).lt.1.e-5)qll(k+1) = 0. + phizz(k+1) = z_at_w(i,k+1,j)*.001-z_at_w(i,1,j)*.001 +! if((i.eq.1.and.j.eq.17))then +! write(0,*)k+1,phizz(k+1),qll(k+1),moist(i,k,j,p_qc),moist(i,k,j,p_qi),rqccuten(i,k,j),rqicuten(i,k,j),rho_phy(i,k,j) +! write(0,*)k+1,z_at_w(i,k+1,j),z_at_w(i,1,j),tt(k+1),o33(k+1),qll(k+1),rhoa(k+1) +! endif + END DO + tt(1)=t8w(i,kts,j) + o33(1)=max(1.e-3,chem(i,kts,j,p_o3)) + qll(1)=0. + phizz(1)=0. + aerext(1)=aerwrf(i,1,j) + k=0 +! write(0,*)k+1,z_at_w(i,k+1,j),z_at_w(i,1,j),tt(k+1),o33(k+1),qll(k+1),rhoa(k+1) +! +! if you have aerosols.... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + if(haveaer)then + aerext(1)=pm2_5_dry(i,1,j)*bext340+ & + pm2_5_water(i,1,j)*bexth2o + aerext(1)=aerext(1)*1.e3 + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + rhoa(1)=p8w(i,kts,j)/t8w(i,kts,j)/r_d + dobsi=350. +! if((i.eq.87.and.j.eq.66).or.(i.eq.105.and.j.eq.70))then +! print *,'before photmad, i,j = ',i,j,pm2_5_dry(i,1,j),pm2_5_water(i,1,j) +! print *,k,rhoa(1),phizz(1),qll(1),aerext(1),o33(1),tt(1),zenita +! endif +!write(0,*)'calling photolysis_mad --------',i,j + call photolysis_mad(kte-1,zenita,phizz,tt,rhoa,o33,aerext,qll,dobsi,phot1, & + nreacj,iprt,uvb_dd1,uvb_du1,uvb_dir1) +!write(0,*)'back from photolysis_mad ---------------------------- ' +! print *,'after photmad, i,j = ',i,j + uvrad(i,j)=uvb_dd1+uvb_dir1-uvb_du1 + do k=kts,kte-1 + do n=1,nreakj-1 + phot1(n,k)=60.*phot1(n,k) + END DO + END DO + 199 continue + do k=kts,kte-1 +! +! + ph_o31d(i,k,j) = phot1(1,k) + ph_o33p(i,k,j) = phot1(2,k) + ph_no2(i,k,j) = phot1(3,k) + ph_no3o2(i,k,j) = phot1(4,k) + ph_no3o(i,k,j) = phot1(5,k) + ph_hno2(i,k,j) = phot1(6,k) + ph_hno3(i,k,j) = phot1(7,k) + ph_hno4(i,k,j) = phot1(8,k) + ph_h2o2(i,k,j) = phot1(9,k) + ph_ch2or(i,k,j) = phot1(10,k) + ph_ch2om(i,k,j) = phot1(11,k) + ph_ch3cho(i,k,j) = phot1(12,k) + ph_ch3coch3(i,k,j) = phot1(13,k) + ph_ch3coc2h5(i,k,j) = phot1(14,k) + ph_hcocho(i,k,j) = phot1(15,k) + ph_ch3cocho(i,k,j) = phot1(16,k) + ph_hcochest(i,k,j) = phot1(17,k) + ph_ch3o2h(i,k,j) = phot1(18,k) + ph_ch3coo2h(i,k,j) = phot1(19,k) + ph_ch3ono2(i,k,j) = phot1(20,k) + ph_hcochob(i,k,j) = phot1(21,k) + ph_macr(i,k,j) = phot1(22,k) +! if(i.eq.5.and.j.eq.5)print *,i,j,k,phot1(3,k),phot1(4,k),phot1(17,k) + END DO + 100 continue + +END SUBROUTINE madronich1_driver + + SUBROUTINE photolysis_mad(mkxcc,a,zmm5,tmm5,pmm5,o3mm5,aerext,wlmm5, & + dobsnew,phot1,nrtest,iprt,uvb_dd1,uvb_du1,uvb_dir1) + ! Note that nreakj can differ from nreacj in csolve1!!!!!! + ! ----- INPUT ------------------------------------------------ + ! Input from MM5 + ! ------ OUTPUT ---------------------------------------------- + ! ----------------------------------------------------------------------- + ! This program calculates J-values for selected atmospheric molecules + ! the program and subroutine structure is as follows + ! runph -main program and menu. + ! calc_zenith -zenith angle calc. + ! in addition, the chapman function ch(zenith) is used between + ! readd -reads spectra and standard profiles + ! photmat -main subroutine (calls the routines below) + ! o3scal -rescales ozone profile to user-selected new dobson + ! subgrid -regrids the altitude profiles ( + ! srband -computes effective ozone cross sections in the + ! schumamkxcc+1+nabv-runge region (if necessary) + ! trapez -interpolation subroutine + ! optics -computes optical parameters and calls delta-eddington + ! delted -delta-eddington code of wiscombe + ! nlayde(ib) -multylayer calc + ! leqt1b(a,n,ncl,nuc,ia,b,m,ib,ijob,kl) -solves + ! pentadiag.system + ! Original program written by S. Madronich, NCAR. The code was + ! last modified by him on 18 Aug. 1987. + ! The driver for the chemistry has been heavily modified by + ! W. R. Stockwell at IFU Germany. (The modifications allow + ! the simulation conditions to be directly modified + ! without recompiling the program [this does not hold for the present + ! version here any more]). The extremely large data base + ! has bee replaced with separate files to allow cross sections and + ! photolysis rates to be more easily updated. However, the order + ! of the input files should be modified with extreme caution. + ! The present version is made for the use of computed + ! fields of T, P, O3, wl, and aerosol (if available) + ! Modifications were made by Renate Forkel in Aug./Sept 1995 + ! The following modifications were made: + ! - No climatological input any more + ! - Arbitrary vertical grid + ! - Several seperate cloud layers are possible. Number of additional + ! layers within the clouds depends on the optical depth + ! - Vertically inhogeneous clouds are possible now + ! - No variable values in commons any more + ! ----------------------------------------------------------------------- + ! xnkg: Molecules per kg air + ! .. Scalar Arguments .. + REAL :: a, dobsnew,uvb_dd1,uvb_du1,uvb_dir1 + INTEGER :: iprt, mkxcc, nrtest + ! .. Local Scalars .. + REAL :: aeru, airu, bextn, df, dj, dz, ff, gaer, gcld, gray, haer, & + hair, ho3, o3u, omaer, omcld, omray, reff, tu, wmicron, xnkg, xx, & + znorm, zu + INTEGER :: i, j, k, kk, kl, lev, nlayer, nlevel, nn, nr, nsurf + ! .. Array Arguments .. + REAL :: aerext(mkxcc+1), o3mm5(mkxcc+1), phot1(nreakj-1,mkxcc+1), & + pmm5(mkxcc+1), tmm5(mkxcc+1), wlmm5(mkxcc+1), zmm5(mkxcc+1) + ! .. Local Arrays .. + REAL :: aaer(130), aer(mkxcc+1+nabv), air(mkxcc+1+nabv), ao2(nj,130), & + ao3(nj,130), arayl(130), cloud(mkxcc+1+nabv), cvo2(nj), & + d(nreakj,nj), endir(nj,130), endn(nj,130), enup(nj,130), & + hilf1(mkxcc+1), hilfd(nj), o3(mkxcc+1+nabv), qy(nj,130,nreakj), & + s(nj,130,nreakj), t(mkxcc+1+nabv), vaer(nj), vair(nj), vcld(nj), & + vo3(nj), vt(nj), z(nj), zkm(mkxcc+1), zmid(nj), zz(mkxcc+1+nabv) + ! .. Data Statements .. + DATA xnkg/2.143E25/ + ! EXTERNAL o3scal, optics, srband, subgrid, trapez + ! wave length range !!! If photolysis is also desired for levels above + ! 2 + ! kl0 should be set equal to 1 again!!!!!!!!!!!!!! + i = 1 + j = 1 + ! albedoph ************************ specify ground albedoph + ! use best estimate albedoph of demerjian et al., + ! adv.env.sci.tech.,v.10,p.369, (1980) + DO kl = kl0, kl1 + + IF (wl(kl)<400.) albedoph(kl) = 0.05 + + IF ((wl(kl)>=400.) .AND. (wl(kl)<450.)) albedoph(kl) = 0.06 + + IF ((wl(kl)>=450.) .AND. (wl(kl)<500.)) albedoph(kl) = 0.08 + + IF ((wl(kl)>=500.) .AND. (wl(kl)<550.)) albedoph(kl) = 0.10 + + IF ((wl(kl)>=550.) .AND. (wl(kl)<600.)) albedoph(kl) = 0.11 + + IF ((wl(kl)>=600.) .AND. (wl(kl)<640.)) albedoph(kl) = 0.12 + + IF ((wl(kl)>=640.) .AND. (wl(kl)<660.)) albedoph(kl) = 0.135 + + IF (wl(kl)>=660.) albedoph(kl) = 0.15 + END DO + + + + nn = mkxcc + 1 + nabv + + ! omray = single scattering albedoph, rayleigh. use 1.00 + ! gray = asymetry factor for rayleigh scattering. use 0.0 + ! arayl(kl) = rayleigh scattering cross section, from + ! frohlich and shaw, appl.opt. v.11, p.1773 (1980). + ! overrides tabulation of jdata.base + hair = 8.05 + omray = 1.0 + gray = 0.0 + + DO 10 kl = kl0, kl1 + wmicron = wl(kl)/1.E3 + xx = 3.916 + 0.074*wmicron + 0.050/wmicron + arayl(kl) = 3.90E-28/(wmicron)**xx +10 CONTINUE + + ! aerosol*********************** specify aerosols + ! aaer(kl) = aerosol total vertical optical depth variation with + ! wavelength. estimated from elterman (1968) + ! aer(i) = attenuation (per km) profile from elterman (1968). + ! given in data statement in beginning of code, for 340 nm (kl=6 + ! same vertical shape at all wavelengths. + ! normalized later (in subroutine subgrid) to total vertical dep + ! this wavelength. + ! omaer = aerosol single scattering albedoph. use 0.99 for now. + ! gaer = aerosol asymetry factor. use 0.61 (hansen and travis 197 + ! (these are assuming particles of about 0.1 micron radius + ! index of refraction of about 1.65 + 0.002i. + ! haer = the aerosol scale height at top of atmosphere + ! use equal to air (8.05 km) + + DO 20 kl = kl0, kl1 + aaer(kl) = 0.379*(340./wl(kl)) +20 CONTINUE + omaer = 0.990 + gaer = 0.610 + haer = 8.05 + + + omcld = 1.000 + gcld = 0.860 + + ho3 = 4.50 + + nsurf = 1 + + ! Vertikales Gitter ohne Wolken: Niveaus zz(i), i=1,mkxcc+1+nabv + + + ! Transformation of MM5-values + ! bextn: cloud extinction coeff per g/m**3 [1/km] + DO k = 1, mkxcc + 1 + zz(k) = zmm5(k) +!write(0,*)' here7a zz = zmm5 ',k,zmm5(k) + t(k) = tmm5(k) + air(k) = xnkg*pmm5(k)*1.E-6 + + ! falls o3mm5 in ppm + + o3(k) = o3mm5(k)*1.E-6*air(k) + aer(k) = aerext(k) + + ! bextn: cloud extinction coeff per g/m**3 [1/km] + ! **** warning: parameterization for bextn only good + ! for continental clouds + + IF (wlmm5(k)>0.) THEN + + ! vereinfachte Version, falls kein + ! Sulfat uebergeben wird. + + reff = 9.6*wlmm5(k)**0.333 + bextn = (0.0275+1.3/reff)*1000. + cloud(k) = wlmm5(k)*bextn + ELSE + cloud(k) = 0. + END IF + ! if(iprt.eq.1)write(6,'(i3,e12.4)')k,cloud(k) + END DO + + znorm = (50.-zz(mkxcc+1))/(50.-20.) + + DO k = 1, nabv + zz(mkxcc+1+k) = 50. - znorm*(50.-zabv(k)) +!write(0,*)' here8a ',k,' zz(',mkxcc+1+k,') ',zz(mkxcc+1+k),znorm,zabv(k) + END DO + + zu = zz(mkxcc+1) + tu = t(mkxcc+1) + o3u = o3(mkxcc+1) + airu = air(mkxcc+1) + aeru = aer(mkxcc+1) + kk = 1 + + ! Zufuegen von Werten oberhalb von MM5 + + ! Die 'abv'-Werte sind bereits in den richtigen Einheiten + DO k = mkxcc + 1 + 1, mkxcc + 1 + nabv +! write(0,'(2i3,5e12.3)') k,kk,zz(k),zabv(kk) +30 IF (zz(k)<=zabv(kk)) THEN + dz = zz(k) - zu + ff = dz/(zabv(kk)-zu) + t(k) = tu + ff*(tabv(kk)-tu) + o3(k) = o3u + ff*(o3abv(kk)-o3u) + air(k) = airu + ff*(pabv(kk)-airu) + aer(k) = aeru + ff*(caabv(kk)-aeru) + cloud(k) = 0. + ! if(iprt.eq.1)then +! write(0,'(2i3,5e12.3)') k,kk,zz(k),zabv(kk),ff,tabv(kk),air(k) + ! endif + ELSE +40 zu = zabv(kk) + tu = tabv(kk) + o3u = o3abv(kk) + airu = pabv(kk) + aeru = caabv(kk) + kk = kk + 1 + + IF (zabv(kk)20.) THEN + n20 = lay + GO TO 30 + END IF + +20 CONTINUE +30 CONTINUE + + e10 = alog(10.) + + DO 60 kl = kl0, kl1 + + IF (wl(kl)>205.) RETURN + + DO 40 lay = n20, nlayer + x1 = alog(4.696E-23*cvo2(lay)/0.2095)/e10 + + IF (wl(kl)>=200.) x1 = vt(lay) + x2 = x1*x1 + x3 = x2*x1 + x4 = x3*x1 + x5 = x4*x1 + x6 = x5*x1 + x7 = x6*x1 + x8 = x7*x1 + ao20lg = sra(kl,1) + sra(kl,2)*x1 + sra(kl,3)*x2 + sra(kl,4)*x3 + & + sra(kl,5)*x4 + sra(kl,6)*x5 + sra(kl,7)*x6 + sra(kl,8)*x7 + & + sra(kl,9)*x8 + ao20 = 10.**ao20lg + + y1 = alog(cvo2(lay))/e10 + y2 = y1*y1 + y3 = y2*y1 + y4 = y3*y1 + clog = srb(kl,1) + srb(kl,2)*y1 + srb(kl,3)*y2 + srb(kl,4)*y3 + & + srb(kl,5)*y4 + c = 10.**clog + zendep = a**c + + ao2(lay,kl) = ao20*zendep +40 CONTINUE + ! assign values below 20 km + DO 50 lay = 1, n20 - 1 + ao2(lay,kl) = ao2(n20,kl) +50 CONTINUE +60 CONTINUE + + RETURN + + END SUBROUTINE srband + + ! ###################################################################### + + SUBROUTINE o3scal(dobsnew,ho3,zz,o3,nn) + ! adjustment of o3 profiles to a user-selected dobson value. + ! select value of dobnew in main program + ! if don't want to use, don't call this subroutine + ! .. Scalar Arguments .. + REAL :: dobsnew, ho3 + INTEGER :: nn + ! .. Local Scalars .. + REAL :: dobsref + INTEGER :: i + ! .. Intrinsic Functions .. + INTRINSIC max, min + ! .. Array Arguments .. + REAL :: o3(nn), zz(nn) + ! write(6,*) o3 + dobsref = o3(nn)*1.E5*ho3 + ! write(06,'('nn: dobsref,dobsnew',2e12.4)') + ! & dobsref/2.687e16,dobsnew + DO 10 i = 1, nn +10 dobsref = dobsref + o3(i)*0.5*(zz(min(i+1,nn))-zz(max(i-1,1)))*1.E5 + dobsref = dobsref/2.687E16 + ! write(06,'('dobsref,dobsnew',2e12.4)') dobsref,dobsnew + DO 20 i = 1, nn + o3(i) = o3(i)*dobsnew/dobsref +20 CONTINUE + ! write(06,*) o3 + + RETURN + + END SUBROUTINE o3scal + + ! ####################################################################### + + SUBROUTINE leqt1b(a,n,nlc,nuc,ia,b,m,ib,ijob,xl) + ! -leqt1b--------s-------library + ! 3--------------------------------------- + ! function - matrix decomposition, linear equation + ! solution - space economizer solution - + ! band storage mode + ! usage - call leqt1b (a,n,nlc,nuc,ia,b,m,ib,ijob,xl, + ! ier) + ! parameters a - input/output matrix of dimension n by + ! (nuc+nlc+1). see parameter ijob. + ! n - order of matrix a and the number of rows in + ! b. (input) + ! nlc - number of lower codiagonals in matrix a. + ! (input) + ! nuc - number of upper codiagonals in matrix a. + ! (input) + ! ia - row dimension of a as specified in the + ! calling program. (input) + ! b - input/output matrix of dimension n by m. + ! on input, b contains the m right-hand sides + ! of the equation ax = b. on output, the + ! solution matrix x replaces b. if ijob = 1, + ! b is not used. + ! m - number of right hand sides (columns in b). + ! (input) + ! ib - row dimension of b as specified in the + ! calling program. (input) + ! ijob - input option parameter. ijob = i implies when + ! i = 0, factor the matrix a and solve the + ! equation ax = b. on input, a contains the + ! coefficient matrix of the equation ax = b, + ! where a is assumed to be an n by n band + ! matrix. a is stored in band storage mode + ! and therefore has dimension n by + ! (nlc+nuc+1). on output, a is replaced + ! by the u matrix of the l-u decomposition + ! of a rowwise permutation of matrix a. u is + ! stored in band storage mode. + ! i = 1, factor the matrix a. a contains the + ! same input/output information as if + ! ijob = 0. + ! i = 2, solve the equation ax = b. this + ! option implies that leqt1b has already + ! been called using ijob = 0 or 1 so that + ! the matrix a has already been factored. + ! in this case, output matrices a and xl + ! must have been saved for reuse in the + ! call to leqt1b. + ! xl - work area of dimension n*(nlc+1). the first + ! nlc*n locations of xl contain components of + ! the l matrix of the l-u decomposition of a + ! rowwise permutation of a. the last n + ! locations contain the pivot indices. + ! ----------------------------------------------------------------------- + ! latest revision - november 27,1973 + ! dimension a(ia,1),xl(n,1),b(ib,1) ! Urspr. Zustand, fun + ! .. Scalar Arguments .. + INTEGER :: ia, ib, ijob, m, n, nlc, nuc + ! .. Array Arguments .. + REAL :: a(ia,5), b(ib,5), xl(n,5) + ! .. Local Scalars .. + REAL :: one, p, q, rn, zero + INTEGER :: i, ik, j, jbeg, jend, k, k1, kk, l, nc, nlc1, nn + ! .. Intrinsic Functions .. + INTRINSIC abs + ! .. Data Statements .. + DATA zero/0./, one/1.0/ + + p = 0 + jbeg = nlc + 1 + nlc1 = jbeg + + IF (ijob==2) GO TO 170 + rn = n + ! restructure the matrix + ! find reciprocal of the largest + ! absolute value in row i + i = 1 + nc = jbeg + nuc + nn = nc + jend = nc + + IF (n==1 .OR. nlc==0) GO TO 50 +10 k = 1 + p = zero + + DO 20 j = jbeg, jend + a(i,k) = a(i,j) + q = abs(a(i,k)) + + IF (q>p) p = q + k = k + 1 +20 CONTINUE + + IF (p==zero) GO TO 280 + xl(i,nlc1) = one/p + + IF (k>nc) GO TO 40 + + DO 30 j = k, nc + a(i,j) = zero +30 CONTINUE +40 i = i + 1 + jbeg = jbeg - 1 + + IF (jend-jbeg==n) jend = jend - 1 + + IF (i<=nlc) GO TO 10 + jbeg = i + nn = jend +50 jend = n - nuc + + DO 90 i = jbeg, n + p = zero + + DO 60 j = 1, nn + q = abs(a(i,j)) + + IF (q>p) p = q +60 CONTINUE + + IF (p==zero) GO TO 280 + xl(i,nlc1) = one/p + + IF (i==jend) GO TO 80 + + IF (il) GO TO 110 + + DO 100 j = k1, l + q = abs(a(j,1))*xl(j,nlc1) + + IF (q<=p) GO TO 100 + p = q + i = j +100 CONTINUE +110 xl(i,nlc1) = xl(k,nlc1) + xl(k,nlc1) = i + ! singularity found + IF ((rn+p)==rn) GO TO 280 + ! interchange rows i and k + IF (k==i) GO TO 130 + + DO 120 j = 1, nc + p = a(k,j) + a(k,j) = a(i,j) + a(i,j) = p +120 CONTINUE + +130 IF (k1>l) GO TO 160 + + DO 150 i = k1, l + p = a(i,1)/a(k,1) + ik = i - k + xl(k1,ik) = p + + DO 140 j = 2, nc + a(i,j-1) = a(i,j) - p*a(k,j) +140 CONTINUE + a(i,nc) = zero +150 CONTINUE +160 CONTINUE + + IF (ijob==1) GO TO 270 + ! forward substitution +170 l = nlc + + DO 220 k = 1, n + i = xl(k,nlc1) + + IF (i==k) GO TO 190 + + DO 180 j = 1, m + p = b(k,j) + b(k,j) = b(i,j) + b(i,j) = p +180 CONTINUE + +190 IF (ll) GO TO 220 + + DO 210 i = k1, l + ik = i - k + p = xl(k1,ik) + + DO 200 j = 1, m + b(i,j) = b(i,j) - p*b(k,j) +200 CONTINUE +210 CONTINUE +220 CONTINUE + ! backward substitution + jbeg = nuc + nlc + + DO 260 j = 1, m + l = 1 + k1 = n + 1 + + DO 250 i = 1, n + k = k1 - i + p = b(k,j) + + IF (l==1) GO TO 240 + + DO 230 kk = 2, l + ik = kk + k + p = p - a(k,kk)*b(ik-1,j) +230 CONTINUE +240 b(k,j) = p/a(k,1) + + IF (l<=jbeg) l = l + 1 +250 CONTINUE +260 CONTINUE + +270 RETURN + +280 CONTINUE + CALL wrf_error_fatal ( ' leqt1b error--matrix algorithmically singular') + END SUBROUTINE leqt1b + + ! ####################################################################### + + FUNCTION chap(zeta) + ! chapman function is used when the solar zenith angle exceeds + ! 75 deg. + ! interpolates between values given in, e.g., mccartney (1976). + ! .. Scalar Arguments .. + REAL :: zeta + ! .. Local Scalars .. + REAL :: rm + INTEGER :: i + ! .. Local Arrays .. + REAL :: y(22) + ! .. Function Return Value .. + REAL :: chap + ! .. Data Statements .. + DATA (y(i),i=1,22)/3.800, 4.055, 4.348, 4.687, 5.083, 5.551, 6.113, & + 6.799, 7.650, 8.732, 10.144, 12.051, 14.730, 18.686, 24.905, 35.466, & + 55.211, 96.753, 197., 485., 1476., 9999./ + + DO 10 i = 75, 96 + rm = i + + IF (zetanj) THEN + CALL wrf_error_fatal ( 'LEV > NJ, NJ GROESSER WAEHLEN') + END IF + + z(lev) = z(lev-1) + dzu + zt(lev) = t(i-1) + (z(lev)-zz(i-1))/(zz(i)-zz(i-1))*(t(i)-t(i-1) & + ) + + if(abs(air(i)-air(i-1)).lt.air(i-1)/1.e5)then + zair(lev) = air(i-1) + else + hlocal = 1./alog(air(i-1)/air(i)) + x0 = (z(lev)-zz(i-1))/(zz(i)+zz(i-1)) + zair(lev) = air(i-1)*exp(-x0/hlocal) + endif + vcld(lev) = cloud(i) + ! write(06,'('u:z,t,air ',i3,3e12.4)') + ! lev,z(lev),zt(lev),zair(lev) + END DO + +10 CONTINUE + + IF (i==nn) GO TO 20 + ! if(lev.ne.1) vcld(lev)=cloud(i) + dzt = (zz(i+1)-zz(i))*.5 + ! number of layers depents on optical depth + idt = max(ifix(cloud(i)*dzt*fnum),1) + dzo = dzt/float(idt) + + DO il = 1, idt + lev = lev + 1 + + IF (lev>nj) THEN + CALL wrf_error_fatal ( 'LEV > NJ, NJ GROESSER WAEHLEN') + END IF + + z(lev) = z(lev-1) + dzo + zt(lev) = t(i) + (z(lev)-zz(i))/(zz(i+1)-zz(i))*(t(i+1)-t(i)) + if(abs(air(i)-air(i+1)).lt.air(i)/1.e5)then + zair(lev) = air(i) + else + hlocal = 1./alog(air(i)/air(i+1)) + x0 = (z(lev)-zz(i))/(zz(i+1)+zz(i)) + zair(lev) = air(i)*exp(-x0/hlocal) + endif + vcld(lev-1) = cloud(i) + ! write(06,'('o:z,t,air ',i3,3e12.4)') + ! lev,z(lev),zt(lev),zair(lev) + END DO + +20 CONTINUE + END IF + ! write(06,'('o:z,t,air ',i3,3e12.4)') lev,z(lev),zt(lev),zair(lev) +30 CONTINUE + + ! number of levels including additional cloud levels + + nlevel = lev + + IF (nlevel>nj) print *, ' NLEVEL > NJ, NJ GROESSER WAEHLEN ', & + nlevel + + ! write(06,'(' nlevel',i3)') nlevel + + + ! assign default yields + DO 40 nr = 1, nreakj + + DO 40 kl = kl0, kl1 + + DO 40 lev = 1, nlevel +40 qy(lev,kl,nr) = xqy(kl,nr) + ! assign default absorption cross sections + DO 50 kl = kl0, kl1 + + DO 50 lev = 1, nlevel + + DO 50 nr = 1, nreakj +50 s(lev,kl,nr) = xs(kl,nr) + ! -------------------------------------------------------------------- + ! re-calculate altitude dependent quantum yields. this currently + ! applies to + ! 2=o3->o(1d) + ! 12=ch2o->h2+co + ! 13=ch3cho->ch3+cho + ! 14=ch3coch3 + ! 15=ch3coch2ch3 + ! 16=hcocho -> 0.13 hcho + 1.87 co process a + ! 17=ch3cocho + ! 22=hcocho -> 0.45 hcho + 1.55 co + 0.80 ho2 process b + + ! o3 and ketones yield is calculated from fit equations, + ! while for ch3cho and the dicarbonyls yields are calculated + ! from the ntp yield by linear adjustment to 1/yield. the ch2o yield + ! recalculated only for wavelengths longer than 329 nm. the yields for + ! 1=o3->o(3p) are calculated as (1.- singlet d yield). + + DO 60 lev = 1, nlevel + ! o3 ozone: + tau = zt(lev) - 230. + a = 0.9*(0.369+2.85E-4*tau+1.28E-5*tau*tau+2.57E-8*tau*tau*tau) + b = -0.575 + 5.59E-3*tau - 1.439E-5*tau*tau - 3.27E-8*tau*tau*tau + c = 0.9*(0.518+9.87E-4*tau-3.94E-5*tau*tau+3.91E-7*tau*tau*tau) + xl0 = 308.20 + 4.4871E-2*tau + 6.9380E-5*tau*tau - & + 2.5452E-6*tau*tau*tau + + DO 60 kl = kl0, kl1 + xl = wl(kl) + qy(lev,kl,2) = a*atan(b*(xl-xl0)) + c + + IF (qy(lev,kl,2)<0.) qy(lev,kl,2) = 0.0 + + IF (qy(lev,kl,2)>0.9) qy(lev,kl,2) = 0.9 + qy(lev,kl,3) = 1.0 - qy(lev,kl,2) + ! ch2o formaldehyde: + IF ((xl>=330.) .AND. qy(lev,kl,12)>0.) THEN + phi1 = qy(lev,kl,11) + phi2 = qy(lev,kl,12) + phi20 = 1. - phi1 + ak300 = ((1./phi2)-(1./phi20))/2.54E+19 + akt = ak300*(1.+61.69*(1.-zt(lev)/300.)*(xl/329.-1.)) + qy(lev,kl,12) = 1./((1./phi20)+zair(lev)*akt) + END IF + + IF (qy(lev,kl,12)>1.) qy(lev,kl,12) = 1.0 + + IF (qy(lev,kl,12)<0.) qy(lev,kl,12) = 0.0 + ! ch3cho acetaldehyde: + IF (xqy(kl,13)/=0.) THEN + qy(lev,kl,13) = 1./(1.+(1./xqy(kl,13)-1.)*zair(lev)/2.465E19) + END IF + ! ch3coch3 acetone: + qy(lev,kl,14) = 0.0766 + 0.09415*exp(-zair(lev)/3.222E18) + ! ch3coch2ch3 methyl ethyl ketone: + qy(lev,kl,15) = qy(lev,kl,14) + ! hcocho glyoxal process a: + IF (xqy(kl,16)/=0.) THEN + qy(lev,kl,16) = 1./(1.+(1./xqy(kl,16)-1.)*zair(lev)/2.465E19) + END IF + ! ch3cocho methylglyoxal: + IF (xqy(kl,17)/=0.) THEN + qy(lev,kl,17) = 1./(1.+(1./xqy(kl,17)-1.)*zair(lev)/2.465E19) + END IF + ! hcocho glyoxal process b: + IF (xqy(kl,22)/=0.) THEN + qy(lev,kl,22) = 1./(1.+(1./xqy(kl,22)-1.)*zair(lev)/2.465E19) + END IF + +60 CONTINUE + ! _______________________________________________________________________ + ! correct absorption cross sections for t and p dep. for now, do + ! 2=ozone + DO 90 kl = kl0, kl1 + + DO 80 lev = 1, nlevel + + IF (kl<33 .OR. kl>61) GO TO 70 + tdiffx = zt(lev) - 230. + s(lev,kl,2) = (so3tx(kl,1)+so3tx(kl,2)*tdiffx+so3tx(kl,3)*tdiffx* & + tdiffx)*1.0E-18 + s(lev,kl,3) = s(lev,kl,2) +70 CONTINUE +80 CONTINUE +90 CONTINUE + + ! ----------------------------------------------* layers + nlayer = nlevel - 1 + ! write(06,'(' Layers ',i3)') nlayer + lay = 0 + + DO 100 i = 1, nlayer + lay = lay + 1 + dz = z(i+1) - z(i) + zmid(lay) = z(i) + 0.5*dz + vt(lay) = (zt(lay+1)+zt(lay))/2. + vair(lay) = dz*1.E5*(zair(i+1)+zair(i))/2. +100 CONTINUE + + ! vo3(lay) = dz*1.e5*(o3(i+1) + o3(i))/2. ! umr. dz in cm + ! vcld(lay) = 0. *dz + ! vaer(lay) = (aer(i+1)-aer(i))/alog(aer(i+1)/aer(i)) *dz ! bei + + CALL trapez(zz,o3,1,nn,zmid,vo3,1,nlayer,nn,nn,nj,nj) + + + CALL trapez(zz,aer,1,nn,zmid,vaer,1,nlayer,nn,nn,nj,nj) + + DO 110 i = 1, nlayer + lay = i + dz = z(i+1) - z(i) + ! write(06,'('layer ',i3,6e12.4)') lay,zmid(lay),vt(lay), + ! & vair(lay)/dz,vo3(lay),vaer(lay),vcld(lay) + dz = z(i+1) - z(i) + + ! umr. dz in cm + + vo3(i) = dz*1.E5*vo3(i) + vcld(i) = vcld(i)*dz +110 vaer(i) = vaer(i)*dz + + + ! normalize aerosol optical depth to unity sum + sum = 0. + + DO 120 lay = 1, nlayer + sum = sum + vaer(lay) +120 CONTINUE + + DO 130 lay = 1, nlayer + vaer(lay) = vaer(lay)/sum +130 CONTINUE + + ! calculated vertical column of o2 above the midpoint of each layer: + ! want to use this for computing the average schumann-runge cross + ! secti + ! in each layer. + ! so use half of current layer and half of previous higher layer + + + cvo2(nlayer) = 0.2095*vair(nlayer)/2. + + DO 140 ii = 2, nlayer + lay = nlayer - ii + 1 + cvo2(lay) = cvo2(lay+1) + 0.2095*(vair(lay)+vair(lay+1))/2. +140 CONTINUE + + ! correct attenuation coefficients for pressure and/or temperature + ! dep. + ! for now do only ozone absorption. + DO 160 kl = kl0, kl1 + + DO 150 lay = 1, nlayer + tdiffx = vt(lay) - 230. + ao3(lay,kl) = xs(kl,2) + + IF (kl>=33 .AND. kl<=61) ao3(lay,kl) = (so3tx(kl,1)+so3tx(kl,2)* & + tdiffx+so3tx(kl,3)*tdiffx*tdiffx)*1.0E-18 + +150 CONTINUE +160 CONTINUE + + ! write(06,'(' z ')') + ! write(06,'(5e12.4 )') z + ! write(06,'(' zmid ')') + ! write(06,'(5e12.4 )') zmid + ! write(06,'(' zt ')') + ! write(06,'(5e12.4 )') zt + ! write(06,'(' vt ')') + ! write(06,'(5e12.4 )') vt + ! write(06,'(' vo3 ')') + ! write(06,'(5e12.4 )') vo3 + ! write(06,'(' vair ')') + ! write(06,'(5e12.4 )') vair + ! write(06,'(' vaer ')') + ! write(06,'(5e12.4 )') vaer + + + RETURN + + END SUBROUTINE subgrid + + SUBROUTINE optics(iprt,a,vair,arayl,gray,omray,ao2,vo3,ao3,vcld,gcld, & + omcld,vaer,aaer,gaer,omaer,nlayer,nlevel,nsurf,endir,endn,enup) + ! sm this subroutine prepares the data needed for the flux + ! calculation, + ! t + ! sm calls the scattering subroutine delted. it returns values of + ! the + ! sm flux flux(lev,kl) for altitude lev-1, wavelength kl. + ! sm it calculates the optical depths (vertical) + ! sm for each layer, from the vertical profiles of o2, o3, + ! sm air, cloud, and aerosol, and from the associated 'cross + ! sections + ! implicit real*4 (a-h,o-z) + ! .. Scalar Arguments .. + REAL :: a, gaer, gcld, gray, omaer, omcld, omray + INTEGER :: iprt, nlayer, nlevel, nsurf + ! .. Local Scalars .. + REAL :: dtabs, dtaer, dtair, dtcld, dto2, dto3, dtscat, fdinc, fuinc, & + solflx, sumtau + INTEGER :: ii, lay, lev, nlev, nz, nzm1 + LOGICAL :: mudept + ! .. Intrinsic Functions .. + ! EXTERNAL delted + INTRINSIC amin1 + ! .. Parameters .. + INTEGER, PARAMETER :: nsol = 1 + ! .. Array Arguments .. + REAL :: aaer(130), ao2(nj,130), ao3(nj,130), arayl(130), & + endir(nj,130), endn(nj,130), enup(nj,130), vaer(nj), vair(nj), & + vcld(nj), vo3(nj) + ! .. Local Arrays .. + REAL :: alb(nsol), dir(nj,nsol), dtau(nj), flxd(nj,nsol), & + flxu(nj,nsol), g(nj), musun(nsol), om(nj) + ! if(iprt.eq.1)then + ! write(06,*) a,kl0,kl1,gray,omray,gcld,omcld,gaer,omaer, + ! &nlayer,nlevel,nsurf + ! do kl=1,nlevel + ! write(06,'(5e12.4)') vair(kl),vo3(kl),vcld(kl),vaer(kl) + ! write(06,*) ao2 + ! enddo + ! endif + ! stop + ! loop over wavelengths + DO 30 kl = kl0, kl1 + + ! calculate optical depths for all layers (including cloud + ! sublayers) + + sumtau = 0. + + DO 10 lay = nsurf, nlayer + ii = nlayer + 1 - lay + dtair = vair(lay)*arayl(kl) + dto2 = 0.2095*vair(lay)*ao2(lay,kl) + dto3 = vo3(lay)*ao3(lay,kl) + dtcld = vcld(lay) + dtaer = vaer(lay)*aaer(kl) + + dtscat = dtair + dtcld + dtaer + dtabs = dto2 + dto3 + + dtau(ii) = dtabs + dtscat + om(ii) = (omray*dtair+omcld*dtcld+omaer*dtaer)/dtau(ii) + g(ii) = (gray*dtair+gcld*dtcld+gaer*dtaer)/dtscat + sumtau = sumtau + dtau(ii) + ! if(kl.eq.103.and.iprt.eq.1) ! 55um + ! & write(06,'(' Ope',i4,3e12.4)') + ! 2 ii,arayl(kl),dtcld,dtau(ii) +10 CONTINUE + + ! if(kl.eq.103.and.iprt.eq.1) ! 55um + ! &write(06,'(' Opt. Dicke',i4,2e12.4)') kl,sumtau + + ! initialize fluxes and other delted parameters + solflx = 1. + fdinc = 0. + fuinc = 0. + alb(1) = albedoph(kl) + musun(1) = amin1(a,0.999) + mudept = .FALSE. + nz = nlevel - nsurf + 1 + nzm1 = nz - 1 + nlev = nj + ! if(iprt.eq.1)print *,'nz = ',nz + ! --------------------------------------------------------------------- + CALL delted(dtau,om,g,musun,alb,solflx,fdinc,fuinc,mudept,nz,dir, & + flxu,flxd) + ! if(iprt.eq.1)print *,'nz = ',nz + ! --------------------------------------------------------------------- + ! return to upright grid + DO 20 ii = 1, nlevel - nsurf + 1 + lev = nlevel + 1 - ii + endir(lev,kl) = dir(ii,nsol) + endn(lev,kl) = flxd(ii,nsol) + enup(lev,kl) = flxu(ii,nsol) +20 CONTINUE + +30 CONTINUE + + RETURN + + END SUBROUTINE optics + + ! ####################################################################### + + SUBROUTINE nlayde(ib,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau,lm, & + pp,ex,tx,ty,tz,isav,flxsun,nl2) + ! multi-layer delta-eddington + ! ib = number of levels + ! the top and bottom boundary conditions plus the flux continuity + ! conditions at each interior level form a penta-diagonal system + ! of 2*ib-2 equations for the unknown constants (2 for each layer). + ! the columns of the -ss- array contain the diagonals of the coeffi + ! cient matrix, the lowermost diagonal in column 1, etc. (this is t + ! so-called band storage mode required by imsl routine leqt2b). + ! ueberflussig, falls man nur eine Sonnenhoehe vorsieht. + ! .. Scalar Arguments .. + REAL :: fdinc, fuinc + INTEGER :: ib, nl2 + LOGICAL :: mudept + ! .. Local Scalars .. + REAL :: albdo, rmu0, t1 + INTEGER :: i, ibm1, ic, ijob, ip1, ir, j, ktr, last, lastm2, np + ! .. Intrinsic Functions .. + ! EXTERNAL leqt1b + INTRINSIC exp + ! .. Parameters .. + INTEGER, PARAMETER :: nsol = 1 + ! .. Array Arguments .. + REAL :: alb(1), dir(nj,1), ex(nj), flxd(nj,1), flxsun(1), flxu(nj,1), & + isav(nj), lm(nj), musun(1), pp(nj), tau(nj), tx(nj), ty(nj), tz(nj) + ! .. Local Arrays .. + REAL :: alph(nj), beta(nj), cc(mj,5), exsun(nj), ss(mj,5), work(mj,3), & + x(mj) + + ibm1 = ib - 1 + last = 2*ib - 2 + ss(1,5) = 0. + ss(1,1) = ss(1,5) + ss(1,2) = ss(1,5) + ss(1,3) = (1.-pp(1))/ex(1) + ss(1,4) = (1.+pp(1))*ex(1) + lastm2 = last - 2 + + DO 10 j = 2, lastm2, 2 + i = j/2 + ip1 = i + 1 + ss(j,1) = 0. + ss(j,2) = 1.0 + ss(j,3) = 1.0 + ss(j,4) = -1.0/ex(ip1) + ss(j,5) = -ex(ip1) + ss(j+1,1) = -pp(i) + ss(j+1,2) = pp(i) + ss(j+1,3) = pp(ip1)/ex(ip1) + ss(j+1,4) = -pp(ip1)*ex(ip1) + ss(j+1,5) = 0. +10 CONTINUE + ss(last,5) = 0. + ss(last,1) = ss(last,5) + ss(last,4) = ss(last,5) + + IF (mudept) GO TO 30 + ss(last,2) = 1. + pp(ibm1) - alb(1)*(1.-pp(ibm1)) + ss(last,3) = 1. - pp(ibm1) - alb(1)*(1.+pp(ibm1)) + + ! calculate the l-u decomposition of penta-diagonal matrix -ss- + + ! leqt2b call for testing purposes + ! call leqt2b(ss,last,2,2,nl2,x,1,nl2, 1 ,work,nl2,work(1,8)) + + ! leqt1b destroys the input coeff matrix, so since we must + ! preserve -ss-, we must let it destroy -cc- instead. + DO 20 ic = 1, 5 + + DO 20 ir = 1, last +20 cc(ir,ic) = ss(ir,ic) + ! --------------------------------------------------------------------- + CALL leqt1b(cc,last,2,2,nl2,x,1,nl2,1,work) + ! --------------------------------------------------------------------- + + ! for each sun angle, calculate the r.h.s. of the banded system, + ! solve, and use the solution to construct the fluxes at each level + +30 DO 90 np = 1, nsol + rmu0 = 1./musun(np) + t1 = rmu0**2 - lm(1)**2 + + IF (t1==0.) THEN + t1 = 1.E-7 + PRINT *, 'ACHTUNG t1=0 fuer lm(1)' + END IF + + alph(1) = tx(1)/t1 + beta(1) = ty(1)*(musun(np)*tz(1)+rmu0)/t1 + x(1) = alph(1) + beta(1) + fdinc + + DO 40 j = 2, lastm2, 2 + i = j/2 + ip1 = i + 1 + t1 = rmu0**2 - lm(ip1)**2 + + IF (t1==0.) THEN + t1 = 1.E-7 + PRINT *, 'ACHTUNG t1=0 fuer lm(', ip1, ')' + END IF + + alph(ip1) = tx(ip1)/t1 + beta(ip1) = ty(ip1)*(musun(np)*tz(ip1)+rmu0)/t1 + exsun(ip1) = exp(-rmu0*tau(ip1)) + x(j) = (alph(i)-alph(ip1))*exsun(ip1) + x(j+1) = (beta(i)-beta(ip1))*exsun(ip1) +40 CONTINUE + exsun(ib) = exp(-rmu0*tau(ib)) + + IF (mudept) GO TO 50 + albdo = alb(1) + ijob = 2 + GO TO 70 +50 albdo = alb(np) + ijob = 0 + ss(last,2) = 1. + pp(ibm1) - alb(np)*(1.-pp(ibm1)) + ss(last,3) = 1. - pp(ibm1) - alb(np)*(1.+pp(ibm1)) + + DO 60 ic = 1, 5 + + DO 60 ir = 1, last +60 cc(ir,ic) = ss(ir,ic) + +70 x(last) = (alph(ibm1)-beta(ibm1)+albdo*(flxsun(np)-alph(ibm1)-beta( & + ibm1)))*exsun(ib) + fuinc + + ! solve penta-diagonal system with r.h.s. -x-. soln goes into -x- + + ! call leqt2b(ss,last,2,2,nl2,x,1,nl2,ijob,work,nl2,work(1,8)) + + ! --------------------------------------------------------------------- + CALL leqt1b(cc,last,2,2,nl2,x,1,nl2,ijob,work) + ! --------------------------------------------------------------------- + + dir(1,np) = flxsun(np) + flxd(1,np) = fdinc + flxu(1,np) = (1.+pp(1))/ex(1)*x(1) + (1.-pp(1))*ex(1)*x(2) - & + alph(1) + beta(1) + ktr = 2 + + DO 80 i = 1, ibm1 + + IF (i+1/=isav(ktr)) GO TO 80 + dir(ktr,np) = flxsun(np)*exsun(i+1) + flxd(ktr,np) = (1.-pp(i))*x(2*i-1) + (1.+pp(i))*x(2*i) - & + (alph(i)+beta(i))*exsun(i+1) + flxu(ktr,np) = (1.+pp(i))*x(2*i-1) + (1.-pp(i))*x(2*i) - & + (alph(i)-beta(i))*exsun(i+1) + ktr = ktr + 1 +80 CONTINUE +90 CONTINUE + + RETURN + + END SUBROUTINE nlayde + + ! ####################################################################### + + SUBROUTINE delted(dtau,om,g,musun,alb,solflx,fdinc,fuinc,mudept,nz,dir, & + flxu,flxd) + ! calculate up- and down-fluxes of radiation in a vertically inhomo- + ! geneous atmosphere using the delta-eddington approximation + ! author-- w.j. wiscombe + ! national center for atmospheric research + ! p.o. box 3000 + ! boulder, colorado 80303 + ! input variables + ! nz = number of levels (level 1 is the top of the atmosphere, + ! level nz is the surface) + ! dtau(i), i=1,...,nz-1 = optical depth of layer between levels i an + ! om(i), i=1,...,nz-1 = single-scattering albedoph of layer between + ! levels i and i+1 + ! g(i), i=1,...,nz-1 = asymmetry factor for layer between levels i a + ! nsol = number of incident-beam zenith angles + ! musun(i),i=1,...,nsol = cosine(s) of incident-beam zenith angle(s) + ! alb(i), i=1,...,nsol = surface albedoph + ! mudept = true, alb(i) corresponds to musun(i). false, alb(1) is + ! used for all values of musun(i). + ! solflx = incident-beam flux (normal to beam) at level 1 + ! the beam) at the top of the atmosphere + ! fdinc = incident diffuse down-flux at level 1 + ! fuinc = incident diffuse up-flux at level nz + ! nlev = level dimension (of arrays dtau, etc.) + ! output variables (in same units as solflx, fdinc, and fuinc) + ! dir(i,np) direct flux at level -i- for sun angle -np- + ! (note--in the delta-eddington approxn, because of t + ! truncation of the forward scattering peak, this + ! quantity includes scattered radiation travelling in + ! very nearly the same direction as the actual direct + ! flux. e.g., it includes the aureole around the sun + ! flxd(i,np) diffuse down-flux at level -i- for sun angle -np- + ! (note--this will be less than the actual diffuse + ! down-flux by the same amount that the direct flux + ! -dir- is augmented.) + ! flxu(i,np) diffuse up-flux at level -i- for sun angle -np- + ! internal + ! code variable description (or name in write-up) + ! gp g-prime (transformed asymmetry parameter) + ! omp omega-prime (transformed single scattering albedoph) + ! dtaup delta-tau-prime (transformed layer optical depth) + ! tau(i) cumulative optical depth from top (i=1) to level i + ! lm(i) lambda-sub-i + ! pp(i) p-sub-i + ! lmdtau lm(i)*dtaup + ! ex(i) exp(lmdtau) + ! exsun(i) exp(-tau(i)/musun(np)) + ! alph(i) alpha-sub-i + ! beta(i) beta-sub-i + ! tx(i) 0.75*solflx*omp*(1.+gp *(1.-omp)) + ! ty(i) 0.5*solflx*omp + ! tz(i) 3.*gp*(1.-omp) + ! (tx,ty,tz are merely intermediate quantities for computing alph, + ! isav array of level indices. fluxes are calculated only + ! at these levels. + ! flxsun(np) incident flux musun(np)*solflx at level 1 + ! prec a number somewhat larger than the computer precisio + ! subtracted from any single-scattering albedophs which + ! are exactly equal to one. + ! cutpt any layer for which lmdtau.gt.cutpt is subdivided + ! into equal sublayers, all of which have lmdtau.lt.c + ! nsub number of sublayers into which an offending layer + ! is divided (the whole process being transparent + ! to the user) + ! nl2 2*nlev-2 (input to banded matrix subroutine) + ! ss(nl2,5) the penta-diagonal matrix c, in band storage mode + ! cc(nl2,5) same as -ss- array. used to submit -ss- to leqt1b. + ! work(nl2,3) a temporary storage array used by subroutine leqt1 + ! x(nl2) the vector (x-hat). also temporarily stores + ! r.h.s. d in linear system c*(x-hat) = d. + ! --note-- this code is not perfectly optimized, either in terms of + ! core storage or execution speed, but it should be noted t + ! in general, the lions share of computing time is occupied + ! the exponentials and the penta-diagonal solution routines + ! so eliminating a few operations here or there has almost + ! no impact on running time. + ! ******************* 10 x computer precision ********************** + ! *********** cut-off point for lm(i)*dtaup ************ + ! .. Scalar Arguments .. + REAL :: fdinc, fuinc, solflx + INTEGER :: nz + LOGICAL :: mudept + ! .. Local Scalars .. + REAL :: aux, aux2, c1, cutpt, dtaup, ff, gp, lmdtau, omp, prec, scale, & + t1 + INTEGER :: i, ii, ip1, iup, iupm1, ktr, layers, nl2, nlev, np, nsub, & + nzm1 + ! .. Intrinsic Functions .. + ! EXTERNAL nlayde + INTRINSIC exp, float, sqrt + ! .. Parameters .. + INTEGER, PARAMETER :: nsol = 1 + ! .. Array Arguments .. + REAL :: alb(1), dir(nj,1), dtau(nj), flxd(nj,1), flxu(nj,1), g(nj), & + musun(1), om(nj) + ! .. Local Arrays .. + REAL :: ex(nj), flxsun(1), isav(nj), lm(nj), pp(nj), tau(nj), tx(nj), & + ty(nj), tz(nj) + ! .. Data Statements .. + DATA c1/0.66666666666667/ + DATA prec/1.E-7/ + DATA cutpt/7./ + ! set incident flux at top of atmosphere + DO 10 np = 1, nsol +10 flxsun(np) = musun(np)*solflx + + nzm1 = nz - 1 + nlev = nj + nl2 = 2*nlev - 2 + + ! scale optical depth, sing-scat albedoph, and asymmetry factor + ! and calculate various fcns of these variables + + nzm1 = nz - 1 + tau(1) = 0. + + DO 20 i = 1, nzm1 + ff = g(i)**2 + gp = g(i)/(1.+g(i)) + scale = 1. - ff*om(i) + omp = (1.-ff)*om(i)/scale + + IF (om(i)==1.0) omp = 1. - prec + t1 = 1. - omp*gp + aux = 3.*(1.-omp)*t1 + + IF (om(i)==1.0) aux = 3.*prec*t1 + aux2 = 1. - om(i) + lm(i) = sqrt(aux) + pp(i) = c1*lm(i)/t1 + t1 = gp*(1.-omp) + tx(i) = 0.75*solflx*omp*(1.+t1) + ty(i) = 0.5*solflx*omp + tz(i) = 3.*t1 + isav(i) = i + dtaup = scale*dtau(i) + lmdtau = lm(i)*dtaup + ! test for a layer which is so highly absorbing that it would + ! cause ill-conditioning in the penta-diagonal matrix. if one + ! is found, subdivide it appropriately. + IF (lmdtau>cutpt) GO TO 30 + ex(i) = exp(lmdtau) + tau(i+1) = tau(i) + dtaup +20 CONTINUE + isav(nz) = nz + + + ! normal calculation + + ! --------------------------------------------------------------------- + ! Nur noch nz > 2 moeglich + CALL nlayde(nz,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau,lm,pp, & + ex,tx,ty,tz,isav,flxsun,nl2) + ! --------------------------------------------------------------------- + GO TO 80 + + ! sidestep potential ill-conditioning by subdividing offending + ! layer, and any others like it. + +30 layers = nzm1 + ktr = i + +40 nsub = lmdtau/cutpt + 1. + dtaup = dtaup/float(nsub) + ex(i) = exp(lm(i)*dtaup) + tau(i+1) = tau(i) + dtaup + ip1 = i + 1 + iup = i + nsub + iupm1 = iup - 1 + + DO 50 ii = ip1, iupm1 + lm(ii) = lm(i) + pp(ii) = pp(i) + tx(ii) = tx(i) + ty(ii) = ty(i) + tz(ii) = tz(i) + ex(ii) = ex(i) +50 tau(ii+1) = tau(ii) + dtaup + ktr = ktr + 1 + isav(ktr) = isav(ktr-1) + nsub + layers = layers + nsub - 1 + + IF (layers>nlev) then + CALL wrf_error_fatal ( 'layers>nlev') + endif + + IF (iup>layers) GO TO 70 + + DO 60 i = iup, layers + ff = g(ktr)**2 + gp = g(ktr)/(1.+g(ktr)) + scale = 1. - ff*om(ktr) + omp = (1.-ff)*om(ktr)/scale + + IF (om(ktr)==1.0) omp = 1. - prec + t1 = 1. - omp*gp + lm(i) = sqrt(3.*(1.-omp)*t1) + pp(i) = c1*lm(i)/t1 + t1 = gp*(1.-omp) + tx(i) = 0.75*solflx*omp*(1.+t1) + ty(i) = 0.5*solflx*omp + tz(i) = 3.*t1 + dtaup = scale*dtau(ktr) + lmdtau = lm(i)*dtaup + ! test for a layer which is so highly absorbing that it would + ! cause ill-conditioning in the penta-diagonal matrix. if one + ! is found, subdivide it appropriately. + IF (lmdtau>cutpt) GO TO 40 + ex(i) = exp(lmdtau) + tau(i+1) = tau(i) + dtaup + ktr = ktr + 1 + isav(ktr) = isav(ktr-1) + 1 +60 CONTINUE + + ! --------------------------------------------------------------------- +70 CALL nlayde(layers+1,musun,alb,fdinc,fuinc,mudept,dir,flxu,flxd,tau, & + lm,pp,ex,tx,ty,tz,isav,flxsun,nl2) + ! --------------------------------------------------------------------- + +80 CONTINUE + RETURN + + END SUBROUTINE delted + + ! ####################################################################### + + SUBROUTINE calc_zenith(lat,long,ijd,gmt,azimuth,zenith) + ! this subroutine calculates solar zenith and azimuth angles for a + ! part + ! time and location. must specify: + ! input: + ! lat - latitude in decimal degrees + ! long - longitude in decimal degrees + ! gmt - greenwich mean time - decimal military eg. + ! 22.75 = 45 min after ten pm gmt + ! output + ! zenith + ! azimuth + ! .. Scalar Arguments .. + REAL :: azimuth, gmt, lat, long, zenith + INTEGER :: ijd + ! .. Local Scalars .. + REAL :: caz, csz, cw, d, decl, dr, ec, epsi, eqt, eyt, feqt, feqt1, & + feqt2, feqt3, feqt4, feqt5, feqt6, feqt7, lbgmt, lzgmt, ml, pepsi, & + pi, ra, raz, rdecl, reqt, rlt, rml, rphi, rra, ssw, sw, tab, w, wr, & + yt, zpt, zr + INTEGER :: jd + ! .. Intrinsic Functions .. + INTRINSIC acos, atan, cos, min, sin, tan + ! convert to radians + pi = 3.1415926535590 + dr = pi/180. + rlt = lat*dr + rphi = long*dr + + ! print julian days current 'ijd' + + ! ???? + (yr - yref) + + jd = ijd + + + + d = jd + gmt/24.0 + ! calc geom mean longitude + ml = 279.2801988 + .9856473354*d + 2.267E-13*d*d + rml = ml*dr + + ! calc equation of time in sec + ! w = mean long of perigee + ! e = eccentricity + ! epsi = mean obliquity of ecliptic + w = 282.4932328 + 4.70684E-5*d + 3.39E-13*d*d + wr = w*dr + ec = 1.6720041E-2 - 1.1444E-9*d - 9.4E-17*d*d + epsi = 23.44266511 - 3.5626E-7*d - 1.23E-15*d*d + pepsi = epsi*dr + yt = (tan(pepsi/2.0))**2 + cw = cos(wr) + sw = sin(wr) + ssw = sin(2.0*wr) + eyt = 2.*ec*yt + feqt1 = sin(rml)*(-eyt*cw-2.*ec*cw) + feqt2 = cos(rml)*(2.*ec*sw-eyt*sw) + feqt3 = sin(2.*rml)*(yt-(5.*ec**2/4.)*(cw**2-sw**2)) + feqt4 = cos(2.*rml)*(5.*ec**2*ssw/4.) + feqt5 = sin(3.*rml)*(eyt*cw) + feqt6 = cos(3.*rml)*(-eyt*sw) + feqt7 = -sin(4.*rml)*(.5*yt**2) + feqt = feqt1 + feqt2 + feqt3 + feqt4 + feqt5 + feqt6 + feqt7 + eqt = feqt*13751.0 + + ! convert eq of time from sec to deg + reqt = eqt/240. + ! calc right ascension in rads + ra = ml - reqt + rra = ra*dr + ! calc declination in rads, deg + tab = 0.43360*sin(rra) + rdecl = atan(tab) + decl = rdecl/dr + ! calc local hour angle + lbgmt = 12.0 - eqt/3600. + long*24./360. + lzgmt = 15.0*(gmt-lbgmt) + zpt = lzgmt*dr + csz = sin(rlt)*sin(rdecl) + cos(rlt)*cos(rdecl)*cos(zpt) + if(csz.gt.1)print *,'calczen,csz ',csz + csz = min(1.,csz) +! zr = acos(csz) +! zenith = zr/dr + zr = acos(csz) + zenith = zr/dr + ! calc local solar azimuth + caz = (sin(rdecl)-sin(rlt)*cos(zr))/(cos(rlt)*sin(zr)) + if(caz.lt.-0.999999)then + azimuth=180. + elseif(caz.gt.0.999999)then + azimuth=0. + else + raz = acos(caz) + azimuth = raz/dr + endif +! caz = min(1.,(sin(rdecl)-sin(rlt)*cos(zr))/(cos(rlt)*sin(zr))) +! if(caz.lt.-1)print *,'calczen ',caz +! caz = max(-1.,caz) +! raz = acos(caz) +! azimuth = raz/dr + + IF (lzgmt>0) azimuth = azimuth + (2*(180.-azimuth)) + ! 200 format(' ',f7.2,2(12x,f7.2)) + RETURN + + END SUBROUTINE calc_zenith + + SUBROUTINE trapez(x,y,ianfa,ienda,u,v,ianfn,iendn,ix,iy,iu,iv) + ! * implemented 1992 by ansgar ruggaber, university of munich, frg + ! * funded by the german minister of research and technology (bmft) + ! * under contract no. 521-4007-07eu-738 8 + ! lineare interpolation of referencefield (x(i),y(i)) + ! to (u(i),v(i)) + ! save + ! .. Scalar Arguments .. + INTEGER :: ianfa, ianfn, ienda, iendn, iu, iv, ix, iy + ! .. Array Arguments .. + REAL :: u(iu), v(iv), x(ix), y(iy) + ! .. Local Scalars .. + REAL :: uumord, vumord, xumord, yumord + INTEGER :: i, ianf, ianfnn, idrehu, idrehx, iendnn, iordu, iordx, j + + idrehx = 0 + + IF (x(ianfa)>=x(ienda)) THEN + ! das x-feld wird ansteigend geordnet, das y-feld entsprechend + iordx = (ienda-ianfa+1)/2 + + DO i = ianfa, iordx + xumord = x(i) + x(i) = x(ienda+1-i) + x(ienda+1-i) = xumord + yumord = y(i) + y(i) = y(ienda+1-i) + y(ienda+1-i) = yumord + END DO + + idrehx = 1 + END IF + + idrehu = 0 + + IF (u(ianfn)>=u(iendn)) THEN + ! u-field increasing + iordu = (iendn-ianfn+1)/2 + + DO i = ianfn, iordu + uumord = u(i) + u(i) = u(iendn+1-i) + u(iendn+1-i) = uumord + END DO + + idrehu = 1 + END IF + + ianfnn = ianfn +10 CONTINUE + + IF (u(ianfnn)x(ienda)) THEN + ! no extrapolation at x(ienda) + v(iendnn) = 1.0E-12 + iendnn = iendnn - 1 + GO TO 20 + END IF + + ianf = ianfa + + DO j = ianfnn, iendnn + + DO i = ianf, ienda + + IF (x(i)-u(j)) 30, 50, 40 +30 END DO + + GO TO 70 +40 v(j) = y(i-1) + (y(i)-y(i-1))/(x(i)-x(i-1))*(u(j)-x(i-1)) + GO TO 60 +50 v(j) = y(i) +60 ianf = i +70 END DO + + IF (idrehx/=0) THEN + ! x- und y-field in starting position + DO i = ianfa, iordx + xumord = x(i) + x(i) = x(ienda+1-i) + x(ienda+1-i) = xumord + yumord = y(i) + y(i) = y(ienda+1-i) + y(ienda+1-i) = yumord + END DO + + END IF + + IF (idrehu/=0) THEN + + DO i = ianfn, iordu + uumord = u(i) + u(i) = u(iendn+1-i) + u(iendn+1-i) = uumord + vumord = v(i) + v(i) = v(iendn+1-i) + v(iendn+1-i) = vumord + END DO + + END IF + + END SUBROUTINE trapez + + SUBROUTINE photmad_init(z_at_w,aerwrf,g,ids,ide,jds,jde,kds,kde,ims,ime, & + jms,jme,kms,kme,its,ite,jts,jte,kts,kte) + ! local stuff + ! .. Scalar Arguments .. + REAL, INTENT (IN) :: g + INTEGER, INTENT (IN) :: ide, ids, ime, ims, ite, its, jde, jds, jme, & + jms, jte, jts, kde, kds, kme, kms, kte, kts + ! .. Array Arguments .. + REAL, INTENT (INOUT) :: aerwrf(ims:ime,kms:kme,jms:jme) + REAL, INTENT (IN) :: z_at_w(ims:ime,kms:kme,jms:jme) + ! .. Local Scalars .. + REAL :: z1 + INTEGER :: i, j, k + ! .. Local Arrays .. + REAL :: aerext(kts:kte), phizz(kts:kte), z(kts:kte) + + DO j = jts, jte + + IF (j>jde-1) GO TO 20 + + DO i = its, ite + + IF (i>ide-1) GO TO 10 + + ! z at w points + + z1 = z_at_w(i,kts,j) + z(kts)=0. + + DO k = kts+1, kte + z(k) = z_at_w(i,k,j) - z1 + END DO + + DO k = kts, kte + phizz(k) = .001*z(k) + aerext(k) = 0. +! if(i.eq.its.and.j.eq.jts)print *,phizz(k),aerstd(k),kts,kte +! print *,phizz(k),kts,kte,ite,jte + END DO + +! IF (phizz(kte-1)>20.) THEN +! CALL wrf_error_fatal ( 'phizz(kte-1)>20., set kl0 to 1') +! END IF + + CALL trapez(zstd,aerstd,1,51,phizz,aerext,kts,kte,51,51,kte,kte) + + DO k = kts, kte + aerwrf(i,k,j) = aerext(k) +! if(i.eq.its)print *,k,i,j,aerext(k),phizz(k) +! print *,k,i,j,aerext(k),phizz(k) + END DO + +10 CONTINUE + END DO + +20 CONTINUE + END DO + + END SUBROUTINE photmad_init + + END MODULE module_phot_mad diff --git a/wrfv2_fire/chem/module_racm.F b/wrfv2_fire/chem/module_racm.F new file mode 100644 index 00000000..2d8addbb --- /dev/null +++ b/wrfv2_fire/chem/module_racm.F @@ -0,0 +1,109 @@ + MODULE module_racm + USE module_data_racm + USE module_data_sorgam + + CONTAINS + + subroutine racm_driver(id,ktau,dtstep,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + USE module_configure + USE module_state_description + USE module_model_constants + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, INTENT(IN ) :: & + dtstep,gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! advected chemical tracers +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! +! arrays that hold photolysis rates +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob +! +! arrays that hold the radicals +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + addt,addx,addc,etep,oltp,olip,cslp,limp,hc5p,hc8p,tolp, & + xylp,apip,isop,hc3p,ethp,o3p,tco3,mo2,o1d,olnn,rpho,xo2,& + ketp,olnd +! +! on input from met model +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy +! +! for interaction with aerosols (really is output) +! + real , INTENT(INOUT) :: & + vdrog3(ims:ime,kms:kme-0,jms:jme,ldrog) + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + +! .. +! .. Local Scalars .. + REAL :: clwchem, dt60, dtcmax, dtcmin, xtime + INTEGER :: i,j,k,iprt, jce, jcs, n, nr, ipr,jpr,nvr +! .. +! .. Local Arrays .. + REAL :: p(kts:kte-1), rh(kts:kte-1), & + t(kts:kte-1), vcinp(nspec),wlc(kts:kte-1),p1,wvap + REAL*8 :: t_in,t_end, rj(nphot) + real :: PRDROG(ldrog) + REAL*8 :: ATOL,rtol,temp +! real *8 :: saverad(its:ite,kts:kte,jts:jte,50) + real *8 :: rxylho,rtolho,rcslho,rcslno3,rhc8ho,roliho,rolino3, & + rolio3,roltho,roltno3,rolto3,rapiho,rapino3,rapio3, & + rlimho,rlimno3,rlimo3 +! EXTERNAL arr +! REAL*8 :: arr + +! + + INTEGER :: ixhour,iaerosol_sorgam + real :: xhour,xmin,xtimin + real :: const2,tinv,pot,pt2 + END SUBROUTINE racm_driver + + + + + END MODULE module_racm diff --git a/wrfv2_fire/chem/module_radm.F b/wrfv2_fire/chem/module_radm.F new file mode 100755 index 00000000..6505dde7 --- /dev/null +++ b/wrfv2_fire/chem/module_radm.F @@ -0,0 +1,1708 @@ + MODULE module_radm + USE module_data_radm2 + USE module_data_sorgam + integer numchem + parameter (numchem=numchem_radm) +! .. + CONTAINS + subroutine radm_driver(id,ktau,dtstep,config_flags, & + gmt,julday,t_phy,moist,p8w,t8w, & + p_phy,chem,rho_phy,dz8w,z,z_at_w,vdrog3, & + ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + USE module_model_constants + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, INTENT(IN ) :: & + dtstep,gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! advected chemical tracers +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! +! arrays that hold photolysis rates +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob +! +! on input from met model +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + z , & + t8w,p8w,z_at_w , & + rho_phy +! +! for interaction with aerosols (really is output) +! + real , INTENT(INOUT) :: & + vdrog3(ims:ime,kms:kme-0,jms:jme,ldrog) + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + +! .. +! .. Local Scalars .. + REAL :: clwchem, dt60, dtcmax, dtcmin, xtime + INTEGER :: i,j,k,iprt, jce, jcs, n, nr, ipr,jpr,nvr +! .. +! .. Local Arrays .. + REAL :: p(kts:kte-1), rh(kts:kte-1), rj(kts:kte-1,nreacj), & + t(kts:kte-1), vcinp(kts:kte-1,numchem),wlc(kts:kte-1) + real :: vdrog1(kts:kte-1,ldrog) + +! + + INTEGER :: ixhour,iaerosol_sorgam + real :: xhour,xmin,xtimin + xtime=ktau*dtstep/60. + ixhour=ifix(gmt+.01)+ifix(xtime/60.) + xhour=float(ixhour) + xmin=60.*gmt+(xtime-xhour*60.) + ipr=-10 + jpr=-10 + nvr=5 +! +! following is for combination radm/sorgam only, p_nu0 must be defined +! in that case +! + iaerosol_sorgam=0 + if(p_nu0.gt.1)iaerosol_sorgam=1 + +! + chem=max(chem,epsilc) + do 100 j=jts,jte + do 100 i=its,ite + vcinp=epsilc + vdrog1=0. + iprt=0 +! if(xtime/60.ge.2.)then +! if((i.eq.12.and.j.eq.17).or. & +! (i.eq.12.and.j.eq.7).or. & +! (i.eq.1.and.j.eq.17))iprt=2 +! endif + +! reorder +! +! if(iprt.eq.2)print *,'k,chem(i,k,j,p_sulf),vcinp(k,lsulf)' + do k=kts,kte-1 + vcinp(k,lso2) = max(chem(i,k,j,p_so2),epsilc) + vcinp(k,Lsulf) = max(chem(i,k,j,p_sulf),epsilc) + vcinp(k,Lno2) = max(chem(i,k,j,p_no2),epsilc) + vcinp(k,Lno) = max(chem(i,k,j,p_no),1.e-6) +! vcinp(k,Lno) = max(chem(i,k,j,p_no),epsilc) + vcinp(k,Lo3) = max(chem(i,k,j,p_o3),epsilc) + vcinp(k,Lhno3) = max(chem(i,k,j,p_hno3),epsilc) + vcinp(k,Lh2o2) = max(chem(i,k,j,p_h2o2),epsilc) + vcinp(k,Lald) = max(chem(i,k,j,p_ald),epsilc) + vcinp(k,Lhcho) = max(chem(i,k,j,p_hcho),epsilc) + vcinp(k,Lop1) = max(chem(i,k,j,p_op1),epsilc) + vcinp(k,Lop2) = max(chem(i,k,j,p_op2),epsilc) + vcinp(k,Lpaa) = max(chem(i,k,j,p_paa),epsilc) + vcinp(k,Lora1) = max(chem(i,k,j,p_ora1),epsilc) + vcinp(k,Lora2) = max(chem(i,k,j,p_ora2),epsilc) + vcinp(k,Lnh3) = max(chem(i,k,j,p_nh3),epsilc) + vcinp(k,Ln2o5) = max(chem(i,k,j,p_n2o5),epsilc) + vcinp(k,Lno3) = max(chem(i,k,j,p_no3),epsilc) + vcinp(k,Lpan) = max(chem(i,k,j,p_pan),epsilc) + vcinp(k,Lhc3) = max(chem(i,k,j,p_hc3),epsilc) + vcinp(k,Lhc5) = max(chem(i,k,j,p_hc5),epsilc) + vcinp(k,Lhc8) = max(chem(i,k,j,p_hc8),epsilc) + vcinp(k,Leth) = max(chem(i,k,j,p_eth),epsilc) + vcinp(k,Lco) = max(chem(i,k,j,p_co),epsilc) + vcinp(k,Lol2) = max(chem(i,k,j,p_ol2),epsilc) + vcinp(k,Lolt) = max(chem(i,k,j,p_olt),epsilc) + vcinp(k,Loli) = max(chem(i,k,j,p_oli),epsilc) + vcinp(k,Ltol) = max(chem(i,k,j,p_tol),epsilc) + vcinp(k,Lxyl) = max(chem(i,k,j,p_xyl),epsilc) + vcinp(k,Laco3) = max(chem(i,k,j,p_aco3),epsilc) + vcinp(k,Ltpan) = max(chem(i,k,j,p_tpan),epsilc) + vcinp(k,Lhono) = max(chem(i,k,j,p_hono),epsilc) + vcinp(k,Lhno4) = max(chem(i,k,j,p_hno4),epsilc) + vcinp(k,Lket) = max(chem(i,k,j,p_ket),epsilc) + vcinp(k,Lgly) = max(chem(i,k,j,p_gly),epsilc) + vcinp(k,Lmgly) = max(chem(i,k,j,p_mgly),epsilc) + vcinp(k,Ldcb) = max(chem(i,k,j,p_dcb),epsilc) + vcinp(k,Lonit) = max(chem(i,k,j,p_onit),epsilc) + vcinp(k,Lcsl) = max(chem(i,k,j,p_csl),epsilc) + vcinp(k,Lxyl) = max(chem(i,k,j,p_xyl),epsilc) + vcinp(k,Liso) = max(chem(i,k,j,p_iso),epsilc) + vcinp(k,Lho) = max(chem(i,k,j,p_ho),epsilc) + vcinp(k,Lho2) = max(chem(i,k,j,p_ho2),epsilc) +! if(iprt.eq.2)then +! print *,k,chem(i,k,j,p_sulf),vcinp(k,lsulf) +! endif + enddo +!--- now do chemistry, need some input here + + do k=kts,kte-1 + t(k) = t_phy(i,k,j) + p(k) = .001*p_phy(i,k,j) + rh(k) = .95 + rh(k) = MIN( .95, moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rh(k)=max(.1,rh(k)) +! wlc(k) = moist(i,k,j,p_qc) + wlc(k) = 0. + END DO + dt60 = dtstep/60. + xtimin = max(0.,xtime-dt60) + dtcmin = min(.05,xtime-xtimin) + dtcmax = min(5.,dt60) + dtcmax = min(dtcmax,xtime-xtimin) +! +! radm here is called with a vertical stack +! + jcs = kts + jce = kte-1 + + +! +! fill photolysis rates for use in radm module +! + do k=kts,kte-1 + rj(k,1) = ph_no2(i,k,j) + rj(k,2) = ph_o31d(i,k,j) + rj(k,3) = ph_o33p(i,k,j) + rj(k,4) = ph_hno2(i,k,j) + rj(k,5) = ph_hno3(i,k,j) + rj(k,6) = ph_hno4(i,k,j) + rj(k,7) = ph_no3o2(i,k,j) + rj(k,8) = ph_no3o(i,k,j) + rj(k,9) = ph_h2o2(i,k,j) + rj(k,10) = ph_ch2om(i,k,j) + rj(k,11) = ph_ch2or(i,k,j) + rj(k,12) = ph_ch3cho(i,k,j) + rj(k,13) = ph_ch3o2h(i,k,j) + rj(k,14) = ph_ch3coch3(i,k,j) + rj(k,15) = ph_ch3coo2h(i,k,j) + rj(k,16) = ph_ch3coc2h5(i,k,j) + rj(k,17) = ph_hcocho(i,k,j) + rj(k,18) = ph_hcochob(i,k,j) + rj(k,19) = ph_ch3cocho(i,k,j) + rj(k,20) = ph_hcochest(i,k,j) + rj(k,21) = ph_ch3ono2(i,k,j) + END DO +! print *,'before radm, i,j = ',i,j +! iprt=0 +! if((i.eq.87.and.j.eq.15).or.(i.eq.87.and.j.eq.4))then +! iprt=1 +! endif + CALL radm(rj,wlc,vcinp,t,p,rh,xtime,xtimin,kts,kte-1, & + iprt,dt60,dtcmax,dtcmin,vdrog1,iaerosol_sorgam) +! print *,'after radm, i,j = ',i,j + do k=kts,kte-1 + chem(i,k,j,p_so2) = max(vcinp(k,lso2),epsilc) + chem(i,k,j,p_sulf) = max(vcinp(k,Lsulf),epsilc) + chem(i,k,j,p_no2) = max(vcinp(k,Lno2),epsilc) + chem(i,k,j,p_no) = max(vcinp(k,Lno),1.e-6) + chem(i,k,j,p_o3) = max(vcinp(k,Lo3),epsilc) + chem(i,k,j,p_hno3) = max(vcinp(k,Lhno3),epsilc) + chem(i,k,j,p_h2o2) = max(vcinp(k,Lh2o2),epsilc) + chem(i,k,j,p_ald) = max(vcinp(k,Lald),epsilc) + chem(i,k,j,p_hcho) = max(vcinp(k,Lhcho),epsilc) + chem(i,k,j,p_op1) = max(vcinp(k,Lop1),epsilc) + chem(i,k,j,p_op2) = max(vcinp(k,Lop2),epsilc) + chem(i,k,j,p_paa) = max(vcinp(k,Lpaa),epsilc) + chem(i,k,j,p_ora1) = max(vcinp(k,Lora1),epsilc) + chem(i,k,j,p_ora2) = max(vcinp(k,Lora2),epsilc) + chem(i,k,j,p_nh3) = max(vcinp(k,Lnh3),epsilc) + chem(i,k,j,p_n2o5) = max(vcinp(k,Ln2o5),epsilc) + chem(i,k,j,p_no3) = max(vcinp(k,Lno3),epsilc) + chem(i,k,j,p_pan) = max(vcinp(k,Lpan),epsilc) + chem(i,k,j,p_hc3) = max(vcinp(k,Lhc3),epsilc) + chem(i,k,j,p_hc5) = max(vcinp(k,Lhc5),epsilc) + chem(i,k,j,p_hc8) = max(vcinp(k,Lhc8),epsilc) + chem(i,k,j,p_eth) = max(vcinp(k,Leth),epsilc) + chem(i,k,j,p_co) = max(vcinp(k,Lco),epsilc) + chem(i,k,j,p_ol2) = max(vcinp(k,Lol2),epsilc) + chem(i,k,j,p_olt) = max(vcinp(k,Lolt),epsilc) + chem(i,k,j,p_oli) = max(vcinp(k,Loli),epsilc) + chem(i,k,j,p_tol) = max(vcinp(k,Ltol),epsilc) + chem(i,k,j,p_xyl) = max(vcinp(k,Lxyl),epsilc) + chem(i,k,j,p_aco3) = max(vcinp(k,Laco3),epsilc) + chem(i,k,j,p_tpan) = max(vcinp(k,Ltpan),epsilc) + chem(i,k,j,p_hono) = max(vcinp(k,Lhono),epsilc) + chem(i,k,j,p_hno4) = max(vcinp(k,Lhno4),epsilc) + chem(i,k,j,p_ket) = max(vcinp(k,Lket),epsilc) + chem(i,k,j,p_gly) = max(vcinp(k,Lgly),epsilc) + chem(i,k,j,p_mgly) = max(vcinp(k,Lmgly),epsilc) + chem(i,k,j,p_dcb) = max(vcinp(k,Ldcb),epsilc) + chem(i,k,j,p_onit) = max(vcinp(k,Lonit),epsilc) + chem(i,k,j,p_csl) = max(vcinp(k,Lcsl),epsilc) + chem(i,k,j,p_iso) = max(vcinp(k,Liso),epsilc) + chem(i,k,j,p_ho) = max(vcinp(k,Lho),epsilc) + chem(i,k,j,p_ho2) = max(vcinp(k,Lho2),epsilc) + if(p_nu0.gt.1)then + VDROG3(i,k,j,PXYL ) = VDROG1(k,PXYL ) + VDROG3(i,k,j,PTOL ) = VDROG1(k,PTOL ) + VDROG3(i,k,j,PCSL1) = VDROG1(k,PCSL1) + VDROG3(i,k,j,PCSL2) = VDROG1(k,PCSL2) + VDROG3(i,k,j,PHC8 ) = VDROG1(k,PHC8 ) + VDROG3(i,k,j,POLI1) = VDROG1(k,POLI1) + VDROG3(i,k,j,POLI2) = VDROG1(k,POLI2) + VDROG3(i,k,j,POLI3) = VDROG1(k,POLI3) + VDROG3(i,k,j,POLT1) = VDROG1(k,POLT1) + VDROG3(i,k,j,POLT2) = VDROG1(k,POLT2) + VDROG3(i,k,j,POLT3) = VDROG1(k,POLT3) + endif + END DO +! if(iprt.eq.2)then +! print *,'after radm, k,chem(i,k,j,p_sulf),vcinp(k,lsulf)' +! do k=kts,kte +! print *,k,chem(i,k,j,p_sulf),vcinp(k,lsulf) +! enddo +! endif +100 continue + + +END SUBROUTINE radm_driver + + + SUBROUTINE radm(rjj,wlcc,vcinp,tinp,pinp,rhinp,tstart,timemx, & + jcs,jce,iprt,dt60,dtcmax,dtcmin,vdrog,iaerosol_sorgam) + implicit none +! .. Parameters .. + REAL, PARAMETER :: c302 = 5417.4, c303 = 19.83 +! .. +! .. Scalar Arguments .. + REAL,INTENT(IN) :: dt60, dtcmax, dtcmin, timemx, tstart + INTEGER, INTENT(IN) :: iprt, jce, jcs +! +! + + + integer, intent (in) :: iaerosol_sorgam + REAL,INTENT(IN) :: rjj(jcs:jce,nreacj), & + wlcc(jcs:jce), tinp(jcs:jce),pinp(jcs:jce),rhinp(jcs:jce) +! .. + real,intent (INOUT) :: vdrog(jcs:jce,ldrog),vcinp(jcs:jce,lspec) +! .. +! .. Local Scalars .. + REAL :: dtc, r, timenow, tsqrd, xk0, xk2, xk3 + INTEGER :: i, ir, irdum, j, k, kdum, l, nr +! .. +! .. Local Arrays .. + REAL :: prdrog(jcs:jce,ldrog) + REAL :: aquad(jcs:jce), bquad(jcs:jce), & + crj(jcs:jce,nreacj), crk(jcs:jce,nreack), & + dum(jcs:jce), dvc(jcs:jce,ldiag), dvca(jcs:jce,ldiag), & + dvcg(jcs:jce,ldiag), h2o(jcs:jce,1), & + loss(jcs:jce,lpred), lossl(jcs:jce,lump), & + p(jcs:jce,1), patmot1(jcs:jce), & + patmot2(jcs:jce), patmot3(jcs:jce), & + pot(jcs:jce), prod(jcs:jce,lpred), & + prodl(jcs:jce,lump), rh(jcs:jce), & + rj(jcs:jce,nreacj), rk(jcs:jce,nreack), & + t(jcs:jce,1), tin(jcs:jce), to300(jcs:jce), & + vc(jcs:jce,1,lspec), vca(jcs:jce,1,lspec), & + vcg(jcs:jce,1,lspec), vcl(jcs:jce,lump), wlc(jcs:jce) +! .. +! .. Intrinsic Functions .. + INTRINSIC amax1, amin1, exp, log10 +! .. + IF (iprt==1) PRINT *, 'in radm ', jcs, jce, vcinp(jcs:jce,3), & + vcinp(jcs:jce,lho2) + IF (iprt==1) PRINT *, 'in radm ', lspec, lho2 + IF (iprt==2) PRINT *, 'in radm ', lsulf,vcinp(jcs:jcs+5,lsulf) + r = 0.0820578 + do nr=1,ldrog + do j=jcs,jce + VDROG(j,nr)=0. + enddo + enddo + DO nr = 1, nreacj + DO j = jcs, jce + rj(j,nr) = rjj(j,nr) + END DO + END DO + DO j = jcs, jce + wlc(j) = wlcc(j) + t(j,1) = tinp(j) + p(j,1) = pinp(j) + rh(j) = rhinp(j) + END DO + DO l = 1, lspec + DO j = jcs, jce + vca(j,1,l) = epsilc + vcg(j,1,l) = amax1(epsilc,vcinp(j,l)) + vc(j,1,l) = amax1(epsilc,vcinp(j,l)) + END DO + END DO + IF (iprt==1) PRINT *, ' radm', lho2, vc(jcs:jce,1,3), vc(jcs:jce,1,7), & + vc(jcs:jce,1,lho2) + DO l = 1, lpred + DO j = jcs, jce + prod(j,l) = 0. + loss(j,l) = epsilc + END DO + END DO + DO l = 1, nreacj + DO j = jcs, jce + crj(j,l) = 0. + END DO + END DO + DO l = 1, ldiag + DO j = jcs, jce + dvca(j,l) = epsilc + dvcg(j,l) = epsilc + dvc(j,l) = epsilc + END DO + END DO + DO l = 1, nreack + DO j = jcs, jce + rk(j,l) = 0. + crk(j,l) = epsilc + END DO + END DO + DO l = 1, lump + DO j = jcs, jce + vcl(j,l) = 1.e-9 + lossl(j,l) = epsilc + prodl(j,l) = 0. + END DO + END DO + + dtc = dtcmin + + DO j = jcs, jce + h2o(j,1) = .611E6*rh(j)*exp(c303-c302/t(j,1))/p(j,1) + END DO + + k = 1 + i = 1 + kdum = k + DO j = jcs, jce + tin(j) = 1./t(j,1) !RADM2.0 I --> IMRCHEM +!RADM2.0 I --> IMRCHEM + pot(j) = p(j,1)*tin(j)/101.3 +!RADM2.0 I --> IMRCHEM + to300(j) = t(j,1)/300. + patmot1(j) = const(1)*pot(j) + patmot2(j) = const(2)*pot(j) + patmot3(j) = const(3)*pot(j)*pot(j) + END DO + DO ir = 1, nreack + DO j = jcs, jce + rk(j,ir) = thafac(ir)*exp(-eor(ir)*tin(j))*patmot2(j) + END DO + END DO + DO j = jcs, jce +!3RD ORDER + rk(j,16) = rk(j,16)*patmot3(j)/patmot2(j)*1.E-20 +!1ST ORDER + rk(j,54) = rk(j,54)/patmot2(j)*60. +!1ST ORDER + rk(j,56) = rk(j,56)/patmot2(j)*60. + END DO + DO ir = 1, ntroe + irdum = itroe(ir) + DO j = jcs, jce + aquad(j) = xk0300(ir)*to300(j)**(-xntroe(ir)) + aquad(j) = aquad(j)*patmot1(j) + bquad(j) = xkf300(ir)*to300(j)**(-xmtroe(ir)) + bquad(j) = aquad(j)/bquad(j) + END DO + DO j = jcs, jce + rk(j,irdum) = aquad(j)/(1.+bquad(j))*0.6**(1./(1.+(log10(bquad(j)) & + )**2)) + END DO + IF (ir>2) THEN + DO j = jcs, jce + rk(j,irdum) = rk(j,irdum)*patmot2(j) + END DO + ELSE + DO j = jcs, jce +!changed RADM2.0 IMRCHEM + rk(j,irdum) = rk(j,irdum)/(afac(ir)*exp(bfac(ir)/t(j,1)))*60. + END DO + END IF +!END DO 90 LOOP + END DO + DO j = jcs, jce + tsqrd = t(j,1)*t(j,1) !was Imrchem 3d I --> IMRCHEM + rk(j,30) = rk(j,30)*tsqrd + rk(j,31) = rk(j,31)*tsqrd + rk(j,50) = rk(j,50)*tsqrd + END DO + DO j = jcs, jce + rk(j,1) = patmot1(j)*6.E-34*to300(j)**(-2.3)*patmot2(j) + rk(j,12) = (2.2E-13*exp(620.*tin(j))+1.9E-33*patmot1(j)*exp(980.*tin & + (j)))*patmot2(j) +! IF (iprt==1 .AND. j==jce) THEN +! PRINT *, j, tin(j), patmot1(j), patmot2(j), & +! 1.9E-33*patmot1(j)*exp(980.*tin(j)) +! PRINT *, rk(j,12), 2.2E-13*exp(620.*tin(j)), const(3), p(j,1) +! END IF + xk0 = 7.2E-15*exp(785.*tin(j)) + xk2 = 4.1E-16*exp(1440.*tin(j)) + xk3 = 1.9E-33*exp(725.*tin(j))*patmot1(j) + rk(j,25) = (xk0+xk3/(1.+xk3/xk2))*patmot2(j) + rk(j,29) = (1.5E-13*(1.+2.439E-20*patmot1(j)))*patmot2(j) + rk(j,13) = (3.08E-34*exp(2820.*tin(j))+2.66E-34*patmot1(j)*1.E-20* & + exp(3180.*tin(j)))*patmot3(j) + END DO + DO j = jcs, jce + dum(j) = amin1(rh(j),1.) + dum(j) = amax1(dum(j),0.) +! RK(J,137) = 1./(600.*EXP(-(DUM(J)/.28)**2.8)+5.) +! RK(J,137)= CVMGP(0.2,0.0,DUM(J) - .70) ! HETEROGENOUS N2O5 + rk(j,23) = 0.0 +! HOMOGENEOUS N2O5 + IF (dum(j)-.7>=0.) THEN + rk(j,137) = 0.2 + ELSE + rk(j,137) = 0. + END IF + END DO +!** + DO j = jcs, jce + vcl(j,lnox) = vc(j,1,lno) + vc(j,1,lno2) + vcl(j,lhox) = max(1.e-9,vc(j,1,lho) + vc(j,1,lho2)) + vcl(j,lpao3) = vc(j,1,lpan) + vc(j,1,laco3) + vcl(j,ln2n3) = vc(j,1,lno3) + vc(j,1,ln2o5) + END DO +!********************************************************************** +! C H E M I C A L S O L V E R +!********************************************************************** + timenow = 0. +10 CONTINUE + +! Chemical solver + CALL predraten(jcs,jce,iprt,crj,crk,rj,rk,vc,dvc,vca, & + wlc,dvca,p,h2o,dvcg,t,r) + + CALL producn(jcs,jce,iprt,crj,crk,loss,prod,prodl,lossl, & + prdrog,iaerosol_sorgam) + + CALL setdtc(jcs,jce,dtc,dtcmax,dtcmin,dt60,prod,loss,vc,timenow) + + CALL integ1n(jcs,jce,iprt,dtc,vc,loss,prod,vcl,lossl,prodl, & + rk,dvc,h2o,rj,vdrog,prdrog,iaerosol_sorgam) + + timenow = timenow + dtc + IF (iprt==2) PRINT *, 'end radm', timenow,vc(jcs:jce,1,lsulf) + IF ((timenow+0.001) TAKE THE COMMENTED STUFF +!........ UNCOMMENTED IS: NTOTAL=NOX+HNO3+NO3+2*N2O5+HONO+HNO4 +!-------> DON'T FORGET TO CHANGE INTEG AND CHEM + + +! LOSSL(J,LNTOTAL)= CRK(J,80)+CRK(J,81)+ +! 1 CRK(J,82)+CRK(J,83) + +! LOSSL(J,LNTOTAL)= CRK(J,53)+CRK(J,55)+ +! 1 CRK(J,132)+ +! 1 CRK(J,80)+CRK(J,81)+ +! 1 CRK(J,82)+CRK(J,83) +! PRODL(J,LNTOTAL)= +! 1 CRK(J,20)+ +! 1 CRK(J,50)+CRK(J,54)+CRK(J,56)+CRK(J,73)+ +! 1 CRK(J,51) + +! PRODL(J,LNTOTAL)= CRK(J,101) + CRK(J,73) + + DO j = jcs, jce + prodl(j,ln2n3) = crk(j,17) + crk(j,25) + crk(j,50) + END DO + + DO j = jcs, jce + lossl(j,ln2n3) = crk(j,23) + crj(j,7) + crj(j,8) + crk(j,18) + & + crk(j,19) + crk(j,20) + crk(j,74) + crk(j,75) + crk(j,76) + & + crk(j,77) + crk(j,78) + crk(j,79) + crk(j,80) + crk(j,81) + & + crk(j,82) + crk(j,83) + crk(j,137) + END DO + + DO j = jcs, jce + loss(j,lpan) = crk(j,50) + crk(j,54) + END DO + + DO j = jcs, jce + prod(j,lpan) = crk(j,53) + END DO + + DO j = jcs, jce + loss(j,lhno3) = crj(j,5) + crk(j,25) + END DO + + DO j = jcs, jce + prod(j,lhno3) = crk(j,20) + 2.D0*crk(j,23) + crk(j,24) + crk(j,74) + & + crk(j,75) + crk(j,76) + crk(j,77) + crk(j,78) + crk(j,79) + & + 2.*crk(j,137) + END DO + + DO j = jcs, jce + loss(j,lh2o2) = max(alow,crj(j,9) + crk(j,14) ) +! if(iprt.eq.1.and.j.eq.jce)then +! print *,LH2O2,LOSS(J,LH2O2),CRJ(J, 9),CRK(J, 14) +! endif + END DO + + DO j = jcs, jce + prod(j,lh2o2) = crk(j,12) + crk(j,13) +! if(iprt.eq.1.and.j.eq.jce)then +! print *,LH2O2,prod(J,LH2O2),CRK(J, 12),CRK(J, 13) +! endif + END DO + + DO j = jcs, jce + loss(j,lhcho) = crj(j,10) + crj(j,11) + crk(j,41) + crk(j,74) + END DO + + DO j = jcs, jce + prod(j,lhcho) = crj(j,13) + .13*crj(j,17) + .45*crj(j,18) + & + .009*crk(j,32) + .5*crk(j,47) + crk(j,50) + crk(j,57) + & + .09*crk(j,58) + .04*crk(j,62) + 1.6*crk(j,64) + crk(j,65) + & + .28*crk(j,66) + crk(j,73) + crk(j,84) + .53*crk(j,85) + & + .18*crk(j,86) + .53*crk(j,87) + 1.5*crk(j,102) + .75*crk(j,103) + & + .75*crk(j,104) + .77*crk(j,105) + .80*crk(j,106) + & + 1.55*crk(j,107) + 1.25*crk(j,108) + .89*crk(j,109) + & + .75*crk(j,110) + crk(j,111) + crk(j,112) + crk(j,113) + & + .5*crk(j,114) + .8*crk(j,119) + .5*crk(j,120) + .14*crk(j,121) + & + crk(j,128) + crk(j,134) + 1.75*crk(j,138) + crk(j,139) + & + 2.0*crk(j,140) + END DO + + DO j = jcs, jce + prod(j,lhono) = crk(j,15) + END DO + + DO j = jcs, jce + loss(j,lhono) = crj(j,4) + END DO + + DO j = jcs, jce + prod(j,lhno4) = crk(j,10) + END DO + + DO j = jcs, jce + loss(j,lhno4) = crj(j,6) + crk(j,11) + crk(j,26) + END DO + + DO j = jcs, jce + prod(j,ln2o5) = crk(j,21) + END DO + + DO j = jcs, jce + loss(j,ln2o5) = crk(j,22) + crk(j,23) + crk(j,137) + END DO + + DO j = jcs, jce + prod(j,lno3) = crk(j,17) + crk(j,22) + crk(j,25) + crk(j,50) + END DO + + DO j = jcs, jce + loss(j,lno3) = crj(j,7) + crj(j,8) + crk(j,18) + crk(j,19) + & + crk(j,20) + crk(j,21) + crk(j,74) + crk(j,75) + crk(j,76) + & + crk(j,77) + crk(j,78) + crk(j,79) + crk(j,80) + crk(j,81) + & + crk(j,82) + crk(j,83) + END DO + + DO j = jcs, jce + loss(j,lco) = crk(j,29) + END DO + + DO j = jcs, jce + prod(j,lco) = crj(j,10) + crj(j,11) + crj(j,12) + 1.87*crj(j,17) + & + 1.55*crj(j,18) + crj(j,19) + crk(j,41) + 2.*crk(j,44) + & + crk(j,45) + .95*crk(j,68) + crk(j,74) + 2.*crk(j,76) + crk(j,77) + & + .42*crk(j,84) + .33*crk(j,85) + .23*crk(j,86) + .33*crk(j,87) + & + .475*crk(j,114) + .95*crk(j,126) + END DO + + DO j = jcs, jce + loss(j,lald) = crj(j,12) + crk(j,42) + crk(j,75) + END DO + + DO j = jcs, jce + prod(j,lald) = crj(j,14) + .075*crk(j,32) + .2*crj(j,21) + & + .5*crk(j,48) + .75*crk(j,58) + .38*crk(j,60) + .35*crk(j,62) + & + .2*crk(j,64) + crk(j,65) + 1.45*crk(j,66) + crk(j,73) + & + crk(j,71) + .5*crk(j,85) + .72*crk(j,86) + .5*crk(j,87) + & + .75*crk(j,103) + .15*crk(j,104) + .41*crk(j,105) + & + .46*crk(j,106) + .35*crk(j,107) + .75*crk(j,108) + & + .725*crk(j,109) + crk(j,115) + .2*crk(j,116) + .14*crk(j,117) + & + .1*crk(j,118) + .6*crk(j,119) + crk(j,120) + .725*crk(j,121) + & + crk(j,138) + crk(j,139) + 2.0*crk(j,140) + END DO + + DO j = jcs, jce + loss(j,lop1) = crj(j,13) + crk(j,47) + END DO + + DO j = jcs, jce + prod(j,lop1) = crk(j,88) + END DO + + DO j = jcs, jce + loss(j,lop2) = crj(j,14) + crk(j,48) + END DO + + DO j = jcs, jce + prod(j,lop2) = crk(j,89) + crk(j,90) + crk(j,91) + crk(j,92) + & + crk(j,93) + crk(j,94) + crk(j,95) + crk(j,96) + crk(j,98) + & + crk(j,99) + crk(j,100) + crk(j,127) + crk(j,133) + END DO + + DO j = jcs, jce + loss(j,lpaa) = crj(j,15) + crk(j,49) + END DO + + DO j = jcs, jce + prod(j,lpaa) = crk(j,97) + END DO + + DO j = jcs, jce + loss(j,lket) = crj(j,16) + crk(j,43) + END DO + + DO j = jcs, jce + prod(j,lket) = .8*crj(j,21) + .025*crk(j,32) + .25*crk(j,58) + & + .69*crk(j,60) + 1.06*crk(j,62) + .10*crk(j,66) + .10*crk(j,86) + & + .6*crk(j,104) + .75*crk(j,105) + 1.39*crk(j,106) + & + .55*crk(j,109) + .8*crk(j,116) + .86*crk(j,117) + .9*crk(j,118) + & + .55*crk(j,121) + END DO + + DO j = jcs, jce + loss(j,lgly) = crj(j,17) + crj(j,18) + crk(j,44) + crk(j,76) + END DO + + DO j = jcs, jce + prod(j,lgly) = .89*crk(j,68) + .16*crk(j,69) + .16*crk(j,112) + & + .44*crk(j,114) + .2*crk(j,124) + .89*crk(j,126) + END DO + + DO j = jcs, jce + loss(j,lmgly) = crj(j,19) + crk(j,45) + crk(j,77) + END DO + + DO j = jcs, jce + prod(j,lmgly) = .11*crk(j,68) + .17*crk(j,69) + .450*crk(j,70) + & + crk(j,72) + .75*crk(j,110) + .17*crk(j,112) + .45*crk(j,113) + & + .05*crk(j,114) + crk(j,122) + .8*crk(j,124) + crk(j,125) + & + .11*crk(j,126) + END DO + + DO j = jcs, jce + loss(j,ldcb) = crj(j,20) + crk(j,46) + crk(j,78) + END DO + + DO j = jcs, jce + loss(j,ldcb) = max(alow,loss(j,ldcb)) + END DO + + DO j = jcs, jce + prod(j,ldcb) = .70*crk(j,69) + .806*crk(j,70) + .7*crk(j,112) + & + .806*crk(j,113) + crk(j,124) + crk(j,125) + END DO + + DO j = jcs, jce + loss(j,lonit) = crj(j,21) + crk(j,51) + END DO + + DO j = jcs, jce + prod(j,lonit) = .036*crk(j,58) + .08*crk(j,60) + .24*crk(j,62) + & + crk(j,101) + crk(j,132) + END DO + + DO j = jcs, jce + loss(j,lso2) = crk(j,28) + END DO + + DO j = jcs, jce + loss(j,lsulf) = 0. + END DO + + DO j = jcs, jce + prod(j,lsulf) = crk(j,28) +! if(iprt==2)print *,' j,prod = ',j,prod(j,lsulf) + END DO + + DO j = jcs, jce + loss(j,leth) = crk(j,31) + END DO + + DO j = jcs, jce + loss(j,lhc3) = crk(j,32) + END DO + + DO j = jcs, jce + loss(j,lhc5) = crk(j,33) + END DO + + DO j = jcs, jce + loss(j,lhc8) = crk(j,34) + END DO + + DO j = jcs, jce + loss(j,lol2) = crk(j,35) + crk(j,80) + crk(j,84) + END DO + + DO j = jcs, jce + loss(j,lolt) = crk(j,36) + crk(j,81) + crk(j,85) + END DO + + DO j = jcs, jce + loss(j,loli) = crk(j,37) + crk(j,82) + crk(j,86) + END DO + + DO j = jcs, jce + loss(j,ltol) = crk(j,38) + END DO + + DO j = jcs, jce + loss(j,lcsl) = crk(j,40) + .5*crk(j,79) + END DO + + DO j = jcs, jce + prod(j,lcsl) = .25*crk(j,38) + .17*crk(j,39) + END DO + + DO j = jcs, jce + loss(j,lxyl) = crk(j,39) + END DO + + DO j = jcs, jce + loss(j,laco3) = crk(j,53) + crk(j,67) + crk(j,97) + crk(j,111) + & + crk(j,115) + crk(j,116) + crk(j,117) + crk(j,118) + crk(j,119) + & + crk(j,120) + crk(j,121) + crk(j,122) + 2.*crk(j,123) + & + crk(j,124) + crk(j,125) + .95*crk(j,126) + crk(j,129) + & + crk(j,135) + crk(j,139) + END DO + + DO j = jcs, jce + prod(j,laco3) = crj(j,16) + crj(j,19) + .02*crj(j,20) + crk(j,42) + & + crk(j,45) + crk(j,49) + crk(j,54) + .05*crk(j,68) + crk(j,75) + & + crk(j,77) + .03*crk(j,114) + END DO + + DO j = jcs, jce + loss(j,liso) = crk(j,52) + crk(j,83) + crk(j,87) + END DO + + DO j = jcs, jce + loss(j,ltpan) = crk(j,56) + END DO + + DO j = jcs, jce + prod(j,ltpan) = crk(j,55) + END DO + + DO j = jcs, jce + loss(j,lora1) = 1.E-27 + END DO + + DO j = jcs, jce + prod(j,lora1) = .4*crk(j,84) + .06*crk(j,86) + .2*crk(j,85) + & + .2*crk(j,87) + END DO + + DO j = jcs, jce + loss(j,lora2) = 1.E-27 + END DO + + DO j = jcs, jce + prod(j,lora2) = .2*crk(j,85) + .29*crk(j,86) + .2*crk(j,87) + & + .5*crk(j,111) + .5*crk(j,114) + .5*crk(j,115) + .5*crk(j,116) + & + .5*crk(j,117) + .5*crk(j,118) + .5*crk(j,119) + .5*crk(j,120) + & + .5*crk(j,121) + .5*crk(j,122) + .5*crk(j,139) + END DO + + DO j = jcs, jce + lossl(j,lhox) = crk(j,15) + crk(j,24) + crk(j,25) + crk(j,26) + & + crk(j,27) + crk(j,30) + crk(j,31) + .83*crk(j,32) + crk(j,33) + & + crk(j,34) + crk(j,35) + crk(j,36) + crk(j,37) + .75*crk(j,38) + & + .83*crk(j,39) + 1.8*crk(j,40) + crk(j,42) + crk(j,43) + & + crk(j,45) + crk(j,46) + crk(j,49) + crk(j,50) + crk(j,51) + & + crk(j,52) + crk(j,10) + 2.*crk(j,12) + 2.*crk(j,13) + crk(j,20) + & + crk(j,27) + crk(j,88) + crk(j,89) + crk(j,90) + crk(j,91) + & + .5*crk(j,47) + .5*crk(j,48) + crk(j,92) + crk(j,93) + crk(j,94) + & + crk(j,95) + crk(j,96) + crk(j,97) + crk(j,98) + crk(j,99) + & + crk(j,100) + crk(j,101) + crk(j,127) + crk(j,133) + lossl(j,lhox) = max(alow,lossl(j,lhox)) + END DO + + DO j = jcs, jce + prodl(j,lhox) = crj(j,4) + crj(j,5) + crj(j,6) + 2.*crj(j,9) + & + crj(j,13) + crj(j,14) + crj(j,15) + 2.*crk(j,5) + 2.*crj(j,11) + & + crj(j,12) + crj(j,13) + crj(j,14) + .8*crj(j,18) + crj(j,19) + & + .98*crj(j,20) + crj(j,21) + crk(j,11) + crk(j,57) + & + .964*crk(j,58) + .92*crk(j,60) + .76*crk(j,62) + crk(j,64) + & + crk(j,65) + crk(j,66) + .92*crk(j,68) + crk(j,69) + crk(j,70) + & + crk(j,71) + crk(j,72) + crk(j,74) + crk(j,76) + .12*crk(j,84) + & + .33*crk(j,85) + .40*crk(j,86) + .33*crk(j,87) + crk(j,102) + & + crk(j,103) + crk(j,104) + crk(j,105) + crk(j,106) + crk(j,107) + & + crk(j,108) + crk(j,109) + crk(j,110) + .5*crk(j,111) + & + 2.0*crk(j,112) + 2.*crk(j,113) + .46*crk(j,114) + .5*crk(j,115) + & + .5*crk(j,116) + .5*crk(j,117) + .5*crk(j,118) + .5*crk(j,119) + & + .5*crk(j,120) + .5*crk(j,121) + .5*crk(j,122) + crk(j,124) + & + crk(j,125) + .92*crk(j,126) + crk(j,128) + crk(j,134) + & + .5*crk(j,138) + END DO + +! DO 850 L=1 ,LPRED +! DO 850 J=JCS,JCE +! PROD(J,L)= PROD(J,L) + PRODS(J,L) +!850 CONTINUE + +! DO 900 J=JCS,JCE +! PRODL(J,LNOX) = PRODL(J,LNOX)+ PRODS(J,LNO) + PRODS(J,LNO2) +! PRODL(J,LNTOTAL)= PRODL(J,LNTOTAL)+PRODS(J,LNO)+PRODS(J,LNO2) +!900 CONTINUE + DO J = JCS, JCE + PRDROG(J,PXYL) = CRK(J, 39) + PRDROG(J,PTOL) = CRK(J, 38) + PRDROG(J,PCSL1) = CRK(J, 40) + PRDROG(J,PCSL2) = 0.50 * CRK(J, 79) + PRDROG(J,PHC8) = CRK(J, 34) + PRDROG(J,POLI1) = CRK(J, 37) + PRDROG(J,POLI2) = CRK(J, 82) + PRDROG(J,POLI3) = CRK(J, 86) + PRDROG(J,POLT1) = CRK(J, 36) + PRDROG(J,POLT2) = CRK(J, 81) + PRDROG(J,POLT3) = CRK(J, 85) +! +! next lines for radm only, RACM would be different +! + PRDROG(J,PAPI1) = 0. + PRDROG(J,PAPI2) = 0. + PRDROG(J,PAPI3) = 0. + PRDROG(J,PLIM1) = 0. + PRDROG(J,PLIM2) = 0. + PRDROG(J,PLIM3) = 0. + ENDDO + + RETURN + END SUBROUTINE producn + SUBROUTINE setdtc(jcs,jce,dtc,dtcmax,dtcmin,dt60,prod,loss,vc, & + timenow ) + implicit none + REAL, PARAMETER :: huge=1.e10 +! .. Scalar Arguments .. + REAL, intent(in) :: dt60, dtcmax, dtcmin, timenow + INTEGER, intent(in) :: jce, jcs + REAL, intent(in) :: loss(jcs:jce,lpred), & + prod(jcs:jce,lpred), vc(jcs:jce,1,lspec) + real, intent(inout) :: dtc + +! .. +! .. +! .. Local Scalars .. + INTEGER :: j, k, l +! .. +! .. Local Arrays .. + REAL :: dtlsp(lspec), dum(jcs:jce) +! .. +! .. Intrinsic Functions .. + INTRINSIC abs, max, min +! .. +! .. + k = 1 + + DO l = 1, lspec + dtlsp(l) = huge + END DO + DO l = 1, lpred + IF (qdtc(l)==1) THEN + DO j = jcs, jce + dum(j) = prod(j,l) - loss(j,l) +! dum(j) = max(abs(dum(j)),epsilc) + dum(j) = max(abs(dum(j)),1.e-30) + dum(j) = .02*vc(j,1,l)/dum(j) +! DUM(J) = CVMGP(DUM(J),HUGE,VC(J,1,L)-epsilc*100.) + IF (vc(j,1,l)-1.e-10>=0.) THEN + dum(j) = dum(j) + ELSE + dum(j) = huge + END IF + + END DO + DO j = jcs, jce + dtlsp(l) = min(dtlsp(l),dum(j)) + END DO + END IF + END DO +! IF (dtc<=dtcmax*.9) THEN +! dtc = dtc*1.1 +! ELSE +! dtc = dtcmax +! END IF + dtc = dtcmax + DO l = 1, lpred + IF (qdtc(l)==1) THEN + IF (dtlsp(l)dt60) dtc = dt60 - timenow + RETURN + END SUBROUTINE setdtc + SUBROUTINE chemin + implicit none +! .. Scalar Arguments .. + RETURN + END SUBROUTINE chemin + + END MODULE module_radm diff --git a/wrfv2_fire/chem/module_vertmx_wrf.F b/wrfv2_fire/chem/module_vertmx_wrf.F new file mode 100755 index 00000000..ad20f72c --- /dev/null +++ b/wrfv2_fire/chem/module_vertmx_wrf.F @@ -0,0 +1,174 @@ +MODULE module_vertmx_wrf + +CONTAINS + + SUBROUTINE vertmx(dt,phi,kt_turb,zsigma,zsigma_half,vd,kts,kte) +! !! to calculate change in time of phi due to vertical mixing +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! .. Scalar Arguments .. + REAL :: dt, vd + INTEGER :: kts,kte +! .. +! .. Array Arguments .. + REAL, DIMENSION (kts:kte+1) :: kt_turb, zsigma + REAL, DIMENSION (kts:kte) :: phi, zsigma_half +! .. +! .. Local Scalars .. + INTEGER :: k +! .. +! .. Local Arrays .. + REAL, DIMENSION (kts:kte+1) :: a_coeff + REAL, DIMENSION (kts:kte) :: b_coeff, lhs1, lhs2, lhs3, rhs +! .. +! .. External Subroutines .. +! EXTERNAL coeffs, rlhside, tridiag +! .. + CALL coeffs(kts,kte+1,zsigma,zsigma_half,a_coeff,b_coeff) + + CALL rlhside(kts,kte+1,kt_turb,a_coeff,b_coeff,phi,dt,vd,rhs,lhs1,lhs2,lhs3) + + CALL tridiag(kts,kte,lhs1,lhs2,lhs3,rhs) + + DO k = kts,kte + phi(k) = rhs(k) + END DO + + END SUBROUTINE vertmx + SUBROUTINE rlhside(kts,kte,k_turb,a_coeff,b_coeff,phi,dt,vd,rhs,lhs1,lhs2,lhs3) + !! to calculate right and left hand sides in diffusion equation + !! for the tridiagonal solver + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case +! .. Scalar Arguments .. + REAL :: dt, vd + INTEGER :: kts,kte +! .. +! .. Array Arguments .. + REAL, DIMENSION (kts:kte) :: a_coeff, k_turb + REAL, DIMENSION (kts:kte-1) :: b_coeff, lhs1, lhs2, lhs3, phi, rhs +! .. +! .. Local Scalars .. + REAL :: a1, a2, alfa_explicit = .25, beta_implicit = .75 + INTEGER :: i +! .. +! rhs(1)=phi(1) !! this should be really the n+1 step + rhs(1) = 0. + rhs(1) = (1./(dt*b_coeff(1))-alfa_explicit*(a_coeff(2)*k_turb(2)+vd))* & + phi(1) + alfa_explicit*a_coeff(2)*k_turb(2)*phi(2) + lhs1(1) = 0. +! lhs2(1)=1. +! lhs3(1)=0. +! lhs3(1)=-1. + lhs2(1) = 1./(dt*b_coeff(1)) + beta_implicit*(a_coeff(2)*k_turb(2)+vd) + lhs3(1) = -beta_implicit*a_coeff(2)*k_turb(2) + + DO i = kts+1, kte - 2 + a1 = a_coeff(i)*k_turb(i) + a2 = a_coeff(i+1)*k_turb(i+1) + rhs(i) = (1./(dt*b_coeff(i))-alfa_explicit*(a1+a2))*phi(i) + & + alfa_explicit*(a1*phi(i-1)+a2*phi(i+1)) + + lhs1(i) = -beta_implicit*a1 + lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) + lhs3(i) = -beta_implicit*a2 + END DO + + !! zero flux at the top + + rhs(kte-1) = 0. + lhs1(kte-1) = 1. + lhs2(kte-1) = -1. + lhs3(kte-1) = 0. + + END SUBROUTINE rlhside + + + + + + + + + + + SUBROUTINE tridiag(kts,kte,a,b,c,f) + !! to solve system of linear eqs on tridiagonal matrix n times n + !! after Peaceman and Rachford, 1955 + !! a,b,c,F - are vectors of order n + !! a,b,c - are coefficients on the LHS + !! F - is initially RHS on the output becomes a solution vector + !! Mariusz Pagowski, March 2001 + !! conventions used: + !! input is lower case + !! output is upper case +! .. Scalar Arguments .. + INTEGER :: kts,kte +! .. +! .. Array Arguments .. + REAL, DIMENSION (kts:kte) :: a, b, c, f +! .. +! .. Local Scalars .. + REAL :: p + INTEGER :: i +! .. +! .. Local Arrays .. + REAL, DIMENSION (kts:kte) :: q +! .. + c(kte) = 0. + q(1) = -c(1)/b(1) + f(1) = f(1)/b(1) + + DO i = kts+1, kte + p = 1./(b(i)+a(i)*q(i-1)) + q(i) = -c(i)*p + f(i) = (f(i)-a(i)*f(i-1))*p + END DO + + DO i = kte - 1, kts, -1 + f(i) = f(i) + q(i)*f(i+1) + END DO + + END SUBROUTINE tridiag + + + + + + + + SUBROUTINE coeffs(kts,kte,z_sigma,z_sigma_half,a_coeff,b_coeff) +! !! to calculate coefficients in diffusion equation +! !! Mariusz Pagowski, March 2001 +! !! conventions used: +! !! input is lower case +! !! output is upper case +! .. Scalar Arguments .. + INTEGER :: kts,kte +! .. +! .. Array Arguments .. + REAL, DIMENSION (kts:kte) :: a_coeff, z_sigma + REAL, DIMENSION (kts:kte-1) :: b_coeff, z_sigma_half +! .. +! .. Local Scalars .. + REAL :: any + INTEGER :: i +! .. + any = 1. + + a_coeff(1) = any + b_coeff(1) = 1./(z_sigma(2)-z_sigma(1)) + + DO i = kts+1, kte - 1 + a_coeff(i) = 1./(z_sigma_half(i)-z_sigma_half(i-1)) + b_coeff(i) = 1./(z_sigma(i+1)-z_sigma(i)) + END DO + + a_coeff(kte) = any + + END SUBROUTINE coeffs +END MODULE module_vertmx_wrf diff --git a/wrfv2_fire/chem/module_wetscav_driver.F b/wrfv2_fire/chem/module_wetscav_driver.F new file mode 100644 index 00000000..def1ac00 --- /dev/null +++ b/wrfv2_fire/chem/module_wetscav_driver.F @@ -0,0 +1,225 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + +MODULE module_wetscav_driver + + +CONTAINS + + +!=========================================================================== +!=========================================================================== + subroutine wetscav_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,moist,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg, & + gas_aqfrac, numgas_aqfrac, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1, & + cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!---------------------------------------------------------------------- +! +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction +! +! This driver calls subroutines for wet scavenging. +! +! 1. MADE-SORGAM (Not yet implemented.) +! 2. MOSAIC +! +!---------------------------------------------------------------------- + + USE module_configure + USE module_state_description + USE module_model_constants + USE module_mosaic_wetscav + + IMPLICIT NONE + +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +!-- alt inverse density +!-- t_phy temperature (K) +!-- w vertical velocity (m/s) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- dz8w dz between full levels (m) +!-- p8w pressure at full levels (Pa) +!-- p_phy pressure (Pa) +! points (dimensionless) +!-- z 3D height with lowest level being the terrain +!-- rho_phy density (kg/m^3) +!-- qlsink Fractional cloud water sink (/s) +!-- precr rain precipitation rate at all levels (kg/m2/s) +!-- preci ice precipitation rate at all levels (kg/m2/s) +!-- precs snow precipitation rate at all levels (kg/m2/s) +!-- precg graupel precipitation rate at all levels (kg/m2/s) & +!-- R_d gas constant for dry air ( 287. J/kg/K) +!-- R_v gas constant for water vapor (461 J/k/kg) +!-- Cp specific heat at constant pressure (1004 J/k/kg) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- G acceleration due to gravity (m/s^2) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- config_flags%kemit end index for k for emissions arrays +! +!====================================================================== + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra +! + +! LOCAL VAR + integer :: ii,jj,kk + REAL, DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! column change due to scavening + + +!----------------------------------------------------------------- + +! These are unneeded, since the default behavior is to do nothing. +! If the default changes, then lines need to be added for CBMZ and +! CBMZ_BB. +! IF (config_flags%chem_opt .eq. 0) return +! IF (config_flags%chem_opt .eq. 1) return + +! +! select which aerosol scheme to take +! + cps_select: SELECT CASE(config_flags%chem_opt) + + CASE (RADM2SORG) + CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver') + do ii=its,ite + do kk=kts,kte + do jj=jts,jte + if(chem(ii,kk,jj,p_nu0).lt.1.e07)then + chem(ii,kk,jj,p_nu0)=1.e7 + endif + enddo + enddo + enddo + + CASE (RACMSORG) + CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver') + do ii=its,ite + do kk=kts,kte + do jj=jts,jte + if(chem(ii,kk,jj,p_nu0).lt.1.e07)then + chem(ii,kk,jj,p_nu0)=1.e7 + endif + enddo + enddo + enddo + + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CALL wrf_debug(15,'wetscav_driver calling mosaic_wetscav_driver') + call wetscav_cbmz_mosaic (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg, qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT cps_select + + end subroutine wetscav_driver + + +END MODULE module_wetscav_driver + + diff --git a/wrfv2_fire/chem/photolysis_driver.F b/wrfv2_fire/chem/photolysis_driver.F new file mode 100755 index 00000000..ca42cb5d --- /dev/null +++ b/wrfv2_fire/chem/photolysis_driver.F @@ -0,0 +1,136 @@ +!WRF:MODEL_LAYER:CHEMISTRY +! + SUBROUTINE photolysis_driver (id,ktau,dtstep, config_flags,haveaer,& + gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & + chem,rho_phy,dz8w,xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5,ph_o2, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + pm2_5_dry,pm2_5_water,uvrad, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!------------------------------------------------------------------------ + USE module_configure + USE module_state_description + USE module_model_constants + USE module_phot_mad + USE module_phot_fastj + INTEGER, INTENT(IN ) :: id,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: & + ktau + REAL, INTENT(IN ) :: & + dtstep,gmt +! +! advected moisture variables +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist +! +! aerosol interaction +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water, aerwrf +! +! arrays that hold the photolysis rates +! + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5,ph_o2 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + gd_cloud,gd_cloud2 +! +! arrays that hold the aerosol optical properties +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4 +! +! array that holds all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! on input from meteorological part of model +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT ) :: uvrad + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + xlat, & + xlong + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + LOGICAL, INTENT(IN) :: haveaer +! +! +! LOCAL VAR + + +!----------------------------------------------------------------- + + IF (config_flags%phot_opt .eq. 0) return +! +! select photolysis option +! + chem_phot_select: SELECT CASE(config_flags%phot_opt) + + CASE (PHOTMAD) + CALL wrf_debug(15,'calling madronich1_driver') + call madronich1_driver(id,ktau,dtstep,config_flags,haveaer, & + gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & + chem,rho_phy,dz8w,xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + pm2_5_dry,pm2_5_water,uvrad, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE (PHOTFASTJ) + call wrf_debug(15,'calling fastj_driver') + call fastj_driver(id,ktau,dtstep,config_flags, & + gmt,julday,t_phy,moist,p8w,p_phy, & + chem,rho_phy,dz8w,xlat,xlong,z_at_w, & + ph_o2,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + + END SELECT chem_phot_select + +END SUBROUTINE photolysis_driver diff --git a/wrfv2_fire/clean b/wrfv2_fire/clean new file mode 100755 index 00000000..5a20d75a --- /dev/null +++ b/wrfv2_fire/clean @@ -0,0 +1,48 @@ +#!/bin/csh -f + +set nonomatch + + +foreach dir ( frame chem share dyn_em dyn_exp dyn_nmm phys main tools ) +( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.inc *.F90 *.a \ + db_* Warnings module_state_description.F module_dm.F gmeta \ + wrfdata whatiread rsl.* show_domain* ) +end + + +( cd tools/CodeBase ; make clean ) + +( cd inc ; /bin/rm -f *.inc namelist.default ) + + +if ( "$1" == '-a' ) then + if ( -f configure.wrf ) then + /bin/cp configure.wrf configure.wrf.backup + /bin/rm -f configure.wrf + endif + if ( -f Registry/Registry ) then + /bin/cp Registry/Registry Registry/Registry.backup + /bin/rm -f Registry/Registry + endif + /bin/rm -fr ./netcdf_links + /bin/rm -fr tools/code_dbase + ( cd external ; make -i superclean ) + ( cd external/io_grib1/WGRIB ; make clean ) + ( cd tools ; /bin/rm -f registry gen_comms.c fseeko_test fseeko64_test ) + ( cd inc; /bin/rm -f dm_comm_cpp_flags wrf_io_flags.h wrf_status_codes.h ) + ( cd run ; /bin/rm -f gm* out* fort* ideal* *.exe ; \ + /bin/cp -f namelist.input namelist.input.backup ; \ + /bin/rm -f namelist.input ) >& /dev/null + ( cd test/exp_real ; /bin/rm -f gm* out* fort* real* ) + ( cd test ; rm -f */*.exe */ETAMPNEW_DATA */GENPARM.TBL */LANDUSE.TBL */README.namelist \ + */RRTM_DATA */SOILPARM.TBL */VEGPARM.TBL */urban_param.tbl */grib2map.tbl \ + */CAM_ABS_DATA */CAM_AEROPT_DATA \ + */ozone.formatted */ozone_lat.formatted */ozone_plev.formatted \ + */gribmap.txt */tr??t?? ) >& /dev/null +endif + +#cms++ +if ( -e chem/KPP )then + ( cd chem/KPP; ./clean_kpp ) +endif +#cms-- diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile new file mode 100755 index 00000000..24ce11e8 --- /dev/null +++ b/wrfv2_fire/compile @@ -0,0 +1,261 @@ +#!/bin/csh -f + +cont1: + +if ( ! -e configure.wrf ) then + ./configure $1 + set dontask +endif + + +#---------------------------------- +if ( ! $?WRF_KPP ) setenv WRF_KPP 0 +if ( $WRF_KPP == 1 ) then +chem/KPP/compile_wkc +endif + + + + +#--------------------------------- + +if ( ! $?dontask && $?prompt ) then + echo "This script assumes you have configured the code already." + echo "You only need to configure once." + echo "If you wish to reconfigure, type c at the prompt below" + echo " " + echo "Ready to compile? [ync]" + set resp=$< + + if ( "$resp" == "c" ) then + ./configure + goto cont1 + endif + + if ( "$resp" == "n" ) then + exit 2 + endif +endif + +set arglist="" +foreach a ( $argv ) + if ( "$a" == "-h" ) then + goto hlp + else + if ( "$a" != "-d" ) then + set arglist = ( $arglist $a ) + endif + endif +end + +if ( $arglist == "" ) then + goto hlp +else + unsetenv A2DCASE + setenv A2DCASE `echo $arglist | grep 2d` + + if ( ! ( $?WRF_EM_CORE || $?WRF_NMM_CORE \ + || $?WRF_COAMPS_CORE || $?WRF_EXP_CORE )) then + echo 'None of WRF_EM_CORE, WRF_NMM_CORE, ' +# echo ' WRF_COAMPS_CORE, or WRF_EXP_CORE ' + echo ' specified in shell environment.... ' + setenv WRF_EM_CORE 1 + setenv WRF_NMM_CORE 0 + setenv WRF_COAMPS_CORE 0 + setenv WRF_EXP_CORE 0 + endif + +# these settings get passed down through the environment in the +# calls to Make + if ( ! $?WRF_EM_CORE ) setenv WRF_EM_CORE 0 + if ( ! $?WRF_NMM_CORE ) setenv WRF_NMM_CORE 0 + if ( ! $?WRF_NMM_NEST ) setenv WRF_NMM_NEST 0 + if ( ! $?WRF_COAMPS_CORE ) setenv WRF_COAMPS_CORE 0 + if ( ! $?WRF_EXP_CORE ) setenv WRF_EXP_CORE 0 + if ( ! $?WRF_CHEM ) setenv WRF_CHEM 0 + if ( ! $?WRF_CONVERT ) then + if ( "$arglist" == "convert_em" ) then + setenv WRF_CONVERT 1 + setenv WRF_EM_CORE 0 + else + setenv WRF_CONVERT 0 + endif + endif + + set overwrite=0 + if ($WRF_NMM_CORE == 1 && $WRF_CHEM == 1 ) then + echo "Chemistry not yet supported in NMM core, set WRF_CHEM to 0 " + grep -q DM_PARALLEL configure.wrf + if ( $status == 1 ) then + echo NMM_CORE must be configured for DM parallel + echo Please rerun the configure script and chose a DM parallel option + exit 3 + endif + if ( ! -f Registry/Registry ) then + echo Registry file does not exist + set overwrite=1 + else + head -2 Registry/Registry | tail -1 | grep NMM_CHEM > /dev/null + if ( $status ) then + set overwrite=1 + else + set nmm_time=`ls -1tr Registry | cat -n | grep -w 'Registry\.NMM_CHEM' | grep -v 'Registry.NMM_CHEM.' | awk '{print $1}'` + set rg_time=`ls -1tr Registry | cat -n | grep -w 'Registry' | grep -v 'Registry.' | awk '{print $1}'` + if ( $nmm_time > $rg_time ) set overwrite=1 + endif + endif + if ( $overwrite ) then + echo copying Registry/Registry.NMM_CHEM to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.NMM_CHEM. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.NMM_CHEM >> Registry/Registry + endif +# exit 2 + endif + + + if ($WRF_EM_CORE == 1 && $WRF_NMM_CORE == 1 ) then + echo "Cannot compile both EM and NMM cores in same executable yet." + exit 2 + endif + if ($WRF_EM_CORE == 0 && $WRF_NMM_CORE == 0 && ! $WRF_CONVERT == 1 ) then + echo "Cannot compile because both EM and NMM cores are set to 0." + exit 2 + endif + if (($WRF_EM_CORE == 1)&&($WRF_CHEM == 0 )&&($WRF_CONVERT == 0)) then + if ( ! -f Registry/Registry ) then + set overwrite=1 + else + head -2 Registry/Registry | tail -1 | grep EM > /dev/null + if ( $status ) then + set overwrite=1 + else + set em_time=`ls -1tr Registry | cat -n | grep -w 'Registry\.EM' | grep -v 'Registry.EM.' | awk '{print $1}'` + set rg_time=`ls -1tr Registry | cat -n | grep -w 'Registry' | grep -v 'Registry.' | awk '{print $1}'` + if ( $em_time > $rg_time ) set overwrite=1 + endif + endif + if ( $overwrite ) then + echo copying Registry/Registry.EM to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.EM. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.EM >> Registry/Registry + endif + else if (($WRF_EM_CORE == 1)&&($WRF_CHEM == 1 )) then + if ( ! -f Registry/Registry ) then + set overwrite=1 + else + head -2 Registry/Registry | tail -1 | grep EM_CHEM > /dev/null + if ( $status ) then + set overwrite=1 + else + set em_time=`ls -1tr Registry | cat -n | grep -w 'Registry\.EM_CHEM' | grep -v 'Registry.EM_CHEM.' | awk '{print $1}'` + set rg_time=`ls -1tr Registry | cat -n | grep -w 'Registry' | grep -v 'Registry.' | awk '{print $1}'` + if ( $em_time > $rg_time ) set overwrite=1 + endif + endif + if ( $overwrite ) then + echo copying Registry/Registry.EM_CHEM to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.EM_CHEM. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.EM_CHEM >> Registry/Registry + endif + else if (($WRF_EM_CORE == 0)&&($WRF_CONVERT == 1 )) then + if ( ! -f Registry/Registry ) then + set overwrite=1 + else + head -2 Registry/Registry | tail -1 | grep EM_CONVERT > /dev/null + if ( $status ) then + set overwrite=1 + else + set em_time=`ls -1tr Registry | cat -n | grep -w 'Registry\.EM_CONVERT' | grep -v 'Registry.EM_CONVERT.' | awk '{print $1}'` + set rg_time=`ls -1tr Registry | cat -n | grep -w 'Registry' | grep -v 'Registry.' | awk '{print $1}'` + if ( $em_time > $rg_time ) set overwrite=1 + endif + endif + if ( $overwrite ) then + echo copying Registry/Registry.CONVERT to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.CONVERT. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.CONVERT >> Registry/Registry + endif + + + endif + if (($WRF_NMM_CORE == 1)&&($WRF_CHEM == 0 )) then + grep -q DM_PARALLEL configure.wrf + if ( $status == 1 ) then + echo NMM_CORE must be configured for DM parallel + echo Please rerun the configure script and chose a DM parallel option + exit 3 + endif + if ( ! -f Registry/Registry ) then + set overwrite=1 + else + head -2 Registry/Registry | tail -1 | grep NMM > /dev/null + if ( $status ) then + set overwrite=1 + else + set nmm_time=`ls -1tr Registry | cat -n | grep -w 'Registry\.NMM' | grep -v 'Registry.NMM.' | awk '{print $1}'` + set rg_time=`ls -1tr Registry | cat -n | grep -w 'Registry' | grep -v 'Registry.' | awk '{print $1}'` + if ( $nmm_time > $rg_time ) set overwrite=1 + endif + endif + if ( $overwrite ) then + if (($WRF_NMM_CORE == 1)&&($WRF_NMM_NEST == 1)) then + echo copying Registry/Registry.NMM_NEST to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.NMM_NEST. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.NMM_NEST >> Registry/Registry + else + echo copying Registry/Registry.NMM to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.NMM. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.NMM >> Registry/Registry + endif + endif +# integrity check for a kludge where a hard coded value in the +# registry must match the same value in arch/preamble + set registryvalue=`grep 'dimspec.* q ' Registry/Registry.NMM | sed -e 's/..*constant=//' -e 's/ ..*$//'` + set preamblevalue=`grep 'DNMM_MAX_DIM=.*' arch/preamble | sed -e 's/..*-DNMM_MAX_DIM=//' -e 's/ ..*$//'` + if ( $registryvalue != $preamblevalue ) then + echo "Harded coded value of dimspec q in Registry ($registryvalue) does not" + echo "equal the hard coded value of NMM_MAX_DIM in arch/preamble ($preamblevalue)" + echo "Please fix and try again." + exit 2 + endif + endif + + echo " " + echo -n "**** Compiling: " + if ( $WRF_EM_CORE ) echo -n "WRF_EM_CORE " + if ( $WRF_NMM_CORE ) echo -n "WRF_NMM_CORE " + if ( $WRF_COAMPS_CORE ) echo -n "WRF_COAMPS_CORE " + if ( $WRF_EXP_CORE ) echo -n "WRF_EXP_CORE " + echo "." + echo " " + + # This incredible hackery due to OSF1 $(PWD) not changing during + # build via regtest.csh ... + # Note that $WRF_SRC_ROOT_DIR is only used by the OSF1 build. + if ( $?WRF_SRC_ROOT_DIR ) then + make $arglist A2DCASE="$A2DCASE" WRF_SRC_ROOT_DIR="$WRF_SRC_ROOT_DIR" + else + make $arglist A2DCASE="$A2DCASE" WRF_SRC_ROOT_DIR="$PWD" + endif + +endif + +exit 0 + +hlp: + +echo ' ' +echo 'Usage:' +echo ' ' +echo ' compile wrf compile wrf in run dir (NOTE: no real.exe, ndown.exe, or ideal.exe generated)' +echo ' ' +echo ' or choose a test case (see README_test_cases for details) :' +foreach d ( `/bin/ls test` ) + if ( "$d" != "CVS" ) then + echo " compile $d" + endif +end +echo ' ' +echo ' compile -h help message' + + diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure new file mode 100755 index 00000000..2d80347a --- /dev/null +++ b/wrfv2_fire/configure @@ -0,0 +1,378 @@ +#!/bin/sh + +arg1=$1 + +# lifted from the configure file for mpich; 00/03/10 jm +# +# Check for perl and perl version +for p in perl5 perl +do + # Extract the first word of "$p", so it can be a program name with args. + set dummy $p; ac_word=$2 + if test -z "$ac_echo_n" ; then + ac_echo_n=yes + if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi + else + ac_n= ac_c='\c' ac_t= + fi + ac_echo_test=`echo foo 1>&1` + if test -z "$ac_echo_test" ; then + print_error "Your sh shell does not handle the output redirection" + print_error "1>&1 correctly. Configure will work around this problem," + print_error "but you should report the problem to your vendor." + fi + fi + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo $ac_n "checking for $ac_word""... $ac_c" + else + echo $ac_n "checking for $ac_word""... $ac_c" 1>&1 + fi + ac_prog_where="" + if test -n "$PERL"; then + ac_pg_PERL="$PERL" # Let the user override the test. + else + ac_first_char=`expr "$p" : "\(.\)"` + if test "$ac_first_char" = "/" -a -x "$p" ; then + ac_pg_PERL="$p" + ac_prog_where=$p + else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_pg_PERL="$p" + ac_prog_where=$ac_dir/$ac_word + break + fi + done + IFS="$ac_save_ifs" + fi + fi;PERL="$ac_pg_PERL" + if test -n "$ac_prog_where" ; then + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo "$ac_t""found $ac_prog_where ($PERL)" + else + echo "$ac_t""found $ac_prog_where ($PERL)" 1>&1 + fi + PERLFULLPATH=$ac_prog_where + else + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo "$ac_t""no" + else + echo "$ac_t""no" 1>&1 + fi + fi + test -n "$PERL" && break +done + +if test -z "$PERL" ; then + # We have to set this outside of the loop lest the first failure in + # PROGRAM_CHECK set the value (which then terminates the effect of the + # loop, since autoconf macros only set values that are null, they + # don't override them + PERL="" +fi + +if test -n "$PERL" ; then + PERL="$PERL" + + perlversion=`$PERL -v | grep 'This is perl' | \ + sed -e 's/^.*v[a-z ]*\([0-9]\).*$/\1/'` + + # Should do a test first for ch_p4 etc. + if test "$perlversion" -lt 5 ; then + echo "WRF build requires perl version 5, which configure did not find." + echo "You can set the environment variable PERL to contain the " + echo "location of perl version 5." + echo "Configure believes that $PERL is version $perlversion ." + PERL="" + fi + +fi + +# Look for netcdf +if test -z "$NETCDF" ; then + for p in /usr/local/netcdf + do + if test -d $p ; then + NETCDF=$p + break + fi + done +fi +if test -z "$NETCDF" ; then + + if [ `hostname | cut -c 1-2` = "bs" -o \ + `hostname | cut -c 1-2` = "bd" -o \ + `hostname` = "tempest" -o `hostname` = "ute" ] ; then + echo 'Compiling on an NCAR system with weird paths to NetCDF' + echo 'Setting up a local NetCDF directory with symlinks' + if ( test -d ./netcdf_links ) ; then + echo 'A directory ./netcdf_links already exists. Continuing.' + else + mkdir ./netcdf_links + if [ -z "$OBJECT_MODE" ] ; then + OBJECT_MODE=32 + export OBJECT_MODE + fi + if [ $OBJECT_MODE -ne 64 -a \( `hostname | cut -c 1-2` = "bd" -o `hostname | cut -c 1-2` = "bs" \) ] ; then + ( cd ./netcdf_links ; ln -s /usr/local/lib32/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + else + ( cd ./netcdf_links ; ln -s /usr/local/lib64/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + fi + fi + NETCDF=`pwd`/netcdf_links + export NETCDF + + + else + bedone="" + if [ -d ./netcdf_links ] ; then + echo '** There is an existing ./netcdf_links file. Should I use? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + bedone="yes" + else + echo 'Removing existing ./netcdf_links directory' + /bin/rm -fr ./netcdf_links + fi + else + echo '** WARNING: No path to NETCDF and environment variable NETCDF not set.' + echo '** would you like me to try to fix? [y]' + fi + netcdfipath="" + netcdflpath="" + while [ -z "$bedone" ] ; do + read resp + if [ "$resp" = "y" -o -z "$resp" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'There is already a ./netcdf_links directory. Okay to use links' + echo 'in this directory for NetCDF include and lib dirs? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + continue + fi + fi + if [ -z "$netcdfipath" ] ; then + echo 'Enter full path to NetCDF include directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdfipath=$resp + fi + if [ -z "$netcdflpath" ] ; then + echo 'Enter full path to NetCDF library directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdflpath=$resp + fi + + if [ -n "$netcdflpath" -a -n "$netcdfipath" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'Existing ./netcdf_links directory. Okay to remove. [y]' + read resp + if [ "$resp" = "y" ] ; then + /bin/rm -fr ./netcdf_links + fi + fi + mkdir ./netcdf_links + cd ./netcdf_links + ln -s "$netcdfipath" include + ln -s "$netcdflpath" lib + cd .. + echo created new ./netcdf_links directory + /bin/ls -lF ./netcdf_links + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + fi + else + bedone="yes" + fi + done + fi +fi + +if test -z "$PDHF5" ; then + if [ `hostname | cut -c 1-2` = "bb" -o `hostname | cut -c 1-2` = "bf" -o `hostname | cut -c 1-2` = "bs" -o \ + `hostname` = "dataproc" -o `hostname` = "ute" ] ; then + if [ -d ~michalak/hdf5pbin ] ; then + PHDF5=~michalak/hdf5pbin + export PHDF5 + fi + if [ "$OBJECT_MODE" -eq 64 ] ; then + if [ -d ~michalak/hdf5pbin-64 ] ; then + PHDF5=~michalak/hdf5pbin-64 + export PHDF5 + fi + fi + fi +fi + +if [ -n "$NETCDF" ] ; then + echo "Will use NETCDF in dir: $NETCDF" +else + echo "Will configure for use without NetCDF" +fi + +if [ -n "$PNETCDF" ] ; then + echo "Will use PNETCDF in dir: $PNETCDF" +# experimental, so don't tease the user if it is not there +#else +# echo "Will configure for use without NetCDF" +fi + +if [ -n "$PHDF5" ] ; then + echo "Will use PHDF5 in dir: $PHDF5" +else + echo "PHDF5 not set in environment. Will configure WRF for use without." +fi + +# Users who are cross-compiling can set environment variable +# $WRF_OS to override the value normally obtained from `uname`. +# If $WRF_OS is set, then $WRF_MACH can also be set to override +# the value normally obtained from `uname -m`. If $WRF_OS is +# set and $WRF_MACH is not set, then $WRF_MACH defaults to "ARCH". +# If $WRF_OS is not set then $WRF_MACH is ignored. +if [ -n "$WRF_OS" ] ; then + echo "${0}: WRF operating system set to \"${WRF_OS}\" via environment variable \$WRF_OS" + os=$WRF_OS + mach="ARCH" + if [ -n "$WRF_MACH" ] ; then + echo "${0}: WRF machine set to \"${WRF_MACH}\" via environment variable \$WRF_MACH" + mach=$WRF_MACH + fi +else + # if the uname command exists, give it a shot and see if + # we can narrow the choices; otherwise, spam 'em + os="ARCH" + mach="ARCH" + type uname > /dev/null + if [ $? -eq 0 ] ; then + os=`uname` + if [ "$os" = "AIX" -o "$os" = "IRIX" -o "$os" = "IRIX64" -o "$os" = "SunOS" -o "$os" = "HP-UX" -o "$os" = "Darwin" ] ; then + mach="ARCH" + else + if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT-5.1" ] ; then + mach=`uname -m` + else + os="ARCH" + mach="ARCH" + fi + fi + fi +fi + +# an IBM specific hack to adjust the bmaxstack and bmaxdata options if addressing is 32-bit +if [ "$os" = "AIX" ] ; then + if [ -z "$OBJECT_MODE" ] ; then + OBJECT_MODE=32 + export OBJECT_MODE + fi + if [ "$OBJECT_MODE" = "32" ] ; then +# the bang means nothing to sh in this context; use to represent spaces (perl will unbang) + ldflags=-bmaxstack:256000000!-bmaxdata:2048000000 + fi +fi + +# compile options that come from the environment, such as chemistry +# the "!" is removed by Config.pl +if [ -n "$WRF_CHEM" ] ; then + if [ $WRF_CHEM = 1 ] ; then + echo building WRF with chemistry option + compileflags="${compileflags}!-DWRF_CHEM" + if [ $WRF_KPP = 1 ] ; then + echo building WRF with KPP chemistry option + compileflags="${compileflags}!-DWRF_KPP" + fi + else + compileflags=" " + fi +else + compileflags=" " +fi + +# Found perl, so proceed with configuration +if test -n "$PERL" ; then + $PERL arch/Config.pl -perl=$PERL -netcdf=$NETCDF -pnetcdf=$PNETCDF -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ + -compileflags=$compileflags + if test ! -f configure.wrf ; then + exit 1 + fi +fi + +if [ "$arg1" = "-d" ] ; then +ls -l configure.wrf + if [ -e configure.wrf ] ; then + sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//g' configure.wrf > configure.wrf.edit + /bin/mv configure.wrf.edit configure.wrf + fi +fi + +# new feb 2005. test whether MPI-2 +if test -f configure.wrf ; then + grep 'DMPARALLEL .*=.*1' configure.wrf > /dev/null + if [ $? = 0 ] ; then + echo testing for MPI_Comm_f2c and MPI_Comm_c2f + /bin/rm -f tools/mpi2_test + ( make mpi2_test 2> /dev/null ) 1> /dev/null + if test -e tools/mpi2_test.o ; then + echo " " MPI_Comm_f2c and MPI_Comm_c2f are supported + sed '/^CC .*=/s/$/ -DMPI2_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + else + echo " " MPI_Comm_f2c and MPI_Comm_c2f are not supported + fi + fi +# new dec 2005. test what fseek is supported (needed for share/landread.c to work correctly) + echo testing for fseeko and fseeko64 + /bin/rm -f tools/fseeko_test tools/fseeko64_test + ( make fseek_test 2> /dev/null ) 1> /dev/null + if test -x tools/fseeko64_test ; then + ( tools/fseeko64_test 2> /dev/null ) 1> /dev/null + if [ $? = 0 ] ; then + echo fseeko64 is supported + sed '/^CC .*=/s/$/ -DFSEEKO64_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + fi + else + if test -x tools/fseeko_test ; then + ( tools/fseeko_test 2> /dev/null ) 1> /dev/null + if [ $? = 0 ] ; then + echo fseeko is supported and handles 64 bit offsets + sed '/^CC .*=/s/$/ -DFSEEKO_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + else + echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek + echo but may not work correctly for very high resolution terrain datasets + fi + else + echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek + echo but may not work correctly for very high resolution terrain datasets + fi + fi +fi + +echo "------------------------------------------------------------------------" +sed -e '1,/#### Architecture specific settings ####/d' -e '/^externals/,$d' configure.wrf + +echo "------------------------------------------------------------------------" +echo "Settings listed above are written to configure.wrf." +echo "If you wish to change settings, please edit that file." +echo "If you wish to change the default options, edit the file:" +echo " arch/configure.defaults" +echo " " + diff --git a/wrfv2_fire/configure.wrf.backup b/wrfv2_fire/configure.wrf.backup new file mode 100644 index 00000000..6eb4677f --- /dev/null +++ b/wrfv2_fire/configure.wrf.backup @@ -0,0 +1,264 @@ +# configure.wrf +# +# This file was automatically generated by the configure script in the +# top level directory. You may make changes to the settings in this +# file but be aware they will be overwritten each time you run configure. +# Ordinarily, it is necessary to run configure once, when the code is +# first installed. +# +# To permanently change options, change the settings for your platform +# in the file arch/configure.defaults then rerun configure. +# +SHELL = /bin/sh +DEVTOP = `pwd` +LIBINCLUDE = . +.SUFFIXES: .F .i .o .f90 .c + +#### Get core settings from environment (set in compile script) +#### Note to add a core, this has to be added to. + +COREDEFS = -DEM_CORE=$(WRF_EM_CORE) \ + -DNMM_CORE=$(WRF_NMM_CORE) -DNMM_MAX_DIM=2600 \ + -DCOAMPS_CORE=$(WRF_COAMPS_CORE) \ + -DEXP_CORE=$(WRF_EXP_CORE) + +#### Single location for defining total number of domains. You need +#### at least 1 + 2*(number of total nests). For example, 1 coarse +#### grid + three fine grids = 1 + 2(3) = 7, so MAX_DOMAINS=7. + +MAX_DOMAINS = 21 + +#### DM buffer length for the configuration flags. + +CONFIG_BUF_LEN = 16384 + + +############################################################################## +#### The settings in this section are defaults that may be overridden by the +#### architecture-specific settings in the next section. +############################################################################## + +############################################################################## +#### NOTE: Do not modify these default values here. To override these +#### values, make changes after "Architecture specific settings". +############################################################################## + +#### Native size (in bytes) of Fortran REAL data type on this architecture #### +#### Note: to change real wordsize (for example, to promote REALs from +#### 4-byte to 8-byte), modify the definition of RWORDSIZE in the +#### section following "Architecture specific settings". Do not +#### change NATIVE_RWORDSIZE as is it architecture-specific. +NATIVE_RWORDSIZE = 4 + +#### Default sed command and script for Fortran source files #### +SED_FTN = sed -f ../arch/standard.sed + +# Hack to work around $(PWD) not changing during OSF1 build. +# $(IO_GRIB_SHARE_DIR) is reset during the OSF1 build only. +IO_GRIB_SHARE_DIR = + +#### ESMF switches #### +#### These are set up by Config.pl #### +# switch to use separately installed ESMF library for coupling: 1==true +ESMF_COUPLING = 0 +# select dependences on module_utility.o +ESMF_MOD_DEPENDENCE = ../external/esmf_time_f90/module_utility.o +# select -I options for separately installed ESMF library, if present +ESMF_MOD_INC = +# select -I options for external/io_esmf vs. external/esmf_time_f90 +ESMF_IO_INC = -I../external/esmf_time_f90 +# select cpp token for external/io_esmf vs. external/esmf_time_f90 +ESMF_IO_DEFS = +# select build target for external/io_esmf vs. external/esmf_time_f90 +ESMF_TARGET = esmf_time + +############################################################################## + + +#### Architecture specific settings #### + +# Settings for Darwin (single-threaded, no nesting, USES: gcc-3.3, xlf cpp, SystemStubs) +# +# Using -qfloat=nomaf option can result in identical results with +# non-optimized and optimized results (suggested by Fovell of UCLA) +# One may turn on by uncommenting it in FCOPTIM line +# +FC = xlf90_r +SFC = $(FC) +LD = xlf90_r +#CC = cc_r +CC = gcc-3.3 +SCC = $(CC) +RWORDSIZE = $(NATIVE_RWORDSIZE) +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +CFLAGS = -DNOUNDERSCORE -DLANDREAD_STUB -I /usr/include/sys -DMACOS +FCOPTIM = #-O3 -qarch=auto #-qfloat=nomaf +FCDEBUG = #-qnoopt -qfullpath +FCBASEOPTS = -qsave $(FCDEBUG) -qmaxmem=32767 -qspillsize=32767 -w +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) +FCSUFFIX = -qsuffix=f=f90 +# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.) +ESMF_LIB_FLAGS = +ESMF_IO_LIB = -L../external/esmf_time_f90 -lesmf_time +ESMF_IO_LIB_EXT = -L../../external/esmf_time_f90 -lesmf_time +INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int -I../external/esmf_time_f90 \ + -I../frame -I../share -I../phys -I../inc -I../chem +ARCHFLAGS = $(COREDEFS) -DGRIB1 -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ + -DNETCDF \ + -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DLANDREAD_STUB -DMAC_KLUDGE +# -DLIMIT_ARGS -DNO_NAMELIST_PRINT -DNATIVE_MASSV -DMACOS +PERL = perl +REGISTRY = Registry +#LIB = -L../external/io_netcdf -lwrfio_nf -L/usr/local/netcdf-xlf/lib -lnetcdf -lmass -lmassv +LIB = -L../external/io_netcdf -lwrfio_nf -L/usr/local/netcdf-xlf/lib -lnetcdf \ + -L../external/io_int -lwrfio_int \ + -L../external/io_grib1 -lio_grib1 \ + \ + -L../external/io_grib_share -lio_grib_share \ + ../frame/module_internal_header_util.o ../frame/pack_utils.o -L../external/esmf_time_f90 -lesmf_time + +LDFLAGS = -Wl,-stack_size,10000000,-stack_addr,0xc0000000 -L/usr/lib -lSystemStubs +ENVCOMPDEFS = +WRF_CHEM = 0 +CPP = /opt/ibmcmp/xlf/8.1/exe/cpp -C -P +#CPP = /usr/bin/cpp -C -P -xassembler-with-cpp +POUND_DEF = -DNONSTANDARD_SYSTEM -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) -DMAX_DOMAINS_F=$(MAX_DOMAINS) +CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) $(COREDEFS) $(ENVCOMPDEFS) $(POUND_DEF) +AR = ar ru +M4 = m4 -B 14000 +RANLIB = ranlib +NETCDFPATH = /usr/local/netcdf-xlf +CC_TOOLS = cc + +externals : wrf_ioapi_includes wrfio_nf wrfio_grib_share wrfio_grib1 wrfio_int module_dm.F esmf_time + +module_dm.F : + ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ) + +wrfio_nf : + ( cd ../external/io_netcdf ; make NETCDFPATH=/usr/local/netcdf-xlf RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" ) + +wrfio_int : + ( cd ../external/io_int ; \ + make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" all ) + +wrfio_grib_share : + ( cd ../external/io_grib_share ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib1 : + ( cd ../external/io_grib1 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive) + +wrfio_grib2 : + ( cd ../external/io_grib2 ; \ + make CC="$(SCC)" CFLAGS="$(CFLAGS) -qcpluscmt" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" FREE="" FIXED="-qfixed" archive) + +esmf_time : + ( cd ../external/esmf_time_f90 ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" ) + +solve_interface.o : solve_interface.F + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c -qfree=f90 -qspillsize=32767 -I. $(PROMOTION) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +# compile these without high optimization to speed compile +shift_domain_em.o : shift_domain_em.F +module_io_mm5.o : module_io_mm5.F +module_si_io.o : module_si_io.F +module_io_wrf.o : module_io_wrf.F +module_domain.o : module_domain.F +module_start.o : module_start.F +module_initialize.o : module_initialize.F +module_initialize_b_wave.o : module_initialize_b_wave.F +module_initialize_hill2d_x.o : module_initialize_hill2d_x.F +module_initialize_quarter_ss.o : module_initialize_quarter_ss.F +module_initialize_squall2d_x.o : module_initialize_squall2d_x.F +module_initialize_squall2d_y.o : module_initialize_squall2d_y.F +module_initialize_real.o : module_initialize_real.F +module_dm.o : module_dm.F +start_domain.o : start_domain.F +solve_em.o : solve_em.F +mediation_interp_domain.o : mediation_interp_domain.F +mediation_force_domain.o : mediation_force_domain.F +mediation_feedback_domain.o : mediation_feedback_domain.F +convert_nmm.o : convert_nmm.F +module_configure.o : module_configure.F + +module_io_mm5.o module_si_io.o module_io_wrf.o module_domain.o \ +module_start.o module_initialize.o module_initialize_b_wave.o \ +module_initialize_hill2d_x.o module_initialize_quarter_ss.o \ +module_initialize_squall2d_x.o module_initialize_squall2d_y.o \ +module_initialize_real.o module_dm.o \ +shift_domain_em.o \ +mediation_interp_domain.o \ +module_configure.o \ +solve_em.o \ +convert_nmm.o : + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 + +########################################################### + +# These sub-directory builds are identical across all architectures +wrfio_esmf : + ( cd ../external/io_esmf ; \ + make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " ) + + +# +# Macros, these should be generic for all machines + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + +# There is probably no reason to modify these rules + +wrf_ioapi_includes : + ( cd ../external/ioapi_share ; \ + $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" ) + +.F.i: + $(RM) $@ + $(CPP) -I../inc $(CPPFLAGS) $*.F > $@ + mv $*.i $(DEVTOP)/pick/$*.f90 + cp $*.F $(DEVTOP)/pick + +.F.o: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90 + $(RM) $*.b + $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi + +.F.f90: + $(RM) $@ + $(SED_FTN) $*.F > $*.b + $(CPP) -I../inc $(CPPFLAGS) $*.b > $@ + $(RM) $*.b + +.f90.o: + $(RM) $@ + $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi +#PGI if [ ! -e $@ ] ; then \ +#PGI sleep 10 ; $(FC) -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \ +#PGI fi + +.c.o: + $(RM) $@ + $(CC) -c $(CFLAGS) $*.c + diff --git a/wrfv2_fire/dyn_em/Makefile b/wrfv2_fire/dyn_em/Makefile new file mode 100644 index 00000000..7c638a29 --- /dev/null +++ b/wrfv2_fire/dyn_em/Makefile @@ -0,0 +1,226 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + + +MODULES = \ + module_advect_em.o \ + module_diffusion_em.o \ + module_small_step_em.o \ + module_big_step_utilities_em.o \ + module_em.o \ + module_solvedebug_em.o \ + module_bc_em.o \ + module_init_utilities.o \ + $(CASE_MODULE) + +# possible CASE_MODULE settings +# module_initialize_b_wave.o \ +# module_initialize_grav2d_x.o \ +# module_initialize_hill2d_x.o \ +# module_initialize_fire.o \ +# module_initialize_quarter_ss.o \ +# module_initialize_real.o \ +# module_initialize_lsm_x.o \ +# module_initialize_squall2d_x.o \ +# module_initialize_squall2d_y.o + +OBJS = \ + init_modules_em.o \ + solve_em.o \ + start_em.o \ + shift_domain_em.o \ + couple_or_uncouple_em.o \ + nest_init_utils.o \ + interp_domain_em.o + + +LIBTARGET = dyn_em +TARGETDIR = ./ +$(LIBTARGET) : $(MODULES) $(OBJS) + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) + +include ../configure.wrf + +clean: + @ echo 'use the clean script' + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +couple_or_uncouple_em.o: ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../frame/module_machine.o \ + ../frame/module_tiles.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o + +init_modules_em.o: module_big_step_utilities_em.o + +interp_domain_em.o: ../frame/module_domain.o \ + ../frame/module_configure.o + +module_advect_em.o: ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + +module_bc_em.o: ../share/module_bc.o ../frame/module_configure.o \ + ../frame/module_wrf_error.o + +module_big_step_utilities_em.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o + +module_diffusion_em.o: module_big_step_utilities_em.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + ../frame/module_wrf_error.o + +module_em.o: module_big_step_utilities_em.o module_advect_em.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o + +module_small_step_em.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + +module_initialize_b_wave.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_grav2d_x.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_hill2d_x.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_fire.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_quarter_ss.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_real.o : ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + ../share/module_soil_pre.o \ + ../share/module_optional_si_input.o + +module_initialize_squall2d_x.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +module_initialize_squall2d_y.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + +nest_init_utils.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o + +start_em.o: module_bc_em.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + ../share/module_date_time.o \ + ../phys/module_physics_init.o + +solve_em.o: module_small_step_em.o \ + module_em.o \ + module_solvedebug_em.o \ + module_bc_em.o \ + module_diffusion_em.o \ + module_big_step_utilities_em.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../frame/module_state_description.o \ + ../frame/module_machine.o \ + ../frame/module_tiles.o \ + ../frame/module_dm.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + ../phys/module_radiation_driver.o \ + ../phys/module_surface_driver.o \ + ../phys/module_cumulus_driver.o \ + ../phys/module_microphysics_driver.o \ + ../phys/module_microphysics_zero_out.o \ + ../phys/module_pbl_driver.o \ + ../phys/module_fire_driver.o \ + ../phys/module_fddagd_driver.o \ + ../phys/module_fddaobs_driver.o \ + ../phys/module_physics_addtendc.o + +# ../chem/module_chem_utilities.o \ +# ../chem/module_input_chem_data.o + +# DO NOT DELETE diff --git a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F new file mode 100644 index 00000000..f41e26a0 --- /dev/null +++ b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F @@ -0,0 +1,425 @@ +!WRF:MEDIATION_LAYER:couple_uncouple_utility + +SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & +! +#include "em_dummy_new_args.inc" +! + ) + + +! #undef DM_PARALLEL + +! Driver layer modules + USE module_domain + USE module_configure + USE module_driver_constants + USE module_machine + USE module_tiles + USE module_dm + USE module_bc +! Mediation layer modules +! Registry generated module + USE module_state_description + + IMPLICIT NONE + + ! Subroutine interface block. + + TYPE(domain) , TARGET :: grid + + ! Definitions of dummy arguments to solve +#include + + ! WRF state bcs + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + LOGICAL, INTENT( IN) :: couple + + ! Local data + + INTEGER :: k_start , k_end + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER :: i,j,k, im + INTEGER :: num_3d_c, num_3d_m, num_3d_s + REAL :: mu_factor + + REAL, DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: mut_2, muut_2, muvt_2, muwt_2 + +! De-reference dimension information stored in the grid data structure. + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + num_3d_m = num_moist + num_3d_c = num_chem + num_3d_s = num_scalar + + ! couple or uncouple mass-point variables + ! first, compute mu or its reciprical as necessary + +! write(6,*) ' in couple ' +! write(6,*) ' x,y memory ', grid%sm31,grid%em31,grid%sm33,grid%em33 +! write(6,*) ' x,y patch ', ips, ipe, jps, jpe + + +! if(couple) then +! write(6,*) ' coupling variables for grid ',grid%id +! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe +! else +! write(6,*) ' uncoupling variables for grid ',grid%id +! write(6,*) ' ips, ipe, jps, jpe ',ips,ipe,jps,jpe +! write(6,*) ' x, y, size ',size(mu_2,1),size(mu_2,2) +! end if + +#ifdef DM_PARALLEL +# include +#endif + + + IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN + CALL set_physical_bc2d( grid%em_mub, 't', & + config_flags, & + ids,ide, jds,jde, & ! domain dims + ims,ime, jms,jme, & ! memory dims + ips,ipe, jps,jpe, & ! patch dims + ips,ipe, jps,jpe ) + CALL set_physical_bc2d( grid%em_mu_1, 't', & + config_flags, & + ids,ide, jds,jde, & ! domain dims + ims,ime, jms,jme, & ! memory dims + ips,ipe, jps,jpe, & ! patch dims + ips,ipe, jps,jpe ) + CALL set_physical_bc2d( grid%em_mu_2, 't', & + config_flags, & + ids,ide, jds,jde, & ! domain dims + ims,ime, jms,jme, & ! memory dims + ips,ipe, jps,jpe, & ! patch dims + ips,ipe, jps,jpe ) + ENDIF + + +#ifdef DM_PARALLEL +# include "HALO_EM_COUPLE_A.inc" +# include "PERIOD_EM_COUPLE_A.inc" +#endif + + ! computations go out one row and column to avoid having to communicate before solver + + IF( couple ) THEN + +! write(6,*) ' coupling: setting mu arrays ' + + DO j = max(jds,jps),min(jde-1,jpe) + DO i = max(ids,ips),min(ide-1,ipe) + mut_2(i,j) = grid%em_mub(i,j) + grid%em_mu_2(i,j) + muwt_2(i,j) = (grid%em_mub(i,j) + grid%em_mu_2(i,j))/grid%msft(i,j) + ENDDO + ENDDO + +! need boundary condition fixes for u and v ??? + +! write(6,*) ' coupling: setting muv and muv arrays ' + + DO j = max(jds,jps),min(jde-1,jpe) + DO i = max(ids,ips),min(ide-1,ipe) + muut_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j) + muvt_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))/grid%msfv(i,j) + ENDDO + ENDDO + + IF ( config_flags%nested .or. config_flags%specified ) THEN + + IF ( jpe .eq. jde ) THEN + j = jde + DO i = max(ids,ips),min(ide-1,ipe) + muvt_2(i,j) = (grid%em_mub(i,j-1) + grid%em_mu_2(i,j-1))/grid%msfv(i,j) + ENDDO + ENDIF + IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN + i = ide + DO j = max(jds,jps),min(jde-1,jpe) + muut_2(i,j) = (grid%em_mub(i-1,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j) + ENDDO + ENDIF + + ELSE + + IF ( jpe .eq. jde ) THEN + j = jde + DO i = max(ids,ips),min(ide-1,ipe) + muvt_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1))/grid%msfv(i,j) + ENDDO + ENDIF + IF ( ipe .eq. ide ) THEN + i = ide + DO j = max(jds,jps),min(jde-1,jpe) + muut_2(i,j) = 0.5*(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j))/grid%msfu(i,j) + ENDDO + ENDIF + + END IF + + ELSE + +! write(6,*) ' uncoupling: setting mu arrays ' + + DO j = max(jds,jps),min(jde-1,jpe) + DO i = max(ids,ips),min(ide-1,ipe) + mut_2(i,j) = 1./(grid%em_mub(i,j) + grid%em_mu_2(i,j)) + muwt_2(i,j) = grid%msft(i,j)/(grid%em_mub(i,j) + grid%em_mu_2(i,j)) + ENDDO + ENDDO + +! write(6,*) ' uncoupling: setting muv arrays ' + + DO j = max(jds,jps),min(jde-1,jpe) + DO i = max(ids,ips),min(ide-1,ipe) + muut_2(i,j) = 2.*grid%msfu(i,j)/(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j)) + ENDDO + ENDDO + + DO j = max(jds,jps),min(jde-1,jpe) + DO i = max(ids,ips),min(ide-1,ipe) + muvt_2(i,j) = 2.*grid%msfv(i,j)/(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1)) + ENDDO + ENDDO + + IF ( config_flags%nested .or. config_flags%specified ) THEN + + IF ( jpe .eq. jde ) THEN + j = jde + DO i = max(ids,ips),min(ide-1,ipe) + muvt_2(i,j) = grid%msfv(i,j)/(grid%em_mub(i,j-1) + grid%em_mu_2(i,j-1)) + ENDDO + ENDIF + IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN + i = ide + DO j = max(jds,jps),min(jde-1,jpe) + muut_2(i,j) = grid%msfu(i,j)/(grid%em_mub(i-1,j) + grid%em_mu_2(i-1,j)) + ENDDO + ENDIF + + ELSE + + IF ( jpe .eq. jde ) THEN + j = jde + DO i = max(ids,ips),min(ide-1,ipe) + muvt_2(i,j) = 2.*grid%msfv(i,j)/(grid%em_mub(i,j)+grid%em_mub(i,j-1) + grid%em_mu_2(i,j) + grid%em_mu_2(i,j-1)) + ENDDO + ENDIF + IF ( ipe .eq. ide ) THEN + i = ide + DO j = max(jds,jps),min(jde-1,jpe) + muut_2(i,j) = 2.*grid%msfu(i,j)/(grid%em_mub(i,j)+grid%em_mub(i-1,j) + grid%em_mu_2(i,j) + grid%em_mu_2(i-1,j)) + ENDDO + ENDIF + + END IF + + END IF + + ! couple/uncouple mu point variables + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k,im ) + DO j = max(jds,jps),min(jde-1,jpe) + + DO k = kps,kpe + DO i = max(ids,ips),min(ide-1,ipe) + grid%em_ph_2(i,k,j) = grid%em_ph_2(i,k,j)*mut_2(i,j) + grid%em_w_2(i,k,j) = grid%em_w_2(i,k,j)*muwt_2(i,j) + ENDDO + ENDDO + + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + grid%em_t_2(i,k,j) = grid%em_t_2(i,k,j)*mut_2(i,j) + ENDDO + ENDDO + + IF (num_3d_m >= PARAM_FIRST_SCALAR ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + moist(i,k,j,im) = moist(i,k,j,im)*mut_2(i,j) + ENDDO + ENDDO + ENDDO + END IF + + IF (num_3d_c >= PARAM_FIRST_SCALAR ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_c + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + chem(i,k,j,im) = chem(i,k,j,im)*mut_2(i,j) + ENDDO + ENDDO + ENDDO + END IF + + IF (num_3d_s >= PARAM_FIRST_SCALAR ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_s + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + scalar(i,k,j,im) = scalar(i,k,j,im)*mut_2(i,j) + ENDDO + ENDDO + ENDDO + END IF + +! do u and v + + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide,ipe) + grid%em_u_2(i,k,j) = grid%em_u_2(i,k,j)*muut_2(i,j) + ENDDO + ENDDO + + ENDDO ! j loop + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k ) + DO j = max(jds,jps),min(jde,jpe) + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + grid%em_v_2(i,k,j) = grid%em_v_2(i,k,j)*muvt_2(i,j) + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN + CALL set_physical_bc3d( grid%em_ph_1, 'w', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_ph_2, 'w', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_w_1, 'w', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_w_2, 'w', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_t_1, 't', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_t_2, 't', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_u_1, 'u', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_u_2, 'u', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_v_1, 'v', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + CALL set_physical_bc3d( grid%em_v_2, 'v', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + + IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN + DO im = PARAM_FIRST_SCALAR , num_3d_m + + CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + ENDDO + ENDIF + + + IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN + DO im = PARAM_FIRST_SCALAR , num_3d_c + + CALL set_physical_bc3d( chem(ims,kms,jms,im), 'p', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + ENDDO + ENDIF + + IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN + DO im = PARAM_FIRST_SCALAR , num_3d_s + + CALL set_physical_bc3d( scalar(ims,kms,jms,im), 'p', & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + ips,ipe, jps,jpe, kps,kpe ) + ENDDO + ENDIF + + ENDIF + +#ifdef DM_PARALLEL +# include "HALO_EM_COUPLE_B.inc" +# include "PERIOD_EM_COUPLE_B.inc" +#endif + +END SUBROUTINE couple_or_uncouple_em + +LOGICAL FUNCTION em_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag ) + USE module_configure + IMPLICIT NONE + INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save + LOGICAL, INTENT(IN) :: xstag, ystag + + INTEGER ioff, joff, spec_zone + + CALL nl_get_spec_zone( 1, spec_zone ) + ioff = 0 ; joff = 0 + IF ( xstag ) ioff = 1 + IF ( ystag ) joff = 1 + + em_cd_feedback_mask = ( pig .ge. ips_save+spec_zone .and. & + pjg .ge. jps_save+spec_zone .and. & + pig .le. ipe_save-spec_zone +ioff .and. & + pjg .le. jpe_save-spec_zone +joff ) + + +END FUNCTION em_cd_feedback_mask + diff --git a/wrfv2_fire/dyn_em/init_modules_em.F b/wrfv2_fire/dyn_em/init_modules_em.F new file mode 100644 index 00000000..dc9da055 --- /dev/null +++ b/wrfv2_fire/dyn_em/init_modules_em.F @@ -0,0 +1,5 @@ +!WRF:MEDIATION_LAYER +! +SUBROUTINE init_modules_em +END SUBROUTINE init_modules_em + diff --git a/wrfv2_fire/dyn_em/interp_domain_em.F b/wrfv2_fire/dyn_em/interp_domain_em.F new file mode 100644 index 00000000..3e3cad6d --- /dev/null +++ b/wrfv2_fire/dyn_em/interp_domain_em.F @@ -0,0 +1,59 @@ +#ifdef DM_PARALLEL + +subroutine dummy_interp_em +! these routines will be provided the module_dm from the appropriate external package +! this dummy routine is just here for compilers that complain if they do not see +! some fortran +end + +#else + +! Note: since nesting is not supported single-processor except with +! the non-MPI configurations using RSL, this is basically dead-code. +! Needs to be here for linking purposes only. + +SUBROUTINE interp_domain_em_part1 ( grid, ngrid, config_flags & +! +#include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid , ngrid +#include + + INTEGER nlev + INTEGER i,j,pig,pjg,cm,cn,nig,njg,k + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe + INTEGER :: nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe + + CALL get_ijk_from_grid ( grid , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL get_ijk_from_grid ( ngrid , & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe ) + + nlev = ckde - ckds + 1 + + ! code here to interpolate the data into the nested domain +# include "em_nest_interpdown_interp.inc" + + RETURN + +END SUBROUTINE interp_domain_em_part1 + +! Stub ... not used in serial code +SUBROUTINE interp_domain_em_part2 +END SUBROUTINE interp_domain_em_part2 + +#endif + + diff --git a/wrfv2_fire/dyn_em/module_advect_em.F b/wrfv2_fire/dyn_em/module_advect_em.F new file mode 100644 index 00000000..f1261e59 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_advect_em.F @@ -0,0 +1,7056 @@ +!WRF:MODEL_LAYER:DYNAMICS +! +MODULE module_advect_em + + USE module_bc + USE module_model_constants + USE module_wrf_error + +CONTAINS + + +SUBROUTINE mass_flux_divergence ( field, field_old, tendency, & + ru, rv, rom, & + mut, config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + field_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: imin, imax, jmin, jmax + + REAL :: mrdx, mrdy, ub, vb, uw, vw + REAL , DIMENSION(its:ite,kts:kte) :: vflux + + LOGICAL :: specified + +!--------------- horizontal flux + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & + *(ru(i+1,k,j)*(field(i+1,k,j)+field(i ,k,j)) & + -ru(i ,k,j)*(field(i ,k,j)+field(i-1,k,j))) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + mrdy=msft(i,j)*rdy + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & + *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j )) & + -rv(i,k,j )*(field(i,k,j )+field(i,k,j-1))) + ENDDO + ENDDO + ENDDO + +!---------------- vertical flux divergence + + + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO + + DO j = j_start, j_end + + DO k = kts+1, ktf + DO i = i_start, i_end + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + ENDDO + + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + +END SUBROUTINE mass_flux_divergence + +!------------------------------------------------------------------------------- + +SUBROUTINE advect_u ( u, u_old, tendency, & + ru, rv, rom, & + mut, config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, & + u_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip + INTEGER :: jp1, jp0, jtmp + + INTEGER :: horz_order, vert_order + + REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp + REAL , DIMENSION(its:ite, kts:kte) :: vflux + + + REAL, DIMENSION( its-1:ite+1, kts:kte ) :: fqx + REAL, DIMENSION( its:ite, kts:kte, 2) :: fqy + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye + +! definition of flux operators, 3rd, 4th, 5th or 6th order + + REAL :: flux3, flux4, flux5, flux6 + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & + +(q_ip2+q_im3) )/60.0 + + flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & + -sign(1.,ua)*( & + (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 + + + LOGICAL :: specified + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + +! set order for vertical and horzontal flux operators + + horz_order = config_flags%h_mom_adv_order + vert_order = config_flags%v_mom_adv_order + + ktf=MIN(kte,kde-1) + +! begin with horizontal flux divergence + + horizontal_order_test : IF( horz_order == 6 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_6 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux6( & + u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & + u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) + ENDDO + ENDDO + +! we must be close to some boundary where we need to reduce the order of the stencil + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & + *(u(i,k,j)+u(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux4( & + u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel ) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & + *(u(i,k,j)+u(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux4( & + u(i,k,j-2),u(i,k,j-1), & + u(i,k,j),u(i,k,j+1),vel ) + ENDDO + ENDDO + + END IF + +!stopped + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfu(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_6 + +! next, x - flux divergence + + i_start = its + i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = ids+3 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-1,ite) + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j), & + u(i-1,k,j), u(i ,k,j), & + u(i+1,k,j), u(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) +! specified uses upstream normal wind at boundaries + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + ub = u(i-1,k,j) + IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i,k,j)+ub) + ENDDO + END IF + + i = ids+2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-1 ) THEN ! second order flux next to the boundary + i = ide + DO k=kts,ktf + ub = u(i,k,j) + IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i-1,k,j)+ub) + ENDDO + ENDIF + + DO k=kts,ktf + i = ide-1 + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfu(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 5 ) THEN + +! 5th order horizontal flux calculation +! This code is EXACTLY the same as the 6th order code +! EXCEPT the 5th order and 3rd operators are used in +! place of the 6th and 4th order operators + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_5 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux5( & + u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & + u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) + ENDDO + ENDDO + +! we must be close to some boundary where we need to reduce the order of the stencil + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & + *(u(i,k,j)+u(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux3( & + u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel ) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j)) & + *(u(i,k,j)+u(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux3( & + u(i,k,j-2),u(i,k,j-1), & + u(i,k,j),u(i,k,j+1),vel ) + ENDDO + ENDDO + + END IF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfu(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_5 + +! next, x - flux divergence + + i_start = its + i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = ids+3 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-1,ite) + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), & + u(i-1,k,j), u(i ,k,j), & + u(i+1,k,j), u(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) +! specified uses upstream normal wind at boundaries + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + ub = u(i-1,k,j) + IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i,k,j)+ub) + ENDDO + END IF + + i = ids+2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-1 ) THEN ! second order flux next to the boundary + i = ide + DO k=kts,ktf + ub = u(i,k,j) + IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i-1,k,j)+ub) + ENDDO + ENDIF + + DO k=kts,ktf + i = ide-1 + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfu(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 4 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-1) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- x - advection first + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-1 + i_end_f = ide-1 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), vel ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) +! specified uses upstream normal wind at boundaries + + IF( degrade_xs ) THEN + i = i_start + DO k=kts,ktf + ub = u(i-1,k,j) + IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i,k,j)+ub) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + i = i_end+1 + DO k=kts,ktf + ub = u(i,k,j) + IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i-1,k,j)+ub) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfu(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + +! y flux divergence + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + +!CJM these may not work with tiling because they define j_start and end in terms of domain dim + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + +! j flux loop for v flux of u momentum + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ( (j < j_start_f) .and. degrade_ys) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) & + *(u(i,k,j_start)+u(i,k,j_start-1)) + ENDDO + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) & + *(u(i,k,j_end+1)+u(i,k,j_end)) + ENDDO + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts, ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1), & + u(i,k,j ), u(i,k,j+1), & + vel ) + ENDDO + ENDDO + + END IF + + IF (j > j_start) THEN + +! y flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfu(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + + ELSE IF ( horz_order == 3 ) THEN + +! As with the 5th and 6th order flux chioces, the 3rd and 4th order +! code is EXACTLY the same EXCEPT for the flux operator. + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-1) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- x - advection first + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-1 + i_end_f = ide-1 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) + fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j), & + u(i ,k,j), u(i+1,k,j), vel ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) +! specified uses upstream normal wind at boundaries + + IF( degrade_xs ) THEN + i = i_start + DO k=kts,ktf + ub = u(i-1,k,j) + IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i,k,j)+ub) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + i = i_end+1 + DO k=kts,ktf + ub = u(i,k,j) + IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j) + fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) & + *(u(i-1,k,j)+ub) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfu(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + ENDDO + +! y flux divergence + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + +!CJM these may not work with tiling because they define j_start and end in terms of domain dim + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + +! j flux loop for v flux of u momentum + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ( (j < j_start_f) .and. degrade_ys) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start)) & + *(u(i,k,j_start)+u(i,k,j_start-1)) + ENDDO + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) & + *(u(i,k,j_end+1)+u(i,k,j_end)) + ENDDO + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts, ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) + fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1), & + u(i,k,j ), u(i,k,j+1), & + vel ) + ENDDO + ENDDO + + END IF + + IF (j > j_start) THEN + +! y flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfu(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + + ELSE IF ( horz_order == 2 ) THEN + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) + IF ( specified ) i_start = MAX(ids+2,its) + IF ( specified ) i_end = MIN(ide-2,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfu(i,j)*rdx + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & + *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) & + -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j))) + ENDDO + ENDDO + ENDDO + + IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN + DO j = j_start, j_end + DO k=kts,ktf + i = ids+1 + mrdx=msfu(i,j)*rdx + ub = u(i-1,k,j) + IF (u(i,k,j) .LT. 0.) ub = u(i,k,j) + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & + *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) & + -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub)) + ENDDO + ENDDO + ENDIF + IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN + DO j = j_start, j_end + DO k=kts,ktf + i = ide-1 + mrdx=msfu(i,j)*rdx + ub = u(i+1,k,j) + IF (u(i,k,j) .GT. 0.) ub = u(i,k,j) + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & + *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) & + -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j))) + ENDDO + ENDDO + ENDIF + + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfu(i,j)*rdy + tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 & + *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) & + -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))) + ENDDO + ENDDO + ENDDO + + ELSE + + WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: h_order not known ',horz_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF horizontal_order_test + +! radiative lateral boundary condition in x for normal velocity (u) + + IF ( (config_flags%open_xs) .and. its == ids ) THEN + + j_start = jts + j_end = MIN(jte,jde-1) + + DO j = j_start, j_end + DO k = kts, ktf + ub = MIN(ru(its,k,j)-cb*mut(its,j), 0.) + tendency(its,k,j) = tendency(its,k,j) & + - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j)) + ENDDO + ENDDO + + ENDIF + + IF ( (config_flags%open_xe) .and. ite == ide ) THEN + + j_start = jts + j_end = MIN(jte,jde-1) + + DO j = j_start, j_end + DO k = kts, ktf + ub = MAX(ru(ite,k,j)+cb*mut(ite-1,j), 0.) + tendency(ite,k,j) = tendency(ite,k,j) & + - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j)) + ENDDO + ENDDO + + ENDIF + +! pick up the rest of the horizontal radiation boundary conditions. +! (these are the computations that don't require 'cb') +! first, set to index ranges + + i_start = its + i_end = MIN(ite,ide) + imin = ids + imax = ide-1 + + IF (config_flags%open_xs) THEN + i_start = MAX(ids+1, its) + imin = ids + ENDIF + IF (config_flags%open_xe) THEN + i_end = MIN(ite,ide-1) + imax = ide-1 + ENDIF + + IF( (config_flags%open_ys) .and. (jts == jds)) THEN + + DO i = i_start, i_end + + mrdy=msfu(i,jts)*rdy + ip = MIN( imax, i ) + im = MAX( imin, i-1 ) + + DO k=kts,ktf + + vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts)) + vb = MIN( vw, 0. ) + dvm = rv(ip,k,jts+1)-rv(ip,k,jts) + dvp = rv(im,k,jts+1)-rv(im,k,jts) + tendency(i,k,jts)=tendency(i,k,jts)-mrdy*( & + vb*(u_old(i,k,jts+1)-u_old(i,k,jts)) & + +0.5*u(i,k,jts)*(dvm+dvp)) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_ye) .and. (jte == jde)) THEN + + DO i = i_start, i_end + + mrdy=msfu(i,jte-1)*rdy + ip = MIN( imax, i ) + im = MAX( imin, i-1 ) + + DO k=kts,ktf + + vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte)) + vb = MAX( vw, 0. ) + dvm = rv(ip,k,jte)-rv(ip,k,jte-1) + dvp = rv(im,k,jte)-rv(im,k,jte-1) + tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*( & + vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2)) & + +0.5*u(i,k,jte-1)*(dvm+dvp)) + ENDDO + ENDDO + + ENDIF + +!-------------------- vertical advection + + i_start = its + i_end = ite + j_start = jts + j_end = min(jte,jde-1) + +! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) +! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) + + IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_ye .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO + + vert_order_test : IF (vert_order == 6) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) + vflux(i,k) = vel*flux6( & + u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) + vflux(i,k) = vel*flux4( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + k = ktf-1 + vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) + vflux(i,k) = vel*flux4( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + + ENDDO + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + ENDDO + + ELSE IF (vert_order == 5) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) + vflux(i,k) = vel*flux5( & + u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) + vflux(i,k) = vel*flux3( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + k = ktf-1 + vel=0.5*(rom(i,k,j)+rom(i-1,k,j)) + vflux(i,k) = vel*flux3( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + + ENDDO + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + ENDDO + + ELSE IF (vert_order == 4) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) + vflux(i,k) = vel*flux4( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + + ENDDO + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + ENDDO + + ELSE IF (vert_order == 3) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) + vflux(i,k) = vel*flux3( & + u(i,k-2,j), u(i,k-1,j), & + u(i,k ,j), u(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + + ENDDO + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + ENDDO + + ELSE IF (vert_order == 2) THEN + + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) & + *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j)) + ENDDO + ENDDO + + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE + + WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF vert_order_test + +END SUBROUTINE advect_u + +!------------------------------------------------------------------------------- + +SUBROUTINE advect_v ( v, v_old, tendency, & + ru, rv, rom, & + mut, config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: v, & + v_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax + + REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum + REAL , DIMENSION(its:ite, kts:kte) :: vflux + + + REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx + REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy + + INTEGER :: horz_order + INTEGER :: vert_order + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye + + INTEGER :: jp1, jp0, jtmp + + +! definition of flux operators, 3rd, 4th, 5th or 6th order + + REAL :: flux3, flux4, flux5, flux6 + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & + +(q_ip2+q_im3) )/60.0 + + flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & + -sign(1.,ua)*( & + (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 + + + + LOGICAL :: specified + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + +! set order for the advection schemes + + ktf=MIN(kte,kde-1) + horz_order = config_flags%h_mom_adv_order + vert_order = config_flags%v_mom_adv_order + + +! here is the choice of flux operators + + + horizontal_order_test : IF( horz_order == 6 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- y - advection first + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-1) + j_end_f = jde-2 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_6 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux6( & + v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & + v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) + ENDDO + ENDDO + +! we must be close to some boundary where we need to reduce the order of the stencil +! specified uses upstream normal wind at boundaries + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vb = v(i,k,j-1) + IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(v(i,k,j)+vb) + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux4( & + v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) + ENDDO + ENDDO + + + ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vb = v(i,k,j) + IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(vb+v(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux4( & + v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) + ENDDO + ENDDO + + END IF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfv(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_6 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = jte + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j), & + v(i-1,k,j), v(i ,k,j), & + v(i+1,k,j), v(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) & + *(v(i,k,j)+v(i-1,k,j)) + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & + *(v(i_end+1,k,j)+v(i_end,k,j)) + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfv(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 5 ) THEN + +! 5th order horizontal flux calculation +! This code is EXACTLY the same as the 6th order code +! EXCEPT the 5th order and 3rd operators are used in +! place of the 6th and 4th order operators + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- y - advection first + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-1) + j_end_f = jde-2 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_5 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux5( & + v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & + v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) + ENDDO + ENDDO + +! we must be close to some boundary where we need to reduce the order of the stencil +! specified uses upstream normal wind at boundaries + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vb = v(i,k,j-1) + IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(v(i,k,j)+vb) + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux3( & + v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) + ENDDO + ENDDO + + + ELSE IF ( j == jde ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vb = v(i,k,j) + IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(vb+v(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i, k, jp1 ) = vel*flux3( & + v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel ) + ENDDO + ENDDO + + END IF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfv(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_5 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = jte + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), & + v(i-1,k,j), v(i ,k,j), & + v(i+1,k,j), v(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) & + *(v(i,k,j)+v(i-1,k,j)) + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & + *(v(i_end+1,k,j)+v(i_end,k,j)) + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfv(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 4 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-1) ) degrade_ye = .false. + +!--------------- y - advection first + + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + +!CJM May not work with tiling because defined in terms of domain dims + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-1 + j_end_f = jde-1 + ENDIF + +! compute fluxes +! specified uses upstream normal wind at boundaries + + jp0 = 1 + jp1 = 2 + + DO j = j_start, j_end+1 + + IF ((j == j_start) .and. degrade_ys) THEN + DO k = kts,ktf + DO i = i_start, i_end + vb = v(i,k,j-1) + IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(v(i,k,j)+vb) + ENDDO + ENDDO + ELSE IF ((j == j_end+1) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + vb = v(i,k,j) + IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(vb+v(i,k,j-1)) + ENDDO + ENDDO + ELSE + DO k = kts, ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1), & + v(i,k,j ), v(i,k,j+1), & + vel ) + ENDDO + ENDDO + END IF + + IF( j > j_start) THEN + DO k = kts, ktf + DO i = i_start, i_end + mrdy=msfv(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + +! next, x - flux divergence + + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = jte + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 3rd or 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts,ktf + fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) & + *(v(i_start,k,j)+v(i_start-1,k,j)) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + DO k=kts,ktf + fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & + *(v(i_end+1,k,j)+v(i_end,k,j)) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfv(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 3 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-1) ) degrade_ye = .false. + +!--------------- y - advection first + + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + +!CJM May not work with tiling because defined in terms of domain dims + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-1 + j_end_f = jde-1 + ENDIF + +! compute fluxes +! specified uses upstream normal wind at boundaries + + jp0 = 1 + jp1 = 2 + + DO j = j_start, j_end+1 + + IF ((j == j_start) .and. degrade_ys) THEN + DO k = kts,ktf + DO i = i_start, i_end + vb = v(i,k,j-1) + IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(v(i,k,j)+vb) + ENDDO + ENDDO + ELSE IF ((j == j_end+1) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + vb = v(i,k,j) + IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1) + fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1)) & + *(vb+v(i,k,j-1)) + ENDDO + ENDDO + ELSE + DO k = kts, ktf + DO i = i_start, i_end + vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) + fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1), & + v(i,k,j ), v(i,k,j+1), & + vel ) + ENDDO + ENDDO + END IF + + IF( j > j_start) THEN + DO k = kts, ktf + DO i = i_start, i_end + mrdy=msfv(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + +! next, x - flux divergence + + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = jte + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 3rd or 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) + fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j), & + v(i ,k,j), v(i+1,k,j), & + vel ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts,ktf + fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) & + *(v(i_start,k,j)+v(i_start-1,k,j)) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + DO k=kts,ktf + fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1)) & + *(v(i_end+1,k,j)+v(i_end,k,j)) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfv(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 2 ) THEN + + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + + IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye ) j_end = MIN(jde-1,jte) + IF ( specified ) j_start = MAX(jds+2,jts) + IF ( specified ) j_end = MIN(jde-2,jte) + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mrdy=msfv(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & + *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) & + -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1))) + + ENDDO + ENDDO + ENDDO +! specified uses upstream normal wind at boundaries + + IF ( specified .AND. jts .LE. jds+1 ) THEN + j = jds+1 + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfv(i,j)*rdy + vb = v(i,k,j-1) + IF (v(i,k,j) .LT. 0.) vb = v(i,k,j) + + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & + *((rv(i,k,j+1)+rv(i,k,j ))*(v(i,k,j+1)+v(i,k,j )) & + -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+vb)) + + ENDDO + ENDDO + ENDIF + + IF ( specified .AND. jte .GE. jde-1 ) THEN + j = jde-1 + DO k=kts,ktf + DO i = i_start, i_end + + mrdy=msfv(i,j)*rdy + vb = v(i,k,j+1) + IF (v(i,k,j) .GT. 0.) vb = v(i,k,j) + + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 & + *((rv(i,k,j+1)+rv(i,k,j ))*(vb+v(i,k,j )) & + -(rv(i,k,j )+rv(i,k,j-1))*(v(i,k,j )+v(i,k,j-1))) + + ENDDO + ENDDO + ENDIF + + IF ( .NOT. config_flags%periodic_x ) THEN + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + ENDIF + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mrdx=msfv(i,j)*rdx + + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 & + *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i ,k,j)) & + -(ru(i ,k,j)+ru(i ,k,j-1))*(v(i ,k,j)+v(i-1,k,j))) + + ENDDO + ENDDO + ENDDO + + ELSE + + + WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF horizontal_order_test + +! radiative lateral boundary condition in y for normal velocity (v) + + IF ( (config_flags%open_ys) .and. jts == jds ) THEN + + i_start = its + i_end = MIN(ite,ide-1) + + DO i = i_start, i_end + DO k = kts, ktf + vb = MIN(rv(i,k,jts)-cb*mut(i,jts), 0.) + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts)) + ENDDO + ENDDO + + ENDIF + + IF ( (config_flags%open_ye) .and. jte == jde ) THEN + + i_start = its + i_end = MIN(ite,ide-1) + + DO i = i_start, i_end + DO k = kts, ktf + vb = MAX(rv(i,k,jte)+cb*mut(i,jte-1), 0.) + tendency(i,k,jte) = tendency(i,k,jte) & + - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1)) + ENDDO + ENDDO + + ENDIF + +! pick up the rest of the horizontal radiation boundary conditions. +! (these are the computations that don't require 'cb'. +! first, set to index ranges + + j_start = jts + j_end = MIN(jte,jde) + + jmin = jds + jmax = jde-1 + + IF (config_flags%open_ys) THEN + j_start = MAX(jds+1, jts) + jmin = jds + ENDIF + IF (config_flags%open_ye) THEN + j_end = MIN(jte,jde-1) + jmax = jde-1 + ENDIF + +! compute x (u) conditions for v, w, or scalar + + IF( (config_flags%open_xs) .and. (its == ids)) THEN + + DO j = j_start, j_end + + mrdx=msfv(its,j)*rdx + jp = MIN( jmax, j ) + jm = MAX( jmin, j-1 ) + + DO k=kts,ktf + + uw = 0.5*(ru(its,k,jp)+ru(its,k,jm)) + ub = MIN( uw, 0. ) + dup = ru(its+1,k,jp)-ru(its,k,jp) + dum = ru(its+1,k,jm)-ru(its,k,jm) + tendency(its,k,j)=tendency(its,k,j)-mrdx*( & + ub*(v_old(its+1,k,j)-v_old(its,k,j)) & + +0.5*v(its,k,j)*(dup+dum)) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_xe) .and. (ite == ide) ) THEN + DO j = j_start, j_end + + mrdx=msfv(ite-1,j)*rdx + jp = MIN( jmax, j ) + jm = MAX( jmin, j-1 ) + + DO k=kts,ktf + + uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm)) + ub = MAX( uw, 0. ) + dup = ru(ite,k,jp)-ru(ite-1,k,jp) + dum = ru(ite,k,jm)-ru(ite-1,k,jm) + +! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & +! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & +! +0.5*v(ite-1,k,j)* & +! ( ru(ite,k,jp)-ru(ite-1,k,jp) & +! +ru(ite,k,jm)-ru(ite-1,k,jm)) ) + tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( & + ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) & + +0.5*v(ite-1,k,j)*(dup+dum)) + + ENDDO + ENDDO + + ENDIF + +!-------------------- vertical advection + + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO + + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + + vert_order_test : IF (vert_order == 6) THEN + + DO j = j_start, j_end + + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux6( & + v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux4( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + k = ktf-1 + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux4( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + + ENDDO + + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 5) THEN + + DO j = j_start, j_end + + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux5( & + v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux3( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + k = ktf-1 + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux3( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + + ENDDO + + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 4) THEN + + DO j = j_start, j_end + + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux4( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + + ENDDO + + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 3) THEN + + DO j = j_start, j_end + + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) + vflux(i,k) = vel*flux3( & + v(i,k-2,j), v(i,k-1,j), & + v(i,k ,j), v(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + k=kts+1 + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + k=ktf + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + + ENDDO + + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + + ELSE IF (vert_order == 2) THEN + + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + + vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) & + *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j)) + ENDDO + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + + ENDDO + ENDDO + ENDDO + + ELSE + + WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF vert_order_test + +END SUBROUTINE advect_v + +!------------------------------------------------------------------- + +SUBROUTINE advect_scalar ( field, field_old, tendency, & + ru, rv, rom, & + mut, config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + field_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax + + REAL :: mrdx, mrdy, ub, vb, uw, vw + REAL , DIMENSION(its:ite, kts:kte) :: vflux + + + REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx + REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy + + INTEGER :: horz_order, vert_order + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye + + INTEGER :: jp1, jp0, jtmp + + +! definition of flux operators, 3rd, 4th, 5th or 6th order + + REAL :: flux3, flux4, flux5, flux6 + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & + +(q_ip2+q_im3) )/60.0 + + flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & + -sign(1.,ua)*( & + (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 + + + LOGICAL :: specified + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + +! set order for the advection schemes + + ktf=MIN(kte,kde-1) + horz_order = config_flags%h_sca_adv_order + vert_order = config_flags%v_sca_adv_order + +! begin with horizontal flux divergence +! here is the choice of flux operators + + + horizontal_order_test : IF( horz_order == 6 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + ktf=MIN(kte,kde-1) + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_6 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1 ) = vel*flux6( & + field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i,k, jp1) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1 ) = vel*flux4( & + field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1) = vel*flux4( & + field(i,k,j-2),field(i,k,j-1), & + field(i,k,j),field(i,k,j+1),vel ) + ENDDO + ENDDO + + ENDIF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_6 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = ru(i,k,j) + fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), & + field(i-1,k,j), field(i ,k,j), & + field(i+1,k,j), field(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + fqx(i,k) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + vel = ru(i,k,j) + fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + fqx(i,k) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + vel = ru(i,k,j) + fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF( horz_order == 5 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + ktf=MIN(kte,kde-1) + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_5 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1 ) = vel*flux5( & + field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i,k, jp1) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1 ) = vel*flux3( & + field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + vel = rv(i,k,j) + fqy( i, k, jp1) = vel*flux3( & + field(i,k,j-2),field(i,k,j-1), & + field(i,k,j),field(i,k,j+1),vel ) + ENDDO + ENDDO + + ENDIF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_5 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + vel = ru(i,k,j) + fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & + field(i-1,k,j), field(i ,k,j), & + field(i+1,k,j), field(i+2,k,j), & + vel ) + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + fqx(i,k) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + vel = ru(i,k,j) + fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + fqx(i,k) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + vel = ru(i,k,j) + fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + ENDDO + + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + + ELSE IF( horz_order == 4 ) THEN + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +! begin flux computations +! start with x flux divergence + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 3rd or 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + ru(i,k,j) ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts,ktf + fqx(i_start, k) = 0.5*ru(i_start,k,j) & + *(field(i_start,k,j)+field(i_start-1,k,j)) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + DO k=kts,ktf + fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) & + *(field(i_end+1,k,j)+field(i_end,k,j)) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + +! next -> y flux divergence calculation + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ((j < j_start_f) .and. degrade_ys) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i,k,jp1) = 0.5*rv(i,k,j_start) & + *(field(i,k,j_start)+field(i,k,j_start-1)) + ENDDO + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) & + *(field(i,k,j_end+1)+field(i,k,j_end)) + ENDDO + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts, ktf + DO i = i_start, i_end + fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), & + rv(i,k,j) ) + ENDDO + ENDDO + END IF + + IF ( j > j_start ) THEN +! y flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + + + ELSE IF( horz_order == 3 ) THEN + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +! begin flux computations +! start with x flux divergence + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 3rd or 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + ru(i,k,j) ) + ENDDO + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts,ktf + fqx(i_start, k) = 0.5*ru(i_start,k,j) & + *(field(i_start,k,j)+field(i_start-1,k,j)) + ENDDO + ENDIF + + IF( degrade_xe ) THEN + DO k=kts,ktf + fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j) & + *(field(i_end+1,k,j)+field(i_end,k,j)) + ENDDO + ENDIF + +! x flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + +! next -> y flux divergence calculation + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ((j < j_start_f) .and. degrade_ys) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i,k,jp1) = 0.5*rv(i,k,j_start) & + *(field(i,k,j_start)+field(i,k,j_start-1)) + ENDDO + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts, ktf + DO i = i_start, i_end + fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) & + *(field(i,k,j_end+1)+field(i,k,j_end)) + ENDDO + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts, ktf + DO i = i_start, i_end + fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), & + rv(i,k,j) ) + ENDDO + ENDDO + END IF + + IF ( j > j_start ) THEN +! y flux-divergence into tendency + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + + ELSE IF( horz_order == 2 ) THEN + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( .NOT. config_flags%periodic_x ) THEN + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + ENDIF + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & + *(ru(i+1,k,j)*(field(i+1,k,j)+field(i ,k,j)) & + -ru(i ,k,j)*(field(i ,k,j)+field(i-1,k,j))) + ENDDO + ENDDO + ENDDO + + i_start = its + i_end = MIN(ite,ide-1) + + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + mrdy=msft(i,j)*rdy + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & + *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j )) & + -rv(i,k,j )*(field(i,k,j )+field(i,k,j-1))) + ENDDO + ENDDO + ENDDO + + ELSE + + WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF horizontal_order_test + +! pick up the rest of the horizontal radiation boundary conditions. +! (these are the computations that don't require 'cb'. +! first, set to index ranges + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! compute x (u) conditions for v, w, or scalar + + IF( (config_flags%open_xs) .and. (its == ids) ) THEN + + DO j = j_start, j_end + DO k = kts, ktf + ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) + tendency(its,k,j) = tendency(its,k,j) & + - rdx*( & + ub*( field_old(its+1,k,j) & + - field_old(its ,k,j) ) + & + field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_xe) .and. (ite == ide) ) THEN + + DO j = j_start, j_end + DO k = kts, ktf + ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) + tendency(i_end,k,j) = tendency(i_end,k,j) & + - rdx*( & + ub*( field_old(i_end ,k,j) & + - field_old(i_end-1,k,j) ) + & + field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_ys) .and. (jts == jds) ) THEN + + DO i = i_start, i_end + DO k = kts, ktf + vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*( & + vb*( field_old(i,k,jts+1) & + - field_old(i,k,jts ) ) + & + field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_ye) .and. (jte == jde)) THEN + + DO i = i_start, i_end + DO k = kts, ktf + vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) + tendency(i,k,j_end) = tendency(i,k,j_end) & + - rdy*( & + vb*( field_old(i,k,j_end ) & + - field_old(i,k,j_end-1) ) + & + field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & + ) + ENDDO + ENDDO + + ENDIF + + +!-------------------- vertical advection + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO + + vert_order_test : IF (vert_order == 6) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=rom(i,k,j) + vflux(i,k) = vel*flux6( & + field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + + k = kts+2 + vel=rom(i,k,j) + vflux(i,k) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + k = ktf-1 + vel=rom(i,k,j) + vflux(i,k) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + + k=ktf + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 5) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + vel=rom(i,k,j) + vflux(i,k) = vel*flux5( & + field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + + k = kts+2 + vel=rom(i,k,j) + vflux(i,k) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + k = ktf-1 + vel=rom(i,k,j) + vflux(i,k) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + + k=ktf + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 4) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=rom(i,k,j) + vflux(i,k) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + k=ktf + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE IF (vert_order == 3) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + vel=rom(i,k,j) + vflux(i,k) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + k=ktf + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + + ELSE IF (vert_order == 2) THEN + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + ENDDO + + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + + ENDDO + + ELSE + + WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF vert_order_test + +END SUBROUTINE advect_scalar + +!--------------------------------------------------------------------------------- + +SUBROUTINE advect_w ( w, w_old, tendency, & + ru, rv, rom, & + mut, config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzu, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: w, & + w_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzu + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax + + REAL :: mrdx, mrdy, ub, vb, uw, vw + REAL , DIMENSION(its:ite, kts:kte) :: vflux + + INTEGER :: horz_order, vert_order + + REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx + REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye + + INTEGER :: jp1, jp0, jtmp + +! definition of flux operators, 3rd, 4th, 5th or 6th order + + REAL :: flux3, flux4, flux5, flux6 + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + + flux3(q_im2, q_im1, q_i, q_ip1, ua) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2) & + +(q_ip2+q_im3) )/60.0 + + flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & + -sign(1.,ua)*( & + (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0 + + + LOGICAL :: specified + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + +! set order for the advection scheme + + ktf=MIN(kte,kde-1) + horz_order = config_flags%h_sca_adv_order + vert_order = config_flags%v_sca_adv_order + +! here is the choice of flux operators + +! begin with horizontal flux divergence + + horizontal_order_test : IF( horz_order == 6 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_6 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux6( & + w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux6( & + w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux4( & + w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux4( & + w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux4( & + w(i,k,j-2),w(i,k,j-1), & + w(i,k,j),w(i,k,j+1),vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux4( & + w(i,k,j-2),w(i,k,j-1), & + w(i,k,j),w(i,k,j+1),vel ) + ENDDO + + ENDIF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_6 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts+1,ktf + DO i = i_start_f, i_end_f + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), & + w(i-1,k,j), w(i ,k,j), & + w(i+1,k,j), w(i+2,k,j), & + vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start_f, i_end_f + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j), & + w(i-1,k,j), w(i ,k,j), & + w(i+1,k,j), w(i+2,k,j), & + vel ) + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts+1,ktf + fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDDO + k = ktf+1 + fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDIF + + DO k=kts+1,ktf + i = i_start+1 + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + + k = ktf+1 + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts+1,ktf + fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDDO + k = ktf+1 + fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDIF + + i = ide-2 + DO k=kts+1,ktf + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + + k = ktf+1 + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDIF + +! x flux-divergence into tendency + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + + +ELSE IF (horz_order == 5 ) THEN + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_5 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux5( & + w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux5( & + w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux3( & + w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux3( & + w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel ) + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* & + (w(i,k,j)+w(i,k,j-1)) + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts+1,ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux3( & + w(i,k,j-2),w(i,k,j-1), & + w(i,k,j),w(i,k,j+1),vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux3( & + w(i,k,j-2),w(i,k,j-1), & + w(i,k,j),w(i,k,j+1),vel ) + ENDDO + + ENDIF + +! y flux-divergence into tendency + + IF(j > j_start) THEN + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_5 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th or 6th order flux + + DO k=kts+1,ktf + DO i = i_start_f, i_end_f + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & + w(i-1,k,j), w(i ,k,j), & + w(i+1,k,j), w(i+2,k,j), & + vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start_f, i_end_f + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & + w(i-1,k,j), w(i ,k,j), & + w(i+1,k,j), w(i+2,k,j), & + vel ) + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts+1,ktf + fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDDO + k = ktf+1 + fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDIF + + i = i_start+1 + DO k=kts+1,ktf + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + k = ktf+1 + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts+1,ktf + fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDDO + k = ktf+1 + fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & + *(w(i,k,j)+w(i-1,k,j)) + ENDIF + + i = ide-2 + DO k=kts+1,ktf + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + k = ktf+1 + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDIF + +! x flux-divergence into tendency + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + +ELSE IF ( horz_order == 4 ) THEN + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +! begin flux computations +! start with x flux divergence + +!--------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + + DO k=kts+1,ktf + DO i = i_start_f, i_end_f + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start_f, i_end_f + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts+1,ktf + fqx(i_start, k) = & + 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) & + *(w(i_start,k,j)+w(i_start-1,k,j)) + ENDDO + k = ktf+1 + fqx(i_start, k) = & + 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) & + *(w(i_start,k,j)+w(i_start-1,k,j)) + ENDIF + + IF( degrade_xe ) THEN + DO k=kts+1,ktf + fqx(i_end+1, k) = & + 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) & + *(w(i_end+1,k,j)+w(i_end,k,j)) + ENDDO + k = ktf+1 + fqx(i_end+1, k) = & + 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) & + *(w(i_end+1,k,j)+w(i_end,k,j)) + ENDIF + +! x flux-divergence into tendency + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + +! next -> y flux divergence calculation + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ((j < j_start_f) .and. degrade_ys) THEN + DO k = kts+1, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) & + *(w(i,k,j_start)+w(i,k,j_start-1)) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) & + *(w(i,k,j_start)+w(i,k,j_start-1)) + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts+1, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) & + *(w(i,k,j_end+1)+w(i,k,j_end)) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) & + *(w(i,k,j_end+1)+w(i,k,j_end)) + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts+1, ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), & + vel ) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), & + vel ) + ENDDO + END IF + + IF( j > j_start ) THEN +! y flux-divergence into tendency + DO k = kts+1, ktf+1 + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + +ELSE IF ( horz_order == 3 ) THEN + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +! begin flux computations +! start with x flux divergence + +!--------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 + + IF(degrade_xs) then + i_start = ids+1 + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = ide-2 + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + + DO k=kts+1,ktf + DO i = i_start_f, i_end_f + vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) + fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start_f, i_end_f + vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) + fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j), & + w(i ,k,j), w(i+1,k,j), & + vel ) + ENDDO + +! second order flux close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + DO k=kts+1,ktf + fqx(i_start, k) = & + 0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j)) & + *(w(i_start,k,j)+w(i_start-1,k,j)) + ENDDO + k = ktf+1 + fqx(i_start, k) = & + 0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j)) & + *(w(i_start,k,j)+w(i_start-1,k,j)) + ENDIF + + IF( degrade_xe ) THEN + DO k=kts+1,ktf + fqx(i_end+1, k) = & + 0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j)) & + *(w(i_end+1,k,j)+w(i_end,k,j)) + ENDDO + k = ktf+1 + fqx(i_end+1, k) = & + 0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j)) & + *(w(i_end+1,k,j)+w(i_end,k,j)) + ENDIF + +! x flux-divergence into tendency + + DO k=kts+1,ktf+1 + DO i = i_start, i_end + mrdx=msft(i,j)*rdx + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + + ENDDO + +! next -> y flux divergence calculation + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + +! 3rd or 4th order flux has a 5 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 + + IF(degrade_ys) then + j_start = jds+1 + j_start_f = j_start+1 + ENDIF + + IF(degrade_ye) then + j_end = jde-2 + j_end_f = jde-2 + ENDIF + + jp1 = 2 + jp0 = 1 + + DO j = j_start, j_end+1 + + IF ((j < j_start_f) .and. degrade_ys) THEN + DO k = kts+1, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start)) & + *(w(i,k,j_start)+w(i,k,j_start-1)) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start)) & + *(w(i,k,j_start)+w(i,k,j_start-1)) + ENDDO + ELSE IF ((j > j_end_f) .and. degrade_ye) THEN + DO k = kts+1, ktf + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) & + *(w(i,k,j_end+1)+w(i,k,j_end)) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + fqy(i, k, jp1) = & + 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) & + *(w(i,k,j_end+1)+w(i,k,j_end)) + ENDDO + ELSE +! 3rd or 4th order flux + DO k = kts+1, ktf + DO i = i_start, i_end + vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) + fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), & + vel ) + ENDDO + ENDDO + k = ktf+1 + DO i = i_start, i_end + vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) + fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1), & + w(i,k,j ), w(i,k,j+1), & + vel ) + ENDDO + END IF + + IF( j > j_start ) THEN +! y flux-divergence into tendency + DO k = kts+1, ktf+1 + DO i = i_start, i_end + mrdy=msft(i,j-1)*rdy + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + END IF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO + +ELSE IF (horz_order == 2 ) THEN + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( .NOT. config_flags%periodic_x ) THEN + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + ENDIF + + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + + mrdx=msft(i,j)*rdx + + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & + *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j)) & + *(w(i+1,k,j)+w(i,k,j)) & + -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) & + *(w(i,k,j)+w(i-1,k,j))) + + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + + mrdx=msft(i,j)*rdx + + tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 & + *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j)) & + *(w(i+1,k,j)+w(i,k,j)) & + -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) & + *(w(i,k,j)+w(i-1,k,j))) + + ENDDO + + ENDDO + + i_start = its + i_end = MIN(ite,ide-1) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & + *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* & + (w(i,k,j+1)+w(i,k,j)) & + -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)) & + *(w(i,k,j)+w(i,k,j-1))) + + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 & + *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* & + (w(i,k,j+1)+w(i,k,j)) & + -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)) & + *(w(i,k,j)+w(i,k,j-1))) + + ENDDO + + ENDDO + + ELSE + + WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF horizontal_order_test + + +! pick up the the horizontal radiation boundary conditions. +! (these are the computations that don't require 'cb'. +! first, set to index ranges + + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF( (config_flags%open_xs) .and. (its == ids)) THEN + + DO j = j_start, j_end + DO k = kts+1, ktf + + uw = 0.5*(fzm(k)*(ru(its,k ,j)+ru(its+1,k ,j)) + & + fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j)) ) + ub = MIN( uw, 0. ) + + tendency(its,k,j) = tendency(its,k,j) & + - rdx*( & + ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & + w(its,k,j)*( & + fzm(k)*(ru(its+1,k ,j)-ru(its,k ,j))+ & + fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j))) & + ) + ENDDO + ENDDO + + k = ktf+1 + DO j = j_start, j_end + + uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j)) & + -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j)) ) + ub = MIN( uw, 0. ) + + tendency(its,k,j) = tendency(its,k,j) & + - rdx*( & + ub*(w_old(its+1,k,j) - w_old(its,k,j)) + & + w(its,k,j)*( & + (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))- & + fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j))) & + ) + ENDDO + + ENDIF + + IF( (config_flags%open_xe) .and. (ite == ide)) THEN + + DO j = j_start, j_end + DO k = kts+1, ktf + + uw = 0.5*(fzm(k)*(ru(ite-1,k ,j)+ru(ite,k ,j)) + & + fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) ) + ub = MAX( uw, 0. ) + + tendency(i_end,k,j) = tendency(i_end,k,j) & + - rdx*( & + ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & + w(i_end,k,j)*( & + fzm(k)*(ru(ite,k ,j)-ru(ite-1,k ,j)) + & + fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j))) & + ) + ENDDO + ENDDO + + k = ktf+1 + DO j = j_start, j_end + + uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j)) & + -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j)) ) + ub = MAX( uw, 0. ) + + tendency(i_end,k,j) = tendency(i_end,k,j) & + - rdx*( & + ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) + & + w(i_end,k,j)*( & + (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) - & + fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j))) & + ) + ENDDO + + ENDIF + + + IF( (config_flags%open_ys) .and. (jts == jds)) THEN + + DO i = i_start, i_end + DO k = kts+1, ktf + + vw = 0.5*( fzm(k)*(rv(i,k ,jts)+rv(i,k ,jts+1)) + & + fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) ) + vb = MIN( vw, 0. ) + + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*( & + vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & + w(i,k,jts)*( & + fzm(k)*(rv(i,k ,jts+1)-rv(i,k ,jts))+ & + fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts))) & + ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1)) & + -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1)) ) + vb = MIN( vw, 0. ) + + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*( & + vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) + & + w(i,k,jts)*( & + (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))- & + fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts))) & + ) + ENDDO + + ENDIF + + IF( (config_flags%open_ye) .and. (jte == jde) ) THEN + + DO i = i_start, i_end + DO k = kts+1, ktf + + vw = 0.5*( fzm(k)*(rv(i,k ,jte-1)+rv(i,k ,jte)) + & + fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) ) + vb = MAX( vw, 0. ) + + tendency(i,k,j_end) = tendency(i,k,j_end) & + - rdy*( & + vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & + w(i,k,j_end)*( & + fzm(k)*(rv(i,k ,jte)-rv(i,k ,jte-1))+ & + fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1))) & + ) + ENDDO + ENDDO + + k = ktf+1 + DO i = i_start, i_end + + vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte)) & + -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte)) ) + vb = MAX( vw, 0. ) + + tendency(i,k,j_end) = tendency(i,k,j_end) & + - rdy*( & + vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) + & + w(i,k,j_end)*( & + (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))- & + fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1))) & + ) + ENDDO + + ENDIF + +!-------------------- vertical advection + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO + + vert_order_test : IF (vert_order == 6) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux6( & + w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux4( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + + k = ktf + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux4( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + + k=ktf+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + +! pick up flux contribution for w at the lid. wcs, 13 march 2004 + k = ktf+1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) + ENDDO + + ENDDO + + ELSE IF (vert_order == 5) THEN + + DO j = j_start, j_end + + DO k=kts+3,ktf-1 + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux5( & + w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + k = kts+2 + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux3( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + k = ktf + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux3( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + + k=ktf+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + +! pick up flux contribution for w at the lid, wcs. 13 march 2004 + k = ktf+1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) + ENDDO + + ENDDO + + ELSE IF (vert_order == 4) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux4( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + k=ktf+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + +! pick up flux contribution for w at the lid, wcs. 13 march 2004 + k = ktf+1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) + ENDDO + + ENDDO + + ELSE IF (vert_order == 3) THEN + + DO j = j_start, j_end + + DO k=kts+2,ktf + DO i = i_start, i_end + vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) + vflux(i,k) = vel*flux3( & + w(i,k-2,j), w(i,k-1,j), & + w(i,k ,j), w(i,k+1,j), -vel ) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + k=ktf+1 + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO + ENDDO + +! pick up flux contribution for w at the lid, wcs. 13 march 2004 + k = ktf+1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) + ENDDO + + ENDDO + + ELSE IF (vert_order == 2) THEN + + DO j = j_start, j_end + DO k=kts+1,ktf+1 + DO i = i_start, i_end + + vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j)) + ENDDO + ENDDO + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k)) + + ENDDO + ENDDO + +! pick up flux contribution for w at the lid, wcs. 13 march 2004 + k = ktf+1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k)) + ENDDO + + ENDDO + + ELSE + + WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF vert_order_test + +END SUBROUTINE advect_w + +!---------------------------------------------------------------- + +SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & + ru, rv, rom, & + mut, mub, mu_old, & + config_flags, & + msfu, msfv, msft, & + fzm, fzp, & + rdx, rdy, rdzw, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! this is a first cut at a positive definite advection option +! for scalars in WRF. This version is memory intensive -> +! we save 3d arrays of x, y and z both high and low order fluxes +! (six in all). Alternatively, we could sweep in a direction +! and lower the cost considerably. + +! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order +! fluxes initially + +! WCS, 3 December 2002, 24 February 2003 + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + field_old, & + ru, & + rv, & + rom + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy, & + dt + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax + + REAL :: mrdx, mrdy, ub, vb, uw, vw, mu + +! storage for high and low order fluxes + + REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz + REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl + + INTEGER :: horz_order, vert_order + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye + + INTEGER :: jp1, jp0, jtmp + + REAL :: flux_out, ph_low, scale + REAL, PARAMETER :: eps=1.e-20 + + +! definition of flux operators, 3rd, 4th, 5th or 6th order + + REAL :: flux3, flux4, flux5, flux6, flux_upwind + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr + + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & + (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) + + flux3(q_im2, q_im1, q_i, q_ip1, ua) = & + flux4(q_im2, q_im1, q_i, q_ip1, ua) + & + sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) + + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & + +(1./60.)*(q_ip2+q_im3) + + flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & + flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & + -sign(1.,ua)*(1./60.)*( & + (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) + + flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & + +0.5*max(-1.0,(cr-abs(cr)))*q_i +! flux_upwind(q_im1, q_i, cr ) = 0. + + REAL :: dx,dy,dz + + LOGICAL, PARAMETER :: pd_limit = .true. + +! set order for the advection schemes + +! write(6,*) ' in pd advection routine ' + + ktf=MIN(kte,kde-1) + horz_order = config_flags%h_sca_adv_order + vert_order = config_flags%v_sca_adv_order + +! determine boundary mods for flux operators +! We degrade the flux operators from 3rd/4th order +! to second order one gridpoint in from the boundaries for +! all boundary conditions except periodic and symmetry - these +! conditions have boundary zone data fill for correct application +! of the higher order flux stencils + + degrade_xs = .true. + degrade_xe = .true. + degrade_ys = .true. + degrade_ye = .true. + +! begin with horizontal flux divergence +! here is the choice of flux operators + + + horizontal_order_test : IF( horz_order == 6 ) THEN + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + +!-- y flux compute; these bounds are for periodic and sym b.c. + + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + j_start_f = j_start + j_end_f = j_end+1 + +!-- modify loop bounds if open or specified + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 6th order + + j_loop_y_flux_6 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux6( & + field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux4( & + field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i, k, j ) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j) = vel*flux4( & + field(i,k,j-2),field(i,k,j-1), & + field(i,k,j),field(i,k,j+1),vel ) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ENDIF + + ENDDO j_loop_y_flux_6 + +! next, x flux + +!-- these bounds are for periodic and sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + i_start_f = i_start + i_end_f = i_end+1 + + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- modify loop bounds for open and specified b.c + + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 6th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j), & + field(i-1,k,j), field(i ,k,j), & + field(i+1,k,j), field(i+2,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j)/mu + cr = vel*dt/dx + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + + ENDIF + + ENDDO ! enddo for outer J loop + +!--- end of 6th order horizontal flux calculation + + ELSE IF( horz_order == 5 ) THEN + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+2) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-3) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+2) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-3) ) degrade_ye = .false. + +!--------------- y - advection first + +!-- y flux compute; these bounds are for periodic and sym b.c. + + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + j_start_f = j_start + j_end_f = j_end+1 + +!-- modify loop bounds if open or specified + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+3 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-3 + ENDIF + +! compute fluxes, 5th order + + j_loop_y_flux_5 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux5( & + field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux3( & + field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i, k, j ) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j) = vel*flux3( & + field(i,k,j-2),field(i,k,j-1), & + field(i,k,j),field(i,k,j+1),vel ) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ENDIF + + ENDDO j_loop_y_flux_5 + +! next, x flux + +!-- these bounds are for periodic and sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + i_start_f = i_start + i_end_f = i_end+1 + + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- modify loop bounds for open and specified b.c + + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+2 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-3 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 5th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & + field(i-1,k,j), field(i ,k,j), & + field(i+1,k,j), field(i+2,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j)/mu + cr = vel*dt/dx + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + + i = ids+2 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + + ENDIF + + IF( degrade_xe ) THEN + + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + + i = ide-2 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + + ENDIF + + ENDDO ! enddo for outer J loop + +!--- end of 5th order horizontal flux calculation + + ELSE IF( horz_order == 4 ) THEN + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- y - advection first + +!-- y flux compute; these bounds are for periodic and sym b.c. + + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + j_start_f = j_start + j_end_f = j_end+1 + +!-- modify loop bounds if open or specified + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+2 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-2 + ENDIF + +! compute fluxes, 4th order + + j_loop_y_flux_4 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux4( field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i, k, j ) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ENDIF + + ENDDO j_loop_y_flux_4 + +! next, x flux + +!-- these bounds are for periodic and sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + i_start_f = i_start + i_end_f = i_end+1 + + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- modify loop bounds for open and specified b.c + + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j)/mu + cr = vel*dt/dx + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + ENDIF + + IF( degrade_xe ) THEN + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + ENDIF + + ENDDO ! enddo for outer J loop + +!--- end of 4th order horizontal flux calculation + + ELSE IF( horz_order == 3 ) THEN + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids+1) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-2) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds+1) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-2) ) degrade_ye = .false. + +!--------------- y - advection first + +!-- y flux compute; these bounds are for periodic and sym b.c. + + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + j_start_f = j_start + j_end_f = j_end+1 + +!-- modify loop bounds if open or specified + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + + IF(degrade_ys) then + j_start = MAX(jts,jds+1) + j_start_f = jds+2 + ENDIF + + IF(degrade_ye) then + j_end = MIN(jte,jde-2) + j_end_f = jde-2 + ENDIF + +! compute fluxes, 3rd order + + j_loop_y_flux_3 : DO j = j_start, j_end+1 + + IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux3( field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + + DO k=kts,ktf + DO i = i_start, i_end + + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i, k, j ) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO + + ENDIF + + ENDDO j_loop_y_flux_3 + +! next, x flux + +!-- these bounds are for periodic and sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + i_start_f = i_start + i_end_f = i_end+1 + + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- modify loop bounds for open and specified b.c + + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + IF(degrade_xs) then + i_start = MAX(ids+1,its) + i_start_f = i_start+1 + ENDIF + + IF(degrade_xe) then + i_end = MIN(ide-2,ite) + i_end_f = ide-2 + ENDIF + +! compute fluxes + + DO j = j_start, j_end + +! 4th order flux + + DO k=kts,ktf + DO i = i_start_f, i_end_f + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDDO + +! lower order fluxes close to boundaries (if not periodic or symmetric) + + IF( degrade_xs ) THEN + + IF( i_start == ids+1 ) THEN ! second order flux next to the boundary + i = ids+1 + DO k=kts,ktf + + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j)/mu + cr = vel*dt/dx + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + ENDIF + + IF( degrade_xe ) THEN + IF( i_end == ide-2 ) THEN ! second order flux next to the boundary + i = ide-1 + DO k=kts,ktf + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx(i,k,j) = 0.5*(ru(i,k,j)) & + *(field(i,k,j)+field(i-1,k,j)) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + ENDDO + ENDIF + ENDIF + + ENDDO ! enddo for outer J loop + +!--- end of 3rd order horizontal flux calculation + + + ELSE IF( horz_order == 2 ) THEN + + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xs .or. & + (its > ids) ) degrade_xs = .false. + IF( config_flags%periodic_x .or. & + config_flags%symmetric_xe .or. & + (ite < ide-1) ) degrade_xe = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ys .or. & + (jts > jds) ) degrade_ys = .false. + IF( config_flags%periodic_y .or. & + config_flags%symmetric_ye .or. & + (jte < jde-1) ) degrade_ye = .false. + +!-- y flux compute; these bounds are for periodic and sym b.c. + + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- modify loop bounds if open or specified + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + IF(degrade_ys) j_start = MAX(jts,jds+1) + IF(degrade_ye) j_end = MIN(jte,jde-2) + +! compute fluxes, 2nd order, y flux + + DO j = j_start, j_end+1 + DO k=kts,ktf + DO i = i_start, i_end + dy = 2./(msft(i,j)+msft(i,j-1))/rdy + mu = 0.5*(mut(i,j)+mut(i,j-1)) + vel = rv(i,k,j) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & + (field(i,k,j)+field(i,k,j-1)) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + ENDDO + ENDDO + ENDDO + +! next, x flux + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end+1 + dx = 2./(msft(i,j)+msft(i-1,j))/rdx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + ENDDO + ENDDO + ENDDO + +!--- end of 3nd order horizontal flux calculation + + ELSE + + WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF horizontal_order_test + +! pick up the rest of the horizontal radiation boundary conditions. +! (these are the computations that don't require 'cb'. +! first, set to index ranges + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! compute x (u) conditions for v, w, or scalar + + IF( (config_flags%open_xs) .and. (its == ids) ) THEN + + DO j = j_start, j_end + DO k = kts, ktf + ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. ) + tendency(its,k,j) = tendency(its,k,j) & + - rdx*( & + ub*( field_old(its+1,k,j) & + - field_old(its ,k,j) ) + & + field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_xe) .and. (ite == ide) ) THEN + + DO j = j_start, j_end + DO k = kts, ktf + ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. ) + tendency(i_end,k,j) = tendency(i_end,k,j) & + - rdx*( & + ub*( field_old(i_end ,k,j) & + - field_old(i_end-1,k,j) ) + & + field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_ys) .and. (jts == jds) ) THEN + + DO i = i_start, i_end + DO k = kts, ktf + vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*( & + vb*( field_old(i,k,jts+1) & + - field_old(i,k,jts ) ) + & + field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts)) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%open_ye) .and. (jte == jde)) THEN + + DO i = i_start, i_end + DO k = kts, ktf + vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) + tendency(i,k,j_end) = tendency(i,k,j_end) & + - rdy*( & + vb*( field_old(i,k,j_end ) & + - field_old(i,k,j_end-1) ) + & + field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1)) & + ) + ENDDO + ENDDO + + ENDIF + +!-------------------- vertical advection + +!-- loop bounds for periodic or sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- loop bounds for open or specified conditions + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + vert_order_test : IF (vert_order == 6) THEN + + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. + ENDDO + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=kts+2 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf-1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + ENDDO + + ENDDO + + ELSE IF (vert_order == 5) THEN + + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. + ENDDO + + DO k=kts+3,ktf-2 + DO i = i_start, i_end + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=kts+2 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf-1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + ENDDO + + ENDDO + + ELSE IF (vert_order == 4) THEN + + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. + ENDDO + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux4( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + ENDDO + + ENDDO + + ELSE IF (vert_order == 3) THEN + + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. + ENDDO + + DO k=kts+2,ktf-1 + DO i = i_start, i_end + + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + ENDDO + + DO i = i_start, i_end + + k=kts+1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + ENDDO + + ENDDO + + ELSE IF (vert_order == 2) THEN + + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + ENDDO + ENDDO + + ENDDO + + ELSE + + WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF vert_order_test + + IF (pd_limit) THEN + +! positive definite filter + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- loop bounds for open or specified conditions + + IF(degrade_xs) i_start = its + IF(degrade_xe) i_end = MIN(ite,ide-1) + IF(degrade_ys) j_start = jts + IF(degrade_ye) j_end = MIN(jte,jde-1) + + IF(config_flags%specified .or. config_flags%nested) THEN + IF (degrade_xs) i_start = MAX(its,ids+1) + IF (degrade_xe) i_end = MIN(ite,ide-2) + IF (degrade_ys) j_start = MAX(jts,jds+1) + IF (degrade_ye) j_end = MIN(jte,jde-2) + END IF + + IF(config_flags%open_xs) THEN + IF (degrade_xs) i_start = MAX(its,ids+1) + END IF + IF(config_flags%open_xe) THEN + IF (degrade_xe) i_end = MIN(ite,ide-2) + END IF + IF(config_flags%open_ys) THEN + IF (degrade_ys) j_start = MAX(jts,jds+1) + END IF + IF(config_flags%open_ye) THEN + IF (degrade_ye) j_end = MIN(jte,jde-2) + END IF + +!-- here is the limiter... + + DO j=j_start, j_end + DO k=kts, ktf + DO i=i_start, i_end + + ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & + - dt*( msft(i,j)*( rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) & + +rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & + +rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) + + flux_out = dt*(msft(i,j)*( rdx*( max(0.,fqx (i+1,k,j)) & + -min(0.,fqx (i ,k,j)) ) & + +rdy*( max(0.,fqy (i,k,j+1)) & + -min(0.,fqy (i,k,j )) ) ) & + +rdzw(k)*( min(0.,fqz (i,k+1,j)) & + -max(0.,fqz (i,k ,j)) ) ) + + IF( flux_out .gt. ph_low ) THEN + + scale = max(0.,ph_low/(flux_out+eps)) + IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) + IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) + IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) + IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j ) +! note: z flux is opposite sign in mass coordinate because +! vertical coordinate decreases with increasing k + IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j) + IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j) + + END IF + + ENDDO + ENDDO + ENDDO + + END IF + +! add in the pd-limited flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + tendency (i,k,j) = tendency(i,k,j) & + -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & + +fqzl(i,k+1,j)-fqzl(i,k,j)) + + ENDDO + ENDDO + ENDDO + +! x flux divergence +! + IF(degrade_xs) i_start = i_start + 1 + IF(degrade_xe) i_end = i_end - 1 + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + tendency (i,k,j) = tendency(i,k,j) & + - msft(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & + +fqxl(i+1,k,j)-fqxl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + +! y flux divergence +! + i_start = its + i_end = MIN(ite,ide-1) + IF(degrade_ys) j_start = j_start + 1 + IF(degrade_ye) j_end = j_end - 1 + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + tendency (i,k,j) = tendency(i,k,j) & + - msft(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & + +fqyl(i,k,j+1)-fqyl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE advect_scalar_pd + +!---------------------------------------------------------------- + +END MODULE module_advect_em + diff --git a/wrfv2_fire/dyn_em/module_bc_em.F b/wrfv2_fire/dyn_em/module_bc_em.F new file mode 100644 index 00000000..d162ee17 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_bc_em.F @@ -0,0 +1,1028 @@ +!WRF:MODEL_LAYER:BOUNDARY +! +MODULE module_bc_em + + USE module_bc + USE module_configure + USE module_wrf_error + +CONTAINS + +!------------------------------------------------------------------------ + + SUBROUTINE spec_bdyupdate_ph( ph_save, field, & + field_tend, mu_tend, muts, dt, & + variable_in, config_flags, & + spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine adds the tendencies in the boundary specified region. +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone + CHARACTER, INTENT(IN ) :: variable_in + REAL, INTENT(IN ) :: dt + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend, ph_save + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu_tend, muts + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: b_dist, b_limit + +! Local array + + REAL, DIMENSION( its:ite , jts:jte ) :: mu_old + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + IF (variable == 'M') variable = 'm' + IF (variable == 'H') variable = 'h' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 'm') ktf = kte + IF (variable == 'h') ktf = kte + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + + mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + + field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & + dt*field_tend(i,k,j)/muts(i,j) + & + ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.) + + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + + mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + + field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & + dt*field_tend(i,k,j)/muts(i,j) + & + ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.) + + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + + mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + + field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & + dt*field_tend(i,k,j)/muts(i,j) + & + ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.) + + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + + mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + + field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & + dt*field_tend(i,k,j)/muts(i,j) + & + ph_save(i,k,j)*(mu_old(i,j)/muts(i,j) - 1.) + + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE spec_bdyupdate_ph + +!------------------------------------------------------------------------ + + SUBROUTINE relax_bdy_dry ( config_flags, & + ru_tendf, rv_tendf, ph_tendf, t_tendf, & + rw_tendf, mu_tend, & + ru, rv, ph, t, & + w, mu, mut, & + u_bxs,u_bxe,u_bys,u_bye, & + v_bxs,v_bxe,v_bys,v_bye, & + ph_bxs,ph_bxe,ph_bys,ph_bye, & + t_bxs,t_bxe,t_bys,t_bye, & + w_bxs,w_bxe,w_bys,w_bye, & + mu_bxs,mu_bxe,mu_bys,mu_bye, & + u_btxs,u_btxe,u_btys,u_btye, & + v_btxs,v_btxe,v_btys,v_btye, & + ph_btxs,ph_btxe,ph_btys,ph_btye, & + t_btxs,t_btxe,t_btys,t_btye, & + w_btxs,w_btxe,w_btys,w_btye, & + mu_btxs,mu_btxe,mu_btys,mu_btye, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its, ite, jts, jte, kts, kte) + IMPLICIT NONE + + ! Input data. + TYPE( grid_config_rec_type ) config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: ru, & + rv, & + ph, & + w, & + t + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu , & + mut + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: ru_tendf, & + rv_tendf, & + ph_tendf, & + rw_tendf, & + t_tendf + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tend + REAL , DIMENSION( spec_bdy_width) , INTENT(IN ) :: fcx, gcx + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: u_bxs,u_bxe, & + v_bxs,v_bxe, & + ph_bxs,ph_bxe, & + w_bxs,w_bxe, & + t_bxs,t_bxe, & + u_btxs,u_btxe, & + v_btxs,v_btxe, & + ph_btxs,ph_btxe, & + w_btxs,w_btxe, & + t_btxs,t_btxe + + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: u_bys,u_bye, & + v_bys,v_bye, & + ph_bys,ph_bye, & + w_bys,w_bye, & + t_bys,t_bye, & + u_btys,u_btye, & + v_btys,v_btye, & + ph_btys,ph_btye, & + w_btys,w_btye, & + t_btys,t_btye + + + REAL, DIMENSION( jms:jme , 1:1 , spec_bdy_width, 4 ), INTENT(IN ) :: mu_bxs,mu_bxe, & + mu_btxs,mu_btxe + + REAL, DIMENSION( ims:ime , 1:1 , spec_bdy_width, 4 ), INTENT(IN ) :: mu_bys,mu_bye, & + mu_btys,mu_btye + REAL, INTENT(IN ) :: dtbc + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) :: rfield + INTEGER :: i_start, i_end, j_start, j_end, i, j, k + + CALL relax_bdytend ( ru, ru_tendf, & + u_bxs,u_bxe,u_bys,u_bye,u_btxs,u_btxe,u_btys,u_btye, & + 'u' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL relax_bdytend ( rv, rv_tendf, & + v_bxs,v_bxe,v_bys,v_bye,v_btxs,v_btxe,v_btys,v_btye, & + 'v' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! rfield will be calculated beyond tile limits because relax_bdytend +! requires a 5-point stencil, and this avoids need for inter-tile/patch +! communication here + i_start = max(its-1, ids) + i_end = min(ite+1, ide-1) + j_start = max(jts-1, jds) + j_end = min(jte+1, jde-1) + + DO j=j_start,j_end + DO k=kts,kte + DO i=i_start,i_end + rfield(i,k,j) = ph(i,k,j)*mut(i,j) + ENDDO + ENDDO + ENDDO + + CALL relax_bdytend ( rfield, ph_tendf, & + ph_bxs,ph_bxe,ph_bys,ph_bye, ph_btxs,ph_btxe,ph_btys,ph_btye, & + 'h' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + DO j=j_start,j_end + DO k=kts,kte-1 + DO i=i_start,i_end + rfield(i,k,j) = t(i,k,j)*mut(i,j) + ENDDO + ENDDO + ENDDO + CALL relax_bdytend ( rfield, t_tendf, & + t_bxs,t_bxe,t_bys,t_bye, t_btxs,t_btxe,t_btys,t_btye, & + 't' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL relax_bdytend ( mu, mu_tend, & + mu_bxs,mu_bxe,mu_bys,mu_bye, mu_btxs,mu_btxe,mu_btys,mu_btye, & + 'm' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, 1 ,1 , & ! domain dims + ims,ime, jms,jme, 1 ,1 , & ! memory dims + ips,ipe, jps,jpe, 1 ,1 , & ! patch dims + its,ite, jts,jte, 1 ,1 ) + + IF( config_flags%nested) THEN + + i_start = max(its-1, ids) + i_end = min(ite+1, ide-1) + j_start = max(jts-1, jds) + j_end = min(jte+1, jde-1) + + DO j=j_start,j_end + DO k=kts,kte + DO i=i_start,i_end + rfield(i,k,j) = w(i,k,j)*mut(i,j) + ENDDO + ENDDO + ENDDO + + CALL relax_bdytend ( rfield, rw_tendf, & + w_bxs,w_bxe,w_bys,w_bye, w_btxs,w_btxe,w_btys,w_btye, & + 'h' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + END IF + + END SUBROUTINE relax_bdy_dry +!------------------------------------------------------------------------ + SUBROUTINE relax_bdy_scalar ( scalar_tend, & + scalar, mu, & + scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, & + scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its, ite, jts, jte, kts, kte) + IMPLICIT NONE + + ! Input data. + TYPE( grid_config_rec_type ) config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: scalar + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: scalar_tend + REAL , DIMENSION( spec_bdy_width) , INTENT(IN ) :: fcx, gcx + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: scalar_bxs,scalar_bxe, & + scalar_btxs,scalar_btxe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: scalar_bys,scalar_bye, & + scalar_btys,scalar_btye + REAL, INTENT(IN ) :: dtbc +!Local + INTEGER :: i,j,k, i_start, i_end, j_start, j_end + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) :: rscalar + +! rscalar will be calculated beyond tile limits because relax_bdytend +! requires a 5-point stencil, and this avoids need for inter-tile/patch +! communication here + i_start = max(its-1, ids) + i_end = min(ite+1, ide-1) + j_start = max(jts-1, jds) + j_end = min(jte+1, jde-1) + + DO j=j_start,j_end + DO k=kts,min(kte,kde-1) + DO i=i_start,i_end + rscalar(i,k,j) = scalar(i,k,j)*mu(i,j) + ENDDO + ENDDO + ENDDO + + CALL relax_bdytend (rscalar, scalar_tend, & + scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & + 'q' , config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + + END SUBROUTINE relax_bdy_scalar + +!------------------------------------------------------------------------ + SUBROUTINE spec_bdy_dry ( config_flags, & + ru_tend, rv_tend, ph_tend, t_tend, & + rw_tend, mu_tend, & + u_bxs,u_bxe,u_bys,u_bye, & + v_bxs,v_bxe,v_bys,v_bye, & + ph_bxs,ph_bxe,ph_bys,ph_bye, & + t_bxs,t_bxe,t_bys,t_bye, & + w_bxs,w_bxe,w_bys,w_bye, & + mu_bxs,mu_bxe,mu_bys,mu_bye, & + u_btxs,u_btxe,u_btys,u_btye, & + v_btxs,v_btxe,v_btys,v_btye, & + ph_btxs,ph_btxe,ph_btys,ph_btye, & + t_btxs,t_btxe,t_btys,t_btye, & + w_btxs,w_btxe,w_btys,w_btye, & + mu_btxs,mu_btxe,mu_btys,mu_btye, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its, ite, jts, jte, kts, kte) + IMPLICIT NONE + + ! Input data. + TYPE( grid_config_rec_type ) config_flags + + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT ) :: ru_tend, & + rv_tend, & + ph_tend, & + rw_tend, & + t_tend + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(OUT ) :: mu_tend + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: u_bxs,u_bxe, & + v_bxs,v_bxe, & + ph_bxs,ph_bxe, & + w_bxs,w_bxe, & + t_bxs,t_bxe, & + u_btxs,u_btxe, & + v_btxs,v_btxe, & + ph_btxs,ph_btxe, & + w_btxs,w_btxe, & + t_btxs,t_btxe + + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: u_bys,u_bye, & + v_bys,v_bye, & + ph_bys,ph_bye, & + w_bys,w_bye, & + t_bys,t_bye, & + u_btys,u_btye, & + v_btys,v_btye, & + ph_btys,ph_btye, & + w_btys,w_btye, & + t_btys,t_btye + + REAL, DIMENSION( jms:jme , 1:1 , spec_bdy_width, 4 ), INTENT(IN ) :: mu_bxs,mu_bxe, & + mu_btxs,mu_btxe + + REAL, DIMENSION( ims:ime , 1:1 , spec_bdy_width, 4 ), INTENT(IN ) :: mu_bys,mu_bye, & + mu_btys,mu_btye + CALL spec_bdytend ( ru_tend, & + u_bxs,u_bxe,u_bys,u_bye, u_btxs,u_btxe,u_btys,u_btye, & + 'u' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL spec_bdytend ( rv_tend, & + v_bxs,v_bxe,v_bys,v_bye, v_btxs,v_btxe,v_btys,v_btye, & + 'v' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL spec_bdytend ( ph_tend, & + ph_bxs,ph_bxe,ph_bys,ph_bye, ph_btxs,ph_btxe,ph_btys,ph_btye, & + 'h' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL spec_bdytend ( t_tend, & + t_bxs,t_bxe,t_bys,t_bye, t_btxs,t_btxe,t_btys,t_btye, & + 't' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + CALL spec_bdytend ( mu_tend, & + mu_bxs,mu_bxe,mu_bys,mu_bye, mu_btxs,mu_btxe,mu_btys,mu_btye, & + 'm' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, 1 ,1 , & ! domain dims + ims,ime, jms,jme, 1 ,1 , & ! memory dims + ips,ipe, jps,jpe, 1 ,1 , & ! patch dims + its,ite, jts,jte, 1 ,1 ) + + if(config_flags%nested) & + CALL spec_bdytend ( rw_tend, & + w_bxs,w_bxe,w_bys,w_bye, w_btxs,w_btxe,w_btys,w_btye, & + 'h' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + END SUBROUTINE spec_bdy_dry + +!------------------------------------------------------------------------ + SUBROUTINE spec_bdy_scalar ( scalar_tend, & + scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, & + scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & + spec_bdy_width, spec_zone, & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its, ite, jts, jte, kts, kte) + IMPLICIT NONE + + ! Input data. + TYPE( grid_config_rec_type ) config_flags + + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT ) :: scalar_tend + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: scalar_bxs,scalar_bxe, & + scalar_btxs,scalar_btxe + + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: scalar_bys,scalar_bye, & + scalar_btys,scalar_btye + +!Local + INTEGER :: i,j,k + + + CALL spec_bdytend ( scalar_tend, & + scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & + 'q' , config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + + END SUBROUTINE spec_bdy_scalar + +!------------------------------------------------------------------------ + + SUBROUTINE set_phys_bc_dry_1( config_flags, u_1, u_2, v_1, v_2, & + rw_1, rw_2, w_1, w_2, & + t_1, t_2, tp_1, tp_2, pp, pip, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + +! +! this is just a wraper to call the boundary condition routines +! for each variable +! + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + TYPE( grid_config_rec_type ) config_flags + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & + u_1,u_2, v_1, v_2, rw_1, rw_2, w_1, w_2, & + t_1, t_2, tp_1, tp_2, pp, pip + + + + CALL set_physical_bc3d( u_1 , 'u', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( u_2 , 'u', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( v_1 , 'v', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( v_2 , 'v', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( rw_1 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( rw_2 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( w_1 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( w_2 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( t_1, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( t_2, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( tp_1, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( tp_2, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( pp , 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( pip , 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + END SUBROUTINE set_phys_bc_dry_1 + +!-------------------------------------------------------------- + + SUBROUTINE set_phys_bc_dry_2( config_flags, & + u_1, u_2, v_1, v_2, w_1, w_2, & + t_1, t_2, ph_1, ph_2, mu_1, mu_2, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + +! +! this is just a wraper to call the boundary condition routines +! for each variable +! + + IMPLICIT NONE + + TYPE( grid_config_rec_type ) config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & + u_1, u_2, v_1, v_2, w_1, w_2, & + t_1, t_2, ph_1, ph_2 + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + mu_1, mu_2 + + + CALL set_physical_bc3d( u_1, 'U', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( u_2, 'U', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( v_1 , 'V', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( v_2 , 'V', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( w_1, 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( w_2, 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( t_1, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( t_2, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( ph_1 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( ph_2 , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc2d( mu_1, 't', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + CALL set_physical_bc2d( mu_2, 't', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + END SUBROUTINE set_phys_bc_dry_2 + +!------------------------------------------------------------------------ + + SUBROUTINE set_phys_bc_smallstep_1( config_flags, ru_1, du, rv_1, dv, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + +! +! this is just a wraper to call the boundary condition routines +! for each variable +! + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + TYPE( grid_config_rec_type ) config_flags + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & + ru_1,du, rv_1, dv + + CALL set_physical_bc3d( ru_1 , 'u', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kde ) + CALL set_physical_bc3d( du , 'u', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kde ) + CALL set_physical_bc3d( rv_1 , 'v', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kde ) + CALL set_physical_bc3d( dv , 'v', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kde ) + + END SUBROUTINE set_phys_bc_smallstep_1 + +!------------------------------------------------------------------- + + SUBROUTINE rk_phys_bc_dry_1( config_flags, u, v, rw, w, & + muu, muv, mut, php, alt, p, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + +! +! this is just a wraper to call the boundary condition routines +! for each variable +! + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + TYPE( grid_config_rec_type ) config_flags + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: u, v, rw, w, php, alt, p + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: muu, muv, mut + + CALL set_physical_bc3d( u , 'u', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( v , 'v', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d(rw , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( w , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( php , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( alt, 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( p, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc2d( muu, 'u', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + CALL set_physical_bc2d( muv, 'v', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + CALL set_physical_bc2d( mut, 't', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + END SUBROUTINE rk_phys_bc_dry_1 + +!------------------------------------------------------------------------ + + SUBROUTINE rk_phys_bc_dry_2( config_flags, u, v, w, & + t, ph, mu, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + +! +! this is just a wraper to call the boundary condition routines +! for each variable +! + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + TYPE( grid_config_rec_type ) config_flags + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & + u, v, w, t, ph + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + mu + + CALL set_physical_bc3d( u , 'U', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( v , 'V', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( w , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( t, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( ph , 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc2d( mu, 't', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + its, ite, jts, jte ) + + END SUBROUTINE rk_phys_bc_dry_2 + +!--------------------------------------------------------------------- + + SUBROUTINE set_w_surface( config_flags, & + w, ht, u, v, cf1, cf2, cf3, rdx, rdy, msft, & + ids, ide, jds, jde, kds, kde, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte, & + ims, ime, jms, jme, kms, kme ) + implicit none + + TYPE( grid_config_rec_type ) config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + ips, ipe, jps, jpe, kps, kpe + + REAL :: cf1, cf2, cf3, rdx, rdy + + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: u, & + v + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(INOUT) :: w + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: ht, msft + + INTEGER :: i,j + INTEGER :: ip1,im1,jp1,jm1 + +! set kinematic lower boundary condition on W + + DO j = jts,min(jte,jde-1) + jm1 = max(j-1,jds) + jp1 = min(j+1,jde-1) + DO i = its,min(ite,ide-1) + im1 = max(i-1,ids) + ip1 = min(i+1,ide-1) + + w(i,1,j)= msft(i,j)*( & + .5*rdy*( & + (ht(i,jp1)-ht(i,j )) & + *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1)) & + +(ht(i,j )-ht(i,jm1)) & + *(cf1*v(i,1,j )+cf2*v(i,2,j )+cf3*v(i,3,j )) ) & + +.5*rdx*( & + (ht(ip1,j)-ht(i,j )) & + *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j)) & + +(ht(i ,j)-ht(im1,j)) & + *(cf1*u(i ,1,j)+cf2*u(i ,2,j)+cf3*u(i ,3,j)) ) & + ) + ENDDO + ENDDO + + END SUBROUTINE set_w_surface + +END MODULE module_bc_em diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F new file mode 100644 index 00000000..b83439ef --- /dev/null +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -0,0 +1,5213 @@ +!WRF:MODEL_LAYER:DYNAMICS +! + +#if (RWORDSIZE == 4) +# define VPOWX vspowx +# define VPOW vspow +#else +# define VPOWX vpowx +# define VPOW vpow +#endif + + +MODULE module_big_step_utilities_em + + USE module_domain + USE module_model_constants + USE module_state_description + USE module_configure + USE module_wrf_error + +CONTAINS + +!------------------------------------------------------------------------------- + +SUBROUTINE calc_mu_uv ( config_flags, & + mu, mub, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: muu, muv + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu, mub + + ! local stuff + + INTEGER :: i, j, itf, jtf, im, jm + +! +! +! calc_mu_uv calculates the full column dry-air mass at the staggered +! horizontal velocity points (u,v) and places the results in muu and muv. +! This routine uses the reference state (mub) and perturbation state (mu) +! +! + + + itf=ite + jtf=MIN(jte,jde-1) + + IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=its + im = its + if(config_flags%periodic_x) im = its-1 + DO j=jts,jtf +! muu(i,j) = mu(i,j) +mub(i,j) +! fix for periodic b.c., 13 march 2004, wcs + muu(i,j) = 0.5*(mu(i,j)+mu(im,j)+mub(i,j)+mub(im,j)) + ENDDO + ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=ite + im = ite-1 + if(config_flags%periodic_x) im = ite + DO j=jts,jtf +! muu(i,j) = mu(i-1,j) +mub(i-1,j) +! fix for periodic b.c., 13 march 2004, wcs + muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)+mub(i-1,j)+mub(im,j)) + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=its + im = its + if(config_flags%periodic_x) im = its-1 + DO j=jts,jtf +! muu(i,j) = mu(i,j) +mub(i,j) +! fix for periodic b.c., 13 march 2004, wcs + muu(i,j) = 0.5*(mu(i,j)+mu(im,j)+mub(i,j)+mub(im,j)) + ENDDO + i=ite + im = ite-1 + if(config_flags%periodic_x) im = ite + DO j=jts,jtf +! muu(i,j) = mu(i-1,j) +mub(i-1,j) +! fix for periodic b.c., 13 march 2004, wcs + muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)+mub(i-1,j)+mub(im,j)) + ENDDO + END IF + + itf=MIN(ite,ide-1) + jtf=jte + + IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts+1,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jts + jm = jts + if(config_flags%periodic_y) jm = jts-1 + DO i=its,itf +! muv(i,j) = mu(i,j) +mub(i,j) +! fix for periodic b.c., 13 march 2004, wcs + muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)+mub(i,j)+mub(i,jm)) + ENDDO + ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jte + jm = jte-1 + if(config_flags%periodic_y) jm = jte + DO i=its,itf + muv(i,j) = mu(i,j-1) +mub(i,j-1) +! fix for periodic b.c., 13 march 2004, wcs + muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)+mub(i,j-1)+mub(i,jm)) + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts+1,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jts + jm = jts + if(config_flags%periodic_y) jm = jts-1 + DO i=its,itf +! muv(i,j) = mu(i,j) +mub(i,j) +! fix for periodic b.c., 13 march 2004, wcs + muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)+mub(i,j)+mub(i,jm)) + ENDDO + j=jte + jm = jte-1 + if(config_flags%periodic_y) jm = jte + DO i=its,itf +! muv(i,j) = mu(i,j-1) +mub(i,j-1) +! fix for periodic b.c., 13 march 2004, wcs + muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)+mub(i,j-1)+mub(i,jm)) + ENDDO + END IF + +END SUBROUTINE calc_mu_uv + +!------------------------------------------------------------------------------- + +SUBROUTINE calc_mu_uv_1 ( config_flags, & + mu, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: muu, muv + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + + ! local stuff + + INTEGER :: i, j, itf, jtf, im, jm + +! +! +! calc_mu_uv calculates the full column dry-air mass at the staggered +! horizontal velocity points (u,v) and places the results in muu and muv. +! This routine uses the full state (mu) +! +! + + itf=ite + jtf=MIN(jte,jde-1) + + IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + ENDDO + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + ENDDO + ENDDO + i=its + im = its + if(config_flags%periodic_x) im = its-1 + DO j=jts,jtf + muu(i,j) = 0.5*(mu(i,j)+mu(im,j)) + ENDDO + ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + ENDDO + ENDDO + i=ite + im = ite-1 + if(config_flags%periodic_x) im = ite + DO j=jts,jtf + muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)) + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + ENDDO + ENDDO + i=its + im = its + if(config_flags%periodic_x) im = its-1 + DO j=jts,jtf + muu(i,j) = 0.5*(mu(i,j)+mu(im,j)) + ENDDO + i=ite + im = ite-1 + if(config_flags%periodic_x) im = ite + DO j=jts,jtf + muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)) + ENDDO + END IF + + itf=MIN(ite,ide-1) + jtf=jte + + IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + ENDDO + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts+1,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + ENDDO + ENDDO + j=jts + jm = jts + if(config_flags%periodic_y) jm = jts-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)) + ENDDO + ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + ENDDO + ENDDO + j=jte + jm = jte-1 + if(config_flags%periodic_y) jm = jte + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)) + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts+1,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + ENDDO + ENDDO + j=jts + jm = jts + if(config_flags%periodic_y) jm = jts-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)) + ENDDO + j=jte + jm = jte-1 + if(config_flags%periodic_y) jm = jte + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)) + ENDDO + END IF + +END SUBROUTINE calc_mu_uv_1 + +!------------------------------------------------------------------------------- + +SUBROUTINE couple_momentum ( muu, ru, u, msfu, & + muv, rv, v, msfv, & + mut, rw, w, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: ru, rv, rw + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: muu, muv, mut + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, msfv, msft + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, v, w + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! couple_momentum couples the velocities to the full column mass and +! the map factors. +! +! + + ktf=MIN(kte,kde-1) + + itf=ite + jtf=MIN(jte,jde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + ru(i,k,j)=u(i,k,j)*muu(i,j)/msfu(i,j) + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=jte + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rv(i,k,j)=v(i,k,j)*muv(i,j)/msfv(i,j) + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + DO j=jts,jtf + DO k=kts,kte + DO i=its,itf + rw(i,k,j)=w(i,k,j)*mut(i,j)/msft(i,j) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE couple_momentum + +!------------------------------------------------------------------- + +SUBROUTINE calc_mu_staggered ( mu, mub, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: muu, muv + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu, mub + + ! local stuff + + INTEGER :: i, j, itf, jtf + +! +! +! calc_mu_staggered calculates the full dry air mass at the staggered +! velocity points (u,v). +! +! + + itf=ite + jtf=MIN(jte,jde-1) + + IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=its + DO j=jts,jtf + muu(i,j) = mu(i,j) +mub(i,j) + ENDDO + ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=ite + DO j=jts,jtf + muu(i,j) = mu(i-1,j) +mub(i-1,j) + ENDDO + ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN + DO j=jts,jtf + DO i=its+1,itf-1 + muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + ENDDO + ENDDO + i=its + DO j=jts,jtf + muu(i,j) = mu(i,j) +mub(i,j) + ENDDO + i=ite + DO j=jts,jtf + muu(i,j) = mu(i-1,j) +mub(i-1,j) + ENDDO + END IF + + itf=MIN(ite,ide-1) + jtf=jte + + IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN + DO j=jts+1,jtf + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jts + DO i=its,itf + muv(i,j) = mu(i,j) +mub(i,j) + ENDDO + ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jte + DO i=its,itf + muv(i,j) = mu(i,j-1) +mub(i,j-1) + ENDDO + ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN + DO j=jts+1,jtf-1 + DO i=its,itf + muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + ENDDO + ENDDO + j=jts + DO i=its,itf + muv(i,j) = mu(i,j) +mub(i,j) + ENDDO + j=jte + DO i=its,itf + muv(i,j) = mu(i,j-1) +mub(i,j-1) + ENDDO + END IF + +END SUBROUTINE calc_mu_staggered + +!------------------------------------------------------------------------------- + +SUBROUTINE couple ( mu, mub, rfield, field, name, & + msf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + CHARACTER(LEN=1) , INTENT(IN ) :: name + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: rfield + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu, mub, msf + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + REAL , DIMENSION(ims:ime,jms:jme) :: muu , muv + +! +! +! subroutine couple couples the input variable with the dry-air +! column mass (mu). +! +! + + + ktf=MIN(kte,kde-1) + + IF (name .EQ. 'u')THEN + + CALL calc_mu_staggered ( mu, mub, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + itf=ite + jtf=MIN(jte,jde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rfield(i,k,j)=field(i,k,j)*muu(i,j)/msf(i,j) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'v')THEN + + CALL calc_mu_staggered ( mu, mub, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + itf=ite + itf=MIN(ite,ide-1) + jtf=jte + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rfield(i,k,j)=field(i,k,j)*muv(i,j)/msf(i,j) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'w')THEN + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts,kte + DO i=its,itf + rfield(i,k,j)=field(i,k,j)*(mu(i,j)+mub(i,j))/msf(i,j) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'h')THEN + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts,kte + DO i=its,itf + rfield(i,k,j)=field(i,k,j)*(mu(i,j)+mub(i,j)) + ENDDO + ENDDO + ENDDO + + ELSE + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rfield(i,k,j)=field(i,k,j)*(mu(i,j)+mub(i,j)) + ENDDO + ENDDO + ENDDO + + ENDIF + +END SUBROUTINE couple + +!----------------------------------------------------------------------- + +SUBROUTINE calc_ww ( mu, ru, rv, ww, & + rdx, rdy, msft, dnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: ru, rv + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu, msft + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT ) :: ww + REAL , INTENT(IN ) :: rdx, rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + REAL , DIMENSION( its:ite ) :: dmdt + +! +! +! calc_ww calculates omega using the mass-coupled velocities mu*u, mu*v. +! The algorithm integrates the continuity equation through the column +! followed by a diagnosis of omega. +! +! + + + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + itf=MIN(ite,ide-1) + + DO j=jts,jtf + + DO i=its,ite + dmdt(i) = 0. + ww(i,1,j) = 0. + ww(i,kte,j) = 0. + ENDDO + +!! DO k=kts,ktf+1 + + DO k=kts,ktf + DO i=its,itf + + dmdt(i) = dmdt(i) + dnw(k)* ( rdx*(ru(i+1,k,j)-ru(i,k,j)) & + +rdy*(rv(i,k,j+1)-rv(i,k,j)) ) + + ENDDO + ENDDO + +! DO K=2,NZ-1 +! ww(K,I)=ww(K-1,I)-DNW(K-1)* +! & (DMDT+RDX*( xmu(i )*u(K,I ) +! & -xmu(im1)*u(k,im1)) ) +! END DO + + DO k=2,ktf + DO i=its,itf + + ww(i,k,j)=ww(i,k-1,j) & + - dnw(k-1)* ( dmdt(i) & + +rdx*(ru(i+1,k-1,j)-ru(i,k-1,j)) & + +rdy*(rv(i,k-1,j+1)-rv(i,k-1,j)) ) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE calc_ww + + +!------------------------------------------------------------------------------- + +SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & + rdx, rdy, msft, msfu, msfv, dnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, v + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mup, mub, & + msft, msfu, msfv + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT ) :: ww + REAL , INTENT(IN ) :: rdx, rdy + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + REAL , DIMENSION( its:ite ) :: dmdt + REAL , DIMENSION( its:ite, kts:kte ) :: divv + REAL , DIMENSION( its:ite+1, jts:jte+1 ) :: muu, muv + +! +! +! calc_ww calculates omega using the velocities (u,v) and the dry-air +! column mass (mup+mub). +! The algorithm integrates the continuity equation through the column +! followed by a diagnosis of omega. +! +! + +! +! +! calc_ww_cp calculates omega using the velocities (u,v) and the +! column mass mu. +! +! + + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + itf=MIN(ite,ide-1) + +! mu coupled with the appropriate map factor + + DO j=jts,jtf + DO i=its,min(ite+1,ide) + muu(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i-1,j)+mub(i-1,j))/msfu(i,j) + ENDDO + ENDDO + + DO j=jts,min(jte+1,jde) + DO i=its,itf + muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))/msfv(i,j) + ENDDO + ENDDO + + DO j=jts,jtf + + DO i=its,ite + dmdt(i) = 0. + ww(i,1,j) = 0. + ww(i,kte,j) = 0. + ENDDO + + DO k=kts,ktf + DO i=its,itf + + divv(i,k) = msft(i,j)*dnw(k)*( rdx*(muu(i+1,j)*u(i+1,k,j)-muu(i,j)*u(i,k,j)) & + +rdy*(muv(i,j+1)*v(i,k,j+1)-muv(i,j)*v(i,k,j)) ) + +! dmdt(i) = dmdt(i) + dnw(k)* ( rdx*(ru(i+1,k,j)-ru(i,k,j)) & +! +rdy*(rv(i,k,j+1)-rv(i,k,j)) ) + + dmdt(i) = dmdt(i) + divv(i,k) + + + ENDDO + ENDDO + + DO k=2,ktf + DO i=its,itf + +! ww(i,k,j)=ww(i,k-1,j) & +! - dnw(k-1)* ( dmdt(i) & +! +rdx*(ru(i+1,k-1,j)-ru(i,k-1,j)) & +! +rdy*(rv(i,k-1,j+1)-rv(i,k-1,j)) ) + + ww(i,k,j)=ww(i,k-1,j) - dnw(k-1)*dmdt(i) - divv(i,k-1) + + ENDDO + ENDDO + ENDDO + + +END SUBROUTINE calc_ww_cp + + +!------------------------------------------------------------------------------- + +SUBROUTINE calc_cq ( moist, cqu, cqv, cqw, n_moist, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist + + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN ) :: moist + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: cqu, cqv, cqw + + ! Local stuff + + REAL :: qtot + + INTEGER :: i, j, k, itf, jtf, ktf, ispe + +! +! +! calc_cq calculates moist coefficients for the momentum equations. +! +! + + itf=ite + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + + IF( n_moist >= PARAM_FIRST_SCALAR ) THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + qtot = 0. +!DEC$ loop count(3) + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + moist(i,k,j,ispe) + moist(i-1,k,j,ispe) + ENDDO +! qtot = 0.5*( moist(i ,k,j,1)+moist(i ,k,j,2)+moist(i ,k,j,3)+ & +! & moist(i-1,k,j,1)+moist(i-1,k,j,2)+moist(i-1,k,j,3) ) +! cqu(i,k,j) = 1./(1.+qtot) + cqu(i,k,j) = 1./(1.+0.5*qtot) + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=jte + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + qtot = 0. +!DEC$ loop count(3) + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + moist(i,k,j,ispe) + moist(i,k,j-1,ispe) + ENDDO +! qtot = 0.5*( moist(i,k,j ,1)+moist(i,k,j ,2)+moist(i,k,j ,3)+ & +! & moist(i,k,j-1,1)+moist(i,k,j-1,2)+moist(i,k,j-1,3) ) +! cqv(i,k,j) = 1./(1.+qtot) + cqv(i,k,j) = 1./(1.+0.5*qtot) + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts+1,ktf + DO i=its,itf + qtot = 0. +!DEC$ loop count(3) + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + moist(i,k,j,ispe) + moist(i,k-1,j,ispe) + ENDDO +! qtot = 0.5*( moist(i,k ,j,1)+moist(i,k ,j,2)+moist(i,k-1,j,3)+ & +! & moist(i,k-1,j,1)+moist(i,k-1,j,2)+moist(i,k ,j,3) ) +! cqw(i,k,j) = qtot + cqw(i,k,j) = 0.5*qtot + ENDDO + ENDDO + ENDDO + + ELSE + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + cqu(i,k,j) = 1. + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=jte + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + cqv(i,k,j) = 1. + ENDDO + ENDDO + ENDDO + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts+1,ktf + DO i=its,itf + cqw(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + END IF + +END SUBROUTINE calc_cq + +!---------------------------------------------------------------------- + +SUBROUTINE calc_alt ( alt, al, alb, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: alb, al + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT( OUT) :: alt + + ! Local stuff + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! calc_alt computes the full inverse density +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + alt(i,k,j) = al(i,k,j)+alb(i,k,j) + ENDDO + ENDDO + ENDDO + + +END SUBROUTINE calc_alt + +!---------------------------------------------------------------------- + +SUBROUTINE calc_p_rho_phi ( moist, n_moist, & + al, alb, mu, muts, ph, p, pb, & + t, p0, t0, znu, dnw, rdnw, & + rdn, non_hydrostatic, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + LOGICAL , INTENT(IN ) :: non_hydrostatic + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: alb, & + pb, & + t + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, n_moist ), INTENT(IN ) :: moist + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT( OUT) :: al, p + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: ph + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu, muts + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: znu, dnw, rdnw, rdn + + REAL, INTENT(IN ) :: t0, p0 + + ! Local stuff + + INTEGER :: i, j, k, itf, jtf, ktf, ispe + REAL :: qvf, qtot, qf1, qf2 + REAL, DIMENSION( its:ite) :: temp,cpovcv_v + + +! +! +! For the nonhydrostatic option, calc_p_rho_phi calculates the +! diagnostic quantities pressure and (inverse) density from the +! prognostic variables using the equation of state. +! +! For the hydrostatic option, calc_p_rho_phi calculates the +! diagnostic quantities (inverse) density and geopotential from the +! prognostic variables using the equation of state and the hydrostatic +! equation. +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + +#ifndef INTELMKL + cpovcv_v = cpovcv +#endif + + IF (non_hydrostatic) THEN + + IF (n_moist >= PARAM_FIRST_SCALAR ) THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + al(i,k,j)=-1./muts(i,j)*(alb(i,k,j)*mu(i,j) & + +rdnw(k)*(ph(i,k+1,j)-ph(i,k,j))) + temp(i)=(r_d*(t0+t(i,k,j))*qvf)/ & + (p0*(al(i,k,j)+alb(i,k,j))) + ENDDO +#ifdef INTELMKL + CALL VPOWX ( itf-its+1, temp(its), cpovcv, p(its,k,j) ) +#else +! use vector version from libmassv or from compat lib in frame/libmassv.F + CALL VPOW ( p(its,k,j), temp(its), cpovcv_v(its), itf-its+1 ) +#endif + DO i=its,itf + p(i,k,j)= p(i,k,j)*p0-pb(i,k,j) + ENDDO + ENDDO + ENDDO + + ELSE + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + al(i,k,j)=-1./muts(i,j)*(alb(i,k,j)*mu(i,j) & + +rdnw(k)*(ph(i,k+1,j)-ph(i,k,j))) + p(i,k,j)=p0*( (r_d*(t0+t(i,k,j)))/ & + (p0*(al(i,k,j)+alb(i,k,j))) )**cpovcv & + -pb(i,k,j) + ENDDO + ENDDO + ENDDO + + END IF + + ELSE + +! hydrostatic pressure, al, and ph1 calc; WCS, 5 sept 2001 + + + IF (n_moist >= PARAM_FIRST_SCALAR ) THEN + + DO j=jts,jtf + + k=ktf ! top layer + DO i=its,itf + + qtot = 0. + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + moist(i,k,j,ispe) + ENDDO + qf2 = 1./(1.+qtot) + qf1 = qtot*qf2 + + p(i,k,j) = - 0.5*(mu(i,j)+qf1*muts(i,j))/rdnw(k)/qf2 + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j) + + ENDDO + + DO k=ktf-1,kts,-1 ! remaining layers, integrate down + DO i=its,itf + + qtot = 0. + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + 0.5*( moist(i,k ,j,ispe) + moist(i,k+1,j,ispe) ) + ENDDO + qf2 = 1./(1.+qtot) + qf1 = qtot*qf2 + + p(i,k,j) = p(i,k+1,j) - (mu(i,j) + qf1*muts(i,j))/qf2/rdn(k+1) + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j) + ENDDO + ENDDO + + DO k=2,ktf+1 ! integrate hydrostatic equation for geopotential + DO i=its,itf + +! ph(i,k,j) = ph(i,k-1,j) - (1./rdnw(k-1))*( & +! (muts(i,j)+mu(i,j))*al(i,k-1,j)+ & +! mu(i,j)*alb(i,k-1,j) ) + ph(i,k,j) = ph(i,k-1,j) - (dnw(k-1))*( & + (muts(i,j))*al(i,k-1,j)+ & + mu(i,j)*alb(i,k-1,j) ) + + + ENDDO + ENDDO + + ENDDO + + ELSE + + DO j=jts,jtf + + k=ktf ! top layer + DO i=its,itf + + qtot = 0. + qf2 = 1./(1.+qtot) + qf1 = qtot*qf2 + + p(i,k,j) = - 0.5*(mu(i,j)+qf1*muts(i,j))/rdnw(k)/qf2 + qvf = 1. + al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j) + + ENDDO + + DO k=ktf-1,kts,-1 ! remaining layers, integrate down + DO i=its,itf + + qtot = 0. + qf2 = 1./(1.+qtot) + qf1 = qtot*qf2 + + p(i,k,j) = p(i,k+1,j) - (mu(i,j) + qf1*muts(i,j))/qf2/rdn(k+1) + qvf = 1. + al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j) + ENDDO + ENDDO + + DO k=2,ktf+1 ! integrate hydrostatic equation for geopotential + DO i=its,itf + +! ph(i,k,j) = ph(i,k-1,j) - (1./rdnw(k-1))*( & +! (muts(i,j)+mu(i,j))*al(i,k-1,j)+ & +! mu(i,j)*alb(i,k-1,j) ) + ph(i,k,j) = ph(i,k-1,j) - (dnw(k-1))*( & + (muts(i,j))*al(i,k-1,j)+ & + mu(i,j)*alb(i,k-1,j) ) + + + ENDDO + ENDDO + + ENDDO + + END IF + + END IF + +END SUBROUTINE calc_p_rho_phi + +!---------------------------------------------------------------------- + +SUBROUTINE calc_php ( php, ph, phb, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: phb, ph + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT( OUT) :: php + + ! Local stuff + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! calc_php calculates the full geopotential from the reference state +! geopotential and the perturbation geopotential (phb_ph). +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + php(i,k,j) = 0.5*(phb(i,k,j)+phb(i,k+1,j)+ph(i,k,j)+ph(i,k+1,j)) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE calc_php + +!------------------------------------------------------------------------------- + +SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mu, dt, & + u, v, ht, & + cf1, cf2, cf3, rdx, rdy, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: ph_tend, & + ph_new, & + ph_old, & + u, & + v + + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT( OUT) :: w + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mu, ht, msft + + REAL, INTENT(IN ) :: dt, cf1, cf2, cf3, rdx, rdy + + INTEGER :: i, j, k, itf, jtf + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + +! +! +! diagnose_w diagnoses the vertical velocity from the geopoential equation. +! Used with the hydrostatic option. +! +! + + DO j = jts, jtf + +! lower b.c. on w + + DO i = its, itf + w(i,1,j)= msft(i,j)*( & + .5*rdy*( & + (ht(i,j+1)-ht(i,j )) & + *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1)) & + +(ht(i,j )-ht(i,j-1)) & + *(cf1*v(i,1,j )+cf2*v(i,2,j )+cf3*v(i,3,j )) ) & + +.5*rdx*( & + (ht(i+1,j)-ht(i,j )) & + *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j)) & + +(ht(i,j )-ht(i-1,j)) & + *(cf1*u(i ,1,j)+cf2*u(i ,2,j)+cf3*u(i ,3,j)) ) & + ) + ENDDO + +! use geopotential equation to diagnose w + + DO k = 2, kte + DO i = its, itf + w(i,k,j) = msft(i,j)*( (ph_new(i,k,j)-ph_old(i,k,j))/dt & + - ph_tend(i,k,j)/mu(i,j) )/g + + ENDDO + ENDDO + + ENDDO + +END SUBROUTINE diagnose_w + +!------------------------------------------------------------------------------- + +SUBROUTINE rhs_ph( ph_tend, u, v, ww, & + ph, ph_old, phb, w, & + mut, muu, muv, & + fnm, fnp, & + rdnw, cfn, cfn1, rdx, rdy, msft, & + non_hydrostatic, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: & + u, & + v, & + ww, & + ph, & + ph_old, & + phb, & + w + +! pjj/cray +! REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT( OUT) :: ph_tend + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: ph_tend + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: muu, muv, mut, msft + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, fnm, fnp + + REAL, INTENT(IN ) :: cfn, cfn1, rdx, rdy + + LOGICAL, INTENT(IN ) :: non_hydrostatic + + ! Local stuff + + INTEGER :: i, j, k, itf, jtf, ktf, kz, i_start, j_start + REAL :: ur, ul, ub, vr, vl, vb + REAL, DIMENSION(its:ite,kts:kte) :: wdwn + + INTEGER :: advective_order + + LOGICAL :: specified + +! +! +! rhs_ph calculates the large-timestep tendency terms for the geopotential +! equation. These terms include the advection and "gw". The geopotential +! equation is cast in advective form, so we don't use the flux form advection +! algorithms here. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + advective_order = config_flags%h_sca_adv_order +! advective_order = 2 ! original configuration (pre Oct 2001) + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + +! advective form for the geopotential equation + + DO j = jts, jtf + + DO k = 2, kte + DO i = its, itf + wdwn(i,k) = .5*(ww(i,k,j)+ww(i,k-1,j))*rdnw(k-1) & + *(ph(i,k,j)-ph(i,k-1,j)+phb(i,k,j)-phb(i,k-1,j)) + ENDDO + ENDDO + + DO k = 2, kte-1 + DO i = its, itf + ph_tend(i,k,j) = ph_tend(i,k,j) & + - (fnm(k)*wdwn(i,k+1)+fnp(k)*wdwn(i,k)) + ENDDO + ENDDO + + ENDDO + + IF (non_hydrostatic) THEN ! add in "gw" term. + DO j = jts, jtf ! in hydrostatic mode, "gw" will be diagnosed + ! after the timestep to give us "w" + DO i = its, itf + ph_tend(i,kde,j) = 0. + ENDDO + + DO k = 2, kte + DO i = its, itf + ph_tend(i,k,j) = ph_tend(i,k,j) + mut(i,j)*g*w(i,k,j)/msft(i,j) + ENDDO + ENDDO + + ENDDO + + END IF + + IF (advective_order <= 2) THEN + +! y (v) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( (config_flags%open_ys) .and. jts == jds ) j_start = jts+1 + IF ( (config_flags%open_ye) .and. jte == jde ) jtf = jtf-1 + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdy* & + ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))* & + (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & + +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))* & + (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdy* & + ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))* & + (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & + +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))* & + (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) + ENDDO + + ENDDO + +! x (u) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( (config_flags%open_xs) .and. its == ids ) i_start = its+1 + IF ( (config_flags%open_xe) .and. ite == ide ) itf = itf-1 + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdx* & + ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))* & + (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & + +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))* & + (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdx* & + ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))* & + (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & + +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))* & + (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) + ENDDO + + ENDDO + + ELSE IF (advective_order <= 4) THEN + +! y (v) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( (config_flags%open_ys) .and. jts == jds ) j_start = jts+1 + IF ( (config_flags%open_ye) .and. jte == jde ) jtf = jtf-1 + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdy* ( & + ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1)) & + +muv(i,j )*(v(i,k,j )+v(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdy* ( & + ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1)) & + +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + ENDDO + + ENDDO + + +! x (u) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( (config_flags%open_xs) .and. its == ids ) i_start = its+1 + IF ( (config_flags%open_xe) .and. ite == ide ) itf = itf-1 + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdx*( & + ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j)) & + +muu(i,j )*(u(i,k,j )+u(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdx*( & + ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j)) & + +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j)) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + ENDDO + + ENDDO + + ELSE IF (advective_order <= 6) THEN + +! y (v) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + +! IF ( (config_flags%open_ys) .and. jts == jds ) j_start = jts+1 +! IF ( (config_flags%open_ye) .and. jte == jde ) jtf = jtf-1 + + IF (config_flags%open_ys .or. specified ) j_start = max(jts,jds+2) + IF (config_flags%open_ye .or. specified ) jtf = min(jtf,jde-3) + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdy* ( & + ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1)) & + +muv(i,j )*(v(i,k,j )+v(i,k-1,j )) )* (1./60.)*( & + 45.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -9.*(ph(i,k,j+2)-ph(i,k,j-2)) & + +(ph(i,k,j+3)-ph(i,k,j-3)) & + +45.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -9.*(phb(i,k,j+2)-phb(i,k,j-2)) & + +(phb(i,k,j+3)-phb(i,k,j-3)) ) ) + + + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdy* ( & + ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1)) & + +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j )) )* (1./60.)*( & + 45.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -9.*(ph(i,k,j+2)-ph(i,k,j-2)) & + +(ph(i,k,j+3)-ph(i,k,j-3)) & + +45.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -9.*(phb(i,k,j+2)-phb(i,k,j-2)) & + +(phb(i,k,j+3)-phb(i,k,j-3)) ) ) + + ENDDO + + ENDDO + + +! pick up near boundary rows using 4th order stencil +! (open bc copy only goes out to jds-1 and jde, hence 4rth is ok but 6th is too big) + + IF ( (config_flags%open_ys) .and. jts <= jds+1 ) THEN + + j = jds+1 + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdy* ( & + ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1)) & + +muv(i,j )*(v(i,k,j )+v(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdy* ( & + ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1)) & + +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + ENDDO + + END IF + + IF ( (config_flags%open_ye) .and. jte >= jde-2 ) THEN + + j = jde-2 + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdy* ( & + ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1)) & + +muv(i,j )*(v(i,k,j )+v(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdy* ( & + ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1)) & + +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j )) )* (1./12.)*( & + 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & + -(ph(i,k,j+2)-ph(i,k,j-2)) & + +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & + -(phb(i,k,j+2)-phb(i,k,j-2)) ) ) + + ENDDO + + END IF + +! x (u) advection + + i_start = its + j_start = jts + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF (config_flags%open_xs .or. specified ) i_start = max(its,ids+2) + IF (config_flags%open_xe .or. specified ) itf = min(itf,ide-3) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) itf=MIN(ite,ide-1) + + DO j = j_start, jtf + + DO k = 2, kte-1 + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdx*( & + ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j)) & + +muu(i,j )*(u(i,k,j )+u(i,k-1,j )) )* (1./60.)*( & + 45.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -9.*(ph(i+2,k,j)-ph(i-2,k,j)) & + +(ph(i+3,k,j)-ph(i-3,k,j)) & + +45.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -9.*(phb(i+2,k,j)-phb(i-2,k,j)) & + +(phb(i+3,k,j)-phb(i-3,k,j)) ) ) + ENDDO + ENDDO + + k = kte + DO i = i_start, itf + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdx*( & + ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j)) & + +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j)) )* (1./60.)*( & + 45.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -9.*(ph(i+2,k,j)-ph(i-2,k,j)) & + +(ph(i+3,k,j)-ph(i-3,k,j)) & + +45.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -9.*(phb(i+2,k,j)-phb(i-2,k,j)) & + +(phb(i+3,k,j)-phb(i-3,k,j)) ) ) + ENDDO + + ENDDO + + IF ( (config_flags%open_xs) .and. its <= ids+1 ) THEN + i = ids + 1 + DO j = j_start, jtf + DO k = 2, kte-1 + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdx*( & + ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j)) & + +muu(i,j )*(u(i,k,j )+u(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + ENDDO + k = kte + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdx*( & + ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j)) & + +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j)) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + + ENDDO + END IF + + IF ( (config_flags%open_xe) .and. ite >= ide-2 ) THEN + i = ide-2 + DO j = j_start, jtf + DO k = 2, kte-1 + ph_tend(i,k,j)=ph_tend(i,k,j) - .25*rdx*( & + ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j)) & + +muu(i,j )*(u(i,k,j )+u(i,k-1,j )) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + ENDDO + k = kte + ph_tend(i,k,j)=ph_tend(i,k,j) - .5*rdx*( & + ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j)) & + +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j)) )* (1./12.)*( & + 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & + -(ph(i+2,k,j)-ph(i-2,k,j)) & + +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & + -(phb(i+2,k,j)-phb(i-2,k,j)) ) ) + + ENDDO + END IF + + END IF + +! lateral open boundary conditions, +! start with north and south (y) boundaries + + i_start = its + itf=MIN(ite,ide-1) + + ! south + + IF ( (config_flags%open_ys) .and. jts == jds ) THEN + + j=jts + + DO k=2,kde + kz = min(k,kde-1) + DO i = its,itf + vb =.5*( fnm(kz)*(v(i,kz ,j+1)+v(i,kz ,j )) & + +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j )) ) + vl=amin1(vb,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*mut(i,j)*( & + +vl*(ph_old(i,k,j+1)-ph_old(i,k,j))) + ENDDO + ENDDO + + END IF + + ! north + + IF ( (config_flags%open_ye) .and. jte == jde ) THEN + + j=jte-1 + + DO k=2,kde + kz = min(k,kde-1) + DO i = its,itf + vb=.5*( fnm(kz)*(v(i,kz ,j+1)+v(i,kz ,j)) & + +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j)) ) + vr=amax1(vb,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*mut(i,j)*( & + +vr*(ph_old(i,k,j)-ph_old(i,k,j-1))) + ENDDO + ENDDO + + END IF + + ! now the east and west (y) boundaries + + j_start = its + jtf=MIN(jte,jde-1) + + ! west + + IF ( (config_flags%open_xs) .and. its == ids ) THEN + + i=its + + DO j = jts,jtf + DO k=2,kde-1 + kz = k + ub =.5*( fnm(kz)*(u(i+1,kz ,j)+u(i ,kz ,j)) & + +fnp(kz)*(u(i+1,kz-1,j)+u(i ,kz-1,j)) ) + ul=amin1(ub,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdx*mut(i,j)*( & + +ul*(ph_old(i+1,k,j)-ph_old(i,k,j))) + ENDDO + + k = kde + kz = k + ub =.5*( fnm(kz)*(u(i+1,kz ,j)+u(i ,kz ,j)) & + +fnp(kz)*(u(i+1,kz-1,j)+u(i ,kz-1,j)) ) + ul=amin1(ub,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdx*mut(i,j)*( & + +ul*(ph_old(i+1,k,j)-ph_old(i,k,j))) + ENDDO + + END IF + + ! east + + IF ( (config_flags%open_xe) .and. ite == ide ) THEN + + i = ite-1 + + DO j = jts,jtf + DO k=2,kde-1 + kz = k + ub=.5*( fnm(kz)*(u(i+1,kz ,j)+u(i,kz ,j)) & + +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) ) + ur=amax1(ub,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdx*mut(i,j)*( & + +ur*(ph_old(i,k,j)-ph_old(i-1,k,j))) + ENDDO + + k = kde + kz = k-1 + ub=.5*( fnm(kz)*(u(i+1,kz ,j)+u(i,kz ,j)) & + +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) ) + ur=amax1(ub,0.) + ph_tend(i,k,j)=ph_tend(i,k,j)-rdx*mut(i,j)*( & + +ur*(ph_old(i,k,j)-ph_old(i-1,k,j))) + + ENDDO + + END IF + + END SUBROUTINE rhs_ph + +!------------------------------------------------------------------------------- + +SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & + ph,alt,p,pb,al,php,cqu,cqv, & + muu,muv,mu,fnm,fnp,rdnw, & + cf1,cf2,cf3,rdx,rdy,msft, & + config_flags, non_hydrostatic, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + LOGICAL, INTENT (IN ) :: non_hydrostatic + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: & + ph, & + alt, & + al, & + p, & + pb, & + php, & + cqu, & + cqv + + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: & + ru_tend, & + rv_tend + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: muu, muv, mu, msft + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, fnm, fnp + + REAL, INTENT(IN ) :: rdx, rdy, cf1, cf2, cf3 + + INTEGER :: i,j,k, itf, jtf, ktf, i_start, j_start + REAL, DIMENSION( ims:ime, kms:kme ) :: dpn + REAL :: dpx, dpy + + LOGICAL :: specified + +! +! +! horizontal_pressure_gradient calculates the +! horizontal pressure gradient terms for the large-timestep tendency +! in the horizontal momentum equations (u,v). +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + +! start with the north-south (y) pressure gradient + + itf=MIN(ite,ide-1) + jtf=jte + ktf=MIN(kte,kde-1) + i_start = its + j_start = jts + IF ( (config_flags%open_ys .or. specified .or. & + config_flags%nested ) .and. jts == jds ) j_start = jts+1 + IF ( (config_flags%open_ye .or. specified .or. & + config_flags%nested ) .and. jte == jde ) jtf = jtf-1 + + DO j = j_start, jtf + + IF ( non_hydrostatic ) THEN + + k=1 + + DO i = i_start, itf + dpn(i,k) = .5*( cf1*(p(i,k ,j-1)+p(i,k ,j)) & + +cf2*(p(i,k+1,j-1)+p(i,k+1,j)) & + +cf3*(p(i,k+2,j-1)+p(i,k+2,j)) ) + dpn(i,kde) = 0. + ENDDO + + DO k=2,ktf + DO i = i_start, itf + dpn(i,k) = .5*( fnm(k)*(p(i,k ,j-1)+p(i,k ,j)) & + +fnp(k)*(p(i,k-1,j-1)+p(i,k-1,j)) ) + END DO + END DO + + DO K=1,ktf + DO i = i_start, itf + dpy = .5*rdy*muv(i,j)*( & + (ph (i,k+1,j)-ph (i,k+1,j-1) + ph(i,k,j)-ph(i,k,j-1)) & + +(alt(i,k ,j)+alt(i,k ,j-1))*(p (i,k,j)-p (i,k,j-1)) & + +(al (i,k ,j)+al (i,k ,j-1))*(pb(i,k,j)-pb(i,k,j-1)) ) + dpy = dpy + rdy*(php(i,k,j)-php(i,k,j-1))* & + (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i,j-1)+mu(i,j))) + rv_tend(i,k,j) = rv_tend(i,k,j)-cqv(i,k,j)*dpy + END DO + END DO + + ELSE + + DO K=1,ktf + DO i = i_start, itf + dpy = .5*rdy*muv(i,j)*( & + (ph (i,k+1,j)-ph (i,k+1,j-1) + ph(i,k,j)-ph(i,k,j-1)) & + +(alt(i,k ,j)+alt(i,k ,j-1))*(p (i,k,j)-p (i,k,j-1)) & + +(al (i,k ,j)+al (i,k ,j-1))*(pb(i,k,j)-pb(i,k,j-1)) ) + rv_tend(i,k,j) = rv_tend(i,k,j)-cqv(i,k,j)*dpy + END DO + END DO + + END IF + + ENDDO + +! now the east-west (x) pressure gradient + + itf=ite + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + i_start = its + j_start = jts + IF ( (config_flags%open_xs .or. specified .or. & + config_flags%nested ) .and. its == ids ) i_start = its+1 + IF ( (config_flags%open_xe .or. specified .or. & + config_flags%nested ) .and. ite == ide ) itf = itf-1 + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) itf=ite + + DO j = j_start, jtf + + IF ( non_hydrostatic ) THEN + + k=1 + + DO i = i_start, itf + dpn(i,k) = .5*( cf1*(p(i-1,k ,j)+p(i,k ,j)) & + +cf2*(p(i-1,k+1,j)+p(i,k+1,j)) & + +cf3*(p(i-1,k+2,j)+p(i,k+2,j)) ) + dpn(i,kde) = 0. + ENDDO + + DO k=2,ktf + DO i = i_start, itf + dpn(i,k) = .5*( fnm(k)*(p(i-1,k ,j)+p(i,k ,j)) & + +fnp(k)*(p(i-1,k-1,j)+p(i,k-1,j)) ) + END DO + END DO + + DO K=1,ktf + DO i = i_start, itf + dpx = .5*rdx*muu(i,j)*( & + (ph (i,k+1,j)-ph (i-1,k+1,j) + ph(i,k,j)-ph(i-1,k,j)) & + +(alt(i,k ,j)+alt(i-1,k ,j))*(p (i,k,j)-p (i-1,k,j)) & + +(al (i,k ,j)+al (i-1,k ,j))*(pb(i,k,j)-pb(i-1,k,j)) ) + dpx = dpx + rdx*(php(i,k,j)-php(i-1,k,j))* & + (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i-1,j)+mu(i,j))) + ru_tend(i,k,j) = ru_tend(i,k,j)-cqu(i,k,j)*dpx + END DO + END DO + + ELSE + + DO K=1,ktf + DO i = i_start, itf + dpx = .5*rdx*muu(i,j)*( & + (ph (i,k+1,j)-ph (i-1,k+1,j) + ph(i,k,j)-ph(i-1,k,j)) & + +(alt(i,k ,j)+alt(i-1,k ,j))*(p (i,k,j)-p (i-1,k,j)) & + +(al (i,k ,j)+al (i-1,k ,j))*(pb(i,k,j)-pb(i-1,k,j)) ) + ru_tend(i,k,j) = ru_tend(i,k,j)-cqu(i,k,j)*dpx + END DO + END DO + + END IF + + ENDDO + +END SUBROUTINE horizontal_pressure_gradient + +!------------------------------------------------------------------------------- + +SUBROUTINE pg_buoy_w( rw_tend, p, cqw, mu, mub, & + rdnw, rdn, g, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: p + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: cqw + + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: rw_tend + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mub, mu, msft + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, rdn + + REAL, INTENT(IN ) :: g + + INTEGER :: itf, jtf, i, j, k + REAL :: cq1, cq2 + + +! +! +! pg_buoy_w calculates the +! vertical pressure gradient and buoyancy terms for the large-timestep +! tendency in the vertical momentum equation. +! +! + +! BUOYANCY AND PRESSURE GRADIENT TERM IN W EQUATION AT TIME T + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + DO j = jts,jtf + + k=kde + DO i=its,itf + cq1 = 1./(1.+cqw(i,k-1,j)) + cq2 = cqw(i,k-1,j)*cq1 + rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msft(i,j))*g*( & + cq1*2.*rdnw(k-1)*( -p(i,k-1,j)) & + -mu(i,j)-cq2*mub(i,j) ) + END DO + + DO k = 2, kde-1 + DO i = its,itf + cq1 = 1./(1.+cqw(i,k,j)) + cq2 = cqw(i,k,j)*cq1 + cqw(i,k,j) = cq1 + rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msft(i,j))*g*( & + cq1*rdn(k)*(p(i,k,j)-p(i,k-1,j)) & + -mu(i,j)-cq2*mub(i,j) ) + END DO + ENDDO + + + ENDDO + +END SUBROUTINE pg_buoy_w + +!------------------------------------------------------------------------------- + +SUBROUTINE w_damp( rw_tend, ww, w, mut, rdnw, dt, & + w_damping, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: w_damping + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN ) :: ww, w + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: rw_tend + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mut + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw + + REAL, INTENT(IN) :: dt + REAL :: cfl, cf_n, cf_d, maxcfl, maxdub, maxdeta + + INTEGER :: itf, jtf, i, j, k, maxi, maxj, maxk + INTEGER :: some + CHARACTER*512 :: temp + CHARACTER (LEN=256) :: time_str + CHARACTER (LEN=256) :: grid_str + +! +! +! w_damp computes a damping term for the vertical velocity when the +! vertical Courant number is too large. This was found to be preferable to +! decreasing the timestep or increasing the diffusion in real-data applications +! that produced potentially-unstable large vertical velocities because of +! unphysically large heating rates coming from the cumulus parameterization +! schemes run at moderately high resolutions (dx ~ O(10) km). +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + some = 0 + maxcfl = 0. + + IF ( w_damping == 1 ) THEN + DO j = jts,jtf + + DO k = 2, kde-1 + DO i = its,itf +#if 0 + cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt) + if(cfl .gt. w_beta)then +#else +! restructure to get rid of divide + cf_n = abs(ww(i,k,j)*rdnw(k)*dt) + cf_d = abs(mut(i,j)) + if(cf_n .gt. cf_d*w_beta )then +#endif + cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt) + IF ( cfl > maxcfl ) THEN + maxcfl = cfl ; maxi = i ; maxj = j ; maxk = k + maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k) + ENDIF + WRITE(temp,*)i,j,k,' cfl,w,d(eta)=',cfl,w(i,k,j),-1./rdnw(k) + CALL wrf_debug ( 100 , TRIM(temp) ) + if ( cfl > 2. ) some = some + 1 + rw_tend(i,k,j) = rw_tend(i,k,j)-sign(1.,w(i,k,j))*w_alpha*(cfl-w_beta)*mut(i,j) + endif + END DO + ENDDO + ENDDO + ELSE +! just print + DO j = jts,jtf + + DO k = 2, kde-1 + DO i = its,itf + cf_n = abs(ww(i,k,j)*rdnw(k)*dt) + cf_d = abs(mut(i,j)) + if(cf_n .gt. cf_d*w_beta )then + cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt) + IF ( cfl > maxcfl ) THEN + maxcfl = cfl ; maxi = i ; maxj = j ; maxk = k + maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k) + ENDIF + WRITE(temp,*)i,j,k,' cfl,w,d(eta)=',cfl,w(i,k,j),-1./rdnw(k) + CALL wrf_debug ( 100 , TRIM(temp) ) + if ( cfl > 2. ) some = some + 1 + endif + END DO + ENDDO + ENDDO + ENDIF + IF ( some .GT. 0 ) THEN + CALL get_current_time_string( time_str ) + CALL get_current_grid_name( grid_str ) + WRITE(wrf_err_message,*)some, & + ' points exceeded cfl=2 in domain '//TRIM(grid_str)//' at time '//TRIM(time_str)//' hours' + CALL wrf_debug ( 0 , TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'MAX AT i,j,k: ',maxi,maxj,maxk,' cfl,w,d(eta)=',maxcfl, & + maxdub,maxdeta + CALL wrf_debug ( 0 , TRIM(wrf_err_message) ) + ENDIF + +END SUBROUTINE w_damp + +!------------------------------------------------------------------------------- + +SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & + config_flags, & + msfu, msfv, msft, khdif, xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + CHARACTER(LEN=1) , INTENT(IN ) :: name + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, xkmhd + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , INTENT(IN ) :: rdx, & + rdy, & + khdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + + INTEGER :: i_start, i_end, j_start, j_end + + REAL :: mrdx, mkrdxm, mkrdxp, & + mrdy, mkrdym, mkrdyp + REAL :: pr_inv + + LOGICAL :: specified + +! +! +! horizontal_diffusion computes the horizontal diffusion tendency +! on model horizontal coordinate surfaces. +! +! + + pr_inv = 1./prandtl + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + IF (name .EQ. 'u') THEN + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mkrdxm=msft(i-1,j)*mu(i-1,j)*xkmhd(i-1,k,j)*rdx + mkrdxp=msft(i,j)*mu(i,j)*xkmhd(i,k,j)*rdx + mrdx=msfu(i,j)*rdx + mkrdym=0.5*(msfu(i,j)+msfu(i,j-1))* & + 0.25*(mu(i,j)+mu(i,j-1)+mu(i-1,j-1)+mu(i-1,j))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdy + mkrdyp=0.5*(msfu(i,j)+msfu(i,j+1))* & + 0.25*(mu(i,j)+mu(i,j+1)+mu(i-1,j+1)+mu(i-1,j))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j+1)+xkmhd(i-1,k,j+1)+xkmhd(i-1,k,j))*rdy + mrdy=msfu(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)+( & + mrdx*(mkrdxp*(field(i+1,k,j)-field(i ,k,j)) & + -mkrdxm*(field(i ,k,j)-field(i-1,k,j))) & + +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j )) & + -mkrdym*(field(i,k,j )-field(i,k,j-1)))) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'v')THEN + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mkrdxm=0.5*(msfv(i,j)+msfv(i-1,j))* & + 0.25*(mu(i,j)+mu(i,j-1)+mu(i-1,j-1)+mu(i-1,j))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdx + mkrdxp=0.5*(msfv(i,j)+msfv(i+1,j))* & + 0.25*(mu(i,j)+mu(i,j-1)+mu(i+1,j-1)+mu(i+1,j))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i+1,k,j-1)+xkmhd(i+1,k,j))*rdx + mrdx=msfv(i,j)*rdx + mkrdym=msft(i,j-1)*xkmhd(i,k,j-1)*rdy + mkrdyp=msft(i,j)*xkmhd(i,k,j)*rdy + mrdy=msfv(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)+( & + mrdx*(mkrdxp*(field(i+1,k,j)-field(i ,k,j)) & + -mkrdxm*(field(i ,k,j)-field(i-1,k,j))) & + +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j )) & + -mkrdym*(field(i,k,j )-field(i,k,j-1)))) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'w')THEN + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + + mkrdxm=msfu(i,j)* & + 0.25*(mu(i,j)+mu(i-1,j)+mu(i,j)+mu(i-1,j))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i-1,k,j)+xkmhd(i,k-1,j)+xkmhd(i-1,k-1,j))*rdx + mkrdxp=msfu(i+1,j)* & + 0.25*(mu(i+1,j)+mu(i,j)+mu(i+1,j)+mu(i,j))* & + 0.25*(xkmhd(i+1,k,j)+xkmhd(i,k,j)+xkmhd(i+1,k-1,j)+xkmhd(i,k-1,j))*rdx + mrdx=msft(i,j)*rdx + mkrdym=msfv(i,j)* & + 0.25*(mu(i,j)+mu(i,j-1)+mu(i,j)+mu(i,j-1))* & + 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i,k-1,j)+xkmhd(i,k-1,j-1))*rdy + mkrdyp=msfv(i,j+1)* & + 0.25*(mu(i,j+1)+mu(i,j)+mu(i,j+1)+mu(i,j))* & + 0.25*(xkmhd(i,k,j+1)+xkmhd(i,k,j)+xkmhd(i,k-1,j+1)+xkmhd(i,k-1,j))*rdy + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)+( & + mrdx*(mkrdxp*(field(i+1,k,j)-field(i ,k,j)) & + -mkrdxm*(field(i ,k,j)-field(i-1,k,j))) & + +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j )) & + -mkrdym*(field(i,k,j )-field(i,k,j-1)))) + ENDDO + ENDDO + ENDDO + + ELSE + + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mkrdxm=msfu(i,j)*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx*pr_inv + mkrdxp=msfu(i+1,j)*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx*pr_inv + mrdx=msft(i,j)*rdx + mkrdym=msfv(i,j)*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy*pr_inv + mkrdyp=msfv(i,j+1)*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy*pr_inv + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)+( & + mrdx*(mkrdxp*(field(i+1,k,j)-field(i ,k,j)) & + -mkrdxm*(field(i ,k,j)-field(i-1,k,j))) & + +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j )) & + -mkrdym*(field(i,k,j )-field(i,k,j-1)))) + ENDDO + ENDDO + ENDDO + + ENDIF + +END SUBROUTINE horizontal_diffusion + +!----------------------------------------------------------------------------------------- + +SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, mu, & + config_flags, base_3d, & + msfu, msfv, msft, khdif, xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + CHARACTER(LEN=1) , INTENT(IN ) :: name + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + xkmhd, & + base_3d + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft + + REAL , INTENT(IN ) :: rdx, & + rdy, & + khdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + + INTEGER :: i_start, i_end, j_start, j_end + + REAL :: mrdx, mkrdxm, mkrdxp, & + mrdy, mkrdym, mkrdyp + REAL :: pr_inv + + LOGICAL :: specified + +! +! +! horizontal_diffusion_3dmp computes the horizontal diffusion tendency +! on model horizontal coordinate surfaces. This routine computes diffusion +! a perturbation scalar (field-base_3d). +! +! + + pr_inv = 1./prandtl + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + + DO j = j_start, j_end + DO k=kts,ktf + DO i = i_start, i_end + + mkrdxm=msfu(i,j)*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx*pr_inv + mkrdxp=msfu(i+1,j)*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx*pr_inv + mrdx=msft(i,j)*rdx + mkrdym=msfv(i,j)*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy*pr_inv + mkrdyp=msfv(i,j+1)*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy*pr_inv + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)+( & + mrdx*( mkrdxp*( field(i+1,k,j) -field(i ,k,j) & + -base_3d(i+1,k,j)+base_3d(i ,k,j) ) & + -mkrdxm*( field(i ,k,j) -field(i-1,k,j) & + -base_3d(i ,k,j)+base_3d(i-1,k,j) ) ) & + +mrdy*( mkrdyp*( field(i,k,j+1) -field(i,k,j ) & + -base_3d(i,k,j+1)+base_3d(i,k,j ) ) & + -mkrdym*( field(i,k,j ) -field(i,k,j-1) & + -base_3d(i,k,j )+base_3d(i,k,j-1) ) ) & + ) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE horizontal_diffusion_3dmp + +!----------------------------------------------------------------------------------------- + +SUBROUTINE vertical_diffusion ( name, field, tendency, & + config_flags, & + alt, mut, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + CHARACTER(LEN=1) , INTENT(IN ) :: name + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: field, & + alt + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw + + REAL , INTENT(IN ) :: kvdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION(its:ite, jts:jte) :: vfluxm, vfluxp, zz + REAL , DIMENSION(its:ite, 0:kte+1) :: vflux + + REAL :: rdz + + LOGICAL :: specified + +! +! +! vertical_diffusion +! computes vertical diffusion tendency. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + IF (name .EQ. 'w')THEN + + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +j_loop_w : DO j = j_start, j_end + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)= (kvdif/alt(i,k,j))*rdnw(k)*(field(i,k+1,j)-field(i,k,j)) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts+1,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j) & + +rdn(k)*g*g/mut(i,j)/(0.5*(alt(i,k,j)+alt(i,k-1,j))) & + *(vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_w + + ELSE IF(name .EQ. 'm')THEN + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +j_loop_s : DO j = j_start, j_end + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j))) & + *(field(i,k+1,j)-field(i,k,j)) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,0)=vflux(i,1) + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_s + + ENDIF + +END SUBROUTINE vertical_diffusion + + +!------------------------------------------------------------------------------- + +SUBROUTINE vertical_diffusion_mp ( field, tendency, config_flags, & + base, & + alt, mut, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: field, & + alt + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, & + rdnw, & + base + + REAL , INTENT(IN ) :: kvdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION(its:ite, 0:kte+1) :: vflux + + REAL :: rdz + + LOGICAL :: specified + +! +! +! vertical_diffusion_mp +! computes vertical diffusion tendency of a perturbation variable +! (field-base). Note that base as a 1D (k) field. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +j_loop_s : DO j = j_start, j_end + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j))) & + *(field(i,k+1,j)-field(i,k,j)-base(k+1)+base(k)) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,0)=vflux(i,1) + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_s + +END SUBROUTINE vertical_diffusion_mp + + +!------------------------------------------------------------------------------- + +SUBROUTINE vertical_diffusion_3dmp ( field, tendency, config_flags, & + base_3d, & + alt, mut, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: field, & + alt, & + base_3d + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, & + rdnw + + REAL , INTENT(IN ) :: kvdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION(its:ite, 0:kte+1) :: vflux + + REAL :: rdz + + LOGICAL :: specified + +! +! +! vertical_diffusion_3dmp +! computes vertical diffusion tendency of a perturbation variable +! (field-base_3d). +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +j_loop_s : DO j = j_start, j_end + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j))) & + *( field(i,k+1,j) -field(i,k,j) & + -base_3d(i,k+1,j)+base_3d(i,k,j) ) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,0)=vflux(i,1) + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_s + +END SUBROUTINE vertical_diffusion_3dmp + + +!------------------------------------------------------------------------------- + + +SUBROUTINE vertical_diffusion_u ( field, tendency, & + config_flags, u_base, & + alt, muu, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: field, & + alt + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: muu + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw, u_base + + REAL , INTENT(IN ) :: kvdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION(its:ite, 0:kte+1) :: vflux + + REAL :: rdz, zz + + LOGICAL :: specified + +! +! +! vertical_diffusion_u computes vertical diffusion tendency for +! the u momentum equation. This routine assumes a constant eddy +! viscosity kvdif. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + +j_loop_u : DO j = j_start, j_end + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i ,k ,j) & + +alt(i-1,k ,j) & + +alt(i ,k+1,j) & + +alt(i-1,k+1,j) ) ) & + *(field(i,k+1,j)-field(i,k,j) & + -u_base(k+1) +u_base(k) ) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,0)=vflux(i,1) + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts,ktf-1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+ & + g*g*rdnw(k)/muu(i,j)/(0.5*(alt(i-1,k,j)+alt(i,k,j)))* & + (vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_u + +END SUBROUTINE vertical_diffusion_u + +!------------------------------------------------------------------------------- + + +SUBROUTINE vertical_diffusion_v ( field, tendency, & + config_flags, v_base, & + alt, muv, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: field, & + alt + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw, v_base + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: muv + + REAL , INTENT(IN ) :: kvdif + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf, jm1 + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION(its:ite, 0:kte+1) :: vflux + + REAL :: rdz, zz + + LOGICAL :: specified + +! +! +! vertical_diffusion_v computes vertical diffusion tendency for +! the v momentum equation. This routine assumes a constant eddy +! viscosity kvdif. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified ) j_end = MIN(jde-1,jte) + +j_loop_v : DO j = j_start, j_end +! jm1 = max(j-1,1) + jm1 = j-1 + + DO k=kts,ktf-1 + DO i = i_start, i_end + vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i,k ,j ) & + +alt(i,k ,jm1) & + +alt(i,k+1,j ) & + +alt(i,k+1,jm1) ) ) & + *(field(i,k+1,j)-field(i,k,j) & + -v_base(k+1) +v_base(k) ) + ENDDO + ENDDO + + DO i = i_start, i_end + vflux(i,0)=vflux(i,1) + ENDDO + + DO i = i_start, i_end + vflux(i,ktf)=0. + ENDDO + + DO k=kts,ktf-1 + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)+ & + g*g*rdnw(k)/muv(i,j)/(0.5*(alt(i,k,jm1)+alt(i,k,j)))* & + (vflux(i,k)-vflux(i,k-1)) + ENDDO + ENDDO + + ENDDO j_loop_v + +END SUBROUTINE vertical_diffusion_v + +!*************** end new mass coordinate routines + +!------------------------------------------------------------------------------- + +SUBROUTINE calculate_full ( rfield, rfieldb, rfieldp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rfieldb, & + rfieldp + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT ) :: rfield + + ! Local indices. + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! calculate_full +! calculates full 3D field from pertubation and base field. +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rfield(i,k,j)=rfieldb(i,k,j)+rfieldp(i,k,j) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE calculate_full + +!------------------------------------------------------------------------------ + +SUBROUTINE coriolis ( ru, rv, rw, ru_tend, rv_tend, rw_tend, & + config_flags, & + f, e, sina, cosa, fzm, fzp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: ru_tend, & + rv_tend, & + rw_tend + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: ru, & + rv, & + rw + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: f, & + e, & + sina, & + cosa + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + ! Local indices. + + INTEGER :: i, j , k, ktf + INTEGER :: i_start, i_end, j_start, j_end + + LOGICAL :: specified + +! +! +! coriolis calculates the large timestep tendency terms in the +! u, v, and w momentum equations arise from the coriolis force. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + +! coriolis for u-momentum equation + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified .or. & + config_flags%nested) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + DO j = jts, MIN(jte,jde-1) + + DO k=kts,ktf + DO i = i_start, i_end + + ru_tend(i,k,j)=ru_tend(i,k,j) + 0.5*(f(i,j)+f(i-1,j)) & + *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) & + - 0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j)) & + *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j)) + + ENDDO + ENDDO + + IF ( (config_flags%open_xs) .and. (its == ids) ) THEN + + DO k=kts,ktf + + ru_tend(its,k,j)=ru_tend(its,k,j) + 0.5*(f(its,j)+f(its,j)) & + *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) & + - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) & + *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j)) + + ENDDO + + ENDIF + + IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN + + DO k=kts,ktf + + ru_tend(ite,k,j)=ru_tend(ite,k,j) + 0.5*(f(ite-1,j)+f(ite-1,j)) & + *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) & + - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) & + *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j)) + + ENDDO + + ENDIF + + ENDDO + +! coriolis term for v-momentum equation + + j_start = jts + j_end = jte + + IF ( config_flags%open_ys .or. specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified .or. & + config_flags%nested) j_end = MIN(jde-1,jte) + + IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN + + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,jts)=rv_tend(i,k,jts) - 0.5*(f(i,jts)+f(i,jts)) & + *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts)) & + + 0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts)) & + *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts)) + + ENDDO + ENDDO + + ENDIF + + DO j=j_start, j_end + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,j)=rv_tend(i,k,j) - 0.5*(f(i,j)+f(i,j-1)) & + *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) & + + 0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)+sina(i,j-1)) & + *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j)) + + ENDDO + ENDDO + ENDDO + + + IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN + + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,jte)=rv_tend(i,k,jte) - 0.5*(f(i,jte-1)+f(i,jte-1)) & + *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1)) & + + 0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1)) & + *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1)) + + ENDDO + ENDDO + + ENDIF + +! coriolis term for w-mometum + + DO j=jts,MIN(jte, jde-1) + DO k=kts+1,ktf + DO i=its,MIN(ite, ide-1) + + rw_tend(i,k,j)=rw_tend(i,k,j) + e(i,j)* & + (cosa(i,j)*0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j)) & + +fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j))) & + -sina(i,j)*0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1)) & + +fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1)))) + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE coriolis + +!------------------------------------------------------------------------------ + +SUBROUTINE perturbation_coriolis ( ru_in, rv_in, rw, ru_tend, rv_tend, rw_tend, & + config_flags, & + u_base, v_base, z_base, & + muu, muv, phb, ph, & + f, e, sina, cosa, fzm, fzp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: ru_tend, & + rv_tend, & + rw_tend + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: ru_in, & + rv_in, & + rw, & + ph, & + phb + + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: f, & + e, & + sina, & + cosa + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: muu, & + muv + + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base, & + v_base, & + z_base + + ! Local storage + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) :: ru, & + rv + + REAL :: z_at_u, z_at_v, wkp1, wk, wkm1 + + ! Local indices. + + INTEGER :: i, j , k, ktf + INTEGER :: i_start, i_end, j_start, j_end + + LOGICAL :: specified + +! +! +! perturbation_coriolis calculates the large timestep tendency terms in the +! u, v, and w momentum equations arise from the coriolis force. This version +! subtracts off the horizontal velocities from the initial sounding when +! computing the forcing terms, hence "perturbation" coriolis. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + ktf=MIN(kte,kde-1) + +! coriolis for u-momentum equation + + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified .or. & + config_flags%nested) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + +! compute perturbation mu*v for use in u momentum equation + + DO j = jts, MIN(jte,jde-1)+1 + DO k=kts+1,ktf-1 + DO i = i_start-1, i_end + z_at_v = 0.25*( phb(i,k,j )+phb(i,k+1,j ) & + +phb(i,k,j-1)+phb(i,k+1,j-1) & + +ph(i,k,j )+ph(i,k+1,j ) & + +ph(i,k,j-1)+ph(i,k+1,j-1))/g + wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k))) + wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1))) + wk = 1.-wkp1-wkm1 + rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*( & + wkm1*v_base(k-1) & + +wk *v_base(k ) & + +wkp1*v_base(k+1) ) + ENDDO + ENDDO + ENDDO + + +! pick up top and bottom v + + DO j = jts, MIN(jte,jde-1)+1 + DO i = i_start-1, i_end + + k = kts + z_at_v = 0.25*( phb(i,k,j )+phb(i,k+1,j ) & + +phb(i,k,j-1)+phb(i,k+1,j-1) & + +ph(i,k,j )+ph(i,k+1,j ) & + +ph(i,k,j-1)+ph(i,k+1,j-1))/g + wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k))) + wk = 1.-wkp1 + rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*( & + +wk *v_base(k ) & + +wkp1*v_base(k+1) ) + + k = ktf + z_at_v = 0.25*( phb(i,k,j )+phb(i,k+1,j ) & + +phb(i,k,j-1)+phb(i,k+1,j-1) & + +ph(i,k,j )+ph(i,k+1,j ) & + +ph(i,k,j-1)+ph(i,k+1,j-1))/g + wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1))) + wk = 1.-wkm1 + rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*( & + wkm1*v_base(k-1) & + +wk *v_base(k ) ) + + ENDDO + ENDDO + +! compute coriolis forcing for u + + DO j = jts, MIN(jte,jde-1) + + DO k=kts,ktf + DO i = i_start, i_end + ru_tend(i,k,j)=ru_tend(i,k,j) + 0.5*(f(i,j)+f(i-1,j)) & + *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) & + - 0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j)) & + *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j)) + ENDDO + ENDDO + + IF ( (config_flags%open_xs) .and. (its == ids) ) THEN + + DO k=kts,ktf + + ru_tend(its,k,j)=ru_tend(its,k,j) + 0.5*(f(its,j)+f(its,j)) & + *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) & + - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) & + *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j)) + + ENDDO + + ENDIF + + IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN + + DO k=kts,ktf + + ru_tend(ite,k,j)=ru_tend(ite,k,j) + 0.5*(f(ite-1,j)+f(ite-1,j)) & + *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) & + - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) & + *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j)) + + ENDDO + + ENDIF + + ENDDO + +! coriolis term for v-momentum equation + + j_start = jts + j_end = jte + + IF ( config_flags%open_ys .or. specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. specified .or. & + config_flags%nested) j_end = MIN(jde-1,jte) + +! compute perturbation mu*u for use in v momentum equation + + DO j = j_start-1,j_end + DO k=kts+1,ktf-1 + DO i = its, MIN(ite,ide-1)+1 + z_at_u = 0.25*( phb(i ,k,j)+phb(i ,k+1,j) & + +phb(i-1,k,j)+phb(i-1,k+1,j) & + +ph(i ,k,j)+ph(i ,k+1,j) & + +ph(i-1,k,j)+ph(i-1,k+1,j))/g + wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k))) + wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1))) + wk = 1.-wkp1-wkm1 + ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*( & + wkm1*u_base(k-1) & + +wk *u_base(k ) & + +wkp1*u_base(k+1) ) + ENDDO + ENDDO + ENDDO + +! pick up top and bottom u + + DO j = j_start-1,j_end + DO i = its, MIN(ite,ide-1)+1 + + k = kts + z_at_u = 0.25*( phb(i ,k,j)+phb(i ,k+1,j) & + +phb(i-1,k,j)+phb(i-1,k+1,j) & + +ph(i ,k,j)+ph(i ,k+1,j) & + +ph(i-1,k,j)+ph(i-1,k+1,j))/g + wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k))) + wk = 1.-wkp1 + ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*( & + +wk *u_base(k ) & + +wkp1*u_base(k+1) ) + + + k = ktf + z_at_u = 0.25*( phb(i ,k,j)+phb(i ,k+1,j) & + +phb(i-1,k,j)+phb(i-1,k+1,j) & + +ph(i ,k,j)+ph(i ,k+1,j) & + +ph(i-1,k,j)+ph(i-1,k+1,j))/g + wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1))) + wk = 1.-wkm1 + ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*( & + wkm1*u_base(k-1) & + +wk *u_base(k ) ) + + ENDDO + ENDDO + +! compute coriolis forcing for v momentum equation + + IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN + + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,jts)=rv_tend(i,k,jts) - 0.5*(f(i,jts)+f(i,jts)) & + *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts)) & + + 0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts)) & + *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts)) + + ENDDO + ENDDO + + ENDIF + + DO j=j_start, j_end + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,j)=rv_tend(i,k,j) - 0.5*(f(i,j)+f(i,j-1)) & + *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) & + + 0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)+sina(i,j-1)) & + *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j)) + + ENDDO + ENDDO + ENDDO + + + IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN + + DO k=kts,ktf + DO i=its,MIN(ide-1,ite) + + rv_tend(i,k,jte)=rv_tend(i,k,jte) - 0.5*(f(i,jte-1)+f(i,jte-1)) & + *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1)) & + + 0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1)) & + *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1)) + + ENDDO + ENDDO + + ENDIF + +! coriolis term for w-mometum + + DO j=jts,MIN(jte, jde-1) + DO k=kts+1,ktf + DO i=its,MIN(ite, ide-1) + + rw_tend(i,k,j)=rw_tend(i,k,j) + e(i,j)* & + (cosa(i,j)*0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j)) & + +fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j))) & + -sina(i,j)*0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1)) & + +fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1)))) + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE perturbation_coriolis + +!------------------------------------------------------------------------------ + +SUBROUTINE curvature ( ru, rv, rw, u, v, w, ru_tend, rv_tend, rw_tend, & + config_flags, & + msfu, msfv, fzm, fzp, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: ru_tend, & + rv_tend, & + rw_tend + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: ru, & + rv, & + rw, & + u, & + v, & + w + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + REAL , INTENT(IN ) :: rdx, & + rdy + + ! Local data + +! INTEGER :: i, j, k, itf, jtf, ktf, kp1, im, ip, jm, jp + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end +! INTEGER :: irmin, irmax, jrmin, jrmax + + REAL , DIMENSION( its-1:ite , kts:kte, jts-1:jte ) :: vxgm + + LOGICAL :: specified + +! +! +! curvature calculates the large timestep tendency terms in the +! u, v, and w momentum equations arise from the curvature terms. +! +! + + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + +! irmin = ims +! irmax = ime +! jrmin = jms +! jrmax = jme +! IF ( config_flags%open_xs ) irmin = ids +! IF ( config_flags%open_xe ) irmax = ide-1 +! IF ( config_flags%open_ys ) jrmin = jds +! IF ( config_flags%open_ye ) jrmax = jde-1 + +! Define v cross grad m at scalar points - vxgm(i,j) + + i_start = its-1 + i_end = ite + j_start = jts-1 + j_end = jte + + IF ( ( config_flags%open_xs .or. specified .or. & + config_flags%nested) .and. (its == ids) ) i_start = its + IF ( ( config_flags%open_xe .or. specified .or. & + config_flags%nested) .and. (ite == ide) ) i_end = ite-1 + IF ( ( config_flags%open_ys .or. specified .or. & + config_flags%nested) .and. (jts == jds) ) j_start = jts + IF ( ( config_flags%open_ye .or. specified .or. & + config_flags%nested) .and. (jte == jde) ) j_end = jte-1 + IF ( config_flags%periodic_x ) i_start = its-1 + IF ( config_flags%periodic_x ) i_end = ite + + DO j=j_start, j_end + DO k=kts,ktf + DO i=i_start, i_end + vxgm(i,k,j)=0.5*(u(i,k,j)+u(i+1,k,j))*(msfv(i,j+1)-msfv(i,j))*rdy - & + 0.5*(v(i,k,j)+v(i,k,j+1))*(msfu(i+1,j)-msfu(i,j))*rdx + ENDDO + ENDDO + ENDDO + +! Pick up the boundary rows for open (radiation) lateral b.c. +! Rather crude at present, we are assuming there is no +! variation in this term at the boundary. + + IF ( ( config_flags%open_xs .or. (specified .AND. .NOT. config_flags%periodic_x) .or. & + config_flags%nested) .and. (its == ids) ) THEN + + DO j = jts, jte-1 + DO k = kts, ktf + vxgm(its-1,k,j) = vxgm(its,k,j) + ENDDO + ENDDO + + ENDIF + + IF ( ( config_flags%open_xe .or. (specified .AND. .NOT. config_flags%periodic_x) .or. & + config_flags%nested) .and. (ite == ide) ) THEN + + DO j = jts, jte-1 + DO k = kts, ktf + vxgm(ite,k,j) = vxgm(ite-1,k,j) + ENDDO + ENDDO + + ENDIF + + IF ( ( config_flags%open_ys .or. specified .or. & + config_flags%nested) .and. (jts == jds) ) THEN + + DO k = kts, ktf + DO i = its-1, ite + vxgm(i,k,jts-1) = vxgm(i,k,jts) + ENDDO + ENDDO + + ENDIF + + IF ( ( config_flags%open_ye .or. specified .or. & + config_flags%nested) .and. (jte == jde) ) THEN + + DO k = kts, ktf + DO i = its-1, ite + vxgm(i,k,jte) = vxgm(i,k,jte-1) + ENDDO + ENDDO + + ENDIF + +! curvature term for u momentum eqn. + + i_start = its + IF ( config_flags%open_xs .or. specified .or. & + config_flags%nested) i_start = MAX ( ids+1 , its ) + IF ( config_flags%open_xe .or. specified .or. & + config_flags%nested) i_end = MIN ( ide-1 , ite ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + DO j=jts,MIN(jde-1,jte) + DO k=kts,ktf + DO i=i_start,i_end + + ru_tend(i,k,j)=ru_tend(i,k,j) + 0.5*(vxgm(i,k,j)+vxgm(i-1,k,j)) & + *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) & + - u(i,k,j)*reradius & + *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j)) + + ENDDO + ENDDO + ENDDO + +! curvature term for v momentum eqn. + + j_start = jts + IF ( config_flags%open_ys .or. specified .or. & + config_flags%nested) j_start = MAX ( jds+1 , jts ) + IF ( config_flags%open_ye .or. specified .or. & + config_flags%nested) j_end = MIN ( jde-1 , jte ) + + DO j=j_start,j_end + DO k=kts,ktf + DO i=its,MIN(ite,ide-1) + + rv_tend(i,k,j)=rv_tend(i,k,j) - 0.5*(vxgm(i,k,j)+vxgm(i,k,j-1)) & + *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) & + + v(i,k,j)*reradius & + *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j)) + + ENDDO + ENDDO + ENDDO + +! curvature term for vertical momentum eqn. + + DO j=jts,MIN(jte,jde-1) + DO k=MAX(2,kts),ktf + DO i=its,MIN(ite,ide-1) + + rw_tend(i,k,j)=rw_tend(i,k,j) + reradius* & + (0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j))+fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j))) & + *0.5*(fzm(k)*( u(i,k,j) +u(i+1,k,j))+fzp(k)*( u(i,k-1,j) +u(i+1,k-1,j))) & + +0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1))+fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1))) & + *0.5*(fzm(k)*( v(i,k,j) +v(i,k,j+1))+fzp(k)*( v(i,k-1,j) +v(i,k-1,j+1)))) + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE curvature + +!------------------------------------------------------------------------------ + +SUBROUTINE decouple ( rr, rfield, field, name, config_flags, & + fzm, fzp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + CHARACTER(LEN=1) , INTENT(IN ) :: name + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rfield + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rr + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT ) :: field + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, fzp + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! decouple decouples a variable from the column dry-air mass. +! +! + + ktf=MIN(kte,kde-1) + + IF (name .EQ. 'u')THEN + itf=ite + jtf=MIN(jte,jde-1) + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + field(i,k,j)=rfield(i,k,j)/(0.5*(rr(i,k,j)+rr(i-1,k,j))) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'v')THEN + itf=MIN(ite,ide-1) + jtf=jte + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + field(i,k,j)=rfield(i,k,j)/(0.5*(rr(i,k,j)+rr(i,k,j-1))) + ENDDO + ENDDO + ENDDO + + ELSE IF (name .EQ. 'w')THEN + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + DO j=jts,jtf + DO k=kts+1,ktf + DO i=its,itf + field(i,k,j)=rfield(i,k,j)/(fzm(k)*rr(i,k,j)+fzp(k)*rr(i,k-1,j)) + ENDDO + ENDDO + ENDDO + + DO j=jts,jtf + DO i=its,itf + field(i,kte,j) = 0. + ENDDO + ENDDO + + ELSE + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ! For theta we will decouple tb and tp and add them to give t afterwards + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + field(i,k,j)=rfield(i,k,j)/rr(i,k,j) + ENDDO + ENDDO + ENDDO + + ENDIF + +END SUBROUTINE decouple + +!------------------------------------------------------------------------------- + + +SUBROUTINE zero_tend ( tendency, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! zero_tend sets the input tendency array to zero. +! +! + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + tendency(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + END SUBROUTINE zero_tend + +!====================================================================== +! physics prep routines +!====================================================================== + + SUBROUTINE phy_prep ( config_flags, & ! input + mu, muu, muv, u, v, p, pb, alt, ph, & ! input + phb, t, tsk, moist, n_moist, & ! input + mu_3d, rho, th_phy, p_phy , pi_phy , & ! output + u_phy, v_phy, p8w, t_phy, t8w, & ! output + z, z_at_w, dz8w, & ! output + fzm, fzp, & ! params + RTHRATEN, & + RTHBLTEN, RUBLTEN, RVBLTEN, & + RQVBLTEN, RQCBLTEN, RQIBLTEN, & + RTHCUTEN, RQVCUTEN, RQCCUTEN, & + RQRCUTEN, RQICUTEN, RQSCUTEN, & + RTHFTEN, RQVFTEN, & + RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN, & + RQVNDGDTEN, RMUNDGDTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: n_moist + + REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN) :: moist + + + REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: TSK, mu, muu, muv + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT( OUT) :: u_phy, & + v_phy, & + pi_phy, & + p_phy, & + p8w, & + t_phy, & + th_phy, & + t8w, & + mu_3d, & + rho, & + z, & + dz8w, & + z_at_w + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: pb, & + p, & + u, & + v, & + alt, & + ph, & + phb, & + t + + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATEN + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHFTEN, & + RQVFTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RUNDGDTEN, & + RVNDGDTEN, & + RTHNDGDTEN, & + RQVNDGDTEN, & + RMUNDGDTEN + + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv + INTEGER :: i, j, k + REAL :: w1, w2, z0, z1, z2 + +!----------------------------------------------------------------------- + +! +! +! phys_prep calculates a number of diagnostic quantities needed by +! the physics routines. It also decouples the physics tendencies from +! the column dry-air mass (the physics routines expect to see/update the +! uncoupled tendencies). +! +! + +! set up loop bounds for this grid's boundary conditions + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) + + k_start = kts + k_end = min( kte, kde-1 ) + +! compute thermodynamics and velocities at pressure points + + do j = j_start,j_end + do k = k_start, k_end + do i = i_start, i_end + + th_phy(i,k,j) = t(i,k,j) + t0 + p_phy(i,k,j) = p(i,k,j) + pb(i,k,j) + pi_phy(i,k,j) = (p_phy(i,k,j)/p1000mb)**rcp + t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) + rho(i,k,j) = 1./alt(i,k,j)*(1.+moist(i,k,j,P_QV)) + mu_3d(i,k,j) = mu(i,j) + u_phy(i,k,j) = 0.5*(u(i,k,j)+u(i+1,k,j)) + v_phy(i,k,j) = 0.5*(v(i,k,j)+v(i,k,j+1)) + + enddo + enddo + enddo + +! compute z at w points + + do j = j_start,j_end + do k = k_start, kte + do i = i_start, i_end + z_at_w(i,k,j) = (phb(i,k,j)+ph(i,k,j))/g + enddo + enddo + enddo + + do j = j_start,j_end + do k = k_start, kte-1 + do i = i_start, i_end + dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j) + enddo + enddo + enddo + + do j = j_start,j_end + do i = i_start, i_end + dz8w(i,kte,j) = 0. + enddo + enddo + +! compute z at p points (average of z at w points) + + do j = j_start,j_end + do k = k_start, k_end + do i = i_start, i_end + z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) ) + enddo + enddo + enddo + +! interp t and p at w points + + do j = j_start,j_end + do k = 2, k_end + do i = i_start, i_end + p8w(i,k,j) = fzm(k)*p_phy(i,k,j)+fzp(k)*p_phy(i,k-1,j) + t8w(i,k,j) = fzm(k)*t_phy(i,k,j)+fzp(k)*t_phy(i,k-1,j) + enddo + enddo + enddo + +! extrapolate p and t to surface and top. +! we'll use an extrapolation in z for now + + do j = j_start,j_end + do i = i_start, i_end + +! bottom + + z0 = z_at_w(i,1,j) + z1 = z(i,1,j) + z2 = z(i,2,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 + p8w(i,1,j) = w1*p_phy(i,1,j)+w2*p_phy(i,2,j) + t8w(i,1,j) = w1*t_phy(i,1,j)+w2*t_phy(i,2,j) + +! top + + z0 = z_at_w(i,kte,j) + z1 = z(i,k_end,j) + z2 = z(i,k_end-1,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 + +! p8w(i,kde,j) = w1*p_phy(i,kde-1,j)+w2*p_phy(i,kde-2,j) +!!! bug fix extrapolate ln(p) so p is positive definite + p8w(i,kde,j) = exp(w1*log(p_phy(i,kde-1,j))+w2*log(p_phy(i,kde-2,j))) + t8w(i,kde,j) = w1*t_phy(i,kde-1,j)+w2*t_phy(i,kde-2,j) + + enddo + enddo + +! decouple all physics tendencies + + IF (config_flags%ra_lw_physics .gt. 0 .or. config_flags%ra_sw_physics .gt. 0) THEN + + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + + ENDIF + + IF (config_flags%cu_physics .gt. 0) THEN + + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + + IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + + IF (config_flags%bl_pbl_physics .gt. 0) THEN + + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RUBLTEN(I,K,J) =RUBLTEN(I,K,J)/mu(I,J) + RVBLTEN(I,K,J) =RVBLTEN(I,K,J)/mu(I,J) + RTHBLTEN(I,K,J)=RTHBLTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + + IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RQVBLTEN(I,K,J)=RQVBLTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QC .ge. PARAM_FIRST_SCALAR) THEN + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RQCBLTEN(I,K,J)=RQCBLTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. PARAM_FIRST_SCALAR) THEN + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RQIBLTEN(I,K,J)=RQIBLTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + +! decouple advective forcing required by Grell-Devenyi scheme + + if ( config_flags%cu_physics == GDSCHEME ) then + + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + + IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN + DO J=j_start,j_end + DO I=i_start,i_end + DO K=k_start,k_end + RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + END IF + +! fdda +! note fdda u and v tendencies are staggered, also only interior points have muu/muv, +! so only decouple those + + IF (config_flags%grid_fdda .gt. 0) THEN + + i_startu=MAX(its,ids+1) + j_startv=MAX(jts,jds+1) + + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_startu,i_end + RUNDGDTEN(I,K,J) =RUNDGDTEN(I,K,J)/muu(I,J) + ENDDO + ENDDO + ENDDO + DO J=j_startv,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RVNDGDTEN(I,K,J) =RVNDGDTEN(I,K,J)/muv(I,J) + ENDDO + ENDDO + ENDDO + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RTHNDGDTEN(I,K,J)=RTHNDGDTEN(I,K,J)/mu(I,J) +! RMUNDGDTEN(I,J) - no coupling + ENDDO + ENDDO + ENDDO + IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN + DO J=j_start,j_end + DO K=k_start,k_end + DO I=i_start,i_end + RQVNDGDTEN(I,K,J)=RQVNDGDTEN(I,K,J)/mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + +END SUBROUTINE phy_prep + +!------------------------------------------------------------ + + SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & + p, p8w, p0, pb, ph, phb, & + th_phy, pii, pf, & + z, z_at_w, dz8w, & + dt,h_diabatic, & + config_flags,fzm, fzp, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + +! Here we construct full fields +! needed by the microphysics + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dt + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN ) :: al, & + alb, & + p, & + pb, & + ph, & + phb + + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT( OUT) :: rho, & + th_phy, & + pii, & + pf, & + z, & + z_at_w, & + dz8w, & + p8w +! pjj/cray +! p8w, & +! h_diabatic + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: h_diabatic + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: t_new, & + t_old + + REAL, INTENT(IN ) :: t0, p0 + REAL :: z0,z1,z2,w1,w2 + + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i, j, k + +!-------------------------------------------------------------------- + +! +! +! moist_phys_prep_em calculates a number of diagnostic quantities needed by +! the microphysics routines. +! +! + +! set up loop bounds for this grid's boundary conditions + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) + + k_start = kts + k_end = min( kte, kde-1 ) + + DO j = j_start, j_end + DO k = k_start, kte + DO i = i_start, i_end + z_at_w(i,k,j) = (ph(i,k,j)+phb(i,k,j))/g + ENDDO + ENDDO + ENDDO + + do j = j_start,j_end + do k = k_start, kte-1 + do i = i_start, i_end + dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j) + enddo + enddo + enddo + + do j = j_start,j_end + do i = i_start, i_end + dz8w(i,kte,j) = 0. + enddo + enddo + + + ! compute full pii, rho, and z at the new time-level + ! (needed for physics). + ! convert perturbation theta to full theta (th_phy) + ! use h_diabatic to temporarily save pre-microphysics full theta + + DO j = j_start, j_end + DO k = k_start, k_end + DO i = i_start, i_end + +#ifdef REVERT + t_new(i,k,j) = t_new(i,k,j)-h_diabatic(i,k,j)*dt +#endif + th_phy(i,k,j) = t_new(i,k,j) + t0 + h_diabatic(i,k,j) = th_phy(i,k,j) + rho(i,k,j) = 1./(al(i,k,j)+alb(i,k,j)) + pii(i,k,j) = ((p(i,k,j)+pb(i,k,j))/p0)**rcp + z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) ) + pf(i,k,j) = p(i,k,j)+pb(i,k,j) + + ENDDO + ENDDO + ENDDO + +! interp t and p at w points + + do j = j_start,j_end + do k = 2, k_end + do i = i_start, i_end + p8w(i,k,j) = fzm(k)*pf(i,k,j)+fzp(k)*pf(i,k-1,j) + enddo + enddo + enddo + +! extrapolate p and t to surface and top. +! we'll use an extrapolation in z for now + + do j = j_start,j_end + do i = i_start, i_end + +! bottom + + z0 = z_at_w(i,1,j) + z1 = z(i,1,j) + z2 = z(i,2,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 + p8w(i,1,j) = w1*pf(i,1,j)+w2*pf(i,2,j) + +! top + + z0 = z_at_w(i,kte,j) + z1 = z(i,k_end,j) + z2 = z(i,k_end-1,j) + w1 = (z0 - z2)/(z1 - z2) + w2 = 1. - w1 +! p8w(i,kde,j) = w1*pf(i,kde-1,j)+w2*pf(i,kde-2,j) + p8w(i,kde,j) = exp(w1*log(pf(i,kde-1,j))+w2*log(pf(i,kde-2,j))) + + enddo + enddo + + END SUBROUTINE moist_physics_prep_em + +!------------------------------------------------------------------------------ + + SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & + th_phy, h_diabatic, dt, & + config_flags, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + +! Here we construct full fields +! needed by the microphysics + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: t_new, & + t_old, & + th_phy, & + h_diabatic + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: mut + + + REAL, INTENT(IN ) :: t0, dt + + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i, j, k + +!-------------------------------------------------------------------- + +! +! +! moist_phys_finish_em resets theta to its perturbation value and +! computes and stores the microphysics diabatic heating term. +! +! + +! set up loop bounds for this grid's boundary conditions + + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) + + k_start = kts + k_end = min( kte, kde-1 ) + +! add microphysics theta diff to perturbation theta, set h_diabatic + + DO j = j_start, j_end + DO k = k_start, k_end + DO i = i_start, i_end + + t_new(i,k,j) = t_new(i,k,j) + (th_phy(i,k,j)-h_diabatic(i,k,j)) + h_diabatic(i,k,j) = (th_phy(i,k,j)-h_diabatic(i,k,j))/dt +! h_diabatic(i,k,j) = 0. + + ENDDO + ENDDO + ENDDO + + END SUBROUTINE moist_physics_finish_em + +!---------------------------------------------------------------- + + + SUBROUTINE init_module_big_step + END SUBROUTINE init_module_big_step + +SUBROUTINE set_tend ( field, field_adv_tend, msf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: field + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN) :: field_adv_tend + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: msf + + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + +! +! +! set_tend copies the advective tendency array into the tendency array. +! +! + + jtf = MIN(jte,jde-1) + ktf = MIN(kte,kde-1) + itf = MIN(ite,ide-1) + DO j = jts, jtf + DO k = kts, ktf + DO i = its, itf + field(i,k,j) = field_adv_tend(i,k,j)*msf(i,j) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE set_tend + +!------------------------------------------------------------------------------ + + SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & + rw_tendf, t_tendf, & + u, v, w, t, t_init, & + mut, muu, muv, ph, phb, & + u_base, v_base, t_base, z_base, & + dampcoef, zdamp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Apr 2005 Modifications by George Bryan, NCAR: +! - Generalized the code in a way that allows for +! simulations with steep terrain. +! +! Jul 2004 Modifications by George Bryan, NCAR: +! - Modified the code to use u_base, v_base, and t_base +! arrays for the background state. Removed the hard-wired +! base-state values. +! - Modified the code to use dampcoef, zdamp, and damp_opt, +! i.e., the upper-level damper variables in namelist.input. +! Removed the hard-wired variables in the older version. +! This damper is used when damp_opt = 2. +! - Modified the code to account for the movement of the +! model surfaces with time. The code now obtains a base- +! state value by interpolation using the "_base" arrays. + +! Nov 2003 Bug fix by Jason Knievel, NCAR + +! Aug 2003 Meridional dimension, some comments, and +! changes in layout of the code added by +! Jason Knievel, NCAR + +! Jul 2003 Original code by Bill Skamarock, NCAR + +! Purpose: This routine applies Rayleigh damping to a layer at top +! of the model domain. + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: ru_tendf, rv_tendf, rw_tendf, t_tendf + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: u, v, w, t, t_init, ph, phb + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mut, muu, muv + + REAL, DIMENSION( kms:kme ) , INTENT(IN ) & + :: u_base, v_base, t_base, z_base + + REAL, INTENT(IN ) & + :: dampcoef, zdamp + +! Local variables. + + INTEGER & + :: i_start, i_end, j_start, j_end, k_start, k_end, i, j, k, ktf, k1, k2 + + REAL & + :: pii, dcoef, z, ztop + + REAL :: wkp1, wk, wkm1 + + REAL, DIMENSION( kms:kme ) :: z00, u00, v00, t00 + +! End declarations. +!----------------------------------------------------------------------- + + pii = 2.0 * asin(1.0) + + ktf = MIN( kte, kde-1 ) + +!----------------------------------------------------------------------- +! Adjust u to base state. + + DO j = jts, MIN( jte, jde-1 ) + DO i = its, MIN( ite, ide ) + + ! Get height at top of model + ztop = 0.5*( phb(i ,kde,j)+phb(i-1,kde,j) & + +ph(i ,kde,j)+ph(i-1,kde,j) )/g + + ! Find bottom of damping layer + k1 = ktf + z = ztop + DO WHILE( z >= (ztop-zdamp) ) + z = 0.25*( phb(i ,k1,j)+phb(i ,k1+1,j) & + +phb(i-1,k1,j)+phb(i-1,k1+1,j) & + +ph(i ,k1,j)+ph(i ,k1+1,j) & + +ph(i-1,k1,j)+ph(i-1,k1+1,j))/g + z00(k1) = z + k1 = k1 - 1 + ENDDO + k1 = k1 + 2 + + ! Get reference state at model levels + DO k = k1, ktf + k2 = ktf + DO WHILE( z_base(k2) .gt. z00(k) ) + k2 = k2 - 1 + ENDDO + if(k2+1.gt.ktf)then + u00(k) = u_base(k2) + ( u_base(k2) - u_base(k2-1) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2) - z_base(k2-1) ) + else + u00(k) = u_base(k2) + ( u_base(k2+1) - u_base(k2) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2+1) - z_base(k2) ) + endif + ENDDO + + ! Apply the Rayleigh damper + DO k = k1, ktf + dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp ) + dcoef = (SIN( 0.5 * pii * dcoef ) )**2 + ru_tendf(i,k,j) = ru_tendf(i,k,j) - & + muu(i,j) * ( dcoef * dampcoef ) * & + ( u(i,k,j) - u00(k) ) + END DO + + END DO + END DO + +! End adjustment of u. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Adjust v to base state. + + DO j = jts, MIN( jte, jde ) + DO i = its, MIN( ite, ide-1 ) + + ! Get height at top of model + ztop = 0.5*( phb(i,kde,j )+phb(i,kde,j-1) & + +ph(i,kde,j )+ph(i,kde,j-1) )/g + + ! Find bottom of damping layer + k1 = ktf + z = ztop + DO WHILE( z >= (ztop-zdamp) ) + z = 0.25*( phb(i,k1,j )+phb(i,k1+1,j ) & + +phb(i,k1,j-1)+phb(i,k1+1,j-1) & + +ph(i,k1,j )+ph(i,k1+1,j ) & + +ph(i,k1,j-1)+ph(i,k1+1,j-1))/g + z00(k1) = z + k1 = k1 - 1 + ENDDO + k1 = k1 + 2 + + ! Get reference state at model levels + DO k = k1, ktf + k2 = ktf + DO WHILE( z_base(k2) .gt. z00(k) ) + k2 = k2 - 1 + ENDDO + if(k2+1.gt.ktf)then + v00(k) = v_base(k2) + ( v_base(k2) - v_base(k2-1) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2) - z_base(k2-1) ) + else + v00(k) = v_base(k2) + ( v_base(k2+1) - v_base(k2) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2+1) - z_base(k2) ) + endif + ENDDO + + ! Apply the Rayleigh damper + DO k = k1, ktf + dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp ) + dcoef = (SIN( 0.5 * pii * dcoef ) )**2 + rv_tendf(i,k,j) = rv_tendf(i,k,j) - & + muv(i,j) * ( dcoef * dampcoef ) * & + ( v(i,k,j) - v00(k) ) + END DO + + END DO + END DO + +! End adjustment of v. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Adjust w to base state. + + DO j = jts, MIN( jte, jde-1 ) + DO i = its, MIN( ite, ide-1 ) + ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g + DO k = kts, MIN( kte, kde ) + z = ( phb(i,k,j) + ph(i,k,j) ) / g + IF ( z >= (ztop-zdamp) ) THEN + dcoef = 1.0 - MIN( 1.0, ( ztop - z ) / zdamp ) + dcoef = ( SIN( 0.5 * pii * dcoef ) )**2 + rw_tendf(i,k,j) = rw_tendf(i,k,j) - & + mut(i,j) * ( dcoef * dampcoef ) * w(i,k,j) + END IF + END DO + END DO + END DO + +! End adjustment of w. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Adjust potential temperature to base state. + + DO j = jts, MIN( jte, jde-1 ) + DO i = its, MIN( ite, ide-1 ) + + ! Get height at top of model + ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g + + ! Find bottom of damping layer + k1 = ktf + z = ztop + DO WHILE( z >= (ztop-zdamp) ) + z = 0.5 * ( phb(i,k1,j) + phb(i,k1+1,j) + & + ph(i,k1,j) + ph(i,k1+1,j) ) / g + z00(k1) = z + k1 = k1 - 1 + ENDDO + k1 = k1 + 2 + + ! Get reference state at model levels + DO k = k1, ktf + k2 = ktf + DO WHILE( z_base(k2) .gt. z00(k) ) + k2 = k2 - 1 + ENDDO + if(k2+1.gt.ktf)then + t00(k) = t_base(k2) + ( t_base(k2) - t_base(k2-1) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2) - z_base(k2-1) ) + else + t00(k) = t_base(k2) + ( t_base(k2+1) - t_base(k2) ) & + * ( z00(k) - z_base(k2) ) & + / ( z_base(k2+1) - z_base(k2) ) + endif + ENDDO + + ! Apply the Rayleigh damper + DO k = k1, ktf + dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp ) + dcoef = (SIN( 0.5 * pii * dcoef ) )**2 + t_tendf(i,k,j) = t_tendf(i,k,j) - & + mut(i,j) * ( dcoef * dampcoef ) * & + ( t(i,k,j) - t00(k) ) + END DO + + END DO + END DO + +! End adjustment of potential temperature. +!----------------------------------------------------------------------- + + END SUBROUTINE rk_rayleigh_damp + +!============================================================================== +!============================================================================== + + SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & + config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: 14 Nov 2006 Name of variable changed by Jason Knievel +! 07 Jun 2006 Revised and generalized by Jason Knievel +! 25 Apr 2005 Original code by Jason Knievel, NCAR + +! Purpose: Apply 6th-order, monotonic (flux-limited), numerical +! diffusion to 3-d velocity and to scalars. + +! References: Ming Xue (MWR Aug 2000) +! Durran ("Numerical Methods for Wave Equations..." 1999) +! George Bryan (personal communication) + +!------------------------------------------------------------------------------ +! Begin: Declarations. + + IMPLICIT NONE + + INTEGER, INTENT(IN) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + TYPE(grid_config_rec_type), INTENT(IN) & + :: config_flags + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) & + :: tendency + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) & + :: field + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) & + :: mu + + REAL, INTENT(IN) & + :: dt + + REAL, INTENT(IN) & + :: diff_6th_factor + + INTEGER, INTENT(IN) & + :: diff_6th_opt + + CHARACTER(LEN=1) , INTENT(IN) & + :: name + + INTEGER & + :: i, j, k, & + i_start, i_end, & + j_start, j_end, & + k_start, k_end, & + ktf + + REAL & + :: dflux_x_p0, dflux_y_p0, & + dflux_x_p1, dflux_y_p1, & + tendency_x, tendency_y, & + mu_avg_p0, mu_avg_p1, & + diff_6th_coef + + LOGICAL & + :: specified + +! End: Declarations. +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! Begin: Translate the diffusion factor into a diffusion coefficient. See +! Durran's text, section 2.4.3, then adjust for sixth-order diffusion (not +! fourth) and for diffusion in two dimensions (not one). For reference, a +! factor of 1.0 would mean complete diffusion of a 2dx wave in one time step, +! although application of the flux limiter reduces somewhat the effects of +! diffusion for a given coefficient. + + diff_6th_coef = diff_6th_factor * 0.015625 / ( 2.0 * dt ) + +! End: Translate diffusion factor. +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! Begin: Assign limits of spatial loops depending on variable to be diffused. +! The halo regions are already filled with values by the time this subroutine +! is called, which allows the stencil to extend beyond the domains' edges. + + ktf = MIN( kte, kde-1 ) + + IF ( name .EQ. 'u' ) THEN + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jde-1,jte) + k_start = kts + k_end = ktf + + ELSE IF ( name .EQ. 'v' ) THEN + + i_start = its + i_end = MIN(ide-1,ite) + j_start = jts + j_end = jte + k_start = kts + k_end = ktf + + ELSE IF ( name .EQ. 'w' ) THEN + + i_start = its + i_end = MIN(ide-1,ite) + j_start = jts + j_end = MIN(jde-1,jte) + k_start = kts+1 + k_end = ktf + + ELSE + + i_start = its + i_end = MIN(ide-1,ite) + j_start = jts + j_end = MIN(jde-1,jte) + k_start = kts + k_end = ktf + + ENDIF + +! End: Assignment of limits of spatial loops. +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! Begin: Loop across spatial dimensions. + + DO j = j_start, j_end + DO k = k_start, k_end + DO i = i_start, i_end + +!------------------------------------------------------------------------------ +! Begin: Diffusion in x (i index). + +! Calculate the diffusive flux in x direction (from Xue's eq. 3). + + dflux_x_p0 = ( 10.0 * ( field(i, k,j) - field(i-1,k,j) ) & + - 5.0 * ( field(i+1,k,j) - field(i-2,k,j) ) & + + ( field(i+2,k,j) - field(i-3,k,j) ) ) + + dflux_x_p1 = ( 10.0 * ( field(i+1,k,j) - field(i ,k,j) ) & + - 5.0 * ( field(i+2,k,j) - field(i-1,k,j) ) & + + ( field(i+3,k,j) - field(i-2,k,j) ) ) + +! If requested in the namelist (diff_6th_opt=2), prohibit up-gradient diffusion +! (variation on Xue's eq. 10). + + IF ( diff_6th_opt .EQ. 2 ) THEN + + IF ( dflux_x_p0 * ( field(i ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN + dflux_x_p0 = 0.0 + END IF + + IF ( dflux_x_p1 * ( field(i+1,k,j)-field(i ,k,j) ) .LE. 0.0 ) THEN + dflux_x_p1 = 0.0 + END IF + + END IF + +! Apply 6th-order diffusion in x direction. + + IF ( name .EQ. 'u' ) THEN + mu_avg_p0 = mu(i-1,j) + mu_avg_p1 = mu(i ,j) + ELSE IF ( name .EQ. 'v' ) THEN + mu_avg_p0 = 0.25 * ( & + mu(i-1,j-1) + & + mu(i ,j-1) + & + mu(i-1,j ) + & + mu(i ,j ) ) + mu_avg_p1 = 0.25 * ( & + mu(i ,j-1) + & + mu(i+1,j-1) + & + mu(i ,j ) + & + mu(i+1,j ) ) + ELSE + mu_avg_p0 = 0.5 * ( & + mu(i-1,j) + & + mu(i ,j) ) + mu_avg_p1 = 0.5 * ( & + mu(i ,j) + & + mu(i+1,j) ) + END IF + + tendency_x = diff_6th_coef * & + ( ( mu_avg_p1 * dflux_x_p1 ) - ( mu_avg_p0 * dflux_x_p0 ) ) + +! End: Diffusion in x. +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! Begin: Diffusion in y (j index). + +! Calculate the diffusive flux in y direction (from Xue's eq. 3). + + dflux_y_p0 = ( 10.0 * ( field(i,k,j ) - field(i,k,j-1) ) & + - 5.0 * ( field(i,k,j+1) - field(i,k,j-2) ) & + + ( field(i,k,j+2) - field(i,k,j-3) ) ) + + dflux_y_p1 = ( 10.0 * ( field(i,k,j+1) - field(i,k,j ) ) & + - 5.0 * ( field(i,k,j+2) - field(i,k,j-1) ) & + + ( field(i,k,j+3) - field(i,k,j-2) ) ) + +! If requested in the namelist (diff_6th_opt=2), prohibit up-gradient diffusion +! (variation on Xue's eq. 10). + + IF ( diff_6th_opt .EQ. 2 ) THEN + + IF ( dflux_y_p0 * ( field(i,k,j )-field(i,k,j-1) ) .LE. 0.0 ) THEN + dflux_y_p0 = 0.0 + END IF + + IF ( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j ) ) .LE. 0.0 ) THEN + dflux_y_p1 = 0.0 + END IF + + END IF + +! Apply 6th-order diffusion in y direction. + + IF ( name .EQ. 'u' ) THEN + mu_avg_p0 = 0.25 * ( & + mu(i-1,j-1) + & + mu(i ,j-1) + & + mu(i-1,j ) + & + mu(i ,j ) ) + mu_avg_p1 = 0.25 * ( & + mu(i-1,j ) + & + mu(i ,j ) + & + mu(i-1,j+1) + & + mu(i ,j+1) ) + ELSE IF ( name .EQ. 'v' ) THEN + mu_avg_p0 = mu(i,j-1) + mu_avg_p1 = mu(i,j ) + ELSE + mu_avg_p0 = 0.5 * ( & + mu(i,j-1) + & + mu(i,j ) ) + mu_avg_p1 = 0.5 * ( & + mu(i,j ) + & + mu(i,j+1) ) + END IF + + tendency_y = diff_6th_coef * & + ( ( mu_avg_p1 * dflux_y_p1 ) - ( mu_avg_p0 * dflux_y_p0 ) ) + +! End: Diffusion in y. +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! Begin: Combine diffusion in x and y. + + tendency(i,k,j) = tendency(i,k,j) + tendency_x + tendency_y + +! End: Combine diffusion in x and y. +!------------------------------------------------------------------------------ + + ENDDO + ENDDO + ENDDO + +! End: Loop across spatial dimensions. +!------------------------------------------------------------------------------ + + END SUBROUTINE sixth_order_diffusion + +!============================================================================== +!============================================================================== + +END MODULE module_big_step_utilities_em diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F new file mode 100644 index 00000000..e3975a2c --- /dev/null +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -0,0 +1,5224 @@ +! WRF:MODEL_LAYER:PHYSICS + + MODULE module_diffusion_em + + USE module_configure + USE module_bc + USE module_state_description + USE module_big_step_utilities_em + USE module_model_constants + USE module_wrf_error + + CONTAINS + +!======================================================================= +!======================================================================= + + SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + u_base, v_base,msfu, msfv, msft, & + rdx, rdy, dn, dnw, rdz, rdzw, & + fnm, fnp, cf1, cf2, cf3, zx, zy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by Jason Knievel and George Bryan, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! ... ... + +! Purpose: This routine calculates deformation and 3-d divergence. + +! References: Klemp and Wilhelmson (JAS 1978) +! Chen and Dudhia (NCAR WRF physics report 2000) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: rdx, rdy, cf1, cf2, cf3 + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: fnm, fnp, dn, dnw, u_base, v_base + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT( IN ) & + :: msfu, msfv, msft + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: u, v, w, zx, zy, rdz, rdzw + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: defor11, defor22, defor33, defor12, defor13, defor23, div + +! Local variables. + + INTEGER & + :: i, j, k, ktf, ktes1, ktes2, i_start, i_end, j_start, j_end + + REAL & + :: tmp, tmpzx, tmpzy, tmpzeta_z, cft1, cft2 + + REAL, DIMENSION( its:ite, jts:jte ) & + :: mm, zzavg, zeta_zd12 + + REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) & + :: tmp1, hat, hatavg + +! End declarations. +!----------------------------------------------------------------------- + +!======================================================================= +! In the following section, calculate 3-d divergence and the first three +! (defor11, defor22, defor33) of six deformation terms. + + ktes1 = kte-1 + ktes2 = kte-2 + + cft2 = - 0.5 * dnw(ktes1) / dn(ktes1) + cft1 = 1.0 - cft2 + + ktf = MIN( kte, kde-1 ) + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + +! Square the map scale factor. + + DO j = j_start, j_end + DO i = i_start, i_end + mm(i,j) = msft(i,j) * msft(i,j) + END DO + END DO + +!----------------------------------------------------------------------- +! Calculate du/dx. + +! Apply a coordinate transformation to zonal velocity, u. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end+1 + hat(i,k,j) = u(i,k,j) / msfu(i,j) + END DO + END DO + END DO + +! Average in x and z. + + DO j=j_start,j_end + DO k=kts+1,ktf + DO i=i_start,i_end + hatavg(i,k,j) = 0.5 * & + ( fnm(k) * ( hat(i,k ,j) + hat(i+1, k,j) ) + & + fnp(k) * ( hat(i,k-1,j) + hat(i+1,k-1,j) ) ) + END DO + END DO + END DO + +! Extrapolate to top and bottom of domain (to w levels). + + DO j = j_start, j_end + DO i = i_start, i_end + hatavg(i,1,j) = 0.5 * ( & + cf1 * hat(i ,1,j) + & + cf2 * hat(i ,2,j) + & + cf3 * hat(i ,3,j) + & + cf1 * hat(i+1,1,j) + & + cf2 * hat(i+1,2,j) + & + cf3 * hat(i+1,3,j) ) + hatavg(i,kte,j) = 0.5 * ( & + cft1 * ( hat(i,ktes1,j) + hat(i+1,ktes1,j) ) + & + cft2 * ( hat(i,ktes2,j) + hat(i+1,ktes2,j) ) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmpzx = 0.25 * ( & + zx(i,k ,j) + zx(i+1,k ,j) + & + zx(i,k+1,j) + zx(i+1,k+1,j) ) + tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *tmpzx * rdzw(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp1(i,k,j) = mm(i,j) * ( rdx * ( hat(i+1,k,j) - hat(i,k,j) ) - & + tmp1(i,k,j)) + END DO + END DO + END DO + +! End calculation of du/dx. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate defor11 (2*du/dx). + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + defor11(i,k,j) = 2.0 * tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of defor11. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate zonal divergence (du/dx) and add it to the divergence array. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + div(i,k,j) = tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of zonal divergence. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dv/dy. + +! Apply a coordinate transformation to meridional velocity, v. + + DO j = j_start, j_end+1 + DO k = kts, ktf + DO i = i_start, i_end + hat(i,k,j) = v(i,k,j) / msfv(i,j) + END DO + END DO + END DO + +! Account for the slope in y of eta surfaces. + + DO j=j_start,j_end + DO k=kts+1,ktf + DO i=i_start,i_end + hatavg(i,k,j) = 0.5 * ( & + fnm(k) * ( hat(i,k ,j) + hat(i,k ,j+1) ) + & + fnp(k) * ( hat(i,k-1,j) + hat(i,k-1,j+1) ) ) + END DO + END DO + END DO + +! Extrapolate to top and bottom of domain (to w levels). + + DO j = j_start, j_end + DO i = i_start, i_end + hatavg(i,1,j) = 0.5 * ( & + cf1 * hat(i,1,j ) + & + cf2 * hat(i,2,j ) + & + cf3 * hat(i,3,j ) + & + cf1 * hat(i,1,j+1) + & + cf2 * hat(i,2,j+1) + & + cf3 * hat(i,3,j+1) ) + hatavg(i,kte,j) = 0.5 * ( & + cft1 * ( hat(i,ktes1,j) + hat(i,ktes1,j+1) ) + & + cft2 * ( hat(i,ktes2,j) + hat(i,ktes2,j+1) ) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmpzy = 0.25 * ( & + zy(i,k ,j) + zy(i,k ,j+1) + & + zy(i,k+1,j) + zy(i,k+1,j+1) ) + tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * tmpzy * rdzw(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp1(i,k,j) = mm(i,j) * ( & + rdy * ( hat(i,k,j+1) - hat(i,k,j) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + +! End calculation of dv/dy. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate defor22 (2*dv/dy). + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + defor22(i,k,j) = 2.0 * tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of defor22. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate meridional divergence (dv/dy) and add it to the divergence +! array. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + div(i,k,j) = div(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of meridional divergence. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dw/dz. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( w(i,k+1,j) - w(i,k,j) ) * rdzw(i,k,j) + END DO + END DO + END DO + +! End calculation of dw/dz. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate defor33 (2*dw/dz). + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + defor33(i,k,j) = 2.0 * tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of defor33. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate vertical divergence (dw/dz) and add it to the divergence +! array. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + div(i,k,j) = div(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + +! End calculation of vertical divergence. +!----------------------------------------------------------------------- + +! Three-dimensional divergence is now finished and values are in array +! "div." Also, the first three (defor11, defor22, defor33) of six +! deformation terms are now calculated at pressure points. +!======================================================================= + +!======================================================================= +! Calculate the final three deformations (defor12, defor13, defor23) at +! vorticity points. + + i_start = its + i_end = ite + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-1, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-1, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + +!----------------------------------------------------------------------- +! Calculate du/dy. + +! First, calculate an average mapscale factor. + + DO j = j_start, j_end + DO i = i_start, i_end + mm(i,j) = 0.25 * ( msfu(i,j-1) + msfu(i,j) ) * ( msfv(i-1,j) + msfv(i,j) ) + END DO + END DO + +! Apply a coordinate transformation to zonal velocity, u. + + DO j =j_start-1, j_end + DO k =kts, ktf + DO i =i_start, i_end + hat(i,k,j) = u(i,k,j) / msfu(i,j) + END DO + END DO + END DO + +! Average in y and z. + + DO j=j_start,j_end + DO k=kts+1,ktf + DO i=i_start,i_end + hatavg(i,k,j) = 0.5 * ( & + fnm(k) * ( hat(i,k ,j-1) + hat(i,k ,j) ) + & + fnp(k) * ( hat(i,k-1,j-1) + hat(i,k-1,j) ) ) + END DO + END DO + END DO + +! Extrapolate to top and bottom of domain (to w levels). + + DO j = j_start, j_end + DO i = i_start, i_end + hatavg(i,1,j) = 0.5 * ( & + cf1 * hat(i,1,j-1) + & + cf2 * hat(i,2,j-1) + & + cf3 * hat(i,3,j-1) + & + cf1 * hat(i,1,j ) + & + cf2 * hat(i,2,j ) + & + cf3 * hat(i,3,j ) ) + hatavg(i,kte,j) = 0.5 * ( & + cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) + & + cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmpzy = 0.25 * ( & + zy(i-1,k ,j) + zy(i,k ,j) + & + zy(i-1,k+1,j) + zy(i,k+1,j) ) + tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & + 0.5 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) ) + END DO + END DO + END DO + +! End calculation of du/dy. +!---------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add the first term to defor12 (du/dy+dv/dx) at vorticity points. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + defor12(i,k,j) = mm(i,j) * ( & + rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + +! End addition of the first term to defor12. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dv/dx. + +! Apply a coordinate transformation to meridional velocity, v. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start-1, i_end + hat(i,k,j) = v(i,k,j) / msfv(i,j) + END DO + END DO + END DO + +! Account for the slope in x of eta surfaces. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + hatavg(i,k,j) = 0.5 * ( & + fnm(k) * ( hat(i-1,k ,j) + hat(i,k ,j) ) + & + fnp(k) * ( hat(i-1,k-1,j) + hat(i,k-1,j) ) ) + END DO + END DO + END DO + +! Extrapolate to top and bottom of domain (to w levels). + + DO j = j_start, j_end + DO i = i_start, i_end + hatavg(i,1,j) = 0.5 * ( & + cf1 * hat(i-1,1,j) + & + cf2 * hat(i-1,2,j) + & + cf3 * hat(i-1,3,j) + & + cf1 * hat(i ,1,j) + & + cf2 * hat(i ,2,j) + & + cf3 * hat(i ,3,j) ) + hatavg(i,kte,j) = 0.5 * ( & + cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) + & + cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmpzx = 0.25 * ( & + zx(i,k ,j-1) + zx(i,k ,j) + & + zx(i,k+1,j-1) + zx(i,k+1,j) ) + tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * & + 0.5 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) ) + END DO + END DO + END DO + +! End calculation of dv/dx. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add the second term to defor12 (du/dy+dv/dx) at vorticity points. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + defor12(i,k,j) = defor12(i,k,j) + & + mm(i,j) * ( & + rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + +! End addition of the second term to defor12. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Update the boundary for defor12 (might need to change later). + + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN + DO j = jts, jte + DO k = kts, kte + defor12(ids,k,j) = defor12(ids+1,k,j) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN + DO k = kts, kte + DO i = its, ite + defor12(i,k,jds) = defor12(i,k,jds+1) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN + DO j = jts, jte + DO k = kts, kte + defor12(ide,k,j) = defor12(ide-1,k,j) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN + DO k = kts, kte + DO i = its, ite + defor12(i,k,jde) = defor12(i,k,jde-1) + END DO + END DO + END IF + +! End update of boundary for defor12. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dw/dx. + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide ) + IF ( config_flags%periodic_y ) j_end = MIN( jte, jde ) + +! Square the mapscale factor. + + DO j = jts, jte + DO i = its, ite + mm(i,j) = msfu(i,j) * msfu(i,j) + END DO + END DO + +! Apply a coordinate transformation to vertical velocity, w. This is for both +! defor13 and defor23. + + DO j = j_start, j_end + DO k = kts, kte + DO i = i_start, i_end + hat(i,k,j) = w(i,k,j) / msft(i,j) + END DO + END DO + END DO + + i = i_start-1 + DO j = j_start, MIN( jte, jde-1 ) + DO k = kts, kte + hat(i,k,j) = w(i,k,j) / msft(i,j) + END DO + END DO + + j = j_start-1 + DO k = kts, kte + DO i = i_start, MIN( ite, ide-1 ) + hat(i,k,j) = w(i,k,j) / msft(i,j) + END DO + END DO + +! QUESTION: What is this for? + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + hatavg(i,k,j) = 0.25 * ( & + hat(i ,k ,j) + & + hat(i ,k+1,j) + & + hat(i-1,k ,j) + & + hat(i-1,k+1,j) ) + END DO + END DO + END DO + +! Calculate dw/dx. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zx(i,k,j) * & + 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) ) + END DO + END DO + END DO + +! End calculation of dw/dx. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add the first term (dw/dx) to defor13 (dw/dx+du/dz) at vorticity +! points. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + defor13(i,k,j) = mm(i,j) * ( & + rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + defor13(i,kts,j ) = 0.0 + defor13(i,ktf+1,j) = 0.0 + END DO + END DO + +! End addition of the first term to defor13. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate du/dz. + + IF ( config_flags%mix_full_fields ) THEN + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( u(i,k,j) - u(i,k-1,j) ) * & + 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) ) + END DO + END DO + END DO + + ELSE + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( u(i,k,j) - u_base(k) - u(i,k-1,j) + u_base(k-1) ) * & + 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) ) + END DO + END DO + END DO + + END IF + +!----------------------------------------------------------------------- +! Add the second term (du/dz) to defor13 (dw/dx+du/dz) at vorticity +! points. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + +! End addition of the second term to defor13. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dw/dy. + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%periodic_y ) j_end = MIN( jte, jde ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + +! Square mapscale factor. + + DO j = jts, jte + DO i = its, ite + mm(i,j) = msfv(i,j) * msfv(i,j) + END DO + END DO + +! QUESTION: What is this for? + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + hatavg(i,k,j) = 0.25 * ( & + hat(i,k ,j ) + & + hat(i,k+1,j ) + & + hat(i,k ,j-1) + & + hat(i,k+1,j-1) ) + END DO + END DO + END DO + +! Calculate dw/dy and store in tmp1. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zy(i,k,j) * & + 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) ) + END DO + END DO + END DO + +! End calculation of dw/dy. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add the first term (dw/dy) to defor23 (dw/dy+dv/dz) at vorticity +! points. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + defor23(i,k,j) = mm(i,j) * ( & + rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + defor23(i,kts,j ) = 0.0 + defor23(i,ktf+1,j) = 0.0 + END DO + END DO + +! End addition of the first term to defor23. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Calculate dv/dz. + + IF ( config_flags%mix_full_fields ) THEN + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( v(i,k,j) - v(i,k-1,j) ) * & + 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) ) + END DO + END DO + END DO + + ELSE + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tmp1(i,k,j) = ( v(i,k,j) - v_base(k) - v(i,k-1,j) + v_base(k-1) ) * & + 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) ) + END DO + END DO + END DO + + END IF + +! End calculation of dv/dz. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add the second term (dv/dz) to defor23 (dw/dy+dv/dz) at vorticity +! points. + +! Add tmp1 to defor23. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + +! End addition of the second term to defor23. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Update the boundary for defor13 and defor23 (might need to change +! later). + + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN + DO j = jts, jte + DO k = kts, kte + defor13(ids,k,j) = defor13(ids+1,k,j) + defor23(ids,k,j) = defor23(ids+1,k,j) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN + DO k = kts, kte + DO i = its, ite + defor13(i,k,jds) = defor13(i,k,jds+1) + defor23(i,k,jds) = defor23(i,k,jds+1) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN + DO j = jts, jte + DO k = kts, kte + defor13(ide,k,j) = defor13(ide-1,k,j) + defor23(ide,k,j) = defor23(ide-1,k,j) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN + DO k = kts, kte + DO i = its, ite + defor13(i,k,jde) = defor13(i,k,jde-1) + defor23(i,k,jde) = defor23(i,k,jde-1) + END DO + END DO + END IF + +! End update of boundary for defor13 and defor23. +!----------------------------------------------------------------------- + +! The second three (defor12, defor13, defor23) of six deformation terms +! are now calculated at vorticity points. +!======================================================================= + + END SUBROUTINE cal_deform_and_div + +!======================================================================= +!======================================================================= + + SUBROUTINE calculate_km_kh( config_flags, dt, & + dampcoef, zdamp, damp_opt, & + xkmh, xkmhd, xkmv, xkhh, xkhv, & + BN2, khdif, kvdif, div, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + tke, p8w, t8w, theta, t, p, moist, & + dn, dnw, dx, dy, rdz, rdzw, cr_len, & + n_moist, cf1, cf2, cf3, warm_rain, & + kh_tke_upper_bound, kv_tke_upper_bound, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! ... ... + +! Purpose: This routine calculates exchange coefficients for the TKE +! scheme. + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: n_moist, damp_opt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL, INTENT( IN ) & + :: warm_rain + + REAL, INTENT( IN ) & + :: cr_len, dx, dy, zdamp, dt, dampcoef, cf1, cf2, cf3, khdif, kvdif + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: dnw, dn + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) & + :: moist + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: xkmv, xkmh, xkmhd, xkhv, xkhh, BN2 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT( IN ) & + :: defor11, defor22, defor33, defor12, defor13, defor23, & + div, rdz, rdzw, p8w, t8w, theta, t, p + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: tke + + REAL, INTENT( IN ) & + :: kh_tke_upper_bound, kv_tke_upper_bound + +! Local variables. + + INTEGER & + :: i_start, i_end, j_start, j_end, ktf, i, j, k + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + CALL calculate_N2( config_flags, BN2, moist, & + theta, t, p, p8w, t8w, & + dnw, dn, rdz, rdzw, & + n_moist, cf1, cf2, cf3, warm_rain, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! Select a scheme for calculating diffusion coefficients. + + km_coef: SELECT CASE( config_flags%km_opt ) + + CASE (1) + CALL isotropic_km( config_flags, xkmh, xkmhd, xkmv, & + xkhh, xkhv, khdif, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (2) + CALL tke_km( config_flags, xkmh, xkmhd, xkmv, & + xkhh, xkhv, BN2, tke, p8w, t8w, theta, & + rdz, rdzw, dx, dy, cr_len, & + kh_tke_upper_bound, kv_tke_upper_bound, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (3) + CALL smag_km( config_flags, xkmh, xkmhd, xkmv, & + xkhh, xkhv, BN2, div, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + rdzw, dx, dy, cr_len, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (4) + CALL smag2d_km( config_flags, xkmh, xkmhd, xkmv, & + xkhh, xkhv, defor11, defor22, defor12, & + rdzw, dx, dy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE DEFAULT + CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' ) + + END SELECT km_coef + + IF ( damp_opt .eq. 1 ) THEN + CALL cal_dampkm( config_flags, xkmhd, xkmh, xkhh, xkmv, xkhv, & + dx, dy, dt, dampcoef, rdz, rdzw, zdamp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + END IF + + END SUBROUTINE calculate_km_kh + +!======================================================================= + +SUBROUTINE cal_dampkm( config_flags,xkmhd,xkmh,xkhh,xkmv,xkhv, & + dx,dy,dt,dampcoef, & + rdz, rdzw ,zdamp, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN ) :: zdamp,dx,dy,dt,dampcoef + + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmhd, & + xkmh , & + xkhh , & + xkmv , & + xkhv + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdz, & + rdzw +! LOCAL VARS + + INTEGER :: i_start, i_end, j_start, j_end, ktf, ktfm1, i, j, k + REAL :: kmmax,kmmvmax,degrad90,dz,tmp + REAL , DIMENSION( its:ite ) :: deltaz + REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: dampk,dampkv + +! End declarations. +!----------------------------------------------------------------------- + + ktf = min(kte,kde-1) + ktfm1 = ktf-1 + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! keep upper damping diffusion away from relaxation zones at boundaries if used + IF(config_flags%specified .OR. config_flags%nested)THEN + i_start = MAX(i_start,ids+config_flags%spec_bdy_width-1) + i_end = MIN(i_end,ide-config_flags%spec_bdy_width) + j_start = MAX(j_start,jds+config_flags%spec_bdy_width-1) + j_end = MIN(j_end,jde-config_flags%spec_bdy_width) + ENDIF + + kmmax=dx*dx/dt + degrad90=DEGRAD*90. + DO j = j_start, j_end + + k=ktf + DO i = i_start, i_end + +! deltaz(i)=0.5*dnw(k)/zeta_z(i,j) +! dz=dnw(k)/zeta_z(i,j) + dz = 1./rdzw(i,k,j) + deltaz(i) = 0.5*dz + + kmmvmax=dz*dz/dt + tmp=min(deltaz(i)/zdamp,1.) + dampk(i,k,j)=cos(degrad90*tmp)*kmmax*dampcoef + dampkv(i,k,j)=cos(degrad90*tmp)*kmmvmax*dampcoef +! set upper limit on vertical K (based on horizontal K) + dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j)) + + ENDDO + + DO k = ktfm1,kts,-1 + DO i = i_start, i_end + +! deltaz(i)=deltaz(i)+dn(k)/zeta_z(i,j) +! dz=dnw(k)/zeta_z(i,j) + dz = 1./rdz(i,k,j) + deltaz(i) = deltaz(i) + dz + dz = 1./rdzw(i,k,j) + + kmmvmax=dz*dz/dt + tmp=min(deltaz(i)/zdamp,1.) + dampk(i,k,j)=cos(degrad90*tmp)*kmmax*dampcoef + dampkv(i,k,j)=cos(degrad90*tmp)*kmmvmax*dampcoef +! set upper limit on vertical K (based on horizontal K) + dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j)) + ENDDO + ENDDO + + ENDDO + + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + xkmhd(i,k,j)=max(xkmhd(i,k,j),dampk(i,k,j)) + xkmh(i,k,j)=max(xkmh(i,k,j),dampk(i,k,j)) + xkhh(i,k,j)=max(xkhh(i,k,j),dampk(i,k,j)) + xkmv(i,k,j)=max(xkmv(i,k,j),dampkv(i,k,j)) + xkhv(i,k,j)=max(xkhv(i,k,j),dampkv(i,k,j)) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE cal_dampkm + +!======================================================================= +!======================================================================= + + SUBROUTINE calculate_N2( config_flags, BN2, moist, & + theta, t, p, p8w, t8w, & + dnw, dn, rdz, rdzw, & + n_moist, cf1, cf2, cf3, warm_rain, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: n_moist, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL, INTENT( IN ) & + :: warm_rain + + REAL, INTENT( IN ) & + :: cf1, cf2, cf3 + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: BN2 + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: rdz, rdzw, theta, t, p, p8w, t8w + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: dnw, dn + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), INTENT( INOUT ) & + :: moist + +! Local variables. + + INTEGER & + :: i, j, k, ktf, ispe, ktes1, ktes2, & + i_start, i_end, j_start, j_end + + REAL & + :: coefa, thetaep1, thetaem1, qc_cr, es, tc, qlpqi, qsw, qsi, & + tmpdz, xlvqv, thetaesfc, thetasfc, qvtop, qvsfc, thetatop, thetaetop + + REAL, DIMENSION( its:ite, jts:jte ) & + :: tmp1sfc, tmp1top + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: tmp1, qvs, qctmp + +! End declarations. +!----------------------------------------------------------------------- + + qc_cr = 0.00001 ! in Kg/Kg + + ktf = MIN( kte, kde-1 ) + ktes1 = kte-1 + ktes2 = kte-2 + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-2 ,jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + IF ( P_QC .GT. PARAM_FIRST_SCALAR) THEN + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + qctmp(i,k,j) = moist(i,k,j,P_QC) + END DO + END DO + END DO + ELSE + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + qctmp(i,k,j) = 0.0 + END DO + END DO + END DO + END IF + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + tmp1(i,k,j) = 0.0 + END DO + END DO + END DO + + DO j = jts,jte + DO i = its,ite + tmp1sfc(i,j) = 0.0 + tmp1top(i,j) = 0.0 + END DO + END DO + + DO ispe = PARAM_FIRST_SCALAR, n_moist + IF ( ispe .EQ. P_QV .OR. ispe .EQ. P_QC .OR. ispe .EQ. P_QI) THEN + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp1(i,k,j) = tmp1(i,k,j) + moist(i,k,j,ispe) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + tmp1sfc(i,j) = tmp1sfc(i,j) + & + cf1 * moist(i,1,j,ispe) + & + cf2 * moist(i,2,j,ispe) + & + cf3 * moist(i,3,j,ispe) + tmp1top(i,j) = tmp1top(i,j) + & + moist(i,ktes1,j,ispe) + & + ( moist(i,ktes1,j,ispe) - moist(i,ktes2,j,ispe) ) * & + 0.5 * dnw(ktes1) / dn(ktes1) + END DO + END DO + END IF + END DO + +! Calculate saturation mixing ratio. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tc = t(i,k,j) - SVPT0 + es = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t(i,k,j) - SVP3 ) ) + qvs(i,k,j) = EP_2 * es / ( p(i,k,j) - es ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts+1, ktf-1 + DO i = i_start, i_end + tmpdz = 1.0 / rdz(i,k,j) + 1.0 / rdz(i,k+1,j) + IF ( moist(i,k,j,P_QV) .GE. qvs(i,k,j) .OR. qctmp(i,k,j) .GE. qc_cr) THEN + xlvqv = XLV * moist(i,k,j,P_QV) + coefa = ( 1.0 + xlvqv / R_d / t(i,k,j) ) / & + ( 1.0 + XLV * xlvqv / Cp / R_v / t(i,k,j) / t(i,k,j) ) / & + theta(i,k,j) + thetaep1 = theta(i,k+1,j) * & + ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) ) + thetaem1 = theta(i,k-1,j) * & + ( 1.0 + XLV * qvs(i,k-1,j) / Cp / t(i,k-1,j) ) + BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaem1 ) / tmpdz - & + ( tmp1(i,k+1,j) - tmp1(i,k-1,j) ) / tmpdz ) + ELSE + BN2(i,k,j) = g * ( (theta(i,k+1,j) - theta(i,k-1,j) ) / & + theta(i,k,j) / tmpdz + & + 1.61 * ( moist(i,k+1,j,P_QV) - moist(i,k-1,j,P_QV) ) / & + tmpdz - & + ( tmp1(i,k+1,j) - tmp1(i,k-1,j) ) / tmpdz ) + ENDIF + END DO + END DO + END DO + + k = kts + DO j = j_start, j_end + DO i = i_start, i_end + tmpdz = 1.0 / rdz(i,k+1,j) + 0.5 / rdzw(i,k,j) + thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) + IF ( moist(i,k,j,P_QV) .GE. qvs(i,k,j) .OR. qctmp(i,k,j) .GE. qc_cr) THEN + qvsfc = cf1 * qvs(i,1,j) + & + cf2 * qvs(i,2,j) + & + cf3 * qvs(i,3,j) + xlvqv = XLV * moist(i,k,j,P_QV) + coefa = ( 1.0 + xlvqv / R_d / t(i,k,j) ) / & + ( 1.0 + XLV * xlvqv / Cp / R_v / t(i,k,j) / t(i,k,j) ) / & + theta(i,k,j) + thetaep1 = theta(i,k+1,j) * & + ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) ) + thetaesfc = thetasfc * & + ( 1.0 + XLV * qvsfc / Cp / t8w(i,kts,j) ) + BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaesfc ) / tmpdz - & + ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz ) + ELSE + qvsfc = cf1 * moist(i,1,j,P_QV) + & + cf2 * moist(i,2,j,P_QV) + & + cf3 * moist(i,3,j,P_QV) +! BN2(i,k,j) = g * ( ( theta(i,k+1,j) - thetasfc ) / & +! theta(i,k,j) / tmpdz + & +! 1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) / & +! tmpdz - & +! ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz ) +!...... MARTA: change in computation of BN2 at the surface, WCS 040331 + + tmpdz= 1./rdzw(i,k,j) ! controlare come calcola rdzw + BN2(i,k,j) = g * ( ( theta(i,k+1,j) - theta(i,k,j)) / & + theta(i,k,j) / tmpdz + & + 1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) / & + tmpdz - & + ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz ) +! end of MARTA/WCS change + + ENDIF + END DO + END DO + + +!...... MARTA: change in computation of BN2 at the top, WCS 040331 + DO j = j_start, j_end + DO i = i_start, i_end + BN2(i,ktf,j)=BN2(i,ktf-1,j) + END DO + END DO +! end of MARTA/WCS change + + END SUBROUTINE calculate_N2 + +!======================================================================= +!======================================================================= + +SUBROUTINE isotropic_km( config_flags, & + xkmh,xkmhd,xkmv,xkhh,xkhv,khdif,kvdif, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN ) :: khdif,kvdif + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & + xkmhd, & + xkmv, & + xkhh, & + xkhv +! LOCAL VARS + + INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k + REAL :: khdif3,kvdif3 + +! End declarations. +!----------------------------------------------------------------------- + + ktf = kte + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + +! khdif3=khdif*3. +! kvdif3=kvdif*3. + khdif3=khdif/prandtl + kvdif3=kvdif/prandtl + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + xkmh(i,k,j)=khdif + xkmhd(i,k,j)=khdif + xkmv(i,k,j)=kvdif + xkhh(i,k,j)=khdif3 + xkhv(i,k,j)=kvdif3 + ENDDO + ENDDO + ENDDO + +END SUBROUTINE isotropic_km + +!======================================================================= +!======================================================================= + +SUBROUTINE smag_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv,BN2, & + div,defor11,defor22,defor33,defor12, & + defor13,defor23, & + rdzw,dx,dy,cr_len_in, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN ) :: cr_len_in, dx, dy + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: BN2, & + rdzw + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & + xkmhd, & + xkmv, & + xkhh, & + xkhv + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & + defor11, & + defor22, & + defor33, & + defor12, & + defor13, & + defor23, & + div + +! LOCAL VARS + + INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k + REAL :: deltas, tmp, pr, mlen_h, mlen_v, cr_len + + REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 + +! End declarations. +!----------------------------------------------------------------------- + + ktf = min(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + pr = prandtl + cr_len = cr_len_in + + do j=j_start,j_end + do k=kts,ktf + do i=i_start,i_end + def2(i,k,j)=0.5*(defor11(i,k,j)*defor11(i,k,j) + & + defor22(i,k,j)*defor22(i,k,j) + & + defor33(i,k,j)*defor33(i,k,j)) + enddo + enddo + enddo + + do j=j_start,j_end + do k=kts,ktf + do i=i_start,i_end + tmp=0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ & + defor12(i+1,k,j)+defor12(i+1,k,j+1)) + def2(i,k,j)=def2(i,k,j)+tmp*tmp + enddo + enddo + enddo + + do j=j_start,j_end + do k=kts,ktf + do i=i_start,i_end + tmp=0.25*(defor13(i ,k+1,j)+defor13(i ,k,j)+ & + defor13(i+1,k+1,j)+defor13(i+1,k,j)) + def2(i,k,j)=def2(i,k,j)+tmp*tmp + enddo + enddo + enddo + + do j=j_start,j_end + do k=kts,ktf + do i=i_start,i_end + tmp=0.25*(defor23(i,k+1,j )+defor23(i,k,j )+ & + defor23(i,k+1,j+1)+defor23(i,k,j+1)) + def2(i,k,j)=def2(i,k,j)+tmp*tmp + enddo + enddo + enddo +! + cr_len = dx + 1. ! hardwire for mixing length = (dx*dy*dz)**(1/3). + ! remove this for the alternate formulation + + IF (dx .gt. cr_len) THEN + mlen_h=sqrt(dx*dy) + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + mlen_v= 1./rdzw(i,k,j) + tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr) + tmp=tmp**0.5 + xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h ) + xkmh(i,k,j)=min(xkmh(i,k,j), 10.*mlen_h ) + xkmhd(i,k,j)=xkmh(i,k,j) + xkmv(i,k,j)=max(c_s*c_s*mlen_v*mlen_v*tmp, 1.0E-6*mlen_v*mlen_v ) + xkmv(i,k,j)=min(xkmv(i,k,j), 10.*mlen_v ) + xkhh(i,k,j)=xkmh(i,k,j)/pr + xkhv(i,k,j)=xkmv(i,k,j)/pr + ENDDO + ENDDO + ENDDO + ELSE + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + deltas=(dx*dy/rdzw(i,k,j))**0.33333333 + tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr) + tmp=tmp**0.5 + xkmh(i,k,j)=max(c_s*c_s*deltas*deltas*tmp, 1.0E-6*deltas*deltas ) + xkmh(i,k,j)=min(xkmh(i,k,j), 10.*deltas ) + xkmhd(i,k,j)=xkmh(i,k,j) + xkmv(i,k,j)=xkmh(i,k,j) + xkhh(i,k,j)=xkmh(i,k,j)/pr + xkhv(i,k,j)=xkmv(i,k,j)/pr + ENDDO + ENDDO + ENDDO + ENDIF + +END SUBROUTINE smag_km + +!======================================================================= +!======================================================================= + +SUBROUTINE smag2d_km( config_flags,xkmh,xkmhd,xkmv,xkhh,xkhv, & + defor11,defor22,defor12, & + rdzw,dx,dy, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN ) :: dx, dy + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rdzw + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & + xkmhd, & + xkmv, & + xkhh, & + xkhv + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & + defor11, & + defor22, & + defor12 + +! LOCAL VARS + + INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k + REAL :: deltas, tmp, pr, mlen_h + + REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 + +! End declarations. +!----------------------------------------------------------------------- + + ktf = min(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + pr=prandtl + + do j=j_start,j_end + do k=kts,ktf + do i=i_start,i_end + def2(i,k,j)=0.25*((defor11(i,k,j)-defor22(i,k,j))*(defor11(i,k,j)-defor22(i,k,j))) + tmp=0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ & + defor12(i+1,k,j)+defor12(i+1,k,j+1)) + def2(i,k,j)=def2(i,k,j)+tmp*tmp + enddo + enddo + enddo +! + mlen_h=sqrt(dx*dy) + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp=sqrt(def2(i,k,j)) +! xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h ) + xkmh(i,k,j)=c_s*c_s*mlen_h*mlen_h*tmp + xkmh(i,k,j)=min(xkmh(i,k,j), 10.*mlen_h ) + xkmhd(i,k,j)=xkmh(i,k,j) + xkmv(i,k,j)=0. + xkhh(i,k,j)=xkmh(i,k,j)/pr + xkhv(i,k,j)=0. + ENDDO + ENDDO + ENDDO + +END SUBROUTINE smag2d_km + +!======================================================================= +!======================================================================= + + SUBROUTINE tke_km( config_flags, xkmh, xkmhd, xkmv, xkhh, xkhv, & + bn2, tke, p8w, t8w, theta, & + rdz, rdzw, dx,dy, cr_len_in, & + kh_tke_upper_bound, kv_tke_upper_bound, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by Jason Knievel and George Bryan, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! ... ... + +! Purpose: This routine calculates the exchange coefficients for the +! TKE turbulence parameterization. + +! References: Klemp and Wilhelmson (JAS 1978) +! Chen and Dudhia (NCAR WRF physics report 2000) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: cr_len_in, dx, dy + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: tke, p8w, t8w, theta, rdz, rdzw, bn2 + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: xkmh, xkmhd, xkmv, xkhh, xkhv + + REAL, INTENT( IN ) & + :: kh_tke_upper_bound, kv_tke_upper_bound + +! Local variables. + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: l_scale + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: dthrdn + + REAL & + :: deltas, tmp, mlen_s, mlen_h, mlen_v, tmpdz, & + thetasfc, thetatop, minkx, pr_inv, pr_inv_h, pr_inv_v, cr_len + + INTEGER & + :: i_start, i_end, j_start, j_end, ktf, i, j, k + + REAL, PARAMETER :: tke_seed_value = 1.e-06 + REAL :: tke_seed + REAL, PARAMETER :: epsilon = 1.e-10 + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-2, jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + +! in the absence of surface drag or a surface heat flux, there +! is no way to generate tke without pre-existing tke. Use +! tke_seed if the drag and flux are off. + + cr_len = cr_len_in + tke_seed = tke_seed_value + if( (config_flags%tke_drag_coefficient .gt. epsilon) .or. & + (config_flags%tke_heat_flux .gt. epsilon) ) tke_seed = 0. + + DO j = j_start, j_end + DO k = kts+1, ktf-1 + DO i = i_start, i_end + tmpdz = 1.0 / ( rdz(i,k+1,j) + rdz(i,k,j) ) + dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz + END DO + END DO + END DO + + k = kts + DO j = j_start, j_end + DO i = i_start, i_end + tmpdz = 1.0 / ( rdzw(i,k+1,j) + rdzw(i,k,j) ) + thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) + dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz + END DO + END DO + + k = ktf + DO j = j_start, j_end + DO i = i_start, i_end + tmpdz = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j) + thetatop = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp ) + dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz + END DO + END DO + + cr_len = dx + 1.0 ! hardwire for mixing length = (dx*dy*dz)**(1/3). + ! remove this for the alternate formulation + + IF ( dx .gt. cr_len ) THEN + mlen_h = SQRT( dx * dy ) + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp = SQRT( MAX( tke(i,k,j), tke_seed ) ) + deltas = 1.0 / rdzw(i,k,j) + mlen_v = deltas + IF ( dthrdn(i,k,j) .GT. 0.) THEN + mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j) ) )**0.5 + mlen_v = MIN( mlen_v, mlen_s ) + END IF + xkmh(i,k,j) = MAX( c_k * tmp * mlen_h, 1.0E-6 * mlen_h * mlen_h ) + xkmh(i,k,j) = MIN( xkmh(i,k,j), 10.0 * mlen_h ) + xkmhd(i,k,j) = xkmh(i,k,j) + xkmv(i,k,j) = MAX( c_k * tmp * mlen_v, 1.0E-6 * deltas * deltas ) + xkmv(i,k,j) = MIN( xkmv(i,k,j), 10.0 * deltas ) + pr_inv_h = 1./prandtl + pr_inv_v = 1.0 + 2.0 * mlen_v / deltas + xkhh(i,k,j) = xkmh(i,k,j) * pr_inv_h + xkhv(i,k,j) = xkmv(i,k,j) * pr_inv_v + END DO + END DO + END DO + ELSE + CALL calc_l_scale( config_flags, tke, BN2, l_scale, & + i_start, i_end, ktf, j_start, j_end, & + dx, dy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tmp = SQRT( MAX( tke(i,k,j), tke_seed ) ) + deltas = ( dx * dy / rdzw(i,k,j) )**0.33333333 + xkmh(i,k,j) = c_k * tmp * l_scale(i,k,j) + xkmh(i,k,j) = MIN( kh_tke_upper_bound, xkmh(i,k,j) ) + xkmhd(i,k,j) = xkmh(i,k,j) + xkmv(i,k,j) = c_k * tmp * l_scale(i,k,j) + xkmv(i,k,j) = MIN( kv_tke_upper_bound, xkmv(i,k,j) ) + pr_inv = 1.0 + 2.0 * l_scale(i,k,j) / deltas + xkhh(i,k,j) = MIN( kh_tke_upper_bound*pr_inv, xkmh(i,k,j) * pr_inv ) + xkhv(i,k,j) = MIN( kv_tke_upper_bound*pr_inv, xkmv(i,k,j) * pr_inv ) + END DO + END DO + END DO + END IF + + END SUBROUTINE tke_km + +!======================================================================= +!======================================================================= + + SUBROUTINE calc_l_scale( config_flags, tke, BN2, l_scale, & + i_start, i_end, ktf, j_start, j_end, & + dx, dy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Written by Bryan and Knievel, NCAR + +! Purpose: This routine calculates the length scale, based on stability, +! for TKE parameterization of subgrid-scale turbulence. + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: i_start, i_end, ktf, j_start, j_end, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: BN2, tke, rdzw + + REAL, INTENT( IN ) & + :: dx, dy + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ), INTENT( OUT ) & + :: l_scale + +! Local variables. + + INTEGER & + :: i, j, k + + REAL & + :: deltas, tmp + +! End declarations. +!----------------------------------------------------------------------- + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + deltas = ( dx * dy / rdzw(i,k,j) )**0.33333333 + l_scale(i,k,j) = deltas + + IF ( BN2(i,k,j) .gt. 1.0e-6 ) THEN + tmp = SQRT( MAX( tke(i,k,j), 1.0e-6 ) ) + l_scale(i,k,j) = 0.76 * tmp / SQRT( BN2(i,k,j) ) + l_scale(i,k,j) = MIN( l_scale(i,k,j), deltas) + l_scale(i,k,j) = MAX( l_scale(i,k,j), 0.001 * deltas ) + END IF + + END DO + END DO + END DO + + END SUBROUTINE calc_l_scale + +!======================================================================= +!======================================================================= + +SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & + tke_tendf, & + moist_tendf, n_moist, & + chem_tendf, n_chem, & + scalar_tendf, n_scalar, & + thp, theta, mu, tke, config_flags, & + defor11, defor22, defor12, & + defor13, defor23, div, & + moist, chem, scalar, & + msfu, msfv, msft, xkmh, xkhh,km_opt, & + rdx, rdy, rdz, rdzw, fnm, fnp, & + cf1, cf2, cf3, zx, zy, dn, dnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist, n_chem, n_scalar, km_opt + + REAL , INTENT(IN ) :: cf1, cf2, cf3 + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfu, & + msfv, & + msft, & + mu + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::rt_tendf,& + ru_tendf,& + rv_tendf,& + rw_tendf,& + tke_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & + INTENT(INOUT) :: chem_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar), & + INTENT(INOUT) :: scalar_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(IN ) :: moist + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & + INTENT(IN ) :: chem + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & + INTENT(IN ) :: scalar + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & + defor22, & + defor12, & + defor13, & + defor23, & + div, & + xkmh, & + xkhh, & + zx, & + zy, & + theta, & + thp, & + tke, & + rdz, & + rdzw + + + REAL , INTENT(IN ) :: rdx, & + rdy + +! LOCAL VARS + + INTEGER :: im, ic, is + +! REAL , DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1) :: xkhh + +! End declarations. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Call diffusion subroutines. + + CALL horizontal_diffusion_u_2( ru_tendf, mu, config_flags, & + defor11, defor12, div, & + tke(ims,kms,jms), & + msfu, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL horizontal_diffusion_v_2( rv_tendf, mu, config_flags, & + defor12, defor22, div, & + tke(ims,kms,jms), & + msfv, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL horizontal_diffusion_w_2( rw_tendf, mu, config_flags, & + defor13, defor23, div, & + tke(ims,kms,jms), & + msft, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdz, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL horizontal_diffusion_s ( rt_tendf, mu, config_flags, thp, & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (km_opt .eq. 2) & + CALL horizontal_diffusion_s ( tke_tendf(ims,kms,jms), & + mu, config_flags, & + tke(ims,kms,jms), & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .true., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN + + moist_loop: do im = PARAM_FIRST_SCALAR, n_moist + + CALL horizontal_diffusion_s( moist_tendf(ims,kms,jms,im), & + mu, config_flags, & + moist(ims,kms,jms,im), & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDDO moist_loop + + ENDIF + + IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN + + chem_loop: do ic = PARAM_FIRST_SCALAR, n_chem + + CALL horizontal_diffusion_s( chem_tendf(ims,kms,jms,ic), & + mu, config_flags, & + chem(ims,kms,jms,ic), & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDDO chem_loop + + ENDIF + IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN + + scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar + + CALL horizontal_diffusion_s( scalar_tendf(ims,kms,jms,is), & + mu, config_flags, & + scalar(ims,kms,jms,is), & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDDO scalar_loop + + ENDIF + + END SUBROUTINE horizontal_diffusion_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & + defor11, defor12, div, tke, & + msfu, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfu, & + mu + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdzw + + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & + defor12, & + div, & + tke, & + xkmh, & + zx, & + zy + + REAL , INTENT(IN ) :: rdx, & + rdy +! Local data + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & + titau2avg, & + titau1, & + titau2, & + xkxavg, & + rravg +! new +! zxavg, & +! zyavg + REAL :: mrdx, mrdy, rcoup + + REAL :: tmpzy, tmpzeta_z + + REAL :: term1, term2, term3 + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + +!----------------------------------------------------------------------- +! u : p (.), u(|), w(-) +! +! p u p u u u +! +! p | . | . | . | k+1 | . | . | . | k+1 +! +! w - 13 - - k+1 13 k+1 +! +! p | 11 O 11 | . | k | 12 O 12 | . | k +! +! w - 13 - - k 13 k +! +! p | . | . | . | k-1 | . | . | . | k-1 +! +! i-1 i i i+1 j-1 j j j+1 j+1 +! + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-1,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + +! titau1 = titau11 + is_ext=1 + ie_ext=0 + js_ext=0 + je_ext=0 + CALL cal_titau_11_22_33( config_flags, titau1, & + mu, tke, xkmh, defor11, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! titau2 = titau12 + is_ext=0 + ie_ext=0 + js_ext=0 + je_ext=1 + CALL cal_titau_12_21( config_flags, titau2, & + mu, xkmh, defor12, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! titau1avg = titau11avg +! titau2avg = titau12avg + + DO j = j_start, j_end + DO k = kts+1,ktf + DO i = i_start, i_end + titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i-1,k ,j)+titau1(i,k ,j))+ & + fnp(k)*(titau1(i-1,k-1,j)+titau1(i,k-1,j))) + titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j+1)+titau2(i,k ,j))+ & + fnp(k)*(titau2(i,k-1,j+1)+titau2(i,k-1,j))) + tmpzy = 0.25*( zy(i-1,k,j )+zy(i,k,j )+ & + zy(i-1,k,j+1)+zy(i,k,j+1) ) +! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j)) +! titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)*tmpzeta_z +! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy *tmpzeta_z + + titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j) + titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy + + ENDDO + ENDDO + ENDDO +! + DO j = j_start, j_end + DO i = i_start, i_end + titau1avg(i,kts,j)=0. + titau1avg(i,ktf+1,j)=0. + titau2avg(i,kts,j)=0. + titau2avg(i,ktf+1,j)=0. + ENDDO + ENDDO +! + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + + mrdx=msfu(i,j)*rdx + mrdy=msfu(i,j)*rdy + tendency(i,k,j)=tendency(i,k,j)- & + (mrdx*(titau1(i,k,j )-titau1(i-1,k,j))+ & + mrdy*(titau2(i,k,j+1)-titau2(i,k,j ))- & + msfu(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ & + (titau2avg(i,k+1,j)-titau2avg(i,k,j)) & + ) ) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE horizontal_diffusion_u_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & + defor12, defor22, div, tke, & + msfv, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfv, & + mu + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor12, & + defor22, & + div, & + tke, & + xkmh, & + zx, & + zy, & + rdzw + + REAL , INTENT(IN ) :: rdx, & + rdy + +! Local data + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & + titau2avg, & + titau1, & + titau2, & + xkxavg, & + rravg +! new +! zxavg, & +! zyavg + + REAL :: mrdx, mrdy, rcoup + + REAL :: tmpzx, tmpzeta_z + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + +!----------------------------------------------------------------------- +! v : p (.), v(+), w(-) +! +! p v p v v v +! +! p + . + . + . + k+1 + . + . + . + k+1 +! +! w - 23 - - k+1 23 k+1 +! +! p + 22 O 22 + . + k + 21 O 21 + . + k +! +! w - 23 - - k 23 k +! +! p + . + . + . + k-1 + . + . + . + k-1 +! +! j-1 j j j+1 i-1 i i i+1 i+1 +! + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-1,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + +! titau1 = titau21 + is_ext=0 + ie_ext=1 + js_ext=0 + je_ext=0 + CALL cal_titau_12_21( config_flags, titau1, & + mu, xkmh, defor12, & + is_ext,ie_ext,js_ext,je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! titau2 = titau22 + is_ext=0 + ie_ext=0 + js_ext=1 + je_ext=0 + CALL cal_titau_11_22_33( config_flags, titau2, & + mu, tke, xkmh, defor22, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + DO j = j_start, j_end + DO k = kts+1,ktf + DO i = i_start, i_end + titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i+1,k ,j)+titau1(i,k ,j))+ & + fnp(k)*(titau1(i+1,k-1,j)+titau1(i,k-1,j))) + titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j-1)+titau2(i,k ,j))+ & + fnp(k)*(titau2(i,k-1,j-1)+titau2(i,k-1,j))) + + tmpzx = 0.25*( zx(i,k,j )+zx(i+1,k,j )+ & + zx(i,k,j-1)+zx(i+1,k,j-1) ) + + + titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx + titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j) + + + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + titau1avg(i,kts,j)=0. + titau1avg(i,ktf+1,j)=0. + titau2avg(i,kts,j)=0. + titau2avg(i,ktf+1,j)=0. + ENDDO + ENDDO +! + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + + mrdx=msfv(i,j)*rdx + mrdy=msfv(i,j)*rdy + tendency(i,k,j)=tendency(i,k,j)- & + (mrdy*(titau2(i ,k,j)-titau2(i,k,j-1))+ & + mrdx*(titau1(i+1,k,j)-titau1(i,k,j ))- & + msfv(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ & + (titau2avg(i,k+1,j)-titau2avg(i,k,j)) & + ) & + ) + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE horizontal_diffusion_v_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & + defor13, defor23, div, tke, & + msft, xkmh, rdx, rdy, fnm, fnp, & + zx, zy, rdz, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msft, & + mu + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor13, & + defor23, & + div, & + tke, & + xkmh, & + zx, & + zy, & + rdz + + REAL , INTENT(IN ) :: rdx, & + rdy + +! Local data + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & + titau2avg, & + titau1, & + titau2, & + xkxavg, & + rravg +! new +! zxavg, & +! zyavg + + REAL :: mrdx, mrdy, rcoup + + REAL :: tmpzx, tmpzy, tmpzeta_z + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + +!----------------------------------------------------------------------- +! w : p (.), u(|), v(+), w(-) +! +! p u p u p v p v +! +! w - - - k+1 w - - - k+1 +! +! p . | 33 | . k p . + 33 + . k +! +! w - 31 O 31 - k w - 32 O 32 - k +! +! p . | 33 | . k-1 p . | 33 | . k-1 +! +! w - - - k-1 w - - - k-1 +! +! i-1 i i i+1 j-1 j j j+1 +! + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + +! titau1 = titau31 + is_ext=0 + ie_ext=1 + js_ext=0 + je_ext=0 + CALL cal_titau_13_31( config_flags, titau1, defor13, & + mu, xkmh, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! titau2 = titau32 + is_ext=0 + ie_ext=0 + js_ext=0 + je_ext=1 + CALL cal_titau_23_32( config_flags, titau2, defor23, & + mu, xkmh, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! titau1avg = titau31avg * zx * zeta_z = titau13avg * zx * zeta_z +! titau2avg = titau32avg * zy * zeta_z = titau23avg * zy * zeta_z + + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + titau1avg(i,k,j)=0.25*(titau1(i+1,k+1,j)+titau1(i,k+1,j)+ & + titau1(i+1,k ,j)+titau1(i,k ,j)) + titau2avg(i,k,j)=0.25*(titau2(i,k+1,j+1)+titau2(i,k+1,j)+ & + titau2(i,k ,j+1)+titau2(i,k ,j)) +! new + tmpzx =0.25*( zx(i,k ,j)+zx(i+1,k ,j)+ & + zx(i,k+1,j)+zx(i+1,k+1,j) ) + tmpzy =0.25*( zy(i,k ,j)+zy(i,k ,j+1)+ & + zy(i,k+1,j)+zy(i,k+1,j+1) ) + + titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx + titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy +! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx*zeta_z(i,j) +! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy*zeta_z(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + titau1avg(i,kts ,j)=0. + titau2avg(i,kts ,j)=0. + titau1avg(i,ktf+1,j)=0. + titau2avg(i,ktf+1,j)=0. + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts+1,ktf + DO i = i_start, i_end + + mrdx=msft(i,j)*rdx + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)- & + (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+ & + mrdy*(titau2(i,k,j+1)-titau2(i,k,j))- & + msft(i,j)*rdz(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j)+ & + titau2avg(i,k,j)-titau2avg(i,k-1,j) & + ) & + ) +! msft(i,j)/dn(k)*(titau1avg(i,k,j)-titau1avg(i,k-1,j)+ & +! titau2avg(i,k,j)-titau2avg(i,k-1,j) & +! ) & +! ) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE horizontal_diffusion_w_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & + msft, msfu, msfv, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dn, dnw, & + doing_tke, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL, INTENT(IN ) :: doing_tke + + REAL , INTENT(IN ) :: cf1, cf2, cf3 + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfu + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfv + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msft + + REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: mu + +! REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1), & +! INTENT(IN ) :: xkhh + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + xkhh, & + rdz, & + rdzw + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: var, & + zx, & + zy + + REAL , INTENT(IN ) :: rdx, & + rdy + +! Local data + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: H1avg, & + H2avg, & + H1, & + H2, & + xkxavg +! new +! zxavg, & +! zyavg + + REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: tmptendf + + REAL :: mrdx, mrdy, rcoup + REAL :: tmpzx, tmpzy, tmpzeta_z + INTEGER :: ktes1,ktes2 + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + +!----------------------------------------------------------------------- +! scalars: t (.), u(|), v(+), w(-) +! +! t u t u t v t v +! +! w - 3 - k+1 w - 3 - k+1 +! +! t . 1 O 1 . k t . 2 O 2 . k +! +! w - 3 - k w - 3 - k +! +! t . | . | . k-1 t . + . + . k-1 +! +! w - - - k-1 w - - - k-1 +! +! t i-1 i i i+1 j-1 j j j+1 +! + + ktes1=kte-1 + ktes2=kte-2 + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + +! diffusion of the TKE needs mutiple 2 + + IF ( doing_tke ) THEN + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + tmptendf(i,k,j)=tendency(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + +! H1 = partial var over partial x + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + 1 +! new +! zxavg(i,k,j) =0.5*( zx(i-1,k,j)+ zx(i,k,j)) + xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j)) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + 1 + H1avg(i,k,j)=0.5*(fnm(k)*(var(i-1,k ,j)+var(i,k ,j))+ & + fnp(k)*(var(i-1,k-1,j)+var(i,k-1,j))) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + 1 + H1avg(i,kts ,j)=0.5*(cf1*var(i ,1,j)+cf2*var(i ,2,j)+ & + cf3*var(i ,3,j)+cf1*var(i-1,1,j)+ & + cf2*var(i-1,2,j)+cf3*var(i-1,3,j)) + H1avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- & + var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ & + var(i-1,ktes1,j)+(var(i-1,ktes1,j)- & + var(i-1,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)) + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + 1 +! new + tmpzx = 0.5*( zx(i,k,j)+ zx(i,k+1,j)) + H1(i,k,j)=-msfu(i,j)*xkxavg(i,k,j)*( & + rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx* & + (H1avg(i,k+1,j)-H1avg(i,k,j))*rdzw(i,k,j) ) + +! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j)) +! H1(i,k,j)=-msfu(i,j)*xkxavg(i,k,j)*( & +! rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx*tmpzeta_z* & +! (H1avg(i,k+1,j)-H1avg(i,k,j))/dnw(k)) + ENDDO + ENDDO + ENDDO + +! H2 = partial var over partial y + + DO j = j_start, j_end + 1 + DO k = kts, ktf + DO i = i_start, i_end +! new +! zyavg(i,k,j) =0.5*( zy(i,k,j-1)+ zy(i,k,j)) + xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j)) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + 1 + DO k = kts+1, ktf + DO i = i_start, i_end +! new + H2avg(i,k,j)=0.5*(fnm(k)*(var(i,k ,j-1)+var(i,k ,j))+ & + fnp(k)*(var(i,k-1,j-1)+var(i,k-1,j))) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + 1 + DO i = i_start, i_end + H2avg(i,kts ,j)=0.5*(cf1*var(i,1,j )+cf2*var(i ,2,j)+ & + cf3*var(i,3,j )+cf1*var(i,1,j-1)+ & + cf2*var(i,2,j-1)+cf3*var(i,3,j-1)) + H2avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- & + var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ & + var(i,ktes1,j-1)+(var(i,ktes1,j-1)- & + var(i,ktes2,j-1))*0.5*dnw(ktes1)/dn(ktes1)) + ENDDO + ENDDO + + DO j = j_start, j_end + 1 + DO k = kts, ktf + DO i = i_start, i_end +! new + tmpzy = 0.5*( zy(i,k,j)+ zy(i,k+1,j)) + + H2(i,k,j)=-msfv(i,j)*xkxavg(i,k,j)*( & + rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy* & + (H2avg(i ,k+1,j)-H2avg(i,k,j))*rdzw(i,k,j)) + +! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i,j-1)) +! H2(i,k,j)=-msfv(i,j)*xkxavg(i,k,j)*( & +! rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy*tmpzeta_z* & +! (H2avg(i ,k+1,j)-H2avg(i,k,j))/dnw(k)) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + H1avg(i,k,j)=0.5*(fnm(k)*(H1(i+1,k ,j)+H1(i,k ,j))+ & + fnp(k)*(H1(i+1,k-1,j)+H1(i,k-1,j))) + H2avg(i,k,j)=0.5*(fnm(k)*(H2(i,k ,j+1)+H2(i,k ,j))+ & + fnp(k)*(H2(i,k-1,j+1)+H2(i,k-1,j))) +! new +! zxavg(i,k,j)=fnm(k)*zx(i,k,j)+fnp(k)*zx(i,k-1,j) +! zyavg(i,k,j)=fnm(k)*zy(i,k,j)+fnp(k)*zy(i,k-1,j) + +! H1avg(i,k,j)=zx*H1avg*zeta_z +! H2avg(i,k,j)=zy*H2avg*zeta_z + + tmpzx = 0.5*( zx(i,k,j)+ zx(i+1,k,j )) + tmpzy = 0.5*( zy(i,k,j)+ zy(i ,k,j+1)) + + H1avg(i,k,j)=H1avg(i,k,j)*tmpzx + H2avg(i,k,j)=H2avg(i,k,j)*tmpzy + +! H1avg(i,k,j)=H1avg(i,k,j)*tmpzx*zeta_z(i,j) +! H2avg(i,k,j)=H2avg(i,k,j)*tmpzy*zeta_z(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + H1avg(i,kts ,j)=0. + H1avg(i,ktf+1,j)=0. + H2avg(i,kts ,j)=0. + H2avg(i,ktf+1,j)=0. + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + + mrdx=msft(i,j)*rdx + mrdy=msft(i,j)*rdy + + tendency(i,k,j)=tendency(i,k,j)- & + (mrdx*0.5*((mu(i+1,j)+mu(i,j))*H1(i+1,k,j)- & + (mu(i-1,j)+mu(i,j))*H1(i ,k,j))+ & + mrdy*0.5*((mu(i,j+1)+mu(i,j))*H2(i,k,j+1)- & + (mu(i,j-1)+mu(i,j))*H2(i,k,j ))- & + msft(i,j)*mu(i,j)*(H1avg(i,k+1,j)-H1avg(i,k,j)+ & + H2avg(i,k+1,j)-H2avg(i,k,j) & + )*rdzw(i,k,j) & + ) + + ENDDO + ENDDO + ENDDO + + IF ( doing_tke ) THEN + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tmptendf(i,k,j)+2.* & + (tendency(i,k,j)-tmptendf(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDIF + +END SUBROUTINE horizontal_diffusion_s + +!======================================================================= +!======================================================================= + +SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & + tke_tendf, moist_tendf, n_moist, & + chem_tendf, n_chem, & + scalar_tendf, n_scalar, & + u_2, v_2, & + thp,u_base,v_base,t_base,qv_base,mu,tke, & + config_flags,defor13,defor23,defor33,div, & + moist, chem, scalar, xkmv, xkhv,km_opt, & + fnm, fnp, dn, dnw, rdz, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist, n_chem, n_scalar, km_opt + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: qv_base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: v_base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: t_base + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::ru_tendf,& + rv_tendf,& + rw_tendf,& + tke_tendf,& + rt_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & + INTENT(INOUT) :: chem_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & + INTENT(INOUT) :: scalar_tendf + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & + INTENT(INOUT) :: chem + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & + INTENT(IN ) :: scalar + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor13, & + defor23, & + defor33, & + div, & + xkmv, & + xkhv, & + tke, & + rdz, & + u_2, & + v_2, & + rdzw + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: thp + +! LOCAL VAR + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme) :: var_mix + + INTEGER :: im, i,j,k + INTEGER :: i_start, i_end, j_start, j_end + +! REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: xkhv + +!*************************************************************************** +!*************************************************************************** +!MODIFICA VARIABILI PER I FLUSSI +! + REAL , DIMENSION( ims:ime, jms:jme) :: Cd + REAL :: V0_u,V0_v,tao_xz,tao_yz,ustar,cd0 + REAL :: xsfc,psi1,vk2,zrough,lnz + REAL :: heat_flux +! +!FINE MODIFICA VARIABILI PER I FLUSSI +!*************************************************************************** +! + +! End declarations. +!----------------------------------------------------------------------- + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) +! +!----------------------------------------------------------------------- + + CALL vertical_diffusion_u_2( ru_tendf, config_flags, mu, & + defor13, xkmv, & + dnw, rdzw, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + CALL vertical_diffusion_v_2( rv_tendf, config_flags, mu, & + defor23, xkmv, & + dnw, rdzw, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL vertical_diffusion_w_2( rw_tendf, config_flags, mu, & + defor33, tke(ims,kms,jms), & + div, xkmv, & + dn, rdz, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!***************************************** +!***************************************** +! MODIFICA al flusso di momento alla parete +! + cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient + ! set in namelist.input + DO j = j_start, j_end+1 + DO i = i_start, i_end+1 + Cd(i,j)= cd0 + ENDDO + ENDDO +! +!calcolo del modulo della velocita + DO j = j_start, j_end + DO i = i_start, i_end+1 + V0_u=0. + tao_xz=0. + V0_u= sqrt((u_2(i,kts,j)**2) + & + (((v_2(i ,kts,j )+ & + v_2(i ,kts,j+1)+ & + v_2(i-1,kts,j )+ & + v_2(i-1,kts,j+1))/4)**2))+epsilon + tao_xz=Cd(i,j)*V0_u*u_2(i,kts,j) + ru_tendf(i,kts,j)=ru_tendf(i,kts,j) & + -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j)) + ENDDO + ENDDO + +! + DO j = j_start, j_end+1 + DO i = i_start, i_end + V0_v=0. + tao_yz=0. + V0_v= sqrt((v_2(i,kts,j)**2) + & + (((u_2(i ,kts,j )+ & + u_2(i ,kts,j-1)+ & + u_2(i+1,kts,j )+ & + u_2(i+1,kts,j-1))/4)**2))+epsilon + tao_yz=Cd(i,j)*V0_v*v_2(i,kts,j) + rv_tendf(i,kts,j)=rv_tendf(i,kts,j) & + -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1)) + ENDDO + ENDDO +! +! FINE MODIFICA al flusso di momento alla parete +!***************************************** +!***************************************** + + IF ( config_flags%mix_full_fields ) THEN + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) + var_mix(i,k,j) = thp(i,k,j) + ENDDO + ENDDO + ENDDO + + ELSE + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) + var_mix(i,k,j) = thp(i,k,j) - t_base(k) + ENDDO + ENDDO + ENDDO + + END IF + + CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + +!***************************************** +!***************************************** +!MODIFICA al flusso di calore +! +! + heat_flux = config_flags%tke_heat_flux ! constant heat flux value + ! set in namelist.input + DO j = j_start, j_end + DO i = i_start, i_end + + rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & + +mu(i,j)*heat_flux*rdzw(i,kts,j) + + ENDDO + ENDDO +! +! FINE MODIFICA al flusso di calore +!***************************************** +!***************************************** + + If (km_opt .eq. 2) then + CALL vertical_diffusion_s( tke_tendf(ims,kms,jms), & + config_flags, tke(ims,kms,jms), & + mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .true., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + endif + + IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN + + moist_loop: do im = PARAM_FIRST_SCALAR, n_moist + + IF ( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) + var_mix(i,k,j) = moist(i,k,j,im) - qv_base(k) + ENDDO + ENDDO + ENDDO + + ELSE + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) + var_mix(i,k,j) = moist(i,k,j,im) + ENDDO + ENDDO + ENDDO + + END IF + + + CALL vertical_diffusion_s( moist_tendf(ims,kms,jms,im), & + config_flags, var_mix, & + mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDDO moist_loop + + ENDIF + + IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN + + chem_loop: do im = PARAM_FIRST_SCALAR, n_chem + + CALL vertical_diffusion_s( chem_tendf(ims,kms,jms,im), & + config_flags, chem(ims,kms,jms,im), & + mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO chem_loop + + ENDIF + + + IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN + + scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar + + CALL vertical_diffusion_s( scalar_tendf(ims,kms,jms,im), & + config_flags, scalar(ims,kms,jms,im), & + mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO scalar_loop + + ENDIF + +END SUBROUTINE vertical_diffusion_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & + defor13, xkmv, & + dnw, rdzw, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw +! REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: zeta_z + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) ::defor13, & + xkmv, & + rdzw + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + +! LOCAL VARS + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 + + REAL , DIMENSION( its:ite, jts:jte) :: zzavg + + REAL :: rdzu + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = ite + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-1,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + +! titau3 = titau13 + is_ext=0 + ie_ext=0 + js_ext=0 + je_ext=0 + CALL cal_titau_13_31( config_flags, titau3, defor13, & + mu, xkmv, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +! + DO j = j_start, j_end + DO k=kts+1,ktf + DO i = i_start, i_end + + rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) + tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)-titau3(i,k,j)) + + ENDDO + ENDDO + ENDDO + +! ******** MODIF... +! we will pick up the surface drag (titau3(i,kts,j)) later +! + DO j = j_start, j_end + k=kts + DO i = i_start, i_end + + rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) + tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)) + ENDDO + ENDDO +! ******** MODIF... + +END SUBROUTINE vertical_diffusion_u_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & + defor23, xkmv, & + dnw, rdzw, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw +! REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: zeta_z + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) ::defor23, & + xkmv, & + rdzw + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + +! LOCAL VARS + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 + + REAL , DIMENSION( its:ite, jts:jte) :: zzavg + + REAL :: rdzv + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-1,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + +! titau3 = titau23 + is_ext=0 + ie_ext=0 + js_ext=0 + je_ext=0 + CALL cal_titau_23_32( config_flags, titau3, defor23, & + mu, xkmv, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + DO j = j_start, j_end + DO k = kts+1,ktf + DO i = i_start, i_end + + rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1)) + tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)-titau3(i,k,j)) + + ENDDO + ENDDO + ENDDO + +! ******** MODIF... +! we will pick up the surface drag (titau3(i,kts,j)) later +! + DO j = j_start, j_end + k=kts + DO i = i_start, i_end + + rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1)) + tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)) + + ENDDO + ENDDO +! ******** MODIF... + +END SUBROUTINE vertical_diffusion_v_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & + defor33, tke, div, xkmv, & + dn, rdz, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) ::defor33, & + tke, & + div, & + xkmv, & + rdz + + REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: mu + +! LOCAL VARS + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: is_ext,ie_ext,js_ext,je_ext + + REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + +! titau3 = titau33 + is_ext=0 + ie_ext=0 + js_ext=0 + je_ext=0 + CALL cal_titau_11_22_33( config_flags, titau3, & + mu, tke, xkmv, defor33, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! DO j = j_start, j_end +! DO k = kts+1, ktf +! DO i = i_start, i_end +! titau3(i,k,j)=titau3(i,k,j)*zeta_z(i,j) +! ENDDO +! ENDDO +! ENDDO + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdz(i,k,j)*(titau3(i,k,j)-titau3(i,k-1,j)) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE vertical_diffusion_w_2 + +!======================================================================= +!======================================================================= + +SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + doing_tke, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL, INTENT(IN ) :: doing_tke + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN) :: xkhv + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: mu + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: var, & + rdz, & + rdzw +! LOCAL VARS + + INTEGER :: i, j, k, ktf + + INTEGER :: i_start, i_end, j_start, j_end + + REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: H3, & + xkxavg, & + rravg + + REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: tmptendf + +! End declarations. +!----------------------------------------------------------------------- + + ktf=MIN(kte,kde-1) + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1) + + IF (doing_tke) THEN + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + tmptendf(i,k,j)=tendency(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + +! H3 + + xkxavg = 0. + + DO j = j_start, j_end + DO k = kts+1,ktf + DO i = i_start, i_end + xkxavg(i,k,j)=fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j) + H3(i,k,j)=-xkxavg(i,k,j)*(var(i,k,j)-var(i,k-1,j))*rdz(i,k,j) +! H3(i,k,j)=-xkxavg(i,k,j)*zeta_z(i,j)* & +! (var(i,k,j)-var(i,k-1,j))/dn(k) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + H3(i,kts,j)=0. + H3(i,ktf+1,j)=0. +! H3(i,kts,j)=H3(i,kts+1,j) +! H3(i,ktf+1,j)=H3(i,ktf,j) + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j) & + -mu(i,j)*(H3(i,k+1,j)-H3(i,k,j))*rdzw(i,k,j) + ENDDO + ENDDO + ENDDO + + IF (doing_tke) THEN + DO j = j_start, j_end + DO k = kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tmptendf(i,k,j)+2.* & + (tendency(i,k,j)-tmptendf(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDIF + +END SUBROUTINE vertical_diffusion_s + +!======================================================================= +!======================================================================= + + SUBROUTINE cal_titau_11_22_33( config_flags, titau, & + mu, tke, xkx, defor, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Purpose: This routine calculates stress terms (taus) for use in +! the calculation of production of TKE by sheared wind + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +! Key: + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER, INTENT( IN ) & + :: is_ext, ie_ext, js_ext, je_ext + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & + :: titau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor, xkx, tke + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + + i_start = its + i_end = ite + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-1, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-1, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + i_start = i_start - is_ext + i_end = i_end + ie_ext + j_start = j_start - js_ext + j_end = j_end + je_ext + + IF ( config_flags%km_opt .EQ. 2) THEN + DO j = j_start,j_end + DO k = kts,ktf + DO i = i_start,i_end + titau(i,k,j) = mu(i,j) * ( - xkx(i,k,j) * ( defor(i,k,j) ) ) + END DO + END DO + END DO + ELSE + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) + END DO + END DO + END DO + END IF + + END SUBROUTINE cal_titau_11_22_33 + +!======================================================================= +!======================================================================= + + SUBROUTINE cal_titau_12_21( config_flags, titau, & + mu, xkx, defor, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Modifications by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Pusrpose This routine calculates the stress terms (taus) for use in +! the calculation of production of TKE by sheared wind + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +! Key: + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER, INTENT( IN ) & + :: is_ext, ie_ext, js_ext, je_ext + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & + :: titau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor, xkx + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & + :: xkxavg + + REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & + :: muavg + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + +! Needs one more point in the x and y directions. + + i_start = its + i_end = ite + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested ) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested ) i_end = MIN( ide-1, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested ) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested ) j_end = MIN( jde-1, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + i_start = i_start - is_ext + i_end = i_end + ie_ext + j_start = j_start - js_ext + j_end = j_end + je_ext + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + xkxavg(i,k,j) = 0.25 * ( xkx(i-1,k,j ) + xkx(i,k,j ) + & + xkx(i-1,k,j-1) + xkx(i,k,j-1) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + muavg(i,j) = 0.25 * ( mu(i-1,j ) + mu(i,j ) + & + mu(i-1,j-1) + mu(i,j-1) ) + END DO + END DO + +! titau12 or titau21 + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + END DO + END DO + END DO + + END SUBROUTINE cal_titau_12_21 + +!======================================================================= + + SUBROUTINE cal_titau_13_31( config_flags, titau, & + defor, mu, xkx, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Modifications by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Purpose: This routine calculates the stress terms (taus) for use in +! the calculation of production of TKE by sheared wind + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +! Key: + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER, INTENT( IN ) & + :: is_ext, ie_ext, js_ext, je_ext + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: fnm, fnp + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & + :: titau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN ) & + :: defor, xkx + + REAL, DIMENSION( ims:ime, jms:jme), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & + :: xkxavg + + REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & + :: muavg + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + +! Find ide-1 and jde-1 for averaging to p point. + + i_start = its + i_end = ite + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-1, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-2, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + i_start = i_start - is_ext + i_end = i_end + ie_ext + j_start = j_start - js_ext + j_end = j_end + je_ext + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i-1,k ,j) ) + & + fnp(k) * ( xkx(i,k-1,j) + xkx(i-1,k-1,j) ) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + muavg(i,j) = 0.5 * ( mu(i,j) + mu(i-1,j) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO i = i_start, i_end + titau(i,kts ,j) = 0.0 + titau(i,ktf+1,j) = 0.0 + ENDDO + ENDDO + + END SUBROUTINE cal_titau_13_31 + +!======================================================================= +!======================================================================= + + SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & + mu, xkx, fnm, fnp, & + is_ext, ie_ext, js_ext, je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Purpose: This routine calculates stress terms (taus) for use in +! the calculation of production of TKE by sheared wind + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +! Key: + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER, INTENT( IN ) & + :: is_ext,ie_ext,js_ext,je_ext + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: fnm, fnp + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & + :: titau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor, xkx + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & + :: xkxavg + + REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & + :: muavg + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + +! Find ide-1 and jde-1 for averaging to p point. + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-1, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + i_start = i_start - is_ext + i_end = i_end + ie_ext + j_start = j_start - js_ext + j_end = j_end + je_ext + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i,k ,j-1) ) + & + fnp(k) * ( xkx(i,k-1,j) + xkx(i,k-1,j-1) ) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + muavg(i,j) = 0.5 * ( mu(i,j) + mu(i,j-1) ) + END DO + END DO + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + titau(i,kts ,j) = 0.0 + titau(i,ktf+1,j) = 0.0 + END DO + END DO + + END SUBROUTINE cal_titau_23_32 + +!======================================================================= +!======================================================================= + +SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & + defor12,defor13,defor23,xkmh,xkmhd,xkmv,xkhh,xkhv,tke, & + RUBLTEN, RVBLTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + +!------------------------------------------------------------------------------ +! Begin declarations. + + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::RUBLTEN, & + RVBLTEN, & + defor11, & + defor22, & + defor33, & + defor12, & + defor13, & + defor23, & + xkmh, & + xkmhd, & + xkmv, & + xkhh, & + xkhv, & + tke, & + div + +! End declarations. +!----------------------------------------------------------------------- + + IF(config_flags%bl_pbl_physics .GT. 0) THEN + + CALL set_physical_bc3d( RUBLTEN , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( RVBLTEN , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + ENDIF + + ! move out of the conditional, below; this one is needed for + ! all diff_opt cases. JM + CALL set_physical_bc3d( xkmhd , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + IF(config_flags%diff_opt .eq. 2) THEN + + CALL set_physical_bc3d( xkmh , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + + CALL set_physical_bc3d( xkmv , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( xkhh , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( xkhv , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( tke , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( div , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor11 , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor22 , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor33 , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor12 , 'd', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor13 , 'e', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + CALL set_physical_bc3d( defor23 , 'f', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) + + ENDIF + +END SUBROUTINE phy_bc + +!======================================================================= +!======================================================================= + + SUBROUTINE tke_rhs( tendency, BN2, config_flags, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + u, v, w, div, tke, mu, & + theta, p, p8w, t8w, z, fnm, fnp, & + cf1, cf2, cf3, msft, xkmh, xkmv, xkhv, & + rdx, rdy, dx, dy, dt, zx, zy, & + rdz, rdzw, dn, dnw, cr_len, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: cf1, cf2, cf3, dt, rdx, rdy, dx, dy, cr_len + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: fnm, fnp, dnw, dn + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: msft + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: tendency + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor11, defor22, defor33, defor12, defor13, defor23, & + div, BN2, tke, xkmh, xkmv, xkhv, zx, zy, u, v, w, theta, & + p, p8w, t8w, z, rdz, rdzw + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + +! End declarations. +!----------------------------------------------------------------------- + + CALL tke_shear( tendency, config_flags, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + u, v, w, tke, mu, fnm, fnp, & + cf1, cf2, cf3, msft, xkmh, xkmv, & + rdx, rdy, zx, zy, rdz, rdzw, dnw, dn, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL tke_buoyancy( tendency, config_flags, mu, & + tke, xkhv, BN2, theta, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL tke_dissip( tendency, config_flags, & + mu, tke, bn2, theta, p8w, t8w, z, & + dx, dy,rdz, rdzw, cr_len, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! Set a lower limit on TKE. + + ktf = MIN( kte, kde-1 ) + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .or. config_flags%specified .or. & + config_flags%nested) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. config_flags%specified .or. & + config_flags%nested) i_end = MIN(ide-2,ite) + IF ( config_flags%open_ys .or. config_flags%specified .or. & + config_flags%nested) j_start = MAX(jds+1,jts) + IF ( config_flags%open_ye .or. config_flags%specified .or. & + config_flags%nested) j_end = MIN(jde-2,jte) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = max( tendency(i,k,j), -mu(i,j) * max( 0.0 , tke(i,k,j) ) / dt ) + END DO + END DO + END DO + + END SUBROUTINE tke_rhs + +!======================================================================= +!======================================================================= + + SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & + tke, xkhv, BN2, theta, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: dt + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: tendency + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: xkhv, tke, BN2, theta + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf + + INTEGER & + :: i_start, i_end, j_start, j_end + + REAL :: heat_flux + +! End declarations. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Add to the TKE tendency the term that accounts for production of TKE +! due to buoyant motions. + + ktf = MIN( kte, kde-1 ) + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested ) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested ) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested ) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested ) j_end = MIN( jde-2, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) - mu(i,j) * xkhv(i,k,j) * BN2(i,k,j) + END DO + END DO + END DO + +! MARTA: change in the computation of the tke's tendency at the surface. +! the buoyancy flux is the average of the surface heat flux (0.06) and the +! flux at the first w level +! +! WCS 040331 + + heat_flux = config_flags%tke_heat_flux ! constant heat flux value + ! set in namelist.input + IF(abs(heat_flux).lt.1.0e-6)THEN + K=KTS + DO j = j_start, j_end + DO i = i_start, i_end + tendency(i,k,j)= tendency(i,k,j) - & + mu(i,j)*xkhv(i,k,j)*BN2(i,k,j) + ENDDO + ENDDO + ELSE + K=KTS + DO j = j_start, j_end + DO i = i_start, i_end + tendency(i,k,j)= tendency(i,k,j) - & + mu(i,j)*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2. + + ENDDO + ENDDO + ENDIF +! end of MARTA/WCS change + +! The tendency array now includes production of TKE from buoyant +! motions. +!----------------------------------------------------------------------- + + END SUBROUTINE tke_buoyancy + +!======================================================================= +!======================================================================= + + SUBROUTINE tke_dissip( tendency, config_flags, & + mu, tke, bn2, theta, p8w, t8w, z, & + dx, dy, rdz, rdzw, cr_len_in, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Changes by George Bryan and Jason Knievel, NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Purpose: This routine calculates dissipation of turbulent kinetic +! energy. + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: dx, dy, cr_len_in + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: tendency + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: tke, bn2, theta, p8w, t8w, z, rdz, rdzw + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: dthrdn + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: l_scale + + REAL, DIMENSION( its:ite ) & + :: sumtke, sumtkez + + INTEGER & + :: i, j, k, ktf, i_start, i_end, j_start, j_end + + REAL & + :: disp_len, deltas, coefc, tmpdz, len_s, thetasfc, & + thetatop, len_0, tketmp, tmp, cr_len, ce1, ce2 + +! End declarations. +!----------------------------------------------------------------------- + + ce1 = ( c_k / 0.10 ) * 0.19 + ce2 = max( 0.0 , 0.93 - ce1 ) + + ktf = MIN( kte, kde-1 ) + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-2, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + cr_len = cr_len_in + cr_len = dx + 1.0 ! hardwire for mixing length = (dx*dy*dz)**(1/3). + ! remove this for the alternate formulation + + IF (dx .gt. cr_len) THEN + + DO j = j_start, j_end + DO i = i_start, i_end + sumtke(i) = 0.0 + sumtkez(i) = 0.0 + END DO + DO k = kts, ktf + DO i = i_start, i_end + tketmp = MAX( tke(i,k,j), 0.0 ) + sumtke(i) = sumtke(i) + SQRT(tketmp) / rdzw(i,k,j) + sumtkez(i) = sumtkez(i)+ sumtke(i) * z(i,k,j) + IF ( ABS( sumtke(i) ) .gt. 0.01 ) THEN + len_0 = 0.2 * sumtkez(i) / sumtke(i) + ELSE + len_0 = 80.0 + ENDIF + len_0 = MIN( 80.0, len_0) + l_scale(i,k,j) = KARMAN * z(i,k,j) / & + ( 1.0 + KARMAN * z(i,k,j) / len_0 ) + tendency(i,k,j) = tendency(i,k,j) - & + mu(i,j) * 2.0 * SQRT( 2.0 ) / 15.0 * & + tketmp**1.5 / l_scale(i,k,j) + END DO + END DO + END DO + ELSE + CALL calc_l_scale( config_flags, tke, BN2, l_scale, & + i_start, i_end, ktf, j_start, j_end, & + dx, dy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + deltas = ( dx * dy / rdzw(i,k,j) )**0.33333333 + tketmp = MAX( tke(i,k,j), 1.0e-6 ) + +! Apply Deardorff's (1980) "wall effect" at the bottom of the domain. + + IF ( k .eq. kts .or. k .eq. ktf ) then + coefc = 3.9 + ELSE + coefc = ce1 + ce2 * l_scale(i,k,j) / deltas + END IF + + tendency(i,k,j) = tendency(i,k,j) - & + mu(i,j) * coefc * tketmp**1.5 / l_scale(i,k,j) + END DO + END DO + END DO + ENDIF + + END SUBROUTINE tke_dissip + +!======================================================================= +!======================================================================= + + SUBROUTINE tke_shear( tendency, config_flags, & + defor11, defor22, defor33, & + defor12, defor13, defor23, & + u, v, w, tke, mu, fnm, fnp, & + cf1, cf2, cf3, msft, xkmh, xkmv, & + rdx, rdy, zx, zy, rdz, rdzw, dn, dnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! History: Sep 2003 Rewritten by George Bryan and Jason Knievel, +! NCAR +! Oct 2001 Converted to mass core by Bill Skamarock, NCAR +! Aug 2000 Original code by Shu-Hua Chen, UC-Davis + +! Purpose: This routine calculates the production of turbulent +! kinetic energy by stresses due to sheared wind. + +! References: Klemp and Wilhelmson (JAS 1978) +! Deardorff (B-L Meteor 1980) +! Chen and Dudhia (NCAR WRF physics report 2000) + +! Key: + +! avg temporary working array +! cf1 +! cf2 +! cf3 +! defor11 deformation term ( du/dx + du/dx ) +! defor12 deformation term ( dv/dx + du/dy ); same as defor21 +! defor13 deformation term ( dw/dx + du/dz ); same as defor31 +! defor22 deformation term ( dv/dy + dv/dy ) +! defor23 deformation term ( dw/dy + dv/dz ); same as defor32 +! defor33 deformation term ( dw/dz + dw/dz ) +! div 3-d divergence +! dn +! dnw +! fnm +! fnp +! msft +! rdx +! rdy +! tendency +! titau tau (stress tensor) with a tilde, indicating division by +! a map-scale factor and the fraction of the total modeled +! atmosphere beneath a given altitude (titau = tau/m/zeta) +! tke turbulent kinetic energy + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT( IN ) & + :: cf1, cf2, cf3, rdx, rdy + + REAL, DIMENSION( kms:kme ), INTENT( IN ) & + :: fnm, fnp, dn, dnw + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: msft + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: tendency + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor11, defor22, defor33, defor12, defor13, defor23, & + tke, xkmh, xkmv, zx, zy, u, v, w, rdz, rdzw + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & + :: mu + +! Local variables. + + INTEGER & + :: i, j, k, ktf, ktes1, ktes2, & + i_start, i_end, j_start, j_end, & + is_ext, ie_ext, js_ext, je_ext + + REAL & + :: mtau + + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & + :: avg, titau, tmp2 + + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & + :: titau12, tmp1, zxavg, zyavg + + REAL :: absU, cd0 + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + ktes1 = kte-1 + ktes2 = kte-2 + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested ) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested ) i_end = MIN( ide-2, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested ) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested ) j_end = MIN( jde-2, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + zxavg(i,k,j) = 0.25 * ( zx(i,k ,j) + zx(i+1,k ,j) + & + zx(i,k+1,j) + zx(i+1,k+1,j) ) + zyavg(i,k,j) = 0.25 * ( zy(i,k ,j) + zy(i,k ,j+1) + & + zy(i,k+1,j) + zy(i,k+1,j+1) ) + END DO + END DO + END DO + +! Begin calculating production of turbulence due to shear. The approach +! is to add together contributions from six terms, each of which is the +! square of a deformation that is then multiplied by an exchange +! coefficiant. The same exchange coefficient is assumed for horizontal +! and vertical coefficients for some of the terms (the vertical value is +! the one used). + +! For defor11. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + 0.5 * & + mu(i,j) * xkmh(i,k,j) * ( ( defor11(i,k,j) )**2 ) + END DO + END DO + END DO + +! For defor22. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + 0.5 * & + mu(i,j) * xkmh(i,k,j) * ( ( defor22(i,k,j) )**2 ) + END DO + END DO + END DO + +! For defor33. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + 0.5 * & + mu(i,j) * xkmv(i,k,j) * ( ( defor33(i,k,j) )**2 ) + END DO + END DO + END DO + +! For defor12. + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + avg(i,k,j) = 0.25 * & + ( ( defor12(i ,k,j)**2 ) + ( defor12(i ,k,j+1)**2 ) + & + ( defor12(i+1,k,j)**2 ) + ( defor12(i+1,k,j+1)**2 ) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmh(i,k,j) * avg(i,k,j) + END DO + END DO + END DO + +! For defor13. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end+1 + tmp2(i,k,j) = defor13(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end+1 + tmp2(i,kts ,j) = 0.0 + tmp2(i,ktf+1,j) = 0.0 + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + avg(i,k,j) = 0.25 * & + ( ( tmp2(i ,k+1,j)**2 ) + ( tmp2(i ,k,j)**2 ) + & + ( tmp2(i+1,k+1,j)**2 ) + ( tmp2(i+1,k,j)**2 ) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmv(i,k,j) * avg(i,k,j) + END DO + END DO + END DO + +!MARTA: add the drag at the surface; WCS 040331 + K=KTS + + cd0 = config_flags%tke_drag_coefficient ! drag coefficient set + ! in namelist.input + DO j = j_start, j_end + DO i = i_start, i_end + + absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) + + tendency(i,k,j) = tendency(i,k,j) + & + mu(i,j)*( (u(i,k,j)+u(i+1,k,j))*0.5* & + cd0*absU*defor13(i,kts+1,j)) + + END DO + END DO +! end of MARTA/WCS change + +! For defor23. + + DO j = j_start, j_end+1 + DO k = kts+1, ktf + DO i = i_start, i_end + tmp2(i,k,j) = defor23(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end+1 + DO i = i_start, i_end + tmp2(i,kts, j) = 0.0 + tmp2(i,ktf+1,j) = 0.0 + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + avg(i,k,j) = 0.25 * & + ( ( tmp2(i,k+1,j )**2 ) + ( tmp2(i,k,j )**2) + & + ( tmp2(i,k+1,j+1)**2 ) + ( tmp2(i,k,j+1)**2) ) + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmv(i,k,j) * avg(i,k,j) + END DO + END DO + END DO + +!MARTA: add the drag at the surface; WCS 040331 + K=KTS + + cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient + ! set in namelist.input + DO j = j_start, j_end + DO i = i_start, i_end + + absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) + + tendency(i,k,j) = tendency(i,k,j) + & + mu(i,j)*( (v(i,k,j)+v(i,k,j+1))*0.5* & + cd0*absU*defor23(i,kts+1,j)) + + END DO + END DO +! end of MARTA/WCS change + + END SUBROUTINE tke_shear + +!======================================================================= +!======================================================================= + + SUBROUTINE compute_diff_metrics( config_flags, ph, phb, z, rdz, rdzw, & + zx, zy, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!----------------------------------------------------------------------- +! Begin declarations. + + IMPLICIT NONE + + TYPE( grid_config_rec_type ), INTENT( IN ) & + :: config_flags + + INTEGER, INTENT( IN ) & + :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: ph, phb + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( OUT ) & + :: rdz, rdzw, zx, zy, z + + REAL, INTENT( IN ) & + :: rdx, rdy + +! Local variables. + + INTEGER & + :: i, j, k, i_start, i_end, j_start, j_end, ktf + +! End declarations. +!----------------------------------------------------------------------- + + ktf = MIN( kte, kde-1 ) + +! Bug fix, WCS, 22 april 2002. + +! We need rdzw in halo for average to u and v points. + + j_start = jts-1 + j_end = jte + +! Begin with dz computations. + + DO j = j_start, j_end + + IF ( ( j_start >= jts ) .AND. ( j_end <= MIN( jte, jde-1 ) ) ) THEN + i_start = its-1 + i_end = ite + ELSE + i_start = its + i_end = MIN( ite, ide-1 ) + END IF + +! Compute z at w points for rdz and rdzw computations. We'll switch z +! to z at p points before returning + + DO k = 1, kte + +! Bug fix, WCS, 22 april 2002 + + DO i = i_start, i_end + z(i,k,j) = ( ph(i,k,j) + phb(i,k,j) ) / g + END DO + END DO + + DO k = 1, ktf + DO i = i_start, i_end + rdzw(i,k,j) = 1.0 / ( z(i,k+1,j) - z(i,k,j) ) + END DO + END DO + + DO k = 2, ktf + DO i = i_start, i_end + rdz(i,k,j) = 2.0 / ( z(i,k+1,j) - z(i,k-1,j) ) + END DO + END DO + +! Bug fix, WCS, 22 april 2002; added the following code + + DO i = i_start, i_end + rdz(i,1,j) = 2./(z(i,2,j)-z(i,1,j)) + END DO + + END DO + +! End bug fix. + +! Now compute zx and zy; we'll assume that the halo for ph and phb is +! properly filled. + + i_start = its + i_end = MIN( ite, ide-1 ) + j_start = jts + j_end = MIN( jte, jde-1 ) + + DO j = j_start, j_end + DO k = 1, kte + DO i = MAX( ids+1, its ), i_end + zx(i,k,j) = rdx * ( phb(i,k,j) - phb(i-1,k,j) ) / g + END DO + END DO + END DO + + DO j = j_start, j_end + DO k = 1, kte + DO i = MAX( ids+1, its ), i_end + zx(i,k,j) = zx(i,k,j) + rdx * ( ph(i,k,j) - ph(i-1,k,j) ) / g + END DO + END DO + END DO + + DO j = MAX( jds+1, jts ), j_end + DO k = 1, kte + DO i = i_start, i_end + zy(i,k,j) = rdy * ( phb(i,k,j) - phb(i,k,j-1) ) / g + END DO + END DO + END DO + + DO j = MAX( jds+1, jts ), j_end + DO k = 1, kte + DO i = i_start, i_end + zy(i,k,j) = zy(i,k,j) + rdy * ( ph(i,k,j) - ph(i,k,j-1) ) / g + END DO + END DO + END DO + +! Some b.c. on zx and zy. + + IF ( .NOT. config_flags%periodic_x ) THEN + + IF ( ite == ide ) THEN + DO j = j_start, j_end + DO k = 1, ktf + zx(ide,k,j) = 0.0 + END DO + END DO + END IF + + IF ( its == ids ) THEN + DO j = j_start, j_end + DO k = 1, ktf + zx(ids,k,j) = 0.0 + END DO + END DO + END IF + + ELSE + + IF ( ite == ide ) THEN + DO j=j_start,j_end + DO k=1,ktf + zx(ide,k,j) = rdx * ( phb(ide,k,j) - phb(ide-1,k,j) ) / g + END DO + END DO + + DO j = j_start, j_end + DO k = 1, ktf + zx(ide,k,j) = zx(ide,k,j) + rdx * ( ph(ide,k,j) - ph(ide-1,k,j) ) / g + END DO + END DO + END IF + + IF ( its == ids ) THEN + DO j = j_start, j_end + DO k = 1, ktf + zx(ids,k,j) = rdx * ( phb(ids,k,j) - phb(ids-1,k,j) ) / g + END DO + END DO + + DO j =j_start,j_end + DO k =1,ktf + zx(ids,k,j) = zx(ids,k,j) + rdx * ( ph(ids,k,j) - ph(ids-1,k,j) ) / g + END DO + END DO + END IF + + END IF + + IF ( .NOT. config_flags%periodic_y ) THEN + + IF ( jte == jde ) THEN + DO k =1, ktf + DO i =i_start, i_end + zy(i,k,jde) = 0.0 + END DO + END DO + END IF + + IF ( jts == jds ) THEN + DO k =1, ktf + DO i =i_start, i_end + zy(i,k,jds) = 0.0 + END DO + END DO + END IF + + ELSE + + IF ( jte == jde ) THEN + DO j=j_start, j_end + DO k=1, ktf + zy(i,k,jde) = rdy * ( phb(i,k,jde) - phb(i,k,jde-1) ) / g + END DO + END DO + + DO j = j_start, j_end + DO k = 1, ktf + zy(i,k,jde) = zy(i,k,jde) + rdy * ( ph(i,k,jde) - ph(i,k,jde-1) ) / g + END DO + END DO + END IF + + IF ( jts == jds ) THEN + DO j = j_start, j_end + DO k = 1, ktf + zy(i,k,jds) = rdy * ( phb(i,k,jds) - phb(i,k,jds-1) ) / g + END DO + END DO + + DO j = j_start, j_end + DO k = 1, ktf + zy(i,k,jds) = zy(i,k,jds) + rdy * ( ph(i,k,jds) - ph(i,k,jds-1) ) / g + END DO + END DO + END IF + + END IF + +! Calculate z at p points. + + DO j = j_start, j_end + DO k = 1, ktf + DO i = i_start, i_end + z(i,k,j) = 0.5 * & + ( ph(i,k,j) + phb(i,k,j) + ph(i,k+1,j) + phb(i,k+1,j) ) / g + END DO + END DO + END DO + + END SUBROUTINE compute_diff_metrics + +!======================================================================= +!======================================================================= + + END MODULE module_diffusion_em + +!======================================================================= +!======================================================================= + + diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F new file mode 100644 index 00000000..75983bba --- /dev/null +++ b/wrfv2_fire/dyn_em/module_em.F @@ -0,0 +1,1688 @@ +!WRF:MODEL_LAYER:DYNAMICS +! + +MODULE module_em + + USE module_model_constants + USE module_advect_em + USE module_big_step_utilities_em + USE module_state_description + +CONTAINS + +!------------------------------------------------------------------------ + +SUBROUTINE rk_step_prep ( config_flags, rk_step, & + u, v, w, t, ph, mu, & + moist, & + ru, rv, rw, ww, php, alt, muu, muv, & + mub, mut, phb, pb, p, al, alb, & + cqu, cqv, cqw, & + msfu, msfv, msft, & + fnm, fnp, dnw, rdx, rdy, & + n_moist, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + + ! Input data. + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist, rk_step + + REAL , INTENT(IN ) :: rdx, rdy + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: u, & + v, & + w, & + t, & + ph, & + phb, & + pb, & + al, & + alb + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT( OUT) :: ru, & + rv, & + rw, & + ww, & + php, & + cqu, & + cqv, & + cqw, & + alt + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: p + + + + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( IN) :: & + moist + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msft, & + msfu, & + msfv, & + mu, & + mub + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: muu, & + muv, & + mut + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, fnp, dnw + + integer :: k + + +! +! +! rk_step_prep prepares a number of diagnostic quantities +! in preperation for a Runge-Kutta timestep. subroutines called +! by rk_step_prep calculate +! +! (1) total column dry air mass (mut, call to calculate_full) +! +! (2) total column dry air mass at u and v points +! (muu, muv, call to calculate_mu_uv) +! +! (3) mass-coupled velocities for advection +! (ru, rv, and rw, call to couple_momentum) +! +! (4) omega (call to calc_ww_cp) +! +! (5) moisture coefficients (cqu, cqv, cqw, call to calc_cq) +! +! (6) inverse density (alt, call to calc_alt) +! +! (7) geopotential at pressure points (php, call to calc_php) +! +! + + CALL calculate_full( mut, mub, mu, & + ids, ide, jds, jde, 1, 2, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + CALL calc_mu_uv ( config_flags, & + mu, mub, muu, muv, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL couple_momentum( muu, ru, u, msfu, & + muv, rv, v, msfv, & + mut, rw, w, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! new call, couples V with mu, also has correct map factors. WCS, 3 june 2001 + CALL calc_ww_cp ( u, v, mu, mub, ww, & + rdx, rdy, msft, msfu, msfv, dnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL calc_cq ( moist, cqu, cqv, cqw, n_moist, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL calc_alt ( alt, al, alb, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL calc_php ( php, ph, phb, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +END SUBROUTINE rk_step_prep + +!------------------------------------------------------------------------------- + +SUBROUTINE rk_tendency ( config_flags, rk_step, & + ru_tend, rv_tend, rw_tend, ph_tend, t_tend, & + ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, & + mu_tend, u_save, v_save, w_save, ph_save, & + t_save, mu_save, RTHFTEN, & + ru, rv, rw, ww, & + u, v, w, t, ph, & + u_old, v_old, w_old, t_old, ph_old, & + h_diabatic, phb,t_init, & + mu, mut, muu, muv, mub, & + al, alt, p, pb, php, cqu, cqv, cqw, & + u_base, v_base, t_base, qv_base, z_base, & + msfu, msfv, msft, f, e, sina, cosa, & + fnm, fnp, rdn, rdnw, & + dt, rdx, rdy, khdif, kvdif, xkmhd, & + diff_6th_opt, diff_6th_factor, & + dampcoef,zdamp,damp_opt, & + cf1, cf2, cf3, cfn, cfn1, n_moist, & + non_hydrostatic, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL , INTENT(IN ) :: non_hydrostatic + + INTEGER , INTENT(IN ) :: n_moist, rk_step + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: ru, & + rv, & + rw, & + ww, & + u, & + v, & + w, & + t, & + ph, & + u_old, & + v_old, & + w_old, & + t_old, & + ph_old, & + phb, & + al, & + alt, & + p, & + pb, & + php, & + cqu, & + cqv, & + t_init, & + xkmhd, & + h_diabatic + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(OUT ) :: ru_tend, & + rv_tend, & + rw_tend, & + t_tend, & + ph_tend, & + RTHFTEN, & + u_save, & + v_save, & + w_save, & + ph_save, & + t_save + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(INOUT) :: ru_tendf, & + rv_tendf, & + rw_tendf, & + t_tendf, & + ph_tendf, & + cqw + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: mu_tend, & + mu_save + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft, & + f, & + e, & + sina, & + cosa, & + mu, & + mut, & + mub, & + muu, & + muv + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, & + fnp, & + rdn, & + rdnw, & + u_base, & + v_base, & + t_base, & + qv_base, & + z_base + + REAL , INTENT(IN ) :: rdx, & + rdy, & + dt, & + khdif, & + kvdif + INTEGER, INTENT( IN ) :: diff_6th_opt + REAL, INTENT( IN ) :: diff_6th_factor + + INTEGER, INTENT( IN ) :: damp_opt + + REAL, INTENT( IN ) :: zdamp, dampcoef + + REAL :: kdift, khdq, kvdq, cfn, cfn1, cf1, cf2, cf3 + INTEGER :: i,j,k + +! +! +! rk_tendency computes the large-timestep tendency terms in the +! momentum, thermodynamic (theta), and geopotential equations. +! These terms include: +! +! (1) advection (for u, v, w, theta - calls to advect_u, advect_v, +! advect_w, and advact_scalar). +! +! (2) geopotential equation terms (advection and "gw" - call to rhs_ph). +! +! (3) buoyancy term in vertical momentum equation (call to pg_buoy_w). +! +! (4) Coriolis and curvature terms in u,v,w momentum equations +! (calls to subroutines coriolis, curvature) +! +! (5) 3D diffusion on coordinate surfaces. +! +! + + CALL zero_tend ( ru_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( rv_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( rw_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( t_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( ph_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( u_save, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( v_save, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( w_save, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( ph_save, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( t_save, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( mu_tend, & + ids, ide, jds, jde, 1, 1, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + CALL zero_tend ( mu_save, & + ids, ide, jds, jde, 1, 1, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + ! advection tendencies + + CALL advect_u ( u, u , ru_tend, ru, rv, ww, & + mut, config_flags, & + msfu, msfv, msft, & + fnm, fnp, rdx, rdy, rdnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL advect_v ( v, v , rv_tend, ru, rv, ww, & + mut, config_flags, & + msfu, msfv, msft, & + fnm, fnp, rdx, rdy, rdnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (non_hydrostatic) & + CALL advect_w ( w, w, rw_tend, ru, rv, ww, & + mut, config_flags, & + msfu, msfv, msft, & + fnm, fnp, rdx, rdy, rdn, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! theta flux divergence + + CALL advect_scalar ( t, t, t_tend, ru, rv, ww, & + mut, config_flags, & + msfu, msfv, msft, fnm, fnp, & + rdx, rdy, rdnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF ( config_flags%cu_physics == GDSCHEME ) THEN + + ! theta advection only: + + CALL set_tend( RTHFTEN, t_tend, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + END IF + + CALL rhs_ph( ph_tend, u, v, ww, ph, ph, phb, w, & + mut, muu, muv, & + fnm, fnp, & + rdnw, cfn, cfn1, rdx, rdy, msft, & + non_hydrostatic, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + CALL horizontal_pressure_gradient( ru_tend,rv_tend, & + ph,alt,p,pb,al,php,cqu,cqv, & + muu,muv,mu,fnm,fnp,rdnw, & + cf1,cf2,cf3,rdx,rdy,msft, & + config_flags, non_hydrostatic, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (non_hydrostatic) & + CALL pg_buoy_w( rw_tend, p, cqw, mu, mub, & + rdnw, rdn, g, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL w_damp ( rw_tend, ww, w, mut, rdnw, dt, & + config_flags%w_damping, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(config_flags%pert_coriolis) THEN + + CALL perturbation_coriolis ( ru, rv, rw, & + ru_tend, rv_tend, rw_tend, & + config_flags, & + u_base, v_base, z_base, & + muu, muv, phb, ph, & + f, e, sina, cosa, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE + + CALL coriolis ( ru, rv, rw, & + ru_tend, rv_tend, rw_tend, & + config_flags, & + f, e, sina, cosa, fnm, fnp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + END IF + + + CALL curvature ( ru, rv, rw, u, v, w, & + ru_tend, rv_tend, rw_tend, & + config_flags, & + msfu, msfv, fnm, fnp, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +!************************************************************** +! +! Next, the terms that we integrate only with forward-in-time +! (evaluate with time t variables). +! +!************************************************************** + + forward_step: IF( rk_step == 1 ) THEN + + diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN + + CALL horizontal_diffusion ('u', u, ru_tendf, mut, config_flags, & + msfu, msfv, msft, & + khdif, xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL horizontal_diffusion ('v', v, rv_tendf, mut, config_flags, & + msfu, msfv, msft, & + khdif, xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL horizontal_diffusion ('w', w, rw_tendf, mut, config_flags, & + msfu, msfv, msft, & + khdif, xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + khdq = 3.*khdif + CALL horizontal_diffusion_3dmp ( 'm', t, t_tendf, mut, & + config_flags, t_init, & + msfu, msfv, msft, & + khdq , xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN + + CALL vertical_diffusion_u ( u, ru_tendf, config_flags, & + u_base, & + alt, muu, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL vertical_diffusion_v ( v, rv_tendf, config_flags, & + v_base, & + alt, muv, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (non_hydrostatic) & + CALL vertical_diffusion ( 'w', w, rw_tendf, config_flags, & + alt, mut, rdn, rdnw, kvdif, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + kvdq = 3.*kvdif + CALL vertical_diffusion_3dmp ( t, t_tendf, config_flags, t_init, & + alt, mut, rdn, rdnw, kvdq , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDIF pbl_test + + ! Theta tendency computations. + + END IF diff_opt1 + + IF ( diff_6th_opt .NE. 0 ) THEN + + CALL sixth_order_diffusion( 'u', u, ru_tendf, mut, dt, & + config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL sixth_order_diffusion( 'v', v, rv_tendf, mut, dt, & + config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF (non_hydrostatic) & + CALL sixth_order_diffusion( 'w', w, rw_tendf, mut, dt, & + config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL sixth_order_diffusion( 'm', t, t_tendf, mut, dt, & + config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDIF + + IF( damp_opt .eq. 2 ) & + CALL rk_rayleigh_damp( ru_tendf, rv_tendf, & + rw_tendf, t_tendf, & + u, v, w, t, t_init, & + mut, muu, muv, ph, phb, & + u_base, v_base, t_base, z_base, & + dampcoef, zdamp, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + END IF forward_step + +END SUBROUTINE rk_tendency + +!------------------------------------------------------------------------------- + +SUBROUTINE rk_addtend_dry ( ru_tend, rv_tend, rw_tend, ph_tend, t_tend, & + ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, & + u_save, v_save, w_save, ph_save, t_save, & + mu_tend, mu_tendf, rk_step, & + h_diabatic, mut, msft, msfu, msfv, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: rk_step + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: ru_tend, & + rv_tend, & + rw_tend, & + ph_tend, & + t_tend, & + ru_tendf, & + rv_tendf, & + rw_tendf, & + ph_tendf, & + t_tendf + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tend, & + mu_tendf + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN ) :: u_save, & + v_save, & + w_save, & + ph_save, & + t_save, & + h_diabatic + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, & + msft, & + msfu, & + msfv + + +! Local + INTEGER :: i, j, k + + +! +! +! rk_addtend_dry constructs the full large-timestep tendency terms for +! momentum (u,v,w), theta and geopotential equations. This is accomplished +! by combining the physics tendencies (in *tendf; these are computed +! the first RK substep, held fixed thereafter) with the RK tendencies +! (in *tend, these include advection, pressure gradient, etc; +! these change each rk substep). Output is in *tend. +! +! + +! Finally, add the forward-step tendency to the rk_tendency + +! u/v/w/save contain bc tendency that needs to be multiplied by msf +! before adding it to physics tendency (*tendf) +! For momentum we need the final tendency to include an inverse msf +! physics/bc tendency needs to be divided, advection tendency already has it + +! For scalars we need the final tendency to include an inverse msf +! advection tendency is OK, physics/bc tendency needs to be divided by msf + + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,ite + IF(rk_step == 1)ru_tendf(i,k,j) = ru_tendf(i,k,j) + u_save(i,k,j)*msfu(i,j) + ru_tend(i,k,j) = ru_tend(i,k,j) + ru_tendf(i,k,j)/msfu(i,j) + ENDDO + ENDDO + ENDDO + + DO j = jts,jte + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + IF(rk_step == 1)rv_tendf(i,k,j) = rv_tendf(i,k,j) + v_save(i,k,j)*msfv(i,j) + rv_tend(i,k,j) = rv_tend(i,k,j) + rv_tendf(i,k,j)/msfv(i,j) + ENDDO + ENDDO + ENDDO + + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte + DO i = its,MIN(ite,ide-1) + IF(rk_step == 1)rw_tendf(i,k,j) = rw_tendf(i,k,j) + w_save(i,k,j)*msft(i,j) + rw_tend(i,k,j) = rw_tend(i,k,j) + rw_tendf(i,k,j)/msft(i,j) + IF(rk_step == 1)ph_tendf(i,k,j) = ph_tendf(i,k,j) + ph_save(i,k,j) + ph_tend(i,k,j) = ph_tend(i,k,j) + ph_tendf(i,k,j)/msft(i,j) + ENDDO + ENDDO + ENDDO + + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + IF(rk_step == 1)t_tendf(i,k,j) = t_tendf(i,k,j) + t_save(i,k,j) + t_tend(i,k,j) = t_tend(i,k,j) + t_tendf(i,k,j)/msft(i,j) & + + mut(i,j)*h_diabatic(i,k,j)/msft(i,j) + ENDDO + ENDDO + ENDDO + + DO j = jts,MIN(jte,jde-1) + DO i = its,MIN(ite,ide-1) +! mu tendencies not coupled with 1/msf + mu_tend(i,j) = mu_tend(i,j) + mu_tendf(i,j) + ENDDO + ENDDO + +END SUBROUTINE rk_addtend_dry + +!------------------------------------------------------------------------------- + +SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & + rk_step, dt, & + ru, rv, ww, mut, mub, mu_old, & + alt, & + scalar_old, scalar, & + scalar_tends, advect_tend, & + RQVFTEN, & + base, moist_step, fnm, fnp, & + msfu, msfv, msft, & + rdx, rdy, rdn, rdnw, & + khdif, kvdif, xkmhd, & + diff_6th_opt, diff_6th_factor,& + pd_advection, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: rk_step, scs, sce + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + LOGICAL , INTENT(IN ) :: moist_step + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), & + INTENT(INOUT) :: scalar, scalar_old + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), & + INTENT(INOUT) :: scalar_tends + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: advect_tend + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: RQVFTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: ru, & + rv, & + ww, & + xkmhd, & + alt + + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, & + fnp, & + rdn, & + rdnw, & + base + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, & + msfv, & + msft, & + mub, & + mut, & + mu_old + + REAL , INTENT(IN ) :: rdx, & + rdy, & + khdif, & + kvdif + + INTEGER, INTENT( IN ) :: diff_6th_opt + REAL, INTENT( IN ) :: diff_6th_factor + + REAL , INTENT(IN ) :: dt + + LOGICAL, INTENT(IN ) :: pd_advection + + ! Local data + + INTEGER :: im, i,j,k + + REAL :: khdq, kvdq, tendency + +! +! +! rk_scalar_tend calls routines that computes scalar tendency from advection +! and 3D mixing (TKE or fixed eddy viscosities). +! +! + + + khdq = khdif/prandtl + kvdq = kvdif/prandtl + + scalar_loop : DO im = scs, sce + + CALL zero_tend ( advect_tend(ims,kms,jms), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF( (rk_step == 3) .and. pd_advection ) THEN + + CALL advect_scalar_pd ( scalar(ims,kms,jms,im), & + scalar_old(ims,kms,jms,im), & + advect_tend(ims,kms,jms), & + ru, rv, ww, mut, mub, mu_old, & + config_flags, & + msfu, msfv, msft, fnm, fnp, & + rdx, rdy, rdnw,dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ELSE + + CALL advect_scalar ( scalar(ims,kms,jms,im), & + scalar(ims,kms,jms,im), & + advect_tend(ims,kms,jms), & + ru, rv, ww, mut, config_flags, & + msfu, msfv, msft, fnm, fnp, & + rdx, rdy, rdnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + END IF + + IF( config_flags%cu_physics == GDSCHEME .and. moist_step .and. ( im == P_QV) ) THEN + + CALL set_tend( RQVFTEN, advect_tend, msft, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + rk_step_1: IF( rk_step == 1 ) THEN + + diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN + + CALL horizontal_diffusion ( 'm', scalar(ims,kms,jms,im), & + scalar_tends(ims,kms,jms,im), mut, & + config_flags, & + msfu, msfv, msft, khdq , xkmhd, rdx, rdy, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN + + IF( (moist_step) .and. ( im == P_QV)) THEN + + CALL vertical_diffusion_mp ( scalar(ims,kms,jms,im), & + scalar_tends(ims,kms,jms,im), & + config_flags, base, & + alt, mut, rdn, rdnw, kvdq , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ELSE + + CALL vertical_diffusion ( 'm', scalar(ims,kms,jms,im), & + scalar_tends(ims,kms,jms,im), & + config_flags, & + alt, mut, rdn, rdnw, kvdq, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + END IF + + ENDIF pbl_test + + ENDIF diff_opt1 + + IF ( diff_6th_opt .NE. 0 ) & + CALL sixth_order_diffusion( 'm', scalar(ims,kms,jms,im), & + scalar_tends(ims,kms,jms,im), & + mut, dt, config_flags, & + diff_6th_opt, diff_6th_factor, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDIF rk_step_1 + + END DO scalar_loop + +END SUBROUTINE rk_scalar_tend + +!------------------------------------------------------------------------------- + +SUBROUTINE rk_update_scalar( scs, sce, & + scalar_1, scalar_2, sc_tend, & + advect_tend, msft, & + mu_old, mu_new, mu_base, & + rk_step, dt, spec_zone, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: scs, sce, rk_step, spec_zone + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT(IN ) :: dt + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), & + INTENT(INOUT) :: scalar_1, & + scalar_2, & + sc_tend + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: advect_tend + + REAL, DIMENSION(ims:ime, jms:jme ), INTENT(IN ) :: mu_old, & + mu_new, & + mu_base, & + msft + + INTEGER :: i,j,k,im + REAL :: sc_middle, msfsq + REAL, DIMENSION(its:ite) :: muold, r_munew + + REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: tendency + + INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end + INTEGER :: i_start_spc,i_end_spc,j_start_spc,j_end_spc,k_start_spc,k_end_spc + +! +! +! rk_scalar_update advances the scalar equation given the time t value +! of the scalar and the scalar tendency. +! +! + + +! +! set loop limits. + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + + i_start_spc = i_start + i_end_spc = i_end + j_start_spc = j_start + j_end_spc = j_end + k_start_spc = k_start + k_end_spc = k_end + + IF( config_flags%nested .or. config_flags%specified ) THEN + IF( .NOT. config_flags%periodic_x)i_start = max( its,ids+spec_zone ) + IF( .NOT. config_flags%periodic_x)i_end = min( ite,ide-spec_zone-1 ) + j_start = max( jts,jds+spec_zone ) + j_end = min( jte,jde-spec_zone-1 ) + k_start = kts + k_end = min( kte, kde-1 ) + ENDIF + + IF ( rk_step == 1 ) THEN + + ! replace t-dt values (in scalar_1) with t values scalar_2, + ! then compute new values by adding tendency to values at t + + DO im = scs,sce + + DO j = jts, min(jte,jde-1) + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + tendency(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO j = j_start,j_end + DO k = k_start,k_end + DO i = i_start,i_end + tendency(i,k,j) = advect_tend(i,k,j) * msft(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start_spc,j_end_spc + DO k = k_start_spc,k_end_spc + DO i = i_start_spc,i_end_spc + tendency(i,k,j) = tendency(i,k,j) + sc_tend(i,k,j,im) + ENDDO + ENDDO + ENDDO + + DO j = jts, min(jte,jde-1) + + DO i = its, min(ite,ide-1) + muold(i) = mu_old(i,j) + mu_base(i,j) + r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + ENDDO + + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + + scalar_1(i,k,j,im) = scalar_2(i,k,j,im) + scalar_2(i,k,j,im) = (muold(i)*scalar_1(i,k,j,im) & + + dt*tendency(i,k,j))*r_munew(i) + + ENDDO + ENDDO + ENDDO + + ENDDO + + ELSE + + ! just compute new values, scalar_1 already at time t. + + DO im = scs, sce + + DO j = jts, min(jte,jde-1) + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + tendency(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO j = j_start,j_end + DO k = k_start,k_end + DO i = i_start,i_end + tendency(i,k,j) = advect_tend(i,k,j) * msft(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start_spc,j_end_spc + DO k = k_start_spc,k_end_spc + DO i = i_start_spc,i_end_spc + tendency(i,k,j) = tendency(i,k,j) + sc_tend(i,k,j,im) + ENDDO + ENDDO + ENDDO + + DO j = jts, min(jte,jde-1) + + DO i = its, min(ite,ide-1) + muold(i) = mu_old(i,j) + mu_base(i,j) + r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + ENDDO + + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + + scalar_2(i,k,j,im) = (muold(i)*scalar_1(i,k,j,im) & + + dt*tendency(i,k,j))*r_munew(i) + + ENDDO + ENDDO + ENDDO + + ENDDO + + END IF + +END SUBROUTINE rk_update_scalar + +!------------------------------------------------------------------------------- + +SUBROUTINE rk_update_scalar_pd( scs, sce, & + scalar, sc_tend, & + msft, & + mu_old, mu_new, mu_base, & + rk_step, dt, spec_zone, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: scs, sce, rk_step, spec_zone + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, INTENT(IN ) :: dt + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce), & + INTENT(INOUT) :: scalar, & + sc_tend + + REAL, DIMENSION(ims:ime, jms:jme ), INTENT(IN ) :: mu_old, & + mu_new, & + mu_base, & + msft + + INTEGER :: i,j,k,im + REAL :: sc_middle, msfsq + REAL, DIMENSION(its:ite) :: muold, r_munew + + REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: tendency + + INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end + INTEGER :: i_start_spc,i_end_spc,j_start_spc,j_end_spc,k_start_spc,k_end_spc + +! +! +! rk_scalar_update advances the scalar equation given the time t value +! of the scalar and the scalar tendency. +! +! + + +! +! set loop limits. + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + + i_start_spc = i_start + i_end_spc = i_end + j_start_spc = j_start + j_end_spc = j_end + k_start_spc = k_start + k_end_spc = k_end + + IF( config_flags%nested .or. config_flags%specified ) THEN + IF( .NOT. config_flags%periodic_x)i_start = max( its,ids+spec_zone ) + IF( .NOT. config_flags%periodic_x)i_end = min( ite,ide-spec_zone-1 ) + j_start = max( jts,jds+spec_zone ) + j_end = min( jte,jde-spec_zone-1 ) + k_start = kts + k_end = min( kte, kde-1 ) + ENDIF + + DO im = scs, sce + + DO j = jts, min(jte,jde-1) + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + tendency(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO j = j_start_spc,j_end_spc + DO k = k_start_spc,k_end_spc + DO i = i_start_spc,i_end_spc + tendency(i,k,j) = tendency(i,k,j) + sc_tend(i,k,j,im) + sc_tend(i,k,j,im) = 0. + ENDDO + ENDDO + ENDDO + + DO j = jts, min(jte,jde-1) + + DO i = its, min(ite,ide-1) + muold(i) = mu_old(i,j) + mu_base(i,j) + r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + ENDDO + + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + + scalar(i,k,j,im) = (muold(i)*scalar(i,k,j,im) & + + dt*tendency(i,k,j))*r_munew(i) + ENDDO + ENDDO + ENDDO + + ENDDO + +END SUBROUTINE rk_update_scalar_pd + +!------------------------------------------------------------ + +SUBROUTINE init_zero_tendency(ru_tendf, rv_tendf, rw_tendf, ph_tendf, & + t_tendf, tke_tendf, mu_tendf, & + moist_tendf,chem_tendf,scalar_tendf, & + n_moist,n_chem,n_scalar,rk_step, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,rk_step + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: & + ru_tendf, & + rv_tendf, & + rw_tendf, & + ph_tendf, & + t_tendf, & + tke_tendf + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist),INTENT(INOUT)::& + moist_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_chem ),INTENT(INOUT)::& + chem_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar ),INTENT(INOUT)::& + scalar_tendf + +! LOCAL VARS + + INTEGER :: im, ic, is + +! +! +! init_zero_tendency +! sets tendency arrays to zero for all prognostic variables. +! +! + + + CALL zero_tend ( ru_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( rv_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( rw_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( ph_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( t_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( tke_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL zero_tend ( mu_tendf, & + ids, ide, jds, jde, kds, kds, & + ims, ime, jms, jme, kms, kms, & + its, ite, jts, jte, kts, kts ) + +! DO im=PARAM_FIRST_SCALAR,n_moist + DO im=1,n_moist ! make sure first one is zero too + CALL zero_tend ( moist_tendf(ims,kms,jms,im), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO + +! DO ic=PARAM_FIRST_SCALAR,n_chem + DO ic=1,n_chem ! make sure first one is zero too + CALL zero_tend ( chem_tendf(ims,kms,jms,ic), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO + +! DO ic=PARAM_FIRST_SCALAR,n_scalar + DO ic=1,n_scalar ! make sure first one is zero too + CALL zero_tend ( scalar_tendf(ims,kms,jms,ic), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO + +END SUBROUTINE init_zero_tendency + +!=================================================================== + + +SUBROUTINE dump_data( a, field, io_unit, & + ims, ime, jms, jme, kms, kme, & + ids, ide, jds, jde, kds, kde ) +implicit none +integer :: ims, ime, jms, jme, kms, kme, & + ids, ide, jds, jde, kds, kde +real, dimension(ims:ime, kms:kme, jds:jde) :: a +character :: field +integer :: io_unit + +integer :: is,ie,js,je,ks,ke + +! +! +! calculate_phy_tend couples the physics tendencies to the column mass (mu), +! because prognostic equations are in flux form, but physics tendencies are +! computed for uncoupled variables. +! +! + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + ktf=MIN(kte,kde-1) + itsu=MAX(its,ids+1) + jtsv=MAX(jts,jds+1) + +! radiation + + IF (config_flags%ra_lw_physics .gt. 0 .or. config_flags%ra_sw_physics .gt. 0) THEN + + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RTHRATEN(I,K,J)=mu(I,J)*RTHRATEN(I,K,J) + ENDDO + ENDDO + ENDDO + + ENDIF + +! cumulus + + IF (config_flags%cu_physics .gt. 0) THEN + + DO J=jts,jtf + DO I=its,itf + DO K=kts,ktf + RTHCUTEN(I,K,J)=mu(I,J)*RTHCUTEN(I,K,J) + RQVCUTEN(I,K,J)=mu(I,J)*RQVCUTEN(I,K,J) + ENDDO + ENDDO + ENDDO + + IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO I=its,itf + DO K=kts,ktf + RQCCUTEN(I,K,J)=mu(I,J)*RQCCUTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO I=its,itf + DO K=kts,ktf + RQRCUTEN(I,K,J)=mu(I,J)*RQRCUTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO I=its,itf + DO K=kts,ktf + RQICUTEN(I,K,J)=mu(I,J)*RQICUTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN + DO J=jts,jtf + DO I=its,itf + DO K=kts,ktf + RQSCUTEN(I,K,J)=mu(I,J)*RQSCUTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + +! pbl + + IF (config_flags%bl_pbl_physics .gt. 0) THEN + + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RUBLTEN(I,K,J) =mu(I,J)*RUBLTEN(I,K,J) + RVBLTEN(I,K,J) =mu(I,J)*RVBLTEN(I,K,J) + RTHBLTEN(I,K,J)=mu(I,J)*RTHBLTEN(I,K,J) + ENDDO + ENDDO + ENDDO + + IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQVBLTEN(I,K,J)=mu(I,J)*RQVBLTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QC .ge. PARAM_FIRST_SCALAR) THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQCBLTEN(I,K,J)=mu(I,J)*RQCBLTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. PARAM_FIRST_SCALAR) THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQIBLTEN(I,K,J)=mu(I,J)*RQIBLTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + +! fdda +! note fdda u and v tendencies are staggered, also only interior points have muu/muv, +! so only couple those + + IF (config_flags%grid_fdda .gt. 0) THEN + + DO J=jts,jtf + DO K=kts,ktf + DO I=itsu,itf +! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & +! write(*,'(a,3i6,e15.5)') 'u_ten before=',i,k,j, RUNDGDTEN(i,k,j) + RUNDGDTEN(I,K,J) =muu(I,J)*RUNDGDTEN(I,K,J) +! if( i == itf/2 .AND. j == jtf/2 .AND. k==ktf/2 ) & +! write(*,'(a,2f15.5)') 'mu, muu=',mu(i,j), muu(i,j) +! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & +! write(*,'(a,3i6,e15.5)') 'u_ten after=',i,k,j, RUNDGDTEN(i,k,j) +! if( RUNDGDTEN(i,k,j) > 30.0 ) write(*,*) 'IKJ=',i,k,j + ENDDO + ENDDO + ENDDO +! write(*,'(a,e15.5)') 'u_ten MAXIMUM after=', maxval(RUNDGDTEN) + DO J=jtsv,jtf + DO K=kts,ktf + DO I=its,itf + RVNDGDTEN(I,K,J) =muv(I,J)*RVNDGDTEN(I,K,J) + ENDDO + ENDDO + ENDDO + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf +! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & +! write(*,'(a,3i6,e15.5)') 'th before=',i,k,j, RTHNDGDTEN(I,K,J) + RTHNDGDTEN(I,K,J)=mu(I,J)*RTHNDGDTEN(I,K,J) +! RMUNDGDTEN(I,J) - no coupling +! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & +! write(*,'(a,3i6,e15.5)') 'th after=',i,k,j, RTHNDGDTEN(I,K,J) + ENDDO + ENDDO + ENDDO + + IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + RQVNDGDTEN(I,K,J)=mu(I,J)*RQVNDGDTEN(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF + +END SUBROUTINE calculate_phy_tend + +!----------------------------------------------------------------------- + +SUBROUTINE positive_definite_filter ( a, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: a + + INTEGER :: i,k,j + +! +! +! debug and testing code for bounding a variable +! +! + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) +! a(i,k,j) = max(a(i,k,j),0.) + a(i,k,j) = min(1000.,max(a(i,k,j),0.)) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE positive_definite_filter + +!----------------------------------------------------------------------- + +SUBROUTINE bound_tke ( tke, tke_upper_bound, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: tke + REAL, INTENT( IN) :: tke_upper_bound + + INTEGER :: i,k,j + +! +! +! bounds tke between zero and tke_upper_bound. +! +! + + DO j=jts,min(jte,jde-1) + DO k=kts,kte-1 + DO i=its,min(ite,ide-1) + tke(i,k,j) = min(tke_upper_bound,max(tke(i,k,j),0.)) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE bound_tke + + + +END MODULE module_em diff --git a/wrfv2_fire/dyn_em/module_init_utilities.F b/wrfv2_fire/dyn_em/module_init_utilities.F new file mode 100644 index 00000000..9c140a92 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_init_utilities.F @@ -0,0 +1,95 @@ +MODULE module_init_utilities + +CONTAINS + + real function interp_0( v_in, & + z_in, z_out, nz_in ) + implicit none + integer nz_in, nz_out + real v_in(nz_in), z_in(nz_in) + real z_out + + integer kp, k, im, ip + logical interp, increasing_z + real height, w1, w2 + logical debug + parameter ( debug = .false. ) + +! does vertical coordinate increase or decrease with increasing k? +! set offset appropriately + + height = z_out + + if(debug) write(6,*) ' height in interp_0 ',height + + if (z_in(nz_in) .gt. z_in(1)) then + + if(debug) write(6,*) ' monotonic increase in z in interp_0 ' + IF (height > z_in(nz_in)) then + if(debug) write(6,*) ' point 1 in interp_0 ' + w2 = (z_in(nz_in)-height)/(z_in(nz_in)-z_in(nz_in-1)) + w1 = 1.-w2 + interp_0 = w1*v_in(nz_in) + w2*v_in(nz_in-1) + ELSE IF (height < z_in(1)) then + if(debug) write(6,*) ' point 2 in interp_0 ' + w2 = (z_in(2)-height)/(z_in(2)-z_in(1)) + w1 = 1.-w2 + interp_0 = w1*v_in(2) + w2*v_in(1) + ELSE + if(debug) write(6,*) ' point 3 in interp_0 ' + interp = .false. + kp = nz_in + DO WHILE ( (interp .eqv. .false.) .and. (kp .ge. 2) ) + IF( ((z_in(kp) .ge. height) .and. & + (z_in(kp-1) .le. height)) ) THEN + w2 = (height-z_in(kp))/(z_in(kp-1)-z_in(kp)) + w1 = 1.-w2 + interp_0 = w1*v_in(kp) + w2*v_in(kp-1) + if(debug) write(6,*) ' interp data, kp, w1, w2 ',kp, w1, w2 + if(debug) write(6,*) ' interp data, v_in(kp), v_in(kp-1), interp_0 ', & + v_in(kp), v_in(kp-1), interp_0 + interp = .true. + END IF + kp = kp-1 + ENDDO + ENDIF + + else + + if(debug) write(6,*) ' monotonic decrease in z in interp_0 ' + + IF (height < z_in(nz_in)) then + if(debug) write(6,*) ' point 1 in interp_0 ' + w2 = (z_in(nz_in)-height)/(z_in(nz_in)-z_in(nz_in-1)) + w1 = 1.-w2 + interp_0 = w1*v_in(nz_in) + w2*v_in(nz_in-1) + ELSE IF (height > z_in(1)) then + if(debug) write(6,*) ' point 2 in interp_0 ' + w2 = (z_in(2)-height)/(z_in(2)-z_in(1)) + w1 = 1.-w2 + interp_0 = w1*v_in(2) + w2*v_in(1) + ELSE + if(debug) write(6,*) ' point 3 in interp_0 ' + interp = .false. + kp = nz_in + height = z_out + DO WHILE ( (interp .eqv. .false.) .and. (kp .ge. 2) ) + IF( ((z_in(kp) .le. height) .and. & + (z_in(kp-1) .ge. height)) ) THEN + w2 = (height-z_in(kp))/(z_in(kp-1)-z_in(kp)) + w1 = 1.-w2 + interp_0 = w1*v_in(kp) + w2*v_in(kp-1) + interp = .true. + END IF + kp = kp-1 + ENDDO + ENDIF + + end if + + return + END FUNCTION interp_0 + +END MODULE module_init_utilities + + diff --git a/wrfv2_fire/dyn_em/module_initialize_b_wave.F b/wrfv2_fire/dyn_em/module_initialize_b_wave.F new file mode 100644 index 00000000..890f1830 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_b_wave.F @@ -0,0 +1,955 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + call wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding, debug + +! kludge space for initial jet + + INTEGER, parameter :: nz_jet=64, ny_jet=80 + REAL, DIMENSION(nz_jet, ny_jet) :: u_jet, rho_jet, th_jet, z_jet + +! perturbation parameters + + REAL, PARAMETER :: htbub=8000., radbub=2000000., radz=8000., tpbub=1.0 + REAL :: piov2, tp + INTEGER :: icen, jcen + real :: thtmp, ptmp, temp(3) + +#ifdef DM_PARALLEL +# include +#endif + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + piov2 = 2.*atan(1.0) + icen = ide/4 + jcen = jde/2 + + stretch_grid = .true. + delt = 0. + z_scale = .50 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/4 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1,' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + + grid%ht(i,j) = 0. + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 1.e-04 + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' reading input jet sounding ' + call read_input_jet( u_jet, rho_jet, th_jet, z_jet, nz_jet, ny_jet ) + + write(6,*) ' getting dry sounding for base state ' + write(6,*) ' using middle column in jet sounding, j = ',ny_jet/2 + dry_sounding = .true. + + dry_sounding = .true. + debug = .true. ! this will produce print of the sounding + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, u_jet, rho_jet, th_jet, z_jet, & + nz_jet, ny_jet, ny_jet/2, debug ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + +! For the jet, using the middle column for the base state means that +! we will be extrapolating above the highest height data to the south +! of the centerline. + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface + grid%em_phb(i,1,j) = 0. + grid%em_php(i,1,j) = 0. + grid%em_ph0(i,1,j) = 0. + grid%ht(i,j) = 0. + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting grid%moist sounding for full state ' + + dry_sounding = .true. + IF (config_flags%mp_physics /= 0) dry_sounding = .false. + + DO J = jts, min(jde-1,jte) + +! get sounding for this point + + debug = .false. ! this will turn off print of the sounding + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, u_jet, rho_jet, th_jet, z_jet, & + nz_jet, ny_jet, j, debug ) + + DO I = its, min(ide-1,ite) + +! we could just do the first point in "i" and copy from there, but we'll +! be lazy and do all the points as if they are all, independent + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + grid%moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(grid%moist(i,k,j,P_QV)+grid%moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(grid%moist(i,k,j,P_QV)+grid%moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + +! interp u + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',tpbub + + DO J = jts, min(jde-1,jte) + yrad = config_flags%dy*float(j-jde/2-1)/radbub + DO I = its, min(ide-1,ite) + xrad = float(i-1)/float(ide-ids) + + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-htbub)/radz + RAD=SQRT(yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + tp = tpbub*cos(rad*piov2)*cos(rad*piov2)*cos(xrad*2*pi+pi) + grid%em_t_1(i,k,j)=grid%em_t_1(i,k,j)+tp + grid%em_t_2(i,k,j)=grid%em_t_1(i,k,j) + qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1),grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), grid%moist(1,k,1,P_QV) + enddo + + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + write(6,*) ' at j = 1 ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_al(1,k,1)+grid%em_alb(1,k,1), & + grid%em_t_1(1,k,1)+t0, grid%moist(1,k,1,P_QV) + enddo + + + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + write(6,*) ' at j = jde/2 ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,jde/2)+grid%em_phb(1,k,jde/2), & + grid%em_p(1,k,jde/2)+grid%em_pb(1,k,jde/2), grid%em_al(1,k,jde/2)+grid%em_alb(1,k,jde/2), & + grid%em_t_1(1,k,jde/2)+t0, grid%moist(1,k,jde/2,P_QV) + enddo + + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + write(6,*) ' at j = jde-1 ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,jde-1)+grid%em_phb(1,k,jde-1), & + grid%em_p(1,k,jde-1)+grid%em_pb(1,k,jde-1), grid%em_al(1,k,jde-1)+grid%em_alb(1,k,jde-1), & + grid%em_t_1(1,k,jde-1)+t0, grid%moist(1,k,jde-1,P_QV) + enddo + +! set v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + DO K = 1, kte + grid%em_v_1(i,k,j) = 0. + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! fill out last i row for u + + DO J = jts, min(jde-1,jte) + DO I = ite, ite + + DO K = 1, kte + grid%em_u_1(i,k,j) = grid%em_u_1(its,k,j) + grid%em_u_2(i,k,j) = grid%em_u_2(its,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = grid%moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + if (i .eq. 1) print*,'sfctem',j,temp(1),temp(2),temp(3),grid%tsk(I,J) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + +!--------------------------------------------------------------------- + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- +#if 0 +! TEST DRIVER FOR "read_input_jet" and "get_sounding" + implicit none + integer, parameter :: nz_jet=64, ny_jet=80 + real, dimension(nz_jet,ny_jet) :: u_jet, rho_jet, & + th_jet, z_jet + + real, dimension(nz_jet,ny_jet) :: zk,p,p_dry,theta,rho,u,v,qv + logical :: dry, debug + integer :: j, nl + + call read_input_jet( u_jet, rho_jet, th_jet, z_jet, nz_jet, ny_jet ) + + call opngks + call parray( u_jet, nz_jet, ny_jet) + call parray( rho_jet, nz_jet, ny_jet) + call parray( th_jet, nz_jet, ny_jet) +! call clsgks + +! set up initial jet + + debug = .true. + dry = .true. + do j=1,ny_jet + + call get_sounding( zk(:,j),p(:,j),p_dry(:,j),theta(:,j), & + rho(:,j),u(:,j), v(:,j), qv(:,j), & + dry, nz_jet, nl, u_jet, rho_jet, th_jet, & + z_jet, nz_jet, ny_jet, j, debug ) + debug = .false. + + enddo + + write(6,*) ' lowest level p, th, and rho, highest level p ' + + do j=1,ny_jet + write(6,*) j, p(1,j),theta(1,j),rho(1,j), p(nz_jet,j) +! write(6,*) j, p(1,j),theta(1,j)-th_jet(1,j),rho(1,j)-rho_jet(1,j) + enddo + + call parray( p, nz_jet, ny_jet) + call parray( p_dry, nz_jet, ny_jet) + call parray( theta, nz_jet, ny_jet) + + call clsgks + + end + +!--------------------------------- + + subroutine parray(a,m,n) + dimension a(m,n) + dimension b(n,m) + + do i=1,m + do j=1,n + b(j,i) = a(i,j) + enddo + enddo + + write(6,'('' dimensions m,n '',2i6)')m,n + call set(.05,.95,.05,.95,0.,1.,0.,1.,1) + call perim(4,5,4,5) + call setusv('LW',2000) +! CALL CONREC(a,m,m,n,cmax,cmin,cinc,-1,-638,-922) + CALL CONREC(b,n,n,m,0.,0.,0.,-1,-638,-922) + call frame + return + end + +! END TEST DRIVER FOR "read_input_jet" and "get_sounding" +#endif + +!------------------------------------------------------------------ + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in, & + u_jet, rho_jet, th_jet, z_jet, & + nz_jet, ny_jet, j_point, debug ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer nz_jet, ny_jet, j_point + real, dimension(nz_jet, ny_jet) :: u_jet, rho_jet, th_jet, z_jet + + integer n + parameter(n=1000) + logical debug + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + +! call read_sounding( p_surf, th_surf, qv_surf, & +! h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + call calc_jet_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input, & + n, nl, debug, u_jet, rho_jet, th_jet, z_jet, j_point, & + nz_jet, ny_jet, dry ) + + nl = nz_jet + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) +! +! do k=1,nl +! qv_input(k) = 0.001*qv_input(k) +! enddo +! p_surf = 100.*p_surf ! convert to pascals + + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------------------ + + subroutine calc_jet_sounding( p_surf, th_surf, qv_surf, & + h, th, qv, u, v, n, nl, debug, & + u_jet, rho_jet, th_jet, z_jet, & + jp, nz_jet, ny_jet, dry ) + implicit none + integer :: n, nl, jp, nz_jet, ny_jet + + real, dimension(nz_jet, ny_jet) :: u_jet, rho_jet, th_jet, z_jet + real, dimension(n) :: h,th,qv,u,v + real :: p_surf, th_surf, qv_surf + logical :: debug, dry + + real, dimension(1:nz_jet) :: rho, rel_hum, p + integer :: k + +! some local stuff + + real :: tmppi, es, qvs, temperature + real, parameter :: p1000mb=1.e+05, rcp=287./1004.5, svpt0=273.15, & + svp3 = 29.65, ep_2=287./461.6, r_d = 287., & + cpovcv = 1004./(1004.-287.), & + svp1 = 0.6112, svp2 = 17.67 + +! get sounding from column jp + + do k=1,nz_jet + h(k) = z_jet(k,jp) + th(k) = th_jet(k,jp) + qv(k) = 0. + rho(k) = rho_jet(k,jp) + u(k) = u_jet(k,jp) + v(k) = 0. + enddo + + if (.not.dry) then + DO k=1,nz_jet + if(h(k) .gt. 8000.) then + rel_hum(k)=0.1 + else + rel_hum(k)=(1.-0.90*(h(k)/8000.)**1.25) + end if + rel_hum(k) = min(0.7,rel_hum(k)) + ENDDO + else + do k=1,nz_jet + rel_hum(k) = 0. + enddo + endif + +! next, compute pressure + + do k=1,nz_jet + p(k) = p1000mb*(R_d*rho(k)*th(k)/p1000mb)**cpovcv + enddo + +! here we adjust for fixed moisture profile + + IF (.not.dry) THEN + +! here we assume the input theta is th_v, so we reset theta accordingly + + DO k=1,nz_jet + tmppi=(p(k)/p1000mb)**rcp + temperature = tmppi*th(k) + if (temperature .gt. svpt0) then + es = 1000.*svp1*exp(svp2*(temperature-svpt0)/(temperature-svp3)) + qvs = ep_2*es/(p(k)-es) + else + es = 1000.*svp1*exp( 21.8745584*(temperature-273.16)/(temperature-7.66) ) + qvs = ep_2*es/(p(k)-es) + endif + qv(k) = rel_hum(k)*qvs + th(k) = th(k)/(1.+.61*qv(k)) + ENDDO + + ENDIF + +! finally, set the surface data. We'll just do a simple extrapolation + + p_surf = 1.5*p(1) - 0.5*p(2) + th_surf = 1.5*th(1) - 0.5*th(2) + qv_surf = 1.5*qv(1) - 0.5*qv(2) + + end subroutine calc_jet_sounding + +!--------------------------------------------------------------------- + + SUBROUTINE read_input_jet( u, r, t, zk, nz, ny ) + implicit none + + integer, intent(in) :: nz,ny + real, dimension(nz,ny), intent(out) :: u,r,t,zk + integer :: ny_in, nz_in, j,k + real, dimension(ny,nz) :: field_in + +! this code assumes it is called on processor 0 only + + OPEN(unit=10, file='input_jet', form='unformatted', status='old' ) + REWIND(10) + read(10) ny_in,nz_in + if((ny_in /= ny ) .or. (nz_in /= nz)) then + write(0,*) ' error in input jet dimensions ' + write(0,*) ' ny, ny_input, nz, nz_input ', ny, ny_in, nz,nz_in + write(0,*) ' error exit ' + call wrf_error_fatal ( ' error in input jet dimensions ' ) + end if + read(10) field_in + do j=1,ny + do k=1,nz + u(k,j) = field_in(j,k) + enddo + enddo + read(10) field_in + do j=1,ny + do k=1,nz + t(k,j) = field_in(j,k) + enddo + enddo + + read(10) field_in + do j=1,ny + do k=1,nz + r(k,j) = field_in(j,k) + enddo + enddo + + do j=1,ny + do k=1,nz + zk(k,j) = 125. + 250.*float(k-1) + enddo + enddo + + end subroutine read_input_jet + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_fire.F b/wrfv2_fire/dyn_em/module_initialize_fire.F new file mode 100644 index 00000000..7bc9d3a1 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_fire.F @@ -0,0 +1,829 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + INTEGER :: xs , xe , ys , ye + REAL :: mtn_ht + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 3. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + dry_sounding = .true. + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' getting dry sounding for base state ' + + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + ENDIF + CALL wrf_dm_bcast_real( zk , nl_max ) + CALL wrf_dm_bcast_real( p_in , nl_max ) + CALL wrf_dm_bcast_real( pd_in , nl_max ) + CALL wrf_dm_bcast_real( theta , nl_max ) + CALL wrf_dm_bcast_real( rho , nl_max ) + CALL wrf_dm_bcast_real( u , nl_max ) + CALL wrf_dm_bcast_real( v , nl_max ) + CALL wrf_dm_bcast_real( qv , nl_max ) + CALL wrf_dm_bcast_integer ( nl_in , 1 ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite + grid%ht(i,j) = 0. + ENDDO + ENDDO + + xs=ide/2 -3 + xs=ids -3 + xe=xs + 6 + ys=jde/2 -3 + ye=ys + 6 + mtn_ht = 500 +#ifdef MTN + DO j=max(ys,jds),min(ye,jde-1) + DO i=max(xs,ids),min(xe,ide-1) + grid%ht(i,j) = mtn_ht * 0.25 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef EW_RIDGE + DO j=max(ys,jds),min(ye,jde-1) + DO i=ids,ide + grid%ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef NS_RIDGE + DO j=jds,jde + DO i=max(xs,ids),min(xe,ide-1) + grid%ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) + ENDDO + ENDDO +#endif + DO j=jts,jte + DO i=its,ite + grid%em_phb(i,1,j) = g * grid%ht(i,j) + grid%em_ph0(i,1,j) = g * grid%ht(i,j) + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + ENDIF + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + if((i==2) .and. (j==2)) then + write(6,*) ' grid%em_ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + ENDIF + + ENDDO + ENDDO + +!#if 0 + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) + yrad = config_flags%dy*float(j-nyc)/10000. +! yrad = 0. + DO I = its, min(ide-1,ite) + xrad = config_flags%dx*float(i-nxc)/10000. +! xrad = 0. + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-1500.)/1500. + RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + grid%em_t_1(i,k,j)=grid%em_t_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + grid%em_t_2(i,k,j)=grid%em_t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, alp, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + ENDIF + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + ENDIF + CALL wrf_dm_bcast_real( grid%em_t_base , kte ) + CALL wrf_dm_bcast_real( grid%qv_base , kte ) + CALL wrf_dm_bcast_real( grid%u_base , kte ) + CALL wrf_dm_bcast_real( grid%v_base , kte ) + CALL wrf_dm_bcast_real( grid%z_base , kte ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=1000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_fire.F.sav b/wrfv2_fire/dyn_em/module_initialize_fire.F.sav new file mode 100644 index 00000000..dcaa991b --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_fire.F.sav @@ -0,0 +1,852 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + +#include "deref_kludge.h" + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid, & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid, & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + + INTEGER :: xs , xe , ys , ye + REAL :: mtn_ht + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +#include "deref_kludge.h" + +#define COPY_IN +#include +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 3. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + msft(i,j) = 1. + msfu(i,j) = 1. + msfv(i,j) = 1. + sina(i,j) = 0. + cosa(i,j) = 1. + e(i,j) = 0. + f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + ww(i,k,j) = 0. + END DO + END DO + END DO + + step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + dnw(k) = znw(k+1) - znw(k) + rdnw(k) = 1./dnw(k) + znu(k) = 0.5*(znw(k+1)+znw(k)) + ENDDO + DO k=2, kde-1 + dn(k) = 0.5*(dnw(k)+dnw(k-1)) + rdn(k) = 1./dn(k) + fnp(k) = .5* dnw(k )/dn(k) + fnm(k) = .5* dnw(k-1)/dn(k) + ENDDO + + cof1 = (2.*dn(2)+dn(3))/(dn(2)+dn(3))*dnw(1)/dn(2) + cof2 = dn(2) /(dn(2)+dn(3))*dnw(1)/dn(3) + cf1 = fnp(2) + cof1 + cf2 = fnm(2) - cof1 - cof2 + cf3 = cof2 + + cfn = (.5*dnw(kde-1)+dn(kde-1))/dn(kde-1) + cfn1 = -.5*dnw(kde-1)/dn(kde-1) + rdx = 1./config_flags%dx + rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + dry_sounding = .true. + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' getting dry sounding for base state ' + + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + ENDIF + CALL wrf_dm_bcast_real( zk , nl_max ) + CALL wrf_dm_bcast_real( p_in , nl_max ) + CALL wrf_dm_bcast_real( pd_in , nl_max ) + CALL wrf_dm_bcast_real( theta , nl_max ) + CALL wrf_dm_bcast_real( rho , nl_max ) + CALL wrf_dm_bcast_real( u , nl_max ) + CALL wrf_dm_bcast_real( v , nl_max ) + CALL wrf_dm_bcast_real( qv , nl_max ) + CALL wrf_dm_bcast_integer ( nl_in , 1 ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite + ht(i,j) = 0. + ENDDO + ENDDO + + xs=ide/2 -3 + xs=ids -3 + xe=xs + 6 + ys=jde/2 -3 + ye=ys + 6 + mtn_ht = 500 +#ifdef MTN + DO j=max(ys,jds),min(ye,jde-1) + DO i=max(xs,ids),min(xe,ide-1) + ht(i,j) = mtn_ht * 0.25 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef EW_RIDGE + DO j=max(ys,jds),min(ye,jde-1) + DO i=ids,ide + ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef NS_RIDGE + DO j=jds,jde + DO i=max(xs,ids),min(xe,ide-1) + ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) + ENDDO + ENDDO +#endif + DO j=jts,jte + DO i=its,ite + phb(i,1,j) = g * ht(i,j) + ph0(i,1,j) = g * ht(i,j) + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, phb(i,1,j)/g, nl_in ) + mub(i,j) = p_surf-p_top + +! this is dry hydrostatic sounding (base state), so given p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = znu(k)*(p_surf - p_top) + p_top + pb(i,k,j) = p_level + t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + alb(i,k,j) = (r_d/p1000mb)*(t_init(i,k,j)+t0)*(pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + phb(i,k,j) = phb(i,k-1,j) - dnw(k-1)*mub(i,j)*alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' ptop is ',p_top + write(6,*) ' base state mub(1,1), p_surf is ',mub(1,1),mub(1,1)+p_top + ENDIF + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + mu_1(i,j) = pd_surf-p_top - mub(i,j) + mu_2(i,j) = mu_1(i,j) + mu0(i,j) = mu_1(i,j) + mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = znu(k)*(pd_surf - p_top) + p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + t_2(i,k,j) = t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! p(i,k,j) = - 0.5*mu_1(i,j)/rdnw(k) + p(i,k,j) = - 0.5*(mu_1(i,j)+qvf1*mub(i,j))/rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + alt(i,k,j) = (r_d/p1000mb)*(t_1(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) + al(i,k,j) = alt(i,k,j) - alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + p(i,k,j) = p(i,k+1,j) - (mu_1(i,j) + qvf1*mub(i,j))/qvf2/rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + alt(i,k,j) = (r_d/p1000mb)*(t_1(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) + al(i,k,j) = alt(i,k,j) - alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, al (inverse density) +! is computed from the geopotential. + + + ph_1(i,1,j) = 0. + DO k = 2,kte + ph_1(i,k,j) = ph_1(i,k-1,j) - (1./rdnw(k-1))*( & + (mub(i,j)+mu_1(i,j))*al(i,k-1,j)+ & + mu_1(i,j)*alb(i,k-1,j) ) + + ph_2(i,k,j) = ph_1(i,k,j) + ph0(i,k,j) = ph_1(i,k,j) + phb(i,k,j) + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + if((i==2) .and. (j==2)) then + write(6,*) ' ph_1 calc ',ph_1(2,1,2),ph_1(2,2,2),mu_1(2,2)+mub(2,2),mu_1(2,2), & + alb(2,1,2),al(1,2,1),rdnw(1) + endif + ENDIF + + ENDDO + ENDDO + +!#if 0 + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) + yrad = config_flags%dy*float(j-nyc)/10000. +! yrad = 0. + DO I = its, min(ide-1,ite) + xrad = config_flags%dx*float(i-nxc)/10000. +! xrad = 0. + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(ph_1(i,k,j)+ph_1(i,k+1,j) & + +phb(i,k,j)+phb(i,k+1,j))/g + zrad = (zrad-1500.)/1500. + RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + T_1(i,k,j)=T_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + T_2(i,k,j)=T_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + alt(i,k,j) = (r_d/p1000mb)*(t_1(i,k,j)+t0)*qvf* & + (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) + al(i,k,j) = alt(i,k,j) - alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + ph_1(i,k,j) = ph_1(i,k-1,j) - (1./rdnw(k-1))*( & + (mub(i,j)+mu_1(i,j))*al(i,k-1,j)+ & + mu_1(i,j)*alb(i,k-1,j) ) + + ph_2(i,k,j) = ph_1(i,k,j) + ph0(i,k,j) = ph_1(i,k,j) + phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' mu_1 from comp ', mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, p, al, t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, ph_1(1,k,1)+phb(1,k,1), & + p(1,k,1)+pb(1,k,1), alt(1,k,1), & + t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, ph_1, pp, alp, t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, ph_1(1,k,1), & + p(1,k,1), al(1,k,1), & + t_1(1,k,1), moist(1,k,1,P_QV) + enddo + ENDIF + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(phb(i,1,j)+phb(i,1,j-1))/g + END IF + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte-1 + p_level = znu(k)*(p_surf - p_top) + p_top + v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + v_2(i,k,j) = v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(phb(i,1,j)+phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte-1 + p_level = znu(k)*(p_surf - p_top) + p_top + u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + u_2(i,k,j) = u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + w_1(i,k,j) = 0. + w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + DO k=1,kte-1 + t_base(k) = t_1(1,k,1) + qv_base(k) = moist(1,k,1,P_QV) + u_base(k) = u_1(1,k,1) + v_base(k) = v_1(1,k,1) + z_base(k) = 0.5*(phb(1,k,1)+phb(1,k+1,1)+ph_1(1,k,1)+ph_1(1,k+1,1))/g + ENDDO + ENDIF + CALL wrf_dm_bcast_real( t_base , kte ) + CALL wrf_dm_bcast_real( qv_base , kte ) + CALL wrf_dm_bcast_real( u_base , kte ) + CALL wrf_dm_bcast_real( v_base , kte ) + CALL wrf_dm_bcast_real( z_base , kte ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = t_2(i,1,j)+t0 + ptmp = p(i,1,j)+pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = t_2(i,2,j)+t0 + ptmp = p(i,2,j)+pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = t_2(i,3,j)+t0 + ptmp = p(i,3,j)+pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + TSK(I,J)=cf1*temp(1)+cf2*temp(2)+cf3*temp(3) + TMN(I,J)=TSK(I,J)-0.5 + ENDDO + ENDDO + +#define COPY_OUT +#include + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=1000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F new file mode 100644 index 00000000..42eb8a53 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F @@ -0,0 +1,840 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2, t_min, t_max +! REAL, EXTERNAL :: interp_0 + REAL :: hm, xa, xpos, xposml, xpospl + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + REAL :: xa1, xal1,pii,hm1 ! data for intercomparison setup from dale + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + hm = 000. + xa = 5.0 + + icm = ide/2 + + + xa1 = 5000./500. + xal1 = 4000./500. + pii = 2.*asin(1.0) + hm1 = 250. +! hm1 = 1000. + + + stretch_grid = .true. +! z_scale = .50 + z_scale = 1.675 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' getting dry sounding for base state ' + dry_sounding = .true. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, .true.) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface +!! grid%ht(i,j) = 0. + grid%ht(i,j) = hm/(1.+(float(i-icm)/xa)**2) +! grid%ht(i,j) = hm1*exp(-(( float(i-icm)/xa1)**2)) & +! *( (cos(pii*float(i-icm)/xal1))**2 ) + grid%em_phb(i,1,j) = g*grid%ht(i,j) + grid%em_php(i,1,j) = 0. + grid%em_ph0(i,1,j) = grid%em_phb(i,1,j) + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, .false. ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + grid%moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(grid%moist(i,k,j,P_QV)+grid%moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + if((i==2) .and. (j==2)) then + write(6,*) ' ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + + ENDDO + ENDDO + +! cold bubble input (from straka et al, IJNMF, vol 17, 1993 pp 1-22) + + t_min = grid%em_t_1(its,kts,jts) + t_max = t_min + u_mean = 00. + + xpos = config_flags%dx*nxc - u_mean*900. + xposml = xpos - config_flags%dx*(ide-1) + xpospl = xpos + config_flags%dx*(ide-1) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) +! xrad = config_flags%dx*float(i-nxc)/4000. ! 4000 meter horizontal radius +! ! centered in the domain + + xrad = min( abs(config_flags%dx*float(i)-xpos), & + abs(config_flags%dx*float(i)-xposml), & + abs(config_flags%dx*float(i)-xpospl))/4000. + + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-3000.)/2000. ! 2000 meter vertical radius, + ! centered at z=3000, + RAD=SQRT(xrad*xrad+zrad*zrad) + IF(RAD <= 1.) THEN + + ! perturbation temperature is 15 C, convert to potential temperature + + delt = -15.0 / ((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**rcp + + grid%em_T_1(i,k,j)=grid%em_T_1(i,k,j)+delt*(COS(PI*RAD)+1.0)/2. + grid%em_T_2(i,k,j)=grid%em_T_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + + t_min = min(t_min, grid%em_t_1(i,k,j)) + t_max = max(t_max, grid%em_t_1(i,k,j)) + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' min and max theta perturbation ',t_min,t_max + + + + +! -- end bubble insert + + write(6,*) ' mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, p, al, t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, ph_1, pp, alp, t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + + write(6,*) ' ' + write(6,*) ' k, model level, dz ' + do k=1,kde-1 + write(6,'(i3,1x,e12.5,1x,f10.2)') k, & + .5*(grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1)+grid%em_ph_1(1,k+1,1)+grid%em_phb(1,k+1,1))/g, & + (grid%em_ph_1(1,k+1,1)+grid%em_phb(1,k+1,1)-grid%em_ph_1(1,k,1)-grid%em_phb(1,k,1))/g + enddo + write(6,*) ' model top (m) is ', (grid%em_ph_1(1,kde,1)+grid%em_phb(1,kde,1))/g + + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%TSK(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%TMN(I,J)=grid%TSK(I,J)-0.5 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in, base_state ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + logical base_state + + integer n, iz + parameter(n=1000) + logical debug + parameter( debug = .false.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + +! iz = 1 +! do k=2,nl +! if(h_input(k) .lt. 12000.) iz = k +! enddo +! write(6,*) " tropopause ",iz,h_input(iz) +! if(dry) then +! write(6,*) ' nl is ',nl +! do k=1,nl +! th_input(k) = th_input(k)+10.+10*float(k)/nl +! enddo +! write(6,*) ' finished adjusting theta ' +! endif + +! do k=1,nl +! u_input(k) = 2*u_input(k) +! enddo +! +! end if + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,20 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + +! write(6,*) ' zeroing u input ' + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) +! u(k) = 0. + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F new file mode 100644 index 00000000..654e99ec --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F @@ -0,0 +1,764 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. +! NOTE: Modified to remove all but arrays of rank 4 or more from the +! argument list. Arrays with rank>3 are still problematic due to the +! above-noted fie- and pox-ities. TBH 20061129. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1,dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm, xa + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + REAL :: xa1, xal1,pii,hm1 ! data for intercomparison setup from dale + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + hm = 100. + xa = 5.0 + + icm = ide/2 + + + xa1 = 5000./500. + xal1 = 4000./500. + pii = 2.*asin(1.0) + hm1 = 250. +! hm1 = 1000. + + + stretch_grid = .true. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/4 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1,' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' getting dry sounding for base state ' + dry_sounding = .true. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, .true.) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface +!! grid%ht(i,j) = 0. + grid%ht(i,j) = hm/(1.+(float(i-icm)/xa)**2) +! grid%ht(i,j) = hm1*exp(-(( float(i-icm)/xa1)**2)) & +! *( (cos(pii*float(i-icm)/xal1))**2 ) + grid%em_phb(i,1,j) = g*grid%ht(i,j) + grid%em_php(i,1,j) = 0. + grid%em_ph0(i,1,j) = grid%em_phb(i,1,j) + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + nl_max, nl_in, .false. ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + if((i==2) .and. (j==2)) then + write(6,*) ' grid%em_ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + + ENDDO + ENDDO + + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, alp, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in, base_state ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + logical base_state + + integer n, iz + parameter(n=1000) + logical debug + parameter( debug = .false.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + +! iz = 1 +! do k=2,nl +! if(h_input(k) .lt. 12000.) iz = k +! enddo +! write(6,*) " tropopause ",iz,h_input(iz) +! if(dry) then +! write(6,*) ' nl is ',nl +! do k=1,nl +! th_input(k) = th_input(k)+10.+10*float(k)/nl +! enddo +! write(6,*) ' finished adjusting theta ' +! endif + +! do k=1,nl +! u_input(k) = 2*u_input(k) +! enddo +! +! end if + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,20 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + +! write(6,*) ' zeroing u input ' + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) +! u(k) = 0. + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F new file mode 100644 index 00000000..7bc9d3a1 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F @@ -0,0 +1,829 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + INTEGER :: xs , xe , ys , ye + REAL :: mtn_ht + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 3. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + dry_sounding = .true. + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' getting dry sounding for base state ' + + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + ENDIF + CALL wrf_dm_bcast_real( zk , nl_max ) + CALL wrf_dm_bcast_real( p_in , nl_max ) + CALL wrf_dm_bcast_real( pd_in , nl_max ) + CALL wrf_dm_bcast_real( theta , nl_max ) + CALL wrf_dm_bcast_real( rho , nl_max ) + CALL wrf_dm_bcast_real( u , nl_max ) + CALL wrf_dm_bcast_real( v , nl_max ) + CALL wrf_dm_bcast_real( qv , nl_max ) + CALL wrf_dm_bcast_integer ( nl_in , 1 ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite + grid%ht(i,j) = 0. + ENDDO + ENDDO + + xs=ide/2 -3 + xs=ids -3 + xe=xs + 6 + ys=jde/2 -3 + ye=ys + 6 + mtn_ht = 500 +#ifdef MTN + DO j=max(ys,jds),min(ye,jde-1) + DO i=max(xs,ids),min(xe,ide-1) + grid%ht(i,j) = mtn_ht * 0.25 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef EW_RIDGE + DO j=max(ys,jds),min(ye,jde-1) + DO i=ids,ide + grid%ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(ye-ys) * ( j-ys ) + pi ) ) + ENDDO + ENDDO +#endif +#ifdef NS_RIDGE + DO j=jds,jde + DO i=max(xs,ids),min(xe,ide-1) + grid%ht(i,j) = mtn_ht * 0.50 * & + ( 1. + COS ( 2*pi/(xe-xs) * ( i-xs ) + pi ) ) + ENDDO + ENDDO +#endif + DO j=jts,jte + DO i=its,ite + grid%em_phb(i,1,j) = g * grid%ht(i,j) + grid%em_ph0(i,1,j) = g * grid%ht(i,j) + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + ENDIF + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + if((i==2) .and. (j==2)) then + write(6,*) ' grid%em_ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + ENDIF + + ENDDO + ENDDO + +!#if 0 + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) + yrad = config_flags%dy*float(j-nyc)/10000. +! yrad = 0. + DO I = its, min(ide-1,ite) + xrad = config_flags%dx*float(i-nxc)/10000. +! xrad = 0. + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-1500.)/1500. + RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + grid%em_t_1(i,k,j)=grid%em_t_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + grid%em_t_2(i,k,j)=grid%em_t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + IF ( wrf_dm_on_monitor() ) THEN + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, alp, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + ENDIF + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + IF ( wrf_dm_on_monitor() ) THEN + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + ENDIF + CALL wrf_dm_bcast_real( grid%em_t_base , kte ) + CALL wrf_dm_bcast_real( grid%qv_base , kte ) + CALL wrf_dm_bcast_real( grid%u_base , kte ) + CALL wrf_dm_bcast_real( grid%v_base , kte ) + CALL wrf_dm_bcast_real( grid%z_base , kte ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=1000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F new file mode 100644 index 00000000..1be4aaad --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -0,0 +1,4235 @@ +!REAL:MODEL_LAYER:INITIALIZATION + +#ifndef VERT_UNIT +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains, specifically for the Eulerian, mass-based coordinate. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_bc + USE module_configure + USE module_domain + USE module_io_domain + USE module_model_constants + USE module_state_description + USE module_timing + USE module_soil_pre + USE module_date_time +#ifdef DM_PARALLEL + USE module_dm +#endif + + REAL , SAVE :: p_top_save + INTEGER :: internal_time_loop + +CONTAINS + +!------------------------------------------------------------------- + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input space and data. No gridded meteorological data has been stored, though. + +! TYPE (domain), POINTER :: grid + TYPE (domain) :: grid + + ! Local data. + + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt ( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include "em_actual_new_args.inc" +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( 'ERROR-dyn_opt-wrong-in-namelist' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +#include "em_dummy_new_args.inc" +! + ) + + USE module_optional_si_input + IMPLICIT NONE + + ! Input space and data. No gridded meteorological data has been stored, though. + +! TYPE (domain), POINTER :: grid + TYPE (domain) :: grid + +#include "em_dummy_new_decl.inc" + + TYPE (grid_config_rec_type) :: config_flags + + ! Local domain indices and counters. + + INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + INTEGER :: loop , num_seaice_changes + + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + ips, ipe, jps, jpe, kps, kpe, & + i, j, k + INTEGER :: ns + + ! Local data + + INTEGER :: error + REAL :: p_surf, p_level + REAL :: cof1, cof2 + REAL :: qvf , qvf1 , qvf2 , pd_surf + REAL :: p00 , t00 , a + REAL :: hold_znw + LOGICAL :: were_bad + + LOGICAL :: stretch_grid, dry_sounding, debug + INTEGER IICOUNT + + REAL :: p_top_requested , temp + INTEGER :: num_metgrid_levels + REAL , DIMENSION(max_eta) :: eta_levels + REAL :: max_dz + +! INTEGER , PARAMETER :: nl_max = 1000 +! REAL , DIMENSION(nl_max) :: grid%em_dn + +integer::oops1,oops2 + + REAL :: zap_close_levels + INTEGER :: force_sfc_in_vinterp + INTEGER :: interp_type , lagrange_order , extrap_type , t_extrap_type + LOGICAL :: lowest_lev_from_sfc + LOGICAL :: we_have_tavgsfc + + INTEGER :: lev500 , loop_count + REAL :: zl , zu , pl , pu , z500 , dz500 , tvsfc , dpmu + +!-- Carsel and Parrish [1988] + REAL , DIMENSION(100) :: lqmi + +#ifdef DM_PARALLEL +# include "em_data_calls.inc" +#endif + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + ! Check to see if the boundary conditions are set properly in the namelist file. + ! This checks for sufficiency and redundancy. + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + ! Some sort of "this is the first time" initialization. Who knows. + + grid%step_number = 0 + grid%itimestep=0 + + ! Pull in the info in the namelist to compare it to the input data. + + grid%real_data_init_type = model_config_rec%real_data_init_type + + ! To define the base state, we call a USER MODIFIED routine to set the three + ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K), + ! and A (temperature difference, from 1000 mb to 300 mb, K). + + CALL const_module_initialize ( p00 , t00 , a ) + +#if 0 +!KLUDGE, this is for testing only +if ( flag_metgrid .eq. 1 ) then +read (20+grid%id) grid%em_ht_gc +read (20+grid%id) grid%em_xlat_gc +read (20+grid%id) grid%em_xlong_gc +read (20+grid%id) msft +read (20+grid%id) msfu +read (20+grid%id) msfv +read (20+grid%id) f +read (20+grid%id) e +read (20+grid%id) sina +read (20+grid%id) cosa +read (20+grid%id) grid%landmask +read (20+grid%id) grid%landusef +read (20+grid%id) grid%soilctop +read (20+grid%id) grid%soilcbot +read (20+grid%id) grid%vegcat +read (20+grid%id) grid%soilcat +else +write (20+grid%id) grid%em_ht +write (20+grid%id) grid%em_xlat +write (20+grid%id) grid%em_xlong +write (20+grid%id) msft +write (20+grid%id) msfu +write (20+grid%id) msfv +write (20+grid%id) f +write (20+grid%id) e +write (20+grid%id) sina +write (20+grid%id) cosa +write (20+grid%id) grid%landmask +write (20+grid%id) grid%landusef +write (20+grid%id) grid%soilctop +write (20+grid%id) grid%soilcbot +write (20+grid%id) grid%vegcat +write (20+grid%id) grid%soilcat +endif +#endif + + + ! Is there any vertical interpolation to do? The "old" data comes in on the correct + ! vertical locations already. + + IF ( flag_metgrid .EQ. 1 ) THEN ! <----- START OF VERTICAL INTERPOLATION PART ----> + + ! Variables that are named differently between SI and WPS. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%tsk(i,j) = grid%em_tsk_gc(i,j) + grid%tmn(i,j) = grid%em_tmn_gc(i,j) + grid%xlat(i,j) = grid%em_xlat_gc(i,j) + grid%xlong(i,j) = grid%em_xlong_gc(i,j) + grid%ht(i,j) = grid%em_ht_gc(i,j) + END DO + END DO + + ! If we have any input low-res surface pressure, we store it. + + IF ( flag_psfc .EQ. 1 ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%em_psfc_gc(i,j) = grid%psfc(i,j) + grid%em_p_gc(i,1,j) = grid%psfc(i,j) + END DO + END DO + END IF + + ! If we have the low-resolution surface elevation, stick that in the + ! "input" locations of the 3d height. We still have the "hi-res" topo + ! stuck in the grid%em_ht array. The grid%landmask if test is required as some sources + ! have ZERO elevation over water (thank you very much). + + IF ( flag_soilhgt .EQ. 1) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + IF ( grid%landmask(i,j) .GT. 0.5 ) THEN + grid%em_ght_gc(i,1,j) = grid%toposoil(i,j) + grid%em_ht_gc(i,j)= grid%toposoil(i,j) + END IF + END DO + END DO + END IF + + ! Assign surface fields with original input values. If this is hybrid data, + ! the values are not exactly representative. However - this is only for + ! plotting purposes and such at the 0h of the forecast, so we are not all that + ! worried. + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide,ite) + grid%u10(i,j)=grid%em_u_gc(i,1,j) + END DO + END DO + + DO j = jts, min(jde,jte) + DO i = its, min(ide-1,ite) + grid%v10(i,j)=grid%em_v_gc(i,1,j) + END DO + END DO + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + grid%t2(i,j)=grid%em_t_gc(i,1,j) + END DO + END DO + + IF ( flag_qv .EQ. 1 ) THEN + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + grid%q2(i,j)=grid%em_qv_gc(i,1,j) + END DO + END DO + END IF + + ! The number of vertical levels in the input data. There is no staggering for + ! different variables. + + num_metgrid_levels = grid%num_metgrid_levels + + ! The requested ptop for real data cases. + + p_top_requested = grid%p_top_requested + + ! Compute the top pressure, grid%p_top. For isobaric data, this is just the + ! top level. For the generalized vertical coordinate data, we find the + ! max pressure on the top level. We have to be careful of two things: + ! 1) the value has to be communicated, 2) the value can not increase + ! at subsequent times from the initial value. + + IF ( internal_time_loop .EQ. 1 ) THEN + CALL find_p_top ( grid%em_p_gc , grid%p_top , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + +#ifdef DM_PARALLEL + grid%p_top = wrf_dm_max_real ( grid%p_top ) +#endif + + ! Compare the requested grid%p_top with the value available from the input data. + + IF ( p_top_requested .LT. grid%p_top ) THEN + print *,'p_top_requested = ',p_top_requested + print *,'allowable grid%p_top in data = ',grid%p_top + CALL wrf_error_fatal ( 'p_top_requested < grid%p_top possible from data' ) + END IF + + ! The grid%p_top valus is the max of what is available from the data and the + ! requested value. We have already compared <, so grid%p_top is directly set to + ! the value in the namelist. + + grid%p_top = p_top_requested + + ! For subsequent times, we have to remember what the grid%p_top for the first + ! time was. Why? If we have a generalized vert coordinate, the grid%p_top value + ! could fluctuate. + + p_top_save = grid%p_top + + ELSE + CALL find_p_top ( grid%em_p_gc , grid%p_top , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + +#ifdef DM_PARALLEL + grid%p_top = wrf_dm_max_real ( grid%p_top ) +#endif + IF ( grid%p_top .GT. p_top_save ) THEN + print *,'grid%p_top from last time period = ',p_top_save + print *,'grid%p_top from this time period = ',grid%p_top + CALL wrf_error_fatal ( 'grid%p_top > previous value' ) + END IF + grid%p_top = p_top_save + ENDIF + + ! Get the monthly values interpolated to the current date for the traditional monthly + ! fields of green-ness fraction and background albedo. + + CALL monthly_interp_to_date ( grid%em_greenfrac , current_date , grid%vegfra , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + CALL monthly_interp_to_date ( grid%em_albedo12m , current_date , grid%albbck , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Get the min/max of each i,j for the monthly green-ness fraction. + + CALL monthly_min_max ( grid%em_greenfrac , grid%shdmin , grid%shdmax , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! The model expects the green-ness values in percent, not fraction. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%vegfra(i,j) = grid%vegfra(i,j) * 100. + grid%shdmax(i,j) = grid%shdmax(i,j) * 100. + grid%shdmin(i,j) = grid%shdmin(i,j) * 100. + END DO + END DO + + ! The model expects the albedo fields as a fraction, not a percent. Set the + ! water values to 8%. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%albbck(i,j) = grid%albbck(i,j) / 100. + grid%snoalb(i,j) = grid%snoalb(i,j) / 100. + IF ( grid%landmask(i,j) .LT. 0.5 ) THEN + grid%albbck(i,j) = 0.08 + grid%snoalb(i,j) = 0.08 + END IF + END DO + END DO + + ! Compute the mixing ratio from the input relative humidity. + + IF ( flag_qv .NE. 1 ) THEN + CALL rh_to_mxrat (grid%em_rh_gc, grid%em_t_gc, grid%em_p_gc, grid%em_qv_gc , .TRUE. , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + END IF + + ! Two ways to get the surface pressure. 1) If we have the low-res input surface + ! pressure and the low-res topography, then we can do a simple hydrostatic + ! relation. 2) Otherwise we compute the surface pressure from the sea-level + ! pressure. + ! Note that on output, grid%em_psfc is now hi-res. The low-res surface pressure and + ! elevation are grid%em_psfc_gc and grid%em_ht_gc (same as grid%em_ght_gc(k=1)). + + IF ( config_flags%adjust_heights ) THEN + we_have_tavgsfc = ( flag_tavgsfc == 1 ) + ELSE + we_have_tavgsfc = .FALSE. + END IF + + IF ( ( flag_psfc .EQ. 1 ) .AND. ( flag_soilhgt .EQ. 1 ) .AND. & + ( config_flags%sfcp_to_sfcp ) ) THEN + CALL sfcprs2(grid%em_t_gc, grid%em_qv_gc, grid%em_ght_gc, grid%em_psfc_gc, grid%ht, & + grid%em_tavgsfc, grid%em_p_gc, grid%psfc, we_have_tavgsfc, & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + ELSE + CALL sfcprs (grid%em_t_gc, grid%em_qv_gc, grid%em_ght_gc, grid%em_pslv_gc, grid%ht, & + grid%em_tavgsfc, grid%em_p_gc, grid%psfc, we_have_tavgsfc, & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + + ! If we have no input surface pressure, we'd better stick something in there. + + IF ( flag_psfc .NE. 1 ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%em_psfc_gc(i,j) = grid%psfc(i,j) + grid%em_p_gc(i,1,j) = grid%psfc(i,j) + END DO + END DO + END IF + END IF + + ! Integrate the mixing ratio to get the vapor pressure. + + CALL integ_moist ( grid%em_qv_gc , grid%em_p_gc , grid%em_pd_gc , grid%em_t_gc , grid%em_ght_gc , grid%em_intq_gc , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + + ! Compute the difference between the dry, total surface pressure (input) and the + ! dry top pressure (constant). + + CALL p_dts ( grid%em_mu0 , grid%em_intq_gc , grid%psfc , grid%p_top , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + + ! Compute the dry, hydrostatic surface pressure. + + CALL p_dhs ( grid%em_pdhs , grid%ht , p00 , t00 , a , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute the eta levels if not defined already. + + IF ( grid%em_znw(1) .NE. 1.0 ) THEN + + eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) + max_dz = model_config_rec%max_dz + + CALL compute_eta ( grid%em_znw , & + eta_levels , max_eta , max_dz , & + grid%p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + + ! The input field is temperature, we want potential temp. + + CALL t_to_theta ( grid%em_t_gc , grid%em_p_gc , p00 , & + ids , ide , jds , jde , 1 , num_metgrid_levels , & + ims , ime , jms , jme , 1 , num_metgrid_levels , & + its , ite , jts , jte , 1 , num_metgrid_levels ) + + ! On the eta surfaces, compute the dry pressure = mu eta, stored in + ! grid%em_pb, since it is a pressure, and we don't need another kms:kme 3d + ! array floating around. The grid%em_pb array is re-computed as the base pressure + ! later after the vertical interpolations are complete. + + CALL p_dry ( grid%em_mu0 , grid%em_znw , grid%p_top , grid%em_pb , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! All of the vertical interpolations are done in dry-pressure space. The + ! input data has had the moisture removed (grid%em_pd_gc). The target levels (grid%em_pb) + ! had the vapor pressure removed from the surface pressure, then they were + ! scaled by the eta levels. + + interp_type = grid%interp_type + lagrange_order = grid%lagrange_order + lowest_lev_from_sfc = grid%lowest_lev_from_sfc + zap_close_levels = grid%zap_close_levels + force_sfc_in_vinterp = grid%force_sfc_in_vinterp + t_extrap_type = grid%t_extrap_type + extrap_type = grid%extrap_type + + CALL vert_interp ( grid%em_qv_gc , grid%em_pd_gc , moist(:,:,:,P_QV) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + CALL vert_interp ( grid%em_t_gc , grid%em_pd_gc , grid%em_t_2 , grid%em_pb , & + num_metgrid_levels , 'T' , & + interp_type , lagrange_order , t_extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) +#if 0 + ! Uncomment the Registry entries to activate these. This adds + ! noticeably to the allocated space for the model. + + IF ( flag_qr .EQ. 1 ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( im .EQ. P_QR ) THEN + CALL vert_interp ( qr_gc , grid%em_pd_gc , moist(:,:,:,P_QR) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + END IF + + IF ( flag_qc .EQ. 1 ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( im .EQ. P_QC ) THEN + CALL vert_interp ( qc_gc , grid%em_pd_gc , moist(:,:,:,P_QC) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + END IF + + IF ( flag_qi .EQ. 1 ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( im .EQ. P_QI ) THEN + CALL vert_interp ( qi_gc , grid%em_pd_gc , moist(:,:,:,P_QI) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + END IF + + IF ( flag_qs .EQ. 1 ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( im .EQ. P_QS ) THEN + CALL vert_interp ( qs_gc , grid%em_pd_gc , moist(:,:,:,P_QS) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + END IF + + IF ( flag_qg .EQ. 1 ) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( im .EQ. P_QG ) THEN + CALL vert_interp ( qg_gc , grid%em_pd_gc , moist(:,:,:,P_QG) , grid%em_pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + END IF +#endif + +#ifdef DM_PARALLEL + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte + + ! For the U and V vertical interpolation, we need the pressure defined + ! at both the locations for the horizontal momentum, which we get by + ! averaging two pressure values (i and i-1 for U, j and j-1 for V). The + ! pressure field on input (grid%em_pd_gc) and the pressure of the new coordinate + ! (grid%em_pb) are both communicated with an 8 stencil. + +# include "HALO_EM_VINTERP_UV_1.inc" +#endif + + CALL vert_interp ( grid%em_u_gc , grid%em_pd_gc , grid%em_u_2 , grid%em_pb , & + num_metgrid_levels , 'U' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + CALL vert_interp ( grid%em_v_gc , grid%em_pd_gc , grid%em_v_2 , grid%em_pb , & + num_metgrid_levels , 'V' , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + END IF ! <----- END OF VERTICAL INTERPOLATION PART ----> + + ! Protect against bad grid%em_tsk values over water by supplying grid%sst (if it is + ! available, and if the grid%sst is reasonable). + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & + ( grid%sst(i,j) .GT. 200. ) .AND. ( grid%sst(i,j) .LT. 350. ) ) THEN + grid%tsk(i,j) = grid%sst(i,j) + ENDIF + END DO + END DO + + ! Save the grid%em_tsk field for later use in the sea ice surface temperature + ! for the Noah LSM scheme. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%tsk_save(i,j) = grid%tsk(i,j) + END DO + END DO + + ! Take the data from the input file and store it in the variables that + ! use the WRF naming and ordering conventions. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + IF ( grid%snow(i,j) .GE. 10. ) then + grid%snowc(i,j) = 1. + ELSE + grid%snowc(i,j) = 0.0 + END IF + END DO + END DO + + ! Set flag integers for presence of snowh and soilw fields + + grid%ifndsnowh = flag_snowh + IF (num_sw_levels_input .GE. 1) THEN + grid%ifndsoilw = 1 + ELSE + grid%ifndsoilw = 0 + END IF + + ! We require input data for the various LSM schemes. + + enough_data : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE (LSMSCHEME) + IF ( num_st_levels_input .LT. 2 ) THEN + CALL wrf_error_fatal ( 'Not enough soil temperature data for Noah LSM scheme.') + END IF + + CASE (RUCLSMSCHEME) + IF ( num_st_levels_input .LT. 2 ) THEN + CALL wrf_error_fatal ( 'Not enough soil temperature data for RUC LSM scheme.') + END IF + + END SELECT enough_data + + ! For sf_surface_physics = 1, we want to use close to a 30 cm value + ! for the bottom level of the soil temps. + + fix_bottom_level_for_temp : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE (SLABSCHEME) + IF ( flag_tavgsfc .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%tmn(i,j) = grid%em_tavgsfc(i,j) + END DO + END DO + ELSE IF ( flag_st010040 .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%tmn(i,j) = grid%st010040(i,j) + END DO + END DO + ELSE IF ( flag_st000010 .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%tmn(i,j) = grid%st000010(i,j) + END DO + END DO + ELSE IF ( flag_soilt020 .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%tmn(i,j) = grid%soilt020(i,j) + END DO + END DO + ELSE IF ( flag_st007028 .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%tmn(i,j) = grid%st007028(i,j) + END DO + END DO + ELSE + CALL wrf_debug ( 0 , 'No 10-40 cm, 0-10 cm, 7-28, or 20 cm soil temperature data for grid%em_tmn') + CALL wrf_debug ( 0 , 'Using 1 degree static annual mean temps' ) + END IF + + CASE (LSMSCHEME) + + CASE (RUCLSMSCHEME) + + END SELECT fix_bottom_level_for_temp + + ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is + ! is for the 5-layer scheme. + + num_veg_cat = SIZE ( grid%landusef , DIM=2 ) + num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) + num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) + CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold ) + CALL nl_get_isice ( grid%id , grid%isice ) + CALL nl_get_iswater ( grid%id , grid%iswater ) + CALL adjust_for_seaice_pre ( grid%xice , grid%landmask , grid%tsk , grid%ivgtyp , grid%vegcat , grid%lu_index , & + grid%xland , grid%landusef , grid%isltyp , grid%soilcat , grid%soilctop , & + grid%soilcbot , grid%tmn , & + grid%seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + grid%iswater , grid%isice , & + model_config_rec%sf_surface_physics(grid%id) , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! surface_input_source=1 => use data from static file (fractional category as input) + ! surface_input_source=2 => use data from grib file (dominant category as input) + + IF ( config_flags%surface_input_source .EQ. 1 ) THEN + grid%vegcat (its,jts) = 0 + grid%soilcat(its,jts) = 0 + END IF + + ! Generate the vegetation and soil category information from the fractional input + ! data, or use the existing dominant category fields if they exist. + + IF ( ( grid%soilcat(its,jts) .LT. 0.5 ) .AND. ( grid%vegcat(its,jts) .LT. 0.5 ) ) THEN + + num_veg_cat = SIZE ( grid%landusef , DIM=2 ) + num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) + num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) + + CALL process_percent_cat_new ( grid%landmask , & + grid%landusef , grid%soilctop , grid%soilcbot , & + grid%isltyp , grid%ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + model_config_rec%iswater(grid%id) ) + + ! Make all the veg/soil parms the same so as not to confuse the developer. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + grid%vegcat(i,j) = grid%ivgtyp(i,j) + grid%soilcat(i,j) = grid%isltyp(i,j) + END DO + END DO + + ELSE + + ! Do we have dominant soil and veg data from the input already? + + IF ( grid%soilcat(its,jts) .GT. 0.5 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%isltyp(i,j) = NINT( grid%soilcat(i,j) ) + END DO + END DO + END IF + IF ( grid%vegcat(its,jts) .GT. 0.5 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) ) + END DO + END DO + END IF + + END IF + + ! Land use assignment. + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%lu_index(i,j) = grid%ivgtyp(i,j) + IF ( grid%lu_index(i,j) .NE. model_config_rec%iswater(grid%id) ) THEN + grid%landmask(i,j) = 1 + grid%xland(i,j) = 1 + ELSE + grid%landmask(i,j) = 0 + grid%xland(i,j) = 2 + END IF + END DO + END DO + + ! Adjust the various soil temperature values depending on the difference in + ! in elevation between the current model's elevation and the incoming data's + ! orography. + + IF ( flag_soilhgt .EQ. 1 ) THEN + adjust_soil : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME ) + CALL adjust_soil_temp_new ( grid%tmn , model_config_rec%sf_surface_physics(grid%id) , & + grid%tsk , grid%ht , grid%toposoil , grid%landmask , flag_soilhgt , & + grid%st000010 , grid%st010040 , grid%st040100 , grid%st100200 , grid%st010200 , & + flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , & + grid%st000007 , grid%st007028 , grid%st028100 , grid%st100255 , & + flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , & + grid%soilt000 , grid%soilt005 , grid%soilt020 , grid%soilt040 , grid%soilt160 , & + grid%soilt300 , & + flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , & + flag_soilt160 , flag_soilt300 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + END SELECT adjust_soil + END IF + + ! Fix grid%em_tmn and grid%em_tsk. + + fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME ) + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & + ( grid%sst(i,j) .GT. 240. ) .AND. ( grid%sst(i,j) .LT. 350. ) ) THEN + grid%tmn(i,j) = grid%sst(i,j) + grid%tsk(i,j) = grid%sst(i,j) + ELSE IF ( grid%landmask(i,j) .LT. 0.5 ) THEN + grid%tmn(i,j) = grid%tsk(i,j) + END IF + END DO + END DO + END SELECT fix_tsk_tmn + + ! Is the grid%em_tsk reasonable? + + IF ( internal_time_loop .NE. 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN + grid%tsk(i,j) = grid%em_t_2(i,1,j) + END IF + END DO + END DO + ELSE + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN + print *,'error in the grid%em_tsk' + print *,'i,j=',i,j + print *,'grid%landmask=',grid%landmask(i,j) + print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) + if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then + grid%tsk(i,j)=grid%tmn(i,j) + else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then + grid%tsk(i,j)=grid%sst(i,j) + else + CALL wrf_error_fatal ( 'grid%em_tsk unreasonable' ) + end if + END IF + END DO + END DO + END IF + + ! Is the grid%em_tmn reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( grid%tmn(i,j) .LT. 170. ) .OR. ( grid%tmn(i,j) .GT. 400. ) ) & + .AND. ( grid%landmask(i,j) .GT. 0.5 ) ) THEN + IF ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) THEN + print *,'error in the grid%em_tmn' + print *,'i,j=',i,j + print *,'grid%landmask=',grid%landmask(i,j) + print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) + END IF + + if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then + grid%tmn(i,j)=grid%tsk(i,j) + else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then + grid%tmn(i,j)=grid%sst(i,j) + else + CALL wrf_error_fatal ( 'grid%em_tmn unreasonable' ) + endif + END IF + END DO + END DO + + interpolate_soil_tmw : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME ) + CALL process_soil_real ( grid%tsk , grid%tmn , & + grid%landmask , grid%sst , & + st_input , sm_input , sw_input , st_levels_input , sm_levels_input , sw_levels_input , & + grid%zs , grid%dzs , grid%tslb , grid%smois , grid%sh2o , & + flag_sst , flag_soilt000, flag_soilm000, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + model_config_rec%sf_surface_physics(grid%id) , & + model_config_rec%num_soil_layers , & + model_config_rec%real_data_init_type , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc ) + + END SELECT interpolate_soil_tmw + + ! Minimum soil values, residual, from RUC LSM scheme. For input from Noah and using + ! RUC LSM scheme, this must be subtracted from the input total soil moisture. For + ! input RUC data and using the Noah LSM scheme, this value must be added to the soil + ! moisture input. + + lqmi(1:num_soil_top_cat) = & + (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & + 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & + 0.004, 0.065 /) +! 0.004, 0.065, 0.020, 0.004, 0.008 /) ! has extra levels for playa, lava, and white sand + + ! At the initial time we care about values of soil moisture and temperature, other times are + ! ignored by the model, so we ignore them, too. + + IF ( domain_ClockIsStartTime(grid) ) THEN + account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE ( LSMSCHEME ) + iicount = 0 + IF ( FLAG_SM000010 .EQ. 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 200 ) .and. & + ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then + print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) + iicount = iicount + 1 + grid%smois(i,:,j) = 0.005 + END IF + END DO + END DO + IF ( iicount .GT. 0 ) THEN + print *,'Noah -> Noah: total number of small soil moisture locations = ',iicount + END IF + ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%smois(i,:,j) = grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) + END DO + END DO + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 200 ) .and. & + ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then + print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) + iicount = iicount + 1 + grid%smois(i,:,j) = 0.005 + END IF + END DO + END DO + IF ( iicount .GT. 0 ) THEN + print *,'RUC -> Noah: total number of small soil moisture locations = ',iicount + END IF + END IF + + CASE ( RUCLSMSCHEME ) + iicount = 0 + IF ( FLAG_SM000010 .EQ. 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) - lqmi(grid%isltyp(i,j)) , 0. ) + END DO + END DO + ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN + ! no op + END IF + + END SELECT account_for_zero_soil_moisture + END IF + + ! Is the grid%tslb reasonable? + + IF ( internal_time_loop .NE. 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO ns = 1 , model_config_rec%num_soil_layers + DO i = its, MIN(ide-1,ite) + IF ( grid%tslb(i,ns,j) .LT. 170 .or. grid%tslb(i,ns,j) .GT. 400. ) THEN + grid%tslb(i,ns,j) = grid%em_t_2(i,1,j) + grid%smois(i,ns,j) = 0.3 + END IF + END DO + END DO + END DO + ELSE + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( grid%tslb(i,1,j) .LT. 170. ) .OR. ( grid%tslb(i,1,j) .GT. 400. ) ) .AND. & + ( grid%landmask(i,j) .GT. 0.5 ) ) THEN + IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .AND. & + ( model_config_rec%sf_surface_physics(grid%id) .NE. RUCLSMSCHEME ) ) THEN + print *,'error in the grid%tslb' + print *,'i,j=',i,j + print *,'grid%landmask=',grid%landmask(i,j) + print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) + print *,'grid%tslb = ',grid%tslb(i,:,j) + print *,'old grid%smois = ',grid%smois(i,:,j) + grid%smois(i,1,j) = 0.3 + grid%smois(i,2,j) = 0.3 + grid%smois(i,3,j) = 0.3 + grid%smois(i,4,j) = 0.3 + END IF + + IF ( (grid%tsk(i,j).GT.170. .AND. grid%tsk(i,j).LT.400.) .AND. & + (grid%tmn(i,j).GT.170. .AND. grid%tmn(i,j).LT.400.) ) THEN + fake_soil_temp : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + CASE ( SLABSCHEME ) + DO ns = 1 , model_config_rec%num_soil_layers + grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + & + grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0) + END DO + CASE ( LSMSCHEME , RUCLSMSCHEME ) + CALL wrf_error_fatal ( 'Assigning constant soil moisture, bad idea') + DO ns = 1 , model_config_rec%num_soil_layers + grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + & + grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0) + END DO + END SELECT fake_soil_temp + else if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then + CALL wrf_error_fatal ( 'grid%tslb unreasonable 1' ) + DO ns = 1 , model_config_rec%num_soil_layers + grid%tslb(i,ns,j)=grid%tsk(i,j) + END DO + else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then + CALL wrf_error_fatal ( 'grid%tslb unreasonable 2' ) + DO ns = 1 , model_config_rec%num_soil_layers + grid%tslb(i,ns,j)=grid%sst(i,j) + END DO + else if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then + CALL wrf_error_fatal ( 'grid%tslb unreasonable 3' ) + DO ns = 1 , model_config_rec%num_soil_layers + grid%tslb(i,ns,j)=grid%tmn(i,j) + END DO + else + CALL wrf_error_fatal ( 'grid%tslb unreasonable 4' ) + endif + END IF + END DO + END DO + END IF + + ! Adjustments for the seaice field AFTER the grid%tslb computations. This is + ! is for the Noah LSM scheme. + + num_veg_cat = SIZE ( grid%landusef , DIM=2 ) + num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) + num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) + CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold ) + CALL nl_get_isice ( grid%id , grid%isice ) + CALL nl_get_iswater ( grid%id , grid%iswater ) + CALL adjust_for_seaice_post ( grid%xice , grid%landmask , grid%tsk , grid%tsk_save , & + grid%ivgtyp , grid%vegcat , grid%lu_index , & + grid%xland , grid%landusef , grid%isltyp , grid%soilcat , & + grid%soilctop , & + grid%soilcbot , grid%tmn , grid%vegfra , & + grid%tslb , grid%smois , grid%sh2o , & + grid%seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + model_config_rec%num_soil_layers , & + grid%iswater , grid%isice , & + model_config_rec%sf_surface_physics(grid%id) , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Let us make sure (again) that the grid%landmask and the veg/soil categories match. + +oops1=0 +oops2=0 + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. & + ( grid%ivgtyp(i,j) .NE. config_flags%iswater .OR. grid%isltyp(i,j) .NE. 14 ) ) .OR. & + ( ( grid%landmask(i,j) .GT. 0.5 ) .AND. & + ( grid%ivgtyp(i,j) .EQ. config_flags%iswater .OR. grid%isltyp(i,j) .EQ. 14 ) ) ) THEN + IF ( grid%tslb(i,1,j) .GT. 1. ) THEN +oops1=oops1+1 + grid%ivgtyp(i,j) = 5 + grid%isltyp(i,j) = 8 + grid%landmask(i,j) = 1 + grid%xland(i,j) = 1 + ELSE IF ( grid%sst(i,j) .GT. 1. ) THEN +oops2=oops2+1 + grid%ivgtyp(i,j) = config_flags%iswater + grid%isltyp(i,j) = 14 + grid%landmask(i,j) = 0 + grid%xland(i,j) = 2 + ELSE + print *,'the grid%landmask and soil/veg cats do not match' + print *,'i,j=',i,j + print *,'grid%landmask=',grid%landmask(i,j) + print *,'grid%ivgtyp=',grid%ivgtyp(i,j) + print *,'grid%isltyp=',grid%isltyp(i,j) + print *,'iswater=', config_flags%iswater + print *,'grid%tslb=',grid%tslb(i,:,j) + print *,'grid%sst=',grid%sst(i,j) + CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' ) + END IF + END IF + END DO + END DO +if (oops1.gt.0) then +print *,'points artificially set to land : ',oops1 +endif +if(oops2.gt.0) then +print *,'points artificially set to water: ',oops2 +endif +! fill grid%sst array with grid%em_tsk if missing in real input (needed for time-varying grid%sst in wrf) + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( flag_sst .NE. 1 ) THEN + grid%sst(i,j) = grid%tsk(i,j) + ENDIF + END DO + END DO + + ! From the full level data, we can get the half levels, reciprocals, and layer + ! thicknesses. These are all defined at half level locations, so one less level. + ! We allow the vertical coordinate to *accidently* come in upside down. We want + ! the first full level to be the ground surface. + + ! Check whether grid%em_znw (full level) data are truly full levels. If not, we need to adjust them + ! to be full levels. + ! in this test, we check if grid%em_znw(1) is neither 0 nor 1 (within a tolerance of 10**-5) + + were_bad = .false. + IF ( ( (grid%em_znw(1).LT.(1-1.E-5) ) .OR. ( grid%em_znw(1).GT.(1+1.E-5) ) ).AND. & + ( (grid%em_znw(1).LT.(0-1.E-5) ) .OR. ( grid%em_znw(1).GT.(0+1.E-5) ) ) ) THEN + were_bad = .true. + print *,'Your grid%em_znw input values are probably half-levels. ' + print *,grid%em_znw + print *,'WRF expects grid%em_znw values to be full levels. ' + print *,'Adjusting now to full levels...' + ! We want to ignore the first value if it's negative + IF (grid%em_znw(1).LT.0) THEN + grid%em_znw(1)=0 + END IF + DO k=2,kde + grid%em_znw(k)=2*grid%em_znw(k)-grid%em_znw(k-1) + END DO + END IF + + ! Let's check our changes + + IF ( ( ( grid%em_znw(1) .LT. (1-1.E-5) ) .OR. ( grid%em_znw(1) .GT. (1+1.E-5) ) ).AND. & + ( ( grid%em_znw(1) .LT. (0-1.E-5) ) .OR. ( grid%em_znw(1) .GT. (0+1.E-5) ) ) ) THEN + print *,'The input grid%em_znw height values were half-levels or erroneous. ' + print *,'Attempts to treat the values as half-levels and change them ' + print *,'to valid full levels failed.' + CALL wrf_error_fatal("bad grid%em_znw values from input files") + ELSE IF ( were_bad ) THEN + print *,'...adjusted. grid%em_znw array now contains full eta level values. ' + ENDIF + + IF ( grid%em_znw(1) .LT. grid%em_znw(kde) ) THEN + DO k=1, kde/2 + hold_znw = grid%em_znw(k) + grid%em_znw(k)=grid%em_znw(kde+1-k) + grid%em_znw(kde+1-k)=hold_znw + END DO + END IF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + END DO + + ! Now the same sort of computations with the half eta levels, even ANOTHER + ! level less than the one above. + + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + END DO + + ! Scads of vertical coefficients. + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + + ! Inverse grid distances. + + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + + ! Some of the many weird geopotential initializations that we'll see today: grid%em_ph0 is total, + ! and grid%em_ph_2 is a perturbation from the base state geopotential. We set the base geopotential + ! at the lowest level to terrain elevation * gravity. + + DO j=jts,jte + DO i=its,ite + grid%em_ph0(i,1,j) = grid%ht(i,j) * g + grid%em_ph_2(i,1,j) = 0. + END DO + END DO + + ! Base state potential temperature and inverse density (alpha = 1/rho) from + ! the half eta levels and the base-profile surface pressure. Compute 1/rho + ! from equation of state. The potential temperature is a perturbation from t0. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + + ! Base state pressure is a function of eta level and terrain, only, plus + ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level + ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K). + + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) + + + DO k = 1, kte-1 + grid%em_php(i,k,j) = grid%em_znw(k)*(p_surf - grid%p_top) + grid%p_top ! temporary, full lev base pressure + grid%em_pb(i,k,j) = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top +! temp = MAX ( 200., t00 + A*LOG(grid%em_pb(i,k,j)/p00) ) + temp = t00 + A*LOG(grid%em_pb(i,k,j)/p00) + grid%em_t_init(i,k,j) = temp*(p00/grid%em_pb(i,k,j))**(r_d/cp) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + END DO + + ! Base state mu is defined as base state surface pressure minus grid%p_top + + grid%em_mub(i,j) = p_surf - grid%p_top + + ! Dry surface pressure is defined as the following (this mu is from the input file + ! computed from the dry pressure). Here the dry pressure is just reconstituted. + + pd_surf = grid%em_mu0(i,j) + grid%p_top + + ! Integrate base geopotential, starting at terrain elevation. This assures that + ! the base state is in exact hydrostatic balance with respect to the model equations. + ! This field is on full levels. + + grid%em_phb(i,1,j) = grid%ht(i,j) * g + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + END DO + END DO + END DO + + ! Fill in the outer rows and columns to allow us to be sloppy. + + IF ( ite .EQ. ide ) THEN + i = ide + DO j = jts, MIN(jde-1,jte) + grid%em_mub(i,j) = grid%em_mub(i-1,j) + grid%em_mu_2(i,j) = grid%em_mu_2(i-1,j) + DO k = 1, kte-1 + grid%em_pb(i,k,j) = grid%em_pb(i-1,k,j) + grid%em_t_init(i,k,j) = grid%em_t_init(i-1,k,j) + grid%em_alb(i,k,j) = grid%em_alb(i-1,k,j) + END DO + DO k = 1, kte + grid%em_phb(i,k,j) = grid%em_phb(i-1,k,j) + END DO + END DO + END IF + + IF ( jte .EQ. jde ) THEN + j = jde + DO i = its, ite + grid%em_mub(i,j) = grid%em_mub(i,j-1) + grid%em_mu_2(i,j) = grid%em_mu_2(i,j-1) + DO k = 1, kte-1 + grid%em_pb(i,k,j) = grid%em_pb(i,k,j-1) + grid%em_t_init(i,k,j) = grid%em_t_init(i,k,j-1) + grid%em_alb(i,k,j) = grid%em_alb(i,k,j-1) + END DO + DO k = 1, kte + grid%em_phb(i,k,j) = grid%em_phb(i,k,j-1) + END DO + END DO + END IF + + ! Compute the perturbation dry pressure (grid%em_mub + grid%em_mu_2 + ptop = dry grid%em_psfc). + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + grid%em_mu_2(i,j) = grid%em_mu0(i,j) - grid%em_mub(i,j) + END DO + END DO + + ! Fill in the outer rows and columns to allow us to be sloppy. + + IF ( ite .EQ. ide ) THEN + i = ide + DO j = jts, MIN(jde-1,jte) + grid%em_mu_2(i,j) = grid%em_mu_2(i-1,j) + END DO + END IF + + IF ( jte .EQ. jde ) THEN + j = jde + DO i = its, ite + grid%em_mu_2(i,j) = grid%em_mu_2(i,j-1) + END DO + END IF + + lev500 = 0 + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + + ! Assign the potential temperature (perturbation from t0) and qv on all the mass + ! point locations. + + DO k = 1 , kde-1 + grid%em_t_2(i,k,j) = grid%em_t_2(i,k,j) - t0 + END DO + + dpmu = 10001. + loop_count = 0 + + DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. & + ( loop_count .LT. 5 ) ) + + loop_count = loop_count + 1 + + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum + ! equation) down from the top to get the pressure perturbation. First get the pressure + ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. + + k = kte-1 + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_2(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_2(i,k,j)+t0)*qvf& + *(((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_2(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_2(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + END DO + + ! This is the hydrostatic equation used in the model after the small timesteps. In + ! the model, grid%em_al (inverse density) is computed from the geopotential. + + DO k = 2,kte + grid%em_ph_2(i,k,j) = grid%em_ph_2(i,k-1,j) - & + grid%em_dnw(k-1) * ( (grid%em_mub(i,j)+grid%em_mu_2(i,j))*grid%em_al(i,k-1,j) & + + grid%em_mu_2(i,j)*grid%em_alb(i,k-1,j) ) + grid%em_ph0(i,k,j) = grid%em_ph_2(i,k,j) + grid%em_phb(i,k,j) + END DO + + ! Adjust the column pressure so that the computed 500 mb height is close to the + ! input value (of course, not when we are doing hybrid input). + + IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. its ) .AND. ( j .EQ. jts ) ) THEN + DO k = 1 , num_metgrid_levels + IF ( ABS ( grid%em_p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN + lev500 = k + EXIT + END IF + END DO + END IF + + ! We only do the adjustment of height if we have the input data on pressure + ! surfaces, and folks have asked to do this option. + + IF ( ( flag_metgrid .EQ. 1 ) .AND. & + ( config_flags%adjust_heights ) .AND. & + ( lev500 .NE. 0 ) ) THEN + + DO k = 2 , kte-1 + + ! Get the pressures on the full eta levels (grid%em_php is defined above as + ! the full-lev base pressure, an easy array to use for 3d space). + + pl = grid%em_php(i,k ,j) + & + ( grid%em_p(i,k-1 ,j) * ( grid%em_znw(k ) - grid%em_znu(k ) ) + & + grid%em_p(i,k ,j) * ( grid%em_znu(k-1 ) - grid%em_znw(k ) ) ) / & + ( grid%em_znu(k-1 ) - grid%em_znu(k ) ) + pu = grid%em_php(i,k+1,j) + & + ( grid%em_p(i,k-1+1,j) * ( grid%em_znw(k +1) - grid%em_znu(k+1) ) + & + grid%em_p(i,k +1,j) * ( grid%em_znu(k-1+1) - grid%em_znw(k+1) ) ) / & + ( grid%em_znu(k-1+1) - grid%em_znu(k+1) ) + + ! If these pressure levels trap 500 mb, use them to interpolate + ! to the 500 mb level of the computed height. + + IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN + zl = ( grid%em_ph_2(i,k ,j) + grid%em_phb(i,k ,j) ) / g + zu = ( grid%em_ph_2(i,k+1,j) + grid%em_phb(i,k+1,j) ) / g + + z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + & + zu * ( LOG(pl ) - LOG(50000.) ) ) / & + ( LOG(pl) - LOG(pu) ) +! z500 = ( zl * ( (50000.) - (pu ) ) + & +! zu * ( (pl ) - (50000.) ) ) / & +! ( (pl) - (pu) ) + + ! Compute the difference of the 500 mb heights (computed minus input), and + ! then the change in grid%em_mu_2. The grid%em_php is still full-levels, base pressure. + + dz500 = z500 - grid%em_ght_gc(i,lev500,j) + tvsfc = ((grid%em_t_2(i,1,j)+t0)*((grid%em_p(i,1,j)+grid%em_php(i,1,j))/p1000mb)**(r_d/cp)) * & + (1.+0.6*moist(i,1,j,P_QV)) + dpmu = ( grid%em_php(i,1,j) + grid%em_p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) + dpmu = dpmu - ( grid%em_php(i,1,j) + grid%em_p(i,1,j) ) + grid%em_mu_2(i,j) = grid%em_mu_2(i,j) - dpmu + EXIT + END IF + + END DO + ELSE + dpmu = 0. + END IF + + END DO + + END DO + END DO + + ! If this is data from the SI, then we probably do not have the original + ! surface data laying around. Note that these are all the lowest levels + ! of the respective 3d arrays. For surface pressure, we assume that the + ! vertical gradient of grid%em_p prime is zilch. This is not all that important. + ! These are filled in so that the various plotting routines have something + ! to play with at the initial time for the model. + + IF ( flag_metgrid .NE. 1 ) THEN + DO j = jts, min(jde-1,jte) + DO i = its, min(ide,ite) + grid%u10(i,j)=grid%em_u_2(i,1,j) + END DO + END DO + + DO j = jts, min(jde,jte) + DO i = its, min(ide-1,ite) + grid%v10(i,j)=grid%em_v_2(i,1,j) + END DO + END DO + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) + grid%psfc(i,j)=p_surf + grid%em_p(i,1,j) + grid%q2(i,j)=moist(i,1,j,P_QV) + grid%th2(i,j)=grid%em_t_2(i,1,j)+300. + grid%t2(i,j)=grid%th2(i,j)*(((grid%em_p(i,1,j)+grid%em_pb(i,1,j))/p00)**(r_d/cp)) + END DO + END DO + + ! If this data is from WPS, then we have previously assigned the surface + ! data for u, v, and t. If we have an input qv, welp, we assigned that one, + ! too. Now we pick up the left overs, and if RH came in - we assign the + ! mixing ratio. + + ELSE IF ( flag_metgrid .EQ. 1 ) THEN + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) + grid%psfc(i,j)=p_surf + grid%em_p(i,1,j) + grid%th2(i,j)=grid%t2(i,j)*(p00/(grid%em_p(i,1,j)+grid%em_pb(i,1,j)))**(r_d/cp) + END DO + END DO + IF ( flag_qv .NE. 1 ) THEN + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + grid%q2(i,j)=moist(i,1,j,P_QV) + END DO + END DO + END IF + + END IF + + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte +#ifdef DM_PARALLEL +# include "HALO_EM_INIT_1.inc" +# include "HALO_EM_INIT_2.inc" +# include "HALO_EM_INIT_3.inc" +# include "HALO_EM_INIT_4.inc" +# include "HALO_EM_INIT_5.inc" +#endif + + RETURN + + END SUBROUTINE init_domain_rk + +!--------------------------------------------------------------------- + + SUBROUTINE const_module_initialize ( p00 , t00 , a ) + USE module_configure + IMPLICIT NONE + ! For the real-data-cases only. + REAL , INTENT(OUT) :: p00 , t00 , a + CALL nl_get_base_pres ( 1 , p00 ) + CALL nl_get_base_temp ( 1 , t00 ) + CALL nl_get_base_lapse ( 1 , a ) + END SUBROUTINE const_module_initialize + +!------------------------------------------------------------------- + + SUBROUTINE rebalance_driver ( grid ) + + IMPLICIT NONE + + TYPE (domain) :: grid + + CALL rebalance( grid & +! +#include "em_actual_new_args.inc" +! + ) + + END SUBROUTINE rebalance_driver + +!--------------------------------------------------------------------- + + SUBROUTINE rebalance ( grid & +! +#include "em_dummy_new_args.inc" +! + ) + IMPLICIT NONE + + TYPE (domain) :: grid + +#include "em_dummy_new_decl.inc" + + TYPE (grid_config_rec_type) :: config_flags + + REAL :: p_surf , pd_surf, p_surf_int , pb_int , ht_hold + REAL :: qvf , qvf1 , qvf2 + REAL :: p00 , t00 , a + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: t_init_int + + ! Local domain indices and counters. + + INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + ips, ipe, jps, jpe, kps, kpe, & + i, j, k + +#ifdef DM_PARALLEL +# include "em_data_calls.inc" +#endif + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + ALLOCATE ( t_init_int(ims:ime,kms:kme,jms:jme) ) + + ! Some of the many weird geopotential initializations that we'll see today: grid%em_ph0 is total, + ! and grid%em_ph_2 is a perturbation from the base state geopotential. We set the base geopotential + ! at the lowest level to terrain elevation * gravity. + + DO j=jts,jte + DO i=its,ite + grid%em_ph0(i,1,j) = grid%ht_fine(i,j) * g + grid%em_ph_2(i,1,j) = 0. + END DO + END DO + + ! To define the base state, we call a USER MODIFIED routine to set the three + ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K), + ! and A (temperature difference, from 1000 mb to 300 mb, K). + + CALL const_module_initialize ( p00 , t00 , a ) + + ! Base state potential temperature and inverse density (alpha = 1/rho) from + ! the half eta levels and the base-profile surface pressure. Compute 1/rho + ! from equation of state. The potential temperature is a perturbation from t0. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + + ! Base state pressure is a function of eta level and terrain, only, plus + ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level + ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K). + ! The fine grid terrain is ht_fine, the interpolated is grid%em_ht. + + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht_fine(i,j)/a/r_d ) **0.5 ) + p_surf_int = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j) /a/r_d ) **0.5 ) + + DO k = 1, kte-1 + grid%em_pb(i,k,j) = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + pb_int = grid%em_znu(k)*(p_surf_int - grid%p_top) + grid%p_top + grid%em_t_init(i,k,j) = (t00 + A*LOG(grid%em_pb(i,k,j)/p00))*(p00/grid%em_pb(i,k,j))**(r_d/cp) - t0 + t_init_int(i,k,j)= (t00 + A*LOG(pb_int /p00))*(p00/pb_int )**(r_d/cp) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + END DO + + ! Base state mu is defined as base state surface pressure minus grid%p_top + + grid%em_mub(i,j) = p_surf - grid%p_top + + ! Dry surface pressure is defined as the following (this mu is from the input file + ! computed from the dry pressure). Here the dry pressure is just reconstituted. + + pd_surf = ( grid%em_mub(i,j) + grid%em_mu_2(i,j) ) + grid%p_top + + ! Integrate base geopotential, starting at terrain elevation. This assures that + ! the base state is in exact hydrostatic balance with respect to the model equations. + ! This field is on full levels. + + grid%em_phb(i,1,j) = grid%ht_fine(i,j) * g + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + END DO + END DO + END DO + + ! Replace interpolated terrain with fine grid values. + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%ht(i,j) = grid%ht_fine(i,j) + END DO + END DO + + ! Perturbation fields. + + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + + ! The potential temperature is THETAnest = THETAinterp + ( TBARnest - TBARinterp) + + DO k = 1 , kde-1 + grid%em_t_2(i,k,j) = grid%em_t_2(i,k,j) + ( grid%em_t_init(i,k,j) - t_init_int(i,k,j) ) + END DO + + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum + ! equation) down from the top to get the pressure perturbation. First get the pressure + ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. + + k = kte-1 + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_2(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_2(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_2(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_2(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + END DO + + ! This is the hydrostatic equation used in the model after the small timesteps. In + ! the model, grid%em_al (inverse density) is computed from the geopotential. + + DO k = 2,kte + grid%em_ph_2(i,k,j) = grid%em_ph_2(i,k-1,j) - & + grid%em_dnw(k-1) * ( (grid%em_mub(i,j)+grid%em_mu_2(i,j))*grid%em_al(i,k-1,j) & + + grid%em_mu_2(i,j)*grid%em_alb(i,k-1,j) ) + grid%em_ph0(i,k,j) = grid%em_ph_2(i,k,j) + grid%em_phb(i,k,j) + END DO + + END DO + END DO + + DEALLOCATE ( t_init_int ) + + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte +#ifdef DM_PARALLEL +# include "HALO_EM_INIT_1.inc" +# include "HALO_EM_INIT_2.inc" +# include "HALO_EM_INIT_3.inc" +# include "HALO_EM_INIT_4.inc" +# include "HALO_EM_INIT_5.inc" +#endif + END SUBROUTINE rebalance + +!--------------------------------------------------------------------- + + RECURSIVE SUBROUTINE find_my_parent ( grid_ptr_in , grid_ptr_out , id_i_am , id_wanted , found_the_id ) + + USE module_domain + + TYPE(domain) , POINTER :: grid_ptr_in , grid_ptr_out + TYPE(domain) , POINTER :: grid_ptr_sibling + INTEGER :: id_wanted , id_i_am + LOGICAL :: found_the_id + + found_the_id = .FALSE. + grid_ptr_sibling => grid_ptr_in + DO WHILE ( ASSOCIATED ( grid_ptr_sibling ) ) + + IF ( grid_ptr_sibling%grid_id .EQ. id_wanted ) THEN + found_the_id = .TRUE. + grid_ptr_out => grid_ptr_sibling + RETURN + ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 ) THEN + grid_ptr_sibling => grid_ptr_sibling%nests(1)%ptr + CALL find_my_parent ( grid_ptr_sibling , grid_ptr_out , id_i_am , id_wanted , found_the_id ) + ELSE + grid_ptr_sibling => grid_ptr_sibling%sibling + END IF + + END DO + + END SUBROUTINE find_my_parent + +#endif + +!--------------------------------------------------------------------- + +#ifdef VERT_UNIT + +!This is a main program for a small unit test for the vertical interpolation. + +program vint + + implicit none + + integer , parameter :: ij = 3 + integer , parameter :: keta = 30 + integer , parameter :: kgen =20 + + integer :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + integer :: generic + + real , dimension(1:ij,kgen,1:ij) :: fo , po + real , dimension(1:ij,1:keta,1:ij) :: fn_calc , fn_interp , pn + + integer, parameter :: interp_type = 1 ! 2 +! integer, parameter :: lagrange_order = 2 ! 1 + integer :: lagrange_order + logical, parameter :: lowest_lev_from_sfc = .FALSE. ! .TRUE. + real , parameter :: zap_close_levels = 500. ! 100. + integer, parameter :: force_sfc_in_vinterp = 0 ! 6 + + integer :: k + + ids = 1 ; ide = ij ; jds = 1 ; jde = ij ; kds = 1 ; kde = keta + ims = 1 ; ime = ij ; jms = 1 ; jme = ij ; kms = 1 ; kme = keta + its = 1 ; ite = ij ; jts = 1 ; jte = ij ; kts = 1 ; kte = keta + + generic = kgen + + print *,' ' + print *,'------------------------------------' + print *,'UNIT TEST FOR VERTICAL INTERPOLATION' + print *,'------------------------------------' + print *,' ' + do lagrange_order = 1 , 2 + print *,' ' + print *,'------------------------------------' + print *,'Lagrange Order = ',lagrange_order + print *,'------------------------------------' + print *,' ' + call fillitup ( fo , po , fn_calc , pn , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + generic , lagrange_order ) + + print *,' ' + print *,'Level Pressure Field' + print *,' (Pa) (generic)' + print *,'------------------------------------' + print *,' ' + do k = 1 , generic + write (*,fmt='(i2,2x,f12.3,1x,g15.8)' ) & + k,po(2,k,2),fo(2,k,2) + end do + print *,' ' + + call vert_interp ( fo , po , fn_interp , pn , & + generic , 'T' , & + interp_type , lagrange_order , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + print *,'Multi-Order Interpolator' + print *,'------------------------------------' + print *,' ' + print *,'Level Pressure Field Field Field' + print *,' (Pa) Calc Interp Diff' + print *,'------------------------------------' + print *,' ' + do k = kts , kte-1 + write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) & + k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2) + end do + + call vert_interp_old ( fo , po , fn_interp , pn , & + generic , 'T' , & + interp_type , lagrange_order , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + print *,'Linear Interpolator' + print *,'------------------------------------' + print *,' ' + print *,'Level Pressure Field Field Field' + print *,' (Pa) Calc Interp Diff' + print *,'------------------------------------' + print *,' ' + do k = kts , kte-1 + write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) & + k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2) + end do + end do + +end program vint + +subroutine wrf_error_fatal (string) + character (len=*) :: string + print *,string + stop +end subroutine wrf_error_fatal + +subroutine fillitup ( fo , po , fn , pn , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + generic , lagrange_order ) + + implicit none + + integer , intent(in) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + integer , intent(in) :: generic , lagrange_order + + real , dimension(ims:ime,generic,jms:jme) , intent(out) :: fo , po + real , dimension(ims:ime,kms:kme,jms:jme) , intent(out) :: fn , pn + + integer :: i , j , k + + real , parameter :: piov2 = 3.14159265358 / 2. + + k = 1 + do j = jts , jte + do i = its , ite + po(i,k,j) = 102000. + end do + end do + + do k = 2 , generic + do j = jts , jte + do i = its , ite + po(i,k,j) = ( 5000. * ( 1 - (k-1) ) + 100000. * ( (k-1) - (generic-1) ) ) / (1. - real(generic-1) ) + end do + end do + end do + + if ( lagrange_order .eq. 1 ) then + do k = 1 , generic + do j = jts , jte + do i = its , ite + fo(i,k,j) = po(i,k,j) +! fo(i,k,j) = sin(po(i,k,j) * piov2 / 102000. ) + end do + end do + end do + else if ( lagrange_order .eq. 2 ) then + do k = 1 , generic + do j = jts , jte + do i = its , ite + fo(i,k,j) = (((po(i,k,j)-5000.)/102000.)*((102000.-po(i,k,j))/102000.))*102000. +! fo(i,k,j) = sin(po(i,k,j) * piov2 / 102000. ) + end do + end do + end do + end if + +!!!!!!!!!!!! + + do k = kts , kte + do j = jts , jte + do i = its , ite + pn(i,k,j) = ( 5000. * ( 0 - (k-1) ) + 102000. * ( (k-1) - (kte-1) ) ) / (-1. * real(kte-1) ) + end do + end do + end do + + do k = kts , kte-1 + do j = jts , jte + do i = its , ite + pn(i,k,j) = ( pn(i,k,j) + pn(i,k+1,j) ) /2. + end do + end do + end do + + + if ( lagrange_order .eq. 1 ) then + do k = kts , kte-1 + do j = jts , jte + do i = its , ite + fn(i,k,j) = pn(i,k,j) +! fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. ) + end do + end do + end do + else if ( lagrange_order .eq. 2 ) then + do k = kts , kte-1 + do j = jts , jte + do i = its , ite + fn(i,k,j) = (((pn(i,k,j)-5000.)/102000.)*((102000.-pn(i,k,j))/102000.))*102000. +! fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. ) + end do + end do + end do + end if + +end subroutine fillitup + +#endif + +!--------------------------------------------------------------------- + + SUBROUTINE vert_interp ( fo , po , fnew , pnu , & + generic , var_type , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Vertically interpolate the new field. The original field on the original + ! pressure levels is provided, and the new pressure surfaces to interpolate to. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type + LOGICAL , INTENT(IN) :: lowest_lev_from_sfc + REAL , INTENT(IN) :: zap_close_levels + INTEGER , INTENT(IN) :: force_sfc_in_vinterp + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + INTEGER , INTENT(IN) :: generic + + CHARACTER (LEN=1) :: var_type + + REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: fo , po + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew + + REAL , DIMENSION(ims:ime,generic,jms:jme) :: forig , porig + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew + + ! Local vars + + INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 , knext + INTEGER :: istart , iend , jstart , jend , kstart , kend + INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below + INTEGER , DIMENSION(ims:ime ) :: ks + INTEGER , DIMENSION(ims:ime ) :: ko_above_sfc + INTEGER :: count , zap , kst + + LOGICAL :: any_below_ground + + REAL :: p1 , p2 , pn, hold + REAL , DIMENSION(1:generic) :: ordered_porig , ordered_forig + REAL , DIMENSION(kts:kte) :: ordered_pnew , ordered_fnew + + ! Horiontal loop bounds for different variable types. + + IF ( var_type .EQ. 'U' ) THEN + istart = its + iend = ite + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = MAX(ids+1,its) , MIN(ide-1,ite) + porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5 + END DO + END DO + IF ( ids .EQ. its ) THEN + DO k = 1,generic + porig(its,k,j) = po(its,k,j) + END DO + END IF + IF ( ide .EQ. ite ) THEN + DO k = 1,generic + porig(ite,k,j) = po(ite-1,k,j) + END DO + END IF + + DO k = kstart,kend + DO i = MAX(ids+1,its) , MIN(ide-1,ite) + pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5 + END DO + END DO + IF ( ids .EQ. its ) THEN + DO k = kstart,kend + pnew(its,k,j) = pnu(its,k,j) + END DO + END IF + IF ( ide .EQ. ite ) THEN + DO k = kstart,kend + pnew(ite,k,j) = pnu(ite-1,k,j) + END DO + END IF + END DO + ELSE IF ( var_type .EQ. 'V' ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = jte + kstart = kts + kend = kte-1 + DO i = istart,iend + DO k = 1,generic + DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5 + END DO + END DO + IF ( jds .EQ. jts ) THEN + DO k = 1,generic + porig(i,k,jts) = po(i,k,jts) + END DO + END IF + IF ( jde .EQ. jte ) THEN + DO k = 1,generic + porig(i,k,jte) = po(i,k,jte-1) + END DO + END IF + + DO k = kstart,kend + DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5 + END DO + END DO + IF ( jds .EQ. jts ) THEN + DO k = kstart,kend + pnew(i,k,jts) = pnu(i,k,jts) + END DO + END IF + IF ( jde .EQ. jte ) THEN + DO k = kstart,kend + pnew(i,k,jte) = pnu(i,k,jte-1) + END DO + END IF + END DO + ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + ELSE + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + END IF + + DO j = jstart , jend + + ! The lowest level is the surface. Levels 2 through "generic" are supposed to + ! be "bottom-up". Flip if they are not. This is based on the input pressure + ! array. + + IF ( porig(its,2,j) .LT. porig(its,generic,j) ) THEN + DO kn = 2 , ( generic + 1 ) / 2 + DO i = istart , iend + hold = porig(i,kn,j) + porig(i,kn,j) = porig(i,generic+2-kn,j) + porig(i,generic+2-kn,j) = hold + forig(i,kn,j) = fo (i,generic+2-kn,j) + forig(i,generic+2-kn,j) = fo (i,kn,j) + END DO + DO i = istart , iend + forig(i,1,j) = fo (i,1,j) + END DO + END DO + ELSE + DO kn = 1 , generic + DO i = istart , iend + forig(i,kn,j) = fo (i,kn,j) + END DO + END DO + END IF + + ! Skip all of the levels below ground in the original data based upon the surface pressure. + ! The ko_above_sfc is the index in the pressure array that is above the surface. If there + ! are no levels underground, this is index = 2. The remaining levels are eligible for use + ! in the vertical interpolation. + + DO i = istart , iend + ko_above_sfc(i) = -1 + END DO + DO ko = kstart+1 , kend + DO i = istart , iend + IF ( ko_above_sfc(i) .EQ. -1 ) THEN + IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN + ko_above_sfc(i) = ko + END IF + END IF + END DO + END DO + + ! Piece together columns of the original input data. Pass the vertical columns to + ! the iterpolator. + + DO i = istart , iend + + ! If the surface value is in the middle of the array, three steps: 1) do the + ! values below the ground (this is just to catch the occasional value that is + ! inconsistently below the surface based on input data), 2) do the surface level, then + ! 3) add in the levels that are above the surface. For the levels next to the surface, + ! we check to remove any levels that are "too close". When building the column of input + ! pressures, we also attend to the request for forcing the surface analysis to be used + ! in a few lower eta-levels. + + ! How many levels have we skipped in the input column. + + zap = 0 + + ! Fill in the column from up to the level just below the surface with the input + ! presssure and the input field (orig or old, which ever). For an isobaric input + ! file, this data is isobaric. + + IF ( ko_above_sfc(i) .GT. 2 ) THEN + count = 1 + DO ko = 2 , ko_above_sfc(i)-1 + ordered_porig(count) = porig(i,ko,j) + ordered_forig(count) = forig(i,ko,j) + count = count + 1 + END DO + + ! Make sure the pressure just below the surface is not "too close", this + ! will cause havoc with the higher order interpolators. In case of a "too close" + ! instance, we toss out the offending level (NOT the surface one) by simply + ! decrementing the accumulating loop counter. + + IF ( ordered_porig(count-1) - porig(i,1,j) .LT. zap_close_levels ) THEN + count = count -1 + zap = 1 + END IF + + ! Add in the surface values. + + ordered_porig(count) = porig(i,1,j) + ordered_forig(count) = forig(i,1,j) + count = count + 1 + + ! A usual way to do the vertical interpolation is to pay more attention to the + ! surface data. Why? Well it has about 20x the density as the upper air, so we + ! hope the analysis is better there. We more strongly use this data by artificially + ! tossing out levels above the surface that are beneath a certain number of prescribed + ! eta levels at this (i,j). The "zap" value is how many levels of input we are + ! removing, which is used to tell the interpolator how many valid values are in + ! the column. The "count" value is the increment to the index of levels, and is + ! only used for assignments. + + IF ( force_sfc_in_vinterp .GT. 0 ) THEN + + ! Get the pressure at the eta level. We want to remove all input pressure levels + ! between the level above the surface to the pressure at this eta surface. That + ! forces the surface value to be used through the selected eta level. Keep track + ! of two things: the level to use above the eta levels, and how many levels we are + ! skipping. + + knext = ko_above_sfc(i) + find_level : DO ko = ko_above_sfc(i) , generic + IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN + knext = ko + exit find_level + ELSE + zap = zap + 1 + END IF + END DO find_level + + ! No request for special interpolation, so we just assign the next level to use + ! above the surface as, ta da, the first level above the surface. I know, wow. + + ELSE + knext = ko_above_sfc(i) + END IF + + ! One more time, make sure the pressure just above the surface is not "too close", this + ! will cause havoc with the higher order interpolators. In case of a "too close" + ! instance, we toss out the offending level above the surface (NOT the surface one) by simply + ! incrementing the loop counter. Here, count-1 is the surface level and knext is either + ! the next level up OR it is the level above the prescribed number of eta surfaces. + + IF ( ordered_porig(count-1) - porig(i,knext,j) .LT. zap_close_levels ) THEN + kst = knext+1 + zap = zap + 1 + ELSE + kst = knext + END IF + + DO ko = kst , generic + ordered_porig(count) = porig(i,ko,j) + ordered_forig(count) = forig(i,ko,j) + count = count + 1 + END DO + + ! This is easy, the surface is the lowest level, just stick them in, in this order. OK, + ! there are a couple of subtleties. We have to check for that special interpolation that + ! skips some input levels so that the surface is used for the lowest few eta levels. Also, + ! we must macke sure that we still do not have levels that are "too close" together. + + ELSE + + ! Initialize no input levels have yet been removed from consideration. + + zap = 0 + + ! The surface is the lowest level, so it gets set right away to location 1. + + ordered_porig(1) = porig(i,1,j) + ordered_forig(1) = forig(i,1,j) + + ! We start filling in the array at loc 2, as in just above the level we just stored. + + count = 2 + + ! Are we forcing the interpolator to skip valid input levels so that the + ! surface data is used through more levels? Essentially as above. + + IF ( force_sfc_in_vinterp .GT. 0 ) THEN + knext = 2 + find_level2: DO ko = 2 , generic + IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN + knext = ko + exit find_level2 + ELSE + zap = zap + 1 + END IF + END DO find_level2 + ELSE + knext = 2 + END IF + + ! Fill in the data above the surface. The "knext" index is either the one + ! just above the surface OR it is the index associated with the level that + ! is just above the pressure at this (i,j) of the top eta level that is to + ! be directly impacted with the surface level in interpolation. + + DO ko = knext , generic + IF ( ordered_porig(count-1) - porig(i,ko,j) .LT. zap_close_levels ) THEN + zap = zap + 1 + CYCLE + END IF + ordered_porig(count) = porig(i,ko,j) + ordered_forig(count) = forig(i,ko,j) + count = count + 1 + END DO + + END IF + + ! Now get the column of the "new" pressure data. So, this one is easy. + + DO kn = kstart , kend + ordered_pnew(kn) = pnew(i,kn,j) + END DO + + ! The polynomials are either in pressure or LOG(pressure). + + IF ( interp_type .EQ. 1 ) THEN + CALL lagrange_setup ( var_type , & + ordered_porig , ordered_forig , generic-zap , lagrange_order , extrap_type , & + ordered_pnew , ordered_fnew , kend-kstart+1 ,i,j) + ELSE + CALL lagrange_setup ( var_type , & + LOG(ordered_porig(1:generic-zap)) , ordered_forig , generic-zap , lagrange_order , extrap_type , & + LOG(ordered_pnew(kstart:kend)) , ordered_fnew , kend-kstart+1 ,i,j) + END IF + + ! Save the computed data. + + DO kn = kstart , kend + fnew(i,kn,j) = ordered_fnew(kn) + END DO + + ! There may have been a request to have the surface data from the input field + ! to be assigned as to the lowest eta level. This assumes thin layers (usually + ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V). + + IF ( lowest_lev_from_sfc ) THEN + fnew(i,1,j) = forig(i,ko_above_sfc(i)-1,j) + END IF + + END DO + + END DO + + END SUBROUTINE vert_interp + +!--------------------------------------------------------------------- + + SUBROUTINE vert_interp_old ( forig , po , fnew , pnu , & + generic , var_type , & + interp_type , lagrange_order , extrap_type , lowest_lev_from_sfc , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Vertically interpolate the new field. The original field on the original + ! pressure levels is provided, and the new pressure surfaces to interpolate to. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type + LOGICAL , INTENT(IN) :: lowest_lev_from_sfc + REAL , INTENT(IN) :: zap_close_levels + INTEGER , INTENT(IN) :: force_sfc_in_vinterp + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + INTEGER , INTENT(IN) :: generic + + CHARACTER (LEN=1) :: var_type + + REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: forig , po + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew + + REAL , DIMENSION(ims:ime,generic,jms:jme) :: porig + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew + + ! Local vars + + INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 + INTEGER :: istart , iend , jstart , jend , kstart , kend + INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below + INTEGER , DIMENSION(ims:ime ) :: ks + INTEGER , DIMENSION(ims:ime ) :: ko_above_sfc + + LOGICAL :: any_below_ground + + REAL :: p1 , p2 , pn +integer vert_extrap +vert_extrap = 0 + + ! Horiontal loop bounds for different variable types. + + IF ( var_type .EQ. 'U' ) THEN + istart = its + iend = ite + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = MAX(ids+1,its) , MIN(ide-1,ite) + porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5 + END DO + END DO + IF ( ids .EQ. its ) THEN + DO k = 1,generic + porig(its,k,j) = po(its,k,j) + END DO + END IF + IF ( ide .EQ. ite ) THEN + DO k = 1,generic + porig(ite,k,j) = po(ite-1,k,j) + END DO + END IF + + DO k = kstart,kend + DO i = MAX(ids+1,its) , MIN(ide-1,ite) + pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5 + END DO + END DO + IF ( ids .EQ. its ) THEN + DO k = kstart,kend + pnew(its,k,j) = pnu(its,k,j) + END DO + END IF + IF ( ide .EQ. ite ) THEN + DO k = kstart,kend + pnew(ite,k,j) = pnu(ite-1,k,j) + END DO + END IF + END DO + ELSE IF ( var_type .EQ. 'V' ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = jte + kstart = kts + kend = kte-1 + DO i = istart,iend + DO k = 1,generic + DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5 + END DO + END DO + IF ( jds .EQ. jts ) THEN + DO k = 1,generic + porig(i,k,jts) = po(i,k,jts) + END DO + END IF + IF ( jde .EQ. jte ) THEN + DO k = 1,generic + porig(i,k,jte) = po(i,k,jte-1) + END DO + END IF + + DO k = kstart,kend + DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5 + END DO + END DO + IF ( jds .EQ. jts ) THEN + DO k = kstart,kend + pnew(i,k,jts) = pnu(i,k,jts) + END DO + END IF + IF ( jde .EQ. jte ) THEN + DO k = kstart,kend + pnew(i,k,jte) = pnu(i,k,jte-1) + END DO + END IF + END DO + ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + ELSE + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart,jend + DO k = 1,generic + DO i = istart,iend + porig(i,k,j) = po(i,k,j) + END DO + END DO + + DO k = kstart,kend + DO i = istart,iend + pnew(i,k,j) = pnu(i,k,j) + END DO + END DO + END DO + END IF + + DO j = jstart , jend + + ! Skip all of the levels below ground in the original data based upon the surface pressure. + ! The ko_above_sfc is the index in the pressure array that is above the surface. If there + ! are no levels underground, this is index = 2. The remaining levels are eligible for use + ! in the vertical interpolation. + + DO i = istart , iend + ko_above_sfc(i) = -1 + END DO + DO ko = kstart+1 , kend + DO i = istart , iend + IF ( ko_above_sfc(i) .EQ. -1 ) THEN + IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN + ko_above_sfc(i) = ko + END IF + END IF + END DO + END DO + + ! Initialize interpolation location. These are the levels in the original pressure + ! data that are physically below and above the targeted new pressure level. + + DO kn = kts , kte + DO i = its , ite + k_above(i,kn) = -1 + k_below(i,kn) = -2 + END DO + END DO + + ! Starting location is no lower than previous found location. This is for O(n logn) + ! and not O(n^2), where n is the number of vertical levels to search. + + DO i = its , ite + ks(i) = 1 + END DO + + ! Find trapping layer for interpolation. The kn index runs through all of the "new" + ! levels of data. + + DO kn = kstart , kend + + DO i = istart , iend + + ! For each "new" level (kn), we search to find the trapping levels in the "orig" + ! data. Most of the time, the "new" levels are the eta surfaces, and the "orig" + ! levels are the input pressure levels. + + found_trap_above : DO ko = ks(i) , generic-1 + + ! Because we can have levels in the interpolation that are not valid, + ! let's toss out any candidate orig pressure values that are below ground + ! based on the surface pressure. If the level =1, then this IS the surface + ! level, so we HAVE to keep that one, but maybe not the ones above. If the + ! level (ks) is NOT=1, then we have to just CYCLE our loop to find a legit + ! below-pressure value. If we are not below ground, then we choose two + ! neighboring levels to test whether they surround the new pressure level. + + ! The input trapping levels that we are trying is the surface and the first valid + ! level above the surface. + + IF ( ( ko .LT. ko_above_sfc(i) ) .AND. ( ko .EQ. 1 ) ) THEN + ko_1 = ko + ko_2 = ko_above_sfc(i) + + ! The "below" level is underground, cycle until we get to a valid pressure + ! above ground. + + ELSE IF ( ( ko .LT. ko_above_sfc(i) ) .AND. ( ko .NE. 1 ) ) THEN + CYCLE found_trap_above + + ! The "below" level is above the surface, so we are in the clear to test these + ! two levels out. + + ELSE + ko_1 = ko + ko_2 = ko+1 + + END IF + + ! The test of the candidate levels: "below" has to have a larger pressure, and + ! "above" has to have a smaller pressure. + + ! OK, we found the correct two surrounding levels. The locations are saved for use in the + ! interpolation. + + IF ( ( porig(i,ko_1,j) .GE. pnew(i,kn,j) ) .AND. & + ( porig(i,ko_2,j) .LT. pnew(i,kn,j) ) ) THEN + k_above(i,kn) = ko_2 + k_below(i,kn) = ko_1 + ks(i) = ko_1 + EXIT found_trap_above + + ! What do we do is we need to extrapolate the data underground? This happens when the + ! lowest pressure that we have is physically "above" the new target pressure. Our + ! actions depend on the type of variable we are interpolating. + + ELSE IF ( porig(i,1,j) .LT. pnew(i,kn,j) ) THEN + + ! For horizontal winds and moisture, we keep a constant value under ground. + + IF ( ( var_type .EQ. 'U' ) .OR. & + ( var_type .EQ. 'V' ) .OR. & + ( var_type .EQ. 'Q' ) ) THEN + k_above(i,kn) = 1 + ks(i) = 1 + + ! For temperature and height, we extrapolate the data. Hopefully, we are not + ! extrapolating too far. For pressure level input, the eta levels are always + ! contained within the surface to p_top levels, so no extrapolation is ever + ! required. + + ELSE IF ( ( var_type .EQ. 'Z' ) .OR. & + ( var_type .EQ. 'T' ) ) THEN + k_above(i,kn) = ko_above_sfc(i) + k_below(i,kn) = 1 + ks(i) = 1 + + ! Just a catch all right now. + + ELSE + k_above(i,kn) = 1 + ks(i) = 1 + END IF + + EXIT found_trap_above + + ! The other extrapolation that might be required is when we are going above the + ! top level of the input data. Usually this means we chose a P_PTOP value that + ! was inappropriate, and we should stop and let someone fix this mess. + + ELSE IF ( porig(i,generic,j) .GT. pnew(i,kn,j) ) THEN + print *,'data is too high, try a lower p_top' + print *,'pnew=',pnew(i,kn,j) + print *,'porig=',porig(i,:,j) + CALL wrf_error_fatal ('requested p_top is higher than input data, lower p_top') + + END IF + END DO found_trap_above + END DO + END DO + + ! Linear vertical interpolation. + + DO kn = kstart , kend + DO i = istart , iend + IF ( k_above(i,kn) .EQ. 1 ) THEN + fnew(i,kn,j) = forig(i,1,j) + ELSE + k2 = MAX ( k_above(i,kn) , 2) + k1 = MAX ( k_below(i,kn) , 1) + IF ( k1 .EQ. k2 ) THEN + CALL wrf_error_fatal ( 'identical values in the interp, bad for divisions' ) + END IF + IF ( interp_type .EQ. 1 ) THEN + p1 = porig(i,k1,j) + p2 = porig(i,k2,j) + pn = pnew(i,kn,j) + ELSE IF ( interp_type .EQ. 2 ) THEN + p1 = ALOG(porig(i,k1,j)) + p2 = ALOG(porig(i,k2,j)) + pn = ALOG(pnew(i,kn,j)) + END IF + IF ( ( p1-pn) * (p2-pn) > 0. ) THEN +! CALL wrf_error_fatal ( 'both trapping pressures are on the same side of the new pressure' ) +! CALL wrf_debug ( 0 , 'both trapping pressures are on the same side of the new pressure' ) +vert_extrap = vert_extrap + 1 + END IF + fnew(i,kn,j) = ( forig(i,k1,j) * ( p2 - pn ) + & + forig(i,k2,j) * ( pn - p1 ) ) / & + ( p2 - p1 ) + END IF + END DO + END DO + + search_below_ground : DO kn = kstart , kend + any_below_ground = .FALSE. + DO i = istart , iend + IF ( k_above(i,kn) .EQ. 1 ) THEN + fnew(i,kn,j) = forig(i,1,j) + any_below_ground = .TRUE. + END IF + END DO + IF ( .NOT. any_below_ground ) THEN + EXIT search_below_ground + END IF + END DO search_below_ground + + ! There may have been a request to have the surface data from the input field + ! to be assigned as to the lowest eta level. This assumes thin layers (usually + ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V). + + DO i = istart , iend + IF ( lowest_lev_from_sfc ) THEN + fnew(i,1,j) = forig(i,ko_above_sfc(i),j) + END IF + END DO + + END DO +print *,'VERT EXTRAP = ', vert_extrap + + END SUBROUTINE vert_interp_old + +!--------------------------------------------------------------------- + + SUBROUTINE lagrange_setup ( var_type , all_x , all_y , all_dim , n , extrap_type , & + target_x , target_y , target_dim ,i,j) + + ! We call a Lagrange polynomial interpolator. The parallel concerns are put off as this + ! is initially set up for vertical use. The purpose is an input column of pressure (all_x), + ! and the associated pressure level data (all_y). These are assumed to be sorted (ascending + ! or descending, no matter). The locations to be interpolated to are the pressures in + ! target_x, probably the new vertical coordinate values. The field that is output is the + ! target_y, which is defined at the target_x location. Mostly we expect to be 2nd order + ! overlapping polynomials, with only a single 2nd order method near the top and bottom. + ! When n=1, this is linear; when n=2, this is a second order interpolator. + + IMPLICIT NONE + + CHARACTER (LEN=1) :: var_type + INTEGER , INTENT(IN) :: all_dim , n , extrap_type , target_dim + REAL, DIMENSION(all_dim) , INTENT(IN) :: all_x , all_y + REAL , DIMENSION(target_dim) , INTENT(IN) :: target_x + REAL , DIMENSION(target_dim) , INTENT(OUT) :: target_y + + ! Brought in for debug purposes, all of the computations are in a single column. + + INTEGER , INTENT(IN) :: i,j + + ! Local vars + + REAL , DIMENSION(n+1) :: x , y + REAL :: target_y_1 , target_y_2 + LOGICAL :: found_loc + INTEGER :: loop , loc_center_left , loc_center_right , ist , iend , target_loop + + ! Local vars for the problem of extrapolating theta below ground. + + REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt + REAL , PARAMETER :: RovCp = 287. / 1004. + REAL , PARAMETER :: CRC_const1 = 11880.516 ! m + REAL , PARAMETER :: CRC_const2 = 0.1902632 ! + REAL , PARAMETER :: CRC_const3 = 0.0065 ! K/km + + IF ( all_dim .LT. n+1 ) THEN +print *,'all_dim = ',all_dim +print *,'order = ',n +print *,'i,j = ',i,j +print *,'p array = ',all_x +print *,'f array = ',all_y +print *,'p target= ',target_x + CALL wrf_error_fatal ( 'troubles, the interpolating order is too large for this few input values' ) + END IF + + IF ( n .LT. 1 ) THEN + CALL wrf_error_fatal ( 'pal, linear is about as low as we go' ) + END IF + + ! Loop over the list of target x and y values. + + DO target_loop = 1 , target_dim + + ! Find the two trapping x values, and keep the indices. + + found_loc = .FALSE. + find_trap : DO loop = 1 , all_dim -1 + IF ( ( target_x(target_loop) - all_x(loop) ) * ( target_x(target_loop) - all_x(loop+1) ) .LE. 0.0 ) THEN + loc_center_left = loop + loc_center_right = loop+1 + found_loc = .TRUE. + EXIT find_trap + END IF + END DO find_trap + + IF ( ( .NOT. found_loc ) .AND. ( target_x(target_loop) .GT. all_x(1) ) ) THEN + + ! Use a constant value below ground. + + IF ( extrap_type .EQ. 1 ) THEN + + target_y(target_loop) = all_y(1) + + ! Wild extrapolation. + + ELSE IF ( extrap_type .EQ. 2 ) THEN + + target_y(target_loop) = ( all_y(1) * ( target_x(target_loop) - all_x(2) ) + & + all_y(2) * ( all_x(1) - target_x(target_loop) ) ) / & + ( all_x(1) - all_x(2) ) + + ! The pressure is most likely coming in as dry pressure, so the computations + ! of temp <==> theta are not perfect, but they are better than the wild + ! extrapolation option above. Basically: get the new temp with a 6.5 K/km + ! lapse rate. + + ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN + + depth_of_extrap_in_p = target_x(target_loop) - all_x(1) + avg_of_extrap_p = ( target_x(target_loop) + all_x(1) ) * 0.5 + temp_extrap_starting_point = all_y(1) * ( all_x(1) / 100000. ) ** RovCp + dhdp = CRC_const1 * CRC_const2 * ( avg_of_extrap_p / 100. ) ** ( CRC_const2 - 1. ) + dh = dhdp * ( depth_of_extrap_in_p / 100. ) + dt = dh * CRC_const3 + target_y(target_loop) = ( temp_extrap_starting_point + dt ) * ( 100000. / target_x(target_loop) ) ** RovCp + + ELSE IF ( extrap_type .EQ. 3 ) THEN + CALL wrf_error_fatal ( 'You are not allowed to use extrap_option #3 for any var except for theta.' ) + + END IF + CYCLE + ELSE IF ( .NOT. found_loc ) THEN + print *,'i,j = ',i,j + print *,'target pressure and value = ',target_x(target_loop),target_y(target_loop) + DO loop = 1 , all_dim + print *,'column of pressure and value = ',all_x(loop),all_y(loop) + END DO + CALL wrf_error_fatal ( 'troubles, could not find trapping x locations' ) + END IF + + ! Even or odd order? We can put the value in the middle if this is + ! an odd order interpolator. For the even guys, we'll do it twice + ! and shift the range one index, then get an average. + + IF ( MOD(n,2) .NE. 0 ) THEN + IF ( ( loc_center_left -(((n+1)/2)-1) .GE. 1 ) .AND. & + ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN + ist = loc_center_left -(((n+1)/2)-1) + iend = ist + n + CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) + ELSE + IF ( .NOT. found_loc ) THEN + CALL wrf_error_fatal ( 'I doubt this will happen, I will only do 2nd order for now' ) + END IF + END IF + + ELSE IF ( MOD(n,2) .EQ. 0 ) THEN + IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. & + ( loc_center_right+(((n )/2) ) .LE. all_dim ) .AND. & + ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. & + ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN + ist = loc_center_left -(((n )/2)-1) + iend = ist + n + CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_1 ) + ist = loc_center_left -(((n )/2) ) + iend = ist + n + CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_2 ) + target_y(target_loop) = ( target_y_1 + target_y_2 ) * 0.5 + + ELSE IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. & + ( loc_center_right+(((n )/2) ) .LE. all_dim ) ) THEN + ist = loc_center_left -(((n )/2)-1) + iend = ist + n + CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) + ELSE IF ( ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. & + ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN + ist = loc_center_left -(((n )/2) ) + iend = ist + n + CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) + ELSE + CALL wrf_error_fatal ( 'unauthorized area, you should not be here' ) + END IF + + END IF + + END DO + + END SUBROUTINE lagrange_setup + +!--------------------------------------------------------------------- + + SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y ) + + ! Interpolation using Lagrange polynomials. + ! P(x) = f(x0)Ln0(x) + ... + f(xn)Lnn(x) + ! where Lnk(x) = (x -x0)(x -x1)...(x -xk-1)(x -xk+1)...(x -xn) + ! --------------------------------------------- + ! (xk-x0)(xk-x1)...(xk-xk-1)(xk-xk+1)...(xk-xn) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: n + REAL , DIMENSION(0:n) , INTENT(IN) :: x , y + REAL , INTENT(IN) :: target_x + + REAL , INTENT(OUT) :: target_y + + ! Local vars + + INTEGER :: i , k + REAL :: numer , denom , Px + REAL , DIMENSION(0:n) :: Ln + + Px = 0. + DO i = 0 , n + numer = 1. + denom = 1. + DO k = 0 , n + IF ( k .EQ. i ) CYCLE + numer = numer * ( target_x - x(k) ) + denom = denom * ( x(i) - x(k) ) + END DO + Ln(i) = y(i) * numer / denom + Px = Px + Ln(i) + END DO + target_y = Px + + END SUBROUTINE lagrange_interp + +#ifndef VERT_UNIT +!--------------------------------------------------------------------- + + SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute reference pressure and the reference mu. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: mu0 + REAL , DIMENSION( kms:kme ) , INTENT(IN) :: eta + REAL :: pdht + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pdry + + ! Local vars + + INTEGER :: i , j , k + REAL , DIMENSION( kms:kme ) :: eta_h + + DO k = kts , kte-1 + eta_h(k) = ( eta(k) + eta(k+1) ) * 0.5 + END DO + + DO j = jts , MIN ( jde-1 , jte ) + DO k = kts , kte-1 + DO i = its , MIN (ide-1 , ite ) + pdry(i,k,j) = eta_h(k) * mu0(i,j) + pdht + END DO + END DO + END DO + + END SUBROUTINE p_dry + +!--------------------------------------------------------------------- + + SUBROUTINE p_dts ( pdts , intq , psfc , p_top , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute difference between the dry, total surface pressure and the top pressure. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , INTENT(IN) :: p_top + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: psfc + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: intq + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: pdts + + ! Local vars + + INTEGER :: i , j , k + + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + pdts(i,j) = psfc(i,j) - intq(i,j) - p_top + END DO + END DO + + END SUBROUTINE p_dts + +!--------------------------------------------------------------------- + + SUBROUTINE p_dhs ( pdhs , ht , p0 , t0 , a , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute dry, hydrostatic surface pressure. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: ht + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: pdhs + + REAL , INTENT(IN) :: p0 , t0 , a + + ! Local vars + + INTEGER :: i , j , k + + REAL , PARAMETER :: Rd = 287. + REAL , PARAMETER :: g = 9.8 + + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + pdhs(i,j) = p0 * EXP ( -t0/a + SQRT ( (t0/a)**2 - 2. * g * ht(i,j)/(a * Rd) ) ) + END DO + END DO + + END SUBROUTINE p_dhs + +!--------------------------------------------------------------------- + + SUBROUTINE find_p_top ( p , p_top , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Find the largest pressure in the top level. This is our p_top. We are + ! assuming that the top level is the location where the pressure is a minimum + ! for each column. In cases where the top surface is not isobaric, a + ! communicated value must be shared in the calling routine. Also in cases + ! where the top surface is not isobaric, care must be taken that the new + ! maximum pressure is not greater than the previous value. This test is + ! also handled in the calling routine. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL :: p_top + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p + + ! Local vars + + INTEGER :: i , j , k, min_lev + + i = its + j = jts + p_top = p(i,2,j) + min_lev = 2 + DO k = 2 , kte + IF ( p_top .GT. p(i,k,j) ) THEN + p_top = p(i,k,j) + min_lev = k + END IF + END DO + + k = min_lev + p_top = p(its,k,jts) + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + p_top = MAX ( p_top , p(i,k,j) ) + END DO + END DO + + END SUBROUTINE find_p_top + +!--------------------------------------------------------------------- + + SUBROUTINE t_to_theta ( t , p , p00 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute dry, hydrostatic surface pressure. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , INTENT(IN) :: p00 + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: t + + ! Local vars + + INTEGER :: i , j , k + + REAL , PARAMETER :: Rd = 287. + REAL , PARAMETER :: Cp = 1004. + + DO j = jts , MIN ( jde-1 , jte ) + DO k = kts , kte + DO i = its , MIN (ide-1 , ite ) + t(i,k,j) = t(i,k,j) * ( p00 / p(i,k,j) ) ** (Rd / Cp) + END DO + END DO + END DO + + END SUBROUTINE t_to_theta + +!--------------------------------------------------------------------- + + SUBROUTINE integ_moist ( q_in , p_in , pd_out , t_in , ght_in , intq , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Integrate the moisture field vertically. Mostly used to get the total + ! vapor pressure, which can be subtracted from the total pressure to get + ! the dry pressure. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: q_in , p_in , t_in , ght_in + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pd_out + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: intq + + ! Local vars + + INTEGER :: i , j , k + INTEGER , DIMENSION(ims:ime) :: level_above_sfc + REAL , DIMENSION(ims:ime,jms:jme) :: psfc , tsfc , qsfc, zsfc + REAL , DIMENSION(ims:ime,kms:kme) :: q , p , t , ght, pd + + REAL :: rhobar , qbar , dz + REAL :: p1 , p2 , t1 , t2 , q1 , q2 , z1, z2 + + LOGICAL :: upside_down + + REAL , PARAMETER :: Rd = 287. + REAL , PARAMETER :: g = 9.8 + + ! Get a surface value, always the first level of a 3d field. + + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + psfc(i,j) = p_in(i,kts,j) + tsfc(i,j) = t_in(i,kts,j) + qsfc(i,j) = q_in(i,kts,j) + zsfc(i,j) = ght_in(i,kts,j) + END DO + END DO + + IF ( p_in(its,kts+1,jts) .LT. p_in(its,kte,jts) ) THEN + upside_down = .TRUE. + ELSE + upside_down = .FALSE. + END IF + + DO j = jts , MIN ( jde-1 , jte ) + + ! Initialize the integrated quantity of moisture to zero. + + DO i = its , MIN (ide-1 , ite ) + intq(i,j) = 0. + END DO + + IF ( upside_down ) THEN + DO i = its , MIN (ide-1 , ite ) + p(i,kts) = p_in(i,kts,j) + t(i,kts) = t_in(i,kts,j) + q(i,kts) = q_in(i,kts,j) + ght(i,kts) = ght_in(i,kts,j) + DO k = kts+1,kte + p(i,k) = p_in(i,kte+2-k,j) + t(i,k) = t_in(i,kte+2-k,j) + q(i,k) = q_in(i,kte+2-k,j) + ght(i,k) = ght_in(i,kte+2-k,j) + END DO + END DO + ELSE + DO i = its , MIN (ide-1 , ite ) + DO k = kts,kte + p(i,k) = p_in(i,k ,j) + t(i,k) = t_in(i,k ,j) + q(i,k) = q_in(i,k ,j) + ght(i,k) = ght_in(i,k ,j) + END DO + END DO + END IF + + ! Find the first level above the ground. If all of the levels are above ground, such as + ! a terrain following lower coordinate, then the first level above ground is index #2. + + DO i = its , MIN (ide-1 , ite ) + level_above_sfc(i) = -1 + IF ( p(i,kts+1) .LT. psfc(i,j) ) THEN + level_above_sfc(i) = kts+1 + ELSE + find_k : DO k = kts+1,kte-1 + IF ( ( p(i,k )-psfc(i,j) .GE. 0. ) .AND. & + ( p(i,k+1)-psfc(i,j) .LT. 0. ) ) THEN + level_above_sfc(i) = k+1 + EXIT find_k + END IF + END DO find_k + IF ( level_above_sfc(i) .EQ. -1 ) THEN +print *,'i,j = ',i,j +print *,'p = ',p(i,:) +print *,'p sfc = ',psfc(i,j) + CALL wrf_error_fatal ( 'Could not find level above ground') + END IF + END IF + END DO + + DO i = its , MIN (ide-1 , ite ) + + ! Account for the moisture above the ground. + + pd(i,kte) = p(i,kte) + DO k = kte-1,level_above_sfc(i),-1 + rhobar = ( p(i,k ) / ( Rd * t(i,k ) ) + & + p(i,k+1) / ( Rd * t(i,k+1) ) ) * 0.5 + qbar = ( q(i,k ) + q(i,k+1) ) * 0.5 + dz = ght(i,k+1) - ght(i,k) + intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz + pd(i,k) = p(i,k) - intq(i,j) + END DO + + ! Account for the moisture between the surface and the first level up. + + IF ( ( p(i,level_above_sfc(i)-1)-psfc(i,j) .GE. 0. ) .AND. & + ( p(i,level_above_sfc(i) )-psfc(i,j) .LT. 0. ) .AND. & + ( level_above_sfc(i) .GT. kts ) ) THEN + p1 = psfc(i,j) + p2 = p(i,level_above_sfc(i)) + t1 = tsfc(i,j) + t2 = t(i,level_above_sfc(i)) + q1 = qsfc(i,j) + q2 = q(i,level_above_sfc(i)) + z1 = zsfc(i,j) + z2 = ght(i,level_above_sfc(i)) + rhobar = ( p1 / ( Rd * t1 ) + & + p2 / ( Rd * t2 ) ) * 0.5 + qbar = ( q1 + q2 ) * 0.5 + dz = z2 - z1 + IF ( dz .GT. 0.1 ) THEN + intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz + END IF + + ! Fix the underground values. + + DO k = level_above_sfc(i)-1,kts+1,-1 + pd(i,k) = p(i,k) - intq(i,j) + END DO + END IF + pd(i,kts) = psfc(i,j) - intq(i,j) + + END DO + + IF ( upside_down ) THEN + DO i = its , MIN (ide-1 , ite ) + pd_out(i,kts,j) = pd(i,kts) + DO k = kts+1,kte + pd_out(i,kte+2-k,j) = pd(i,k) + END DO + END DO + ELSE + DO i = its , MIN (ide-1 , ite ) + DO k = kts,kte + pd_out(i,k,j) = pd(i,k) + END DO + END DO + END IF + + END DO + + END SUBROUTINE integ_moist + +!--------------------------------------------------------------------- + + SUBROUTINE rh_to_mxrat (rh, t, p, q , wrt_liquid , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + LOGICAL , INTENT(IN) :: wrt_liquid + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p , t + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: rh + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: q + + ! Local vars + + INTEGER :: i , j , k + + REAL :: ew , q1 , t1 + + REAL, PARAMETER :: T_REF = 0.0 + REAL, PARAMETER :: MW_AIR = 28.966 + REAL, PARAMETER :: MW_VAP = 18.0152 + + REAL, PARAMETER :: A0 = 6.107799961 + REAL, PARAMETER :: A1 = 4.436518521e-01 + REAL, PARAMETER :: A2 = 1.428945805e-02 + REAL, PARAMETER :: A3 = 2.650648471e-04 + REAL, PARAMETER :: A4 = 3.031240396e-06 + REAL, PARAMETER :: A5 = 2.034080948e-08 + REAL, PARAMETER :: A6 = 6.136820929e-11 + + REAL, PARAMETER :: ES0 = 6.1121 + + REAL, PARAMETER :: C1 = 9.09718 + REAL, PARAMETER :: C2 = 3.56654 + REAL, PARAMETER :: C3 = 0.876793 + REAL, PARAMETER :: EIS = 6.1071 + REAL :: RHS + REAL, PARAMETER :: TF = 273.16 + REAL :: TK + + REAL :: ES + REAL :: QS + REAL, PARAMETER :: EPS = 0.622 + REAL, PARAMETER :: SVP1 = 0.6112 + REAL, PARAMETER :: SVP2 = 17.67 + REAL, PARAMETER :: SVP3 = 29.65 + REAL, PARAMETER :: SVPT0 = 273.15 + + ! This subroutine computes mixing ratio (q, kg/kg) from basic variables + ! pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%). + ! The reference temperature (t_ref, C) is used to describe the temperature + ! at which the liquid and ice phase change occurs. + + DO j = jts , MIN ( jde-1 , jte ) + DO k = kts , kte + DO i = its , MIN (ide-1 , ite ) + rh(i,k,j) = MIN ( MAX ( rh(i,k,j) , 1. ) , 100. ) + END DO + END DO + END DO + + IF ( wrt_liquid ) THEN + DO j = jts , MIN ( jde-1 , jte ) + DO k = kts , kte + DO i = its , MIN (ide-1 , ite ) + es=svp1*10.*EXP(svp2*(t(i,k,j)-svpt0)/(t(i,k,j)-svp3)) + qs=eps*es/(p(i,k,j)/100.-es) + q(i,k,j)=MAX(.01*rh(i,k,j)*qs,0.0) + END DO + END DO + END DO + + ELSE + DO j = jts , MIN ( jde-1 , jte ) + DO k = kts , kte + DO i = its , MIN (ide-1 , ite ) + + t1 = t(i,k,j) - 273.16 + + ! Obviously dry. + + IF ( t1 .lt. -200. ) THEN + q(i,k,j) = 0 + + ELSE + + ! First compute the ambient vapor pressure of water + + IF ( ( t1 .GE. t_ref ) .AND. ( t1 .GE. -47.) ) THEN ! liq phase ESLO + ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6))))) + + ELSE IF ( ( t1 .GE. t_ref ) .AND. ( t1 .LT. -47. ) ) then !liq phas poor ES + ew = es0 * exp(17.67 * t1 / ( t1 + 243.5)) + + ELSE + tk = t(i,k,j) + rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) + & + c3 * (1. - tk / tf) + alog10(eis) + ew = 10. ** rhs + + END IF + + ! Now sat vap pres obtained compute local vapor pressure + + ew = MAX ( ew , 0. ) * rh(i,k,j) * 0.01 + + ! Now compute the specific humidity using the partial vapor + ! pressures of water vapor (ew) and dry air (p-ew). The + ! constants assume that the pressure is in hPa, so we divide + ! the pressures by 100. + + q1 = mw_vap * ew + q1 = q1 / (q1 + mw_air * (p(i,k,j)/100. - ew)) + + q(i,k,j) = q1 / (1. - q1 ) + + END IF + + END DO + END DO + END DO + + END IF + + END SUBROUTINE rh_to_mxrat + +!--------------------------------------------------------------------- + + SUBROUTINE compute_eta ( znw , & + eta_levels , max_eta , max_dz , & + p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute eta levels, either using given values from the namelist (hardly + ! a computation, yep, I know), or assuming a constant dz above the PBL, + ! knowing p_top and the number of eta levels. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + REAL , INTENT(IN) :: max_dz + REAL , INTENT(IN) :: p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 + INTEGER , INTENT(IN) :: max_eta + REAL , DIMENSION (max_eta) , INTENT(IN) :: eta_levels + + REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw + + ! Local vars + + INTEGER :: k + REAL :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp + REAL , DIMENSION(kts:kte) :: dnw + + INTEGER , PARAMETER :: prac_levels = 17 + INTEGER :: loop , loop1 + REAL , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac + REAL , DIMENSION(kts:kte) :: alb , phb + + ! Gee, do the eta levels come in from the namelist? + + IF ( ABS(eta_levels(1)+1.) .GT. 0.0000001 ) THEN + + IF ( ( ABS(eta_levels(1 )-1.) .LT. 0.0000001 ) .AND. & + ( ABS(eta_levels(kde)-0.) .LT. 0.0000001 ) ) THEN + DO k = kds+1 , kde-1 + znw(k) = eta_levels(k) + END DO + znw( 1) = 1. + znw(kde) = 0. + ELSE + CALL wrf_error_fatal ( 'First eta level should be 1.0 and the last 0.0 in namelist' ) + END IF + + ! Compute eta levels assuming a constant delta z above the PBL. + + ELSE + + ! Compute top of the atmosphere with some silly levels. We just want to + ! integrate to get a reasonable value for ztop. We use the planned PBL-esque + ! levels, and then just coarse resolution above that. We know p_top, and we + ! have the base state vars. + + p_surf = p00 + + znw_prac = (/ 1.000 , 0.993 , 0.983 , 0.970 , 0.954 , 0.934 , 0.909 , & + 0.88 , 0.8 , 0.7 , 0.6 , 0.5 , 0.4 , 0.3 , 0.2 , 0.1 , 0.0 /) + + DO k = 1 , prac_levels - 1 + znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5 + dnw_prac(k) = znw_prac(k+1) - znw_prac(k) + END DO + + DO k = 1, prac_levels-1 + pb = znu_prac(k)*(p_surf - p_top) + p_top +! temp = MAX ( 200., t00 + A*LOG(pb/p00) ) + temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + END DO + + ! Base state mu is defined as base state surface pressure minus p_top + + mub = p_surf - p_top + + ! Integrate base geopotential, starting at terrain elevation. + + phb(1) = 0. + DO k = 2,prac_levels + phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1) + END DO + + ! So, now we know the model top in meters. Get the average depth above the PBL + ! of each of the remaining levels. We are going for a constant delta z thickness. + + ztop = phb(prac_levels) / g + ztop_pbl = phb(8 ) / g + dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 ) + + ! Standard levels near the surface so no one gets in trouble. + + DO k = 1 , 8 + znw(k) = znw_prac(k) + END DO + + ! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9 + ! Skamarock et al, NCAR TN 468. Use full levels, so + ! use twice the thickness. + + DO k = 8, kte-1 + pb = znw(k) * (p_surf - p_top) + p_top +! temp = MAX ( 200., t00 + A*LOG(pb/p00) ) + temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) + END DO + znw(kte) = 0.000 + + ! There is some iteration. We want the top level, ztop, to be + ! consistent with the delta z, and we want the half level values + ! to be consistent with the eta levels. The inner loop to 10 gets + ! the eta levels very accurately, but has a residual at the top, due + ! to dz changing. We reset dz five times, and then things seem OK. + + DO loop1 = 1 , 5 + DO loop = 1 , 10 + DO k = 8, kte-1 + pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top +! temp = MAX ( 200., t00 + A*LOG(pb/p00) ) + temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) + END DO + IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN + print *,'Converged znw(kte) should be 0.0 = ',znw(kte) + END IF + znw(kte) = 0.000 + END DO + + ! Here is where we check the eta levels values we just computed. + + DO k = 1, kde-1 + pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top +! temp = MAX ( 200., t00 + A*LOG(pb/p00) ) + temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + END DO + + phb(1) = 0. + DO k = 2,kde + phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) + END DO + + ! Reset the model top and the dz, and iterate. + + ztop = phb(kde)/g + ztop_pbl = phb(8)/g + dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 ) + END DO + + IF ( dz .GT. max_dz ) THEN +print *,'z (m) = ',phb(1)/g +do k = 2 ,kte +print *,'z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g +end do +print *,'dz (m) above fixed eta levels = ',dz +print *,'namelist max_dz (m) = ',max_dz +print *,'namelist p_top (Pa) = ',p_top + CALL wrf_debug ( 0, 'You need one of three things:' ) + CALL wrf_debug ( 0, '1) More eta levels to reduce the dz: e_vert' ) + CALL wrf_debug ( 0, '2) A lower p_top so your total height is reduced: p_top_requested') + CALL wrf_debug ( 0, '3) Increase the maximum allowable eta thickness: max_dz') + CALL wrf_debug ( 0, 'All are namelist options') + CALL wrf_error_fatal ( 'dz above fixed eta levels is too large') + END IF + + END IF + + END SUBROUTINE compute_eta + +!--------------------------------------------------------------------- + + SUBROUTINE monthly_min_max ( field_in , field_min , field_max , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Plow through each month, find the max, min values for each i,j. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_min , field_max + + ! Local vars + + INTEGER :: i , j , l + REAL :: minner , maxxer + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + minner = field_in(i,1,j) + maxxer = field_in(i,1,j) + DO l = 2 , 12 + IF ( field_in(i,l,j) .LT. minner ) THEN + minner = field_in(i,l,j) + END IF + IF ( field_in(i,l,j) .GT. maxxer ) THEN + maxxer = field_in(i,l,j) + END IF + END DO + field_min(i,j) = minner + field_max(i,j) = maxxer + END DO + END DO + + END SUBROUTINE monthly_min_max + +!--------------------------------------------------------------------- + + SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Linrarly in time interpolate data to a current valid time. The data is + ! assumed to come in "monthly", valid at the 15th of every month. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + CHARACTER (LEN=24) , INTENT(IN) :: date_str + REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out + + ! Local vars + + INTEGER :: i , j , l + INTEGER , DIMENSION(0:13) :: middle + INTEGER :: target_julyr , target_julday , target_date + INTEGER :: julyr , julday , int_month , month1 , month2 + REAL :: gmt + CHARACTER (LEN=4) :: yr + CHARACTER (LEN=2) :: mon , day15 + + + WRITE(day15,FMT='(I2.2)') 15 + DO l = 1 , 12 + WRITE(mon,FMT='(I2.2)') l + CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt ) + middle(l) = julyr*1000 + julday + END DO + + l = 0 + middle(l) = middle( 1) - 31 + + l = 13 + middle(l) = middle(12) + 31 + + CALL get_julgmt ( date_str , target_julyr , target_julday , gmt ) + target_date = target_julyr * 1000 + target_julday + find_month : DO l = 0 , 12 + IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + int_month = l + IF ( ( int_month .EQ. 0 ) .OR. ( int_month .EQ. 12 ) ) THEN + month1 = 12 + month2 = 1 + ELSE + month1 = int_month + month2 = month1 + 1 + END IF + field_out(i,j) = ( field_in(i,month2,j) * ( target_date - middle(l) ) + & + field_in(i,month1,j) * ( middle(l+1) - target_date ) ) / & + ( middle(l+1) - middle(l) ) + END DO + END DO + EXIT find_month + END IF + END DO find_month + + END SUBROUTINE monthly_interp_to_date + +!--------------------------------------------------------------------- + + SUBROUTINE sfcprs (t, q, height, pslv, ter, avgsfct, p, & + psfc, ez_method, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + + ! Computes the surface pressure using the input height, + ! temperature and q (already computed from relative + ! humidity) on p surfaces. Sea level pressure is used + ! to extrapolate a first guess. + + IMPLICIT NONE + + REAL, PARAMETER :: g = 9.8 + REAL, PARAMETER :: gamma = 6.5E-3 + REAL, PARAMETER :: pconst = 10000.0 + REAL, PARAMETER :: Rd = 287. + REAL, PARAMETER :: TC = 273.15 + 17.5 + + REAL, PARAMETER :: gammarg = gamma * Rd / g + REAL, PARAMETER :: rov2 = Rd / 2. + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + LOGICAL , INTENT ( IN ) :: ez_method + + REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p + REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: pslv , ter, avgsfct + REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc + + INTEGER :: i + INTEGER :: j + INTEGER :: k + INTEGER , DIMENSION (its:ite,jts:jte) :: k500 , k700 , k850 + + LOGICAL :: l1 + LOGICAL :: l2 + LOGICAL :: l3 + LOGICAL :: OK + + REAL :: gamma78 ( its:ite,jts:jte ) + REAL :: gamma57 ( its:ite,jts:jte ) + REAL :: ht ( its:ite,jts:jte ) + REAL :: p1 ( its:ite,jts:jte ) + REAL :: t1 ( its:ite,jts:jte ) + REAL :: t500 ( its:ite,jts:jte ) + REAL :: t700 ( its:ite,jts:jte ) + REAL :: t850 ( its:ite,jts:jte ) + REAL :: tfixed ( its:ite,jts:jte ) + REAL :: tsfc ( its:ite,jts:jte ) + REAL :: tslv ( its:ite,jts:jte ) + + ! We either compute the surface pressure from a time averaged surface temperature + ! (what we will call the "easy way"), or we try to remove the diurnal impact on the + ! surface temperature (what we will call the "other way"). Both are essentially + ! corrections to a sea level pressure with a high-resolution topography field. + + IF ( ez_method ) THEN + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / avgsfct(i,j) ) ** ( - g / ( Rd * gamma ) ) + END DO + END DO + + ELSE + + ! Find the locations of the 850, 700 and 500 mb levels. + + k850 = 0 ! find k at: P=850 + k700 = 0 ! P=700 + k500 = 0 ! P=500 + + i = its + j = jts + DO k = kts+1 , kte + IF (NINT(p(i,k,j)) .EQ. 85000) THEN + k850(i,j) = k + ELSE IF (NINT(p(i,k,j)) .EQ. 70000) THEN + k700(i,j) = k + ELSE IF (NINT(p(i,k,j)) .EQ. 50000) THEN + k500(i,j) = k + END IF + END DO + + IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / t(i,1,j) ) ** ( - g / ( Rd * gamma ) ) + END DO + END DO + + RETURN +#if 0 + + ! Possibly it is just that we have a generalized vertical coord, so we do not + ! have the values exactly. Do a simple assignment to a close vertical level. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + DO k = kts+1 , kte-1 + IF ( ( p(i,k,j) - 85000. ) * ( p(i,k+1,j) - 85000. ) .LE. 0.0 ) THEN + k850(i,j) = k + END IF + IF ( ( p(i,k,j) - 70000. ) * ( p(i,k+1,j) - 70000. ) .LE. 0.0 ) THEN + k700(i,j) = k + END IF + IF ( ( p(i,k,j) - 50000. ) * ( p(i,k+1,j) - 50000. ) .LE. 0.0 ) THEN + k500(i,j) = k + END IF + END DO + END DO + END DO + + ! If we *still* do not have the k levels, punt. I mean, we did try. + + OK = .TRUE. + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN + OK = .FALSE. + PRINT '(A)','(i,j) = ',i,j,' Error in finding p level for 850, 700 or 500 hPa.' + DO K = kts+1 , kte + PRINT '(A,I3,A,F10.2,A)','K = ',k,' PRESSURE = ',p(i,k,j),' Pa' + END DO + PRINT '(A)','Expected 850, 700, and 500 mb values, at least.' + END IF + END DO + END DO + IF ( .NOT. OK ) THEN + CALL wrf_error_fatal ( 'wrong pressure levels' ) + END IF +#endif + + ! We are here if the data is isobaric and we found the levels for 850, 700, + ! and 500 mb right off the bat. + + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + k850(i,j) = k850(its,jts) + k700(i,j) = k700(its,jts) + k500(i,j) = k500(its,jts) + END DO + END DO + END IF + + ! The 850 hPa level of geopotential height is called something special. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + ht(i,j) = height(i,k850(i,j),j) + END DO + END DO + + ! The variable ht is now -ter/ht(850 hPa). The plot thickens. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + ht(i,j) = -ter(i,j) / ht(i,j) + END DO + END DO + + ! Make an isothermal assumption to get a first guess at the surface + ! pressure. This is to tell us which levels to use for the lapse + ! rates in a bit. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + psfc(i,j) = pslv(i,j) * (pslv(i,j) / p(i,k850(i,j),j)) ** ht(i,j) + END DO + END DO + + ! Get a pressure more than pconst Pa above the surface - p1. The + ! p1 is the top of the level that we will use for our lapse rate + ! computations. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN + p1(i,j) = 85000. + ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0. ) THEN + p1(i,j) = psfc(i,j) - pconst + ELSE + p1(i,j) = 50000. + END IF + END DO + END DO + + ! Compute virtual temperatures for k850, k700, and k500 layers. Now + ! you see why we wanted Q on pressure levels, it all is beginning + ! to make sense. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + t850(i,j) = t(i,k850(i,j),j) * (1. + 0.608 * q(i,k850(i,j),j)) + t700(i,j) = t(i,k700(i,j),j) * (1. + 0.608 * q(i,k700(i,j),j)) + t500(i,j) = t(i,k500(i,j),j) * (1. + 0.608 * q(i,k500(i,j),j)) + END DO + END DO + + ! Compute lapse rates between these three levels. These are + ! environmental values for each (i,j). + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + gamma78(i,j) = ALOG(t850(i,j) / t700(i,j)) / ALOG (p(i,k850(i,j),j) / p(i,k700(i,j),j) ) + gamma57(i,j) = ALOG(t700(i,j) / t500(i,j)) / ALOG (p(i,k700(i,j),j) / p(i,k500(i,j),j) ) + END DO + END DO + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN + t1(i,j) = t850(i,j) + ELSE IF ( ( psfc(i,j) - 85000. ) .GE. 0. ) THEN + t1(i,j) = t700(i,j) * (p1(i,j) / (p(i,k700(i,j),j))) ** gamma78(i,j) + ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0.) THEN + t1(i,j) = t500(i,j) * (p1(i,j) / (p(i,k500(i,j),j))) ** gamma57(i,j) + ELSE + t1(i,j) = t500(i,j) + ENDIF + END DO + END DO + + ! From our temperature way up in the air, we extrapolate down to + ! the sea level to get a guess at the sea level temperature. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslv(i,j) = t1(i,j) * (pslv(i,j) / p1(i,j)) ** gammarg + END DO + END DO + + ! The new surface temperature is computed from the with new sea level + ! temperature, just using the elevation and a lapse rate. This lapse + ! rate is -6.5 K/km. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tsfc(i,j) = tslv(i,j) - gamma * ter(i,j) + END DO + END DO + + ! A small correction to the sea-level temperature, in case it is too warm. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tfixed(i,j) = tc - 0.005 * (tsfc(i,j) - tc) ** 2 + END DO + END DO + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + l1 = tslv(i,j) .LT. tc + l2 = tsfc(i,j) .LE. tc + l3 = .NOT. l1 + IF ( l2 .AND. l3 ) THEN + tslv(i,j) = tc + ELSE IF ( ( .NOT. l2 ) .AND. l3 ) THEN + tslv(i,j) = tfixed(i,j) + END IF + END DO + END DO + + ! Finally, we can get to the surface pressure. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + p1(i,j) = - ter(i,j) * g / ( rov2 * ( tsfc(i,j) + tslv(i,j) ) ) + psfc(i,j) = pslv(i,j) * EXP ( p1(i,j) ) + END DO + END DO + + END IF + + ! Surface pressure and sea-level pressure are the same at sea level. + +! DO j = jts , MIN(jde-1,jte) +! DO i = its , MIN(ide-1,ite) +! IF ( ABS ( ter(i,j) ) .LT. 0.1 ) THEN +! psfc(i,j) = pslv(i,j) +! END IF +! END DO +! END DO + + END SUBROUTINE sfcprs + +!--------------------------------------------------------------------- + + SUBROUTINE sfcprs2(t, q, height, psfc_in, ter, avgsfct, p, & + psfc, ez_method, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + + ! Computes the surface pressure using the input height, + ! temperature and q (already computed from relative + ! humidity) on p surfaces. Sea level pressure is used + ! to extrapolate a first guess. + + IMPLICIT NONE + + REAL, PARAMETER :: g = 9.8 + REAL, PARAMETER :: Rd = 287. + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + LOGICAL , INTENT ( IN ) :: ez_method + + REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p + REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: psfc_in , ter, avgsfct + REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc + + INTEGER :: i + INTEGER :: j + INTEGER :: k + + REAL :: tv_sfc_avg , tv_sfc , del_z + + ! Compute the new surface pressure from the old surface pressure, and a + ! known change in elevation at the surface. + + ! del_z = diff in surface topo, lo-res vs hi-res + ! psfc = psfc_in * exp ( g del_z / (Rd Tv_sfc ) ) + + + IF ( ez_method ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tv_sfc_avg = avgsfct(i,j) * (1. + 0.608 * q(i,1,j)) + del_z = height(i,1,j) - ter(i,j) + psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc_avg ) ) + END DO + END DO + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tv_sfc = t(i,1,j) * (1. + 0.608 * q(i,1,j)) + del_z = height(i,1,j) - ter(i,j) + psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc ) ) + END DO + END DO + END IF + + END SUBROUTINE sfcprs2 + +!--------------------------------------------------------------------- + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +END MODULE module_initialize +#endif diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F new file mode 100644 index 00000000..cf0d8513 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F @@ -0,0 +1,772 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. +! NOTE: Modified to remove all but arrays of rank 4 or more from the +! argument list. Arrays with rank>3 are still problematic due to the +! above-noted fie- and pox-ities. TBH 20061129. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 3. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = jde/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' getting dry sounding for base state ' + dry_sounding = .true. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface + grid%em_phb(i,1,j) = 0. + grid%em_php(i,1,j) = 0. + grid%em_ph0(i,1,j) = 0. + grid%ht(i,j) = 0. + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + if((i==2) .and. (j==2)) then + write(6,*) ' grid%em_ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + + ENDDO + ENDDO + +!#if 0 + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) +! yrad = config_flags%dy*float(j-nyc)/4000. + yrad = 0. + DO I = its, min(ide-1,ite) + xrad = config_flags%dx*float(i-nxc)/4000. +! xrad = 0. + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-1500.)/1500. + RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + grid%em_t_1(i,k,j)=grid%em_t_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + grid%em_t_2(i,k,j)=grid%em_t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, alp, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=1000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F new file mode 100644 index 00000000..6971bdf3 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F @@ -0,0 +1,769 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. 1 & + .or. dyn_opt .eq. 2 & + .or. dyn_opt .eq. 3 & + ) THEN + CALL init_domain_rk( grid & +! +#include +! + ) + + ELSE + WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + ! Local data + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: hm + REAL :: pi + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 3. +! z_scale = .50 + z_scale = .40 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = (jde-jds)/2 + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + CALL nl_set_mminlu(1, ' ') + CALL nl_set_iswater(1,0) + CALL nl_set_cen_lat(1,40.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_map_proj(1,0) + + +! here we initialize data we currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%f(i,j) = 0. + + END DO + END DO + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%em_ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde + grid%em_znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & + (1.-exp(-1./z_scale)) + ENDDO + ELSE + DO k=1, kde + grid%em_znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%em_dnw(k) = grid%em_znw(k+1) - grid%em_znw(k) + grid%em_rdnw(k) = 1./grid%em_dnw(k) + grid%em_znu(k) = 0.5*(grid%em_znw(k+1)+grid%em_znw(k)) + ENDDO + DO k=2, kde-1 + grid%em_dn(k) = 0.5*(grid%em_dnw(k)+grid%em_dnw(k-1)) + grid%em_rdn(k) = 1./grid%em_dn(k) + grid%em_fnp(k) = .5* grid%em_dnw(k )/grid%em_dn(k) + grid%em_fnm(k) = .5* grid%em_dnw(k-1)/grid%em_dn(k) + ENDDO + + cof1 = (2.*grid%em_dn(2)+grid%em_dn(3))/(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(2) + cof2 = grid%em_dn(2) /(grid%em_dn(2)+grid%em_dn(3))*grid%em_dnw(1)/grid%em_dn(3) + grid%cf1 = grid%em_fnp(2) + cof1 + grid%cf2 = grid%em_fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%em_dnw(kde-1)+grid%em_dn(kde-1))/grid%em_dn(kde-1) + grid%cfn1 = -.5*grid%em_dnw(kde-1)/grid%em_dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' getting dry sounding for base state ' + dry_sounding = .true. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface + grid%em_phb(i,1,j) = 0. + grid%em_php(i,1,j) = 0. + grid%em_ph0(i,1,j) = 0. + grid%ht(i,j) = 0. + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + grid%em_mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%em_p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_pb(i,k,j) = p_level + grid%em_t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%em_mub(1,1), p_surf is ',grid%em_mub(1,1),grid%em_mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%em_phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%em_mu_1(i,j) = pd_surf-grid%p_top - grid%em_mub(i,j) + grid%em_mu_2(i,j) = grid%em_mu_1(i,j) + grid%em_mu0(i,j) = grid%em_mu_1(i,j) + grid%em_mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%em_znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%em_t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%em_t_2(i,k,j) = grid%em_t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%em_p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%em_p(i,k,j) = - 0.5*grid%em_mu_1(i,j)/grid%em_rdnw(k) + grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%em_al (inverse density) +! is computed from the geopotential. + + + grid%em_ph_1(i,1,j) = 0. + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + if((i==2) .and. (j==2)) then + write(6,*) ' grid%em_ph_1 calc ',grid%em_ph_1(2,1,2),grid%em_ph_1(2,2,2),& + grid%em_mu_1(2,2)+grid%em_mub(2,2),grid%em_mu_1(2,2), & + grid%em_alb(2,1,2),grid%em_al(1,2,1),grid%em_rdnw(1) + endif + + ENDDO + ENDDO + +!#if 0 + +! thermal perturbation to kick off convection + + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) + yrad = config_flags%dy*float(j-nyc)/4000. +! yrad = 0. + DO I = its, min(ide-1,ite) +! xrad = config_flags%dx*float(i-nxc)/4000. + xrad = 0. + DO K = 1, kte-1 + +! put in preturbation theta (bubble) and recalc density. note, +! the mass in the column is not changing, so when theta changes, +! we recompute density and geopotential + + zrad = 0.5*(grid%em_ph_1(i,k,j)+grid%em_ph_1(i,k+1,j) & + +grid%em_phb(i,k,j)+grid%em_phb(i,k+1,j))/g + zrad = (zrad-1500.)/1500. + RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad) + IF(RAD <= 1.) THEN + grid%em_t_1(i,k,j)=grid%em_t_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + grid%em_t_2(i,k,j)=grid%em_t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* & + (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm) + grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j) + ENDIF + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%em_ph_1(i,k,j) = grid%em_ph_1(i,k-1,j) - (1./grid%em_rdnw(k-1))*( & + (grid%em_mub(i,j)+grid%em_mu_1(i,j))*grid%em_al(i,k-1,j)+ & + grid%em_mu_1(i,j)*grid%em_alb(i,k-1,j) ) + + grid%em_ph_2(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_ph0(i,k,j) = grid%em_ph_1(i,k,j) + grid%em_phb(i,k,j) + ENDDO + + ENDDO + ENDDO + +!#endif + + write(6,*) ' grid%em_mu_1 from comp ', grid%em_mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%em_p, grid%em_al, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1)+grid%em_phb(1,k,1), & + grid%em_p(1,k,1)+grid%em_pb(1,k,1), grid%em_alt(1,k,1), & + grid%em_t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%em_ph_1, pp, alp, grid%em_t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%em_ph_1(1,k,1), & + grid%em_p(1,k,1), grid%em_al(1,k,1), & + grid%em_t_1(1,k,1), moist(1,k,1,P_QV) + enddo + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%em_phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%em_phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i,1,j-1))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%em_v_2(i,k,j) = grid%em_v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%em_phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%em_phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%em_phb(i,1,j)+grid%em_phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte + p_level = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%em_u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%em_u_2(i,k,j) = grid%em_u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%em_w_1(i,k,j) = 0. + grid%em_w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%em_t_base(k) = grid%em_t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%em_u_1(1,k,1) + grid%v_base(k) = grid%em_v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%em_phb(1,k,1)+grid%em_phb(1,k+1,1)+grid%em_ph_1(1,k,1)+grid%em_ph_1(1,k+1,1))/g + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + thtmp = grid%em_t_2(i,1,j)+t0 + ptmp = grid%em_p(i,1,j)+grid%em_pb(i,1,j) + temp(1) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,2,j)+t0 + ptmp = grid%em_p(i,2,j)+grid%em_pb(i,2,j) + temp(2) = thtmp * (ptmp/p1000mb)**rcp + thtmp = grid%em_t_2(i,3,j)+t0 + ptmp = grid%em_p(i,3,j)+grid%em_pb(i,3,j) + temp(3) = thtmp * (ptmp/p1000mb)**rcp + + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) + grid%tmn(I,J)=grid%tsk(I,J)-0.5 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=1000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real p1000mb,cv,cp,r,cvpm,g + parameter (p1000mb = 1.e+05, r = 287, cp = 1003., cv = cp-r, cvpm = -cv/cp, g=9.81 ) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl + + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize diff --git a/wrfv2_fire/dyn_em/module_small_step_em.F b/wrfv2_fire/dyn_em/module_small_step_em.F new file mode 100644 index 00000000..07fd2951 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_small_step_em.F @@ -0,0 +1,1639 @@ +!WRF:MODEL_LAYER:DYNAMICS +! + +! SMALL_STEP code for the geometric height coordinate model +! +!--------------------------------------------------------------------------- + +MODULE module_small_step_em + + USE module_configure + USE module_model_constants + +CONTAINS + +!---------------------------------------------------------------------- + +SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & + t_1, t_2, ph_1, ph_2, & + mub, mu_1, mu_2, & + muu, muus, muv, muvs, & + mut, muts, mudf, & + u_save, v_save, w_save, & + t_save, ph_save, mu_save, & + ww, ww_save, & + dnw, c2a, pb, p, alt, & + msfu, msfv, msft, & + rk_step, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE ! religion first + +! declarations for the stuff coming in + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: rk_step + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: u_1, & + v_1, & + w_1, & + t_1, & + ph_1 + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT( OUT) :: u_save, & + v_save, & + w_save, & + t_save, & + ph_save + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: u_2, & + v_2, & + w_2, & + t_2, & + ph_2 + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT( OUT) :: c2a, & + ww_save + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: pb, & + p, & + alt, & + ww + +! pjj/cray +! REAL, DIMENSION(ims:ime, jms:jme) , INTENT(INOUT) :: mu_1 + REAL, DIMENSION(ims:ime, jms:jme) , INTENT(INOUT) :: mu_1,mu_2 + + REAL, DIMENSION(ims:ime, jms:jme) , INTENT(INout) :: mub, & + muu, & + muv, & + mut, & + msfu, & + msfv, & + msft + + REAL, DIMENSION(ims:ime, jms:jme) , INTENT( OUT) :: muus, & + muvs, & + muts, & +!pjj/cray +! mu_2, & + mudf + + REAL, DIMENSION(ims:ime, jms:jme) , INTENT( OUT) :: mu_save + + REAL, DIMENSION(kms:kme, jms:jme) , INTENT(IN ) :: dnw + +! local variables + + INTEGER :: i, j, k + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i_endu, j_endv + + +! +! +! small_step_prep prepares the prognostic variables for the small timestep. +! This includes switching time-levels in the arrays and computing coupled +! perturbation variables for the small timestep +! (i.e. mu*u" = mu(t)*u(t)-mu(*)*u(*); mu*u" is advanced during the small +! timesteps +! +! + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = min(kte,kde-1) + + i_endu = i_end + j_endv = j_end + + IF(i_end == ide) i_end = i_end - 1 + IF(j_end == jde) j_end = j_end - 1 + + ! if this is the first RK step, reset *_1 to *_2 + ! (we are replacing the t-dt fields with the time t fields) + + IF ((rk_step == 1) ) THEN + +! 1 jun 2001 -> added boundary copy to 2D boundary condition routines, +! should be OK now without the following data copy +!#if 0 +! DO j=j_start, j_end +! mu_2(0,j)=mu_2(1,j) +! mu_2(i_endu,j)=mu_2(i_end,j) +! mu_1(0,j)=mu_2(1,j) +! mu_1(i_endu,j)=mu_2(i_end,j) +! mub(0,j)=mub(1,j) +! mub(i_endu,j)=mub(i_end,j) +! ENDDO +! DO i=i_start, i_end +! mu_2(i,0)=mu_2(i,1) +! mu_2(i,j_endv)=mu_2(i,j_end) +! mu_1(i,0)=mu_2(i,1) +! mu_1(i,j_endv)=mu_2(i,j_end) +! mub(i,0)=mub(i,1) +! mub(i,j_endv)=mub(i,j_end) +! ENDDO +!#endif + + DO j=j_start, j_end + DO i=i_start, i_end + mu_1(i,j)=mu_2(i,j) + ww_save(i,kde,j) = 0. + ww_save(i,1,j) = 0. + mudf(i,j) = 0. ! initialize external mode div damp to zero + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_endu + u_1(i,k,j) = u_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_endv + DO k=k_start, k_end + DO i=i_start, i_end + v_1(i,k,j) = v_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + t_1(i,k,j) = t_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, min(kde,kte) + DO i=i_start, i_end + w_1(i,k,j) = w_2(i,k,j) + ph_1(i,k,j) = ph_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO i=i_start, i_end + muts(i,j)=mub(i,j)+mu_2(i,j) + ENDDO + DO i=i_start, i_endu +! rk_step==1, WCS fix for tiling +! muus(i,j)=0.5*(mub(i,j)+mu_2(i,j)+mub(i-1,j)+mu_2(i-1,j)) + muus(i,j) = muu(i,j) + ENDDO + ENDDO + + DO j=j_start, j_endv + DO i=i_start, i_end +! rk_step==1, WCS fix for tiling +! muvs(i,j)=0.5*(mub(i,j)+mu_2(i,j)+mub(i,j-1)+mu_2(i,j-1)) + muvs(i,j) = muv(i,j) + ENDDO + ENDDO + + DO j=j_start, j_end + DO i=i_start, i_end + mu_save(i,j)=mu_2(i,j) + mu_2(i,j)=mu_2(i,j)-mu_2(i,j) + ENDDO + ENDDO + + ELSE + + DO j=j_start, j_end + DO i=i_start, i_end + muts(i,j)=mub(i,j)+mu_1(i,j) + ENDDO + DO i=i_start, i_endu + muus(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i-1,j)+mu_1(i-1,j)) + ENDDO + ENDDO + + DO j=j_start, j_endv + DO i=i_start, i_end + muvs(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i,j-1)+mu_1(i,j-1)) + ENDDO + ENDDO + + DO j=j_start, j_end + DO i=i_start, i_end + mu_save(i,j)=mu_2(i,j) + mu_2(i,j)=mu_1(i,j)-mu_2(i,j) + ENDDO + ENDDO + + + END IF + + ! set up the small timestep variables + + DO j=j_start, j_end + DO i=i_start, i_end + ww_save(i,kde,j) = 0. + ww_save(i,1,j) = 0. + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + c2a(i,k,j) = cpovcv*(pb(i,k,j)+p(i,k,j))/alt(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_endu + u_save(i,k,j) = u_2(i,k,j) + u_2(i,k,j) = (muus(i,j)*u_1(i,k,j)-muu(i,j)*u_2(i,k,j))/msfu(i,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_endv + DO k=k_start, k_end + DO i=i_start, i_end + v_save(i,k,j) = v_2(i,k,j) + v_2(i,k,j) = (muvs(i,j)*v_1(i,k,j)-muv(i,j)*v_2(i,k,j))/msfv(i,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + t_save(i,k,j) = t_2(i,k,j) + t_2(i,k,j) = muts(i,j)*t_1(i,k,j)-mut(i,j)*t_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end +! DO k=k_start, min(kde,kte) + DO k=k_start, kde + DO i=i_start, i_end + w_save(i,k,j) = w_2(i,k,j) + w_2(i,k,j) = (muts(i,j)* w_1(i,k,j)-mut(i,j)* w_2(i,k,j))/msft(i,j) + ph_save(i,k,j) = ph_2(i,k,j) + ph_2(i,k,j) = ph_1(i,k,j)-ph_2(i,k,j) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end +! DO k=k_start, min(kde,kte) + DO k=k_start, kde + DO i=i_start, i_end + ww_save(i,k,j) = ww(i,k,j) + ENDDO + ENDDO + ENDDO + +END SUBROUTINE small_step_prep + +!------------------------------------------------------------------------- + + +SUBROUTINE small_step_finish( u_2, u_1, v_2, v_1, w_2, w_1, & + t_2, t_1, ph_2, ph_1, ww, ww1, & + mu_2, mu_1, & + mut, muts, muu, muus, muv, muvs, & + u_save, v_save, w_save, & + t_save, ph_save, mu_save, & + msfu, msfv, msft, & + h_diabatic, & + number_of_small_timesteps,dts, & + rk_step, rk_order, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + IMPLICIT NONE ! religion first + +! stuff passed in + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: number_of_small_timesteps + INTEGER, INTENT(IN ) :: rk_step, rk_order + REAL, INTENT(IN ) :: dts + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: u_1, & + v_1, & + w_1, & + t_1, & + ww1, & + ph_1 + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: u_2, & + v_2, & + w_2, & + t_2, & + ww, & + ph_2 + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(IN ) :: u_save, & + v_save, & + w_save, & + t_save, & + ph_save, & + h_diabatic + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: muus, muvs + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mu_2, mu_1 + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mut, muts, & + muu, muv, mu_save + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: msfu, msfv, msft + + +! local stuff + + INTEGER :: i,j,k + INTEGER :: i_start, i_end, j_start, j_end, i_endu, j_endv + +! +! +! small_step_finish reconstructs the full uncoupled prognostic variables +! from the coupled perturbation variables used in the small timesteps. +! +! + + i_start = its + i_end = ite + j_start = jts + j_end = jte + + i_endu = i_end + j_endv = j_end + + IF(i_end == ide) i_end = i_end - 1 + IF(j_end == jde) j_end = j_end - 1 + + +! 1 jun 2001 -> added boundary copy to 2D boundary condition routines, +! should be OK now without the following data copy + +!#if 0 +! DO j=j_start, j_end +! muts(0,j)=muts(1,j) +! muts(i_endu,j)=muts(i_end,j) +! ENDDO +! DO i=i_start, i_end +! muts(i,0)=muts(i,1) +! muts(i,j_endv)=muts(i,j_end) +! ENDDO + +! DO j = j_start, j_endv +! DO i = i_start, i_end +! muvs(i,j) = 0.5*(muts(i,j) + muts(i,j-1)) +! ENDDO +! ENDDO + +! DO j = j_start, j_end +! DO i = i_start, i_endu +! muus(i,j) = 0.5*(muts(i,j) + muts(i-1,j)) +! ENDDO +! ENDDO +!#endif + +! addition of time level t back into variables + + DO j = j_start, j_endv + DO k = kds, kde-1 + DO i = i_start, i_end + v_2(i,k,j) = (msfv(i,j)*v_2(i,k,j) + v_save(i,k,j)*muv(i,j))/muvs(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kds, kde-1 + DO i = i_start, i_endu + u_2(i,k,j) = (msfu(i,j)*u_2(i,k,j) + u_save(i,k,j)*muu(i,j))/muus(i,j) + ENDDO + ENDDO + ENDDO + + DO j = j_start, j_end + DO k = kds, kde + DO i = i_start, i_end + w_2(i,k,j) = (msft(i,j)*w_2(i,k,j) + w_save(i,k,j)*mut(i,j))/muts(i,j) + ph_2(i,k,j) = ph_2(i,k,j) + ph_save(i,k,j) + ww(i,k,j) = ww(i,k,j) + ww1(i,k,j) + ENDDO + ENDDO + ENDDO + +#ifdef REVERT + DO j = j_start, j_end + DO k = kds, kde-1 + DO i = i_start, i_end + t_2(i,k,j) = (t_2(i,k,j) + t_save(i,k,j)*mut(i,j))/muts(i,j) + ENDDO + ENDDO + ENDDO +#else + IF ( rk_step < rk_order ) THEN + DO j = j_start, j_end + DO k = kds, kde-1 + DO i = i_start, i_end + t_2(i,k,j) = (t_2(i,k,j) + t_save(i,k,j)*mut(i,j))/muts(i,j) + ENDDO + ENDDO + ENDDO + ELSE + + DO j = j_start, j_end + DO k = kds, kde-1 + DO i = i_start, i_end + t_2(i,k,j) = (t_2(i,k,j) - dts*number_of_small_timesteps*mut(i,j)*h_diabatic(i,k,j) & + + t_save(i,k,j)*mut(i,j))/muts(i,j) + ENDDO + ENDDO + ENDDO + ENDIF +#endif + + DO j = j_start, j_end + DO i = i_start, i_end + mu_2(i,j) = mu_2(i,j) + mu_save(i,j) + ENDDO + ENDDO + +END SUBROUTINE small_step_finish + +!----------------------------------------------------------------------- + +SUBROUTINE calc_p_rho( al, p, ph, & + alt, t_2, t_1, c2a, pm1, & + mu, muts, znu, t0, & + rdnw, dnw, smdiv, & + non_hydrostatic, step, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE ! religion first + +! declarations for the stuff coming in + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: step + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT( OUT) :: al, & + p +! pjj/cray +! p, & +! pm1 + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(IN ) :: alt, & + t_2, & + t_1, & + c2a + +! pjj/cray +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: ph + REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: ph, pm1 + + REAL, DIMENSION(ims:ime, jms:jme) , INTENT(IN ) :: mu, & + muts + + REAL, DIMENSION(kms:kme) , INTENT(IN ) :: dnw, & + rdnw, & + znu + + REAL, INTENT(IN ) :: t0, smdiv + + LOGICAL, INTENT(IN ) :: non_hydrostatic + +! local variables + + INTEGER :: i, j, k + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end + REAL :: ptmp + +! +! +! For the nonhydrostatic option, +! calc_p_rho computes the perturbation inverse density and +! perturbation pressure from the hydrostatic relation and the +! linearized equation of state, respectively. +! +! For the hydrostatic option, +! calc_p_rho computes the perturbation pressure, perturbation density, +! and perturbation geopotential +! from the vertical coordinate definition, linearized equation of state +! and the hydrostatic relation, respectively. +! +! forward weighting of the pressure (divergence damping) is also +! computed here. +! +! + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = min(kte,kde-1) + + IF(i_end == ide) i_end = i_end - 1 + IF(j_end == jde) j_end = j_end - 1 + + IF (non_hydrostatic) THEN + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + +! al computation is all dry, so ok with moisture + + al(i,k,j)=-1./muts(i,j)*(alt(i,k,j)*mu(i,j) & + +rdnw(k)*(ph(i,k+1,j)-ph(i,k,j))) + +! this is temporally linearized p, no moisture correction needed + + p(i,k,j)=c2a(i,k,j)*(alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & + /(muts(i,j)*(t0+t_1(i,k,j)))-al (i,k,j)) + + ENDDO + ENDDO + ENDDO + + ELSE ! hydrostatic calculation + + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + p(i,k,j)=mu(i,j)*znu(k) + al(i,k,j)=alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & + /(muts(i,j)*(t0+t_1(i,k,j)))-p(i,k,j)/c2a(i,k,j) + ph(i,k+1,j)=ph(i,k,j)-dnw(k)*(muts(i,j)*al (i,k,j) & + +mu(i,j)*alt(i,k,j)) + ENDDO + ENDDO + ENDDO + + END IF + +! divergence damping setup + + IF (step == 0) then ! we're initializing small timesteps + DO j=j_start, j_end + DO k=k_start, k_end + DO i=i_start, i_end + pm1(i,k,j)=p(i,k,j) + ENDDO + ENDDO + ENDDO + ELSE ! we're in the small timesteps + DO j=j_start, j_end ! and adding div damping component + DO k=k_start, k_end + DO i=i_start, i_end + ptmp = p(i,k,j) + p(i,k,j) = p(i,k,j) + smdiv*(p(i,k,j)-pm1(i,k,j)) + pm1(i,k,j) = ptmp + ENDDO + ENDDO + ENDDO + END IF + +END SUBROUTINE calc_p_rho + +!---------------------------------------------------------------------- + +SUBROUTINE calc_coef_w( a,alpha,gamma, & + mut, cqw, & + rdn, rdnw, c2a, & + dts, g, epssm, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims + + IMPLICIT NONE ! religion first + +! passed in through the call + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: c2a, & + cqw + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: alpha, & + gamma, & + a + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: mut + + REAL, DIMENSION(kms:kme), INTENT(IN ) :: rdn, & + rdnw + + REAL, INTENT(IN ) :: epssm, & + dts, & + g + +! Local stack data. + + REAL, DIMENSION(ims:ime) :: cof + REAL :: b, c + + INTEGER :: i, j, k, i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: ij, ijp, ijm + +! +! +! calc_coef_w calculates the coefficients needed for the +! implicit solution of the vertical momentum and geopotential equations. +! This requires solution of a tri-diagonal equation. +! +! + + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + + outer_j_loop: DO j = j_start, j_end + + DO i = i_start, i_end + cof(i) = (.5*dts*g*(1.+epssm)/mut(i,j))**2 + a(i, 2 ,j) = 0. + a(i,kde,j) =-2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) + gamma(i,1 ,j) = 0. + ENDDO + + DO k=3,kde-1 + DO i=i_start, i_end + a(i,k,j) = -cqw(i,k,j)*cof(i)*rdn(k)* rdnw(k-1)*c2a(i,k-1,j) + ENDDO + ENDDO + + + DO k=2,kde-1 + DO i=i_start, i_end + b = 1.+cqw(i,k,j)*cof(i)*rdn(k)*(rdnw(k )*c2a(i,k,j ) & + +rdnw(k-1)*c2a(i,k-1,j)) + c = -cqw(i,k,j)*cof(i)*rdn(k)*rdnw(k )*c2a(i,k,j ) + alpha(i,k,j) = 1./(b-a(i,k,j)*gamma(i,k-1,j)) + gamma(i,k,j) = c*alpha(i,k,j) + ENDDO + ENDDO + + DO i=i_start, i_end + b = 1.+2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) + c = 0. + alpha(i,kde,j) = 1./(b-a(i,kde,j)*gamma(i,kde-1,j)) + gamma(i,kde,j) = c*alpha(i,kde,j) + ENDDO + + ENDDO outer_j_loop + +END SUBROUTINE calc_coef_w + +!---------------------------------------------------------------------- + +SUBROUTINE advance_uv ( u, ru_tend, v, rv_tend, & + p, pb, & + ph, php, alt, al, mu, & + muu, cqu, muv, cqv, mudf, & + rdx, rdy, dts, & + cf1, cf2, cf3, fnm, fnp, & + emdiv, & + rdnw, config_flags, spec_zone, & + non_hydrostatic, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + + IMPLICIT NONE ! religion first + +! stuff coming in + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + LOGICAL, INTENT(IN ) :: non_hydrostatic + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: & + u, & + v + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN ) :: & + ru_tend, & + rv_tend, & + ph, & + php, & + p, & + pb, & + alt, & + al, & + cqu, & + cqv + + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: muu, & + muv, & + mu, & + mudf + + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: fnm, & + fnp , & + rdnw + + REAL, INTENT(IN ) :: rdx, & + rdy, & + dts, & + cf1, & + cf2, & + cf3, & + emdiv + + +! Local 3d array from the stack (note tile size) + + REAL, DIMENSION (its:ite, kts:kte) :: dpn, dpxy + REAL, DIMENSION (its:ite) :: mudf_xy + REAL :: dx, dy + + INTEGER :: i,j,k, i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i_endu, j_endv, k_endw + INTEGER :: i_start_up, i_end_up, j_start_up, j_end_up + INTEGER :: i_start_vp, i_end_vp, j_start_vp, j_end_vp + + INTEGER :: i_start_u_tend, i_end_u_tend, j_start_v_tend, j_end_v_tend + +! +! +! advance_uv advances the explicit perturbation horizontal momentum +! equations (u,v) by adding in the large-timestep tendency along with +! the small timestep pressure gradient tendency. +! +! + +! now, the real work. +! set the loop bounds taking into account boundary conditions. + + IF( config_flags%nested .or. config_flags%specified ) THEN + i_start = max( its,ids+spec_zone ) + i_end = min( ite,ide-spec_zone-1 ) + j_start = max( jts,jds+spec_zone ) + j_end = min( jte,jde-spec_zone-1 ) + k_start = kts + k_end = min( kte, kde-1 ) + + i_endu = min( ite,ide-spec_zone ) + j_endv = min( jte,jde-spec_zone ) + k_endw = k_end + + IF( config_flags%periodic_x) THEN + i_start = its + i_end = ite + i_endu = i_end + IF(i_end == ide) i_end = i_end - 1 + ENDIF + ELSE + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + + i_endu = i_end + j_endv = j_end + k_endw = k_end + + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + ENDIF + + i_start_up = i_start + i_end_up = i_endu + j_start_up = j_start + j_end_up = j_end + + i_start_vp = i_start + i_end_vp = i_end + j_start_vp = j_start + j_end_vp = j_endv + + IF ( (config_flags%open_xs .or. & + config_flags%symmetric_xs ) & + .and. (its == ids) ) & + i_start_up = i_start_up + 1 + + IF ( (config_flags%open_xe .or. & + config_flags%symmetric_xe ) & + .and. (ite == ide) ) & + i_end_up = i_end_up - 1 + + IF ( (config_flags%open_ys .or. & + config_flags%symmetric_ys ) & + .and. (jts == jds) ) & + j_start_vp = j_start_vp + 1 + + IF ( (config_flags%open_ye .or. & + config_flags%symmetric_ye ) & + .and. (jte == jde) ) & + j_end_vp = j_end_vp - 1 + + i_start_u_tend = i_start + i_end_u_tend = i_endu + j_start_v_tend = j_start + j_end_v_tend = j_endv + + IF ( config_flags%symmetric_xs .and. (its == ids) ) & + i_start_u_tend = i_start_u_tend+1 + IF ( config_flags%symmetric_xe .and. (ite == ide) ) & + i_end_u_tend = i_end_u_tend-1 + IF ( config_flags%symmetric_ys .and. (jts == jds) ) & + j_start_v_tend = j_start_v_tend+1 + IF ( config_flags%symmetric_ye .and. (jte == jde) ) & + j_end_v_tend = j_end_v_tend-1 + + dx = 1./rdx + dy = 1./rdy + +! start real calculations. +! first, u + + u_outer_j_loop: DO j = j_start, j_end + + DO k = k_start, k_end + DO i = i_start_u_tend, i_end_u_tend + u(i,k,j) = u(i,k,j) + dts*ru_tend(i,k,j) + ENDDO + ENDDO + + DO i = i_start_up, i_end_up + mudf_xy(i)= -emdiv*dx*(mudf(i,j)-mudf(i-1,j)) + ENDDO + + DO k = k_start, k_end + DO i = i_start_up, i_end_up + + dpxy(i,k)= .5*rdx*muu(i,j)*( & + ((ph (i,k+1,j)-ph (i-1,k+1,j))+(ph (i,k,j)-ph (i-1,k,j))) & + +(alt(i,k ,j)+alt(i-1,k ,j))*(p (i,k,j)-p (i-1,k,j)) & + +(al (i,k ,j)+al (i-1,k ,j))*(pb (i,k,j)-pb (i-1,k,j)) ) + + ENDDO + ENDDO + + IF (non_hydrostatic) THEN + + DO i = i_start_up, i_end_up + dpn(i,1) = .5*( cf1*(p(i,1,j)+p(i-1,1,j)) & + +cf2*(p(i,2,j)+p(i-1,2,j)) & + +cf3*(p(i,3,j)+p(i-1,3,j)) ) + dpn(i,kde) = 0. + ENDDO + + + DO k = k_start+1, k_end + DO i = i_start_up, i_end_up + dpn(i,k) = .5*( fnm(k)*(p(i,k ,j)+p(i-1,k ,j)) & + +fnp(k)*(p(i,k-1,j)+p(i-1,k-1,j)) ) + ENDDO + ENDDO + + DO k = k_start, k_end + DO i = i_start_up, i_end_up + dpxy(i,k)=dpxy(i,k) + rdx*(php(i,k,j)-php(i-1,k,j))* & + (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i-1,j)+mu(i,j))) + ENDDO + ENDDO + + + END IF + + + DO k = k_start, k_end + DO i = i_start_up, i_end_up + u(i,k,j)=u(i,k,j)-dts*cqu(i,k,j)*dpxy(i,k)+mudf_xy(i) + ENDDO + ENDDO + + ENDDO u_outer_j_loop + +! now v + + v_outer_j_loop: DO j = j_start_v_tend, j_end_v_tend + + + DO k = k_start, k_end + DO i = i_start, i_end + v(i,k,j) = v(i,k,j) + dts*rv_tend(i,k,j) + ENDDO + ENDDO + + DO i = i_start, i_end + mudf_xy(i)= -emdiv*dy*(mudf(i,j)-mudf(i,j-1)) + ENDDO + + IF ( ( j >= j_start_vp) & + .and.( j <= j_end_vp ) ) THEN + + DO k = k_start, k_end + DO i = i_start, i_end + + dpxy(i,k)= .5*rdy*muv(i,j)*( & + ((ph(i,k+1,j)-ph(i,k+1,j-1))+(ph (i,k,j)-ph (i,k,j-1))) & + +(alt(i,k ,j)+alt(i,k ,j-1))*(p (i,k,j)-p (i,k,j-1)) & + +(al (i,k ,j)+al (i,k ,j-1))*(pb (i,k,j)-pb (i,k,j-1)) ) + + ENDDO + ENDDO + + + IF (non_hydrostatic) THEN + + DO i = i_start, i_end + dpn(i,1) = .5*( cf1*(p(i,1,j)+p(i,1,j-1)) & + +cf2*(p(i,2,j)+p(i,2,j-1)) & + +cf3*(p(i,3,j)+p(i,3,j-1)) ) + dpn(i,kde) = 0. + ENDDO + + + DO k = k_start+1, k_end + DO i = i_start, i_end + dpn(i,k) = .5*( fnm(k)*(p(i,k ,j)+p(i,k ,j-1)) & + +fnp(k)*(p(i,k-1,j)+p(i,k-1,j-1)) ) + ENDDO + ENDDO + + DO k = k_start, k_end + DO i = i_start, i_end + dpxy(i,k)=dpxy(i,k) + rdy*(php(i,k,j)-php(i,k,j-1))* & + (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i,j-1)+mu(i,j))) + ENDDO + ENDDO + + + END IF + + + DO k = k_start, k_end + DO i = i_start, i_end + v(i,k,j)=v(i,k,j)-dts*cqv(i,k,j)*dpxy(i,k)+mudf_xy(i) + ENDDO + ENDDO + END IF + + ENDDO v_outer_j_loop + +END SUBROUTINE advance_uv + +!--------------------------------------------------------------------- + +SUBROUTINE advance_mu_t( ww, ww_1, u, u_1, v, v_1, & + mu, mut, muave, muts, muu, muv, & + mudf, uam, vam, wwam, t, t_1, & + t_ave, ft, mu_tend, & + rdx, rdy, dts, epssm, & + dnw, fnm, fnp, rdnw, & + msfu, msfv, msft, & + step, config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE ! religion first + +! stuff coming in + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: step + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN ) :: & + u, & + v, & + u_1, & + v_1, & + t_1, & + ft + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: & + ww, & + ww_1, & + t, & + t_ave, & + uam, & + vam, & + wwam + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: muu, & + muv, & + mut, & + msfu, & + msfv, & + msft, & + mu_tend + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT( OUT) :: muave, & + muts, & + mudf + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: mu + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: fnm, & + fnp, & + dnw, & + rdnw + + + REAL, INTENT(IN ) :: rdx, & + rdy, & + dts, & + epssm + +! Local 3d array from the stack (note tile size) + + REAL, DIMENSION (its:ite, kts:kte) :: wdtn, dvdxi + REAL, DIMENSION (its:ite) :: dmdt + + INTEGER :: i,j,k, i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i_endu, j_endv + REAL :: acc + +! +! +! advance_mu_t advances the explicit perturbation theta equation and the mass +! conservation equation. In addition, the small timestep omega is updated, +! and some quantities needed in other places are squirrelled away. +! +! + +! now, the real work. +! set the loop bounds taking into account boundary conditions. + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + + i_endu = i_end + j_endv = j_end + + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + + IF ( .NOT. config_flags%periodic_x )THEN + IF ( (config_flags%specified .or. config_flags%nested) .and. (its == ids) ) & + i_start = i_start + 1 + + IF ( (config_flags%specified .or. config_flags%nested) .and. (ite == ide) ) & + i_end = i_end - 1 + ENDIF + + IF ( (config_flags%specified .or. config_flags%nested) .and. (jts == jds) ) & + j_start = j_start + 1 + + IF ( (config_flags%specified .or. config_flags%nested) .and. (jte == jde) ) & + j_end = j_end - 1 + + +! CALCULATION OF WW (dETA/dt) + DO j = j_start, j_end + + DO i=i_start, i_end + dmdt(i) = 0. + ENDDO +! NOTE: mu is not coupled with the map scale factor. +! ww (omega) IS coupled with the map scale factor. +! Being coupled with the map scale factor means +! multiplication by (1/msft) in this case. + + DO k=k_start, k_end + DO i=i_start, i_end + dvdxi(i,k) = msft(i,j)*msft(i,j)*( & + rdy*( (v(i,k,j+1)+muv(i,j+1)*v_1(i,k,j+1)/msfv(i,j+1)) & + -(v(i,k,j )+muv(i,j )*v_1(i,k,j )/msfv(i,j )) ) & + +rdx*( (u(i+1,k,j)+muu(i+1,j)*u_1(i+1,k,j)/msfu(i+1,j)) & + -(u(i,k,j )+muu(i ,j)*u_1(i,k,j )/msfu(i ,j)) ) ) + dmdt(i) = dmdt(i) + dnw(k)*dvdxi(i,k) + ENDDO + ENDDO + DO i=i_start, i_end + muave(i,j) = mu(i,j) + mu(i,j) = mu(i,j)+dts*(dmdt(i)+mu_tend(i,j)) + mudf(i,j) = (dmdt(i)+mu_tend(i,j)) ! save tendency for div damp filter + muts(i,j) = mut(i,j)+mu(i,j) + muave(i,j) =.5*((1.+epssm)*mu(i,j)+(1.-epssm)*muave(i,j)) + ENDDO + + DO k=2,k_end + DO i=i_start, i_end + ww(i,k,j)=ww(i,k-1,j)-dnw(k-1)*(dmdt(i)+dvdxi(i,k-1)+mu_tend(i,j))/msft(i,j) + ENDDO + END DO + +! NOTE: ww_1 (large timestep ww) is already coupled with the +! map scale factor + + DO k=1,k_end + DO i=i_start, i_end + ww(i,k,j)=ww(i,k,j)-ww_1(i,k,j) + END DO + END DO + + ENDDO + +! CALCULATION OF THETA + +! NOTE: theta'' is not coupled with the map-scale factor, +! while the theta'' tendency is coupled (i.e., mult by 1/msft) + + DO j=j_start, j_end + DO k=1,k_end + DO i=i_start, i_end + t_ave(i,k,j) = t(i,k,j) + t (i,k,j) = t(i,k,j) + msft(i,j)*dts*ft(i,k,j) + END DO + END DO + ENDDO + + DO j=j_start, j_end + + DO i=i_start, i_end + wdtn(i,1 )=0. + wdtn(i,kde)=0. + ENDDO + + DO k=2,k_end + DO i=i_start, i_end + wdtn(i,k)= ww(i,k,j)*(fnm(k)*t_1(i,k ,j)+fnp(k)*t_1(i,k-1,j)) + ENDDO + ENDDO + + DO k=1,k_end + DO i=i_start, i_end + t(i,k,j) = t(i,k,j) - dts*msft(i,j)*( & + msft(i,j)*( & + .5*rdy* & + ( v(i,k,j+1)*(t_1(i,k,j+1)+t_1(i,k, j )) & + -v(i,k,j )*(t_1(i,k, j )+t_1(i,k,j-1)) ) & + + .5*rdx* & + ( u(i+1,k,j)*(t_1(i+1,k,j)+t_1(i ,k,j)) & + -u(i ,k,j)*(t_1(i ,k,j)+t_1(i-1,k,j)) ) ) & + + rdnw(k)*( wdtn(i,k+1)-wdtn(i,k) ) ) + ENDDO + ENDDO + + ENDDO + +END SUBROUTINE advance_mu_t + + + +!------------------------------------------------------------ + +SUBROUTINE advance_w( w, rw_tend, ww, u, v, & + mu1, mut, muave, muts, & + t_2ave, t_2, t_1, & + ph, ph_1, phb, ph_tend, & + ht, c2a, cqw, alt, alb, & + a, alpha, gamma, & + rdx, rdy, dts, t0, epssm, & + dnw, fnm, fnp, rdnw, rdn, & + cf1, cf2, cf3, msft, & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims + + IMPLICIT NONE ! religion first + +! stuff coming in + + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + t_2ave, & + w, & + ph + + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN ) :: & + rw_tend, & + ww, & + u, & + v, & + t_2, & + t_1, & + ph_1, & + phb, & + ph_tend, & + alpha, & + gamma, & + a, & + c2a, & + cqw, & + alb, & + alt + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: & + mu1, & + mut, & + muave, & + muts, & + ht, & + msft + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: fnp, & + fnm, & + rdnw, & + rdn, & + dnw + + REAL, INTENT(IN ) :: rdx, & + rdy, & + dts, & + cf1, & + cf2, & + cf3, & + t0, & + epssm + +! Stack based 3d data, tile size. + + REAL, DIMENSION( its:ite ) :: mut_inv, msft_inv + REAL, DIMENSION( its:ite, kts:kte ) :: rhs, wdwn + INTEGER :: i,j,k, i_start, i_end, j_start, j_end, k_start, k_end + +! +! +! advance_w advances the implicit w and geopotential equations. +! +! + +! set loop limits. +! Currently set for periodic boundary conditions + + i_start = its + i_end = ite + j_start = jts + j_end = jte + k_start = kts + k_end = kte-1 + + + IF(j_end == jde) j_end = j_end - 1 + IF(i_end == ide) i_end = i_end - 1 + + IF ( .NOT. config_flags%periodic_x )THEN + IF ( (config_flags%specified .or. config_flags%nested) .and. (its == ids) ) & + i_start = i_start + 1 + + IF ( (config_flags%specified .or. config_flags%nested) .and. (ite == ide) ) & + i_end = i_end - 1 + ENDIF + + IF ( (config_flags%specified .or. config_flags%nested) .and. (jts == jds) ) & + j_start = j_start + 1 + + IF ( (config_flags%specified .or. config_flags%nested) .and. (jte == jde) ) & + j_end = j_end - 1 + + +! calculation of phi and w equations + + DO i=i_start, i_end + rhs(i,1) = 0. + ENDDO + + j_loop_w: DO j = j_start, j_end + DO i=i_start, i_end + mut_inv(i) = 1./mut(i,j) + msft_inv(i) = 1./msft(i,j) + ENDDO + + DO k=1, k_end + DO i=i_start, i_end + t_2ave(i,k,j)=.5*((1.+epssm)*t_2(i,k,j) & + +(1.-epssm)*t_2ave(i,k,j)) + t_2ave(i,k,j)=(t_2ave(i,k,j)-mu1(i,j)*t_1(i,k,j)) & + /(muts(i,j)*(t0+t_1(i,k,j))) + wdwn(i,k+1)=.5*(ww(i,k+1,j)+ww(i,k,j))*rdnw(k) & + *(ph_1(i,k+1,j)-ph_1(i,k,j)+phb(i,k+1,j)-phb(i,k,j)) + rhs(i,k+1) = dts*(ph_tend(i,k+1,j) + .5*g*(1.-epssm)*w(i,k+1,j)) + + ENDDO + ENDDO + + DO k=2,k_end + DO i=i_start, i_end + rhs(i,k) = rhs(i,k)-dts*( fnm(k)*wdwn(i,k+1) & + +fnp(k)*wdwn(i,k ) ) + ENDDO + ENDDO + +! NOTE: phi'' is not coupled with the map-scale factor (1/m), +! but it's tendency is, so must multiply by msft here + + DO k=2,k_end+1 + DO i=i_start, i_end + rhs(i,k) = ph(i,k,j) + msft(i,j)*rhs(i,k)*mut_inv(i) + ENDDO + ENDDO + +! lower boundary condition on w + + DO i=i_start, i_end + w(i,1,j)= & + + .5*rdy*( & + (ht(i,j+1)-ht(i,j )) & + *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1)) & + +(ht(i,j )-ht(i,j-1)) & + *(cf1*v(i,1,j )+cf2*v(i,2,j )+cf3*v(i,3,j )) ) & + + +.5*rdx*( & + (ht(i+1,j)-ht(i,j )) & + *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j)) & + +(ht(i,j )-ht(i-1,j)) & + *(cf1*u(i ,1,j)+cf2*u(i ,2,j)+cf3*u(i ,3,j)) ) + + ENDDO +! +! Jammed 3 doubly nested loops over k/i into 1 for slight improvement +! in efficiency. No change in results (bit-for-bit). JM 20040514 +! (left a blank line where the other two k/i-loops were) +! + DO k=2,k_end + DO i=i_start, i_end + w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & + + + msft_inv(i)*cqw(i,k,j)*( & + +.5*dts*g*mut_inv(i)*rdn(k)* & + (c2a(i,k ,j)*rdnw(k ) & + *((1.+epssm)*(rhs(i,k+1 )-rhs(i,k )) & + +(1.-epssm)*(ph(i,k+1,j)-ph(i,k ,j))) & + -c2a(i,k-1,j)*rdnw(k-1) & + *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & + +(1.-epssm)*(ph(i,k ,j)-ph(i,k-1,j))))) & + + +dts*g*msft_inv(i)*(rdn(k)* & + (c2a(i,k ,j)*alt(i,k ,j)*t_2ave(i,k ,j) & + -c2a(i,k-1,j)*alt(i,k-1,j)*t_2ave(i,k-1,j)) & + +(rdn(k)*(c2a(i,k ,j)*alb(i,k ,j) & + -c2a(i,k-1,j)*alb(i,k-1,j))*mut_inv(i)-1.) & + *muave(i,j)) + ENDDO + ENDDO + + K=k_end+1 + + DO i=i_start, i_end + w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & + +msft_inv(i)*( & + -.5*dts*g*mut_inv(i)*rdnw(k-1)**2*2.*c2a(i,k-1,j) & + *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & + +(1.-epssm)*(ph(i,k,j)-ph(i,k-1,j))) & + -dts*g*(2.*rdnw(k-1)* & + c2a(i,k-1,j)*alt(i,k-1,j)*t_2ave(i,k-1,j) & + +(1.+2.*rdnw(k-1)*c2a(i,k-1,j)*alb(i,k-1,j)*mut_inv(i)) & + *muave(i,j)) ) + ENDDO + + DO k=2,k_end+1 + DO i=i_start, i_end + w(i,k,j)=(w(i,k,j)-a(i,k,j)*w(i,k-1,j))*alpha(i,k,j) + ENDDO + ENDDO + + DO k=k_end,2,-1 + DO i=i_start, i_end + w (i,k,j)=w (i,k,j)-gamma(i,k,j)*w(i,k+1,j) + ph(i,k+1,j) = rhs(i,k+1)+msft(i,j)*.5*dts*g*(1.+epssm) & + *w(i,k+1,j)/muts(i,j) + ENDDO + ENDDO + + DO i=i_start, i_end + ph(i,2,j) = rhs(i,2)+msft(i,j)*.5*dts*g*(1.+epssm) & + *w(i,2,j)/muts(i,j) + ENDDO + + ENDDO j_loop_w + +END SUBROUTINE advance_w + +!--------------------------------------------------------------------- + +SUBROUTINE sumflux ( ru, rv, ww, & + u_lin, v_lin, ww_lin, & + muu, muv, & + ru_m, rv_m, ww_m, epssm, & + msfu, msfv, & + iteration , number_of_small_timesteps, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + IMPLICIT NONE ! religion first + +! declarations for the stuff coming in + + INTEGER, INTENT(IN ) :: number_of_small_timesteps + INTEGER, INTENT(IN ) :: iteration + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: ru, & + rv, & + ww, & + u_lin, & + v_lin, & + ww_lin + + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme) , INTENT(INOUT) :: ru_m, & + rv_m, & + ww_m + REAL, DIMENSION(ims:ime, jms:jme) , INTENT(IN ) :: muu, muv, msfu, msfv + + INTEGER :: mini, minj, mink + + + REAL, INTENT(IN ) :: epssm + INTEGER :: i,j,k + + +! +! +! update the small-timestep time-averaged mass fluxes; these +! are needed for consistent mass-conserving scalar advection. +! +! + + IF (iteration == 1 )THEN + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + ru_m(i,k,j) = 0. + rv_m(i,k,j) = 0. + ww_m(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + ENDIF + + mini = min(ide-1,ite) + minj = min(jde-1,jte) + mink = min(kde-1,kte) + + + DO j = jts, minj + DO k = kts, mink + DO i = its, mini + ru_m(i,k,j) = ru_m(i,k,j) + ru(i,k,j) + rv_m(i,k,j) = rv_m(i,k,j) + rv(i,k,j) + ww_m(i,k,j) = ww_m(i,k,j) + ww(i,k,j) + ENDDO + ENDDO + ENDDO + + IF (ite .GT. mini) THEN + DO j = jts, minj + DO k = kts, mink + DO i = mini+1, ite + ru_m(i,k,j) = ru_m(i,k,j) + ru(i,k,j) + ENDDO + ENDDO + ENDDO + END IF + IF (jte .GT. minj) THEN + DO j = minj+1, jte + DO k = kts, mink + DO i = its, mini + rv_m(i,k,j) = rv_m(i,k,j) + rv(i,k,j) + ENDDO + ENDDO + ENDDO + END IF + IF ( kte .GT. mink) THEN + DO j = jts, minj + DO k = mink+1, kte + DO i = its, mini + ww_m(i,k,j) = ww_m(i,k,j) + ww(i,k,j) + ENDDO + ENDDO + ENDDO + END IF + + IF (iteration == number_of_small_timesteps) THEN + + DO j = jts, minj + DO k = kts, mink + DO i = its, mini + ru_m(i,k,j) = ru_m(i,k,j) / number_of_small_timesteps & + + muu(i,j)*u_lin(i,k,j)/msfu(i,j) + rv_m(i,k,j) = rv_m(i,k,j) / number_of_small_timesteps & + + muv(i,j)*v_lin(i,k,j)/msfv(i,j) + ww_m(i,k,j) = ww_m(i,k,j) / number_of_small_timesteps & + + ww_lin(i,k,j) + ENDDO + ENDDO + ENDDO + + + IF (ite .GT. mini) THEN + DO j = jts, minj + DO k = kts, mink + DO i = mini+1, ite + ru_m(i,k,j) = ru_m(i,k,j) / number_of_small_timesteps & + + muu(i,j)*u_lin(i,k,j)/msfu(i,j) + ENDDO + ENDDO + ENDDO + END IF + IF (jte .GT. minj) THEN + DO j = minj+1, jte + DO k = kts, mink + DO i = its, mini + rv_m(i,k,j) = rv_m(i,k,j) / number_of_small_timesteps & + + muv(i,j)*v_lin(i,k,j)/msfv(i,j) + ENDDO + ENDDO + ENDDO + END IF + IF ( kte .GT. mink) THEN + DO j = jts, minj + DO k = mink+1, kte + DO i = its, mini + ww_m(i,k,j) = ww_m(i,k,j) / number_of_small_timesteps & + + ww_lin(i,k,j) + ENDDO + ENDDO + ENDDO + END IF + + ENDIF + + +END SUBROUTINE sumflux + +!--------------------------------------------------------------------- + + SUBROUTINE init_module_small_step + END SUBROUTINE init_module_small_step + +END MODULE module_small_step_em diff --git a/wrfv2_fire/dyn_em/module_solvedebug_em.F b/wrfv2_fire/dyn_em/module_solvedebug_em.F new file mode 100644 index 00000000..a6500d46 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_solvedebug_em.F @@ -0,0 +1,325 @@ +!WRF:MEDIATION_LAYER:UTIL +! + +MODULE module_solvedebug_em +CONTAINS + SUBROUTINE var_min_max( u,v,w,t,r, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION( kms: , ims: , jms: ), & + INTENT(IN) :: u,v,w,t,r + + INTEGER :: i, j, k, istag, jstag, imax, imin, jmax, jmin, & + kmax, kmin + + REAL :: vmax, vmin, vavg + + vmin = u(1,1,1) + vmax = u(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe-1 + do i=ips,ipe + do k=kps,kpe-1 + if(u(k,i,j) .gt. vmax) then + vmax = u(k,i,j) + imax = i + jmax = j + kmax = k + endif + + if(u(k,i,j) .lt. vmin) then + vmin = u(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(u(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips)*(jpe-jps-1)*(kpe-kps-1)) + write(6,*) ' ru min,max,avg ',vmin,vmax,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + + vmin = v(1,1,1) + vmax = v(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe + do i=ips,ipe-1 + do k=kps,kpe-1 + if(v(k,i,j) .gt. vmax) then + vmax = v(k,i,j) + imax = i + jmax = j + kmax = k + endif + if(v(k,i,j) .lt. vmin) then + vmin = v(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(v(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips-1)*(jpe-jps)*(kpe-kps-1)) + write(6,*) ' rv min,max,avg ',vmin,vmax,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + + + vmin = w(1,1,1) + vmax = w(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe-1 + do i=ips,ipe-1 + do k=kps,kpe + if(w(k,i,j) .gt. vmax) then + vmax = w(k,i,j) + imax = i + jmax = j + kmax = k + endif + if(w(k,i,j) .lt. vmin) then + vmin = w(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(w(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips-1)*(jpe-jps-1)*(kpe-kps)) + write(6,*) ' rom min,max,avg ',vmin,vmax,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + + + vmin = t(1,1,1) + vmax = t(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe-1 + do i=ips,ipe-1 + do k=kps,kpe-1 + if(t(k,i,j) .gt. vmax) then + vmax = t(k,i,j) + imax = i + jmax = j + kmax = k + endif + if(t(k,i,j) .lt. vmin) then + vmin = t(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(t(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips-1)*(jpe-jps-1)*(kpe-kps-1)) + write(6,*) ' rtp min,max,avg ',vmin,vmax,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + + + vmin = r(1,1,1) + vmax = r(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe-1 + do i=ips,ipe-1 + do k=kps,kpe-1 + if(r(k,i,j) .gt. vmax) then + vmax = r(k,i,j) + imax = i + jmax = j + kmax = k + endif + if(r(k,i,j) .lt. vmin) then + vmin = r(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(r(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips-1)*(jpe-jps-1)*(kpe-kps-1)) + write(6,*) ' rhop min,max,avg ',vmin,vmax,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + return + end subroutine var_min_max + + SUBROUTINE var1_min_max( u, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + REAL, DIMENSION(kms: , ims: , jms: ), & + INTENT(IN) :: u + + INTEGER :: i, j, k, istag, jstag, imax, imin, jmax, jmin, & + kmax, kmin + + REAL :: vmax, vmin, vavg + + write(6,*) ' min, max, and avg stats ' + + vmin = u(1,1,1) + vmax = u(1,1,1) + vavg = 0. + imax = 1 + imin = 1 + jmax = 1 + jmin = 1 + kmax = 1 + kmin = 1 + + do j=jps,jpe-1 + do i=ips,ipe + do k=kps,kpe-1 + if(u(k,i,j) .gt. vmax) then + vmax = u(k,i,j) + imax = i + jmax = j + kmax = k + endif + + if(u(k,i,j) .lt. vmin) then + vmin = u(k,i,j) + imin = i + jmin = j + kmin = k + endif + vavg = vavg + abs(u(k,i,j)) + enddo + enddo + enddo + vavg = vavg/float((ipe-ips)*(jpe-jps-1)*(kpe-kps-1)) + write(6,*) ' ru max,min,avg ',vmax,vmin,vavg + write(6,*) kmax, imax, jmax, kmin, imin, jmin + + return + end subroutine var1_min_max + + + + + SUBROUTINE var_print ( u, & + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + level ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: level + + REAL, DIMENSION(kms:kme, ims:ime, jms:jme), & + INTENT(IN) :: u + + INTEGER :: i, j, k, istag, jstag, it, imax, imin, jmax, jmin, & + kmax, kmin, ii,jj + + REAL :: vmax, vmin, vavg + + write(6,*) ' level for print ',level + write(6,*) (u(level, ii, 1),ii=1,ipe) + write(6,*) (u(level, 1, jj),jj=1,jpe) + + return + end subroutine var_print + + SUBROUTINE symm_check ( f, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + level ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: level + + REAL, DIMENSION(kms:kme, ims:ime, jms:jme), & + INTENT(IN) :: f + + INTEGER :: i, j, k, istag, jstag, it, imax, imin, jmax, jmin, & + kmax, kmin, ii,jj + + REAL :: vmax, vmin, vavg + + write(6,*) ide,' = ide' + + do k=kps,kpe + do i=ips,ipe + do j=jps,jpe + if(f(k,i,j).ne.f(k,ide-i,j))print *,' x asymmetry at kij ',k,i,j + if(f(k,i,j).ne.f(k,i,jde-j))print *,' y asymmetry at kij ',k,i,j + enddo + enddo + enddo + return + end subroutine symm_check +END MODULE module_solvedebug_em diff --git a/wrfv2_fire/dyn_em/nest_init_utils.F b/wrfv2_fire/dyn_em/nest_init_utils.F new file mode 100644 index 00000000..226ca6b1 --- /dev/null +++ b/wrfv2_fire/dyn_em/nest_init_utils.F @@ -0,0 +1,325 @@ +SUBROUTINE init_domain_constants_em ( parent , nest ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: parent , nest + + INTEGER iswater , map_proj, julyr, julday + REAL cen_lat, cen_lon, truelat1 , truelat2 , gmt , moad_cen_lat , stand_lon + CHARACTER (LEN=4) :: char_junk + +! single-value constants + + nest%p_top = parent%p_top + nest%cfn = parent%cfn + nest%cfn1 = parent%cfn1 + nest%rdx = 1./nest%dx + nest%rdy = 1./nest%dy +! nest%dts = nest%dt/float(nest%time_step_sound) + nest%dtseps = parent%dtseps ! used in height model only? + nest%resm = parent%resm ! used in height model only? + nest%zetatop = parent%zetatop ! used in height model only? + nest%cf1 = parent%cf1 + nest%cf2 = parent%cf2 + nest%cf3 = parent%cf3 + nest%gmt = parent%gmt + nest%julyr = parent%julyr + nest%julday = parent%julday + + CALL nl_get_mminlu ( 1,char_junk(1:4) ) + CALL nl_get_iswater (1, iswater ) + CALL nl_get_truelat1 ( 1 , truelat1 ) + CALL nl_get_truelat2 ( 1 , truelat2 ) + CALL nl_get_moad_cen_lat ( 1 , moad_cen_lat ) + CALL nl_get_stand_lon ( 1 , stand_lon ) + CALL nl_get_map_proj ( 1 , map_proj ) + CALL nl_get_gmt ( 1 , gmt) + CALL nl_get_julyr ( 1 , julyr) + CALL nl_get_julday ( 1 , julday) + IF ( nest%id .NE. 1 ) THEN + CALL nl_set_gmt (nest%id, gmt) + CALL nl_set_julyr (nest%id, julyr) + CALL nl_set_julday (nest%id, julday) + CALL nl_set_iswater (nest%id, iswater ) + CALL nl_set_truelat1 ( nest%id , truelat1 ) + CALL nl_set_truelat2 ( nest%id , truelat2 ) + CALL nl_set_moad_cen_lat ( nest%id , moad_cen_lat ) + CALL nl_set_stand_lon ( nest%id , stand_lon ) + CALL nl_set_map_proj ( nest%id , map_proj ) + END IF + nest%gmt = gmt + nest%julday = julday + nest%julyr = julyr + nest%iswater = iswater + nest%cen_lat = cen_lat + nest%cen_lon = cen_lon + nest%truelat1= truelat1 + nest%truelat2= truelat2 + nest%moad_cen_lat= moad_cen_lat + nest%stand_lon= stand_lon + nest%map_proj= map_proj + + nest%step_number = parent%step_number + +! 1D constants (Z) + + nest%em_fnm = parent%em_fnm + nest%em_fnp = parent%em_fnp + nest%em_rdnw = parent%em_rdnw + nest%em_rdn = parent%em_rdn + nest%em_dnw = parent%em_dnw + nest%em_dn = parent%em_dn + nest%em_znu = parent%em_znu + nest%em_znw = parent%em_znw + nest%em_t_base = parent%em_t_base + nest%u_base = parent%u_base + nest%v_base = parent%v_base + nest%qv_base = parent%qv_base + nest%z_base = parent%z_base + nest%dzs = parent%dzs + nest%zs = parent%zs + +END SUBROUTINE init_domain_constants_em + +SUBROUTINE blend_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + USE module_configure + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_interpolated + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: ter_input + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: ter_temp + INTEGER :: i , j , k , spec_bdy_width + REAL :: r_blend_zones + INTEGER blend_cell, blend_width + + ! The fine grid elevation comes from the horizontally interpolated + ! parent elevation for the first spec_bdy_width row/columns, so we need + ! to get that value. We blend the coarse and fine in the next blend_width + ! rows and columns. After that, in the interior, it is 100% fine grid. + + CALL nl_get_spec_bdy_width ( 1, spec_bdy_width) + CALL nl_get_blend_width ( 1, blend_width) + + ! Initialize temp values to the nest ter elevation. This fills in the values + ! that will not be modified below. + + DO j = jps , MIN(jpe, jde-1) + DO k = kps , kpe + DO i = ips , MIN(ipe, ide-1) + ter_temp(i,k,j) = ter_input(i,k,j) + END DO + END DO + END DO + + ! To avoid some tricky indexing, we fill in the values inside out. This allows + ! us to overwrite incorrect assignments. There are replicated assignments, and + ! there is much unnecessary "IF test inside of a loop" stuff. For a large + ! domain, this is only a patch; for a small domain, this is not a biggy. + + r_blend_zones = 1./(blend_width+1) + DO j = jps , MIN(jpe, jde-1) + DO k = kps , kpe + DO i = ips , MIN(ipe, ide-1) + DO blend_cell = blend_width,1,-1 + IF ( ( i .EQ. spec_bdy_width + blend_cell ) .OR. ( j .EQ. spec_bdy_width + blend_cell ) .OR. & + ( i .EQ. ide - spec_bdy_width - blend_cell ) .OR. ( j .EQ. jde - spec_bdy_width - blend_cell ) ) THEN + ter_temp(i,k,j) = ( (blend_cell)*ter_input(i,k,j) + (blend_width+1-blend_cell)*ter_interpolated(i,k,j) ) & + * r_blend_zones + END IF + ENDDO + IF ( ( i .LE. spec_bdy_width ) .OR. ( j .LE. spec_bdy_width ) .OR. & + ( i .GE. ide - spec_bdy_width ) .OR. ( j .GE. jde - spec_bdy_width ) ) THEN + ter_temp(i,k,j) = ter_interpolated(i,k,j) + END IF + END DO + END DO + END DO + + ! Set nest elevation with temp values. All values not overwritten in the above + ! loops have been previously set in the initial assignment. + + DO j = jps , MIN(jpe, jde-1) + DO k = kps , kpe + DO i = ips , MIN(ipe, ide-1) + ter_input(i,k,j) = ter_temp(i,k,j) + END DO + END DO + END DO + +END SUBROUTINE blend_terrain + +SUBROUTINE store_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: ter_interpolated + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: ter_input + + INTEGER :: i , j , k + + DO j = jps , MIN(jpe, jde-1) + DO k = kps , kpe + DO i = ips , MIN(ipe, ide-1) + ter_interpolated(i,k,j) = ter_input(i,k,j) + END DO + END DO + END DO + +END SUBROUTINE store_terrain + + +SUBROUTINE input_terrain_rsmas ( grid , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + USE module_domain + IMPLICIT NONE + TYPE ( domain ) :: grid + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER :: i , j , k , myproc + INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_terrain + CHARACTER*256 :: message, message2 + CHARACTER*256 :: rsmas_data_path + +#if DM_PARALLEL +! Local globally sized arrays + REAL , DIMENSION(ids:ide,jds:jde) :: ht_g, xlat_g, xlon_g +#endif + + CALL wrf_get_myproc ( myproc ) + +#if 0 +CALL domain_clock_get ( grid, current_timestr=message2 ) +WRITE ( message , FMT = '(A," HT before ",I3)' ) TRIM(message2), grid%id +write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message) +do j = jps,jpe +do i = ips,ipe +write(30+myproc,*)grid%ht(i,j) +enddo +enddo +#endif + + CALL nl_get_rsmas_data_path(1,rsmas_data_path) + do i = 1, LEN(TRIM(rsmas_data_path)) + ipath(i) = ICHAR(rsmas_data_path(i:i)) + enddo + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + + CALL wrf_patch_to_global_real ( grid%xlat , xlat_g , grid%domdesc, ' ' , 'xy' , & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%xlong , xlon_g , grid%domdesc, ' ' , 'xy' , & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + + IF ( wrf_dm_on_monitor() ) THEN + CALL get_terrain ( grid%dx/1000., xlat_g(ids:ide,jds:jde), xlon_g(ids:ide,jds:jde), ht_g(ids:ide,jds:jde), & + ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) ) + WHERE ( ht_g(ids:ide,jds:jde) < -1000. ) ht_g(ids:ide,jds:jde) = 0. + ENDIF + + CALL wrf_global_to_patch_real ( ht_g , grid%ht , grid%domdesc, ' ' , 'xy' , & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) +#else + + CALL get_terrain ( grid%dx/1000., grid%xlat(ids:ide,jds:jde), grid%xlong(ids:ide,jds:jde), grid%ht(ids:ide,jds:jde), & + ide-ids+1,jde-jds+1,ide-ids+1,jde-jds+1, ipath, LEN(TRIM(rsmas_data_path)) ) + WHERE ( grid%ht(ids:ide,jds:jde) < -1000. ) grid%ht(ids:ide,jds:jde) = 0. + +#endif + +#if 0 +CALL domain_clock_get ( grid, current_timestr=message2 ) +WRITE ( message , FMT = '(A," HT after ",I3)' ) TRIM(message2), grid%id +write(30+myproc,*)ipe-ips+1,jpe-jps+1,trim(message) +do j = jps,jpe +do i = ips,ipe +write(30+myproc,*)grid%ht(i,j) +enddo +enddo +#endif + +END SUBROUTINE input_terrain_rsmas + +SUBROUTINE update_after_feedback_em ( grid & +! +#include "em_dummy_new_args.inc" +! + ) +! +! perform core specific updates, exchanges after +! model feedback (called from med_feedback_domain) -John +! + +! Driver layer modules + USE module_domain + USE module_configure + USE module_driver_constants + USE module_machine + USE module_tiles + USE module_dm + USE module_bc +! Mediation layer modules +! Registry generated module + USE module_state_description + + IMPLICIT NONE + + ! Subroutine interface block. + + TYPE(domain) , TARGET :: grid + + ! Definitions of dummy arguments +#include + + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + CALL wrf_debug( 500, "entering update_after_feedback_em" ) + +#ifdef DM_PARALLEL +# define REGISTER_I1 +# include +#endif + +! Obtain dimension information stored in the grid data structure. + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL wrf_debug( 500, "before HALO_EM_FEEDBACK.inc in update_after_feedback_em" ) +#ifdef DM_PARALLEL +#include "HALO_EM_FEEDBACK.inc" +#endif + CALL wrf_debug( 500, "leaving update_after_feedback_em" ) + +END SUBROUTINE update_after_feedback_em + diff --git a/wrfv2_fire/dyn_em/shift_domain_em.F b/wrfv2_fire/dyn_em/shift_domain_em.F new file mode 100644 index 00000000..e3fbea94 --- /dev/null +++ b/wrfv2_fire/dyn_em/shift_domain_em.F @@ -0,0 +1,137 @@ +SUBROUTINE shift_domain_em ( grid , disp_x, disp_y & +! +# include +! + ) + USE module_domain + USE module_timing + USE module_configure + USE module_dm + USE module_timing + IMPLICIT NONE + ! Arguments + INTEGER disp_x, disp_y ! number of parent domain points to move + TYPE(domain) , POINTER :: grid + ! Local + INTEGER i, j, ii + INTEGER px, py ! number and direction of nd points to move + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + TYPE (grid_config_rec_type) :: config_flags + + INTERFACE + ! need to split this routine to avoid clobbering certain widely used compilers + SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & +! +# include +! + ) + USE module_domain + USE module_timing + USE module_configure + USE module_dm + USE module_timing + IMPLICIT NONE + ! Arguments + INTEGER disp_x, disp_y ! number of parent domain points to move + TYPE(domain) , POINTER :: grid + TYPE (grid_config_rec_type) :: config_flags + + ! Definitions of dummy arguments to solve +#include + END SUBROUTINE shift_domain_em2 + END INTERFACE + + ! Definitions of dummy arguments to solve +#include + +#ifdef MOVE_NESTS +#ifdef DM_PARALLEL +# include +#endif + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + px = isign(config_flags%parent_grid_ratio,disp_x) + py = isign(config_flags%parent_grid_ratio,disp_y) + + grid%imask_nostag = 1 + grid%imask_xstag = 1 + grid%imask_ystag = 1 + grid%imask_xystag = 1 + + grid%imask_nostag(ips:min(ide-1,ipe),jps:min(jde-1,jpe)) = 0 + grid%imask_xstag(ips:ipe,jps:min(jde-1,jpe)) = 0 + grid%imask_ystag(ips:min(ide-1,ipe),jps:jpe) = 0 + grid%imask_xystag(ips:ipe,jps:jpe) = 0 + +! shift the nest domain in x + do ii = 1,abs(disp_x) +#include + enddo + + CALL shift_domain_em2 ( grid , disp_x, disp_y & +! +# include +! + ) + +#endif + +END SUBROUTINE shift_domain_em + +SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & +! +# include +! + ) + USE module_domain + USE module_timing + USE module_configure + USE module_dm + USE module_timing + IMPLICIT NONE + ! Arguments + INTEGER disp_x, disp_y ! number of parent domain points to move + TYPE(domain) , POINTER :: grid + ! Local + INTEGER i, j, ii + INTEGER px, py ! number and direction of nd points to move + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + TYPE (grid_config_rec_type) :: config_flags + + ! Definitions of dummy arguments to solve +#include + +#ifdef MOVE_NESTS + +#ifdef DM_PARALLEL +# include +#endif + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + px = isign(config_flags%parent_grid_ratio,disp_x) + py = isign(config_flags%parent_grid_ratio,disp_y) + +! shift the nest domain in y + do ii = 1,abs(disp_y) +#include + enddo + +#endif +END SUBROUTINE shift_domain_em2 + diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F new file mode 100644 index 00000000..b5b62531 --- /dev/null +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -0,0 +1,3505 @@ +!WRF:MEDIATION_LAYER:SOLVER + +SUBROUTINE solve_em ( grid , config_flags & +! Actual arguments generated from Registry +#include "em_dummy_new_args.inc" +! + ) + +! Driver layer modules + USE module_domain + USE module_configure + USE module_driver_constants + USE module_machine + USE module_tiles + USE module_dm +! Mediation layer modules +! Model layer modules + USE module_model_constants + USE module_small_step_em + USE module_em + USE module_big_step_utilities_em + USE module_bc + USE module_bc_em + USE module_solvedebug_em + USE module_physics_addtendc + USE module_diffusion_em +! Registry generated module + USE module_state_description + USE module_radiation_driver + USE module_surface_driver + USE module_cumulus_driver + USE module_microphysics_driver + USE module_microphysics_zero_out + USE module_pbl_driver + USE module_fire_driver + USE module_fddagd_driver + USE module_fddaobs_driver + USE module_diagnostics +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_chem_utilities +#endif + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , TARGET :: grid + + ! Definitions of dummy arguments to this routine (generated from Registry). +#include "em_dummy_new_decl.inc" + + ! Structure that contains run-time configuration (namelist) data for domain + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local data + + INTEGER :: k_start , k_end, its, ite, jts, jte + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER :: sids , side , sjds , sjde , skds , skde , & + sims , sime , sjms , sjme , skms , skme , & + sips , sipe , sjps , sjpe , skps , skpe + + + INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey + + INTEGER :: ij , iteration + INTEGER :: im , num_3d_m , ic , num_3d_c , is , num_3d_s + INTEGER :: loop + INTEGER :: sz + + LOGICAL :: specified_bdy, channel_bdy + +! storage for tendencies and decoupled state (generated from Registry) + +#include +! Previous time level of tracer arrays now defined as i1 variables; +! the state 4d arrays now redefined as 1-time level arrays in Registry. +! Benefit: save memory in nested runs, since only 1 domain is active at a +! time. Potential problem on stack-limited architectures: increases +! amount of data on program stack by making these automatic arrays. + + INTEGER :: rc + INTEGER :: number_of_small_timesteps, rk_step + INTEGER :: klevel,ijm,ijp,i,j,k,size1,size2 ! for prints/plots only + INTEGER :: idum1, idum2, dynamics_option + + INTEGER :: rk_order, iwmax, jwmax, kwmax + REAL :: dt_rk, dts_rk, dtm, wmax + INTEGER :: l,kte,kk + +! urban related variables + INTEGER :: NUM_ROOF_LAYERS, NUM_WALL_LAYERS, NUM_ROAD_LAYERS ! urban + +! fire related variables + REAL :: moad_dx, moad_dy + REAL :: moad_cen_lat, moad_cen_lon + +! Define benchmarking timers if -DBENCH is compiled +#include + +!---------------------- +! Executable statements +!---------------------- + +! Needed by some comm layers, grid%e.g. RSL. If needed, nmm_data_calls.inc is +! generated from the registry. The definition of REGISTER_I1 allows +! I1 data to be communicated in this routine if necessary. +#ifdef DM_PARALLEL +# define REGISTER_I1 +# include "em_data_calls.inc" +#endif + +! +!

+! solve_em is the main driver for advancing a grid a single timestep.
+! It is a mediation-layer routine -> DM and SM calls are made where 
+! needed for parallel processing.  
+!
+! solve_em can integrate the equations using 3 time-integration methods
+!      
+!    - 3rd order Runge-Kutta time integration (recommended)
+!      
+!    - 2nd order Runge-Kutta time integration
+!      
+! The main sections of solve_em are
+!     
+! (1) Runge-Kutta (RK) loop
+!     
+! (2) Non-timesplit physics (i.grid%e., tendencies computed for updating
+!     model state variables during the first RK sub-step (loop)
+!     
+! (3) Small (acoustic, sound) timestep loop - within the RK sub-steps
+!     
+! (4) scalar advance for moist and chem scalar variables (and TKE)
+!     within the RK sub-steps.
+!     
+! (5) time-split physics (after the RK step), currently this includes
+!     only microphyics
+!
+! A more detailed description of these sections follows.
+!
+! + +! Initialize timers if compiled with -DBENCH +#include + +! set runge-kutta solver (2nd or 3rd order) + + dynamics_option = config_flags%rk_ord + +! Obtain dimension information stored in the grid data structure. + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + + CALL get_ijk_from_subgrid ( grid , & + sids, side, sjds, sjde, skds, skde, & + sims, sime, sjms, sjme, skms, skme, & + sips, sipe, sjps, sjpe, skps, skpe ) + + k_start = kps + k_end = kpe + + num_3d_m = num_moist + num_3d_c = num_chem + num_3d_s = num_scalar + +! Compute these starting and stopping locations for each tile and number of tiles. +! See: http://www.mmm.ucar.edu/wrf/WG2/topics/settiles + CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe ) +!print *,grid%julian,grid%julday,' grid%julian,grid%julday in solve' + + grid%itimestep = grid%itimestep + 1 + +!********************************************************************** +! +! LET US BEGIN....... +! +! +!
+! (1) RK integration loop is named the "Runge_Kutta_loop:"
+!
+!   Predictor-corrector type time integration.
+!   Advection terms are evaluated at time t for the predictor step,
+!   and advection is re-evaluated with the latest predicted value for
+!   each succeeding time corrector step
+!
+!   2nd order Runge Kutta (rk_order = 2):
+!   Step 1 is taken to the midpoint predictor, step 2 is the full step.
+!
+!   3rd order Runge Kutta (rk_order = 3):
+!   Step 1 is taken to from t to dt/3, step 2 is from t to dt/2,
+!   and step 3 is from t to dt.
+!
+!   non-timesplit physics are evaluated during first RK step and
+!   these physics tendencies are stored for use in each RK pass.
+!
+! +!********************************************************************** + +#ifdef WRF_CHEM +! +! prepare chem aerosols for advection before communication +! + + kte=min(k_end,kde-1) +# ifdef DM_PARALLEL + if ( num_chem >= PARAM_FIRST_SCALAR ) then +!----------------------------------------------------------------------- +! see matching halo calls below for stencils +!-------------------------------------------------------------- + CALL wrf_debug ( 200 , ' call HALO_RK_CHEM' ) + IF ( config_flags%h_mom_adv_order <= 4 ) THEN +# include "HALO_EM_CHEM_E_3.inc" + if( config_flags%progn > 0 ) then +# include "HALO_EM_SCALAR_E_3.inc" + end if + ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN +# include "HALO_EM_CHEM_E_5.inc" + if( config_flags%progn > 0 ) then +# include "HALO_EM_SCALAR_E_5.inc" + end if + ELSE + WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + endif +# endif +!-------------------------------------------------------------- +#endif + + rk_order = config_flags%rk_ord + IF (grid%time_step_sound == 0) THEN +! auto-set option +! This function will give 4 for 6*dx and 6 for 10*dx and returns even numbers only + grid%time_step_sound = max ( 2 * ( INT (300.*grid%dt/grid%dx-0.01) + 1 ), 4 ) + WRITE(wrf_err_message,*)'dx, dt, time_step_sound=',grid%dx,grid%dt,grid%time_step_sound + CALL wrf_debug ( 50 , wrf_err_message ) + ENDIF + + grid%dts = grid%dt/float(grid%time_step_sound) + + Runge_Kutta_loop: DO rk_step = 1, rk_order + + ! Set the step size and number of small timesteps for + ! each part of the timestep + + dtm = grid%dt + IF ( rk_order == 1 ) THEN + + write(wrf_err_message,*)' leapfrog removed, error exit for dynamics_option = ',dynamics_option + CALL wrf_error_fatal( wrf_err_message ) + + ELSE IF ( rk_order == 2 ) THEN ! 2nd order Runge-Kutta timestep + + IF ( rk_step == 1) THEN + dt_rk = 0.5*grid%dt + dts_rk = grid%dts + number_of_small_timesteps = grid%time_step_sound/2 + ELSE + dt_rk = grid%dt + dts_rk = grid%dts + number_of_small_timesteps = grid%time_step_sound + ENDIF + + ELSE IF ( rk_order == 3 ) THEN ! third order Runge-Kutta + + IF ( rk_step == 1) THEN + dt_rk = grid%dt/3. + dts_rk = dt_rk + number_of_small_timesteps = 1 + ELSE IF (rk_step == 2) THEN + dt_rk = 0.5*grid%dt + dts_rk = grid%dts + number_of_small_timesteps = grid%time_step_sound/2 + ELSE + dt_rk = grid%dt + dts_rk = grid%dts + number_of_small_timesteps = grid%time_step_sound + ENDIF + + ELSE + + write(wrf_err_message,*)' unknown solver, error exit for dynamics_option = ',dynamics_option + CALL wrf_error_fatal( wrf_err_message ) + + END IF + +! +! Time level t is in the *_2 variable in the first part +! of the step, and in the *_1 variable after the predictor. +! the latest predicted values are stored in the *_2 variables. +! + CALL wrf_debug ( 200 , ' call rk_step_prep ' ) + +BENCH_START(step_prep_tim) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + DO ij = 1 , grid%num_tiles + + CALL rk_step_prep ( config_flags, rk_step, & + grid%em_u_2, grid%em_v_2, grid%em_w_2, grid%em_t_2, grid%em_ph_2, grid%em_mu_2, & + moist, & + grid%em_ru, grid%em_rv, grid%em_rw, grid%em_ww, grid%em_php, grid%em_alt, grid%em_muu, grid%em_muv, & + grid%em_mub, grid%em_mut, grid%em_phb, grid%em_pb, grid%em_p, grid%em_al, grid%em_alb, & + cqu, cqv, cqw, & + grid%msfu, grid%msfv, grid%msft, & + grid%em_fnm, grid%em_fnp, grid%em_dnw, grid%rdx, grid%rdy, & + num_3d_m, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + + END DO + !$OMP END PARALLEL DO +BENCH_END(step_prep_tim) + +#ifdef DM_PARALLEL +!----------------------------------------------------------------------- +! Stencils for patch communications (WCS, 29 June 2001) +! Note: the small size of this halo exchange reflects the +! fact that we are carrying the uncoupled variables +! as state variables in the mass coordinate model, as +! opposed to the coupled variables as in the height +! coordinate model. +! +! * * * * * +! * * * * * * * * * +! * + * * + * * * + * * +! * * * * * * * * * +! * * * * * +! +! 3D variables - note staggering! grid%em_ru(X), grid%em_rv(Y), grid%em_ww(grid%em_z), grid%em_php(grid%em_z) +! +!j grid%em_ru x +!j grid%em_rv x +!j grid%em_ww x +!j grid%em_php x +!j grid%em_alt x +!j grid%em_ph_2 x +!j grid%em_phb x +! +! the following are 2D (xy) variables +! +!j grid%em_muu x +!j grid%em_muv x +!j grid%em_mut x +!-------------------------------------------------------------- +# include "HALO_EM_A.inc" +#endif + +! set boundary conditions on variables +! from big_step_prep for use in big_step_proc + +#ifdef DM_PARALLEL +# include "PERIOD_BDY_EM_A.inc" +#endif + +! CALL set_tiles ( grid , ids , ide , jds , jde , ips-1 , ipe+1 , jps-1 , jpe+1 ) + +BENCH_START(set_phys_bc_tim) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 200 , ' call rk_phys_bc_dry_1' ) + + CALL rk_phys_bc_dry_1( config_flags, grid%em_ru, grid%em_rv, grid%em_rw, grid%em_ww, & + grid%em_muu, grid%em_muv, grid%em_mut, grid%em_php, grid%em_alt, grid%em_p, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + !TBH: need this 2nd timestep and later + CALL set_physical_bc3d( grid%em_al, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + CALL set_physical_bc3d( grid%em_ph_2, 'w', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + + END DO + !$OMP END PARALLEL DO +BENCH_END(set_phys_bc_tim) + + rk_step_is_one : IF (rk_step == 1) THEN ! only need to initialize diffusion tendencies + + ! initialize all tendencies to zero in order to update physics + ! tendencies first (separate from dry dynamics). + +BENCH_START(init_zero_tend_tim) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 200 , ' call init_zero_tendency' ) + CALL init_zero_tendency ( ru_tendf, rv_tendf, rw_tendf, & + ph_tendf, t_tendf, tke_tend, & + mu_tendf, & + moist_tend,chem_tend,scalar_tend, & + num_3d_m,num_3d_c,num_3d_s, & + rk_step, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + + END DO + !$OMP END PARALLEL DO +BENCH_END(init_zero_tend_tim) + +#ifdef DM_PARALLEL +# include "HALO_EM_PHYS_A.inc" +#endif + +! +!
+!(2) The non-timesplit physics begins with a call to "phy_prep"
+!    (which computes some diagnostic variables such as temperature,
+!    pressure, u and v at grid%em_p points, etc).  This is followed by
+!    calls to the physics drivers:
+!
+!              radiation,
+!              surface,
+!              pbl,
+!              cumulus,
+!              3D TKE and mixing.
+!
+!
+
+
+BENCH_START(phy_prep_tim)
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+      DO ij = 1 , grid%num_tiles
+
+         CALL wrf_debug ( 200 , ' call phy_prep' )
+         CALL phy_prep ( config_flags,                           &
+                         grid%em_mut, grid%em_muu, grid%em_muv, grid%em_u_2, &
+                         grid%em_v_2, grid%em_p, grid%em_pb, grid%em_alt,              &
+                         grid%em_ph_2, grid%em_phb, grid%em_t_2, grid%tsk, moist, num_3d_m,   &
+                         mu_3d, rho,                             &
+                         th_phy, p_phy, pi_phy, u_phy, v_phy,    &
+                         p8w, t_phy, t8w, grid%em_z, z_at_w,             &
+                         dz8w, grid%em_fnm, grid%em_fnp,                         &    
+                         grid%rthraten,                               &
+                         grid%rthblten, grid%rublten, grid%rvblten,             &
+                         grid%rqvblten, grid%rqcblten, grid%rqiblten,           &
+                         grid%rthcuten, grid%rqvcuten, grid%rqccuten,           &
+                         grid%rqrcuten, grid%rqicuten, grid%rqscuten,           &
+                         grid%rthften,  grid%rqvften,                      &
+                         grid%RUNDGDTEN, grid%RVNDGDTEN, grid%RTHNDGDTEN,       &
+                         grid%RQVNDGDTEN, grid%RMUNDGDTEN,                 &
+                         ids, ide, jds, jde, kds, kde,           &
+                         ims, ime, jms, jme, kms, kme,           &
+                         grid%i_start(ij), grid%i_end(ij),       &
+                         grid%j_start(ij), grid%j_end(ij),       &
+                         k_start, k_end                         )
+      ENDDO
+      !$OMP END PARALLEL DO
+
+BENCH_END(phy_prep_tim)
+
+!  physics to implement
+
+!      CALL set_tiles ( grid , ids , ide-1 , jds , jde-1 ips , ipe , jps , jpe )
+
+! Open MP loops are in physics drivers
+! radiation
+
+!-----------------------------------------------------------------
+! urban related variable are added to arguments of radiation_driver
+!-----------------------------------------------------------------
+
+         CALL wrf_debug ( 200 , ' call radiation_driver' )
+BENCH_START(rad_driver_tim)
+
+         CALL radiation_driver(                                           &
+     &         ACFRCV=grid%acfrcv      ,ACFRST=grid%acfrst      ,ALBEDO=grid%albedo      &
+     &        ,CFRACH=grid%cfrach      ,CFRACL=grid%cfracl      ,CFRACM=grid%cfracm      &
+     &        ,CUPPT=grid%cuppt        ,CZMEAN=grid%czmean      ,DT=grid%dt              &
+     &        ,DZ8W=dz8w          ,EMISS=grid%emiss        ,GLW=grid%glw            &
+     &        ,GMT=grid%gmt            ,GSW=grid%gsw            ,HBOT=grid%hbot          &
+     &        ,HTOP=grid%htop ,HBOTR=grid%hbotr, HTOPR=grid%htopr ,ICLOUD=config_flags%icloud &
+     &        ,ITIMESTEP=grid%itimestep,JULDAY=grid%julday, JULIAN=grid%julian      &
+     &        ,JULYR=grid%julyr        ,LW_PHYSICS=config_flags%ra_lw_physics  &
+     &        ,NCFRCV=grid%ncfrcv      ,NCFRST=grid%ncfrst      ,NPHS=1             &
+     &        ,P8W=p8w            ,P=p_phy            ,PI=pi_phy          &
+     &        ,RADT=grid%radt     ,RA_CALL_OFFSET=grid%ra_call_offset     &
+     &        ,RHO=rho            ,RLWTOA=grid%rlwtoa                          &
+     &        ,RSWTOA=grid%rswtoa      ,RTHRATEN=grid%rthraten                      &
+     &        ,RTHRATENLW=grid%rthratenlw                                      &
+     &        ,RTHRATENSW=grid%rthratensw                  ,SNOW=grid%snow          &
+     &        ,STEPRA=grid%stepra      ,SWDOWN=grid%swdown      ,SWDOWNC=grid%swdownc    &
+     &        ,SW_PHYSICS=config_flags%ra_sw_physics  ,T8W=t8w            &
+     &        ,T=t_phy            ,TAUCLDC=grid%taucldc    ,TAUCLDI=grid%taucldi    &
+     &        ,TSK=grid%tsk            ,VEGFRA=grid%vegfra     ,WARM_RAIN=grid%warm_rain &
+     &        ,XICE=grid%xice                                                  &
+     &        ,XLAND=grid%xland        ,XLAT=grid%xlat          ,XLONG=grid%xlong        &
+!Optional urban
+     &        ,DECLIN_URB=grid%declin_urb        ,COSZ_URB2D=grid%cosz_urb2d        &
+     &        ,OMG_URB2D=grid%omg_urb2d                                        &
+!
+     &        ,Z=grid%em_z                                                        &
+     &        ,LEVSIZ=grid%levsiz, N_OZMIXM=num_ozmixm                    &
+     &        ,N_AEROSOLC=num_aerosolc                                    &
+     &        ,PAERLEV=grid%paerlev                                       &
+     &        ,CAM_ABS_DIM1=grid%cam_abs_dim1, CAM_ABS_DIM2=grid%cam_abs_dim2 &
+     &        ,CAM_ABS_FREQ_S=grid%cam_abs_freq_s                         &
+     &        ,XTIME=grid%xtime                                                &
+            ! indexes
+     &        ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde          &
+     &        ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme          &
+     &        ,i_start=grid%i_start,i_end=min(grid%i_end, ide-1)          &
+     &        ,j_start=grid%j_start,j_end=min(grid%j_end, jde-1)          &
+     &        ,kts=k_start, kte=min(k_end,kde-1)                          &
+     &        ,num_tiles=grid%num_tiles                                   &
+            ! Optional                          
+     &        , CLDFRA=grid%cldfra                                        &
+     &        , PB=grid%em_pb                                                     &
+     &        , F_ICE_PHY=grid%f_ice_phy,F_RAIN_PHY=grid%f_rain_phy                 &
+     &        , QV=moist(ims,kms,jms,P_QV), F_QV=F_QV                     &
+     &        , QC=moist(ims,kms,jms,P_QC), F_QC=F_QC                     &
+     &        , QR=moist(ims,kms,jms,P_QR), F_QR=F_QR                     &
+     &        , QI=moist(ims,kms,jms,P_QI), F_QI=F_QI                     &
+     &        , QS=moist(ims,kms,jms,P_QS), F_QS=F_QS                     &
+     &        , QG=moist(ims,kms,jms,P_QG), F_QG=F_QG                     &
+     &        , QNDROP=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP    &
+#ifdef ACFLUX
+     &        ,ACSWUPT=acswupt    ,ACSWUPTC=acswuptc                      &
+     &        ,ACSWDNT=acswdnt    ,ACSWDNTC=acswdntc                      &
+     &        ,ACSWUPB=acswupb    ,ACSWUPBC=acswupbc                      &
+     &        ,ACSWDNB=acswdnb    ,ACSWDNBC=acswdnbc                      &
+     &        ,ACLWUPT=aclwupt    ,ACLWUPTC=aclwuptc                      &
+     &        ,ACLWDNT=aclwdnt    ,ACLWDNTC=aclwdntc                      &
+     &        ,ACLWUPB=aclwupb    ,ACLWUPBC=aclwupbc                      &
+     &        ,ACLWDNB=aclwdnb    ,ACLWDNBC=aclwdnbc                      &
+     &        ,SWUPT=swupt    ,SWUPTC=swuptc                              &
+     &        ,SWDNT=swdnt    ,SWDNTC=swdntc                              &
+     &        ,SWUPB=swupb    ,SWUPBC=swupbc                              &
+     &        ,SWDNB=swdnb    ,SWDNBC=swdnbc                              &
+     &        ,LWUPT=lwupt    ,LWUPTC=lwuptc                              &
+     &        ,LWDNT=lwdnt    ,LWDNTC=lwdntc                              &
+     &        ,LWUPB=lwupb    ,LWUPBC=lwupbc                              &
+     &        ,LWDNB=lwdnb    ,LWDNBC=lwdnbc                              &
+#endif
+     &        ,LWCF=grid%lwcf                                                  &
+     &        ,SWCF=grid%swcf                                                  &
+     &        ,OLR=grid%olr                                                    &
+     &        ,OZMIXM=grid%ozmixm, PIN=grid%pin                                     &
+     &        ,M_PS_1=grid%m_ps_1, M_PS_2=grid%m_ps_2, AEROSOLC_1=grid%aerosolc_1        &
+     &        ,AEROSOLC_2=grid%aerosolc_2, M_HYBI0=grid%m_hybi                      &
+     &        ,ABSTOT=grid%abstot, ABSNXT=grid%absnxt, EMSTOT=grid%emstot                &
+#ifdef WRF_CHEM
+     &        ,CU_RAD_FEEDBACK=config_flags%cu_rad_feedback                &
+     &        ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback                &
+     &        ,QC_ADJUST=grid%GD_CLOUD_B , QI_ADJUST=grid%GD_CLOUD2_B         &
+     &        ,PM2_5_DRY=grid%pm2_5_dry, PM2_5_WATER=grid%pm2_5_water               &
+     &        ,PM2_5_DRY_EC=grid%pm2_5_dry_ec                                  &
+     &        ,TAUAER300=grid%tauaer1, TAUAER400=grid%tauaer2 & ! jcb
+     &        ,TAUAER600=grid%tauaer3, TAUAER999=grid%tauaer4 & ! jcb
+     &        ,GAER300=grid%gaer1, GAER400=grid%gaer2, GAER600=grid%gaer3, GAER999=grid%gaer4 & ! jcb
+     &        ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & ! jcb
+#endif
+     &                                                              )
+
+BENCH_END(rad_driver_tim)
+
+!********* Surface driver
+! surface
+
+BENCH_START(surf_driver_tim)
+
+!-----------------------------------------------------------------
+! urban related variable are added to arguments of surface_driver
+!-----------------------------------------------------------------
+      NUM_ROOF_LAYERS = grid%num_soil_layers !urban
+      NUM_WALL_LAYERS = grid%num_soil_layers !urban
+      NUM_ROAD_LAYERS = grid%num_soil_layers !urban
+
+      CALL wrf_debug ( 200 , ' call surface_driver' )
+      CALL surface_driver(                                                &
+     &         ACSNOM=grid%acsnom      ,ACSNOW=grid%acsnow      ,AKHS=grid%akhs          &
+     &        ,AKMS=grid%akms          ,ALBBCK=grid%albbck      ,ALBEDO=grid%albedo      &
+     &        ,BR=br              ,CANWAT=grid%canwat      ,CHKLOWQ=chklowq    &
+     &        ,CT=grid%ct              ,DT=grid%dt         ,DX=grid%dx         &
+     &        ,DZ8W=dz8w          ,DZS=grid%dzs            ,FLHC=grid%flhc          &
+     &        ,FLQC=grid%flqc          ,GLW=grid%glw            ,GRDFLX=grid%grdflx      &
+     &        ,GSW=grid%gsw    ,SWDOWN=grid%swdown        ,GZ1OZ0=gz1oz0      ,HFX=grid%hfx              &
+     &        ,HT=grid%ht              ,IFSNOW=config_flags%ifsnow      ,ISFFLX=config_flags%isfflx      &
+     &        ,ISLTYP=grid%isltyp      ,ITIMESTEP=grid%itimestep                    &
+     &        ,IVGTYP=grid%ivgtyp      ,LH=grid%lh              ,LOWLYR=grid%lowlyr      &
+     &        ,MAVAIL=grid%mavail      ,NUM_SOIL_LAYERS=config_flags%num_soil_layers        &
+     &        ,P8W=p8w            ,PBLH=grid%pblh          ,PI_PHY=pi_phy      &
+     &        ,PSFC=grid%psfc          ,PSHLTR=pshltr      ,PSIH=psih          &
+     &        ,PSIM=psim          ,P_PHY=p_phy        ,Q10=q10            &
+     &        ,Q2=grid%q2              ,QFX=grid%qfx            ,QSFC=grid%qsfc          &
+     &        ,QSHLTR=qshltr      ,QZ0=grid%qz0            ,RAINCV=grid%raincv      &
+     &        ,RA_LW_PHYSICS=config_flags%ra_lw_physics            ,RHO=rho            &
+     &        ,RMOL=grid%rmol          ,SFCEVP=grid%sfcevp      ,SFCEXC=grid%sfcexc      &
+     &        ,SFCRUNOFF=grid%sfcrunoff                                        &
+     &        ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics                        &
+     &        ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics  ,SH2O=grid%sh2o          &
+     &        ,SHDMAX=grid%shdmax      ,SHDMIN=grid%shdmin      ,SMOIS=grid%smois        &
+     &        ,SMSTAV=grid%smstav      ,SMSTOT=grid%smstot      ,SNOALB=grid%snoalb      &
+     &        ,SNOW=grid%snow          ,SNOWC=grid%snowc        ,SNOWH=grid%snowh        &
+     &        ,SST=grid%sst            ,SST_UPDATE=grid%sst_update                  &
+     &        ,STEPBL=grid%stepbl      ,TH10=th10          ,TH2=grid%th2            &
+     &        ,THZ0=grid%thz0          ,TH_PHY=th_phy      ,TKE_MYJ=grid%tke_myj    &
+     &        ,TMN=grid%tmn            ,TSHLTR=tshltr      ,TSK=grid%tsk            &
+     &        ,TSLB=grid%tslb          ,T_PHY=t_phy        ,U10=grid%u10            &
+     &        ,URATX=grid%uratx        ,VRATX=grid%vratx   ,TRATX=grid%tratx        &
+     &        ,UDRUNOFF=grid%udrunoff  ,UST=grid%ust       ,UZ0=grid%uz0            &
+     &        ,U_FRAME=grid%u_frame    ,U_PHY=u_phy        ,V10=grid%v10            &
+     &        ,VEGFRA=grid%vegfra      ,VZ0=grid%vz0       ,V_FRAME=grid%v_frame    &
+     &        ,V_PHY=v_phy             ,WARM_RAIN=grid%warm_rain                    &
+     &        ,WSPD=wspd               ,XICE=grid%xice     ,XLAND=grid%xland        &
+     &        ,Z0=grid%z0              ,Z=grid%em_z        ,ZNT=grid%znt            &
+     &        ,ZS=grid%zs                                                           &
+     &        ,DECLIN_URB=grid%declin_urb  ,COSZ_URB2D=grid%cosz_urb2d    & !I urban
+     &        ,OMG_URB2D=grid%omg_urb2d    ,xlat_urb2d=grid%XLAT          & !I urban
+     &        ,NUM_ROOF_LAYERS=num_roof_layers                            & !I urban
+     &        ,NUM_WALL_LAYERS=num_wall_layers                            & !I urban
+     &        ,NUM_ROAD_LAYERS=num_road_layers                            &
+     &        ,DZR=grid%dzr ,DZB=grid%dzb ,DZG=grid%dzg                   & !I urban
+     &        ,TR_URB2D=grid%tr_urb2d ,TB_URB2D=grid%tb_urb2d             &
+     &        ,TG_URB2D=grid%tg_urb2d                                     & !H urban
+     &        ,TC_URB2D=grid%tc_urb2d ,QC_URB2D=grid%qc_urb2d             & !H urban
+     &        ,UC_URB2D=grid%uc_urb2d                                     & !H urban
+     &        ,XXXR_URB2D=grid%xxxr_urb2d                                 &
+     &        ,XXXB_URB2D=grid%xxxb_urb2d                                 & !H urban
+     &        ,XXXG_URB2D=grid%xxxg_urb2d                                 &
+     &        ,XXXC_URB2D=grid%xxxc_urb2d                                 & !H urban
+     &        ,TRL_URB3D=grid%trl_urb3d   ,TBL_URB3D=grid%tbl_urb3d       & !H urban
+     &        ,TGL_URB3D=grid%tgl_urb3d                                   & !H urban
+     &        ,SH_URB2D=grid%sh_urb2d     ,LH_URB2D=grid%lh_urb2d         &
+     &        ,G_URB2D=grid%g_urb2d                                       & !H urban
+     &        ,RN_URB2D=grid%rn_urb2d     , TS_URB2D=grid%ts_urb2d        & !H urban 
+     &        ,FRC_URB2D=grid%frc_urb2d                                   & !H urban
+     &        ,UTYPE_URB2D=grid%utype_urb2d                               & !H urban
+     &        ,ucmcall=grid%ucmcall                                       & !H urban
+           ! Indexes
+     &        ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde          &
+     &        ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme          &
+     &        , I_START=grid%i_start,I_END=min(grid%i_end, ide-1)         &
+     &        , J_START=grid%j_start,J_END=min(grid%j_end, jde-1)         &
+     &        , KTS=k_start, KTE=min(k_end,kde-1)                         &
+     &        , NUM_TILES=grid%num_tiles                                  &
+           ! Optional
+     &        ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV                 &
+     &        ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC                 &
+     &        ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR                 &
+     &        ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI                 &
+     &        ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS                 &
+     &        ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG                 &
+     &        ,CAPG=grid%capg, EMISS=grid%emiss, HOL=hol,MOL=grid%mol                    &
+     &        ,RAINBL=grid%rainbl,SR=grid%em_sr                                              &
+     &        ,RAINNCV=grid%rainncv,REGIME=regime,T2=grid%t2,THC=grid%thc                &
+     &        ,QSG=grid%qsg,QVG=grid%qvg,QCG=grid%qcg,SOILT1=grid%soilt1,TSNAV=grid%tsnav          & ! ruc lsm
+     &        ,SMFR3D=grid%smfr3d,KEEPFR3DFLAG=grid%keepfr3dflag                    & ! ruc lsm
+     &        ,POTEVP=grid%em_POTEVP, SNOPCX=grid%em_SNOPCX, SOILTB=grid%em_SOILTB                & ! ruc lsm
+     &                                                              )
+BENCH_END(surf_driver_tim)
+
+!*********
+! pbl
+
+      CALL wrf_debug ( 200 , ' call pbl_driver' )
+BENCH_START(pbl_driver_tim)
+      CALL pbl_driver(                                                    &
+     &         AKHS=grid%akhs          ,AKMS=grid%akms                              &
+     &        ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics                 &
+     &        ,BR=br              ,CHKLOWQ=chklowq    ,CT=grid%ct              &
+     &        ,DT=grid%dt              ,DX=grid%dx              ,DZ8W=dz8w          &
+     &        ,EL_MYJ=grid%el_myj      ,EXCH_H=grid%exch_h      ,GRDFLX=grid%grdflx      &
+     &        ,GZ1OZ0=gz1oz0      ,HFX=grid%hfx            ,HT=grid%ht              &
+     &        ,ITIMESTEP=grid%itimestep                    ,KPBL=grid%kpbl          &
+     &        ,LH=grid%lh              ,LOWLYR=grid%lowlyr      ,P8W=p8w            &
+     &        ,PBLH=grid%pblh          ,PI_PHY=pi_phy      ,PSIH=psih          &
+     &        ,PSIM=psim          ,P_PHY=p_phy        ,QFX=grid%qfx            &
+     &        ,QSFC=grid%qsfc          ,QZ0=grid%qz0                                &
+     &        ,RA_LW_PHYSICS=config_flags%ra_lw_physics                   &
+     &        ,RHO=rho            ,RQCBLTEN=grid%rqcblten  ,RQIBLTEN=grid%rqiblten  &
+     &        ,RQVBLTEN=grid%rqvblten  ,RTHBLTEN=grid%rthblten  ,RUBLTEN=grid%rublten    &
+     &        ,RVBLTEN=grid%rvblten    ,SNOW=grid%snow          ,STEPBL=grid%stepbl      &
+     &        ,THZ0=grid%thz0          ,TH_PHY=th_phy      ,TKE_MYJ=grid%tke_myj    &
+     &        ,TSK=grid%tsk            ,T_PHY=t_phy        ,UST=grid%ust            &
+     &        ,UZ0=grid%uz0            ,U_FRAME=grid%u_frame    ,U_PHY=u_phy        &
+     &        ,VZ0=grid%vz0            ,V_FRAME=grid%v_frame    ,V_PHY=v_phy        &
+     &        ,WARM_RAIN=grid%warm_rain                    ,WSPD=wspd          &
+     &        ,XICE=grid%xice          ,XLAND=grid%xland        ,Z=grid%em_z                &
+     &        ,ZNT=grid%znt                                                    &
+     &        ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde          &
+     &        ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme          &
+     &        ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)          &
+     &        ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)          &
+     &        ,KTS=k_start, KTE=min(k_end,kde-1)                          &
+     &        ,NUM_TILES=grid%num_tiles                                   &
+          ! optional
+     &        ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV                 &
+     &        ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC                 &
+     &        ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR                 &
+     &        ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI                 &
+     &        ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS                 &
+     &        ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG                 &
+     &        ,HOL=HOL, MOL=grid%mol, REGIME=REGIME                            &
+     &                                                          )
+
+BENCH_END(pbl_driver_tim)
+
+!*****
+! fire 
+
+      IF ((grid%sr_x > 0 .OR. grid%sr_y > 0) .AND. config_flags%ifire > 0) THEN
+
+         CALL wrf_debug ( 200 , ' call fire_driver, ifire = ', config_flags%ifire )
+
+BENCH_START(fire_driver_tim)
+
+         CALL nl_get_dx(1,moad_dx)
+         CALL nl_get_dy(1,moad_dy)
+         CALL nl_get_cen_lat(1,moad_cen_lat)
+         CALL nl_get_cen_lon(1,moad_cen_lon)
+
+         CALL fire_driver(config_flags%ifire                        & ! send
+            ,u_phy,v_phy,grid%u_frame,grid%v_frame,grid%em_mut,rho  &
+            ,grid%itimestep,grid%dt,grid%dx,grid%dy                 &
+            ,grid%em_z,z_at_w,dz8w,grid%ht                          &
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,sids,side, skds,skde, sjds,sjde                        &
+            ,sims,sime, skms,skme, sjms,sjme                        &
+            ,sips,sipe, skps,skpe, sjps,sjpe                        &
+            ,k_start,min(k_end,kde-1),grid%num_tiles                &
+            ,grid%i_start,min(grid%i_end,ide-1)                     &
+            ,grid%j_start,min(grid%j_end,jde-1)                     &
+            ,grid%grid_id                                           &
+            ,config_flags%cen_lat,config_flags%cen_lon              &
+            ,grid%em_lat_ll_d,grid%em_lon_ll_d                      &
+            ,moad_cen_lat,moad_cen_lon                              &
+            ,head_grid%em_lat_ll_d,head_grid%em_lon_ll_d            &
+            ,head_grid%dx,head_grid%dy                              &
+            ,model_config_rec%s_we(1), model_config_rec%e_we(1)     &
+            ,model_config_rec%s_sn(1), model_config_rec%e_sn(1)     &
+            ,grid%sr_x,grid%sr_y                                    &
+            ,config_flags%fire_lat_init,config_flags%fire_lon_init  &
+            ,config_flags%fire_ign_time                             &
+            ,config_flags%fire_shape,config_flags%fire_crwn_hgt     &
+            ,config_flags%fire_ext_grnd,config_flags%fire_ext_crwn  &
+            ,config_flags%fire_sprd_mdl                             &
+            ,config_flags%fire_fuel_read,config_flags%fire_fuel_cat & 
+            ,grid%nfuel_cat,grid%nfl,grid%nfl_t,grid%nfl_c          & ! send and recv
+            ,grid%ncod,grid%in1,grid%in2,grid%ixb,grid%iyb          &
+            ,grid%icn,grid%fg,grid%fc,grid%r_0,grid%bbb             &
+            ,grid%betafl,grid%phiwc,grid%area,grid%area2            &
+            ,grid%zf,grid%zsf,grid%tign_g,grid%tign_c               &
+            ,grid%tign_crt,grid%xfg,grid%yfg,grid%xcd               &
+            ,grid%ycd,grid%xcn,grid%ycn,grid%sprdx,grid%sprdy       &
+            ,grid%rthfrten,grid%rqvfrten                            &
+            ,grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx)         ! recv
+
+BENCH_END(fire_driver_tim)
+
+      ENDIF
+
+! cumulus para.
+
+          CALL wrf_debug ( 200 , ' call cumulus_driver' )
+
+BENCH_START(cu_driver_tim)
+         CALL cumulus_driver(                                             &
+                 ! Prognostic variables
+     &              U=u_phy   ,V=v_phy   ,TH=th_phy  ,T=t_phy             &
+     &             ,W=grid%em_w_2     ,P=p_phy   ,PI=pi_phy  ,RHO=rho             &
+                 ! Other arguments
+     &             ,ITIMESTEP=grid%itimestep ,DT=grid%dt      ,DX=grid%dx                &
+     &             ,RAINC=grid%rainc   ,RAINCV=grid%raincv   ,NCA=grid%nca               &
+     &             ,HTOP=grid%cutop    ,HBOT=grid%cubot      ,KPBL=grid%kpbl             &
+     &             ,DZ8W=dz8w     ,P8W=p8w                                &
+     &             ,W0AVG=grid%w0avg   ,STEPCU=grid%stepcu                          &
+     &             ,CLDEFI=grid%cldefi ,LOWLYR=grid%lowlyr ,XLAND=grid%xland             &
+     &             ,APR_GR=grid%apr_gr ,APR_W=grid%apr_w   ,APR_MC=grid%apr_mc           &
+     &             ,APR_ST=grid%apr_st ,APR_AS=grid%apr_as ,APR_CAPMA=grid%apr_capma     &
+     &             ,APR_CAPME=grid%apr_capme          ,APR_CAPMI=grid%apr_capmi     &
+     &             ,MASS_FLUX=grid%mass_flux          ,XF_ENS=grid%xf_ens           &
+     &             ,PR_ENS=grid%pr_ens ,HT=grid%ht                                  &
+     &             ,ENSDIM=config_flags%ensdim ,MAXIENS=config_flags%maxiens ,MAXENS=config_flags%maxens         &
+     &             ,MAXENS2=config_flags%maxens2                ,MAXENS3=config_flags%maxens3       &
+     &             ,CU_ACT_FLAG=cu_act_flag   ,WARM_RAIN=grid%warm_rain        &
+     &             ,GSW=grid%gsw                                               &
+                 ! Selection flag
+     &             ,CU_PHYSICS=config_flags%cu_physics                    &
+                 ! Dimension arguments
+     &             ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
+     &             ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
+     &             ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
+     &             ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
+     &             ,KTS=k_start, KTE=min(k_end,kde-1)                     &
+     &             ,NUM_TILES=grid%num_tiles                              &
+                 ! Moisture tendency arguments
+     &             ,RQVCUTEN=grid%rqvcuten , RQCCUTEN=grid%rqccuten                 &
+     &             ,RQSCUTEN=grid%rqscuten , RQICUTEN=grid%rqicuten                 &
+     &             ,RQRCUTEN=grid%rqrcuten , RQVBLTEN=grid%rqvblten                 &
+     &             ,RQVFTEN=grid%rqvften                                       &
+                 ! Other tendency arguments
+     &             ,RTHRATEN=grid%rthraten , RTHBLTEN=grid%rthblten                 &
+     &             ,RTHCUTEN=grid%rthcuten , RTHFTEN=grid%rthften                   &
+                 ! Moisture tracer arguments
+     &             ,QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV            &
+     &             ,QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC            &
+     &             ,QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR            &
+     &             ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI            &
+     &             ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS            &
+     &             ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG            &
+#ifdef WRF_CHEM
+     &             ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2                          &
+#endif
+     &                                                          )
+BENCH_END(cu_driver_tim)
+
+! fdda
+
+          CALL wrf_debug ( 200 , ' call fddagd_driver' )
+
+BENCH_START(fdda_driver_tim)
+   CALL fddagd_driver(itimestep=grid%itimestep,dt=grid%dt,xtime=grid%XTIME,         &
+                  id=grid%id,      &
+                  RUNDGDTEN=grid%rundgdten,RVNDGDTEN=grid%rvndgdten,                &
+                  RTHNDGDTEN=grid%rthndgdten,RQVNDGDTEN=grid%rqvndgdten,            &
+                  RMUNDGDTEN=grid%rmundgdten,                                  &
+                  u_ndg_old=fdda3d(ims,kms,jms,P_u_ndg_old),              &
+                  v_ndg_old=fdda3d(ims,kms,jms,P_v_ndg_old),              &
+                  t_ndg_old=fdda3d(ims,kms,jms,P_t_ndg_old),              &
+                  q_ndg_old=fdda3d(ims,kms,jms,P_q_ndg_old),              &
+                  mu_ndg_old=fdda2d(ims,1,jms,P_mu_ndg_old),              &
+                  u_ndg_new=fdda3d(ims,kms,jms,P_u_ndg_new),              &
+                  v_ndg_new=fdda3d(ims,kms,jms,P_v_ndg_new),              &
+                  t_ndg_new=fdda3d(ims,kms,jms,P_t_ndg_new),              &
+                  q_ndg_new=fdda3d(ims,kms,jms,P_q_ndg_new),              &
+                  mu_ndg_new=fdda2d(ims,1,jms,P_mu_ndg_new),              &
+                  u3d=grid%em_u_2,v3d=grid%em_v_2,th_phy=th_phy,rho=rho,moist=moist,      &
+                  p_phy=p_phy,pi_phy=pi_phy,p8w=p8w,t_phy=t_phy,          &
+                  dz8w=dz8w,z=grid%em_z,z_at_w=z_at_w,                            &
+                  config_flags=config_flags,dx=grid%DX,n_moist=num_3d_m,  &
+                  STEPFG=grid%STEPFG,                                          &
+                  pblh=grid%pblh,ht=grid%ht,                                        &
+                    IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
+                   ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
+                   ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
+                   ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
+                   ,KTS=k_start, KTE=min(k_end,kde-1)                     &
+                   , num_tiles=grid%num_tiles                             )
+BENCH_END(fdda_driver_tim)
+
+! calculate_phy_tend
+
+BENCH_START(cal_phy_tend)
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call calculate_phy_tend' )
+          CALL calculate_phy_tend (config_flags,grid%em_mut,grid%em_muu,grid%em_muv,pi_phy,            &
+                     grid%rthraten,                                         &
+                     grid%rublten,grid%rvblten,grid%rthblten,                         &
+                     grid%rqvblten,grid%rqcblten,grid%rqiblten,                       &
+                     grid%rthcuten,grid%rqvcuten,grid%rqccuten,grid%rqrcuten,              &
+                     grid%rqicuten,grid%rqscuten,                                &
+                     grid%RUNDGDTEN,grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RQVNDGDTEN,        &
+                     grid%RMUNDGDTEN,                                       &
+                     ids,ide, jds,jde, kds,kde,                        &
+                     ims,ime, jms,jme, kms,kme,                        &
+                     grid%i_start(ij), min(grid%i_end(ij),ide-1),      &
+                     grid%j_start(ij), min(grid%j_end(ij),jde-1),      &
+                     k_start    , min(k_end,kde-1)                     )
+
+      ENDDO
+      !$OMP END PARALLEL DO
+BENCH_END(cal_phy_tend)
+
+! tke diffusion
+
+     IF(config_flags%diff_opt .eq. 2 .OR. config_flags%diff_opt .eq. 1) THEN
+
+BENCH_START(comp_diff_metrics_tim)
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+
+       DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call compute_diff_metrics ' )
+          CALL compute_diff_metrics ( config_flags, grid%em_ph_2, grid%em_phb, grid%em_z, grid%em_rdz, grid%em_rdzw, &
+                                      grid%em_zx, grid%em_zy, grid%rdx, grid%rdy,                      &
+                                      ids, ide, jds, jde, kds, kde,          &
+                                      ims, ime, jms, jme, kms, kme,          &
+                                      grid%i_start(ij), grid%i_end(ij),      &
+                                      grid%j_start(ij), grid%j_end(ij),      &
+                                      k_start    , k_end                    )
+       ENDDO
+       !$OMP END PARALLEL DO
+BENCH_END(comp_diff_metrics_tim)
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_A1.inc"
+#endif
+
+BENCH_START(tke_diff_bc_tim)
+       DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call bc for diffusion_metrics ' )
+          CALL set_physical_bc3d( grid%em_rdzw , 'w', config_flags,           &
+                                  ids, ide, jds, jde, kds, kde,       &
+                                  ims, ime, jms, jme, kms, kme,       &
+                                  ips, ipe, jps, jpe, kps, kpe,       &
+                                  grid%i_start(ij), grid%i_end(ij),   &
+                                  grid%j_start(ij), grid%j_end(ij),   &
+                                  k_start    , k_end                 )
+          CALL set_physical_bc3d( grid%em_rdz , 'w', config_flags,            &
+                                  ids, ide, jds, jde, kds, kde,       &
+                                  ims, ime, jms, jme, kms, kme,       &
+                                  ips, ipe, jps, jpe, kps, kpe,       &
+                                  grid%i_start(ij), grid%i_end(ij),   &
+                                  grid%j_start(ij), grid%j_end(ij),   &
+                                  k_start    , k_end                 )
+          CALL set_physical_bc3d( grid%em_z , 'w', config_flags,              &
+                                  ids, ide, jds, jde, kds, kde,       &
+                                  ims, ime, jms, jme, kms, kme,       &
+                                  ips, ipe, jps, jpe, kps, kpe,       &
+                                  grid%i_start(ij), grid%i_end(ij),   &
+                                  grid%j_start(ij), grid%j_end(ij),   &
+                                  k_start    , k_end                 )
+          CALL set_physical_bc3d( grid%em_zx , 'w', config_flags,             &
+                                  ids, ide, jds, jde, kds, kde,       &
+                                  ims, ime, jms, jme, kms, kme,       &
+                                  ips, ipe, jps, jpe, kps, kpe,       &
+                                  grid%i_start(ij), grid%i_end(ij),   &
+                                  grid%j_start(ij), grid%j_end(ij),   &
+                                  k_start    , k_end                 )
+          CALL set_physical_bc3d( grid%em_zy , 'w', config_flags,             &
+                                  ids, ide, jds, jde, kds, kde,       &
+                                  ims, ime, jms, jme, kms, kme,       &
+                                  ips, ipe, jps, jpe, kps, kpe,       &
+                                  grid%i_start(ij), grid%i_end(ij),   &
+                                  grid%j_start(ij), grid%j_end(ij),   &
+                                  k_start    , k_end                 )
+
+       ENDDO
+BENCH_END(tke_diff_bc_tim)
+
+#ifdef DM_PARALLEL
+#     include "HALO_EM_TKE_C.inc"
+#endif
+
+BENCH_START(deform_div_tim)
+
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+
+       DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call cal_deform_and_div' )
+          CALL cal_deform_and_div ( config_flags,grid%em_u_2,grid%em_v_2,grid%em_w_2,grid%div,        &
+                                    grid%defor11,grid%defor22,grid%defor33,grid%defor12,     &
+                                    grid%defor13,grid%defor23,                     &
+                                    grid%u_base, grid%v_base,grid%msfu,grid%msfv,grid%msft,       &
+                                    grid%rdx, grid%rdy, grid%em_dn, grid%em_dnw, grid%em_rdz, grid%em_rdzw,        &
+                                    grid%em_fnm,grid%em_fnp,grid%cf1,grid%cf2,grid%cf3,grid%em_zx,grid%em_zy,           &
+                                    ids, ide, jds, jde, kds, kde,        &
+                                    ims, ime, jms, jme, kms, kme,        &
+                                    grid%i_start(ij), grid%i_end(ij),    &
+                                    grid%j_start(ij), grid%j_end(ij),    &
+                                    k_start    , k_end                  )
+       ENDDO
+       !$OMP END PARALLEL DO
+BENCH_END(deform_div_tim)
+
+
+#ifdef DM_PARALLEL
+#     include "HALO_EM_TKE_D.inc"
+#endif
+
+
+! calculate tke, kmh, and kmv
+
+BENCH_START(calc_tke_tim)
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+
+       DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call calculate_km_kh' )
+          CALL calculate_km_kh( config_flags,grid%dt,grid%dampcoef,grid%zdamp,config_flags%damp_opt,     &
+                                grid%xkmh,grid%xkmhd,grid%xkmv,grid%xkhh,grid%xkhv,grid%bn2,               &
+                                grid%khdif,grid%kvdif,grid%div,                             &
+                                grid%defor11,grid%defor22,grid%defor33,grid%defor12,             &
+                                grid%defor13,grid%defor23,                             &
+                                grid%em_tke_2,p8w,t8w,th_phy,           &
+                                t_phy,p_phy,moist,grid%em_dn,grid%em_dnw,                    &
+                                grid%dx,grid%dy,grid%em_rdz,grid%em_rdzw,config_flags%mix_cr_len,num_3d_m,          &
+                                grid%cf1, grid%cf2, grid%cf3, grid%warm_rain,                    &
+                                grid%kh_tke_upper_bound, grid%kv_tke_upper_bound,      &
+                                ids,ide, jds,jde, kds,kde,                   &
+                                ims,ime, jms,jme, kms,kme,                   &
+                                grid%i_start(ij), grid%i_end(ij),            &
+                                grid%j_start(ij), grid%j_end(ij),            &
+                                k_start    , k_end                          )
+       ENDDO
+       !$OMP END PARALLEL DO
+BENCH_END(calc_tke_tim)
+
+#ifdef DM_PARALLEL
+#     include "HALO_EM_TKE_E.inc"
+#endif
+
+     ENDIF
+
+#ifdef DM_PARALLEL
+#      include "PERIOD_BDY_EM_PHY_BC.inc"
+      IF ( config_flags%grid_fdda .eq. 1) THEN
+#      include "PERIOD_BDY_EM_FDDA_BC.inc"
+      ENDIF
+#      include "PERIOD_BDY_EM_CHEM.inc"
+#endif
+
+BENCH_START(phy_bc_tim)
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij )
+
+     DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call phy_bc' )
+       CALL phy_bc (config_flags,grid%div,grid%defor11,grid%defor22,grid%defor33,            &
+                            grid%defor12,grid%defor13,grid%defor23,                     &
+                            grid%xkmh,grid%xkmhd,grid%xkmv,grid%xkhh,grid%xkhv,                   &
+                            grid%em_tke_2,                          &
+                            grid%rublten, grid%rvblten,                            &
+                            ids, ide, jds, jde, kds, kde,                &
+                            ims, ime, jms, jme, kms, kme,                &
+                            ips, ipe, jps, jpe, kps, kpe,                &
+                            grid%i_start(ij), grid%i_end(ij),            &
+                            grid%j_start(ij), grid%j_end(ij),            &
+                            k_start    , k_end                           )
+     ENDDO
+     !$OMP END PARALLEL DO
+BENCH_END(phy_bc_tim)
+
+#ifdef DM_PARALLEL
+!-----------------------------------------------------------------------
+!
+! MPP for some physics tendency, km, kh, deformation, and divergence
+!
+!               *                     *
+!             * + *      * + *        +
+!               *                     *
+!
+! (for PBL)
+! grid%rublten                  x
+! grid%rvblten                             x
+!
+! (for diff_opt >= 1)
+! grid%defor11                  x
+! grid%defor22                             x
+! grid%defor12       x
+! grid%defor13                  x
+! grid%defor23                             x
+! grid%div           x
+! grid%xkmv          x
+! grid%xkmh          x
+! grid%xkmhd         x
+! grid%xkhv          x
+! grid%xkhh          x
+! tke           x
+!
+!-----------------------------------------------------------------------
+      IF ( config_flags%bl_pbl_physics .ge. 1 ) THEN
+#      include "HALO_EM_PHYS_PBL.inc"
+      ENDIF
+      IF ( config_flags%grid_fdda .eq. 1) THEN
+#      include "HALO_EM_FDDA.inc"
+      ENDIF
+      IF ( config_flags%diff_opt .ge. 1 ) THEN
+#      include "HALO_EM_PHYS_DIFFUSION.inc"
+      ENDIF
+
+      IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#       include "HALO_EM_TKE_3.inc"
+      ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#       include "HALO_EM_TKE_5.inc"
+      ELSE
+        WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      ENDIF
+#endif
+
+BENCH_START(update_phy_ten_tim)
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+        CALL wrf_debug ( 200 , ' call update_phy_ten' )
+        CALL update_phy_ten(t_tendf, ru_tendf, rv_tendf,moist_tend,        &
+                          scalar_tend, mu_tendf,                                        &
+                          grid%rthraten,grid%rthblten,grid%rthcuten,grid%rublten,grid%rvblten,      &
+                          grid%rqvblten,grid%rqcblten,grid%rqiblten,                      &
+                          grid%rqvcuten,grid%rqccuten,grid%rqrcuten,grid%rqicuten,grid%rqscuten,    &
+                          grid%RUNDGDTEN,grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RQVNDGDTEN,       &
+                          grid%RMUNDGDTEN,                                      &
+                          grid%rthfrten,grid%rqvfrten,                     &  ! fire
+                          num_3d_m,num_3d_s,config_flags,rk_step,grid%adv_moist_cond,    &
+                          ids, ide, jds, jde, kds, kde,                    &
+                          ims, ime, jms, jme, kms, kme,                    &
+                          grid%i_start(ij), grid%i_end(ij),                &
+                          grid%j_start(ij), grid%j_end(ij),                &
+                          k_start, k_end                               )
+
+      END DO
+      !$OMP END PARALLEL DO
+BENCH_END(update_phy_ten_tim)
+
+     IF( config_flags%diff_opt .eq. 2 .and. config_flags%km_opt .eq. 2 ) THEN
+
+BENCH_START(tke_rhs_tim)
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+
+       DO ij = 1 , grid%num_tiles
+
+          CALL tke_rhs  ( tke_tend,grid%bn2,                               &
+                          config_flags,grid%defor11,grid%defor22,grid%defor33,       &
+                          grid%defor12,grid%defor13,grid%defor23,grid%em_u_2,grid%em_v_2,grid%em_w_2,grid%div,    &
+                          grid%em_tke_2,grid%em_mut,                     &
+                          th_phy,p_phy,p8w,t8w,grid%em_z,grid%em_fnm,grid%em_fnp,             &
+                          grid%cf1,grid%cf2,grid%cf3,grid%msft,grid%xkmh,grid%xkmv,grid%xkhv,grid%rdx,grid%rdy,    &
+                          grid%dx,grid%dy,grid%dt,grid%em_zx,grid%em_zy,grid%em_rdz,grid%em_rdzw,grid%em_dn,       &
+                          grid%em_dnw,config_flags%mix_cr_len,  &
+                          ids, ide, jds, jde, kds, kde,               &
+                          ims, ime, jms, jme, kms, kme,               &
+                          grid%i_start(ij), grid%i_end(ij),           &
+                          grid%j_start(ij), grid%j_end(ij),           &
+                          k_start    , k_end                         )
+
+       ENDDO
+       !$OMP END PARALLEL DO
+BENCH_END(tke_rhs_tim)
+
+     ENDIF
+
+! calculate vertical diffusion first and then horizontal
+! (keep this order)
+
+     IF(config_flags%diff_opt .eq. 2) THEN
+
+       IF (config_flags%bl_pbl_physics .eq. 0) THEN
+
+BENCH_START(vert_diff_tim)
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+
+           CALL wrf_debug ( 200 , ' call vertical_diffusion_2 ' )
+           CALL vertical_diffusion_2( ru_tendf, rv_tendf, rw_tendf,              &
+                                      t_tendf, tke_tend,                         &
+                                      moist_tend, num_3d_m,                      &
+                                      chem_tend, num_3d_c,                       &
+                                      scalar_tend, num_3d_s,                     &
+                                      grid%em_u_2, grid%em_v_2,                                  &
+                                      grid%em_t_2,grid%u_base,grid%v_base,grid%em_t_base,grid%qv_base,          &
+                                      grid%em_mut,grid%em_tke_2,config_flags,                    &
+                                      grid%defor13,grid%defor23,grid%defor33,                   &
+                                      grid%div, moist, chem, scalar,                  &
+                                      grid%xkmv, grid%xkhv, config_flags%km_opt,                        &
+                                      grid%em_fnm, grid%em_fnp, grid%em_dn, grid%em_dnw, grid%em_rdz, grid%em_rdzw,              &
+                                      ids, ide, jds, jde, kds, kde,              &
+                                      ims, ime, jms, jme, kms, kme,              &
+                                      grid%i_start(ij), grid%i_end(ij),          &
+                                      grid%j_start(ij), grid%j_end(ij),          &
+                                      k_start    , k_end                        )
+
+         ENDDO
+         !$OMP END PARALLEL DO
+BENCH_END(vert_diff_tim)
+
+       ENDIF
+!
+BENCH_START(hor_diff_tim)
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+       DO ij = 1 , grid%num_tiles
+
+         CALL wrf_debug ( 200 , ' call horizontal_diffusion_2' )
+         CALL horizontal_diffusion_2( t_tendf, ru_tendf, rv_tendf, rw_tendf, &
+                                      tke_tend,                              &
+                                      moist_tend, num_3d_m,                  &
+                                      chem_tend, num_3d_c,                   &
+                                      scalar_tend, num_3d_s,                 &
+                                      grid%em_t_2, th_phy,                           &
+                                      grid%em_mut, grid%em_tke_2, config_flags,              &
+                                      grid%defor11, grid%defor22, grid%defor12,             &
+                                      grid%defor13, grid%defor23, grid%div,                 &
+                                      moist, chem, scalar,                   &
+                                      grid%msfu, grid%msfv, grid%msft, grid%xkmhd, grid%xkhh, config_flags%km_opt, &
+                                      grid%rdx, grid%rdy, grid%em_rdz, grid%em_rdzw,                   &
+                                      grid%em_fnm, grid%em_fnp, grid%cf1, grid%cf2, grid%cf3,               &
+                                      grid%em_zx, grid%em_zy, grid%em_dn, grid%em_dnw,                       &
+                                      ids, ide, jds, jde, kds, kde,          &
+                                      ims, ime, jms, jme, kms, kme,          &
+                                      grid%i_start(ij), grid%i_end(ij),      &
+                                      grid%j_start(ij), grid%j_end(ij),      &
+                                      k_start    , k_end                    )
+       ENDDO
+       !$OMP END PARALLEL DO
+BENCH_END(hor_diff_tim)
+
+     ENDIF
+
+# ifdef DM_PARALLEL
+#     include "HALO_OBS_NUDGE.inc"
+#endif
+!***********************************************************************
+! This section for obs nudging
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+         CALL fddaobs_driver (grid%grid_id, model_config_rec%grid_id,  &
+                  model_config_rec%parent_id, config_flags%restart,    &
+                  grid%obs_nudge_opt,                                  &
+                  grid%obs_ipf_errob,                                  &
+                  grid%obs_ipf_nudob,                                  &
+                  grid%fdda_start,                                     &
+                  grid%fdda_end,                                       &
+                  grid%obs_nudge_wind,                                 &
+                  grid%obs_nudge_temp,                                 &
+                  grid%obs_nudge_mois,                                 &
+                  grid%obs_nudge_pstr,                                 &
+                  grid%obs_coef_wind,                                  &
+                  grid%obs_coef_temp,                                  &
+                  grid%obs_coef_mois,                                  &
+                  grid%obs_coef_pstr,                                  &             
+                  grid%obs_rinxy,                                      &
+                  grid%obs_rinsig,                                     &
+                  grid%obs_twindo,                                     &
+                  grid%obs_npfi,                                       &
+                  grid%obs_ionf,                                       &
+                  grid%obs_idynin,                                     &
+                  grid%obs_dtramp,                                     &
+                  model_config_rec%cen_lat(1),                         &
+                  model_config_rec%cen_lon(1),                         &
+                  config_flags%truelat1,                               &
+                  config_flags%truelat2,                               &
+                  config_flags%map_proj,                               &
+                  model_config_rec%i_parent_start,                     &
+                  model_config_rec%j_parent_start,                     &
+                  grid%parent_grid_ratio,                              &
+                  grid%max_dom, grid%itimestep,                        &
+                  grid%dt, grid%gmt, grid%julday, grid%fdob,           &
+                  grid%max_obs,                                        &
+                  model_config_rec%nobs_ndg_vars,                      &
+                  model_config_rec%nobs_err_flds,                      &
+                  grid%fdob%nstat, grid%fdob%varobs, grid%fdob%errf,   &
+                  grid%dx, grid%KPBL,grid%HT,                          &
+                  grid%em_mut, grid%em_muu, grid%em_muv,               &
+                  grid%msft, grid%msfu, grid%msfv,                     &
+                  p_phy, t_tendf, t0,                                  &
+                  grid%em_u_2, grid%em_v_2, grid%em_t_2,               &
+                  moist(:,:,:,P_QV),                                   &
+                  grid%em_pb, grid%p_top, grid%em_p,                   &
+                  grid%uratx, grid%vratx, grid%tratx,                  &
+                  ru_tendf, rv_tendf,                                  &
+                  moist_tend(:,:,:,P_QV), grid%em_obs_savwt,           &
+                  ids,ide, jds,jde, kds,kde,                           &
+                  ims,ime, jms,jme, kms,kme,                           &
+                  grid%i_start(ij), min(grid%i_end(ij),ide-1),         &
+                  grid%j_start(ij), min(grid%j_end(ij),jde-1),         &
+                  k_start    , min(k_end,kde-1)                     )
+
+      ENDDO
+
+     !$OMP END PARALLEL DO
+! 
+!***********************************************************************
+
+     END IF rk_step_is_one
+
+BENCH_START(rk_tend_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+
+      CALL wrf_debug ( 200 , ' call rk_tendency' )
+      CALL rk_tendency ( config_flags, rk_step,                           &
+                         grid%em_ru_tend, grid%em_rv_tend, rw_tend, ph_tend, t_tend,      &
+                         ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
+                         mu_tend, grid%em_u_save, grid%em_v_save, w_save, ph_save,        &
+                         grid%em_t_save, mu_save, grid%rthften,                        &
+                         grid%em_ru, grid%em_rv, grid%em_rw, grid%em_ww,                                  &
+                         grid%em_u_2, grid%em_v_2, grid%em_w_2, grid%em_t_2, grid%em_ph_2,                        &
+                         grid%em_u_1, grid%em_v_1, grid%em_w_1, grid%em_t_1, grid%em_ph_1,                        &
+                         grid%h_diabatic, grid%em_phb, grid%em_t_init,                         &
+                         grid%em_mu_2, grid%em_mut, grid%em_muu, grid%em_muv, grid%em_mub,                        &
+                         grid%em_al, grid%em_alt, grid%em_p, grid%em_pb, grid%em_php, cqu, cqv, cqw,              &
+                         grid%u_base, grid%v_base, grid%em_t_base, grid%qv_base, grid%z_base,         &
+                         grid%msfu, grid%msfv, grid%msft, grid%f, grid%e, grid%sina, grid%cosa,              &
+                         grid%em_fnm, grid%em_fnp, grid%em_rdn, grid%em_rdnw,                             &
+                         grid%dt, grid%rdx, grid%rdy, grid%khdif, grid%kvdif, grid%xkmhd,               &
+                         grid%diff_6th_opt, grid%diff_6th_factor,           &
+                         grid%dampcoef,grid%zdamp,config_flags%damp_opt,                         &
+                         grid%cf1, grid%cf2, grid%cf3, grid%cfn, grid%cfn1, num_3d_m,              &
+                         config_flags%non_hydrostatic,                    &
+                         ids, ide, jds, jde, kds, kde,                    &
+                         ims, ime, jms, jme, kms, kme,                    &
+                         grid%i_start(ij), grid%i_end(ij),                &
+                         grid%j_start(ij), grid%j_end(ij),                &
+                         k_start, k_end                                  )
+   END DO
+   !$OMP END PARALLEL DO
+BENCH_END(rk_tend_tim)
+
+BENCH_START(relax_bdy_dry_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+
+     IF( (config_flags%specified .or. config_flags%nested) .and. rk_step == 1 ) THEN 
+
+       CALL relax_bdy_dry ( config_flags,                                &
+                            grid%em_u_save, grid%em_v_save, ph_save, grid%em_t_save,             &
+                            w_save, mu_tend,                             & 
+                            grid%em_ru, grid%em_rv, grid%em_ph_2, grid%em_t_2,                           &
+                            grid%em_w_2, grid%em_mu_2, grid%em_mut,                              &
+                            grid%em_u_bxs,grid%em_u_bxe,grid%em_u_bys,grid%em_u_bye, &
+                            grid%em_v_bxs,grid%em_v_bxe,grid%em_v_bys,grid%em_v_bye, &
+                            grid%em_ph_bxs,grid%em_ph_bxe,grid%em_ph_bys,grid%em_ph_bye, &
+                            grid%em_t_bxs,grid%em_t_bxe,grid%em_t_bys,grid%em_t_bye, &
+                            grid%em_w_bxs,grid%em_w_bxe,grid%em_w_bys,grid%em_w_bye, &
+                            grid%em_mu_bxs,grid%em_mu_bxe,grid%em_mu_bys,grid%em_mu_bye, &
+                            grid%em_u_btxs,grid%em_u_btxe,grid%em_u_btys,grid%em_u_btye, &
+                            grid%em_v_btxs,grid%em_v_btxe,grid%em_v_btys,grid%em_v_btye, &
+                            grid%em_ph_btxs,grid%em_ph_btxe,grid%em_ph_btys,grid%em_ph_btye, &
+                            grid%em_t_btxs,grid%em_t_btxe,grid%em_t_btys,grid%em_t_btye, &
+                            grid%em_w_btxs,grid%em_w_btxe,grid%em_w_btys,grid%em_w_btye, &
+                            grid%em_mu_btxs,grid%em_mu_btxe,grid%em_mu_btys,grid%em_mu_btye, &
+                            config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone,       &
+                            grid%dtbc, grid%fcx, grid%gcx,                              &
+                            ids,ide, jds,jde, kds,kde,                   &
+                            ims,ime, jms,jme, kms,kme,                   &
+                            ips,ipe, jps,jpe, kps,kpe,                   &
+                            grid%i_start(ij), grid%i_end(ij),            &
+                            grid%j_start(ij), grid%j_end(ij),            &
+                            k_start, k_end                              )
+
+
+     ENDIF
+
+     CALL rk_addtend_dry( grid%em_ru_tend,  grid%em_rv_tend,  rw_tend,  ph_tend,  t_tend,  &
+                          ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
+                          grid%em_u_save, grid%em_v_save, w_save, ph_save, grid%em_t_save, &
+                          mu_tend, mu_tendf, rk_step,                      &
+                          grid%h_diabatic, grid%em_mut, grid%msft, grid%msfu, grid%msfv,               &
+                          ids,ide, jds,jde, kds,kde,                       &
+                          ims,ime, jms,jme, kms,kme,                       &
+                          ips,ipe, jps,jpe, kps,kpe,                       &
+                          grid%i_start(ij), grid%i_end(ij),                &
+                          grid%j_start(ij), grid%j_end(ij),                &
+                          k_start, k_end                                  )
+
+     IF( config_flags%specified .or. config_flags%nested ) THEN 
+       CALL spec_bdy_dry ( config_flags,                                    &
+                           grid%em_ru_tend, grid%em_rv_tend, ph_tend, t_tend,               &
+                           rw_tend, mu_tend,                                &
+                           grid%em_u_bxs,grid%em_u_bxe,grid%em_u_bys,grid%em_u_bye, &
+                           grid%em_v_bxs,grid%em_v_bxe,grid%em_v_bys,grid%em_v_bye, &
+                           grid%em_ph_bxs,grid%em_ph_bxe,grid%em_ph_bys,grid%em_ph_bye, &
+                           grid%em_t_bxs,grid%em_t_bxe,grid%em_t_bys,grid%em_t_bye, &
+                           grid%em_w_bxs,grid%em_w_bxe,grid%em_w_bys,grid%em_w_bye, &
+                           grid%em_mu_bxs,grid%em_mu_bxe,grid%em_mu_bys,grid%em_mu_bye, &
+                           grid%em_u_btxs,grid%em_u_btxe,grid%em_u_btys,grid%em_u_btye, &
+                           grid%em_v_btxs,grid%em_v_btxe,grid%em_v_btys,grid%em_v_btye, &
+                           grid%em_ph_btxs,grid%em_ph_btxe,grid%em_ph_btys,grid%em_ph_btye, &
+                           grid%em_t_btxs,grid%em_t_btxe,grid%em_t_btys,grid%em_t_btye, &
+                           grid%em_w_btxs,grid%em_w_btxe,grid%em_w_btys,grid%em_w_btye, &
+                           grid%em_mu_btxs,grid%em_mu_btxe,grid%em_mu_btys,grid%em_mu_btye, &
+                           config_flags%spec_bdy_width, grid%spec_zone,                       &
+                           ids,ide, jds,jde, kds,kde,  & ! domain dims
+                           ims,ime, jms,jme, kms,kme,  & ! memory dims
+                           ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                           grid%i_start(ij), grid%i_end(ij),                &
+                           grid%j_start(ij), grid%j_end(ij),                &
+                           k_start, k_end                                  )
+     
+     ENDIF
+
+   END DO
+   !$OMP END PARALLEL DO
+BENCH_END(relax_bdy_dry_tim)
+
+!
+!
+! (3) Small (acoustic,sound) steps.
+!
+!    Several acoustic steps are taken each RK pass.  A small step 
+!    sequence begins with calculating perturbation variables 
+!    and coupling them to the column dry-air-mass mu 
+!    (call to small_step_prep).  This is followed by computing
+!    coefficients for the vertically implicit part of the
+!    small timestep (call to calc_coef_w).  
+!
+!    The small steps are taken
+!    in the named loop "small_steps:".  In the small_steps loop, first 
+!    the horizontal momentum (u and v) are advanced (call to advance_uv),
+!    next mu and theta are advanced (call to advance_mu_t) followed by
+!    advancing w and the geopotential (call to advance_w).  Diagnostic
+!    values for pressure and inverse density are updated at the end of
+!    each small_step.
+!
+!    The small-step section ends with the change of the perturbation variables
+!    back to full variables (call to small_step_finish).
+!

+!
+
+BENCH_START(small_step_prep_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+
+    ! Calculate coefficients for the vertically implicit acoustic/gravity wave
+    ! integration.  We only need calculate these for the first pass through -
+    ! the predictor step.  They are reused as is for the corrector step.
+    ! For third-order RK, we need to recompute these after the first 
+    ! predictor because we may have changed the small timestep -> grid%dts.
+
+      CALL wrf_debug ( 200 , ' call calc_coef_w' )
+
+      CALL small_step_prep( grid%em_u_1,grid%em_u_2,grid%em_v_1,grid%em_v_2,grid%em_w_1,grid%em_w_2,          &
+                            grid%em_t_1,grid%em_t_2,grid%em_ph_1,grid%em_ph_2,                &
+                            grid%em_mub, grid%em_mu_1, grid%em_mu_2,                  &
+                            grid%em_muu, muus, grid%em_muv, muvs,             &
+                            grid%em_mut, grid%em_muts, grid%em_mudf,                  & 
+                            grid%em_u_save, grid%em_v_save, w_save,           & 
+                            grid%em_t_save, ph_save, mu_save,         &
+                            grid%em_ww, ww1,                          &
+                            grid%em_dnw, c2a, grid%em_pb, grid%em_p, grid%em_alt,             &
+                            grid%msfu, grid%msfv, grid%msft,                 &
+                            rk_step,                          &
+                            ids, ide, jds, jde, kds, kde,     &
+                            ims, ime, jms, jme, kms, kme,     &
+                            grid%i_start(ij), grid%i_end(ij), &
+                            grid%j_start(ij), grid%j_end(ij), &
+                            k_start    , k_end               )
+      CALL calc_p_rho( grid%em_al, grid%em_p, grid%em_ph_2,                      &
+                       grid%em_alt, grid%em_t_2, grid%em_t_save, c2a, pm1,       &
+                       grid%em_mu_2, grid%em_muts, grid%em_znu, t0,              &
+                       grid%em_rdnw, grid%em_dnw, grid%smdiv,                 &
+                       config_flags%non_hydrostatic, 0,               &
+                       ids, ide, jds, jde, kds, kde,     &
+                       ims, ime, jms, jme, kms, kme,     &
+                       grid%i_start(ij), grid%i_end(ij), &
+                       grid%j_start(ij), grid%j_end(ij), &
+                       k_start    , k_end               )
+
+      IF (config_flags%non_hydrostatic)                                &
+      CALL calc_coef_w( a,alpha,gamma,                    &
+                        grid%em_mut, cqw,                         &
+                        grid%em_rdn, grid%em_rdnw, c2a,                   &
+                        dts_rk, g, grid%epssm,                 &
+                        ids, ide, jds, jde, kds, kde,     &
+                        ims, ime, jms, jme, kms, kme,     &
+                        grid%i_start(ij), grid%i_end(ij), &
+                        grid%j_start(ij), grid%j_end(ij), &
+                        k_start    , k_end               )
+
+
+   ENDDO
+   !$OMP END PARALLEL DO
+BENCH_END(small_step_prep_tim)
+
+
+#ifdef DM_PARALLEL
+!-----------------------------------------------------------------------
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!  Note:  the small size of this halo exchange reflects the 
+!         fact that we are carrying the uncoupled variables 
+!         as state variables in the mass coordinate model, as
+!         opposed to the coupled variables as in the height
+!         coordinate model.
+!
+!                              * * * * *
+!            *        * * *    * * * * *
+!          * + *      * + *    * * + * * 
+!            *        * * *    * * * * *
+!                              * * * * *
+!
+!  3D variables - note staggering!  grid%em_ph_2(grid%em_z), grid%em_u_save(X), grid%em_v_save(Y)
+!
+!j grid%em_ph_2      x
+!j grid%em_al        x
+!j grid%em_p         x
+!j grid%em_t_1       x
+!j grid%em_t_save    x
+!j grid%em_u_save    x
+!j grid%em_v_save    x
+!
+!  the following are 2D (xy) variables
+!
+!j grid%em_mu_1      x
+!j grid%em_mu_2      x
+!j grid%em_mudf      x
+!--------------------------------------------------------------
+#      include "HALO_EM_B.inc"
+#      include "PERIOD_BDY_EM_B.inc"
+#endif
+
+BENCH_START(set_phys_bc2_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+
+         CALL set_physical_bc3d( grid%em_ru_tend, 'u', config_flags,          &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_rv_tend, 'v', config_flags,            &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_ph_2, 'w', config_flags,          &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_al, 'p', config_flags,            &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_p, 'p', config_flags,             &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_t_1, 'p', config_flags,             &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc3d( grid%em_t_save, 't', config_flags,             &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe, &
+                           grid%i_start(ij), grid%i_end(ij),                 &
+                           grid%j_start(ij), grid%j_end(ij),                 &
+                           k_start    , k_end                     )
+
+         CALL set_physical_bc2d( grid%em_mu_1, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+         CALL set_physical_bc2d( grid%em_mu_2, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+         CALL set_physical_bc2d( grid%em_mudf, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+    END DO
+    !$OMP END PARALLEL DO
+BENCH_END(set_phys_bc2_tim)
+
+   small_steps : DO iteration = 1 , number_of_small_timesteps
+
+   ! Boundary condition time (or communication time).  
+
+#ifdef DM_PARALLEL
+#      include "PERIOD_BDY_EM_B.inc"
+#endif
+
+
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+BENCH_START(advance_uv_tim)
+         CALL advance_uv ( grid%em_u_2, grid%em_ru_tend, grid%em_v_2, grid%em_rv_tend,       &
+                           grid%em_p, grid%em_pb,                            &
+                           grid%em_ph_2, grid%em_php, grid%em_alt, grid%em_al, grid%em_mu_2,         &
+                           grid%em_muu, cqu, grid%em_muv, cqv, grid%em_mudf,         &
+                           grid%rdx, grid%rdy, dts_rk,                 &
+                           grid%cf1, grid%cf2, grid%cf3, grid%em_fnm, grid%em_fnp,          &
+                           grid%emdiv,                            &
+                           grid%em_rdnw, config_flags,grid%spec_zone,     &
+                           config_flags%non_hydrostatic,                  &
+                           ids, ide, jds, jde, kds, kde,     &
+                           ims, ime, jms, jme, kms, kme,     &
+                           grid%i_start(ij), grid%i_end(ij), &
+                           grid%j_start(ij), grid%j_end(ij), &
+                           k_start    , k_end               )
+BENCH_END(advance_uv_tim)
+
+BENCH_START(spec_bdy_uv_tim)
+         IF( config_flags%specified .or. config_flags%nested ) THEN
+           CALL spec_bdyupdate(grid%em_u_2, grid%em_ru_tend, dts_rk,      &
+                               'u'         , config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, kds,kde,  & ! domain dims
+                               ims,ime, jms,jme, kms,kme,  & ! memory dims
+                               ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),         &
+                               grid%j_start(ij), grid%j_end(ij),         &
+                               k_start    , k_end             )
+
+           CALL spec_bdyupdate(grid%em_v_2, grid%em_rv_tend, dts_rk,      &
+                               'v'         , config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, kds,kde,  & ! domain dims
+                               ims,ime, jms,jme, kms,kme,  & ! memory dims
+                               ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),         &
+                               grid%j_start(ij), grid%j_end(ij),         &
+                               k_start    , k_end             )
+
+         ENDIF
+BENCH_END(spec_bdy_uv_tim)
+
+      END DO
+      !$OMP END PARALLEL DO
+
+#ifdef DM_PARALLEL
+!
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!         *                     *
+!       * + *      * + *        +
+!         *                     *
+!
+!  grid%em_u_2               x
+!  grid%em_v_2                          x
+!
+#     include "HALO_EM_C.inc"
+#endif
+
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+        !  advance the mass in the column, theta, and calculate grid%em_ww
+
+BENCH_START(advance_mu_t_tim)
+        CALL advance_mu_t( grid%em_ww, ww1, grid%em_u_2, grid%em_u_save, grid%em_v_2, grid%em_v_save, &
+                           grid%em_mu_2, grid%em_mut, muave, grid%em_muts, grid%em_muu, grid%em_muv,  &
+                           grid%em_mudf, grid%em_ru_m, grid%em_rv_m, grid%em_ww_m,                       &
+                           grid%em_t_2, grid%em_t_save, t_2save, t_tend,                              &
+                           mu_tend,                                                                   &
+                           grid%rdx, grid%rdy, dts_rk, grid%epssm,                                    &
+                           grid%em_dnw, grid%em_fnm, grid%em_fnp, grid%em_rdnw,                       &
+                           grid%msfu, grid%msfv, grid%msft,                                           &
+                           iteration, config_flags,                                                   &
+                           ids, ide, jds, jde, kds, kde,      &
+                           ims, ime, jms, jme, kms, kme,      &
+                           grid%i_start(ij), grid%i_end(ij),  &
+                           grid%j_start(ij), grid%j_end(ij),  &
+                           k_start    , k_end                )
+BENCH_END(advance_mu_t_tim)
+
+BENCH_START(spec_bdy_t_tim)
+         IF( config_flags%specified .or. config_flags%nested ) THEN
+
+           CALL spec_bdyupdate(grid%em_t_2, t_tend, dts_rk,      &
+                               't'         , config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, kds,kde,  & ! domain dims
+                               ims,ime, jms,jme, kms,kme,  & ! memory dims
+                               ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),         &
+                               grid%j_start(ij), grid%j_end(ij),         &
+                               k_start    , k_end             )
+
+           CALL spec_bdyupdate(grid%em_mu_2, mu_tend, dts_rk,      &
+                               'm'         , config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, 1  ,1  ,  & ! domain dims
+                               ims,ime, jms,jme, 1  ,1  ,  & ! memory dims
+                               ips,ipe, jps,jpe, 1  ,1  ,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),         &
+                               grid%j_start(ij), grid%j_end(ij),         &
+                               1    , 1             )
+
+           CALL spec_bdyupdate(grid%em_muts, mu_tend, dts_rk,      &
+                               'm'         , config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, 1  ,1  ,  & ! domain dims
+                               ims,ime, jms,jme, 1  ,1  ,  & ! memory dims
+                               ips,ipe, jps,jpe, 1  ,1  ,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),         &
+                               grid%j_start(ij), grid%j_end(ij),         &
+                               1    , 1             )
+         ENDIF
+BENCH_END(spec_bdy_t_tim)
+
+         ! sumflux accumulates the time-averged mass flux
+         ! (time averaged over the acoustic steps) for use
+         ! in the scalar advection (flux divergence).  Using
+         ! time averaged values gives us exact scalar conservation.
+
+BENCH_START(sumflux_tim)
+         CALL sumflux ( grid%em_u_2, grid%em_v_2, grid%em_ww,                         &
+                        grid%em_u_save, grid%em_v_save, ww1,                  &
+                        grid%em_muu, grid%em_muv,                             &
+                        grid%em_ru_m, grid%em_rv_m, grid%em_ww_m, grid%epssm,              &
+                        grid%msfu, grid%msfv,                           &
+                        iteration, number_of_small_timesteps, &
+                        ids, ide, jds, jde, kds, kde,         &
+                        ims, ime, jms, jme, kms, kme,         &
+                        grid%i_start(ij), grid%i_end(ij),     &
+                        grid%j_start(ij), grid%j_end(ij),     &
+                        k_start    , k_end                   )
+BENCH_END(sumflux_tim)
+
+         ! small (acoustic) step for the vertical momentum,
+         ! density and coupled potential temperature.
+
+
+BENCH_START(advance_w_tim)
+        IF ( config_flags%non_hydrostatic ) THEN
+          CALL advance_w( grid%em_w_2, rw_tend, grid%em_ww, grid%em_u_2, grid%em_v_2,       &
+                          grid%em_mu_2, grid%em_mut, muave, grid%em_muts,           &
+                          t_2save, grid%em_t_2, grid%em_t_save,             &
+                          grid%em_ph_2, ph_save, grid%em_phb, ph_tend,      &
+                          grid%ht, c2a, cqw, grid%em_alt, grid%em_alb,           &
+                          a, alpha, gamma,                  &
+                          grid%rdx, grid%rdy, dts_rk, t0, grid%epssm,      &
+                          grid%em_dnw, grid%em_fnm, grid%em_fnp, grid%em_rdnw, grid%em_rdn,         &
+                          grid%cf1, grid%cf2, grid%cf3, grid%msft,              &
+                          config_flags,                     &
+                          ids,ide, jds,jde, kds,kde,        & ! domain dims
+                          ims,ime, jms,jme, kms,kme,        & ! memory dims
+                          grid%i_start(ij), grid%i_end(ij), &
+                          grid%j_start(ij), grid%j_end(ij), &
+                          k_start    , k_end               )
+        ENDIF
+BENCH_END(advance_w_tim)
+
+        IF( config_flags%specified .or. config_flags%nested ) THEN
+
+BENCH_START(spec_bdynhyd_tim)
+           IF (config_flags%non_hydrostatic)  THEN
+             CALL spec_bdyupdate_ph( ph_save, grid%em_ph_2, ph_tend, mu_tend, grid%em_muts, dts_rk, &
+                                     'h'         , config_flags, &
+                                     grid%spec_zone,                  &
+                                     ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                     ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                     ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                     grid%i_start(ij), grid%i_end(ij),         &
+                                     grid%j_start(ij), grid%j_end(ij),         &
+                                     k_start    , k_end             )
+             IF( config_flags%specified ) THEN
+               CALL zero_grad_bdy ( grid%em_w_2,                        &
+                                    'w'         , config_flags, &
+                                    grid%spec_zone,                  &
+                                    ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                    ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                    ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                    grid%i_start(ij), grid%i_end(ij),         &
+                                    grid%j_start(ij), grid%j_end(ij),         &
+                                    k_start    , k_end             )
+             ELSE
+               CALL spec_bdyupdate   ( grid%em_w_2, rw_tend, dts_rk,       &
+                                       'h'         , config_flags, &
+                                       grid%spec_zone,                  &
+                                       ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                       ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                       ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                       grid%i_start(ij), grid%i_end(ij),         &
+                                       grid%j_start(ij), grid%j_end(ij),         &
+                                       k_start    , k_end             )
+             ENDIF
+          ENDIF
+BENCH_END(spec_bdynhyd_tim)
+        ENDIF
+
+BENCH_START(cald_p_rho_tim)
+        CALL calc_p_rho( grid%em_al, grid%em_p, grid%em_ph_2,                      &
+                         grid%em_alt, grid%em_t_2, grid%em_t_save, c2a, pm1,       &
+                         grid%em_mu_2, grid%em_muts, grid%em_znu, t0,              &
+                         grid%em_rdnw, grid%em_dnw, grid%smdiv,                 &
+                         config_flags%non_hydrostatic, iteration,       &
+                         ids, ide, jds, jde, kds, kde,     &
+                         ims, ime, jms, jme, kms, kme,     &
+                         grid%i_start(ij), grid%i_end(ij), &
+                         grid%j_start(ij), grid%j_end(ij), &
+                         k_start    , k_end               )
+BENCH_END(cald_p_rho_tim)
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+#ifdef DM_PARALLEL
+!
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!         *                     *
+!       * + *      * + *        +
+!         *                     *
+!
+!  grid%em_ph_2   x
+!  grid%em_al     x
+!  grid%em_p      x
+!
+!  2D variables (x,y)
+!
+!  grid%em_mu_2   x
+!  grid%em_muts   x
+!  grid%em_mudf   x
+
+#      include "HALO_EM_C2.inc"
+#      include "PERIOD_BDY_EM_B3.inc"
+#endif
+
+BENCH_START(phys_bc_tim)
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+
+        ! boundary condition set for next small timestep
+
+         CALL set_physical_bc3d( grid%em_ph_2, 'w', config_flags,          &
+                                 ids, ide, jds, jde, kds, kde,     &
+                                 ims, ime, jms, jme, kms, kme,     &
+                                 ips, ipe, jps, jpe, kps, kpe,     &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij), &
+                                 k_start    , k_end               )
+
+         CALL set_physical_bc3d( grid%em_al, 'p', config_flags,            &
+                                 ids, ide, jds, jde, kds, kde,     &
+                                 ims, ime, jms, jme, kms, kme,     &
+                                 ips, ipe, jps, jpe, kps, kpe,     &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij), &
+                                 k_start    , k_end               )
+
+         CALL set_physical_bc3d( grid%em_p, 'p', config_flags,             &
+                                 ids, ide, jds, jde, kds, kde,     &
+                                 ims, ime, jms, jme, kms, kme,     &
+                                 ips, ipe, jps, jpe, kps, kpe,     &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij), &
+                                 k_start    , k_end               )
+
+         CALL set_physical_bc2d( grid%em_muts, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+         CALL set_physical_bc2d( grid%em_mu_2, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+         CALL set_physical_bc2d( grid%em_mudf, 't', config_flags,          &
+                                 ids, ide, jds, jde,               &
+                                 ims, ime, jms, jme,               &
+                                 ips, ipe, jps, jpe,               &
+                                 grid%i_start(ij), grid%i_end(ij), &
+                                 grid%j_start(ij), grid%j_end(ij) )
+
+      END DO
+      !$OMP END PARALLEL DO
+BENCH_END(phys_bc_tim)
+
+   END DO small_steps
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+
+      CALL wrf_debug ( 200 , ' call rk_small_finish' )
+
+      ! change time-perturbation variables back to 
+      ! full perturbation variables.
+      ! first get updated mu at u and v points
+
+BENCH_START(calc_mu_uv_tim)
+      CALL calc_mu_uv_1 ( config_flags,                     &
+                          grid%em_muts, muus, muvs,                 &
+                          ids, ide, jds, jde, kds, kde,     &
+                          ims, ime, jms, jme, kms, kme,     &
+                          grid%i_start(ij), grid%i_end(ij), &
+                          grid%j_start(ij), grid%j_end(ij), &
+                          k_start    , k_end               )
+BENCH_END(calc_mu_uv_tim)
+BENCH_START(small_step_finish_tim)
+      CALL small_step_finish( grid%em_u_2, grid%em_u_1, grid%em_v_2, grid%em_v_1, grid%em_w_2, grid%em_w_1,     &
+                              grid%em_t_2, grid%em_t_1, grid%em_ph_2, grid%em_ph_1, grid%em_ww, ww1,    &
+                              grid%em_mu_2, grid%em_mu_1,                       &
+                              grid%em_mut, grid%em_muts, grid%em_muu, muus, grid%em_muv, muvs,  & 
+                              grid%em_u_save, grid%em_v_save, w_save,           &
+                              grid%em_t_save, ph_save, mu_save,         &
+                              grid%msfu, grid%msfv, grid%msft,                 &
+                              grid%h_diabatic,                       &
+                              number_of_small_timesteps,dts_rk, &
+                              rk_step, rk_order,                &
+                              ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              grid%i_start(ij), grid%i_end(ij), &
+                              grid%j_start(ij), grid%j_end(ij), &
+                              k_start    , k_end               )
+!  call  to set ru_m, rv_m and ww_m b.c's for PD advection
+
+         IF (rk_step == 3) THEN
+
+           CALL set_physical_bc3d( grid%em_ru_m, 'u', config_flags,   &
+                                   ids, ide, jds, jde, kds, kde,      &
+                                   ims, ime, jms, jme, kms, kme,      &
+                                   ips, ipe, jps, jpe, kps, kpe,      &
+                                   grid%i_start(ij), grid%i_end(ij),  &
+                                   grid%j_start(ij), grid%j_end(ij),  &
+                                   k_start    , k_end                )
+
+           CALL set_physical_bc3d( grid%em_rv_m, 'v', config_flags,   &
+                                   ids, ide, jds, jde, kds, kde,      &
+                                   ims, ime, jms, jme, kms, kme,      &
+                                   ips, ipe, jps, jpe, kps, kpe,      &
+                                   grid%i_start(ij), grid%i_end(ij),  &
+                                   grid%j_start(ij), grid%j_end(ij),  &
+                                   k_start    , k_end                )
+
+           CALL set_physical_bc3d( grid%em_ww_m, 'w', config_flags,   &
+                                   ids, ide, jds, jde, kds, kde,      &
+                                   ims, ime, jms, jme, kms, kme,      &
+                                   ips, ipe, jps, jpe, kps, kpe,      &
+                                   grid%i_start(ij), grid%i_end(ij),  &
+                                   grid%j_start(ij), grid%j_end(ij),  &
+                                   k_start    , k_end                )
+
+           CALL set_physical_bc2d( grid%em_mut, 't', config_flags,   &
+                                   ids, ide, jds, jde,               &
+                                   ims, ime, jms, jme,                &
+                                   ips, ipe, jps, jpe,                &
+                                   grid%i_start(ij), grid%i_end(ij),  &
+                                   grid%j_start(ij), grid%j_end(ij) )
+
+          END IF
+
+BENCH_END(small_step_finish_tim)
+
+   END DO
+   !$OMP END PARALLEL DO
+
+!-----------------------------------------------------------------------
+!  add in physics tendency first if positive definite advection is used.
+!  pd advection applies advective flux limiter on last runge-kutta step
+!-----------------------------------------------------------------------
+! first moisture
+
+  IF (config_flags%pd_moist .and. (rk_step == rk_order)) THEN
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+       CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
+       do im = PARAM_FIRST_SCALAR, num_3d_m
+       CALL rk_update_scalar_pd( im, im,                                   &
+                                 moist_old(ims,kms,jms,im),                &
+                                 moist_tend(ims,kms,jms,im),               &
+                                 grid%msft,                                &
+                                 grid%em_mu_1, grid%em_mu_1, grid%em_mub,  &
+                                 rk_step, dt_rk, grid%spec_zone,           &
+                                 config_flags,                             &
+                                 ids, ide, jds, jde, kds, kde,             &
+                                 ims, ime, jms, jme, kms, kme,             &
+                                 grid%i_start(ij), grid%i_end(ij),         &
+                                 grid%j_start(ij), grid%j_end(ij),         &
+                                 k_start    , k_end                       )
+       ENDDO
+   END DO
+   !$OMP END PARALLEL DO
+
+!---------------------- positive definite bc call
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+      IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
+        DO im = PARAM_FIRST_SCALAR , num_3d_m
+          CALL set_physical_bc3d( moist_old(ims,kms,jms,im), 'p', config_flags,   &
+                                   ids, ide, jds, jde, kds, kde,                  &
+                                   ims, ime, jms, jme, kms, kme,                  &
+                                   ips, ipe, jps, jpe, kps, kpe,                  &
+                                   grid%i_start(ij), grid%i_end(ij),              &
+                                   grid%j_start(ij), grid%j_end(ij),              &
+                                   k_start    , k_end                            )
+         END DO
+      ENDIF
+   END DO
+   !$OMP END PARALLEL DO
+
+#ifdef DM_PARALLEL
+   if(config_flags%pd_moist) then
+#ifndef RSL
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+#     include "HALO_EM_MOIST_OLD_E_5.inc"
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+#     include "HALO_EM_MOIST_OLD_E_7.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+#else
+       WRITE(wrf_err_message,*)'cannot use pd scheme with RSL - use RSL-LITE'
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+#endif     
+  endif
+#endif
+
+   END IF  ! end if for pd_moist
+
+! scalars
+
+  IF (config_flags%pd_scalar .and. (rk_step == rk_order)) THEN
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+       CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
+       do im = PARAM_FIRST_SCALAR, num_3d_s
+       CALL rk_update_scalar_pd( im, im,                                  &
+                                 scalar_old(ims,kms,jms,im),              &
+                                 scalar_tend(ims,kms,jms,im),             &
+                                 grid%msft,                               &
+                                 grid%em_mu_1, grid%em_mu_1, grid%em_mub, &
+                                 rk_step, dt_rk, grid%spec_zone,          &
+                                 config_flags,                            &
+                                 ids, ide, jds, jde, kds, kde,            &
+                                 ims, ime, jms, jme, kms, kme,            &
+                                 grid%i_start(ij), grid%i_end(ij),        &
+                                 grid%j_start(ij), grid%j_end(ij),        &
+                                 k_start    , k_end                      )
+       ENDDO
+   ENDDO
+   !$OMP END PARALLEL DO
+
+!---------------------- positive definite bc call
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+      IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
+        DO im = PARAM_FIRST_SCALAR , num_3d_s
+            CALL set_physical_bc3d(  scalar_old(ims,kms,jms,im), 'p', config_flags, &
+                                   ids, ide, jds, jde, kds, kde,                    &
+                                   ims, ime, jms, jme, kms, kme,                    &
+                                   ips, ipe, jps, jpe, kps, kpe,                    &
+                                   grid%i_start(ij), grid%i_end(ij),                &
+                                   grid%j_start(ij), grid%j_end(ij),                &
+                                   k_start    , k_end                              )
+         END DO
+      ENDIF
+   END DO
+   !$OMP END PARALLEL DO
+
+#ifdef DM_PARALLEL
+   if(config_flags%pd_scalar) then
+#ifndef RSL
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+#     include "HALO_EM_SCALAR_OLD_E_5.inc"
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+#     include "HALO_EM_SCALAR_OLD_E_7.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+#else
+       WRITE(wrf_err_message,*)'cannot use pd scheme with RSL - use RSL-LITE'
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+#endif     
+  endif
+#endif
+
+   END IF  ! end if for pd_scalar
+
+! chem
+
+  IF (config_flags%pd_chem .and. (rk_step == rk_order)) THEN
+
+!  write(6,*) ' pd advection for chem '
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+       CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
+       do im = PARAM_FIRST_SCALAR, num_3d_c
+       CALL rk_update_scalar_pd( im, im,                                  &
+                                 chem_old(ims,kms,jms,im),                &
+                                 chem_tend(ims,kms,jms,im),               &
+                                 grid%msft,                               &
+                                 grid%em_mu_1, grid%em_mu_1, grid%em_mub, &
+                                 rk_step, dt_rk, grid%spec_zone,          &
+                                 config_flags,                            &
+                                 ids, ide, jds, jde, kds, kde,            &
+                                 ims, ime, jms, jme, kms, kme,            &
+                                 grid%i_start(ij), grid%i_end(ij),        &
+                                 grid%j_start(ij), grid%j_end(ij),        &
+                                 k_start    , k_end                      )
+       ENDDO
+   END DO
+   !$OMP END PARALLEL DO
+
+!---------------------- positive definite bc call
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+      IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
+        DO im = PARAM_FIRST_SCALAR , num_3d_c
+!print*,"~before set_physical_bc3d, im, grid id=",im,grid%id
+          CALL set_physical_bc3d(  chem_old(ims,kms,jms,im), 'p', config_flags,     &
+                                   ids, ide, jds, jde, kds, kde,                    &
+                                   ims, ime, jms, jme, kms, kme,                    &
+                                   ips, ipe, jps, jpe, kps, kpe,                    &
+                                   grid%i_start(ij), grid%i_end(ij),                &
+                                   grid%j_start(ij), grid%j_end(ij),                &
+                                   k_start    , k_end                              )
+         END DO 
+      ENDIF
+   END DO
+   !$OMP END PARALLEL DO
+
+
+#ifdef DM_PARALLEL
+   if(config_flags%pd_chem) then
+#ifndef RSL
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+#     include "HALO_EM_CHEM_OLD_E_5.inc"
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+#     include "HALO_EM_CHEM_OLD_E_7.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+#else
+       WRITE(wrf_err_message,*)'cannot use pd scheme with RSL - use RSL-LITE'
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+#endif     
+  endif
+#endif
+
+  END IF  ! end if for pd_chem
+
+! tke
+
+  IF (config_flags%pd_tke .and. (rk_step == rk_order) &
+      .and. (config_flags%km_opt .eq. 2)                ) THEN
+
+!  write(6,*) ' pd advection for tke '
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+       CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' )
+       CALL rk_update_scalar_pd( 1, 1,                                    &
+                                 grid%em_tke_1,                           &
+                                 tke_tend(ims,kms,jms),                   &
+                                 grid%msft,                               &
+                                 grid%em_mu_1, grid%em_mu_1, grid%em_mub, &
+                                 rk_step, dt_rk, grid%spec_zone,          &
+                                 config_flags,                            &
+                                 ids, ide, jds, jde, kds, kde,            &
+                                 ims, ime, jms, jme, kms, kme,            &
+                                 grid%i_start(ij), grid%i_end(ij),        &
+                                 grid%j_start(ij), grid%j_end(ij),        &
+                                 k_start    , k_end                      )
+   END DO
+   !$OMP END PARALLEL DO
+
+!---------------------- positive definite bc call
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+          CALL set_physical_bc3d(  grid%em_tke_1, 'p', config_flags,  &
+                                   ids, ide, jds, jde, kds, kde,      &
+                                   ims, ime, jms, jme, kms, kme,      &
+                                   ips, ipe, jps, jpe, kps, kpe,      &
+                                   grid%i_start(ij), grid%i_end(ij),  &
+                                   grid%j_start(ij), grid%j_end(ij),  &
+                                   k_start    , k_end                )
+   END DO
+   !$OMP END PARALLEL DO
+
+!---  end of positive definite physics tendency update
+
+#ifdef DM_PARALLEL
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+#     include "HALO_EM_TKE_OLD_E_5.inc"
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+#     include "HALO_EM_TKE_OLD_E_7.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+#endif
+
+   END IF  ! end if for pd_tke
+
+#ifdef DM_PARALLEL
+!
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!
+! grid%em_ru_m      x
+! grid%em_rv_m      x
+! grid%em_ww_m      x
+! grid%em_mut       x
+!
+!--------------------------------------------------------------
+
+#  include "HALO_EM_D.inc"
+#endif
+
+!
+!
+! (4) Still within the RK loop, the scalar variables are advanced.
+!
+!    For the moist and chem variables, each one is advanced
+!    individually, using named loops "moist_variable_loop:"
+!    and "chem_variable_loop:".  Each RK substep begins by
+!    calculating the advective tendency, and, for the first RK step, 
+!    3D mixing (calling rk_scalar_tend) followed by an update
+!    of the scalar (calling rk_scalar_update).
+!

+!
+
+
+  moist_scalar_advance: IF (num_3d_m >= PARAM_FIRST_SCALAR )  THEN
+
+   moist_variable_loop: do im = PARAM_FIRST_SCALAR, num_3d_m
+
+   if (grid%adv_moist_cond .or. im==p_qv ) then
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   moist_tile_loop_1: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_scalar_tend' )
+
+BENCH_START(rk_scalar_tend_tim)
+
+       CALL rk_scalar_tend (  im, im, config_flags,                                      &
+                              rk_step, dt_rk,                                            &
+                              grid%em_ru_m, grid%em_rv_m, grid%em_ww_m,                  &
+                              grid%em_mut, grid%em_mub, grid%em_mu_1,                    &
+                              grid%em_alt,                                               &
+                              moist_old(ims,kms,jms,im),                                 &
+                              moist(ims,kms,jms,im),                                     &
+                              moist_tend(ims,kms,jms,im),                                &
+                              advect_tend,grid%rqvften,                                  &
+                              grid%qv_base, .true., grid%em_fnm, grid%em_fnp,            &
+                              grid%msfu, grid%msfv, grid%msft,                           &
+                              grid%rdx, grid%rdy, grid%em_rdn, grid%em_rdnw, grid%khdif, &
+                              grid%kvdif, grid%xkmhd,                                    &
+                              grid%diff_6th_opt, grid%diff_6th_factor,                   &
+                              config_flags%pd_moist,            &
+                              ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              grid%i_start(ij), grid%i_end(ij), &
+                              grid%j_start(ij), grid%j_end(ij), &
+                              k_start    , k_end               )
+
+BENCH_END(rk_scalar_tend_tim)
+
+BENCH_START(rlx_bdy_scalar_tim)
+     IF( ( config_flags%specified .or. config_flags%nested ) .and. rk_step == 1 ) THEN 
+         IF ( im .EQ. P_QV .OR. config_flags%nested ) THEN
+            CALL relax_bdy_scalar ( moist_tend(ims,kms,jms,im),            & 
+                                    moist(ims,kms,jms,im),  grid%em_mut,         &
+                                    moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im),moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
+                                    moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im),moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), &
+                                    config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
+                                    grid%dtbc, grid%fcx, grid%gcx,             &
+                                    config_flags,               &
+                                    ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                    ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                    ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                    grid%i_start(ij), grid%i_end(ij),      &
+                                    grid%j_start(ij), grid%j_end(ij),      &
+                                    k_start, k_end                        )
+
+            CALL spec_bdy_scalar  ( moist_tend(ims,kms,jms,im),                &
+                                    moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im),moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
+                                    moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im),moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), &
+                                    config_flags%spec_bdy_width, grid%spec_zone,                 &
+                                    config_flags,               &
+                                    ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                    ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                    ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                    grid%i_start(ij), grid%i_end(ij),          &
+                                    grid%j_start(ij), grid%j_end(ij),          &
+                                    k_start, k_end                               )
+          ENDIF
+     ENDIF
+BENCH_END(rlx_bdy_scalar_tim)
+
+   ENDDO moist_tile_loop_1
+   !$OMP END PARALLEL DO
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   moist_tile_loop_2: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_update_scalar' )
+
+BENCH_START(update_scal_tim)
+       CALL rk_update_scalar( im, im,                           &
+                              moist_old(ims,kms,jms,im),        &
+                              moist(ims,kms,jms,im),            &
+                              moist_tend(ims,kms,jms,im),       &
+                              advect_tend, grid%msft,                &
+                              grid%em_mu_1, grid%em_mu_2, grid%em_mub,                  &
+                              rk_step, dt_rk, grid%spec_zone,        &
+                              config_flags,     &
+                              ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              grid%i_start(ij), grid%i_end(ij), &
+                              grid%j_start(ij), grid%j_end(ij), &
+                              k_start    , k_end               )
+BENCH_END(update_scal_tim)
+
+BENCH_START(flow_depbdy_tim)
+       IF( config_flags%specified ) THEN
+         IF(im .ne. P_QV)THEN
+           CALL flow_dep_bdy  (  moist(ims,kms,jms,im),                     &
+                               grid%em_ru_m, grid%em_rv_m, config_flags, &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, kds,kde,  & ! domain dims
+                               ims,ime, jms,jme, kms,kme,  & ! memory dims
+                               ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                               grid%i_start(ij), grid%i_end(ij),                      &
+                               grid%j_start(ij), grid%j_end(ij),                      &
+                               k_start, k_end                               )
+         ENDIF
+       ENDIF
+BENCH_END(flow_depbdy_tim)
+
+   ENDDO moist_tile_loop_2
+   !$OMP END PARALLEL DO
+
+     ENDIF  !-- if (grid%adv_moist_cond .or. im==p_qv ) then
+
+   ENDDO moist_variable_loop
+
+ ENDIF moist_scalar_advance
+
+BENCH_START(tke_adv_tim)
+ TKE_advance: IF (config_flags%km_opt .eq. 2) then
+
+#ifdef DM_PARALLEL
+      IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#       include "HALO_EM_TKE_ADVECT_3.inc"
+      ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#       include "HALO_EM_TKE_ADVECT_5.inc"
+      ELSE
+        WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      ENDIF
+#endif
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   tke_tile_loop_1: DO ij = 1 , grid%num_tiles
+
+     CALL wrf_debug ( 200 , ' call rk_scalar_tend for tke' )
+     CALL rk_scalar_tend ( 1, 1, config_flags,                                        &
+                           rk_step, dt_rk,                                            &
+                           grid%em_ru_m, grid%em_rv_m, grid%em_ww_m,                  &
+                           grid%em_mut, grid%em_mub, grid%em_mu_1,                    &
+                           grid%em_alt,                                               &
+                           grid%em_tke_1,                                             &
+                           grid%em_tke_2,                                             &
+                           tke_tend(ims,kms,jms),                                     &
+                           advect_tend,grid%rqvften,                                  &
+                           grid%qv_base, .false., grid%em_fnm, grid%em_fnp,           &
+                           grid%msfu, grid%msfv, grid%msft,                           &
+                           grid%rdx, grid%rdy, grid%em_rdn, grid%em_rdnw, grid%khdif, &
+                           grid%kvdif, grid%xkmhd,                                    &
+                           grid%diff_6th_opt, grid%diff_6th_factor,                   &
+                           config_flags%pd_tke,              &
+                           ids, ide, jds, jde, kds, kde,     &
+                           ims, ime, jms, jme, kms, kme,     &
+                           grid%i_start(ij), grid%i_end(ij), &
+                           grid%j_start(ij), grid%j_end(ij), &
+                           k_start    , k_end               )
+
+   ENDDO tke_tile_loop_1
+   !$OMP END PARALLEL DO
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   tke_tile_loop_2: DO ij = 1 , grid%num_tiles
+
+     CALL wrf_debug ( 200 , ' call rk_update_scalar' )
+     CALL rk_update_scalar( 1, 1,                             &
+                            grid%em_tke_1,               &
+                            grid%em_tke_2,               &
+                            tke_tend(ims,kms,jms),            &
+                            advect_tend,grid%msft,                 &
+                            grid%em_mu_1, grid%em_mu_2, grid%em_mub,                  &
+                            rk_step, dt_rk, grid%spec_zone,        &
+                            config_flags,     &
+                            ids, ide, jds, jde, kds, kde,     &
+                            ims, ime, jms, jme, kms, kme,     &
+                            grid%i_start(ij), grid%i_end(ij), &
+                            grid%j_start(ij), grid%j_end(ij), &
+                            k_start    , k_end               ) 
+
+! bound the tke (greater than 0, less than tke_upper_bound)
+
+     CALL bound_tke( grid%em_tke_2, grid%tke_upper_bound, &
+                     ids, ide, jds, jde, kds, kde,        &
+                     ims, ime, jms, jme, kms, kme,        &
+                     grid%i_start(ij), grid%i_end(ij),    &
+                     grid%j_start(ij), grid%j_end(ij),    &
+                     k_start    , k_end                  )
+
+     IF( config_flags%specified .or. config_flags%nested ) THEN
+         CALL flow_dep_bdy (  grid%em_tke_2,                     &
+                              grid%em_ru_m, grid%em_rv_m, config_flags,               &
+                              grid%spec_zone,                              &
+                              ids,ide, jds,jde, kds,kde,  & ! domain dims
+                              ims,ime, jms,jme, kms,kme,  & ! memory dims
+                              ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                              grid%i_start(ij), grid%i_end(ij),       &
+                              grid%j_start(ij), grid%j_end(ij),       &
+                              k_start, k_end                               )
+     ENDIF
+   ENDDO tke_tile_loop_2
+   !$OMP END PARALLEL DO
+
+   END IF TKE_advance
+BENCH_END(tke_adv_tim)
+
+#ifdef WRF_CHEM
+!  next the chemical species
+BENCH_START(chem_adv_tim)
+  chem_scalar_advance: IF (num_3d_c >= PARAM_FIRST_SCALAR)  THEN
+
+   chem_variable_loop: do ic = PARAM_FIRST_SCALAR, num_3d_c
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   chem_tile_loop_1: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_scalar_tend in chem_tile_loop_1' )
+       CALL rk_scalar_tend ( ic, ic, config_flags,                            &
+                             rk_step, dt_rk,                                  &
+                             grid%em_ru_m, grid%em_rv_m, grid%em_ww_m,        &
+                             grid%em_mut, grid%em_mub, grid%em_mu_1,          &
+                             grid%em_alt,                                     &
+                             chem_old(ims,kms,jms,ic),                        &
+                             chem(ims,kms,jms,ic),                            &
+                             chem_tend(ims,kms,jms,ic),                       &
+                             advect_tend,grid%rqvften,                        &
+                             grid%qv_base, .false., grid%em_fnm, grid%em_fnp, &
+                             grid%msfu, grid%msfv, grid%msft,                 &
+                             grid%rdx, grid%rdy, grid%em_rdn, grid%em_rdnw,   &
+                             grid%khdif, grid%kvdif, grid%xkmhd,              &
+                             grid%diff_6th_opt, grid%diff_6th_factor,         &
+                             config_flags%pd_chem,             &
+                             ids, ide, jds, jde, kds, kde,     &
+                             ims, ime, jms, jme, kms, kme,     &
+                             grid%i_start(ij), grid%i_end(ij), &
+                             grid%j_start(ij), grid%j_end(ij), &
+                             k_start    , k_end               )
+!
+! Currently, chemistry species with specified boundaries (i.e. the mother
+! domain)  are being over written by flow_dep_bdy_chem. So, relax_bdy and
+! spec_bdy are only called for nests. For boundary conditions from global model or larger domain,
+! chem is uncoupled, and only used for one row/column on inflow (if have_bcs_chem=.true.) 
+!
+     IF( ( config_flags%nested ) .and. rk_step == 1 ) THEN
+       if(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_chem' )
+
+         CALL relax_bdy_scalar ( chem_tend(ims,kms,jms,ic),             &
+                                 chem(ims,kms,jms,ic),  grid%em_mut,            &
+                                 chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic),chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
+                                 chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic),chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
+                                 config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
+                                 grid%dtbc, grid%fcx, grid%gcx,             &
+                                 config_flags,               &
+                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                 grid%i_start(ij), grid%i_end(ij),      &
+                                 grid%j_start(ij), grid%j_end(ij),      &
+                                 k_start, k_end                         )
+         CALL spec_bdy_scalar  ( chem_tend(ims,kms,jms,ic),                 &
+                                 chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic),chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
+                                 chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic),chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
+                                 config_flags%spec_bdy_width, grid%spec_zone,                 &
+                                 config_flags,               &
+                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                 grid%i_start(ij), grid%i_end(ij),          &
+                                 grid%j_start(ij), grid%j_end(ij),          &
+                                 k_start, k_end                             )
+     ENDIF
+
+   ENDDO chem_tile_loop_1
+
+   !$OMP END PARALLEL DO
+
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   chem_tile_loop_2: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_update_scalar' )
+       CALL rk_update_scalar( ic, ic,                           &
+                              chem_old(ims,kms,jms,ic),         &  ! was chem_1
+                              chem(ims,kms,jms,ic),             &
+                              chem_tend(ims,kms,jms,ic),        &
+                              advect_tend, grid%msft,                &
+                              grid%em_mu_1, grid%em_mu_2, grid%em_mub,                  &
+                              rk_step, dt_rk, grid%spec_zone,        &
+                              config_flags,     &
+                              ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              grid%i_start(ij), grid%i_end(ij), &
+                              grid%j_start(ij), grid%j_end(ij), &
+                              k_start    , k_end               )
+
+
+       IF( config_flags%specified  ) THEN
+! come back to this and figure out why two different routines are needed. JM 20041203
+!#ifndef WRF_CHEM
+!!$           CALL flow_dep_bdy  ( chem(ims,kms,jms,ic),       &
+!!$                                grid%em_ru_m, grid%em_rv_m, config_flags,   &
+!!$                                grid%spec_zone,             &
+!!$                                ids,ide, jds,jde, kds,kde,  & ! domain dims
+!!$                                ims,ime, jms,jme, kms,kme,  & ! memory dims
+!!$                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+!!$                                grid%i_start(ij), grid%i_end(ij),  &
+!!$                                grid%j_start(ij), grid%j_end(ij),  &
+!!$                                k_start, k_end                    )
+!#else
+           CALL flow_dep_bdy_chem( chem(ims,kms,jms,ic),            &
+                                chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic),chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
+                                chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic),chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), &
+                                dt_rk, &
+                                config_flags%spec_bdy_width,grid%em_z,      &
+                                grid%have_bcs_chem,      &
+                                grid%em_ru_m, grid%em_rv_m, config_flags,grid%em_alt,       &
+                                grid%em_t_1,grid%em_pb,grid%em_p,t0,p1000mb,rcp,grid%em_ph_2,grid%em_phb,g, &
+                                grid%spec_zone,ic,                  &
+                                ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                grid%i_start(ij), grid%i_end(ij),   &
+                                grid%j_start(ij), grid%j_end(ij),   &
+                                k_start, k_end                      )
+!#endif
+       ENDIF
+
+
+   ENDDO chem_tile_loop_2
+   !$OMP END PARALLEL DO
+
+   ENDDO chem_variable_loop
+
+ ENDIF chem_scalar_advance
+BENCH_END(chem_adv_tim)
+#endif
+
+!  next the other scalar species
+  other_scalar_advance: IF (num_3d_s >= PARAM_FIRST_SCALAR)  THEN
+
+   scalar_variable_loop: do is = PARAM_FIRST_SCALAR, num_3d_s
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   scalar_tile_loop_1: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_scalar_tend' )
+       CALL rk_scalar_tend ( is, is, config_flags,                            &
+                             rk_step, dt_rk,                                  &
+                             grid%em_ru_m, grid%em_rv_m, grid%em_ww_m,        &
+                             grid%em_mut, grid%em_mub, grid%em_mu_1,          &
+                             grid%em_alt,                                     &
+                             scalar_old(ims,kms,jms,is),                      &
+                             scalar(ims,kms,jms,is),                          &
+                             scalar_tend(ims,kms,jms,is),                     &
+                             advect_tend,grid%rqvften,                        &
+                             grid%qv_base, .false., grid%em_fnm, grid%em_fnp, &
+                             grid%msfu, grid%msfv, grid%msft,                 &
+                             grid%rdx, grid%rdy, grid%em_rdn, grid%em_rdnw,   &
+                             grid%khdif, grid%kvdif, grid%xkmhd,              &
+                             grid%diff_6th_opt, grid%diff_6th_factor,         &
+                             config_flags%pd_scalar,           &
+                             ids, ide, jds, jde, kds, kde,     &
+                             ims, ime, jms, jme, kms, kme,     &
+                             grid%i_start(ij), grid%i_end(ij), &
+                             grid%j_start(ij), grid%j_end(ij), &
+                             k_start    , k_end               )
+
+     IF( config_flags%nested .and. (rk_step == 1) ) THEN
+
+       IF (is .eq. P_QNDROP .OR. is .eq. P_QNI) THEN
+
+         CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is),            &
+                                 scalar(ims,kms,jms,is),  grid%em_mut,         &
+                                 scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is),scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
+                                 scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is),scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), &
+                                 config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, &
+                                 grid%dtbc, grid%fcx, grid%gcx,             &
+                                 config_flags,               &
+                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                 grid%i_start(ij), grid%i_end(ij),      &
+                                 grid%j_start(ij), grid%j_end(ij),      &
+                                 k_start, k_end                        )
+
+         CALL spec_bdy_scalar  ( scalar_tend(ims,kms,jms,is),                &
+                                 scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is),scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
+                                 scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is),scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), &
+                                 config_flags%spec_bdy_width, grid%spec_zone,                 &
+                                 config_flags,               &
+                                 ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                 ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                 ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                 grid%i_start(ij), grid%i_end(ij),          &
+                                 grid%j_start(ij), grid%j_end(ij),          &
+                                 k_start, k_end                               )
+
+       ENDIF
+
+     ENDIF ! b.c test for chem nested boundary condition
+
+   ENDDO scalar_tile_loop_1
+   !$OMP END PARALLEL DO
+
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   scalar_tile_loop_2: DO ij = 1 , grid%num_tiles
+
+       CALL wrf_debug ( 200 , ' call rk_update_scalar' )
+       CALL rk_update_scalar( is, is,                           &
+                              scalar_old(ims,kms,jms,is),       &  ! was scalar_1
+                              scalar(ims,kms,jms,is),           &
+                              scalar_tend(ims,kms,jms,is),      &
+                              advect_tend, grid%msft,                &
+                              grid%em_mu_1, grid%em_mu_2, grid%em_mub,                  &
+                              rk_step, dt_rk, grid%spec_zone,        &
+                              config_flags,     &
+                              ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              grid%i_start(ij), grid%i_end(ij), &
+                              grid%j_start(ij), grid%j_end(ij), &
+                              k_start    , k_end               )
+
+
+       IF( config_flags%specified ) THEN
+           CALL flow_dep_bdy  ( scalar(ims,kms,jms,is),     &
+                                grid%em_ru_m, grid%em_rv_m, config_flags,   &
+                                grid%spec_zone,                  &
+                                ids,ide, jds,jde, kds,kde,  & ! domain dims
+                                ims,ime, jms,jme, kms,kme,  & ! memory dims
+                                ips,ipe, jps,jpe, kps,kpe,  & ! patch  dims
+                                grid%i_start(ij), grid%i_end(ij),  &
+                                grid%j_start(ij), grid%j_end(ij),  &
+                                k_start, k_end                    )
+       ENDIF
+
+
+   ENDDO scalar_tile_loop_2
+   !$OMP END PARALLEL DO
+
+   ENDDO scalar_variable_loop
+
+ ENDIF other_scalar_advance
+
+ !  update the pressure and density at the new time level
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+
+BENCH_START(calc_p_rho_tim)
+
+     CALL calc_p_rho_phi( moist, num_3d_m,                &
+                          grid%em_al, grid%em_alb, grid%em_mu_2, grid%em_muts,              &
+                          grid%em_ph_2, grid%em_p, grid%em_pb, grid%em_t_2,                 &
+                          p0, t0, grid%em_znu, grid%em_dnw, grid%em_rdnw,           &
+                          grid%em_rdn, config_flags%non_hydrostatic,             &
+                          ids, ide, jds, jde, kds, kde,     &
+                          ims, ime, jms, jme, kms, kme,     &
+                          grid%i_start(ij), grid%i_end(ij), &
+                          grid%j_start(ij), grid%j_end(ij), &
+                          k_start    , k_end               )
+
+BENCH_END(calc_p_rho_tim)
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+!  Reset the boundary conditions if there is another corrector step.
+!  (rk_step < rk_order), else we'll handle it at the end of everything
+!  (after the split physics, before exiting the timestep).
+
+   rk_step_1_check: IF ( rk_step < rk_order ) THEN
+
+!-----------------------------------------------------------
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!  here's where we need a wide comm stencil - these are the 
+!  uncoupled variables so are used for high order calc in
+!  advection and mixong routines.
+!
+!                              * * * * *
+!            *        * * *    * * * * *
+!          * + *      * + *    * * + * * 
+!            *        * * *    * * * * *
+!                              * * * * *
+!
+!
+! grid%em_u_2                              x
+! grid%em_v_2                              x
+! grid%em_w_2                              x
+! grid%em_t_2                              x
+! grid%em_ph_2                             x
+! grid%em_al         x
+!
+!  2D variable
+! grid%em_mu_2       x
+!
+!  4D variable
+! moist               x
+! chem                x
+!scalar               x
+
+#ifdef DM_PARALLEL
+   IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#    include "HALO_EM_D2_3.inc"
+   ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#    include "HALO_EM_D2_5.inc"
+   ELSE 
+     WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+     CALL wrf_error_fatal(TRIM(wrf_err_message))
+   ENDIF
+#  include "PERIOD_BDY_EM_D.inc"
+#  include "PERIOD_BDY_EM_MOIST2.inc"
+#  include "PERIOD_BDY_EM_CHEM2.inc"
+#  include "PERIOD_BDY_EM_SCALAR2.inc"
+#endif
+
+BENCH_START(bc_end_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+    tile_bc_loop_1: DO ij = 1 , grid%num_tiles
+
+
+      CALL wrf_debug ( 200 , ' call rk_phys_bc_dry_2' )
+
+      CALL rk_phys_bc_dry_2( config_flags,                         &
+                             grid%em_u_2, grid%em_v_2, grid%em_w_2,                    &
+                             grid%em_t_2, grid%em_ph_2, grid%em_mu_2,                  &
+                             ids, ide, jds, jde, kds, kde,     &
+                             ims, ime, jms, jme, kms, kme,     &
+                             ips, ipe, jps, jpe, kps, kpe,     &
+                             grid%i_start(ij), grid%i_end(ij), &
+                             grid%j_start(ij), grid%j_end(ij), &
+                             k_start    , k_end               )
+
+BENCH_START(diag_w_tim)
+     IF (.not. config_flags%non_hydrostatic) THEN
+     CALL diagnose_w( ph_tend, grid%em_ph_2, grid%em_ph_1, grid%em_w_2, grid%em_muts, dt_rk,  &
+                      grid%em_u_2, grid%em_v_2, grid%ht,                           &
+                      grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msft,          &
+                      ids, ide, jds, jde, kds, kde,           &
+                      ims, ime, jms, jme, kms, kme,           &
+                      grid%i_start(ij), grid%i_end(ij),       &
+                      grid%j_start(ij), grid%j_end(ij),       &
+                      k_start    , k_end                     )
+     ENDIF
+BENCH_END(diag_w_tim)
+
+      IF (num_3d_m >= PARAM_FIRST_SCALAR) THEN
+
+        moisture_loop_bdy_1 : DO im = PARAM_FIRST_SCALAR , num_3d_m
+  
+          CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p', config_flags,   &
+                                   ids, ide, jds, jde, kds, kde,             &
+                                   ims, ime, jms, jme, kms, kme,             &
+                                   ips, ipe, jps, jpe, kps, kpe,             &
+                                   grid%i_start(ij), grid%i_end(ij),                   &
+                                   grid%j_start(ij), grid%j_end(ij),                   &
+                                   k_start    , k_end                       )
+         END DO moisture_loop_bdy_1
+
+      ENDIF
+
+      IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
+
+        chem_species_bdy_loop_1 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
+
+          CALL set_physical_bc3d( chem(ims,kms,jms,ic), 'p', config_flags,   &
+                                  ids, ide, jds, jde, kds, kde,            &
+                                  ims, ime, jms, jme, kms, kme,            &
+                                  ips, ipe, jps, jpe, kps, kpe,            &
+                                  grid%i_start(ij), grid%i_end(ij),                  &
+                                  grid%j_start(ij), grid%j_end(ij),                  &
+                                  k_start    , k_end-1                    )
+
+        END DO chem_species_bdy_loop_1
+
+      END IF
+
+      IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN
+
+        scalar_species_bdy_loop_1 : DO is = PARAM_FIRST_SCALAR , num_3d_s
+
+          CALL set_physical_bc3d( scalar(ims,kms,jms,is), 'p', config_flags,   &
+                                  ids, ide, jds, jde, kds, kde,            &
+                                  ims, ime, jms, jme, kms, kme,            &
+                                  ips, ipe, jps, jpe, kps, kpe,            &
+                                  grid%i_start(ij), grid%i_end(ij),                  &
+                                  grid%j_start(ij), grid%j_end(ij),                  &
+                                  k_start    , k_end-1                    )
+
+        END DO scalar_species_bdy_loop_1
+
+      END IF
+
+      IF (config_flags%km_opt .eq. 2) THEN
+
+        CALL set_physical_bc3d( grid%em_tke_2 , 'p', config_flags,  &
+                                ids, ide, jds, jde, kds, kde,            &
+                                ims, ime, jms, jme, kms, kme,            &
+                                ips, ipe, jps, jpe, kps, kpe,            &
+                                grid%i_start(ij), grid%i_end(ij),        &
+                                grid%j_start(ij), grid%j_end(ij),        &
+                                k_start    , k_end                      )
+      END IF
+
+    END DO tile_bc_loop_1
+   !$OMP END PARALLEL DO
+BENCH_END(bc_end_tim)
+
+
+#ifdef DM_PARALLEL
+
+!                           * * * * *
+!         *        * * *    * * * * *
+!       * + *      * + *    * * + * *
+!         *        * * *    * * * * *
+!                           * * * * *
+
+! moist, chem, scalar, tke      x
+
+
+      IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+        IF ( (config_flags%pd_tke) .and. (rk_step == rk_order-1) ) THEN
+#         include "HALO_EM_TKE_5.inc"
+        ELSE
+#         include "HALO_EM_TKE_3.inc"
+        ENDIF
+      ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+        IF ( (config_flags%pd_tke) .and. (rk_step == rk_order-1) ) THEN
+#         include "HALO_EM_TKE_7.inc"
+        ELSE
+#         include "HALO_EM_TKE_5.inc"
+        ENDIF
+      ELSE
+        WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      ENDIF
+
+#if 0
+   IF (config_flags%km_opt .eq. 2) THEN
+#      include  "HALO_EM_TKE_F.inc"
+   ENDIF
+#endif
+
+   if ( num_moist .ge. PARAM_FIRST_SCALAR ) then
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+       IF ( (config_flags%pd_moist) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_MOIST_E_5.inc"
+       ELSE
+#        include "HALO_EM_MOIST_E_3.inc"
+       END IF
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+       IF ( (config_flags%pd_moist) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_MOIST_E_7.inc"
+       ELSE
+#        include "HALO_EM_MOIST_E_5.inc"
+       END IF
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+   if ( num_chem >= PARAM_FIRST_SCALAR ) then
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+       IF ( (config_flags%pd_chem) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_CHEM_E_5.inc"
+       ELSE
+#        include "HALO_EM_CHEM_E_3.inc"
+       END IF
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+       IF ( (config_flags%pd_chem) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_CHEM_E_7.inc"
+       ELSE
+#        include "HALO_EM_CHEM_E_5.inc"
+       END IF
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+   if ( num_scalar >= PARAM_FIRST_SCALAR ) then
+     IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+       IF ( (config_flags%pd_scalar) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_SCALAR_E_5.inc"
+       ELSE
+#        include "HALO_EM_SCALAR_E_3.inc"
+       END IF
+     ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+       IF ( (config_flags%pd_scalar) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_SCALAR_E_7.inc"
+       ELSE
+#        include "HALO_EM_SCALAR_E_5.inc"
+       END IF
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+#endif
+
+   ENDIF rk_step_1_check
+
+
+!**********************************************************
+!
+!  end of RK predictor-corrector loop
+!
+!**********************************************************
+
+ END DO Runge_Kutta_loop
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , grid%num_tiles
+
+BENCH_START(advance_ppt_tim)
+      CALL wrf_debug ( 200 , ' call advance_ppt' )
+      CALL advance_ppt(grid%rthcuten,grid%rqvcuten,grid%rqccuten,grid%rqrcuten, &
+                     grid%rqicuten,grid%rqscuten,grid%rainc,grid%raincv,grid%nca,    &
+                     grid%htop,grid%hbot,grid%cutop,grid%cubot,                 &
+                     grid%cuppt, config_flags,                   &
+                     ids,ide, jds,jde, kds,kde,             &
+                     ims,ime, jms,jme, kms,kme,             &
+                     grid%i_start(ij), grid%i_end(ij),      &
+                     grid%j_start(ij), grid%j_end(ij),      &
+                     k_start    , k_end                    )
+BENCH_END(advance_ppt_tim)
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+!
+!
+! (5) time-split physics.
+!
+!     Microphysics are the only time  split physics in the WRF model 
+!     at this time.  Split-physics begins with the calculation of
+!     needed diagnostic quantities (pressure, temperature, etc.)
+!     followed by a call to the microphysics driver, 
+!     and finishes with a clean-up, storing off of a diabatic tendency
+!     from the moist physics, and a re-calulation of the  diagnostic
+!     quantities pressure and density.
+!

+!
+
+  IF (config_flags%mp_physics /= 0)  then
+
+   IF( config_flags%specified .or. config_flags%nested ) THEN
+     sz = grid%spec_zone
+   ELSE
+     sz = 0
+   ENDIF
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij, its, ite, jts, jte )
+
+   scalar_tile_loop_1a: DO ij = 1 , grid%num_tiles
+
+       IF ( config_flags%periodic_x ) THEN
+         its = max(grid%i_start(ij),ids)
+         ite = min(grid%i_end(ij),ide-1)
+       ELSE
+         its = max(grid%i_start(ij),ids+sz)
+         ite = min(grid%i_end(ij),ide-1-sz)
+       ENDIF
+       jts = max(grid%j_start(ij),jds+sz)
+       jte = min(grid%j_end(ij),jde-1-sz)
+
+       CALL wrf_debug ( 200 , ' call moist_physics_prep' )
+BENCH_START(moist_physics_prep_tim)
+       CALL moist_physics_prep_em( grid%em_t_2, grid%em_t_1, t0, rho,                &
+                                   grid%em_al, grid%em_alb, grid%em_p, p8w, p0, grid%em_pb,          &
+                                   grid%em_ph_2, grid%em_phb, th_phy, pi_phy, p_phy, &
+                                   grid%em_z, z_at_w, dz8w,                  &
+                                   dtm, grid%h_diabatic,                  &
+                                   config_flags,grid%em_fnm, grid%em_fnp,            &
+                                   ids, ide, jds, jde, kds, kde,     &
+                                   ims, ime, jms, jme, kms, kme,     &
+                                   its, ite, jts, jte,               &
+                                   k_start    , k_end               )
+BENCH_END(moist_physics_prep_tim)
+   END DO scalar_tile_loop_1a
+   !$OMP END PARALLEL DO
+
+       CALL wrf_debug ( 200 , ' call microphysics_driver' )
+
+       grid%em_sr = 0.
+       specified_bdy = config_flags%specified .OR. config_flags%nested
+       channel_bdy = config_flags%specified .AND. config_flags%periodic_x
+
+#if 0
+BENCH_START(microswap_1)
+! for load balancing; communication to redistribute the points
+   IF ( config_flags%mp_physics .EQ. ETAMPNEW ) THEN
+#include "SWAP_ETAMP_NEW.inc"
+   ELSE IF ( config_flags%mp_physics .EQ. WSM3SCHEME ) THEN
+#include "SWAP_WSM3.inc"
+   ENDIF
+BENCH_END(microswap_1)
+#endif
+
+BENCH_START(micro_driver_tim)
+
+       CALL microphysics_driver(                                          &
+     &         DT=dtm             ,DX=grid%dx              ,DY=grid%dy              &
+     &        ,DZ8W=dz8w          ,F_ICE_PHY=grid%f_ice_phy                    &
+     &        ,ITIMESTEP=grid%itimestep                    ,LOWLYR=grid%lowlyr      &
+     &        ,P8W=p8w            ,P=p_phy            ,PI_PHY=pi_phy      &
+     &        ,RHO=rho            ,SPEC_ZONE=grid%spec_zone                    &
+     &        ,SR=grid%em_sr              ,TH=th_phy                              &
+     &        ,WARM_RAIN=grid%warm_rain                                   &
+     &        ,T8W=t8w                                                    &
+     &        ,CLDFRA=grid%cldfra, EXCH_H=grid%exch_h &
+     &        ,NSOURCE=grid%qndropsource                                  &
+#ifdef WRF_CHEM
+     &        ,QLSINK=grid%qlsink,CLDFRA_OLD=grid%cldfra_old             &
+     &        ,PRECR=grid%precr, PRECI=grid%preci, PRECS=grid%precs, PRECG=grid%precg &
+#endif
+     &        ,XLAND=grid%xland                                           &
+     &        ,SPECIFIED=specified_bdy, CHANNEL_SWITCH=channel_bdy        &
+     &        ,F_RAIN_PHY=grid%f_rain_phy                                      &
+     &        ,F_RIMEF_PHY=grid%f_rimef_phy                                    &
+     &        ,MP_PHYSICS=config_flags%mp_physics                         &
+     &        ,ID=grid%id                                                 &
+     &        ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde          &
+     &        ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme          &
+     &        ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)          &
+     &        ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)          &
+     &        ,KTS=k_start, KTE=min(k_end,kde-1)                          &
+     &        ,NUM_TILES=grid%num_tiles                                   &
+     &        ,NAER=grid%naer                                             &
+                 ! Optional
+     &        , RAINNC=grid%rainnc, RAINNCV=grid%rainncv                            &
+     &        , SNOWNC=grid%snownc, SNOWNCV=grid%snowncv                            &
+     &        , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv                &
+     &        , W=grid%em_w_2, Z=grid%em_z, HT=grid%ht                                         &
+     &        , MP_RESTART_STATE=grid%mp_restart_state                         &
+     &        , TBPVS_STATE=grid%tbpvs_state                                   & ! etampnew
+     &        , TBPVS0_STATE=grid%tbpvs0_state                                 & ! etampnew
+     &        , QV_CURR=moist(ims,kms,jms,P_QV), F_QV=F_QV              &
+     &        , QC_CURR=moist(ims,kms,jms,P_QC), F_QC=F_QC              &
+     &        , QR_CURR=moist(ims,kms,jms,P_QR), F_QR=F_QR              &
+     &        , QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI              &
+     &        , QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS              &
+     &        , QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG              &
+     &        , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
+     &        , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI         &
+     &        , QT_CURR=scalar(ims,kms,jms,P_QT), F_QT=F_QT             &
+                                                                          )
+BENCH_END(micro_driver_tim)
+
+#if 0
+BENCH_START(microswap_2)
+! for load balancing; communication to redistribute the points
+   IF ( config_flags%mp_physics .EQ. ETAMPNEW ) THEN
+#include "SWAP_ETAMP_NEW.inc"
+   ELSE IF ( config_flags%mp_physics .EQ. WSM3SCHEME ) THEN
+#include "SWAP_WSM3.inc"
+   ENDIF
+BENCH_END(microswap_2)
+#endif
+
+       CALL wrf_debug ( 200 , ' call moist_physics_finish' )
+BENCH_START(moist_phys_end_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij, its, ite, jts, jte )
+
+   scalar_tile_loop_1b: DO ij = 1 , grid%num_tiles
+
+       IF ( config_flags%periodic_x ) THEN
+         its = max(grid%i_start(ij),ids)
+         ite = min(grid%i_end(ij),ide-1)
+       ELSE
+         its = max(grid%i_start(ij),ids+sz)
+         ite = min(grid%i_end(ij),ide-1-sz)
+       ENDIF
+       jts = max(grid%j_start(ij),jds+sz)
+       jte = min(grid%j_end(ij),jde-1-sz)
+
+       CALL microphysics_zero_out (                                    &
+                     moist , num_moist , config_flags ,              &
+                     ids, ide, jds, jde, kds, kde,                     &
+                     ims, ime, jms, jme, kms, kme,                     &
+                     its, ite, jts, jte,                               &
+                     k_start    , k_end                                )
+
+       CALL moist_physics_finish_em( grid%em_t_2, grid%em_t_1, t0, grid%em_muts, th_phy,       &
+                                     grid%h_diabatic, dtm, config_flags,    &
+                                     ids, ide, jds, jde, kds, kde,     &
+                                     ims, ime, jms, jme, kms, kme,     &
+                                     its, ite, jts, jte,               &
+                                     k_start    , k_end               )
+
+       CALL calc_p_rho_phi( moist, num_3d_m,                &
+                            grid%em_al, grid%em_alb, grid%em_mu_2, grid%em_muts,              &
+                            grid%em_ph_2, grid%em_p, grid%em_pb, grid%em_t_2,                 &
+                            p0, t0, grid%em_znu, grid%em_dnw, grid%em_rdnw,           &
+                            grid%em_rdn, config_flags%non_hydrostatic,             &
+                            ids, ide, jds, jde, kds, kde,     &
+                            ims, ime, jms, jme, kms, kme,     &
+                            its, ite, jts, jte,               &
+                            k_start    , k_end               )
+
+   END DO scalar_tile_loop_1b
+   !$OMP END PARALLEL DO
+BENCH_END(moist_phys_end_tim)
+
+  ENDIF
+
+  IF (.not. config_flags%non_hydrostatic) THEN
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+     CALL diagnose_w( ph_tend, grid%em_ph_2, grid%em_ph_1, grid%em_w_2, grid%em_muts, dt_rk,  &
+                      grid%em_u_2, grid%em_v_2, grid%ht,                           &
+                      grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msft,          &
+                      ids, ide, jds, jde, kds, kde,           &
+                      ims, ime, jms, jme, kms, kme,           &
+                      grid%i_start(ij), grid%i_end(ij),       &
+                      grid%j_start(ij), grid%j_end(ij),       &
+                      k_start    , k_end                     )
+
+   END DO
+   !$OMP END PARALLEL DO
+  ENDIF
+
+   chem_tile_loop_3: DO ij = 1 , grid%num_tiles
+
+          CALL wrf_debug ( 200 , ' call scalar_tile_loop_2' )
+
+     IF ( num_3d_c >= PARAM_FIRST_SCALAR ) then
+
+!
+!  tiled chemistry not here, it is called from solve_interface, and found in chem_driver
+!
+
+     END IF
+
+   END DO chem_tile_loop_3
+
+
+   !  We're finished except for boundary condition (and patch) update
+
+   ! Boundary condition time (or communication time).  At this time, we have
+   ! implemented periodic and symmetric physical boundary conditions.
+
+   ! b.c. routine for data within patch.
+
+   ! we need to do both time levels of 
+   ! data because the time filter only works in the physical solution space.
+
+   ! First, do patch communications for boundary conditions (periodicity)
+
+!-----------------------------------------------------------
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!  here's where we need a wide comm stencil - these are the 
+!  uncoupled variables so are used for high order calc in
+!  advection and mixong routines.
+!
+!                              * * * * *
+!            *        * * *    * * * * *
+!          * + *      * + *    * * + * * 
+!            *        * * *    * * * * *
+!                              * * * * *
+!
+!   grid%em_u_1                            x
+!   grid%em_u_2                            x
+!   grid%em_v_1                            x
+!   grid%em_v_2                            x
+!   grid%em_w_1                            x
+!   grid%em_w_2                            x
+!   grid%em_t_1                            x
+!   grid%em_t_2                            x
+!  grid%em_ph_1                            x
+!  grid%em_ph_2                            x
+!  grid%em_tke_1                           x
+!  grid%em_tke_2                           x
+!
+!    2D variables
+!  grid%em_mu_1     x
+!  grid%em_mu_2     x
+!
+!    4D variables
+!  moist                         x
+!   chem                         x
+! scalar                         x
+!----------------------------------------------------------
+
+
+#ifdef DM_PARALLEL
+   IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#    include "HALO_EM_D3_3.inc"
+   ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#    include "HALO_EM_D3_5.inc"
+   ELSE 
+     WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+     CALL wrf_error_fatal(TRIM(wrf_err_message))
+   ENDIF
+#  include "PERIOD_BDY_EM_D3.inc"
+#  include "PERIOD_BDY_EM_MOIST.inc"
+#  include "PERIOD_BDY_EM_CHEM.inc"
+#  include "PERIOD_BDY_EM_SCALAR.inc"
+#endif
+
+!  now set physical b.c on a patch
+
+BENCH_START(bc_2d_tim)
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+   tile_bc_loop_2: DO ij = 1 , grid%num_tiles
+
+
+     CALL wrf_debug ( 200 , ' call set_phys_bc_dry_2' )
+
+     CALL set_phys_bc_dry_2( config_flags,                           &
+                             grid%em_u_1, grid%em_u_2, grid%em_v_1, grid%em_v_2, grid%em_w_1, grid%em_w_2,           &
+                             grid%em_t_1, grid%em_t_2, grid%em_ph_1, grid%em_ph_2, grid%em_mu_1, grid%em_mu_2,       &
+                             ids, ide, jds, jde, kds, kde,           &
+                             ims, ime, jms, jme, kms, kme,           &
+                             ips, ipe, jps, jpe, kps, kpe,           &
+                             grid%i_start(ij), grid%i_end(ij),       &
+                             grid%j_start(ij), grid%j_end(ij),       &
+                             k_start    , k_end                     )
+
+     CALL set_physical_bc3d( grid%em_tke_1, 'p', config_flags,   &
+                             ids, ide, jds, jde, kds, kde,            &
+                             ims, ime, jms, jme, kms, kme,            &
+                             ips, ipe, jps, jpe, kps, kpe,            &
+                             grid%i_start(ij), grid%i_end(ij),        &
+                             grid%j_start(ij), grid%j_end(ij),        &
+                             k_start    , k_end-1                    )
+     CALL set_physical_bc3d( grid%em_tke_2 , 'p', config_flags,  &
+                             ids, ide, jds, jde, kds, kde,            &
+                             ims, ime, jms, jme, kms, kme,            &
+                             ips, ipe, jps, jpe, kps, kpe,            &
+                             grid%i_start(ij), grid%i_end(ij),        &
+                             grid%j_start(ij), grid%j_end(ij),        &
+                             k_start    , k_end                      )
+
+     moisture_loop_bdy_2 : DO im = PARAM_FIRST_SCALAR , num_3d_m
+
+       CALL set_physical_bc3d( moist(ims,kms,jms,im), 'p',           &
+                               config_flags,                           &
+                               ids, ide, jds, jde, kds, kde,           &
+                               ims, ime, jms, jme, kms, kme,           &
+                               ips, ipe, jps, jpe, kps, kpe,           &
+                               grid%i_start(ij), grid%i_end(ij),       &
+                               grid%j_start(ij), grid%j_end(ij),       &
+                               k_start    , k_end                     )
+
+     END DO moisture_loop_bdy_2
+
+     chem_species_bdy_loop_2 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
+
+       CALL set_physical_bc3d( chem(ims,kms,jms,ic) , 'p', config_flags,  &
+                               ids, ide, jds, jde, kds, kde,            &
+                               ims, ime, jms, jme, kms, kme,            &
+                               ips, ipe, jps, jpe, kps, kpe,            &
+                               grid%i_start(ij), grid%i_end(ij),                  &
+                               grid%j_start(ij), grid%j_end(ij),                  &
+                               k_start    , k_end                      )
+
+     END DO chem_species_bdy_loop_2
+
+     scalar_species_bdy_loop_2 : DO is = PARAM_FIRST_SCALAR , num_3d_s
+
+       CALL set_physical_bc3d( scalar(ims,kms,jms,is) , 'p', config_flags,  &
+                               ids, ide, jds, jde, kds, kde,            &
+                               ims, ime, jms, jme, kms, kme,            &
+                               ips, ipe, jps, jpe, kps, kpe,            &
+                               grid%i_start(ij), grid%i_end(ij),                  &
+                               grid%j_start(ij), grid%j_end(ij),                  &
+                               k_start    , k_end                      )
+
+     END DO scalar_species_bdy_loop_2
+
+   END DO tile_bc_loop_2
+   !$OMP END PARALLEL DO
+BENCH_END(bc_2d_tim)
+
+   IF( config_flags%specified .or. config_flags%nested ) THEN 
+     grid%dtbc = grid%dtbc + grid%dt
+   ENDIF
+
+! calculate some model diagnostics.
+
+         CALL wrf_debug ( 200 , ' call diagnostic_driver' )
+   
+         CALL diagnostic_output_calc(                                     &
+     &              DPSDT=grid%dpsdt   ,DMUDT=grid%dmudt                  &
+     &             ,P_PHY=p_phy   ,PK1M=grid%pk1m                         &
+     &             ,MU_2=grid%em_mu_2  ,MU_2M=grid%mu_2m                  &
+     &             ,U=grid%em_u_2    ,V=grid%em_v_2                       &
+     &             ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv           &
+     &             ,RAINC=grid%rainc    ,RAINNC=grid%rainnc               &
+     &             ,HFX=grid%hfx   ,SFCEVP=grid%sfcevp    ,LH=grid%lh     &
+     &             ,DT=grid%dt      ,SBW=config_flags%spec_bdy_width      &
+     &             ,XTIME=grid%xtime                                      &
+                 ! Selection flag
+     &             ,DIAG_PRINT=config_flags%diag_print                    &
+                 ! Dimension arguments
+     &             ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
+     &             ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
+     &             ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe     &
+     &             ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
+     &             ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
+     &             ,KTS=k_start, KTE=min(k_end,kde-1)                     &
+     &             ,NUM_TILES=grid%num_tiles                              &
+     &                                                          )
+
+#ifdef DM_PARALLEL
+!-----------------------------------------------------------------------
+! see above
+!--------------------------------------------------------------
+   CALL wrf_debug ( 200 , ' call HALO_RK_E' )
+   IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#    include "HALO_EM_E_3.inc"
+   ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#    include "HALO_EM_E_5.inc"
+   ELSE
+     WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+     CALL wrf_error_fatal(TRIM(wrf_err_message))
+   ENDIF
+#endif
+
+#ifdef DM_PARALLEL
+   if ( num_moist >= PARAM_FIRST_SCALAR  ) then
+!-----------------------------------------------------------------------
+! see above
+!--------------------------------------------------------------
+     CALL wrf_debug ( 200 , ' call HALO_RK_MOIST' )
+     IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#      include "HALO_EM_MOIST_E_3.inc"
+     ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#      include "HALO_EM_MOIST_E_5.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+   if ( num_chem >= PARAM_FIRST_SCALAR ) then
+!-----------------------------------------------------------------------
+! see above
+!--------------------------------------------------------------
+     CALL wrf_debug ( 200 , ' call HALO_RK_CHEM' )
+     IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#      include "HALO_EM_CHEM_E_3.inc"
+     ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#      include "HALO_EM_CHEM_E_5.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+   if ( num_scalar >= PARAM_FIRST_SCALAR ) then
+!-----------------------------------------------------------------------
+! see above
+!--------------------------------------------------------------
+     CALL wrf_debug ( 200 , ' call HALO_RK_SCALAR' )
+     IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#      include "HALO_EM_SCALAR_E_3.inc"
+     ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#      include "HALO_EM_SCALAR_E_5.inc"
+     ELSE
+       WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order
+       CALL wrf_error_fatal(TRIM(wrf_err_message))
+     ENDIF
+   endif
+#endif
+
+   CALL wrf_debug ( 200 , ' call end of solve_em' )
+
+! Finish timers if compiled with -DBENCH.
+#include 
+
+   RETURN
+
+END SUBROUTINE solve_em
+
diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F
new file mode 100644
index 00000000..7f2567e0
--- /dev/null
+++ b/wrfv2_fire/dyn_em/start_em.F
@@ -0,0 +1,946 @@
+!-------------------------------------------------------------------
+
+   SUBROUTINE start_domain_em ( grid, allowed_to_read  &
+! Actual arguments generated from Registry
+# include "em_dummy_new_args.inc"
+!
+)
+
+   USE module_domain
+   USE module_dm
+!  USE module_io_domain
+   USE module_state_description
+   USE module_model_constants
+   USE module_bc
+   USE module_bc_em
+!  USE module_timing
+   USE module_configure
+   USE module_tiles
+
+   USE module_physics_init
+#ifdef WRF_CHEM
+   USE module_aerosols_sorgam, only: sum_pm_sorgam
+   USE module_mosaic_driver, only: sum_pm_mosaic
+#endif
+
+#ifdef DM_PARALLEL
+   USE module_dm
+#endif
+
+!!debug
+!USE module_compute_geop
+
+   USE module_model_constants
+   IMPLICIT NONE
+   !  Input data.
+   TYPE (domain)          :: grid
+
+   LOGICAL , INTENT(IN)   :: allowed_to_read
+
+   !  Definitions of dummy arguments to this routine (generated from Registry).
+# include "em_dummy_new_decl.inc"
+
+   !  Structure that contains run-time configuration (namelist) data for domain
+   TYPE (grid_config_rec_type)              :: config_flags
+
+   !  Local data
+   INTEGER                             ::                       &
+                                  ids, ide, jds, jde, kds, kde, &
+                                  ims, ime, jms, jme, kms, kme, &
+                                  ips, ipe, jps, jpe, kps, kpe, &
+                                  its, ite, jts, jte, kts, kte, &
+                                  ij,i,j,k,ii,jj,kk,loop,error,l
+
+   INTEGER     :: i_m
+
+   REAL        :: p00, t00, a, p_surf, pd_surf
+#ifdef WRF_CHEM
+   REAL        RGASUNIV ! universal gas constant [ J/mol-K ]
+   PARAMETER ( RGASUNIV = 8.314510 )
+      REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: &
+                      z_at_w,convfac
+   REAL :: tempfac
+#endif
+
+   REAL :: qvf1, qvf2, qvf
+   REAL :: MPDT
+   REAL :: spongeweight
+   LOGICAL :: first_trip_for_this_domain, start_of_simulation
+#ifndef WRF_CHEM
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: cldfra_old
+#endif
+
+   REAL :: lat1 , lat2 , lat3 , lat4
+   REAL :: lon1 , lon2 , lon3 , lon4
+   INTEGER :: num_points_lat_lon , iloc , jloc
+   CHARACTER (LEN=132) :: message
+
+! Needed by some comm layers, e.g. RSL. If needed, nmm_data_calls.inc is
+! generated from the registry.  The definition of REGISTER_I1 allows
+! I1 data to be communicated in this routine if necessary.
+#ifdef DM_PARALLEL
+#    include "em_data_calls.inc"
+#endif
+   CALL get_ijk_from_grid (  grid ,                   &
+                             ids, ide, jds, jde, kds, kde,    &
+                             ims, ime, jms, jme, kms, kme,    &
+                             ips, ipe, jps, jpe, kps, kpe    )
+
+   kts = kps ; kte = kpe     ! note that tile is entire patch
+   its = ips ; ite = ipe     ! note that tile is entire patch
+   jts = jps ; jte = jpe    ! note that tile is entire patch
+#ifndef WRF_CHEM
+         ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_OLD = 0.
+#endif
+   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+   IF ( ( MOD (ide-ids,config_flags%parent_grid_ratio) .NE. 0 ) .OR. &
+        ( MOD (jde-jds,config_flags%parent_grid_ratio) .NE. 0 ) ) THEN
+      WRITE(message, FMT='("Nested dimensions are illegal for domain ",I2,":  Both &
+         &MOD(",I4,"-",I1,",",I2,") and MOD(",I4,"-",I1,",",I2,") must = 0" )') &
+         grid%id,ide,ids,config_flags%parent_grid_ratio,jde,jds,config_flags%parent_grid_ratio
+      CALL wrf_error_fatal ( message ) 
+   END IF
+
+! here we check to see if the boundary conditions are set properly
+
+   CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
+
+!kludge - need to stop CG from resetting precip and phys tendencies to zero
+!         when we are in here due to a nest being spawned, we want to still
+!         recompute the base state, but that is about it
+   !  This is temporary and will need to be changed when grid%itimestep is removed.
+
+   IF ( grid%itimestep .EQ. 0 ) THEN
+      first_trip_for_this_domain = .TRUE.
+   ELSE
+      first_trip_for_this_domain = .FALSE.
+   END IF
+
+   IF ( .not. ( config_flags%restart .or. grid%moved ) ) THEN 
+       grid%itimestep=0
+   ENDIF
+
+   IF ( config_flags%restart .or. grid%moved ) THEN 
+       first_trip_for_this_domain = .TRUE.
+   ENDIF
+
+   IF (config_flags%specified) THEN
+!
+! Arrays for specified boundary conditions
+! wig: Add a combined exponential+linear weight on the mother boundaries
+!      following code changes by Ruby Leung. For the nested grid, there
+!      appears to be some problems when a sponge is used. The points where
+!      processors meet have problematic values.
+
+     DO loop = grid%spec_zone + 1, grid%spec_zone + grid%relax_zone
+       grid%fcx(loop) = 0.1 / grid%dt * (grid%spec_zone + grid%relax_zone - loop) / (grid%relax_zone - 1)
+       grid%gcx(loop) = 1.0 / grid%dt / 50. * (grid%spec_zone + grid%relax_zone - loop) / (grid%relax_zone - 1)
+!      spongeweight=exp(-(loop-2)/3.)
+!      grid%fcx(loop) = grid%fcx(loop)*spongeweight
+!      grid%gcx(loop) = grid%gcx(loop)*spongeweight
+     ENDDO
+
+   ELSE IF (config_flags%nested) THEN
+!
+! Arrays for nested boundary conditions
+
+     DO loop = grid%spec_zone + 1, grid%spec_zone + grid%relax_zone
+       grid%fcx(loop) = 0.1 / grid%dt * (grid%spec_zone + grid%relax_zone - loop) / (grid%relax_zone - 1)
+       grid%gcx(loop) = 1.0 / grid%dt / 50. * (grid%spec_zone + grid%relax_zone - loop) / (grid%relax_zone - 1)
+!      spongeweight=exp(-(loop-2)/3.)
+!      grid%fcx(loop) = grid%fcx(loop)*spongeweight
+!      grid%gcx(loop) = grid%gcx(loop)*spongeweight
+!      grid%fcx(loop) = 0.
+!      grid%gcx(loop) = 0.
+     ENDDO
+
+     grid%dtbc = 0.
+
+   ENDIF
+
+   IF ( ( grid%id .NE. 1 ) .AND. ( .NOT. config_flags%input_from_file ) ) THEN
+   
+      !  Every time a domain starts or every time a domain moves, this routine is called.  We want
+      !  the center (middle) lat/lon of the grid for the metacode.  The lat/lon values are
+      !  defined at mass points.  Depending on the even/odd points in the SN and WE directions,
+      !  we end up with the middle point as either 1 point or an average of either 2 or 4 points.
+      !  Add to this, the need to make sure that we are on the correct patch to retrieve the
+      !  value of the lat/lon, AND that the lat/lons (for an average) may not all be on the same
+      !  patch.  Once we find the correct value for lat lon, we need to keep it around on all patches, 
+      !  which is where the wrf_dm_min_real calls come in.  
+      !  If this is the most coarse domain, we do not go in here.  Also, if there is an input file
+      !  (which has the right values for the middle lat/lon) we do not go in this IF test.
+   
+      IF      ( ( MOD(ide,2) .EQ. 0 ) .AND. ( MOD(jde,2) .EQ. 0 ) ) THEN
+         num_points_lat_lon = 1
+         iloc = ide/2
+         jloc = jde/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat1 = grid%xlat (iloc,jloc)
+            lon1 = grid%xlong(iloc,jloc)
+         ELSE
+            lat1 = 99999.
+            lon1 = 99999.
+         END IF
+         lat1 = wrf_dm_min_real ( lat1 )
+         lon1 = wrf_dm_min_real ( lon1 )
+         CALL nl_set_cen_lat ( grid%id , lat1 )
+         CALL nl_set_cen_lon ( grid%id , lon1 )
+      ELSE IF ( ( MOD(ide,2) .NE. 0 ) .AND. ( MOD(jde,2) .EQ. 0 ) ) THEN
+         num_points_lat_lon = 2
+         iloc = (ide-1)/2
+         jloc =  jde   /2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat1 = grid%xlat (iloc,jloc)
+            lon1 = grid%xlong(iloc,jloc)
+         ELSE
+            lat1 = 99999.
+            lon1 = 99999.
+         END IF
+         lat1 = wrf_dm_min_real ( lat1 )
+         lon1 = wrf_dm_min_real ( lon1 )
+   
+         iloc = (ide+1)/2
+         jloc =  jde   /2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat2 = grid%xlat (iloc,jloc)
+            lon2 = grid%xlong(iloc,jloc)
+         ELSE
+            lat2 = 99999.
+            lon2 = 99999.
+         END IF
+         lat2 = wrf_dm_min_real ( lat2 )
+         lon2 = wrf_dm_min_real ( lon2 )
+   
+         CALL nl_set_cen_lat ( grid%id , ( lat1 + lat2 ) * 0.50 )
+         CALL nl_set_cen_lon ( grid%id , ( lon1 + lon2 ) * 0.50 )
+      ELSE IF ( ( MOD(ide,2) .EQ. 0 ) .AND. ( MOD(jde,2) .NE. 0 ) ) THEN
+         num_points_lat_lon = 2
+         iloc =  ide   /2
+         jloc = (jde-1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat1 = grid%xlat (iloc,jloc)
+            lon1 = grid%xlong(iloc,jloc)
+         ELSE
+            lat1 = 99999.
+            lon1 = 99999.
+         END IF
+         lat1 = wrf_dm_min_real ( lat1 )
+         lon1 = wrf_dm_min_real ( lon1 )
+   
+         iloc =  ide   /2
+         jloc = (jde+1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat2 = grid%xlat (iloc,jloc)
+            lon2 = grid%xlong(iloc,jloc)
+         ELSE
+            lat2 = 99999.
+            lon2 = 99999.
+         END IF
+         lat2 = wrf_dm_min_real ( lat2 )
+         lon2 = wrf_dm_min_real ( lon2 )
+   
+         CALL nl_set_cen_lat ( grid%id , ( lat1 + lat2 ) * 0.50 )
+         CALL nl_set_cen_lon ( grid%id , ( lon1 + lon2 ) * 0.50 )
+      ELSE IF ( ( MOD(ide,2) .NE. 0 ) .AND. ( MOD(jde,2) .NE. 0 ) ) THEN
+         num_points_lat_lon = 4
+         iloc = (ide-1)/2
+         jloc = (jde-1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat1 = grid%xlat (iloc,jloc)
+            lon1 = grid%xlong(iloc,jloc)
+         ELSE
+            lat1 = 99999.
+            lon1 = 99999.
+         END IF
+         lat1 = wrf_dm_min_real ( lat1 )
+         lon1 = wrf_dm_min_real ( lon1 )
+   
+         iloc = (ide+1)/2
+         jloc = (jde-1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat2 = grid%xlat (iloc,jloc)
+            lon2 = grid%xlong(iloc,jloc)
+         ELSE
+            lat2 = 99999.
+            lon2 = 99999.
+         END IF
+         lat2 = wrf_dm_min_real ( lat2 )
+         lon2 = wrf_dm_min_real ( lon2 )
+   
+         iloc = (ide-1)/2
+         jloc = (jde+1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat3 = grid%xlat (iloc,jloc)
+            lon3 = grid%xlong(iloc,jloc)
+         ELSE
+            lat3 = 99999.
+            lon3 = 99999.
+         END IF
+         lat3 = wrf_dm_min_real ( lat3 )
+         lon3 = wrf_dm_min_real ( lon3 )
+   
+         iloc = (ide+1)/2
+         jloc = (jde+1)/2
+         IF ( ( ips .LE. iloc ) .AND. ( ipe .GE. iloc ) .AND. &
+              ( jps .LE. jloc ) .AND. ( jpe .GE. jloc ) ) THEN
+            lat4 = grid%xlat (iloc,jloc)
+            lon4 = grid%xlong(iloc,jloc)
+         ELSE
+            lat4 = 99999.
+            lon4 = 99999.
+         END IF
+         lat4 = wrf_dm_min_real ( lat4 )
+         lon4 = wrf_dm_min_real ( lon4 )
+   
+         CALL nl_set_cen_lat ( grid%id , ( lat1 + lat2 + lat3 + lat4 ) * 0.25 )
+         CALL nl_set_cen_lon ( grid%id , ( lon1 + lon2 + lon3 + lon4 ) * 0.25 )
+      END IF
+   END IF
+
+   IF ( .NOT. config_flags%restart .AND. &
+        (( config_flags%input_from_hires ) .OR. ( config_flags%input_from_file ))) THEN
+
+      IF ( config_flags%map_proj .EQ. 0 ) THEN
+         CALL wrf_error_fatal ( 'start_domain: Idealized case cannot have a separate nested input file' )
+      END IF 
+
+      CALL nl_get_base_pres  ( 1 , p00 )
+      CALL nl_get_base_temp  ( 1 , t00 )
+      CALL nl_get_base_lapse ( 1 , a   )
+
+      !  Base state potential temperature and inverse density (alpha = 1/rho) from
+      !  the half eta levels and the base-profile surface pressure.  Compute 1/rho
+      !  from equation of state.  The potential temperature is a perturbation from t0.
+
+      DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+
+            !  Base state pressure is a function of eta level and terrain, only, plus
+            !  the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level
+            !  temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K).
+
+            p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
+
+            DO k = 1, kte-1
+               grid%em_pb(i,k,j) = grid%em_znu(k)*(p_surf - grid%p_top) + grid%p_top
+               grid%em_t_init(i,k,j) = (t00 + A*LOG(grid%em_pb(i,k,j)/p00))*(p00/grid%em_pb(i,k,j))**(r_d/cp) - t0
+               grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm
+            END DO
+
+            !  Base state mu is defined as base state surface pressure minus grid%p_top
+
+            grid%em_mub(i,j) = p_surf - grid%p_top
+
+            !  Integrate base geopotential, starting at terrain elevation.  This assures that
+            !  the base state is in exact hydrostatic balance with respect to the model equations.
+            !  This field is on full levels.
+
+            grid%em_phb(i,1,j) = grid%ht(i,j) * g
+            DO k  = 2,kte
+               grid%em_phb(i,k,j) = grid%em_phb(i,k-1,j) - grid%em_dnw(k-1)*grid%em_mub(i,j)*grid%em_alb(i,k-1,j)
+            END DO
+         END DO
+      END DO
+
+   ENDIF
+
+   IF(.not.config_flags%restart)THEN
+
+!  if this is for a nested domain, the defined/interpolated fields are the _2
+
+     IF ( first_trip_for_this_domain ) THEN
+
+! data that is expected to be zero must be explicitly initialized as such
+     grid%h_diabatic = 0.
+
+       DO j = jts,min(jte,jde-1)
+       DO k = kts,kte-1
+       DO i = its, min(ite,ide-1)
+           IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+             grid%em_t_1(i,k,j)=grid%em_t_2(i,k,j)
+           ENDIF
+       ENDDO
+       ENDDO
+       ENDDO
+  
+       DO j = jts,min(jte,jde-1)
+       DO i = its, min(ite,ide-1)
+           IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+             grid%em_mu_1(i,j)=grid%em_mu_2(i,j)
+           ENDIF
+       ENDDO
+       ENDDO
+     END IF
+
+!  reconstitute base-state fields
+
+    IF(config_flags%max_dom .EQ. 1)THEN
+! with single domain, grid%em_t_init from wrfinput is OK to use
+     DO j = jts,min(jte,jde-1)
+     DO k = kts,kte-1
+     DO i = its, min(ite,ide-1)
+       IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+         grid%em_pb(i,k,j) = grid%em_znu(k)*grid%em_mub(i,j)+grid%p_top
+         grid%em_alb(i,k,j) = (r_d/p1000mb)*(grid%em_t_init(i,k,j)+t0)*(grid%em_pb(i,k,j)/p1000mb)**cvpm
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+    ELSE
+! with nests, grid%em_t_init generally needs recomputations (since it is not interpolated)
+     DO j = jts,min(jte,jde-1)
+     DO k = kts,kte-1
+     DO i = its, min(ite,ide-1)
+       IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+         grid%em_pb(i,k,j) = grid%em_znu(k)*grid%em_mub(i,j)+grid%p_top
+         grid%em_alb(i,k,j) = -grid%em_rdnw(k)*(grid%em_phb(i,k+1,j)-grid%em_phb(i,k,j))/grid%em_mub(i,j)
+         grid%em_t_init(i,k,j) = grid%em_alb(i,k,j)*(p1000mb/r_d)/((grid%em_pb(i,k,j)/p1000mb)**cvpm) - t0
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+    ENDIF
+
+     DO j = jts,min(jte,jde-1)
+
+       k = kte-1
+       DO i = its, min(ite,ide-1)
+         IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+           qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV))
+           qvf2 = 1./(1.+qvf1)
+           qvf1 = qvf1*qvf2
+           grid%em_p(i,k,j) = - 0.5*(grid%em_mu_1(i,j)+qvf1*grid%em_mub(i,j))/grid%em_rdnw(k)/qvf2
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf*(((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm)
+           grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j)
+         ENDIF
+       ENDDO
+
+       DO k = kte-2, 1, -1
+       DO i = its, min(ite,ide-1)
+         IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+           qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV))
+           qvf2 = 1./(1.+qvf1)
+           qvf1 = qvf1*qvf2
+           grid%em_p(i,k,j) = grid%em_p(i,k+1,j) - (grid%em_mu_1(i,j) + qvf1*grid%em_mub(i,j))/qvf2/grid%em_rdn(k+1)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%em_alt(i,k,j) = (r_d/p1000mb)*(grid%em_t_1(i,k,j)+t0)*qvf* &
+                        (((grid%em_p(i,k,j)+grid%em_pb(i,k,j))/p1000mb)**cvpm)
+           grid%em_al(i,k,j) = grid%em_alt(i,k,j) - grid%em_alb(i,k,j)
+         ENDIF
+       ENDDO
+       ENDDO
+
+     ENDDO
+
+   ENDIF
+
+   IF ( ( grid%id .NE. 1 ) .AND. .NOT. ( config_flags%restart ) .AND. &
+       ( ( config_flags%input_from_hires ) .OR. ( config_flags%input_from_file ) ) ) THEN
+      DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+            grid%em_mu_2(i,j) = grid%em_mu_2(i,j) + grid%em_al(i,1,j) / ( grid%em_alt(i,1,j) * grid%em_alb(i,1,j) ) * &
+                                    g * ( grid%ht(i,j) - grid%ht_fine(i,j) )
+         END DO
+       END DO
+       DO j = jts,min(jte,jde-1)
+       DO i = its, min(ite,ide-1)
+          grid%em_mu_1(i,j)=grid%em_mu_2(i,j)
+       ENDDO
+       ENDDO
+
+   END IF
+
+   IF ( first_trip_for_this_domain ) THEN
+
+   CALL wrf_debug ( 100 , 'module_start: start_domain_rk: Before call to phy_init' )
+
+! namelist MPDT does not exist yet, so set it here
+! MPDT is the call frequency for microphysics in minutes (0 means every step)
+   MPDT = 0.
+
+! set GMT outside of phy_init because phy_init may not be called on this
+! process if, for example, it is a moving nest and if this part of the domain is not
+! being initialized (not the leading edge).
+   CALL domain_setgmtetc( grid, start_of_simulation )
+
+   CALL set_tiles ( grid , grid%imask_nostag, ims, ime, jms, jme, ips, ipe, jps, jpe )
+
+! Phy_init is not necessarily thread-safe; do not multi-thread this loop.
+! The tiling is to handle the fact that we may be masking off part of the computation.
+   DO ij = 1, grid%num_tiles
+
+     CALL phy_init (  grid%id , config_flags, grid%DT, grid%RESTART, grid%em_znw, grid%em_znu,   &
+                      grid%p_top, grid%tsk, grid%RADT,grid%BLDT,grid%CUDT, MPDT, &
+                      grid%rthcuten, grid%rqvcuten, grid%rqrcuten,           &
+                      grid%rqccuten, grid%rqscuten, grid%rqicuten,           &
+                      grid%rublten,grid%rvblten,grid%rthblten,               &
+                      grid%rqvblten,grid%rqcblten,grid%rqiblten,             &
+                      grid%rthraten,grid%rthratenlw,grid%rthratensw,         &
+                      grid%stepbl,grid%stepra,grid%stepcu,                   &
+                      grid%w0avg, grid%rainnc, grid%rainc, grid%raincv, grid%rainncv,  &
+                      grid%nca,grid%swrad_scat,                    &
+                      grid%cldefi,grid%lowlyr,                          &
+                      grid%mass_flux,                              &
+                      grid%rthften, grid%rqvften,                       &
+                      grid%cldfra,                                      &
+#ifdef WRF_CHEM
+                      grid%cldfra_old,                                  &
+#endif
+#ifndef WRF_CHEM
+                      cldfra_old,                                  &
+#endif
+                      grid%glw,grid%gsw,grid%emiss,grid%lu_index, &
+                      grid%landuse_ISICE, grid%landuse_LUCATS,            &
+                      grid%landuse_LUSEAS, grid%landuse_ISN,              &
+                      grid%lu_state,                                      &
+                      grid%xlat,grid%xlong,grid%albedo,grid%albbck,grid%GMT,grid%JULYR,grid%JULDAY,     &
+                      grid%levsiz, num_ozmixm, num_aerosolc, grid%paerlev,  &
+                      grid%tmn,grid%xland,grid%znt,grid%z0,grid%ust,grid%mol,grid%pblh,grid%tke_myj,     &
+                      grid%exch_h,grid%thc,grid%snowc,grid%mavail,grid%hfx,grid%qfx,grid%rainbl, &
+                      grid%tslb,grid%zs,grid%dzs,config_flags%num_soil_layers,grid%warm_rain,  &
+                      grid%adv_moist_cond,                         &
+                      grid%apr_gr,grid%apr_w,grid%apr_mc,grid%apr_st,grid%apr_as,      &
+                      grid%apr_capma,grid%apr_capme,grid%apr_capmi,          &
+                      grid%xice,grid%vegfra,grid%snow,grid%canwat,grid%smstav,         &
+                      grid%smstot, grid%sfcrunoff,grid%udrunoff,grid%grdflx,grid%acsnow,      &
+                      grid%acsnom,grid%ivgtyp,grid%isltyp, grid%sfcevp,grid%smois,     &
+                      grid%sh2o, grid%snowh, grid%smfr3d,                    &
+                      grid%DX,grid%DY,grid%f_ice_phy,grid%f_rain_phy,grid%f_rimef_phy, &
+                      grid%mp_restart_state,grid%tbpvs_state,grid%tbpvs0_state,&
+                      allowed_to_read, grid%moved, start_of_simulation,               &
+                      ids, ide, jds, jde, kds, kde,           &
+                      ims, ime, jms, jme, kms, kme,           &
+                      grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), kts, kte, &
+                      ozmixm,grid%pin,                             &     ! Optional
+                      grid%m_ps_1,grid%m_ps_2,grid%m_hybi,aerosolc_1,aerosolc_2,&  ! Optional
+                      grid%rundgdten,grid%rvndgdten,grid%rthndgdten,         &     ! Optional
+                      grid%rqvndgdten,grid%rmundgdten,                  &     ! Optional
+                      grid%FGDT,grid%stepfg,                        &     ! Optional
+                      grid%DZR, grid%DZB, grid%DZG,                          & !Optional urban
+                      grid%TR_URB2D,grid%TB_URB2D,grid%TG_URB2D,grid%TC_URB2D,    & !Optional urban
+                      grid%QC_URB2D, grid%XXXR_URB2D,grid%XXXB_URB2D,        & !Optional urban
+                      grid%XXXG_URB2D, grid%XXXC_URB2D,                 & !Optional urban
+                      grid%TRL_URB3D, grid%TBL_URB3D, grid%TGL_URB3D,        & !Optional urban
+                      grid%SH_URB2D, grid%LH_URB2D, grid%G_URB2D, grid%RN_URB2D,  & !Optional urban
+                      grid%TS_URB2D, grid%FRC_URB2D, grid%UTYPE_URB2D,      & !Optional urban
+                      itimestep=grid%itimestep, fdob=grid%fdob             &
+                      )
+
+   ENDDO
+
+
+ 
+   CALL wrf_debug ( 100 , 'module_start: start_domain_rk: After call to phy_init' )
+
+#ifdef MCELIO
+   LU_MASK = 0.
+   WHERE ( grid%lu_index .EQ. 16 ) LU_MASK = 1.
+#endif
+
+   END IF
+
+#if 0
+#include "CYCLE_TEST.inc"
+#endif
+
+!
+!
+
+ !  set physical boundary conditions for all initialized variables
+
+!-----------------------------------------------------------------------
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!  Note:  the size of this halo exchange reflects the 
+!         fact that we are carrying the uncoupled variables 
+!         as state variables in the mass coordinate model, as
+!         opposed to the coupled variables as in the height
+!         coordinate model.
+!
+!                           * * * * *
+!         *        * * *    * * * * *
+!       * + *      * + *    * * + * * 
+!         *        * * *    * * * * *
+!                           * * * * *
+!
+!j  grid%em_u_1                          x
+!j  grid%em_u_2                          x
+!j  grid%em_v_1                          x
+!j  grid%em_v_2                          x
+!j  grid%em_w_1                          x
+!j  grid%em_w_2                          x
+!j  grid%em_t_1                          x
+!j  grid%em_t_2                          x
+!j grid%em_ph_1                          x
+!j grid%em_ph_2                          x
+!
+!j  grid%em_t_init                       x
+!
+!j  grid%em_phb   x
+!j  grid%em_ph0   x
+!j  grid%em_php   x
+!j   grid%em_pb   x
+!j   grid%em_al   x
+!j  grid%em_alt   x
+!j  grid%em_alb   x
+!
+!  the following are 2D (xy) variables
+!
+!j grid%em_mu_1                          x
+!j grid%em_mu_2                          x
+!j grid%em_mub   x
+!j grid%em_mu0   x
+!j grid%ht    x
+!j grid%msft  x
+!j grid%msfu  x
+!j grid%msfv  x
+!j grid%sina  x
+!j grid%cosa  x
+!j grid%e     x
+!j grid%f     x
+!
+!  4D variables
+!
+! moist                        x
+!  chem                        x
+!scalar                        x
+
+!--------------------------------------------------------------
+
+#ifdef DM_PARALLEL
+#  include "HALO_EM_INIT_1.inc"
+#  include "HALO_EM_INIT_2.inc"
+#  include "HALO_EM_INIT_3.inc"
+#  include "HALO_EM_INIT_4.inc"
+#  include "HALO_EM_INIT_5.inc"
+#  include "PERIOD_BDY_EM_INIT.inc"
+#  include "PERIOD_BDY_EM_MOIST.inc"
+#  include "PERIOD_BDY_EM_CHEM.inc"
+#endif
+
+
+   CALL set_physical_bc3d( grid%em_u_1 , 'U' , config_flags ,                  &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_u_2 , 'U' , config_flags ,                  &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_v_1 , 'V' , config_flags ,                  &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_v_2 , 'V' , config_flags ,                  &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+! set kinematic condition for w 
+
+   CALL set_physical_bc2d( grid%ht , 'r' , config_flags ,                &
+                           ids , ide , jds , jde , &
+                           ims , ime , jms , jme , &
+                           its , ite , jts , jte , &
+                           its , ite , jts , jte   )
+
+   IF ( .not. config_flags%restart ) THEN 
+   CALL set_w_surface(  config_flags,                                      &
+                        grid%em_w_1, grid%ht, grid%em_u_1, grid%em_v_1, grid%cf1, &
+                        grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msft,        &
+                        ids, ide, jds, jde, kds, kde,                      &
+                        ips, ipe, jps, jpe, kps, kpe,                      &
+                        its, ite, jts, jte, kts, kte,                      &
+                        ims, ime, jms, jme, kms, kme                      )
+   CALL set_w_surface(  config_flags,                                      &
+                        grid%em_w_2, grid%ht, grid%em_u_2, grid%em_v_2, grid%cf1, &
+                        grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msft,        &
+                        ids, ide, jds, jde, kds, kde,                      &
+                        ips, ipe, jps, jpe, kps, kpe,                      &
+                        its, ite, jts, jte, kts, kte,                      &
+                        ims, ime, jms, jme, kms, kme                      )
+   END IF
+
+! finished setting kinematic condition for w at the surface
+
+   CALL set_physical_bc3d( grid%em_w_1 , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_w_2 , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_ph_1 , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_ph_2 , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_t_1 , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_t_2 , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc2d( grid%em_mu_1, 't' , config_flags ,   &
+                           ids , ide , jds , jde ,  &
+                           ims , ime , jms , jme ,  &
+                           its , ite , jts , jte ,  &
+                           its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%em_mu_2, 't' , config_flags ,   &
+                           ids , ide , jds , jde ,  &
+                           ims , ime , jms , jme ,  &
+                           its , ite , jts , jte ,  &
+                           its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%em_mub , 't' , config_flags ,   &
+                           ids , ide , jds , jde ,  &
+                           ims , ime , jms , jme ,  &
+                           its , ite , jts , jte ,  &
+                           its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%em_mu0 , 't' , config_flags ,   &
+                           ids , ide , jds , jde ,  &
+                           ims , ime , jms , jme ,  &
+                           its , ite , jts , jte ,  &
+                           its , ite , jts , jte   )
+
+
+   CALL set_physical_bc3d( grid%em_phb , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_ph0 , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_php , 'W' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   CALL set_physical_bc3d( grid%em_pb , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_al , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_alt , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d( grid%em_alb , 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+   CALL set_physical_bc3d(grid%em_t_init, 't' , config_flags ,                 &
+                         ids , ide , jds , jde , kds , kde ,        &
+                         ims , ime , jms , jme , kms , kme ,        &
+                         its , ite , jts , jte , kts , kte ,        &
+                         its , ite , jts , jte , kts , kte )
+
+   IF (num_moist > 0) THEN
+
+! use of (:,:,:,loop) not efficient on DEC, but (ims,kms,jms,loop) not portable to SGI/Cray
+
+      loop_3d_m   : DO loop = 1 , num_moist
+         CALL set_physical_bc3d( moist(:,:,:,loop) , 'r' , config_flags ,                 &
+                                 ids , ide , jds , jde , kds , kde ,        &
+                                 ims , ime , jms , jme , kms , kme ,        &
+                                 its , ite , jts , jte , kts , kte ,        &
+                                 its , ite , jts , jte , kts , kte )
+      END DO loop_3d_m
+
+   ENDIF
+
+!wig 17-Oct-2006, begin: I think the following should be here...
+   IF (num_scalar > 0) THEN
+
+! use of (:,:,:,loop) not efficient on DEC, but (ims,kms,jms,loop) not portable to SGI/Cray
+
+      loop_3d_s   : DO loop = 1 , num_scalar
+         CALL set_physical_bc3d( scalar(:,:,:,loop) , 'r' , config_flags ,                 &
+                                 ids , ide , jds , jde , kds , kde ,        &
+                                 ims , ime , jms , jme , kms , kme ,        &
+                                 its , ite , jts , jte , kts , kte ,        &
+                                 its , ite , jts , jte , kts , kte )
+      END DO loop_3d_s
+
+   ENDIF
+!wig end.
+
+
+#ifdef WRF_CHEM
+!
+!   we do this here, so we only have one chem_init routine for either core....
+!
+         do j=jts,min(jte,jde-1)
+            do i=its,min(ite,ide-1)
+               do k=kts,kte
+                 z_at_w(i,k,j)=(grid%em_ph_2(i,k,j)+grid%em_phb(i,k,j))/g
+               enddo
+               do k=kts,min(kte,kde-1)
+                 tempfac=(grid%em_t_1(i,k,j) + t0)*((grid%em_p(i,k,j) + grid%em_pb(i,k,j))/p1000mb)**rcp
+                 convfac(i,k,j) = (grid%em_p(i,k,j)+grid%em_pb(i,k,j))/rgasuniv/tempfac
+               enddo
+            enddo
+         enddo
+
+         CALL chem_init (grid%id,chem,grid%dt,grid%bioemdt,grid%photdt,     &
+                         grid%chemdt,                                       &
+                         grid%stepbioe,grid%stepphot,grid%stepchem,                        &
+                         z_at_w,g,grid%aerwrf,config_flags,                               &
+                         grid%em_alt,grid%em_t_1,grid%em_p,convfac,                              &
+                         grid%gd_cloud, grid%gd_cloud2,                                  &
+                         grid%gd_cloud_b, grid%gd_cloud2_b,                              &
+                         grid%tauaer1,grid%tauaer2,grid%tauaer3,grid%tauaer4,                   &
+                         grid%gaer1,grid%gaer2,grid%gaer3,grid%gaer4,                           &
+                         grid%waer1,grid%waer2,grid%waer3,grid%waer4,                           &
+                         grid%pm2_5_dry,grid%pm2_5_water,grid%pm2_5_dry_ec,                &
+                         grid%chem_in_opt,                                  &
+                         ids , ide , jds , jde , kds , kde ,                &
+                         ims , ime , jms , jme , kms , kme ,                &
+                         its , ite , jts , jte , kts , kte                  )
+
+!
+! calculate initial pm
+!
+!       print *,'calculating initial pm'
+        select case (config_flags%chem_opt)
+        case (RADM2SORG, RACMSORG)
+           call sum_pm_sorgam (                                             &
+                grid%em_alt, chem, grid%h2oaj, grid%h2oai,                                    &
+                grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                 &
+                ids,ide, jds,jde, kds,kde,                                  &
+                ims,ime, jms,jme, kms,kme,                                  &
+                its,ite, jts,jte, kts,kte                                   )
+
+        case (CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ)
+           call sum_pm_mosaic (                                             &
+                grid%em_alt, chem,                                                  &
+                grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                 &
+                ids,ide, jds,jde, kds,kde,                                  &
+                ims,ime, jms,jme, kms,kme,                                  &
+                its,ite, jts,jte, kts,kte                                   )
+
+        case default
+           do j=jts,min(jte,jde-1)
+              do k=kts,min(kte,kde-1)
+                 do i=its,min(ite,ide-1)
+                    grid%pm2_5_dry(i,k,j)    = 0.
+                    grid%pm2_5_water(i,k,j)  = 0.
+                    grid%pm2_5_dry_ec(i,k,j) = 0.
+                    grid%pm10(i,k,j)         = 0.
+                 enddo
+              enddo
+           enddo
+        end select
+#endif
+
+   IF (num_chem >= PARAM_FIRST_SCALAR ) THEN
+! use of (:,:,:,loop) not efficient on DEC, but (ims,kms,jms,loop) not portable to SGI/Cray
+
+      loop_3d_c   : DO loop = PARAM_FIRST_SCALAR , num_chem
+         CALL set_physical_bc3d( chem(:,:,:,loop) , 'r' , config_flags ,                 &
+                                 ids , ide , jds , jde , kds , kde ,        &
+                                 ims , ime , jms , jme , kms , kme ,        &
+                                 its , ite , jts , jte , kts , kte ,        &
+                                 its , ite , jts , jte , kts , kte )
+      END DO loop_3d_c
+
+   ENDIF
+
+   CALL set_physical_bc2d( grid%msft , 'r' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfu , 'x' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+   CALL set_physical_bc2d( grid%msfv , 'y' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+   CALL set_physical_bc2d( grid%sina , 'r' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+   CALL set_physical_bc2d( grid%cosa , 'r' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+   CALL set_physical_bc2d( grid%e , 'r' , config_flags ,                 &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+   CALL set_physical_bc2d( grid%f , 'r' , config_flags ,                 &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   ) 
+
+#ifndef WRF_CHEM
+      DEALLOCATE(CLDFRA_OLD)
+#endif
+#ifdef DM_PARALLEL
+#   include "HALO_EM_INIT_1.inc"
+#   include "HALO_EM_INIT_2.inc"
+#   include "HALO_EM_INIT_3.inc"
+#   include "HALO_EM_INIT_4.inc"
+#   include "HALO_EM_INIT_5.inc"
+#  include "PERIOD_BDY_EM_INIT.inc"
+#  include "PERIOD_BDY_EM_MOIST.inc"
+#  include "PERIOD_BDY_EM_CHEM.inc"
+#endif
+
+     CALL wrf_debug ( 100 , 'module_start: start_domain_rk: Returning' )
+
+     RETURN
+
+   END SUBROUTINE start_domain_em
+
diff --git a/wrfv2_fire/dyn_exp/Makefile b/wrfv2_fire/dyn_exp/Makefile
new file mode 100644
index 00000000..ede7060b
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/Makefile
@@ -0,0 +1,31 @@
+#
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+
+MODULES =                 		\
+        module_exp.o         		\
+	$(CASE_MODULE)
+
+# possible CASE_MODULE settings
+#	module_initialize_exp.o        
+
+OBJS    = 		          	\
+	solve_exp.o init_modules_exp.o
+
+LIBTARGET    =  dyn_exp
+TARGETDIR    =  ./
+$(LIBTARGET) :  $(MODULES) $(OBJS)
+		$(AR) ../main/libwrflib.a $(MODULES) $(OBJS)
+
+include ../configure.wrf
+
+clean:
+	@ echo 'use the clean script'
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+solve_exp.o:   module_exp.o
+
diff --git a/wrfv2_fire/dyn_exp/README b/wrfv2_fire/dyn_exp/README
new file mode 100644
index 00000000..c9e1045e
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/README
@@ -0,0 +1,123 @@
+1.  Created a new "core specific" directory
+
+mkdir dyn_exp
+
+2.  Create a test directory for experimental core
+
+mkdir test/exp_real
+
+3.  Edited top level Makefile to add targets for same
+
+3.a.  rules to build the framework and then the experimental core
+
+exp_wrf :
+        $(MAKE) MODULE_DIRS="$(SLT_MODULES)" ext
+        $(MAKE) MODULE_DIRS="$(SLT_MODULES)" toolsdir
+        $(MAKE) MODULE_DIRS="$(SLT_MODULES)" framework
+        $(MAKE) MODULE_DIRS="$(SLT_MODULES)" shared
+        $(MAKE) MODULE_DIRS="$(SLT_MODULES)" exp_core
+
+3.b.  sub-rule to build the expimental core
+
+exp_core :
+        @ echo '--------------------------------------'
+        ( cd dyn_exp ; $(MAKE) )
+
+3.c.  experimental core initialization
+
+exp_real : exp_wrf
+        @ echo '--------------------------------------'
+        ( cd main ; $(MAKE) MODULE_DIRS="$(EXP_MODULES)" SOLVER=exp IDEAL_CASE=exp exp_ideal )
+        ( cd test/exp ; /bin/rm -f ideal.exe ; ln -sf ../../main/ideal.exe . )
+        ( cd test/exp ; ln -sf ../../run/README.namelist . )
+
+
+3.d.   add macros to specify the modules for this core
+
+EXP_MODULE_DIR = -I../dyn_exp
+EXP_MODULES =  $(EXP_MODULE_DIR) $(INCLUDE_MODULES)
+
+
+
+4. Edit share/solve_interface.F to add call to experimental core
+
+   ELSE IF ( config_flags%dyn_opt == DYN_EXP  ) THEN
+
+     CALL solve_exp  ( grid ,            &
+!
+#include 
+!
+               )
+
+4a. share/start_domain.F
+
+5. Create dyn_exp/solve_exp.F
+
+It's all there and very short -- just a trivial relaxation; some of the
+stuff in there is just "magic," for right now.  Note that the code in
+here is the code to do one step. The time loop is part of the driver
+and can be found in frame/module_integrate.F, which call
+solve_interface, which calls this routine. Note, too, that solve_exp
+doesn't do any computation itself. It is mediation layer. It calls
+model layer subroutines (dyn_exp/module_exp.F) to do the actual computation
+in 'tile-callable' fashion.
+
+6. Create dyn_exp/module_exp.F
+
+This is the model layer code.  Note that boundary tests are always
+encoded explicitly as conditionals using the domain indices passed
+in through the arg list; never implicitly as part of the loop range.
+
+7. Edit the Registry file and create the state data assocaited with this
+solver.  Single entry:
+
+ state real x ikj dyn_exp 2 - ih "TOYVAR"
+
+This specfies a two timelevel variable 'x' that will be known at the
+mediation layer and below as x_1 and x_2 (since it is core associated it
+will be known as exp_x_1 and exp_x_2 in the driver layer; the name
+of the core is prepended to prevent colllisions with variables of the
+same name that are associated with other cores).  The 'ih' means it will
+participate in initial data and in history data. The veriable is known
+externally as TOYVAR, its data name and the name the variable will have
+in data sets.
+
+Note that since the variable is not listed as staggered in any dimension
+it's logical (domain) size is ids:ide-1, kds:kde-1, jds:jde-1. This
+is important in the the module_exp.F code that tests for northern
+and eastern boundaries, and in the init code in module_initialize_exp.F
+
+8. Edit the Registry file and create a halo-exchange for x_1.
+
+ halo     HALO_EXP_A    4:x_1
+
+Note that since halo operations are called from the mediation layer, it
+is not necessary to pre-pend the dyncore name to the variable name x_1
+when adding it to a comm operation like a halo exchange.
+
+9. Edit the Registry file to set up '4' as the value of the 
+namelist variable dyn_opt that means to select our exp dyncore.
+
+package   dyn_exp       dyn_opt==4                   -             -
+
+10. Create a dyn_exp/Makefile  (see that file)
+
+11. Create an file exp/init_modules.F (also includes a couple of stubs
+for other dyncores already in WRF; this is not the normal or correct
+way of doing that; but I'm hurrying...)
+
+12. Create a file exp/module_initialize_exp.F.  This is not part of the
+WRF model itself; rather it is a pre-processor that produces initial
+data for the WRF model.
+
+13. Edit frame/module_domain.F to add case for DYN_EXP to
+alloc_space_field.  (This is a bug;
+one should never have to edit the framework code; will fix this in
+coming versions).  Same goes for share/start_domain.F, although this
+is not a framework routine.
+
+14. clean commands
+
+15. namelist file
+     copy from another dir and change dyn_opt
+     boundary conditions
diff --git a/wrfv2_fire/dyn_exp/init_modules_exp.F b/wrfv2_fire/dyn_exp/init_modules_exp.F
new file mode 100644
index 00000000..60d418a7
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/init_modules_exp.F
@@ -0,0 +1,34 @@
+!WRF:MEDIATION_LAYER
+!
+SUBROUTINE init_modules_exp
+ USE module_configure
+ USE module_driver_constants
+ USE module_model_constants
+ USE module_domain
+ USE module_machine
+ USE module_nesting
+ USE module_sm
+ USE module_timing
+ USE module_tiles
+ USE module_io_wrf
+ USE module_io
+#ifdef DM_PARALLEL
+ USE module_dm
+#endif
+
+ CALL init_module_configure
+ CALL init_module_driver_constants
+ CALL init_module_model_constants
+ CALL init_module_domain
+! CALL init_module_start
+ CALL init_module_machine
+#ifdef DM_PARALLEL
+ CALL init_module_dm
+#endif
+ CALL init_module_nesting
+ CALL init_module_timing
+ CALL init_module_tiles
+ CALL init_module_io_wrf
+ CALL init_module_io
+END SUBROUTINE init_modules_exp
+
diff --git a/wrfv2_fire/dyn_exp/module_exp.F b/wrfv2_fire/dyn_exp/module_exp.F
new file mode 100644
index 00000000..7a9e760e
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/module_exp.F
@@ -0,0 +1,90 @@
+!WRF:MODEL_LAYER:DYNAMICS
+!
+
+MODULE module_exp
+
+   USE module_state_description
+
+CONTAINS
+
+!------------------------------------------------------------------------
+
+SUBROUTINE relax_1_into_2  ( x1, x2,                        &
+                           ids, ide, jds, jde, kds, kde,    &
+                           ims, ime, jms, jme, kms, kme,    &
+                           its, ite, jts, jte, kts, kte    )
+
+   IMPLICIT NONE
+
+
+   !  Input data.
+
+   INTEGER ,       INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
+                                    ims, ime, jms, jme, kms, kme, &
+                                    its, ite, jts, jte, kts, kte
+
+   REAL , DIMENSION(  ims:ime , kms:kme, jms:jme ) ,                      &
+                                               INTENT(IN   ) ::  x1
+
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme  ) ,                     &
+                                               INTENT(  OUT) ::  x2
+
+   integer :: k, i, j
+
+
+   DO j = jts, jte
+     IF ( j > jds .AND. j < jde-1 ) THEN    ! jde-1 because x is not staggered in Y
+       DO k = kts, kte
+         DO i = its, ite
+           IF ( i > ids .AND. i < ide-1 ) THEN    ! ide-1 because x is not staggered in X
+             x2(i,k,j) = 0.25*(x1(i+1,k,j)+x1(i-1,k,j)+x1(i,k,j+1)+x1(i,k,j-1))
+           ENDIF
+         ENDDO
+       ENDDO
+     ENDIF
+   ENDDO
+
+END SUBROUTINE relax_1_into_2
+
+!-------------------------------------------------------------------------------
+
+SUBROUTINE copy_2_into_1  ( x2, x1,                        &
+                           ids, ide, jds, jde, kds, kde,    &
+                           ims, ime, jms, jme, kms, kme,    &
+                           its, ite, jts, jte, kts, kte    )
+
+   IMPLICIT NONE
+
+
+   !  Input data.
+
+   INTEGER ,       INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
+                                    ims, ime, jms, jme, kms, kme, &
+                                    its, ite, jts, jte, kts, kte
+
+   REAL , DIMENSION(  ims:ime , kms:kme, jms:jme ) ,                      &
+                                               INTENT(IN   ) ::  x2
+
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme  ) ,                     &
+                                               INTENT(  OUT) ::  x1
+
+   integer :: k, i, j
+
+   DO j = jts, jte
+     IF ( j > jds .AND. j < jde-1 ) THEN
+       DO k = kts, kte
+         DO i = its, ite
+           IF ( i > ids .AND. i < ide-1 ) THEN
+             x1(i,k,j) = x2(i,k,j)
+           ENDIF
+         ENDDO
+       ENDDO
+     ENDIF
+   ENDDO
+
+END SUBROUTINE copy_2_into_1
+
+!-------------------------------------------------------------------------------
+
+END MODULE module_exp
+
diff --git a/wrfv2_fire/dyn_exp/module_initialize_exp.F b/wrfv2_fire/dyn_exp/module_initialize_exp.F
new file mode 100644
index 00000000..224b8476
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/module_initialize_exp.F
@@ -0,0 +1,163 @@
+!IDEAL:MODEL_LAYER:INITIALIZATION
+!
+
+!  This MODULE holds the routines which are used to perform various initializations
+!  for the individual domains.  
+
+!  This MODULE CONTAINS the following routines:
+
+!  initialize_field_test - 1. Set different fields to different constant
+!                             values.  This is only a test.  If the correct
+!                             domain is not found (based upon the "id")
+!                             then a fatal error is issued.               
+
+MODULE module_initialize
+
+   USE module_domain
+   USE module_state_description
+   USE module_model_constants
+   USE module_timing
+   USE module_configure
+
+
+CONTAINS
+
+   SUBROUTINE init_domain_exp ( grid &
+!
+# include 
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include 
+
+   TYPE (grid_config_rec_type)              :: config_flags
+
+   !  Local data
+   INTEGER                             ::                       &
+                                  ids, ide, jds, jde, kds, kde, &
+                                  ims, ime, jms, jme, kms, kme, &
+                                  its, ite, jts, jte, kts, kte, &
+                                  i, j, k
+
+#define COPY_IN
+#include 
+
+   SELECT CASE ( model_data_order )
+         CASE ( DATA_ORDER_ZXY )
+   kds = grid%sd31 ; kde = grid%ed31 ;
+   ids = grid%sd32 ; ide = grid%ed32 ;
+   jds = grid%sd33 ; jde = grid%ed33 ;
+
+   kms = grid%sm31 ; kme = grid%em31 ;
+   ims = grid%sm32 ; ime = grid%em32 ;
+   jms = grid%sm33 ; jme = grid%em33 ;
+
+   kts = grid%sp31 ; kte = grid%ep31 ;   ! note that tile is entire patch
+   its = grid%sp32 ; ite = grid%ep32 ;   ! note that tile is entire patch
+   jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
+         CASE ( DATA_ORDER_XYZ )
+   ids = grid%sd31 ; ide = grid%ed31 ;
+   jds = grid%sd32 ; jde = grid%ed32 ;
+   kds = grid%sd33 ; kde = grid%ed33 ;
+
+   ims = grid%sm31 ; ime = grid%em31 ;
+   jms = grid%sm32 ; jme = grid%em32 ;
+   kms = grid%sm33 ; kme = grid%em33 ;
+
+   its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
+   jts = grid%sp32 ; jte = grid%ep32 ;   ! note that tile is entire patch
+   kts = grid%sp33 ; kte = grid%ep33 ;   ! note that tile is entire patch
+         CASE ( DATA_ORDER_XZY )
+   ids = grid%sd31 ; ide = grid%ed31 ;
+   kds = grid%sd32 ; kde = grid%ed32 ;
+   jds = grid%sd33 ; jde = grid%ed33 ;
+
+   ims = grid%sm31 ; ime = grid%em31 ;
+   kms = grid%sm32 ; kme = grid%em32 ;
+   jms = grid%sm33 ; jme = grid%em33 ;
+
+   its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
+   kts = grid%sp32 ; kte = grid%ep32 ;   ! note that tile is entire patch
+   jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
+
+   END SELECT
+
+
+   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+! set the boundaries of the X array
+    DO j = jts, jte
+      DO k = kts, kte
+        DO i = its, ite
+          IF ( i == ids .OR. i == ide-1 .OR. j == jds .OR. j == jde-1 ) THEN
+            x_1(i,k,j) = 1.
+            x_2(i,k,j) = 1.
+          ELSE
+            x_1(i,k,j) = 0.
+            x_2(i,k,j) = 0.
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+
+#define COPY_OUT
+#include 
+
+   RETURN
+
+   END SUBROUTINE init_domain_exp
+   
+!-------------------------------------------------------------------
+! this is a wrapper for the solver-specific init_domain routines.
+! Also dereferences the grid variables and passes them down as arguments.
+! This is crucial, since the lower level routines may do message passing
+! and this will get fouled up on machines that insist on passing down
+! copies of assumed-shape arrays (by passing down as arguments, the 
+! data are treated as assumed-size -- ie. f77 -- arrays and the copying
+! business is avoided).  Fie on the F90 designers.  Fie and a pox.
+
+   SUBROUTINE init_domain ( grid )
+
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid 
+   !  Local data.
+   INTEGER                :: dyn_opt 
+   INTEGER :: idum1, idum2
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+#include "deref_kludge.h"
+
+   CALL nl_get_dyn_opt( 1, dyn_opt )
+   
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+   IF ( dyn_opt .eq. DYN_EXP  ) THEN
+     CALL init_domain_exp( grid &
+!
+#include 
+!
+                        )
+   ELSE
+     WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt
+     CALL wrf_error_fatal ( ' init_domain: unknown or unimplemented dyn_opt ' )
+   ENDIF
+
+   END SUBROUTINE init_domain
+
+   SUBROUTINE init_module_initialize
+   END SUBROUTINE init_module_initialize
+
+
+END MODULE module_initialize
diff --git a/wrfv2_fire/dyn_exp/solve_exp.F b/wrfv2_fire/dyn_exp/solve_exp.F
new file mode 100644
index 00000000..7e1625da
--- /dev/null
+++ b/wrfv2_fire/dyn_exp/solve_exp.F
@@ -0,0 +1,154 @@
+!WRF:MEDIATION_LAYER:SOLVER
+!
+
+SUBROUTINE solve_exp ( grid                &
+!
+#include "exp_dummy_args.inc"
+!
+                 )
+
+USE module_exp
+
+
+! Driver layer modules
+   USE module_domain
+   USE module_configure
+   USE module_driver_constants
+   USE module_machine
+   USE module_tiles
+   USE module_dm
+! Mediation layer modules
+! Registry generated module
+   USE module_state_description
+
+   IMPLICIT NONE
+
+   !  Subroutine interface block.
+
+   !  Input data.
+
+   TYPE(domain) , TARGET          :: grid
+
+   !  Definitions of dummy arguments to solve
+#include 
+
+   !  WRF state bcs
+   TYPE (grid_config_rec_type)              :: config_flags
+
+   ! WRF state data
+
+   ! Local data
+
+   INTEGER                         :: k_start , k_end
+   INTEGER                         :: ids , ide , jds , jde , kds , kde , &
+                                      ims , ime , jms , jme , kms , kme , &
+                                      ips , ipe , jps , jpe , kps , kpe
+   INTEGER                         :: ij , iteration
+   INTEGER                         :: im , num_3d_m , ic , num_3d_c
+   INTEGER                         :: loop
+   INTEGER                         :: ijds, ijde
+   INTEGER                         :: idum1, idum2
+
+! storage for tendencies and decoupled state (generated from Registry)
+#include 
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+#include "deref_kludge.h"
+
+#define COPY_IN
+#include 
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#      include 
+#endif
+
+   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+! this sets up the P_* indices into the moisture and chem arrays
+   CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+ 
+   !  De-reference dimension information stored in the grid data structure.
+
+!                    ikj model   kij model
+
+   ids             = grid%sd31 ! grid%sd32 
+   ide             = grid%ed31 ! grid%ed32 
+   jds             = grid%sd33 ! grid%sd33 
+   jde             = grid%ed33 ! grid%ed33 
+   kds             = grid%sd32 ! grid%sd31 
+   kde             = grid%ed32 ! grid%ed31
+
+   ims             = grid%sm31 ! grid%sm32
+   ime             = grid%em31 ! grid%em32 
+   jms             = grid%sm33 ! grid%sm33 
+   jme             = grid%em33 ! grid%em33 
+   kms             = grid%sm32 ! grid%sm31 
+   kme             = grid%em32 ! grid%em31
+
+   ips             = grid%sp31 ! grid%sp32
+   ipe             = grid%ep31 ! grid%ep32
+   jps             = grid%sp33 ! grid%sp33
+   jpe             = grid%ep33 ! grid%ep33
+   kps             = grid%sp32 ! grid%sp31
+   kpe             = grid%ep32 ! grid%ep31
+
+   k_start         = grid%sd32 ! grid%sd31
+   k_end           = grid%ed32 ! grid%ed31
+
+   ijds = min(ids, jds)
+   ijde = max(ide, jde)
+
+   !  Compute these starting and stopping locations for each tile and number of tiles.
+
+   CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe )
+
+! end of "magic"; start of experimental solver; just a goofy relaxation 
+
+! Halo exchange on x_1 for relaxation operator in model layer subroutine
+! relax_1_into_2
+
+#ifdef DM_PARALLEL
+# include "HALO_EXP_A.inc"
+#endif
+
+! Simple 4 pt average of x_1 into x_2
+
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij )
+     DO ij = 1 , grid%num_tiles
+        CALL wrf_debug ( 200 , ' call relax_1_into_2' )
+        CALL relax_1_into_2 ( x_1, x_2,                            &
+                              ids, ide, jds, jde, kds, kde,        &
+                              ims, ime, jms, jme, kms, kme,        &
+                              grid%i_start(ij), grid%i_end(ij),    &
+                              grid%j_start(ij), grid%j_end(ij),    &
+                              k_start, k_end                       )
+     END DO
+     !$OMP END PARALLEL DO
+
+! Update x_1 for next go 'round
+
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij )
+     DO ij = 1 , grid%num_tiles
+        CALL wrf_debug ( 200 , ' call copy_2_into_1' )
+        CALL copy_2_into_1  ( x_2, x_1,                            &
+                              ids, ide, jds, jde, kds, kde,        &
+                              ims, ime, jms, jme, kms, kme,        &
+                              grid%i_start(ij), grid%i_end(ij),    &
+                              grid%j_start(ij), grid%j_end(ij),    &
+                              k_start, k_end                       )
+     END DO
+     !$OMP END PARALLEL DO
+
+#define COPY_OUT
+#include 
+
+   RETURN
+
+END SUBROUTINE solve_exp
+
diff --git a/wrfv2_fire/dyn_nmm/BUCKETS.F b/wrfv2_fire/dyn_nmm/BUCKETS.F
new file mode 100644
index 00000000..2f4475ce
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/BUCKETS.F
@@ -0,0 +1,287 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: ACCUMULATION BUCKETS
+!
+!-----------------------------------------------------------------------
+      SUBROUTINE BUCKETS(NTSD,NPREC,NSRFC,NRDSW,NRDLW                   &
+     &                  ,RESTART,TSTART                                 &
+     &                  ,NCLOD,NHEAT,NPHS,TSPH                          &
+     &                  ,ACPREC,CUPREC,ACSNOW,ACSNOM,SSROFF,BGROFF      &
+     &                  ,SFCEVP,POTEVP,SFCSHX,SFCLHX,SUBSHX,SNOPCX      &
+     &                  ,SFCUVX,POTFLX                                  &
+     &                  ,ARDSW,ASWIN,ASWOUT,ASWTOA                      &
+     &                  ,ARDLW,ALWIN,ALWOUT,ALWTOA                      &
+     &                  ,ACFRST,NCFRST,ACFRCV,NCFRCV                    &
+     &                  ,AVCNVC,AVRAIN,TCUCN,TRAIN                      &
+     &                  ,ASRFC                                          &
+     &                  ,T,TLMAX,TLMIN                                  &
+     &                  ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    BUCKETS     EMPTY ACCUMULATION BUCKETS WHEN NEEDED
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 04-08-18
+!     
+! ABSTRACT:
+!     VARIOUS ACCUMULATING QUANTITIES NEED TO BE RESET TO ZERO AT
+!     SPECIFIED INTERVALS.
+!     
+! USAGE: CALL BUCKETS FROM SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!        NTSD - CURRENT TIMESTEP
+!       NPREC - NUMBER OF TIMESTEPS BETWEEN EMPTYING BUCKETS FOR PRECIP
+!       NHEAT - NUMBER OF TIMESTEPS BETWEEN EMPTYING BUCKETS FOR 
+!               LATENT HEATING
+!       NCNVC - NUMBER OF TIMESTEPS BETWEEN CALLS TO CONVECTION
+!       TSPH - NUMBER OF DYNAMICS TIMESTEPS PER HOUR
+!      ACPREC - ACCUMULATED TOTAL PRECIPITATION (M)
+!      CUPREC - ACCUMULATED CONVECTIVE PRECIPITATION (M)
+!      ACSNOW - ACCUMULATED SNOWFALL (M)
+!      ACSNOM - ACCUMULATED SNOWMELT (M)
+!      SSROFF - ACCUMULATED SURFACE RUNOFF
+!      BGROFF - ACCUMULATED BELOW GROUND RUNOFF
+!      SFCEVP - ACCUMULATED SURFACE EVAPORATION
+!      POTEVP - ACCUMULATED POTENTIAL EVAPORATION
+!           T - TEMPERATURE
+!       TLMAX - MAX TEMPERATURE EACH HOUR IN LOWEST LAYER
+!       TLMIN - MIN TEMPERATURE EACH HOUR IN LOWEST LAYER
+!  
+!   OUTPUT ARGUMENT LIST:  THE ACCUMULATED QUANTITIES
+!     
+!   OUTPUT FILES:  NONE
+!     
+!   SUBPROGRAMS CALLED:  NONE
+!  
+!   UNIQUE: NONE
+!  
+!   LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!*** ARGUMENTS
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: NCLOD,NHEAT,NPHS,NPREC,NRDLW,NRDSW          &
+                           ,NSRFC,NTSD                                  &
+                           ,IDS,IDE,JDS,JDE,KDS,KDE                     &
+                           ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE 
+!
+      REAL,INTENT(IN) :: TSPH,TSTART
+      REAL,INTENT(OUT) :: ARDLW,ARDSW,ASRFC,AVCNVC,AVRAIN
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: ACPREC,ACSNOM      &
+     &                                              ,ACSNOW,ALWIN       &
+     &                                              ,ACFRST,ACFRCV      &
+     &                                              ,ALWOUT,ALWTOA      &
+     &                                              ,ASWIN,ASWOUT       &
+     &                                              ,ASWTOA,BGROFF      &
+     &                                              ,CUPREC,POTEVP      &
+     &                                              ,POTFLX,SFCEVP      &
+     &                                              ,SFCLHX,SFCSHX      &
+     &                                              ,SFCUVX,SNOPCX      &
+     &                                              ,SSROFF,SUBSHX
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: NCFRST,NCFRCV
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: TLMAX,TLMIN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: T
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: TCUCN      &
+     &                                                      ,TRAIN
+!
+      LOGICAL,INTENT(IN) :: RESTART
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES 
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K,NTSD_BUCKET,NTSPH
+      LOGICAL  WRF_DM_ON_MONITOR
+      EXTERNAL WRF_DM_ON_MONITOR
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      NTSD_BUCKET=NTSD
+      IF(RESTART.AND.TSTART>0.)THEN
+        NTSD_BUCKET=NTSD-1
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  TOTAL AND CONVECTIVE PRECIPITATION ARRAYS.
+!***  TOTAL SNOW AND SNOW MELT ARRAYS.
+!***  STORM SURFACE AND BASE GROUND RUN OFF ARRAYS.
+!***  EVAPORATION ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NPREC)==0)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ACPREC(I,J)=0.
+          CUPREC(I,J)=0.
+          ACSNOW(I,J)=0.
+          ACSNOM(I,J)=0.
+          SSROFF(I,J)=0.
+          BGROFF(I,J)=0.
+          SFCEVP(I,J)=0.
+          POTEVP(I,J)=0.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT PRECIP/RUNOFF ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  SFC FLUX ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NSRFC)==0)THEN
+        ASRFC=0.
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          SFCSHX(I,J)=0.
+          SFCLHX(I,J)=0.
+          SUBSHX(I,J)=0.
+          SNOPCX(I,J)=0.
+          SFCUVX(I,J)=0.
+          POTFLX(I,J)=0.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT SFC EVAP/FLUX ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  SHORTWAVE FLUX ACCUMULATION ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NRDSW)==0)THEN
+        ARDSW=0.
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ASWIN(I,J) =0.
+          ASWOUT(I,J)=0.
+          ASWTOA(I,J)=0.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT ACCUMULATED SHORTWAVE FLUX ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  LONGWAVE FLUX ACCUMULATION ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NRDLW)==0)THEN
+        ARDLW=0.
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ALWIN(I,J) =0.
+          ALWOUT(I,J)=0.
+          ALWTOA(I,J)=0.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT ACCUMULATED LONGWAVE FLUX ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  TIME-AVERAGED CLOUD FRACTION ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NCLOD)==0)THEN
+!***
+  !--- Ferrier 11/2/05:  Right now no accumulator variable is used (e.g.,
+  !    "ACLOD"), but instead the 2D arrays NCFRST & NCFRCV are used.  These
+  !    can be removed later to streamline the code.
+!***
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ACFRCV(I,J)=0.
+          ACFRST(I,J)=0.
+          NCFRCV(I,J)=0
+          NCFRST(I,J)=0
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT ACCUMULATED CLOUD FRACTION ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  GRID-SCALE AND CONVECTIVE (LATENT) HEATING ARRAYS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NHEAT)==0)THEN
+        AVCNVC=0.
+        AVRAIN=0.
+!
+        DO J=JTS,JTE
+        DO K=KTS,KTE
+        DO I=ITS,ITE
+          TRAIN(I,K,J)=0.
+          TCUCN(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('ZEROED OUT ACCUMULATED LATENT HEATING ARRAYS')
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  MAX/MIN TEMPERATURES
+!-----------------------------------------------------------------------
+!
+      NTSPH=NINT(TSPH)
+      IF(MOD(NTSD_BUCKET,NTSPH)==0)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          TLMAX(I,J)=-999.
+          TLMIN(I,J)=999.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('RESET MAX/MIN TEMPERTURES')
+        ENDIF
+      ENDIF
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        TLMAX(I,J)=MAX(TLMAX(I,J),T(I,1,J))
+        TLMIN(I,J)=MIN(TLMIN(I,J),T(I,1,J))
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE BUCKETS
+!
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/CLTEND.F b/wrfv2_fire/dyn_nmm/CLTEND.F
new file mode 100644
index 00000000..b535fd0d
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/CLTEND.F
@@ -0,0 +1,95 @@
+!
+!NCEP_MESO:MODEL_LAYER: PHYSICS
+!
+!**********************************************************************
+      SUBROUTINE CLTEND (ICLTEND,NPHS,T,T_OLD,T_ADJ                    &
+                        ,IDS,IDE,JDS,JDE,KDS,KDE                       &
+                        ,IMS,IME,JMS,JME,KMS,KME                       &
+                        ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    CLTEND      TEMPERATURE CHANGE BY CLOUD PROCESSES
+!   PRGRMMR: FERRIER         ORG: W/NP22     DATE: 01-09-26
+!     
+! ABSTRACT:
+!     CLTEND GRADUALLY UPDATES TEMPERATURE TENDENCIES FROM CONVECTION 
+!     GRID-SCALE MICROPHYSICS, AND PRECIPITATION ASSIMILATION.
+!     
+! USAGE: CALL CLTEND FROM SOLVE_RUNSTEAM
+!   INPUT ARGUMENT LIST:
+!     ICLTEND - FLAG SET TO -1 PRIOR TO PHYSICS CALLS, 0 AFTER PHYSICS
+!               CALLS, AND 1 FOR UPDATING TEMPERATURES EVERY TIME STEP
+!  
+!   OUTPUT ARGUMENT LIST:  NONE
+!     
+!   OUTPUT FILES:  NONE
+!     
+!   SUBPROGRAMS CALLED:  NONE
+!  
+!   UNIQUE: NONE
+!  
+!   LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!----------------------------------------------------------------------
+      USE module_MPP
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: ICLTEND                                    &
+                           ,IDS,IDE,JDS,JDE,KDS,KDE                    &
+                           ,IMS,IME,JMS,JME,KMS,KME                    &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE                    &
+                           ,NPHS
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T     &
+                                                                ,T_ADJ &
+                                                                ,T_OLD
+!
+!***  LOCAL VARIABLES 
+!
+      INTEGER :: I,J,K
+!
+      REAL :: DELTPH
+!
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+      IF(ICLTEND.LT.0)THEN
+        DO J=JTS,JTE
+        DO K=KTS,KTE
+        DO I=ITS,ITE
+          T_OLD(I,K,J)=T(I,K,J)
+        ENDDO
+        ENDDO
+        ENDDO
+      ELSEIF(ICLTEND.EQ.0)THEN
+        DO J=JTS,JTE
+        DO K=KTS,KTE
+        DO I=ITS,ITE
+          T_ADJ(I,K,J)=T(I,K,J)-T_OLD(I,K,J)
+          T(I,K,J)=T_OLD(I,K,J)
+        ENDDO
+        ENDDO
+        ENDDO
+      ELSE
+        DELTPH=1./REAL(NPHS)
+        DO J=JTS,JTE
+        DO K=KTS,KTE
+        DO I=ITS,ITE
+          T(I,K,J)=T(I,K,J)+DELTPH*T_ADJ(I,K,J)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE CLTEND
+!
+!----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/DSTRB.F b/wrfv2_fire/dyn_nmm/DSTRB.F
new file mode 100644
index 00000000..a521c869
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/DSTRB.F
@@ -0,0 +1,167 @@
+!-----------------------------------------------------------------------
+      SUBROUTINE DSTRB(ARRAYG,ARRAYL,LGS,LGE,LLS,LLE,L1                 &
+     &,                IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &,                IMS,IME,JMS,JME,KMS,KME                          &
+     &,                ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!     DSTRB DISTRIBUTES THE ELEMENTS OF REAL GLOBAL ARRAY ARRG TO THE
+!     REAL LOCAL ARRAYS ARRL.  LG IS THE VERTICAL DIMENSION OF THE
+!     GLOBAL ARRAY.  LL IS THE VERTICAL DIMENSION OF THE LOCAL ARRAY.
+!     L1 IS THE SPECIFIC LEVEL OF ARRL THAT IS BEING FILLED DURING
+!     THIS CALL (PERTINENT WHEN LG=1 AND LL>1).
+!-----------------------------------------------------------------------
+      USE MODULE_EXT_INTERNAL
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INCLUDE "mpif.h"
+!-----------------------------------------------------------------------
+!***
+!***  ARGUMENT VARIABLES
+!***
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &,                     IMS,IME,JMS,JME,KMS,KME                     &
+     &,                     ITS,ITE,JTS,JTE,KTS,KTE
+      INTEGER,INTENT(IN) :: L1,LGE,LGS,LLE,LLS
+!
+      REAL,DIMENSION(IDS:IDE,LGS:LGE,JDS:JDE),INTENT(IN) :: ARRAYG
+      REAL,DIMENSION(IMS:IME,LLS:LLE,JMS:JME),INTENT(OUT) :: ARRAYL
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      REAL,ALLOCATABLE,DIMENSION(:) :: ARRAYX
+!
+      INTEGER :: I,IEND,IPE,IRECV,IRTN,ISEND,ISTART,J,JEND,JSTART,KNT   &
+     &,          L,MPI_COMM_COMP,NUMVALS,MYPE,NPES
+      INTEGER,DIMENSION(4) :: LIMITS
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: ISTAT
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!***  GET OUR TASK ID AND THE COMMUNICATOR
+!
+      CALL WRF_GET_MYPROC(MYPE)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL WRF_GET_NPROC(NPES)
+!
+!***  INITIALIZE THE OUTPUT ARRAY
+!
+      DO J=JMS,JME
+      DO L=LLS,LLE
+      DO I=IMS,IME
+        ARRAYL(I,L,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  TASK 0 FILLS ITS OWN LOCAL DOMAIN THEN PARCELS OUT ALL THE OTHER 
+!***  PIECES TO THE OTHER TASKS.
+!-----------------------------------------------------------------------
+!
+      tasks : IF(MYPE==0)THEN
+!
+        IF(LGE==LGS)THEN
+          DO J=JTS,JTE
+          DO I=ITS,ITE
+            ARRAYL(I,L1,J)=ARRAYG(I,LGS,J)
+          ENDDO
+          ENDDO
+!
+        ELSE
+!
+          DO J=JTS,JTE
+            DO L=LGS,LGE
+            DO I=ITS,ITE
+              ARRAYL(I,L,J)=ARRAYG(I,L,J)
+            ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+!
+!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
+!***  SENDS OUT THE APPROPRIATE PIECE OF THE GLOBAL ARRAY.
+!
+        DO IPE=1,NPES-1
+!
+          CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP      &
+     &,                 ISTAT,IRECV)
+          ISTART=LIMITS(1)
+          IEND=LIMITS(2)
+          JSTART=LIMITS(3)
+          JEND=LIMITS(4)
+!
+          NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1)*(LGE-LGS+1)
+          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+          
+          KNT=0
+!
+          DO J=JSTART,JEND
+            DO L=LGS,LGE
+            DO I=ISTART,IEND
+              KNT=KNT+1
+              ARRAYX(KNT)=ARRAYG(I,L,J)
+            ENDDO
+            ENDDO
+          ENDDO
+!
+          CALL MPI_SEND(ARRAYX,KNT,MPI_REAL,IPE,IPE,MPI_COMM_COMP,ISEND)
+!
+          DEALLOCATE(ARRAYX)
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
+!***  RECEIVE THEIR PIECE OF THE GLOBAL ARRAY FROM TASK 0.
+!-----------------------------------------------------------------------
+!
+      ELSE
+!
+        LIMITS(1)=ITS
+        LIMITS(2)=ITE
+        LIMITS(3)=JTS
+        LIMITS(4)=JTE
+!
+        CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND)
+!
+        NUMVALS=(ITE-ITS+1)*(JTE-JTS+1)*(LGE-LGS+1)
+        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!
+        CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
+     &,               ISTAT,IRECV)
+!
+        KNT=0
+        IF(LGE==LGS)THEN
+          DO J=JTS,JTE
+          DO I=ITS,ITE
+            KNT=KNT+1
+            ARRAYL(I,L1,J)=ARRAYX(KNT)
+          ENDDO
+          ENDDO
+        ELSE
+          DO J=JTS,JTE
+            DO L=LGS,LGE
+            DO I=ITS,ITE
+              KNT=KNT+1
+              ARRAYL(I,L,J)=ARRAYX(KNT)
+            ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+!
+        DEALLOCATE(ARRAYX)
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF tasks
+!
+!-----------------------------------------------------------------------
+      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE DSTRB
+!
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/Makefile b/wrfv2_fire/dyn_nmm/Makefile
new file mode 100644
index 00000000..d1d16355
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/Makefile
@@ -0,0 +1,91 @@
+#
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+
+MODULES =                 		\
+        module_ADVECTION.o         	\
+        module_BC_NMM.o         	\
+        module_BNDRY_COND.o         	\
+        module_NEST_UTIL.o              \
+        module_CTLBLK.o         	\
+        module_DIFFUSION_NMM.o         	\
+        module_IGWAVE_ADJUST.o         	\
+        module_NONHY_DYNAM.o         	\
+        module_PHYSICS_CALLS.o       	\
+        module_MPPINIT.o        	\
+        module_TIMERS.o                 \
+        module_ZEROX.o                  \
+        module_si_io_nmm.o              \
+        module_initialize_real.o        \
+        module_PRECIP_ADJUST.o          \
+	$(CASE_MODULE)
+
+# moved into share/Makefile
+#        module_MPP.o              	\
+
+#        module_INDX.o                   \
+
+# possible CASE_MODULE settings
+#	module_initialize_nmm.o        
+
+OBJS    = 		          	\
+	read_nmm.o			\
+	init_modules_nmm.o  		\
+	start_domain_nmm.o  		\
+	solve_nmm.o         		\
+	RDTEMP.o    			\
+	BUCKETS.o 			\
+        DSTRB.o                         \
+	CLTEND.o                        \
+        NMM_NEST_UTILS1.o
+
+
+LIBTARGET    =  dyn_nmm
+TARGETDIR    =  ./
+$(LIBTARGET) :  $(MODULES) $(OBJS)
+		$(AR) ../main/libwrflib.a $(MODULES) $(OBJS)
+
+include ../configure.wrf
+
+clean:
+	@ echo 'use the clean script'
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+solve_nmm.o:   module_BC_NMM.o \
+               module_IGWAVE_ADJUST.o module_ADVECTION.o  \
+               module_NONHY_DYNAM.o module_DIFFUSION_NMM.o    \
+               module_BNDRY_COND.o module_PHYSICS_CALLS.o \
+               module_CTLBLK.o
+
+module_ADVECTION.o: ../share/module_MPP.o module_INDX.o
+
+module_MPPINIT.o: ../share/module_MPP.o 
+
+module_DIFFUSION_NMM.o: ../share/module_MPP.o module_INDX.o
+
+module_IGWAVE_ADJUST.o: ../share/module_MPP.o module_INDX.o module_ZEROX.o module_TIMERS.o
+
+module_PHYSICS_CALLS.o: \
+		../frame/module_domain.o		\
+		../frame/module_dm.o		\
+		../frame/module_configure.o		\
+		../frame/module_tiles.o		\
+		../frame/module_state_description.o		\
+		../share/module_model_constants.o		\
+		../phys/module_ra_gfdleta.o  \
+		../phys/module_radiation_driver.o  \
+		../phys/module_sf_myjsfc.o  \
+		../phys/module_surface_driver.o  \
+		../phys/module_pbl_driver.o  \
+		../phys/module_cu_bmj.o  \
+		../phys/module_cumulus_driver.o  \
+		../phys/module_mp_etanew.o  \
+		../phys/module_microphysics_driver.o
+
+module_initialize_real.o: ../share/module_model_constants.o
+
+# DO NOT DELETE
diff --git a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F
new file mode 100644
index 00000000..514d8ab6
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F
@@ -0,0 +1,3164 @@
+#if (NMM_NEST == 1)
+!===========================================================================
+!
+! E-GRID NESTING UTILITIES: This is gopal's doing
+!
+!===========================================================================
+
+SUBROUTINE med_nest_egrid_configure ( parent , nest )
+ USE module_domain
+ USE module_configure
+ USE module_timing
+
+ IMPLICIT NONE
+ TYPE(domain) , POINTER             :: parent , nest
+ REAL, PARAMETER                    :: ERAD=6371200.
+ REAL, PARAMETER                    :: DTR=0.01745329
+ REAL, PARAMETER                    :: DTAD=1.0
+ REAL, PARAMETER                    :: CP=1004.6
+ INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE
+
+!----------------------------------------------------------------------------
+!  PURPOSE: 
+!         - Initialize nested domain configurations including setting up 
+!           wbd,sbd and some other variables and 1D arrays. 
+!         - Note that in order to obtain coincident grid points, which  
+!           is a basic requirement for RSL, WRF infrastructure, we use 
+!           western and southern boundaries of nested domain (nest%wbd0
+!           and nest%sbd0 derived from the parent domain. In this case
+!           the nested domain may be considered as a part of the parent 
+!           domain with a higher resolution (telescoping ?). 
+!         - Also note that in this case, the central lat/lons for nested 
+!           domain should coincide with the central lat/lons of the parent,
+!           although the nested domain NEED NOT be located at the center of
+!           the domain.
+!----------------------------------------------------------------------------
+!
+!   BASIC TEST FOR PARENT DOMAIN: CHECK IF JMAX IS ODD. SINCE JDE IN THE NAMELIST
+!   IS JMAX + 1, WE NEED TO CHECK IF JDE IS EVEN IN WRF CONTEXT
+
+    IF(MOD(parent%ed33,2) .NE. 0)THEN
+     CALL wrf_error_fatal("PARENT DOMAIN: JMAX IS EVEN, INCREASE e_sn IN THE namelist.input BY 1")
+    ENDIF
+
+!   BASIC TEST FOR NESTED DOMAIN: CHECK IF JMAX IS ODD. SINCE JDE IN THE NAMELIST
+!   IS JMAX + 1, WE NEED TO CHECK IF JDE IS EVEN IN WRF CONTEXT
+
+    IF(MOD(nest%ed33,2) .NE. 0)THEN
+     CALL wrf_error_fatal("NESTED DOMAIN: JMAX IS EVEN, INCREASE e_sn IN THE namelist.input BY 1")
+    ENDIF
+
+!   Parent grid configuration, including, western and southern boundary
+
+    IDS = parent%sd31
+    IDE = parent%ed31
+    KDS = parent%sd32
+    KDE = parent%ed32
+    JDS = parent%sd33
+    JDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    KMS = parent%sm32
+    KME = parent%em32
+    JMS = parent%sm33
+    JME = parent%em33
+
+    ITS = parent%sp31
+    ITE = parent%ep31
+    KTS = parent%sp32
+    KTE = parent%ep32
+    JTS = parent%sp33
+    JTE = parent%ep33
+
+!   grid configuration
+
+    ! calculate wbd0 and sbd0 only for MOAD i.e. grid with parent_id == 0
+    if (parent%parent_id == 0 ) then        ! Dusan's doing
+       parent%wbd0 = -(IDE-2)*parent%dx     ! WBD0: in degrees;factor 2 takes care of dummy last column
+       parent%sbd0 = -((JDE-1)/2)*parent%dy ! SBD0: in degrees; note that JDE-1 should be odd  
+    end if
+    nest%wbd0   = parent%wbd0 + (nest%i_parent_start-1)*2.*parent%dx + mod(nest%j_parent_start+1,2)*parent%dx
+    nest%sbd0   = parent%sbd0 + (nest%j_parent_start-1)*parent%dy
+    nest%dx     = parent%dx/nest%parent_grid_ratio
+    nest%dy     = parent%dy/nest%parent_grid_ratio
+
+    write(0,*)" - i_parent_start = ",nest%i_parent_start
+    write(0,*)" - j_parent_start = ",nest%j_parent_start
+    write(0,*)" - parent%wbd0    = ",parent%wbd0
+    write(0,*)" - parent%sbd0    = ",parent%sbd0
+    write(0,*)" - nest%wbd0      = ",nest%wbd0
+    write(0,*)" - nest%sbd0      = ",nest%sbd0
+    write(0,*)" - nest%dx        = ",nest%dx
+    write(0,*)" - nest%dy        = ",nest%dy
+!
+    CALL nl_set_dx (nest%id , nest%dx)   ! for output purpose
+    CALL nl_set_dy (nest%id , nest%dy)   ! for output purpose
+
+!   set lat-lons; parent set to nested domain
+
+    CALL nl_get_cen_lat (parent%id, parent%cen_lat) ! cen_lat of parent set to nested domain
+    CALL nl_get_cen_lon (parent%id, parent%cen_lon) ! cen_lon of parent set to nested domain
+
+    nest%cen_lat=parent%cen_lat
+    nest%cen_lon=parent%cen_lon
+!
+    CALL nl_set_cen_lat ( nest%id , nest%cen_lat)  ! for output purpose
+    CALL nl_set_cen_lon ( nest%id , nest%cen_lon)  ! for output purpose
+
+    write(0,*)" - nest%cen_lat   = ",nest%cen_lat
+    write(0,*)" - nest%cen_lon   = ",nest%cen_lon
+
+
+!   soil configuration
+
+    nest%nmm_sldpth  = parent%nmm_sldpth
+    nest%nmm_dzsoil  = parent%nmm_dzsoil
+    nest%nmm_rtdpth  = parent%nmm_rtdpth
+
+!   numerical set up
+
+    nest%nmm_deta        = parent%nmm_deta
+    nest%nmm_aeta        = parent%nmm_aeta
+    nest%nmm_etax        = parent%nmm_etax
+    nest%nmm_dfl         = parent%nmm_dfl
+    nest%nmm_deta1       = parent%nmm_deta1
+    nest%nmm_aeta1       = parent%nmm_aeta1
+    nest%nmm_eta1        = parent%nmm_eta1
+    nest%nmm_deta2       = parent%nmm_deta2
+    nest%nmm_aeta2       = parent%nmm_aeta2
+    nest%nmm_eta2        = parent%nmm_eta2
+    nest%nmm_pdtop       = parent%nmm_pdtop
+    nest%nmm_pt          = parent%nmm_pt
+    nest%nmm_dfrlg       = parent%nmm_dfrlg
+    nest%num_soil_layers = parent%num_soil_layers
+    nest%num_moves       = parent%num_moves
+
+! Unfortunately, some of the single value constants in used in module_initialize have 
+! to be defiend here instead of the usual spot in med_initialize_nest_nmm. There
+! appears to be a problem in Registry and related code in this area.
+!
+! state  logical upstrm   -      dyn_nmm     -      -      -
+
+
+    nest%nmm_dlmd   = nest%dx
+    nest%nmm_dphd   = nest%dy
+    nest%nmm_dy_nmm = erad*(nest%nmm_dphd*dtr)
+    nest%nmm_cpgfv  = -nest%dt/(48.*nest%nmm_dy_nmm)
+    nest%nmm_en     = nest%dt/( 4.*nest%nmm_dy_nmm)*dtad
+    nest%nmm_ent    = nest%dt/(16.*nest%nmm_dy_nmm)*dtad
+    nest%nmm_f4d    = -.5*nest%dt*dtad
+    nest%nmm_f4q    = -nest%dt*dtad
+    nest%nmm_ef4t   = .5*nest%dt/cp
+
+!  Other output configurations that will make grads happy 
+
+   CALL nl_get_truelat1 (parent%id, parent%truelat1 )
+   CALL nl_get_truelat2 (parent%id, parent%truelat2 )
+   CALL nl_get_map_proj (parent%id, parent%map_proj )
+   CALL nl_get_iswater (parent%id, parent%iswater )
+
+   nest%truelat1=parent%truelat1
+   nest%truelat2=parent%truelat2
+   nest%map_proj=parent%map_proj
+   nest%iswater=parent%iswater
+
+   CALL nl_set_truelat1(nest%id, nest%truelat1)
+   CALL nl_set_truelat2(nest%id, nest%truelat2)
+   CALL nl_set_map_proj(nest%id, nest%map_proj)
+   CALL nl_set_iswater(nest%id, nest%iswater)
+
+!   physics and other configurations
+!   CALL nl_get_iswater (parent%id, nest%iswater) ! iswater is just based on parents
+!   CALL nl_get_bl_surface_physics (nest%id,  nest%bl_surface_physics )
+!   CALL nl_get_num_soil_layers( parent%num_soil_layers )
+!   CALL nl_get_real_data_init_type (parent%real_data_init_type)
+
+END SUBROUTINE med_nest_egrid_configure
+
+SUBROUTINE med_construct_egrid_weights ( parent , nest )
+ USE module_domain
+ USE module_configure
+ USE module_timing
+
+ IMPLICIT NONE
+ TYPE(domain) , POINTER             :: parent , nest
+ LOGICAL, EXTERNAL                  :: wrf_dm_on_monitor
+ INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE
+ INTEGER                            :: I,J,II,JJ,NII,NJJ
+ REAL                               :: parent_CLAT,parent_CLON,parent_WBD,parent_SBD,parent_DLMD,parent_DPHD
+ REAL                               :: nest_WBD,nest_SBD,nest_DLMD,nest_DPHD
+ REAL                               :: SW_LATD,SW_LOND
+ REAL                               :: ADDSUM1,ADDSUM2
+ REAL                               :: xr,zr,xc
+!-----------------------------------------------------------------------------------------------------------
+!   PURPOSE: 
+!           - Initialize lat-lons and determine weights 
+!
+!----------------------------------------------------------------------------------------------------------
+
+!   First obtain central latitude and longitude for the parent domain
+
+    CALL nl_get_cen_lat (parent%ID, parent_CLAT)
+    CALL nl_get_cen_lon (parent%ID, parent_CLON)
+
+!   Parent grid configuration, including, western and southern boundary
+
+    IDS = parent%sd31
+    IDE = parent%ed31
+    KDS = parent%sd32
+    KDE = parent%ed32
+    JDS = parent%sd33
+    JDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    KMS = parent%sm32
+    KME = parent%em32
+    JMS = parent%sm33
+    JME = parent%em33
+
+    ITS  = parent%sp31
+    ITE  = parent%ep31
+    KTS  = parent%sp32
+    KTE  = parent%ep32
+    JTS  = parent%sp33
+    JTE  = parent%ep33
+!
+    parent_DLMD = parent%dx                ! DLMD: dlamda in degrees 
+    parent_DPHD = parent%dy                ! DPHD: dphi in degrees 
+    parent_WBD  = parent%wbd0
+    parent_SBD  = parent%sbd0
+
+!   Now compute Geodetic lat/lon (Positive East) of parent grid in degrees
+
+    CALL EARTH_LATLON ( parent%nmm_HLAT,parent%nmm_HLON,parent%nmm_VLAT,parent%nmm_VLON,  & !output
+                        parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,                    & !inputs 
+                        parent_CLAT,parent_CLON,                                          &
+                        IDS,IDE,JDS,JDE,KDS,KDE,                                          &
+                        IMS,IME,JMS,JME,KMS,KME,                                          &
+                        ITS,ITE,JTS,JTE,KTS,KTE                                           )
+
+!   Nested grid configuration, including, western and southern boundary
+
+    IDS = nest%sd31
+    IDE = nest%ed31
+    KDS = nest%sd32
+    KDE = nest%ed32
+    JDS = nest%sd33
+    JDE = nest%ed33
+
+    IMS = nest%sm31
+    IME = nest%em31
+    KMS = nest%sm32
+    KME = nest%em32
+    JMS = nest%sm33
+    JME = nest%em33
+
+    ITS  = nest%sp31
+    ITE  = nest%ep31
+    KTS  = nest%sp32
+    KTE  = nest%ep32
+    JTS  = nest%sp33
+    JTE  = nest%ep33
+!
+    nest_DLMD = nest%dx
+    nest_DPHD = nest%dy
+    nest_WBD  = nest%wbd0
+    nest_SBD  = nest%sbd0
+
+!
+!   Now compute Geodetic lat/lon (Positive East) of nest in degrees, with the same central lat-lon
+!   as the parent grid
+!
+
+    CALL EARTH_LATLON ( nest%nmm_HLAT,nest%nmm_HLON,nest%nmm_VLAT,nest%nmm_VLON, & ! output
+                        nest_DLMD,nest_DPHD,nest_WBD,nest_SBD,                   & ! nest inputs
+                        parent_CLAT,parent_CLON,                                 & ! parent central lat/lon
+                        IDS,IDE,JDS,JDE,KDS,KDE,                                 & ! nested domain dimension
+                        IMS,IME,JMS,JME,KMS,KME,                                 &
+                        ITS,ITE,JTS,JTE,KTS,KTE                                  )
+
+!   Determine the weights of nested grid h points nearest to H points of parent domain 
+
+    CALL G2T2H( nest%nmm_IIH,nest%nmm_JJH,                       & ! output grid index on nested grid
+                nest%nmm_HBWGT1,nest%nmm_HBWGT2,                 & ! output weights on the nested grid 
+                nest%nmm_HBWGT3,nest%nmm_HBWGT4,                 &
+                nest%nmm_HLAT,nest%nmm_HLON,                     & ! target (nest) input lat lon in degrees
+                parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,   & ! parent res, western and south boundaries
+                parent_CLAT,parent_CLON,                         & ! parent central lat,lon, all in degrees
+                parent%ed31,parent%ed33,                         & ! parent imax and jmax
+                IDS,IDE,JDS,JDE,KDS,KDE,                         & ! 
+                IMS,IME,JMS,JME,KMS,KME,                         & ! nested grid configuration
+                ITS,ITE,JTS,JTE,KTS,KTE                          ) !
+
+
+!   Determine the weights of nested grid v points nearest to V points of parent domain
+
+    CALL G2T2V( nest%nmm_IIV,nest%nmm_JJV,                       & ! output grid index on nested grid
+                nest%nmm_VBWGT1,nest%nmm_VBWGT2,                 & ! output weights on the nested grid
+                nest%nmm_VBWGT3,nest%nmm_VBWGT4,                 &
+                nest%nmm_VLAT,nest%nmm_VLON,                     & ! target (nest) input lat lon in degrees
+                parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,   & ! parent res, western and south boundaries
+                parent_CLAT,parent_CLON,                         & ! parent central lat,lon, all in degrees
+                parent%ed31,parent%ed33,                         & ! parent imax and jmax
+                IDS,IDE,JDS,JDE,KDS,KDE,                         & !
+                IMS,IME,JMS,JME,KMS,KME,                         & ! nested grid configuration
+                ITS,ITE,JTS,JTE,KTS,KTE                          ) !
+
+!*** CHECK WEIGHTS AT MASS AND VELOCITY POINTS
+
+     CALL WEIGTS_CHECK(nest%nmm_HBWGT1,nest%nmm_HBWGT2,          & ! output weights on the nested grid
+                       nest%nmm_HBWGT3,nest%nmm_HBWGT4,          &
+                       nest%nmm_VBWGT1,nest%nmm_VBWGT2,          & ! output weights on the nested grid
+                       nest%nmm_VBWGT3,nest%nmm_VBWGT4,          &
+                       IDS,IDE,JDS,JDE,KDS,KDE,                  & !
+                       IMS,IME,JMS,JME,KMS,KME,                  & ! nested grid configuration
+                       ITS,ITE,JTS,JTE,KTS,KTE                   )
+
+!*** CHECK DOMAIN BOUNDS BEFORE PROCEEDING TO INTERPOLATION
+!
+    CALL BOUNDS_CHECK( nest%nmm_IIH,nest%nmm_JJH,nest%nmm_IIV,nest%nmm_JJV,   &
+                       nest%i_parent_start,nest%j_parent_start,nest%shw,      &
+                       IDS,IDE,JDS,JDE,KDS,KDE,                               & !
+                       IMS,IME,JMS,JME,KMS,KME,                               & ! nested grid configuration
+                       ITS,ITE,JTS,JTE,KTS,KTE                                )
+
+!------------------------------------------------------------------------------------------
+
+END SUBROUTINE med_construct_egrid_weights 
+
+!======================================================================================
+!
+! compute earth lat-lons for parent and the nest before interpolations
+!------------------------------------------------------------------------------
+
+SUBROUTINE EARTH_LATLON ( HLAT,HLON,VLAT,VLON,     & !Earth lat,lon at H and V points
+                          DLMD1,DPHD1,WBD1,SBD1,   & !input res,west & south boundaries,
+                          CENTRAL_LAT,CENTRAL_LON, & ! central lat,lon, all in degrees   
+                          IDS,IDE,JDS,JDE,KDS,KDE, &  
+                          IMS,IME,JMS,JME,KMS,KME, &
+                          ITS,ITE,JTS,JTE,KTS,KTE  )
+!============================================================================
+!
+ IMPLICIT NONE
+ INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME 
+ INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE  
+ REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
+ REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
+ REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT)        :: HLAT,HLON,VLAT,VLON
+
+! local
+
+ INTEGER,PARAMETER                           :: KNUM=SELECTED_REAL_KIND(13) 
+ INTEGER                                     :: I,J
+ REAL(KIND=KNUM)                             :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0
+ REAL(KIND=KNUM)                             :: TDLM,TDPH,TLMH,TLMV,TLMH0,TLMV0,TPHH,TPHV,DTR
+ REAL(KIND=KNUM)                             :: STPH,CTPH,STPV,CTPV,PI_2
+ REAL(KIND=KNUM)                             :: SPHH,CLMH,FACTH,SPHV,CLMV,FACTV
+ REAL(KIND=KNUM), DIMENSION(IMS:IME,JMS:JME) :: GLATH,GLONH,GLATV,GLONV
+!-------------------------------------------------------------------------
+
+!
+      PI_2 = ACOS(0.)
+      DTR  = PI_2/90.
+      WB   = WBD1 * DTR                 ! WB:   western boundary in radians
+      SB   = SBD1 * DTR                 ! SB:   southern boundary in radians
+      DLM  = DLMD1 * DTR                ! DLM:  dlamda in radians 
+      DPH  = DPHD1 * DTR                ! DPH:  dphi   in radians
+      TDLM = DLM + DLM                  ! TDLM: 2.0*dlamda 
+      TDPH = DPH + DPH                  ! TDPH: 2.0*DPH 
+
+!     For earth lat lon only
+
+      TPH0  = CENTRAL_LAT*DTR                ! TPH0: central lat in radians 
+      STPH0 = SIN(TPH0)
+      CTPH0 = COS(TPH0)
+
+!      WRITE(0,*) 'WB,SB,DLM,DPH,DTR: ',WBD1,SBD1,DLM,DPH,DTR    
+!      WRITE(0,*) 'IMS,IME,JMS,JME,KMS,KME',IMS,IME,JMS,JME,KMS,KME 
+!      WRITE(0,*) 'IDS,IDE,JDS,JDE,KDS,KDE',IDS,IDE,JDS,JDE,KDS,KDE
+!      WRITE(0,*) 'ITS,ITE,JTS,JTE,KTS,KTE',ITS,ITE,JTS,JTE,KTS,KTE 
+
+                                                !    .H
+      DO J = JTS,MIN(JTE,JDE-1)                 ! H./    This loop takes care of zig-zag 
+!                                               !   \.H  starting points along j  
+         TLMH0 = WB - TDLM + MOD(J+1,2) * DLM   !  ./    TLMH (rotated lats at H points)
+         TLMV0 = WB - TDLM + MOD(J,2) * DLM     !  H     (//ly for V points) 
+         TPHH = SB + (J-1)*DPH                  !   TPHH (rotated lons at H points) are simple trans.
+         TPHV = TPHH                            !   TPHV (rotated lons at V points) are simple trans.
+         STPH = SIN(TPHH)
+         CTPH = COS(TPHH)
+         STPV = SIN(TPHV)
+         CTPV = COS(TPHV)
+
+                                                              !   .H
+         DO I = ITS,MIN(ITE,IDE-1)                            !  / 
+           TLMH = TLMH0 + I*TDLM                              !  \.H   .U   .H 
+!                                                             !H./ ----><----
+           SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH)     !     DLM + DLM
+           GLATH(I,J)=ASIN(SPHH)                              ! GLATH: Earth Lat in radians 
+           CLMH = CTPH*COS(TLMH)/(COS(GLATH(I,J))*CTPH0) &
+                - TAN(GLATH(I,J))*TAN(TPH0)
+           IF(CLMH .GT. 1.) CLMH = 1.0
+           IF(CLMH .LT. -1.) CLMH = -1.0
+           FACTH = 1.
+           IF(TLMH .GT. 0.) FACTH = -1.
+           GLONH(I,J) = -CENTRAL_LON*DTR + FACTH*ACOS(CLMH)
+
+         ENDDO                                    
+
+         DO I = ITS,MIN(ITE,IDE-1)
+           TLMV = TLMV0 + I*TDLM
+           SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV)
+           GLATV(I,J) = ASIN(SPHV)
+           CLMV = CTPV*COS(TLMV)/(COS(GLATV(I,J))*CTPH0) &
+                - TAN(GLATV(I,J))*TAN(TPH0)
+           IF(CLMV .GT. 1.) CLMV = 1.
+           IF(CLMV .LT. -1.) CLMV = -1.
+           FACTV = 1.
+           IF(TLMV .GT. 0.) FACTV = -1.
+           GLONV(I,J) = -CENTRAL_LON*DTR + FACTV*ACOS(CLMV)
+
+         ENDDO
+
+      ENDDO
+
+!     Conversion to degrees (may not be required, eventually)
+
+      DO J = JTS, MIN(JTE,JDE-1)
+       DO I = ITS, MIN(ITE,IDE-1)
+          HLAT(I,J) = GLATH(I,J) / DTR
+          HLON(I,J)= -GLONH(I,J)/DTR
+          IF(HLON(I,J) .GT. 180.) HLON(I,J) = HLON(I,J)  - 360.
+          IF(HLON(I,J) .LT. -180.) HLON(I,J) = HLON(I,J) + 360.
+!
+          VLAT(I,J) = GLATV(I,J) / DTR
+          VLON(I,J) = -GLONV(I,J) / DTR
+          IF(VLON(I,J) .GT. 180.) VLON(I,J) = VLON(I,J)  - 360.
+          IF(VLON(I,J) .LT. -180.) VLON(I,J) = VLON(I,J) + 360.
+
+       ENDDO
+      ENDDO
+
+END SUBROUTINE EARTH_LATLON
+
+!-----------------------------------------------------------------------------  
+
+  SUBROUTINE G2T2H( IIH,JJH,                     & ! output grid index and weights 
+                    HBWGT1,HBWGT2,               & ! output weights in terms of parent grid
+                    HBWGT3,HBWGT4,               & 
+                    HLAT,HLON,                   & ! target (nest) input lat lon in degrees
+                    DLMD1,DPHD1,WBD1,SBD1,       & ! parent res, west and south boundaries
+                    CENTRAL_LAT,CENTRAL_LON,     & ! parent central lat,lon, all in degrees
+                    P_IDE,P_JDE,                 & ! parent imax and jmax
+                    IDS,IDE,JDS,JDE,KDS,KDE,     & ! target (nest) dIMEnsions
+                    IMS,IME,JMS,JME,KMS,KME,     &
+                    ITS,ITE,JTS,JTE,KTS,KTE      )
+
+! 
+!***  Tom Black   - Initial Version
+!***  Gopal       - Revised Version for WRF (includes coincident grid points) 
+!*** 
+!***  GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY,
+!***  AND THE NESTED GRID LAT-LONS AT H POINTS, THIS ROUTINE FIRST LOCATES THE 
+!***  INDICES,IIH,JJH, OF THE PARENT DOMAIN'S H POINTS THAT LIES CLOSEST TO THE
+!***  h POINTS OF THE NESTED DOMAIN   
+!
+!============================================================================
+!
+ IMPLICIT NONE
+ INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
+ INTEGER,    INTENT(IN   )                            :: P_IDE,P_JDE
+ REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
+ REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(IN)   :: HLAT,HLON
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+
+! local
+
+ INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)
+ INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE
+ INTEGER           :: NROW,NCOL,KROWS
+ REAL(KIND=KNUM)   :: X,Y,Z,TLAT,TLON
+ REAL(KIND=KNUM)   :: PI_2,D2R,R2D,GLAT,GLON,DPH,DLM,TPH0,TLM0,WB,SB                
+ REAL(KIND=KNUM)   :: ROW,COL,SLP0,TLATHC,TLONHC,DENOM,SLOPE
+ REAL(KIND=KNUM)   :: TLAT1,TLAT2,TLON1,TLON2,DLM1,DLM2,DLM3,DLM4,D1,D2
+ REAL(KIND=KNUM)   :: DLA1,DLA2,DLA3,DLA4,S1,R1,DS1,AN1,AN2,AN3                    ! Q
+ REAL(KIND=KNUM)   :: DL1,DL2,DL3,DL4,DL1I,DL2I,DL3I,DL4I,SUMDL,TLONO,TLATO 
+ REAL(KIND=KNUM)   :: DTEMP
+ REAL   , DIMENSION(IMS:IME,JMS:JME)    :: TLATHX,TLONHX
+ INTEGER, DIMENSION(IMS:IME,JMS:JME)    :: KOUTB
+!------------------------------------------------------------------------------- 
+
+  IMT=2*P_IDE-2             ! parent i dIMEnsions 
+  JMT=P_JDE/2               ! parent j dIMEnsions 
+  PI_2=ACOS(0.)
+  D2R=PI_2/90.
+  R2D=1./D2R
+  DPH=DPHD1*D2R
+  DLM=DLMD1*D2R
+  TPH0= CENTRAL_LAT*D2R
+  TLM0=-CENTRAL_LON*D2R        ! NOTE THE MINUS HERE
+  WB=WBD1*D2R                   ! CONVERT NESTED GRID H POINTS FROM GEODETIC
+  SB=SBD1*D2R
+  SLP0=DPHD1/DLMD1
+  DSLP0=NINT(R2D*ATAN(SLP0))
+  DS1=SQRT(DPH*DPH+DLM*DLM)    ! Q
+  AN1=ASIN(DLM/DS1)
+  AN2=ASIN(DPH/DS1)
+
+  DO J =  JTS,MIN(JTE,JDE-1) 
+    DO I = ITS,MIN(ITE,IDE-1) 
+
+!***
+!***  LOCATE TARGET h POINTS (HLAT AND HLON) ON THE PARENT DOMAIN AND
+!***  DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST 
+!***  CONVERT NESTED GRID h POINTS FROM GEODETIC TO TRANSFORMED 
+!***  COORDINATE ON THE PARENT GRID
+!
+
+      GLAT=HLAT(I,J)*D2R
+      GLON= (360. - HLON(I,J))*D2R
+      X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT)
+      Y=-COS(GLAT)*SIN(GLON-TLM0)
+      Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0)
+      TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y))
+      TLON=R2D*ATAN(Y/X)
+
+!      ROW=TLAT/DPHD1+JMT         ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN
+!      COL=TLON/DLMD1+P_IDE-1     ! (P_IDE-1) IS THE CENTRAL COLUMN OF THE PARENT DOMAIN 
+
+      ROW=(TLAT-SBD1)/DPHD1+1     ! Dusan's doing
+      COL=(TLON-WBD1)/DLMD1+1     ! Dusan's doing
+
+      NROW=INT(ROW + 0.001)     ! ROUND-OFF IS AVOIDED WITHOUT USING NINT ON PURPOSE
+      NCOL=INT(COL + 0.001)     
+      TLAT=TLAT*D2R
+      TLON=TLON*D2R
+
+!***  
+!***
+!***  FIRST CONSIDER THE SITUATION WHERE THE POINT h IS AT
+!***
+!***              V      H
+!***
+!***
+!***                 h           
+!***              H      V
+!***
+!***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
+!***
+      IF(MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.1.OR.     &     
+         MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.0)THEN        
+           TLAT1=(NROW-JMT)*DPH                           
+           TLAT2=TLAT1+DPH                              
+           TLON1=(NCOL-(P_IDE-1))*DLM                                   
+           TLON2=TLON1+DLM                                 
+           DLM1=TLON-TLON1                                 
+           DLM2=TLON-TLON2
+!           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+!           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+           D1=ACOS(DTEMP)
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           D2=ACOS(DTEMP)
+            IF(D1.GT.D2)THEN
+             NROW=NROW+1                    ! FIND THE NEAREST H ROW
+             NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
+            ENDIF 
+!            WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
+      ELSE
+!***
+!***  NOW CONSIDER THE SITUATION WHERE THE POINT h IS AT
+!***
+!***              H      V
+!***
+!***
+!***                 h 
+!***              V      H
+!***
+!***  THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID
+!***
+!***
+           TLAT1=(NROW+1-JMT)*DPH
+           TLAT2=TLAT1-DPH
+           TLON1=(NCOL-(P_IDE-1))*DLM
+           TLON2=TLON1+DLM
+           DLM1=TLON-TLON1
+           DLM2=TLON-TLON2
+!           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+!           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+           D1=ACOS(DTEMP)
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           D2=ACOS(DTEMP)
+             IF(D1.LT.D2)THEN
+              NROW=NROW+1                    ! FIND THE NEAREST H ROW
+             ELSE
+              NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
+             ENDIF
+!             WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
+      ENDIF
+
+      KROWS=((NROW-1)/2)*IMT
+      IF(MOD(NROW,2).EQ.1)THEN
+        K=KROWS+(NCOL+1)/2
+      ELSE
+        K=KROWS+P_IDE-1+NCOL/2
+      ENDIF
+
+!***
+!***  WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS
+!***  NEAREST TO THE CENTER K AS SEEN BELOW.  WE MUST FIND
+!***  WHICH OF THE FOUR H-BOXES (OF WHICH THIS H POINT IS
+!***  A VERTEX) SURROUNDS THE INNER GRID h POINT IN QUESTION.
+!***
+!**
+!***                  H
+!***
+!***
+!***
+!***            H     V     H
+!***
+!***
+!***               h
+!***      H     V     H     V     H
+!***
+!***
+!***
+!***            H     V     H
+!***
+!***
+!***
+!***                  H
+!***
+!***
+!***  FIND THE SLOPE OF THE LINE CONNECTING h AND THE CENTER H.
+!***
+    N2R=K/IMT
+    MK=MOD(K,IMT)
+!
+    IF(MK.EQ.0)THEN
+      TLATHC=SB+(2*N2R-1)*DPH
+    ELSE
+      TLATHC=SB+(2*N2R+(MK-1)/(P_IDE-1))*DPH
+    ENDIF
+!
+    IF(MK.LE.(P_IDE-1))THEN
+      TLONHC=WB+2*(MK-1)*DLM
+    ELSE
+      TLONHC=WB+(2*(MK-(P_IDE-1))-1)*DLM
+    ENDIF
+  
+!
+!***  EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE
+!***  DEALING WITH SLOPES TO GENERATE DIAMOND SHAPE H BOXES, WE NEED TO BE
+!***  CAREFUL HERE      
+!
+
+    IF(ABS(TLON-TLONHC) .LE. 1.E-4)TLONHC=TLON
+    IF(ABS(TLAT-TLATHC) .LE. 1.E-4)TLATHC=TLAT
+    DENOM=(TLON-TLONHC)
+!
+!***
+!***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON
+!***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID.
+!***
+!*** COINCIDENT CONDITIONS
+
+    IF(DENOM.EQ.0.0)THEN
+
+      IF(TLATHC.EQ.TLAT)THEN
+        KOUTB(I,J)=K
+        IIH(I,J) = NCOL
+        JJH(I,J) = NROW
+        TLATHX(I,J)=TLATHC
+        TLONHX(I,J)=TLONHC
+        HBWGT1(I,J)=1.0
+        HBWGT2(I,J)=0.0
+        HBWGT3(I,J)=0.0
+        HBWGT4(I,J)=0.0
+!        WRITE(60,*)'TRIVIAL SOLUTION'
+      ELSE                                      ! SAME LONGITUDE BUT DIFFERENT LATS
+!
+         IF(TLATHC .GT. TLAT)THEN      ! NESTED POINT SOUTH OF PARENT
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW-1
+          TLATHX(I,J)=TLATHC-DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'VANISHING SLOPE, -ve: TLATHC-DPH, TLONHC-DLM'
+         ELSE                                   ! NESTED POINT NORTH OF PARENT
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW+1
+          TLATHX(I,J)=TLATHC+DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'VANISHING SLOPE, +ve: TLATHC+DPH, TLONHC-DLM' 
+         ENDIF
+!***
+!***
+!***                  4
+!***
+!***                  h
+!***             1         2
+!***
+!***                  3
+!***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
+
+       TLATO=TLATHX(I,J)
+       TLONO=TLONHX(I,J)
+       DLM1=TLON-TLONO
+       DLA1=TLAT-TLATO                                               ! Q
+!      DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q 
+!
+       TLATO=TLATHX(I,J)
+       TLONO=TLONHX(I,J)+2.*DLM
+       DLM2=TLON-TLONO
+       DLA2=TLAT-TLATO                                               ! Q
+!      DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
+! 
+       TLATO=TLATHX(I,J)-DPH
+       TLONO=TLONHX(I,J)+DLM
+       DLM3=TLON-TLONO
+       DLA3=TLAT-TLATO                                               ! Q
+!      DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
+ 
+       TLATO=TLATHX(I,J)+DPH
+       TLONO=TLONHX(I,J)+DLM
+       DLM4=TLON-TLONO
+       DLA4=TLAT-TLATO                                               ! Q
+!      DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
+
+
+!      THE BILINEAR WEIGHTS
+!***
+!***
+       AN3=ATAN2(DLA1,DLM1)                                          ! Q
+       R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
+       S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
+       R1=R1/DS1
+       S1=S1/DS1
+       DL1I=(1.-R1)*(1.-S1)
+       DL2I=R1*S1
+       DL3I=R1*(1.-S1)
+       DL4I=(1.-R1)*S1
+!
+       HBWGT1(I,J)=DL1I
+       HBWGT2(I,J)=DL2I
+       HBWGT3(I,J)=DL3I
+       HBWGT4(I,J)=DL4I
+! 
+      ENDIF
+
+    ELSE
+!
+!*** NON-COINCIDENT POINTS   
+!
+      SLOPE=(TLAT-TLATHC)/DENOM
+      DSLOPE=NINT(R2D*ATAN(SLOPE))
+
+      IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN
+        IF(TLON.GT.TLONHC)THEN
+          IF(TLONHC.GE.-WB-DLM)CALL wrf_error_fatal("1H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K
+          IIH(I,J) = NCOL
+          JJH(I,J) = NROW
+          TLATHX(I,J)=TLATHC
+          TLONHX(I,J)=TLONHC
+!          WRITE(60,*)'HERE WE GO1: TLATHC, TLONHC'
+        ELSE
+          IF(TLONHC.LE.WB+DLM)CALL wrf_error_fatal("2H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-1
+          IIH(I,J) = NCOL-2
+          JJH(I,J) = NROW
+          TLATHX(I,J)=TLATHC
+          TLONHX(I,J)=TLONHC -2.*DLM
+!          WRITE(60,*)'HERE WE GO2: TLATHC, TLONHC -2.*DLM'
+        ENDIF
+
+!
+      ELSEIF(DSLOPE.GT.DSLP0)THEN
+        IF(TLON.GT.TLONHC)THEN
+          IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("3H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW+1
+          TLATHX(I,J)=TLATHC+DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'HERE WE GO3:  TLATHC+DPH, TLONHC-DLM'
+        ELSE
+          IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("4H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW-1
+          TLATHX(I,J)=TLATHC-DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'HERE WE GO4:  TLATHC-DPH, TLONHC-DLM' 
+        ENDIF
+
+!
+      ELSEIF(DSLOPE.LT.-DSLP0)THEN
+        IF(TLON.GT.TLONHC)THEN
+          IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("5H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW-1
+          TLATHX(I,J)=TLATHC-DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'HERE WE GO5:  TLATHC-DPH, TLONHC-DLM'
+        ELSE
+          IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("6H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIH(I,J) = NCOL-1
+          JJH(I,J) = NROW+1
+          TLATHX(I,J)=TLATHC+DPH
+          TLONHX(I,J)=TLONHC-DLM
+!          WRITE(60,*)'HERE WE GO6: TLATHC+DPH,  TLONHC-DLM'
+        ENDIF
+      ENDIF
+
+!
+!***  NOW WE WILL MOVE AS FOLLOWS:
+!***
+!***
+!***                      4
+!***
+!***
+!***  
+!***                   h
+!***             1                 2
+!***
+!***
+!***
+!***
+!***                      3
+!***
+!***
+!***
+!***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
+      
+      TLATO=TLATHX(I,J)
+      TLONO=TLONHX(I,J)
+      DLM1=TLON-TLONO
+      DLA1=TLAT-TLATO                                               ! Q
+!     DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
+!
+      TLATO=TLATHX(I,J)                                             ! redundant computations
+      TLONO=TLONHX(I,J)+2.*DLM
+      DLM2=TLON-TLONO
+      DLA2=TLAT-TLATO                                               ! Q
+!     DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
+!
+      TLATO=TLATHX(I,J)-DPH
+      TLONO=TLONHX(I,J)+DLM
+      DLM3=TLON-TLONO
+      DLA3=TLAT-TLATO                                               ! Q
+!     DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
+!
+      TLATO=TLATHX(I,J)+DPH
+      TLONO=TLONHX(I,J)+DLM
+      DLM4=TLON-TLONO
+      DLA4=TLAT-TLATO                                               ! Q
+!     DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
+
+!     THE BILINEAR WEIGHTS
+!***
+      AN3=ATAN2(DLA1,DLM1)                                          ! Q
+      R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
+      S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
+      R1=R1/DS1
+      S1=S1/DS1
+      DL1I=(1.-R1)*(1.-S1)
+      DL2I=R1*S1
+      DL3I=R1*(1.-S1)
+      DL4I=(1.-R1)*S1
+!
+      HBWGT1(I,J)=DL1I
+      HBWGT2(I,J)=DL2I
+      HBWGT3(I,J)=DL3I
+      HBWGT4(I,J)=DL4I
+!
+    ENDIF 
+
+!
+!***  FINALLY STORE IIH IN TERMS OF E-GRID INDEX
+!
+      IIH(I,J)=NINT(0.5*IIH(I,J))
+
+      HBWGT1(I,J)=MAX(HBWGT1(I,J),0.0)   ! all weights must be GE zero (postive def)
+      HBWGT2(I,J)=MAX(HBWGT2(I,J),0.0)   ! all weights must be GE zero (postive def)
+      HBWGT3(I,J)=MAX(HBWGT3(I,J),0.0)   ! all weights must be GE zero (postive def)
+      HBWGT4(I,J)=MAX(HBWGT4(I,J),0.0)   ! all weights must be GE zero (postive def)
+
+!      write(0,105)"H WEIGHTS:",I,J,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J), &
+!                               HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J),IIH(i,j),JJH(i,j)
+! 105  format(a,2i4,5f7.3,2i4)
+
+   ENDDO
+  ENDDO
+
+
+  RETURN 
+  END SUBROUTINE G2T2H
+!========================================================================================
+
+
+  SUBROUTINE G2T2V( IIV,JJV,                     & ! output grid index and weights
+                    VBWGT1,VBWGT2,               & ! output weights in terms of parent grid
+                    VBWGT3,VBWGT4,               &
+                    VLAT,VLON,                   & ! target (nest) input lat lon in degrees
+                    DLMD1,DPHD1,WBD1,SBD1,       & ! parent res, west and south boundaries
+                    CENTRAL_LAT,CENTRAL_LON,     & ! parent central lat,lon, all in degrees
+                    P_IDE,P_JDE,                 & ! parent imax and jmax
+                    IDS,IDE,JDS,JDE,KDS,KDE,     & ! target (nest) dIMEnsions
+                    IMS,IME,JMS,JME,KMS,KME,     &
+                    ITS,ITE,JTS,JTE,KTS,KTE      )
+
+!
+!***  Tom Black   - Initial Version 
+!***  Gopal       - Revised Version for WRF (includes coincIDEnt grid points)
+!***
+!***  GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY,
+!***  AND THE NESTED GRID LAT-LONS AT v POINTS, THIS ROUTINE FIRST LOCATES THE
+!***  INDICES,IIV,JJV, OF THE PARENT DOMAIN'S v POINTS THAT LIES CLOSEST TO THE
+!***  v POINTS OF THE NESTED DOMAIN
+!
+!============================================================================
+
+ IMPLICIT NONE
+ INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
+ INTEGER,    INTENT(IN   )                            :: P_IDE,P_JDE
+ REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
+ REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
+ REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)    :: VLAT,VLON
+ REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(OUT)   :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),   INTENT(OUT)   :: IIV,JJV
+
+! local
+
+ INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)     ! (6) single precision
+ INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE
+ INTEGER           :: NROW,NCOL,KROWS
+ REAL(KIND=KNUM)   :: X,Y,Z,TLAT,TLON
+ REAL(KIND=KNUM)   :: PI_2,D2R,R2D,GLAT,GLON,DPH,DLM,TPH0,TLM0,WB,SB
+ REAL(KIND=KNUM)   :: ROW,COL,SLP0,TLATVC,TLONVC,DENOM,SLOPE
+ REAL(KIND=KNUM)   :: TLAT1,TLAT2,TLON1,TLON2,DLM1,DLM2,DLM3,DLM4,D1,D2
+ REAL(KIND=KNUM)   :: DLA1,DLA2,DLA3,DLA4,S1,R1,DS1,AN1,AN2,AN3                    ! Q
+ REAL(KIND=KNUM)   :: DL1,DL2,DL3,DL4,DL1I,DL2I,DL3I,DL4I,SUMDL,TLONO,TLATO
+ REAL(KIND=KNUM)   :: DTEMP
+ REAL  , DIMENSION(IMS:IME,JMS:JME)      :: TLATVX,TLONVX
+ INTEGER, DIMENSION(IMS:IME,JMS:JME)     :: KOUTB
+!-------------------------------------------------------------------------------------
+
+  IMT=2*P_IDE-2             ! parent i dIMEnsions
+  JMT=P_JDE/2               ! parent j dIMEnsions
+  PI_2=ACOS(0.)
+  D2R=PI_2/90.
+  R2D=1./D2R
+  DPH=DPHD1*D2R
+  DLM=DLMD1*D2R
+  TPH0= CENTRAL_LAT*D2R
+  TLM0=-CENTRAL_LON*D2R        ! NOTE THE MINUS HERE
+  WB=WBD1*D2R                   ! DEGREES TO RADIANS
+  SB=SBD1*D2R
+  SLP0=DPHD1/DLMD1
+  DSLP0=NINT(R2D*ATAN(SLP0))
+  DS1=SQRT(DPH*DPH+DLM*DLM)    ! Q
+  AN1=ASIN(DLM/DS1)
+  AN2=ASIN(DPH/DS1)
+
+  DO J =  JTS,MIN(JTE,JDE-1)
+    DO I = ITS,MIN(ITE,IDE-1)
+!***
+!***  LOCATE TARGET v POINTS (VLAT AND VLON) ON THE PARENT DOMAIN AND
+!***  DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST
+!***  CONVERT NESTED GRID v POINTS FROM GEODETIC TO TRANSFORMED
+!***  COORDINATE ON THE PARENT GRID
+!
+
+      GLAT=VLAT(I,J)*D2R
+      GLON=(360. - VLON(I,J))*D2R
+      X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT)
+      Y=-COS(GLAT)*SIN(GLON-TLM0)
+      Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0)
+      TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y))
+      TLON=R2D*ATAN(Y/X)
+
+!      ROW=TLAT/DPHD1+JMT         ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN
+!      COL=TLON/DLMD1+P_IDE-1     ! (P_IDE-1) IS THE CENTRAL COLUMN OF THE PARENT DOMAIN
+
+      ROW=(TLAT-SBD1)/DPHD1+1     ! Dusan's doing
+      COL=(TLON-WBD1)/DLMD1+1     ! Dusan's doing
+
+      NROW=INT(ROW + 0.001)     ! ROUND-OFF IS AVOIDED WITHOUT USING NINT ON PURPOSE
+      NCOL=INT(COL + 0.001)
+      TLAT=TLAT*D2R
+      TLON=TLON*D2R
+
+!***
+!***
+!***  FIRST CONSIDER THE SITUATION WHERE THE POINT v IS AT
+!***
+!***              H      V
+!***
+!***
+!***                 v
+!***              V      H
+!***
+!***  THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID
+!***
+
+      IF(MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.1.OR.     &
+         MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.0)THEN
+           TLAT1=(NROW-JMT)*DPH
+           TLAT2=TLAT1+DPH
+           TLON1=(NCOL-(P_IDE-1))*DLM
+           TLON2=TLON1+DLM
+           DLM1=TLON-TLON1
+           DLM2=TLON-TLON2
+!           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+!           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+           D1=ACOS(DTEMP)
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           D2=ACOS(DTEMP)
+            IF(D1.GT.D2)THEN
+             NROW=NROW+1                    ! FIND THE NEAREST V ROW
+             NCOL=NCOL+1                    ! FIND THE NEAREST V COLUMN
+            ENDIF
+!            WRITE(61,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
+      ELSE
+
+!***
+!***  NOW CONSIDER THE SITUATION WHERE THE POINT v IS AT
+!***
+!***              V      H
+!***
+!***
+!***                 v
+!***              H      V
+!***
+!*** THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID
+!***
+           TLAT1=(NROW+1-JMT)*DPH
+           TLAT2=TLAT1-DPH
+           TLON1=(NCOL-(P_IDE-1))*DLM
+           TLON2=TLON1+DLM
+           DLM1=TLON-TLON1
+           DLM2=TLON-TLON2
+!           D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+!           D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1))
+           D1=ACOS(DTEMP)
+           DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2))
+           D2=ACOS(DTEMP)
+             IF(D1.LT.D2)THEN
+              NROW=NROW+1                    ! FIND THE NEAREST H ROW
+             ELSE
+              NCOL=NCOL+1                    ! FIND THE NEAREST H COLUMN
+             ENDIF
+!             WRITE(61,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW
+
+      ENDIF
+
+      KROWS=((NROW-1)/2)*IMT
+      IF(MOD(NROW,2).EQ.1)THEN
+        K=KROWS+NCOL/2
+      ELSE
+        K=KROWS+P_IDE-2+(NCOL+1)/2     ! check this one should this not be P_IDE-2 ????
+      ENDIF
+
+!***
+!***  WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS
+!***  NEAREST TO THE CENTER K AS SEEN BELOW.  WE MUST FIND
+!***  WHICH OF THE FOUR V-BOXES (OF WHICH THIS V POINT IS
+!***  A VERTEX) SURROUNDS THE INNER GRID v POINT IN QUESTION.
+!***
+!***
+!***                  V
+!***
+!***
+!***
+!***            V     H     V
+!***
+!***
+!***               v
+!***      V     H     V     H     V
+!***
+!***
+!***
+!***            V     H     V
+!***
+!***
+!***
+!***                  V
+!***
+!***
+!***  FIND THE SLOPE OF THE LINE CONNECTING v AND THE CENTER V.
+!***
+      N2R=K/IMT
+      MK=MOD(K,IMT)
+!
+      IF(MK.EQ.0)THEN
+        TLATVC=SB+(2*N2R-1)*DPH
+      ELSE
+        TLATVC=SB+(2*N2R+MK/(P_IDE-1))*DPH
+      ENDIF
+!
+      IF(MK.LE.(P_IDE-1)-1)THEN
+        TLONVC=WB+(2*MK-1)*DLM
+      ELSE
+        TLONVC=WB+2*(MK-(P_IDE-1))*DLM
+      ENDIF
+
+!
+!***  EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE
+!***  DEALING WITH SLOPES TO GENERATE DIAMOND SHAPE V BOXES, WE NEED TO BE
+!***  CAREFUL HERE
+!
+       IF(ABS(TLON-TLONVC) .LE. 1.E-4)TLONVC=TLON
+       IF(ABS(TLAT-TLATVC) .LE. 1.E-4)TLATVC=TLAT
+       DENOM=(TLON-TLONVC)
+!
+!***
+!***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON
+!***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID.
+!***
+!*** COINCIDENT CONDITIONS
+
+     IF(DENOM.EQ.0.0)THEN
+
+       IF(TLATVC.EQ.TLAT)THEN
+         KOUTB(I,J)=K
+         IIV(I,J) = NCOL
+         JJV(I,J) = NROW
+         TLATVX(I,J)=TLATVC
+         TLONVX(I,J)=TLONVC
+         VBWGT1(I,J)=1.0
+         VBWGT2(I,J)=0.0
+         VBWGT3(I,J)=0.0
+         VBWGT4(I,J)=0.0
+!         WRITE(61,*)'TRIVIAL SOLUTION'
+       ELSE                              ! SAME LONGITUDE BUT DIFFERENT LATS 
+          
+         IF(TLATVC .GT. TLAT)THEN      ! NESTED POINT SOUTH OF PARENT
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW-1
+          TLATVX(I,J)=TLATVC-DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'VANISHING SLOPE, -ve: TLATVC-DPH, TLONVC-DLM'
+         ELSE                                   ! NESTED POINT NORTH OF PARENT
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW+1
+          TLATVX(I,J)=TLATVC+DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'VANISHING SLOPE, +ve: TLATVC+DPH, TLONVC-DLM'
+         ENDIF
+
+!***
+!***
+!***                  4
+!***
+!***                  v 
+!***             1         2
+!***
+!***                  3
+!***  DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX
+
+       TLATO=TLATVX(I,J)
+       TLONO=TLONVX(I,J)
+       DLM1=TLON-TLONO
+       DLA1=TLAT-TLATO                                               ! Q
+!      DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
+!
+       TLATO=TLATVX(I,J)
+       TLONO=TLONVX(I,J)+2.*DLM
+       DLM2=TLON-TLONO
+       DLA2=TLAT-TLATO                                               ! Q
+!      DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
+
+       TLATO=TLATVX(I,J)-DPH
+       TLONO=TLONVX(I,J)+DLM
+       DLM3=TLON-TLONO
+       DLA3=TLAT-TLATO                                               ! Q
+!      DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
+
+       TLATO=TLATVX(I,J)+DPH
+       TLONO=TLONVX(I,J)+DLM
+       DLM4=TLON-TLONO
+       DLA4=TLAT-TLATO                                               ! Q
+!      DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
+       DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
+                 
+!      THE BILINEAR WEIGHTS
+!***
+       AN3=ATAN2(DLA1,DLM1)                                          ! Q
+       R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
+       S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
+       R1=R1/DS1
+       S1=S1/DS1
+       DL1I=(1.-R1)*(1.-S1)
+       DL2I=R1*S1
+       DL3I=R1*(1.-S1)
+       DL4I=(1.-R1)*S1
+!
+       VBWGT1(I,J)=DL1I
+       VBWGT2(I,J)=DL2I
+       VBWGT3(I,J)=DL3I
+       VBWGT4(I,J)=DL4I      
+
+      ENDIF
+
+    ELSE
+
+!
+!*** NON-COINCIDENT POINTS
+!
+      SLOPE=(TLAT-TLATVC)/DENOM
+      DSLOPE=NINT(R2D*ATAN(SLOPE))
+
+      IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN
+        IF(TLON.GT.TLONVC)THEN
+          IF(TLONVC.GE.-WB-DLM)CALL wrf_error_fatal("1V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K
+          IIV(I,J)=NCOL
+          JJV(I,J)=NROW
+          TLATVX(I,J)=TLATVC
+          TLONVX(I,J)=TLONVC
+!          WRITE(61,*)'HERE WE GO1: TLATHC, TLONHC'
+        ELSE
+          IF(TLONVC.LE.WB+DLM)CALL wrf_error_fatal("2V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-1
+          IIV(I,J) = NCOL-2
+          JJV(I,J) = NROW
+          TLATVX(I,J)=TLATVC
+          TLONVX(I,J)=TLONVC-2.*DLM
+!          WRITE(61,*)'HERE WE GO2: TLATHC, TLONHC -2.*DLM'
+        ENDIF
+ 
+      ELSEIF(DSLOPE.GT.DSLP0)THEN
+        IF(TLON.GT.TLONVC)THEN
+          IF(TLATVC.GE.-SB-DPH)CALL wrf_error_fatal("3V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW+1
+          TLATVX(I,J)=TLATVC+DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'HERE WE GO3:  TLATHC+DPH, TLONHC-DLM'
+        ELSE
+          IF(TLATVC.LE.SB+DPH)CALL wrf_error_fatal("4V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW-1
+          TLATVX(I,J)=TLATVC-DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'HERE WE GO4:  TLATHC-DPH, TLONHC-DLM'
+        ENDIF
+ 
+      ELSEIF(DSLOPE.LT.-DSLP0)THEN
+        IF(TLON.GT.TLONVC)THEN
+          IF(TLATVC.LE.SB+DPH)CALL wrf_error_fatal("5V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K-(P_IDE-1)
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW-1
+          TLATVX(I,J)=TLATVC-DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'HERE WE GO5:  TLATHC-DPH, TLONHC-DLM'
+        ELSE
+          IF(TLATVC.GE.-SB-DPH)CALL wrf_error_fatal("6V:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT")
+          KOUTB(I,J)=K+(P_IDE-1)-1
+          IIV(I,J) = NCOL-1
+          JJV(I,J) = NROW+1
+          TLATVX(I,J)=TLATVC+DPH
+          TLONVX(I,J)=TLONVC-DLM
+!          WRITE(61,*)'HERE WE GO6: TLATHC+DPH,  TLONHC-DLM'
+        ENDIF
+      ENDIF
+!
+!***  NOW WE WILL MOVE AS FOLLOWS:
+!***
+!***
+!***                      4
+!***
+!***
+!*** 
+!***                   v 
+!***             1                 2
+!***
+!***
+!***
+!***
+!***                      3
+!***
+!***
+!***
+!***  DL 1-4 ARE THE ANGULAR DISTANCES FROM v TO EACH VERTEX
+
+      TLATO=TLATVX(I,J)
+      TLONO=TLONVX(I,J)
+      DLM1=TLON-TLONO
+      DLA1=TLAT-TLATO                                               ! Q
+!     DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL1=SQRT(DLM1*DLM1+DLA1*DLA1)                                 ! Q
+!
+      TLATO=TLATVX(I,J)
+      TLONO=TLONVX(I,J)+2.*DLM
+      DLM2=TLON-TLONO
+      DLA2=TLAT-TLATO                                               ! Q
+!     DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL2=SQRT(DLM2*DLM2+DLA2*DLA2)                                 ! Q
+!
+      TLATO=TLATVX(I,J)-DPH
+      TLONO=TLONVX(I,J)+DLM
+      DLM3=TLON-TLONO
+      DLA3=TLAT-TLATO                                               ! Q
+!     DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL3=SQRT(DLM3*DLM3+DLA3*DLA3)                                 ! Q
+!
+      TLATO=TLATVX(I,J)+DPH
+      TLONO=TLONVX(I,J)+DLM
+      DLM4=TLON-TLONO
+      DLA4=TLAT-TLATO                                               ! Q
+!     DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q
+      DL4=SQRT(DLM4*DLM4+DLA4*DLA4)                                 ! Q
+ 
+!     THE BILINEAR WEIGHTS
+!***
+      AN3=ATAN2(DLA1,DLM1)                                          ! Q
+      R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1)
+      S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1)
+      R1=R1/DS1
+      S1=S1/DS1
+      DL1I=(1.-R1)*(1.-S1)
+      DL2I=R1*S1
+      DL3I=R1*(1.-S1)
+      DL4I=(1.-R1)*S1
+!
+      VBWGT1(I,J)=DL1I
+      VBWGT2(I,J)=DL2I
+      VBWGT3(I,J)=DL3I
+      VBWGT4(I,J)=DL4I
+
+     ENDIF
+
+!
+!***  FINALLY STORE IIH IN TERMS OF E-GRID INDEX
+!
+      IIV(I,J)=NINT(0.5*IIV(I,J))
+
+      VBWGT1(I,J)=MAX(VBWGT1(I,J),0.0)   ! all weights must be GE zero (postive def)
+      VBWGT2(I,J)=MAX(VBWGT2(I,J),0.0)   ! all weights must be GE zero (postive def)
+      VBWGT3(I,J)=MAX(VBWGT3(I,J),0.0)   ! all weights must be GE zero (postive def)
+      VBWGT4(I,J)=MAX(VBWGT4(I,J),0.0)   ! all weights must be GE zero (postive def)
+
+!      WRITE(61,*)I,J,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J), &
+!                    VBWGT1(I,J)+VBWGT2(I,J)+VBWGT3(I,J)+VBWGT4(I,J),IIV(i,j),JJV(i,j)
+
+    ENDDO
+  ENDDO
+
+ RETURN
+ END SUBROUTINE G2T2V
+
+!------------------------------------------------------------------------------
+!
+SUBROUTINE WEIGTS_CHECK(HBWGT1,HBWGT2,HBWGT3,HBWGT4,       & 
+                        VBWGT1,VBWGT2,VBWGT3,VBWGT4,       &
+                        IDS,IDE,JDS,JDE,KDS,KDE,           &
+                        IMS,IME,JMS,JME,KMS,KME,           & 
+                        ITS,ITE,JTS,JTE,KTS,KTE            )
+
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)                                 :: IDS,IDE,JDS,JDE,KDS,KDE,  &
+                                                         IMS,IME,JMS,JME,KMS,KME,  &
+                                                         ITS,ITE,JTS,JTE,KTS,KTE
+  REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)   :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+  REAL,    DIMENSION(IMS:IME,JMS:JME),   INTENT(IN)   :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+
+! local 
+
+  REAL , PARAMETER :: EPSI=1.0E-3
+  INTEGER          :: I,J
+  REAL             :: ADDSUM
+
+!-------------------------------------------------------------------------------------
+
+! DUE TO THE NEED FOR HALO EXCHANGES IN PARALLEL RUNS ONE HAS TO ENSURE CONSISTENT 
+! USAGE OF NUMBER OF PROCESSORS BEFORE ANY FURTHER COMPUTATIONS. WE INTRODUCE THIS
+! CHECK FIRST
+
+  IF((ITE-ITS) .LE. 5 .OR. (JTE-JTS) .LE. 5)THEN
+   WRITE(0,*)'ITE-ITS=',ITE-ITS,'JTE-JTS=',JTE-JTS
+   CALL wrf_error_fatal ('NESTED DOMAIN:PLEASE OPTIMIZE THE NUMBER OF PROCESSES; TRY SQUARES OF NUMBERS') 
+  ENDIF
+
+!  
+! NOW CHECK WEIGHTS
+!
+
+  ADDSUM=0.
+  DO J = JTS, MIN(JTE,JDE-1)
+   DO I = ITS, MIN(ITE,IDE-1)
+      ADDSUM=HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J)
+      IF(ABS(1.0-ADDSUM) .GE. EPSI)THEN
+       WRITE(0,*)'I=',I,'J=',J,'WEIGHTS=',HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J),1-ADDSUM
+       CALL wrf_error_fatal ('NESTED DOMAIN:SOMETHING IS WRONG WITH WEIGHTS COMPUTATION AT MASS POINTS') 
+      ENDIF
+   ENDDO
+  ENDDO
+
+  ADDSUM=0.
+  DO J = JTS, MIN(JTE,JDE-1)
+   DO I = ITS, MIN(ITE,IDE-1)
+      ADDSUM=VBWGT1(I,J)+VBWGT2(I,J)+VBWGT3(I,J)+VBWGT4(I,J)
+      IF(ABS(1.0-ADDSUM) .GE. EPSI)THEN 
+       WRITE(0,*)'I=',I,'J=',J,'WEIGHTS=',VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J),1-ADDSUM
+       CALL wrf_error_fatal ('NESTED DOMAIN:SOMETHING IS WRONG WITH WEIGHTS COMPUTATION AT VELOCITY POINTS')
+      ENDIF
+   ENDDO
+  ENDDO
+
+END SUBROUTINE WEIGTS_CHECK
+
+!-----------------------------------------------------------------------------------
+
+SUBROUTINE BOUNDS_CHECK( IIH,JJH,IIV,JJV,          &
+                         IPOS,JPOS,SHW,            &
+                         IDS,IDE,JDS,JDE,KDS,KDE,  & !
+                         IMS,IME,JMS,JME,KMS,KME,  & ! nested grid configuration
+                         ITS,ITE,JTS,JTE,KTS,KTE   )
+
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: IPOS,JPOS,SHW,            &
+                        IDS,IDE,JDS,JDE,KDS,KDE,  & 
+                        IMS,IME,JMS,JME,KMS,KME,  & 
+                        ITS,ITE,JTS,JTE,KTS,KTE   
+
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IIH,JJH,IIV,JJV
+
+! local variables
+
+ INTEGER :: I,J
+
+!***  Gopal       - Initial version 
+!***
+!*** CHECK DOMAIN BOUNDS BEFORE PROCEEDING TO INTERPOLATION
+!
+!============================================================================
+
+  IF(IPOS .LE. SHW)CALL wrf_error_fatal('NESTED DOMAIN TOO CLOSE TO PARENTs X-BOUNDARY')
+  IF(JPOS .LE. SHW)CALL wrf_error_fatal('NESTED DOMAIN TOO CLOSE TO PARENTs Y-BOUNDARY')
+
+  DO J = JTS, MIN(JTE,JDE-1)
+   DO I = ITS, MIN(ITE,IDE-1)
+      IF(IIH(I,J) .EQ. 0)CALL wrf_error_fatal ('IIH=0: SOMETHING IS WRONG')
+      IF(JJH(I,J) .EQ. 0)CALL wrf_error_fatal ('JJH=0: SOMETHING IS WRONG')
+   ENDDO
+  ENDDO
+
+  DO J = JTS, MIN(JTE,JDE-1)
+   DO I = ITS, MIN(ITE,IDE-1)
+      IF(IIH(I,J) .LT. (IPOS-SHW) .OR. JJH(I,J) .LT. (JPOS-SHW) .OR.   &
+         IIV(I,J) .LT. (IPOS-SHW) .OR. JJV(I,J) .LT. (JPOS-SHW))THEN
+         WRITE(0,*)I,J,IIH(I,J),IPOS,JJH(I,J),JPOS,SHW
+         WRITE(0,*)I,J,IIV(I,J),IPOS,JJV(I,J),JPOS,SHW
+         CALL wrf_error_fatal ('CHECK NESTED DOMAIN BOUNDS: TRY INCREASING STENCIL WIDTH') 
+      ENDIF
+   ENDDO
+  ENDDO
+
+END SUBROUTINE BOUNDS_CHECK
+
+!==========================================================================================
+
+
+SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD,        &
+                               PINT,T,Q,CWM,            &
+                               FIS,QS,PD,PDTOP,PTOP,    &
+                               ETA1,ETA2,               &
+                               DETA1,DETA2,             &
+                               IDS,IDE,JDS,JDE,KDS,KDE, &
+                               IMS,IME,JMS,JME,KMS,KME, &
+                               ITS,ITE,JTS,JTE,KTS,KTE  )
+!
+
+ USE MODULE_MODEL_CONSTANTS
+ IMPLICIT NONE
+ INTEGER,    INTENT(IN   )                            :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER,    INTENT(IN   )                            :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER,    INTENT(IN   )                            :: ITS,ITE,JTS,JTE,KTS,KTE
+ REAL,       INTENT(IN   )                            :: PDTOP,PTOP
+ REAL, DIMENSION(KMS:KME),                 INTENT(IN) :: ETA1,ETA2,DETA1,DETA2
+ REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(IN) :: FIS,PD,QS
+ REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN) :: PINT,T,Q,CWM
+ REAL, DIMENSION(KMS:KME),                 INTENT(OUT):: PSTD
+ REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(OUT):: Z3d,Q3d,T3d
+
+! local
+
+ INTEGER,PARAMETER                                    :: JTB=134
+ INTEGER                                              :: I,J,K,ILOC,JLOC
+ REAL, PARAMETER                                      :: LAPSR=6.5E-3, GI=1./G,D608=0.608
+ REAL, PARAMETER                                      :: COEF3=287.05*GI*LAPSR, COEF2=-1./COEF3
+ REAL, PARAMETER                                      :: TRG=2.0*R_D*GI,LAPSI=1.0/LAPSR
+ REAL, PARAMETER                                      :: P_REF=103000.
+ REAL                                                 :: A,B,APELP,RTOPP,DZ,ZMID
+ REAL, DIMENSION(IMS:IME,JMS:JME)                     :: SLP,TSFC,ZMSLP
+ REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME)             :: Z3d_IN
+ REAL,DIMENSION(JTB)                                  :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
+ REAL,DIMENSION(JTB)                                  :: QIN,QOUT,TIN,TOUT
+!-------------------------------------------------------------------------------------- 
+
+!  CLEAN Z3D ARRAY FIRST
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO K=KDS,KDE
+      DO I = ITS, MIN(ITE,IDE-1)
+       Z3d(I,K,J)=0.0
+       T3d(I,K,J)=0.0
+       Q3d(I,K,J)=0.0
+      ENDDO
+     ENDDO
+    ENDDO 
+
+
+!  DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
+
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+       Z3d_IN(I,1,J)=FIS(I,J)*GI
+      ENDDO
+    ENDDO 
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO K = KDS,KDE-1
+      DO I = ITS, MIN(ITE,IDE-1)
+        APELP    = (PINT(I,K+1,J)+PINT(I,K,J))
+!       RTOPP    = TRG*T(I,K,J)*(1.0+Q(I,K,J)*P608-CWM(I,K,J))/APELP
+        RTOPP    = TRG*T(I,K,J)*(1.0+Q(I,K,J)*P608)/APELP
+        DZ       = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))   ! (RTv/P_TOT)*D(P_HYDRO)
+        Z3d_IN(I,K+1,J) = Z3d_IN(I,K,J) + DZ
+!       IF(I==2 .AND. J==2)WRITE(0,*)'INSIDE BASE_STATE',K,T(I,K,J)
+      ENDDO
+     ENDDO
+    ENDDO
+
+
+!  CONSTRUCT STANDARD ISOBARIC SURFACES 
+
+    DO K=KDS,KDE                         ! target points in model interface levels (pint)
+       PSTD(K) = ETA1(K)*PDTOP + ETA2(K)*(P_REF -PDTOP - PTOP) + PTOP
+    ENDDO
+
+!   DETERMINE THE MSLP USE THAT TO CREATE HEIGHTS AT 1000. mb LEVEL. THESE HEIGHTS  
+!   MAY ONLY BE USED IN VERTICAL INTERPOLATION TO ISOBARIC SURFACES WHICH ARE LOCATED
+!   BELOW GROUND LEVEL. 
+
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+        TSFC(I,J) = T(I,1,J)*(1.+D608*Q(I,1,J)) + LAPSR*(Z3d_IN(I,1,J)+Z3d_IN(I,2,J))*0.5
+        A         = LAPSR*Z3d_IN(I,1,J)/TSFC(I,J)
+        SLP(I,J)  = PINT(I,1,J)*(1-A)**COEF2    ! sea level pressure 
+        B         = (PSTD(1)/SLP(I,J))**COEF3
+        ZMSLP(I,J)= TSFC(I,J)*LAPSI*(1.0 - B)   ! Height at 1000. mb level
+      ENDDO
+    ENDDO
+
+!   INTERPOLATE Z3d_IN TO STANDARD PRESSURE INTERFACES. FOR LEVELS BELOW
+!   GROUND USE ZMSLP(I,J)
+
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+!    
+!     clean local array before use of spline
+
+      PIN=0.;ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0.
+
+       DO K=KDS,KDE                           ! inputs at model interfaces 
+         PIN(K) = PINT(I,KDE-K+1,J)
+         ZIN(K) = Z3d_IN(I,KDE-K+1,J)
+       ENDDO
+
+       IF(PINT(I,1,J) .LE. PSTD(1))THEN
+          PIN(KDE) = PSTD(1)                 
+          ZIN(KDE) = ZMSLP(I,J)             
+       ENDIF
+!
+       Y2(1   )=0.
+       Y2(KDE)=0.
+!
+       DO K=KDS,KDE
+          PIO(K)=PSTD(K)
+       ENDDO
+!
+       CALL SPLINE1(I,J,JTB,KDE,PIN,ZIN,Y2,KDE,PIO,ZOUT,DUM1,DUM2)  ! interpolate
+!
+
+       DO K=KDS,KDE                           ! inputs at model interfaces
+         Z3d(I,K,J)=ZOUT(K)
+       ENDDO
+       
+      ENDDO
+    ENDDO
+!
+!   INTERPOLATE TEMPERATURE ONTO THE STANDARD PRESSURE LEVELS. FOR LEVELS BELOW  
+!   GROUND USE A LAPSE RATE ATMOSPHERE 
+!
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+!  
+!     clean local array before use of spline or linear interpolation
+!
+      PIN=0.;TIN=0.;Y2=0;PIO=0.;TOUT=0.;DUM1=0.;DUM2=0.
+
+       DO K=KDS+1,KDE                           ! inputs at model levels
+         PIN(K-1) = EXP((ALOG(PINT(I,KDE-K+1,J))+ALOG(PINT(I,KDE-K+2,J)))*0.5)
+         TIN(K-1) = T(I,KDE-K+1,J)
+       ENDDO
+
+       IF(PINT(I,1,J) .LE. PSTD(1))THEN
+         PIN(KDE-1) = EXP((ALOG(PSTD(1))+ALOG(PSTD(2)))*0.5)
+         ZMID     = 0.5*(Z3d_IN(I,1,J)+Z3d_IN(I,2,J))
+         TIN(KDE-1) = T(I,1,J) + LAPSR*(ZMID-ZMSLP(I,J)) 
+       ENDIF
+!
+       Y2(1   )=0.
+       Y2(KDE-1)=0.
+!
+       DO K=KDS,KDE-1
+          PIO(K)=EXP((ALOG(PSTD(K))+ALOG(PSTD(K+1)))*0.5)
+       ENDDO
+
+       CALL SPLINE1(I,J,JTB,KDE-1,PIN,TIN,Y2,KDE-1,PIO,TOUT,DUM1,DUM2)  ! interpolate
+
+
+       DO K=KDS,KDE-1                           ! inputs at model levels
+         T3d(I,K,J)=TOUT(K)
+       ENDDO
+
+      ENDDO
+    ENDDO
+
+!
+!   INTERPOLATE MOISTURE ONTO THE STANDARD PRESSURE LEVELS. FOR LEVELS BELOW 
+!   GROUND USE THE SURFACE MOISTURE 
+!
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+!
+!     clean local array before use of spline or linear interpolation
+
+
+      PIN=0.;QIN=0.;Y2=0;PIO=0.;QOUT=0.;DUM1=0.;DUM2=0.
+
+       DO K=KDS+1,KDE                           ! inputs at model levels
+         PIN(K-1) = EXP((ALOG(PINT(I,KDE-K+1,J))+ALOG(PINT(I,KDE-K+2,J)))*0.5)
+         QIN(K-1) = Q(I,KDE-K+1,J)
+       ENDDO
+
+       IF(PINT(I,1,J) .LE. PSTD(1))THEN
+          PIN(KDE-1) = EXP((ALOG(PSTD(1))+ALOG(PSTD(2)))*0.5)
+!         QIN(KDE-1) =  QS(I,J)
+       ENDIF
+
+       Y2(1   )=0.
+       Y2(KDE-1)=0.
+!
+       DO K=KDS,KDE-1
+          PIO(K)=EXP((ALOG(PSTD(K))+ALOG(PSTD(K+1)))*0.5)
+       ENDDO
+
+       CALL SPLINE1(I,J,JTB,KDE-1,PIN,QIN,Y2,KDE-1,PIO,QOUT,DUM1,DUM2)  ! interpolate
+
+       DO K=KDS,KDE-1                          ! inputs at model levels
+         Q3d(I,K,J)=QOUT(K)
+       ENDDO
+
+      ENDDO
+    ENDDO
+
+END SUBROUTINE BASE_STATE_PARENT
+!=============================================================================
+      SUBROUTINE SPLINE1(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
+!
+!   ******************************************************************
+!   *                                                                *
+!   *  THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE        *
+!   *  PROGRAMED FOR A SMALL SCALAR MACHINE.                         *
+!   *                                                                *
+!   *  PROGRAMER Z. JANJIC                                           *
+!   *                                                                *
+!   *  NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION.  MUST BE GE 3. *
+!   *  XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
+!   *         FUNCTION ARE GIVEN.  MUST BE IN ASCENDING ORDER.       *
+!   *  YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD.   *
+!   *  Y2   - THE SECOND DERIVATIVES AT THE POINTS XOLD.  IF NATURAL *
+!   *         SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE      *
+!   *         SPECIFIED.                                             *
+!   *  NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED.     *
+!   *  XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE     *
+!   *         FUNCTION ARE CALCULATED.  XNEW(K) MUST BE GE XOLD(1)   *
+!   *         AND LE XOLD(NOLD).                                     *
+!   *  YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED.           *
+!   *  P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2.                *
+!   *                                                                *
+!   ******************************************************************
+!---------------------------------------------------------------------
+      IMPLICIT NONE
+!---------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD
+      REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD
+      REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2
+      REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW
+!
+      INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1
+      REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                 &
+             ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
+!---------------------------------------------------------------------
+
+!     debug
+
+      II=9999 !67 !35 !50   !4
+      JJ=9999 !31 !73 !115  !192
+      IF(I.eq.II.and.J.eq.JJ)THEN
+        WRITE(0,*)'DEBUG in SPLINE1:HSO= ',xnew(1:nold)
+        DO K=1,NOLD
+         WRITE(0,*)'DEBUG in SPLINE1:L,ZETAI,PINTI= ' &
+                        ,K,YOLD(K),XOLD(K)
+        ENDDO 
+      ENDIF 
+
+!
+      NOLDM1=NOLD-1
+!
+      DXL=XOLD(2)-XOLD(1)
+      DXR=XOLD(3)-XOLD(2)
+      DYDXL=(YOLD(2)-YOLD(1))/DXL
+      DYDXR=(YOLD(3)-YOLD(2))/DXR
+      RTDXC=0.5/(DXL+DXR)
+!
+      P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1))
+      Q(1)=-RTDXC*DXR
+!
+      IF(NOLD.EQ.3)GO TO 150
+!---------------------------------------------------------------------
+      K=3
+!
+  100 DXL=DXR
+      DYDXL=DYDXR
+      DXR=XOLD(K+1)-XOLD(K)
+      DYDXR=(YOLD(K+1)-YOLD(K))/DXR
+      DXC=DXL+DXR
+      DEN=1./(DXL*Q(K-2)+DXC+DXC)
+!
+      P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2))
+      Q(K-1)=-DEN*DXR
+!
+      K=K+1
+      IF(K.LT.NOLD)GO TO 100
+!-----------------------------------------------------------------------
+  150 K=NOLDM1
+!
+  200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1)
+!
+      K=K-1
+      IF(K.GT.1)GO TO 200
+!-----------------------------------------------------------------------
+      K1=1
+!
+  300 XK=XNEW(K1)
+!
+      DO 400 K2=2,NOLD
+!
+      IF(XOLD(K2).GT.XK)THEN
+        KOLD=K2-1
+        GO TO 450
+      ENDIF
+!
+  400 CONTINUE
+!
+      YNEW(K1)=YOLD(NOLD)
+      GO TO 600
+!
+  450 IF(K1.EQ.1)GO TO 500
+      IF(K.EQ.KOLD)GO TO 550
+!
+  500 K=KOLD
+!
+      Y2K=Y2(K)
+      Y2KP1=Y2(K+1)
+      DX=XOLD(K+1)-XOLD(K)
+      RDX=1./DX
+!
+      AK=.1666667*RDX*(Y2KP1-Y2K)
+      BK=0.5*Y2K
+      CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K)
+!
+  550 X=XK-XOLD(K)
+      XSQ=X*X
+!
+      YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
+
+!  debug
+
+      if(i.eq.ii.and.j.eq.jj)then
+        write(0,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', k1,xnew(k1),ynew(k1)
+      endif
+
+!
+  600 K1=K1+1
+      IF(K1.LE.NNEW)GO TO 300
+
+      RETURN
+      END SUBROUTINE SPLINE1
+!---------------------------------------------------------------------
+
+SUBROUTINE NEST_TERRAIN ( nest, config_flags )
+
+ USE module_domain
+ USE module_configure
+ USE module_timing
+
+ USE wrfsi_static
+
+ IMPLICIT NONE
+
+ TYPE(domain) , POINTER                        :: nest
+ TYPE(grid_config_rec_type) , INTENT(IN)       :: config_flags
+
+!
+! Local variables
+!
+
+ LOGICAL, EXTERNAL                 :: wrf_dm_on_monitor
+ INTEGER                           :: ids,ide,jds,jde,kds,kde
+ INTEGER                           :: ims,ime,jms,jme,kms,kme
+ INTEGER                           :: its,ite,jts,jte,kts,kte 
+ INTEGER                           :: i_parent_start, j_parent_start
+ INTEGER                           :: parent_grid_ratio
+ INTEGER                           :: n,i,j,ii,jj,nnxp,nnyp
+ INTEGER                           :: i_start,j_start,level
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: data1     ! for highres topo
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: avc_big, lnd_big, lah_big, loh_big
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: avc_nest, lnd_nest, lah_nest, loh_nest
+ INTEGER                           :: im_big, jm_big, i_add
+ INTEGER                           :: im, jm
+ CHARACTER(LEN=6)                  :: nestpath
+
+ integer                           :: input_type
+ character(len=128)                :: input_fname
+ character (len=32)                :: cname
+ integer                           :: ndim
+ character (len=3)                 :: memorder
+ character (len=32)                :: stagger
+ integer, dimension(3)             :: domain_start, domain_end
+ integer                           :: wrftype
+ character (len=128), dimension(3) :: dimnames
+
+ integer :: istatus
+ integer :: handle
+ integer :: comm_1, comm_2
+
+ real, allocatable, dimension(:,:,:) :: real_domain
+
+ character (len=10), dimension(4)  :: name = (/ "XLAT_M    ", &
+                                                "XLONG_M   ", &
+                                                "LANDMASK  ", &
+                                                "HGT_M     " /)
+
+ integer, parameter :: IO_BIN=1, IO_NET=2
+
+ integer :: io_form_input
+
+ write(0,*)"in NEST_TERRAIN config_flags%io_form_input = ", config_flags%io_form_input
+ write(0,*)"in NEST_TERRAIN config_flags%auxinput1_inname = ", config_flags%auxinput1_inname
+ io_form_input = config_flags%io_form_input
+ if (config_flags%auxinput1_inname(1:7) == "met_nmm") then
+    input_type = 2
+ else
+    input_type = 1
+ end if
+
+!----------------------------------------------------------------------------------
+
+      IDS = nest%sd31
+      IDE = nest%ed31
+      KDS = nest%sd32
+      KDE = nest%ed32
+      JDS = nest%sd33
+      JDE = nest%ed33
+
+      IMS = nest%sm31
+      IME = nest%em31
+      KMS = nest%sm32
+      KME = nest%em32
+      JMS = nest%sm33
+      JME = nest%em33
+
+      ITS = nest%sp31
+      ITE = nest%ep31
+      KTS = nest%sp32
+      KTE = nest%ep32
+      JTS = nest%sp33
+      JTE = nest%ep33
+
+      i_parent_start = nest%i_parent_start
+      j_parent_start = nest%j_parent_start
+      parent_grid_ratio = nest%parent_grid_ratio
+
+      NNXP=IDE-1
+      NNYP=JDE-1
+
+      ALLOCATE(DATA1(1:NNXP,1:NNYP))
+!
+!
+!--- Read in high resolution topography
+!
+      IF ( wrf_dm_on_monitor() ) THEN                    ! first assign a status
+!
+!      This part of the code is Dusan's doing. Extended by gopal for multiple nest (Feb 19,2005)
+!
+       call find_ijstart_level (nest,i_start,j_start,level)
+       write(0,*)" nest%id =", nest%id , " i_start,j_start,level =", i_start,j_start,level
+
+       write(nestpath,"(a4,i1,a1)") 'nest',level,'/'
+
+       if ( level > 0 ) then
+
+          if (input_type == 1) then
+!
+!        SI version of the static file
+!
+             CALL get_wrfsi_static_dims(nestpath, im_big, jm_big)
+             ALLOCATE (avc_big(im_big,jm_big))
+             ALLOCATE (lnd_big(im_big,jm_big))
+             ALLOCATE (lah_big(im_big,jm_big))
+             ALLOCATE (loh_big(im_big,jm_big))
+             CALL get_wrfsi_static_2d(nestpath, 'avc', avc_big)
+             CALL get_wrfsi_static_2d(nestpath, 'lnd', lnd_big)
+             CALL get_wrfsi_static_2d(nestpath, 'lah', lah_big)
+             CALL get_wrfsi_static_2d(nestpath, 'loh', loh_big)
+
+          else if (input_type == 2) then
+!
+!        WPS version of the static file
+!
+
+#ifdef INTIO
+             if (io_form_input == IO_BIN) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".int"
+#endif
+#ifdef NETCDF
+             if (io_form_input == IO_NET) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".nc"
+#endif
+
+             comm_1 = 1
+             comm_2 = 1
+
+#ifdef INTIO
+             if (io_form_input == IO_BIN) &
+                call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
+#endif
+#ifdef NETCDF
+             if (io_form_input == IO_NET) &
+                call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
+#endif
+             if (istatus /= 0) CALL wrf_error_fatal('NEST_TERRAIN error after ext_XXX_open_for_read '//trim(input_fname))
+
+
+             do n=1,4
+
+             cname = name(n)
+
+             domain_start = 1
+             domain_end = 1
+#ifdef INTIO
+             if (io_form_input == IO_BIN) &
+                call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
+#endif
+#ifdef NETCDF
+             if (io_form_input == IO_NET) &
+                call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
+#endif
+             print *, "istatus=", istatus
+             print *, "ndim=", ndim
+             print *, "memorder=", memorder
+             print *, "stagger=", stagger
+             print *, "domain_start=", domain_start
+             print *, "domain_end=", domain_end
+             print *, "wrftype=", wrftype
+
+
+             if (allocated(real_domain)) deallocate(real_domain)
+             allocate(real_domain(domain_start(1):domain_end(1), domain_start(2):domain_end(2), domain_start(3):domain_end(3)))
+
+#ifdef INTIO
+             if (io_form_input == IO_BIN) then
+                call ext_int_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, wrftype, &
+                                        1, 1, 0, memorder, stagger, &
+                                        dimnames, domain_start, domain_end, domain_start, domain_end, &
+                                        domain_start, domain_end, istatus)
+             end if
+#endif
+#ifdef NETCDF
+             if (io_form_input == IO_NET) then
+                call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, wrftype, &
+                                        1, 1, 0, memorder, stagger, &
+                                        dimnames, domain_start, domain_end, domain_start, domain_end, &
+                                        domain_start, domain_end, istatus)
+             end if
+#endif
+             print *, "istatus=", istatus
+
+             im_big = domain_end(1)
+             jm_big = domain_end(2)
+             if (cname(1:10) == "XLAT_M    ") then
+                ALLOCATE (lah_big(im_big,jm_big))
+                do j=1,jm_big
+                do i=1,im_big
+                   lah_big(i,j) = real_domain(i,j,1)
+                end do
+                end do
+             else if (cname(1:10) == "XLONG_M   ") then
+                ALLOCATE (loh_big(im_big,jm_big))
+                do j=1,jm_big
+                do i=1,im_big
+                   loh_big(i,j) = real_domain(i,j,1)
+                end do
+                end do
+             else if (cname(1:10) == "LANDMASK  ") then
+                ALLOCATE (lnd_big(im_big,jm_big))
+                do j=1,jm_big
+                do i=1,im_big
+                   lnd_big(i,j) = real_domain(i,j,1)
+                end do
+                end do
+             else if (cname(1:10) == "HGT_M     ") then
+                ALLOCATE (avc_big(im_big,jm_big))
+                do j=1,jm_big
+                do i=1,im_big
+                   avc_big(i,j) = real_domain(i,j,1)
+                end do
+                end do
+             end if
+
+             end do
+
+#ifdef INTIO
+             if (io_form_input == IO_BIN) then
+                call ext_int_ioclose(handle, istatus)
+             end if
+#endif
+#ifdef NETCDF
+             if (io_form_input == IO_NET) then
+                call ext_ncd_ioclose(handle, istatus)
+             end if
+#endif
+
+          else
+             CALL wrf_error_fatal('NEST_TERRAIN wrong input_type')
+          end if
+
+       else
+          CALL wrf_error_fatal('this routine NEST_TERRAIN should nou be called for top-level domain')
+       end if
+
+! select subdomain from big fine grid
+
+        im = NNXP
+        jm = NNYP
+
+        ALLOCATE (avc_nest(im,jm))
+        ALLOCATE (lnd_nest(im,jm))
+        ALLOCATE (lah_nest(im,jm))
+        ALLOCATE (loh_nest(im,jm))
+
+        i_add = mod(j_start+1,2) 
+        DO j=1,jm
+        DO i=1,im
+           avc_nest(i,j) = avc_big(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
+           lnd_nest(i,j) = lnd_big(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
+           lah_nest(i,j) = lah_big(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
+           loh_nest(i,j) = loh_big(i_start+i-1 + mod(j+1,2)*i_add, j_start+j-1)
+        END DO
+        END DO
+
+        WRITE(0,*)'SOME MATCHING TEST i_parent_start, j_parent_start',i_parent_start,j_parent_start
+        WRITE(0,*)'WRFSI LAT      COMPUTED LAT'
+        WRITE(0,*)lah_nest(1,1),nest%nmm_hlat(1,1)
+        WRITE(0,*)'WRFSI LON      COMPUTED LON'
+        WRITE(0,*)loh_nest(1,1),nest%nmm_hlon(1,1)
+
+        IF(ABS(lah_nest(1,1)-nest%nmm_hlat(1,1)) .GE. 0.5 .OR.  & 
+           ABS(loh_nest(1,1)-nest%nmm_hlon(1,1)) .GE. 0.5)THEN 
+            WRITE(0,*)'CHECK WRFSI CONFIGURATION AND INPUT HIGH RESOLUTION TOPOGRAPHY AND/OR GRID RATIO' 
+            CALL wrf_error_fatal('LATLON MISMATCH: ERROR READING static FILE FOR THE NEST')
+        ENDIF
+
+        call smdhld(im,jm,avc_nest,1.0-lnd_nest,12,12)
+
+!-------------4-point averaging of mountains along inner boundary-------
+
+        do i=1,im-1
+            avc_nest(i,2)=0.25*(avc_nest(i,1)+avc_nest(i+1,1)+ &
+           &                    avc_nest(i,3)+avc_nest(i+1,3))
+        enddo
+
+        do i=1,im-1
+            avc_nest(i,jm-1)=0.25*(avc_nest(i,jm-2)+avc_nest(i+1,jm-2)+ &
+           &                       avc_nest(i,jm)+avc_nest(i+1,jm))
+        enddo
+
+        do j=4,jm-3,2
+            avc_nest(1,j)=0.25*(avc_nest(1,j-1)+avc_nest(2,j-1)+ &
+           &                    avc_nest(1,j+1)+avc_nest(2,j+1))
+        enddo
+
+        do j=4,jm-3,2
+            avc_nest(im,j)=0.25*(avc_nest(im-1,j-1)+avc_nest(im,j-1)+ &
+           &                     avc_nest(im-1,j+1)+avc_nest(im,j+1))
+        enddo
+        
+        DO J = 1,NNYP
+         DO I = 1,NNXP
+            DATA1(I,J) = 9.81*avc_nest(I,J)
+         ENDDO
+        ENDDO
+
+        DEALLOCATE (avc_big,lnd_big)
+        DEALLOCATE (avc_nest,lnd_nest)
+!
+      ENDIF
+
+      CALL wrf_dm_bcast_bytes (DATA1,NNXP*NNYP*RWORDSIZE)
+
+      DO J=JDS,JDE
+       DO I =IDS,IDE
+        IF(I.GE.ITS .AND. I .LE. MIN(ide-1,ite) .AND. J.GE.JTS  .AND. J .LE. MIN(jde-1,jte))THEN
+          nest%nmm_hres_fis(I,J)=DATA1(I,J)
+        ENDIF
+       ENDDO
+      ENDDO
+
+      DEALLOCATE(DATA1)
+      WRITE(0,*)'end of NEST_TERRAIN'
+
+END SUBROUTINE NEST_TERRAIN
+!===========================================================================================
+
+
+SUBROUTINE med_init_domain_constants_nmm ( parent, nest)   !, config_flags)
+  ! Driver layer
+   USE module_domain
+   USE module_configure
+   USE module_timing
+   IMPLICIT NONE
+   TYPE(domain) , POINTER                     :: parent, nest, grid
+!
+#ifdef DEREF_KLUDGE
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+!
+   INTERFACE
+     SUBROUTINE med_initialize_nest_nmm ( grid  &   
+!
+# include 
+!
+                           )
+        USE module_domain
+        USE module_configure
+        USE module_timing
+        IMPLICIT NONE
+        TYPE(domain) , POINTER                  :: grid
+#include 
+     END SUBROUTINE med_initialize_nest_nmm 
+   END INTERFACE
+
+!------------------------------------------------------------------------------
+!  PURPOSE: 
+!         - initialize some data, mainly 2D & 3D nmm arrays  very similar to 
+!           those done in ./dyn_nmm/module_initialize_real.F 
+!-----------------------------------------------------------------------------
+!
+
+   grid => nest
+
+#ifdef DEREF_KLUDGE
+   sm31             = grid%sm31
+   em31             = grid%em31
+   sm32             = grid%sm32
+   em32             = grid%em32
+   sm33             = grid%sm33
+   em33             = grid%em33
+   sm31x            = grid%sm31x
+   em31x            = grid%em31x
+   sm32x            = grid%sm32x
+   em32x            = grid%em32x
+   sm33x            = grid%sm33x
+   em33x            = grid%em33x
+   sm31y            = grid%sm31y
+   em31y            = grid%em31y
+   sm32y            = grid%sm32y
+   em32y            = grid%em32y
+   sm33y            = grid%sm33y
+   em33y            = grid%em33y
+#endif
+
+   CALL med_initialize_nest_nmm( grid &   
+!
+# include 
+!
+                       )
+
+END SUBROUTINE med_init_domain_constants_nmm
+
+SUBROUTINE med_initialize_nest_nmm( grid &
+!
+# include 
+!
+                           )
+
+ USE module_domain
+ USE module_configure
+ USE module_timing
+ IMPLICIT NONE
+
+! Local domain indices and counters.
+
+ INTEGER :: ids, ide, jds, jde, kds, kde, &
+            ims, ime, jms, jme, kms, kme, &
+            its, ite, jts, jte, kts, kte, &
+            i, j, k, nnxp, nnyp 
+
+ TYPE(domain) , POINTER                     :: grid
+
+! Local data
+
+ LOGICAL, EXTERNAL                   :: wrf_dm_on_monitor
+ INTEGER                             :: KHH,KVH,JAM,JA,IHL, IHH, L
+ INTEGER                             :: II,JJ,ISRCH,ISUM
+ INTEGER, ALLOCATABLE, DIMENSION(:)  :: KHL2,KVL2,KHH2,KVH2,KHLA,KHHA,KVLA,KVHA
+ INTEGER,PARAMETER                   :: KNUM=SELECTED_REAL_KIND(13)
+!
+ REAL(KIND=KNUM)                     :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0
+ REAL(KIND=KNUM)                     :: STPH,CTPH,TDLM,TDPH,FP,TPH,TLM,TLM0
+ REAL                                :: TPH0D,TLM0D,ANBI,TSPH,DTAD,DTCF,DT
+ REAL                                :: ACDT,CDDAMP,DXP
+ REAL                                :: WBD,SBD,WBI,SBI,EBI
+ REAL                                :: DY_NMM0
+ REAL                                :: RSNOW,SNOFAC
+ REAL, ALLOCATABLE, DIMENSION(:)     :: DXJ,WPDARJ,CPGFUJ,CURVJ,   &
+                                        FCPJ,FDIVJ,EMJ,EMTJ,FADJ,  &
+                                        HDACJ,DDMPUJ,DDMPVJ
+!
+ REAL, PARAMETER:: SALP=2.60
+ REAL, PARAMETER:: SNUP=0.040
+ REAL, PARAMETER:: W_NMM=0.08
+ REAL, PARAMETER:: COAC=0.75
+ REAL, PARAMETER:: CODAMP=6.4
+ REAL, PARAMETER:: TWOM=.00014584
+ REAL, PARAMETER:: CP=1004.6
+ REAL, PARAMETER:: DFC=1.0    
+ REAL, PARAMETER:: DDFC=1.0  
+ REAL, PARAMETER:: ROI=916.6
+ REAL, PARAMETER:: R=287.04
+ REAL, PARAMETER:: CI=2060.0
+ REAL, PARAMETER:: ROS=1500.
+ REAL, PARAMETER:: CS=1339.2
+ REAL, PARAMETER:: DS=0.050
+ REAL, PARAMETER:: AKS=.0000005
+ REAL, PARAMETER:: DZG=2.85
+ REAL, PARAMETER:: DI=.1000
+ REAL, PARAMETER:: AKI=0.000001075
+ REAL, PARAMETER:: DZI=2.0
+ REAL, PARAMETER:: THL=210.
+ REAL, PARAMETER:: PLQ=70000.
+ REAL, PARAMETER:: ERAD=6371200.
+ REAL, PARAMETER:: DTR=0.01745329
+
+   !  Definitions of dummy arguments to solve
+#include 
+
+#ifdef DEREF_KLUDGE
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+#ifdef DEREF_KLUDGE
+   sm31             = grid%sm31
+   em31             = grid%em31
+   sm32             = grid%sm32
+   em32             = grid%em32
+   sm33             = grid%sm33
+   em33             = grid%em33
+   sm31x            = grid%sm31x
+   em31x            = grid%em31x
+   sm32x            = grid%sm32x
+   em32x            = grid%em32x
+   sm33x            = grid%sm33x
+   em33x            = grid%em33x
+   sm31y            = grid%sm31y
+   em31y            = grid%em31y
+   sm32y            = grid%sm32y
+   em32y            = grid%em32y
+   sm33y            = grid%sm33y
+   em33y            = grid%em33y
+#endif
+
+#define COPY_IN
+#include 
+#ifdef DM_PARALLEL
+#      include 
+#endif
+
+   CALL get_ijk_from_grid (  grid ,                           &
+                             ids, ide, jds, jde, kds, kde,    &
+                             ims, ime, jms, jme, kms, kme,    &
+                             its, ite, jts, jte, kts, kte     )
+
+
+!=================================================================================
+!
+!
+
+    DT=grid%dt         !float(TIME_STEP)/parent_time_step_ratio
+    NNXP=min(ITE,IDE-1)
+    NNYP=min(JTE,JDE-1)
+    JAM=6+2*((JDE-1)-10)         ! this should be the fix instead of JAM=6+2*(NNYP-10)
+
+    WRITE(0,*)'TIME STEP ON DOMAIN',grid%id,'==',dt
+
+!
+    ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP))
+    ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP))
+    ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),FADJ(JTS:NNYP))
+    ALLOCATE(HDACJ(JTS:NNYP),DDMPUJ(JTS:NNYP),DDMPVJ(JTS:NNYP))
+    ALLOCATE(KHLA(JAM),KHHA(JAM))
+    ALLOCATE(KVLA(JAM),KVHA(JAM))
+
+!   INITIALIZE SOME LAND/WATER SURFACE DATA ON THE BASIS OF INPUTS: SM, XICE, WEASD, 
+!   INTERPOLATED FROM MOTHER (WRFSI) DOMAIN. THIS PART OF THE CODE HAS TO BE REVISITED
+!   LATER ON
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+      IF(SM(I,J).GT.0.9) THEN           ! OVER WATER SURFACE
+!
+           IF (XICE(I,J) .gt. 0)THEN    ! XICE: SI INPUT ON PARENT, INTERPOLATED ONTO NEST
+             SI(I,J)=1.0                ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT
+           ENDIF
+!
+           EPSR(I,J)= 0.97              ! VALID OVER SEA SURFACE
+           GFFC(I,J)= 0.
+           ALBEDO(I,J)=.06
+           ALBASE(I,J)=.06
+!
+              IF(SI (I,J) .GT. 0.)THEN  ! VALID OVER SEA-ICE 
+                 SM(I,J)=0.
+                 SI(I,J)=0.             ! 
+                 SICE(I,J)=1.
+                 GFFC(I,J)=0.           ! just leave zero as irrelevant
+                 ALBEDO(I,J)=.60        ! DEFINE ALBEDO 
+                 ALBASE(I,J)=.60
+              ENDIF
+!
+      ELSE                              ! OVER LAND SURFACE
+!
+           SI(I,J)=5.0*WEASD(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (SI) IS INTERPOLATED 
+           EPSR(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
+           GFFC(I,J)=0.0                ! just leave zero as irrelevant
+           SICE(I,J)=0.                 ! SEA ICE
+           SNO(I,J)=SI(I,J)*.20         ! LAND-SNOW COVER 
+!
+      ENDIF
+!
+     ENDDO
+    ENDDO
+
+!   This may just be a fix and may need some Registry related changes, later on
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+         VEGFRA(I,J)=VEGFRC(I,J)
+     ENDDO
+    ENDDO
+
+!   DETERMINE ALBEDO OVER LAND ON THE BASIS OF INPUTS: SM, ALBASE, MXSNAL & VEGFRA
+!   INTERPOLATED FROM MOTHER (WRFSI) DOMAIN
+
+ 
+    DO J = JTS, MIN(JTE,JDE-1) 
+     DO I = ITS, MIN(ITE,IDE-1)
+
+          IF(SM(I,J).LT.0.9.AND.SICE(I,J).LT.0.9) THEN
+!
+            IF ( (SNO(I,J) .EQ. 0.0) .OR. &            ! SNOWFREE ALBEDO
+                           (ALBASE(I,J) .GE. MXSNAL(I,J) ) ) THEN
+              ALBEDO(I,J) = ALBASE(I,J)
+            ELSE
+              IF (SNO(I,J) .LT. SNUP) THEN             ! MODIFY ALBEDO IF SNOWCOVER:
+                  RSNOW = SNO(I,J)/SNUP                ! BELOW SNOWDEPTH THRESHOLD
+                  SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
+              ELSE
+                  SNOFAC = 1.0                         ! ABOVE SNOWDEPTH THRESHOLD
+              ENDIF
+              ALBEDO(I,J) = ALBASE(I,J) &
+                          + (1.0-VEGFRA(I,J))*SNOFAC*(MXSNAL(I,J)-ALBASE(I,J))
+            ENDIF
+!
+          END IF
+
+          SI(I,J)=5.0*WEASD(I,J)
+          SNO(I,J)=WEASD(I,J)
+! this block probably superfluous.  Meant to guarantee land/sea agreement
+
+        IF (SM(I,J) .gt. 0.5)THEN 
+           landmask(I,J)=0.0
+        ELSE 
+           landmask(I,J)=1.0
+        ENDIF 
+
+        IF (SICE(I,J) .eq. 1.0) then !!!! change vegtyp and sltyp to fit seaice (desireable??)
+         ISLTYP(I,J)=16
+         IVGTYP(I,J)=24
+        ENDIF 
+
+     ENDDO
+    ENDDO
+
+!  Check land water interface
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS,MIN(ITE,IDE-1)
+      IF(SM(I,J).GT.0.9 .AND. VEGFRA(I,J) .NE. 0) THEN
+        WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,SM(I-1,J),VEGFRA(I-1,j),SM(I,J),VEGFRA(I,J)
+      ENDIF
+!
+      IF(SM(I,J).GT.0.9 .AND. NMM_TSK(I,J) .NE. 0) THEN
+        WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,SM(I-1,J),NMM_TSK(I-1,J),SM(I,J),NMM_TSK(I,J)
+      ENDIF
+     ENDDO
+    ENDDO
+
+
+!   hardwire root depth for time being
+
+        RTDPTH=0.
+        RTDPTH(1)=0.1
+        RTDPTH(2)=0.3
+        RTDPTH(3)=0.6
+
+!   hardwire soil depth for time being
+
+        SLDPTH=0.
+        SLDPTH(1)=0.1
+        SLDPTH(2)=0.3
+        SLDPTH(3)=0.6
+        SLDPTH(4)=1.0
+
+!-----------  END OF LAND SURFACE INITIALIZATION -------------------------------------
+!
+!   INITIALIZE 3D HEIGHT MASK AND VELOCITY FIELDS (HTM AND VTM),
+!   AND LOWEST ABV GROUND LEVEL (LMH AND LMV) AND RECIPROCAL 
+!   ETAS (RES) OVER THE NESTED DOMAIN  
+
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO K = KTS,KTE
+      DO I = ITS, MIN(ITE,IDE-1)
+       HTM(I,K,J)=1.0
+       VTM(I,K,J)=1.0
+      ENDDO
+     ENDDO
+    ENDDO
+
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+       LMH(I,J)= KME-1        ! note the flipping for start_domain_nmm.F
+       LMV(I,J)= KME-1        ! this is consistent with Tom's version
+       RES(I,J)=1.
+     ENDDO
+    ENDDO
+
+!   INITIALIZE 2D BOUNDARY MASKS
+
+!! HBM2:
+ 
+    HBM2=0.
+    DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+       IF((J .GE. 3 .and. J .LE. (JDE-1)-2) .AND.   &
+          (I .GE. 2 .and. I .LE. (IDE-1)-2+MOD(J,2))) THEN
+          HBM2(I,J)=1.
+        ENDIF
+      ENDDO
+    ENDDO   
+
+!! HBM3:
+
+    HBM3=0.
+    DO J=JTS,MIN(JTE,JDE-1)
+     IHWG(J)=mod(J+1,2)-1
+      IF (J .ge. 4 .and. J .le. (JDE-1)-3) THEN
+        IHL=(IDS+1)-IHWG(J) 
+        IHH=(IDE-1)-2
+        DO I=ITS,MIN(ITE,IDE-1)
+           IF (I .ge. IHL  .and. I .le. IHH) HBM3(I,J)=1.
+        ENDDO 
+      ENDIF
+    ENDDO 
+   
+!! VBM2
+
+    VBM2=0.
+    DO J=JTS,MIN(JTE,JDE-1)
+     DO I=ITS,MIN(ITE,IDE-1)
+       IF((J .ge. 3 .and. J .le. (JDE-1)-2)  .AND.  &
+          (I .ge. 2 .and. I .le. (IDE-1)-1-MOD(J,2))) THEN
+           VBM2(I,J)=1.
+       ENDIF
+     ENDDO
+    ENDDO
+
+!! VBM3
+
+    VBM3=0.
+    DO J=JTS,MIN(JTE,JDE-1)
+      DO I=ITS,MIN(ITE,IDE-1)
+        IF((J .ge. 4 .and. J .le. (JDE-1)-3)  .AND.  &
+           (I .ge. 3-MOD(J,2) .and. I .le. (IDE-1)-2)) THEN
+           VBM3(I,J)=1.
+        ENDIF
+      ENDDO
+    ENDDO
+
+    TPH0D  = grid%CEN_LAT
+    TLM0D  = grid%CEN_LON
+    TPH0   = TPH0D*DTR
+    WBD    = grid%WBD0   ! gopal's doing: may use Registry WBD0 now
+    WB     = WBD*DTR
+    SBD    = grid%SBD0   ! gopal's doing: may use Registry SBD0 now
+    SB     = SBD*DTR
+    DLM    = DLMD*DTR  ! input now from med_nest_egrid_configure
+    DPH    = DPHD*DTR  ! input now from med_nest_egrid_configure
+    TDLM   = DLM+DLM
+    TDPH   = DPH+DPH
+    WBI    = WB+TDLM
+    SBI    = SB+TDPH
+    EBI    = WB+((ide-1)-2)*TDLM  ! gopal's doing: check this for nested domain
+    ANBI   = SB+((jde-1)-3)*DPH   ! gopal's doing: check this for nested domain
+    STPH0  = SIN(TPH0)
+    CTPH0  = COS(TPH0)
+    TSPH   = 3600./grid%DT
+    DTAD   = 1.0
+    DTCF   = 4.0    
+    DY_NMM0= DY_NMM ! ERAD*DPH; input now from med_nest_egrid_configure
+
+!   CORIOLIS PARAMETER  (There appears to be some roundoff in computing TLM & STPH and other terms,
+!   in the nested domain. The problem needs to be revisited
+
+    DO J=JTS,MIN(JTE,JDE-1)
+      TLM0=WB-TDLM+MOD(J,2)*DLM           ! remember this is a wind point
+      TPH =SB+float(J-1)*DPH
+      STPH=SIN(TPH)
+      CTPH=COS(TPH)
+      DO I=ITS,MIN(ITE,IDE-1)
+         TLM=TLM0 + I*TDLM
+         FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM))
+         F(I,J)=0.5*grid%DT*FP
+      ENDDO
+    ENDDO
+
+
+    DO J=JTS,MIN(JTE,JDE-1)
+      KHL2(J)=(IDE-1)*(J-1)-(J-1)/2+2
+      KVL2(J)=(IDE-1)*(J-1)-J/2+2
+      KHH2(J)=(IDE-1)*J-J/2-1
+      KVH2(J)=(IDE-1)*J-(J+1)/2-1
+    ENDDO
+
+
+    TPH=SB-DPH
+    DO J=JTS,MIN(JTE,JDE-1)
+      TPH=SB+float(J-1)*DPH
+      DXP=ERAD*DLM*COS(TPH)
+      DXJ(J)=DXP
+      WPDARJ(J)=-W_NMM*((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM0**2)/  & 
+                (grid%DT*32.*DXP*DY_NMM0)
+      CPGFUJ(J)=-grid%DT/(48.*DXP)
+      CURVJ(J)=.5*grid%DT*TAN(TPH)/ERAD
+      FCPJ(J)=grid%DT/(CP*192.*DXP*DY_NMM0)
+      FDIVJ(J)=1./(12.*DXP*DY_NMM0)
+      FADJ(J)=-grid%DT/(48.*DXP*DY_NMM0)*DTAD
+      ACDT=grid%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM0**2)
+      CDDAMP=CODAMP*ACDT
+      HDACJ(J)=COAC*ACDT/(4.*DXP*DY_NMM0)
+      DDMPUJ(J)=CDDAMP/DXP
+      DDMPVJ(J)=CDDAMP/DY_NMM0
+    ENDDO
+
+! --------------DERIVED VERTICAL GRID CONSTANTS--------------------------
+
+     WRITE(0,*)'NEW CHANGE',F4D,EF4T,F4Q
+
+      DO L=KDS,KDE-1
+        RDETA(L)=1./DETA(L)
+        F4Q2(L)=-.25*grid%DT*DTAD/DETA(L)
+      ENDDO
+
+       DO J=JTS,MIN(JTE,JDE-1)
+        DO I=ITS,MIN(ITE,IDE-1)
+          DX_NMM(I,J)=DXJ(J)
+          WPDAR(I,J)=WPDARJ(J)*HBM2(I,J)
+          CPGFU(I,J)=CPGFUJ(J)*VBM2(I,J)
+          CURV(I,J)=CURVJ(J)*VBM2(I,J)
+          FCP(I,J)=FCPJ(J)*HBM2(I,J)
+          FDIV(I,J)=FDIVJ(J)*HBM2(I,J)
+          FAD(I,J)=FADJ(J)
+          HDACV(I,J)=HDACJ(J)*VBM2(I,J)
+          HDAC(I,J)=HDACJ(J)*1.25*HBM2(I,J)
+        ENDDO
+       ENDDO
+
+       DO J=JTS, MIN(JTE,JDE-1)
+        IF (J.LE.5.OR.J.GE.(JDE-1)-4) THEN
+          KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have
+          DO I=ITS,MIN(ITE,IDE-1)
+             IF (I .ge. 2 .and. I .le. KHH) THEN
+               HDAC(I,J)=HDAC(I,J)* DFC
+             ENDIF
+          ENDDO
+        ELSE
+          KHH=2+MOD(J,2)
+          DO I=ITS,MIN(ITE,IDE-1)
+             IF (I .ge. 2 .and. I .le. KHH) THEN
+               HDAC(I,J)=HDAC(I,J)* DFC
+             ENDIF
+          ENDDO
+          KHH=(IDE-1)-2+MOD(J,2)
+
+          DO I=ITS,MIN(ITE,IDE-1)
+             IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN
+               HDAC(I,J)=HDAC(I,J)* DFC
+             ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+
+      DO J=JTS,min(JTE,JDE-1)
+      DO I=ITS,min(ITE,IDE-1)
+        DDMPU(I,J)=DDMPUJ(J)*VBM2(I,J)
+        DDMPV(I,J)=DDMPVJ(J)*VBM2(I,J)
+        HDACV(I,J)=HDACV(I,J)*VBM2(I,J)
+      ENDDO
+      ENDDO
+
+! --------------INCREASING DIFFUSION ALONG THE BOUNDARIES----------------
+
+        DO J=JTS,MIN(JTE,JDE-1)
+        IF (J.LE.5.OR.J.GE.JDE-1-4) THEN
+          KVH=(IDE-1)-1-MOD(J,2)
+          DO I=ITS,MIN(ITE,IDE-1)
+            IF (I .ge. 2 .and.  I .le. KVH) THEN
+             DDMPU(I,J)=DDMPU(I,J)*DDFC
+             DDMPV(I,J)=DDMPV(I,J)*DDFC
+             HDACV(I,J)=HDACV(I,J)*DFC
+            ENDIF
+          ENDDO
+        ELSE
+          KVH=3-MOD(J,2)
+          DO I=ITS,MIN(ITE,IDE-1)
+           IF (I .ge. 2 .and.  I .le. KVH) THEN
+            DDMPU(I,J)=DDMPU(I,J)*DDFC
+            DDMPV(I,J)=DDMPV(I,J)*DDFC
+            HDACV(I,J)=HDACV(I,J)*DFC
+           ENDIF
+          ENDDO
+          KVH=(IDE-1)-1-MOD(J,2)
+          DO I=ITS,MIN(ITE,IDE-1)
+           IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN
+            DDMPU(I,J)=DDMPU(I,J)*DDFC
+            DDMPV(I,J)=DDMPV(I,J)*DDFC
+            HDACV(I,J)=HDACV(I,J)*DFC
+           ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+
+! This one was left over for nested domain
+ 
+     DO J = JTS, MIN(JTE,JDE-1)
+       DO I = ITS, MIN(ITE,IDE-1)
+          GLAT(I,J)=HLAT(I,J)*DTR
+          GLON(I,J)=HLON(I,J)*DTR
+       ENDDO
+     ENDDO
+
+!!   compute EMT, EM on global domain, and only on task 0.
+
+!    IF (wrf_dm_on_monitor()) THEN   !!!! NECESSARY TO LIMIT THIS TO TASK ZERO?
+      
+     ALLOCATE(EMJ(JDS:JDE-1),EMTJ(JDS:JDE-1))
+     write(0,*) 'FIGURING OUT EMJ, EMTJ ', JDS, JDE-1
+     DO J=JDS,JDE-1
+       TPH=SB+float(J-1)*DPH
+       DXP=ERAD*DLM*COS(TPH)
+       EMJ(J)= grid%DT/( 4.*DXP)*DTAD
+       EMTJ(J)=grid%DT/(16.*DXP)*DTAD
+!       write(0,*) 'J, EMTJ(J): ', J, EMTJ(J)
+     ENDDO
+
+          JA=0
+          DO 161 J=3,5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 161      EMT(JA)=EMTJ(J)
+          DO 162 J=(JDE-1)-4,(JDE-2)-2
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 162      EMT(JA)=EMTJ(J)
+          DO 163 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=2+MOD(J,2)
+ 163      EMT(JA)=EMTJ(J)
+          DO 164 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=(IDE-1)-2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 164      EMT(JA)=EMTJ(J)
+
+! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR----
+
+          JA=0
+          DO 171 J=3,5
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 171      EM(JA)=EMJ(J)
+          DO 172 J=(JDE-1)-4,(JDE-2)-2
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 172      EM(JA)=EMJ(J)
+          DO 173 J=6,(JDE-1)-5
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=2+MOD(J+1,2)
+ 173      EM(JA)=EMJ(J)
+          DO 174 J=6,(JDE-1)-5
+          JA=JA+1
+          KVLA(JA)=(IDE-1)-2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 174      EM(JA)=EMJ(J)
+
+!        ENDIF ! wrf_dm_on_monitor
+
+!! must be a better place to put this, but will eliminate "phantom"
+!! wind points here (no wind point on eastern boundary of odd numbered rows)
+!!
+                                                                !   phantom
+        IF (ABS(IDE-1-ITE) .eq. 1 ) THEN                        !      | 
+         WRITE(0,*)'zero phantom winds'                         !  H  [x]    H    V
+         DO K=KDS,KDE-1                                         !  
+          DO J=JDS,JDE-1,2                                      !  V  [H]    V    H
+           IF (J .ge. JTS .and. J .le. JTE) THEN                !
+             U(IDE-1,K,J)=0.                                    !  H  [x]    H    V
+             V(IDE-1,K,J)=0.                                    !  ------    ------  
+           ENDIF                                                !   ide-1      ide
+          ENDDO                                                 !   NMM/SI     WRF
+         ENDDO                                                  !   domain    domain
+        ENDIF                                                   !             (dummy)   
+
+
+! just a test for gravity waves
+
+!  PD=62000.
+!   U=0.0
+!   V=0.0
+!   T=300.
+!   Q=0.0
+!   Q2=0.0
+!   CWM=0.0
+!   FIS=0.0
+
+! testx
+!  DO J = JTS, MIN(JTE,JDE-1)
+!   DO K = KTS,KTE
+!    DO I = ITS, MIN(ITE,IDE-1)
+!      SM(I,J)=I
+!       U(I,K,J)=J
+!    ENDDO
+!   ENDDO
+!  ENDDO
+!
+
+!   deallocs
+
+    DEALLOCATE(KHL2,KVL2,KHH2,KVH2)
+    DEALLOCATE(DXJ,WPDARJ,CPGFUJ,CURVJ)
+    DEALLOCATE(FCPJ,FDIVJ,FADJ)
+    DEALLOCATE(HDACJ,DDMPUJ,DDMPVJ)
+    DEALLOCATE(KHLA,KHHA)
+    DEALLOCATE(KVLA,KVHA)
+
+
+END SUBROUTINE med_initialize_nest_nmm
+!======================================================================
+
+      subroutine smdhld(ime,jme,h,s,lines,nsmud)
+      dimension ihw(jme),ihe(jme)
+      dimension h(ime,jme),s(ime,jme) &
+     &         ,hbms(ime,jme),hne(ime,jme),hse(ime,jme)
+!-----------------------------------------------------------------------
+          do j=1,jme
+      ihw(j)=-mod(j,2)
+      ihe(j)=ihw(j)+1
+          enddo
+!-----------------------------------------------------------------------
+
+              do j=1,jme
+          do i=1,ime
+      hbms(i,j)=1.-s(i,j)
+          enddo
+              enddo
+!
+      jmelin=jme-lines+1
+      ibas=lines/2
+      m2l=mod(lines,2)
+!
+              do j=lines,jmelin
+          ihl=ibas+mod(j,2)+m2l*mod(j+1,2)
+          ihh=ime-ibas-m2l*mod(j+1,2)
+
+!       write(6,*) 'no smooth limits for J: ', J, 'are  ', ihl,ihh
+!
+          do i=ihl,ihh
+      hbms(i,j)=0.
+          enddo
+              enddo
+!-----------------------------------------------------------------------
+                  do ks=1,nsmud
+
+                write(6,*) 'H(1,1): ', h(1,1)
+                write(6,*) 'H(3,1): ', h(1,1)
+!-----------------------------------------------------------------------
+              do j=1,jme-1
+          do i=1,ime-1
+      hne(i,j)=h(i+ihe(j),j+1)-h(i,j)
+          enddo
+              enddo
+              do j=2,jme
+          do i=1,ime-1
+      hse(i,j)=h(i+ihe(j),j-1)-h(i,j)
+          enddo
+              enddo
+!
+              do j=2,jme-1
+          do i=1+mod(j,2),ime-1
+      h(i,j)=(hne(i,j)-hne(i+ihw(j),j-1) &
+     &       +hse(i,j)-hse(i+ihw(j),j+1))*hbms(i,j)*0.125+h(i,j)
+          enddo
+              enddo
+!-----------------------------------------------------------------------
+
+!!!         smooth around boundary somehow?
+
+!       special treatment for four corners
+
+        if (hbms(1,1) .eq. 1) then
+        h(1,1)=0.75*h(1,1)+0.125*h(1+ihe(1),2)+ &
+     &                            0.0625*(h(2,1)+h(1,3))
+        endif
+
+        if (hbms(ime,1) .eq. 1) then
+        h(ime,1)=0.75*h(ime,1)+0.125*h(ime+ihw(1),2)+ &
+     &                            0.0625*(h(ime-1,1)+h(ime,3))
+        endif
+
+        if (hbms(1,jme) .eq. 1) then
+        h(1,jme)=0.75*h(1,jme)+0.125*h(1+ihe(jme),jme-1)+ &
+     &                            0.0625*(h(2,jme)+h(1,jme-2))
+        endif
+
+        if (hbms(ime,jme) .eq. 1) then
+        h(ime,jme)=0.75*h(ime,jme)+0.125*h(ime+ihw(jme),jme-1)+ &
+     &                            0.0625*(h(ime-1,jme)+h(ime,jme-2))
+        endif
+
+
+!       S bound
+
+        J=1
+        do I=2,ime-1
+        if (hbms(I,J) .eq. 1) then
+        h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihe(J),J+1))
+        endif
+        enddo
+
+!       N bound
+
+        J=JME
+        do I=2,ime-1
+        if (hbms(I,J) .eq. 1) then
+        h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J-1)+h(I+ihe(J),J-1))
+        endif
+        enddo
+
+!       W bound
+
+        I=1
+        do J=3,jme-2
+        if (hbms(I,J) .eq. 1) then
+        h(I,J)=0.75*h(I,J)+0.125*(h(I+ihe(J),J+1)+h(I+ihe(J),J-1))
+        endif
+        enddo
+
+!       E bound
+
+        I=IME
+        do J=3,jme-2
+        if (hbms(I,J) .eq. 1) then
+        h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihw(J),J-1))
+        endif
+        enddo
+
+
+                      enddo   ! end ks loop
+
+!!      (light touch) with 5-point filter over untouched interior?
+
+!       do ks=1,5
+!       do J=lines-1,jme-(lines-1)
+!       do I=lines-1,ime-(lines-1)
+!       if (s(I,J) .eq. 0 .and.
+!     &      h(I,J) .gt. h(i+ihw(J),J+1) .and.
+!     &      h(I,J) .gt. h(I+ihe(J),J+1) .and.
+!     &      h(I,J) .gt. h(i+ihw(J),J-1) .and.
+!     &      h(I,J) .gt. h(I+ihe(J),J-1)) then
+!       write(6,*) 'smoothing topo at I,J...', I,J,H(I,J)
+!       h(I,J)=h(I,J)+0.125*( h(i+ihw(J),J+1) + h(I+ihe(J),J+1) +
+!     &                      h(i+ihw(J),J-1) + h(I+ihe(J),J-1) -
+!     &                       4*h(I,J) )
+!       write(6,*) 'post smoothing val', ks,H(I,J)
+!       endif
+!       enddo
+!       enddo
+!       enddo
+
+!-----------------------------------------------------------------------
+      return
+      end subroutine smdhld
+
+!--------------------------------------------------------------------------------------
+#if 0
+SUBROUTINE initial_nest_pivot ( parent , nest, iloc, jloc )
+
+!==========================================================================================
+!
+! This program produces i_start and j_start for the nested domain depending on the
+! central lat-lon of the storm.
+!
+!==========================================================================================
+
+ USE module_domain
+ USE module_configure
+ USE module_timing
+ USE module_dm 
+
+ IMPLICIT NONE
+ TYPE(domain) , POINTER              :: parent , nest
+ INTEGER, INTENT(OUT)                :: ILOC,JLOC
+ INTEGER                             :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER                             :: IDS,IDE,JDS,JDE,KDS,KDE
+ INTEGER                             :: IMS,IME,JMS,JME,KMS,KME
+ INTEGER                             :: ITS,ITE,JTS,JTE,KTS,KTE
+ INTEGER                             :: NIDE,NJDE              ! nest dimension
+ INTEGER                             :: I,J,ITER,IDUM,JDUM
+ REAL                                :: ALAT,ALON,DIFF1,DIFF2,ERR
+ REAL                                :: parent_CLAT,parent_CLON,parent_SLAT,parent_SLON
+ REAL                                :: parent_WBD,parent_SBD,parent_DLMD,parent_DPHD 
+!========================================================================================
+
+!   First obtain central latitude and longitude for the parent domain
+
+    CALL nl_get_cen_lat (parent%ID, parent_CLAT)
+    CALL nl_get_cen_lon (parent%ID, parent_CLON)
+!    CALL nl_get_storm_lat (parent%ID, parent_SLAT)
+!    CALL nl_get_storm_lon (parent%ID, parent_SLON)
+
+!   Parent grid configuration, including, western and southern boundary
+
+    IDS = parent%sd31
+    IDE = parent%ed31
+    KDS = parent%sd32
+    KDE = parent%ed32
+    JDS = parent%sd33
+    JDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    KMS = parent%sm32
+    KME = parent%em32
+    JMS = parent%sm33
+    JME = parent%em33
+
+    ITS  = parent%sp31
+    ITE  = parent%ep31
+    KTS  = parent%sp32
+    KTE  = parent%ep32
+    JTS  = parent%sp33
+    JTE  = parent%ep33
+
+    NIDE = nest%ed31
+    NJDE = nest%ed33
+
+    parent_DLMD = parent%dx          ! DLMD: dlamda in degrees
+    parent_DPHD = parent%dy          ! DPHD: dphi in degrees
+    parent_WBD  = -(IDE-2)*parent%dx ! WBD0: in deg;factor 2 takes care of dummy last column 
+    parent_SBD  = -((JDE-1)/2)*parent%dy ! SBD0: in degrees; note that JDE-1 should be odd 
+    ALAT  = parent_SLAT - 0.5*(NJDE-2)*parent_DPHD/nest%parent_grid_ratio
+    ALON  = parent_SLON - 1.0*(NIDE-2)*parent_DLMD/nest%parent_grid_ratio
+
+!    WRITE(0,*)'ALAT AND ALON=',ALAT,ALON
+
+    CALL EARTH_LATLON ( parent%nmm_HLAT,parent%nmm_HLON,parent%nmm_VLAT,parent%nmm_VLON, & !output
+                        parent_DLMD,parent_DPHD,parent_WBD,parent_SBD,                   & !inputs
+                        parent_CLAT,parent_CLON,                                         &
+                        IDS,IDE,JDS,JDE,KDS,KDE,                                         &
+                        IMS,IME,JMS,JME,KMS,KME,                                         &
+                        ITS,ITE,JTS,JTE,KTS,KTE                          )
+
+!   start iteration
+
+      ILOC=-99
+      JLOC=-99
+      ERR=0.1
+      ITER=1
+100   CONTINUE
+
+     DO J = JTS,min(JTE,JDE-1)
+      DO I = ITS,min(ITE,IDE-1)
+        DIFF1 = ABS(ALAT - parent%nmm_HLAT(I,J))
+        DIFF2 = ABS(ALON - parent%nmm_HLON(I,J))
+        IF(DIFF1 .LE. ERR .AND. DIFF2 .LE. ERR)THEN
+         ILOC=I
+         JLOC=J
+!         WRITE(0,*)'ITERATED',ERR,ITER,I,J,parent%nmm_HLAT(I,J),ALAT,parent%nmm_HLON(I,J),ALON
+        ENDIF
+      ENDDO
+     ENDDO
+
+     CALL wrf_dm_maxval_integer ( ILOC, idum, jdum )
+     CALL wrf_dm_maxval_integer ( JLOC, idum, jdum ) 
+
+     IF(ILOC .EQ. -99 .AND. JLOC .EQ. -99)THEN
+       ERR=ERR+0.1
+       ITER=ITER+1
+       IF(ITER .LE. 100)GO TO 100
+     ENDIF
+
+     IF(ILOC .NE. -99 .AND. JLOC .NE. -99)THEN
+       WRITE(0,*)'NOTE: I_PARENT_START AND J_PARENT_START FOUND FOR THE NESTED DOMAIN CONFIGURATION AT ITER=',ITER
+       WRITE(0,*)'istart=',ILOC
+       WRITE(0,*)'jstart=',JLOC
+     ELSE
+       ILOC=IDE/3
+       JLOC=JDE/3
+!
+       WRITE(0,*)'WARNING: COULD NOT LOCATE I_PARENT_START AND J_PARENT_START FROM INPUT STORM INFO'
+       WRITE(0,*)'ISTART=',IDE/3
+       WRITE(0,*)'JSTART=',JDE/3
+     ENDIF
+
+     RETURN
+END SUBROUTINE initial_nest_pivot
+
+!============================================================================================
+#endif
+
+LOGICAL FUNCTION nmm_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
+   INTEGER, INTENT(IN) :: pig, ips_save, ipe_save , pjg, jps_save, jpe_save
+   LOGICAL, INTENT(IN) :: xstag, ystag
+
+   INTEGER ioff, joff
+
+   ioff = 0 ; joff = 0
+   IF ( xstag  ) ioff = 1
+   IF ( ystag  ) joff = 1
+
+   nmm_cd_feedback_mask = ( pig .ge. ips_save+1        .and.      &
+                            pjg .ge. jps_save+1        .and.      &
+                            pig .le. ipe_save-1  +ioff .and.      &
+                            pjg .le. jpe_save-1  +joff           )
+
+END FUNCTION nmm_cd_feedback_mask
+
+!----------------------------------------------------------------------------
+#else
+SUBROUTINE stub_nmm_nest_stub
+END SUBROUTINE stub_nmm_nest_stub
+#endif
+
+RECURSIVE SUBROUTINE find_ijstart_level ( grid, i_start, j_start, level )
+
+! Dusan Jovic
+
+   USE module_domain
+
+   IMPLICIT NONE
+
+   !  Input data.
+
+   TYPE(domain) :: grid
+   INTEGER, INTENT (OUT) :: i_start, j_start, level
+   INTEGER :: iadd
+
+      if (grid%parent_id == 0 ) then
+         i_start = 1
+         j_start = 1
+         level = 0
+      else
+         call find_ijstart_level ( grid%parents(1)%ptr, i_start, j_start, level )
+         if (level > 0) then
+             iadd = (i_start-1)*3
+             if ( mod(j_start,2).ne.0 .and. mod(grid%j_parent_start,2).ne.0 ) iadd = iadd - 1
+             if ( mod(j_start,2).eq.0 .and. mod(grid%j_parent_start,2).eq.0 ) iadd = iadd + 2
+         else
+             iadd = -mod(grid%j_parent_start,2)
+         end if
+         i_start = iadd + grid%i_parent_start*3 - 1
+         j_start = ( (j_start-1) + (grid%j_parent_start-1) ) * 3 + 1
+         level = level + 1
+      end if
+
+END SUBROUTINE find_ijstart_level
diff --git a/wrfv2_fire/dyn_nmm/RDTEMP.F b/wrfv2_fire/dyn_nmm/RDTEMP.F
new file mode 100644
index 00000000..a2482b0a
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/RDTEMP.F
@@ -0,0 +1,139 @@
+!
+!NCEP_MESO:MODEL_LAYER: PHYSICS
+!
+!***********************************************************************
+      SUBROUTINE RDTEMP(NTSD,DT,JULDAY,JULYR,IHRST,GLAT,GLON            &
+     &                 ,CZEN,CZMEAN,T,RSWTT,RLWTT,HTM,HBM2              &
+     &                 ,IDS,IDE,JDS,JDE,KDS,KDE                         &
+     &                 ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                 ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    RDTEMP      RADIATIVE TEMPERATURE CHANGE
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 93-12-29
+!     
+! ABSTRACT:
+!     RDTEMP APPLIES THE TEMPERATURE TENDENCIES DUE TO
+!     RADIATION AT ALL LAYERS AT EACH ADJUSTMENT TIME STEP
+!     
+! PROGRAM HISTORY LOG:
+!   87-09-??  BLACK      - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   95-11-20  ABELES     - PARALLEL OPTIMIZATION
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   02-06-07  BLACK      - WRF CODING STANDARDS
+!   02-09-09  WOLFE      - CONVERTING TO GLOBAL INDEXING
+!     
+! USAGE: CALL RDTEMP FROM SUBROUTINE SOLVE_RUNSTREAM
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!-----------------------------------------------------------------------
+      USE MODULE_MPP
+      USE MODULE_RA_GFDLETA,ONLY : CAL_MON_DAY,ZENITH
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,INTENT(IN) :: IHRST,JULDAY,JULYR,NTSD
+!
+      REAL,INTENT(IN) :: DT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZMEAN,GLAT,GLON    &
+     &                                             ,HBM2
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM         &
+     &                                                     ,RLWTT       &
+     &                                                     ,RSWTT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CZEN
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,JDAY,JMONTH,K
+!
+      INTEGER,DIMENSION(3) :: IDAT
+!
+      REAL :: DAYI,HOUR,TIMES,TTNDKL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CZEN2,XLAT2,XLON2
+!
+      REAL,DIMENSION(ITS:ITE,JTS:JTE) :: FACTR
+!
+      REAL :: DEGRAD=3.1415926/180.
+      real :: xlat1,xlon1
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      MYIS=MAX(IDS,ITS)
+      MYIE=MIN(IDE,ITE)
+      MYJS=MAX(JDS,JTS)
+      MYJE=MIN(JDE,JTE)
+!-----------------------------------------------------------------------
+!
+!***  GET CURRENT VALUE OF COS(ZENITH ANGLE)
+!
+      TIMES=NTSD*DT
+!
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        XLAT2(I,J)=GLAT(I,J)
+        XLON2(I,J)=GLON(I,J)
+!!!!!!!!!!!!Remove the following lines after bit-correct answers
+!!!!!!!!!!!!are established with the control
+!       xlat1=glat(i,j)/degrad
+!       xlat2(i,j)=xlat1*degrad
+!       xlon1=glon(i,j)/degrad
+!       xlon2(i,j)=xlon1*degrad
+!!!!!!!!!!!!
+!!!!!!!!!!!!
+      ENDDO
+      ENDDO
+!
+      CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
+
+      IDAT(1)=JMONTH
+      IDAT(2)=JDAY
+      IDAT(3)=JULYR
+!
+      CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,XLON2,XLAT2,CZEN2          &
+     &           ,MYIS,MYIE,MYJS,MYJE                                   &
+     &           ,IDS,IDE,JDS,JDE,KDS,KDE                               &
+     &           ,IMS,IME,JMS,JME,KMS,KME                               &
+     &           ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        CZEN(I,J)=CZEN2(I,J)
+        IF(CZMEAN(I,J).GT.0.)THEN 
+          FACTR(I,J)=CZEN(I,J)/CZMEAN(I,J)
+        ELSE
+          FACTR(I,J)=0.
+        ENDIF
+      ENDDO
+      ENDDO
+!
+      DO J=MYJS,MYJE
+        DO K=KTS,KTE
+        DO I=MYIS,MYIE
+          TTNDKL=RSWTT(I,K,J)*FACTR(I,J)+RLWTT(I,K,J)
+          T(I,K,J)=T(I,K,J)+TTNDKL*DT*HTM(I,K,J)*HBM2(I,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE RDTEMP
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/adve_optim.h b/wrfv2_fire/dyn_nmm/adve_optim.h
new file mode 100644
index 00000000..313fb4c3
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/adve_optim.h
@@ -0,0 +1,1173 @@
+!*********************************************************************** 
+      SUBROUTINE ADVE(NTSD,DT,DETA1,DETA2,PDTOP                         &
+     &               ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX,DY        &
+     &               ,HTM,HBM2,VTM,VBM2,LMH,LMV                         &
+     &               ,T,U,V,PDSLO,TOLD,UOLD,VOLD                        &
+     &               ,PETDT,UPSTRM                                      &
+     &               ,FEW,FNS,FNE,FSE                                   &
+     &               ,ADT,ADU,ADV                                       &
+     &               ,N_IUP_H,N_IUP_V                                   &
+     &               ,N_IUP_ADH,N_IUP_ADV                               &
+     &               ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                       &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    ADVE        HORIZONTAL AND VERTICAL ADVECTION
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 93-10-28       
+!     
+! ABSTRACT:
+!     ADVE CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
+!     ADVECTION TO THE TENDENCIES OF TEMPERATURE AND WIND AND THEN
+!     UPDATES THOSE VARIABLES.
+!     THE JANJIC ADVECTION SCHEME FOR THE ARAKAWA E GRID IS USED
+!     FOR ALL VARIABLES INSIDE THE FIFTH ROW.  AN UPSTREAM SCHEME
+!     IS USED ON ALL VARIABLES IN THE THIRD, FOURTH, AND FIFTH
+!     OUTERMOST ROWS.  THE ADAMS-BASHFORTH TIME SCHEME IS USED.
+!     
+! PROGRAM HISTORY LOG:
+!   87-06-??  JANJIC     - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   96-03-28  BLACK      - ADDED EXTERNAL EDGE
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   99-07-    JANJIC     - CONVERTED TO ADAMS-BASHFORTH SCHEME
+!                          COMBINING HORIZONTAL AND VERTICAL ADVECTION
+!   02-02-04  BLACK      - ADDED VERTICAL CFL CHECK
+!   02-02-05  BLACK      - CONVERTED TO WRF FORMAT
+!   02-08-29  MICHALAKES - CONDITIONAL COMPILATION OF MPI
+!                          CONVERT TO GLOBAL INDEXING
+!   02-09-06  WOLFE      - MORE CONVERSION TO GLOBAL INDEXING
+!   04-05-29  JANJIC,BLACK - CRANK-NICHOLSON VERTICAL ADVECTION
+!     
+! USAGE: CALL ADVE FROM SUBROUTINE SOLVE_RUNSTREAM
+!   INPUT ARGUMENT LIST:
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV  &
+     &                                                ,LMH,LMV
+!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,DY,EN,ENT,F4D,PDTOP
+!
+      REAL,DIMENSION(NMM_MAX_DIM),INTENT(IN) :: EM_LOC,EMT_LOC
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CURV,DX,F,FAD,HBM2  &
+     &                                             ,PDSLO,VBM2
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,VTM
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T,TOLD   &
+     &                                                        ,U,UOLD   &
+     &                                                        ,V,VOLD
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: ADT,ADU    &
+     &                                                      ,ADV        &
+     &                                                      ,FEW,FNE    &
+     &                                                      ,FNS,FSE
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      LOGICAL :: UPSTRM
+!
+      INTEGER :: I,IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART                   &
+     &          ,IUP_ADH_J,IVH,IVL                                      &
+     &          ,J,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART            &
+     &          ,K,KNTI_ADH,KSTART,KSTOP,LMHK,LMVK                      &
+     &          ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
+!
+      INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
+!
+      INTEGER :: J0_P3,J0_P2,J0_P1,J0_00,J0_M1,J1_P2,J1_P1,J1_00,J1_M1  &
+     &          ,J2_P1,J2_00,J2_M1,J3_P2,J3_P1,J3_00                    &
+     &          ,J4_P1,J4_00,J4_M1,J5_00,J5_M1,J6_P1,J6_00
+!
+      INTEGER,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ISPA,ISQA
+!
+      REAL :: ARRAY3_X,CFT,CFU,CFV,CMT,CMU,CMV                          &
+     &       ,DPDE_P3,DTE,DTQ                                           &
+     &       ,F0,F1,F2,F3,FEW_00,FEW_P1,FNE_X,FNS_P1,FNS_X,FPP,FSE_X    &
+     &       ,HM,PDOP,PDOPU,PDOPV,PP                                    &
+     &       ,PVVLO,PVVLOU,PVVLOV,PVVUP,PVVUPU,PVVUPV                   &
+     &       ,QP,RDP,RDPD,RDPDX,RDPDY,RDPU,RDPV                         &
+     &       ,T_UP,TEMPA,TEMPB,TTA,TTB,U_UP,UDY_P1,UDY_X                &
+     &       ,VXD_X,VDX_P2,V_UP,VDX_X,VM,VTA,VUA,VVA                    &
+     &       ,VVLO,VVLOU,VVLOV,VVUP,VVUPU,VVUPV
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: ARRAY0,ARRAY1              &
+     &                                      ,ARRAY2,ARRAY3              &
+     &                                      ,VAD_TEND_T,VAD_TEND_U      &
+     &                                      ,VAD_TEND_V
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: TEW,UEW,VEW
+!
+      REAL,DIMENSION(KTS:KTE) :: CRT,CRU,CRV,DETA1_PDTOP                &
+     &                          ,RCMT,RCMU,RCMV,RSTT,RSTU,RSTV,TN,UN    &
+     &                          ,VAD_TNDX_T,VAD_TNDX_U,VAD_TNDX_V,VN
+!
+      REAL,DIMENSION(ITS-5:ITE+5,-1:1) :: PETDTK
+!
+      REAL,DIMENSION(ITS-5:ITE+5) :: TDN,UDN,VDN
+!
+!-----------------------------------------------------------------------
+!
+!***  TYPE 0 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-3:3) :: DPDE
+!
+!***  TYPE 1 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-2:2) :: TST,UDY,UST,VDX,VST
+!
+!***  TYPE 4 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:1) :: TNS,UNS,VNS
+!
+!***  TYPE 5 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KMS:KME,-1:0) :: TNE,UNE,VNE
+!
+!***  TYPE 6 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KMS:KME, 0:1) :: TSE,USE,VSE
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***********************************************************************
+!
+!                         DPDE      -----  3
+!                          |                      J Increasing
+!                          |                        
+!                          |                            ^
+!                         FNS       -----  2            |
+!                          |                            |
+!                          |                            |
+!                          |                            |
+!                         VNS       -----  1            |
+!                          |
+!                          |
+!                          |
+!                         ADV       -----  0  ------> Current J
+!                          |
+!                          |
+!                          |
+!                         VNS       ----- -1
+!                          |
+!                          |
+!                          |
+!                         FNS       ----- -2
+!                          |
+!                          |
+!                          |
+!                         DPDE      ----- -3
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      ISTART=MYIS_P2
+      IEND=MYIE_P2 
+      IF(ITE==IDE)IEND=MYIE-3 
+!
+      DTQ=DT*0.25
+      DTE=DT*(0.5*0.25)
+!***
+!***  INITIALIZE SOME WORKING ARRAYS TO ZERO
+!***
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        TEW(I,K)=0.
+        UEW(I,K)=0.
+        VEW(I,K)=0.
+      ENDDO
+      ENDDO
+!
+!***  TYPE 0
+!
+      DO N=-3,3
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          DPDE(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPE 1
+!
+      DO N=-2,2
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TST(I,K,N)=0.
+          UST(I,K,N)=0.
+          VST(I,K,N)=0.
+          UDY(I,K,N)=0.
+          VDX(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPES 5 AND 6
+!
+      DO N=-1,0
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TNE(I,K,N)=0.
+          TSE(I,K,N+1)=0.
+          UNE(I,K,N)=0.
+          USE(I,K,N+1)=0.
+          VNE(I,K,N)=0.
+          VSE(I,K,N+1)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  PRECOMPUTE DETA1 TIMES PDTOP.
+!***
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        DETA1_PDTOP(K)=DETA1(K)*PDTOP
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  WE NEED THE STARTING AND ENDING J FOR THIS TASK'S INTEGRATION
+!***
+      JSTART=MYJS2
+      JEND=MYJE2
+!
+!
+!-----------------------------------------------------------------------
+!
+!***  START THE HORIZONTAL ADVECTION IN THE INITIAL SOUTHERN SLABS.
+!
+!-----------------------------------------------------------------------
+!
+      DO J=-2,1
+        JJ=JSTART+J
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          TST(I,K,J)=T(I,K,JJ)*FFC+TOLD(I,K,JJ)*FBC
+          UST(I,K,J)=U(I,K,JJ)*FFC+UOLD(I,K,JJ)*FBC
+          VST(I,K,J)=V(I,K,JJ)*FFC+VOLD(I,K,JJ)*FBC
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
+!***  ONLY THE NORTHERNMOST OF EACH OF THE WORKING ARRAYS WILL BE
+!***  FILLED IN THE PRIMARY INTEGRATION SECTION.
+!-----------------------------------------------------------------------
+!
+      J1=-3
+      IF(JTS==JDS)J1=-2  ! Cannot go 3 south from J=2 for south tasks
+!
+      DO J=J1,2
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,K,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,JJ)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,1
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          UDY(I,K,J)=U(I,K,JJ)*DY
+          VDX_X=V(I,K,JJ)*DX(I,JJ)
+          FNS(I,K,JJ)=VDX_X*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
+          VDX(I,K,J)=VDX_X
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,0
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPA=(UDY(I+IHE(JJ),K,J)+VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J+1)      +VDX(I,K,J+1))
+          FNE(I,K,JJ)=TEMPA*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,1
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPB=(UDY(I+IHE(JJ),K,J)-VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J-1)      -VDX(I,K,J-1))
+          FSE(I,K,JJ)=TEMPB*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,0
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS1_P3,MYIE1_P3
+          FNS_X=FNS(I,K,JJ)
+          TNS(I,K,J)=FNS_X*(TST(I,K,J+1)-TST(I,K,J-1))
+!
+          UDY_X=U(I,K,JJ)*DY
+          FEW(I,K,JJ)=UDY_X*(DPDE(I+IVW(JJ),K,J)+DPDE(I+IVE(JJ),K,J))   
+        ENDDO
+        ENDDO
+!
+        DO K=KTS,KTE
+        DO I=MYIS1_P4,MYIE1_P4
+          UNS(I,K,J)=(FNS(I+IHW(JJ),K,JJ)+FNS(I+IHE(JJ),K,JJ))          &
+     &              *(UST(I,K,J+1)-UST(I,K,J-1))
+          VNS(I,K,J)=(FNS(I,K,JJ-1)+FNS(I,K,JJ+1))                      &
+     &              *(VST(I,K,J+1)-VST(I,K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      JJ=JSTART-1
+!
+      DO K=KTS,KTE
+      DO I=MYIS1_P2,MYIE1_P2
+        FNE_X=FNE(I,K,JJ)
+        TNE(I,K,-1)=FNE_X*(TST(I+IHE(JJ),K,0)-TST(I,K,-1))
+!
+        FSE_X=FSE(I,K,JJ+1)
+        TSE(I,K,0)=FSE_X*(TST(I+IHE(JJ+1),K,-1)-TST(I,K,0))
+!
+        UNE(I,K,-1)=(FNE(I+IVW(JJ),K,JJ)+FNE(I+IVE(JJ),K,JJ))           &
+     &             *(UST(I+IVE(JJ),K,0)-UST(I,K,-1))
+        USE(I,K,0)=(FSE(I+IVW(JJ+1),K,JJ+1)+FSE(I+IVE(JJ+1),K,JJ+1))    &
+     &            *(UST(I+IVE(JJ+1),K,-1)-UST(I,K,0))
+        VNE(I,K,-1)=(FNE(I,K,JJ-1)+FNE(I,K,JJ+1))                       &
+     &             *(VST(I+IVE(JJ),K,0)-VST(I,K,-1))
+        VSE(I,K,0)=(FSE(I,K,JJ)+FSE(I,K,JJ+2))                          &
+     &            *(VST(I+IVE(JJ+1),K,-1)-VST(I,K,0))
+      ENDDO
+      ENDDO
+!
+      JKNT=0
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      main_integration : DO J=JSTART,JEND
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND PFDHT DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P3 denotes +3, M1 denotes -1, etc.)
+!***
+
+!
+! John and Tom both think this is all right, even for tiles,
+! as long as the slab arrays being indexed by these things
+! are locally defined.
+!
+      JKNT=JKNT+1
+!
+      J0_P3=INDX3_WRK(3,JKNT,0)
+      J0_P2=INDX3_WRK(2,JKNT,0)
+      J0_P1=INDX3_WRK(1,JKNT,0)
+      J0_00=INDX3_WRK(0,JKNT,0)
+      J0_M1=INDX3_WRK(-1,JKNT,0)
+!
+      J1_P2=INDX3_WRK(2,JKNT,1)
+      J1_P1=INDX3_WRK(1,JKNT,1)
+      J1_00=INDX3_WRK(0,JKNT,1)
+      J1_M1=INDX3_WRK(-1,JKNT,1)
+!
+      J2_P1=INDX3_WRK(1,JKNT,2)
+      J2_00=INDX3_WRK(0,JKNT,2)
+      J2_M1=INDX3_WRK(-1,JKNT,2)
+!
+      J3_P2=INDX3_WRK(2,JKNT,3)
+      J3_P1=INDX3_WRK(1,JKNT,3)
+      J3_00=INDX3_WRK(0,JKNT,3)
+!
+      J4_P1=INDX3_WRK(1,JKNT,4)
+      J4_00=INDX3_WRK(0,JKNT,4)
+      J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+      J5_00=INDX3_WRK(0,JKNT,5)
+      J5_M1=INDX3_WRK(-1,JKNT,5)
+!
+      J6_P1=INDX3_WRK(1,JKNT,6)
+      J6_00=INDX3_WRK(0,JKNT,6)
+!
+      MY_IS_GLB=1  ! make this a noop for global indexing
+      MY_IE_GLB=1  ! make this a noop for global indexing
+      MY_JS_GLB=1  ! make this a noop for global indexing
+      MY_JE_GLB=1  ! make this a noop for global indexing
+!  
+!-----------------------------------------------------------------------
+!***  THE WORKING ARRAYS FOR THE PRIMARY VARIABLES
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P4,MYIE_P4
+        TST(I,K,J1_P2)=T(I,K,J+2)*FFC+TOLD(I,K,J+2)*FBC
+        UST(I,K,J1_P2)=U(I,K,J+2)*FFC+UOLD(I,K,J+2)*FBC
+        VST(I,K,J1_P2)=V(I,K,J+2)*FFC+VOLD(I,K,J+2)*FBC
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P4,MYIE_P4
+!
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
+!***  FOR T.
+!-----------------------------------------------------------------------
+!
+        DPDE_P3=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J+3)
+        DPDE(I,K,J0_P3)=DPDE_P3
+!
+!-----------------------------------------------------------------------
+        UDY(I,K,J1_P2)=U(I,K,J+2)*DY
+        VDX_P2=V(I,K,J+2)*DX(I,J+2)
+        VDX(I,K,J1_P2)=VDX_P2
+        FNS(I,K,J+2)=VDX_P2*(DPDE(I,K,J0_P1)+DPDE_P3)
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO K=KTS,KTE
+      DO I=MYIS_P3,MYIE_P3
+        TEMPA=(UDY(I+IHE(J+1),K,J1_P1)+VDX(I+IHE(J+1),K,J1_P1))         &
+     &       +(UDY(I,K,J1_P2)         +VDX(I,K,J1_P2))
+        FNE(I,K,J+1)=TEMPA*(DPDE(I,K,J0_P1)+DPDE(I+IHE(J+1),K,J0_P2))
+!
+!-----------------------------------------------------------------------
+        TEMPB=(UDY(I+IHE(J+2),K,J1_P2)-VDX(I+IHE(J+2),K,J1_P2))         &
+     &       +(UDY(I,K,J1_P1)         -VDX(I,K,J1_P1))
+        FSE(I,K,J+2)=TEMPB*(DPDE(I,K,J0_P2)+DPDE(I+IHE(J),K,J0_P1))
+!
+!-----------------------------------------------------------------------
+        FNS_P1=FNS(I,K,J+1)
+        TNS(I,K,J4_P1)=FNS_P1*(TST(I,K,J1_P2)-TST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+        UDY_P1=U(I,K,J+1)*DY
+        FEW(I,K,J+1)=UDY_P1*(DPDE(I+IVW(J+1),K,J0_P1)                   &
+     &                        +DPDE(I+IVE(J+1),K,J0_P1))
+        FEW_00=FEW(I,K,J)
+        TEW(I,K)=FEW_00*(TST(I+IVE(J),K,J1_00)-TST(I+IVW(J),K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
+!***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
+!-----------------------------------------------------------------------
+!
+        FNE_X=FNE(I,K,J)
+        TNE(I,K,J5_00)=FNE_X*(TST(I+IHE(J),K,J1_P1)-TST(I,K,J1_00))
+!
+        FSE_X=FSE(I,K,J+1)
+        TSE(I,K,J6_P1)=FSE_X*(TST(I+IHE(J+1),K,J1_00)-TST(I,K,J1_P1))
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  CALCULATION OF MOMENTUM ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE_P2
+        UEW(I,K)=(FEW(I+IHW(J),K,J)+FEW(I+IHE(J),K,J))                  &
+     &          *(UST(I+IHE(J),K,J1_00)-UST(I+IHW(J),K,J1_00))
+        UNS(I,K,J4_P1)=(FNS(I+IHW(J+1),K,J+1)                           &
+     &                 +FNS(I+IHE(J+1),K,J+1))                          &
+     &                *(UST(I,K,J1_P2)-UST(I,K,J1_00))
+        VEW(I,K)=(FEW(I,K,J-1)+FEW(I,K,J+1))                            &
+     &          *(VST(I+IHE(J),K,J1_00)-VST(I+IHW(J),K,J1_00))
+        VNS(I,K,J4_P1)=(FNS(I,K,J)+FNS(I,K,J+2))                        &
+     &                *(VST(I,K,J1_P2)-VST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
+!***  LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
+!-----------------------------------------------------------------------
+!
+        UNE(I,K,J5_00)=(FNE(I+IVW(J),K,J)+FNE(I+IVE(J),K,J))            &
+     &                *(UST(I+IVE(J),K,J1_P1)-UST(I,K,J1_00))
+        USE(I,K,J6_P1)=(FSE(I+IVW(J+1),K,J+1)                           &
+     &                 +FSE(I+IVE(J+1),K,J+1))                          &
+     &                *(UST(I+IVE(J+1),K,J1_00)-UST(I,K,J1_P1))
+        VNE(I,K,J5_00)=(FNE(I,K,J-1)+FNE(I,K,J+1))                      &
+     &                *(VST(I+IVE(J),K,J1_P1)-VST(I,K,J1_00))
+        VSE(I,K,J6_P1)=(FSE(I,K,J)+FSE(I,K,J+2))                        &
+     &                *(VST(I+IVE(J+1),K,J1_00)-VST(I,K,J1_P1))
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR T.
+!***  THE AD ARRAYS ARE ON H POINTS.
+!***  SKIP TO UPSTREAM IF THESE ROWS HAVE ONLY UPSTREAM POINTS.
+!-----------------------------------------------------------------------
+!
+      
+      JGLOBAL=J+MY_JS_GLB-1
+      IF(JGLOBAL>=6.AND.JGLOBAL<=JDE-5)THEN
+!
+        JJ=J+MY_JS_GLB-1   ! okay because MY_JS_GLB is 1
+        IF(ITS==IDS)ISTART=3+MOD(JJ,2)  ! need to think about this
+                                        ! more in terms of how to 
+                                        ! convert to global indexing
+!
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPD=1./DPDE(I,K,J0_00)
+!
+          ADT(I,K,J)=(TEW(I+IHW(J),K)+TEW(I+IHE(J),K)                   &
+     &               +TNS(I,K,J4_M1)+TNS(I,K,J4_P1)                     &
+     &               +TNE(I+IHW(J),K,J5_M1)+TNE(I,K,J5_00)              &
+     &               +TSE(I,K,J6_00)+TSE(I+IHW(J),K,J6_P1))             &
+     &               *RDPD*FAD(I,J)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
+!***  THE AD ARRAYS ARE ON VELOCITY POINTS.
+!-----------------------------------------------------------------------
+!
+        IF(ITS==IDS)ISTART=3+MOD(JJ+1,2)
+!
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPDX=1./(DPDE(I+IVW(J),K,J0_00)+DPDE(I+IVE(J),K,J0_00))
+          RDPDY=1./(DPDE(I,K,J0_M1)+DPDE(I,K,J0_P1))
+!
+          ADU(I,K,J)=(UEW(I+IVW(J),K)+UEW(I+IVE(J),K)                   &
+     &               +UNS(I,K,J4_M1)+UNS(I,K,J4_P1)                     &
+     &               +UNE(I+IVW(J),K,J5_M1)+UNE(I,K,J5_00)              &
+     &               +USE(I,K,J6_00)+USE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDX*FAD(I+IVW(J),J)
+!
+          ADV(I,K,J)=(VEW(I+IVW(J),K)+VEW(I+IVE(J),K)                   &
+     &               +VNS(I,K,J4_M1)+VNS(I,K,J4_P1)                     &
+     &               +VNE(I+IVW(J),K,J5_M1)+VNE(I,K,J5_00)              &
+     &               +VSE(I,K,J6_00)+VSE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDY*FAD(I+IVW(J),J)
+!
+        ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  END OF JANJIC HORIZONTAL ADVECTION 
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  UPSTREAM ADVECTION OF T, U, AND V
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      upstream : IF(UPSTRM)THEN
+!
+!-----------------------------------------------------------------------
+!***
+!***  COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
+!***
+!-----------------------------------------------------------------------
+!
+          N_IUPH_J=N_IUP_H(J)   ! See explanation in INIT
+!
+          DO K=KTS,KTE
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+              TTA=EMT_LOC(J)*(UST(I,K,J1_M1)+UST(I+IHW(J),K,J1_00)      &
+     &                       +UST(I+IHE(J),K,J1_00)+UST(I,K,J1_P1))
+              TTB=ENT       *(VST(I,K,J1_M1)+VST(I+IHW(J),K,J1_00)      &
+     &                       +VST(I+IHE(J),K,J1_00)+VST(I,K,J1_P1))
+              PP=-TTA-TTB
+              QP= TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISPA(I,K)=-1
+              ELSE
+                ISPA(I,K)= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQA(I,K)=-1
+              ELSE
+                ISQA(I,K)= 1
+              ENDIF
+!
+              PP=ABS(PP)
+              QP=ABS(QP)
+              ARRAY3_X=PP*QP
+              ARRAY0(I,K)=ARRAY3_X-PP-QP
+              ARRAY1(I,K)=PP-ARRAY3_X
+              ARRAY2(I,K)=QP-ARRAY3_X
+              ARRAY3(I,K)=ARRAY3_X
+            ENDDO
+!
+          ENDDO
+!-----------------------------------------------------------------------
+!
+          N_IUPADH_J=N_IUP_ADH(J) 
+!
+          DO K=KTS,KTE
+!
+            KNTI_ADH=1
+            IUP_ADH_J=IUP_ADH(IMS,J)
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+!
+              ISP=ISPA(I,K)
+              ISQ=ISQA(I,K)
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          *HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          *HTM(I+IPQ,K,J+ISP+ISQ)>0.1)THEN
+                 GO TO 150
+              ENDIF
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          +HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          +HTM(I+IPQ,K,J+ISP+ISQ)<0.1)THEN 
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I,K,J)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+     &         <0.99)THEN
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFQ,K,J+ISQ)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+               <0.99)THEN
+!
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)                                &
+     &        +HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=0.5*(T(I,K,J)                   &
+     &                                      +T(I+IPQ,K,J+ISP+ISQ))
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF(HTM(I+IHE(J)+IFP,K,J+ISP)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF(HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSE
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)            &
+     &                              +T(I+IHE(J)+IFQ,K,J+ISQ)            &
+     &                              -T(I,K,J)
+!
+              ENDIF
+!
+  150         CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+              IF(I==IUP_ADH_J)THEN  ! Update advection H tendencies
+!
+                ISP=ISPA(I,K)
+                ISQ=ISQA(I,K)
+                IFP=(ISP-1)/2
+                IFQ=(-ISQ-1)/2
+                IPQ=(ISP-ISQ)/2
+!
+                F0=ARRAY0(I,K)
+                F1=ARRAY1(I,K)
+                F2=ARRAY2(I,K)
+                F3=ARRAY3(I,K)
+!
+                ADT(I,K,J)=F0*T(I,K,J)                                  &
+     &                    +F1*T(I+IHE(J)+IFP,K,J+ISP)                   &
+     &                    +F2*T(I+IHE(J)+IFQ,K,J+ISQ)                   &
+                          +F3*T(I+IPQ,K,J+ISP+ISQ)
+!
+!-----------------------------------------------------------------------
+!
+                IF(KNTI_ADH Current J
+!                          |
+!                          |
+!                          |
+!                         VNS       ----- -1
+!                          |
+!                          |
+!                          |
+!                         FNS       ----- -2
+!                          |
+!                          |
+!                          |
+!                         DPDE      ----- -3
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      ISTART=MYIS_P2
+      IEND=MYIE_P2 
+      IF(ITE==IDE)IEND=MYIE-3 
+!
+      DTQ=DT*0.25
+      DTE=DT*(0.5*0.25)
+!***
+!***  INITIALIZE SOME WORKING ARRAYS TO ZERO
+!***
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        TEW(I,K)=0.
+        UEW(I,K)=0.
+        VEW(I,K)=0.
+      ENDDO
+      ENDDO
+!
+!***  TYPE 0
+!
+      DO N=-3,3
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          DPDE(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPE 1
+!
+      DO N=-2,2
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TST(I,K,N)=0.
+          UST(I,K,N)=0.
+          VST(I,K,N)=0.
+          UDY(I,K,N)=0.
+          VDX(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPES 5 AND 6
+!
+      DO N=-1,0
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TNE(I,K,N)=0.
+          TSE(I,K,N+1)=0.
+          UNE(I,K,N)=0.
+          USE(I,K,N+1)=0.
+          VNE(I,K,N)=0.
+          VSE(I,K,N+1)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  PRECOMPUTE DETA1 TIMES PDTOP.
+!***
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        DETA1_PDTOP(K)=DETA1(K)*PDTOP
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  WE NEED THE STARTING AND ENDING J FOR THIS TASK'S INTEGRATION
+!***
+      JSTART=MYJS2
+      JEND=MYJE2
+!
+!
+!-----------------------------------------------------------------------
+!
+!***  START THE HORIZONTAL ADVECTION IN THE INITIAL SOUTHERN SLABS.
+!
+!-----------------------------------------------------------------------
+!
+      DO J=-2,1
+        JJ=JSTART+J
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          TST(I,K,J)=T(I,K,JJ)*FFC+TOLD(I,K,JJ)*FBC
+          UST(I,K,J)=U(I,K,JJ)*FFC+UOLD(I,K,JJ)*FBC
+          VST(I,K,J)=V(I,K,JJ)*FFC+VOLD(I,K,JJ)*FBC
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
+!***  ONLY THE NORTHERNMOST OF EACH OF THE WORKING ARRAYS WILL BE
+!***  FILLED IN THE PRIMARY INTEGRATION SECTION.
+!-----------------------------------------------------------------------
+!
+      J1=-3
+      IF(JTS==JDS)J1=-2  ! Cannot go 3 south from J=2 for south tasks
+!
+      DO J=J1,2
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,K,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,JJ)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,1
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          UDY(I,K,J)=U(I,K,JJ)*DY
+          VDX_X=V(I,K,JJ)*DX(I,JJ)
+          FNS(I,K,JJ)=VDX_X*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
+          VDX(I,K,J)=VDX_X
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,0
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPA=(UDY(I+IHE(JJ),K,J)+VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J+1)      +VDX(I,K,J+1))
+          FNE(I,K,JJ)=TEMPA*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,1
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPB=(UDY(I+IHE(JJ),K,J)-VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J-1)      -VDX(I,K,J-1))
+          FSE(I,K,JJ)=TEMPB*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,0
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+        DO I=MYIS1_P3,MYIE1_P3
+          FNS_X=FNS(I,K,JJ)
+          TNS(I,K,J)=FNS_X*(TST(I,K,J+1)-TST(I,K,J-1))
+!
+          UDY_X=U(I,K,JJ)*DY
+          FEW(I,K,JJ)=UDY_X*(DPDE(I+IVW(JJ),K,J)+DPDE(I+IVE(JJ),K,J))   
+        ENDDO
+        ENDDO
+!
+        DO K=KTS,KTE
+        DO I=MYIS1_P4,MYIE1_P4
+          UNS(I,K,J)=(FNS(I+IHW(JJ),K,JJ)+FNS(I+IHE(JJ),K,JJ))          &
+     &              *(UST(I,K,J+1)-UST(I,K,J-1))
+          VNS(I,K,J)=(FNS(I,K,JJ-1)+FNS(I,K,JJ+1))                      &
+     &              *(VST(I,K,J+1)-VST(I,K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      JJ=JSTART-1
+!
+      DO K=KTS,KTE
+      DO I=MYIS1_P2,MYIE1_P2
+        FNE_X=FNE(I,K,JJ)
+        TNE(I,K,-1)=FNE_X*(TST(I+IHE(JJ),K,0)-TST(I,K,-1))
+!
+        FSE_X=FSE(I,K,JJ+1)
+        TSE(I,K,0)=FSE_X*(TST(I+IHE(JJ+1),K,-1)-TST(I,K,0))
+!
+        UNE(I,K,-1)=(FNE(I+IVW(JJ),K,JJ)+FNE(I+IVE(JJ),K,JJ))           &
+     &             *(UST(I+IVE(JJ),K,0)-UST(I,K,-1))
+        USE(I,K,0)=(FSE(I+IVW(JJ+1),K,JJ+1)+FSE(I+IVE(JJ+1),K,JJ+1))    &
+     &            *(UST(I+IVE(JJ+1),K,-1)-UST(I,K,0))
+        VNE(I,K,-1)=(FNE(I,K,JJ-1)+FNE(I,K,JJ+1))                       &
+     &             *(VST(I+IVE(JJ),K,0)-VST(I,K,-1))
+        VSE(I,K,0)=(FSE(I,K,JJ)+FSE(I,K,JJ+2))                          &
+     &            *(VST(I+IVE(JJ+1),K,-1)-VST(I,K,0))
+      ENDDO
+      ENDDO
+!
+      JKNT=0
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      main_integration : DO J=JSTART,JEND
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND PFDHT DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P3 denotes +3, M1 denotes -1, etc.)
+!***
+
+!
+! John and Tom both think this is all right, even for tiles,
+! as long as the slab arrays being indexed by these things
+! are locally defined.
+!
+      JKNT=JKNT+1
+!
+      J0_P3=INDX3_WRK(3,JKNT,0)
+      J0_P2=INDX3_WRK(2,JKNT,0)
+      J0_P1=INDX3_WRK(1,JKNT,0)
+      J0_00=INDX3_WRK(0,JKNT,0)
+      J0_M1=INDX3_WRK(-1,JKNT,0)
+!
+      J1_P2=INDX3_WRK(2,JKNT,1)
+      J1_P1=INDX3_WRK(1,JKNT,1)
+      J1_00=INDX3_WRK(0,JKNT,1)
+      J1_M1=INDX3_WRK(-1,JKNT,1)
+!
+      J2_P1=INDX3_WRK(1,JKNT,2)
+      J2_00=INDX3_WRK(0,JKNT,2)
+      J2_M1=INDX3_WRK(-1,JKNT,2)
+!
+      J3_P2=INDX3_WRK(2,JKNT,3)
+      J3_P1=INDX3_WRK(1,JKNT,3)
+      J3_00=INDX3_WRK(0,JKNT,3)
+!
+      J4_P1=INDX3_WRK(1,JKNT,4)
+      J4_00=INDX3_WRK(0,JKNT,4)
+      J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+      J5_00=INDX3_WRK(0,JKNT,5)
+      J5_M1=INDX3_WRK(-1,JKNT,5)
+!
+      J6_P1=INDX3_WRK(1,JKNT,6)
+      J6_00=INDX3_WRK(0,JKNT,6)
+!
+      MY_IS_GLB=1  ! make this a noop for global indexing
+      MY_IE_GLB=1  ! make this a noop for global indexing
+      MY_JS_GLB=1  ! make this a noop for global indexing
+      MY_JE_GLB=1  ! make this a noop for global indexing
+!  
+!-----------------------------------------------------------------------
+!***  THE WORKING ARRAYS FOR THE PRIMARY VARIABLES
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P4,MYIE_P4
+        TST(I,K,J1_P2)=T(I,K,J+2)*FFC+TOLD(I,K,J+2)*FBC
+        UST(I,K,J1_P2)=U(I,K,J+2)*FFC+UOLD(I,K,J+2)*FBC
+        VST(I,K,J1_P2)=V(I,K,J+2)*FFC+VOLD(I,K,J+2)*FBC
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P4,MYIE_P4
+!
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
+!***  FOR T.
+!-----------------------------------------------------------------------
+!
+        DPDE_P3=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J+3)
+        DPDE(I,K,J0_P3)=DPDE_P3
+!
+!-----------------------------------------------------------------------
+        UDY(I,K,J1_P2)=U(I,K,J+2)*DY
+        VDX_P2=V(I,K,J+2)*DX(I,J+2)
+        VDX(I,K,J1_P2)=VDX_P2
+        FNS(I,K,J+2)=VDX_P2*(DPDE(I,K,J0_P1)+DPDE_P3)
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO K=KTS,KTE
+      DO I=MYIS_P3,MYIE_P3
+        TEMPA=(UDY(I+IHE(J+1),K,J1_P1)+VDX(I+IHE(J+1),K,J1_P1))         &
+     &       +(UDY(I,K,J1_P2)         +VDX(I,K,J1_P2))
+        FNE(I,K,J+1)=TEMPA*(DPDE(I,K,J0_P1)+DPDE(I+IHE(J+1),K,J0_P2))
+!
+!-----------------------------------------------------------------------
+        TEMPB=(UDY(I+IHE(J+2),K,J1_P2)-VDX(I+IHE(J+2),K,J1_P2))         &
+     &       +(UDY(I,K,J1_P1)         -VDX(I,K,J1_P1))
+        FSE(I,K,J+2)=TEMPB*(DPDE(I,K,J0_P2)+DPDE(I+IHE(J),K,J0_P1))
+!
+!-----------------------------------------------------------------------
+        FNS_P1=FNS(I,K,J+1)
+        TNS(I,K,J4_P1)=FNS_P1*(TST(I,K,J1_P2)-TST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+        UDY_P1=U(I,K,J+1)*DY
+        FEW(I,K,J+1)=UDY_P1*(DPDE(I+IVW(J+1),K,J0_P1)                   &
+     &                        +DPDE(I+IVE(J+1),K,J0_P1))
+        FEW_00=FEW(I,K,J)
+        TEW(I,K)=FEW_00*(TST(I+IVE(J),K,J1_00)-TST(I+IVW(J),K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
+!***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
+!-----------------------------------------------------------------------
+!
+        FNE_X=FNE(I,K,J)
+        TNE(I,K,J5_00)=FNE_X*(TST(I+IHE(J),K,J1_P1)-TST(I,K,J1_00))
+!
+        FSE_X=FSE(I,K,J+1)
+        TSE(I,K,J6_P1)=FSE_X*(TST(I+IHE(J+1),K,J1_00)-TST(I,K,J1_P1))
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  CALCULATION OF MOMENTUM ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE_P2
+        UEW(I,K)=(FEW(I+IHW(J),K,J)+FEW(I+IHE(J),K,J))                  &
+     &          *(UST(I+IHE(J),K,J1_00)-UST(I+IHW(J),K,J1_00))
+        UNS(I,K,J4_P1)=(FNS(I+IHW(J+1),K,J+1)                           &
+     &                 +FNS(I+IHE(J+1),K,J+1))                          &
+     &                *(UST(I,K,J1_P2)-UST(I,K,J1_00))
+        VEW(I,K)=(FEW(I,K,J-1)+FEW(I,K,J+1))                            &
+     &          *(VST(I+IHE(J),K,J1_00)-VST(I+IHW(J),K,J1_00))
+        VNS(I,K,J4_P1)=(FNS(I,K,J)+FNS(I,K,J+2))                        &
+     &                *(VST(I,K,J1_P2)-VST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
+!***  LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
+!-----------------------------------------------------------------------
+!
+        UNE(I,K,J5_00)=(FNE(I+IVW(J),K,J)+FNE(I+IVE(J),K,J))            &
+     &                *(UST(I+IVE(J),K,J1_P1)-UST(I,K,J1_00))
+        USE(I,K,J6_P1)=(FSE(I+IVW(J+1),K,J+1)                           &
+     &                 +FSE(I+IVE(J+1),K,J+1))                          &
+     &                *(UST(I+IVE(J+1),K,J1_00)-UST(I,K,J1_P1))
+        VNE(I,K,J5_00)=(FNE(I,K,J-1)+FNE(I,K,J+1))                      &
+     &                *(VST(I+IVE(J),K,J1_P1)-VST(I,K,J1_00))
+        VSE(I,K,J6_P1)=(FSE(I,K,J)+FSE(I,K,J+2))                        &
+     &                *(VST(I+IVE(J+1),K,J1_00)-VST(I,K,J1_P1))
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR T.
+!***  THE AD ARRAYS ARE ON H POINTS.
+!***  SKIP TO UPSTREAM IF THESE ROWS HAVE ONLY UPSTREAM POINTS.
+!-----------------------------------------------------------------------
+!
+      
+      JGLOBAL=J+MY_JS_GLB-1
+      IF(JGLOBAL>=6.AND.JGLOBAL<=JDE-5)THEN
+!
+        JJ=J+MY_JS_GLB-1   ! okay because MY_JS_GLB is 1
+        IF(ITS==IDS)ISTART=3+MOD(JJ,2)  ! need to think about this
+                                        ! more in terms of how to 
+                                        ! convert to global indexing
+!
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPD=1./DPDE(I,K,J0_00)
+!
+          ADT(I,K,J)=(TEW(I+IHW(J),K)+TEW(I+IHE(J),K)                   &
+     &               +TNS(I,K,J4_M1)+TNS(I,K,J4_P1)                     &
+     &               +TNE(I+IHW(J),K,J5_M1)+TNE(I,K,J5_00)              &
+     &               +TSE(I,K,J6_00)+TSE(I+IHW(J),K,J6_P1))             &
+     &               *RDPD*FAD(I,J)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
+!***  THE AD ARRAYS ARE ON VELOCITY POINTS.
+!-----------------------------------------------------------------------
+!
+        IF(ITS==IDS)ISTART=3+MOD(JJ+1,2)
+!
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPDX=1./(DPDE(I+IVW(J),K,J0_00)+DPDE(I+IVE(J),K,J0_00))
+          RDPDY=1./(DPDE(I,K,J0_M1)+DPDE(I,K,J0_P1))
+!
+          ADU(I,K,J)=(UEW(I+IVW(J),K)+UEW(I+IVE(J),K)                   &
+     &               +UNS(I,K,J4_M1)+UNS(I,K,J4_P1)                     &
+     &               +UNE(I+IVW(J),K,J5_M1)+UNE(I,K,J5_00)              &
+     &               +USE(I,K,J6_00)+USE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDX*FAD(I+IVW(J),J)
+!
+          ADV(I,K,J)=(VEW(I+IVW(J),K)+VEW(I+IVE(J),K)                   &
+     &               +VNS(I,K,J4_M1)+VNS(I,K,J4_P1)                     &
+     &               +VNE(I+IVW(J),K,J5_M1)+VNE(I,K,J5_00)              &
+     &               +VSE(I,K,J6_00)+VSE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDY*FAD(I+IVW(J),J)
+!
+        ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  END OF JANJIC HORIZONTAL ADVECTION 
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  UPSTREAM ADVECTION OF T, U, AND V
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      upstream : IF(UPSTRM)THEN
+!
+!-----------------------------------------------------------------------
+!***
+!***  COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
+!***
+!-----------------------------------------------------------------------
+!
+          N_IUPH_J=N_IUP_H(J)   ! See explanation in INIT
+!
+          DO K=KTS,KTE
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+              TTA=EMT_LOC(J)*(UST(I,K,J1_M1)+UST(I+IHW(J),K,J1_00)      &
+     &                       +UST(I+IHE(J),K,J1_00)+UST(I,K,J1_P1))
+              TTB=ENT       *(VST(I,K,J1_M1)+VST(I+IHW(J),K,J1_00)      &
+     &                       +VST(I+IHE(J),K,J1_00)+VST(I,K,J1_P1))
+              PP=-TTA-TTB
+              QP= TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISPA(I,K)=-1
+              ELSE
+                ISPA(I,K)= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQA(I,K)=-1
+              ELSE
+                ISQA(I,K)= 1
+              ENDIF
+!
+              PP=ABS(PP)
+              QP=ABS(QP)
+              ARRAY3_X=PP*QP
+              ARRAY0(I,K)=ARRAY3_X-PP-QP
+              ARRAY1(I,K)=PP-ARRAY3_X
+              ARRAY2(I,K)=QP-ARRAY3_X
+              ARRAY3(I,K)=ARRAY3_X
+            ENDDO
+!
+          ENDDO
+!-----------------------------------------------------------------------
+!
+          N_IUPADH_J=N_IUP_ADH(J) 
+!
+          DO K=KTS,KTE
+!
+            KNTI_ADH=1
+            IUP_ADH_J=IUP_ADH(IMS,J)
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+!
+              ISP=ISPA(I,K)
+              ISQ=ISQA(I,K)
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          *HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          *HTM(I+IPQ,K,J+ISP+ISQ)>0.1)THEN
+                 GO TO 150
+              ENDIF
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          +HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          +HTM(I+IPQ,K,J+ISP+ISQ)<0.1)THEN 
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I,K,J)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+     &         <0.99)THEN
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFQ,K,J+ISQ)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+               <0.99)THEN
+!
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)                                &
+     &        +HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=0.5*(T(I,K,J)                   &
+     &                                      +T(I+IPQ,K,J+ISP+ISQ))
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF(HTM(I+IHE(J)+IFP,K,J+ISP)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF(HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSE
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)            &
+     &                              +T(I+IHE(J)+IFQ,K,J+ISQ)            &
+     &                              -T(I,K,J)
+!
+              ENDIF
+!
+  150         CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+              IF(I==IUP_ADH_J)THEN  ! Update advection H tendencies
+!
+                ISP=ISPA(I,K)
+                ISQ=ISQA(I,K)
+                IFP=(ISP-1)/2
+                IFQ=(-ISQ-1)/2
+                IPQ=(ISP-ISQ)/2
+!
+                F0=ARRAY0(I,K)
+                F1=ARRAY1(I,K)
+                F2=ARRAY2(I,K)
+                F3=ARRAY3(I,K)
+!
+                ADT(I,K,J)=F0*T(I,K,J)                                  &
+     &                    +F1*T(I+IHE(J)+IFP,K,J+ISP)                   &
+     &                    +F2*T(I+IHE(J)+IFQ,K,J+ISQ)                   &
+                          +F3*T(I+IPQ,K,J+ISP+ISQ)
+!
+!-----------------------------------------------------------------------
+!
+                IF(KNTI_ADH Current J
+!                          |
+!                          |
+!                          |
+!                         VNS       ----- -1
+!                          |
+!                          |
+!                          |
+!                         FNS       ----- -2
+!                          |
+!                          |
+!                          |
+!                         DPDE      ----- -3
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      ISTART=MYIS_P2
+      IEND=MYIE_P2 
+      IF(ITE==IDE)IEND=MYIE-3 
+!
+      DTQ=DT*0.25
+      DTE=DT*(0.5*0.25)
+!***
+!***  INITIALIZE SOME WORKING ARRAYS TO ZERO
+!***
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        TEW(I,K)=0.
+        UEW(I,K)=0.
+        VEW(I,K)=0.
+      ENDDO
+      ENDDO
+!
+!***  TYPE 0
+!
+      DO N=-3,3
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          DPDE(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPE 1
+!
+      DO N=-2,2
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TST(I,K,N)=0.
+          UST(I,K,N)=0.
+          VST(I,K,N)=0.
+          UDY(I,K,N)=0.
+          VDX(I,K,N)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!***  TYPES 5 AND 6
+!
+      DO N=-1,0
+        DO K=KTS,KTE
+        DO I=ITS-5,ITE+5
+          TNE(I,K,N)=0.
+          TSE(I,K,N+1)=0.
+          UNE(I,K,N)=0.
+          USE(I,K,N+1)=0.
+          VNE(I,K,N)=0.
+          VSE(I,K,N+1)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  PRECOMPUTE DETA1 TIMES PDTOP.
+!***
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        DETA1_PDTOP(K)=DETA1(K)*PDTOP
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  WE NEED THE STARTING AND ENDING J FOR THIS TASK'S INTEGRATION
+!***
+!-----------------------------------------------------------------------
+!
+      JSTART=MYJS2
+      JEND=MYJE2
+!
+!-----------------------------------------------------------------------
+!
+!***  START THE HORIZONTAL ADVECTION IN THE INITIAL SOUTHERN SLABS.
+!
+!-----------------------------------------------------------------------
+!
+      DO J=-2,1
+        JJ=JSTART+J
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          TST(I,K,J)=T(I,K,JJ)*FFC+TOLD(I,K,JJ)*FBC
+          UST(I,K,J)=U(I,K,JJ)*FFC+UOLD(I,K,JJ)*FBC
+          VST(I,K,J)=V(I,K,JJ)*FFC+VOLD(I,K,JJ)*FBC
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
+!***  ONLY THE NORTHERNMOST OF EACH OF THE WORKING ARRAYS WILL BE
+!***  FILLED IN THE PRIMARY INTEGRATION SECTION.
+!-----------------------------------------------------------------------
+!
+      J1=-3
+      IF(JTS==JDS)J1=-2  ! Cannot go 3 south from J=2 for south tasks
+!
+      DO J=J1,2
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,K,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,JJ)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,1
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          UDY(I,K,J)=U(I,K,JJ)*DY
+          VDX_X=V(I,K,JJ)*DX(I,JJ)
+          FNS(I,K,JJ)=VDX_X*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
+          VDX(I,K,J)=VDX_X
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-2,0
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k,tempa)
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPA=(UDY(I+IHE(JJ),K,J)+VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J+1)      +VDX(I,K,J+1))
+          FNE(I,K,JJ)=TEMPA*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,1
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k,tempb)
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          TEMPB=(UDY(I+IHE(JJ),K,J)-VDX(I+IHE(JJ),K,J))                 &
+     &         +(UDY(I,K,J-1)      -VDX(I,K,J-1))
+          FSE(I,K,JJ)=TEMPB*(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO J=-1,0
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(fns_x,i,k,udy_x)
+        DO K=KTS,KTE
+        DO I=MYIS1_P3,MYIE1_P3
+          FNS_X=FNS(I,K,JJ)
+          TNS(I,K,J)=FNS_X*(TST(I,K,J+1)-TST(I,K,J-1))
+!
+          UDY_X=U(I,K,JJ)*DY
+          FEW(I,K,JJ)=UDY_X*(DPDE(I+IVW(JJ),K,J)+DPDE(I+IVE(JJ),K,J))   
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS1_P4,MYIE1_P4
+          UNS(I,K,J)=(FNS(I+IHW(JJ),K,JJ)+FNS(I+IHE(JJ),K,JJ))          &
+     &              *(UST(I,K,J+1)-UST(I,K,J-1))
+          VNS(I,K,J)=(FNS(I,K,JJ-1)+FNS(I,K,JJ+1))                      &
+     &              *(VST(I,K,J+1)-VST(I,K,J-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      JJ=JSTART-1
+!
+!$omp parallel do                                                       &
+!$omp& private(fne_x,fse_x,i,k)
+      DO K=KTS,KTE
+      DO I=MYIS1_P2,MYIE1_P2
+        FNE_X=FNE(I,K,JJ)
+        TNE(I,K,-1)=FNE_X*(TST(I+IHE(JJ),K,0)-TST(I,K,-1))
+!
+        FSE_X=FSE(I,K,JJ+1)
+        TSE(I,K,0)=FSE_X*(TST(I+IHE(JJ+1),K,-1)-TST(I,K,0))
+!
+        UNE(I,K,-1)=(FNE(I+IVW(JJ),K,JJ)+FNE(I+IVE(JJ),K,JJ))           &
+     &             *(UST(I+IVE(JJ),K,0)-UST(I,K,-1))
+        USE(I,K,0)=(FSE(I+IVW(JJ+1),K,JJ+1)+FSE(I+IVE(JJ+1),K,JJ+1))    &
+     &            *(UST(I+IVE(JJ+1),K,-1)-UST(I,K,0))
+        VNE(I,K,-1)=(FNE(I,K,JJ-1)+FNE(I,K,JJ+1))                       &
+     &             *(VST(I+IVE(JJ),K,0)-VST(I,K,-1))
+        VSE(I,K,0)=(FSE(I,K,JJ)+FSE(I,K,JJ+2))                          &
+     &            *(VST(I+IVE(JJ+1),K,-1)-VST(I,K,0))
+      ENDDO
+      ENDDO
+!
+      JKNT=0
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      main_integration : DO J=JSTART,JEND
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND PFDHT DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P3 denotes +3, M1 denotes -1, etc.)
+!***
+!-----------------------------------------------------------------------
+!
+      JKNT=JKNT+1
+!
+      J0_P3=INDX3_WRK(3,JKNT,0)
+      J0_P2=INDX3_WRK(2,JKNT,0)
+      J0_P1=INDX3_WRK(1,JKNT,0)
+      J0_00=INDX3_WRK(0,JKNT,0)
+      J0_M1=INDX3_WRK(-1,JKNT,0)
+!
+      J1_P2=INDX3_WRK(2,JKNT,1)
+      J1_P1=INDX3_WRK(1,JKNT,1)
+      J1_00=INDX3_WRK(0,JKNT,1)
+      J1_M1=INDX3_WRK(-1,JKNT,1)
+!
+      J2_P1=INDX3_WRK(1,JKNT,2)
+      J2_00=INDX3_WRK(0,JKNT,2)
+      J2_M1=INDX3_WRK(-1,JKNT,2)
+!
+      J3_P2=INDX3_WRK(2,JKNT,3)
+      J3_P1=INDX3_WRK(1,JKNT,3)
+      J3_00=INDX3_WRK(0,JKNT,3)
+!
+      J4_P1=INDX3_WRK(1,JKNT,4)
+      J4_00=INDX3_WRK(0,JKNT,4)
+      J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+      J5_00=INDX3_WRK(0,JKNT,5)
+      J5_M1=INDX3_WRK(-1,JKNT,5)
+!
+      J6_P1=INDX3_WRK(1,JKNT,6)
+      J6_00=INDX3_WRK(0,JKNT,6)
+!
+      MY_IS_GLB=1  ! make this a noop for global indexing
+      MY_IE_GLB=1  ! make this a noop for global indexing
+      MY_JS_GLB=1  ! make this a noop for global indexing
+      MY_JE_GLB=1  ! make this a noop for global indexing
+  
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dpde_p3,few_00,fne_x,fns_p1,fse_x,i,k,tempa,tempb        &
+!$omp&        ,udy_p1,vdx_p2)
+      vertical_loop_1 : DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!***  EXECUTE HORIZONTAL ADVECTION.
+!-----------------------------------------------------------------------
+!
+      DO I=MYIS_P4,MYIE_P4
+        TST(I,K,J1_P2)=T(I,K,J+2)*FFC+TOLD(I,K,J+2)*FBC
+        UST(I,K,J1_P2)=U(I,K,J+2)*FFC+UOLD(I,K,J+2)*FBC
+        VST(I,K,J1_P2)=V(I,K,J+2)*FFC+VOLD(I,K,J+2)*FBC
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!
+      DO I=MYIS_P4,MYIE_P4
+!
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
+!***  FOR T.
+!-----------------------------------------------------------------------
+!
+        DPDE_P3=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J+3)
+        DPDE(I,K,J0_P3)=DPDE_P3
+!
+!-----------------------------------------------------------------------
+        UDY(I,K,J1_P2)=U(I,K,J+2)*DY
+        VDX_P2=V(I,K,J+2)*DX(I,J+2)
+        VDX(I,K,J1_P2)=VDX_P2
+        FNS(I,K,J+2)=VDX_P2*(DPDE(I,K,J0_P1)+DPDE_P3)
+      ENDDO
+!
+!-----------------------------------------------------------------------
+      DO I=MYIS_P3,MYIE_P3
+        TEMPA=(UDY(I+IHE(J+1),K,J1_P1)+VDX(I+IHE(J+1),K,J1_P1))         &
+     &       +(UDY(I,K,J1_P2)         +VDX(I,K,J1_P2))
+        FNE(I,K,J+1)=TEMPA*(DPDE(I,K,J0_P1)+DPDE(I+IHE(J+1),K,J0_P2))
+!
+!-----------------------------------------------------------------------
+        TEMPB=(UDY(I+IHE(J+2),K,J1_P2)-VDX(I+IHE(J+2),K,J1_P2))         &
+     &       +(UDY(I,K,J1_P1)         -VDX(I,K,J1_P1))
+        FSE(I,K,J+2)=TEMPB*(DPDE(I,K,J0_P2)+DPDE(I+IHE(J),K,J0_P1))
+!
+!-----------------------------------------------------------------------
+        FNS_P1=FNS(I,K,J+1)
+        TNS(I,K,J4_P1)=FNS_P1*(TST(I,K,J1_P2)-TST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+        UDY_P1=U(I,K,J+1)*DY
+        FEW(I,K,J+1)=UDY_P1*(DPDE(I+IVW(J+1),K,J0_P1)                   &
+     &                        +DPDE(I+IVE(J+1),K,J0_P1))
+        FEW_00=FEW(I,K,J)
+        TEW(I,K)=FEW_00*(TST(I+IVE(J),K,J1_00)-TST(I+IVW(J),K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
+!***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
+!-----------------------------------------------------------------------
+!
+        FNE_X=FNE(I,K,J)
+        TNE(I,K,J5_00)=FNE_X*(TST(I+IHE(J),K,J1_P1)-TST(I,K,J1_00))
+!
+        FSE_X=FSE(I,K,J+1)
+        TSE(I,K,J6_P1)=FSE_X*(TST(I+IHE(J+1),K,J1_00)-TST(I,K,J1_P1))
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  CALCULATION OF MOMENTUM ADVECTION COMPONENTS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
+!-----------------------------------------------------------------------
+!
+      DO I=MYIS_P2,MYIE_P2
+        UEW(I,K)=(FEW(I+IHW(J),K,J)+FEW(I+IHE(J),K,J))                  &
+     &          *(UST(I+IHE(J),K,J1_00)-UST(I+IHW(J),K,J1_00))
+        UNS(I,K,J4_P1)=(FNS(I+IHW(J+1),K,J+1)                           &
+     &                 +FNS(I+IHE(J+1),K,J+1))                          &
+     &                *(UST(I,K,J1_P2)-UST(I,K,J1_00))
+        VEW(I,K)=(FEW(I,K,J-1)+FEW(I,K,J+1))                            &
+     &          *(VST(I+IHE(J),K,J1_00)-VST(I+IHW(J),K,J1_00))
+        VNS(I,K,J4_P1)=(FNS(I,K,J)+FNS(I,K,J+2))                        &
+     &                *(VST(I,K,J1_P2)-VST(I,K,J1_00))
+!
+!-----------------------------------------------------------------------
+!***  THE FOLLOWING NE AND SE FLUXES ARE TIED TO V POINTS AND ARE
+!***  LOCATED JUST TO THE NE AND SE OF THE GIVEN I,J.
+!-----------------------------------------------------------------------
+!
+        UNE(I,K,J5_00)=(FNE(I+IVW(J),K,J)+FNE(I+IVE(J),K,J))            &
+     &                *(UST(I+IVE(J),K,J1_P1)-UST(I,K,J1_00))
+        USE(I,K,J6_P1)=(FSE(I+IVW(J+1),K,J+1)                           &
+     &                 +FSE(I+IVE(J+1),K,J+1))                          &
+     &                *(UST(I+IVE(J+1),K,J1_00)-UST(I,K,J1_P1))
+        VNE(I,K,J5_00)=(FNE(I,K,J-1)+FNE(I,K,J+1))                      &
+     &                *(VST(I+IVE(J),K,J1_P1)-VST(I,K,J1_00))
+        VSE(I,K,J6_P1)=(FSE(I,K,J)+FSE(I,K,J+2))                        &
+     &                *(VST(I+IVE(J+1),K,J1_00)-VST(I,K,J1_P1))
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_loop_1
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR T.
+!***  THE AD ARRAYS ARE ON H POINTS.
+!***  SKIP TO UPSTREAM IF THESE ROWS HAVE ONLY UPSTREAM POINTS.
+!-----------------------------------------------------------------------
+!
+      
+      JGLOBAL=J+MY_JS_GLB-1
+      IF(JGLOBAL>=6.AND.JGLOBAL<=JDE-5)THEN
+!
+        JJ=J+MY_JS_GLB-1   ! okay because MY_JS_GLB is 1
+        IF(ITS==IDS)ISTART=3+MOD(JJ,2)  ! need to think about this
+                                        ! more in terms of how to 
+                                        ! convert to global indexing
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k,rdpd)
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPD=1./DPDE(I,K,J0_00)
+!
+          ADT(I,K,J)=(TEW(I+IHW(J),K)+TEW(I+IHE(J),K)                   &
+     &               +TNS(I,K,J4_M1)+TNS(I,K,J4_P1)                     &
+     &               +TNE(I+IHW(J),K,J5_M1)+TNE(I,K,J5_00)              &
+     &               +TSE(I,K,J6_00)+TSE(I+IHW(J),K,J6_P1))             &
+     &               *RDPD*FAD(I,J)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
+!***  THE AD ARRAYS ARE ON VELOCITY POINTS.
+!-----------------------------------------------------------------------
+!
+        IF(ITS==IDS)ISTART=3+MOD(JJ+1,2)
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k,rdpdx,rdpdy)
+        DO K=KTS,KTE
+        DO I=ISTART,IEND
+          RDPDX=1./(DPDE(I+IVW(J),K,J0_00)+DPDE(I+IVE(J),K,J0_00))
+          RDPDY=1./(DPDE(I,K,J0_M1)+DPDE(I,K,J0_P1))
+!
+          ADU(I,K,J)=(UEW(I+IVW(J),K)+UEW(I+IVE(J),K)                   &
+     &               +UNS(I,K,J4_M1)+UNS(I,K,J4_P1)                     &
+     &               +UNE(I+IVW(J),K,J5_M1)+UNE(I,K,J5_00)              &
+     &               +USE(I,K,J6_00)+USE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDX*FAD(I+IVW(J),J)
+!
+          ADV(I,K,J)=(VEW(I+IVW(J),K)+VEW(I+IVE(J),K)                   &
+     &               +VNS(I,K,J4_M1)+VNS(I,K,J4_P1)                     &
+     &               +VNE(I+IVW(J),K,J5_M1)+VNE(I,K,J5_00)              &
+     &               +VSE(I,K,J6_00)+VSE(I+IVW(J),K,J6_P1))             &
+     &               *RDPDY*FAD(I+IVW(J),J)
+!
+        ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  END OF JANJIC HORIZONTAL ADVECTION 
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  UPSTREAM ADVECTION OF T, U, AND V
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      upstream : IF(UPSTRM)THEN
+!
+!-----------------------------------------------------------------------
+!***
+!***  COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
+!***
+!-----------------------------------------------------------------------
+!
+          N_IUPH_J=N_IUP_H(J)   ! See explanation in INIT
+!
+!$omp parallel do                                                       &
+!$omp& private(array3_x,i,k,pp,qp,tta,ttb)
+          DO K=KTS,KTE
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+              TTA=EMT_LOC(J)*(UST(I,K,J1_M1)+UST(I+IHW(J),K,J1_00)      &
+     &                       +UST(I+IHE(J),K,J1_00)+UST(I,K,J1_P1))
+              TTB=ENT       *(VST(I,K,J1_M1)+VST(I+IHW(J),K,J1_00)      &
+     &                       +VST(I+IHE(J),K,J1_00)+VST(I,K,J1_P1))
+              PP=-TTA-TTB
+              QP= TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISPA(I,K)=-1
+              ELSE
+                ISPA(I,K)= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQA(I,K)=-1
+              ELSE
+                ISQA(I,K)= 1
+              ENDIF
+!
+              PP=ABS(PP)
+              QP=ABS(QP)
+              ARRAY3_X=PP*QP
+              ARRAY0(I,K)=ARRAY3_X-PP-QP
+              ARRAY1(I,K)=PP-ARRAY3_X
+              ARRAY2(I,K)=QP-ARRAY3_X
+              ARRAY3(I,K)=ARRAY3_X
+            ENDDO
+!
+          ENDDO
+!-----------------------------------------------------------------------
+!
+          N_IUPADH_J=N_IUP_ADH(J) 
+!
+!$omp parallel do                                                       &
+!$omp& private(f0,f1,f2,f3,i,ifp,ifq,ipq,isp,isq,iup_adh_j,k,knti_adh)
+          DO K=KTS,KTE
+!
+            KNTI_ADH=1
+            IUP_ADH_J=IUP_ADH(IMS,J)
+!
+            DO II=0,N_IUPH_J-1
+              I=IUP_H(IMS+II,J)
+!
+              ISP=ISPA(I,K)
+              ISQ=ISQA(I,K)
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          *HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          *HTM(I+IPQ,K,J+ISP+ISQ)>0.1)THEN
+                 GO TO 150
+              ENDIF
+!
+              IF(HTM(I+IHE(J)+IFP,K,J+ISP)                              &
+     &          +HTM(I+IHE(J)+IFQ,K,J+ISQ)                              &
+     &          +HTM(I+IPQ,K,J+ISP+ISQ)<0.1)THEN 
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I,K,J)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+     &         <0.99)THEN
+!
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFQ,K,J+ISQ)+HTM(I+IPQ,K,J+ISP+ISQ)         &
+               <0.99)THEN
+!
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF                                                    &
+     &        (HTM(I+IHE(J)+IFP,K,J+ISP)                                &
+     &        +HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=0.5*(T(I,K,J)                   &
+     &                                      +T(I+IPQ,K,J+ISP+ISQ))
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSEIF(HTM(I+IHE(J)+IFP,K,J+ISP)<0.99)THEN
+                T(I+IHE(J)+IFP,K,J+ISP)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFQ,K,J+ISQ)
+!
+              ELSEIF(HTM(I+IHE(J)+IFQ,K,J+ISQ)<0.99)THEN
+                T(I+IHE(J)+IFQ,K,J+ISQ)=T(I,K,J)                        &
+     &                                 +T(I+IPQ,K,J+ISP+ISQ)            &
+     &                                 -T(I+IHE(J)+IFP,K,J+ISP)
+!
+              ELSE
+                T(I+IPQ,K,J+ISP+ISQ)=T(I+IHE(J)+IFP,K,J+ISP)            &
+     &                              +T(I+IHE(J)+IFQ,K,J+ISQ)            &
+     &                              -T(I,K,J)
+!
+              ENDIF
+!
+  150         CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+              IF(I==IUP_ADH_J)THEN  ! Update advection H tendencies
+!
+                ISP=ISPA(I,K)
+                ISQ=ISQA(I,K)
+                IFP=(ISP-1)/2
+                IFQ=(-ISQ-1)/2
+                IPQ=(ISP-ISQ)/2
+!
+                F0=ARRAY0(I,K)
+                F1=ARRAY1(I,K)
+                F2=ARRAY2(I,K)
+                F3=ARRAY3(I,K)
+!
+                ADT(I,K,J)=F0*T(I,K,J)                                  &
+     &                    +F1*T(I+IHE(J)+IFP,K,J+ISP)                   &
+     &                    +F2*T(I+IHE(J)+IFQ,K,J+ISQ)                   &
+                          +F3*T(I+IPQ,K,J+ISP+ISQ)
+!
+!-----------------------------------------------------------------------
+!
+                IF(KNTI_ADH=6000)then
+!       IF(I==ITEST.AND.J==JTEST)THEN
+!!
+!         PVVLO=PETDT(I,KTE-1,J)*DT*0.25
+!         VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
+!         TTLO=VVLO*(T(I,KTE-1,J)-T(I,KTE,J)                            &
+!    &              +TN(KTE-1)-TN(KTE))
+!         ADTP=TTLO+TN(KTE)-T(I,KTE,J)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTE     &
+!    &,             ' ADTP=',ADTP
+!         WRITE(0,*)' T=',T(I,KTE,J),' TN=',TN(KTE)                     &
+!    &,               ' VAD_TEND_T=',VAD_TEND_T(I,KTE)
+!         WRITE(0,*)' '
+!!
+!         DO K=KTE-1,LMHK+1,-1
+!           RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
+!           PVVUP=PVVLO
+!           PVVLO=PETDT(I,K-1,J)*DT*0.25
+!           VVUP=PVVUP*RDP
+!           VVLO=PVVLO*RDP
+!           TTUP=VVUP*(T(I,K,J)-T(I,K+1,J)+TN(K)-TN(K+1))
+!           TTLO=VVLO*(T(I,K-1,J)-T(I,K,J)+TN(K-1)-TN(K))
+!           ADTP=TTLO+TTUP+TN(K)-T(I,K,J)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',K             &
+!    &,               ' ADTP=',ADTP
+!           WRITE(0,*)' T=',T(I,K,J),' TN=',TN(K)                       &
+!    &,               ' VAD_TEND_T=',VAD_TEND_T(I,K)
+!           WRITE(0,*)' '
+!         ENDDO
+!!
+!         IF(LMHK==KTS)THEN
+!           PVVUP=PVVLO
+!           VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
+!           TTUP=VVUP*(T(I,KTS,J)-T(I,KTS+1,J)+TN(KTS)-TN(KTS+1))
+!           ADTP=TTUP+TN(KTS)-T(I,KTS,J)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTS           &
+!    &,               ' ADTP=',ADTP
+!           WRITE(0,*)' T=',T(I,KTS,J),' TN=',TN(KTS)                   &
+!    &,               ' VAD_TEND_T=',VAD_TEND_T(I,KTS)
+!           WRITE(0,*)' '
+!         ENDIF
+!       ENDIF
+!       endif
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_t
+!
+!-----------------------------------------------------------------------
+!***  NOW VERTICAL ADVECTION OF WIND COMPONENTS
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(cfu,cfv,cmu,cmv,cru,crv,i,k,lmvk,pdopu,pdopv             &
+!$omp&        ,pvvlou,pvvlov,pvvupu,pvvupv,rcmu,rcmv,rdpu,rdpv          &
+!$omp&        ,rstu,rstv,un,vn,vvlou,vvlov,vvupu,vvupv                  &
+!!!$omp&        ,adup,advp,tulo,tuup,tvlo,tvup                            &
+!$omp&         ) 
+      iloop_for_uv:  DO I=MYIS1,MYIE1
+!
+        PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
+        PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
+        PVVLOU=(PETDT(I+IVW(J),KTE-1,J)+PETDT(I+IVE(J),KTE-1,J))*DTE
+        PVVLOV=(PETDT(I,KTE-1,J-1)+PETDT(I,KTE-1,J+1))*DTE
+        VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
+        VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
+        CMU=-VVLOU*WGT2+1.
+        CMV=-VVLOV*WGT2+1.
+        RCMU(KTE)=1./CMU
+        RCMV(KTE)=1./CMV
+        CRU(KTE)=VVLOU*WGT2
+        CRV(KTE)=VVLOV*WGT2
+        RSTU(KTE)=-VVLOU*WGT1*(U(I,KTE-1,J)-U(I,KTE,J))+U(I,KTE,J)
+        RSTV(KTE)=-VVLOV*WGT1*(V(I,KTE-1,J)-V(I,KTE,J))+V(I,KTE,J)
+!
+        LMVK=KTE-LMV(I,J)+1
+        DO K=KTE-1,LMVK+1,-1
+          RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
+          RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
+          PVVUPU=PVVLOU
+          PVVUPV=PVVLOV
+          PVVLOU=(PETDT(I+IVW(J),K-1,J)+PETDT(I+IVE(J),K-1,J))*DTE
+          PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
+          VVUPU=PVVUPU*RDPU
+          VVUPV=PVVUPV*RDPV
+          VVLOU=PVVLOU*RDPU
+          VVLOV=PVVLOV*RDPV
+          CFU=-VVUPU*WGT2*RCMU(K+1)
+          CFV=-VVUPV*WGT2*RCMV(K+1)
+          CMU=-CRU(K+1)*CFU+(VVUPU-VVLOU)*WGT2+1.
+          CMV=-CRV(K+1)*CFV+(VVUPV-VVLOV)*WGT2+1.
+          RCMU(K)=1./CMU
+          RCMV(K)=1./CMV
+          CRU(K)=VVLOU*WGT2
+          CRV(K)=VVLOV*WGT2
+          RSTU(K)=-RSTU(K+1)*CFU+U(I,K,J)                               &
+     &            -(U(I,K,J)-U(I,K+1,J))*VVUPU*WGT1                     &
+     &            -(U(I,K-1,J)-U(I,K,J))*VVLOU*WGT1
+          RSTV(K)=-RSTV(K+1)*CFV+V(I,K,J)                               &
+     &            -(V(I,K,J)-V(I,K+1,J))*VVUPV*WGT1                     &
+     &            -(V(I,K-1,J)-V(I,K,J))*VVLOV*WGT1
+        ENDDO
+!
+        RDPU=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPU)
+        RDPV=1./(DETA1_PDTOP(LMVK)+DETA2(LMVK)*PDOPV)
+        PVVUPU=PVVLOU
+        PVVUPV=PVVLOV
+        VVUPU=PVVUPU*RDPU
+        VVUPV=PVVUPV*RDPV
+        CFU=-VVUPU*WGT2*RCMU(LMVK+1)
+        CFV=-VVUPV*WGT2*RCMV(LMVK+1)
+        CMU=-CRU(LMVK+1)*CFU+VVUPU*WGT2+1.
+        CMV=-CRV(LMVK+1)*CFV+VVUPV*WGT2+1.
+        CRU(LMVK)=0.
+        CRV(LMVK)=0.
+        RSTU(LMVK)=-(U(I,LMVK,J)-U(I,LMVK+1,J))*VVUPU*WGT1              &
+     &               -RSTU(LMVK+1)*CFU+U(I,LMVK,J)
+        RSTV(LMVK)=-(V(I,LMVK,J)-V(I,LMVK+1,J))*VVUPV*WGT1              &
+     &               -RSTV(LMVK+1)*CFV+V(I,LMVK,J)
+        UN(LMVK)=RSTU(LMVK)/CMU
+        VN(LMVK)=RSTV(LMVK)/CMV
+        VAD_TEND_U(I,LMVK)=UN(LMVK)-U(I,LMVK,J)
+        VAD_TEND_V(I,LMVK)=VN(LMVK)-V(I,LMVK,J)
+!
+        DO K=LMVK+1,KTE
+          UN(K)=(-CRU(K)*UN(K-1)+RSTU(K))*RCMU(K)
+          VN(K)=(-CRV(K)*VN(K-1)+RSTV(K))*RCMV(K)
+          VAD_TEND_U(I,K)=UN(K)-U(I,K,J)
+          VAD_TEND_V(I,K)=VN(K)-V(I,K,J)
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  The following section is only for checking the implicit solution
+!***  using back-substitution.  Remove this section otherwise.
+!-----------------------------------------------------------------------
+!
+!       if(ntsd<=10.or.ntsd>=6000)then
+!       IF(I==ITEST.AND.J==JTEST)THEN
+!!
+!         PDOPU=(PDSLO(I+IVW(J),J)+PDSLO(I+IVE(J),J))*0.5
+!         PDOPV=(PDSLO(I,J-1)+PDSLO(I,J+1))*0.5
+!         PVVLOU=(PETDT(I+IVW(J),KTE-1,J)                               &
+!    &           +PETDT(I+IVE(J),KTE-1,J))*DTE
+!         PVVLOV=(PETDT(I,KTE-1,J-1)                                    &
+!    &           +PETDT(I,KTE-1,J+1))*DTE
+!         VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
+!         VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
+!         TULO=VVLOU*(U(I,KTE-1,J)-U(I,KTE,J)+UN(KTE-1)-UN(KTE))
+!         TVLO=VVLOV*(V(I,KTE-1,J)-V(I,KTE,J)+VN(KTE-1)-VN(KTE))
+!         ADUP=TULO+UN(KTE)-U(I,KTE,J)
+!         ADVP=TVLO+VN(KTE)-V(I,KTE,J)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTE             &
+!    &,             ' ADUP=',ADUP,' ADVP=',ADVP
+!         WRITE(0,*)' U=',U(I,KTE,J),' UN=',UN(KTE)                     &
+!    &,             ' VAD_TEND_U=',VAD_TEND_U(I,KTE)                    &
+!    &,             ' V=',V(I,KTE,J),' VN=',VN(KTE)                     &
+!    &,             ' VAD_TEND_V=',VAD_TEND_V(I,KTE)
+!         WRITE(0,*)' '
+!!
+!         DO K=KTE-1,LMVK+1,-1
+!           RDPU=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPU)
+!           RDPV=1./(DETA1_PDTOP(K)+DETA2(K)*PDOPV)
+!           PVVUPU=PVVLOU
+!           PVVUPV=PVVLOV
+!           PVVLOU=(PETDT(I+IVW(J),K-1,J)                               &
+!    &            +PETDT(I+IVE(J),K-1,J))*DTE
+!           PVVLOV=(PETDT(I,K-1,J-1)+PETDT(I,K-1,J+1))*DTE
+!           VVUPU=PVVUPU*RDPU
+!           VVUPV=PVVUPV*RDPV
+!           VVLOU=PVVLOU*RDPU
+!           VVLOV=PVVLOV*RDPV
+!           TUUP=VVUPU*(U(I,K,J)-U(I,K+1,J)+UN(K)-UN(K+1))
+!           TVUP=VVUPV*(V(I,K,J)-V(I,K+1,J)+VN(K)-VN(K+1))
+!           TULO=VVLOU*(U(I,K-1,J)-U(I,K,J)+UN(K-1)-UN(K))
+!           TVLO=VVLOV*(V(I,K-1,J)-V(I,K,J)+VN(K-1)-VN(K))
+!           ADUP=TUUP+TULO+UN(K)-U(I,K,J)
+!           ADVP=TVUP+TVLO+VN(K)-V(I,K,J)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',K     &
+!    &,               ' ADUP=',ADUP,' ADVP=',ADVP
+!           WRITE(0,*)' U=',U(I,K,J),' UN=',UN(K)                       &
+!    &,               ' VAD_TEND_U=',VAD_TEND_U(I,K)                    &
+!    &,               ' V=',V(I,K,J),' VN=',VN(K)                       &
+!    &,               ' VAD_TEND_V=',VAD_TEND_V(I,K)
+!           WRITE(0,*)' '
+!         ENDDO
+!!
+!         IF(LMVK==KTS)THEN
+!           PVVUPU=PVVLOU
+!           PVVUPV=PVVLOV
+!           VVUPU=PVVUPU/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
+!           VVUPV=PVVUPV/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
+!           TUUP=VVUPU*(U(I,KTS,J)-U(I,KTS+1,J)+UN(KTS)-UN(KTS+1))
+!           TVUP=VVUPV*(V(I,KTS,J)-V(I,KTS+1,J)+VN(KTS)-VN(KTS+1))
+!           ADUP=TUUP+UN(KTS)-U(I,KTS,J)
+!           ADVP=TVUP+VN(KTS)-V(I,KTS,J)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTS   &
+!    &,               ' ADUP=',ADUP,' ADVP=',ADVP
+!           WRITE(0,*)' U=',U(I,KTS,J),' UN=',UN(KTS)                   &
+!    &,               ' VAD_TEND_U=',VAD_TEND_U(I,KTS)                  &
+!    &,               ' V=',V(I,KTS,J),' VN=',VN(KTS)                   &
+!    &,               ' VAD_TEND_V=',VAD_TEND_V(I,KTS)
+!           WRITE(0,*)' '
+!         ENDIF
+!       ENDIF
+!     endif
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_uv
+!
+!-----------------------------------------------------------------------
+!
+!***  NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
+!***  CURVATURE AND CORIOLIS TERMS
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(fpp,hm,i,k,vm)
+      DO K=KTS,KTE
+      DO I=MYIS1,MYIE1
+        HM=HTM(I,K,J)*HBM2(I,J)
+        VM=VTM(I,K,J)*VBM2(I,J)
+        ADT(I,K,J)=(VAD_TEND_T(I,K)+2.*ADT(I,K,J))*HM
+!
+        FPP=CURV(I,J)*2.*UST(I,K,J1_00)+F(I,J)*2.
+        ADU(I,K,J)=(VAD_TEND_U(I,K)+2.*ADU(I,K,J)+VST(I,K,J1_00)*FPP)   &
+     &             *VM
+        ADV(I,K,J)=(VAD_TEND_V(I,K)+2.*ADV(I,K,J)-UST(I,K,J1_00)*FPP)   &
+     &             *VM
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  SAVE THE OLD VALUES FOR TIMESTEPPING
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS_P4,MYJE_P4
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          TOLD(I,K,J)=T(I,K,J)
+          UOLD(I,K,J)=U(I,K,J)
+          VOLD(I,K,J)=V(I,K,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FINALLY UPDATE THE PROGNOSTIC VARIABLES
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+        DO I=MYIS1,MYIE1
+          T(I,K,J)=ADT(I,K,J)+T(I,K,J)
+          U(I,K,J)=ADU(I,K,J)+U(I,K,J)
+          V(I,K,J)=ADV(I,K,J)+V(I,K,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE ADVE
+!-----------------------------------------------------------------------
+!
+!***********************************************************************
+      SUBROUTINE VAD2(NTSD,DT,IDTAD,DX,DY                               &
+     &               ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                &
+     &               ,HBM2,LMH                                          &
+     &               ,Q,Q2,CWM,PETDT                                    &
+     &               ,N_IUP_H,N_IUP_V                                   &
+     &               ,N_IUP_ADH,N_IUP_ADV                               &
+     &               ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                       &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    VAD2        VERTICAL ADVECTION OF H2O SUBSTANCE AND TKE
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!
+! ABSTRACT:
+!     VAD2 CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
+!     TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN UPDATES
+!     THOSE VARIABLES.  AN ANTI-FILTERING TECHNIQUE IS USED.
+!
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC   - ORIGINATOR
+!   98-11-02  BLACK    - MODIFIED FOR DISTRIBUTED MEMORY
+!   99-03-17  TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
+!   02-02-06  BLACK    - CONVERTED TO WRF FORMAT
+!   02-09-06  WOLFE    - MORE CONVERSION TO GLOBAL INDEXING
+!   04-11-23  BLACK    - THREADED
+!
+! USAGE: CALL VAD2 FROM SUBROUTINE SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+! NMM_MAX_DIM is set in configure.wrf and must agree with
+! the value of dimspec q in the Registry/Registry
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
+!
+!----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.525
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP     &
+     &       ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ                           &
+     &       ,Q00,Q4P,QP,QP0                                            &
+     &       ,RFACEK,RFACQK,RFACWK,RFC,RR                               &
+     &       ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW                       &
+     &       ,W00,W4P,WP,WP0
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK           &
+     &                          ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      ADDT=REAL(IDTAD)*DT
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup   &
+!$omp&        ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff    &
+!$omp&        ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk    &
+!$omp&        ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top    &
+!$omp&        ,w00,w3,w4,w4p,wp,wp0)
+      main_integration : DO J=MYJS2,MYJE2
+!
+      DO I=MYIS1_P1,MYIE1_P1
+!-----------------------------------------------------------------------
+        KOFF=KTE-LMH(I,J)
+!
+        E3(KTE)=Q2(I,KTE,J)*0.5
+!
+        DO K=KTE-1,KOFF+1,-1
+          E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
+        ENDDO
+!
+        DO K=KOFF+1,KTE
+          Q3(K)=MAX(Q(I,K,J),EPSQ)
+          W3(K)=MAX(CWM(I,K,J),CLIMIT)
+          E4(K)=E3(K)
+          Q4(K)=Q3(K)
+          W4(K)=W3(K)
+        ENDDO
+!
+        PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
+!
+        DO K=KTE-1,KOFF+2,-1
+          PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
+        ENDDO
+!
+        PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
+!-----------------------------------------------------------------------
+        HADDT=-ADDT*HBM2(I,J)
+!
+        DO K=KTE,KOFF+1,-1
+          RR=PETDTK(K)*HADDT
+!
+          IF(RR<0.)THEN
+            LAP=1
+          ELSE
+            LAP=-1
+          ENDIF
+!
+          LA(K)=LAP
+          LLAP=K+LAP
+!
+          TOP=.FALSE.
+          BOT=.FALSE.
+!
+          IF(LLAP>KOFF.AND.LLAP0)THEN
+            RFC=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDSL(I,J))             &
+     &         /(DETA1(KTE  )*PDTOP+DETA2(KTE  )*PDSL(I,J))
+            DQL(KTE)=-DQL(KTE+1)*RFC
+            DWL(KTE)=-DWL(KTE+1)*RFC
+            DEL(KTE)=-DEL(KTE+1)*RFC
+          ENDIF
+        ENDIF
+!
+        IF(BOT)THEN
+          IF(LA(KOFF+2)<0)THEN
+            RFC=(DETA1(KOFF+2)*PDTOP+DETA2(KOFF+2)*PDSL(I,J))           &
+     &         /(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))
+            DQL(KOFF+1)=-DQL(KOFF+2)*RFC
+            DWL(KOFF+1)=-DWL(KOFF+2)*RFC
+            DEL(KOFF+1)=-DEL(KOFF+2)*RFC
+          ENDIF
+        ENDIF
+!
+        DO K=KOFF+1,KTE
+          Q4(K)=Q3(K)+DQL(K)
+          W4(K)=W3(K)+DWL(K)
+          E4(K)=E3(K)+DEL(K)
+        ENDDO
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+        SUMPQ=0.
+        SUMNQ=0.
+        SUMPW=0.
+        SUMNW=0.
+        SUMPE=0.
+        SUMNE=0.
+!
+!***  ANTI-FILTERING LIMITERS
+!
+        DO 50 K=KTE-1,KOFF+2,-1
+!
+        DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+!
+        Q4P=Q4(K)
+        W4P=W4(K)
+        E4P=E4(K)
+!
+        LAP=LA(K)
+!
+        IF(LAP.NE.0)THEN
+          DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP                            &
+     &        +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
+          DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP                            &
+     &        +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
+!
+          AFRP=2.*AFR(K)*DPDN*DPDN/(DPDN+DPUP)
+          D2PQQ=((Q4(K+LAP)-Q4P)/DPDN                                   &
+     &          -(Q4P-Q4(K-LAP))/DPUP)*AFRP
+          D2PQW=((W4(K+LAP)-W4P)/DPDN                                   &
+     &          -(W4P-W4(K-LAP))/DPUP)*AFRP
+          D2PQE=((E4(K+LAP)-E4P)/DPDN                                   &
+     &          -(E4P-E4(K-LAP))/DPUP)*AFRP
+        ELSE
+          D2PQQ=0.
+          D2PQW=0.
+          D2PQE=0.
+        ENDIF
+!
+        QP=Q4P-D2PQQ
+        WP=W4P-D2PQW
+        EP=E4P-D2PQE
+!
+        Q00=Q3(K)
+        QP0=Q3(K+LAP)
+!
+        W00=W3(K)
+        WP0=W3(K+LAP)
+!
+        E00=E3(K)
+        EP0=E3(K+LAP)
+!
+        IF(LAP/=0)THEN
+          QP=MAX(QP,MIN(Q00,QP0))
+          QP=MIN(QP,MAX(Q00,QP0))
+          WP=MAX(WP,MIN(W00,WP0))
+          WP=MIN(WP,MAX(W00,WP0))
+          EP=MAX(EP,MIN(E00,EP0))
+          EP=MIN(EP,MAX(E00,EP0))
+        ENDIF
+!
+        DQP=QP-Q00
+        DWP=WP-W00
+        DEP=EP-E00
+!
+        DQL(K)=DQP
+        DWL(K)=DWP
+        DEL(K)=DEP
+!
+        DQP=DQP*DETAP
+        DWP=DWP*DETAP
+        DEP=DEP*DETAP
+!
+        IF(DQP>0.)THEN
+          SUMPQ=SUMPQ+DQP
+        ELSE
+          SUMNQ=SUMNQ+DQP
+        ENDIF
+!
+        IF(DWP>0.)THEN
+          SUMPW=SUMPW+DWP
+        ELSE
+          SUMNW=SUMNW+DWP
+        ENDIF
+!
+        IF(DEP>0.)THEN
+          SUMPE=SUMPE+DEP
+        ELSE
+          SUMNE=SUMNE+DEP
+        ENDIF
+!
+   50   CONTINUE
+!-----------------------------------------------------------------------
+        DQL(KOFF+1)=0.
+        DWL(KOFF+1)=0.
+        DEL(KOFF+1)=0.
+!
+        DQL(KTE)=0.
+        DWL(KTE)=0.
+        DEL(KTE)=0.
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+        IF(SUMPQ>1.E-9)THEN
+          RFACQK=-SUMNQ/SUMPQ
+        ELSE
+          RFACQK=1.
+        ENDIF
+!
+        IF(SUMPW>1.E-9)THEN
+          RFACWK=-SUMNW/SUMPW
+        ELSE
+          RFACWK=1.
+        ENDIF
+!
+        IF(SUMPE>1.E-9)THEN
+          RFACEK=-SUMNE/SUMPE
+        ELSE
+          RFACEK=1.
+        ENDIF
+!
+        IF(RFACQKCONSERVE_MAX)RFACQK=1.
+        IF(RFACWKCONSERVE_MAX)RFACWK=1.
+        IF(RFACEKCONSERVE_MAX)RFACEK=1.
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+        DO K=KTE,KOFF+1,-1
+          DQP=DQL(K)
+          IF(DQP>=0.)DQP=DQP*RFACQK
+          Q(I,K,J)=Q3(K)+DQP
+        ENDDO
+!-----------------------------------------------------------------------
+        DO K=KTE,KOFF+1,-1
+          DWP=DWL(K)
+          IF(DWP>=0.)DWP=DWP*RFACWK
+          CWM(I,K,J)=W3(K)+DWP
+        ENDDO
+!-----------------------------------------------------------------------
+        DO K=KTE,KOFF+1,-1
+          DEP=DEL(K)
+          IF(DEP>=0.)DEP=DEP*RFACEK
+          E3(K)=E3(K)+DEP
+        ENDDO
+!
+        HBM2IJ=HBM2(I,J)
+        Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ             &
+     &             +Q2(I,KTE,J)*(1.-HBM2IJ)
+        DO K=KTE-1,KOFF+2,-1
+          Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ           &
+     &             +Q2(I,K,J)*(1.-HBM2IJ)
+        ENDDO
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      ENDDO 
+!
+      ENDDO main_integration
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      END SUBROUTINE VAD2
+!-----------------------------------------------------------------------
+!
+!***********************************************************************
+      SUBROUTINE HAD2(                                                  &
+#if defined(DM_PARALLEL)
+     &                domdesc ,                                         &
+#endif
+     &                NTSD,DT,IDTAD,DX,DY                               &
+     &               ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                &
+     &               ,HTM,HBM2,HBM3,LMH                                 &
+     &               ,Q,Q2,CWM,U,V,Z,HYDRO                              &
+     &               ,N_IUP_H,N_IUP_V                                   &
+     &               ,N_IUP_ADH,N_IUP_ADV                               &
+     &               ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                       &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    HAD2        HORIZONTAL ADVECTION OF H2O AND TKE
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!
+! ABSTRACT:
+!     HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
+!     TO THE TENDENCIES OF WATER SUBSTANCE AND TKE AND THEN
+!     UPDATES THOSE VARIABLES.  AN ANTI-FILTERING TECHNIQUE IS USED.
+!
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC   - ORIGINATOR
+!   98-11-02  BLACK    - MODIFIED FOR DISTRIBUTED MEMORY
+!   99-03-17  TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
+!   02-02-06  BLACK    - CONVERTED TO WRF FORMAT
+!   02-09-06  WOLFE    - MORE CONVERSION TO GLOBAL INDEXING
+!   03-05-23  JANJIC   - ADDED SLOPE FACTOR
+!   04-11-23  BLACK    - THREADED
+!
+! USAGE: CALL HAD2 FROM SUBROUTINE SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
+! dimspec q in Registry/Registry.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,Q2
+!
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.530
+!
+#ifdef DM_PARALLEL
+      INTEGER :: DOMDESC
+#endif
+!
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
+      INTEGER :: N
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
+      REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
+#endif
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
+!
+      INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF           &
+     &                                             ,IFQA,IFQF           &
+     &                                             ,JFPA,JFPF           &
+     &                                             ,JFQA,JFQF
+!
+      REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ    &
+     &       ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0  &
+     &       ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q     &
+     &       ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC        &
+     &       ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ   &
+     &       ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0   &
+     &       ,WSTIJ
+!
+      DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4                  &
+     &                          ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST   &
+     &                                                  ,DQST,DVOL,DWST &
+     &                                                  ,E1,E2,Q1,W1
+      integer :: nunit,ier
+      save nunit
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      RDY=1./DY
+      SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
+      CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
+!
+      ADDT=REAL(IDTAD)*DT
+      ENH=ADDT/(08.*DY)
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS_P3,MYJE_P3
+      DO I=MYIS_P2,MYIE_P2
+        EMH (I,J)=ADDT/(08.*DX(I,J))
+        DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
+        E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
+        E2(I,KTE,J)=E1(I,KTE,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(e1x,htmikj,i,j,k)
+      DO J=MYJS_P3,MYJE_P3
+        DO K=KTS,KTE
+        DO I=MYIS_P2,MYIE_P2
+          DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+          HTMIKJ=HTM(I,K,J)
+          Q  (I,K,J)=MAX(Q  (I,K,J),EPSQ)*HTMIKJ
+          CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTMIKJ
+          Q1  (I,K,J)=Q  (I,K,J)
+          W1  (I,K,J)=CWM(I,K,J)
+        ENDDO
+        ENDDO
+!
+        DO K=KTE-1,KTS,-1
+        DO I=MYIS_P2,MYIE_P2
+          E1X=(Q2(I,K+1,J)+Q2(I,K,J))*0.5
+          E1(I,K,J)=MAX(E1X,EPSQ2)
+          E2(I,K,J)=E1(I,K,J)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
+      DO J=MYJS2_P1,MYJE2_P1
+      DO K=KTS,KTE
+      DO I=MYIS1_P1,MYIE1_P1
+!
+        TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1))     &
+     &      *EMH(I,J)*HBM2(I,J)
+        TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1))     &
+     &      *ENH*HBM2(I,J)
+!
+        SPP=-TTA-TTB
+        SQP= TTA-TTB
+!
+        IF(SPP<0.)THEN
+          JFP=-1
+        ELSE
+          JFP=1
+        ENDIF
+        IF(SQP<0.)THEN
+          JFQ=-1
+        ELSE
+          JFQ=1
+        ENDIF
+!
+        IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
+        IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
+!
+        JFPA(I,K,J)=J+JFP
+        JFQA(I,K,J)=J+JFQ
+!
+        IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
+        IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
+!
+        JFPF(I,K,J)=J-JFP
+        JFQF(I,K,J)=J-JFQ
+!
+!-----------------------------------------------------------------------
+        IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
+          DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
+          DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
+!
+          IF(ABS(DZA)>SLOPAC)THEN
+            SSA=DZA*SPP
+            IF(SSA>CRIT)THEN
+              SPP=0. !spp*.1
+            ENDIF
+          ENDIF
+!
+          IF(ABS(DZB)>SLOPAC)THEN
+            SSB=DZB*SQP
+            IF(SSB>CRIT)THEN
+              SQP=0. !sqp*.1
+            ENDIF
+          ENDIF
+!
+        ENDIF
+!-----------------------------------------------------------------------
+        SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
+        SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
+        FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J)                           &
+     &             *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
+        PP=ABS(SPP)
+        QP=ABS(SQP)
+!
+        AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
+        AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
+!
+        Q1(I,K,J)=(Q  (IFPA(I,K,J),K,JFPA(I,K,J))-Q  (I,K,J))*PP        &
+     &           +(Q  (IFQA(I,K,J),K,JFQA(I,K,J))-Q  (I,K,J))*QP        &
+     &           +(Q  (I,K,J-2)+Q  (I,K,J+2)                            &
+     &            -Q  (I-1,K,J)-Q  (I+1,K,J))*FPQ                       &
+     &           +Q(I,K,J)
+!
+        W1(I,K,J)=(CWM(IFPA(I,K,J),K,JFPA(I,K,J))-CWM(I,K,J))*PP        &
+     &           +(CWM(IFQA(I,K,J),K,JFQA(I,K,J))-CWM(I,K,J))*QP        &
+     &           +(CWM(I,K,J-2)+CWM(I,K,J+2)                            &
+     &            -CWM(I-1,K,J)-CWM(I+1,K,J))*FPQ                       &
+     &           +CWM(I,K,J)
+!
+        E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP        &
+     &           +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP        &
+     &           +(E1 (I,K,J-2)+E1 (I,K,J+2)                            &
+     &            -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ                       &
+     &           +E1(I,K,J)
+!
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        XSUMS(1,K)=0.
+        XSUMS(2,K)=0.
+        XSUMS(3,K)=0.
+        XSUMS(4,K)=0.
+        XSUMS(5,K)=0.
+        XSUMS(6,K)=0.
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!***  ANTI-FILTERING LIMITERS
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME 
+        DO K=KMS,KME 
+        DO I=IMS,IME 
+          XSUMS_L(I,K,J,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JDS,JDE 
+        DO K=KDS,KDE 
+        DO I=IDS,IDE 
+          XSUMS_G(I,K,J,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+#endif
+!-----------------------------------------------------------------------
+      DO 150 J=MYJS2,MYJE2
+      DO 150 K=KTS,KTE
+      DO 150 I=MYIS1,MYIE1
+!
+      DVOLP=DVOL(I,K,J)
+      Q1IJ =Q1(I,K,J)
+      W1IJ =W1(I,K,J)
+      E2IJ =E2(I,K,J)
+!
+      HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
+      HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
+!
+      D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ                         &
+     &      -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J)))                        &
+     &      *HAFP                                                       &
+     &     +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ                         &
+     &      -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J)))                        &
+     &      *HAFQ
+!
+      D2PQW=(W1(IFPA(I,K,J),K,JFPA(I,K,J))-W1IJ                         &
+     &      -W1IJ+W1(IFPF(I,K,J),K,JFPF(I,K,J)))                        &
+     &      *HAFP                                                       &
+     &     +(W1(IFQA(I,K,J),K,JFQA(I,K,J))-W1IJ                         &
+     &      -W1IJ+W1(IFQF(I,K,J),K,JFQF(I,K,J)))                        &
+     &      *HAFQ
+!
+      D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ                         &
+     &      -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J)))                        &
+     &      *HAFP                                                       &
+     &     +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ                         &
+     &      -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J)))                        &
+     &      *HAFQ
+!
+      QSTIJ=Q1IJ-D2PQQ
+      WSTIJ=W1IJ-D2PQW
+      ESTIJ=E2IJ-D2PQE
+!
+      Q00=Q  (I          ,K          ,J)
+      QP0=Q  (IFPA(I,K,J),K,JFPA(I,K,J))
+      Q0Q=Q  (IFQA(I,K,J),K,JFQA(I,K,J))
+!
+      W00=CWM(I          ,K          ,J)
+      WP0=CWM(IFPA(I,K,J),K,JFPA(I,K,J))
+      W0Q=CWM(IFQA(I,K,J),K,JFQA(I,K,J))
+!
+      E00=E1 (I          ,K          ,J)
+      EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
+      E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
+!
+      QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
+      QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
+      WSTIJ=MAX(WSTIJ,MIN(W00,WP0,W0Q))
+      WSTIJ=MIN(WSTIJ,MAX(W00,WP0,W0Q))
+      ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
+      ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
+!
+      DQSTIJ=QSTIJ-Q(I,K,J)
+      DWSTIJ=WSTIJ-CWM(I,K,J)
+      DESTIJ=ESTIJ-E1(I,K,J)
+!
+      DQST(I,K,J)=DQSTIJ
+      DWST(I,K,J)=DWSTIJ
+      DEST(I,K,J)=DESTIJ
+!
+      DQSTIJ=DQSTIJ*DVOLP
+      DWSTIJ=DWSTIJ*DVOLP
+      DESTIJ=DESTIJ*DVOLP
+!
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+        XSUMS_L(I,K,J,N)=0.
+      ENDDO
+!
+      IF(DQSTIJ>0.)THEN
+        XSUMS_L(I,K,J,1)=DQSTIJ
+      ELSE
+        XSUMS_L(I,K,J,2)=DQSTIJ
+      ENDIF
+!
+      IF(DWSTIJ>0.)THEN
+        XSUMS_L(I,K,J,3)=DWSTIJ
+      ELSE
+        XSUMS_L(I,K,J,4)=DWSTIJ
+      ENDIF
+!
+      IF(DESTIJ>0.)THEN
+        XSUMS_L(I,K,J,5)=DESTIJ
+      ELSE
+        XSUMS_L(I,K,J,6)=DESTIJ
+      ENDIF
+#else
+      IF(DQSTIJ>0.)THEN
+        XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
+      ELSE
+        XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
+      ENDIF
+!
+      IF(DWSTIJ>0.)THEN
+        XSUMS(3,K)=XSUMS(3,K)+DWSTIJ
+      ELSE
+        XSUMS(4,K)=XSUMS(4,K)+DWSTIJ
+      ENDIF
+!
+      IF(DESTIJ>0.)THEN
+        XSUMS(5,K)=XSUMS(5,K)+DESTIJ
+      ELSE
+        XSUMS(6,K)=XSUMS(6,K)+DESTIJ
+      ENDIF
+#endif
+!
+  150 CONTINUE
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+        CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N)           &
+     &,                                XSUMS_G(1,1,1,N),DOMDESC         & 
+     &,                               'xyz','xzy'                       &
+     &,                                IDS,IDE,KDS,KDE,JDS,JDE          &    
+     &,                                IMS,IME,KMS,KME,JMS,JME          &
+     &,                                ITS,ITE,KTS,KTE,JTS,JTE )
+      ENDDO
+!
+      GSUMS=0.
+!
+      IF(WRF_DM_ON_MONITOR())THEN
+        DO N=1,6
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=JDS,JDE
+          DO K=KDS,KDE
+          DO I=IDS,IDE
+            GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+
+      CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*6*(KDE-KDS+1) )
+
+#else
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# ifdef DM_PARALLEL
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1)                      &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      GSUMS=XSUMS
+# endif
+#endif
+!
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+!     if(mype==0)then
+!       if(ntsd==0)then
+!!        call int_get_fresh_handle(nunit)
+!!        close(nunit)
+!         nunit=56
+!         open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
+!       endif
+!     endif
+      DO K=KTS,KTE
+!       if(mype==0)then
+!         write(nunit)(gsums(i,k),i=1,6)
+!       endif
+!
+!-----------------------------------------------------------------------
+        SUMPQ=GSUMS(1,K)
+        SUMNQ=GSUMS(2,K)
+        SUMPW=GSUMS(3,K)
+        SUMNW=GSUMS(4,K)
+        SUMPE=GSUMS(5,K)
+        SUMNE=GSUMS(6,K)
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+        IF(SUMPQ>1.)THEN
+          RFACQK=-SUMNQ/SUMPQ
+        ELSE
+          RFACQK=1.
+        ENDIF
+!
+        IF(SUMPW>1.)THEN
+          RFACWK=-SUMNW/SUMPW
+        ELSE
+          RFACWK=1.
+        ENDIF
+!
+        IF(SUMPE>1.)THEN
+          RFACEK=-SUMNE/SUMPE
+        ELSE
+          RFACEK=1.
+        ENDIF
+!
+        IF(RFACQKCONSERVE_MAX)RFACQK=1.
+        IF(RFACWKCONSERVE_MAX)RFACWK=1.
+        IF(RFACEKCONSERVE_MAX)RFACEK=1.
+!
+        RFACQ(K)=RFACQK
+        RFACW(K)=RFACWK
+        RFACE(K)=RFACEK
+!
+      ENDDO
+!     if(mype==0.and.ntsd==181)close(nunit)
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dqstij,i,j,k,rfacqk,rfqij)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          RFACQK=RFACQ(K)
+          IF(RFACQK<1.)THEN
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,K,J)
+              RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
+              IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
+              Q(I,K,J)=Q(I,K,J)+DQSTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,K,J)
+              RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
+              IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
+              Q(I,K,J)=Q(I,K,J)+DQSTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dwstij,i,j,k,rfacwk,rfwij)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          RFACWK=RFACW(K)
+          IF(RFACWK<1.)THEN
+            DO I=MYIS1,MYIE1
+              DWSTIJ=DWST(I,K,J)
+              RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
+              IF(DWSTIJ>=0.)DWSTIJ=DWSTIJ*RFWIJ
+              CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DWSTIJ=DWST(I,K,J)
+              RFWIJ=HBM2(I,J)*(RFACWK-1.)+1.
+              IF(DWSTIJ<0.)DWSTIJ=DWSTIJ/RFWIJ
+              CWM(I,K,J)=CWM(I,K,J)+DWSTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(destij,i,j,k,rfacek,rfeij)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          RFACEK=RFACE(K)
+          IF(RFACEK<1.)THEN
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,K,J)
+              RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
+              IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
+              E1(I,K,J)=E1(I,K,J)+DESTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,K,J)
+              RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
+              IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
+              E1(I,K,J)=E1(I,K,J)+DESTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS,MYJE
+      DO K=KTS,KTE
+      DO I=MYIS,MYIE
+        Q  (I,K,J)=MAX(Q  (I,K,J),EPSQ)*HTM(I,K,J)
+        CWM(I,K,J)=MAX(CWM(I,K,J),CLIMIT)*HTM(I,K,J)
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2)            &
+     &             *HTM(I,KTE,J)
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,koff)
+      DO J=MYJS,MYJE
+      DO K=KTE-1,KTS+1,-1
+      DO I=MYIS,MYIE
+        KOFF=KTE-LMH(I,J)
+        IF(K>KOFF+1)THEN
+          Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2)          &
+     &             *HTM(I,K,J)
+        ELSE
+          Q2(I,K,J)=Q2(I,K+1,J)
+        ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE HAD2
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE VAD2_DRY(NTSD,DT,IDTAD,DX,DY                           &
+     &                   ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP            &
+     &                   ,HBM2,LMH                                      &
+     &                   ,Q2,PETDT                                      &
+     &                   ,N_IUP_H,N_IUP_V                               &
+     &                   ,N_IUP_ADH,N_IUP_ADV                           &
+     &                   ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                   &
+     &                   ,IHE,IHW,IVE,IVW,INDX3_WRK                     &
+     &                   ,IDS,IDE,JDS,JDE,KDS,KDE                       &
+     &                   ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                   ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    VAD2_DRY    VERTICAL ADVECTION OF TKE
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!
+! ABSTRACT:
+!     VAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL AND VERTICAL
+!     ADVECTION TO THE TENDENCY OF TKE AND THEN UPDATES IT.
+!     AN ANTI-FILTERING TECHNIQUE IS USED.
+!
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC   - ORIGINATOR
+!   98-11-02  BLACK    - MODIFIED FOR DISTRIBUTED MEMORY
+!   99-03-17  TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
+!   02-02-06  BLACK    - CONVERTED TO WRF FORMAT
+!   02-09-06  WOLFE    - MORE CONVERSION TO GLOBAL INDEXING
+!   04-11-23  BLACK    - THREADED
+!
+! USAGE: CALL VAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+! NMM_MAX_DIM is set in configure.wrf and must agree with
+! the value of dimspec q in the Registry/Registry
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.525
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      REAL :: ADDT,AFRP,D2PQE,DEP,DETAP,DPDN,DPUP,DQP                   &
+     &       ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ                           &
+     &       ,RFACEK,RFC,RR,SUMNE,SUMPE
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,PETDTK,RFACE
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      ADDT=REAL(IDTAD)*DT
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(afr,afrp,bot,d2pqe,del,dep,detap,dpdn,dpup,e00,e3        &
+!$omp&        ,e4,e4p,ep,ep0,hbm2ij,i,j,k,koff,la,lap,llap,petdtk       &
+!$omp&        ,rfacek,rfc,rr,sumne,sumpe,top)
+      main_integration : DO J=MYJS2,MYJE2
+!
+      DO I=MYIS1_P1,MYIE1_P1
+!-----------------------------------------------------------------------
+        KOFF=KTE-LMH(I,J)
+!
+        E3(KTE)=Q2(I,KTE,J)*0.5
+!
+        DO K=KTE-1,KOFF+1,-1
+          E3(K)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
+        ENDDO
+!
+        DO K=KOFF+1,KTE
+          E4(K)=E3(K)
+        ENDDO
+!
+        PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
+!
+        DO K=KTE-1,KOFF+2,-1
+          PETDTK(K)=(PETDT(I,K+1,J)+PETDT(I,K,J))*0.5
+        ENDDO
+!
+        PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
+!-----------------------------------------------------------------------
+        HADDT=-ADDT*HBM2(I,J)
+!
+        DO K=KTE,KOFF+1,-1
+          RR=PETDTK(K)*HADDT
+!
+          IF(RR<0.)THEN
+            LAP=1
+          ELSE
+            LAP=-1
+          ENDIF
+!
+          LA(K)=LAP
+          LLAP=K+LAP
+!
+          TOP=.FALSE.
+          BOT=.FALSE.
+!
+          IF(LLAP>0.AND.LLAP0.)THEN
+          SUMPE=SUMPE+DEP
+        ELSE
+          SUMNE=SUMNE+DEP
+        ENDIF
+!
+   50   CONTINUE
+!-----------------------------------------------------------------------
+        DEL(KTE)=0.
+!
+        DEL(KOFF+1)=0.
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+        IF(SUMPE>1.E-9)THEN
+          RFACEK=-SUMNE/SUMPE
+        ELSE
+          RFACEK=1.
+        ENDIF
+!
+        IF(RFACEKCONSERVE_MAX)RFACEK=1.
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+        DO K=KOFF+1,KTE
+          DEP=DEL(K)
+          IF(DEP>=0.)DEP=DEP*RFACEK
+          E3(K)=E3(K)+DEP
+        ENDDO
+!
+        HBM2IJ=HBM2(I,J)
+        Q2(I,KTE,J)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ             &
+     &             +Q2(I,KTE,J)*(1.-HBM2IJ)
+        DO K=KTE-1,KOFF+2
+          Q2(I,K,J)=MAX(E3(K)+E3(K)-Q2(I,K+1,J),EPSQ2)*HBM2IJ           &
+     &             +Q2(I,K,J)*(1.-HBM2IJ)
+        ENDDO
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      ENDDO 
+!
+      ENDDO main_integration
+!-----------------------------------------------------------------------
+!----------------------------------------------------------------------
+      END SUBROUTINE VAD2_DRY
+!----------------------------------------------------------------------
+!
+!***********************************************************************
+      SUBROUTINE HAD2_DRY(NTSD,DT,IDTAD,DX,DY                           &
+     &                   ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP            &
+     &                   ,HTM,HBM2,HBM3,LMH                             &
+     &                   ,Q2,U,V,Z,HYDRO                                &
+     &                   ,N_IUP_H,N_IUP_V                               &
+     &                   ,N_IUP_ADH,N_IUP_ADV                           &
+     &                   ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                   &
+     &                   ,IHE,IHW,IVE,IVW,INDX3_WRK                     &
+     &                   ,IDS,IDE,JDS,JDE,KDS,KDE                       &
+     &                   ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                   ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    HAD2_DRY    HORIZONTAL ADVECTION OF TKE
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!
+! ABSTRACT:
+!     HAD2 CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
+!     TO THE TENDENCIES OF TKE AND UPDATES IT.
+!     AN ANTI-FILTERING TECHNIQUE IS USED.
+!
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC   - ORIGINATOR
+!   98-11-02  BLACK    - MODIFIED FOR DISTRIBUTED MEMORY
+!   99-03-17  TUCCILLO - INCORPORATED MPI_ALLREDUCE FOR GLOBAL SUM
+!   02-02-06  BLACK    - CONVERTED TO WRF FORMAT
+!   02-09-06  WOLFE    - MORE CONVERSION TO GLOBAL INDEXING
+!   03-05-23  JANJIC   - ADDED SLOPE FACTOR
+!   04-11-23  BLACK    - THREADED
+!
+! USAGE: CALL HAD2_DRY FROM SUBROUTINE DIGITAL_FILTER
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+! NMM_MAX_DIM is set in configure.wrf and must agree with
+! the value of dimspec q in the Registry/Registry
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q2
+!
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+!----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.530
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP
+!
+      INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF           &
+     &                                             ,IFQA,IFQF           &
+     &                                             ,JFPA,JFPF           &
+     &                                             ,JFQA,JFQF
+!
+      REAL :: ADDT,AFRP,CRIT,D2PQE,DEP,DESTIJ,DVOLP,DZA,DZB             &
+     &       ,E00,E0Q,E2IJ,E4P,ENH,EP,EP0,ESTIJ,FPQ                     &
+     &       ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00                       &
+     &       ,QP,RDY,RFACEK,RFC,RFEIJ,RR                                &
+     &       ,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMPE,TTA,TTB
+!
+      REAL,DIMENSION(2,KTE-KTS+1) :: GSUMS,XSUMS
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,E3,E4,RFACE
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: AFP,AFQ,DEST,DVOL      &
+     &                                          ,E1,E2  
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+      RDY=1./DY
+      SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
+      CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
+!
+      ADDT=REAL(IDTAD)*DT
+      ENH=ADDT/(08.*DY)
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS_P3,MYJE_P3
+      DO I=MYIS_P2,MYIE_P2
+        EMH (I,J)=ADDT/(08.*DX(I,J))
+        DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
+        E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
+        E2(I,KTE,J)=E1(I,KTE,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS_P3,MYJE_P3
+!
+        DO K=KTS,KTE
+        DO I=MYIS_P2,MYIE_P2
+          DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+        ENDDO
+        ENDDO
+!
+        DO K=KTE-1,KTS,-1
+        DO I=MYIS_P2,MYIE_P2
+          E1(I,K,J)=MAX((Q2(I,K+1,J)+Q2(I,K,J))*0.5,EPSQ2)
+          E2(I,K,J)=E1(I,K,J)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,spp,sqp,ssa,ssb,tta,ttb)
+      DO J=MYJS2_P1,MYJE2_P1
+      DO K=KTS,KTE
+      DO I=MYIS1_P1,MYIE1_P1
+!
+        TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1))     &
+     &      *EMH(I,J)*HBM2(I,J)
+        TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1))     &
+     &      *ENH*HBM2(I,J)
+!
+        SPP=-TTA-TTB
+        SQP= TTA-TTB
+!
+        IF(SPP<0.)THEN
+          JFP=-1
+        ELSE
+          JFP=1
+        ENDIF
+        IF(SQP<0.)THEN
+          JFQ=-1
+        ELSE
+          JFQ=1
+        ENDIF
+!
+        IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
+        IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
+!
+        JFPA(I,K,J)=J+JFP
+        JFQA(I,K,J)=J+JFQ
+!
+        IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
+        IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
+!
+        JFPF(I,K,J)=J-JFP
+        JFQF(I,K,J)=J-JFQ
+!
+!------------------------------------------------------------------------
+        IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
+          DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
+          DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
+!
+          IF(ABS(DZA)>SLOPAC)THEN
+            SSA=DZA*SPP
+            IF(SSA>CRIT)THEN
+              SPP=0. !spp*.1
+            ENDIF
+          ENDIF
+!
+          IF(ABS(DZB)>SLOPAC)THEN
+            SSB=DZB*SQP
+            IF(SSB>CRIT)THEN
+              SQP=0. !sqp*.1
+            ENDIF
+          ENDIF
+!
+        ENDIF
+!-----------------------------------------------------------------------
+        SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
+        SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
+        FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J)                           &
+     &             *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
+        PP=ABS(SPP)
+        QP=ABS(SQP)
+!
+        AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
+        AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
+!
+        E2(I,K,J)=(E1 (IFPA(I,K,J),K,JFPA(I,K,J))-E1 (I,K,J))*PP        &
+     &           +(E1 (IFQA(I,K,J),K,JFQA(I,K,J))-E1 (I,K,J))*QP        &
+     &           +(E1 (I,K,J-2)+E1 (I,K,J+2)                            &
+     &            -E1 (I-1,K,J)-E1 (I+1,K,J))*FPQ                       &
+     &           +E1(I,K,J)
+!
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        XSUMS(1,K)=0.
+        XSUMS(2,K)=0.
+      ENDDO
+!
+!--------------ANTI-FILTERING LIMITERS----------------------------------
+!
+      DO 150 J=MYJS2,MYJE2
+      DO 150 K=KTS,KTE
+      DO 150 I=MYIS1,MYIE1
+!
+      DVOLP=DVOL(I,K,J)
+      E2IJ =E2(I,K,J)
+!
+      HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
+      HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
+!
+      D2PQE=(E2(IFPA(I,K,J),K,JFPA(I,K,J))-E2IJ                         &
+     &      -E2IJ+E2(IFPF(I,K,J),K,JFPF(I,K,J)))                        &
+     &      *HAFP                                                       &
+     &     +(E2(IFQA(I,K,J),K,JFQA(I,K,J))-E2IJ                         &
+     &      -E2IJ+E2(IFQF(I,K,J),K,JFQF(I,K,J)))                        &
+     &      *HAFQ
+!
+      ESTIJ=E2IJ-D2PQE
+!
+      E00=E1 (I          ,K          ,J)
+      EP0=E1 (IFPA(I,K,J),K,JFPA(I,K,J))
+      E0Q=E1 (IFQA(I,K,J),K,JFQA(I,K,J))
+!
+      ESTIJ=MAX(ESTIJ,MIN(E00,EP0,E0Q))
+      ESTIJ=MIN(ESTIJ,MAX(E00,EP0,E0Q))
+!
+      DESTIJ=ESTIJ-E1(I,K,J)
+      DEST(I,K,J)=DESTIJ
+!
+      DESTIJ=DESTIJ*DVOLP
+!
+      IF(DESTIJ>0.)THEN
+        XSUMS(1,K)=XSUMS(1,K)+DESTIJ
+      ELSE
+        XSUMS(2,K)=XSUMS(2,K)+DESTIJ
+      ENDIF
+!
+  150 CONTINUE
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+#ifdef DM_PARALLEL
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL MPI_ALLREDUCE(XSUMS,GSUMS,2*(KTE-KTS+1),MPI_REAL,MPI_SUM     &
+     &                  ,MPI_COMM_COMP,IRECV)
+#else
+      GSUMS=XSUMS
+#endif
+!
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+        SUMPE=GSUMS(1,K)
+        SUMNE=GSUMS(2,K)
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+        IF(SUMPE>1.)THEN
+          RFACEK=-SUMNE/SUMPE
+        ELSE
+          RFACEK=1.
+        ENDIF
+!
+        IF(RFACEKCONSERVE_MAX)RFACEK=1.
+!
+        RFACE(K)=RFACEK
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(destij,i,j,k,rfacek,rfeij)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          RFACEK=RFACE(K)
+          IF(RFACEK<1.)THEN
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,K,J)
+              RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
+              IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
+              E1(I,K,J)=E1(I,K,J)+DESTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,K,J)
+              RFEIJ=HBM2(I,J)*(RFACEK-1.)+1.
+              IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
+              E1(I,K,J)=E1(I,K,J)+DESTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        Q2(I,KTE,J)=MAX(E1(I,KTE,J)+E1(I,KTE,J)-EPSQ2,EPSQ2)            &
+     &             *HTM(I,KTE,J)
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,koff)
+      DO J=MYJS,MYJE
+      DO K=KTE-1,KTS+1,-1
+      DO I=MYIS,MYIE
+        KOFF=KTE-LMH(I,J)
+        IF(K>KOFF+1)THEN
+          Q2(I,K,J)=MAX(E1(I,K,J)+E1(I,K,J)-Q2(I,K+1,J),EPSQ2)          &
+     &             *HTM(I,K,J)
+        ELSE
+          Q2(I,K,J)=Q2(I,K+1,J)
+        ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE HAD2_DRY
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!^L
+! New routines added by Georg Grell to handle advection more like ARW
+! core.  Instead of VAD2/HAD2 that advect TKE, specific humidity, and
+! condensed water species all in one routine, we call VAD2/HAD2_SCAL
+! with multidimensioned arrays to advect each variable.  For purposes
+! here, solve_nmm.F calls this routine once for TKE, then again for
+! all the species held in the moist array (qv, qc, qi, qr, qs, qg),
+! then call again for number concentrations held in scalar array (qni).
+! The dummy argument lstart is the starting index of the multidimensioned
+! array for starting the advection since the 1st index of moist and
+! scalar are actually empty placeholders (and the 2nd element is vapor,
+! then qc, etc.)  When calling with single 3D array (like TKE), just
+! set NUM_SCAL=1 and lstart=1.  The variable to advect is called SCAL
+! herein.
+!***********************************************************************
+      SUBROUTINE VAD2_SCAL(NTSD,DT,IDTAD,DX,DY                               &
+     &               ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                &
+     &               ,HBM2,LMH                                          &
+     &               ,SCAL,PETDT                                        &
+     &               ,N_IUP_H,N_IUP_V                                   &
+     &               ,N_IUP_ADH,N_IUP_ADV                               &
+     &               ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                       &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+     &               ,NUM_SCAL,lstart                                   &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    VAD2_SCAL   VERTICAL ADVECTION OF SCALARS
+!
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!            GRELL,PECKHAM   ORG: NOAA/FSL   DATE: 05-02-03
+!     
+! ABSTRACT:          
+!     VAD2_SCAL CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION   
+!     TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN UPDATES           
+!     THOSE VARIABLES.  AN ANTI-FILTERING TECHNIQUE IS USED.            
+!    
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC           - ORIGINATOR
+!   05-02-03  GRELL,PECKHAM    - MODIFIED FOR SCALARS                   
+!    
+! USAGE: CALL VAD2_SCAL FROM SUBROUTINE SOLVE_NMM                       
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!                
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:      
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+
+      INTEGER,INTENT(IN) :: NUM_SCAL, lstart
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+! NMM_MAX_DIM is set in configure.wrf and must agree with
+! the value of dimspec q in the Registry/Registry
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!    
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,1:NUM_SCAL),INTENT(INOUT) :: SCAL
+!
+!----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.525
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP, L
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DPDN,DPUP,DQP     &
+     &       ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ                           &
+     &       ,Q00,Q4P,QP,QP0                                            &
+     &       ,RFACEK,RFACQK,RFACWK,RFC,RR                               &
+     &       ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW                       &
+     &       ,W00,W4P,WP,WP0
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4,PETDTK           &
+     &                          ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!     
+      ADDT=REAL(IDTAD)*DT
+!     
+!-----------------------------------------------------------------------
+!     
+!$omp parallel do                                                       &
+!$omp& private(afr,afrp,bot,d2pqe,d2pqq,d2pqw,del,dep,detap,dpdn,dpup   &
+!$omp&        ,dql,dqp,dwl,dwp,e00,e3,e4,e4p,ep,ep0,haddt,i,j,k,koff    &
+!$omp&        ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacek,rfacqk    &
+!$omp&        ,rfacwk,rfc,rr,sumne,sumnq,sumnw,sumpe,sumpq,sumpw,top    &
+!$omp&        ,w00,w3,w4,w4p,wp,wp0)
+
+      scalar_loop : DO L=lstart,NUM_SCAL
+      main_integration : DO J=MYJS2,MYJE2
+!
+      DO I=MYIS1_P1,MYIE1_P1
+!-----------------------------------------------------------------------
+        KOFF=KTE-LMH(I,J)
+!
+        DO K=KOFF+1,KTE
+!         Q3(K)=MAX(SCAL(I,K,J,L),EPSILSCALAR)
+          Q3(K)=SCAL(I,K,J,L)
+          Q4(K)=Q3(K)
+        ENDDO
+!
+        PETDTK(KTE)=PETDT(I,KTE-1,J)*0.5
+!
+        DO K=KTE-1,KOFF+2,-1
+          PETDTK(K)=(PETDT(I,K,J)+PETDT(I,K-1,J))*0.5
+        ENDDO
+!
+        PETDTK(KOFF+1)=PETDT(I,KOFF+1,J)*0.5
+!-----------------------------------------------------------------------
+        HADDT=-ADDT*HBM2(I,J)
+!
+        DO K=KTE,KOFF+1,-1
+          RR=PETDTK(K)*HADDT
+!
+          IF(RR<0.)THEN
+            LAP=1
+          ELSE
+            LAP=-1
+          ENDIF
+!
+          LA(K)=LAP
+          LLAP=K+LAP
+!
+          TOP=.FALSE.
+          BOT=.FALSE.
+!
+          IF(LLAP>KOFF.AND.LLAP0)THEN
+            RFC=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDSL(I,J))             &
+     &         /(DETA1(KTE  )*PDTOP+DETA2(KTE  )*PDSL(I,J))
+            DQL(KTE)=-DQL(KTE+1)*RFC
+          ENDIF
+        ENDIF
+!       
+        IF(BOT)THEN
+          IF(LA(KOFF+2)<0)THEN
+            RFC=(DETA1(KOFF+2)*PDTOP+DETA2(KOFF+2)*PDSL(I,J))           &
+     &         /(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))
+            DQL(KOFF+1)=-DQL(KOFF+2)*RFC
+          ENDIF
+        ENDIF
+!       
+        DO K=KOFF+1,KTE
+          Q4(K)=Q3(K)+DQL(K)
+        ENDDO
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+        SUMPQ=0.
+        SUMNQ=0.
+!
+!***  ANTI-FILTERING LIMITERS
+!       
+        DO 50 K=KTE-1,KOFF+2,-1
+!       
+        DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+!       
+        Q4P=Q4(K)
+!       
+        LAP=LA(K)
+!       
+        IF(LAP.NE.0)THEN
+          DPDN=(AETA1(K+LAP)-AETA1(K))*PDTOP                            &
+     &        +(AETA2(K+LAP)-AETA2(K))*PDSL(I,J)
+          DPUP=(AETA1(K)-AETA1(K-LAP))*PDTOP                            &
+     &        +(AETA2(K)-AETA2(K-LAP))*PDSL(I,J)
+!
+          AFRP=2.*AFR(K)*DPDN*DPDN/(DPDN+DPUP)
+          D2PQQ=((Q4(K+LAP)-Q4P)/DPDN                                   &
+     &          -(Q4P-Q4(K-LAP))/DPUP)*AFRP
+        ELSE
+          D2PQQ=0.
+        ENDIF
+!
+        QP=Q4P-D2PQQ
+!
+        Q00=Q3(K)
+        QP0=Q3(K+LAP)
+!
+        IF(LAP/=0)THEN
+          QP=MAX(QP,MIN(Q00,QP0))
+          QP=MIN(QP,MAX(Q00,QP0))
+        ENDIF
+!
+        DQP=QP-Q00
+!
+        DQL(K)=DQP
+!
+        DQP=DQP*DETAP
+!
+        IF(DQP>0.)THEN
+          SUMPQ=SUMPQ+DQP
+        ELSE
+          SUMNQ=SUMNQ+DQP
+        ENDIF
+!
+   50   CONTINUE
+!-----------------------------------------------------------------------
+        DQL(KOFF+1)=0.
+!
+        DQL(KTE)=0.
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+        IF(SUMPQ>1.E-9)THEN
+          RFACQK=-SUMNQ/SUMPQ
+        ELSE  
+          RFACQK=1.
+        ENDIF
+!         
+        IF(RFACQKCONSERVE_MAX)RFACQK=1.
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+        DO K=KTE,KOFF+1,-1
+          DQP=DQL(K)
+          IF(DQP>=0.)DQP=DQP*RFACQK
+          SCAL(I,K,J,L)=Q3(K)+DQP
+        ENDDO
+!
+!       HBM2IJ=HBM2(I,J)
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      ENDDO
+
+!       
+      ENDDO main_integration
+      ENDDO scalar_loop
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      END SUBROUTINE VAD2_SCAL
+!-----------------------------------------------------------------------
+!         
+!***********************************************************************
+      SUBROUTINE HAD2_SCAL(                                             &
+#if defined(DM_PARALLEL)
+     &                domdesc ,                                         &
+#endif  
+     &                NTSD,DT,IDTAD,DX,DY                               &
+     &               ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                &
+     &               ,HTM,HBM2,HBM3,LMH                                 &
+     &               ,SCAL,U,V,Z,HYDRO                              &
+     &               ,N_IUP_H,N_IUP_V                                   &
+     &               ,N_IUP_ADH,N_IUP_ADV                               &
+     &               ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                       &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+     &               ,NUM_SCAL,lstart                                   &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    HAD2_SCAL   HORIZONTAL ADVECTION OF SCALAR
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-07-19
+!            GRELL,PECKHAM   ORG: NOAA/FSL   DATE: 05-02-03
+!
+! ABSTRACT:
+!     HAD2_SCAL CALCULATES THE CONTRIBUTION OF THE HORIZONTAL ADVECTION
+!     TO THE TENDENCIES OF SCALAR SUBSTANCES AND THEN
+!     UPDATES THOSE VARIABLES.  AN ANTI-FILTERING TECHNIQUE IS USED.
+!
+! PROGRAM HISTORY LOG:
+!   96-07-19  JANJIC           - ORIGINATOR
+!   05-01-03  GRELL,PECKKHAM   - MODIFIED FOR SCALAR
+!
+! USAGE: CALL HAD2_SCAL FROM SUBROUTINE SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST
+!
+!   OUTPUT FILES:
+!       NONE
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!    
+      IMPLICIT NONE  
+!    
+!-----------------------------------------------------------------------
+!    
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+
+      INTEGER,INTENT(IN) :: NUM_SCAL, lstart
+!   
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: N_IUP_H,N_IUP_V          &
+     &                                        ,N_IUP_ADH,N_IUP_ADV
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IUP_H,IUP_V      &
+     &                                                ,IUP_ADH,IUP_ADV
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
+! dimspec q in Registry/Registry.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!   
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!   
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!   
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!   
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!     
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,HBM2,HBM3,PDSL
+!     
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V,Z
+! 
+!!!!!   q is local. CORRECT DIMENSION???
+!jjjj
+!!!!!      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME)               :: Q
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: Q
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_SCAL),INTENT(INOUT) :: SCAL
+!
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      REAL,PARAMETER :: FF1=0.530
+!
+#ifdef DM_PARALLEL
+      INTEGER :: DOMDESC
+#endif
+!
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
+      INTEGER :: N
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,6) :: XSUMS_L
+      REAL,DIMENSION(IDS:IDE,KDS:KDE,JDS:JDE,6) :: XSUMS_G
+#endif
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,KOFF,LAP,LLAP,MPI_COMM_COMP, L
+!
+      INTEGER,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: IFPA,IFPF           &
+     &                                             ,IFQA,IFQF           &
+     &                                             ,JFPA,JFPF           &
+     &                                             ,JFQA,JFQF
+!
+      REAL :: ADDT,AFRP,CRIT,D2PQE,D2PQQ,D2PQW,DEP,DESTIJ,DQP,DQSTIJ    &
+     &       ,DVOLP,DWP,DWSTIJ,DZA,DZB,E00,E0Q,E1X,E2IJ,E4P,ENH,EP,EP0  &
+     &       ,ESTIJ,FPQ,HAFP,HAFQ,HBM2IJ,HM,HTMIKJ,PP,PPQ00,Q00,Q0Q     &
+     &       ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACEK,RFACQK,RFACWK,RFC        &
+     &       ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNE,SUMNQ   &
+     &       ,SUMNW,SUMPE,SUMPQ,SUMPW,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0   &
+     &       ,WSTIJ
+!
+      DOUBLE PRECISION,DIMENSION(6,KTE-KTS+1) :: GSUMS,XSUMS
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4                  &
+     &                          ,RFACE,RFACQ,RFACW,Q3,Q4,W3,W4
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: DARE,EMH
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,JTS-5:JTE+5) :: AFP,AFQ,DEST   &
+     &                                                  ,DQST,DVOL,DWST &
+     &                                                  ,E1,E2,Q1,W1
+      integer :: nunit,ier
+      save nunit
+!***********************************************************************
+!-----------------------------------------------------------------------
+!     
+      RDY=1./DY
+      SLOPAC=SLOPHT*SQRT(2.)*0.5*50.
+      CRIT=SLOPAC*REAL(IDTAD)*DT*RDY*1000.
+!     
+      ADDT=REAL(IDTAD)*DT
+      ENH=ADDT/(08.*DY)
+!     
+!-----------------------------------------------------------------------
+!
+      SCALAR_LOOP :  DO L=lstart,NUM_SCAL
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS_P3,MYJE_P3                         
+      DO I=MYIS_P2,MYIE_P2                         
+        EMH (I,J)=ADDT/(08.*DX(I,J))               
+        DARE(I,J)=HBM3(I,J)*DX(I,J)*DY
+!       E1(I,KTE,J)=MAX(Q2(I,KTE,J)*0.5,EPSQ2)
+!       E2(I,KTE,J)=E1(I,KTE,J)
+      ENDDO  
+      ENDDO  
+!-----------------------------------------------------------------------
+!    
+!$omp parallel do                                                       &
+!$omp& private(e1x,htmikj,i,j,k)
+      DO J=MYJS_P3,MYJE_P3
+        DO K=KTS,KTE
+        DO I=MYIS_P2,MYIE_P2
+          DVOL(I,K,J)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+          HTMIKJ=HTM(I,K,J)
+!         Q  (I,K,J)=MAX(SCAL(I,K,J,L),EPSILSCALAR)*HTMIKJ
+          Q  (I,K,J)=SCAL(I,K,J,L)*HTMIKJ
+          Q1  (I,K,J)=Q  (I,K,J)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dza,dzb,fpq,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp,tta,ttb)
+      DO J=MYJS2_P1,MYJE2_P1
+      DO K=KTS,KTE
+      DO I=MYIS1_P1,MYIE1_P1
+!
+        TTA=(U(I,K,J-1)+U(I+IHW(J),K,J)+U(I+IHE(J),K,J)+U(I,K,J+1))     &
+     &      *EMH(I,J)*HBM2(I,J)
+        TTB=(V(I,K,J-1)+V(I+IHW(J),K,J)+V(I+IHE(J),K,J)+V(I,K,J+1))     &
+     &      *ENH*HBM2(I,J)
+!
+        SPP=-TTA-TTB
+        SQP= TTA-TTB
+!
+        IF(SPP<0.)THEN
+          JFP=-1
+        ELSE
+          JFP=1
+        ENDIF
+        IF(SQP<0.)THEN
+          JFQ=-1
+        ELSE
+          JFQ=1
+        ENDIF
+!
+        IFPA(I,K,J)=IHE(J)+I+( JFP-1)/2
+        IFQA(I,K,J)=IHE(J)+I+(-JFQ-1)/2
+!
+        JFPA(I,K,J)=J+JFP
+        JFQA(I,K,J)=J+JFQ
+!
+        IFPF(I,K,J)=IHE(J)+I+(-JFP-1)/2
+        IFQF(I,K,J)=IHE(J)+I+( JFQ-1)/2
+!         
+        JFPF(I,K,J)=J-JFP
+        JFQF(I,K,J)=J-JFQ
+!       
+!-----------------------------------------------------------------------
+        IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
+          DZA=(Z(IFPA(I,K,J),K,JFPA(I,K,J))-Z(I,K,J))*RDY
+          DZB=(Z(IFQA(I,K,J),K,JFQA(I,K,J))-Z(I,K,J))*RDY
+!
+          IF(ABS(DZA)>SLOPAC)THEN
+            SSA=DZA*SPP
+            IF(SSA>CRIT)THEN
+              SPP=0. !spp*.1
+            ENDIF
+          ENDIF
+!    
+          IF(ABS(DZB)>SLOPAC)THEN
+            SSB=DZB*SQP
+            IF(SSB>CRIT)THEN
+              SQP=0. !sqp*.1
+            ENDIF
+          ENDIF
+!       
+        ENDIF
+!-----------------------------------------------------------------------
+        SPP=SPP*HTM(IFPA(I,K,J),K,JFPA(I,K,J))
+        SQP=SQP*HTM(IFQA(I,K,J),K,JFQA(I,K,J))
+        FPQ=SPP*SQP*HTM(I,K,J-2)*HTM(I-1,K,J)                           &
+     &             *HTM(I+1,K,J)*HTM(I,K,J+2)*0.25
+        PP=ABS(SPP)
+        QP=ABS(SQP)
+!       
+        AFP(I,K,J)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
+        AFQ(I,K,J)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
+!       
+        Q1(I,K,J)=(Q  (IFPA(I,K,J),K,JFPA(I,K,J))-Q  (I,K,J))*PP        &
+     &           +(Q  (IFQA(I,K,J),K,JFQA(I,K,J))-Q  (I,K,J))*QP        &
+     &           +(Q  (I,K,J-2)+Q  (I,K,J+2)                            &
+     &            -Q  (I-1,K,J)-Q  (I+1,K,J))*FPQ                       &
+     &           +Q(I,K,J)
+!
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        XSUMS(1,K)=0.
+        XSUMS(2,K)=0.
+        XSUMS(3,K)=0.
+        XSUMS(4,K)=0.
+        XSUMS(5,K)=0.
+        XSUMS(6,K)=0.
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!***  ANTI-FILTERING LIMITERS
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          XSUMS_L(I,K,J,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JDS,JDE
+        DO K=KDS,KDE
+        DO I=IDS,IDE
+          XSUMS_G(I,K,J,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!     
+      ENDDO
+!
+#endif
+!-----------------------------------------------------------------------
+      DO 150 J=MYJS2,MYJE2
+      DO 150 K=KTS,KTE
+      DO 150 I=MYIS1,MYIE1
+!       
+      DVOLP=DVOL(I,K,J)
+      Q1IJ =Q1(I,K,J)
+      W1IJ =W1(I,K,J)
+      E2IJ =E2(I,K,J)
+!     
+      HAFP=HTM(IFPF(I,K,J),K,JFPF(I,K,J))*AFP(I,K,J)
+      HAFQ=HTM(IFQF(I,K,J),K,JFQF(I,K,J))*AFQ(I,K,J)
+!
+      D2PQQ=(Q1(IFPA(I,K,J),K,JFPA(I,K,J))-Q1IJ                         &
+     &      -Q1IJ+Q1(IFPF(I,K,J),K,JFPF(I,K,J)))                        &
+     &      *HAFP                                                       &
+     &     +(Q1(IFQA(I,K,J),K,JFQA(I,K,J))-Q1IJ                         &
+     &      -Q1IJ+Q1(IFQF(I,K,J),K,JFQF(I,K,J)))                        &
+     &      *HAFQ                                                       
+!
+      QSTIJ=Q1IJ-D2PQQ
+!       
+      Q00=Q  (I          ,K          ,J)
+      QP0=Q  (IFPA(I,K,J),K,JFPA(I,K,J))
+      Q0Q=Q  (IFQA(I,K,J),K,JFQA(I,K,J))
+!       
+      QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
+      QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
+!
+      DQSTIJ=QSTIJ-Q(I,K,J)
+!       
+      DQST(I,K,J)=DQSTIJ
+!       
+      DQSTIJ=DQSTIJ*DVOLP
+!
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+        XSUMS_L(I,K,J,N)=0.
+      ENDDO
+!
+      IF(DQSTIJ>0.)THEN
+        XSUMS_L(I,K,J,1)=DQSTIJ
+      ELSE
+        XSUMS_L(I,K,J,2)=DQSTIJ
+      ENDIF
+!
+#else
+      IF(DQSTIJ>0.)THEN
+        XSUMS(1,K)=XSUMS(1,K)+DQSTIJ
+      ELSE
+        XSUMS(2,K)=XSUMS(2,K)+DQSTIJ
+      ENDIF
+!
+#endif
+!
+  150 CONTINUE
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL)
+      DO N=1,6
+        CALL WRF_PATCH_TO_GLOBAL_REAL( XSUMS_L(IMS,KMS,JMS,N)           &
+     &,                                XSUMS_G(1,1,1,N),DOMDESC         &
+     &,                               'xyz','xzy'                       &
+     &,                                IDS,IDE,KDS,KDE,JDS,JDE          &
+     &,                                IMS,IME,KMS,KME,JMS,JME          &
+     &,                                ITS,ITE,KTS,KTE,JTS,JTE )
+      ENDDO
+!
+      GSUMS=0.
+!
+      IF(WRF_DM_ON_MONITOR())THEN
+        DO N=1,6
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=JDS,JDE
+          DO K=KDS,KDE
+          DO I=IDS,IDE
+            GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,K,J,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+      
+      CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*6*(KDE-KDS+1) )
+      
+#else
+!-----------------------------------------------------------------------
+!     
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!     
+# ifdef DM_PARALLEL
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL MPI_ALLREDUCE(XSUMS,GSUMS,6*(KTE-KTS+1)                      &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      GSUMS=XSUMS
+# endif
+#endif  
+!    
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION          
+!-----------------------------------------------------------------------
+!    
+!     if(mype==0)then
+!       if(ntsd==0)then
+!!        call int_get_fresh_handle(nunit)
+!!        close(nunit)
+!         nunit=56
+!         open(unit=nunit,file='gsums',form='unformatted',iostat=ier)
+!       endif
+!     endif
+      DO K=KTS,KTE
+!       if(mype==0)then
+!         write(nunit)(gsums(i,k),i=1,6)
+!       endif
+!
+!-----------------------------------------------------------------------
+        SUMPQ=GSUMS(1,K)
+        SUMNQ=GSUMS(2,K)
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+        IF(SUMPQ>1.)THEN
+          RFACQK=-SUMNQ/SUMPQ
+        ELSE
+          RFACQK=1.
+        ENDIF
+!
+        IF(RFACQKCONSERVE_MAX)RFACQK=1.
+!
+        RFACQ(K)=RFACQK
+!
+      ENDDO
+!     if(mype==0.and.ntsd==181)close(nunit)
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dqstij,i,j,k,rfacqk,rfqij)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          RFACQK=RFACQ(K)
+          IF(RFACQK<1.)THEN
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,K,J)
+              RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
+              IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
+              Q(I,K,J)=Q(I,K,J)+DQSTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,K,J)
+              RFQIJ=HBM2(I,J)*(RFACQK-1.)+1.
+              IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
+              Q(I,K,J)=Q(I,K,J)+DQSTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS,MYJE
+      DO K=KTS,KTE
+      DO I=MYIS,MYIE
+!       SCAL(I,K,J,L)=MAX(Q (I,K,J),EPSILSCALAR)*HTM(I,K,J)
+        SCAL(I,K,J,L)=Q (I,K,J)*HTM(I,K,J)
+      ENDDO
+      ENDDO
+      ENDDO
+        
+      ENDDO   SCALAR_LOOP
+!-----------------------------------------------------------------------
+      END SUBROUTINE HAD2_SCAL
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      END MODULE MODULE_ADVECTION
+!-----------------------------------------------------------------------
+
diff --git a/wrfv2_fire/dyn_nmm/module_BC_NMM.F b/wrfv2_fire/dyn_nmm/module_BC_NMM.F
new file mode 100644
index 00000000..f9a0ec80
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_BC_NMM.F
@@ -0,0 +1,14 @@
+!
+      MODULE MODULE_BC_NMM
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+!***  PRIMARY BOUNDARY CONDITION ARRAYS
+!
+      REAL,ALLOCATABLE,DIMENSION(:,:) :: PDB_ORIG
+!
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: TB_ORIG,QB_ORIG,     &
+                            UB_ORIG,VB_ORIG,Q2B_ORIG,CWMB_ORIG
+!
+!----------------------------------------------------------------------
+      END MODULE MODULE_BC_NMM
diff --git a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
new file mode 100644
index 00000000..86721ee6
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
@@ -0,0 +1,1135 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: BOUNDARY CONDITION UPDATES
+!
+!-----------------------------------------------------------------------
+!
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_BNDRY_COND
+!
+!-----------------------------------------------------------------------
+      USE MODULE_STATE_DESCRIPTION
+      USE MODULE_MODEL_CONSTANTS
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+      INCLUDE "mpif.h"
+#endif
+!-----------------------------------------------------------------------
+      REAL :: D06666=0.06666666
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE BOCOH(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &  ! GRIDID ADDED BY GOPAL
+     &                ,LB,ETA1,ETA2,PDTOP,PT,RES,HTM                    &
+     &                ,PD_B,T_B,Q_B,U_B,V_B,Q2_B,CWM_B                  &
+     &                ,PD_BT,T_BT,Q_BT,U_BT,V_BT,Q2_BT,CWM_BT           &
+     &                ,PD,T,Q,Q2,CWM,PINT,MOIST,N_MOIST,SCALAR,N_SCALAR &
+#ifdef WRF_CHEM
+     &                ,CHEM,NUMG,CONFIG_FLAGS                           &
+#endif
+     &                ,IJDS,IJDE,SPEC_BDY_WIDTH,Z                       &  ! min/max(id,jd)
+     &                ,IHE,IHW,IVE,IVW,INDX3_WRK                        &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    BOCOH       UPDATE MASS POINTS ON BOUNDARY
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 94-03-08
+!     
+! ABSTRACT:
+!     TEMPERATURE, SPECIFIC HUMIDITY, AND SURFACE PRESSURE
+!     ARE UPDATED ON THE DOMAIN BOUNDARY BY APPLYING THE
+!     PRE-COMPUTED TENDENCIES AT EACH TIME STEP.
+!     
+! PROGRAM HISTORY LOG:
+!   87-??-??  MESINGER   - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D in HORIZONTAL
+!   96-12-13  BLACK      - FINAL MODIFICATION FOR NESTED RUNS
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   00-01-06  BLACK      - MODIFIED FOR JANJIC NONHYDROSTATIC CODE
+!   00-09-14  BLACK      - MODIFIED FOR DIRECT ACCESS READ
+!   01-03-12  BLACK      - CONVERTED TO WRF STRUCTURE
+!   02-08-29  MICHALAKES - CHANGED II=I-MY_IS_GLB+1 TO II=I
+!                          ADDED CONDITIONAL COMPILATION AROUND MPI
+!                          CONVERT INDEXING FROM LOCAL TO GLOBAL
+!   02-09-06  WOLFE      - MORE CONVERSION TO GLOBAL INDEXING 
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL BOCOH FROM SUBROUTINE SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!
+!     NOTE THAT IDE AND JDE INSIDE ROUTINE SHOULD BE PASSED IN
+!     AS WHAT WRF CONSIDERS THE UNSTAGGERED GRID DIMENSIONS; THAT
+!     IS, 1 LESS THAN THE IDE AND JDE SET BY WRF FRAMEWORK, JM
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!***********************************************************************
+!-----------------------------------------------------------------------
+#ifdef WRF_CHEM
+    USE MODULE_INPUT_CHEM_DATA
+#endif
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+      LOGICAL,INTENT(IN) :: NEST
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+      INTEGER,INTENT(IN) :: IJDS,IJDE,SPEC_BDY_WIDTH
+      INTEGER,INTENT(IN) :: N_MOIST, N_SCALAR
+#ifdef WRF_CHEM
+      INTEGER,INTENT(IN) :: NUMG
+#endif
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! NMM_MAX_DIM is set in configure.wrf and must agree with the value of
+! dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: GRIDID
+      INTEGER,INTENT(IN) :: LB,NBC,NTSD
+      LOGICAL,INTENT(IN) :: LAST_TIME
+      INTEGER,INTENT(INOUT) :: NBOCO
+!
+      REAL,INTENT(IN) :: DT0,PDTOP,PT,TSPH
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM
+!
+      REAL,DIMENSION(IJDS:IJDE,1,SPEC_BDY_WIDTH,4)                      &
+     &                                     ,INTENT(INOUT) :: PD_B,PD_BT
+!
+      REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4)                &
+     &                                ,INTENT(INOUT) :: CWM_B,Q_B,Q2_B  &
+     &                                                 ,T_B,U_B,V_B 
+      REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4)                &
+     &                             ,INTENT(INOUT) :: CWM_BT,Q_BT,Q2_BT  &
+     &                                              ,T_BT,U_BT,V_BT 
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM      &
+     &                                                        ,PINT,Q   &
+     &                                                        ,Q2,T,Z
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_MOIST),INTENT(INOUT) :: MOIST
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_SCALAR),INTENT(INOUT) :: SCALAR
+#ifdef WRF_CHEM
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_CHEM),INTENT(INOUT) :: CHEM
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+#endif
+
+
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      INTEGER :: BF,I,IB,IBDY,II,IIM,IM,IRTN,ISIZ1,ISIZ2                &
+     &          ,J,JB,JJ,JJM,JM,K,N,NN,NREC,REC,NV
+      INTEGER :: MY_IS_GLB,MY_JS_GLB,MY_IE_GLB,MY_JE_GLB  
+      INTEGER :: I_M,ILPAD1,IRPAD1,JBPAD1,JTPAD1
+!
+      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
+!
+      REAL :: BCHR,RHTM,SHTM,DT
+      REAL :: CONVFAC,RRI,PLYR
+      INTEGER KK,NUMGAS
+      REAL :: CWK
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM
+   ! DETERMINE THE INDEX OF THE LAST GAS SPECIES
+     NUMGAS=P_HO2                     
+     NUMGAS=NUMG
+!   NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT)       
+#endif
+      IM=IDE-IDS+1
+      JM=JDE-JDS+1
+      IIM=IM
+      JJM=JM
+!
+      ISIZ1=2*LB
+      ISIZ2=2*LB*(KME-KMS)
+!
+      W_BDY=(ITS==IDS)
+      E_BDY=(ITE==IDE)
+      S_BDY=(JTS==JDS)
+      N_BDY=(JTE==JDE)
+!
+      ILPAD1=1
+      IF(W_BDY)ILPAD1=0
+      IRPAD1=1
+      IF(E_BDY)IRPAD1=0
+      JBPAD1=1
+      IF(S_BDY)JBPAD1=0
+      JTPAD1=1
+      IF(N_BDY)JTPAD1=0
+!
+      MY_IS_GLB=ITS
+      MY_IE_GLB=ITE
+      MY_JS_GLB=JTS
+      MY_JE_GLB=JTE
+!
+      DT=DT0
+!
+!-----------------------------------------------------------------------
+!***  SOUTH AND NORTH BOUNDARIES
+!-----------------------------------------------------------------------
+!
+!***  USE IBDY=1 FOR SOUTH; 2 FOR NORTH
+!
+      DO IBDY=1,2 
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((S_BDY.AND.IBDY==1).OR.(N_BDY.AND.IBDY==2))THEN
+!
+          IF(IBDY==1)THEN
+            BF=P_YSB     ! Which boundary (YSB=the boundary where Y is at its start)
+            JB=1         ! Which cell in from boundary
+            JJ=1         ! Which cell in the domain
+          ELSE
+            BF=P_YEB     ! Which boundary (YEB=the boundary where Y is at its end)
+            JB=1         ! Which cell in from boundary
+            JJ=JJM       ! Which cell in the domain
+          ENDIF
+!
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_B(I,1,JB,BF)=PD_B(I,1,JB,BF)+PD_BT(I,1,JB,BF)*DT
+            PD(I,JJ)=PD_B(I,1,JB,BF)
+          ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_B(I,K,JB,BF)=T_B(I,K,JB,BF)+T_BT(I,K,JB,BF)*DT
+              Q_B(I,K,JB,BF)=Q_B(I,K,JB,BF)+Q_BT(I,K,JB,BF)*DT
+              Q2_B(I,K,JB,BF)=Q2_B(I,K,JB,BF)+Q2_BT(I,K,JB,BF)*DT
+              CWM_B(I,K,JB,BF)=CWM_B(I,K,JB,BF)+CWM_BT(I,K,JB,BF)*DT
+              T(I,K,JJ)=T_B(I,K,JB,BF)
+              Q(I,K,JJ)=Q_B(I,K,JB,BF)
+              Q2(I,K,JJ)=Q2_B(I,K,JB,BF)
+              CWM(I,K,JJ)=CWM_B(I,K,JB,BF)
+              PINT(I,K,JJ)=ETA1(K)*PDTOP                                &
+     &                    +ETA2(K)*PD(I,JJ)*RES(I,JJ)+PT
+            ENDDO
+          ENDDO
+          DO I_M=1,N_MOIST
+            IF(I_M==P_QV)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+              DO K=KTS,KTE
+              DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+                MOIST(I,K,JJ,I_M)=Q(I,K,JJ)/(1.-Q(I,K,JJ))
+              ENDDO
+              ENDDO
+            ELSE
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+              DO K=KTS,KTE
+              DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+                MOIST(I,K,JJ,I_M)=0.
+              ENDDO
+              ENDDO
+            ENDIF
+          ENDDO
+          DO I_M=2,N_SCALAR
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+            DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              SCALAR(I,K,JJ,I_M)=0.
+            ENDDO
+            ENDDO
+          ENDDO
+#ifdef WRF_CHEM
+!$omp parallel do                                                       &
+!$omp& private(i,k,nv)
+          DO NV=2,NUMG
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              CALL BDY_CHEM_VALUE (CHEM(I,K,JJ,NV), Z(I,K,JJ), NV,NUMG)
+            ENDDO
+          ENDDO
+          ENDDO
+!$omp parallel do                                                       &
+!$omp& private(i,k,nv)
+          DO NV=NUMG+1,NUM_CHEM
+          DO K=KTS,KTE
+          KK=MIN(K+1,KTE)
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              PLYR=(PINT(I,K,JJ)+PINT(I,KK,JJ))*0.5
+              RRI=R_D*T(I,K,JJ)*(1.+.608*Q(I,K,JJ))/PLYR
+              CONVFAC=PLYR/RGASUNIV/T(I,K,JJ)
+              CALL BDY_CHEM_VALUE_SORGAM (CHEM(I,K,JJ,NV), Z(I,K,JJ), NV, &
+                                          CONFIG_FLAGS,RRI,CONVFAC,G)
+            ENDDO
+          ENDDO
+          ENDDO
+#endif
+        ENDIF
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  WEST AND EAST BOUNDARIES
+!-----------------------------------------------------------------------
+!
+!***  USE IBDY=1 FOR WEST; 2 FOR EAST. 
+!
+      DO IBDY=1,2 
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((W_BDY.AND.IBDY==1).OR.(E_BDY.AND.IBDY==2))THEN
+          IF(IBDY==1)THEN
+            BF=P_XSB     ! Which boundary (XSB=the boundary where X is at its start)
+            IB=1         ! Which cell in from boundary 
+            II=1         ! Which cell in the domain
+          ELSE
+            BF=P_XEB     ! Which boundary (XEB=the boundary where X is at its end)
+            IB=1         ! Which cell in from boundary
+            II=IIM       ! Which cell in the domain
+          ENDIF
+!
+          DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+            IF(MOD(J,2)==1)THEN
+              PD_B(J,1,IB,BF)=PD_B(J,1,IB,BF)+PD_BT(J,1,IB,BF)*DT
+              PD(II,J)=PD_B(J,1,IB,BF)
+            ENDIF
+          ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(j,k)
+          DO K=KTS,KTE
+            DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+!
+              IF(MOD(J,2)==1)THEN
+                T_B(J,K,IB,BF)=T_B(J,K,IB,BF)+T_BT(J,K,IB,BF)*DT
+                Q_B(J,K,IB,BF)=Q_B(J,K,IB,BF)+Q_BT(J,K,IB,BF)*DT
+                Q2_B(J,K,IB,BF)=Q2_B(J,K,IB,BF)+Q2_BT(J,K,IB,BF)*DT
+                CWM_B(J,K,IB,BF)=CWM_B(J,K,IB,BF)+CWM_BT(J,K,IB,BF)*DT
+                T(II,K,J)=T_B(J,K,IB,BF)
+                Q(II,K,J)=Q_B(J,K,IB,BF)
+                Q2(II,K,J)=Q2_B(J,K,IB,BF)
+                CWM(II,K,J)=CWM_B(J,K,IB,BF)
+                PINT(II,K,J)=ETA1(K)*PDTOP                              &
+     &                      +ETA2(K)*PD(II,J)*RES(II,J)+PT
+              ENDIF
+!
+            ENDDO
+          ENDDO
+!
+          DO I_M=1,N_MOIST
+            IF(I_M==P_QV)THEN
+!$omp parallel do                                                       &
+!$omp& private(j,k)
+              DO K=KTS,KTE
+              DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+                IF(MOD(J,2)==1)THEN
+                  MOIST(II,K,J,I_M)=Q(II,K,J)/(1.-Q(II,K,J))
+                ENDIF
+              ENDDO
+              ENDDO
+!
+            ELSE
+!$omp parallel do                                                       &
+!$omp& private(j,k)
+              DO K=KTS,KTE
+              DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+                IF(MOD(J,2)==1)THEN
+                  MOIST(II,K,J,I_M)=0.
+                ENDIF
+              ENDDO
+              ENDDO
+!
+            ENDIF
+          ENDDO
+!
+          DO I_M=2,N_SCALAR
+!$omp parallel do                                                       &
+!$omp& private(j,k)
+            DO K=KTS,KTE
+            DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+              IF(MOD(J,2)==1)THEN
+                SCALAR(II,K,J,I_M)=0.
+              ENDIF
+            ENDDO
+            ENDDO
+          ENDDO
+!
+#ifdef WRF_CHEM
+!$omp parallel do                                                       &
+!$omp& private(nv,j,k)
+          DO K=KTS,KTE
+            KK=MIN(K+1,KTE)
+            DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+              IF(MOD(J,2)==1)THEN
+                 DO NV=2,NUMG
+                   CALL BDY_CHEM_VALUE (CHEM(II,K,J,NV), Z(II,K,J), NV,NUMG)
+                 ENDDO
+!$omp parallel do                                                       &
+!$omp& private(nv)
+                 DO NV=NUMG+1,NUM_CHEM
+                    PLYR=(PINT(II,K,J)+PINT(II,KK,J))*0.5
+                    RRI=R_D*T(II,K,J)*(1.+P608*Q(II,K,J))/PLYR
+                    CONVFAC=PLYR/RGASUNIV/T(II,K,J)
+                    CALL BDY_CHEM_VALUE_SORGAM (CHEM(II,K,J,NV), Z(II,K,J), NV, &
+     &                                          CONFIG_FLAGS,RRI,CONVFAC,G)
+                 ENDDO
+               ENDIF
+            ENDDO
+          ENDDO
+
+#endif
+        ENDIF
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SPACE INTERPOLATION OF PD THEN REMAINING MASS VARIABLES
+!***  AT INNER BOUNDARY
+!-----------------------------------------------------------------------
+!
+!***  ONE ROW NORTH OF SOUTHERN BOUNDARY
+!
+      IF(S_BDY)THEN
+        DO I=MYIS,MYIE1
+          SHTM=HTM(I,KTE,1)+HTM(I+1,KTE,1)+HTM(I,KTE,3)+HTM(I+1,KTE,3)
+          PD(I,2)=(PD(I,1)*HTM(I,KTE,1)+PD(I+1,1)*HTM(I+1,KTE,1)        &
+     &            +PD(I,3)*HTM(I,KTE,3)+PD(I+1,3)*HTM(I+1,KTE,3))/SHTM
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS,MYIE1
+          CWK=PD(I,JJM-1)
+          SHTM=HTM(I,KTE,JJM-2)+HTM(I+1,KTE,JJM-2)+HTM(I,KTE,JJM)       &
+     &                                          +HTM(I+1,KTE,JJM)
+          PD(I,JJM-1)=(PD(I,JJM-2)*HTM(I,KTE,JJM-2)                     &
+     &                +PD(I+1,JJM-2)*HTM(I+1,KTE,JJM-2)                 &
+     &                +PD(I,JJM)*HTM(I,KTE,JJM)                         &
+     &                +PD(I+1,JJM)*HTM(I+1,KTE,JJM))/SHTM
+
+! test. 
+
+          IF(I<=IDE-1.AND.ABS(CWK-PD(I,JJM-1))>=300.)THEN
+            WRITE(0,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE NORTHERN BOUNDARY AT',I,JJM-1,'GRID #',GRIDID
+            WRITE(0,*)'             ',CWK/100.
+            WRITE(0,*)PD(I,JJM)/100.,'               ',PD(I+1,JJM)/100.
+            WRITE(0,*)'             ',PD(I,JJM-1)/100.
+            WRITE(0,*)PD(I,JJM-2)/100.,'             ',PD(I+1,JJM-2)/100.
+            WRITE(0,*)
+          ENDIF
+
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW EAST OF WESTERN BOUNDARY
+!
+      IF(W_BDY)THEN
+        DO J=4,JM-3,2
+!
+          IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            CWK=PD(1,J)
+            JJ=J
+            SHTM=HTM(1,KTE,JJ-1)+HTM(2,KTE,JJ-1)+HTM(1,KTE,JJ+1)        &
+     &                                          +HTM(2,KTE,JJ+1)
+            PD(1,JJ)=(PD(1,JJ-1)*HTM(1,KTE,JJ-1)                        &
+     &               +PD(2,JJ-1)*HTM(2,KTE,JJ-1)                        &
+     &               +PD(1,JJ+1)*HTM(1,KTE,JJ+1)                        &
+     &               +PD(2,JJ+1)*HTM(2,KTE,JJ+1))/SHTM
+
+! test.
+
+             IF(ABS(CWK-PD(1,JJ))>300.)THEN
+              WRITE(0,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE WESTERN BOUNDARY AT',J,1,'GRID #',GRIDID
+              WRITE(0,*)'             ',CWK/100.
+              WRITE(0,*)PD(1,JJ+1)/100.,'               ',PD(2,JJ+1)/100.
+              WRITE(0,*)'             ',PD(1,JJ)/100.
+              WRITE(0,*)PD(1,JJ-1)/100,'               ',PD(2,JJ-1)/100.
+              WRITE(0,*)
+            ENDIF
+
+          ENDIF
+!
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW WEST OF EASTERN BOUNDARY
+!
+      IF(E_BDY)THEN
+        DO J=4,JM-3,2
+!
+          IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            SHTM=HTM(IIM-1,KTE,JJ-1)+HTM(IIM,KTE,JJ-1)                  &
+     &          +HTM(IIM-1,KTE,JJ+1)+HTM(IIM,KTE,JJ+1)
+            PD(IIM-1,JJ)=(PD(IIM-1,JJ-1)*HTM(IIM-1,KTE,JJ-1)            &
+     &                   +PD(IIM,JJ-1)*HTM(IIM,KTE,JJ-1)                &
+     &                   +PD(IIM-1,JJ+1)*HTM(IIM-1,KTE,JJ+1)            &
+     &                   +PD(IIM,JJ+1)*HTM(IIM,KTE,JJ+1))/SHTM
+          ENDIF
+!
+        ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,jj,k,rhtm)
+      DO 200 K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!***  ONE ROW NORTH OF SOUTHERN BOUNDARY
+!
+      IF(S_BDY)THEN
+        DO I=MYIS,MYIE1
+          RHTM=1./(HTM(I,K,1)+HTM(I+1,K,1)+HTM(I,K,3)+HTM(I+1,K,3))
+          T(I,K,2)=(T(I,K,1)*HTM(I,K,1)+T(I+1,K,1)*HTM(I+1,K,1)         &
+     &             +T(I,K,3)*HTM(I,K,3)+T(I+1,K,3)*HTM(I+1,K,3))        &
+     &             *RHTM
+          Q(I,K,2)=(Q(I,K,1)*HTM(I,K,1)+Q(I+1,K,1)*HTM(I+1,K,1)         &
+     &             +Q(I,K,3)*HTM(I,K,3)+Q(I+1,K,3)*HTM(I+1,K,3))        &
+     &             *RHTM
+          Q2(I,K,2)=(Q2(I,K,1)*HTM(I,K,1)+Q2(I+1,K,1)*HTM(I+1,K,1)      &
+     &              +Q2(I,K,3)*HTM(I,K,3)+Q2(I+1,K,3)*HTM(I+1,K,3))     &
+     &              *RHTM
+          CWM(I,K,2)=(CWM(I,K,1)*HTM(I,K,1)+CWM(I+1,K,1)*HTM(I+1,K,1)   &
+     &               +CWM(I,K,3)*HTM(I,K,3)+CWM(I+1,K,3)*HTM(I+1,K,3))  &
+     &               *RHTM
+          PINT(I,K,2)=ETA1(K)*PDTOP+ETA2(K)*PD(I,2)*RES(I,2)+PT
+        ENDDO
+        DO I_M=1,N_MOIST
+          IF(I_M==P_QV)THEN
+            DO I=MYIS,MYIE1
+              MOIST(I,K,2,I_M)=Q(I,K,2)/(1.-Q(I,K,2))
+            ENDDO
+          ELSE
+            DO I=MYIS,MYIE1
+              MOIST(I,K,2,I_M)=(MOIST(I,K,1,I_M)*HTM(I,K,1)             &
+     &                         +MOIST(I+1,K,1,I_M)*HTM(I+1,K,1)         &
+     &                         +MOIST(I,K,3,I_M)*HTM(I,K,3)             &
+     &                         +MOIST(I+1,K,3,I_M)*HTM(I+1,K,3))        &
+     &                          *RHTM
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO I_M=2,N_SCALAR
+          DO I=MYIS,MYIE1
+            SCALAR(I,K,2,I_M)=(SCALAR(I,K,1,I_M)*HTM(I,K,1)             &
+     &                        +SCALAR(I+1,K,1,I_M)*HTM(I+1,K,1)         &
+     &                        +SCALAR(I,K,3,I_M)*HTM(I,K,3)             &
+     &                        +SCALAR(I+1,K,3,I_M)*HTM(I+1,K,3))        &
+     &                         *RHTM
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS,MYIE1
+          RHTM=1./(HTM(I,K,JJM-2)+HTM(I+1,K,JJM-2)                      &
+     &            +HTM(I,K,JJM)+HTM(I+1,K,JJM))
+          T(I,K,JJM-1)=(T(I,K,JJM-2)*HTM(I,K,JJM-2)                     &
+     &                 +T(I+1,K,JJM-2)*HTM(I+1,K,JJM-2)                 &
+     &                 +T(I,K,JJM)*HTM(I,K,JJM)                         &
+     &                 +T(I+1,K,JJM)*HTM(I+1,K,JJM))                    &
+     &                 *RHTM
+          Q(I,K,JJM-1)=(Q(I,K,JJM-2)*HTM(I,K,JJM-2)                     &
+     &                 +Q(I+1,K,JJM-2)*HTM(I+1,K,JJM-2)                 &
+     &                 +Q(I,K,JJM)*HTM(I,K,JJM)                         &
+     &                 +Q(I+1,K,JJM)*HTM(I+1,K,JJM))                    &
+     &                 *RHTM
+          Q2(I,K,JJM-1)=(Q2(I,K,JJM-2)*HTM(I,K,JJM-2)                   &
+     &                  +Q2(I+1,K,JJM-2)*HTM(I+1,K,JJM-2)               &
+     &                  +Q2(I,K,JJM)*HTM(I,K,JJM)                       &
+     &                  +Q2(I+1,K,JJM)*HTM(I+1,K,JJM))                  &
+     &                  *RHTM
+          CWM(I,K,JJM-1)=(CWM(I,K,JJM-2)*HTM(I,K,JJM-2)                 &
+     &                   +CWM(I+1,K,JJM-2)*HTM(I+1,K,JJM-2)             &
+     &                   +CWM(I,K,JJM)*HTM(I,K,JJM)                     &
+     &                   +CWM(I+1,K,JJM)*HTM(I+1,K,JJM))                &
+     &                   *RHTM
+          PINT(I,K,JJM-1)=ETA1(K)*PDTOP                                 &
+     &                   +ETA2(K)*PD(I,JJM-1)*RES(I,JJM-1)+PT
+        ENDDO
+        DO I_M=1,N_MOIST
+          IF(I_M==P_QV)THEN
+            DO I=MYIS,MYIE1
+              MOIST(I,K,JJM-1,I_M)=Q(I,K,JJM-1)/(1.-Q(I,K,JJM-1))
+            ENDDO
+          ELSE
+            DO I=MYIS,MYIE1
+              MOIST(I,K,JJM-1,I_M)=(MOIST(I,K,JJM-2,I_M)*HTM(I,K,JJM-2) &
+     &                             +MOIST(I+1,K,JJM-2,I_M)*HTM(I+1,K,JJM-2) &
+     &                             +MOIST(I,K,JJM,I_M)*HTM(I,K,JJM)     &
+     &                             +MOIST(I+1,K,JJM,I_M)*HTM(I+1,K,JJM)) &
+     &                              *RHTM
+            ENDDO
+
+          ENDIF
+        ENDDO
+!
+        DO I_M=2,N_SCALAR
+          DO I=MYIS,MYIE1
+            SCALAR(I,K,JJM-1,I_M)=(SCALAR(I,K,JJM-2,I_M)*HTM(I,K,JJM-2) &
+     &                            +SCALAR(I+1,K,JJM-2,I_m)*HTM(I+1,K,JJM-2) &
+     &                            +SCALAR(I,K,JJM,I_M)*HTM(I,K,JJM)     &
+     &                            +SCALAR(I+1,K,JJM,I_M)*HTM(I+1,K,JJM)) &
+     &                             *RHTM
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!***  ONE ROW EAST OF WESTERN BOUNDARY
+!
+      IF(W_BDY)THEN
+        DO J=4,JM-3,2
+!
+          IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            RHTM=1./(HTM(1,K,JJ-1)+HTM(2,K,JJ-1)                        &
+     &              +HTM(1,K,JJ+1)+HTM(2,K,JJ+1))
+            T(1,K,JJ)=(T(1,K,JJ-1)*HTM(1,K,JJ-1)                        &
+     &                +T(2,K,JJ-1)*HTM(2,K,JJ-1)                        &
+     &                +T(1,K,JJ+1)*HTM(1,K,JJ+1)                        &
+     &                +T(2,K,JJ+1)*HTM(2,K,JJ+1))                       &
+     &                *RHTM
+            Q(1,K,JJ)=(Q(1,K,JJ-1)*HTM(1,K,JJ-1)                        &
+     &                +Q(2,K,JJ-1)*HTM(2,K,JJ-1)                        &
+     &                +Q(1,K,JJ+1)*HTM(1,K,JJ+1)                        &
+     &                +Q(2,K,JJ+1)*HTM(2,K,JJ+1))                       &
+     &                *RHTM
+            Q2(1,K,JJ)=(Q2(1,K,JJ-1)*HTM(1,K,JJ-1)                      &
+     &                 +Q2(2,K,JJ-1)*HTM(2,K,JJ-1)                      &
+     &                 +Q2(1,K,JJ+1)*HTM(1,K,JJ+1)                      &
+     &                 +Q2(2,K,JJ+1)*HTM(2,K,JJ+1))                     &
+     &                 *RHTM
+            CWM(1,K,JJ)=(CWM(1,K,JJ-1)*HTM(1,K,JJ-1)                    &
+     &                  +CWM(2,K,JJ-1)*HTM(2,K,JJ-1)                    &
+     &                  +CWM(1,K,JJ+1)*HTM(1,K,JJ+1)                    &
+     &                  +CWM(2,K,JJ+1)*HTM(2,K,JJ+1))                   &
+     &                  *RHTM
+            PINT(1,K,JJ)=ETA1(K)*PDTOP                                  &
+     &                  +ETA2(K)*PD(1,JJ)*RES(1,JJ)+PT
+            DO I_M=1,N_MOIST
+              IF(I_M==P_QV)THEN
+                MOIST(1,K,JJ,I_M)=Q(1,K,JJ)/(1.-Q(1,K,JJ))     
+              ELSE  
+                MOIST(1,K,JJ,I_M)=(MOIST(1,K,JJ-1,I_M)*HTM(1,K,JJ-1)    &
+     &                            +MOIST(2,K,JJ-1,I_M)*HTM(2,K,JJ-1)    &
+     &                            +MOIST(1,K,JJ+1,I_M)*HTM(1,K,JJ+1)    &
+     &                            +MOIST(2,K,JJ+1,I_M)*HTM(2,K,JJ+1))   &
+     &                             *RHTM
+              ENDIF
+            ENDDO    
+!
+            DO I_M=2,N_SCALAR
+              SCALAR(1,K,JJ,I_M)=(SCALAR(1,K,JJ-1,I_M)*HTM(1,K,JJ-1)    &
+     &                           +SCALAR(2,K,JJ-1,I_M)*HTM(2,K,JJ-1)    &
+     &                           +SCALAR(1,K,JJ+1,I_M)*HTM(1,K,JJ+1)    &
+     &                           +SCALAR(2,K,JJ+1,I_M)*HTM(2,K,JJ+1))   &
+     &                            *RHTM
+            ENDDO
+!
+          ENDIF
+!
+        ENDDO
+!
+      ENDIF
+!
+!***  ONE ROW WEST OF EASTERN BOUNDARY
+!
+      IF(E_BDY)THEN
+        DO J=4,JM-3,2
+!
+          IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            RHTM=1./(HTM(IIM-1,K,JJ-1)+HTM(IIM,K,JJ-1)                  &
+     &              +HTM(IIM-1,K,JJ+1)+HTM(IIM,K,JJ+1))
+            T(IIM-1,K,JJ)=(T(IIM-1,K,JJ-1)*HTM(IIM-1,K,JJ-1)            &
+     &                    +T(IIM,K,JJ-1)*HTM(IIM,K,JJ-1)                &
+     &                    +T(IIM-1,K,JJ+1)*HTM(IIM-1,K,JJ+1)            &
+     &                    +T(IIM,K,JJ+1)*HTM(IIM,K,JJ+1))               &
+     &                    *RHTM
+            Q(IIM-1,K,JJ)=(Q(IIM-1,K,JJ-1)*HTM(IIM-1,K,JJ-1)            &
+     &                    +Q(IIM,K,JJ-1)*HTM(IIM,K,JJ-1)                &
+     &                    +Q(IIM-1,K,JJ+1)*HTM(IIM-1,K,JJ+1)            &
+     &                    +Q(IIM,K,JJ+1)*HTM(IIM,K,JJ+1))               &
+     &                    *RHTM
+            Q2(IIM-1,K,JJ)=(Q2(IIM-1,K,JJ-1)*HTM(IIM-1,K,JJ-1)          &
+     &                     +Q2(IIM,K,JJ-1)*HTM(IIM,K,JJ-1)              &
+     &                     +Q2(IIM-1,K,JJ+1)*HTM(IIM-1,K,JJ+1)          &
+     &                     +Q2(IIM,K,JJ+1)*HTM(IIM,K,JJ+1))             &
+     &                     *RHTM
+            CWM(IIM-1,K,JJ)=(CWM(IIM-1,K,JJ-1)*HTM(IIM-1,K,JJ-1)        &
+     &                      +CWM(IIM,K,JJ-1)*HTM(IIM,K,JJ-1)            &
+     &                      +CWM(IIM-1,K,JJ+1)*HTM(IIM-1,K,JJ+1)        &
+     &                      +CWM(IIM,K,JJ+1)*HTM(IIM,K,JJ+1))           &
+     &                      *RHTM
+            PINT(IIM-1,K,JJ)=ETA1(K)*PDTOP                              &
+     &                      +ETA2(K)*PD(IIM-1,JJ)*RES(IIM-1,JJ)+PT
+!
+            DO I_M=1,N_MOIST
+              IF(I_M==P_QV)THEN
+                MOIST(IIM-1,K,JJ,I_M)=Q(IIM-1,K,JJ)/(1.-Q(IIM-1,K,JJ))
+              ELSE
+                MOIST(IIM-1,K,JJ,I_M)=(MOIST(IIM-1,K,JJ-1,I_M)*HTM(IIM-1,K,JJ-1) &
+     &                                +MOIST(IIM,K,JJ-1,I_M)*HTM(IIM,K,JJ-1)     &
+     &                                +MOIST(IIM-1,K,JJ+1,I_M)*HTM(IIM-1,K,JJ+1) &
+     &                                +MOIST(IIM,K,JJ+1,I_M)*HTM(IIM,K,JJ+1))    &
+     &                                 *RHTM
+                ENDIF
+              ENDDO
+!
+              DO I_M=2,N_SCALAR
+                SCALAR(IIM-1,K,JJ,I_M)=(SCALAR(IIM-1,K,JJ-1,I_M)*HTM(IIM-1,K,JJ-1)  &
+     &                                 +SCALAR(IIM,K,JJ-1,I_M)*HTM(IIM,K,JJ-1)      &
+     &                                 +SCALAR(IIM-1,K,JJ+1,I_M)*HTM(IIM-1,K,JJ+1)  &
+     &                                 +SCALAR(IIM,K,JJ+1,I_M)*HTM(IIM,K,JJ+1))     &
+     &                                  *RHTM
+              ENDDO
+!
+          ENDIF
+!
+        ENDDO
+      ENDIF
+!-----------------------------------------------------------------------
+!
+  200 CONTINUE
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE BOCOH
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE BOCOV(GRIDID,NTSD,DT,LB,VTM,U_B,V_B,U_BT,V_BT          &  ! GRIDID ADDED BY GOPAL
+     &                ,U,V                                              &
+     &                ,IJDS,IJDE,SPEC_BDY_WIDTH                         &  ! min/max(id,jd)
+     &                ,IHE,IHW,IVE,IVW,INDX3_WRK                        &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    BOCOV       UPDATE WIND POINTS ON BOUNDARY
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 94-03-08
+!     
+! ABSTRACT:
+!     U AND V COMPONENTS OF THE WIND ARE UPDATED ON THE
+!     DOMAIN BOUNDARY BY APPLYING THE PRE-COMPUTED
+!     TENDENCIES AT EACH TIME STEP.  AN EXTRAPOLATION FROM
+!     INSIDE THE DOMAIN IS USED FOR THE COMPONENT TANGENTIAL
+!     TO THE BOUNDARY IF THE NORMAL COMPONENT IS OUTWARD.
+!     
+! PROGRAM HISTORY LOG:
+!   87-??-??  MESINGER   - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   01-03-13  BLACK      - CONVERTED TO WRF STRUCTURE
+!   02-09-06  WOLFE      - MORE CONVERSION TO GLOBAL INDEXING 
+!   04-11-23  BLACK      - THREADED
+!     
+! USAGE: CALL BOCOH FROM SUBROUTINE SOLVE_NMM
+!   INPUT ARGUMENT LIST:
+!
+!     NOTE THAT IDE AND JDE INSIDE ROUTINE SHOULD BE PASSED IN
+!     AS WHAT WRF CONSIDERS THE UNSTAGGERED GRID DIMENSIONS; THAT
+!     IS, 1 LESS THAN THE IDE AND JDE SET BY WRF FRAMEWORK, JM
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+      INTEGER,INTENT(IN) :: IJDS,IJDE,SPEC_BDY_WIDTH
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! NMM_MAX_DIM is set in configure.wrf and must agree with
+! the value of dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: GRIDID
+      INTEGER,INTENT(IN) :: LB,NTSD
+!
+      REAL,INTENT(IN) :: DT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: VTM
+!
+      REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4),INTENT(INOUT)  &
+     &                                         :: U_B,V_B,U_BT,V_BT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: U,V
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      INTEGER :: I,II,IIM,IM,J,JJ,JJM,JM,K,N
+      INTEGER :: MY_IS_GLB, MY_JS_GLB,MY_IE_GLB,MY_JE_GLB  
+      INTEGER :: IBDY,BF,JB,IB
+      INTEGER :: ILPAD1,IRPAD1,JBPAD1,JTPAD1
+      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  TIME INTERPOLATION OF U AND V AT THE OUTER BOUNDARY
+!-----------------------------------------------------------------------
+!
+      IM=IDE-IDS+1
+      JM=JDE-JDS+1
+      IIM=IM
+      JJM=JM
+!
+      W_BDY=(ITS==IDS)
+      E_BDY=(ITE==IDE)
+      S_BDY=(JTS==JDS)
+      N_BDY=(JTE==JDE)
+!
+      ILPAD1=1
+      IF(ITS==IDS)ILPAD1=0
+      IRPAD1=1
+      IF(ITE==IDE)ILPAD1=0
+      JBPAD1=1
+      IF(JTS==JDS)JBPAD1=0
+      JTPAD1=1
+      IF(JTE==JDE)JTPAD1=0
+!
+      MY_IS_GLB=ITS
+      MY_IE_GLB=ITE
+      MY_JS_GLB=JTS
+      MY_JE_GLB=JTE
+!
+!-----------------------------------------------------------------------
+!***  SOUTH AND NORTH BOUNDARIES
+!***  USE IBDY=1 FOR SOUTH; 2 FOR NORTH.
+!-----------------------------------------------------------------------
+!
+      DO IBDY=1,2  
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((S_BDY.AND.IBDY==1).OR.(N_BDY.AND.IBDY==2))THEN
+!
+          IF(IBDY==1)THEN 
+            BF=P_YSB     ! Which boundary (YSB=the boundary where Y is at its start)
+            JB=1         ! Which cell in from Boundary 
+            JJ=1         ! Which cell in the Domain
+          ELSE
+            BF=P_YEB     ! Which boundary (YEB=the boundary where Y is at its end)
+            JB=1         ! Which cell in from Boundary
+            JJ=JJM       ! Which cell in the Domain
+          ENDIF
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_B(I,K,JB,BF)=U_B(I,K,JB,BF)+U_BT(I,K,JB,BF)*DT
+              V_B(I,K,JB,BF)=V_B(I,K,JB,BF)+V_BT(I,K,JB,BF)*DT
+              U(I,K,JJ)=U_B(I,K,JB,BF)
+              V(I,K,JJ)=V_B(I,K,JB,BF)
+            ENDDO
+          ENDDO
+!
+        ENDIF
+      ENDDO
+
+!
+!-----------------------------------------------------------------------
+!***  WEST AND EAST BOUNDARIES
+!***  USE IBDY=1 FOR WEST; 2 FOR EAST.
+!-----------------------------------------------------------------------
+!
+      DO IBDY=1,2    
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((W_BDY.AND.IBDY==1).OR.(E_BDY.AND.IBDY==2))THEN
+!
+          IF(IBDY==1)THEN 
+            BF=P_XSB     ! Which boundary (YSB=the boundary where Y is at its start)
+            IB=1         ! Which cell in from boundary
+            II=1         ! Which cell in the domain
+          ELSE
+            BF=P_XEB     ! Which boundary (YEB=the boundary where Y is at its end)
+            IB=1         ! Which cell in from boundary
+            II=IIM       ! Which cell in the domain
+          ENDIF
+!
+!$omp parallel do                                                       &
+!$omp& private(j,k)
+          DO K=KTS,KTE
+            DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)
+              IF(MOD(J,2)==0)THEN
+                U_B(J,K,IB,BF)=U_B(J,K,IB,BF)+U_BT(J,K,IB,BF)*DT
+                V_B(J,K,IB,BF)=V_B(J,K,IB,BF)+V_BT(J,K,IB,BF)*DT
+                U(II,K,J)=U_B(J,K,IB,BF)
+                V(II,K,J)=V_B(J,K,IB,BF)
+              ENDIF
+            ENDDO
+          ENDDO
+!
+        ENDIF
+      ENDDO
+
+!
+!-----------------------------------------------------------------------
+!***  EXTRAPOLATION OF TANGENTIAL VELOCITY AT OUTFLOW POINTS
+!***  BASED ON SOME DISCUSSIONS WITH ZAVISA AND EXPERIMENTS
+!***  ON GRAVITY PULSE FOR NESTED DOMAIN.
+!-----------------------------------------------------------------------
+!
+      IF(GRIDID/=1)GO TO 201
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,jj,k)
+      DO 200 K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!***  SOUTHERN BOUNDARY
+!
+      IF(S_BDY)THEN
+        DO I=MYIS1_P1,MYIE2_P1
+          IF(V(I,K,1)<0.)U(I,K,1)=(VTM(I,K,5)+1.)*U(I,K,3)              &
+     &                            -VTM(I,K,5)    *U(I,K,5)
+        ENDDO
+      ENDIF
+!
+!***  NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS1_P1,MYIE2_P1
+          IF(V(I,K,JJM)>0.)                                             &
+     &        U(I,K,JJM)=(VTM(I,K,JJM-4)+1.)*U(I,K,JJM-2)               &
+     &                   -VTM(I,K,JJM-4)    *U(I,K,JJM-4)
+        ENDDO
+      ENDIF
+!
+!***  WESTERN BOUNDARY
+!
+      DO J=4,JM-3,2
+        IF(W_BDY)THEN
+!
+          IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            IF(U(1,K,JJ)<0.)                                            &
+     &          V(1,K,JJ)=(VTM(3,K,JJ)+1.)*V(2,K,JJ)                    &
+     &                    -VTM(3,K,JJ)    *V(3,K,JJ)
+          ENDIF
+!
+        ENDIF
+      ENDDO
+!
+!***  EASTERN BOUNDARY
+!
+      DO J=4,JM-3,2
+        IF(E_BDY)THEN
+!
+          IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            IF(U(IIM,K,JJ)>0.)                                          &
+     &          V(IIM,K,JJ)=(VTM(IIM-2,K,JJ)+1.)*V(IIM-1,K,JJ)          &
+     &                      -VTM(IIM-2,K,JJ)    *V(IIM-2,K,JJ)
+          ENDIF
+!
+        ENDIF
+      ENDDO
+!-----------------------------------------------------------------------
+!
+  200 CONTINUE
+
+  201 CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  SPACE INTERPOLATION OF U AND V AT THE INNER BOUNDARY
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,jj,k)
+      DO 300 K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!***  SOUTHWEST CORNER
+!
+      IF(S_BDY.AND.W_BDY)THEN
+        U(2,K,2)=D06666*(4.*(U(1,K,1)+U(2,K,1)+U(2,K,3))                &
+     &                     + U(1,K,2)+U(1,K,4)+U(2,K,4))               
+        V(2,K,2)=D06666*(4.*(V(1,K,1)+V(2,K,1)+V(2,K,3))                &
+     &                      +V(1,K,2)+V(1,K,4)+V(2,K,4))
+      ENDIF
+!
+!***  SOUTHEAST CORNER
+!
+      IF(S_BDY.AND.E_BDY)THEN
+        U(IIM-1,K,2)=D06666*(4.*(U(IIM-2,K,1)+U(IIM-1,K,1)              &
+     &                          +U(IIM-2,K,3))                          &
+     &                          +U(IIM,K,2)+U(IIM,K,4)+U(IIM-1,K,4))
+        V(IIM-1,K,2)=D06666*(4.*(V(IIM-2,K,1)+V(IIM-1,K,1)              &
+     &                          +V(IIM-2,K,3))                          &
+     &                          +V(IIM,K,2)+V(IIM,K,4)+V(IIM-1,K,4))
+      ENDIF
+!
+!***  NORTHWEST CORNER
+!
+      IF(N_BDY.AND.W_BDY)THEN
+        U(2,K,JJM-1)=D06666*(4.*(U(1,K,JJM)+U(2,K,JJM)+U(2,K,JJM-2))    &
+     &                          +U(1,K,JJM-1)+U(1,K,JJM-3)              &
+     &                          +U(2,K,JJM-3))
+        V(2,K,JJM-1)=D06666*(4.*(V(1,K,JJM)+V(2,K,JJM)+V(2,K,JJM-2))    &
+     &                          +V(1,K,JJM-1)+V(1,K,JJM-3)              &
+     &                          +V(2,K,JJM-3))
+      ENDIF
+!
+!***  NORTHEAST CORNER
+!
+      IF(N_BDY.AND.E_BDY)THEN
+        U(IIM-1,K,JJM-1)=                                               &
+     &    D06666*(4.*(U(IIM-2,K,JJM)+U(IIM-1,K,JJM)+U(IIM-2,K,JJM-2))   &
+     &               +U(IIM,K,JJM-1)+U(IIM,K,JJM-3)+U(IIM-1,K,JJM-3))
+        V(IIM-1,K,JJM-1)=                                               &
+     &    D06666*(4.*(V(IIM-2,K,JJM)+V(IIM-1,K,JJM)+V(IIM-2,K,JJM-2))   &
+     &               +V(IIM,K,JJM-1)+V(IIM,K,JJM-3)+V(IIM-1,K,JJM-3))
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  SPACE INTERPOLATION OF U AND V AT THE INNER BOUNDARY
+!-----------------------------------------------------------------------
+!
+!***  ONE ROW NORTH OF SOUTHERN BOUNDARY
+!
+      IF(S_BDY)THEN
+        DO I=MYIS2,MYIE2
+          U(I,K,2)=(U(I-1,K,1)+U(I,K,1)+U(I-1,K,3)+U(I,K,3))*0.25
+          V(I,K,2)=(V(I-1,K,1)+V(I,K,1)+V(I-1,K,3)+V(I,K,3))*0.25
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS2,MYIE2
+          U(I,K,JJM-1)=(U(I-1,K,JJM-2)+U(I,K,JJM-2)                     &
+     &                 +U(I-1,K,JJM)+U(I,K,JJM))*0.25
+          V(I,K,JJM-1)=(V(I-1,K,JJM-2)+V(I,K,JJM-2)                     &
+     &                 +V(I-1,K,JJM)+V(I,K,JJM))*0.25
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW EAST OF WESTERN BOUNDARY
+!
+      DO J=3,JM-2,2
+        IF(W_BDY)THEN
+          IF(W_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            U(1,K,JJ)=(U(1,K,JJ-1)+U(2,K,JJ-1)                          &
+     &                +U(1,K,JJ+1)+U(2,K,JJ+1))*0.25
+            V(1,K,JJ)=(V(1,K,JJ-1)+V(2,K,JJ-1)                          &
+     &                +V(1,K,JJ+1)+V(2,K,JJ+1))*0.25
+          ENDIF
+        ENDIF
+      ENDDO
+!
+!***  ONE ROW WEST OF EASTERN BOUNDARY
+!
+      IF(E_BDY)THEN
+        DO J=3,JM-2,2
+          IF(E_BDY.AND.J>=MY_JS_GLB-JBPAD1                              &
+     &            .AND.J<=MY_JE_GLB+JTPAD1)THEN
+            JJ=J
+            U(IIM-1,K,JJ)=0.25*(U(IIM-1,K,JJ-1)+U(IIM,K,JJ-1)           &
+     &                         +U(IIM-1,K,JJ+1)+U(IIM,K,JJ+1))
+            V(IIM-1,K,JJ)=0.25*(V(IIM-1,K,JJ-1)+V(IIM,K,JJ-1)           &
+     &                         +V(IIM-1,K,JJ+1)+V(IIM,K,JJ+1))
+          ENDIF
+        ENDDO
+      ENDIF
+!-----------------------------------------------------------------------
+!
+  300 CONTINUE
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE BOCOV
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+      END MODULE MODULE_BNDRY_COND
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/module_CLDWTR.F b/wrfv2_fire/dyn_nmm/module_CLDWTR.F
new file mode 100644
index 00000000..3206f4cb
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_CLDWTR.F
@@ -0,0 +1,18 @@
+!
+      MODULE MODULE_CLDWTR
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+!***  GRID-SCALE CLOUD WATER
+!
+!jm      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CWM,F_ICE,F_RAIN,F_RIMEF
+!
+!jm      REAL,ALLOCATABLE,DIMENSION(:,:) :: SR,U00
+!jm      REAL,ALLOCATABLE,DIMENSION(:,:) :: CFRACH,CFRACL,CFRACM,CUPPT
+!
+!jm      INTEGER,ALLOCATABLE,DIMENSION(:,:) :: LC
+!jm      INTEGER,ALLOCATABLE,DIMENSION(:) :: UL
+!
+      LOGICAL MICRO_START
+!----------------------------------------------------------------------
+      END MODULE MODULE_CLDWTR
diff --git a/wrfv2_fire/dyn_nmm/module_CTLBLK.F b/wrfv2_fire/dyn_nmm/module_CTLBLK.F
new file mode 100644
index 00000000..2c44316b
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_CTLBLK.F
@@ -0,0 +1,40 @@
+!
+      MODULE MODULE_CTLBLK
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+!***  FUNDAMENTAL DOMAIN VARIABLES
+!
+      INTEGER :: IM,JM,LM
+      INTEGER :: NROOT
+!----------------------------------------------------------------------
+!
+!***  SET SOME CONSTANTS
+!
+      INTEGER :: LIST=6            ! STANDARD OUT UNIT NUMBER
+      INTEGER,PARAMETER :: LSM=39  ! NUMBER OF OUTPUT PRESSURE LEVELS
+!----------------------------------------------------------------------
+!
+!***  SINGLE GLOBAL OR MULTIPLE LOCAL RESTART FILES
+!
+      LOGICAL :: SINGLRST
+!----------------------------------------------------------------------
+!
+!***  VARIOUS CONTROL VARIABLES
+!
+      LOGICAL :: RUN,FIRST,RESTRT,NEST
+!
+!JW   REAL :: DT,TLM0D,TPH0D,TSPH
+      REAL :: TLM0D,TPH0D,TSPH
+!
+      INTEGER :: IHRST,NFCST,NUNIT_NBC,IOUT                            &
+                ,NTSTM,NSTART,NTDDMP,NBOCO,NSHDE 
+!               ,NTSD,NTSTM,NSTART,NTDDMP,NPREC,NBOCO,NSHDE 
+!
+      INTEGER,DIMENSION(3) :: IDAT
+!
+      INTEGER,DIMENSION(99) :: ISHDE
+!
+      REAL,DIMENSION(LSM) :: SPL
+!----------------------------------------------------------------------
+      END MODULE MODULE_CTLBLK
diff --git a/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F b/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F
new file mode 100644
index 00000000..a58e2d94
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F
@@ -0,0 +1,773 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: HORIZONTAL DIFFUSION
+!
+!-----------------------------------------------------------------------
+!
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_DIFFUSION_NMM
+!
+!-----------------------------------------------------------------------
+      USE MODULE_MODEL_CONSTANTS
+!-----------------------------------------------------------------------
+!
+      LOGICAL :: SECOND=.TRUE.
+      INTEGER :: KSMUD=1
+!
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV                        &
+     &                ,HTM,HBM2,VTM,DETA1,SIGMA                         &
+     &                ,T,Q,U,V,Q2,Z,W,SM,SICE                           &
+     &                ,IHE,IHW,IVE,IVW,INDX3_WRK                        &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    HDIFF       HORIZONTAL DIFFUSION
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 93-11-17
+!     
+! ABSTRACT:
+!     HDIFF CALCULATES THE CONTRIBUTION OF THE HORIZONTAL DIFFUSION
+!     TO THE TENDENCIES OF TEMPERATURE, SPECIFIC HUMIDITY, WIND
+!     COMPONENTS, AND TURBULENT KINETIC ENERGY AND THEN UPDATES THOSE
+!     VARIABLES.  A SECOND-ORDER NONLINEAR SCHEME SIMILAR TO
+!     SMAGORINSKY'S IS USED WHERE THE DIFFUSION COEFFICIENT IS
+!     A FUNCTION OF THE DEFORMATION FIELD AND OF THE TURBULENT
+!     KINETIC ENERGY.
+!     
+! PROGRAM HISTORY LOG:
+!   87-06-??  JANJIC     - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   96-03-28  BLACK      - ADDED EXTERNAL EDGE
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   02-02-07  BLACK      - CONVERTED TO WRF STRUCTURE
+!   02-08-29  MICHALAKES -
+!   02-09-06  WOLFE      -
+!   03-05-27  JANJIC     - ADDED SLOPE ADJUSTMENT
+!   04-11-18  BLACK      - THREADED
+!   06-08-15  JANJIC     - ENHANCEMENT AT SLOPING SEA COAST
+!     
+! USAGE: CALL HDIFF FROM SUBROUTINE SOLVE_RUNSTREAM
+!
+!   INPUT ARGUMENT LIST:
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,DY
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: DETA1
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2            &
+     &                                             ,HDAC,HDACV          &
+     &                                             ,SM,SICE
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,VTM,Z,W
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: T,Q,Q2   &
+     &                                                        ,U,V
+!
+      INTEGER, DIMENSION(JMS:JME), INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: SIGMA
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      LOGICAL :: CILINE,WATSLOP
+!
+      INTEGER :: I,J,J1_P1,J1_P2,J2_00,J2_M1,J2_P1,J3_00,J3_P1,J3_P2    &
+     &          ,J4_00,J4_M1,J4_M2,J4_P1,J4_P2,JJ,JKNT,JSTART,K,KS
+!
+      REAL :: DEF_J,DEFSK,DEFTK,HKNE_J,HKSE_J,Q2L,RDY,SLOP,SLOPHC       &
+     &       ,UTK,VKNE_J,VKSE_J,VTK,DEF1,DEF2,DEF3,DEF4
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: Q2L_IK,SNE,SSE
+!
+!***  TYPE 1 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-2:2) :: DEF
+!
+!***  TYPE 2 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-2:1) :: HKNE,QNE,Q2NE,TNE     &
+     &                                           ,UNE,VKNE,VNE
+!
+!***  TYPE 3 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:2) :: HKSE,QSE,Q2SE,TSE     &
+     &                                           ,USE,VKSE,VSE
+!
+!***  TYPE 4 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:1) :: CKE,QDIF,Q2DIF        &
+     &                                           ,TDIF,UDIF,VDIF
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      JSTART=MYJS2
+!-----------------------------------------------------------------------
+!
+      SLOPHC=SLOPHT*SQRT(2.)*0.5
+      RDY=1./DY
+!
+!-----------------------------------------------------------------------
+!***
+!***  DIFFUSING Q2 AT GROUND LEVEL DOES NOT MATTER
+!***  BECAUSE USTAR2 IS RECALCULATED
+!***
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J.
+!-----------------------------------------------------------------------
+!
+      DO J=-2,2
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        DEF(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO J=-2,1
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        TNE(I,K,J)=0.
+        QNE(I,K,J)=0.
+        Q2NE(I,K,J)=0.
+        HKNE(I,K,J)=0.
+        UNE(I,K,J)=0.
+        VNE(I,K,J)=0.
+        VKNE(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO J=-1,2
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        TSE(I,K,J)=0.
+        QSE(I,K,J)=0.
+        Q2SE(I,K,J)=0.
+        HKSE(I,K,J)=0.
+        USE(I,K,J)=0.
+        VSE(I,K,J)=0.
+        VKSE(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(def_j,def1,def2,def3,def4,defsk,deftk,i,j,jj,k,q2l)
+      DO J=-2,1
+        JJ=JSTART+J
+!
+        DO K=KTS,KTE
+
+        DO I=MYIS_P1,MYIE_P1
+          DEFTK=U(I+IHE(JJ),K,JJ)-U(I+IHW(JJ),K,JJ)                     &
+     &         -V(I,K,JJ+1)+V(I,K,JJ-1)
+          DEFSK=U(I,K,JJ+1)-U(I,K,JJ-1)                                 &
+     &         +V(I+IHE(JJ),K,JJ)-V(I+IHW(JJ),K,JJ)
+          Q2L=MAX(Q2(I,K,JJ),EPSQ2)
+          IF(Q2L<=EPSQ2)Q2L=0.
+!
+          DEF1=W(I+IHW(JJ),K,JJ-1)-W(I,K,JJ)
+          DEF2=W(I+IHE(JJ),K,JJ-1)-W(I,K,JJ)
+          DEF3=W(I+IHW(JJ),K,JJ+1)-W(I,K,JJ)
+          DEF4=W(I+IHE(JJ),K,JJ+1)-W(I,K,JJ)
+!
+          DEF_J=DEFTK*DEFTK+DEFSK*DEFSK+DEF1*DEF1+DEF2*DEF2+            &
+     &          DEF3*DEF3+DEF4*DEF4+SCQ2*Q2L
+          DEF_J=SQRT(DEF_J+DEF_J)*HBM2(I,JJ)
+          DEF_J=MAX(DEF_J,DEFC)
+          DEF_J=MIN(DEF_J,DEFM)
+          DEF_J=DEF_J*0.1
+          DEF(I,K,J)=DEF_J
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(hkne_j,i,j,jj,k,slop,sne,vkne_j)
+      DO J=-2,0
+        JJ=JSTART+J
+!
+!-----------------------------------------------------------------------
+!***  SLOPE SWITCHES FOR MOISTURE
+!-----------------------------------------------------------------------
+!
+        IF(SIGMA==1)THEN
+          DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!***  PRESSURE DOMAIN
+!-----------------------------------------------------------------------
+!
+            IF(DETA1(K)>0.)THEN
+              DO I=MYIS_P1,MYIE1_P1
+                SNE(I,K)=1.
+              ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SIGMA DOMAIN
+!-----------------------------------------------------------------------
+!
+            ELSE
+              DO I=MYIS_P1,MYIE1_P1
+                SLOP=ABS((Z(I+IHE(JJ),K,JJ+1)-Z(I,K,JJ))*RDY)
+!
+                CILINE=((SM(I+IHE(JJ),JJ+1)/=SM(I,JJ)) .OR.             &
+                        (SICE(I+IHE(JJ),JJ+1)/=SICE(I,JJ)))
+!
+                WATSLOP=(SM(I+IHE(JJ),JJ+1)==1.0 .AND.                  &
+                         SM(I,JJ)==1.0 .AND. SLOP/=0.)
+!
+                IF(SLOP0.)THEN
+              DO I=MYIS_P1,MYIE1_P1
+                SSE(I,K)=1.
+              ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SIGMA DOMAIN
+!-----------------------------------------------------------------------
+!
+            ELSE
+              DO I=MYIS_P1,MYIE1_P1
+                SLOP=ABS((Z(I+IHE(JJ),K,JJ-1)-Z(I,K,JJ))*RDY)
+!
+                CILINE=((SM(I+IHE(JJ),JJ-1)/=SM(I,JJ)) .OR.             &
+                        (SICE(I+IHE(JJ),JJ-1)/=SICE(I,JJ)))
+!
+                WATSLOP=(SM(I+IHE(JJ),JJ-1)==1.0 .AND.                  &
+                         SM(I,JJ)==1.0 .AND. SLOP/=0.) 
+!
+                IF(SLOP0.)THEN
+            DO I=MYIS_P1,MYIE1_P1
+              SNE(I,K)=1.
+              SSE(I,K)=1.
+            ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SIGMA DOMAIN
+!-----------------------------------------------------------------------
+!
+          ELSE
+            DO I=MYIS_P1,MYIE1_P1
+              SLOP=ABS((Z(I+IHE(J+1),K,J+2)-Z(I,K,J+1))*RDY)
+!
+              CILINE=((SM(I+IHE(J+1),J+2)/=SM(I,J+1)) .OR.              &
+                      (SICE(I+IHE(J+1),J+2)/=SICE(I,J+1)))
+!
+              WATSLOP=(SM(I+IHE(J+1),J+2)==1.0 .AND.                    &
+                       SM(I,J+1)==1.0 .AND. SLOP/=0.)
+!
+              IF(SLOP
+#endif
+!-----------------------------------------------------------------------
+!
+        ENDDO  ! End of smoothing loop
+!
+!-----------------------------------------------------------------------
+      ENDIF nonhydrostatic_smoothing
+!-----------------------------------------------------------------------
+      END SUBROUTINE PDTE
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE VTOA(                                                  &
+#ifdef DM_PARALLEL
+     &                grid,                                             &
+#endif
+     &                NTSD,DT,PT,ETA2                                   &
+     &               ,HTM,HBM2,EF4T                                     &
+     &               ,T,DWDT,RTOP,OMGALF                                &
+     &               ,PINT,DIV,PSDT,RES                                 &
+     &               ,IHE,IHW,IVE,IVW,INDX3_WRK                         &                 
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &               ,IMS,IME,JMS,JME,KMS,KME                           &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    VTOA        OMEGA-ALPHA
+!   PRGRMMR: JANJIC          ORG: W/NP2      DATE: 04-02-17      
+!     
+! ABSTRACT:
+!     VTOA UPDATES THE NONHYDROSTATIC PRESSURE AND ADDS THE
+!     CONTRIBUTION OF THE OMEGA-ALPHA TERM OF THE THERMODYNAMIC
+!     EQUATION.  ALSO, THE OMEGA-ALPHA TERM IS COMPUTED FOR DIAGNOSTICS.
+!     
+! PROGRAM HISTORY LOG:
+!   04-02-17  JANJIC     - SEPARATED FROM ORIGINAL PDTEDT ROUTINE
+!   04-11-23  BLACK      - THREADED
+!     
+
+!   INPUT ARGUMENT LIST:
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!***********************************************************************
+#ifdef DM_PARALLEL
+      USE MODULE_DOMAIN
+      USE MODULE_DM
+#endif
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+!     INCLUDE "mpif.h"
+      TYPE (DOMAIN) :: GRID
+#endif
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+                           ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,EF4T,PT
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HBM2,PSDT,RES
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DIV,DWDT    &
+     &                                                     ,HTM,RTOP
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: OMGALF,T  
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: PINT
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      INTEGER :: I,IHH,IHL,IX,J,JHH,JHL,JJ,JX,K,KNT,KS,NSMUD
+      INTEGER :: J1_00,J1_M1,J2_00,J2_P1
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: PRET,TPM
+!
+      REAL :: DWDTP,RHS,TPMP
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!***  PREPARATIONS
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS_P2,MYJE_P2
+      DO I=MYIS_P2,MYIE_P2
+        PINT(I,KTE+1,J)=PT
+        TPM(I,J)=PT+PINT(I,KTE,J)
+        PRET(I,J)=PSDT(I,J)*RES(I,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***  KINETIC ENERGY GENERATION TERMS IN T EQUATION
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dwdtp,i,j,rhs,tpmp)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        DWDTP=DWDT(I,KTE,J)
+        TPMP=PINT(I,KTE,J)+PINT(I,KTE-1,J)
+!
+        RHS=-DIV(I,KTE,J)*RTOP(I,KTE,J)*HTM(I,KTE,J)*DWDTP*EF4T
+        OMGALF(I,KTE,J)=OMGALF(I,KTE,J)+RHS
+        T(I,KTE,J)=OMGALF(I,KTE,J)*HBM2(I,J)+T(I,KTE,J)
+        PINT(I,KTE,J)=PRET(I,J)*(ETA2(KTE+1)+ETA2(KTE))*DWDTP*DT        &
+     &             +TPM(I,J)-PINT(I,KTE+1,J)
+!
+        TPM(I,J)=TPMP
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dwdtp,i,j,k,rhs,tpmp)
+      DO J=MYJS,MYJE
+        DO K=KTE-1,KTS+1,-1
+        DO I=MYIS,MYIE
+          DWDTP=DWDT(I,K,J)
+          TPMP=PINT(I,K,J)+PINT(I,K-1,J)
+!
+          RHS=-(DIV(I,K+1,J)+DIV(I,K,J))*RTOP(I,K,J)*HTM(I,K,J)*DWDTP   &
+     &         *EF4T
+          OMGALF(I,K,J)=OMGALF(I,K,J)+RHS
+          T(I,K,J)=OMGALF(I,K,J)*HBM2(I,J)+T(I,K,J)
+          PINT(I,K,J)=PRET(I,J)*(ETA2(K+1)+ETA2(K))*DWDTP*DT            &
+     &               +TPM(I,J)-PINT(I,K+1,J)
+!
+          TPM(I,J)=TPMP
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dwdtp,i,j,rhs)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+!
+        DWDTP=DWDT(I,KTS,J)
+!
+        RHS=-(DIV(I,KTS+1,J)+DIV(I,KTS,J))*RTOP(I,KTS,J)*HTM(I,KTS,J)   &
+     &       *DWDTP*EF4T
+        OMGALF(I,KTS,J)=OMGALF(I,KTS,J)+RHS
+        T(I,KTS,J)=OMGALF(I,KTS,J)*HBM2(I,J)+T(I,KTS,J)
+        PINT(I,KTS,J)=PRET(I,J)*(ETA2(KTS+1)+ETA2(KTS))*DWDTP*DT        &
+     &                 +TPM(I,J)-PINT(I,KTS+1,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE VTOA
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE DDAMP(NTSD,DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2,VTM      &
+     &                ,T,U,V,DDMPU,DDMPV                                &
+     &                ,IHE,IHW,IVE,IVW,INDX3_WRK                        &              
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    DDAMP       DIVERGENCE DAMPING
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 94-03-08       
+!     
+! ABSTRACT:
+!     DDAMP MODIFIES THE WIND COMPONENTS SO AS TO REDUCE THE
+!     HORIZONTAL DIVERGENCE.
+!     
+! PROGRAM HISTORY LOG:
+!   87-08-??  JANJIC     - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   95-03-28  BLACK      - ADDED EXTERNAL EDGE
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   01-03-12  BLACK      - CONVERTED TO WRF STRUCTURE
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL DDAMP FROM SUBROUTINE SOLVE_RUNSTREAM
+!
+!   INPUT ARGUMENT LIST:
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBPROGRAMS CALLED:
+!  
+!     UNIQUE: NONE
+!  
+!     LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,PDTOP
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDMPU,DDMPV         &
+     &                                             ,HBM2,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: VTM
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: DIV,T    &
+     &                                                        ,U,V
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      INTEGER :: I,IER,J,J4_00,J4_M1,J4_P1,JJ,JKNT,JSTART,K,STAT
+!
+      REAL :: RDPDX,RDPDY
+!
+!***  TYPE 4 WORKING ARRAY   ! See PFDHT
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:1) :: CKE,DPDE
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE WORKING ARRAY NEEDED FOR AVERAGING AND
+!***  DIFFERENCING IN J
+!
+!-----------------------------------------------------------------------
+      JSTART=MYJS2
+!
+      DO J=-1,0
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P2,MYIE_P2
+          DPDE(I,K,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,JJ)
+          DIV(I,K,JJ)=DIV(I,K,JJ)*HBM2(I,JJ)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+      JKNT=0
+!-----------------------------------------------------------------------
+!
+      main_integration : DO J=MYJS2,MYJE2
+!
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX OF THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND PFDHT DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P2 denotes +2, etc.)
+!***
+      JKNT=JKNT+1
+!
+      J4_P1=INDX3_WRK(1,JKNT,4)
+      J4_00=INDX3_WRK(0,JKNT,4)
+      J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,k,rdpdx,rdpdy)
+      DO K=KTS,KTE
+!
+      DO I=MYIS_P2,MYIE_P2
+        DPDE(I,K,J4_P1)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J+1)
+        DIV(I,K,J+1)=DIV(I,K,J+1)*HBM2(I,J+1)
+      ENDDO
+!
+      DO I=MYIS1_P1,MYIE1_P1
+        RDPDX=VTM(I,K,J)/(DPDE(I+IVW(J),K,J4_00)                        &
+     &                   +DPDE(I+IVE(J),K,J4_00))
+        U(I,K,J)=U(I,K,J)+(DIV(I+IVE(J),K,J)-DIV(I+IVW(J),K,J))         &
+     &                    *RDPDX*DDMPU(I,J)
+!
+        RDPDY=VTM(I,K,J)/(DPDE(I,K,J4_M1)+DPDE(I,K,J4_P1))
+        V(I,K,J)=V(I,K,J)+(DIV(I,K,J+1)-DIV(I,K,J-1))                   &
+     &                    *RDPDY*DDMPV(I,J)
+      ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE DDAMP
+!-----------------------------------------------------------------------
+      END MODULE MODULE_IGWAVE_ADJUST
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/module_INDX.F b/wrfv2_fire/dyn_nmm/module_INDX.F
new file mode 100644
index 00000000..b15c3c51
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_INDX.F
@@ -0,0 +1,49 @@
+!
+      MODULE MODULE_INDX
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+!***  INDEX INCREMENTS FOR MOVING TO NEIGHBORS ON THE E-GRID
+!
+      INTEGER,ALLOCATABLE,DIMENSION(:) :: IHE,IHW,IVE,IVW,IRAD         &
+                                         ,IHEG,IHWG,IVEG,IVWG,IRADG
+!----------------------------------------------------------------------
+!
+!***  INDEX INCREMENTS FOR 3RD INDEX IN WORKING ARRAYS IN PFDHT, DDAMP,
+!***  ADVE, AND HDIFF.
+!
+      INTEGER,ALLOCATABLE,DIMENSION(:,:,:) :: INDX3_WRK
+!----------------------------------------------------------------------
+!
+!***  INCREMENTS TO J1_00 IN UPSTREAM HORIZONTAL ADVECTION.
+!
+      INTEGER,DIMENSION(-2:2,-2:2) :: INC_UPS
+!----------------------------------------------------------------------
+!
+!***  NUMBER OF POINTS NEEDED IN EACH ROW FOR UPSTREAM COMPUTATIONS
+!
+      INTEGER,ALLOCATABLE,DIMENSION(:) :: N_IUP_H,N_IUP_V              &
+                                         ,N_IUP_ADH,N_IUP_ADV
+!
+!***  I VALUES IN EACH ROW NEEDED FOR UPSTREAM ADVECTION
+!
+      INTEGER,ALLOCATABLE,DIMENSION(:,:) :: IUP_H,IUP_V,IUP_ADH,IUP_ADV
+!----------------------------------------------------------------------
+
+      CONTAINS
+         SUBROUTINE init_module_indx
+#if 0
+            ALLOCATE(IHE(-2:NMM_MAX_DIM))
+            ALLOCATE(IHW(-2:NMM_MAX_DIM))
+            ALLOCATE(IVE(-2:NMM_MAX_DIM))
+            ALLOCATE(IVW(-2:NMM_MAX_DIM))
+            ALLOCATE(IRAD(-2:NMM_MAX_DIM))
+            ALLOCATE(IHEG(-2:NMM_MAX_DIM))
+            ALLOCATE(IHWG(-2:NMM_MAX_DIM))
+            ALLOCATE(IVEG(-2:NMM_MAX_DIM))
+            ALLOCATE(IVWG(-2:NMM_MAX_DIM))
+            ALLOCATE(IRADG(-2:NMM_MAX_DIM))
+            ALLOCATE(INDX3_WRK(-3:3,1:NMM_MAX_DIM,0:6))
+#endif
+         END SUBROUTINE init_module_indx
+      END MODULE MODULE_INDX
diff --git a/wrfv2_fire/dyn_nmm/module_MPP.F b/wrfv2_fire/dyn_nmm/module_MPP.F
new file mode 100644
index 00000000..255d3adb
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_MPP.F
@@ -0,0 +1,61 @@
+!
+      MODULE MODULE_MPP
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+!***  THE RANK OF THIS TASK
+!
+      INTEGER :: MYPE
+!----------------------------------------------------------------------
+!
+!***  NUMBER OF TASKS
+!
+      INTEGER :: INPES,JNPES,NPES
+!
+!***  FUNDAMENTAL GLOBAL AND LOCAL ARRAY EXTENTS ON EACH TASK
+!
+      INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB               &
+                ,MY_IS_LOC,MY_IE_LOC,MY_JS_LOC,MY_JE_LOC
+!----------------------------------------------------------------------
+!
+!***  SUB-DOMAIN LOOP LIMITS THAT PENETRATE HALOES
+!
+      INTEGER :: MYIS,MYIE,MYJS,MYJE                                   &
+                ,MYIS1,MYIS2,MYIS3,MYIS4,MYIS5                         &
+                ,MYIE1,MYIE2,MYIE3,MYIE4,MYIE5                         &
+                ,MYIS_P1,MYIS_P2,MYIS_P3,MYIS_P4,MYIS_P5               &
+                ,MYIS1_P1,MYIS1_P2,MYIS1_P3,MYIS1_P4,MYIS1_P5          &
+                ,MYIS2_P1,MYIS2_P2,MYIS2_P3,MYIS2_P4,MYIS2_P5          &
+                ,MYIS3_P1,MYIS3_P2,MYIS3_P3,MYIS3_P4,MYIS3_P5          &
+                ,MYIS4_P1,MYIS4_P2,MYIS4_P3,MYIS4_P4,MYIS4_P5          &
+                ,MYIS5_P1,MYIS5_P2,MYIS5_P3,MYIS5_P4,MYIS5_P5          &
+                ,MYIE_P1,MYIE_P2,MYIE_P3,MYIE_P4,MYIE_P5               &
+                ,MYIE1_P1,MYIE1_P2,MYIE1_P3,MYIE1_P4,MYIE1_P5          &
+                ,MYIE2_P1,MYIE2_P2,MYIE2_P3,MYIE2_P4,MYIE2_P5          &
+                ,MYIE3_P1,MYIE3_P2,MYIE3_P3,MYIE3_P4,MYIE3_P5          &
+                ,MYIE4_P1,MYIE4_P2,MYIE4_P3,MYIE4_P4,MYIE4_P5          &
+                ,MYIE5_P1,MYIE5_P2,MYIE5_P3,MYIE5_P4,MYIE5_P5          &
+                ,MYJS1,MYJS2,MYJS3,MYJS4,MYJS5                         &
+                ,MYJE1,MYJE2,MYJE3,MYJE4,MYJE5                         &
+                ,MYJS_P1,MYJS_P2,MYJS_P3,MYJS_P4,MYJS_P5               &
+                ,MYJS1_P1,MYJS1_P2,MYJS1_P3,MYJS1_P4,MYJS1_P5          &
+                ,MYJS2_P1,MYJS2_P2,MYJS2_P3,MYJS2_P4,MYJS2_P5          &
+                ,MYJS3_P1,MYJS3_P2,MYJS3_P3,MYJS3_P4,MYJS3_P5          &
+                ,MYJS4_P1,MYJS4_P2,MYJS4_P3,MYJS4_P4,MYJS4_P5          &
+                ,MYJS5_P1,MYJS5_P2,MYJS5_P3,MYJS5_P4,MYJS5_P5          &
+                ,MYJE_P1,MYJE_P2,MYJE_P3,MYJE_P4,MYJE_P5               &
+                ,MYJE1_P1,MYJE1_P2,MYJE1_P3,MYJE1_P4,MYJE1_P5          &
+                ,MYJE2_P1,MYJE2_P2,MYJE2_P3,MYJE2_P4,MYJE2_P5          &
+                ,MYJE3_P1,MYJE3_P2,MYJE3_P3,MYJE3_P4,MYJE3_P5          &
+                ,MYJE4_P1,MYJE4_P2,MYJE4_P3,MYJE4_P4,MYJE4_P5          &
+                ,MYJE5_P1,MYJE5_P2,MYJE5_P3,MYJE5_P4,MYJE5_P5
+
+!
+!----------------------------------------------------------------------
+!
+!***  MPI_COMM_COMP IS THE INTRACOMMUNICATOR FOR ALL TASKS.
+!
+      INTEGER :: MPI_COMM_COMP
+
+!----------------------------------------------------------------------
+      END MODULE MODULE_MPP
diff --git a/wrfv2_fire/dyn_nmm/module_MPPINIT.F b/wrfv2_fire/dyn_nmm/module_MPPINIT.F
new file mode 100644
index 00000000..bd465cf4
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_MPPINIT.F
@@ -0,0 +1,447 @@
+!
+!NCEP_MESO:MEDIATION_LAYER: SET UP DOMAIN DECOMPOSITION VARIABLES
+!
+!
+!----------------------------------------------------------------------
+!
+      MODULE MODULE_MPPINIT
+!
+!----------------------------------------------------------------------
+      USE MODULE_MPP
+!----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!**********************************************************************
+      SUBROUTINE MPPINIT(IDS,IDE,JDS,JDE,KDS,KDE                       &
+                        ,IMS,IME,JMS,JME,KMS,KME                       &
+                        ,IPS,IPE,JPS,JPE,KPS,KPE)
+!**********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    MPPINIT     SET UP DECOMPOSITION VARIABLES
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 98-10-28
+!
+! ABSTRACT:
+!     MPPINIT DETERMINES ALL RELEVANT VALUES FOR DIMENSIONS OF THE
+!     DISTRIBUTED SUBDOMAINS AND THEIR HALOES.
+!
+! PROGRAM HISTORY LOG:
+!   97-??-??  MEYS       - ORIGINATOR
+!   97-??-??  BLACK      - CHANGES MADE FOR CLARITY
+!   98-10-29  BLACK      - REWRITTEN FOR CLARITY
+!
+! USAGE: CALL MPPINIT FROM MAIN PROGRAM NCEP_MESO
+!   INPUT ARGUMENT LIST:
+
+!   OUTPUT ARGUMENT LIST:
+!     NONE
+!
+!   OUTPUT FILES:
+!     NONE
+!
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE:
+!        NONE
+!
+!     LIBRARY:
+!        NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+                           ,IMS,IME,JMS,JME,KMS,KME                    &
+                           ,IPS,IPE,JPS,JPE,KPS,KPE
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+
+      CALL wrf_get_myproc ( MYPE )
+      CALL wrf_get_nproc  ( NPES )
+      CALL wrf_get_dm_communicator ( mpi_comm_comp )
+
+!jm
+      MYIS    = MAX( IPS-0, IDS+0 )
+      MYIS_P1 = MAX( IPS-1, IDS+0 )
+      MYIS_P2 = MAX( IPS-2, IDS+0 )
+      MYIS_P3 = MAX( IPS-3, IDS+0 )
+      MYIS_P4 = MAX( IPS-4, IDS+0 )
+      MYIS_P5 = MAX( IPS-5, IDS+0 )
+!
+      MYIS1   = MAX( IPS-0, IDS+1 )
+      MYIS1_P1= MAX( IPS-1, IDS+1 )
+      MYIS1_P2= MAX( IPS-2, IDS+1 )
+      MYIS1_P3= MAX( IPS-3, IDS+1 )
+      MYIS1_P4= MAX( IPS-4, IDS+1 )
+      MYIS1_P5= MAX( IPS-5, IDS+1 )
+!
+      MYIS2   = MAX( IPS-0, IDS+2 )
+      MYIS2_P1= MAX( IPS-1, IDS+2 )
+      MYIS2_P2= MAX( IPS-2, IDS+2 )
+      MYIS2_P3= MAX( IPS-3, IDS+2 )
+      MYIS2_P4= MAX( IPS-4, IDS+2 )
+      MYIS2_P5= MAX( IPS-5, IDS+2 )
+!
+      MYIS3   = MAX( IPS-0, IDS+3 )
+      MYIS3_P1= MAX( IPS-1, IDS+3 )
+      MYIS3_P2= MAX( IPS-2, IDS+3 )
+      MYIS3_P3= MAX( IPS-3, IDS+3 )
+      MYIS3_P4= MAX( IPS-4, IDS+3 )
+      MYIS3_P5= MAX( IPS-5, IDS+3 )
+!
+      MYIS4   = MAX( IPS-0, IDS+4 )
+      MYIS4_P1= MAX( IPS-1, IDS+4 )
+      MYIS4_P2= MAX( IPS-2, IDS+4 )
+      MYIS4_P3= MAX( IPS-3, IDS+4 )
+      MYIS4_P4= MAX( IPS-4, IDS+4 )
+      MYIS4_P5= MAX( IPS-5, IDS+4 )
+!
+      MYIS5   = MAX( IPS-0, IDS+5 )
+      MYIS5_P1= MAX( IPS-1, IDS+5 )
+      MYIS5_P2= MAX( IPS-2, IDS+5 )
+      MYIS5_P3= MAX( IPS-3, IDS+5 )
+      MYIS5_P4= MAX( IPS-4, IDS+5 )
+      MYIS5_P5= MAX( IPS-5, IDS+5 )
+
+!jm
+      MYIE    = MIN( IPE+0, IDE-0 )
+      MYIE_P1 = MIN( IPE+1, IDE-0 )
+      MYIE_P2 = MIN( IPE+2, IDE-0 )
+      MYIE_P3 = MIN( IPE+3, IDE-0 )
+      MYIE_P4 = MIN( IPE+4, IDE-0 )
+      MYIE_P5 = MIN( IPE+5, IDE-0 )
+!
+      MYIE1   = MIN( IPE+0, IDE-1 )
+      MYIE1_P1= MIN( IPE+1, IDE-1 )
+      MYIE1_P2= MIN( IPE+2, IDE-1 )
+      MYIE1_P3= MIN( IPE+3, IDE-1 )
+      MYIE1_P4= MIN( IPE+4, IDE-1 )
+      MYIE1_P5= MIN( IPE+5, IDE-1 )
+!
+      MYIE2   = MIN( IPE+0, IDE-2 )
+      MYIE2_P1= MIN( IPE+1, IDE-2 )
+      MYIE2_P2= MIN( IPE+2, IDE-2 )
+      MYIE2_P3= MIN( IPE+3, IDE-2 )
+      MYIE2_P4= MIN( IPE+4, IDE-2 )
+      MYIE2_P5= MIN( IPE+5, IDE-2 )
+!
+      MYIE3   = MIN( IPE+0, IDE-3 )
+      MYIE3_P1= MIN( IPE+1, IDE-3 )
+      MYIE3_P2= MIN( IPE+2, IDE-3 )
+      MYIE3_P3= MIN( IPE+3, IDE-3 )
+      MYIE3_P4= MIN( IPE+4, IDE-3 )
+      MYIE3_P5= MIN( IPE+5, IDE-3 )
+!
+      MYIE4   = MIN( IPE+0, IDE-4 )
+      MYIE4_P1= MIN( IPE+1, IDE-4 )
+      MYIE4_P2= MIN( IPE+2, IDE-4 )
+      MYIE4_P3= MIN( IPE+3, IDE-4 )
+      MYIE4_P4= MIN( IPE+4, IDE-4 )
+      MYIE4_P5= MIN( IPE+5, IDE-4 )
+!
+      MYIE5   = MIN( IPE+0, IDE-5 )
+      MYIE5_P1= MIN( IPE+1, IDE-5 )
+      MYIE5_P2= MIN( IPE+2, IDE-5 )
+      MYIE5_P3= MIN( IPE+3, IDE-5 )
+      MYIE5_P4= MIN( IPE+4, IDE-5 )
+      MYIE5_P5= MIN( IPE+5, IDE-5 )
+
+!jm
+      MYJS    = MAX( JPS-0, JDS+0 )
+      MYJS_P1 = MAX( JPS-1, JDS+0 )
+      MYJS_P2 = MAX( JPS-2, JDS+0 )
+      MYJS_P3 = MAX( JPS-3, JDS+0 )
+      MYJS_P4 = MAX( JPS-4, JDS+0 )
+      MYJS_P5 = MAX( JPS-5, JDS+0 )
+!
+      MYJS1   = MAX( JPS-0, JDS+1 )
+      MYJS1_P1= MAX( JPS-1, JDS+1 )
+      MYJS1_P2= MAX( JPS-2, JDS+1 )
+      MYJS1_P3= MAX( JPS-3, JDS+1 )
+      MYJS1_P4= MAX( JPS-4, JDS+1 )
+      MYJS1_P5= MAX( JPS-5, JDS+1 )
+!
+      MYJS2   = MAX( JPS-0, JDS+2 )
+      MYJS2_P1= MAX( JPS-1, JDS+2 )
+      MYJS2_P2= MAX( JPS-2, JDS+2 )
+      MYJS2_P3= MAX( JPS-3, JDS+2 )
+      MYJS2_P4= MAX( JPS-4, JDS+2 )
+      MYJS2_P5= MAX( JPS-5, JDS+2 )
+!
+      MYJS3   = MAX( JPS-0, JDS+3 )
+      MYJS3_P1= MAX( JPS-1, JDS+3 )
+      MYJS3_P2= MAX( JPS-2, JDS+3 )
+      MYJS3_P3= MAX( JPS-3, JDS+3 )
+      MYJS3_P4= MAX( JPS-4, JDS+3 )
+      MYJS3_P5= MAX( JPS-5, JDS+3 )
+!
+      MYJS4   = MAX( JPS-0, JDS+4 )
+      MYJS4_P1= MAX( JPS-1, JDS+4 )
+      MYJS4_P2= MAX( JPS-2, JDS+4 )
+      MYJS4_P3= MAX( JPS-3, JDS+4 )
+      MYJS4_P4= MAX( JPS-4, JDS+4 )
+      MYJS4_P5= MAX( JPS-5, JDS+4 )
+!
+      MYJS5   = MAX( JPS-0, JDS+5 )
+      MYJS5_P1= MAX( JPS-1, JDS+5 )
+      MYJS5_P2= MAX( JPS-2, JDS+5 )
+      MYJS5_P3= MAX( JPS-3, JDS+5 )
+      MYJS5_P4= MAX( JPS-4, JDS+5 )
+      MYJS5_P5= MAX( JPS-5, JDS+5 )
+!
+!jm
+      MYJE    = MIN( JPE+0, JDE-0 )
+      MYJE_P1 = MIN( JPE+1, JDE-0 )
+      MYJE_P2 = MIN( JPE+2, JDE-0 )
+      MYJE_P3 = MIN( JPE+3, JDE-0 )
+      MYJE_P4 = MIN( JPE+4, JDE-0 )
+      MYJE_P5 = MIN( JPE+5, JDE-0 )
+!
+      MYJE1   = MIN( JPE+0, JDE-1 )
+      MYJE1_P1= MIN( JPE+1, JDE-1 )
+      MYJE1_P2= MIN( JPE+2, JDE-1 )
+      MYJE1_P3= MIN( JPE+3, JDE-1 )
+      MYJE1_P4= MIN( JPE+4, JDE-1 )
+      MYJE1_P5= MIN( JPE+5, JDE-1 )
+!
+      MYJE2   = MIN( JPE+0, JDE-2 )
+      MYJE2_P1= MIN( JPE+1, JDE-2 )
+      MYJE2_P2= MIN( JPE+2, JDE-2 )
+      MYJE2_P3= MIN( JPE+3, JDE-2 )
+      MYJE2_P4= MIN( JPE+4, JDE-2 )
+      MYJE2_P5= MIN( JPE+5, JDE-2 )
+!
+      MYJE3   = MIN( JPE+0, JDE-3 )
+      MYJE3_P1= MIN( JPE+1, JDE-3 )
+      MYJE3_P2= MIN( JPE+2, JDE-3 )
+      MYJE3_P3= MIN( JPE+3, JDE-3 )
+      MYJE3_P4= MIN( JPE+4, JDE-3 )
+      MYJE3_P5= MIN( JPE+5, JDE-3 )
+!
+      MYJE4   = MIN( JPE+0, JDE-4 )
+      MYJE4_P1= MIN( JPE+1, JDE-4 )
+      MYJE4_P2= MIN( JPE+2, JDE-4 )
+      MYJE4_P3= MIN( JPE+3, JDE-4 )
+      MYJE4_P4= MIN( JPE+4, JDE-4 )
+      MYJE4_P5= MIN( JPE+5, JDE-4 )
+!
+      MYJE5   = MIN( JPE+0, JDE-5 )
+      MYJE5_P1= MIN( JPE+1, JDE-5 )
+      MYJE5_P2= MIN( JPE+2, JDE-5 )
+      MYJE5_P3= MIN( JPE+3, JDE-5 )
+      MYJE5_P4= MIN( JPE+4, JDE-5 )
+      MYJE5_P5= MIN( JPE+5, JDE-5 )
+
+!----------------------------------------------------------------------
+      END SUBROUTINE MPPINIT
+!**********************************************************************
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!jm!**********************************************************************
+!jm!----------------------------------------------------------------------
+!jm!
+!jm!**********************************************************************
+!jm      SUBROUTINE GOSSIP(IDS,IDE,JDS,JDE,KDS,KDE                        &
+!jm                       ,IMS,IME,JMS,JME,KMS,KME                        &
+!jm                       ,ITS,ITE,JTS,JTE,KTS,KTE)
+!jm!**********************************************************************
+!jm!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!jm!                .      .    .
+!jm! SUBPROGRAM:    GOSSIP      EXCHANGE OF FIELDS BETWEEN PROCESSORS
+!jm!   PRGRMMR: BLACK           ORG: W/NP2      DATE: 97-08-30
+!jm!
+!jm! ABSTRACT:
+!jm!     GOSSIP EXCHANGES MANY FIELDS BETWEEN PROCESSORS
+!jm!     IN ORDER TO FILL THE HALOES
+!jm!
+!jm! PROGRAM HISTORY LOG:
+!jm!   97-05-??  MEYS       - ORIGINATOR
+!jm!   98-10-23  BLACK      - MODIFIED FOR CURRENT VERSION OF MODEL 
+!jm!   01-03-21  BLACK      - CONVERTED TO WRF FORMAT
+!jm!
+!jm! USAGE: CALL GOSSIP FROM MAIN PROGRAM EBU
+!jm!   INPUT ARGUMENT LIST:
+!jm!       IMS - TASKS'S STARTING I ADDRESS
+!jm!       IME - TASKS'S ENDING I ADDRESS
+!jm!       JMS - TASKS'S STARTING J ADDRESS
+!jm!       JME - TASKS'S ENDING J ADDRESS
+!jm!       KMS - TASKS'S STARTING K ADDRESS
+!jm!       KME - TASKS'S ENDING K ADDRESS
+!jm!
+!jm!   OUTPUT ARGUMENT LIST:
+!jm!     NONE
+!jm!
+!jm!   OUTPUT FILES:
+!jm!     NONE
+!jm!
+!jm!   SUBPROGRAMS CALLED:
+!jm!
+!jm!     UNIQUE: EXCH
+!jm!
+!jm!     LIBRARY: NONE
+!jm!
+!jm! ATTRIBUTES:
+!jm!   LANGUAGE: FORTRAN 90
+!jm!   MACHINE : IBM SP
+!jm!$$$
+!jm!**********************************************************************
+!jm!----------------------------------------------------------------------
+!jm!
+!jm      IMPLICIT NONE
+!jm!
+!jm!----------------------------------------------------------------------
+!jm      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+!jm                           ,IMS,IME,JMS,JME,KMS,KME                    &
+!jm                           ,ITS,ITE,JTS,JTE,KTS,KTE
+!jm!
+!jm      INTEGER :: J
+!jm!----------------------------------------------------------------------
+!jm!**********************************************************************
+!jm!
+!jm!***  THE NHB ARRAYS
+!jm!
+!jm      CALL EXCH(LMH,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(LMV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(HBM2,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(HBM3,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(VBM2,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(VBM3,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(SM,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(SICE,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(HTM,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(VTM,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(DX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(WPDAR,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(CPGFU,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(CURV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(FCP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(FDIV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(FAD,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(F,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(DDMPU,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(DDMPV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(GLAT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(GLON,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(EPSR,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(TG,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(GFFC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(SST,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(ALBASE,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(HDAC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(HDACV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(IVGTYP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(ISLTYP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(ISLOPE,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH(VEGFRC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm!
+!jm!***  THE RESTRT FILE ARRAYS
+!jm!
+!jm      CALL EXCH (OMGALF,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (PD,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RES,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (FIS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (T,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (U,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (V,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (Q,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (Q2,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CWM,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (TRAIN,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (TCUCN,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RSWIN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RSWOUT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (TG,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (Z0,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (AKMS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CZEN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (AKHS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (THS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (QS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (TWBS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (QWBS,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (HBOT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CFRACL,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (THZ0,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (QZ0,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (UZ0,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (VZ0,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (USTAR,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (HTOP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CFRACM,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SNO,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SI,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CLDEFI,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RF,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CUPPT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CFRACH,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SOILTB,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SFCEXC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SMSTAV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SMSTOT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (GRNFLX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (PCTSNO,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RLWIN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (RADOT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CZMEAN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SIGT4,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (U00,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (LC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SR,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (PREC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACPREC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACCLIQ,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CUPREC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACFRCV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (NCFRCV,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACFRST,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (NCFRST,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACSNOW,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ACSNOM,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SSROFF,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (BGROFF,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SFCSHX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SFCLHX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SUBSHX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SNOPCX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SFCUVX,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SFCEVP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (POTEVP,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ASWIN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ASWOUT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ASWTOA,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ALWIN,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ALWOUT,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ALWTOA,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SMC,NSOIL,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (CMC,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (STC,NSOIL,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (SH2O,NSOIL,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (ALBEDO,1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm!
+!jm      CALL EXCH (PINT,LM+1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (Z,LM+1,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (DWDT,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (TOLD,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (UOLD,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm      CALL EXCH (VOLD,LM,5,5,IMS,IME,JMS,JME,KMS,KME)
+!jm!
+!jm      DO J=MYJS_P4,MYJE_P4
+!jm        IVW(J)=IVWG(J+MY_JS_GLB-1)
+!jm        IVE(J)=IVEG(J+MY_JS_GLB-1)
+!jm        IHE(J)=IHEG(J+MY_JS_GLB-1)
+!jm        IHW(J)=IHWG(J+MY_JS_GLB-1)
+!jm      ENDDO
+!jm!
+!jm!----------------------------------------------------------------------
+!jm      END SUBROUTINE GOSSIP
+!----------------------------------------------------------------------
+      END MODULE MODULE_MPPINIT
+
diff --git a/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F
new file mode 100644
index 00000000..743c015f
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F
@@ -0,0 +1,436 @@
+!
+!NCEP_MESO:MODEL_LAYER: BOUNDARY CONDITION UPDATES
+!
+!----------------------------------------------------------------------
+!
+      MODULE module_NEST_UTIL
+!
+!----------------------------------------------------------------------
+      USE MODULE_MPP
+      USE MODULE_STATE_DESCRIPTION
+      USE MODULE_DM
+!
+!#ifdef DM_PARALLEL
+!      INCLUDE "mpif.h"
+!#endif
+!----------------------------------------------------------------------
+      CONTAINS
+!
+!*********************************************************************************************
+      SUBROUTINE NESTBC_PATCH(PD_B,T_B,Q_B,U_B,V_B,Q2_B,CWM_B                             &
+                             ,PD_BT,T_BT,Q_BT,U_BT,V_BT,Q2_BT,CWM_BT                      & 
+                             ,PDTMP_B,TTMP_B,QTMP_B,UTMP_B,VTMP_B,Q2TMP_B,CWMTMP_B        &
+                             ,PDTMP_BT,TTMP_BT,QTMP_BT,UTMP_BT,VTMP_BT,Q2TMP_BT,CWMTMP_BT &
+                             ,IJDS,IJDE,SPEC_BDY_WIDTH                                    &  ! min/max(id,jd)
+                             ,IDS,IDE,JDS,JDE,KDS,KDE                                     &
+                             ,IMS,IME,JMS,JME,KMS,KME                                     &
+                             ,ITS,ITE,JTS,JTE,KTS,KTE                                     )
+!**********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    PATCH       
+!   PRGRMMR: gopal 
+!     
+! ABSTRACT:
+!         THIS IS JUST A FIX FOR USING NESTED BOUNDARIES IN THE HALLO REGION     
+! PROGRAM HISTORY LOG:
+!   09-23-2004  : gopal 
+!     
+! USAGE: CALL PATCH FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$  
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!
+
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+                           ,IMS,IME,JMS,JME,KMS,KME                    &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+      INTEGER,INTENT(IN) :: IJDS,IJDE,SPEC_BDY_WIDTH
+!
+!
+      REAL,DIMENSION(IJDS:IJDE,1,SPEC_BDY_WIDTH,4)                     &
+                                           ,INTENT(INOUT) :: PD_B,PD_BT
+!
+      REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4)                &
+                                      ,INTENT(INOUT) :: CWM_B,Q_B,Q2_B, &
+                                                        T_B,U_B,V_B 
+      REAL,DIMENSION(IJDS:IJDE,KMS:KME,SPEC_BDY_WIDTH,4)                &
+                                   ,INTENT(INOUT) :: CWM_BT,Q_BT,Q2_BT, &
+                                                     T_BT,U_BT,V_BT 
+
+      REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: PDTMP_B,PDTMP_BT
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),                          &
+                                  INTENT(IN) :: TTMP_B,QTMP_B,UTMP_B,   &
+                                                VTMP_B,Q2TMP_B,CWMTMP_B
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),                           &
+                                  INTENT(IN) :: TTMP_BT,QTMP_BT,UTMP_BT, &
+                                                VTMP_BT,Q2TMP_BT,CWMTMP_BT
+!
+!----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
+      INTEGER :: I,J,K,IBDY,II,JJ,IB,JB,IIM,JJM,BF
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      W_BDY=(ITS==IDS)
+      E_BDY=(ITE==IDE)
+      S_BDY=(JTS==JDS)
+      N_BDY=(JTE==JDE)
+
+!----------------------------------------------------------------------
+!***  WEST AND EAST BOUNDARIES
+!----------------------------------------------------------------------
+!
+!***  USE IBDY=1 FOR WEST; 2 FOR EAST.
+
+!      WRITE(0,*)'WESTERN BC FOR PATCH',IDS,MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+!
+
+      DO IBDY=1,2
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((W_BDY.AND.IBDY.EQ.1).OR.(E_BDY.AND.IBDY.EQ.2))THEN
+          IF(IBDY.EQ.1)THEN
+            BF=P_XSB     ! Which boundary (XSB=the boundary where X is at its start)
+            IB=1         ! Which cell in from boundary
+            II=1         ! Which cell in the domain
+          ELSE
+            BF=P_XEB     ! Which boundary (XEB=the boundary where X is at its end)
+            IB=1         ! Which cell in from boundary
+            II=IDE       ! Which cell in the domain
+          ENDIF
+
+          DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+             IF(MOD(J,2).EQ.1)THEN                 ! J=3,5,7,9
+                PD_B(J,1,IB,BF)  =PDTMP_B(II,J)
+                PD_BT(J,1,IB,BF) =PDTMP_BT(II,J)
+             ENDIF
+          ENDDO
+
+!
+          DO K=KTS,KTE
+            DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)  
+              IF(MOD(J,2).EQ.1)THEN                  ! J=3,5,7,9
+                T_B(J,K,IB,BF)    = TTMP_B(II,K,J)
+                T_BT(J,K,IB,BF)   = TTMP_BT(II,K,J)
+                Q_B(J,K,IB,BF)    = QTMP_B(II,K,J)
+                Q_BT(J,K,IB,BF)   = QTMP_BT(II,K,J)
+                Q2_B(J,K,IB,BF)   = Q2TMP_B(II,K,J)
+                Q2_BT(J,K,IB,BF)  = Q2TMP_BT(II,K,J)
+                CWM_B(J,K,IB,BF)  = CWMTMP_B(II,K,J)
+                CWM_BT(J,K,IB,BF) = CWMTMP_BT(II,K,J)
+              ENDIF
+            ENDDO
+          ENDDO
+
+          DO K=KTS,KTE
+            DO J=MAX(JTS-1,JDS+2-1),MIN(JTE+1,JDE-1)   
+              IF(MOD(J,2).EQ.0)THEN                  ! J=2,4,6,8  
+                U_B(J,K,IB,BF)    = UTMP_B(II,K,J)
+                U_BT(J,K,IB,BF)   = UTMP_BT(II,K,J)
+                V_B(J,K,IB,BF)    = VTMP_B(II,K,J)
+                V_BT(J,K,IB,BF)   = VTMP_BT(II,K,J)
+              ENDIF
+            ENDDO
+          ENDDO
+
+        ENDIF
+      ENDDO
+!
+!----------------------------------------------------------------------
+!***  SOUTH AND NORTH BOUNDARIES
+!----------------------------------------------------------------------
+!
+!***  USE IBDY=1 FOR SOUTH; 2 FOR NORTH
+!
+      DO IBDY=1,2
+!
+!***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
+!
+        IF((S_BDY.AND.IBDY.EQ.1).OR.(N_BDY.AND.IBDY.EQ.2))THEN
+!
+          IF(IBDY.EQ.1)THEN
+            BF=P_YSB     ! Which boundary (YSB=the boundary where Y is at its start)
+            JB=1         ! Which cell in from boundary
+            JJ=1         ! Which cell in the domain
+          ELSE
+            BF=P_YEB      ! Which boundary (YEB=the boundary where Y is at its end)
+            JB=1          ! Which cell in from boundary
+            JJ=JDE        ! Which cell in the domain
+          ENDIF
+!
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_B(I,1,JB,BF) = PDTMP_B(I,JJ)
+            PD_BT(I,1,JB,BF)= PDTMP_BT(I,JJ)
+          ENDDO
+
+!
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_B(I,K,JB,BF)   = TTMP_B(I,K,JJ)
+              T_BT(I,K,JB,BF)  = TTMP_BT(I,K,JJ)
+              Q_B(I,K,JB,BF)   = QTMP_B(I,K,JJ)
+              Q_BT(I,K,JB,BF)  = QTMP_BT(I,K,JJ)
+              Q2_B(I,K,JB,BF)  = Q2TMP_B(I,K,JJ)
+              Q2_BT(I,K,JB,BF) = Q2TMP_BT(I,K,JJ) 
+              CWM_B(I,K,JB,BF) = CWMTMP_B(I,K,JJ)
+              CWM_BT(I,K,JB,BF)= CWMTMP_BT(I,K,JJ)
+            ENDDO
+          ENDDO
+
+          DO K=KTS,KTE
+           DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_B(I,K,JB,BF)   = UTMP_B(I,K,JJ)
+              U_BT(I,K,JB,BF)  = UTMP_BT(I,K,JJ)
+              V_B(I,K,JB,BF)   = VTMP_B(I,K,JJ)
+              V_BT(I,K,JB,BF)  = VTMP_BT(I,K,JJ)
+           ENDDO
+          ENDDO
+
+        ENDIF
+      ENDDO
+END  SUBROUTINE NESTBC_PATCH 
+
+!----------------------------------------------------------------------
+!
+SUBROUTINE STATS_FOR_MOVE (XLOC,YLOC,PDYN,MSLP,SQWS              &
+                          ,PINT,T,Q,U,V                          &
+                          ,FIS,PD,SM,PDTOP,PTOP                  &
+                          ,DETA1,DETA2                           &
+                          ,MOVED,MVNEST,NTSD,NPHS                &
+                          ,IDS,IDE,JDS,JDE,KDS,KDE               &
+                          ,IMS,IME,JMS,JME,KMS,KME               &
+                          ,ITS,ITE,JTS,JTE,KTS,KTE               )
+
+!**********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:  STATS_FOR_MOVE  
+!   PRGRMMR: gopal
+!
+! ABSTRACT:
+!         THIS ROUTINE COMPUTES SOME STATS REQUIRED FOR AUTOMATIC GRID MOTION 
+! PROGRAM HISTORY LOG:
+!   05-18-2005  : gopal
+!
+! USAGE: CALL STATS_FOR_MOVE FROM SUBROUTINE SOLVE_RUNSTREAM FOR NESTED DOMAIN ONLY
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!**********************************************************************
+
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_DM 
+
+      IMPLICIT NONE
+!
+      LOGICAL,EXTERNAL                                      :: wrf_dm_on_monitor
+      LOGICAL,INTENT(INOUT)                                 :: MVNEST  ! NMM SWITCH FOR GRID MOTION
+      LOGICAL,INTENT(IN)                                    :: MOVED   
+      INTEGER,INTENT(IN)                                    :: IDS,IDE,JDS,JDE,KDS,KDE   &
+                                                              ,IMS,IME,JMS,JME,KMS,KME   &
+                                                              ,ITS,ITE,JTS,JTE,KTS,KTE   &
+                                                              ,NTSD,NPHS
+!
+      INTEGER, INTENT(OUT)                                  :: XLOC,YLOC
+      REAL, DIMENSION(KMS:KME),                 INTENT(IN)  :: DETA1,DETA2 
+      REAL,                                     INTENT(IN)  :: PDTOP,PTOP
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(IN)  :: FIS,PD,SM
+      REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN)  :: PINT,T,Q,U,V
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(OUT) :: PDYN,MSLP,SQWS
+!
+!     LOCAL
+
+      INTEGER,SAVE                                          :: NTIME0
+      INTEGER                                               :: IM,JM,IP,JP
+      INTEGER                                               :: I,K,J,XR,YR,DTMOVE,IDUM,JDUM,ITF,JTF
+      REAL, PARAMETER                                       :: LAPSR=6.5E-3, GI=1./G,D608=0.608
+      REAL, PARAMETER                                       :: COEF3=287.05*GI*LAPSR, COEF2=-1./COEF3
+      REAL, PARAMETER                                       :: TRG=2.0*R_D*GI,LAPSI=1.0/LAPSR
+      REAL                                                  :: DZ,RTOPP,APELP,A,TSFC,STMP0,STMP1
+      REAL                                                  :: SMSUM,SMOUT,XDIFF,YDIFF,PCUT,PGR
+      REAL                                                  :: MINGBL_PDYN,MAXGBL_PDYN,MAXGBL_SQWS
+      REAL                                                  :: MINGBL_MIJ
+      REAL, DIMENSION(IMS:IME,JMS:JME)                      :: MIJ
+      REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME)              :: Z
+
+!    EXEC 
+
+     ITF=MIN(ITE,IDE-1)
+     JTF=MIN(JTE,JDE-1)     
+
+!----------------------------------------------------------------------------------
+
+!     KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS
+
+      IF(MOD(NTSD+1,NPHS)/=0)THEN
+        MVNEST=.FALSE.
+        RETURN
+      ENDIF
+
+      WRITE(0,*)'PHYSICS IN SINK',NTSD,NPHS
+
+!     DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
+
+      DO J = JTS, MIN(JTE,JDE)
+       DO I = ITS, MIN(ITE,IDE)
+         Z(I,1,J)=FIS(I,J)*GI
+       ENDDO
+      ENDDO
+!
+      DO J = JTS, MIN(JTE,JDE)
+       DO K = KTS,KTE
+        DO I = ITS, MIN(ITE,IDE)
+          APELP      = (PINT(I,K+1,J)+PINT(I,K,J))
+          RTOPP      = TRG*T(I,K,J)*(1.0+Q(I,K,J)*P608)/APELP
+          DZ         = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) 
+          Z(I,K+1,J) = Z(I,K,J) + DZ
+        ENDDO
+       ENDDO
+      ENDDO
+
+!     DETERMINE THE MEAN SEA LEVEL PRESSURE, THE VERTICALLY AVERAGED WIND
+!     SPEED AT ABOUT LEVELS 9 10 AND 11 AND THE DYNAMIC PRESSURES DEFINED
+!     FROM BASIC BERNOULLI's THEOREM
+
+      DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+            TSFC      = T(I,1,J)*(1.+D608*Q(I,1,J)) + LAPSR*(Z(I,1,J)+Z(I,2,J))*0.5
+            A         = LAPSR*Z(I,1,J)/TSFC
+            MSLP(I,J) = PINT(I,1,J)*(1-A)**COEF2
+            SQWS(I,J) =  (U(I,9,J)*U(I,9,J) + V(I,9,J)*V(I,9,J)           &
+                      +   U(I,10,J)*U(I,10,J) + V(I,10,J)*V(I,10,J)       &
+                      +   U(I,11,J)*U(I,11,J) + V(I,11,J)*V(I,11,J))/3.0
+            PDYN(I,J) =   MSLP(I,J)  + 1.1*SQWS(I,J)/2.0
+        ENDDO
+      ENDDO
+
+!     FILTER OUT PDYN AND STORE THAT IN MIJ. THE MAXIMUM VALUE OF MIJ GIVES THE STORM CENTER
+!     ALSO DO THAT WITHIN A SUB DOMAIN
+
+      MAXGBL_PDYN=MAXVAL(PDYN(ITS:ITF,JTS:JTF))       
+      CALL WRF_DM_MAXVAL(MAXGBL_PDYN,IDUM,JDUM)    
+      MINGBL_PDYN=MINVAL(PDYN(ITS:ITF,JTS:JTF))
+      CALL WRF_DM_MINVAL(MINGBL_PDYN,IDUM,JDUM)            
+      PCUT = 0.5*(MAXGBL_PDYN + MINGBL_PDYN)
+!
+      IM=IDE/2 - IDE/6 
+      IP=IDE/2 + IDE/6
+      JM=JDE/2 - JDE/4
+      JP=JDE/2 + JDE/4
+!
+      DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+          IF(I .GE. IM .AND. I .LE. IP .AND. J .GE. JM .AND. J .LE. JP  &
+                       .AND. PCUT .GT. PDYN(I,J))THEN
+             MIJ(I,J) = PDYN(I,J)   
+          ELSE
+             MIJ(I,J) = 105000. 
+          ENDIF
+        ENDDO
+      ENDDO
+
+      DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+          PDYN(I,J)=MIJ(I,J) 
+        ENDDO
+      ENDDO
+
+!     DETERMINE THE LOCATION OF CENTER OF THE CIRCULATION DEFINED BY MIJ AND FIND THE CORRESPONDING MSLP 
+
+      MINGBL_MIJ=MINVAL(MIJ(ITS:ITF,JTS:JTF))
+      DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+           IF(MIJ(I,J) .EQ. MINGBL_MIJ)THEN
+             XLOC=I
+             YLOC=J
+             STMP0=MSLP(I,J)
+           ENDIF
+        ENDDO
+      ENDDO
+
+      CALL WRF_DM_MINVAL(MINGBL_MIJ,XLOC,YLOC)
+      CALL WRF_DM_MINVAL(STMP0,IDUM,JDUM)
+
+!     DETERMINE THE MAXIMUM MSLP AT ABOUT 18 GRID POINTS AWAY FROM THE STORM CENTER 
+
+      DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+           IF(I .EQ. XLOC+18)THEN
+             XR=I
+             YR=J
+             STMP1=MSLP(I,J)
+           ENDIF
+        ENDDO
+      ENDDO
+
+      CALL WRF_DM_MAXVAL(STMP1,XR,YR)
+
+!
+!     DETERMINE IF THE ENTIRE NESTED DOMAIN IS OVER LAND (SM=0)
+!
+
+      SMSUM = 0.0
+      DO J = JTS, MIN(JTE,JDE)
+       DO I = ITS, MIN(ITE,IDE)
+         SMSUM = SMSUM + SM(I,J)
+       ENDDO
+      ENDDO
+
+      SMOUT=WRF_DM_SUM_REAL(SMSUM)/(IDE*JDE)
+
+!     STOP GRID MOTION. AVOID MOVING TOO RAPID GRID MOTION, SAY SOMETHING LIKE EVERY
+!     OTHER TIME STEP OR SO  
+
+      PGR=STMP1-STMP0
+      XDIFF=ABS(XLOC - IDE/2)
+      YDIFF=ABS(YLOC - JDE/2)
+      IF(NTSD==0 .OR. MOVED)NTIME0=NTSD 
+      DTMOVE=NTSD-NTIME0                    ! TIME INTERVAL SINCE THE PREVIOUS MOVE
+!
+      IF(DTMOVE .LE. 45 .OR. PGR .LE. 200.)THEN       
+        WRITE(0,*)'SUSPEND MOTION: SMALL DTMOVE OR WEAK PGF:','DTMOVE=',DTMOVE,'PGR=',PGR 
+        MVNEST=.FALSE.                               ! SET STATIC GRID
+      ELSE IF(STMP0 .GE. STMP1)THEN
+        WRITE(0,*)'SUSPEND MOTION: THERE IS NO VORTEX IN THE DOMAIN:','STMP0=',STMP0,'STMP1=',STMP1
+        MVNEST=.FALSE.
+      ELSE IF(XDIFF .GT. 24 .OR. YDIFF .GT. 24)THEN
+        WRITE(0,*)'SUSPEND MOTION: LOST VORTEX ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
+        MVNEST=.FALSE.
+      ELSE IF(SMOUT .LE. 0.2 .AND. XDIFF .GT. 12 .AND. YDIFF .GT. 12)THEN  
+        WRITE(0,*)'SUSPEND MOTION: VORTEX LOST OVER LAND ','DTMOVE=',DTMOVE,'XDIFF=',XDIFF,'YDIFF=',YDIFF
+        MVNEST=.FALSE. 
+      ELSE IF(SMOUT .LE. 0.2 .AND. PGR .LE. 400.)THEN
+        WRITE(0,*)'SUSPEND MOTION: VORTEX WEAK OVER LAND ','SMOUT=',SMOUT,'PGR=',PGR
+        MVNEST=.FALSE.
+      ELSE IF(SMOUT .LE. 0.2 .AND. DTMOVE .GE. 1500)THEN
+        WRITE(0,*)'SUSPEND MOTION: STOP MOTION  OVER LAND','SMOUT=',SMOUT,'DTMOVE=',DTMOVE
+        MVNEST=.FALSE.
+      ELSE
+        MVNEST=.TRUE.
+      ENDIF
+
+      RETURN
+
+END SUBROUTINE STATS_FOR_MOVE
+!----------------------------------------------------------------------------------
+
+END  MODULE module_NEST_UTIL
+
diff --git a/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F b/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F
new file mode 100644
index 00000000..316e5112
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F
@@ -0,0 +1,1047 @@
+!----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: NONHYDROSTATIC DYNAMICS ROUTINES
+!
+!----------------------------------------------------------------------
+!
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!
+!----------------------------------------------------------------------
+!
+      MODULE MODULE_NONHY_DYNAM
+!
+!----------------------------------------------------------------------
+      USE MODULE_MODEL_CONSTANTS
+!     USE MODULE_INDX
+!----------------------------------------------------------------------
+!
+      REAL :: CAPA=R_D/CP,RG=1./G,TRG=2.*R_D/G
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE EPS(NTSD,DT,HYDRO,DX,DY,FAD                            &
+                    ,DETA1,DETA2,PDTOP,PT                               &
+                    ,HTM,HBM2,HBM3,LMH                                  &
+                    ,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT                   &
+                    ,DWDT,DWDTMN,DWDTMX                                 &
+                    ,FNS,FEW,FNE,FSE                                    &
+                    ,T,U,V,W,Q,CWM                                      &
+                    ,IHE,IHW,IVE,IVW,INDX3_WRK                          &
+                    ,IDS,IDE,JDS,JDE,KDS,KDE                            &
+                    ,IMS,IME,JMS,JME,KMS,KME                            &
+                    ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    EPS
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 9?-??-??
+!
+! ABSTRACT:
+!     EPS COMPUTES THE VERTICAL AND HORIZONTAL ADVECTION OF DZ/DT
+!
+! PROGRAM HISTORY LOG:
+!   9?-??-??  JANJIC     - ORIGINATOR
+!   00-01-05  BLACK      - DISTRIBUTED MEMORY AND THREADS
+!   02-02-07  BLACK      - CONVERTED TO WRF STRUCTURE
+!   04-11-22  BLACK      - THREADED
+!
+! USAGE: CALL EPS FROM SUBROUTINE SOLVE_RUNSTREAM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST:
+!
+!   OUTPUT FILES:
+!     NONE
+!
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+      INCLUDE "mpif.h"
+#endif
+!
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+                           ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE 
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP,PT
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DWDTMN,DWDTMX,DX    &
+                                                   ,FAD,HBM2,HBM3       &
+                                                   ,PDSL,PDSLO
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: CWM         &
+                                                           ,FEW,FNE     &
+                                                           ,FNS,FSE     &
+                                                           ,HTM,Q       &
+                                                           ,RTOP        &
+                                                           ,U,V
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: DWDT     &
+                                                              ,PDWDT    &
+                                                              ,T
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: PINT,W
+!
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,PARAMETER :: NTSHY=2
+!
+      REAL,PARAMETER :: WGHT=0.35,WP=0.
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      INTEGER :: I,J,J4_00,J4_M1,J4_P1,J5_00,J5_M1,J6_00,J6_P1          &
+                ,JEND,JJ,JKNT,JSTART,K,KOFF,LMP
+!
+      REAL,DIMENSION(KTS:KTE) :: B1,B2,B3,C0,CWM_K,DWDT_K,Q_K,RDPP      &
+                                ,RTOP_K,T_K
+!
+      REAL,DIMENSION(KTS:KTE+1) :: CHI,COFF,PINT_K,PNP1,PONE,PSTR,W_K
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: TTB
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE) :: WEW
+!
+      REAL :: ADDT,DELP,DETAL,DP,DPDE,DPPL,DPSTR,DPTL,DPTU              &
+             ,DWDTT,EPSN,FCT,FFC,GDT,GDT2                               &
+             ,HBM3IJ,HM,PP1,PSTRDN,PSTRUP,RDP,RDPDN,RDPUP,RDT           &
+             ,TFC,TMP,TTAL,TTFC
+!
+      LOGICAL :: BOT,TOP
+!
+!***  TYPE 4 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:1) :: WNS
+!
+!***  TYPE 5 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:0) :: WNE
+!
+!***  TYPE 6 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE, 0:1) :: WSE
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IF(NTSD<=NTSHY.OR.HYDRO)THEN
+!***
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P1,MYIE_P1
+          PINT(I,KTE+1,J)=PT
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=MYJS_P2,MYJE_P2
+          DO K=KTS,KTE
+          DO I=MYIS_P1,MYIE_P1
+            DWDT(I,K,J)=1.
+            PDWDT(I,K,J)=1.
+          ENDDO
+          ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=MYJS_P2,MYJE_P2
+          DO K=KTE,KTS,-1
+          DO I=MYIS_P1,MYIE_P1
+            PINT(I,K,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)+PINT(I,K+1,J)
+          ENDDO
+          ENDDO
+        ENDDO
+!***
+        RETURN
+!***
+      ENDIF
+!-----------------------------------------------------------------------
+      ADDT=DT
+      RDT=1./ADDT
+!-----------------------------------------------------------------------
+!
+!***  TIME TENDENCY
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS_P1,MYJE_P1
+        DO K=KTS,KTE
+        DO I=MYIS_P1,MYIE_P1
+          DWDT(I,K,J)=(W(I,K,J)-DWDT(I,K,J))*HTM(I,K,J)*HBM2(I,J)*RDT
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***
+!***  VERTICAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+      DO J=MYJS2,MYJE2
+      DO I=MYIS,MYIE
+        TTB(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,ttal)
+      DO J=MYJS2,MYJE2
+      DO K=KTE,KTS+1,-1
+      DO I=MYIS,MYIE
+        TTAL=(W(I,K-1,J)-W(I,K,J))*PETDT(I,K-1,J)*0.5
+        DWDT(I,K,J)=(TTAL+TTB(I,J))                                     &
+                   /(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J))                &
+                    +DWDT(I,K,J)
+        TTB(I,J)=TTAL
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        TTB(I,J)=(W(I,KTS,J)-W(I,KTS+1,J))*PETDT(I,KTS,J)*0.5
+        DWDT(I,KTS,J)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J)) &
+                     +DWDT(I,KTS,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  END OF VERTICAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***
+!***  HORIZONTAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J
+!-----------------------------------------------------------------------
+!
+      JSTART=MYJS3
+!
+      DO J=-1,0
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          WNS(I,K,J)=FNS(I,K,JJ)*(W(I,K,JJ+1)-W(I,K,JJ-1))
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+      J=-1
+      JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE1_P2
+        WNE(I,K,J)=FNE(I,K,JJ)*(W(I+IHE(JJ),K,JJ+1)-W(I,K,JJ))
+      ENDDO
+      ENDDO
+!
+      J=0
+      JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE1_P2
+        WSE(I,K,J)=FSE(I,K,JJ)*(W(I+IHE(JJ),K,JJ-1)-W(I,K,JJ))
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      JKNT=0
+      JSTART=MYJS3
+      JEND  =MYJE3
+!
+      main_horizontal:  DO J=JSTART,JEND
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND PFDHT DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P3 denotes +3, M1 denotes -1, etc.)
+!***
+      JKNT=JKNT+1
+!
+      J4_P1=INDX3_WRK(1,JKNT,4)
+      J4_00=INDX3_WRK(0,JKNT,4)
+      J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+      J5_00=INDX3_WRK(0,JKNT,5)
+      J5_M1=INDX3_WRK(-1,JKNT,5)
+!
+      J6_P1=INDX3_WRK(1,JKNT,6)
+      J6_00=INDX3_WRK(0,JKNT,6)
+!
+!-----------------------------------------------------------------------
+!***  THE WORKING ARRAYS FOR THE PRIMARY VARIABLES
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dpde,i,k)
+      DO K=KTS,KTE
+!
+      DO I=MYIS_P3,MYIE_P3
+        WEW(I,K)=FEW(I,K,J)*(W(I+IVE(J),K,J)-W(I+IVW(J),K,J))
+        WNS(I,K,J4_P1)=FNS(I,K,J+1)*(W(I,K,J+2)-W(I,K,J))
+      ENDDO
+!
+!***  DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!
+      DO I=MYIS_P2,MYIE1_P2
+        WNE(I,K,J5_00)=FNE(I,K,J)*(W(I+IHE(J),K,J+1)-W(I,K,J))
+        WSE(I,K,J6_P1)=FSE(I,K,J+1)*(W(I+IHE(J+1),K,J)-W(I,K,J+1))
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      DO I=MYIS2,MYIE2
+        DPDE=DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)
+        DWDT(I,K,J)=-(WEW(I+IHW(J),K)      +WEW(I+IHE(J),K)             &
+                     +WNS(I,K,J4_M1)       +WNS(I,K,J4_P1)              &
+                     +WNE(I+IHW(J),K,J5_M1)+WNE(I,K,J5_00)              &
+                     +WSE(I,K,J6_00)       +WSE(I+IHW(J),K,J6_P1))      &
+                     *FAD(I,J)*HTM(I,K,J)*HBM3(I,J)/(DPDE*DT)           &
+                     +DWDT(I,K,J)
+      ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      ENDDO main_horizontal
+!
+!-----------------------------------------------------------------------
+!***
+!***  END OF HORIZONTAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dwdtt,i,j,k)
+      DO J=MYJS,MYJE
+      DO K=KTS,KTE
+      DO I=MYIS,MYIE
+        DWDTT=DWDT(I,K,J)*HTM(I,K,J)
+        DWDTT=MAX(DWDTT,DWDTMN(I,J))
+        DWDTT=MIN(DWDTT,DWDTMX(I,J))
+!
+        DWDT(I,K,J)=(DWDTT*RG+1.)*(1.-WP)+PDWDT(I,K,J)*WP
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      GDT=G*DT
+      GDT2=GDT*GDT
+      FFC=-R_D/GDT2
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(b1,b2,b3,c0,chi,coff,cwm_k,delp,dppl,dpstr,dptl,dptu,    &
+!$omp&         dwdt_k,fct,hbm3ij,i,j,k,koff,pint_k,pnp1,pone,pp1,pstr,  &
+!$omp&         pstrdn,pstrup,q_k,rdpdn,rdpp,rdpup,rtop_k,t_k,tfc,       &
+!$omp&         tmp,ttfc,w_k)
+      final_update:  DO J=MYJS3,MYJE3
+!
+      PONE(KTE+1)=PT
+      PSTR(KTE+1)=PT
+      PNP1(KTE+1)=PT
+      CHI(KTE+1)=0.
+!
+      DO I=MYIS2,MYIE2
+!
+!-----------------------------------------------------------------------
+!
+!***  EXTRACT COLUMNS FROM 3-D ARRAYS
+!
+        DO K=KTS,KTE
+          CWM_K(K)=CWM(I,K,J)
+          DWDT_K(K)=DWDT(I,K,J)
+          Q_K(K)=Q(I,K,J)
+          RTOP_K(K)=RTOP(I,K,J)
+          T_K(K)=T(I,K,J)
+        ENDDO
+!
+        DO K=KTS,KTE+1
+          PINT_K(K)=PINT(I,K,J)
+          W_K(K)=W(I,K,J)
+        ENDDO
+!-----------------------------------------------------------------------
+!
+        KOFF=KTE-LMH(I,J)
+!
+        DO K=KTE,KOFF+1,-1
+          CHI(K)=0.
+          DPPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          RDPP(K)=1./DPPL
+          PONE(K)=PINT_K(K)
+          DPSTR=DWDT_K(K)*DPPL
+          PSTR(K)=PSTR(K+1)+DPSTR
+          PP1=PNP1(K+1)+DPSTR
+          PNP1(K)=(PP1-PONE(K))*WGHT+PONE(K)
+          TFC=Q_K(K)*P608+(1.-CWM_K(K))
+          TTFC=-CAPA*TFC+1.
+          COFF(K)=T_K(K)*TTFC*TFC*DPPL*FFC                              &
+                   /((PNP1(K+1)+PNP1(K))*(PNP1(K+1)+PNP1(K)))
+        ENDDO
+!-----------------------------------------------------------------------
+!
+        PSTRUP=-(PSTR(KTE+1)+PSTR(KTE)-PONE(KTE+1)-PONE(KTE))*COFF(KTE)
+!
+!-----------------------------------------------------------------------
+        DO K=KTE-1,KOFF+1,-1
+          RDPDN=RDPP(K)
+          RDPUP=RDPP(K+1)
+!
+          PSTRDN=-(PSTR(K+1)+PSTR(K)-PONE(K+1)-PONE(K))*COFF(K)
+!
+          B1(K)=COFF(K+1)+RDPUP
+          B2(K)=(COFF(K+1)+COFF(K))-(RDPUP+RDPDN)
+          B3(K)=COFF(K)+RDPDN
+          C0(K)=PSTRUP+PSTRDN
+!
+          PSTRUP=PSTRDN
+        ENDDO
+!-----------------------------------------------------------------------
+        B1(KTE-1)=0.
+        B2(KOFF+1)=B2(KOFF+1)+B3(KOFF+1)
+!-----------------------------------------------------------------------
+!
+!***  ELIMINATION
+!
+        DO K=KTE-2,KOFF+1,-1
+          TMP=-B1(K)/B2(K+1)
+          B2(K)=B3(K+1)*TMP+B2(K)
+          C0(K)=C0(K+1)*TMP+C0(K)
+        ENDDO
+!
+        CHI(KTE+1)=0.
+!-----------------------------------------------------------------------
+!
+!***  BACK SUBSTITUTION
+!
+        CHI(KOFF+2)=C0(KOFF+1)/B2(KOFF+1)
+        CHI(KOFF+1)=CHI(KOFF+2)
+!
+        DO K=KOFF+3,KTE
+          CHI(K)=(-B3(K-1)*CHI(K-1)+C0(K-1))/B2(K-1)
+        ENDDO
+!-----------------------------------------------------------------------
+        HBM3IJ=HBM3(I,J)
+        DPTU=0.
+        FCT=0.5/CP*HBM3IJ
+!
+        DO K=KTE,KOFF+1,-1
+          DPTL=(CHI(K)+PSTR(K)-PINT_K(K))*HBM3IJ
+          PINT_K(K)=PINT_K(K)+DPTL
+          T_K(K)=(DPTU+DPTL)*RTOP_K(K)*FCT+T_K(K)
+          DELP=(PINT_K(K)-PINT_K(K+1))*RDPP(K)
+          W_K(K)=((DELP-DWDT_K(K))*GDT+W_K(K))*HBM3IJ
+          DWDT_K(K)=(DELP-1.)*HBM3IJ+1.
+!
+          DPTU=DPTL
+        ENDDO
+!-----------------------------------------------------------------------
+        DO K=KOFF+1,KTE
+          PINT(I,K,J)=PINT_K(K)
+          T(I,K,J)=T_K(K)
+          W(I,K,J)=W_K(K)
+          DWDT(I,K,J)=DWDT_K(K)
+        ENDDO
+!-----------------------------------------------------------------------
+!
+      ENDDO
+!
+      ENDDO final_update
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE EPS
+!
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE VADZ(NTSD,DT,FIS,SIGMA,DFL,HTM,HBM2                    &
+                     ,DETA1,DETA2,PDTOP                                 &
+                     ,PINT,PDSL,PDSLO,PETDT                             &
+                     ,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT                       &
+                     ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+                     ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+                     ,IMS,IME,JMS,JME,KMS,KME                           &
+                     ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    VADZ        VERTICAL ADVECTION OF HEIGHT
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 93-11-17
+!     
+! ABSTRACT:
+!     VADV CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
+!     OF HEIGHT IN ORDER TO COMPUTE W=DZ/DT DIAGNOSTICALLY
+!     
+! PROGRAM HISTORY LOG:
+!   96-05-??  JANJIC     - ORIGINATOR
+!   00-01-04  BLACK      - DISTRIBUTED MEMORY AND THREADS
+!   01-03-26  BLACK      - CONVERTED TO WRF STRUCTURE
+!   02-02-19  BLACK      - CONVERSION UPDATED
+!   04-11-22  BLACK      - THREADED
+!     
+! USAGE: CALL VADZ FROM MAIN PROGRAM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST:
+!
+!   OUTPUT FILES:
+!     NONE
+!
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+#ifdef  AS_RECEIVED
+      LOGICAL,INTENT(IN) :: SIGMA
+#else
+      INTEGER,INTENT(IN) :: SIGMA
+#endif
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+                           ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      REAL,INTENT(IN) :: DT,PDTOP
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: DFL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PDSL,PDSLO
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: CWM,HTM     &
+                                                           ,Q,RTOP,T
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: PDWDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: DWDT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: W,Z
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+      INTEGER :: I,J,K
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: FNE,FSE,TTB
+!
+      REAL :: DZ,RDT,TTAL,ZETA
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      RDT=1./DT
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dz,i,j,k,zeta)
+      DO J=MYJS,MYJE
+!
+        DO K=KTS,KTE
+        DO I=MYIS,MYIE
+          PDWDT(I,K,J)=DWDT(I,K,J)
+          DWDT(I,K,J)=W(I,K,J)
+        ENDDO
+        ENDDO
+!
+        DO I=MYIS,MYIE
+          W(I,KTS,J)=0.
+#ifdef AS_RECEIVED
+          IF(SIGMA)THEN
+#else
+          IF(SIGMA==1)THEN
+#endif
+            Z(I,KTS,J)=FIS(I,J)*RG
+          ELSE
+            Z(I,KTS,J)=0.
+          ENDIF
+        ENDDO
+!
+        DO K=KTS,KTE
+!
+          ZETA=DFL(K+1)*RG
+!
+          DO I=MYIS,MYIE
+!
+            DZ=(Q(I,K,J)*P608-CWM(I,K,J)+1.)*T(I,K,J)                   &
+              /(PINT(I,K+1,J)+PINT(I,K,J))                              &
+              *(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))*TRG
+            Z(I,K+1,J)=(Z(I,K,J)+DZ-ZETA)*HTM(I,K,J)+ZETA
+            W(I,K+1,J)=(DZ-RTOP(I,K,J)                                  &
+                      *(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J))*RG)         &
+                      *HTM(I,K,J)*HBM2(I,J)                             &
+                      +W(I,K,J)
+!
+          ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS,MYJE
+!
+        DO K=KTS,KTE
+        DO I=MYIS,MYIE
+          Z(I,K,J)=(Z(I,K+1,J)+Z(I,K,J))*0.5
+          W(I,K,J)=(W(I,K+1,J)+W(I,K,J))*HTM(I,K,J)*HBM2(I,J)*0.5*RDT
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!-----------------------------------------------------------------------
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        TTB(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,ttal)
+      DO J=MYJS2,MYJE2
+        DO K=KTE,KTS+1,-1
+        DO I=MYIS1,MYIE1
+          TTAL=(Z(I,K-1,J)-Z(I,K,J))*PETDT(I,K-1,J)*0.5
+          W(I,K,J)=(TTAL+TTB(I,J))/(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)) &
+                  +W(I,K,J)
+          TTB(I,J)=TTAL
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        W(I,KTS,J)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J))    &
+                  +W(I,KTS,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE VADZ
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE HADZ(NTSD,DT,HYDRO,HTM,HBM2,DETA1,DETA2,PDTOP          &
+                     ,DX,DY,FAD                                         &
+                     ,FEW,FNS,FNE,FSE                                   &
+                     ,PDSL,U,V,W,Z                                      &
+                     ,IHE,IHW,IVE,IVW,INDX3_WRK                         &
+                     ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+                     ,IMS,IME,JMS,JME,KMS,KME                           &
+                     ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    HADZ        HORIZONTAL ADVECTION OF HEIGHT
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 96-05-??       
+!     
+! ABSTRACT:
+!     HADZ CALCULATES DIAGNOSTICALLY THE CONTRIBUTION OF
+!     THE HORIZONTAL ADVECTION OF HEIGHT
+!     
+! PROGRAM HISTORY LOG:
+!   96-05-??  JANJIC     - ORIGINATOR
+!   00-01-04  BLACK      - DISTRIBUTED MEMORY AND THREADS
+!   01-03-26  BLACK      - CONVERTED TO WRF STRUCTURE
+!   04-11-22  BLACK      - THREADED
+!
+! USAGE: CALL HADZ FROM MAIN PROGRAM
+!   INPUT ARGUMENT LIST:
+!
+!   OUTPUT ARGUMENT LIST:
+!     NONE
+!
+!   OUTPUT FILES:
+!
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+      INTEGER,INTENT(IN) :: NTSD
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+                           ,IMS,IME,JMS,JME,KMS,KME                     &
+                           ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!***  NMM_MAX_DIM is set in configure.wrf and must agree with
+!***  the value of dimspec q in the Registry/Registry
+!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!
+      INTEGER,DIMENSION(-3:3,NMM_MAX_DIM,0:6),INTENT(IN) :: INDX3_WRK
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,FAD,HBM2,PDSL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,U,V
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: FEW,FNE    &
+                                                            ,FNS,FSE
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: W
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+      INTEGER,PARAMETER :: NTSHY=2
+!
+      INTEGER :: I,J,J1_00,J1_P1,J1_P2,J4_00,J4_M1,J4_P1,J5_00,J5_M1    &
+                ,J6_00,J6_P1,JJ,JKNT,JSTART,K
+!
+      REAL :: FEWP,FNEP,FNSP,FSEP,UDY,VDX
+!
+      REAL,DIMENSION(IMS:IME,KTS:KTE) :: UDY_00,ZEW
+!
+!***  TYPE 1 WORKING ARRAY (SEE PFDHT)
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-2:2) :: DPDE
+!
+!***  TYPE 4 WORKING ARRAY 
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:1) :: UNED,USED,ZNS
+!
+!***  TYPE 5 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE,-1:0) :: ZNE
+!
+!***  TYPE 6 WORKING ARRAY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,KTS:KTE, 0:1) :: ZSE
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IF(NTSD+1<=NTSHY.OR.HYDRO)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=MYJS,MYJE
+          DO K=KTS,KTE
+          DO I=MYIS,MYIE
+            W(I,K,J)=0.
+          ENDDO
+          ENDDO
+        ENDDO
+!***
+        RETURN
+!***
+      ENDIF
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!***  FIRST ZERO OUT SOME WORKING ARRAYS
+!
+      DO J=-2,2
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        DPDE(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO J=-1,1
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+      DO K=KTS,KTE
+      DO I=ITS-5,ITE+5
+        UNED(I,K,J)=0.
+        USED(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MARCH NORTHWARD THROUGH THE SOUTHERNMOST SLABS TO BEGIN
+!***  FILLING THE MAIN WORKING ARRAYS WHICH ARE MULTI-DIMENSIONED
+!***  IN J BECAUSE THEY ARE DIFFERENCED OR AVERAGED IN J
+!-----------------------------------------------------------------------
+!
+      JSTART=MYJS2_P1
+!
+      DO J=-2,1
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+        DO K=KTS,KTE
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,K,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,JJ)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+      DO J=-1,0
+        JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(fnsp,i,k,udy,vdx)
+        DO K=KTS,KTE
+        DO I=MYIS_P3,MYIE_P3
+          UDY=U(I,K,JJ)*DY
+          VDX=V(I,K,JJ)*DX(I,JJ)
+          UNED(I,K,J)=UDY+VDX
+          USED(I,K,J)=UDY-VDX
+          FNSP=VDX*(DPDE(I,K,J-1)+DPDE(I,K,J+1))
+          ZNS(I,K,J)=FNSP*(Z(I,K,JJ+1)-Z(I,K,JJ-1))
+          FNS(I,K,JJ)=FNSP
+          UDY_00(I,K)=UDY
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+      J=-1
+      JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(fnep,i,k)
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE_P2
+        FNEP=(UNED(I+IHE(JJ),K,J)+UNED(I,K,J+1))                        &
+            *(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J+1))
+        ZNE(I,K,J)=FNEP*(Z(I+IHE(JJ),K,JJ+1)-Z(I,K,JJ))
+      ENDDO
+      ENDDO
+!
+      J=0
+      JJ=JSTART+J
+!
+!$omp parallel do                                                       &
+!$omp& private(fsep,i,k)
+      DO K=KTS,KTE
+      DO I=MYIS_P2,MYIE_P2
+        FSEP=(USED(I+IHE(JJ),K,J)+USED(I,K,J-1))                        &
+            *(DPDE(I,K,J)+DPDE(I+IHE(JJ),K,J-1))
+        ZSE(I,K,J)=FSEP*(Z(I+IHE(JJ),K,JJ-1)-Z(I,K,JJ))
+        FSE(I,K,JJ)=FSEP
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      JKNT=0
+!
+      main_integration:  DO J=MYJS2_P1,MYJE2_P1
+!
+!-----------------------------------------------------------------------
+!***
+!***  SET THE 3RD INDEX IN THE WORKING ARRAYS (SEE SUBROUTINE INIT
+!***                                           AND ABOVE DIAGRAMS)
+!***
+!***  J[TYPE]_NN WHERE "TYPE" IS THE WORKING ARRAY TYPE SEEN IN THE
+!***  LOCAL DECLARATION ABOVE (DEPENDENT UPON THE J EXTENT) AND
+!***  NN IS THE NUMBER OF ROWS NORTH OF THE CENTRAL ROW WHOSE J IS
+!***  THE CURRENT VALUE OF THE main_integration LOOP.
+!***  (P2 denotes +2, etc.)
+!***
+        JKNT=JKNT+1
+!
+        J1_P2=INDX3_WRK(2,JKNT,1)
+        J1_P1=INDX3_WRK(1,JKNT,1)
+        J1_00=INDX3_WRK(0,JKNT,1)
+!
+        J4_P1=INDX3_WRK(1,JKNT,4)
+        J4_00=INDX3_WRK(0,JKNT,4)
+        J4_M1=INDX3_WRK(-1,JKNT,4)
+!
+        J5_00=INDX3_WRK(0,JKNT,5)
+        J5_M1=INDX3_WRK(-1,JKNT,5)
+!
+        J6_P1=INDX3_WRK(1,JKNT,6)
+        J6_00=INDX3_WRK(0,JKNT,6)
+!-----------------------------------------------------------------------
+!
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(fewp,fnep,fnsp,fsep,i,k,udy,vdx)
+        DO K=KTS,KTE
+!
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,K,J1_P2)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J+2)
+        ENDDO
+!
+        DO I=MYIS_P3,MYIE_P3
+          UDY=U(I,K,J+1)*DY
+          VDX=V(I,K,J+1)*DX(I,J+1)
+!
+          FEWP=UDY_00(I,K)                                              &
+             *(DPDE(I+IVW(J),K,J1_00)+DPDE(I+IVE(J),K,J1_00))
+          FNSP=VDX*(DPDE(I,K,J1_00)+DPDE(I,K,J1_P2))
+!
+          FEW(I,K,J)=FEWP
+          FNS(I,K,J+1)=FNSP
+!
+          ZEW(I,K)=FEWP*(Z(I+IVE(J),K,J)-Z(I+IVW(J),K,J))
+          ZNS(I,K,J4_P1)=FNSP*(Z(I,K,J+2)-Z(I,K,J))
+!
+          UNED(I,K,J4_P1)=UDY+VDX
+          USED(I,K,J4_P1)=UDY-VDX
+!
+          UDY_00(I,K)=UDY
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!
+!-----------------------------------------------------------------------
+        DO I=MYIS_P2,MYIE1_P2
+          FNEP=(UNED(I+IHE(J),K,J4_00)+UNED(I,K,J4_P1))                 &
+              *(DPDE(I,K,J1_00)+DPDE(I+IHE(J),K,J1_P1))
+          FNE(I,K,J)=FNEP
+          ZNE(I,K,J5_00)=FNEP*(Z(I+IHE(J),K,J+1)-Z(I,K,J))
+!
+          FSEP=(USED(I+IHE(J+1),K,J4_P1)+USED(I,K,J4_00))               &
+              *(DPDE(I,K,J1_P1)+DPDE(I+IHE(J+1),K,J1_00))
+          FSE(I,K,J+1)=FSEP
+          ZSE(I,K,J6_P1)=FSEP*(Z(I+IHE(J+1),K,J)-Z(I,K,J+1))
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  ADVECTION OF Z
+!
+!-----------------------------------------------------------------------
+        DO I=MYIS1_P1,MYIE1_P1
+          W(I,K,J)=-(ZEW(I+IHW(J),K)+ZEW(I+IHE(J),K)                    &
+                    +ZNS(I,K,J4_M1)+ZNS(I,K,J4_P1)                      &
+                    +ZNE(I+IHW(J),K,J5_M1)+ZNE(I,K,J5_00)               &
+                    +ZSE(I,K,J6_00)+ZSE(I+IHW(J),K,J6_P1))              &
+                    *FAD(I,J)*HTM(I,K,J)*HBM2(I,J)/(DPDE(I,K,J1_00)*DT) &
+                    +W(I,K,J)
+        ENDDO
+!
+        ENDDO   ! End K loop
+!-----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE HADZ
+!
+!-----------------------------------------------------------------------
+      END MODULE MODULE_NONHY_DYNAM
+!-----------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
new file mode 100644
index 00000000..989ae8d2
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
@@ -0,0 +1,2315 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: PHYSICS
+!
+!-----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_PHYSICS_CALLS
+!
+!-----------------------------------------------------------------------
+      USE MODULE_DOMAIN
+      USE MODULE_DM
+      USE MODULE_CONFIGURE
+      USE MODULE_TILES
+      USE MODULE_STATE_DESCRIPTION,ONLY : P_QV,P_QC,P_QR,P_QI,P_QS,P_QG,P_QNI
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_RA_GFDLETA,ONLY : CAL_MON_DAY,ZENITH
+      USE MODULE_RADIATION_DRIVER
+      USE MODULE_SF_MYJSFC
+      USE MODULE_SURFACE_DRIVER
+      USE MODULE_PBL_DRIVER
+      USE MODULE_CU_BMJ
+      USE MODULE_CUMULUS_DRIVER
+      USE MODULE_MP_ETANEW
+      USE MODULE_MICROPHYSICS_DRIVER
+      USE MODULE_MICROPHYSICS_ZERO_OUT
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
+     &                    ,IHRST,NPHS,GLAT,GLON                         &
+     &                    ,NRADS,NRADL                                  &
+     &                    ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT   &
+     &                    ,PD,RES,PINT,T,Q,MOIST,THS,ALBEDO,EPSR        &
+     &                    ,F_ICE,F_RAIN                                 &
+#ifdef WRF_CHEM
+     &                    ,GD_CLOUD,GD_CLOUD2                           &
+#endif
+     &                    ,SM,HBM2,LMH,CLDFRA,N_MOIST,RESTRT            &
+     &                    ,RLWTT,RSWTT,RLWIN,RSWIN,RSWINC,RSWOUT        &
+     &                    ,RLWTOA,RSWTOA,CZMEAN                         &
+     &                    ,CFRACL,CFRACM,CFRACH,SIGT4                   &
+     &                    ,ACFRST,NCFRST,ACFRCV,NCFRCV                  &
+     &                    ,CUPPT,VEGFRC,SNOW,HTOP,HBOT                  &
+     &                    ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM               &
+     &                    ,GRID,CONFIG_FLAGS                            &
+     &                    ,RTHRATEN                                     &
+#ifdef WRF_CHEM
+     &                    ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC         &
+     &                    ,TAUAER1, TAUAER2, TAUAER3, TAUAER4           &
+     &                    ,GAER1, GAER2, GAER3, GAER4                   &
+     &                    ,WAER1, WAER2, WAER3, WAER4                   &
+#endif
+     &                    ,IDS,IDE,JDS,JDE,KDS,KDE                      &
+     &                    ,IMS,IME,JMS,JME,KMS,KME                      &
+     &                    ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***  NOTE ***
+! RLWIN  - downward longwave at the surface (=TOTLWDN, now a local array)
+! RSWIN  - downward shortwave at the surface (=TOTSWDN, now a local array)
+! RSWINC - CLEAR-SKY downward shortwave at the surface (=TOTSWDNC, new for AQ)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    RADIATION   RADIATION OUTER DRIVER
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 2002-06-04       
+!     
+! ABSTRACT:
+!     RADIATION SERVES AS THE INTERFACE BETWEEN THE NCEP NONHYDROSTATIC
+!     MESOSCALE MODEL AND THE WRF RADIATION DRIVER.
+!     
+! PROGRAM HISTORY LOG:
+!   02-06-04  BLACK      - ORIGINATOR
+!   02-09-09  WOLFE      - CONVERTING TO GLOBAL INDEXING
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL RADIATION FROM SOLVE_NMM      
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,IHRST,JULDAY,JULYR                          &
+     &                     ,N_MOIST,NPHS,NRADL,NRADS,NTSD               &
+     &                     ,NUM_AEROSOLC,NUM_OZMIXM
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: NCFRCV,NCFRST
+!
+      REAL,INTENT(IN) :: DT,PDTOP,PT,XTIME,JULIAN
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ALBEDO              &
+     &                                             ,EPSR,GLAT,GLON      &
+     &                                             ,HBM2                &
+     &                                             ,PD,RES,SM           &
+     &                                             ,SNOW,THS,VEGFRC,SICE
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CUPPT            
+
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE       &
+     &                                                     ,F_RAIN      &
+     &                                                     ,Q,T,Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RTHRATEN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,N_MOIST),INTENT(INOUT) :: MOIST
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACFRCV,ACFRST    &
+     &                                                ,RLWIN,RLWTOA     &
+     &                                                ,RSWIN,RSWOUT     &
+     &                                                ,HBOT,HTOP        &
+     &                                                ,RSWINC,RSWTOA
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: PINT     &
+     &                                                        ,RLWTT    &
+     &                                                        ,RSWTT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CFRACH,CFRACL      &
+     &                                              ,CFRACM,CZMEAN      &
+     &                                              ,SIGT4
+#ifdef WRF_CHEM
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME ),INTENT(IN) ::            &
+     &                              GAER1,GAER2,GAER3,GAER4,            &
+     &                              GD_CLOUD,GD_CLOUD2,                 &
+     &                              PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC, &
+     &                              TAUAER1,TAUAER2,TAUAER3,TAUAER4,    &
+     &                              WAER1,WAER2,WAER3,WAER4
+#endif
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CLDFRA
+!
+      LOGICAL,INTENT(IN) :: RESTRT
+!
+      TYPE(DOMAIN),TARGET :: GRID
+!
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+      INTEGER :: I,ICLOUD,IENDX,II,J,JDAY,JMONTH,K,KMNTH,LMHIJ,NRAD
+!
+      INTEGER,DIMENSION(3) :: IDAT
+      INTEGER,DIMENSION(12) :: MONTH=(/31,28,31,30,31,30,31,31          &
+     &                                ,30,31,30,31/)
+!
+      REAL :: CAPA,DAYI,DPL,FICE,FRAIN,GMT,HOUR,PDSL,PLYR,PSFC          &
+     &       ,QI,QR,QW,RADT,TIMES,WC,TDUM
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: REXNSFC,SWNETDN                &
+     &                                  ,TOT,TSFC,XLAND,XLAT,XLON       &
+     &                                  ,TOTLWDN,TOTSWDN,TOTSWDNC,CZEN  &
+     &                                  ,HBOTR,HTOPR,CUPPTR
+!
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W,P_PHY,PI_PHY    &
+     &                                          ,RR,T8W                 &
+     &                                          ,THRATENLW,THRATENSW    &
+     &                                          ,TH_PHY,T_PHY,CLFR
+!
+!
+!***  Different way to include cloud effects in radiation.
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: QC1R,QI1R
+!
+      LOGICAL :: WARM_RAIN
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!*****
+!***** NOTE: THIS IS HARDWIRED FOR CALLS TO LONGWAVE AND SHORTWAVE
+!*****       AT EQUAL INTERVALS
+!*****
+      NRAD=NRADS
+      RADT=DT*NRADS/60.
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      CAPA=R_D/CP
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dpl,fice,frain,i,j,k,pdsl,plyr,ql,tl)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL=PD(I,J)*RES(I,J)
+        P8W(I,KTE+1,J)=PT
+        XLAT(I,J)=GLAT(I,J)/DEGRAD
+        XLON(I,J)=GLON(I,J)/DEGRAD
+        XLAND(I,J)=SM(I,J)+1.
+        PSFC=PD(I,J)+PDTOP+PT
+        REXNSFC(I,J)=(PSFC*1.E-5)**CAPA
+        TSFC(I,J)=THS(I,J)*REXNSFC(I,J)
+        T8W(I,1,J)=TSFC(I,J)
+        P8W(I,KTS,J)=ETA1(KTS)*PDTOP+ETA2(KTS)*PDSL+PT
+!
+!-----------------------------------------------------------------------
+!***  FILL THE SINGLE-COLUMN INPUT
+!-----------------------------------------------------------------------
+!
+        DO K=KTS,KTE
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL
+          QL(K)=AMAX1(Q(I,K,J),EPSQ)
+          PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL+PT
+          TL(K)=T(I,K,J)
+!
+          RR(I,K,J)=PLYR/(R_D*TL(K)*(1.+P608*QL(K)))
+          T_PHY(I,K,J)=TL(K)
+          TH_PHY(I,K,J)=TL(K)*(1.E5/PLYR)**CAPA
+          P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL+PT
+          P_PHY(I,K,J)=PLYR
+          PI_PHY(I,K,J)=(PLYR*1.E-5)**CAPA
+          DZ(I,K,J)=TL(K)*(P608*QL(K)+1.)*R_D                           &
+     &                 *(P8W(I,K,J)-P8W(I,K+1,J))                       &
+     &                 /(P_PHY(I,K,J)*G)
+!!!  &                 *ALOG(P8W(I,KFLIP,J)/P8W(I,KFLIP+1,J))/G         &
+!!!  &                 *ALOG(PINT(I,K+1,J)/PINT(I,K,J))/G               &
+!
+          RTHRATEN(I,K,J)=0.
+          THRATENLW(I,K,J)=0.
+          THRATENSW(I,K,J)=0.
+!         PM2_5_DRY(I,K,J)=0.
+!         PM2_5_WATER(I,K,J)=0.
+
+        ENDDO
+!
+        DO K=KTS+1,KTE
+          T8W(I,K,J)=0.5*(TL(K-1)+TL(K))
+        ENDDO
+        T8W(I,KTE+1,J)=-1.E20
+!
+      ENDDO
+      ENDDO
+!
+      ICLOUD=999
+!
+      GMT=REAL(IHRST)
+!
+!-----------------------------------------------------------------------
+!
+!***  CALL THE INNER DRIVER.
+!
+!-----------------------------------------------------------------------
+!
+      DO J=JMS,JME
+      DO K=KMS,KME
+      DO I=IMS,IME
+        QC1R(I,K,J)=0.
+        QI1R(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+          DO I=MYIS1,MYIE1
+            QC1R(I,K,J)=MOIST(I,K,J,P_QC)
+            QI1R(I,K,J)=MOIST(I,K,J,P_QI)
+          ENDDO
+        ENDDO
+      ENDDO
+      DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          CLDFRA(I,K,J)=0.
+        ENDDO
+        ENDDO
+!
+        DO I=IMS,IME
+          CFRACH(I,J)=0.
+          CFRACL(I,J)=0.
+          CFRACM(I,J)=0.
+          CZMEAN(I,J)=0.
+          SIGT4(I,J)=0.
+          TOTSWDN(I,J)=0.   ! TOTAL (clear+cloudy sky) shortwave down at the surface
+          TOTSWDNC(I,J)=0.  ! CLEAR SKY shortwave down at the surface
+          SWNETDN(I,J)=0.   ! Net (down - up) total (clear+cloudy sky) shortwave at the surface
+          TOTLWDN(I,J)=0.   ! Total longwave down at the surface
+          CUPPTR(I,J)=CUPPT(I,J)   ! Temporary array set to zero in radiation
+!-- NOTE:  HBOTR, HTOPR are passed into radiation and set equal to HBOT, HTOP.  HBOT, HTOP are
+!          reset to clear sky values to be used by the ARW.  At the bottom of this subroutine, 
+!          HBOT, HTOP are re-defined again to values stored in HBOTR, HTOPR.  HBOT, HTOP are 
+!          reset to clear sky values after the call to radiation and after the top of the hour
+!          in subroutine CUCNVC below.
+        ENDDO
+      ENDDO
+!
+      CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
+!
+      CALL RADIATION_DRIVER(                                            &
+     &                  IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
+     &                 ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
+     &                 ,I_START=GRID%I_START,I_END=GRID%I_END           &
+     &                 ,J_START=GRID%J_START,J_END=GRID%J_END           &
+     &                 ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
+     &                 ,ITIMESTEP=NTSD,DT=DT                            &
+#ifdef WRF_CHEM
+     &                 ,cu_rad_feedback=config_flags%cu_rad_feedback    &
+     &                 ,aer_ra_feedback=config_flags%aer_ra_feedback    &
+     &        ,PM2_5_DRY=pm2_5_dry, PM2_5_WATER=pm2_5_water               &
+     &        ,PM2_5_DRY_EC=pm2_5_dry_ec                                  &
+     &        ,TAUAER300=tauaer1, TAUAER400=tauaer2, TAUAER600=tauaer3, TAUAER999=tauaer4 & ! jcb
+     &        ,GAER300=gaer1, GAER400=gaer2, GAER600=gaer3, GAER999=gaer4 & ! jcb
+     &        ,WAER300=waer1, WAER400=waer2, WAER600=waer3, WAER999=waer4 & ! jcb
+     &        ,qc_adjust=GD_CLOUD,qi_adjust=GD_CLOUD2                   &
+#endif
+     &                 ,RTHRATENLW=THRATENLW,RTHRATENSW=THRATENSW       &
+     &                 ,RTHRATEN=RTHRATEN                               &
+     &                 ,GLW=TOTLWDN,GSW=SWNETDN,SWDOWN=TOTSWDN          &
+     &                 ,XLAT=XLAT,XLONG=XLON,ALBEDO=ALBEDO,EMISS=EPSR   &
+     &                 ,XICE=SICE,XLAND=XLAND,Z=Z,TSK=TSFC              &
+     &                 ,N_AEROSOLC=NUM_AEROSOLC,PAERLEV=GRID%PAERLEV    &
+     &                 ,CAM_ABS_DIM1=GRID%CAM_ABS_DIM1                  &
+     &                 ,CAM_ABS_DIM2=GRID%CAM_ABS_DIM2                  &
+     &                 ,CAM_ABS_FREQ_S=GRID%CAM_ABS_FREQ_S              &
+     &                 ,LEVSIZ=GRID%LEVSIZ,N_OZMIXM=NUM_OZMIXM          &
+     &                 ,HTOP=HTOP,HBOT=HBOT,CUPPT=CUPPTR                &
+     &                 ,HTOPR=HTOPR,HBOTR=HBOTR                         &
+     &                 ,VEGFRA=VEGFRC,SNOW=SNOW                         &
+     &                 ,RHO=RR,P8W=P8W,P=P_PHY,PI=PI_PHY                &
+     &                 ,DZ8W=DZ,T=T_PHY,T8W=T8W,GMT=GMT                 &
+     &                 ,JULDAY=JULDAY,JULYR=JULYR,NPHS=NPHS             &
+     &                 ,JULIAN=JULIAN,XTIME=XTIME                       &
+     &                 ,LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS           &
+     &                 ,SW_PHYSICS=CONFIG_FLAGS%RA_SW_PHYSICS           &
+     &                 ,RADT=RADT,RA_CALL_OFFSET=GRID%RA_CALL_OFFSET    &
+     &                 ,STEPRA=NRAD,ICLOUD=ICLOUD                       &
+     &                 ,WARM_RAIN=WARM_RAIN                             & 
+     &                 ,SWDOWNC=TOTSWDNC,CLDFRA=CLFR                    &
+     &                 ,RSWTOA=RSWTOA,RLWTOA=RLWTOA                     &
+     &                 ,CZMEAN=CZMEAN,CFRACL=CFRACL                     &
+     &                 ,CFRACM=CFRACM,CFRACH=CFRACH                     &
+     &                 ,ACFRST=ACFRST,NCFRST=NCFRST                     &
+     &                 ,ACFRCV=ACFRCV,NCFRCV=NCFRCV                     &
+     &                 ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN               &
+     &                 ,QV=MOIST(IMS,KMS,JMS,P_QV),F_QV=F_QV            &
+     &                 ,QC=MOIST(IMS,KMS,JMS,P_QC),F_QC=F_QC                               &
+     &                 ,QR=MOIST(IMS,KMS,JMS,P_QR),F_QR=F_QR            &
+     &                 ,QI=MOIST(IMS,KMS,JMS,P_QI),F_QI=F_QI                               &
+     &                 ,QS=MOIST(IMS,KMS,JMS,P_QS),F_QS=F_QS            &
+     &                 ,QG=MOIST(IMS,KMS,JMS,P_QG),F_QG=F_QG          )
+
+!
+!-----------------------------------------------------------------------
+!
+!***  UPDATE FLUXES AND TEMPERATURE TENDENCIES.
+!
+!-----------------------------------------------------------------------
+!***  SHORTWAVE
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+      IF(MOD(NTSD,NRADS)==0)THEN
+!-----------------------------------------------------------------------
+!
+        IF(CONFIG_FLAGS%RA_SW_PHYSICS/=GFDLSWSCHEME)THEN
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE CZMEAN FOR NON-GFDL SHORTWAVE
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS,MYJE
+          DO I=MYIS,MYIE
+            CZMEAN(I,J)=0.
+            TOT(I,J)=0.
+          ENDDO
+          ENDDO
+!
+          CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
+          IDAT(1)=JMONTH
+          IDAT(2)=JDAY
+          IDAT(3)=JULYR
+!
+          DO II=0,NRADS,NPHS
+            TIMES=NTSD*DT+II*DT
+            CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN       &
+     &                 ,MYIS &
+     &                 ,MYIE &
+     &                 ,MYJS &
+     &                 ,MYJE &
+     &                 ,IDS,IDE,JDS,JDE,KDS,KDE                         &
+     &                 ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                 ,ITS,ITE,JTS,JTE,KTS,KTE)
+            DO J=MYJS,MYJE
+            DO I=MYIS,MYIE
+              IF(CZEN(I,J)>0.)THEN
+                CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
+                TOT(I,J)=TOT(I,J)+1.
+              ENDIF
+            ENDDO
+            ENDDO
+!
+          ENDDO
+!
+          DO J=MYJS,MYJE
+          DO I=MYIS,MYIE
+            IF(TOT(I,J)>0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE TOTAL SFC SHORTWAVE DOWN FOR NON-GFDL SCHEMES
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+          DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+!
+            IF(HBM2(I,J)>0.5)THEN
+              TOTSWDN(I,J)=SWNETDN(I,J)/(1.-ALBEDO(I,J))  
+!--- No value currently available for clear-sky solar fluxes from
+!    non GFDL schemes, though it's needed for air quality forecasts.
+!    For the time being, set to the total downward solar fluxes.
+              TOTSWDNC(I,J)=TOTSWDN(I,J)
+            ENDIF
+!
+          ENDDO
+          ENDDO
+!
+        ENDIF   !End non-GFDL block
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,k)
+        DO J=MYJS2,MYJE2
+          IENDX=MYIE1
+          IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
+          DO I=MYIS1,IENDX
+!
+            RSWIN(I,J)=TOTSWDN(I,J)
+            RSWINC(I,J)=TOTSWDNC(I,J)
+            RSWOUT(I,J)=TOTSWDN(I,J)-SWNETDN(I,J)
+!
+            DO K=KTS,KTE
+              RSWTT(I,K,J)=THRATENSW(I,K,J)*PI_PHY(I,K,J)
+            ENDDO
+!
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  LONGWAVE
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,NRADL)==0)THEN
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,k,lmhij)
+        DO J=MYJS2,MYJE2
+          IENDX=MYIE1
+          IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
+          DO I=MYIS1,IENDX
+!
+            IF(HBM2(I,J)>0.5)THEN
+              LMHIJ=KTE+1-LMH(I,J)
+              TDUM=T(I,LMHIJ,J)
+              SIGT4(I,J)=STBOLT*TDUM*TDUM*TDUM*TDUM
+!
+              DO K=KTS,KTE
+                RLWTT(I,K,J)=THRATENLW(I,K,J)*PI_PHY(I,K,J)
+              ENDDO
+!
+              RLWIN(I,J)=TOTLWDN(I,J)
+            ENDIF
+!
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-- Store 3D cloud fractions & restore HBOT/HTOP arrays
+!
+      DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
+        DO K=KTS,KTE
+          DO I=MYIS1,IENDX
+            CLDFRA(I,K,J)=CLFR(I,K,J)
+          ENDDO
+        ENDDO
+        DO I=MYIS1,IENDX
+          HBOT(I,J)=HBOTR(I,J)
+          HTOP(I,J)=HTOPR(I,J)
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***  ZERO OUT BOUNDARY ROWS.
+!-----------------------------------------------------------------------
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        IF(HBM2(I,J)<0.5)THEN
+          ACFRST(I,J)=0.
+          ACFRCV(I,J)=0.
+          CFRACL(I,J)=0.
+          CFRACM(I,J)=0.
+          CFRACH(I,J)=0.
+          RSWTOA(I,J)=0.
+          RLWTOA(I,J)=0.
+        ENDIF
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+
+      END SUBROUTINE RADIATION
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
+     &                ,N_MOIST,NSOIL,SLDPTH,DZSOIL                      &
+     &                ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT       &
+     &                ,SM,LMH,HTM,VTM,HBM2,VBM2,DX_ARRAY,DFRLG          &
+     &                ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT              &
+!- RLWIN/RSWIN - downward longwave/shortwave at the surface (also TOTLWDN/TOTSWDN in RADIATION)
+     &                ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR              &
+     &                ,Q2,U,V,THS,TSFC,SST,PREC,SNO,ZERO_3D             &
+     &                ,FIS,Z0,Z0BASE,USTAR,PBLH,LPBL,EL_MYJ             &
+     &                ,MOIST,RMOL                                       &
+     &                ,EXCH_H,AKHS,AKMS,AKHS_OUT,AKMS_OUT               &
+     &                ,THZ0,QZ0,UZ0,VZ0,QS,MAVAIL                       &
+     &                ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF          &
+     &                ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX        &
+     &                ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB       &
+     &                ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR                &
+     &                ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR            &
+     &                ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG  &
+     &                ,TWBS,QWBS,SFCSHX,SFCLHX,SFCEVP                   &
+     &                ,POTEVP,POTFLX,SUBSHX                             &
+     &                ,APHTIM,ARDSW,ARDLW,ASRFC                         &
+     &                ,RSWOUT,RSWTOA,RLWTOA                             &
+     &                ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA          &
+     &                ,UZ0H,VZ0H,DUDT,DVDT                              & 
+     &                ,RTHBLTEN,RQVBLTEN                                & 
+     &                ,PCPFLG,DDATA                                     & ! PRECIP ASSIM
+     &                ,GRID,CONFIG_FLAGS                                &
+     &                ,IHE,IHW,IVE,IVW                                  &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    TURBL       TURBULENCE OUTER DRIVER
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 02-04-19       
+!     
+! ABSTRACT:
+!     TURBL DRIVES THE TURBULENCE SCHEMES
+!     
+! PROGRAM HISTORY LOG (with changes to called routines) :
+!   95-03-15  JANJIC     - ORIGINATOR OF THE SUBROUTINES CALLED
+!   BLACK & JANJIC       - ORIGINATORS OF THE DRIVER
+!   95-03-28  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   96-03-29  BLACK      - ADDED EXTERNAL EDGE; REMOVED SCRCH COMMON
+!   96-07-19  MESINGER   - ADDED Z0 EFFECTIVE
+!   98-??-??  TUCCILLO   - MODIFIED FOR CLASS VIII PARALLELISM
+!   98-10-27  BLACK      - PARALLEL CHANGES INTO MOST RECENT CODE
+!   02-01-10  JANJIC     - MOIST TURBULENCE (DRIVER, MIXLEN, VDIFH)
+!   02-01-10  JANJIC     - VERT. DIF OF Q2 INCREASED (Grenier & Bretherton)
+!   02-02-02  JANJIC     - NEW SFCDIF
+!   02-04-19  BLACK      - ORIGINATOR OF THIS OUTER DRIVER FOR WRF
+!   02-05-03  JANJIC     - REMOVAL OF SUPERSATURATION AT 2m AND 10m
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL TURBL FROM SOLVE_NMM
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,N_MOIST,NPHS,NSOIL,NTSD
+!
+      INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: ISLTYP,IVGTYP    &
+     &                                                ,LMH
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL
+!
+      REAL,INTENT(IN) :: DT,PDTOP,PT
+!
+      REAL,INTENT(INOUT) :: APHTIM,ARDSW,ARDLW,ASRFC
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: DFRLG,ETA1,ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ALBASE,MXSNAL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZEN,CZMEAN         &
+     &                                             ,DX_ARRAY            &
+     &                                             ,FIS,HBM2            &
+     &                                             ,PD,RES              &
+     &                                             ,RLWIN,RLWTOA        &
+     &                                             ,RSWIN,RSWOUT,RSWTOA &
+     &                                             ,SHDMIN,SHDMAX       &
+!    &                                             ,SICE,SIGT4,SM,SR    & !Bandaid
+     &                                             ,SICE,SIGT4          &
+     &                                             ,SST,TG,VBM2,VEGFRC
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SM,EPSR,SR         !Bandaid
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT  &
+                                                    ,SFCEXC,SMSTAV      &
+                                                    ,SOILTB,TWBS
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACSNOM,ACSNOW    &
+     &                                                ,AKHS,AKMS        &
+     &                                                ,ALBEDO           &
+     &                                                ,MAVAIL           &
+     &                                                ,BGROFF,CMC       &
+     &                                                ,PBLH,POTEVP      &
+     &                                                ,POTFLX,PREC      &
+     &                                                ,QCG,QS,QSG       &
+     &                                                ,QVG,QZ0          &
+     &                                                ,SFCEVP           &
+     &                                                ,SFCLHX,SFCSHX    &
+     &                                                ,SI,SMSTOT        &
+     &                                                ,SNO,SNOPCX       &
+     &                                                ,SOILT1           &
+     &                                                ,SSROFF,SUBSHX    &
+     &                                                ,T2,THS,THZ0      &
+     &                                                ,TSFC,TSNAV       &
+     &                                                ,USTAR,UZ0,UZ0H   &
+     &                                                ,VZ0,VZ0H         &
+     &                                                ,Z0,Z0BASE
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: AKHS_OUT,AKMS_OUT  &
+     &                                              ,ALWIN,ALWOUT       &
+     &                                              ,ALWTOA,ASWIN       &
+     &                                              ,ASWOUT,ASWTOA      &
+     &                                              ,PSHLTR,Q10,QSHLTR  &
+     &                                              ,TH10,TSHLTR        &
+     &                                              ,U10,V10
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM      &
+     &                                                        ,DUDT     &
+     &                                                        ,DVDT     &
+     &                                                        ,EXCH_H   &
+     &                                                        ,F_ICE    &
+     &                                                        ,F_RAIN   &
+     &                                                        ,Q,Q2     &
+     &                                                        ,T,U,V
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RQVBLTEN,RTHBLTEn
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,N_MOIST),INTENT(INOUT) :: MOIST
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: HTM,VTM
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: ZERO_3D
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: EL_MYJ
+!
+      REAL,DIMENSION(NSOIL),INTENT(IN) :: DZSOIL,SLDPTH
+!
+      REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME),INTENT(INOUT) :: KEEPFR3DFLAG &
+     &                                                      ,SH2O,SMC     &
+     &                                                      ,SMFR3D,STC
+!
+      LOGICAL,INTENT(IN) :: RESTRT
+!
+      TYPE(DOMAIN),TARGET :: GRID
+!
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+!
+!  For precip assimilation:
+      LOGICAL,INTENT(IN) :: PCPFLG
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DDATA
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+      INTEGER :: I,I_M,IDUMMY,IEND,ISFFLX,ISTR,J,K,KOUNT_ALL,LENGTH_ROW &
+     &          ,LLIJ,LLMH,LLYR,N,SST_UPDATE
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LOWLYR
+!
+      REAL :: TRESH=0.95
+!
+      REAL :: ALTITUDE,CWML,DQDT,DTDT,DTPHS,DX,DZHALF,FACTR,FACTRL      &
+     &       ,G_INV,PDSL,PLYR,PSFC,QI,QL,QOLD,QR,QW,RATIOMX,RDTPHS      &
+     &       ,ROG,RWMSK,SDEPTH,SNO_FACTR,TL,TLMH,TLMH4,TNEW,TSFC2       &
+     &       ,U_FRAME,V_FRAME,WMSK,XLVRW
+!
+      REAL :: APES,CKLQ,FACTOR,FFS,PQ0X,Q2SAT,QFC1,QLOWX,RLIVWV         &
+     &       ,THBOT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: BR,CHKLOWQ,CT,CWMLOW,ELFLX     &
+     &                                  ,EXNSFC,FACTRS,FLHC,FLQC,GZ1OZ0 &
+     &                                  ,ONE,PLM,PSFC_OUT,PSIH,PSIM     &
+     &                                  ,Q2X,QLOW,RAIN,RAINBL           &
+     &                                  ,RLW_DN_SFC,RMOL,RSW_NET_SFC    &
+     &                                  ,RSW_DN_SFC                     &
+     &                                  ,SFCEVPX,SFCZ,SNOW,SNOWC,SNOWH  &
+     &                                  ,TH2X,THLOW,TLOW,VGFRCK         &
+     &                                  ,WSPD,XLAND,ZERO_2D,EMISS
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME-1,JMS:JME) :: EXNER
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W                 &
+     &                                          ,P_PHY,PI_PHY           &
+     &                                          ,RQCBLTEN,RQIBLTEN      &
+     &                                          ,RR   &
+!    &                                          ,RQVBLTEN,RR,RTHBLTEN   &
+     &                                          ,T_PHY,TH_PHY,TKE       &
+     &                                          ,U_PHY,V_PHY,Z
+!
+      REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: ZERO_SOIL
+!
+      LOGICAL :: E_BDY,WARM_RAIN
+!
+      INTEGER :: ucmcall
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+     ucmcall=config_flags%ucmcall
+!
+      DTPHS=NPHS*DT
+      RDTPHS=1./DTPHS
+      G_INV=1./G
+      ROG=R_D*G_INV
+      FACTOR=-XLV*RHOWATER/DTPHS
+!
+      U_FRAME=0.
+      V_FRAME=0.
+!
+      IDUMMY=0
+      ISFFLX=1
+      DX=0.
+      SST_UPDATE=0
+!
+      DO J=JMS,JME
+      DO I=IMS,IME
+        UZ0H(I,J)=0.
+        VZ0H(I,J)=0.
+        ONE(I,J)=1.
+        RMOL(I,J)=0.  !Reciprocal of Monin-Obukhov length
+        SFCEVPX(I,J)=0.  !Dummy for accumulated latent energy, not flux
+      ENDDO
+      ENDDO
+!
+      IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
+        SNO_FACTR=1.
+      ELSE
+        SNO_FACTR=0.001
+      ENDIF
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        LOWLYR(I,J)=1
+        VGFRCK(I,J)=100.*VEGFRC(I,J)
+        SNOW(I,J)=SNO(I,J)
+        SNOWH(I,J)=SI(I,J)*SNO_FACTR
+        XLAND(I,J)=SM(I,J)+1.
+        T2(I,J)=TSFC(I,J)
+        EMISS(I,J)=EPSR(I,J)
+      ENDDO
+      ENDDO
+!
+      IF(NTSD==0)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          Z0BASE(I,J)=Z0(I,J)
+          IF(SM(I,J)>0.5.AND.SICE(I,J)>0.5)THEN  !Bandaid
+            SM(I,J)=0.        
+          ENDIF              
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=MYJS,MYJE
+      DO K=KTS,KTE+1
+      DO I=MYIS,MYIE
+        Z(I,K,J)=0.
+        DZ(I,K,J)=0.
+        EXCH_H(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  PREPARE NEEDED ARRAYS
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(cwml,factrl,i,j,k,llij,llmh,pdsl,plyr,psfc,qi,ql,qr,qw   &
+!$omp&        ,tl,tlmh,tlmh4)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+!
+        LLMH=LMH(I,J)
+        PDSL=PD(I,J)*RES(I,J)
+!!!     PSFC=PD(I,J)+PDTOP+PT
+!!!     P8W(I,KTS,J)=PSFC
+        P8W(I,KTS,J)=PINT(I,KTS,J)
+        PSFC=PINT(I,KTS,J)
+        LOWLYR(I,J)=KTE+1-LLMH
+        EXNSFC(I,J)=(1.E5/PSFC)**CAPA
+        THS(I,J)=(SST(I,J)*EXNSFC(I,J))*SM(I,J)+THS(I,J)*(1.-SM(I,J))
+        TSFC(I,J)=THS(I,J)/EXNSFC(I,J)
+        SFCZ(I,J)=FIS(I,J)*G_INV
+        ZERO_2D(I,J)=0.
+!YL     RAIN(I,J)=PREC(I,J)*RHOWATER
+        IF (PCPFLG.AND.DDATA(I,J)<100.)THEN
+          RAIN(I,J)=DDATA(I,J)*RHOWATER
+        ELSE
+          RAIN(I,J)=PREC(I,J)*RHOWATER
+        ENDIF
+!YL
+        RAINBL(I,J)=0.
+        IF(SNO(I,J)>0.)SNOWC(I,J)=1.
+        LLIJ=LOWLYR(I,J)
+        PLM(I,J)=(PINT(I,LLIJ,J)+PINT(I,LLIJ+1,J))*0.5
+        TH2X(I,J)=T(I,LLIJ,J)*(1.E5/PLM(I,J))**CAPA
+        Q2X(I,J)=Q(I,LLIJ,J)
+!
+!-----------------------------------------------------------------------
+!*** LONG AND SHORTWAVE FLUX AT GROUND SURFACE
+!-----------------------------------------------------------------------
+!
+        IF(CZMEAN(I,J)>0.)THEN
+          FACTRS(I,J)=CZEN(I,J)/CZMEAN(I,J)
+        ELSE
+          FACTRS(I,J)=0.
+        ENDIF
+!
+        IF(SIGT4(I,J)>0.)THEN
+          TLMH=T(I,LLIJ,J)
+          FACTRL=STBOLT*TLMH*TLMH*TLMH*TLMH/SIGT4(I,J)
+        ELSE
+          FACTRL=0.
+        ENDIF
+!     
+!- RLWIN/RSWIN - downward longwave/shortwave at the surface
+!
+        RLW_DN_SFC(I,J)=RLWIN(I,J)*HBM2(I,J)*FACTRL
+        RSW_NET_SFC(I,J)=(RSWIN(I,J)-RSWOUT(I,J))*HBM2(I,J)*FACTRS(I,J)
+!
+!- Instant downward solar for nmm_lsm
+!
+        RSW_DN_SFC(I,J)=RSWIN(I,J)*HBM2(I,J)*FACTRS(I,J)
+!
+!-----------------------------------------------------------------------
+!***  FILL THE ARRAYS FOR CALLING THE INNER DRIVER.
+!-----------------------------------------------------------------------
+!
+        Z(I,KTS,J)=SFCZ(I,J)
+!
+        DO K=KTS,KTE
+          Q2(I,K,J)=AMAX1(Q2(I,K,J)*HBM2(I,J),EPSQ2)
+          QL=AMAX1(Q(I,K,J),EPSQ)
+          PLYR=(PINT(I,K,J)+PINT(I,K+1,J))*0.5
+!!!       PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL+PT
+          TL=T(I,K,J)
+          CWML=CWM(I,K,J)
+!
+          RR(I,K,J)=PLYR/(R_D*TL)
+          T_PHY(I,K,J)=TL
+!
+          EXNER(I,K,J)=(1.E5/PLYR)**CAPA
+          PI_PHY(I,K,J)=1./EXNER(I,K,J)
+          TH_PHY(I,K,J)=TL*EXNER(I,K,J)
+          P8W(I,K+1,J)=PINT(I,K+1,J)
+!!!       P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL+PT
+          P_PHY(I,K,J)=PLYR
+          TKE(I,K,J)=0.5*Q2(I,K,J)
+!
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          RQCBLTEN(I,K,J)=0.
+          RQIBLTEN(I,K,J)=0.
+!
+          Z(I,K+1,J)=Z(I,K,J)+TL/PLYR                                   &
+     &                  *(DETA1(K)*PDTOP+DETA2(K)*PDSL)*ROG             &
+                        *(Q(I,K,J)*P608-CWML+1.)
+          Z(I,K+1,J)=(Z(I,K+1,J)-DFRLG(K+1))*HTM(I,K,J)+DFRLG(K+1)
+!!!       FACTR=1.-HTM(I,K,J)
+!!!       Z(I,K+1,J)=Z(I,K+1,J)*HTM(I,K,J)+FACTR*DFRLG(K+1)
+          DZ(I,K,J)=Z(I,K+1,J)-Z(I,K,J)
+        ENDDO
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,llyr,qlowx)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        TWBS(I,J)=0.
+        QWBS(I,J)=0.
+        LLYR=LOWLYR(I,J)
+        THLOW(I,J)=TH_PHY(I,LLYR,J)
+        TLOW(I,J)=T_PHY(I,LLYR,J)
+        QLOW(I,J)=MAX(Q(I,LLYR,J),EPSQ)
+        QLOWX=QLOW(I,J)/(1.-QLOW(I,J))
+        QLOW(I,J)=QLOWX/(1.+QLOWX)
+        CWMLOW(I,J)=CWM(I,LLYR,J)
+        PBLH(I,J)=MAX(PBLH(I,J),0.)
+        PBLH(I,J)=MIN(PBLH(I,J),Z(I,KTE,J))
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE VELOCITY COMPONENTS AT MASS POINTS
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,rwmsk,wmsk)
+      DO J=MYJS1_P1,MYJE1_P1
+!
+        DO K=KTS,KTE
+          DO I=MYIS_P1,MYIE_P1
+            WMSK=VTM(I+IHE(J),K,J)+VTM(I+IHW(J),K,J)                    &
+     &          +VTM(I,K,J+1)+VTM(I,K,J-1)
+            IF(WMSK>0.)THEN
+              RWMSK=1./WMSK
+              U_PHY(I,K,J)=(U(I+IHE(J),K,J)*VTM(I+IHE(J),K,J)           &
+     &                         +U(I+IHW(J),K,J)*VTM(I+IHW(J),K,J)       &
+     &                         +U(I,K,J+1)*VTM(I,K,J+1)                 &
+     &                         +U(I,K,J-1)*VTM(I,K,J-1))*RWMSK
+              V_PHY(I,K,J)=(V(I+IHE(J),K,J)*VTM(I+IHE(J),K,J)           &
+     &                         +V(I+IHW(J),K,J)*VTM(I+IHW(J),K,J)       &
+     &                         +V(I,K,J+1)*VTM(I,K,J+1)                 &
+     &                         +V(I,K,J-1)*VTM(I,K,J-1))*RWMSK
+            ELSE
+              U_PHY(I,K,J)=0.
+              V_PHY(I,K,J)=0.
+            ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iend,istr,j)
+      DO J=MYJS1_P1,MYJE1_P1
+        IF(MOD(J,2)==0)THEN
+          ISTR=MYIS_P1
+          IEND=MIN(MYIE_P1,IDE-1)
+        ELSE
+          ISTR=MAX(MYIS_P1,IDS+1)
+          IEND=MIN(MYIE_P1,IDE-1)
+        ENDIF
+!     
+        DO I=ISTR,IEND
+          UZ0H(I,J)=(UZ0(I+IHE(J),J)+UZ0(I+IHW(J),J)                    &
+     &              +UZ0(I,J+1)+UZ0(I,J-1))*0.25
+!!!  &              +UZ0(I,J+1)+UZ0(I,J-1))*HBM2(I,J)*0.25
+          VZ0H(I,J)=(VZ0(I+IHE(J),J)+VZ0(I+IHW(J),J)                    &
+     &              +VZ0(I,J+1)+VZ0(I,J-1))*0.25
+!!!  &              +VZ0(I,J+1)+VZ0(I,J-1))*HBM2(I,J)*0.25
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!***  CALL SURFACE LAYER AND LAND SURFACE PHYSICS
+!
+!-----------------------------------------------------------------------
+!
+      CALL SET_TILES(GRID,IDS,IDE-1,JDS+1,JDE-1,ITS,ITE,JTS,JTE)
+!
+      DO J=JTS,JTE  !jm was JTS
+      DO I=ITS,ITE
+        IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
+          ONE(I,J)=1.
+        ELSE
+!tgs  -  MAVAIL should not be equal to 1. for other LSMs
+          ONE(I,J)=MAVAIL(I,J)
+        ENDIF 
+      ENDDO
+      ENDDO
+!
+      CALL SURFACE_DRIVER(                                              &
+     &           ACSNOM=ACSNOM,ACSNOW=ACSNOW,AKHS=AKHS,AKMS=AKMS        &
+     &          ,ALBEDO=ALBEDO,BR=BR,CANWAT=CMC,CHKLOWQ=CHKLOWQ         &
+     &          ,DT=DT,DX=DX,DZ8W=DZ,DZS=DZSOIL,GLW=RLW_DN_SFC          &
+     &          ,GRDFLX=GRNFLX,GSW=RSW_NET_SFC,SWDOWN=RSW_DN_SFC        &
+     &          ,GZ1OZ0=GZ1OZ0,HFX=TWBS                                 &
+     &          ,HT=SFCZ,IFSNOW=IDUMMY,ISFFLX=ISFFLX,ISLTYP=ISLTYP      &
+     &          ,ITIMESTEP=NTSD,IVGTYP=IVGTYP,LOWLYR=LOWLYR             &
+     &          ,MAVAIL=ONE,RMOL=RMOL,NUM_SOIL_LAYERS=NSOIL,P8W=P8W &
+     &          ,PBLH=PBLH,PI_PHY=PI_PHY,PSHLTR=PSHLTR,PSIH=PSIH        &
+     &          ,PSIM=PSIM,P_PHY=P_PHY,Q10=Q10,Q2=Q2X,QFX=QWBS,QSFC=QS  &
+     &          ,QSHLTR=QSHLTR,QZ0=QZ0,RAINCV=RAIN                      &
+     &          ,RHO=RR,SFCEVP=SFCEVPX,SFCEXC=SFCEXC,SFCRUNOFF=SSROFF   &
+     &          ,SMOIS=SMC,SMSTAV=SMSTAV,SMSTOT=SMSTOT,SNOALB=MXSNAL    &
+     &          ,SNOW=SNOW,SNOWC=SNOWC,SNOWH=SNOWH,STEPBL=NPHS          &
+     &          ,SST=SST,SST_UPDATE=SST_UPDATE                          &
+     &          ,TH10=TH10,TH2=TH2X,T2=T2,THZ0=THZ0,TH_PHY=TH_PHY       &
+     &          ,TMN=TG,TSHLTR=TSHLTR,TSK=TSFC,TSLB=STC,T_PHY=T_PHY     &
+     &          ,U10=U10,UDRUNOFF=BGROFF,UST=USTAR,UZ0=UZ0H             &
+     &          ,U_FRAME=U_FRAME,U_PHY=U_PHY,V10=V10,VEGFRA=VGFRCK      &
+     &          ,VZ0=VZ0H,V_FRAME=V_FRAME,V_PHY=V_PHY                   &
+     &          ,WARM_RAIN=WARM_RAIN,WSPD=WSPD,XICE=SICE                &
+     &          ,XLAND=XLAND,Z=Z,ZNT=Z0,ZS=SLDPTH,CT=CT,TKE_MYJ=TKE     &
+     &          ,ALBBCK=ALBASE,LH=ELFLX,SH2O=SH2O,SHDMAX=SHDMAX         &
+     &          ,SHDMIN=SHDMIN,Z0=Z0BASE,FLQC=FLQC,FLHC=FLHC            &
+     &          ,PSFC=PSFC_OUT,EMISS=EPSR                               &
+     &          ,SF_SFCLAY_PHYSICS=CONFIG_FLAGS%SF_SFCLAY_PHYSICS       &
+     &          ,SF_SURFACE_PHYSICS=CONFIG_FLAGS%SF_SURFACE_PHYSICS     &
+     &          ,RA_LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS               &
+     &          ,UCMCALL=ucmcall                                        &
+     &          ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE        &
+     &          ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME        &
+     &          ,I_START=GRID%I_START,I_END=GRID%I_END                  &
+     &          ,J_START=GRID%J_START,J_END=GRID%J_END                  &
+     &          ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES               &
+           ! Optional args
+     &          ,QV_CURR=MOIST(IMS,KMS,JMS,P_QV),F_QV=F_QV              &
+     &          ,QC_CURR=MOIST(IMS,KMS,JMS,P_QC),F_QC=F_QC              &
+     &          ,QR_CURR=MOIST(IMS,KMS,JMS,P_QR),F_QR=F_QR              &
+     &          ,QI_CURR=MOIST(IMS,KMS,JMS,P_QI),F_QI=F_QI              &
+     &          ,QS_CURR=MOIST(IMS,KMS,JMS,P_QS),F_QS=F_QS              & 
+     &          ,QG_CURR=MOIST(IMS,KMS,JMS,P_QG),F_QG=F_QG              &
+     &          ,RAINBL=RAINBL                                          &
+! for RUCLSM
+     &          ,QSG=QSG, QVG=QVG, QCG=QCG, SOILT1=SOILT1               &
+     &          ,TSNAV=TSNAV, SMFR3D=SMFR3D, KEEPFR3DFLAG=KEEPFR3DFLAG  &
+     &          ,POTEVP=POTEVP,SNOPCX=SNOPCX,SOILTB=SOILTB,SR=SR)
+!
+!-----------------------------------------------------------------------
+!
+!***  CALL FREE ATMOSPHERE TURBULENCE
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=JMS,JME
+      DO K=KMS,KME
+      DO I=IMS,IME
+        DUDT(I,K,J)=0.
+        DVDT(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!***  THE SURFACE EXCHANGE COEFFICIENTS AKHS AND AKMS ARE ACTUALLY
+!***  MULTIPLIED BY HALF THE DEPTH OF THE LOWEST LAYER.  WE MUST RETAIN
+!***  THOSE VALUES FOR THE NEXT TIMESTEP SO USE AUXILLIARY ARRAYS FOR
+!***  THE OUTPUT.
+!
+!$omp parallel do                                                       &
+!$omp& private(dzhalf,i,j)
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        DZHALF=0.5*DZ(I,KTS,J)
+        AKHS_OUT(I,J)=AKHS(I,J)*DZHALF
+        AKMS_OUT(I,J)=AKMS(I,J)*DZHALF
+      ENDDO
+      ENDDO
+!
+      CALL PBL_DRIVER(                                                &
+     &                ITIMESTEP=NTSD,DT=DT                            &
+     &               ,U_FRAME=U_FRAME,V_FRAME=V_FRAME                 &
+     &               ,RUBLTEN=DUDT,RVBLTEN=DVDT,RTHBLTEN=RTHBLTEN     &
+     &               ,RQVBLTEN=RQVBLTEN,RQCBLTEN=RQCBLTEN             &
+     &               ,RQIBLTEN=RQIBLTEN                               &
+     &               ,TSK=TSFC,XLAND=XLAND,ZNT=Z0,HT=SFCZ             &
+     &               ,UST=USTAR, PBLH=PBLH                            &
+     &               ,HFX=TWBS,QFX=QWBS,  GRDFLX=GRNFLX               &
+     &               ,U_PHY=U_PHY,V_PHY=V_PHY,TH_PHY=TH_PHY,RHO=RR    &
+     &               ,P_PHY=P_PHY,PI_PHY=PI_PHY,P8W=P8W,T_PHY=T_PHY   &
+     &               ,DZ8W=DZ,Z=Z,TKE_MYJ=TKE,EL_MYJ=EL_MYJ           &
+     &               ,EXCH_H=EXCH_H,AKHS=AKHS,AKMS=AKMS               &
+     &               ,THZ0=THZ0,QZ0=QZ0,UZ0=UZ0H,VZ0=VZ0H             &
+     &               ,QSFC=QS,LOWLYR=LOWLYR                           &
+     &               ,PSIM=PSIM,PSIH=PSIH,GZ1OZ0=GZ1OZ0               &
+     &               ,WSPD=WSPD,BR=BR,CHKLOWQ=CHKLOWQ                 &
+     &               ,DX=DX,STEPBL=NPHS,WARM_RAIN=WARM_RAIN           &
+     &               ,KPBL=KPBL,CT=CT,LH=ELFLX,SNOW=SNOW,XICE=SICE    &
+     &               ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics      &
+     &               ,RA_LW_PHYSICS=config_flags%ra_lw_physics        &
+     &               ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
+     &               ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
+     &               ,I_START=GRID%I_START,I_END=GRID%I_END           &
+     &               ,J_START=GRID%J_START,J_END=GRID%J_END           &
+     &               ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
+                ! Optional args
+     &               ,QV_CURR=moist(IMS,KMS,JMS,P_QV) , F_QV=F_QV     &
+     &               ,QC_CURR=moist(IMS,KMS,JMS,P_QC) , F_QC=F_QC     &
+     &               ,QR_CURR=moist(IMS,KMS,JMS,P_QR) , F_QR=F_QR     &
+     &               ,QI_CURR=moist(IMS,KMS,JMS,P_QI) , F_QI=F_QI     &
+     &               ,QS_CURR=moist(IMS,KMS,JMS,P_QS) , F_QS=F_QS     &
+     &               ,QG_CURR=moist(IMS,KMS,JMS,P_QG) , F_QG=F_QG   )
+!
+!***  NOTE THAT THE EXCHANGE COEFFICIENTS FOR HEAT EXCH_H COMING OUT OF
+!***  PBL_DRIVER ARE DEFINED AT THE TOPS OF THE LAYERS KTS TO KTE-1
+!***  IF MODULE_BL_MYJPBL WAS INVOKED.
+!
+!-----------------------------------------------------------------------
+! UNCOMPUTED LOCATIONS MUST BE FILLED IN FOR THE POST-PROCESSOR
+!-----------------------------------------------------------------------
+!
+!***  EASTERN GLOBAL BOUNDARY
+!
+      IF(MYIE==IDE)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+        DO J=JDS,JDE
+        IF (J>=MYJS.AND.J<=MYJE)THEN
+          TH10(MYIE,J)=TH10(MYIE-1,J)
+          Q10(MYIE,J)=Q10(MYIE-1,J)
+          U10(MYIE,J)=U10(MYIE-1,J)
+          V10(MYIE,J)=V10(MYIE-1,J)
+          TSHLTR(MYIE,J)=TSHLTR(MYIE-1,J)
+          QSHLTR(MYIE,J)=QSHLTR(MYIE-1,J)
+        ENDIF
+        ENDDO
+      ENDIF
+!
+!***  SOUTHERN GLOBAL BOUNDARY
+!
+
+      IF(MYJS==1)THEN
+        DO J=1,2
+        DO I=IDS,IDE
+          IF (I>=MYIS.AND.I<=MYIE) THEN
+            TH10(I,J)=TH10(I,MYJS+2)
+            Q10(I,J)=Q10(I,MYJS+2)
+            U10(I,J)=U10(I,MYJS+2)
+            V10(I,J)=V10(I,MYJS+2)
+            TSHLTR(I,J)=TSHLTR(I,MYJS+2)
+            QSHLTR(I,J)=QSHLTR(I,MYJS+2)
+          ENDIF
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!***  NORTHERN GLOBAL BOUNDARY
+!
+      IF(MYJE==JDE)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+        DO J=MYJE-1,MYJE
+        DO I=IDS,IDE
+          IF (I>=MYIS.AND.I<=MYIE) THEN
+            TH10(I,J)=TH10(I,MYJE-2)
+            Q10(I,J)=Q10(I,MYJE-2)
+            U10(I,J)=U10(I,MYJE-2)
+            V10(I,J)=V10(I,MYJE-2)
+            TSHLTR(I,J)=TSHLTR(I,MYJE-2)
+            QSHLTR(I,J)=QSHLTR(I,MYJE-2)
+          ENDIF
+        ENDDO
+        ENDDO
+      ENDIF
+!
+      IF(CONFIG_FLAGS%SF_SFCLAY_PHYSICS==1)THEN ! non-NMM package
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+        DO J=MYJS1,MYJE1
+        DO I=MYIS,MYIE1
+!         TSHLTR(I,J)=TSHLTR(I,J)*(1.E5/PSHLTR(I,J))**RCP
+          IF(TSHLTR(I,J)<200..OR.TSHLTR(I,J)>350.)THEN
+            WRITE(0,*)'Troublesome TSHLTR...I,J,TSHLTR,PSHLTR: ',       &
+               I,J,TSHLTR(I,J),PSHLTR(I,J)
+          ENDIF
+	ENDDO
+	ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE MODEL LAYER CONTAINING THE TOP OF THE BOUNDARY LAYER
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%BL_PBL_PHYSICS/=MYJPBLSCHEME)THEN
+        LENGTH_ROW=MYIE1-MYIS1+1
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          KPBL(I,J)=-1000
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(altitude,i,j,k,kount_all)
+        DO J=MYJS2,MYJE2
+          KOUNT_ALL=0
+          find_kpbl : DO K=KTS,KTE
+          DO I=MYIS1,MYIE1
+            ALTITUDE=Z(I,K+1,J)-SFCZ(I,J)
+            IF(PBLH(I,J)<=ALTITUDE.AND.KPBL(I,J)<0)THEN
+              KPBL(I,J)=K
+              KOUNT_ALL=KOUNT_ALL+1
+            ENDIF
+            IF(KOUNT_ALL==LENGTH_ROW)EXIT find_kpbl
+          ENDDO
+          ENDDO find_kpbl
+        ENDDO
+      ENDIF
+!
+      IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
+        SNO_FACTR=1.
+      ELSE
+        SNO_FACTR=1000.
+      ENDIF
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        SNO(I,J)=SNOW(I,J)
+        SI(I,J)=SNOWH(I,J)*SNO_FACTR
+        LPBL(I,J)=KTE-KPBL(I,J)+1
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  DIAGNOSTIC RADIATION ACCUMULATION
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,tsfc2)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS,MYIE
+        ASWIN (I,J)=ASWIN (I,J)+RSWIN(I,J)*HBM2(I,J)*FACTRS(I,J)
+        ASWOUT(I,J)=ASWOUT(I,J)-RSWOUT(I,J)*HBM2(I,J)*FACTRS(I,J)
+        ASWTOA(I,J)=ASWTOA(I,J)+RSWTOA(I,J)*HBM2(I,J)*FACTRS(I,J)
+        ALWIN (I,J)=ALWIN (I,J)+RLW_DN_SFC(I,J)
+        ALWOUT(I,J)=ALWOUT(I,J)-RADOT (I,J)*HBM2(I,J)
+        ALWTOA(I,J)=ALWTOA(I,J)+RLWTOA(I,J)*HBM2(I,J)
+!
+        TSFC2=TSFC(I,J)*TSFC(I,J)
+        RADOT(I,J)=HBM2(I,J)*EPSR(I,J)*STBOLT*TSFC2*TSFC2
+        THS(I,J)=TSFC(I,J)*EXNSFC(I,J)
+        PREC(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD, AND TKE.
+!-----------------------------------------------------------------------
+!
+      E_BDY=(ITE>=IDE)
+!
+!$omp parallel do                                                       &
+!$omp& private(dqdt,dtdt,i,iend,j,k,qi,qold,qr,qw,ratiomx,i_m)
+      DO J=MYJS2,MYJE2
+        IEND=MYIE1
+        IF(E_BDY.AND.MOD(J,2)==0)IEND=IEND-1
+!
+        DO K=KTS,KTE
+        DO I=MYIS1,IEND
+          DTDT=RTHBLTEN(I,K,J)*PI_PHY(I,K,J)
+          DQDT=RQVBLTEN(I,K,J)         !Mixing ratio tendency
+          T(I,K,J)=T(I,K,J)+DTDT*DTPHS
+          QOLD=Q(I,K,J)
+          RATIOMX=QOLD/(1.-QOLD)+DQDT*DTPHS
+          Q(I,K,J)=RATIOMX/(1.+RATIOMX)
+!         Q(I,K,J)=MAX(Q(I,K,J),EPSQ)
+          QW=max(0.,MOIST(I,K,J,P_QC)+RQCBLTEN(I,K,J)*DTPHS )
+          IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+            QI=max(0.,MOIST(I,K,J,P_QS)+RQIBLTEN(I,K,J)*DTPHS )
+          ELSE
+            QI=max(0.,MOIST(I,K,J,P_QI)+RQIBLTEN(I,K,J)*DTPHS )
+          ENDIF
+          QR=max(0.,MOIST(I,K,J,P_QR) )
+!          CWM(I,K,J)=QW+QI+QR
+          CWM(I,K,J)=0. 
+!
+          DO I_M=1,N_MOIST
+             IF(I_M/=P_QV)THEN
+               CWM(I,K,J)=CWM(I,K,J)+MOIST(I,K,J,I_M)
+             ENDIF
+             IF(I_M==P_QV)THEN
+               MOIST(I,K,J,P_QV)=MAX(EPSQ,(MOIST(I,K,J,P_QV) + RQVBLTEN(I,K,J)*DTPHS) )
+             ELSEIF (I_M==P_QC)THEN
+                CWM(I,K,J)=MAX(0., (CWM(I,K,J) + RQCBLTEN(I,K,J)*DTPHS) )
+             ELSEIF(I_M==P_QI)THEN
+                CWM(I,K,J)=MAX(0., (CWM(I,K,J) + RQIBLTEN(I,K,J)*DTPHS) )
+             ENDIF
+          ENDDO
+!
+          MOIST(I,K,J,P_QC)=QW
+          MOIST(I,K,J,P_QR)=QR
+!
+          IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+          MOIST(I,K,J,P_QS)=QI
+            IF(QI<=EPSQ)THEN  
+              F_ICE(I,K,J)=0.
+            ELSE
+              F_ICE(I,K,J)=MAX(0.,MIN(1.,QI/CWM(I,K,J)))
+            ENDIF
+!
+            IF(QR<=EPSQ)THEN
+              F_RAIN(I,K,J)=0.
+            ELSE
+              F_RAIN(I,K,J)=QR/(QW+QR)
+            ENDIF
+          ELSE
+          MOIST(I,K,J,P_QI)=QI
+          ENDIF
+!
+          Q2(I,K,J)=2.*TKE(I,K,J)
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***
+!***  SAVE SURFACE-RELATED FIELDS.
+!***
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,llij,xlvrw)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        LLIJ=LOWLYR(I,J)
+!
+!-----------------------------------------------------------------------
+!***  INSTANTANEOUS SENSIBLE AND LATENT HEAT FLUX
+!-----------------------------------------------------------------------
+!
+        TWBS(I,J)=-TWBS(I,J)
+        QWBS(I,J)=-QWBS(I,J)*XLV*CHKLOWQ(I,J)
+!
+!-----------------------------------------------------------------------
+!***  ACCUMULATED QUANTITIES.
+!***  IN OPNL LSM, SFCEVP APPEARS TO BE IN UNITS OF
+!***  METERS OF LIQUID WATER.  IT IS COMING FROM
+!***  WRF MODULE AS KG/M**2.
+!-----------------------------------------------------------------------
+!
+        SFCSHX(I,J)=SFCSHX(I,J)+TWBS(I,J)
+        SFCLHX(I,J)=SFCLHX(I,J)+QWBS(I,J)
+        XLVRW=DTPHS/(XLV*RHOWATER)
+        SFCEVP(I,J)=SFCEVP(I,J)-QWBS(I,J)*XLVRW
+        POTEVP(I,J)=POTEVP(I,J)-QWBS(I,J)*SM(I,J)*XLVRW
+        POTFLX(I,J)=POTEVP(I,J)*FACTOR
+        SUBSHX(I,J)=SUBSHX(I,J)+GRNFLX(I,J)
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COUNTERS
+!-----------------------------------------------------------------------
+!
+      APHTIM=APHTIM+1.
+      ARDSW =ARDSW +1.
+      ARDLW =ARDLW +1.
+      ASRFC =ASRFC +1.
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE TURBL
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE UV_H_TO_V(NTSD,DT,NPHS,UZ0H,VZ0H,UZ0,VZ0               &
+     &                    ,DUDT,DVDT,U,V,HBM2,VTM,IVE,IVW               & 
+     &                    ,IDS,IDE,JDS,JDE,KDS,KDE                      &
+     &                    ,IMS,IME,JMS,JME,KMS,KME                      &
+     &                    ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    UV_H_TO_V   INTERPOLATE WINDS FROM H TO V POINTS
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 05-02-22       
+!     
+! ABSTRACT:
+!     INTERPOLATE WINDS BACK TO V POINTS AFTER TURBULENCE
+!     
+! PROGRAM HISTORY LOG :
+!   05-02-22  BLACK      - ORIGINATOR
+!     
+! USAGE: CALL TURBL FROM SOLVE_NMM
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,NPHS,NTSD
+!
+      INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IVE,IVW
+!
+      REAL,INTENT(IN) :: DT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HBM2,UZ0H,VZ0H
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DUDT,DVDT   &
+     &                                                     ,VTM
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: UZ0,VZ0
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: U,V
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,IEND,J,K
+!
+      REAL :: DTPHS
+!
+      LOGICAL :: E_BDY
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      DTPHS=NPHS*DT
+      E_BDY=(ITE>=IDE)
+!
+!-----------------------------------------------------------------------
+!***  RECONSTRUCT UZ0 AND VZ0 ON VELOCITY POINTS.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS,MYIE
+        UZ0(I,J)=(UZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J)                     &
+     &           +UZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J)                     &
+     &           +UZ0H(I,J+1)*HBM2(I,J+1)+UZ0H(I,J-1)*HBM2(I,J-1))*0.25
+        VZ0(I,J)=(VZ0H(I+IVE(J),J)*HBM2(I+IVE(J),J)                     &
+     &           +VZ0H(I+IVW(J),J)*HBM2(I+IVW(J),J)                     &
+     &           +VZ0H(I,J+1)*HBM2(I,J+1)+VZ0H(I,J-1)*HBM2(I,J-1))*0.25
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  INTERPOLATE WIND TENDENCIES TO VELOCITY POINTS AND UPDATE WINDS.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iend,j,k)
+      DO J=MYJS2,MYJE2
+        IEND=MYIE1
+        IF(E_BDY.AND.MOD(J,2)==1)IEND=IEND-1
+!
+        DO K=KTS,KTE
+        DO I=MYIS1,IEND
+          U(I,K,J)=(DUDT(I+IVE(J),K,J)+DUDT(I+IVW(J),K,J)               &
+     &             +DUDT(I,K,J+1)+DUDT(I,K,J-1))*0.25*DTPHS             &
+     &             *VTM(I,K,J)+U(I,K,J)
+          V(I,K,J)=(DVDT(I+IVE(J),K,J)+DVDT(I+IVW(J),K,J)               &
+     &             +DVDT(I,K,J+1)+DVDT(I,K,J-1))*0.25*DTPHS             &
+     &             *VTM(I,K,J)+V(I,K,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE UV_H_TO_V
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
+     &                 ,GPS,RESTRT,HYDRO                                &
+     &                 ,CLDEFI,LMH,N_MOIST,ENSDIM                       &
+     &                 ,MOIST                                           &
+     &                 ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2               &
+     &                 ,F_ICE,F_RAIN                                    &
+!***  Changes for other cu-schemes, most for gd scheme
+     &                 ,APR_GR,APR_W,APR_MC,TTEN,QTEN                   &
+     &                 ,APR_ST,APR_AS,APR_CAPMA                         &
+     &                 ,APR_CAPME          ,APR_CAPMI                   &
+     &                 ,MASS_FLUX         ,XF_ENS                       &
+     &                 ,PR_ENS,GSW                                      &
+#ifdef WRF_CHEM
+     &                 ,GD_CLOUD,GD_CLOUD2,RAINCV                       &
+#endif
+!
+     &                 ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN              &
+     &                 ,OMGALF,U,V,VTM,WINT,Z,FIS,W0AVG                 &
+     &                 ,PREC,ACPREC,CUPREC,CUPPT,CPRATE                 &
+     &                 ,SM,HBM2,LPBL,CNVBOT,CNVTOP                      &
+     &                 ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS               &
+     &                 ,RTHBLTEN,RQVBLTEN,RTHRATEN                      & 
+     &                 ,AVCNVC,ACUTIM,ZERO_3D,IHE,IHW                   &
+     &                 ,GRID,CONFIG_FLAGS                               &
+     &                 ,IDS,IDE,JDS,JDE,KDS,KDE                         &
+     &                 ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                 ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    CUCNVC      CONVECTIVE PRECIPITATION OUTER DRIVER
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 02-03-21       
+!     
+! ABSTRACT:
+!     CUCVNC DRIVES THE WRF CONVECTION SCHEMES
+!     
+! PROGRAM HISTORY LOG:
+!   02-03-21  BLACK      - ORIGINATOR
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL CUCNVC FROM SOLVE_NMM
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: ENSDIM                                      &
+     &                     ,IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,N_MOIST,NCNVC,NTSD,NRADS,NRADL
+!
+      INTEGER, DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH,LPBL
+!
+      REAL,INTENT(IN) :: DT,GPS,PDTOP,PT
+!
+      REAL,INTENT(INOUT) :: ACUTIM,AVCNVC
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+      REAL,DIMENSION(KMS:KME  ),INTENT(IN) :: ETA1,ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,CLDEFI    &
+     &                                                ,CNVBOT,CNVTOP    &
+     &                                                ,CUPPT,CUPREC     &
+     &                                                ,HBOT,HTOP        &
+     &                                                ,HBOTD,HTOPD      &
+     &                                                ,HBOTS,HTOPS      &
+     &                 ,APR_GR,APR_W,APR_MC                             &
+     &                 ,APR_ST,APR_AS,APR_CAPMA                         &
+     &                 ,APR_CAPME          ,APR_CAPMI                   &
+     &                 ,MASS_FLUX                                       &
+     &                 ,GSW  ,PREC,CPRATE
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE       &
+     &                                                     ,F_RAIN
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: TTEN     &
+     &                                                     ,QTEN        &
+     &                                       ,RTHBLTEN,RQVBLTEN,RTHRATEN
+
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: Q,T      &
+     &                                                        ,CWM      &
+     &                                                        ,TCUCN    &
+     &                                                        ,W0AVG    &
+     &                                                        ,WINT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: OMGALF      &
+     &                                                     ,PINT,U,V    &
+     &                                                     ,VTM,Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: ZERO_3D
+      REAL,DIMENSION(IMS:IME,jMS:jME,1:ENSDIM),INTENT(INOUT) ::          &
+     &                         XF_ENS                                    &
+     &                        ,PR_ENS
+      
+!    
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,N_MOIST)                   &
+     &                                           ,INTENT(INOUT) :: moist
+#ifdef WRF_CHEM
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: GD_CLOUD &
+     &                                                        ,GD_CLOUD2
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: RAINCV
+#endif
+!
+      LOGICAL,INTENT(IN) :: HYDRO,RESTRT
+!
+      TYPE(DOMAIN),TARGET :: GRID
+!
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+      INTEGER :: I,ICLDCK,IENDX,J,K,MNTO,NCUBOT,NCUTOP,NSTEP_CNV        &
+     &          ,N_TIMSTPS_OUTPUT
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LBOT,LOWLYR,LTOP
+!
+      REAL :: CAPA,CF_HI,DPL,DQDT,DTCNVC,DTDT,FICE,FRAIN,G_INV          &
+     &       ,PCPCOL,PDSL,PLYR,QI,QL_K,QR,QW,RDTCNVC,RWMSK,WMSK,WC
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,NCA,RAINC          &
+     &                                  ,SFCZ,XLAND
+!
+#ifndef WRF_CHEM
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: RAINCV
+#endif
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME) :: WMID
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W,P_PHY,PI_PHY    &
+     &                                          ,RQCCUTEN,RQRCUTEN      &
+     &                                          ,RQICUTEN,RQSCUTEN      &
+     &                                          ,RQVCUTEN,RR,RTHCUTEN   &
+     &                                          ,T_PHY,TH_PHY           &
+     &                                          ,U_PHY,V_PHY
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME)        :: ZERO_2D
+      REAL,DIMENSION(IMS:IME,JMS:JME,ENSDIM) :: ZERO_GD
+!
+      LOGICAL :: RESTART,WARM_RAIN
+      LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG
+!
+!-----------------------------------------------------------------------
+!***  FOR TEMPERATURE CHANGE CHECK ONLY.
+!-----------------------------------------------------------------------
+      INTEGER :: DTEMP_CHECK=1.0
+      REAL :: TCHANGE
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!***  RESET THE HBOT/HTOP CONVECTIVE CLOUD BOTTOM (BASE) AND TOP ARRAYS
+!***  USED IN RADIATION.  THEY STORE THE MAXIMUM VERTICAL LIMITS OF 
+!***  CONVECTIVE CLOUD BETWEEN RADIATION CALLS.  CUPPT IS THE ACCUMULATED
+!***  CONVECTIVE PRECIPITATION BETWEEN RADIATION CALLS.
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,NRADS)==0.OR.MOD(NTSD,NRADL)==0)THEN
+         DO J=JMS,JME
+         DO I=IMS,IME
+           HTOP(I,J)=0.
+           HBOT(I,J)=REAL(KTE+1)
+           CUPPT(I,J)=0.
+         ENDDO
+         ENDDO
+      ENDIF
+!-----------------------------------------------------------------------
+      IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
+     &   CONFIG_FLAGS%CU_PHYSICS==BMJSCHEME)RETURN
+      IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
+     &   CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)RETURN
+!-----------------------------------------------------------------------
+      NSTEP_CNV=NCNVC
+!
+      RESTART=RESTRT
+!-----------------------------------------------------------------------
+      IF(CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN
+!
+        IF(.NOT.RESTART.AND.NTSD==0)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=JTS,JTE
+          DO K=KTS,KTE
+          DO I=ITS,ITE
+            W0AVG(I,K,J)=0.
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDIF
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  GENERAL PREPARATION 
+!-----------------------------------------------------------------------
+!
+      AVCNVC=AVCNVC+1.
+      ACUTIM=ACUTIM+1.
+!
+      DTCNVC=NCNVC*DT
+      RDTCNVC=1./DTCNVC
+      CAPA=R_D/CP
+      G_INV=1./G
+!
+!$omp parallel do                                                       &
+!$omp& private(dpl,fice,frain,i,j,k,pdsl,plyr,ql,tl)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL=PD(I,J)*RES(I,J)
+        RAINCV(I,J)=0.
+        RAINC(I,J)=0.
+        P8W(I,KTS,J)=PD(I,J)+PDTOP+PT
+        LOWLYR(I,J)=KTE+1-LMH(I,J)
+        XLAND(I,J)=SM(I,J)+1.
+        NCA(I,J)=0.
+        SFCZ(I,J)=FIS(I,J)*G_INV
+!tgs
+          CUTOP(I,J)=HTOP(I,J)
+          CUBOT(I,J)=HBOT(I,J)
+!
+!***  LPBL IS THE MODEL LAYER CONTAINING THE PBL TOP
+!***  COUNTING DOWNWARD FROM THE TOP OF THE DOMAIN
+!***  SO KPBL IS THE SAME LAYER COUNTING UPWARD FROM 
+!***  THE GROUND.
+!
+        KPBL(I,J)=KTE-LPBL(I,J)+1
+        ZERO_2D(I,J)=0
+!
+        DO K=KTS,KTE
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL
+          QL(K)=AMAX1(Q(I,K,J),EPSQ)
+          PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL+PT
+          TL(K)=T(I,K,J)
+!
+          RR(I,K,J)=PLYR/(R_D*TL(K)*(P608*QL(K)+1.))
+          T_PHY(I,K,J)=TL(K)
+
+          TH_PHY(I,K,J)=TL(K)*(1.E5/PLYR)**CAPA
+!!!       P8W(I,KFLIP,J)=PINT(I,K+1,J)
+          P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL+PT
+          P_PHY(I,K,J)=PLYR
+          PI_PHY(I,K,J)=(PLYR*1.E-5)**CAPA
+!
+          RTHCUTEN(I,K,J)=0.
+          RQVCUTEN(I,K,J)=0.
+          RQCCUTEN(I,K,J)=0.
+          RQRCUTEN(I,K,J)=0.
+          RQICUTEN(I,K,J)=0.
+          RQSCUTEN(I,K,J)=0.
+        ENDDO
+!
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+
+      IF(.NOT.HYDRO)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+        DO I=MYIS1,MYIE1
+          DZ(I,K,J)=Z(I,K+1,J)-Z(I,K,J)
+        ENDDO
+        ENDDO
+        ENDDO
+!
+        IF(NTSD==0)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=MYJS2,MYJE2
+          DO K=KTS,KTE
+          DO I=MYIS1,MYIE1
+            WINT(I,K,J)=0.
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDIF
+      ELSE
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          WINT(I,1,J)=0.
+          WINT(I,KTE+1,J)=0.
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,plyr,wmid)
+        DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            WMID(I,KTS)=-OMGALF(I,KTS,J)*CP/(G*DT)
+            PDSL=PD(I,J)*RES(I,J)
+            PLYR=AETA1(KTS)*PDTOP+AETA2(KTS)*PDSL+PT
+            DZ(I,KTS,J)=T(I,KTS,J)*(P608*Q(I,KTS,J)+1.)*R_D             &
+     &                 *(P8W(I,KTS,J)-P8W(I,KTS+1,J))                   &
+     &                 /(PLYR*G)
+          ENDDO
+!
+          DO K=KTS+1,KTE
+          DO I=MYIS1,MYIE1
+            QL_K=AMAX1(Q(I,K,J),EPSQ)
+            WMID(I,K)=-OMGALF(I,K,J)*CP/(G*DT)
+            WINT(I,K,J)=0.5*(WMID(I,K-1)+WMID(I,K))
+            DZ(I,K,J)=T_PHY(I,K,J)*(P608*QL_K+1.)*R_D                   &
+     &               *(P8W(I,K,J)-P8W(I,K+1,J))                         &
+     &               /(P_PHY(I,K,J)*G)
+          ENDDO
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE VELOCITY COMPONENTS AT MASS POINTS
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%CU_PHYSICS.NE.BMJSCHEME)THEN
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,rwmsk,wmsk)
+        DO J=MYJS1_P1,MYJE1_P1
+!
+          DO K=KTS,KTE
+          DO I=MYIS_P1,MYIE_P1
+            WMSK=VTM(I+IHE(J),K,J)+VTM(I+IHW(J),K,J)                    &
+     &          +VTM(I,K,J+1)+VTM(I,K,J-1)
+            IF(WMSK>0.)THEN
+              RWMSK=1./WMSK
+              U_PHY(I,K,J)=(U(I+IHE(J),K,J)*VTM(I+IHE(J),K,J)           &
+     &                         +U(I+IHW(J),K,J)*VTM(I+IHW(J),K,J)       &
+     &                         +U(I,K,J+1)*VTM(I,K,J+1)                 &
+     &                         +U(I,K,J-1)*VTM(I,K,J-1))*RWMSK
+              V_PHY(I,K,J)=(V(I+IHE(J),K,J)*VTM(I+IHE(J),K,J)           &
+     &                         +V(I+IHW(J),K,J)*VTM(I+IHW(J),K,J)       &
+     &                         +V(I,K,J+1)*VTM(I,K,J+1)                 &
+     &                         +V(I,K,J-1)*VTM(I,K,J-1))*RWMSK
+            ELSE
+              U_PHY(I,K,J)=0.
+              V_PHY(I,K,J)=0.
+            ENDIF
+          ENDDO
+          ENDDO
+!
+        ENDDO
+!
+      ENDIF
+!-----------------------------------------------------------------------
+!
+!***  SINGLE-COLUMN CONVECTION
+!
+!-----------------------------------------------------------------------
+!
+      CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
+!
+      CALL CUMULUS_DRIVER(                                              &
+     &                  IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
+     &                 ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
+     &                 ,I_START=GRID%I_START,I_END=GRID%I_END           &
+     &                 ,J_START=GRID%J_START,J_END=GRID%J_END           &
+     &                 ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
+                  ! Prognostic
+     &                 ,U=U_PHY,V=V_PHY,TH=TH_PHY,T=T_PHY,W=WINT        &
+     &                 ,P=P_PHY,PI=PI_PHY,RHO=RR,W0AVG=W0AVG            &
+                  ! Others
+     &                 ,ITIMESTEP=NTSD,DT=DT,DX=GPS                     &
+     &                 ,RAINC=RAINC,RAINCV=RAINCV,NCA=NCA               &
+     &                 ,DZ8W=DZ,P8W=P8W,FORCET=TTEN,FORCEQ=QTEN         &
+     &                 ,CLDEFI=cldefi,LOWLYR=lowlyr,XLAND=xland         &
+     &                 ,CU_ACT_FLAG=cu_act_flag,WARM_RAIN=warm_rain     &
+     &                 ,STEPCU=NSTEP_CNV,GSW=gsw                        &
+     &                 ,HTOP=CUTOP,HBOT=CUBOT,KPBL=KPBL,HT=SFCZ         &   
+     &                 ,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc         &
+     &                 ,APR_ST=apr_st,APR_AS=apr_as,APR_CAPMA=apr_capma &
+     &                 ,APR_CAPME=apr_capme,APR_CAPMI=apr_capmi         &
+     &                 ,MASS_FLUX=mass_flux,XF_ENS=xf_ens               &
+     &                 ,PR_ENS=pr_ens                                   &
+#ifdef WRF_CHEM
+     &                 ,gd_cloud=gd_cloud,gd_cloud2=gd_cloud2           &
+#endif
+
+     &                 ,ENSDIM=ENSDIM,MAXIENS=1,MAXENS=3                &
+     &                 ,MAXENS2=3,MAXENS3=16                            &
+     &                 ,RTHCUTEN=RTHCUTEN ,RQVCUTEN=RQVCUTEN            &
+     &                 ,RQCCUTEN=RQCCUTEN ,RQRCUTEN=RQRCUTEN            &
+     &                 ,RQICUTEN=RQICUTEN ,RQSCUTEN=RQSCUTEN            &
+     &                 ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN             & 
+     &                 ,RTHRATEN=RTHRATEN                               & 
+                  ! Selection argument
+     &                 ,CU_PHYSICS=CONFIG_FLAGS%CU_PHYSICS              &
+                  ! Moisture tracer arguments
+     &                 ,QV_CURR=MOIST(IMS,KMS,JMS,P_QV),F_QV=F_QV       &
+     &                 ,QC_CURR=MOIST(IMS,KMS,JMS,P_QC),F_QC=F_QC       &
+     &                 ,QR_CURR=MOIST(IMS,KMS,JMS,P_QR),F_QR=F_QR       &
+     &                 ,QI_CURR=MOIST(IMS,KMS,JMS,P_QI),F_QI=F_QI       &
+     &                 ,QS_CURR=MOIST(IMS,KMS,JMS,P_QS),F_QS=F_QS       &
+     &                 ,QG_CURR=MOIST(IMS,KMS,JMS,P_QG),F_QG=F_QG      )
+!
+!-----------------------------------------------------------------------
+!
+!***  CNVTOP/CNVBOT HOLD THE MAXIMUM VERTICAL LIMITS OF CONVECTIVE CLOUD 
+!***  BETWEEN HISTORY OUTPUT TIMES.  HBOTS/HTOPS STORE SIMILIAR INFORMATION
+!***  FOR SHALLOW (NONPRECIPITATING) CONVECTION, AND HBOTD/HTOPD ARE FOR
+!***  DEEP (PRECIPITATING) CONVECTION.  
+!
+      CF_HI=CONFIG_FLAGS%HISTORY_INTERVAL
+      N_TIMSTPS_OUTPUT=NINT(60.*CF_HI/DT)
+      MNTO=MOD(NTSD,N_TIMSTPS_OUTPUT)
+!
+      IF(MNTO>0.AND.MNTO<=NCNVC)THEN
+        DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
+        DO I=MYIS1,IENDX
+          CNVBOT(I,J)=REAL(KTE+1.)
+          CNVTOP(I,J)=0.
+          HBOTD(I,J)=REAL(KTE+1.)
+          HTOPD(I,J)=0.
+          HBOTS(I,J)=REAL(KTE+1.)
+          HTOPS(I,J)=0.
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dqdt,dtdt,i,iendx,j,k,ncubot,ncutop,pcpcol               &
+!$omp&        ,tchange                                                  &
+!$omp&        )
+      DO J=MYJS2,MYJE2
+      IENDX=MYIE1
+      IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
+      DO I=MYIS1,IENDX
+!
+!***  UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING.
+!***  THE FLIP IS BECAUSE RTHCUTEN AND RQVCUTEN REACH THIS POINT
+!***  WITH LAYER 1 AT THE BOTTOM.
+!
+        DO K=KTS,KTE
+!
+!***  RQVCUTEN IN BMJDRV IS THE MIXING RATIO TENDENCY,
+!***  SO RETRIEVE DQDT BY CONVERTING TO SPECIFIC HUMIDITY.
+!
+          DQDT=RQVCUTEN(I,K,J)/(1.+MOIST(I,K,J,P_QV))**2
+!
+!***  RTHCUTEN IN BMJDRV IS DTDT OVER PI.
+!
+          DTDT=RTHCUTEN(I,K,J)*PI_PHY(I,K,J)
+          T(I,K,J)=T(I,K,J)+DTDT*DTCNVC
+          Q(I,K,J)=Q(I,K,J)+DQDT*DTCNVC
+          MOIST(I,K,J,P_QV)=Q(I,K,J)/(1.-Q(I,K,J))       !Convert to mixing ratio
+!tgs - added next two lines
+          cps_select: SELECT CASE(config_flags%cu_physics)
+!
+          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME)
+           IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+             MOIST(I,K,J,P_QS)=MAX(0.,MOIST(I,K,J,P_QS)+RQICUTEN(I,K,J)*DTCNVC+RQSCUTEN(I,K,J)*DTCNVC)
+           ELSE
+             MOIST(I,K,J,P_QI)=MAX(0.,MOIST(I,K,J,P_QI)+RQICUTEN(I,K,J)*DTCNVC)
+             MOIST(I,K,J,P_QS)=MAX(0.,MOIST(I,K,J,P_QS)+RQSCUTEN(I,K,J)*DTCNVC)
+           ENDIF
+           MOIST(I,K,J,P_QR)=MAX(0.,MOIST(I,K,J,P_QR)+RQRCUTEN(I,K,J)*DTCNVC)
+           MOIST(I,K,J,P_QC)=MAX(0.,MOIST(I,K,J,P_QC)+RQCCUTEN(I,K,J)*DTCNVC)
+          END SELECT cps_select
+!
+          TCUCN(I,K,J)=TCUCN(I,K,J)+DTDT
+!
+          TCHANGE=DTDT*DTCNVC
+	  IF(ABS(TCHANGE)>DTEMP_CHECK)THEN
+            WRITE(0,*)'BIG T CHANGE BY CONVECTION:  I,J,K,NTSD',TCHANGE,I,J,K,NTSD
+	  ENDIF
+!
+        ENDDO
+!
+!***  UPDATE PRECIPITATION
+!
+        PCPCOL=RAINCV(I,J)*1.E-3*NSTEP_CNV
+        PREC(I,J)=PREC(I,J)+PCPCOL
+        ACPREC(I,J)=ACPREC(I,J)+PCPCOL
+        CUPREC(I,J)=CUPREC(I,J)+PCPCOL
+        CUPPT(I,J)=CUPPT(I,J)+PCPCOL
+        CPRATE(I,J)=PCPCOL
+!
+!***  SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND
+!***  FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS.
+!***  MUST BE TREATED SEPARATELY FROM EACH OTHER.
+!
+        NCUTOP=NINT(CUTOP(I,J))
+        NCUBOT=NINT(CUBOT(I,J))
+!
+        IF(NCUTOP>1.AND.NCUTOP0.)THEN
+            HTOPD(I,J)=MAX(CUTOP(I,J),HTOPD(I,J))
+          ELSE
+            HTOPS(I,J)=MAX(CUTOP(I,J),HTOPS(I,J))
+          ENDIF
+        ENDIF
+        IF(NCUBOT>0.AND.NCUBOT0.)THEN
+            HBOTD(I,J)=MIN(CUBOT(I,J),HBOTD(I,J))
+          ELSE
+            HBOTS(I,J)=MIN(CUBOT(I,J),HBOTS(I,J))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=JMS,JME
+      DO K=KMS,KME
+      DO I=IMS,IME
+        ZERO_3D(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE CUCNVC
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
+     &                   ,DX,DY,LMH,SM,HBM2,FIS                         &
+     &                   ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2             &
+     &                   ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN            &
+     &                   ,MOIST,SCALAR,N_SCALAR                         &
+     &                   ,F_ICE,F_RAIN,F_RIMEF,SR                       &
+     &                   ,PREC,ACPREC,AVRAIN,ZERO_3D                    &
+     &                   ,MP_RESTART_STATE                              &
+     &                   ,TBPVS_STATE                                   &
+     &                   ,TBPVS0_STATE                                  &
+     &                   ,GRID,CONFIG_FLAGS                             &
+     &                   ,IDS,IDE,JDS,JDE,KDS,KDE                       &
+     &                   ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                   ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    GSMDRIVE    MICROPHYSICS OUTER DRIVER
+!   PRGRMMR: BLACK           ORG: W/NP22     DATE: 02-03-26       
+!     
+! ABSTRACT:
+!     GSMDRIVE DRIVES THE MICROPHYSICS SCHEMES
+!     
+! PROGRAM HISTORY LOG:
+!   02-03-26  BLACK      - ORIGINATOR
+!   04-11-18  BLACK      - THREADED
+!     
+! USAGE: CALL GSMDRIVE FROM SOLVE_NMM
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,N_MOIST,N_SCALAR,NPHS,NTSD
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DT,DX,DY,PDTOP,PT
+!
+      REAL,INTENT(INOUT) :: AVRAIN
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: AETA1,AETA2,DETA1,DETA2
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA1,ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PD,RES,SM
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: PINT
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: ZERO_3D
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: CWM,Q,T  &
+     &                                                        ,TRAIN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE    &
+     &                                                        ,F_RAIN   &
+     &                                                        ,F_RIMEF
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,n_moist),INTENT(INOUT) :: MOIST
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,n_scalar),INTENT(INOUT) :: SCALAR
+!
+!***  State var for etampnew microphysics (JM, 2005 05 02)
+!
+      REAL,DIMENSION(:),INTENT(INOUT) ::               MP_RESTART_STATE &
+     &                                                     ,TBPVS_STATE &
+     &                                                    ,TBPVS0_STATE
+
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR
+!
+      TYPE(DOMAIN),TARGET :: GRID
+!
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+      INTEGER :: I,I_M,IENDX,J,K,IJ
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR
+!
+      REAL :: CAPA,DPL,DTPHS,PCPCOL,PDSL,PLYR,RDTPHS,RG,TNEW
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,RAINNC,RAINNCV,XLAND      &
+     &                                  ,ZERO_2D
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DZ,P8W,P_PHY,PI_PHY    &
+     &                                          ,RR,T_PHY,TH_PHY
+!
+      LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+        QT_PRESENT=.TRUE.
+      ELSE
+        QT_PRESENT=.FALSE.
+      ENDIF
+!
+      DTPHS=NPHS*DT
+      RDTPHS=1./DTPHS
+      CAPA=R_D/CP
+      RG=1./G
+      AVRAIN=AVRAIN+1.
+!
+!-----------------------------------------------------------------------
+!
+!***  PREPARE NEEDED ARRAYS
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dpl,i,j,k,pdsl,plyr,ql,tl)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL=PD(I,J)*RES(I,J)
+        P8W(I,KTE+1,J)=PT
+        LOWLYR(I,J)=KTE+1-LMH(I,J)
+        XLAND(I,J)=SM(I,J)+1.
+        ZERO_2D(I,J)=0.
+! FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE 
+!         ACCUMULATED RAIN BUT NOT YET USED BY NMM)
+! COULD BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC) 
+        RAINNC(I,J)=0.
+!
+!***  FILL THE SINGLE-COLUMN INPUT
+!
+        DO K=KTS,KTE
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL
+          QL(K)=AMAX1(Q(I,K,J),EPSQ)
+!!!       PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL+PT
+          PLYR=(PINT(I,K,J)+PINT(I,K+1,J))*0.5
+          TL(K)=T(I,K,J)
+!
+          RR(I,K,J)=PLYR/(R_D*TL(K)*(P608*QL(K)+1.))
+          T_PHY(I,K,J)=TL(K)
+          PI_PHY(I,K,J)=(PLYR*1.E-5)**CAPA
+          TH_PHY(I,K,J)=TL(K)/PI_PHY(I,K,J)
+!!!       P8W(I,KFLIP,J)=PINT(I,K+1,J)
+          P8W(I,K,J)=ETA1(K)*PDTOP+ETA2(K)*PDSL+PT
+          P_PHY(I,K,J)=PLYR
+          DZ(I,K,J)=DPL*RG/RR(I,K,J)
+        ENDDO
+!
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+!***  CALL MICROPHYSICS
+!
+!-----------------------------------------------------------------------
+!
+      CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
+!
+      CALL MICROPHYSICS_DRIVER(                                         &
+     &                  TH=TH_PHY,RHO=RR,PI_PHY=PI_PHY,P=P_PHY          &
+     &                 ,RAINNC=RAINNC,RAINNCV=RAINNCV                   &
+     &                 ,DZ8W=DZ,P8W=P8W,DT=DTPHS,DX=DX,DY=DY            &
+     &                 ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS              &
+     &                 ,SPECIFIED=CONFIG_FLAGS%SPECIFIED                &
+     &                        .OR.CONFIG_FLAGS%NESTED                   &
+     &                 ,SPEC_ZONE=0,WARM_RAIN=WARM_RAIN                 &
+     &                 ,XLAND=XLAND,ITIMESTEP=NTSD-1                    &
+     &                 ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN               &
+     &                 ,F_RIMEF_PHY=F_RIMEF                             &
+     &                 ,LOWLYR=LOWLYR,SR=SR                             &
+     &                 ,QV_CURR=MOIST(IMS,KMS,JMS,P_QV),F_QV=F_QV       &
+     &                 ,QC_CURR=MOIST(IMS,KMS,JMS,P_QC),F_QC=F_QC       &
+     &                 ,QR_CURR=MOIST(IMS,KMS,JMS,P_QR),F_QR=F_QR       &
+     &                 ,QI_CURR=MOIST(IMS,KMS,JMS,P_QI),F_QI=F_QI       &
+     &                 ,QS_CURR=MOIST(IMS,KMS,JMS,P_QS),F_QS=F_QS       &
+     &                 ,QG_CURR=MOIST(IMS,KMS,JMS,P_QG),F_QG=F_QG       &
+     &                 ,QNI_CURR=SCALAR(IMS,KMS,JMS,P_QNI),F_QNI=F_QNI  &
+     &                 ,QT_CURR=CWM,F_QT=qt_present                     &
+     &                 ,MP_RESTART_STATE=MP_RESTART_STATE               &
+     &                 ,TBPVS_STATE=TBPVS_STATE                         &
+     &                 ,TBPVS0_STATE=TBPVS0_STATE                       &
+     &                 ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE &
+     &                 ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME &
+     &                 ,I_START=GRID%I_START,I_END=GRID%I_END           &
+     &                 ,J_START=GRID%J_START,J_END=GRID%J_END           &
+     &                 ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
+                                                                        )
+
+!$omp parallel do                                                       &
+!$omp& private(ij)
+      DO IJ=1,GRID%NUM_TILES
+        CALL MICROPHYSICS_ZERO_OUT(                                     &
+                     MOIST,N_MOIST,CONFIG_FLAGS                         &
+                    ,IDS,IDE,JDS,JDE,KDS,KDE                            &
+                    ,IMS,IME,JMS,JME,KMS,KME                            &
+                    ,GRID%I_START(IJ),GRID%I_END(IJ)                    &
+                    ,GRID%J_START(IJ),GRID%J_END(IJ)                    &
+                    ,KTS,KTE                                       )
+      ENDDO
+
+
+
+!
+!-----------------------------------------------------------------------
+!
+      E_BDY=(ITE>=IDE)
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,k,pcpcol,tnew,i_m)
+      DO J=MYJS2,MYJE2
+      IENDX=MYIE1
+      IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
+      DO I=MYIS1,IENDX
+!
+!***  UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING.
+!
+        DO K=KTS,KTE
+          TNEW=TH_PHY(I,K,J)*PI_PHY(I,K,J)
+          TRAIN(I,K,J)=TRAIN(I,K,J)+(TNEW-T(I,K,J))*RDTPHS
+          T(I,K,J)=TNEW
+          Q(I,K,J)=MOIST(I,K,J,P_QV)/(1.+MOIST(I,K,J,P_QV)) !To s.h.
+!         CWM(I,K,J)=0.
+!         DO I_M=2,N_MOIST
+!           IF(I_M/=P_QV)THEN
+!             CWM(I,K,J)=CWM(I,K,J)+MOIST(I,K,J,I_M)
+!           ENDIF
+!         ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  UPDATE PRECIPITATION
+!-----------------------------------------------------------------------
+!
+        PCPCOL=RAINNCV(I,J)*1.E-3
+        PREC(I,J)=PREC(I,J)+PCPCOL
+        ACPREC(I,J)=ACPREC(I,J)+PCPCOL
+! NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT OUT ABOVE
+!    SINCE IT IS ONLY A LOCAL ARRAY FOR NOW
+!
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO J=JMS,JME
+      DO K=KMS,KME
+      DO I=IMS,IME
+        ZERO_3D(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!-------------------------------------------------------------------
+!
+      END SUBROUTINE GSMDRIVE
+!
+!-------------------------------------------------------------------
+!
+      END MODULE MODULE_PHYSICS_CALLS
+!
+!-------------------------------------------------------------------
diff --git a/wrfv2_fire/dyn_nmm/module_PRECIP_ADJUST.F b/wrfv2_fire/dyn_nmm/module_PRECIP_ADJUST.F
new file mode 100644
index 00000000..a3e14a6e
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_PRECIP_ADJUST.F
@@ -0,0 +1,297 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: PHYSICS
+!
+!----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_PRECIP_ADJUST
+!
+! This module contains 3 subroutines:
+!     READPCP
+!     CHKSNOW
+!     ADJPPT
+!-----------------------------------------------------------------------
+!***
+!***  Specify the diagnostic point here: (i,j) and the processor number.
+!***  Remember that in WRF, local and global (i,j) are the same, so don't
+!***  use the "local(i,j)" output from glb2loc.f; use the GLOBAL (I,J)
+!***  and the PE_WRF.
+!***
+!
+      INTEGER :: ITEST=346,JTEST=256,TESTPE=53
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!-----------------------------------------------------------------------
+      SUBROUTINE READPCP(PPTDAT,DDATA,LSPA                              &
+     &  ,IDS,IDE,JDS,JDE,KDS,KDE                                        &
+     &  ,IMS,IME,JMS,JME,KMS,KME                                        &
+     &  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!     ****************************************************************
+!     *                                                              *
+!     *   PRECIPITATION ASSIMILATION INITIALIZATION.                 *
+!     *    READ IN PRECIP ANALYSIS AND DATA MASK AND SET UP ALL      *
+!     *    APPROPRIATE VARIABLES.                                    *
+!     *                   MIKE BALDWIN, MARCH 1994                   *
+!     *                   Adapted to 2-D code, Ying Lin, Mar 1996    *
+!     *                   For WRF/NMM: Y.Lin Mar 2005                *
+!     *                                                              *
+!     ****************************************************************
+!-----------------------------------------------------------------------
+!
+! READ THE BINARY VERSION OF THE PRECIP ANALYSIS.
+!
+      IMPLICIT NONE
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,                    &
+     &                      IMS,IME,JMS,JME,KMS,KME,                    &
+     &                      ITS,ITE,JTS,JTE,KTS,KTE
+      REAL,DIMENSION(IDS:IDE,JDS:JDE) :: TEMPG
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: TEMPL
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: DDATA, LSPA
+      REAL,DIMENSION(IMS:IME,JMS:JME,3),INTENT(OUT) :: PPTDAT
+      INTEGER :: I, J, IHR
+      INTEGER :: MYPE
+      CHARACTER*256 :: MESSAGE
+!
+! Get the value of MYPE:
+!
+      CALL WRF_GET_MYPROC(MYPE)
+!
+      TEMPG=999.
+!
+      DO IHR=1,3
+        IF(MYPE==0)THEN
+          READ(40+IHR) ((TEMPG(I,J),I=IDS,IDE-1),J=JDS,JDE-1)
+          WRITE(MESSAGE,*) 'IHR=', IHR, ' FINISHED READING PCP TO TEMPG'
+          CALL WRF_MESSAGE(MESSAGE)
+          CLOSE(40+IHR)
+!
+          DO J=JDS,JDE-1
+            DO I=IDS,IDE-1
+! In the binary version of the precip data, missing data are denoted as '999.'
+! Convert the valid data from mm to m:
+              IF (TEMPG(I,J).LT.900.) TEMPG(I,J)=TEMPG(I,J)*0.001
+            ENDDO
+          ENDDO
+        ENDIF
+!
+! Distribute to local temp array:
+        CALL DSTRB(TEMPG,TEMPL,1,1,1,1,1                                &
+     &,                IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &,                IMS,IME,JMS,JME,KMS,KME                          &
+     &,                ITS,ITE,JTS,JTE,KTS,KTE)
+!
+! Place into correct hour slot in PPTDAT:
+        DO J=JMS,JME
+          DO I=IMS,IME
+            PPTDAT(I,J,IHR)=TEMPL(I,J)
+          ENDDO
+        ENDDO
+!
+        IF(MYPE==TESTPE)THEN
+          WRITE(MESSAGE,*) 'ADJPPT-READPCP, IHR',IHR, 'PPTDAT=',        &
+     &      PPTDAT(ITEST,JTEST,IHR)
+          CALL WRF_MESSAGE(MESSAGE)
+        ENDIF
+
+      ENDDO
+!
+! Give DDATA (hourly precipitation analysis partitioned into each physics
+! timestep; partitioning done in ADJPPT) an initial value of 999, because
+! TURBL/SURFCE is called before ADJPPT.  Also initialize LSPA to zero.
+!
+      DDATA=999.
+      LSPA=0.
+!
+      RETURN
+      END SUBROUTINE READPCP
+!
+      SUBROUTINE CHKSNOW(NTSD,DT,NPHS,SR,PPTDAT                         &
+     &  ,IDS,IDE,JDS,JDE,KDS,KDE                                        &
+     &  ,IMS,IME,JMS,JME,KMS,KME                                        &
+     &  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+! AT THE FIRST PHYSICS TIME STEP AFTER THE TOP OF EACH HOUR, CHECK THE SNOW
+! ARRAY AGAINST THE SR (SNOW/TOTAL PRECIP RATIO).  IF SR .GE. 0.9, SET THIS
+! POINT TO MISSING (SO WE WON'T DO SNOW ADJUSTMENT HERE).
+!
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: NTSD,NPHS
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,                    &
+     &                      IMS,IME,JMS,JME,KMS,KME,                    &
+     &                      ITS,ITE,JTS,JTE,KTS,KTE
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: SR
+      REAL,DIMENSION(IMS:IME,JMS:JME,3),INTENT(INOUT) :: PPTDAT
+      REAL,INTENT(IN) :: DT
+      REAL :: TIMES
+      INTEGER :: I, J, IHR
+      INTEGER :: MYPE
+      CHARACTER*256 :: MESSAGE
+!-----------------------------------------------------------------------
+      TIMES=NTSD*DT
+      IF (MOD(TIMES,3600.) < NPHS*DT) THEN
+        IHR=INT(TIMES)/3600+1
+        IF (IHR > 3) go to 10
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          IF (SR(I,J) >= 0.9) PPTDAT(I,J,IHR) = 999.
+        ENDDO
+        ENDDO
+!
+! Get the value of MYPE:
+!
+        CALL WRF_GET_MYPROC(MYPE)
+!
+        IF (MYPE==TESTPE) THEN
+          WRITE(MESSAGE,1010) TIMES,SR(ITEST,JTEST)
+ 1010     FORMAT('ADJPPT-CHKSNOW: TIMES, SR=',F6.0,X,F6.4)
+          CALL WRF_MESSAGE(MESSAGE)
+        ENDIF
+      ENDIF
+ 10   CONTINUE
+      RETURN
+      END SUBROUTINE CHKSNOW
+!
+      SUBROUTINE ADJPPT(NTSD,DT,NPHS,PREC,LSPA,PPTDAT,DDATA             &
+     &  ,IDS,IDE,JDS,JDE,KDS,KDE                                        &
+     &  ,IMS,IME,JMS,JME,KMS,KME                                        &
+     &  ,ITS,ITE,JTS,JTE,KTS,KTE)
+
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .     
+! SUBPROGRAM:    ADJPPT    PRECIPITATION/CLOUD ADJUSTMENT
+!    PRGRMMR:    Y. LIN    ORG: W/NP22     DATE: 2005/03/30
+!     
+! ABSTRACT:
+!     ADJPPT  MAKES ADJUSTMENT TO MODEL'S TEMPERATURE, MOISTURE, HYDROMETEOR
+!     FIELDS TO BE MORE CONSISTENT WITH THE OBSERVED PRECIPITATION AND CLOUD
+!     TOP PRESSURE
+!     
+!     FOR NOW, AS A FIRST STEP, JUST PARTITION THE INPUT HOURLY PRECIPITATION
+!     OBSERVATION INTO TIME STEPS, AND FEED IT INTO THE SOIL.
+! PROGRAM HISTORY LOG:
+!
+!   2005/03/30  LIN      - BAREBONES PRECIPITATION PARTITION/FEEDING TO GROUND
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: NPHS, NTSD
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,                    &
+     &                      IMS,IME,JMS,JME,KMS,KME,                    &
+     &                      ITS,ITE,JTS,JTE,KTS,KTE
+      REAL,INTENT(IN) :: DT
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PREC
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: DDATA, LSPA
+      REAL,DIMENSION(IMS:IME,JMS:JME,3),INTENT(OUT) :: PPTDAT
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+!-----------------------------------------------------------------------
+      REAL :: DTPHS, FRACT, FRACT1, FRACT2, TIMES, TPHS1, TPHS2
+      INTEGER :: I, J, IHR, IHR1, IHR2, NTSP
+      INTEGER :: MYPE
+      CHARACTER*256 :: MESSAGE
+!
+! Get the value of MYPE:
+!
+      CALL WRF_GET_MYPROC(MYPE)
+!
+      TIMES=NTSD*DT
+      IHR=INT(TIMES)/3600+1
+! Size of physics time step:
+      DTPHS=NPHS*DT
+!
+! Compute the beginning and ending time of the current physics time step,
+! TPHS1 and TPHS2:
+!  
+      NTSP=NTSD/NPHS+1
+      TPHS1=(NTSP-1)*DTPHS
+      TPHS2=NTSP*DTPHS
+!
+      IHR1=INT(TPHS1)/3600+1
+      IHR2=INT(TPHS2)/3600+1
+!
+! Fraction of an hour that falls into IHR1 and IHR2.  Note that IHR1 and IHR2
+! might be identical.
+      IF (IHR1 > 3) THEN 
+        GO TO 200
+      ELSEIF (IHR2 > 3) THEN
+        IHR2=3
+        FRACT1=(3600.- MOD(INT(TPHS1),3600))/3600.
+        FRACT2=0.
+      ELSEIF (IHR1 .EQ. IHR2) THEN
+         FRACT1=0.5*DTPHS/3600.
+         FRACT2=FRACT1
+      ELSE
+         FRACT1=(3600.- MOD(INT(TPHS1),3600))/3600.
+         FRACT2=FLOAT(MOD(INT(TPHS2),3600))/3600.
+      ENDIF
+!
+      FRACT=FRACT1 + FRACT2
+!
+      IF (MYPE==TESTPE) THEN
+         WRITE(MESSAGE,1010) NTSD,NTSP,TIMES,IHR1,IHR2,TPHS1,TPHS2,      &
+      &    FRACT1,FRACT2
+ 1010    FORMAT('ADJPPT: NTSD,NTSP,TIMES=',I4,X,I4,1X,F6.0,' IHR1,IHR2=',&
+      &    I1,X,I1,' TPHS1,TPHS2=',F6.0,X,F6.0,' FRACT1,FRACT2=',        &
+      &    2(X,F6.4))
+        CALL WRF_MESSAGE(MESSAGE)
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!   FRACT1/2 IS THE FRACTION OF IHR1/2'S PRECIP THAT WE WANT FOR
+!   THIS ADJUSTMENT (assuming that the physics time step spans over
+!   IHR1 and IHR2.  If not, then IHR1=IHR2).
+!-----------------------------------------------------------------------
+!   SET UP OBSERVED PRECIP FOR THIS TIMESTEP IN DDATA
+!-----------------------------------------------------------------------
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+! Note sometimes IHR1=IHR2.  
+        IF (PPTDAT(I,J,IHR1).GT.900..OR.PPTDAT(I,J,IHR2).GT.900.) THEN
+          DDATA(I,J) = 999.
+          LSPA(I,J) = LSPA(I,J) + PREC(I,J)
+          GO TO 100
+        ELSE
+          IF (IHR2 .LE. 3) then
+            DDATA(I,J) = PPTDAT(I,J,IHR1)*FRACT1                        &
+     &                 + PPTDAT(I,J,IHR2)*FRACT2
+          ELSE
+            DDATA(I,J) = PPTDAT(I,J,IHR1)*FRACT1 
+          ENDIF
+!
+           LSPA(I,J) = LSPA(I,J) + DDATA(I,J)
+        ENDIF
+        IF (I.EQ.ITEST .AND. J.EQ.JTEST .AND. MYPE.EQ.TESTPE) THEN
+          WRITE(MESSAGE,1020) DDATA(I,J), PREC(I,J), LSPA(I,J)
+ 1020     FORMAT('ADJPPT: DDATA=',E12.6, ' PREC=',E12.6,' LSPA=',E12.6)
+          CALL WRF_MESSAGE(MESSAGE)
+        ENDIF
+!
+ 100    CONTINUE
+      ENDDO
+      ENDDO
+!
+ 200  CONTINUE
+
+      RETURN
+      END SUBROUTINE ADJPPT
+END MODULE module_PRECIP_ADJUST
diff --git a/wrfv2_fire/dyn_nmm/module_TIMERS.F b/wrfv2_fire/dyn_nmm/module_TIMERS.F
new file mode 100644
index 00000000..acba2fd6
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_TIMERS.F
@@ -0,0 +1,17 @@
+!
+      MODULE MODULE_TIMERS
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!***  TIMERS OF FORECAST COMPONENTS
+!
+      REAL :: adve_tim,bocoh_tim,bocov_tim,chkout_tim,cltend_tim       &
+             ,cucnvc_tim,ddamp_tim,eps_tim,exch_tim,goss_tim           &
+             ,gsmdrive_tim,had2_tim,hadz_tim,hdiff_tim                 &
+             ,init_tim,nhb_tim,pdtedt_tim,pfdht_tim                    &
+             ,radtn_tim,rdtemp_tim,res_tim,surfce_tim,turbl_tim        &
+             ,vad2_tim,vadz_tim          
+      REAL :: allocm_tim,allocs_tim,digflt_tim,fltas_tim               &
+             ,gossip_tim,mpp_tim,runstream_tim
+      REAL :: brun_tim,btim,btimx,pct,tot_tim,tot2_tim
+!----------------------------------------------------------------------
+      END MODULE MODULE_TIMERS
diff --git a/wrfv2_fire/dyn_nmm/module_ZEROX.F b/wrfv2_fire/dyn_nmm/module_ZEROX.F
new file mode 100644
index 00000000..af6812fb
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_ZEROX.F
@@ -0,0 +1,85 @@
+      MODULE MODULE_ZEROX
+!----------------------------------------------------------------------
+      CONTAINS
+!----------------------------------------------------------------------
+!**********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    ZEROx       ZERO OUT MULTI-DIMENSIONAL ARRAY
+!   PRGRMMR: BLACK           ORG: W/NP2      DATE: 01-03-20
+!
+! ABSTRACT:
+!     SUBROUTINE ZEROx FILLS REAL ARRAYS WITH ZEROES
+!
+!     CURRENT INTERFACES: ZERO2, ZERO3
+!
+! PROGRAM HISTORY LOG:
+!   01-03-20  BLACK      - ORIGINATOR
+!
+! USAGE: CALL ZERO WHERE NEEDED
+!   INPUT ARGUMENT LIST:
+!      ARR2 - THE ARRAY TO BE FILLED
+!       IMS - THE STARTING I VALUE FOR LOCAL MEMORY
+!       IME - THE ENDING I VALUE FOR LOCAL MEMORY
+!       JMS - THE STARTING J VALUE FOR LOCAL MEMORY
+!       JME - THE ENDING J VALUE FOR LOCAL MEMORY
+!
+!   OUTPUT ARGUMENT LIST:
+!      ARR2
+!
+!   OUTPUT FILES:
+!     NONE
+!
+!   SUBPROGRAMS CALLED:
+!
+!     UNIQUE: NONE
+!
+!     LIBRARY: NONE
+!
+!   COMMON BLOCKS: NONE
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP
+!$$$
+!**********************************************************************
+      SUBROUTINE ZERO2(ARR2,IS,IE,JS,JE)
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IE,IS,JE,JS
+      REAL,DIMENSION(IS:IE,JS:JE),INTENT(INOUT) :: ARR2
+!
+      INTEGER :: I,J
+!**********************************************************************
+!----------------------------------------------------------------------
+      DO J=JS,JE
+      DO I=IS,IE
+        ARR2(I,J)=0.
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+      END SUBROUTINE ZERO2
+!**********************************************************************
+      SUBROUTINE ZERO3(ARR2,IS,IE,JS,JE,KS,KE)
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IE,IS,JE,JS,KE,KS
+      REAL,DIMENSION(IS:IE,KS:KE,JS:JE),INTENT(INOUT) :: ARR2
+!
+      INTEGER :: I,J,K
+!**********************************************************************
+!----------------------------------------------------------------------
+      DO J=JS,JE
+      DO K=KS,KE
+      DO I=IS,IE
+        ARR2(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+      END SUBROUTINE ZERO3
+!**********************************************************************
+!----------------------------------------------------------------------
+      END MODULE MODULE_ZEROX
diff --git a/wrfv2_fire/dyn_nmm/module_initialize_real.F b/wrfv2_fire/dyn_nmm/module_initialize_real.F
new file mode 100644
index 00000000..bd2d691d
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_initialize_real.F
@@ -0,0 +1,3905 @@
+!REAL:MODEL_LAYER:INITIALIZATION
+
+!  This MODULE holds the routines which are used to perform various initializations
+!  for the individual domains, specifically for the Eulerian, mass-based coordinate.
+
+!-----------------------------------------------------------------------
+
+MODULE module_initialize
+
+   USE module_bc
+   USE module_configure
+   USE module_domain
+   USE module_io_domain
+   USE module_model_constants
+!   USE module_si_io_nmm
+   USE module_state_description
+   USE module_timing
+   USE module_soil_pre
+#ifdef DM_PARALLEL
+   USE module_dm
+#endif
+
+   INTEGER :: internal_time_loop
+
+
+CONTAINS
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain ( grid )
+
+      IMPLICIT NONE
+
+      !  Input space and data.  No gridded meteorological data has been stored, though.
+
+!     TYPE (domain), POINTER :: grid 
+      TYPE (domain)          :: grid 
+
+      !  Local data.
+
+      INTEGER :: dyn_opt 
+      INTEGER :: idum1, idum2
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+#include "deref_kludge.h"
+
+      CALL nl_get_dyn_opt ( head_grid%id, dyn_opt )
+      
+      CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+      IF (      dyn_opt .eq. 1 &
+           .or. dyn_opt .eq. 2 &
+           .or. dyn_opt .eq. 3 &
+                                          ) THEN
+        CALL wrf_error_fatal ( "no RK version within dyn_nmm, dyn_opt wrong in namelist, wrf_error_fataling" )
+
+     ELSEIF ( dyn_opt .eq. 4 ) THEN
+
+        CALL init_domain_nmm (grid &
+!
+#include 
+!
+      )
+
+      ELSE
+         WRITE(0,*)' init_domain: unknown or unimplemented dyn_opt = ',dyn_opt
+        CALL wrf_error_fatal ( "ERROR-dyn_opt-wrong-in-namelist" )
+      ENDIF
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+!---------------------------------------------------------------------
+   SUBROUTINE init_domain_nmm ( grid &
+!
+# include 
+!
+   )
+
+      USE module_optional_si_input
+      IMPLICIT NONE
+
+      !  Input space and data.  No gridded meteorological data has been stored, though.
+
+!     TYPE (domain), POINTER :: grid
+      TYPE (domain)          :: grid
+
+# include 
+
+      TYPE (grid_config_rec_type)              :: config_flags
+
+      !  Local domain indices and counters.
+
+      INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
+
+      INTEGER                             ::                       &
+                                     ids, ide, jds, jde, kds, kde, &
+                                     ims, ime, jms, jme, kms, kme, &
+                                     its, ite, jts, jte, kts, kte, &
+                                     ips, ipe, jps, jpe, kps, kpe, &
+                                     i, j, k, NNXP, NNYP
+
+      !  Local data
+
+        CHARACTER(LEN=19):: start_date
+
+#ifdef DM_PARALLEL
+
+        LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
+
+!              INTEGER :: DOMDESC
+              REAL,ALLOCATABLE    :: SICE_G(:,:), SM_G(:,:)
+              INTEGER, ALLOCATABLE::  IHE_G(:),IHW_G(:)
+#endif
+
+      CHARACTER (LEN=132) :: message
+
+      INTEGER :: error
+      REAL    :: p_surf, p_level
+      REAL    :: cof1, cof2
+      REAL    :: qvf , qvf1 , qvf2 , pd_surf
+      REAL    :: p00 , t00 , a
+      REAL    :: hold_znw, rmin,rmax
+
+      REAL :: p_top_requested , ptsgm
+      INTEGER :: num_metgrid_levels, ICOUNT
+      REAL , DIMENSION(max_eta) :: eta_levels
+
+
+      LOGICAL :: stretch_grid, dry_sounding, debug, log_flag_sst, hyb_coor
+
+        REAL, ALLOCATABLE,DIMENSION(:,:):: ADUM2D,SNOWC,HT,TG_ALT, &
+                                           PDVP,PSFC_OUTV
+
+        REAL, ALLOCATABLE,DIMENSION(:,:,:):: P3D_OUT,P3DV_OUT,P3DV_IN, &
+                                             QTMP,QTMP2
+
+        INTEGER, ALLOCATABLE, DIMENSION(:):: KHL2,KVL2,KHH2,KVH2, &
+                                             KHLA,KHHA,KVLA,KVHA
+
+!        INTEGER, ALLOCATABLE, DIMENSION(:,:):: LU_INDEX
+
+        REAL, ALLOCATABLE, DIMENSION(:):: DXJ,WPDARJ,CPGFUJ,CURVJ, &
+                                          FCPJ,FDIVJ,EMJ,EMTJ,FADJ, &
+                                          HDACJ,DDMPUJ,DDMPVJ
+
+        REAL, ALLOCATABLE,DIMENSION(:),SAVE:: SG1,SG2,DSG1,DSG2, &
+                                              SGML1,SGML2
+
+!-- Carsel and Parrish [1988]
+         REAL , DIMENSION(100) :: lqmi
+         integer iicount 
+
+        REAL:: TPH0D,TLM0D
+        REAL:: TPH0,WB,SB,TDLM,TDPH
+        REAL:: WBI,SBI,EBI,ANBI,STPH0,CTPH0
+        REAL:: TSPH,DTAD,DTCF
+        REAL:: ACDT,CDDAMP,DXP,FP
+        REAL:: WBD,SBD
+        REAL:: RSNOW,SNOFAC
+        REAL, PARAMETER:: SALP=2.60
+        REAL, PARAMETER:: SNUP=0.040
+        REAL:: SMCSUM,STCSUM,SEAICESUM,FISX
+        REAL:: cur_smc, aposs_smc
+
+        INTEGER,PARAMETER:: DOUBLE=SELECTED_REAL_KIND(15,300)
+        REAL(KIND=DOUBLE):: TERM1,APH,TLM,TPH,DLM,DPH,STPH,CTPH
+
+        INTEGER:: KHH,KVH,JAM,JA, IHL, IHH, L
+        INTEGER:: II,JJ,ISRCH,ISUM,ITER, Ilook,Jlook
+
+
+        REAL, PARAMETER:: DTR=0.01745329
+        REAL, PARAMETER:: W_NMM=0.08
+        REAL, PARAMETER:: COAC=1.6
+        REAL, PARAMETER:: CODAMP=6.4
+        REAL, PARAMETER:: TWOM=.00014584
+        REAL, PARAMETER:: CP=1004.6
+        REAL, PARAMETER:: DFC=1.0
+        REAL, PARAMETER:: DDFC=8.0
+        REAL, PARAMETER:: ROI=916.6
+        REAL, PARAMETER:: R=287.04
+        REAL, PARAMETER:: CI=2060.0
+        REAL, PARAMETER:: ROS=1500.
+        REAL, PARAMETER:: CS=1339.2
+        REAL, PARAMETER:: DS=0.050
+        REAL, PARAMETER:: AKS=.0000005
+        REAL, PARAMETER:: DZG=2.85
+        REAL, PARAMETER:: DI=.1000
+        REAL, PARAMETER:: AKI=0.000001075
+        REAL, PARAMETER:: DZI=2.0
+        REAL, PARAMETER:: THL=210.
+        REAL, PARAMETER:: PLQ=70000.
+        REAL, PARAMETER:: ERAD=6371200.
+        REAL, PARAMETER:: TG0=258.16
+        REAL, PARAMETER:: TGA=30.0
+
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+#include "deref_kludge.h"
+
+        if (ALLOCATED(ADUM2D)) DEALLOCATE(ADUM2D)
+        if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT)
+
+#define COPY_IN
+#include 
+#ifdef DM_PARALLEL
+#    include 
+#endif
+
+      SELECT CASE ( model_data_order )
+         CASE ( DATA_ORDER_ZXY )
+            kds = grid%sd31 ; kde = grid%ed31 ;
+            ids = grid%sd32 ; ide = grid%ed32 ;
+            jds = grid%sd33 ; jde = grid%ed33 ;
+
+            kms = grid%sm31 ; kme = grid%em31 ;
+            ims = grid%sm32 ; ime = grid%em32 ;
+            jms = grid%sm33 ; jme = grid%em33 ;
+
+            kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch
+            its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch
+            jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
+
+         CASE ( DATA_ORDER_XYZ )
+            ids = grid%sd31 ; ide = grid%ed31 ;
+            jds = grid%sd32 ; jde = grid%ed32 ;
+            kds = grid%sd33 ; kde = grid%ed33 ;
+
+            ims = grid%sm31 ; ime = grid%em31 ;
+            jms = grid%sm32 ; jme = grid%em32 ;
+            kms = grid%sm33 ; kme = grid%em33 ;
+
+            its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
+            jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch
+            kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch
+
+         CASE ( DATA_ORDER_XZY )
+            ids = grid%sd31 ; ide = grid%ed31 ;
+            kds = grid%sd32 ; kde = grid%ed32 ;
+            jds = grid%sd33 ; jde = grid%ed33 ;
+
+            ims = grid%sm31 ; ime = grid%em31 ;
+            kms = grid%sm32 ; kme = grid%em32 ;
+            jms = grid%sm33 ; jme = grid%em33 ;
+
+            its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
+            kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch
+            jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
+
+      END SELECT
+
+
+        
+        grid%DT=float(grid%TIME_STEP)
+
+        NNXP=min(ITE,IDE-1)
+        NNYP=min(JTE,JDE-1)
+
+        write(message,*) 'IDE, JDE: ', IDE,JDE
+        write(message,*) 'NNXP, NNYP: ', NNXP,NNYP
+        CALL wrf_message(message)
+
+        JAM=6+2*(JDE-JDS-10)
+
+	if (internal_time_loop .eq. 1) then
+
+        ALLOCATE(ADUM2D(grid%sm31:grid%em31,jms:jme))
+        ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP))
+        ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP))
+        ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),&
+                 FADJ(JTS:NNYP))
+        ALLOCATE(HDACJ(JTS:NNYP),DDMPUJ(JTS:NNYP),DDMPVJ(JTS:NNYP))
+        ALLOCATE(KHLA(JAM),KHHA(JAM))
+        ALLOCATE(KVLA(JAM),KVHA(JAM))
+          
+        endif
+
+
+    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+        write(message,*) 'cen_lat: ', config_flags%cen_lat
+        CALL wrf_debug(100,message)
+        write(message,*) 'cen_lon: ', config_flags%cen_lon
+        CALL wrf_debug(100,message)
+        write(message,*) 'dx: ', config_flags%dx
+        CALL wrf_debug(100,message)
+        write(message,*) 'dy: ', config_flags%dy
+        CALL wrf_debug(100,message)
+        write(message,*) 'config_flags%start_year: ', config_flags%start_year
+        CALL wrf_debug(100,message)
+        write(message,*) 'config_flags%start_month: ', config_flags%start_month
+        CALL wrf_debug(100,message)
+        write(message,*) 'config_flags%start_day: ', config_flags%start_day
+        CALL wrf_debug(100,message)
+        write(message,*) 'config_flags%start_hour: ', config_flags%start_hour
+        CALL wrf_debug(100,message)
+
+        write(start_date,435) config_flags%start_year, config_flags%start_month, &
+                config_flags%start_day, config_flags%start_hour
+  435   format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':00:00')
+        
+        dlmd=config_flags%dx
+        dphd=config_flags%dy
+        tph0d=config_flags%cen_lat
+        tlm0d=config_flags%cen_lon
+
+!==========================================================================
+
+!!
+
+ !  Check to see if the boundary conditions are set 
+ !  properly in the namelist file.
+ !  This checks for sufficiency and redundancy.
+
+      CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
+
+      !  Some sort of "this is the first time" initialization.  Who knows.
+
+      grid%itimestep=0
+
+      !  Pull in the info in the namelist to compare it to the input data.
+
+      grid%real_data_init_type = model_config_rec%real_data_init_type
+      write(message,*) 'what is flag_metgrid: ', flag_metgrid
+      CALL wrf_message(message)
+
+     IF ( flag_metgrid .EQ. 1 ) THEN  !   <----- START OF VERTICAL INTERPOLATION PART ---->
+
+     num_metgrid_levels = grid%num_metgrid_levels
+
+	IF (ght_gc(its,jts,10) .lt. ght_gc(its,jts,11)) THEN
+
+           write(message,*) 'normal ground up file order'
+           hyb_coor=.false.
+           CALL wrf_message(message)
+
+        ELSE
+
+           hyb_coor=.true.
+           write(message,*) 'reverse the order of coordinate'
+           CALL wrf_message(message)
+
+           CALL reverse_vert_coord(ght_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+           CALL reverse_vert_coord(p_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+           CALL reverse_vert_coord(t_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+           CALL reverse_vert_coord(u_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+           CALL reverse_vert_coord(v_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+           CALL reverse_vert_coord(rh_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+        endif
+
+
+	IF (hyb_coor) THEN 
+                           ! limit extreme deviations from source model topography
+                           ! due to potential for nasty extrapolation/interpolation issues
+                           !
+          write(message,*) 'min, max of ht_gc before adjust: ', minval(ht_gc), maxval(ht_gc)
+          CALL wrf_debug(100,message)
+          ICOUNT=0
+          DO J=JTS,min(JTE,JDE-1)
+           DO I=ITS,min(ITE,IDE-1)
+             IF ((ht_gc(I,J) - ght_gc(I,J,2)) .LT. -150.) THEN
+               ht_gc(I,J)=ght_gc(I,J,2)-150.
+               IF (ICOUNT .LT. 20) THEN
+                 write(message,*) 'increasing NMM topo toward RUC  ', I,J
+                 CALL wrf_debug(100,message)
+                 ICOUNT=ICOUNT+1
+               ENDIF
+             ELSEIF ((ht_gc(I,J) - ght_gc(I,J,2)) .GT. 150.) THEN
+               ht_gc(I,J)=ght_gc(I,J,2)+150.
+               IF (ICOUNT .LT. 20) THEN
+                 write(message,*) 'decreasing NMM topo toward RUC ', I,J
+                 CALL wrf_debug(100,message)
+                 ICOUNT=ICOUNT+1
+               ENDIF
+             ENDIF
+           END DO
+          END DO
+
+          write(message,*) 'min, max of ht_gc after correct: ', minval(ht_gc), maxval(ht_gc)
+          CALL wrf_debug(100,message)
+        ENDIF
+
+      CALL boundary_smooth(ht_gc,landmask, grid, 12 , 12 &
+     &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                          IMS,IME,JMS,JME,KMS,KME             &
+     &,                          ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+           if (LANDMASK(I,J) .gt. 0.5) SM(I,J)=0.
+           if (LANDMASK(I,J) .le. 0.5) SM(I,J)=1.
+	if (tsk_gc(I,J) .gt. 0.) then
+	   NMM_TSK(I,J)=tsk_gc(I,J)
+        else
+           NMM_TSK(I,J)=t_gc(I,J,1) ! stopgap measure
+        endif
+!
+           GLAT(I,J)=hlat_gc(I,J)*DEGRAD
+           GLON(I,J)=hlon_gc(I,J)*DEGRAD
+           WEASD(I,J)=SNOW(I,J)
+           XICE(I,J)=XICE_gc(I,J)
+         ENDDO
+       ENDDO
+
+! First item is to define the target vertical coordinate
+
+     num_metgrid_levels = grid%num_metgrid_levels
+     eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
+     ptsgm             = model_config_rec%ptsgm
+     p_top_requested = grid%p_top_requested
+     pt=p_top_requested
+
+
+	if (internal_time_loop .eq. 1) then
+
+	write(message,*) 'KDE-1: ', KDE-1
+        CALL wrf_debug(1,message)
+	allocate(SG1(1:KDE-1))
+	allocate(SG2(1:KDE-1))
+	allocate(DSG1(1:KDE-1))
+	allocate(DSG2(1:KDE-1))
+	allocate(SGML1(1:KDE))
+	allocate(SGML2(1:KDE))
+
+      CALL define_nmm_vertical_coord (kde-1, ptsgm, pt,pdtop, eta_levels, &
+                                      ETA1,DETA1,AETA1,             &
+                                      ETA2,DETA2,AETA2, DFL, DFRLG         )
+
+       DO L=KDS,KDE-1
+        DETA(L)=eta_levels(L)-eta_levels(L+1)
+       ENDDO
+	endif
+
+        if (.NOT. allocated(PDVP))     allocate(PDVP(IMS:IME,JMS:JME))
+        if (.NOT. allocated(P3D_OUT))  allocate(P3D_OUT(IMS:IME,KDS:KDE-1,JMS:JME))
+        if (.NOT. allocated(PSFC_OUTV)) allocate(PSFC_OUTV(IMS:IME,JMS:JME))
+        if (.NOT. allocated(P3DV_OUT)) allocate(P3DV_OUT(IMS:IME,KDS:KDE-1,JMS:JME))
+        if (.NOT. allocated(P3DV_IN))  allocate(P3DV_IN(IMS:IME,JMS:JME,num_metgrid_levels))
+        
+	write(message,*) 'num_metgrid_levels: ', num_metgrid_levels
+        CALL wrf_message(message)
+
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+           FIS(I,J)=ht_gc(I,J)*g
+!
+!	IF ( p_gc(I,J,1) .ne. 200100. .AND.  (ht_gc(I,J) .eq. ght_gc(I,J,1)) .AND. ht_gc(I,J) .ne. 0) THEN
+	IF ( p_gc(I,J,1) .ne. 200100. .AND.  (abs(ht_gc(I,J)-ght_gc(I,J,1)) .lt. 0.01) .AND. ht_gc(I,J) .ne. 0) THEN
+	  IF (mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) THEN
+	    write(message,*) 'ht_gc and toposoil to swap, flag_soilhgt ::: ', &
+                          I,J, ht_gc(I,J),toposoil(I,J),flag_soilhgt
+            CALL wrf_debug(10,message)
+          ENDIF
+                IF ( ( flag_soilhgt.EQ. 1 ) ) THEN 
+                 ght_gc(I,J,1)=toposoil(I,J)
+                ENDIF
+        ENDIF
+
+         ENDDO
+       ENDDO
+
+      CALL compute_nmm_surfacep (ht_gc, ght_gc, p_gc , t_gc               &
+     &,                          psfc_out, num_metgrid_levels  &
+     &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                          IMS,IME,JMS,JME,KMS,KME             &
+     &,                          ITS,ITE,JTS,JTE,KTS,KTE ) ! H points
+
+	
+
+      CALL compute_3d_pressure (psfc_out,AETA1,AETA2   &
+     &,            pdtop,pt,pd,p3d_out                 &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+
+
+
+#ifdef DM_PARALLEL
+	ips=its ; ipe=ite ;  jps=jts ; jpe=jte ; kps=kts ; kpe=kte
+# include "HALO_NMM_MG2.inc"
+#endif
+
+     DO J=JMS,JME
+      DO K=1,num_metgrid_levels
+       DO I=IMS,IME
+         p_gc_xzy(I,K,J)=p_gc(I,J,K)
+       END DO
+      END DO
+     END DO
+
+#ifdef DM_PARALLEL
+# include "HALO_NMM_MG3.inc"
+#endif
+
+     DO J=JMS,JME
+      DO K=1,num_metgrid_levels
+       DO I=IMS,IME
+         p_gc(I,J,K)=p_gc_xzy(I,K,J)
+       END DO
+      END DO
+     END DO
+
+       do K=1,num_metgrid_levels
+	do J=JTS,min(JTE,JDE-1)
+         do I=ITS,min(ITE,IDE-1)
+
+         IF (K .eq. KTS) THEN
+           IF (J .eq. JDS .and. I .lt. IDE-1) THEN  ! S boundary
+             PDVP(I,J)=0.5*(PD(I,J)+PD(I+1,J))
+             PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J))
+           ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary
+             PDVP(I,J)=0.5*(PD(I,J)+PD(I+1,J))
+             PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J))
+           ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary
+             PDVP(I,J)=0.5*(PD(I,J-1)+PD(I,J+1))
+             PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J-1)+PSFC_OUT(I,J+1))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary
+             PDVP(I,J)=0.5*(PD(I,J-1)+PD(I,J+1))
+             PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J-1)+PSFC_OUT(I,J+1))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary
+             PDVP(I,J)=PD(I,J)
+             PSFC_OUTV(I,J)=PSFC_OUT(I,J)
+           ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
+             PDVP(I,J)=0.25*(PD(I,J)+PD(I-1,J)+PD(I,J+1)+PD(I,J-1))
+             PSFC_OUTV(I,J)=0.25*(PSFC_OUT(I,J)+PSFC_OUT(I-1,J)+ &
+                                  PSFC_OUT(I,J+1)+PSFC_OUT(I,J-1))
+           ELSE ! interior odd row
+             PDVP(I,J)=0.25*(PD(I,J)+PD(I+1,J)+PD(I,J+1)+PD(I,J-1))
+             PSFC_OUTV(I,J)=0.25*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J)+ &
+                                  PSFC_OUT(I,J+1)+PSFC_OUT(I,J-1))
+           ENDIF
+          ENDIF
+
+           IF (J .eq. JDS .and. I .lt. IDE-1) THEN  ! S boundary 
+             P3DV_IN(I,J,K)=0.5*(p_gc(I,J,K)+p_gc(I+1,J,K))
+           ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary
+             P3DV_IN(I,J,K)=0.5*(p_gc(I,J,K)+p_gc(I+1,J,K))
+           ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary
+             P3DV_IN(I,J,K)=0.5*(p_gc(I,J-1,K)+p_gc(I,J+1,K))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary
+             P3DV_IN(I,J,K)=0.5*(p_gc(I,J-1,K)+p_gc(I,J+1,K))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary
+             P3DV_IN(I,J,K)=p_gc(I,J,K)
+           ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
+             P3DV_IN(I,J,K)=0.25*(p_gc(I,J,K)+p_gc(I-1,J,K) + &
+                                  p_gc(I,J+1,K)+p_gc(I,J-1,K))
+           ELSE ! interior odd row
+             P3DV_IN(I,J,K)=0.25*(p_gc(I,J,K)+p_gc(I+1,J,K) + &
+                                  p_gc(I,J+1,K)+p_gc(I,J-1,K))
+           ENDIF
+
+
+         enddo
+        enddo
+       enddo
+
+      CALL compute_3d_pressure (psfc_outv,AETA1,AETA2   &
+     &,            pdtop,pt,pdvp,p3dv_out              &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+      
+      CALL interp_press2press_lin(p_gc, p3d_out        &
+     &,            t_gc, T,num_metgrid_levels          &
+     &,            .TRUE.,.TRUE.,.TRUE.               & ! extrap, ignore_lowest, t_field
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+
+
+      CALL interp_press2press_lin(p3dv_in, p3dv_out        &
+     &,            u_gc, U,num_metgrid_levels          &
+     &,            .FALSE.,.TRUE.,.FALSE.              &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+
+      CALL interp_press2press_lin(p3dv_in, p3dv_out        &
+     &,            V_gc, V,num_metgrid_levels          &
+     &,            .FALSE.,.TRUE.,.FALSE.              &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+
+       IF (hyb_coor) THEN
+       CALL wind_adjust(p3dv_in,p3dv_out,U_gc,V_gc,U,V  &
+     &,                 num_metgrid_levels,5000.        &
+     &,                 IDS,IDE,JDS,JDE,KDS,KDE           &
+     &,                 IMS,IME,JMS,JME,KMS,KME           &
+     &,                 ITS,ITE,JTS,JTE,KTS,KTE )
+       ENDIF
+         
+
+         ALLOCATE(qtmp(IMS:IME,num_metgrid_levels,JMS:JME))
+         ALLOCATE(qtmp2(IMS:IME,JMS:JME,num_metgrid_levels))
+
+            CALL rh_to_mxrat (rh_gc, t_gc, p_gc, qtmp , .TRUE. , &
+                        ids , ide , jds , jde , 1 , num_metgrid_levels , &
+                        ims , ime , jms , jme , 1 , num_metgrid_levels , &
+                        its , ite , jts , jte , 1 , num_metgrid_levels )
+
+       do K=1,num_metgrid_levels
+	do J=JTS,min(JTE,JDE-1)
+         do I=ITS,min(ITE,IDE-1)
+           QTMP2(I,J,K)=QTMP(I,K,J)/(1.0+QTMP(I,K,J))
+         end do
+        end do
+       end do
+
+      CALL interp_press2press_log(p_gc, p3d_out        &
+     &,            QTMP2, Q,num_metgrid_levels          &
+     &,            .FALSE.,.TRUE.                      &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE )
+
+      IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP)
+      IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2)
+
+         !  Get the monthly values interpolated to the current date 
+         !  for the traditional monthly
+         !  fields of green-ness fraction and background albedo.
+
+	if (internal_time_loop .eq. 1) then
+
+         CALL monthly_interp_to_date ( greenfrac_gc , current_date , vegfra , &
+                                       ids , ide , jds , jde , kds , kde , &
+                                       ims , ime , jms , jme , kms , kme , &
+                                       its , ite , jts , jte , kts , kte )
+
+         CALL monthly_interp_to_date ( albedo12m_gc , current_date , albbck , &
+                                       ids , ide , jds , jde , kds , kde , &
+                                       ims , ime , jms , jme , kms , kme , &
+                                       its , ite , jts , jte , kts , kte )
+
+         !  Get the min/max of each i,j for the monthly green-ness fraction.
+
+         CALL monthly_min_max ( greenfrac_gc , shdmin , shdmax , &
+                                ids , ide , jds , jde , kds , kde , &
+                                ims , ime , jms , jme , kms , kme , &
+                                its , ite , jts , jte , kts , kte )
+
+         !  The model expects the green-ness values in percent, not fraction.
+
+         DO j = jts, MIN(jte,jde-1)
+           DO i = its, MIN(ite,ide-1)
+!!              vegfra(i,j) = vegfra(i,j) * 100.
+              shdmax(i,j) = shdmax(i,j) * 100.
+              shdmin(i,j) = shdmin(i,j) * 100.
+              VEGFRC(I,J)=VEGFRA(I,J)
+           END DO
+         END DO
+
+         !  The model expects the albedo fields as 
+         !  a fraction, not a percent.  Set the water values to 8%.
+
+         DO j = jts, MIN(jte,jde-1)
+           DO i = its, MIN(ite,ide-1)
+              if (albbck(i,j) .lt. 5.) then
+                  write(message,*) 'reset albedo to 8%...  I,J,albbck:: ', I,J,albbck(I,J)
+                  CALL wrf_debug(10,message)
+                  albbck(I,J)=8.
+              endif
+              albbck(i,j) = albbck(i,j) / 100.
+              snoalb(i,j) = snoalb(i,j) / 100.
+              IF ( landmask(i,j) .LT. 0.5 ) THEN
+                 albbck(i,j) = 0.08
+                 snoalb(i,j) = 0.08
+              END IF
+              albase(i,j)=albbck(i,j)
+              mxsnal(i,j)=snoalb(i,j)
+           END DO
+         END DO
+
+         endif
+
+!  new deallocs
+        DEALLOCATE(p3d_out,p3dv_out,p3dv_in)
+
+     END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
+
+	if (internal_time_loop .eq. 1) then
+
+!!! WEASD has "snow water equivalent" in mm
+
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+
+      IF(SM(I,J).GT.0.9) THEN
+
+       IF (XICE(I,J) .gt. 0) then
+         SI(I,J)=1.0
+       ENDIF
+
+!  SEA
+              EPSR(I,J)=.97
+              GFFC(I,J)=0.
+              ALBEDO(I,J)=.06
+              ALBASE(I,J)=.06
+              IF(SI (I,J).GT.0.    ) THEN
+!  SEA-ICE
+                 SM(I,J)=0.
+                 SI(I,J)=0.
+                 SICE(I,J)=1.
+                 GFFC(I,J)=0. ! just leave zero as irrelevant
+                 ALBEDO(I,J)=.60
+                 ALBASE(I,J)=.60
+              ENDIF
+           ELSE
+
+        SI(I,J)=5.0*WEASD(I,J)/1000.
+!  LAND
+        EPSR(I,J)=1.0
+        GFFC(I,J)=0.0 ! just leave zero as irrelevant
+        SICE(I,J)=0.
+        SNO(I,J)=SI(I,J)*.20
+           ENDIF
+        ENDDO
+        ENDDO
+
+! DETERMINE ALBEDO OVER LAND
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+          IF(SM(I,J).LT.0.9.AND.SICE(I,J).LT.0.9) THEN
+! SNOWFREE ALBEDO
+            IF ( (SNO(I,J) .EQ. 0.0) .OR. &
+                (ALBASE(I,J) .GE. MXSNAL(I,J) ) ) THEN
+              ALBEDO(I,J) = ALBASE(I,J)
+            ELSE
+! MODIFY ALBEDO IF SNOWCOVER:
+! BELOW SNOWDEPTH THRESHOLD...
+              IF (SNO(I,J) .LT. SNUP) THEN
+                RSNOW = SNO(I,J)/SNUP
+                SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
+! ABOVE SNOWDEPTH THRESHOLD...
+              ELSE
+                SNOFAC = 1.0
+              ENDIF
+! CALCULATE ALBEDO ACCOUNTING FOR SNOWDEPTH AND VGFRCK
+              ALBEDO(I,J) = ALBASE(I,J) &
+               + (1.0-VEGFRA(I,J))*SNOFAC*(MXSNAL(I,J)-ALBASE(I,J))
+            ENDIF
+          END IF
+          SI(I,J)=5.0*WEASD(I,J)
+          SNO(I,J)=WEASD(I,J)
+
+!!  convert VEGFRA
+          VEGFRA(I,J)=VEGFRA(I,J)*100.
+!
+        ENDDO
+      ENDDO
+
+#ifdef DM_PARALLEL
+
+        ALLOCATE(SM_G(IDS:IDE,JDS:JDE),SICE_G(IDS:IDE,JDS:JDE))
+
+        CALL WRF_PATCH_TO_GLOBAL_REAL( SICE(IMS,JMS)           &
+     &,                                SICE_G,grid%DOMDESC         &
+     &,                               'z','xy'                       &
+     &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
+     &,                                IMS,IME,JMS,JME,1,1              &
+     &,                                ITS,ITE,JTS,JTE,1,1 )
+
+        CALL WRF_PATCH_TO_GLOBAL_REAL( SM(IMS,JMS)           &
+     &,                                SM_G,grid%DOMDESC         &
+     &,                               'z','xy'                       &
+     &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
+     &,                                IMS,IME,JMS,JME,1,1              &
+     &,                                ITS,ITE,JTS,JTE,1,1 )
+
+
+        IF (WRF_DM_ON_MONITOR()) THEN
+
+  637   format(40(f3.0,1x))
+
+        allocate(IHE_G(JDS:JDE-1),IHW_G(JDS:JDE-1))
+       DO j = JDS, JDE-1
+          IHE_G(J)=MOD(J+1,2)
+          IHW_G(J)=IHE_G(J)-1
+       ENDDO
+
+      DO ITER=1,10
+       DO j = jds+1, (jde-1)-1
+         DO i = ids+1, (ide-1)-1
+
+! any sea ice around point in question?
+
+        IF (SM_G(I,J) .ge. 0.9) THEN
+          SEAICESUM=SICE_G(I+IHE_G(J),J+1)+SICE_G(I+IHW_G(J),J+1)+ &
+                    SICE_G(I+IHE_G(J),J-1)+SICE_G(I+IHW_G(J),J-1)
+          IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
+
+            IF ((SICE_G(I+IHE_G(J),J+1).lt.0.1 .and. SM_G(I+IHE_G(J),J+1).lt.0.1) .OR. &
+                (SICE_G(I+IHW_G(J),J+1).lt.0.1 .and. SM_G(I+IHW_G(J),J+1).lt.0.1) .OR. &
+                (SICE_G(I+IHE_G(J),J-1).lt.0.1 .and. SM_G(I+IHE_G(J),J-1).lt.0.1) .OR. &
+                (SICE_G(I+IHW_G(J),J-1).lt.0.1 .and. SM_G(I+IHW_G(J),J-1).lt.0.1)) THEN
+
+!             HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
+
+              write(message,*) 'making seaice (1): ', I,J
+              CALL wrf_debug(100,message)
+              SICE_G(I,J)=1.0
+              SM_G(I,J)=0.
+
+            ENDIF
+
+          ELSEIF (SEAICESUM .ge. 3) THEN
+
+!           WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
+
+            write(message,*) 'making seaice (2): ', I,J
+            CALL wrf_debug(100,message)
+            SICE_G(I,J)=1.0
+            SM_G(I,J)=0.
+          ENDIF
+
+        ENDIF
+
+        ENDDO
+       ENDDO
+      ENDDO
+
+        ENDIF
+
+        CALL WRF_GLOBAL_TO_PATCH_REAL( SICE_G, SICE           &
+     &,                                grid%DOMDESC         &
+     &,                               'z','xy'                       &
+     &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
+     &,                                IMS,IME,JMS,JME,1,1              &
+     &,                                ITS,ITE,JTS,JTE,1,1 )
+
+        CALL WRF_GLOBAL_TO_PATCH_REAL( SM_G,SM           &
+     &,                                grid%DOMDESC         &
+     &,                               'z','xy'                       &
+     &,                                IDS,IDE-1,JDS,JDE-1,1,1          &
+     &,                                IMS,IME,JMS,JME,1,1              &
+     &,                                ITS,ITE,JTS,JTE,1,1 )
+
+        IF (WRF_DM_ON_MONITOR()) THEN
+
+        DEALLOCATE(SM_G,SICE_G)
+        DEALLOCATE(IHE_G,IHW_G)
+
+        ENDIF
+
+        write(message,*) 'revised sea ice on patch'
+        CALL wrf_debug(100,message)
+        DO J=JTE,JTS,-(((JTE-JTS)/25)+1)
+          write(message,637) (SICE(I,J),I=ITS,ITE,ITE/20)
+          CALL wrf_debug(100,message)
+        END DO
+
+#else
+! serial sea ice reprocessing
+
+       DO j = jts, MIN(jte,jde-1)
+          IHE(J)=MOD(J+1,2)
+          IHW(J)=IHE(J)-1
+       ENDDO
+
+      DO ITER=1,10
+       DO j = jts+1, MIN(jte,jde-1)-1
+         DO i = its+1, MIN(ite,ide-1)-1
+
+! any sea ice around point in question?
+
+        IF (SM(I,J) .gt. 0.9) THEN
+          SEAICESUM=SICE(I+IHE(J),J+1)+SICE(I+IHW(J),J+1)+ &
+                  SICE(I+IHE(J),J-1)+SICE(I+IHW(J),J-1)
+          IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
+            IF ((SICE(I+IHE(J),J+1).lt.0.1 .and. SM(I+IHE(J),J+1).lt.0.1) .OR. &
+                (SICE(I+IHW(J),J+1).lt.0.1 .and. SM(I+IHW(J),J+1).lt.0.1) .OR. &
+                (SICE(I+IHE(J),J-1).lt.0.1 .and. SM(I+IHE(J),J-1).lt.0.1) .OR. &
+                (SICE(I+IHW(J),J-1).lt.0.1 .and. SM(I+IHW(J),J-1).lt.0.1)) THEN
+
+!       HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
+              SICE(I,J)=1.0
+              SM(I,J)=0.
+            ENDIF
+          ELSEIF (SEAICESUM .ge. 3) THEN
+!       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
+        SICE(I,J)=1.0
+        SM(I,J)=0.
+          ENDIF
+        ENDIF
+
+        ENDDO
+       ENDDO
+      ENDDO
+
+#endif
+
+! this block meant to guarantee land/sea agreement between SM and landmask
+
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+
+          IF (SM(I,J) .gt. 0.5) THEN
+                landmask(I,J)=0.0
+          ELSEIF (SM(I,J) .lt. 0.5 .and. SICE(I,J) .gt. 0.9) then
+                landmask(I,J)=0.0
+          ELSEIF (SM(I,J) .lt. 0.5 .and. SICE(I,J) .lt. 0.1) then
+                landmask(I,J)=1.0
+          ELSE 
+                write(message,*) 'missed point in landmask definition ' , I,J
+                CALL wrf_message(message)
+                landmask(I,J)=0.0
+          ENDIF
+!
+	IF (SICE(I,J) .gt. 0.5 .and. NMM_TSK(I,J) .lt. 0.1 .and. SST(I,J) .gt. 0.) THEN
+           write(message,*) 'set NMM_TSK to: ', SST(I,J)
+           CALL wrf_message(message)
+           NMM_TSK(I,J)=SST(I,J)
+           SST(I,J)=0.
+        endif
+
+        ENDDO
+      ENDDO
+
+      !  For sf_surface_physics = 1, we want to use close to a 10 cm value
+      !  for the bottom level of the soil temps.
+
+      IF      ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .AND. &
+                ( flag_st000010 .EQ. 1 ) ) THEN
+         DO j = jts , MIN(jde-1,jte)
+            DO i = its , MIN(ide-1,ite)
+               soiltb(i,j) = st000010(i,j)
+            END DO
+         END DO
+      END IF
+
+  !  Adjust the various soil temperature values depending on the difference in
+  !  in elevation between the current model's elevation and the incoming data's
+  !  orography.
+
+      IF ( ( flag_toposoil .EQ. 1 ) ) THEN 
+
+        ALLOCATE(HT(ims:ime,jms:jme))
+
+        DO J=jms,jme
+          DO I=ims,ime
+              HT(I,J)=FIS(I,J)/9.81
+          END DO
+        END DO
+           
+!       if (maxval(toposoil) .gt. 100.) then
+!
+!  Being avoided.   Something to revisit eventually.
+!
+!1219 might be simply a matter of including TOPOSOIL 
+!
+!    CODE NOT TESTED AT NCEP USING THIS FUNCTIONALITY, 
+!    SO TO BE SAFE WILL AVOID FOR RETRO RUNS.
+!
+!        CALL adjust_soil_temp_new ( soiltb , 2 , &
+!                       nmm_tsk , ht , toposoil , landmask, flag_toposoil , &
+!                       st000010 , st010040 , st040100 , st100200 , st010200 , &
+!                       flag_st000010 , flag_st010040 , flag_st040100 , &
+!                       flag_st100200 , flag_st010200 , &
+!                       soilt000 , soilt005 , soilt020 , soilt040 , &
+!                       soilt160 , soilt300 , &
+!                       flag_soilt000 , flag_soilt005 , flag_soilt020 , &
+!                       flag_soilt040 , flag_soilt160 , flag_soilt300 , &
+!                       ids , ide , jds , jde , kds , kde , &
+!                       ims , ime , jms , jme , kms , kme , &
+!                       its , ite , jts , jte , kts , kte )
+!       endif
+
+      END IF
+
+      !  Process the LSM data.
+   
+      !  surface_input_source=1 => use data from static file 
+      !                            (fractional category as input)
+      !  surface_input_source=2 => use data from grib file 
+      !                            (dominant category as input)
+
+      IF ( config_flags%surface_input_source .EQ. 1 ) THEN
+         vegcat (its,jts) = 0
+         soilcat(its,jts) = 0
+      END IF
+
+      !  Generate the vegetation and soil category information 
+      !  from the fractional input
+      !  data, or use the existing dominant category fields if they exist.
+
+      IF ((soilcat(its,jts) .LT. 0.5) .AND. (vegcat(its,jts) .LT. 0.5)) THEN
+
+         num_veg_cat      = SIZE ( landusef_gc , DIM=3 )
+         num_soil_top_cat = SIZE ( soilctop_gc , DIM=3 )
+         num_soil_bot_cat = SIZE ( soilcbot_gc , DIM=3 )
+
+        do J=JMS,JME
+        do K=1,num_veg_cat
+        do I=IMS,IME
+           landusef(I,K,J)=landusef_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+        do J=JMS,JME
+        do K=1,num_soil_top_cat
+        do I=IMS,IME
+           soilctop(I,K,J)=soilctop_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+        do J=JMS,JME
+        do K=1,num_soil_bot_cat
+        do I=IMS,IME
+           soilcbot(I,K,J)=soilcbot_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+!       sm (1=water, 0=land)
+!       landmask(0=water, 1=land)
+
+
+	write(message,*) 'landmask into process_percent_cat_new'
+
+        CALL wrf_debug(1,message)
+	do J=JTE,JTS,-(((JTE-JTS)/20)+1)
+	write(message,641) (landmask(I,J),I=ITS,min(ITE,IDE-1),((ITE-ITS)/15)+1)
+        CALL wrf_debug(1,message)
+        enddo
+  641	format(25(f3.0,1x))
+
+         CALL process_percent_cat_new ( landmask , &
+                         landusef , soilctop , soilcbot , &
+                         isltyp , ivgtyp , &
+                         num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
+                         ids , ide , jds , jde , kds , kde , &
+                         ims , ime , jms , jme , kms , kme , &
+                         its , ite , jts , jte , kts , kte , &
+                         model_config_rec%iswater(grid%id) )
+
+         DO j = jts , MIN(jde-1,jte)
+            DO i = its , MIN(ide-1,ite)
+               vegcat(i,j)  = ivgtyp(i,j)
+               soilcat(i,j) = isltyp(i,j)
+            END DO
+         END DO
+
+       ELSE
+
+         !  Do we have dominant soil and veg data from the input already?
+
+         IF ( soilcat(its,jts) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  isltyp(i,j) = NINT( soilcat(i,j) )
+               END DO
+            END DO
+         END IF
+         IF ( vegcat(its,jts) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  ivgtyp(i,j) = NINT( vegcat(i,j) )
+               END DO
+            END DO
+         END IF
+
+       ENDIF
+
+        DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        IF (SICE(I,J) .lt. 0.1) THEN
+          IF (landmask(I,J) .gt. 0.5 .and. sm(I,J) .gt. 0.5) THEN
+                write(message,*) 'land mask and SM both > 0.5: ', &
+                                           I,J,landmask(I,J),sm(I,J)
+                CALL wrf_message(message)
+                SM(I,J)=0.
+          ELSEIF (landmask(I,J) .lt. 0.5 .and. sm(I,J) .lt. 0.5) THEN
+                write(message,*) 'land mask and SM both < 0.5: ', &
+                                           I,J, landmask(I,J),sm(I,J)
+                CALL wrf_message(message)
+                SM(I,J)=1.
+          ENDIF
+        ELSE
+          IF (landmask(I,J) .gt. 0.5 .and. SM(I,J)+SICE(I,J) .gt. 0.9) then
+            write(message,*) 'landmask says LAND, SM/SICE say SEAICE: ', I,J
+          ENDIF
+        ENDIF
+
+           ENDDO
+        ENDDO
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        if (SICE(I,J) .gt. 0.9) then
+        ISLTYP(I,J)=16
+        IVGTYP(I,J)=24
+        endif
+
+            ENDDO
+         ENDDO
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        if (SM(I,J) .lt. 0.5) then
+            SST(I,J)=0.
+        endif
+
+        if (SM(I,J) .gt. 0.5) then
+          if (SST(I,J) .lt. 0.1) then
+            SST(I,J)=NMM_TSK(I,J)
+          endif
+            NMM_TSK(I,J)=0.
+        endif
+
+                
+        IF ( (NMM_TSK(I,J)+SST(I,J)) .lt. 200. .or. &
+             (NMM_TSK(I,J)+SST(I,J)) .gt. 350. ) THEN
+          write(message,*) 'TSK, SST trouble at : ', I,J
+          CALL wrf_message(message)
+          write(message,*) 'SM, NMM_TSK,SST ', SM(I,J),NMM_TSK(I,J),SST(I,J)
+          CALL wrf_message(message)
+        ENDIF
+
+            ENDDO
+         ENDDO
+
+        write(message,*) 'SM'
+        CALL wrf_message(message)
+
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (sm(i,J),I=its,ite,((ite-its)/10)+1)
+          CALL wrf_message(message)
+        END DO
+
+        write(message,*) 'SST/NMM_TSK'
+        CALL wrf_debug(10,message)
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (SST(I,J)+NMM_TSK(I,J),I=ITS,min(ide-1,ite),((ite-its)/10)+1)
+          CALL wrf_debug(10,message)
+        END DO
+
+  635   format(20(f5.1,1x))
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+               IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
+                  soiltb(i,j) = sst(i,j)
+               ELSE IF (  landmask(i,j) .GT. 0.5 ) THEN
+                  soiltb(i,j) = nmm_tsk(i,j)
+               END IF
+            END DO
+         END DO
+
+!      END IF
+
+   !  Land use categories, dominant soil and vegetation types (if available).
+
+!       allocate(lu_index(ims:ime,jms:jme))
+   
+          DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+               lu_index(i,j) = ivgtyp(i,j)
+            END DO
+          END DO
+
+        if (flag_sst .eq. 1) log_flag_sst=.true.
+        if (flag_sst .eq. 0) log_flag_sst=.false.
+
+	write(message,*) 'st_input dimensions: ', size(st_input,dim=1), & 
+                                  size(st_input,dim=2),size(st_input,dim=3)
+        CALL wrf_debug(100,message)
+
+        write(message,*) 'maxval st_input(1): ', maxval(st_input(:,1,:))
+          CALL wrf_message(message)
+        write(message,*) 'maxval st_input(2): ', maxval(st_input(:,2,:))
+          CALL wrf_message(message)
+        write(message,*) 'maxval st_input(3): ', maxval(st_input(:,3,:))
+          CALL wrf_message(message)
+        write(message,*) 'maxval st_input(4): ', maxval(st_input(:,4,:))
+          CALL wrf_message(message)
+
+! =============================================================
+
+   IF (.NOT. ALLOCATED(TG_ALT))ALLOCATE(TG_ALT(grid%sm31:grid%em31,jms:jme))
+
+      TPH0=TPH0D*DTR
+      WBD=-(((ide-1)-1)*DLMD)
+      WB= WBD*DTR
+      SBD=-(((jde-1)/2)*DPHD)
+      SB= SBD*DTR
+      DLM=DLMD*DTR
+      DPH=DPHD*DTR
+      TDLM=DLM+DLM
+      TDPH=DPH+DPH
+      WBI=WB+TDLM
+      SBI=SB+TDPH
+      EBI=WB+(ide-2)*TDLM
+      ANBI=SB+(jde-2)*DPH
+      STPH0=SIN(TPH0)
+      CTPH0=COS(TPH0)
+      TSPH=3600./GRID%DT
+
+         DO J=JTS,min(JTE,JDE-1)
+           TLM=WB-TDLM+MOD(J,2)*DLM   !For velocity points on the E grid
+           TPH=SB+float(J-1)*DPH
+           STPH=SIN(TPH)
+           CTPH=COS(TPH)
+           DO I=ITS,MIN(ITE,IDE-1)
+
+        if (I .eq. ITS) THEN
+             TLM=TLM+TDLM*ITS
+        else
+             TLM=TLM+TDLM
+        endif
+
+             TERM1=(STPH0*CTPH*COS(TLM)+CTPH0*STPH)
+             FP=TWOM*(TERM1)
+             F(I,J)=0.5*GRID%DT*FP
+           ENDDO
+         ENDDO
+
+         DO J=JTS,min(JTE,JDE-1)
+           TLM=WB-TDLM+MOD(J+1,2)*DLM   !For mass points on the E grid
+           TPH=SB+float(J-1)*DPH
+           STPH=SIN(TPH)
+           CTPH=COS(TPH)
+           DO I=ITS,MIN(ITE,IDE-1)
+
+        if (I .eq. ITS) THEN
+             TLM=TLM+TDLM*ITS
+        else
+             TLM=TLM+TDLM
+        endif
+
+             TERM1=(STPH0*CTPH*COS(TLM)+CTPH0*STPH)
+             APH=ASIN(TERM1)
+             TG_ALT(I,J)=TG0+TGA*COS(APH)-FIS(I,J)/3333.
+           ENDDO
+         ENDDO
+
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+!                  IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
+!                         SICE(I,J) .eq. 0. ) THEN
+!                     TG(i,j) = sst(i,j)
+!                   ELSEIF (SICE(I,J) .eq. 1) THEN
+!                     TG(i,j) = 271.16
+!                   END IF
+
+        if (TG(I,J) .lt. 200.) then   ! only use default TG_ALT definition if
+                                      ! not getting TGROUND from SI
+                TG(I,J)=TG_ALT(I,J)
+        endif
+
+       if (TG(I,J) .lt. 200. .or. TG(I,J) .gt. 320.) then
+               write(message,*) 'problematic TG point at : ', I,J
+               CALL wrf_message( message )
+       endif
+
+        adum2d(i,j)=nmm_tsk(I,J)+sst(I,J)
+
+               END DO
+            END DO
+
+        DEALLOCATE(TG_ALT)
+	
+	write(message,*) 'call process_soil_real with num_st_levels_input: ',  num_st_levels_input
+        CALL wrf_message( message )
+
+! =============================================================
+
+  CALL process_soil_real ( adum2d, TG , &
+     landmask, sst, &
+     st_input, sm_input, sw_input, &
+     st_levels_input , sm_levels_input , &
+     sw_levels_input , &
+     sldpth , dzsoil , stc , smc , sh2o,  &
+     flag_sst , flag_soilt000, flag_soilm000, &
+     ids , ide , jds , jde , kds , kde , &
+     ims , ime , jms , jme , kms , kme , &
+     its , ite , jts , jte , kts , kte , &
+     model_config_rec%sf_surface_physics(grid%id) , &
+     model_config_rec%num_soil_layers ,  &
+     model_config_rec%real_data_init_type , &
+     num_st_levels_input , num_sm_levels_input , &
+     num_sw_levels_input , &
+     num_st_levels_alloc , num_sm_levels_alloc , &
+     num_sw_levels_alloc )
+
+! =============================================================
+
+!  Minimum soil values, residual, from RUC LSM scheme.  
+!  For input from Noah and using
+!  RUC LSM scheme, this must be subtracted from the input 
+!  total soil moisture.  For  input RUC data and using the Noah LSM scheme,
+!  this value must be added to the soil moisture_input.
+
+       lqmi(1:num_soil_top_cat) = &
+       (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10,     &
+         0.089, 0.095, 0.10,  0.070, 0.068, 0.078, 0.0,      &
+         0.004, 0.065 /) !dusan , 0.020, 0.004, 0.008 /)
+
+!  At the initial time we care about values of soil moisture and temperature,
+!  other times are ignored by the model, so we ignore them, too.
+
+          account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+             CASE ( LSMSCHEME , NMMLSMSCHEME)
+                iicount = 0
+                IF      ( FLAG_SM000010 .EQ. 1 ) THEN
+                   DO j = jts, MIN(jde-1,jte)
+                      DO i = its, MIN(ide-1,ite)
+                         IF ((landmask(i,j).gt.0.5) .and. (stc(i,1,j) .gt. 200) .and. &
+                            (stc(i,1,j) .lt. 400) .and. (smc(i,1,j) .lt. 0.005)) then
+                            write(message,*) 'Noah > Noah: bad soil moisture at i,j = ',i,j,smc(i,:,j)
+                            CALL wrf_message(message)
+                            iicount = iicount + 1
+                            smc(i,:,j) = 0.005
+                         END IF
+                      END DO
+                   END DO
+                   IF ( iicount .GT. 0 ) THEN
+                   write(message,*) 'Noah -> Noah: total number of small soil moisture locations= ',&
+                                                                                        iicount
+                   CALL wrf_message(message)
+                   END iF
+                ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN
+                   DO j = jts, MIN(jde-1,jte)
+                      DO i = its, MIN(ide-1,ite)
+                         smc(i,:,j) = smc(i,:,j) + lqmi(isltyp(i,j))
+                      END DO
+                   END DO
+                   DO j = jts, MIN(jde-1,jte)
+                      DO i = its, MIN(ide-1,ite)
+                         IF ((landmask(i,j).gt.0.5) .and. (stc(i,1,j) .gt. 200) .and. &
+                            (stc(i,1,j) .lt. 400) .and. (smc(i,1,j) .lt. 0.004)) then
+                            write(message,*) 'RUC -> Noah: bad soil moisture at i,j = ' &
+                                                                     ,i,j,smc(i,:,j)
+                            CALL wrf_message(message)
+                            iicount = iicount + 1
+                            smc(i,:,j) = 0.004
+                         END IF
+                      END DO
+                   END DO
+                   IF ( iicount .GT. 0 ) THEN
+                   write(message,*) 'RUC -> Noah: total number of small soil moisture locations = ',&
+                                                                                       iicount
+                   CALL wrf_message(message)
+                   END IF
+                END IF 
+               CASE ( RUCLSMSCHEME )
+                iicount = 0
+                IF      ( FLAG_SM000010 .EQ. 1 ) THEN
+                   DO j = jts, MIN(jde-1,jte)
+                      DO i = its, MIN(ide-1,ite)
+                         smc(i,:,j) = MAX ( smc(i,:,j) - lqmi(isltyp(i,j)) , 0. )
+                      END DO
+                   END DO
+                ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN
+                   ! no op
+                END IF
+
+          END SELECT account_for_zero_soil_moisture
+
+!!!     zero out NMM_TSK at water points again
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+        if (SM(I,J) .gt. 0.5) then
+            NMM_TSK(I,J)=0.
+        endif
+            END DO
+         END DO
+
+!!      check on STC
+
+          DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        IF (SICE(I,J) .gt. 0.9) then
+          DO L = 1, grid%num_soil_layers
+            STC(I,L,J)=271.16    ! TG value used by Eta/NMM
+          END DO
+        END IF
+
+        IF (SM(I,J) .gt. 0.9) then
+          DO L = 1, grid%num_soil_layers
+            STC(I,L,J)=273.16    ! TG value used by Eta/NMM
+          END DO
+        END IF
+                
+            END DO
+          END DO
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        IF (SM(I,J) .lt. 0.1 .and. STC(I,1,J) .lt. 0.1) THEN
+          write(message,*) 'troublesome SM,STC,SMC value: ', I,J,SM(I,J), stc(I,1,J),smc(I,1,J)
+          CALL wrf_message(message)
+        do JJ=J-1,J+1
+        do L=1, grid%num_soil_layers
+        do II=I-1,I+1
+
+	if (II .ge. its .and. II .le. MIN(ide-1,ite) .and. &
+            JJ .ge. jts .and. JJ .le. MIN(jde-1,jte)) then
+
+        STC(I,L,J)=amax1(STC(I,L,J),STC(II,L,JJ))
+        cur_smc=SMC(I,L,J)
+
+        if ( SMC(II,L,JJ) .gt. 0.005 .and. SMC(II,L,JJ) .lt. 1.0) then 
+		aposs_smc=SMC(II,L,JJ)
+
+        if ( cur_smc .eq. 0 ) then
+                cur_smc=aposs_smc
+                SMC(I,L,J)=cur_smc
+        else
+                cur_smc=amin1(cur_smc,aposs_smc)
+                cur_smc=amin1(cur_smc,aposs_smc)
+                SMC(I,L,J)=cur_smc
+        endif
+	endif
+
+	endif ! bounds check
+
+        enddo
+        enddo
+        enddo
+        write(message,*) 'STC, SMC(1) now: ',  stc(I,1,J),smc(I,1,J)
+        CALL wrf_message(message)
+        endif
+
+        if (STC(I,1,J) .lt. 0.1) then
+          write(message,*) 'QUITTING DUE TO STILL troublesome STC value: ', I,J, stc(I,1,J),smc(I,1,J)
+          call wrf_error_fatal(message)
+        endif
+
+        ENDDO
+        ENDDO
+
+!hardwire soil stuff for time being
+
+        RTDPTH=0.
+        RTDPTH(1)=0.1
+        RTDPTH(2)=0.3
+        RTDPTH(3)=0.6
+
+        SLDPTH=0.
+        SLDPTH(1)=0.1
+        SLDPTH(2)=0.3
+        SLDPTH(3)=0.6
+        SLDPTH(4)=1.0
+
+!!! main body of nmm_specific starts here
+!
+        do J=jts,min(jte,jde-1)
+        do I=its,min(ite,ide-1)
+         LMH(I,J)= kme-1        !1
+         LMV(I,J)= kme-1        !1
+         RES(I,J)=1.
+        enddo
+        enddo
+
+!! HBM2
+
+        HBM2=0.
+
+       do J=jts,min(jte,jde-1)
+        do I=its,min(ite,ide-1)
+
+        IF ( (J .ge. 3 .and. J .le. (jde-1)-2) .AND. &
+             (I .ge. 2 .and. I .le. (ide-1)-2+mod(J,2)) ) THEN
+       HBM2(I,J)=1.
+        ENDIF
+       enddo
+       enddo
+
+!! HBM3
+        HBM3=0.
+
+!!      LOOP OVER LOCAL DIMENSIONS
+
+       do J=jts,min(jte,jde-1)
+          IHWG(J)=mod(J+1,2)-1
+          IF (J .ge. 4 .and. J .le. (jde-1)-3) THEN
+            IHL=(ids+1)-IHWG(J)
+            IHH=(ide-1)-2
+            do I=its,min(ite,ide-1)
+              IF (I .ge. IHL  .and. I .le. IHH) HBM3(I,J)=1.
+            enddo
+          ENDIF
+        enddo
+
+!! VBM2
+
+       VBM2=0.
+
+       do J=jts,min(jte,jde-1)
+       do I=its,min(ite,ide-1)
+
+        IF ( (J .ge. 3 .and. J .le. (jde-1)-2)  .AND.  &
+             (I .ge. 2 .and. I .le. (ide-1)-1-mod(J,2)) ) THEN
+
+           VBM2(I,J)=1.
+
+        ENDIF
+
+       enddo
+       enddo
+
+!! VBM3
+
+        VBM3=0.
+
+       do J=jts,min(jte,jde-1)
+       do I=its,min(ite,ide-1)
+
+        IF ( (J .ge. 4 .and. J .le. (jde-1)-3)  .AND.  &
+             (I .ge. 3-mod(J,2) .and. I .le. (ide-1)-2) ) THEN
+         VBM3(I,J)=1.
+        ENDIF
+
+       enddo
+       enddo
+
+      DTAD=1.0
+!       IDTCF=DTCF, IDTCF=4
+      DTCF=4.0 ! used?
+
+      DY_NMM=ERAD*DPH
+      CPGFV=-GRID%DT/(48.*DY_NMM)
+      EN= GRID%DT/( 4.*DY_NMM)*DTAD
+      ENT=GRID%DT/(16.*DY_NMM)*DTAD
+
+        DO J=jts,nnyp
+         KHL2(J)=(IDE-1)*(J-1)-(J-1)/2+2
+         KVL2(J)=(IDE-1)*(J-1)-J/2+2
+         KHH2(J)=(IDE-1)*J-J/2-1
+         KVH2(J)=(IDE-1)*J-(J+1)/2-1
+        ENDDO
+
+        TPH=SB-DPH
+
+        DO J=jts,min(jte,jde-1)
+         TPH=SB+float(J-1)*DPH
+         DXP=ERAD*DLM*COS(TPH)
+         DXJ(J)=DXP
+         WPDARJ(J)=-W_NMM * &
+     ((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM**2)/ &
+                   (GRID%DT*32.*DXP*DY_NMM)
+
+         CPGFUJ(J)=-GRID%DT/(48.*DXP)
+         CURVJ(J)=.5*GRID%DT*TAN(TPH)/ERAD
+         FCPJ(J)=GRID%DT/(CP*192.*DXP*DY_NMM)
+         FDIVJ(J)=1./(12.*DXP*DY_NMM)
+!         EMJ(J)= GRID%DT/( 4.*DXP)*DTAD
+!         EMTJ(J)=GRID%DT/(16.*DXP)*DTAD
+         FADJ(J)=-GRID%DT/(48.*DXP*DY_NMM)*DTAD
+         ACDT=GRID%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM**2)
+         CDDAMP=CODAMP*ACDT
+         HDACJ(J)=COAC*ACDT/(4.*DXP*DY_NMM)
+         DDMPUJ(J)=CDDAMP/DXP
+         DDMPVJ(J)=CDDAMP/DY_NMM
+        ENDDO
+
+          DO J=JTS,min(JTE,JDE-1)
+           TLM=WB-TDLM+MOD(J,2)*DLM
+           TPH=SB+float(J-1)*DPH
+           STPH=SIN(TPH)
+           CTPH=COS(TPH)
+           DO I=ITS,MIN(ITE,IDE-1)
+
+        if (I .eq. ITS) THEN
+             TLM=TLM+TDLM*ITS
+        else
+             TLM=TLM+TDLM
+        endif
+
+             FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM))
+             F(I,J)=0.5*GRID%DT*FP
+
+           ENDDO
+          ENDDO
+
+! --------------DERIVED VERTICAL GRID CONSTANTS--------------------------
+
+      EF4T=.5*GRID%DT/CP
+      F4Q =   -GRID%DT*DTAD
+      F4D =-.5*GRID%DT*DTAD
+
+       DO L=KDS,KDE-1
+        RDETA(L)=1./DETA(L)
+        F4Q2(L)=-.25*GRID%DT*DTAD/DETA(L)
+       ENDDO
+
+        DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+          DX_NMM(I,J)=DXJ(J)
+          WPDAR(I,J)=WPDARJ(J)*HBM2(I,J)
+          CPGFU(I,J)=CPGFUJ(J)*VBM2(I,J)
+          CURV(I,J)=CURVJ(J)*VBM2(I,J)
+          FCP(I,J)=FCPJ(J)*HBM2(I,J)
+          FDIV(I,J)=FDIVJ(J)*HBM2(I,J)
+          FAD(I,J)=FADJ(J)
+          HDACV(I,J)=HDACJ(J)*VBM2(I,J)
+          HDAC(I,J)=HDACJ(J)*1.25*HBM2(I,J)
+        ENDDO
+        ENDDO
+
+        DO J=JTS, MIN(JDE-1,JTE)
+
+        IF (J.LE.5.OR.J.GE.(JDE-1)-4) THEN
+
+               KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have
+               DO I=ITS,MIN(IDE-1,ITE)
+                 IF (I .ge. 2 .and. I .le. KHH) THEN
+                   HDAC(I,J)=HDAC(I,J)* DFC
+                 ENDIF
+               ENDDO
+
+        ELSE
+
+          KHH=2+MOD(J,2)
+               DO I=ITS,MIN(IDE-1,ITE)
+                 IF (I .ge. 2 .and. I .le. KHH) THEN
+                    HDAC(I,J)=HDAC(I,J)* DFC
+                 ENDIF
+               ENDDO
+
+          KHH=(IDE-1)-2+MOD(J,2)
+
+               DO I=ITS,MIN(IDE-1,ITE)
+                 IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN
+                   HDAC(I,J)=HDAC(I,J)* DFC
+                 ENDIF
+               ENDDO
+        ENDIF
+      ENDDO
+
+      DO J=JTS,min(JTE,JDE-1)
+      DO I=ITS,min(ITE,IDE-1)
+        DDMPU(I,J)=DDMPUJ(J)*VBM2(I,J)
+        DDMPV(I,J)=DDMPVJ(J)*VBM2(I,J)
+        HDACV(I,J)=HDACV(I,J)*VBM2(I,J)
+      ENDDO
+      ENDDO
+! --------------INCREASING DIFFUSION ALONG THE BOUNDARIES----------------
+
+        DO J=JTS,MIN(JDE-1,JTE)
+        IF (J.LE.5.OR.J.GE.JDE-1-4) THEN
+          KVH=(IDE-1)-1-MOD(J,2)
+          DO I=ITS,min(IDE-1,ITE)
+            IF (I .ge. 2 .and.  I .le. KVH) THEN
+             DDMPU(I,J)=DDMPU(I,J)*DDFC
+             DDMPV(I,J)=DDMPV(I,J)*DDFC
+             HDACV(I,J)=HDACV(I,J)* DFC
+            ENDIF
+          ENDDO
+        ELSE
+          KVH=3-MOD(J,2)
+          DO I=ITS,min(IDE-1,ITE)
+           IF (I .ge. 2 .and.  I .le. KVH) THEN
+            DDMPU(I,J)=DDMPU(I,J)*DDFC
+            DDMPV(I,J)=DDMPV(I,J)*DDFC
+            HDACV(I,J)=HDACV(I,J)* DFC
+           ENDIF
+          ENDDO
+          KVH=(IDE-1)-1-MOD(J,2)
+          DO I=ITS,min(IDE-1,ITE)
+           IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN
+            DDMPU(I,J)=DDMPU(I,J)*DDFC
+            DDMPV(I,J)=DDMPV(I,J)*DDFC
+            HDACV(I,J)=HDACV(I,J)* DFC
+           ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+
+        write(message,*) 'STC(1)'
+        CALL wrf_message(message)
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (stc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1)
+          CALL wrf_message(message)
+        ENDDO
+
+        write(message,*) 'SMC(1)'
+        CALL wrf_message(message)
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (smc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1)
+          CALL wrf_message(message)
+        ENDDO
+
+          DO j = jts, MIN(jde-1,jte)
+          DO i=  ITS, MIN(IDE-1,ITE)
+
+          if (SM(I,J) .lt. 0.1 .and. SMC(I,1,J) .gt. 0.5 .and. SICE(I,J) .lt. 0.1) then
+            write(message,*) 'very moist on land point: ', I,J,SMC(I,1,J)
+            CALL wrf_debug(10,message)
+          endif
+
+          enddo
+        enddo
+
+!!!   compute EMT, EM on global domain, and only on task 0.
+
+#ifdef DM_PARALLEL
+        IF (wrf_dm_on_monitor()) THEN   !!!! NECESSARY TO LIMIT THIS TO TASK ZERO?
+#else
+        IF (JDS .eq. JTS) THEN !! set unfailable condition for serial job
+#endif
+
+        ALLOCATE(EMJ(JDS:JDE-1),EMTJ(JDS:JDE-1))
+
+        DO J=JDS,JDE-1
+         TPH=SB+float(J-1)*DPH
+         DXP=ERAD*DLM*COS(TPH)
+         EMJ(J)= GRID%DT/( 4.*DXP)*DTAD
+         EMTJ(J)=GRID%DT/(16.*DXP)*DTAD
+        ENDDO
+        
+          JA=0
+          DO 161 J=3,5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 161      EMT(JA)=EMTJ(J)
+          DO 162 J=(JDE-1)-4,(JDE-1)-2
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 162      EMT(JA)=EMTJ(J)
+          DO 163 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=2+MOD(J,2)
+ 163      EMT(JA)=EMTJ(J)
+          DO 164 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=(IDE-1)-2
+          KHHA(JA)=(IDE-1)-1-MOD(J+1,2)
+ 164      EMT(JA)=EMTJ(J)
+
+! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR----
+
+      JA=0
+              DO 171 J=3,5
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 171      EM(JA)=EMJ(J)
+              DO 172 J=(JDE-1)-4,(JDE-1)-2
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 172      EM(JA)=EMJ(J)
+              DO 173 J=6,(JDE-1)-5
+          JA=JA+1
+          KVLA(JA)=2
+          KVHA(JA)=2+MOD(J+1,2)
+ 173      EM(JA)=EMJ(J)
+              DO 174 J=6,(JDE-1)-5
+          JA=JA+1
+          KVLA(JA)=(IDE-1)-2
+          KVHA(JA)=(IDE-1)-1-MOD(J,2)
+ 174      EM(JA)=EMJ(J)
+
+   696  continue
+
+        ENDIF ! wrf_dm_on_monitor/serial job
+
+      call NMM_SH2O(IMS,IME,JMS,JME,ITS,NNXP,JTS,NNYP,4,ISLTYP, &
+                             SM,SICE,STC,SMC,SH2O)
+
+!! must be a better place to put this, but will eliminate "phantom"
+!! wind points here (no wind point on eastern boundary of odd numbered rows)
+
+        IF (   abs(IDE-1-ITE) .eq. 1 ) THEN ! along eastern boundary
+          write(message,*) 'zero phantom winds'
+          CALL wrf_message(message)
+          DO K=1,KDE-1
+            DO J=JDS,JDE-1,2
+              IF (J .ge. JTS .and. J .le. JTE) THEN
+                u(IDE-1,K,J)=0.
+                v(IDE-1,K,J)=0.
+              ENDIF
+            ENDDO
+          ENDDO 
+        ENDIF
+
+  969   continue
+
+         DO j = jms, jme
+            DO i = ims, ime
+             fisx=max(fis(i,j),0.)
+             Z0(I,J)    =SM(I,J)*Z0SEA+(1.-SM(I,J))*                      &
+     &                (0.*Z0MAX+FISx    *FCM+Z0LAND)
+            ENDDO
+          ENDDO
+
+        write(message,*) 'Z0 over memory, leaving module_initialize_real'
+        CALL wrf_message(message)
+        DO J=JME,JMS,-((JME-JMS)/20+1)
+          write(message,635) (Z0(I,J),I=IMS,IME,(IME-IMS)/14+1)
+          CALL wrf_message(message)
+        ENDDO
+
+
+	endif ! on first_time check
+
+        write(message,*) 'leaving init_domain_nmm'
+        CALL wrf_message( TRIM(message) )
+      
+
+       write(message,*)'STUFF MOVED TO REGISTRY:',grid%IDTAD,          &
+     & grid%NSOIL,grid%NRADL,grid%NRADS,grid%NPHS,grid%NCNVC,grid%sigma
+       CALL wrf_message( TRIM(message) )
+!==================================================================================
+
+#define COPY_OUT
+#include 
+      RETURN
+
+   END SUBROUTINE init_domain_nmm
+
+!------------------------------------------------------
+
+
+  SUBROUTINE define_nmm_vertical_coord ( LM, PTSGM, PT, PDTOP,HYBLEVS, &
+                                         SG1,DSG1,SGML1,         &
+                                         SG2,DSG2,SGML2,DFL, DFRLG            )
+
+        IMPLICIT NONE
+
+!        USE module_model_constants
+
+!!! certain physical parameters here probably don't need to be defined, as defined
+!!! elsewhere within WRF.  Done for initial testing purposes.
+
+        INTEGER ::  LM, LPT2, L
+        REAL    ::  PTSGM, PT, PL, PT2, PDTOP
+        REAL    ::  RGOG, PSIG,PHYB,PHYBM
+        REAL, PARAMETER  :: Rd           =  287.04  ! J deg{-1} kg{-1}
+        REAL, PARAMETER :: CP=1004.6,GAMMA=.0065,PRF0=101325.,T0=288.
+        REAL, PARAMETER :: g=9.81
+
+        REAL, DIMENSION(LM)   :: DSG,DSG1,DSG2
+        REAL, DIMENSION(LM)   :: SGML1,SGML2
+        REAL, DIMENSION(LM+1) :: SG1,SG2,HYBLEVS,DFL,DFRLG
+
+        CHARACTER(LEN=132)    :: message
+
+        LPT2=LM+1
+
+        write(message,*) 'pt= ', pt
+        CALL wrf_message(message)
+
+        DO L=LM+1,1,-1
+          pl=HYBLEVS(L)*(101325.-pt)+pt
+          if(pl.lt.ptSGm) LPT2=l
+        ENDDO
+
+      IF(LPT2.lt.LM+1) THEN
+        pt2=HYBLEVS(LPT2)*(101325.-pt)+pt
+      ELSE
+        pt2=pt
+      ENDIF
+
+      write(message,*) '*** Sigma system starts at ',pt2,' Pa, from level ',LPT2
+      CALL wrf_message(message)
+
+      pdtop=pt2-pt
+
+        write(message,*) 'allocating DSG,DSG1,DSG2 as ', LM
+        CALL wrf_debug(10,message)
+
+        DSG=-99.
+
+      DO L=1,LM
+        DSG(L)=HYBLEVS(L)- HYBLEVS(L+1)
+      ENDDO
+
+        DSG1=0.
+        DSG2=0.
+
+      DO L=LM,1,-1
+
+       IF(L.ge.LPT2) then
+        DSG1(L)=DSG(L)
+       ELSE
+        DSG2(L)=DSG(L)
+       ENDIF
+
+      ENDDO
+
+        SGML1=-99.
+        SGML2=-99.
+
+       IF(LPT2.le.LM+1) THEN
+
+        DO L=LM+1,LPT2,-1
+        SG2(L)=0.
+        ENDDO
+
+       DO L=LPT2,2,-1
+        SG2(L-1)=SG2(L)+DSG2(L-1)
+       ENDDO
+
+        DO L=LPT2-1,1,-1
+        SG2(L)=SG2(L)/SG2(1)
+        ENDDO
+        SG2(1)=1.
+
+       DO L=LPT2-1,1,-1
+        DSG2(L)=SG2(L)-SG2(L+1)
+        SGML2(l)=(SG2(l)+SG2(l+1))*0.5
+       ENDDO
+
+      ENDIF
+
+      DO L=LM,LPT2,-1
+        DSG2(L)=0.
+        SGML2(L)=0.
+      ENDDO
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+        SG1(LM+1)=0.
+
+      DO L=LM+1,LPT2,-1
+       SG1(L-1)=SG1(L)+DSG1(L-1)
+      ENDDO
+
+      DO L=LM,LPT2,-1
+       SG1(L)=SG1(L)/SG1(LPT2-1)
+      ENDDO
+
+        SG1(LPT2-1)=1.
+
+       do l=LPT2-2,1,-1
+        SG1(l)=1.
+       enddo
+
+
+      DO L=LM,LPT2,-1
+       DSG1(L)=SG1(L)-SG1(L+1)
+       SGML1(L)=(SG1(L)+SG1(L+1))*0.5
+      ENDDO
+
+      DO L=LPT2-1,1,-1
+               DSG1(L)=0.
+               SGML1(L)=1.
+      ENDDO
+
+ 1000 format('l,hyblevs,psig,SG1,SG2,phyb,phybm')
+ 1100 format(' ',i4,f7.4,f10.2,2f7.4,2f10.2)
+
+      write(message,1000)
+      CALL wrf_debug(100,message)
+
+      do l=1,LM+1
+        psig=HYBLEVS(L)*(101325.-pt)+pt
+        phyb=SG1(l)*pdtop+SG2(l)*(101325.-pdtop-pt)+pt
+        if(l.lt.LM+1) then
+          phybm=SGML1(l)*pdtop+SGML2(l)*(101325.-pdtop-pt)+pt
+        else
+          phybm=-99.
+        endif
+
+        write(message,1100) l,HYBLEVS(L),psig &
+                      ,SG1(l),SG2(l),phyb,phybm
+        CALL wrf_debug(100,message)
+      enddo
+
+
+  632   format(f9.6)
+
+       write(message,*) 'SG1'
+       CALL wrf_debug(100,message)
+       do L=LM+1,1,-1
+       write(message,632) SG1(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+       write(message,*) 'SG2'
+       CALL wrf_debug(100,message)
+       do L=LM+1,1,-1
+       write(message,632) SG2(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+       write(message,*) 'DSG1'
+       CALL wrf_debug(100,message)
+       do L=LM,1,-1
+       write(message,632) DSG1(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+       write(message,*) 'DSG2'
+       CALL wrf_debug(100,message)
+       do L=LM,1,-1
+       write(message,632) DSG2(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+       write(message,*) 'SGML1'
+       CALL wrf_debug(100,message)
+       do L=LM,1,-1
+       write(message,632) SGML1(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+       write(message,*) 'SGML2'
+       CALL wrf_debug(100,message)
+       do L=LM,1,-1
+       write(message,632) SGML2(L)
+       CALL wrf_debug(100,message)
+       enddo
+
+      rgog=(rd*gamma)/g
+      DO L=1,LM+1
+        DFL(L)=g*T0*(1.-((pt+SG1(L)*pdtop+SG2(L)*(101325.-pt2)) &
+                       /101325.)**rgog)/gamma
+        DFRLG(L)=DFL(L)/g
+       write(message,*) 'L, DFL(L): ', L, DFL(L)
+       CALL wrf_debug(100,message)
+      ENDDO
+
+  END SUBROUTINE define_nmm_vertical_coord
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE compute_nmm_surfacep ( TERRAIN_HGT_T, Z3D_IN, PRESS3D_IN, T3D_IN   &
+     &,                             psfc_out,generic           & 
+     &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                             IMS,IME,JMS,JME,KMS,KME             &
+     &,                             ITS,ITE,JTS,JTE,KTS,KTE  )
+
+	
+       IMPLICIT NONE
+
+       real, allocatable:: dum2d(:,:),DUM2DB(:,:)
+       
+       integer :: IDS,IDE,JDS,JDE,KDS,KDE
+       integer :: IMS,IME,JMS,JME,KMS,KME
+       integer :: ITS,ITE,JTS,JTE,KTS,KTE,Ilook,Jlook
+       integer :: I,J,II,generic,L,KINSERT,K,bot_lev,LL
+       integer :: IHE(JMS:JME),IHW(JMS:JME), loopinc,iloopinc
+	
+       real :: TERRAIN_HGT_T(IMS:IME,JMS:JME)
+       real :: Z3D_IN(IMS:IME,JMS:JME,generic)
+       real :: T3D_IN(IMS:IME,JMS:JME,generic)
+       real :: PRESS3D_IN(IMS:IME,JMS:JME,generic)
+       real :: PSFC_IN(IMS:IME,JMS:JME),TOPO_IN(IMS:IME,JMS:JME)
+       real :: psfc_out(IMS:IME,JMS:JME),rincr(IMS:IME,JMS:JME)
+       real :: dif1,dif2,dif3,dif4,dlnpdz,BOT_INPUT_HGT,BOT_INPUT_PRESS,dpdz,rhs
+       real :: zin(generic),pin(generic)
+
+       character (len=256) :: message
+	
+       logical :: DEFINED_PSFC(IMS:IME,JMS:JME), DEFINED_PSFCB(IMS:IME,JMS:JME)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+	Ilook=25
+        Jlook=25
+
+       DO j = JMS, JME
+          IHE(J)=MOD(J+1,2)
+          IHW(J)=IHE(J)-1
+       ENDDO
+
+       DO J=JMS,JME
+       DO I=IMS,IME
+          DEFINED_PSFC(I,J)=.FALSE.
+          DEFINED_PSFCB(I,J)=.FALSE.
+        IF (PRESS3D_IN(I,J,1) .ne. 200100.) THEN
+          PSFC_IN(I,J)=PRESS3D_IN(I,J,1)
+          TOPO_IN(I,J)=Z3D_IN(I,J,1)
+        ELSE
+          PSFC_IN(I,J)=PRESS3D_IN(I,J,2)
+          TOPO_IN(I,J)=Z3D_IN(I,J,2)
+        ENDIF
+       ENDDO
+       ENDDO
+
+! input surface pressure smoothing over the ocean - still needed for NAM?
+
+        II_loop: do II=1,8
+
+        CYCLE II_loop
+
+	do J=JTS+1,min(JTE,JDE-1)-1
+         do I=ITS+1,min(ITE,IDE-1)-1
+         rincr(I,J)=0.
+
+       if (PSFC_IN(I,J) .gt. 100000.          .and. &
+           PSFC_IN(I+IHE(J),J+1) .gt. 100000. .and. &
+           PSFC_IN(I+IHE(J),J-1) .gt. 100000. .and. &
+           PSFC_IN(I+IHW(J),J+1) .gt. 100000. .and. &
+           PSFC_IN(I+IHW(J),J-1) .gt. 100000. ) then
+
+       dif1=abs(PSFC_IN(I,J)-PSFC_IN(I+IHE(J),J+1))
+       dif2=abs(PSFC_IN(I,J)-PSFC_IN(I+IHE(J),J-1))
+       dif3=abs(PSFC_IN(I,J)-PSFC_IN(I+IHW(J),J+1))
+       dif4=abs(PSFC_IN(I,J)-PSFC_IN(I+IHW(J),J-1))
+
+        if (max(dif1,dif2,dif3,dif4) .lt. 200. .and. TOPO_IN(I,J).le. 0.5 .and. &
+            TOPO_IN(I+IHE(J),J+1) .le. 0.5 .and. &
+            TOPO_IN(I+IHW(J),J+1) .le. 0.5 .and. &
+            TOPO_IN(I+IHE(J),J-1) .le. 0.5 .and. &
+            TOPO_IN(I+IHW(J),J-1) .lt. 0.5) then
+
+        rincr(I,J)=0.125*( 4.*PSFC_IN(I,J)+ &
+                            PSFC_IN(I+IHE(J),J+1)+PSFC_IN(I+IHE(J),J-1)+ &
+                            PSFC_IN(I+IHW(J),J+1)+PSFC_IN(I+IHW(J),J-1) ) &
+                          - PSFC_IN(I,J)
+
+!        if (rincr(I,J) .ne. 0 .and. abs(rincr(I,J)) .gt. 20.) then
+!          write(message,*) 'II, I,J,rincr: ', II, I,J,rincr(I,J)
+!          CALL wrf_message(message) 
+!        endif
+
+         endif
+         endif
+
+        ENDDO
+        ENDDO
+
+       DO J=JTS+1,min(JTE,JDE-1)-1
+         DO I=ITS+1,min(ITE,IDE-1)-1
+           PSFC_IN(I,J)=PSFC_IN(I,J) + rincr(I,J)
+         ENDDO
+       ENDDO
+
+!        write(message,*) ' -------------------------------------------------- '
+!        CALL wrf_message(message)
+
+         end do II_loop
+
+       ALLOCATE(DUM2D(IMS:IME,JMS:JME))
+     
+       DO J=JMS,JME
+        DO I=IMS,IME
+         DUM2D(I,J)=-9.
+        END DO
+       END DO
+
+       DO J=JTS,min(JTE,JDE-1)
+        I_loop: DO I=ITS,min(ITE,IDE-1)
+
+         IF (PSFC_IN(I,J) .lt. 0.1) THEN
+           write(message,*) 'QUITTING BECAUSE I,J, PSFC_IN: ', I,J,PSFC_IN(I,J)
+           call wrf_error_fatal(message)
+         ENDIF
+
+         BOT_INPUT_PRESS=PSFC_IN(I,J)
+         BOT_INPUT_HGT=TOPO_IN(I,J)
+
+         IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
+
+	   write(message,*) ' TERRAIN_HGT_T: ', I,J, TERRAIN_HGT_T(I,J)
+           CALL wrf_message(message)
+	   write(message,*) ' PSFC_IN, TOPO_IN: ', &
+                            I, J, PSFC_IN(I,J),TOPO_IN(I,J)
+           CALL wrf_message(message)
+
+           DO L=1,generic
+	     write(message,*) ' L,PRESS3D_IN, Z3D_IN: ', &
+                             I,J,L, PRESS3D_IN(I,J,L),Z3D_IN(I,J,L)
+             CALL wrf_debug(10,message)
+           END DO
+         ENDIF
+
+       DO L=2,generic-1
+
+         IF ( PRESS3D_IN(i,j,L) .gt. PSFC_IN(I,J) .AND.  &
+             Z3D_IN(I,J,L) .lt. TERRAIN_HGT_T(I,J) .AND. &
+             Z3D_IN(I,J,L+1) .gt. TERRAIN_HGT_T(I,J) ) THEN
+
+           BOT_INPUT_PRESS=PRESS3D_IN(i,j,L)
+           BOT_INPUT_HGT=Z3D_IN(I,J,L)
+
+!           IF (I .eq. Ilook .and. J .eq. Jlook) THEN
+!             write(message,*) 'BOT_INPUT_PRESS, BOT_INPUT_HGT NOW : ', &
+!                         Ilook,Jlook, BOT_INPUT_PRESS, BOT_INPUT_HGT
+!             CALL wrf_message(message)
+!           ENDIF
+
+          ENDIF 
+       END DO	
+
+!!!!!!!!!!!!!!!!!!!!!! START HYDRO CHECK
+
+       IF ( PRESS3D_IN(i,j,1) .ne. 200100. .AND. &
+          (PSFC_IN(I,J) .gt. PRESS3D_IN(i,j,2) .OR. &
+           TOPO_IN(I,J) .lt. Z3D_IN(I,J,2)) ) THEN        ! extrapolate downward
+
+         IF (J .eq. JTS .AND. I .eq. ITS) THEN
+            write(message,*) 'hydro check - should only be for isobaric input'
+            CALL wrf_message(message)
+         ENDIF
+
+	 IF (Z3D_IN(I,J,2) .ne. TOPO_IN(I,J)) THEN
+           dpdz=(PRESS3D_IN(i,j,2)-PSFC_IN(I,J))/(Z3D_IN(I,J,2)-TOPO_IN(I,J))
+           rhs=-9.81*((PRESS3D_IN(i,j,2)+ PSFC_IN(I,J))/2.)/(287.04* T3D_IN(I,J,2))
+
+	   IF ( abs(PRESS3D_IN(i,j,2)-PSFC_IN(I,J)) .gt. 290.) THEN
+             IF (dpdz .lt. 1.05*rhs .OR. dpdz .gt. 0.95*rhs) THEN
+                write(message,*) 'I,J,P(2),Psfc,Z(2),Zsfc: ', &
+                    I,J,PRESS3D_IN(i,j,2),PSFC_IN(I,J),Z3D_IN(I,J,2),TOPO_IN(I,J)
+               IF (mod(I,5).eq.0 .AND. mod(J,5).eq.0) CALL wrf_debug(50,message)
+	      CYCLE I_loop
+             ENDIF 
+
+           ENDIF 
+
+         ELSE ! z(2) equals TOPO_IN
+
+	  IF (PRESS3D_IN(i,j,2) .eq. PSFC_IN(I,J)) THEN
+!	    write(message,*) 'all equal at I,J: ', I,J
+!           CALL wrf_message(message)
+          ELSE
+!           write(message,*) 'heights equal, pressures not: ', &
+!                           PRESS3D_IN(i,j,2), PSFC_IN(I,J)
+!           CALL wrf_message(message)
+	    CYCLE I_loop
+	  ENDIF
+
+         ENDIF
+       
+         IF ( abs(PRESS3D_IN(i,j,2)-PSFC_IN(I,J)) .gt. 290.) THEN
+           IF (PRESS3D_IN(i,j,2) .lt. PSFC_IN(I,J) .and. &
+                          Z3D_IN(I,J,2) .lt. TOPO_IN(I,J)) THEN
+!            write(message,*) 'surface data mismatch(a) at I,J: ', I,J
+!            CALL wrf_message(message)
+	     CYCLE I_loop
+           ELSEIF (PRESS3D_IN(i,j,2) .gt. PSFC_IN(I,J) .AND.  &
+                  Z3D_IN(I,J,2) .gt. TOPO_IN(I,J)) THEN
+!             write(message,*) 'surface data mismatch(b) at I,J: ', I,J
+!             CALL wrf_message(message)
+             CYCLE I_loop
+           ENDIF
+         ENDIF 
+       ENDIF
+
+!!!!!!! loop over a few more levels
+
+        DO L=3,6
+          IF ( PRESS3D_IN(i,j,1) .ne. 200100. .AND. &
+             (((PSFC_IN(I,J)-PRESS3D_IN(i,j,L)) .lt. 400.) .OR. &
+               TOPO_IN(I,J) .lt. Z3D_IN(I,J,L))) then
+                 
+	    IF (Z3D_IN(I,J,L) .ne. TOPO_IN(I,J)) THEN
+              dpdz=(PRESS3D_IN(i,j,L)-PSFC_IN(I,J))/ &
+                   (Z3D_IN(I,J,L)-TOPO_IN(I,J))
+              rhs=-9.81*((PRESS3D_IN(i,j,L)+ PSFC_IN(I,J))/2.)/ &
+                        (287.04*T3D_IN(I,J,L))
+              IF ( abs(PRESS3D_IN(i,j,L)-PSFC_IN(I,J)) .gt. 290.) THEN
+                IF (dpdz .lt. 1.05*rhs .or. dpdz .gt. 0.95*rhs) THEN
+                  write(message,*) 'I,J,L,Piso,Psfc,Ziso,Zsfc: ', &
+                                    I,J,L,PRESS3D_IN(i,j,L),PSFC_IN(I,J),&
+                                    Z3D_IN(I,J,L),TOPO_IN(I,J)
+                  IF (mod(I,5).eq.0 .AND. mod(J,5).eq.0) &
+                                               CALL wrf_debug(50,message)
+	          CYCLE I_loop
+                ENDIF 
+              ENDIF
+            ELSE
+	      IF (PRESS3D_IN(i,j,2) .eq. PSFC_IN(I,J)) THEN
+!	        write(message,*) 'all equal at I,J: ', I,J
+!               CALL wrf_message(message)
+              ELSE 
+	        CYCLE I_loop
+              ENDIF
+            ENDIF
+          ENDIF
+
+	  IF ( abs(PRESS3D_IN(i,j,L)-PSFC_IN(I,J)) .gt. 290.) THEN
+            IF (PRESS3D_IN(i,j,L) .lt. PSFC_IN(I,J) .AND. &
+                    Z3D_IN(I,J,L) .lt. TOPO_IN(I,J)) THEN
+              CYCLE I_loop
+            ELSEIF (PRESS3D_IN(i,j,L) .gt. PSFC_IN(I,J) .AND.  &
+                    Z3D_IN(I,J,L) .gt. TOPO_IN(I,J)) THEN
+             CYCLE I_loop
+            ENDIF 
+          ENDIF 
+        END DO
+!!!!!!!!!!!!!!!!!!!!!! END HYDRO CHECK
+
+        IF (TERRAIN_HGT_T(I,J) .eq. BOT_INPUT_HGT ) THEN
+           dum2d(I,J)=BOT_INPUT_PRESS
+
+	  IF (BOT_INPUT_HGT .ne. 0. .and. (BOT_INPUT_HGT-INT(BOT_INPUT_HGT) .ne. 0.) ) THEN
+	    write(message,*) 'with BOT_INPUT_HGT: ', BOT_INPUT_HGT, &
+                             'set dum2d to bot_input_pres: ', I,J,dum2d(I,J)
+            CALL wrf_message(message)
+          ENDIF
+
+          IF (dum2d(I,J) .lt. 50000. .OR. dum2d(I,J) .gt. 109000.) THEN
+            write(message,*) 'bad dum2d(a): ', I,J,DUM2D(I,J)
+            CALL wrf_message(message)
+          ENDIF
+
+        ELSEIF (TERRAIN_HGT_T(I,J) .lt. BOT_INPUT_HGT ) THEN
+
+!         target is below lowest possible input...extrapolate
+
+          IF ( BOT_INPUT_PRESS-PRESS3D_IN(I,J,2) .gt. 500. ) THEN
+            dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,2)) ) / &
+                     (BOT_INPUT_HGT-Z3D_IN(i,j,2))
+            IF (I .eq. Ilook .and. J .eq. Jlook) THEN
+              write(message,*) 'I,J,dlnpdz(a): ', I,J,dlnpdz
+              CALL wrf_message(message)
+            ENDIF
+
+          ELSE
+
+!! thin layer and/or just have lowest level - difference with 3rd level data
+            IF ( abs(BOT_INPUT_PRESS - PRESS3D_IN(i,j,3)) .gt. 290. ) THEN
+
+              dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,3)) ) / &
+                      (BOT_INPUT_HGT-Z3D_IN(i,j,3))
+
+              IF (I .eq. Ilook .and. J .eq. Jlook) then
+               write(message,*) 'p diff: ', BOT_INPUT_PRESS, PRESS3D_IN(i,j,3)
+               CALL wrf_message(message)
+               write(message,*) 'z diff: ', BOT_INPUT_HGT, Z3D_IN(i,j,3)
+               CALL wrf_message(message)
+              ENDIF
+	
+            ELSE
+
+!! Loop up to level 7 looking for a sufficiently thick layer
+
+              FIND_THICK:  DO LL=4,7
+               IF( abs(BOT_INPUT_PRESS - PRESS3D_IN(i,j,LL)) .gt. 290.) THEN
+                 dlnpdz= (log(BOT_INPUT_PRESS)-log(PRESS3D_IN(i,j,LL)) ) / &
+                   (BOT_INPUT_HGT-Z3D_IN(i,j,LL))
+                EXIT FIND_THICK
+               ENDIF 
+              END DO FIND_THICK
+
+            ENDIF
+        
+          ENDIF
+
+        dum2d(I,J)= exp(log(BOT_INPUT_PRESS) + dlnpdz * &
+                        (TERRAIN_HGT_T(I,J) - BOT_INPUT_HGT) )
+
+         IF (dum2d(I,J) .lt. 57000. .or. dum2d(I,J) .gt. 108000.) THEN
+           write(message,*) 'bad dum2d(b): ', I,J,DUM2D(I,J)
+           CALL wrf_message(message)
+           write(message,*) 'BOT_INPUT_PRESS, dlnpdz, TERRAIN_HGT_T, BOT_INPUT_HGT: ', &
+                BOT_INPUT_PRESS, dlnpdz, TERRAIN_HGT_T(I,J), BOT_INPUT_HGT
+           CALL wrf_message(message)
+           write(message,*) 'Z3D_IN: ', Z3D_IN(I,J,1:10)
+           CALL wrf_message(message)
+           write(message,*) 'PRESS3D_IN: ', PRESS3D_IN(I,J,1:10)
+           CALL wrf_message(message)
+         ENDIF 
+
+        ELSE ! target level bounded by input levels
+
+          DO L=2,generic-1
+            IF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,L) .AND. &
+                  TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,L+1) ) THEN
+               dlnpdz= (log(PRESS3D_IN(i,j,l))-log(PRESS3D_IN(i,j,L+1)) ) / &
+                       (Z3D_IN(i,j,l)-Z3D_IN(i,j,L+1))
+               dum2d(I,J)= log(PRESS3D_IN(i,j,l)) +   &
+                           dlnpdz * (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,L) )
+               dum2d(i,j)=exp(dum2d(i,j))
+               IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
+                 write(message,*) 'bad dum2d(c): ', I,J,DUM2D(I,J)
+                 CALL wrf_message(message)
+               ENDIF
+            ENDIF
+          ENDDO
+
+!!! account for situation where BOT_INPUT_HGT < TERRAIN_HGT_T < Z3D_IN(:,2,:)
+          IF (dum2d(I,J) .eq. -9 .AND. BOT_INPUT_HGT .lt. TERRAIN_HGT_T(I,J) &
+              .AND. TERRAIN_HGT_T(I,J) .lt. Z3D_IN(I,J,2)) then
+
+            IF (mod(I,50) .eq. 0 .AND. mod(J,50) .eq. 0) THEN
+              write(message,*) 'I,J,BOT_INPUT_HGT, bot_pres, TERRAIN_HGT_T: ',  &
+                 I,J,BOT_INPUT_HGT, BOT_INPUT_PRESS, TERRAIN_HGT_T(I,J)
+              CALL wrf_message(message)
+            ENDIF
+
+            dlnpdz= (log(PSFC_IN(i,j))-log(PRESS3D_IN(i,j,2)) ) / &
+                    (TOPO_IN(i,j)-Z3D_IN(i,j,2))
+            dum2d(I,J)= log(PSFC_IN(i,j)) +   &
+                        dlnpdz * (TERRAIN_HGT_T(I,J) - TOPO_IN(i,j) )
+            dum2d(i,j)= exp(dum2d(i,j))
+            IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN
+              write(message,*) 'bad dum2d(d): ', I,J,DUM2D(I,J)
+              CALL wrf_message(message)
+            ENDIF
+          ENDIF
+
+          IF (dum2d(I,J) .eq. -9.) THEN
+            write(message,*) 'must have flukey situation in new ', I,J
+            CALL wrf_message(message)
+            write(message,*) 'I,J,BOT_INPUT_HGT, bot_pres, TERRAIN_HGT_T: ',  &
+                       I,J,BOT_INPUT_HGT, BOT_INPUT_PRESS, TERRAIN_HGT_T(I,J)
+            CALL wrf_message(message)
+
+            DO L=1,generic-1
+              IF ( TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,L) ) THEN
+! problematic with HGT_M substitution for "input" surface height?
+                dum2d(i,j)=PRESS3D_IN(I,J,L)
+                IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 110000.) THEN
+                  write(message,*) 'bad dum2d(e): ', I,J,DUM2D(I,J)
+                  CALL wrf_message(message)
+                ENDIF
+              ENDIF
+            ENDDO
+
+            IF ( TERRAIN_HGT_T(I,J) .eq. TOPO_IN(I,J)) THEN
+              dum2d(I,J)=PSFC_IN(I,J)
+              IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 110000.) THEN
+                write(message,*) 'bad dum2d(f): ', I,J,DUM2D(I,J)
+                CALL wrf_message(message)
+              ENDIF
+             write(message,*) 'matched input topo, psfc: ', I,J,TOPO_IN(I,J),PSFC_IN(I,J)
+             CALL wrf_message(message)
+            ENDIF
+
+            IF (dum2d(I,J) .eq. -9.) THEN
+              CALL wrf_error_fatal("quitting due to undefined surface pressure")
+            ENDIF 
+          ENDIF
+
+          DEFINED_PSFC(I,J)=.TRUE.
+
+	  IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
+	    write(message,*) 'newstyle psfc: ', I,J,dum2d(I,J)
+            CALL wrf_message(message)
+          ENDIF
+
+        ENDIF 
+
+        ENDDO I_loop
+        ENDDO
+
+        write(message,*) 'psfc points (new style)'
+        CALL wrf_message(message)
+	loopinc=max( (JTE-JTS)/20,1)
+	iloopinc=max( (ITE-ITS)/10,1)
+
+        DO J=min(JTE,JDE-1),JTS,-loopinc
+          write(message,633) (dum2d(I,J)/100.,I=ITS,min(ITE,IDE-1),iloopinc)
+        END DO
+
+  633   format(35(f5.0,1x))
+
+        write(message,*) 'PSFC extremes (new style)'
+        CALL wrf_message(message)
+        write(message,*) minval(dum2d,MASK=DEFINED_PSFC),maxval(dum2d,MASK=DEFINED_PSFC)
+        CALL wrf_message(message)
+
+        IF (minval(dum2d,MASK=DEFINED_PSFC) .lt. 50000. .or. maxval(dum2d,MASK=DEFINED_PSFC) .gt. 110000.) THEN
+	  CALL wrf_error_fatal("quit due to crazy surface pressure")
+        ENDIF
+
+!! "traditional" isobaric only approach ------------------------------------------------
+
+       ALLOCATE (DUM2DB(IMS:IME,JMS:JME))
+       DO J=JMS,JME
+        DO I=IMS,IME
+         DUM2DB(I,J)=-9.
+        END DO
+       END DO
+
+       DO J=JTS,min(JTE,JDE-1)
+       DO I=ITS,min(ITE,IDE-1)
+
+        IF (TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,2)) THEN ! targ below lowest
+
+          IF ( abs(PRESS3D_IN(i,j,2)-PRESS3D_IN(i,j,3)) .gt. 290.) THEN
+            dlnpdz= (log(PRESS3D_IN(i,j,2))-log(PRESS3D_IN(i,j,3)) ) / &
+                    (Z3D_IN(i,j,2)-Z3D_IN(i,j,3))
+          ELSE
+            dlnpdz= (log(PRESS3D_IN(i,j,2))-log(PRESS3D_IN(i,j,4)) ) / &
+                    (Z3D_IN(i,j,2)-Z3D_IN(i,j,4))
+          ENDIF
+
+          DUM2DB(I,J)= exp( log(PRESS3D_IN(i,j,2)) + dlnpdz * &
+                           (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,2)) )
+
+	  IF (I .eq. Ilook .and. J .eq. Jlook) THEN
+	    write(message,*) 'I,K, trad: dlnpdz, press_in(2), terrain_t, Z3D_IN(2): ', I,J,dlnpdz, &
+                             PRESS3D_IN(i,j,2), TERRAIN_HGT_T(I,J), Z3D_IN(i,j,2)
+            CALL wrf_message(message)
+          ENDIF
+
+          DEFINED_PSFCB(i,j)=.true.
+
+        ELSEIF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,2)) THEN ! target level bounded by input levels
+
+        DO L=2,generic-1
+          IF (TERRAIN_HGT_T(I,J) .gt. Z3D_IN(i,j,L) .AND. &
+              TERRAIN_HGT_T(I,J) .lt. Z3D_IN(i,j,L+1) ) THEN
+
+            dlnpdz= (log(PRESS3D_IN(i,j,l))-log(PRESS3D_IN(i,j,L+1)) ) / &
+                    (Z3D_IN(i,j,l)-Z3D_IN(i,j,L+1))
+
+            DUM2DB(I,J)= log(PRESS3D_IN(i,j,l)) +   &
+                         dlnpdz * (TERRAIN_HGT_T(I,J) - Z3D_IN(i,j,L) )
+            DUM2DB(i,j)=exp(DUM2DB(i,j))
+
+	    DEFINED_PSFCB(i,j)=.true.
+
+            IF (DUM2DB(I,J) .lt. 13000.) THEN
+              write(message,*) 'I,J,L,terrain,Z3d(L),z3d(L+1),p3d(L),p3d(l+1): ', I,J,L, &
+                                TERRAIN_HGT_T(I,J),Z3D_IN(I,J,L),Z3D_IN(I,J,L+1),PRESS3D_IN(I,J,L), &
+                                PRESS3D_IN(I,J,L+1)
+              CALL wrf_error_fatal(message)
+            ENDIF
+          ENDIF
+        ENDDO
+
+        ELSEIF (TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,2)) THEN
+          DUM2DB(i,j)=PRESS3D_IN(I,J,2)
+	  DEFINED_PSFCB(i,j)=.true.
+        ENDIF
+
+        IF (DUM2DB(I,J) .eq. -9.) THEN
+          write(message,*) 'must have flukey situation in trad ', I,J
+          CALL wrf_message(message)
+          DO L=1,generic-1
+            IF ( TERRAIN_HGT_T(I,J) .eq. Z3D_IN(i,j,L) ) THEN
+              DUM2DB(i,j)=PRESS3D_IN(I,J,L)
+              DEFINED_PSFCB(i,j)=.true.
+            ENDIF
+          ENDDO
+        ENDIF
+
+        IF (DUM2DB(I,J) .eq. -9.) THEN
+          write(message,*) 'HOPELESS PSFC, I QUIT'
+          CALL wrf_error_fatal(message) 
+        ENDIF
+
+	if (I .eq. Ilook .and. J .eq. Jlook) THEN
+	  write(message,*) ' traditional psfc: ', I,J,DUM2DB(I,J)
+          CALL wrf_message(message) 
+        ENDIF
+
+       ENDDO
+       ENDDO
+
+       write(message,*) 'psfc points (traditional)'
+       CALL wrf_message(message)
+       DO J=min(JTE,JDE-1),JTS,-loopinc
+         write(message,633) (DUM2DB(I,J)/100.,I=its,min(ite,IDE-1),iloopinc)
+         CALL wrf_message(message)
+       ENDDO
+
+       write(message,*) 'PSFC extremes (traditional)'
+       CALL wrf_message(message)
+       write(message,*) minval(DUM2DB,MASK=DEFINED_PSFCB),maxval(DUM2DB,MASK=DEFINED_PSFCB)
+       CALL wrf_message(message)
+       IF (minval(DUM2DB,MASK=DEFINED_PSFCB) .lt. 50000. .or. maxval(DUM2DB,MASK=DEFINED_PSFCB) .gt. 108000.) THEN
+         call wrf_error_fatal("quit due to crazy surface pressure")
+       ENDIF
+
+!!!!! end traditional
+
+       DO J=JTS,min(JTE,JDE-1)
+       DO I=ITS,min(ITE,IDE-1)
+         IF (DEFINED_PSFCB(I,J) .and. DEFINED_PSFC(I,J)) THEN
+
+          IF (  abs(dum2d(I,J)-DUM2DB(I,J)) .gt. 400.) THEN
+	     write(message,*) 'BIG DIFF I,J, dum2d, DUM2DB: ', I,J,dum2d(I,J),DUM2DB(I,J)
+             CALL wrf_message(message)
+          ENDIF
+
+!! do we have enough confidence in new style to give it more than 50% weight?
+          psfc_out(I,J)=0.5*(dum2d(I,J)+DUM2DB(I,J))
+
+         ELSEIF (DEFINED_PSFC(I,J)) THEN
+           psfc_out(I,J)=dum2d(I,J)
+         ELSEIF (DEFINED_PSFCB(I,J)) THEN
+           psfc_out(I,J)=DUM2DB(I,J)
+         ELSE
+	   write(message,*) 'I,J,dum2d,DUM2DB: ', I,J,dum2d(I,J),DUM2DB(I,J)
+           CALL wrf_message(message)
+	   write(message,*) 'I,J,DEFINED_PSFC(I,J),DEFINED_PSFCB(I,J): ', I,J,DEFINED_PSFC(I,J),DEFINED_PSFCB(I,J)
+           CALL wrf_message(message)
+	   call wrf_error_fatal("psfc_out completely undefined")
+         ENDIF
+
+	IF (I .eq. Ilook .AND. J .eq. Jlook) THEN
+	  write(message,*) ' combined psfc: ', I,J,psfc_out(I,J)
+          CALL wrf_message(message)
+        ENDIF
+
+	IF (psfc_out(I,J) .lt. 50000. .or. psfc_out(I,J) .gt. 107000.) THEN
+	  write(message,*) 'bad combo on psfc_out: ', I,J, psfc_out(I,J)
+          CALL wrf_message(message)
+	  write(message,*) 'DEFINED_PSFC, dum2d: ', DEFINED_PSFC(I,J),dum2d(I,J)
+          CALL wrf_message(message)
+	  write(message,*) 'DEFINED_PSFCB, DUM2DB: ', DEFINED_PSFCB(I,J),DUM2DB(I,J)
+          CALL wrf_message(message)
+	  call wrf_error_fatal("psfc_out looks BAD")
+	ENDIF
+
+       ENDDO
+       ENDDO
+	
+	deallocate(dum2d,dum2db)
+
+	END SUBROUTINE compute_nmm_surfacep
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE compute_3d_pressure(psfc_out,SGML1,SGML2,pdtop,pt       &
+     &,                              pd,p3d_out                          &
+     &,                              IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                              IMS,IME,JMS,JME,KMS,KME             &
+     &,                              ITS,ITE,JTS,JTE,KTS,KTE )
+
+
+        REAL, INTENT(IN) :: psfc_out(IMS:IME,JMS:JME)
+        REAL, INTENT(IN) :: SGML1(KDE),SGML2(KDE),pdtop,pt
+
+        REAL, INTENT(OUT):: p3d_out(IMS:IME,KDS:KDE-1,JMS:JME)
+        REAL, INTENT(OUT):: PD(IMS:IME,JMS:JME)
+         
+        INTEGER          :: IDS,IDE,JDS,JDE,KDS,KDE
+        INTEGER          :: IMS,IME,JMS,JME,KMS,KME
+        INTEGER          :: ITS,ITE,JTS,JTE,KTS,KTE  
+
+        CHARACTER (len=132) :: message
+
+!	write(message,*) 'pdtop, pt, psfc_out(1,1): ', pdtop, pt, psfc_out(1,1)
+!        CALL wrf_message(message)
+
+        DO J=JTS,min(JTE,JDE-1)
+          DO I=ITS,min(ITE,IDE-1)
+             PD(I,J)=psfc_out(I,J)-PDTOP-PT
+          ENDDO
+        ENDDO
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO K=KDS,KDE-1
+          DO I=ITS,min(ITE,IDE-1)
+           p3d_out(I,K,J)=PD(I,J)*SGML2(K)+PDTOP*SGML1(K)+PT
+
+	IF (p3d_out(I,K,J) .ge. psfc_out(I,J) .or. p3d_out(I,K,J) .le. pt) THEN
+           write(message,*) 'I,K,J,p3d_out: ', I,K,J,p3d_out(I,K,J)
+           CALL wrf_error_fatal(message)
+ 	ENDIF
+
+          ENDDO
+         ENDDO
+        ENDDO
+
+	END SUBROUTINE compute_3d_pressure
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE interp_press2press_lin(press_in,press_out, &
+                                    data_in, data_out,generic          &
+     &,                             extrapolate,ignore_lowest,TFIELD    & 
+     &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                             IMS,IME,JMS,JME,KMS,KME             &
+     &,                             ITS,ITE,JTS,JTE,KTS,KTE )
+
+    ! Interpolates data from one set of pressure surfaces to
+    ! another set of pressures
+
+    INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
+    INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
+    INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
+
+!    REAL, INTENT(IN)                   :: press_in(IMS:IME,generic,JMS:JME)
+    REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(IN)                   :: press_out(IMS:IME,KDS:KDE-1,JMS:JME)
+!    REAL, INTENT(IN)                   :: data_in(IMS:IME,generic,JMS:JME)
+    REAL, INTENT(IN)                   :: data_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(OUT)                  :: data_out(IMS:IME,KMS:KME,JMS:JME)
+    LOGICAL, INTENT(IN)                :: extrapolate, ignore_lowest, TFIELD
+    LOGICAL                            :: col_smooth
+
+    INTEGER                            :: i,j
+    INTEGER                            :: k,kk
+    REAL                               :: desired_press
+    REAL                               :: dvaldlnp,dlnp,tadiabat,tiso
+
+    REAL, PARAMETER                    :: ADIAFAC=9.81/1004.
+    REAL, PARAMETER                    :: TSTEXTRAPFAC=.0065
+
+
+
+    data_out(:,:,:) = -99999.9
+
+    IF (ignore_lowest) then
+       LMIN=2
+    ELSE
+       LMIN=1
+    ENDIF
+
+    DO j = JTS, min(JTE,JDE-1)
+      DO i = ITS, min(ITE,IDE-1)
+
+       col_smooth=.false.
+
+        output_loop: DO k = KDS,KDE-1
+
+          desired_press = press_out(i,k,j)
+
+        if (K .gt. KDS) then
+	if (TFIELD .and. col_smooth .and. desired_press .lt. press_in(i,j,LMIN) &
+                                    .and. press_out(i,k-1,j) .gt. press_in(i,j,LMIN)) then
+	  MAX_SMOOTH=K
+!	  write(message,*) 'I,J, MAX_SMOOTH: ', I,J, MAX_SMOOTH
+!         CALL wrf_debug(100,message)
+        endif
+        endif
+
+! keep track of where the extrapolation begins
+
+          IF (desired_press .GT. press_in(i,j,LMIN)) THEN
+           IF (TFIELD .and. K .eq. 1  .and. (desired_press - press_in(i,j,LMIN)) .gt. 3000.) then
+            col_smooth=.TRUE.   ! due to large extrapolation distance
+           ENDIF 
+	
+
+            IF ((desired_press - press_in(i,j,LMIN)).LT. 50.) THEN ! 0.5 mb
+               data_out(i,k,j) = data_in(i,j,LMIN)
+            ELSE
+              IF (extrapolate) THEN
+                ! Extrapolate downward because desired P level is below
+                ! the lowest level in our input data.  Extrapolate using simple
+                ! 1st derivative of value with respect to ln P for the bottom 2
+                ! input layers.
+
+                ! Add a check to make sure we are not using the gradient of
+                ! a very thin layer
+
+                if (TFIELD) then
+                  tiso=0.5*(data_in(i,j,1)+data_in(i,j,2))
+                endif
+
+
+                IF ( (press_in(i,j,LMIN)-press_in(i,j,LMIN+1)) .GT. 500.) THEN ! likely isobaric data
+                  dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+1))
+                  dvaldlnp = (data_in(i,j,LMIN) - data_in(i,j,LMIN+1)) / dlnp
+                ELSE                                                           ! assume terrain following
+                  dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+5))
+                  dvaldlnp = (data_in(i,j,LMIN) - data_in(i,j,LMIN+5)) / dlnp
+                ENDIF
+                data_out(i,k,j) = data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+	if (TFIELD .and. data_out(i,k,j) .lt. tiso-0.2) then
+
+! restrict slope to -1K/10 hPa
+          dvaldlnp=max(dvaldlnp, -1.0/ &
+                                log( press_in(i,j,LMIN) / &
+                                   ( press_in(i,j,LMIN)-1000.)  )) 
+
+          data_out(I,K,J)= data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+        elseif (TFIELD .and. data_out(i,k,j) .gt. tiso+0.2) then
+
+! restrict slope to +0.8K/10 hPa
+          dvaldlnp=min(dvaldlnp, 0.8/ &
+                                log( press_in(i,j,LMIN) / &
+                                   ( press_in(i,j,LMIN)-1000.)  )) 
+
+          data_out(I,K,J)= data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+         endif
+
+              ELSE
+                data_out(i,k,j) = data_in(i,j,LMIN)
+              ENDIF
+            ENDIF
+          ELSE IF (desired_press .LT. press_in(i,j,generic)) THEN
+            IF ( (press_in(i,j,generic) - desired_press) .LT. 10.) THEN
+               data_out(i,k,j) = data_in(i,j,generic)
+            ELSE
+              IF (extrapolate) THEN
+                ! Extrapolate upward
+                IF ((press_in(i,j,generic-1)-press_in(i,j,generic)).GT.50.) THEN
+                  dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-1))
+                  dvaldlnp=(data_in(i,j,generic)-data_in(i,j,generic-1))/dlnp
+                ELSE
+                  dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-2))
+                  dvaldlnp=(data_in(i,j,generic)-data_in(i,j,generic-2))/dlnp
+                ENDIF
+                data_out(i,k,j) =  data_in(i,j,generic) + &
+                  dvaldlnp * (log(desired_press)-log(press_in(i,j,generic)))
+              ELSE
+                data_out(i,k,j) = data_in(i,j,generic)
+              ENDIF
+            ENDIF
+          ELSE
+            ! We can trap between two levels and linearly interpolate
+
+            input_loop:  DO kk = LMIN, generic-1
+              IF (desired_press .EQ. press_in(i,j,kk) )THEN
+                data_out(i,k,j) = data_in(i,j,kk)
+                EXIT input_loop
+              ELSE IF ( (desired_press .LT. press_in(i,j,kk)) .AND. &
+                        (desired_press .GT. press_in(i,j,kk+1)) ) THEN
+
+!       do trapped in lnp
+
+         dlnp = log(press_in(i,j,kk)) - log(press_in(i,j,kk+1))
+         dvaldlnp = (data_in(i,j,kk)-data_in(i,j,kk+1))/dlnp
+         data_out(i,k,j) = data_in(i,j,kk+1)+ &
+                           dvaldlnp*(log(desired_press)-log(press_in(i,j,kk+1)))
+
+                EXIT input_loop
+              ENDIF
+
+            ENDDO input_loop
+          ENDIF
+        ENDDO output_loop
+
+	if (col_smooth) then
+       do K=max(KDS,MAX_SMOOTH-4),MAX_SMOOTH+4
+       data_out(I,K,J)=0.5*(data_out(I,K,J)+data_out(I,K+1,J))
+       enddo
+        endif
+
+      ENDDO
+    ENDDO
+  END SUBROUTINE interp_press2press_lin
+
+  SUBROUTINE wind_adjust(press_in,press_out, &
+                                    U_in, V_in,U_out,V_out           &
+     &,                             generic,depth_replace    & 
+     &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                             IMS,IME,JMS,JME,KMS,KME             &
+     &,                             ITS,ITE,JTS,JTE,KTS,KTE )
+
+    INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
+    INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
+    INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
+    INTEGER                            :: MAXLIN,MAXLOUT
+
+    REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(IN)                   :: press_out(IMS:IME,KDS:KDE-1,JMS:JME)
+    REAL, INTENT(IN)                   :: U_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(IN)                   :: V_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(INOUT)                :: U_out(IMS:IME,KMS:KME,JMS:JME)
+    REAL, INTENT(INOUT)                :: V_out(IMS:IME,KMS:KME,JMS:JME)
+    REAL                               :: p1d_in(generic)
+    REAL                               :: p1d_out(KDS:KDE-1)
+
+
+    DO j = JTS, min(JTE,JDE-1)
+      DO i = ITS, min(ITE,IDE-1)
+
+!        IF (press_out(I,1,J) .lt. press_in(I,J,2)) then
+         IF(  (press_in(I,J,2)-press_out(I,1,J)) .gt. 200.) then
+
+        U_out(I,1,J)=U_in(I,J,2)
+        V_out(I,1,J)=V_in(I,J,2)
+
+   INLOOP: DO L=2,generic
+	p1d_in(L)=-9999.
+        IF (  (press_in(I,J,2)-press_in(I,J,L)) .lt. depth_replace) THEN
+          p1d_in(L)=(press_in(I,J,2)-press_in(I,J,L))
+          MAXLIN=L
+        ELSE
+          p1d_in(L)=(press_in(I,J,2)-press_in(I,J,L))
+          EXIT INLOOP
+        ENDIF 
+    END DO INLOOP
+
+   OUTLOOP: DO L=KDS,KDE-1
+	p1d_out(L)=-9999.
+        IF (  (press_out(I,1,J)-press_out(I,L,J)) .lt. depth_replace) THEN
+          p1d_out(L)=(press_out(I,1,J)-press_out(I,L,J))
+          MAXLOUT=L
+        ELSE
+          EXIT OUTLOOP
+        ENDIF 
+    END DO OUTLOOP
+
+        DO L=1,MAXLOUT
+	ptarg=p1d_out(L)
+
+    FINDLOOP:   DO LL=2,MAXLIN
+
+         if (p1d_in(LL) .lt. ptarg .and. p1d_in(LL+1) .gt. ptarg) then
+
+           dlnp=log(p1d_in(LL))-log(p1d_in(LL+1))
+           dudlnp=(U_in(I,J,LL)-U_in(I,J,LL+1))/dlnp
+           dvdlnp=(V_in(I,J,LL)-V_in(I,J,LL+1))/dlnp
+           U_out(I,L,J)=U_in(I,J,LL)+dudlnp*(log(ptarg)-log(p1d_in(LL)))
+           V_out(I,L,J)=V_in(I,J,LL)+dvdlnp*(log(ptarg)-log(p1d_in(LL)))
+
+           EXIT FINDLOOP
+         endif
+
+   END DO FINDLOOP
+        END DO   ! MAXLOUT loop
+           
+
+        ENDIF
+
+      ENDDO
+    ENDDO
+
+
+
+  END SUBROUTINE wind_adjust
+!--------------------------------------------------------------------
+
+  SUBROUTINE interp_press2press_log(press_in,press_out, &
+                                    data_in, data_out, generic          &
+     &,                             extrapolate,ignore_lowest           & 
+     &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                             IMS,IME,JMS,JME,KMS,KME             &
+     &,                             ITS,ITE,JTS,JTE,KTS,KTE )
+
+    ! Interpolates ln(data) from one set of pressure surfaces to
+    ! another set of pressures
+
+    INTEGER                            :: IDS,IDE,JDS,JDE,KDS,KDE
+    INTEGER                            :: IMS,IME,JMS,JME,KMS,KME
+    INTEGER                            :: ITS,ITE,JTS,JTE,KTS,KTE,generic
+
+!    REAL, INTENT(IN)                   :: press_in(IMS:IME,generic,JMS:JME)
+    REAL, INTENT(IN)                   :: press_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(IN)                   :: press_out(IMS:IME,KDS:KDE-1,JMS:JME)
+!    REAL, INTENT(IN)                   :: data_in(IMS:IME,generic,JMS:JME)
+    REAL, INTENT(IN)                   :: data_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(OUT)                  :: data_out(IMS:IME,KMS:KME,JMS:JME)
+    LOGICAL, INTENT(IN)                :: extrapolate, ignore_lowest
+
+    INTEGER                            :: i,j
+    INTEGER                            :: k,kk
+    REAL                               :: desired_press
+    REAL                               :: dlnvaldlnp,dlnp
+
+
+    data_out(:,:,:) = -99999.9
+
+    IF (ignore_lowest) then
+       LMIN=2
+    ELSE
+       LMIN=1
+    ENDIF
+
+    DO j = JTS, min(JTE,JDE-1)
+      DO i = ITS, min(ITE,IDE-1)
+
+        output_loop: DO k = KDS,KDE-1
+
+          desired_press = press_out(i,k,j)
+
+          IF (desired_press .GT. press_in(i,j,LMIN)) THEN
+
+            IF ((desired_press - press_in(i,j,LMIN)).LT. 10.) THEN ! 0.1 mb
+               data_out(i,k,j) = data_in(i,j,LMIN)
+            ELSE
+              IF (extrapolate) THEN
+                ! Extrapolate downward because desired P level is below
+                ! the lowest level in our input data.  Extrapolate using simple
+                ! 1st derivative of value with respect to ln P for the bottom 2
+                ! input layers.
+
+                ! Add a check to make sure we are not using the gradient of
+                ! a very thin layer
+
+                IF ( (press_in(i,j,LMIN)-press_in(i,j,LMIN+1)) .GT. 100.) THEN
+                  dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+1))
+                  dlnvaldlnp = ( log(data_in(i,j,LMIN)) - log(data_in(i,j,LMIN+1)) ) / dlnp
+
+                ELSE
+
+                  dlnp     = log(press_in(i,j,LMIN))-log(press_in(i,j,LMIN+2))
+                  dlnvaldlnp = (log(data_in(i,j,LMIN)) - log(data_in(i,j,LMIN+2))) / dlnp
+
+                ENDIF
+
+                data_out(i,k,j) = exp(log(data_in(i,j,LMIN)) + dlnvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN))))
+              ELSE
+                data_out(i,k,j) = data_in(i,j,LMIN)
+              ENDIF
+            ENDIF
+          ELSE IF (desired_press .LT. press_in(i,j,generic)) THEN
+            IF ( (press_in(i,j,generic) - desired_press) .LT. 10.) THEN
+               data_out(i,k,j) = data_in(i,j,generic)
+            ELSE
+              IF (extrapolate) THEN
+                ! Extrapolate upward
+                IF ((press_in(i,j,generic-1)-press_in(i,j,generic)).GT.50.) THEN
+                  dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-1))
+                  dlnvaldlnp=(log(data_in(i,j,generic))-log(data_in(i,j,generic-1)))/dlnp
+                ELSE
+                  dlnp    =log(press_in(i,j,generic))-log(press_in(i,j,generic-2))
+                  dlnvaldlnp=(log(data_in(i,j,generic))-log(data_in(i,j,generic-2)))/dlnp
+                ENDIF
+                data_out(i,k,j) =  exp(log(data_in(i,j,generic)) + &
+                          dlnvaldlnp * (log(desired_press)-log(press_in(i,j,generic))))
+              ELSE
+                data_out(i,k,j) = data_in(i,j,generic)
+              ENDIF
+            ENDIF
+          ELSE
+            ! We can trap between two levels and linearly interpolate
+
+            input_loop:  DO kk = LMIN, generic-1
+              IF (desired_press .EQ. press_in(i,j,kk) )THEN
+                data_out(i,k,j) = data_in(i,j,kk)
+                EXIT input_loop
+              ELSE IF ( (desired_press .LT. press_in(i,j,kk)) .AND. &
+                        (desired_press .GT. press_in(i,j,kk+1)) ) THEN
+
+!       do trapped in lnp
+
+         dlnp = log(press_in(i,j,kk)) - log(press_in(i,j,kk+1))
+         dlnvaldlnp = (log(data_in(i,j,kk))-log(data_in(i,j,kk+1)))/dlnp
+         data_out(i,k,j) = exp(log(data_in(i,j,kk+1))+ &
+                          dlnvaldlnp*(log(desired_press)-log(press_in(i,j,kk+1))))
+
+                EXIT input_loop
+
+              ENDIF
+
+            ENDDO input_loop
+          ENDIF
+        ENDDO output_loop
+      ENDDO
+    ENDDO
+  END SUBROUTINE interp_press2press_log
+
+!-------------------------------------------------------------------
+   SUBROUTINE rh_to_mxrat (rh, t, p, q , wrt_liquid , &
+                           ids , ide , jds , jde , kds , kde , &
+                           ims , ime , jms , jme , kms , kme , &
+                           its , ite , jts , jte , kts , kte )
+
+      IMPLICIT NONE
+
+      INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
+                                     ims , ime , jms , jme , kms , kme , &
+                                     its , ite , jts , jte , kts , kte
+
+      LOGICAL , INTENT(IN)        :: wrt_liquid
+
+!      REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN)     :: p , t
+!      REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT)  :: rh
+      REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(IN)     :: p , t
+      REAL , DIMENSION(ims:ime,jms:jme,kms:kme) , INTENT(INOUT)  :: rh
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT)    :: q
+
+      !  Local vars
+
+      INTEGER                     :: i , j , k
+
+      REAL                        :: ew , q1 , t1
+
+      REAL,         PARAMETER     :: T_REF       = 0.0
+      REAL,         PARAMETER     :: MW_AIR      = 28.966
+      REAL,         PARAMETER     :: MW_VAP      = 18.0152
+
+      REAL,         PARAMETER     :: A0       = 6.107799961
+      REAL,         PARAMETER     :: A1       = 4.436518521e-01
+      REAL,         PARAMETER     :: A2       = 1.428945805e-02
+      REAL,         PARAMETER     :: A3       = 2.650648471e-04
+      REAL,         PARAMETER     :: A4       = 3.031240396e-06
+      REAL,         PARAMETER     :: A5       = 2.034080948e-08
+      REAL,         PARAMETER     :: A6       = 6.136820929e-11
+
+      REAL,         PARAMETER     :: ES0 = 6.1121
+
+      REAL,         PARAMETER     :: C1       = 9.09718
+      REAL,         PARAMETER     :: C2       = 3.56654
+      REAL,         PARAMETER     :: C3       = 0.876793
+      REAL,         PARAMETER     :: EIS      = 6.1071
+      REAL                        :: RHS
+      REAL,         PARAMETER     :: TF       = 273.16
+      REAL                        :: TK
+
+      REAL                        :: ES
+      REAL                        :: QS
+      REAL,         PARAMETER     :: EPS         = 0.622
+      REAL,         PARAMETER     :: SVP1        = 0.6112
+      REAL,         PARAMETER     :: SVP2        = 17.67
+      REAL,         PARAMETER     :: SVP3        = 29.65
+      REAL,         PARAMETER     :: SVPT0       = 273.15
+
+      !  This subroutine computes mixing ratio (q, kg/kg) from basic variables
+      !  pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%).
+      !  The reference temperature (t_ref, C) is used to describe the temperature
+      !  at which the liquid and ice phase change occurs.
+
+         DO k = kts , kte
+      DO j = jts , MIN ( jde-1 , jte )
+            DO i = its , MIN (ide-1 , ite )
+                  rh(i,j,k) = MIN ( MAX ( rh(i,j,k) ,  1. ) , 100. )
+            END DO
+         END DO
+      END DO
+
+      IF ( wrt_liquid ) THEN
+            DO k = kts , kte
+         DO j = jts , MIN ( jde-1 , jte )
+               DO i = its , MIN (ide-1 , ite )
+                  es=svp1*10.*EXP(svp2*(t(i,j,k)-svpt0)/(t(i,j,k)-svp3))
+                  qs=eps*es/(p(i,j,k)/100.-es)
+                  q(i,k,j)=MAX(.01*rh(i,j,k)*qs,0.0)
+               END DO
+            END DO
+         END DO
+
+      ELSE
+            DO k = kts , kte
+         DO j = jts , MIN ( jde-1 , jte )
+               DO i = its , MIN (ide-1 , ite )
+
+                  t1 = t(i,j,k) - 273.16
+
+                  !  Obviously dry.
+
+                  IF ( t1 .lt. -200. ) THEN
+                     q(i,k,j) = 0
+
+                  ELSE
+
+                     !  First compute the ambient vapor pressure of water
+
+                     IF ( ( t1 .GE. t_ref ) .AND. ( t1 .GE. -47.) ) THEN    ! liq phase ESLO
+                        ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6)))))
+
+                     ELSE IF ( ( t1 .GE. t_ref ) .AND. ( t1 .LT. -47. ) ) then !liq phas poor ES
+                        ew = es0 * exp(17.67 * t1 / ( t1 + 243.5))
+
+                     ELSE
+                        tk = t(i,j,k)
+                        rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) +  &
+                               c3 * (1. - tk / tf) +      alog10(eis)
+                        ew = 10. ** rhs
+
+                     END IF
+
+                     !  Now sat vap pres obtained compute local vapor pressure
+
+                     ew = MAX ( ew , 0. ) * rh(i,j,k) * 0.01
+
+                     !  Now compute the specific humidity using the partial vapor
+                     !  pressures of water vapor (ew) and dry air (p-ew).  The
+                     !  constants assume that the pressure is in hPa, so we divide
+                     !  the pressures by 100.
+
+                     q1 = mw_vap * ew
+                     q1 = q1 / (q1 + mw_air * (p(i,j,k)/100. - ew))
+
+                     q(i,k,j) = q1 / (1. - q1 )
+
+                  END IF
+
+               END DO
+            END DO
+         END DO
+
+      END IF
+
+   END SUBROUTINE rh_to_mxrat
+
+!--=------------------------------------------------------------------
+
+      SUBROUTINE  boundary_smooth(h, landmask, grid, nsmth , nrow &
+     &,                          IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                          IMS,IME,JMS,JME,KMS,KME             &
+     &,                          ITS,ITE,JTS,JTE,KTS,KTE ) 
+
+	implicit none
+
+      TYPE (domain)          :: grid 
+
+        integer :: IDS,IDE,JDS,JDE,KDS,KDE
+        integer :: IMS,IME,JMS,JME,KMS,KME
+        integer :: ITS,ITE,JTS,JTE,KTS,KTE
+        integer :: IPS,IPE,JPS,JPE,KPS,KPE
+        integer:: ihw(JDS:JDE-1),ihe(JDS:JDE-1),nsmth,nrow
+        real::    h(IMS:IME,JMS:JME),landmask(IMS:IME,JMS:JME)
+        real ::   h_old(IMS:IME,JMS:JME)
+        real ::   hbms(IDS:IDE-1,JDS:JDE-1)
+        real ::   hse(IDS:IDE-1,JDS:JDE-1)
+        real ::   hne(IDS:IDE-1,JDS:JDE-1)
+        integer :: ihl, ihh, m2l, ibas,jmelin
+        integer :: I,J,KS,IOFFSET,JSTART,JEND
+        character (len=256) :: message
+
+	ips=its
+        ipe=ite
+	jps=jts
+        jpe=jte
+	kps=kts
+        kpe=kte
+
+        do j= JTS,min(JTE,JDE-1)
+         ihw(J)=-mod(J,2)
+         ihe(j)=ihw(J)+1
+        end do
+
+        do J=JTS,min(JTE,JDE-1)
+         do I=ITS,min(ITE,IDE-1)
+           hbms(I,J)=landmask(I,J)
+         enddo
+        enddo
+
+        jmelin=(JDE-1)-nrow+1
+        ibas=nrow/2
+        m2l=mod(nrow,2)
+
+        do j=jts,min(jte,jde-1)
+         ihl=ibas+mod(j,2)+m2l*mod(J+1,2)
+         ihh=(IDE-1)-ibas-m2l*mod(J+1,2)
+         do i=its,min(ite,ide-1)
+          if (I .ge. ihl .and. I .le. ihh .and. J .ge. nrow .and. J .le. jmelin) then
+           hbms(I,J)=0.
+          endif
+         end do
+        end do
+
+  634	format(30(f2.0,1x))
+
+        do KS=1,nsmth
+
+         grid%nmm_ht_gc=h
+#ifdef DM_PARALLEL
+# include "HALO_NMM_MG.inc"
+#endif
+         h=grid%nmm_ht_gc
+         h_old=grid%nmm_ht_gc
+
+          do J=JTS,min(JTE,JDE-1)
+           do I=ITS, min(ITE,IDE-1)
+              if (I .ge. (IDS+mod(J,2)) .and. J .gt. JDS .and. J .lt. JDE-1 .and. I .lt. IDE-1) then
+                h(i,j)= ( h_old(i+ihe(j),j+1) + h_old(i+ihw(j),j-1) + h_old(i+ihe(j),j-1) + h_old(i+ihw(j),j+1) - &
+                        4. *h_old(i,j) )*hbms(i,j)*0.125+h_old(i,j)
+              endif
+
+           enddo
+          enddo
+
+!       special treatment for four corners
+
+        if (hbms(1,1) .eq. 1 .and. ITS .le. 1 .and. JTS .le. 1) then
+        h(1,1)=0.75*h(1,1)+0.125*h(1+ihe(1),2)+  &
+                                 0.0625*(h(2,1)+h(1,3))
+        endif
+
+        if (hbms(IDE-1,1) .eq. 1 .and. ITE .ge. IDE-2 .and. JTS .le. 1) then
+        h(IDE-1,1)=0.75*h(IDE-1,1)+0.125*h(IDE-1+ihw(1),2)+ &
+                                 0.0625*(h(IDE-1-1,1)+h(IDE-1,3))
+        endif
+
+        if (hbms(1,JDE-1) .eq. 1 .and. ITS .le. 1 .and. JTE .ge. JDE-2) then
+        h(1,JDE-1)=0.75*h(1,JDE-1)+0.125*h(1+ihe(JDE-1),JDE-1-1)+ &
+                                 0.0625*(h(2,JDE-1)+h(1,JDE-1-2))
+        endif
+
+        if (hbms(IDE-1,JDE-1) .eq. 1 .and. ITE .ge. IDE-2 .and. JTE .ge. JDE-2) then
+        h(IDE-1,JDE-1)=0.75*h(IDE-1,JDE-1)+0.125*h(IDE-1+ihw(JDE-1),JDE-1-1)+ &
+                                 0.0625*(h(IDE-1-1,JDE-1)+h(IDE-1,JDE-1-2))
+        endif
+
+        do J=JMS,JME
+         do I=IMS,IME
+         grid%nmm_ht_gc(I,J)=h(I,J)
+         enddo 
+        enddo
+#ifdef DM_PARALLEL
+# include "HALO_NMM_MG.inc"
+#endif
+        do J=JMS,JME
+         do I=IMS,IME
+         h(I,J)=grid%nmm_ht_gc(I,J)
+         enddo 
+        enddo
+
+
+!       S bound
+	if (JTS .eq. JDS) then
+        J=JTS
+
+        do I=ITS,ITE
+        if (I .ge. IDS+1 .and. I .le. IDE-2) then
+        if (hbms(I,J) .eq. 1) then
+        h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihe(J),J+1))
+        endif
+        endif
+        enddo
+
+        endif
+
+!       N bound
+        if (JTE .eq. JDE) then
+        J=JDE-1
+	write(message,*) 'DOING N BOUND SMOOTHING for J= ', J
+        CALL wrf_message(message)
+         do I=ITS,min(ITE,IDE-1)
+          if (hbms(I,J) .eq. 1 .and. I .ge. IDS+1 .and. I .le. IDE-2) then
+           h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J-1)+h(I+ihe(J),J-1))
+          endif
+         enddo
+	endif
+
+!       W bound
+        if (ITS .eq. IDS) then
+         I=ITS
+         do J=JTS,min(JTE,JDE-1)
+          if (hbms(I,J) .eq. 1 .and. J .ge. JDS+2 .and. J .le. JDE-3 .and. mod(J,2) .eq. 1) then
+           h(I,J)=0.75*h(I,J)+0.125*(h(I+ihe(J),J+1)+h(I+ihe(J),J-1))
+          endif
+         enddo
+	endif
+
+!       E bound
+	if (ITE .eq. IDE) then
+	write(message,*) 'DOING E BOUND SMOOTHING for I= ', min(ITE,IDE-1)
+        CALL wrf_message(message)
+         I=min(ITE,IDE-1)
+         do J=JTS,min(JTE,JDE-1) 
+          if (hbms(I,J) .eq. 1  .and. J .ge. JDS+2 .and. J .le. JDE-3 .and. mod(J,2) .eq. 1) then
+           h(I,J)=0.75*h(I,J)+0.125*(h(I+ihw(J),J+1)+h(I+ihw(J),J-1))
+          endif
+         enddo
+	endif
+
+        enddo   ! end ks loop
+
+        do J=JMS,JME
+         do I=IMS,IME
+         grid%nmm_ht_gc(I,J)=h(I,J)
+         enddo 
+        enddo
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_MG.inc"
+#endif
+        do J=JMS,JME
+         do I=IMS,IME
+         h(I,J)=grid%nmm_ht_gc(I,J)
+        enddo 
+        enddo
+
+! extra smoothing along inner boundary
+
+          if (JTS .eq. JDS) then
+           if (ITE .eq. IDE) then
+              IOFFSET=1
+           else
+              IOFFSET=0
+           endif
+!  Southern Boundary
+           do i=its,min(ITE,IDE-1)-IOFFSET
+             h(i,2)=0.25*(h(i,1)+h(i+1,1)+ &
+                          h(i,3)+h(i+1,3))
+           enddo
+          endif
+
+
+          if (JTE .eq. JDE) then
+           if (ITE .eq. IDE) then
+              IOFFSET=1
+           else
+              IOFFSET=0
+           endif
+           do i=its,min(ITE,IDE-1)-IOFFSET
+             h(i,(JDE-1)-1)=0.25*(h(i,(JDE-1)-2)+h(i+1,(JDE-1)-2)+ &
+                                h(i,JDE-1)+h(i+1,JDE-1))
+           enddo
+          endif
+        
+           if (JTS .eq. 1) then
+             JSTART=4
+           else
+             JSTART=JTS+mod(JTS,2) ! needs to be even
+           endif
+
+           if (JTE .eq. JDE) then
+             JEND=(JDE-1)-3
+           else
+             JEND=JTE
+           endif
+
+          if (ITS .eq. IDS) then
+
+!  Western Boundary
+          do j=JSTART,JEND,2
+            h(1,j)=0.25*(h(1,j-1)+h(2,j-1)+ &
+                         h(1,j+1)+h(2,j+1))
+
+          enddo
+          endif
+	
+
+          if (ITE .eq. IDE) then
+!  Eastern Boundary
+          do j=JSTART,JEND,2
+            h(IDE-1,j)=0.25*(h((IDE-1)-1,j-1)+h((IDE-1),j-1)+ &
+                              h((IDE-1)-1,j+1)+h((IDE-1),j+1))
+          enddo
+          endif
+
+
+       END SUBROUTINE boundary_smooth
+
+!--------------------------------------------------------------------
+
+   SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , &
+                      ids , ide , jds , jde , kds , kde , &
+                      ims , ime , jms , jme , kms , kme , &
+                      its , ite , jts , jte , kts , kte )
+
+   !  Linrarly in time interpolate data to a current valid time.  The data is
+   !  assumed to come in "monthly", valid at the 15th of every month.
+
+      IMPLICIT NONE
+
+      INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
+                                     ims , ime , jms , jme , kms , kme , &
+                                     its , ite , jts , jte , kts , kte
+
+      CHARACTER (LEN=24) , INTENT(IN) :: date_str
+      REAL , DIMENSION(ims:ime,jms:jme,12) , INTENT(IN)  :: field_in
+      REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_out
+
+      !  Local vars
+
+      INTEGER :: i , j , l
+      INTEGER , DIMENSION(0:13) :: middle
+      INTEGER :: target_julyr , target_julday , target_date
+      INTEGER :: julyr , julday , int_month, next_month
+      REAL :: gmt
+      CHARACTER (LEN=4) :: yr
+      CHARACTER (LEN=2) :: mon , day15
+
+
+      WRITE(day15,FMT='(I2.2)') 15
+      DO l = 1 , 12
+         WRITE(mon,FMT='(I2.2)') l
+         CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt )
+         middle(l) = julyr*1000 + julday
+      END DO
+
+      l = 0
+      middle(l) = middle( 1) - 31
+
+      l = 13
+      middle(l) = middle(12) + 31
+
+      CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
+      target_date = target_julyr * 1000 + target_julday
+      find_month : DO l = 0 , 12
+         IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
+            DO j = jts , MIN ( jde-1 , jte )
+               DO i = its , MIN (ide-1 , ite )
+                  int_month = MOD ( l , 12 )
+                  IF ( int_month .EQ. 0 ) int_month = 12
+
+	IF (int_month == 12) THEN
+            next_month=1
+        ELSE
+            next_month=int_month+1
+        ENDIF
+
+                  field_out(i,j) =  ( field_in(i,j,next_month) * ( target_date - middle(l)   ) + &
+                                      field_in(i,j,int_month  ) * ( middle(l+1) - target_date ) ) / &
+                                    ( middle(l+1) - middle(l) )
+               END DO
+            END DO
+            EXIT find_month
+         END IF
+      END DO find_month
+   END SUBROUTINE monthly_interp_to_date
+
+!---------------------------------------------------------------------
+   SUBROUTINE monthly_min_max ( field_in , field_min , field_max , &
+                      ids , ide , jds , jde , kds , kde , &
+                      ims , ime , jms , jme , kms , kme , &
+                      its , ite , jts , jte , kts , kte )
+
+   !  Plow through each month, find the max, min values for each i,j.
+
+      IMPLICIT NONE
+
+      INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
+                                     ims , ime , jms , jme , kms , kme , &
+                                     its , ite , jts , jte , kts , kte
+
+      REAL , DIMENSION(ims:ime,jms:jme,12) , INTENT(IN)  :: field_in
+      REAL , DIMENSION(ims:ime,   jms:jme) , INTENT(OUT) :: field_min , field_max
+
+      !  Local vars
+
+      INTEGER :: i , j , l
+      REAL :: minner , maxxer
+
+      DO j = jts , MIN(jde-1,jte)
+         DO i = its , MIN(ide-1,ite)
+            minner = field_in(i,j,1)
+            maxxer = field_in(i,j,1)
+            DO l = 2 , 12
+               IF ( field_in(i,j,l) .LT. minner ) THEN
+                  minner = field_in(i,j,l)
+               END IF
+               IF ( field_in(i,j,l) .GT. maxxer ) THEN
+                  maxxer = field_in(i,j,l)
+               END IF
+            END DO
+            field_min(i,j) = minner
+            field_max(i,j) = maxxer
+         END DO
+      END DO
+
+   END SUBROUTINE monthly_min_max
+
+!-----------------------------------------------------------------------
+
+  SUBROUTINE reverse_vert_coord  ( field, start_z, end_z                &
+     &,                             IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,                             IMS,IME,JMS,JME,KMS,KME             &
+     &,                             ITS,ITE,JTS,JTE,KTS,KTE )
+
+	IMPLICIT NONE
+
+        INTEGER , INTENT(IN)        :: ids , ide , jds , jde , kds , kde , &
+                                       ims , ime , jms , jme , kms , kme , &
+                                       its , ite , jts , jte , kts , kte,  &
+                                       start_z, end_z
+
+        REAL, INTENT(INOUT)         :: field(IMS:IME,JMS:JME,end_z) 
+! local
+
+        INTEGER                     :: I,J,L
+        REAL, ALLOCATABLE           :: dum3d(:,:,:)
+
+        allocate(dum3d(IMS:IME,JMS:JME,end_z))
+
+        DO L=start_z,end_z
+          DO J=jts,min(jte,jde-1)
+            DO I=its,min(ite,ide-1)
+	      dum3d(I,J,L)=field(I,J,end_z-L+start_z)
+            END DO
+          END DO
+        END DO
+
+        DO L=start_z,end_z
+          DO J=jts,min(jte,jde-1)
+            DO I=its,min(ite,ide-1)
+              field(I,J,L)=dum3d(I,J,L)
+            END DO
+          END DO
+        END DO
+       
+        DEALLOCATE(dum3d)
+
+        END SUBROUTINE reverse_vert_coord
+
+
+!--------------------------------------------------------------------
+      SUBROUTINE NMM_SH2O(IMS,IME,JMS,JME,ISTART,IM,JSTART,JM,&
+                        NSOIL,ISLTPK, &
+                        SM,SICE,STC,SMC,SH2O)
+
+!!        INTEGER, PARAMETER:: NSOTYP=9
+!        INTEGER, PARAMETER:: NSOTYP=16
+        INTEGER, PARAMETER:: NSOTYP=19 !!!!!!!!MAYBE???
+
+        REAL :: PSIS(NSOTYP),BETA(NSOTYP),SMCMAX(NSOTYP)
+        REAL :: STC(IMS:IME,NSOIL,JMS:JME), &
+                SMC(IMS:IME,NSOIL,JMS:JME)
+        REAL :: SH2O(IMS:IME,NSOIL,JMS:JME),SICE(IMS:IME,JMS:JME),&
+                SM(IMS:IME,JMS:JME)
+        REAL :: HLICE,GRAV,T0,BLIM
+        INTEGER :: ISLTPK(IMS:IME,JMS:JME)
+        CHARACTER(LEN=132) :: message
+
+! Constants used in cold start SH2O initialization
+      DATA HLICE/3.335E5/,GRAV/9.81/,T0/273.15/
+      DATA BLIM/5.5/
+!      DATA PSIS /0.04,0.62,0.47,0.14,0.10,0.26,0.14,0.36,0.04/
+!      DATA BETA /4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/
+!      DATA SMCMAX /0.421,0.464,0.468,0.434,0.406, &
+!                  0.465,0.404,0.439,0.421/
+
+        
+!!!      NOT SURE...PSIS=SATPSI, BETA=BB??
+
+        DATA PSIS /0.069, 0.036, 0.141, 0.759, 0.759, 0.355,   &
+                   0.135, 0.617, 0.263, 0.098, 0.324, 0.468,   &
+                   0.355, 0.000, 0.069, 0.036, 0.468, 0.069, 0.069  /
+
+        DATA BETA/2.79,  4.26,  4.74,  5.33,  5.33,  5.25,    &
+                  6.66,  8.72,  8.17, 10.73, 10.39, 11.55,    &
+                  5.25,  0.00,  2.79,  4.26, 11.55, 2.79, 2.79 /
+
+        DATA SMCMAX/0.339, 0.421, 0.434, 0.476, 0.476, 0.439,  &
+                    0.404, 0.464, 0.465, 0.406, 0.468, 0.468,  &
+                    0.439, 1.000, 0.200, 0.421, 0.468, 0.200, 0.339/
+
+        DO K=1,NSOIL
+         DO J=JSTART,JM
+          DO I=ISTART,IM
+!tst
+        IF (SMC(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then
+  if (K .eq. 1) then
+    write(message,*) 'I,J,reducing SMC from ' ,I,J,SMC(I,K,J), 'to ', SMCMAX(ISLTPK(I,J))
+    CALL wrf_debug(100,message)
+  endif
+        SMC(I,K,J)=SMCMAX(ISLTPK(I,J))
+        ENDIF
+!tst
+
+        IF ( (SM(I,J) .lt. 0.5) .and. (SICE(I,J) .lt. 0.5) ) THEN
+
+        IF (ISLTPK(I,J) .gt. 19) THEN
+                WRITE(message,*) 'FORCING ISLTPK at : ', I,J
+                CALL wrf_message(message)
+                ISLTPK(I,J)=9
+        ELSEIF (ISLTPK(I,J) .le. 0) then
+                WRITE(message,*) 'FORCING ISLTPK at : ', I,J
+                CALL wrf_message(message)
+                ISLTPK(I,J)=1
+        ENDIF
+
+
+! cold start:  determine liquid soil water content (SH2O)
+! SH2O <= SMC for T < 273.149K (-0.001C)
+
+           IF (STC(I,K,J) .LT. 273.149) THEN
+
+! first guess following explicit solution for Flerchinger Eqn from Koren
+! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O).
+
+              BX = BETA(ISLTPK(I,J))
+              IF ( BETA(ISLTPK(I,J)) .GT. BLIM ) BX = BLIM
+
+        if ( GRAV*(-PSIS(ISLTPK(I,J))) .eq. 0 ) then
+        write(message,*) 'TROUBLE'
+        CALL wrf_message(message)
+        write(message,*) 'I,J: ', i,J
+        CALL wrf_message(message)
+        write(message,*) 'grav, isltpk, psis(isltpk): ', grav,isltpk(I,J),&
+                 psis(isltpk(I,J))
+        CALL wrf_message(message)
+        endif
+
+        if (BX .eq. 0 .or. STC(I,K,J) .eq. 0) then
+                write(message,*) 'TROUBLE -- I,J,BX, STC: ', I,J,BX,STC(I,K,J)
+                CALL wrf_message(message)
+        endif
+              FK = (((HLICE/(GRAV*(-PSIS(ISLTPK(I,J)))))* &
+                  ((STC(I,K,J)-T0)/STC(I,K,J)))** &
+                  (-1/BX))*SMCMAX(ISLTPK(I,J))
+              IF (FK .LT. 0.02) FK = 0.02
+              SH2O(I,K,J) = MIN ( FK, SMC(I,K,J) )
+! ----------------------------------------------------------------------
+! now use iterative solution for liquid soil water content using
+! FUNCTION FRH2O (from the Eta "NOAH" land-surface model) with the
+! initial guess for SH2O from above explicit first guess.
+
+              SH2O(I,K,J)=FRH2O_init(STC(I,K,J),SMC(I,K,J),SH2O(I,K,J), &
+                         SMCMAX(ISLTPK(I,J)),BETA(ISLTPK(I,J)), &
+                         PSIS(ISLTPK(I,J)))
+
+            ELSE ! above freezing
+              SH2O(I,K,J)=SMC(I,K,J)
+            ENDIF
+
+        ELSE   ! water point
+              SH2O(I,K,J)=SMC(I,K,J)
+        ENDIF ! test on land/ice/sea
+        IF (SH2O(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) THEN
+          write(message,*) 'SH2O > THAN SMCMAX ', I,J,SH2O(I,K,J),SMCMAX(ISLTPK(I,J)),SMC(I,K,J)
+          CALL wrf_message(message)
+        ENDIF
+
+         ENDDO
+        ENDDO
+       ENDDO
+
+        END SUBROUTINE NMM_SH2O
+
+!-------------------------------------------------------------------
+
+      FUNCTION FRH2O_init(TKELV,SMC,SH2O,SMCMAX,B,PSIS)
+
+      IMPLICIT NONE
+
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!  PURPOSE:  CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT
+!  IF TEMPERATURE IS BELOW 273.15K (T0).  REQUIRES NEWTON-TYPE ITERATION
+!  TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF
+!  KOREN ET AL. (1999, JGR, VOL 104(D16), 19569-19585).
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+! New version (JUNE 2001): much faster and more accurate newton iteration
+! achieved by first taking log of eqn cited above -- less than 4
+! (typically 1 or 2) iterations achieves convergence.  Also, explicit
+! 1-step solution option for special case of parameter Ck=0, which reduces
+! the original implicit equation to a simpler explicit form, known as the
+! ""Flerchinger Eqn". Improved handling of solution in the limit of
+! freezing point temperature T0.
+!
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+! INPUT:
+!
+!   TKELV.........Temperature (Kelvin)
+!   SMC...........Total soil moisture content (volumetric)
+!   SH2O..........Liquid soil moisture content (volumetric)
+!   SMCMAX........Saturation soil moisture content (from REDPRM)
+!   B.............Soil type "B" parameter (from REDPRM)
+!   PSIS..........Saturated soil matric potential (from REDPRM)
+!
+! OUTPUT:
+!   FRH2O.........supercooled liquid water content.
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+      REAL B
+      REAL BLIM
+      REAL BX
+      REAL CK
+      REAL DENOM
+      REAL DF
+      REAL DH2O
+      REAL DICE
+      REAL DSWL
+      REAL ERROR
+      REAL FK
+      REAL FRH2O_init
+      REAL GS
+      REAL HLICE
+      REAL PSIS
+      REAL SH2O
+      REAL SMC
+      REAL SMCMAX
+      REAL SWL
+      REAL SWLK
+      REAL TKELV
+      REAL T0
+
+      INTEGER NLOG
+      INTEGER KCOUNT
+      PARAMETER (CK=8.0)
+!      PARAMETER (CK=0.0)
+      PARAMETER (BLIM=5.5)
+!      PARAMETER (BLIM=7.0)
+      PARAMETER (ERROR=0.005)
+
+      PARAMETER (HLICE=3.335E5)
+      PARAMETER (GS = 9.81)
+      PARAMETER (DICE=920.0)
+      PARAMETER (DH2O=1000.0)
+      PARAMETER (T0=273.15)
+
+!  ###   LIMITS ON PARAMETER B: B < 5.5  (use parameter BLIM)  ####
+!  ###   SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT  ####
+!  ###   IS NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES    ####
+!  ################################################################
+!
+      BX = B
+      IF ( B .GT. BLIM ) BX = BLIM
+! ------------------------------------------------------------------
+
+! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG.
+      NLOG=0
+      KCOUNT=0
+
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! C  IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+
+      IF (TKELV .GT. (T0 - 1.E-3)) THEN
+
+        FRH2O_init=SMC
+
+      ELSE
+
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+       IF (CK .NE. 0.0) THEN
+
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CCCCCCCCC OPTION 1: ITERATED SOLUTION FOR NONZERO CK CCCCCCCCCCC
+! CCCCCCCCCCCC IN KOREN ET AL, JGR, 1999, EQN 17 CCCCCCCCCCCCCCCCC
+
+! INITIAL GUESS FOR SWL (frozen content)
+        SWL = SMC-SH2O
+! KEEP WITHIN BOUNDS.
+         IF (SWL .GT. (SMC-0.02)) SWL=SMC-0.02
+         IF(SWL .LT. 0.) SWL=0.
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! C  START OF ITERATIONS
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+        DO WHILE (NLOG .LT. 10 .AND. KCOUNT .EQ. 0)
+         NLOG = NLOG+1
+         DF = ALOG(( PSIS*GS/HLICE ) * ( ( 1.+CK*SWL )**2. ) * &
+             ( SMCMAX/(SMC-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV)
+         DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( SMC - SWL )
+         SWLK = SWL - DF/DENOM
+! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION.
+         IF (SWLK .GT. (SMC-0.02)) SWLK = SMC - 0.02
+         IF(SWLK .LT. 0.) SWLK = 0.
+! MATHEMATICAL SOLUTION BOUNDS APPLIED.
+         DSWL=ABS(SWLK-SWL)
+         SWL=SWLK
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CC IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.)
+! CC WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED.
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+         IF ( DSWL .LE. ERROR )  THEN
+           KCOUNT=KCOUNT+1
+         END IF
+        END DO
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! C  END OF ITERATIONS
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION.
+        FRH2O_init = SMC - SWL
+
+! CCCCCCCCCCCCCCCCCCCCCCCC END OPTION 1 CCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+       ENDIF
+
+       IF (KCOUNT .EQ. 0) THEN
+!         Print*,'Flerchinger used in NEW version. Iterations=',NLOG
+
+! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CCCCC OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 CCCCCCCC
+! CCCCCCCCCCCCC IN KOREN ET AL., JGR, 1999, EQN 17  CCCCCCCCCCCCCCC
+
+        FK=(((HLICE/(GS*(-PSIS)))*((TKELV-T0)/TKELV))**(-1/BX))*SMCMAX
+! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION
+        IF (FK .LT. 0.02) FK = 0.02
+        FRH2O_init = MIN ( FK, SMC )
+
+! CCCCCCCCCCCCCCCCCCCCCCCCC END OPTION 2 CCCCCCCCCCCCCCCCCCCCCCCCCC
+
+       ENDIF
+
+      ENDIF
+
+        RETURN
+
+      END FUNCTION FRH2O_init
+
+
+!--------------------------------------------------------------------
+
+   SUBROUTINE init_module_initialize
+   END SUBROUTINE init_module_initialize
+
+!---------------------------------------------------------------------
+
+END MODULE module_initialize
diff --git a/wrfv2_fire/dyn_nmm/module_si_io_nmm.F b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F
new file mode 100644
index 00000000..949af8a6
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F
@@ -0,0 +1,1313 @@
+MODULE module_si_io_nmm
+
+   USE module_optional_si_input
+
+   IMPLICIT NONE
+
+      !  Input 3D meteorological fields.
+
+      REAL , DIMENSION(:,:,:) , ALLOCATABLE :: u_input , v_input , &
+                                               q_input , t_input
+
+      !  Input 3D LSM fields.
+
+      REAL , DIMENSION(:,:,:) , ALLOCATABLE :: landuse_frac_input , &
+                                               soil_top_cat_input , &
+                                               soil_bot_cat_input
+
+      REAL, ALLOCATABLE:: htm_in(:,:,:),vtm_in(:,:,:)
+
+      !  Input 2D surface fields.
+
+      REAL , DIMENSION(:,:)   , ALLOCATABLE :: soilt010_input , soilt040_input , &
+                                               soilt100_input , soilt200_input , &
+                                               soilm010_input , soilm040_input , &
+                                               soilm100_input , soilm200_input , &
+                                               psfc_in,pmsl
+
+      REAL , DIMENSION(:,:)   , ALLOCATABLE :: lat_wind, lon_wind 
+
+      REAL , DIMENSION(:)     , ALLOCATABLE :: DETA_in, AETA_in, ETAX_in
+      REAL , DIMENSION(:)     , ALLOCATABLE :: DETA1_in, AETA1_in, ETA1_in
+      REAL , DIMENSION(:)     , ALLOCATABLE :: DETA2_in, AETA2_in, ETA2_in, DFL_in
+
+      REAL , DIMENSION(:,:,:), ALLOCATABLE :: st_inputx , sm_inputx, sw_inputx
+
+      !  Local input arrays
+
+      REAL,DIMENSION(:,:),ALLOCATABLE :: dum2d
+      INTEGER,DIMENSION(:,:),ALLOCATABLE :: idum2d
+      REAL,DIMENSION(:,:,:),ALLOCATABLE :: dum3d
+
+      LOGICAL , SAVE :: first_time_in = .TRUE.
+
+      INTEGER :: flag_soilt010 , flag_soilt100 , flag_soilt200 , &
+        	 flag_soilm010 , flag_soilm100 , flag_soilm200
+
+!   Some constants to allow simple dimensions in the defined types
+!   given below.
+
+      INTEGER, PARAMETER          :: var_maxdims = 5
+      INTEGER, PARAMETER          :: max_staggers_xy_new = 4
+      INTEGER, PARAMETER          :: max_staggers_xy_old = 3
+      INTEGER, PARAMETER          :: max_staggers_z = 2
+      INTEGER, PARAMETER          :: max_standard_lats = 4
+      INTEGER, PARAMETER          :: max_standard_lons = 4  
+      INTEGER, PARAMETER          :: max_fg_variables = 200
+      INTEGER, PARAMETER          :: max_vertical_levels = 2000
+
+!   This module defines the items needed for the WRF metadata
+!   which is broken up into three levels:  
+!      Global metadata:  Those things which apply to the
+!                        entire simulation that are 
+!                        independent of time, domain, or
+!                        variable
+!
+!      Domain metadata:  Those things which apply to 
+!                        a single domain (this may
+!                        or may not be time dependent)
+!
+!      Variable metadata: Those things which apply to 
+!                        a specific variable at a 
+!                        specific time
+!
+!      The variable names and definitions can be 
+!      found in the wrf_metadata spec, which is still
+!      a living document as coding goes on.   The names
+!      may not match exactly, but you should be able 
+!      to figure things out.  
+!
+
+      TYPE wrf_var_metadata
+	 CHARACTER (LEN=8)         :: name 
+	 CHARACTER (LEN=16)        :: units
+	 CHARACTER (LEN=80)        :: description
+	 INTEGER                   :: domain_id
+	 INTEGER                   :: ndim
+	 INTEGER                   :: dim_val (var_maxdims)
+	 CHARACTER(LEN=4)          :: dim_desc (var_maxdims)
+	 INTEGER                   :: start_index(var_maxdims)
+	 INTEGER                   :: stop_index(var_maxdims)
+	 INTEGER                   :: h_stagger_index
+	 INTEGER                   :: v_stagger_index
+	 CHARACTER(LEN=8)          :: array_order
+	 CHARACTER(LEN=4)          :: field_type
+	 CHARACTER(LEN=8)          :: field_source_prog
+	 CHARACTER(LEN=80)         :: source_desc
+	 CHARACTER(LEN=8)          :: field_time_type
+	 INTEGER                   :: vt_date_start
+	 REAL                      :: vt_time_start
+	 INTEGER                   :: vt_date_stop
+	 REAL                      :: vt_time_stop
+      END TYPE wrf_var_metadata
+
+      TYPE(wrf_var_metadata)  :: var_meta , var_info
+
+      TYPE wrf_domain_metadata
+	 INTEGER                   :: id
+	 INTEGER                   :: parent_id
+	 CHARACTER(LEN=8)          :: dyn_init_src
+	 CHARACTER(LEN=8)          :: static_init_src 
+	 INTEGER                   :: vt_date
+	 REAL                      :: vt_time
+	 INTEGER                   :: origin_parent_x
+	 INTEGER                   :: origin_parent_y
+	 INTEGER                   :: ratio_to_parent
+	 REAL                      :: delta_x
+	 REAL                      :: delta_y
+	 REAL                      :: top_level
+	 INTEGER                   :: origin_parent_z
+	 REAL                      :: corner_lats_new(4,max_staggers_xy_new)
+	 REAL                      :: corner_lons_new(4,max_staggers_xy_new)
+	 REAL                      :: corner_lats_old(4,max_staggers_xy_old)
+	 REAL                      :: corner_lons_old(4,max_staggers_xy_old)
+	 INTEGER                   :: xdim
+	 INTEGER                   :: ydim
+	 INTEGER                   :: zdim
+      END TYPE wrf_domain_metadata
+      TYPE(wrf_domain_metadata) :: dom_meta
+
+      TYPE wrf_global_metadata
+	 CHARACTER(LEN=80)         :: simulation_name
+	 CHARACTER(LEN=80)         :: user_desc
+	 INTEGER                   :: si_version
+	 INTEGER                   :: analysis_version  
+	 INTEGER                   :: wrf_version
+	 INTEGER                   :: post_version
+	 CHARACTER(LEN=32)         :: map_projection
+	 REAL                      :: moad_known_lat
+	 REAL                      :: moad_known_lon
+	 CHARACTER(LEN=8)          :: moad_known_loc
+	 REAL                      :: moad_stand_lats(max_standard_lats)
+	 REAL                      :: moad_stand_lons(max_standard_lons)
+	 REAL                      :: moad_delta_x
+	 REAL                      :: moad_delta_y
+	 CHARACTER(LEN=4)          :: horiz_stagger_type
+	 INTEGER                   :: num_stagger_xy
+	 REAL                      :: stagger_dir_x_new(max_staggers_xy_new)
+	 REAL                      :: stagger_dir_y_new(max_staggers_xy_new)
+	 REAL                      :: stagger_dir_x_old(max_staggers_xy_old)
+	 REAL                      :: stagger_dir_y_old(max_staggers_xy_old)
+	 INTEGER                   :: num_stagger_z    
+	 REAL                      :: stagger_dir_z(max_staggers_z)
+	 CHARACTER(LEN=8)          :: vertical_coord
+	 INTEGER                   :: num_domains
+	 INTEGER                   :: init_date
+	 REAL                      :: init_time
+	 INTEGER                   :: end_date
+	 REAL                      :: end_time
+	 CHARACTER(LEN=4)          :: lu_source
+	 INTEGER                   :: lu_water
+	 INTEGER                   :: lu_ice  
+      END TYPE wrf_global_metadata
+      TYPE(wrf_global_metadata)   :: global_meta
+
+CONTAINS
+
+   SUBROUTINE read_si ( grid, file_date_string )
+
+      USE module_soil_pre
+      USE module_domain
+
+      IMPLICIT NONE
+
+      TYPE(domain) , INTENT(INOUT)  :: grid
+      CHARACTER (LEN=19) , INTENT(IN) :: file_date_string
+
+      INTEGER :: ids,ide,jds,jde,kds,kde           &
+                ,ims,ime,jms,jme,kms,kme           &
+                ,its,ite,jts,jte,kts,kte
+
+      INTEGER :: i , j , k , loop, IMAX, JMAX
+
+      REAL :: dummy
+
+      CHARACTER (LEN= 8) :: dummy_char
+
+      INTEGER :: ok , map_proj , ok_open
+      REAL :: pt
+      INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
+
+      write(0,*)' enter read_si'
+
+      SELECT CASE ( model_data_order )
+         CASE ( DATA_ORDER_ZXY )
+            kds = grid%sd31 ; kde = grid%ed31 ;
+            ids = grid%sd32 ; ide = grid%ed32 ;
+            jds = grid%sd33 ; jde = grid%ed33 ;
+
+            kms = grid%sm31 ; kme = grid%em31 ;
+            ims = grid%sm32 ; ime = grid%em32 ;
+            jms = grid%sm33 ; jme = grid%em33 ;
+
+            kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch
+            its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch
+            jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
+
+         CASE ( DATA_ORDER_XYZ )
+            ids = grid%sd31 ; ide = grid%ed31 ;
+            jds = grid%sd32 ; jde = grid%ed32 ;
+            kds = grid%sd33 ; kde = grid%ed33 ;
+
+            ims = grid%sm31 ; ime = grid%em31 ;
+            jms = grid%sm32 ; jme = grid%em32 ;
+            kms = grid%sm33 ; kme = grid%em33 ;
+
+            its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
+            jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch
+            kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch
+
+         CASE ( DATA_ORDER_XZY )
+            ids = grid%sd31 ; ide = grid%ed31 ;
+            kds = grid%sd32 ; kde = grid%ed32 ;
+            jds = grid%sd33 ; jde = grid%ed33 ;
+
+            ims = grid%sm31 ; ime = grid%em31 ;
+            kms = grid%sm32 ; kme = grid%em32 ;
+            jms = grid%sm33 ; jme = grid%em33 ;
+
+            its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch
+            kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch
+            jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch
+
+      END SELECT
+
+      !  Initialize what soil temperature and moisture is available.
+
+      write(0,*) 'dum3d I allocs: ', ids,ide-1
+      write(0,*) 'dum3d J allocs: ', jds,jde-1
+      write(0,*) 'dum3d K allocs: ', kds,kde-1
+
+      flag_st000010 = 0
+      flag_st010040 = 0
+      flag_st040100 = 0
+      flag_st100200 = 0
+      flag_sm000010 = 0 
+      flag_sm010040 = 0
+      flag_sm040100 = 0
+      flag_sm100200 = 0
+      flag_st010200 = 0
+      flag_sm010200 = 0
+
+      flag_soilt010 = 0
+      flag_soilt040 = 0
+      flag_soilt100 = 0
+      flag_soilt200 = 0 
+      flag_soilm010 = 0 
+      flag_soilm040 = 0
+      flag_soilm100 = 0
+      flag_soilm200 = 0
+
+      flag_sst      = 0
+      flag_toposoil = 0
+
+      !  How many soil levels have we found?  Well, right now, none.
+
+      num_st_levels_input = 0
+      num_sm_levels_input = 0
+      st_levels_input = -1
+      sm_levels_input = -1
+
+      !  Get the space for the data if this is the first time here.
+
+        write(6,*) 'enter read_si...first_time_in:: ', first_time_in
+
+      IF ( first_time_in ) THEN
+
+         CLOSE(12)
+         OPEN ( FILE   = 'real_input_nm.global.metadata' , &
+                UNIT   = 12                              , &
+                STATUS = 'OLD'                           , &
+                ACCESS = 'SEQUENTIAL'                    , &
+                FORM   = 'UNFORMATTED'                   , &
+                IOSTAT = ok_open                           )
+
+         IF ( ok_open .NE. 0 ) THEN
+            PRINT '(A)','You asked for WRF SI data, but no real_input_nm.global.metadata file exists.'
+            STOP 'No_real_input_nm.global.metadata_exists'
+         END IF
+
+         READ(12) global_meta%simulation_name, global_meta%user_desc, &
+                  global_meta%si_version, global_meta%analysis_version, &
+                  global_meta%wrf_version, global_meta%post_version
+   
+         REWIND (12)
+
+         IF      ( global_meta%si_version .EQ. 1 ) THEN
+            READ(12) global_meta%simulation_name, global_meta%user_desc, &
+                     global_meta%si_version, global_meta%analysis_version, &
+                     global_meta%wrf_version, global_meta%post_version, &
+                     global_meta%map_projection, global_meta%moad_known_lat, &
+                     global_meta%moad_known_lon, global_meta%moad_known_loc, &
+                     global_meta%moad_stand_lats, global_meta%moad_stand_lons, &
+                     global_meta%moad_delta_x, global_meta%moad_delta_y, &
+                     global_meta%horiz_stagger_type, global_meta%num_stagger_xy, &
+                     global_meta%stagger_dir_x_old, global_meta%stagger_dir_y_old, &
+                     global_meta%num_stagger_z, global_meta%stagger_dir_z, &
+                     global_meta%vertical_coord, global_meta%num_domains, &
+                     global_meta%init_date, global_meta%init_time, &
+                     global_meta%end_date, global_meta%end_time
+         ELSE IF ( global_meta%si_version .EQ. 2 ) THEN
+            READ(12) global_meta%simulation_name, global_meta%user_desc, &
+                     global_meta%si_version, global_meta%analysis_version, &
+                     global_meta%wrf_version, global_meta%post_version, &
+                     global_meta%map_projection, global_meta%moad_known_lat, &
+                     global_meta%moad_known_lon, global_meta%moad_known_loc, &
+                     global_meta%moad_stand_lats, global_meta%moad_stand_lons, &
+                     global_meta%moad_delta_x, global_meta%moad_delta_y, &
+                     global_meta%horiz_stagger_type, global_meta%num_stagger_xy, &
+                     global_meta%stagger_dir_x_new, global_meta%stagger_dir_y_new, &
+                     global_meta%num_stagger_z, global_meta%stagger_dir_z, &
+                     global_meta%vertical_coord, global_meta%num_domains, &
+                     global_meta%init_date, global_meta%init_time, &
+                     global_meta%end_date, global_meta%end_time , &
+                     global_meta%lu_source, global_meta%lu_water, global_meta%lu_ice
+         END IF
+         CLOSE (12)
+   
+         print *,'GLOBAL METADATA'
+         print *,'global_meta%simulation_name', global_meta%simulation_name
+         print *,'global_meta%user_desc', global_meta%user_desc
+         print *,'global_meta%user_desc', global_meta%user_desc
+         print *,'global_meta%si_version', global_meta%si_version
+         print *,'global_meta%analysis_version', global_meta%analysis_version
+         print *,'global_meta%wrf_version', global_meta%wrf_version
+         print *,'global_meta%post_version', global_meta%post_version
+         print *,'global_meta%map_projection', global_meta%map_projection
+         print *,'global_meta%moad_known_lat', global_meta%moad_known_lat
+         print *,'global_meta%moad_known_lon', global_meta%moad_known_lon
+         print *,'global_meta%moad_known_loc', global_meta%moad_known_loc
+         print *,'global_meta%moad_stand_lats', global_meta%moad_stand_lats
+         print *,'global_meta%moad_stand_lons', global_meta%moad_stand_lons
+         print *,'global_meta%moad_delta_x', global_meta%moad_delta_x
+         print *,'global_meta%moad_delta_y', global_meta%moad_delta_y
+         print *,'global_meta%horiz_stagger_type', global_meta%horiz_stagger_type
+         print *,'global_meta%num_stagger_xy', global_meta%num_stagger_xy
+         IF      ( global_meta%si_version .EQ. 1 ) THEN
+            print *,'global_meta%stagger_dir_x', global_meta%stagger_dir_x_old
+            print *,'global_meta%stagger_dir_y', global_meta%stagger_dir_y_old
+         ELSE IF ( global_meta%si_version .EQ. 2 ) THEN
+            print *,'global_meta%stagger_dir_x', global_meta%stagger_dir_x_new
+            print *,'global_meta%stagger_dir_y', global_meta%stagger_dir_y_new
+         END IF
+         print *,'global_meta%num_stagger_z', global_meta%num_stagger_z
+         print *,'global_meta%stagger_dir_z', global_meta%stagger_dir_z
+         print *,'global_meta%vertical_coord', global_meta%vertical_coord
+         print *,'global_meta%num_domains', global_meta%num_domains
+         print *,'global_meta%init_date', global_meta%init_date
+         print *,'global_meta%init_time', global_meta%init_time
+         print *,'global_meta%end_date', global_meta%end_date
+         print *,'global_meta%end_time', global_meta%end_time
+         IF ( global_meta%si_version .EQ. 2 ) THEN
+            print *,'global_meta%lu_source', global_meta%lu_source
+            print *,'global_meta%lu_water', global_meta%lu_water
+            print *,'global_meta%lu_ice', global_meta%lu_ice
+         END IF
+         print *,' '
+
+         !  1D - this is the definition of the vertical coordinate.
+
+        IF (.NOT. ALLOCATED (DETA_in)) ALLOCATE(DETA_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (AETA_in)) ALLOCATE(AETA_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (ETAX_in)) ALLOCATE(ETAX_in(kds:kde))
+
+        IF (.NOT. ALLOCATED (DETA1_in)) ALLOCATE(DETA1_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (AETA1_in)) ALLOCATE(AETA1_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (ETA1_in))  ALLOCATE(ETA1_in(kds:kde))
+
+        IF (.NOT. ALLOCATED (DETA2_in)) ALLOCATE(DETA2_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (AETA2_in)) ALLOCATE(AETA2_in(kds:kde-1))
+        IF (.NOT. ALLOCATED (ETA2_in)) ALLOCATE(ETA2_in(kds:kde))
+
+        IF (.NOT. ALLOCATED (DFL_in)) ALLOCATE(DFL_in(kds:kde))
+
+         !  3D met
+
+        IF (.NOT. ALLOCATED (u_input)  ) ALLOCATE ( u_input(its:ite,jts:jte,kts:kte) )
+        IF (.NOT. ALLOCATED (v_input)  ) ALLOCATE ( v_input(its:ite,jts:jte,kts:kte) )
+        IF (.NOT. ALLOCATED (q_input)  ) ALLOCATE ( q_input(its:ite,jts:jte,kts:kte) )
+        IF (.NOT. ALLOCATED (t_input)  ) ALLOCATE ( t_input(its:ite,jts:jte,kts:kte) )
+        IF (.NOT. ALLOCATED (htm_in)  ) ALLOCATE ( htm_in(its:ite,jts:jte,kts:kte) )
+        IF (.NOT. ALLOCATED (vtm_in)  ) ALLOCATE ( vtm_in(its:ite,jts:jte,kts:kte) )
+
+        !  2D pressure fields
+
+        IF (.NOT. ALLOCATED (pmsl)              ) ALLOCATE ( pmsl(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (psfc_in)           ) ALLOCATE ( psfc_in(its:ite,jts:jte) )
+
+        !  2D - for LSM, these are computed from the categorical precentage values.
+
+        !  2D - for LSM, the various soil temperature and moisture levels that are available.
+
+        IF (.NOT. ALLOCATED (st_inputx)) ALLOCATE (st_inputx(its:ite,jts:jte,num_st_levels_alloc))
+        IF (.NOT. ALLOCATED (sm_inputx)) ALLOCATE (sm_inputx(its:ite,jts:jte,num_st_levels_alloc))
+        IF (.NOT. ALLOCATED (sw_inputx)) ALLOCATE (sw_inputx(its:ite,jts:jte,num_st_levels_alloc))
+
+        IF (.NOT. ALLOCATED (soilt010_input)    ) ALLOCATE ( soilt010_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilt040_input)    ) ALLOCATE ( soilt040_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilt100_input)    ) ALLOCATE ( soilt100_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilt200_input)    ) ALLOCATE ( soilt200_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilm010_input)    ) ALLOCATE ( soilm010_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilm040_input)    ) ALLOCATE ( soilm040_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilm100_input)    ) ALLOCATE ( soilm100_input(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (soilm200_input)    ) ALLOCATE ( soilm200_input(its:ite,jts:jte) )
+
+        IF (.NOT. ALLOCATED (lat_wind)          ) ALLOCATE (lat_wind(its:ite,jts:jte))
+        IF (.NOT. ALLOCATED (lon_wind)          ) ALLOCATE (lon_wind(its:ite,jts:jte))
+
+        !  Local arrays
+        IF (.NOT. ALLOCATED (dum2d)             ) ALLOCATE (dum2d(IDS:IDE-1,JDS:JDE-1))
+        IF (.NOT. ALLOCATED (idum2d)            ) ALLOCATE (idum2d(IDS:IDE-1,JDS:JDE-1))
+        IF (.NOT. ALLOCATED (dum3d)             ) ALLOCATE (dum3d(IDS:IDE-1,JDS:JDE-1,KDS:KDE-1))
+
+
+      END IF
+
+      CLOSE(13)
+
+      write(6,*) 'file_date_string: ', file_date_string
+      write(6,*) 'opening real_input_nm.d01.'//file_date_string//' as unit 13'
+      OPEN ( FILE   = 'real_input_nm.d01.'//file_date_string , &
+             UNIT   = 13                                     , &
+             STATUS = 'OLD'                                  , &
+             ACCESS = 'SEQUENTIAL'                           , &
+             FORM   = 'UNFORMATTED'                            )
+
+      IF      ( global_meta%si_version .EQ. 1 ) THEN
+         READ (13) dom_meta%id,dom_meta%parent_id,dom_meta%dyn_init_src,&
+                   dom_meta%static_init_src, dom_meta%vt_date, dom_meta%vt_time, &
+                   dom_meta%origin_parent_x, dom_meta%origin_parent_y, &
+                   dom_meta%ratio_to_parent, dom_meta%delta_x, dom_meta%delta_y, &
+                   dom_meta%top_level, dom_meta%origin_parent_z, &
+                   dom_meta%corner_lats_old, dom_meta%corner_lons_old, dom_meta%xdim, &
+                   dom_meta%ydim, dom_meta%zdim
+      ELSE IF ( global_meta%si_version .EQ. 2 ) THEN
+         READ (13) dom_meta%id,dom_meta%parent_id,dom_meta%dyn_init_src,&
+                   dom_meta%static_init_src, dom_meta%vt_date, dom_meta%vt_time, &
+                   dom_meta%origin_parent_x, dom_meta%origin_parent_y, &
+                   dom_meta%ratio_to_parent, dom_meta%delta_x, dom_meta%delta_y, &
+                   dom_meta%top_level, dom_meta%origin_parent_z, &
+                   dom_meta%corner_lats_new, dom_meta%corner_lons_new, dom_meta%xdim, &
+                   dom_meta%ydim, dom_meta%zdim
+      END IF
+
+      print *,'DOMAIN METADATA'
+      print *,'dom_meta%id=', dom_meta%id
+      print *,'dom_meta%parent_id=', dom_meta%parent_id
+      print *,'dom_meta%dyn_init_src=', dom_meta%dyn_init_src
+      print *,'dom_meta%static_init_src=', dom_meta%static_init_src
+      print *,'dom_meta%vt_date=', dom_meta%vt_date
+      print *,'dom_meta%vt_time=', dom_meta%vt_time
+      print *,'dom_meta%origin_parent_x=', dom_meta%origin_parent_x
+      print *,'dom_meta%origin_parent_y=', dom_meta%origin_parent_y
+      print *,'dom_meta%ratio_to_parent=', dom_meta%ratio_to_parent
+      print *,'dom_meta%delta_x=', dom_meta%delta_x
+      print *,'dom_meta%delta_y=', dom_meta%delta_y
+      print *,'dom_meta%top_level=', dom_meta%top_level
+      print *,'dom_meta%origin_parent_z=', dom_meta%origin_parent_z
+      IF      ( global_meta%si_version .EQ. 1 ) THEN
+         print *,'dom_meta%corner_lats=', dom_meta%corner_lats_old
+         print *,'dom_meta%corner_lons=', dom_meta%corner_lons_old
+      ELSE IF ( global_meta%si_version .EQ. 2 ) THEN
+         print *,'dom_meta%corner_lats=', dom_meta%corner_lats_new
+         print *,'dom_meta%corner_lons=', dom_meta%corner_lons_new
+      END IF
+      print *,'dom_meta%xdim=', dom_meta%xdim
+      print *,'dom_meta%ydim=', dom_meta%ydim
+      print *,'dom_meta%zdim=', dom_meta%zdim
+      print *,' '
+
+      !  A simple domain size test.
+    
+
+!!        relax constraint, as model namelist has +1 for i and j, while
+!!        si data has true dimensions
+
+      IF (  abs(dom_meta%xdim - (ide-1)) .gt. 1 &
+       .OR. abs(dom_meta%ydim - (jde-1)) .gt. 1 &
+       .OR. abs(dom_meta%zdim - (kde-1)) .gt. 1) THEN
+         PRINT '(A)','Namelist does not match the input data.'
+         PRINT '(A,3I5,A)','Namelist dimensions =',ide-1,jde-1,kde-1,'.'
+         PRINT '(A,3I5,A)','Input data dimensions =',dom_meta%xdim,dom_meta%ydim,dom_meta%zdim,'.'
+         STOP 'Wrong_data_size'
+      END IF
+
+      ! How about the grid distance?  Is it the same as in the namelist?
+
+      IF        ( global_meta%si_version .EQ. 1 ) THEN
+         CALL nl_set_cen_lat ( grid%id , ( dom_meta%corner_lats_old(1,1) + dom_meta%corner_lats_old(2,1) +        &
+                                        dom_meta%corner_lats_old(3,1) + dom_meta%corner_lats_old(4,1) ) * 0.25 ) 
+      ELSE IF ( ( global_meta%si_version .EQ. 2 ) .AND. ( global_meta%moad_known_loc(1:6) .EQ. 'CENTER' ) ) THEN
+         CALL nl_set_cen_lat ( grid%id , global_meta%moad_known_lat )
+      ELSE IF   ( global_meta%si_version .EQ. 2 ) THEN
+         CALL nl_set_cen_lat ( grid%id , ( dom_meta%corner_lats_new(1,1) + dom_meta%corner_lats_new(2,1) +        &
+                                        dom_meta%corner_lats_new(3,1) + dom_meta%corner_lats_new(4,1) ) * 0.25 ) 
+      END IF
+
+
+!!!        might be trouble here
+
+      CALL nl_set_cen_lon ( grid%id , global_meta%moad_stand_lons(1) )
+!!!!!
+      write(6,*) 'set_cen_lat... global_meta%moad_stand_lats(1): ', global_meta%moad_stand_lats(1)
+      CALL nl_set_cen_lat ( grid%id , global_meta%moad_stand_lats(1) )
+!!!!!
+      CALL nl_set_truelat1 ( grid%id , global_meta%moad_stand_lats(1) )
+      CALL nl_set_truelat2 ( grid%id , global_meta%moad_stand_lats(2) )
+
+      pt = dom_meta%top_level
+
+      IF      ( global_meta%map_projection(1:17) .EQ. 'LAMBERT CONFORMAL'   ) THEN
+         map_proj = 1
+      ELSE IF ( global_meta%map_projection(1:19) .EQ. 'POLAR STEREOGRAPHIC' ) THEN
+         map_proj = 2
+      ELSE IF ( global_meta%map_projection(1: 8) .EQ. 'MERCATOR'            ) THEN
+         map_proj = 3
+      ELSE IF ( global_meta%map_projection(1:14) .EQ. 'ROTATED LATLON' ) THEN
+         map_proj = 203 !?
+      ELSE
+         PRINT '(A,A,A)','Undefined map projection: ',TRIM(global_meta%map_projection(1:20)),'.'
+         STOP 'Undefined_map_proj_si'
+      END IF
+      CALL nl_set_map_proj ( grid%id , map_proj ) 
+     
+      write(0,*) 'global_meta%si_version: ', global_meta%si_version
+      write(0,*) 'global_meta%lu_source: ', global_meta%lu_source
+      write(0,*) 'global_meta%lu_water: ', global_meta%lu_water
+      IF      ( global_meta%si_version .EQ. 1 ) THEN
+         CALL nl_set_mminlu (grid%id, 'USGS' )
+         CALL nl_set_iswater (grid%id, 16 )
+      ELSE IF ( global_meta%si_version .EQ. 2 ) THEN
+         CALL nl_set_mminlu ( grid%id, global_meta%lu_source )
+         CALL nl_set_iswater (grid%id, global_meta%lu_water )
+         CALL nl_set_isice (grid%id, global_meta%lu_ice )
+      END IF
+
+      CALL nl_set_gmt (grid%id, dom_meta%vt_time / 3600. )
+      CALL nl_set_julyr (grid%id, dom_meta%vt_date / 1000 )
+      CALL nl_set_julday (grid%id, dom_meta%vt_date - ( dom_meta%vt_date / 1000 ) * 1000 )
+
+      write(6,*) 'start reading from unit 13'
+      read_all_the_data : DO
+
+         READ (13,IOSTAT=OK) var_info%name, var_info%units, &
+                             var_info%description, var_info%domain_id, var_info%ndim, &
+                             var_info%dim_val, var_info%dim_desc, var_info%start_index, &
+                             var_info%stop_index, var_info%h_stagger_index, var_info%v_stagger_index,&
+                             var_info%array_order, var_info%field_type, var_info%field_source_prog, &
+                             var_info%source_desc, var_info%field_time_type, var_info%vt_date_start, &
+                             var_info%vt_time_start, var_info%vt_date_stop, var_info%vt_time_stop
+
+         IF ( OK .NE. 0 ) THEN
+            PRINT '(A,A,A)','End of file found for real_input_nm.d01.',file_date_string,'.'
+            EXIT read_all_the_data
+         END IF
+
+!        print *,'VARIABLE METADATA'
+         PRINT '(A,A)','var_info%name=', var_info%name 
+!        print *,'var_info%units=', var_info%units 
+!        print *,'var_info%description=', var_info%description 
+!        print *,'var_info%domain_id=', var_info%domain_id 
+!        print *,'var_info%ndim=', var_info%ndim 
+!        print *,'var_info%dim_val=', var_info%dim_val 
+!        print *,'var_info%dim_desc=', var_info%dim_desc 
+!        print *,'var_info%start_index=', var_info%start_index 
+!        print *,'var_info%stop_index=', var_info%stop_index 
+!        print *,'var_info%h_stagger_index=', var_info%h_stagger_index 
+!        print *,'var_info%v_stagger_index=', var_info%v_stagger_index
+!        print *,'var_info%array_order=', var_info%array_order 
+!        print *,'var_info%field_type=', var_info%field_type 
+!        print *,'var_info%field_source_prog=', var_info%field_source_prog 
+!        print *,'var_info%source_desc=', var_info%source_desc 
+!        print *,'var_info%field_time_type=', var_info%field_time_type 
+!        print *,'var_info%vt_date_start=', var_info%vt_date_start 
+!        print *,'var_info%vt_time_start=', var_info%vt_time_start 
+!        print *,'var_info%vt_date_stop=', var_info%vt_date_stop 
+!        print *,'var_info%vt_time_stop=', var_info%vt_time_stop
+
+        JMAX=min(JDE-1,JTE)
+        IMAX=min(IDE-1,ITE)
+         !  3D meteorological fields.
+
+         write(0,*)' read_si var_info%name=',var_info%name(1:8)
+
+         IF      ( var_info%name(1:8) .EQ. 'T       ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              t_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+
+         ELSE IF      ( var_info%name(1:8) .EQ. 'U       ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              u_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'V       ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              v_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'Q      ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              q_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+
+         !  3D LSM fields.  Don't know the 3rd dimension until we read it in.
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'LANDUSEF' ) THEN
+            IF ( ( first_time_in ) .AND. ( .NOT. ALLOCATED ( landuse_frac_input) ) ) THEN
+               ALLOCATE (landuse_frac_input(its:ite,jts:jte,var_info%dim_val(3)) )
+            END IF
+            READ (13) (((dum3d(i,j,k),i=ids,ide-1),j=jds,jde-1),k=1,var_info%dim_val(3))
+            do k=1,var_info%dim_val(3)
+            do j=jts,JMAX
+            do i=its,IMAX
+              landuse_frac_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILCTOP' ) THEN
+            IF ( ( first_time_in ) .AND. ( .NOT. ALLOCATED ( soil_top_cat_input) ) ) THEN
+               ALLOCATE (soil_top_cat_input(its:ite,jts:jte,var_info%dim_val(3)) )
+            END IF
+            READ (13) (((dum3d(i,j,k),i=ids,ide-1),j=jds,jde-1),k=1,var_info%dim_val(3))
+            do k=1,var_info%dim_val(3)
+            do j=jts,JMAX
+            do i=its,IMAX
+              soil_top_cat_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILCBOT' ) THEN
+            IF ( ( first_time_in ) .AND. ( .NOT. ALLOCATED ( soil_bot_cat_input) ) ) THEN
+               ALLOCATE (soil_bot_cat_input(its:ite,jts:jte,var_info%dim_val(3)) )
+            END IF
+            READ (13) (((dum3d(i,j,k),i=ids,ide-1),j=jds,jde-1),k=1,var_info%dim_val(3))
+            do k=1,var_info%dim_val(3)
+            do j=jts,JMAX
+            do i=its,IMAX
+              soil_bot_cat_input(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+
+         !  2D dry pressure minus ptop.
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'PD      ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_pd(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'PSFC    ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              psfc_in(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'PMSL    ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              pmsl(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'PDTOP   ' ) THEN
+            READ (13) grid%nmm_pdtop
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'PT      ' ) THEN
+            READ (13) grid%nmm_pt
+
+         !  2D surface fields.
+
+        ELSE IF ( var_info%name(1:8) .eq. 'GLAT    ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_glat(i,j)=dum2d(i,j)
+            enddo
+            enddo
+        ELSE IF ( var_info%name(1:8) .eq. 'GLON    ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_glon(i,j)=dum2d(i,j)
+            enddo
+            enddo
+        ELSE IF ( var_info%name(1:8) .eq. 'LAT_V   ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              lat_wind(i,j)=dum2d(i,j)
+            enddo
+            enddo
+        ELSE IF ( var_info%name(1:8) .eq. 'LON_V   ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              lon_wind(i,j)=dum2d(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ST000010' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%st000010(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_st000010 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st000010(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ST010040' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%st010040(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_st010040 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st010040(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ST040100' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%st040100(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_st040100 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st040100(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ST100200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%st100200(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_st100200 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st100200(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ST010200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%st010200(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_st010200 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st010200(i,j)
+            enddo
+            enddo
+
+        ELSE IF ( var_info%name(1:8) .EQ. 'SM000010' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%sm000010(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sm000010 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm000010(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SM010040' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%sm010040(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sm010040 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm010040(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SM040100' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%sm040100(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sm040100 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm040100(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SM100200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%sm100200(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sm100200 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm100200(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SM010200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%sm010200(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sm010200 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int2(var_info%name(3:8))
+            do j=jts,JMAX
+            do i=its,IMAX
+               sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm010200(i,j)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILT010' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilt010_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilt010 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int1(var_info%name(6:8))
+!mp            st_inputx(:,:,num_st_levels_input + 1) = soilt010_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = soilt010_input(I,J)
+            enddo
+            enddo
+            write(6,*) 'num_st_levels_input=',num_st_levels_input
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILT040' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilt040_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilt040 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int1(var_info%name(6:8))
+!mp            st_inputx(:,:,num_st_levels_input + 1) = soilt040_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = soilt040_input(I,J)
+            enddo
+            enddo
+            write(6,*) 'num_st_levels_input=',num_st_levels_input
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILT100' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilt100_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilt100 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int1(var_info%name(6:8))
+!mp            st_inputx(:,:,num_st_levels_input + 1) = soilt100_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = soilt100_input(I,J)
+            enddo
+            enddo
+            write(6,*) 'num_st_levels_input=',num_st_levels_input
+        ELSE IF ( var_info%name(1:8) .EQ. 'SOILT200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilt200_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilt200 = 1
+            num_st_levels_input = num_st_levels_input + 1
+            st_levels_input(num_st_levels_input) = char2int1(var_info%name(6:8))
+!mp            st_inputx(:,:,num_st_levels_input + 1) = soilt200_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              st_inputx(I,J,num_st_levels_input + 1) = soilt200_input(I,J)
+            enddo
+            enddo
+            write(6,*) 'num_st_levels_input=',num_st_levels_input
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILM010' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilm010_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilm010 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int1(var_info%name(6:8))
+!mp            sm_inputx(:,:,num_sm_levels_input + 1) = soilm010_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = soilm010_input(I,J)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILM040' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilm040_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilm040 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int1(var_info%name(6:8))
+!mp            sm_inputx(:,:,num_sm_levels_input + 1) = soilm040_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = soilm040_input(I,J)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILM100' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilm100_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilm100 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int1(var_info%name(6:8))
+!mp            sm_inputx(:,:,num_sm_levels_input + 1) = soilm100_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = soilm100_input(I,J)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILM200' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              soilm200_input(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_soilm200 = 1
+            num_sm_levels_input = num_sm_levels_input + 1
+            sm_levels_input(num_sm_levels_input) = char2int1(var_info%name(6:8))
+!mp            sm_inputx(:,:,num_sm_levels_input + 1) = soilm200_input
+            do j=jts,JMAX
+            do i=its,IMAX
+              sm_inputx(I,J,num_sm_levels_input + 1) = soilm200_input(I,J)
+            enddo
+            enddo
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'SEAICE  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%xice(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'WEASD   ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%weasd(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'CANWAT  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%canwat(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'LANDMASK' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%landmask(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SKINTEMP' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_nmm_tsk(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'TGROUND ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+             grid%nmm_tg(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SOILTB  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+             grid%nmm_soiltb(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SST     ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+               grid%sst(i,j)=dum2d(i,j)
+            enddo
+            enddo
+            flag_sst = 1
+         ELSE IF ( var_info%name(1:8) .EQ. 'GREENFRC' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_vegfrc(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'ISLOPE  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_islope(i,j)=nint(dum2d(i,j))
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'GREENMAX' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%greenmax(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'GREENMIN' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+               grid%greenmin(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'FIS     ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_fis(i,j)=dum2d(i,j)
+            enddo
+            enddo
+        ELSE IF ( var_info%name(1:8) .EQ. 'Z0      ' ) THEN
+!         ELSE IF ( var_info%name(1:8) .EQ. 'STDEV   ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_z0(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'CMC     ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_cmc(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'HTM     ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              htm_in(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'VTM     ' ) THEN
+            READ (13) dum3d
+            do k=kts,kte-1
+            do j=jts,JMAX
+            do i=its,IMAX
+              vtm_in(i,j,k)=dum3d(i,j,k)
+            enddo
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'SM      ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_sm(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'ALBASE  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_albase(i,j)=dum2d(i,j)
+            enddo
+            enddo
+         ELSE IF ( var_info%name(1:8) .EQ. 'MXSNAL  ' ) THEN
+            READ (13) dum2d
+            do j=jts,JMAX
+            do i=its,IMAX
+              grid%nmm_mxsnal(i,j)=dum2d(i,j)
+            enddo
+            enddo
+
+         !  1D vertical coordinate.
+
+          ELSE IF ( var_info%name(1:8) .EQ. 'DETA    ' ) THEN
+             READ(13) DETA_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'DETA1   ' ) THEN
+             READ(13) DETA1_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'DETA2   ' ) THEN
+             READ(13) DETA2_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'ETAX    ' ) THEN
+             READ(13) ETAX_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'ETA1    ' ) THEN
+             READ(13) ETA1_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'ETA2    ' ) THEN
+             READ(13) ETA2_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'AETA    ' ) THEN
+             READ(13) AETA_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'AETA1   ' ) THEN
+             READ(13) AETA1_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'AETA2   ' ) THEN
+             READ(13) AETA2_in
+          ELSE IF ( var_info%name(1:8) .EQ. 'DFL     ' ) THEN
+             READ(13) DFL_in
+
+!         ELSE IF ( var_info%name(1:8) .EQ. 'ETAPHALF' ) THEN
+!            READ (13) etahalf
+!         ELSE IF ( var_info%name(1:8) .EQ. 'ETAPFULL' ) THEN
+!            READ (13) etafull
+
+         !  wrong input data.
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'ZETAFULL' ) THEN
+            PRINT '(A)','Oops, you put in the height data.'
+            STOP 'this_is_mass_not_height'
+ 
+
+         !  Stuff that we do not want or need is just skipped over.
+
+         ELSE
+print *,'------------------> skipping ', var_info%name(1:8)
+            READ (13) dummy
+         END IF
+
+      END DO read_all_the_data
+
+      CLOSE (13)
+
+      first_time_in = .FALSE.
+
+!new
+        sw_inputx=0.
+!new
+
+      do j=jts,JMAX
+      do k=kts,kte-1
+      do i=its,IMAX
+        grid%nmm_HTM(I,K,J)=HTM_in(I,J,K)
+        grid%nmm_VTM(I,K,J)=VTM_in(I,J,K)
+        grid%nmm_U(I,K,J)=U_input(I,J,K)
+        grid%nmm_V(I,K,J)=V_input(I,J,K)
+        grid%nmm_T(I,K,J)=T_input(I,J,K)
+        grid%nmm_Q(I,K,J)=Q_input(I,J,K)
+      enddo
+      enddo
+      enddo
+
+      write(0,*) 'size sw_input: ', size(sw_input,dim=1),size(sw_input,dim=2),size(sw_input,dim=3)
+      write(0,*) 'size sw_inputx: ', size(sw_inputx,dim=1),size(sw_inputx,dim=2),size(sw_inputx,dim=3)
+      sw_input=0.
+
+        write(0,*) 'maxval st_inputx(1): ', maxval(st_input(:,:,1))
+        write(0,*) 'maxval st_inputx(2): ', maxval(st_input(:,:,2))
+        write(0,*) 'maxval st_inputx(3): ', maxval(st_input(:,:,3))
+        write(0,*) 'maxval st_inputx(4): ', maxval(st_input(:,:,4))
+
+
+        do K=1,num_st_levels_alloc
+         do J=JTS,min(JDE-1,JTE)
+          do I=ITS,min(IDE-1,ITE)
+             st_input(I,K,J)=st_inputx(I,J,K)
+             sm_input(I,K,J)=sm_inputx(I,J,K)
+             sw_input(I,K,J)=sw_inputx(I,J,K)
+          enddo
+         enddo
+        enddo
+
+        write(0,*) 'maxval st_input(1): ', maxval(st_input(:,1,:))
+        write(0,*) 'maxval st_input(2): ', maxval(st_input(:,2,:))
+        write(0,*) 'maxval st_input(3): ', maxval(st_input(:,3,:))
+        write(0,*) 'maxval st_input(4): ', maxval(st_input(:,4,:))
+
+
+         num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
+         num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
+         num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
+
+        do J=JTS,min(JDE-1,JTE)
+         do K=1,num_soil_top_cat
+          do I=ITS,min(IDE-1,ITE)
+          grid%SOILCTOP(I,K,J)=soil_top_cat_input(I,J,K)
+          enddo
+         enddo
+        enddo
+
+        do J=JTS,min(JDE-1,JTE)
+         do K=1,num_soil_bot_cat
+          do I=ITS,min(IDE-1,ITE)
+          grid%SOILCBOT(I,K,J)=soil_bot_cat_input(I,J,K)
+          enddo
+         enddo
+        enddo
+
+        do J=JTS,min(JDE-1,JTE)
+         do K=1,num_veg_cat
+          do I=ITS,min(IDE-1,ITE)
+          grid%LANDUSEF(I,K,J)=landuse_frac_input(I,J,K)
+          enddo
+         enddo
+        enddo
+
+
+      do K=KDS,KDE
+        grid%nmm_ETAX(K)=ETAX_in(KDE-K+1)
+        grid%nmm_ETA1(K)=ETA1_in(KDE-K+1)
+        grid%nmm_ETA2(K)=ETA2_in(KDE-K+1)
+        grid%nmm_DFL(K)=DFL_in(KDE-K+1)
+      enddo
+
+      do K=KDS,KDE-1
+        grid%nmm_DETA(K)=DETA_in(KDE-K)
+        grid%nmm_DETA1(K)=DETA1_in(KDE-K)
+        grid%nmm_DETA2(K)=DETA2_in(KDE-K)
+        grid%nmm_AETA(K)=AETA_in(KDE-K)
+        grid%nmm_AETA1(K)=AETA1_in(KDE-K)
+        grid%nmm_AETA2(K)=AETA2_in(KDE-K)
+      enddo
+
+   END SUBROUTINE read_si
+
+END MODULE module_si_io_nmm
diff --git a/wrfv2_fire/dyn_nmm/nmm_loop_basemacros.h b/wrfv2_fire/dyn_nmm/nmm_loop_basemacros.h
new file mode 100644
index 00000000..3cb00bf6
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/nmm_loop_basemacros.h
@@ -0,0 +1,9 @@
+! these define the various loop range variables
+! that were defined in module_MPP. Defined as macros
+! here to allow thread-safety/tile callability
+
+#define MY_IS(A,B) max(ids+(A),its-(B))
+#define MY_IE(A,B) min(ide-(A),ite+(B))
+#define MY_JS(A,B) max(jds+(A),jts-(B))
+#define MY_JE(A,B) min(jde-(A),jte+(B))
+
diff --git a/wrfv2_fire/dyn_nmm/nmm_loop_macros.h b/wrfv2_fire/dyn_nmm/nmm_loop_macros.h
new file mode 100644
index 00000000..53519330
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/nmm_loop_macros.h
@@ -0,0 +1,128 @@
+! these define the various loop range variables
+! that were defined in module_MPP. Defined as macros
+! here to allow thread-safety/tile callability
+
+#define MYIS      MY_IS( 0 , 0  )
+#define MYIS_P1   MY_IS( 0 , 1  )
+#define MYIS_P2   MY_IS( 0 , 2  )
+#define MYIS_P3   MY_IS( 0 , 3  )
+#define MYIS_P4   MY_IS( 0 , 4  )
+#define MYIS_P5   MY_IS( 0 , 5  )
+#define MYIS1     MY_IS( 1 , 0  )
+#define MYIS1_P1  MY_IS( 1 , 1  )
+#define MYIS1_P2  MY_IS( 1 , 2  )
+#define MYIS1_P3  MY_IS( 1 , 3  )
+#define MYIS1_P4  MY_IS( 1 , 4  )
+#define MYIS1_P5  MY_IS( 1 , 5  )
+#define MYIS2     MY_IS( 2 , 0  )
+#define MYIS2_P1  MY_IS( 2 , 1  )
+#define MYIS2_P2  MY_IS( 2 , 2  )
+#define MYIS2_P3  MY_IS( 2 , 3  )
+#define MYIS2_P4  MY_IS( 2 , 4  )
+#define MYIS2_P5  MY_IS( 2 , 5  )
+#define MYIS3     MY_IS( 3 , 0  )
+#define MYIS3_P1  MY_IS( 3 , 1  )
+#define MYIS3_P2  MY_IS( 3 , 2  )
+#define MYIS3_P3  MY_IS( 3 , 3  )
+#define MYIS3_P4  MY_IS( 3 , 4  )
+#define MYIS3_P5  MY_IS( 3 , 5  )
+#define MYIS4     MY_IS( 4 , 0  )
+#define MYIS4_P1  MY_IS( 4 , 1  )
+#define MYIS4_P2  MY_IS( 4 , 2  )
+#define MYIS4_P3  MY_IS( 4 , 3  )
+#define MYIS4_P4  MY_IS( 4 , 4  )
+#define MYIS4_P5  MY_IS( 4 , 5  )
+
+#define MYIE      MY_IE( 0 , 0  )
+#define MYIE_P1   MY_IE( 0 , 1  )
+#define MYIE_P2   MY_IE( 0 , 2  )
+#define MYIE_P3   MY_IE( 0 , 3  )
+#define MYIE_P4   MY_IE( 0 , 4  )
+#define MYIE_P5   MY_IE( 0 , 5  )
+#define MYIE1     MY_IE( 1 , 0  )
+#define MYIE1_P1  MY_IE( 1 , 1  )
+#define MYIE1_P2  MY_IE( 1 , 2  )
+#define MYIE1_P3  MY_IE( 1 , 3  )
+#define MYIE1_P4  MY_IE( 1 , 4  )
+#define MYIE1_P5  MY_IE( 1 , 5  )
+#define MYIE2     MY_IE( 2 , 0  )
+#define MYIE2_P1  MY_IE( 2 , 1  )
+#define MYIE2_P2  MY_IE( 2 , 2  )
+#define MYIE2_P3  MY_IE( 2 , 3  )
+#define MYIE2_P4  MY_IE( 2 , 4  )
+#define MYIE2_P5  MY_IE( 2 , 5  )
+#define MYIE3     MY_IE( 3 , 0  )
+#define MYIE3_P1  MY_IE( 3 , 1  )
+#define MYIE3_P2  MY_IE( 3 , 2  )
+#define MYIE3_P3  MY_IE( 3 , 3  )
+#define MYIE3_P4  MY_IE( 3 , 4  )
+#define MYIE3_P5  MY_IE( 3 , 5  )
+#define MYIE4     MY_IE( 4 , 0  )
+#define MYIE4_P1  MY_IE( 4 , 1  )
+#define MYIE4_P2  MY_IE( 4 , 2  )
+#define MYIE4_P3  MY_IE( 4 , 3  )
+#define MYIE4_P4  MY_IE( 4 , 4  )
+#define MYIE4_P5  MY_IE( 4 , 5  )
+
+#define MYJS      MY_JS( 0 , 0  )
+#define MYJS_P1   MY_JS( 0 , 1  )
+#define MYJS_P2   MY_JS( 0 , 2  )
+#define MYJS_P3   MY_JS( 0 , 3  )
+#define MYJS_P4   MY_JS( 0 , 4  )
+#define MYJS_P5   MY_JS( 0 , 5  )
+#define MYJS1     MY_JS( 1 , 0  )
+#define MYJS1_P1  MY_JS( 1 , 1  )
+#define MYJS1_P2  MY_JS( 1 , 2  )
+#define MYJS1_P3  MY_JS( 1 , 3  )
+#define MYJS1_P4  MY_JS( 1 , 4  )
+#define MYJS1_P5  MY_JS( 1 , 5  )
+#define MYJS2     MY_JS( 2 , 0  )
+#define MYJS2_P1  MY_JS( 2 , 1  )
+#define MYJS2_P2  MY_JS( 2 , 2  )
+#define MYJS2_P3  MY_JS( 2 , 3  )
+#define MYJS2_P4  MY_JS( 2 , 4  )
+#define MYJS2_P5  MY_JS( 2 , 5  )
+#define MYJS3     MY_JS( 3 , 0  )
+#define MYJS3_P1  MY_JS( 3 , 1  )
+#define MYJS3_P2  MY_JS( 3 , 2  )
+#define MYJS3_P3  MY_JS( 3 , 3  )
+#define MYJS3_P4  MY_JS( 3 , 4  )
+#define MYJS3_P5  MY_JS( 3 , 5  )
+#define MYJS4     MY_JS( 4 , 0  )
+#define MYJS4_P1  MY_JS( 4 , 1  )
+#define MYJS4_P2  MY_JS( 4 , 2  )
+#define MYJS4_P3  MY_JS( 4 , 3  )
+#define MYJS4_P4  MY_JS( 4 , 4  )
+#define MYJS4_P5  MY_JS( 4 , 5  )
+
+#define MYJE      MY_JE( 0 , 0  )
+#define MYJE_P1   MY_JE( 0 , 1  )
+#define MYJE_P2   MY_JE( 0 , 2  )
+#define MYJE_P3   MY_JE( 0 , 3  )
+#define MYJE_P4   MY_JE( 0 , 4  )
+#define MYJE_P5   MY_JE( 0 , 5  )
+#define MYJE1     MY_JE( 1 , 0  )
+#define MYJE1_P1  MY_JE( 1 , 1  )
+#define MYJE1_P2  MY_JE( 1 , 2  )
+#define MYJE1_P3  MY_JE( 1 , 3  )
+#define MYJE1_P4  MY_JE( 1 , 4  )
+#define MYJE1_P5  MY_JE( 1 , 5  )
+#define MYJE2     MY_JE( 2 , 0  )
+#define MYJE2_P1  MY_JE( 2 , 1  )
+#define MYJE2_P2  MY_JE( 2 , 2  )
+#define MYJE2_P3  MY_JE( 2 , 3  )
+#define MYJE2_P4  MY_JE( 2 , 4  )
+#define MYJE2_P5  MY_JE( 2 , 5  )
+#define MYJE3     MY_JE( 3 , 0  )
+#define MYJE3_P1  MY_JE( 3 , 1  )
+#define MYJE3_P2  MY_JE( 3 , 2  )
+#define MYJE3_P3  MY_JE( 3 , 3  )
+#define MYJE3_P4  MY_JE( 3 , 4  )
+#define MYJE3_P5  MY_JE( 3 , 5  )
+#define MYJE4     MY_JE( 4 , 0  )
+#define MYJE4_P1  MY_JE( 4 , 1  )
+#define MYJE4_P2  MY_JE( 4 , 2  )
+#define MYJE4_P3  MY_JE( 4 , 3  )
+#define MYJE4_P4  MY_JE( 4 , 4  )
+#define MYJE4_P5  MY_JE( 4 , 5  )
+
diff --git a/wrfv2_fire/dyn_nmm/read_nmm.F b/wrfv2_fire/dyn_nmm/read_nmm.F
new file mode 100644
index 00000000..3f59baf4
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/read_nmm.F
@@ -0,0 +1,970 @@
+!WRF:MEDIATION_LAYER:
+!
+
+SUBROUTINE med_read_nmm ( grid , config_flags , ntsd, dt_from_file, tstart_from_file, tend_from_file &
+!
+#include 
+!
+     )
+  ! Driver layer
+   USE module_domain
+   USE module_io_domain
+  ! Model layer
+   USE module_configure
+   USE module_bc_time_utilities
+!----------------------------------------------------------------------
+
+   IMPLICIT NONE
+
+!----------------------------------------------------------------------
+
+  ! Arguments
+   TYPE(domain)                               :: grid
+   TYPE (grid_config_rec_type) , INTENT(IN)   :: config_flags
+
+#include 
+
+!----------------------------------------------------------------------
+  ! Local
+
+   REAL, DIMENSION(1:2*NMM_MAX_DIM,2)           :: PDB
+   REAL, DIMENSION(1:2*NMM_MAX_DIM,grid%sd32:grid%ed32-1,2) :: TB,QB,UB,VB,Q2B,CWMB
+
+   INTEGER :: NUNIT_PARMETA=10,NUNIT_FCSTDATA=11                  &
+             ,NUNIT_NHB=12,NUNIT_CO2=14,NUNIT_Z0=22
+   INTEGER :: NMAP,NRADSH,NRADLH,NTDDMP
+   INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE
+   INTEGER :: IPS,IPE,JPS,JPE,KPS,KPE
+   INTEGER :: IMS,IME,JMS,JME,KMS,KME
+   INTEGER :: IM,JM,LM,NROOT,INPES,JNPES,NFCST,NUNIT_NBC,LISTB
+!!!INTEGER :: I,J,K,IHRST,JAM,NTSD,IHRSTB,IHH,IHL
+   INTEGER :: I,J,K,IHRST,JAM,IHRSTB,IHH,IHL
+   INTEGER :: KBI,KBI2,LRECBC
+   INTEGER :: N,ISTART,LB,NREC
+! Addition, JM 20050819
+! Rconfig variables no longer passed through dummy arg list or declared
+! in nmm_dummy_decl. Declare them local here.
+   INTEGER :: NSOIL,NPHS,NCNVC,IDTAD,SIGMA,NRADS,NRADL
+   REAL    :: DT
+! End addition, JM 20050819
+   INTEGER,DIMENSION(3) :: IDAT,IDATB
+   LOGICAL :: RESTRT,SINGLRST,NEST,RUN,RUNB
+   REAL :: TSTART,TEND,TPREC,THEAT,TCLOD,TRDSW,TRDLW,TSRFC
+   REAL :: BCHR,TSTEPS,TSPH,TBOCO
+   REAL,DIMENSION(39) :: SPL
+   REAL,DIMENSION(99) :: TSHDE
+   REAL,ALLOCATABLE,DIMENSION(:) :: TEMP1
+   REAL,ALLOCATABLE,DIMENSION(:,:) :: TEMP
+   INTEGER,ALLOCATABLE,DIMENSION(:,:) :: ITEMP
+   REAL,ALLOCATABLE,DIMENSION(:,:,:) :: HOLD
+   REAL ::                      TDDAMP                     &
+                                            ,ETA
+   REAL :: PLQ,RDPQ,RDTHEQ,STHEQ,THE0Q
+   REAL :: ROS,CS,DS,ROI,CI,DI                             &
+          ,PL,THL,RDQ,RDTH,RDP,RDTHE                       &
+                ,QS0,SQS,STHE,THE0
+!!!tlb   REAL :: PTBL,TTBL                                       &
+   REAL :: WBD,SBD,TLM0D,TPH0D,R,        CMLD,DP30               &
+    ,X1P,Y1P,IXM,IYM
+   INTEGER :: NN, mype
+   REAL :: dt_from_file
+   REAL :: tstart_from_file, tend_from_file
+   real :: dtx
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+
+
+
+!**********************************************************************
+!
+!***  Temporary fix for reading in lookup tables
+!
+   INTEGER,PARAMETER :: ITB=76,JTB=134,ITBQ=152,JTBQ=440
+   REAL,DIMENSION(ITB,JTB) :: PTBL
+   REAL,DIMENSION(JTB,ITB) :: TTBL
+   REAL,DIMENSION(JTBQ,ITBQ) :: TTBLQ
+!**********************************************************************
+   CHARACTER*256 mess
+!----------------------------------------------------------------------
+! small file with global dimensions
+   NAMELIST /PARMNMM/ IM,JM,LM,NSOIL,NROOT,INPES,JNPES
+!
+! another small file with forecast parameters
+   NAMELIST /FCSTDATA/                                            &
+    TSTART,TEND,RESTRT,SINGLRST,NMAP,TSHDE,SPL                    &
+   ,NPHS,NCNVC,NRADSH,NRADLH,NTDDMP                               &
+   ,TPREC,THEAT,TCLOD,TRDSW,TRDLW,TSRFC                           &
+   ,NEST,HYDRO
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+#include "deref_kludge.h"
+#define COPY_IN
+#include 
+#ifdef DM_PARALLEL
+#    include 
+#endif
+
+!
+   REWIND NUNIT_PARMETA
+   READ(NUNIT_PARMETA,PARMNMM)
+   NSOIL=4
+      write(0,*)' assigned nsoil=',nsoil
+   CALL wrf_debug ( 100 , 'nmm: read global dimensions file' )
+
+! temporarily produce array limits here
+!   IDS=1
+!   IDE=IM
+!   JDS=1
+!   JDE=JM
+!   KDS=1
+!   KDE=LM
+
+!----------------------------------------------------------------------
+  CALL get_ijk_from_grid (  grid ,                   &
+                            ids, ide, jds, jde, kds, kde,    &
+                            ims, ime, jms, jme, kms, kme,    &
+                            ips, ipe, jps, jpe, kps, kpe    )
+
+! GLOBAL GRID DIMS ARE WHAT WRF CONSIDERS UNSTAGGERED
+   ide = ide - 1
+   jde = jde - 1
+   kde = kde - 1
+   NSOIL=4
+
+   CALL wrf_debug(100,'in mediation_read_nmm')
+   WRITE(mess,*)'ids,ide,jds,jde,kds,kde ',ids,ide,jds,jde,kds,kde
+   CALL wrf_debug(100,mess)
+
+!----------------------------------------------------------------------
+! read constants file
+      write(0,*)' before allocates and nhb nsoil=',nsoil
+   ALLOCATE(TEMP1(1:NSOIL),STAT=I)
+   ALLOCATE(ITEMP(IDS:IDE,JDS:JDE),STAT=I)
+   ALLOCATE(TEMP(IDS:IDE,JDS:JDE),STAT=I)
+   ALLOCATE(HOLD(IDS:IDE,JDS:JDE,KDS:KDE),STAT=I)
+!
+!----------------------------------------------------------------------
+! read z0 file
+      READ(NUNIT_Z0)TEMP
+      DO J=JDS,JDE
+      DO I=IDS,IDE
+        Z0(I,J)=TEMP(I,J)
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+!
+   READ(NUNIT_NHB) NFCST,NUNIT_NBC,LISTB,DT,IDTAD,SIGMA
+      write(0,*)' read_nmm sigma=',sigma
+   dt_from_file = dt
+   WRITE( mess, * ) 'NFCST = ',NFCST,'  DT  = ',DT
+   WRITE( 0, * ) 'NFCST = ',NFCST,'  DT  = ',DT,' NHB=',NUNIT_NHB 
+   CALL wrf_debug(100, mess)
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) ITEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       LMH(I,J)=ITEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) ITEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       LMV(I,J)=ITEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       HBM2(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       HBM3(I,J)=0.
+     ENDDO
+   ENDDO
+!
+   DO J=JDS,JDE
+     IHWG(J)=MOD(J+1,2)-1
+     IF(J.GE.JDS+3.AND.J.LE.JDE-3)THEN
+       IHL=2-IHWG(J)
+!      IHWG=MOD(J+1,2)-1
+!      IHL=2-IHWG
+       IHL=2-IHWG(J)
+       IHH=IDE-2
+       DO I=IDS,IDE
+         IF(I.GE.IHL.AND.I.LE.IHH)HBM3(I,J)=1.
+       ENDDO
+     ENDIF
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       VBM2(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       VBM3(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       SM(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       SICE(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NUNIT_NHB)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read HTM into HOLD' )
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         HTM(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read of record' )
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NUNIT_NHB)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read VTM into HOLD' )
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         VTM(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read VTM' )
+!----------------------------------------------------------------------
+   JAM=6+2*(JDE-JDS-9)
+   READ(NUNIT_NHB)DY_NMM,CPGFV,EN,ENT,R,PT,TDDAMP                 &
+                 ,F4D,F4Q,EF4T,PDTOP                              &
+                 ,(DETA(KME-K),K=KMS,KME-1)                       &
+                 ,(AETA(KME-K),K=KMS,KME-1)                       &
+                 ,(F4Q2(KME-K),K=KMS,KME-1)                       &
+                 ,(ETAX(KME+1-K),K=KMS,KME)                       &
+                 ,(DFL(KME+1-K),K=KMS,KME)                        &
+                 ,(DETA1(KME-K),K=KMS,KME-1)                      &
+                 ,(AETA1(KME-K),K=KMS,KME-1)                      &
+                 ,(ETA1(KME+1-K),K=KMS,KME)                       &
+                 ,(DETA2(KME-K),K=KMS,KME-1)                      &
+                 ,(AETA2(KME-K),K=KMS,KME-1)                      &
+                 ,(ETA2(KME+1-K),K=KMS,KME)                       &
+                 ,(EM(K),K=1,JAM)                                 &
+                 ,(EMT(K),K=1,JAM)
+   CALL wrf_debug ( 100 , 'nmm: read NMM_DX_NMM' )
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       DX_NMM(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_WPDAR' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       WPDAR(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_CPGFU' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       CPGFU(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_CURV' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       CURV(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_FCP' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       FCP(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   CALL wrf_debug ( 100 , 'nmm: read NMM_FDIV' )
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       FDIV(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   CALL wrf_debug ( 100 , 'nmm: read NMM_FAD' )
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       FAD(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_F' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       F(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_DDMPU' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       DDMPU(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_DDMPV' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       DDMPV(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_GLAT' )
+   READ(NUNIT_NHB) PT, TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       GLAT(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read NMM_GLON' )
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       GLON(I,J)=-TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read PLQ,RDPQ,RDTHEQ,STHEQ,THE0Q' )
+   READ(NUNIT_NHB)PLQ,RDPQ,RDTHEQ,STHEQ,THE0Q
+!                ,(STHEQ(K),K=1,ITBQ)                             &
+!                ,(THE0Q(K),K=1,ITBQ)
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read ROS,CS,DS,ROI,CI,DI' )
+   READ(NUNIT_NHB)ROS,CS,DS,ROI,CI,DI                             &
+           ,PL,THL,RDQ,RDTH,RDP,RDTHE                             &
+           ,(DETA(KME-K),K=KMS,KME-1)                             &
+           ,(AETA(KME-K),K=KMS,KME-1)                             &
+           ,(DFRLG(KME+1-K),K=KMS,KME)                            &
+           ,(DETA1(KME-K),K=KMS,KME-1)                            &
+           ,(AETA1(KME-K),K=KMS,KME-1)                            &
+           ,(DETA2(KME-K),K=KMS,KME-1)                            &
+           ,(AETA2(KME-K),K=KMS,KME-1)                            &
+           ,QS0,SQS,STHE,THE0
+!          ,(QS0(K),K=1,JTB)                                      &
+!          ,(SQS(K),K=1,JTB)                                      &
+!          ,(STHE(K),K=1,ITB)                                     &                
+!          ,(THE0(K),K=1,ITB)
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       MXSNAL(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       EPSR(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       TG(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       GFFC(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       SST(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       ALBASE(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       HDAC(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       HDACV(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+!!!tlb   READ(NUNIT_NHB) TEMP
+    READ(NUNIT_NHB) TTBLQ
+!   DO J=JDS,JDE
+!     DO I=IDS,IDE
+!       TTBLQ(I,J)=TEMP(I,J)
+!     ENDDO
+!   ENDDO
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read PTBL,TTBL' )
+        READ(NUNIT_NHB)PTBL,TTBL                                       &
+                ,R,PT,TSPH                                             &
+                ,WBD,SBD,TLM0D,TPH0D,DLMD,DPHD,CMLD,DP30               &
+                ,X1P,Y1P,IXM,IYM                                       &
+                ,(DETA(KME-K),K=KMS,KME-1)                             &
+                ,(AETA(KME-K),K=KMS,KME-1)                             &
+                ,(ETAX(KME+1-K),K=KMS,KME)                             &
+                ,(DETA1(KME-K),K=KMS,KME-1)                            &
+                ,(AETA1(KME-K),K=KMS,KME-1)                            &
+                ,(ETA1(KME+1-K),K=KMS,KME)                             &
+                ,(DETA2(KME-K),K=KMS,KME-1)                            &
+                ,(AETA2(KME-K),K=KMS,KME-1)                            &
+                ,(ETA2(KME+1-K),K=KMS,KME)                              
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) ITEMP
+    DO J=JDS,JDE
+      DO I=IDS,IDE
+        IVGTYP(I,J)=ITEMP(I,J)
+      ENDDO
+    ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) ITEMP
+    DO J=JDS,JDE
+      DO I=IDS,IDE
+        ISLTYP(I,J)=ITEMP(I,J)
+      ENDDO
+    ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) ITEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       ISLOPE(I,J)=ITEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       VEGFRC(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) (SLDPTH(N),N=1,NSOIL)
+!----------------------------------------------------------------------
+   READ(NUNIT_NHB) (RTDPTH(N),N=1,NSOIL)
+!----------------------------------------------------------------------
+   CALL wrf_debug ( 100 , 'nmm: read constants file' )
+
+   REWIND NUNIT_FCSTDATA
+   READ(NUNIT_FCSTDATA,FCSTDATA)
+   tstart_from_file = tstart
+   tend_from_file   = tend
+   CALL wrf_debug ( 100 , 'nmm: read forecast parameters file' )
+!----------------------------------------------------------------------
+
+   nrads = nint(nradsh*tsph)
+   nradl = nint(nradlh*tsph)
+!----------------------------------------------------------------------
+!
+! INITIAL CONDITIONS
+!
+!----------------------------------------------------------------------
+   REWIND NFCST
+   READ(NFCST)RUN,IDAT,IHRST,NTSD
+   IF(NTSD.EQ.1)NTSD=0
+!----------------------------------------------------------------------
+   READ(NFCST) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       PD(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NFCST) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       RES(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+!----------------------------------------------------------------------
+   READ(NFCST) TEMP
+   DO J=JDS,JDE
+     DO I=IDS,IDE
+       FIS(I,J)=TEMP(I,J)
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read FIS' )
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NFCST)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read U into HOLD' )
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         U(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read U' )
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NFCST)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         V(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read V' )
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NFCST)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         T(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read T' )
+!----------------------------------------------------------------------
+   DO K=KDE,KDS,-1
+     READ(NFCST)((HOLD(I,J,K),I=IDS,IDE),J=JDS,JDE)
+   ENDDO
+   DO K=KDS,KDE
+     DO J=JDS,JDE
+       DO I=IDS,IDE
+         Q(I,K,J)=HOLD(I,J,K)
+       ENDDO
+     ENDDO
+   ENDDO
+   CALL wrf_debug ( 100 , 'nmm: read Q' )
+!----------------------------------------------------------------------
+   READ(NFCST)((SI(I,J),I=IDS,IDE),J=JDS,JDE)
+   READ(NFCST)((SNO(I,J),I=IDS,IDE),J=JDS,JDE)
+!  READ(NFCST)(((SMC(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+   READ(NFCST)(((hold(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+      do k=1,nsoil
+        do j=jds,jde
+        do i=ids,ide
+          smc(i,k,j)=hold(i,j,k)
+        enddo
+        enddo
+      enddo
+   READ(NFCST)((CMC(I,J),I=IDS,IDE),J=JDS,JDE)
+!  READ(NFCST)(((STC(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+   READ(NFCST)(((hold(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+   do k=1,nsoil
+     do j=jds,jde
+     do i=ids,ide
+       stc(i,k,j)=hold(i,j,k)
+     enddo
+     enddo
+   enddo
+!  READ(NFCST)(((SH2O(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+   READ(NFCST)(((hold(I,J,N),I=IDS,IDE),J=JDS,JDE),N=1,NSOIL)
+   do k=1,nsoil
+     do j=jds,jde
+     do i=ids,ide
+       sh2o(i,k,j)=hold(i,j,k)
+!      sh2o(i,k,j)=0.05
+     enddo
+     enddo
+   enddo
+   CALL wrf_debug ( 100 , 'nmm: read initial conditions file' )
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!
+ENTRY med_read_nmm_bdy ( grid , config_flags , ntsd , dt_from_file, tstart_from_file, tend_from_file &
+!
+#include 
+!
+     )
+!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+!----------------------------------------------------------------------
+!***  READ BOUNDARY CONDITIONS.
+!----------------------------------------------------------------------
+!
+      DT = dt_from_file
+  CALL get_ijk_from_grid (  grid ,                   &
+                            ids, ide, jds, jde, kds, kde,    &
+                            ims, ime, jms, jme, kms, kme,    &
+                            ips, ipe, jps, jpe, kps, kpe    )
+
+! GLOBAL GRID DIMS ARE WHAT WRF CONSIDERS UNSTAGGERED
+   ide = ide - 1
+   jde = jde - 1
+   kde = kde - 1
+   NSOIL=4
+
+   CALL wrf_debug(100,'in mediation_read_nmm')
+   WRITE(mess,*)'ids,ide,jds,jde,kds,kde ',ids,ide,jds,jde,kds,kde
+   CALL wrf_debug(100,mess)
+
+      mype = 0
+      IF(MYPE.EQ.0)THEN
+        IF(NEST)THEN
+          KBI=2*IM+JM-3
+          KBI2=KBI-4
+#ifdef DEC_ALPHA
+          LRECBC=(1+(1+6*LM)*KBI*2+(KBI+KBI2)*(LM+1))
+#else
+          LRECBC=4*(1+(1+6*LM)*KBI*2+(KBI+KBI2)*(LM+1))
+#endif
+          OPEN(UNIT=NUNIT_NBC,ACCESS='DIRECT',RECL=LRECBC)
+          read(nunit_nbc,rec=2) bchr
+        ENDIF
+!
+        IF(.NOT.NEST)REWIND NUNIT_NBC
+!
+#ifdef DP_REAL
+        IF(NEST)THEN
+          READ(NUNIT_NBC,REC=1)RUNBX,IDATBX,IHRSTBX,TBOCO
+        ELSE
+          READ(NUNIT_NBC)RUNBX,IDATBX,IHRSTBX,TBOCO
+        ENDIF
+!
+        RUNB=RUNBX
+        IDATB=IDATBX
+        IHRSTB=IHRSTBX
+#else
+        IF(NEST)THEN
+          READ(NUNIT_NBC,REC=1)RUNB,IDATB,IHRSTB,TBOCO
+        ELSE
+          READ(NUNIT_NBC)RUNB,IDATB,IHRSTB,TBOCO
+        ENDIF
+#endif
+      ENDIF
+!
+!      CALL MPI_BCAST(RUNB,1,MPI_LOGICAL,0,MPI_COMM_COMP,IRTN)
+!      CALL MPI_BCAST(IDATB,3,MPI_INTEGER,0,MPI_COMM_COMP,IRTN)
+!      CALL MPI_BCAST(IHRSTB,1,MPI_INTEGER,0,MPI_COMM_COMP,IRTN)
+!      CALL MPI_BCAST(TBOCO,1,MPI_REAL,0,MPI_COMM_COMP,IRTN)
+!
+!      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!
+      ISTART=NINT(TSTART)
+      LB=2*(IDE-IDS+1)+(JDE-JDS+1)-3
+!
+
+      IF(MYPE.EQ.0.AND..NOT.NEST)THEN
+!
+        READ(NUNIT_NBC)BCHR
+  205   READ(NUNIT_NBC)((PDB(N,I),N=1,LB),I=1,2)
+        READ(NUNIT_NBC)(((TB(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+        READ(NUNIT_NBC)(((QB(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+        READ(NUNIT_NBC)(((UB(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+        READ(NUNIT_NBC)(((VB(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+        READ(NUNIT_NBC)(((Q2B(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+        READ(NUNIT_NBC)(((CWMB(N,K,I),N=1,LB),K=KDE,KDS,-1),I=1,2)
+!
+        IF(ISTART.EQ.NINT(BCHR))THEN
+          IF(ISTART.GT.0)READ(NUNIT_NBC)BCHR
+          GO TO 215
+        ELSE
+          READ(NUNIT_NBC)BCHR
+        ENDIF
+!
+      write(0,*)' read_nmm istart=',istart,' bchr=',bchr,' tsph=',tsph
+        IF(ISTART.GE.NINT(BCHR))THEN
+          GO TO 205
+        ELSEIF(ISTART.LT.NINT(BCHR))THEN
+          TSTEPS=ISTART*TSPH
+!
+          DO N=1,LB
+      if(n==5.or.n==6)then
+        write(0,*)' read_nmm i=',i,' pdb(1)=',pdb(n,1),' pdb(2)=',pdb(n,2),' dt=',dt,' tsteps=',tsteps
+      endif
+            PDB(N,1)=PDB(N,1)+PDB(N,2)*DT*TSTEPS
+          ENDDO
+!
+          DO K=1,LM
+          DO N=1,LB
+            TB(N,K,1)=TB(N,K,1)+TB(N,K,2)*DT*TSTEPS
+            QB(N,K,1)=QB(N,K,1)+QB(N,K,2)*DT*TSTEPS
+            UB(N,K,1)=UB(N,K,1)+UB(N,K,2)*DT*TSTEPS
+            VB(N,K,1)=VB(N,K,1)+VB(N,K,2)*DT*TSTEPS
+            Q2B(N,K,1)=Q2B(N,K,1)+Q2B(N,K,2)*DT*TSTEPS
+            CWMB(N,K,1)=CWMB(N,K,1)+CWMB(N,K,2)*DT*TSTEPS
+          ENDDO
+          ENDDO
+          GO TO 215
+        ENDIF
+      ENDIF
+!
+      IF(MYPE.EQ.0.AND.NEST)THEN
+        NREC=1
+!
+  210   NREC=NREC+1
+        READ(NUNIT_NBC,REC=NREC)BCHR
+!
+        IF(ISTART.EQ.NINT(BCHR))THEN
+!!!!!     IF(ISTART.GT.0)READ(NUNIT_NBC,REC=NREC+1)BCHR
+          GO TO 215
+        ELSE
+          GO TO 210
+        ENDIF
+      ENDIF
+!
+  215 CONTINUE
+
+      IF(NTSD.EQ.0)THEN
+        IF(MYPE.EQ.0.AND..NOT.NEST.AND.ISTART.GE.NINT(BCHR))THEN
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+          BACKSPACE NUNIT_NBC
+!          WRITE(LIST,*)'  BACKSPACE UNIT NBC=',NUNIT_NBC
+        ENDIF
+      ENDIF
+
+      IF(MYPE.EQ.0.AND.NEST)THEN
+          NREC=NINT(((NTSD-1)*DT)/3600.)+2
+          READ(NUNIT_NBC,REC=NREC)BCHR                                  &
+                         ,((PDB(N,NN),N=1,LB),NN=1,2)                  &
+                         ,(((TB(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)   &
+                         ,(((QB(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)   &
+                         ,(((UB(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)   &
+                         ,(((VB(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)   &
+                        ,(((Q2B(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)   &
+                       ,(((CWMB(N,K,NN),N=1,LB),K=KDE,KDS,-1),NN=1,2)
+      ENDIF
+
+! Copy the bounary into the WRF framework boundary data structs
+
+      N=1
+!
+!***  SOUTH BOUNDARY
+!
+      DO I=1,IDE
+        PD_B(I,1,1,P_YSB) = PDB(N,1)
+        PD_BT(I,1,1,P_YSB) = PDB(N,2)
+        N=N+1
+      ENDDO
+!
+!***  NORTH BOUNDARY
+!
+      DO I=1,IDE
+        PD_B(I,1,1,P_YEB) = PDB(N,1)
+        PD_BT(I,1,1,P_YEB) = PDB(N,2)
+        N=N+1
+      ENDDO
+!
+!***  WEST BOUNDARY
+!
+      DO J=3,JDE-2,2
+        PD_B(J,1,1,P_XSB) = PDB(N,1)
+        PD_BT(J,1,1,P_XSB) = PDB(N,2)
+        N=N+1
+      ENDDO
+!
+!***  EAST BOUNDARY
+!
+      DO J=3,JDE-2,2
+        PD_B(J,1,1,P_XEB) = PDB(N,1)
+        PD_BT(J,1,1,P_XEB) = PDB(N,2)
+        N=N+1
+      ENDDO
+!
+      DO K=KDS,KDE
+        N=1
+!
+!***  SOUTH BOUNDARY
+!
+        DO I=1,IDE
+          T_B(I,k,1,P_YSB) = TB(N,k,1)
+          T_BT(I,k,1,P_YSB) = TB(N,k,2)
+          Q_B(I,k,1,P_YSB) = QB(N,k,1)
+          Q_BT(I,k,1,P_YSB) = QB(N,k,2)
+          Q2_B(I,k,1,P_YSB) = Q2B(N,k,1)
+          Q2_BT(I,k,1,P_YSB) = Q2B(N,k,2)
+          CWM_B(I,k,1,P_YSB) = CWMB(N,k,1)
+          CWM_BT(I,k,1,P_YSB) = CWMB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  NORTH BOUNDARY
+!
+        DO I=1,IDE
+          T_B(I,k,1,P_YEB) = TB(N,k,1)
+          T_BT(I,k,1,P_YEB) = TB(N,k,2)
+          Q_B(I,k,1,P_YEB) = QB(N,k,1)
+          Q_BT(I,k,1,P_YEB) = QB(N,k,2)
+          Q2_B(I,k,1,P_YEB) = Q2B(N,k,1)
+          Q2_BT(I,k,1,P_YEB) = Q2B(N,k,2)
+          CWM_B(I,k,1,P_YEB) = CWMB(N,k,1)
+          CWM_BT(I,k,1,P_YEB) = CWMB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  WEST BOUNDARY
+!
+        DO J=3,JDE-2,2
+          T_B(J,k,1,P_XSB) = TB(N,k,1)
+          T_BT(J,k,1,P_XSB) = TB(N,k,2)
+          Q_B(J,k,1,P_XSB) = QB(N,k,1)
+          Q_BT(J,k,1,P_XSB) = QB(N,k,2)
+          Q2_B(J,k,1,P_XSB) = Q2B(N,k,1)
+          Q2_BT(J,k,1,P_XSB) = Q2B(N,k,2)
+          CWM_B(J,k,1,P_XSB) = CWMB(N,k,1)
+          CWM_BT(J,k,1,P_XSB) = CWMB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  EAST BOUNDARY
+!
+        DO J=3,JDE-2,2
+          T_B(J,k,1,P_XEB) = TB(N,k,1)
+          T_BT(J,k,1,P_XEB) = TB(N,k,2)
+      if(k.eq.1.and.j.eq.79)then
+        write(0,62510)ntsd,nrec
+        write(0,62511)p_xeb,t_b(j,k,1,p_xeb),t_bt(j,k,1,p_xeb)
+62510   format(' ntsd=',i5,' nrec=',i5)
+62511   format(' p_xeb=',i2,' t_b=',z8,' t_bt=',z8)
+      endif
+          Q_B(J,k,1,P_XEB) = QB(N,k,1)
+          Q_BT(J,k,1,P_XEB) = QB(N,k,2)
+          Q2_B(J,k,1,P_XEB) = Q2B(N,k,1)
+          Q2_BT(J,k,1,P_XEB) = Q2B(N,k,2)
+          CWM_B(J,k,1,P_XEB) = CWMB(N,k,1)
+          CWM_BT(J,k,1,P_XEB) = CWMB(N,k,2)
+          N=N+1
+        ENDDO
+      ENDDO
+
+      DO K=KDS,KDE
+        N=1
+!
+!***  SOUTH BOUNDARY
+!
+        DO I=1,IDE-1
+          U_B(I,k,1,P_YSB) = UB(N,k,1)
+          U_BT(I,k,1,P_YSB) = UB(N,k,2)
+          V_B(I,k,1,P_YSB) = VB(N,k,1)
+          V_BT(I,k,1,P_YSB) = VB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  NORTH BOUNDARY
+!
+        DO I=1,IDE-1
+          U_B(I,k,1,P_YEB) = UB(N,k,1)
+          U_BT(I,k,1,P_YEB) = UB(N,k,2)
+          V_B(I,k,1,P_YEB) = VB(N,k,1)
+          V_BT(I,k,1,P_YEB) = VB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  WEST BOUNDARY
+!
+        DO J=2,JDE-1,2
+          U_B(J,k,1,P_XSB) = UB(N,k,1)
+          U_BT(J,k,1,P_XSB) = UB(N,k,2)
+          V_B(J,k,1,P_XSB) = VB(N,k,1)
+          V_BT(J,k,1,P_XSB) = VB(N,k,2)
+          N=N+1
+        ENDDO
+!
+!***  EAST BOUNDARY
+!
+        DO J=2,JDE-1,2
+          U_B(J,k,1,P_XEB) = UB(N,k,1)
+          U_BT(J,k,1,P_XEB) = UB(N,k,2)
+          V_B(J,k,1,P_XEB) = VB(N,k,1)
+          V_BT(J,k,1,P_XEB) = VB(N,k,2)
+          N=N+1
+        ENDDO
+      ENDDO
+
+!
+!      CALL MPI_BCAST(BCHR,1,MPI_REAL,0,MPI_COMM_COMP,IRTN)
+!
+!      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!
+!      IF(MYPE.EQ.0)WRITE(LIST,*)'  READ UNIT NBC=',NUNIT_NBC
+!
+!***
+!***  COMPUTE THE 1ST TIME FOR BOUNDARY CONDITION READ
+!***
+!
+!      NBOCO=NINT(BCHR*TSPH)
+!
+
+!
+
+   DEALLOCATE(TEMP1,STAT=I)
+   DEALLOCATE(ITEMP,STAT=I)
+   DEALLOCATE(TEMP,STAT=I)
+   DEALLOCATE(HOLD,STAT=I)
+
+      CALL wrf_debug ( 100 , 'nmm: returnomatic' )
+
+#define COPY_OUT
+#include 
+
+   RETURN
+END SUBROUTINE med_read_nmm
+
diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F
new file mode 100644
index 00000000..70e15183
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/solve_nmm.F
@@ -0,0 +1,2185 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MEDIATION_LAYER:SOLVER
+!
+!-----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!-----------------------------------------------------------------------
+!
+      SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                           &
+!
+#include "nmm_dummy_args.inc"
+!
+     &           )
+!-----------------------------------------------------------------------
+      USE MODULE_DOMAIN
+      USE MODULE_CONFIGURE
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_STATE_DESCRIPTION
+      USE MODULE_CTLBLK
+      USE MODULE_DM
+      USE MODULE_IGWAVE_ADJUST,		ONLY: PDTE,PFDHT,DDAMP,VTOA
+      USE MODULE_ADVECTION,		ONLY: ADVE,VAD2,HAD2,VAD2_SCAL,HAD2_SCAL
+      USE MODULE_NONHY_DYNAM,		ONLY: EPS,VADZ,HADZ
+      USE MODULE_DIFFUSION_NMM, 	ONLY: HDIFF
+      USE MODULE_BNDRY_COND,		ONLY: BOCOH,BOCOV
+      USE MODULE_PHYSICS_CALLS
+      USE MODULE_EXT_INTERNAL
+      USE MODULE_PRECIP_ADJUST
+      USE MODULE_NEST_UTIL
+#ifdef WRF_CHEM
+      USE MODULE_INPUT_CHEM_DATA,       ONLY: GET_LAST_GAS
+#endif
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+      INCLUDE "mpif.h"
+!-----------------------------------------------------------------------
+!
+!***  INPUT DATA
+!
+!-----------------------------------------------------------------------
+!
+      TYPE(DOMAIN),TARGET :: GRID
+!
+!***  DEFINITIONS OF DUMMY ARGUMENTS TO THIS ROUTINE (GENERATED FROM REGISTRY)
+!
+! NOTE, REGISTRY NO LONGER GENERATES DUMMY ARGUMENTS OR DUMMY ARGUMENT
+! DECLARATIONS FOR RCONFIG ENTRIES. THEY ARE STILL PART OF STATE. ACCESS
+! TO THESE VARIABLES IS NOW THROUGH GRID STRUCTURE, AS MODIFIED BELOW.
+! AFFECTED VARIABLES: SIGMA, DT, NPHS, IDTAD, NRADS, NRADL, JULDAY,
+! JULYR, NUM_SOIL_LAYERS, NCNVC, ENSDIM, DY, AND SPEC_BDY_WIDTH.
+! JM, 20050819
+!
+!----------------------------
+#include 
+!----------------------------
+!
+!***  STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN
+!
+      TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS
+#ifdef WRF_CHEM
+      INTEGER :: NUMGAS
+#endif
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+      INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE                                &
+     &          ,IMS,IME,JMS,JME,KMS,KME                                & 
+     &          ,IPS,IPE,JPS,JPE,KPS,KPE                                &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER :: I,ICLTEND,IDF,IJDE,IJDS,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST &
+     &          ,NTSD_current
+      INTEGER,SAVE :: NTSD_restart
+!dusan      INTEGER :: MPI_COMM_COMP,MYPE,MYPROC,NPES
+      INTEGER :: MYPROC
+      INTEGER :: KVH,NTSD_rad,RC
+      REAL :: WC, QI, QR, QW, FICE, FRAIN
+      INTEGER :: NUM_OZMIXM,NUM_AEROSOLC
+!
+      CHARACTER*80 :: MESSAGE
+!
+!  For precip assimilation:
+      INTEGER :: ISTAT
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: PPTDAT
+
+!  For physics compatibility with other packages
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: TTEN,QTEN
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: RTHRATEN,RTHBLTEN,RQVBLTEN
+!
+      REAL :: DT_INV,GPS
+!
+      LOGICAL :: LAST_TIME
+!
+      LOGICAL wrf_dm_on_monitor
+      EXTERNAL wrf_dm_on_monitor
+!
+!-----------------------------------------------------------------------
+!***  TIMING VARIABLES
+!-----------------------------------------------------------------------
+      real,save :: solve_tim,exch_tim,pdte_tim,adve_tim,vtoa_tim        &
+     &,            vadz_tim,hadz_tim,eps_tim,vad2_tim,had2_tim          &
+     &,            radiation_tim,rdtemp_tim,turbl_tim,cltend_tim        &
+     &,            cucnvc_tim,gsmdrive_tim,hdiff_tim,bocoh_tim          &
+     &,            pfdht_tim,ddamp_tim,bocov_tim,uv_htov_tim,sum_tim    &
+     &,            adjppt_tim
+      real,save :: exch_tim_max
+      real :: btim,btimx
+      real :: et_max,this_tim
+      integer :: n_print_time
+!
+#ifdef RSL
+      integer rsl_internal_milliclock
+      external rsl_internal_milliclock
+# define timef rsl_internal_milliclock
+#else
+!     real*8,dimension(1) :: timef
+      real*8 :: timef
+#endif
+!-----------------------------------------------------------------------
+!
+#ifdef DEREF_KLUDGE
+! SEE http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+      INTEGER :: SM31,EM31,SM32,EM32,SM33,EM33 
+      INTEGER :: SM31X,EM31X,SM32X,EM32X,SM33X,EM33X
+      INTEGER :: SM31Y,EM31Y,SM32Y,EM32Y,SM33Y,EM33Y
+#endif
+!
+!-----------------------------------------------------------------------
+!
+! LIMIT THE NUMBER OF ARGUMENTS IF COMPILED WITH -DLIMIT_ARGS BY COPYING
+! SCALAR (NON-ARRAY) ARGUMENTS OUT OF THE GRID DATA STRUCTURE INTO LOCALLY
+! DEFINED COPIES (DEFINED IN EM_DUMMY_DECL.INC, ABOVE, AS THEY ARE IF THEY
+! ARE ARGUMENTS).  AN EQUIVALENT INCLUDE OF EM_SCALAR_DEREFS.INC APPEARS
+! AT THE END OF THE ROUTINE TO COPY BACK ANY CHNAGED NON-ARRAY VALUES.
+! THE DEFINITION OF COPY_IN OR COPY_OUT BEFORE THE INCLUDE DEFINES THE
+! DIRECTION OF THE COPY.  NMM_SCALAR_DEREFS IS GENERATED FROM REGISTRY.
+!
+!-----------------------------------------------------------------------
+#define COPY_IN
+#include 
+!-----------------------------------------------------------------------
+!
+! TRICK PROBLEMATIC COMPILERS INTO NOT PERFORMING COPY-IN/COPY-OUT BY ADDING
+! INDICES TO ARRAY ARGUMENTS IN THE CALL STATEMENTS IN THIS ROUTINE.
+! IT HAS THE EFFECT OF PASSING ONLY THE FIRST ELEMENT OF THE ARRAY, RATHER
+! THAN THE ENTIRE ARRAY.  SEE:
+! http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+!
+!-----------------------------------------------------------------------
+#include "deref_kludge.h"
+!-----------------------------------------------------------------------
+!
+! NEEDED BY SOME COMM LAYERS, E.G. RSL.  IF NEEDED, nmm_data_calls.inc IS
+! GENERATED FROM THE REGISTRY.  THE DEFINITION OF REGISTER_I1 ALLOWS
+! I1 DATA TO BE COMMUNICATED IN THIS ROUTINE IF NECESSARY.
+!
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#    include 
+#endif
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      CALL WRF_GET_MYPROC(MYPROC)
+      MYPE=MYPROC
+!-----------------------------------------------------------------------
+!
+!***  OBTAIN DIMENSION INFORMATION STORED IN THE GRID DATA STRUCTURE.
+!
+      CALL GET_IJK_FROM_GRID(GRID                                       &
+     &                      ,IDS,IDE,JDS,JDE,KDS,KDE                    &
+     &                      ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                      ,IPS,IPE,JPS,JPE,KPS,KPE )
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE THESE STARTING AND STOPPING LOCATIONS FOR EACH TILE AND
+!***  NUMBER OF TILES.
+!***  SEE: http://www.mmm.ucar.edu/wrf/WG2/topics/settiles
+!
+      CALL SET_TILES(GRID,IDS,IDE,JDS,JDE,IPS,IPE,JPS,JPE)
+!-----------------------------------------------------------------------
+!
+!***  TTEN, QTEN are used by GD convection scheme
+!
+      ALLOCATE(TTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
+      ALLOCATE(QTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
+      ALLOCATE(RTHBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
+      ALLOCATE(RQVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
+      ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT)
+!
+#ifdef WRF_CHEM
+  NUMGAS          = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT)
+#endif
+      DO J=JMS,JME
+      DO K=KMS,KME
+      DO I=IMS,IME
+        TTEN(I,K,J)=T(I,K,J)
+        QTEN(I,K,J)=Q(I,K,J)
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      GRID%SIGMA=1 
+      HYDRO=.FALSE.
+!
+      IJDS=MIN(IDS,JDS)
+      IJDE=MAX(IDE,JDE)
+!
+      IDF=IDE-1
+      JDF=JDE-1
+      KDF=KDE-1
+!
+!-----------------------------------------------------------------------
+!
+!***  FOR NOW SET CONTROLS FOR TILES TO PATCHES
+!
+!-----------------------------------------------------------------------
+      ITS=IPS
+      ITE=MIN(IPE,IDF)
+      JTS=JPS
+      JTE=MIN(JPE,JDF)
+      KTS=KPS
+      KTE=MIN(KPE,KDF)
+      if(ntsd==0)then
+        write(0,*)' its=',its,' ite=',ite
+        write(0,*)' jts=',jts,' jte=',jte
+        write(0,*)' kts=',kts,' kte=',kte
+      endif
+!-----------------------------------------------------------------------
+!***  SET TIMING VARIABLES TO ZERO AT START OF FORECAST.
+!-----------------------------------------------------------------------
+      if(ntsd==0)then
+        solve_tim=0.
+        exch_tim=0.
+        pdte_tim=0.
+        adve_tim=0.
+        vtoa_tim=0.
+        vadz_tim=0.
+        hadz_tim=0.
+        eps_tim=0.
+        vad2_tim=0.
+        had2_tim=0.
+        radiation_tim=0.
+        rdtemp_tim=0.
+        turbl_tim=0.
+        cltend_tim=0.
+        cucnvc_tim=0.
+        gsmdrive_tim=0.
+        hdiff_tim=0.
+        bocoh_tim=0.
+        pfdht_tim=0.
+        ddamp_tim=0.
+        bocov_tim=0.
+        uv_htov_tim=0.
+        exch_tim_max=0.
+        adjppt_tim=0.
+      endif
+!-----------------------------------------------------------------------
+      N_MOIST=NUM_MOIST
+!
+      DO J=MYJS_P4,MYJE_P4
+        IHEG(J)=MOD(J+1,2)
+        IHWG(J)=IHEG(J)-1
+        IVEG(J)=MOD(J,2)
+        IVWG(J)=IVEG(J)-1
+      ENDDO
+
+      DO J=MYJS_P4,MYJE_P4
+        IVW(J)=IVWG(J)
+        IVE(J)=IVEG(J)
+        IHE(J)=IHEG(J)
+        IHW(J)=IHWG(J)
+      ENDDO
+!
+!***  LATERAL POINTS IN THE BOUNDARY ARRAYS
+!
+      LB=2*(IDF-IDS+1)+(JDF-JDS+1)-3
+!
+!***  APPROXIMATE GRIDPOINT SPACING (METERS)
+!
+      JC=JMS+(JME-JMS)/2
+      GPS=SQRT(DX_NMM(IMS,JC)**2+DY_NMM**2)
+!
+!***  TIMESTEPS PER HOUR
+!
+      TSPH=3600./GRID%DT
+!
+      n_print_time=nint(3600./grid%dt)   ! Print stats once per hour
+!-----------------------------------------------------------------------
+!
+      NBOCO=0
+!-----------------------------------------------------------------------
+!***
+!***               THE MAIN TIME INTEGRATION LOOP
+!***
+!-----------------------------------------------------------------------
+!
+!***  NTSD IS THE TIMESTEP COUNTER (Number of Time Steps Done)
+!
+!-----------------------------------------------------------------------
+!***
+!***  ADVANCE_count STARTS AT ZERO FOR ALL RUNS (REGULAR AND RESTART).
+!***
+!-----------------------------------------------------------------------
+!
+      CALL DOMAIN_CLOCK_GET(GRID,ADVANCEcOUNT=NTSD_current)
+!
+      IF(NTSD_current==0)THEN
+        IF(GRID%RESTART.AND.GRID%TSTART>0.)THEN
+          IHRST=NSTART_HOUR
+          NTSD_restart=NTSD+1
+        ELSE
+          IHRST=GRID%GMT
+          NSTART_HOUR=IHRST
+          NTSD_restart=0
+        ENDIF
+      ENDIF
+!
+      NTSD=NTSD_restart+NTSD_current
+      LAST_TIME=domain_last_time_step(GRID)
+!
+!-----------------------------------------------------------------------
+!
+      IF(WRF_DM_ON_MONITOR() )THEN
+        WRITE(MESSAGE,125)NTSD,NTSD*GRID%DT/3600.
+  125   FORMAT(' SOLVE_NMM: TIMESTEP IS ',I5,'   TIME IS ',F7.3,' HOURS')
+        CALL WRF_MESSAGE(TRIM(MESSAGE))
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL WRF_GET_NPROC(NPES)
+!
+#if (NMM_NEST == 1)
+!-----------------------------------------------------------------------------
+!***  PATCHING NESTED BOUNDARIES.
+!-----------------------------------------------------------------------------
+!
+      CALL wrf_debug ( 100 , 'nmm: in patch' )
+
+      btimx=timef()
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_ZZ.inc"
+#endif
+
+      IF(GRID%ID/=1)THEN
+!
+        CALL NESTBC_PATCH (PD_B,T_B,Q_B,U_B,V_B,Q2_B,CWM_B                                    &
+                          ,PD_BT,T_BT,Q_BT,U_BT,V_BT,Q2_BT,CWM_BT                             &
+                          ,PDNEST_B,TNEST_B,QNEST_B,UNEST_B,VNEST_B,Q2NEST_B,CWMNEST_B        &
+                          ,PDNEST_BT,TNEST_BT,QNEST_BT,UNEST_BT,VNEST_BT,Q2NEST_BT,CWMNEST_BT &
+                          ,IJDS,IJDE,GRID%SPEC_BDY_WIDTH                                      &
+                          ,IDS,IDF,JDS,JDF,KDS,KDE                                            &
+                          ,IMS,IME,JMS,JME,KMS,KME                                            &
+                          ,ITS,ITE,JTS,JTE,KTS,KTE                                            )
+        CALL wrf_debug ( 100 , 'nmm: out of patch' )
+!
+#ifdef MOVE_NESTS
+
+        IF(GRID%ID/=1.AND.MOD(NTSD,1)==0.AND.GRID%NUM_MOVES==-99)THEN
+          XLOC_1=(IDE-1)/2     ! This maneuvers the storm to the center of the nest quickly
+          YLOC_1=(JDE-1)/2     ! This maneuvers the storm to the center of the nest quickly
+        ENDIF
+#endif
+
+      ENDIF
+#endif
+!
+!-----------------------------------------------------------------------
+!***  ALLOCATE PPTDAT ARRAY (PRECIP ASSIM):
+!-----------------------------------------------------------------------
+!
+      IF(GRID%PCPFLG.AND..NOT.ALLOCATED(PPTDAT))THEN
+        ALLOCATE(PPTDAT(IMS:IME,JMS:JME,3),STAT=ISTAT)
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***
+!***      Call READPCP to
+!***            1) READ IN PRECIPITATION FOR HOURS 1, 2 and 3;
+!***            2) Initialize DDATA to 999. (this is the amount
+!***               of input precip allocated to each physics time step
+!***               in ADJPPT; TURBL/SURFCE, which uses DDATA, is called
+!***               before ADJPPT)
+!***            3) Initialize LSPA to zero
+!***
+!-----------------------------------------------------------------------
+      IF (NTSD==0) THEN
+        IF (GRID%PCPFLG) THEN
+          CALL READPCP(PPTDAT,DDATA,LSPA                                &
+     &      ,IDS,IDE,JDS,JDE,KDS,KDE                                    &
+     &      ,IMS,IME,JMS,JME,KMS,KME                                    &
+     &      ,ITS,ITE,JTS,JTE,KTS,KTE)
+        ENDIF
+      ENDIF
+!-----------------------------------------------------------------------
+!
+      btim=timef()
+!
+!-----------------------------------------------------------------------
+!***  ZERO OUT ACCUMULATED QUANTITIES WHEN NEEDED.
+!-----------------------------------------------------------------------
+!
+      CALL BUCKETS(NTSD,NPREC,NSRFC,NRDSW,NRDLW                         &
+     &            ,GRID%RESTART,GRID%TSTART                             &
+     &            ,NCLOD,NHEAT,GRID%NPHS,TSPH                           &
+     &            ,ACPREC,CUPREC,ACSNOW,ACSNOM,SSROFF,BGROFF            &
+     &            ,SFCEVP,POTEVP,SFCSHX,SFCLHX,SUBSHX,SNOPCX            &
+     &            ,SFCUVX,POTFLX                                        &
+     &            ,ARDSW,ASWIN,ASWOUT,ASWTOA                            &
+     &            ,ARDLW,ALWIN,ALWOUT,ALWTOA                            &
+     &            ,ACFRST,NCFRST,ACFRCV,NCFRCV                          &
+     &            ,AVCNVC,AVRAIN,TCUCN,TRAIN                            &
+     &            ,ASRFC                                                &
+     &            ,T,TLMAX,TLMIN                                        &
+     &            ,IDS,IDE,JDS,JDE,KDS,KDE                              &
+     &            ,IMS,IME,JMS,JME,KMS,KME                              &
+     &            ,ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!
+      IF(NTSD==0)THEN
+        FIRST=.TRUE.
+!       call hpm_init()
+        btimx=timef()
+!
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A.inc"
+#endif
+!
+#ifdef DM_PARALLEL
+      IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
+#    include "HALO_NMM_A_3.inc"
+      ENDIF
+#endif
+!
+!***  Only for chemistry:
+!
+#ifdef WRF_CHEM   
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A_2.inc"
+#endif
+#endif
+!
+!-----------------------------------------------------------------------
+!***  USE THE FOLLOWING VARIABLES TO KEEP TRACK OF EXCHANGE TIMES.
+!-----------------------------------------------------------------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max           &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!-----------------------------------------------------------------------
+!
+        GO TO 2003
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+ 2000 CONTINUE
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  PRESSURE TENDENCY, SIGMA DOT, VERTICAL PART OF OMEGA-ALPHA
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_D.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL PDTE(                                                        &
+#ifdef DM_PARALLEL
+     &            GRID,                                                 &
+#endif
+     &            NTSD,GRID%DT,PT,ETA2,RES,HYDRO                        &
+     &           ,HTM,HBM2                                              &
+     &           ,PD,PDSL,PDSLO                                         &
+     &           ,PETDT,DIV,PSDT                                        &
+     &           ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &           ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &           ,IMS,IME,JMS,JME,KMS,KME                               &
+     &           ,ITS,ITE,JTS,JTE,KTS,KTE)
+
+      pdte_tim=pdte_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  ADVECTION OF T, U, AND V
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_F.inc"
+#    include "HALO_NMM_F1.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL ADVE(NTSD,GRID%DT,DETA1,DETA2,PDTOP                          &
+     &         ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX_NMM,DY_NMM      &
+     &         ,HTM,HBM2,VTM,VBM2,LMH,LMV                               &
+     &         ,T,U,V,PDSLO,TOLD,UOLD,VOLD                              &
+     &         ,PETDT,UPSTRM                                            &
+     &         ,FEW,FNS,FNE,FSE                                         &
+     &         ,ADT,ADU,ADV                                             & 
+     &         ,N_IUP_H,N_IUP_V                                         &
+     &         ,N_IUP_ADH,N_IUP_ADV                                     &
+     &         ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                             &
+     &         ,IHE,IHW,IVE,IVW,INDX3_WRK                               &
+     &         ,IDS,IDF,JDS,JDF,KDS,KDE                                 &
+     &         ,IMS,IME,JMS,JME,KMS,KME                                 &
+     &         ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      adve_tim=adve_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  PRESSURE TENDENCY, ETA/SIGMADOT, VERTICAL PART OF OMEGA-ALPHA TERM
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!
+      CALL VTOA(                                                        &
+#ifdef DM_PARALLEL
+     &          GRID,                                                   &
+#endif
+     &          NTSD,GRID%DT,PT,ETA2                                    &
+     &         ,HTM,HBM2,EF4T                                           &
+     &         ,T,DWDT,RTOP,OMGALF                                      &
+     &         ,PINT,DIV,PSDT,RES                                       &
+     &         ,IHE,IHW,IVE,IVW,INDX3_WRK                               &
+     &         ,IDS,IDF,JDS,JDF,KDS,KDE                                 &
+     &         ,IMS,IME,JMS,JME,KMS,KME                                 &
+     &         ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      vtoa_tim=vtoa_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  VERTICAL ADVECTION OF HEIGHT
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!
+      CALL VADZ(NTSD,GRID%DT,FIS,GRID%SIGMA,DFL,HTM,HBM2                &
+     &         ,DETA1,DETA2,PDTOP                                       &
+     &         ,PINT,PDSL,PDSLO,PETDT                                   &
+     &         ,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT                             &
+     &         ,IHE,IHW,IVE,IVW,INDX3_WRK                               &
+     &         ,IDS,IDF,JDS,JDF,KDS,KDE                                 &
+     &         ,IMS,IME,JMS,JME,KMS,KME                                 &
+     &         ,ITS,ITE,JTS,JTE,KTS,KTE)
+
+      vadz_tim=vadz_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  HORIZONTAL ADVECTION OF HEIGHT
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_G.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL HADZ(NTSD,GRID%DT,HYDRO,HTM,HBM2,DETA1,DETA2,PDTOP           &
+     &         ,DX_NMM,DY_NMM,FAD                                       &
+     &         ,FEW,FNS,FNE,FSE                                         &
+     &         ,PDSL,U,V,W,Z                                            &
+     &         ,IHE,IHW,IVE,IVW,INDX3_WRK                               &
+     &         ,IDS,IDF,JDS,JDF,KDS,KDE                                 &
+     &         ,IMS,IME,JMS,JME,KMS,KME                                 &
+     &         ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      hadz_tim=hadz_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  ADVECTION OF W
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_H.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL EPS(NTSD,GRID%DT,HYDRO,DX_NMM,DY_NMM,FAD                     &
+     &        ,DETA1,DETA2,PDTOP,PT                                     &
+     &        ,HTM,HBM2,HBM3,LMH                                        &
+     &        ,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT                         &
+     &        ,DWDT,DWDTMN,DWDTMX                                       &
+     &        ,FNS,FEW,FNE,FSE                                          &
+     &        ,T,U,V,W,Q,CWM                                            &
+     &        ,IHE,IHW,IVE,IVW,INDX3_WRK                                &
+     &        ,IDS,IDF,JDS,JDF,KDS,KDE                                  &
+     &        ,IMS,IME,JMS,JME,KMS,KME                                  &
+     &        ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      eps_tim=eps_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  VERTICAL ADVECTION OF Q, TKE, AND CLOUD WATER
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,GRID%IDTAD)==0)THEN
+        btimx=timef()
+!
+        vad2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+          CALL VAD2(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM               &
+     &             ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                  &
+     &             ,HBM2,LMH                                            &
+     &             ,Q,Q2,CWM,PETDT                                      &
+     &             ,N_IUP_H,N_IUP_V                                     &
+     &             ,N_IUP_ADH,N_IUP_ADV                                 &
+     &             ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                         &
+     &             ,IHE,IHW,IVE,IVW,INDX3_WRK                           &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                             &
+     &             ,IMS,IME,JMS,JME,KMS,KME                             &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        ELSE vad2_micro_check
+          CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM          &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP             &
+     &                  ,HBM2,LMH                                       &
+     &                  ,Q2,PETDT                                       &
+     &                  ,N_IUP_H,N_IUP_V                                &
+     &                  ,N_IUP_ADH,N_IUP_ADV                            &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                    &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                      &
+     &                  ,1,1                                            &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)                              
+     
+          CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM          &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP             &
+     &                  ,HBM2,LMH                                       &
+     &                  ,MOIST,PETDT                                    &
+     &                  ,N_IUP_H,N_IUP_V                                &
+     &                  ,N_IUP_ADH,N_IUP_ADV                            &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                    &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                      &
+     &                  ,NUM_MOIST,2                                    &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+          CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM          &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP             &
+     &                  ,HBM2,LMH                                       &
+     &                  ,SCALAR,PETDT                                   &
+     &                  ,N_IUP_H,N_IUP_V                                &
+     &                  ,N_IUP_ADH,N_IUP_ADV                            &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                    &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                      &
+     &                  ,NUM_SCALAR,2                                   &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+
+          DO J=MYJS,MYJE
+          DO K=KTS,KTE
+          DO i=MYIS,MYIE
+            Q(I,K,J)=MOIST(I,K,J,P_QV)/(1.+MOIST(I,K,J,P_QV))
+          ENDDO
+          ENDDO   
+          ENDDO   
+!
+        ENDIF vad2_micro_check
+!
+        vad2_tim=vad2_tim+timef()-btimx
+!
+      ENDIF
+!    
+!-----------------------------------------------------------------------
+!***  VERTICAL ADVECTION OF CHEMISTRY
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM  
+      IF(MOD(NTSD,GRID%IDTAD)==0)THEN
+#ifdef IBM
+        btimx=timef()
+#endif
+!
+        CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM            &
+     &           ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                    &
+     &           ,HBM2,LMH                                              &
+     &           ,CHEM,PETDT                                            & 
+     &           ,N_IUP_H,N_IUP_V                                       &
+     &           ,N_IUP_ADH,N_IUP_ADV                                   &
+     &           ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                           &
+     &           ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &           ,NUM_CHEM,1                                            & 
+     &           ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &           ,IMS,IME,JMS,JME,KMS,KME                               &
+     &           ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      ENDIF      
+#endif 
+!
+!-----------------------------------------------------------------------
+!***  HORIZONTAL ADVECTION OF Q, TKE, AND CLOUD WATER
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,GRID%IDTAD)==0)THEN
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_I.inc"
+#endif
+!
+#ifdef DM_PARALLEL
+        IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
+#    include "HALO_NMM_I_3.inc"
+        ENDIF
+#endif
+!
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max           &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!
+        btimx=timef()
+!
+!-----------------------------------------------------------------------
+        had2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+!-----------------------------------------------------------------------
+!
+          CALL HAD2(                                                   &
+#if defined(DM_PARALLEL)
+     &              GRID%DOMDESC,                                      &
+#endif
+     &              NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM              &
+     &             ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP                 &
+     &             ,HTM,HBM2,HBM3,LMH                                  &
+     &             ,Q,Q2,CWM,U,V,Z,HYDRO                               &
+     &             ,N_IUP_H,N_IUP_V                                    &
+     &             ,N_IUP_ADH,N_IUP_ADV                                &
+     &             ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                        &
+     &             ,IHE,IHW,IVE,IVW,INDX3_WRK                          &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!***  UPDATE MOIST ARRAY
+!
+          DO J=MYJS,MYJE
+          DO K=KTS,KTE
+          DO I=MYIS,MYIE
+            MOIST(I,K,J,P_QV)=Q(I,K,J)/(1.-Q(I,K,J))
+            WC = CWM(I,K,J)
+            QI = 0.
+            QR = 0.
+            QW = 0.
+            FICE=F_ICE(I,K,J)
+            FRAIN=F_RAIN(I,K,J)
+!
+            IF(FICE>=1.)THEN
+              QI=WC
+            ELSEIF(FICE<=0.)THEN
+              QW=WC
+            ELSE
+              QI=FICE*WC
+              QW=WC-QI
+            ENDIF
+!
+            IF(QW>0..AND.FRAIN>0.)THEN
+              IF(FRAIN>=1.)THEN
+                QR=QW
+                QW=0.
+              ELSE
+                QR=FRAIN*QW
+                QW=QW-QR
+              ENDIF
+            ENDIF
+!
+            MOIST(I,K,J,P_QC)=QW
+            MOIST(I,K,J,P_QR)=QR
+            MOIST(I,K,J,P_QI)=0.
+            MOIST(I,K,J,P_QS)=QI
+            MOIST(I,K,J,P_QG)=0.
+          ENDDO
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+        ELSE had2_micro_check
+!-----------------------------------------------------------------------
+!
+          CALL HAD2_SCAL(                                              &
+#if defined(DM_PARALLEL)
+     &                   GRID%DOMDESC,                                 &
+#endif        
+     &                   NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM         &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP            &
+     &                  ,HTM,HBM2,HBM3,LMH                             &
+     &                  ,Q2,U,V,Z,HYDRO                                &
+     &                  ,N_IUP_H,N_IUP_V                               &
+     &                  ,N_IUP_ADH,N_IUP_ADV                           &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                   &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                     &
+     &                  ,1,1                                           &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                       &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!        
+          CALL HAD2_SCAL(                                              &
+#if defined(DM_PARALLEL)
+     &                   GRID%DOMDESC,                                 &
+#endif
+     &                   NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM         &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP            &
+     &                  ,HTM,HBM2,HBM3,LMH                             &
+     &                  ,MOIST,U,V,Z,HYDRO                             &
+     &                  ,N_IUP_H,N_IUP_V                               &
+     &                  ,N_IUP_ADH,N_IUP_ADV                           &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                   &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                     &
+     &                  ,NUM_MOIST,2                                   &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                       &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+          CALL HAD2_SCAL(                                              &
+#if defined(DM_PARALLEL)
+     &                   GRID%DOMDESC,                                 &
+#endif
+     &                   NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM         &
+     &                  ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP            &
+     &                  ,HTM,HBM2,HBM3,LMH                             &
+     &                  ,SCALAR,U,V,Z,HYDRO                            &
+     &                  ,N_IUP_H,N_IUP_V                               &
+     &                  ,N_IUP_ADH,N_IUP_ADV                           &
+     &                  ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                   &
+     &                  ,IHE,IHW,IVE,IVW,INDX3_WRK                     &
+     &                  ,NUM_SCALAR,2                                  &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                       &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)                             
+!    
+          DO J=MYJS,MYJE
+          DO K=KTS,KTE 
+          DO I=MYIS,MYIE
+            Q(I,K,J)=MOIST(I,K,J,P_QV)/(1.+MOIST(I,K,J,P_QV))           
+          ENDDO
+          ENDDO    
+          ENDDO   
+!
+!-----------------------------------------------------------------------
+        ENDIF had2_micro_check
+!-----------------------------------------------------------------------
+!
+        had2_tim=had2_tim+timef()-btimx
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  HORIZONTAL ADVECTION OF CHEMISTRY
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM
+      IF(MOD(NTSD,GRID%IDTAD)==0)THEN
+        btimx=timef()
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_I_2.inc"
+#endif
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max           &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!
+        btimx=timef()
+!
+        CALL HAD2_SCAL(                                                &
+#if defined(DM_PARALLEL)
+     &                 GRID%DOMDESC,                                   &
+#endif
+     &                 NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM           &
+     &                ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP              &
+     &                ,HTM,HBM2,HBM3,LMH                               &
+     &                ,CHEM,U,V,Z,HYDRO                                &
+     &                ,N_IUP_H,N_IUP_V                                 &
+     &                ,N_IUP_ADH,N_IUP_ADV                             &
+     &                ,IUP_H,IUP_V,IUP_ADH,IUP_ADV                     &
+     &                ,IHE,IHW,IVE,IVW,INDX3_WRK                       &
+     &                ,NUM_CHEM,1                                      &
+     &                ,IDS,IDF,JDS,JDF,KDS,KDE                         &
+     &                ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+
+      ENDIF
+#endif
+!
+!----------------------------------------------------------------------
+!***  RADIATION
+!----------------------------------------------------------------------
+!
+!***  When allocating CAM radiation 4d arrays (ozmixm, aerosolc), 
+!***  the following two scalars are not needed.
+!
+      NUM_OZMIXM=1
+      NUM_AEROSOLC=1
+!
+      IF(NTSD<=0)THEN
+        NTSD_rad=NTSD
+      ELSE
+!
+!***  Call radiation just BEFORE the top of the hour
+!***  so that updated fields are written to history files.
+!
+        NTSD_rad=NTSD+1
+      ENDIF
+!
+      IF(MOD(NTSD_rad,GRID%NRADS)==0.OR.                               &
+     &   MOD(NTSD_rad,GRID%NRADL)==0)THEN
+        btimx=timef()
+!
+        CALL RADIATION(NTSD_rad,GRID%DT,GRID%JULDAY,GRID%JULYR         &
+     &                ,GRID%XTIME,GRID%JULIAN                          &
+     &                ,IHRST,GRID%NPHS                                 &
+     &                ,GLAT,GLON,GRID%NRADS,GRID%NRADL                 &
+     &                ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT      &
+     &                ,PD,RES,PINT,T,Q,MOIST,THS,ALBEDO,EPSR           &
+     &                ,F_ICE,F_RAIN                                    &
+#ifdef WRF_CHEM
+     &                ,GD_CLOUD,GD_CLOUD2                              &
+#endif
+     &                ,SM,HBM2,LMH,CLDFRA,N_MOIST,RESTRT               &
+     &                ,RLWTT,RSWTT,RLWIN,RSWIN,RSWINC,RSWOUT           &
+     &                ,RLWTOA,RSWTOA,CZMEAN                            &
+     &                ,CFRACL,CFRACM,CFRACH,SIGT4                      &
+     &                ,ACFRST,NCFRST,ACFRCV,NCFRCV                     &
+     &                ,CUPPT,VEGFRC,SNO,HTOP,HBOT                      &
+     &                ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM                  &
+     &                ,GRID,CONFIG_FLAGS                               &
+     &                ,RTHRATEN                                        &  
+#ifdef WRF_CHEM
+     &                ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC            &
+     &                ,TAUAER1, TAUAER2, TAUAER3, TAUAER4              & 
+     &                ,GAER1, GAER2, GAER3, GAER4                      &
+     &                ,WAER1, WAER2, WAER3, WAER4                      &
+#endif
+     &                ,IDS,IDF,JDS,JDF,KDS,KDE                         &
+     &                ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        DO J=JMS,JME
+        DO I=IMS,IME
+          GSW(I,J)=RSWIN(I,J)-RSWOUT(I,J)
+        ENDDO
+        ENDDO
+!
+!                            ***  NOTE  ***
+! RLWIN/RSWIN  - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN)
+! RSWINC - CLEAR-SKY downward shortwave at the surface (new for AQ)
+!                            ***  NOTE  ***
+!
+        radiation_tim=radiation_tim+timef()-btimx
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  APPLY TEMPERATURE TENDENCY DUE TO RADIATION
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!
+      CALL RDTEMP(NTSD,GRID%DT,GRID%JULDAY,GRID%JULYR,IHRST,GLAT,GLON  &
+     &           ,CZEN,CZMEAN,T,RSWTT,RLWTT,HTM,HBM2                   &
+     &           ,IDS,IDF,JDS,JDF,KDS,KDE                              &
+     &           ,IMS,IME,JMS,JME,KMS,KME                              &
+     &           ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      rdtemp_tim=rdtemp_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!***  TURBULENT PROCESSES 
+!----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,GRID%NPHS)==0)THEN
+!
+        btimx=timef()
+!
+        CALL TURBL(NTSD,GRID%DT,GRID%NPHS,RESTRT                       &
+     &            ,N_MOIST,GRID%NUM_SOIL_LAYERS,SLDPTH,DZSOIL          &
+     &            ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT          &
+!    &            ,SM,LMH,HTM,VTM,HBM2,VBM2,DX_NMM,DFL                 &
+     &            ,SM,LMH,HTM,VTM,HBM2,VBM2,DX_NMM,DFRLG               &
+     &            ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT                 &
+     &            ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR                 &
+     &            ,Q2,U,V,THS,NMM_TSK,SST,PREC,SNO,ZERO_3D             &
+     &            ,FIS,Z0,Z0BASE,USTAR,PBLH,LPBL,EL_MYJ                &
+     &            ,MOIST,RMOL                                          &
+     &            ,EXCH_H,AKHS,AKMS,AKHS_OUT,AKMS_OUT                  &
+     &            ,THZ0,QZ0,UZ0,VZ0,QSH,MAVAIL                         &
+     &            ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF             &
+     &            ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX           &
+     &            ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB          &
+     &            ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR                   &
+     &            ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR               &
+     &            ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG     &
+     &            ,TWBS,QWBS,SFCSHX,SFCLHX,SFCEVP                      &
+     &            ,POTEVP,POTFLX,SUBSHX                                &
+     &            ,APHTIM,ARDSW,ARDLW,ASRFC                            &
+     &            ,RSWOUT,RSWTOA,RLWTOA                                &
+     &            ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA             &
+     &            ,UZ0H,VZ0H,DUDT,DVDT                                 & 
+     &            ,RTHBLTEN,RQVBLTEN                                   & 
+     &            ,GRID%PCPFLG,DDATA                                   &
+     &            ,GRID,CONFIG_FLAGS                                   &
+     &            ,IHE,IHW,IVE,IVW                                     &
+     &            ,IDS,IDF,JDS,JDF,KDS,KDE                             &
+     &            ,IMS,IME,JMS,JME,KMS,KME                             &
+     &            ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!                     ***  NOTE  ***
+! RLWIN/RSWIN - downward longwave/shortwave at the surface
+!                     ***  NOTE  ***
+!
+        turbl_tim=turbl_tim+timef()-btimx
+!
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+# include "HALO_NMM_TURBL_A.inc"
+#endif
+!-----------------
+#ifdef DM_PARALLEL
+# include "HALO_NMM_TURBL_B.inc"
+#endif
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max           &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!
+!***  INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS.
+!
+        btimx=timef()
+        CALL UV_H_TO_V(NTSD,GRID%DT,GRID%NPHS,UZ0H,VZ0H,UZ0,VZ0         &
+     &                ,DUDT,DVDT,U,V,HBM2,VTM,IVE,IVW                   &
+     &                ,IDS,IDF,JDS,JDF,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+        uv_htov_tim=uv_htov_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!*** STORE ORIGINAL TEMPERATURE ARRAY
+!----------------------------------------------------------------------
+!
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_J.inc"
+#endif
+!
+#ifdef DM_PARALLEL
+        IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
+#    include "HALO_NMM_J_3.inc"
+        ENDIF
+#endif
+!
+#ifdef WRF_CHEM
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_J_2.inc"
+#endif
+#endif
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max           &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!
+        ICLTEND=-1
+        btimx=timef()
+! 
+        CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ                    &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        cltend_tim=cltend_tim+timef()-btimx
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  CONVECTIVE PRECIPITATION
+!----------------------------------------------------------------------
+      IF(MOD(NTSD,GRID%NCNVC)==0.AND.                                  &
+     &   CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN
+!
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_C.inc"
+#endif
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max          &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+      ENDIF
+!
+      IF(GRID%NCNVC/=999)THEN
+        btimx=timef()
+!
+!***  GET TENDENCIES FOR GD SCHEME.
+!    
+        IF(CONFIG_FLAGS%CU_PHYSICS==GDSCHEME)THEN
+          DT_INV=1./GRID%DT
+          DO J=JMS,JME
+          DO K=KMS,KME
+          DO I=IMS,IME
+            TTEN(I,K,J)=(T(I,K,J)-TTEN(I,K,J))*DT_INV
+            QTEN(I,K,J)=(Q(I,K,J)-QTEN(I,K,J))*DT_INV
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDIF
+
+        CALL CUCNVC(NTSD,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL      &
+     &             ,GPS,RESTRT,HYDRO,CLDEFI,LMH,N_MOIST,GRID%ENSDIM    &
+     &             ,MOIST                                              &
+     &             ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2                  &
+     &             ,F_ICE,F_RAIN                                       &
+!***  Changes for other cu schemes, most for GD scheme
+     &             ,APR_GR,APR_W,APR_MC,TTEN,QTEN                      &
+     &             ,APR_ST,APR_AS,APR_CAPMA                            &
+     &             ,APR_CAPME,APR_CAPMI                                &
+     &             ,MASS_FLUX,XF_ENS                                   &
+     &             ,PR_ENS,GSW                                         &
+#ifdef WRF_CHEM
+     &             ,GD_CLOUD,GD_CLOUD2,RAINCV                          &
+#endif
+!
+     &             ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN                 &
+     &             ,OMGALF,U,V,VTM,W,Z,FIS,W0AVG                       &
+     &             ,PREC,ACPREC,CUPREC,CUPPT,CPRATE                    &
+     &             ,SM,HBM2,LPBL,CNVBOT,CNVTOP                         &
+     &             ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS                  &
+     &             ,RTHBLTEN,RQVBLTEN,RTHRATEN                         & 
+     &             ,AVCNVC,ACUTIM,ZERO_3D,IHE,IHW                      &
+     &             ,GRID,CONFIG_FLAGS                                  &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        cucnvc_tim=cucnvc_tim+timef()-btimx
+!
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  GRIDSCALE MICROPHYSICS (CONDENSATION & PRECIPITATION)
+!----------------------------------------------------------------------
+!
+      IF(MOD(NTSD,GRID%NPHS)==0)THEN
+        btimx=timef()
+!
+        CALL GSMDRIVE(NTSD,GRID%DT,GRID%NPHS,N_MOIST                   &
+     &               ,DX_NMM(ITS,JC),GRID%DY,LMH,SM,HBM2,FIS           &
+     &               ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2                &
+     &               ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN               &
+     &               ,MOIST,SCALAR,NUM_SCALAR                          &
+     &               ,F_ICE,F_RAIN,F_RIMEF,SR                          &
+     &               ,PREC,ACPREC,AVRAIN,ZERO_3D                       &
+     &               ,MP_RESTART_STATE                                 &
+     &               ,TBPVS_STATE                                      &
+     &               ,TBPVS0_STATE                                     &
+     &               ,GRID,CONFIG_FLAGS                                &
+     &               ,IDS,IDF,JDS,JDF,KDS,KDE                          &
+     &               ,IMS,IME,JMS,JME,KMS,KME                          &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        gsmdrive_tim=gsmdrive_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!---------PRECIPITATION ASSIMILATION------------------------------------
+!-----------------------------------------------------------------------
+!
+        IF (GRID%PCPFLG) THEN
+          btimx=timef()
+!
+          CALL CHKSNOW(NTSD,GRID%DT,GRID%NPHS,SR,PPTDAT                 &
+     &      ,IDS,IDE,JDS,JDE,KDS,KDE                                    &
+     &      ,IMS,IME,JMS,JME,KMS,KME                                    &
+     &      ,ITS,ITE,JTS,JTE,KTS,KTE)
+          CALL ADJPPT(NTSD,GRID%DT,GRID%NPHS,PREC,LSPA,PPTDAT,DDATA     &
+     &      ,IDS,IDE,JDS,JDE,KDS,KDE                                    &
+     &      ,IMS,IME,JMS,JME,KMS,KME                                    &
+     &      ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+          adjppt_tim=adjppt_tim+timef()-btimx
+        ENDIF
+!
+!----------------------------------------------------------------------
+!***  CALCULATE TEMP TENDENCIES AND RESTORE ORIGINAL TEMPS
+!----------------------------------------------------------------------
+!      
+        ICLTEND=0
+        btimx=timef()
+!
+        CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ                    &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+        cltend_tim=cltend_tim+timef()-btimx
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  UPDATE TEMP TENDENCIES FROM CLOUD PROCESSES EVERY TIME STEP
+!----------------------------------------------------------------------
+!
+      ICLTEND=1
+      btimx=timef()
+!
+      CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ                      &
+     &           ,IDS,IDF,JDS,JDF,KDS,KDE                              &
+     &           ,IMS,IME,JMS,JME,KMS,KME                              &
+     &           ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      cltend_tim=cltend_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!***  LATERAL DIFFUSION
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_K.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL HDIFF(NTSD,GRID%DT,FIS,DY_NMM,HDAC,HDACV                    &
+     &          ,HTM,HBM2,VTM,DETA1,GRID%SIGMA                         &
+     &          ,T,Q,U,V,Q2,Z,W,SM,SICE                                &
+     &          ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      DO J=MYJS,MYJE
+      DO K=KTS,KTE
+      DO I=MYIS,MYIE
+!!!      MOIST(I,K,J,P_QV)=MAX(0.,Q(I,K,J)/(1.-Q(I,K,J)))
+         MOIST(I,K,J,P_QV)=Q(I,K,J)/(1.-Q(I,K,J))
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      hdiff_tim=hdiff_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!***  UPDATING BOUNDARY VALUES AT HEIGHT POINTS
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_L.inc"
+#endif
+!
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_L_3.inc"
+#endif
+!
+#ifdef WRF_CHEM
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_L_2.inc"
+#endif
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL BOCOH(GRID%ID,NTSD,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH & 
+     &          ,LB,ETA1,ETA2,PDTOP,PT,RES,HTM                         &
+     &          ,PD_B,T_B,Q_B,U_B,V_B,Q2_B,CWM_B                       &
+     &          ,PD_BT,T_BT,Q_BT,U_BT,V_BT,Q2_BT,CWM_BT                &
+     &          ,PD,T,Q,Q2,CWM,PINT,MOIST,N_MOIST,SCALAR,NUM_SCALAR    &
+#ifdef WRF_CHEM
+     &          ,CHEM,NUMGAS,CONFIG_FLAGS                              &
+#endif
+     &          ,IJDS,IJDE,GRID%SPEC_BDY_WIDTH,Z                       &
+     &          ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      bocoh_tim=bocoh_tim+timef()-btimx
+!     if(mod(ntsd,n_print_time)==0)then
+!       call twr(t,0,'t',ntsd,mype,npes,mpi_comm_comp &
+!    &          ,ids,ide,jds,jde,kds,kde                               &
+!    &          ,ims,ime,jms,jme,kms,kme                               &
+!    &          ,its,ite,jts,jte,kts,kte)
+!     endif
+!
+!----------------------------------------------------------------------
+!***  IS IT TIME FOR A CHECK POINT ON THE MODEL HISTORY FILE?
+!----------------------------------------------------------------------
+!
+ 2003 CONTINUE
+!
+!----------------------------------------------------------------------
+!***  PRESSURE GRD, CORIOLIS, DIVERGENCE, AND HORIZ PART OF OMEGA-ALPHA
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A.inc"
+#endif
+!
+#ifdef DM_PARALLEL
+      IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
+#    include "HALO_NMM_A_3.inc"
+      ENDIF
+#endif
+!
+#ifdef WRF_CHEM
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A_2.inc"
+#endif
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max             &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL PFDHT(NTSD,LAST_TIME,PT,DETA1,DETA2,PDTOP,RES,FIS           &
+     &          ,HYDRO,GRID%SIGMA,FIRST,DX_NMM,DY_NMM                  &
+     &          ,HTM,HBM2,VTM,VBM2,VBM3                                &
+     &          ,FDIV,FCP,WPDAR,DFL,CPGFU,CPGFV                        &
+     &          ,PD,PDSL,T,Q,U,V,CWM,OMGALF,PINT,DWDT                  &
+     &          ,RTOP,DIV,FEW,FNS,FNE,FSE                              &
+     &          ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      pfdht_tim=pfdht_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!***  DIVERGENCE DAMPING
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_B.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max            &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL DDAMP(NTSD,GRID%DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2,VTM      &
+     &          ,T,U,V,DDMPU,DDMPV                                     &
+     &          ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      ddamp_tim=ddamp_tim+timef()-btimx
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+      IF(FIRST.AND.NTSD==0)THEN
+        FIRST=.FALSE.
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A.inc"
+#endif
+#ifdef WRF_CHEM
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A_2.inc"
+#endif
+#endif
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+!       this_tim=timef()-btimx
+!       call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max          &
+!    &                    ,mpi_comm_comp,irtn)
+!       exch_tim_max=exch_tim_max+et_max
+!
+        GO TO 2000
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  UPDATING BOUNDARY VALUES AT VELOCITY POINTS
+!----------------------------------------------------------------------
+!
+      btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_C.inc"
+#endif
+!-----------------
+      exch_tim=exch_tim+timef()-btimx
+!     this_tim=timef()-btimx
+!     call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max            &
+!    &                  ,mpi_comm_comp,irtn)
+!     exch_tim_max=exch_tim_max+et_max
+!
+      btimx=timef()
+!
+      CALL BOCOV(GRID%ID,NTSD,GRID%DT,LB,VTM,U_B,V_B,U_BT,V_BT         & 
+     &          ,U,V                                                   &
+     &          ,IJDS,IJDE,GRID%SPEC_BDY_WIDTH                         &
+     &          ,IHE,IHW,IVE,IVW,INDX3_WRK                             &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE )
+!
+      bocov_tim=bocov_tim+timef()-btimx
+!
+!----------------------------------------------------------------------
+!***  COPY THE NMM VARIABLE Q2 TO THE WRF VARIABLE TKE_MYJ
+!----------------------------------------------------------------------
+!
+      DO J=JTS,JTE
+      DO K=KTS,KTE
+      DO I=ITS,ITE
+        TKE_MYJ(I,K,J)=0.5*Q2(I,K,J) !TKE is q squared over 2
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!----------------------------------------------------------------------
+!
+      IF(LAST_TIME.AND.ALLOCATED(PPTDAT))THEN
+        DEALLOCATE(PPTDAT,STAT=ISTAT)
+      ENDIF
+!
+!----------------------------------------------------------------------
+!
+      solve_tim=solve_tim+timef()-btim
+!
+!----------------------------------------------------------------------
+!***  PRINT TIMING VARIABLES WHEN DESIRED.
+!----------------------------------------------------------------------
+!
+      sum_tim=pdte_tim+adve_tim+vtoa_tim+vadz_tim+hadz_tim+eps_tim     &
+     &       +vad2_tim+had2_tim+radiation_tim+rdtemp_tim+turbl_tim     &
+     &       +cltend_tim+cucnvc_tim+gsmdrive_tim+hdiff_tim             &
+     &       +bocoh_tim+pfdht_tim+ddamp_tim+bocov_tim+uv_htov_tim      &
+     &       +exch_tim+adjppt_tim
+!
+      if(mod(ntsd,n_print_time)==0)then
+        write(0,*)' ntsd=',ntsd,' solve_tim=',solve_tim*1.e-3          &
+     &           ,' sum_tim=',sum_tim*1.e-3
+        write(0,*)' pdte_tim=',pdte_tim*1.e-3,' pct=',pdte_tim/sum_tim*100.
+        write(0,*)' adve_tim=',adve_tim*1.e-3,' pct=',adve_tim/sum_tim*100.
+        write(0,*)' vtoa_tim=',vtoa_tim*1.e-3,' pct=',vtoa_tim/sum_tim*100.
+        write(0,*)' vadz_tim=',vadz_tim*1.e-3,' pct=',vadz_tim/sum_tim*100.
+        write(0,*)' hadz_tim=',hadz_tim*1.e-3,' pct=',hadz_tim/sum_tim*100.
+        write(0,*)' eps_tim=',eps_tim*1.e-3,' pct=',eps_tim/sum_tim*100.
+        write(0,*)' vad2_tim=',vad2_tim*1.e-3,' pct=',vad2_tim/sum_tim*100.
+        write(0,*)' had2_tim=',had2_tim*1.e-3,' pct=',had2_tim/sum_tim*100.
+        write(0,*)' radiation_tim=',radiation_tim*1.e-3,' pct=',radiation_tim/sum_tim*100.
+        write(0,*)' rdtemp_tim=',rdtemp_tim*1.e-3,' pct=',rdtemp_tim/sum_tim*100.
+        write(0,*)' turbl_tim=',turbl_tim*1.e-3,' pct=',turbl_tim/sum_tim*100.
+        write(0,*)' cltend_tim=',cltend_tim*1.e-3,' pct=',cltend_tim/sum_tim*100.
+        write(0,*)' cucnvc_tim=',cucnvc_tim*1.e-3,' pct=',cucnvc_tim/sum_tim*100.
+        write(0,*)' gsmdrive_tim=',gsmdrive_tim*1.e-3,' pct=',gsmdrive_tim/sum_tim*100.
+        write(0,*)' adjppt_tim=',adjppt_tim*1.e-3,' pct=',adjppt_tim/sum_tim*100.
+        write(0,*)' hdiff_tim=',hdiff_tim*1.e-3,' pct=',hdiff_tim/sum_tim*100.
+        write(0,*)' bocoh_tim=',bocoh_tim*1.e-3,' pct=',bocoh_tim/sum_tim*100.
+        write(0,*)' pfdht_tim=',pfdht_tim*1.e-3,' pct=',pfdht_tim/sum_tim*100.
+        write(0,*)' ddamp_tim=',ddamp_tim*1.e-3,' pct=',ddamp_tim/sum_tim*100.
+        write(0,*)' bocov_tim=',bocov_tim*1.e-3,' pct=',bocov_tim/sum_tim*100.
+        write(0,*)' uv_h_to_v_tim=',uv_htov_tim*1.e-3,' pct=',uv_htov_tim/sum_tim*100.
+        write(0,*)' exch_tim=',exch_tim*1.e-3,' pct=',exch_tim/sum_tim*100.
+!        call time_stats(exch_tim,'exchange',ntsd,mype,npes,mpi_comm_comp)
+!        write(0,*)' exch_tim_max=',exch_tim_max*1.e-3
+!
+        call field_stats(t,mype,mpi_comm_comp                          &
+     &                  ,ids,ide,jds,jde,kds,kde                       &
+     &                  ,ims,ime,jms,jme,kms,kme                       &
+     &                  ,its,ite,jts,jte,kts,kte)
+      endif
+!
+!     if(last_time)then
+      DEALLOCATE(TTEN,STAT=ISTAT)
+      DEALLOCATE(QTEN,STAT=ISTAT)
+      DEALLOCATE(RTHRATEN,STAT=ISTAT)
+      DEALLOCATE(RTHBLTEN,STAT=ISTAT)
+      DEALLOCATE(RQVBLTEN,STAT=ISTAT)
+!
+#define COPY_OUT
+#include 
+      Return
+!----------------------------------------------------------------------
+!**********************************************************************
+!**********************************************************************
+!*************    EXIT FROM THE TIME LOOP    **************************
+!**********************************************************************
+!**********************************************************************
+!----------------------------------------------------------------------
+      END SUBROUTINE SOLVE_NMM
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE TWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP       &
+     &              ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &              ,IMS,IME,JMS,JME,KMS,KME                           &
+     &              ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!**********************************************************************
+      USE MODULE_EXT_INTERNAL
+!
+      IMPLICIT NONE
+      INCLUDE "mpif.h"
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                    &
+     &                     ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME+KK,JMS:JME),INTENT(IN) :: ARRAY
+!
+      CHARACTER(*),INTENT(IN) :: FIELD
+!
+!*** LOCAL VARIABLES
+!
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
+      INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
+      INTEGER,DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM
+!
+      INTEGER :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND,IUNIT                &
+     &          ,J,K,N,NLEN,NSIZE
+      INTEGER :: ITS_REM,ITE_REM,JTS_REM,JTE_REM
+!
+      REAL,DIMENSION(IDS:IDE,JDS:JDE) :: TWRITE
+      REAL,ALLOCATABLE,DIMENSION(:) :: VALUES
+      CHARACTER(5) :: TIMESTEP
+      CHARACTER(6) :: FMT
+      CHARACTER(12) :: FILENAME
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      IF(NTSD<=9)THEN
+        FMT='(I1.1)'
+        NLEN=1
+      ELSEIF(NTSD<=99)THEN
+        FMT='(I2.2)'
+        NLEN=2
+      ELSEIF(NTSD<=999)THEN
+        FMT='(I3.3)'
+        NLEN=3
+      ELSEIF(NTSD<=9999)THEN
+        FMT='(I4.4)'
+        NLEN=4
+      ELSEIF(NTSD<=99999)THEN
+        FMT='(I5.5)'
+        NLEN=5
+      ENDIF
+      WRITE(TIMESTEP,FMT)NTSD
+      FILENAME=FIELD//'_'//TIMESTEP(1:NLEN)
+!
+      IF(MYPE==0)THEN
+        CALL INT_GET_FRESH_HANDLE(IUNIT)
+        CLOSE(IUNIT)
+        OPEN(UNIT=IUNIT,FILE=FILENAME,FORM='UNFORMATTED',IOSTAT=IER)
+      ENDIF
+!
+!----------------------------------------------------------------------
+!!!!  DO 500 K=KTS,KTE+KK     !Unflipped
+!!!!  DO 500 K=KTE+KK,KTS,-1
+      DO 500 K=KDE-1,KDS,-1   !Write LM layers top down for checking
+!----------------------------------------------------------------------
+!
+      IF(MYPE==0)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          TWRITE(I,J)=ARRAY(I,K,J)
+        ENDDO
+        ENDDO
+!
+        DO IPE=1,NPES-1
+          CALL MPI_RECV(IT_REM,2,MPI_INTEGER,IPE,IPE                    &
+     &                 ,MPI_COMM_COMP,JSTAT,IRECV)
+          CALL MPI_RECV(JT_REM,2,MPI_INTEGER,IPE,IPE                    &
+     &                 ,MPI_COMM_COMP,JSTAT,IRECV)
+!
+          ITS_REM=IT_REM(1)
+          ITE_REM=IT_REM(2)
+          JTS_REM=JT_REM(1)
+          JTE_REM=JT_REM(2)
+!
+          NSIZE=(ITE_REM-ITS_REM+1)*(JTE_REM-JTS_REM+1)
+          ALLOCATE(VALUES(1:NSIZE))
+!
+          CALL MPI_RECV(VALUES,NSIZE,MPI_REAL,IPE,IPE                   &
+     &                 ,MPI_COMM_COMP,JSTAT,IRECV)
+          N=0
+          DO J=JTS_REM,JTE_REM
+            DO I=ITS_REM,ITE_REM
+              N=N+1
+              TWRITE(I,J)=VALUES(N)
+            ENDDO
+          ENDDO
+!
+          DEALLOCATE(VALUES)
+!
+        ENDDO
+!
+!----------------------------------------------------------------------
+      ELSE
+        NSIZE=(ITE-ITS+1)*(JTE-JTS+1)
+        ALLOCATE(VALUES(1:NSIZE))
+!
+        N=0
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          N=N+1
+          VALUES(N)=ARRAY(I,K,J)
+        ENDDO
+        ENDDO
+!
+        IT_REM(1)=ITS
+        IT_REM(2)=ITE
+        JT_REM(1)=JTS
+        JT_REM(2)=JTE
+!
+        CALL MPI_SEND(IT_REM,2,MPI_INTEGER,0,MYPE                       &
+     &               ,MPI_COMM_COMP,ISEND)
+        CALL MPI_SEND(JT_REM,2,MPI_INTEGER,0,MYPE                       &
+     &               ,MPI_COMM_COMP,ISEND)
+!
+        CALL MPI_SEND(VALUES,NSIZE,MPI_REAL,0,MYPE                      &
+     &               ,MPI_COMM_COMP,ISEND)
+!
+        DEALLOCATE(VALUES)
+!
+      ENDIF
+!----------------------------------------------------------------------
+!
+      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!
+      IF(MYPE==0)THEN
+!
+        DO J=JDS,JDE-1
+          IENDX=IDE-1
+          IF(MOD(J,2)==0)IENDX=IENDX-1
+          WRITE(IUNIT)(TWRITE(I,J),I=1,IENDX)
+        ENDDO
+!
+      ENDIF
+!
+!----------------------------------------------------------------------
+  500 CONTINUE
+!
+      IF(MYPE==0)CLOSE(IUNIT)
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE TWR
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE EXIT(NAME,T,Q,U,V,Q2,NTSD,MYPE,MPI_COMM_COMP          &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &               ,IMS,IME,JMS,JME,KMS,KME                          &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!**********************************************************************
+      USE MODULE_EXT_INTERNAL
+!
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+      INCLUDE "mpif.h"
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                    &
+     &                     ,MYPE,MPI_COMM_COMP,NTSD      
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: T,Q,U,V,Q2
+      CHARACTER(*),INTENT(IN) :: NAME
+!
+      INTEGER :: I,J,K,IEND,IERR,IRET
+      CHARACTER(256) :: ERRMESS
+      LOGICAL :: E_BDY,S_BDY
+!----------------------------------------------------------------------
+      IRET=0
+  100 FORMAT(' EXIT ',A,' AT NTSD=',I5)
+      IEND=ITE
+      S_BDY=(JTS==JDS)
+      E_BDY=(ITE==IDE-1)
+!
+      DO J=JTS,JTE
+      IEND=ITE
+      DO K=KTS,KTE
+      IF(E_BDY.AND.MOD(J,2)==0)IEND=ITE-1
+!
+      DO I=ITS,IEND
+        IF(T(I,K,J)>330..OR.T(I,K,J)<180..OR.T(I,K,J)/=T(I,K,J))THEN
+          WRITE(0,100)NAME,NTSD
+          WRITE(0,200)I,J,K,T(I,K,J),MYPE,NTSD
+  200     FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' T=',E12.5      &
+     &,          ' MYPE=',I3,' NTSD=',I5)
+          IRET=666
+          return
+!         WRITE(ERRMESS,205)NAME,T(I,K,J),I,K,J,MYPE
+  205     FORMAT(' EXIT ',A,' TEMPERATURE=',E12.5                      &
+     &,          ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
+!         CALL WRF_ERROR_FATAL(ERRMESS)
+!         CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        ELSEIF(Q(I,K,J)<-1.E-4.OR.Q(I,K,J)>30.E-3                      &
+     &         .OR.Q(I,K,J)/=Q(I,K,J))THEN
+          WRITE(0,100)NAME,NTSD
+          WRITE(0,300)I,J,K,Q(I,K,J),MYPE,NTSD
+  300     FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' Q=',E12.5      &
+     &,          ' MYPE=',I3,' NTSD=',I5)
+          IRET=666
+          return
+!         WRITE(ERRMESS,305)NAME,Q(I,K,J),I,K,J,MYPE
+  305     FORMAT(' EXIT ',A,' SPEC HUMIDITY=',E12.5                    &
+     &,          ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
+!         CALL WRF_ERROR_FATAL(ERRMESS)
+!         CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO J=JTS,JTE
+      IEND=ITE
+      DO K=KTS,KTE
+      IF(E_BDY.AND.MOD(J,2)==1)IEND=ITE-1
+      DO I=ITS,IEND
+        IF(ABS(U(I,K,J))>125..OR.ABS(V(I,K,J))>125.                    &
+     &         .OR.U(I,K,J)/=U(I,K,J).OR.V(I,K,J)/=V(I,K,J))THEN
+          WRITE(0,100)NAME,NTSD
+          WRITE(0,400)I,J,K,U(I,K,J),V(I,K,J),MYPE,NTSD
+  400     FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' U=',E12.5      &
+     &,          ' V=',E12.5,' MYPE=',I3,' NTSD=',I5)
+          IRET=666
+          return
+!         WRITE(ERRMESS,405)NAME,U(I,K,J),V(I,K,J),I,K,J,MYPE
+  405     FORMAT(' EXIT ',A,' U=',E12.5,' V=',E12.5                    &
+     &,          ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3)
+!         CALL WRF_ERROR_FATAL(ERRMESS)
+!         CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+      END SUBROUTINE EXIT
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE TIME_STATS(TIME_LCL,NAME,NTSD,MYPE,NPES,MPI_COMM_COMP)
+!----------------------------------------------------------------------
+!**********************************************************************
+      USE MODULE_EXT_INTERNAL
+!
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+      INCLUDE "mpif.h"
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,NTSD
+      REAL,INTENT(IN) :: TIME_LCL
+!
+      CHARACTER(*),INTENT(IN) :: NAME
+!
+!*** LOCAL VARIABLES
+!
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
+      INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
+      INTEGER,ALLOCATABLE,DIMENSION(:) :: ID_PE,IPE_SORT
+!
+      INTEGER :: IPE,IPE_MAX,IPE_MEDIAN,IPE_MIN,IRECV,IRTN,ISEND       &
+     &          ,N,N_MEDIAN,NLEN
+!
+      REAL,ALLOCATABLE,DIMENSION(:) :: TIME,SORT_TIME
+      REAL,DIMENSION(2) :: REMOTE
+      REAL :: TIME_MAX,TIME_MEAN,TIME_MEDIAN,TIME_MIN
+!
+      CHARACTER(5) :: TIMESTEP
+      CHARACTER(6) :: FMT
+      CHARACTER(25) :: TITLE
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      IF(NTSD<=9)THEN
+        FMT='(I1.1)'
+        NLEN=1
+      ELSEIF(NTSD<=99)THEN
+        FMT='(I2.2)'
+        NLEN=2
+      ELSEIF(NTSD<=999)THEN
+        FMT='(I3.3)'
+        NLEN=3
+      ELSEIF(NTSD<=9999)THEN
+        FMT='(I4.4)'
+        NLEN=4
+      ELSEIF(NTSD<=99999)THEN
+        FMT='(I5.5)'
+        NLEN=5
+      ENDIF
+      WRITE(TIMESTEP,FMT)NTSD
+      TITLE=NAME//'_'//TIMESTEP(1:NLEN)
+!
+!----------------------------------------------------------------------
+!
+      IF(MYPE==0)THEN
+        ALLOCATE(TIME(1:NPES))
+        ALLOCATE(SORT_TIME(1:NPES))
+        ALLOCATE(ID_PE(1:NPES))
+        ALLOCATE(IPE_SORT(1:NPES))
+!
+        TIME(1)=TIME_LCL
+        ID_PE(1)=MYPE
+!
+!***  COLLECT TIMES AND PE VALUES FROM OTHER PEs
+!
+        DO IPE=1,NPES-1
+          CALL MPI_RECV(REMOTE,2,MPI_REAL,IPE,IPE                      &
+     &                 ,MPI_COMM_COMP,JSTAT,IRECV)
+!
+          TIME(IPE+1)=REMOTE(1)
+          ID_PE(IPE+1)=NINT(REMOTE(2))
+        ENDDO
+!
+!***  NOW GET STATS.
+!***  FIRST THE MAX, MIN, AND MEAN TIMES.
+!
+        TIME_MEAN=0.
+        TIME_MAX=-1.
+        TIME_MIN=1.E10
+        IPE_MAX=-1
+        IPE_MIN=-1
+!
+        DO N=1,NPES
+          TIME_MEAN=TIME_MEAN+TIME(N)
+!
+          IF(TIME(N)>TIME_MAX)THEN
+            TIME_MAX=TIME(N)
+            IPE_MAX=ID_PE(N)
+          ENDIF
+!
+          IF(TIME(N) ',NMM_MAX_DIM,    &
+         '. Increase NMM_MAX_DIM in configure.wrf, clean, and recompile.'
+        CALL WRF_ERROR_FATAL(wrf_err_message)
+      ENDIF
+!
+      IF(JME.GT. NMM_MAX_DIM )THEN
+        WRITE(wrf_err_message,*)                                       &
+         'start_domain_nmm jme (',jme,') > ',NMM_MAX_DIM,    &
+         '. Increase NMM_MAX_DIM in configure.wrf, clean, and recompile.'
+        CALL WRF_ERROR_FATAL(wrf_err_message)
+      ENDIF
+#else
+      IF(IMS.GT.-2.OR.IME.GT. NMM_MAX_DIM )THEN
+        WRITE(wrf_err_message,*)                                       &
+         'start_domain_nmm ims(',ims,' > -2 or ime (',ime,') > ',NMM_MAX_DIM,    &
+         '. Increase NMM_MAX_DIM in configure.wrf, clean, and recompile.'
+        CALL WRF_ERROR_FATAL(wrf_err_message)
+      ENDIF
+!
+      IF(JMS.GT.-2.OR.JME.GT. NMM_MAX_DIM )THEN
+        WRITE(wrf_err_message,*)                                       &
+         'start_domain_nmm jms(',jms,' > -2 or jme (',jme,') > ',NMM_MAX_DIM,    &
+         '. Increase NMM_MAX_DIM in configure.wrf, clean, and recompile.'
+        CALL WRF_ERROR_FATAL(wrf_err_message)
+      ENDIF
+#endif
+!
+!---------------------------------------------------------------------- 
+!
+      WRITE(0,196)IHRST,IDAT
+      WRITE(LIST,196)IHRST,IDAT
+  196 FORMAT(' FORECAST BEGINS ',I2,' GMT ',2(I2,'/'),I4)
+!!!!!!tlb
+!!!! For now, set NPES to 1
+      NPES=1
+!!!!!!tlb
+      MY_IS_GLB=IPS
+      MY_IE_GLB=IPE-1
+      MY_JS_GLB=JPS
+      MY_JE_GLB=JPE-1
+!
+      IM=IPE-1
+      JM=JPE-1
+!!!!!!!!!
+!! All "my" variables defined below have had the IDE or JDE specification
+!! reduced by 1
+!!!!!!!!!!!
+
+      MYIS=MAX(IDS,IPS)
+      MYIE=MIN(IDE-1,IPE)
+      MYJS=MAX(JDS,JPS)
+      MYJE=MIN(JDE-1,JPE)
+
+      MYIS1  =MAX(IDS+1,IPS)
+      MYIE1  =MIN(IDE-2,IPE)
+      MYJS2  =MAX(JDS+2,JPS)
+      MYJE2  =MIN(JDE-3,JPE)
+!
+      MYIS_P1=MAX(IDS,IPS-1)
+      MYIE_P1=MIN(IDE-1,IPE+1)
+      MYIS_P2=MAX(IDS,IPS-2)
+      MYIE_P2=MIN(IDE-1,IPE+2)
+      MYIS_P3=MAX(IDS,IPS-3)
+      MYIE_P3=MIN(IDE-1,IPE+3)
+      MYJS_P3=MAX(JDS,JPS-3)
+      MYJE_P3=MIN(JDE-1,JPE+3)
+      MYIS_P4=MAX(IDS,IPS-4)
+      MYIE_P4=MIN(IDE-1,IPE+4)
+      MYJS_P4=MAX(JDS,JPS-4)
+      MYJE_P4=MIN(JDE-1,JPE+4)
+      MYIS_P5=MAX(IDS,IPS-5)
+      MYIE_P5=MIN(IDE-1,IPE+5)
+      MYJS_P5=MAX(JDS,JPS-5)
+      MYJE_P5=MIN(JDE-1,JPE+5)
+!
+      MYIS1_P1=MAX(IDS+1,IPS-1)
+      MYIE1_P1=MIN(IDE-2,IPE+1)
+      MYIS1_P2=MAX(IDS+1,IPS-2)
+      MYIE1_P2=MIN(IDE-2,IPE+2)
+!
+      MYJS1_P1=MAX(JDS+1,JPS-1)
+      MYJS2_P1=MAX(JDS+2,JPS-1)
+      MYJE1_P1=MIN(JDE-2,JPE+1)
+      MYJE2_P1=MIN(JDE-3,JPE+1)
+      MYJS1_P2=MAX(JDS+1,JPS-2)
+      MYJE1_P2=MIN(JDE-2,JPE+2)
+      MYJS2_P2=MAX(JDS+2,JPS-2)
+      MYJE2_P2=MIN(JDE-3,JPE+2)
+      MYJS1_P3=MAX(JDS+1,JPS-3)
+      MYJE1_P3=MIN(JDE-2,JPE+3)
+      MYJS2_P3=MAX(JDS+2,JPS-3)
+      MYJE2_P3=MIN(JDE-3,JPE+3)
+!!!!!!!!!!!
+!
+#ifdef DM_PARALLEL
+
+      CALL WRF_GET_MYPROC(MYPROC)
+      MYPE=MYPROC
+
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+
+#  include 
+
+!        CALL wrf_shutdown
+!        stop
+
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#endif
+
+      DO J=MYJS_P4,MYJE_P4
+        IHEG(J)=MOD(J+1,2)
+        IHWG(J)=IHEG(J)-1
+        IVEG(J)=MOD(J,2)
+        IVWG(J)=IVEG(J)-1
+      ENDDO
+!
+      DO J=MYJS_P4,MYJE_P4
+        IVW(J)=IVWG(J)
+        IVE(J)=IVEG(J)
+        IHE(J)=IHEG(J)
+        IHW(J)=IHWG(J)
+      ENDDO
+!
+      CAPA=R_D/CP
+      LM=KPE-KPS+1
+!
+      IFS=IPS
+      JFS=JPS
+      JFE=MIN(JPE,JDE-1)
+      IFE=MIN(IPE,IDE-1)
+!
+      IF(.NOT.RESTRT)THEN
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          LLMH=LMH(I,J)
+          KOFF=KPE-1-LLMH
+          PDSL(I,J)  =PD(I,J)*RES(I,J)
+          PREC(I,J)  =0.
+          ACPREC(I,J)=0.
+          CUPREC(I,J)=0.
+          rg=1./g
+          ht=fis(i,j)*rg
+!!!       fisx=ht*g
+!          fisx=max(fis(i,j),0.)
+!          prodx=Z0(I,J)*Z0MAX
+!          Z0(I,J)    =SM(I,J)*Z0SEA+(1.-SM(I,J))*                      &
+!     &                (Z0(I,J)*Z0MAX+FISx    *FCM+Z0LAND)
+!!!  &                (prodx        +FISx    *FCM+Z0LAND)
+          QSH(I,J)   =0.
+          AKMS(I,J)  =0.
+          AKHS(I,J)  =0.
+          TWBS(I,J)  =0.
+          QWBS(I,J)  =0.
+          CLDEFI(I,J)=1.
+!!!!          HTOP(I,J)  =REAL(LLMH)
+!!!!          HBOT(I,J)  =REAL(LLMH)
+          HTOP(I,J)  =REAL(KTS)
+          HTOPD(I,J) =REAL(KTS)
+          HTOPS(I,J) =REAL(KTS)
+          HBOT(I,J)  =REAL(KTE)
+          HBOTD(I,J) =REAL(KTE)
+          HBOTS(I,J) =REAL(KTE)
+!***
+!***  AT THIS POINT, WE MUST CALCULATE THE INITIAL POTENTIAL TEMPERATURE
+!***  OF THE SURFACE AND OF THE SUBGROUND.
+!***  EXTRAPOLATE DOWN FOR INITIAL SURFACE POTENTIAL TEMPERATURE.
+!***  ALSO DO THE SHELTER PRESSURE.
+!***
+          PM1=AETA1(KOFF+1)*PDTOP+AETA2(KOFF+1)*PDSL(I,J)+PT
+          APEM1=(1.E5/PM1)**CAPA
+
+        IF (NMM_TSK(I,J) .ge. 200.) THEN ! have a specific skin temp, use it
+               THS(I,J)=NMM_TSK(I,J)*APEM1
+               TSFCK=NMM_TSK(I,J)
+	ELSE ! use lowest layer as a proxy
+          THS(I,J)=T(I,KOFF+1,J)*APEM1
+          TSFCK=T(I,KOFF+1,J)
+	ENDIF
+
+!	if (I .eq. IFE/2 .and. J .eq. JFE/2) then
+!	write(6,*) 'I,J,T(I,KOFF+1,J),NMM_TSK(I,J):: ', I,J,T(I,KOFF+1,J),NMM_TSK(I,J)
+!	write(6,*) 'THS(I,J): ', THS(I,J)
+!	endif
+
+          PSFCK=PD(I,J)+PDTOP+PT
+!
+          IF(SM(I,J).LT.0.5) THEN
+            QSH(I,J)=PQ0/PSFCK*EXP(A2*(TSFCK-A3)/(TSFCK-A4))
+          ELSEIF(SM(I,J).GT.0.5) THEN
+            THS(I,J)=SST(I,J)*(1.E5/(PD(I,J)+PDTOP+PT))**CAPA
+          ENDIF
+!
+          TERM1=-0.068283/T(I,KOFF+1,J)
+          PSHLTR(I,J)=(PD(I,J)+PDTOP+PT)*EXP(TERM1)
+!
+          USTAR(I,J)=0.1
+          THZ0(I,J)=THS(I,J)
+          QZ0(I,J)=QSH(I,J)
+          UZ0(I,J)=0.
+          VZ0(I,J)=0.
+! 
+        ENDDO
+        ENDDO
+
+!***
+!***  INITIALIZE 3D MASKS
+!***
+        DO J=JFS,JFE
+          DO K=KPS,KPE
+          DO I=IFS,IFE
+            HTM(I,K,J)=1.
+            VTM(I,K,J)=1.
+          ENDDO
+          ENDDO
+        ENDDO
+!***
+!***  INITIALIZE CLOUD FIELDS
+!***
+      IF (MAXVAL(CWM) .gt. 0. .and. MAXVAL(CWM) .lt. 1.) then
+        write(0,*) 'appear to have CWM values...do not zero'
+      ELSE
+        write(0,*) 'zeroing CWM'
+        DO J=JFS,JFE
+          DO K=KPS,KPE
+          DO I=IFS,IFE
+            CWM(I,K,J)=0.
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!***
+!***  INITIALIZE ACCUMULATOR ARRAYS TO ZERO.
+!***
+        ARDSW=0.0
+        ARDLW=0.0
+        ASRFC=0.0
+        AVRAIN=0.0
+        AVCNVC=0.0
+!
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          ACFRCV(I,J)=0.
+          NCFRCV(I,J)=0
+          ACFRST(I,J)=0.
+          NCFRST(I,J)=0
+          ACSNOW(I,J)=0.
+          ACSNOM(I,J)=0.
+          SSROFF(I,J)=0.
+          BGROFF(I,J)=0.
+          ALWIN(I,J) =0.
+          ALWOUT(I,J)=0.
+          ALWTOA(I,J)=0.
+          ASWIN(I,J) =0.
+          ASWOUT(I,J)=0.
+          ASWTOA(I,J)=0.
+          SFCSHX(I,J)=0.
+          SFCLHX(I,J)=0.
+          SUBSHX(I,J)=0.
+          SNOPCX(I,J)=0.
+          SFCUVX(I,J)=0.
+          SFCEVP(I,J)=0.
+          POTEVP(I,J)=0.
+          POTFLX(I,J)=0.
+        ENDDO
+        ENDDO
+!***
+!***  INITIALIZE SATURATION SPECIFIC HUMIDITY OVER THE WATER.
+!***
+        EPS=R_D/R_V
+!
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          IF(SM(I,J).GT.0.5)THEN
+            CLOGES =-CM1/SST(I,J)-CM2*ALOG10(SST(I,J))+CM3
+            ESE    = 10.**(CLOGES+2.)
+            QSH(I,J)= SM(I,J)*EPS*ESE/(PD(I,J)+PDTOP+PT-ESE*(1.-EPS))
+          ENDIF
+        ENDDO
+        ENDDO
+!***  
+!***  INITIALIZE TURBULENT KINETIC ENERGY (TKE) TO A SMALL
+!***  VALUE (EPSQ2) ABOVE GROUND.  SET TKE TO ZERO IN THE
+!***  THE LOWEST MODEL LAYER.  IN THE LOWEST TWO ATMOSPHERIC
+!***  ETA LAYERS SET TKE TO A SMALL VALUE (Q2INI).
+!***
+!***EROGERS: add check for realistic values of q2
+!
+      IF (MAXVAL(Q2) .gt. epsq2 .and. MAXVAL(Q2) .lt. 200.) then
+        write(0,*) 'appear to have Q2 values...do not zero'
+      ELSE
+        write(0,*) 'zeroing Q2'
+        DO J=JFS,JFE
+        DO K=KPS,KPE-1
+        DO I=IFS,IFE
+          Q2(I,K,J)=HTM(I,K+1,J)*HBM2(I,J)*EPSQ2
+        ENDDO
+        ENDDO
+        ENDDO
+!
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          Q2(I,LM,J)    = 0.
+          LLMH          = LMH(I,J)
+          Q2(I,LLMH-2,J)= HBM2(I,J)*Q2INI
+          Q2(I,LLMH-1,J)= HBM2(I,J)*Q2INI
+        ENDDO
+        ENDDO
+      ENDIF
+!***  
+!***  PAD ABOVE GROUND SPECIFIC HUMIDITY IF IT IS TOO SMALL.
+!***  INITIALIZE LATENT HEATING ACCUMULATION ARRAYS.
+!***
+        DO J=JFS,JFE
+        DO K=KPS,KPE
+        DO I=IFS,IFE
+          IF(Q(I,K,J).LT.EPSQ)Q(I,K,J)=EPSQ*HTM(I,K,J)
+          TRAIN(I,K,J)=0.
+          TCUCN(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!***
+!***  INITIALIZE MAX/MIN TEMPERATURES.
+!***
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          TLMAX(I,J)=T(I,KPS,J)
+          TLMIN(I,J)=T(I,KPS,J)
+        ENDDO
+        ENDDO
+!
+!----------------------------------------------------------------------
+!***  END OF SCRATCH START INITIALIZATION BLOCK.
+!----------------------------------------------------------------------
+!
+        CALL wrf_message('INIT:  INITIALIZED ARRAYS FOR CLEAN START')
+      ENDIF ! <--- (not restart)
+
+      IF(NEST)THEN
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+!
+          LLMH=LMH(I,J)
+          KOFF=KPE-1-LLMH
+!
+          IF(T(I,KOFF+1,J).EQ.0.)THEN
+            T(I,KOFF+1,J)=T(I,KOFF+2,J)
+          ENDIF
+!
+          TERM1=-0.068283/T(I,KOFF+1,J)
+          PSHLTR(I,J)=(PD(I,J)+PDTOP+PT)*EXP(TERM1)
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  RESTART INITIALIZING.  CHECK TO SEE IF WE NEED TO ZERO
+!***  ACCUMULATION ARRAYS.
+!----------------------------------------------------------------------
+
+      TSPH=3600./GRID%DT ! needed?
+      NPHS0=GRID%NPHS
+
+      IF(MYPE==0)THEN
+        write(0,*)' start_nmm TSTART=',grid%tstart
+        write(0,*)' start_nmm TPREC=',grid%tprec
+        write(0,*)' start_nmm THEAT=',grid%theat
+        write(0,*)' start_nmm TCLOD=',grid%tclod
+        write(0,*)' start_nmm TRDSW=',grid%trdsw
+        write(0,*)' start_nmm TRDLW=',grid%trdlw
+        write(0,*)' start_nmm TSRFC=',grid%tsrfc
+        write(0,*)' start_nmm PCPFLG=',grid%pcpflg
+      ENDIF
+
+      NSTART = INT(grid%TSTART*TSPH+0.5)
+!
+      NTSD = NSTART
+
+
+!! want non-zero values for NPREC, NHEAT type vars to avoid problems
+!! with mod statements below.
+
+      NPREC  = INT(grid%TPREC *TSPH+0.5)
+      NHEAT  = INT(grid%THEAT *TSPH+0.5)
+      NCLOD  = INT(grid%TCLOD *TSPH+0.5)
+      NRDSW  = INT(grid%TRDSW *TSPH+0.5)
+      NRDLW  = INT(grid%TRDLW *TSPH+0.5)
+      NSRFC  = INT(grid%TSRFC *TSPH+0.5)
+
+      IF(RESTRT)THEN
+!
+!***
+!***    AVERAGE CLOUD AMOUNT ARRAY
+!***
+        IF(MOD(NTSD,NCLOD).LT.GRID%NPHS)THEN
+          CALL wrf_message('  ZERO AVG CLD AMT ARRAY')
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            ACFRCV(I,J)=0.
+            NCFRCV(I,J)=0
+            ACFRST(I,J)=0.
+            NCFRST(I,J)=0
+          ENDDO
+          ENDDO
+        ENDIF
+!***  
+!***     GRID-SCALE AND CONVECTIVE LATENT HEATING ARRAYS.
+!***  
+        IF(MOD(NTSD,NHEAT).LT.GRID%NCNVC)THEN
+          CALL wrf_message('  ZERO ACCUM LATENT HEATING ARRAYS')
+!
+          AVRAIN=0.
+          AVCNVC=0.
+          DO J=JFS,JFE
+          DO K=KPS,KPE
+          DO I=IFS,IFE
+            TRAIN(I,K,J)=0.
+            TCUCN(I,K,J)=0.
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDIF
+!***
+!***  IF THIS IS NOT A NESTED RUN, INITIALIZE TKE
+!***
+!       IF(.NOT.NEST)THEN
+!         DO K=1,LM
+!           DO J=JFS,JFE
+!           DO I=IFS,IFE
+!             Q2(I,K,J)=AMAX1(Q2(I,K,J)*HBM2(I,J),EPSQ2)
+!           ENDDO
+!           ENDDO
+!         ENDDO
+!       ENDIF
+!***
+!***  CLOUD EFFICIENCY
+!***
+!       DO J=JFS,JFE
+!       DO I=IFS,IFE
+!!!       CLDEFI(I,J)=AVGEFI*SM(I,J)+STEFI*(1.-SM(I,J))
+!         CLDEFI(I,J)=1.
+!       ENDDO
+!       ENDDO
+!***
+!***  TOTAL AND CONVECTIVE PRECIPITATION ARRAYS.
+!***  TOTAL SNOW AND SNOW MELT ARRAYS.
+!***  STORM SURFACE AND BASE GROUND RUN OFF ARRAYS.
+!     
+        IF(MOD(NTSD,NPREC).LT.GRID%NPHS)THEN
+          CALL wrf_message('  ZERO ACCUM PRECIP ARRAYS')
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            ACPREC(I,J)=0.
+            CUPREC(I,J)=0.
+            ACSNOW(I,J)=0.
+            ACSNOM(I,J)=0.
+            SSROFF(I,J)=0.
+            BGROFF(I,J)=0.
+          ENDDO
+          ENDDO
+        ENDIF
+!***  
+!***  LONG WAVE RADIATION ARRAYS.
+!***  
+        IF(MOD(NTSD,NRDLW).LT.GRID%NPHS)THEN
+          CALL wrf_message('  ZERO ACCUM LW RADTN ARRAYS')
+          ARDLW=0.
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            ALWIN(I,J) =0.
+            ALWOUT(I,J)=0.
+            ALWTOA(I,J)=0.
+          ENDDO
+          ENDDO
+        ENDIF
+!***  
+!***  SHORT WAVE RADIATION ARRAYS.
+!***  
+        IF(MOD(NTSD,NRDSW).LT.GRID%NPHS)THEN
+          CALL wrf_message('  ZERO ACCUM SW RADTN ARRAYS')
+          ARDSW=0.
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            ASWIN(I,J) =0.
+            ASWOUT(I,J)=0.
+            ASWTOA(I,J)=0.
+          ENDDO
+          ENDDO
+        ENDIF
+!***  
+!***  SURFACE SENSIBLE AND LATENT HEAT FLUX ARRAYS.
+!***  
+        IF(MOD(NTSD,NSRFC).LT.GRID%NPHS)THEN
+          CALL wrf_message('  ZERO ACCUM SFC FLUX ARRAYS')
+          ASRFC=0.
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            SFCSHX(I,J)=0.
+            SFCLHX(I,J)=0.
+            SUBSHX(I,J)=0.
+            SNOPCX(I,J)=0.
+            SFCUVX(I,J)=0.
+            SFCEVP(I,J)=0.
+            POTEVP(I,J)=0.
+            POTFLX(I,J)=0.
+          ENDDO
+          ENDDO
+        ENDIF
+!***
+!***  ENDIF FOR RESTART FILE ACCUMULATION ZERO BLOCK.
+!***
+        CALL wrf_message('INIT:  INITIALIZED ARRAYS FOR RESTART START')
+      ENDIF
+!
+      DO J=JFS,JFE
+      DO K=KPS,KPE
+      DO I=IFS,IFE
+        ZERO_3D(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+!
+!***  FLAG FOR INITIALIZING ARRAYS, LOOKUP TABLES, & CONSTANTS USED IN
+!***  MICROPHYSICS AND RADIATION
+!
+!----------------------------------------------------------------------
+!
+      MICRO_START=.TRUE.
+!
+!----------------------------------------------------------------------
+!***
+!***  INITIALIZE ADVECTION TENDENCIES TO ZERO SO THAT
+!***  BOUNDARY POINTS WILL ALWAYS BE ZERO
+!***
+      DO J=JFS,JFE
+      DO K=KPS,KPE
+      DO I=IFS,IFE
+        ADT(I,K,J)=0.
+        ADU(I,K,J)=0.
+        ADV(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+!***
+!***  SET INDEX ARRAYS FOR UPSTREAM ADVECTION
+!***
+!----------------------------------------------------------------------
+      DO J=JFS,JFE
+        N_IUP_H(J)=0
+        N_IUP_V(J)=0
+        N_IUP_ADH(J)=0
+        N_IUP_ADV(J)=0
+!
+        DO I=IFS,IFE
+          IUP_H(I,J)=-999
+          IUP_V(I,J)=-999
+          IUP_ADH(I,J)=-999
+          IUP_ADV(I,J)=-999
+        ENDDO
+!
+      ENDDO
+
+#ifndef NO_UPSTREAM_ADVECTION
+!
+!***  N_IUP_H HOLDS THE NUMBER OF MASS POINTS NEEDED IN EACH ROW
+!***  FOR UPSTREAM ADVECTION (FULL ROWS IN THE 3RD THROUGH 7TH
+!***  ROWS FROM THE SOUTH AND NORTH GLOBAL BOUNDARIES AND 
+!***  FOUR POINTS ADJACENT TO THE WEST AND EAST GLOBAL BOUNDARIES
+!***  ON ALL OTHER INTERNAL ROWS).  SIMILARLY FOR N_IUP_V.
+!***  BECAUSE OF HORIZONTAL OPERATIONS, THESE POINTS EXTEND OUTSIDE 
+!***  OF THE UPSTREAM REGION SOMEWHAT.
+!***  N_IUP_ADH HOLDS THE NUMBER OF MASS POINTS NEEDED IN EACH ROW
+!***  FOR THE COMPUTATION OF THE TENDENCIES THEMSELVES (ADT, ADQ2M
+!***  AND ADQ2L); SPECIFICALLY THESE TENDENCIES ARE ONLY DONE IN
+!***  THE UPSTREAM REGION.
+!***  N_IUP_ADV HOLDS THE NUMBER OF MASS POINTS NEEDED IN EACH ROW
+!***  FOR THE VELOCITY POINT TENDENCIES.
+!***  IUP_H AND IUP_V HOLD THE ACTUAL I VALUES USED IN EACH ROW.
+!***  LIKEWISE FOR IUP_ADH AND IUP_ADV. 
+!***  ALSO, SET UPSTRM FOR THOSE TASKS AROUND THE GLOBAL EDGE.
+!
+      UPSTRM=.FALSE.
+!
+      S_BDY=(JPS==JDS)
+      N_BDY=(JPE==JDE)
+      W_BDY=(IPS==IDS)
+      E_BDY=(IPE==IDE)
+!
+      JTPAD2=2
+      JBPAD2=2
+      IRPAD2=2
+      ILPAD2=2
+!
+      IF(S_BDY)THEN
+        UPSTRM=.TRUE.
+        JBPAD2=0
+!
+        DO JJ=1,7
+          J=JJ      ! -MY_JS_GLB+1
+          KNTI=0
+          DO I=MYIS_P2,MYIE_P2
+            IUP_H(IMS+KNTI,J)=I
+            IUP_V(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_H(J)=KNTI
+          N_IUP_V(J)=KNTI
+        ENDDO
+!
+        DO JJ=3,5
+          J=JJ      ! -MY_JS_GLB+1
+          KNTI=0
+          ISTART=MYIS1_P2
+          IEND=MYIE1_P2
+          IF(E_BDY)IEND=IEND-MOD(JJ+1,2)
+          DO I=ISTART,IEND
+            IUP_ADH(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_ADH(J)=KNTI
+!
+          KNTI=0
+          ISTART=MYIS1_P2
+          IEND=MYIE1_P2
+          IF(E_BDY)IEND=IEND-MOD(JJ,2)
+          DO I=ISTART,IEND
+            IUP_ADV(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_ADV(J)=KNTI
+        ENDDO
+      ENDIF
+!
+      IF(N_BDY)THEN
+        UPSTRM=.TRUE.
+        JTPAD2=0
+!
+        DO JJ=JDE-7, JDE-1 ! JM-6,JM
+          J=JJ      ! -MY_JS_GLB+1
+          KNTI=0
+          DO I=MYIS_P2,MYIE_P2
+            IUP_H(IMS+KNTI,J)=I
+            IUP_V(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_H(J)=KNTI
+          N_IUP_V(J)=KNTI
+        ENDDO
+!
+        DO JJ=JDE-5, JDE-3 ! JM-4,JM-2
+          J=JJ      ! -MY_JS_GLB+1
+          KNTI=0
+          ISTART=MYIS1_P2
+          IEND=MYIE1_P2
+          IF(E_BDY)IEND=IEND-MOD(JJ+1,2)
+          DO I=ISTART,IEND
+            IUP_ADH(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_ADH(J)=KNTI
+!
+          KNTI=0
+          ISTART=MYIS1_P2
+          IEND=MYIE1_P2
+          IF(E_BDY)IEND=IEND-MOD(JJ,2)
+          DO I=ISTART,IEND
+            IUP_ADV(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          N_IUP_ADV(J)=KNTI
+        ENDDO
+      ENDIF
+!
+      IF(W_BDY)THEN
+        UPSTRM=.TRUE.
+        ILPAD2=0
+        DO JJ=8,JDE-8   ! JM-7
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+!
+            DO I=1,4
+              IUP_H(IMS+I-1,J)=I
+              IUP_V(IMS+I-1,J)=I
+            ENDDO
+            N_IUP_H(J)=4
+            N_IUP_V(J)=4
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6   ! JM-5
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            KNTI=0
+            IEND=2+MOD(JJ,2)
+            DO I=2,IEND
+              IUP_ADH(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_ADH(J)=KNTI
+!
+            KNTI=0
+            IEND=2+MOD(JJ+1,2)
+            DO I=2,IEND
+              IUP_ADV(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_ADV(J)=KNTI
+!
+          ENDIF
+        ENDDO
+      ENDIF
+!
+      CALL WRF_GET_NPROCX(INPES)
+!
+      IF(E_BDY)THEN
+        UPSTRM=.TRUE.
+        IRPAD2=0
+        DO JJ=8,JDE-8   ! JM-7
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            IEND=IM-MOD(JJ+1,2)
+            ISTART=IEND-3
+!
+!***  IN CASE THERE IS ONLY A SINGLE GLOBAL TASK IN THE
+!***  I DIRECTION THEN WE MUST ADD THE WESTSIDE UPSTREAM
+!***  POINTS TO THE EASTSIDE POINTS IN EACH ROW.
+!
+            KNTI=0
+            IF(INPES.EQ.1)KNTI=N_IUP_H(J)
+!
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              IUP_H(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_H(J)=KNTI
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6   ! JM-5
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            IEND=IM-1-MOD(JJ+1,2)
+            ISTART=IEND-MOD(JJ,2)
+            KNTI=0
+            IF(INPES.EQ.1)KNTI=N_IUP_ADH(J)
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              IUP_ADH(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_ADH(J)=KNTI
+          ENDIF
+        ENDDO
+!***
+        DO JJ=8,JDE-8  ! JM-7
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            IEND=IM-MOD(JJ,2)
+            ISTART=IEND-3
+            KNTI=0
+            IF(INPES.EQ.1)KNTI=N_IUP_V(J)
+!
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              IUP_V(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_V(J)=KNTI
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6  !  JM-5
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            IEND=IM-1-MOD(JJ,2)
+            ISTART=IEND-MOD(JJ+1,2)
+            KNTI=0
+            IF(INPES.EQ.1)KNTI=N_IUP_ADV(J)
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              IUP_ADV(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            N_IUP_ADV(J)=KNTI
+          ENDIF
+        ENDDO
+      ENDIF
+!----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!tlb
+!!!Read in EM and EMT from the original NMM nhb file
+!!!   call int_get_fresh_handle( retval )
+!!!   close(retval)
+!!!   open(unit=retval,file=seeout,form='UNFORMATTED',iostat=ier)
+!!!!!!do j=1,128
+!!!     read(seeout)
+!!!!!!  read(55)
+!!!!!!enddo
+!!!   read(seeout)dummyx,em,emt
+!!!!!!read(55)dummyx,em,emt
+!!!   close(retval)
+      jam=6+2*(JDE-JDS-1-9)
+!     read(55)(em(j),j=1,jam),(emt(j),j=1,jam)
+!!!!!!!!!!!!!!!!!!!!tlb
+!
+!***  EXTRACT EM AND EMT FOR THE LOCAL SUBDOMAINS
+!
+      DO J=MYJS_P5,MYJE_P5
+        EM_LOC(J)=-9.E9
+        EMT_LOC(J)=-9.E9
+      ENDDO
+!!!   IF(IBROW==1)THEN
+      IF(S_BDY)THEN
+        DO J=3,5
+          EM_LOC(J)=EM(J-2)
+          EMT_LOC(J)=EMT(J-2)
+        ENDDO
+      ENDIF
+!!!   IF(ITROW==1)THEN
+      IF(N_BDY)THEN
+        KNT=3
+        DO JJ=JDE-5,JDE-3 ! JM-4,JM-2
+          KNT=KNT+1
+          J=JJ      ! -MY_JS_GLB+1
+          EM_LOC(J)=EM(KNT)
+          EMT_LOC(J)=EMT(KNT)
+        ENDDO
+      ENDIF
+!!!   IF(ILCOL==1)THEN
+      IF(W_BDY)THEN
+        KNT=6
+        DO JJ=6,JDE-6 ! JM-5
+          KNT=KNT+1
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            EM_LOC(J)=EM(KNT)
+            EMT_LOC(J)=EMT(KNT)
+          ENDIF
+        ENDDO
+      ENDIF
+!!!   IF(IRCOL==1)THEN
+      IF(E_BDY)THEN
+        KNT=6+JDE-11 ! JM-10
+        DO JJ=6,JDE-6 ! JM-5
+          KNT=KNT+1
+          IF(JJ.GE.MY_JS_GLB-2.AND.JJ.LE.MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            EM_LOC(J)=EM(KNT)
+            EMT_LOC(J)=EMT(KNT)
+          ENDIF
+        ENDDO
+      ENDIF
+#else
+      CALL wrf_message( 'start_domain_nmm: upstream advection commented out')
+#endif
+!
+!***
+!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
+!***
+      IF(NSTART.EQ.0)THEN
+!
+         GRID%NSOIL= GRID%NUM_SOIL_LAYERS
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          PCTSNO(I,J)=-999.0
+          IF(SM(I,J).LT.0.5)THEN
+              CMC(I,J)=0.0
+!              CMC(I,J)=canwat(i,j)   ! tgs
+            IF(SICE(I,J).GT.0.5)THEN
+!***
+!***  SEA-ICE CASE
+!***
+              SMSTAV(I,J)=1.0
+              SMSTOT(I,J)=1.0
+              SSROFF(I,J)=0.0
+              BGROFF(I,J)=0.0
+              CMC(I,J)=0.0
+              DO NS=1,GRID%NSOIL
+                SMC(I,NS,J)=1.0
+!               SH2O(I,NS,J)=0.05
+                SH2O(I,NS,J)=1.0
+              ENDDO
+            ENDIF
+          ELSE
+!***
+!***  WATER CASE
+!***
+            SMSTAV(I,J)=1.0
+            SMSTOT(I,J)=1.0
+            SSROFF(I,J)=0.0
+            BGROFF(I,J)=0.0
+            SOILTB(I,J)=NMM_TSK(I,J)
+            GRNFLX(I,J)=0.
+            SUBSHX(I,J)=0.0
+            ACSNOW(I,J)=0.0
+            ACSNOM(I,J)=0.0
+            SNOPCX(I,J)=0.0
+            CMC(I,J)=0.0
+            SNO(I,J)=0.0
+            DO NS=1,GRID%NSOIL
+              SMC(I,NS,J)=1.0
+              STC(I,NS,J)=NMM_TSK(I,J)
+!             SH2O(I,NS,J)=0.05
+              SH2O(I,NS,J)=1.0
+            ENDDO
+          ENDIF
+!
+        ENDDO
+        ENDDO
+!
+        APHTIM=0.0
+        ARATIM=0.0
+        ACUTIM=0.0
+!
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  INITIALIZE RADTN VARIABLES
+!***  CALCULATE THE NUMBER OF STEPS AT EACH POINT.
+!***  THE ARRAY 'LVL' WILL COORDINATE VERTICAL LOCATIONS BETWEEN
+!***  THE LIFTED WORKING ARRAYS AND THE FUNDAMENTAL MODEL ARRAYS.
+!***  LVL HOLDS THE HEIGHT (IN MODEL LAYERS) OF THE TOPOGRAPHY AT
+!***  EACH GRID POINT.
+!----------------------------------------------------------------------
+!   
+      DO J=JFS,JFE
+      DO I=IFS,IFE
+        LVL(I,J)=LM-LMH(I,J)
+      ENDDO
+      ENDDO
+!***
+!***  DETERMINE MODEL LAYER LIMITS FOR HIGH(3), MIDDLE(2),
+!***  AND LOW(1) CLOUDS.  ALSO FIND MODEL LAYER THAT IS JUST BELOW
+!***  (HEIGHT-WISE) 400 MB. (K400)
+!*** 
+      K400=0
+      PSUM=PT
+      SLPM=101325.
+      PDIF=SLPM-PT
+      DO K=1,LM
+        PSUM=PSUM+DETA(K)*PDIF
+        IF(LPTOP(3).EQ.0)THEN
+          IF(PSUM.GT.PHITP)LPTOP(3)=K
+        ELSEIF(LPTOP(2).EQ.0)THEN
+          IF(PSUM.GT.PMDHI)LPTOP(2)=K
+        ELSEIF(K400.EQ.0)THEN
+          IF(PSUM.GT.P400)K400=K
+        ELSEIF(LPTOP(1).EQ.0)THEN
+          IF(PSUM.GT.PLOMD)LPTOP(1)=K
+        ENDIF
+      ENDDO
+!***
+!*** CALL GRADFS ONCE TO CALC. CONSTANTS AND GET O3 DATA
+!***
+      KCCO2=0
+!***
+!*** CALCULATE THE MIDLAYER PRESSURES IN THE STANDARD ATMOSPHERE
+!***
+      PSS=101325.
+      PDIF=PSS-PT
+!
+      ALLOCATE(PHALF(LM+1),STAT=I)
+!
+      DO K=KPS,KPE-1
+        PHALF(K+1)=AETA(K)*PDIF+PT
+      ENDDO
+      
+!
+      PHALF(1)=0.
+      PHALF(LM+1)=PSS
+!***
+!!!   CALL GRADFS(PHALF,KCCO2,NUNIT_CO2)
+!***
+!***  CALL SOLARD TO CALCULATE NON-DIMENSIONAL SUN-EARTH DISTANCE
+!***
+!!!   IF(MYPE.EQ.0)CALL SOLARD(SUN_DIST)
+!!!   CALL MPI_BCAST(SUN_DIST,1,MPI_REAL,0,MPI_COMM_COMP,IRTN)
+
+!***
+!***  CALL ZENITH SIMPLY TO GET THE DAY OF THE YEAR FOR
+!***  THE SETUP OF THE OZONE DATA
+!***
+      TIME=(NTSD-1)*GRID%DT
+!
+!!!   CALL ZENITH(TIME,DAYI,HOUR)
+!
+      ADDL=0.
+      IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
+!
+!!!   CALL O3CLIM
+!
+!
+      DEALLOCATE(PHALF)
+!----------------------------------------------------------------------
+!***  SOME INITIAL VALUES RELATED TO TURBULENCE SCHEME
+!----------------------------------------------------------------------
+!
+      DO J=JFS,JFE
+      DO I=IFS,IFE
+!***
+!***  TRY A SIMPLE LINEAR INTERP TO GET 2/10 M VALUES
+!***
+        PDSL(I,J)=PD(I,J)*RES(I,J)
+        LMHK=LMH(I,J)
+        LMVK=LMV(I,J)
+!
+        KOFF=KPE-1-LMHK
+        KOFV=KPE-1-LMVK
+!
+        ULM=U(I,KOFV+1,J)
+        VLM=V(I,KOFV+1,J)
+        TLM=T(I,KOFF+1,J)
+        QLM=Q(I,KOFF+1,J)
+        PLM=AETA1(KOFF+1)*PDTOP+AETA2(KOFF+1)*PDSL(I,J)+PT
+        APELM=(1.0E5/PLM)**CAPA
+        APELMNW=(1.0E5/PSHLTR(I,J))**CAPA
+        THLM=TLM*APELM
+        DPLM=(DETA1(KOFF+1)*PDTOP+DETA2(KOFF+1)*PDSL(I,J))*0.5
+        DZLM=R_D*DPLM*TLM*(1.+P608*QLM)/(G*PLM)
+        FAC1=10./DZLM
+        FAC2=(DZLM-10.)/DZLM
+        IF(DZLM.LE.10.)THEN
+          FAC1=1.
+          FAC2=0.
+        ENDIF
+!
+        IF(.NOT.RESTRT)THEN
+          TH10(I,J)=FAC2*THS(I,J)+FAC1*THLM
+          Q10(I,J)=FAC2*QSH(I,J)+FAC1*QLM
+          U10(I,J)=ULM
+          V10(I,J)=VLM
+        ENDIF
+!
+!        FAC1=2./DZLM
+!        FAC2=(DZLM-2.)/DZLM
+!        IF(DZLM.LE.2.)THEN
+!          FAC1=1.
+!          FAC2=0.
+!        ENDIF
+!
+        IF(.NOT.RESTRT.OR.NEST)THEN
+
+	IF ( (THLM-THS(I,J)) .gt. 2.0) THEN  ! weight differently in different scenarios
+	 FAC1=0.3
+         FAC2=0.7
+        ELSE
+         FAC1=0.8
+         FAC2=0.2
+        ENDIF
+
+          TSHLTR(I,J)=FAC2*THS(I,J)+FAC1*THLM
+!          TSHLTR(I,J)=0.2*THS(I,J)+0.8*THLM
+          QSHLTR(I,J)=FAC2*QSH(I,J)+FAC1*QLM
+!          QSHLTR(I,J)=0.2*QSH(I,J)+0.8*QLM
+        ENDIF
+!***
+!***  NEED TO CONVERT TO THETA IF IS THE RESTART CASE
+!***  AS CHKOUT.f WILL CONVERT TO TEMPERATURE
+!***
+!EROGERS: COMMENT OUT IN WRF-NMM
+!***
+!       IF(RESTRT)THEN
+!         TSHLTR(I,J)=TSHLTR(I,J)*APELMNW
+!       ENDIF
+      ENDDO
+      ENDDO
+!
+!----------------------------------------------------------------------
+!***  INITIALIZE TAU-1 VALUES FOR ADAMS-BASHFORTH 
+!----------------------------------------------------------------------
+!
+      IF(.NOT.RESTRT)THEN
+        DO J=jfs,jfe
+          DO K=KPS,KPE
+          DO I=ifs,ife
+            TOLD(I,K,J)=T(I,K,J)   ! T AT TAU-1
+            UOLD(I,K,J)=U(I,K,J)   ! U AT TAU-1
+            VOLD(I,K,J)=V(I,K,J)   ! V AT TAU-1
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  INITIALIZE NONHYDROSTATIC QUANTITIES
+!----------------------------------------------------------------------
+!
+!!!!	SHOULD DWDT BE REDEFINED IF RESTRT?
+
+        IF(.NOT.RESTRT.OR.NEST)THEN
+      DO J=jfs,jfe
+        DO K=KPS,KPE
+        DO I=ifs,ife
+          DWDT(I,K,J)=1.
+        ENDDO
+        ENDDO
+      ENDDO
+	ENDIF
+!***
+      IF(GRID%SIGMA.EQ.1)THEN
+        DO J=jfs,jfe
+        DO I=ifs,ife
+          PDSL(I,J)=PD(I,J)
+        ENDDO
+        ENDDO
+      ELSE
+        DO J=jfs,jfe
+        DO I=ifs,ife
+          PDSL(I,J)=RES(I,J)*PD(I,J)
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!***
+!
+!
+!!!!	SHOULD PINT,Z,W BE REDEFINED IF RESTRT?
+
+      write(0,*)' restrt=',restrt,' nest=',nest
+      write(0,*)' ifs=',ifs,' ife=',ife
+      write(0,*)' jfs=',jfs,' jfe=',jfe
+      write(0,*)' kps=',kps,' kpe=',kpe
+      write(0,*)' pdtop=',pdtop,' pt=',pt
+        IF(.NOT.RESTRT.OR.NEST)THEN
+      DO J=jfs,jfe
+        DO K=KPS,KPE
+        DO I=ifs,ife
+          PINT(I,K,J)=ETA1(K)*PDTOP+ETA2(K)*PDSL(I,J)+PT
+          Z(I,K,J)=PINT(I,K,J)
+          W(I,K,J)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+	ENDIF
+
+#ifndef NO_RESTRICT_ACCEL
+!----------------------------------------------------------------------
+!***  RESTRICTING THE ACCELERATION ALONG THE BOUNDARIES
+!----------------------------------------------------------------------
+!
+      DO J=jfs,jfe
+      DO I=ifs,ife
+        DWDTMN(I,J)=-EPSIN
+        DWDTMX(I,J)= EPSIN
+      ENDDO
+      ENDDO
+
+
+!
+!***
+      IF(JHL.GT.1)THEN
+        JHH=JDE-1-JHL+1 ! JM-JHL+1
+        IHL=JHL/2+1
+!
+        DO J=1,JHL
+          IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IDE-1 ! IM
+              IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                DWDTMN(IX,JX)=-EPSB
+                DWDTMX(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=JHH,JDE-1   ! JM
+          IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IDE-1 ! IM
+              IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                DWDTMN(IX,JX)=-EPSB
+                DWDTMX(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=1,JDE-1 ! JM
+          IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IHL
+              IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                DWDTMN(IX,JX)=-EPSB
+                DWDTMX(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=1,JDE-1 ! JM
+          IF(J.GE.MY_JS_GLB-JBPAD2.AND.J.LE.MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+             ! moved this line to inside the J-loop, 20030429, jm
+            IHH=IDE-1-IHL+MOD(j,2) ! IM-IHL+MOD(J,2)
+            DO I=IHH,IDE-1 ! IM
+              IF(I.GE.MY_IS_GLB-ILPAD2.AND.I.LE.MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                DWDTMN(IX,JX)=-EPSB
+                DWDTMX(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+      ENDIF
+
+#else
+      CALL wrf_message('start_domain_nmm: NO_RESTRICT_ACCEL')
+#endif
+
+!-----------------------------------------------------------------------
+!***  CALL THE GENERAL PHYSICS INITIALIZATION
+!-----------------------------------------------------------------------
+!
+
+      ALLOCATE(SFULL(KMS:KME),STAT=I)           ; SFULL    = 0.
+      ALLOCATE(SMID(KMS:KME),STAT=I)            ; SMID     = 0.
+      ALLOCATE(EMISS(IMS:IME,JMS:JME),STAT=I)   ; EMISS    = 0.
+      ALLOCATE(GLW(IMS:IME,JMS:JME),STAT=I)     ; GLW      = 0.
+      ALLOCATE(HFX(IMS:IME,JMS:JME),STAT=I)     ; HFX      = 0.
+      ALLOCATE(LOWLYR(IMS:IME,JMS:JME),STAT=I)  ; LOWLYR   = 0.
+!     ALLOCATE(MAVAIL(IMS:IME,JMS:JME),STAT=I)  ; MAVAIL   = 0.
+      ALLOCATE(NCA(IMS:IME,JMS:JME),STAT=I)     ; NCA      = 0.
+      ALLOCATE(QFX(IMS:IME,JMS:JME),STAT=I)     ; QFX      = 0.
+      ALLOCATE(RAINBL(IMS:IME,JMS:JME),STAT=I)  ; RAINBL   = 0.
+      ALLOCATE(RAINC(IMS:IME,JMS:JME),STAT=I)   ; RAINC    = 0.
+      ALLOCATE(RAINNC(IMS:IME,JMS:JME),STAT=I)  ; RAINNC   = 0.
+      ALLOCATE(RAINNCV(IMS:IME,JMS:JME),STAT=I) ; RAINNCV  = 0.
+
+      ALLOCATE(ZS(KMS:KME),STAT=I)              ; ZS       = 0.
+      ALLOCATE(SNOWC(IMS:IME,JMS:JME),STAT=I)   ; SNOWC    = 0.
+      ALLOCATE(THC(IMS:IME,JMS:JME),STAT=I)     ; THC      = 0.
+      ALLOCATE(TMN(IMS:IME,JMS:JME),STAT=I)     ; TMN      = 0.
+      ALLOCATE(TSFC(IMS:IME,JMS:JME),STAT=I)    ; TSFC     = 0.
+      ALLOCATE(Z0_DUM(IMS:IME,JMS:JME),STAT=I)  ; Z0_DUM   = 0.
+      ALLOCATE(ALBEDO_DUM(IMS:IME,JMS:JME),STAT=I)  ; ALBEDO_DUM   = 0.
+
+      ALLOCATE(DZS(KMS:KME),STAT=I)                         ; DZS = 0.
+      ALLOCATE(RQCBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQCBLTEN = 0.
+      ALLOCATE(RQIBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQIBLTEN = 0.
+      ALLOCATE(RQVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQVBLTEN =  0.
+      ALLOCATE(RTHBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RTHBLTEN =  0.
+      ALLOCATE(RUBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ; RUBLTEN = 0.
+      ALLOCATE(RVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ; RVBLTEN = 0.
+      ALLOCATE(RQCCUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQCCUTEN = 0.
+      ALLOCATE(RQICUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQICUTEN  = 0.
+      ALLOCATE(RQRCUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQRCUTEN = 0.
+      ALLOCATE(RQSCUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQSCUTEN = 0.
+      ALLOCATE(RQVCUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQVCUTEN = 0.
+      ALLOCATE(RTHCUTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RTHCUTEN = 0.
+      ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RTHRATEN  = 0.
+      ALLOCATE(RTHRATENLW(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; RTHRATENLW = 0.
+      ALLOCATE(RTHRATENSW(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; RTHRATENSW = 0.
+      ALLOCATE(RRI(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; RRI = 0.
+      ALLOCATE(ZINT(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; ZINT = 0.
+!     ALLOCATE(ZMID(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; ZMID = 0.
+      ALLOCATE(CONVFAC(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CONVFAC = 0.
+#ifndef WRF_CHEM
+      ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_OLD = 0.
+#endif
+#if 0
+      ALLOCATE(W0AVG(IMS:IME,KMS:KME,JMS:JME),STAT=I)       ; W0AVG = 0.
+#endif
+!-----------------------------------------------------------------------
+!jm added set of g_inv
+      G_INV=1./G
+      ROG=R_D*G_INV
+      GRID%RADT=GRID%NRADS*GRID%DT/60.
+      GRID%BLDT=GRID%NPHS*GRID%DT/60.
+      GRID%CUDT=GRID%NCNVC*GRID%DT/60.
+      GRID%GSMDT=GRID%NPHS*GRID%DT/60.
+!
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        SFCZ=FIS(I,J)*G_INV
+        ZINT(I,KTS,J)=SFCZ
+        PDSL(I,J)=PD(I,J)*RES(I,J)
+        PSURF=PINT(I,KTS,J)
+        EXNSFC=(1.E5/PSURF)**CAPA
+        XLAND(I,J)=SM(I,J)+1.
+        THSIJ=(SST(I,J)*EXNSFC)*(XLAND(I,J)-1.)                         &
+     &        +THS(I,J)*(2.-SM(I,J))
+        TSFC(I,J)=THSIJ/EXNSFC
+!
+        DO K=KTS,KTE-1
+          PLYR=(PINT(I,K,J)+PINT(I,K+1,J))*0.5
+          TL=T(I,K,J)
+          CWML=CWM(I,K,J)
+          rri(i,k,j)=r_d*tl*(1.+p608*q(i,k,j))/plyr
+          ZINT(I,K+1,J)=ZINT(I,K,J)+TL/PLYR                             & 
+                     *(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))*ROG        & 
+                     *(Q(I,K,J)*P608-CWML+1.)
+        ENDDO
+!
+!        DO K=KTS,KTE
+!!!       ZMID(I,K,J)=0.5*(ZINT(I,K,J)+ZINT(I,K+1,J))
+!        ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  RECREATE SIGMA VALUES AT LAYER INTERFACES FOR THE FULL VERTICAL
+!***  DOMAIN FROM THICKNESS VALUES FOR THE TWO SUBDOMAINS.
+!***  NOTE: KTE=NUMBER OF LAYERS PLUS ONE
+!-----------------------------------------------------------------------
+!
+      write(0,*)' start_domain kte=',kte
+      PDTOT=101325.-PT
+      RPDTOT=1./PDTOT
+      PDBOT=PDTOT-PDTOP
+      SFULL(KTS)=1.
+      SFULL(KTE)=0.
+      dsigsum = 0.
+      DO K=KTS+1,KTE
+        DSIG=(DETA1(K-1)*PDTOP+DETA2(K-1)*PDBOT)*RPDTOT
+        dsigsum=dsigsum+dsig
+        SFULL(K)=SFULL(K-1)-DSIG
+        SMID(K-1)=0.5*(SFULL(K-1)+SFULL(K))
+      ENDDO
+      dsig=(deta1(kte-1)*pdtop+deta2(kte-1)*pdbot)*rpdtot
+      dsigsum=dsigsum+dsig
+      SMID(KTE-1)=0.5*(SFULL(KTE-1)+SFULL(KTE))
+!
+!-----------------------------------------------------------------------
+
+      LU_INDEX=IVGTYP
+
+      IF(.NOT.RESTRT)THEN
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          Z0_DUM(I,J)=Z0(I,J) ! hold
+          ALBEDO_DUM(I,J)=ALBEDO(I,J) ! Save albedos
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!     always define the quantity Z0BASE
+                                                                                                                                              
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+                                                                                                                                              
+! topo based
+!       Z0BASE(I,J)=SM(I,J)*Z0SEA+(1.-SM(I,J))*  &
+!    &             (FIS(I,J)*(FCM/3.)+Z0LAND)
+!
+        IF(SM(I,J)==0)then
+!         Z0BASE(I,J)=MAX(VZ0TBL_24(IVGTYP(I,J)),0.1)
+          Z0BASE(I,J)=VZ0TBL_24(IVGTYP(I,J))+Z0LAND
+        ELSE
+          Z0BASE(I,J)=VZ0TBL_24(IVGTYP(I,J))+Z0SEA
+        ENDIF
+!
+      ENDDO
+      ENDDO
+!
+! when allocating CAM radiation 4d arrays (ozmixm, aerosolc) these are not needed
+      num_ozmixm=1
+      num_aerosolc=1
+
+! Set GMT, JULDAY, and JULYR outside of phy_init because it is no longer 
+! called inside phy_init due to moving nest changes.  (When nests move 
+! phy_init may not be called on a process if, for example, it is a moving 
+! nest and if this part of the domain is not being initialized (not the 
+! leading edge).)  Calling domain_setgmtetc() here will avoid this problem 
+! when NMM moves to moving nests.  
+      CALL domain_setgmtetc( GRID, START_OF_SIMULATION )
+
+! Several arguments are RCONFIG entries in Registry.NMM. Registry no longer
+! includes these as dummy arguments or declares them.  Access them from 
+! GRID.  JM 20050819
+      CALL PHY_INIT(GRID%ID,CONFIG_FLAGS,GRID%DT,GRID%RESTART,sfull,smid&
+     &             ,PT,TSFC,GRID%RADT,GRID%BLDT,GRID%CUDT,GRID%GSMDT    &
+     &             ,RTHCUTEN, RQVCUTEN, RQRCUTEN                        &
+     &             ,RQCCUTEN, RQSCUTEN, RQICUTEN                        &
+     &             ,RUBLTEN,RVBLTEN,RTHBLTEN                            &
+     &             ,RQVBLTEN,RQCBLTEN,RQIBLTEN                          &
+     &             ,RTHRATEN,RTHRATENLW,RTHRATENSW                      &
+     &             ,STEPBL,STEPRA,STEPCU                                &
+     &             ,W0AVG, RAINNC, RAINC, RAINCV, RAINNCV               &
+     &             ,NCA,GRID%SWRAD_SCAT                                 &
+     &             ,CLDEFI,LOWLYR                                       &
+     &             ,MASS_FLUX                                           &
+     &             ,RTHFTEN, RQVFTEN                                    &
+     &             ,CLDFRA,CLDFRA_OLD,GLW,GSW,EMISS,LU_INDEX            &
+     &             ,GRID%LANDUSE_ISICE, GRID%LANDUSE_LUCATS             &
+     &             ,GRID%LANDUSE_LUSEAS, GRID%LANDUSE_ISN               &
+     &             ,GRID%LU_STATE                                       &
+     &             ,XLAT,XLONG,ALBEDO,ALBBCK                            &
+     &             ,GRID%GMT,GRID%JULYR,GRID%JULDAY                     &
+     &             ,GRID%LEVSIZ, NUM_OZMIXM, NUM_AEROSOLC, GRID%PAERLEV &
+     &             ,TMN,XLAND,ZNT,Z0,USTAR,MOL,PBLH,TKE_MYJ             &
+     &             ,EXCH_H,THC,SNOWC,MAVAIL,HFX,QFX,RAINBL              &
+     &             ,STC,ZS,DZS,GRID%NUM_SOIL_LAYERS,WARM_RAIN           &
+     &             ,ADV_MOIST_COND                                      &
+     &             ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS                   &
+     &             ,APR_CAPMA,APR_CAPME,APR_CAPMI                       &
+     &             ,XICE,VEGFRA,SNOW,CANWAT,SMSTAV                      &
+     &             ,SMSTOT, SFCRUNOFF,UDRUNOFF,GRDFLX,ACSNOW            &
+     &             ,ACSNOM,IVGTYP,ISLTYP,SFCEVP,SMC                     &
+     &             ,SH2O, SNOWH, SMFR3D                                 &  ! temporary
+     &             ,GRID%DX,GRID%DY,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY    &
+     &             ,MP_RESTART_STATE,TBPVS_STATE,TBPVS0_STATE           &
+     &             ,.TRUE.,.FALSE.,START_OF_SIMULATION                  &
+     &             ,IDS, IDE, JDS, JDE, KDS, KDE                        &
+     &             ,IMS, IME, JMS, JME, KMS, KME                        &
+     &             ,ITS, ITE, JTS, JTE, KTS, KTE                        &
+     &                )
+
+!-----------------------------------------------------------------------
+!
+!mp replace F*_PHY with values defined in module_initialize_real.F?
+
+	IF (.NOT. RESTRT) THEN
+! Added by Greg Thompson, NCAR-RAL, for initializing water vapor
+! mixing ratio (from NMM's specific humidity var) into moist array.
+
+        write(0,*) 'Initializng moist(:,:,:, Qv) from Q'
+        DO J=JFS,JFE
+        DO K=KPS,KPE
+        DO I=IFS,IFE
+           moist(I,K,J,P_QV) = Q(I,K,J) / (1.-Q(I,K,J))                 
+        enddo      
+        enddo      
+        enddo      
+     
+! Also sum cloud water, ice, rain, snow, graupel into Ferrier CWM       
+! array (if any hydrometeors found and non-zero from initialization     
+! package).  Then, determine fractions ice and rain from species.       
+     
+        IF (.not. (MAXVAL(CWM).gt.0. .and. MAXVAL(CWM).lt.1.) ) then    
+          do i_m = 2, num_moist
+          if (i_m.ne.p_qv) &
+     &       write(0,*) ' summing moist(:,:,:,',i_m,') into CWM array'  
+          DO J=JFS,JFE
+          DO K=KPS,KPE
+          DO I=IFS,IFE
+            IF ( (moist(I,K,J,i_m).gt.EPSQ) .and. (i_m.ne.p_qv) ) THEN  
+               CWM(I,K,J) = CWM(I,K,J) + moist(I,K,J,i_m)               
+            ENDIF  
+          enddo    
+          enddo
+          enddo
+          enddo
+
+          IF (.not. ( (maxval(F_ICE)+maxval(F_RAIN)) .gt. EPSQ) ) THEN
+            write(0,*) '  computing F_ICE'
+            do i_m = 2, num_moist
+            DO J=JFS,JFE
+            DO K=KPS,KPE
+            DO I=IFS,IFE
+              IF ( (moist(I,K,J,i_m).gt.EPSQ) .and. &
+     &               ( (i_m.eq.p_qi).or.(i_m.eq.p_qs).or.(i_m.eq.p_qg) ) ) THEN
+                 F_ICE(I,K,J) = F_ICE(I,K,J) + moist(I,K,J,i_m)
+              ENDIF
+        if (model_config_rec%mp_physics(grid%id).EQ.ETAMPNEW) then
+            if ((i_m.eq.p_qi).or.(i_m.eq.p_qg) ) then
+               moist(I,K,J,p_qs)=moist(I,K,J,p_qs)+moist(I,K,J,i_m)
+               moist(I,K,J,i_m) =0.
+            endif
+        endif
+            enddo
+            enddo
+            enddo
+            enddo
+            write(0,*) '  computing F_RAIN'
+            DO J=JFS,JFE
+            DO K=KPS,KPE
+            DO I=IFS,IFE
+          IF(F_ICE(i,k,j)<=EPSQ)THEN
+              F_ICE(I,K,J)=0.
+          ELSE
+              F_ICE(I,K,J) = F_ICE(I,K,J)/CWM(I,K,J)
+          ENDIF
+              IF ( (moist(I,K,J,p_qr)+moist(I,K,J,p_qc)).gt.EPSQ) THEN
+           IF(moist(i,k,j,p_qr)<=EPSQ)THEN
+              F_RAIN(I,K,J)=0.
+           ELSE
+              F_RAIN(I,K,J) = moist(i,k,j,p_qr) &
+     &                    / (moist(i,k,j,p_qr)+moist(i,k,j,p_qc))
+           ENDIF
+              ENDIF
+            enddo
+            enddo
+            enddo
+          ENDIF
+        ENDIF
+! End addition by Greg Thompson
+
+        IF (maxval(F_ICE) .gt. 0.) THEN
+        write(0,*) 'F_ICE > 0'
+         do J=JMS,JME
+         do K=KMS,KME
+         do I=IMS,IME
+          F_ICE_PHY(I,K,J)=F_ICE(I,K,J)
+         enddo
+         enddo
+         enddo
+        ENDIF
+
+        IF (maxval(F_RAIN) .gt. 0.) THEN
+        write(0,*) 'F_RAIN > 0'
+         do J=JMS,JME
+         do K=KMS,KME
+         do I=IMS,IME
+          F_RAIN_PHY(I,K,J)=F_RAIN(I,K,J)
+         enddo
+         enddo
+         enddo
+        ENDIF
+
+        IF (maxval(F_RIMEF) .gt. 0.) THEN
+        write(0,*) 'F_RIMEF > 0'
+         do J=JMS,JME
+         do K=KMS,KME
+         do I=IMS,IME
+          F_RIMEF_PHY(I,K,J)=F_RIMEF(I,K,J)
+         enddo
+         enddo
+         enddo
+        ENDIF
+	ENDIF
+
+!mp
+        IF (.NOT. RESTRT) THEN
+      DO J=JMS,JME
+      DO I=IMS,IME
+        Z0(I,J)=Z0_DUM(I,J)+0.5*Z0(I,J) ! add 1/2 of veg Z0 component,
+                                        ! expecting this code to be called
+                                        ! both by real and by the model.
+      ENDDO
+      ENDDO
+  !-- Replace albedos if original albedos are nonzero
+      IF(MAXVAL(ALBEDO_DUM)>0.)THEN
+        DO J=JMS,JME
+        DO I=IMS,IME
+          ALBEDO(I,J)=ALBEDO_DUM(I,J)
+        ENDDO
+        ENDDO
+      ENDIF
+        ENDIF
+
+      DO J=JMS,JME
+      DO I=IMS,IME
+        APREC(I,J)=RAINNC(I,J)*1.E-3
+        CUPREC(I,J)=RAINCV(I,J)*1.E-3
+      ENDDO
+      ENDDO
+!following will need mods Sep06
+!
+#ifdef WRF_CHEM
+      DO J=JTS,JTE
+        JJ=MIN(JDE-1,J)
+        DO K=KTS,KTE-1
+          KK=MIN(KDE-1,K)
+          DO I=ITS,ITE
+            II=MIN(IDE-1,I)
+            CONVFAC(I,K,J) = PINT(II,KK,JJ)/RGASUNIV/T(II,KK,JJ)
+          ENDDO
+        ENDDO
+      ENDDO
+!
+         CALL CHEM_INIT (GRID%ID,CHEM,GRID%DT,GRID%BIOEMDT,GRID%PHOTDT,GRID%CHEMDT, &
+               STEPBIOE,STEPPHOT,STEPCHEM,                           &
+               ZINT,G,AERWRF,CONFIG_FLAGS,                           &
+               RRI,T,PINT,CONVFAC,GD_CLOUD_B,GD_CLOUD2_B,            &
+               TAUAER1,TAUAER2,TAUAER3,TAUAER4,                      &
+               GAER1,GAER2,GAER3,GAER4,                              &
+               WAER1,WAER2,WAER3,WAER4,                              &
+               PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC,GRID%CHEM_IN_OPT,  &
+               IDS , IDE , JDS , JDE , KDS , KDE ,                   &
+               IMS , IME , JMS , JME , KMS , KME ,                   &
+               ITS , ITE , JTS , JTE , KTS , KTE                     )
+!     
+! calculate initial pm
+!     
+        SELECT CASE (CONFIG_FLAGS%CHEM_OPT)
+        CASE (RADM2SORG, RACMSORG,RACMSORG_KPP)
+           CALL SUM_PM_SORGAM (                                             &
+                RRI, CHEM, H2OAJ, H2OAI,                                    &
+                PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10,                 &
+                IDS,IDE, JDS,JDE, KDS,KDE,                                  &
+                IMS,IME, JMS,JME, KMS,KME,                                  &
+                ITS,ITE, JTS,JTE, KTS,KTE                                   )
+               
+        CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ)
+           CALL SUM_PM_MOSAIC (                                             &
+                RRI, CHEM,                                                  &
+                PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10,                 &
+                IDS,IDE, JDS,JDE, KDS,KDE,                                  &
+                IMS,IME, JMS,JME, KMS,KME,                                  &
+                ITS,ITE, JTS,JTE, KTS,KTE                                   )
+               
+        CASE DEFAULT
+           DO J=JTS,MIN(JTE,JDE-1)
+              DO K=KTS,MIN(KTE,KDE-1)
+                 DO I=ITS,MIN(ITE,IDE-1)
+                    PM2_5_DRY(I,K,J)    = 0.
+                    PM2_5_WATER(I,K,J)  = 0.
+                    PM2_5_DRY_EC(I,K,J) = 0.
+                    PM10(I,K,J)         = 0.
+                 ENDDO
+              ENDDO
+           ENDDO
+        END SELECT
+#endif
+      DEALLOCATE(SFULL)
+      DEALLOCATE(SMID)
+      DEALLOCATE(DZS)
+      DEALLOCATE(EMISS)
+      DEALLOCATE(GLW)
+      DEALLOCATE(HFX)
+      DEALLOCATE(LOWLYR)
+!     DEALLOCATE(MAVAIL)
+      DEALLOCATE(NCA)
+      DEALLOCATE(QFX)
+      DEALLOCATE(RAINBL)
+      DEALLOCATE(RAINC)
+      DEALLOCATE(RAINNC)
+      DEALLOCATE(RAINNCV)
+      DEALLOCATE(RQCBLTEN)
+      DEALLOCATE(RQIBLTEN)
+      DEALLOCATE(RQVBLTEN)
+      DEALLOCATE(RTHBLTEN)
+      DEALLOCATE(RUBLTEN)
+      DEALLOCATE(RVBLTEN)
+      DEALLOCATE(RQCCUTEN)
+      DEALLOCATE(RQICUTEN)
+      DEALLOCATE(RQRCUTEN)
+      DEALLOCATE(RQSCUTEN)
+      DEALLOCATE(RQVCUTEN)
+      DEALLOCATE(RTHCUTEN)
+      DEALLOCATE(RTHRATEN)
+      DEALLOCATE(RTHRATENLW)
+      DEALLOCATE(RTHRATENSW)
+      DEALLOCATE(ZINT)
+      DEALLOCATE(CONVFAC)
+#ifndef WRF_CHEM
+      DEALLOCATE(CLDFRA_OLD)
+#endif
+      DEALLOCATE(RRI)
+!     DEALLOCATE(ZMID)
+      DEALLOCATE(SNOWC)
+      DEALLOCATE(THC)
+      DEALLOCATE(TMN)
+      DEALLOCATE(TSFC)
+      DEALLOCATE(ZS)
+#if 0
+      DEALLOCATE(W0AVG)
+#endif
+!-----------------------------------------------------------------------
+!----------------------------------------------------------------------
+        DO J=jfs,jfe
+        DO I=ifs,ife
+          DWDTMN(I,J)=DWDTMN(I,J)*HBM3(I,J)
+          DWDTMX(I,J)=DWDTMX(I,J)*HBM3(I,J)
+        ENDDO
+        ENDDO
+!----------------------------------------------------------------------
+!***  INITIALIZE 3RD INDEX IN WORKING ARRAYS USED IN PFDHT, DDAMP, AND  
+!***  HZADV.  THESE ARRAYS MUST HAVE AN EXTENT OF MORE THAN 1 IN J DUE 
+!***  TO THE MANY DIFFERENCES AND AVERAGES THAT ARE COMPUTED IN J
+!***  OR BECAUSE THE ARRAY IS SIMPLY REFERENCED AT MORE THAN ONE J.
+!***  THE WORKING "SPACE" SPANS FROM 3 ROWS SOUTH TO 3 ROWS NORTH
+!***  OF THE ROW FOR WHICH THE PRIMARY COMPUTATION IS BEING DONE
+!***  THUS THE 3RD DIMENSION CAN VARY FROM -3 TO +3 ALTHOUGH ALL OF
+!***  THESE ARRAYS DO NOT NEED TO SPAN THAT MANY ROWS.  FOR INSTANCE,
+!***  SOME OF THE ARRAYS ARE ONLY USED FROM 2 ROWS SOUTH TO 1 ROW 
+!***  NORTH, OR FROM 1 ROW SOUTH TO THE CENTRAL ROW.  AS THE INTEGRATION
+!***  MOVES NORTHWARD, THE SOUTHERNMOST I,K SLAB IS DROPPED FOR EACH
+!***  WORKING ARRAY AND THE NORTHERNMOST IS GENERATED.  SO AS NOT TO
+!***  HAVE TO ACTUALLY MOVE ANY OF THE I,K SLABS NORTHWARD, THE 3RD
+!***  INDEX IS CYCLED THROUGH THE EXTENT OF EACH ARRAY'S J DIMENSION.
+!***  THE FOLLOWING WILL FILL AN ARRAY WITH THE VALUES OF THE 3RD
+!***  INDEX FOR EACH THESE VARIATIONS OF J EXTENTS FOR ALL J's IN
+!***  THE LOCAL DOMAIN.
+!----------------------------------------------------------------------
+!
+!***  CASE 0: J EXTENT IS -3 TO 3
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP3=KNT+2-7*((KNT+5)/7)
+        JP2=JP3-1+7*((4-JP3)/7)
+        JP1=JP2-1+7*((4-JP2)/7)
+        J00=JP1-1+7*((4-JP1)/7)
+        JM1=J00-1+7*((4-J00)/7)
+        JM2=JM1-1+7*((4-JM1)/7)
+        JM3=JM2-1+7*((4-JM2)/7)
+        INDX3_WRK(3,KNT,0)=JP3
+        INDX3_WRK(2,KNT,0)=JP2
+        INDX3_WRK(1,KNT,0)=JP1
+        INDX3_WRK(0,KNT,0)=J00
+        INDX3_WRK(-1,KNT,0)=JM1
+        INDX3_WRK(-2,KNT,0)=JM2
+        INDX3_WRK(-3,KNT,0)=JM3
+      ENDDO
+!
+!***  CASE 1: J EXTENT IS -2 TO 2
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP2=KNT+1-5*((KNT+3)/5)
+        JP1=JP2-1+5*((3-JP2)/5)
+        J00=JP1-1+5*((3-JP1)/5)
+        JM1=J00-1+5*((3-J00)/5)
+        JM2=JM1-1+5*((3-JM1)/5)
+        INDX3_WRK(3,KNT,1)=999
+        INDX3_WRK(2,KNT,1)=JP2
+        INDX3_WRK(1,KNT,1)=JP1
+        INDX3_WRK(0,KNT,1)=J00
+        INDX3_WRK(-1,KNT,1)=JM1
+        INDX3_WRK(-2,KNT,1)=JM2
+        INDX3_WRK(-3,KNT,1)=999
+      ENDDO
+!
+!***  CASE 2: J EXTENT IS -2 TO 1
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP1=KNT-4*((KNT+2)/4)
+        J00=JP1-1+4*((2-JP1)/4)
+        JM1=J00-1+4*((2-J00)/4)
+        JM2=JM1-1+4*((2-JM1)/4)
+        INDX3_WRK(3,KNT,2)=999
+        INDX3_WRK(2,KNT,2)=999
+        INDX3_WRK(1,KNT,2)=JP1
+        INDX3_WRK(0,KNT,2)=J00
+        INDX3_WRK(-1,KNT,2)=JM1
+        INDX3_WRK(-2,KNT,2)=JM2
+        INDX3_WRK(-3,KNT,2)=999
+      ENDDO
+!
+!***  CASE 3: J EXTENT IS -1 TO 2
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP2=KNT+1-4*((KNT+2)/4)
+        JP1=JP2-1+4*((3-JP2)/4)
+        J00=JP1-1+4*((3-JP1)/4)
+        JM1=J00-1+4*((3-J00)/4)
+        INDX3_WRK(3,KNT,3)=999
+        INDX3_WRK(2,KNT,3)=JP2
+        INDX3_WRK(1,KNT,3)=JP1
+        INDX3_WRK(0,KNT,3)=J00
+        INDX3_WRK(-1,KNT,3)=JM1
+        INDX3_WRK(-2,KNT,3)=999
+        INDX3_WRK(-3,KNT,3)=999
+      ENDDO
+!
+!***  CASE 4: J EXTENT IS -1 TO 1
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP1=KNT-3*((KNT+1)/3)
+        J00=JP1-1+3*((2-JP1)/3)
+        JM1=J00-1+3*((2-J00)/3)
+        INDX3_WRK(3,KNT,4)=999
+        INDX3_WRK(2,KNT,4)=999
+        INDX3_WRK(1,KNT,4)=JP1
+        INDX3_WRK(0,KNT,4)=J00
+        INDX3_WRK(-1,KNT,4)=JM1
+        INDX3_WRK(-2,KNT,4)=999
+        INDX3_WRK(-3,KNT,4)=999
+      ENDDO
+!
+!***  CASE 5: J EXTENT IS -1 TO 0
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        J00=-MOD(KNT+1,2)
+        JM1=-1-J00
+        INDX3_WRK(3,KNT,5)=999
+        INDX3_WRK(2,KNT,5)=999
+        INDX3_WRK(1,KNT,5)=999
+        INDX3_WRK(0,KNT,5)=J00
+        INDX3_WRK(-1,KNT,5)=JM1
+        INDX3_WRK(-2,KNT,5)=999
+        INDX3_WRK(-3,KNT,5)=999
+      ENDDO
+!
+!***  CASE 6: J EXTENT IS 0 TO 1
+!
+      KNT=0
+      DO J=MYJS2_P2,MYJE2_P2
+        KNT=KNT+1
+        JP1=MOD(KNT,2)
+        J00=1-JP1
+        INDX3_WRK(3,KNT,6)=999
+        INDX3_WRK(2,KNT,6)=999
+        INDX3_WRK(1,KNT,6)=JP1
+        INDX3_WRK(0,KNT,6)=J00
+        INDX3_WRK(-1,KNT,6)=999
+        INDX3_WRK(-2,KNT,6)=999
+        INDX3_WRK(-3,KNT,6)=999
+      ENDDO
+
+#ifdef DM_PARALLEL
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#  include 
+#endif
+
+#define COPY_OUT
+#include 
+
+   RETURN
+
+
+END SUBROUTINE start_domain_nmm
+
diff --git a/wrfv2_fire/external/IOAPI b/wrfv2_fire/external/IOAPI
new file mode 100644
index 00000000..a5a38c1b
--- /dev/null
+++ b/wrfv2_fire/external/IOAPI
@@ -0,0 +1,4 @@
+
+Please see http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the 
+latest documentation of the WRF I/O API.  
+
diff --git a/wrfv2_fire/external/Makefile b/wrfv2_fire/external/Makefile
new file mode 100644
index 00000000..936119c5
--- /dev/null
+++ b/wrfv2_fire/external/Makefile
@@ -0,0 +1,18 @@
+
+
+superclean :
+	( cd esmf_time_f90 ;  make superclean )
+	( cd io_netcdf ;  make superclean )
+	( cd io_pnetcdf ;  make superclean )
+	( cd io_int ; make superclean )
+	( cd io_mcel ;  make superclean )
+	( cd io_phdf5 ; make superclean )
+	( cd io_grib1 ; make superclean )
+	( cd io_grib_share ; make superclean )
+	( cd io_grib2 ; make superclean )
+	( cd io_esmf ;  make superclean )
+	( cd ioapi_share ;  make superclean )
+	( cd RSL/RSL ; make superclean )
+	( cd RSL_LITE ; make superclean )
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/LoopMacros.inc b/wrfv2_fire/external/RSL/RSL/LoopMacros.inc
new file mode 100644
index 00000000..a37495ec
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/LoopMacros.inc
@@ -0,0 +1,38 @@
+c#define OLDR90
+
+#ifdef OLDR90
+# define MAX_RUNPAD 0
+#else
+# define MAX_RUNPAD 2
+#endif
+
+#ifndef RSL_MAXRUN
+# define RSL_MAXRUN 700
+#endif
+
+
+#  define RSL_RUN_ARGS  xinest,nrunj,nruni,js,is,ie,is2,js2,je2,idif,jdif
+#  define RSL_RUN_VARS RSL_RUN_ARGS
+
+#  define RSL_INIT_RUNS(D) rsl_get_run_info(D,RSL_MAXRUN,RSL_RUN_VARS)
+
+#  define RSL_DECLARE_RUN_ARGS integer xinest,nrunj,nruni,js(nrunj),is(nrunj),ie(nrunj),is2(nruni),js2(nruni),je2(nruni),idif,jdif,nr,ig,jg
+#  define RSL_DECLARE_RUN_VARS integer xinest,nrunj,nruni,js(RSL_MAXRUN),is(RSL_MAXRUN),ie(RSL_MAXRUN),is2(RSL_MAXRUN),js2(RSL_MAXRUN),je2(RSL_MAXRUN),idif,jdif,nr,ig,jg
+
+#  define RSL_MAJOR_BOUND(J,L,H) if ((((J)-jdif).ge.(L)).and.(((J)-jdif).le.(H))) then
+#  define RSL_MINOR_BOUND(I,L,H) if ((((I)-idif).ge.(L)).and.(((I)-idif).le.(H))) then
+#  define RSL_END_BOUND  endif
+
+#  define RSL_MAJOR_LOOP(J) do nr=1+MAX_RUNPAD,nrunj+MAX_RUNPAD;J=js(nr);jg=J-jdif
+#  define RSL_END_MAJOR_LOOP enddo
+
+#  define RSL_MINOR_LOOP(I) do I=is(nr),ie(nr);ig=I-idif
+#  define RSL_END_MINOR_LOOP enddo
+
+#  define RSL_MAJOR_LOOPB(J,L,H) do nr=1+MAX_RUNPAD,nrunj+MAX_RUNPAD;J=js(nr);jg=J-jdif;RSL_MAJOR_BOUND(J,L,H)
+#  define RSL_END_MAJOR_LOOPB RSL_END_BOUND ; enddo
+
+#  define RSL_MINOR_LOOPB(I,L,H) do I=is(nr),ie(nr);ig=I-idif;RSL_MINOR_BOUND(I,L,H)
+#  define RSL_END_MINOR_LOOPB RSL_END_BOUND ; enddo
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/README b/wrfv2_fire/external/RSL/RSL/README
new file mode 100755
index 00000000..e69de29b
diff --git a/wrfv2_fire/external/RSL/RSL/TODO b/wrfv2_fire/external/RSL/RSL/TODO
new file mode 100755
index 00000000..e69de29b
diff --git a/wrfv2_fire/external/RSL/RSL/bcopy.c b/wrfv2_fire/external/RSL/RSL/bcopy.c
new file mode 100755
index 00000000..d9377e1f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/bcopy.c
@@ -0,0 +1,75 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+bcopy( a, b, n )
+  char *a, *b ;
+  int n ;
+{
+  register int i ;
+  for ( i = 0 ; i < n ; i++ )
+  {
+    *b++ = *a++ ;
+  }
+}
+
+bzero( a, n )
+  char *a ;
+  int n ;
+{
+  register int i ;
+  for ( i = 0 ; i < n ; i++ ) *a++ = '\0' ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/border.c b/wrfv2_fire/external/RSL/RSL/border.c
new file mode 100755
index 00000000..45cf7756
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/border.c
@@ -0,0 +1,158 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+static int zero = 0 ;
+
+rsl_processor_t
+locproc( i, m, numproc )
+  rsl_index_t i ;
+  rsl_dimlen_t m ;
+  rsl_processor_t numproc ;
+{
+  int val ;
+  rsl_processor_t retval ;
+
+  int ii, im, inumproc ;
+
+  ii = i ; im = m ; inumproc = numproc ;
+  c_locproc( &ii, &im, &inumproc, &zero, &zero, &val ) ;
+  retval = val ;
+  return( retval ) ;
+}
+  
+
+
+/***************************************************************************
+ patchmap routine:
+      Given position(p) in the global dimension (max) in the grid, with
+      margins of size ml (left/top) and mr (right/bottom), divide it among
+      the nproc processors in that dimension so the margins get at least
+      the margin and no more than width+1 processes.
+
+                          J A Mogill         19 April 1993
+****************************************************************************/
+
+c_locproc(p, max, nproc, ml, mr, ret)
+int *p, *max, *nproc, *ml, *mr, *ret;
+
+{ 
+  int width, rem, ret2, bl, br, mid, adjust;
+
+  int p_r, max_r, nproc_r, zero ;
+
+  adjust = 0;
+  rem = *max%*nproc;
+  width = *max/(*nproc);
+  mid = *max/2;
+
+  if(rem>0 && ((rem%2==0 || rem>2) || *p<=mid ))
+     width++;
+  if(*p<=mid && rem%2!=0)
+     adjust++;
+
+  bl = maximum(width,*ml);
+  br = maximum(width,*mr);
+
+  if(*p*max-br-1)
+     *ret = *nproc-1;
+  else
+     {
+       p_r = *p-bl ;
+       max_r = *max-bl-br+adjust ;
+       nproc_r = maximum(*nproc-2,1) ;
+       zero = 0 ;
+
+       c_locproc( &p_r, &max_r, &nproc_r, &zero, &zero, &ret2);
+       *ret = ret2 + 1;
+     }
+}
+
+
+
+
+
+
+int maximum(x,y)
+int x,y;
+
+ {
+   if(x>=y)
+     return(x);
+   else
+     return(y);
+ }
+
+#if 0
+main()
+{
+   int i, m, numproc ;
+   m = 61 ;
+   numproc = 10 ;
+   for ( i = 0; i < 61 ; i++ ) 
+   {
+   printf("locproc(%d,%d,%d) = %d\n",i,m,numproc,locproc(i,m,numproc)) ;
+   }
+}
+#endif
+
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/boundary_safe.F b/wrfv2_fire/external/RSL/RSL/boundary_safe.F
new file mode 100755
index 00000000..29dc3426
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/boundary_safe.F
@@ -0,0 +1,281 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine boundary_safe( pid, bwdth, ix, jx, il, jl )
+      implicit none
+
+      integer bwdth		! boundary width
+      integer ix, jx		! static dimensions
+      integer il, jl		! effective dimensions
+      integer pid( ix, jx )	! map array
+
+      integer i, j, p, q, problem, strat, a, b
+
+c boundary safe in east-west -- we do not want the e/w boundaries
+c decomposed in this dimension. 
+
+c check western boundary
+      do i = 1, ix
+        problem = 0
+        p = pid(i,1)
+        do j = 1,bwdth
+          if ( p .ne. pid(i,j) .and. problem .eq. 0 ) problem = j
+        enddo
+        if ( problem .ne. 0 ) then
+
+           q = pid(i,problem)
+	   strat = 1
+           do j = problem, problem+bwdth-1
+             if ( pid(i,j) .ne. q ) then
+	       if ( j .le. bwdth ) then		! no hope for it
+                 write(0,*)'wb: problem with mapper: use patchmap'
+                 goto 890
+	       endif
+	       strat = 2
+             endif
+           enddo
+
+	   if ( strat .eq. 1 ) then		! stategy 1 -- move offending
+						! point(s) from boundary area
+             j = problem
+             do q = 1, bwdth
+               pid(i,q) = pid(i,j)
+               j = j+1
+             enddo
+             j = bwdth+1
+             do q = 1, problem-1
+               pid(i,j) = p
+               j = j+1
+             enddo
+	   else					! strategy 2 -- make all one
+						! or the other
+c	     write(0,*) 'wb using strat 2 on i=',i
+	     a = problem - 1		! # points on first proc
+	     b = bwdth - a 		! # points on second
+	     if ( a .lt. b ) then
+	       do j = 1, a
+		 pid( i, j ) = pid( i, bwdth ) 
+	       enddo
+	     else
+	       do j = a+1, bwdth
+		 pid( i, j ) = pid( i, 1 ) 
+	       enddo
+	     endif
+	   endif
+        endif
+      enddo
+c check southern boundary
+      do j = 1, jx
+        problem = 0
+        p = pid(1,j)
+        do i = 1,bwdth
+          if ( p .ne. pid(i,j) .and. problem .eq. 0 ) problem = i
+        enddo
+        if ( problem .ne. 0 ) then
+
+           q = pid(problem,j)
+           strat = 1
+           do i = problem, problem+bwdth-1
+             if ( pid(i,j) .ne. q ) then
+               if ( i .le. bwdth ) then           ! no hope for it
+                 write(0,*)'sb: problem with mapper: use patchmap'
+                 goto 890
+               endif
+               strat = 2
+             endif
+           enddo
+
+           if ( strat .eq. 1 ) then             ! stategy 1 -- move offending
+                                                ! point(s) from boundary area
+             i = problem
+             do q = 1, bwdth
+               pid(q,j) = pid(i,j)
+               i = i+1
+             enddo
+             i = bwdth+1
+             do q = 1, problem-1
+               pid(i,j) = p
+               i = i+1
+             enddo
+           else                                 ! strategy 2 -- make all one
+                                                ! or the other
+c             write(0,*) 'sb using strat 2 on j=',j
+             a = problem - 1            ! # points on first proc
+             b = bwdth - a              ! # points on second
+             if ( a .lt. b ) then
+               do i = 1, a
+                 pid( i, j ) = pid( bwdth, j )
+               enddo
+             else
+               do i = a+1, bwdth
+                 pid( i, j ) = pid( 1, j )
+               enddo
+             endif
+           endif
+        endif
+      enddo
+c check eastern boundary
+      do i = 1, ix
+        problem = 0
+        p = pid(i,jl)
+        do j = jl,jl-bwdth,-1   ! this covers bwdth+1 cells for beta grid
+          if ( p .ne. pid(i,j) .and. problem .eq. 0 ) problem = j
+        enddo
+        if ( problem .ne. 0 ) then
+
+           q = pid(i,problem)
+           strat = 1
+           do j = problem, problem-bwdth, -1
+             if ( pid(i,j) .ne. q ) then
+               if ( j .ge. jl-bwdth+1 ) then              ! no hope for it
+                 write(0,*)'eb: problem with mapper: use patchmap'
+                 goto 890
+               endif
+               strat = 2
+             endif
+           enddo
+
+           if ( strat .eq. 1 ) then             ! stategy 1 -- move offending
+                                                ! point(s) from boundary area
+             j = problem
+             do q = jl,jl-bwdth,-1
+               pid(i,q) = pid(i,j)
+               j = j-1
+             enddo
+             j = jl-bwdth-1
+             do q = jl,problem+1,-1
+               pid(i,j) = p
+               j = j-1
+             enddo
+           else                                 ! strategy 2 -- make all one
+                                                ! or the other
+c             write(0,*) 'eb using strat 2 on i=',i
+             a = jl - problem           ! # points on first proc
+             b = bwdth - a              ! # points on second
+             if ( a .lt. b ) then
+               do j = jl, jl-a+1, -1
+                 pid( i, j ) = pid( i, jl-bwdth+1 )
+               enddo
+             else
+               do j = jl-a, jl-bwdth+1, -1
+                 pid( i, j ) = pid( i, jl )
+               enddo
+             endif
+           endif
+        endif
+      enddo
+c check northern boundary
+      do j = 1, jx
+        problem = 0
+        p = pid(il,j)
+        do i = il,il-bwdth,-1   ! this covers bwdth+1 cells for beta grid
+          if ( p .ne. pid(i,j) .and. problem .eq. 0 ) problem = i
+        enddo
+        if ( problem .ne. 0 ) then
+
+           q = pid(problem,j)
+           strat = 1
+           do i = problem, problem-bwdth, -1
+             if ( pid(i,j) .ne. q ) then
+               if ( i .ge. il-bwdth+1 ) then              ! no hope for it
+                 write(0,*)'nb: problem with mapper: use patchmap'
+                 goto 890
+               endif
+               strat = 2
+             endif
+           enddo
+
+           if ( strat .eq. 1 ) then             ! stategy 1 -- move offending
+                                                ! point(s) from boundary area
+             i = problem
+             do q = il,il-bwdth,-1
+               pid(q,j) = pid(i,j)
+               i = i-1
+             enddo
+             i = il-bwdth-1
+             do q = il,problem+1,-1
+               pid(i,j) = p
+               i = i-1
+             enddo
+           else                                 ! strategy 2 -- make all one
+                                                ! or the other
+c             write(0,*) 'nb using strat 2 on j=',j
+             a = il - problem           ! # points on first proc
+             b = bwdth - a              ! # points on second
+             if ( a .lt. b ) then
+               do i = il, il-a+1, -1
+                 pid( i, j ) = pid( il-bwdth+1, j )
+               enddo
+             else
+               do i = il-a, il-bwdth+1, -1
+                 pid( i, j ) = pid( il, j )
+               enddo
+             endif
+
+           endif
+        endif
+      enddo
+
+c boundary safe in north-south -- we do not want the n/s boundaries
+c decomposed in this dimension
+
+      return
+ 890  continue
+      stop
+      end
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/buf_for_proc.c b/wrfv2_fire/external/RSL/RSL/buf_for_proc.c
new file mode 100755
index 00000000..d6216fb6
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/buf_for_proc.c
@@ -0,0 +1,210 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+typedef struct bufdesc {
+  char * buf ;
+  int size ;
+} bufdesc_t ;
+
+/* buftab[RSL_SENDBUF] is send buffer descriptor,
+   buftab[RSL_RECVBUF] is recv buffer descriptor. */
+static bufdesc_t buftab[2][RSL_MAXPROC] ;
+static int first = 1 ;
+
+#ifdef NEC_TUNE
+/*
+   NECNOTE:
+   modify RSL message buffering scheme to utilize NEC Global Memory
+   to aid in performance of MPI Message Passing on Multi-node SX machines.
+*/
+#include 
+#include 
+#define MAXBUFSIZE 1024*1024*64 /* NEC Global Memory buffer size */
+#endif
+/* 
+   buffer_for_proc
+
+   returns a pointer to a buffer already allocated for processor P if
+   it is big enough; otherwise, it frees the existing buffer, if there
+   is one and then allocates a new one that is big enough.  If RSL_FREEBUF
+   is called for a P, the two buffers (send and recv) are truncated and
+   freed and NULL is returned.
+
+   You are guaranteed to get back the same buffer as the previous call
+   for a given P, as long as the size is less than the size passed to
+   the previous call.  Thus, you can use this routine to manage the
+   pointers to the buffers for P and avoid having to set up arrays
+   of pointers in the routines that use these buffers.
+
+*/
+
+char *
+buffer_for_proc( P, size, code )
+  rsl_processor_t P ;   /* processor number */
+  int size,		/* requested size */
+      code ;		/* RSL_SENDBUF, RSL_RECVBUF, or RSL_FREEBUF */
+{
+  rsl_processor_t p ;
+  int i, j ;
+  char * ret ;
+#ifdef NEC_TUNE
+  static char * private_buf ; /* pointer to NEC Global Memory */
+  static int cur_indx ;       /* size of total user memory requests */
+#endif
+
+  ret = NULL ;
+  if ( first )
+  {
+    for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+    {
+      buftab[0][p].buf  = NULL ;    
+      buftab[1][p].buf  = NULL ;    
+      buftab[0][p].size = 0 ;    
+      buftab[1][p].size = 0 ;    
+    }
+#ifdef NEC_TUNE
+    MPI_Alloc_mem(MAXBUFSIZE, MPI_INFO_NULL, &private_buf) ;
+    cur_indx = 0 ;
+#endif
+    first = 0 ;
+  }
+  if ( P < 0 || P >= RSL_MAXPROC )
+  {
+#ifndef NEC_TUNE
+    sprintf(mess,"Bad P argument to buffer_for_proc.  P = %d. Has RSL_MESH been called?\n",P) ;
+    RSL_TEST_ERR( 1, mess ) ;
+#else
+    fprintf(stderr,"Bad P argument to buffer_for_proc.  P = %d. Has RSL_MESH been called?\n",P) ;
+#endif
+  }
+  if ( code == RSL_FREEBUF )
+  {
+/* fprintf(stderr,"buffer_for_proc freeing buffer %d\n",P) ; */
+/* NECNOTE: do not free Global Memory */
+#ifndef NEC_TUNE
+    if ( buftab[0][P].buf != NULL ) RSL_FREE( buftab[0][P].buf ) ;
+    if ( buftab[1][P].buf != NULL ) RSL_FREE( buftab[1][P].buf ) ;
+    buftab[0][P].buf  = NULL ;    
+    buftab[1][P].buf  = NULL ;    
+    buftab[0][P].size = 0 ;    
+    buftab[1][P].size = 0 ;    
+#endif
+/* show_tot_size() ; */
+  }
+  else if ( code == RSL_SENDBUF || code == RSL_RECVBUF )
+  {
+    if ( buftab[code][P].size < size )
+    {
+/* fprintf(stderr,"buffer_for_proc %s %d : was %d, increasing to %d\n",
+         (code == RSL_SENDBUF)?"RSL_SENDBUF":"RSL_RECVBUF",
+	 P,buftab[code][P].size, size+512) ; */
+#ifndef NEC_TUNE
+      if ( buftab[code][P].buf != NULL ) RSL_FREE( buftab[code][P].buf ) ;
+      buftab[code][P].buf = RSL_MALLOC(char,size+512) ;
+      buftab[code][P].size = size ;
+#else
+/*
+   NECNOTE:
+   if we exceed the GLOBAL MEMORY allocated, stop program.
+   user should increase MAXBUFSIZE above to fix problem.
+*/
+      if( (cur_indx+size) > MAXBUFSIZE )
+      {
+        fprintf(stderr,
+          "<<>> exceeded MAXBUFSIZE %ld requested %ld bytes",
+          MAXBUFSIZE, cur_indx+size) ;
+        exit(3) ;
+      }
+      buftab[code][P].buf = private_buf ;
+      buftab[code][P].size = size ;
+      private_buf =  private_buf + size+512 ;
+      cur_indx = cur_indx + size+512 ;
+#endif
+/* show_tot_size() ; */
+    }
+    ret = buftab[code][P].buf ;
+  }
+  return(ret) ;
+}
+
+show_tot_size()
+{
+  int P ;
+  int acc ;
+  acc = 0 ;
+  for ( P = 0 ; P < RSL_MAXPROC ; P++ )
+  {
+    acc += buftab[0][P].size ;
+    acc += buftab[1][P].size ;
+  }
+#ifndef NEC_TUNE
+  fprintf(stderr,"Total bytes allocated for buffers: %d\n", acc ) ;
+#else
+  printf("Total bytes allocated for buffers: %d\n", acc ) ;
+#endif
+}
+
+int
+buffer_size_for_proc( P, code )
+  int P ;
+  int code ;
+{
+  return( buftab[code][P].size ) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/buf_for_proc.h b/wrfv2_fire/external/RSL/RSL/buf_for_proc.h
new file mode 100755
index 00000000..9042d9b4
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/buf_for_proc.h
@@ -0,0 +1,68 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef BUFFER_FOR_PROC_H
+#define BUFFER_FOR_PROC_H
+
+#define RSL_SENDBUF 0
+#define RSL_RECVBUF 1
+#define RSL_FREEBUF 2
+
+char * buffer_for_proc() ;	/* forward declaration */
+
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/build_rsltest b/wrfv2_fire/external/RSL/RSL/build_rsltest
new file mode 100755
index 00000000..4384da92
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/build_rsltest
@@ -0,0 +1,19 @@
+#!/bin/csh
+
+# for IBM
+
+#setenv F90 "mpxlf -qfixed=132 -qnosave "
+#setenv RSLLIB RSL/librsl.a
+
+# for Alpha
+
+set echo
+
+setenv F90 "mpif90 -g -extend_source"
+#setenv F90 "f90 -g -extend_source"
+setenv RSLLIB ./librsl.a
+
+/lib/cpp -C -P rsltest.F > rsltest.f
+$F90 -c rsltest.f
+$F90 -o tst rsltest.o $RSLLIB
+
diff --git a/wrfv2_fire/external/RSL/RSL/cd.c b/wrfv2_fire/external/RSL/RSL/cd.c
new file mode 100755
index 00000000..f5225c98
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/cd.c
@@ -0,0 +1,317 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+
+#ifdef STANDALONE
+  typedef int * int_p ;
+# define RSL_INVALID -1
+# define RSL_VALID 1
+# define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+# define INDEX_3(A,B,NB,C,NC)  INDEX_2( (A), INDEX_2( (B), (C), (NC) ), (NB)*(NC))
+# define RSL_MALLOC(T,N)  (T *)malloc((sizeof(T))*(N))
+# define RSL_MALLOC(T,N)  (T *)malloc((sizeof(T))*(N))
+# define RSL_FREE(P)  free(P)
+# define BOUNDARY_SAFE boundary_safe_
+
+main()
+{
+  int i,m,n,py,px ;
+  int bwdth ;
+  int wk1[4000], wk2[4000] ;
+  for ( i = 0 ; i < 4000 ; i++ ) wk1[i] = RSL_VALID ;
+  printf("m n py px bwdth\n") ; scanf("%d %d %d %d %d",&m,&n,&py,&px,&bwdth) ;
+  rsl_default_decomp( wk1, wk2, NULL, &m,&n,&py,&px ) ;
+  if ( bwdth > 0 ) BOUNDARY_SAFE ( wk2, &bwdth, &m, &n, &m, &n ) ;
+  print_region( wk2, m,n) ; 
+}
+#else
+#  include "rsl.h"
+#endif
+
+/*#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) ) */
+
+mark_line( wrk, m, n, x1, y1, x2, y2, val )
+  int wrk[] ;
+  int m, n, x1, y1, x2, y2, val ;
+{
+  int x, y, i, j, k ;
+  int yz, yz2, dex ;
+
+  double SLOPE, X, Y, DX, DY, dY, X1, X2, Y1, Y2 ;
+
+  X1 = x1 ;
+  X2 = x2 ;
+  DX = X2 - X1 ;
+  Y1 = y1 ;
+  Y2 = y2 ;
+  DY = Y2 - Y1 ;
+  if ( DX == 0.0 )
+  {
+    if ( y2 >= y1 )
+      for ( i = y1 ; i <= y2 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    else
+      for ( i = y2 ; i <= y1 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    return ;
+  }
+  else
+  {
+    SLOPE = DY/DX ;
+    dY = SLOPE * .5 ;
+  }
+
+  if ( x2 >= X1 )
+  {
+    Y = y1 + .5 ;
+    for ( X = x1+.5 ; X < x2+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x2, y2, m )] = val ;
+  }
+  else
+  {
+    Y = y2 + .5 ;
+    for ( X = x2+.5 ; X < x1+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x1, y1, m )] = val ;
+  }
+}
+
+fill_region( wrk, m, n, v, v2 )
+  int wrk[], m, n, v, v2 ;
+{
+  int x, y ;
+  
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flood( 0, y, v, v2, wrk, m, n ) ;
+    flood( n-1, y, v, v2, wrk, m, n ) ;
+  }
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flood( x, 0, v, v2, wrk, m, n ) ;
+    flood( x, m-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+flood( x, y, v, v2, wrk, m, n )
+  int x, y, v, v2, wrk[], m, n ;
+{
+  if ( x < 0 || x >= n || y < 0 || y >= m )
+    return ;
+  if ( wrk[INDEX_2(x,y,m)] == v )
+  {
+    wrk[INDEX_2(x,y,m)] = v2 ;
+    flood( x+1, y  , v, v2, wrk, m, n ) ;
+    flood( x-1, y  , v, v2, wrk, m, n ) ;
+    flood( x  , y+1, v, v2, wrk, m, n ) ;
+    flood( x  , y-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+decomp_region_2( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+  wk = RSL_MALLOC( int, m*n ) ;
+
+  nprocs = px * py ;
+
+  ncells = 0 ;
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != -1 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+#if 0
+printf("ncells %d\n",ncells) ;
+printf("nprocs %d\n",nprocs) ;
+printf("n_p    %d\n",n_p) ;
+#endif
+
+  /* divide over py in m dimension first */
+  pid = -1 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != RSL_INVALID )
+      {
+        if ( i % n_py == 0 ) pid++ ;
+        i++ ;
+        if ( pid > py-1 ) pid = py-1 ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  /* now divide over px in n dimension */
+  n_px = n_py / px ;
+  for ( p = 0 ; p < py ; p++ )
+  {
+    pid = -1 ;
+    i = 0 ;
+    for ( x = 0 ; x < n ; x++ )
+    {
+      for ( y = 0 ; y < m ; y++ )
+      {
+        if ( wk[INDEX_2(x,y,m)] == p )
+        {
+          if ( i % n_px == 0 ) pid++ ;
+          i++ ;
+          if ( pid > px-1 ) pid = px-1 ;
+          wk[INDEX_2(x,y,m)] = pid*10000 + p ;
+        }
+      }
+    }
+  }
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != RSL_INVALID )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  RSL_FREE(wk) ;
+}
+
+print_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int i, j ;
+  for ( i = m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < n ; j++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == RSL_INVALID )
+        printf("  ." ) ;
+      else 
+	printf("%3d", wrk[ INDEX_2( j, i, m ) ] ) ;
+    }
+    printf("\n") ;
+  }
+}
+
+#ifndef vpp
+rsl_default_decomp( w1, w2, info_p, m_p, n_p, py_p, px_p )
+  int_p w1, w2, info_p, m_p, n_p, py_p, px_p ;
+{
+  int i ;
+  int bwdth ;
+
+  bwdth = HARD_CODED_BOUNDARY_WIDTH_FIX_ME_PLEASE ;
+
+  for ( i = 0 ; i < *n_p * *m_p ; i++ )
+    w2[i] = w1[i] ;
+  if ( regular_decomp )
+  {
+    patchmap( w2, *m_p, *n_p, *py_p, *px_p ) ;
+  }
+  else
+  {
+    decomp_region_2( w2, *m_p, *n_p, *py_p, *px_p ) ;
+  }
+  return(0) ;
+}
+#else
+rsl_default_decomp( w1, w2, info_p, m_p, n_p, py_p, px_p )
+  int_p w1, w2, info_p, m_p, n_p, py_p, px_p ;
+{
+  int i ;
+
+  for ( i = 0 ; i < *n_p * *m_p ; i++ )
+    w2[i] = w1[i] ;
+  patchmap( w2, *m_p, *n_p, *py_p, *px_p ) ;
+  return(0) ;
+}
+#endif
+
diff --git a/wrfv2_fire/external/RSL/RSL/cd1.c b/wrfv2_fire/external/RSL/RSL/cd1.c
new file mode 100755
index 00000000..9cf3b0f2
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/cd1.c
@@ -0,0 +1,489 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+
+mark_line( wrk, m, n, x1, y1, x2, y2 )
+  int wrk[] ;
+  int m, n, x1, y1, x2, y2 ;
+{
+  int x, y, i, j, k ;
+  int yz, yz2, dex ;
+
+  double SLOPE, X, Y, DX, DY, dY, X1, X2, Y1, Y2 ;
+
+  X1 = x1 ;
+  X2 = x2 ;
+  DX = X2 - X1 ;
+  Y1 = y1 ;
+  Y2 = y2 ;
+  DY = Y2 - Y1 ;
+  if ( DX == 0.0 )
+  {
+    if ( y2 >= y1 )
+      for ( i = y1 ; i <= y2 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = 1 ;
+    else
+      for ( i = y2 ; i <= y1 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = 1 ;
+    return ;
+  }
+  else
+  {
+    SLOPE = DY/DX ;
+    dY = SLOPE * .5 ;
+  }
+
+  if ( x2 >= X1 )
+  {
+    Y = y1 + .5 ;
+    for ( X = x1+.5 ; X < x2+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x2, y2, m )] = 1 ;
+  }
+  else
+  {
+    Y = y2 + .5 ;
+    for ( X = x2+.5 ; X < x1+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x1, y1, m )] = 1 ;
+  }
+}
+
+fill_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int x, y ;
+  
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flood( 0, y, 0, 2, wrk, m, n ) ;
+    flood( n-1, y, 0, 2, wrk, m, n ) ;
+  }
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flood( x, 0, 0, 2, wrk, m, n ) ;
+    flood( x, m-1, 0, 2, wrk, m, n ) ;
+  }
+
+  for ( y = 0 ; y < n ; y++ )
+  {
+    for ( x = 0 ; x < m ; x++ )
+    {
+      if      ( wrk[ INDEX_2(x,y,m) ] == 0 )
+        wrk[ INDEX_2(x,y,m) ] = 1 ;
+      else if ( wrk[ INDEX_2(x,y,m) ] == 2 )
+        wrk[ INDEX_2(x,y,m) ] = 0 ;
+    }
+  }
+}
+
+decomp_region_1( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  /* divide over py in m dimension first */
+  pid = 0 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        i++ ;
+        if ( i % n_py == 0 ) pid++ ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  /* now divide over px in n dimension */
+  n_px = n_py / px ;
+  for ( p = 0 ; p < py ; p++ )
+  {
+    pid = 0 ;
+    i = 0 ;
+    for ( x = 0 ; x < n ; x++ )
+    {
+      for ( y = 0 ; y < m ; y++ )
+      {
+        if ( wk[INDEX_2(x,y,m)] == p )
+        {
+          i++ ;
+          if ( i % n_px == 0 ) pid++ ;
+          if ( pid > px-1 ) pid = px-1 ;
+          wk[INDEX_2(x,y,m)] = pid*10000 + p ;
+        }
+      }
+    }
+  }
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+decomp_region_2( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+
+  printf("decomp_region_2( wrk, %d, %d, %d, %d )\n",m, n, py, px ) ;
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  dc2( 0, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+dc2( p, nprocs, wk, wrk, m, n, py, px, n_p )
+  int p, nprocs, wk[], wrk[], m, n, py, px, n_p ;
+{
+  int x, y, i, v, flg, reach, oldi ;
+
+  if ( p >= nprocs ) return ;
+
+  printf("dc2(%d, %d, wk, wk, %d, %d, %d, %d, %d)\n",p, nprocs,m, n, py, px, n_p );
+
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flg = 1 ;
+    for ( y = 0 ; y < m && flg ; y++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flg = 1 ;
+    for ( x = n-1 ; x >= 0 && flg ; x-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = n-1 ; x >=0 ; x-- )
+  {
+    flg = 1 ;
+    for ( y = m-1 ; y >=0 && flg ; y-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = m-1 ; y >= 0 ; y-- )
+  {
+    flg = 1 ;
+    for ( x = 0 ; x < n && flg ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    for ( y = 0 ; y < m ; y++ )
+    {
+      v = wk[INDEX_2(x,y,m)] ;
+      if ( v == -1 && wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        goto breakout ;
+      }
+    }
+  }
+
+breakout:
+  if ( x == n ) return ;                /* done, none found */
+
+  printf("dc2: p %d v %d x %d y %d  wrk %d\n", p,v,x,y,wrk[INDEX_2(x,y,m)]) ;
+  
+  reach = 0 ;
+  i = 0 ;
+  /* start acreting outward until we're stopped dead or we get enough */
+  while ( (i < n_p) )
+  {
+    reach++ ;
+    oldi = i ;
+    acrete( wk, wrk, p, &i, n_p, reach, x, y, m, n ) ;
+    if ( i == oldi ) break ;
+  }
+
+  printf("\n") ;
+  print_region( wk, m, n ) ;
+
+  dc2( p+1, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+}
+
+#define T(X,Y) \
+   {                                                                    \
+     if( (X) >= 0 && (X) < n && (Y) >= 0 && (Y) < m && *i < n_p )       \
+       if (wk[INDEX_2((X),(Y),m)]==-1&&wrk[INDEX_2((X),(Y),m)]!=0)      \
+       {                                                                \
+	   setone = 1 ;							\
+           wk[INDEX_2((X),(Y),m)] = p ;                                 \
+           *i = *i + 1 ;                                                \
+       }                                                                \
+   }
+
+acrete( wk, wrk, p, i, n_p, reach, x, y, m, n )
+  int wk[], wrk[], p, *i, n_p ;
+{
+  int setone ;
+
+  if ( reach == 0 ) return ;
+  if ( *i >= n_p ) return ;
+  if ( !(x >= 0 && x < n && y >= 0 && y < m) ) return ;
+  if ( wrk[INDEX_2(x,y,m)]==0 ) return ;
+  if ( wk[INDEX_2(x,y,m)]!=-1 && wk[INDEX_2(x,y,m)]!= p) return ;
+
+  /*
+  if ( p == 5 && reach == 1 )
+  printf("acrete(wk,wrk, p %d, *i %d, n_p %d, reach %d, x %d, y %d, m %d, n %d)\n",p, *i, n_p, reach, x, y, m, n ) ;
+  */
+
+  T( x   , y   ) ;
+  T( x-1 , y+1 ) ;
+  T( x   , y+1 ) ;
+  T( x+1 , y+1 ) ;
+  T( x-1 , y   ) ;
+  T( x+1 , y   ) ;
+  T( x-1 , y-1 ) ;
+  T( x   , y-1 ) ;
+  T( x+1 , y-1 ) ;
+
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y-1 , m, n ) ;
+
+}
+
+
+flood( x, y, v, v2, wrk, m, n )
+  int x, y, v, v2, wrk[], m, n ;
+{
+  if ( x < 0 || x >= n || y < 0 || y >= m )
+    return ;
+  if ( wrk[INDEX_2(x,y,m)] == v )
+  {
+    wrk[INDEX_2(x,y,m)] = v2 ;
+    flood( x+1, y  , v, v2, wrk, m, n ) ;
+    flood( x-1, y  , v, v2, wrk, m, n ) ;
+    flood( x  , y+1, v, v2, wrk, m, n ) ;
+    flood( x  , y-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+print_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int i, j ;
+  for ( i = m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < n ; j++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == -1 )
+        printf("  ." ) ;
+      else 
+	printf("%3d", wrk[ INDEX_2( j, i, m ) ] ) ;
+    }
+    printf("\n") ;
+  }
+}
+
+/****************/
+
+main()
+{
+  /*      n   m */
+  int wrk[100 * 100] ;
+  int i, j, m, n, x1, y1, x2, y2, py, px, opt ;
+
+  for ( i = 0 ; i < 100*100 ; i++ ) wrk[i] = 0 ;
+
+  scanf("%d %d", &m, &n) ;
+  scanf("%d %d %d", &py, &px, &opt) ;
+  scanf("%d %d", &x1, &y1) ;
+  while ( scanf("%d %d", &x2, &y2) != EOF )
+  {
+    mark_line( wrk, m, n, x1, y1, x2, y2 ) ;
+    x1 = x2 ;
+    y1 = y2 ;
+  }
+
+  /* print_region( wrk, m, n ) ; */
+
+  fill_region( wrk, m, n ) ;
+
+  /* print_region( wrk, m, n ) ; */
+
+  switch ( opt )
+  {
+    case 1 : decomp_region_1( wrk, m, n, py, px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ;
+    case 2 : decomp_region_2( wrk, m, n, py, px ) ;
+	     break ; 
+    default : break ;
+  }
+
+  printf("\n") ;
+
+
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/cd2.c b/wrfv2_fire/external/RSL/RSL/cd2.c
new file mode 100755
index 00000000..9cf3b0f2
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/cd2.c
@@ -0,0 +1,489 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+
+mark_line( wrk, m, n, x1, y1, x2, y2 )
+  int wrk[] ;
+  int m, n, x1, y1, x2, y2 ;
+{
+  int x, y, i, j, k ;
+  int yz, yz2, dex ;
+
+  double SLOPE, X, Y, DX, DY, dY, X1, X2, Y1, Y2 ;
+
+  X1 = x1 ;
+  X2 = x2 ;
+  DX = X2 - X1 ;
+  Y1 = y1 ;
+  Y2 = y2 ;
+  DY = Y2 - Y1 ;
+  if ( DX == 0.0 )
+  {
+    if ( y2 >= y1 )
+      for ( i = y1 ; i <= y2 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = 1 ;
+    else
+      for ( i = y2 ; i <= y1 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = 1 ;
+    return ;
+  }
+  else
+  {
+    SLOPE = DY/DX ;
+    dY = SLOPE * .5 ;
+  }
+
+  if ( x2 >= X1 )
+  {
+    Y = y1 + .5 ;
+    for ( X = x1+.5 ; X < x2+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x2, y2, m )] = 1 ;
+  }
+  else
+  {
+    Y = y2 + .5 ;
+    for ( X = x2+.5 ; X < x1+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = 1 ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x1, y1, m )] = 1 ;
+  }
+}
+
+fill_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int x, y ;
+  
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flood( 0, y, 0, 2, wrk, m, n ) ;
+    flood( n-1, y, 0, 2, wrk, m, n ) ;
+  }
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flood( x, 0, 0, 2, wrk, m, n ) ;
+    flood( x, m-1, 0, 2, wrk, m, n ) ;
+  }
+
+  for ( y = 0 ; y < n ; y++ )
+  {
+    for ( x = 0 ; x < m ; x++ )
+    {
+      if      ( wrk[ INDEX_2(x,y,m) ] == 0 )
+        wrk[ INDEX_2(x,y,m) ] = 1 ;
+      else if ( wrk[ INDEX_2(x,y,m) ] == 2 )
+        wrk[ INDEX_2(x,y,m) ] = 0 ;
+    }
+  }
+}
+
+decomp_region_1( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  /* divide over py in m dimension first */
+  pid = 0 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        i++ ;
+        if ( i % n_py == 0 ) pid++ ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  /* now divide over px in n dimension */
+  n_px = n_py / px ;
+  for ( p = 0 ; p < py ; p++ )
+  {
+    pid = 0 ;
+    i = 0 ;
+    for ( x = 0 ; x < n ; x++ )
+    {
+      for ( y = 0 ; y < m ; y++ )
+      {
+        if ( wk[INDEX_2(x,y,m)] == p )
+        {
+          i++ ;
+          if ( i % n_px == 0 ) pid++ ;
+          if ( pid > px-1 ) pid = px-1 ;
+          wk[INDEX_2(x,y,m)] = pid*10000 + p ;
+        }
+      }
+    }
+  }
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+decomp_region_2( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+
+  printf("decomp_region_2( wrk, %d, %d, %d, %d )\n",m, n, py, px ) ;
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  dc2( 0, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+dc2( p, nprocs, wk, wrk, m, n, py, px, n_p )
+  int p, nprocs, wk[], wrk[], m, n, py, px, n_p ;
+{
+  int x, y, i, v, flg, reach, oldi ;
+
+  if ( p >= nprocs ) return ;
+
+  printf("dc2(%d, %d, wk, wk, %d, %d, %d, %d, %d)\n",p, nprocs,m, n, py, px, n_p );
+
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flg = 1 ;
+    for ( y = 0 ; y < m && flg ; y++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flg = 1 ;
+    for ( x = n-1 ; x >= 0 && flg ; x-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = n-1 ; x >=0 ; x-- )
+  {
+    flg = 1 ;
+    for ( y = m-1 ; y >=0 && flg ; y-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = m-1 ; y >= 0 ; y-- )
+  {
+    flg = 1 ;
+    for ( x = 0 ; x < n && flg ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    for ( y = 0 ; y < m ; y++ )
+    {
+      v = wk[INDEX_2(x,y,m)] ;
+      if ( v == -1 && wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        goto breakout ;
+      }
+    }
+  }
+
+breakout:
+  if ( x == n ) return ;                /* done, none found */
+
+  printf("dc2: p %d v %d x %d y %d  wrk %d\n", p,v,x,y,wrk[INDEX_2(x,y,m)]) ;
+  
+  reach = 0 ;
+  i = 0 ;
+  /* start acreting outward until we're stopped dead or we get enough */
+  while ( (i < n_p) )
+  {
+    reach++ ;
+    oldi = i ;
+    acrete( wk, wrk, p, &i, n_p, reach, x, y, m, n ) ;
+    if ( i == oldi ) break ;
+  }
+
+  printf("\n") ;
+  print_region( wk, m, n ) ;
+
+  dc2( p+1, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+}
+
+#define T(X,Y) \
+   {                                                                    \
+     if( (X) >= 0 && (X) < n && (Y) >= 0 && (Y) < m && *i < n_p )       \
+       if (wk[INDEX_2((X),(Y),m)]==-1&&wrk[INDEX_2((X),(Y),m)]!=0)      \
+       {                                                                \
+	   setone = 1 ;							\
+           wk[INDEX_2((X),(Y),m)] = p ;                                 \
+           *i = *i + 1 ;                                                \
+       }                                                                \
+   }
+
+acrete( wk, wrk, p, i, n_p, reach, x, y, m, n )
+  int wk[], wrk[], p, *i, n_p ;
+{
+  int setone ;
+
+  if ( reach == 0 ) return ;
+  if ( *i >= n_p ) return ;
+  if ( !(x >= 0 && x < n && y >= 0 && y < m) ) return ;
+  if ( wrk[INDEX_2(x,y,m)]==0 ) return ;
+  if ( wk[INDEX_2(x,y,m)]!=-1 && wk[INDEX_2(x,y,m)]!= p) return ;
+
+  /*
+  if ( p == 5 && reach == 1 )
+  printf("acrete(wk,wrk, p %d, *i %d, n_p %d, reach %d, x %d, y %d, m %d, n %d)\n",p, *i, n_p, reach, x, y, m, n ) ;
+  */
+
+  T( x   , y   ) ;
+  T( x-1 , y+1 ) ;
+  T( x   , y+1 ) ;
+  T( x+1 , y+1 ) ;
+  T( x-1 , y   ) ;
+  T( x+1 , y   ) ;
+  T( x-1 , y-1 ) ;
+  T( x   , y-1 ) ;
+  T( x+1 , y-1 ) ;
+
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y-1 , m, n ) ;
+
+}
+
+
+flood( x, y, v, v2, wrk, m, n )
+  int x, y, v, v2, wrk[], m, n ;
+{
+  if ( x < 0 || x >= n || y < 0 || y >= m )
+    return ;
+  if ( wrk[INDEX_2(x,y,m)] == v )
+  {
+    wrk[INDEX_2(x,y,m)] = v2 ;
+    flood( x+1, y  , v, v2, wrk, m, n ) ;
+    flood( x-1, y  , v, v2, wrk, m, n ) ;
+    flood( x  , y+1, v, v2, wrk, m, n ) ;
+    flood( x  , y-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+print_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int i, j ;
+  for ( i = m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < n ; j++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == -1 )
+        printf("  ." ) ;
+      else 
+	printf("%3d", wrk[ INDEX_2( j, i, m ) ] ) ;
+    }
+    printf("\n") ;
+  }
+}
+
+/****************/
+
+main()
+{
+  /*      n   m */
+  int wrk[100 * 100] ;
+  int i, j, m, n, x1, y1, x2, y2, py, px, opt ;
+
+  for ( i = 0 ; i < 100*100 ; i++ ) wrk[i] = 0 ;
+
+  scanf("%d %d", &m, &n) ;
+  scanf("%d %d %d", &py, &px, &opt) ;
+  scanf("%d %d", &x1, &y1) ;
+  while ( scanf("%d %d", &x2, &y2) != EOF )
+  {
+    mark_line( wrk, m, n, x1, y1, x2, y2 ) ;
+    x1 = x2 ;
+    y1 = y2 ;
+  }
+
+  /* print_region( wrk, m, n ) ; */
+
+  fill_region( wrk, m, n ) ;
+
+  /* print_region( wrk, m, n ) ; */
+
+  switch ( opt )
+  {
+    case 1 : decomp_region_1( wrk, m, n, py, px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ;
+    case 2 : decomp_region_2( wrk, m, n, py, px ) ;
+	     break ; 
+    default : break ;
+  }
+
+  printf("\n") ;
+
+
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/cd3.c b/wrfv2_fire/external/RSL/RSL/cd3.c
new file mode 100755
index 00000000..55a6c69c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/cd3.c
@@ -0,0 +1,487 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+
+mark_line( wrk, m, n, x1, y1, x2, y2, val )
+  int wrk[] ;
+  int m, n, x1, y1, x2, y2, val ;
+{
+  int x, y, i, j, k ;
+  int yz, yz2, dex ;
+
+  double SLOPE, X, Y, DX, DY, dY, X1, X2, Y1, Y2 ;
+
+  X1 = x1 ;
+  X2 = x2 ;
+  DX = X2 - X1 ;
+  Y1 = y1 ;
+  Y2 = y2 ;
+  DY = Y2 - Y1 ;
+  if ( DX == 0.0 )
+  {
+    if ( y2 >= y1 )
+      for ( i = y1 ; i <= y2 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    else
+      for ( i = y2 ; i <= y1 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    return ;
+  }
+  else
+  {
+    SLOPE = DY/DX ;
+    dY = SLOPE * .5 ;
+  }
+
+  if ( x2 >= X1 )
+  {
+    Y = y1 + .5 ;
+    for ( X = x1+.5 ; X < x2+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x2, y2, m )] = val ;
+  }
+  else
+  {
+    Y = y2 + .5 ;
+    for ( X = x2+.5 ; X < x1+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x1, y1, m )] = val ;
+  }
+}
+
+fill_region( wrk, m, n, v, v2 )
+  int wrk[], m, n, v, v2 ;
+{
+  int x, y ;
+  
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flood( 0, y, v, v2, wrk, m, n ) ;
+    flood( n-1, y, v, v2, wrk, m, n ) ;
+  }
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flood( x, 0, v, v2, wrk, m, n ) ;
+    flood( x, m-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+decomp_region_1( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  /* divide over py in m dimension first */
+  pid = -1 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        if ( i % n_py == 0 ) pid++ ;
+        i++ ;
+        if ( pid > px-1 ) pid = px-1 ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  /* now divide over px in n dimension */
+  n_px = n_py / px ;
+  for ( p = 0 ; p < py ; p++ )
+  {
+    pid = -1 ;
+    i = 0 ;
+    for ( x = 0 ; x < n ; x++ )
+    {
+      for ( y = 0 ; y < m ; y++ )
+      {
+        if ( wk[INDEX_2(x,y,m)] == p )
+        {
+          if ( i % n_px == 0 ) pid++ ;
+          i++ ;
+          if ( pid > py-1 ) pid = py-1 ;
+          wk[INDEX_2(x,y,m)] = pid*10000 + p ;
+        }
+      }
+    }
+  }
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+decomp_region_2( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+
+  printf("decomp_region_2( wrk, %d, %d, %d, %d )\n",m, n, py, px ) ;
+  wk = (int*)malloc(m*n*sizeof(int)) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  dc2( 0, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  free(wk) ;
+}
+
+dc2( p, nprocs, wk, wrk, m, n, py, px, n_p )
+  int p, nprocs, wk[], wrk[], m, n, py, px, n_p ;
+{
+  int x, y, i, v, flg, reach, oldi ;
+
+  if ( p >= nprocs ) return ;
+
+  printf("dc2(%d, %d, wk, wk, %d, %d, %d, %d, %d)\n",p, nprocs,m, n, py, px, n_p );
+
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flg = 1 ;
+    for ( y = 0 ; y < m && flg ; y++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flg = 1 ;
+    for ( x = n-1 ; x >= 0 && flg ; x-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = n-1 ; x >=0 ; x-- )
+  {
+    flg = 1 ;
+    for ( y = m-1 ; y >=0 && flg ; y-- )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( y = m-1 ; y >= 0 ; y-- )
+  {
+    flg = 1 ;
+    for ( x = 0 ; x < n && flg ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        if ( wk[INDEX_2(x,y,m)] == -1 ) goto breakout ;
+        if ( wk[INDEX_2(x,y,m)] != -1 ) flg = 0 ; 
+      }
+    }
+  }
+
+  for ( x = 0 ; x < n ; x++ )
+  {
+    for ( y = 0 ; y < m ; y++ )
+    {
+      v = wk[INDEX_2(x,y,m)] ;
+      if ( v == -1 && wrk[INDEX_2(x,y,m)] != 0 )
+      {
+        goto breakout ;
+      }
+    }
+  }
+
+breakout:
+  if ( x == n ) return ;                /* done, none found */
+
+  printf("dc2: p %d v %d x %d y %d  wrk %d\n", p,v,x,y,wrk[INDEX_2(x,y,m)]) ;
+  
+  reach = 0 ;
+  i = 0 ;
+  /* start acreting outward until we're stopped dead or we get enough */
+  while ( (i < n_p) )
+  {
+    reach++ ;
+    oldi = i ;
+    acrete( wk, wrk, p, &i, n_p, reach, x, y, m, n ) ;
+    if ( i == oldi ) break ;
+  }
+
+  printf("\n") ;
+  print_region( wk, m, n ) ;
+
+  dc2( p+1, nprocs, wk, wrk, m, n, py, px, n_p ) ;
+}
+
+#define T(X,Y) \
+   {                                                                    \
+     if( (X) >= 0 && (X) < n && (Y) >= 0 && (Y) < m && *i < n_p )       \
+       if (wk[INDEX_2((X),(Y),m)]==-1&&wrk[INDEX_2((X),(Y),m)]!=0)      \
+       {                                                                \
+	   setone = 1 ;							\
+           wk[INDEX_2((X),(Y),m)] = p ;                                 \
+           *i = *i + 1 ;                                                \
+       }                                                                \
+   }
+
+acrete( wk, wrk, p, i, n_p, reach, x, y, m, n )
+  int wk[], wrk[], p, *i, n_p ;
+{
+  int setone ;
+
+  if ( reach == 0 ) return ;
+  if ( *i >= n_p ) return ;
+  if ( !(x >= 0 && x < n && y >= 0 && y < m) ) return ;
+  if ( wrk[INDEX_2(x,y,m)]==0 ) return ;
+  if ( wk[INDEX_2(x,y,m)]!=-1 && wk[INDEX_2(x,y,m)]!= p) return ;
+
+  /*
+  if ( p == 5 && reach == 1 )
+  printf("acrete(wk,wrk, p %d, *i %d, n_p %d, reach %d, x %d, y %d, m %d, n %d)\n",p, *i, n_p, reach, x, y, m, n ) ;
+  */
+
+  T( x   , y   ) ;
+  T( x-1 , y+1 ) ;
+  T( x   , y+1 ) ;
+  T( x+1 , y+1 ) ;
+  T( x-1 , y   ) ;
+  T( x+1 , y   ) ;
+  T( x-1 , y-1 ) ;
+  T( x   , y-1 ) ;
+  T( x+1 , y-1 ) ;
+
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x-1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y+1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y   , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x+1 , y-1 , m, n ) ;
+  acrete( wk, wrk, p, i, n_p, reach-1, x   , y-1 , m, n ) ;
+
+}
+
+
+flood( x, y, v, v2, wrk, m, n )
+  int x, y, v, v2, wrk[], m, n ;
+{
+  if ( x < 0 || x >= n || y < 0 || y >= m )
+    return ;
+  if ( wrk[INDEX_2(x,y,m)] == v )
+  {
+    wrk[INDEX_2(x,y,m)] = v2 ;
+    flood( x+1, y  , v, v2, wrk, m, n ) ;
+    flood( x-1, y  , v, v2, wrk, m, n ) ;
+    flood( x  , y+1, v, v2, wrk, m, n ) ;
+    flood( x  , y-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+print_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int i, j ;
+  for ( i = m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < n ; j++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == -1 )
+        printf("  ." ) ;
+      else 
+	printf("%3d", wrk[ INDEX_2( j, i, m ) ] ) ;
+    }
+    printf("\n") ;
+  }
+}
+
+/****************/
+
+main()
+{
+  /*      n   m */
+  int wrk[100 * 100] ;
+  int i, j, m, n, x1, y1, x2, y2, py, px, opt ;
+
+  for ( i = 0 ; i < 100*100 ; i++ ) wrk[i] = 0 ;
+
+  scanf("%d %d", &m, &n) ;
+  scanf("%d %d %d", &py, &px, &opt) ;
+  scanf("%d %d", &x1, &y1) ;
+  while ( scanf("%d %d", &x2, &y2) != EOF )
+  {
+    mark_line( wrk, m, n, x1, y1, x2, y2, 1 ) ;
+    x1 = x2 ;
+    y1 = y2 ;
+  }
+
+  print_region( wrk, m, n ) ;
+
+  fill_region( wrk, m, n, 0, 2 ) ;
+  for ( j = 0 ; j < n ; j++ )
+    for ( i = 0 ; i < m ; i++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == 2 )
+        wrk[ INDEX_2( j, i, m ) ] = 0 ;
+      else
+        wrk[ INDEX_2( j, i, m ) ] = 1 ;
+    }
+
+  print_region( wrk, m, n ) ;
+
+  switch ( opt )
+  {
+    case 1 : decomp_region_1( wrk, m, n, py, px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ;
+    case 2 : decomp_region_2( wrk, m, n, py, px ) ;
+	     break ; 
+    default : break ;
+  }
+
+  printf("\n") ;
+
+
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/cd4.c b/wrfv2_fire/external/RSL/RSL/cd4.c
new file mode 100755
index 00000000..f864defd
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/cd4.c
@@ -0,0 +1,391 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+#include "rsl.h"
+
+
+/*#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) ) */
+
+mark_line( wrk, m, n, x1, y1, x2, y2, val )
+  int wrk[] ;
+  int m, n, x1, y1, x2, y2, val ;
+{
+  int x, y, i, j, k ;
+  int yz, yz2, dex ;
+
+  double SLOPE, X, Y, DX, DY, dY, X1, X2, Y1, Y2 ;
+
+  X1 = x1 ;
+  X2 = x2 ;
+  DX = X2 - X1 ;
+  Y1 = y1 ;
+  Y2 = y2 ;
+  DY = Y2 - Y1 ;
+  if ( DX == 0.0 )
+  {
+    if ( y2 >= y1 )
+      for ( i = y1 ; i <= y2 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    else
+      for ( i = y2 ; i <= y1 ; i++ )
+        wrk[ INDEX_2( x1, i, m )] = val ;
+    return ;
+  }
+  else
+  {
+    SLOPE = DY/DX ;
+    dY = SLOPE * .5 ;
+  }
+
+  if ( x2 >= X1 )
+  {
+    Y = y1 + .5 ;
+    for ( X = x1+.5 ; X < x2+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x2, y2, m )] = val ;
+  }
+  else
+  {
+    Y = y2 + .5 ;
+    for ( X = x2+.5 ; X < x1+.5 ; X = X+.5 )
+    {
+      j = X + .25 ;
+      if ( dY >= 0.0 )
+        for ( i = Y ; i <= (k=Y+dY) ; i++ )     /* k business converts to int */
+          wrk[ INDEX_2( j, i, m )] = val ;
+      else
+        for ( i = Y ; i >= (k=Y+dY) ; i-- )
+          wrk[ INDEX_2( j, i, m )] = val ;
+      Y = Y + dY ;
+    }
+    wrk[ INDEX_2( x1, y1, m )] = val ;
+  }
+}
+
+fill_region( wrk, m, n, v, v2 )
+  int wrk[], m, n, v, v2 ;
+{
+  int x, y ;
+  
+  for ( y = 0 ; y < m ; y++ )
+  {
+    flood( 0, y, v, v2, wrk, m, n ) ;
+    flood( n-1, y, v, v2, wrk, m, n ) ;
+  }
+  for ( x = 0 ; x < n ; x++ )
+  {
+    flood( x, 0, v, v2, wrk, m, n ) ;
+    flood( x, m-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+/* decompose over a 1-d vector of processors in y */
+decomp_region_1y( wrk, m, n, py )
+  int wrk[], m, n, py ;
+{
+  int *wk ;
+  int nprocs, i, x, y, ncells, pid, n_py ;
+
+  wk = RSL_MALLOC( int, m*n ) ;
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+  /* divide over py in m dimension first */
+  pid = -1 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        if ( i % n_py == 0 ) pid++ ;
+        i++ ;
+        if ( pid > py-1 ) pid = py-1 ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  RSL_FREE(wk) ;
+}
+
+/* decompose over a 1-d vector of processors in x */
+decomp_region_1x( wrk, m, n, px )
+  int wrk[], m, n, px ;
+{
+  int *wk ;
+  int nprocs, i, x, y, ncells, pid, n_px ;
+
+  wk = RSL_MALLOC( int, m*n ) ;
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+  /* divide over px in m dimension first */
+  pid = -1 ;
+  i = 0 ;
+  n_px = ncells / px ;
+  for ( x = 0 ; x < n ; x++ )
+  {
+    for ( y = 0 ; y < m ; y++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        if ( i % n_px == 0 ) pid++ ;
+        i++ ;
+        if ( pid > px-1 ) pid = px-1 ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  RSL_FREE(wk) ;
+}
+
+decomp_region_2( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int *wk ;
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, pid, p ;
+
+  wk = RSL_MALLOC( int, m*n ) ;
+
+  nprocs = px * py ;
+
+  for ( x = 0 ; x < m*n ; x++ ) 
+  {
+    wk[x] = -1 ;
+    if ( wrk[x] != 0 ) ncells++ ;
+  }
+
+  n_p = ncells / nprocs ;
+
+  /* divide over py in m dimension first */
+  pid = -1 ;
+  i = 0 ;
+  n_py = ncells / py ;
+  for ( y = 0 ; y < m ; y++ )
+  {
+    for ( x = 0 ; x < n ; x++ )
+    {
+      if ( wrk[INDEX_2(x,y,m)] != 0 )   /* only do cells in partition */
+      {
+        if ( i % n_py == 0 ) pid++ ;
+        i++ ;
+        if ( pid > px-1 ) pid = px-1 ;
+        wk[INDEX_2(x,y,m)] = pid ;
+      }
+    }
+  }
+
+  /* now divide over px in n dimension */
+  n_px = n_py / px ;
+  for ( p = 0 ; p < py ; p++ )
+  {
+    pid = -1 ;
+    i = 0 ;
+    for ( x = 0 ; x < n ; x++ )
+    {
+      for ( y = 0 ; y < m ; y++ )
+      {
+        if ( wk[INDEX_2(x,y,m)] == p )
+        {
+          if ( i % n_px == 0 ) pid++ ;
+          i++ ;
+          if ( pid > py-1 ) pid = py-1 ;
+          wk[INDEX_2(x,y,m)] = pid*10000 + p ;
+        }
+      }
+    }
+  }
+  
+  for ( x = 0 ; x < n ; x++ )
+    for ( y = 0 ; y < m ; y++ )
+  {
+    if (( p = wk[ INDEX_2( x, y, m ) ] ) != -1 )
+    {
+      n_py = p % 10000 ;
+      n_px = p / 10000 ;
+      wrk[INDEX_2( x, y, m )] = n_py*px + n_px ;
+    }
+    else
+    {
+      wrk[INDEX_2( x, y, m )] = wk[INDEX_2( x, y, m )] ;
+    }
+  }
+
+  RSL_FREE(wk) ;
+}
+
+flood( x, y, v, v2, wrk, m, n )
+  int x, y, v, v2, wrk[], m, n ;
+{
+  if ( x < 0 || x >= n || y < 0 || y >= m )
+    return ;
+  if ( wrk[INDEX_2(x,y,m)] == v )
+  {
+    wrk[INDEX_2(x,y,m)] = v2 ;
+    flood( x+1, y  , v, v2, wrk, m, n ) ;
+    flood( x-1, y  , v, v2, wrk, m, n ) ;
+    flood( x  , y+1, v, v2, wrk, m, n ) ;
+    flood( x  , y-1, v, v2, wrk, m, n ) ;
+  }
+}
+
+print_region( wrk, m, n )
+  int wrk[], m, n ;
+{
+  int i, j ;
+  for ( i = m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < n ; j++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == -1 )
+        printf("  ." ) ;
+      else 
+	printf("%3d", wrk[ INDEX_2( j, i, m ) ] ) ;
+    }
+    printf("\n") ;
+  }
+}
+
+/****************/
+
+main()
+{
+  /*      n   m */
+  int wrk[100 * 100] ;
+  int i, j, m, n, x1, y1, x2, y2, py, px, opt ;
+
+  for ( i = 0 ; i < 100*100 ; i++ ) wrk[i] = 0 ;
+
+  scanf("%d %d", &m, &n) ;
+  scanf("%d %d %d", &py, &px, &opt) ;
+  scanf("%d %d", &x1, &y1) ;
+  while ( scanf("%d %d", &x2, &y2) != EOF )
+  {
+    mark_line( wrk, m, n, x1, y1, x2, y2, 1 ) ;
+    x1 = x2 ;
+    y1 = y2 ;
+  }
+
+  print_region( wrk, m, n ) ;
+
+  fill_region( wrk, m, n, 0, 2 ) ;
+  for ( j = 0 ; j < n ; j++ )
+    for ( i = 0 ; i < m ; i++ )
+    {
+      if ( wrk[ INDEX_2( j, i, m ) ] == 2 )
+        wrk[ INDEX_2( j, i, m ) ] = 0 ;
+      else
+        wrk[ INDEX_2( j, i, m ) ] = 1 ;
+    }
+
+  print_region( wrk, m, n ) ;
+
+  switch ( opt )
+  {
+    case 0 : decomp_region_1x( wrk, m, n, py*px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ;
+    case 1 : decomp_region_1y( wrk, m, n, py*px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ;
+    case 2 : decomp_region_2( wrk, m, n, py, px ) ;
+	     print_region( wrk, m, n ) ;
+	     break ; 
+    default : break ;
+  }
+
+  printf("\n") ;
+
+
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_cells.c b/wrfv2_fire/external/RSL/RSL/comp_cells.c
new file mode 100755
index 00000000..a1738a0b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_cells.c
@@ -0,0 +1,227 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+static rsl_list_t *lp[RSL_MAXDOMAINS] ;
+
+
+/*@
+  RSL_COMPUTE_CELLS - apply a subroutine to all points of a domain
+
+  Synopsis:
+  RSL_COMPUTE_CELLS ( d, f )
+    INTEGER     d        ! (I) RSL domain descriptor
+    EXTERNAL    f        ! (I) Subroutine
+
+  Notes:
+  This routine is supported but considered obsolete.
+  RSL now provides more integrated means for iterating over decomposed
+  domain dimensions --- see LoopMacros.
+
+  RSL_COMPUTE_CELLS calls
+  a subroutine for each grid point of the domain.
+  By default, the
+  cells on each processor are traversed in an M-minor, N-major ordering.
+  This ordering can be changed
+  using RSL_ORDER.  Use RSL_COMPUTE_MASK to iterate over a subset of a domain.
+  The subroutine F takes five 
+  integer arguments (see example) that provide local and global indices of
+  a point and nest level.  Other model data must be provided to the subroutine
+  through common or through a USE statement (Fortran90).
+
+  Example:
+
+$  subroutine F( inest, i, j, ig, jg )
+$  integer inest    ! nest level (1 is top)
+$  integer i, j     ! index of point in local memory
+$  integer ig, jg   ! index of point in global domain
+$    -- computation for point --
+$  return
+$  end
+
+$  external f
+$    --
+$  call rsl_compute_cells ( d, f )
+$    --
+$  stop
+$  end
+
+BREAKTHEEXAMPLECODE
+
+  The subroutine F is 
+  called for a point of the domain d if M evaluates true.
+
+  See also:
+  LoopMacros, RSL_ORDER, RSL_COMPUTE_MASK
+
+@*/
+
+/*@
+  RSL_COMPUTE_MASK - apply a subroutine to selected points in a domain
+
+  Synopsis:
+  RSL_COMPUTE_MASK ( d, f, m )
+    INTEGER    d      ! (I) RSL domain descriptor
+    EXTERNAL   f      ! (I) Subroutine
+    EXTERNAL   m      ! (I) Mask function
+    LOGICAL    m
+
+  Notes:
+  This routine is supported but considered obsolete.
+  RSL now provides more integrated means for iterating over decomposed
+  domain dimensions --- see LoopMacros.
+
+  RSL_COMPUTE_MASK calls
+  a subroutine for grid points of the domain based on evaluation of a
+  mask function.  See also RSL_COMPUTE_CELLS.
+
+  Example:
+$  subroutine F( inest, i, j, ig, jg )
+$  integer inest    ! nest level (1 is top)
+$  integer i, j     ! index of point in local memory
+$  integer ig, jg   ! index of point in global domain
+$    -- computation for point --
+$  return
+$  end
+$
+$  logical function M ( inest, i, j, ig, jg )
+$  M = < .true. if included in computation >
+$  return
+$  end
+$
+$  external f, m
+$  logical  m
+$    --
+$  call rsl_compute_mask ( d, f, m )
+$    --
+BREAKTHEEXAMPLECODE
+
+  The subroutine F is 
+  called for a point of the domain d if M evaluates true.
+
+  See also:
+  LoopMacros, RSL_ORDER, RSL_COMPUTE_MASK
+
+@*/
+
+int RSL_INIT_NEXTCELL ( d_p )
+  int_p d_p ;
+{
+  rsl_index_t d ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p, 
+			   &(domain_info[*d_p].loc_m),
+			   &(domain_info[*d_p].loc_n) ) ;
+  }
+  lp[d] = domain_info[d].pts ;
+  return(0) ;
+}
+
+int RSL_INIT_GHOST ( d_p )
+  int_p d_p ;
+{
+  rsl_index_t d ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: invalid domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  lp[d] = domain_info[d].ghost_pts ;
+  return(0) ;
+}
+
+int RSL_C_NEXTCELL ( d_p, min_p, maj_p, min_g_p, maj_g_p, retval_p )
+  int_p d_p, min_p, maj_p, min_g_p, maj_g_p, retval_p ;
+{
+  rsl_index_t d ;
+  rsl_point_t *pt ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: invalid domain") ;
+
+  if ( lp[d] == NULL )
+  {
+    *retval_p = 0 ;		/* no more */
+  }
+  else
+  {
+    pt = (rsl_point_t *) lp[d]->data ;
+    *min_g_p = ID_IDEX( pt->id ) + 1;
+    *maj_g_p = ID_JDEX( pt->id ) + 1;
+    *min_p = *min_g_p - domain_info[d].ilocaloffset ;
+    *maj_p = *maj_g_p - domain_info[d].jlocaloffset ;
+#if 0
+fprintf(stderr,"%d comp_cells point -> %d %d %d %d; jlocaloffset %d\n",
+       rsl_myproc, *min_p, *maj_p, *min_g_p, *maj_g_p,
+       domain_info[d].jlocaloffset) ;
+#endif
+    lp[d] = lp[d]->next ;
+    *retval_p = 1 ;
+  }
+  return(0) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/comp_cells_f.F b/wrfv2_fire/external/RSL/RSL/comp_cells_f.F
new file mode 100755
index 00000000..c2dfafd6
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_cells_f.F
@@ -0,0 +1,181 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine rsl_compute_cells( domain, f )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+
+      integer nl, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )	       ! get nest level for this domain
+      call rsl_init_nextcell(domain)   ! initializes rsl_next_cell
+      call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      do while ( retval .eq. 1 )
+         dummy = f( nl+1, min, maj, min_g, maj_g )
+         call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      enddo
+      return
+      end
+
+      subroutine rsl_compute_mask( domain, f, mask )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+      logical mask	! function (mask out cells 
+
+      integer nl, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )        ! get nest level for this domain
+      call rsl_init_nextcell(domain)   ! initializes rsl_next_cell
+      call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      do while ( retval .eq. 1 )
+	 if ( mask( domain, min, maj, min_g, maj_g ) ) then
+           dummy = f( nl+1, min, maj, min_g, maj_g )
+	 endif
+         call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      enddo
+      return
+      end
+
+
+      logical function rsl_nextcell( d, min, maj, min_g, maj_g )
+      integer d, min, maj, min_g, maj_g
+      integer retval
+      call rsl_c_nextcell( d, min, maj, min_g, maj_g, retval )
+      if ( retval .eq. 1 ) then
+         rsl_nextcell = .true.
+      else
+         rsl_nextcell = .false.
+      endif
+      return
+      end
+
+c routine for computing on ghost points
+      subroutine rsl_compute_ghost( domain, f )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+
+      integer nl, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )        ! get nest level for this domain
+      call rsl_init_ghost(domain)      ! initializes rsl_next_cell
+      call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      do while ( retval .eq. 1 )
+         dummy = f( nl+1, min, maj, min_g, maj_g )
+         call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      enddo
+
+      return
+      end
+
+
+      subroutine rsl_compute_cells6( domain, f, d, ilen, jlen, klen )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+      character d(*)  ! pointer to structure
+      integer ilen, jlen, klen
+
+      integer nl, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )        ! get nest level for this domain
+      call rsl_init_nextcell(domain)   ! initializes rsl_next_cell
+      call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      do while ( retval .eq. 1 )
+         dummy = f( nl+1, min, maj, min_g, maj_g, d, ilen, jlen, klen )
+         call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      enddo
+      return
+      end
+
+      subroutine rsl_compute_mask6( domain, f, mask,
+     $                              d, ilen, jlen, klen )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+      logical mask      ! function (mask out cells
+      character d(*)  ! pointer to structure
+      integer ilen, jlen, klen
+
+      integer nl, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )        ! get nest level for this domain
+      call rsl_init_nextcell(domain)   ! initializes rsl_next_cell
+      call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      do while ( retval .eq. 1 )
+         if ( mask( domain, min, maj, min_g, maj_g ) ) then
+           dummy =
+     $        f( nl+1, min, maj, min_g, maj_g, d, ilen, jlen, klen )
+         endif
+         call rsl_c_nextcell( domain, min, maj, min_g, maj_g, retval )
+      enddo
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_period.c b/wrfv2_fire/external/RSL/RSL/comp_period.c
new file mode 100755
index 00000000..9710ee17
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_period.c
@@ -0,0 +1,516 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* The mechanism here is similar to and patterned after that used by the
+   stencil mechanism: see comp_sten.c */
+
+
+/* used by compile_period, below */
+static period_desc_t *sd ;            /* set in compile_period */
+static rsl_procrec_t *procrec ;       /* set in compile_period */
+static int send_accum ;
+static int recv_accum ;
+
+static check_local_pts_period( d, m, n, hm, hn, min_gh, maj_gh, fldspec )
+  rsl_index_t d ;               /* domain index */
+  rsl_index_t m, n ;            /* this point */
+  rsl_index_t hm, hn ;          /* home point (whose period I'm on)  */
+  rsl_index_t min_gh ;        /* direction and amount to make sure minor ghost region is updated */
+  rsl_index_t maj_gh ;        /* direction and amount to make sure major ghost region is updated */
+  rsl_fldspec_t *fldspec ;
+{
+  int mlen ;                    /* length of minor domain dimension */
+  rsl_fldspec_t *fp, *fpm, *prev, *new ;
+  int message, found ;
+  rsl_processor_t  P , Pthis , Pmin_gh , Pmaj_gh ;
+  rsl_point_id_t id ;
+  rsl_ptrec_t *ptrec, *recv_ptrec ;
+  int recv_npts ;       /* dummy */
+  rsl_list_t *lp ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *domain ;
+  message_desc_t * msg ;
+  int mfldlen, nfldlen ;
+  rsl_fldspec_t *fld ;
+
+  dinfo = &(domain_info[d]) ;
+  domain = dinfo->domain ;
+  mlen = dinfo->len_m ;
+
+  switch ( fldspec->strategy )
+  {
+    case MINNS_MAJEW_2D :
+      mfldlen = fldspec->glen[0] ; nfldlen = fldspec->glen[1] ; break ;
+    case MINEW_MAJNS_2D :
+      mfldlen = fldspec->glen[1] ; nfldlen = fldspec->glen[0] ; break ;
+    case MINNS_MAJEW_K_3D :
+      mfldlen = fldspec->glen[0] ; nfldlen = fldspec->glen[1] ; break ;
+    case MINEW_MAJNS_K_3D :
+      mfldlen = fldspec->glen[1] ; nfldlen = fldspec->glen[0] ; break ;
+    case K_MIDNS_MAJEW_3D :
+      mfldlen = fldspec->glen[1] ; nfldlen = fldspec->glen[2] ; break ;
+    case MINNS_K_MAJEW_3D :
+      mfldlen = fldspec->glen[0] ; nfldlen = fldspec->glen[2] ; break ;
+    default :
+      RSL_TEST_ERR(1,"unsupported strategy") ;
+  }
+
+/* P is the processor on which sits the off-domain point being filled in */
+  P       = domain[INDEX_2( (hn<0)?0:((hn>nfldlen-1)?nfldlen-1:hn) , (hm<0)?0:((hm>mfldlen-1)?mfldlen-1:hm),mlen )  ].P ;
+  Pmin_gh = domain[INDEX_2( (hn<0)?0:((hn>nfldlen-1)?nfldlen-1:hn) , (hm+min_gh<0)?0:((hm+min_gh>mfldlen-1)?mfldlen-1:hm+min_gh),mlen )  ].P ;
+  Pmaj_gh = domain[INDEX_2( (hn+maj_gh<0)?0:((hn+maj_gh>nfldlen-1)?nfldlen-1:hn+maj_gh) , (hm<0)?0:((hm>mfldlen-1)?mfldlen-1:hm       ),mlen )  ].P ;
+
+/* Pthis is the processor on which sits the on-domain point being replicated */
+  Pthis = RSL_INVALID ;
+  if ( n >= 0 && n < dinfo->len_n && m >= 0 && m < dinfo->len_m )
+     Pthis = domain[INDEX_2(n,m,mlen)].P ;
+
+/* SENDS -- if the point to be replicated sits on my processsor, and the off-domain point being filled
+   in sits on the "other" processor, record a send that includes the coordinates of the point being
+   replicated for the packing mechanism.  */
+
+#if 1
+  if (   rsl_c_comp2phys_proc ( Pthis ) == rsl_myproc  && 
+       ( P == procrec->P || Pmin_gh == procrec->P || Pmaj_gh == procrec->P ) &&
+         rsl_c_comp2phys_proc ( procrec->P ) != rsl_myproc )   /* if the other processor is me don't bother */
+#else
+  if ( rsl_c_comp2phys_proc ( Pthis ) == rsl_myproc  &&  P == procrec->P )
+#endif
+  {
+#if 0
+fprintf(stderr,"send: %d %d P = %d , Pthis = %d , procrec->P %d , m %d , n %d , hm %d , hn %d , min_gh %d , maj_gh %d \n", mfldlen, nfldlen,  P, Pthis, procrec->P, m,n,hm,hn,min_gh,maj_gh ) ;
+#endif
+    found = 0 ;
+/* always create a new record; searching and trying to reuse records will throw
+   off the order of packing when multiple fields with different dimensions are
+   involved. */
+    if ( !found )       /* add it */
+    {
+      lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
+      ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
+      ptrec->ig = m ;
+      ptrec->jg = n ;
+      ptrec->nsendmsgs = 0 ;
+      ptrec->nrecvmsgs = 0 ;
+      ptrec->send_messages = NULL ;
+      ptrec->recv_messages = NULL ;
+      lp->data = ptrec ;
+      lp->next = procrec->point_list ;
+      procrec->point_list = lp ;
+      procrec->npts++ ;
+      send_accum += sizeof( rsl_point_hdr_t ) ;
+    }
+/* 1.1.1.1.2 */
+    /* at this point ptrec points to a ptrec (for the local point) in the 
+       list for the non-local processor. */
+    if ( ptrec->send_messages == NULL )
+    {
+      msg = RSL_MALLOC( message_desc_t , 1 ) ;
+      lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+      lp->data = msg ;
+      lp->next = ptrec->send_messages ;
+      ptrec->send_messages = lp ;
+    }
+    lp = ptrec->send_messages ;
+    msg = lp->data ;
+    fld = RSL_MALLOC( rsl_fldspec_t , 1 ) ;
+    *fld = *fldspec ;
+    fld->next = msg->fldspecs ;
+    msg->fldspecs = fld ;
+    send_accum += fldsize( fld ) ;
+    send_accum += sizeof(int) ;         /* for send of period point index */
+    ptrec->nsendmsgs = 1 ;
+  }
+
+/* RECEIVES: if the off-domain point to be filled in is on my processor, and the processor
+   this with the on-domain point is the "other" processor, generate a receive, recording the
+   coordinates of the off-domain point for the upacking mechanism.  */
+
+#if 1
+  if ( ( rsl_c_comp2phys_proc ( P ) == rsl_myproc || rsl_c_comp2phys_proc ( Pmaj_gh ) == rsl_myproc || rsl_c_comp2phys_proc ( Pmin_gh ) == rsl_myproc ) && 
+         Pthis == procrec->P && 
+         rsl_c_comp2phys_proc ( Pthis ) != rsl_myproc )   /* if the other processor is me don't bother */
+#else
+  if ( rsl_c_comp2phys_proc ( P ) == rsl_myproc && Pthis == procrec->P )
+#endif
+  {
+
+#if 0
+fprintf(stderr,"recv: %d %d P = %d , Pthis = %d , procrec->P %d , m %d , n %d , hm %d , hn %d , min_gh %d , maj_gh %d\n", mfldlen, nfldlen, P, Pthis, procrec->P, m,n,hm,hn,min_gh,maj_gh ) ;
+#endif
+
+/* 2.1.1.1.1 */
+    /* add the ghost point to the list of points from which we
+       will receive messages */
+    found = 0 ;
+    if ( !found )       /* add it */
+    {
+      lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
+      recv_ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
+      recv_ptrec->ig = hm ;
+      recv_ptrec->jg = hn ;
+      recv_ptrec->nsendmsgs = 0 ;
+      recv_ptrec->nrecvmsgs = 0 ;
+      recv_ptrec->send_messages = NULL ;
+      recv_ptrec->recv_messages = NULL ;
+      lp->data = recv_ptrec ;
+      lp->next = procrec->recv_point_list ;
+      procrec->recv_point_list = lp ;
+      procrec->recv_npts++ ;
+      recv_accum += sizeof( rsl_point_hdr_t ) ;
+    }
+
+    if ( recv_ptrec->recv_messages == NULL )
+    {
+      msg = RSL_MALLOC( message_desc_t , 1 ) ;
+      lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+      lp->data = msg ;
+      lp->next = recv_ptrec->recv_messages ;
+      recv_ptrec->recv_messages = lp ;
+    }
+    lp = recv_ptrec->recv_messages ;
+    msg = lp->data ;
+    fld = RSL_MALLOC( rsl_fldspec_t , 1 ) ;
+    *fld = *fldspec ;
+    fld->next = msg->fldspecs ;
+    msg->fldspecs = fld ;
+    recv_accum += fldsize( fld ) ;
+    recv_accum += sizeof(int) ;
+    recv_ptrec->nrecvmsgs = 1 ;
+
+  }
+}
+
+/* this is used internally only -- this will be called automatically
+   whenever a period exchange is attempted on a period that has not
+   yet been compiled */
+rsl_compile_period( d_p, s_p )
+  int_p d_p, s_p ;
+{
+  int d, s ;
+  int i, j, k ;
+  int len_plist ;
+  int (*ptfcn)() ;
+  rsl_list_t *lp, *lp2, *destr, *destr2, *ghost_points ;
+  rsl_domain_info_t *dp ;
+  rsl_point_t  *pt ;
+  rsl_dimlen_t mlen, nlen ;
+  rsl_fldspec_t * fld ;
+  message_desc_t *msg ;
+  int m, n, dir ;
+  rsl_processor_t P, Plist[RSL_MAXPROC] ;
+  int check_local_pts_period() ;
+
+  d = *d_p ;
+  s = *s_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "rsl_compile_period: bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID, 
+        "rsl_compile_period: descriptor for invalid domain" ) ;
+
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+
+  /* sd is static so that check_local_pts can get at it */
+  RSL_TEST_ERR( s <= 0 || s > RSL_MAXDESCRIPTORS,
+        "rsl_compile_period: bad period descriptor" ) ;
+  RSL_TEST_ERR((sd = (period_desc_t *)pr_descriptors[s]) == NULL,
+        "compile_descriptor: null period descriptor" ) ;
+  RSL_TEST_ERR( sd->tag != PERIOD_DESC,
+        "compile_descriptor: bad period descriptor" ) ;
+  RSL_TEST_ERR( sd->compiled[d] != 0,
+        "compile_period: period has already been compiled for this domain") ;
+
+  sd->compiled[d] = 1 ;
+  dp = &(domain_info[d]) ;
+
+  if ( dp->decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+for ( dir = 0 ; dir < 2 ; dir++ )
+{
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
+    procrec->P = P ;
+    procrec->npts = 0 ;
+    procrec->recv_npts = 0 ;
+
+/* 1.1 */
+    /* for every ghost point from P, mark any local point that lies
+       on its period (using the point function associated with the
+       period.   */
+    
+    send_accum = 0 ;
+    recv_accum = 0 ;
+
+        for ( fld = sd->msgs[d]->fldspecs ; fld != NULL ; fld = fld->next )
+    for ( n = 0 ; n < nlen ; n++ )
+      for ( m = 0 ; m < mlen ; m++ )
+/* 1.1.1 */
+         {
+           switch ( fld->strategy )
+           {
+           case MINNS_MAJEW_2D :
+             rsl_period_pt( dir, d, m, fld->glen[0], fld->stag[0], n, fld->glen[1], fld->stag[1], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           case MINEW_MAJNS_2D :
+             rsl_period_pt( dir, d, m, fld->glen[1], fld->stag[1], n, fld->glen[0], fld->stag[0], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           case MINNS_MAJEW_K_3D :
+             rsl_period_pt( dir, d, m, fld->glen[0], fld->stag[0], n, fld->glen[1], fld->stag[1], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           case MINEW_MAJNS_K_3D :
+             rsl_period_pt( dir, d, m, fld->glen[1], fld->stag[1], n, fld->glen[0], fld->stag[0], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           case K_MIDNS_MAJEW_3D :
+             rsl_period_pt( dir, d, m, fld->glen[1], fld->stag[1], n, fld->glen[2], fld->stag[2], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           case MINNS_K_MAJEW_3D :
+             rsl_period_pt( dir, d, m, fld->glen[0], fld->stag[0], n, fld->glen[2], fld->stag[2], fld, sd->bdyw[d], check_local_pts_period ) ; break ;
+           default :
+              RSL_TEST_ERR(1,"unsupported strategy") ;
+           }
+         }
+
+    procrec->nsends = 0 ;
+    procrec->nrecvs = 0 ;
+    procrec->sendsize = send_accum + sizeof(int) ; /* extra word for count */
+    procrec->recvsize = recv_accum + sizeof(int) ; /* extra word for count */
+
+    if ( send_accum != 0 || recv_accum != 0 )
+    {
+      procrec->next = sd->procs[dir][d] ;
+      sd->procs[dir][d] = procrec ;
+    }
+    else
+    {
+      RSL_FREE(procrec) ;
+    }
+  }
+  {
+    int ig, jg, i, j ;
+    rsl_list_t *lp1 ;
+    void * base ;
+    int elemsz, t0, t1, pack_table_size ;
+    period_desc_t * per ;
+    rsl_ptrec_t * ptrec ;
+    message_desc_t * msg ;
+    rsl_fldspec_t * fld ;
+    
+    per = (period_desc_t *) pr_descriptors[ s ] ;
+    for ( procrec = per->procs[dir][d] ; procrec != NULL ; procrec = procrec->next )
+    {
+      init_period_refs() ;
+      for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
+      {
+        ptrec = (rsl_ptrec_t *) lp->data ;
+        ig = ptrec->ig ;
+        jg = ptrec->jg ;
+        i = ig - domain_info[d].ilocaloffset ;
+        j = jg - domain_info[d].jlocaloffset ;
+
+        for ( lp1 = ptrec->send_messages ; lp1 != NULL ; lp1 = lp1->next )
+        {
+          msg = (message_desc_t *) lp1->data ;
+          for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+          {
+            if ( fld->type >= 100 ) sd->has_f90_fields = 1 ;
+            base = fld->base ;
+#if 0
+fprintf(stderr,"pack  P=%d  i j ig jg    %3d %3d %3d %3d, base %08x\n",procrec->P,i,j,ig,jg,base) ;
+#endif
+            elemsz = fld->elemsz ;
+            switch (fld->strategy)
+            {
+            case MINNS_MAJEW_2D :               /*  eg: psa(i,j) */
+              t0 = fld->llen[0] ;
+              store_period_refs( base, fld->f90_table_index , (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+            case MINEW_MAJNS_2D :               /* xxx(j,i) */
+              t0 = fld->llen[0] ;
+              store_period_refs( base, fld->f90_table_index , (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+
+
+
+            case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , 
+                                         (i+j*t0)*elemsz,     /* offset */
+                                         elemsz,              /* n      */
+                                         fld->llen[2],        /* nelems */
+                                         t1*elemsz) ;         /* stride */
+              break ;
+
+            case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index ,
+                                         (j+i*t0)*elemsz,     /* offset */
+                                         elemsz,              /* n      */
+                                         fld->llen[2],        /* nelems */
+                                         t1*elemsz) ;         /* stride */
+              break ;
+
+            case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                                                             /* offset               n      nelems   stride */
+                                                             /*   |                  |         |      |     */
+                                                             /*   v                  v         v      v     */
+              store_period_refs( base, fld->f90_table_index , (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
+              break ;
+
+            case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
+              break ;
+            default:
+              RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+              break ;
+            }
+          }
+        }
+      }
+      period_refs( &(procrec->pack_table),
+                    &(procrec->pack_table_size),
+                    &(procrec->pack_table_nbytes) , 0 ) ;
+    }
+  }
+#if 0
+fprintf(stderr,"-=-=-=-=-=-=-\n") ;
+#endif
+  {
+    int ig, jg, i, j ;
+    rsl_list_t *lp1 ;
+    void * base ;
+    int elemsz, t0, t1, pack_table_size ;
+    period_desc_t * per ;
+    rsl_ptrec_t * ptrec ;
+    message_desc_t * msg ;
+    rsl_fldspec_t * fld ;
+    
+    per = (period_desc_t *) pr_descriptors[ s ] ;
+    for ( procrec = per->procs[dir][d] ; procrec != NULL ; procrec = procrec->next )
+    {
+      init_period_refs() ;
+      for ( lp = procrec->recv_point_list ; lp != NULL ; lp = lp->next )
+      {
+        ptrec = (rsl_ptrec_t *) lp->data ;
+        ig = ptrec->ig ;
+        jg = ptrec->jg ;
+        i = ig - domain_info[d].ilocaloffset ;
+        j = jg - domain_info[d].jlocaloffset ;
+
+        for ( lp1 = ptrec->recv_messages ; lp1 != NULL ; lp1 = lp1->next )
+        {
+          msg = (message_desc_t *) lp1->data ;
+          for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+          {
+            if ( fld->type >= 100 ) sd->has_f90_fields = 1 ;
+            base = fld->base ;
+#if 0
+fprintf(stderr,"unpack  P = %d  i j ig jg    %3d %3d %3d %3d, base %08x\n",procrec->P,i,j,ig,jg, base) ;
+#endif
+            elemsz = fld->elemsz ;
+            switch (fld->strategy)
+            {
+            case MINNS_MAJEW_2D :               /*  eg: psa(i,j) */
+              t0 = fld->llen[0] ;
+              store_period_refs( base, fld->f90_table_index , (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+            case MINEW_MAJNS_2D :               /* xxx(j,i) */
+              t0 = fld->llen[0] ;
+              store_period_refs( base, fld->f90_table_index , (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+            case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , (i+j*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+              break ;
+            case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , (j+i*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+              break ;
+            case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
+              break ;
+            case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_period_refs( base, fld->f90_table_index , (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
+              break ;
+            default:
+              RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+              break ;
+            }
+          }
+        }
+      }
+      period_refs( &(procrec->unpack_table),
+                    &(procrec->unpack_table_size),
+                    &(procrec->unpack_table_nbytes) , 0 ) ;
+    }
+  }
+}
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_slabs.c b/wrfv2_fire/external/RSL/RSL/comp_slabs.c
new file mode 100755
index 00000000..a9c27e2f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_slabs.c
@@ -0,0 +1,177 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+static rsl_list_t *rp[RSL_MAXDOMAINS] ;
+
+/*@
+  RSL_COMPUTE_ISLAB - apply a routine to each islab locally stored points
+
+  Synopsis:
+  subroutine RSL_COMPUTE_ISLAB ( d, f )
+  integer d
+  external f
+
+  Input parameters:
+. d - domain descriptor
+. f - subroutine to be applied
+
+  Notes:
+  This is one of the principal computational routines of RSL.  It applies
+  a function that represents some piece of work -- compute a time step
+  -- to be done on a horizontal grid point.  RSL_COMPUTE_ISLAB will
+  call the subroutine for each continguous run of points local to the
+  processor up the minor dimension of the domain.
+
+  The subroutine, f, provided should be slab-callable
+  and have six
+  integer dummy arguments which are shown in the example below.
+
+  Example:
+
+$  -- prototypical function --
+$  subroutine F( inest, irun, i1, j1, ig1, jg1 )
+$  integer inest    ! nest level (1 is top)
+$  integer irun     ! number of points in the run
+$  integer i, j     ! index of starting point in local memory
+$  integer ig, jg   ! index of starting point in global domain
+
+$  j = j1
+$  ig = ig1-1
+$  do i = i1, i1+irun-1
+$    ig = ig+1
+$    -- computation --
+$  enddo
+
+$  return
+$  end
+
+$  -- top level routine --
+
+$  external f, m
+$  logical  m
+$    --
+$  call rsl_compute_islab ( d, f )
+$    --
+
+BREAKTHEEXAMPLECODE
+
+@*/
+
+/*@
+  RSL_INIT_NEXTISLAB - Initialize a traversal over local slabs
+
+  RSL_C_NEXTISLAB - Get indices and run length of next slab in traversal
+
+  Notes:
+  These routines are called from within RSL_COMPUTE_ISLAB and are not
+  typically used by the application programmer.
+
+@*/
+int RSL_INIT_NEXTISLAB ( d_p )
+  int_p d_p ;
+{
+  rsl_index_t d ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextislab: bad domain descriptor") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextislab: invalid domain descriptor") ;
+
+  rp[d] = domain_info[d].iruns ;
+  return(0) ;
+}
+
+int RSL_C_NEXTISLAB ( d_p, irun_p, min_p, maj_p, min_g_p, maj_g_p, retval_p )
+  int_p d_p, irun_p, min_p, maj_p, min_g_p, maj_g_p, retval_p ;
+{
+  rsl_index_t d ;
+  rsl_runrec_t *rrec ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  if ( rp[d] == NULL )
+  {
+    *retval_p = 0 ;		/* no more */
+  }
+  else
+  {
+    rrec = (rsl_runrec_t *)(rp[d]->data) ;
+    *irun_p = rrec->runlength ;
+    *min_g_p = rrec->ig + 1;
+    *maj_g_p = rrec->jg + 1;
+    *min_p = *min_g_p - domain_info[d].ilocaloffset ;
+    *maj_p = *maj_g_p - domain_info[d].jlocaloffset ;
+    rp[d] = rp[d]->next ;
+    *retval_p = 1 ;
+  }
+  return(0) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_slabs_f.F b/wrfv2_fire/external/RSL/RSL/comp_slabs_f.F
new file mode 100755
index 00000000..6683daa2
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_slabs_f.F
@@ -0,0 +1,79 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine rsl_compute_islab( domain, f )
+      implicit none
+      integer domain    ! domain descriptor
+      integer f         ! function (typed to keep implicit none quiet)
+
+      integer nl, irun, min, maj, min_g, maj_g
+      integer retval
+      integer dummy
+
+      call rsl_nl( domain, nl )	       ! get nest level for this domain
+      call rsl_init_nextislab(domain)   ! initializes rsl_next_cell
+      call rsl_c_nextislab( domain, irun, min, maj, min_g, 
+     +                      maj_g, retval )
+      do while ( retval .eq. 1 )
+         dummy = f( nl+1, irun, min, maj, min_g, maj_g )
+         call rsl_c_nextislab( domain, irun, min, maj, min_g, maj_g,
+     +                         retval )
+      enddo
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_sten.c b/wrfv2_fire/external/RSL/RSL/comp_sten.c
new file mode 100755
index 00000000..cd836869
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_sten.c
@@ -0,0 +1,875 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*
+   Here's a drawing of the graph this routine is trying to construct:
+
+      (stencil_desc)
+        |      |
+        |      |
+        |    array of message_descs corresponding to stencil pts
+        |      msg1 msg2 msg3 msg4 ...
+        |       0    1    2    3     
+        |                       \
+   array of processor lists      \ <---pointers back to message structures
+   on list for each domain        \        |
+     |                            |        |
+  d                               ^      \ v       +-------------------------+
+  o (0) -->  procrec  -->         |       \        |there is one node for    |
+  m            |                  |        \       |each physical processor  |
+  a (1)        |                  |         \      |this processor will need |
+  i            |                  ^          \     |to communicate with for  |
+  n  .         |                  |           \    |this stencil.            |
+     .         v                  |            ^   +-------------------------+
+     .      (list_t)              |            |
+               |  \               ^            ^     +-------------------------+
+               | ( ptrec ) --> (list_t) --> (list_t) |1 for each msg associated|
+               |     |                               |with the point           |
+               |      \                              +-------------------------+
+               v       \+-------------------------------------------------+
+            (list_t)    |points to the entry for the local point in domain|
+               |        |data structure.                                  |
+               |        +-------------------------------------------------+
+               .
+               .
+               .
+
+**************
+  Algorithm:
+
+    P is a remote processor, M is me
+
+ 1  To work out sends to P from M:
+ 1.1   for each ghost point GP from P
+ 1.1.1   for each point p on GP's stencil
+ 1.1.1.1    if p is on M
+ 1.1.1.1.1     add p to list of points going to P (if not already on)
+ 1.1.1.1.2     add message from p to p's entry in the aforementioned list 
+
+ 2  To work out receives from P to M:
+ 2.1   for each ghost point GP from P
+ 2.1.1   for each point p on GP's stencil
+ 2.1.1.1    if p is on M
+ 2.1.1.1.1     add GP to list of points being sent from P (if not already on)
+ 2.1.1.1.2     add message from GP to GP's entry in the aforementioned list 
+
+    Combined algorithm;
+          
+ 1  To work out receives from P to M:
+ 1.1   for each ghost point GP from P
+ 1.1.1   for each point p on GP's stencil
+ 1.1.1.1    if p is on M
+ 1.1.1.1.1     add p to list of points going to P (if not already on)
+ 1.1.1.1.2     add message from p to p's entry in the aforementioned list 
+ 2.1.1.1.1     add GP to list of points being sent from P (if not already on)
+ 2.1.1.1.2     add message from GP to GP's entry in the aforementioned list 
+
+*/
+
+/* used by compile_stencil, below */
+static stencil_desc_t *sd ;            /* set in compile_stencil */
+static rsl_procrec_t *procrec ;        /* set in compile_stencil */
+static int send_accum ;
+static int recv_accum ;
+
+#if 0
+/* this is a linked list that is used for the receives from the remote
+   processor (the GP list in the above algorithmic descriptions).  We are 
+   only counting bytes for these messages (to allocated the correctly sized 
+   buffers) so this is just a temporary data structure that is cleaned up 
+   on each call to rsl_compile_stencil */
+static rsl_list_t *recv_point_list = NULL ;   /* 940308 */
+#endif
+
+dstry_ptrec_list( recv_ptrec )
+  rsl_ptrec_t *recv_ptrec ;
+{
+  destroy_list( &(recv_ptrec->recv_messages), NULL ) ;
+}
+
+rsl_processor_t idx_ ;
+
+#ifdef NEC_TUNE
+/*
+   NECNOTE: 
+   quick tables to speed up link list searching in routine check_local_pts.
+   tbl_'id'_... used for searching rsl_point_t id's.
+*/
+static int ntbl_id_max = 128 ; /* Note first allocation will be of size 256 */
+static int ntbl_id = 0 ;
+static rsl_point_id_t *tbl_id = NULL ;
+static rsl_ptrec_t **tbl_ptrec = NULL ;
+static rsl_procrec_t *prev_procrec = NULL ;
+#endif
+/* 1.1.1 (continued) */
+/* this routine is called for each point on the ghost point's stencil */
+check_local_pts( d, m, n, hm, hn, pt, ipt )
+  rsl_index_t d ;               /* domain index */
+  rsl_index_t m, n ;            /* this point */
+  rsl_index_t hm, hn ;          /* home point (whose stencil I'm on)  */
+  rsl_index_t pt ;              /* point in stencil */
+  rsl_index_t ipt ;             /* inverse point in stencil */
+{
+  int mlen ;			/* length of minor domain dimension */
+  rsl_fldspec_t *fp, *fpm, *prev, *new ;
+  int message, found ;
+  rsl_processor_t  P ;
+  rsl_point_id_t id ;
+  rsl_ptrec_t *ptrec, *recv_ptrec ;
+  int recv_npts ;       /* dummy */
+  rsl_list_t *lp ;
+  message_desc_t *msg ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *domain ;
+#ifdef NEC_TUNE
+  int i ;
+#endif
+
+  dinfo = &(domain_info[d]) ;
+  domain = dinfo->domain ;
+  mlen = dinfo->len_m ;
+
+  /* P is proc of ghost point */
+  P = domain[INDEX_2(hn,hm,mlen)].P ;
+/* 1.1.1.1 */
+  if ( rsl_c_comp2phys_proc (domain[INDEX_2(n,m,mlen)].P) == rsl_myproc )
+  {
+/* 1.1.1.1.1 */
+    id = POINTID(d,n,m) ;
+    found = 0 ;
+#ifndef NEC_TUNE
+    for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
+    {
+      ptrec = (rsl_ptrec_t *)lp->data ;
+      if ( ptrec->pt->id == id )
+      {
+        found = 1 ;
+        break ;
+      }
+    }
+#else
+    if ( prev_procrec != procrec )
+    {
+      ntbl_id = 0 ;
+      prev_procrec = procrec ;
+    }
+    for ( i = 0 ; i < ntbl_id ; i++ )
+    {
+      if ( tbl_id[i] == id )
+      {
+        found = 1 ;
+        break ;
+      }
+    }
+    if ( found ) ptrec = tbl_ptrec[i] ;
+#endif
+    if ( !found )       /* add it */
+    {
+      lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
+      ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
+      ptrec->pt = &(domain[INDEX_2(n,m,mlen)]) ;
+      ptrec->ig = m ;
+      ptrec->jg = n ;
+      ptrec->nsendmsgs = 0 ;
+      ptrec->nrecvmsgs = 0 ;
+      ptrec->send_messages = NULL ;
+      ptrec->recv_messages = NULL ;
+      lp->data = ptrec ;
+      lp->next = procrec->point_list ;
+      procrec->point_list = lp ;
+      procrec->npts++ ;
+      send_accum += sizeof( rsl_point_hdr_t ) ;
+#ifdef NEC_TUNE
+      if ( ntbl_id == ntbl_id_max || tbl_id == NULL )
+      {
+        ntbl_id_max *= 2 ;
+        tbl_id = (rsl_point_id_t *)realloc((void *)tbl_id, ntbl_id_max*sizeof(rsl_point_id_t *)) ;
+        tbl_ptrec = (rsl_ptrec_t **)realloc((void *)tbl_ptrec, ntbl_id_max*sizeof(rsl_ptrec_t *)) ;
+      }
+      tbl_id[ntbl_id] = id ;
+      tbl_ptrec[ntbl_id] = ptrec ;
+      ntbl_id++ ;
+#endif
+    }
+
+/* 2.1.1.1.1 */
+    /* add the ghost point to the list of points from which we
+       will receive messages */
+    id = POINTID(d,hn,hm) ;
+    found = 0 ;
+    for ( lp = procrec->recv_point_list ; lp != NULL ; lp = lp->next )
+    {
+      recv_ptrec = (rsl_ptrec_t *)lp->data ;
+      if ( recv_ptrec->pt->id == id )
+      {
+        found = 1 ;
+        break ;
+      }
+    }
+    if ( !found )       /* add it */
+    {
+      lp    = RSL_MALLOC( rsl_list_t, 1 ) ;
+      recv_ptrec = RSL_MALLOC( rsl_ptrec_t, 1 ) ;
+      recv_ptrec->pt = &(domain[INDEX_2(hn,hm,mlen)]) ;
+      recv_ptrec->ig = hm ;
+      recv_ptrec->jg = hn ;
+      recv_ptrec->nsendmsgs = 0 ;
+      recv_ptrec->nrecvmsgs = 0 ;
+      recv_ptrec->send_messages = NULL ;
+      recv_ptrec->recv_messages = NULL ;
+      lp->data = recv_ptrec ;
+      lp->next = procrec->recv_point_list ;
+      procrec->recv_point_list = lp ;
+      procrec->recv_npts++ ;
+      recv_accum += sizeof( rsl_point_hdr_t ) ;
+    }
+
+
+/* 1.1.1.1.2 */
+    /* at this point ptrec points to a ptrec (for the local point) in the 
+       list for the non-local processor. */
+    msg = sd->msgs[d][ pt-1 ] ;
+    if ( msg != NULL )
+    {
+      /* iterate through message list for ptrec and add the message 
+         to be sent to the ghost point from this local point to the list
+         for the local point if it isn't there */
+      for ( lp = ptrec->send_messages, found = 0 ; lp != NULL ; lp = lp->next )
+      {
+        if ( msg == ( message_desc_t * )lp->data )
+        {
+          found = 1 ;
+          break ;
+        }
+      }
+      if ( !found )   /* add it */
+      {
+        lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+        lp->data = msg ;
+        lp->next = ptrec->send_messages ;
+	lp->info1 = pt ;			/* index of stencil point */
+        ptrec->send_messages = lp ;
+        send_accum += message_size( msg ) ;
+        send_accum += sizeof(int) ;		/* for send of stencil point index */
+        ptrec->nsendmsgs++ ;
+      }
+    }
+
+/* 2.1.1.1.2 */
+    /* repeat for the receives, but note, that for the receives we
+       are only interested in the size of the messages. Also, we're
+       interested in the ghost-point, not the point.*/
+    msg = sd->msgs[d][ ipt-1 ] ;     /* ipt instead of pt used for index */
+    if ( msg != NULL )
+    {
+      /* iterate through message list for recv_ptrec and if message to be
+         received is not there add it. */
+      for ( lp = recv_ptrec->recv_messages, found = 0 ;
+                                      lp != NULL ; lp = lp->next )
+      {
+        if ( msg == ( message_desc_t * )lp->data )
+        {
+          found = 1 ;
+          break ;
+        }
+      }
+      if ( !found )
+      {
+        lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+        lp->data = msg ;
+        lp->next = recv_ptrec->recv_messages ;
+	lp->info2 = ipt ;		/* inverse stencil point */
+        recv_ptrec->recv_messages = lp ;
+        recv_accum += message_size( msg ) ;
+        recv_accum += sizeof(int) ;		/* for send of stencil point index */
+        recv_ptrec->nrecvmsgs++ ;
+        ptrec->nrecvmsgs = recv_ptrec->nrecvmsgs ;   /* intentional (ptrec) */
+      }
+    }
+  }
+}
+
+check_sten ( s_p )
+  int_p s_p ;
+{
+  int s ;
+
+  s = *s_p ;
+  RSL_TEST_ERR( s <= 0 || s > RSL_MAXDESCRIPTORS,
+	"rsl_compile_stencil: bad stencil descriptor" ) ;
+  RSL_TEST_ERR((sd = (stencil_desc_t *)sh_descriptors[s]) == NULL,
+	"compile_descriptor: null stencil descriptor" ) ;
+fprintf(stderr,"DEBUG CHECK_STEN: s %d, sd->tag %d\n", s, sd->tag ) ;
+  RSL_TEST_ERR( sd->tag != STENCIL_DESC,
+        "compile_descriptor: bad stencil descriptor" ) ;
+}
+
+/* this is now used internally only -- this will be called automatically
+   whenever a stencil exchange is attempted on a stencil that has not
+   yet been compiled */
+rsl_compile_stencil( d_p, s_p )
+  int_p d_p, s_p ;
+{
+  int d, s ;
+  int i, j, k ;
+  int len_plist ;
+  int (*ptfcn)() ;
+  rsl_list_t *lp, *lp2, *destr, *destr2, *ghost_points ;
+  rsl_domain_info_t *dp ;
+  rsl_point_t  *pt ;
+  rsl_dimlen_t mlen, nlen ;
+  int m, n ;
+  rsl_processor_t P, Plist[RSL_MAXPROC] ;
+  int check_local_pts() ;
+
+  d = *d_p ;
+  s = *s_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "rsl_compile_stencil: bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID, 
+	"rsl_compile_stencil: descriptor for invalid domain" ) ;
+
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+
+  /* sd is static so that check_local_pts can get at it */
+  RSL_TEST_ERR( s <= 0 || s > RSL_MAXDESCRIPTORS,
+	"rsl_compile_stencil: bad stencil descriptor" ) ;
+  RSL_TEST_ERR((sd = (stencil_desc_t *)sh_descriptors[s]) == NULL,
+	"compile_descriptor: null stencil descriptor" ) ;
+  RSL_TEST_ERR( sd->tag != STENCIL_DESC,
+        "compile_descriptor: bad stencil descriptor" ) ;
+  RSL_TEST_ERR( sd->compiled[d] != 0,
+        "compile_stencil: stencil has already been compiled for this domain") ;
+
+  sd->compiled[d] = 1 ;
+  ptfcn = sd->f[d].ptfcn ;
+  dp = &(domain_info[d]) ;
+
+  if ( dp->decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  /* get a list of the processors that have ghost points and store in 
+     Plist; len_plist is the number of processors stored */
+  for ( i = 0 ; i < RSL_MAXPROC ; i++ )
+    Plist[i] = 0 ;
+  for ( lp = dp->ghost_pts ; lp != NULL ; lp = lp->next ) 
+  {
+    idx_ = ((rsl_point_t *)lp->data)->P ;
+    if ( idx_ < 0 || idx_ >= RSL_MAXPROC )
+    {
+      sprintf(mess,"domain %d: idx_ = %d\n",d, idx_ );
+      RSL_TEST_WRN(1,mess) ;
+    }
+    Plist[ idx_ ] = 1 ;
+  }
+  for ( len_plist = 0, i = 0 ; i < RSL_MAXPROC ; i++ )
+    if ( Plist[i] == 1 ) Plist[ len_plist++ ] = i ;
+
+  for ( k = 0 ; k < len_plist ; k++ )
+  {
+    P = Plist[k] ; 
+
+    procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
+    procrec->P = P ;
+    procrec->next = sd->procs[d] ;
+    sd->procs[d] = procrec ;
+
+#if 0
+    destroy_list( &recv_point_list, dstry_ptrec_list ) ;
+    recv_point_list = NULL ;
+#endif
+
+/* 1.1 */
+    /* for every ghost point from P, mark any local point that lies
+       on its stencil (using the point function associated with the
+       stencil.   */
+    procrec->npts = 0 ;
+    procrec->recv_npts = 0 ;
+    send_accum = 0 ;
+    recv_accum = 0 ;
+    for ( n = 0 ; n < nlen ; n++ )
+      for ( m = 0 ; m < mlen ; m++ )
+        if ( dp->domain[ INDEX_2( n, m, mlen ) ].P == P )
+        {
+/* 1.1.1 */
+           (*ptfcn)( d, m, mlen, n, nlen, check_local_pts ) ;
+        }
+
+    procrec->nsends = 0 ;
+    procrec->nrecvs = 0 ;
+    procrec->sendsize = send_accum + sizeof(int) ; /* extra word for count */
+    procrec->recvsize = recv_accum + sizeof(int) ; /* extra word for count */
+  }
+#define NEW
+#ifdef NEW
+  {
+    int ig, jg, i, j ;
+    rsl_list_t *lp1 ;
+    void * base ;
+    int elemsz, t0, t1, pack_table_size ;
+    stencil_desc_t * sten ;
+    rsl_ptrec_t * ptrec ;
+    message_desc_t * msg ;
+    rsl_fldspec_t * fld ;
+
+    sten = (stencil_desc_t *) sh_descriptors[ s ] ;
+    for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+    {
+      init_process_refs() ;
+      for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
+      {
+        ptrec = (rsl_ptrec_t *) lp->data ;
+        ig = ptrec->ig ;
+        jg = ptrec->jg ;
+        i = ig - domain_info[d].ilocaloffset ;
+        j = jg - domain_info[d].jlocaloffset ;
+
+        for ( lp1 = ptrec->send_messages ; lp1 != NULL ; lp1 = lp1->next )
+        {
+	  msg = (message_desc_t *) lp1->data ;
+	  for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+	  {
+            if ( fld->type >= 100 ) sten->has_f90_fields = 1 ;
+	    base = fld->base ;
+	    elemsz = fld->elemsz ;
+	    switch (fld->strategy)
+	    {
+	    case MINNS_MAJEW_2D :		/*  eg: psa(i,j) */
+	      t0 = fld->llen[0] ;
+	      store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
+	      break ;
+	    case MINEW_MAJNS_2D :		/* xxx(j,i) */
+	      t0 = fld->llen[0] ;
+	      store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
+	      break ;
+	    case MINNS_MAJEW_K_3D :		/*  eg: ua(i,j,k) */
+	      t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+	      store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+	      break ;
+	    case MINEW_MAJNS_K_3D :		/*  eg: u(j,i,k) */
+	      t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+	      store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+	      break ;
+	    case K_MIDNS_MAJEW_3D :		/*  eg: u(k,i,j) */
+	      t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+	      store_process_refs( base, fld->f90_table_index, (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
+	      break ;
+	    case MINNS_K_MAJEW_3D :		/*  eg: u(i,k,j) */
+	      t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+	      store_process_refs( base, fld->f90_table_index, (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
+	      break ;
+	    default:
+	      RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+	      break ;
+	    }
+	  }
+        }
+      }
+      process_refs( &(procrec->pack_table),
+                    &(procrec->pack_table_size),
+                    &(procrec->pack_table_nbytes), 1 ) ;
+#if 0
+      fprintf(stderr,"pack P = %3d:\n",procrec->P ) ;
+      show_pack_table( procrec->pack_table,
+                       procrec->pack_table_size,
+                       procrec->pack_table_nbytes ) ;
+#endif
+    }
+  }
+  {
+    int ig, jg, i, j ;
+    rsl_list_t *lp1 ;
+    void * base ;
+    int elemsz, t0, t1, pack_table_size ;
+    stencil_desc_t * sten ;
+    rsl_ptrec_t * ptrec ;
+    message_desc_t * msg ;
+    rsl_fldspec_t * fld ;
+    
+    sten = (stencil_desc_t *) sh_descriptors[ s ] ;
+    for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+    {
+      init_process_refs() ;
+      for ( lp = procrec->recv_point_list ; lp != NULL ; lp = lp->next )
+      {
+        ptrec = (rsl_ptrec_t *) lp->data ;
+        ig = ptrec->ig ;
+        jg = ptrec->jg ;
+        i = ig - domain_info[d].ilocaloffset ;
+        j = jg - domain_info[d].jlocaloffset ;
+
+        for ( lp1 = ptrec->recv_messages ; lp1 != NULL ; lp1 = lp1->next )
+        {
+	  msg = (message_desc_t *) lp1->data ;
+	  for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+	  {
+            if ( fld->type >= 100 ) sten->has_f90_fields = 1 ;
+	    base = fld->base ;
+	    elemsz = fld->elemsz ;
+            switch (fld->strategy)
+            {
+            case MINNS_MAJEW_2D :               /*  eg: psa(i,j) */
+              t0 = fld->llen[0] ;
+              store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+            case MINEW_MAJNS_2D :               /* xxx(j,i) */
+              t0 = fld->llen[0] ;
+              store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz, 1, elemsz) ;
+              break ;
+            case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_process_refs( base, fld->f90_table_index, (i+j*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+              break ;
+            case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_process_refs( base, fld->f90_table_index, (j+i*t0)*elemsz, elemsz,
+                                         fld->llen[2],
+                                         t1*elemsz) ;
+              break ;
+            case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_process_refs( base, fld->f90_table_index, (i*t0+j*t1)*elemsz, elemsz * t0, 1, elemsz) ;
+              break ;
+            case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+              t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+              store_process_refs( base, fld->f90_table_index, (i+j*t1)*elemsz, elemsz, fld->llen[1], t0*elemsz) ;
+              break ;
+            default:
+              RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+              break ;
+            }
+	  }
+        }
+      }
+      process_refs( &(procrec->unpack_table),
+                    &(procrec->unpack_table_size),
+                    &(procrec->unpack_table_nbytes), 1 ) ;
+#if 0
+      fprintf(stderr,"upack P = %3d:\n",procrec->P ) ;
+      show_pack_table( procrec->unpack_table,
+                       procrec->unpack_table_size,
+                       procrec->unpack_table_nbytes ) ;
+#endif
+    }
+  }
+#endif
+}
+
+show_pack_table( pack_table, pack_table_size, pack_table_nbytes )
+  packrec_t pack_table[] ;
+  int pack_table_size ;
+  int pack_table_nbytes ;
+{
+  int i,ii,jj ;
+  for ( i = 0 ; i < pack_table_size ; i++ )
+  {
+    fprintf(stderr,
+"  base %08x %12d offset %10d f90 index %d n %3d nelem %5d stride %5d valid %2d\n",
+	      pack_table[i].base,
+	      pack_table[i].base,
+	      pack_table[i].offset,
+	      pack_table[i].f90_table_index,
+	      pack_table[i].n,
+	      pack_table[i].nelems,
+	      pack_table[i].stride,
+	      pack_table[i].valid ) ;
+#if 0
+    for ( jj = 0 ; jj < pack_table[i].nelems ; jj++ )
+    for ( ii = 0 ; ii < pack_table[i].n ; ii += 4 )
+    {
+      fprintf(stderr,"** elem %d, n %d, %16lx, %f\n",jj,ii,
+		(float *)( (char *)
+		   pack_table[i].base + 
+		   pack_table[i].offset +
+		   jj * pack_table[i].stride +
+		   ii ),
+		*((float *)( (char *)
+		   pack_table[i].base + 
+		   pack_table[i].offset +
+		   jj * pack_table[i].stride +
+		   ii ))
+		   ) ;
+    }
+#endif
+
+  }
+  fprintf(stderr," table nbytes=%d\n", pack_table_nbytes ) ;
+}
+
+
+/*@
+  SHOW_STEN_DIAGS - Show run time information about stencil performance.
+
+  Input parameter:
+. d - domain descriptor
+. s - stencil descriptor
+
+  Synopsis:
+  subroutine SHOW_STEN_DIAGS ( d, s )
+  integer d
+  integer s
+
+  Notes:
+  Information is sent to a file sten_diags_ for each
+  processor.
+
+  See also:
+  RSL_CREATE_STENCIL, RSL_DESCRIBE_STENCIL, RSL_EXCH_STENCIL
+
+@*/
+
+static int show_sten_diags_first = 1 ;
+
+SHOW_STEN_DIAGS ( d_p, s_p )
+  int_p d_p, s_p ;
+{
+  int d, s, P, nsends, nbytes ;
+  stencil_desc_t *sp ;
+  rsl_procrec_t *procrec ;
+  rsl_ptrec_t *ptrec ;
+  FILE *fp ;
+  char fname[80], *code  ;
+  int smsgs, rmsgs ;
+  rsl_list_t *lp ;
+
+  s = *s_p ;
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, 
+                            "show_sten_diags: bad domain descriptor") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+		"show_sten_diags: invalid domain descriptor" ) ;
+  sp = (stencil_desc_t *)sh_descriptors[s] ;
+  if ( sp == NULL ) return ;
+  if ( show_sten_diags_first )
+  {
+    code = "w" ;
+    show_sten_diags_first = 0 ;
+  }
+  else
+  {
+    code = "a" ;
+  }
+  sprintf(fname,"sten_diags_%04d",rsl_myproc) ;
+  if (( fp = fopen ( fname, code )) == NULL )
+  {
+     perror(fname) ;
+     exit(2) ;
+  }
+  fprintf(fp,"Diagnostics for stencil %3d, domain %3d\n",s,d) ;
+
+  for ( procrec = sp->procs[d] ; procrec != NULL ; procrec = procrec->next )
+  {
+    smsgs = 0 ; rmsgs = 0 ;
+    for ( lp = procrec->point_list ; lp != NULL ; lp = lp->next )
+    {
+      ptrec = (rsl_ptrec_t *) lp->data ;
+      smsgs += ptrec->nsendmsgs ;
+      rmsgs += ptrec->nrecvmsgs ;
+    }
+    fprintf(fp,"   to %4d : %5d of %10d bytes (%10d tot), pts %4d, msgs %4d\n",
+            procrec->P,
+            procrec->nsends,
+            procrec->sendsize,
+            procrec->nsends*procrec->sendsize,
+            procrec->npts,
+            smsgs ) ;
+    fprintf(fp," from %4d : %5d of %10d bytes (%10d tot), pts %4d, msgs %4d\n",
+            procrec->P,
+            procrec->nrecvs,
+            procrec->recvsize,
+            procrec->nrecvs*procrec->recvsize,
+            procrec->recv_npts,
+            rmsgs ) ;
+  }
+  fclose(fp) ;
+}
+
+static FILE * fp = NULL ;
+static int show_first = 1 ;
+SHOW_MESSAGE ( mh_p )
+  int_p mh_p ;
+{
+  int mh ;
+  message_desc_t *msg ;
+  rsl_fldspec_t  *fld ; 
+  int dim ;
+  char * code ;
+  char fname[80] ;
+
+  mh = *mh_p ;
+  if ( show_first )
+  {
+    code = "w" ;
+    show_first = 0 ;
+    sprintf(fname,"show_def_%04d",rsl_myproc) ;
+    if (( fp = fopen ( fname, code )) == NULL )
+    {
+       perror(fname) ;
+       exit(2) ;
+    }
+  }
+  if ( mh == RSL_INVALID )
+  {
+    fprintf(fp,"MESSAGE HANDLE: RSL_INVALID\n" ) ;
+  }
+  else
+  {
+    msg = (message_desc_t *)mh_descriptors[mh] ;
+    show_message_desc( msg ) ;
+  }
+}
+
+show_message_desc( msg )
+  message_desc_t * msg ;
+{
+  rsl_fldspec_t  *fld ; 
+  int dim ;
+  int mh ;
+
+  if ( msg == NULL ) return ;
+  fprintf(fp,"MESSAGE HANDLE: %d\n",msg->mh ) ;
+  fprintf(fp,"           tag: %d\n",msg->tag ) ;
+  fprintf(fp,"         nflds: %d\n",msg->nflds ) ;
+  for ( fld = msg->fldspecs ; fld != NULL ; fld=fld->next )
+  {
+    fprintf(fp,"  FLD:\n") ;
+    fprintf(fp,"          base: %x\n",fld->base ) ;
+    fprintf(fp,"          ndim: %d\n",fld->ndim ) ;
+    fprintf(fp,"        elemsz: %d\n",fld->elemsz ) ;
+    for ( dim = 0 ; dim < fld->ndim && dim < RSL_MAXDIM ; dim++ )
+    {
+      fprintf(fp,"       decomp[%3d]: %d\n",dim,fld->decomp[dim] ) ;
+      fprintf(fp,"         gdex[%3d]: %d\n",dim,fld->gdex[dim] ) ;
+      fprintf(fp,"         glen[%3d]: %d\n",dim,fld->glen[dim] ) ;
+      fprintf(fp,"         llen[%3d]: %d\n",dim,fld->llen[dim] ) ;
+    }
+  }
+}
+
+/*@
+  SHOW_STENCIL - Show information about the stencil structure
+
+  Input parameter:
+. s - domain descriptor
+
+  Synopsis:
+  subroutine SHOW_STENCIL ( s )
+  integer s		
+
+  Notes:
+  Information is sent to a file show_def_ for each
+  processor.
+
+  See also:
+  RSL_CREATE_STENCIL, RSL_DESCRIBE_STENCIL
+
+@*/
+
+SHOW_STENCIL ( d_p, sh_p )
+  int_p d_p ;
+  int_p sh_p ;
+{
+  int sh, d ;
+  int spt ;
+  stencil_desc_t * sten ; 
+  char * code ;
+  char fname[80] ;
+
+  d  = *d_p ;
+  sh = *sh_p ;
+  if ( show_first )
+  {
+    code = "w" ;
+    show_first = 0 ;
+    sprintf(fname,"show_def_%04d",rsl_myproc) ;
+    if (( fp = fopen ( fname, code )) == NULL )
+    {
+       perror(fname) ;
+       exit(2) ;
+    }
+  }
+  sten = (stencil_desc_t *)sh_descriptors[sh] ;
+  if ( sten == NULL ) return ;
+  fprintf(fp,"STENCIL HANDLE: %d\n",sh ) ;
+  fprintf(fp,"           tag: %d\n",sten->tag ) ;
+  fprintf(fp,"          npts: %d\n",sten->npts[d] ) ;
+  fprintf(fp,"        maskid: %d\n",sten->maskid[d] ) ;
+  
+  for ( spt = 0 ; spt < sten->npts[d] && spt < RSL_MAXSTEN+1 ; spt++ )
+  {
+    fprintf(fp,"    stencil pt: %d\n",spt ) ;
+    show_message_desc( sten->msgs[d][spt] ) ;
+  }
+
+  /* code to show processor lists not here yet */
+
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_world.bad b/wrfv2_fire/external/RSL/RSL/comp_world.bad
new file mode 100755
index 00000000..994b09f4
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_world.bad
@@ -0,0 +1,502 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_GET_RUN_INFO - get RSL information about size and shape local allocation.
+
+  Notes:
+  This routine is used to initialize loops over each processor's
+  local partition of the decomposed domain.  The routine can be used
+  directly, or RSL-provided macros may be used in the code that expand
+  to the proper calls.  Both M4 and CPP macros are provided in the 
+  RSL distribution (see LoopMacros).
+  The macro approach is recommended
+  for readability, simplicity,
+  and also to insulate the code from future potential updates in RSL.
+  Of the two sets, the M4 macros are recommended since they
+  are more flexible.
+
+  RSL returns through the arguments Arg6, Arg7, and Arg8 information
+  for iterating over the local processor partition N-major, M-minor.
+  Argument Arg4 is the number of iterations to cover the part of the
+  domain allocated to the processor.  Arg6 contains the
+  J-indices (Arg4 of them) of each I-strip local to the processor.
+  The first index into the local partition is stored at stored at Arg6(3).
+  The locations Arg6(1) and Arg6(2) are placeholders for indices
+  if one wishes to include one or two of the pad or ghost cells in
+  the iteration (see RSL_GET_INFOP).
+  Arg7 contains the starting and ending indices of each I-strip.  Likewise,
+  the first actual index in Arg7 is at Arg7(3).
+  The arguments Arg9, Arg10, and
+  Arg11 have the same sense as Arg6, Arg7, and Arg8, except that they
+  provide information for 
+  iteration in M-major, N-minor order.  Argument Arg5 is
+  the number of major iterations over M.
+  The arrays Arg6, Arg7, Arg8, Arg9, Arg10, and Arg11 store local (memory)
+  indices.  The logical (global) indices can be obtained by subtracting
+  Arg12 (for M-dimension indices) or Arg13 (for N-dimension indices).
+  
+  Unlike programs that are implemented in single address
+  spaces, the identical
+  relationship between logical and memory
+  indices does not hold for data-domain decomposition over distributed
+  memories.  That is, the memory index (the subscripts into a model
+  array) may not be used for testing proximity of the point to a
+  boundary in the logical domain.  Further, the relationship between
+  logical and memory indices differs on each processor.  The Arg12 and
+  Arg13 arguments are the differences between the local and global
+  indices in the M and N dimensions, respectively, and can be used by
+  the program for converting between logical and memory indices.  For
+  example, the local index I in the M dimension is equal to Arg12 plus
+  the global index IG.
+
+  All of these arrays -- Arg6, Arg7, Arg8, Arg9, Arg10, and Arg11 
+  are integers and must have been allocated by the user with size
+  large enough to fit the largest possible run through a dimension.
+  The argument Arg2 is the length of the arrays.
+  The integer Arg1 is an RSL domain descriptor.
+
+  The integer Arg3
+  is the nest level of the domain (mother domain is at nest-level 1),
+  which is not necessary for iteration over the domain but which 
+  is information that RSL has available and that is useful to have
+  at the beginning of a module.
+
+  Example:
+
+$  -- original code --
+
+$  subroutine F( ... )
+$  ...
+$  do j = 3, jl-2
+$    do i = 3, il-2
+$      a(i,j) = b(i,j) + c(i,j)
+$    enddo
+$  enddo
+
+$  -- example using M4 macros in LoopMacros.m4 --
+
+$  subroutine F( ... )
+$  RSL_RUN_DECL
+$  ...
+$  RSL_INIT_RUNVARS(d)              ! d is an RSL domain descriptor
+$  RSL_DO_N(j,3,jl-2)
+$    RSL_DO_M(i,3,il-2)
+$      a(i,j) = b(i,j) + c(i,j)
+$    RSL_ENDDO
+$  RSL_ENDDO
+
+$  -- example using CPP macros in LoopMacros.inc --
+
+$ #include "LoopMacros.cpp"
+$  subroutine F( ... )
+$  RSL_DECLARE_RUN_VARS 
+$  ...
+$  RSL_INIT_RUNS(d)                 ! d is an RSL domain descriptor
+$  RSL_MAJOR_BOUND(j,3,jl-2)
+$    RSL_MINOR_BOUND(j,3,jl-2)
+$      a(i,j) = b(i,j) + c(i,j)
+$    RSL_END_MINOR_LOOPB
+$  RSL_END_MAJOR_LOOPB
+
+$  -- example with macros expanded --
+
+$  subroutine F( ... )
+$  integer   ig,jg,nruni,nrunj,js,is,ie,is2,js2,je2,idif,jdif,nr
+$  dimension js(512)  ,is(512)  ,ie(512)    ! for N-major iteration
+$  dimension is2(512) ,js2(512) ,je2(512)   ! for M-major iteration
+$
+$  call rsl_get_run_info( d,     512,   nl,   nrunj,   nruni, 
+$ +                       js,    is,    ie,
+$ +                       js2,   is2,   ie2,
+$ +                       idif,  jdif                         )
+
+$  do nr = 3, nrun+2
+$    j=js(nr)
+$    jg=j-jdif
+$    if ( jg .ge. 3 .and. jg .le. maxj-2 ) then
+$      do i=is(nr),ie1(nr)
+$        ig=i-idif
+$        if ( ig .ge. 3 .and. ig .le. maxi-2 ) then
+$          a(i,j) = b(i,j) + c(i,j)
+$        endif
+$      enddo
+$    endif
+$  enddo
+
+BREAKTHEEXAMPLECODE
+
+  See also:
+  RSL_GET_RUN_INFOP, LoopMacros.m4
+
+@*/
+
+RSL_GET_RUN_INFO ( d_p, maxrun_p, nl_p, nrunj_p, nruni_p, js, is, ie, is2, js2, je2, idif_p, jdif_p )
+  int_p 
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,nrunj_p      /* (O) Number of runs through domain in j-major traversal */
+   ,nruni_p ;    /* (O) Number of runs through domain in i-minor traversal */
+  int
+    js[]         /* (O) Local J-index of each run in j-major traversal */
+   ,is[]         /* (O) Starting local I-index of each run in j-major traversal */
+   ,ie[]         /* (O) Ending local I-index of each run in j-major traversal */
+   ,is2[]        /* (O) Local I-index of each run in i-major traversal */
+   ,js2[]        /* (O) Starting local J-index of each run in i-major traversal */
+   ,je2[] ;      /* (O) Ending local J-index of each run in i-major traversal */
+  int_p
+    idif_p       /* (O) Difference between local and global I indices (i-ig). */
+   ,jdif_p  ;    /* (O) Difference between local and global J indices (j-jg). */
+{
+  int x ;
+  int *dummy ;
+  x = 0 ;
+  dummy = NULL ;
+  RSL_GET_RUN_INFOP ( d_p, &x, maxrun_p, nl_p, nrunj_p, nruni_p,
+                      js, is, ie, is2, js2, je2, idif_p, jdif_p,
+                      dummy, dummy ) ;
+}
+
+/* additional P argument is the width of pad to allow for */
+/*@
+  RSL_GET_RUN_INFOP - get RSL information about size and shape local allocation.
+
+  Notes:
+  This routine is similar to RSL_GET_RUN_INFO except that it allows for
+  execution on the extended array pads of the local processor
+  subdomains.  This can be useful for trading off computation for
+  communication in the code and can simplify the implementation
+  by allowing fewer modifications for distributed memory
+  parallelism.  The argument Arg2 may be set to
+  for one of 3 modes of iteration over the local subdomain ---
+  Arg2 = 2 gives iteration over the local subdomain and the set of
+  ghost points that are two-away from points in the local subdomain,
+  Arg2 = 1 gives iteration over the local subdomain and the set of
+  ghost points that are one-away from points in the local subdomain, and
+  Arg2 = 0 gives iteration over just the local subdomain (no ghost points).
+  that are immediately adjacent to the local processor subdomain, or
+  the set that is within 2 cells of the local processor subdomain.  The
+  information for controlling iteration over the region is returned in
+  the arguments Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, and Arg12.
+
+  The M4 RSL loop macros automatically initialize 3 separate sets of
+  these data structures for the 3 available modes of iteration.
+
+  See also:
+  RSL_GET_RUN_INFO, LoopMacros.m4
+@*/
+RSL_GET_RUN_INFOP ( d_p, p_p, maxrun_p, nl_p, nrunj_p, nruni_p,
+                    js, is, ie, is2, js2, je2, idif_p, jdif_p,
+                    jg2n, ig2n )
+  int_p
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,p_p          /* (I) How many extra pad cells to include (0, 1, or 2) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,nrunj_p      /* (O) Number of runs through domain in j-major traversal */
+   ,nruni_p      /* (O) Number of runs through domain in i-minor traversal */
+   ,js           /* (OA) Local J-index of each run in j-major traversal */
+   ,is           /* (OA) Starting local I-index of each run in j-major traversal */
+   ,ie           /* (OA) Ending local I-index of each run in j-major traversal */
+   ,is2          /* (OA) Local I-index of each run in i-major traversal */
+   ,js2          /* (OA) Starting local J-index of each run in i-major traversal */
+   ,je2          /* (OA) Ending local J-index of each run in i-major traversal */
+   ,idif_p       /* (O) Difference between local and global I indices (i-ig). */
+   ,jdif_p       /* (O) Difference between local and global J indices (j-jg). */
+   ,jg2n         /* (OA) Number of run for a global J-index in j-major traversal. */
+   ,ig2n         /* (OA) Number of run for a global I-index in i-major traversal. */
+   ;
+{
+  int d, i, p ;
+  d = *d_p ;
+  p = *p_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_run_info: bad domain") ;
+  RSL_TEST_ERR( p < 0, "Negative pad arg for RSL_GET_RUN_INFOP") ;
+  if ( p > MAX_KINDPAD )
+  {
+    sprintf(mess,"RSL_GET_RUN_INFOP: pad arg (%d) larger than %d",p,MAX_KINDPAD) ;
+    RSL_TEST_ERR( 1,  mess ) ;
+  }
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  *nl_p = domain_info[d].nest_level ;
+  *idif_p = domain_info[d].idif ;
+  *jdif_p = domain_info[d].jdif ;
+
+  *nrunj_p = domain_info[d].nrun[p] ;
+  if ( *maxrun_p < *nrunj_p )
+  {
+         *maxrun_p, *nrunj_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+
+/*****************/
+  if ( p <=2 )
+  {
+  for ( i = 0 ; i < MAX_RUNPAD-p ; i++ )
+  {
+    js[i] = 0 ;
+    is[i] = 0 ;
+    ie[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nrunj_p ; i++ )
+  {
+    js[i+(MAX_RUNPAD-p)] = domain_info[d].js[p][i] ;
+    is[i+(MAX_RUNPAD-p)] = domain_info[d].is[p][i] ;
+    ie[i+(MAX_RUNPAD-p)] = domain_info[d].ie[p][i] ;
+  }
+  if ( jg2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      jg2n[i] = domain_info[d].jg2n[p][i] + MAX_RUNPAD-p;
+    }
+  }
+
+  *nruni_p = domain_info[d].nruni[p] ;
+  if ( *maxrun_p < *nruni_p )
+  {
+    sprintf(mess,
+     "rsl_get_run_info: would overwrite user arrays: maxrun (%d) < nruni (%d)",
+         *maxrun_p, *nruni_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  for ( i = 0 ; i < MAX_RUNPAD-p ; i++ )
+  {
+    is2[i] = 0 ;
+    js2[i] = 0 ;
+    je2[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nruni_p ; i++ )
+  {
+    is2[i+(MAX_RUNPAD-p)] = domain_info[d].is2[p][i] ;
+    js2[i+(MAX_RUNPAD-p)] = domain_info[d].js2[p][i] ;
+    je2[i+(MAX_RUNPAD-p)] = domain_info[d].je2[p][i] ;
+  }
+  if ( ig2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      ig2n[i] = domain_info[d].ig2n[p][i] + MAX_RUNPAD-p;
+    }
+  }
+  }
+/*****************/
+/*****************/
+  else if ( p > 3 && p <= 4)
+  {
+  int p1 ;
+  p1 = 0 ;
+  for ( i = 0 ; i < MAX_RUNPAD-p1 ; i++ )
+  {
+    js[i] = 0 ;
+    is[i] = 0 ;
+    ie[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nrunj_p ; i++ )
+  {
+    js[i+(MAX_RUNPAD-0)] = domain_info[d].js[p][i] ;
+    is[i+(MAX_RUNPAD-0)] = domain_info[d].is[p][i] ;
+    ie[i+(MAX_RUNPAD-0)] = domain_info[d].ie[p][i] ;
+  }
+  if ( jg2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      jg2n[i] = domain_info[d].jg2n[p][i] + MAX_RUNPAD-0;
+    }
+  }
+
+  *nruni_p = domain_info[d].nruni[p] ;
+  if ( *maxrun_p < *nruni_p )
+  {
+    sprintf(mess,
+     "rsl_get_run_info: would overwrite user arrays: maxrun (%d) < nruni (%d)",
+         *maxrun_p, *nruni_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  for ( i = 0 ; i < MAX_RUNPAD-0 ; i++ )
+  {
+    is2[i] = 0 ;
+    js2[i] = 0 ;
+    je2[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nruni_p ; i++ )
+  {
+    is2[i+(MAX_RUNPAD-0)] = domain_info[d].is2[p][i] ;
+    js2[i+(MAX_RUNPAD-0)] = domain_info[d].js2[p][i] ;
+    je2[i+(MAX_RUNPAD-0)] = domain_info[d].je2[p][i] ;
+  }
+  if ( ig2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      ig2n[i] = domain_info[d].ig2n[p][i] + MAX_RUNPAD-0;
+    }
+  }
+  }
+/*****************/
+}
+
+RSL_REG_RUN_INFOP( d_p, p_p, maxrun_p, nl_p,
+		  is, ie,
+		  js, je,
+		  idif_p, jdif_p )
+  int_p
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,p_p          /* (I) How many extra pad cells to include (0, 1, or 2) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,is
+   ,ie
+   ,js
+   ,je
+   ,idif_p
+   ,jdif_p ;
+{
+  int d, i, j, p, cnt ;
+  d = *d_p ;
+  p = *p_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_run_info: bad domain") ;
+  RSL_TEST_ERR( p < 0, "Negative pad arg for RSL_GET_RUN_INFOP") ;
+  if ( p > MAX_KINDPAD )
+  {
+    sprintf(mess,"RSL_GET_RUN_INFOP: pad arg (%d) larger than %d",p,MAX_KINDPAD)
+ ;
+    RSL_TEST_ERR( 1,  mess ) ;
+  }
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  RSL_TEST_ERR( domain_info[*d_p].len_n > *maxrun_p,
+    "domain_info[*d_p].len_n > *maxrun_p") ;
+  RSL_TEST_ERR( domain_info[*d_p].len_m > *maxrun_p,
+    "domain_info[*d_p].len_m > *maxrun_p") ;
+
+  *nl_p = domain_info[d].nest_level ;
+  *idif_p = domain_info[d].idif ;
+  *jdif_p = domain_info[d].jdif ;
+
+/* in following code, note assumptions on order of traversal,
+   contiguity of points, and rectangularity of partitions */
+  /** js, je **/
+  for ( j=0, cnt=0 ; j < domain_info[*d_p].len_n ; j++ )
+  {
+    if ( j+1 < domain_info[d].js2[p][MAX_RUNPAD]-*jdif_p )
+    {
+      js[j]=domain_info[d].js2[p][MAX_RUNPAD] ;
+      je[j]=9999999 ;
+    }
+    else if ( j+1 > domain_info[d].je2[p][MAX_RUNPAD]-*jdif_p )
+    {
+      js[j]=9999999 ;
+      je[j]=domain_info[d].je2[p][MAX_RUNPAD] ;
+    }
+    else
+    {
+      js[j]=domain_info[d].js2[p][MAX_RUNPAD] + cnt ;
+      je[j]=domain_info[d].js2[p][MAX_RUNPAD] + cnt ;  /* yes -> js2 */
+      cnt++ ;
+    }
+  }
+  /** is, ie **/
+  for ( i=0, cnt=0 ; i < domain_info[*d_p].len_m ; i++ )
+  {
+    if ( i+1 < domain_info[d].is[p][MAX_RUNPAD]-*idif_p )
+    {
+      is[i]=domain_info[d].is[p][MAX_RUNPAD] ;
+      ie[i]=-9999999 ;
+    }
+    else if ( i+1 > domain_info[d].ie[p][MAX_RUNPAD]-*idif_p )
+    {
+      is[i]=9999999 ;
+      ie[i]=domain_info[d].ie[p][MAX_RUNPAD] ;
+    }
+    else
+    {
+      is[i]=domain_info[d].is[p][MAX_RUNPAD] + cnt ;
+      ie[i]=domain_info[d].is[p][MAX_RUNPAD] + cnt ;  /* yes -> is */
+      cnt++ ;
+    }
+       if ( rsl_debug_flg )
+       {
+       printf("is[%3d] = info[%d].is[%d] + cnt %3d = %d : ",i,d,p,cnt,is[i]);
+       printf("ie[%3d] = %d \n",i,d,p,cnt,ie[i]);
+       }
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/comp_world.c b/wrfv2_fire/external/RSL/RSL/comp_world.c
new file mode 100755
index 00000000..8b345c68
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_world.c
@@ -0,0 +1,688 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_GET_RUN_INFO - get RSL information about size and shape local allocation.
+
+  Notes:
+  This routine is used to initialize loops over each processor's
+  local partition of the decomposed domain.  The routine can be used
+  directly, or RSL-provided macros may be used in the code that expand
+  to the proper calls.  Both M4 and CPP macros are provided in the 
+  RSL distribution (see LoopMacros).
+  The macro approach is recommended
+  for readability, simplicity,
+  and also to insulate the code from future potential updates in RSL.
+  Of the two sets, the M4 macros are recommended since they
+  are more flexible.
+
+  RSL returns through the arguments Arg6, Arg7, and Arg8 information
+  for iterating over the local processor partition N-major, M-minor.
+  Argument Arg4 is the number of iterations to cover the part of the
+  domain allocated to the processor.  Arg6 contains the
+  J-indices (Arg4 of them) of each I-strip local to the processor.
+  The first index into the local partition is stored at stored at Arg6(3).
+  The locations Arg6(1) and Arg6(2) are placeholders for indices
+  if one wishes to include one or two of the pad or ghost cells in
+  the iteration (see RSL_GET_INFOP).
+  Arg7 contains the starting and ending indices of each I-strip.  Likewise,
+  the first actual index in Arg7 is at Arg7(3).
+  The arguments Arg9, Arg10, and
+  Arg11 have the same sense as Arg6, Arg7, and Arg8, except that they
+  provide information for 
+  iteration in M-major, N-minor order.  Argument Arg5 is
+  the number of major iterations over M.
+  The arrays Arg6, Arg7, Arg8, Arg9, Arg10, and Arg11 store local (memory)
+  indices.  The logical (global) indices can be obtained by subtracting
+  Arg12 (for M-dimension indices) or Arg13 (for N-dimension indices).
+  
+  Unlike programs that are implemented in single address
+  spaces, the identical
+  relationship between logical and memory
+  indices does not hold for data-domain decomposition over distributed
+  memories.  That is, the memory index (the subscripts into a model
+  array) may not be used for testing proximity of the point to a
+  boundary in the logical domain.  Further, the relationship between
+  logical and memory indices differs on each processor.  The Arg12 and
+  Arg13 arguments are the differences between the local and global
+  indices in the M and N dimensions, respectively, and can be used by
+  the program for converting between logical and memory indices.  For
+  example, the local index I in the M dimension is equal to Arg12 plus
+  the global index IG.
+
+  All of these arrays -- Arg6, Arg7, Arg8, Arg9, Arg10, and Arg11 
+  are integers and must have been allocated by the user with size
+  large enough to fit the largest possible run through a dimension.
+  The argument Arg2 is the length of the arrays.
+  The integer Arg1 is an RSL domain descriptor.
+
+  The integer Arg3
+  is the nest level of the domain (mother domain is at nest-level 1),
+  which is not necessary for iteration over the domain but which 
+  is information that RSL has available and that is useful to have
+  at the beginning of a module.
+
+  Example:
+
+$  -- original code --
+
+$  subroutine F( ... )
+$  ...
+$  do j = 3, jl-2
+$    do i = 3, il-2
+$      a(i,j) = b(i,j) + c(i,j)
+$    enddo
+$  enddo
+
+$  -- example using M4 macros in LoopMacros.m4 --
+
+$  subroutine F( ... )
+$  RSL_RUN_DECL
+$  ...
+$  RSL_INIT_RUNVARS(d)              ! d is an RSL domain descriptor
+$  RSL_DO_N(j,3,jl-2)
+$    RSL_DO_M(i,3,il-2)
+$      a(i,j) = b(i,j) + c(i,j)
+$    RSL_ENDDO
+$  RSL_ENDDO
+
+$  -- example using CPP macros in LoopMacros.inc --
+
+$ #include "LoopMacros.cpp"
+$  subroutine F( ... )
+$  RSL_DECLARE_RUN_VARS 
+$  ...
+$  RSL_INIT_RUNS(d)                 ! d is an RSL domain descriptor
+$  RSL_MAJOR_BOUND(j,3,jl-2)
+$    RSL_MINOR_BOUND(j,3,jl-2)
+$      a(i,j) = b(i,j) + c(i,j)
+$    RSL_END_MINOR_LOOPB
+$  RSL_END_MAJOR_LOOPB
+
+$  -- example with macros expanded --
+
+$  subroutine F( ... )
+$  integer   ig,jg,nruni,nrunj,js,is,ie,is2,js2,je2,idif,jdif,nr
+$  dimension js(512)  ,is(512)  ,ie(512)    ! for N-major iteration
+$  dimension is2(512) ,js2(512) ,je2(512)   ! for M-major iteration
+$
+$  call rsl_get_run_info( d,     512,   nl,   nrunj,   nruni, 
+$ +                       js,    is,    ie,
+$ +                       js2,   is2,   ie2,
+$ +                       idif,  jdif                         )
+
+$  do nr = 3, nrun+2
+$    j=js(nr)
+$    jg=j-jdif
+$    if ( jg .ge. 3 .and. jg .le. maxj-2 ) then
+$      do i=is(nr),ie1(nr)
+$        ig=i-idif
+$        if ( ig .ge. 3 .and. ig .le. maxi-2 ) then
+$          a(i,j) = b(i,j) + c(i,j)
+$        endif
+$      enddo
+$    endif
+$  enddo
+
+BREAKTHEEXAMPLECODE
+
+  See also:
+  RSL_GET_RUN_INFOP, LoopMacros.m4
+
+@*/
+
+RSL_GET_RUN_INFO ( d_p, maxrun_p, nl_p, nrunj_p, nruni_p, js, is, ie, is2, js2, je2, idif_p, jdif_p )
+  int_p 
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,nrunj_p      /* (O) Number of runs through domain in j-major traversal */
+   ,nruni_p ;    /* (O) Number of runs through domain in i-minor traversal */
+  int
+    js[]         /* (O) Local J-index of each run in j-major traversal */
+   ,is[]         /* (O) Starting local I-index of each run in j-major traversal */
+   ,ie[]         /* (O) Ending local I-index of each run in j-major traversal */
+   ,is2[]        /* (O) Local I-index of each run in i-major traversal */
+   ,js2[]        /* (O) Starting local J-index of each run in i-major traversal */
+   ,je2[] ;      /* (O) Ending local J-index of each run in i-major traversal */
+  int_p
+    idif_p       /* (O) Difference between local and global I indices (i-ig). */
+   ,jdif_p  ;    /* (O) Difference between local and global J indices (j-jg). */
+{
+  int x ;
+  int *dummy ;
+  x = 0 ;
+  dummy = NULL ;
+  RSL_GET_RUN_INFOP ( d_p, &x, maxrun_p, nl_p, nrunj_p, nruni_p,
+                      js, is, ie, is2, js2, je2, idif_p, jdif_p,
+                      dummy, dummy ) ;
+}
+
+/* additional P argument is the width of pad to allow for */
+/*@
+  RSL_GET_RUN_INFOP - get RSL information about size and shape local allocation.
+
+  Notes:
+  This routine is similar to RSL_GET_RUN_INFO except that it allows for
+  execution on the extended array pads of the local processor
+  subdomains.  This can be useful for trading off computation for
+  communication in the code and can simplify the implementation
+  by allowing fewer modifications for distributed memory
+  parallelism.  The argument Arg2 may be set to
+  for one of 3 modes of iteration over the local subdomain ---
+  Arg2 = 2 gives iteration over the local subdomain and the set of
+  ghost points that are two-away from points in the local subdomain,
+  Arg2 = 1 gives iteration over the local subdomain and the set of
+  ghost points that are one-away from points in the local subdomain, and
+  Arg2 = 0 gives iteration over just the local subdomain (no ghost points).
+  that are immediately adjacent to the local processor subdomain, or
+  the set that is within 2 cells of the local processor subdomain.  The
+  information for controlling iteration over the region is returned in
+  the arguments Arg5, Arg6, Arg7, Arg8, Arg9, Arg10, Arg11, and Arg12.
+
+  The M4 RSL loop macros automatically initialize 3 separate sets of
+  these data structures for the 3 available modes of iteration.
+
+  See also:
+  RSL_GET_RUN_INFO, LoopMacros.m4
+@*/
+RSL_GET_RUN_INFOP ( d_p, p_p, maxrun_p, nl_p, nrunj_p, nruni_p,
+                    js, is, ie, is2, js2, je2, idif_p, jdif_p,
+                    jg2n, ig2n )
+  int_p
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,p_p          /* (I) How many extra pad cells to include (0, 1, or 2) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,nrunj_p      /* (O) Number of runs through domain in j-major traversal */
+   ,nruni_p      /* (O) Number of runs through domain in i-minor traversal */
+   ,js           /* (OA) Local J-index of each run in j-major traversal */
+   ,is           /* (OA) Starting local I-index of each run in j-major traversal */
+   ,ie           /* (OA) Ending local I-index of each run in j-major traversal */
+   ,is2          /* (OA) Local I-index of each run in i-major traversal */
+   ,js2          /* (OA) Starting local J-index of each run in i-major traversal */
+   ,je2          /* (OA) Ending local J-index of each run in i-major traversal */
+   ,idif_p       /* (O) Difference between local and global I indices (i-ig). */
+   ,jdif_p       /* (O) Difference between local and global J indices (j-jg). */
+   ,jg2n         /* (OA) Number of run for a global J-index in j-major traversal. */
+   ,ig2n         /* (OA) Number of run for a global I-index in i-major traversal. */
+   ;
+{
+  int d, i, p ;
+  d = *d_p ;
+  p = *p_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_run_info: bad domain") ;
+  RSL_TEST_ERR( p < 0, "Negative pad arg for RSL_GET_RUN_INFOP") ;
+  if ( p > MAX_KINDPAD )
+  {
+    sprintf(mess,"RSL_GET_RUN_INFOP: pad arg (%d) larger than %d",p,MAX_KINDPAD) ;
+    RSL_TEST_ERR( 1,  mess ) ;
+  }
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  *nl_p = domain_info[d].nest_level ;
+  *idif_p = domain_info[d].idif ;
+  *jdif_p = domain_info[d].jdif ;
+
+  *nrunj_p = domain_info[d].nrun[p] ;
+  if ( *maxrun_p < *nrunj_p )
+  {
+    sprintf(mess,
+     "rsl_get_run_info: would overwrite user arrays: maxrun (%d) < nruni (%d)",
+         *maxrun_p, *nrunj_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+
+/*****************/
+  if ( p <= MAX_RUNPAD )
+  {
+  for ( i = 0 ; i < MAX_RUNPAD-p ; i++ )
+  {
+    js[i] = 0 ;
+    is[i] = 0 ;
+    ie[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nrunj_p ; i++ )
+  {
+    js[i+(MAX_RUNPAD-p)] = domain_info[d].js[p][i] ;
+    is[i+(MAX_RUNPAD-p)] = domain_info[d].is[p][i] ;
+    ie[i+(MAX_RUNPAD-p)] = domain_info[d].ie[p][i] ;
+  }
+  if ( jg2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      jg2n[i] = domain_info[d].jg2n[p][i] + MAX_RUNPAD-p;
+    }
+  }
+
+  *nruni_p = domain_info[d].nruni[p] ;
+  if ( *maxrun_p < *nruni_p )
+  {
+    sprintf(mess,
+     "rsl_get_run_info: would overwrite user arrays: maxrun (%d) < nruni (%d)",
+         *maxrun_p, *nruni_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  for ( i = 0 ; i < MAX_RUNPAD-p ; i++ )
+  {
+    is2[i] = 0 ;
+    js2[i] = 0 ;
+    je2[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nruni_p ; i++ )
+  {
+    is2[i+(MAX_RUNPAD-p)] = domain_info[d].is2[p][i] ;
+    js2[i+(MAX_RUNPAD-p)] = domain_info[d].js2[p][i] ;
+    je2[i+(MAX_RUNPAD-p)] = domain_info[d].je2[p][i] ;
+  }
+  if ( ig2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      ig2n[i] = domain_info[d].ig2n[p][i] + MAX_RUNPAD-p;
+    }
+  }
+  }
+/*****************/
+/*****************/
+  else if ( p > 3 && p <= 4)
+  {
+  int p1 ;
+  p1 = 0 ;
+  for ( i = 0 ; i < MAX_RUNPAD-p1 ; i++ )
+  {
+    js[i] = 0 ;
+    is[i] = 0 ;
+    ie[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nrunj_p ; i++ )
+  {
+    js[i+(MAX_RUNPAD-0)] = domain_info[d].js[p][i] ;
+    is[i+(MAX_RUNPAD-0)] = domain_info[d].is[p][i] ;
+    ie[i+(MAX_RUNPAD-0)] = domain_info[d].ie[p][i] ;
+  }
+  if ( jg2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      jg2n[i] = domain_info[d].jg2n[p][i] + MAX_RUNPAD-0;
+    }
+  }
+
+  *nruni_p = domain_info[d].nruni[p] ;
+  if ( *maxrun_p < *nruni_p )
+  {
+    sprintf(mess,
+     "rsl_get_run_info: would overwrite user arrays: maxrun (%d) < nruni (%d)",
+         *maxrun_p, *nruni_p ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  for ( i = 0 ; i < MAX_RUNPAD-0 ; i++ )
+  {
+    is2[i] = 0 ;
+    js2[i] = 0 ;
+    je2[i] = -1 ;
+  }
+  for ( i = 0 ; i < *nruni_p ; i++ )
+  {
+    is2[i+(MAX_RUNPAD-0)] = domain_info[d].is2[p][i] ;
+    js2[i+(MAX_RUNPAD-0)] = domain_info[d].js2[p][i] ;
+    je2[i+(MAX_RUNPAD-0)] = domain_info[d].je2[p][i] ;
+  }
+  if ( ig2n != NULL )
+  {
+    for ( i = 0 ; i < domain_info[d].len_n ; i++ )
+    {
+      ig2n[i] = domain_info[d].ig2n[p][i] + MAX_RUNPAD-0;
+    }
+  }
+  }
+/*****************/
+}
+
+RSL_REG_RUN_INFOP ( d_p, p_p, maxrun_p, nl_p,
+		  is, ie,
+		  js, je,
+		  idif_p, jdif_p )
+  int_p
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,p_p          /* (I) How many extra pad cells to include (0, 1, or 2) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,is
+   ,ie
+   ,js
+   ,je
+   ,idif_p
+   ,jdif_p ;
+{
+  int d, i, j, p, cnt ;
+  d = *d_p ;
+  p = *p_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_run_info: bad domain") ;
+  RSL_TEST_ERR( p < 0, "Negative pad arg for RSL_GET_RUN_INFOP") ;
+  if ( p > MAX_KINDPAD )
+  {
+    sprintf(mess,"RSL_GET_RUN_INFOP: pad arg (%d) larger than %d",p,MAX_KINDPAD)
+ ;
+    RSL_TEST_ERR( 1,  mess ) ;
+  }
+  RSL_TEST_ERR( ((! sw_allow_dynpad) && p > 4),
+   "Invalid to call RSL_REG_RUN_INFOP with p > 4 if RSL_ALLOW_DYNPAD has not been called.\n") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  RSL_TEST_ERR( domain_info[*d_p].len_n > *maxrun_p,
+    "domain_info[*d_p].len_n > *maxrun_p") ;
+  RSL_TEST_ERR( domain_info[*d_p].len_m > *maxrun_p,
+    "domain_info[*d_p].len_m > *maxrun_p") ;
+
+  *nl_p = domain_info[d].nest_level ;
+  *idif_p = domain_info[d].idif ;
+  *jdif_p = domain_info[d].jdif ;
+
+#define WHICH_RUN 0
+/* in following code, note assumptions on order of traversal,
+   contiguity of points, and rectangularity of partitions */
+  /** js, je **/
+  for ( j=0, cnt=0 ; j < domain_info[*d_p].len_n ; j++ )
+  {
+    if ( j+1 < domain_info[d].js2[p][WHICH_RUN]-*jdif_p )
+    {
+      js[j]=domain_info[d].js2[p][WHICH_RUN] ;
+      je[j]=-9999999 ;
+    }
+    else if ( j+1 > domain_info[d].je2[p][WHICH_RUN]-*jdif_p )
+    {
+      js[j]=9999999 ;
+      je[j]=domain_info[d].je2[p][WHICH_RUN] ;
+    }
+    else
+    {
+      js[j]=domain_info[d].js2[p][WHICH_RUN] + cnt ;
+      je[j]=domain_info[d].js2[p][WHICH_RUN] + cnt ;  /* yes -> js2 */
+      cnt++ ;
+    }
+  }
+  /** is, ie **/
+  for ( i=0, cnt=0 ; i < domain_info[*d_p].len_m ; i++ )
+  {
+    if ( i+1 < domain_info[d].is[p][WHICH_RUN]-*idif_p )
+    {
+      is[i]=domain_info[d].is[p][WHICH_RUN] ;
+      ie[i]=-9999999 ;
+    }
+    else if ( i+1 > domain_info[d].ie[p][WHICH_RUN]-*idif_p )
+    {
+      is[i]=9999999 ;
+      ie[i]=domain_info[d].ie[p][WHICH_RUN] ;
+    }
+    else
+    {
+      is[i]=domain_info[d].is[p][WHICH_RUN] + cnt ;
+      ie[i]=domain_info[d].is[p][WHICH_RUN] + cnt ;  /* yes -> is */
+      cnt++ ;
+    }
+  }
+}
+
+RSL_DYNPAD_7    ( d_p, maxrun_p, nl_p,
+		  is, ie,
+		  js, je,
+		  idif_p, jdif_p )
+  int_p
+    d_p          /* (I) RSL domain descriptor (input) */
+   ,maxrun_p     /* (I) Number of elements in array arguments to this routine */
+   ,nl_p         /* (O) Nest level of the domain */
+   ,is          /* 2d arrays -- first index is array elements, second is runpad from 0..6 */
+   ,ie
+   ,js
+   ,je
+   ,idif_p
+   ,jdif_p ;
+{
+  int d, i, j, p, cnt ;
+  d = *d_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_run_info: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  RSL_TEST_ERR( ! sw_allow_dynpad, "RSL_DYNPAD_7 cannot be used unless RSL_ALLOW_DYNPAD has been called") ; 
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  RSL_TEST_ERR( domain_info[*d_p].len_n > *maxrun_p,
+    "domain_info[*d_p].len_n > *maxrun_p") ;
+  RSL_TEST_ERR( domain_info[*d_p].len_m > *maxrun_p,
+    "domain_info[*d_p].len_m > *maxrun_p") ;
+
+  *nl_p = domain_info[d].nest_level ;
+  *idif_p = domain_info[d].idif ;
+  *jdif_p = domain_info[d].jdif ;
+
+  for ( p = 0 ; p <= 6 ; p++ )
+  {
+
+#define WHICH_RUN 0
+/* in following code, note assumptions on order of traversal,
+   contiguity of points, and rectangularity of partitions */
+  /** js, je **/
+  for ( j=0, cnt=0 ; j < domain_info[*d_p].len_n ; j++ )
+  {
+    if ( j+1 < domain_info[d].js2[p][WHICH_RUN]-*jdif_p )
+    {
+      js[j+*maxrun_p*p]=domain_info[d].js2[p][WHICH_RUN] ;
+      je[j+*maxrun_p*p]=-9999999 ;
+    }
+    else if ( j+1 > domain_info[d].je2[p][WHICH_RUN]-*jdif_p )
+    {
+      js[j+*maxrun_p*p]=9999999 ;
+      je[j+*maxrun_p*p]=domain_info[d].je2[p][WHICH_RUN] ;
+    }
+    else
+    {
+      js[j+*maxrun_p*p]=domain_info[d].js2[p][WHICH_RUN] + cnt ;
+      je[j+*maxrun_p*p]=domain_info[d].js2[p][WHICH_RUN] + cnt ;  /* yes -> js2 */
+      cnt++ ;
+    }
+  }
+  /** is, ie **/
+  for ( i=0, cnt=0 ; i < domain_info[*d_p].len_m ; i++ )
+  {
+    if ( i+1 < domain_info[d].is[p][WHICH_RUN]-*idif_p )
+    {
+      is[i+*maxrun_p*p]=domain_info[d].is[p][WHICH_RUN] ;
+      ie[i+*maxrun_p*p]=-9999999 ;
+    }
+    else if ( i+1 > domain_info[d].ie[p][WHICH_RUN]-*idif_p )
+    {
+      is[i+*maxrun_p*p]=9999999 ;
+      ie[i+*maxrun_p*p]=domain_info[d].ie[p][WHICH_RUN] ;
+    }
+    else
+    {
+      is[i+*maxrun_p*p]=domain_info[d].is[p][WHICH_RUN] + cnt ;
+      ie[i+*maxrun_p*p]=domain_info[d].is[p][WHICH_RUN] + cnt ;  /* yes -> is */
+      cnt++ ;
+    }
+  }
+  }
+}
+
+RSL_REG_PATCHINFO_MN ( d_p ,
+                       sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3   )
+  int_p d_p ;
+  int_p sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3 ;
+{
+  int d, i, j, k ;
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "rsl_get_run_info: bad domain" ) ;
+  *sp1 = -1 ; *ep1 = -1 ;
+  *sp2 = -1 ; *ep2 = -1 ;
+  for ( j = 0 ; j < domain_info[d].len_n ; j++ )
+  {
+    for ( i = 0 ; i < domain_info[d].len_m ; i++ )
+    {
+      if ( rsl_c_comp2phys_proc(domain_info[d].domain[INDEX_2(j,i,domain_info[d].len_m)].P)==rsl_myproc)
+      {
+	if ( *sp1 < 0 ) *sp1 = i + 1 ;
+	*ep1 = i + 1 ;
+	if ( *sp2 < 0 ) *sp2 = j + 1 ;
+	*ep2 = j + 1 ;
+      }
+    }
+  }
+  *sp3 = 1 ;
+  *ep3 = domain_info[d].len_z ;
+}
+
+RSL_REG_PATCHINFO_MZ ( d_p ,
+                       sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3   )
+  int_p d_p ;
+  int_p sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3 ;
+{
+  int d, i, j, k ;
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "rsl_get_run_info: bad domain" ) ;
+  *sp1 = -1 ; *ep1 = -1 ;
+  *sp3 = -1 ; *ep3 = -1 ;
+  for ( k = 0 ; k < domain_info[d].len_z ; k++ )
+  {
+    for ( i = 0 ; i < domain_info[d].len_m ; i++ )
+    {
+      if ( rsl_c_comp2phys_proc(domain_info[d].domain_mz[INDEX_2(k,i,domain_info[d].len_m)].P)==rsl_myproc)
+      {
+        if ( *sp1 < 0 ) *sp1 = i + 1 ;
+        *ep1 = i + 1 ;
+        if ( *sp3 < 0 ) *sp3 = k + 1 ;
+        *ep3 = k + 1 ;
+      }
+    }
+  }
+  *sp2 = 1 ;
+  *ep2 = domain_info[d].len_n ;
+}
+
+RSL_REG_PATCHINFO_NZ ( d_p ,
+                       sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3   )
+  int_p d_p ;
+  int_p sp1  , ep1  , sp2  , ep2 ,  sp3  , ep3 ;
+{
+  int d, i, j, k ;
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "rsl_get_run_info: bad domain" ) ;
+  *sp2 = -1 ; *ep2 = -1 ;
+  *sp3 = -1 ; *ep3 = -1 ;
+  for ( k = 0 ; k < domain_info[d].len_z ; k++ )
+  {
+    for ( j = 0 ; j < domain_info[d].len_n ; j++ )
+    {
+      if ( rsl_c_comp2phys_proc(domain_info[d].domain_nz[INDEX_2(k,j,domain_info[d].len_n)].P)==rsl_myproc)
+      {
+        if ( *sp2 < 0 ) *sp2 = j + 1 ;
+        *ep2 = j + 1 ;
+        if ( *sp3 < 0 ) *sp3 = k + 1 ;
+        *ep3 = k + 1 ;
+      }
+    }
+  }
+  *sp1 = 1 ;
+  *ep1 = domain_info[d].len_m ;
+}
+
+RSL_GET_GLEN ( d_p , mlen_p , nlen_p , zlen_p )
+  int_p d_p, mlen_p, nlen_p, zlen_p ;
+{
+  rsl_domain_info_t *dinfo ;
+  int d ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_get_get_glen: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_get_glen: invalid domain") ;
+
+  dinfo = &(domain_info[d]) ;
+  *mlen_p = dinfo->len_m ;
+  *nlen_p = dinfo->len_n ;
+  *zlen_p = dinfo->len_z ;
+  return(0) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/comp_xpose.c b/wrfv2_fire/external/RSL/RSL/comp_xpose.c
new file mode 100755
index 00000000..781f08a1
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/comp_xpose.c
@@ -0,0 +1,858 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* The mechanism here is similar to and patterned after that used by the
+   stencil mechanism: see comp_sten.c */
+
+
+/* this is used internally only -- this will be called automatically
+   whenever a xpose is attempted that has not
+   yet been compiled */
+rsl_compile_xpose( d_p, x_p )
+  int_p d_p, x_p ;
+{
+  int d, x ;
+  xpose_desc_t * xp ;
+  int i, j, ig, jg, kg, k, js, je, is, ie, ks, ke  ;
+  int len_plist ;
+  rsl_domain_info_t *dp ;
+  rsl_point_t  *pt ;
+  rsl_dimlen_t mlen, nlen, zlen ;
+  rsl_fldspec_t * fld ;
+  message_desc_t *msg_from, *msg_to ;
+  rsl_procrec_t *procrec ;
+  int m, n, dir ;
+  rsl_processor_t P, Plist[RSL_MAXPROC], sendP, recvP, prevP ;
+  int elemsz, t0, t1 ;
+  int ipack ;
+  void *base ;
+
+  d = *d_p ;
+  x = *x_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "rsl_compile_xpose: bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID, 
+        "rsl_compile_xpose: descriptor for invalid domain" ) ;
+
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+  zlen = domain_info[d].len_z ;
+
+  RSL_TEST_ERR( x <= 0 || x > RSL_MAXDESCRIPTORS,
+        "rsl_compile_xpose: bad xpose descriptor" ) ;
+  RSL_TEST_ERR((xp = (xpose_desc_t *)xp_descriptors[x]) == NULL,
+        "rsl_compile_xpose: null xpose descriptor" ) ;
+  RSL_TEST_ERR( xp->tag != XPOSE_DESC,
+        "rsl_compile_xpose: bad xpose descriptor" ) ;
+  RSL_TEST_ERR( xp->compiled[d] != 0,
+        "rsl_compile_xpose: xpose has already been compiled for this domain") ;
+
+  xp->compiled[d] = 1 ;
+
+  dp = &(domain_info[d]) ;
+  if ( dp->decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+/************* MN to MZ *************/
+
+  msg_from = xp->msgs_mn[d] ; 
+  msg_to   = xp->msgs_mz[d] ;
+
+
+/* first pass builds the procrec list, second pass traverses it */
+/* this is necessary because the process_refs mechanism can only */
+/* build one set of pack or unpack lists at a time */
+/* ipack = 0 packing on sender ; ipack = 1, unpacking on receiver */
+
+    xp->procs[d][XPOSE_MN_MZ] = NULL ;
+    ipack = 0 ;
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )
+    {
+      procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
+      procrec->P = P ;
+
+      init_process_refs() ;
+
+/***/ for ( k = 0 ; k < zlen ; k++ )
+      {
+/***/   for ( ig = 0 ; ig < mlen ; ig++ )
+        {
+         recvP = domain_info[*d_p].domain_mz[INDEX_2(k,ig,mlen)].P ;
+         if ( ipack == 0 || rsl_c_comp2phys_proc(recvP) != rsl_myproc )
+         {
+          js = 0 - domain_info[d].jlocaloffset ; je = -1 ;
+          prevP = domain_info[*d_p].domain[INDEX_2(0,ig,mlen)].P ;
+#if 0
+fprintf(stderr,"set js to %d\n",js) ;
+fprintf(stderr,"set prevP to %d\n",prevP) ;
+#endif
+/***/     for ( jg = 0 ; jg < nlen ; jg++ ) 
+          {
+	    sendP = domain_info[*d_p].domain[INDEX_2(jg,ig,mlen)].P ;
+	    if ( jg == nlen-1 ) 
+              { sendP = -1 ; je++ ;}
+            i = ig - domain_info[d].ilocaloffset ;
+            j = jg - domain_info[d].jlocaloffset ;
+#if 0
+if ( k==0) fprintf(stderr,"P %d sendP %d prevP %d js %d je %d\n",P,sendP,prevP, js,je) ;
+#endif
+	    if ((ipack == 0) && (sendP != prevP ))
+	    {
+	      if ( rsl_c_comp2phys_proc(prevP) == rsl_myproc && recvP == P )
+	      {
+	        if ( jg > 0 )
+	        {
+	          /* store the pencil (ig,k,js:je) as being sent 
+	             from sendP and received by recvP */
+  
+                  if ( ipack == 0 ) { fld = msg_from->fldspecs ; }
+                  else              { fld = msg_to->fldspecs ; }
+  
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d js %2d je %2d je-js+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,js,je,je-js+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+js*t0+k*t1)*elemsz, elemsz,
+                                                  je-js+1 ,
+                                                  -t0*elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (js+i*t0+k*t1)*elemsz, (je-js+1)*elemsz,
+                                                  1 ,
+                                                  -elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (k+i*t0+js*t1)*elemsz, elemsz,
+                                                  je-js+1, 
+						  -t1*elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d js %2d je %2d je-js+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,js,je,je-js+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+k*t0+js*t1)*elemsz, elemsz,
+                                                  je-js+1,
+						  -t1*elemsz) ;  /* don't need to suppress packing optimization on MN grid because of pads */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting js to %d\n",j) ;
+#endif
+	      js = j ;
+	    }
+	    je = j ;
+#if 0
+fprintf(stderr,"resetting je to %d\n",je) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+         }
+        }
+      }
+        process_refs( &(procrec->pack_table),
+                      &(procrec->pack_table_size),
+                      &(procrec->pack_table_nbytes), 1 ) ;
+
+#if 0
+        fprintf(stderr,"pack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->pack_table,
+                         procrec->pack_table_size,
+                         procrec->pack_table_nbytes ) ;
+#endif
+
+        procrec->next = xp->procs[d][XPOSE_MN_MZ] ;
+        xp->procs[d][XPOSE_MN_MZ] = procrec ;
+    }
+
+/* unpacking loop */
+
+    ipack = 1 ;
+    for ( procrec = xp->procs[d][XPOSE_MN_MZ] ; procrec != NULL ; procrec = procrec->next )
+    {
+      P = procrec->P ;
+      init_process_refs() ;
+
+/***/ for ( kg = 0 ; kg < zlen ; kg++ )
+      {
+/***/   for ( ig = 0 ; ig < mlen ; ig++ )
+        {
+         recvP = domain_info[*d_p].domain_mz[INDEX_2(kg,ig,mlen)].P ;
+
+          js = 0 - domain_info[d].jlocaloffset_mz ; je = -1 ;
+
+          prevP = domain_info[*d_p].domain[INDEX_2(0,ig,mlen)].P ;
+/***/     for ( jg = 0 ; jg < nlen ; jg++ ) 
+          {
+	    sendP = domain_info[*d_p].domain[INDEX_2(jg,ig,mlen)].P ;
+	    if ( jg == nlen-1 ) 
+              { sendP = -1 ; je++ ;}
+
+            i = ig - domain_info[d].ilocaloffset_mz ;
+            j = jg - domain_info[d].jlocaloffset_mz ;
+            k = kg - domain_info[d].klocaloffset_mz ;
+
+	    if (sendP != prevP )
+	    {
+#if 0
+fprintf(stderr,"sendP (%2d) != prevP (%d) =? P (%d) ||  recvP (%d) =? rsl_myproc (%d)\n",
+sendP,prevP,P,recvP,rsl_myproc) ;
+#endif
+ 	      if ( rsl_c_comp2phys_proc(prevP) == P && recvP == rsl_myproc )
+	      {
+	        if ( jg > 0 )
+	        {
+	          /* store the pencil (ig,k,js:je) as being sent 
+	             from sendP and received by recvP */
+    
+                  if ( ipack == 0 ) { fld = msg_from->fldspecs ; }
+                  else              { fld = msg_to->fldspecs ; }
+    
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d js %2d je %2d je-js+1 %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,js,je,je-js+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+js*t0+k*t1)*elemsz, elemsz,
+                                                  je-js+1 ,
+                                                  -t0*elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (js+i*t0+k*t1)*elemsz, (je-js+1)*elemsz,
+                                                  1 ,
+                                                  -elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (k+i*t0+js*t1)*elemsz, elemsz,
+                                                  je-js+1, 
+						  -t1*elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d js %2d je %2d je-js+1 %3d ofst %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,js,je,je-js+1, (i+k*t0+js*t1)*elemsz) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+k*t0+js*t1)*elemsz, elemsz,
+                                                  je-js+1, 
+						  -t1*elemsz) ;   /* negative stride suppresses some unpacking collapses */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting js to %d\n",j) ;
+#endif
+	      js = j ;
+	    }
+	    je = j ;
+#if 0
+fprintf(stderr,"resetting je to %d\n",je) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+        }
+      }
+        process_refs( &(procrec->unpack_table),
+                      &(procrec->unpack_table_size),
+                      &(procrec->unpack_table_nbytes), 1 ) ;
+#if 0
+        fprintf(stderr,"unpack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->unpack_table,
+                         procrec->unpack_table_size,
+                         procrec->unpack_table_nbytes ) ;
+#endif
+
+    }
+
+/************* MZ to NZ *************/
+
+  msg_from = xp->msgs_mz[d] ; 
+  msg_to   = xp->msgs_nz[d] ;
+
+
+/* first pass builds the procrec list, second pass traverses it */
+/* this is necessary because the process_refs mechanism can only */
+/* build one set of pack or unpack lists at a time */
+/* ipack = 0 packing on sender ; ipack = 1, unpacking on receiver */
+
+   ipack = 0  ;
+    xp->procs[d][XPOSE_MZ_NZ] = NULL ;
+    ipack = 0 ;
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )
+    {
+      procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
+      procrec->P = P ;
+
+      init_process_refs() ;
+
+/***/ for ( jg = 0 ; jg < nlen ; jg++ )
+      {
+/***/   for ( kg = 0 ; kg < zlen ; kg++ )
+        {
+         recvP = domain_info[*d_p].domain_nz[INDEX_2(kg,jg,nlen)].P ;
+         if ( ipack == 0 || rsl_c_comp2phys_proc(recvP) != rsl_myproc )
+         {
+          is = 0 - domain_info[d].ilocaloffset_mz ; ie = -1 ;
+          prevP = domain_info[*d_p].domain_mz[INDEX_2(kg,0,mlen)].P ;
+#if 0
+fprintf(stderr,"set is to %d\n",is) ;
+fprintf(stderr,"set prevP to %d\n",prevP) ;
+#endif
+/***/     for ( ig = 0 ; ig < mlen ; ig++ ) 
+          {
+	    sendP = domain_info[*d_p].domain_mz[INDEX_2(kg,ig,mlen)].P ;
+	    if ( ig == mlen-1 ) 
+              { sendP = -1 ; ie++ ;}
+            i = ig - domain_info[d].ilocaloffset_mz ;
+            j = jg - domain_info[d].jlocaloffset_mz ;
+            k = kg - domain_info[d].klocaloffset_mz ;
+#if 0
+if ( k==0) fprintf(stderr,"P %d sendP %d prevP %d js %d je %d\n",P,sendP,prevP, is,ie) ;
+#endif
+	    if (sendP != prevP )
+	    {
+	      if ( rsl_c_comp2phys_proc(prevP) == rsl_myproc && recvP == P )
+	      {
+	        if ( ig > 0 )
+	        {
+	          /* store the pencil (is:ie,k,jg) as being sent 
+	             from sendP and received by recvP */
+  
+                  fld = msg_from->fldspecs ;
+  
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d is %2d ie %2d ie-is+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,is,ie,ie-is+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (is+j*t0+k*t1)*elemsz, (ie-is+1)*elemsz,
+                                                  1 ,
+                                                  -elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (j+is*t0+k*t1)*elemsz, elemsz,
+                                                  (ie-is+1) ,
+                                                  -t0*elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (k+is*t0+j*t1)*elemsz, elemsz,
+                                                  ie-is+1,
+                                                  -t0*elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d is %2d ie %2d ie-is+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,is,ie,ie-is+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (is+k*t0+j*t1)*elemsz, (ie-is+1)*elemsz,
+                                                  1,
+						  -elemsz) ;   /* negative stride suppresses some packing optimzation in process_refs */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting is to %d\n",j) ;
+#endif
+	      is = i ;
+	    }
+	    ie = i ;
+#if 0
+fprintf(stderr,"resetting ie to %d\n",ie) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+         }
+        }
+      }
+        process_refs( &(procrec->pack_table),
+                      &(procrec->pack_table_size),
+                      &(procrec->pack_table_nbytes), 1 ) ;
+
+#if 0
+        fprintf(stderr,"pack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->pack_table,
+                         procrec->pack_table_size,
+                         procrec->pack_table_nbytes ) ;
+#endif
+
+        procrec->next = xp->procs[d][XPOSE_MZ_NZ] ;
+        xp->procs[d][XPOSE_MZ_NZ] = procrec ;
+    }
+
+/* unpacking loop */
+
+    ipack = 1 ;
+    for ( procrec = xp->procs[d][XPOSE_MZ_NZ] ; procrec != NULL ; procrec = procrec->next )
+    {
+      P = procrec->P ;
+      init_process_refs() ;
+
+/***/ for ( jg = 0 ; jg < nlen ; jg++ )
+      {
+/***/   for ( kg = 0 ; kg < zlen ; kg++ )
+        {
+         recvP = domain_info[*d_p].domain_nz[INDEX_2(kg,jg,nlen)].P ;
+          is = 0 - domain_info[d].ilocaloffset_nz ; ie = -1 ;
+          prevP = domain_info[*d_p].domain_mz[INDEX_2(kg,0,mlen)].P ;
+/***/     for ( ig = 0 ; ig < mlen ; ig++ ) 
+          {
+	    sendP = domain_info[*d_p].domain_mz[INDEX_2(kg,ig,mlen)].P ;
+	    if ( ig == mlen-1 ) 
+              { sendP = -1 ; ie++ ;}
+
+            i = ig - domain_info[d].ilocaloffset_nz ;
+            j = jg - domain_info[d].jlocaloffset_nz ;
+            k = kg - domain_info[d].klocaloffset_nz ;
+
+	    if (sendP != prevP )
+	    {
+#if 0
+fprintf(stderr,"sendP (%2d) != prevP (%d) =? P (%d) ||  recvP (%d) =? rsl_myproc (%d)\n",
+sendP,prevP,P,recvP,rsl_myproc) ;
+#endif
+ 	      if ( rsl_c_comp2phys_proc(prevP) == P && recvP == rsl_myproc )
+	      {
+	        if ( ig > 0 )
+	        {
+	          /* store the pencil (is:ie,k,jg) as being sent 
+	             from sendP and received by recvP */
+    
+                  fld = msg_to->fldspecs ;
+    
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d is %2d ie %2d ie-is+1 %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,is,ie,ie-is+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (is+j*t0+k*t1)*elemsz, (ie-is+1)*elemsz,
+                                                  1 ,
+                                                  -elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (j+is*t0+k*t1)*elemsz, elemsz,
+                                                  ie-is+1 ,
+                                                  -t0*elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (k+is*t0+j*t1)*elemsz, elemsz,
+                                                  ie-is+1,
+						  -t0*elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d is %2d ie %2d ie-is+1 %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,is,ie,ie-is+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (is+k*t0+j*t1)*elemsz, (ie-is+1)*elemsz,
+                                                  1,
+						  -elemsz) ;  /* negative stride suppresses some unpacking optimization in process_refs */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting is to %d\n",i) ;
+#endif
+	      is = i ;
+	    }
+	    ie = i ;
+#if 0
+fprintf(stderr,"resetting je to %d\n",je) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+        }
+      }
+        process_refs( &(procrec->unpack_table),
+                      &(procrec->unpack_table_size),
+                      &(procrec->unpack_table_nbytes), 1 ) ;
+#if 0
+        fprintf(stderr,"unpack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->unpack_table,
+                         procrec->unpack_table_size,
+                         procrec->unpack_table_nbytes ) ;
+#endif
+
+    }
+
+/************* NZ to MN *************/
+ /* (may the circle be unbroken) */
+
+  msg_from = xp->msgs_nz[d] ; 
+  msg_to   = xp->msgs_mn[d] ;
+
+/* first pass builds the procrec list, second pass traverses it */
+/* this is necessary because the process_refs mechanism can only */
+/* build one set of pack or unpack lists at a time */
+/* ipack = 0 packing on sender ; ipack = 1, unpacking on receiver */
+
+   ipack = 0  ;
+    xp->procs[d][XPOSE_NZ_MN] = NULL ;
+    ipack = 0 ;
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )
+    {
+      procrec = RSL_MALLOC( rsl_procrec_t, 1 ) ;
+      procrec->P = P ;
+
+      init_process_refs() ;
+
+/***/ for ( jg = 0 ; jg < nlen ; jg++ )
+      {
+/***/   for ( ig = 0 ; ig < mlen ; ig++ ) 
+        {
+         recvP = domain_info[*d_p].domain[INDEX_2(jg,ig,mlen)].P ;
+         if ( ipack == 0 || rsl_c_comp2phys_proc(recvP) != rsl_myproc )
+         {
+          ks = 0 - domain_info[d].klocaloffset_nz ; ke = -1 ;
+          prevP = domain_info[*d_p].domain_nz[INDEX_2(0,jg,nlen)].P ;
+#if 0
+fprintf(stderr,"set ks to %d\n",ks) ;
+fprintf(stderr,"set prevP to %d\n",prevP) ;
+#endif
+/***/     for ( kg = 0 ; kg < zlen ; kg++ )
+          {
+	    sendP = domain_info[*d_p].domain_nz[INDEX_2(kg,jg,nlen)].P ;
+	    if ( kg == zlen-1 ) 
+              { sendP = -1 ; ke++ ;}
+            i = ig - domain_info[d].ilocaloffset_nz ;
+            j = jg - domain_info[d].jlocaloffset_nz ;
+            k = kg - domain_info[d].klocaloffset_nz ;
+#if 0
+if ( k==0) fprintf(stderr,"P %d sendP %d prevP %d ks %d ke %d\n",P,sendP,prevP, ks,ke) ;
+#endif
+	    if (sendP != prevP )
+	    {
+	      if ( rsl_c_comp2phys_proc(prevP) == rsl_myproc && recvP == P )
+	      {
+	        if ( kg > 0 )
+	        {
+	          /* store the pencil (ig,ks:ke,jg) as being sent 
+	             from sendP and received by recvP */
+  
+                  fld = msg_from->fldspecs ;
+  
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d ks %2d ke %2d ke-ks+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,ks,ke,ke-ks+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+j*t0+ks*t1)*elemsz, elemsz,
+                                                  ke-ks+1 ,
+                                                  -t1*elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (j+i*t0+ks*t1)*elemsz, elemsz,
+                                                  ke-ks+1 ,
+                                                  -t1*elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (ks+i*t0+j*t1)*elemsz, (ke-ks+1)*elemsz,
+                                                  1, 
+						  -elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"MZ to MN s_p_r^: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d ks %2d ke %2d ke-ks+1 %3d\n",P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,ks,ke,ke-ks+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+ks*t0+j*t1)*elemsz, elemsz,
+                                                  ke-ks+1,
+						  -t0*elemsz) ;  /* negative stride suppresses some packing optimizationin process_refs */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting ks to %d\n",k) ;
+#endif
+	      ks = k ;
+	    }
+	    ke = k ;
+#if 0
+fprintf(stderr,"resetting ke to %d\n",ke) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+         }
+        }
+      }
+        process_refs( &(procrec->pack_table),
+                      &(procrec->pack_table_size),
+                      &(procrec->pack_table_nbytes), 1 ) ;
+
+#if 0
+        fprintf(stderr,"pack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->pack_table,
+                         procrec->pack_table_size,
+                         procrec->pack_table_nbytes ) ;
+#endif
+
+        procrec->next = xp->procs[d][XPOSE_NZ_MN] ;
+        xp->procs[d][XPOSE_NZ_MN] = procrec ;
+    }
+
+/* unpacking loop */
+
+    ipack = 1 ;
+    for ( procrec = xp->procs[d][XPOSE_NZ_MN] ; procrec != NULL ; procrec = procrec->next )
+    {
+      P = procrec->P ;
+      init_process_refs() ;
+
+/***/ for ( jg = 0 ; jg < nlen ; jg++ )
+      {
+/***/   for ( ig = 0 ; ig < mlen ; ig++ ) 
+        {
+         recvP = domain_info[*d_p].domain[INDEX_2(jg,ig,mlen)].P ;
+          ks = 0                               ; ke = -1 ;
+          prevP = domain_info[*d_p].domain_nz[INDEX_2(0,jg,nlen)].P ;
+/***/     for ( kg = 0 ; kg < zlen ; kg++ )
+          {
+	    sendP = domain_info[*d_p].domain_nz[INDEX_2(kg,jg,nlen)].P ;
+	    if ( kg == zlen-1 ) 
+              { sendP = -1 ; ke++ ;}
+
+            i = ig - domain_info[d].ilocaloffset ;
+            j = jg - domain_info[d].jlocaloffset ;
+            k = kg ;
+
+	    if (sendP != prevP )
+	    {
+#if 0
+fprintf(stderr,"sendP (%2d) != prevP (%d) =? P (%d) ||  recvP (%d) =? rsl_myproc (%d)\n",
+sendP,prevP,P,recvP,rsl_myproc) ;
+#endif
+ 	      if ( rsl_c_comp2phys_proc(prevP) == P && recvP == rsl_myproc )
+	      {
+	        if ( kg > 0 )
+	        {
+	          /* store the pencil (i,ks:ke,jg) as being sent 
+	             from sendP and received by recvP */
+    
+                  fld = msg_to->fldspecs ;
+    
+                  for ( ; fld != NULL ;  fld = fld->next )
+                  {
+                    if ( fld->type >= 100 ) xp->has_f90_fields = 1 ;
+                    base = fld->base ;
+                    elemsz = fld->elemsz ;
+                    switch (fld->strategy)
+                    {
+                      case MINNS_MAJEW_K_3D :             /*  eg: ua(i,j,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d ks %2d ke %2d ke-ks+1 %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,ks,ke,ke-ks+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+j*t0+ks*t1)*elemsz, elemsz,
+                                                  ke-ks+1 ,
+                                                  -t1*elemsz) ;
+                        break ;
+                      case MINEW_MAJNS_K_3D :             /*  eg: u(j,i,k) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (j+i*t0+ks*t1)*elemsz, elemsz,
+                                                  ke-ks+1 ,
+                                                  -t1*elemsz) ;
+                        break ;
+                      case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+                        store_process_refs( base, fld->f90_table_index, (ks+i*t0+j*t1)*elemsz, (ke-ks+1)*elemsz,
+                                                  1, 
+						  -elemsz) ;
+                        break ;
+                      case MINNS_K_MAJEW_3D :             /*  eg: u(i,k,j) */
+                        t0 = fld->llen[0] ; t1 = fld->llen[1]*t0 ;
+#if 0
+if (1)fprintf(stderr,"MZ to MN s_p_rv: P %2d prevP %2d recvP %2d ipack %d i %2d j %2d k %2d ig %2d jg %2d t0 %3d t1 %3d ks %2d ke %2d ke-ks+1 %3d\n",
+P,prevP,recvP,ipack,i,j,k,ig,jg,t0,t1,ks,ke,ke-ks+1) ;
+#endif
+                        store_process_refs( base, fld->f90_table_index, (i+ks*t0+j*t1)*elemsz, elemsz,
+                                                  ke-ks+1,
+						  -t0*elemsz) ;   /* don't need to suppress optimizations unpacking onto MN grid because of pads */
+                        break ;
+                      default:
+                        RSL_TEST_ERR(1,"new pack comp: strategy not supported" ) ;
+                        break ;
+                    }
+                  }
+	        }
+	      }
+#if 0
+fprintf(stderr,"resetting ks to %d\n",k) ;
+#endif
+	      ks = k ;
+	    }
+	    ke = k ;
+#if 0
+fprintf(stderr,"resetting ke to %d\n",ke) ;
+#endif
+	    prevP = sendP ;
+#if 0
+fprintf(stderr,"resset prevP to %d\n",prevP) ;
+#endif
+          }
+        }
+      }
+        process_refs( &(procrec->unpack_table),
+                      &(procrec->unpack_table_size),
+                      &(procrec->unpack_table_nbytes), 1 ) ;
+#if 0
+        fprintf(stderr,"unpack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->unpack_table,
+                         procrec->unpack_table_size,
+                         procrec->unpack_table_nbytes ) ;
+#endif
+
+    }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/compat.h b/wrfv2_fire/external/RSL/RSL/compat.h
new file mode 100755
index 00000000..26b9814a
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/compat.h
@@ -0,0 +1,698 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef COMPAT_H
+#define COMPAT_H
+
+/* 
+   Note that when using these macros, you *HAVE* to leave a space
+   between the routine name and its argument list.  Example:
+
+	 RSL_C_COMPUTE_PROC (P)
+
+   This applies both to declaration and use from C.
+*/
+
+#ifndef T3D
+
+#  ifndef NOUNDERSCORE
+
+/********************************************* F2CSTYLE *****/
+#    ifdef F2CSTYLE
+
+#   define RSL_INITIALIZE		rsl_initialize__
+#   define RSL_INITIALIZE1		rsl_initialize1__
+#   define RSL_SHUTDOWN		rsl_shutdown__
+#   define RSL_MESH		rsl_mesh__
+#   define RSL_MOTHER_DOMAIN	rsl_mother_domain__
+#   define RSL_MOTHER_DOMAIN3D	rsl_mother_domain3d__
+#   define RSL_SPAWN_REGULAR_NEST	rsl_spawn_regular_nest__
+#   define RSL_SPAWN_REGULAR_NEST1	rsl_spawn_regular_nest1__
+#   define RSL_SPAWN_IRREG_NEST   rsl_spawn_irreg_nest__
+#   define RSL_GET_BDY_LPT        rsl_get_bdy_lpt__
+#   define RSL_GET_BDY_LARRAY     rsl_get_bdy_larray__
+#   define RSL_GET_BDY_LARRAY2     rsl_get_bdy_larray2__
+#   define RSL_GET_BDY_GPT        rsl_get_bdy_gpt__
+#   define RSL_GET_BDY_GARRAY     rsl_get_bdy_garray__
+#   define RSL_GET_BDY4_LPT       rsl_get_bdy4_lpt__
+#   define RSL_GET_BDY4_LARRAY    rsl_get_bdy4_larray__
+#   define RSL_GET_BDY4_GPT       rsl_get_bdy4_gpt__
+#   define RSL_GET_BDY4_GARRAY    rsl_get_bdy4_garray__
+#   define RSL_PATCH_DECOMPOSE	rsl_patch_decompose__
+#   define RSL_FDECOMPOSE	        rsl_fdecompose__
+#   define RSL_FCN_REMAP    	rsl_fcn_remap__
+#   define RSL_FCN_DECOMPOSE	rsl_fcn_decompose__
+#   define RSL_NEW_DECOMPOSITION	rsl_new_decomposition__
+#   define RSL_IAMMONITOR         rsl_iammonitor__
+#   define RSL_C_IAMMONITOR       rsl_c_iammonitor__
+#   define RSL_MONITOR_PROC       rsl_monitor_proc__
+#   define RSL_IAMCOMPUTE         rsl_iamcompute__
+#   define RSL_C_IAMCOMPUTE       rsl_c_iamcompute__
+#   define RSL_PHYS2COMP_C	rsl_phys2comp_c__
+#   define RSL_COMP2PHYS_C	rsl_comp2phys_c__
+#   define RSL_CREATE_STENCIL	rsl_create_stencil__
+#   define RSL_CREATE_XPOSE	rsl_create_xpose__
+#   define RSL_CREATE_MESSAGE     rsl_create_message__
+#   define RSL_BUILD_MESSAGE      rsl_build_message__
+#   define RSL_BLANK_MESSAGE      rsl_blank_message__
+#   define RSL_DESCRIBE_STENCIL   rsl_describe_stencil__
+#   define RSL_DESCRIBE_XPOSE   rsl_describe_xpose__
+#   define RSL_EXCH_STENCIL       rsl_exch_stencil__
+#   define RSL_COMPILE_STENCIL    rsl_compile_stencil__
+#   define RSL_INIT_NEXTCELL      rsl_init_nextcell__
+#   define RSL_INIT_GHOST         rsl_init_ghost__
+#   define RSL_C_NEXTCELL         rsl_c_nextcell__
+#   define RSL_READ               rsl_read__
+#   define RSL_WRITE              rsl_write__
+#   define RSL_IOSERVE            rsl_ioserve__
+#   define RSL_IO_SHUTDOWN        rsl_io_shutdown__
+#   define RSL_INIT_FORTRAN       rsl_init_fortran__
+#   define RSL_CLOSE              rsl_close__
+#   define SHOW_DOMAIN_DECOMP     show_domain_decomp__
+#   define READ_DOMAIN_DECOMP     read_domain_decomp__
+#   define GET_DOMAIN_DECOMP      get_domain_decomp__
+#   define SHOW_STEN_DIAGS        show_sten_diags__
+#   define SHOW_MESSAGE           show_message__
+#   define SHOW_STENCIL           show_stencil__
+
+#   define RSL_CREATE_PERIOD    rsl_create_period__
+#   define RSL_DESCRIBE_PERIOD   rsl_describe_period__
+#   define RSL_EXCH_PERIOD       rsl_exch_period__
+#   define RSL_COMPILE_PERIOD    rsl_compile_period__
+
+#   define FORT_COMPLEXREAD 	fort_complexread__
+#   define FORT_INTREAD 		fort_intread__
+#   define FORT_CHARACTERREAD 	fort_characterread__
+#   define FORT_DOUBLEREAD 	fort_doubleread__
+#   define FORT_REALREAD 		fort_realread__
+#   define FORT_COMPLEXWRITE 	fort_complexwrite__
+#   define FORT_INTWRITE 		fort_intwrite__
+#   define FORT_CHARACTERWRITE 	fort_characterwrite__
+#   define FORT_DOUBLEWRITE 	fort_doublewrite__
+#   define FORT_REALWRITE 	fort_realwrite__
+#   define FORT_CLOSE          	fort_close__
+
+#   define RSL_MM_BDY_IN          rsl_mm_bdy_in__
+#   define RSL_MM_DIST_BDY        rsl_mm_dist_bdy__
+#   define RSL_READ_REPL          rsl_read_repl__
+#   define RSL_READ_REPLW         rsl_read_replw__
+#   define FORT_BDYIN_REAL        fort_bdyin_real__
+#   define FORT_BDYIN_DBL         fort_bdyin_dbl__
+
+#   define RSL_F_SET_PADAREA      rsl_f_set_padarea__
+#   define RSL_SET_PADAREA        rsl_set_padarea__
+
+#   define RSL_TO_CHILD_INFO      rsl_to_child_info__
+#   define RSL_TO_CHILD_MSG       rsl_to_child_msg__
+#   define RSL_BCAST_MSGS         rsl_bcast_msgs__
+#   define RSL_FROM_PARENT_INFO   rsl_from_parent_info__
+#   define RSL_FROM_PARENT_MSG    rsl_from_parent_msg__
+
+#   define RSL_TO_PARENT_INFO     rsl_to_parent_info__
+#   define RSL_TO_PARENT_MSG      rsl_to_parent_msg__
+#   define RSL_TO_PARENT_MSGX     rsl_to_parent_msgx__
+#   define RSL_MERGE_MSGS         rsl_merge_msgs__
+#   define RSL_FROM_CHILD_INFO    rsl_from_child_info__
+#   define RSL_FROM_CHILD_MSG     rsl_from_child_msg__
+#   define RSL_FROM_CHILD_MSGX    rsl_from_child_msgx__
+
+#   define RSL_WITHIN_NESTED_BOUNDARY  rsl_within_nested_boundary__
+#   define RSL_WITHIN_NESTED_BETA  rsl_within_nested_beta__
+
+#   define RSL_NL                 rsl_nl__
+
+
+#   define RSL_FUNIT_CLOSE        rsl_funit_close__
+#   define RSL_ORDER              rsl_order__
+
+#   define RSL_DEBUG		rsl_debug__
+
+#   define RSL_MON_BCAST		rsl_mon_bcast__
+
+#  ifdef MPI
+#   define MPI_INIT_F             mpi_init_f__
+#  endif
+
+/* socket stuff */
+#   define RSL_SOCKOPEN           rsl_sockopen__
+#   define RSL_SOCKWRITE          rsl_sockwrite__
+#   define RSL_SOCKREAD           rsl_sockread_		/* not yet */
+#   define RSL_SOCKCLOSE          rsl_sockclose__
+
+/* slab stuff added 1/9/95 */
+#   define RSL_INIT_NEXTISLAB     rsl_init_nextislab__
+#   define RSL_C_NEXTISLAB        rsl_c_nextislab__
+
+#   define RSL_COMPUTE            rsl_compute__
+#   define RSL_GET_RUN_INFO       rsl_get_run_info__
+#   define RSL_GET_RUN_INFOP      rsl_get_run_infop__
+#   define RSL_REG_RUN_INFOP      rsl_reg_run_infop__
+#   define RSL_DYNPAD_7           rsl_dynpad_7__
+
+#   define RSL_CHILD_INFO         rsl_child_info__
+#   define RSL_CHILD_INFO1        rsl_child_info1__
+
+#   define RSL_REMAP_STATE        rsl_remap_state__
+#   define RSL_DESCRIBE_STATE     rsl_describe_state__
+
+#   define RSL_PATCH_DECOMP       rsl_patch_decomp__
+#   define SET_DEF_DECOMP_FCN     set_def_decomp_fcn__
+#   define SET_DEF_DECOMP_FCN1     set_def_decomp_fcn1__
+#   define SET_DEF_DECOMP_INFO     set_def_decomp_info__
+
+#   define BOUNDARY_SAFE		boundary_safe__
+
+#   define RSL_BDY_TIEBRK		rsl_bdy_tiebrk__
+
+#   define RSL_OLD_OFFSETS        rsl_old_offsets__
+
+#   define RSL_ERROR_DUP          rsl_error_dup__
+#   define RSL_ERROR_DUP1          rsl_error_dup1__
+
+#   define RSL_OUTPUT_BUFFER_WRITE rsl_output_buffer_write__
+#   define RSL_OUTPUT_BUFFER_YES   rsl_output_buffer_yes__
+#   define RSL_OUTPUT_BUFFER_NO   rsl_output_buffer_no__
+#   define RSL_IO_NODE_YES        rsl_io_node_yes__
+#   define RSL_IO_NODE_NO         rsl_io_node_no__
+#   define RSL_WRITE_MM5V3_SM_HEADER rsl_write_mm5v3_sm_header__
+#   define RSL_WRITE_MM5V3_BIG_HEADER rsl_write_mm5v3_big_header__
+#   define RSL_WRITE_1D_DATA     rsl_write_1d_data__
+
+#   define RSL_REGISTER_F90     rsl_register_f90__
+#   define RSL_REGISTER_F90_BASE_AND_SIZE     rsl_register_f90_base_and_size__
+#   define RSL_START_REGISTER_F90     rsl_start_register_f90__
+#   define RSL_END_REGISTER_F90     rsl_end_register_f90__
+
+#   define RSL_RESET_STAGING   rsl_reset_staging__
+
+#   define RSL_TO_OH_INFO    rsl_to_oh_info__
+#   define RSL_TO_OH_MSG     rsl_to_oh_msg__
+#   define RSL_FROM_TH_INFO  rsl_from_th_info__
+#   define RSL_FROM_TH_MSG   rsl_from_th_msg__
+#   define RSL_FORCE_HEMI    rsl_force_hemi__
+#   define RSL_POINT_ON_PROC    rsl_point_on_proc__
+#   define RSL_PROC_FOR_POINT    rsl_proc_for_point__
+
+#   define VRCOPY   vrcopy_
+
+#   define RSL_SET_REGULAR_DECOMP  rsl_set_regular_decomp__
+#   define RSL_ALLOW_DYNPAD  rsl_allow_dynpad__
+#   define RSL_GET_COMMUNICATOR    rsl_get_communicator__
+#   define RSL_SET_COMMUNICATOR    rsl_set_communicator__
+
+#   define RSL_XPOSE_MN_MZ     rsl_xpose_mn_mz__
+#   define RSL_XPOSE_MZ_MN     rsl_xpose_mz_mn__
+#   define RSL_XPOSE_MZ_NZ     rsl_xpose_mz_nz__
+#   define RSL_XPOSE_NZ_MZ     rsl_xpose_nz_mz__
+#   define RSL_XPOSE_NZ_MN     rsl_xpose_nz_mn__
+#   define RSL_XPOSE_MN_NZ     rsl_xpose_mn_nz__
+
+#   define RSL_REG_PATCHINFO_MN  rsl_reg_patchinfo_mn__
+#   define RSL_REG_PATCHINFO_MZ  rsl_reg_patchinfo_mz__
+#   define RSL_REG_PATCHINFO_NZ  rsl_reg_patchinfo_nz__
+
+#   define COLLECT_ON_COMM  collect_on_comm__
+#   define INT_PACK_DATA  int_pack_data__
+
+#   define GET_NEXT_DOMAIN_DESCRIPTOR get_next_domain_descriptor__
+#   define RSL_GET_GLEN rsl_get_glen__
+#   define RSL_REMAP_ARRAY rsl_remap_array__
+#   define RSL_MOVE_NEST rsl_move_nest__
+
+#   define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock__
+#   define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__
+
+#    else
+
+/********************************************* UNDERSCORE *****/
+
+#   define RSL_INITIALIZE		rsl_initialize_
+#   define RSL_INITIALIZE1		rsl_initialize1_
+#   define RSL_SHUTDOWN		rsl_shutdown_
+#   define RSL_MESH		rsl_mesh_
+#   define RSL_MOTHER_DOMAIN	rsl_mother_domain_
+#   define RSL_MOTHER_DOMAIN3D	rsl_mother_domain3d_
+#   define RSL_SPAWN_REGULAR_NEST	rsl_spawn_regular_nest_
+#   define RSL_SPAWN_REGULAR_NEST1	rsl_spawn_regular_nest1_
+#   define RSL_SPAWN_IRREG_NEST   rsl_spawn_irreg_nest_
+#   define RSL_GET_BDY_LPT        rsl_get_bdy_lpt_
+#   define RSL_GET_BDY_LARRAY     rsl_get_bdy_larray_
+#   define RSL_GET_BDY_LARRAY2     rsl_get_bdy_larray2_
+#   define RSL_GET_BDY_GPT        rsl_get_bdy_gpt_
+#   define RSL_GET_BDY_GARRAY     rsl_get_bdy_garray_
+#   define RSL_GET_BDY4_LPT       rsl_get_bdy4_lpt_
+#   define RSL_GET_BDY4_LARRAY    rsl_get_bdy4_larray_
+#   define RSL_GET_BDY4_GPT       rsl_get_bdy4_gpt_
+#   define RSL_GET_BDY4_GARRAY    rsl_get_bdy4_garray_
+#   define RSL_PATCH_DECOMPOSE	rsl_patch_decompose_
+#   define RSL_FDECOMPOSE	        rsl_fdecompose_
+#   define RSL_FCN_REMAP    	rsl_fcn_remap_
+#   define RSL_FCN_DECOMPOSE	rsl_fcn_decompose_
+#   define RSL_NEW_DECOMPOSITION	rsl_new_decomposition_
+#   define RSL_IAMMONITOR         rsl_iammonitor_
+#   define RSL_C_IAMMONITOR       rsl_c_iammonitor_
+#   define RSL_MONITOR_PROC       rsl_monitor_proc_
+#   define RSL_IAMCOMPUTE         rsl_iamcompute_
+#   define RSL_C_IAMCOMPUTE       rsl_c_iamcompute_
+#   define RSL_PHYS2COMP_C	rsl_phys2comp_c_
+#   define RSL_COMP2PHYS_C	rsl_comp2phys_c_
+#   define RSL_CREATE_STENCIL	rsl_create_stencil_
+#   define RSL_CREATE_XPOSE	rsl_create_xpose_
+#   define RSL_CREATE_MESSAGE     rsl_create_message_
+#   define RSL_BUILD_MESSAGE      rsl_build_message_
+#   define RSL_BLANK_MESSAGE      rsl_blank_message_
+#   define RSL_DESCRIBE_STENCIL   rsl_describe_stencil_
+#   define RSL_DESCRIBE_XPOSE   rsl_describe_xpose_
+#   define RSL_EXCH_STENCIL       rsl_exch_stencil_
+#   define RSL_COMPILE_STENCIL    rsl_compile_stencil_
+#   define RSL_INIT_NEXTCELL      rsl_init_nextcell_
+#   define RSL_INIT_GHOST         rsl_init_ghost_
+#   define RSL_C_NEXTCELL         rsl_c_nextcell_
+#   define RSL_READ               rsl_read_
+#   define RSL_WRITE              rsl_write_
+#   define RSL_IOSERVE            rsl_ioserve_
+#   define RSL_IO_SHUTDOWN        rsl_io_shutdown_
+#   define RSL_INIT_FORTRAN       rsl_init_fortran_
+#   define RSL_CLOSE              rsl_close_
+#   define SHOW_DOMAIN_DECOMP     show_domain_decomp_
+#   define READ_DOMAIN_DECOMP     read_domain_decomp_
+#   define GET_DOMAIN_DECOMP      get_domain_decomp_
+#   define SHOW_STEN_DIAGS        show_sten_diags_
+#   define SHOW_MESSAGE           show_message_
+#   define SHOW_STENCIL           show_stencil_
+
+#   define RSL_CREATE_PERIOD    rsl_create_period_
+#   define RSL_DESCRIBE_PERIOD   rsl_describe_period_
+#   define RSL_EXCH_PERIOD       rsl_exch_period_
+#   define RSL_COMPILE_PERIOD    rsl_compile_period_
+
+#   define FORT_COMPLEXREAD 	fort_complexread_
+#   define FORT_INTREAD 		fort_intread_
+#   define FORT_CHARACTERREAD 	fort_characterread_
+#   define FORT_DOUBLEREAD 	fort_doubleread_
+#   define FORT_REALREAD 		fort_realread_
+#   define FORT_COMPLEXWRITE 	fort_complexwrite_
+#   define FORT_INTWRITE 		fort_intwrite_
+#   define FORT_CHARACTERWRITE 	fort_characterwrite_
+#   define FORT_DOUBLEWRITE 	fort_doublewrite_
+#   define FORT_REALWRITE 	fort_realwrite_
+#   define FORT_CLOSE          	fort_close_
+
+#   define RSL_MM_BDY_IN          rsl_mm_bdy_in_
+#   define RSL_MM_DIST_BDY        rsl_mm_dist_bdy_
+#   define RSL_READ_REPL          rsl_read_repl_
+#   define RSL_READ_REPLW         rsl_read_replw_
+#   define FORT_BDYIN_REAL        fort_bdyin_real_
+#   define FORT_BDYIN_DBL         fort_bdyin_dbl_
+
+#   define RSL_F_SET_PADAREA      rsl_f_set_padarea_
+#   define RSL_SET_PADAREA        rsl_set_padarea_
+
+#   define RSL_TO_CHILD_INFO      rsl_to_child_info_
+#   define RSL_TO_CHILD_MSG       rsl_to_child_msg_
+#   define RSL_BCAST_MSGS         rsl_bcast_msgs_
+#   define RSL_FROM_PARENT_INFO   rsl_from_parent_info_
+#   define RSL_FROM_PARENT_MSG    rsl_from_parent_msg_
+
+#   define RSL_TO_PARENT_INFO     rsl_to_parent_info_
+#   define RSL_TO_PARENT_MSG      rsl_to_parent_msg_
+#   define RSL_TO_PARENT_MSGX     rsl_to_parent_msgx_
+#   define RSL_MERGE_MSGS         rsl_merge_msgs_
+#   define RSL_FROM_CHILD_INFO    rsl_from_child_info_
+#   define RSL_FROM_CHILD_MSG     rsl_from_child_msg_
+#   define RSL_FROM_CHILD_MSGX    rsl_from_child_msgx_
+
+#   define RSL_WITHIN_NESTED_BOUNDARY  rsl_within_nested_boundary_
+#   define RSL_WITHIN_NESTED_BETA  rsl_within_nested_beta_
+
+#   define RSL_NL                 rsl_nl_
+
+
+#   define RSL_FUNIT_CLOSE        rsl_funit_close_
+#   define RSL_ORDER              rsl_order_
+
+#   define RSL_DEBUG		rsl_debug_
+
+#   define RSL_MON_BCAST		rsl_mon_bcast_
+
+#  ifdef MPI
+#   define MPI_INIT_F             mpi_init_f_
+#  endif
+
+/* socket stuff */
+#   define RSL_SOCKOPEN           rsl_sockopen_
+#   define RSL_SOCKWRITE          rsl_sockwrite_
+#   define RSL_SOCKREAD           rsl_sockread_		/* not yet */
+#   define RSL_SOCKCLOSE          rsl_sockclose_
+
+/* slab stuff added 1/9/95 */
+#   define RSL_INIT_NEXTISLAB     rsl_init_nextislab_
+#   define RSL_C_NEXTISLAB        rsl_c_nextislab_
+
+#   define RSL_COMPUTE            rsl_compute_
+#   define RSL_GET_RUN_INFO       rsl_get_run_info_
+#   define RSL_GET_RUN_INFOP      rsl_get_run_infop_
+#   define RSL_REG_RUN_INFOP      rsl_reg_run_infop_
+#   define RSL_DYNPAD_7           rsl_dynpad_7_
+
+#   define RSL_CHILD_INFO         rsl_child_info_
+#   define RSL_CHILD_INFO1        rsl_child_info1_
+
+#   define RSL_REMAP_STATE        rsl_remap_state_
+#   define RSL_DESCRIBE_STATE     rsl_describe_state_
+
+#   define RSL_PATCH_DECOMP       rsl_patch_decomp_
+#   define SET_DEF_DECOMP_FCN     set_def_decomp_fcn_
+#   define SET_DEF_DECOMP_FCN1     set_def_decomp_fcn1_
+#   define SET_DEF_DECOMP_INFO     set_def_decomp_info_
+
+#   define BOUNDARY_SAFE		boundary_safe_
+
+#   define RSL_BDY_TIEBRK		rsl_bdy_tiebrk_
+
+#   define RSL_OLD_OFFSETS        rsl_old_offsets_
+
+#   define RSL_ERROR_DUP          rsl_error_dup_
+#   define RSL_ERROR_DUP1          rsl_error_dup1_
+
+#   define RSL_OUTPUT_BUFFER_WRITE rsl_output_buffer_write_
+#   define RSL_OUTPUT_BUFFER_YES   rsl_output_buffer_yes_
+#   define RSL_OUTPUT_BUFFER_NO   rsl_output_buffer_no_
+#   define RSL_IO_NODE_YES        rsl_io_node_yes_
+#   define RSL_IO_NODE_NO         rsl_io_node_no_
+#   define RSL_WRITE_MM5V3_SM_HEADER rsl_write_mm5v3_sm_header_
+#   define RSL_WRITE_MM5V3_BIG_HEADER rsl_write_mm5v3_big_header_
+#   define RSL_WRITE_1D_DATA     rsl_write_1d_data_
+
+#   define RSL_REGISTER_F90     rsl_register_f90_
+#   define RSL_START_REGISTER_F90     rsl_start_register_f90_
+#   define RSL_REGISTER_F90_BASE_AND_SIZE     rsl_register_f90_base_and_size_
+#   define RSL_END_REGISTER_F90     rsl_end_register_f90_
+
+#   define RSL_RESET_STAGING   rsl_reset_staging_
+
+#   define RSL_TO_OH_INFO    rsl_to_oh_info_
+#   define RSL_TO_OH_MSG     rsl_to_oh_msg_
+#   define RSL_FROM_TH_INFO  rsl_from_th_info_
+#   define RSL_FROM_TH_MSG   rsl_from_th_msg_
+#   define RSL_FORCE_HEMI    rsl_force_hemi_
+#   define RSL_POINT_ON_PROC    rsl_point_on_proc_
+#   define RSL_PROC_FOR_POINT    rsl_proc_for_point_
+
+#   define VRCOPY   vrcopy_
+
+#   define RSL_SET_REGULAR_DECOMP  rsl_set_regular_decomp_
+#   define RSL_ALLOW_DYNPAD  rsl_allow_dynpad_
+
+#   define RSL_GET_COMMUNICATOR    rsl_get_communicator_
+#   define RSL_SET_COMMUNICATOR    rsl_set_communicator_
+
+#   define RSL_XPOSE_MN_MZ     rsl_xpose_mn_mz_
+#   define RSL_XPOSE_MZ_MN     rsl_xpose_mz_mn_
+#   define RSL_XPOSE_MZ_NZ     rsl_xpose_mz_nz_
+#   define RSL_XPOSE_NZ_MZ     rsl_xpose_nz_mz_
+#   define RSL_XPOSE_NZ_MN     rsl_xpose_nz_mn_
+#   define RSL_XPOSE_MN_NZ     rsl_xpose_mn_nz_
+
+#   define RSL_REG_PATCHINFO_MN  rsl_reg_patchinfo_mn_
+#   define RSL_REG_PATCHINFO_MZ  rsl_reg_patchinfo_mz_
+#   define RSL_REG_PATCHINFO_NZ  rsl_reg_patchinfo_nz_
+
+#   define COLLECT_ON_COMM  collect_on_comm_
+#   define INT_PACK_DATA  int_pack_data_
+
+#   define GET_NEXT_DOMAIN_DESCRIPTOR get_next_domain_descriptor_
+#   define RSL_GET_GLEN rsl_get_glen_
+#   define RSL_REMAP_ARRAY rsl_remap_array_
+#   define RSL_MOVE_NEST rsl_move_nest_
+
+#   define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock_
+#   define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_
+
+#    endif
+
+#  else
+
+/********************************************* NOUNDERSCORE ***/
+
+#   define RSL_INITIALIZE		rsl_initialize
+#   define RSL_INITIALIZE1		rsl_initialize1
+#   define RSL_SHUTDOWN		rsl_shutdown
+#   define RSL_MESH		rsl_mesh
+#   define RSL_MOTHER_DOMAIN	rsl_mother_domain
+#   define RSL_MOTHER_DOMAIN3D	rsl_mother_domain3d
+#   define RSL_SPAWN_REGULAR_NEST	rsl_spawn_regular_nest
+#   define RSL_SPAWN_REGULAR_NEST1	rsl_spawn_regular_nest1
+#   define RSL_SPAWN_IRREG_NEST   rsl_spawn_irreg_nest
+#   define RSL_GET_BDY_LPT        rsl_get_bdy_lpt
+#   define RSL_GET_BDY_LARRAY     rsl_get_bdy_larray
+#   define RSL_GET_BDY_LARRAY2     rsl_get_bdy_larray2
+#   define RSL_GET_BDY_GPT        rsl_get_bdy_gpt
+#   define RSL_GET_BDY_GARRAY     rsl_get_bdy_garray
+#   define RSL_GET_BDY4_LPT        rsl_get_bdy4_lpt
+#   define RSL_GET_BDY4_LARRAY     rsl_get_bdy4_larray
+#   define RSL_GET_BDY4_GPT        rsl_get_bdy4_gpt
+#   define RSL_GET_BDY4_GARRAY     rsl_get_bdy4_garray
+#   define RSL_PATCH_DECOMPOSE	rsl_patch_decompose
+#   define RSL_FDECOMPOSE	        rsl_fdecompose
+#   define RSL_FCN_REMAP    	rsl_fcn_remap
+#   define RSL_FCN_DECOMPOSE	rsl_fcn_decompose
+#   define RSL_NEW_DECOMPOSITION	rsl_new_decomposition
+#   define RSL_IAMMONITOR         rsl_iammonitor
+#   define RSL_C_IAMMONITOR       rsl_c_iammonitor
+#   define RSL_MONITOR_PROC       rsl_monitor_proc
+#   define RSL_IAMCOMPUTE         rsl_iamcompute
+#   define RSL_C_IAMCOMPUTE       rsl_c_iamcompute
+#   define RSL_PHYS2COMP_C	rsl_phys2comp_c
+#   define RSL_COMP2PHYS_C	rsl_comp2phys_c
+#   define RSL_CREATE_STENCIL	rsl_create_stencil
+#   define RSL_CREATE_XPOSE	rsl_create_xpose
+#   define RSL_CREATE_MESSAGE     rsl_create_message
+#   define RSL_BUILD_MESSAGE      rsl_build_message
+#   define RSL_BLANK_MESSAGE      rsl_blank_message
+#   define RSL_DESCRIBE_STENCIL   rsl_describe_stencil
+#   define RSL_DESCRIBE_XPOSE   rsl_describe_xpose
+#   define RSL_EXCH_STENCIL       rsl_exch_stencil
+#   define RSL_COMPILE_STENCIL    rsl_compile_stencil
+#   define RSL_INIT_NEXTCELL      rsl_init_nextcell
+#   define RSL_INIT_GHOST         rsl_init_ghost
+#   define RSL_C_NEXTCELL         rsl_c_nextcell
+#   define RSL_READ               rsl_read
+#   define RSL_WRITE              rsl_write
+#   define RSL_IOSERVE            rsl_ioserve
+#   define RSL_IO_SHUTDOWN        rsl_io_shutdown
+#   define RSL_INIT_FORTRAN       rsl_init_fortran
+#   define RSL_CLOSE              rsl_close
+#   define SHOW_DOMAIN_DECOMP     show_domain_decomp
+#   define READ_DOMAIN_DECOMP     read_domain_decomp
+#   define GET_DOMAIN_DECOMP      get_domain_decomp
+#   define SHOW_STEN_DIAGS        show_sten_diags
+#   define SHOW_MESSAGE           show_message
+#   define SHOW_STENCIL           show_stencil
+
+#   define RSL_CREATE_PERIOD    rsl_create_period
+#   define RSL_DESCRIBE_PERIOD   rsl_describe_period
+#   define RSL_EXCH_PERIOD       rsl_exch_period
+#   define RSL_COMPILE_PERIOD    rsl_compile_period
+
+#   define FORT_COMPLEXREAD 	fort_complexread
+#   define FORT_INTREAD 		fort_intread
+#   define FORT_CHARACTERREAD 	fort_characterread
+#   define FORT_DOUBLEREAD 	fort_doubleread
+#   define FORT_REALREAD 		fort_realread
+#   define FORT_COMPLEXWRITE 	fort_complexwrite
+#   define FORT_INTWRITE 		fort_intwrite
+#   define FORT_CHARACTERWRITE 	fort_characterwrite
+#   define FORT_DOUBLEWRITE 	fort_doublewrite
+#   define FORT_REALWRITE 	fort_realwrite
+#   define FORT_CLOSE   	 	fort_close
+
+#   define RSL_MM_BDY_IN          rsl_mm_bdy_in
+#   define RSL_MM_DIST_BDY        rsl_mm_dist_bdy
+#   define RSL_READ_REPL          rsl_read_repl
+#   define RSL_READ_REPLW         rsl_read_replw
+#   define FORT_BDYIN_REAL        fort_bdyin_real
+#   define FORT_BDYIN_DBL         fort_bdyin_dbl
+
+#   define RSL_F_SET_PADAREA      rsl_f_set_padarea
+#   define RSL_SET_PADAREA        rsl_set_padarea
+
+#   define RSL_TO_CHILD_INFO      rsl_to_child_info
+#   define RSL_TO_CHILD_MSG       rsl_to_child_msg
+#   define RSL_BCAST_MSGS         rsl_bcast_msgs
+#   define RSL_FROM_PARENT_INFO   rsl_from_parent_info
+#   define RSL_FROM_PARENT_MSG    rsl_from_parent_msg
+
+#   define RSL_TO_PARENT_INFO     rsl_to_parent_info
+#   define RSL_TO_PARENT_MSG      rsl_to_parent_msg
+#   define RSL_TO_PARENT_MSGX     rsl_to_parent_msgx
+#   define RSL_MERGE_MSGS         rsl_merge_msgs
+#   define RSL_FROM_CHILD_INFO    rsl_from_child_info
+#   define RSL_FROM_CHILD_MSG     rsl_from_child_msg
+#   define RSL_FROM_CHILD_MSGX    rsl_from_child_msgx
+
+#   define RSL_WITHIN_NESTED_BOUNDARY  rsl_within_nested_boundary
+#   define RSL_WITHIN_NESTED_BETA  rsl_within_nested_beta
+
+#   define RSL_NL                 rsl_nl
+
+#   define RSL_FUNIT_CLOSE        rsl_funit_close
+#   define RSL_ORDER              rsl_order
+
+#   define RSL_DEBUG		rsl_debug
+
+#   define RSL_MON_BCAST		rsl_mon_bcast
+
+#  ifdef MPI
+#   define MPI_INIT_F             mpi_init_f
+#  endif
+
+/* socket stuff */
+#   define RSL_SOCKOPEN           rsl_sockopen
+#   define RSL_SOCKWRITE          rsl_sockwrite
+#   define RSL_SOCKREAD           rsl_sockread		/* not yet */
+#   define RSL_SOCKCLOSE          rsl_sockclose
+
+/* slab stuff added 1/9/95 */
+#   define RSL_INIT_NEXTISLAB     rsl_init_nextislab
+#   define RSL_C_NEXTISLAB        rsl_c_nextislab
+
+#   define RSL_COMPUTE            rsl_compute
+#   define RSL_GET_RUN_INFO       rsl_get_run_info
+#   define RSL_GET_RUN_INFOP      rsl_get_run_infop
+#   define RSL_REG_RUN_INFOP      rsl_reg_run_infop
+#   define RSL_DYNPAD_7           rsl_dynpad_7
+
+#   define RSL_CHILD_INFO         rsl_child_info
+#   define RSL_CHILD_INFO1        rsl_child_info1
+
+#   define RSL_REMAP_STATE        rsl_remap_state
+#   define RSL_DESCRIBE_STATE     rsl_describe_state
+
+#   define RSL_PATCH_DECOMP       rsl_patch_decomp
+#   define SET_DEF_DECOMP_FCN     set_def_decomp_fcn
+#   define SET_DEF_DECOMP_FCN1     set_def_decomp_fcn1
+#   define SET_DEF_DECOMP_INFO     set_def_decomp_info
+
+#   define BOUNDARY_SAFE		boundary_safe
+
+#   define RSL_BDY_TIEBRK		rsl_bdy_tiebrk
+
+#   define RSL_OLD_OFFSETS        rsl_old_offsets
+
+#   define RSL_ERROR_DUP          rsl_error_dup
+#   define RSL_ERROR_DUP1          rsl_error_dup1
+
+#   define RSL_OUTPUT_BUFFER_WRITE rsl_output_buffer_write
+#   define RSL_OUTPUT_BUFFER_YES   rsl_output_buffer_yes
+#   define RSL_OUTPUT_BUFFER_NO   rsl_output_buffer_no
+#   define RSL_IO_NODE_YES        rsl_io_node_yes
+#   define RSL_IO_NODE_NO         rsl_io_node_no
+#   define RSL_WRITE_MM5V3_SM_HEADER rsl_write_mm5v3_sm_header
+#   define RSL_WRITE_MM5V3_BIG_HEADER rsl_write_mm5v3_big_header
+#   define RSL_WRITE_1D_DATA     rsl_write_1d_data
+
+#   define RSL_REGISTER_F90     rsl_register_f90
+#   define RSL_START_REGISTER_F90     rsl_start_register_f90
+#   define RSL_REGISTER_F90_BASE_AND_SIZE     rsl_register_f90_base_and_size
+#   define RSL_END_REGISTER_F90     rsl_end_register_f90
+
+#   define RSL_RESET_STAGING   rsl_reset_staging
+
+#   define RSL_TO_OH_INFO    rsl_to_oh_info
+#   define RSL_TO_OH_MSG     rsl_to_oh_msg
+#   define RSL_FROM_TH_INFO  rsl_from_th_info
+#   define RSL_FROM_TH_MSG   rsl_from_th_msg
+#   define RSL_FORCE_HEMI    rsl_force_hemi
+#   define RSL_POINT_ON_PROC    rsl_point_on_proc
+#   define RSL_PROC_FOR_POINT    rsl_proc_for_point
+
+#   define VRCOPY   vrcopy
+
+#   define RSL_SET_REGULAR_DECOMP  rsl_set_regular_decomp
+#   define RSL_ALLOW_DYNPAD  rsl_allow_dynpad
+
+#   define RSL_GET_COMMUNICATOR    rsl_get_communicator
+#   define RSL_SET_COMMUNICATOR    rsl_set_communicator
+
+#   define RSL_XPOSE_MN_MZ     rsl_xpose_mn_mz
+#   define RSL_XPOSE_MZ_MN     rsl_xpose_mz_mn
+#   define RSL_XPOSE_MZ_NZ     rsl_xpose_mz_nz
+#   define RSL_XPOSE_NZ_MZ     rsl_xpose_nz_mz
+#   define RSL_XPOSE_NZ_MN     rsl_xpose_nz_mn
+#   define RSL_XPOSE_MN_NZ     rsl_xpose_mn_nz
+
+#   define RSL_REG_PATCHINFO_MN  rsl_reg_patchinfo_mn
+#   define RSL_REG_PATCHINFO_MZ  rsl_reg_patchinfo_mz
+#   define RSL_REG_PATCHINFO_NZ  rsl_reg_patchinfo_nz
+
+#   define COLLECT_ON_COMM  collect_on_comm
+#   define INT_PACK_DATA  int_pack_data
+
+#   define GET_NEXT_DOMAIN_DESCRIPTOR get_next_domain_descriptor
+#   define RSL_GET_GLEN rsl_get_glen
+#   define RSL_REMAP_ARRAY rsl_remap_array
+#   define RSL_MOVE_NEST rsl_move_nest
+
+#   define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock
+#   define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock
+
+#  endif
+#endif
+
+#endif /* nothing after this */
diff --git a/wrfv2_fire/external/RSL/RSL/debug.c b/wrfv2_fire/external/RSL/RSL/debug.c
new file mode 100755
index 00000000..50e26e6f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/debug.c
@@ -0,0 +1,411 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/*
+ * debug.c
+ *
+ * Various debugging things, including malloc debugging stuff
+ */
+
+dumdebug(j)
+{
+  return ;
+}
+
+/* #define NEXUS_MALLOC_DEBUG */
+#ifdef NEXUS_MALLOC_DEBUG
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+/*
+ * Memory allocation debugging and diagnostics code.
+ */
+
+#define NEXUS_MALLOC_PAD 512
+#define NEXUS_N_MALLOC_RECS 20000
+
+typedef struct _malloc_rec_t
+{
+    char *addr;
+    char *file;
+    char *free_file;
+    int size;
+#ifdef crayx1
+    int line;
+    int free_line;
+    int freed;
+#else
+    short line;
+    short free_line;
+    short freed;
+#endif
+} *malloc_rec_t;
+
+static struct _malloc_rec_t malloc_recs[NEXUS_N_MALLOC_RECS];
+static int next_malloc_rec = 0;
+
+static char last_successful_file[1024];
+static int last_successful_line;
+
+static int initialized = 0;
+
+
+#define START_MAGIC 0xf00dface
+#define END_MAGIC 0xeeaaddff
+
+/*
+ * nexus_debug_malloc()
+ *
+ * Malloc wrapper that can print out the size and location
+ * of allocations when the -Dmalloc argument has been given.
+ *
+ * The intent is to define a macro of the form
+ *
+ *	#ifdef NEXUS_DEBUG
+ *	#define malloc(size) nexus_debug_malloc(size, __FILE__, __LINE__)
+ *	#endif
+ *
+ * in order to trace memory allocation in detail.
+ * 
+ */
+void *nexus_debug_malloc(int size, char *file, int line)
+{
+    void *rc, *addr;
+    malloc_rec_t rec;
+    int *p;
+
+	nexus_debug_malloc_check(file, line);
+	
+	while ((size & 0x07) != 0)
+	    size++;
+	
+	if (next_malloc_rec >= NEXUS_N_MALLOC_RECS)
+	{
+	    fprintf(stderr,"Too many malloc recs\n");
+	    rc = malloc(size);
+	}
+	else
+	{
+	    rec = &malloc_recs[next_malloc_rec];
+	    
+	    addr = malloc(size + 2 * NEXUS_MALLOC_PAD);
+	    rc = (char *) addr + NEXUS_MALLOC_PAD;
+	    bzero( rc, size ) ; 	/* zero storage */
+	    if (0 )
+	    {
+		printf("malloc(%d) at %s:%d returns %x idx=%d\n",
+			    size, file, line, rc, next_malloc_rec);
+	    }
+	    
+	    rec->addr = addr;
+	    rec->file = file;
+	    rec->line = line;
+	    rec->size = size;
+	    rec->free_file = (char *) NULL;
+	    rec->free_line = -1;
+	    rec->freed = 0;
+
+	    if (NEXUS_MALLOC_PAD >= 4)
+	    {
+		*((int *) addr) = next_malloc_rec;
+	    
+		for (p = (int *) addr + 1; p < (int *) rc; p++)
+		{
+		    *p = START_MAGIC;
+		}
+		for (p = (int *) ((char *) addr + size + NEXUS_MALLOC_PAD);
+		     p < (int *) ((char *) addr + size + 2 * NEXUS_MALLOC_PAD); p++)
+		{
+		    *p = END_MAGIC;
+		}
+	    }
+
+	    next_malloc_rec++;
+	}
+
+    return rc;
+} /* nexus_debug_malloc() */
+
+
+/*
+ * nexus_debug_malloc_check()
+ *
+ * Walk the list of allocated blocks looking for munged memory.
+ */
+nexus_debug_malloc_check(char *file, int line)
+{
+    int i;
+    malloc_rec_t rec;
+    int *p;
+
+    if (NEXUS_MALLOC_PAD < 4)
+	return;
+
+    for (i = 0; i < next_malloc_rec; i++)
+    {
+	rec = &malloc_recs[i];
+
+	if (rec->freed)
+	    continue;
+
+	if (*((int *) rec->addr) != i)
+	{
+	    fprintf(stderr,"Malloc check (start) failed for idx %d at %s:%d for allocation at %s:%d of size %d. Last successful check was %s:%d\n",
+			i,
+			file, line,
+			rec->file, rec->line,
+			rec->size,
+			last_successful_file,
+			last_successful_line);
+	    exit(2) ;
+	}
+
+	for (p = (int *) rec->addr + 1; p < (int *) ((char *) rec->addr + NEXUS_MALLOC_PAD); p++)
+	{
+	    if (*p != START_MAGIC)
+	    {
+	    fprintf(stderr,"Malloc check (start) failed for idx %d at %s:%d for allocation at %s:%d of size %d Last successful check was %s:%d\n",
+			    i,
+			    file, line,
+			    rec->file, rec->line,
+			    rec->size,
+			    last_successful_file,
+			    last_successful_line);
+	    exit(2) ;
+	    }
+	}
+	
+	for (p = (int *) ((char *) rec->addr + rec->size + NEXUS_MALLOC_PAD);
+	     p < (int *) ((char *) rec->addr + rec->size + 2 * NEXUS_MALLOC_PAD); p++)
+	{
+	    if (*p != END_MAGIC)
+	    {
+	    fprintf(stderr,"Malloc check (end) failed for idx %d at %s:%d for allocation at %s:%d of size %d Last successful check was %s:%d\n",
+			    i,
+			    file, line,
+			    rec->file, rec->line,
+			    rec->size,
+			    last_successful_file,
+			    last_successful_line);
+	    exit(2) ;
+	    }
+	}
+    }
+    strcpy(last_successful_file, file);
+    last_successful_line = line;
+} /* nexus_debug_malloc_check() */
+
+void nexus_debug_mem_check(int size, void *address)
+{
+    int i;
+    malloc_rec_t rec;
+    char *pad1_start, *pad1_end, *pad2_start, *pad2_end, *a_start, *a_end;
+
+    for (i = 0; i < next_malloc_rec; i++)
+    {
+	rec = &malloc_recs[i];
+
+	if (rec->freed)
+	    continue;
+
+	pad1_start = rec->addr;
+	pad1_end = pad1_start + NEXUS_MALLOC_PAD;
+
+	pad2_start = rec->addr + rec->size + NEXUS_MALLOC_PAD;
+	pad2_end = pad2_start + NEXUS_MALLOC_PAD;
+
+	a_start = address;
+	a_end = a_start + size - 1;
+
+	if ((a_start >= pad1_start && a_start < pad1_end) ||
+	    (a_end >= pad1_start && a_end < pad1_end) ||
+	    (a_start >= pad2_start && a_start < pad2_end) ||
+	    (a_end >= pad2_start && a_end < pad2_end) ||
+	    (a_start < pad1_start && a_end > pad1_end) ||
+	    (a_start < pad2_start && a_end > pad2_end))
+	{
+	    fprintf(stderr,"Malloc memory check for address %x length %s failed for idx %d for allocation at %s:%d of size %d.\n",
+			address,
+			size,
+			i,
+			rec->file, rec->line,
+			rec->size);
+	    exit(2) ;
+	}
+    }
+} /* nexus_debug_mem_check() */
+
+
+/*
+ * nexus_debug_show_freed_blocks()
+ *
+ * Walk the list of allocated blocks looking blocks that
+ * were never freed.
+ */
+void nexus_debug_show_freed_blocks()
+{
+    int i;
+    malloc_rec_t rec;
+
+    for (i = 0; i < next_malloc_rec; i++)
+    {
+	rec = &malloc_recs[i];
+
+	if (!rec->freed)
+	{
+	    fprintf(stderr,"Unfreed block %d size=%5d at %s:%d\n",
+			i, rec->size, rec->file, rec->line);
+	}
+    }
+} /* nexus_debug_show_freed_blocks() */
+
+
+/*
+ * nexus_debug_show_malloc_stats()
+ *
+ * Print a summary of memory allocation statistics.
+ */
+void nexus_debug_show_malloc_stats()
+{
+    int i;
+    malloc_rec_t rec;
+    int bytes, bytes_freed;
+    int n_blocks_freed;
+
+    bytes = bytes_freed = n_blocks_freed = 0;
+
+    for (i = 0; i < next_malloc_rec; i++)
+    {
+	rec = &malloc_recs[i];
+
+	bytes += rec->size;
+
+	if (rec->freed)
+	{
+	    bytes_freed += rec->size;
+	    n_blocks_freed++;
+	}
+    }
+
+    fprintf(stderr,"Malloc statistics:\n");
+    fprintf(stderr,"\tbytes allocated:  %d\n", bytes);
+    fprintf(stderr,"\tbytes freed:      %d\n", bytes_freed);
+    fprintf(stderr,"\tbytes unfreed:    %d\n", bytes - bytes_freed);
+    fprintf(stderr,"\tblocks allocated: %d\n", next_malloc_rec);
+    fprintf(stderr,"\tblocks freed:     %d\n", n_blocks_freed);
+    fprintf(stderr,"\tblocks unfreed:   %d\n", next_malloc_rec - n_blocks_freed);
+} /* nexus_debug_show_malloc_stats() */
+
+
+/*
+ * nexus_debug_free()
+ */
+void nexus_debug_free(void *ptr, char *file, int line)
+{
+    void *addr;
+    int idx;
+
+	malloc_rec_t rec;
+
+	if (NEXUS_MALLOC_PAD >= 4)
+	{
+	    addr = (char *) ptr - NEXUS_MALLOC_PAD;
+	
+	    idx = *((int *) addr);
+
+	    if ( idx < 0 || idx >= NEXUS_N_MALLOC_RECS )
+	    {
+fprintf(stderr,"nexus_debug_free(): bad idx = %d; \n  possibly corrupt ptr %08x at %s line %d\n",
+idx, ptr, file, line ) ;
+	    }
+
+	    rec = &(malloc_recs[idx]);
+
+	    if (rec->freed == 1 )
+	    {
+		fprintf(stderr,"nexus_debug_free(): block %x idx %d allocated at %s:%d was freed twice at %s:%d and %s:%d\n",
+			    ptr, idx,
+			    rec->file, rec->line,
+			    rec->free_file, rec->free_line,
+			    file, line);
+		exit(2) ;
+	    }
+	
+	    rec->freed = 1;
+	    rec->free_file = file;
+	    rec->free_line = line;
+	    free(addr);
+	}
+	else
+	{
+	    idx = -1;
+	    free(ptr);
+	}
+	if (0)
+	{
+	    nexus_printf("free(%x) at %s:%d index=%d\n",
+			ptr, file, line, idx);
+	}
+} /* nexus_debug_free() */
+
+
+
+#endif /* NEXUS_DEBUG */
+
diff --git a/wrfv2_fire/external/RSL/RSL/decomp.c b/wrfv2_fire/external/RSL/RSL/decomp.c
new file mode 100755
index 00000000..ccd610a6
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/decomp.c
@@ -0,0 +1,551 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#define DEFINE_GLOBAL
+
+#include 
+#include 
+#include "rsl.h"
+
+rsl_list_t *point_move_receives[ RSL_MAXPROC ] ;
+rsl_list_t *point_move_sends[ RSL_MAXPROC ] ;
+
+/*@
+  RSL_FDECOMPOSE Decompose domain using user-supplied function.
+
+  Notes:
+  This routine decomposes the a domain using a function provided
+  by the user.  The prototypical mapping function is described below.
+
+  Mapping function:
+  The user-supplied function for decomposing the domain should have
+  the following form.
+
+  Verbatim:
+$  INTEGER FUNCTION MAPPING ( in, out, info_p, m, n, py, px )
+BREAKTHEEXAMPLECODE
+
+  In and out are m by n integer arrays.  Each element of the in array is
+  set to RSL_VALID for valid points in the domain or RSL_INVALID if the
+  point is not considered to be part of the domain and therefore not
+  to be allocated to a processor (as might be the case if extra memory
+  is allocated but not used).  The function generates an out array
+  such that every point that was RSL_VALID in the in array is given
+  a processor number between 0 (zero) and py times px minus 1.  Integers
+  m and n are the in and out array dimensions; integer py is the number
+  of processors decomposing m; integer px is the number of processors
+  decomposing n.
+
+@*/
+
+RSL_FDECOMPOSE (d_p,fcn,py_p,px_p,info_p,mloc_p,nloc_p,zloc_p,
+                                         mloc_mz_p,nloc_mz_p,zloc_mz_p,
+                                         mloc_nz_p,nloc_nz_p,zloc_nz_p )
+  int_p
+    d_p  ;      /* (I) domain descriptor */
+  int 
+   (*fcn)() ;   /* (I) decomposition function */
+  int_p
+    py_p        /* (I) number of processors in y dimension */
+   ,px_p        /* (I) number of processors in x dimension */
+   ,info_p	     /* (I) extra argument, passed as-is to fcn */
+   ,mloc_p      /* (O) minimum m size of local array on this processor */
+   ,nloc_p      /* (O) minimum n size of local array on this processor */
+   ,zloc_p      /* (O) minimum n size of local array on this processor */
+   ,mloc_mz_p   /* (O) minimum m size of local array on this processor */
+   ,nloc_mz_p   /* (O) minimum n size of local array on this processor */
+   ,zloc_mz_p   /* (O) minimum n size of local array on this processor */
+   ,mloc_nz_p   /* (O) minimum m size of local array on this processor */
+   ,nloc_nz_p   /* (O) minimum n size of local array on this processor */
+   ,zloc_nz_p   /* (O) minimum n size of local array on this processor */
+   ;
+{
+
+  int d, nest, state, mlen, nlen, zlen, i, j, k, m, n, z, px, py, px1, py1 ;
+  int result ;
+  int mom ;
+  int kn, km, kp, np ;
+  int was_decomposed ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *domain, *ndomain, *p ;
+  rsl_child_info_t *moms_kids, *my_kids ;
+  int *wrk1, *wrk2 ;
+  rsl_list_t *lp ;
+  int P, my_P ;
+  int l, h, lz, hiz ;
+  int retval ;
+
+  retval = 0 ;
+  d = *d_p ;
+  px = *px_p ;
+  py = *py_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, 
+                "rsl_fdecompose: bad domain descriptor" ) ;
+  dinfo = &( domain_info[d] ) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+                "rsl_fdecompose: invalid domain descriptor" ) ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  zlen = dinfo->len_z ;
+
+/* set the ones that aren't decomposed */
+  *zloc_p = zlen ;
+  *nloc_mz_p = nlen + 2 * rsl_padarea ;
+  *mloc_nz_p = mlen + 2 * rsl_padarea ;
+
+  if ( zlen > 1 ) {
+/* figure out MZ decomp: added 20010222 -- for 3d decomposition for xposes */
+    wrk1 = RSL_MALLOC( int, mlen * zlen ) ;
+    wrk2 = RSL_MALLOC( int, mlen * zlen ) ;
+    domain = dinfo->domain_mz ;
+
+  /* load up input work array with valid points */
+    for ( k = 0 ; k < zlen ; k++ )
+      for ( i = 0 ; i < mlen ; i++ )
+      {
+        if ( domain[ INDEX_2(k,i,mlen) ].valid == RSL_VALID )
+          wrk1[INDEX_2(k,i,mlen)] = RSL_VALID ;
+        else
+          wrk1[INDEX_2(k,i,mlen)] = RSL_INVALID ;
+      }
+
+    m = mlen ; z = zlen ; px1 = px ; py1 = py ;  /* protect variables */
+    result = rsl_default_decomp( wrk1, wrk2, info_p, &m, &z, &px1, &py1 ) ;
+
+    if ( ! result )
+    {
+      /* set the processor numbers of the valid points */
+      l = -1 ; h = -1 ; lz = -1 ; hiz = -1 ;
+      for ( k = 0 ; k < zlen ; k++ ) {
+        for ( i = 0 ; i < mlen ; i++ ) {
+          p = &(domain[ INDEX_2(k,i,mlen) ]) ;
+	  p->valid = RSL_VALID ;
+          p->P = wrk2[INDEX_2(k,i,mlen)] ;
+          if ( rsl_c_comp2phys_proc(p->P) == rsl_myproc ) {
+	    if ( l == -1 ) l = i ;
+	    h = i ;
+	    if ( lz == -1 ) lz = k ;
+	    hiz = k ;
+          }
+        }
+      }
+      *mloc_mz_p = h-l+1 + 2 * rsl_padarea ;
+      *zloc_mz_p = hiz-lz+1 ;
+    }
+
+    RSL_FREE( wrk1 ) ;
+    RSL_FREE( wrk2 ) ;
+
+/* figure out NZ decomp: added 20010222 -- for 3d decomposition for xposes */
+    wrk1 = RSL_MALLOC( int, nlen * zlen ) ;
+    wrk2 = RSL_MALLOC( int, nlen * zlen ) ;
+    domain = dinfo->domain_nz ;
+
+  /* load up input work array with valid points */
+    for ( k = 0 ; k < zlen ; k++ )
+      for ( j = 0 ; j < nlen ; j++ )
+      {
+        if ( domain[ INDEX_2(k,j,nlen) ].valid == RSL_VALID )
+          wrk1[INDEX_2(k,j,nlen)] = RSL_VALID ;
+        else
+          wrk1[INDEX_2(k,j,nlen)] = RSL_INVALID ;
+      }
+
+    n = nlen ; z = zlen ; px1 = px ; py1 = py ;  /* protect variables */
+    result = rsl_default_decomp( wrk1, wrk2, info_p, &n, &z, &px1, &py1 ) ;
+
+    if ( ! result )
+    {
+      /* set the processor numbers of the valid points */
+      l = -1 ; h = -1 ; lz = -1 ; hiz = -1 ;
+      for ( k = 0 ; k < zlen ; k++ ) {
+        for ( j = 0 ; j < nlen ; j++ ) {
+          p = &(domain[ INDEX_2(k,j,nlen) ]) ;
+	  p->valid = RSL_VALID ;
+          p->P = wrk2[INDEX_2(k,j,nlen)] ;
+          if ( rsl_c_comp2phys_proc(p->P) == rsl_myproc ) {
+	    if ( l == -1 ) l = j ;
+	    h = j ;
+	    if ( lz == -1 ) lz = k ;
+	    hiz = k ;
+          }
+        }
+      }
+      *nloc_nz_p = h-l+1 + 2 * rsl_padarea ;
+      *zloc_nz_p = hiz-lz+1 ;
+    }
+
+    RSL_FREE( wrk1 ) ;
+    RSL_FREE( wrk2 ) ;
+
+  }
+/* end of changes for xposes -- 20010222 */
+
+  wrk1 = RSL_MALLOC( int, mlen * nlen ) ;
+  wrk2 = RSL_MALLOC( int, mlen * nlen ) ;
+  domain = dinfo->domain ;
+
+  /* load up input work array with valid points */
+  for ( j = 0 ; j < nlen ; j++ )
+    for ( i = 0 ; i < mlen ; i++ )
+    {
+      if ( domain[ INDEX_2(j,i,mlen) ].valid == RSL_VALID )
+        wrk1[INDEX_2(j,i,mlen)] = RSL_VALID ;
+      else
+        wrk1[INDEX_2(j,i,mlen)] = RSL_INVALID ;
+    }
+
+  if ( fcn != NULL )
+  {
+    m = mlen ; n = nlen ; px1 = px ; py1 = py ;  /* protect variables */
+    result = (*fcn)( wrk1, wrk2, info_p, &m, &n, &py1, &px1 ) ;
+  }
+  else
+  {
+    /* call internal decomposition routine */
+    m = mlen ; n = nlen ; px1 = px ; py1 = py ;  /* protect variables */
+    result = rsl_default_decomp( wrk1, wrk2, info_p, &m, &n, &py1, &px1 ) ;
+  }
+
+
+  if ( result )
+  {
+    if ( dinfo->decomposed )
+    {
+      RSL_TEST_WRN( 1, "RSL_FDECOMPOSE: Decomposition not changed." ) ;
+      return(1) ;
+    }
+    else
+    {
+      RSL_TEST_WRN( 1, "RSL_FDECOMPOSE: method failure -- not decomposed" ) ;
+      return(1) ;
+    }
+  }
+
+  if ( dinfo->decomposed )
+  {
+    /* make a note that there was a previous decomposition and
+       store it in wrk1 for use in figuring out what needs to 
+       be moved to get from the old decomp to the new one */
+    was_decomposed = 1 ;
+    for ( j = 0 ; j < nlen ; j++ )
+    {
+      for ( i = 0 ; i < mlen ; i++ )
+      {
+	wrk1[INDEX_2(j,i,mlen)] = domain[ INDEX_2(j,i,mlen) ].P ;
+      }
+    }
+  }
+
+  destroy_decomposition( d_p ) ;                /* no backing out now */
+
+#ifdef ENABLE_READ_DECOMP
+result = read_domain_decomp ( d, wrk2,  m, n ) ;  /* 20030505 */
+#endif
+
+  for ( P = 0 ; P < RSL_MAXPROC ; P++ )
+  {
+    destroy_list( &(point_move_receives[P]), NULL ) ;
+    destroy_list( &(point_move_sends[P]), NULL ) ;
+  }
+
+  /* set the processor numbers of the valid points */
+  for ( j = 0 ; j < nlen ; j++ )
+  {
+    for ( i = 0 ; i < mlen ; i++ )
+    {
+      if ( wrk2[INDEX_2(j,i,mlen)] != RSL_INVALID )
+      {
+        p = &(domain[ INDEX_2(j,i,mlen) ]) ;
+/* added 5/16/95 */
+/* If a previous decomposition exists, build a list of point moves to each processor */
+	if ( was_decomposed )
+	{
+	  /* figure out the sends */
+	  /* note: wrk1 contains the old decomposition; wrk2 the new one */
+	  if (( rsl_c_comp2phys_proc(wrk1[INDEX_2(j,i,mlen)]) == rsl_myproc))
+	  {
+	    lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+	    lp->info1 = i ;
+	    lp->info2 = j ;
+	    lp->next = point_move_sends[wrk2[INDEX_2(j,i,mlen)]] ;
+            point_move_sends[wrk2[INDEX_2(j,i,mlen)]] = lp ;
+	  }
+	  else
+	  if (( rsl_c_comp2phys_proc(wrk2[INDEX_2(j,i,mlen)] ) == rsl_myproc )) 
+	  {
+	    int idex ;
+
+	    idex = wrk1[INDEX_2(j,i,mlen)] ;
+	    lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+	    lp->info1 = i ;
+	    lp->info2 = j ;
+	    lp->next = point_move_receives[idex] ;
+            point_move_receives[idex] = lp ;
+	  }
+	}
+
+	p->valid = RSL_VALID ;
+        p->P = wrk2[INDEX_2(j,i,mlen)] ;
+        /* if this is a child of point in the next domain up, let the
+	   mother know where the kid is going */
+	if (( mom = p->mother_id ) != RSL_INVALID )
+	{
+	  p->mother_P =
+	    domain_info[ID_DOMAIN(mom)].
+	      domain[INDEX_2(ID_JDEX(mom),
+			     ID_IDEX(mom),
+			     domain_info[ID_DOMAIN(mom)].len_m )].P ;
+	  moms_kids =
+	    domain_info[ID_DOMAIN(mom)].
+	      domain[INDEX_2(ID_JDEX(mom),
+			     ID_IDEX(mom),
+			     domain_info[ID_DOMAIN(mom)].len_m )].children_p ;
+          /* search for me in mom's list -- mom! remember your own kid? */
+	  for ( kn = 0 ; kn < dinfo->irax_n ; kn++ )
+	  {
+	    for ( km = 0 ; km < dinfo->irax_m ; km++ )
+	    {
+	      if ( moms_kids->child[INDEX_2(kn,km,dinfo->irax_m)] ==
+		   POINTID( d, j, i ))
+	      {
+		/* she remembered!
+		   here's my processsor, mom. don't be a stranger, OK?  */
+		moms_kids->P[ INDEX_2(kn,km,dinfo->irax_m) ] = 
+		   domain[ INDEX_2(j,i,mlen) ].P ;
+		break ;
+	      }
+	    }
+	  }
+	}
+#if 0
+	/* added 4/21/95 -- there should never be a point without an
+	   associated mother id at this point in the program */
+	else 
+	{
+	  /* note, the mother domain would not have a parent */
+	  if ( d != 0 )
+	  {
+	    sprintf(mess,"Point %d %d on domain %d has no mother.\n",
+		  i,j,d ) ;
+	    RSL_TEST_ERR(1,mess)
+	  }
+	}
+#endif
+
+        /* this bit informs the children associated with this point
+           that the processor allocation for this point has set */
+	my_P = domain[ INDEX_2(j,i,mlen) ].P ;
+	if (( my_kids = p->children_p ) != NULL )
+	{
+	  /* the the nest id and the nest info for my chidren */
+	  nest = ID_DOMAIN(my_kids->child[0]) ;
+	  ninfo = &(domain_info[nest]) ;
+	  ndomain = ninfo->domain ;
+	  /* */
+	  for ( kp = 0 ; kp < ninfo->irax_n * ninfo->irax_m ; kp++ )
+	  {
+	    np = my_kids->child[kp] ;
+	    ndomain[INDEX_2(ID_JDEX(np),ID_IDEX(np),
+		    domain_info[ID_DOMAIN(np)].len_m )].mother_P = my_P ;
+	  }
+	}
+      }
+    }
+  }
+
+  /* note that this call will set mloc_p and nloc_p, which can then
+     be used by the calling program to allocate buffers of the
+     appropriate size, if desired.  NOTE ALSO, THAT THE EXTRA MEMORY
+     FOR THE PADS IS INCLUDED. */
+  dinfo->decomposed = 1 ;
+  rsl_new_decomposition( d_p, mloc_p, nloc_p ) ;
+
+  /* TODO code to move state vector stuff around needs to be added */
+
+  RSL_FREE( wrk1 ) ;
+  RSL_FREE( wrk2 ) ;
+  return(retval) ;
+}
+
+destroy_decomposition( d_p )
+  int_p d_p ;
+{
+  int d, nest ;
+  int mlen, nlen, i, j, mom, np ;
+  int kn, km, kp ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *domain, *ndomain, *p ;
+  rsl_child_info_t *moms_kids ;
+  rsl_child_info_t *my_kids ;
+  int destroy_runrec() ;
+
+  d = *d_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+                "rsl_fdecompose: bad domain descriptor" ) ;
+  dinfo = &( domain_info[d] ) ;
+  domain = dinfo->domain ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+                "rsl_fdecompose: invalid domain descriptor" ) ;
+
+  dinfo->decomposed = 0 ;
+
+  /* uncompile stencils associated with domain */
+  /* note: we aren't getting rid of them, just uncompiling them */
+  for ( i = 0 ; i < dinfo->stencurs ; i++ )
+  {
+    if ( dinfo->stenlist[i] != RSL_INVALID )
+      uncompile_stencil_on_domain( d, sh_descriptors[dinfo->stenlist[i]] ) ;
+  }
+
+  /* TODO uncompile bcast/merges associated with domain */
+
+  mlen = dinfo->len_m ; nlen = dinfo->len_n ;
+
+  for ( j = 0 ; j < nlen ; j++ )
+  {
+    for ( i = 0 ; i < mlen ; i++ )
+    {
+      p = &(domain[ INDEX_2(j,i,mlen) ]) ;
+      p->P = RSL_INVALID ;
+      if ( p->valid )
+      {
+	/* this bit informs the mother domain point associated with this point
+	   that the processor allocation for this point has been invalidated */
+	if (( mom = p->mother_id ) != RSL_INVALID )
+	{
+          moms_kids =
+            domain_info[ID_DOMAIN(mom)].
+              domain[INDEX_2(ID_JDEX(mom),
+                             ID_IDEX(mom),
+                             domain_info[ID_DOMAIN(mom)].len_m )].children_p ;
+          for ( kn = 0 ; kn < dinfo->irax_n ; kn++ )
+          {
+            for ( km = 0 ; km < dinfo->irax_m ; km++ )
+            {
+              if ( moms_kids->child[INDEX_2(kn,km,dinfo->irax_m)] ==
+                   POINTID( d, j, i ))
+              {
+                /*  I've lost my processor, ma.  Goodbye. */
+                moms_kids->P[ INDEX_2(kn,km,dinfo->irax_m) ] = RSL_INVALID ;
+                break ;
+              }
+            }
+          }
+        }
+	/* this bit informs the children associated with this point
+	   that the processor allocation for this point has been invalidated */
+	if (( my_kids = p->children_p ) != NULL )
+	{
+	  /* the the nest id and the nest info for my chidren */
+	  nest = ID_DOMAIN(my_kids->child[0]) ;
+	  ninfo = &(domain_info[nest]) ;
+	  ndomain = ninfo->domain ;
+	  /* */
+	  for ( kp = 0 ; kp < ninfo->irax_n * ninfo->irax_m ; kp++ )
+	  {
+	    np = my_kids->child[kp] ;
+	    ndomain[INDEX_2(ID_JDEX(np),ID_IDEX(np),
+		    domain_info[ID_DOMAIN(np)].len_m )].mother_P = RSL_INVALID ;
+	  }
+	}
+      }
+    }
+  }
+
+  for ( i = 0 ; i < RSL_MAXDOMAINS ; i++ )
+  {
+    domain_info[d].child_bcast_compiled[i] = 0 ;
+    domain_info[d].child_merge_compiled[i] = 0 ;
+  }
+  domain_info[d].parent_bcast_compiled = 0 ;
+  domain_info[d].parent_merge_compiled = 0 ;
+
+/* store for move */
+  domain_info[d].old_ilocaloffset = domain_info[d].ilocaloffset ;
+  domain_info[d].old_jlocaloffset = domain_info[d].jlocaloffset ;
+  domain_info[d].ilocaloffset = RSL_INVALID ;
+  domain_info[d].jlocaloffset = RSL_INVALID ;
+  domain_info[d].loc_m = RSL_INVALID ;
+  domain_info[d].loc_n = RSL_INVALID ;
+  destroy_list( &(domain_info[d].pts), NULL ) ;
+  destroy_list( &(domain_info[d].ghost_pts), NULL ) ;
+  destroy_list( &(domain_info[d].iruns), destroy_runrec ) ;
+  { int p ;
+    for ( p = 0 ; p < MAX_KINDPAD ; p++ )
+    {
+      if ( domain_info[d].js[p] != NULL ) RSL_FREE( domain_info[d].js[p] ) ;
+      if ( domain_info[d].is[p] != NULL ) RSL_FREE( domain_info[d].is[p] ) ;
+      if ( domain_info[d].ie[p] != NULL ) RSL_FREE( domain_info[d].ie[p] ) ;
+      if ( domain_info[d].ie[p] != NULL ) RSL_FREE( domain_info[d].jg2n[p] ) ;
+      domain_info[d].js[p] = NULL ;
+      domain_info[d].is[p] = NULL ;
+      domain_info[d].ie[p] = NULL ;
+      domain_info[d].jg2n[p] = NULL ;
+      if ( domain_info[d].js[p] != NULL ) RSL_FREE( domain_info[d].is2[p] ) ;
+      if ( domain_info[d].is[p] != NULL ) RSL_FREE( domain_info[d].js2[p] ) ;
+      if ( domain_info[d].ie[p] != NULL ) RSL_FREE( domain_info[d].je2[p] ) ;
+      if ( domain_info[d].ie[p] != NULL ) RSL_FREE( domain_info[d].ig2n[p] ) ;
+      domain_info[d].is2[p] = NULL ;
+      domain_info[d].js2[p] = NULL ;
+      domain_info[d].je2[p] = NULL ;
+      domain_info[d].ig2n[p] = NULL ;
+    }
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/default_decomposition.c b/wrfv2_fire/external/RSL/RSL/default_decomposition.c
new file mode 100755
index 00000000..c867d577
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/default_decomposition.c
@@ -0,0 +1,191 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+static struct default_decomp {
+   int (*default_decomp_fcn)() ;
+} default_decomp[RSL_MAXDOMAINS] ;
+static int *def_decomp_info[RSL_MAXDOMAINS] ;
+
+/* this is called from various parts of the code to decompose a
+   domain if it has not been decomposed already */
+default_decomposition( d_p, mloc_p, nloc_p )
+  int_p d_p, mloc_p, nloc_p ;
+{ 
+  int px, py ;
+  int (*f)() ;
+  int retval ;
+  int zloc_p,
+      mloc_mz_p, nloc_mz_p, zloc_mz_p,
+      mloc_nz_p, nloc_nz_p, zloc_nz_p ;
+
+  py = rsl_nproc_m ;
+  px = rsl_nproc_n ;
+
+  f = default_decomp[*d_p].default_decomp_fcn ;
+
+  retval = RSL_FDECOMPOSE (
+          d_p,
+	  f,
+	  &py,
+	  &px,
+	  def_decomp_info[*d_p],
+	  mloc_p, nloc_p, &zloc_p,
+	  &mloc_mz_p, &nloc_mz_p, &zloc_mz_p,
+	  &mloc_nz_p, &nloc_nz_p, &zloc_nz_p ) ;
+
+/* these have been added for the parallel matrix transpose, 20010223.
+   default_decomp is called many places in RSL, and rather than thread
+   all this through, I have opted to just store the additional info
+   from teh decomposition algorithma and store it in the domain info */
+  domain_info[*d_p].loc_m = *mloc_p ;
+  domain_info[*d_p].loc_n = *nloc_p ;
+  domain_info[*d_p].loc_z = zloc_p ;
+  domain_info[*d_p].loc_mz_m = mloc_mz_p ;
+  domain_info[*d_p].loc_mz_n = nloc_mz_p ;
+  domain_info[*d_p].loc_mz_z = zloc_mz_p ;
+  domain_info[*d_p].loc_nz_m = mloc_nz_p ;
+  domain_info[*d_p].loc_nz_n = nloc_nz_p ;
+  domain_info[*d_p].loc_nz_z = zloc_nz_p ;
+
+  return(retval) ;
+}
+
+/*@
+  SET_DEF_DECOMP_FCN --- Replace the default mapping routine.
+
+  This provides a mechanism to replace the mapping function currently
+  in effect with a different routine, specified by the functional
+  pointer Arg1.  This is the routine that will be called by RSL
+  whenever a new domain is created.  The user program can provide
+  additional information to the mapping function using 
+  SET_DEF_DECOMP_INFO.
+
+  Mapping function:
+  The user-supplied function for decomposing the domain should have
+  the following form.
+
+  Verbatim:
+$ INTEGER FUNCTION MAPPING ( in, out, info, m, n, py, px )
+BREAKTHEEXAMPLECODE
+
+  In and out are m by n integer arrays.  Each element of the in array is
+  set to RSL_VALID for valid points in the domain or RSL_INVALID if the
+  point is not considered to be part of the domain and therefore not
+  to be allocated to a processor (as might be the case if extra memory
+  is allocated but not used).  The function generates an out array
+  such that every point that was RSL_VALID in the in array is given
+  a processor number between 0 (zero) and py times px minus 1.  Integers
+  m and n are the in and out array dimensions; integer py is the number
+  of processors decomposing m; integer px is the number of processors
+  decomposing n.
+
+  See also:
+  SET_DEF_DECOMP_INFO
+
+@*/
+SET_DEF_DECOMP_FCN ( f )
+  int 
+    (*f)() ;        /* (I) Function to use as default decomposition. */
+{
+  int i ;
+
+  for ( i = 0 ; i < RSL_MAXDOMAINS ; i++ )
+    default_decomp[i].default_decomp_fcn = f ;
+}
+
+SET_DEF_DECOMP_FCN1 ( d_p, f )
+  int_p d_p ;
+  int
+    (*f)() ;        /* (I) Function to use as default decomposition. */
+{
+  int i ;
+  int d ;
+
+  d = *d_p ;
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "rsl_compile_stencil: bad domain descriptor" ) ;
+  default_decomp[*d_p].default_decomp_fcn = f ;
+}
+
+
+/*@
+  SET_DEF_DECOMP_INFO --- Provide data to RSL to pass to the mapping routine.
+
+  Notes:
+  When RSL calls the default mapping function, the data provided as Arg2
+  will be passed as the third argument to the function.  This provides
+  mechanism for moving data such as timing information from the user program
+  to the mapping routine for use in calculating the domain decomposition.
+
+  See also:
+  SET_DEF_DECOMP_FCN
+
+
+@*/
+SET_DEF_DECOMP_INFO ( d_p, inf )
+  int_p 
+      d_p ;    /* (I) RSL domain descriptor */
+  void *
+      inf ;    /* (I) Pointer to memory that will be passed as-is to the decomposition routine */
+{
+  def_decomp_info[*d_p] = (int_p) inf ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/destroy_list.c b/wrfv2_fire/external/RSL/RSL/destroy_list.c
new file mode 100755
index 00000000..7007aba3
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/destroy_list.c
@@ -0,0 +1,104 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* traverse a list and free up nodes */
+
+#if 0
+destroy_list( list, dfcn )
+  rsl_list_t ** list ;		/* pointer to pointer to list */
+  int (*dfcn)() ;		/* pointer to function for destroying
+				   the data field of the list */
+{
+  if ( list == NULL ) return ;
+  if ( *list == NULL ) return ;
+
+  if ( dfcn != NULL ) (*dfcn)( (*list)->data ) ;
+
+  destroy_list( &((*list)->next), dfcn ) ;
+
+  RSL_FREE( (*list) ) ;
+
+  *list = NULL ;
+
+  return(0) ;
+
+}
+#else
+
+destroy_list( list, dfcn )
+  rsl_list_t ** list ;		/* pointer to pointer to list */
+  int (*dfcn)() ;		/* pointer to function for destroying
+				   the data field of the list */
+{
+  rsl_list_t *p, *trash ;
+  if ( list == NULL ) return(0) ;
+  if ( *list == NULL ) return(0) ;
+  for ( p = *list ; p != NULL ; )
+  {
+    if ( dfcn != NULL ) (*dfcn)( p->data ) ;
+    trash = p ;
+    p = p->next ;
+    RSL_FREE( trash ) ;
+  }
+  *list = NULL ;
+  return(0) ;
+}
+
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/domain_def.c b/wrfv2_fire/external/RSL/RSL/domain_def.c
new file mode 100755
index 00000000..25a35345
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/domain_def.c
@@ -0,0 +1,1675 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+#define SOUTH RSL_MLOW
+#define NORTH RSL_MHIGH
+#define WEST  RSL_NLOW
+#define EAST  RSL_NHIGH
+
+static int debuggal_mine = 0 ;
+
+/*@
+  RSL_MOTHER_DOMAIN - Define the topmost domain.
+
+  Notes:
+  This routine defines the principal, top-level domain of the model.
+
+  As input, the routine takes Arg2, a specifier for the largest stencil that
+  will be used.  It may be one of
+  
+  Verbatim:
+  
+$    RSL_4PT,
+$    RSL_8PT,
+$    RSL_12PT,
+$    RSL_24PT, or
+$    RSL_168PT.
+
+BREAKTHEEXAMPLECODE
+  It also takes Arg3 and Arg4, the
+  logical (undecomposed) dimensions of the domain, m and n.
+
+  Output is Arg1, a domain descriptor, a
+  handle to RSL's definition of the domain, and Arg5 and Arg6,
+  minimum local sizes
+  for array dimensions on the local processor.  These values can be used
+  to allocate local arrays in models that use dynamic memory allocation.
+  Models that allocate memory
+  statically may use these values as a check to be sure that enough
+  memory has been allocated.
+
+  RSL must have been initialized and a processor mesh specified
+  before a domain is defined.
+
+  Example:
+
+$  INCLUDE 'rsl.inc'
+$  INTEGER D
+$  INTEGER MLEN, NLEN
+$  --
+$  CALL RSL_INITIALIZE
+$  CALL RSL_MESH(2, 2)
+$  CALL RSL_MOTHER_DOMAIN(D,RSL_8PT,25,30,MLEN,NLEN)
+
+BREAKTHEEXAMPLECODE
+  This declares a 25 by 30 element domain.
+  The
+  integer d contains a domain descriptor, which will
+  be used in all subsequent operations involving the domain.
+
+  See also:
+  RSL_INITIALIZE, RSL_SPAWN_REGULAR_NEST
+
+@*/
+int
+RSL_MOTHER_DOMAIN ( domain_p, maskid_p, mlen_p, nlen_p, mloc_p, nloc_p )
+  int_p
+    domain_p        /* (O)  Domain id. */
+   ,maskid_p        /* (I)  Id of maximum stencil for this domain. */
+   ,mlen_p          /* (I)  Number of cells in m dimension of domain. */
+   ,nlen_p          /* (I)  Number of cells in n dimension of domain. */
+   ,mloc_p          /* (O)  Required size of local memory in m. */
+   ,nloc_p          /* (O)  Required size of local memory in n. */
+    ;
+{
+  rsl_index_t i, j, k ;
+  int  d ;
+  rsl_dimlen_t nmax ;
+  rsl_dimlen_t mmax ;
+  rsl_dimlen_t zmax ;
+  int mmin, nmin, mtrim, ntrim ;
+
+  mmax = *mlen_p ;
+  nmax = *nlen_p ;
+  zmax = 1 ;  /* trivial */
+  GET_NEXT_DOMAIN_DESCRIPTOR ( &d ) ; ;
+  *domain_p = d ;
+
+  RSL_TEST_ERR( domain_info[d].valid == RSL_VALID,
+     "rsl_mother_domain() called more than once" ) ;
+
+  domain_info[d].nest_level = 0 ;
+  domain_info[d].maskid     = *maskid_p ;
+  domain_info[d].trim_m     = 0 ;
+  domain_info[d].trim_n     = 0 ;
+
+  rsl_c_initialize_domain( d, nmax, mmax, zmax, nmax, mmax, zmax ) ;
+
+  mtrim = domain_info[d].trim_m ;
+  ntrim = domain_info[d].trim_n ;
+
+  for ( j = 0 ; j < nmax ; j++ ) for ( i = 0 ; i < mmax ; i++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain[INDEX_2(j,i,mmax)].valid = RSL_VALID ;
+      domain_info[d].domain[INDEX_2(j,i,mmax)].trimmed = 0 ; }
+
+  for ( k = 0 ; k < zmax ; k++ ) for ( i = 0 ; i < mmax ; i++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain_mz[INDEX_2(k,i,mmax)].valid = RSL_VALID ; }
+
+  for ( k = 0 ; k < zmax ; k++ ) for ( j = 0 ; j < nmax ; j++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain_nz[INDEX_2(k,j,nmax)].valid = RSL_VALID ; }
+
+  trim_domain( domain_info[d].domain, mmax, nmax, 0, 0 ) ;
+
+  work_out_bdy( domain_info[d].domain, mmax, nmax ) ;
+
+  {
+/* moved here, 4/21/95 --- see comment in spawn nest below */
+    int dd ;
+    dd = d ;
+    default_decomposition( &dd,
+                           mloc_p,
+                           nloc_p ) ;
+  }
+
+  rsl_ndomains = 1 ;
+  return(0) ;
+}
+
+/* (20010222) */
+RSL_MOTHER_DOMAIN3D( domain_p, maskid_p, mlen_p, nlen_p, zlen_p, 
+                                         mloc_p, nloc_p, zloc_p,
+                                         mloc_mz_p, nloc_mz_p , zloc_mz_p,
+                                         mloc_nz_p, nloc_nz_p , zloc_nz_p )
+  int_p
+    domain_p        /* (O)  Domain id. */
+   ,maskid_p        /* (I)  Id of maximum stencil for this domain. */
+   ,mlen_p          /* (I)  Number of cells in m dimension of domain. */
+   ,nlen_p          /* (I)  Number of cells in n dimension of domain. */
+   ,zlen_p          /* (I)  Number of cells in z dimension of domain. */
+   ,mloc_p          /* (O)  Required size of local memory in m. (MN decomp) */
+   ,nloc_p          /* (O)  Required size of local memory in n.      "      */
+   ,zloc_p          /* (O)  Required size of local memory in z.      "      */
+   ,mloc_mz_p       /* (O)  Required size of local memory in m. (MZ decomp) */
+   ,nloc_mz_p       /* (O)  Required size of local memory in n.      "      */
+   ,zloc_mz_p       /* (O)  Required size of local memory in z.      "      */
+   ,mloc_nz_p       /* (O)  Required size of local memory in m. (NZ decomp) */
+   ,nloc_nz_p       /* (O)  Required size of local memory in n.      "      */
+   ,zloc_nz_p       /* (O)  Required size of local memory in z.      "      */
+    ;
+{
+
+  rsl_index_t i, j, k ;
+  int  d ;
+  rsl_dimlen_t nmax ;
+  rsl_dimlen_t mmax ;
+  rsl_dimlen_t zmax ;
+  int mmin, nmin, mtrim, ntrim ;
+
+  mmax = *mlen_p ;
+  nmax = *nlen_p ;
+  zmax = *zlen_p ;
+  GET_NEXT_DOMAIN_DESCRIPTOR ( &d ) ;
+  *domain_p = d ;
+
+  RSL_TEST_ERR( domain_info[d].valid == RSL_VALID,
+     "rsl_mother_domain() called more than once" ) ;
+
+  if ( domain_info[d].domain_mz != NULL ) { RSL_FREE( domain_info[d].domain_mz ) ; }
+  if ( domain_info[d].domain_nz != NULL ) { RSL_FREE( domain_info[d].domain_nz ) ; }
+
+
+  domain_info[d].nest_level = 0 ;
+  domain_info[d].maskid     = *maskid_p ;
+  domain_info[d].trim_m     = 0 ;
+  domain_info[d].trim_n     = 0 ;
+
+  rsl_c_initialize_domain( d, nmax, mmax, zmax, nmax, mmax, zmax ) ;
+
+  mtrim = domain_info[d].trim_m ;
+  ntrim = domain_info[d].trim_n ;
+
+  for ( j = 0 ; j < nmax ; j++ ) for ( i = 0 ; i < mmax ; i++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain[INDEX_2(j,i,mmax)].valid = RSL_VALID ;
+      domain_info[d].domain[INDEX_2(j,i,mmax)].trimmed = 0 ; }
+
+  for ( k = 0 ; k < zmax ; k++ ) for ( i = 0 ; i < mmax ; i++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain_mz[INDEX_2(k,i,mmax)].valid = RSL_VALID ; }
+
+  for ( k = 0 ; k < zmax ; k++ ) for ( j = 0 ; j < nmax ; j++ )
+    { /* all points valid on mother domain -- always rectangular */
+      domain_info[d].domain_nz[INDEX_2(k,j,nmax)].valid = RSL_VALID ; }
+
+  trim_domain( domain_info[d].domain, mmax, nmax, 0, 0 ) ;
+
+  work_out_bdy( domain_info[d].domain, mmax, nmax ) ;
+
+  {
+/* moved here, 4/21/95 --- see comment in spawn nest below */
+    int dd ;
+    dd = d ;
+    default_decomposition( &dd,
+                           mloc_p,
+                           nloc_p ) ;
+  }
+
+/* these are set by the revised default_decomposition routine (20010223) */
+
+  *zloc_p    = domain_info[d].loc_z ;
+  *mloc_mz_p = domain_info[d].loc_mz_m ;
+  *nloc_mz_p = domain_info[d].loc_mz_n ;
+  *zloc_mz_p = domain_info[d].loc_mz_z ;
+  *mloc_nz_p = domain_info[d].loc_nz_m ;
+  *nloc_nz_p = domain_info[d].loc_nz_n ;
+  *zloc_nz_p = domain_info[d].loc_nz_z ;
+
+  rsl_ndomains = 1 ;
+
+}
+
+/*
+   rsl_c_initialize_domain
+
+   Initializes a domain descriptor.
+
+   For a mother domain the actual and effective sizes will be the same.
+
+   For a nest, they may differ.   This is because the nest must always
+   be a multiple of IRAX wide, but may not compute over all of that.
+
+*/
+int
+rsl_c_initialize_domain ( d, nmax, mmax, zmax, neff, meff, zeff )
+  rsl_index_t d ;
+  rsl_dimlen_t nmax, mmax, zmax ;   /* actual size definition */
+  rsl_dimlen_t neff, meff, zeff ;   /* effective size definition (for computing) */
+{
+  rsl_index_t i, j, k ;
+  rsl_point_t *p ;
+
+#if 0
+  fprintf(stderr,"1> rsl_c_initialize_domain d = %d\n",d ) ;
+  fprintf(stderr,"                    nmax     = %d\n",nmax ) ;
+  fprintf(stderr,"                    mmax     = %d\n",mmax ) ;
+  fprintf(stderr,"                    neff     = %d\n",neff ) ;
+  fprintf(stderr,"                    meff     = %d\n",meff ) ;
+#endif
+
+  domain_info[d].pts = NULL ;
+  domain_info[d].ghost_pts = NULL ;
+  domain_info[d].iruns = NULL ;
+  domain_info[d].len_n = nmax ;
+  domain_info[d].len_m = mmax ;
+  domain_info[d].len_z = zmax ;
+  domain_info[d].eff_n = neff ;
+  domain_info[d].eff_m = meff ;
+  domain_info[d].eff_z = zeff ;
+  domain_info[d].coord_n = RSL_INVALID ;
+  domain_info[d].coord_m = RSL_INVALID ;
+
+#if 0
+  fprintf(stderr,"2> rsl_c_initialize_domain d = %d\n",d ) ;
+  fprintf(stderr,"                    nmax     = %d\n",nmax ) ;
+  fprintf(stderr,"                    mmax     = %d\n",mmax ) ;
+  fprintf(stderr,"                    zmax     = %d\n",zmax ) ;
+  fprintf(stderr,"                    neff     = %d\n",neff ) ;
+  fprintf(stderr,"                    meff     = %d\n",meff ) ;
+#endif
+
+  if ( domain_info[d].domain != NULL )    { RSL_FREE( domain_info[d].domain ) ; }
+  if ( domain_info[d].domain_mz != NULL ) { RSL_FREE( domain_info[d].domain_mz ) ; }
+  if ( domain_info[d].domain_nz != NULL ) { RSL_FREE( domain_info[d].domain_nz ) ; }
+
+  domain_info[d].domain    = RSL_MALLOC(rsl_point_t,(nmax*mmax)) ;
+  domain_info[d].domain_nz = RSL_MALLOC(rsl_point_t,(nmax*zmax)) ;
+  domain_info[d].domain_mz = RSL_MALLOC(rsl_point_t,(mmax*zmax)) ;
+
+  domain_info[d].valid = RSL_VALID ;
+  domain_info[d].decomposed = 0 ;
+  domain_info[d].trim_m = 0 ;
+  domain_info[d].trim_n = 0 ;
+
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+  
+      p = &(domain_info[d].domain[ INDEX_2(j,i,mmax) ]) ;
+      p->dbdy = RSL_INVALID ;
+      p->P           = RSL_INVALID ;
+      p->valid       = RSL_INVALID ;
+      p->trimmed     = RSL_INVALID ;
+      p->id          = POINTID( d, j, i ) ;
+      p->info_1      = RSL_INVALID ;
+      p->info_2      = RSL_INVALID ;
+      p->mother_id   = RSL_INVALID ;
+      p->which_kid_am_i_m   = RSL_INVALID ;
+      p->which_kid_am_i_n   = RSL_INVALID ;
+      if ( p->children_p != NULL ) 
+      {
+        RSL_FREE( p->children_p ) ;
+      }
+      p->dbdy = RSL_INVALID ;
+      p->bdy_cclockwise = RSL_INVALID ;
+      p->bdy_clockwise = RSL_INVALID ;
+      p->dbdy_x = RSL_INVALID ;
+      p->bdy_x_cclockwise = RSL_INVALID ;
+      p->bdy_x_clockwise = RSL_INVALID ;
+    }
+  }
+
+
+  for ( i = 0 ; i < RSL_MAXDESCRIPTORS ; i++ )
+  {
+    domain_info[d].stenlist[i] = RSL_INVALID ;
+  }
+  for ( i = 0 ; i < RSL_MAXDOMAINS ; i++ )
+  {
+    domain_info[d].child_bcast_compiled[i] = 0 ;
+    domain_info[d].child_merge_compiled[i] = 0 ;
+  }
+  domain_info[d].parent_bcast_compiled = 0 ;
+  domain_info[d].parent_merge_compiled = 0 ;
+  domain_info[d].stencurs = 0 ;
+  domain_info[d].periodcurs = 0 ;
+  domain_info[d].xposecurs = 0 ;
+
+  return(0);
+}
+
+/*@
+  RSL_SPAWN_REGULAR_NEST - Spawn a domain using coarse domain dimensions. 
+
+  Notes:
+  This routine spawns a rectangular nest in an existing domain whose
+  descriptor is provided as Arg2.  The newly defined domain descriptor
+  is returned as Arg1.
+
+  The argument Arg3 specifies the maximum stencil that will be used on
+  the domain and may be one of
+
+  Verbatim:
+$    RSL_4PT,
+$    RSL_8PT,
+$    RSL_12PT,
+$    RSL_24PT, or
+$    RSL_168PT.
+
+BREAKTHEEXAMPLECODE
+
+  These are defined in the file rsl.inc.
+  For efficiency, choose the smallest.  Arg4 and Arg5 are the coordinates
+  of the south-west corner of the nest in the parent domain.  The
+  arguments Arg6 and Arg7 are the dimensions of the parent domain area
+  under which the nest is being defined.  In other words, the nest
+  dimensions are specified in parent domain units
+  (RSL_SPAWN_REGULAR_NEST1 allows specification of the nest dimensions
+  in nest units).  The Arg8 and Arg9 are the nesting ratios in M and N
+  respectively; these are the number of nest cells per parent cell in
+  each dimension (e.g. 3, as in MM5.) The Arg10 and Arg11 arguments are
+  trim arguments for adjusting a logical (undecomposed) dimension of
+  the nest from other than a multiple of the number of parent domain
+  cells in the dimension.
+
+  On return, Arg12 and Arg13 are set to the minimum local dimensions that
+  will be required for model arrays on the processor.  This also includes
+  additional memory for ghost points around the local processor partition
+  (the amount allocated will depend on the stencil specified by Arg3).
+  The Arg14 and Arg15 arguments will be set to the effective undecomposed
+  dimensions, after trimming.
+
+  Example:
+
+$   IPOS = 15 ; JPOS = 20     ! position of nest sw corner
+$   IDIM = 7  ; JDIM = 10     ! dimensions of nested region in parent
+$   BTRIM = 2                 ! trimming for MM5 nesting w/ Arakawa B-grid
+$   IRAX = 3                  ! nesting ratio
+$   CALL RSL_SPAWN_REGULAR_NEST( NEST%RSL_ID, PARENT%RSL_ID, RSL_24PT,
+$  +                             IPOS, JPOS, IDIM, JDIM,
+$  +                             IRAX, IRAX,
+$  +                             BTRIM, BTRIM,
+$  +                             MLOC, NLOC, M, N )
+$ C
+$ C Use size info returned by RSL to allocate 2-d and 3-d domain data
+$ C structures for nest.
+$ C
+$   NLEV = 25                 ! number vert. levels
+$   ALLOCATE( NEST\%UA(MLOC,NLOC,NLEV) )   ! ew wind
+$   ALLOCATE( NEST\%VA(MLOC,NLOC,NLEV) )   ! ns wind
+$   ALLOCATE( NEST\%TA(MLOC,NLOC,NLEV) )   ! ns wind
+$   ALLOCATE( NEST\%PS(MLOC,NLOC) )        ! surface pres
+$   ...
+
+BREAKTHEEXAMPLECODE
+
+  A rectangular nest is spawned within a 7-cell by 10-cell region of a
+  parent domain.  The southwest corner of the nest is positioned under
+  parent cell (15,20).  A 24-point stencil is the largest that will be used
+  on the nest.  There are 3 nest cells per parent cell in both
+  horizontal dimensions; thus the total nest size is 21 by 30 cells.
+  However, we wish to follow a rule (used in MM5) that nest dimensions
+  must always be one greater than a multiple of the nesting ratio to
+  accounts for the staggering of dot and cross grids on the parent and
+  nest.  Therefore, we trim two points from the northern and eastern
+  edges of the nest; the result is effective nest dimensions of 19 by
+  28, the values returned in m and n respectively.  In the example,
+  return values mloc and nloc are used in subsequent Fortran90 allocate
+  statements to size the local state arrays for the nest.
+
+  See also:
+  RSL_INITIALIZE, RSL_MOTHER_DOMAIN, RSL_SPAWN_REGULAR_NEST1
+
+@*/
+
+RSL_SPAWN_REGULAR_NEST ( n_p, d_p, maskid_p, sw_min_p,  sw_maj_p, dim_min_p, dim_maj_p, irax_m_p,  irax_n_p, mtrim_p, ntrim_p, mloc_p, nloc_p, mlen_p, nlen_p )
+  int_p 
+    n_p             /* (O) Handle to nested domain. */
+   ,d_p             /* (I) Handle to parent domain. */
+   ,maskid_p        /* (I) Id of maximum stencil for this domain. */
+   ,sw_min_p        /* (I) M coord in mother domain of sw of nest.*/
+   ,sw_maj_p        /* (I) N coord in mother domain of sw of nest.*/
+   ,dim_min_p       /* (I) M dimension of nest.  */
+   ,dim_maj_p       /* (I) N dimension of nest.  */
+   ,mtrim_p         /* (I) M trim. */
+   ,ntrim_p         /* (I) N trip. */
+   ,irax_m_p        /* (I) Nesting ratio in M dimension. */
+   ,irax_n_p ;      /* (I) Nesting ration in n dimension. */
+  int_p
+    mloc_p          /* (O) Minimum local array size in M. */
+   ,nloc_p ;        /* (O) Minimum local array size in N. */
+  int_p
+    mlen_p          /* (O) Undecomposed size of M. */
+   ,nlen_p ;        /* (O) Undecomposed size of N. */
+{
+rsl_c_spawn_regnest( n_p, d_p, maskid_p, sw_min_p, sw_maj_p,
+                     dim_min_p, dim_maj_p,
+                     irax_m_p, irax_n_p,
+		     mtrim_p, ntrim_p,
+                     mloc_p, nloc_p,
+                     mlen_p, nlen_p, 1 ) ;
+}
+
+/*@
+  RSL_SPAWN_REGULAR_NEST1 - Spawn a domain using nested domain dimensions. 
+
+  Notes:
+  This routine spawns a rectangular nest in an existing domain whose
+  descriptor is provided as Arg2.  The newly defined domain descriptor
+  is returned as Arg1.
+
+  The argument Arg3 specifies the maximum stencil that will be used on
+  the domain and may be one of
+
+  Verbatim:
+$    RSL_4PT,
+$    RSL_8PT,
+$    RSL_12PT,
+$    RSL_24PT, or
+$    RSL_168PT.
+
+BREAKTHEEXAMPLECODE
+
+  These are defined in the file rsl.inc.
+  For efficiency, choose the smallest.
+  Arg4 and Arg5 are the coordinates of the south-west corner of the nest in
+  the parent domain.
+  The arguments Arg6 and Arg7 are the dimensions of the nest.
+  (RSL_SPAWN_REGULAR_NEST allows
+  specification of the nest dimensions in terms of the parent grid).
+  The Arg8 and Arg9 are the nesting ratios in M and N respectively; these
+  are the number of nest cells per parent cell in each dimension (e.g. 3, as
+  in MM5.)
+
+  On return, Arg10 and Arg11 are set to the minimum local dimensions that
+  will be required for model arrays on the processor.  This also includes
+  additional memory for ghost points around the local processor partition
+  (the amount allocated will depend on the stencil specified by Arg3).
+  The Arg12 and Arg13 arguments will be set to the effective undecomposed
+  dimensions.
+
+  Example:
+
+$   IPOS = 15 ; JPOS = 20     ! position of nest sw corner
+$   IDIM = 19 ; JDIM = 28     ! dimensions of nest
+$   IRAX = 3                  ! nesting ratio
+$   CALL RSL_SPAWN_REGULAR_NEST1( NEST%RSL_ID, PARENT%RSL_ID, RSL_24PT,
+$  +                              IPOS, JPOS, IDIM, JDIM,
+$  +                              IRAX, IRAX,
+$  +                              MLOC, NLOC, M, N )
+$ C
+$ C Use size info returned by RSL to allocate 2-d and 3-d domain data
+$ C structures for nest.
+$ C
+$   NLEV = 25                 ! number vert. levels
+$   ALLOCATE( NEST\%UA(MLOC,NLOC,NLEV) )   ! ew wind
+$   ALLOCATE( NEST\%VA(MLOC,NLOC,NLEV) )   ! ns wind
+$   ALLOCATE( NEST\%TA(MLOC,NLOC,NLEV) )   ! ns wind
+$   ALLOCATE( NEST\%PS(MLOC,NLOC) )        ! surface pres
+$   ...
+
+BREAKTHEEXAMPLECODE
+
+  A rectangular 19 by 28 cell nest is spawned an located with its
+  southwest corner at point (15,20) in the parent domain.  A 24-point
+  stencil is the largest that will be used on the nest.  There are 3
+  nest cells per parent cell in both horizontal dimensions.  In the
+  example, return values mloc and nloc are used in subsequent Fortran90
+  allocate statements to size the local state arrays for the nest.
+
+  See also:
+  RSL_INITIALIZE, RSL_MOTHER_DOMAIN, RSL_SPAWN_REGULAR_NEST
+
+@*/
+RSL_SPAWN_REGULAR_NEST1 ( n_p, d_p, maskid_p,
+                          sw_min_p,  sw_maj_p,
+                          dim_min_p, dim_maj_p,
+                          irax_m_p,  irax_n_p,
+                          mloc_p, nloc_p, mlen_p, nlen_p ) 
+  int_p 
+    n_p,            /* (O) Handle to nested domain. */
+    d_p,            /* (I) Handle to parent domain. */
+    maskid_p,       /* (I) Id of maximum stencil for this domain. */
+    sw_min_p,       /* (I) M coord in mother domain of sw of nest. */
+    sw_maj_p,       /* (I) N coord in mother domain of sw of nest. */
+    dim_min_p,      /* (I) M dimension of nest. */
+    dim_maj_p,      /* (I) N dimension of nest. */
+    irax_m_p,       /* (I) Nesting ratio in M dimension.*/
+    irax_n_p ;      /* (I) Nesting ratio in N dimension.*/
+  int_p
+    mloc_p,         /* (O) Minimum local array size in M. */
+    nloc_p ;        /* (O) Minimum local array size in N. */
+  int_p
+    mlen_p,         /* (O) Undecomposed size of M. */
+    nlen_p ;        /* (O) Undecomposed size of N. */
+{
+int dummy ;
+rsl_c_spawn_regnest( n_p, d_p, maskid_p, sw_min_p, sw_maj_p,
+                     dim_min_p, dim_maj_p,
+                     irax_m_p, irax_n_p,
+		     &dummy, &dummy,	/* not needed when using n.d. coords */
+                     mloc_p, nloc_p,  
+                     mlen_p, nlen_p, 0 ) ;
+}
+
+rsl_c_spawn_regnest( n_p, d_p, maskid_p,
+                     sw_min_p, sw_maj_p,
+                     dim_min_p, dim_maj_p,
+                     irax_m_p, irax_n_p,
+		     mtrim_p, ntrim_p,
+                     mloc_p, nloc_p, 
+                     mlen_p, nlen_p, sw )
+  int_p n_p,            /* handle to nested domain */
+        d_p,            /* handle to mother domain */
+        maskid_p,       /* Input.   Id of maximum stencil for this domain. */
+        sw_min_p,       /* coordinates in mother domain of sw corner of nest */
+        sw_maj_p,       /* 0)?(len_m*irax_m-elen_m):0 ;
+    ntrim = ((len_n*irax_n-elen_n)>0)?(len_n*irax_n-elen_n):0 ;
+
+  }
+  else          /* default: dims are specified in c.d. coords */
+  {
+    len_m = *dim_min_p ;
+    len_n = *dim_maj_p ;
+    nlen_m = len_m * irax_m ;
+    nlen_n = len_n * irax_n ;
+    elen_m = nlen_m ;
+    elen_n = nlen_n ;
+    ime = im + len_m - 1 ;
+    jme = jm + len_n - 1 ;
+  }
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "invalid domain index") ;
+  RSL_TEST_ERR( im < 0 || im >= domain_info[d].len_m || 
+                jm < 0 || jm >= domain_info[d].len_n || 
+                ime < 0 || ime>= domain_info[d].len_m || 
+                jme< 0 || jme>= domain_info[d].len_n , 
+                     "nested domain won't fit in mother domain" ) ;
+
+  /* set the four corners of the nest in c.d. coordinates */
+  xlist[0] = jm   ; ylist[0] = im  ;
+  xlist[1] = jm   ; ylist[1] = ime ;
+  xlist[2] = jme  ; ylist[2] = ime ;
+  xlist[3] = jme  ; ylist[3] = im  ;
+  nlistpoints = 4 ;
+
+  rsl_spawn_nest ( n_p, d_p, maskid_p, xlist, ylist, &nlistpoints,
+                   &mtrim, &ntrim,
+                   irax_m_p, irax_n_p,
+                   mloc_p, nloc_p, mlen_p, nlen_p ) ;
+
+  domain_info[*n_p].nestshape = RSL_REGULAR_NEST ;
+  domain_info[*n_p].eff_m = elen_m ;
+  domain_info[*n_p].eff_n = elen_n ;
+  domain_info[*n_p].trim_m = mtrim ;
+  domain_info[*n_p].trim_n = ntrim ;
+
+}
+
+/*@
+  RSL_SPAWN_IRREG_NEST - Spawn a non-rectangular nest.
+
+  Notes:
+  This routine spawns an irregularly shaped nest in an existing domain whose
+  descriptor is provided as Arg2.  The newly defined domain descriptor
+  is returned as Arg1.
+
+  The argument Arg3 specifies the maximum stencil that will be used on
+  the domain and may be one of
+
+  Verbatim:
+$    RSL_4PT,
+$    RSL_8PT,
+$    RSL_12PT,
+$    RSL_24PT, or
+$    RSL_168PT.
+
+BREAKTHEEXAMPLECODE
+
+  These are defined in the file rsl.inc.
+  that will be used on the domain.  For efficiency, choose the smallest.
+
+  The shape of the irregular nest is specified by listing the nodes (corners)
+  of the polygon.  The corner vertices are specified by their parent domain
+  coordinates.  The M coordinates of the vertices are given by the array Arg4.
+  the N coordinates are given by Arg5.  Arg6 gives the number of vertices.
+
+  The Arg7 and Arg8 are the nesting ratios in M and N respectively; these
+  are the number of nest cells per parent cell in each dimension (e.g. 3
+  in MM5.)
+  The Arg9 and Arg10 arguments are trim arguments for adjusting a
+  logical (undecomposed) dimension of the nest from other than a multiple
+  of the number of parent domain cells in the dimension.
+
+  On return, Arg11 and Arg12 are set to the minimum local dimensions that
+  will be required for model arrays on the processor.  This is always
+  rectangular, even though the local processor partition may not be.
+  This also includes
+  additional memory for ghost points around the local processor partition
+  (the amount allocated will depend on the stencil specified by Arg3).
+  The Arg13 and Arg14 arguments will be set to the effective undecomposed
+  dimensions of the rectangle enclosing the irregularly shaped nest.
+
+  Example:
+
+$ C
+$ C Irregular nest outline specified by listing the vertices
+$ C of the polygonal domain.  These are parent domain coordinates.
+$ C
+$   ILIST( 1) = 15 ; JLIST( 1) =        18
+$   ILIST( 2) = 10 ; JLIST( 2) =        20
+$   ILIST( 3) = 10 ; JLIST( 3) =        27
+$   ILIST( 4) = 15 ; JLIST( 4) =        27
+$   ILIST( 5) = 20 ; JLIST( 5) =        32
+$   ILIST( 6) = 20 ; JLIST( 6) =        54
+$   ILIST( 7) = 39 ; JLIST( 7) =        54
+$   ILIST( 8) = 39 ; JLIST( 8) =        31
+$   ILIST( 9) = 26 ; JLIST( 9) =        18
+$   NVX = 9                   ! Number of vertices in polygon.
+$   BTRIM = 2                 ! trimming for MM5 nesting w/ Arakawa B-grid
+$   IRAX = 3                  ! nesting ratio
+$ CALL RSL_SPAWN_IRREG_NEST(
+$ +                NEST%RSL_ID, PARENT%RSL_ID,
+$ +                RSL_24PT,
+$ +                ILIST, JLIST, NVX,
+$ +                IRAX, IRAX,
+$ +                BTRIM, BTRIM,
+$ +                MLOC, NLOC,
+$ +                M,    N      )
+
+BREAKTHEEXAMPLECODE
+
+  A polygonal region of nesting is specified in the parent domain
+  by listing the coordinates of the vertices.  As with the other
+  nest spawning routines in RSL, MLOC and
+  NLOC are set to the minimum sizes of data arrays to hold the local
+  processor's allocation of the domain.  M and N are the global
+  dimensions (in nest coordiates) of the bounding box for the
+  irregularly shaped nest.
+
+
+  See also:
+  RSL_INITIALIZE, RSL_SPAWN_REGULAR_NEST
+
+@*/
+RSL_SPAWN_IRREG_NEST ( n_p, d_p, maskid_p,
+                       ypoints0, xpoints0, npoints_p,
+                       irax_m_p, irax_n_p,
+                       mtrim_p, ntrim_p,
+                       mloc_p, nloc_p,
+		       mlen_p, nlen_p )
+  int_p
+    n_p             /* (O) Handle to nested domain. */
+   ,d_p             /* (I) Handle to parent domain. */
+   ,maskid_p ;      /* (I) Id of maximum stencil for this domain. */
+  int
+    xpoints0[]       /* (I) List of M coordinates of nest shape vertices. */
+   ,ypoints0[] ;     /* (I) List of N coordinates of nest shape vertices. */
+  int_p
+    npoints_p       /* (I) Number of vertices in nest shape polygon. */
+   ,mtrim_p         /* (I) Number of points to trim from M dimension. */
+   ,ntrim_p         /* (I) Number of points to trim from N dimension. */
+   ,irax_m_p        /* (I) Nesting ratio in M dimension. */
+   ,irax_n_p        /* (I) Nesting ratio in N dimension. */
+   ,mloc_p          /* (O) Minimum local array size in M. */
+   ,nloc_p ;        /* (O) Minimum local array size in N. */
+  int_p
+    mlen_p          /* (O) Undecomposed size in M of enclosing rectangle. */
+   ,nlen_p ;        /* (O) Undecomposed size in N of enclosing rectangle. */
+{
+  int c ;
+  rsl_index_t i, j, in, jn ;
+  rsl_index_t d ;               /* number of mother domain */
+  rsl_index_t nest ;            /* number of nest domain */
+  int irax_m, irax_n ;
+  int xpoints[1024], ypoints[1024] ;
+
+  d = *d_p ;
+  irax_m = *irax_m_p ;
+  irax_n = *irax_n_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "invalid domain index") ;
+  RSL_TEST_ERR( *npoints_p >= 1024,
+    "internal error; see routine and recompile with larger arrays") ;
+
+  /* convert fortran point specs to C (zero based) */
+
+  for ( i = 0 ; i < *npoints_p ; i++ )
+  {
+     xpoints[i] = xpoints0[i] - 1 ;
+     ypoints[i] = ypoints0[i] - 1 ;
+  }
+
+  rsl_spawn_nest ( n_p, d_p, maskid_p, xpoints, ypoints, npoints_p,
+                   mtrim_p, ntrim_p,
+                   irax_m_p, irax_n_p, mloc_p, nloc_p, mlen_p, nlen_p ) ;
+
+  domain_info[*n_p].nestshape = RSL_RAGGED_NEST ;
+  domain_info[*n_p].trim_m = *mtrim_p ;
+  domain_info[*n_p].trim_n = *ntrim_p ;
+
+}
+
+rsl_spawn_nest ( nest_p, par_p, maskid_p,
+                 xpoints, ypoints, npoints_p,
+                 mtrim_p, ntrim_p,
+                 irax_m_p, irax_n_p,
+                 mloc_p, nloc_p, mlen_p, nlen_p )
+  int_p 
+    nest_p,
+    par_p,
+    maskid_p,
+    xpoints,
+    ypoints,       /* these are arrays */
+    npoints_p,
+    mtrim_p,
+    ntrim_p,       /* trim amounts */
+    irax_m_p,
+    irax_n_p ;
+  int_p
+    mloc_p,
+    nloc_p ;        /* output: local memory needs */
+  int_p
+    mlen_p,
+    nlen_p ;
+{
+  int par ;                     /* parent domain descriptor */
+  int nest ;                    /* nested domain descriptor */
+  int nmax_par, mmax_par ;      /* parent global dimensions */
+  int neff_par, meff_par ;      /* parent effective global dimensions */
+  int nmax_nes, mmax_nes ;      /* nest global dimensions */
+  int neff_nes, meff_nes ;      /* nest effective global dimensions */
+  int irax_m, irax_n ;          /* nesting ratio, m by n */
+  int npts ;
+  int i, j, m, n ;
+  int in, jn ;  /* nested domain cursors */
+  int which_kid_am_i_m, which_kid_am_i_n ;
+  int mid ;     /* mother point id */
+  int nid ;     /* nest point id */
+  int cm, cn ;  /* cursors for m, n dimension in children of cd point */
+  int im,ime ;  /* coordinate of first/last in mother domain */
+  int jm,jme ;  /* coordinate of first/last in mother domain */
+  int * work ;                  /* work array */
+  int mtrim, ntrim ;
+  int dmlow, dmhigh, dnlow, dnhigh, mmin, nmin ;
+  rsl_point_t *ppt, *p, *pdom, *ndom ; /* working point and domain pointers */
+
+  par = *par_p ;
+  npts = *npoints_p ;
+  irax_m = *irax_m_p ;
+  irax_n = *irax_n_p ;
+  mtrim = *mtrim_p ;
+  ntrim = *ntrim_p ;
+
+  RSL_TEST_ERR( par < 0 || par >= RSL_MAXDOMAINS,
+             "spawn_nest: bad parent domain index") ;
+  RSL_TEST_ERR( !domain_info[par].valid == RSL_VALID,
+                "spawn_nest: invalid parent domain") ;
+
+/* test for the existence of other, previously defined active nests at
+   this level. */
+  if ( old_offsets == 1 )
+  {
+    int i ;
+    for ( i = 1 ; i < RSL_MAXDOMAINS ; i++ )
+    {
+      RSL_TEST_ERR( 
+      (domain_info[i].valid == RSL_VALID && domain_info[i].parent == par ),
+      "Already a nest at this level; disallowed with old offsetting scheme.") ;
+    }
+  }
+
+  nmax_par = domain_info[par].len_n ;
+  mmax_par = domain_info[par].len_m ;
+  neff_par = domain_info[par].eff_n ;
+  meff_par = domain_info[par].eff_m ;
+
+  work = RSL_MALLOC( int,  nmax_par*mmax_par ) ;
+  for ( i = 0 ; i < nmax_par*mmax_par ; i++ )
+    work[i] = 0 ;
+
+  /* draw the polygon */
+  i = 0 ;
+  if ( xpoints[i] < 0 || xpoints[i] >= neff_par ||
+       ypoints[i] < 0 || ypoints[i] >= meff_par )
+  {
+    sprintf(mess,
+      "spawn_nest: point outside effective boundary of parent x=%d, y=%d\n",
+      xpoints[i], ypoints[i] ) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+  for ( i = 1 ; i < npts ; i++ )
+  {
+    if ( xpoints[i] < 0 || xpoints[i] >= neff_par ||
+         ypoints[i] < 0 || ypoints[i] >= meff_par )
+    {
+      sprintf(mess,
+        "spawn_nest: point outside effective boundary of parent x=%d, y=%d\n",
+        xpoints[i], ypoints[i] ) ;
+      RSL_TEST_ERR(1,mess) ;
+    }
+    mark_line( work, mmax_par, nmax_par,
+               xpoints[i-1], ypoints[i-1], 
+               xpoints[i],   ypoints[i], 1 ) ;
+  }
+  /* close polygon if not closed already
+     (if it is closed, this won't do anything) */
+  mark_line( work, mmax_par, nmax_par,
+             xpoints[0], ypoints[0], 
+             xpoints[npts-1], ypoints[npts-1], 1 ) ;
+
+  fill_region( work, mmax_par, nmax_par, 0, 2 ) ;
+
+  m = mmax_par ;
+  n = nmax_par ;
+
+  for ( j = 0 ; j < n ; j++ )
+    for ( i = 0 ; i < m ; i++ )
+    {
+      if ( work[ INDEX_2( j, i, m ) ] == 2 )
+        work[ INDEX_2( j, i, m ) ] = RSL_INVALID ;
+      else
+        work[ INDEX_2( j, i, m ) ] = RSL_VALID ;
+    }
+
+  /* at this point, the region of the c.d. that will have a nest has
+     been drawn.  Figure out how big a domain we need to hold this shape. */
+
+  /* work out min and max indices in i and j */
+  ime = -99999999 ;
+  jme = -99999999 ;
+  im  =  99999999 ;
+  jm  =  99999999 ;
+  for ( j = 0 ; j < n ; j++ )
+    for ( i = 0 ; i < m ; i++ )
+      if ( work[ INDEX_2( j, i, m ) ] == RSL_VALID )
+      {
+        if ( i > ime ) ime = i ;
+        if ( i < im ) im = i ;
+        if ( j > jme ) jme = j ;
+        if ( j < jm ) jm = j ;
+      }
+
+/* the nested dimensions */
+  nmax_nes = ( jme - jm + 1 ) * irax_n ;
+  mmax_nes = ( ime - im + 1 ) * irax_m ;
+  *nlen_p = nmax_nes - ntrim ;
+  *mlen_p = mmax_nes - mtrim ;
+
+/* create the nest */
+  GET_NEXT_DOMAIN_DESCRIPTOR ( &nest ) ;
+  *nest_p = nest ;
+  domain_info[nest].nest_level = domain_info[par].nest_level + 1 ;
+  rsl_ndomains++ ;
+  rsl_c_initialize_domain( nest,
+      nmax_nes, mmax_nes, 1, *nlen_p, *mlen_p, 1 ) ;
+  domain_info[nest].parent = par ;
+  domain_info[nest].maskid = *maskid_p ;
+
+/* the coordinate in the c.d. -- note, the coordinate point does not
+   have to be in the nest itself. */
+
+  domain_info[nest].coord_m = im ;
+  domain_info[nest].coord_n = jm ;
+  domain_info[nest].irax_m = irax_m ;
+  domain_info[nest].irax_n = irax_n ;
+
+  pdom = domain_info[par].domain ;
+  ndom = domain_info[nest].domain ;
+
+/* link up child pointers */
+  for ( j = jm ; j <= jme ; j++ )
+  {
+    for ( i = im ; i <= ime ; i++ )
+    {
+      if ( work[ INDEX_2( j, i, mmax_par ) ] == RSL_VALID )
+      {
+        ppt = &(pdom[ INDEX_2( j, i, mmax_par ) ]) ;
+        if ( ppt->children_p != NULL )
+        {
+          RSL_FREE(  ppt->children_p ) ;
+        }
+        ppt->children_p = RSL_MALLOC( rsl_child_info_t, 1 ) ;
+        mid = POINTID(par,j,i) ;
+        for ( cn = 0 ; cn < irax_n ; cn++ )
+        {
+          for ( cm = 0 ; cm < irax_m ; cm++ )
+          {
+            jn = (j-jm)*irax_n+cn ;
+            in = (i-im)*irax_m+cm ;
+            nid = POINTID( nest, jn, in ) ;
+            /* connect child pointers in mother domain */
+            ppt->children_p->child[ INDEX_2(cn,cm,irax_m) ] = nid ;
+            /* connect mother pointers in child domain */
+            ndom[INDEX_2(jn,in,mmax_nes)].mother_id = mid ;
+            ndom[INDEX_2(jn,in,mmax_nes)].which_kid_am_i_m = cm ;
+            ndom[INDEX_2(jn,in,mmax_nes)].which_kid_am_i_n = cn ;
+            /* mark the nested point as valid */
+            ndom[INDEX_2(jn,in,mmax_nes)].valid = RSL_VALID ;
+          }
+        }
+      }
+    }
+  }
+
+  trim_domain( ndom, mmax_nes, nmax_nes, mtrim, ntrim ) ;
+
+  debuggal_mine = 1 ;
+
+  work_out_bdy( ndom, mmax_nes, nmax_nes ) ;
+
+  if ( domain_info[par].decomposed == 0 )
+  {
+    int dum1, dum2 ;
+    default_decomposition( &par, &dum1, &dum2 ) ;
+    domain_info[par].decomposed = 1 ;
+  }
+  if ( domain_info[nest].decomposed == 0 )
+  {
+    default_decomposition( &nest, mloc_p, nloc_p ) ;
+    domain_info[nest].decomposed = 1 ;
+  }
+
+  RSL_FREE( work ) ;
+}
+
+
+/* 
+
+The effective size of a nest for purposes of computation on the
+nest is not necessarily it's actual size.  The actual size is
+constrained to be some multiple of the nesting ratio in each 
+dimension, whereas the effective size may be less (it is, in
+fact, 2 less in MM5).  An earlier version of R90 attempted to
+express this by simply invalidating the extra cells in the
+trim_domain routine after the nested domain had been defined.
+However, this caused problems for the broadcast/merges because
+although the extra cells do not participate in computation, they
+may receive data from a parent -- this happens in the case of
+dot-variables in a staggered B-grid (U and V in MM5).  The last
+row and column of the dot variables end up being passed down from
+the parent into the last+1 row and column of the nest (because
+of staggering).  If those cells are invalidated they will not
+participate in the bcast merge and this data is lost to the
+nest.  By trimming, but not invalidating the extra cells, they
+are allowed to participate in the bcast merge, but the section
+of R90 code that works out what cells are valid for computation
+(this is in rsl_new_decomp.c) can still avoid including them.
+jm 9/13/95.
+
+*/
+
+trim_domain( dom, mmax, nmax, mtrim, ntrim )
+  rsl_point_t *dom ;
+  int mmax, nmax, mtrim, ntrim ;
+{
+  int i, j, jj, ii, cnt ;
+  rsl_point_t *p, *pdiag, *pn, *pne, *pe ;
+
+  for ( j = nmax-1 ; j >= 0 ; j-- )
+  {
+    for ( i = mmax-1 ; i >= 0 ; i-- )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      p->trimmed = 0 ;
+    }
+  }
+
+  /* sweep down from high m and knock out first mtrim we hit */
+
+  for ( j = nmax-1 ; j >= 0 ; j-- )
+  {
+    cnt = 0 ;
+    for ( i = mmax-1 ; i >= 0 ; i-- )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID )
+      {
+	if ( cnt < mtrim )
+	{
+	  /* p->valid = RSL_INVALID ; */
+	  p->trimmed = 1 ;
+	  /* 1/22/96 -- handle inside northeast corners on irreg grids. jm */
+	  jj = j-cnt-1 ;
+	  if ( jj >= 0 )
+	  {
+	    pdiag = &(dom[INDEX_2(jj,i,mmax)]) ;
+	    if ( pdiag->valid == RSL_VALID )
+	    {
+	      pdiag->trimmed = 1 ;
+	    }
+	  }
+	  /* 1/22/96 -- end */
+	}
+	cnt++ ;
+      }
+      else
+	cnt = 0 ;
+    }
+  }
+  /* now do the same for ntrim */
+  for ( i = mmax-1 ; i >= 0 ; i-- )
+  {
+    cnt = 0 ;
+    for ( j = nmax-1 ; j >= 0 ; j-- )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID )
+      {
+        if ( cnt < ntrim )
+        {
+          /* p->valid = RSL_INVALID ; */
+	  p->trimmed = 1 ;
+          /* 1/22/96 -- handle inside northeast corners on irreg grids. jm */
+          ii = i-cnt-1 ;
+          if ( ii >= 0 )
+          {
+            pdiag = &(dom[INDEX_2(j,ii,mmax)]) ;
+            if ( pdiag->valid == RSL_VALID )
+            {
+              pdiag->trimmed = 1 ;
+            }
+          }
+          /* 1/22/96 -- end */
+        }
+        cnt++ ;
+      }
+      else
+        cnt = 0 ;
+    }
+  }
+
+/* set up cross grid points */
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = mmax-1 ; i >= 0 ; i-- )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      p->cross = 0 ;
+      if ( p->valid == RSL_VALID && ! p->trimmed )
+      {
+        if ( (i+1 < mmax) && (j+1 < nmax) )
+        {
+          if (    ((pn  =  &(dom[INDEX_2(j  ,i+1,mmax)])) != NULL )
+               && ((pne =  &(dom[INDEX_2(j+1,i+1,mmax)])) != NULL )
+               && ((pe  =  &(dom[INDEX_2(j+1,i  ,mmax)])) != NULL ) )
+          {
+            if ( ( pn->valid == RSL_VALID  &&  ! pn->trimmed  ) &&
+                 ( pne->valid == RSL_VALID &&  ! pne->trimmed ) &&
+                 ( pe->valid == RSL_VALID  &&  ! pe->trimmed  )  )
+            {
+              p->cross = 1 ;
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
+#ifndef NEC_TUNE
+#define PTEST(P) (!(P.valid==RSL_VALID && P.trimmed == 0)) 
+#define QTEST(P) (!(P.valid==RSL_VALID && P.trimmed == 0 && P.cross == 1 )) 
+#else
+#define PTEST(P) (!(P.valid==RSL_VALID & P.trimmed == 0)) 
+#define QTEST(P) (!(P.valid==RSL_VALID & P.trimmed == 0 & P.cross == 1 )) 
+#endif
+
+
+work_out_bdy( dom, mmax, nmax )
+  rsl_point_t *dom ;
+  int mmax, nmax ;
+{
+  int i, j, idx, in ;
+  int dmlow, dmhigh, dnlow, dnhigh ;
+  int d00, d0n, dm0, dmn ;
+  int min, closest ;
+  rsl_point_t *p ;
+  int *wrk_bdy1, *wrk_dbdy1 ;
+  int *wrk_bdy2, *wrk_dbdy2 ;
+#ifdef NEC_TUNE
+  int ii ;
+  int jj ;
+  int Tdmlow ;
+  int Tdmhigh ;
+  int Tdnlow ;
+  int Tdnhigh ;
+#endif
+
+/* this first section works out the distance and direction to the "closest"
+   boundary. */
+
+  wrk_bdy1 = RSL_MALLOC(int, mmax*nmax) ;
+  wrk_dbdy1 = RSL_MALLOC(int, mmax*nmax) ;
+  wrk_bdy2 = RSL_MALLOC(int, mmax*nmax) ;
+  wrk_dbdy2 = RSL_MALLOC(int, mmax*nmax) ;
+
+/* DOT GRID */
+#pragma csd parallel for private(j, i, idx, p)
+  for ( j = 0 ; j < nmax ; j++ )
+#pragma _CRI concurrent
+#pragma cdir nodep
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      p = &(dom[ idx ]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 )
+      {
+	wrk_bdy1[ idx ] = 0 ; wrk_dbdy1[ idx ] = 0 ;
+	wrk_bdy2[ idx ] = 0 ; wrk_dbdy2[ idx ] = 0 ;
+      }
+      else
+      {
+	wrk_bdy1[ idx ] = -1 ; wrk_dbdy1[ idx ] = -1 ;
+	wrk_bdy2[ idx ] = -1 ; wrk_dbdy2[ idx ] = -1 ;
+      }
+
+    }
+
+  fill_boundary( wrk_bdy1, wrk_dbdy1, mmax, nmax,	/* counter clockwise */
+		 1, -1, NORTH, SOUTH, EAST, WEST ) ;
+  fill_boundary( wrk_bdy2, wrk_dbdy2, mmax, nmax,	/* clockwise */
+		 0, -1, NORTH, SOUTH, EAST, WEST ) ;
+#pragma csd parallel for private(j, i, idx, p)
+  for ( j = 0 ; j < nmax ; j++ )
+#pragma _CRI concurrent
+#pragma cdir nodep
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+#ifndef NEC_TUNE
+      p = &(dom[ idx ]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 )
+      {
+	p->dbdy = wrk_dbdy1[ idx ] ;
+	p->bdy_cclockwise = wrk_bdy1[ idx ] ;
+	p->bdy_clockwise = wrk_bdy2[ idx ] ;
+      }
+      else
+      {
+	p->dbdy = RSL_INVALID ;
+	p->bdy_cclockwise = RSL_INVALID ;
+	p->bdy_clockwise = RSL_INVALID ;
+      }
+#else
+      if ( dom[idx].valid == RSL_VALID && dom[idx].trimmed == 0 )
+      {
+        dom[idx].dbdy = wrk_dbdy1[ idx ] ;
+        dom[idx].bdy_cclockwise = wrk_bdy1[ idx ] ;
+        dom[idx].bdy_clockwise = wrk_bdy2[ idx ] ; 
+      }
+      else
+      {
+        dom[idx].dbdy = RSL_INVALID ;
+        dom[idx].bdy_cclockwise = RSL_INVALID ;
+        dom[idx].bdy_clockwise = RSL_INVALID ;
+      }
+#endif
+    }
+
+/* CROSS GRID */
+#pragma csd parallel for private(j, i, idx, p)
+  for ( j = 0 ; j < nmax ; j++ )
+#pragma _CRI concurrent
+#pragma cdir nodep
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      p = &(dom[ idx ]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 && p->cross == 1 )
+      {
+	wrk_bdy1[ idx ] = 0 ; wrk_dbdy1[ idx ] = 0 ;
+	wrk_bdy2[ idx ] = 0 ; wrk_dbdy2[ idx ] = 0 ;
+      }
+      else
+      {
+	wrk_bdy1[ idx ] = -1 ; wrk_dbdy1[ idx ] = -1 ;
+	wrk_bdy2[ idx ] = -1 ; wrk_dbdy2[ idx ] = -1 ;
+      }
+
+    }
+
+  fill_boundary( wrk_bdy1, wrk_dbdy1, mmax, nmax,	/* counter clockwise */
+		 1, -1, NORTH, SOUTH, EAST, WEST ) ;
+  fill_boundary( wrk_bdy2, wrk_dbdy2, mmax, nmax,	/* clockwise */
+		 0, -1, NORTH, SOUTH, EAST, WEST ) ;
+
+#pragma csd parallel for private(j, i, idx, p)
+  for ( j = 0 ; j < nmax ; j++ )
+#pragma _CRI concurrent
+#pragma cdir nodep
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      p = &(dom[ idx ]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 && p->cross == 1 )
+      {
+	p->dbdy_x = wrk_dbdy1[ idx ] ;
+	p->bdy_x_cclockwise = wrk_bdy1[ idx ] ;
+	p->bdy_x_clockwise = wrk_bdy2[ idx ] ;
+      }
+      else
+      {
+	p->dbdy_x = RSL_INVALID ;
+	p->bdy_x_cclockwise = RSL_INVALID ;
+	p->bdy_x_clockwise = RSL_INVALID ;
+      }
+    }
+
+  RSL_FREE( wrk_bdy1 ) ;
+  RSL_FREE( wrk_dbdy1 ) ;
+  RSL_FREE( wrk_bdy2 ) ;
+  RSL_FREE( wrk_dbdy2 ) ;
+
+/* this second section works out the distances to each of the four boundaries
+   but does not take corners into account */
+
+#ifdef NO_RAGGED
+
+/* DOT GRID */
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 )
+      {
+        p->dist_mlow  = (i)+1 ;
+        p->dist_mhigh = (mmax-i) ;
+        p->dist_nlow  = (j)+1 ;
+        p->dist_nhigh = (nmax-j) ;
+      }
+    }
+  }
+/* CROSS GRID */
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 && p->cross == 1 )
+      {
+        p->dist_mlow_x  = (i)+1  ;              /* make 1 based for fortran */
+        p->dist_mhigh_x = (mmax-i) ;
+        p->dist_nlow_x  = (j)+1  ;
+        p->dist_nhigh_x = (nmax-j) ;
+      }
+    }
+  }
+
+#else
+
+/* DOT GRID */
+  /* work out boundary info -- this is a little tricky (and time consuming)
+     because we have to allow for irregularly shaped nests */
+#pragma csd parallel for private(j, i, p, dmlow, dmhigh, dnlow, dnhigh)
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 )
+      {
+        /* zip down til we find the mlow boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dmlow = 1 ; i-dmlow >= 0 ; dmlow++ )
+        {
+          if ( PTEST(dom[INDEX_2(j,i-dmlow,mmax)])) break ;
+        }
+        dmlow-- ;
+#else
+        for ( ii = 1 ; ii <= i ; ii++ )
+        {
+          if ( PTEST(dom[INDEX_2(j,i-ii,mmax)])) break ;
+        }
+        dmlow = ii - 1 ;
+        Tdmlow = dmlow ;
+#endif
+        /* zip up til we find the mhigh boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dmhigh = 1 ; i+dmhigh < mmax ; dmhigh++ )
+        {
+          if ( PTEST(dom[INDEX_2(j,i+dmhigh,mmax)])) break ;
+        }
+        dmhigh-- ;
+#else
+        for ( ii = 1 ; ii < mmax-i ; ii++ )
+        {
+          if ( PTEST(dom[INDEX_2(j,i+ii,mmax)])) break ;
+        }
+        dmhigh = ii - 1 ;
+        Tdmhigh = dmhigh ;
+#endif
+        /* zip west til we find the nlow boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dnlow = 1 ; j-dnlow >= 0 ; dnlow++ )
+        {
+          if ( PTEST(dom[INDEX_2(j-dnlow,i,mmax)])) break ;
+        }
+        dnlow-- ;
+#else
+        for ( jj = 1 ; jj <= j ; jj++ )
+        {
+          if ( PTEST(dom[INDEX_2(j-jj,i,mmax)])) break ;
+        }
+        dnlow = jj - 1 ;
+        Tdnlow = dnlow ;
+#endif
+        /* zip east til we find the nhigh boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dnhigh = 1 ; j+dnhigh < nmax ; dnhigh++ )
+        {
+          if ( PTEST(dom[INDEX_2(j+dnhigh,i,mmax)])) break ;
+        }
+        dnhigh-- ;
+#else
+        for ( jj = 1 ; jj < nmax-j ; jj++ )
+        {
+          if ( PTEST(dom[INDEX_2(j+jj,i,mmax)])) break ;
+        }
+        dnhigh = jj - 1 ;
+        Tdnhigh = dnhigh ;
+#endif
+
+        p->dist_mlow  = dmlow+1  ;		/* make 1 based for fortran */
+        p->dist_mhigh = dmhigh+1 ;
+        p->dist_nlow  = dnlow+1  ;
+        p->dist_nhigh = dnhigh+1 ;
+
+      }
+    }
+  }
+
+/* CROSS GRID */
+  /* work out boundary info -- this is a little tricky (and time consuming)
+     because we have to allow for irregularly shaped nests */
+#pragma csd parallel for private(j, i, p, dmlow, dmhigh, dnlow, dnhigh)
+  for ( j = 0 ; j < nmax-1 ; j++ )
+  {
+    for ( i = 0 ; i < mmax-1 ; i++ )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->valid == RSL_VALID && p->trimmed == 0 && p->cross == 1 )
+      {
+        /* zip down til we find the mlow boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dmlow = 1 ; i-dmlow >= 0 ; dmlow++ )
+        {
+          if ( QTEST(dom[INDEX_2(j,i-dmlow,mmax)])) break ;
+        }
+        dmlow-- ;
+#else
+        for ( ii = 1 ; ii <= i ; ii++ )
+        {
+          if ( QTEST(dom[INDEX_2(j,i-ii,mmax)])) break ;
+        }
+        dmlow = ii - 1 ;
+        Tdmlow = dmlow ;
+#endif
+        /* zip up til we find the mhigh boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dmhigh = 1 ; i+dmhigh < mmax ; dmhigh++ )
+        {
+          if ( QTEST(dom[INDEX_2(j,i+dmhigh,mmax)])) break ;
+        }
+        dmhigh-- ;
+#else
+        for ( ii = 1 ; ii < mmax-i ; ii++ )
+        {
+          if ( QTEST(dom[INDEX_2(j,i+ii,mmax)])) break ;
+        }
+        dmhigh = ii - 1 ;
+        Tdmhigh = dmhigh ;
+#endif
+        /* zip west til we find the nlow boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dnlow = 1 ; j-dnlow >= 0 ; dnlow++ )
+        {
+          if ( QTEST(dom[INDEX_2(j-dnlow,i,mmax)])) break ;
+        }
+        dnlow-- ;
+#else
+        for ( jj = 1 ; jj <= j ; jj++ )
+        {
+          if ( QTEST(dom[INDEX_2(j-jj,i,mmax)])) break ;
+        }
+        dnlow = jj - 1 ;
+        Tdnlow = dnlow ;
+#endif
+        /* zip east til we find the nhigh boundary */
+#ifndef NEC_TUNE
+#pragma _CRI concurrent
+        for ( dnhigh = 1 ; j+dnhigh < nmax ; dnhigh++ )
+        {
+          if ( QTEST(dom[INDEX_2(j+dnhigh,i,mmax)])) break ;
+        }
+        dnhigh-- ;
+#else
+        for ( jj = 1 ; jj < nmax-j ; jj++ )
+        {
+          if ( QTEST(dom[INDEX_2(j+jj,i,mmax)])) break ;
+        }
+        dnhigh = jj - 1 ;
+        Tdnhigh = dnhigh ;
+#endif
+
+        p->dist_mlow_x  = dmlow+1  ;		/* make 1 based for fortran */
+        p->dist_mhigh_x = dmhigh+1 ;
+        p->dist_nlow_x  = dnlow+1  ;
+        p->dist_nhigh_x = dnhigh+1 ;
+
+      }
+    }
+  }
+#endif
+}
+
+#if COMMENTED_OUT
+RSL_DEACTIVATE_DOMAIN ( d_p )
+  int_p d_p ;
+{
+  rsl_domain_info_t * ninfo ;
+  int d, P ;
+  int destroy_runrec() ;
+  int i ;
+
+  d = *d_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "invalid domain index") ;
+
+  domain_info[d].valid = RSL_INVALID ;
+  domain_info[d].decomposed = 0 ;
+
+  if ( domain_info[d].domain != NULL ) RSL_FREE( domain_info[d].domain ) ;
+
+  destroy_list( &(domain_info[d].pts), NULL ) ;
+  destroy_list( &(domain_info[d].ghost_pts), NULL ) ;
+  destroy_list( &(domain_info[d].iruns), destroy_runrec ) ;
+
+  if ( domain_info[d].js != NULL ) RSL_FREE( domain_info[d].js ) ;
+  if ( domain_info[d].is != NULL ) RSL_FREE( domain_info[d].is ) ;
+  if ( domain_info[d].ie != NULL ) RSL_FREE( domain_info[d].ie ) ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    ninfo->bcast_recv_Pnpts[P] = 0 ;
+    ninfo->bcast_recv_Plist[P] = RSL_INVALID ;
+    ninfo->bcast_recv_Ptags[P] = RSL_INVALID ;
+    ninfo->Nbcast_recv_Plist = 0 ;
+  }
+
+/* get rid of stencils on this domain */
+  for ( i = 0 ; i < domain_info[d].stencurs ; i++ )
+  {
+    if ( domain_info[d].stenlist[i] > 0 && 
+	 domain_info[d].stenlist[i] < RSL_MAXDESCRIPTORS )
+    {
+      destroy_stencil_on_domain( d,
+				 sh_descriptors[domain_info[d].stenlist[i]] ) ;
+    }
+  }
+  domain_info[d].stencurs = 0 ;
+
+}
+#endif
+
+
+/* this returns the first unused domain descriptor; it checks
+   for unusededness by seeing if the domain pointed to is valid 
+   or not.  If it's not, it's unused.  That's the only checking
+   that this thing does. */
+/* this can also be used to find out what the next descriptor
+   will be -- so it shouldn't, by itself, change the state of 
+   the domain descriptor as a result of being called */
+
+GET_NEXT_DOMAIN_DESCRIPTOR ( d_p )
+  int_p d_p ;
+{
+  int d ;
+
+  for ( d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    if ( domain_info[d].valid == RSL_INVALID )
+    {
+      break ;
+    }
+  }
+  RSL_TEST_ERR( d == RSL_MAXDOMAINS, "Out of domains." ) ;
+  *d_p = d ;
+}
+
+
+#if 0
+clear()
+{
+char clear[] = "" ;
+printf(clear) ;
+}
+
+
+if (debuggal_mine) {
+  int i, j, x ;
+  rsl_point_t *p ;
+  printf("------ in %d ------ bc: %d %d\n", in, breadcrumb_i, breadcrumb_j ) ;
+  for ( i = mmax-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < nmax ; j++ )
+    {
+      p = &(dom[INDEX_2(j,i,mmax)]) ;
+      if ( p->dbdy==-1 ) x = 0 ;
+      else x = p->dbdy % 10 ;
+      printf("%1d",x ) ;
+    }
+    printf("\n") ;
+  }
+/*
+  sleep(1) ;
+  clear() ;
+*/
+}
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/exch_period.c b/wrfv2_fire/external/RSL/RSL/exch_period.c
new file mode 100755
index 00000000..8787846e
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/exch_period.c
@@ -0,0 +1,306 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_EXCH_PERIOD - Exchange data on an RSL periodic boundary
+
+  Notes:
+
+  See also:
+
+@*/
+
+RSL_EXCH_PERIOD ( d_p, s_p, dir_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,s_p             /* (I) Period descriptor. */
+   ,dir_p ;         /* (I) RSL_M or RSL_N. */
+{
+  int d, s, dir ;
+  period_desc_t *per ;
+  message_desc_t *msg ;
+  rsl_procrec_t *procrec ;
+  rsl_ptrec_t *ptrec ;
+  rsl_list_t *lp, *lp1 ;
+  rsl_index_t ig, jg ;
+  rsl_point_hdr_t point_hdr ;
+  int i, ipt, sp, j ;
+  int curs ;
+  int nprocs, npts ;
+  int retval ;
+  int mtype, mdest ;
+  char * pbuf ;
+  int P ;
+  int Pque[RSL_MAXPROC] ;
+  rsl_procrec_t *procrecque[RSL_MAXPROC ] ;
+  int typeque[RSL_MAXPROC] ;
+  int tqp, ndone ;
+  packrec_t * pr ;
+  void * base ;
+
+int ts, te ;
+
+  d = *d_p ; s = *s_p ; 
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+  if      ( *dir_p == RSL_M )
+  {
+    dir = 0 ;
+  }
+  else if ( *dir_p == RSL_N )
+  {
+    dir = 1 ;
+  }
+  else
+  {
+    RSL_TEST_ERR( 1 , "invalid direction: must be RSL_M or RSL_N" ) ;
+  }
+
+
+#ifdef UPSHOT
+MPE_Log_event( 15, s, "period begin" ) ;
+#endif
+#if 0
+fprintf(stderr,"debug called RSL_EXCH_PERIOD %d\n",s ) ;
+#endif
+
+  per = (period_desc_t *) pr_descriptors[ s ] ;
+
+  /* if period has not been compiled, compile it now! */
+  if ( per->compiled[d] == 0 )
+  {
+    rsl_compile_period( d_p, s_p ) ;
+  }
+
+  /* post receives */
+  /* iterate over procrecs for domain and post buffers */
+
+  tqp = 0 ;
+  for ( procrec = per->procs[dir][d] ; procrec != NULL ; procrec = procrec->next )
+  {
+#if 0
+ fprintf(stderr,"A procrec->P %d\n",procrec->P) ;
+ fprintf(stderr,"  procrec->npts %d\n",procrec->npts) ;
+ fprintf(stderr,"  procrec->recv_npts %d\n",procrec->recv_npts) ;
+ fprintf(stderr,"  procrec->pack_table_size %d\n",procrec->pack_table_size) ;
+ fprintf(stderr,"  procrec->unpack_table_size %d\n",procrec->unpack_table_size) ;
+ fprintf(stderr,"  procrec->pack_table_nbytes %d\n",procrec->pack_table_nbytes) ;
+ fprintf(stderr,"  procrec->unpack_table_nbytes %d\n",procrec->unpack_table_nbytes) ;
+#endif
+    if ( procrec->unpack_table_nbytes > 0 )
+    {
+      P = procrec->P ;
+      Pque[tqp] = P ;
+      procrecque[tqp] = procrec ;
+      pbuf = buffer_for_proc( P, procrec->unpack_table_nbytes, RSL_RECVBUF ) ;
+      mtype = MTYPE_FROMTO( MSG_PERCOM, 
+			    rsl_c_comp2phys_proc (procrec->P), 
+			    rsl_myproc ) ;
+      typeque[tqp] = mtype ;
+      procrec->nrecvs++ ; /* diagnostic */
+#if 0
+fprintf(stderr,"debug posting async recv for %d bytes from %d\n", procrec->unpack_table_nbytes, rsl_c_comp2phys_proc (procrec->P) ) ;
+#endif
+      RSL_RECVBEGIN ( pbuf, procrec->unpack_table_nbytes, mtype ) ;
+      tqp++ ;
+    }
+  }
+  nprocs = tqp ;
+
+  /* pack buffers and issue sends */
+
+  for ( procrec = per->procs[dir][d] ; procrec != NULL ; procrec = procrec->next )
+  {
+    pbuf=buffer_for_proc(procrec->P, procrec->pack_table_nbytes, RSL_SENDBUF) ;
+    pr = procrec->pack_table ;
+    for ( curs = 0, i = 0 ; i < procrec->pack_table_size ; i++, pr++ )
+    {
+      if ( per->has_f90_fields && procrec->pack_table_size > 0 )
+        base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+      else
+        base = pr->base ;
+      for ( j = 0 ; j < pr->nelems ; j++ )
+      {
+#if 0
+fprintf(stderr,"pck base %08x, %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base),
+(char *)(base) + pr->offset + j * pr->stride,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+#endif
+        bcopy((char *)(base) + pr->offset + j * pr->stride,
+	      &(pbuf[curs]),pr->n) ;
+        curs += pr->n ;
+      }
+    }
+    if ( curs > 0 )
+    {
+      mdest = rsl_c_comp2phys_proc (procrec->P) ;
+      mtype = MTYPE_FROMTO( MSG_PERCOM, rsl_myproc, mdest ) ;
+      procrec->nsends++ ;
+      if ( curs > procrec->pack_table_nbytes ) 
+      {
+        sprintf(mess,"pack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#if 0
+fprintf(stderr,"debug sending %d bytes to %d\n", curs, mdest ) ;
+#endif
+#if 1
+      RSL_SEND ( pbuf, curs, mtype, mdest ) ;
+#else
+
+{ 
+   MPI_Request waitHandle ;
+   MPI_Isend (pbuf,
+              curs,
+              MPI_BYTE,
+              mdest,
+              mtype,
+              rsl_mpi_communicator,
+              &waitHandle);
+}
+
+#endif
+    }
+    else if ( curs == 0 && procrec->pack_table_nbytes != 0 )
+    {
+      RSL_TEST_ERR(1,"internal error") ;
+    }
+  }
+
+
+  /* wait on receives and unpack messages as they come in */
+  ndone = 0 ;
+  tqp = 0 ;
+  retval = 1 ;
+
+  while( ndone < nprocs )
+  {
+    if (tqp >= nprocs ) tqp = 0 ;
+    if (typeque[tqp] != RSL_INVALID)
+    {
+      mtype = typeque[tqp] ;
+      if ( rsl_noprobe == NULL )
+        RSL_PROBE ( mtype, &retval ) ;
+      /* else, retval will always be 1 */
+
+      if ( retval )
+      {
+#ifdef PGON
+/* on the Paragon, calling RSL_PROBE clears the message so this
+   would bomb on an unknown message id.  Don't call unless the probe
+   is disabled (rsl_noprobe != NULL). */
+        if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtype ) ;
+#else  
+        RSL_RECVEND ( mtype ) ;
+#endif
+
+	curs = 0 ;
+        pbuf = buffer_for_proc( Pque[tqp], 0, RSL_RECVBUF ) ;
+        procrec = procrecque[tqp] ;
+        pr = procrec->unpack_table ;
+        for ( curs = 0, i = 0 ; i < procrec->unpack_table_size ; i++, pr++ )
+	{
+          if ( per->has_f90_fields && procrec->unpack_table_size > 0 )
+            base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+          else
+            base = pr->base ;
+          for ( j = 0 ; j < pr->nelems ; j++ )
+          {
+#if 0
+fprintf(stderr,"uck base %08x, %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base),
+(char *)(base) + pr->offset + j * pr->stride,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+#endif
+            bcopy(&(pbuf[curs]),
+		 (char *)(base) + pr->offset + j * pr->stride, pr->n) ;
+            curs += pr->n ;
+	  }
+	}
+	if ( curs == 0 )
+	{
+	  RSL_TEST_ERR(1,"internal error") ;
+	}
+        if ( curs > procrec->unpack_table_nbytes )
+        {
+          sprintf(mess,"unpack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+          RSL_TEST_ERR(1,mess) ;
+	}
+#if 0
+fprintf(stderr,"debug got message from %d and unpacked %d bytes\n", Pque[tqp], curs ) ;
+#endif
+        typeque[tqp] = RSL_INVALID ;
+        ndone++ ;
+      }
+    }
+    tqp++ ;
+  }
+#ifdef UPSHOT
+MPE_Log_event( 16, s, "per end" ) ;
+#endif
+
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/exch_sten.c b/wrfv2_fire/external/RSL/RSL/exch_sten.c
new file mode 100755
index 00000000..cd7be996
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/exch_sten.c
@@ -0,0 +1,609 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_EXCH_STENCIL - Exchange data on an RSL stencil
+
+  Notes:
+  This routine is used to exchange data within domain Arg1 using
+  an RSL stencil, Arg2.
+  When this routine returns, data
+  in the ghost areas around the local partition will have been
+  updated with data from cells on surrounding processors, as
+  described in the stencil.  A stencil must have been described
+  in the context of a domain before it can be used on the domain
+  (RSL_DESCRIBE_STENCIL).
+
+  This routine generates interprocessor communication on message
+  passing architectures.
+
+  All processors must call RSL_EXCH_STENCIL at the same point in
+  the code.
+
+  See also:
+  RSL_CREATE_STENCIL, RSL_DESCRIBE_STENCIL
+
+@*/
+
+#ifndef crayx1
+
+#ifdef NEC_TUNE
+void copymem( void *src,    /* Source address (byte) */
+              int src_inc,  /* Stride between source per copy (bytes) */
+              void *dest,   /* Destination address (byte) */
+              int dest_inc, /* Stride between destination per copy (bytes) */
+              int nbytes,   /* Number of bytes to move per copy (bytes) */
+              int nelems )  /* Number of times to repeat copy */
+{
+  /* Byte based pointers. */
+  char * src1b ;
+  char * dest1b ;
+  /* 4 byte based pointers. */
+  int * src4b ;
+  int * dest4b ;
+  /* 8 byte based pointers. */
+  long * src8b ;
+  long * dest8b ;
+  int outer ;
+  int inner ;
+
+  if ( (((long)src | (long)dest | src_inc | dest_inc | nbytes) & (sizeof(int) -1)) == 0 )
+  {
+    src4b = (int *)(src) ;
+    dest4b = (int *)(dest) ;
+    src_inc /= sizeof(int) ;
+    dest_inc /= sizeof(int) ;
+
+    for ( outer = 0 ; outer < nbytes/sizeof(int) ; outer++ )
+    {
+#pragma cdir nodep
+      for ( inner = 0 ; inner < nelems ; inner++ )
+      {
+        dest4b[outer + inner*dest_inc] = src4b[outer + inner*src_inc] ;
+      }
+    }
+  }
+  else
+  {
+    src1b = (char *) (src) ;
+    dest1b = (char *) (dest) ;
+    for ( inner = 0 ; inner < nelems ; inner++ )
+    {
+      bcopy(src1b, dest1b, nbytes) ;
+      src1b += src_inc ;
+      dest1b += dest_inc ;
+    }
+  }
+} /* copymem */
+#endif
+
+RSL_EXCH_STENCIL ( d_p, s_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,s_p ;           /* (I) Stencil descriptor. */
+{
+  int d, s ;
+  stencil_desc_t *sten ;
+  message_desc_t *msg ;
+  rsl_procrec_t *procrec ;
+  rsl_ptrec_t *ptrec ;
+  rsl_list_t *lp, *lp1 ;
+  rsl_index_t ig, jg ;
+  rsl_point_hdr_t point_hdr ;
+  int i, ipt, sp, j ;
+  int curs ;
+  int nprocs, npts ;
+  int retval ;
+  int mtype, mdest ;
+  char * pbuf ;
+  int P ;
+  int Pque[RSL_MAXPROC] ;
+  rsl_procrec_t *procrecque[RSL_MAXPROC ] ;
+  int typeque[RSL_MAXPROC] ;
+  int tqp, ndone ;
+  void * base ;
+  packrec_t * pr ;
+
+
+  d = *d_p ; s = *s_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+
+#ifdef UPSHOT
+MPE_Log_event( 15, s, "sten begin" ) ;
+#endif
+#if 0
+fprintf(stderr,"debug called RSL_EXCH_STENCIL %d\n",s ) ;
+#endif
+
+  if ((sten = (stencil_desc_t *) sh_descriptors[ s ]) == NULL )
+  {
+    RSL_TEST_ERR(1,"invalid or unspecified stencil descriptor" ) ;
+  }
+
+  /* if stencil has not been compiled, compile it now! */
+  if ( sten->compiled[d] == 0 )
+  {
+    rsl_compile_stencil( d_p, s_p ) ;
+  }
+
+  /* post receives */
+  /* iterate over procrecs for domain and post buffers */
+
+  tqp = 0 ;
+  for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+  {
+    if ( procrec->unpack_table_nbytes > 0 )
+    {
+      P = procrec->P ;
+      Pque[tqp] = P ;
+      procrecque[tqp] = procrec ;
+      pbuf = buffer_for_proc( P, procrec->unpack_table_nbytes, RSL_RECVBUF ) ;
+      mtype = MTYPE_FROMTO( MSG_STENCOM, 
+                            rsl_c_comp2phys_proc (procrec->P), 
+                            rsl_myproc ) ;
+      typeque[tqp] = mtype ;
+      procrec->nrecvs++ ; /* diagnostic */
+#if 0
+fprintf(stderr,"debug posting async recv for %d bytes from %d\n", procrec->unpack_table_nbytes, rsl_c_comp2phys_proc (procrec->P) ) ;
+#endif
+      RSL_RECVBEGIN ( pbuf, procrec->unpack_table_nbytes, mtype ) ;
+      tqp++ ;
+    }
+  }
+  nprocs = tqp ;
+
+  /* pack buffers and issue sends */
+
+  for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+  {
+    pbuf=buffer_for_proc(procrec->P, procrec->pack_table_nbytes, RSL_SENDBUF) ;
+    pr = procrec->pack_table ;
+    for ( curs = 0, i = 0 ; i < procrec->pack_table_size ; i++, pr++ )
+    {
+      if ( sten->has_f90_fields && procrec->pack_table_size > 0 )
+        base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+      else
+        base =  pr->base ;
+#if 0
+fprintf(stderr,"pack   base %lu, f90_index %d, sten=%d\n",base,pr->f90_table_index,s) ;
+#endif
+#ifndef NEC_TUNE
+      for ( j = 0 ; j < pr->nelems ; j++ )
+      {
+
+#if 0
+if ( rsl_debug_flg ) {
+fprintf(stderr,"pck %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base) + pr->offset + j * pr->stride,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+}
+#endif
+
+        bcopy((char *)(base) + pr->offset + j * pr->stride,
+	      &(pbuf[curs]),pr->n) ;
+        curs += pr->n ;
+      }
+#else
+      copymem((char *)(base) + pr->offset, pr->stride, &(pbuf[curs]), pr->n, pr->n, pr->nelems) ;
+      curs += pr->n*pr->nelems ;
+#endif
+    }
+    if ( curs > 0 )
+    {
+      mdest = rsl_c_comp2phys_proc (procrec->P) ;
+      mtype = MTYPE_FROMTO( MSG_STENCOM, rsl_myproc, mdest ) ;
+      procrec->nsends++ ;
+      if ( curs > procrec->pack_table_nbytes ) 
+      {
+        sprintf(mess,"pack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#if 0
+fprintf(stderr,"debug sending %d bytes to %d, sten=%d\n", curs, mdest, s ) ;
+#endif
+      RSL_SEND ( pbuf, curs, mtype, mdest ) ;
+    }
+    else if ( curs == 0 && procrec->pack_table_nbytes != 0 )
+    {
+      RSL_TEST_ERR(1,"internal error") ;
+    }
+  }
+
+  /* wait on receives and unpack messages as they come in */
+  ndone = 0 ;
+  tqp = 0 ;
+  retval = 1 ;
+
+  while( ndone < nprocs )
+  {
+    if (tqp >= nprocs ) tqp = 0 ;
+    if (typeque[tqp] != RSL_INVALID)
+    {
+      mtype = typeque[tqp] ;
+      if ( rsl_noprobe == NULL )
+        RSL_PROBE ( mtype, &retval ) ;
+      /* else, retval will always be 1 */
+
+      if ( retval )
+      {
+#ifdef PGON
+/* on the Paragon, calling RSL_PROBE clears the message so this
+   would bomb on an unknown message id.  Don't call unless the probe
+   is disabled (rsl_noprobe != NULL). */
+        if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtype ) ;
+#else  
+        RSL_RECVEND ( mtype ) ;
+#endif
+
+	curs = 0 ;
+        pbuf = buffer_for_proc( Pque[tqp], 0, RSL_RECVBUF ) ;
+        procrec = procrecque[tqp] ;
+        pr = procrec->unpack_table ;
+        for ( curs = 0, i = 0 ; i < procrec->unpack_table_size ; i++, pr++ )
+	{
+          if ( sten->has_f90_fields && procrec->unpack_table_size > 0 )
+            base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+          else
+            base = pr->base ;
+#if 0
+fprintf(stderr,"unpack base %lu, f90_index %d, sten=%d\n",base,pr->f90_table_index,s) ;
+#endif
+#ifndef NEC_TUNE
+          for ( j = 0 ; j < pr->nelems ; j++ )
+          {
+            bcopy(&(pbuf[curs]),
+		 (char *)(base) + pr->offset + j * pr->stride, pr->n) ;
+            curs += pr->n ;
+	  }
+#else
+          copymem(&(pbuf[curs]), pr->n, (char *)(base) + pr->offset, pr->stride, pr->n, pr->nelems) ;
+          curs += pr->n*pr->nelems ;
+#endif
+	}
+	if ( curs == 0 )
+	{
+	  RSL_TEST_ERR(1,"internal error") ;
+	}
+        if ( curs > procrec->unpack_table_nbytes )
+        {
+          sprintf(mess,"unpack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+          RSL_TEST_ERR(1,mess) ;
+	}
+#if 0
+fprintf(stderr,"debug got message from %d and unpacked %d bytes; sten=%d\n", Pque[tqp], curs, s ) ;
+#endif
+        typeque[tqp] = RSL_INVALID ;
+        ndone++ ;
+      }
+    }
+    tqp++ ;
+  }
+#ifdef UPSHOT
+MPE_Log_event( 16, s, "sten end" ) ;
+#endif
+
+}
+
+
+#else
+
+
+RSL_EXCH_STENCIL ( d_p, s_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,s_p ;           /* (I) Stencil descriptor. */
+{
+  int d, s ;
+  stencil_desc_t *sten ;
+  rsl_procrec_t *procrec ;
+  int i,j ;
+  int curs ;
+  int nprocs ;
+  int retval ;
+  int mtype, mdest ;
+  char * pbuf ;
+  int P ;
+  int Pque[RSL_MAXPROC] ;
+  rsl_procrec_t *procrecque[RSL_MAXPROC ] ;
+  int typeque[RSL_MAXPROC] ;
+  int tqp, ndone ;
+  void * base ;
+
+  packrec_t * pr ;
+
+  d = *d_p ; s = *s_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+
+#ifdef UPSHOT
+MPE_Log_event( 15, s, "sten begin" ) ;
+#endif
+#if 0
+fprintf(stderr,"debug called RSL_EXCH_STENCIL %d\n",s ) ;
+#endif
+
+  if ((sten = (stencil_desc_t *) sh_descriptors[ s ]) == NULL )
+  {
+    RSL_TEST_ERR(1,"invalid or unspecified stencil descriptor" ) ;
+  }
+
+  /* if stencil has not been compiled, compile it now! */
+  if ( sten->compiled[d] == 0 )
+  {
+    rsl_compile_stencil( d_p, s_p ) ;
+                                                                                       
+    /* fill in curs value for pack and unpack buffers */
+    for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+    {
+      /* determine offset into pack buffer for each element */
+      pr = procrec->pack_table ;
+      if ( procrec->pack_table_nbytes > 0 )
+      {
+        for ( curs = 0, i = 0 ; i < procrec->pack_table_size ; i++, pr++ )
+        {
+          pr->curs = curs;
+          curs += pr->nelems * pr->n;
+        }
+//        fprintf(stderr, "pack %d %d\n", curs, procrec->pack_table_nbytes);
+      }
+      /* determine offset into unpack buffer for each element */
+      if ( procrec->unpack_table_nbytes > 0 )
+      {
+        pr = procrec->unpack_table ;
+        for ( curs = 0, i = 0 ; i < procrec->unpack_table_size ; i++, pr++ )
+        {
+          pr->curs = curs;
+          curs += pr->nelems * pr->n;
+        }
+//        fprintf(stderr, "unpack %d %d\n", curs, procrec->unpack_table_nbytes);
+      }
+    }
+  }
+
+  /* post receives */
+  /* iterate over procrecs for domain and post buffers */
+
+  tqp = 0 ;
+  for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+  {
+    if ( procrec->unpack_table_nbytes > 0 )
+    {
+      P = procrec->P ;
+      Pque[tqp] = P ;
+      procrecque[tqp] = procrec ;
+      pbuf = buffer_for_proc( P, procrec->unpack_table_nbytes, RSL_RECVBUF ) ;
+      mtype = MTYPE_FROMTO( MSG_STENCOM, 
+                   rsl_c_comp2phys_proc (procrec->P), rsl_myproc ) ;
+      typeque[tqp] = mtype ;
+      procrec->nrecvs++ ; /* diagnostic */
+#if 0
+fprintf(stderr,"debug posting async recv for %d bytes from %d\n", procrec->unpack_table_nbytes, rsl_c_comp2phys_proc (procrec->P) ) ;
+#endif
+      RSL_RECVBEGIN ( pbuf, procrec->unpack_table_nbytes, mtype ) ;
+      tqp++ ;
+    }
+  }
+  nprocs = tqp ;
+
+  /* pack buffers and issue sends */
+
+  for ( procrec = sten->procs[d] ; procrec != NULL ; procrec = procrec->next )
+  {
+
+    pbuf=buffer_for_proc(procrec->P, procrec->pack_table_nbytes, RSL_SENDBUF) ;
+
+#pragma csd parallel for private(i, pr, base)
+    for ( i = 0 ; i < procrec->pack_table_size ; i++ )
+    {
+      int inc, nwrds;
+      int *bufin, *bufout;
+
+      pr = &procrec->pack_table[i];
+
+      if ( sten->has_f90_fields && procrec->pack_table_size > 0 )
+        base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+      else
+        base =  pr->base ;
+#if 0
+fprintf(stderr,"pack   base %lu, f90_index %d, sten=%d\n",base,pr->f90_table_index,s) ;
+#endif
+#pragma no_cache_alloc bufin bufout
+      bufin = (int *)(base) + (pr->offset >> 2);
+      bufout = (int *)(pbuf) + (pr->curs >> 2);
+      inc = pr->stride >> 2;
+      nwrds = pr->n >> 2;
+      if (nwrds < 64) {
+        int j, k;
+        for (j = 0; j < nwrds; j++) {
+#pragma _CRI ivdep
+#pragma prefervector 
+#pragma cdir nodep
+           for (k = 0; k < pr->nelems; k++) {
+              bufout[k*nwrds+j] = bufin[k*inc+j];
+           }
+        }
+      }
+      else {
+        int j, k;
+        int iwd = 0;
+        int iwd2 = 0;
+        for (j = 0; j < pr->nelems; j++) {
+#pragma _CRI ivdep
+#pragma cdir nodep
+          for (k = 0; k < nwrds; k++) {
+            bufout[iwd++] = bufin[iwd2+k];
+          }
+          iwd2 += inc;
+        }
+      }
+    }
+
+    curs = procrec->pack_table_nbytes;
+    if ( curs > 0 )
+    {
+      mdest = rsl_c_comp2phys_proc (procrec->P) ;
+      mtype = MTYPE_FROMTO( MSG_STENCOM, rsl_myproc, mdest ) ;
+      procrec->nsends++ ;
+#if 0
+fprintf(stderr,"debug sending %d bytes to %d, sten=%d\n", curs, mdest, s ) ;
+#endif
+      RSL_SEND ( pbuf, curs, mtype, mdest ) ;
+    }
+  }
+
+  /* wait on receives and unpack messages as they come in */
+  ndone = 0 ;
+  tqp = 0 ;
+  retval = 1 ;
+
+  while( ndone < nprocs )
+  {
+    if (tqp >= nprocs ) tqp = 0 ;
+    if (typeque[tqp] != RSL_INVALID)
+    {
+      mtype = typeque[tqp] ;
+      if ( rsl_noprobe == NULL )
+        RSL_PROBE ( mtype, &retval ) ;
+      /* else, retval will always be 1 */
+
+      if ( retval )
+      {
+#ifdef PGON
+/* on the Paragon, calling RSL_PROBE clears the message so this
+   would bomb on an unknown message id.  Don't call unless the probe
+   is disabled (rsl_noprobe != NULL). */
+        if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtype ) ;
+#else  
+        RSL_RECVEND ( mtype ) ;
+#endif
+
+        pbuf = buffer_for_proc( Pque[tqp], 0, RSL_RECVBUF ) ;
+        procrec = procrecque[tqp] ;
+#pragma csd parallel for private(i, pr, base)
+        for ( i = 0 ; i < procrec->unpack_table_size ; i++ )
+        {
+          int inc, nwrds;
+          int *bufin, *bufout;
+#pragma no_cache_alloc bufin bufout
+
+          pr = &procrec->unpack_table[i] ;
+
+          if ( sten->has_f90_fields && procrec->unpack_table_size > 0 )
+            base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+          else
+            base = pr->base ;
+#if 0
+fprintf(stderr,"unpack base %lu, f90_index %d, sten=%d\n",base,pr->f90_table_index,s) ;
+#endif
+
+          bufin = (int *)(pbuf) + (pr->curs >> 2);
+          bufout = (int *)(base) + (pr->offset >> 2);
+          inc = pr->stride >> 2;
+          nwrds = pr->n >> 2;
+          if (nwrds < 64) {
+            int j, k;
+            for (j = 0; j < nwrds; j++) {
+#pragma _CRI ivdep
+#pragma prefervector 
+#pragma cdir nodep
+                for (k = 0; k < pr->nelems; k++) {
+                bufout[k*inc+j] = bufin[k*nwrds+j];
+              }
+            }
+          }
+          else {
+            int j, k;
+            int iwd = 0;
+            int iwd2 = 0;
+            for (j = 0; j < pr->nelems; j++) {
+#pragma _CRI ivdep
+#pragma cdir nodep
+              for (k = 0; k < nwrds; k++) {
+                bufout[iwd2+k] = bufin[iwd++];
+              }
+              iwd2 += inc;
+            }
+          }
+        }
+
+#if 0
+fprintf(stderr,"debug got message from %d and unpacked %d bytes; sten=%d\n", Pque[tqp], curs, s ) ;
+#endif
+        typeque[tqp] = RSL_INVALID ;
+        ndone++ ;
+      }
+    }
+    tqp++ ;
+  }
+#ifdef UPSHOT
+MPE_Log_event( 16, s, "sten end" ) ;
+#endif
+}
+
+
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/fill_boundary.c b/wrfv2_fire/external/RSL/RSL/fill_boundary.c
new file mode 100755
index 00000000..161ac37b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fill_boundary.c
@@ -0,0 +1,547 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+/*
+   Given a work array with the in-valid entries marked with invalid,
+   Traverse the boundaries and figure the distances using the snake
+   and breadcrumb method: start at an outer point, leave a breadcrumb
+   and snake around either clockwise or counterclockwise (value of rot)
+   feeling the left or right edge respectively, until you get back to the
+   breadcrumb, then jump in and start the next boundary.  Each valid
+   cell is marked with an integer signifying its distance from the boundary
+   (1 is the outermost valid row or column).
+
+   The points are also marked with the code for which boundary they are
+   closest to.  How corners are marked will depend on which direction
+   the rotation occured.  Therefore, one may wish to compute two
+   traversals, and then difference them.  Any points that come up
+   different can be resolved by the differencing algorithm with an
+   east-west wins, north-south wins, or diagonal-separate policy.
+
+   the array bdy countains the invalid markings
+   the array dbdy, may be uninitialized
+   m is assumed to be minor and the north-south dimension.
+   n is assumed to be major and the east-west dimension.
+   the integer boundary tags are passed in.
+
+   returns zero for success, non-zero for failure 
+
+*/
+
+#include "rsl.h"
+
+#ifndef INDEX_2
+# define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+#endif
+#ifndef INDEX_3
+# define INDEX_3(A,B,NB,C,NC)  INDEX_2((A),INDEX_2((B),(C),(NC)),(NB)*(NC))
+#endif
+#ifndef RSL_MALLOC
+# define RSL_MALLOC(T,N)  (T *)rsl_malloc(__FILE__,__LINE__,(sizeof(T))*(N))
+#endif
+#ifndef RSL_TEST_ERR
+# define RSL_TEST_ERR(T,M) {if(T){fprintf(stderr,"error (\"%s\":%d) %s\n",__FILE__,__LINE__,M);RSL_FATAL(5);}}
+#endif
+#ifndef RSL_FATAL
+# define RSL_FATAL(X) exit(X)
+#endif
+
+static int bc_i, bc_j, dir ;    /* breadcrumb indices */
+static int in ;
+
+
+/* fortran wrapper */
+#ifdef NOUNDERSCORE
+fill_bdy( bdy, dbdy, mmax, nmax, rot, invalid, ntag, stag, etag, wtag )
+#else
+# ifdef F2CSTYLE
+fill_bdy__( bdy, dbdy, mmax, nmax, rot, invalid, ntag, stag, etag, wtag )
+# else
+fill_bdy_( bdy, dbdy, mmax, nmax, rot, invalid, ntag, stag, etag, wtag )
+# endif
+#endif
+  int * bdy ;     /* boundary associations, on entry contains invalid entries */
+  int * dbdy ;    /* distances to boundaries, may be unitialized */
+  int * mmax,     /* minor n/s dimension of arrays */
+      * nmax ;    /* major e/w dimension of arrays */
+  int * rot ;     /* rotation 1=counterclockwise, 0=clockwise */
+  int * invalid ; /* integer value of an invalid point */
+  int * ntag ;    /* tag for north boundary assn */
+  int * stag ;    /* tag for south boundary assn */
+  int * etag ;    /* tag for east  boundary assn */
+  int * wtag ;    /* tag for west  boundary assn */
+{
+ fill_boundary( bdy, dbdy, *mmax, *nmax, *rot, *invalid,
+                *ntag, *stag, *etag, *wtag ) ;
+}
+
+fill_boundary( bdy, dbdy, mmax, nmax, rot, invalid, ntag, stag, etag, wtag )
+  int * bdy ;   /* boundary associations, on entry contains invalid entries */
+  int * dbdy ;  /* distances to boundaries, may be unitialized */
+  int mmax,     /* minor n/s dimension of arrays */
+      nmax ;    /* major e/w dimension of arrays */
+  int rot ;     /* rotation 1=counterclockwise, 0=clockwise */
+  int invalid ; /* integer value of an invalid point */
+  int ntag ;    /* tag for north boundary assn */
+  int stag ;    /* tag for south boundary assn */
+  int etag ;    /* tag for east  boundary assn */
+  int wtag ;    /* tag for west  boundary assn */
+{
+  int i, j, retval ;
+
+  if ( bdy == NULL && dbdy == NULL ) return(1) ;
+
+  retval = 0 ; 
+
+  /* initialized distances array -- nextcell relies on this */
+  for ( i = 0 ; i < mmax*nmax ; i++ ) dbdy[i] = -1 ;
+
+  in = 0 ;
+  while ( ! place_to_start( bdy, dbdy, mmax, nmax, rot,
+                            &i, &j, 
+                            invalid, ntag, stag, etag, wtag,
+                            &dir ) )
+  {
+    bc_i = i ;
+    bc_j = j ;
+    /* recursive */
+    in++ ;
+    retval = fill_boundary_1( bdy, dbdy, mmax, nmax, rot, i, j,
+                              invalid, ntag, stag, etag, wtag ) ;
+  }
+  return( retval ) ;
+}
+
+fill_boundary_1( bdy, dbdy, mmax, nmax, rot, i, j,
+                 invalid, ntag, stag, etag, wtag )
+  int * bdy ;   /* boundary associations, on entry contains invalid entries */
+  int * dbdy ;  /* distances to boundaries, initialized to -1 */
+  int mmax,     /* minor n/s dimension of arrays */
+      nmax ;    /* major e/w dimension of arrays */
+  int rot ;     /* rotation 1=counterclockwise, 0=clockwise */
+  int i, j ;    /* current point */
+  int invalid ; /* integer value of an invalid point */
+  int ntag ;    /* tag for north boundary assn */
+  int stag ;    /* tag for south boundary assn */
+  int etag ;    /* tag for east  boundary assn */
+  int wtag ;    /* tag for west  boundary assn */
+
+{
+  int idx ;     /* index of point */
+  int fbc ;     /* found bread crumb */
+  int i2, j2 ;
+  int retval ;
+
+  idx = INDEX_2(j,i,mmax) ;
+
+  dbdy[ idx ] = in ;
+  bdy[ idx ] = bdy_from_dir( dir, rot, ntag, stag, etag, wtag ) ;
+
+
+#if 0
+if ( in >= 15 ) {
+  int i, j, idx ;
+  char x ;
+  printf("------ in %d ------ bc: %d %d\n", in, bc_i, bc_j ) ;
+  for ( i = mmax-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < nmax ; j++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      if ( dbdy[idx]==-1 ) x = '.' ;
+      else x = (dbdy[idx] % 10) + '0' ;
+      printf("%1c",x ) ;
+    }
+    printf("\n") ;
+  }
+/*  sleep(1) ; */
+/*  clear() ; */
+}
+#endif
+
+  while ( nextcell( bdy, dbdy, mmax, nmax, rot, i, j, in, &i2, &j2, &fbc,
+                    invalid, ntag, stag, etag, wtag ) )
+  {
+    if ( fbc )
+    {
+      bc_i = i2 ;
+      bc_j = j2 ;
+      /* recurse */
+      in++ ;
+      retval = fill_boundary_1( bdy, dbdy, mmax, nmax, rot, i2, j2,
+                                invalid, ntag, stag, etag, wtag ) ;
+      break ;
+    }
+    else
+    {
+      idx = INDEX_2(j2,i2,mmax) ;
+      dbdy[ idx ] = in ;
+      bdy[ idx ] = bdy_from_dir( dir, rot, ntag, stag, etag, wtag ) ;
+    }
+    i = i2 ;
+    j = j2 ;
+  }
+#if 0
+if ( in >= 15 ) {
+  char x ;
+  int i, j,  idx ;
+  printf("------ in %d ------ bc: %d %d\n", in, bc_i, bc_j ) ;
+  for ( i = mmax-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < nmax ; j++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      if ( dbdy[idx]==-1 ) x = '.' ;
+      else x = (dbdy[idx] % 10) + '0' ;
+      printf("%1c",x ) ;
+    }
+    printf("\n") ;
+  }
+/*  sleep(1) ; */
+/*  clear() ; */
+}
+#endif
+  return(retval) ;
+}
+
+nextcell( bdy, dbdy, mmax, nmax, rot, i, j, in, i2, j2, fbc,
+          invalid, ntag, stag, etag, wtag )
+  int * bdy ;   /* boundary associations, on entry contains invalid entries */
+  int * dbdy ;  /* distances to boundaries, initialized to -1 */
+  int mmax,     /* minor n/s dimension of arrays */
+      nmax ;    /* major e/w dimension of arrays */
+  int rot ;     /* rotation 1=counterclockwise, 0=clockwise */
+  int i, j ;    /* current point */
+  int in ;      /* how far into domain on this instantiation of routine */
+  int *i2,*j2 ;	/* new point */
+  int *fbc ;    /* found bread crumb */
+  int invalid ; /* integer value of an invalid point */
+  int ntag ;    /* tag for north boundary assn */
+  int stag ;    /* tag for south boundary assn */
+  int etag ;    /* tag for east  boundary assn */
+  int wtag ;    /* tag for west  boundary assn */
+{
+  int cnt, try, fail ;
+  int ii, jj, idx ;
+
+  *fbc = 0 ;
+  for ( cnt = 0 ; cnt < 4 ; cnt++ )
+  {
+    if ( rot ) 		/* counter clockwise */
+    {
+      if      ( dir == ntag )
+      {
+      /* going north; try to go east */
+        ii = i  ; jj = j+1 ; try = etag ; fail = wtag ;
+      }
+      else if ( dir == etag )
+      {
+      /* going east; try to go south */
+        ii = i-1 ; jj = j   ; try = stag ; fail = ntag ;
+      }
+      else if ( dir == stag )
+      {
+      /* going south; try to go west */
+        ii = i   ; jj = j-1 ; try = wtag ; fail = etag ;
+      }
+      else if ( dir == wtag )
+      {
+      /* going west; try to go north */
+        ii = i+1 ; jj = j   ; try = ntag ; fail = stag ;
+      }
+      else
+      {
+        RSL_TEST_ERR(1,"method failure") ;
+      }
+    }
+    else   		/* clockwise */
+    {
+      if      ( dir == ntag )
+      {
+      /* going north; try to go west */
+        ii = i   ; jj = j-1 ; try = wtag ; fail = etag ;
+      }
+      else if ( dir == etag )
+      {
+      /* going east; try to go north */
+        ii = i+1 ; jj = j   ; try = ntag ; fail = stag ;
+      }
+      else if ( dir == stag )
+      {
+      /* going south; try to go east */
+        ii = i   ; jj = j+1 ; try = etag ; fail = wtag ;
+      }
+      else if ( dir == wtag )
+      {
+      /* going west; try to go south */
+        ii = i-1 ; jj = j   ; try = stag ; fail = ntag ;
+      }
+      else
+      {
+        RSL_TEST_ERR(1,"method failure") ;
+      }
+    }
+    if ( ii >= 0 && ii < mmax && jj >= 0 && jj < nmax )
+    {
+      if ( ii == bc_i && jj == bc_j )
+      {
+        *fbc = 1 ;
+      }
+      idx = INDEX_2(jj,ii,mmax) ;
+      dir = try ;
+      *i2 = ii ; *j2 = jj ;
+      if ( bdy[idx] != invalid &&
+          (dbdy[idx] == -1 || (dbdy[idx] == in && ! *fbc )))
+                  /* this business (prev line) allows backtracking */
+      {
+        return(1) ;
+      }
+    }
+    dir = fail ;
+  }
+  return(0) ;
+}
+
+/***********************
+  Table for bdy_from_dir
+                             boundary associating for rotation
+      going             rot=1 (counterclock)    rot=0 (clockwise)
+      ---------------------------------------------------
+      north             east                    west
+      east              south                   north
+      south             west                    east
+      west              north                   south
+
+
+************************/
+bdy_from_dir( dir, rot, ntag, stag, etag, wtag )
+  int dir ;                     /* current direction */
+  int rot ;                     /* rotation (see table) */
+  int ntag, stag, etag, wtag ;  /* direction tags */
+{
+  int bdy ;
+
+  if      ( dir == ntag )
+    bdy = (rot?etag:wtag) ;  /* if north, then east  bdy */
+  else if ( dir == etag )
+    bdy = (rot?stag:ntag) ;  /* if east , then south bdy */
+  else if ( dir == stag )
+    bdy = (rot?wtag:etag) ;  /* if south, then west  bdy */
+  else if ( dir == wtag )
+    bdy = (rot?ntag:stag) ;  /* if west , then north bdy */
+  else
+    RSL_TEST_ERR(1,"bad tag") ;
+
+  return( bdy ) ;
+}
+
+/* returns 0 on success (found a place to start, otherwise non-zero */
+place_to_start( bdy, dbdy, mmax, nmax, rot,
+                i2, j2,
+                invalid, ntag, stag, etag, wtag,
+                dir )
+  int * bdy ;   /* boundary associations, on entry contains invalid entries */
+  int * dbdy ;  /* distances to boundaries, initialized to -1 */
+  int mmax,     /* minor n/s dimension of arrays */
+      nmax ;    /* major e/w dimension of arrays */
+  int rot ;     /* rotation 1=counterclockwise, 0=clockwise */
+  int *i2, *j2 ; /* current point  (output) */
+  int invalid ; /* integer value of an invalid point */
+  int ntag ;    /* tag for north boundary assn */
+  int stag ;    /* tag for south boundary assn */
+  int etag ;    /* tag for east  boundary assn */
+  int wtag ;    /* tag for west  boundary assn */
+  int *dir ;	/* initial direction (output) */
+{
+  int i, j, idx ;
+  int i0, j0, it, jt ;
+  int cnt ;
+
+  /* find first valid point */
+  for ( j = 0 ; j < nmax ; j++ )
+  {
+    for ( i = 0 ; i < mmax ; i++ )
+    {
+      idx = INDEX_2(j,i,mmax) ;
+      if ( bdy[ idx ] != invalid && dbdy[idx] == -1 )
+      {
+	*i2 = i ;
+	*j2 = j ;
+	goto out1 ;
+      }
+    }
+  }
+
+out1:
+
+  /* set an initial direction -- we will chose the first valid direction
+     that does not have a valid direction to its right (rot=1, cntrclkwise)
+     or left (rot=1, clkwise) */
+
+
+  for ( cnt = 0 ; cnt < 4 ; cnt++ ) 
+  {
+    switch(cnt)
+    {
+    case 0 :
+      /* how about north ? */
+      *dir = ntag ;
+      i0 = i+1 ; j0 = j ;
+      it = i ; jt = (rot?j+1:j-1) ;
+      break ;
+    case 1 :
+      /* how about south ? */
+      *dir = stag ;
+      i0 = i-1 ; j0 = j ;
+      it = i ; jt = (rot?j-1:j+1) ;
+      break ;
+    case 2 :
+      /* how about east ? */
+      *dir = etag ;
+      i0 = i ; j0 = j+1 ;
+      it = (rot?i-1:i+1) ; jt = j ;
+      break ;
+    case 3 :
+      /* how about west ? */
+      *dir = wtag ;
+      i0 = i ; j0 = j-1 ;
+      it = (rot?i+1:i-1) ; jt = j ;
+      break ;
+    }
+
+    /* there are RETURN statements in these conditionals */
+    /* see if i0, j0 is valid, then see if it,jt is invalid */
+    if ( i0 >= 0 && i0 < mmax && j0 >= 0 && j0 < nmax )
+    {
+      idx = INDEX_2(j0,i0,mmax) ;
+      if ( bdy[ idx ] != invalid && dbdy[idx] == -1 ) /*and unvisited*/
+      {
+	/* if this point is invalid or out of bounds, we've got the
+	   correct choice for i0, j0 and direction */
+        if ( ! ( it >= 0 && it < mmax && jt >= 0 && jt < nmax ) )
+	{
+	  return(0) ;
+	}
+	idx = INDEX_2(jt,it,mmax) ;
+        if ( bdy[ idx ] == invalid || dbdy[idx] != -1 ) /* or visited */
+	{
+	  return(0) ;
+	}
+      }
+    }
+#if 0
+    switch(cnt)
+    {
+    case 0 :
+      /* how about north ? */
+      *dir = ntag ;
+      i0 = i+1 ; j0 = j ;
+      it = i0 ; jt = (rot?j+1:j-1) ;
+      break ;
+    case 1 :
+      /* how about south ? */
+      *dir = stag ;
+      i0 = i-1 ; j0 = j ;
+      it = i0 ; jt = (rot?j-1:j+1) ;
+      break ;
+    case 2 :
+      /* how about east ? */
+      *dir = etag ;
+      i0 = i ; j0 = j+1 ;
+      it = (rot?i-1:i+1) ; jt = j0 ;
+      break ;
+    case 3 :
+      /* how about west ? */
+      *dir = wtag ;
+      i0 = i ; j0 = j-1 ;
+      it = (rot?i+1:i-1) ; jt = j0 ;
+      break ;
+    }
+
+    /* there are RETURN statements in these conditionals */
+    /* see if i0, j0 is valid, then see if it,jt is invalid */
+    if ( i0 >= 0 && i0 < mmax && j0 >= 0 && j0 < nmax )
+    {
+      idx = INDEX_2(j0,i0,mmax) ;
+      if ( bdy[ idx ] != invalid && dbdy[idx] == -1 ) /*and unvisited*/
+      {
+	/* if this point is invalid or out of bounds, we've got the
+	   correct choice for i0, j0 and direction */
+        if ( ! ( it >= 0 && it < mmax && jt >= 0 && jt < nmax ) )
+	{
+	  return(0) ;
+	}
+	idx = INDEX_2(jt,it,mmax) ;
+        if ( bdy[ idx ] == invalid || dbdy[idx] != -1 ) /* or visited */
+	{
+	  return(0) ;
+	}
+      }
+    }
+#endif
+  }
+  return(1) ;
+}
+
+char cl[] = "" ;
+
+clear()
+{
+printf(cl) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/fix_semicolons.c b/wrfv2_fire/external/RSL/RSL/fix_semicolons.c
new file mode 100755
index 00000000..d6ae3cd1
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fix_semicolons.c
@@ -0,0 +1,91 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+
+main()
+{
+   char inline[1024] ;
+   char inquote ;
+   int i ;
+
+
+   inquote = '\0' ;
+
+   while ( gets( inline )  != NULL )
+   {
+     /* parse the line and if you see a semicolon that's not
+	inside quotes, make a new card out of what follows */
+     for ( i = 0 ; i < 1024 ; i++ )
+     {
+       if ( inline[i] == '\0' ) { putchar('\n') ; break ; }
+       if ( inline[i] == '\'' && inquote == '\0' ) inquote = '\'' ;
+       if ( inline[i] == '\'' && inquote == '\'' ) inquote = '\0' ;
+       if ( inline[i] == '"'  && inquote == '"'  ) inquote = '\0' ;
+       if ( inline[i] == '"'  && inquote == '\0' ) inquote = '"' ;
+       if ( inline[i] == ';' && inquote == '\0' )
+       {
+	 printf("\n      ") ;
+       }
+       else
+       {
+	 putchar(inline[i]) ;
+       }
+     }
+   }
+   exit(0) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/fort.7 b/wrfv2_fire/external/RSL/RSL/fort.7
new file mode 100644
index 00000000..f9a03a8d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort.7
@@ -0,0 +1,3 @@
+10 12 
+1
+2 2
diff --git a/wrfv2_fire/external/RSL/RSL/fort_bdyin_dbl.F b/wrfv2_fire/external/RSL/RSL/fort_bdyin_dbl.F
new file mode 100755
index 00000000..8e8f4145
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_bdyin_dbl.F
@@ -0,0 +1,66 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_bdyin_dbl( unit,
+     $               buf_e,buf_w,buf_n,buf_s, n_ew, n_ns )
+      implicit none
+      integer unit, n_ew, n_ns
+      double precision buf_e(n_ew),buf_w(n_ew),buf_n(n_ns),buf_s(n_ns)
+      read( unit ) buf_e,buf_w,buf_n,buf_s
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_bdyin_real.F b/wrfv2_fire/external/RSL/RSL/fort_bdyin_real.F
new file mode 100755
index 00000000..528bc92c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_bdyin_real.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine fort_bdyin_real( unit,
+     $               buf_e,buf_w,buf_n,buf_s, n_ew, n_ns )
+      implicit none
+      integer unit, n_ew, n_ns
+      real buf_e(n_ew),buf_w(n_ew),buf_n(n_ns),buf_s(n_ns)
+      read( unit ) buf_e,buf_w,buf_n,buf_s
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_characterread.F b/wrfv2_fire/external/RSL/RSL/fort_characterread.F
new file mode 100755
index 00000000..0eb4ae70
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_characterread.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_characterread( unit, buf, n )
+      implicit none
+      integer unit, n
+      character buf(n)
+      read( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_characterwrite.F b/wrfv2_fire/external/RSL/RSL/fort_characterwrite.F
new file mode 100755
index 00000000..f7120e0b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_characterwrite.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_characterwrite( unit, buf, n )
+      implicit none
+      integer unit, n
+      character buf(n)
+      write( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_close.F b/wrfv2_fire/external/RSL/RSL/fort_close.F
new file mode 100755
index 00000000..1fb64189
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_close.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+c added 7/27/94
+      subroutine fort_close(unit)
+      implicit none
+      integer unit
+      close( unit )
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_complexread.F b/wrfv2_fire/external/RSL/RSL/fort_complexread.F
new file mode 100755
index 00000000..99a74b53
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_complexread.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_complexread( unit, buf, n )
+      implicit none
+      integer unit, n
+      complex buf(n)
+      read( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_complexwrite.F b/wrfv2_fire/external/RSL/RSL/fort_complexwrite.F
new file mode 100755
index 00000000..8757c81d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_complexwrite.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_complexwrite( unit, buf, n )
+      implicit none
+      integer unit, n
+      complex buf(n)
+      write( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_doubleread.F b/wrfv2_fire/external/RSL/RSL/fort_doubleread.F
new file mode 100755
index 00000000..f73cfab9
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_doubleread.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_doubleread( unit, buf, n )
+      implicit none
+      integer unit, n
+      double precision buf(n)
+      read( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_doublewrite.F b/wrfv2_fire/external/RSL/RSL/fort_doublewrite.F
new file mode 100755
index 00000000..82c5ed18
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_doublewrite.F
@@ -0,0 +1,66 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_doublewrite( unit, buf, n )
+      implicit none
+      integer unit, n
+      double precision buf(n)
+      write( unit ) buf
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/fort_intread.F b/wrfv2_fire/external/RSL/RSL/fort_intread.F
new file mode 100755
index 00000000..6299ed48
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_intread.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_intread( unit, buf, n )
+      implicit none
+      integer unit, n
+      integer buf(n)
+      read( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_intwrite.F b/wrfv2_fire/external/RSL/RSL/fort_intwrite.F
new file mode 100755
index 00000000..7c665e27
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_intwrite.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine fort_intwrite( unit, buf, n )
+      implicit none
+      integer unit, n
+      integer buf(n)
+      write( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_realread.F b/wrfv2_fire/external/RSL/RSL/fort_realread.F
new file mode 100755
index 00000000..fb635b03
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_realread.F
@@ -0,0 +1,68 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine fort_realread( unit, buf, n )
+      implicit none
+      integer unit, n, i
+      real buf(n)
+c      real testbuf( 242800 )
+c          write(0,*)'fort_realread unit ',unit,' n ',n,
+c     +             ' loc(buf) ',loc(buf), ' loc(testbuf) ',loc(testbuf)
+c      read( unit ) (testbuf(i),i=1,n)
+      read( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/fort_realwrite.F b/wrfv2_fire/external/RSL/RSL/fort_realwrite.F
new file mode 100755
index 00000000..80a1fa2f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/fort_realwrite.F
@@ -0,0 +1,64 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine fort_realwrite( unit, buf, n )
+      implicit none
+      integer unit, n
+      real buf(n)
+      write( unit ) buf
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/generate_invoke.csh b/wrfv2_fire/external/RSL/RSL/generate_invoke.csh
new file mode 100755
index 00000000..c77499af
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/generate_invoke.csh
@@ -0,0 +1,37 @@
+# generates the case statement in invoke_pf.F
+# Usage:  generate_invoke.csh n
+#
+# where n is the number of cases to generate.
+# 
+onintr cleanup
+
+/bin/rm -f /tmp/foo1.$$
+
+set n = $1
+
+set i = 0 
+while ( $i < $n )
+  echo "," >> /tmp/foo1.$$
+  @ i += 1
+end
+
+set i = 0
+while ( $i < $n )
+  @ ii = $i + 1
+  sed "$ii,${n}s/.*,/&A($i),/" /tmp/foo1.$$ > /tmp/foo2.$$
+  /bin/mv /tmp/foo2.$$ /tmp/foo1.$$
+  @ i += 1
+end
+
+cat -n /tmp/foo1.$$ | \
+sed -e 's/^/case/' -e 's/	/ : /' -e 's/,/(*f)(/' -e 's/,$/); break ;/' \
+> /tmp/foo2.$$
+
+echo 'case     0 : (*f)() ; break ;'
+cat /tmp/foo2.$$
+
+
+cleanup:
+
+/bin/rm -f /tmp/foo[12].$$
+
diff --git a/wrfv2_fire/external/RSL/RSL/get_bdy_info.c b/wrfv2_fire/external/RSL/RSL/get_bdy_info.c
new file mode 100755
index 00000000..372f9e08
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/get_bdy_info.c
@@ -0,0 +1,859 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+static int tiebreaker = DIAG_WINS ;
+/*@
+  RSL_BDY_TIEBRK -- Break ties in determining cells' boundary affiliations.
+
+  Notes:
+  This routine effects the information provided by the set of RSL_GET_BDY routines.
+
+  Corner points that are equidistant to both a boundary in the M dimension and
+  a boundary in the N dimension are, by default considered neither; they are
+  considered "diagonal." RSL_BDY_TIEBRK changes the behavior to the one specified
+  by the argument Arg1, which may be M_WINS, N_WINS, or DIAG_WINS (defined in the file
+  rsl.inc).
+
+  See also:
+
+  RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY, RSL_GET_BDY_GPT,
+
+  RSL_GET_BDY_GARRAY
+
+@*/
+RSL_BDY_TIEBRK ( brk_p )
+  int_p brk_p ;      /* (I) M_WINS, N_WINS, or DIAG_WINS */
+{
+  if      ( *brk_p == M_WINS )
+    tiebreaker = M_WINS ;
+  else if ( *brk_p == N_WINS ) 
+    tiebreaker = N_WINS ;
+  else 
+    tiebreaker = DIAG_WINS ;
+}
+
+
+/*@
+  RSL_GET_BDY_LPT  -- Get boundary information for a locally indexed point.
+
+  Notes:
+  This returns boundary information for a locally specified point in the integer
+  array Arg2. The information is useful with irregularly shaped nests
+  (see RSL_SPAWN_IRREG_NEST), in which boundary proximity is not easily determined
+  from loop indices.
+
+  The variations of this routine are RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY,
+  RSL_GET_BDY_GPT, and RSL_GET_BDY_GARRAY.
+
+  The argument Arg3 should be either DOT_BDY_INFO_LEN or 
+  CROSS_BDY_INFO_LEN (defined in the file rsl.inc).  With DOT_BDY_INFO_LEN, the
+  routine will return
+  boundary information for a domain containing all points of the grid (i.e., the 
+  dot-boundaries of an Arakawa-B grid).
+  With CROSS_BDY_INFO_LEN, the routine will return the dot boundary information plus
+  the cross boundary information (i.e., the uppermost boundaries in M and N are at
+  M-1 and N-1).
+
+  The array Arg2 may be indexed to obtain the following information.
+
+  Verbatim:
+$      symbolic name        description
+$      (rsl.inc)          
+$      --------------------------------------------
+$
+$ Normal grid boundary information (dot, in Arakawa B)
+$
+$      RSL_MLOW             Distance to MLOW (south) boundary
+$      RSL_MHIGH            Distance to MHIGH (north) boundary
+$      RSL_NLOW             Distance to NLOW (west) boundary 
+$      RSL_NHIGH            Distance to NHIGH (east) boundary
+$      RSL_DBDY             Distance to closest boundary
+$      RSL_CLOSEST          Closest boundary
+$
+$ Cross grid boundary information (Arakawa B)
+$
+$      RSL_MLOW_X           Distance to MLOW (south) cross boundary
+$      RSL_MHIGH_X          Distance to MHIGH (north) cross boundary
+$      RSL_NLOW_X           Distance to NLOW (west) cross boundary 
+$      RSL_NHIGH_X          Distance to NHIGH (east) cross boundary
+$      RSL_DBDY_X           Distance to closest cross boundary
+$      RSL_CLOSEST_X        Closest cross boundary
+
+BREAKTHEEXAMPLECODE
+
+  Example:
+$      INTEGER LBDYINFO(CROSS_BDY_INFO_LEN)
+$      ...
+$      RSL_DO_N(J,1,JMAX)
+$        RSL_DO_M(I,1,IMAX)
+$          CALL RSL_GET_BDY_LPT( DID, GBDYINFO, CROSS_BDY_INFO_LEN, I, J )
+$          IF ( LBDYINFO(RSL_DBDY) .EQ. 1 ) THEN
+$            ...CODE TO EXECUTE ONLY ON OUTERMOST BOUNDARY CELLS...
+$          ENDIF
+$        RSL_ENDDO
+$      RSL_ENDDO
+$      
+BREAKTHEEXAMPLECODE
+
+  In this example, the boundary information in LBDYINFO is used to determine
+  the first boundary row or column during iteration over a domain.
+
+
+  See also:
+
+  RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY, RSL_GET_BDY_GPT,
+
+  RSL_GET_BDY_GARRAY
+
+
+@*/
+   
+RSL_GET_BDY_LPT ( d_p, bdyinf, n_p, i_p, j_p )
+  int_p 
+    d_p ;            /* (I) RSL domain descriptor */
+  int 
+    bdyinf[] ;       /* (O) Boundary information (see table) */
+  int_p 
+    n_p              /* (I) DOT_BDY_INFO_LEN or CROSS_BDY_INFO_LEN */
+   ,i_p              /* (I) M coordinate of point */
+   ,j_p ;            /* (I) N coordinate of point */
+{
+  int d ;
+  int i, j, nrun, ig, jg ;
+  int mloc, nloc, len, mtn ;
+  int mlen, idif, jdif ;
+  int *p ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *ddom, *pt ;
+
+  d = *d_p ;
+
+  if ( *n_p < DOT_BDY_INFO_LEN )
+  {
+    sprintf(mess, "argument for length of bdyinfo too small, %d < %d",
+	    *n_p, DOT_BDY_INFO_LEN ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_compute: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  dinfo = &(domain_info[*d_p]) ;
+  ddom = dinfo->domain ;
+
+  mlen = dinfo->len_m ;
+  idif = dinfo->idif ;
+  jdif = dinfo->jdif ;
+
+  for ( p = bdyinf, i = 0 ; i < *n_p ; i++, p++ )
+  {
+    *p = RSL_INVALID ;
+  }
+  i = *i_p-1 ;
+  j = *j_p-1 ;
+  jg = j - jdif ;
+  ig = i - idif ;
+
+  pt = &(ddom[INDEX_2(jg,ig,mlen)]) ;
+
+  bdyinf[ RSL_MLOW      -1 ] = pt->dist_mlow ;
+  bdyinf[ RSL_MHIGH     -1 ] = pt->dist_mhigh ;
+  bdyinf[ RSL_NLOW      -1 ] = pt->dist_nlow ;
+  bdyinf[ RSL_NHIGH     -1 ] = pt->dist_nhigh ;
+  bdyinf[ RSL_DBDY      -1 ] = pt->dbdy ;
+  bdyinf[ RSL_CLOSEST   -1 ] = set_bdy_direction( pt->bdy_cclockwise,
+		   				  pt->bdy_clockwise ) ;
+
+  if ( *n_p > DOT_BDY_INFO_LEN && *n_p <= CROSS_BDY_INFO_LEN ) 
+  {
+    bdyinf[ RSL_MLOW_X    -1 ] = pt->dist_mlow_x ;
+    bdyinf[ RSL_MHIGH_X   -1 ] = pt->dist_mhigh_x ;
+    bdyinf[ RSL_NLOW_X    -1 ] = pt->dist_nlow_x ;
+    bdyinf[ RSL_NHIGH_X   -1 ] = pt->dist_nhigh_x ;
+    bdyinf[ RSL_DBDY_X    -1 ] = pt->dbdy_x ;
+    bdyinf[ RSL_CLOSEST_X -1 ] = set_bdy_direction( pt->bdy_x_cclockwise,
+		   				    pt->bdy_x_clockwise ) ;
+  }
+
+}
+
+
+/*@
+  RSL_GET_BDY_LARRAY  -- Get local array containing boundary information.
+
+  Notes:
+  This fills in the entries of Arg2, a 3-dimensional array of boundary information for
+  a domain.  The first two dimensions are the locally sized M and N dimensions
+  of the domain.  The array is indexed by the local domain indices and by the
+  third (most major) index that specifies the
+  information about the point (see table).
+
+  The variations of this routine are RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY,
+  RSL_GET_BDY_GPT, and RSL_GET_BDY_GARRAY.
+  
+  The first two dimensions of Arg2 must be declared MLOC and NLOC, the local array sizes returned
+  by the RSL domain definition routines RSL_MOTHER and the several nest spawning routines.
+  The third
+  dimension of Arg2 should be declared using one either CROSS_BDY_INFO_LEN or
+  DOT_BDY_INFO_LEN (if in doubt use CROSS_BDY_INFO_LEN, since it is larger).
+  These are defined in the file ``rsl.inc." Also use this constant as
+  Arg3 in the call to RSL_GET_BDY_LARRAY.  With DOT_BDY_INFO_LEN, the
+  routine will return
+  boundary information for a domain containing all points of the grid (i.e., the 
+  dot-boundaries of an Arakawa-B grid).
+  With CROSS_BDY_INFO_LEN, the routine will return the dot boundary information plus
+  the cross boundary information (i.e., the uppermost boundaries in M and N are at
+  M-1 and N-1).
+
+  Improper declaration and allocation
+  of memory for
+  Arg2 properly or an incorrect value for Arg3 may result in memory
+  being overwritten with unpredictable results.
+
+  The array Arg2 may be indexed to obtain the following information.
+
+  Verbatim:
+$      symbolic name        description
+$      (rsl.inc)          
+$      --------------------------------------------
+$
+$      RSL_MLOW             Distance to MLOW (south) boundary
+$      RSL_MHIGH            Distance to MHIGH (north) boundary
+$      RSL_NLOW             Distance to NLOW (west) boundary
+$      RSL_NHIGH            Distance to NHIGH (east) boundary
+$      RSL_DBDY             Distance to closest boundary
+$      RSL_CLOSEST          Closest boundary
+$
+$ Cross grid boundary information (Arakawa B)
+$
+$      RSL_MLOW_X           Distance to MLOW (south) cross boundary
+$      RSL_MHIGH_X          Distance to MHIGH (north) cross boundary
+$      RSL_NLOW_X           Distance to NLOW (west) cross boundary
+$      RSL_NHIGH_X          Distance to NHIGH (east) cross boundary
+$      RSL_DBDY_X           Distance to closest cross boundary
+$      RSL_CLOSEST_X        Closest cross boundary
+
+BREAKTHEEXAMPLECODE
+
+
+
+  Example:
+$      INTEGER, ALLOCATABLE :: LBDYINFO(:,:,:)
+$      ...
+$      ALLOCATE( LBDYINFO( MLOC, NLOC, CROSS_BDY_INFO_LEN ) )
+$      ...
+$      CALL RSL_GET_BDY_LARRAY( DID, LBDYINFO, CROSS_BDY_INFO_LEN )
+$      RSL_DO_N(J,1,JMAX)
+$        RSL_DO_M(I,1,IMAX)
+$          IF ( LBDYINFO(I,J,RSL_DBDY) .EQ. 1 ) THEN
+$            ...CODE TO EXECUTE ONLY ON OUTERMOST BOUNDARY CELLS...
+$          ENDIF
+$        RSL_ENDDO
+$      RSL_ENDDO
+$      
+BREAKTHEEXAMPLECODE
+
+
+  See also:
+
+  RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY, RSL_GET_BDY_GPT,
+
+  RSL_GET_BDY_GARRAY
+
+
+@*/
+
+RSL_GET_BDY_LARRAY ( d_p, bdyinf, n_p )
+  int_p d_p ;       /* (I) RSL domain descriptor */
+  int_p bdyinf ;    /* (O) A 3-dimensional array (see discussion) */
+  int_p n_p ;       /* (I) DOT_BDY_INFO_LEN or CROSS_BDY_INFO_LEN */
+{
+  int d ;
+  int cross ;
+  int i, j, nrun, ig, jg ;
+  int mloc, nloc, len, mtn ;
+  int mlen, idif, jdif ;
+  int *p ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *ddom, *pt ;
+
+  d = *d_p ;
+
+  if ( *n_p < DOT_BDY_INFO_LEN )
+  {
+    sprintf(mess, "argument for length of bdyinfo too small, %d < %d",
+            *n_p, DOT_BDY_INFO_LEN ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_compute: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  dinfo = &(domain_info[*d_p]) ;
+  ddom = dinfo->domain ;
+
+  mlen = dinfo->len_m ;
+  mloc = dinfo->loc_m ;
+  nloc = dinfo->loc_n ;
+  mtn = mloc*nloc ;
+  idif = dinfo->idif ;
+  jdif = dinfo->jdif ;
+
+  for ( p = bdyinf, i = 0 ; i < *n_p*mtn ; i++, p++ )
+  {
+    *p = RSL_INVALID ;
+  }
+  for ( nrun = 0 ; nrun < domain_info[d].nrun[0] ; nrun++ )
+  {
+    j = dinfo->js[0][nrun]-1 ;
+    jg = j - jdif ;
+    for ( i = dinfo->is[0][nrun]-1 ; i <= dinfo->ie[0][nrun]-1 ; i++ )
+    {
+      ig = i - idif ;
+      pt = &(ddom[INDEX_2(jg,ig,mlen)]) ;
+      cross = pt->cross ;
+      p = &(bdyinf[INDEX_3(0,j,nloc,i,mloc)]) ;
+
+      *p = pt->dist_mlow    ; p+=mtn ;
+      *p = pt->dist_mhigh   ; p+=mtn ;
+      *p = pt->dist_nlow    ; p+=mtn ;
+      *p = pt->dist_nhigh   ; p+=mtn ;
+      *p = pt->dbdy         ; p+=mtn ;
+      *p = set_bdy_direction( pt->bdy_cclockwise,
+			      pt->bdy_clockwise ) ;
+			      p+=mtn ;
+
+      if ( *n_p > DOT_BDY_INFO_LEN && *n_p <= CROSS_BDY_INFO_LEN )
+      {
+	/* note that the increment of p is outside the if  and
+	   happens unconditionally */
+        if ( cross ) *p = pt->dist_mlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_mhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dbdy_x         ; p+=mtn ;
+        if ( cross ) *p = set_bdy_direction( pt->bdy_x_cclockwise,
+		           	             pt->bdy_x_clockwise ) ;
+			                       p+=mtn ;
+      }
+    }
+  }
+}
+
+RSL_GET_BDY_LARRAY2 ( d_p, bdyinf, n_p, mloc_p, nloc_p )
+  int_p d_p ;       /* (I) RSL domain descriptor */
+  int_p bdyinf ;    /* (O) A 3-dimensional array (see discussion) */
+  int_p n_p ;       /* (I) DOT_BDY_INFO_LEN or CROSS_BDY_INFO_LEN */
+  int_p mloc_p, nloc_p ; /* (I) m and n dimensions of bdyinf */
+{
+  int d ;
+  int cross ;
+  int i, j, nrun, ig, jg ;
+  int mloc, nloc, len, mtn ;
+  int mlen, idif, jdif ;
+  int *p ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *ddom, *pt ;
+
+  d = *d_p ;
+
+  if ( *n_p < DOT_BDY_INFO_LEN )
+  {
+    sprintf(mess, "argument for length of bdyinfo too small, %d < %d",
+            *n_p, DOT_BDY_INFO_LEN ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_compute: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+
+  dinfo = &(domain_info[*d_p]) ;
+  ddom = dinfo->domain ;
+
+  mlen = dinfo->len_m ;
+  mloc = *mloc_p ;
+  nloc = *nloc_p ;
+  mtn = mloc*nloc ;
+  idif = dinfo->idif ;
+  jdif = dinfo->jdif ;
+
+  for ( p = bdyinf, i = 0 ; i < *n_p*mtn ; i++, p++ )
+  {
+    *p = RSL_INVALID ;
+  }
+  for ( nrun = 0 ; nrun < domain_info[d].nrun[0] ; nrun++ )
+  {
+    j = dinfo->js[0][nrun]-1 ;
+    jg = j - jdif ;
+    for ( i = dinfo->is[0][nrun]-1 ; i <= dinfo->ie[0][nrun]-1 ; i++ )
+    {
+      ig = i - idif ;
+      pt = &(ddom[INDEX_2(jg,ig,mlen)]) ;
+      cross = pt->cross ;
+      p = &(bdyinf[INDEX_3(0,j,nloc,i,mloc)]) ;
+
+      *p = pt->dist_mlow    ; p+=mtn ;
+      *p = pt->dist_mhigh   ; p+=mtn ;
+      *p = pt->dist_nlow    ; p+=mtn ;
+      *p = pt->dist_nhigh   ; p+=mtn ;
+      *p = pt->dbdy         ; p+=mtn ;
+      *p = set_bdy_direction( pt->bdy_cclockwise,
+			      pt->bdy_clockwise ) ;
+			      p+=mtn ;
+
+      if ( *n_p > DOT_BDY_INFO_LEN && *n_p <= CROSS_BDY_INFO_LEN )
+      {
+	/* note that the increment of p is outside the if  and
+	   happens unconditionally */
+        if ( cross ) *p = pt->dist_mlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_mhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dbdy_x         ; p+=mtn ;
+        if ( cross ) *p = set_bdy_direction( pt->bdy_x_cclockwise,
+		           	             pt->bdy_x_clockwise ) ;
+			                       p+=mtn ;
+      }
+    }
+  }
+}
+
+
+/* These are like the other routines but return the global (undecomposed)
+   boundary data for a domain.  Bdyinf would be indexed by ig and jg,
+   rather than i and j in the calling program.  */
+
+/*@
+  RSL_GET_BDY_GPT  -- Get boundary information for a globally indexed point.
+
+  Notes:
+  This returns boundary information for a globally specified point in the integer
+  array Arg2. The information is useful with irregularly shaped nests
+  (see RSL_SPAWN_IRREG_NEST), in which boundary proximity is not easily determined
+  from loop indices.
+
+  The variations of this routine are RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY,
+  RSL_GET_BDY_GPT, and RSL_GET_BDY_GARRAY.
+
+  The argument Arg3 should be either DOT_BDY_INFO_LEN or 
+  CROSS_BDY_INFO_LEN (defined in the file rsl.inc).  With DOT_BDY_INFO_LEN, the
+  routine will return
+  boundary information for a domain containing all points of the grid (i.e., the 
+  dot-boundaries of an Arakawa-B grid).
+  With CROSS_BDY_INFO_LEN, the routine will return the dot boundary information plus
+  the cross boundary information (i.e., the uppermost boundaries in M and N are at
+  M-1 and N-1).
+
+  The array Arg2 may be indexed to obtain the following information.
+
+  Verbatim:
+$      symbolic name        description
+$      (rsl.inc)          
+$      --------------------------------------------
+$
+$      RSL_MLOW             Distance to MLOW (south) boundary
+$      RSL_MHIGH            Distance to MHIGH (north) boundary
+$      RSL_NLOW             Distance to NLOW (west) boundary
+$      RSL_NHIGH            Distance to NHIGH (east) boundary
+$      RSL_DBDY             Distance to closest boundary
+$      RSL_CLOSEST          Closest boundary
+$
+$ Cross grid boundary information (Arakawa B)
+$
+$      RSL_MLOW_X           Distance to MLOW (south) cross boundary
+$      RSL_MHIGH_X          Distance to MHIGH (north) cross boundary
+$      RSL_NLOW_X           Distance to NLOW (west) cross boundary
+$      RSL_NHIGH_X          Distance to NHIGH (east) cross boundary
+$      RSL_DBDY_X           Distance to closest cross boundary
+$      RSL_CLOSEST_X        Closest cross boundary
+
+BREAKTHEEXAMPLECODE
+
+  Example:
+$      INTEGER GBDYINFO(CROSS_BDY_INFO_LEN)
+$      ...
+$      RSL_DO_N(J,1,JMAX)
+$        RSL_DO_M(I,1,IMAX)
+$          CALL RSL_GET_BDY_GPT( DID, GBDYINFO, CROSS_BDY_INFO_LEN, IG, JG )
+$          IF ( GBDYINFO(RSL_DBDY) .EQ. 1 ) THEN
+$            ...CODE TO EXECUTE ONLY ON OUTERMOST BOUNDARY CELLS...
+$          ENDIF
+$        RSL_ENDDO
+$      RSL_ENDDO
+$      
+BREAKTHEEXAMPLECODE
+
+  In this example, the boundary information in GBDYINFO is used to determine
+  the first boundary row or column during iteration over a domain.  The reserved
+  global index variables IG and JG are set by the RSL_DO macros.
+
+  See also:
+
+  RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY, RSL_GET_BDY_GPT,
+
+  RSL_GET_BDY_GARRAY
+
+@*/
+
+
+RSL_GET_BDY_GPT ( d_p, bdyinf, n_p, ig_p, jg_p )
+  int_p 
+    d_p ;            /* (I) RSL domain descriptor */
+  int 
+    bdyinf[] ;       /* (O) Boundary information (see table). */
+  int_p 
+    n_p              /* (I) DOT_BDY_INFO_LEN or CROSS_BDY_INFO_LEN */
+   ,ig_p             /* (I) Global index into M dimension */
+   ,jg_p ;           /* (I) Global index into N dimension */
+{
+  int d ;
+  int i, j ;
+  int mlen, nlen ;
+  int *p ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *ddom, *pt ;
+
+  d = *d_p ;
+
+  if ( *n_p < DOT_BDY_INFO_LEN )
+  {
+    sprintf(mess, "argument for length of bdyinfo too small, %d < %d",
+            *n_p, DOT_BDY_INFO_LEN ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_compute: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+
+  dinfo = &(domain_info[*d_p]) ;
+  ddom = dinfo->domain ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+
+  for ( p = bdyinf, i = 0 ; i < *n_p ; i++, p++ )
+  {
+    *p = RSL_INVALID ;
+  }
+
+  j = *jg_p-1 ;
+  i = *ig_p-1 ;
+
+  pt = &(ddom[INDEX_2(j,i,mlen)]) ;
+
+  bdyinf[ RSL_MLOW      -1 ] = pt->dist_mlow ;
+  bdyinf[ RSL_MHIGH     -1 ] = pt->dist_mhigh ;
+  bdyinf[ RSL_NLOW      -1 ] = pt->dist_nlow ;
+  bdyinf[ RSL_NHIGH     -1 ] = pt->dist_nhigh ;
+  bdyinf[ RSL_DBDY      -1 ] = pt->dbdy ;
+  bdyinf[ RSL_CLOSEST   -1 ] = set_bdy_direction( pt->bdy_cclockwise,
+                                                  pt->bdy_clockwise ) ;
+
+  if ( *n_p > DOT_BDY_INFO_LEN && *n_p <= CROSS_BDY_INFO_LEN )
+  {
+    bdyinf[ RSL_MLOW_X    -1 ] = pt->dist_mlow_x ;
+    bdyinf[ RSL_MHIGH_X   -1 ] = pt->dist_mhigh_x ;
+    bdyinf[ RSL_NLOW_X    -1 ] = pt->dist_nlow_x ;
+    bdyinf[ RSL_NHIGH_X   -1 ] = pt->dist_nhigh_x ;
+    bdyinf[ RSL_DBDY_X    -1 ] = pt->dbdy_x ;
+    bdyinf[ RSL_CLOSEST_X -1 ] = set_bdy_direction( pt->bdy_x_cclockwise,
+                                                    pt->bdy_x_clockwise ) ;
+  }
+
+}
+
+/*@
+  RSL_GET_BDY_GARRAY  -- Get global array containing boundary information.
+
+  Notes:
+  This fills in the entries of Arg2, a 3-dimensional array of boundary information for
+  a domain.  The first two dimensions are the globally sized M and N dimensions
+  of the domain.  The array is indexed by the global domain indices and by the
+  third (most major) index that specifies the
+  information about the point (see table).
+
+  The variations of this routine are RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY,
+  RSL_GET_BDY_GPT, and RSL_GET_BDY_GARRAY.
+  
+  The first two dimensions of Arg2 must be declared M and N, the global array sizes returned
+  by the RSL domain definition routines RSL_MOTHER and the several nest spawning routines.
+  The third
+  dimension of Arg2 should be declared using one either CROSS_BDY_INFO_LEN or
+  DOT_BDY_INFO_LEN (if in doubt use CROSS_BDY_INFO_LEN, since it is larger).
+  These are defined in the file ``rsl.inc." Also use this constant as
+  Arg3 in the call to RSL_GET_BDY_LARRAY.  With DOT_BDY_INFO_LEN, the
+  routine will return
+  boundary information for a domain containing all points of the grid (i.e., the 
+  dot-boundaries of an Arakawa-B grid).
+  With CROSS_BDY_INFO_LEN, the routine will return the dot boundary information plus
+  the cross boundary information (i.e., the uppermost boundaries in M and N are at
+  M-1 and N-1).
+
+  Improper declaration and allocation
+  of memory for
+  Arg2 properly or an incorrect value for Arg3 may result in memory
+  being overwritten with unpredictable results.
+
+  The array Arg2 may be indexed to obtain the following information.
+
+  Verbatim:
+$      symbolic name        description
+$      (rsl.inc)          
+$      --------------------------------------------
+$
+$      RSL_MLOW             Distance to MLOW (south) boundary
+$      RSL_MHIGH            Distance to MHIGH (north) boundary
+$      RSL_NLOW             Distance to NLOW (west) boundary
+$      RSL_NHIGH            Distance to NHIGH (east) boundary
+$      RSL_DBDY             Distance to closest boundary
+$      RSL_CLOSEST          Closest boundary
+$
+$ Cross grid boundary information (Arakawa B)
+$
+$      RSL_MLOW_X           Distance to MLOW (south) cross boundary
+$      RSL_MHIGH_X          Distance to MHIGH (north) cross boundary
+$      RSL_NLOW_X           Distance to NLOW (west) cross boundary
+$      RSL_NHIGH_X          Distance to NHIGH (east) cross boundary
+$      RSL_DBDY_X           Distance to closest cross boundary
+$      RSL_CLOSEST_X        Closest cross boundary
+
+
+BREAKTHEEXAMPLECODE
+
+  Example:
+$      INTEGER, ALLOCATABLE :: GBDYINFO(:,:,:)
+$      ...
+$      ALLOCATE( GBDYINFO( M, N, CROSS_BDY_INFO_LEN ) )
+$      ...
+$      CALL RSL_GET_BDY_LARRAY( DID, GBDYINFO, CROSS_BDY_INFO_LEN )
+$      ...
+$      RSL_DO_N(J,1,JMAX)
+$        RSL_DO_M(I,1,IMAX)
+$          IF ( GBDYINFO(IG,JG,RSL_DBDY) .EQ. 1 ) THEN
+$            ...CODE TO EXECUTE ONLY ON OUTERMOST BOUNDARY CELLS...
+$          ENDIF
+$        RSL_ENDDO
+$      RSL_ENDDO
+$      
+BREAKTHEEXAMPLECODE
+
+  In this example, the boundary information array GBDYINFO is used to determine
+  the first boundary row or column during iteration over a domain.  The reserved
+  global index variables IG and JG are set by the RSL_DO macros.
+
+
+  See also:
+
+  RSL_GET_BDY_LPT, RSL_GET_BDY_LARRAY, RSL_GET_BDY_GPT,
+
+  RSL_GET_BDY_GARRAY
+
+
+@*/
+
+RSL_GET_BDY_GARRAY ( d_p, bdyinf, n_p )
+  int_p d_p ;         /* (I) RSL domain descriptor */
+  int_p bdyinf ;      /* (O) A 3-dimensional array (see discussion) */
+  int_p n_p ;         /* (I) DOT_BDY_INFO_LEN or CROSS_BDY_INFO_LEN */
+{
+  int d ;
+  int i, j ;
+  int mtn ;
+  int mlen, nlen ;
+  int cross ;
+  int *p ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *ddom, *pt ;
+
+  d = *d_p ;
+
+  if ( *n_p < DOT_BDY_INFO_LEN )
+  {
+    sprintf(mess, "argument for length of bdyinfo too small, %d < %d",
+            *n_p, DOT_BDY_INFO_LEN ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_compute: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+
+  dinfo = &(domain_info[*d_p]) ;
+  ddom = dinfo->domain ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  mtn = mlen*nlen ;
+
+  for ( p = bdyinf, i = 0 ; i < 2*mtn ; i++, p++ )
+  {
+    *p = RSL_INVALID ;
+  }
+  for ( j = 0 ; j < nlen ; j++ )
+  {
+    for ( i = 0 ; i < mlen ; i++ )
+    {
+      pt = &(ddom[INDEX_2(j,i,mlen)]) ;
+      cross = pt->cross ;
+      p = &(bdyinf[INDEX_3(0,j,nlen,i,mlen)]) ;
+
+      *p = pt->dist_mlow    ; p+=mtn ;
+      *p = pt->dist_mhigh   ; p+=mtn ;
+      *p = pt->dist_nlow    ; p+=mtn ;
+      *p = pt->dist_nhigh   ; p+=mtn ;
+      *p = pt->dbdy         ; p+=mtn ;
+      *p = set_bdy_direction( pt->bdy_cclockwise,
+                              pt->bdy_clockwise ) ;
+                              p+=mtn ;
+
+      if ( *n_p > DOT_BDY_INFO_LEN && *n_p <= CROSS_BDY_INFO_LEN )
+      {
+        /* note that the increment of p is outside the if  and
+           happens unconditionally */
+        if ( cross ) *p = pt->dist_mlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_mhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nlow_x    ; p+=mtn ;
+        if ( cross ) *p = pt->dist_nhigh_x   ; p+=mtn ;
+        if ( cross ) *p = pt->dbdy_x         ; p+=mtn ;
+        if ( cross ) *p = set_bdy_direction( pt->bdy_x_cclockwise,
+                                             pt->bdy_x_clockwise ) ;
+                                               p+=mtn ;
+      }
+    }
+  }
+}
+
+
+/*****************************************/
+/* bits in closest are mapped as follows */
+/*                                       */
+/*       5  6  7                         */
+/*       3     4                         */
+/*       0  1  2                         */
+/*                                       */
+/*****************************************/
+set_bdy_direction( cclock, clock )
+  int cclock,	/* dir to closest boundary from counter-clockwise traversal */
+      clock ;   /* dir to closest boundary from clockwise traversal */
+{
+  /* if they agree, fine.  Just return */
+  if ( cclock == clock ) return(cclock) ;
+
+  /* otherwise, resolve the disagrement using one of several strategies */
+
+  if      ( tiebreaker == M_WINS )
+  {
+    if      ( cclock == RSL_MLOW || cclock == RSL_MHIGH )
+      return( cclock ) ;
+    else if ( clock == RSL_MLOW || clock == RSL_MHIGH )
+      return( clock ) ;
+    else
+      return( RSL_INVALID ) ;
+  }
+  else if ( tiebreaker == N_WINS ) 
+  {
+    if      ( cclock == RSL_NLOW || cclock == RSL_NHIGH )
+      return( cclock ) ;
+    else if ( clock == RSL_NLOW || clock == RSL_NHIGH )
+      return( clock ) ;
+    else
+      return( RSL_INVALID ) ;
+  }
+  else if ( tiebreaker == DIAG_WINS )
+  {
+    if      (( cclock == RSL_MLOW &&  clock == RSL_NLOW ) ||
+	     (  clock == RSL_MLOW && cclock == RSL_NLOW ))
+      return( RSL_00 ) ;
+    else if (( cclock == RSL_MHIGH &&  clock == RSL_NLOW )||
+	     (  clock == RSL_MHIGH && cclock == RSL_NLOW ))
+      return( RSL_M0 ) ;
+    else if (( cclock == RSL_MLOW &&  clock == RSL_NHIGH ) ||
+	     (  clock == RSL_MLOW && cclock == RSL_NHIGH ))
+      return( RSL_0N ) ;
+    else if (( cclock == RSL_MHIGH &&  clock == RSL_NHIGH ) ||
+	     (  clock == RSL_MHIGH && cclock == RSL_NHIGH ))
+      return( RSL_MN ) ;
+    else
+      return( RSL_INVALID ) ;
+  }
+  else
+    RSL_TEST_ERR(1,"no such strategy") ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/handle_spec1.c b/wrfv2_fire/external/RSL/RSL/handle_spec1.c
new file mode 100755
index 00000000..f2bc5a44
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/handle_spec1.c
@@ -0,0 +1,236 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* this routine is specific to MM5.  It's purpose is to read in boundary
+   data from the boundary file and these records have unusual shapes.  There
+   are also multiple fields per record.  For not it easier to do this this
+   was, with a special routine, than to incorporate the necessary generality
+   into rsl.  This particular implementation of this is especially 
+   dreadful -- there is ample room for improvement as time permits. */
+
+/* IMPORTANT -- note that the three-d variables have k (level) as their
+   second, not third, dimension in MM5.  EG:  ueb(MIX,MKX,NSPGD)  2/1/94 */
+
+/* rev: 2/3/94, added code to pass and receive extra boundary points to 
+   neighboring processors along a 4 pt stencil */
+
+/* rev: 7/14/94, changed to a 12 pt stencil to make sure we have enough
+   points for the dot and the cross grids.   Also modified rsl_mm_io.c */
+
+/* rev: 9/8/94, fixed memory leak wherein pbuf was only freed when 
+   rsl_myproc was equal to mdest.  Change to free unconditionally
+   for each of the boundaries.  */
+
+/* rev: 1/10/95, added test to make sure domain is always c.d.  This
+   function will not work properly on a nest and should never be
+   called on one.  MM5 does not read in boundary data on a nest. */
+
+int
+handle_special1( req, buf_e, esz,
+		      buf_w, wsz,
+	              buf_n, nsz,
+		      buf_s, ssz )
+  rsl_read_req_t * req ;
+  char **buf_e, **buf_w, **buf_n, **buf_s ;
+  int *wsz, *esz, *nsz, *ssz ;
+{
+  int dim, i, k, ig, jg, d ;
+  int maj, min, majlen, minlen ;
+  int nelem_ns, nelem_ew, nbytes, typelen, len, cursor  ;
+  int P ;
+  int bwdth ;
+  int mlen, mtag, mdest ;
+  int psendto[ RSL_MAXPROC ] ;    /* size of messages to each processor */
+  char *rbuf_e, *rbuf_w, *rbuf_n, *rbuf_s, *rbuf_tot ;
+  rsl_point_t *domain ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  bwdth = req->speciala ;
+
+  nelem_ns = bwdth * req->glen[1] * ( req->ndim==3?req->glen[2]:1 ) ;
+  nelem_ew = bwdth * req->glen[0] * ( req->ndim==3?req->glen[2]:1 ) ;
+
+  typelen = elemsize( req->type ) ;
+
+  *wsz = nelem_ew * typelen ;
+  *esz = nelem_ew * typelen ;
+  *nsz = nelem_ns * typelen ;
+  *ssz = nelem_ns * typelen ;
+
+  /* figure out sizes of buffers needed */
+              /*caller will free */
+  rbuf_tot = RSL_MALLOC( char, 2*(nelem_ew+nelem_ns)*typelen+100) ; /* 100 is safety */
+  *buf_e = &( rbuf_tot[ 0                                      ] ) ;
+  *buf_w = &( rbuf_tot[ 1 * nelem_ew                 * typelen ] ) ;  
+  *buf_n = &( rbuf_tot[ 2 * nelem_ew                 * typelen ] ) ;  
+  *buf_s = &( rbuf_tot[(2 * nelem_ew + 1 * nelem_ns) * typelen ] ) ;  
+
+  if ( i_am_monitor )
+  {
+    /* call fortran to read a record from the named unit */
+    switch ( req->type )
+    {
+    case RSL_REAL :
+      FORT_BDYIN_REAL ( &(req->unit), 
+             *buf_e, *buf_w, *buf_n, *buf_s, &nelem_ew, &nelem_ns ) ;
+      break ;
+#ifndef T3D
+    case RSL_DOUBLE :
+      FORT_BDYIN_DBL ( &(req->unit),
+             *buf_e, *buf_w, *buf_n, *buf_s, &nelem_ew, &nelem_ns ) ;
+      break ;
+#endif
+    default :
+      RSL_TEST_WRN(1,"read operation not yet implemented for this data type") ;
+    }
+  }
+
+  d = req->domain ;
+  RSL_TEST_ERR( d != 0,
+		"attempt to read boundary data on domain other than c.d.") ;
+  majlen = domain_info[d].len_n ;
+  minlen = domain_info[d].len_m ;
+  domain = domain_info[d].domain ;
+
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 	/* 95/02/22 */
+  {
+    psendto[i] = 0 ;
+  }
+  /*  figure out sizes for each processor */
+  for ( jg = 0 ; jg < majlen ; jg++ )
+  {
+    for ( ig = 0 ; ig < minlen ; ig++ )
+    {
+        domain[INDEX_2(jg,ig,minlen)].info_1 = 0 ;
+    }
+  }
+  for ( jg = 0 ; jg < majlen ; jg++ )
+  {
+    for ( ig = 0 ; ig < minlen ; ig++ )
+    {
+      if ( jg < bwdth )                             /* west  1 */
+      {
+        domain[INDEX_2(jg,ig,minlen)].info_1 = domain[INDEX_2(jg,ig,minlen)].info_1 | 1 ; /* mark on wbdy */
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( jg >= majlen - bwdth && jg <  majlen )   /* east  2 */
+      {
+        domain[INDEX_2(jg,ig,minlen)].info_1 = domain[INDEX_2(jg,ig,minlen)].info_1 | 2 ; /* mark on edy */
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( ig >= minlen - bwdth && ig <  minlen )   /* north 8 */
+      {
+        domain[INDEX_2(jg,ig,minlen)].info_1 = domain[INDEX_2(jg,ig,minlen)].info_1 | 8 ; /* mark on nbdy */
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( ig < bwdth )                             /* south 4 */
+      {
+        domain[INDEX_2(jg,ig,minlen)].info_1 = domain[INDEX_2(jg,ig,minlen)].info_1 | 4 ; /* mark on sbdy */
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+    }
+  }
+
+  if ( i_am_monitor )
+  {
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )	/* 95/02/22 */
+    {
+      if ( psendto[P] != 0 )
+      {
+        mdest = rsl_c_comp2phys_proc( P ) ;
+        if ( ! mdest == rsl_myproc )
+        {
+          mtag = MTYPE_FROMTO( MSG_SPECIAL1_RESPONSE, rsl_myproc, mdest ) ;
+          mlen = 2*(nelem_ew+nelem_ns)*typelen ;
+          RSL_SEND( rbuf_tot, mlen, mtag, mdest ) ;
+        }
+        }
+    }
+  }
+  else
+  {
+    if ( psendto[rsl_c_phys2comp_proc(rsl_myproc)] )
+    {
+      mdest = RSL_C_MONITOR_PROC () ;
+      mtag = MTYPE_FROMTO( MSG_SPECIAL1_RESPONSE, mdest, rsl_myproc ) ;
+      mlen = 2*(nelem_ew+nelem_ns)*typelen ;
+      RSL_RECV( rbuf_tot, mlen, mtag ) ;
+    }
+  }
+
+  if ( psendto[rsl_c_phys2comp_proc(rsl_myproc)] )
+    return( 2*(nelem_ew+nelem_ns)*typelen ) ;  /* whether to expect message */
+  else
+    return(0) ;
+
+}
+
+bdymark( d, ig, jg, hig, hjg, pt, ipt )
+  int d, ig, jg, hig, hjg, pt, ipt ;
+{ 
+  int minlen ;
+
+  minlen = domain_info[d].len_m ;
+  if ( domain_info[d].domain[INDEX_2(jg,ig,minlen)].info_1 == 1 )
+    domain_info[d].domain[INDEX_2(jg,ig,minlen)].info_2 = 1 ; /* mark for this proc */
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/handle_spec2.c b/wrfv2_fire/external/RSL/RSL/handle_spec2.c
new file mode 100755
index 00000000..ebabb1fb
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/handle_spec2.c
@@ -0,0 +1,110 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* for reading in replicated data */
+
+int
+handle_special2( req )
+  rsl_read_req_t * req ;
+{
+  int mlen, mtag, mdest ;
+  rsl_read_resp_t resp ;
+  char *rbuf ;
+  int nbytes ;
+  int P ;
+
+#ifdef T3D
+fprintf(stderr,"handle_special2 called - disabled on T3D.  Stopping\n") ;
+exit(3) ;
+#endif
+
+  /* is this a new request?  if so, service it.  otherwise, it has already
+  being handled -- discard the message */
+
+  if ( req->sequence <= io_seq_monitor ) return(0) ;
+  if ( req->sequence > io_seq_monitor+1 )
+  {
+    sprintf(mess,"handle_read_request: sequence number race %d > %d",
+	   req->sequence, io_seq_monitor+1 ) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+  /* req->sequence equals io_seq_monitor+1 */
+  io_seq_monitor++ ;
+
+  nbytes = req->speciala ;
+  rbuf = RSL_MALLOC( char, nbytes ) ;
+
+  FORT_CHARACTERREAD ( &(req->unit), rbuf, &nbytes ) ;
+
+  resp.sequence = req->sequence ;
+
+  for ( P = 0 ; P < rsl_nproc ; P++ )
+  {
+    mdest = rsl_c_comp2phys_proc(P) ;
+    mtag = MTYPE_FROMTO( MSG_SPECIAL2_RESPONSE, rsl_myproc, mdest ) ;
+    mlen = sizeof( resp ) ;
+    RSL_SEND( &resp, mlen, mtag, mdest ) ;
+    mlen = nbytes ;
+    RSL_SEND( rbuf, mlen, mtag, mdest ) ;
+  }
+
+  RSL_FREE( rbuf ) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/handle_spec3.c b/wrfv2_fire/external/RSL/RSL/handle_spec3.c
new file mode 100644
index 00000000..e642b2c3
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/handle_spec3.c
@@ -0,0 +1,189 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+#include "which_boundary.h"
+
+/* this routine is specific to MM5.  It's purpose is to read in boundary
+   data from the boundary file and these records have unusual shapes.  There
+   are also multiple fields per record.  For not it easier to do this this
+   was, with a special routine, than to incorporate the necessary generality
+   into rsl.  This particular implementation of this is especially 
+   dreadful -- there is ample room for improvement as time permits. */
+
+/* IMPORTANT -- note that the three-d variables have k (level) as their
+   second, not third, dimension in MM5.  EG:  ueb(MIX,MKX,NSPGD)  2/1/94 */
+
+/* rev: 2/3/94, added code to pass and receive extra boundary points to 
+   neighboring processors along a 4 pt stencil */
+
+/* rev: 7/14/94, changed to a 12 pt stencil to make sure we have enough
+   points for the dot and the cross grids.   Also modified rsl_mm_io.c */
+
+/* rev: 9/8/94, fixed memory leak wherein pbuf was only freed when 
+   rsl_myproc was equal to mdest.  Change to free unconditionally
+   for each of the boundaries.  */
+
+/* rev: 1/10/95, added test to make sure domain is always c.d.  This
+   function will not work properly on a nest and should never be
+   called on one.  MM5 does not read in boundary data on a nest. */
+
+int
+handle_special3( req, which_boundary, rbuf, buf ) 
+  rsl_read_req_t * req ;
+  int which_boundary ;
+  char *rbuf ;
+  char **buf ;
+{
+  int dim, i, k, ig, jg, d ;
+  int maj, min, majlen, minlen ;
+  int nelem ;
+  int P ;
+  int bwdth ;
+  int mlen, mtag, mdest ;
+  int psendto[ RSL_MAXPROC ] ;    /* size of messages to each processor */
+  rsl_point_t *domain ;
+  int i_am_monitor ;
+  int typelen ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  bwdth = req->speciala ;
+
+  if      ( which_boundary == WHICH_BDY_NORTH || which_boundary == WHICH_BDY_SOUTH )
+    nelem = bwdth * req->glen[1] * ( req->ndim==3?req->glen[2]:1 ) ;
+  else if ( which_boundary == WHICH_BDY_WEST || which_boundary == WHICH_BDY_EAST )
+    nelem = bwdth * req->glen[0] * ( req->ndim==3?req->glen[2]:1 ) ;
+  else
+    RSL_TEST_ERR(1,"handle_special3 bad which_boundary") ;
+
+  typelen = elemsize( req->type ) ;
+
+  /* figure out sizes of buffers needed */
+              /*caller will free */
+  *buf = RSL_MALLOC( char, nelem*typelen+100) ; /* 100 is safety */
+
+  d = req->domain ;
+  RSL_TEST_ERR( d != 0,
+		"attempt to read boundary data on domain other than c.d.") ;
+  majlen = domain_info[d].len_n ;
+  minlen = domain_info[d].len_m ;
+  domain = domain_info[d].domain ;
+
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 	/* 95/02/22 */
+  {
+    psendto[i] = 0 ;
+  }
+  for ( jg = 0 ; jg < majlen ; jg++ )
+  {
+    for ( ig = 0 ; ig < minlen ; ig++ )
+    {
+      if ( jg < bwdth )                             /* west  1 */
+      {
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( jg >= majlen - bwdth && jg <  majlen )   /* east  2 */
+      {
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( ig >= minlen - bwdth && ig <  minlen )   /* north 8 */
+      {
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+      if ( ig < bwdth )                             /* south 4 */
+      {
+        psendto[domain[INDEX_2(jg,ig,minlen)].P] = 1 ;
+      }
+    }
+  }
+
+  if ( i_am_monitor )
+  {
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )	/* 95/02/22 */
+    {
+      if ( psendto[P] != 0 )
+      {
+        mdest = rsl_c_comp2phys_proc( P ) ;
+        if ( ! mdest == rsl_myproc )
+        {
+          mtag = MTYPE_FROMTO( MSG_SPECIAL1_RESPONSE, rsl_myproc, mdest ) ;
+          mlen = nelem*typelen ;
+          RSL_SEND( rbuf, mlen, mtag, mdest ) ;
+        }
+      }
+    }
+    bcopy( rbuf, *buf, nelem*typelen ) ;
+  }
+  else
+  {
+    if ( psendto[rsl_c_phys2comp_proc(rsl_myproc)] )
+    {
+      mdest = RSL_C_MONITOR_PROC () ;
+      mtag = MTYPE_FROMTO( MSG_SPECIAL1_RESPONSE, mdest, rsl_myproc ) ;
+      mlen = nelem*typelen ;
+      RSL_RECV( *buf, mlen, mtag ) ;
+    }
+  }
+
+  if ( psendto[rsl_c_phys2comp_proc(rsl_myproc)] )
+    return( nelem*typelen ) ;  /* whether to expect message */
+  else
+    return(0) ;
+
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/index.c b/wrfv2_fire/external/RSL/RSL/index.c
new file mode 100755
index 00000000..298226a5
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/index.c
@@ -0,0 +1,89 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/* function versions of indexing macros */
+#include 
+#include 
+#include "rsl.h"
+
+rsl_point_id_t
+pointid( d, j, i )
+  rsl_index_t d, j, i ;
+{
+  return(POINTID(d,j,i)) ;
+}
+
+rsl_index_t
+id_domain( m )
+  rsl_point_id_t m ;
+{
+  return(ID_DOMAIN(m)) ;
+}
+
+rsl_index_t
+id_jdex(m)
+  rsl_point_id_t m ;
+{
+  return(ID_JDEX(m)) ;
+}
+
+rsl_index_t
+id_idex(m)
+  rsl_point_id_t m ;
+{
+  return(ID_IDEX(m)) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/invoke_pf.c b/wrfv2_fire/external/RSL/RSL/invoke_pf.c
new file mode 100755
index 00000000..6099bbdb
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/invoke_pf.c
@@ -0,0 +1,141 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#define MAXDOM_MAKE 1
+
+#include 
+#include 
+#include "rsl.h"
+
+/*#define A(I) b->[I]*/
+#define A(I) x[I]
+
+invoke_pf( nflds, f,
+           parent_nl, child_nl,
+	   p_i, p_j, p_ig, p_jg,
+	   n_ig, n_jg,
+	   cm1, cn1, buf, n )
+  int nflds ;
+  int (*f)() ;
+  int_p    parent_nl, child_nl,
+	   p_i, p_j, p_ig, p_jg,
+	   n_ig, n_jg,
+	   cm1, cn1, buf, n ;
+{
+  int x[900] ;		/* remove -- testing only */
+
+  RSL_TEST_ERR( nflds > 50 || nflds < 0, "nflds out of range") ;
+  /* the following case statement was genenerated by the script
+     generate_invoke.csh (I did not type this in by hand!) */
+  switch (nflds)
+  {
+case     0 : (*f)() ; break ;
+case     1 : (*f)(A(0)); break ;
+case     2 : (*f)(A(0),A(1)); break ;
+case     3 : (*f)(A(0),A(1),A(2)); break ;
+case     4 : (*f)(A(0),A(1),A(2),A(3)); break ;
+case     5 : (*f)(A(0),A(1),A(2),A(3),A(4)); break ;
+case     6 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5)); break ;
+case     7 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6)); break ;
+case     8 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7)); break ;
+case     9 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8)); break ;
+case    10 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9)); break ;
+case    11 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10)); break ;
+case    12 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11)); break ;
+case    13 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12)); break ;
+case    14 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13)); break ;
+case    15 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14)); break ;
+case    16 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15)); break ;
+case    17 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16)); break ;
+case    18 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17)); break ;
+case    19 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18)); break ;
+case    20 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19)); break ;
+case    21 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20)); break ;
+case    22 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21)); break ;
+case    23 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22)); break ;
+case    24 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23)); break ;
+case    25 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24)); break ;
+case    26 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25)); break ;
+case    27 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26)); break ;
+case    28 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27)); break ;
+case    29 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28)); break ;
+case    30 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29)); break ;
+case    31 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30)); break ;
+case    32 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31)); break ;
+case    33 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32)); break ;
+case    34 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33)); break ;
+case    35 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34)); break ;
+case    36 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35)); break ;
+case    37 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36)); break ;
+case    38 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37)); break ;
+case    39 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38)); break ;
+case    40 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39)); break ;
+case    41 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40)); break ;
+case    42 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41)); break ;
+case    43 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42)); break ;
+case    44 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43)); break ;
+case    45 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44)); break ;
+case    46 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45)); break ;
+case    47 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45),A(46)); break ;
+case    48 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45),A(46),A(47)); break ;
+case    49 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45),A(46),A(47),A(48)); break ;
+case    50 : (*f)(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11),A(12),A(13),A(14),A(15),A(16),A(17),A(18),A(19),A(20),A(21),A(22),A(23),A(24),A(25),A(26),A(27),A(28),A(29),A(30),A(31),A(32),A(33),A(34),A(35),A(36),A(37),A(38),A(39),A(40),A(41),A(42),A(43),A(44),A(45),A(46),A(47),A(48),A(49)); break ;
+
+    default:
+	RSL_TEST_ERR(1,"bad number of arguments") ;
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/makefile b/wrfv2_fire/external/RSL/RSL/makefile
new file mode 100755
index 00000000..f2282ae2
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile
@@ -0,0 +1,207 @@
+#########################################################################
+#     
+#                              COPYRIGHT
+#     
+#     The following is a notice of limited availability of the code and 
+#     Government license and disclaimer which must be included in the 
+#     prologue of the code and in all source listings of the code.
+#     
+#     Copyright notice
+#       (c) 1977  University of Chicago
+#     
+#     Permission is hereby granted to use, reproduce, prepare 
+#     derivative works, and to redistribute to others at no charge.  If 
+#     you distribute a copy or copies of the Software, or you modify a 
+#     copy or copies of the Software or any portion of it, thus forming 
+#     a work based on the Software and make and/or distribute copies of 
+#     such work, you must meet the following conditions:
+#     
+#          a) If you make a copy of the Software (modified or verbatim) 
+#             it must include the copyright notice and Government       
+#             license and disclaimer.
+#     
+#          b) You must cause the modified Software to carry prominent   
+#             notices stating that you changed specified portions of    
+#             the Software.
+#     
+#     This software was authored by:
+#     
+#     Argonne National Laboratory
+#     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+#     Mathematics and Computer Science Division
+#     Argonne National Laboratory, Argonne, IL  60439
+#     
+#     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+#     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+#     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+#     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+#     
+#                      GOVERNMENT LICENSE AND DISCLAIMER
+#     
+#     This computer code material was prepared, in part, as an account 
+#     of work sponsored by an agency of the United States Government.
+#     The Government is granted for itself and others acting on its 
+#     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+#     this data to reproduce, prepare derivative works, distribute 
+#     copies to the public, perform publicly and display publicly, and 
+#     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+#     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+#     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+#     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+#     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+#     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+#     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+#
+#########################################################################
+
+# Top level makefile for RSL.
+#
+#
+
+###################################################
+# User settable compile time constants.
+###################################################
+
+# largest number of domains
+MAX_DOMAINS  = 6
+
+# largest number of processors
+MAX_PROC     = 256
+
+###################################################
+# Install time constants
+###################################################
+
+# 0 is hostless (monitor is a compute node);
+# 1 (monitor is an extra node)
+HOST_NODE = 0
+#HOST_NODE = 1
+
+# 1, monitor is the low node; 0, monitor is high node
+# (set this for all hosts)
+MON_LOW = 1
+#MON_LOW = 0
+
+###################################################
+# Generally not modified
+###################################################
+
+CONFIG_OPTS = -DIMAX_MAKE=$(IMAX) -DJMAX_MAKE=$(JMAX) \
+	      -DMAXDOM_MAKE=$(MAX_DOMAINS) \
+	      -DMAXPROC_MAKE=$(MAX_PROC) \
+	      -DHOST_NODE=$(HOST_NODE) -DMON_LOW=$(MON_LOW) \
+	      -DALLOW_RSL_168PT=1 $(LEARN_BCAST)
+
+MAKE_OPTS=SED_LINE="-e s/IMAX_MAKE/$(IMAX)/ \
+		     -e s/JMAX_MAKE/$(JMAX)/ \
+		     -e s/MAXDOM_MAKE/$(MAX_DOMAINS)/ \
+	             -e s/MAXPROC_MAKE/$(MAX_PROC)/" \
+          CONFIG_OPTS="$(CONFIG_OPTS)"
+
+
+include makefile.core
+OBJ = $(CORE_OBJ)
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+MINITAR = $(CORE_MINITAR)
+
+.SUFFIXES: .o .c
+MAKE = make -r
+
+help :
+	@ echo "Must specify target (see makefile)."
+
+mpl :
+	@ echo "Do not compile for MPL.  Use MPI."
+
+sp2 :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make sp2 > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.sp2 $(MAKE_OPTS) all
+
+sp2ch :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make sp2ch > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.sp2ch $(MAKE_OPTS) all
+
+sp2.1 :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make sp2.1 > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.sp2.1 $(MAKE_OPTS) all
+
+t3e :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make t3e > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.t3e $(MAKE_OPTS) all
+
+crayx1 :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make x1 > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.x1 $(MAKE_OPTS) all
+
+o2k :
+	$(MAKE) -f makefile.o2k $(MAKE_OPTS) all
+
+hp :
+	$(MAKE) -f makefile.hp $(MAKE_OPTS) all
+
+alpha :
+	$(MAKE) -f makefile.alpha $(MAKE_OPTS) all
+
+alphavector :
+	$(MAKE) -f makefile.alphavector $(MAKE_OPTS) all
+
+vpp :
+	$(MAKE) -f makefile.vpp $(MAKE_OPTS) all
+
+sunmpi :
+	$(MAKE) -f makefile.sunmpi $(MAKE_OPTS) all
+
+altix :
+	$(MAKE) -f makefile.altix $(MAKE_OPTS) all
+
+linux :
+	$(MAKE) -f makefile.linux LINUX_MPIHOME=$(LINUX_MPIHOME) $(MAKE_OPTS) all
+
+sx :
+	$(MAKE) -f makefile.sx $(MAKE_OPTS) all
+
+stub :
+	@ if [ -f LAST_MADE ] ; then /bin/mv -f LAST_MADE LAST_MADE.bak ; fi
+	@ echo Last made as: make stub > LAST_MADE
+	@ make >> LAST_MADE
+	$(MAKE) -f makefile.stub $(MAKE_OPTS) all
+
+showtar :
+	@ echo these files will be included in the tar
+	@ echo $(TAR) | tr '\040' '\012'
+
+tar :
+	tar cvf rsltar $(TAR)
+	compress rsltar
+	ls -l rsltar.Z
+
+minitar :
+	tar cvf rslminitar $(MINITAR)
+	compress rslminitar
+	ls -l rslminitar.Z
+
+man :
+	$(MAKE) -f Makefile.man
+	cd docs ; make man
+
+manclean :
+	/bin/rm -fr man
+	cd docs ; make manclean
+
+superclean : 
+	/bin/rm -f *.o librsl.a rsl.inc
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.alpha b/wrfv2_fire/external/RSL/RSL/makefile.alpha
new file mode 100755
index 00000000..1636dbfe
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.alpha
@@ -0,0 +1,55 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the DEC Alpha
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+### When compiling RSL with MM5, the CC macro is defined by the call to make
+### from MM5/Makefile.  Don't define it here.
+# for compiling with MPICH
+#CC = mpicc
+# for compiling with DEC's version of MPI
+#CC = cc
+#FC = f77
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -DMPI -DSWAPBYTES -O $(UNDERSCORE)
+FFLAGS  = -align dcommons -convert big_endian -O
+#CFLAGS = -DMPI -DSWAPBYTES -g $(UNDERSCORE)
+#FFLAGS  = -align dcommons -convert big_endian -g
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.alphavector b/wrfv2_fire/external/RSL/RSL/makefile.alphavector
new file mode 100755
index 00000000..ff504f82
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.alphavector
@@ -0,0 +1,60 @@
+#version of RSL makefile used for testing vector option on local compaq hosts
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the DEC Alpha
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+### When compiling RSL with MM5, the CC macro is defined by the call to make
+### from MM5/Makefile.  Don't define it here.
+# for compiling with MPICH
+#CC = mpicc
+# for compiling with DEC's version of MPI
+#CC = cc
+#FC = f77
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -DMPI -DSWAPBYTES -Dvpp -Dalphavector -O $(UNDERSCORE)
+FFLAGS  = -align dcommons -convert big_endian -O
+CFLAGS = -DMPI -DSWAPBYTES -Dvpp -Dalphavector -g $(UNDERSCORE)
+FFLAGS  = -align dcommons -convert big_endian -g
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
+
+vicopy.o : vicopy.F
+	$(FC) -c $(FVFLAGS) $<
+
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.altix b/wrfv2_fire/external/RSL/RSL/makefile.altix
new file mode 100644
index 00000000..199706aa
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.altix
@@ -0,0 +1,59 @@
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the SGI Altix using Intel 8.0 compilers
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = icc
+FC = ifort
+
+# MPIHOME=/usr
+# IDIR=$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+# CFLAGS = -w -O3 -ipo -tpp2 -g -DMPI -DRSL_SYNCIO -Dlinux -DSWAPBYTES
+# FFLAGS = -w -O3 -ipo -tpp2 -ftz -g -convert big_endian
+CFLAGS = -w -O3 -ip -tpp2 -no-gcc -DMPI -DRSL_SYNCIO -Dlinux -DSWAPBYTES $(IDIR) -DMPI2_SUPPORT
+#FFLAGS = -w -O3 -ip -tpp2 -ftz -convert big_endian $(IDIR) -mP3OPT_ecg_mm_fp_ld_latency=20
+FFLAGS = -w -O3 -ip -tpp2 -ftz -convert big_endian $(IDIR) 
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+#	xild -lib ru librsl.a $(OBJ)
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+superclean : clean
+	/bin/rm -f librsl.a rsl.inc
+
+
+###
+
+$(OBJ) : $(HDR)
+
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.core b/wrfv2_fire/external/RSL/RSL/makefile.core
new file mode 100755
index 00000000..4b543a01
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.core
@@ -0,0 +1,39 @@
+
+CORE_OBJ = set_padarea.o set_f_padarea.o domain_def.o within_nest.o  \
+      mesh_topo.o \
+      decomp.o show_decomp.o rsl_new_decom.o rsl_nl.o rsl_initial.o \
+      rsl_malloc.o index.o border.o pt.o proc.o proc_f.o \
+      buf_for_proc.o message_def.o stencil_def.o comp_sten.o \
+      pack_message.o exch_sten.o rsl_probe.o comp_cells_f.o comp_cells.o \
+      fort_realread.o \
+      fort_intread.o \
+      fort_complexread.o \
+      fort_characterread.o \
+      fort_close.o \
+      fort_realwrite.o \
+      fort_intwrite.o \
+      fort_complexwrite.o \
+      fort_characterwrite.o \
+      rsl_funit_close.o \
+      fort_bdyin_real.o \
+      rsl_io.o rsl_ioserve.o rsl_init_f.o \
+      rsl_mm_io.o handle_spec1.o handle_spec2.o handle_spec3.o \
+      rsl_bcast.o rsl_bcast_f.o rsl_merge.o rsl_merge_f.o \
+      rsl_order.o rsl_move.o rsl_debug.o rsl_mon_bcast.o rsl_fopen_f.o \
+      rsl_fclose_f.o \
+      comp_slabs.o comp_slabs_f.o destroy_list.o comp_world.o \
+      cd.o rsl.o default_decomposition.o rsl_child_info.o get_bdy_info.o \
+      rsl_remap_state.o patchmap.o boundary_safe.o fill_boundary.o \
+      process_refs.o rsl_error_dup.o \
+      fort_doubleread.o  fort_doublewrite.o fort_bdyin_dbl.o \
+      comp_period.o exch_period.o period_def.o period_refs.o \
+      rsl_hemiforce.o \
+      comp_xpose.o xpose_def.o xpose.o
+
+CORE_HDR = rsl.h  rsl_comm.h compat.h
+
+CORE_MINITAR = rsl.inc_base *.c *.h *.inc *.f TODO makefile* *.csh README*
+
+CORE_TAR = $(CORE_MINITAR)
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.hp b/wrfv2_fire/external/RSL/RSL/makefile.hp
new file mode 100755
index 00000000..c7de5109
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.hp
@@ -0,0 +1,51 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = mpicc
+FC = mpif90
+
+MPIHOME=#/usr/local/mpi
+IDIR=#$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -DMPI -DNOUNDERSCORE -g
+FFLAGS = +noppu +O3
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.ibm.sv b/wrfv2_fire/external/RSL/RSL/makefile.ibm.sv
new file mode 100755
index 00000000..b2f51c0c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.ibm.sv
@@ -0,0 +1,49 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = cc
+FC = xlf
+
+MPIHOME=/usr/local/mpi
+IDIR=$(MPIHOME)/include
+
+LIB = 
+
+CFLAGS = -I$(IDIR) -DNOUNDERSCORE -DMPI -g # -O # -g
+FFLAGS = -g
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.f.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.linux b/wrfv2_fire/external/RSL/RSL/makefile.linux
new file mode 100755
index 00000000..0af39ade
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.linux
@@ -0,0 +1,47 @@
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+IDIR=$(LINUX_MPIHOME)/include
+#CC = $(LINUX_MPIHOME)/bin/mpicc
+#FC = $(LINUX_MPIHOME)/bin/mpif77 -byteswapio
+
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -I$(IDIR) -DMPI -DRSL_SYNCIO -Dlinux -DSWAPBYTES -O
+FFLAGS = -O
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.o2k b/wrfv2_fire/external/RSL/RSL/makefile.o2k
new file mode 100755
index 00000000..ce04e346
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.o2k
@@ -0,0 +1,54 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy_o2k.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = cc -64 -mips4
+FC = f90 -64 -mips4
+
+MPIHOME=/usr
+IDIR=$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -w -I$(IDIR) -DMPI -DO2K -O2 -DMPI2_SUPPORT
+FFLAGS = -w -O2
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+superclean : clean
+	/bin/rm -f librsl.a rsl.inc
+
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.sp2 b/wrfv2_fire/external/RSL/RSL/makefile.sp2
new file mode 100755
index 00000000..47f46ba3
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.sp2
@@ -0,0 +1,51 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = mpcc
+FC = mpxlf
+
+MPIHOME=#/usr/local/mpi
+IDIR=#$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -I$(IDIR) -DNOUNDERSCORE -DMPI -O
+FFLAGS = -O
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.sp2.1 b/wrfv2_fire/external/RSL/RSL/makefile.sp2.1
new file mode 100755
index 00000000..ad67c133
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.sp2.1
@@ -0,0 +1,54 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+# this is for older versions of the SP, in which the MPI stuff is not
+# automatically accessible via mpcc.
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = mpicc
+FC = mpixlf
+
+MPIHOME=#/usr/local/mpi
+IDIR=#$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .a .inc .o .c .F
+
+CFLAGS = -I$(IDIR) -DNOUNDERSCORE -DMPI -O
+FFLAGS = -O
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+	touch librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.sp2ch b/wrfv2_fire/external/RSL/RSL/makefile.sp2ch
new file mode 100755
index 00000000..e1ad8cfd
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.sp2ch
@@ -0,0 +1,51 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = cc
+FC = xlf
+
+MPIHOME=/homes/michalak/mpich
+IDIR=$(MPIHOME)/include
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -I$(IDIR) -DNOUNDERSCORE -DMPI -g
+FFLAGS = -g #-O
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.stub b/wrfv2_fire/external/RSL/RSL/makefile.stub
new file mode 100755
index 00000000..d93642d6
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.stub
@@ -0,0 +1,59 @@
+
+# this is a makefile for RSL that maps the package down to the
+# IBM SP without message passing at all (must run single proc)
+
+include makefile.core
+OBJ = $(CORE_OBJ) debug.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+.SUFFIXES: .F .o .c
+
+
+
+LIB = 
+
+# IBM
+#CFLAGS = -DNOUNDERSCORE -DSTUBS -g
+#CC = cc
+#FC = xlf
+# SUN
+#CFLAGS = -DSTUBS -g
+#CC = cc
+#FC = f77 -w
+
+
+#FFLAGS = -O
+#ucomment for alpha
+#CFLAGS = -DSTUBS -DSWAPBYTES -O
+#FFLAGS = -O -convert big_endian
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.sunmpi b/wrfv2_fire/external/RSL/RSL/makefile.sunmpi
new file mode 100755
index 00000000..d27bbebb
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.sunmpi
@@ -0,0 +1,63 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on SunOS
+
+.SUFFIXES: .F .o .c
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o debug.o fort_doubleread.o fort_doublewrite.o fort_bdyin_dbl.o mpi_init_f.o rsl_error_dup.o vicopy_o2k.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = mpcc
+FC = mpf90
+
+MPIHOME=
+IDIR=.
+
+LIB = 
+
+COPTIM = -O
+FOPTIM = -O
+CFLAGS = -I$(IDIR) -DMPI -DSUN
+FFLAGS =
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+	ranlib librsl.a
+
+# problem with illigal instruction in rsl_merge when compiled with -O
+# haven't determined cause yet.  96/06/02
+rsl_merge.o :
+	$(CC) -c -g $(CFLAGS) $(CONFIG_OPTS) $<
+
+# problem with illigal instruction in rsl_merge when compiled with -O
+# haven't determined cause yet.  96/06/02
+#rsl_merge_f.o :
+#	$(FC) -c -g $(FFLAGS) $<
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(COPTIM) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $(FOPTIM) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.sx b/wrfv2_fire/external/RSL/RSL/makefile.sx
new file mode 100755
index 00000000..55591c1f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.sx
@@ -0,0 +1,70 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the NEC SX-5
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy_sx.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = sxmpic++
+FC = sxmpif90
+
+#MPIHOME=
+#IDIR=
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -DMPI -I../../../include -Dsx -DRSL_SYNCIO -Dcrayx1 -DNO_RAGGED
+CFLAGS = -DMPI -I../../../include -Dsx -DRSL_SYNCIO -DNEC_TUNE -DNEC_SINGLENEST -DNEC_TYPE4B
+CFLAGS = -DMPI -I../../../include -Dsx -DRSL_SYNCIO -DNEC_TUNE
+FFLAGS = -float0
+#INLINE = -pi fullmsg auto file=proc.c
+
+# "-DNEC_SINGLENEST"
+# avoids redundant count of grid points.
+# don't specify this if the form of the grid-plane changes.
+# (i.e. multi-nest run)
+# target file is "rsl_ioserve.c".
+
+# "-DNEC_TYPE4B"
+# 1 byte char data copy by "bcopy" is replaced with 4 byte float
+# substitution.
+# this modification promotes vectorization.
+# this effects only multi-nest run.
+# target file is "rsl_bcast.c".
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	sxar cr librsl.a $(OBJ)
+#	ranlib librsl.a
+
+rsl_mpi_compat.o:	rsl_mpi_compat.c
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(INLINE) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.t3e b/wrfv2_fire/external/RSL/RSL/makefile.t3e
new file mode 100755
index 00000000..a8070303
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.t3e
@@ -0,0 +1,58 @@
+
+##### from Bill Gropp #####
+# (see /Net/moline14/moline14_5/gropp/mpich/examples/test/pt2pt/Makefile)
+#
+#MPIR_HOME   = /opt/ctl/mpt/1.1.0.1
+##LIB_PATH    = -L$(MPIR_HOME)/lib
+#LIB_PATH    = -L/opt/ctl/mpt/1.1.0.1/lib
+#LIB_LIST    = -lmpi
+#INCLUDE_DIR =  -I$(MPIR_HOME)/include
+#
+LIBS = $(LIB_PATH) $(LIB_LIST)
+#
+##### end stuff from Gropp #####
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = cc
+FC = f90
+
+.SUFFIXES: .o .c .F
+
+IDIR= $(INCLUDE_DIR)
+
+CFLAGS = -DMPI -DT3D -O $(IDIR) -DRSL_SYNCIO
+FFLAGS = 
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+#	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.vpp b/wrfv2_fire/external/RSL/RSL/makefile.vpp
new file mode 100755
index 00000000..d66ea831
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.vpp
@@ -0,0 +1,55 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = vcc
+FC = frt
+
+MPIHOME=#/usr/local/mpi
+IDIR=$(MPIINCDIR)
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -I$(IDIR) -DMPI -Dvpp -DRSL_SYNCIO -O -Wl,-P -J -KA32 -Ka4
+FFLAGS = -O -Fixed -X7 -Wl,-P -Wv -KA32
+FVFLAGS = -Sw -Wv,-Of,-te,-ilfunc,-noalias,-m3,-P255 -Oe,-P -Kfast -Pdos -lmpi -lmp -KA32
+
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
+
+vicopy.o : vicopy.F
+	$(FC) -c $(FVFLAGS) $<
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.vpp2 b/wrfv2_fire/external/RSL/RSL/makefile.vpp2
new file mode 100755
index 00000000..85d95059
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.vpp2
@@ -0,0 +1,50 @@
+
+# this is a makefile for RSL that maps the package down to the
+# MPI message passing primitives on the IBM SP[12] and nets of wkstations
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o debug.o fort_doubleread.o fort_doublewrite.o rsl_error_dup.o fort_bdyin_dbl.o vicopy.o
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = vcc
+FC = frt
+
+MPIHOME=#/usr/local/mpi
+IDIR=$(MPIINCDIR)
+
+LIB = 
+
+.SUFFIXES: .o .c .F
+
+CFLAGS = -I$(IDIR) -DMPI -Dvpp2 -Dnomallinfo -DRSL_SYNCIO -O -Wl,-P -J
+FFLAGS = -O -Fixed -X7 -Wl,-P
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/makefile.x1 b/wrfv2_fire/external/RSL/RSL/makefile.x1
new file mode 100755
index 00000000..a43f464f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/makefile.x1
@@ -0,0 +1,64 @@
+
+##### from Bill Gropp #####
+# (see /Net/moline14/moline14_5/gropp/mpich/examples/test/pt2pt/Makefile)
+#
+#MPIR_HOME   = /opt/ctl/mpt/1.1.0.1
+##LIB_PATH    = -L$(MPIR_HOME)/lib
+#LIB_PATH    = -L/opt/ctl/mpt/1.1.0.1/lib
+#LIB_LIST    = -lmpi
+#INCLUDE_DIR =  -I$(MPIR_HOME)/include
+#
+LIBS = $(LIB_PATH) $(LIB_LIST)
+#
+##### end stuff from Gropp #####
+
+include makefile.core
+OBJ = $(CORE_OBJ) rsl_mpi_compat.o mpi_init_f.o vicopy.o debug.o 
+HDR = $(CORE_HDR)
+TAR = $(CORE_TAR)
+
+CC = cc
+FC = ftn
+
+.SUFFIXES: .o .c .F
+
+IDIR= $(INCLUDE_DIR)
+
+CFLAGS = -DMPI -O3 $(IDIR) -DRSL_SYNCIO -Dcrayx1 -h list=a  -DNO_RAGGED
+FFLAGS = -Dcrayx1
+
+CFLAGS0 = -hstream0,vector3,scalar3,fp2,inline3 -DMPI -DRSL_SYNCIO -VV -h display_opt -h report=imsvf -Dcrayx1
+
+warning :
+	@ echo 'This makefile is not a top level makefile'
+	@ echo 'and is not intended for direct use.  Please'
+	@ echo 'type "make" by itself for assistance.'
+
+all : rsl.inc librsl.a
+
+fill_boundary.o : fill_boundary.c
+	$(CC) -P $(CFLAGS0) $(CONFIG_OPTS) fill_boundary.c
+	$(CC) -c $(CFLAGS0) $(CONFIG_OPTS) fill_boundary.c
+
+rsl.inc : $(HDR) rsl.inc_base
+	cat $(HDR) | sed $(SED_LINE) |\
+	grep '^#.*define.*\/\* FORTRAN \*\/' | \
+	awk '{printf("      integer %s\n      parameter(%s=%s)\n",$$2,$$2,$$3)}' | \
+	cat rsl.inc_base - > rsl.inc
+
+librsl.a : $(OBJ)
+	ar cr librsl.a $(OBJ)
+#	ranlib librsl.a
+
+.c.o :
+	$(CC) -c $(CFLAGS) $(CONFIG_OPTS) $<
+
+.F.o :
+	$(FC) -c $(FFLAGS) $<
+
+clean :
+	/bin/rm -f *.o
+
+###
+
+$(OBJ) : $(HDR)
diff --git a/wrfv2_fire/external/RSL/RSL/mesh_topo.c b/wrfv2_fire/external/RSL/RSL/mesh_topo.c
new file mode 100755
index 00000000..446b9ddf
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/mesh_topo.c
@@ -0,0 +1,66 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+rsl_processor_t
+mesh_topo( p_row, nrow, p_col, ncol )
+  rsl_processor_t p_row, nrow, p_col, ncol ;
+{
+  return( p_row*ncol + p_col ) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/message_def.c b/wrfv2_fire/external/RSL/RSL/message_def.c
new file mode 100755
index 00000000..27960528
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/message_def.c
@@ -0,0 +1,562 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_CREATE_MESSAGE - create a descriptor for an RSL message.
+
+  Synopsis:
+  RSL_CREATE_MESSAGE ( m )
+  integer m
+
+  Input parameter:
+. m - message descriptor
+
+  Notes:
+  Create a descriptor for an RSL message.  On return, the
+  integer Arg1 will contain a handle to a new RSL message.
+  Messages exist only temporarily by themselves -- once a message
+  has been asssociated with a stencil or a state vector, the handle
+  becomes invalid.
+
+  See also:
+  RSL_BUILD_MESSAGE, RSL_DESCRIBE_STENCIL, RSL_DESCRIBE_STATE
+
+@*/
+
+
+RSL_CREATE_MESSAGE ( mh_p )
+  int_p mh_p ;
+{
+
+  int i ;
+  message_desc_t *msg ;
+
+  /* NOTE: never return the 0th message descriptor */
+  for ( i = 1 ; i < RSL_MAXDESCRIPTORS ; i++ )
+    if ( mh_descriptors[i] == NULL ) break ;    /* got one */
+
+  RSL_TEST_ERR( i == RSL_MAXDESCRIPTORS,
+    "rsl_create_message: out of descriptors.\nAre you creating messages and then not associating them with\na stencil, bcast/merge, or state vector?" ) ;
+
+  *mh_p = i ;
+  msg = RSL_MALLOC(message_desc_t,1) ;
+  msg->tag = MESSAGE_DESC ;
+  msg->mh = *mh_p ;
+  mh_descriptors[*mh_p] = msg ;
+}
+
+/* Only ever called internally to RSL.   This routine is for use
+   by routines that associate messages with other RSL constructs.  Once
+   the association is made, those constructs point to the messages.  We
+   do *not* free the message description structures here, only free up
+   the descriptors so they can be used again.  */
+
+release_mh_descriptor (mh_p)
+  int_p mh_p ;
+{
+  int mh ;
+
+  mh = *mh_p ;
+
+  if ( mh == RSL_INVALID ) return ;
+
+  RSL_TEST_ERR( mh <= 0 || mh >= RSL_MAXDESCRIPTORS,
+                "internal error.  Invalid message descriptor.") ;
+  if ( mh_descriptors[mh] != NULL )
+  {
+    mh_descriptors[mh] = NULL ;
+  }
+  /* it can happen that this will be called for a descriptor that
+     has already been nulled out.  Let it happen. */
+}
+
+
+/*
+  RSL_BLANK_MESSAGE - (obsolete) describe a message for broadcast/merges.
+
+  Synopsis:
+  RSL_BLANK_MESSAGE ( m, len )
+  integer m
+  integer len
+
+  Input parameter:
+. m - message descriptor
+. len - length, in bytes, of message
+
+  Notes:
+  Messages to be used in a broadcast or a merge operation
+  for inter-domain communication do not have fields associated
+  with them ahead of time, unlike messages that are used
+  in stencil exchanges (see RSL_BUILD_MESSAGE).  Rather, the
+  packing and unpacking routines are provided by the user,
+  and the message is simply a stream of bytes.   RSL_BLANK_MESSAGE
+  designates a message as a blank message and associates with
+  the message its length in bytes.
+
+  See also:
+  RSL_BUILD_MESSAGE, RSL_COMP_BCAST, RSL_COMP_MERGE
+*/
+
+
+RSL_BLANK_MESSAGE ( mh_p, len_p )
+  int_p mh_p ;          /* message handle */
+  int_p len_p ;         /* length in bytes */
+{
+  int mh, len ;
+  message_desc_t *msg ;
+
+  mh = *mh_p ; len = *len_p ;
+
+  RSL_TEST_ERR((mh <= 0)|| (mh >= RSL_MAXDESCRIPTORS),
+                "rsl_blank_message: bad message handle" ) ;
+  RSL_TEST_ERR((msg = (message_desc_t *)mh_descriptors[mh])==NULL,
+               "descriptor for null message");
+  RSL_TEST_ERR( msg->tag != MESSAGE_DESC,
+       "rsl_blank_message: handle given is not for an rsl message def" ) ;
+
+  msg->tag = BLANK_MESSAGE_DESC ;       /* change tag */
+  msg->nbytes = len ;
+  return ;
+}
+
+/*@
+  RSL_BUILD_MESSAGE - Add a 2- or 3-dimensional field to a message.
+
+  Notes:
+  An RSL message is a set of fields that are to be communicated
+  for a point in the model grid.  Describing messages in this way
+  allows RSL to assume control of packing and unpacking of model data
+  from and to local processor memory for efficient and transparent
+  communication of stencil exchanges and state remappings.
+    
+  A field (Arg3), a multi-dimensional
+  array of a given type (Arg2),
+  is
+  added
+  to a message (Arg1) by repeated calls to RSL_BUILD_MESSAGE.
+  Once constructed, messages may then be combined into stencils
+  (RSL_DESCRIBE_STENCIL) for stencil exchanges (RSL_EXCH_STENCIL).
+  A message may also be used to describe a state-vector (RSL_DESCRIBE_STATE)
+  used in remapping for load balancing.
+
+  The Arg4 argument gives the number of dimensions in the field
+  being added to the message.  It is permissable to mix 2 and 3
+  dimensional fields.  Regardless, however, 2 and only dimensions
+  of the field
+  must be decomposed.
+  The three arguments Arg4, Arg5, and Arg6, are integer arrays
+  of size Arg4.  The indicies of these arrays correspond to the
+  dimensions of the field being added; index 1 is the most minor,
+  and index ndim is the most major dimension.
+  
+  The values stored in the Arg4 array may be
+  
+  Verbatim:
+$     RSL_NORTHSOUTH  -- decomposed over M
+$     RSL_EASTWEST -- decomposed over N
+$     RSL_NOTDECOMPOSED.  -- not decomposed.
+BREAKTHEEXAMPLECODE
+
+  This tells RSL whether the
+  dimension in question is decomposed over a north/south column of
+  processors in the mesh, an east-west row in the mesh, or -- as is the
+  case with the vertical dimension in 3-d arrays -- not decomposed at
+  all.  RSL_NORTHSOUTH, RSL_EASTWEST, and RSL_NOTDECOMPOSED are 
+  defined in the RSL include file "rsl.inc".
+
+  The values stored in the Arg5 array are the global, or
+  undecomposed, sizes of each dimension of the field.  The values 
+  stored in the Arg6 array are the local, or actual,
+  sizes of the dimensions of the field as it exists in the processor's
+  memory.  If the field is statically declared (say, in common) the
+  sizes would be the sizes that were used to declare the array itself.
+  If the array is dynamically allocated using a Fortran90 
+  ALLOCATE() statement, the values of llen would be sizes that
+  were specified to the ALLOCATE() statement.  In the latter case,
+  if these sizes ever change during the course of a run, it would
+  be necessary to destroy this message and reconstruct a new one
+  for RSL, since it must always be able to determine the true size
+  in memory of the data structures involved in messaging operations.
+
+  Example:
+$  integer m                           ! message descriptor
+$  integer decomp(3), llen(3), glen(3) ! dimension descriptions
+$  real ua(ix,jx,kx), va(ix,jx,kx)     ! locally dimensioned 3-d arrays
+$  real psa(ix,jx,kx)                  ! locally dimensioned 2-d array
+
+$  decomp(1) = RSL_NORTHSOUTH     ! how most minor dim decomposed
+$  decomp(2) = RSL_EASTWEST       ! how next dim decomposed
+$  decomp(3) = RSL_NOTDECOMPOSED  ! major dim (vertical) not decomposed
+
+$  glen(1) = g_ix    ! global size in n/s
+$  glen(2) = g_jx    ! global size in e/w
+$  glen(3) = kx      ! size in vertical
+$  llen(1) = ix      ! local size in n/s
+$  llen(2) = jx      ! local size in e/w
+$  llen(3) = kx      ! local size of vertical (same as global)
+
+$  call rsl_create_message( m )
+$  call rsl_build_message( m, RSL_REAL, ua,  3, decomp, glen, llen )
+$  call rsl_build_message( m, RSL_REAL, va,  3, decomp, glen, llen )
+$  call rsl_build_message( m, RSL_REAL, psa, 2, decomp, glen, llen )
+
+
+BREAKTHEEXAMPLECODE
+
+  In the above example, a message is created and then built by 
+  adding two three-dimensional fields and one two-dimensional field.  
+  The order of the construction is not important.  Subsequent
+  to these statements, the completed message could be used to define
+  one or more points of a stencil exchange to communicate ua,
+  psa, and va between processors.
+
+
+  See also:
+  RSL_CREATE_MESSAGE, RSL_BLANK_MESSAGE, RSL_DESCRIBE_STENCIL,
+  RSL_DESCRIBE_STATE
+
+@*/
+
+static struct f90_base_table_entry {
+  char * base, * virt_base ;
+  int size_in_bytes ;
+} f90_base_table[ MAX_BASE_TABLE_ENTRIES ] ;
+static int base_table_cursor = 1;
+static int base_table_size = 1;
+
+RSL_BUILD_MESSAGE ( mh_p, t_p, base, ndim_p, decomp, glen, llen )
+  int_p 
+     mh_p       /* (I) Message handle created by RSL_CREATE_MESSAGE. */
+    ,t_p        /* (I) RSL type description. */
+    ,ndim_p ;   /* (I) Number of dimensions of field being added to message.*/
+  void *
+    base ;      /* (I) Base address field in local memory. */
+  int 
+    decomp[] ;  /* (I) How decomposed. */
+  int 
+    glen[] ;    /* (I) Global (undecomposed) dimensions of field. */
+  int 
+    llen[] ;    /* (I) Local (decomposed) dimensions of field. */
+{
+  int mh, t, ndim, i ;
+  message_desc_t *msg ;
+  rsl_fldspec_t *fld ;
+  int dim ;
+  int f90_table_index ;
+  char errmess[256] ;
+
+  mh = *mh_p ; t = *t_p ; ndim = *ndim_p ;
+
+  RSL_TEST_ERR( ndim < 0, "rsl_build_message: bad ndim argument" ) ;
+  RSL_TEST_ERR( ndim > RSL_MAXDIM, 
+"rsl_build_message: ndim too large.  Change RSL_MAXDIM; recompile librsl.a." ) ;
+  RSL_TEST_ERR((mh <= 0)||(mh >= RSL_MAXDESCRIPTORS),
+       "rsl_build_message: bad message handle" ) ;
+  if ( (msg = (message_desc_t *)mh_descriptors[mh])==NULL )
+  {
+      RSL_TEST_ERR(1, "descriptor for null message");
+  }
+  RSL_TEST_ERR( msg->tag != MESSAGE_DESC,
+       "rsl_build_message: handle given is not for an rsl message def" ) ;
+
+  fld = RSL_MALLOC( rsl_fldspec_t, 1 ) ;
+
+  fld->type = t ;
+  fld->elemsz = elemsize( t ) ;
+  for ( fld->memsize = fld->elemsz, i = 0 ; i < ndim ; i++ )
+  {
+    fld->memsize = fld->memsize * llen[i] ;
+  }
+
+  if ( t >= 100 )
+  {
+    if ( ! (fld->f90_table_index = get_index_for_base( base )) )
+    { RSL_TEST_ERR(1,"Use of unregistered f90 typed variable") ; }
+#if 0
+    fld->base = (void *)((fld->f90_table_index-1) * F90_MAX_FLD_SIZE_IN_BYTES + 1) ; /* don't allow base of 0 */
+#else
+    fld->base = f90_base_table[ fld->f90_table_index ].virt_base ;
+#endif
+  }
+  else
+  {
+    fld->base = base ;
+  }
+  fld->ndim = ndim ;
+  for ( dim = 0 ; dim < ndim ; dim++ )
+  {
+    fld->decomp[dim] = decomp[dim] ;
+    fld->gdex[dim] = RSL_INVALID ;	/* this gets filled in dynamically */
+    if ( decomp[dim] == RSL_NOTDECOMPOSED && glen[dim] != llen[dim] )
+    {
+       sprintf(errmess,
+"rsl_build_message: mesg %d: dim %d is RSL_NOTDECOMPOSED so glen(%d)=%d must eq llen(%d)=%d",
+       mh, dim+1, dim+1, glen[dim], dim+1, llen[dim] ) ;
+       RSL_TEST_WRN( 1, errmess ) ;
+    }
+    fld->glen[dim] = glen[dim] ;
+    fld->llen[dim] = llen[dim] ;
+    if ( decomp[dim] > 10 )
+      fld->stag[dim] = 1 ;
+    else 
+      fld->stag[dim] = 0 ;
+  }
+
+  /* work out pack/unpack strategy for this field */
+  switch ( ndim )
+  {
+  case 2 :
+    if      ( decomp[0]%10 == RSL_M && 
+	      decomp[1]%10 == RSL_N )
+      fld->strategy = MINNS_MAJEW_2D ;
+    else if ( decomp[1]%10 == RSL_M &&
+	      decomp[0]%10 == RSL_N )
+      fld->strategy = MINEW_MAJNS_2D ;
+    else
+      RSL_TEST_ERR(1,"rsl_build_message: unsupported decomposition strategy for 2d message") ;
+    break ;
+  case 3 :
+    if      ( decomp[0]%10 == RSL_M &&
+	      decomp[1]%10 == RSL_N &&
+	      decomp[2]%10 == RSL_NOTDECOMPOSED)
+      fld->strategy = MINNS_MAJEW_K_3D ;
+    else if ( decomp[0]%10 == RSL_N &&
+	      decomp[1]%10 == RSL_M &&
+	      decomp[2]%10 == RSL_NOTDECOMPOSED)
+      fld->strategy = MINEW_MAJNS_K_3D ;
+    else if ( decomp[0]%10 == RSL_NOTDECOMPOSED &&
+	      decomp[1]%10 == RSL_M &&
+	      decomp[2]%10 == RSL_N )
+      fld->strategy = K_MIDNS_MAJEW_3D ;
+    else if ( decomp[0]%10 == RSL_M &&
+	      decomp[1]%10 == RSL_NOTDECOMPOSED &&
+	      decomp[2]%10 == RSL_N )
+      fld->strategy = MINNS_K_MAJEW_3D ;
+    else
+      RSL_TEST_ERR(1,"rsl_build_message: unsupported decomposition strategy for 3d message") ;
+    break ;
+  default :
+    sprintf(mess,"rsl_build_message: %d dimension flds not supported yet\n",
+	    ndim ) ;
+    RSL_TEST_ERR(1,mess) ;
+    break ;
+  }
+
+  /* insert fldspec at beginning of list (note: we're not concerning
+     ourselves with order of the fields -- this will reverse them from
+     the order they were specified in.) */
+
+  fld->next = msg->fldspecs ;
+  msg->fldspecs = fld ;
+  msg->nflds++ ;
+}
+
+
+RSL_REGISTER_F90 ( base )
+  char * base ;
+{
+  if ( base_table_cursor < MAX_BASE_TABLE_ENTRIES )
+  {
+    f90_base_table[ base_table_cursor ].base = base ;
+    base_table_cursor++ ;
+  }
+  else
+  {
+    RSL_TEST_ERR(1,"Exceeded MAX_BASE_TABLE_ENTRIES number of f90 fields") ;
+  }
+}
+
+#define BASE_TABLE_PADDING sizeof(double) ;
+RSL_REGISTER_F90_BASE_AND_SIZE ( base , size )
+  char * base ;
+  int * size ;
+{
+  if ( base_table_cursor < MAX_BASE_TABLE_ENTRIES )
+  {
+    f90_base_table[ base_table_cursor ].base = base ;
+    f90_base_table[ base_table_cursor ].size_in_bytes = * size ;
+    f90_base_table[ base_table_cursor ].virt_base =
+           f90_base_table[ base_table_cursor-1 ].virt_base +
+           f90_base_table[ base_table_cursor-1 ].size_in_bytes + BASE_TABLE_PADDING ;
+    base_table_cursor++ ;
+  }
+  else
+  {
+    RSL_TEST_ERR(1,"Exceeded MAX_BASE_TABLE_ENTRIES number of f90 fields") ;
+  }
+}
+
+RSL_END_REGISTER_F90 ()
+{
+  base_table_size = base_table_cursor ;
+}
+
+RSL_START_REGISTER_F90 ()
+{
+  base_table_cursor = 1 ;
+  f90_base_table[ 0 ].virt_base = (char *) BASE_TABLE_PADDING ;
+  f90_base_table[ 0 ].size_in_bytes = 0 ;
+}
+
+void *
+get_base_for_index ( dex )
+  int dex ;
+{
+  if ( dex < 1 || dex >= base_table_size )
+  {
+    sprintf(mess, "bad index %d into f90_base_table.  base_table_size %d\n", dex, base_table_size ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  return( (void *) f90_base_table[dex].base ) ;
+}
+
+get_index_for_base ( base )
+  char * base ;
+{
+  int i ;
+  for ( i = 1 ; i < base_table_size ; i++ )
+  { 
+    if ( base == f90_base_table[ i ].base )
+    {
+      return( i ) ;
+    }
+  }
+  return(0) ;
+}
+
+/* return the number of bytes this message will require 
+   (only the data requirements -- descriptors not figured here */
+int
+message_size( msg )
+  message_desc_t *msg ;
+{
+  int dim, dimlen ;
+  int accum ;
+  rsl_fldspec_t * fld ;
+
+  if ( msg == NULL ) return(0) ;
+  if ( msg->tag != MESSAGE_DESC ) return(-1) ;
+  accum = 0 ;
+  for ( fld = msg->fldspecs ; fld != NULL ; fld = fld->next )
+  {
+    accum += fldsize( fld ) ;
+  }
+  return(accum) ;
+}
+
+int
+fldsize( fld )
+  rsl_fldspec_t * fld ;
+{
+  int dim, dimlen ;
+  int accum, fldaccum ;
+  fldaccum = 1 ;
+  for ( dim = 0 ; dim < fld->ndim ; dim++ )
+  {
+    fldaccum *= (fld->decomp[dim] == RSL_NOTDECOMPOSED)?fld->llen[dim]:1;
+  }
+  return (fldaccum * fld->elemsz) ;
+}
+
+/* only used internally within the RSL package... called by routines
+   that destroy larger RSL constructs such as stencils, bcast/merges,
+   state vectors (note: this routine was written using emacs, so
+   be careful) */
+destroy_message( msg )
+  message_desc_t * msg ;
+{
+  rsl_fldspec_t *fld, *doomed ;
+  if ( msg == NULL ) return ;
+  RSL_TEST_ERR( msg->tag != MESSAGE_DESC, "destroy_message: arg not a msg.") ;
+
+  for ( fld = msg->fldspecs ; fld != NULL ; )
+  {
+    doomed = fld ;
+    fld = fld->next ;
+    RSL_FREE( doomed ) ;
+  }
+  RSL_FREE( msg ) ;
+  msg = NULL ;
+}
+
+int
+elemsize( t )
+  int t ;
+{
+  if ( t >= 100 ) t = t % 100 ; /* remove extra info */
+  switch ( t )
+  {
+#ifdef T3D
+  case RSL_REAL         : return(sizeof(double)) ;
+#else
+  case RSL_REAL         : return(sizeof(float)) ;
+#endif
+  case RSL_DOUBLE       : return(sizeof(double)) ;
+#ifdef T3D
+  case RSL_COMPLEX      : return(2*sizeof(double)) ;
+#else
+  case RSL_COMPLEX      : return(2*sizeof(float)) ;
+#endif
+  case RSL_INTEGER      : return(sizeof(int)) ;
+  case RSL_CHARACTER    : return(sizeof(char)) ;
+  }
+  return(-1) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/mpc_sttus.c b/wrfv2_fire/external/RSL/RSL/mpc_sttus.c
new file mode 100755
index 00000000..752950a8
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/mpc_sttus.c
@@ -0,0 +1,66 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+mpc_sttus( x )
+int x ;
+{
+   int i ;
+   int j ;
+   j = x ;
+   i = mpc_status( j ) ;
+   return(i) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/mpi_init_f.F b/wrfv2_fire/external/RSL/RSL/mpi_init_f.F
new file mode 100755
index 00000000..23ab0a69
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/mpi_init_f.F
@@ -0,0 +1,67 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine mpi_init_f( ierr )
+      logical iflag
+      call mpi_initialized( iflag, ierr )
+      ierr = 0 
+      if ( .NOT. iflag ) then
+         call mpi_init(ierr)
+      endif
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/mpir_getarg.F b/wrfv2_fire/external/RSL/RSL/mpir_getarg.F
new file mode 100755
index 00000000..1a578935
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/mpir_getarg.F
@@ -0,0 +1,84 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+c for some reason, n is passed in by value -- don't use
+      subroutine mpir_getarg( i, arg, n )
+      implicit none
+      integer i,n,j,m,cur
+      character arg(*)
+      character*256 str
+      call getarg( i, str)
+      m = len(str)
+      do j = 1,m
+        arg(j) = str(j:j)
+      enddo
+      return
+      end
+
+      integer function mpir_iargc()
+      implicit none
+      integer iargc
+      external iargc
+      mpir_iargc = iargc()
+      return
+      end
+
+c      program main
+c      character arg(30)
+c      call mpir_getarg( 1, arg, 30 )
+c      print *,arg
+c      end
diff --git a/wrfv2_fire/external/RSL/RSL/mpl_test.c b/wrfv2_fire/external/RSL/RSL/mpl_test.c
new file mode 100755
index 00000000..17c9d87f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/mpl_test.c
@@ -0,0 +1,132 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+#include "rsl_comm.h"
+
+char buf1[4096] ;
+char buf2[4096] ;
+char buf3[4096] ;
+char buf4[4096] ;
+char buf5[4096] ;
+
+main()
+{
+  int rc, bc ;
+  int source ;
+  int tag, tag1, tag2, tag3, tag4, tag5 ;
+  int handle1 ;
+  int nbuf[10] ;
+  int que[5] ;
+  int retval ;
+  int i, ngot ;
+
+  RSL_INITIALIZE () ;
+
+  tag1 = 1001 ;
+  tag2 = 1002 ;
+  tag3 = 1003 ;
+  tag4 = 1004 ;
+  tag5 = 1005 ;
+
+  if ( rsl_myproc != 0 )
+  {
+/* Post several receives */
+    RSL_RECVBEGIN ( buf1, 2000, tag1 ) ; 
+    RSL_RECVBEGIN ( buf2, 2000, tag2 ) ; 
+    RSL_RECVBEGIN ( buf3, 2000, tag3 ) ; 
+    RSL_RECVBEGIN ( buf4, 2000, tag4 ) ; 
+    RSL_RECVBEGIN ( buf5, 2000, tag5 ) ; 
+
+    que[0] = 0 ;
+    que[1] = 0 ;
+    que[2] = 0 ;
+    que[3] = 0 ;
+    que[4] = 0 ;
+
+/* Probe for receive */
+    i = 0 ;
+    ngot = 0 ;
+    while ( ngot < 5 ) 
+    {
+      if ( i >= 5 ) i = 0 ; 
+      tag = 1001 + i ;
+      if ( que[i] != RSL_INVALID )
+      {
+      RSL_PROBE ( tag, &retval ) ;
+      if ( retval )
+      {
+        RSL_RECVEND ( tag ) ;
+        que[i] = RSL_INVALID ;
+        ngot++ ;
+      }
+      }
+      i++ ;
+    }
+  }
+  else
+  {
+    RSL_SEND ( buf1, 2000, tag1, 1 ) ;
+    RSL_SEND ( buf2, 2000, tag2, 1 ) ;
+    RSL_SEND ( buf3, 2000, tag3, 1 ) ;
+    RSL_SEND ( buf4, 2000, tag4, 1 ) ;
+    RSL_SEND ( buf5, 2000, tag5, 1 ) ;
+  }
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/pack_message.c b/wrfv2_fire/external/RSL/RSL/pack_message.c
new file mode 100755
index 00000000..ac1889dd
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/pack_message.c
@@ -0,0 +1,415 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#define INTXFER
+#include 
+#include 
+#include "rsl.h"
+
+#define FWD(A,B,C)	my_bcopy(A,B,C)
+#define BWD(A,B,C)	my_bcopy(B,A,C)
+
+extern int debuggal_pack ;
+
+static int first_1 = 1 ;
+static int first_2 = 1 ;
+
+static FILE * xfp = NULL ;
+
+pack_message( msg, buf, cursor_p, d, ig, jg)
+  message_desc_t *msg  ;
+  char * buf ;
+  int * cursor_p ;
+  rsl_index_t d, ig, jg;
+{
+  rsl_fldspec_t *fld ;
+  int stride ;
+  register int *ips, *ipd ;
+  char * dd, * ss ;
+  unsigned int i, j, k, elemsz, t0, t1, t2, t3 ;
+  char * base ;
+  int cursor ;
+
+  cursor = *cursor_p ;
+
+#if 0
+if ( xfp == NULL )
+{
+  sprintf(mess,"xfp.%03d",rsl_myproc);
+  if(( xfp = fopen(mess,"w")) == NULL ) perror(mess)  ;
+}
+#endif
+
+  if ( msg == NULL ) return(-1) ;
+
+  i = ig - domain_info[d].ilocaloffset ;	/* this must not go neg */
+  j = jg - domain_info[d].jlocaloffset ;        /* this must not go neg */
+
+#if 0
+  if ( debuggal_pack )
+  {
+    fprintf(stderr,"pack_message: %16x, d %d i %d,j %d,ig %d,jg %d, ioff %d, joff %d\n",
+    msg->fldspecs->base, d, i,j,ig,jg,domain_info[d].ilocaloffset,domain_info[d].jlocaloffset ) ;
+    if ( first_2 == 1 )
+    {
+      first_2 = 0 ;
+      for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+      {
+        base = fld->base ;
+        fprintf(stderr,"  : %16x\n",base) ;
+      }
+    }
+    fflush(stderr) ;
+  }
+#endif
+
+  for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+  {
+    elemsz = fld->elemsz ;
+    if ( fld->type >= 100 )
+    {
+      base = (void *)get_base_for_index( fld->f90_table_index ) ;
+    }
+    else
+    {
+      base = fld->base ;
+    }
+    switch (fld->strategy)
+    {
+    case MINNS_MAJEW_2D :		/*  eg: psa(i,j) */
+      t0 = fld->llen[0] ;
+      FWD( base+(i+j*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
+      break ;
+    case MINEW_MAJNS_2D :		/*      eg: xxx(j,i) */
+      t0 = fld->llen[0] ;
+      FWD( base+(j+i*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
+      break ;
+    case MINNS_MAJEW_K_3D :		/*  eg: ua(i,j,k) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+	stride = t1 ;
+        ipd = (int *)(&buf[cursor]) ;
+	ips = (int *)(base + (i + j*t0)*elemsz) ;
+	/* ipd must be aligned on 4 byte boundary on some machines
+	   for this to work -- a symptom of it not working would be
+	   a bus error, for example. */
+	for ( k = 0 ; k < fld->llen[2] ; k++ )
+	{
+           *ipd = *ips ;
+	   ips += stride ;
+	   ipd ++ ;
+	}
+	cursor += fld->llen[2] * elemsz ;
+	break ;
+#endif
+      default :
+        for( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+          FWD( base+(i+j*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
+	  cursor+=elemsz ;
+        }
+	break ;
+      }
+      break ;
+    case MINEW_MAJNS_K_3D :		/*  eg: u(j,i,k) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+        stride = t1 ;
+        ipd = (int *)(&buf[cursor]) ;
+        ips = (int *)(base + (j + i*t0)*elemsz) ;
+        /* ipd must be aligned on 4 byte boundary on some machines
+           for this to work -- a symptom of it not working would be
+           a bus error, for example. */
+        for ( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+           *ipd = *ips ;
+           ips += stride ;
+           ipd ++ ;
+        }
+        cursor += fld->llen[2] * elemsz ;
+        break ;
+#endif
+      default :
+        for( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+          FWD( base+(j+i*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
+	  cursor+=elemsz ;
+        }
+	break ;
+      }
+      break ;
+
+    case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+        ipd = (int *)(&buf[cursor]) ;
+        ips = (int *)(base + (i*t0+j*t1)*elemsz) ;
+        /* ipd must be aligned on 4 byte boundary on some machines
+           for this to work -- a symptom of it not working would be
+           a bus error, for example. */
+        for ( k = 0 ; k < t0 ; k++ )
+        {
+           *ipd++ = *ips++ ;
+        }
+        cursor += t0*elemsz ;
+        break ;
+#endif
+      default :
+        FWD( base+(i*t0+j*t1)*elemsz,&(buf[cursor]),t0*elemsz ) ;
+        cursor+=t0*elemsz ;
+        break ;
+      }
+      break ;
+
+
+    default:
+      RSL_TEST_ERR(1,"pack_message: strategy not supported" ) ;
+      break ;
+    }
+  }
+  *cursor_p = cursor ;
+}
+
+unpack_message( msg, buf, cursor_p, d, ig, jg)
+  message_desc_t *msg  ;
+  char * buf ;
+  int * cursor_p ;
+  rsl_index_t d, ig, jg;
+{
+  rsl_fldspec_t *fld ;
+  register int * ips, * ipd ;
+  char * dd, * ss ;
+  unsigned int i, j, k, elemsz, t0, t1, t2, t3 ;
+  char * base ;
+  int cursor ;
+  int stride ;
+
+  cursor = *cursor_p ;
+
+#if 0
+if ( xfp == NULL )
+{
+  sprintf(mess,"xfp.%03d",rsl_myproc);
+  xfp = fopen(mess,"w") ;
+}
+#endif
+
+
+  if ( msg == NULL ) return(-1) ;
+
+  i = ig - domain_info[d].ilocaloffset ;	/* this must not go neg */
+  j = jg - domain_info[d].jlocaloffset ;        /* this must not go neg */
+
+#if 0
+  if ( debuggal_pack )
+  {
+    fprintf(stderr,"unpack_message: %16x, i %d,j %d,ig %d,jg %d, ioff %d, joff %d\n",
+    msg->fldspecs->base,i,j,ig,jg,domain_info[d].ilocaloffset,domain_info[d].jlocaloffset ) ;
+    if ( first_1 == 1 )
+    {
+      first_1 = 0 ;
+      for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+      {
+        base = fld->base ;
+        fprintf(stderr, "  : base=%16x, elemsz=%d, strategy=%d \n"
+                           , base, fld->elemsz, fld->strategy
+               ) ;
+      }
+    }
+
+    fflush(stderr) ;
+  }
+#endif
+
+  for ( fld = msg->fldspecs ; fld != NULL ;  fld = fld->next )
+  {
+    elemsz = fld->elemsz ;
+    if ( fld->type >= 100 )
+    {
+      base = (void *)get_base_for_index( fld->f90_table_index ) ;
+    }
+    else
+    {
+      base = fld->base ;
+    }
+    switch (fld->strategy)
+    {
+    case MINNS_MAJEW_2D :		/*  eg: psa(i,j) */
+      t0 = fld->llen[0] ;
+      BWD( base+(i+j*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
+      break ;
+    case MINEW_MAJNS_2D :		/*      eg: xxx(j,i) */
+      t0 = fld->llen[0] ;
+      BWD( base+(j+i*t0)*elemsz,&(buf[cursor]),elemsz ) ; cursor+=elemsz ;
+      break ;
+    case MINNS_MAJEW_K_3D :		/*  eg: ua(i,j,k) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+        stride = t1 ;
+        ips = (int *)(&buf[cursor]) ;
+        ipd = (int *)(base + (i + j*t0)*elemsz) ;
+        /* ipd must be aligned on 4 byte boundary on some machines
+           for this to work -- a symptom of it not working would be
+           a bus error, for example. */
+        for ( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+           *ipd = *ips ;
+           ips ++ ;
+           ipd += stride ;
+        }
+        cursor += fld->llen[2] * elemsz ;
+        break ;
+#endif
+      default :
+        for( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+          BWD( base+(i+j*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
+          cursor+=elemsz ;
+        }
+        break ;
+      }
+      break ;
+    case MINEW_MAJNS_K_3D :		/*  eg: u(j,i,k) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+        stride = t1 ;
+        ips = (int *)(&buf[cursor]) ;
+        ipd = (int *)(base + (j + i*t0)*elemsz) ;
+        /* ipd must be aligned on 4 byte boundary on some machines
+           for this to work -- a symptom of it not working would be
+           a bus error, for example. */
+        for ( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+           *ipd = *ips ;
+           ips ++ ;
+           ipd += stride ;
+        }
+        cursor += fld->llen[2] * elemsz ;
+        break ;
+#endif
+      default :
+        for( k = 0 ; k < fld->llen[2] ; k++ )
+        {
+          BWD( base+(j+i*t0+k*t1)*elemsz,&(buf[cursor]),elemsz ) ;
+          cursor+=elemsz ;
+        }
+        break ;
+      }
+      break ;
+
+    case K_MIDNS_MAJEW_3D :             /*  eg: u(k,i,j) */
+      t0 = fld->llen[0] ;
+      t1 = fld->llen[1]*t0 ;
+      switch (elemsz)
+      {
+#ifdef INTXFER
+      case sizeof(int) :
+        ips = (int *)(&buf[cursor]) ;
+        ipd = (int *)(base + (i*t0+j*t1)*elemsz) ;
+        /* ipd must be aligned on 4 byte boundary on some machines
+           for this to work -- a symptom of it not working would be
+           a bus error, for example. */
+        for ( k = 0 ; k < t0 ; k++ )
+        {
+           *ipd++ = *ips++ ;
+        }
+        cursor += t0*elemsz ;
+        break ;
+#endif
+      default :
+        BWD( base+(i*t0+j*t1)*elemsz,&(buf[cursor]),t0*elemsz ) ;
+        cursor+=t0*elemsz ;
+        break ;
+      }
+      break ;
+
+    default:
+      RSL_TEST_ERR(1,"unpack_message: strategy not supported" ) ;
+      break ;
+    }
+  }
+  *cursor_p = cursor ;
+}
+
+my_bcopy( A, B, C )
+  char * A ;
+  char * B ;
+  int C ;
+{
+  int i ;
+  for ( i = 0 ; i < C ; i++ ) *(B+i) = *(A+i) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/patchmap.c b/wrfv2_fire/external/RSL/RSL/patchmap.c
new file mode 100755
index 00000000..06effb85
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/patchmap.c
@@ -0,0 +1,90 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include 
+#include "rsl.h"
+
+RSL_PATCH_DECOMP ( w1, w2, info_p, m_p, n_p, py_p, px_p ) 
+  int_p w1, w2, info_p, m_p, n_p, py_p, px_p ;
+{
+  int i ;
+  for ( i = 0 ; i < *n_p * *m_p ; i++ )
+    w2[i] = w1[i] ;
+  patchmap( w2, *m_p, *n_p, *py_p, *px_p ) ;
+  return(0) ;
+}
+
+patchmap( wrk, m, n, py, px )
+  int wrk[], m, n, py, px ;
+{
+  int x, y, ncells, nprocs, n_p, n_py, n_px, i, j, pid, p ;
+  int p_maj, p_min ;  /* processor # in lon, in lat */
+
+  nprocs = px * py ;
+
+  for ( j = 0 ; j < n ; j++ )
+  {
+    p_maj = locproc( j, n, px ) ;
+    for ( i = 0 ; i < m ; i++ )
+    {
+      p_min = locproc( i, m, py ) ;
+      wrk[ i + j*m ] = mesh_topo( p_min, py, p_maj, px ) ;
+    }
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/period_def.c b/wrfv2_fire/external/RSL/RSL/period_def.c
new file mode 100755
index 00000000..70359c1d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/period_def.c
@@ -0,0 +1,210 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_CREATE_PERIOD -- Create a period descriptor.
+
+  Notes:
+
+  See also:
+@*/
+
+RSL_CREATE_PERIOD ( pr_p )
+  int_p pr_p ;     /* (O) New RSL period descriptor. */
+{
+  int i ;
+  period_desc_t *per ;
+  
+  /* NOTE: never return the 0th period */
+  for ( i = 1 ; i < RSL_MAXDESCRIPTORS ; i++ )
+    if ( pr_descriptors[i] == NULL ) break ;    /* got one */
+
+  RSL_TEST_ERR( i == RSL_MAXDESCRIPTORS,
+  "rsl_create_period:  out of descriptors.");
+
+  *pr_p = i ;
+  per = RSL_MALLOC(period_desc_t,1) ;
+  per->tag = PERIOD_DESC ;
+  per->has_f90_fields = 0 ;
+  pr_descriptors[*pr_p] = per ;
+  per->pr = *pr_p ;
+}
+
+release_pr_descriptor (pr_p)
+  int_p pr_p ;
+{
+  int pr ;
+
+  pr = *pr_p ;
+  RSL_TEST_ERR( pr < 0 || pr >= RSL_MAXDESCRIPTORS,
+                "internal error.  Invalid period descriptor.") ;
+  if ( pr_descriptors[pr] != NULL )
+  {
+    pr_descriptors[pr] = NULL ;
+  }
+}
+
+/*@
+  RSL_DESCRIBE_PERIOD -- Defines an RSL period exchange on a domain.
+
+  Notes:
+
+  See also:
+
+@*/
+
+RSL_DESCRIBE_PERIOD ( d_p, pr_p, bdyw_p, message_p )
+  int_p d_p,            /* (I) Domain descriptor. */
+        pr_p,           /* (I) Period handle */
+        bdyw_p ;        /* (I) BDY width. */
+  int_p message_p ;       /* (I) Array of message descriptors. */
+{
+  int d, pr, mh, bdyw ;
+  rsl_domain_info_t * dinfo ;
+  period_desc_t *per ;
+  message_desc_t *msg ;
+  int pt ;
+
+  d = *d_p ; pr = *pr_p ; bdyw = *bdyw_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_describe_period: bad domain descriptor\n") ;
+  dinfo = &(domain_info[d]) ;
+  RSL_TEST_ERR(dinfo->valid != RSL_VALID,
+    "rsl_describe_period: descriptor is not for a valid domain\n") ;
+
+  RSL_TEST_ERR( bdyw < 1 ,
+    "rsl_describe_period: boundary width < 1" ) ;
+  RSL_TEST_ERR( pr < 0 || pr >= RSL_MAXDESCRIPTORS,
+    "rsl_describe_period: bad period handle" ) ;
+  per = (period_desc_t *) pr_descriptors[pr] ;
+  RSL_TEST_ERR( per->tag != PERIOD_DESC,
+       "rsl_describe_period: handle given is not for an rsl period def" ) ;
+
+  per->bdyw[d] = bdyw ;
+  per->compiled[d] = 0 ;
+
+  mh = *message_p ;
+  RSL_TEST_ERR( mh < 0 || mh >=RSL_MAXDESCRIPTORS,
+         "rsl_describe_period: bad message handle in list") ;
+  msg = (message_desc_t *) mh_descriptors[ mh ] ;
+  RSL_TEST_ERR( msg->tag != MESSAGE_DESC, 
+   "rsl_describe_period: handle given in message list is not for an rsl mesage def" ) ;
+  per->msgs[d] = msg ;
+  
+  release_mh_descriptor( message_p ) ;
+  /* add my descriptor to the list for the domain */
+  dinfo->periodlist[dinfo->periodcurs] = pr ;
+  dinfo->periodcurs++ ;  /* 970317 */
+  if ( dinfo->periodcurs >= RSL_MAXDESCRIPTORS )
+  {
+    sprintf(mess,
+     "Domain %d doesn't have room for any more periods, but the allowable\nlimit of %d should have been more than enough.\nYou might recompile RSL with a higher setting for RSL_MAXDESCRIPTORS, but\n it's likely something else is wrong.",
+       d, RSL_MAXDESCRIPTORS ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+}
+
+/* only used internally within the RSL package */
+destroy_period( per )
+  period_desc_t * per ;
+{
+  int d ;
+  rsl_fldspec_t *fld, *doomed ;
+  if ( per == NULL ) return ;
+  RSL_TEST_ERR( per->tag != PERIOD_DESC, "destroy_period: arg not a period desc.") ;
+
+  for ( d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    destroy_period_on_domain( d, per ) ;
+  }
+  release_pr_descriptor (per->pr) ;
+  RSL_FREE( per ) ;
+}
+
+destroy_period_on_domain( d, per )
+  int d ;
+  period_desc_t * per ;
+{
+  int i ;
+
+  if ( per == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "destroy_period_on_domain: bad domain descriptor") ;
+  destroy_message( per->msgs[d] ) ;
+  uncompile_period_on_domain( d, per ) ;
+}
+
+uncompile_period_on_domain( d, per )
+  int d ;
+  period_desc_t * per ;
+{
+  int i ;
+
+  if ( per == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "uncompile_period_on_domain: bad domain descriptor") ;
+  per->compiled[d] = 0 ;
+  destroy_procrec_list( per->procs[0][d] ) ;
+  destroy_procrec_list( per->procs[1][d] ) ;
+  per->procs[0][d] = NULL ; /* 970317 */
+  per->procs[1][d] = NULL ; /* 970317 */
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/period_def.h b/wrfv2_fire/external/RSL/RSL/period_def.h
new file mode 100755
index 00000000..adf6bcc3
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/period_def.h
@@ -0,0 +1,73 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef PERIOD_DEF_H
+#define PERIOD_DEF_H
+
+typedef struct period_desc {
+  rsl_tag_t tag;                        /* should be PERIOD_DESC */
+  int pr ;		/* my descriptor */
+  int has_f90_fields ;
+  rsl_tag_t compiled[RSL_MAXDOMAINS];
+  rsl_tag_t bdyw[RSL_MAXDOMAINS] ;
+  message_desc_t *msgs[RSL_MAXDOMAINS] ; 
+  rsl_procrec_t *procs[2][RSL_MAXDOMAINS] ; /* 2 is dir, RSL_M or RSL_N */
+} period_desc_t ;
+
+#endif  /* nothing after this line */
+
diff --git a/wrfv2_fire/external/RSL/RSL/period_refs.c b/wrfv2_fire/external/RSL/RSL/period_refs.c
new file mode 100644
index 00000000..78fd7eaa
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/period_refs.c
@@ -0,0 +1,133 @@
+#include 
+#include 
+#include "rsl.h"
+
+static rsl_list_t * list_head = NULL ;
+
+static int destroy_packrec( p ) packrec_t * p ; { free( p ) ; return(0) ; }
+
+static int compare_period_sort( a, b, dummy )
+  packrec_t *a, *b ;
+  int dummy ;
+{
+  if ( a != NULL && b != NULL )
+#if 0
+    if ((unsigned long)a->offset+(unsigned long)a->base > (unsigned long)b->offset+(unsigned long)b->base)
+#else
+    if ((unsigned long)a->base > (unsigned long)b->base)
+#endif
+      return(1) ;
+  return(0) ;
+}
+
+init_period_refs()
+{
+  rsl_list_t * lp, *lpnext ; 
+  destroy_list( &list_head, destroy_packrec ) ;
+  list_head = NULL ;
+}
+
+store_period_refs( base, f90_table_index , offset, n, nelems, stride )
+  void * base ;
+  int f90_table_index ;
+  int offset ;
+  int n ;
+  int nelems ;
+  int stride ;
+{
+  rsl_list_t * lp, *lp1, *lp2, *lp3, *lp4 ;
+  rsl_list_t * x ;
+  packrec_t * newrec, *arec, *nextrec ;
+  int found, found1 ;
+
+  newrec = RSL_MALLOC( packrec_t, 1 ) ;
+  newrec->base = base ;
+  newrec->f90_table_index = f90_table_index ;
+  newrec->offset = offset ;
+  newrec->n = n ;
+  newrec->nelems = nelems ;
+  newrec->stride = stride ;
+  newrec->valid = 1 ;
+
+  lp1 = NULL ;
+  for ( lp = list_head ; lp != NULL ; lp = lp->next )
+  {
+    lp1 = lp ;
+  }
+  if ( lp1 == NULL )
+  {
+    lp1 = RSL_MALLOC( rsl_list_t, 1 ) ;
+    lp1->next = NULL ;
+    list_head = lp1 ;
+  }
+  else
+  {
+    lp1->next = RSL_MALLOC( rsl_list_t, 1 ) ;
+    lp1 = lp1->next ;
+    lp1->next = NULL ;
+  }
+  lp1->data = newrec ;
+}
+
+#include 
+RSL_INTERNAL_MILLICLOCK ()
+{
+    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 = 1000 * isec + usec / 1000 ;
+    return(msecs) ;
+}
+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) ;
+}
+
+period_refs( pack_table, pack_table_size, pack_table_nbytes, collapse )
+  packrec_t ** pack_table ;
+  int * pack_table_size, *pack_table_nbytes, collapse ;
+{
+  /* First sort the primary list, then sort each of the secondary lists
+     in the data structure built by
+     store_process_refs.   Finally, go through and collapse them. */
+
+  rsl_list_t * lp, *lp1, *lp2, *lp3 ;
+  packrec_t *x, *y ;
+  int i, nbytes ;
+  int compare_period_sort() ;
+
+  /* figure the number of entries */
+  for ( i = 0, lp = list_head ; lp ; lp = lp->next )
+      i++ ;
+
+  *pack_table_size = i ;
+
+  /* now allocate and populate the table */
+  *pack_table = RSL_MALLOC( packrec_t, *pack_table_size ) ;
+  for ( i = 0, nbytes = 0, lp = list_head ; lp ; lp = lp->next )
+    {
+      x = (packrec_t *)lp->data ;
+      nbytes += x->n * x->nelems ;
+      bcopy(lp->data,&((*pack_table)[i]),sizeof(packrec_t)) ;
+      i++ ;
+    }
+
+  *pack_table_nbytes = nbytes ;
+  
+  return ;
+}
+ 
diff --git a/wrfv2_fire/external/RSL/RSL/picl_mpl_compat.c b/wrfv2_fire/external/RSL/RSL/picl_mpl_compat.c
new file mode 100755
index 00000000..0ec081b4
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/picl_mpl_compat.c
@@ -0,0 +1,462 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#ifdef MPL
+#ifndef __MPL_COMPAT__
+#define __MPL_COMPAT__
+
+#include 
+
+typedef unsigned int MPL_Request ;
+typedef unsigned int MPL_Status ;
+
+#define PICLHandleInc 128
+
+struct tagsToHandles
+       {
+       int tag;
+       MPL_Request Handle;
+       int type ;		/* send = 1, recv = 2 */
+       int nbytes ;
+       };
+struct piclMPLHandles
+       {
+       int nHandles;
+       int nUsed;
+       struct tagsToHandles *tags;
+       } piclMPLHandleLUT;
+
+/******************************************************
+ * piclMPLInit ()
+ *   do whatever initialization is necessary for the
+ *   MPL port
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *  Adapted to MPL: J. Michalakes 7/13/94
+ *  Adapted to PICL from RSL: J. Michalakes 7/13/94
+ *
+ *****************************************************/
+
+static int argc_dummy = 0 ;
+static char * argv_dummy = "" ;
+
+int dontcare ;
+int allmsg ;
+int nulltask ;
+int allgrp ;
+int type_low ;
+int type_high ;
+
+/*
+ *   setarc0
+ */
+
+void setarc0( i1, i2, i3, i4 ) 	/* noop */
+  int *i1, *i2, *i3, *i4 ;
+{ return ; }
+
+/*
+ *   check0
+ */
+
+void check0( i1 ) 	        /* noop */
+  int *i1 ;
+{ return ; }
+
+/*
+ *   open0
+ */
+
+void open0( nprocs, me, dum )
+  int *nprocs, *me, *dum ;
+{
+  int nbuf[4] ;
+   
+  piclMPLHandleLUT.nHandles = PICLHandleInc;
+  piclMPLHandleLUT.nUsed = 0;
+  piclMPLHandleLUT.tags = (struct tagsToHandles *) 
+                     malloc (sizeof (struct tagsToHandles) * PICLHandleInc);
+
+  mpc_task_query( nbuf, 2, 2 ) ;
+  type_low = nbuf[0] ;
+  type_high= nbuf[1] ;
+  mpc_task_query( nbuf, 4, 3 ) ;
+  dontcare = nbuf[0] ;
+  allmsg   = nbuf[1] ;
+  nulltask = nbuf[2] ;
+  allgrp   = nbuf[3] ;
+
+#if 0
+  fprintf(stderr,"piclMPLInit: \n") ;
+  fprintf(stderr,"type_low:  %d\n",type_low) ;
+  fprintf(stderr,"type_high: %d\n",type_high) ;
+  fprintf(stderr,"dontcare:  %d\n",dontcare) ;
+  fprintf(stderr,"allmsg:    %d\n",allmsg) ;
+  fprintf(stderr,"nulltask:  %d\n",nulltask) ;
+  fprintf(stderr,"allgrp:    %d\n",allgrp) ;
+#endif
+
+
+  if (piclMPLHandleLUT.tags == NULL)
+  {
+    fprintf (stderr, "Fatal Error: malloc failure in piclMPLInit\n");
+    exit(1);
+  }
+
+  who0( nprocs, me, dum ) ;
+}
+
+/*
+ *   who0
+ */
+who0( nprocs, me, dum )
+  int *nprocs, *me, *dum ;
+{
+  mpc_environ( nprocs, me ) ;
+}
+
+/*
+ *   clock0
+ */
+double clock0()
+{
+  fprintf(stderr,"Warning -- clock0 is stubbed in %s\n", __FILE__ ) ;
+  return(0.0) ;		 /* stub for now */
+}
+
+/*
+ *   recv0
+ */
+
+recv0( buf, len, type )
+  char *buf ;
+  int *len, *type ;
+{
+  int rc ;
+  int rsl_mp_source ;
+  int rsl_mp_type ;
+  int rsl_mp_n ;
+
+  rsl_mp_type = *type ;
+  rsl_mp_n = *len ;
+
+  if ( rsl_mp_type < type_low || rsl_mp_type > type_high )
+  {
+    sprintf(mess,"RSL_RECV message type %d out of allowed range: %d..%d\n",
+            rsl_mp_type,type_low,type_high) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  rc = mpc_brecv(buf,rsl_mp_n,
+                 &rsl_mp_source,
+                 &rsl_mp_type,
+                 &rsl_mp_nbytes) ;
+  if ( rc ) {fprintf(stderr,"mpc_brecv returns %d\n",rc);exit(1);} 
+  if ( rsl_mp_nbytes > (*len) )
+  {
+    fprintf(stderr,"Message too large: tag %d, recvd %d, allocated %d\n",
+            *type,rsl_mp_nbytes,(*len));
+  }
+}
+
+/*
+ *   send0
+ */
+
+send0( buf, len, type, dest )
+  char *buf ;
+  int *len, *type, *dest ;
+{
+  int rc ;
+  int rsl_mp_type ;
+
+  rsl_mp_type = *type ;
+  if ( rsl_mp_type < type_low || rsl_mp_type > type_high )
+  {
+    sprintf(mess,"RSL_SEND message type %d out of allowed range: %d..%d\n",
+    rsl_mp_type,type_low,type_high) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  if (0) fprintf(stderr,"mpc_bsend: nlen %10d  type %10d  dest %10d\n", \
+                 B, rsl_mp_type, D ) ; \
+  rc = mpc_bsend(A,B,D,C) ; \
+  if ( rc ) {fprintf(stderr,"mpc_bsend returns %d\n",rc);exit(1);} \
+}
+
+
+
+
+/******************************************************
+ * piclMPLFindWaitH (tag)
+ *  Use the LUT to find an MPL wait handle from a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+long piclMPLFindWaitH (tag, waitHandle, type, nbytes )
+  int tag;   /* Tag for which we lookup a wait handle */
+  MPL_Request *waitHandle ;
+  int *type, *nbytes ;
+{
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < piclMPLHandleLUT.nUsed; i++)
+  {
+    if (piclMPLHandleLUT.tags[i].tag == tag)
+    {
+      *waitHandle = piclMPLHandleLUT.tags[i].Handle;
+      *type = piclMPLHandleLUT.tags[i].type;
+      *nbytes = piclMPLHandleLUT.tags[i].nbytes;
+      piclMPLHandleLUT.nUsed--;  /* Keep them contiguous */
+      piclMPLHandleLUT.tags[i].tag=piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].tag;
+      piclMPLHandleLUT.tags[i].Handle=
+                  piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].Handle;
+      piclMPLHandleLUT.tags[i].type=
+		  piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].type;
+      piclMPLHandleLUT.tags[i].nbytes=
+		  piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].nbytes ;
+      retVal = 0 ;
+      break;
+    }
+  }
+  return( retVal ) ;
+}
+
+/******************************************************
+ * piclMPLSaveWaitH (tag, waitHandle)
+ *  Use the LUT to save an MPL wait handle referenced by a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void piclMPLSaveWaitH (tag, waitHandle,type,nbytes)
+ int tag;
+ MPL_Request * waitHandle;
+ int type, nbytes ;
+{
+ /* Make sure there is enough space, if not, try a realloc */
+ /* If the realloc fails we're in deep trouble */
+ if (piclMPLHandleLUT.nUsed == piclMPLHandleLUT.nHandles)
+   {
+   struct tagsToHandles *tags;  /* Temp pointer */
+   tags = (struct tagsToHandles *) 
+      realloc (piclMPLHandleLUT.tags, 
+      sizeof (struct tagsToHandles) * (piclMPLHandleLUT.nHandles + PICLHandleInc));
+   if (tags != NULL)
+     {
+     piclMPLHandleLUT.tags = tags;
+     piclMPLHandleLUT.nHandles += PICLHandleInc;
+     }
+   else
+     {
+#ifdef FATAL_ERRORS
+     fprintf (stderr, "Fatal Error: realloc failure in piclMPLSaveWaitH\n");
+     exit(1);
+#endif
+     return;
+     }
+   }
+ /* Stash the handle */
+ piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].tag = tag;
+ piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].Handle = *waitHandle;
+ piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].type = type ;
+ piclMPLHandleLUT.tags[piclMPLHandleLUT.nUsed].nbytes = nbytes ;
+ piclMPLHandleLUT.nUsed++;
+}
+
+/******************************************************
+ * piclMPLISend (buff, mlen, tag, dest)
+ *  Post a non blocking send an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void piclMPLISend (buff, mlen, tag, dest)
+ char *buff;
+ int mlen;
+ int tag;
+ int dest;
+ {
+   MPL_Request waitHandle;
+   int rc ;
+ 
+   if ( tag < type_low || tag > type_high )
+   {
+sprintf(mess,"PICL_SENDBEGIN message type %d out of allowed range: %d..%d\n",
+tag,type_low,type_high) ;
+PICL_TEST_ERR( 1, mess ) ;
+   }
+
+   rc = mpc_send  (buff,
+              mlen,
+              dest,
+              tag,
+              &waitHandle); 
+
+#if 0
+fprintf(stderr,"mpc_send: nlen %10d  type %10d  dest %10d  handle %08x\n",
+mlen, tag, dest, waitHandle ) ;
+#endif
+
+   if ( rc )
+   {
+     sprintf(mess,"mpc_send returns %d", rc ) ;
+     PICL_TEST_ERR( 1, mess ) ;
+   }
+
+   piclMPLSaveWaitH (tag, &waitHandle,1,mlen);
+ }
+ 
+/******************************************************
+ * piclMPLIRecv (buff, mlen, tag)
+ *  Post a non blocking receive an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void piclMPLIRecv (buff, mlen, tag)
+ char *buff;
+ int mlen;
+ int tag;
+ {
+   MPL_Request waitHandle;
+   int source ;
+   int tagloc ;
+   int rc ;
+
+   source = dontcare ;
+   tagloc = tag ;
+
+   if ( tag < type_low || tag > type_high )
+   {
+sprintf(mess,"PICL_RECVBEGIN message type %d out of allowed range: %d..%d\n",
+tag,type_low,type_high) ;
+PICL_TEST_ERR( 1, mess ) ;
+   }
+
+
+   rc = mpc_recv  (buff,
+              mlen,
+              &source,
+              &tagloc,
+              &waitHandle);
+
+#if 0
+fprintf(stderr,"mpc_recv: nlen %10d  type %10d  source %10d  handle %08x\n",
+mlen, tag, source, waitHandle ) ;
+#endif
+
+   if ( rc )
+   {
+     sprintf(mess,"mpc_recv returns %d", rc ) ;
+     PICL_TEST_ERR( 1, mess ) ;
+   }
+
+   piclMPLSaveWaitH (tag, &waitHandle, 2, mlen);
+ }
+
+/******************************************************
+ * piclMPLWait (tag)
+ *  Wait for a pending send/recv
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+extern int mperrno ;
+ 
+void piclMPLWait (tag)
+ int tag;
+{
+  MPL_Request waitHandle;
+  MPL_Status status ;
+  int rc ;
+  int type, nbytes;
+
+  if ( piclMPLFindWaitH (tag, &waitHandle, &type, &nbytes ) != 0 )
+  {
+    fprintf(stderr,"piclMPLWait: tag %d not found by piclMPLFindWaitH\n",tag) ;
+    exit(2) ;
+  }
+
+#if 0
+  fprintf(stderr,"calling mpc_wait: tag %d, handle %08x, type %d (%s), original nbytes %d\n",
+        tag, waitHandle, type, (type==1)?"send":((type==2)?"recv":"unknown"),
+	nbytes) ;
+#endif
+
+  rc = mpc_wait ( &waitHandle, &status  );
+  if ( rc )
+  {
+    fprintf(stderr,"mpc_wait fails: tag %d, handle %08x, type %d (%s), original nbytes %d, status %d, rc %d, mperrno = %d\n",
+        tag, waitHandle, type, (type==1)?"send":((type==2)?"recv":"unknown"),
+	nbytes, status, rc, mperrno) ;
+    exit(2) ;
+  }
+
+#if 0
+  fprintf(stderr,"mpc_wait : tag %d, handle %08x, status %d\n",
+        tag, waitHandle, status) ;
+#endif
+
+}
+
+#endif /* __MPL_COMPAT__ */
+#endif /* MPL */
diff --git a/wrfv2_fire/external/RSL/RSL/proc.c b/wrfv2_fire/external/RSL/RSL/proc.c
new file mode 100755
index 00000000..0ea9e6b7
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/proc.c
@@ -0,0 +1,254 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+#ifdef FORTRANMANUAL
+/*@
+  RSL_IAMMONITOR -- Informational routine: am I the monitor?
+
+  Notes:
+  This function returns the value .TRUE. on the monitor processor
+  (usually node zero), and .FALSE. otherwise.  The monitor node is the
+  I/O node and also the root node for broadcasts (using RSL_MON_BCAST)
+  and internal reads and writes (RSL_READ, RSL_WRITE).  RSL_IAMMONITOR
+  may be called before RSL_MESH has been called.
+
+  Example:
+$  IF ( RSL_IAMMONITOR() ) THEN
+$    CALL RSL_UOPEN( INPUT_UNIT, FNAME, "OLD" )
+$  ENDIF
+BREAKTHEEXAMPLECODE
+  This shows RSL_IAMMONITOR being used in conjunction with
+  the RSL unformatted fortran open routine to do a named
+  upon on the monitor processor.
+
+  See also:
+  RSL_C_IAMMONITOR, RSL_MESH, RSL_MON_BCAST, RSL_READ, RSL_WRITE
+  
+@*/
+int
+RSL_IAMMONITOR ( retval )
+  int_p retval ;   /* Return value */
+{}
+#endif
+
+/*@
+  RSL_C_IAMMONITOR -- Informational routine: am I the monitor?
+
+  Notes:
+  The integer Arg1 is set to 1 on the monitor processor.  The monitor
+  (usually node zero).  The monitor node is the I/O node and also the
+  root node for broadcasts
+  (using RSL_MON_BCAST) and internal reads and writes (RSL_READ, RSL_WRITE).
+  RSL_C_IAMMONITOR may be called before RSL_MESH has been called.
+
+  See also:
+  RSL_IAMMONITOR, RSL_MESH, RSL_MON_BCAST, RSL_READ, RSL_WRITE
+  
+@*/
+
+int
+RSL_C_IAMMONITOR ( retval )
+  int_p retval ;  /* Return value. */
+{
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+					/* hostless */
+  if ( rsl_myproc == rsl_nproc-1 ) 
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  else
+					/* have a host node */
+  if ( rsl_myproc == 0 ) 
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+  if ( rsl_myproc == rsl_nproc )
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  else
+  if ( rsl_myproc == 0 )
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  endif
+#endif
+  return(0) ;
+}
+
+int
+RSL_C_IAMCOMPUTE ( retval )
+  int_p retval ;
+{
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+  if ( rsl_myproc < rsl_nproc-1 ) 
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  else
+  if ( rsl_myproc > 0 )
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+  if ( rsl_myproc < rsl_nproc )
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  else
+  if ( rsl_myproc > 0 )
+    *retval = 1 ;
+  else
+    *retval = 0 ;
+#  endif
+#endif
+  return(0) ;
+}
+
+RSL_MONITOR_PROC ( retval )
+   int * retval ;
+{
+   *retval = RSL_C_MONITOR_PROC () ;
+}
+
+
+RSL_C_MONITOR_PROC ()
+{
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+  return(rsl_nproc-1) ; 
+#  else
+  return(0) ; 
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+  return(rsl_nproc) ; 
+#  else
+  return(0) ; 
+#  endif
+#endif
+}
+
+/* this maps compute processor id (0 based) to physical
+   processor id */
+int
+rsl_c_comp2phys_proc ( P ) 
+  int P ;
+{
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+  return(P) ;
+#  else
+  return(P) ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+  return(P) ;     /* monitor is high */
+#  else
+  return(P+1) ;     /* monitor is low */
+#  endif
+#endif
+}
+
+
+RSL_COMP2PHYS_C ( P, retval )
+  int_p P, retval ;
+{
+  *retval = rsl_c_comp2phys_proc( *P ) ;
+  return ;
+}
+
+
+/* this maps physical processor id to compute proc id
+   inverse of rsl_c_comp2phys_proc */
+
+int 
+rsl_c_phys2comp_proc( P )
+{
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+  return(P) ;
+#  else
+  return(P) ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+  return(P) ;		/* monitor is high */
+#  else
+  return(P-1) ;		/* monitor is low */
+#  endif
+#endif
+}
+
+RSL_PHYS2COMP_C ( P, retval )
+  int_p P, retval ;
+{
+  *retval = rsl_c_phys2comp_proc( *P ) ;
+  return ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/proc_f.F b/wrfv2_fire/external/RSL/RSL/proc_f.F
new file mode 100755
index 00000000..31375a67
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/proc_f.F
@@ -0,0 +1,100 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      logical function rsl_iammonitor()           ! wrapper
+      implicit none
+      external rsl_c_iammonitor
+      integer retval
+      call rsl_c_iammonitor( retval ) 
+      if ( retval .eq. 1 ) then
+         rsl_iammonitor = .true.
+      else
+         rsl_iammonitor = .false.
+      endif
+      return
+      end
+
+      logical function rsl_iamcompute()           ! wrapper
+      implicit none
+      external rsl_c_iamcompute
+      integer retval
+      call rsl_c_iamcompute( retval )  
+      if ( retval .eq. 1 ) then
+         rsl_iamcompute = .true.
+      else
+         rsl_iamcompute = .false.
+      endif
+      return
+      end
+
+      integer function rsl_phys2comp( p )
+      implicit none
+      external rsl_phys2comp_c
+      integer retval, p
+      call  rsl_phys2comp_c( p, retval )
+      rsl_phys2comp = retval
+      return
+      end
+
+      integer function rsl_comp2phys( p )
+      implicit none
+      external rsl_comp2phys_c
+      integer retval, p
+      call  rsl_comp2phys_c( p, retval )
+      rsl_comp2phys = retval
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/process_refs.c b/wrfv2_fire/external/RSL/RSL/process_refs.c
new file mode 100644
index 00000000..79328c5d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/process_refs.c
@@ -0,0 +1,530 @@
+#include 
+#include 
+#include "rsl.h"
+
+#ifdef NEC_TUNE
+typedef struct{
+  int max_nsec ;                   /* Maximum number of entris on secondary list */
+  int nsec ;                       /* Number of entries on secondary list */
+  void *base ;                     /* Base address */
+  int *offset ;                    /* Array of "offsets" associated with base */
+  int *n ;                         /* Array of "lengths" associated with offset */
+  packrec_t **data ;               /* Array of "Ptr's to head data" */
+} Pri_lst_t ;
+static int max_npri = 128 ;        /* Max. no of "base" entries on primary list */
+static int npri = 0 ;              /* Number of "base" entries on primary list */
+static Pri_lst_t *Pri_lst = NULL ; /* Primary list */
+#endif
+static rsl_list_t * list_head = NULL ;
+
+static int destroy_packrec( p ) packrec_t * p ; { free( p ) ; return(0) ;}
+
+init_process_refs()
+{
+  int destroy_packrec() ;
+  rsl_list_t * lp, *lpnext ; 
+
+  for ( lp = list_head ; lp ; lp = lp->next )
+  {
+    destroy_list( &(lp->data), destroy_packrec ) ;
+  }
+  destroy_list( &list_head, NULL ) ;
+#ifdef NEC_TUNE
+/*
+   NECNOTE: 
+   If primary list is allocated and has entries assigned, free all data
+   allocated on secondary lists by reseting variable 'nsec' to zero.
+*/
+  if ( npri != 0 )
+  {
+    int ipri ;
+    for ( ipri = 0 ; ipri < npri ; ipri++ )
+    {
+      Pri_lst[ipri].nsec = 0 ; /* Free all entries on secondary list */
+    }
+    npri = 0 ; /* Free all entries on primary list */
+  }
+#endif
+}
+/*
+   The data structure being built by this routine:
+      (n is next pointer, d is data pointer)
+   The primary list (downwards) is a list of lists.
+   Each of the secondary lists (leftwards) is a list of all the
+   pack or unpack records with the same base.  This routine
+   checks to ensure that recs that are complete duplicates
+   (which can happen) are not added.
+
+   list_t -d-> list_t -n-> list_t -n-> list_t -n-> ...
+    |           \            \           \
+    n            d            d           d
+    |             \            \            \
+    |           base,off,n    base,off,n   base,off,n    ...
+    v
+   list_t -d-> list_t -n-> list_t -n-> list_t -n-> ...
+    |           \            \           \
+    n            d            d           d
+    |             \            \            \
+    |           base,off,n    base,off,n   base,off,n    ...
+    v
+   list_t -d-> list_t -n-> list_t -n-> list_t -n-> ...
+    |           \            \           \
+    n            d            d           d
+    |             \            \            \
+    |           base,off,n    base,off,n   base,off,n    ...
+    v
+    .
+    .
+    .
+*/
+
+store_process_refs( base, f90_table_index , offset, n, nelems, stride )
+  void * base ;
+  int f90_table_index ;
+  int offset ;
+  int n ;
+  int nelems ;
+  int stride ;
+{
+  rsl_list_t * lp, *lp1, *lp2, *lp3, *lp4 ;
+  rsl_list_t * x ;
+  packrec_t * newrec, *arec, *nextrec ;
+  int found, found1 ;
+#ifdef NEC_TUNE
+  int ipri ;
+  int isec ;
+  int found_search ;
+
+  if ( Pri_lst == NULL ) /* Need to initialize Primary list */
+  {
+    Pri_lst = realloc(Pri_lst, max_npri*sizeof(Pri_lst_t)) ;
+    RSL_TEST_ERR(Pri_lst == NULL, "out of memory - 1") ;
+  }
+#endif
+
+#if 0
+fprintf(stderr,"debug store_process_refs 1 base %08x ",base) ;
+fprintf(stderr," f90_table_index %3d ",f90_table_index) ;
+fprintf(stderr," offset %10d ",offset) ;
+fprintf(stderr," n %5d",n) ;
+fprintf(stderr," nelems %5d",nelems) ;
+fprintf(stderr," stride %5d\n",stride) ;
+#endif
+
+  newrec = RSL_MALLOC( packrec_t, 1 ) ;
+  newrec->endstop = 0 ;
+  if ( stride < 0 ) { newrec->endstop = 1 ; stride = -stride ; }
+  newrec->base = base ;
+  newrec->f90_table_index = f90_table_index ;
+  newrec->offset = offset ;
+  newrec->n = n ;
+  newrec->nelems = nelems ;
+  newrec->stride = stride ;
+  newrec->valid = 1 ;
+
+  /* traverse the primary list and see if there's a secondary
+     list already for this base address.  If there is not, add
+     it with newrec as the first entry in the new secondar list. 
+     If there is alread a secondary list, traverse it and make sure
+     there's not already an entry for newrec.  If there isn't, add
+     an entry for newrec to the end of the secondary list. */
+  found = 0 ;
+#ifdef	NEC_TUNE
+  for ( ipri = 0 ; ipri < npri ; ipri++ )
+  {
+    if ( base == Pri_lst[ipri].base )
+    {
+      found = 1 ;
+      break ;
+    }
+  }
+  if ( found )
+  {
+    /* Quick search to see whether this is a duplicate call. */
+    found_search = 0 ;
+#pragma vdir altcode=loopcnt
+    for ( isec = 0 ; isec < Pri_lst[ipri].nsec ; isec++ )
+    {
+      if ( Pri_lst[ipri].offset[isec] == offset )
+      {
+        found_search = 1 ; /* return silently */
+        break ;
+      }
+    }
+    if ( found_search )
+    {
+      if ( Pri_lst[ipri].n[isec] < n )
+      {
+        Pri_lst[ipri].n[isec] = n ;
+        Pri_lst[ipri].data[isec]->n = n ;
+      }
+      RSL_FREE(newrec) ;
+      return ;
+    }
+  }
+#endif
+  for ( lp = list_head ; lp ; lp = lp->next )
+  {
+    if ( lp != NULL )
+      if ((lp1 = (rsl_list_t *)lp->data) != NULL )
+         if ((arec = (packrec_t *) lp1->data) != NULL )
+           if ( arec->base == base )
+           {
+             found = 1 ;
+             break ;
+           }
+  }
+  if ( !found )
+  {
+    x = RSL_MALLOC( rsl_list_t, 1 ) ;
+    x->next = list_head ;
+    list_head = x ;
+    x->data = RSL_MALLOC( rsl_list_t, 1 ) ;
+    ((rsl_list_t *) x->data)->data = newrec ;
+    ((rsl_list_t *) x->data)->next = NULL ;
+  }
+  else
+  {
+    /* includes an insertion sort */
+    found1 = 0 ;
+#ifndef NEC_TUNE
+    for ( lp2 = lp1 ; lp2 != NULL ; lp2 = lp2->next )
+    {
+      lp3 = lp2 ;  /* store previous lp2 */
+      arec = (packrec_t *) lp2->data ;
+
+      if (lp2 == lp1)
+      {
+	if ( newrec->offset < arec->offset )
+	{ found1 = 0 ; break ; }
+      }
+      if (newrec->offset == arec->offset)
+      {
+        if (arec->n >= newrec->n)
+          { found1 = 1 ; break ; }
+        else
+          { arec->n = newrec->n ; found1 = 1 ; break ; }
+      }
+      else if (lp2->next != NULL)
+      {
+	nextrec = lp2->next->data ;
+	if ( newrec->offset > arec->offset &&
+	     newrec->offset < nextrec->offset )
+        { found1 = 2 ; break ; }
+      }
+      else if (newrec->offset > arec->offset)
+      {
+        { found1 = 2 ; break ; }
+      }
+    }
+#else
+    for ( lp2 = lp1 ; lp2 != NULL ; lp2 = lp2->next )
+    {
+      lp3 = lp2 ;  /* store previous lp2 */
+      arec = (packrec_t *) lp2->data ;
+
+      if (lp2 == lp1)
+      {
+        if ( offset < arec->offset )
+        { found1 = 0 ; break ; }
+      }
+      if (offset == arec->offset)
+      {
+        if (arec->n >= n)
+          { found1 = 1 ; break ; }
+        else
+          { arec->n = n ; found1 = 3 ; break ; }
+      }
+      else if (lp2->next != NULL)
+      {
+        nextrec = lp2->next->data ;
+        if ( offset > arec->offset &&
+             offset < nextrec->offset )
+        { found1 = 2 ; break ; }
+      }
+      else if (offset > arec->offset)
+      {
+        { found1 = 2 ; break ; }
+      }
+    }
+/* NECNOTE: Add base/offset/n to duplicate list. */
+    if ( found1 == 1 || found1 == 3 )
+    {
+      int nsec ;
+      int pri_found ;
+      RSL_FREE(newrec) ;
+
+      for ( ipri = 0, pri_found = 0 ; ipri < npri ; ipri++ )
+      {
+        if ( Pri_lst[ipri].base == base )
+        {
+          pri_found = 1 ;
+          break ;
+        }
+      }
+
+      if ( !pri_found )
+      {
+        if ( npri == max_npri )
+        {
+          max_npri *= 2 ;
+          Pri_lst = (Pri_lst_t *)realloc(Pri_lst, max_npri*sizeof(Pri_lst_t)) ;
+        }
+
+        Pri_lst[npri].max_nsec = 128 ;
+        Pri_lst[npri].nsec = 0 ;
+        Pri_lst[npri].base = base ;
+/*
+   NECNOTE:
+   I'd like to use RSL_MALLOC, but there is a good chance that the
+   following two pointers will be 'realloc'ed.
+*/
+        Pri_lst[npri].offset = (int *)malloc(Pri_lst[npri].max_nsec*sizeof(int)) ;
+        Pri_lst[npri].n = (int *)malloc(Pri_lst[npri].max_nsec*sizeof(int)) ;
+        Pri_lst[npri].data = (packrec_t **)malloc(Pri_lst[npri].max_nsec*sizeof(packrec_t *)) ;
+        RSL_TEST_ERR(Pri_lst[npri].offset == NULL || Pri_lst[npri].n == NULL ||
+                     Pri_lst[npri].data == NULL, "out of memory - 2") ;
+        npri++ ;
+      }
+
+      nsec = Pri_lst[ipri].nsec ;
+      if ( nsec == Pri_lst[ipri].max_nsec )
+      {
+        Pri_lst[ipri].max_nsec *= 2 ;
+        Pri_lst[ipri].offset = (int *)realloc(Pri_lst[ipri].offset, Pri_lst[ipri].max_nsec*sizeof(int)) ;
+        Pri_lst[ipri].n = (int *)realloc(Pri_lst[ipri].n, Pri_lst[ipri].max_nsec*sizeof(int)) ;
+        Pri_lst[ipri].data = (packrec_t **)realloc(Pri_lst[ipri].data, Pri_lst[ipri].max_nsec*sizeof(packrec_t *)) ;
+      }
+
+      Pri_lst[ipri].offset[nsec] = offset ;
+      Pri_lst[ipri].n[nsec] = n ;
+      Pri_lst[ipri].data[nsec] = arec ;
+      Pri_lst[ipri].nsec++ ;
+    }
+#endif
+    if ( found1 == 0 )      /* not found; add to beginning of list */
+    {
+      lp4 = RSL_MALLOC( rsl_list_t, 1 ) ;
+      lp4->next = (rsl_list_t *) lp->data ;
+      lp4->data = newrec ;
+      lp->data = lp4 ;
+    }
+    if ( found1 == 2 )      /* insert after this element */
+    {
+      lp4 = RSL_MALLOC( rsl_list_t, 1 ) ;
+      lp4->data = newrec ;
+      lp4->next = lp2->next ;
+      lp2->next = lp4 ;
+    }
+  }
+}
+
+static int compare_primary( lp1, lp2, dummy )
+  rsl_list_t *lp1, *lp2 ;
+  int dummy ;
+{
+  rsl_list_t *a, *b ;
+  packrec_t *x, *y ;
+  if ( lp1 != NULL && lp2 != NULL )
+  {
+    if ((x=(packrec_t*)lp1->data) != NULL && (y=(packrec_t*)lp2->data) != NULL )
+    {
+      if (x->base > y->base)
+      {
+        return(1) ;
+      }
+    }
+    else
+      RSL_TEST_ERR(1,"compare_primary 2") ;
+  }
+  else
+    RSL_TEST_ERR(1, "compare_primary 1" ) ;
+  return(0) ;
+}
+
+static int compare_secondary( a, b, dummy )
+  packrec_t *a, *b ;
+  int dummy ;
+{
+  if ( a != NULL && b != NULL )
+    if (a->offset > b->offset) 
+      return(1) ;
+  return(0) ;
+}
+
+static int collapsetable( lst )
+  rsl_list_t ** lst ;
+{
+  rsl_list_t * lp, * lp2, * prevlp ;
+  packrec_t *x, *y ;
+
+  if ( lst == NULL ) return(0)  ;
+
+lp = *lst ; x = lp->data ; if ( ! (x->valid ) ) RSL_TEST_ERR(1,"internal error: first entry invalid\n") ;
+
+  for ( lp = *lst ; lp != NULL ; lp = lp->next )
+  {
+    if (( x = lp->data ) != NULL ) ; if ( x->valid )       /* 2 statements */
+    {
+      for ( lp2 = lp->next ; lp2 != NULL ; lp2 = lp2->next )
+      {
+        if (( y = lp2->data ) != NULL ) ; if ( y->valid )  /* 2 statements */
+        {
+          if ((x->stride == y->stride) &&
+              (x->nelems == y->nelems) &&
+	      ((x->offset + x->n ) == y->offset) && ! x->endstop )
+          {
+	    {
+              y->valid = 0 ;
+              x->n += y->n ;
+	    }
+	  }
+          else
+	  {
+	    break ;   /* out of inner loop */
+	  }
+        }
+      }
+    }
+  }
+/* new bit... collapse sequences of entries with the same base and stride */
+  {
+    int xn, bigstride, firsty ;
+    for ( lp = *lst ; lp != NULL ; lp = lp->next )
+    {
+      if (( x = lp->data ) != NULL ) ; if ( x->valid )       /* 2 statements */
+      {
+        if ( x->nelems != 1 ) continue ;
+        xn = x->n ;
+	firsty = 1 ;
+        for ( lp2 = lp->next ; lp2 != NULL ; lp2 = lp2->next )
+        {
+          if (( y = lp2->data ) != NULL ) ; if ( y->valid )  /* 2 statements */
+          {
+	    if ( y->base != x->base ) break ;
+	    if ( y->nelems != 1 ) break ;
+	    if ( y->n != xn ) break ;
+	    if ( firsty == 1 ) /* first y */
+	    {
+	      firsty = 0 ;
+	      bigstride = y->offset - x->offset ;
+	    }
+	    if ( bigstride <= x->n ) break ;
+	    if ( y->offset - x->offset == bigstride )
+	    {
+	      y->valid = 0 ;
+	      x->nelems++ ;
+	      x->stride = bigstride ;
+	    }
+          }
+        }
+      }
+    }
+  }
+  /* now eliminate the invalidated entries */
+  for ( prevlp = *lst, lp = *lst ; lp != NULL ; )
+  {
+    if (( x=lp->data ) != NULL ) ; if ( ! x->valid )   /* 2 statements */
+    {
+      RSL_TEST_ERR( lp == *lst , " internal error -- shouldn't happen " ) ;
+      prevlp->next = lp->next ;
+      lp->next = NULL ;
+      destroy_list( &lp, destroy_packrec ) ;  /* destroys just one rec */
+      lp2 = prevlp ;
+      lp = prevlp->next ;
+    }
+    else
+    {
+      lp2 = lp ;
+      lp = lp->next ;
+    }
+    prevlp = lp2 ;
+  }
+}
+
+process_refs( pack_table, pack_table_size, pack_table_nbytes, collapse )
+  packrec_t ** pack_table ;
+  int * pack_table_size, *pack_table_nbytes, collapse ;
+{
+  /* First sort the primary list, then sort each of the secondary lists
+     in the data structure built by
+     store_process_refs.   Finally, go through and collapse them. */
+
+  int compare_primary(), compare_secondary() ;
+  rsl_list_t * lp, *lp1, *lp2, *lp3 ;
+  packrec_t *x, *y ;
+  int dummy ;
+  int i, nbytes ;
+
+#if 0
+fprintf(stderr,"before sort\n") ;
+for ( i = 0, lp = list_head ; lp ; lp = lp->next )
+{
+lp2 = lp->data ;
+fprintf(stderr,"%d %08x\n", i,  ((packrec_t *)(lp2->data))->base) ;
+i++ ;
+}
+#endif
+
+  dummy = 0 ;
+  rsl_sort( &list_head, compare_primary, dummy ) ;
+
+  /* figure the number of entries */
+  for ( i = 0, lp = list_head ; lp ; lp = lp->next )
+    for ( lp1 = (rsl_list_t *)lp->data ; lp1 ; lp1 = lp1->next )
+      i++ ;
+
+  for ( lp = list_head ; lp ; lp = lp->next )
+  {
+    rsl_sort( &(lp->data), compare_secondary, 99 ) ;
+#if 1
+    if ( collapse ) collapsetable( &(lp->data) ) ;
+#endif
+  }
+
+#if 0
+  for ( i = 0, lp = list_head ; lp ; lp = lp->next )
+  {
+#if 0
+lp1 = (rsl_list_t *)lp->data ; x = (packrec_t *)lp1->data ;
+fprintf(stderr,"Entries for base %08x\n", x->base ) ;
+#endif
+    for ( lp1 = (rsl_list_t *)lp->data ; lp1 ; lp1 = lp1->next )
+    {
+#if 0
+x = (packrec_t *)lp1->data ;
+fprintf(stderr,"     offset %10d  %d  %4d\n", x->offset, x->f90_table_index,x->n ) ;
+#endif
+      i++ ;
+    }
+  }
+#endif
+
+
+  /* figure the number of remaining entries */
+  for ( i = 0, lp = list_head ; lp ; lp = lp->next )
+    for ( lp1 = (rsl_list_t *)lp->data ; lp1 ; lp1 = lp1->next )
+      i++ ;
+
+  *pack_table_size = i ;
+
+#if 0
+fprintf(stderr,"debug 2 pack_table_size = %d\n",*pack_table_size) ;
+#endif
+
+  /* now allocate and populate the table */
+  *pack_table = RSL_MALLOC( packrec_t, *pack_table_size ) ;
+  for ( i = 0, nbytes = 0, lp = list_head ; lp ; lp = lp->next )
+    for ( lp1 = (rsl_list_t *)lp->data ; lp1 ; lp1 = lp1->next )
+    {
+      x = (packrec_t *)lp1->data ;
+      nbytes += x->n * x->nelems ;
+      bcopy(lp1->data,&((*pack_table)[i]),sizeof(packrec_t)) ;
+      i++ ;
+    }
+
+  *pack_table_nbytes = nbytes ;
+  
+  return ;
+}
+ 
diff --git a/wrfv2_fire/external/RSL/RSL/pt.c b/wrfv2_fire/external/RSL/RSL/pt.c
new file mode 100755
index 00000000..1335d74a
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/pt.c
@@ -0,0 +1,878 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* apply the function f to each of the points of the stencil in order:
+
+                       1
+                    2 00  3
+                       4
+
+NOTE: as written, this routine assumes that the ns index is minor as
+in the NCAR MM.
+
+*/
+
+rsl_4pt( d, min, minlen, maj, majlen, f  )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+if ( maj >= 0 && maj < majlen )
+{
+  /* n1 */ if ( min+1 < minlen ) (*f)( d, min+1, maj, min, maj, 1, 4 ) ;
+  /* s1 */ if ( min-1 >= 0 )      (*f)( d, min-1, maj, min, maj, 4, 1 ) ;
+}
+if ( min >= 0 && min < minlen )
+{
+  /* w1 */ if ( maj-1 >= 0 )      (*f)( d, min, maj-1, min, maj, 2, 3 ) ;
+  /* e1 */ if ( maj+1 < majlen ) (*f)( d, min, maj+1, min, maj, 3, 2 ) ;
+}
+/* 00 */ if ( maj >= 0 && maj < majlen &&
+              min >= 0 && min < minlen ) (*f)( d, min, maj, min, maj, 0, 0 ) ;
+}
+
+/* Comment about periodic boundaries and staggered fields. JM 20031223 
+
+This is a bit of a stretch from the point of view of intuition, but if
+you have the following grid that is 5 dot points and 4 cross points
+across:
+
+        0     1     2     3     4     5
+        .  x  .  x  .  x  .  x  .  x  .
+           0     1     2     3     4 
+
+then the correct way to update a 1-deep periodic boundary is:
+
+(not 5!)                                  (not zero!)
+  4     0     1     2     3     4     5     1
+  .  x  .  x  .  x  .  x  .  x  .  x  .  x  .
+     4     0     1     2     3     4     0
+
+It may help to think about this as the 0 and 5 dot points being
+copies of each other. */
+
+/* periodic version ; Feb 99 */
+rsl_period_pt( dir, d, min, minlen, minstag, maj, majlen, majstag, fld, bdyw, f  )
+  int dir ;    /* direction: 0 is M, 1 is N */
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  int minstag ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int majstag ;
+  int bdyw ;
+  rsl_fldspec_t * fld ;
+  int (*f)() ;
+{
+  if ( bdyw >= 1 )
+  {
+    if      ( dir == 1 )   /* RSL_N */
+    {
+      if ( majstag )
+      {
+        /* Dot point at YS (index 0) replicated to last dot point in domain before XE boundary, (majlen-1) */
+        if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min-1, maj, min-1,    majlen-0, -1, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,    majlen-0,  0, 0, fld ) ;
+                                                                    (*f)( d, min+1, maj, min+1,    majlen-0,  1, 0, fld ) ; }
+        /* Dot point at YS+1 (index 1) replicated to first dot point in YE boundary, (majlen) */
+        if ( maj == 1        && min >=0 && min < minlen+minstag ) { (*f)( d, min-1, maj, min-1,    majlen+1, -1, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,    majlen+1,  0, 0, fld ) ;
+                                                                    (*f)( d, min+1, maj, min+1,    majlen+1,  1, 0, fld ) ; }
+        /* YE edge of domain goes to YS edge - 1 */
+        if ( maj == majlen-1 && min >=0 && min < minlen+minstag ) { (*f)( d, min-1, maj, min-1,    -1,     -1, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,    -1,      0, 0, fld ) ;
+                                                                    (*f)( d, min+1, maj, min+1,    -1,      1, 0, fld ) ; }
+
+      }
+      else
+      {
+        /* YS edge of domain goes to YE edge + 1 */
+        if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min-1, maj, min-1,    majlen, -1, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,    majlen,  0, 0, fld ) ;
+                                                                    (*f)( d, min+1, maj, min+1,    majlen,  1, 0, fld ) ; }
+
+        /* YE edge of domain goes to YS edge - 1 */
+        if ( maj == majlen-1 && min >=0 && min < minlen )         { (*f)( d, min-1, maj, min-1,    -1,     -1, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,    -1,      0, 0, fld ) ;
+                                                                    (*f)( d, min+1, maj, min+1,    -1,      1, 0, fld ) ; }
+      }
+    }
+    else if ( dir == 0 )   /* RSL_M */
+    {
+      if ( minstag )
+      {
+        /* Dot point at XS (index 0) replicated to last dot point in domain before XE boundary, (minlen-1) */
+        if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-1, minlen-0, maj-1,    0, -1, fld ) ;
+                                                                    (*f)( d, min, maj  , minlen-0, maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+1, minlen-0, maj+1,    0,  1, fld ) ; }
+        if ( min == 1        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-1, minlen+1, maj-1,    0, -1, fld ) ;
+                                                                    (*f)( d, min, maj  , minlen+1, maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+1, minlen+1, maj+1,    0,  1, fld ) ; }
+        /* XE edge of domain goes to XS edge - 1 */
+        if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-1, -1,       maj-1,    0, -1, fld ) ;
+                                                                    (*f)( d, min, maj  , -1,       maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+1, -1,       maj+1,    0,  1, fld ) ; }
+      }
+      else
+      {
+        /* XS edge of domain goes to XE edge + 1 */
+        if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-1, minlen, maj-1,    0, -1, fld ) ;
+                                                                    (*f)( d, min, maj  , minlen, maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+1, minlen, maj+1,    0,  1, fld ) ; }
+
+        /* XE edge of domain goes to XS edge - 1 */
+        if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-1, -1,     maj-1,    0, -1, fld ) ;
+                                                                    (*f)( d, min, maj  , -1,     maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+1, -1,     maj+1,    0,  1, fld ) ; }
+      }
+    }
+
+/* sw corner to ne corner */
+    if ( min == 0+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag, majlen+majstag,   0,  0, fld ) ; }
+/* nw corner to se corner */
+    if ( min == 0+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag, -1            ,   0,  0, fld ) ; }
+/* se corner to nw corner */
+    if ( min == minlen-1-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag,   0,  0, fld ) ; }
+/* ne corner to sw corner */
+    if ( min == minlen-1-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -1            , -1            ,   0,  0, fld ) ; }
+
+  }
+#if 1
+  if ( bdyw >= 2 )
+  {
+    if      ( dir == 1 ) /* RSL_N */
+    {
+      if ( majstag )
+      {
+/**/    if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  majlen-0, -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    majlen-0,  0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  majlen-0,  2, 0, fld ) ; }
+        if ( maj == 1        && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  majlen+1, -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    majlen+1,  0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  majlen+1,  2, 0, fld ) ; }
+        if ( maj == 2        && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  majlen+2, -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    majlen+2,  0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  majlen+2,  2, 0, fld ) ; }
+        if ( maj == majlen-2 && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  -2,       -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    -2,        0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  -2,        2, 0, fld ) ; }
+/**/    if ( maj == majlen-1 && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  -1,       -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    -1,        0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  -1,        2, 0, fld ) ; }
+      }
+      else
+      {
+/**/    if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  majlen,   -2, 0, fld ) ;
+                                                                    (*f)( d, min  , maj, min  ,  majlen,    0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  majlen,    2, 0, fld ) ; }
+        if ( maj == 1        && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  majlen+1, -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    majlen+1,  0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  majlen+1,  2, 0, fld ) ; }
+        if ( maj == majlen-2 && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  -2,       -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    -2,        0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  -2,        2, 0, fld ) ; }
+/**/    if ( maj == majlen-1 && min >=0 && min < minlen+minstag ) { (*f)( d, min-2, maj, min-2,  -1,       -2, 0, fld ) ;
+                                                                    (*f)( d, min,   maj, min,    -1,        0, 0, fld ) ;
+                                                                    (*f)( d, min+2, maj, min+2,  -1,        2, 0, fld ) ; }
+      }
+    }
+    else if ( dir == 0 ) /* RSL_M */
+    {
+      if ( minstag )
+      {
+/**/    if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, minlen-0, maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   minlen-0, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, minlen-0, maj+2,    0,  2, fld ) ; }
+/**/    if ( min == 1        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, minlen+1, maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   minlen+1, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, minlen+1, maj+2,    0,  2, fld ) ; }
+        if ( min == 2        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, minlen+2, maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   minlen+2, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, minlen+2, maj+2,    0,  2, fld ) ; }
+        if ( min == minlen-2 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, -2,       maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   -2,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, -2,       maj+2,    0,  2, fld ) ; }
+/**/    if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, -1,       maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   -1,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, -1,       maj+2,    0,  2, fld ) ; }
+      }
+      else
+      {
+/**/    if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, minlen,   maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj  , minlen,   maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, minlen,   maj+2,    0,  2, fld ) ; }
+        if ( min == 1        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, minlen+1, maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj  , minlen+1, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, minlen+1, maj+2,    0,  2, fld ) ; }
+        if ( min == minlen-2 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, -2,       maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj,   -2,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, -2,       maj+2,    0,  2, fld ) ; }
+/**/    if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj-2, -1,       maj-2,    0, -2, fld ) ;
+                                                                    (*f)( d, min, maj  , -1,       maj  ,    0,  0, fld ) ;
+                                                                    (*f)( d, min, maj+2, -1,       maj+2,    0,  2, fld ) ; }
+      }
+    }
+
+/* sw corner to ne corner */
+/*  if ( min == 0+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag  , majlen+majstag  ,   0,  0, fld ) ; } */
+    if ( min == 1+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag+1, majlen+majstag  ,   0,  0, fld ) ; }
+    if ( min == 0+minstag        && maj == 1+majstag        ) { (*f)( d, min, maj  , minlen+minstag  , majlen+majstag+1,   0,  0, fld ) ; }
+    if ( min == 1+minstag        && maj == 1+majstag        ) { (*f)( d, min, maj  , minlen+minstag+1, majlen+majstag+1,   0,  0, fld ) ; }
+/* nw corner to se corner */
+/*  if ( min == 0+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag  , -1            ,   0,  0, fld ) ; } */
+    if ( min == 0+minstag        && maj == majlen-2-majstag ) { (*f)( d, min, maj  , minlen+minstag  , -2            ,   0,  0, fld ) ; }
+    if ( min == 1+minstag        && maj == majlen-2-majstag ) { (*f)( d, min, maj  , minlen+minstag+1, -2            ,   0,  0, fld ) ; }
+    if ( min == 1+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag+1, -1            ,   0,  0, fld ) ; }
+/* se corner to nw corner */
+/*  if ( min == minlen-1-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag  ,   0,  0, fld ) ; } */
+    if ( min == minlen-2-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -2            , majlen+majstag  ,   0,  0, fld ) ; }
+    if ( min == minlen-2-minstag && maj == 1+majstag        ) { (*f)( d, min, maj  , -2            , majlen+majstag+1,   0,  0, fld ) ; }
+    if ( min == minlen-1-minstag && maj == 1+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag+1,   0,  0, fld ) ; }
+/* ne corner to sw corner */
+/*  if ( min == minlen-1-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -1            , -1            ,   0,  0, fld ) ; } */
+    if ( min == minlen-1-minstag && maj ==majlen-2-majstag  ) { (*f)( d, min, maj  , -1            , -2            ,   0,  0, fld ) ; }
+    if ( min == minlen-2-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -2            , -1            ,   0,  0, fld ) ; }
+    if ( min == minlen-2-minstag && maj ==majlen-2-majstag  ) { (*f)( d, min, maj  , -2            , -2            ,   0,  0, fld ) ; }
+
+  }
+
+#endif
+
+  if ( bdyw >= 3 )
+  {
+    if      ( dir == 1 ) /* RSL_N */
+    {
+      if ( majstag )
+      {
+        if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen-0, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen-0,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen-0,  3, 0, fld ) ; }
+        if ( maj == 1        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+1, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+1,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+1,  3, 0, fld ) ; }
+        if ( maj == 2        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+2, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+2,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+2,  3, 0, fld ) ; }
+        if ( maj == 3        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+3, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+3,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+3,  3, 0, fld ) ; }
+        if ( maj == majlen-3 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -3,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -3,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -3,        3, 0, fld ) ; }
+        if ( maj == majlen-2 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -2,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -2,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -2,        3, 0, fld ) ; }
+        if ( maj == majlen-1 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -1,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -1,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -1,        3, 0, fld ) ; }
+
+      }
+      else
+      {
+        if ( maj == 0        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+0, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+0,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+0,  3, 0, fld ) ; }
+        if ( maj == 1        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+1, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+1,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+1,  3, 0, fld ) ; }
+        if ( maj == 2        && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      majlen+2, -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+2,  0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      majlen+2,  3, 0, fld ) ; }
+        if ( maj == majlen-3 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -3,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -3,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -3,        3, 0, fld ) ; }
+        if ( maj == majlen-2 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -2,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -2,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -2,        3, 0, fld ) ; }
+        if ( maj == majlen-1 && min >=0 && min < minlen+minstag ) { (*f)( d, min, maj, min,      -1,       -3, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -1,        0, 0, fld ) ;
+                                                                    (*f)( d, min, maj, min,      -1,        3, 0, fld ) ; }
+      }
+    }
+    else if ( dir == 0 ) /* RSL_M */
+    {
+      if ( minstag )
+      {
+        if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen-0, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen-0, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen-0, maj,      0,  3, fld ) ; }
+        if ( min == 1        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+1, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+1, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+1, maj,      0,  3, fld ) ; }
+        if ( min == 2        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+2, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+2, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+2, maj,      0,  3, fld ) ; }
+        if ( min == 3        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+3, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+3, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+3, maj,      0,  3, fld ) ; }
+        if ( min == minlen-3 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -3,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -3,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -3,       maj,      0,  3, fld ) ; }
+        if ( min == minlen-2 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -2,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -2,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -2,       maj,      0,  3, fld ) ; }
+        if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -1,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -1,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -1,       maj,      0,  3, fld ) ; }
+      }
+      else
+      {
+        if ( min == 0        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+0, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+0, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+0, maj,      0,  3, fld ) ; }
+        if ( min == 1        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+1, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+1, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+1, maj,      0,  3, fld ) ; }
+        if ( min == 2        && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, minlen+2, maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+2, maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, minlen+2, maj,      0,  3, fld ) ; }
+        if ( min == minlen-3 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -3,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -3,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -3,       maj,      0,  3, fld ) ; }
+        if ( min == minlen-2 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -2,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -2,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -2,       maj,      0,  3, fld ) ; }
+        if ( min == minlen-1 && maj >=0 && maj < majlen+majstag ) { (*f)( d, min, maj, -1,       maj,      0, -3, fld ) ;
+                                                                    (*f)( d, min, maj, -1,       maj,      0,  0, fld ) ;
+                                                                    (*f)( d, min, maj, -1,       maj,      0,  3, fld ) ; }
+      }
+    }
+  }
+/* sw corner to ne corner */
+/*  if ( min == 0+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag  , majlen+majstag  ,   0,  0, fld ) ; } */
+/*  if ( min == 1+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag+1, majlen+majstag  ,   0,  0, fld ) ; } */
+/*  if ( min == 0+minstag        && maj == 1+majstag        ) { (*f)( d, min, maj  , minlen+minstag  , majlen+majstag+1,   0,  0, fld ) ; } */
+/*  if ( min == 1+minstag        && maj == 1+majstag        ) { (*f)( d, min, maj  , minlen+minstag+1, majlen+majstag+1,   0,  0, fld ) ; } */
+    if ( min == 2+minstag        && maj == 0+majstag        ) { (*f)( d, min, maj  , minlen+minstag+2, majlen+majstag  ,   0,  0, fld ) ; }
+    if ( min == 2+minstag        && maj == 1+majstag        ) { (*f)( d, min, maj  , minlen+minstag+2, majlen+majstag+1,   0,  0, fld ) ; }
+    if ( min == 2+minstag        && maj == 2+majstag        ) { (*f)( d, min, maj  , minlen+minstag+2, majlen+majstag+2,   0,  0, fld ) ; }
+    if ( min == 1+minstag        && maj == 2+majstag        ) { (*f)( d, min, maj  , minlen+minstag+1, majlen+majstag+2,   0,  0, fld ) ; }
+    if ( min == 0+minstag        && maj == 2+majstag        ) { (*f)( d, min, maj  , minlen+minstag  , majlen+majstag+2,   0,  0, fld ) ; }
+/* nw corner to se corner */
+/*  if ( min == 0+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag  , -1            ,   0,  0, fld ) ; } */
+/*  if ( min == 0+minstag        && maj == majlen-2-majstag ) { (*f)( d, min, maj  , minlen+minstag  , -2            ,   0,  0, fld ) ; } */
+/*  if ( min == 1+minstag        && maj == majlen-2-majstag ) { (*f)( d, min, maj  , minlen+minstag+1, -2            ,   0,  0, fld ) ; } */
+/*  if ( min == 1+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag+1, -1            ,   0,  0, fld ) ; } */
+    if ( min == 2+minstag        && maj == majlen-1-majstag ) { (*f)( d, min, maj  , minlen+minstag+2, -1            ,   0,  0, fld ) ; }
+    if ( min == 2+minstag        && maj == majlen-2-majstag ) { (*f)( d, min, maj  , minlen+minstag+2, -2            ,   0,  0, fld ) ; }
+    if ( min == 2+minstag        && maj == majlen-3-majstag ) { (*f)( d, min, maj  , minlen+minstag+2, -3            ,   0,  0, fld ) ; }
+    if ( min == 1+minstag        && maj == majlen-3-majstag ) { (*f)( d, min, maj  , minlen+minstag+1, -3            ,   0,  0, fld ) ; }
+    if ( min == 0+minstag        && maj == majlen-3-majstag ) { (*f)( d, min, maj  , minlen+minstag  , -3            ,   0,  0, fld ) ; }
+/* se corner to nw corner */
+/*  if ( min == minlen-1-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag  ,   0,  0, fld ) ; } */
+/*  if ( min == minlen-2-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -2            , majlen+majstag  ,   0,  0, fld ) ; } */
+/*  if ( min == minlen-2-minstag && maj == 1+majstag        ) { (*f)( d, min, maj  , -2            , majlen+majstag+1,   0,  0, fld ) ; } */
+/*  if ( min == minlen-1-minstag && maj == 1+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag+1,   0,  0, fld ) ; } */
+    if ( min == minlen-3-minstag && maj == 0+majstag        ) { (*f)( d, min, maj  , -3            , majlen+majstag+0,   0,  0, fld ) ; }
+    if ( min == minlen-3-minstag && maj == 1+majstag        ) { (*f)( d, min, maj  , -3            , majlen+majstag+1,   0,  0, fld ) ; }
+    if ( min == minlen-3-minstag && maj == 2+majstag        ) { (*f)( d, min, maj  , -3            , majlen+majstag+2,   0,  0, fld ) ; }
+    if ( min == minlen-2-minstag && maj == 2+majstag        ) { (*f)( d, min, maj  , -2            , majlen+majstag+2,   0,  0, fld ) ; }
+    if ( min == minlen-1-minstag && maj == 2+majstag        ) { (*f)( d, min, maj  , -1            , majlen+majstag+2,   0,  0, fld ) ; }
+/* ne corner to sw corner */
+/*  if ( min == minlen-1-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -1            , -1            ,   0,  0, fld ) ; } */
+/*  if ( min == minlen-1-minstag && maj ==majlen-2-majstag  ) { (*f)( d, min, maj  , -1            , -2            ,   0,  0, fld ) ; } */
+/*  if ( min == minlen-2-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -2            , -1            ,   0,  0, fld ) ; } */
+/*  if ( min == minlen-2-minstag && maj ==majlen-2-majstag  ) { (*f)( d, min, maj  , -2            , -2            ,   0,  0, fld ) ; } */
+    if ( min == minlen-3-minstag && maj ==majlen-1-majstag  ) { (*f)( d, min, maj  , -3            , -1            ,   0,  0, fld ) ; }
+    if ( min == minlen-3-minstag && maj ==majlen-2-majstag  ) { (*f)( d, min, maj  , -3            , -2            ,   0,  0, fld ) ; }
+    if ( min == minlen-3-minstag && maj ==majlen-3-majstag  ) { (*f)( d, min, maj  , -3            , -3            ,   0,  0, fld ) ; }
+    if ( min == minlen-2-minstag && maj ==majlen-3-majstag  ) { (*f)( d, min, maj  , -2            , -3            ,   0,  0, fld ) ; }
+    if ( min == minlen-1-minstag && maj ==majlen-3-majstag  ) { (*f)( d, min, maj  , -1            , -3            ,   0,  0, fld ) ; }
+
+}
+
+
+/* apply the function f to each of the points of the stencil in order:
+
+                    1  2  3
+                    4 00  5   
+                    6  7  8
+
+NOTE: as written, this routine assumes that the ns index is minor as
+in the NCAR MM.
+
+*/
+
+rsl_8pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+if ( maj >= 0 && maj < majlen )
+{
+  /* n1 */ if ( min+1 < minlen ) (*f)( d, min+1, maj, min, maj, 2, 7 ) ;
+  /* s1 */ if ( min-1 >= 0 )      (*f)( d, min-1, maj, min, maj, 7, 2 ) ;
+}
+if ( min >= 0 && min < minlen )
+{
+  /* w1 */ if ( maj-1 >= 0 )      (*f)( d, min, maj-1, min, maj, 4, 5 ) ;
+  /* e1 */ if ( maj+1 < majlen ) (*f)( d, min, maj+1, min, maj, 5, 4 ) ;
+}
+/* nw */ if ( maj-1 >= 0 &&
+              min+1 < minlen ) (*f)( d, min+1, maj-1, min, maj, 1, 8  ) ;
+/* ne */ if ( maj+1 < majlen &&
+              min+1 < minlen ) (*f)( d, min+1, maj+1, min, maj, 3, 6 ) ;
+/* sw */ if ( maj-1 >= 0 &&
+              min-1 >= 0 )      (*f)( d, min-1, maj-1, min, maj, 6, 3 ) ;
+/* se */ if ( maj+1 < majlen &&
+              min-1 >= 0 )      (*f)( d, min-1, maj+1, min, maj, 8, 1 ) ;
+/* 00 */ if ( maj >= 0 && maj < majlen &&
+              min >= 0 && min < minlen ) (*f)( d, min, maj, min, maj, 0, 0 ) ;
+}
+
+/* apply the function f to each of the points of the stencil in order:
+
+                       1
+                    2  3  4
+                 5  6 00  7  8
+                    9 10 11
+                      12
+
+NOTE: as written, this routine assumes that the ns index is minor as
+in the NCAR MM.
+
+*/
+
+rsl_12pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+if ( maj >= 0 && maj < majlen )
+{
+  /* n2 */ if ( min+2 < minlen ) (*f)( d, min+2, maj, min, maj, 1, 12 ) ;
+  /* n1 */ if ( min+1 < minlen ) (*f)( d, min+1, maj, min, maj, 3, 10 ) ;
+  /* s1 */ if ( min-1 >= 0 )      (*f)( d, min-1, maj, min, maj, 10, 3 ) ;
+  /* s2 */ if ( min-2 >= 0 )      (*f)( d, min-2, maj, min, maj, 12, 1 ) ;
+}
+if ( min >= 0 && min < minlen )
+{
+  /* w2 */ if ( maj-2 >= 0 )      (*f)( d, min, maj-2, min, maj, 5, 8 ) ;
+  /* w1 */ if ( maj-1 >= 0 )      (*f)( d, min, maj-1, min, maj, 6, 7 ) ;
+  /* e1 */ if ( maj+1 < majlen ) (*f)( d, min, maj+1, min, maj, 7, 6 ) ;
+  /* e2 */ if ( maj+2 < majlen ) (*f)( d, min, maj+2, min, maj, 8, 5 ) ;
+}
+/* nw */ if ( maj-1 >= 0 &&
+              min+1 < minlen ) (*f)( d, min+1, maj-1, min, maj, 2, 11 ) ;
+/* ne */ if ( maj+1 < majlen && 
+              min+1 < minlen ) (*f)( d, min+1, maj+1, min, maj,  4, 9 ) ;
+/* sw */ if ( maj-1 >= 0 && 
+              min-1 >= 0 )      (*f)( d, min-1, maj-1, min, maj, 9, 4 ) ;
+/* se */ if ( maj+1 < majlen && 
+              min-1 >= 0 )      (*f)( d, min-1, maj+1, min, maj, 11, 2 ) ;
+/* 00 */ if ( maj >= 0 && maj < majlen && 
+              min >= 0 && min < minlen ) (*f)( d, min, maj, min, maj, 0, 0 ) ;
+}
+
+/* apply the function f to each of the points of the stencil in order:
+
+                 1  2  3  4  5
+                 6  7  8  9 10
+                11 12 00 13 14
+                15 16 17 18 19
+                20 21 22 23 24
+
+NOTE: as written, this routine assumes that the ns index is minor as
+in the NCAR MM.
+
+*/
+static char pts[] = { 20, 21, 22, 23, 24,
+                      15, 16, 17, 18, 19,
+                      11, 12,  0, 13, 14,
+                       6,  7,  8,  9, 10,
+                       1,  2,  3,  4,  5, } ;
+
+static char ipts[] = { 5,  4,  3,  2,  1,
+                      10,  9,  8,  7,  6,
+                      14, 13,  0, 12, 11,
+                      19, 18, 17, 16, 15,
+                      24, 23, 22, 21, 20, } ;
+
+rsl_24pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+  rsl_index_t i, j, k ;
+
+  k = 0 ;
+  for ( i = -2 ; i <= 2 ; i++ )
+  {
+    for ( j = -2 ; j <= 2 ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+        (*f)(d,min+i,maj+j,min,maj,pts[k],ipts[k]) ;
+      }
+      k++ ;
+    }
+  }
+}
+
+#if ( ALLOW_RSL_168PT == 1 )
+/* apply the function f to each of the points of the stencil in order:
+
+  1   2   3   4   5   6   7   8   9  10  11  12  13
+ 14  15  16  17  18  19  20  21  22  23  23  25  26
+ 27  28  29  30  31  32  33  34  35  36  37  38  39
+ 40  41  42  43  44  45  46  47  48  49  50  51  52
+ 53  54  55  56  57  58  59  60  61  62  63  64  65
+ 66  67  68  69  70  71  72  73  74  75  76  77  78
+ 79  80  81  82  83  84  00  85  86  87  88  89  90
+ 91  92  93  94  95  96  97  98  99 100 101 102 103
+104 105 106 107 108 109 110 111 112 113 114 115 116
+117 118 119 120 121 122 123 124 125 126 127 128 129
+130 131 132 133 134 135 136 137 138 139 140 141 142
+143 144 145 146 147 148 149 150 151 152 153 154 155
+156 157 158 159 160 161 162 163 164 165 166 167 168
+
+NOTE: as written, this routine assumes that the ns index is minor as
+in the NCAR MM.
+
+Here is a shell script for converting the above table into 
+the form that is assigned to ipts168 below (it reverses
+the columns).   Commas get added separately.
+
+#
+/bin/cp xxx yyy
+echo phase 1
+set i=0
+while ($i < 13)
+  echo $i
+  cut -c1-4 yyy > /tmp/$i.temp
+  cut -c5-  yyy > foo
+  /bin/mv foo yyy
+  @ i += 1
+end
+echo phase 1
+/bin/cp /tmp/0.temp yyy
+set i=1
+while ($i < 13)
+  echo $i
+  paste /tmp/$i.temp yyy | sed 's/    //' > foo
+  /bin/mv foo yyy
+  @ i += 1
+end
+
+*/
+
+
+static rsl_index_t pts48[] = {
+    42, 43, 44, 45, 46, 47, 48,
+    35, 36, 37, 38, 39, 40, 41,
+    28, 29, 30, 31, 32, 33, 34,
+    22, 23, 24, 00, 25, 26, 27,
+    15, 16, 17, 18, 19, 20, 21,
+     8,  9, 10, 11, 12, 13, 14,
+     1,  2,  3,  4,  5,  6,  7
+    } ;
+
+static rsl_index_t ipts48[] = {
+     7,  6,  5,  4,  3,  2,  1,
+    14, 13, 12, 11, 10,  9,  8,
+    21, 20, 19, 18, 17, 16, 15,
+    27, 26, 25, 00, 24, 23, 22,
+    34, 33, 32, 31, 30, 29, 28,
+    41, 40, 39, 38, 37, 36, 35,
+    48, 47, 46, 45, 44, 43, 42
+    } ;
+
+
+rsl_48pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+  rsl_index_t i, j, k ;
+
+  k = 0 ;
+  for ( i = -3 ; i <= 3 ; i++ )
+  {
+    for ( j = -3 ; j <= 3 ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+        (*f)(d,min+i,maj+j,min,maj,pts48[k],ipts48[k]) ;
+      }
+      k++ ;
+    }
+  }
+}
+
+static rsl_index_t pts80[] = {
+    72, 73, 74, 75, 76, 77, 78, 79, 80,
+    63, 64, 65, 66, 67, 68, 69, 70, 71,
+    54, 55, 56, 57, 58, 59, 60, 61, 62,
+    45, 46, 47, 48, 49, 50, 51, 52, 53,
+    37, 38, 39, 40, 00, 41, 42, 43, 44,
+    28, 29, 30, 31, 32, 33, 34, 35, 36,
+    19, 20, 21, 22, 23, 24, 25, 26, 27,
+    10, 11, 12, 13, 14, 15, 16, 17, 18,
+     1,  2,  3,  4,  5,  6,  7,  8,  9,
+    } ;
+
+static rsl_index_t ipts80[] = {
+     9,  8,  7,  6,  5,  4,  3,  2,  1,
+    18, 17, 16, 15, 14, 13, 12, 11, 10,
+    27, 26, 25, 24, 23, 22, 21, 20, 19,
+    36, 35, 34, 33, 32, 31, 30, 29, 28,
+    44, 43, 42, 41, 00, 40, 39, 38, 37,
+    53, 52, 51, 50, 49, 48, 47, 46, 45,
+    62, 61, 60, 59, 58, 57, 56, 55, 54,
+    71, 70, 69, 68, 67, 66, 65, 64, 63,
+    80, 79, 78, 77, 76, 75, 74, 73, 72
+    } ;
+
+
+rsl_80pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+  rsl_index_t i, j, k ;
+
+  k = 0 ;
+  for ( i = -4 ; i <= 4 ; i++ )
+  {
+    for ( j = -4 ; j <= 4 ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+        (*f)(d,min+i,maj+j,min,maj,pts80[k],ipts80[k]) ;
+      }
+      k++ ;
+    }
+  }
+}
+
+static rsl_index_t pts120[] = {
+   110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120,
+    99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109,
+    88,  89,  90,  91,  92,  93,  94,  95,  96,  97,  98,
+    77,  78,  79,  80,  81,  82,  83,  84,  85,  86,  87,
+    66,  67,  68,  69,  70,  71,  72,  73,  74,  75,  76,
+    56,  57,  58,  59,  60,  00,  61,  62,  63,  64,  65,
+    45,  46,  47,  48,  49,  50,  51,  52,  53,  54,  55,
+    34,  35,  36,  37,  38,  39,  40,  41,  42,  43,  44,
+    23,  24,  25,  26,  27,  28,  29,  30,  31,  32,  33,
+    12,  13,  14,  15,  16,  17,  18,  19,  20,  21,  22,
+     1,   2,   3,   4,   5,   6,   7,   8,   9,  10,  11,
+    } ;
+
+static rsl_index_t ipts120[] = {
+    11,  10,   9,   8,   7,   6,   5,   4,   3,   2,   1,
+    22,  21,  20,  19,  18,  17,  16,  15,  14,  13,  12,
+    33,  32,  31,  30,  29,  28,  27,  26,  25,  24,  23,
+    44,  43,  42,  41,  40,  39,  38,  37,  36,  35,  34,
+    55,  54,  53,  52,  51,  50,  49,  48,  47,  46,  45,
+    65,  64,  63,  62,  61,  00,  60,  59,  58,  57,  56,
+    76,  75,  74,  73,  72,  71,  70,  69,  68,  67,  66,
+    87,  86,  85,  84,  83,  82,  81,  80,  79,  78,  77,
+    98,  97,  96,  95,  94,  93,  92,  91,  90,  89,  88,
+   109, 108, 107, 106, 105, 104, 103, 102, 101, 100,  99,
+   120, 119, 118, 117, 116, 115, 114, 113, 112, 111, 110
+    } ;
+
+
+rsl_120pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+  rsl_index_t i, j, k ;
+
+  k = 0 ;
+  for ( i = -5 ; i <= 5 ; i++ )
+  {
+    for ( j = -5 ; j <= 5 ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+        (*f)(d,min+i,maj+j,min,maj,pts120[k],ipts120[k]) ;
+      }
+      k++ ;
+    }
+  }
+}
+
+static rsl_index_t pts168[] = {
+   156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168,
+   143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155,
+   130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142,
+   117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129,
+   104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116,
+    91,  92,  93,  94,  95,  96,  97,  98,  99, 100, 101, 102, 103,
+    79,  80,  81,  82,  83,  84,  00,  85,  86,  87,  88,  89,  90,
+    66,  67,  68,  69,  70,  71,  72,  73,  74,  75,  76,  77,  78,
+    53,  54,  55,  56,  57,  58,  59,  60,  61,  62,  63,  64,  65,
+    40,  41,  42,  43,  44,  45,  46,  47,  48,  49,  50,  51,  52,
+    27,  28,  29,  30,  31,  32,  33,  34,  35,  36,  37,  38,  39,
+    14,  15,  16,  17,  18,  19,  20,  21,  22,  23,  23,  25,  26,
+     1,   2,   3,   4,   5,   6,   7,   8,   9,  10,  11,  12,  13
+    } ;
+
+static rsl_index_t ipts168[] = {
+    13,  12,  11,  10,   9,   8,   7,   6,   5,   4,   3,   2,   1, 
+    26,  25,  23,  23,  22,  21,  20,  19,  18,  17,  16,  15,  14, 
+    39,  38,  37,  36,  35,  34,  33,  32,  31,  30,  29,  28,  27, 
+    52,  51,  50,  49,  48,  47,  46,  45,  44,  43,  42,  41,  40, 
+    65,  64,  63,  62,  61,  60,  59,  58,  57,  56,  55,  54,  53, 
+    78,  77,  76,  75,  74,  73,  72,  71,  70,  69,  68,  67,  66, 
+    90,  89,  88,  87,  86,  85,  00,  84,  83,  82,  81,  80,  79, 
+   103, 102, 101, 100,  99,  98,  97,  96,  95,  94,  93,  92,  91, 
+   116, 115, 114, 113, 112, 111, 110, 109, 108, 107, 106, 105, 104, 
+   129, 128, 127, 126, 125, 124, 123, 122, 121, 120, 119, 118, 117, 
+   142, 141, 140, 139, 138, 137, 136, 135, 134, 133, 132, 131, 130, 
+   155, 154, 153, 152, 151, 150, 149, 148, 147, 146, 145, 144, 143, 
+   168, 167, 166, 165, 164, 163, 162, 161, 160, 159, 158, 157, 156
+    } ;
+
+
+rsl_168pt( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+  rsl_index_t i, j, k ;
+
+  k = 0 ;
+  for ( i = -6 ; i <= 6 ; i++ )
+  {
+    for ( j = -6 ; j <= 6 ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+        (*f)(d,min+i,maj+j,min,maj,pts168[k],ipts168[k]) ;
+      }
+      k++ ;
+    }
+  }
+}
+
+/* March 1997 */
+
+rsl_2ptm( d, min, minlen, maj, majlen, f  )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+if ( maj >= 0 && maj < majlen )
+{
+  /* n1 */ if ( min+1 < minlen ) (*f)( d, min+1, maj, min, maj, 1, 4 ) ;
+  /* s1 */ if ( min-1 >= 0 )      (*f)( d, min-1, maj, min, maj, 4, 1 ) ;
+}
+/* 00 */ if ( maj >= 0 && maj < majlen &&
+              min >= 0 && min < minlen ) (*f)( d, min, maj, min, maj, 0, 0 ) ;
+}
+
+rsl_4ptm( d, min, minlen, maj, majlen, f )
+  rsl_index_t d ;
+  rsl_index_t min ;
+  rsl_dimlen_t minlen ;
+  rsl_index_t maj ;
+  rsl_dimlen_t majlen ;
+  int (*f)() ;
+{
+if ( maj >= 0 && maj < majlen )
+{
+  /* n2 */ if ( min+2 < minlen ) (*f)( d, min+2, maj, min, maj, 1, 12 ) ;
+  /* n1 */ if ( min+1 < minlen ) (*f)( d, min+1, maj, min, maj, 3, 10 ) ;
+  /* s1 */ if ( min-1 >= 0 )      (*f)( d, min-1, maj, min, maj, 10, 3 ) ;
+  /* s2 */ if ( min-2 >= 0 )      (*f)( d, min-2, maj, min, maj, 12, 1 ) ;
+}
+/* 00 */ if ( maj >= 0 && maj < majlen && 
+              min >= 0 && min < minlen ) (*f)( d, min, maj, min, maj, 0, 0 ) ;
+}
+
+
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/rsl.c b/wrfv2_fire/external/RSL/RSL/rsl.c
new file mode 100755
index 00000000..52f6bd45
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl.c
@@ -0,0 +1,71 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+destroy_runrec( p )
+  rsl_runrec_t *p ;
+{
+  if ( p != NULL ) RSL_FREE( p ) ;
+}
+
+rsl_fatal( n )
+  int n ;
+{
+  exit(n) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl.h b/wrfv2_fire/external/RSL/RSL/rsl.h
new file mode 100755
index 00000000..ec57dacf
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl.h
@@ -0,0 +1,876 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+#ifndef RSL_H
+#define RSL_H
+
+/**************************************************************/
+/* Any changes to this file should be followed by make clean  */
+/* before remaking the RSL library                            */
+/**************************************************************/
+
+/**************************************************************/
+/* not likely that you will need to change things below here */
+
+/* this definition used in cd.c */
+#define HARD_CODED_BOUNDARY_WIDTH_FIX_ME_PLEASE 5
+
+#define RSL_MAXDOMAINS  MAXDOM_MAKE	/* FORTRAN */
+
+#define RSL_MAXPROC     MAXPROC_MAKE	/* FORTRAN */
+
+/* increased from 5 to 7 10/4/96 to accomodate 168 pt stencil */
+/* decreased to 3 (2 + 1 for garbage row) to save memory -- only estore
+   in sound needs 168 pt stencil and we'll handle that as a special case */
+#define RSL_DEFAULT_PADAREA 4           /* FORTRAN */
+
+#define RSL_MLOW        1		/* FORTRAN */
+#define RSL_MHIGH       2               /* FORTRAN */
+#define RSL_NLOW        3               /* FORTRAN */
+#define RSL_NHIGH       4               /* FORTRAN */
+#define RSL_DBDY	5		/* FORTRAN */
+#define RSL_CLOSEST     6		/* FORTRAN */
+
+#define DOT_BDY_INFO_LEN 10		/* FORTRAN */
+
+#define RSL_MLOW_X      7		/* FORTRAN */
+#define RSL_MHIGH_X     8               /* FORTRAN */
+#define RSL_NLOW_X      9               /* FORTRAN */
+#define RSL_NHIGH_X    10               /* FORTRAN */
+#define RSL_DBDY_X     11		/* FORTRAN */
+#define RSL_CLOSEST_X  12		/* FORTRAN */
+
+#define CROSS_BDY_INFO_LEN 12 		/* FORTRAN */
+
+#define RSL_00	        7		/* FORTRAN */
+#define RSL_M0	        8		/* FORTRAN */
+#define RSL_0N	        9		/* FORTRAN */
+#define RSL_MN	       10		/* FORTRAN */
+
+#define MLOW (RSL_MLOW-1)
+#define MHIGH (RSL_MHIGH-1)
+#define NLOW (RSL_NLOW-1)
+#define NHIGH (RSL_NHIGH-1)
+
+#define MAX_RUNPAD  6
+#define MAX_KINDPAD 8
+/* break ties in boundary classification */
+#define M_WINS      0                   /* FORTRAN */
+#define N_WINS      1                   /* FORTRAN */
+#define DIAG_WINS  2                   /* FORTRAN */
+
+#ifdef SHOW_RSL_CONFIGURATION
+/* SHOW_RSL_CONFIGURATION is only every defined externally.  This
+   next bit is never actually used.  Rather it is used by the top
+   level makefile to show the configuration of the model when the
+   user types make showconfig.  */
+show config:  ---if the library were completely remade---
+show config:"RSL_IMAX" would be set to:            RSL_IMAX
+show config:"RSL_JMAX" would be set to:            RSL_JMAX
+show config:"RSL_MAXDOMAINS" would be set to:      RSL_MAXDOMAINS
+show config:"RSL_MAXPROC" would be set to:         RSL_MAXPROC
+show config:  ---See also the makefile---
+#endif
+
+
+/* this should become runtime setaable from the fortran someday */
+
+#define RSL_TRUE  1			/* FORTRAN */
+#define RSL_FALSE 0			/* FORTRAN */
+#define RSL_INVALID -1			/* FORTRAN */
+#define RSL_VALID 1			/* FORTRAN */
+
+#define RSL_IRAX 3			/* FORTRAN */
+#define RSL_MAXCHILDREN (RSL_IRAX*RSL_IRAX)
+#define RSL_MAXKIDS RSL_MAXCHILDREN
+#define RSL_MAXDESCRIPTORS  2048
+/* settings below will allow for 20000 fields */
+#define MAX_BASE_TABLE_ENTRIES 20000
+
+#if (ALLOW_RSL_168PT == 1)
+#  define RSL_MAXSTEN    168              /* MAX NUMBER OF STENCIL PTS */
+#else
+#  define RSL_MAXSTEN	 24		/* MAX NUMBER OF STENCIL PTS */
+#endif
+
+
+#define RSL_REAL		0	/* FORTRAN */
+#define RSL_DOUBLE		1	/* FORTRAN */
+#define RSL_COMPLEX		2	/* FORTRAN */
+#define RSL_INTEGER		3	/* FORTRAN */
+#define RSL_CHARACTER		4	/* FORTRAN */
+
+#define RSL_REAL_F90		100	/* FORTRAN */
+#define RSL_DOUBLE_F90		101	/* FORTRAN */
+#define RSL_COMPLEX_F90		102	/* FORTRAN */
+#define RSL_INTEGER_F90		103	/* FORTRAN */
+#define RSL_CHARACTER_F90	104	/* FORTRAN */
+
+/* traversal orders */
+/* A = Ascending, D = Descending, applied to dim in order left to right */
+#define MINMAJ_AA                0       /* FORTRAN */
+#define MINMAJ_AD                1       /* FORTRAN */
+#define MINMAJ_DA                2       /* FORTRAN */
+#define MINMAJ_DD                3       /* FORTRAN */
+#define MAJMIN_AA             1000       /* FORTRAN */
+#define MAJMIN_AD             1001       /* FORTRAN */
+#define MAJMIN_DA             1002       /* FORTRAN */
+#define MAJMIN_DD             1003       /* FORTRAN */
+#define MINMAJ           MINMAJ_AA       /* FORTRAN */
+#define MAJMIN           MAJMIN_AA       /* FORTRAN */
+
+#define MNMJ(X)     ( ( (X) / 1000 ) == 0 )
+#define D1(X)       ( 2 & (X) )
+#define D2(X)       ( 1 & (X) )
+#define A1(X)       ( ! A1 )
+#define A2(X)       ( ! A2 )
+
+/* nested domain shapes */
+#define RSL_REGULAR_NEST  55		/* FORTRAN */
+#define RSL_RAGGED_NEST  56		/* FORTRAN */
+
+/* packing strategies */
+#define MINNS_MAJEW_2D   0
+#define MINEW_MAJNS_2D   1
+#define MINNS_MAJEW_K_3D 2
+#define MINEW_MAJNS_K_3D 3
+#define K_MIDNS_MAJEW_3D 4
+#define MINNS_K_MAJEW_3D 5
+
+/* io strategies */
+
+#define IO_REPL  99		/* FORTRAN */
+
+#define IO2D_IJ  0		/* FORTRAN */
+#define IO2D_JI  1		/* FORTRAN */
+#define IO3D_IJK 2		/* FORTRAN */
+#define IO3D_JIK 3		/* FORTRAN */
+#define IO2D     4		/* FORTRAN */
+#define IO3D     5		/* FORTRAN */
+#define IO3D_KIJ 6              /* FORTRAN */
+#define IO3D_IKJ 7              /* FORTRAN */
+
+#define IO2D_IJ_RAW  10		/* FORTRAN */
+#define IO2D_JI_RAW  11		/* FORTRAN */
+#define IO3D_IJK_RAW 12		/* FORTRAN */
+#define IO3D_JIK_RAW 13		/* FORTRAN */
+
+#define IO2D_IJ_PORTAL  20	/* FORTRAN */
+#define IO2D_JI_PORTAL  21	/* FORTRAN */
+#define IO3D_IJK_PORTAL 22	/* FORTRAN */
+#define IO3D_JIK_PORTAL 23	/* FORTRAN */
+
+#define IO2D_IJ_INTERNAL  24	/* FORTRAN */
+#define IO2D_JI_INTERNAL  25	/* FORTRAN */
+#define IO3D_IJK_INTERNAL 26	/* FORTRAN */
+#define IO3D_JIK_INTERNAL 27	/* FORTRAN */
+#define IO3D_KIJ_INTERNAL 28	/* FORTRAN */
+#define IO3D_IKJ_INTERNAL 29	/* FORTRAN */
+
+#define IO2D_IJ_88  30	/* FORTRAN */
+#define IO2D_JI_88  31	/* FORTRAN */
+#define IO3D_IJK_88 32	/* FORTRAN */
+#define IO3D_JIK_88 33	/* FORTRAN */
+
+#define RSL_MAXDIM 3
+
+/* type declarations */
+
+typedef int * int_p ;
+#if !(defined(SUNDEBUG) || defined(crayx1))
+#ifndef NEC_TUNE
+typedef short   rsl_processor_t ;
+typedef short   rsl_index_t ;
+typedef short   rsl_dimlen_t ;
+#else
+typedef int   rsl_processor_t ;
+typedef int   rsl_index_t ;
+typedef int   rsl_dimlen_t ;
+#endif
+#else
+typedef int   rsl_processor_t ;
+typedef int   rsl_index_t ;
+typedef int   rsl_dimlen_t ;
+#endif
+typedef long    rsl_point_id_t ;
+
+#ifdef crayx1
+typedef int rsl_tag_t ;
+#else
+#ifndef NEC_TUNE
+typedef unsigned char rsl_tag_t ;
+#else
+typedef int rsl_tag_t ;
+#endif
+#endif
+
+typedef struct rsl_list {
+  struct rsl_list * next ;
+  void * data ;	                /* pointer to some node */
+#ifdef crayx1
+  int info1 ;                   /* blank info field */
+  int info2 ;                   /* blank info field */
+#else
+  short info1 ;                 /* blank info field */
+  short info2 ;                 /* blank info field */
+#endif
+} rsl_list_t ;
+
+
+typedef struct rsl_runrec {	/* added 1/9/95 for rsl_compute_islab */
+  int i, j, ig, jg, runlength ;
+} rsl_runrec_t ;
+
+typedef struct bcast_point_desc {
+  rsl_point_id_t nest_id ;	/* pt in nest */
+  rsl_point_id_t parent_id ;	/* cd pt */
+  unsigned char cn, cm ;	/* indices of point, with respect to cd pt */
+} bcast_point_desc_t ;
+
+typedef bcast_point_desc_t merge_point_desc_t ;
+
+typedef struct rsl_fldspec {
+  struct rsl_fldspec    * next ;
+  void                  * base ;
+  rsl_tag_t             ndim ;
+  rsl_tag_t             elemsz ;
+  rsl_tag_t             memsize ;
+  rsl_tag_t             type ;
+  int                   f90_table_index ;
+  rsl_tag_t             strategy ;
+  rsl_tag_t             decomp[ RSL_MAXDIM ] ;
+  rsl_index_t           gdex[ RSL_MAXDIM ] ;
+  rsl_dimlen_t          glen[ RSL_MAXDIM ] ;
+  rsl_dimlen_t          llen[ RSL_MAXDIM ] ;
+  rsl_dimlen_t          stag[ RSL_MAXDIM ] ;  /* 0 = not staggered; 1 = staggered */
+} rsl_fldspec_t ;
+
+typedef struct message_desc {
+  rsl_tag_t tag;
+    /* should be MESSAGE_DESC or BLANK_MESSAGE_DESC */
+  int mh ;              /* handle */
+  int nflds ;           /* number of field specs in message */
+  int nbytes ;          /* for blank messages */
+  rsl_fldspec_t *fldspecs ;
+} message_desc_t ;
+
+typedef struct rsl_plist_elem {
+  struct rsl_plist_elem *next ;
+  rsl_point_id_t id ;
+  rsl_processor_t P ;
+} rsl_plist_elem_t ;
+
+typedef struct rsl_child_info {
+  rsl_point_id_t  child[RSL_MAXCHILDREN] ;
+  rsl_processor_t P[RSL_MAXCHILDREN] ;
+} rsl_child_info_t ;
+
+typedef struct rsl_point {
+  rsl_processor_t   P ;		/* physical processor number */
+  int               valid ;	/* a valid point? */
+  rsl_tag_t         trimmed ;	/* was this point trimmed */
+  rsl_tag_t         cross ;     /* member of the cross grid */
+  rsl_tag_t	    info_1 ;	/* misc tag info */
+  rsl_tag_t	    info_2 ;	/* misc tag info */
+  rsl_point_id_t    id ;
+  rsl_point_id_t    mother_id ;
+  rsl_processor_t   mother_P ;
+  rsl_tag_t         which_kid_am_i_m ;
+  rsl_tag_t         which_kid_am_i_n ;
+
+/* on whole grid */
+
+ 			/* counter-clockwise and clockwise below refer
+			   to the direction of the traversal in fill_boundary
+			   that determined the boundary association... 
+			   we store both to allow for several resolution
+			   strategies on corners.  */
+
+/* dot grid */
+  rsl_index_t       bdy_cclockwise ;	/* direction to boundary (counter) */
+  rsl_index_t       bdy_clockwise ;	/* direction to boundary (clockwise) */
+  rsl_index_t       dbdy ;		/* distance to boundary */
+
+			/* these next four fields are computed differently,
+			   in that they do not take into account corners.
+			   They simply measure the distance from the point
+			   to the boundary in question. */
+  rsl_index_t       dist_mlow ;		/* distance to southern bdy */
+  rsl_index_t       dist_mhigh ;	/*     "    to northern bdy */
+  rsl_index_t       dist_nlow ;         /*     "    to western bdy  */
+  rsl_index_t       dist_nhigh ;        /*     "    to eastern bdy  */
+
+/* on cross grid */
+/* cross grid */
+  rsl_index_t       bdy_x_cclockwise ;	/* direction to boundary (counter) */
+  rsl_index_t       bdy_x_clockwise ;	/* direction to boundary (clockwise) */
+  rsl_index_t       dbdy_x ;		/* distance to boundary */
+
+  rsl_index_t       dist_mlow_x ;	/* distance to southern bdy */
+  rsl_index_t       dist_mhigh_x ;	/*     "    to northern bdy */
+  rsl_index_t       dist_nlow_x ;       /*     "    to western bdy  */
+  rsl_index_t       dist_nhigh_x ;      /*     "    to eastern bdy  */
+
+  rsl_child_info_t *children_p ;
+} rsl_point_t ;
+
+typedef struct rsl_hemi_rec {
+  int oig , ojg ;
+  int nbytes ;
+  int curs ;
+  char * data ;
+  struct rsl_hemi_rec * next ;
+} rsl_hemi_rec_t ;
+
+typedef struct rsl_domain_info {
+  int valid ;
+  int decomposed ;
+
+  /* parent domain descriptor */
+  int parent ;
+  int nestshape ;	/* RSL_REGULAR_NEST, RSL_RAGGED_NEST */
+
+  /* information about parent, children */
+  int parent_bcast_compiled ;
+  int parent_merge_compiled ;
+  int child_bcast_compiled[RSL_MAXDOMAINS] ;
+  int child_merge_compiled[RSL_MAXDOMAINS] ;
+
+  /* pointer to MN domain data structure (array of points) */
+  rsl_point_t     *domain ;
+
+  /* pointer to MZ domain data structure (array of points) (20010222) */
+  rsl_point_t     *domain_mz ;
+
+  /* pointer to NZ domain data structure (array of points) (20010222) */
+  rsl_point_t     *domain_nz ;
+
+/* MN decomp */
+  /* dimensions of the global domain data structure */
+  rsl_dimlen_t    len_m ;
+  rsl_dimlen_t    len_n ;
+  rsl_dimlen_t    eff_m ;
+  rsl_dimlen_t    eff_n ;
+  rsl_dimlen_t    loc_m ;
+  rsl_dimlen_t    loc_n ;
+  /* dimensions of the global domain data structure (20010222) */
+  rsl_dimlen_t    len_z ;
+  rsl_dimlen_t    eff_z ;
+  rsl_dimlen_t    loc_z ;
+/* MZ decomp (20010223) */
+  /* dimensions of the global domain data structure */
+  rsl_dimlen_t    len_mz_m ;
+  rsl_dimlen_t    len_mz_n ;
+  rsl_dimlen_t    eff_mz_m ;
+  rsl_dimlen_t    eff_mz_n ;
+  rsl_dimlen_t    loc_mz_m ;
+  rsl_dimlen_t    loc_mz_n ;
+  rsl_dimlen_t    len_mz_z ;
+  rsl_dimlen_t    eff_mz_z ;
+  rsl_dimlen_t    loc_mz_z ;
+/* NZ decomp  (20010223 */
+  /* dimensions of the global domain data structure */
+  rsl_dimlen_t    len_nz_m ;
+  rsl_dimlen_t    len_nz_n ;
+  rsl_dimlen_t    eff_nz_m ;
+  rsl_dimlen_t    eff_nz_n ;
+  rsl_dimlen_t    loc_nz_m ;
+  rsl_dimlen_t    loc_nz_n ;
+  rsl_dimlen_t    len_nz_z ;
+  rsl_dimlen_t    eff_nz_z ;
+  rsl_dimlen_t    loc_nz_z ;
+
+  /* list of stencils used on this domain  (just keep handles) */
+  int stenlist[RSL_MAXDESCRIPTORS] ;
+  int stencurs ;
+  int periodlist[RSL_MAXDESCRIPTORS] ;
+  int periodcurs ;
+  int xposelist[RSL_MAXDESCRIPTORS] ;
+  int xposecurs ;
+
+  message_desc_t *old_state_vect, *new_state_vect ;
+
+  /* coordinates of the domain in its parent (sort of) */
+  rsl_index_t     coord_m ;
+  rsl_index_t     coord_n ;
+
+  /* nesting ratio in parent domain */
+  int irax_m ;
+  int irax_n ;
+
+  /* trimming constants -- these are used to tell rsl how much shorter
+     in a dimension the effective range of a nest is than the declared
+     range -- it might be declared longer because it has to be a 
+     multiple of irax_[mn] */
+  int trim_m ;
+  int trim_n ;
+
+  rsl_index_t  nest_level ;     /* 0 is mother domain */
+  rsl_list_t   *pts ;	 	/* list of points on this processor */
+  rsl_list_t   *ghost_pts ;	/* list of points communicating with us */
+  rsl_list_t   *iruns ;		/* list of runs in idimension 1/9/95 */
+  rsl_index_t  ilocaloffset ;	/* ns offset global to local in domain ds */
+  rsl_index_t  jlocaloffset ;   /* ew offset global to local in domain ds */
+
+  rsl_index_t  ilocaloffset_mz ;
+  rsl_index_t  jlocaloffset_mz ;
+  rsl_index_t  klocaloffset_mz ;
+
+  rsl_index_t  ilocaloffset_nz ;
+  rsl_index_t  jlocaloffset_nz ;
+  rsl_index_t  klocaloffset_nz ;
+
+  rsl_index_t  old_ilocaloffset ;
+  rsl_index_t  old_jlocaloffset ;
+  int          maskid  ;	/* maximum stencil specified for this domain */
+
+/* added for RSL_COMPUTE -- in comp_world.c */
+/* these are worked out in rsl_new_decomp.c */
+  int    idif, jdif ;
+  /* these are for iterating with j-major */
+  int    nrun[MAX_KINDPAD+1];
+  int    *(js[MAX_KINDPAD+1]) ;
+  int    *(is[MAX_KINDPAD+1]), *(ie[MAX_KINDPAD+1]), *(jg2n[MAX_KINDPAD+1]) ;
+  /* these are for iterating with i-major */
+  int    nruni[MAX_KINDPAD+1];
+  int    *(is2[MAX_KINDPAD+1]) ;
+  int    *(js2[MAX_KINDPAD+1]), *(je2[MAX_KINDPAD+1]), *(ig2n[MAX_KINDPAD+1]) ;
+
+  rsl_processor_t bcast_recv_Pnpts[RSL_MAXPROC] ;
+  rsl_processor_t bcast_recv_Plist[RSL_MAXPROC] ;
+  rsl_processor_t bcast_recv_Ptags[RSL_MAXPROC] ;
+  int Nbcast_recv_Plist ;
+  rsl_processor_t bcast_send_Pnpts[RSL_MAXPROC] ;
+  rsl_processor_t bcast_send_Plist[RSL_MAXPROC] ;
+  int Nbcast_send_Plist ;
+
+  rsl_list_t *bcast_Xlist ;
+
+
+  rsl_processor_t merge_recv_Pnpts[RSL_MAXPROC] ;
+  rsl_processor_t merge_recv_Plist[RSL_MAXPROC] ;
+  rsl_processor_t merge_recv_Ptags[RSL_MAXPROC] ;
+  int Nmerge_recv_Plist ;
+  rsl_processor_t merge_send_Pnpts[RSL_MAXPROC] ;
+  rsl_processor_t merge_send_Plist[RSL_MAXPROC] ;
+  int Nmerge_send_Plist ;
+
+  rsl_list_t *merge_Xlist ;
+
+
+  int other_hemi_proclist_built ;
+  rsl_hemi_rec_t * other_hemi_procbufs[RSL_MAXPROC] ;
+  int hemi_sendPlist[RSL_MAXPROC] ;
+  int hemi_recvPlist[RSL_MAXPROC] ;
+  int hemi_recv_tags[RSL_MAXPROC] ;
+
+  int is_write, is_read, ie_write, ie_read ;
+  int js_write, js_read, je_write, je_read ;
+
+} rsl_domain_info_t ;
+
+
+/* March 1998 -- structure for new packing strategy */
+#ifdef crayx1
+struct packrec_struct {
+    void * base ;
+    int offset ;
+    int n ;             /* number of bytes in an element */
+    int nelems ;        /* number of elements */
+    int stride ;        /* number of bytes between each element */
+    int f90_table_index ;
+    int endstop ;
+    int valid ;
+    int curs ;          /* position of data in pack buf */
+} ;
+typedef struct packrec_struct packrec_t ;
+
+#else
+struct packrec_struct {
+  void * base ;
+  int offset ;
+  int n ;		/* number of bytes in an element */
+  int nelems ;		/* number of elements */
+  int stride ;		/* number of bytes between each element */
+  int f90_table_index ;
+  int endstop ;
+  int valid ;
+} ;
+typedef struct packrec_struct packrec_t ;
+#endif
+
+typedef struct rsl_procrec {
+  struct rsl_procrec * next ;
+  rsl_processor_t P ;
+  int sendsize ;	/* size of send buf needed for this processor */
+  int recvsize ;	/* size of recv buf needed for this processor */
+  int npts ;
+  int recv_npts ;
+  int nsends ;		/* diagnostic -- keeps running total number of sends */
+  int nrecvs ;		/* diagnostic -- keeps running total number of sends */
+  rsl_list_t *point_list ;
+/* Mar 1998 */
+  rsl_list_t *recv_point_list ;
+  packrec_t * pack_table ;
+  int pack_table_size ;
+  int pack_table_nbytes ;
+  packrec_t * unpack_table ;
+  int unpack_table_size ;
+  int unpack_table_nbytes ;
+} rsl_procrec_t ;
+
+typedef struct rsl_ptrec {
+  struct rsl_ptrec * next ;
+  rsl_point_t *pt ;
+  rsl_index_t ig, jg ;
+  rsl_list_t  *send_messages ;
+  rsl_list_t  *recv_messages ;
+#ifdef crayx1
+  int nsendmsgs ;
+  int nrecvmsgs ;
+#else
+  short nsendmsgs ;
+  short nrecvmsgs ;
+#endif
+} rsl_ptrec_t ;
+
+typedef struct rsl_point_hdr {
+  rsl_index_t d, ig, jg, dummy ;   /* dummy maintains alignment */
+  int nmsgs ;
+} rsl_point_hdr_t ;
+
+typedef struct rsl_message_hdr {  /* packet hdr for message */
+  int sp ;
+} rsl_message_hdr_t ;
+
+typedef struct rsl_fld_hdr {	/* packet hdr for fld */
+  void * base ;                 /* base address; byte pointer arithmetic */
+#ifdef crayx1
+  int len ;                     /* number of bytes to follow */
+#else
+  short len ;                   /* number of bytes to follow */
+#endif
+} rsl_fld_hdr_t ;
+
+/* global data */
+
+#ifdef DEFINE_GLOBAL
+#   define EXTERN
+#else
+#   define EXTERN extern
+#endif
+
+EXTERN rsl_domain_info_t  domain_info[RSL_MAXDOMAINS] ;
+/* message descriptors */
+EXTERN void * mh_descriptors[RSL_MAXDESCRIPTORS] ;
+/* stencil descriptors */
+EXTERN void * sh_descriptors[RSL_MAXDESCRIPTORS] ;
+/* xpose descriptors */
+EXTERN void * xp_descriptors[RSL_MAXDESCRIPTORS] ;
+/* period descriptors */
+EXTERN void * pr_descriptors[RSL_MAXDESCRIPTORS] ;
+EXTERN int rsl_ndomains  ; /* number of active domains */
+EXTERN int rsl_nproc     ; /* number of compute processors */
+EXTERN int rsl_nproc_all ; /* total # of processors (compute and monitor) */
+EXTERN int rsl_nproc_n ; /* number of processors decomposing maj dimension */
+EXTERN int rsl_nproc_m ; /* number of processors decomposing min dimension */
+EXTERN int rsl_myproc ;	/* my physical processor id */
+EXTERN int rsl_idum ;	/* dummy integer variable */
+EXTERN int rsl_padarea ;   /* pad area */
+EXTERN int io_seq_compute ;
+EXTERN int io_seq_monitor ;
+EXTERN char mess[1024] ;      /* misc. message buffer for errors and warns */
+EXTERN char * rsl_noprobe ;  /* set from environment */
+
+EXTERN int rsl_debug_flg ;	/* set by rsl_debug */
+EXTERN int old_offsets ;	/* used in rsl_new_decomp.c */
+
+EXTERN int regular_decomp ;
+EXTERN int sw_allow_dynpad ;
+
+/* rsl macros */
+
+#define RSL_FATAL(N)     rsl_fatal(N)
+#define RSL_TEST_ERR(T,M) {if(T){fprintf(stderr,"%d rsl error (\"%s\":%d) %s\n",rsl_myproc,__FILE__,__LINE__,M);RSL_FATAL(5);}}
+#define RSL_TEST_WRN(T,M) {if(T){fprintf(stderr,"%d rsl warning (\"%s\":%d) %s\n",rsl_myproc,__FILE__,__LINE__,M);}}
+
+#if 1
+#ifndef NEC_TUNE
+#define RSL_MALLOC(T,N)  (T *)rsl_malloc(__FILE__,__LINE__,(sizeof(T))*(N))
+#define RSL_FREE(P)      rsl_free(P)
+#else
+#define RSL_MALLOC(T,N)  (T *)calloc(N, sizeof(T))
+#define RSL_FREE(P)      free(P)
+#endif
+#else
+/* Bob Olson's stuff */
+#define RSL_MALLOC(T,N)  (T *)nexus_debug_malloc((sizeof(T))*(N),__FILE__,__LINE__)
+#define RSL_FREE(P)      nexus_debug_free(P,__FILE__,__LINE__)
+#endif
+
+#define MONITOR_ONLY(S)  { int x ; \
+    RSL_C_IAMMONITOR( &x ) ; \
+    if ( x==0 )                 \
+      sprintf(mess,"%s: callable only by monitor",S) ; \
+      RSL_TEST_ERR( x == 0,mess) ; }
+
+/*
+   This uses the low 26 bits of a 32 bit message type to encode a message
+   type, a FROM processor designation and a TO processor designation.  Note
+   the limits of this encoding:
+
+        o  10 bits available for processor id (limit is 1024 processors)
+        o   6 bits available for message tag - 1, because we are not
+            allowing 0.  (limit is thus 63 possible tags)
+
+   This is a potential machine or message passing interface dependency.
+   Note, though, that under the proposed MPI standard, this would not
+   be a problem because there are no FORCED type ranges to avoid and
+   all .
+
+rev: 95/02/15 -- jm.  Modified to drop the TO field (never used) and
+   shorten the TAG field by 1 bit so that the total number of bits
+   required is 15 (compatibility with minimum MPI standard and, in
+   particular for the Fujitsu AP1000 at ANU).  Note the new limits
+   from this encoding:
+
+        o  10 bits available for processor id (limit is 1024 processors)
+           (FROM only is encoded now)
+        o   5 bits available for message tag - 1, because we are not
+            allowing 0.  (limit is now 31 possible tags).
+*/
+
+#if 0
+# define MTYPE_FROMTO(Y,F,T) ((((Y)&0x3f)<<20)|(((F)&0x3ff)<<10)|(((T)&0x3ff)))
+# define MTYPE_TAG(X)   (((X)>>20)&0x3f)
+# define MTYPE_FROM(X)  (((X)>>10)&0x3ff)
+# define MTYPE_TO(X)    ((X)&0x3ff)
+#else
+# if 1
+/* T is ignored and not encoded in the message tag, Y has been shorted 1 bit */
+# define MTYPE_FROMTO(Y,F,T) (((((Y)&0x1f)<<10)|(((F)&0x3ff))) | 0 )
+# define MTYPE_TAG(X)   (((X)>>10)&0x1f)
+# define MTYPE_FROM(X)  ((X)&0x3ff)
+# else
+/* update May 2002, increase upper bound on processors to 4096 (12 bits)*/
+# define MTYPE_FROMTO(Y,F,T) (((((Y)&0x1f)<<12)|(((F)&0xfff))) | 0 )
+# define MTYPE_TAG(X)   (((X)>>12)&0x1f)
+# define MTYPE_FROM(X)  ((X)&0xfff)
+# endif
+#endif
+
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+#define INDEX_3(A,B,NB,C,NC)  INDEX_2( (A), INDEX_2( (B), (C), (NC) ), (NB)*(NC) )
+
+#if 0
+/* new encoding for these -- 
+    7 bits -- domain id		maximum number is 127
+   12 bits -- ig index		maximum number is 4095
+   12 bits -- jg index		maximum number is 4095
+  ----
+   31 bits
+*/
+#define POINTID(D,J,I)   ((((((D)&0x7f))<<24)|(((J)&0xfff)<<12)|((I)&0xfff))|0L)
+#define ID_DOMAIN(M)     ((((M)>>24)&0x7f)|0L)
+#define ID_JDEX(M)       ((((M)>>12)&0xfff)|0L)
+#define ID_IDEX(M)       (((M)      &0xfff)|0L)
+#else
+/* make ig and jg work as signed quantities */
+/* new encoding for these -- 
+    7 bits -- domain id		maximum number is 127
+   12 bits -- ig index		range is -2048 to 2047
+   12 bits -- jg index		range is is -2048 to 2047
+  ----
+   31 bits
+*/
+#define POINTID(D,J,I)   ((((((D)&0x7f))<<24)|(((J)&0xfff)<<12)|((I)&0xfff))|0L)
+#define ID_DOMAIN(M)     ((((M)>>24)&0x7f)|0L)
+#define ID_JDEX(M)       (((((M)>>12)&0xfff)&0x800)?((((M)>>12)&0xfff)|(-4096L)):((((M)>>12)&0xfff)|0L))
+#define ID_IDEX(M)       (((M)&0x800)?(((M)      &0xfff)|(-4096L)):(((M)      &0xfff)|0L))
+#endif
+
+#define IS_INVALID(M) ( (M) == RSL_INVALID )
+
+/* forward declarations */
+
+rsl_point_id_t pointid() ;
+rsl_index_t id_domain(), id_jdex(), id_idex() ;
+
+/* RSL PT DESCRIPTORS */
+
+#define RSL_4PT     4		/* FORTRAN */
+#define RSL_8PT     8		/* FORTRAN */
+#define RSL_12PT   12		/* FORTRAN */
+#define RSL_24PT   24		/* FORTRAN */
+#define RSL_48PT   48		/* FORTRAN */
+#define RSL_80PT   80		/* FORTRAN */
+#define RSL_120PT  120		/* FORTRAN */
+#if (ALLOW_RSL_168PT == 1)
+/* new -- added for MM5's upper radiative boundary stencil 9/26/96 */
+#define RSL_168PT  168          /* FORTRAN */
+#endif
+
+#define RSL_NORTHSOUTH       1	/* FORTRAN */
+#define RSL_EASTWEST         2	/* FORTRAN */
+#define RSL_NORTHSOUTH_STAG  11	/* FORTRAN */
+#define RSL_EASTWEST_STAG    12	/* FORTRAN */
+#define RSL_NOTDECOMPOSED    3	/* FORTRAN */
+
+#define RSL_M                1	/* FORTRAN */
+#define RSL_N                2	/* FORTRAN */
+#define RSL_M_STAG          11	/* FORTRAN */
+#define RSL_N_STAG          12	/* FORTRAN */
+
+/* message tags */
+
+#define MSG_NEWDECOMPOSITION 100
+#define MSG_MONITOR_REQUEST  101
+#define MSG_STENCOM          		1
+#define MSG_READ_RESPONSE    		2
+#define MSG_WRITE_RESPONSE    		3
+#define MSG_WRITE_COMPUTE_RESPONSE    	4
+#define MSG_SPECIAL1_RESPONSE           5
+#define MSG_SPECIAL2_RESPONSE           6
+#define MSG_FROM_PARENT      		7
+#define MSG_BCAST_SETUP      		8
+#define MSG_MERGE_SETUP      		9
+#define MSG_TO_PARENT        	       10
+#define MSG_MON_BCAST		       11
+#define MSG_REDISTCOM    	       12
+#define MSG_PERCOM                     13
+#define MSG_XPOSECOM                     14
+
+#define MSG_IO_FORTRAN                  1
+#define MSG_IO_SOCKET                   2
+
+/* values for request mode2 when writing to sockets
+   Raw mode just writes a byte stream,
+
+   Fortran mode puts control words at beginning and end of each write
+   with byte count in control word. 
+
+   Portal mode puts a portal style dimension descriptor at the
+   head of each new write.
+*/
+
+#define MSG_MODE2_RAW                         1
+#define MSG_MODE2_FORTRAN                     2
+#define MSG_MODE2_PORTAL                      3
+#define MSG_MODE2_88                          4
+
+/* monitor request types */
+#define RSL_READ_REQUEST      100
+#define RSL_READ_RESPONSE     101
+#define RSL_READ_SPECIAL1     102
+#define RSL_READ_SPECIAL2     103
+#define RSL_READ_SPECIAL3     104
+#define RSL_SHUTDOWN_REQUEST  105
+#define RSL_WRITE_REQUEST     106
+#define RSL_WRITE_RESPONSE    107
+
+/* descriptor tags */
+
+#define MESSAGE_DESC 0
+#define STENCIL_DESC 1
+#define BLANK_MESSAGE_DESC 2
+#define PERIOD_DESC 3
+#define XPOSE_DESC 4
+
+/* xpose switches */
+#define XPOSE_MN_MZ 0
+#define XPOSE_MZ_MN 0
+
+#define XPOSE_MZ_NZ 1
+#define XPOSE_NZ_MZ 1
+
+#define XPOSE_MN_NZ 2
+#define XPOSE_NZ_MN 2
+
+/* defines for MPI2 compat */
+
+#ifndef MPI2_SUPPORT
+typedef int MPI_Fint;
+#  define MPI_Comm_c2f(comm) (MPI_Fint)(comm)
+#  define MPI_Comm_f2c(comm) (MPI_Comm)(comm)
+#endif
+
+/* other includes */
+
+#include "rsl_comm.h"
+#include "compat.h"
+#include "buf_for_proc.h"
+#include "stencil_def.h"	/* stencil_def.h must follow message_def.h */
+#include "xpose_def.h"	/* xpose_def.h must follow message_def.h */
+#include "period_def.h"	/* period_def.h must follow message_def.h */
+#include "rsl_io.h"
+
+#if (( defined(vpp) || defined(vpp2) ) && ! defined(sx))
+#define bcopy(a,b,c) vbcopy_C(a,b,c)
+#endif
+
+void * rsl_malloc(), * malloc()  ;
+void * get_base_for_index() ;
+
+#ifdef NEC_TUNE
+extern void copymem( void *, int, void *, int, int, int ) ;
+#endif
+
+
+#endif   /* nothing after this line */
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl.inc_base b/wrfv2_fire/external/RSL/RSL/rsl.inc_base
new file mode 100755
index 00000000..c5cabf2d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl.inc_base
@@ -0,0 +1,20 @@
+      integer rsl_phys2comp, rsl_comp2phys
+      logical rsl_iamcompute, rsl_iammonitor, rsl_nextcell
+      external rsl_iamcompute, rsl_iammonitor, rsl_nextcell
+      external rsl_phys2comp, rsl_comp2phys
+
+      integer rsl_nproc_all
+      integer rsl_nproc
+      integer rsl_myproc
+      integer rsl_nproc_min
+      integer rsl_nproc_maj
+      integer rsl_ndomains
+      integer rsl_padarea
+      common /rslsysXx/ rsl_nproc_all
+      common /rslsysXx/ rsl_nproc
+      common /rslsysXx/ rsl_myproc
+      common /rslsysXx/ rsl_nproc_min
+      common /rslsysXx/ rsl_nproc_maj
+      common /rslsysXx/ rsl_ndomains
+      common /rslsysXx/ rsl_padarea
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_bcast.c b/wrfv2_fire/external/RSL/RSL/rsl_bcast.c
new file mode 100755
index 00000000..6c4da409
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_bcast.c
@@ -0,0 +1,1501 @@
+/* #define LEARN_BCAST */
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#define MOD_9707
+
+#include 
+#include 
+#include "rsl.h"
+
+typedef struct stage_point {
+  char * p ;            /* pointer to buffer for point */
+  int curs ;            /* cursor into point buffer */
+#if (defined(vpp) || defined(vpp2))
+  int blankcurs ;       /* curser into blank stage array */
+#endif
+  int P ;               /* processor ID for point */
+  int kid_id ;
+  int parent_id ;
+  int cm ;
+  int cn ;
+  struct stage_point *next ;    /* list pointer */
+} stage_point_t ;
+
+typedef struct par_info {
+  rsl_index_t ig, jg, cn, cm ;
+  int kidid ;
+} par_info_t ;
+
+static destroy_par_info ( p )
+  char * p ;
+{
+  if ( p != NULL ) RSL_FREE( p ) ;
+}
+
+static rsl_list_t *Xlist, *Xp, *Xprev ;
+static stage_point_t *stage ;
+static int stage_len = 0 ;              /* 96/3/15 */
+
+static int s_d ;
+static int s_nst ;
+static int s_msize ;
+static int s_nlen ;
+static int s_mlen ;
+static int s_nlen_nst ;
+static int s_mlen_nst ;
+static int s_irax_n ;
+static int s_irax_m ;
+static stage_point_t *Plist[RSL_MAXPROC] ;
+static int Psize[RSL_MAXPROC] ;
+static rsl_domain_info_t *s_dinfo, *s_ninfo ;
+static rsl_point_t *s_ddomain, *s_ndomain ;
+static char *s_parent_msgs ;
+static int s_parent_msgs_curs ;
+static int s_remaining ;  /* number of bytes left in a parent message before
+                           the next point descriptor */
+
+/* add a field to a message outgoing for the specified child domain cell */
+/* relies on rsl_ready_bcast having been called already */
+/* sends are specified in terms of coarse domain */
+
+static int s_i, s_j, s_ig, s_jg, s_cm, s_cn,
+           s_nig, s_njg ;
+
+#ifdef LEARN_BCAST
+static int s_putmsg = 0 ;
+#endif
+
+#if (defined(vpp) || defined(vpp2))
+static char *blankstage = NULL ;
+static int blankstagesize = 0 ;
+static int blankstagecurs = 0 ;
+#endif
+
+/*@
+  RSL_TO_CHILD_INFO -- Get the next cell in a packing sequence for forcing.
+
+  Notes:
+  RSL_TO_CHILD_INFO is used in a packing loop to build messages for
+  forcing a nested (Arg2) domain with data from a parent (Arg1), in
+  preparation for a call to RSL_BCAST_MSGS.  For an overview of the
+  mechanism and a detailed example, see RSL_BCAST_MSGS.
+
+  The Arg3 argument gives the size of the parent to child cell messages
+  in bytes.  This may be larger than needed, but never smaller;
+  otherwise the program will abort (to avoid overwriting memory).
+
+  Each call to RSL_TO_CHILD_INFO gives the coordinates of a nested
+  point to be sent forcing data (Arg10, Arg11), the local indices
+  (Arg4, Arg5) and global indices (Arg6, Arg7) of the associated parent
+  cell, and the indices of the child cell in the set of nest cells
+  associated with the parent (Arg8, Arg9).  These
+  specify which of the nest cells associated with the parent
+  is being referred to.  There are IRAX_M by IRAX_N nest points
+  associated with each parent, where IRAX_M is the nesting ratio in the
+  M dimension and IRAX_N is the nesting ratio in the N dimension (See
+  the descriptions for the RSL nest spawning routines RSL_SPAWN...).
+
+  RSL_TO_CHILD_INFO will return a new set of coordinates for every nest
+  point associated with a locally stored parent domain point.  In other
+  words, if the processor has 15 points from the parent domain in its
+  local memory and the nesting ratios are 3 by 3, then 135 (15*9)
+  successive calls to RSL_TO_CHILD_INFO will return valid coordinates.
+  Each time the routine returns with a valid point, the value of Arg12
+  will be 1 and RSL will be in a state that is ready to accept data for
+  the point.  The message is constructed using the routine
+  RSL_TO_CHILD_MSG.  The 136th call will return a value of 0 (zero) in
+  Arg12, indicating there are no more points.
+
+  It isn't necessary that anything be done with the coordinates that
+  are returned.  However, once called, RSL_TO_CHILD_INFO must be called
+  as many times as it takes to exhaust the number of points; otherwise
+  the underlying RSL mechanism will not be left in the proper state at
+  the conclusion of the broadcast.
+
+  See also:
+  RSL_BCAST_MSGS, RSL_TO_CHILD_MSG, RSL_FROM_PARENT_INFO
+@*/
+
+RSL_TO_CHILD_INFO ( d_p, n_p, msize_p,
+                    i_p, j_p,
+                    ig_p, jg_p, cm_p, cn_p,
+                    nig_p, njg_p, retval_p )
+  int_p
+     d_p            /* (I) RSL domain descriptor of parent. */
+    ,n_p            /* (I) RSL domain descriptor of nest. */
+    ,msize_p        /* (I) Message size in bytes. */
+    ,i_p            /* (O) Local M index of parent domain point. */
+    ,j_p            /* (O) Local N index of parent domain point. */
+    ,ig_p           /* (O) Global N index of parent domain point. */
+    ,jg_p           /* (O) Global N index of parent domain point. */
+    ,cm_p           /* (O) M index of child cell beneath parent cell (see discussion). */
+    ,cn_p           /* (O) N index of child cell beneath parent cell (see discussion). */
+    ,nig_p          /* (O) Global M index of nest domain point. */
+    ,njg_p          /* (O) Global N index of nest domain point. */
+    ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
+{
+  rsl_child_info_t *kid ;
+  rsl_list_t *lp ;
+#ifdef LEARN_BCAST
+  int removed ;
+#endif
+  par_info_t *dp ;
+  int P ;
+
+  if ( stage == NULL )
+  {
+    rsl_ready_bcast( d_p, n_p, msize_p ) ;
+  }
+
+  if (( lp = Xlist) == NULL ) 
+  {
+    *retval_p = -1 ;
+    Xlist = s_ninfo->bcast_Xlist ;
+#ifdef LEARN_BCAST
+    Xprev = NULL ;
+    Xp = NULL ;
+    s_putmsg = 0 ;
+#endif
+    return ;
+  }
+
+#ifdef LEARN_BCAST
+  removed = 0 ;
+  if ( s_putmsg == 0 )
+  {
+     /* the node  previous to the one pointed to by Xlist did not
+        add any messages.  Let's get rid of it. */
+     if ( Xprev != NULL  ) { Xprev->next = Xlist ; Xp = Xlist ; removed = 1 ; }
+  }
+  if ( Xlist != s_ninfo->bcast_Xlist && ! removed ) Xprev = Xp ;
+  Xp = Xlist ;
+#endif
+
+  Xlist = Xlist->next ;
+  dp = (par_info_t *)(lp->data) ;
+  s_ig = dp->ig ;
+  s_jg = dp->jg ;
+  s_i = s_ig + s_dinfo->idif ;
+  s_j = s_jg + s_dinfo->jdif ;
+  s_cm = dp->cm ;
+  s_cn = dp->cn ;
+  s_nig = ID_IDEX( dp->kidid ) ;
+  s_njg = ID_JDEX( dp->kidid ) ;
+
+  *ig_p = s_ig + 1 ;
+  *jg_p = s_jg + 1;
+  *i_p = s_i + 1 ;
+  *j_p = s_j + 1;
+  *cm_p = s_cm + 1;
+  *cn_p = s_cn + 1;
+  *nig_p = s_nig + 1;
+  *njg_p = s_njg + 1;
+
+#ifdef LEARN_BCAST
+  s_putmsg = 0 ;
+#endif
+
+  *retval_p = 1 ;
+  return ;
+}
+
+/*@
+  RSL_TO_CHILD_MSG -- Pack force data into a message for a nest point.
+
+  Notes:
+  RSL_TO_CHILD_MSG is used in a loop to pack messages for forcing
+  a nested domain with data from a parent in preparation for
+  a call to RSL_BCAST_MSGS.  For an overview of the mechanism and a detailed
+  example, see RSL_BCAST_MSGS.
+
+  Before calling RSL_TO_CHILD_MSG, RSL must have been put into the correct
+  state; that is, ready to accept data that will be sent to a particular
+  point in the nest.  This is done by first calling RSL_TO_CHILD_INFO.
+  RSL_TO_CHILD_MSG may be called as many times as necessary to pack
+  data into the message (or not at all, if there is no data for the point
+  returned by RSL_TO_CHILD_INFO).  Each call to RSL_TO_CHILD_MSG copies
+  Arg1 bytes from the bufffer specified by Arg2 into the message, which
+  is allocated by RSL and never manipulated directly by
+  the user program.  The amount of data that can be packed is limited
+  to the message size that
+  was specified in the first call to RSL_TO_CHILD_INFO.
+
+  See also:
+  RSL_BCAST_MSGS, RSL_TO_CHILD_INFO
+
+@*/
+
+RSL_TO_CHILD_MSG ( nbuf_p, buf )
+  int_p
+    nbuf_p ;     /* (I) Number of bytes to be packed. */
+#ifndef NEC_TYPE4B
+  char *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+#else
+  float *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+#endif
+{
+  int kiddex ;
+  int nbuf ;
+  int P ;
+#ifdef NEC_TYPE4B
+  float * dist ;
+  int i ;
+#endif
+
+  RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
+
+  nbuf = *nbuf_p ;
+
+#if (defined(vpp)||defined(vpp2))
+#define BLANKBUMP (4*1024)
+#endif
+
+#ifdef LEARN_BCAST
+  s_putmsg = 1 ;
+#endif
+
+  kiddex = INDEX_2(s_njg,s_nig,s_mlen_nst) ;
+  P = s_ndomain[ kiddex ].P ;
+#if ! (defined(vpp)||defined(vpp2))
+  if ( stage[ kiddex ].p == NULL )
+  {
+    stage[ kiddex ].p = RSL_MALLOC( char, s_msize ) ;
+    stage[ kiddex ].curs = 0 ;
+    stage[ kiddex ].P = P ;
+    stage[ kiddex ].next = Plist[P] ;
+    Plist[P] =  &(stage[ kiddex ]) ;
+  }
+#else
+  if ( stage[ kiddex ].p == NULL )
+  {
+    if (  blankstagecurs + s_msize >= blankstagesize )
+    {
+       char * newblank ;
+       int i ;
+       newblank = RSL_MALLOC( char, blankstagesize + BLANKBUMP*s_msize ) ;
+       bcopy(blankstage,newblank,blankstagesize) ;
+       /* reset the stage p pointers into the new blank stage buffer */
+       for ( i = 0 ; i < s_mlen_nst * s_nlen_nst ; i++)
+       {
+         if ( stage[i].p != NULL )
+         {
+           stage[i].p = &(newblank[stage[i].blankcurs]) ;
+         }
+       }
+       blankstagesize += BLANKBUMP*s_msize ;
+       if ( blankstage != NULL ) RSL_FREE( blankstage ) ;
+       blankstage = newblank ;
+    }
+    stage[ kiddex ].p = (char *) &( blankstage[blankstagecurs] ) ;
+    stage[ kiddex ].blankcurs = blankstagecurs ;
+    blankstagecurs += s_msize ;
+    stage[ kiddex ].curs = 0 ;
+    stage[ kiddex ].P = P ;
+    stage[ kiddex ].next = Plist[P] ;
+    Plist[P] =  &(stage[ kiddex ]) ;
+  }
+#endif
+  if ( stage[ kiddex ].curs + nbuf > s_msize )
+  {
+    sprintf(mess,
+    "RSL_TO_CHILD_MSG: would overflow buffer (%d+%d>%d)\n",
+        stage[ kiddex ].curs, nbuf, s_msize ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+
+  /* add point to head of list of points for processor P */
+  stage[kiddex].kid_id = POINTID(s_nst,s_njg,s_nig) ;
+  stage[kiddex].parent_id = POINTID( s_d, s_jg, s_ig ) ;
+  stage[kiddex].cm = s_cm ;
+  stage[kiddex].cn = s_cn ;
+  Psize[P] += s_msize + sizeof( bcast_point_desc_t ) ;
+
+  /* pack the buffer associated with stage[kiddex] */
+#ifndef NEC_TYPE4B
+  bcopy( buf, &(stage[ kiddex ].p[ stage[ kiddex ].curs ]), nbuf ) ;
+#else
+  dist = (float *) &(stage[ kiddex ].p[ stage[ kiddex ].curs ]) ;
+#pragma cdir nodep
+  for ( i = 0 ; i < nbuf / 4 ; i++ )
+  {
+    *(dist++) = *(buf++) ;
+  }
+#endif
+  stage[ kiddex ].curs += nbuf ;
+
+}
+
+/*@
+  RSL_BCAST_MSGS -- Convey forcing data from parent to nest points.
+
+  Notes:
+  RSL_BCAST_MSGS is called once forcing data
+  from points in a parent domain have been packed into messages
+  destined for associated points on the nest.  The routine has
+  no arguments; rather, RSL must be in a ready state; this occurs
+  once RSL_TO_CHILD_INFO has returned a value of 0 (zero)
+  in its last argument on all processors.  The forcing data is
+  conveyed along logical communication channels that were set up
+  between nest points and associated points in the parent domain
+  when the nest was spawned.  Interprocessor communication
+  is generated for messages between points on different processors;
+  otherwise, the transfer
+  is done within the processor's local memory.
+
+  The inverse operation to RSL_BCAST_MSGS is RSL_MERGE_MSGS, which
+  is used for conveying feedback data from nest to parent.
+
+  Note while reading the following example that RSL decomposes all
+  domains independently and over all processors, so that every
+  processor will have cells from the parent and from the nest.
+  Thus, all processors perform both the packing of data from
+  the parent and the unpacking of data onto the nest.  Other
+  RSL routines appearing in the example are described elsewhere
+  in these documents.
+
+  Example:
+
+$ C
+$ C Packing data from the parent.
+$ C
+$   NLEV = (the number of vertical levels)
+$   MSIZE = 3 * NLEV + 1 * WORDSIZE
+$ C
+$ C First call to rsl_to_child_info
+$ C
+$   CALL RSL_TO_CHILD_INFO( PID, NID,      ! parent, nest domain descriptors
+$                           MSIZE,         ! size of message to a point
+$                           I,J,PIG,PJG,   ! local and global parent cell coords
+$                           CM,CN,         ! index of nest cell in parent cell
+$                           NIG,NJG,       ! global nest cell coords
+$                           IRETVAL )      ! return value
+$   DO WHILE ( IRETVAL .EQ. 1 )
+$     IF ( NIG .EQ. 1 .OR. NIG .EQ. M .OR. ! force only cells on nest bdy
+$          NJG .EQ. 1 .OR. NJG .EQ. N     ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_TO_CHILD_MSG( WORDSIZE, FINTERP( CN, CM, U, I, J ) )
+$         CALL RSL_TO_CHILD_MSG( WORDSIZE, FINTERP( CN, CM, V, I, J ) )
+$         CALL RSL_TO_CHILD_MSG( WORDSIZE, FINTERP( CN, CM, T, I, J ) )
+$       ENDDO
+$       CALL RSL_TO_CHILD_MSG( WORDSIZE, FINTERP( CN, CM, PS, I, J ) )
+$     ENDIF
+$ C
+$ C Subsequent calls to rsl_to_child_info
+$ C
+$     CALL RSL_TO_CHILD_INFO( PID, NID, MSIZE, I,J,PIG,PJG, CM,CN,
+$                             NIG,NJG, IRETVAL )
+$   END DO
+$ C
+$ C Broadcast the data.
+$ C
+$   CALL RSL_BCAST_MSGS
+$ C
+$ C Unpack the data onto the nest.
+$ C
+$ C
+$ C First call to rsl_from_parent_info
+$ C
+$   CALL RSL_FROM_PARENT_INFO( I, J,       ! local nest cell coords
+$                              NIG, NJG,   ! global nest cell coords
+$                              CM, CN,     ! index of nest cell in parent cell
+$                              PIG, PJG,   ! global parent cell coords
+$                              IRETVAL )   ! return value
+$   DO WHILE ( IRETVAL .EQ. 1 )
+$     IF ( NIG .EQ. 1 .OR. NIG .EQ. M .OR.      ! force only cells on nest bdy
+$          NJG .EQ. 1 .OR. NJG .EQ. N     ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_FROM_PARENT_MSG( WORDSIZE, U(I,J,K) )
+$         CALL RSL_FROM_PARENT_MSG( WORDSIZE, V(I,J,K) )
+$         CALL RSL_FROM_PARENT_MSG( WORDSIZE, T(I,J,K) )
+$       ENDDO
+$       CALL RSL_FROM_PARENT_MSG( WORDSIZE, PS(I,J) )
+$     END IF
+$ C
+$ C Subsequent calls to rsl_from_parent_info
+$ C
+$     CALL RSL_FROM_PARENT_INFO( I, J, NIG, NJG, CM, CN, PIG, PJG, IRETVAL )
+$   END DO
+
+BREAKTHEEXAMPLECODE
+
+  In this example, three 3-dimensional fields, U, V, and T, and one
+  2-dimensional field, PS, from the parent domain are interpolated and
+  sent as forcing data to the boundary of the nest.  Finterp is an
+  interpolation function that computes the value for the nest based
+  on the coordinates in the parent and on which nest cell the value
+  is going to.  WORDSIZE, PIG, and PJG are integers; otherwise implicit typing
+  holds.
+
+                          
+  See also:
+  RSL_TO_CHILD_INFO, RSL_FROM_PARENT_INFO, RSL_MERGE_MSGS
+
+@*/
+
+
+RSL_BCAST_MSGS ()
+{
+  int P ;
+  char *work ;
+  bcast_point_desc_t pdesc ;
+  stage_point_t *pt ;
+  int curs ;
+  int msglen, mdest, mtag ;
+  int ii ;
+  int ig, jg ;
+#ifdef NEC_TYPE4B
+  float * from ;
+  float * to ;
+  int i ;
+#endif
+
+  RSL_TEST_ERR( stage == NULL,
+    "RSL_BCAST_MSGS: rsl_to_child_info not called first" ) ;
+
+#if 0
+ fprintf(stderr,"RSL_BCAST DEBUG s_msize %d\n",s_msize) ;
+#endif
+
+  for ( ii = 0 ; ii < s_ninfo->Nbcast_send_Plist ; ii++ )
+  {
+    P = s_ninfo->bcast_send_Plist[ii] ;
+    msglen = s_ninfo->bcast_send_Pnpts[ii]*( sizeof(pdesc) + s_msize ) 
+             + sizeof(pdesc) ; /*  end of message marker */
+    curs = 0 ;
+    work = buffer_for_proc( P, msglen, RSL_SENDBUF ) ;
+    /* NOTE ASSUMPTION that the number of points in Plist will
+       be less or equal to ninfo->bcast_send_Pnpts[ii].  If it isn't,
+       we've got trouble.  */
+#if 0
+    /* debugging -- check the length of the list and compare
+       it with the number of points we *think* we have. */
+    { int npts_have, npts_thinkhave ;
+      npts_thinkhave = s_ninfo->bcast_send_Pnpts[ii] ;
+      for ( pt = Plist[P], npts_have = 0 ; pt != NULL ; pt = pt->next )
+      {
+        npts_have++ ;
+      }
+      if ( npts_thinkhave < npts_have )
+      {
+        sprintf(mess,"For P=%d Think have (%d) < have (%d)\n",P,npts_thinkhave,npts_have) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+    }
+#endif
+    for ( pt = Plist[P] ; pt != NULL ; pt = pt->next )
+    {
+      if ( curs+sizeof(bcast_point_desc_t)+s_msize>msglen )
+      {
+        sprintf(mess,"would overwrite in bcast messages: %d > %d",
+                curs+sizeof(bcast_point_desc_t)+s_msize, msglen) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#if 0
+      ig = ID_IDEX( pt->parent_id ) ;
+      jg = ID_JDEX( pt->parent_id ) ;
+      if ( rsl_c_comp2phys_proc(s_dinfo->domain[INDEX_2(jg,ig,s_mlen)].P) != rsl_myproc )
+      {
+        sprintf(mess,"Point %d %d doesn't belong to me (%d) but rather to %d\n",ig,jg,rsl_myproc,
+                      rsl_c_comp2phys_proc(s_dinfo->domain[INDEX_2(jg,ig,s_mlen)].P)) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#endif
+      pdesc.nest_id = pt->kid_id ;
+      pdesc.parent_id = pt->parent_id ;
+      pdesc.cm = pt->cm ;
+      pdesc.cn = pt->cn ;
+      bcopy( &pdesc, &work[curs], sizeof( bcast_point_desc_t )) ;
+      curs += sizeof( bcast_point_desc_t ) ;
+#ifndef NEC_TYPE4B
+      bcopy( pt->p, &work[curs], s_msize ) ;
+#else
+      from = (float *) pt->p ;
+      to = (float *) &work[curs] ;
+#pragma cdir nodep
+      for ( i = 0 ; i < s_msize / 4 ; i++ )
+      {
+        *(to++) = *(from++) ;
+      }
+#endif
+
+#if 0
+{
+  int v ;
+  float f ;
+  fprintf(stderr,"RSL_BCAST DEBUG : ") ;
+  for ( v = 0 ; v < s_msize/4 ; v++ )
+  {
+    bcopy( &work[v*4], &f, 4 ) ;
+    fprintf(stderr," %f ",f ) ;
+  }
+}
+#endif
+
+      curs += s_msize ;
+    }
+    RSL_TEST_ERR(curs+sizeof(bcast_point_desc_t)>msglen,
+      "Internal error: (end marker) would overwrite in bcast messages.") ;
+    /* add end marker */
+    pdesc.nest_id = RSL_INVALID ;
+    pdesc.parent_id = RSL_INVALID ;
+    pdesc.cm = RSL_INVALID ;
+    pdesc.cn = RSL_INVALID ;
+    bcopy( &pdesc, &work[curs], sizeof( bcast_point_desc_t )) ;
+    curs += sizeof( bcast_point_desc_t ) ;
+    /* note that it is all right for mlen to be less than msglen */
+    if ( rsl_c_comp2phys_proc(P) != rsl_myproc )
+    {
+      mdest = rsl_c_comp2phys_proc(P) ;
+      mtag = MTYPE_FROMTO( MSG_FROM_PARENT, rsl_myproc, mdest ) ;
+      msglen = curs ;
+      RSL_SEND( work, msglen, mtag, mdest ) ;
+    }
+    /* othersize, leave in the send buffer and we'll pick it
+       up later */
+  }
+
+  /* reset this for the next phase, in RSL_MESSAGE_FROM_PARENT */
+  s_parent_msgs = NULL ;
+}
+
+/* Return a point from some parent processor each time called.
+   If no more points, from a processor, got to the next one.
+   If no more points at all, retval is returned as RSL_INVALID */
+
+
+/*@
+  RSL_FROM_PARENT_INFO -- Get the next cell in a unpacking sequence for forcing.
+
+  Notes:
+  RSL_FROM_PARENT_INFO is used in a loop to unpack messages
+  containing forcing data for a nested domain.  The messages have arrived on the
+  local processor as a result of a previous call to RSL_BCAST_MSGS.
+  The domain descriptors do not need to be specified; they are part of
+  the state of RSL as a result of the calls to RSL_TO_CHILD_INFO that
+  have come before.  For a detailed example, see RSL_BCAST_MSGS.
+
+  Each call to RSL_FROM_PARENT_INFO gives the local indices a
+  nested point receiving forcing data (Arg1, Arg2), the global indices
+  of the nested point (Arg3, Arg4), and the global indices of the
+  parent domain point providing the forcing data (Arg7, Arg8).  The
+  indices of the child cell in the set of nest cells associated with
+  the parent are returned through arguments Arg5 and Arg6.  These
+  specify which of the nest cells associated with the parent
+  is being referred to.  There are IRAX_M by IRAX_N nest points
+  associated with each parent where IRAX_M is the nesting ratio in the
+  M dimension and IRAX_N is the nesting ratio in the N dimension (See
+  the descriptions for the RSL nest spawning routines RSL_SPAWN...).
+
+  RSL_FROM_PARENT_INFO will return a new set of coordinates for every
+  nest point stored in local processor memory.  For each point,
+  RSL_FROM_PARENT_INFO returns a value of 1 through Arg9.  RSL is
+  left in a state ready to yield
+  data for the nest point; the data
+  is unpacked from the message by calling RSL_FROM_PARENT_MSG.  Once
+  all local nest points have been traversed, RSL_FROM_PARENT_INFO
+  returns a value of 0 (zero) in Arg9.
+
+  It isn't necessary that anything be unpacked with the coordinates
+  that are returned.  However, once called, RSL_FROM_PARENT_INFO must
+  be called as many times as it takes to exhaust the number of points;
+  otherwise the underlying RSL mechanism will not be left in the proper
+  state at the conclusion of the broadcast.
+
+  See also:
+  RSL_BCAST_MSGS, RSL_TO_CHILD_INFO, RSL_FROM_PARENT_MSG
+@*/
+
+RSL_FROM_PARENT_INFO ( i_p, j_p, ig_p, jg_p, cm_p, cn_p,
+                       pig_p, pjg_p, retval_p )
+  int_p
+    i_p         /* (O) Local index in M dimension of nest. */
+   ,j_p         /* (O) Local index in N dimension of nest. */
+   ,ig_p        /* (O) Global index in M dimension of nest. */
+   ,jg_p        /* (O) Global index in N dimension of nest. */
+   ,cm_p        /* (O) M index of child cell beneath parent cell. */
+   ,cn_p        /* (O) N index of child cell beneath parent cell. */
+   ,pig_p       /* (O) Global index in M dimension of parent. */
+   ,pjg_p       /* (O) Global index in N dimension of parent. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  int ii ;
+  bcast_point_desc_t pdesc ;
+
+  if ( s_remaining > 0 )
+  {
+    s_parent_msgs_curs += s_remaining ;
+    s_remaining = 0 ;
+  }
+  get_a_new_bcast_point( retval_p ) ;
+  if ( *retval_p != 1 )
+  {
+    cleanup_after_bcast() ;
+    return ;
+  }
+  s_remaining = s_msize + sizeof(bcast_point_desc_t) ;
+
+  /* at this point we have a non-null message buffer */
+  /* read the descriptor */
+  bcopy( &(s_parent_msgs[s_parent_msgs_curs]),
+         &pdesc,
+         sizeof(bcast_point_desc_t)) ;
+  s_parent_msgs_curs += sizeof(bcast_point_desc_t) ;
+  s_remaining -= sizeof(bcast_point_desc_t) ;
+
+  /* get_a_new_bcast_point should not be returning these */
+  RSL_TEST_ERR( pdesc.nest_id == RSL_INVALID, "Internal error.") ;
+
+  *ig_p = ID_IDEX(pdesc.nest_id)+1 ;
+  *jg_p = ID_JDEX(pdesc.nest_id)+1 ;
+  *i_p = *ig_p + s_ninfo->idif ;
+  *j_p = *jg_p + s_ninfo->jdif ;
+  *pig_p = ID_IDEX(pdesc.parent_id)+1 ;
+  *pjg_p = ID_JDEX(pdesc.parent_id)+1 ;
+  *cm_p = pdesc.cm+1 ;
+  *cn_p = pdesc.cn+1 ;
+
+  *retval_p = 1 ;
+  return ;
+}
+
+/*@
+  RSL_FROM_PARENT_MSG -- Unpack feedback data into a nest point.
+
+  Notes:
+  RSL_FROM_PARENT_MSG is used in a loop to unpack messages containing
+  forcing data from a parent domain.
+  For an overview of the mechanism and a detailed
+  example, see RSL_BCAST_MSGS.
+
+  Before calling RSL_FROM_PARENT_MSG, RSL must have been put into the correct
+  state; that is, ready to accept data that will be sent to a particular
+  point in the nest.  This is done by first calling RSL_FROM_PARENT_INFO.
+  RSL_FROM_PARENT_MSG may then be called as many times as necessary to unpack
+  data from the message (or not at all, if there is no data for the point).
+  Each call to RSL_FROM_PARENT_MSG copies
+  Arg1 bytes from message into the bufffer specified by Arg2. Note that
+  the message
+  is allocated and handled entirely within RSL and never manipulated directly by
+  the user program.  The amount of data that can be packed is limited
+  to the message size that
+  was specified in the first call to RSL_TO_CHILD_INFO.
+
+  See also:
+  RSL_BCAST_MSGS, RSL_FROM_PARENT_INFO, RSL_TO_CHILD_INFO
+
+@*/
+RSL_FROM_PARENT_MSG ( len_p, buf )
+  int_p
+    len_p ;          /* (I) Number of bytes to unpack. */
+#ifndef NEC_TYPE4B
+  char *
+    buf ;            /* (O) Destination buffer. */
+#else
+  float *
+    buf ;            /* (O) Destination buffer. */
+#endif
+{
+#ifdef NEC_TYPE4B
+  float * dist ;
+  int i ;
+#endif
+  if ( *len_p <= 0 ) return ;
+  if ( *len_p > s_remaining ) 
+  {
+    sprintf(mess,
+"RSL_FROM_PARENT_MSG:\n   Requested number of bytes (%d) exceeds %d, the number remaining for this point.\n", *len_p, s_remaining) ;
+    RSL_TEST_WRN(1,mess) ;
+  }
+#ifndef NEC_TYPE4B
+  bcopy( &(s_parent_msgs[s_parent_msgs_curs]),
+         buf,
+         *len_p ) ;
+#else
+  dist = (float *) &(s_parent_msgs[s_parent_msgs_curs]) ;
+#pragma cdir nodep
+  for ( i = 0 ; i < *len_p / 4 ; i++ )
+  {
+    *(buf++) = *(dist++) ;
+  }
+#endif
+
+#if 0
+{
+float f ;
+bcopy(buf,&f,4) ;
+fprintf(stderr,"RSL_FROM_PARENT_MSG debug: curs: %d, val %f\n",
+        s_parent_msgs_curs, f ) ;
+}
+#endif
+
+  s_parent_msgs_curs += *len_p ;
+  s_remaining -= *len_p ;
+}
+
+get_a_new_bcast_point( retval_p )
+  int_p retval_p ;
+{
+  int result, mtag, ii ;
+  bcast_point_desc_t pdesc ;
+
+  do {
+    if ( s_parent_msgs != NULL )
+    {
+#if 0
+      pdesc = *((bcast_point_desc_t *)(&(s_parent_msgs[s_parent_msgs_curs]))) ;
+#else
+/* djs 1/98 */
+      bcopy( &s_parent_msgs[s_parent_msgs_curs]
+           , &pdesc
+           , sizeof( bcast_point_desc_t )
+           ) ;
+#endif
+      if ( pdesc.nest_id != RSL_INVALID )
+      {
+        *retval_p = 1 ;
+        return ;                /* 2.a. */
+      }
+    }
+    /* are there outstanding messages? */
+    for ( ii = 0 ; ii < s_ninfo->Nbcast_recv_Plist ; ii++ )
+    {
+      if ( s_ninfo->bcast_recv_Ptags[ii] != RSL_INVALID )
+      {
+        break ;
+      }
+    }
+    if ((ii == s_ninfo->Nbcast_recv_Plist)||(s_ninfo->Nbcast_recv_Plist <= 0))
+    {
+      *retval_p = -1 ;
+      s_parent_msgs = NULL ;
+      return ;                  /* 2.b.i */
+    }
+    /* scan till we get a message */
+    ii = 0 ;
+    result = 1 ;
+    while (1)
+    {
+      if ( s_ninfo->bcast_recv_Ptags[ii] != RSL_INVALID )
+      {
+        if ( rsl_c_comp2phys_proc(s_ninfo->bcast_recv_Plist[ii]) != rsl_myproc )
+        {
+          mtag = s_ninfo->bcast_recv_Ptags[ii] ;
+          if ( rsl_noprobe == NULL )
+            RSL_PROBE( mtag, &result ) ;
+          /* else, result will always be 1 */
+          if ( result )
+          {
+#ifdef PGON
+            if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtag ) ;
+#else
+            RSL_RECVEND ( mtag ) ;
+#endif
+            s_ninfo->bcast_recv_Ptags[ii] = RSL_INVALID ;
+            s_parent_msgs =
+               buffer_for_proc( s_ninfo->bcast_recv_Plist[ii], 0, RSL_RECVBUF )
+;
+            break ;
+          }
+        }
+        else
+        {
+          /* code to handle data from myself, which will be in my send buffer */
+          s_ninfo->bcast_recv_Ptags[ii] = RSL_INVALID ;
+          s_parent_msgs =
+             buffer_for_proc( s_ninfo->bcast_recv_Plist[ii], 0, RSL_SENDBUF ) ;
+                                                          /*    ^^^^^^^^^^^  */
+                                                          /* because data is */
+                                                          /* from myself     */
+          break ;
+        }
+      }
+      if ( ++ii >= s_ninfo->Nbcast_recv_Plist ) ii = 0 ;
+    }
+    s_parent_msgs_curs = 0 ;
+#if 0
+    pdesc = *((bcast_point_desc_t *)(&(s_parent_msgs[s_parent_msgs_curs]))) ;
+#else
+/* djs 1/98 */
+    bcopy( &s_parent_msgs[s_parent_msgs_curs]
+         , &pdesc
+         , sizeof(bcast_point_desc_t)
+         ) ;
+#endif
+  } while ( pdesc.nest_id == RSL_INVALID ) ;
+  *retval_p = 1 ;
+}
+
+post_receives_from_parent()
+{
+  int ii, msglen, P, mtag, mfrom ;
+  char * work ;
+
+  for ( ii = 0 ; ii < s_ninfo->Nbcast_recv_Plist ; ii++ )
+  {
+    P = s_ninfo->bcast_recv_Plist[ii] ;
+    mfrom = rsl_c_comp2phys_proc(P) ;
+    if ( mfrom != rsl_myproc )
+    {
+      msglen = s_ninfo->bcast_recv_Pnpts[ii]*(sizeof(bcast_point_desc_t)+s_msize)
+               + sizeof(bcast_point_desc_t) ;    /* end marker */
+      work = buffer_for_proc(P, msglen, RSL_RECVBUF) ;
+      mtag = MTYPE_FROMTO( MSG_FROM_PARENT, mfrom, rsl_myproc ) ;
+      RSL_RECVBEGIN( work, msglen, mtag ) ;
+      s_ninfo->bcast_recv_Ptags[ii] = mtag ; /* store tag */
+    }
+    else
+    {
+      /* set the tag so we know to unpack the send buffer 
+         for data from ourself */
+      mtag = MTYPE_FROMTO( MSG_FROM_PARENT, mfrom, rsl_myproc ) ;
+      s_ninfo->bcast_recv_Ptags[ii] = mtag ;
+    }
+  }
+}
+
+RSL_MOVE_NEST ( d_p, n_p,  mdisp_p, ndisp_p )
+  int_p d_p, n_p, mdisp_p, ndisp_p ;
+{
+  int parent, intermed, nest, mdisp, ndisp ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  int i, j, cm, cn, irax_m, irax_n, nid ;
+  int mother_id ;
+  rsl_child_info_t ** children_p ;
+
+  parent = *d_p    ; nest = *n_p      ;
+  mdisp = *mdisp_p ; ndisp = *ndisp_p ; 
+
+  RSL_TEST_ERR( parent < 0 || parent > RSL_MAXDOMAINS, "rsl_move_nest: bad parent domain descriptor" ) ;
+  RSL_TEST_ERR( nest < 0   || nest > RSL_MAXDOMAINS,   "rsl_move_nest: bad nested domain descriptor" ) ;
+  dinfo = &( domain_info[parent]) ;
+  ninfo = &( domain_info[nest]) ;
+  irax_m = ninfo->irax_m ;
+  irax_n = ninfo->irax_n ;
+
+  if ( dinfo->child_bcast_compiled[s_nst] != 1 ||
+       ninfo->parent_bcast_compiled != 1 )
+  {
+    rsl_comp_bcast( d_p, n_p ) ;
+  }
+  dinfo->child_bcast_compiled[nest] = 0 ;  /* invalidate broadcast */
+  ninfo->parent_bcast_compiled      = 0 ;  /* invalidate broadcast */
+
+
+  if ( dinfo->child_merge_compiled[s_nst] != 1 ||
+       ninfo->parent_merge_compiled != 1 )
+  {
+    rsl_comp_merge( d_p, n_p ) ;
+  }
+  dinfo->child_merge_compiled[nest] = 0 ;  /* invalidate merge */
+  ninfo->parent_merge_compiled      = 0 ;  /* invalidate merge */
+
+  children_p = RSL_MALLOC( rsl_child_info_t *, dinfo->len_n * dinfo->len_m ) ;
+
+  for ( j = 0 ; j < dinfo->len_n ; j++ )
+    for ( i = 0 ; i < dinfo->len_m ; i++ )
+         children_p[ INDEX_2( j, i, dinfo->len_m ) ] = NULL ;
+
+  for ( j = 0 ; j < dinfo->len_n ; j++ )
+    for ( i = 0 ; i < dinfo->len_m ; i++ )
+       if (    i - mdisp >= 0 && i - mdisp < dinfo->len_m 
+            && j - ndisp >= 0 && j - ndisp < dinfo->len_n ) {
+         children_p[ INDEX_2( j, i, dinfo->len_m ) ] = dinfo->domain[ INDEX_2( j - ndisp , i - mdisp, dinfo->len_m ) ].children_p ;
+       }
+
+  for ( j = 0 ; j < dinfo->len_n ; j++ )
+    for ( i = 0 ; i < dinfo->len_m ; i++ )
+       dinfo->domain[ INDEX_2( j , i , dinfo->len_m ) ].children_p = children_p[ INDEX_2( j, i, dinfo->len_m ) ] ;
+
+  RSL_FREE( children_p ) ;
+
+  for ( j = 0 ; j < dinfo->len_n ; j++ )
+    for ( i = 0 ; i < dinfo->len_m ; i++ )
+      for ( cn = 0 ; cn < irax_n ; cn++ )
+        for ( cm = 0 ; cm < irax_m ; cm++ )
+          if ( dinfo->domain[ INDEX_2( j, i, dinfo->len_m ) ].children_p != NULL )
+          {
+            dinfo->domain[ INDEX_2( j, i, dinfo->len_m ) ].children_p->child[INDEX_2(cn,cm,irax_m)] = RSL_INVALID ;
+          }
+
+  for ( j = 0 ; j < ninfo->len_n ; j++ )
+  {
+    for ( i = 0 ; i < ninfo->len_m ; i++ )
+    {
+      nid = POINTID( nest, j, i ) ;
+      mother_id = ninfo->domain[ INDEX_2( j, i, ninfo->len_m ) ].mother_id ;
+      mother_id = POINTID(parent, (ID_JDEX( mother_id )) + ndisp, (ID_IDEX( mother_id )) + mdisp ) ;
+      ninfo->domain[ INDEX_2( j, i, ninfo->len_m ) ].mother_id = mother_id ;
+      ninfo->domain[ INDEX_2( j, i, ninfo->len_m ) ].mother_P = 
+                       dinfo->domain[ INDEX_2( ID_JDEX( mother_id ), ID_IDEX( mother_id ), dinfo->len_m ) ].P ;
+      cm = ninfo->domain[ INDEX_2( j, i, ninfo->len_m ) ].which_kid_am_i_m ;
+      cn = ninfo->domain[ INDEX_2( j, i, ninfo->len_m ) ].which_kid_am_i_n ;
+      if ( dinfo->domain[ INDEX_2( ID_JDEX( mother_id ), ID_IDEX( mother_id ), dinfo->len_m ) ].children_p != NULL ) {
+        dinfo->domain[ INDEX_2( ID_JDEX( mother_id ), ID_IDEX( mother_id ), dinfo->len_m ) ].children_p->child[INDEX_2(cn,cm,irax_m)] = nid ;
+      }
+    }
+  }
+  ninfo->coord_m += mdisp ;
+  ninfo->coord_n += ndisp ;
+}
+
+rsl_ready_bcast( d_p, n_p, msize_p )
+  int_p d_p, n_p, msize_p ;
+{
+  int i ;
+  par_info_t *dp ;
+  rsl_list_t *lp ;
+  rsl_child_info_t * kid ;
+  rsl_point_t *pt, *pt2 ;
+  int kidid ;
+  int ig, jg, kig, kjg, cn, cm ;
+  int P ;
+#ifdef NEC_TUNE
+  int size ;
+  int myproc ;
+  int * list ;
+#endif
+
+  s_msize = *msize_p ;
+  s_d = *d_p ;
+  s_nst = *n_p ;
+  RSL_TEST_ERR( stage != NULL,
+    "rsl_ready_bcast: called again before RSL_BCAST_MSGS of previous call.") ;
+  RSL_TEST_ERR( s_d < 0 || s_d > RSL_MAXDOMAINS,
+    "rsl_ready_bcast: bad parent domain descriptor" ) ;
+  RSL_TEST_ERR( s_nst < 0 || s_nst > RSL_MAXDOMAINS,
+    "rsl_ready_bcast: bad nested domain descriptor" ) ;
+  RSL_TEST_ERR( s_d == s_nst,
+    "rsl_ready_bcast: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[s_nst].parent != s_d ,
+    "rsl_ready_bcast: the nest is not a child of the parent" ) ;
+ 
+  s_dinfo = &( domain_info[s_d]) ;
+  s_ninfo = &( domain_info[s_nst]) ;
+  RSL_TEST_ERR( s_dinfo->valid != RSL_VALID,
+    "rsl_ready_bcast: invalid parent domain" ) ;
+  RSL_TEST_ERR( s_ninfo->valid != RSL_VALID,
+    "rsl_ready_bcast: invalid nested domain" ) ;
+  s_ddomain = s_dinfo->domain ;
+  s_ndomain = s_ninfo->domain ;
+
+  s_mlen = s_dinfo->len_m ;
+  s_nlen = s_dinfo->len_n ;
+  s_mlen_nst = s_ninfo->len_m ;
+  s_nlen_nst = s_ninfo->len_n ;
+  s_irax_n = s_ninfo->irax_n ;
+  s_irax_m = s_ninfo->irax_m ;
+
+
+  if ( s_dinfo->child_bcast_compiled[s_nst] != 1 ||
+       s_ninfo->parent_bcast_compiled != 1 )
+  {
+    rsl_comp_bcast( d_p, n_p ) ;
+    if ( s_ninfo->bcast_Xlist != NULL )
+    {
+      destroy_list( &(s_ninfo->bcast_Xlist), destroy_par_info ) ;
+    }
+    s_ninfo->bcast_Xlist = NULL ;
+  }
+
+  post_receives_from_parent() ;
+
+  stage = RSL_MALLOC( stage_point_t , s_mlen_nst * s_nlen_nst ) ;
+  stage_len = s_mlen_nst * s_nlen_nst ;         /* 96/3/15 */
+  for ( i = 0 ; i < stage_len ; i++ )
+  {
+    stage[i].p = NULL ;
+  }
+
+#if (defined(vpp)||defined(vpp2))
+  blankstagecurs = 0 ;
+#endif
+
+  /* construct the list of nested points under local parent points */
+
+  if ( s_ninfo->bcast_Xlist == NULL )
+  {
+    /* traverse backwards so that Xlist can be constructed easily frontwards */
+#ifndef NEC_TUNE
+    for ( jg = s_nlen-1 ; jg >=0 ; jg-- )
+    {
+      for ( ig = s_mlen-1 ; ig >= 0 ; ig-- )
+      {
+        pt = &(s_ddomain[INDEX_2(jg,ig,s_mlen)]) ;
+        if ( pt->valid == RSL_VALID &&
+             rsl_c_comp2phys_proc(pt->P) == rsl_myproc )
+        {
+          if ((kid=pt->children_p) != NULL )
+          {
+            for ( cn = s_irax_n-1 ; cn >= 0 ; cn-- )
+            {
+              for ( cm = s_irax_m-1 ; cm >= 0 ; cm-- )
+              {
+                kidid = kid->child[INDEX_2(cn,cm,s_irax_m)] ;
+                kig = ID_IDEX( kidid ) ;
+                kjg = ID_JDEX( kidid ) ;
+                pt2 = &(s_ndomain[INDEX_2(kjg,kig,s_mlen_nst)]) ;
+                if ( pt2->valid == RSL_VALID  &&
+                     ID_DOMAIN(kidid)==s_nst)
+                {
+                  dp = RSL_MALLOC( par_info_t, 1 ) ;
+                  dp->ig = ig ;
+                  dp->jg = jg ;
+                  dp->cn = cn ;
+                  dp->cm = cm ;
+                  dp->kidid = kidid ;
+                  lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+                  lp->data = dp ;
+                  lp->next = s_ninfo->bcast_Xlist ;
+                  s_ninfo->bcast_Xlist = lp ;
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+#else
+    list = malloc( (s_irax_n*s_irax_m*s_nlen*s_mlen+1) * sizeof(int) ) ;
+    size = 0 ;
+    for ( cn = s_irax_n-1 ; cn >= 0; cn-- )
+    {
+      for ( cm = s_irax_m-1 ; cm >= 0; cm-- )
+      {
+#pragma cdir nodep
+        for ( i = s_nlen*s_mlen-1 ; i >= 0; i-- )
+        {
+          pt = &(s_ddomain[i]) ;
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+          myproc = pt->P ;
+#  else
+          myproc = pt->P ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+          myproc = pt->P ;
+#  else
+          myproc = pt->P + 1 ;
+#  endif
+#endif
+          if ( pt->valid == RSL_VALID && myproc == rsl_myproc )
+          {
+            if ((kid=pt->children_p) != NULL )
+            {
+              kidid = kid->child[INDEX_2(cn,cm,s_irax_m)] ;
+              kig = ID_IDEX( kidid ) ;
+              kjg = ID_JDEX( kidid ) ;
+              pt2 = &(s_ndomain[INDEX_2(kjg,kig,s_mlen_nst)]) ;
+              if ( pt2->valid == RSL_VALID && ID_DOMAIN(kidid)==s_nst)
+              {
+                size++ ;
+                *(list+size) = i ;
+              }
+            }
+          }
+        }
+      }
+    }
+    dp = RSL_MALLOC( par_info_t, size ) ;
+    lp = RSL_MALLOC( rsl_list_t, size ) ;
+    for ( cn = s_irax_n-1 ; cn >= 0; cn-- )
+    {
+      for ( cm = s_irax_m-1 ; cm >= 0; cm-- )
+      {
+        for ( i = 1 ; i <= size ; i++ )
+        {
+          pt = &(s_ddomain[*(list+i)]) ;
+#if ( HOST_NODE == 0 )
+#  if ( MON_LOW == 0 )
+          myproc = pt->P ;
+#  else
+          myproc = pt->P ;
+#  endif
+#else
+#  if ( MON_LOW == 0 )
+          myproc = pt->P ;
+#  else
+          myproc = pt->P + 1 ;
+#  endif
+#endif
+          if ( pt->valid == RSL_VALID && myproc == rsl_myproc )
+          {
+            if ((kid=pt->children_p) != NULL )
+            {
+              kidid = kid->child[INDEX_2(cn,cm,s_irax_m)] ;
+              kig = ID_IDEX( kidid ) ;
+              kjg = ID_JDEX( kidid ) ;
+              pt2 = &(s_ndomain[INDEX_2(kjg,kig,s_mlen_nst)]) ;
+              if ( pt2->valid == RSL_VALID && ID_DOMAIN(kidid)==s_nst)
+              {
+                dp->ig = *(list+i) % s_mlen ;
+                dp->jg = *(list+i) / s_mlen ;
+                dp->cn = cn ;
+                dp->cm = cm ;
+                dp->kidid = kidid ;
+                lp->data = dp ;
+                lp->next = s_ninfo->bcast_Xlist ;
+                s_ninfo->bcast_Xlist = lp ;
+                dp++ ;
+                lp++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+    free( list ) ;
+#endif
+  }
+  Xlist = s_ninfo->bcast_Xlist ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    Plist[P] = NULL ;
+  }
+
+  return ;
+}
+
+/* now used internally only */
+rsl_comp_bcast( d_p, n_p )
+  int_p d_p, 
+        n_p ;
+{
+  int d, nst, mlen, nlen, mlen_nst, nlen_nst ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *ddomain, *ndomain, *pt ;
+  rsl_child_info_t *kids ;
+  rsl_processor_t P ;
+  int i, j, jg, ig, jgn, ign, cn, cm, cnt, p ;
+  int irax_n, irax_m ;
+
+  d = *d_p ;
+  nst = *n_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, 
+        "rsl_comp_bcast: bad parent domain descriptor") ;
+  RSL_TEST_ERR( nst < 0 || nst >= RSL_MAXDOMAINS, 
+        "rsl_comp_bcast: bad nested domain descriptor") ;
+  RSL_TEST_ERR( d == nst, 
+        "rsl_comp_bcast: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+        "rsl_comp_bcast: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+        "rsl_comp_bcast: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+        "rsl_comp_bcast: invalid nested domain" ) ;
+
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  mlen_nst = ninfo->len_m ;
+  nlen_nst = ninfo->len_n ;
+  ddomain = dinfo->domain ;
+  ndomain = ninfo->domain ;
+  irax_n = ninfo->irax_n ;
+  irax_m = ninfo->irax_m ;
+
+  destroy_bcast_compilation( d_p, n_p ) ;
+
+  if ( dinfo->decomposed != 1 )
+  {
+     fprintf(stderr,"Calling default decomposition for parent %d\n",*d_p);
+     default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  if ( ninfo->decomposed != 1 )
+  {
+     fprintf(stderr,"Calling default decomposition for nest %d\n",*n_p);
+     default_decomposition( n_p,
+                           &(domain_info[*n_p].loc_m),
+                           &(domain_info[*n_p].loc_n) ) ;
+  }
+
+  /* begin by computing the receive list */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 
+    ninfo->bcast_recv_Pnpts[i] = 0 ;
+
+  for ( jgn = 0 ; jgn < nlen_nst ; jgn++ )
+  {
+    for ( ign = 0 ; ign < mlen_nst ; ign++ )
+    {
+      pt = &(ndomain[INDEX_2(jgn,ign,mlen_nst)]) ;
+      if ( pt->valid == RSL_VALID  &&
+           rsl_c_comp2phys_proc(pt->P) == rsl_myproc )
+      {
+        (ninfo->bcast_recv_Pnpts[pt->mother_P])++ ; /* count this point as 
+                                                       coming from the parent
+                                                       processor */
+      }
+    }
+  }
+  /* compress and copy the plist */
+  ninfo->Nbcast_recv_Plist = 0 ;
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    if ( ninfo->bcast_recv_Pnpts[P] > 0 )
+    {
+      ninfo->bcast_recv_Pnpts[ninfo->Nbcast_recv_Plist] =
+                                        ninfo->bcast_recv_Pnpts[P] ;
+      ninfo->bcast_recv_Plist[ninfo->Nbcast_recv_Plist] = P ;
+      (ninfo->Nbcast_recv_Plist)++ ;
+    }
+  }
+
+  /* now compute the send list */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 
+    ninfo->bcast_send_Pnpts[i] = 0 ;
+
+  for ( jgn = 0 ; jgn < nlen_nst ; jgn++ )
+  {
+    for ( ign = 0 ; ign < mlen_nst ; ign++ )
+    {
+      pt = &(ndomain[INDEX_2(jgn,ign,mlen_nst)]) ;
+      if ( pt->valid == RSL_VALID  &&
+           rsl_c_comp2phys_proc(pt->mother_P) == rsl_myproc )
+      {
+         if ( pt->valid == RSL_VALID )
+          ninfo->bcast_send_Pnpts[pt->P]++ ; /* count this point being
+                                                sent from me to P */
+      }
+    }
+  }
+
+  /* compress and copy the plist */
+  ninfo->Nbcast_send_Plist = 0 ;
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    if ( ninfo->bcast_send_Pnpts[P] > 0 )
+    {
+      ninfo->bcast_send_Pnpts[ninfo->Nbcast_send_Plist] =
+                                        ninfo->bcast_send_Pnpts[P] ;
+      ninfo->bcast_send_Plist[ninfo->Nbcast_send_Plist] = P ;
+
+      (ninfo->Nbcast_send_Plist)++ ;
+    }
+  }
+
+  dinfo->child_bcast_compiled[nst] = 1 ;
+  ninfo->parent_bcast_compiled = 1 ;
+
+  return ;
+}
+
+cleanup_after_bcast()
+{
+  int i ;
+  if ( stage != NULL )
+  {
+    for ( i = 0 ; i < stage_len ; i++ )
+    {
+#if ! (defined(vpp)||defined(vpp2))
+      if ( stage[i].p != NULL ) RSL_FREE( stage[i].p ) ;  /* 96/3/15 */
+#else
+      stage[i].p = NULL ;
+#endif
+    }
+    RSL_FREE( stage ) ;
+  }
+#if (defined(vpp)||defined(vpp2))
+  blankstagecurs = 0 ;
+#endif
+  stage = NULL ;
+  s_msize = RSL_INVALID ;
+  s_dinfo = NULL ;
+  s_ninfo = NULL ;
+  s_ddomain = NULL ;
+  s_ndomain = NULL ;
+  s_parent_msgs = NULL ;
+  s_parent_msgs_curs = RSL_INVALID ;
+}
+
+destroy_bcast_compilation( d_p, n_p )
+  int_p d_p, n_p ;
+{
+  int d, nst, P ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *ddomain, *ndomain, *pt ;
+
+  d = *d_p ;
+  nst = *n_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+        "rsl_comp_bcast: bad parent domain descriptor") ;
+  RSL_TEST_ERR( nst < 0 || nst >= RSL_MAXDOMAINS,
+        "rsl_comp_bcast: bad nested domain descriptor") ;
+  RSL_TEST_ERR( d == nst,
+        "rsl_comp_bcast: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+        "rsl_comp_bcast: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+        "rsl_comp_bcast: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+        "rsl_comp_bcast: invalid nested domain" ) ;
+  
+  ninfo->parent_bcast_compiled = 0 ;
+  dinfo->child_bcast_compiled[nst] = 0 ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    ninfo->bcast_recv_Pnpts[P] = 0 ;
+    ninfo->bcast_recv_Plist[P] = RSL_INVALID ;
+    ninfo->bcast_recv_Ptags[P] = RSL_INVALID ;
+    ninfo->Nbcast_recv_Plist = 0 ;
+  }
+}
+
+#ifdef NOUNDERSCORE
+cwrap_fbcast ( pd, nd, msize, mf, pf, upf )
+#else
+# ifdef T3D
+CWRAP_FBCAST ( pd, nd, msize, mf, pf, upf )
+# else
+#   ifdef F2CSTYLE
+cwrap_fbcast__( pd, nd, msize, mf, pf, upf )
+#   else
+cwrap_fbcast_( pd, nd, msize, mf, pf, upf )
+#   endif
+# endif
+#endif
+  int *pd, *nd, *msize ;
+  void (*mf)(), (*pf)(), (*upf)() ;
+{
+  char * buf ;
+  buf = RSL_MALLOC( char, *msize ) ;
+#ifdef NOUNDERSCORE
+  rsl_f_bcast_chld ( pd, nd, msize, buf, mf, pf, upf ) ;
+#else
+# ifdef T3D
+  RSL_F_BCAST_CHLD ( pd, nd, msize, buf, mf, pf, upf ) ;
+# else
+#   ifdef F2CSTYLE
+  rsl_f_bcast_chld__( pd, nd, msize, buf, mf, pf, upf ) ;
+#   else
+  rsl_f_bcast_chld_( pd, nd, msize, buf, mf, pf, upf ) ;
+#   endif
+# endif
+#endif
+  RSL_FREE( buf ) ;
+}
+
+#ifdef NOUNDERSCORE
+cwrap_fmerge ( pd, nd, msize, mf, pf, upf )
+#else
+# ifdef T3D
+CWRAP_FMERGE ( pd, nd, msize, mf, pf, upf )
+# else
+#   ifdef F2CSTYLE
+cwrap_fmerge__( pd, nd, msize, mf, pf, upf )
+#   else
+cwrap_fmerge_( pd, nd, msize, mf, pf, upf )
+#   endif
+# endif
+#endif
+  int *pd, *nd, *msize ;
+  void (*mf)(), (*pf)(), (*upf)() ;
+{
+  char * buf ;
+  buf = RSL_MALLOC( char, *msize ) ;
+#ifdef NOUNDERSCORE
+  rsl_f_merge_chld ( pd, nd, msize, buf, mf, pf, upf ) ;
+#else
+# ifdef T3D
+  RSL_F_MERGE_CHLD ( pd, nd, msize, buf, mf, pf, upf ) ;
+# else
+#   ifdef F2CSTYLE
+  rsl_f_merge_chld__( pd, nd, msize, buf, mf, pf, upf ) ;
+#   else
+  rsl_f_merge_chld_( pd, nd, msize, buf, mf, pf, upf ) ;
+#   endif
+# endif
+#endif
+  RSL_FREE( buf ) ;
+}
+
+vbcopy_C(a,b,c)
+  char *a, *b ; int c ;
+{
+#if (( defined(vpp) || defined(vpp2) ) && ! defined(sx))
+  int l, lb ;
+  l = ((c)/sizeof(int)) ;
+  lb = l*sizeof(int) ;
+  vicopy_(a,b,&l) ;
+  l = c-lb ;
+  vbcopy_(a+lb,b+lb,&l) ;
+#endif
+}
+
+RSL_RESET_STAGING ()
+{
+#if (defined(vpp) || defined(vpp2))
+if ( blankstage != NULL ) RSL_FREE( blankstage ) ;
+blankstage = NULL ;
+blankstagesize = 0 ;
+blankstagecurs = 0 ;
+#endif
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_bcast_f.F b/wrfv2_fire/external/RSL/RSL/rsl_bcast_f.F
new file mode 100755
index 00000000..c2997ff5
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_bcast_f.F
@@ -0,0 +1,106 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_bcast_chld( pd, nd, msize, mf, pf, upf )
+      call cwrap_fbcast( pd, nd, msize, mf, pf, upf )
+      return
+      end
+
+      subroutine rsl_f_bcast_chld( pd, nd, msize, buf, mf, pf, upf )
+      implicit none
+      integer pd                ! parent domain
+      integer nd                ! nested domain
+      integer msize             ! message size  in BYTES
+      integer pf                ! packing function
+      integer upf               ! unpacking function
+      logical mf                ! mask function
+      real buf(msize)
+      include 'rsl.inc'
+c local variables
+      integer retval, i, j, ig, jg, dum
+      integer njg, nig, n, pjg, pig, cn, cm
+
+      call rsl_to_child_info( pd, nd, msize,
+     +                        i,j,pig,pjg,cm,cn,nig,njg,retval )
+      do while ( retval .eq. 1 )
+        if ( mf( pd, nd, i, j, pig, pjg ) ) then
+          dum = pf ( pd, nd, i, j, pig, pjg, 
+     +              dum, dum,     nig, njg,
+     +              cm, cn, buf, msize )
+          call rsl_to_child_msg(msize,buf)
+        endif
+        call rsl_to_child_info( pd, nd, msize,
+     +                          i,j,pig,pjg,cm,cn,nig,njg,retval )
+      enddo
+
+c exchange the messages
+      call rsl_bcast_msgs
+
+c unpack the messages from children of points in this domain
+
+      call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg, 
+     +                           retval )
+      do while ( retval .eq. 1 )
+	call rsl_from_parent_msg( msize, buf )
+        dum = upf( pd, nd, i, j, nig, njg, cm, cn, buf, msize )
+        call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg,
+     +                             retval )
+      enddo
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_bdyin_f.F b/wrfv2_fire/external/RSL/RSL/rsl_bdyin_f.F
new file mode 100755
index 00000000..d3d74d39
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_bdyin_f.F
@@ -0,0 +1,76 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine fort_bdyin_real( unit,
+     $               buf_e,buf_w,buf_n,buf_s, n_ew, n_ns )
+      implicit none
+      integer unit, n_ew, n_ns
+      real buf_e(n_ew),buf_w(n_ew),buf_n(n_ns),buf_s(n_ns)
+      read( unit ) buf_e,buf_w,buf_n,buf_s
+      return
+      end
+
+      subroutine fort_bdyin_dbl( unit,
+     $               buf_e,buf_w,buf_n,buf_s, n_ew, n_ns )
+      implicit none
+      integer unit, n_ew, n_ns
+      double precision buf_e(n_ew),buf_w(n_ew),buf_n(n_ns),buf_s(n_ns)
+      read( unit ) buf_e,buf_w,buf_n,buf_s
+      return
+      end
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_cham_compat.c b/wrfv2_fire/external/RSL/RSL/rsl_cham_compat.c
new file mode 100755
index 00000000..ee6b80ad
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_cham_compat.c
@@ -0,0 +1,288 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/* this is still under construction  -- 11/94 */
+
+#ifdef CHAMELEON
+#ifndef __CHAM_COMPAT__
+#define __CHAM_COMPAT__
+
+#include 
+#include "tools.h" 
+#include "comm/comm.h"
+#include "rsl.h"
+
+#define RSLHandleInc 32
+
+typedef long CHAM_request ;
+
+struct tagsToHandles
+       {
+       int tag;
+       char * buff ;
+       int mlen ;
+       int datatype ;
+       CHAM_Request Handle;
+       };
+struct rslCHAMHandles
+       {
+       int nHandles;
+       int nUsed;
+       struct tagsToHandles *tags;
+       } rslCHAMHandleLUT;
+
+/******************************************************
+ * rslCHAMInit ()
+ *   do whatever initialization is necessary for the
+ *   CHAM port
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *  Adapted to CHAM: J. Michalakes 11/94
+ *
+ *****************************************************/
+
+static int dummy = 0 ;
+
+void rslCHAMInit()
+  {
+  rslCHAMHandleLUT.nHandles = RSLHandleInc;
+  rslCHAMHandleLUT.nUsed = 0;
+  rslCHAMHandleLUT.tags = (struct tagsToHandles *) 
+                     malloc (sizeof (struct tagsToHandles) * RSLHandleInc);
+
+#ifdef FATAL_ERRORS
+  if (rslCHAMHandleLUT.tags == NULL)
+    {
+    fprintf (stderr, "Fatal Error: malloc failure in rslCHAMInit\n");
+    exit(1);
+    }
+#endif
+  }
+
+
+/******************************************************
+ * rslCHAMWho ( numproc, myproc )
+ *  Use the LUT to find an CHAM wait handle from a tag
+ *
+ *  Initial coding: J. Michalakes  7/13/94
+ *
+ *****************************************************/
+
+long rslCHAMWho( numproc, myproc )
+  int * numproc, * myproc ;
+{
+  *myproc = PImytid ;
+  *numproc = PInumtids ;
+  return( 0L ) ;
+}
+
+/******************************************************
+ * rslCHAMFindWaitH (tag)
+ *  Use the LUT to find an CHAM wait handle from a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+long rslCHAMFindWaitH (tag, waitHandle,
+		       buff, mlen, datatype )
+  int tag;   /* Tag for which we lookup a wait handle */
+  CHAM_Request *waitHandle ;
+  char ** buff ;
+  int *mlen ;
+  int *datatype ;
+  {
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslCHAMHandleLUT.nUsed; i++)
+    {
+    if (rslCHAMHandleLUT.tags[i].tag == tag)
+      {
+      *buff       = rslCHAMHandleLUT.tags[i].buff;
+      *mlen       = rslCHAMHandleLUT.tags[i].mlen;
+      *datatype   = rslCHAMHandleLUT.tags[i].datatype;
+      *waitHandle = rslCHAMHandleLUT.tags[i].Handle;
+
+      rslCHAMHandleLUT.nUsed--;  /* Keep them contiguous */
+      rslCHAMHandleLUT.tags[i].tag=rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].tag;
+      rslCHAMHandleLUT.tags[i].buff=
+                  rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].buff;
+      rslCHAMHandleLUT.tags[i].mlen=
+                  rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].mlen;
+      rslCHAMHandleLUT.tags[i].datatype=
+                  rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].datatype;
+      rslCHAMHandleLUT.tags[i].Handle=
+                  rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].Handle;
+      break;
+      }
+    }
+  }
+
+/******************************************************
+ * rslCHAMSaveWaitH (tag, waitHandle)
+ *  Use the LUT to save an CHAM wait handle referenced by a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslCHAMSaveWaitH (tag, waitHandle)
+ int tag;
+ CHAM_Request * waitHandle;
+ {
+ /* Make sure there is enough space, if not, try a realloc */
+ /* If the realloc fails we're in deep trouble */
+ if (rslCHAMHandleLUT.nUsed == rslCHAMHandleLUT.nHandles)
+   {
+   struct tagsToHandles *tags;  /* Temp pointer */
+   tags = (struct tagsToHandles *) 
+      realloc (rslCHAMHandleLUT.tags, 
+      sizeof (struct tagsToHandles) * (rslCHAMHandleLUT.nHandles + RSLHandleInc));
+   if (tags != NULL)
+     {
+     rslCHAMHandleLUT.tags = tags;
+     rslCHAMHandleLUT.nHandles += RSLHandleInc;
+     }
+   else
+     {
+#ifdef FATAL_ERRORS
+     fprintf (stderr, "Fatal Error: realloc failure in rslCHAMSaveWaitH\n");
+     exit(1);
+#endif
+     return;
+     }
+   }
+ /* Stash the handle */
+ rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].tag = tag;
+ rslCHAMHandleLUT.tags[rslCHAMHandleLUT.nUsed].Handle = *waitHandle;
+ rslCHAMHandleLUT.nUsed++;
+ }
+
+/******************************************************
+ * rslCHAMISend (buff, mlen, tag, dest)
+ *  Post a non blocking send an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslCHAMISend (buff, mlen, tag, dest)
+ char *buff;
+ int mlen;
+ int tag;
+ int dest;
+ {
+   CHAM_Request waitHandle;
+ 
+   PInsend(   tag,
+	      buff,
+	      mlen,
+	      dest,
+	      MSG_OTHER,
+              &waitHandle); 
+
+   rslCHAMSaveWaitH (tag, &waitHandle);
+ }
+ 
+/******************************************************
+ * rslCHAMIRecv (buff, mlen, tag)
+ *  Post a non blocking receive an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslCHAMIRecv (buff, mlen, tag)
+ char *buff;
+ int mlen;
+ int tag;
+ {
+   CHAM_Request waitHandle;
+
+   PInrecv   (tag,
+              buff,
+              mlen,
+              MSG_OTHER,
+              tag,
+              &waitHandle);
+
+   rslCHAMSaveWaitH (tag, waitHandle);
+ }
+
+/******************************************************
+ * rslCHAMWait (tag)
+ *  Wait for a pending send/recv
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslCHAMWait (tag, flag)
+ int tag, flag;
+ {
+ CHAM_Request waitHandle;
+ CHAM_Status status ;
+
+ rslCHAMFindWaitH (tag, &waitHandle );
+ if ( flag == 1 ) 		/* receive */
+   CHAM_Wait ( &waitHandle, &status  );
+ else				/* send */
+   CHAM_Wait ( &waitHandle, &status  );
+ }
+
+#endif /* __CHAM_COMPAT__ */
+#endif /* CHAM */
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_child_info.c b/wrfv2_fire/external/RSL/RSL/rsl_child_info.c
new file mode 100755
index 00000000..3491a087
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_child_info.c
@@ -0,0 +1,168 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* given a coarse domain point and nest index within it, return
+   its nest coords */
+RSL_CHILD_INFO ( d_p, n_p, ig_p, jg_p, cm_p, cn_p, ni_p, nj_p, nig_p, njg_p )
+  int_p d_p, n_p, ig_p, jg_p, cm_p, cn_p ;      /* input */ 
+  int_p ni_p, nj_p, nig_p, njg_p ; 				/* output */
+{
+  int d, nst ;
+  int kidid ;
+  rsl_domain_info_t *ninfo, *dinfo ;
+  rsl_point_t *ndomain, *ddomain ;
+  int ig, jg, cn, cm, mlen, nlen, irax_n, irax_m ;
+
+  d = *d_p ;
+  nst = *n_p ;
+  RSL_TEST_ERR( d < 0 || d > RSL_MAXDOMAINS,
+    "rsl_child_info: bad parent domain descriptor" ) ;
+  RSL_TEST_ERR( nst < 0 || nst > RSL_MAXDOMAINS,
+    "rsl_child_info: bad nested domain descriptor" ) ;
+  RSL_TEST_ERR( d == nst,
+    "rsl_child_info: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+    "rsl_child_info: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+    "rsl_child_info: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+    "rsl_child_info: invalid nested domain" ) ;
+  ddomain = dinfo->domain ;
+  ndomain = ninfo->domain ;
+
+  ig = *ig_p ;
+  jg = *jg_p ;
+  cn = *cn_p ;
+  cm = *cm_p ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  irax_n = dinfo->irax_n ;
+  irax_m = dinfo->irax_m ;
+
+  *nig_p = RSL_INVALID ;
+  *njg_p = RSL_INVALID ;
+  *ni_p = RSL_INVALID ;
+  *nj_p = RSL_INVALID ;
+
+  if ( ddomain[INDEX_2(jg,ig,mlen)].children_p != NULL )
+  {
+    kidid = ddomain[INDEX_2(jg,ig,mlen)].children_p->
+		    child[INDEX_2(cn,cm,irax_m)] ;
+    *nig_p = ID_IDEX(kidid) ;
+    *njg_p = ID_JDEX(kidid) ;
+    *ni_p = *nig_p + ninfo->idif ;
+    *nj_p = *njg_p + ninfo->jdif ;
+  }
+  return ;
+}
+
+/* given a nested domain pt, return its coarse domain coords and
+   position within the cd cell */
+RSL_CHILD_INFO1 ( d_p, n_p, nig_p, njg_p, cm_p, cn_p, i_p, j_p, ig_p, jg_p )
+  int_p d_p, n_p, nig_p, njg_p ; /* input */
+  int_p cm_p, cn_p, i_p, j_p, ig_p, jg_p ; /* output */
+{
+  int d, nst ;
+  int mid ;
+  rsl_domain_info_t *ninfo, *dinfo ;
+  rsl_point_t *ndomain, *ddomain ;
+  int nig, njg, cn, cm, mlen, nlen, irax_n, irax_m ;
+
+  d = *d_p ;
+  nst = *n_p ;
+  RSL_TEST_ERR( d < 0 || d > RSL_MAXDOMAINS,
+    "rsl_child_info1: bad parent domain descriptor" ) ;
+  RSL_TEST_ERR( nst < 0 || nst > RSL_MAXDOMAINS,
+    "rsl_child_info1: bad nested domain descriptor" ) ;
+  RSL_TEST_ERR( d == nst,
+    "rsl_child_info1: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+    "rsl_child_info1: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+    "rsl_child_info1: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+    "rsl_child_info1: invalid nested domain" ) ;
+  ddomain = dinfo->domain ;
+  ndomain = ninfo->domain ;
+
+  nig = *nig_p ;
+  njg = *njg_p ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  irax_n = dinfo->irax_n ;
+  irax_m = dinfo->irax_m ;
+
+  mid = ndomain[INDEX_2(njg,nig,mlen)].mother_id ;
+  *ig_p = ID_IDEX(mid) ;
+  *jg_p = ID_JDEX(mid) ;
+  *i_p = *ig_p + dinfo->idif ;
+  *j_p = *jg_p + dinfo->jdif ;
+  *cn_p = ndomain[INDEX_2(njg,nig,mlen)].which_kid_am_i_n ;
+  *cm_p = ndomain[INDEX_2(njg,nig,mlen)].which_kid_am_i_m ;
+
+  return ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_comm.h b/wrfv2_fire/external/RSL/RSL/rsl_comm.h
new file mode 100755
index 00000000..8fc4c80e
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_comm.h
@@ -0,0 +1,359 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef RSL_COMM_H
+#define RSL_COMM_H
+
+/* #define STUBS */
+
+/***********************************************************************
+Below is a mapping of the message passing macros that are used in RSL,
+the library package that supports the model (there is no explicit
+message passing in the model code itself -- all of that is encapsulated
+within RSL).
+
+# define RSL_OPEN0(A,B)          open0_( &(A), &(B), &rsl_idum )
+# define RSL_CLOSE0()            close0_()
+# define RSL_WHO(A,B)           who0_( &(A), &(B), &rsl_idum )
+# define RSL_RECV(A,B,C)        recv0_( A, &(B), &(C) )
+# define RSL_SEND(A,B,C,D)      send0_( A, &(B), &(C), &(D) )
+# define RSL_RECVBEGIN(A,B,C)   recvbegin0_( A, &(B), &(C) )
+# define RSL_SENDBEGIN(A,B,C,D) sendbegin0_( A, &(B), &(C), &(D) )
+# define RSL_RECVEND(A)         recvend0_( &(A) )
+# define RSL_SENDEND(A)         sendend0_( &(A) )
+# define RSL_PROBE(A,B)         rsl_probe_( &(A), B )
+
+In this particular fragment, the macros are defined to PICL calls, 
+but that is just incidental.
+
+RSL_OPEN0(A,B)
+RSL_CLOSE0()
+
+  This will map to whatever routine the underlying mp library requires
+  for startup and initialization/shutdown.  It can just be a noop if the
+  mp lib in use does not require initialization.  As far as RSL is concerned,
+  arguments A and B are dummys.
+
+RSL_WHO(A,B)
+
+  This will map to the informational routine in the mp library that
+  returns number of nodes in partition (returned as A) and the node
+  number of the local processor (returned as B).
+
+RSL_RECV(A,B,C)
+
+  This is the synchronous recv (like crecv in NX).  A is a pointer
+  to the buffer, B is the length in bytes, and C is the integer
+  message tag.
+
+RSL_SEND(A,B,C,D)
+
+  This is the synchronous send (like csend in NX).  A is a pointer
+  to the buffer, B is the length in bytes, and C is the integer
+  message tag.  D is the node number of the destination processor.
+
+RSL_RECVBEGIN(A,B,C)
+
+  This is the asynchronous version of RSL_RECV.  It records the message
+  descriptor returned by the OS, posts the receive and then returns
+  control to the calling program.  In NX is it implemented using
+  irecv.
+
+RSL_RECVEND(A)
+
+  This is the call the blocks until completion of the message started
+  with RSL_RECVBEGIN.  The argument, A, is the integer tag of the 
+  message (the third argument, C, of the original RSL_RECVBEGIN call).
+  Using the tag, the routine looks up the OS descriptor for the original
+  message and then issues the mp library call to block on that message
+  (in the case of NX, the routine called is msgwait).
+
+
+RSL_SENDBEGIN(A,B,C,D)
+ 
+  This is the asynchronous version of RSL_SEND.  It records the message
+  descriptor returned by the OS, posts the send and then returns
+  control to the calling program.  In NX is it implemented using
+  isend.
+  
+RSL_SENDEND(A)
+
+  This is the call the blocks until completion of the message started
+  with RSL_SENDBEGIN.  The argument, A, is the integer tag of the 
+  message (the third argument, C, of the original RSL_SENDBEGIN call).
+  Using the tag, the routine looks up the OS descriptor for the original
+  message and then issues the mp library call to block on that message
+  (in the case of NX, the routine called is msgwait).
+
+RSL_PROBE(A,B)
+
+  This maps to the mp library routine for checking on the status of
+  an asynchronously posted receive.  This is *not* currently in use
+  but may be needed at some point in the future.
+
+---
+
+John
+***********************************************************************/
+
+#ifdef STUBS
+
+# define RSL_OPEN0              {RSL_TEST_WRN(1,"COMMUNICATIONS STUBBED!");}
+# define RSL_CLOSE0()
+# define RSL_WHO(A,B)           { A = 1 ; B = 0 ; }
+# define RSL_RECV(A,B,C)
+# define RSL_SEND(A,B,C,D)
+# define RSL_RECVBEGIN(A,B,C)
+# define RSL_SENDBEGIN(A,B,C,D)
+# define RSL_RECVEND(A)
+# define RSL_SENDEND(A)
+# define RSL_PROBE(A,B)         { *(B) = 1 ; }
+
+#else
+#ifdef PGON
+
+# define RSL_OPEN0(A,B)         rslNXInit()
+# define RSL_CLOSE0
+# define RSL_WHO(A,B)           { A = numnodes(); B = mynode(); }
+# define RSL_RECV(A,B,C)        crecv ((long)(C),A,(long)(B))
+# define RSL_SEND(A,B,C,D)      csend ((long)(C),A,(long)(B),(long)(D),(long)0)
+# define RSL_RECVBEGIN(A,B,C)   rslNXIRecv ( A, B, C )
+# define RSL_SENDBEGIN(A,B,C,D) rslNXISend ( A, B, C, D )
+# define RSL_RECVEND(A)         rslNXWait ( A )
+# define RSL_SENDEND(A)         rslNXWait ( A )
+# define RSL_PROBE(A,B)         rslNXProbe ( A, B )
+/* # define RSL_PROBE(A,B)         (*(B) = (iprobe ( A ) == 1)) */
+
+#else
+#ifdef MPL
+/* map down to native MPL primitives of SP[12] */
+
+#    ifdef __MPL_COMPAT__
+       int rsl_mp_source ;
+       int rsl_mp_nbytes ;
+       int rsl_mp_n ;
+       int rsl_mp_type ;
+
+       int dontcare ;
+       int allmsg ;
+       int nulltask ;
+       int allgrp ;
+       int type_low ;
+       int type_high ;
+
+#    else
+       extern int rsl_mp_source ;
+       extern int rsl_mp_nbytes ;
+       extern int rsl_mp_type ;
+       extern int rsl_mp_n ;
+
+       extern int dontcare ;
+       extern int allmsg ;
+       extern int nulltask ;
+       extern int allgrp ;
+       extern int type_low ;
+       extern int type_high ;
+
+#    endif
+
+# define RSL_OPEN0(A,B)         rslMPLInit()
+# define RSL_CLOSE0()
+# define RSL_WHO(A,B)           mpc_environ( &(A), &(B) )
+
+# define RSL_RECV(A,B,C)  \
+  { int rc ; \
+    rsl_mp_source = dontcare ;\
+    rsl_mp_type   = C ;\
+    rsl_mp_n      = B ;\
+    if ( rsl_mp_type < type_low || rsl_mp_type > type_high )	\
+    { \
+      sprintf(mess,"RSL_RECV message type %d out of allowed range: %d..%d\n", \
+      rsl_mp_type,type_low,type_high) ; \
+      RSL_TEST_ERR( 1, mess ) ; \
+    } \
+    rc = mpc_brecv(A,rsl_mp_n,               \
+                   &rsl_mp_source,            \
+                   &rsl_mp_type,              \
+                   &rsl_mp_nbytes) ;  \
+    if ( rc ) {fprintf(stderr,"mpc_brecv returns %d\n",rc);exit(1);} \
+    if ( rsl_mp_nbytes > (B) ) 	\
+    {				\
+      fprintf(stderr,"Message too large: tag %d, recvd %d, allocated %d\n", \
+ 	      C,rsl_mp_nbytes,(B));	\
+    }  \
+  }
+
+# define RSL_SEND(A,B,C,D)       \
+  { \
+    int rc ; \
+    rsl_mp_type = C ; \
+    if ( rsl_mp_type < type_low || rsl_mp_type > type_high )	\
+    { \
+      sprintf(mess,"RSL_SEND message type %d out of allowed range: %d..%d\n", \
+      rsl_mp_type,type_low,type_high) ; \
+      RSL_TEST_ERR( 1, mess ) ; \
+    } \
+    if (0) fprintf(stderr,"mpc_bsend: nlen %10d  type %10d  dest %10d\n", \
+                   B, rsl_mp_type, D ) ; \
+    rc = mpc_bsend(A,B,D,C) ; \
+    if ( rc ) {fprintf(stderr,"mpc_bsend returns %d\n",rc);exit(1);} \
+  }
+
+# define RSL_RECVBEGIN(A,B,C)   rslMPLIRecv ( A, B, C )
+# define RSL_SENDBEGIN(A,B,C,D) rslMPLISend ( A, B, C, D )
+# define RSL_RECVEND(A)         rslMPLWait ( A )
+# define RSL_SENDEND(A)         rslMPLWait ( A )
+# define RSL_PROBE(A,B)         rslMPLProbe( A, B )
+
+#else
+#ifdef MPI
+
+#    include "mpi.h"
+/* EXTERN is defined in rsl.h */
+
+EXTERN MPI_Comm rsl_mpi_communicator ;
+
+#    ifdef __MPI_COMPAT__
+       MPI_Status mpi_status ;
+#    else
+       extern MPI_Status mpi_status ;
+#    endif
+
+# define RSL_OPEN0(A,B)         rslMPIInit() 
+# define RSL_CLOSE0()           MPI_Finalize()
+# define RSL_WHO(A,B)           rslMPIWho( &(A), &(B) )
+
+# define RSL_RECV(A,B,C)  \
+{ \
+MPI_Recv(A,B,MPI_BYTE,MPI_ANY_SOURCE,C,rsl_mpi_communicator,&mpi_status) ; \
+}
+
+# define RSL_SEND(A,B,C,D)      MPI_Send(A,B,MPI_BYTE,D,C,rsl_mpi_communicator)
+# define RSL_RECVBEGIN(A,B,C)   rslMPIIRecv ( A, B, C )
+# define RSL_SENDBEGIN(A,B,C,D) rslMPIISend ( A, B, C, D )
+# define RSL_RECVEND(A)         rslMPIWait ( A )
+# define RSL_SENDEND(A)         rslMPIWait ( A )
+# define RSL_PROBE(A,B)         /* rslMPITest ( A, B ) */
+
+#else
+#ifdef CHAMELEON
+
+#include "tools.h" 
+#include "comm/comm.h"
+
+#   define RSL_OPEN0(A,B)         rslCHAMInit()
+#   define RSL_CLOSE0
+#   define RSL_WHO(A,B)           who0_( &(A), &(B), &rsl_idum )
+#   define RSL_RECV(A,B,C)        PIbrecv( C, A, B, MSG_OTHER )
+#   define RSL_SEND(A,B,C,D)      PIbsend( C, A, B, D, MSG_OTHER )
+#   define RSL_RECVBEGIN(A,B,C)   rslCHAMRecv( A, B, C )
+#   define RSL_SENDBEGIN(A,B,C,D) rslCHAMSend( A, B, C, D )
+#   define RSL_RECVEND(A)         rslCHAMWait( A, 1 )
+#   define RSL_SENDEND(A)         rslCHAMWait( A, 0 )
+#   define RSL_PROBE(A,B)         ( &(A), B )
+
+
+else
+
+# ifndef NOUNDERSCORE
+
+#   ifdef CHAMELEON_PICL
+#     define RSL_OPEN0(A,B)    /* a noop */
+#   else
+#     define RSL_OPEN0(A,B)        open0_( &(A), &(B), &rsl_idum )
+#   endif
+#   define RSL_CLOSE0
+#   define RSL_WHO(A,B)           who0_( &(A), &(B), &rsl_idum )
+#   define RSL_RECV(A,B,C)        recv0_( A, &(B), &(C) )
+#   define RSL_SEND(A,B,C,D)      send0_( A, &(B), &(C), &(D) )
+#   define RSL_RECVBEGIN(A,B,C)   recvbegin0_( A, &(B), &(C) )
+#   define RSL_SENDBEGIN(A,B,C,D) sendbegin0_( A, &(B), &(C), &(D) )
+#   define RSL_RECVEND(A)         recvend0_( &(A) )
+#   define RSL_SENDEND(A)         sendend0_( &(A) )
+#   define RSL_PROBE(A,B)         rsl_probe_( &(A), B )
+
+
+# else
+
+#   ifdef CHAMELEON_PICL_ooo
+#     define RSL_OPEN0(A,B)    /* a noop */
+#   else
+#     define RSL_OPEN0(A,B)        open0( &(A), &(B), &rsl_idum )
+#   endif
+#   define RSL_CLOSE0
+#   define RSL_WHO(A,B)           who0( &(A), &(B), &rsl_idum )
+#   define RSL_RECV(A,B,C)        recv0( A, &(B), &(C) )
+#   define RSL_SEND(A,B,C,D)      send0( A, &(B), &(C), &(D) )
+#   define RSL_RECVBEGIN(A,B,C)   recvbegin0( A, &(B), &(C) )
+#   define RSL_SENDBEGIN(A,B,C,D) sendbegin0( A, &(B), &(C), &(D) )
+#   define RSL_RECVEND(A)         recvend0( &(A) )
+#   define RSL_SENDEND(A)         sendend0( &(A) )
+#   define RSL_PROBE(A,B)         rsl_probe( &(A), B )
+
+# endif  /* NOUNDERSCORE */
+
+#endif  /* CHAMELEON */
+#endif  /* MPI */
+#endif  /* MPL */
+#endif  /* PGON */
+#endif  /* STUBS */
+
+
+
+#endif  /* nothing after this line */
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_debug.c b/wrfv2_fire/external/RSL/RSL/rsl_debug.c
new file mode 100755
index 00000000..3c8dfe9e
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_debug.c
@@ -0,0 +1,69 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+RSL_DEBUG ( setget, flg )
+  int *setget, *flg ;
+{
+  if ( *setget == 1 )
+    rsl_debug_flg = *flg ;
+  else
+    *flg = rsl_debug_flg ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_error_dup.c b/wrfv2_fire/external/RSL/RSL/rsl_error_dup.c
new file mode 100755
index 00000000..78db8478
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_error_dup.c
@@ -0,0 +1,169 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/* redirect standard error from process into a file */
+/* also redirect standard output to a file */
+
+#include 
+#ifdef SEQUENT
+#include 
+#else
+#include 
+#endif
+
+#include "rsl.h"
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+/*@
+  RSL_ERROR_DUP --- Redirect standard out and error on each proc.
+
+  Notes:
+  This routine redirects the standard and error outputs to a 
+  unique pair of files for each processor.  The file names generated
+  are rsl.out.dddd and rsl.error.dddd, where dddd is the 4-digit
+  zero-padded processor number.  RSL\_INITIALIZE must be called before
+  this routine.
+
+  See also:
+  RSL\_INITIALIZE, RSL\_MESH
+@*/
+
+RSL_ERROR_DUP () 
+{
+    int newfd ;
+    char filename[256] ;
+
+    int *me ;
+
+    me = &rsl_myproc ;
+
+/* redirect standard out*/
+    sprintf(filename,"rsl.out.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+	perror("error_dup: cannot open rsl.out.nnnn") ;
+	fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+	return ;
+    }
+    if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
+    {
+	perror("error_dup: dup2 fails to change output descriptor") ;
+	fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+	close(newfd) ;
+	return ;
+    }
+
+/* redirect standard error */
+    sprintf(filename,"rsl.error.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+	perror("error_dup: cannot open rsl.error.log") ;
+	fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+	return ;
+    }
+    if( dup2( newfd, STANDARD_ERROR ) < 0 )
+    {
+	perror("error_dup: dup2 fails to change error descriptor") ;
+	fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+	close(newfd) ;
+	return ;
+    }
+
+}
+
+RSL_ERROR_DUP1 ( int *me )
+{
+    int newfd ;
+    char filename[256] ;
+
+/* redirect standard out*/
+    sprintf(filename,"rsl.out.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+        perror("error_dup: cannot open rsl.out.nnnn") ;
+        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+        return ;
+    }
+    if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
+    {
+        perror("error_dup: dup2 fails to change output descriptor") ;
+        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+        close(newfd) ;
+        return ;
+    }
+
+/* redirect standard error */
+    sprintf(filename,"rsl.error.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+        perror("error_dup: cannot open rsl.error.log") ;
+        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+        return ;
+    }
+    if( dup2( newfd, STANDARD_ERROR ) < 0 )
+    {
+        perror("error_dup: dup2 fails to change error descriptor") ;
+        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+        close(newfd) ;
+        return ;
+    }
+
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_fclose_f.F b/wrfv2_fire/external/RSL/RSL/rsl_fclose_f.F
new file mode 100755
index 00000000..3025f178
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_fclose_f.F
@@ -0,0 +1,71 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine rsl_uclose( unit )
+      implicit none
+      integer unit, result
+
+      call rsl_c_iammonitor( result )
+      if ( result .ne. 1 ) then
+	return
+      endif
+c only execute on monitor
+      close( unit )
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_fopen_f.F b/wrfv2_fire/external/RSL/RSL/rsl_fopen_f.F
new file mode 100755
index 00000000..8314d10f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_fopen_f.F
@@ -0,0 +1,75 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_uopen( unit, name, stat )
+      implicit none
+      integer unit, result
+      character*(*) name, stat
+
+      call rsl_c_iammonitor( result )
+      if ( result .ne. 1 ) then
+	return
+      endif
+c only execute on monitor
+      open( unit, file=name, form="unformatted", status=stat,
+     +      access="sequential",iostat=result, err=99 )
+      return
+  99  continue
+      write(0,*)'rsl_open_uread: error opening ',name,' iostat=',result
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_funit_close.F b/wrfv2_fire/external/RSL/RSL/rsl_funit_close.F
new file mode 100755
index 00000000..dcb22d1d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_funit_close.F
@@ -0,0 +1,64 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+
+      subroutine rsl_funit_close( unit )
+      implicit none
+      integer unit
+      close( unit )
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_hemiforce.c b/wrfv2_fire/external/RSL/RSL/rsl_hemiforce.c
new file mode 100644
index 00000000..b9ea57d7
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_hemiforce.c
@@ -0,0 +1,538 @@
+#define KLUDGE_20000821
+
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_TO_OH_INFO -- Get the next cell in a packing sequence for forcing.
+
+  Notes:
+
+  See also:
+
+@*/
+
+static rsl_domain_info_t *s_tinfo, *s_oinfo ;
+static int s_oig, s_ojg ;
+static int s_p, s_t, s_o ;
+static int s_msize ;
+static struct rsl_hemi_rec * s_q, * s_q1 ;
+static int s_nlen_o ;
+static int s_mlen_o ;
+static rsl_point_t *s_tdomain, *s_odomain ;
+static char * s_pointbuf = NULL ;
+
+RSL_TO_OH_INFO ( t_p, o_p, msize_p, seed_p,
+                 oig_p, ojg_p, retval_p )
+  int_p
+     t_p            /* (I) RSL domain descriptor of this hemi. */
+    ,o_p            /* (I) RSL domain descriptor of other hemi. */
+    ,msize_p        /* (I) Message size in bytes. */
+    ,seed_p         /* (I) =1 start the traversal; =0 (zero) continue traversal */
+    ,oig_p          /* (O) Global M index of other domain point. */
+    ,ojg_p          /* (O) Global N index of other domain point. */
+    ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
+{
+  int kiddex ;
+  int P ;
+  rsl_hemi_rec_t * q ;
+#ifdef KLUDGE_20000821
+  rsl_hemi_rec_t * qnuke ;
+  rsl_hemi_rec_t * prev ;
+#endif
+  int p, p1 ;
+  int globalhemiPlist[RSL_MAXPROC][RSL_MAXPROC], work[RSL_MAXPROC][RSL_MAXPROC] ;
+
+#ifndef STUBS
+  s_msize = *msize_p ;
+  s_t = *t_p ;
+  s_o = *o_p ;
+  RSL_TEST_ERR( s_t < 0 || s_t > RSL_MAXDOMAINS,
+    "rsl_ready_bcast: bad 'this hemi' descriptor" ) ;
+  RSL_TEST_ERR( s_o < 0 || s_o > RSL_MAXDOMAINS,
+    "rsl_ready_bcast: bad 'other hemi' descriptor" ) ;
+  RSL_TEST_ERR( s_t == s_o,
+    "rsl_ready_bcast: hemispere cannot force itself" ) ;
+
+  s_tinfo = &( domain_info[s_t]) ;
+  s_oinfo = &( domain_info[s_o]) ;
+  s_mlen_o = s_oinfo->len_m ;
+  s_nlen_o = s_oinfo->len_n ;
+  s_odomain = s_oinfo->domain ;
+
+  if ( ! s_tinfo->other_hemi_proclist_built )
+  {
+    if ( *seed_p )
+    {
+      s_oig = 0 ; s_ojg = 0 ;
+      for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+      {
+#ifdef KLUDGE_20000821
+        for ( q = s_tinfo->other_hemi_procbufs[p], prev = NULL ; q ; )
+        {
+           if ( q->data ) RSL_FREE( q->data ) ;
+           qnuke = q ;
+           q = q->next ;
+           RSL_FREE( qnuke ) ;
+        }
+#endif
+	s_tinfo->other_hemi_procbufs[p] = NULL ;
+	s_tinfo->hemi_sendPlist[p] = 0 ;
+        for ( p1 = 0 ; p1 < RSL_MAXPROC ; p1++ )
+	{
+	  globalhemiPlist[p][p1] = 0 ;
+	}
+      }
+    }
+    else
+    {
+      s_oig++ ;
+      if ( s_oig >= s_oinfo->len_m )
+      {
+        s_oig = 0 ;
+        s_ojg++ ;
+        if ( s_ojg >= s_oinfo->len_n )
+        {
+	  *retval_p = 0 ;
+#ifndef KLUDGE_20000821
+	  s_tinfo->other_hemi_proclist_built = 1 ; /* FIX 20000818 JM */
+ #endif
+
+/* collapse the list and keep only entries that have data associated */
+/* also fill entries for processors I must send to, indicating the number 
+   of columns that go to each processors, or zero for processors I don't
+   send to */
+          for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+	  {
+	    rsl_hemi_rec_t * prev ;
+	    for ( q = s_tinfo->other_hemi_procbufs[p], prev = NULL ; q ; )
+	    {
+	      if ( q->data == NULL )
+	      {
+		if ( prev == NULL )
+		{
+		  s_tinfo->other_hemi_procbufs[p] = q->next ;
+		  RSL_FREE(q) ;
+		  q = s_tinfo->other_hemi_procbufs[p] ;
+		}
+		else if ( prev->next == q )
+		{
+		  prev->next = q->next ;
+		  RSL_FREE(q) ;
+		  q = prev->next ;
+		}
+		else
+		  RSL_TEST_ERR(1,"internal error") ;
+	      }
+	      else
+	      {
+		s_tinfo->hemi_sendPlist[p]++ ;
+		prev = q ;
+		q = q->next ;
+	      }
+	    }
+	  }
+
+	  /* mpi all to all communication to share matrix of senders/receivers */
+	  MPI_Gather( s_tinfo->hemi_sendPlist, RSL_MAXPROC, MPI_INT,
+                      globalhemiPlist, RSL_MAXPROC, MPI_INT, 
+                      0, rsl_mpi_communicator ) ;
+	  /* transpose */
+	  for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+	    for ( p1 = 0 ; p1 < RSL_MAXPROC ; p1++ )
+	      work[p][p1] = globalhemiPlist[p1][p] ;
+	  for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+	    for ( p1 = 0 ; p1 < RSL_MAXPROC ; p1++ )
+	      globalhemiPlist[p][p1] = work[p][p1] ;
+	  MPI_Scatter( globalhemiPlist, RSL_MAXPROC, MPI_INT, 
+                       s_tinfo->hemi_recvPlist, RSL_MAXPROC, MPI_INT,
+                       0, rsl_mpi_communicator ) ;
+
+	  return ;       /* EARLY RETURN */
+        }
+      }
+    }
+    kiddex = INDEX_2(s_ojg,s_oig,s_mlen_o) ;
+    P = s_odomain[ kiddex ].P ;
+    if ( s_tinfo->other_hemi_procbufs[P] == NULL )
+    {
+      q = RSL_MALLOC( rsl_hemi_rec_t, 1 ) ;
+    }
+    else
+    {
+      q = RSL_MALLOC( rsl_hemi_rec_t, 1 ) ;
+      q->next = s_tinfo->other_hemi_procbufs[P] ;
+    }
+    q->oig = s_oig ;
+    q->ojg = s_ojg ;
+    q->data = NULL ;
+    s_tinfo->other_hemi_procbufs[P] = q ;
+    s_q1 = q ;
+  }
+  else
+  {
+    int * x ;
+    if ( *seed_p )
+    {
+      s_p = -1 ;
+      s_q = NULL ;
+    }
+    if ( s_q == NULL )
+    {
+      s_p++ ;
+      while ( s_tinfo->other_hemi_procbufs[s_p] == NULL ) s_p++ ;
+      if ( s_p >= rsl_nproc_all )
+      {
+	*retval_p = 0 ;
+	return ;       /* EARLY RETURN */
+      }
+      s_q = s_tinfo->other_hemi_procbufs[s_p] ;
+    }
+    s_oig = s_q->oig ;
+    s_ojg = s_q->ojg ;
+    s_q1 = s_q ;
+    s_q = s_q->next ;
+  }
+  *oig_p = s_oig + 1 ;  /* C to Fortran */
+  *ojg_p = s_ojg + 1 ;  /* C to Fortran */
+  *retval_p = 1 ;
+#else
+   RSL_TEST_ERR( 1, "RSL_TO_OH_INFO STUBBED" ) ;
+#endif
+  return ;
+}
+
+/*@
+  RSL_TO_OH_MSG -- Pack force data into a message for a nest point.
+
+  Notes:
+  See also:
+
+@*/
+
+RSL_TO_OH_MSG ( nbuf_p, buf )
+  int_p
+    nbuf_p ;     /* (I) Number of bytes to be packed. */
+  char *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+{
+  int kiddex ;
+  int nbuf ;
+  int P ;
+
+  RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
+  nbuf = *nbuf_p ;
+  if ( s_q1->data == NULL )
+  {
+    s_q1->data = RSL_MALLOC( char, s_msize ) ;
+    s_q1->curs = 0 ;
+  }
+  if ( s_q1->curs+nbuf >= s_msize )
+  {
+    sprintf(mess,"RSL_TO_OH_MSG: store of %d bytes would overflow %d sized buffer.\n",nbuf,s_msize ) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+  bcopy( buf, &(s_q1->data[s_q1->curs]), nbuf ) ;
+  s_q1->curs += nbuf ;
+}
+
+/*@
+  RSL_FORCE_HEMI -- Convey forcing data from this hemi to other hemi
+
+  Notes:
+
+  See also:
+@*/
+
+RSL_FORCE_HEMI ()
+{
+  int P ;
+  int msglen, mdest, mtag ;
+  int ii ;
+  int ig, jg ;
+  char * recvbuf, * sendbuf ;
+  rsl_hemi_rec_t * q ;
+
+  /* post receives */
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    if ( s_tinfo->hemi_recvPlist[P] > 0 )
+    {
+      msglen = s_msize * s_tinfo->hemi_recvPlist[P] + 3*sizeof(int) ;
+      recvbuf = buffer_for_proc( P, msglen,  RSL_RECVBUF ) ;
+      mtag = MTYPE_FROMTO( MSG_FROM_PARENT, P, rsl_myproc ) ;
+#ifdef DEBUGGAL
+fprintf(stderr,"Posting receive on tag %d\n",mtag ) ;
+#endif
+      RSL_RECVBEGIN( recvbuf, msglen, mtag ) ;
+      s_tinfo->hemi_recv_tags[P] = mtag ; /* store tag */
+    }
+  }
+
+  /* do sends */
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+#ifdef DEBUGGAL
+fprintf(stderr,"s_tinfo->hemi_sendPlist[P] %d\n",s_tinfo->hemi_sendPlist[P]) ;
+#endif
+    if ( s_tinfo->hemi_sendPlist[P] > 0 )
+    {
+      int curs ;
+      int endofdata ;
+	  
+	  /* oig,ojg,nbytes,buffer * # of points + end of data */
+      msglen = (3*sizeof(int)+s_msize)*s_tinfo->hemi_sendPlist[P]+1*sizeof(int) ;
+      sendbuf = buffer_for_proc( P, msglen,  RSL_SENDBUF ) ;
+      curs = 0 ;
+      for ( q = s_tinfo->other_hemi_procbufs[P] ; q ; q = q->next )
+      {
+#ifdef DEBUGGAL
+{
+int *dp ;
+dp = (int *) q->data ;
+fprintf(stderr,"> curs %d, msglen %d msize %d (%d %d) data %d\n", curs, msglen, s_msize, q->oig, q->ojg, *dp ) ;
+}
+#endif
+        bcopy( &(q->oig), &(sendbuf[curs]), sizeof(int)) ; curs += sizeof(int) ;
+        bcopy( &(q->ojg), &(sendbuf[curs]), sizeof(int)) ; curs += sizeof(int) ;
+        bcopy( &(q->curs), &(sendbuf[curs]), sizeof(int)) ; curs += sizeof(int) ;
+        bcopy( q->data, &(sendbuf[curs]), q->curs) ; curs += q->curs ;
+      }
+      endofdata = RSL_INVALID ;
+      bcopy( &endofdata, &(sendbuf[curs]), sizeof(int)) ; curs += sizeof(int) ;
+      mtag = MTYPE_FROMTO( MSG_FROM_PARENT, rsl_myproc, P ) ;
+#ifdef DEBUGGAL
+fprintf(stderr,"sending sendbuf to %d, curs = %d\n",P,curs) ;
+#endif
+      RSL_SEND( sendbuf, curs, mtag, P ) ;
+    }
+  }
+}
+
+/*@
+  RSL_FROM_TH_INFO -- Get the next cell in a unpacking sequence for forcing.
+
+  Notes:
+
+  See also:
+@*/
+
+static int s_endofdata, s_remaining, s_ndata, s_curs ;
+static char * s_recvbuf ;
+
+RSL_FROM_TH_INFO ( seed_p, oig_p, ojg_p, retval_p )
+  int_p
+    seed_p      /* (I) =1 if first call; =0 otherwise */
+   ,oig_p        /* (O) Global index in M dimension of nest. */
+   ,ojg_p        /* (O) Global index in N dimension of nest. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  int mtag ;
+
+#ifdef DEBUGGAL
+fprintf(stderr,"RSL_FROM_TH_INFO seed = %d, s_endofdata %d\n",*seed_p,s_endofdata) ;
+#endif
+
+  if ( *seed_p == 1 )
+  {
+    if ( s_pointbuf != NULL ) RSL_FREE(s_pointbuf) ;
+    s_pointbuf = RSL_MALLOC( char, 2*s_msize ) ;  /* 2 times for safety */
+    s_p = 0 ;
+    s_endofdata = 1 ;
+  }
+
+nextproc:
+  if ( s_endofdata )
+  {
+    while ( s_tinfo->hemi_recvPlist[s_p] <= 0 ) s_p++ ;
+    if ( s_p >= rsl_nproc_all )
+    {
+      *retval_p = 0 ;
+#ifdef DEBUGGAL
+fprintf(stderr,"EARLY RETURN retval = 0\n") ;
+#endif
+      return ;          /* EARLY RETURN */
+    }
+    mtag = s_tinfo->hemi_recv_tags[s_p] ;
+#ifdef DEBUGGAL
+fprintf(stderr,"Waiting for receive on tag %d\n",mtag ) ;
+#endif
+    RSL_RECVEND ( mtag ) ;
+#ifdef DEBUGGAL
+fprintf(stderr,"got receive\n") ;
+#endif
+    s_recvbuf = buffer_for_proc( s_p, 0, RSL_RECVBUF ) ;
+    s_p++ ;
+    s_curs = 0 ;
+    s_endofdata = 0 ;
+  }
+
+#ifdef DEBUGGAL
+fprintf(stderr,"before bcopy  %d, s_recvbuf %08x\n",s_curs, s_recvbuf) ;
+#endif
+
+  bcopy ( &(s_recvbuf[s_curs]), oig_p, sizeof(int) ) ; s_curs += sizeof(int) ;
+  if ( *oig_p == RSL_INVALID )
+  {
+#ifdef DEBUGGAL
+fprintf(stderr,"hit end of data for s_p %d, %d\n", s_p, *oig_p ) ;
+#endif
+    s_endofdata = 1 ;
+    goto nextproc ;
+  }
+  bcopy ( &(s_recvbuf[s_curs]), ojg_p, sizeof(int) ) ; s_curs += sizeof(int) ;
+  bcopy ( &(s_recvbuf[s_curs]), &s_ndata, sizeof(int) ) ; s_curs += sizeof(int) ;
+  bcopy ( &(s_recvbuf[s_curs]), s_pointbuf, s_ndata ) ; s_curs += s_ndata ;
+  s_remaining = s_ndata ;
+#ifdef DEBUGGAL
+fprintf(stderr,"s_remaining = %d\n",s_remaining) ;
+#endif
+
+  (*oig_p) ++ ;
+  (*ojg_p) ++ ;
+#ifdef DEBUGGAL
+fprintf(stderr,"RETURN oig ojg %d %d\n", *oig_p, *ojg_p ) ;
+#endif
+  *retval_p = 1 ;
+  return ;
+}
+
+/*@
+  RSL_FROM_TH_MSG -- Unpack feedback data into a nest point.
+
+  Notes:
+
+@*/
+RSL_FROM_TH_MSG ( len_p, buf )
+  int_p
+    len_p ;          /* (I) Number of bytes to unpack. */
+  char *
+    buf ;            /* (O) Destination buffer. */
+{
+  if ( *len_p <= 0 ) return ;
+  if ( *len_p > s_remaining ) 
+  {
+    sprintf(mess,
+"RSL_FROM_TH_MSG:\n   Requested number of bytes (%d) exceeds %d, the number remaining for this point.\n", *len_p, s_remaining) ;
+    RSL_TEST_WRN(1,mess) ;
+  }
+  bcopy( &(s_pointbuf[s_ndata-s_remaining]),
+         buf,
+         *len_p ) ;
+
+  s_remaining -= *len_p ;
+}
+
+/* retval =1 if point is local, =0 otherwise */
+RSL_POINT_ON_PROC ( d_p, ig_p, jg_p, retval_p )
+  int_p d_p, ig_p, jg_p, retval_p ;
+{
+  int d ;
+  int kiddex ;
+  int P ;
+  int ig, jg ;
+
+  rsl_domain_info_t * info ;
+  rsl_point_t       * domain ;
+  ig = *ig_p - 1 ;
+  jg = *jg_p - 1 ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d > RSL_MAXDOMAINS,
+    "rsl_ready_bcast: bad 'this hemi' descriptor" ) ;
+  info = &( domain_info[d]) ;
+/* added 12/27/01 -- JM */
+  if ( ig < 0 || ig >= info->len_m ||
+       jg < 0 || jg >= info->len_n ) { *retval_p = 0 ; return ; }
+  domain = info->domain ;
+  kiddex = INDEX_2(jg,ig,info->len_m ) ;
+  P = domain[ kiddex ].P ;
+  *retval_p = 0 ;
+  if ( P == rsl_myproc ) *retval_p = 1 ;
+  return ;
+}
+
+/* given a global point, return the processor number */
+RSL_PROC_FOR_POINT ( d_p, ig_p, jg_p, retval_p )
+  int_p d_p, ig_p, jg_p, retval_p ;
+{
+  int d ;
+  int kiddex ;
+  int P ;
+  int ig, jg ;
+
+  rsl_domain_info_t * info ;
+  rsl_point_t       * domain ;
+  ig = *ig_p - 1 ;
+  jg = *jg_p - 1 ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d > RSL_MAXDOMAINS,
+    "rsl_point_on_proc: bad descriptor" ) ;
+  info = &( domain_info[d]) ;
+  domain = info->domain ;
+  kiddex = INDEX_2(jg,ig,info->len_m ) ;
+  *retval_p = domain[ kiddex ].P ;
+  return ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_init_f.F b/wrfv2_fire/external/RSL/RSL/rsl_init_f.F
new file mode 100755
index 00000000..06e40caf
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_init_f.F
@@ -0,0 +1,70 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_init_fortran ( nproc_all, nproc, myproc,
+     $              nproc_min, nproc_maj, ndom )
+      include 'rsl.inc'
+
+      rsl_nproc_all = nproc_all
+      rsl_nproc     = nproc
+      rsl_myproc    = myproc
+      rsl_nproc_min = nproc_min
+      rsl_nproc_maj = nproc_maj
+      rsl_ndomains  = ndom
+
+      return
+      end
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_initial.c b/wrfv2_fire/external/RSL/RSL/rsl_initial.c
new file mode 100755
index 00000000..99e63f58
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_initial.c
@@ -0,0 +1,359 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#undef AP1000
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_INITIALIZE - initialize the RSL package.
+
+  Notes:
+  This routine initializes the RSL package and must be called on each
+  processor before any other RSL routine.  Once RSL_INITIALIZE is called,
+  RSL_MON_BCAST and several other low-level informational RSL routines 
+  (e.g. RSL_IAMMONITOR)
+  may be used to broadcast configuration data read in on
+  processor zero to other processors.  Other RSL routines may not be
+  used until RSL_MESH has been called.
+
+  Example:
+
+$  program model
+$  integer intsize                     ! Size in bytes of an integer.
+$  parameter (intsize = 4)
+$  integer nproc_m, nproc_n            ! Number of processors in m, n.
+$  integer retval
+$  namelist /config/ nproc_m, nproc_n  ! Will be read in from namelist.
+
+$  call RSL_INITIALIZE                 ! Initialize RSL
+$  call RSL_IAMMONITOR( retval )       ! Read namelist on processor zero
+$  if ( retval .eq. 1 ) then
+$    read(10,config)
+$  endif
+$  call RSL_MON_BCAST( nproc_m, intsize )   ! Broadcast config to other procs.
+$  call RSL_MON_BCAST( nproc_n, intsize )   ! Broadcast config to other procs.
+$  call RSL_MESH( nproc_m, nproc_n )   ! All processors define processor mesh.
+$  ...                                 ! Rest of model.
+$  call RSL_SHUTDOWN                   ! Shutdown.
+$  stop
+$  end
+  
+BREAKTHEEXAMPLECODE
+
+  See also:
+  RSL_SHUTDOWN, RSL_MESH, RSL_MON_BCAST
+
+@*/
+RSL_INITIALIZE ()
+{
+  int s, o ;
+#ifndef STUBS
+  rslMPIInit() ;
+  rsl_mpi_communicator = MPI_COMM_WORLD ;
+#endif
+  rsl_initialize_internal() ;
+  s = 1 ; o = 0 ;
+  RSL_DEBUG( &s , &o ) ;
+  
+}
+
+#ifndef STUBS
+RSL_INITIALIZE1 ( MPI_Fint * comm )
+{
+  rsl_mpi_communicator = MPI_Comm_f2c( *comm ) ;
+  rsl_initialize_internal() ;
+}
+#else
+RSL_INITIALIZE1 ( int * comm )
+{
+  rsl_initialize_internal() ;
+}
+#endif
+
+rsl_initialize_internal()
+{
+  char name[256] ;
+  int d ;
+  int i ;
+  int rsl_default_decomp() ;		/* defined in cd.c */
+
+  for ( d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    domain_info[d].valid = RSL_INVALID ;
+  }
+  for ( i = 0 ; i < RSL_MAXDESCRIPTORS ; i++ ) mh_descriptors[i] = NULL ;
+  for ( i = 0 ; i < RSL_MAXDESCRIPTORS ; i++ ) sh_descriptors[i] = NULL ;
+  for ( i = 0 ; i < RSL_MAXDESCRIPTORS ; i++ ) xp_descriptors[i] = NULL ;
+  for ( i = 0 ; i < RSL_MAXDESCRIPTORS ; i++ ) pr_descriptors[i] = NULL ;
+  mh_descriptors[0] = (void*)1 ;  /* leave 0th one alone -- never use.
+				   this means that a message handle of
+				   zero is always an error */
+  rsl_ndomains = 0 ;
+  old_offsets = 0 ;
+
+#ifndef STUBS
+  rslMPIInit() ;
+
+  MPI_Comm_size( rsl_mpi_communicator , &rsl_nproc_all ) ;
+  MPI_Comm_rank( rsl_mpi_communicator , &rsl_myproc ) ;
+#else
+  rsl_nproc_all = 1 ;
+  rsl_myproc = 0 ;
+#endif
+
+/* John's patented brain substitute ; 5/3/2002 */
+  if ( rsl_nproc_all > RSL_MAXPROC )
+  {
+    sprintf(mess,"rsl_nproc_all (%d) > RSL_MAXPROC (%d). Recompile RSL with larger value.\n%s\n",rsl_nproc_all,RSL_MAXPROC,
+                 "(For WRF, change value of MAX_PROC in configure.wrf)"
+    ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+
+  rsl_nproc = rsl_nproc_all ; 	/* this may be reset by RSL_MESH */
+  rsl_padarea = RSL_DEFAULT_PADAREA ;
+  io_seq_monitor = 0 ;  /* OBS */
+  io_seq_compute = 1 ;  /* OBS */
+
+  regular_decomp = 0 ;
+  sw_allow_dynpad = 0 ;
+
+
+
+  RSL_INIT_FORTRAN ( &rsl_nproc_all, &rsl_nproc, &rsl_myproc,
+                     &rsl_nproc_m, &rsl_nproc_n, &rsl_ndomains ) ;
+
+#ifndef T3D
+  gethostname(name,255) ;
+  fprintf(stderr,"%s -- rsl_nproc_all %d, rsl_myproc %d\n",name,
+                  rsl_nproc_all, rsl_myproc ) ;
+#endif
+
+  RSL_F_SET_PADAREA ( &rsl_padarea ) ;
+
+  rsl_noprobe = (char *)getenv( "RSL_NOPROBE" ) ;
+  if ( rsl_noprobe != NULL && rsl_myproc == 0 )
+  {
+    if ( rsl_myproc == 0 ) 
+      fprintf(stderr,"Advisory: RSL_NOPROBE defined.  Won't probe.\n") ;
+  }
+
+  for (  d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    domain_info[d].valid = RSL_INVALID ;
+    domain_info[d].iruns = NULL ;
+    domain_info[d].domain = NULL ;
+    domain_info[d].bcast_Xlist = NULL ;
+    domain_info[d].merge_Xlist = NULL ;
+    { int p ;
+      for ( p = 0 ; p < MAX_KINDPAD ; p++ )
+      {
+        domain_info[d].js[p] = NULL ;
+        domain_info[d].is[p] = NULL ;
+        domain_info[d].ie[p] = NULL ;
+        domain_info[d].jg2n[p] = NULL ;
+        domain_info[d].is2[p] = NULL ;
+        domain_info[d].js2[p] = NULL ;
+        domain_info[d].je2[p] = NULL ;
+        domain_info[d].ig2n[p] = NULL ;
+      }
+    }
+    domain_info[d].is_write = RSL_INVALID ;
+    domain_info[d].ie_write = RSL_INVALID ;
+    domain_info[d].js_write = RSL_INVALID ;
+    domain_info[d].je_write = RSL_INVALID ;
+    domain_info[d].is_read = RSL_INVALID ;
+    domain_info[d].ie_read = RSL_INVALID ;
+    domain_info[d].js_read = RSL_INVALID ;
+    domain_info[d].je_read = RSL_INVALID ;
+
+  }
+
+  /* set up default decomposition fuctions */
+  SET_DEF_DECOMP_FCN ( rsl_default_decomp ) ;  /* defined in cd.c */
+  for (  d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    SET_DEF_DECOMP_INFO ( &d, NULL ) ;
+  }
+}
+
+/*@
+  RSL_SHUTDOWN - shut down the RSL package.
+
+  Notes:
+  This routine shuts down the RSL package at the end of the program
+  and should be called before program termination.
+
+  See also:
+  RSL_INITIALIZE, RSL_MESH
+
+@*/
+RSL_SHUTDOWN ()
+{
+  RSL_CLOSE0 () ;
+}
+
+/*@
+  RSL_MESH - specify a 2-dimensional mesh of processors for the RSL package.
+
+  Notes:
+  This routine is used to specify the two-dimensional mesh of processors.
+  RSL_INITIALIZE must have already been called.  RSL_MESH
+  must be called before any RSL domain has been defined.  Only RSL_MON_BCAST
+  will work prior to the call to RSL_MESH; this allows node zero to read
+  and broadcast to the other processors configuration information.
+  RSL_MESH must be called on all processors.
+
+  Example:
+$  program model
+$  integer intsize                     ! Size in bytes of an integer.
+$  parameter (intsize = 4)
+$  integer nproc_m, nproc_n            ! Number of processors in m, n.
+$  integer retval
+$  namelist /config/ nproc_m, nproc_n  ! Will be read in from namelist.
+$
+$  call RSL_INITIALIZE                 ! Initialize RSL
+$  call RSL_IAMMONITOR( retval )       ! Read namelist on processor zero
+$  if ( retval .eq. 1 ) then
+$    read(10,config)
+$  endif
+$  call RSL_MON_BCAST( nproc_m, intsize )   ! Broadcast config to other procs.
+$  call RSL_MON_BCAST( nproc_n, intsize )   ! Broadcast config to other procs.
+$  call RSL_MESH( nproc_m, nproc_n )   ! All processors define processor mesh.
+$  ...                                 ! Rest of model.
+$  call RSL_SHUTDOWN                   ! Shutdown.
+$  stop
+$  end
+BREAKTHEEXAMPLECODE
+
+  See also:
+  RSL_INITIALIZE, RSL_MON_BCAST, RSL_SHUTDOWN
+@*/
+RSL_MESH (nproc_m_p, nproc_n_p )
+  int_p 
+    nproc_m_p   /* (I) Number of processors decomposing M dimension. */
+   ,nproc_n_p   /* (I) Number of processors decomposing N dimension. */
+   ;
+{
+  char name[256] ;
+  int d ;
+  int i ;
+  int rsl_default_decomp() ;		/* defined in cd.c */
+
+  rsl_nproc_m = *nproc_m_p ;
+  rsl_nproc_n = *nproc_n_p ;
+  rsl_nproc = rsl_nproc_n * rsl_nproc_m ;
+
+  rsl_padarea = RSL_DEFAULT_PADAREA ;
+  io_seq_monitor = 0 ;  /* OBS */
+  io_seq_compute = 1 ;  /* OBS */
+
+  RSL_INIT_FORTRAN ( &rsl_nproc_all, &rsl_nproc, &rsl_myproc,
+                     &rsl_nproc_m, &rsl_nproc_n, &rsl_ndomains ) ;
+  RSL_F_SET_PADAREA ( &rsl_padarea ) ;
+  if ( rsl_nproc_all < rsl_nproc )
+  {
+    sprintf(mess,"RSL_MESH: %d is too few processors (need px*py=%d)",
+                 rsl_nproc_all, rsl_nproc ) ;
+    RSL_TEST_ERR( rsl_nproc_all < rsl_nproc, mess ) ;
+  }
+
+}
+
+/*@
+  RSL_OLD_OFFSETS -- Calculate local indices using old F77 MPMM strategy.
+
+  Notes:
+  This routine is provided for backward compatibility with the F77
+  parallel implementation of MM5, MPMM, which was developed
+  using an earlier version of RSL.  Call this routine after
+  RSL_INITIALIZE in the model to use this version of RSL with MPMM.
+
+  See also:
+  RSL_INITIALIZE
+
+@*/
+RSL_OLD_OFFSETS ()
+{
+  old_offsets = 1 ;
+}
+
+RSL_SET_REGULAR_DECOMP ()
+{
+  regular_decomp = 1 ;
+}
+
+RSL_GET_COMMUNICATOR ( communicator )
+  int_p  communicator ;  /* (O) return value with communicator from underlying mp layer (mpi probably) */
+{
+#ifdef MPI
+  *communicator = MPI_Comm_c2f( rsl_mpi_communicator ) ;
+#else
+  *communicator = 0 ;
+#endif
+}
+
+RSL_SET_COMMUNICATOR ( communicator )
+  int_p  communicator ;  /* (O) return value with communicator from underlying mp layer (mpi probably) */
+{
+#ifdef MPI
+  rsl_mpi_communicator = MPI_Comm_f2c( *communicator ) ;
+#endif
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_io.c b/wrfv2_fire/external/RSL/RSL/rsl_io.c
new file mode 100755
index 00000000..77df246b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_io.c
@@ -0,0 +1,1314 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_CLOSE - close a fortran unit
+
+  Synopsis:
+  RSL_CLOSE ( unit )
+  integer unit
+
+  Input parameters:
+. unit - unit number
+
+  Notes:
+  Used to close down a fortran unit number.  At present, RSL does
+  not provide a way of opening a named file, so RSL_CLOSE does
+  no do much except flush the identifier.
+
+@*/
+RSL_CLOSE ( unit_p )
+  int_p unit_p ;
+{
+/* this was added 7/27/94 to the monitor-less version.  It won't
+   work, as is, in the monitor/compute version. */
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR ( &i_am_monitor ) ;
+  if ( i_am_monitor )
+  {
+    FORT_CLOSE ( unit_p ) ;
+  }
+}
+
+int io_debug = 0 ;
+
+enable_rsl_debug() { io_debug = 1 ; }
+disable_rsl_debug() { io_debug = 0 ; }
+
+/*@
+  
+
+  Notes:
+  Used to read in one record from an unformatted (binary) Fortran
+  file or from a globally dimensioned data structure in the memory
+  of the monitor processor (see RSL_IAMMONITOR).  The record should
+  contain an undecomposed two- or three-dimensional array.  As a result
+  of the read, the record is distributed according to the decomposition
+  in effect for the domain whose RSL descriptor is given as argument
+  Arg4.
+
+
+  The layout of the
+  array in memory is specified by Arg2, which may be
+
+  Verbatim:
+$     IO2D_IJ,
+$     IO2D_JI,
+$     IO3D_IJK, or
+$     IO3D_JIK
+BREAKTHEEXAMPLECODE
+
+  for reads from a file, or
+
+  Verbatim:
+$     IO2D_IJ_INTERNAL,
+$     IO2D_JI_INTERNAL,
+$     IO3D_IJK_INTERNAL, or
+$     IO3D_JIK_INTERNAL
+BREAKTHEEXAMPLECODE
+
+  for reads from the memory of the monitor processor.  The constants
+  are defined in the header file rsl.inc.
+
+
+  Internal reads are useful 
+  for distributing the results
+  from global calculations performed on the monitor node.
+  Although this is not a scalable technique --- communication from
+  the monitor processor becomes a bottleneck --- it is often practical
+  and much simpler to implement for operations that are performed
+  only once during initialization, or infrequently.
+
+  For internal reads, instead of a unit number,
+  the first argument is the global (undecomposed)
+  data structure from which the data is to be read and distributed.
+  The data must actually populated the data structure only on the
+  monitor processor (the other processors treat the first argument
+  as a dummy).  The monitor distributes the data and, on return
+  from the read, the local (decomposed) portion of the array 
+  is returned as Arg3 on each processor.
+
+  IO2D_IJ specifies a two-dimensional array
+  whose minor dimension is M.  IO3D_JI specifies a two-dimensional array
+  whose minor dimension is N.  (This is as
+  as specified in the call to the routine that created or spawned
+  the domain; e.g., RSL_MOTHER_DOMAIN).
+
+  The type argument specifies the data type of an array element and
+  may be one of
+  Verbatim:
+$     RSL_REAL,
+$     RSL_DOUBLE,
+$     RSL_COMPLEX,
+$     RSL_INTEGER, or
+$     RSL_CHARACTER.  
+BREAKTHEEXAMPLECODE
+
+  The Arg6 array should contain the global (undecomposed) size of
+  each dimension in order from minor to major.  The first element of
+  glen is the size of the minor dimension.  The Arg7 array should
+  contain the size of each dimension as statically declared on the
+  processor.
+
+  Example:
+$ C Example 1, reading from a file
+$ C
+$    #include "rsl.inc"
+$       real ua(mix,mjx,mkx)
+$       integer glen(3), llen(3)
+$       glen(1) = il
+$       glen(2) = jl
+$       glen(3) = mkx
+$       llen(1) = mix
+$       llen(2) = mjx
+$       llen(3) = mkx
+$ C
+$       call rsl_read( 10, IO3D_IJK, ua, did,
+$     +               RSL_REAL, glen, llen )
+$ C
+BREAKTHEEXAMPLECODE
+
+  In the example a three-dimensional field, ua, is read in
+  from Fortran unit 10 on 
+  domain DID.
+  GLEN(1) and GLEN(2) are set to the global sizes of the two
+  horizontal dimensions.
+  LLEN(1) and LLEN(2) are set to the
+  static sizes of the local array (mix, mjx, and mkx are 
+  Fortran parameters).
+
+  See also:
+  RSL_WRITE
+
+@*/
+RSL_READ ( unit_p, iotag_p, base, d_p, type_p, glen, llen  )
+  int_p
+    unit_p              /* (I) Fortran I/O unit number. */
+   ,iotag_p ;           /* (I) RSL I/O code. */
+  char *
+    base ;              /* (O) Buffer. */
+  int_p
+    d_p                 /* (I) RSL domain descriptor */
+   ,type_p ;            /* (I) RSL data type code. */
+  int
+    glen[]              /* (I) Global dimension information. */
+   ,llen[] ;            /* (I) Local dimension information. */
+{
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  rsl_processor_t me ;
+  int cursor, mdest, mtag, msglen, dim, d ;
+  int mlen, nlen, minelems, majelems ;
+  unsigned long ig, jg, min, maj, ioffset, joffset, tlen, k ;
+  void *dex ;
+  char *pbuf ;
+  int i_am_monitor ;
+  rsl_point_t *domain ;
+  int iotag ;
+
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_read: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_read: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+  domain = domain_info[d].domain ;
+  iotag = *iotag_p ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+  me = rsl_c_phys2comp_proc( rsl_myproc ) ;
+  ioffset = domain_info[*d_p].ilocaloffset ;
+  joffset = domain_info[*d_p].jlocaloffset ;
+  tlen = elemsize( *type_p ) ;
+
+  switch( iotag )
+  {
+  case IO2D_IJ_INTERNAL :
+    iotag = IO2D_IJ ;
+    request.internal = 1 ;
+    break ;
+  case IO2D_JI_INTERNAL :
+    iotag = IO2D_JI ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_IJK_INTERNAL :
+    iotag = IO3D_IJK ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_JIK_INTERNAL :
+    iotag = IO3D_JIK ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_IKJ_INTERNAL :
+    iotag = IO3D_IKJ ;
+    request.internal = 1 ;
+    break ;
+  default :
+    request.internal = 0 ;
+    break ;
+  }
+
+  request.request_type = RSL_READ_REQUEST ;
+  request.request_mode = MSG_IO_FORTRAN ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;
+  request.domain = *d_p ;
+  request.unit = *unit_p ;
+  request.unit_p = unit_p ;
+  request.type = *type_p ;
+  request.iotag = iotag ;
+  request.sequence = io_seq_compute++ ;
+
+  switch( iotag )
+  {
+  case IO2D_IJ :
+    request.ndim = 2 ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO2D_JI :
+    request.ndim = 2 ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+  case IO3D_IJK :
+    RSL_TEST_ERR(glen[2] > llen[2],
+       "rsl_read: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO3D_JIK :
+    RSL_TEST_ERR(glen[2] > llen[2],
+       "rsl_read: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+  case IO3D_KIJ :
+    RSL_TEST_ERR(glen[0] > llen[0],
+       "rsl_read: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[2] ;
+    break ;
+  case IO3D_IKJ :
+    RSL_TEST_ERR(glen[1] > llen[1],
+       "rsl_read: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[2] ;
+    break ;
+
+  default:
+    RSL_TEST_ERR(1,"rsl_read: unknown data tag") ;
+  }
+
+  for ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    request.glen[dim] = glen[dim] ;
+    request.llen[dim] = llen[dim] ;
+  }
+
+  pbuf = NULL ;
+  if ( i_am_monitor )
+  {
+    /* note ! this routine allocates pbuf */
+    handle_read_request( &request, &resp, &pbuf ) ;
+  }
+  else
+  {
+    mdest = RSL_C_MONITOR_PROC () ;
+    mtag = MTYPE_FROMTO( MSG_READ_RESPONSE, mdest, rsl_myproc ) ;
+    msglen = sizeof(resp) ;
+    RSL_RECV( &resp, msglen, mtag ) ;
+
+    pbuf = RSL_MALLOC( char, resp.tofollow ) ;
+    msglen = resp.tofollow ;
+    RSL_RECV( pbuf, msglen, mtag ) ;
+  }
+
+  if ( pbuf != NULL ) 
+  {
+  /* we do it this way to ensure that we unpack in the same
+     order that the data were packed on the monitor */
+  cursor = 0 ;
+#ifndef vpp
+
+  for ( jg = 0 ; jg < nlen ; jg++ )
+  {
+    for ( ig = 0 ; ig < mlen ; ig++ )
+    {
+      if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+      {
+        switch( iotag )
+        {
+        case IO2D_IJ :
+          min = ig - ioffset ;
+          maj = jg - joffset ;
+          dex = base+tlen*(min+maj*llen[0]) ;
+          bcopy(&(pbuf[cursor]),dex,tlen) ;
+          cursor += tlen ;
+          break ;
+        case IO2D_JI :
+          min = jg - joffset ;
+          maj = ig - ioffset ;
+          dex = base+tlen*(min+maj*llen[0]) ;
+          bcopy(&(pbuf[cursor]),dex,tlen) ;
+          cursor += tlen ;
+          break ;
+        case IO3D_IJK :
+          min = ig - ioffset ;
+          maj = jg - joffset ;
+          for ( k = 0 ; k < glen[2] ; k++ )
+          {
+            dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+            bcopy(&(pbuf[cursor]),dex,tlen) ;
+            cursor += tlen ;
+          }
+          break ;
+        case IO3D_JIK :
+          min = jg - joffset ;
+          maj = ig - ioffset ;
+          for ( k = 0 ; k < glen[2] ; k++ )
+          {
+            dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+            bcopy(&(pbuf[cursor]),dex,tlen) ;
+            cursor += tlen ;
+          }
+          break ;
+        case IO3D_KIJ :
+          min = ig - ioffset ;
+          maj = jg - joffset ;
+          for ( k = 0 ; k < glen[0] ; k++ )
+          {
+            dex = base+tlen*(k+llen[0]*(min+maj*llen[1])) ;
+            bcopy(&(pbuf[cursor]),dex,tlen) ;
+            cursor += tlen ;
+          }
+          break ;
+        case IO3D_IKJ :
+          min = ig - ioffset ;
+          maj = jg - joffset ;
+          for ( k = 0 ; k < glen[1] ; k++ )
+          {
+            dex = base+tlen*(min+llen[0]*(k+maj*llen[1])) ;
+            bcopy(&(pbuf[cursor]),dex,tlen) ;
+            cursor += tlen ;
+          }
+          break ;
+
+        }
+      }
+    }
+  }
+#else
+/* assumes 1 d decomp in j only */
+  for ( jg = 0 ; jg < nlen ; jg++ )
+  {
+    if ( me == domain[INDEX_2(jg,0,mlen)].P )
+    {
+        switch( iotag )
+        {
+        case IO2D_IJ :
+          if ( request.type == RSL_REAL )
+          {
+            min = 0 - ioffset ;
+            maj = jg - joffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            VRCOPY (&(pbuf[cursor]),dex,&mlen) ;
+            cursor += tlen*mlen ;
+          }
+          else
+          {
+            for ( ig = 0 ; ig < mlen ; ig++ )
+            {
+              min = ig - ioffset ;
+              maj = jg - joffset ;
+              dex = base+tlen*(min+maj*llen[0]) ;
+              bcopy(&(pbuf[cursor]),dex,tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+        case IO2D_JI :
+          for ( ig = 0 ; ig < mlen ; ig++ )
+          {
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            bcopy(&(pbuf[cursor]),dex,tlen) ;
+            cursor += tlen ;
+          }
+          break ;
+        case IO3D_IJK :
+          maj = jg - joffset ;
+          if ( request.type == RSL_REAL )
+          {
+            for ( k = 0 ; k < glen[2] ; k++ )                 /* note reversal of k and i packing order for vpp */
+            {
+              min = 0 - ioffset ;
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+              VRCOPY ( &(pbuf[cursor]),dex,&mlen) ;
+              cursor += tlen*mlen ;
+            }
+          }
+          else
+          {
+            for ( k = 0 ; k < glen[2] ; k++ )                 /* note reversal of k and i packing order for vpp */
+            {
+              for ( ig = 0 ; ig < mlen ; ig++ )
+              {
+                min = ig - ioffset ;
+                dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+                bcopy(&(pbuf[cursor]),dex,tlen) ;
+                cursor += tlen ;
+              }
+            }
+          }
+          break ;
+        case IO3D_JIK :
+          for ( ig = 0 ; ig < mlen ; ig++ )
+          {
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            for ( k = 0 ; k < glen[2] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+              bcopy(&(pbuf[cursor]),dex,tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+        case IO3D_KIJ :
+          for ( ig = 0 ; ig < mlen ; ig++ )
+          {
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[0] ; k++ )
+            {
+              dex = base+tlen*(k+llen[0]*(min+maj*llen[1])) ;
+              bcopy(&(pbuf[cursor]),dex,tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+        case IO3D_IKJ :
+          for ( ig = 0 ; ig < mlen ; ig++ )
+          {
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[1] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(k+maj*llen[1])) ;
+              bcopy(&(pbuf[cursor]),dex,tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+
+        }
+    }
+  }
+#endif
+
+  RSL_FREE( pbuf ) ;
+  }
+}
+
+/************/
+
+/*@
+  RSL_WRITE - Collect and write a distributed array to a file or memory.
+
+  Notes:
+  Used to write one record to an unformatted (binary) Fortran
+  file or to a globally dimensioned data structure in the memory
+  of the monitor processor (see RSL_IAMMONITOR).  After the write,
+  the record will
+  contain an undecomposed two- or three-dimensional array.
+
+  The layout of the
+  array to be written is specified by Arg2, which may be
+
+  Verbatim:
+$     IO2D_IJ,
+$     IO2D_JI,
+$     IO3D_IJK, or
+$     IO3D_JIK
+BREAKTHEEXAMPLECODE
+
+  for writes to a file, or
+
+  Verbatim:
+$     IO2D_IJ_INTERNAL,
+$     IO2D_JI_INTERNAL,
+$     IO3D_IJK_INTERNAL, or
+$     IO3D_JIK_INTERNAL
+BREAKTHEEXAMPLECODE
+
+  for writes to the memory of the monitor processor.  The constants
+  are defined in the header file rsl.inc.
+  
+  For internal writes, instead of a unit number,
+  the first argument is the global (undecomposed)
+  data structure into which the distributed data is written.
+  All processors send their portion of the distributed array
+  to the monitor processor.  On that processor, the write 
+  returns with the global data structure.
+
+  Internal writes are useful for collecting distributed data onto
+  one processor to perform global operations (RSL_READ may then
+  be used to redistribute the results with an internal read, or
+  if the operation is a reduction, the result can be broadcast
+  using RSL_MON_BCAST).
+  Although this is not a scalable technique --- communication to
+  the monitor processor becomes a bottleneck --- it is often practical
+  and much simpler to implement for operations that are performed
+  only once during initialization, or infrequently (see Example 2 below).
+     
+  IO2D_IJ specifies a two-dimensional array
+  whose minor dimension is M.  IO3D_JI specifies a two-dimensional array
+  whose minor dimension is N.  (This is as
+  as specified in the call to the routine that created or spawned
+  the domain; e.g., RSL_MOTHER_DOMAIN).
+
+  The type argument specifies the data type of an array element and
+  may be one of
+  Verbatim:
+$     RSL_REAL,
+$     RSL_DOUBLE,
+$     RSL_COMPLEX,
+$     RSL_INTEGER, or
+$     RSL_CHARACTER.  
+BREAKTHEEXAMPLECODE
+
+  The Arg6 array should contain the global (undecomposed) size of
+  each dimension in order from minor to major.  The first element of
+  glen is the size of the minor dimension.  The Arg7 array should
+  contain the size of each dimension as statically declared on the
+  processor.
+
+  Example:
+
+$ C
+$ C Example 1, writing a distributed array to unit 11.
+$ C
+$    #include "rsl.inc"
+$       real ua(mix,mjx,mkx)
+$       integer glen(3), llen(3)
+$       glen(1) = il
+$       glen(2) = jl
+$       glen(3) = mkx
+$       llen(1) = mix
+$       llen(2) = mjx
+$       llen(3) = mkx
+$       call rsl_write( 11, IO3D_IJK, ua, domains(inest),
+$     +                 RSL_REAL, glen, llen )
+$ C
+$ C Example 2, part of a global initialization in MM90.
+$ C
+$       ALLOCATE( ASTORE_G(IL,JL) )
+$       ...
+$       CALL RSL_WRITE(ASTORE_G, IO2D_IJ_INTERNAL,
+$     +                ASTORE,DID,RSL_REAL,GLEN,LLEN)
+$       ...
+$       CALL RSL_IAMMONITOR(RETVAL)
+$       IF(RETVAL.EQ.1)THEN
+$         DO J=1,JL
+$           DO I=1,IL
+$             ATOT=ATOT+ASTORE_G(I,J)
+$           ENDDO
+$       ENDDO
+$         NPTS=IL*JL
+$         ABAR=ATOT/NPTS
+$       ENDIF
+$       CALL RSL_MON_BCAST(  ABAR,    WORDSIZE )
+BREAKTHEEXAMPLECODE
+
+  In the example a three-dimensional field, ua, is written to
+  Fortran unit 11 from
+  domain DID.
+  GLEN(1) and GLEN(2) are set to the global sizes of the two
+  horizontal dimensions.
+  LLEN(1) and LLEN(2) are set to the
+  static sizes of the local array (mix, mjx, and mkx are
+  Fortran parameters).
+
+  In example two, a reduction is used to compute an average
+  that will be used to initialize a calculation in a weather
+  model.  RSL_WRITE is used to write into the globally dimensioned
+  array ASTORE_G; RSL_IAMMONITOR is used to limit the calculation
+  to the monitor processor; RSL_MON_BCAST is used to broadcast
+  back the result.
+
+
+  See also:
+  RSL_READ
+
+@*/
+RSL_WRITE ( unit_p, iotag_p, base, d_p, type_p, glen, llen  )
+  int_p
+    unit_p              /* (I) Fortran unit number. */
+   ,iotag_p ;           /* (I) RSL I/O code. */
+  char *
+    base ;              /* (I) Buffer. */
+  int_p
+    d_p                 /* (I) RSL domain descriptor */
+   ,type_p ;            /* (I) RSL data type code. */
+  int
+    glen[]              /* (I) Global dimension information. */
+   ,llen[] ;            /* (I) Local dimension information. */
+{
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  rsl_processor_t me ;
+  int cursor, mdest, mtag, msglen, dim, d ;
+  int mlen, nlen ;
+  int minelems, majelems ;
+  unsigned long min, maj, ioffset, joffset, tlen, k ;
+  int ig, jg ;
+  void *dex ;
+  char *pbuf ;
+  int i_am_monitor ;
+  int psize, nelem, typelen, nbytes, columnelems  ;
+  rsl_point_t *domain ;
+  int iotag ;
+  int *is_write, *ie_write, *js_write, *je_write ;
+  int in_write ;
+  int dummy ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_write: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_write: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+  domain = domain_info[d].domain ;
+
+  is_write = &( domain_info[d].is_write ) ;
+  js_write = &( domain_info[d].js_write ) ;
+  ie_write = &( domain_info[d].ie_write ) ;
+  je_write = &( domain_info[d].je_write ) ;
+
+/* reset and recompute each time; otherwise smaller fields will truncate bigger fields later on . JM 20030417.  */
+  *is_write = RSL_INVALID ;
+  *ie_write = RSL_INVALID ;
+  *js_write = RSL_INVALID ;
+  *je_write = RSL_INVALID ;
+
+  iotag = *iotag_p ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  me = rsl_c_phys2comp_proc( rsl_myproc ) ;
+  ioffset = domain_info[*d_p].ilocaloffset ;
+  joffset = domain_info[*d_p].jlocaloffset ;
+  tlen = elemsize( *type_p ) ;
+
+  switch( iotag )
+  {
+  case IO2D_IJ_INTERNAL :
+    iotag = IO2D_IJ ;
+    request.internal = 1 ;
+    break ;
+  case IO2D_JI_INTERNAL :
+    iotag = IO2D_JI ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_IJK_INTERNAL :
+    iotag = IO3D_IJK ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_JIK_INTERNAL :
+    iotag = IO3D_JIK ;
+    request.internal = 1 ;
+    break ;
+  case IO3D_IKJ_INTERNAL :
+    iotag = IO3D_IKJ ;
+    request.internal = 1 ;
+    break ;
+  default :
+    request.internal = 0 ;
+    break ;
+  }
+
+  request.request_type = RSL_WRITE_REQUEST ;
+  request.request_mode = MSG_IO_FORTRAN ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;
+  request.domain = *d_p ;
+  request.unit = *unit_p ;
+  request.unit_p = unit_p ;
+  request.type = *type_p ;
+  request.iotag = iotag ;
+  request.sequence = io_seq_compute++ ;
+
+  switch( iotag )
+  {
+  case IO2D_IJ :
+    request.ndim = 2 ;
+    break ;
+  case IO2D_JI :
+    request.ndim = 2 ;
+    break ;
+  case IO3D_IJK :
+    request.ndim = 3 ;
+    RSL_TEST_ERR(glen[2] > llen[2],
+       "rsl_write: global len of K dim is greater than local len") ;
+    break ;
+  case IO3D_JIK :
+    RSL_TEST_ERR(glen[2] > llen[2],
+       "rsl_write: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    break ;
+  case IO3D_KIJ :
+    RSL_TEST_ERR(glen[0] > llen[0],
+       "rsl_write: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    break ;
+  case IO3D_IKJ :
+    RSL_TEST_ERR(glen[1] > llen[1],
+       "rsl_write: global len of K dim is greater than local len") ;
+    request.ndim = 3 ;
+    break ;
+  default:
+    RSL_TEST_ERR(1,"rsl_write: unknown data tag") ;
+  }
+  for ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    request.glen[dim] = glen[dim] ;
+    request.llen[dim] = llen[dim] ;
+  }
+
+  /* figure out size of buffer needed */
+  nelem = 1 ;
+  for  ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    nelem *= request.glen[dim] ;
+  }
+  typelen = elemsize( request.type ) ;
+  nbytes = nelem * typelen ;
+
+  switch ( request.iotag )
+  {
+  case IO2D_IJ :
+    columnelems = 1 ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO2D_JI :
+    columnelems = 1 ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+  case IO3D_IJK :
+    columnelems = request.glen[2] ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO3D_JIK :
+    columnelems = request.glen[2] ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+  case IO3D_KIJ :
+    columnelems = request.glen[0] ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[2] ;
+    break ;
+  case IO3D_IKJ :
+    columnelems = request.glen[1] ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[2] ;
+    break ;
+  default:
+    RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
+  }
+
+  /*  figure out size for this processor */
+  pbuf = NULL ;
+  psize = (regular_decomp)?(4*sizeof(int)):0 ;
+
+  RSL_TEST_ERR( majelems <= 0, "Major dim spec on write is zero or less.") ;
+  RSL_TEST_ERR( minelems <= 0, "Minor dim spec on write is zero or less.") ;
+  if ( majelems > domain_info[request.domain].len_n )
+  { sprintf(mess,"Major dim spec on write (%d) greater than global domain definition in that dimension (%d)\n",majelems,domain_info[request.domain].len_n) ;
+    RSL_TEST_ERR(1,mess) ; }
+  if ( minelems > domain_info[request.domain].len_m )
+  { sprintf(mess,"Minor dim spec on write (%d) greater than global domain definition in that dimension (%d)\n",minelems,domain_info[request.domain].len_m) ;
+    RSL_TEST_ERR(1,mess) ; }
+
+  for ( jg = 0 ; jg < majelems ; jg++ )
+  {
+    for ( ig = 0 ; ig < minelems ; ig++ )
+    {
+      if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+        psize += columnelems * typelen ;
+    }
+  }
+
+  pbuf = RSL_MALLOC( char, psize ) ;
+
+  cursor = 0 ;
+
+  if ( regular_decomp )
+  {
+    if ( *is_write == RSL_INVALID )
+    {
+      for ( jg = 0 ; jg < majelems ; jg++ )
+      {
+        for ( ig = 0 ; ig < minelems ; ig++ )
+        {
+          if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+          {
+            if ( *is_write == RSL_INVALID ) { *is_write = ig ; }
+            if ( *js_write == RSL_INVALID ) { *js_write = jg ; }
+            *ie_write = ig ;
+            *je_write = jg ;
+          }
+        }
+      }
+      if ( *is_write == RSL_INVALID )   /* nothing set */
+      {
+        *is_write = 0 ;      /* set so no iterations occur */
+        *js_write = 0 ;
+        *ie_write = -1 ;
+        *je_write = -1 ;
+      }
+    }
+
+    bcopy( is_write, &(pbuf[cursor]), sizeof(int) ) ; cursor += sizeof(int) ;
+    bcopy( ie_write, &(pbuf[cursor]), sizeof(int) ) ; cursor += sizeof(int) ;
+    bcopy( js_write, &(pbuf[cursor]), sizeof(int) ) ; cursor += sizeof(int) ;
+    bcopy( je_write, &(pbuf[cursor]), sizeof(int) ) ; cursor += sizeof(int) ;
+
+    if ( *ie_write == -1 )
+    {
+      in_write = 0 ;
+    }
+    else
+    {
+      in_write = *ie_write - *is_write + 1 ;
+    }
+
+    for ( jg = *js_write ; jg <= *je_write ; jg++ )
+    {
+        switch( iotag )
+        {
+        case IO2D_IJ :
+	  if ( request.type == RSL_REAL ) 
+	  {
+            min = *is_write - ioffset ;
+            maj = jg - joffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            VRCOPY (dex,&(pbuf[cursor]),&in_write) ;
+            cursor += tlen*in_write ;
+	  }
+	  else
+	  {
+            for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+            {
+              min = ig - ioffset ;
+              maj = jg - joffset ;
+              dex = base+tlen*(min+maj*llen[0]) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+        case IO2D_JI :
+          for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+          {
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            bcopy(dex,&(pbuf[cursor]),tlen) ;
+            cursor += tlen ;
+	  }
+          break ;
+        case IO3D_IJK :
+          maj = jg - joffset ;
+	  if ( request.type == RSL_REAL )
+	  {
+            for ( k = 0 ; k < glen[2] ; k++ )                 /* note reversal of k and i packing order for vpp */
+            {
+              min = *is_write - ioffset ;
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+	      VRCOPY ( dex,&(pbuf[cursor]),&in_write) ;
+              cursor += tlen*in_write ;
+	    }
+	  }
+	  else
+	  {
+            for ( k = 0 ; k < glen[2] ; k++ )                 /* note reversal of k and i packing order for vpp */
+            {
+	      for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+	      {
+                min = ig - ioffset ;
+                dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+                bcopy(dex,&(pbuf[cursor]),tlen) ;
+                cursor += tlen ;
+	      }
+            }
+          }
+          break ;
+        case IO3D_JIK :
+          for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+          {
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            for ( k = 0 ; k < glen[2] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+	  }
+          break ;
+
+        case IO3D_KIJ :
+          for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+          {
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[0] ; k++ )
+            {
+              dex = base+tlen*(k+llen[0]*(min+maj*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+          }
+          break ;
+
+        case IO3D_IKJ :
+#ifndef NEC_TUNE
+          for ( ig = *is_write ; ig <= *ie_write ; ig++ )
+          {
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[1] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(k+maj*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+          }
+#else
+          maj = jg - joffset ;
+          min = *is_write - ioffset ;
+          for ( k = 0 ; k < glen[1] ; k++ )
+          {
+            dex = base+tlen*(min+llen[0]*(k+maj*llen[1])) ;
+            copymem(dex, tlen, &(pbuf[cursor+k*tlen]), tlen*glen[1], tlen, *ie_write-*is_write+1) ;
+          }
+          cursor += tlen*(*ie_write-*is_write+1)*glen[1] ;
+#endif
+          break ;
+
+        }
+    }
+  }
+  else
+  {
+    for ( jg = 0 ; jg < majelems ; jg++ )
+    {
+      for ( ig = 0 ; ig < minelems ; ig++ )
+      {
+        if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+        {
+          switch( iotag )
+          {
+          case IO2D_IJ :
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            bcopy(dex,&(pbuf[cursor]),tlen) ;
+            cursor += tlen ;
+            break ;
+          case IO2D_JI :
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            dex = base+tlen*(min+maj*llen[0]) ;
+            bcopy(dex,&(pbuf[cursor]),tlen) ;
+            cursor += tlen ;
+            break ;
+          case IO3D_IJK :
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[2] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+            break ;
+          case IO3D_JIK :
+            min = jg - joffset ;
+            maj = ig - ioffset ;
+            for ( k = 0 ; k < glen[2] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+            break ;
+
+          case IO3D_KIJ :
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[0] ; k++ )
+            {
+              dex = base+tlen*(k+llen[0]*(min+maj*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+            break ;
+          case IO3D_IKJ :
+            min = ig - ioffset ;
+            maj = jg - joffset ;
+            for ( k = 0 ; k < glen[1] ; k++ )
+            {
+              dex = base+tlen*(min+llen[0]*(k+maj*llen[1])) ;
+              bcopy(dex,&(pbuf[cursor]),tlen) ;
+              cursor += tlen ;
+            }
+            break ;
+          }
+        }
+      }
+    }
+  }
+
+  if ( pbuf != NULL )
+  {
+  if ( i_am_monitor )
+  {
+    handle_write_request( &request, nelem, psize, pbuf ) ;
+  }
+  else
+  {
+#ifdef RSL_SYNCIO
+    mdest = RSL_C_MONITOR_PROC () ;
+    msglen = 1 ;
+    mtag = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, mdest, rsl_myproc ) ;
+    RSL_RECV( &dummy, msglen, mtag ) ;
+#endif
+    mdest = RSL_C_MONITOR_PROC () ;
+    msglen = psize ;
+    mtag = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, rsl_myproc, mdest ) ;
+    RSL_SEND( pbuf, msglen, mtag, mdest ) ;
+  }
+
+  RSL_FREE( pbuf ) ;
+  }
+}
+
+
+
+RSL_IO_SHUTDOWN ()
+{ 
+  rsl_read_req_t request ;
+  int mdest, mtag, msglen ;
+
+  request.request_type = RSL_SHUTDOWN_REQUEST ;
+  request.sequence = io_seq_compute++ ;
+  mdest = RSL_C_MONITOR_PROC () ;
+  mtag = MSG_MONITOR_REQUEST ;
+  msglen = sizeof( request ) ;
+
+  RSL_SEND( &request, msglen, mtag, mdest ) ;
+
+  return ;
+}
+
+/* this is collective over all processors, but not every processor will
+   necessarily have data at input or output. Map the patch from the input 
+   array onto the patch of the output array, communicating as necessary.
+   code assumes (for now) anyway, that each patch is disjoint on each side. */
+
+RSL_REMAP_ARRAY ( inbuf, ndim_p, type_p,
+                          is_dimd, ie_dimd, 
+                          is_dimp, ie_dimp, is_dimm, ie_dimm,
+                  outbuf, os_dimp, oe_dimp, os_dimm, oe_dimm )
+  char inbuf[], outbuf[] ;
+  int_p ndim_p, type_p ;
+  int is_dimd[], is_dimp[], is_dimm[], os_dimp[], os_dimm[] ;
+  int ie_dimd[], ie_dimp[], ie_dimm[], oe_dimp[], oe_dimm[] ;
+{
+
+#ifndef STUBS
+
+#define STRT 0
+#define ENDD 1
+#define PCH  0
+#define MEM  1
+#define DOM  2
+
+  int group_i[2][3][RSL_MAXPROC][3] ;
+  int group_o[2][3][RSL_MAXPROC][3] ;
+  MPI_Request reqlist[RSL_MAXPROC] ;
+  MPI_Comm rsl_mpi_communicator=MPI_COMM_WORLD ;
+  char * rcvbuf, *sndbuf ;
+  int outstanding = 0 ; 
+  int msglen ;
+  int P, good, ps0[RSL_MAXPROC], ps1[RSL_MAXPROC] ;
+  int          pe0[RSL_MAXPROC], pe1[RSL_MAXPROC] ;
+  int          ds0, ds1 ;
+  int          de0, de1 ;
+  int i,j,k,l,curs,dex,w, outer ;
+  int ndim, type, mtag ;
+  MPI_Status Stat ;
+
+  ndim = *ndim_p ;
+  type = *type_p ;
+
+  MPI_Allgather( is_dimp, 3, MPI_INT, group_i[STRT][PCH], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( is_dimm, 3, MPI_INT, group_i[STRT][MEM], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( is_dimd, 3, MPI_INT, group_i[STRT][DOM], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( ie_dimp, 3, MPI_INT, group_i[ENDD][PCH], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( ie_dimm, 3, MPI_INT, group_i[ENDD][MEM], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( ie_dimd, 3, MPI_INT, group_i[ENDD][DOM], 3, MPI_INT, rsl_mpi_communicator )  ;
+
+  MPI_Allgather( os_dimp, 3, MPI_INT, group_o[STRT][PCH], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( os_dimm, 3, MPI_INT, group_o[STRT][MEM], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( oe_dimp, 3, MPI_INT, group_o[ENDD][PCH], 3, MPI_INT, rsl_mpi_communicator )  ;
+  MPI_Allgather( oe_dimm, 3, MPI_INT, group_o[ENDD][MEM], 3, MPI_INT, rsl_mpi_communicator )  ;
+
+/* now everybody knows about everybody, figure out what I need from where */
+/* assume ijk for now */
+
+  /* loop over possible senders so we can post receives */
+  /* is any point I need on P? */
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    good = 0 ;
+    /* cases where there definitely are not... */
+    if ( os_dimp[0] > group_i[ENDD][PCH][P][0] || oe_dimp[0] < group_i[STRT][PCH][P][0] )
+    { }
+    else
+    {
+      ps0[outstanding] = ( os_dimp[0] < group_i[STRT][PCH][P][0] )? group_i[STRT][PCH][P][0] : os_dimp[0] ;
+      pe0[outstanding] = ( oe_dimp[0] > group_i[ENDD][PCH][P][0] )? group_i[ENDD][PCH][P][0] : oe_dimp[0] ;
+      if ( os_dimp[1] > group_i[ENDD][PCH][P][1] || oe_dimp[1] < group_i[STRT][PCH][P][1] )
+      { }
+      else
+      {
+        ps1[outstanding] = ( os_dimp[1] < group_i[STRT][PCH][P][1] )? group_i[STRT][PCH][P][1] : os_dimp[1] ;
+        pe1[outstanding] = ( oe_dimp[1] > group_i[ENDD][PCH][P][1] )? group_i[ENDD][PCH][P][1] : oe_dimp[1] ;
+        good = 1 ;
+      }
+    }
+    if ( good )
+    {
+      msglen = (oe_dimp[2]-os_dimp[2]+1)*(pe1[outstanding]-ps1[outstanding]+1)*(pe0[outstanding]-ps0[outstanding]+1)*elemsize(type) ;
+      rcvbuf = (char *) buffer_for_proc(P, msglen, RSL_RECVBUF) ;
+      mtag = MTYPE_FROMTO( MSG_READ_RESPONSE, P, rsl_myproc ) ;
+
+      MPI_Irecv( rcvbuf , msglen, MPI_CHAR, P, 
+                 mtag , rsl_mpi_communicator, &reqlist[outstanding] ) ;  /* posted receive */
+      outstanding++ ;
+    }
+  }
+  /* loop over possible receivers so we can pack and send stuff */
+  /* are points I have needed by P */
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    good = 0 ;
+    /* cases where they definitely are not */
+    if ( is_dimp[0] > group_o[ENDD][PCH][P][0] || ie_dimp[0] < group_o[STRT][PCH][P][0] )
+    { }
+    else
+    {
+      ds0 = ( is_dimp[0] < group_o[STRT][PCH][P][0] )? group_o[STRT][PCH][P][0] : is_dimp[0] ;
+      de0 = ( ie_dimp[0] > group_o[ENDD][PCH][P][0] )? group_o[ENDD][PCH][P][0] : ie_dimp[0] ;
+      if ( is_dimp[1] > group_o[ENDD][PCH][P][1] || ie_dimp[1] < group_o[STRT][PCH][P][1] )
+      { }
+      else
+      {
+        ds1 = ( is_dimp[1] < group_o[STRT][PCH][P][1] )? group_o[STRT][PCH][P][1] : is_dimp[1] ;
+        de1 = ( ie_dimp[1] > group_o[ENDD][PCH][P][1] )? group_o[ENDD][PCH][P][1] : ie_dimp[1] ;
+        good = 1 ;
+      }
+    }
+    if ( good )
+    {
+      /* pack and send */
+      msglen = (oe_dimp[2]-os_dimp[2]+1)*(de1-ds1+1)*(de0-ds0+1)*elemsize(type) ;
+      sndbuf = (char *) buffer_for_proc(P, msglen, RSL_SENDBUF) ;
+      curs = 0 ;
+      for ( k = is_dimm[2] ; k <= ie_dimm[2] ; k++ )
+        for ( j = ds1 ; j <= de1 ; j++ )
+          for ( i = ds0 ; i <= de0 ; i++ )
+            for ( l = 0 ; l < elemsize(type) ; l++ )
+            {
+              dex = elemsize(type)*
+                    ((i-is_dimm[0])
+                    +(j-is_dimm[1])*(ie_dimm[0]-is_dimm[0]+1)
+                    +(k-is_dimm[2])*(ie_dimm[0]-is_dimm[0]+1)*(ie_dimm[1]-is_dimm[1]+1))  ;
+              sndbuf[curs++] = inbuf[l+dex] ;
+            }
+       mtag = MTYPE_FROMTO( MSG_READ_RESPONSE, rsl_myproc, P ) ;
+#if 0
+fprintf(stderr,"MPI_Send to %d %d\n",P,msglen) ;
+#endif
+       MPI_Send( sndbuf, msglen, MPI_CHAR, P, mtag, rsl_mpi_communicator ) ;
+    }
+  }
+
+  for ( outer = 0 ; outer < outstanding ; outer++ )
+  {
+    MPI_Waitany ( outstanding, reqlist, &w, &Stat ) ;
+    P = Stat.MPI_SOURCE ;
+    rcvbuf = (char *) buffer_for_proc(P, 0, RSL_RECVBUF) ;
+    curs = 0 ;
+    for ( k = os_dimm[2] ; k <= oe_dimm[2] ; k++ )
+      for ( j = ps1[w] ; j <= pe1[w] ; j++ )
+        for ( i = ps0[w] ; i <= pe0[w] ; i++ )
+          for ( l = 0 ; l < elemsize(type) ; l++ )
+	  {
+            dex = elemsize(type)*
+                  ((i-os_dimm[0])
+                  +(j-os_dimm[1])*(oe_dimm[0]-os_dimm[0]+1)
+                  +(k-os_dimm[2])*(oe_dimm[0]-os_dimm[0]+1)*(oe_dimm[1]-os_dimm[1]+1))  ;
+            outbuf[l+dex] = rcvbuf[curs++] ;
+	  }
+  }
+#else
+  RSL_TEST_ERR (1,"RSL_REMAP_ARRAY STUBBED") ; 
+#endif
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_io.h b/wrfv2_fire/external/RSL/RSL/rsl_io.h
new file mode 100755
index 00000000..6de2db5f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_io.h
@@ -0,0 +1,130 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef RSL_IO_H
+#define RSL_IO_H
+
+typedef struct rsl_read_resp {
+  int response_type ;
+  int sequence ;
+  int tofollow ;
+} rsl_read_resp_t ;
+
+typedef struct rsl_read_req {
+  int request_type  ;
+
+  int request_mode  ;	/* FORTRAN or SOCKET   added 9/30/94 */
+  int request_mode2 ;	/* RAW or PORTAL       added 9/30/94 */
+
+  rsl_processor_t myproc ;
+  rsl_index_t domain ;
+  void * base ;
+  int sequence ;
+  int iotag ;
+  int unit ;
+  int_p unit_p ;
+  int internal ;
+  int ndim ;
+  int type ;
+  int speciala ;		/* extra information */
+  int specialb ;		/* extra information */
+  int specialc ;		/* extra information */
+  int glen[RSL_MAXDIM] ;
+  int llen[RSL_MAXDIM] ;
+#ifdef crayx1
+  int is_write, ie_write ;
+  int js_write, je_write ;
+  int is_read , ie_read  ;
+  int js_read , je_read  ;
+#else
+  short is_write, ie_write ;
+  short js_write, je_write ;
+  short is_read , ie_read  ;
+  short js_read , je_read  ;
+#endif
+} rsl_read_req_t ;
+
+typedef rsl_read_req_t rsl_write_req_t ;
+
+
+/* start 981228 AFWA IO */
+
+typedef struct rsl_write_buffer_struct {
+  rsl_write_req_t req ;
+  int nelem ;
+  char * buf ;
+  struct rsl_write_buffer_struct *next ;
+} rsl_write_buffer_struct_t ;
+
+#ifdef DEFINE_GLOBAL
+rsl_write_buffer_struct_t * write_buffer_head = NULL ;
+rsl_write_buffer_struct_t * write_buffer_tail = NULL ;
+int rsl_buffer_output = 0 ;
+int rsl_io_node = 0 ;
+#else
+extern rsl_write_buffer_struct_t * write_buffer_head ;
+extern rsl_write_buffer_struct_t * write_buffer_tail ;
+extern int rsl_buffer_output ;
+extern int rsl_io_node ;
+#endif
+
+
+/* end 981228 AFWA IO */
+
+
+#endif /* nothing after this line */
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_ioserve.c b/wrfv2_fire/external/RSL/RSL/rsl_ioserve.c
new file mode 100755
index 00000000..7c6f5ce1
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_ioserve.c
@@ -0,0 +1,1846 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#ifdef T3D
+#include 
+#endif
+
+       static int first_time_through = 1 ;
+
+
+static char request_buf[ 2048 ] ;
+
+/* hack for IBM/Chameleon, and other machines/api's that aren't
+   completely competant about flushing FORTRAN I/O before shutting
+   down.  We'll do that here, each time a shutdown occurs.  That
+   entails keeping track of which files were written to, hence
+   this data structure. */
+
+#define NUNITS  128
+static unsigned char unit_written[NUNITS] ;
+
+
+
+RSL_IOSERVE ()
+{
+  int *rtype ;
+  int msglen, mtag ;
+  int done, nshutdown ;
+  int i, x ;
+
+  nshutdown = 0 ;
+  done = 0 ;
+
+  for ( i = 0 ; i < NUNITS ; i++ )
+     unit_written[i] = '\0' ;
+
+  while( !done )
+  {
+    msglen = 2048 ;
+    mtag = MSG_MONITOR_REQUEST ;
+    RSL_RECV( request_buf, msglen, mtag ) ;
+    rtype = (int *) request_buf ;
+    switch( *rtype )
+    {
+    case RSL_READ_REQUEST :
+      handle_read_request( request_buf ) ;
+      break ;
+    case RSL_WRITE_REQUEST :
+      handle_write_request( request_buf ) ;
+      break ;
+    case RSL_READ_SPECIAL1   :
+      handle_special1( request_buf ) ;
+      break ;
+    case RSL_READ_SPECIAL2   :
+      handle_special2( request_buf ) ;
+      break ;
+    case RSL_SHUTDOWN_REQUEST  :
+      /* last processor causes shutdown */
+      nshutdown++ ;
+      if ( nshutdown == rsl_nproc ) 
+        done = 1 ;
+      break ;
+    default :
+      sprintf(mess,"rsl_ioserve: monitor received unknown request %d",*rtype) ;
+      RSL_TEST_ERR(1,mess) ;
+    }
+  }
+
+  for ( i = 0 ; i < NUNITS ; i++ )
+  {
+     if ( unit_written[i] != '\0' )
+     {
+        x = i + 1 ;
+        RSL_FUNIT_CLOSE ( &x ) ;
+     }
+  }
+}
+
+int
+handle_read_request( req, resp_me, pbuf_me )
+  rsl_read_req_t * req ;
+  char * resp_me ;
+  char ** pbuf_me ;
+{
+  int dim, i, k, ig, jg, nelem ;
+  int columnelems, nbytes, typelen, len, cursor  ;
+  int P ;
+  int msglen, mtag, mdest ;
+  int mlen, nlen, minelems, majelems ;
+  rsl_read_resp_t resp ;
+  int psize[ RSL_MAXPROC ] ;    /* size of messages to each processor */
+  char * rbuf ;
+  char *pbuf ;
+  rsl_point_t *domain ;
+  int nelem_alloc ;
+
+/* efficiency update from JM, 2002/05/24 */
+  int numpts[RSL_MAXPROC], maxnumpts, iii ;
+  int *iptlst, *jptlst, *ip1, *ip2  ;
+  double *dp1, *dp2 ;
+
+/* bug fix from AJB; rbuf needs to be as large as the
+   domain size (with padding out to factor of 3 for nest
+   dimensions) or may generate a seg-fault in bcopies below
+   in loop that runs over the mlen/nlen dimensions
+*/
+  /* figure out size of read buffer needed (includes padding) */
+  nelem_alloc = domain_info[req->domain].len_m * domain_info[req->domain].len_n ;
+  switch ( req->iotag )
+  {
+  case IO2D_IJ  : break ;
+  case IO2D_JI  : break ;
+  case IO3D_IJK : nelem_alloc *= req->glen[2] ; break ;
+  case IO3D_JIK : nelem_alloc *= req->glen[2] ; break ;
+  case IO3D_KIJ : nelem_alloc *= req->glen[0] ; break ;
+  case IO3D_IKJ : nelem_alloc *= req->glen[1] ; break ;
+  }
+  /* figure out number of elements to read into read buffer */
+  nelem = 1 ;
+  for  ( dim = 0 ; dim < req->ndim ; dim++ )
+  {
+    nelem *= req->glen[dim] ; 
+  }
+  typelen = elemsize( req->type ) ;
+  nbytes = nelem_alloc * typelen ;
+
+  rbuf = RSL_MALLOC( char, nbytes ) ;  
+
+  /* call fortran to read a record from the named unit */
+  if ( req->internal ) 
+  {
+#ifndef NEC_TUNE
+    bcopy( req->unit_p, rbuf, nbytes ) ;
+#else
+    copymem( (void *)req->unit_p, typelen, (void *)rbuf, typelen, typelen, nelem_alloc ) ;
+#endif
+  }
+  else
+  {
+    switch ( req->type )
+    {
+    case RSL_REAL :
+      FORT_REALREAD ( &(req->unit), rbuf, &nelem ) ;
+      break ;
+    case RSL_INTEGER :
+      FORT_INTREAD ( &(req->unit), rbuf, &nelem ) ;
+      break ;
+#ifndef T3D
+    case RSL_DOUBLE :
+      FORT_DOUBLEREAD ( &(req->unit), rbuf, &nelem ) ;
+      break ;
+#endif
+    case RSL_COMPLEX :
+      FORT_COMPLEXREAD ( &(req->unit), rbuf, &nelem ) ;
+      break ;
+    case RSL_CHARACTER :
+      FORT_CHARACTERREAD ( &(req->unit), rbuf, &nelem ) ;
+      break ;
+    default :
+      RSL_TEST_WRN(1,"read operation not yet implemented for this data type") ;
+    }
+  }
+  /* global record is now stored -- ship it out */
+  switch ( req->iotag )
+  {
+  case IO2D_IJ :
+    columnelems = 1 ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO2D_JI :
+    columnelems = 1 ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_IJK :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO3D_JIK :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_KIJ :
+    columnelems = req->glen[0] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[2] ;
+    break ;
+  case IO3D_IKJ :
+    columnelems = req->glen[1] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[2] ;
+    break ;
+  default:
+    RSL_TEST_ERR(1,"handle_read_request: unknown data tag") ;
+  }
+  /*  figure out sizes for each processor */
+  pbuf = NULL ;
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )       /* 95/02/22 */
+  {
+    psize[i] = 0 ;
+    numpts[i] = 0 ;
+  }
+  mlen = domain_info[req->domain].len_m ;
+  nlen = domain_info[req->domain].len_n ;
+  domain = domain_info[req->domain].domain ;
+  for ( jg = 0 ; jg < nlen ; jg++ )
+  {
+    for ( ig = 0 ; ig < mlen ; ig++ )
+    {
+      P = domain[INDEX_2(jg,ig,mlen)].P ;       /* 2002/05/24 */
+      psize[P] += columnelems * typelen ;       /* 2002/05/24 */
+      if ( P >= 0 && P < rsl_nproc_all ) numpts[P]++ ;   /* 2002/05/24 */
+    }
+  }
+  maxnumpts = 0 ;                               /* 2002/05/24 */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )       /* 2002/05/24 */
+  {                                             /* 2002/05/24 */
+    if ( maxnumpts < numpts[i] ) maxnumpts = numpts[i] ; /* 2002/05/24 */
+  }                                             /* 2002/05/24 */
+
+  iptlst = RSL_MALLOC( int, rsl_nproc_all * maxnumpts ) ;      /* 2002/05/24 */
+  jptlst = RSL_MALLOC( int, rsl_nproc_all * maxnumpts ) ;      /* 2002/05/24 */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) numpts[i] = 0 ;      /* 2002/05/24 */
+  for ( jg = 0 ; jg < nlen ; jg++ )                            /* 2002/05/24 */
+  {                                                            /* 2002/05/24 */
+   for ( ig = 0 ; ig < mlen ; ig++ )                           /* 2002/05/24 */
+    {                                                          /* 2002/05/24 */
+      P = domain[INDEX_2(jg,ig,mlen)].P ;                      /* 2002/05/24 */
+      if ( P >= 0 && P < rsl_nproc_all )                       /* 2002/05/24 */
+      {                                                        /* 2002/05/24 */
+        iptlst[INDEX_2(P,numpts[P],maxnumpts)] = ig ;          /* 2002/05/24 */
+        jptlst[INDEX_2(P,numpts[P],maxnumpts)] = jg ;          /* 2002/05/24 */
+        numpts[P]++ ;                                          /* 2002/05/24 */
+      }                                                        /* 2002/05/24 */
+    }                                                          /* 2002/05/24 */
+  }                                                            /* 2002/05/24 */
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )       /* 95/02/22 */
+  {
+    len = 0 ;
+    len += psize[P] ;
+    pbuf = RSL_MALLOC( char, len ) ;
+    resp.response_type = RSL_READ_RESPONSE ;
+    resp.sequence = req->sequence ;
+    resp.tofollow = psize[P] ;
+    cursor = 0 ;
+    /*bcopy( &resp, &(pbuf[cursor]), sizeof( resp )) ; cursor += sizeof(resp) ; */
+
+/* NOTE AND WARNING:  this code is quick and dirty and makes the very
+   naive assumption that the data set being read in is point for point
+   with the domain and is dimensioned to be exactly the same size!!!! 
+   Only with this assumption can the ig, jg indices into the domain
+   data structure be used in this way as indices into the data.  This
+   will work for MM.  A more general approach will require modification. */
+
+#ifndef vpp
+if ( typelen == sizeof ( int ) ) {
+    for ( iii = 0 ; iii < numpts[P] ; iii++ )
+    {
+      ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
+      jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
+          RSL_TEST_ERR( cursor >= len,
+   "something wrong with read request: check glen, llen arrays in call") ;
+          switch ( req->iotag )
+          {
+          case IO2D_IJ :
+            ip1 = (int *) &(rbuf[typelen*(ig+jg*req->glen[0])]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            *ip2 = *ip1 ;
+            cursor += typelen ;
+            break ;
+          case IO2D_JI :
+            ip1 = (int *) &(rbuf[typelen*(jg+ig*req->glen[0])]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            *ip2 = *ip1 ;
+            cursor += typelen ;
+            break ;
+          case IO3D_IJK :
+            k = 0 ;
+            ip1 = (int *) &(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              *ip2 = *ip1 ;
+              ip1 += req->glen[0] * req->glen[1] ;
+              ip2++ ;
+            }
+            cursor += typelen*req->glen[2]  ;
+            break ;
+          case IO3D_JIK :
+            k = 0 ;
+            ip1 = (int *) &(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              *ip2 = *ip1 ;
+              ip1 += req->glen[0] * req->glen[1] ;
+              ip2++ ;
+            }
+            cursor += typelen*req->glen[2]  ;
+            break ;
+          case IO3D_KIJ :
+            k = 0 ;
+            ip1 = (int *) &(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[0] ; k++ )
+            {
+              *ip2 = *ip1 ;
+              ip1++ ;
+              ip2++ ;
+            }
+            cursor += typelen*req->glen[0] ;
+            break ;
+          case IO3D_IKJ :
+            k = 0 ;
+            ip1 = (int *) &(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]) ;
+            ip2 = (int *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[1] ; k++ )
+            {
+              *ip2 = *ip1 ;
+              ip1 += req->glen[0] ;
+              ip2++ ;
+            }
+            cursor += typelen*req->glen[1] ;
+            break ;
+          }
+    }
+} else if ( typelen == sizeof ( double ) ) {
+    for ( iii = 0 ; iii < numpts[P] ; iii++ )
+    {
+      ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
+      jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
+          RSL_TEST_ERR( cursor >= len,
+   "something wrong with read request: check glen, llen arrays in call") ;
+          switch ( req->iotag )
+          {
+          case IO2D_IJ :
+            dp1 = (double *) &(rbuf[typelen*(ig+jg*req->glen[0])]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            *dp2 = *dp1 ;
+            cursor += typelen ;
+            break ;
+          case IO2D_JI :
+            dp1 = (double *) &(rbuf[typelen*(jg+ig*req->glen[0])]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            *dp2 = *dp1 ;
+            cursor += typelen ;
+            break ;
+          case IO3D_IJK :
+            k = 0 ;
+            dp1 = (double *) &(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              *dp2 = *dp1 ;
+              dp1 += req->glen[0] * req->glen[1] ;
+              dp2++ ;
+            }
+            cursor += typelen*req->glen[2]  ;
+            break ;
+          case IO3D_JIK :
+            k = 0 ;
+            dp1 = (double *) &(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              *dp2 = *dp1 ;
+              dp1 += req->glen[0] * req->glen[1] ;
+              dp2++ ;
+            }
+            cursor += typelen*req->glen[2]  ;
+            break ;
+          case IO3D_KIJ :
+            k = 0 ;
+            dp1 = (double *) &(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[0] ; k++ )
+            {
+              *dp2 = *dp1 ;
+              dp1++ ;
+              dp2++ ;
+            }
+            cursor += typelen*req->glen[0] ;
+            break ;
+          case IO3D_IKJ :
+            k = 0 ;
+            dp1 = (double *) &(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]) ;
+            dp2 = (double *) &(pbuf[cursor]) ;
+            for ( k = 0 ; k < req->glen[1] ; k++ )
+            {
+              *dp2 = *dp1 ;
+              dp1 += req->glen[0] ;
+              dp2++ ;
+            }
+            cursor += typelen*req->glen[1] ;
+            break ;
+          }
+    }
+}else{
+    for ( iii = 0 ; iii < numpts[P] ; iii++ )
+    {
+      ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
+      jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
+          RSL_TEST_ERR( cursor >= len,
+   "something wrong with read request: check glen, llen arrays in call") ;
+          switch ( req->iotag )
+          {
+          case IO2D_IJ :
+            bcopy(&(rbuf[typelen*(ig+jg*req->glen[0])]),
+                  &(pbuf[cursor]),
+                  typelen) ;
+            cursor += typelen ;
+            break ;
+          case IO2D_JI :
+            bcopy(&(rbuf[typelen*(jg+ig*req->glen[0])]),
+                  &(pbuf[cursor]),
+                  typelen) ;
+            cursor += typelen ;
+            break ;
+          case IO3D_IJK :
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              bcopy(&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                    &(pbuf[cursor]),
+                    typelen) ;
+              cursor += typelen ;
+            }
+            break ;
+          case IO3D_JIK :
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              bcopy(&(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
+                    &(pbuf[cursor]),
+                    typelen) ;
+              cursor += typelen ;
+            }
+            break ;
+          case IO3D_KIJ :
+            for ( k = 0 ; k < req->glen[0] ; k++ )
+            {
+              bcopy(&(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
+                    &(pbuf[cursor]),
+                    typelen) ;
+              cursor += typelen ;
+            }
+            break ;
+          case IO3D_IKJ :
+            for ( k = 0 ; k < req->glen[1] ; k++ )
+            {
+              bcopy(&(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
+                    &(pbuf[cursor]),
+                    typelen) ;
+              cursor += typelen ;
+            }
+            break ;
+          }
+    }
+}
+#else
+    for ( jg = 0 ; jg < nlen ;  jg++ )
+    {
+      if ( domain[INDEX_2(jg,0,mlen)].P == P )
+      {
+          switch ( req->iotag )
+          {
+          case IO2D_IJ :
+            if ( req->type == RSL_REAL )
+            {
+              ig = 0 ;
+              VRCOPY (&(rbuf[typelen*(ig+jg*req->glen[0])]),
+                      &(pbuf[cursor]),
+                      &mlen) ;
+              cursor += typelen*mlen ;
+            }
+            else
+            {
+              for ( ig = 0 ; ig < mlen ; ig++ )
+              {
+                bcopy(&(rbuf[typelen*(ig+jg*req->glen[0])]),
+                      &(pbuf[cursor]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO2D_JI :
+            if ( req->type == RSL_REAL )
+            {
+              for ( ig = 0 ; ig < mlen ; ig++ )
+              {
+                bcopy(&(rbuf[typelen*(jg+ig*req->glen[0])]),
+                      &(pbuf[cursor]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO3D_IJK :
+            if ( req->type == RSL_REAL )
+            {
+              ig = 0 ;
+              for ( k = 0 ; k < req->glen[2] ; k++ )
+              {
+                VRCOPY (&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                        &(pbuf[cursor]),
+                        &mlen) ;
+                cursor += typelen*mlen ;
+              }
+            }
+            else
+            {
+              for ( k = 0 ; k < req->glen[2] ; k++ )
+              {
+                for ( ig = 0 ; ig < mlen ; ig++ )
+                {
+                  bcopy(&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                        &(pbuf[cursor]),
+                        typelen) ;
+                  cursor += typelen ;
+                }
+              }
+            }
+            break ;
+          case IO3D_JIK :
+            for ( ig = 0 ; ig < mlen ; ig++ )
+            {
+              for ( k = 0 ; k < req->glen[2] ; k++ )
+              {
+                bcopy(&(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
+                      &(pbuf[cursor]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO3D_KIJ :
+            for ( ig = 0 ; ig < mlen ; ig++ )
+            {
+              for ( k = 0 ; k < req->glen[0] ; k++ )
+              {
+                bcopy(&(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
+                      &(pbuf[cursor]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO3D_IKJ :
+            for ( ig = 0 ; ig < mlen ; ig++ )
+            {
+              for ( k = 0 ; k < req->glen[1] ; k++ )
+              {
+                bcopy(&(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
+                      &(pbuf[cursor]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+
+        }
+      }
+    }
+#endif
+    mdest = rsl_c_comp2phys_proc( P ) ;
+    mtag = MTYPE_FROMTO( MSG_READ_RESPONSE, rsl_myproc, mdest ) ;
+    msglen = sizeof( resp ) ;
+
+#ifndef T3D
+     { int i, j  ;
+       for ( i = 0 ; i < msglen ; i++ )
+       {
+         j = j + pbuf[i] ;
+       }
+       dumdebug(j) ;
+     }
+#endif
+
+
+    if ( rsl_myproc == mdest )
+    {
+      bcopy( &resp, resp_me, msglen ) ;
+      *pbuf_me = pbuf ;
+    }
+    else
+    {
+      RSL_SEND( &resp, msglen, mtag, mdest ) ;
+      msglen = resp.tofollow ;
+      RSL_SEND( pbuf, msglen, mtag, mdest ) ;
+      RSL_FREE( pbuf ) ;
+    }
+  }
+
+  RSL_FREE (iptlst) ;   /* 20020524 */
+  RSL_FREE (jptlst) ;   /* 20020524 */
+  RSL_FREE( rbuf ) ;
+  return(0) ;
+}
+
+static int wrt_sock_err = 0 ;
+#ifdef NEC_TUNE
+static int pndomains_init = 0;
+static int pndomains[ RSL_MAXPROC ] ; /* Number of domains for each processor */
+#endif
+
+int
+handle_write_request( req, nelem, psize_me, pbuf_me )
+  rsl_write_req_t * req ;
+  int nelem ;
+  int psize_me ;
+  char * pbuf_me ;
+{
+  int dim, i, k, ig, jg, nbytes ;
+  int columnelems, typelen, len, cursor  ;
+  int P ;
+  int minelems, majelems ;
+  int msglen, mtag, mtag2, mdest, mfrom ;
+  int mlen, nlen ;
+  rsl_read_resp_t resp ;
+  int psize[ RSL_MAXPROC ] ;    /* size of messages to each processor */
+  float * pr , * qr ;
+  char * wbuf ;
+  char *pbuf ;
+  rsl_point_t *domain ;
+  int is_write, ie_write, js_write, je_write ;
+  int in_write ;
+#ifdef NEC_TUNE
+  int tcursor ;
+  int j ;
+#endif
+
+  typelen = elemsize( req->type ) ;
+  nbytes = typelen * nelem ;
+  wbuf = RSL_MALLOC( char, nbytes ) ;  
+
+  mlen = domain_info[req->domain].len_m ;
+  nlen = domain_info[req->domain].len_n ;
+  domain = domain_info[req->domain].domain ;
+
+  /* global record is now stored -- ship it out */
+  switch ( req->iotag )
+  {
+  case IO2D_IJ :
+  case IO2D_IJ_RAW :
+  case IO2D_IJ_PORTAL :
+  case IO2D_IJ_88 :
+    columnelems = 1 ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO2D_JI :
+  case IO2D_JI_RAW :
+  case IO2D_JI_PORTAL :
+  case IO2D_JI_88 :
+    columnelems = 1 ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_IJK :
+  case IO3D_IJK_RAW :
+  case IO3D_IJK_PORTAL :
+  case IO3D_IJK_88 :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO3D_JIK :
+  case IO3D_JIK_RAW :
+  case IO3D_JIK_PORTAL :
+  case IO3D_JIK_88 :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_KIJ :
+    columnelems = req->glen[0] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[2] ;
+    break ;
+  case IO3D_IKJ :
+    columnelems = req->glen[1] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[2] ;
+    break ;
+  default:
+    RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
+  }
+
+  RSL_TEST_ERR( majelems <= 0, "Major dim spec on write is zero or less.") ;
+  RSL_TEST_ERR( minelems <= 0, "Minor dim spec on write is zero or less.") ;
+  if ( majelems > nlen )
+  { sprintf(mess,"Major dim spec on write (%d) greater than global domain defini tion in that dimension (%d)\n",majelems,nlen) ;
+    RSL_TEST_ERR(1,mess) ; }
+  if ( minelems > mlen )
+  { sprintf(mess,"Minor dim spec on write (%d) greater than global domain defini tion in that dimension (%d)\n",minelems,mlen) ;
+    RSL_TEST_ERR(1,mess) ; }
+
+#if !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST))
+#ifndef NEC_TUNE
+  /*  figure out sizes for each processor */
+  pbuf = NULL ;
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )       /* 95/02/22 */
+  {
+    psize[i] = (regular_decomp)?(4*sizeof(int)):0 ;
+  }
+  for ( jg = 0 ; jg < majelems ; jg++ )
+  {
+    for ( ig = 0 ; ig < minelems ; ig++ )
+    {
+      psize[domain[INDEX_2(jg,ig,mlen)].P] += columnelems * typelen ;
+    }
+  }
+#else
+  pbuf = NULL ;
+/*
+   NECNOTE:
+   Count the number of domains allocated to each processor.
+*/
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )
+  {
+    pndomains[i] = 0 ;
+  }
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )
+  {
+    j = 0 ;
+    for ( jg = 0 ; jg < majelems ; jg++ )
+    {
+      for ( ig = 0 ; ig < minelems ; ig++ )
+      {
+        if( domain[INDEX_2(jg,ig,mlen)].P == i )
+        {
+          j++ ;
+        }
+      }
+    }
+    pndomains[i] = j ;
+  }
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )
+  {
+    psize[i] = ((regular_decomp)?(4*sizeof(int)):0) + pndomains[i]*columnelems*typelen ;
+  }
+#endif
+#else /* !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST)) */
+  pbuf = NULL ;
+  if ( ! pndomains_init )
+  {
+/*
+   NECNOTE:
+   Count the number of domains allocated to each processor.
+*/
+    for ( i = 0 ; i < rsl_nproc_all ; i++ )
+    {
+      pndomains[i] = 0 ;
+    }
+    for ( i = 0 ; i < rsl_nproc_all ; i++ )
+    {
+      j = 0 ;
+      for ( jg = 0 ; jg < majelems ; jg++ )
+      {
+        for ( ig = 0 ; ig < minelems ; ig++ )
+        {
+          if( domain[INDEX_2(jg,ig,mlen)].P == i )
+          {
+            j++ ;
+          }
+        }
+      }
+      pndomains[i] = j ;
+    }
+  }
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )
+  {
+    psize[i] = ((regular_decomp)?(4*sizeof(int)):0) + pndomains[i]*columnelems*typelen ;
+  }
+#endif /* !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST)) */
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )       /* 95/02/22 */
+  {
+    cursor = 0 ;
+    mdest = rsl_c_comp2phys_proc( P ) ;
+    if ( rsl_myproc != mdest )
+    {
+#ifdef RSL_SYNCIO
+      /* send a short "go ahead" message */
+      msglen = 1 ;
+      mfrom = mdest ;
+      mtag2 = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, rsl_myproc, mfrom ) ;
+      RSL_SEND( " ", msglen, mtag2, mfrom ) ;
+#endif
+      msglen = psize[P] ;
+      pbuf = RSL_MALLOC( char, msglen ) ;
+      mfrom = mdest ;
+      mtag2 = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, mfrom, rsl_myproc ) ;
+      RSL_RECV( pbuf, msglen, mtag2 ) ;
+    }
+    else
+    {
+      sprintf(mess,"psize_me (%d) != psize[P] (%d)", psize_me,psize[P]) ;
+      RSL_TEST_ERR( psize_me != psize[P], mess ) ;
+      msglen = psize_me ;
+      pbuf = pbuf_me ;
+    }
+
+    if ( regular_decomp )
+    {
+
+      bcopy( &(pbuf[cursor]), &is_write, sizeof(int) ) ; cursor += sizeof(int) ;
+      bcopy( &(pbuf[cursor]), &ie_write, sizeof(int) ) ; cursor += sizeof(int) ;
+      bcopy( &(pbuf[cursor]), &js_write, sizeof(int) ) ; cursor += sizeof(int) ;
+      bcopy( &(pbuf[cursor]), &je_write, sizeof(int) ) ; cursor += sizeof(int) ;
+
+      in_write = ie_write - is_write + 1 ;
+
+      for ( jg = js_write ; jg <= je_write ; jg++ )
+      {
+        switch ( req->iotag )
+        {
+          case IO2D_IJ :
+          case IO2D_IJ_RAW :
+          case IO2D_IJ_PORTAL :
+          case IO2D_IJ_88 :
+            if ( req->type == RSL_REAL )
+            {
+               ig = is_write ;
+               VRCOPY ( &(pbuf[cursor]),
+                       &(wbuf[typelen*(ig+jg*req->glen[0])]),
+                       &in_write ) ;
+               cursor += in_write*typelen ;
+            }
+            else
+            {
+              for ( ig = is_write ; ig <= ie_write ; ig++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(ig+jg*req->glen[0])]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO2D_JI :
+          case IO2D_JI_RAW :
+          case IO2D_JI_PORTAL :
+          case IO2D_JI_88 :
+            for ( ig = is_write ; ig <= ie_write ; ig++ )
+            {
+              bcopy(&(pbuf[cursor]),
+                    &(wbuf[typelen*(jg+ig*req->glen[0])]),
+                    typelen) ;
+              cursor += typelen ;
+            }
+            break ;
+          case IO3D_IJK :
+          case IO3D_IJK_RAW :
+          case IO3D_IJK_PORTAL :
+          case IO3D_IJK_88 :
+            if ( req->type == RSL_REAL )
+            {
+              ig = is_write ;
+              for ( k = 0 ; k < req->glen[2] ; k++ )   /* note reversal of i and k on vpp */
+              {
+                VRCOPY ( &(pbuf[cursor]),
+                        &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                        &in_write ) ;
+                cursor += typelen*in_write ;
+              }
+            }
+            else
+            {
+              for ( k = 0 ; k < req->glen[2] ; k++ )   /* note reversal of i and k on vpp */
+              {
+                for ( ig = is_write ; ig <= ie_write ; ig++ )
+                {
+                  bcopy(&(pbuf[cursor]),
+                        &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                        typelen) ;
+                  cursor += typelen ;
+                }
+              }
+            }
+            break ;
+          case IO3D_JIK :
+          case IO3D_JIK_RAW :
+          case IO3D_JIK_PORTAL :
+          case IO3D_JIK_88 :
+            for ( k = 0 ; k < req->glen[2] ; k++ )
+            {
+              for ( ig = is_write ; ig <= ie_write ; ig++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO3D_KIJ :
+            for ( ig = is_write ; ig <= ie_write ; ig++ )
+            {
+              for ( k = 0 ; k < req->glen[0] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+            break ;
+          case IO3D_IKJ :
+#ifndef NEC_TUNE
+            for ( ig = is_write ; ig <= ie_write ; ig++ )
+            {
+              for ( k = 0 ; k < req->glen[1] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+            }
+#else
+            for ( k = 0 ; k < req->glen[1] ; k++ )
+            {
+              tcursor = cursor + (k * typelen) ;
+              copymem(&(pbuf[tcursor]), typelen*req->glen[1],
+                &(wbuf[typelen*(is_write+req->glen[0]*(k+jg*req->glen[1]))]), typelen,
+                typelen, ie_write-is_write+1) ;
+            }
+            cursor += (ie_write-is_write+1)*req->glen[1]*typelen ;
+#endif
+            break ;
+        }
+      }
+    }
+    else
+    {
+      for ( jg = 0 ; jg < majelems ; jg++ )
+      {
+        for ( ig = 0 ; ig < minelems ; ig++ )
+        {
+          if ( domain[INDEX_2(jg,ig,mlen)].P == P )
+          {
+            switch ( req->iotag )
+            {
+            case IO2D_IJ :
+            case IO2D_IJ_RAW :
+            case IO2D_IJ_PORTAL :
+            case IO2D_IJ_88 :
+              bcopy(&(pbuf[cursor]),
+                    &(wbuf[typelen*(ig+jg*req->glen[0])]),
+                    typelen) ;
+              cursor += typelen ;
+              break ;
+            case IO2D_JI :
+            case IO2D_JI_RAW :
+            case IO2D_JI_PORTAL :
+            case IO2D_JI_88 :
+              bcopy(&(pbuf[cursor]),
+                    &(wbuf[typelen*(jg+ig*req->glen[0])]),
+                    typelen) ;
+              cursor += typelen ;
+              break ;
+            case IO3D_IJK :
+            case IO3D_IJK_RAW :
+            case IO3D_IJK_PORTAL :
+            case IO3D_IJK_88 :
+              for ( k = 0 ; k < req->glen[2] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+              break ;
+            case IO3D_JIK :
+            case IO3D_JIK_RAW :
+            case IO3D_JIK_PORTAL :
+            case IO3D_JIK_88 :
+              for ( k = 0 ; k < req->glen[2] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+              break ;
+            case IO3D_KIJ :
+              for ( k = 0 ; k < req->glen[0] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+              break ;
+            case IO3D_IKJ :
+              for ( k = 0 ; k < req->glen[1] ; k++ )
+              {
+                bcopy(&(pbuf[cursor]),
+                      &(wbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
+                      typelen) ;
+                cursor += typelen ;
+              }
+              break ;
+
+            }
+          }
+        }
+      }
+    }
+    if ( rsl_myproc != rsl_c_comp2phys_proc( P ) ) 
+    {
+      RSL_FREE( pbuf ) ;   /* the monitor frees its own buffer outside
+                              this routine */
+    }
+  }
+
+  /* mark the unit as needing to be flushed */
+  if ( ! req->internal )
+  {
+    unit_written[ req->unit - 1 ] = (unsigned char) 1 ;
+  }
+
+/* start 981228 AFWA_IO */
+/* need some kind of graceful failure if the node runs out of memory */
+  if ( rsl_buffer_output && ! req->internal )
+  {
+    if ( write_buffer_head == NULL && write_buffer_tail == NULL )
+    {
+      write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_head ;
+    }
+    else
+    {
+      write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_tail->next ;
+    }
+    write_buffer_tail->req       = *req ;
+    write_buffer_tail->nelem     = nelem ;
+    write_buffer_tail->buf       = RSL_MALLOC( char, nelem * elemsize( req->type ) ) ;
+    bcopy( wbuf, write_buffer_tail->buf, nelem * elemsize( req->type ) ) ;
+  }
+  else
+  {
+    send_to_output_device( req, wbuf, nelem ) ;
+  }
+  RSL_FREE( wbuf ) ;
+  return(0) ;
+}
+
+
+/* these routines added for MM5 v3 */
+
+
+RSL_WRITE_1D_DATA( unit_p,
+                   buf,
+                   nbuf_p,
+                   type_p  )
+  int_p  unit_p ;
+  char * buf             ;  int_p nbuf_p   ;
+  int_p  type_p ;
+{
+  rsl_write_req_t req ;
+  int nelem ;
+  int icurs ;
+  char * wbuf ;
+  int i_am_monitor ;
+  int type, typelen ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+  if ( ! i_am_monitor ) return ;
+
+  nelem = *nbuf_p ;
+  type = *type_p ;
+  typelen = elemsize( type ) ;
+          
+  req.internal     = 0 ;
+  req.request_type = RSL_WRITE_REQUEST ;
+  req.request_mode = MSG_IO_FORTRAN    ;
+  req.unit         = *unit_p           ;
+  req.unit_p       = unit_p            ;
+  req.iotag        = IO_REPL           ;
+  req.type         = type     ;
+
+  wbuf             = RSL_MALLOC( char, nelem*typelen ) ;
+
+  icurs = 0 ;
+  bcopy( buf  , wbuf, nelem*typelen ) ;
+
+  if ( rsl_buffer_output && ! req.internal )
+  {
+    if ( write_buffer_head == NULL && write_buffer_tail == NULL )
+    {
+      write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_head ;
+    }
+    else
+    {
+      write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_tail->next ;
+    }
+    write_buffer_tail->req       = req ;
+    write_buffer_tail->nelem     = nelem ;
+    write_buffer_tail->buf       = RSL_MALLOC( char, nelem*typelen ) ;
+    bcopy( wbuf, write_buffer_tail->buf, nelem*typelen ) ;
+  }
+  else
+  {
+    send_to_output_device( &req, wbuf, nelem ) ;
+  }
+
+  RSL_FREE( wbuf ) ;
+}
+
+send_to_output_device( req, wbuf, nelem )
+  rsl_write_req_t * req ;
+  char * wbuf ;
+  int nelem ;
+{
+
+  int nbytes, typelen, minelems, majelems, columnelems ;
+  int ig, jg ;
+
+  typelen = elemsize( req->type ) ;
+  nbytes = typelen * nelem ;
+
+  /* global record is now stored -- ship it out */
+  switch ( req->iotag )
+  {
+  case IO2D_IJ :
+  case IO2D_IJ_RAW :
+  case IO2D_IJ_PORTAL :
+  case IO2D_IJ_88 :
+    columnelems = 1 ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO2D_JI :
+  case IO2D_JI_RAW :
+  case IO2D_JI_PORTAL :
+  case IO2D_JI_88 :
+    columnelems = 1 ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_IJK :
+  case IO3D_IJK_RAW :
+  case IO3D_IJK_PORTAL :
+  case IO3D_IJK_88 :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[1] ;
+    break ;
+  case IO3D_JIK :
+  case IO3D_JIK_RAW :
+  case IO3D_JIK_PORTAL :
+  case IO3D_JIK_88 :
+    columnelems = req->glen[2] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[0] ;
+    break ;
+  case IO3D_KIJ :
+    columnelems = req->glen[0] ;
+    minelems = req->glen[1] ;
+    majelems = req->glen[2] ;
+    break ;
+  case IO3D_IKJ :
+    columnelems = req->glen[1] ;
+    minelems = req->glen[0] ;
+    majelems = req->glen[2] ;
+    break ;
+  case IO_REPL :
+    break ;
+  default:
+    RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
+  }
+
+  if ( req->request_mode == MSG_IO_FORTRAN )
+  {
+
+  /* call fortran to write a record to the named unit */
+    if ( req->internal )
+    {
+      bcopy( wbuf, req->unit_p, nbytes ) ;
+    }
+    else
+    {
+      /* call fortran to write a record to the named unit */
+      switch ( req->type )
+      {
+      case RSL_REAL :
+        FORT_REALWRITE ( &(req->unit), wbuf, &nelem ) ;
+        break ;
+      case RSL_INTEGER :
+        FORT_INTWRITE ( &(req->unit), wbuf, &nelem ) ;
+        break ;
+#ifndef T3D
+      case RSL_DOUBLE :
+        FORT_DOUBLEWRITE ( &(req->unit), wbuf, &nelem ) ;
+        break ;
+#endif
+      case RSL_COMPLEX :
+        FORT_COMPLEXWRITE ( &(req->unit), wbuf, &nelem ) ;
+        break ;
+      case RSL_CHARACTER :
+#ifndef T3D
+        FORT_CHARACTERWRITE ( &(req->unit), wbuf, &nelem ) ;
+#else
+        {
+          _fcd x ;
+          x = _cptofcd( wbuf, nelem ) ;
+          FORT_CHARACTERWRITE ( &(req->unit), x, &nelem ) ;
+        }
+#endif
+        break ;
+      default :
+        RSL_TEST_WRN(1,"write operation not implemented for this data type") ;
+      }
+    }
+  }
+  else
+  if ( req->request_mode == MSG_IO_SOCKET )
+  {
+    /* nbytes contains the number of bytes to be written,
+       wbuf is the buffer to be written,
+       req->unit is the socket id */
+
+    int cw ;
+    struct hdr_info_3d
+    {
+       int  typelen, xdim, ydim, zdim;
+    } wbuf_header ;
+
+    if ( req->request_mode2 == MSG_MODE2_RAW )
+    {
+      if ( write_sock( req->unit, wbuf, nbytes ) < 0 )
+      {
+        perror("writing on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+    }
+    else
+    if ( req->request_mode2 == MSG_MODE2_FORTRAN )
+    {
+      /* simulate control words at beginning and end */
+      cw = nbytes ;
+
+      if (write_sock(req->unit , &cw, 4)  < 0)
+      {
+        perror("writing first control word on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+      if (write_sock(req->unit , wbuf, nbytes )  < 0)
+      {
+        perror("writing wbuf on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+      if (write_sock(req->unit , &cw, 4)  < 0)
+      {
+        perror("writing second control word on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+    }
+    else
+    if ( req->request_mode2 == MSG_MODE2_PORTAL )
+    {
+      wbuf_header.typelen = typelen ;
+      wbuf_header.xdim  = minelems ;
+      wbuf_header.ydim  = majelems ;
+      wbuf_header.zdim  = columnelems ;
+      if (write_sock(req->unit , &wbuf_header , sizeof( wbuf_header ) )  < 0)
+      {
+        perror("writing wbuf header on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+      if (write_sock(req->unit , wbuf , nbytes )  < 0)
+      {
+        perror("writing wbuf header on socket");
+        RSL_TEST_WRN(1,"") ;
+      }
+    }
+    else
+    if ( req->request_mode2 == MSG_MODE2_88 )
+    {
+      int x,y,z ;
+      char outline[256] ;
+      for ( z = 0; z < columnelems ; z++ )
+      {
+        sprintf(outline,"%d %d\n",majelems,minelems) ;
+        if (write_sock(req->unit , outline , strlen( outline ) )  < 0)
+        {
+          if ( ! wrt_sock_err )
+          {
+            wrt_sock_err = 1 ;
+            perror("writing wbuf header on socket");
+            RSL_TEST_WRN(1,"") ;
+          }
+        }
+        else
+        {
+        for ( ig = 0 ; ig < minelems ; ig++ )
+        {
+          for ( jg = 0 ; jg < majelems ; jg++ )
+          {
+            if ( req->type == RSL_REAL )
+            {
+               float a ;
+               bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(float)) ;
+               sprintf(outline,"%g\n",a) ;
+            }
+            else if ( req->type == RSL_DOUBLE )
+            {
+               double a ;
+               bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(double)) ;
+               sprintf(outline,"%g\n",a) ;
+            }
+            else if ( req->type == RSL_INTEGER )
+            {
+               int a ;
+               bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(int)) ;
+               sprintf(outline,"%d\n",a) ;
+            }
+            if (write_sock(req->unit , outline , strlen(outline) )  < 0)
+            {
+              if ( ! wrt_sock_err )
+              {
+                wrt_sock_err = 1 ;
+                perror("writing wbuf header on socket");
+                RSL_TEST_WRN(1,"") ;
+              }
+            }
+          }
+        }
+        }
+      }
+    }
+    else
+    {
+      sprintf(mess, "Unknown request request_mode2: %d\n",
+              req->request_mode2 ) ;
+      RSL_TEST_ERR(1,mess) ;
+    }
+  }
+  else
+  {
+    sprintf(mess, "Unknown request request_mode: %d\n",
+                  req->request_mode ) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+}
+
+RSL_OUTPUT_BUFFER_WRITE ()
+{
+  int i_am_monitor ;
+  rsl_write_buffer_struct_t * p, * old ;
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  if ( rsl_buffer_output && i_am_monitor && write_buffer_head != NULL )
+  {
+    for ( p = write_buffer_head ; p ; )
+    {
+      send_to_output_device( &(p->req), p->buf, p->nelem ) ;
+      RSL_FREE( p->buf ) ;
+      old = p ;
+      p = p->next ;
+      RSL_FREE( old ) ;
+    }
+  }
+  write_buffer_head = NULL  ;
+  write_buffer_tail = NULL  ;
+}
+
+RSL_OUTPUT_BUFFER_YES ()
+{
+  rsl_buffer_output = 1 ;
+}
+RSL_OUTPUT_BUFFER_NO ()
+{
+  rsl_buffer_output = 0 ;
+}
+
+RSL_IO_NODE_YES ()
+{
+  rsl_io_node = 1 ;
+}
+RSL_IO_NODE_NO ()
+{
+  rsl_io_node = 0 ;
+}
+
+
+
+#include 
+
+write_sock( sd, buf, n )
+  int sd ;
+  char * buf ;
+  int n ;
+{
+  static int errseen = 0 ;
+  int todo, n_written ;
+  char * p ;
+
+  signal( SIGPIPE, SIG_IGN ) ;  /* if the receiver dies, we should cont */
+  todo = n ;
+  p = buf ;
+  if ( ! errseen )
+    do {
+      if ((n_written = write(sd, p, todo)) < 0 )
+      {
+        errseen = 1 ;
+        perror("write_sock") ;
+        return( n_written ) ;
+      }
+      p += n_written ;
+      todo -= n_written ;
+    } while ( todo > 0 ) ;
+  signal( SIGPIPE, SIG_DFL ) ;
+
+  return(n) ;
+}
+
+/* On vpp from here to remainder of file, we may be bcopying character strings
+   so undefine the substution to the vector bcopy */
+#if defined(vpp) || defined(vpp2)
+#undef bcopy
+#endif
+
+
+RSL_WRITE_MM5V3_SM_HEADER( unit_p,ndim_p,
+                        s1_p,s2_p,s3_p,s4_p,
+                        e1_p,e2_p,e3_p,e4_p,
+                        iwordsize_p,
+                        xtime_p,
+                        rwordsize_p,
+                        staggering_p,     nstaggering_p,
+                        ordering_p,       nordering_p,
+                        current_date_p,   ncurrent_date_p,
+                        name_p,           nname_p,
+                        units_p,          nunits_p,
+                        description_p,    ndescription_p )
+  int_p unit_p ;
+  int_p ndim_p ;
+  int_p s1_p, s2_p, s3_p, s4_p ;
+  int_p e1_p, e2_p, e3_p, e4_p ;
+  int_p  iwordsize_p ;
+  char * xtime_p ;
+  int_p  rwordsize_p ;
+#ifndef T3D
+  char * staggering_p     ;  int_p nstaggering_p   ;
+  char * ordering_p       ;  int_p nordering_p      ;
+  char * current_date_p   ;  int_p ncurrent_date_p  ;
+  char * name_p           ;  int_p nname_p          ;
+  char * units_p          ;  int_p nunits_p         ;
+  char * description_p    ;  int_p ndescription_p   ;
+#else
+  _fcd staggering_p     ;  int_p nstaggering_p   ;
+  _fcd ordering_p       ;  int_p nordering_p      ;
+  _fcd current_date_p   ;  int_p ncurrent_date_p  ;
+  _fcd name_p           ;  int_p nname_p          ;
+  _fcd units_p          ;  int_p nunits_p         ;
+  _fcd description_p    ;  int_p ndescription_p   ;
+#endif
+{
+  rsl_write_req_t req ;
+  int nelem ;
+  int iwordsize ;
+  int rwordsize ;
+  int nstringbytes ;
+  int icurs ;
+  char * wbuf ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+  if ( ! i_am_monitor ) return ;
+
+  iwordsize = *iwordsize_p ;
+  rwordsize = *rwordsize_p ;
+  nstringbytes =  *nstaggering_p+ *nordering_p+ *ncurrent_date_p
+                + *nname_p+ *nunits_p+ *ndescription_p ;
+#ifndef T3D
+  nelem = 9 * iwordsize + 1 * rwordsize + nstringbytes ;
+#else
+  nelem = 9 * iwordsize/2 + 1 * rwordsize/2 + nstringbytes ;
+#endif
+
+  req.internal     = 0 ;
+  req.request_type = RSL_WRITE_REQUEST ;
+  req.request_mode = MSG_IO_FORTRAN    ;
+  req.unit         = *unit_p           ;
+  req.unit_p       = unit_p            ;
+  req.iotag        = IO_REPL           ;
+  req.type         = RSL_CHARACTER     ;
+
+  wbuf       = RSL_MALLOC( char, nelem ) ;
+
+  icurs = 0 ;
+#ifndef T3D
+  bcopy( ndim_p, &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( s1_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( s2_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( s3_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( s4_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( e1_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( e2_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( e3_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+  bcopy( e4_p  , &(wbuf[icurs]), iwordsize ) ;   icurs += iwordsize ;
+# ifdef SWAPBYTES
+  rsl_swapbytes( wbuf, iwordsize, 9 ) ;
+# endif
+#else
+#ifdef crayx1
+  { int i ;
+#else
+  { short i ;
+#endif
+    i = *ndim_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *s1_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *s2_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *s3_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *s4_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *e1_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *e2_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *e3_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+    i = *e4_p   ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ;   icurs += iwordsize/2 ;
+  }
+# ifdef SWAPBYTES
+  rsl_swapbytes( wbuf, iwordsize/2, 9 ) ;
+# endif
+#endif
+
+#ifndef T3D
+  bcopy( xtime_p  , &(wbuf[icurs]), rwordsize ) ;  
+# ifdef SWAPBYTES
+  rsl_swapbytes( &(wbuf[icurs]), rwordsize, 1 ) ;
+# endif
+  icurs += rwordsize ;
+#else
+  { float x ; double y ;
+    bcopy( xtime_p, &y, rwordsize ) ;
+    x = y ;
+    bcopy( &x  , &(wbuf[icurs]), rwordsize/2 ) ;
+  }
+# ifdef SWAPBYTES
+  rsl_swapbytes( &(wbuf[icurs]), rwordsize/2, 1 ) ;
+# endif
+  icurs += rwordsize/2 ;
+#endif
+
+#ifndef T3D
+  bcopy( staggering_p   , &(wbuf[icurs]),
+                                 *nstaggering_p ) ;          icurs += *nstaggering_p ;
+  bcopy( ordering_p     , &(wbuf[icurs]),
+                                 *nordering_p    ) ;         icurs += *nordering_p   ;
+  bcopy( current_date_p , &(wbuf[icurs]),
+                                 *ncurrent_date_p    ) ;     icurs += *ncurrent_date_p   ;
+  bcopy( name_p         , &(wbuf[icurs]),
+                                 *nname_p    ) ;             icurs += *nname_p   ;
+  bcopy( units_p        , &(wbuf[icurs]),
+                                 *nunits_p    ) ;            icurs += *nunits_p   ;
+  bcopy( description_p  , &(wbuf[icurs]),
+                                 *ndescription_p    ) ;      icurs += *ndescription_p   ;
+#else
+  bcopy( _fcdtocp( staggering_p )  , &(wbuf[icurs]),
+                                 *nstaggering_p ) ;          icurs += *nstaggering_p ;
+  bcopy( _fcdtocp( ordering_p )    , &(wbuf[icurs]),
+                                 *nordering_p    ) ;         icurs += *nordering_p   ;
+  bcopy( _fcdtocp( current_date_p ), &(wbuf[icurs]),
+                                 *ncurrent_date_p    ) ;     icurs += *ncurrent_date_p   ;
+  bcopy( _fcdtocp( name_p )        , &(wbuf[icurs]),
+                                 *nname_p    ) ;             icurs += *nname_p   ;
+  bcopy( _fcdtocp( units_p )       , &(wbuf[icurs]),
+                                 *nunits_p    ) ;            icurs += *nunits_p   ;
+  bcopy( _fcdtocp( description_p ) , &(wbuf[icurs]),
+                                 *ndescription_p    ) ;      icurs += *ndescription_p   ;
+#endif
+
+  if ( rsl_buffer_output && ! req.internal )
+  {
+    if ( write_buffer_head == NULL && write_buffer_tail == NULL )
+    {
+      write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_head ;
+    }
+    else
+    {
+      write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_tail->next ;
+    }
+    write_buffer_tail->req       = req ;
+    write_buffer_tail->nelem     = nelem ;
+    write_buffer_tail->buf       = RSL_MALLOC( char, nelem ) ;
+    bcopy( wbuf, write_buffer_tail->buf, nelem ) ;
+  }
+  else
+  {
+    send_to_output_device( &req, wbuf, nelem ) ;
+  }
+
+  RSL_FREE( wbuf ) ;
+}
+
+rsl_swapbytes ( buf, wordsz, nwords )
+  char * buf ;
+  int wordsz, nwords ;
+{
+  char tbuf[8] ;
+  int i ;
+
+  if ( wordsz == 4 )
+  {
+    for ( i = 0 ; i < nwords*wordsz ; i += wordsz  )   
+    {
+      tbuf[0] = buf[3+i] ;
+      tbuf[1] = buf[2+i] ;
+      tbuf[2] = buf[1+i] ;
+      tbuf[3] = buf[0+i] ;
+      buf[0+i] = tbuf[0] ;
+      buf[1+i] = tbuf[1] ;
+      buf[2+i] = tbuf[2] ;
+      buf[3+i] = tbuf[3] ;
+    }
+  }
+  else if ( wordsz == 8 )
+  {
+    for ( i = 0 ; i < nwords*wordsz ; i += wordsz )   
+    {
+      tbuf[0] = buf[7+i] ;
+      tbuf[1] = buf[6+i] ;
+      tbuf[2] = buf[5+i] ;
+      tbuf[3] = buf[4+i] ;
+      tbuf[4] = buf[3+i] ;
+      tbuf[5] = buf[2+i] ;
+      tbuf[6] = buf[1+i] ;
+      tbuf[7] = buf[0+i] ;
+      buf[0+i] = tbuf[0] ;
+      buf[1+i] = tbuf[1] ;
+      buf[2+i] = tbuf[2] ;
+      buf[3+i] = tbuf[3] ;
+      buf[4+i] = tbuf[4] ;
+      buf[5+i] = tbuf[5] ;
+      buf[6+i] = tbuf[6] ;
+      buf[7+i] = tbuf[7] ;
+    }
+  }
+  else
+  {
+    sprintf(mess,"invalid argument wordsz = %d",wordsz) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+}
+
+RSL_WRITE_MM5V3_BIG_HEADER( unit_p,
+                         ibuf,nibuf_p,
+                         rbuf,nrbuf_p,
+                         cb1,ncb1_p, 
+                         cb2,ncb2_p,
+                         iwordsize_p,rwordsize_p )
+  int_p  unit_p ;
+  char * ibuf             ;  int_p nibuf_p   ;
+  char * rbuf             ;  int_p nrbuf_p   ;
+#ifndef T3D
+  char * cb1              ;  int_p ncb1_p    ;
+  char * cb2              ;  int_p ncb2_p    ;
+#else
+  _fcd   cb1              ;  int_p ncb1_p    ;
+  _fcd   cb2              ;  int_p ncb2_p    ;
+#endif
+  int_p  iwordsize_p ;
+  int_p  rwordsize_p ;
+{
+  rsl_write_req_t req ;
+  int nelem ;
+  int iwordsize ;
+  int rwordsize ;
+  int nstringbytes ;
+  int icurs ;
+  char * wbuf ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+  if ( ! i_am_monitor ) return ;
+
+  iwordsize = *iwordsize_p ;
+  rwordsize = *rwordsize_p ;
+
+#ifndef T3D
+  nelem = *nibuf_p * iwordsize + 
+          *nrbuf_p * rwordsize +
+          *ncb1_p + *ncb2_p ;
+#else
+  nelem = *nibuf_p * iwordsize /2 + 
+          *nrbuf_p * rwordsize /2 +
+          *ncb1_p + *ncb2_p ;
+#endif
+          
+  req.internal     = 0 ;
+  req.request_type = RSL_WRITE_REQUEST ;
+  req.request_mode = MSG_IO_FORTRAN    ;
+  req.unit         = *unit_p           ;
+  req.unit_p       = unit_p            ;
+  req.iotag        = IO_REPL           ;
+  req.type         = RSL_CHARACTER     ;
+
+  wbuf       = RSL_MALLOC( char, nelem ) ;
+
+  icurs = 0 ;
+#ifdef SWAPBYTES
+  rsl_swapbytes( ibuf, iwordsize, *nibuf_p ) ;
+#endif
+#ifndef T3D
+  bcopy( ibuf  , &(wbuf[icurs]), *nibuf_p * iwordsize ) ;
+  icurs += *nibuf_p * iwordsize ;
+#else
+#ifdef crayx1
+  { long *p ; int *q ; int i ;
+    p = (long *) ibuf ;
+    q = (int *) ibuf ;
+#else
+  { long *p ; short *q ; int i ;
+    p = (long *) ibuf ;
+    q = (short *) ibuf ;
+#endif
+    for ( i = 0 ; i < *nibuf_p ; i++ )
+    {
+      *q = *p ; q++ ; p++ ;
+    }
+  }
+  bcopy( ibuf  , &(wbuf[icurs]), *nibuf_p * iwordsize /2 ) ;
+  icurs += *nibuf_p * iwordsize / 2 ;
+#endif
+#ifdef SWAPBYTES
+  rsl_swapbytes( rbuf, rwordsize, *nrbuf_p ) ;
+#endif
+#ifndef T3D
+  bcopy( rbuf  , &(wbuf[icurs]), *nrbuf_p * rwordsize ) ;
+  icurs += *nrbuf_p * rwordsize ;
+#else
+  { double *p ; float *q ; int i ;
+    p = (double *) rbuf ;
+    q = (float *) rbuf ;
+    for ( i = 0 ; i < *nrbuf_p ; i++ )
+    {
+      *q = *p ; q++ ; p++ ;
+    }
+  }
+  bcopy( rbuf  , &(wbuf[icurs]), *nrbuf_p * rwordsize /2 ) ;
+  icurs += *nrbuf_p * rwordsize / 2 ;
+#endif
+#ifndef T3D
+  bcopy( cb1   , &(wbuf[icurs]), *ncb1_p   ) ;   icurs += *ncb1_p ;
+  bcopy( cb2   , &(wbuf[icurs]), *ncb2_p   ) ;   icurs += *ncb2_p ;
+#else
+  bcopy( _fcdtocp( cb1 ), &(wbuf[icurs]), *ncb1_p   ) ;   icurs += *ncb1_p ;
+  bcopy( _fcdtocp( cb2 ), &(wbuf[icurs]), *ncb2_p   ) ;   icurs += *ncb2_p ;
+#endif
+  if ( rsl_buffer_output && ! req.internal )
+  {
+    if ( write_buffer_head == NULL && write_buffer_tail == NULL )
+    {
+      write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_head ;
+    }
+    else
+    {
+      write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
+      write_buffer_tail = write_buffer_tail->next ;
+    }
+    write_buffer_tail->req       = req ;
+    write_buffer_tail->nelem     = nelem ;
+    write_buffer_tail->buf       = RSL_MALLOC( char, nelem ) ;
+    bcopy( wbuf, write_buffer_tail->buf, nelem ) ;
+  }
+  else
+  {
+    send_to_output_device( &req, wbuf, nelem ) ;
+  }
+  RSL_FREE( wbuf ) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_malloc.c b/wrfv2_fire/external/RSL/RSL/rsl_malloc.c
new file mode 100755
index 00000000..aa2c1c1b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_malloc.c
@@ -0,0 +1,208 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/*#define PADIT		/* add page at beginning and end of allocation */
+#if 0
+# define BASE_MALLOC   fence_malloc
+# define BASE_FREE     fence_free
+#else
+# define BASE_MALLOC   malloc
+# define BASE_FREE     free
+#endif
+
+#include 
+#include 
+#include 
+#ifdef T3D
+#include 
+#endif
+#include "rsl.h"
+
+/*
+extern int EF_ALIGNMENT;
+extern int EF_PROTECT_BELOW;
+extern int EF_PROTECT_FREE;
+*/
+
+
+static char zero_length_storage[] = "" ;
+
+#if !(defined(vpp) || defined(vpp2) || defined(SUN))
+static struct mallinfo minf ;
+#endif
+
+static char *last_f ;
+static int last_l ;
+static int last_s ;
+
+#ifdef O2K
+static struct mallinfo mallinfo() {} ;
+#endif
+
+void * rsl_malloc(f,l,s)
+   char * f ;
+   int l, s ;
+{
+   char mess[128] ;
+   void *retval ;
+   int s2, tries ;
+
+/*
+EF_PROTECT_BELOW = 0 ;
+EF_PROTECT_FREE = 1 ;
+*/
+
+   if ( s == 0 )
+   {
+     retval = (void *) zero_length_storage ;
+   }
+   else 
+   {
+#ifdef PADIT
+     s2 = s + 1024 ;
+#else
+     s2 = s ;
+#endif
+     tries = 0 ;
+     while ((retval=(void *)BASE_MALLOC(s2))==(void *)NULL)
+     {
+       tries++ ;
+       sprintf(mess,
+"rsl_malloc failed allocating %d bytes, called %s, line %d, try %d\n",
+       s,f,l,tries) ;
+       perror(mess) ;
+#if !(defined(vpp) || defined(vpp2) || defined(SUN))
+       minf = mallinfo() ;
+       fprintf(stderr,"mallinfo: arena %d\n",minf.arena)  ;
+       fprintf(stderr,"mallinfo: ordblks %d\n",minf.ordblks)  ;
+       fprintf(stderr,"mallinfo: smblks %d\n",minf.smblks)  ;
+       fprintf(stderr,"mallinfo: hblks %d\n",minf.hblks)  ;
+       fprintf(stderr,"mallinfo: hblkhd %d\n",minf.hblkhd)  ;
+       fprintf(stderr,"mallinfo: usmblks %d\n",minf.usmblks)  ;
+       fprintf(stderr,"mallinfo: fsmblks %d\n",minf.fsmblks)  ;
+       fprintf(stderr,"mallinfo: uordblks %d\n",minf.uordblks)  ;
+       fprintf(stderr,"mallinfo: fordblks %d\n",minf.fordblks)  ;
+       fprintf(stderr,"mallinfo: keepcost %d\n",minf.keepcost)  ;
+#ifdef SUNINFO
+       fprintf(stderr,"mallinfo: mkfast %d\n",minf.mkfast)  ;
+       fprintf(stderr,"mallinfo: nblks %d\n",minf.nblks)  ;
+       fprintf(stderr,"mallinfo: grain %d\n",minf.grain)  ;
+       fprintf(stderr,"mallinfo: uordbytes %d\n",minf.uordbytes)  ;
+       fprintf(stderr,"mallinfo: allocated %d\n",minf.allocated)  ;
+       fprintf(stderr,"mallinfo: treeoverhead %d\n",minf.treeoverhead)  ;
+#endif
+#endif
+       if ( tries >= 2 )
+       { 
+	 system("lsps -a") ;
+	 sleep(1) ;
+       }
+       if ( tries >= 3 ) 
+       {
+	 system("lsps -a") ;
+	 RSL_FATAL(2) ;
+       }
+     }
+   }
+#if !(defined(vpp)||defined(vpp2)) || defined(sx) || defined(alphavector)
+   if ( s > 0 )
+     bzero( retval, s2 ) ;	/* return zero'd storage always */
+#else
+   if ( s > 0 )
+   { int l, lb ;
+     l = s2/sizeof(int) ;
+     lb = l*sizeof(int) ;
+     vizero_( retval, &l  ) ;
+     l = s2-lb ;
+     vbzero_( retval+lb, &l ) ;	/* return zero'd storage always */
+   }
+#endif
+
+#ifdef PADIT
+   retval = retval + 512 ;
+#endif
+
+#ifdef T3D_COMMENTOUT
+   if ( rsl_myproc == 0 )
+   {
+   if (malloc_check(0))
+   {
+    if ( rsl_myproc == 0 )
+    fprintf(stderr,"%s, %d ---problem from malloc_check--- %d bytes last %s %d %d \n",f,l,s,last_f, last_l, last_s) ;
+    exit(3);
+   }
+   }
+   last_s = s ;
+   last_l = l ;
+   last_f = f ;
+#endif
+
+   return(retval) ;
+}
+
+rsl_free( p )
+   char * p ;
+{
+   if ( p == zero_length_storage ) return ;    /* fix from ANU */
+#ifdef PADIT
+   BASE_FREE ( p-512 ) ;
+#else
+   BASE_FREE ( p ) ;
+#endif
+   p = NULL ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_merge.c b/wrfv2_fire/external/RSL/RSL/rsl_merge.c
new file mode 100755
index 00000000..51818241
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_merge.c
@@ -0,0 +1,1181 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+typedef struct stage_point {
+  char * p ;            /* pointer to buffer for point */
+  int curs ;            /* cursor into point buffer */
+  int P ;               /* processor ID for point */
+  int kid_id ;
+  int parent_id ;
+  int cm ;
+  int cn ;
+  struct stage_point *next ;    /* list pointer */
+} stage_point_t ;
+
+typedef struct nest_info {
+  rsl_index_t ig, jg, cn, cm ;
+  int mother_id ;
+} nest_info_t ;
+
+static destroy_nest_info ( p )
+  char * p ;
+{
+  if ( p != NULL ) RSL_FREE( p ) ;
+}
+
+static rsl_list_t *Xlist = NULL ;
+static stage_point_t *stage = NULL ;
+static int stage_len = 0 ;
+
+static int s_d ;
+static int s_nst ;
+static int s_msize ;
+static int s_nlen ;
+static int s_mlen ;
+static int s_nlen_nst ;
+static int s_mlen_nst ;
+static int s_irax_n ;
+static int s_irax_m ;
+static stage_point_t *Plist[RSL_MAXPROC] ;
+static int Psize[RSL_MAXPROC] ;
+static rsl_domain_info_t *s_dinfo = NULL , *s_ninfo  = NULL ;
+static rsl_point_t *s_ddomain = NULL , *s_ndomain  = NULL ;
+static char *s_child_msgs = NULL ;
+static int s_child_msgs_curs = 0 ;
+static int s_remaining = 0 ;  /* number of bytes left in a child message before
+                           the next point descriptor */
+
+/* add a field to a message outgoing for the specified child domain cell */
+/* relies on rsl_ready_merge having been called already */
+/* sends are specified in terms of coarse domain */
+
+static int s_i, s_j, s_ig, s_jg, s_cm, s_cn,
+           s_pig, s_pjg ;
+
+/*@
+  RSL_TO_PARENT_INFO -- Get the next cell in a packing sequence for feedback.
+
+  Notes:
+  RSL_TO_PARENT_INFO is used in a packing loop to build feedback
+  messages from a nested (Arg2) domain with data from a parent (Arg1),
+  in preparation for a call to RSL_MERGE_MSGS.  For an overview of the
+  mechanism and a detailed example, see RSL_MERGE_MSGS.
+
+  The Arg3 argument gives the size of the child to parent cell messages
+  in bytes.  This may be larger than needed, but never smaller;
+  otherwise the program will abort (to avoid overwriting memory).
+
+  Each call to RSL_TO_PARENT_INFO gives the local (Arg4, Arg5) and
+  global (Arg6, Arg7) indices of a nested point that will send feedback
+  data, the global indices (Arg10, Arg11) of the associated parent
+  cell, and the indices of the nest cell in the set of nest cells
+  associated with the parent (Arg8, Arg9).  These last two are needed
+  to differentiate which of the nest cells associated with the parent
+  is being referred to.  There are IRAX_M by IRAX_N nest points
+  associated with each parent, where IRAX_M is the nesting ratio in the
+  M dimension and IRAX_N is the nesting ratio in the N dimension (See
+  the descriptions for the RSL nest spawning routines RSL_SPAWN...).
+
+  RSL_TO_PARENT_INFO will return a new set of coordinates for every
+  nest point stored locally on the processor.  Each time the routine
+  returns with a valid point, the value of Arg12 will be 1 and RSL will
+  be in a state that is ready to accept data for the point.  The
+  message is constructed using the routine RSL_TO_PARENT_MSG.  The last
+  call will return a value of 0 (zero) in Arg12 indicating there are no
+  more nest points.
+
+  It isn't necessary that anything be done with the coordinates that
+  are returned.  However, once called, RSL_TO_PARENT_INFO must be
+  called as many times as it takes to exhaust the number of points;
+  otherwise the underlying RSL mechanism will not be left in the proper
+  state at the conclusion of the broadcast.
+
+  See also:
+  RSL_MERGE_MSGS, RSL_TO_PARENT_MSG, RSL_FROM_CHILD_INFO
+@*/
+
+RSL_TO_PARENT_INFO ( d_p, n_p, msize_p,
+                     i_p, j_p,
+                     ig_p, jg_p, cm_p, cn_p,
+                     pig_p, pjg_p, retval_p )
+  int_p
+    d_p         /* (I) RSL domain descriptor of parent. */
+   ,n_p         /* (I) RSL domain descriptor of nest. */
+   ,msize_p     /* (I) Message size in bytes. */
+   ,i_p         /* (O) Local M index of nest domain point. */
+   ,j_p         /* (O) Local N index of nest domain point. */
+   ,ig_p        /* (O) Global M index of nest domain point. */
+   ,jg_p        /* (O) Global N index of nest domain point. */
+   ,cm_p        /* (O) M index of child cell beneath parent cell. */
+   ,cn_p        /* (O) N index of child cell beneath parent cell. */
+   ,pig_p       /* (O) Global N index of parent domain point. */
+   ,pjg_p       /* (O) Global N index of parent domain point. */
+   ,retval_p ;  /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
+{
+  rsl_child_info_t *kid ;
+  rsl_list_t *lp ;
+  nest_info_t *dp ;
+  int P ;
+
+  if ( stage == NULL )
+  {
+    rsl_ready_merge( d_p, n_p, msize_p ) ;
+  }
+
+  if (( lp = Xlist) == NULL ) 
+  {
+    *retval_p = -1 ;
+    return ;
+  }
+  Xlist = Xlist->next ;
+  dp = (nest_info_t *)(lp->data) ;
+
+  s_ig = dp->ig ;
+  s_jg = dp->jg ;
+  s_i = s_ig + s_ninfo->idif ;
+  s_j = s_jg + s_ninfo->jdif ;
+  s_cm = dp->cm ;
+  s_cn = dp->cn ;
+  s_pig = ID_IDEX( dp->mother_id ) ;
+  s_pjg = ID_JDEX( dp->mother_id ) ;
+
+  *ig_p = s_ig + 1 ;
+  *jg_p = s_jg + 1;
+  *i_p = s_i + 1 ;
+  *j_p = s_j + 1;
+  *cm_p = s_cm + 1;
+  *cn_p = s_cn + 1;
+  *pig_p = s_pig + 1;
+  *pjg_p = s_pjg + 1;
+
+/*
+this should only be freed when the list is recalculated 960605
+  RSL_FREE(lp) ;
+  RSL_FREE(dp) ;
+*/
+
+  *retval_p = 1 ;
+  return ;
+}
+
+/*@
+  RSL_TO_PARENT_MSG -- Pack feedback data into a message for a parent point.
+
+  Notes:
+  RSL_TO_PARENT_MSG is used in a loop to pack messages for feeding back
+  data from
+  a nested domain to a parent in preparation for
+  a call to RSL_MERGE_MSGS.  For an overview of the mechanism and a detailed
+  example, see RSL_MERGE_MSGS.
+
+  Before calling RSL_TO_PARENT_MSG, RSL must have been put into the
+  correct state; that is, ready to accept data that will be sent to a
+  particular parent domain point.  This is done by first calling
+  RSL_TO_PARENT_INFO.  RSL_TO_PARENT_MSG may be called as many times as
+  necessary to pack data into the message (or not at all, if there is
+  no data for the point returned by RSL_TO_PARENT_INFO).  Each call to
+  RSL_TO_PARENT_MSG copies Arg1 bytes from the bufffer specified by
+  Arg2 into the message, which is allocated by RSL and never
+  manipulated directly by the user program.  The amount of data that
+  can be packed is limited to the message size that was specified in
+  the first call to RSL_TO_PARENT_INFO.
+
+  See also:
+  RSL_MERGE_MSGS, RSL_TO_PARENT_INFO
+
+@*/
+
+RSL_TO_PARENT_MSG ( nbuf_p, buf )
+  int_p
+    nbuf_p ;            /* (I) Number of bytes to be packed. */
+  char *
+    buf ;               /* (I) Buffer containing the data to be packed. */
+{
+  int kiddex ;
+  int nbuf ;
+  int P ;
+
+  RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
+  nbuf = *nbuf_p ;
+  kiddex = INDEX_2(s_jg,s_ig,s_mlen_nst) ;
+  P = s_ndomain[ kiddex ].mother_P ;
+  if ( stage[ kiddex ].p == NULL )
+  {
+    stage[ kiddex ].p = RSL_MALLOC( char, s_msize ) ;
+    stage[ kiddex ].curs = 0 ;
+    stage[ kiddex ].P = P ;
+    stage[kiddex].next = Plist[P] ;
+    Plist[P] =  &(stage[ kiddex ]) ;
+  }
+  if ( stage[ kiddex ].curs + nbuf > s_msize ) 
+  {
+    sprintf(mess,
+    "RSL_TO_PARENT_MSG: would overflow buffer (%d+%d>%d)\n",
+        stage[ kiddex ].curs, nbuf, s_msize ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+
+  /* add point to head of list of points for processor P */
+  stage[kiddex].kid_id = POINTID(s_nst,s_jg,s_ig) ;
+  stage[kiddex].parent_id = POINTID( s_d, s_pjg, s_pig ) ;
+  stage[kiddex].cm = s_cm ;
+  stage[kiddex].cn = s_cn ;
+  Psize[P] += s_msize + sizeof( merge_point_desc_t ) ;
+
+  /* pack the buffer associated with stage[kiddex] */
+#ifdef crayx1
+  if( nbuf == sizeof(float) ) {
+    float *bufin  = (float *) buf;
+    float *bufout = (float *)&(stage[ kiddex ].p [ stage[ kiddex].curs]);
+    bufout[0] = bufin[0];
+  }
+  else {
+    bcopy( buf, &(stage[ kiddex ].p[ stage[ kiddex ].curs ]), nbuf ) ;
+  }
+  stage[ kiddex ].curs += nbuf ;
+#else
+  bcopy( buf, &(stage[ kiddex ].p[ stage[ kiddex ].curs ]), nbuf ) ;
+  stage[ kiddex ].curs += nbuf ;
+#endif
+}
+
+#ifdef crayx1
+RSL_TO_PARENT_MSGX ( n_vals_p, s_vals_p, stride_p, buf )
+  int_p
+    n_vals_p ;            /* (I) Number of values to be packed. */
+  int_p
+    s_vals_p ;            /* (I) Size of values to be packed. */
+  int_p
+    stride_p ;            /* (I) Number of values for stride. */
+  char *
+    buf ;                 /* (I) Buffer containing the data to be packed. */
+{
+  int n_vals, s_vals, stride;
+  int kiddex, nbuf, P;
+                                                                                                    
+  RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
+  n_vals = *n_vals_p;
+  s_vals = *s_vals_p;
+  stride = *stride_p;
+  nbuf   = n_vals * s_vals ;   /* Number of bytes to be packed */
+  kiddex = INDEX_2(s_jg,s_ig,s_mlen_nst) ;
+  P = s_ndomain[ kiddex ].mother_P ;
+  if ( stage[ kiddex ].p == NULL )
+  {
+    stage[ kiddex ].p = RSL_MALLOC( char, s_msize ) ;
+    stage[ kiddex ].curs = 0 ;
+    stage[ kiddex ].P = P ;
+    stage[kiddex].next = Plist[P] ;
+    Plist[P] =  &(stage[ kiddex ]) ;
+  }
+  if ( stage[ kiddex ].curs + nbuf > s_msize )
+  {
+    sprintf(mess,
+    "RSL_TO_PARENT_MSGX: would overflow buffer (%d+%d>%d)\n",
+        stage[ kiddex ].curs, nbuf, s_msize ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  /* add point to head of list of points for processor P */
+  stage[kiddex].kid_id = POINTID(s_nst,s_jg,s_ig) ;
+  stage[kiddex].parent_id = POINTID( s_d, s_pjg, s_pig ) ;
+  stage[kiddex].cm = s_cm ;
+  stage[kiddex].cn = s_cn ;
+  Psize[P] += s_msize + sizeof( merge_point_desc_t ) ;
+   
+  /* pack the buffer associated with stage[kiddex] */
+  if ( s_vals == sizeof(float) ) {
+    int k, ki;
+    float *bufin = (float *)buf;
+    float *bufout = (float *)&(stage[ kiddex ].p[ stage[ kiddex ].curs ]);
+#pragma _CRI ivdep
+    for ( k = 0, ki = 0; k < n_vals; k++, ki += stride ) {
+          bufout[k] = bufin[ki];
+    }
+    stage[ kiddex ].curs += nbuf ;
+  }
+  else {
+    sprintf(mess,
+    "RSL_TO_PARENT_MSGX: Element size %d not supported for stride\n", s_vals);
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+}
+#endif
+
+/*@
+  RSL_MERGE_MSGS -- Convey feedback data from nest to parent points.
+
+  Notes:
+  RSL_MERGE_MSGS is called once feedback data
+  to points in a parent domain have been packed into messages
+  from the associated points on the nest.  The routine has
+  no arguments; rather, RSL must be in a ready state; this occurs
+  once RSL_TO_PARENT_INFO has returned a value of 0 (zero)
+  in its last argument on all processors.  The feedback data is
+  conveyed along logical communication channels that were set up
+  between nest points and associated points in the parent domain
+  when the nest was spawned.  Interprocessor communication
+  is generated for messages between
+  points on different processors; otherwise, the transfer
+  is done within the processor's local memory.
+
+  The inverse operation to RSL_MERGE_MSGS is RSL_BCAST_MSGS, which
+  is used for conveying forcing data from parent to nest.
+
+  Note while reading the following example that RSL decomposes all
+  domains independently and over all processors, so that every
+  processor will have cells from the parent and from the nest.
+  Thus, all processors perform both the packing of data from
+  the nest and the unpacking of data onto the parent.  Other
+  RSL routines appearing in the example are described elsewhere
+  in these documents.
+
+  Example:
+
+$ C
+$ C Packing data from the nest.
+$ C
+$   NLEV = (the number of vertical levels)
+$   MSIZE = 3 * NLEV + 1 * WORDSIZE
+$ C
+$ C First call to rsl_to_parent_info
+$ C
+$   CALL RSL_TO_PARENT_INFO( PID, NID,     ! parent, nest domain descriptors
+$                            MSIZE,        ! size of message to a point
+$                            I,J,IG,JG,    ! local and global nest cell coords
+$                            CM,CN,        ! index of nest cell in parent cell
+$                            PIG,PJG,      ! global parent cell coords
+$                            IRETVAL )     ! return value
+$   DO WHILE ( IRETVAL .EQ. 1 )
+$ C   Dot point variables feedback from the sw nest cell under each parent.
+$     IF ( CM .EQ. 1 .AND. CN .EQ. 1 ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_TO_PARENT_MSG( WORDSIZE, U(I,J,K) )
+$         CALL RSL_TO_PARENT_MSG( WORDSIZE, V(I,J,K) )
+$       ENDDO
+$     END IF
+$ C   Cross point variables feedback from the center nest cell.
+$     IF ( CM .EQ. 2 .AND. CN .EQ. 2 ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_TO_PARENT_MSG( WORDSIZE, T(I,J,K) )
+$       ENDDO
+$       CALL RSL_TO_PARENT_MSG( WORDSIZE, PS(I,J) )
+$     ENDIF
+$ C
+$ C Subsequent calls to rsl_to_parent_info
+$ C
+$     CALL RSL_TO_PARENT_INFO( PID, NID, MSIZE, I,J,IG,JG, CM,CN,
+$                              PIG,PJG, IRETVAL )
+$   END DO
+$ C
+$ C Merge the data.
+$ C
+$   CALL RSL_MERGE__MSGS
+$ C
+$ C Unpack the data onto the parent.
+$ C
+$ C
+$ C First call to rsl_from_child_info
+$ C
+$   CALL RSL_FROM_CHILD_INFO( I, J,       ! local parent cell coords
+$                             IG, JG,     ! global parent cell coords
+$                             CM, CN,     ! index of nest cell in parent cell
+$                             NIG, NJG,   ! global nest cell coords
+$                             IRETVAL )   ! return value
+$   DO WHILE ( IRETVAL .EQ. 1 )
+$     IF ( CM .EQ. 1 .AND. CN .EQ. 1 ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_FROM_CHILD_MSG( WORDSIZE, U(I,J,K) )
+$         CALL RSL_FROM_CHILD_MSG( WORDSIZE, V(I,J,K) )
+$       ENDDO
+$     END IF
+$     IF ( CM .EQ. 2 .AND. CN .EQ. 2 ) THEN
+$       DO K = 1, NLEV
+$         CALL RSL_FROM_CHILD_MSG( WORDSIZE, T(I,J,K) )
+$       ENDDO
+$       CALL RSL_FROM_CHILD_MSG( WORDSIZE, PS(I,J) )
+$     END IF
+$ C
+$ C Subsequent calls to rsl_from_child_info
+$ C
+$     CALL RSL_FROM_CHILD_INFO( I, J, IG, JG, CM, CN, NIG, NJG, IRETVAL )
+$   END DO
+
+BREAKTHEEXAMPLECODE
+
+  In this example, three 3-dimensional fields, U, V, and T, and one
+  2-dimensional field, PS, from the parent domain are fed back from the
+  entire nest (as opposed to the forcing example for RSL_BCAST_MSGS in
+  which only the nest boundaries received data).  Assuming an Arakawa-B
+  grid, selecting the center nest cell associated with a parent cell
+  for cross-point data (T, PS) and the south-west nest cell for
+  dot-point data (U, V) accounts for staggering of the dot and cross
+  grids.
+  WORDSIZE, PIG, and PJG are integers; otherwise implicit typing
+  holds.
+
+                          
+  See also:
+  RSL_TO_CHILD_INFO, RSL_FROM_PARENT_INFO, RSL_BCAST_MSGS
+
+@*/
+
+RSL_MERGE_MSGS ()
+{
+  int P ;
+  char *work ;
+  merge_point_desc_t pdesc ;
+  stage_point_t *pt ;
+  int curs ;
+  int msglen, mdest, mtag ;
+  int ii ;
+
+  RSL_TEST_ERR( stage == NULL,
+    "RSL_MERGE_MESSAGES: RSL_MESSAGE_TO_CHILD not called first" ) ;
+
+
+  for ( ii = 0 ; ii < s_ninfo->Nmerge_send_Plist ; ii++ )
+  {
+    P = s_ninfo->merge_send_Plist[ii] ;
+    msglen = s_ninfo->merge_send_Pnpts[ii]*( sizeof(pdesc) + s_msize ) 
+             + sizeof(pdesc) ; /*  end of message marker */
+    curs = 0 ;
+    work = buffer_for_proc( P, msglen, RSL_SENDBUF ) ;
+    /* NOTE ASSUMPTION that the number of points in Plist will
+       be less or equal to ninfo->merge_send_Pnpts[ii].  If it isn't,
+       we've got trouble.  */
+    for ( pt = Plist[P] ; pt != NULL ; pt = pt->next )
+    {
+      RSL_TEST_ERR(curs+sizeof(merge_point_desc_t)+s_msize>msglen,
+        "Internal error: would overwrite in merge messages.") ;
+      pdesc.nest_id = pt->kid_id ;
+      pdesc.parent_id = pt->parent_id ;
+      pdesc.cm = pt->cm ;
+      pdesc.cn = pt->cn ;
+      bcopy( &pdesc, &work[curs], sizeof( merge_point_desc_t )) ;
+      curs += sizeof( merge_point_desc_t ) ;
+      bcopy( pt->p, &work[curs], s_msize ) ;
+      curs += s_msize ;
+    }
+    RSL_TEST_ERR(curs+sizeof(merge_point_desc_t)>msglen,
+      "Internal error: (end marker) would overwrite in merge messages.") ;
+    /* add end marker */
+    pdesc.nest_id = RSL_INVALID ;
+    pdesc.parent_id = RSL_INVALID ;
+    pdesc.cm = RSL_INVALID ;
+    pdesc.cn = RSL_INVALID ;
+    bcopy( &pdesc, &work[curs], sizeof( merge_point_desc_t )) ;
+    curs += sizeof( merge_point_desc_t ) ;
+    /* note that it is all right for mlen to be less than msglen */
+    if ( rsl_c_comp2phys_proc(P) != rsl_myproc )
+    {
+      mdest = rsl_c_comp2phys_proc(P) ;
+      mtag = MTYPE_FROMTO( MSG_TO_PARENT, rsl_myproc, mdest ) ;
+      msglen = curs ;
+      RSL_SEND( work, msglen, mtag, mdest ) ;
+    }
+    /* otherwise, leave in the send buffer and we'll pick it
+       up later */
+  }
+
+  /* reset this for the next phase, in */
+  s_child_msgs = NULL ;
+  s_remaining = 0 ;
+}
+
+/* Return a point from some child processor each time called.
+   If no more points, from a processor, go to the next one.
+   If no more points at all, retval is returned as RSL_INVALID */
+
+/*@
+  RSL_FROM_CHILD_INFO -- Get the next cell in a unpacking sequence for feedback.
+
+  Notes:
+  RSL_FROM_CHILD_INFO is used in a loop to unpack messages containing
+  feedback data from a nested domain.  The messages have arrived on the
+  local processor as a result of a previous call to RSL_MERGE_MSGS.
+  The domain descriptors do not need to be specified; they are part of
+  the state of RSL as a result of the calls to RSL_TO_CHILD_INFO that
+  have come before.  For a detailed example, see RSL_MERGE_MSGS.
+
+  Each call to RSL_FROM_CHILD_INFO gives the local indices (Arg1, Arg2)
+  and global indices (Arg3, Arg4) of a
+  parent domain point receiving feedback data from a nest point
+  whose the global indices are (Arg7, Arg8).
+  The indices of the child cell in the set of nest cells associated with
+  the parent are returned through arguments Arg5 and Arg6.  These
+  specify which of the nest cells associated with the parent
+  is being referred to.  There are IRAX_M by IRAX_N nest points
+  associated with each parent where IRAX_M is the nesting ratio in the
+  M dimension and IRAX_N is the nesting ratio in the N dimension (See
+  the descriptions for the RSL nest spawning routines RSL_SPAWN...).
+
+  RSL_FROM_CHILD_INFO will return a new set of coordinates for every
+  parent domain point stored in local processor memory.  For each
+  point, RSL_FROM_CHILD_INFO returns a value of 1 through
+  Arg9.   RSL is left in a state ready to yield
+  data from the nest point; the data
+  is unpacked from the message by calling RSL_FROM_CHILD_MSG.  Once
+  all local nest points have been traversed, RSL_FROM_CHILD_INFO returns
+  a value of 0 (zero) in Arg9.
+
+  It isn't necessary that anything be unpacked with the coordinates
+  that are returned.  However, once called, RSL_FROM_CHILD_INFO must
+  be called as many times as it takes to exhaust the number of points;
+  otherwise the underlying RSL mechanism will not be left in the proper
+  state at the conclusion of the broadcast.
+
+  See also:
+  RSL_MERGE_MSGS, RSL_TO_PARENT_INFO, RSL_FROM_CHILD_MSG
+@*/
+
+RSL_FROM_CHILD_INFO ( i_p, j_p, ig_p, jg_p, cm_p, cn_p,
+                       nig_p, njg_p, retval_p )
+  int_p
+    i_p         /* (O) Local index in M dimension of parent. */
+   ,j_p         /* (O) Local index in N dimension of parent. */
+   ,ig_p        /* (O) Global index in M dimension of parent. */
+   ,jg_p        /* (O) Global index in N dimension of parent. */
+   ,cm_p        /* (O) M index of child cell beneath parent cell. */
+   ,cn_p        /* (O) N index of child cell beneath parent cell. */
+   ,nig_p       /* (O) Global index in M dimension of nest. */
+   ,njg_p       /* (O) Global index in N dimension of nest. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  int ii ;
+  merge_point_desc_t pdesc ;
+
+  if ( s_remaining > 0 ) 
+  {
+    s_child_msgs_curs += s_remaining ;
+    s_remaining = 0 ;
+  }
+  get_a_new_merge_point( retval_p ) ;
+  if ( *retval_p != 1 )
+  {
+    cleanup_after_merge() ;
+    return ; 
+  }
+  s_remaining = s_msize + sizeof(merge_point_desc_t) ;
+
+  /* at this point we have a non-null message buffer */
+  /* read the descriptor */
+  bcopy( &(s_child_msgs[s_child_msgs_curs]),
+         &pdesc,
+         sizeof(merge_point_desc_t)) ;
+  s_child_msgs_curs += sizeof(merge_point_desc_t) ;
+  s_remaining -= sizeof(merge_point_desc_t) ;
+
+  /* get_a_new_merge_point should not be returning these */
+  RSL_TEST_ERR( pdesc.nest_id == RSL_INVALID, "Internal error.") ;
+
+  *ig_p = ID_IDEX(pdesc.parent_id)+1 ;
+  *jg_p = ID_JDEX(pdesc.parent_id)+1 ;
+  *i_p = *ig_p + s_dinfo->idif ;
+  *j_p = *jg_p + s_dinfo->jdif ;
+  *nig_p = ID_IDEX(pdesc.nest_id)+1 ;
+  *njg_p = ID_JDEX(pdesc.nest_id)+1 ;
+  *cm_p = pdesc.cm+1 ;
+  *cn_p = pdesc.cn+1 ;
+
+  *retval_p = 1 ;
+  return ;
+}
+
+/*@
+  RSL_FROM_CHILD_MSG -- Unpack feedback data into a parent point.
+
+  Notes:
+  RSL_FROM_CHILD_MSG is used in a loop to unpack messages containing
+  feedback data from a nested domain.  For an overview of the mechanism
+  and a detailed example, see RSL_MERGE_MSGS.
+
+  Before calling RSL_FROM_CHILD_MSG, RSL must have been put into the
+  correct state; that is, ready to accept data that will be sent to a
+  particular point in the nest.  This is done by first calling
+  RSL_FROM_CHILD_INFO.  RSL_FROM_CHILD_MSG may then be called as many
+  times as necessary to unpack data from the message (or not at all, if
+  there is no data for the point).  Each call to RSL_FROM_CHILD_MSG
+  copies Arg1 bytes from message into the bufffer specified by Arg2.
+  Note that the message is allocated and handled entirely within RSL
+  and never manipulated directly by the user program.  The amount of
+  data that can be packed is limited to the message size that was
+  specified in the first call to RSL_TO_PARENT_INFO.
+
+  See also:
+  RSL_BCAST_MSGS, RSL_FROM_CHILD_INFO, RSL_TO_PARENT_INFO
+
+@*/
+
+RSL_FROM_CHILD_MSG ( len_p, buf )
+  int_p
+    len_p ;             /* (I) Number of bytes to unpack. */
+  char *
+    buf ;               /* (O) Destination buffer. */
+{
+  if ( *len_p <= 0 ) return ;
+  if ( *len_p > s_remaining ) 
+  {
+    sprintf(mess,
+"RSL_FROM_CHILD_MSG:\n   Requested number of bytes (%d) exceeds %d, the number remaining for this point.\n", *len_p, s_remaining) ;
+    RSL_TEST_WRN(1,mess) ;
+  }
+#ifdef crayx1
+  if( (*len_p) == sizeof(float) ) {
+    float *bufout = (float *)buf;
+    float *bufin  = (float *)&(s_child_msgs[s_child_msgs_curs]);
+    bufout[0]   = bufin[0];
+  }
+  else {
+    bcopy( &(s_child_msgs[s_child_msgs_curs]),
+         buf,
+         *len_p ) ;
+  }
+  s_child_msgs_curs += *len_p ;
+  s_remaining -= *len_p ;
+#else
+  bcopy( &(s_child_msgs[s_child_msgs_curs]),
+         buf,
+         *len_p ) ;
+  s_child_msgs_curs += *len_p ;
+  s_remaining -= *len_p ;
+#endif
+}
+
+#ifdef crayx1
+RSL_FROM_CHILD_MSGX ( n_vals_p, s_vals_p, stride_p, buf )
+  int_p
+    n_vals_p ;            /* (I) Number of values to be packed. */
+  int_p
+    s_vals_p ;            /* (I) Size of values to be packed. */
+  int_p
+    stride_p ;            /* (I) Number of values for stride. */
+  char *
+    buf ;                 /* (O) Buffer containing the unpacked data. */
+{
+  int n_vals, s_vals, stride, len;
+  n_vals = *n_vals_p;
+  s_vals = *s_vals_p;
+  stride = *stride_p;
+  len    = n_vals * s_vals;  /* Number of bytes to unpack */
+  if ( len <= 0 ) return ;
+  if ( len > s_remaining )
+  {
+    sprintf(mess,
+"RSL_FROM_CHILD_MSGX:\n   Requested number of bytes (%d) exceeds %d, the number remaining for this point.\n", len, s_remaining) ;
+    RSL_TEST_WRN(1,mess) ;
+  }
+  if ( (s_vals) == sizeof (float) ) {
+    int k, ki;
+    float *bufout = (float *)buf;
+    float *bufin  = (float *)&(s_child_msgs[s_child_msgs_curs]);
+                                                                 
+#pragma _CRI ivdep
+    for ( k = 0, ki = 0; k < n_vals; k++, ki += stride ) {
+          bufout[ki] = bufin[k];
+    }
+    s_child_msgs_curs += len ;
+    s_remaining -= len ;
+  }
+  else {
+    sprintf(mess, "RSL_FROM_CHILD_MSGX: Element size %d not supported for stride\n", s_vals);
+    RSL_TEST_WRN(1,mess) ;
+  }
+}
+#endif
+
+/* This is called by RSL_FROM_CHILD_INFO on a parent domain each time we
+   need a received point from a nest.
+
+   When this is called, one of two states may obtain.
+
+   1. The first time this is called for a given merge operation, the global
+   pointer s_child_msgs will be equal to NULL.
+
+   2. Subsequent times this is called, the s_child_msgs pointer will be
+   non-null and point to a buffer that was returned by a previous call
+   to this routine.  The integer cursor s_child_msgs_curs will always
+   be the index of the starting byte of a point descriptor of type
+   merge_point_desc_t. 
+   
+     a. If the descriptor is a valid point, we return
+     without doing anything.
+
+     b. If the descriptor is a special invalid descriptor, this marks
+     the end of a set of messages from a processor.  Get the next 
+     buffer and assign it to s_child_msgs, and set the cursors appropriately.
+
+        i. If there are no more messages, the s_child_msgs is set to
+           null and *retval_p is set to -1, indicating that we are 
+           finished with this set of messages for the merge operation.
+
+
+*/
+get_a_new_merge_point( retval_p )
+  int_p retval_p ;
+{
+  int result, mtag, ii ;
+  merge_point_desc_t pdesc ;
+
+  do {
+    if ( s_child_msgs != NULL )
+    {
+#if 0
+      pdesc = *((merge_point_desc_t *)(&(s_child_msgs[s_child_msgs_curs]))) ;
+#else
+/* djs 1/98 */
+      bcopy( &s_child_msgs[s_child_msgs_curs]
+           , &pdesc
+           , sizeof(merge_point_desc_t)
+           ) ;
+#endif
+      if ( pdesc.nest_id != RSL_INVALID )
+      {
+        *retval_p = 1 ;
+        return ;                /* 2.a. */
+      }
+    }
+    /* are there outstanding messages? */
+    for ( ii = 0 ; ii < s_ninfo->Nmerge_recv_Plist ; ii++ )
+    {
+      if ( s_ninfo->merge_recv_Ptags[ii] != RSL_INVALID )
+      {
+        break ;
+      }
+    }
+    if ((ii == s_ninfo->Nmerge_recv_Plist)||(s_ninfo->Nmerge_recv_Plist <= 0))
+    {
+      *retval_p = -1 ;
+      s_child_msgs = NULL ;
+      return ;                  /* 2.b.i */
+    }
+    /* scan till we get a message */
+    ii = 0 ;
+    result = 1 ;
+    while (1)
+    {
+      if ( s_ninfo->merge_recv_Ptags[ii] != RSL_INVALID )
+      {
+        if ( rsl_c_comp2phys_proc(s_ninfo->merge_recv_Plist[ii]) != rsl_myproc )
+        {
+          mtag = s_ninfo->merge_recv_Ptags[ii] ;
+          if ( rsl_noprobe == NULL )
+          {
+            RSL_PROBE( mtag, &result ) ;
+          }
+          /* else, result will always be 1 */
+          if ( result )
+          {
+#ifdef PGON
+            if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtag ) ;
+#else
+            RSL_RECVEND ( mtag ) ;
+#endif
+            s_ninfo->merge_recv_Ptags[ii] = RSL_INVALID ;
+            s_child_msgs =
+               buffer_for_proc( s_ninfo->merge_recv_Plist[ii], 0, RSL_RECVBUF ) ;
+            break ;
+          }
+        }
+        else
+        {
+          /* code to handle data from myself, which will be in my send buffer */
+          s_ninfo->merge_recv_Ptags[ii] = RSL_INVALID ;
+          s_child_msgs =
+             buffer_for_proc( s_ninfo->merge_recv_Plist[ii], 0, RSL_SENDBUF ) ;
+                                                          /*    ^^^^^^^^^^^  */
+                                                          /* because data is */
+                                                          /* from myself     */
+          break ;
+        }
+      }
+      if ( ++ii >= s_ninfo->Nmerge_recv_Plist ) ii = 0 ;
+    }
+    s_child_msgs_curs = 0 ;
+#if 0
+    pdesc = *((merge_point_desc_t *)(&(s_child_msgs[s_child_msgs_curs]))) ;
+#else
+/* djs 1/98 */
+    bcopy ( &s_child_msgs[s_child_msgs_curs]
+          , &pdesc
+          , sizeof(merge_point_desc_t)
+          ) ;
+#endif
+  } while ( pdesc.nest_id == RSL_INVALID ) ;
+  *retval_p = 1 ;
+}
+
+
+post_receives_from_child()
+{
+  int ii, msglen, P, mtag, mfrom ;
+  char * work ;
+
+  for ( ii = 0 ; ii < s_ninfo->Nmerge_recv_Plist ; ii++ )
+  {
+    P = s_ninfo->merge_recv_Plist[ii] ;
+    mfrom = rsl_c_comp2phys_proc(P) ;
+    if ( mfrom != rsl_myproc )
+    {
+      msglen = s_ninfo->merge_recv_Pnpts[ii]*(sizeof(merge_point_desc_t)+s_msize)
+               + sizeof(merge_point_desc_t) ;    /* end marker */
+      work = buffer_for_proc(P, msglen, RSL_RECVBUF) ;
+      mtag = MTYPE_FROMTO( MSG_TO_PARENT, mfrom, rsl_myproc ) ;
+      RSL_RECVBEGIN( work, msglen, mtag ) ;
+      s_ninfo->merge_recv_Ptags[ii] = mtag ; /* store tag */
+    }
+    else
+    {
+      /* next statement is just diagnostic */
+      msglen = s_ninfo->merge_recv_Pnpts[ii]*(sizeof(merge_point_desc_t)+s_msize)
+               + sizeof(merge_point_desc_t) ;    /* end marker */
+      /* set the tag so we know to unpack the send buffer 
+         for data from ourself */
+      mtag = MTYPE_FROMTO( MSG_TO_PARENT, mfrom, rsl_myproc ) ;
+      s_ninfo->merge_recv_Ptags[ii] = mtag ;
+    }
+  }
+}
+
+rsl_ready_merge( d_p, n_p, msize_p )
+  int_p d_p, n_p, msize_p ;
+{
+  int i ;
+  nest_info_t *dp ;
+  rsl_list_t *lp ;
+  rsl_child_info_t * kid ;
+  rsl_point_t *pt ;
+  int kidid ;
+  int ig, jg, cn, cm ;
+  int P ;
+
+  s_msize = *msize_p ;
+  s_d = *d_p ;
+  s_nst = *n_p ;
+  RSL_TEST_ERR( stage != NULL,
+    "rsl_ready_merge: called again before RSL_MERGE_MSGS of previous call.") ;
+  RSL_TEST_ERR( s_d < 0 || s_d > RSL_MAXDOMAINS,
+    "rsl_ready_merge: bad parent domain descriptor" ) ;
+  RSL_TEST_ERR( s_nst < 0 || s_nst > RSL_MAXDOMAINS,
+    "rsl_ready_merge: bad nested domain descriptor" ) ;
+  RSL_TEST_ERR( s_d == s_nst,
+    "rsl_ready_merge: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[s_nst].parent != s_d ,
+    "rsl_ready_merge: the nest is not a child of the parent" ) ;
+ 
+  s_dinfo = &( domain_info[s_d]) ;
+  s_ninfo = &( domain_info[s_nst]) ;
+  RSL_TEST_ERR( s_dinfo->valid != RSL_VALID,
+    "rsl_ready_merge: invalid parent domain" ) ;
+  RSL_TEST_ERR( s_ninfo->valid != RSL_VALID,
+    "rsl_ready_merge: invalid nested domain" ) ;
+  s_ddomain = s_dinfo->domain ;
+  s_ndomain = s_ninfo->domain ;
+
+  s_mlen = s_dinfo->len_m ;
+  s_nlen = s_dinfo->len_n ;
+  s_mlen_nst = s_ninfo->len_m ;
+  s_nlen_nst = s_ninfo->len_n ;
+  s_irax_n = s_ninfo->irax_n ;
+  s_irax_m = s_ninfo->irax_m ;
+
+  if ( s_dinfo->child_merge_compiled[s_nst] != 1 ||
+       s_ninfo->parent_merge_compiled != 1 )
+  {
+    rsl_comp_merge( d_p, n_p ) ;
+    if ( s_ninfo->merge_Xlist != NULL )
+    {
+      destroy_list( &(s_ninfo->merge_Xlist), destroy_nest_info ) ;
+    }
+    s_ninfo->merge_Xlist = NULL ;
+  }
+
+  post_receives_from_child() ;
+
+  /* stage will be NULL here because rsl_ready_merge is only called
+     if stage is NULL (that's tested near the top of this routine).
+     cleanup_after_merge deallocates all this malloc'd storage */
+
+                                                             /* v-paranoid */
+  stage = RSL_MALLOC( stage_point_t , s_mlen_nst * s_nlen_nst * 2 ) ;
+                                                             /* ^-paranoid */
+  stage_len = s_mlen_nst * s_nlen_nst ;  /* 96/3/15 */
+  for ( i = 0 ; i < stage_len ; i++ )
+  {
+    stage[i].p = NULL ;
+  }
+
+  /* construct the list of local nested points that go to parent points */
+#if 0
+  if ( Xlist != NULL ) destroy_list( &(Xlist), destroy_nest_info ) ;
+  Xlist = NULL ;
+#endif
+  if ( s_ninfo->merge_Xlist == NULL )
+  {
+
+  /* traverse backwards so that Xlist can be constructed easily frontwards */
+    for ( jg = s_nlen_nst-1 ; jg >=0 ; jg-- )
+    {
+      for ( ig = s_mlen_nst-1 ; ig >= 0 ; ig-- )
+      {
+        pt = &(s_ndomain[INDEX_2(jg,ig,s_mlen_nst)]) ;
+        if ( pt->valid == RSL_VALID &&
+             rsl_c_comp2phys_proc(pt->P) == rsl_myproc )
+        {
+          dp = RSL_MALLOC( nest_info_t, 1 ) ;
+          dp->ig = ig ;
+          dp->jg = jg ;
+          dp->cn = pt->which_kid_am_i_n ;
+          dp->cm = pt->which_kid_am_i_m ;
+          dp->mother_id = pt->mother_id ;
+          lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+          lp->data = dp ;
+          lp->next = s_ninfo->merge_Xlist ;
+          s_ninfo->merge_Xlist = lp ;
+        }
+      }
+    }
+  }
+  Xlist = s_ninfo->merge_Xlist ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    Plist[P] = NULL ;
+  }
+}
+
+
+
+/* now used internally only */
+rsl_comp_merge( d_p, n_p )
+  int_p d_p, 
+        n_p ;
+{
+  int d, nst, mlen, nlen, mlen_nst, nlen_nst ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *ddomain, *ndomain, *pt ;
+  rsl_child_info_t *kids ;
+  rsl_processor_t P ;
+  int i, j, jg, ig, jgn, ign, cn, cm, cnt, p ;
+  int irax_n, irax_m ;
+
+  d = *d_p ;
+  nst = *n_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, 
+        "rsl_comp_merge: bad parent domain descriptor") ;
+  RSL_TEST_ERR( nst < 0 || nst >= RSL_MAXDOMAINS, 
+        "rsl_comp_merge: bad nested domain descriptor") ;
+  RSL_TEST_ERR( d == nst, 
+        "rsl_comp_merge: domain cannot merge to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+        "rsl_comp_merge: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+        "rsl_comp_merge: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+        "rsl_comp_merge: invalid nested domain" ) ;
+
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  mlen_nst = ninfo->len_m ;
+  nlen_nst = ninfo->len_n ;
+  ddomain = dinfo->domain ;
+  ndomain = ninfo->domain ;
+  irax_n = ninfo->irax_n ;
+  irax_m = ninfo->irax_m ;
+
+  destroy_merge_compilation( d_p, n_p ) ;
+
+  if ( dinfo->decomposed != 1 )
+     default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  if ( ninfo->decomposed != 1 )
+     default_decomposition( n_p,
+                           &(domain_info[*n_p].loc_m),
+                           &(domain_info[*n_p].loc_n) ) ;
+
+  /* begin by computing the receive list */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 
+    ninfo->merge_recv_Pnpts[i] = 0 ;
+
+  for ( jgn = 0 ; jgn < nlen_nst ; jgn++ )
+  {
+    for ( ign = 0 ; ign < mlen_nst ; ign++ )
+    {
+      pt = &(ndomain[INDEX_2(jgn,ign,mlen_nst)]) ;
+      if ( pt->valid == RSL_VALID &&
+           rsl_c_comp2phys_proc(pt->mother_P) == rsl_myproc )
+      {
+        if ( pt->valid == RSL_VALID )
+          (ninfo->merge_recv_Pnpts[pt->P])++ ; /* count this point as 
+                                                  coming from the nest
+                                                  processor */
+      }
+    }
+  }
+  /* compress and copy the plist */
+  ninfo->Nmerge_recv_Plist = 0 ;
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    if ( ninfo->merge_recv_Pnpts[P] > 0 )
+    {
+      ninfo->merge_recv_Pnpts[ninfo->Nmerge_recv_Plist] =
+                                        ninfo->merge_recv_Pnpts[P] ;
+      ninfo->merge_recv_Plist[ninfo->Nmerge_recv_Plist] = P ;
+      (ninfo->Nmerge_recv_Plist)++ ;
+    }
+  }
+
+  /* now compute the send list */
+  for ( i = 0 ; i < rsl_nproc_all ; i++ ) 
+    ninfo->merge_send_Pnpts[i] = 0 ;
+
+  for ( jgn = 0 ; jgn < nlen_nst ; jgn++ )
+  {
+    for ( ign = 0 ; ign < mlen_nst ; ign++ )
+    {
+      pt = &(ndomain[INDEX_2(jgn,ign,mlen_nst)]) ;
+      if ( pt->valid == RSL_VALID && 
+           rsl_c_comp2phys_proc(pt->P) == rsl_myproc )
+      {
+        ninfo->merge_send_Pnpts[pt->mother_P]++ ;
+      }
+    }
+  }
+  /* compress and copy the plist */
+  ninfo->Nmerge_send_Plist = 0 ;
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    if ( ninfo->merge_send_Pnpts[P] > 0 )
+    {
+      ninfo->merge_send_Pnpts[ninfo->Nmerge_send_Plist] =
+                                        ninfo->merge_send_Pnpts[P] ;
+      ninfo->merge_send_Plist[ninfo->Nmerge_send_Plist] = P ;
+      (ninfo->Nmerge_send_Plist)++ ;
+    }
+  }
+
+  dinfo->child_merge_compiled[nst] = 1 ;
+  ninfo->parent_merge_compiled = 1 ;
+}
+
+cleanup_after_merge()
+{
+  int i ;
+  if ( stage != NULL )
+  {
+    for ( i = 0 ; i < stage_len ; i++ )
+    {
+      if ( stage[i].p != NULL ) RSL_FREE( stage[i].p ) ;  /* 96/3/15 */
+    }
+    RSL_FREE( stage ) ;
+  }
+  stage = NULL ;
+  s_msize = RSL_INVALID ;
+  s_dinfo = NULL ;
+  s_ninfo = NULL ;
+  s_ddomain = NULL ;
+  s_ndomain = NULL ;
+  s_child_msgs = NULL ;
+  s_child_msgs_curs = RSL_INVALID ;
+}
+
+destroy_merge_compilation( d_p, n_p )
+  int_p d_p, n_p ;
+{
+  int d, nst, P ;
+  rsl_domain_info_t *dinfo, *ninfo ;
+  rsl_point_t *ddomain, *ndomain, *pt ;
+
+  d = *d_p ;
+  nst = *n_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+        "rsl_comp_merge: bad parent domain descriptor") ;
+  RSL_TEST_ERR( nst < 0 || nst >= RSL_MAXDOMAINS,
+        "rsl_comp_merge: bad nested domain descriptor") ;
+  RSL_TEST_ERR( d == nst,
+        "rsl_comp_merge: domain cannot broadcast to itself" ) ;
+  RSL_TEST_ERR( domain_info[nst].parent != d ,
+        "rsl_comp_merge: the nest is not a child of the parent" ) ;
+
+  dinfo = &( domain_info[d]) ;
+  ninfo = &( domain_info[nst]) ;
+  RSL_TEST_ERR( dinfo->valid != RSL_VALID,
+        "rsl_comp_merge: invalid parent domain" ) ;
+  RSL_TEST_ERR( ninfo->valid != RSL_VALID,
+        "rsl_comp_merge: invalid nested domain" ) ;
+  
+  ninfo->parent_merge_compiled = 0 ;
+  dinfo->child_merge_compiled[nst] = 0 ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    ninfo->merge_recv_Pnpts[P] = 0 ;
+    ninfo->merge_recv_Plist[P] = RSL_INVALID ;
+    ninfo->merge_recv_Ptags[P] = RSL_INVALID ;
+    ninfo->Nmerge_recv_Plist = 0 ;
+  }
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_merge_f.F b/wrfv2_fire/external/RSL/RSL/rsl_merge_f.F
new file mode 100755
index 00000000..08af8e14
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_merge_f.F
@@ -0,0 +1,99 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_merge_chld( pd, nd, msize, mf, pf, upf )
+      call cwrap_fmerge( pd, nd, msize, mf, pf, upf )
+      return
+      end
+
+      subroutine rsl_f_merge_chld( pd, nd, msize, buf, mf, pf, upf )
+      implicit none
+      integer pd                ! parent domain
+      integer nd                ! nested domain
+      integer msize             ! message size (bytes)
+      logical mf                ! packing  mask function
+      integer pf                ! packing function
+      integer upf               ! unpacking function
+      real buf(*)
+      include 'rsl.inc'
+c local variables
+      integer retval, i, j, pig, pjg, nig, njg
+      integer dum, n, cm, cn
+
+      call rsl_to_parent_info( pd, nd, msize,
+     +                         i,j,nig,njg,cm,cn,pig,pjg,retval )
+      do while ( retval .eq. 1 )
+        if ( mf( pd, nd, i, j, nig, njg ) ) then
+          dum = pf( pd, nd, i, j, nig, njg, cm, cn, buf, msize )
+          call rsl_to_parent_msg( msize, buf )
+        endif
+        call rsl_to_parent_info( pd, nd, msize,
+     +                           i,j,nig,njg,cm,cn,pig,pjg,retval )
+      enddo
+
+      call rsl_merge_msgs
+
+      call rsl_from_child_info( i,j,pig,pjg,cm,cn,nig,njg,retval )
+      do while ( retval .eq. 1 )
+        call rsl_from_child_msg( msize, buf )
+        dum = upf( pd, nd, i, j, pig, pjg, cm, cn, buf, msize )
+        call rsl_from_child_info( i,j,pig,pjg,cm,cn,nig,njg,retval )
+      enddo
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_mm_io.c b/wrfv2_fire/external/RSL/RSL/rsl_mm_io.c
new file mode 100755
index 00000000..e6b5e56e
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_mm_io.c
@@ -0,0 +1,596 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* this module is specific to MM5 */
+
+
+/*@
+  RSL_READ_REPL --- Fortran read of replicated, byte data into a buffer
+
+  Notes:
+  This does an unformatted (binary) Fortran read on a
+  file specified by Arg1.  Data is read into the buffer specified
+  by Arg2.  The length of the buffer, in bytes, is given by
+  Arg3.  When the call returns, the data will be available on
+  all processors.
+
+@*/
+RSL_READ_REPL ( unit_p, base, nbytes_p )
+  int_p
+    unit_p ;     /* (I) Fortran I/O unit number. */
+  void *
+    base ;       /* (O) Buffer. */
+  int_p
+    nbytes_p ;   /* (I) Buffer length in bytes. */
+{
+  int unit, nbytes ;
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  rsl_processor_t P ;
+  int mlen, nlen, d ;
+  int mdest, mtag, msglen ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR ( &i_am_monitor ) ;
+
+#ifdef T3D
+  fprintf(stderr,"RSL_READ_REPL not implemented on T3D\n") ;
+  fprintf(stderr,"Use RSL_READ_REPLW instead\n") ;
+  RSL_TEST_ERR(1,"") ;
+  exit(2) ;
+#else
+
+  unit = *unit_p ;
+  nbytes = *nbytes_p ;
+  request.request_type = RSL_READ_SPECIAL2 ;
+  request.speciala = nbytes ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;
+  request.unit = *unit_p ;
+  request.sequence = io_seq_compute++ ;
+
+  if ( i_am_monitor )
+  {
+    FORT_CHARACTERREAD ( &unit, base, &nbytes ) ;
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )     /* 95/02/22 */
+    {
+      mdest = rsl_c_comp2phys_proc(P) ;
+      if ( mdest != rsl_myproc )
+      {
+        mtag = MTYPE_FROMTO( MSG_SPECIAL2_RESPONSE, rsl_myproc, mdest ) ;
+        msglen = sizeof( resp ) ;
+        RSL_SEND( &resp, msglen, mtag, mdest ) ;
+        msglen = nbytes ;
+        RSL_SEND( base, msglen, mtag, mdest ) ;
+      }
+    }
+  }
+  else
+  {
+    mdest = RSL_C_MONITOR_PROC () ;
+    mtag = MTYPE_FROMTO( MSG_SPECIAL2_RESPONSE, mdest, rsl_myproc ) ;
+    msglen = sizeof(resp) ;
+    RSL_RECV( &resp, msglen, mtag ) ;
+    msglen = nbytes ;
+    RSL_RECV( base, msglen, mtag ) ;
+  }
+#endif
+}
+
+/*@
+  RSL_READ_REPLW --- Fortran read of replicated, typed data into a buffer
+
+  Notes:
+  This does an unformatted (binary) Fortran read on a
+  file specified by Arg1.  The element type of the data is
+  given as Arg2.  It may be
+  Verbatim:
+$      RSL_REAL
+$      RSL_INTEGER
+$      RSL_DOUBLE
+$      RSL_COMPLEX
+$      RSL_CHARACTER
+BREAKTHEEXAMPLECODE
+
+  The buffer is provided as
+  Arg3.  The length of the buffer, expressed as the number of
+  elements to be read, is given by
+  Arg4.  When the call returns, the data will be available on
+  all processors.
+
+@*/
+
+RSL_READ_REPLW ( unit_p, type_p, base, nelems_p )
+  int_p
+    unit_p      /* (I) Fortran I/O unit number. */
+   ,type_p ;    /* (I) Element type of data. */
+  void *
+    base ;      /* (O) Buffer. */
+  int_p
+    nelems_p ;  /* (I) Number of elements to be read. */
+{
+  int unit, nwords, type ;
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  rsl_processor_t P ;
+
+  int mdest, mtag, mlen ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR ( &i_am_monitor ) ;
+
+  unit = *unit_p ;
+  nwords = *nelems_p ;
+  type = *type_p ;
+  request.request_type = RSL_READ_SPECIAL2 ;
+  request.speciala = nwords ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;
+  request.unit = *unit_p ;
+  request.sequence = io_seq_compute++ ;
+
+  if ( i_am_monitor )
+  {
+
+    switch (type)
+    {
+    case RSL_REAL :
+      FORT_REALREAD ( &unit, base, &nwords ) ;
+      break ;
+    case RSL_INTEGER :
+      FORT_INTREAD ( &unit, base, &nwords ) ;
+      break ;
+#ifndef T3D
+    case RSL_DOUBLE :
+      FORT_DOUBLEREAD ( &unit, base, &nwords ) ; 
+      break ;
+#endif
+    case RSL_COMPLEX :
+      FORT_COMPLEXREAD ( &unit, base, &nwords ) ; 
+      break ;
+    case RSL_CHARACTER :
+      FORT_CHARACTERREAD ( &unit, base, &nwords ) ;
+      break ;
+    default:
+      RSL_TEST_ERR(1,"unsupported type argument") ;
+    }
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )     /* 95/02/22 */
+    {
+      mdest = rsl_c_comp2phys_proc(P) ;
+      if ( mdest != rsl_myproc )
+      {
+        mtag = MTYPE_FROMTO( MSG_SPECIAL2_RESPONSE, rsl_myproc, mdest ) ;
+        mlen = sizeof( resp ) ;
+        RSL_SEND( &resp, mlen, mtag, mdest ) ;
+        mlen = elemsize(type)*nwords ;
+        RSL_SEND( base, mlen, mtag, mdest ) ;
+      }
+    }
+  }
+  else
+  {
+    mdest = RSL_C_MONITOR_PROC () ;
+    mtag = MTYPE_FROMTO( MSG_SPECIAL2_RESPONSE, mdest, rsl_myproc ) ;
+    mlen = sizeof(resp) ;
+    RSL_RECV( &resp, mlen, mtag ) ;
+    mlen = elemsize(type)*nwords ;
+    RSL_RECV( base, mlen, mtag ) ;
+  }
+}
+
+/* this module is specific to MM5 -- yes, it is a kludge to the max */
+
+/* rev: 9/8/94 -- fixed problem wherein the monitor would attempt to
+   free buffers for boundaries it did not have (and so, had not been
+   allocated storage by the call to handle_spec1).   The effect was
+   a segmentation error in the call to free.    */
+   
+
+RSL_MM_BDY_IN ( unit_p, iotag_p,
+                ebase, wbase, nbase, sbase,
+                d_p, type_p,
+                bdy_wdth_p,
+                glen, llen )
+  int_p unit_p ;
+  int_p iotag_p ;
+  int_p type_p ;
+  int_p bdy_wdth_p ;
+  int_p d_p ;
+  char *ebase, *wbase, *nbase, *sbase ;
+  int glen[], llen[] ;
+{
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  int cursor, mdest, mtag, msglen, dim ;
+  int bwdth ;
+  unsigned long ig, jg, min, maj, ioffset, joffset, tlen, k ;
+  void *dex ;
+  char *pbuf ;
+  char *buf_w, *buf_e, *buf_n, *buf_s ;
+  int wsz, esz, nsz, ssz ;
+  rsl_read_resp_t resp_w, resp_e, resp_n, resp_s ;
+  int P, mlen, nlen, d  ;
+  int bdymark() ;
+  int i_am_monitor, got_bdy ;
+  rsl_point_t *domain ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+  domain = domain_info[d].domain ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  bwdth = *bdy_wdth_p ;
+  ioffset = domain_info[*d_p].ilocaloffset ;
+  joffset = domain_info[*d_p].jlocaloffset ;
+  tlen = elemsize( *type_p ) ;
+
+  request.request_type = RSL_READ_SPECIAL1 ;
+  request.speciala = bwdth ;
+  request.myproc = rsl_myproc ;
+  request.base = ebase ;        /* not used anyway */
+  request.domain = *d_p ;
+  request.unit = *unit_p ;
+  request.type = *type_p ;
+  request.iotag = *iotag_p ;
+  request.sequence = io_seq_compute++ ;
+
+  P = rsl_c_phys2comp_proc( rsl_myproc ) ;
+  mlen = domain_info[*d_p].len_m ;
+  nlen = domain_info[*d_p].len_n ;
+  d = *d_p ;
+
+  switch( *iotag_p )
+  {
+  case IO2D :
+  case IO2D_IJ :
+  case IO2D_JI :
+    request.ndim = 2 ;
+    break ;
+  case IO3D :
+  case IO3D_IJK :
+  case IO3D_JIK :
+    request.ndim = 3 ;
+    break ;
+  default:
+      RSL_TEST_ERR(1,"rsl_mm_bdy_in: unknown data tag") ;
+  }
+  for ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    request.glen[dim] = glen[dim] ;
+    request.llen[dim] = llen[dim] ;
+  }
+
+  buf_w = NULL ;
+  buf_e = NULL ;
+  buf_n = NULL ;
+  buf_s = NULL ;
+  got_bdy = handle_special1( &request, &buf_e, &esz,
+                                       &buf_w, &wsz,
+                                       &buf_n, &nsz,
+                                       &buf_s, &ssz ) ;
+  if ( got_bdy )
+  {
+    int i, j, k, by, b ;
+    int ix_g, jx_g, kx_g ;
+    int ix_l, jx_l, kx_l ;
+    ix_g = glen[0] ; jx_g = glen[1] ; kx_g = (request.ndim==3)?glen[2]:1 ;
+    ix_l = llen[0] ; jx_l = llen[1] ; kx_l = (request.ndim==3)?glen[2]:1 ;
+
+    /* west/east */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( i = 0 ; i < ix_l ; i++ )
+	{
+          if ( i+ioffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+	    {
+	      wbase[by+tlen*(i+k*ix_l+b*ix_l*kx_l)]=buf_w[by+tlen*((i+ioffset)+k*ix_g+b*ix_g*kx_g)];
+	      ebase[by+tlen*(i+k*ix_l+b*ix_l*kx_l)]=buf_e[by+tlen*((i+ioffset)+k*ix_g+b*ix_g*kx_g)];
+	    }
+          }
+	}
+
+    /* north/south */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( j = 0 ; j < jx_l ; j++ )
+	{
+          if ( j+joffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+	    {
+	      nbase[by+tlen*(j+k*jx_l+b*jx_l*kx_l)]=buf_n[by+tlen*((j+joffset)+k*jx_g+b*jx_g*kx_g)];
+	      sbase[by+tlen*(j+k*jx_l+b*jx_l*kx_l)]=buf_s[by+tlen*((j+joffset)+k*jx_g+b*jx_g*kx_g)];
+	    }
+	  }
+	}
+  }
+
+  RSL_FREE( buf_e ) ;
+}
+
+#include "which_boundary.h"
+
+RSL_MM_DIST_BDY ( unit_p, iotag_p, iorder_p, base, d_p,
+                  type_p, bdy_wdth_p, bdy_height_p,
+                  bdy_g_length_p, bdy_l_length_p )
+  int_p
+    unit_p
+   ,iotag_p
+   ,iorder_p ;
+  char *
+    base ;
+  int_p
+    d_p
+   ,type_p
+   ,bdy_wdth_p
+   ,bdy_height_p
+   ,bdy_g_length_p
+   ,bdy_l_length_p ;
+
+{
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  int cursor, mdest, mtag, msglen, dim ;
+  int bwdth ;
+  unsigned long ig, jg, min, maj, ioffset, joffset, tlen, k ;
+  void *dex ;
+  char *buf ;
+  int P, mlen, nlen, d  ;
+  int i_am_monitor, got_bdy, iorder, which_boundary ;
+  rsl_point_t *domain ;
+
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "rsl_init_nextcell: bad domain") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+     "rsl_init_nextcell: invalid domain") ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    default_decomposition( d_p,
+                           &(domain_info[*d_p].loc_m),
+                           &(domain_info[*d_p].loc_n) ) ;
+  }
+  mlen = domain_info[d].len_m ;
+  nlen = domain_info[d].len_n ;
+  domain = domain_info[d].domain ;
+
+  RSL_C_IAMMONITOR( &i_am_monitor ) ;
+
+  iorder = *iorder_p ;
+  bwdth = *bdy_wdth_p ;
+  ioffset = domain_info[*d_p].ilocaloffset ;
+  joffset = domain_info[*d_p].jlocaloffset ;
+  tlen = elemsize( *type_p ) ;
+
+  request.request_type = RSL_READ_SPECIAL1 ;
+  request.speciala = bwdth ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;        /* not used anyway */
+  request.domain = *d_p ;
+  request.unit = *unit_p ;
+  request.type = *type_p ;
+  request.iotag = *iotag_p ;
+  request.sequence = io_seq_compute++ ;
+
+  P = rsl_c_phys2comp_proc( rsl_myproc ) ;
+  mlen = domain_info[*d_p].len_m ;
+  nlen = domain_info[*d_p].len_n ;
+  d = *d_p ;
+
+  switch( *iotag_p )
+  {
+  case IO2D :
+  case IO2D_IJ :
+  case IO2D_JI :
+    request.ndim = 2 ;
+    break ;
+  case IO3D :
+  case IO3D_IJK :
+  case IO3D_JIK :
+    request.ndim = 3 ;
+    break ;
+  default:
+      RSL_TEST_ERR(1,"rsl_mm_bdy_in: unknown data tag") ;
+  }
+
+#if 0
+   /* east  2 */
+   /* west  1 */
+   /* north 8 */
+   /* south 4 */
+#endif
+
+     /* set up some dimensioning for the call to handle_special3.  For regularity with
+	other parts of the RSL code it uses the glen/llen construct for carrying this
+	information, although in the case of n/s boundaries the i info is not used and
+	in the case of the e/w boundaries the j info is not used.  The boundary width
+	information is set above, in the assigment of request.speciala                   */
+
+  switch ( iorder )
+  {
+  case RSL_MLOW :                    /* south */
+    which_boundary = WHICH_BDY_SOUTH ;
+  case RSL_MHIGH :                   /* north */    /* FALL THROUGH */
+    which_boundary = WHICH_BDY_NORTH ;
+    request.glen[0] =  0 ;                 /* I dimension NOT USED for n/s boundaries */
+    request.glen[1] =  *bdy_g_length_p ;   /* Global length of boundary is global J */
+    request.glen[2] =  *bdy_height_p ;     /* number of levels */
+    request.llen[0] =  0 ;                 /* I dimension NOT USED for n/s boundaries */
+    request.llen[1] =  *bdy_l_length_p ;   /* Local length of boundary is local J */
+    request.llen[2] =  *bdy_height_p ;     /* number of levels */
+    break ;
+  case RSL_NLOW :                    /* west */
+    which_boundary = WHICH_BDY_WEST ;
+  case RSL_NHIGH :                   /* east */    /* FALL THROUGH */
+    which_boundary = WHICH_BDY_EAST ;
+    request.glen[0] =  *bdy_g_length_p ;   /* Global Length of boundary is global I */
+    request.glen[1] =  0 ;                 /* J dimension NOT USED for e/w boundaries */
+    request.glen[2] =  *bdy_height_p ;     /* number of levels */
+    request.llen[0] =  *bdy_l_length_p ;   /* Local length of boundary is local I */
+    request.llen[1] =  0 ;                 /* J dimension NOT USED for e/w boundaries */
+    request.llen[2] =  *bdy_height_p ;     /* number of levels */
+    break ;
+  default :
+    RSL_TEST_ERR(1,"Bad iorder spec for RSL_MM_DIST_BDY") ;
+    break ;
+  }
+
+
+  buf = NULL ;
+  got_bdy = handle_special3( &request, which_boundary, base, &buf ) ;
+
+  if ( got_bdy )
+  {
+    int i, j, k, by, b ;
+    int ix_g, jx_g, kx_g ;
+    int ix_l, jx_l, kx_l ;
+    ix_g = request.glen[0] ; jx_g = request.glen[1] ; kx_g = (request.ndim==3)?request.glen[2]:1 ;
+    ix_l = request.llen[0] ; jx_l = request.llen[1] ; kx_l = (request.ndim==3)?request.glen[2]:1 ;
+
+    switch ( iorder )
+    {
+    case RSL_NHIGH :
+    /* east */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( i = 0 ; i < ix_l ; i++ )
+	{
+          if ( i+ioffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+	    {
+	      base[by+tlen*(i+k*ix_l+b*ix_l*kx_l)]=buf[by+tlen*((i+ioffset)+k*ix_g+b*ix_g*kx_g)];
+	    }
+          }
+	}
+        break ;
+
+    case RSL_NLOW :
+    /* west */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( i = 0 ; i < ix_l ; i++ )
+        {
+          if ( i+ioffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+            {
+	      base[by+tlen*(i+k*ix_l+b*ix_l*kx_l)]=buf[by+tlen*((i+ioffset)+k*ix_g+b*ix_g*kx_g)];
+            }
+          }
+        }
+        break ;
+
+    case RSL_MHIGH :
+    /* north */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( j = 0 ; j < jx_l ; j++ )
+	{
+          if ( j+joffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+	    {
+	      base[by+tlen*(j+k*jx_l+b*jx_l*kx_l)]=buf[by+tlen*((j+joffset)+k*jx_g+b*jx_g*kx_g)];
+	    }
+	  }
+	}
+        break ;
+
+    case RSL_MLOW :
+    /* south */
+    for ( b = 0 ; b < bwdth ; b++ )
+      for ( k = 0 ; k < kx_l ; k++ )
+        for ( j = 0 ; j < jx_l ; j++ )
+	{
+          if ( j+joffset >= 0 )
+          {
+            for ( by = 0 ; by < tlen ; by++ )
+	    {
+	      base[by+tlen*(j+k*jx_l+b*jx_l*kx_l)]=buf[by+tlen*((j+joffset)+k*jx_g+b*jx_g*kx_g)];
+	    }
+	  }
+	}
+        break ;
+
+    default:
+        RSL_TEST_ERR(1,"what boundary was that??") ;
+        break ;
+    }
+  }
+
+  RSL_FREE( buf ) ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_mon_bcast.c b/wrfv2_fire/external/RSL/RSL/rsl_mon_bcast.c
new file mode 100755
index 00000000..cb347c39
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_mon_bcast.c
@@ -0,0 +1,147 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/* added 9/20/94 */
+
+/*
+ *  rsl_mon_bcast
+ *
+ *  broadcasts a buffer from the monitor to all other nodes 
+ *
+ *  Right now this is a dumb algorithm for portability.  Could
+ *  map this down to bcasts in specific underlying message packages
+ *  at some point.
+ */
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_MON_BCAST -- Broadcast a buffer from monitor to all other procs.
+
+  Notes:
+  On return, the contents of Arg1 on the monitor processor (usually
+  processor zero) will be contents of Arg1 on all processors.
+  The integer Arg2 is the number of bytes of Arg1 to be broadcast.
+  This routine may be called before RSL_MESH has been called.
+
+  This routine broadcasts the entire buffer, which is considered to be
+  replicated, and therefore undecomposed, data.
+  RSL also permits decomposed array data to be aggragated and distributed
+  from the monitor processor using internal writes and reads (see RSL_WRITE
+  and RSL_READ).
+
+  Despite the unfortunate similarity in names, this routine should not be confused with RSL_BCAST, the scatter operation
+  for nest forcing.  
+
+  Example:
+
+$ Need example
+
+BREAKTHEEXAMPLECODE
+
+  See also:
+  RSL_INITIALIZE, RSL_IAMMONITOR, RSL_READ, RSL_WRITE
+@*/
+
+RSL_MON_BCAST ( buf, nbytes0 )
+  void *
+    buf ;       /*  (IO) Buffer to be broadcast. */
+  int_p 
+    nbytes0 ;   /*  (I) Length of buffer in bytes. */
+{
+  int nbytes ;
+  int retval ;
+  int mtype, mdest, mfrom, mlen ;
+  int P ;
+
+  nbytes = *nbytes0 ;
+
+  RSL_TEST_ERR( buf == NULL, "NULL pointer" ) ;
+  RSL_TEST_ERR( nbytes < 0 , "Invalid (negative) number of bytes" ) ;
+
+#if 0
+/* Replaced this with an MPI_Bcast (below), 3/3/00 */
+  RSL_C_IAMMONITOR ( &retval ) ;
+
+  if ( retval == 1 )                    /* monitor code */
+  {
+    for ( P = 0 ; P < rsl_nproc_all ; P++ )     /* 95/02/22 */
+    {
+      if ( rsl_c_comp2phys_proc(P) != rsl_myproc )  /* not me */
+      {
+               mdest = rsl_c_comp2phys_proc (P) ;
+        mlen  = nbytes ;
+        mtype = MTYPE_FROMTO( MSG_MON_BCAST, rsl_myproc, mdest ) ;
+               RSL_SEND( buf, mlen, mtype, mdest ) ;
+      }
+    }
+  }
+  else                                  /* other nodes */
+  {
+    mfrom = RSL_C_MONITOR_PROC () ;
+    mlen  = nbytes ;
+    mtype  = MTYPE_FROMTO( MSG_MON_BCAST, mfrom, rsl_myproc ) ;
+    RSL_RECV( buf, mlen, mtype ) ;
+  }
+#else
+#  ifndef STUBS
+  MPI_Bcast( buf, nbytes, MPI_BYTE, 0, rsl_mpi_communicator ) ;
+#  endif
+#endif
+
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_move.c b/wrfv2_fire/external/RSL/RSL/rsl_move.c
new file mode 100755
index 00000000..6a3680ad
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_move.c
@@ -0,0 +1,64 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+rsl_move_cells()
+{
+   RSL_TEST_WRN( 1, "rsl_move_cells: stub" ) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_mpi_compat.c b/wrfv2_fire/external/RSL/RSL/rsl_mpi_compat.c
new file mode 100755
index 00000000..05566fa8
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_mpi_compat.c
@@ -0,0 +1,290 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#ifdef MPI
+#ifndef __MPI_COMPAT__
+#define __MPI_COMPAT__
+
+#include 
+#include 
+#include "mpi.h" 
+#include "rsl.h"
+
+#define RSLHandleInc 32
+
+
+struct tagsToHandles
+       {
+       int tag;
+       MPI_Request Handle;
+       };
+struct rslMPIHandles
+       {
+       int nHandles;
+       int nUsed;
+       struct tagsToHandles *tags;
+       } rslMPIHandleLUT;
+
+/******************************************************
+ * rslMPIInit ()
+ *   do whatever initialization is necessary for the
+ *   MPI port
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *  Adapted to MPI: J. Michalakes 7/13/94
+ *
+ *****************************************************/
+
+static int dummy = 0 ;
+
+#ifdef linux
+int xargc ;
+#endif
+
+void rslMPIInit()
+  {
+  int flag ;
+  rslMPIHandleLUT.nHandles = RSLHandleInc;
+  rslMPIHandleLUT.nUsed = 0;
+  rslMPIHandleLUT.tags = (struct tagsToHandles *) 
+                     malloc (sizeof (struct tagsToHandles) * RSLHandleInc);
+
+  MPI_Initialized( &flag ) ;
+
+  if ( ! flag ) {
+
+#ifndef linux
+  MPI_INIT_F ( &dummy ) ;  /* call to fortran wrapper */
+#else
+  xargc = iargc_()+1;
+#  ifdef F2CSTYLE
+  mpi_init__( &dummy ) ;
+#  else
+  mpi_init_( &dummy ) ;
+#  endif
+#endif
+
+  }
+
+#ifdef FATAL_ERRORS
+  if (rslMPIHandleLUT.tags == NULL)
+    {
+    fprintf (stderr, "Fatal Error: malloc failure in rslMPIInit\n");
+    exit(1);
+    }
+#endif
+  }
+
+
+/******************************************************
+ * rslMPIWho ( numproc, myproc )
+ *  Use the LUT to find an MPI wait handle from a tag
+ *
+ *  Initial coding: J. Michalakes  7/13/94
+ *
+ *****************************************************/
+
+long rslMPIWho( numproc, myproc )
+  int * numproc, * myproc ;
+{
+  MPI_Comm_rank( rsl_mpi_communicator, myproc ) ;
+  MPI_Comm_size( rsl_mpi_communicator, numproc ) ;
+  return( 0L ) ;
+}
+
+/******************************************************
+ * rslMPIFindWaitH (tag)
+ *  Use the LUT to find an MPI wait handle from a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+long rslMPIFindWaitH (tag, waitHandle)
+  int tag;   /* Tag for which we lookup a wait handle */
+  MPI_Request *waitHandle ;
+  {
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslMPIHandleLUT.nUsed; i++)
+    {
+    if (rslMPIHandleLUT.tags[i].tag == tag)
+      {
+      *waitHandle = rslMPIHandleLUT.tags[i].Handle;
+      rslMPIHandleLUT.nUsed--;  /* Keep them contiguous */
+      rslMPIHandleLUT.tags[i].tag=rslMPIHandleLUT.tags[rslMPIHandleLUT.nUsed].tag;
+      rslMPIHandleLUT.tags[i].Handle=
+                  rslMPIHandleLUT.tags[rslMPIHandleLUT.nUsed].Handle;
+      break;
+      }
+    }
+    return(0L) ;
+  }
+
+/******************************************************
+ * rslMPISaveWaitH (tag, waitHandle)
+ *  Use the LUT to save an MPI wait handle referenced by a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPISaveWaitH (tag, waitHandle)
+ int tag;
+ MPI_Request * waitHandle;
+ {
+ /* Make sure there is enough space, if not, try a realloc */
+ /* If the realloc fails we're in deep trouble */
+ if (rslMPIHandleLUT.nUsed == rslMPIHandleLUT.nHandles)
+   {
+   struct tagsToHandles *tags;  /* Temp pointer */
+   tags = (struct tagsToHandles *) 
+      realloc (rslMPIHandleLUT.tags, 
+      sizeof (struct tagsToHandles) * (rslMPIHandleLUT.nHandles + RSLHandleInc));
+   if (tags != NULL)
+     {
+     rslMPIHandleLUT.tags = tags;
+     rslMPIHandleLUT.nHandles += RSLHandleInc;
+     }
+   else
+     {
+#ifdef FATAL_ERRORS
+     fprintf (stderr, "Fatal Error: realloc failure in rslMPISaveWaitH\n");
+     exit(1);
+#endif
+     return;
+     }
+   }
+ /* Stash the handle */
+ rslMPIHandleLUT.tags[rslMPIHandleLUT.nUsed].tag = tag;
+ rslMPIHandleLUT.tags[rslMPIHandleLUT.nUsed].Handle = *waitHandle;
+ rslMPIHandleLUT.nUsed++;
+ }
+
+/******************************************************
+ * rslMPIISend (buff, mlen, tag, dest)
+ *  Post a non blocking send an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPIISend (buff, mlen, tag, dest)
+ char *buff;
+ int mlen;
+ int tag;
+ int dest;
+ {
+   MPI_Request waitHandle;
+ 
+   MPI_Isend (buff,
+              mlen,
+              MPI_BYTE,
+              dest,
+              tag,
+              rsl_mpi_communicator,
+              &waitHandle); 
+
+   rslMPISaveWaitH (tag, &waitHandle);
+ }
+ 
+/******************************************************
+ * rslMPIIRecv (buff, mlen, tag)
+ *  Post a non blocking receive an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPIIRecv (buff, mlen, tag)
+ char *buff;
+ int mlen;
+ int tag;
+ {
+   MPI_Request waitHandle;
+
+   MPI_Irecv (buff,
+              mlen,
+              MPI_BYTE,
+              MPI_ANY_SOURCE,
+              tag,
+              rsl_mpi_communicator,
+              &waitHandle);
+
+   rslMPISaveWaitH (tag, &waitHandle);
+ }
+
+/******************************************************
+ * rslMPIWait (tag)
+ *  Wait for a pending send/recv
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPIWait (tag)
+ int tag;
+ {
+ MPI_Request waitHandle;
+ MPI_Status status ;
+
+ rslMPIFindWaitH (tag, &waitHandle );
+ (void) MPI_Wait ( &waitHandle, &status  );
+ }
+
+#endif /* __MPI_COMPAT__ */
+#endif /* MPI */
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_mpl_compat.c b/wrfv2_fire/external/RSL/RSL/rsl_mpl_compat.c
new file mode 100755
index 00000000..5e016819
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_mpl_compat.c
@@ -0,0 +1,421 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#ifdef MPL
+#ifndef __MPL_COMPAT__
+#define __MPL_COMPAT__
+
+#include 
+#include "rsl.h"
+#include "rsl_comm.h"
+
+typedef int MPL_Request ;
+typedef int MPL_Status ;
+
+#define RSLHandleInc 32
+
+#define FATAL_ERRORS
+
+
+struct tagsToHandles
+       {
+       int tag;
+       MPL_Request Handle;
+       int type ;		/* send = 1, recv = 2 */
+       int nbytes ;
+       };
+struct rslMPLHandles
+       {
+       int nHandles;
+       int nUsed;
+       struct tagsToHandles *tags;
+       } rslMPLHandleLUT;
+
+/******************************************************
+ * rslMPLInit ()
+ *   do whatever initialization is necessary for the
+ *   MPL port
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *  Adapted to MPL: J. Michalakes 7/13/94
+ *
+ *****************************************************/
+
+static int argc_dummy = 0 ;
+static char * argv_dummy = "" ;
+
+int dontcare ;
+int allmsg ;
+int nulltask ;
+int allgrp ;
+int type_low ;
+int type_high ;
+
+void rslMPLInit()
+{
+  int nbuf[4] ;
+   
+  rslMPLHandleLUT.nHandles = RSLHandleInc;
+  rslMPLHandleLUT.nUsed = 0;
+  rslMPLHandleLUT.tags = (struct tagsToHandles *) 
+                     malloc (sizeof (struct tagsToHandles) * RSLHandleInc);
+
+  mpc_task_query( nbuf, 2, 2 ) ;
+  type_low = nbuf[0] ;
+  type_high= nbuf[1] ;
+  mpc_task_query( nbuf, 4, 3 ) ;
+  dontcare = nbuf[0] ;
+  allmsg   = nbuf[1] ;
+  nulltask = nbuf[2] ;
+  allgrp   = nbuf[3] ;
+
+#if 0
+  fprintf(stderr,"rslMPLInit: \n") ;
+  fprintf(stderr,"type_low:  %d\n",type_low) ;
+  fprintf(stderr,"type_high: %d\n",type_high) ;
+  fprintf(stderr,"dontcare:  %d\n",dontcare) ;
+  fprintf(stderr,"allmsg:    %d\n",allmsg) ;
+  fprintf(stderr,"nulltask:  %d\n",nulltask) ;
+  fprintf(stderr,"allgrp:    %d\n",allgrp) ;
+#endif
+
+
+#ifdef FATAL_ERRORS
+  if (rslMPLHandleLUT.tags == NULL)
+    {
+    fprintf (stderr, "Fatal Error: malloc failure in rslMPLInit\n");
+    exit(1);
+    }
+#endif
+}
+
+
+/******************************************************
+ * rslMPLFindWaitH (tag)
+ *  Use the LUT to find an MPL wait handle from a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+long rslMPLFindWaitH (tag, waitHandle, type, nbytes )
+  int tag;   /* Tag for which we lookup a wait handle */
+  MPL_Request *waitHandle ;
+  int *type, *nbytes ;
+{
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslMPLHandleLUT.nUsed; i++)
+  {
+    if (rslMPLHandleLUT.tags[i].tag == tag)
+    {
+      *waitHandle = rslMPLHandleLUT.tags[i].Handle;
+      *type = rslMPLHandleLUT.tags[i].type;
+      *nbytes = rslMPLHandleLUT.tags[i].nbytes;
+      rslMPLHandleLUT.nUsed--;  /* Keep them contiguous */
+      rslMPLHandleLUT.tags[i].tag=rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].tag;
+      rslMPLHandleLUT.tags[i].Handle=
+                  rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].Handle;
+      rslMPLHandleLUT.tags[i].type=
+		  rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].type;
+      rslMPLHandleLUT.tags[i].nbytes=
+		  rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].nbytes ;
+      retVal = 0 ;
+      break;
+    }
+  }
+  return( retVal ) ;
+}
+
+/* same as above, but leaves list alone */
+long rslMPLPeekWaitH (tag, waitHandle, type, nbytes )
+  int tag;   /* Tag for which we lookup a wait handle */
+  MPL_Request *waitHandle ;
+  int *type, *nbytes ;
+{
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslMPLHandleLUT.nUsed; i++)
+  {
+    if (rslMPLHandleLUT.tags[i].tag == tag)
+    {
+      *waitHandle = rslMPLHandleLUT.tags[i].Handle;
+      *type = rslMPLHandleLUT.tags[i].type;
+      *nbytes = rslMPLHandleLUT.tags[i].nbytes;
+      retVal = 0 ;
+      break;
+    }
+  }
+  return( retVal ) ;
+}
+
+
+/******************************************************
+ * rslMPLSaveWaitH (tag, waitHandle)
+ *  Use the LUT to save an MPL wait handle referenced by a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPLSaveWaitH (tag, waitHandle,type,nbytes)
+ int tag;
+ MPL_Request * waitHandle;
+ int type, nbytes ;
+{
+ /* Make sure there is enough space, if not, try a realloc */
+ /* If the realloc fails we're in deep trouble */
+ if (rslMPLHandleLUT.nUsed == rslMPLHandleLUT.nHandles)
+   {
+   struct tagsToHandles *tags;  /* Temp pointer */
+   tags = (struct tagsToHandles *) 
+      realloc (rslMPLHandleLUT.tags, 
+      sizeof (struct tagsToHandles) * (rslMPLHandleLUT.nHandles + RSLHandleInc));
+   if (tags != NULL)
+     {
+     rslMPLHandleLUT.tags = tags;
+     rslMPLHandleLUT.nHandles += RSLHandleInc;
+     }
+   else
+     {
+#ifdef FATAL_ERRORS
+     fprintf (stderr, "Fatal Error: realloc failure in rslMPLSaveWaitH\n");
+     exit(1);
+#endif
+     return;
+     }
+   }
+ /* Stash the handle */
+ rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].tag = tag;
+ rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].Handle = *waitHandle;
+ rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].type = type ;
+ rslMPLHandleLUT.tags[rslMPLHandleLUT.nUsed].nbytes = nbytes ;
+ rslMPLHandleLUT.nUsed++;
+}
+
+/******************************************************
+ * rslMPLISend (buff, mlen, tag, dest)
+ *  Post a non blocking send an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPLISend (buff, mlen, tag, dest)
+ char *buff;
+ int mlen;
+ int tag;
+ int dest;
+ {
+   MPL_Request waitHandle;
+   int rc ;
+ 
+   if ( tag < type_low || tag > type_high )
+   {
+sprintf(mess,"RSL_SENDBEGIN message type %d out of allowed range: %d..%d\n",
+tag,type_low,type_high) ;
+RSL_TEST_ERR( 1, mess ) ;
+   }
+
+   rc = mpc_send  (buff,
+              mlen,
+              dest,
+              tag,
+              &waitHandle); 
+
+#if 0
+fprintf(stderr,"mpc_send: nlen %10d  type %10d  dest %10d  handle %08x\n",
+mlen, tag, dest, waitHandle ) ;
+#endif
+
+   if ( rc )
+   {
+     sprintf(mess,"mpc_send returns %d", rc ) ;
+     RSL_TEST_ERR( 1, mess ) ;
+   }
+
+   rslMPLSaveWaitH (tag, &waitHandle,1,mlen);
+ }
+ 
+/******************************************************
+ * rslMPLIRecv (buff, mlen, tag)
+ *  Post a non blocking receive an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslMPLIRecv (buff, mlen, tag)
+ char *buff;
+ int mlen;
+ int tag;
+ {
+   MPL_Request waitHandle;
+   int source ;
+   int tagloc ;
+   int rc ;
+
+   source = dontcare ;
+   tagloc = tag ;
+
+   if ( tag < type_low || tag > type_high )
+   {
+sprintf(mess,"RSL_RECVBEGIN message type %d out of allowed range: %d..%d\n",
+tag,type_low,type_high) ;
+RSL_TEST_ERR( 1, mess ) ;
+   }
+
+
+   rc = mpc_recv  (buff,
+              mlen,
+              &source,
+              &tagloc,
+              &waitHandle);
+
+   if ( rc )
+   {
+     sprintf(mess,"mpc_recv returns %d", rc ) ;
+     RSL_TEST_ERR( 1, mess ) ;
+   }
+
+/* fprintf(stderr,"rslMPLIRecv tag = %d, handle = %d\n",tag,waitHandle) ; */
+
+   rslMPLSaveWaitH (tag, &waitHandle, 2, mlen);
+ }
+
+/******************************************************
+ * rslMPLWait (tag)
+ *  Wait for a pending send/recv
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+extern int mperrno ;
+ 
+void rslMPLWait (tag)
+ int tag;
+{
+  MPL_Request waitHandle;
+  MPL_Status status ;
+  int rc ;
+  int type, nbytes;
+
+  if ( rslMPLFindWaitH (tag, &waitHandle, &type, &nbytes ) != 0 )
+  {
+    fprintf(stderr,"rslMPLWait: tag %d not found by rslMPLFindWaitH\n",tag) ;
+    exit(2) ;
+  }
+
+#if 0
+  fprintf(stderr,"calling mpc_wait: tag %d, handle %08x, type %d (%s), original nbytes %d\n",
+        tag, waitHandle, type, (type==1)?"send":((type==2)?"recv":"unknown"),
+	nbytes) ;
+#endif
+
+  rc = mpc_wait ( &waitHandle, &status  );
+  if ( rc )
+  {
+    fprintf(stderr,"mpc_wait fails: tag %d, handle %08x, type %d (%s), original nbytes %d, status %d, rc %d, mperrno = %d\n",
+        tag, waitHandle, type, (type==1)?"send":((type==2)?"recv":"unknown"),
+	nbytes, status, rc, mperrno) ;
+    exit(2) ;
+  }
+
+#if 0
+  fprintf(stderr,"mpc_wait : tag %d, handle %08x, status %d\n",
+        tag, waitHandle, status) ;
+#endif
+
+}
+
+
+MPL_Request d1, d2, d3, waitHandle, d4, d5, d6 ;
+
+rslMPLProbe( tag, retval )
+  int tag, *retval ;
+{ 
+  MPL_Status status ;
+  int rc ;
+  int type, nbytes ;
+
+  if ( rslMPLPeekWaitH (tag, &waitHandle, &type, &nbytes ) != 0 )
+  {
+    fprintf(stderr,"rslMPLWait: tag %d not found by rslMPLPeekWaitH\n",tag) ;
+    exit(2) ;
+  }
+  rc = mpc_status( waitHandle ) ;
+
+  if ( rc >= 0 )
+  {
+    *retval = 1 ;
+  }
+  else if ( rc == -1 )
+  {
+    *retval = 0 ;
+  }
+  else
+  {
+    sprintf(mess,"No outstanding message for tag %d (handle %d) rc=%d\n",tag,waitHandle,rc) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+  return ;
+}
+
+#endif /* __MPL_COMPAT__ */
+#endif /* MPL */
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_new_decom.c b/wrfv2_fire/external/RSL/RSL/rsl_new_decom.c
new file mode 100755
index 00000000..af8d3931
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_new_decom.c
@@ -0,0 +1,789 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* routine and local data used by rsl_new_decomposition */
+static int count_neighbors_count ;
+static rsl_processor_t count_neighbors_myproc ;
+count_neighbors( d, m, n, hm, hn, pt, ipt )
+  rsl_index_t d ;
+  rsl_index_t m, n ;        /* this point */
+  rsl_index_t hm, hn ;      /* home point (whose stencil I'm on)  */
+  rsl_index_t pt ;              /* point in stencil */
+  rsl_index_t ipt ;             /* inverse point in stencil */
+{
+  int mlen ;
+  rsl_point_t *domain ;
+  rsl_domain_info_t *dinfo ;
+
+  dinfo = &(domain_info[d]) ;
+  domain = dinfo->domain ;
+  mlen = dinfo->len_m ;
+
+  if ( (domain[INDEX_2(n,m,mlen)].info_1 == 0)
+        && (domain[INDEX_2(n,m,mlen)].P != RSL_INVALID) /* 970216 */
+        && (domain[INDEX_2(n,m,mlen)].P != count_neighbors_myproc ) )
+  {
+    domain[INDEX_2(n,m,mlen)].info_1 = 1 ;    /* mark as counted */
+    count_neighbors_count++ ;           /* increment counter */
+  }
+}
+
+
+/* note that this has been changed to an internal routine that
+   is callable for a single domain at a time */
+int
+rsl_new_decomposition( d_p, mloc_p, nloc_p )
+  int_p d_p, 
+        mloc_p, nloc_p ; /* output: minimum sizes to hold local partition */
+{
+  int (*pt)(), (*f)() ;
+  int d, m, n ;
+  int mlen, nlen, zlen, meff, neff ;
+  int P ;
+  int i, j, k, size ;
+  int firsti, firstj, firstk ;
+  int mtype, mdest, retval ;
+  int maskid ;
+  int no_points ;
+  rsl_list_t *lp, *tlp[RSL_MAXDOMAINS] ;
+  rsl_domain_info_t *dinfo ;
+  rsl_point_t *domain ;
+
+  /* added 3/23/95 */
+  int nrun, eff_n, dex ;
+  rsl_list_t *rp ;
+
+  extern rsl_4pt(), rsl_8pt(), rsl_12pt(), rsl_24pt(), rsl_48pt(),
+         rsl_80pt(), rsl_120pt(), rsl_168pt(), count_neighbors() ;
+#if ( ALLOW_RSL_168PT == 1 )
+  extern rsl_168pt() ;
+#endif
+
+  P = rsl_c_phys2comp_proc(rsl_myproc) ;
+  d = *d_p ;
+
+  dinfo = &(domain_info[d]) ;
+
+/* 20010228 */
+
+/* work out the i, j, and k offsets for the transpose arrays */
+/* MZ */
+  domain = dinfo->domain_mz ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  zlen = dinfo->len_z ;
+  firsti = RSL_INVALID ;
+  firstk = RSL_INVALID ;
+  for ( k = 0 ; k < zlen ; k++ )
+  {
+    for ( i = 0 ; i < mlen ; i++ )
+    {
+      if ( rsl_c_comp2phys_proc ( domain[INDEX_2(k,i,mlen)].P ) == rsl_myproc )
+      {
+	if ( firsti == RSL_INVALID ) firsti = i ;
+	if ( firstk == RSL_INVALID ) firstk = k ;
+      }
+    }
+  }
+  dinfo->ilocaloffset_mz = firsti - rsl_padarea ;
+  dinfo->klocaloffset_mz = firstk ;
+  dinfo->jlocaloffset_mz = -rsl_padarea ;
+
+/* NZ */
+  domain = dinfo->domain_nz ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+  zlen = dinfo->len_z ;
+  firstj = RSL_INVALID ;
+  firstk = RSL_INVALID ;
+  for ( k = 0 ; k < zlen ; k++ )
+  {
+    for ( j = 0 ; j < nlen ; j++ )
+    {
+      if ( rsl_c_comp2phys_proc ( domain[INDEX_2(k,j,nlen)].P ) == rsl_myproc )
+      {
+	if ( firstj == RSL_INVALID ) firstj = j ;
+	if ( firstk == RSL_INVALID ) firstk = k ;
+      }
+    }
+  }
+  dinfo->jlocaloffset_nz = firstj - rsl_padarea ;
+  dinfo->klocaloffset_nz = firstk ;
+  dinfo->ilocaloffset_nz = -rsl_padarea ;
+
+/* end 20010228 */
+
+  domain = dinfo->domain ;
+  mlen = dinfo->len_m ;
+  nlen = dinfo->len_n ;
+
+  for ( n = 0 ; n < nlen ; n++ )
+    for ( m = 0 ; m < mlen ; m++ )
+    {
+      domain[INDEX_2(n,m,mlen)].info_1 = 0 ;    /* mark all untouched */
+    }
+
+  maskid = dinfo->maskid ;
+  switch( maskid )
+  {
+
+  case RSL_4PT   : pt = rsl_4pt  ; break ;
+  case RSL_8PT   : pt = rsl_8pt  ; break ;
+  case RSL_12PT  : pt = rsl_12pt ; break ;
+  case RSL_24PT  : pt = rsl_24pt ; break ;
+  case RSL_48PT  : pt = rsl_48pt ; break ;
+  case RSL_80PT  : pt = rsl_80pt ; break ;
+  case RSL_120PT  : pt = rsl_120pt ; break ;
+#if ( ALLOW_RSL_168PT == 1 )
+  case RSL_168PT  : pt = rsl_168pt ; break ;
+#endif
+  default: 
+     RSL_TEST_ERR(1,"rsl_new_decomposition(): bad mask spec") ; break ;
+
+  }
+  mlen = domain_info[d].len_m ;  /* actual dimensions */
+  nlen = domain_info[d].len_n ;
+  meff = domain_info[d].eff_m ;  /* effective dimensions */
+  neff = domain_info[d].eff_n ;
+  firsti = RSL_INVALID ;
+  firstj = RSL_INVALID ;
+  for ( n = 0 ; n < nlen ; n++ )
+  {
+    for ( m = 0 ; m < mlen ; m++ )
+    {
+      if ( domain[INDEX_2(n,m,mlen)].P == P ) 
+      {
+        /* this is assigned to the processor I'm looking at (me).
+           count it and it's untouched off proc neighbors */
+        /* set firsti and firstj for the computation of 
+           ioffset and joffset, later.  Note, what we're really
+           doing is finding the minimum index in each dimension. */
+        if ( domain[INDEX_2(n,m,mlen)].info_1 == 0 )
+        {
+          if ( firsti == RSL_INVALID ) 
+          {
+            firsti = m ;
+          }
+          else
+          {
+            if ( m < firsti ) firsti = m ;
+          }
+          if ( firstj == RSL_INVALID ) 
+          {
+            firstj = n ;
+          }
+          else
+          {
+            if ( n < firstj ) firstj = n ;
+          }
+          domain[INDEX_2(n,m,mlen)].info_1 = 1 ;
+
+          count_neighbors_myproc = P ;
+          count_neighbors_count = 0 ;
+          /* pt is the stencil function set above in this routine,
+             count_neighbors is defined in this file */
+          (*pt)( d, m, mlen, n, nlen, count_neighbors ) ;
+        }
+      }
+    }
+  }
+
+  /* work out the sizes of the local memory requirements for the domain */
+  /* for now, this information is just passed back to the caller; at some
+     point we could optionally allocate the domains, here or elsewhere
+     in RSL */
+
+  no_points=0;
+  if ( firsti == RSL_INVALID || firstj == RSL_INVALID )
+  {
+    no_points=1 ;
+    /* it so happens that this processor doesn't have any points */
+    *mloc_p = 0 ;
+    *nloc_p = 0 ;
+#if 0
+/* removed this return so that the js (and so forth) fields in the domain_info
+   structure get memory allocated  -- 981227 JM */
+    return ;                    /* RETURN */
+#endif
+  }
+  else
+  {
+    int mlow, nlow, mhigh, nhigh ;
+    mlow =   99999999 ;
+    nlow =   99999999 ;
+    mhigh = -99999999 ;
+    nhigh = -99999999 ;
+
+    for ( n = 0 ; n < nlen ; n++ )
+    {
+      for ( m = 0 ; m < mlen ; m++ )
+      {
+        if ( domain[INDEX_2(n,m,mlen)].P == P )
+        {
+          if ( m < mlow  ) mlow  = m ;
+          if ( m > mhigh ) mhigh = m ;
+          if ( n < nlow  ) nlow  = n ;
+          if ( n > nhigh ) nhigh = n ;
+        }
+      }
+    }
+#ifndef vpp
+    *mloc_p = mhigh - mlow + 1 + 2 * rsl_padarea ;
+#else
+    *mloc_p = mhigh - mlow + 1 ;
+#endif
+    *nloc_p = nhigh - nlow + 1 + 2 * rsl_padarea ;
+    dinfo->loc_m = *mloc_p ;
+    dinfo->loc_n = *nloc_p ;
+  }
+
+
+#ifndef vpp
+  dinfo->ilocaloffset = firsti-rsl_padarea ;
+#else
+  dinfo->ilocaloffset = firsti ;
+#endif
+
+  if ( old_offsets == 0 )
+  {
+    dinfo->jlocaloffset = firstj-rsl_padarea ;
+  }
+  else
+  {
+    if ( dinfo->nest_level == 0 )
+    {
+      dinfo->jlocaloffset = firstj-rsl_padarea ;
+    }
+    else
+    {
+      int prevsize, i, pid /*parent id*/, did /*domain id*/;
+      prevsize = 0 ;
+      did = d ;
+      for ( i = 0 ; i < dinfo->nest_level ; i++ )
+      {
+        pid = domain_info[did].parent ;
+        /*
+        prevsize +=  2*rsl_padarea + domain_info[pid].loc_n ;
+        */
+        prevsize +=  domain_info[pid].loc_n ;
+        did = pid ;
+      }
+      RSL_TEST_ERR( (did != 0) , "internal error" ) ;
+      dinfo->jlocaloffset = firstj - rsl_padarea - prevsize ;
+    }
+  }
+
+/* went back to use of actual dimensions -- will test for effective
+   dimensions using whether the point was trimmed */
+  for ( n = 0 ; n < nlen ; n++ )
+  {
+    for ( m = 0 ; m < mlen ; m++ )
+    {
+      if ( domain[INDEX_2(n,m,mlen)].trimmed == 0 )
+      {
+        if ( rsl_c_comp2phys_proc (domain[INDEX_2(n,m,mlen)].P) == rsl_myproc )
+        {
+          /* a local point -- add to list of local points */
+          lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+          lp->data = &(domain[INDEX_2(n,m,mlen)]) ;
+          lp->next = NULL ;
+          /* add to end of list of local points */
+          if ( domain_info[d].pts == NULL )
+          {
+             domain_info[d].pts = lp ;
+             tlp[d] = lp ;
+          }
+          else
+          {
+             tlp[d]->next = lp ;
+             tlp[d] = lp ;
+          }
+        }
+        /* this test is necessary to avoid counting everyone in the
+           domain -- we only want those who have been marked as neighbors
+           by the count_neighbors function */
+        else if ( domain[INDEX_2(n,m,mlen)].info_1 == 1 )
+        {
+          lp = RSL_MALLOC( rsl_list_t, 1 ) ;
+          lp->data = &(domain[INDEX_2(n,m,mlen)]) ;
+          lp->next = domain_info[d].ghost_pts ;
+          domain_info[d].ghost_pts = lp ;
+        }
+      }
+    }
+  }
+
+  /* 1/9/95.  compute runs through partition for rsl_compute_islab */
+
+  {
+    int retval, i, j, ig, jg, prev_ig, prev_jg ;
+    int start_i, start_j, start_ig, start_jg, runlength ;
+    rsl_list_t *rp, *trp[RSL_MAXDOMAINS] ;
+    rsl_runrec_t *rr ;
+
+
+    RSL_INIT_NEXTCELL ( &d ) ;
+    RSL_C_NEXTCELL ( &d, &i, &j, &ig, &jg, &retval ) ;
+    i-- ; j-- ; ig-- ; jg-- ;         /* base 0 for C */
+    start_i = i ;
+    start_j = j ;
+    start_ig = ig ;
+    start_jg = jg ;
+    runlength = 1 ;
+    prev_ig = ig-1 ;
+    prev_jg = jg ;
+    while ( retval != 0 )
+    {
+      if ( ! ( ig == prev_ig+1 && jg == prev_jg ) )
+      {
+        rr = RSL_MALLOC( rsl_runrec_t, 1 ) ;
+        rr->i  = start_i ;
+        rr->j  = start_j ;
+        rr->ig = start_ig ;
+        rr->jg = start_jg ;
+        rr->runlength = runlength-1 ;
+        rp = RSL_MALLOC( rsl_list_t, 1 ) ;
+        rp->data = rr ;
+        rp->next = NULL ;
+        /* add to list of local points */
+        if ( domain_info[d].iruns == NULL )
+        {
+           domain_info[d].iruns = rp ;
+           trp[d] = rp ;
+        }
+        else
+        {
+           trp[d]->next = rp ;
+           trp[d] = rp ;
+        }
+        runlength = 1 ;
+        start_i = i ;
+        start_j = j ;
+        start_ig = ig ;
+        start_jg = jg ;
+      }
+      prev_ig = ig ;
+      prev_jg = jg ;
+      RSL_C_NEXTCELL ( &d, &i, &j, &ig, &jg, &retval ) ;
+      if ( retval == 1 ) runlength++ ;
+      i-- ; j-- ; ig-- ; jg-- ;       /* base 0 for C */
+    }
+    /* handle last one */
+    if ( runlength != 0 )
+    {
+        rr = RSL_MALLOC( rsl_runrec_t, 1 ) ;
+        rr->i  = start_i ;
+        rr->j  = start_j ;
+        rr->ig = start_ig ;
+        rr->jg = start_jg ;
+        rr->runlength = runlength ;
+        rp = RSL_MALLOC( rsl_list_t, 1 ) ;
+        rp->data = rr ;
+        rp->next = NULL ;
+        /* add to list of local points */
+        if ( domain_info[d].iruns == NULL )
+        {
+           domain_info[d].iruns = rp ;
+           trp[d] = rp ;
+        }
+        else
+        {
+           trp[d]->next = rp ;
+           trp[d] = rp ;
+        }
+    }
+  }
+
+  /* 3/22/95.  compute 2d runs through partition for rsl_compute */
+  { 
+    int p ;
+    int i, j, ig, jg, prev_ig, prev_jg ;
+    int start_i, start_j, start_ig, start_jg, runlength ;
+    int nrun ;
+    int m, mlen ;
+    int n, nlen ;
+    int ilocaloffset, jlocaloffset ;
+    int first ;
+    int square ;
+
+    for ( p =  0 ; p <= MAX_KINDPAD ; p++ )
+    {
+      mlen = domain_info[d].len_m ;
+      nlen = domain_info[d].len_n ;
+      for ( n = 0 ; n < nlen ; n++ )
+        for ( m = 0 ; m < mlen ; m++ )
+        {
+          domain[INDEX_2(n,m,mlen)].info_1 = 0 ;    /* mark all untouched */
+        }
+
+      if ( p > 0 )
+      {
+        for ( n = 0 ; n < nlen ; n++ )
+        {
+          for ( m = 0 ; m < mlen ; m++ )
+          {
+            if ( domain[INDEX_2(n,m,mlen)].P == P ) 
+            {
+              /* this is assigned to the processor I'm looking at (me).
+                 count it and it's untouched off proc neighbors */
+                count_neighbors_myproc = P ;
+                count_neighbors_count = 0 ;
+              /* pt is the stencil function set above in this routine,
+                 count_neighbors is defined in this file */
+              switch ( p )
+              {
+              case 1 :
+                rsl_8pt( d, m, mlen, n, nlen, count_neighbors ) ;   
+                break ;
+              case 2 :
+#ifdef INLINE_COUNTS
+                square = 2 ;
+                /* note fall through */
+#else
+                rsl_24pt( d, m, mlen, n, nlen, count_neighbors ) ;  
+                break ;
+#endif
+	      case 3 :
+#ifdef INLINE_COUNTS
+                if ( sw_allow_dynpad )
+                {
+                  square = 3 ;
+                  /* note fall through */
+                }
+                else
+                {
+                  rsl_2ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 1 extra ns */
+                  break ;
+                }
+#else
+		if ( sw_allow_dynpad )
+		{
+                  rsl_48pt( d, m, mlen, n, nlen, count_neighbors ) ;
+		}
+		else
+		{
+                  rsl_2ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 1 extra ns */
+		}
+                break ;
+#endif
+	      case 4 :
+#ifdef INLINE_COUNTS
+		if ( sw_allow_dynpad )
+		{
+                  square = 4 ;
+                  /* note fall through */
+		}
+		else
+		{
+                  rsl_4ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 2 extra ns */
+                  break ;
+		}
+#else
+		if ( sw_allow_dynpad )
+		{
+                  rsl_80pt( d, m, mlen, n, nlen, count_neighbors ) ;
+		}
+		else
+		{
+                  rsl_4ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 2 extra ns */
+		}
+                break ;
+#endif
+	      case 5 :
+#ifdef INLINE_COUNTS
+                /* note fall through */
+                square = 5 ;
+#else
+                rsl_120pt( d, m, mlen, n, nlen, count_neighbors ) ;
+                break ;
+#endif
+	      case 6 :
+#ifdef INLINE_COUNTS
+                square = 6 ;
+{
+/* this code comes from pt.c, rsl_168pt */
+  rsl_index_t min = m ;
+  rsl_dimlen_t minlen = mlen ;
+  rsl_index_t maj = n ;
+  rsl_dimlen_t majlen = nlen ;
+
+  rsl_index_t i, j ;
+
+  for ( i = -square ; i <= square ; i++ )
+  {
+    for ( j = -square ; j <= square ; j++ )
+    {
+      if ( min+i >= 0 && min+i < minlen &&
+             maj+j >= 0 && maj+j < majlen )
+      {
+
+# ifdef INLINE_COUNTS
+/* this code is count_neighbors, above, in this file */
+{
+  rsl_index_t m=min+i, n=maj+j ;        /* this point */
+  rsl_index_t hm=min, hn=maj ;      /* home point (whose stencil I'm on)  */
+
+  if ( (domain[INDEX_2(n,m,mlen)].info_1 == 0)
+        && (domain[INDEX_2(n,m,mlen)].P != RSL_INVALID) /* 970216 */
+        && (domain[INDEX_2(n,m,mlen)].P != count_neighbors_myproc ) )
+  {
+    domain[INDEX_2(n,m,mlen)].info_1 = 1 ;    /* mark as counted */
+    count_neighbors_count++ ;           /* increment counter */
+  }
+}
+# else
+        (*f)(d,min+i,maj+j,min,maj,pts168[k],ipts168[k]) ;
+# endif
+      }
+    }
+  }
+}
+
+#else
+                rsl_168pt( d, m, mlen, n, nlen, count_neighbors ) ; 
+#endif
+                break ;
+	      /* special cases */
+              case 7 :
+                rsl_2ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 1 extra ns */
+                break ;
+              case 8 :
+                rsl_4ptm( d, m, mlen, n, nlen, count_neighbors ) ; /* 2 extra ns */
+                break ;
+              default :
+                sprintf(mess,"internal error p=%d\n",p) ;
+                RSL_TEST_ERR(1,mess) ; 
+              }
+            }
+          }
+        }
+      }
+      /* at this point all the cells in my partition are marked */
+
+      /* set up j-major iteration */
+      if ( domain_info[d].js[p] != NULL ) RSL_FREE( domain_info[d].js[p] ) ;
+      if ( domain_info[d].is[p] != NULL ) RSL_FREE( domain_info[d].is[p] ) ;
+      if ( domain_info[d].ie[p] != NULL ) RSL_FREE( domain_info[d].ie[p] ) ;
+      if ( domain_info[d].jg2n[p] != NULL ) RSL_FREE( domain_info[d].jg2n[p] ) ;
+      domain_info[d].js[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].is[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].ie[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].jg2n[p] = RSL_MALLOC(int,2*nlen+10) ;
+      ilocaloffset = domain_info[d].ilocaloffset ;
+      jlocaloffset = domain_info[d].jlocaloffset ;
+      for ( nrun = 0 ; nrun < 2*nlen+10 ; nrun++ )
+      {
+	domain_info[d].is[p][nrun] = 999999 ;
+	domain_info[d].ie[p][nrun] = -999999 ;
+      }
+      nrun = 0 ;
+      if ( ! no_points )
+      {
+      first = 1 ;
+      for ( n = 0 ; n < nlen ; n++ )
+      {
+        for ( m = 0 ; m < mlen ; m++ )
+        {
+          if ( domain[INDEX_2(n,m,mlen)].trimmed == 0 )
+          {
+            if (domain[INDEX_2(n,m,mlen)].P == P
+              || ( domain[INDEX_2(n,m,mlen)].info_1 == 1 ))
+            {
+              ig = ID_IDEX(domain[INDEX_2(n,m,mlen)].id) ;
+              jg = ID_JDEX(domain[INDEX_2(n,m,mlen)].id) ;
+              i = ig - ilocaloffset ;
+              j = jg - jlocaloffset ;
+              if ( first )
+              {
+                first = 0 ;
+                start_i = i ;
+                start_j = j ;
+                start_ig = ig ;
+                start_jg = jg ;
+                runlength = 1 ;
+                prev_ig = ig-1 ;
+                prev_jg = jg ;
+                domain_info[d].idif = i - ig ;
+                domain_info[d].jdif = j - jg ;
+              }
+              else
+              {
+                runlength++ ;
+              }
+              if ( ! ( ig == prev_ig+1 && jg == prev_jg ) )
+              {
+                domain_info[d].js[p][nrun] = start_j + 1 ;
+                domain_info[d].is[p][nrun] = start_i + 1 ;
+                domain_info[d].ie[p][nrun] = start_i + runlength-1 ;
+		domain_info[d].jg2n[p][jg] = nrun + 1  ;
+                runlength = 1 ;
+                start_i = i ;
+                start_j = j ;
+                start_ig = ig ;
+                start_jg = jg ;
+                nrun++ ;
+              }
+              prev_ig = ig ;
+              prev_jg = jg ;
+            }
+          }
+        }
+      }
+      /* handle last one -- note assumption on setting of jg for
+	 the index into jg2n field */
+      if ( runlength != 0 )
+      {
+        domain_info[d].js[p][nrun] = start_j + 1 ;
+        domain_info[d].is[p][nrun] = start_i + 1 ;
+        domain_info[d].ie[p][nrun] = start_i + runlength ;
+	domain_info[d].jg2n[p][jg] = nrun + 1  ;
+        nrun++ ; 
+      }
+      }
+      domain_info[d].nrun[p] = nrun ;
+
+      /* set up i-major iteration */
+      if ( domain_info[d].is2[p] != NULL ) RSL_FREE( domain_info[d].is2[p] ) ;
+      if ( domain_info[d].js2[p] != NULL ) RSL_FREE( domain_info[d].js2[p] ) ;
+      if ( domain_info[d].je2[p] != NULL ) RSL_FREE( domain_info[d].je2[p] ) ;
+      if ( domain_info[d].ig2n[p] != NULL ) RSL_FREE( domain_info[d].ig2n[p] ) ;
+      domain_info[d].is2[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].js2[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].je2[p] = RSL_MALLOC(int,2*nlen+10) ;
+      domain_info[d].ig2n[p] = RSL_MALLOC(int,2*nlen+10) ;
+      ilocaloffset = domain_info[d].ilocaloffset ;
+      jlocaloffset = domain_info[d].jlocaloffset ;
+      for ( nrun = 0 ; nrun < 2*nlen+10 ; nrun++ )
+      {
+	domain_info[d].js2[p][nrun] = 999999 ;
+	domain_info[d].je2[p][nrun] = -999999 ;
+      }
+      nrun = 0 ;
+      if ( ! no_points )
+      {
+      first = 1 ;
+      for ( m = 0 ; m < mlen ; m++ )
+      {
+        for ( n = 0 ; n < nlen ; n++ )
+        {
+          if ( domain[INDEX_2(n,m,mlen)].trimmed == 0 )
+          {
+            if (domain[INDEX_2(n,m,mlen)].P == P
+              || ( domain[INDEX_2(n,m,mlen)].info_1 == 1 ))
+            {
+              ig = ID_IDEX(domain[INDEX_2(n,m,mlen)].id) ;
+              jg = ID_JDEX(domain[INDEX_2(n,m,mlen)].id) ;
+              i = ig - ilocaloffset ;
+              j = jg - jlocaloffset ;
+              if ( first )
+              {
+                first = 0 ;
+                start_i = i ;
+                start_j = j ;
+                start_ig = ig ;
+                start_jg = jg ;
+                runlength = 1 ;
+                prev_jg = jg-1 ;
+                prev_ig = ig ;
+              }
+              else
+              {
+                runlength++ ;
+              }
+              if ( ! ( jg == prev_jg+1 && ig == prev_ig ) )
+              {
+                domain_info[d].is2[p][nrun] = start_i + 1 ;
+                domain_info[d].js2[p][nrun] = start_j + 1 ;
+                domain_info[d].je2[p][nrun] = start_j + runlength-1 ;
+		domain_info[d].ig2n[p][jg] = nrun + 1  ;
+                runlength = 1 ;
+                start_i = i ;
+                start_j = j ;
+                start_ig = ig ;
+                start_jg = jg ;
+                nrun++ ;
+              }
+              prev_ig = ig ;
+              prev_jg = jg ;
+            }
+          }
+        }
+      }
+      /* handle last one -- note assumption on setting of jg for
+	 the index into jg2n field */
+      if ( runlength != 0 )
+      {
+        domain_info[d].is2[p][nrun] = start_i + 1 ;
+        domain_info[d].js2[p][nrun] = start_j + 1 ;
+        domain_info[d].je2[p][nrun] = start_j + runlength ;
+	domain_info[d].ig2n[p][jg] = nrun + 1  ;
+        nrun++ ; 
+      }
+      }
+      domain_info[d].nruni[p] = nrun ;
+    }
+  }
+  return(0) ;
+}
+
+RSL_ALLOW_DYNPAD ()
+{
+  sw_allow_dynpad = 1 ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_nl.c b/wrfv2_fire/external/RSL/RSL/rsl_nl.c
new file mode 100755
index 00000000..b4be16ed
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_nl.c
@@ -0,0 +1,71 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* return nesting level  for domain */
+RSL_NL ( domain_p, nl_p )
+  int_p  domain_p, nl_p ;
+{
+  int d ;
+
+  d = *domain_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS, "rsl_nl: invalid domain index") ;
+  *nl_p = domain_info[ d ].nest_level ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_nx_compat.c b/wrfv2_fire/external/RSL/RSL/rsl_nx_compat.c
new file mode 100755
index 00000000..bfc0043c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_nx_compat.c
@@ -0,0 +1,300 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#ifdef PGON
+#ifndef __PGON_COMPAT__
+#define __PGON_COMPAT__
+#include 
+#include 
+
+#define RSLHandleInc 32
+
+extern int errno ;
+
+struct tagsToHandles
+       {
+       int tag;
+       long nxHandle;
+       };
+struct rslNXHandles
+       {
+       int nHandles;
+       int nUsed;
+       struct tagsToHandles *tags;
+       } rslNXHandleLUT;
+
+/******************************************************
+ * rslNXInit ()
+ *   do whatever initialization is necessary for the
+ *   NX port
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+void rslNXInit()
+  {
+  rslNXHandleLUT.nHandles = RSLHandleInc;
+  rslNXHandleLUT.nUsed = 0;
+  rslNXHandleLUT.tags = (struct tagsToHandles *) 
+                     malloc (sizeof (struct tagsToHandles) * RSLHandleInc);
+#ifdef FATAL_ERRORS
+  if (rslNXHandleLUT.tags == NULL)
+    {
+    fprintf (stderr, "Fatal Error: malloc failure in rslNXInit\n");
+    exit(1);
+    }
+#endif
+  }
+
+/******************************************************
+ * rslNXFindWaitH (tag)
+ *  Use the LUT to find an NX wait handle from a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+
+long rslNXFindWaitH (tag)
+  int tag;   /* Tag for which we lookup a wait handle */
+  {
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslNXHandleLUT.nUsed; i++)
+    {
+    if (rslNXHandleLUT.tags[i].tag == tag)
+      {
+      retVal = rslNXHandleLUT.tags[i].nxHandle;
+      rslNXHandleLUT.nUsed--;  /* Keep them contiguous */
+      rslNXHandleLUT.tags[i].tag=rslNXHandleLUT.tags[rslNXHandleLUT.nUsed].tag;
+      rslNXHandleLUT.tags[i].nxHandle=
+                  rslNXHandleLUT.tags[rslNXHandleLUT.nUsed].nxHandle;
+      break;
+      }
+    }
+  return retVal;
+  }
+
+/******************************************************
+ * rslNXPeekWaitH (tag)
+ *  Use the LUT to find an NX wait handle from a tag
+ *
+ * same as above but does not remove from list.  JM. 9/27/94
+ *
+ *****************************************************/
+
+long rslNXPeekWaitH (tag)
+  int tag;   /* Tag for which we lookup a wait handle */
+  {
+  int i;
+  long retVal = -1;
+
+  for (i=0; i < rslNXHandleLUT.nUsed; i++)
+    {
+    if (rslNXHandleLUT.tags[i].tag == tag)
+      {
+      retVal = rslNXHandleLUT.tags[i].nxHandle;
+      break;
+      }
+    }
+  return retVal;
+  }
+
+
+
+/******************************************************
+ * rslNXSaveWaitH (tag, waitHandle)
+ *  Use the LUT to save an NX wait handle referenced by a tag
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslNXSaveWaitH (tag, waitHandle)
+ int tag;
+ long waitHandle;
+ {
+ /* Make sure there is enough space, if not, try a realloc */
+ /* If the realloc fails we're in deep trouble */
+ if (rslNXHandleLUT.nUsed == rslNXHandleLUT.nHandles)
+   {
+   struct tagsToHandles *tags;  /* Temp pointer */
+   tags = (struct tagsToHandles *) 
+      realloc (rslNXHandleLUT.tags, 
+      sizeof (struct tagsToHandles) * (rslNXHandleLUT.nHandles + RSLHandleInc));
+   if (tags != NULL)
+     {
+     rslNXHandleLUT.tags = tags;
+     rslNXHandleLUT.nHandles += RSLHandleInc;
+     }
+   else
+     {
+#ifdef FATAL_ERRORS
+     fprintf (stderr, "Fatal Error: realloc failure in rslNXSaveWaitH\n");
+     exit(1);
+#endif
+     return;
+     }
+   }
+ /* Stash the handle */
+ rslNXHandleLUT.tags[rslNXHandleLUT.nUsed].tag = tag;
+ rslNXHandleLUT.tags[rslNXHandleLUT.nUsed].nxHandle = waitHandle;
+ rslNXHandleLUT.nUsed++;
+ }
+
+/******************************************************
+ * rslNXISend (buff, mlen, tag, dest)
+ *  Post a non blocking send an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslNXISend (buff, mlen, tag, dest)
+ char *buff;
+ int mlen;
+ int tag;
+ int dest;
+ {
+ long waitHandle;
+ 
+ waitHandle = isend ((long) tag, buff, (long) mlen, (long) dest, (long) 0);
+ rslNXSaveWaitH (tag, waitHandle);
+ }
+ 
+/******************************************************
+ * rslNXIRecv (buff, mlen, tag)
+ *  Post a non blocking receive an stash a wait handle
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslNXIRecv (buff, mlen, tag)
+ char *buff;
+ int mlen;
+ int tag;
+ {
+ long waitHandle;
+
+ waitHandle = irecv ((long) tag, buff, (long) mlen);
+ rslNXSaveWaitH (tag, waitHandle);
+ }
+
+/******************************************************
+ * rslNXWait (tag)
+ *  Wait for a pending send/recv
+ *
+ *  Initial coding: Leslie Hart, 22 Apr 94
+ *
+ *****************************************************/
+ 
+void rslNXWait (tag)
+ int tag;
+ {
+ long waitHandle;
+
+ waitHandle = rslNXFindWaitH (tag);
+ (void) msgwait (waitHandle);
+ }
+
+/******************************************************
+ * rslNXProbe (tag)
+ *  check for pending receive
+ *
+ * added 9/27/94  jm
+ *
+ *****************************************************/
+ 
+rslNXProbe( tag, retval )
+  int tag, *retval ;
+{
+  long waitHandle;
+  long status ;
+  int rc ;
+  int type, nbytes ;
+
+
+  waitHandle = rslNXPeekWaitH (tag) ;
+  rc = _msgdone( waitHandle ) ;
+
+  if ( rc == 1 )
+  {
+/* message received... now make call that will remove tag from LUT.
+(on other systems, there would be a message wait later after this
+call that would do this, but on the Paragon there won't be.  Presently,
+RSL_PROBE is only called in exch_sten.c, and there is special paragon
+code there to ensure this.)  940927.  JM */
+    waitHandle = rslNXFindWaitH (tag) ;
+    *retval = 1 ;
+  }
+  else if ( rc == 0 )
+  {
+    *retval = 0 ;
+  }
+  else
+  {
+    fprintf(stderr,"Error in _msgdone(%d) for tag=%d.  errno=%d.\n",
+		    waitHandle, tag, errno ) ;
+    *retval = 0 ;
+  }
+
+  return ;
+}
+
+
+#endif /* __PGON_COMPAT__ */
+#endif /* PGON */
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_order.c b/wrfv2_fire/external/RSL/RSL/rsl_order.c
new file mode 100755
index 00000000..1a73c689
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_order.c
@@ -0,0 +1,348 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+RSL_ORDER ( d_p, dir_p ) 
+  rsl_index_t *d_p  ; /* domain */
+  int_p       dir_p ; /* sort direction */
+{
+  int d, dir, up ;
+  int retval ;
+  rsl_list_t *lp ;
+
+  RSL_TEST_ERR( d_p == NULL, "rsl_order: null domain ptr" ) ;
+  d = *d_p ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_order: bad domain descriptor") ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+    "rsl_order: invalid domain") ;
+  RSL_TEST_WRN(1,"RSL_ORDER: obsolete") ;
+
+  if ( dir_p != NULL )
+    dir = *dir_p ;
+  else
+    dir = MINMAJ_AA ;
+
+  lp = domain_info[d].pts ;
+
+  if ( MNMJ( dir ))  /* MNMJ, D1, and D2 macros defined in rsl.h */
+  {
+    up = D1(dir)?-1:1 ;
+    bubble( lp, up ) ; /* sort by inner key */
+    up = D2(dir)?-2:2 ;
+    bubble( lp, up ) ; /* sort by outer key */
+  }
+  else
+  {
+    up = D1(dir)?-2:2 ;
+    bubble( lp, up ) ; /* sort by inner key */
+    up = D2(dir)?-1:1 ;
+    bubble( lp, up ) ; /* sort by outer key */
+  }
+}
+
+lenlist( a )
+  rsl_list_t *a ;
+{
+  rsl_list_t *p ;
+  int i ;
+  for ( p = a, i = 0 ; p != NULL ; p = p->next ) i++  ;
+  return (i) ;
+}
+
+showlist( l, s )
+  rsl_list_t * l ;
+  char * s  ;
+{
+  rsl_list_t * lp ;
+  rsl_point_t *p ;
+  int i, j ;
+
+  for ( lp = l ; lp != NULL ; lp = lp->next ) 
+  {
+    p = (rsl_point_t *) lp->data ;
+    i = ID_IDEX( p->id ) ;
+    j = ID_JDEX( p->id ) ;
+    fprintf(stderr,"%s > %d %d\n",s,i,j) ;
+  }
+}
+
+rsl_sort( list, compare, up )
+  rsl_list_t **list ;
+  int (*compare)() ;
+  int up ;
+{
+#if 0
+  fprintf(stderr,"rsl_sort: lenlist(*list) = %d  %x\n", lenlist(*list), *list ) ; 
+#endif
+  rsl_sort1( list, compare, up ) ;
+}
+
+rsl_sort1( list, compare, up )
+  rsl_list_t **list ;
+  int (*compare)() ;
+  int up ;
+{
+  int n, np, nq ;
+  rsl_list_t *p, *q, *qnext ;
+
+  p = *list ; q = NULL ;
+
+  /* count items and q at list midpoint */
+  for ( n = 0, nq = 0 ; p != NULL ; p = p->next )
+  {
+    if ( n % 2 == 1 ) {
+      if ( q == NULL ) { q = *list ; }
+      else             { q = q->next ; }
+      nq++ ;
+    }
+    n++ ;
+  }
+  if ( n <= 1 ) return ;
+  np = n - nq ;  /* nq is length of first half; np is length of second half */
+
+  qnext = q->next ;
+  q->next = NULL ;
+  /* first half */
+  if ( nq > 1 )
+  {
+    rsl_sort1( list, compare, up ) ;
+  }
+  /* second half */
+  if ( np > 1 )
+  {
+    rsl_sort1( &qnext, compare, up ) ;
+  }
+  if ( n > 0 )
+  {
+    rsl_quicksort_merge ( list, *list, qnext, compare, up, n ) ;
+  }
+}
+
+rsl_quicksort_merge( retlist, a , b, compare, up, n )
+  rsl_list_t **retlist, *a , *b  ;
+  int (*compare)() ;
+  int up ;
+  int n ;
+{
+  rsl_list_t *newlist, *t, *p, *q ;
+  int i ;
+
+  p = b ; q = a ;
+  if ( q != NULL && p != NULL )
+  {
+    if ( (*compare)(q->data,p->data,up) )
+    {
+      newlist = p ;
+      p = p->next ;
+    }
+    else
+    {
+      newlist = q ;
+      q = q->next ;
+    }
+  }
+  else if ( p != NULL )
+  {
+    newlist = p ; p = p->next ;
+  }
+  else if ( q != NULL )
+  {
+    newlist = q ; q = q->next ;
+  }
+
+  t = newlist ;
+  for ( i = 1 ; i < n ; i++ )
+  {
+    if ( q != NULL && p != NULL )
+    {
+      if( (*compare)(q->data,p->data,up) )
+      {
+        t->next = p ;
+        p = p->next ;
+      }
+      else
+      {
+        t->next = q ;
+        q = q->next ;
+      }
+    }
+    else if ( q != NULL )
+    {
+      t->next = q ;
+      q = q->next ;
+    }
+    else if ( p != NULL )
+    {
+      t->next = p ;
+      p = p->next ;
+    }
+    t = t->next ;
+  }
+  t->next = NULL ;
+  *retlist = newlist ;
+}
+
+
+
+/* OBSOLETE */
+bubble( list, up )
+  rsl_list_t *list ;
+  int up ;
+{
+  int i, desc, p, c ;
+  rsl_list_t *lp, *prev ;
+  struct srtrec {
+    rsl_point_t *pt ;
+    int         k1 ;
+    int         k2 ;
+  } *lst, *lp2 ;
+  int swap, pass, listlen, kk ;
+  void * data ;
+  rsl_point_id_t id ;
+  rsl_point_t *pt ;
+
+  desc = 0 ;
+  if ( up < 0 )
+  {
+    up = -up ;
+    desc = 1 ;
+  }
+  listlen = 0 ;
+  for ( lp = list ; lp != NULL ; lp = lp->next ) listlen++ ;
+  lst = RSL_MALLOC( struct srtrec, listlen ) ;
+  for ( lp = list, lp2 = lst  ; lp != NULL ; lp = lp->next, lp2++ )
+  {
+    lp2->pt = (rsl_point_t *) lp->data ;
+    id = lp2->pt->id ;
+    lp2->k1 = ID_IDEX( id ) ;
+    lp2->k2 = ID_JDEX( id ) ;
+  }
+
+  pass = 0 ;
+  swap = 1 ;
+  while ( swap )
+  {
+    swap = 0 ;
+    lp2 = lst ;
+    switch ( up )
+    {
+    case 1:
+      for ( i = 0 ; i < listlen-1 ; i++ )
+      {
+	p = lp2->k1 ;
+	c = (lp2+1)->k1 ;
+	if ((desc && ( p < c )) || (!desc && ( p > c )))
+        {
+            pt = lp2->pt ;
+            lp2->pt = (lp2+1)->pt ;
+            (lp2+1)->pt = pt ;
+            kk = lp2->k1 ;
+            lp2->k1 = (lp2+1)->k1 ;
+            (lp2+1)->k1 = kk ;
+            swap = 1 ;
+        }
+        lp2++ ;
+      }
+      break ;
+    case 2:
+      for ( i = 0 ; i < listlen-1 ; i++ )
+      {
+	p = lp2->k2 ;
+	c = (lp2+1)->k2 ;
+	if ((desc && ( p < c )) || (!desc && ( p > c )))
+        {
+            pt = lp2->pt ;
+            lp2->pt = (lp2+1)->pt ;
+            (lp2+1)->pt = pt ;
+            kk = lp2->k2 ;
+            lp2->k2 = (lp2+1)->k2 ;
+            (lp2+1)->k2 = kk ;
+            swap = 1 ;
+        }
+        lp2++ ;
+      }
+      break ;
+    default:
+      RSL_TEST_ERR(1,"sort: no such key") ;
+      break ;
+    }
+
+    pass++ ;
+#if 0
+    if ( pass%100 == 0 )
+    {
+      fprintf(stderr,"pass %d, listlen %d\n",pass,listlen) ;
+    }
+#endif
+    if ( pass > (listlen + 110))
+    {
+      fprintf(stderr,"pass = %d, listlen=%d\n",pass,listlen) ;
+      RSL_TEST_ERR(1,"something's wrong in sort in rsl order") ;
+    }
+  }
+
+  /* restored sorted values to linked list */
+  for ( lp = list, lp2 = lst  ; lp != NULL ; lp = lp->next, lp2++ )
+  {
+    lp->data = lp2->pt ;
+  }
+
+  RSL_FREE(lst) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_probe.F b/wrfv2_fire/external/RSL/RSL/rsl_probe.F
new file mode 100755
index 00000000..e2ca2f46
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_probe.F
@@ -0,0 +1,65 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_probe( type, retval )
+      implicit none
+      integer type, retval, probe0
+      external probe0
+      retval = probe0( type )
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_remap_state.c b/wrfv2_fire/external/RSL/RSL/rsl_remap_state.c
new file mode 100755
index 00000000..37564701
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_remap_state.c
@@ -0,0 +1,470 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/* #define NOPACK   */
+/* #define NOUNPACK */
+/*
+   rsl_remap_state
+
+   Called to move partitions in memory and between processors
+   after a domain is re-decomposed.  Assumes that a state vector
+   has been associated with a domain.  If not, returns with warning.
+
+ */
+#include 
+#include 
+#include "rsl.h"
+
+extern rsl_list_t *point_move_receives[] ;	/* decomp.c */
+extern rsl_list_t *point_move_sends[] ;
+
+int debuggal_pack = 0 ;
+
+static int sendsize[RSL_MAXPROC] ;
+static int recvsize[RSL_MAXPROC] ;
+static int recvtag[RSL_MAXPROC] ;
+static int recvnpts[RSL_MAXPROC] ;
+
+/*@
+  RSL_REMAP_STATE --- Use previously defined state vectors to remap grid points.
+
+  Notes:
+  This routine is called at the point in a remapping at which two state vectors
+  --- one for the source data structures and one for the destination
+  data structures of a domain --- have 
+  been defined for RSL using RSL_DESCRIBE_STATE.  Remapping can be done in-place
+  (both state vectors may refer to the same data structures).  Also, a
+  new decomposition should have been given to RSL using RSL_FDECOMPOSE.
+
+  When this routine is called, RSL computes the difference between the
+  old and new mappings and constructs a schedule of points that need
+  to be moved between processors.  Using the schedule, it packs data
+  for moving grid points into messages, exchanges the messages between
+  processors, then unpacks the messages into their new locations.
+  Points may be moved in a processor's memory, even if the
+  points are not communicated (this allows RSL to make room for
+  an influx of points in the subdomain, if necessary).  RSL bases
+  packing and unpacking on the state vectors that have been previously
+  defined.
+
+  On return, old domain data structures may be discarded (assuming the
+  remapping has not been done in-place), and computation may resume.
+  All subsequent horizontal iteration, stencil-exchange, and
+  broadcast-merge communications will be over the new mapping.
+  The stencils and broadcast merges will automatically reconfigure
+  themselves the first time they are used on the new mapping.  However,
+  it is crucial that the loop macros (LoopMacros.m4) be re-initialized
+  by an execution of RSL_INIT_RUNVARS, before iteration is begun.
+  If the program is not using the loop macros and instead handling iteration
+  explicitely, a new call to RSL_GET_RUN_INFO or RSL_GET_RUN_INFOP is
+  required.  Iteration using the column-callable routines RSL_COMPUTE_CELLS
+  and RSL_COMPUTE_MASK does not need to be re-initialized.
+
+  Example:
+$ C Construct state vector for current mapping.
+$   dcp(1) = rsl_northsouth ; dcp(2) = rsl_eastwest ; dcp(3) = rsl_notdecomposed
+$   gl(1)  = d%m            ; gl(2)  = d%n          ; gl(3)  = d%nlev
+$   call rsl_create_message(ms)
+$   call rsl_build_message(ms,rsl_real,d%psa,size(shape(d%psa)),
+$                          dcp,gl,shape(d%psa))
+$   call rsl_build_message(ms,rsl_real,d%ua,size(shape(d%ua)),
+$                          dcp,gl,shape(d%ua))
+$   call rsl_build_message(ms,rsl_real,d%va,size(shape(d%va)),
+$                          dcp,gl,shape(d%va))
+$   . . .
+$   call rsl_describe_state(did,ms)
+$ C
+$ C New decomposition.
+$   retval=rsl_fdecompose(did,mapping,p_lt,p_ln,timers,mloc,nloc)
+$ C
+$   if (retval .eq. 0 ) then
+$ C
+$ C Construct state vector for new mapping and associate with
+$ C newly allocated data structures.
+$     call allocate_domain(tmp,did,tmp%m,tmp%n,tmp%nlev,mloc,nloc)
+$     call rsl_create_message(ms)
+$     call rsl_build_message(ms,rsl_real,tmp%ua,size(shape(tmp%psa)),
+$                            dcp,gl,shape(tmp%psa))
+$     . . .
+$     call rsl_describe_state(did,ms)
+$ C
+$ C Effect the remapping
+$     call rsl_remap_state(did)
+
+BREAKTHEEXAMPLECODE
+
+  This example is from the dynamic load balancing code in MM90,
+  the Fortran90 implementation of the Penn State/NCAR MM5.
+
+  A state vector --- an RSL message definition that contains a list of
+  all the fields that make up the state for a grid-column in the old
+  decomposition --- is constructed with successive calls to
+  RSL_BUILD_MESSAGE.  Then, the
+  domain DID is decomposed using the MM90 routine, MAPPING, passed as a
+  function to the RSL_FDECOMPOSE.  TIMERS is an MM90 array of timers for
+  containing per-grid-column performance data that is used by MAPPING.
+  TIMERS
+  is passed directly to MAPPING when it is called from within RSL.
+  RSL_FDECOMPOSE returns 0 for
+  success if the new mapping improves on the current one.
+  It also passes back MLOC and NLOC with the
+  dimensions of arrays that will be needed to hold the arrays of the processor
+  subdomain under the new decomposition.  Otherwise, the RSL_FDECOMPOSE
+  returns a non-zero value, indicating that the program should continue
+  to time step using the old decomposition.
+
+  If a new decomposition is adopted, MM90 allocates a new domain
+  structure, TMP, using MLOC and NLOC.  This will hold the remapped
+  data.  (RSL permits remapping in place, without resizing memory, but
+  this places restrictions on how far the remapping algorithm can go in
+  moving work around).  The code defines a new state vector identical to
+  the previous one except that it is associated with the new fields of TMP.
+
+  The call to RSL_REMAP_STATE effects the remapping.  RSL compares the
+  old and new mappings and generates the lists of moves between each
+  processor.  RSL then uses the information in the first state
+  vector to pack the columns to be moved into messages and sends the
+  messages between the processors. On arrival, the incoming messages are
+  unpacked using information from the second state vector.  When the call
+  returns TMP contains the remapped state data. The program then
+  uses pointer assignments (not shown) to swap old and new data into the
+  D domain, then the old data structures are deallocated.  In the end, D
+  points to the structure with the remapped data and the model resumes
+  time stepping on the domain under the new mapping.
+
+  See also:
+  RSL_DESCRIBE_STATE, RSL_FDECOMPOSE, LoopMacros.m4
+@*/
+
+RSL_REMAP_STATE ( d_p )
+  int_p d_p ; 	/* (I) RSL domain descriptor. */
+{
+  message_desc_t *old, *new ;
+  rsl_domain_info_t * dinfo ;
+  rsl_list_t *lp ;
+  int m1, m2, msize, size, npts, curs ;
+  int mtype, mdest ;
+  int isaved, jsaved ;
+  char *pbuf ;
+  int P ;
+  int d ;
+  int i, id, ig, jg, d1 ;
+
+  d = *d_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_remap_state: bad domain descriptor\n") ;
+  dinfo = &(domain_info[d]) ;
+  RSL_TEST_ERR(dinfo->valid != RSL_VALID,
+    "rsl_remap_state: descriptor is not for a valid domain\n") ;
+
+
+  /* get old and new state vectors */
+
+  RSL_TEST_ERR((old = dinfo->old_state_vect) == NULL,
+	"no state message previously associated with domain" );
+  RSL_TEST_ERR((new = dinfo->new_state_vect) == NULL,
+	"no state message associated with domain" ) ;
+  
+  /* figure out size and post a recieve for each processor in the receive list */
+  m1 = message_size( new ) ;
+  m2 = message_size( old ) ;
+  if ( m1 != m2 )
+  {
+    sprintf(mess,
+    "old (%d) and new (%d) state vectors cannot be different sizes.",m2,m1) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+  msize = m1 ;
+
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    size = 0 ;
+    npts = 0 ;
+    for ( lp = point_move_receives[P] ; lp != NULL ; lp = lp->next )
+    {
+#ifdef crayx1
+      size += msize + 2*sizeof(int) ;  /* size plus int for ig and jg */
+#else
+      size += msize + 2*sizeof(short) ;  /* size plus shorts for ig and jg */
+#endif
+      npts++ ;
+    }
+    if ( size > 0 )
+    {
+      if ( rsl_c_comp2phys_proc(P) != rsl_myproc )
+      {
+        pbuf = buffer_for_proc( P, size, RSL_RECVBUF ) ;
+        mtype = MTYPE_FROMTO( MSG_REDISTCOM,
+                              rsl_c_comp2phys_proc(P),
+                              rsl_myproc ) ;
+        RSL_RECVBEGIN( pbuf, size, mtype ) ;
+	recvsize[P] = size ;
+	recvtag[P] = mtype ;
+        recvnpts[P] = npts ;
+      }
+      else
+      {
+	recvsize[P] = size ;
+	recvtag[P] = mtype ;
+        recvnpts[P] = npts ;
+      }
+    }
+    else
+    {
+      recvsize[P] = 0 ;
+      recvnpts[P] = 0 ;
+      recvtag[P] = RSL_INVALID ;
+    }
+  }
+
+  isaved = dinfo->ilocaloffset ;
+  jsaved = dinfo->jlocaloffset ;
+  dinfo->ilocaloffset = dinfo->old_ilocaloffset ;
+  dinfo->jlocaloffset = dinfo->old_jlocaloffset ;
+
+  debuggal_pack = 0 ;
+
+  /* pack and send messages to each processor in the send list --
+     buffer the ones for me */
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    size = 0 ;
+    npts = 0 ;
+    for ( lp = point_move_sends[P] ; lp != NULL ; lp = lp->next )
+    {
+#ifdef crayx1
+      size += msize + 2*sizeof(int) ;
+#else
+      size += msize + 2*sizeof(short) ;
+#endif
+      npts++ ;
+    }
+    if ( size > 0 )
+    {
+      pbuf = buffer_for_proc( P, size, RSL_SENDBUF ) ;
+    }
+    curs = 0 ;
+    for ( lp = point_move_sends[P] ; lp != NULL ; lp = lp->next )
+    {
+#ifdef crayx1
+      bcopy( &(lp->info1), &(pbuf[curs]), sizeof(int)) ;        /* point id */
+      curs += sizeof(int) ;
+      bcopy( &(lp->info2), &(pbuf[curs]), sizeof(int)) ;        /* point id */
+      curs += sizeof(int) ;
+#else
+      bcopy( &(lp->info1), &(pbuf[curs]), sizeof(short)) ;      /* point id */
+      curs += sizeof(short) ;
+      bcopy( &(lp->info2), &(pbuf[curs]), sizeof(short)) ;      /* point id */
+      curs += sizeof(short) ;
+#endif
+      ig = lp->info1 ;
+      jg = lp->info2 ;
+#ifndef NOPACK
+      pack_message( old, pbuf, &curs, d, ig, jg ) ;
+#else
+      curs = size ;
+#endif
+      RSL_TEST_ERR(curs > size, "Buffer overflow") ;
+    }
+
+    if ( curs > 0 )
+    {
+      if ( rsl_myproc != rsl_c_comp2phys_proc(P) )
+      {
+        mtype = MTYPE_FROMTO( MSG_REDISTCOM,
+			      rsl_myproc,
+			      rsl_c_comp2phys_proc(P) ) ;
+        mdest = rsl_c_comp2phys_proc (P) ;
+        RSL_SEND( pbuf, curs, mtype, mdest ) ;
+      }
+      else
+      {
+	recvsize[P] = curs ;
+	recvnpts[P] = npts ;
+      }
+    }
+  }
+  dinfo->ilocaloffset = isaved ;
+  dinfo->jlocaloffset = jsaved ;
+
+  /* receive points from other processors and unpack in new position */
+  for ( P = 0 ; P < rsl_nproc_all ; P++ )
+  {
+    curs = 0 ;
+    if ( recvsize[P] > 0 ) 
+    {
+      if ( rsl_c_comp2phys_proc( P ) != rsl_myproc )
+      {
+        RSL_RECVEND( recvtag[P] ) ;
+	pbuf = buffer_for_proc( P, recvsize[P], RSL_RECVBUF ) ;
+      }
+      else
+      {
+	pbuf = buffer_for_proc( P, recvsize[P], RSL_SENDBUF ) ;
+      }
+      for ( i = 0 ; i < recvnpts[P] ; i++ )
+      {
+#ifdef crayx1
+        int id ;
+                                                                                                                    
+        bcopy( &(pbuf[curs]), &id, sizeof(int)) ;       /* point id */
+        curs += sizeof(int) ;
+        ig = id ;
+                                                                                                                    
+        bcopy( &(pbuf[curs]), &id, sizeof(int)) ;       /* point id */
+        curs += sizeof(int) ;
+#else
+        short id ;
+                                                                                                                    
+        bcopy( &(pbuf[curs]), &id, sizeof(short)) ;     /* point id */
+        curs += sizeof(short) ;
+        ig = id ;
+                                                                                                                    
+        bcopy( &(pbuf[curs]), &id, sizeof(short)) ;     /* point id */
+        curs += sizeof(short) ;
+#endif
+	jg = id ;
+
+#ifndef NOUNPACK
+        unpack_message( new, pbuf, &curs, d, ig, jg ) ;
+#endif
+      }
+    }
+  }
+
+  buffer_for_proc( rsl_c_phys2comp_proc(rsl_myproc), 0, RSL_FREEBUF ) ;
+
+  debuggal_pack = 0 ;
+
+}
+
+/*@
+  RSL_DESCRIBE_STATE --- Describe a state vector for use in remappping.
+
+  Notes:
+  This routine takes an RSL message, Arg2, and associates it with
+  the domain specified by Arg1.   The message Arg2 is built using
+  RSL_BUILD_MESSAGE.  The state vector is then stored internally
+  within RSL and used in run-time remapping (RSL_REMAP_STATE) for
+  dynamic load balancing.
+
+  RSL keeps a maximum of two state vectors internally, one representing
+  a new state and one representing an old.  Each call to RSL_DESCRIBE_STATE
+  installs Arg2 as the new new state vector, pushing the previous 
+  new state vector to the old position.   The previous old state vector
+  is discarded.  RSL_REMAP_STATE uses the old state vector as it's
+  guide for packing source data into messages
+  for remapping.   The new state vector is used for unpacking into
+  destination data structures.  See RSL_REMAP_STATE for a code example.
+
+  See also:
+  RSL_REMAP_STATE, RSL_BUILD_MESSAGES
+
+
+@*/
+
+RSL_DESCRIBE_STATE ( d_p, message )
+  int_p d_p ;
+  int_p message ;
+{
+  int d ;
+  int mh ;
+  rsl_domain_info_t * dinfo ;
+  message_desc_t *msg ;
+
+  d = *d_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_describe_state: bad domain descriptor\n") ;
+  dinfo = &(domain_info[d]) ;
+  RSL_TEST_ERR(dinfo->valid != RSL_VALID,
+    "rsl_describe_state: descriptor is not for a valid domain\n") ;
+
+  mh = *message ;
+  RSL_TEST_ERR( mh != RSL_INVALID && (mh < 0 || mh >=RSL_MAXDESCRIPTORS),
+"rsl_describe_state: bad message handle in list,\n  must be either valid message or RSL_INVALID") ;
+  dinfo->old_state_vect = dinfo->new_state_vect ;
+  if ( mh != RSL_INVALID )
+  {
+    RSL_TEST_ERR((msg = (message_desc_t *) mh_descriptors[ mh ])==NULL,
+       "rsl_describe_state: handle does not describe an active message") ;
+    RSL_TEST_ERR( msg->tag != MESSAGE_DESC,
+       "rsl_describe_state: handle given in message list is not for an rsl mesage def" ) ;
+    dinfo->new_state_vect = msg ;
+  }
+  else
+  {
+    dinfo->new_state_vect = NULL ;
+  }
+
+/* If there was not an old state, make the old state the dup of the new state */
+  if ( dinfo->old_state_vect == NULL )
+  {
+    dinfo->old_state_vect = dinfo->new_state_vect ;
+  }
+
+  release_mh_descriptor( &mh ) ;
+
+}
+
+void *
+myloc( x )
+  void * x ;
+{
+  return( x ) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsl_socket.c b/wrfv2_fire/external/RSL/RSL/rsl_socket.c
new file mode 100755
index 00000000..714b61ba
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsl_socket.c
@@ -0,0 +1,584 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+/*
+ *  rsl_socket.c  -- added 9/30/94
+ *
+ *               RSL_SOCKOPEN
+ *               RSL_SOCKREAD   <-- not yet
+ *               RSL_SOCKWRITE
+ *               RSL_SOCKCLOSE
+ */
+
+#include "stdio.h"
+#include "stdlib.h"
+#include "rsl.h"
+
+#include 
+#include 
+#include 
+#include 
+#include 
+
+
+/*@
+  RSL_SOCKCLOSE - close a socket
+
+  Synopsis:
+  subroutine RSL_SOCKCLOSE ( sid )
+
+  Input parameters:
+. sid  close a socket opened by RSL_SOCKOPEN
+
+  See also:
+  RSL_SOCKOPEN
+
+@*/
+RSL_SOCKCLOSE ( sid0 )
+  int_p sid0 ;          /* socket id -- set by this routine */
+{
+  int retval ;
+
+  RSL_C_IAMMONITOR ( &retval ) ;
+  if ( retval == 1 ) 
+  {
+    close(*sid0) ;
+  }
+}
+
+static int first = 1 ;
+
+
+/*@
+  RSL_SOCKOPEN - open a TCP/IP socket connection for reading or writing
+
+  Synopsis:
+  subroutine RSL_SOCKOPEN ( sid, portnum, hostname, namelen )
+  integer sid
+  integer portnum
+  character*(*) hostname
+  integer namelen
+
+  Input parameters:
+. portnum  port to connect to on hostname
+. hostname string containing the name of the remote host
+. namelen  length in characters of hostname
+
+  Output parameters:
+. sid	socket descriptor for use in subsequent operations on socket
+
+  Notes:
+  Open a TCP/IP stream socket to a host for later use by RSL_SOCKWRITE and
+  RSL_SOCKREAD.  Portnum must be specified and it is the number of the
+  port on the remote host to connect to.   The name of the host
+  (e.g., xyz.abc.com) is passed to the routine as a string whose length
+  is passed as namelen.
+  
+  On return, sid argument contains the socket descriptor.
+
+  Example:
+
+$ call rsl_sockopen( sid, 5550, 'xyz.abc.com', 11 )
+
+BREAKTHEEXAMPLECODE
+
+  Bugs:
+
+  The routine prints a warning message if it fails to open
+  a socket and returns.  It would be better if this returned
+  an error code.
+
+  See also:
+  socket(2), RSL_SOCKWRITE, RSL_SOCKREAD, RSL_SOCKCLOSE
+
+
+@*/
+RSL_SOCKOPEN ( sid0, portnum0, hstname0, namelen0 )
+  int_p sid0 ;		/* socket id -- set by this routine */
+  int_p portnum0 ;	/* port number input to this routine */
+  char *hstname0 ;	/* name of host */
+  int_p namelen0 ;	/* number of characters in hstname0 */
+{
+  int i, retval  ;
+  char * p, * q, c ;
+  int portnum ;
+  char hstname[128] ;
+
+  struct sockaddr_in name;
+  struct hostent *hp, *gethostbyname();
+
+
+
+  RSL_C_IAMMONITOR ( &retval ) ;
+  if ( retval == 1 )
+  {
+
+    /* process input args from fortran */
+    portnum = *portnum0 ;
+    RSL_TEST_WRN( hstname0 == NULL, "Null hstname argument" ) ;
+    if ( *namelen0 < 0 || *namelen0 > 64 )
+    {
+      sprintf(mess,"Invalid hstname length %d.",*namelen0) ;
+      RSL_TEST_WRN(1,mess) ;
+    }
+    strncpy( hstname, hstname0, *namelen0 ) ;
+    hstname[*namelen0] = '\0' ;
+/* get rid of any white space */
+    {
+      char *p, *q;
+      for ( p = hstname, q = p ; *p ; p++ )
+	if ( *p != ' ' && *p != '\t' && *p != '\n' ) *q++ = *p ; 
+      *q = '\0' ;
+    }
+/* end mod for removing white space */
+
+    /* create socket */
+    if ( (*sid0 = socket(AF_INET,SOCK_STREAM,0)) < 0 ) 
+    {
+      perror("opening socket") ;
+      RSL_TEST_WRN(1,"") ;
+    }
+
+    /* connect socket */
+    name.sin_family = AF_INET;
+    if((hp = gethostbyname(hstname)) == NULL )
+    {
+      sprintf(mess,"%s: unknown host", hstname);
+      RSL_TEST_WRN(1,mess) ;
+    }
+
+    bcopy((char *)hp -> h_addr, (char *)&name.sin_addr, hp-> h_length);
+    name.sin_port = htons(portnum);
+
+    if(connect(*sid0, (struct sockaddr *)&name, sizeof(name)) < 0)
+    {
+      perror("connecting stream socket");
+      RSL_TEST_WRN(1,"") ;
+    }
+    if ( first == 1 )
+    {
+      first = 0 ;
+      setup_socket(*sid0) ;
+    }
+  }
+
+fprintf(stderr,"RSL_SOCKOPEN returns *sid0 = %d\n",*sid0) ;
+  return ;
+}
+
+/************/
+
+/*@
+  RSL_SOCKWRITE - write a distributed two- or three-dimensional array to a socket
+
+  Synopsis:
+  subroutine RSL_SOCKWRITE ( sid, iotag, var, domain, type, glen, llen )
+
+  Input parameters:
+. socket descriptor
+. iotag  tag describing array dimensions
+. var    distributed array being written
+. domain  domain descriptor
+. type   type of an array element
+. glen   integer array of global (undecomposed) dimensions of array
+. llen  integer array of local static dimensions of array
+
+  Notes:
+  A distributed two- or three-dimensional array will be written to
+  a socket, previously opened with RSL_SOCKOPEN.  Except as noted below,
+  the semantics are similar to RSL_READ and RSL_WRITE (which read and
+  write Fortran files).  The reader should become familiar with these
+  routines first.
+
+  A number of different output options are available, depending on the
+  value of iotag.  The tags IO2D_IJ, IO2D_JI, IO3D_IJK, or IO3D_JIK specify
+  Fortran-style record blocking (that is, with Fortran record blocking 
+  information encoded in the data stream).   The data is written to the
+  socket, but a Fortran record-blocking control word is added to the
+  beginning and end of each record written to the socket.  (Each 4-byte
+  control word is a byte
+  count for the record that follows/preceeds it, and for each n-byte
+  record written, n+8 bytes will actually be written to the socket).
+
+  The tags IO2D_IJ_RAW, IO2D_JI_RAW, IO3D_IJK_RAW, and IO3D_JIK_RAW specify
+  that the data is to be streamed to the socket as-is, with no additional
+  record blocking information.
+
+  The tags IO2D_IJ_PORTAL, IO2D_JI_PORTAL, IO3D_IJK_PORTAL, and
+  IO3D_JIK_PORTAL specify that special header packets understood by the
+  Portal communication library (see reference below) are added to the
+  beginning of each record.  This header data describes the dimensionality
+  of the data that will follow and the size of the dimensions; Portal
+  should be used on the receiving process to properly handle data written
+  in this mode.
+
+  Example:
+
+$ glen(1) = il
+$ glen(2) = jl
+$ glen(3) = mkx
+$ llen(1) = mix
+$ llen(2) = mjx
+$ llen(3) = mkx
+
+$ m2 = IO2D_IJ_RAW
+$ m3 = IO3D_IJK_RAW
+
+$ call rsl_sockwrite(sock,m2,ht,domains(inest),RSL_REAL,glen,llen)
+$ call rsl_sockwrite(sock,m3,ta,domains(inest),RSL_REAL,glen,llen)
+
+BREAKTHEEXAMPLECODE
+
+  The 2-dimensional distributed array ht and the three-dimensional
+  distributed array ta are written in raw mode to the socket specified
+  by sock.  Sock has been opened using RSL_SOCKOPEN.
+
+  See also:
+  ``Portal Communication Library for Run-Time Visualization of Distributed,
+  Asynchronous Data,'' J.S. Rowlan, B.T. Wightman, Mathematics and Computer
+  Science Division, Argonne National Laboratory, 1994.  Preprint MCS-P395-1193.
+
+  RSL_SOCKOPEN, RSL_SOCKCLOSE, RSL_READ, RSL_WRITE
+
+
+@*/
+RSL_SOCKWRITE ( unit_p, iotag_p, base, d_p, type_p, glen, llen  )
+  int_p unit_p ;
+  int_p iotag_p ;
+  int_p type_p ;
+  int_p d_p ;
+  char * base ;
+  int glen[], llen[] ;
+{
+  rsl_read_req_t request ;
+  rsl_read_resp_t resp ;
+  rsl_processor_t me ;
+  int cursor, mdest, mtag, msglen, dim ;
+  int mlen, nlen ;
+  int minelems, majelems ;
+  unsigned long ig, jg, min, maj, ioffset, joffset, tlen, k ;
+  void * dex ;
+  char *pbuf ;
+  int i_am_monitor ;
+  int psize, nelem, typelen, nbytes, columnelems  ;
+  rsl_point_t *domain ;
+
+  RSL_TEST_ERR( *d_p < 0 || *d_p >= RSL_MAXDOMAINS,
+		"rsl_sockwrite: bad domain descriptor") ;
+  RSL_TEST_ERR( domain_info[*d_p].valid != RSL_VALID,
+		"rsl_sockwrite: invalid domain descriptor" ) ;
+
+  mlen = domain_info[*d_p].len_m ;
+  nlen = domain_info[*d_p].len_n ;
+  domain = domain_info[*d_p].domain ;
+
+  RSL_C_IAMMONITOR ( &i_am_monitor ) ;
+
+  me = rsl_c_phys2comp_proc( rsl_myproc ) ;
+  ioffset = domain_info[*d_p].ilocaloffset ;
+  joffset = domain_info[*d_p].jlocaloffset ;
+  tlen = elemsize( *type_p ) ;
+
+  request.request_type = RSL_WRITE_REQUEST ;
+  request.request_mode = MSG_IO_SOCKET ;
+  request.myproc = rsl_myproc ;
+  request.base = base ;
+  request.domain = *d_p ;
+  request.unit = *unit_p ;
+  request.type = *type_p ;
+  request.iotag = *iotag_p ;
+  request.sequence = io_seq_compute++ ;
+  switch( *iotag_p )
+  {
+
+  case IO2D_IJ :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_FORTRAN ;
+    break ;
+  case IO2D_JI :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_FORTRAN ;
+    break ;
+  case IO3D_IJK :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_FORTRAN ;
+    break ;
+  case IO3D_JIK :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_FORTRAN ;
+    break ;
+
+  case IO2D_IJ_RAW :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_RAW ;
+    break ;
+  case IO2D_JI_RAW :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_RAW ;
+    break ;
+  case IO3D_IJK_RAW :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_RAW ;
+    break ;
+  case IO3D_JIK_RAW :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_RAW ;
+    break ;
+
+  case IO2D_IJ_PORTAL :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_PORTAL ;
+    break ;
+  case IO2D_JI_PORTAL :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_PORTAL ;
+    break ;
+  case IO3D_IJK_PORTAL :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_PORTAL ;
+    break ;
+  case IO3D_JIK_PORTAL :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_PORTAL ;
+    break ;
+
+  case IO2D_IJ_88 :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_88 ;
+    break ;
+  case IO2D_JI_88 :
+    request.ndim = 2 ;
+    request.request_mode2 = MSG_MODE2_88 ;
+    break ;
+  case IO3D_IJK_88 :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_88 ;
+    break ;
+  case IO3D_JIK_88 :
+    request.ndim = 3 ;
+    request.request_mode2 = MSG_MODE2_88 ;
+    break ;
+
+  default:
+    RSL_TEST_ERR(1,"rsl_read: unknown data tag") ;
+  }
+
+  for ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    request.glen[dim] = glen[dim] ;
+    request.llen[dim] = llen[dim] ;
+  }
+
+  /* figure out size of buffer needed */
+  nelem = 1 ;
+  for  ( dim = 0 ; dim < request.ndim ; dim++ )
+  {
+    nelem *= request.glen[dim] ;
+  }
+  typelen = elemsize( request.type ) ;
+  nbytes = nelem * typelen ;
+
+  switch ( request.iotag )
+  {
+
+  case IO2D_IJ :
+  case IO2D_IJ_RAW :
+  case IO2D_IJ_PORTAL :
+  case IO2D_IJ_88 :
+    columnelems = 1 ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO2D_JI :
+  case IO2D_JI_RAW :
+  case IO2D_JI_PORTAL :
+  case IO2D_JI_88 :
+    columnelems = 1 ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+  case IO3D_IJK :
+  case IO3D_IJK_RAW :
+  case IO3D_IJK_PORTAL :
+  case IO3D_IJK_88 :
+    columnelems = request.llen[2] ;
+    minelems = request.glen[0] ;
+    majelems = request.glen[1] ;
+    break ;
+  case IO3D_JIK :
+  case IO3D_JIK_RAW :
+  case IO3D_JIK_PORTAL :
+  case IO3D_JIK_88 :
+    columnelems = request.llen[2] ;
+    minelems = request.glen[1] ;
+    majelems = request.glen[0] ;
+    break ;
+
+  default:
+    RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
+  }
+
+
+  /*  figure out size for this processor */
+  pbuf = NULL ;
+  psize = 0 ;
+
+  RSL_TEST_ERR( majelems <= 0, "Major dim spec on write is zero or less.") ;
+  RSL_TEST_ERR( minelems <= 0, "Minor dim spec on write is zero or less.") ;
+  if ( majelems > domain_info[request.domain].len_n )
+  { sprintf(mess,"Major dim spec on write (%d) greater than global domain definition in that dimension (%d)\n",majelems,domain_info[request.domain].len_n) ;
+    RSL_TEST_ERR(1,mess) ; }
+  if ( minelems > domain_info[request.domain].len_m )
+  { sprintf(mess,"Minor dim spec on write (%d) greater than global domain definition in that dimension (%d)\n",minelems,domain_info[request.domain].len_m) ;
+    RSL_TEST_ERR(1,mess) ; }
+
+  for ( jg = 0 ; jg < majelems ; jg++ )
+  {
+    for ( ig = 0 ; ig < minelems ; ig++ )
+    {
+      if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+        psize += columnelems * typelen ;
+    }
+  }
+
+
+  pbuf = RSL_MALLOC( char, psize ) ;
+
+  cursor = 0 ;
+
+#if 0
+  for ( jg = 0 ; jg < domain_info[*d_p].len_n ; jg++ )
+  {
+    for ( ig = 0 ; ig < domain_info[*d_p].len_m ; ig++ )
+    {
+#else
+  for ( jg = 0 ; jg < majelems ; jg++ )
+  {
+    for ( ig = 0 ; ig < minelems ; ig++ )
+    {
+#endif
+      if ( me == domain[INDEX_2(jg,ig,mlen)].P )
+      {
+        switch( *iotag_p )
+        {
+        case IO2D_IJ :
+        case IO2D_IJ_RAW :
+        case IO2D_IJ_PORTAL :
+        case IO2D_IJ_88 :
+	  min = ig - ioffset ;
+	  maj = jg - joffset ;
+	  dex = base+tlen*(min+maj*llen[0]) ;
+	  bcopy(dex,&(pbuf[cursor]),tlen) ;
+	  cursor += tlen ;
+          break ;
+        case IO2D_JI :
+        case IO2D_JI_RAW :
+        case IO2D_JI_PORTAL :
+        case IO2D_JI_88 :
+	  min = jg - joffset ;
+	  maj = ig - ioffset ;
+	  dex = base+tlen*(min+maj*llen[0]) ;
+	  bcopy(dex,&(pbuf[cursor]),tlen) ;
+	  cursor += tlen ;
+          break ;
+        case IO3D_IJK :
+        case IO3D_IJK_RAW :
+        case IO3D_IJK_PORTAL :
+        case IO3D_IJK_88 :
+	  min = ig - ioffset ;
+	  maj = jg - joffset ;
+	  for ( k = 0 ; k < llen[2] ; k++ )
+	  {
+	    dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+	    bcopy(dex,&(pbuf[cursor]),tlen) ;
+	    cursor += tlen ;
+	  }
+          break ;
+        case IO3D_JIK :
+        case IO3D_JIK_RAW :
+        case IO3D_JIK_PORTAL :
+        case IO3D_JIK_88 :
+	  min = jg - ioffset ;
+	  maj = ig - joffset ;
+	  for ( k = 0 ; k < llen[2] ; k++ )
+	  {
+	    dex = base+tlen*(min+llen[0]*(maj+k*llen[1])) ;
+	    bcopy(dex,&(pbuf[cursor]),tlen) ;
+	    cursor += tlen ;
+	  }
+          break ;
+        }
+      }
+    }
+  }
+  if ( pbuf != NULL )
+  {
+  if ( i_am_monitor )
+  {
+    handle_write_request( &request, nelem, psize, pbuf ) ;
+  }
+  else
+  {
+    mdest = RSL_C_MONITOR_PROC () ;
+    msglen = psize ;
+    mtag = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, rsl_myproc, mdest ) ;
+    RSL_SEND( pbuf, msglen, mtag, mdest ) ;
+  }
+
+  RSL_FREE( pbuf ) ;
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/rsltest.F b/wrfv2_fire/external/RSL/RSL/rsltest.F
new file mode 100644
index 00000000..afd8c59c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/rsltest.F
@@ -0,0 +1,702 @@
+#include "LoopMacros.inc"
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC FORTRAN 90 MODULE DEFINITION FOR A 'DOMAIN'
+CC
+CC User program definition of domain data structure and
+CC manipulation routines.
+CC
+      module domains_module
+        integer :: maxkids              ! maximum number of children
+        parameter ( maxkids = 5 )
+C
+C Domainstruct is the principal domain data structure in the user
+C program.  It contains the size of the domain in local
+C memory and logically.  Also pointers to parent and child domains,
+C if any.  Also the RSL domain handle.  Also, the domain state
+C arrays themselves (unallocated, so virtually no storage expended
+C unless the domain is actually used).
+C
+        type domainstruct
+C
+C This section has "meta" information about the domain.
+C
+          type( domainstruct ), pointer ::
+     $           parent,        ! parent domain
+     $           child(:)       ! children
+          integer nkids         ! number of (active) children
+          integer nestlevel     ! nestlevel of this domain
+          integer domdesc       ! RSL domain handle
+          logical active        ! flag
+          integer m, mloc       ! global and local dimensions in m
+          integer n, nloc       ! global and local dimensions in n
+          integer sten          ! stencil descriptor
+          integer period        ! periodic boundary descriptor
+C
+C This section has the state arrays for the domain.
+C
+          real, pointer    :: X(:,:)
+          real, pointer    :: Y(:,:)
+        endtype domainstruct
+C
+C Declaration of the top-level domain (all others are children of this one)
+C
+        type ( domainstruct ), target :: mother
+C
+C Domain manipulation routines
+C
+        contains
+C
+C Initialize a domain data structure
+C
+        subroutine init_domain( d )
+          type(domainstruct) :: d
+          d%active = .false.
+          d%m = 0
+          d%n = 0
+        end subroutine
+C
+C Allocate the fields of the domain (including state arrays).  Once
+C this is called, the domain will take more than nominal storage.
+C
+        subroutine allocate_domain( d, m, n, mloc, nloc )
+          type(domainstruct) :: d       ! domain structure
+          integer m, n, mloc, nloc      ! global and local sizes
+          integer k                     ! child index
+
+          if ( d%active ) then
+            write(0,*) 'allocate_domain: domain already active.'
+            stop
+          endif
+C
+C Create and initialize structures for future children.   Note: only
+C the child domain structures and not the child state arrays are
+C being allocated here -- thus, the children require only nominal
+C storage until actually activated and allocated.
+C
+          allocate (d%child(maxkids))
+          do k = 1, maxkids
+            call init_domain( d%child(k) )
+          enddo
+C
+C Set the size information about this domain
+C
+          d%m = m
+          d%n = n
+          d%mloc = mloc
+          d%nloc = nloc
+          d%active = .true.
+          d%nkids = 0
+C
+C Allocate storage for state arrays.
+C
+          allocate (d%X(mloc,nloc))
+          allocate (d%Y(mloc,nloc))
+        end subroutine
+      end module
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC MAIN PROGRAM
+CC
+CC This is the main routine for a Fortran-90/RSL implementation of 
+CC a simple relaxation problem on a grid, with an irregularly shaped
+CC nested domain.
+CC 
+CC The bulk of the main routine, here, is involved with defining
+CC and allocating the problem, which can be done entirely at run-time
+CC by exploiting modern features of F90 such as derived data types
+CC and dynamic memory allocation.
+CC 
+CC The model itself is is executed in one call to another routine,
+CC ITERATE_MODEL
+CC at the bottom of this main program.
+CC 
+      program relaxmain
+      use domains_module
+      implicit none
+      type(domainstruct), pointer :: d
+      include "rsl.inc"
+      integer m,n,mloc,nloc,did         ! coarse domain params
+      integer m_n,n_n,mloc_n,nloc_n,nid ! nested domain params
+      integer mtrim, ntrim              ! trim for the nest
+      integer xlist(20), ylist(20), npoints   ! outline of nest
+      integer iter                      ! number of iterations to perform 
+      integer k                         ! child index
+      integer nproc_m, nproc_n          ! number of procs in m, n
+      integer rsl_patch_decomp
+      external rsl_patch_decomp
+C
+C Initialize RSL
+C
+      call rsl_initialize
+C
+C Input run-time problem configuration information
+C
+      if ( rsl_iammonitor() ) then
+         read(7,*)m,n              ! mother domain size specif. at run time
+         read(7,*)iter             ! number of mother domain iterations
+         read(7,*)nproc_m, nproc_n ! number of processors specif. at run time
+      endif
+      call rsl_mon_bcast( m , 4 )
+      call rsl_mon_bcast( n , 4 )
+      call rsl_mon_bcast( iter , 4 )
+      call rsl_mon_bcast( nproc_m , 4 )
+      call rsl_mon_bcast( nproc_n , 4 )
+       write(0,*)nproc_m,nproc_n
+      call rsl_mesh ( nproc_m, nproc_n )
+      CALL RSL_ERROR_DUP
+      CALL SET_DEF_DECOMP_FCN( rsl_patch_decomp )
+
+C
+C Mother domain.  Note that the RSL routine is called before the
+C domain is allocated.  This allows the local state arrays to be
+C allocated only as large as necessary (using the size information
+C returned by rsl_mother_domain in mloc and nloc).
+C
+      call init_domain(mother)
+C
+      call rsl_mother_domain(
+     $                       did,               ! output: RSL domain handle
+     $                       RSL_8PT,           ! input: max stencil
+     $                       m, n,              ! input: global size
+     $                       mloc, nloc )       ! output: local size
+C
+      call show_domain_decomp ( did )
+      call allocate_domain( mother, m, n, mloc, nloc )
+      mother%domdesc = did                      ! store RSL handle in domain
+      mother%nestlevel = 1                      ! nest level of mother is 1
+#if 0
+C
+C Specify the "trim" for the nest
+C
+      mtrim = 2
+      ntrim = 2
+C
+C Spawn an irregular nest using the outline and trim information
+C specified above.
+C
+      call RSL_SPAWN_REGULAR_NEST1(
+     $              nid,                        ! output: nest handle
+     $              mother%domdesc,             ! input: parent handle
+     $              RSL_8PT,                    ! input: max stencil
+     $              10, 12,
+     $              37, 40,
+     $              3, 3,                       ! input: nesting ratios
+     $              mloc_n, nloc_n,             ! output: local memory size
+     $              m_n, n_n )                  ! output: global size
+      CALL SHOW_DOMAIN_DECOMP( did )
+      CALL SHOW_DOMAIN_DECOMP( nid )
+C
+C Allocate using local size information returned by RSL.
+C
+      call allocate_domain( mother%child(1), m_n, n_n, mloc_n, nloc_n )
+C
+C Set fields in domain structures associating nest with parent
+C
+      mother%nkids = 1                          ! mother has one nest
+      mother%child(1)%parent    => mother       ! back pointer to parent
+      mother%child(1)%domdesc   =  nid          ! store RSL handle
+      mother%child(1)%nestlevel =  mother%nestlevel+1
+#else
+      mother%nkids = 0                          ! mother has no nest
+#endif
+C
+C Define the stencil communications on the mother and all subnests
+C
+      call define_data( mother )                ! user routine: recursive
+C
+C Initialize the interior of the mother and the boundary cells
+C
+      call init_grid( mother, mloc, nloc, 1 )
+C
+C Initialize the nests with data from the mother.  (There is only
+C one nest in this example, but this code allows for more).
+C
+      do k = 1, mother%nkids
+        call initial_nest_data( mother, mother%child(k) )
+      enddo
+C
+C Write initial state of the model
+C
+      call output_domains( mother )             ! recursive
+C
+C Execute 'iter' iterations of the simulation.  The following call
+C executes on the mother and recursively on all nests.
+C
+      call iterate_model( mother, 1, iter )     ! main time loop (recursive)
+C
+      call rsl_shutdown
+      stop
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC ITERATE_MODEL
+CC
+CC Main computational routine -- loop over time, iteration over mother
+CC and all subnests, and control of inter-domain data exchanges.
+CC
+      recursive subroutine iterate_model( d, iter1, itern )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d           ! input: domain 
+      integer iter1, itern              ! input: starting and ending steps
+
+      integer t                         ! local: time step on this domain
+      integer k                         ! local: child index
+
+      do t = iter1, itern
+        call relax_grid( d, d%mloc, d%nloc, 1 )         ! compute this domain
+        do k = 1, d%nkids                               ! for each nest...
+          call force_domain( d, d%child(k) )            !   force
+          call iterate_model( d%child(k), 1, 3 )        !   RECURSIVE CALL
+          call merge_domain( d, d%child(k) )            !   feedback
+        enddo
+        if ( d%nestlevel .eq. 1 .and.
+     $      ((mod(t-1, 5) .eq. 0) .or. (t .eq. itern))
+     $                                            ) then
+          call output_domains( d )                      ! if time, output
+
+        endif
+      enddo
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC RELAX_GRID
+CC
+CC This is the main computational routine that is called for one step
+CC on a domain.  The new value for each point is computed as the
+CC average of the values of 8 neighbors.  Prior to the computation,
+CC a stencil exchange is performed to ensure that off-processor data
+CC will be available for the computation.
+CC
+      subroutine relax_grid( d, ilen, jlen, klen )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d           ! input: domain being computed
+      integer ilen,                     ! input: local array sizes in m
+     $        jlen,                     ! input: local array sizes in n
+     $        klen                      ! input: local array sizes in vertical
+      RSL_DECLARE_RUN_VARS( 500 )      ! declares looping information
+      integer m, n, i, j                ! local: misc info
+      real New( ilen, jlen )            ! local: temporary array
+      integer bdyinfo(ilen,jlen, CROSS_BDY_INFO_LEN)
+                                        ! local: proximity information
+      real, pointer :: X(:,:)           ! local: state array pointer
+C
+C Initialize RSL loop constructs
+C
+      call rsl_get_run_info( d%domdesc, 500, RSL_RUN_VARS )
+C
+C Get boundary proximity information for each cell from RSL.
+C
+      call rsl_get_bdy_larray( d%domdesc, bdyinfo, CROSS_BDY_INFO_LEN )
+C
+C Exchange data with other processors on this domain using the stencil
+C information defined for and stored with the domain.
+C
+
+         write(60+rsl_myproc,*) jlen, ilen, ' XA '
+         do i = 1, ilen
+         do j = 1, jlen
+            write(60+rsl_myproc,*) d%X(i,j)
+         enddo
+         enddo
+         write(70+rsl_myproc,*) jlen, ilen, ' YA '
+         do i = 1, ilen
+         do j = 1, jlen
+            write(70+rsl_myproc,*) d%Y(i,j)
+         enddo
+         enddo
+
+      call rsl_exch_period( d%domdesc, d%period )
+
+         write(60+rsl_myproc,*) jlen, ilen, ' XB '
+         do i = 1, ilen
+         do j = 1, jlen
+            write(60+rsl_myproc,*) d%X(i,j)
+         enddo
+         enddo
+         write(70+rsl_myproc,*) jlen, ilen, ' YB '
+         do i = 1, ilen
+         do j = 1, jlen
+            write(70+rsl_myproc,*) d%Y(i,j)
+         enddo
+         enddo
+
+      call rsl_exch_stencil( d%domdesc, d%sten )
+
+C
+C Set pointer to domain state array.  Size info.
+C
+      X => d%X
+      m = d%m
+      n = d%n
+C
+C Main loop over horizontal dimensions of partition of array that
+C is stored on local processor.  If a boundary cell, hold fixed,
+C otherwise compute average.  Boundary cells are those with a boundary
+C proximity of zero (i.e. they are zero cells away from a boundary).
+C
+      RSL_MAJOR_LOOP(j)
+        RSL_MINOR_LOOP(i)
+          if ( bdyinfo(i,j,RSL_DBDY) .eq. 1 ) then
+             New(i,j) = X(i,j)
+          else
+             New(i,j) =  (
+     $          X(i+1,j-1)   +  X(i+1,j)  +  X(i+1,j+1) +
+     $          X(i,j-1)     +               X(i,j+1)   +
+     $          X(i-1,j-1)   +  X(i-1,j)  +  X(i-1,j+1)
+     $                 ) / 8.0
+          endif
+        RSL_END_MINOR_LOOP
+      RSL_END_MAJOR_LOOP
+C
+C Update X.
+C
+      RSL_MAJOR_LOOP(j)
+        RSL_MINOR_LOOP(i)
+          X(i,j) = New(i,j)
+        RSL_END_MINOR_LOOP
+      RSL_END_MAJOR_LOOP
+C
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC OUTPUT_DOMAINS
+CC
+CC Called initially and periodically.  Outputs state of model on 
+CC to separate files for each nest level.
+CC
+      recursive subroutine output_domains( d )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d                   ! input: domain
+      integer k                                 ! local: child index
+      integer glen(2), llen(2)                  ! local: size arrays
+C
+      glen(1) = d%m
+      glen(2) = d%n
+      llen(1) = d%mloc
+      llen(2) = d%nloc
+C
+C Output top level domain
+C
+      call rsl_write( 18+d%nestlevel-1,         ! Fortran unit for output
+     $                IO2D_IJ,                  ! describe record
+     $                d%X,                      ! data for record
+     $                d%domdesc,                ! domain descriptor
+     $                RSL_REAL,                 ! type of each element
+     $                glen, llen )              ! size info
+C
+C Foreach nest, output it and its subnests recursively.
+C
+      do k = 1, d%nkids
+        call output_domains( d%child(k) )       ! recurse
+      enddo
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC INITIAL_NEST_DATA
+CC
+CC Set the cells in the nest to values transferred down from the parent.
+CC This is called to initialize the nest.
+CC
+      subroutine initial_nest_data ( d, nst )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d, nst              ! input: parent and nest
+      integer pi, pj, pig, pjg                  ! local: parent indices
+      integer ni, nj, nig, njg                  ! local: nest indices
+      integer m, n, i, j, msize                 ! local: misc variables
+      integer cm, cn                            ! local: relative nest index
+      integer retval                            ! local: return value
+      real, pointer :: X(:,:)                   ! local: pointer to state array
+C
+C Point to parent's state arrays.
+C
+      X => d%X
+C
+C Build a message for each point on the nest using data from the
+C overlying cell in the parent domain.  Loop goes until we have handled
+C data from all the parent domain points on this processor.
+C
+      call rsl_to_child_info( d%domdesc, nst%domdesc, 4,
+     $                        i, j, pig, pjg, cm, cn, nig, njg, retval )
+      do while ( retval .eq. 1 )
+        call rsl_to_child_msg( 4, X(i,j) )
+        call rsl_to_child_info( d%domdesc, nst%domdesc, 4,
+     $                          i, j, pig, pjg, cm, cn, nig, njg, retval )
+      enddo
+C
+C Exchange the data using RSL inter-domain communication.
+C
+      call rsl_bcast_msgs
+C
+C Now, point to nest state data
+C
+      X => nst%X
+      X = 0.
+C
+C Unpack the message on each point of the nest.  Loop goes until we
+C have unpacked all the nested domain points that are local to this
+C processor.
+C
+      call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg, retval )
+      do while ( retval .eq. 1 )
+        call rsl_from_parent_msg( 4, X(i,j) )
+        call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg, retval )
+      enddo
+C
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC FORCE_DOMAIN
+CC
+CC Similar to init_domain, except this is called at
+CC each step to force only the boundaries of the nest
+CC (not the entire domain, as in init_domain).
+CC
+      subroutine force_domain ( d, nst )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d, nst              ! input: parent and nest
+      integer pi, pj, pig, pjg                  ! local: parent indices
+      integer ni, nj, nig, njg                  ! local: nest indices
+      integer m, n, i, j, msize                 ! local: misc variables
+      integer cm, cn                            ! local: relative nest index
+      integer retval                            ! local: return value
+      real, pointer :: X(:,:)                   ! local: pointer to state array
+      integer bdyinfo(CROSS_BDY_INFO_LEN)       ! local: boundary proximity
+C
+C Point to parent's state arrays.
+C
+      X => d%X
+C
+C Build a message for ONLY THOSE POINTS on the nest that are on a boundary.
+C The call to rsl_get_bdy_gpt gets the proximity information for a nested
+C point.  The information is then used to decide whether or not data should
+C be packed for that point.  Note: RSL will automatically size the messages
+C between processors to exchange only that data that is packed.
+C
+      call rsl_to_child_info( d%domdesc, nst%domdesc, 4,
+     $                        i, j, pig, pjg, cm, cn, nig, njg, retval )
+      do while ( retval .eq. 1 )
+        call rsl_get_bdy_gpt( nst%domdesc, bdyinfo, CROSS_BDY_INFO_LEN, nig, njg )
+        if ( bdyinfo(RSL_DBDY) .ge. 1 .and. bdyinfo(RSL_DBDY) .le. 2 ) then
+          write(0,999)'xx ' ,rsl_myproc,nig, njg, pig, pjg, cm, cn
+ 999      format(a3,7i5) 
+          call rsl_to_child_msg( 4, X(i,j) )
+        endif
+        call rsl_to_child_info( d%domdesc, nst%domdesc, 4,
+     $                          i, j, pig, pjg, cm, cn, nig, njg, retval )
+      enddo
+C
+C Exchange the data using RSL inter-domain communication.
+C
+      call rsl_bcast_msgs
+C
+C Now, point to nest state data
+C
+      X => nst%X
+C
+C Unpack the message on each point of the nest.  Because the first phase
+C of the exchange packed only data for the boundary points, this loop 
+C will iterate only over those.
+C
+      call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg, retval )
+      do while ( retval .eq. 1 )
+        call rsl_from_parent_msg( 4, X(i,j) )
+        call rsl_from_parent_info( i, j, nig, njg, cm, cn, pig, pjg, retval )
+      enddo
+
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC MERGE_DOMAIN
+CC
+CC This implements the feedback of data from the nest to the parent.
+CC The structure is similar to FORCE_DOMAIN, except that the flow
+CC of information is in the opposite direction.  Data is returned only
+CC for the center nest point under each coarse domain point (cm=2, cn=2).
+CC
+      subroutine merge_domain ( d, nst )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d, nst              ! input: parent and nest
+      integer pi, pj, pig, pjg                  ! local: parent indices
+      integer ni, nj, nig, njg                  ! local: nest indices
+      integer m, n, i, j, msize                 ! local: misc variables
+      integer cm, cn                            ! local: relative nest index
+      integer retval                            ! local: return value
+      real, pointer :: X(:,:)                   ! local: pointer to state array
+C
+      X =>nst%X
+      call rsl_to_parent_info( d%domdesc, nst%domdesc, 4,
+     $                        i, j, nig, njg, cm, cn, pig, pjg, retval )
+      do while ( retval .eq. 1 )
+        if ( cm .eq. 1 .and. cn .eq. 1 ) then
+          call rsl_to_parent_msg( 4, X(i,j) )
+        endif
+        call rsl_to_parent_info( d%domdesc, nst%domdesc, 4,
+     $                          i, j, nig, njg, cm, cn, pig, pjg, retval )
+      enddo
+C
+      call rsl_merge_msgs
+C
+      X => d%X
+      call rsl_from_child_info( i, j, pig, pjg, cm, cn, nig, njg, retval )
+      do while ( retval .eq. 1 )
+        if ( cm .eq. 2 .and. cn .eq. 2 ) then
+          call rsl_from_child_msg( 4, X(i,j) )
+        endif
+        call rsl_from_child_info( i, j, pig, pjg, cm, cn, nig, njg, retval )
+      enddo
+C
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC INIT_GRID
+CC
+CC This is a computational routine whose purpose it is to assign
+CC a domain with initial values.  Boundary cells receive a non-zero
+CC initial value.  The interior receives a zero value.
+CC
+      subroutine init_grid( d, ilen, jlen, klen )
+      use domains_module
+      implicit none
+      include "rsl.inc"
+      type(domainstruct) :: d
+      integer ilen, jlen, klen
+      RSL_DECLARE_RUN_VARS( 500 )
+      integer bdyinfo(ilen,jlen,CROSS_BDY_INFO_LEN)
+      integer m, n, i, j
+      integer cn, cm
+      real, pointer :: X(:,:), Y(:,:)
+C
+      call rsl_get_run_info( d%domdesc, 500, RSL_RUN_VARS )
+      call rsl_get_bdy_larray( d%domdesc, bdyinfo, CROSS_BDY_INFO_LEN )
+C
+      X    => d%X
+      Y    => d%Y
+      m = d%m
+      n = d%n
+      X = 0.
+      Y = 0.
+C
+      RSL_MAJOR_LOOP(j)
+        RSL_MINOR_LOOP(i)
+          if ( bdyinfo(i,j,RSL_DBDY) .eq. 1 ) then
+C              X(i,j) = 10.0
+              X(i,j) = J + I *.01
+          else
+              X(i,j) = 0.0
+          endif
+          if ( bdyinfo(i,j,RSL_DBDY_X) .eq. 1 ) then
+              Y(i,j) = J + I *.01
+          else
+              Y(i,j) = 0.0
+          endif
+        RSL_END_MINOR_LOOP
+      RSL_END_MAJOR_LOOP
+C
+      return
+      end
+CC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CC
+CC DEFINE_DATA
+CC
+CC This is called only once, prior to the first step of the model, and
+CC is used to define the stencils on all the domains in the simulation.
+CC Stencils, though identical, must be assigned individually for each
+CC domain.  This routine does that recursively for the domain 'd', and
+CC all nests under 'd'.
+CC
+      recursive subroutine define_data( d )
+      use domains_module
+      include "rsl.inc"
+      type(domainstruct) :: d           ! input: domain
+      integer decomp(3)                 ! local: how dimensions are decomposed
+      integer llen(3)                   ! local: local size in each dim.
+      integer glen(3)                   ! local: global size in each dim.
+      integer mesg                      ! local: a message definition
+      integer messages(8)               ! local: message for each stencil pt.
+      integer k                         ! local: child index
+!      interface
+!        subroutine rsl_build_message( mesg, type, var, dim , d1, d2, d3 )
+!          integer mesg, type, dim, d1(*), d2(*), d3(*)
+!          real    var(:,:)
+!        end subroutine rsl_build_message
+!      end interface
+C
+      decomp(1) = RSL_NORTHSOUTH        ! m is decomposed by n/s processors
+      decomp(2) = RSL_EASTWEST          ! n is decomposed by e/w processors
+      glen(1) = d%m                     ! global sizes set
+      glen(2) = d%n
+      llen(1) = d%mloc                  ! local sizes set
+      llen(2) = d%nloc
+C
+C Create and build a message descriptor containing the state array X.
+C
+      call rsl_create_message( mesg )
+         write(0,*)'loc of d%X',loc(d%X), loc(d%X(1,1))
+      call rsl_build_message( mesg,RSL_REAL,d%X(1,1),2,decomp,glen,llen )
+      call rsl_build_message( mesg,RSL_REAL,d%Y(1,1),2,decomp,glen,llen )
+C
+C Create and build a stencil with the message on each of the 8 pts.
+C
+      call rsl_create_stencil( d%sten )
+      messages(1) =    mesg
+      messages(2) =           mesg
+      messages(3) =                 mesg
+      messages(4) =    mesg
+      messages(5) =                 mesg
+      messages(6) =    mesg
+      messages(7) =           mesg
+      messages(8) =                 mesg
+      call rsl_describe_stencil( d%domdesc, d%sten, RSL_8PT, messages )
+
+C Periodic boundary
+      call rsl_create_message( mesg )
+      call rsl_build_message( mesg,RSL_REAL,d%X(1,1),2,decomp,glen,llen )
+      glen(1) = d%m-1
+      glen(2) = d%n-1
+      call rsl_build_message( mesg,RSL_REAL,d%Y(1,1),2,decomp,glen,llen )
+      glen(1) = d%m
+      glen(2) = d%n
+      call rsl_create_period( d%period )
+      call rsl_describe_period( d%domdesc, d%period, 1, mesg )
+C
+C Define the stencils for all the child domains of this domains
+C
+      do k = 1, d%nkids
+        call define_data( d%child(k) )  ! RECURSION
+      enddo
+C
+      return
+      end
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
diff --git a/wrfv2_fire/external/RSL/RSL/set_f_padarea.F b/wrfv2_fire/external/RSL/RSL/set_f_padarea.F
new file mode 100755
index 00000000..03454627
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/set_f_padarea.F
@@ -0,0 +1,67 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     
+C                              COPYRIGHT
+C     
+C     The following is a notice of limited availability of the code and 
+C     Government license and disclaimer which must be included in the 
+C     prologue of the code and in all source listings of the code.
+C     
+C     Copyright notice
+C       (c) 1977  University of Chicago
+C     
+C     Permission is hereby granted to use, reproduce, prepare 
+C     derivative works, and to redistribute to others at no charge.  If 
+C     you distribute a copy or copies of the Software, or you modify a 
+C     copy or copies of the Software or any portion of it, thus forming 
+C     a work based on the Software and make and/or distribute copies of 
+C     such work, you must meet the following conditions:
+C     
+C          a) If you make a copy of the Software (modified or verbatim) 
+C             it must include the copyright notice and Government       
+C             license and disclaimer.
+C     
+C          b) You must cause the modified Software to carry prominent   
+C             notices stating that you changed specified portions of    
+C             the Software.
+C     
+C     This software was authored by:
+C     
+C     Argonne National Laboratory
+C     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+C     Mathematics and Computer Science Division
+C     Argonne National Laboratory, Argonne, IL  60439
+C     
+C     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+C     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+C     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+C     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+C     
+C                      GOVERNMENT LICENSE AND DISCLAIMER
+C     
+C     This computer code material was prepared, in part, as an account 
+C     of work sponsored by an agency of the United States Government.
+C     The Government is granted for itself and others acting on its 
+C     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+C     this data to reproduce, prepare derivative works, distribute 
+C     copies to the public, perform publicly and display publicly, and 
+C     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+C     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+C     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+C     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+C     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+
+      subroutine rsl_f_set_padarea( newpad )
+      implicit none
+      include 'rsl.inc'
+      integer newpad
+
+      rsl_padarea = newpad 
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/set_padarea.c b/wrfv2_fire/external/RSL/RSL/set_padarea.c
new file mode 100755
index 00000000..9d129109
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/set_padarea.c
@@ -0,0 +1,66 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+RSL_SET_PADAREA ( newpad_p )
+  int_p newpad_p ;
+{
+  rsl_padarea = *newpad_p ;
+  RSL_F_SET_PADAREA ( newpad_p ) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/setup_socket.c b/wrfv2_fire/external/RSL/RSL/setup_socket.c
new file mode 100755
index 00000000..d005762c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/setup_socket.c
@@ -0,0 +1,91 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#if 0
+From olson@mcs.anl.gov Fri Sep 30 16:02:19 1994
+Received: from mcs.anl.gov (dalek.mcs.anl.gov [140.221.1.2]) by antares.mcs.anl.gov (8.6.4/8.6.4) with ESMTP id QAA01471 for ; Fri, 30 Sep 1994 16:02:18 -0500
+Message-Id: <199409302102.QAA01471@antares.mcs.anl.gov>
+To: michalak
+Subject: socket setup stuff
+Date: Fri, 30 Sep 1994 16:02:17 -0500
+From: Bob Olson 
+Status: RO
+#endif
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+
+static void setup_socket(s)
+  int s ;
+{
+  int on = 1;
+
+#ifdef TCP_RFC1323
+  if (setsockopt(s,IPPROTO_TCP,TCP_RFC1323,&on,sizeof(on)) < 0)
+    perror("setsockopt RFC1323");
+#endif
+  if (setsockopt(s,IPPROTO_TCP,TCP_NODELAY,&on,sizeof(on)) < 0)
+    perror("setsockopt NODELAY");
+  if (setsockopt(s,SOL_SOCKET,SO_REUSEADDR,&on,sizeof(on)) < 0)
+    perror("setsockopt REUSEADDR");
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/show_decomp.c b/wrfv2_fire/external/RSL/RSL/show_decomp.c
new file mode 100755
index 00000000..b4327d33
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/show_decomp.c
@@ -0,0 +1,257 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+#include 
+
+
+static int show_domain_first = 1 ;
+
+SHOW_DOMAIN_DECOMP ( d_p )
+  int_p d_p ;
+{
+#ifndef STUBS
+  rsl_index_t d ;
+  int Phist[RSL_MAXPROC] ;
+  char fname[50] ;
+  FILE * fp ;
+  rsl_index_t i, j, k ;
+  char * code ;
+  int i_am_monitor ;
+
+  RSL_C_IAMMONITOR ( &i_am_monitor ) ;
+
+ if ( i_am_monitor )
+ {
+  d = *d_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+
+  if ( show_domain_first )
+  {
+    code = "w" ;
+    show_domain_first = 0 ;
+  }
+  else
+  {
+    code = "r+" ;
+  }
+  sprintf(fname,"show_domain_%04d",rsl_myproc) ;
+  if (( fp = fopen ( fname, code )) == NULL )
+  {
+     perror(fname) ;
+     exit(2) ;
+  }
+  fseek(fp,0L,2) ;
+  fprintf(fp,"domain=%d, len_n=%d, len_m=%d\n", 
+	   d, domain_info[d].len_n, domain_info[d].len_m ) ;
+  if ( domain_info[d].decomposed != 1 )
+  {
+    fprintf(fp,"not decomposed at this point in program") ;
+    return ;
+  }
+  for ( i = 0 ; i < RSL_MAXPROC ; i++ ) Phist[i] = 0 ;
+  for ( i = domain_info[d].len_m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < domain_info[d].len_n ; j++ )
+    {
+      if ( domain_info[d].domain[INDEX_2(j,i,domain_info[d].len_m)].children_p != NULL )
+        fprintf(fp, "%2d ",domain_info[d].domain[INDEX_2(j,i,domain_info[d].len_m)].P+90) ;
+      else
+        fprintf(fp, "%2d ",domain_info[d].domain[INDEX_2(j,i,domain_info[d].len_m)].P) ;
+      Phist[domain_info[d].domain[INDEX_2(j,i,domain_info[d].len_m)].P]++ ;
+    }
+    fprintf(fp,"\n") ;
+  }
+  for ( i = 0 ; i < rsl_nproc_all ; i++ )
+  {
+    fprintf(fp,"%5d  %7d\n",i,Phist[i]) ;
+  }
+
+/* added 20010222 */
+  if ( domain_info[d].len_z > 1 )
+  {
+    fprintf(fp,"\nMZ decoomposition len_m = %d len_z = %d\n", domain_info[d].len_m, domain_info[d].len_z) ;
+    for ( k = domain_info[d].len_z-1 ; k >= 0 ; k-- ) {
+      for ( i = 0 ; i < domain_info[d].len_m ; i++ ) {
+        fprintf(fp, "%2d ",domain_info[d].domain_mz[INDEX_2(k,i,domain_info[d].len_m)].P) ;
+      }
+      fprintf(fp,"\n") ;
+    }
+    fprintf(fp,"\nNZ decoomposition len_n = %d len_z = %d\n", domain_info[d].len_n, domain_info[d].len_z ) ;
+    for ( k = domain_info[d].len_z-1 ; k >= 0 ; k-- ) {
+      for ( j = 0 ; j < domain_info[d].len_n ; j++ ) {
+        fprintf(fp, "%2d ",domain_info[d].domain_nz[INDEX_2(k,j,domain_info[d].len_n)].P) ;
+      }
+      fprintf(fp,"\n") ;
+    }
+  }
+
+  fclose(fp) ;
+ }
+#endif
+  return(0) ;
+}
+
+
+READ_DOMAIN_DECOMP ( d_p, wrk,  m, n )
+  int_p d_p ;
+  int * wrk ;
+  int m, n ;
+{
+  int P ;
+  int d ;
+  char fname[50] ;
+  FILE * fp ;
+  rsl_index_t i, j, k ;
+  char * code ;
+  int i_am_monitor ;
+  int in_d, in_len_n, in_len_m ;
+
+  code = "r+" ;
+
+  d = *d_p ;
+
+  sprintf(fname,"read_domain_%04d",0) ;
+
+  if (( fp = fopen ( fname, code )) == NULL )
+  {
+     perror(fname) ;
+     return(1) ;
+  }
+
+  fscanf(fp,"domain=%d, len_n=%d, len_m=%d\n", 
+	     &in_d, &in_len_n, &in_len_m ) ;
+  fprintf(stderr,"READ_DOMAIN_DECOMP: domain=%d, len_n=%d, len_m=%d\n", in_d,in_len_n,in_len_m ) ;
+
+  if ( in_len_n != domain_info[d].len_n ) {
+    fprintf(stderr,"in_len_n != domain_info[d].len_n (%d != %d)\n",in_len_n,domain_info[d].len_n) ;
+    RSL_TEST_ERR(1,"" ) ;
+  }
+  if ( in_len_m != domain_info[d].len_m ) {
+    fprintf(stderr,"in_len_m != domain_info[d].len_m (%d != %d)\n",in_len_m,domain_info[d].len_m) ;
+    RSL_TEST_ERR(1,"" ) ;
+  }
+
+  for ( i = domain_info[d].len_m-1 ; i >= 0 ; i-- )
+  {
+    for ( j = 0 ; j < domain_info[d].len_n ; j++ )
+    {
+      fscanf(fp, "%2d ",&P) ;
+      wrk[INDEX_2(j,i,domain_info[d].len_m)] = P ;
+#if 0
+      fprintf(stderr,"%2d ",wrk[INDEX_2(j,i,domain_info[d].len_m)]) ;
+#endif
+    }
+    fscanf(fp,"\n") ;
+#if 0
+    fprintf(stderr,"\n") ;
+#endif
+  }
+
+  fclose(fp) ;
+  return(0) ;
+}
+
+
+GET_DOMAIN_DECOMP ( d_p, wk, nwk_p )
+  int_p d_p ;
+  int_p wk ;
+  int_p nwk_p ;
+{
+  rsl_index_t d ;
+  char fname[50] ;
+  FILE * fp ;
+  int nwk ;
+  rsl_index_t i, j, m ;
+  char * code ;
+
+  d = *d_p ;
+  nwk = *nwk_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+  RSL_TEST_ERR(wk == NULL, "GET_DOMAIN_DECOMP: NULL argument wk" ) ;
+  if ( domain_info[d].len_m * domain_info[d].len_n > nwk )
+  {
+    sprintf(mess,"%d ints would overwrite input array (size=%d ints)\n",
+	    domain_info[d].len_m * domain_info[d].len_n,
+	    nwk);
+    RSL_TEST_ERR(1,mess) ;
+  }
+
+  if ( domain_info[d].decomposed != 1 )
+  {
+    return ;
+  }
+  m = domain_info[d].len_m ;
+
+  for ( j = 0 ; j < domain_info[d].len_n ; j++ )
+  {
+    for ( i = 0 ; i < domain_info[d].len_m ; i++ )
+    {
+      wk[INDEX_2(j,i,m)] = domain_info[d].domain[INDEX_2(j,i,m)].P ;
+    }
+  }
+  return(0) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/stencil_def.c b/wrfv2_fire/external/RSL/RSL/stencil_def.c
new file mode 100755
index 00000000..684c82fb
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/stencil_def.c
@@ -0,0 +1,349 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_CREATE_STENCIL -- Create a stencil descriptor.
+
+  Notes:
+  The output argument is the integer Arg1, a descriptor to 
+  a new RSL stencil.  The stencil is then built (RSL_DESCRIBE_STENCIL)
+  and used in stencil exchanges (RSL_EXCH_STENCIL) during the model
+  run.
+
+  See also:
+  RSL_DESCRIBE_STENCIL, RSL_EXCH_STENCIL
+@*/
+
+RSL_CREATE_STENCIL ( sh_p )
+  int_p sh_p ;     /* (O) New RSL stencil descriptor. */
+{
+  int i ;
+  stencil_desc_t *sten ;
+  
+  /* NOTE: never return the 0th stencil */
+  for ( i = 1 ; i < RSL_MAXDESCRIPTORS ; i++ )
+    if ( sh_descriptors[i] == NULL ) break ;    /* got one */
+
+  RSL_TEST_ERR( i == RSL_MAXDESCRIPTORS,
+  "rsl_create_stencil:  out of descriptors.");
+
+  *sh_p = i ;
+  sten = RSL_MALLOC(stencil_desc_t,1) ;
+  sten->tag = STENCIL_DESC ;
+  sten->has_f90_fields = 0 ;
+  sh_descriptors[*sh_p] = sten ;
+  sten->sh = *sh_p ;
+}
+
+release_sh_descriptor (sh_p)
+  int_p sh_p ;
+{
+  int sh ;
+
+  sh = *sh_p ;
+  RSL_TEST_ERR( sh < 0 || sh >= RSL_MAXDESCRIPTORS,
+                "internal error.  Invalid stencil descriptor.") ;
+  if ( sh_descriptors[sh] != NULL )
+  {
+    sh_descriptors[sh] = NULL ;
+  }
+}
+
+/*@
+  RSL_DESCRIBE_STENCIL -- Defines an RSL stencil exchange on a domain.
+
+  Notes:
+  This routine gives a stencil a size and shape, associates RSL messages
+  with the stencil points, and asssociates the stencil with the domain
+  Arg1.  The argument Arg2 is a stencil descriptor previously created
+  by RSL_CREATE_STENCIL.  The shape of the stencil is specified by
+  Arg3, which is one of RSL_4PT (N, W, E, S), RSL_8PT (NW, N, NE, W, E, SW,
+  S, SE), RSL_24PT (a 5 by 5 stencil of around a given point), RSL_48PT
+  (a 7 by 7 stencil), and RSL_168PT (a 13 by 13 stencil).
+
+  Messages for each stencil point must have been previously created and
+  built using RSL_CREATE_MESSAGE and RSL_BUILD_MESSAGE.  The message
+  descriptors corresponding to 
+  each point in the stencil are passed to RSL_DESCRIBE_STENCIL as elements
+  of the
+  the 1-dimensional integer array Arg4.  The size of Arg4 corresponds to
+  the number of points (not counting the center) of the stencil.  They
+  are ordered from west to east and then north to south.  A message
+  may be associated with more than one stencil point.
+  Unused
+  points in a stencil can be set to RSL_INVALID to indicate that no messages
+  are associated with those points.  
+  Once
+  RSL_DESCRIBE_STENCIL returns, all
+  of the messages are invalidated and the message descriptors become
+  undefined.
+
+  Example:
+
+$  integer m             ! message descriptor
+$  integer messages(8)   ! array of messages for 8 pt stencil
+$  integer sten          ! stencil descriptor
+
+$ C Size and decomposition information for building messages
+$  decomp(1) = RSL_NORTHSOUTH	     ! how most minor dim decomposed
+$  decomp(2) = RSL_EASTWEST	       ! how next dim decomposed
+$  decomp(3) = RSL_NOTDECOMPOSED	  ! major dim (vertical) not decomposed
+$  glen(1) = g_ix	! global size in n/s
+$  glen(2) = g_jx	! global size in e/w
+$  glen(3) = kx		 ! size in vertical
+$  llen(1) = ix	  ! local size in n/s
+$  llen(2) = jx 		! local size in e/w
+$  llen(3) = kx	  ! local size of vertical (same as global)
+$ C Create a message and add fields UA, VA, and PSA
+$  call rsl_create_message( m )
+$  call rsl_build_message( m, RSL_REAL, ua,  3, decomp, glen, llen )
+$  call rsl_build_message( m, RSL_REAL, va,  3, decomp, glen, llen )
+$  call rsl_build_message( m, RSL_REAL, psa, 2, decomp, glen, llen )
+$ C Construct stencil for W,SW,S exchange
+$  messages(1) =    RSL_INVALID
+$  messages(2) =                RSL_INVALID
+$  messages(3) =                            RSL_INVALID
+$  messages(4) =    m
+$  messages(5) =                            RSL_INVALID
+$  messages(6) =    m
+$  messages(7) =                m
+$  messages(8) =                            RSL_INVALID
+$ C Create and describe stencil
+$  call rsl_create_stencil( sten )
+$  call rsl_describe_stencil( d, sten, RSL_8PT, messages )
+
+BREAKTHEEXAMPLECODE
+  In this example, an  exchange of surface pressure PSA
+  and horizontal wind velocity
+  components UA and VA on a south-west stencil is created.  Unused
+  points in the eight-point stencil are marked with RSL_INVALID.  Because
+  the same fields are communicated on each of the three active stencil
+  points (W, SW, and S), the same message, M, is associated with each.
+  Adding spaces to the statements that assign the array messages enhance
+  readability by outlining visually the shape of the communication.
+
+  See also:
+  RSL_CREATE_STENCIL, RSL_EXCH_STENCIL, RSL_CREATE_MESSAGE, RSL_BUILD_MESSAGE
+
+@*/
+
+RSL_DESCRIBE_STENCIL ( d_p, sh_p, maskid_p, messages )
+  int_p d_p,            /* (I) Domain descriptor. */
+        sh_p,           /* (I) Stencil handle */
+        maskid_p ;      /* (I) Stencil shape and size. */
+  int messages[] ;      /* (I) Array of message descriptors. */
+{
+  int d, sh, mh, maskid ;
+  rsl_domain_info_t * dinfo ;
+  stencil_desc_t *sten ;
+  message_desc_t *msg ;
+  int pt ;
+
+  d = *d_p ; sh = *sh_p ; maskid = *maskid_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_describe_stencil: bad domain descriptor\n") ;
+  dinfo = &(domain_info[d]) ;
+  RSL_TEST_ERR(dinfo->valid != RSL_VALID,
+    "rsl_describe_stencil: descriptor is not for a valid domain\n") ;
+
+  RSL_TEST_ERR( sh < 0 || sh >= RSL_MAXDESCRIPTORS,
+    "rsl_describe_stencil: bad stencil handle" ) ;
+  sten = (stencil_desc_t *) sh_descriptors[sh] ;
+  RSL_TEST_ERR( sten->tag != STENCIL_DESC,
+       "rsl_describe_stencil: handle given is not for an rsl stencil def" ) ;
+
+  switch ( maskid )
+  {
+  case RSL_4PT  : sten->f[d].ptfcn = rsl_4pt ;  sten->npts[d] = 4  ; break ;
+  case RSL_8PT  : sten->f[d].ptfcn = rsl_8pt ;  sten->npts[d] = 8  ; break ;
+  case RSL_12PT : sten->f[d].ptfcn = rsl_12pt ; sten->npts[d] = 12 ; break ;
+  case RSL_24PT : sten->f[d].ptfcn = rsl_24pt ; sten->npts[d] = 24 ; break ;
+  case RSL_48PT : sten->f[d].ptfcn = rsl_48pt ; sten->npts[d] = 48 ; break ;
+  case RSL_80PT : sten->f[d].ptfcn = rsl_80pt ; sten->npts[d] = 80 ; break ;
+  case RSL_120PT : sten->f[d].ptfcn = rsl_120pt ; sten->npts[d] = 120 ; break ;
+#if ( ALLOW_RSL_168PT == 1 )
+  case RSL_168PT : sten->f[d].ptfcn = rsl_168pt ; sten->npts[d] = 168 ; break ;
+  default : RSL_TEST_ERR( 1, 
+"rsl_describe_stencil: invalid maskid,\n  must be RSL_4PT, RSL_8PT, RSL_12PT, RSL_24PT, RSL_48PT, or RSL_168PT" ) ;
+#else
+  default : RSL_TEST_ERR( 1, 
+"rsl_describe_stencil: invalid maskid,\n  must be RSL_4PT, RSL_8PT, RSL_12PT or RSL_24PT, RSL_48PT" ) ;
+#endif
+    return ;
+  }
+
+  sten->maskid[d] = maskid ;
+  sten->compiled[d] = 0 ;
+
+  for ( pt = 0 ; pt < sten->npts[d] ; pt++ )
+  {
+    mh = messages[ pt ] ;
+    RSL_TEST_ERR( mh != RSL_INVALID && (mh < 0 || mh >=RSL_MAXDESCRIPTORS),
+"rsl_describe_stencil: bad message handle in list,\n  must be either valid message or RSL_INVALID") ;
+    if ( mh != RSL_INVALID )
+    {
+      msg = (message_desc_t *) mh_descriptors[ mh ] ;
+      RSL_TEST_ERR( msg->tag != MESSAGE_DESC, 
+       "rsl_describe_stencil: handle given in message list is not for an rsl mesage def" ) ;
+      sten->msgs[d][pt] = msg ;
+    }
+    else
+    {
+      sten->msgs[d][pt] = NULL ;
+    }
+  }
+  /* free up the message descriptors; they've done their job */
+  for ( pt = 0 ; pt < sten->npts[d] ; pt++ )
+  {
+    release_mh_descriptor( &(messages[pt]) ) ;
+  }
+  /* add my descriptor to the list for the domain */
+  dinfo->stenlist[dinfo->stencurs] = sh ;
+  dinfo->stencurs++ ;  /* 970317 */
+  if ( dinfo->stencurs >= RSL_MAXDESCRIPTORS )
+  {
+    sprintf(mess,
+     "Domain %d doesn't have room for any more stencils, but the allowable\nlimit of %d should have been more than enough.\nYou might recompile RSL with a higher setting for RSL_MAXDESCRIPTORS, but\n it's likely something else is wrong.",
+       d, RSL_MAXDESCRIPTORS ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+     
+  }
+}
+
+/* only used internally within the RSL package */
+destroy_stencil( sten )
+  stencil_desc_t * sten ;
+{
+  int d ;
+  rsl_fldspec_t *fld, *doomed ;
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( sten->tag != STENCIL_DESC, "destroy_stencil: arg not a stencil.") ;
+
+  for ( d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    destroy_stencil_on_domain( d, sten ) ;
+  }
+  release_sh_descriptor (sten->sh) ;
+  RSL_FREE( sten ) ;
+}
+
+destroy_stencil_on_domain( d, sten )
+  int d ;
+  stencil_desc_t * sten ;
+{
+  int i ;
+
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "destroy_stencil_on_domain: bad domain descriptor") ;
+  for ( i = 0 ; i < RSL_MAXSTEN+1 ; i++ )
+  {
+    destroy_message( sten->msgs[d][i] ) ;
+  }
+  sten->f[d].ptfcn = NULL ;
+  sten->npts[d] = 0 ;
+  uncompile_stencil_on_domain( d, sten ) ;
+}
+
+uncompile_stencil_on_domain( d, sten )
+  int d ;
+  stencil_desc_t * sten ;
+{
+  int i ;
+
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "uncompile_stencil_on_domain: bad domain descriptor") ;
+  sten->compiled[d] = 0 ;
+  destroy_procrec_list( sten->procs[d] ) ;
+  sten->procs[d] = NULL ; /* 970317 */
+}
+
+destroy_procrec_list( prec )
+  rsl_procrec_t *prec ;
+{ 
+  rsl_procrec_t *p, *doomed ;
+  int destroy_ptrec_list() ;
+  if ( prec == NULL ) return ;
+  for ( p = prec ; p != NULL ; )
+  {
+    doomed = p ;
+    p = p->next ;
+    destroy_list( &(doomed->point_list), destroy_ptrec_list ) ;
+    RSL_FREE(doomed) ;
+  }
+}
+
+destroy_ptrec_list( ptrec )
+  rsl_ptrec_t *ptrec ;
+{
+  rsl_ptrec_t *p, *doomed ;
+  if ( ptrec == NULL ) return ;
+  for ( p = ptrec ; p != NULL ; )
+  {
+    doomed = p ;
+    p = p->next ;
+    destroy_list( &(doomed->send_messages), NULL ) ;
+    destroy_list( &(doomed->recv_messages), NULL ) ;
+    RSL_FREE(doomed) ;
+  }
+}
+
diff --git a/wrfv2_fire/external/RSL/RSL/stencil_def.h b/wrfv2_fire/external/RSL/RSL/stencil_def.h
new file mode 100755
index 00000000..77c0a770
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/stencil_def.h
@@ -0,0 +1,90 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef STENCIL_DEF_H
+#define STENCIL_DEF_H
+
+typedef struct stencil_desc {
+  rsl_tag_t tag;                        /* should be STENCIL_DESC */
+  int sh ;		/* my descriptor */
+  int has_f90_fields ;
+  rsl_tag_t compiled[RSL_MAXDOMAINS];
+  rsl_tag_t npts[RSL_MAXDOMAINS] ;
+  rsl_tag_t maskid[RSL_MAXDOMAINS] ;
+  message_desc_t *msgs[RSL_MAXDOMAINS][ RSL_MAXSTEN+1 ] ;
+  rsl_procrec_t *procs[RSL_MAXDOMAINS] ;
+  struct {
+    int (*ptfcn)() ;
+  } f[RSL_MAXDOMAINS] ;
+} stencil_desc_t ;
+
+int rsl_4pt() ;		/* forward declarations for pt functions */
+int rsl_8pt() ;		/* forward declarations for pt functions */
+int rsl_12pt() ;	/* forward declarations for pt functions */
+int rsl_24pt() ;	/* forward declarations for pt functions */
+int rsl_48pt() ;	/* forward declarations for pt functions */
+int rsl_80pt() ;	/* forward declarations for pt functions */
+int rsl_120pt() ;	/* forward declarations for pt functions */
+#if (ALLOW_RSL_168PT == 1)
+int rsl_168pt() ;	/* forward declarations for pt functions */
+#endif
+int rsl_2ptm() ;	/* forward declarations for pt functions */
+int rsl_4ptm() ;	/* forward declarations for pt functions */
+
+#endif  /* nothing after this line */
+
diff --git a/wrfv2_fire/external/RSL/RSL/tag.c b/wrfv2_fire/external/RSL/RSL/tag.c
new file mode 100755
index 00000000..3900820d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/tag.c
@@ -0,0 +1,109 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+FILE * inp = stdin ;
+char inline[256] ;
+
+main( argc, argv )
+  int argc;
+  char * argv[] ;
+{
+  int n, done ;
+
+  if ( argc == 2 )
+  {
+    inp = NULL ;
+  }
+
+  done = 0 ;
+  while ( ! done )
+  {
+  if ( inp == NULL )
+  {
+    n = atoi( argv[1] ) ;
+    done = 1 ;
+  }
+  else
+  {
+    if ( fgets( inline, 80, stdin ) == NULL ) 
+      break ;
+    n = atoi( inline ) ;
+  }
+
+  printf("From  is %d\n", MTYPE_FROM(n) ) ;
+  printf("Tag   is %d\n", MTYPE_TAG(n) ) ;
+
+  switch ( MTYPE_TAG(n) )
+  {
+case MSG_STENCOM	: printf("msg_stencom\n") ; break ;
+case MSG_READ_RESPONSE	: printf("msg_read_response\n") ; break ;
+case MSG_WRITE_RESPONSE	: printf("msg_write_response\n") ; break ;
+case MSG_WRITE_COMPUTE_RESPONSE	: printf("msg_write_compute_response\n") ; break ;
+case MSG_SPECIAL1_RESPONSE	: printf("msg_special1_response\n") ; break ;
+case MSG_SPECIAL2_RESPONSE	: printf("msg_special2_response\n") ; break ;
+case MSG_FROM_PARENT	: printf("msg_from_parent\n") ; break ;
+case MSG_BCAST_SETUP	: printf("msg_bcast_setup\n") ; break ;
+case MSG_MERGE_SETUP	: printf("msg_merge_setup\n") ; break ;
+case MSG_TO_PARENT	: printf("msg_to_parent\n") ; break ;
+  default : break ;
+  }
+  }
+  exit(0) ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/vicopy.F b/wrfv2_fire/external/RSL/RSL/vicopy.F
new file mode 100644
index 00000000..829ed32c
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/vicopy.F
@@ -0,0 +1,45 @@
+      subroutine vicopy( a, b, c )
+      integer a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vrcopy( a, b, c )
+      real a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vbcopy( a, b, c )
+      byte a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vizero( a, c )
+      integer a(*)
+      integer c
+      do i = 1, c
+        a(i) = 0
+      enddo
+      return
+      end
+
+      subroutine vbzero( a, c )
+      byte a(*)
+      integer c
+      do i = 1, c
+        a(i) = 0
+      enddo
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/vicopy_o2k.F b/wrfv2_fire/external/RSL/RSL/vicopy_o2k.F
new file mode 100644
index 00000000..2479bd6d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/vicopy_o2k.F
@@ -0,0 +1,45 @@
+      subroutine vicopy( a, b, c )
+      integer a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vrcopy( a, b, c )
+      real a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vbcopy( a, b, c )
+      integer*1 a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vizero( a, c )
+      integer a(*)
+      integer c
+      do i = 1, c
+        a(i) = 0
+      enddo
+      return
+      end
+
+      subroutine vbzero( a, c )
+      integer*1 a(*)
+      integer c
+      do i = 1, c
+        a(i) = 0
+      enddo
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/vicopy_sx.F b/wrfv2_fire/external/RSL/RSL/vicopy_sx.F
new file mode 100644
index 00000000..f18a5b8f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/vicopy_sx.F
@@ -0,0 +1,18 @@
+      subroutine vicopy( a, b, c )
+      integer a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
+      subroutine vrcopy( a, b, c )
+      real a(*), b(*)
+      integer c
+      do i = 1, c
+        b(i) = a(i)
+      enddo
+      return
+      end
+
diff --git a/wrfv2_fire/external/RSL/RSL/which_boundary.h b/wrfv2_fire/external/RSL/RSL/which_boundary.h
new file mode 100644
index 00000000..5d253e45
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/which_boundary.h
@@ -0,0 +1,5 @@
+#define WHICH_BDY_EAST   2
+#define WHICH_BDY_WEST   1
+#define WHICH_BDY_NORTH  8
+#define WHICH_BDY_SOUTH  4
+
diff --git a/wrfv2_fire/external/RSL/RSL/within_nest.c b/wrfv2_fire/external/RSL/RSL/within_nest.c
new file mode 100755
index 00000000..a9e53675
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/within_nest.c
@@ -0,0 +1,159 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/* note -- only works for regular nests right now */
+/* note also, these indices come is as FORTRAN  (1..n)*/
+
+/* 1/10/95, BUG: should these be converted to use eff_m, eff_n
+   instead of len_m, len_n? */
+
+RSL_WITHIN_NESTED_BOUNDARY ( wdth_p, pd_p, nd_p, ig_p, jg_p, retval_p )
+  int_p wdth_p,         /* width of boundary in nested domain cells */
+        pd_p,           /* descriptor to parent -- this domain */
+        nd_p,           /* descriptor for nest */
+        ig_p, jg_p,     /* coordinates of coarse domain cell */
+        retval_p ;      /* return 1 if on boundary, 0 otherwise */
+{
+  int wdth, pd, nd, ig, jg, retval ;
+  int cwdth ;  /* coarse domain width (ceiling of wdth / IRAX) */
+  int swi, swj, leni, lenj, rax ;
+
+  wdth = *wdth_p ; pd = *pd_p ; nd = *nd_p ;
+  ig = *ig_p - 1 ; jg = *jg_p - 1 ;
+
+  rax = domain_info[nd].irax_m ;  /* TODO -- BUG -- if irax_m and irax_n differ, hozed */
+
+  cwdth = wdth / rax + ((wdth%rax == 0)?0:1) ;
+  swi = domain_info[nd].coord_m ;
+  swj = domain_info[nd].coord_n ;
+  leni = domain_info[nd].len_m /  domain_info[nd].irax_m ;
+  lenj = domain_info[nd].len_n /  domain_info[nd].irax_n ;
+
+  retval = 0 ;
+  if ( jg >= swj && ig >= swi  &&
+       jg < swj + lenj && ig < swi + leni )
+  {
+      
+  /* check western */
+  if      ( jg - swj < cwdth ) 
+    retval = 1 ;
+  /* check eastern */
+  else if ( swj + lenj - jg <= cwdth )
+    retval = 1 ;
+  /* check southern */
+  if      ( ig - swi < cwdth ) 
+    retval = 1 ;
+  /* check northern */
+  else if ( swi + leni - ig <= cwdth )
+    retval = 1 ;
+
+  }
+
+  *retval_p = retval ;
+}
+
+/* like above, but gives an extra row and column on north and east
+   respectively */
+
+RSL_WITHIN_NESTED_BETA ( wdth_p, pd_p, nd_p, ig_p, jg_p, retval_p )
+  int_p wdth_p,         /* width of boundary in nested domain cells */
+        pd_p,           /* descriptor to parent -- this domain */
+        nd_p,           /* descriptor for nest */
+        ig_p, jg_p,     /* coordinates of coarse domain cell */
+        retval_p ;      /* return 1 if on boundary, 0 otherwise */
+{
+  int wdth, pd, nd, ig, jg, retval ;
+  int cwdth ;  /* coarse domain width (ceiling of wdth / IRAX) */
+  int swi, swj, leni, lenj, rax ;
+
+  wdth = *wdth_p ; pd = *pd_p ; nd = *nd_p ;
+  ig = *ig_p - 1 ; jg = *jg_p - 1 ;
+
+  rax = domain_info[nd].irax_m ;  /* TODO -- BUG -- if irax_m and irax_n differ,
+ hozed */
+
+  cwdth = wdth / rax + ((wdth%rax == 0)?0:1) ;
+  swi = domain_info[nd].coord_m ;
+  swj = domain_info[nd].coord_n ;
+  leni = domain_info[nd].len_m /  domain_info[nd].irax_m ;
+  lenj = domain_info[nd].len_n /  domain_info[nd].irax_n ;
+
+  retval = 0 ;
+  if ( jg >= swj && ig >= swi  &&
+       jg < swj + lenj && ig < swi + leni )
+  {
+      
+  /* check western */
+  if      ( jg - swj < cwdth ) 
+    retval = 1 ;
+  /* check eastern */
+  else if ( swj + lenj - jg <= cwdth+1 )
+    retval = 1 ;
+  /* check southern */
+  if      ( ig - swi < cwdth ) 
+    retval = 1 ;
+  /* check northern */
+  else if ( swi + leni - ig <= cwdth+1 )
+    retval = 1 ;
+
+  }
+
+  *retval_p = retval ;
+}
diff --git a/wrfv2_fire/external/RSL/RSL/xpose.c b/wrfv2_fire/external/RSL/RSL/xpose.c
new file mode 100755
index 00000000..240df6e0
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/xpose.c
@@ -0,0 +1,610 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_XPOSE - Transpose data
+
+  Notes:
+
+@*/
+
+RSL_XPOSE_MN_MZ ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+  rsl_xpose_common_up ( d_p , x_p , XPOSE_MN_MZ ) ;
+}
+
+RSL_XPOSE_MZ_MN ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+  rsl_xpose_common_down( d_p, x_p, XPOSE_MZ_MN ) ;
+}
+
+RSL_XPOSE_MZ_NZ ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+  rsl_xpose_common_up ( d_p , x_p , XPOSE_MZ_NZ ) ;
+}
+
+RSL_XPOSE_NZ_MZ ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+  rsl_xpose_common_down( d_p, x_p, XPOSE_NZ_MZ ) ;
+}
+
+RSL_XPOSE_NZ_MN ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+#if 0
+fprintf(stderr,"RSL_XPOSE_NZ_MN called\n" ) ;
+#endif
+  rsl_xpose_common_up ( d_p , x_p , XPOSE_NZ_MN ) ;
+#if 0
+fprintf(stderr,"RSL_XPOSE_NZ_MN back\n" ) ;
+#endif
+}
+
+RSL_XPOSE_MN_NZ ( d_p, x_p )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+{
+  rsl_xpose_common_down( d_p, x_p, XPOSE_MN_NZ ) ;
+}
+
+/**************************************************/
+
+rsl_xpose_common_up ( d_p, x_p, xpose_sw )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+  int xpose_sw ;
+{
+  int d, x ;
+  xpose_desc_t *xpose ;
+  message_desc_t *msg ;
+  rsl_procrec_t *procrec ;
+  rsl_ptrec_t *ptrec ;
+  rsl_list_t *lp, *lp1 ;
+  rsl_index_t ig, jg ;
+  rsl_point_hdr_t point_hdr ;
+  int i, ipt, sp, j ;
+  int curs ;
+  int nprocs, npts ;
+  int retval ;
+  int mtype, mdest ;
+  char * pbuf ;
+  int P ;
+  int Pque[RSL_MAXPROC] ;
+  rsl_procrec_t *procrecque[RSL_MAXPROC ] ;
+  int typeque[RSL_MAXPROC] ;
+  int tqp, ndone ;
+  void * base ;
+  packrec_t * pr ;
+
+
+  d = *d_p ; x = *x_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+
+#ifdef UPSHOT
+MPE_Log_event( 15, x, "xpose begin" ) ;
+#endif
+#if 0
+fprintf(stderr,"debug called RSL_XPOSE_MN_MZ %d\n" ) ;
+#endif
+
+  xpose = (xpose_desc_t *) xp_descriptors[ x ] ;
+
+  /* if xpose has not been compiled, compile it now! */
+  if ( xpose->compiled[d] == 0 )
+  {
+    rsl_compile_xpose( d_p, x_p ) ;
+  }
+
+  /* post receives */
+  /* iterate over procrecs for domain and post buffers */
+
+  tqp = 0 ;
+  for ( procrec = xpose->procs[d][xpose_sw] ; procrec != NULL ; procrec = procrec->next )
+  {
+    if ( procrec->unpack_table_nbytes > 0 )
+    {
+      P = procrec->P ;
+      Pque[tqp] = P ;
+      procrecque[tqp] = procrec ;
+      pbuf = buffer_for_proc( P, procrec->unpack_table_nbytes, RSL_RECVBUF ) ;
+      mtype = MTYPE_FROMTO( MSG_XPOSECOM, 
+                            rsl_c_comp2phys_proc (procrec->P), 
+                            rsl_myproc ) ;
+      typeque[tqp] = mtype ;
+      procrec->nrecvs++ ; /* diagnostic */
+#if 0
+fprintf(stderr,"debug posting async recv for %d bytes from %d\n", procrec->unpack_table_nbytes, rsl_c_comp2phys_proc (procrec->P) ) ;
+#endif
+      RSL_RECVBEGIN ( pbuf, procrec->unpack_table_nbytes, mtype ) ;
+      tqp++ ;
+    }
+  }
+  nprocs = tqp ;
+
+  /* pack buffers and issue sends */
+
+  for ( procrec = xpose->procs[d][xpose_sw] ; procrec != NULL ; procrec = procrec->next )
+  {
+    pbuf=buffer_for_proc(procrec->P, procrec->pack_table_nbytes, RSL_SENDBUF) ;
+    pr = procrec->pack_table ;
+    for ( curs = 0, i = 0 ; i < procrec->pack_table_size ; i++, pr++ )
+    {
+      if ( xpose->has_f90_fields && procrec->pack_table_size > 0 )
+        base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+      else
+        base =  pr->base ;
+#if 0
+fprintf(stderr,"pack   base %lu, f90_index %d, xpose=%d, pr->nelems=%d\n",base,pr->f90_table_index,x, pr->nelems) ;
+#endif
+      for ( j = 0 ; j < pr->nelems ; j++ )
+      {
+
+#if 0
+fprintf(stderr,"pck %08x, base %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base) + pr->offset + j * pr->stride,
+base,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+#endif
+#if 0
+{ int iii, mloc_mn, nloc_mn, zloc_mn, x ;
+mloc_mn = 10 ;
+nloc_mn = 9 ;
+zloc_mn = 2 ;
+for ( iii = 0 ; iii < pr->n ; iii+=4 )
+{
+x = ((pr->offset + j * pr->stride + iii))/4 ;
+fprintf(stderr,"^ >>> %3d i %2d k %2d j %2d          %f\n",
+               x ,
+               x % mloc_mn ,
+               (x % (mloc_mn*zloc_mn))/mloc_mn  ,
+               (x / (mloc_mn*zloc_mn)) ,
+               *((float *)((char *)(base) + pr->offset + j * pr->stride + iii))) ;
+}}
+#endif
+
+
+#if 0
+fprintf(stderr,"pck %08x, base %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base) + pr->offset + j * pr->stride,
+base,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+{ int iii ;
+for ( iii = 0 ; iii < pr->n ; iii+=4 )
+{
+fprintf(stderr,"^ >>> %d  %f\n", pr->offset + j * pr->stride + iii, *((float *)((char *)(base) + pr->offset + j * pr->stride + iii))) ;
+}}
+#endif
+
+
+        bcopy((char *)(base) + pr->offset + j * pr->stride,
+	      &(pbuf[curs]),pr->n) ;
+        curs += pr->n ;
+      }
+    }
+    if ( curs > 0 )
+    {
+      mdest = rsl_c_comp2phys_proc (procrec->P) ;
+      mtype = MTYPE_FROMTO( MSG_XPOSECOM, rsl_myproc, mdest ) ;
+      procrec->nsends++ ;
+      if ( curs > procrec->pack_table_nbytes ) 
+      {
+        sprintf(mess,"pack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#if 0
+fprintf(stderr,"debug sending %d bytes to %d, xpose=%d\n", curs, mdest, x ) ;
+#endif
+      RSL_SEND ( pbuf, curs, mtype, mdest ) ;
+    }
+    else if ( curs == 0 && procrec->pack_table_nbytes != 0 )
+    {
+      RSL_TEST_ERR(1,"internal error") ;
+    }
+  }
+
+  /* wait on receives and unpack messages as they come in */
+  ndone = 0 ;
+  tqp = 0 ;
+  retval = 1 ;
+
+  while( ndone < nprocs )
+  {
+    if (tqp >= nprocs ) tqp = 0 ;
+    if (typeque[tqp] != RSL_INVALID)
+    {
+      mtype = typeque[tqp] ;
+      if ( rsl_noprobe == NULL )
+        RSL_PROBE ( mtype, &retval ) ;
+      /* else, retval will always be 1 */
+
+      if ( retval )
+      {
+#ifdef PGON
+/* on the Paragon, calling RSL_PROBE clears the message so this
+   would bomb on an unknown message id.  Don't call unless the probe
+   is disabled (rsl_noprobe != NULL). */
+        if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtype ) ;
+#else  
+        RSL_RECVEND ( mtype ) ;
+#endif
+
+	curs = 0 ;
+        pbuf = buffer_for_proc( Pque[tqp], 0, RSL_RECVBUF ) ;
+        procrec = procrecque[tqp] ;
+#if 0
+        fprintf(stderr,"**unpack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->unpack_table,
+                         procrec->unpack_table_size,
+                         procrec->unpack_table_nbytes ) ;
+#endif
+
+        pr = procrec->unpack_table ;
+        for ( curs = 0, i = 0 ; i < procrec->unpack_table_size ; i++, pr++ )
+	{
+          if ( xpose->has_f90_fields && procrec->unpack_table_size > 0 )
+            base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+          else
+            base = pr->base ;
+#if 0
+fprintf(stderr,"^ unpack base %08x, n %3d, nelems %d, stride %3d, f90_index %d, xpose=%d\n",
+  base,pr->n,pr->nelems,pr->stride,pr->f90_table_index,x) ;
+#endif
+          for ( j = 0 ; j < pr->nelems ; j++ )
+          {
+            bcopy(&(pbuf[curs]),
+		 (char *)(base) + pr->offset + j * pr->stride, pr->n) ;
+#if 0
+{ int iii, mloc_mz, nloc_mz, zloc_mz, x ;
+mloc_mz = 8 ;
+nloc_mz = 9 ;
+zloc_mz = 3 ;
+for ( iii = 0 ; iii < pr->n ; iii+=4 )
+{
+x = ((pr->offset + j * pr->stride + iii))/4 ;
+fprintf(stderr,"^ <<< %d i %2d k %2d j %2d %f\n",
+               x ,
+               x % mloc_mz ,
+               (x % (mloc_mz*zloc_mz))/mloc_mz  ,
+               (x / (mloc_mz*zloc_mz)) ,
+               *((float *)((char *)(base) + pr->offset + j * pr->stride + iii))) ;
+}}
+#endif
+            curs += pr->n ;
+	  }
+	}
+	if ( curs == 0 )
+	{
+	  RSL_TEST_ERR(1,"internal error") ;
+	}
+        if ( curs > procrec->unpack_table_nbytes )
+        {
+          sprintf(mess,"unpack buffer overflow %d > %d\n",curs,procrec->unpack_table_nbytes) ;
+          RSL_TEST_ERR(1,mess) ;
+	}
+#if 0
+fprintf(stderr,"debug got message from %d and unpacked %d bytes; xpose=%d\n", Pque[tqp], curs, x ) ;
+#endif
+        typeque[tqp] = RSL_INVALID ;
+        ndone++ ;
+      }
+    }
+    tqp++ ;
+  }
+#ifdef UPSHOT
+MPE_Log_event( 16, s, "xpose end" ) ;
+#endif
+}
+
+/***********************************************/
+
+rsl_xpose_common_down ( d_p , x_p , xpose_sw )
+  int_p
+    d_p             /* (I) Domain descriptor. */
+   ,x_p ;           /* (I) Xpose descriptor. */
+  int xpose_sw ;
+{
+  int d, x ;
+  xpose_desc_t *xpose ;
+  message_desc_t *msg ;
+  rsl_procrec_t *procrec ;
+  rsl_ptrec_t *ptrec ;
+  rsl_list_t *lp, *lp1 ;
+  rsl_index_t ig, jg ;
+  rsl_point_hdr_t point_hdr ;
+  int i, ipt, sp, j ;
+  int curs ;
+  int nprocs, npts ;
+  int retval ;
+  int mtype, mdest ;
+  char * pbuf ;
+  int P ;
+  int Pque[RSL_MAXPROC] ;
+  rsl_procrec_t *procrecque[RSL_MAXPROC ] ;
+  int typeque[RSL_MAXPROC] ;
+  int tqp, ndone ;
+  void * base ;
+  packrec_t * pr ;
+
+#if 0
+fprintf(stderr,"RSL_XPOSE_MZ_MN called\n" ) ;
+#endif
+
+  d = *d_p ; x = *x_p ;
+
+  RSL_TEST_ERR(d < 0 || d >= RSL_MAXDOMAINS,
+          "bad domain descriptor" ) ;
+  RSL_TEST_ERR( domain_info[d].valid != RSL_VALID,
+        "descriptor for invalid domain" ) ;
+
+#ifdef UPSHOT
+MPE_Log_event( 15, x, "xpose begin" ) ;
+#endif
+#if 0
+fprintf(stderr,"debug called RSL_XPOSE_MN_MZ %d\n" ) ;
+#endif
+
+  xpose = (xpose_desc_t *) xp_descriptors[ x ] ;
+
+  /* if xpose has not been compiled, compile it now! */
+  if ( xpose->compiled[d] == 0 )
+  {
+    rsl_compile_xpose( d_p, x_p ) ;
+  }
+
+  /* post receives */
+  /* iterate over procrecs for domain and post buffers */
+
+/*** TO EFFECT THE OTHER DIRECTION, JUST SWITCH PACK AND UNPACK POINTERS ***/
+
+  tqp = 0 ;
+  for ( procrec = xpose->procs[d][xpose_sw] ; procrec != NULL ; procrec = procrec->next )
+  {
+    if ( procrec->pack_table_nbytes > 0 )
+    {
+      P = procrec->P ;
+      Pque[tqp] = P ;
+      procrecque[tqp] = procrec ;
+      pbuf = buffer_for_proc( P, procrec->pack_table_nbytes, RSL_RECVBUF ) ;
+      mtype = MTYPE_FROMTO( MSG_XPOSECOM, 
+                            rsl_c_comp2phys_proc (procrec->P), 
+                            rsl_myproc ) ;
+      typeque[tqp] = mtype ;
+      procrec->nrecvs++ ; /* diagnostic */
+#if 0
+fprintf(stderr,"debug posting async recv for %d bytes from %d\n", procrec->pack_table_nbytes, rsl_c_comp2phys_proc (procrec->P) ) ;
+#endif
+      RSL_RECVBEGIN ( pbuf, procrec->pack_table_nbytes, mtype ) ;
+      tqp++ ;
+    }
+  }
+  nprocs = tqp ;
+
+  /* pack buffers and issue sends */
+
+  for ( procrec = xpose->procs[d][xpose_sw] ; procrec != NULL ; procrec = procrec->next )
+  {
+    pbuf=buffer_for_proc(procrec->P, procrec->unpack_table_nbytes, RSL_SENDBUF) ;
+    pr = procrec->unpack_table ;
+    for ( curs = 0, i = 0 ; i < procrec->unpack_table_size ; i++, pr++ )
+    {
+      if ( xpose->has_f90_fields && procrec->unpack_table_size > 0 )
+        base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+      else
+        base =  pr->base ;
+#if 0
+fprintf(stderr,"pack   base %lu, f90_index %d, xpose=%d\n",base,pr->f90_table_index,x) ;
+#endif
+      for ( j = 0 ; j < pr->nelems ; j++ )
+      {
+
+#if 0
+fprintf(stderr,"pck %08x, buf %08x, curs %5d, n %5d, off %5d, j %5d, s %5d\n",
+(char *)(base) + pr->offset + j * pr->stride,
+&(pbuf[curs]), curs, pr->n,
+pr->offset, j, pr->stride ) ;
+{ int iii ;
+for ( iii = 0 ; iii < pr->n ; iii+=4 )
+{
+fprintf(stderr,"v >>> %f\n", *((float *)((char *)(base) + pr->offset + j * pr->stride + iii))) ;
+}}
+#endif
+
+        bcopy((char *)(base) + pr->offset + j * pr->stride,
+	      &(pbuf[curs]),pr->n) ;
+        curs += pr->n ;
+      }
+    }
+    if ( curs > 0 )
+    {
+      mdest = rsl_c_comp2phys_proc (procrec->P) ;
+      mtype = MTYPE_FROMTO( MSG_XPOSECOM, rsl_myproc, mdest ) ;
+      procrec->nsends++ ;
+      if ( curs > procrec->unpack_table_nbytes ) 
+      {
+        sprintf(mess,"pack buffer overflow %d > %d\n",curs,procrec->unpack_table_nbytes) ;
+        RSL_TEST_ERR(1,mess) ;
+      }
+#if 0
+fprintf(stderr,"debug sending %d bytes to %d, xpose=%d\n", curs, mdest, x ) ;
+#endif
+      RSL_SEND ( pbuf, curs, mtype, mdest ) ;
+    }
+    else if ( curs == 0 && procrec->unpack_table_nbytes != 0 )
+    {
+      RSL_TEST_ERR(1,"internal error") ;
+    }
+  }
+
+  /* wait on receives and unpack messages as they come in */
+  ndone = 0 ;
+  tqp = 0 ;
+  retval = 1 ;
+
+  while( ndone < nprocs )
+  {
+    if (tqp >= nprocs ) tqp = 0 ;
+    if (typeque[tqp] != RSL_INVALID)
+    {
+      mtype = typeque[tqp] ;
+      if ( rsl_noprobe == NULL )
+        RSL_PROBE ( mtype, &retval ) ;
+      /* else, retval will always be 1 */
+
+      if ( retval )
+      {
+#ifdef PGON
+/* on the Paragon, calling RSL_PROBE clears the message so this
+   would bomb on an unknown message id.  Don't call unless the probe
+   is disabled (rsl_noprobe != NULL). */
+        if ( rsl_noprobe != NULL ) RSL_RECVEND ( mtype ) ;
+#else  
+        RSL_RECVEND ( mtype ) ;
+#endif
+
+	curs = 0 ;
+        pbuf = buffer_for_proc( Pque[tqp], 0, RSL_RECVBUF ) ;
+        procrec = procrecque[tqp] ;
+#if 0
+        fprintf(stderr,"**unpack P = %3d:\n",procrec->P ) ;
+        show_pack_table( procrec->pack_table,
+                         procrec->pack_table_size,
+                         procrec->pack_table_nbytes ) ;
+#endif
+
+        pr = procrec->pack_table ;
+        for ( curs = 0, i = 0 ; i < procrec->pack_table_size ; i++, pr++ )
+	{
+          if ( xpose->has_f90_fields && procrec->pack_table_size > 0 )
+            base = (void *) get_base_for_index ( pr->f90_table_index ) ;
+          else
+            base = pr->base ;
+#if 0
+fprintf(stderr,"v unpack base %08x, n %3d, nelems %d, stride %3d, f90_index %d, xpose=%d\n",
+  base,pr->n,pr->nelems,pr->stride,pr->f90_table_index,x) ;
+#endif
+          for ( j = 0 ; j < pr->nelems ; j++ )
+          {
+            bcopy(&(pbuf[curs]),
+		 (char *)(base) + pr->offset + j * pr->stride, pr->n) ;
+#if 0
+{ int iii, mloc_mz, nloc_mz, zloc_mz, x ;
+mloc_mz = 8 ;
+nloc_mz = 9 ;
+zloc_mz = 3 ;
+for ( iii = 0 ; iii < pr->n ; iii+=4 )
+{
+x = ((pr->offset + j * pr->stride + iii))/4 ;
+fprintf(stderr,"v <<< %d i %2d k %2d j %2d %f\n",
+               x ,
+               x % mloc_mz ,
+               (x % (mloc_mz*zloc_mz))/mloc_mz  ,
+               (x / (mloc_mz*zloc_mz)) ,
+               *((float *)((char *)(base) + pr->offset + j * pr->stride + iii))) ;
+}}
+#endif
+            curs += pr->n ;
+	  }
+	}
+	if ( curs == 0 )
+	{
+	  RSL_TEST_ERR(1,"internal error") ;
+	}
+        if ( curs > procrec->pack_table_nbytes )
+        {
+          sprintf(mess,"unpack buffer overflow %d > %d\n",curs,procrec->pack_table_nbytes) ;
+          RSL_TEST_ERR(1,mess) ;
+	}
+#if 0
+fprintf(stderr,"debug got message from %d and unpacked %d bytes; xpose=%d\n", Pque[tqp], curs, x ) ;
+#endif
+        typeque[tqp] = RSL_INVALID ;
+        ndone++ ;
+      }
+    }
+    tqp++ ;
+  }
+#ifdef UPSHOT
+MPE_Log_event( 16, s, "xpose end" ) ;
+#endif
+}
+
+
diff --git a/wrfv2_fire/external/RSL/RSL/xpose_def.c b/wrfv2_fire/external/RSL/RSL/xpose_def.c
new file mode 100755
index 00000000..21d882e6
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/xpose_def.c
@@ -0,0 +1,257 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl.h"
+
+/*@
+  RSL_CREATE_XPOSE -- Create a stencil descriptor.
+
+  Notes:
+  The output argument is the integer Arg1, a descriptor to 
+  a new RSL stencil.  The stencil is then built (RSL_DESCRIBE_STENCIL)
+  and used in stencil exchanges (RSL_EXCH_STENCIL) during the model
+  run.
+
+  See also:
+  RSL_DESCRIBE_STENCIL, RSL_EXCH_STENCIL
+@*/
+
+RSL_CREATE_XPOSE ( xp_p )
+  int_p xp_p ;     /* (O) New RSL xpose descriptor. */
+{
+  int i ;
+  xpose_desc_t *xpose ;
+  
+  /* NOTE: never return the 0th stencil */
+  for ( i = 1 ; i < RSL_MAXDESCRIPTORS ; i++ )
+    if ( xp_descriptors[i] == NULL ) break ;    /* got one */
+
+  RSL_TEST_ERR( i == RSL_MAXDESCRIPTORS,
+  "rsl_create_xpose:  out of descriptors.");
+
+  *xp_p = i ;
+  xpose = RSL_MALLOC(xpose_desc_t,1) ;
+  xpose->tag = XPOSE_DESC ;
+  xpose->has_f90_fields = 0 ;
+  xp_descriptors[*xp_p] = xpose ;
+  xpose->xp = *xp_p ;
+}
+
+release_xp_descriptor (xp_p)
+  int_p xp_p ;
+{
+  int xp ;
+
+  xp = *xp_p ;
+  RSL_TEST_ERR( xp < 0 || xp >= RSL_MAXDESCRIPTORS,
+                "internal error.  Invalid xpose descriptor.") ;
+  if ( xp_descriptors[xp] != NULL )
+  {
+    xp_descriptors[xp] = NULL ;
+  }
+}
+
+/*@
+  RSL_DESCRIBE_XPOSE -- Defines an RSL transpose exchange on a domain.
+
+@*/
+
+RSL_DESCRIBE_XPOSE ( d_p, xp_p, message_mn_p , message_mz_p , message_nz_p )
+  int_p d_p,            /* (I) Domain descriptor. */
+        xp_p,           /* (I) Xpose handle */
+    message_mn_p,       /* (I) Message descriptor. */
+    message_mz_p,       /* (I) Message descriptor. */
+    message_nz_p   ;    /* (I) Message descriptor. */
+{
+  int d, xp, mh ;
+  rsl_domain_info_t * dinfo ;
+  xpose_desc_t *xpose ;
+  message_desc_t *msg_mn, *msg_mz, *msg_nz ;
+  int pt ;
+
+  d = *d_p ; xp = *xp_p ;
+
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+    "rsl_describe_xpose: bad domain descriptor\n") ;
+  dinfo = &(domain_info[d]) ;
+  RSL_TEST_ERR(dinfo->valid != RSL_VALID,
+    "rsl_describe_xpose: descriptor is not for a valid domain\n") ;
+
+  RSL_TEST_ERR( xp < 0 || xp >= RSL_MAXDESCRIPTORS,
+    "rsl_describe_stencil: bad stencil handle" ) ;
+  xpose = (xpose_desc_t *) xp_descriptors[xp] ;
+  RSL_TEST_ERR( xpose->tag != XPOSE_DESC,
+       "rsl_describe_xpose: handle given is not for an rsl xpose def" ) ;
+
+  xpose->compiled[d] = 0 ;
+
+  RSL_TEST_ERR(  (*message_mn_p <= 0 || *message_mn_p >=RSL_MAXDESCRIPTORS),
+"rsl_describe_xpose: bad message handle in list,\n  must be valid message") ;
+  msg_mn = (message_desc_t *) mh_descriptors[ *message_mn_p ] ;
+  xpose->msgs_mn[d] = msg_mn ;
+
+  RSL_TEST_ERR(  (*message_mz_p <= 0 || *message_mz_p >=RSL_MAXDESCRIPTORS),
+"rsl_describe_xpose: bad message handle in list,\n  must be valid message") ;
+  msg_mz = (message_desc_t *) mh_descriptors[ *message_mz_p ] ;
+  xpose->msgs_mz[d] = msg_mz ;
+
+  RSL_TEST_ERR(  (*message_nz_p <= 0 || *message_nz_p >=RSL_MAXDESCRIPTORS),
+"rsl_describe_xpose: bad message handle in list,\n  must be valid message") ;
+  msg_nz = (message_desc_t *) mh_descriptors[ *message_nz_p ] ;
+  xpose->msgs_nz[d] = msg_nz ;
+
+  /* free up the message descriptor; it has done its job */
+  release_mh_descriptor( message_mn_p ) ;
+  release_mh_descriptor( message_mz_p ) ;
+  release_mh_descriptor( message_nz_p ) ;
+
+  /* add my descriptor to the list for the domain */
+  dinfo->xposelist[dinfo->xposecurs] = xp ;
+  dinfo->xposecurs++ ;  /* 970317 */
+
+  if ( dinfo->xposecurs >= RSL_MAXDESCRIPTORS )
+  {
+    sprintf(mess,
+     "Domain %d doesn't have room for any more xposes, but the allowable\nlimit of %d should have been more than enough.\nYou might recompile RSL with a higher setting for RSL_MAXDESCRIPTORS, but\n it's likely something else is wrong.",
+       d, RSL_MAXDESCRIPTORS ) ;
+    RSL_TEST_ERR( 1, mess ) ;
+     
+  }
+}
+
+#if 0
+/* some of these need to be converted for xposes; others need to be eliminated */
+/* only used internally within the RSL package */
+destroy_stencil( sten )
+  stencil_desc_t * sten ;
+{
+  int d ;
+  rsl_fldspec_t *fld, *doomed ;
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( sten->tag != STENCIL_DESC, "destroy_stencil: arg not a stencil.") ;
+
+  for ( d = 0 ; d < RSL_MAXDOMAINS ; d++ )
+  {
+    destroy_stencil_on_domain( d, sten ) ;
+  }
+  release_sh_descriptor (sten->sh) ;
+  RSL_FREE( sten ) ;
+}
+
+destroy_stencil_on_domain( d, sten )
+  int d ;
+  stencil_desc_t * sten ;
+{
+  int i ;
+
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "destroy_stencil_on_domain: bad domain descriptor") ;
+  for ( i = 0 ; i < RSL_MAXSTEN+1 ; i++ )
+  {
+    destroy_message( sten->msgs[d][i] ) ;
+  }
+  sten->f[d].ptfcn = NULL ;
+  sten->npts[d] = 0 ;
+  uncompile_stencil_on_domain( d, sten ) ;
+}
+
+uncompile_stencil_on_domain( d, sten )
+  int d ;
+  stencil_desc_t * sten ;
+{
+  int i ;
+
+  if ( sten == NULL ) return ;
+  RSL_TEST_ERR( d < 0 || d >= RSL_MAXDOMAINS,
+     "uncompile_stencil_on_domain: bad domain descriptor") ;
+  sten->compiled[d] = 0 ;
+  destroy_procrec_list( sten->procs[d] ) ;
+  sten->procs[d] = NULL ; /* 970317 */
+}
+
+destroy_procrec_list( prec )
+  rsl_procrec_t *prec ;
+{ 
+  rsl_procrec_t *p, *doomed ;
+  int destroy_ptrec_list() ;
+  if ( prec == NULL ) return ;
+  for ( p = prec ; p != NULL ; )
+  {
+    doomed = p ;
+    p = p->next ;
+    destroy_list( &(doomed->point_list), destroy_ptrec_list ) ;
+    RSL_FREE(doomed) ;
+  }
+}
+
+destroy_ptrec_list( ptrec )
+  rsl_ptrec_t *ptrec ;
+{
+  rsl_ptrec_t *p, *doomed ;
+  if ( ptrec == NULL ) return ;
+  for ( p = ptrec ; p != NULL ; )
+  {
+    doomed = p ;
+    p = p->next ;
+    destroy_list( &(doomed->send_messages), NULL ) ;
+    destroy_list( &(doomed->recv_messages), NULL ) ;
+    RSL_FREE(doomed) ;
+  }
+}
+#endif
diff --git a/wrfv2_fire/external/RSL/RSL/xpose_def.h b/wrfv2_fire/external/RSL/RSL/xpose_def.h
new file mode 100755
index 00000000..f46f253d
--- /dev/null
+++ b/wrfv2_fire/external/RSL/RSL/xpose_def.h
@@ -0,0 +1,75 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+
+
+#ifndef XPOSE_DEF_H
+#define XPOSE_DEF_H
+
+typedef struct xpose_desc {
+  rsl_tag_t tag;               
+  int xp ;		/* my descriptor */
+  int has_f90_fields ;
+  rsl_tag_t compiled[RSL_MAXDOMAINS];
+  rsl_tag_t npts[RSL_MAXDOMAINS] ;
+        /* 0 is from, 1 is to */
+  message_desc_t *msgs_mn[RSL_MAXDOMAINS] ;
+  message_desc_t *msgs_mz[RSL_MAXDOMAINS] ;
+  message_desc_t *msgs_nz[RSL_MAXDOMAINS] ;
+  rsl_procrec_t *procs[RSL_MAXDOMAINS][3] ; /* XPOSE_MN_MZ, XPOSE_MZ_NZ, or XPOSE_MN_NZ */
+} xpose_desc_t ;
+
+#endif  /* nothing after this line */
diff --git a/wrfv2_fire/external/RSL/gen_comms.c b/wrfv2_fire/external/RSL/gen_comms.c
new file mode 100644
index 00000000..b4ecff6f
--- /dev/null
+++ b/wrfv2_fire/external/RSL/gen_comms.c
@@ -0,0 +1,1243 @@
+#include 
+#include 
+#include 
+
+#include "protos.h"
+#include "registry.h"
+#include "data.h"
+
+/* For detecting variables that are members of a derived type */
+#define NULLCHARPTR   (char *) 0
+static int parent_type;
+
+int
+gen_halos ( char * dirname )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
+  char commuse[NAMELEN_LONG] ;
+  int maxstenwidth, stenwidth ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
+  int zdex ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = Halos ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+    /* get maximum stencil width */
+    maxstenwidth = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
+      stenwidth = atoi (t2) ;
+      if ( stenwidth == 0 )
+       { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
+      if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
+      t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
+    }
+    print_warning(fp,fname) ;
+    fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
+    fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
+    fprintf(fp,"    BECAUSE IT CONTAINS AN RSL HALO OPERATION\n" ) ;
+    fprintf(fp,"#endif\n") ;
+
+    fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'set up halo %s' )\n",commname ) ;
+    fprintf(fp,"  CALL setup_halo_rsl( grid )\n" ) ;
+    fprintf(fp,"  CALL reset_msgs_%dpt\n", maxstenwidth ) ;
+
+    /* pass through description again now and generate the calls  */
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
+      stenwidth = atoi (t2) ;
+      t2 = strtok_rentr(NULL,", ", &pos2) ;
+
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+        {
+          fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ;
+        }
+        else
+        {
+
+          strcpy( varref, t2 ) ;
+          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+             if ( !strncmp( q->use,  "dyn_", 4 )) {
+                  char * core ;
+                  core = q->use+4 ;
+                  sprintf(varref,"grid%%%s_%s",core,t2) ;
+             } else {
+                  sprintf(varref,"grid%%%s",t2) ;
+             }
+          }
+
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
+          {
+            fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of halo exchange. %s in %s is %s\n",t2,commname,q->type->name) ;
+          }
+          else if ( q->boundary_array )
+          {
+            fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ;
+          }
+          else
+          {
+            if ( q->node_kind & FOURD )
+            {
+              node_t *member ;
+              zdex = get_index_for_coord( q , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 )
+              {
+                for ( member = q->members ; member != NULL ; member = member->next )
+                {
+                  if ( strcmp( member->name, "-" ) )
+                  {
+                    fprintf(fp,"  if ( P_%s .GT. 1 ) CALL add_msg_%dpt_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n", 
+                       member->name, stenwidth, q->type->name, t2 , member->name, zdex+1 ) ;
+                  }
+                }
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else
+            {
+              strcpy (indices,"");
+              if ( sw_deref_kludge ) /* &&  strchr (t2, '%') != NULLCHARPTR ) */
+              {
+                sprintf(post,")") ;
+                sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+              }
+              dimd = get_dimnode_for_coord( q , COORD_Z ) ;
+              zdex = get_index_for_coord( q , COORD_Z ) ;
+              if ( dimd != NULL )
+              {
+                char dimstrg[256] ;
+
+                if      ( dimd->len_defined_how == DOMAIN_STANDARD )
+                    sprintf(dimstrg,"(glen(%d))",zdex+1) ;
+                else if ( dimd->len_defined_how == NAMELIST )
+                {
+                  if ( !strcmp(dimd->assoc_nl_var_s,"1") )
+                    sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                  else
+                    sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
+                }
+                else if ( dimd->len_defined_how == CONSTANT )
+                    sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
+
+                fprintf(fp,"  CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, dimstrg ) ;
+              }
+              else if ( q->ndims == 2 )  /* 2d */
+              {
+                fprintf(fp,"  CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, "1" ) ;
+              }
+            }
+          }
+          q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
+        }
+        t2 = strtok_rentr( NULL , ", " , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
+    }
+    fprintf(fp,"  CALL stencil_%dpt ( grid%%domdesc , grid%%comms ( %s ) )\n", maxstenwidth , commname ) ;
+    fprintf(fp,"ENDIF\n") ;
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchange halo %s' )\n",commname ) ;
+    fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%comms( %s ) )\n", commname ) ;
+
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_periods ( char * dirname )
+{
+  node_t * p, * q ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
+  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG], commuse[NAMELEN_LONG] ;
+  int maxperwidth, perwidth ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  node_t * dimd ;
+  int zdex ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = Periods ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+    /* get maximum stencil width */
+    maxperwidth = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
+      perwidth = atoi (t2) ;
+      if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+    print_warning(fp,fname) ;
+
+    fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
+    fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
+    fprintf(fp,"    BECAUSE IT CONTAINS AN RSL PERIOD OPERATION\n" ) ;
+    fprintf(fp,"#endif\n") ;
+    fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value .AND. (config_flags%%periodic_x .OR. config_flags%%periodic_y )) THEN\n",commname ) ;
+
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'setting up period %s' )\n",commname ) ;
+    fprintf(fp,"  CALL setup_period_rsl( grid )\n" ) ;
+    fprintf(fp,"  CALL reset_period\n") ;
+
+    /* pass through description again now and generate the calls  */
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
+      perwidth = atoi (t2) ;
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+        {
+          fprintf(stderr,"WARNING 2 : %s in period spec %s is not defined in registry.\n",t2,commname) ;
+        }
+        else
+        {
+          if ( q->boundary_array )
+          {
+            fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ;
+          }
+          else
+          {
+
+            strcpy( varref, t2 ) ;
+            if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+               if ( !strncmp( q->use,  "dyn_", 4 )) {
+                    char * core ;
+                    core = q->use+4 ;
+                    sprintf(varref,"grid%%%s_%s",core,t2) ;
+               } else {
+                    sprintf(varref,"grid%%%s",t2) ;
+               }
+            }
+
+            if ( q->node_kind & FOURD )
+            {
+              node_t *member ;
+              zdex = get_index_for_coord( q , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 )
+              {
+                for ( member = q->members ; member != NULL ; member = member->next )
+                {
+                  if ( strcmp( member->name, "-" ) )
+                  {
+                    fprintf(fp,"  if ( P_%s .GT. 1 ) CALL add_msg_period_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
+                       member->name, q->type->name, t2 , member->name, zdex+1 ) ;
+                  }
+                }
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else
+            {
+              strcpy (indices,"");
+              if ( sw_deref_kludge ) /* &&  strchr (t2, '%') != NULLCHARPTR ) */
+              {
+                sprintf(post,")") ;
+                sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+              }
+              dimd = get_dimnode_for_coord( q , COORD_Z ) ;
+              zdex = get_index_for_coord( q , COORD_Z ) ;
+              if ( dimd != NULL )
+              {
+                char dimstrg[256] ;
+
+                if      ( dimd->len_defined_how == DOMAIN_STANDARD )
+                    sprintf(dimstrg,"(glen(%d))",zdex+1) ;
+                else if ( dimd->len_defined_how == NAMELIST )
+                {
+                  if ( !strcmp(dimd->assoc_nl_var_s,"1") )
+                    sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                  else
+                    sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
+                }
+                else if ( dimd->len_defined_how == CONSTANT )
+                    sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
+
+                fprintf(fp,"  CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, dimstrg ) ;
+              }
+              else if ( q->ndims == 2 )  /* 2d */
+              {
+                fprintf(fp,"  CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, "1" ) ;
+              }
+            }
+          }
+          q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
+        }
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+    fprintf(fp,"  CALL period_def ( grid%%domdesc , grid%%comms ( %s ) , %d )\n",commname , maxperwidth ) ;
+    fprintf(fp,"ENDIF\n") ;
+    fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ; 
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchanging period %s on x' )\n",commname ) ;
+    fprintf(fp,"  CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , x_period_flag )\n",commname ) ;
+    fprintf(fp,"END IF\n") ; 
+    fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchanging period %s on y' )\n",commname ) ;
+    fprintf(fp,"  CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , y_period_flag )\n",commname ) ;
+    fprintf(fp,"END IF\n") ;
+
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_xposes ( char * dirname )
+{
+  node_t * p, * q ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
+  char commuse[NAMELEN_LONG] ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
+  char ** x ;
+  char indices[NAMELEN], post[NAMELEN], varname[NAMELEN], varref[NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = Xposes ; p != NULL ; p = p->next )
+  {
+    for ( x = xposedir ; *x ; x++ )
+    {
+      strcpy( commname, p->name ) ;
+      make_upper_case(commname) ;
+      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
+      else                       { sprintf(fname,"%s_%s.inc",commname,*x) ; }
+      if ((fp = fopen( fname , "w" )) == NULL ) 
+      {
+        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
+        continue ; 
+      }
+
+      print_warning(fp,fname) ;
+      fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
+      fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
+      fprintf(fp,"    BECAUSE IT CONTAINS AN RSL TRANSPOSE OPERATION\n" ) ;
+      fprintf(fp,"#endif\n") ;
+      fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
+
+      fprintf(fp,"  CALL wrf_debug ( 50 , 'setting up xpose %s' )\n",commname ) ;
+      fprintf(fp,"  CALL setup_xpose_rsl( grid )\n") ;
+      fprintf(fp,"  CALL reset_msgs_xpose\n" ) ;
+
+      strcpy( tmp, p->comm_define ) ;
+      strcpy( commuse, p->use ) ;
+      t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+      while ( t1 != NULL )
+      {
+        strcpy( tmp2 , t1 ) ;
+
+/* Z array */
+        t2 = strtok_rentr(tmp2,",", &pos2) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_Z_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+        fprintf(fp," CALL add_msg_xpose_%s ( %s%s ,", q->type->name, varref,indices ) ;
+        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
+
+/* X array */
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_X_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+        fprintf(fp," %s%s ,", varref, indices ) ;
+        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
+
+/* Y array */
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_Y_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+        fprintf(fp," %s%s , 3 )\n", varref, indices ) ;
+        q->subject_to_communication = 1 ;         /* Indicate that this field may be communicated */
+        t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+      }
+      fprintf(fp,"  CALL define_xpose ( grid%%domdesc , grid%%comms ( %s ) )\n", commname ) ;
+      fprintf(fp,"ENDIF\n") ;
+      fprintf(fp,"CALL wrf_debug ( 50 , 'calling wrf_dm_xpose_%s for %s')\n",*x,commname ) ;
+      fprintf(fp,"CALL wrf_dm_xpose_%s ( grid%%domdesc , grid%%comms, %s )\n", *x , commname ) ;
+
+      close_the_file(fp) ;
+    }
+skiperific:
+    ;
+  }
+  return(0) ;
+}
+
+int
+gen_comm_descrips ( char * dirname )
+{
+  node_t * p ;
+  char * fn = "dm_comm_cpp_flags" ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  FILE * fp ;
+  int ncomm ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
+  else                       { sprintf(fname,"%s",fn) ; }
+
+  if ((fp = fopen( fname , "w" )) == NULL )
+  {
+    fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
+  }
+
+  ncomm = 1 ;
+  for ( p = Halos ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
+  }
+  for ( p = Periods ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
+  }
+  for ( p = Xposes ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
+  }
+  fprintf(fp,"-DWRF_RSL_NCOMMS=%d\n",ncomm-1 ) ;
+  return(0) ;
+}
+
+/*
+
+
+
+*/
+
+/* for each core, generate the halo updates to allow shifting all state data */
+int
+gen_shift (  char * dirname )
+{
+  int i, ncore ;
+  FILE * fp ;
+  node_t *p, *q, *dimd ;
+  char * corename ;
+  char **direction ;
+  char *directions[] = { "x", "y", 0L } ;
+  char fname[NAMELEN], vname[NAMELEN], vname2[NAMELEN], core[NAMELEN] ;
+  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
+  int zdex ;
+int said_it = 0 ;
+
+  for ( direction = directions ; *direction != NULL ; direction++ )
+  {
+  for ( ncore = 0 ; ncore < get_num_cores() ; ncore++ )
+  {
+    corename = get_corename_i(ncore) ;
+    if ( dirname == NULL || corename == NULL ) return(1) ;
+    if ( strlen(dirname) > 0 )
+     { sprintf(fname,"%s/%s_shift_halo_%s.inc",dirname,corename,*direction) ; }
+    else
+     { sprintf(fname,"%s_shift_halo_%s.inc",corename,*direction) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+    print_warning(fp,fname) ;
+    fprintf(fp,"IF ( grid%%shift_%s == invalid_message_value ) THEN\n",*direction ) ;
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'set up halo for %s shift' )\n",*direction ) ;
+    fprintf(fp,"  CALL setup_halo_rsl( grid )\n" ) ;
+    fprintf(fp,"  CALL reset_msgs_%s_shift\n", *direction ) ;
+
+    for ( p = Domain.fields ; p != NULL ; p = p->next )
+    {
+
+/* special cases in WRF */
+if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
+     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
+     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
+  if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
+                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
+                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
+  said_it = 1 ; }
+  continue ;
+}
+
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
+	  ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
+      {
+
+        if ( p->node_kind & FOURD ) {
+          sprintf(core,"") ;
+        } else {
+          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
+          else                                sprintf(core,"") ;
+        }
+
+/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
+        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
+	  if ( p->type->type_type == SIMPLE )
+	  {
+	    for ( i = 1 ; i <= p->ntl ; i++ )
+	    {
+              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
+              else              sprintf(vname,"%s",p->name ) ;
+              if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
+              else              sprintf(vname2,"%s%s",core,p->name ) ;
+	      if ( p->node_kind & FOURD )
+              {
+                node_t *member ;
+                zdex = get_index_for_coord( p , COORD_Z ) ;
+                if ( zdex >=1 && zdex <= 3 )
+                {
+                  for ( member = p->members ; member != NULL ; member = member->next )
+                  {
+                    if ( strcmp( member->name, "-" ) )
+                    {
+                      fprintf(fp,
+   "  if ( P_%s .GT. 1 ) CALL add_msg_%s_shift_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
+                         member->name, *direction, p->type->name, vname, member->name, zdex+1 ) ;
+                      p->subject_to_communication = 1 ;
+                    }
+                  }
+                }
+                else
+                {
+                  fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+                }
+              }
+              else
+	      {
+                strcpy (indices,"");
+                if ( sw_deref_kludge ) /* &&  strchr (p->name, '%') != NULLCHARPTR ) */
+                {
+                  sprintf(post,")") ;
+                  sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,p,post)) ;
+                }
+                dimd = get_dimnode_for_coord( p , COORD_Z ) ;
+                zdex = get_index_for_coord( p , COORD_Z ) ;
+                if ( dimd != NULL )
+                {
+                  char dimstrg[256] ;
+
+                  if      ( dimd->len_defined_how == DOMAIN_STANDARD )
+                      sprintf(dimstrg,"(glen(%d))",zdex+1) ;
+                  else if ( dimd->len_defined_how == NAMELIST )
+                  {
+                    if ( !strcmp(dimd->assoc_nl_var_s,"1") )
+                      sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                    else
+                      sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
+                  }
+                  else if ( dimd->len_defined_how == CONSTANT )
+                      sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
+  
+                  fprintf(fp,"  CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, dimstrg ) ;
+                  p->subject_to_communication = 1 ;
+                }
+                else if ( p->ndims == 2 )  /* 2d */
+                {
+                  fprintf(fp,"  CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, "1" ) ;
+                  p->subject_to_communication = 1 ;
+                }
+              }
+            }
+	  }
+	}
+      }
+    }
+    fprintf(fp,"  CALL stencil_%s_shift ( grid%%domdesc , grid%%shift_%s )\n", *direction , *direction ) ;
+    fprintf(fp,"ENDIF\n") ;
+    fprintf(fp,"  CALL wrf_debug ( 50 , 'exchange halo for %s shift' )\n",*direction ) ;
+    fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%shift_%s )\n", *direction ) ;
+
+    for ( p = Domain.fields ; p != NULL ; p = p->next )
+    {
+
+/* special cases in WRF */
+if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
+     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
+     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
+  continue ;
+}
+      if ( p->node_kind & FOURD ) {
+        sprintf(core,"") ;
+      } else {
+        if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
+        else                                sprintf(core,"") ;
+      }
+
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
+	  ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
+      {
+/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
+        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
+  	  if ( p->type->type_type == SIMPLE )
+	  {
+	    for ( i = 1 ; i <= p->ntl ; i++ )
+	    {
+              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
+              else              sprintf(vname,"%s",p->name ) ;
+              if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
+              else              sprintf(vname2,"%s%s",core,p->name ) ;
+
+	      if ( p->node_kind & FOURD )
+              {
+                node_t *member ;
+                zdex = get_index_for_coord( p , COORD_Z ) ;
+                if ( zdex >=1 && zdex <= 3 )
+                {
+                  for ( member = p->members ; member != NULL ; member = member->next )
+                  {
+                    if ( strcmp( member->name, "-" ) )
+                    {
+                      if ( !strcmp( *direction, "x" ) )
+                      {
+                        fprintf(fp,
+   "  if ( P_%s .GT. 1 ) %s ( ips:min(ide%s,ipe),:,jms:jme,P_%s) = %s (ips+px:min(ide%s,ipe)+px,:,jms:jme,P_%s)\n",
+                         member->name, vname, member->stag_x?"":"-1", member->name, vname, member->stag_x?"":"-1", member->name ) ;
+                      }
+                      else
+                      {
+                        fprintf(fp,
+   "  if ( P_%s .GT. 1 ) %s ( ims:ime,:,jps:min(jde%s,jpe),P_%s) = %s (ims:ime,:,jps+py:min(jde%s,jpe)+py,P_%s)\n",
+                         member->name, vname, member->stag_y?"":"-1", member->name, vname, member->stag_y?"":"-1", member->name ) ;
+                      }
+                    }
+                  }
+                }
+                else
+                {
+                  fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+                }
+              }
+              else
+	      {
+	        char * vdim ;
+	        vdim = "" ;
+	        if ( p->ndims == 3 ) vdim = ":," ;
+                if ( !strcmp( *direction, "x" ) )
+                {
+                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),%sjms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,%sjms:jme)\n", vname2,  p->stag_x?"":"-1", vdim, vname2, p->stag_x?"":"-1", vdim ) ;
+                }
+                else
+	        {
+                  fprintf(fp,"grid%%%s (ims:ime,%sjps:min(jde%s,jpe)) = grid%%%s (ims:ime,%sjps+py:min(jde%s,jpe)+py)\n", vname2, vdim,  p->stag_y?"":"-1", vname2, vdim, p->stag_y?"":"-1" ) ;
+                }
+              }
+            }
+	  }
+	}
+      }
+    }
+    close_the_file(fp) ;
+  }
+  }
+}
+
+int
+gen_datacalls ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fn = "data_calls.inc" ;
+  char fname[NAMELEN] ;
+
+  for ( i = 0 ; i < get_num_cores() ; i++ )
+  {
+    corename = get_corename_i(i) ;
+    if ( dirname == NULL || corename == NULL ) return(1) ;
+    if ( strlen(dirname) > 0 )
+     { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+    else
+     { sprintf(fname,"%s_%s",corename,fn) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+    print_warning(fp,fname) ;
+    fprintf(fp," CALL rsl_start_register_f90\n") ;
+    parent_type = SIMPLE;
+    gen_datacalls1( fp , corename, "grid%", FIELD , Domain.fields ) ;
+    gen_datacalls1( fp , corename, "", FOURD , Domain.fields ) ;
+    fprintf(fp,"#ifdef REGISTER_I1\n") ;
+    gen_datacalls1( fp , corename, "", I1 , Domain.fields ) ;
+    fprintf(fp,"#endif\n") ;
+    fprintf(fp," CALL rsl_end_register_f90\n") ;
+    fprintf(fp,"#define  DATA_CALLS_INCLUDED\n") ;
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_datacalls1 ( FILE * fp , char * corename , char * structname , int mask , node_t * node )
+{
+  node_t * p, * q  ;
+  int i, member_number ;
+  char tmp[NAMELEN],tmp2[NAMELEN], tc ;
+  char indices[NAMELEN], post[NAMELEN] ;
+  char s0[NAMELEN], s1[NAMELEN], s2[NAMELEN] ;
+  char e0[NAMELEN], e1[NAMELEN], e2[NAMELEN] ;
+
+  for ( p = node ; p != NULL ; p = p->next )
+  {
+    if ( ( mask & p->node_kind ) &&
+        ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
+    {
+    if ( (p->subject_to_communication == 1) || ( p->type->type_type == DERIVED ) )
+    {
+      if ( p->type->type_type == SIMPLE )
+      {
+        if ( !strcmp( p->type->name , "real" ) ) tc = 'R' ;
+        if ( !strcmp( p->type->name , "double" ) ) tc = 'D' ;
+        if ( !strcmp( p->type->name , "integer" ) ) tc = 'I' ;
+        for ( i = 1 ; i <= p->ntl ; i++ )
+        {
+/* IF (P_QI .ge. P_FIRST_SCALAR */
+          if ( p->members != NULL )   /* a 4d array */
+          {
+            member_number = 0 ;
+            for ( q = p->members ; q != NULL ; q = q->next )
+            {
+              get_elem( "grid%", "", s0, 0, p , 0 ) ;
+              get_elem( "grid%", "", s1, 1, p , 0 ) ;
+              get_elem( "grid%", "", s2, 2, p , 0 ) ;
+
+              get_elem( "grid%", "", e0, 0, p , 1 ) ;
+              get_elem( "grid%", "", e1, 1, p , 1 ) ;
+              get_elem( "grid%", "", e2, 2, p , 1 ) ;
+
+              sprintf(tmp, "(%s,%s,%s,1+%d)", s0, s1, s2, member_number ) ;
+              sprintf(tmp2, "(%s-%s+1)*(%s-%s+1)*(%s-%s+1)*%cWORDSIZE",e0,s0,e1,s1,e2,s2,tc) ;
+              if ( p->ntl > 1 ) fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s_%d %s , &\n %s  )\n",
+                                             member_number,p->name,structname,p->name,i,tmp,tmp2) ;
+              else              fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s %s, &\n %s )\n",
+                                             member_number,p->name,structname,p->name,tmp,tmp2) ;
+              member_number++ ;
+            }
+          }
+          else
+          {
+            char ca[NAMELEN] ;
+            strcpy (indices,"");
+            if ( sw_deref_kludge )
+            {
+              sprintf(post,")") ;
+              sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp,p,post)) ;
+            }
+            strcpy( ca, "" ) ;
+            if (!strncmp( p->use , "dyn_", 4 )) { char * cb ;  cb = p->use+4 ; sprintf(ca,"%s_", cb) ; }
+            if ( p->ntl > 1 ) fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s_%d%s , SIZE( %s%s%s_%d ) * %cWORDSIZE )\n",
+                                                                                   structname,ca,p->name,i,indices,
+                                                                                   structname,ca,p->name,i,tc ) ;
+            else              fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s%s , SIZE( %s%s%s  ) * %cWORDSIZE )\n",
+                                                                                   structname,ca,p->name,indices,
+                                                                                   structname,ca,p->name, tc) ;
+          }
+        }
+      }
+      else if ( p->type->type_type == DERIVED )
+      {
+        parent_type = DERIVED;
+        sprintf( tmp , "grid%%%s%%", p->name ) ; 
+        gen_datacalls1 ( fp , corename , tmp , mask, p->type->fields ) ;
+      }
+    }
+  }
+  }
+  return(0) ;
+}
+
+/*****************/
+/*****************/
+
+gen_nest_packing ( char * dirname )
+{
+  gen_nest_pack( dirname ) ;   
+  gen_nest_unpack( dirname ) ; 
+}
+
+#define PACKIT 1
+#define UNPACKIT 2
+
+int
+gen_nest_pack ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
+  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
+  int ipath ;
+  char ** fnp ; char * fn ;
+  char fname[NAMELEN] ;
+  node_t *node, *p, *dim ;
+  int xdex, ydex, zdex ;
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  int d2, d3 ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+    for ( i = 0 ; i < get_num_cores() ; i++ )
+    {
+      corename = get_corename_i(i) ;
+      if ( dirname == NULL || corename == NULL ) return(1) ;
+      if ( strlen(dirname) > 0 ) {
+       if ( strlen( corename ) > 0 )
+         { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+       else
+         { sprintf(fname,"%s/%s",dirname,fn) ; }
+      } else { 
+       if ( strlen( corename ) > 0 ) 
+          { sprintf(fname,"%s_%s",corename,fn) ; }
+       else
+          { sprintf(fname,"%s",fn) ; }
+      }
+      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+      print_warning(fp,fname) ;
+
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
+
+      if ( d2 + d3 > 0 ) {
+        if ( down_path[ipath] == INTERP_UP )
+        {
+
+          fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
+          fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
+          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
+          fprintf(fp,"                        i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
+          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+ 
+          gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
+
+          fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
+          fprintf(fp,"                         msize*RWORDSIZE,                             &\n") ;
+          fprintf(fp,"                         i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
+          fprintf(fp,"ENDDO\n") ;
+
+        }
+        else
+        {
+
+          fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
+          fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
+          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
+          fprintf(fp,"                        i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
+          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+  
+          gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
+
+          fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc ,  &\n") ;
+          fprintf(fp,"                        msize*RWORDSIZE,                             &\n") ;
+          fprintf(fp,"                        i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
+          fprintf(fp,"ENDDO\n") ;
+
+        }
+      }
+
+      close_the_file(fp) ;
+    }
+  }
+  return(0) ;
+}
+
+int
+gen_nest_unpack ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
+  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
+  int ipath ;
+  char ** fnp ; char * fn ;
+  char fname[NAMELEN] ;
+  node_t *node, *p, *dim ;
+  int xdex, ydex, zdex ;
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  int d2, d3 ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+    for ( i = 0 ; i < get_num_cores() ; i++ )
+    {
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      corename = get_corename_i(i) ;
+      if ( dirname == NULL || corename == NULL ) return(1) ;
+      if ( strlen(dirname) > 0 )
+       { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+      else
+       { sprintf(fname,"%s_%s",corename,fn) ; }
+      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+      print_warning(fp,fname) ;
+
+      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
+
+      if ( d2 + d3 > 0 ) {
+        if ( down_path[ipath] == INTERP_UP )
+        {
+
+          fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
+          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+
+          gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
+
+          fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
+          fprintf(fp,"ENDDO\n") ;
+
+        }
+        else
+        {
+
+          fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
+          fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+          gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
+          fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
+          fprintf(fp,"ENDDO\n") ;
+
+        }
+      }
+
+      close_the_file(fp) ;
+    }
+  }
+  return(0) ;
+}
+
+int
+gen_nest_packunpack ( FILE *fp , node_t * node , char * corename, int dir, int down_path )
+{
+  int i ;
+  node_t *p, *p1, *dim ;
+  int d2, d3, xdex, ydex, zdex ;
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN], vname2[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  char c, d ;
+
+  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
+  {
+
+    if ( p1->node_kind & FOURD )
+    {
+      gen_nest_packunpack ( fp, p1->members, corename, dir , down_path ) ;  /* RECURSE over members */
+      continue ;
+    }
+    else
+    {
+      p = p1 ;
+    }
+
+    if ( p->io_mask & down_path )
+    {
+      if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
+      {
+
+        if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
+        else                                sprintf(core,"") ;
+
+        if ( p->ntl > 1 ) sprintf(tag,"_2") ;
+        else              sprintf(tag,"") ;
+
+        set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
+        zdex = get_index_for_coord( p , COORD_Z ) ;
+        xdex = get_index_for_coord( p , COORD_X ) ;
+        ydex = get_index_for_coord( p , COORD_Y ) ;
+
+        if ( down_path == INTERP_UP )
+        {
+          c = ( dir == PACKIT )?'n':'p' ;
+          d = ( dir == PACKIT )?'2':'1' ;
+        } else {
+          c = ( dir == UNPACKIT )?'n':'p' ;
+          d = ( dir == UNPACKIT )?'2':'1' ;
+        }
+
+        if ( zdex >= 0 ) {
+          if      ( xdex == 0 && zdex == 1 && ydex == 2 )  sprintf(dexes,"pig,k,pjg") ;
+          else if ( zdex == 0 && xdex == 1 && ydex == 2 )  sprintf(dexes,"k,pig,pjg") ;
+          else if ( xdex == 0 && ydex == 1 && zdex == 2 )  sprintf(dexes,"pig,pjg,k") ;
+        } else {
+          if ( xdex == 0 && ydex == 1 )  sprintf(dexes,"pig,pjg") ;
+          if ( ydex == 0 && xdex == 1 )  sprintf(dexes,"pjg,pig") ;
+        }
+
+        /* construct variable name */
+        if ( p->scalar_array_member )
+        {
+          sprintf(vname,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
+          if ( strlen(core) > 0 )
+            sprintf(vname2,"%s_%s%s(%s,P_%s)",core,p->use,tag,dexes,p->name) ;
+          else
+            sprintf(vname2,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
+        }
+        else
+        {
+          sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
+          if ( strlen(core) > 0 )
+            sprintf(vname2,"%s_%s%s(%s)",core,p->name,tag,dexes) ;
+          else
+            sprintf(vname2,"%s%s(%s)",p->name,tag,dexes) ;
+        }
+
+        if ( p->scalar_array_member )
+	{
+fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
+	}
+
+        if ( dir == UNPACKIT ) 
+        {
+          if ( down_path == INTERP_UP )
+	  {
+            if ( zdex >= 0 ) {
+fprintf(fp,"CALL rsl_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"CALL rsl_from_child_msg(RWORDSIZE,xv)\n" ) ;
+            }
+fprintf(fp,"IF ( %s_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
+                 corename, p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(grid%%%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], vname2 ) ;
+            } else {
+fprintf(fp,"grid%%%s = xv(1) ;\n", vname2) ;
+            }
+fprintf(fp,"ENDIF\n") ;
+          }
+          else
+          {
+            if ( zdex >= 0 ) {
+fprintf(fp,"CALL rsl_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\ngrid%%%s = xv(k)\nENDDO\n",
+                                    ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], vname2) ;
+            } else {
+fprintf(fp,"CALL rsl_from_parent_msg(RWORDSIZE,xv)\ngrid%%%s = xv(1)\n", vname2) ;
+            }
+          }
+        }
+        else
+        {
+          if ( down_path == INTERP_UP )
+	  {
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
+                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_to_parent_msg(RWORDSIZE,xv)\n", vname2) ;
+            }
+          }
+          else
+          {
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nxv(k)= grid%%%s\nENDDO\nCALL rsl_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
+                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)=grid%%%s\nCALL rsl_to_child_msg(RWORDSIZE,xv)\n", vname2) ;
+            }
+          }
+        }
+        if ( p->scalar_array_member )
+	{
+fprintf(fp,"ENDIF\n") ;
+	}
+      }
+    }
+  }
+
+  return(0) ;
+}
+
+/*****************/
+
+int
+count_fields ( node_t * node , int * d2 , int * d3 , char * corename , int down_path )
+{
+  node_t * p ;
+  int zdex ;
+/* count up the total number of levels from all fields */
+  for ( p = node ;  p != NULL ; p = p->next )
+  {
+    if ( p->node_kind == FOURD ) 
+    {
+      count_fields( p->members , d2 , d3 , corename , down_path ) ;  /* RECURSE */
+    }
+    else
+    {
+      if ( p->io_mask & down_path )
+      {
+        if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
+        {
+          if ( p->node_kind == FOURD )
+            zdex = get_index_for_coord( p->members , COORD_Z ) ;
+          else
+            zdex = get_index_for_coord( p , COORD_Z ) ;
+  
+          if ( zdex < 0 ) {
+            (*d2)++ ;   /* if no zdex then only 2 d */
+          } else {
+            (*d3)++ ;   /* if has a zdex then 3 d */
+          }
+        }
+      }
+    }
+  }
+  return(0) ;
+}
+
+/*****************/
+
+int
+gen_comms ( char * dirname )
+{
+  if ( sw_dm_parallel )
+    fprintf(stderr,"ADVISORY: RSL version of gen_comms is linked in with registry program.\n") ;
+
+  gen_halos( "inc" ) ;
+  gen_shift( "inc" ) ;
+  gen_periods( "inc" ) ;
+  gen_xposes( "inc" ) ;
+  gen_comm_descrips( "inc" ) ;
+  gen_datacalls( "inc" ) ;
+  gen_nest_packing( "inc" ) ;
+
+  return(0) ;
+}
+
diff --git a/wrfv2_fire/external/RSL/module_dm.F b/wrfv2_fire/external/RSL/module_dm.F
new file mode 100644
index 00000000..a323c6d1
--- /dev/null
+++ b/wrfv2_fire/external/RSL/module_dm.F
@@ -0,0 +1,4960 @@
+!WRF:PACKAGE:RSL 
+!
+MODULE module_dm
+
+   USE module_machine
+   USE module_configure
+   USE module_state_description
+   USE module_wrf_error
+
+#include "rsl.inc"
+
+   INTEGER msg_z, msg_x, msg_y
+   INTEGER msg,messages(168)
+   INTEGER invalid_message_value
+   INTEGER x_period_flag, y_period_flag
+   INTEGER msg_msg
+   INTEGER &
+      n5w5 ,n5w4 ,n5w3 ,n5w2 ,n5w ,n5 ,n5e ,n5e2 ,n5e3 ,n5e4 ,n5e5  &
+     ,n4w5 ,n4w4 ,n4w3 ,n4w2 ,n4w ,n4 ,n4e ,n4e2 ,n4e3 ,n4e4 ,n4e5  &
+     ,n3w5 ,n3w4 ,n3w3 ,n3w2 ,n3w ,n3 ,n3e ,n3e2 ,n3e3 ,n3e4 ,n3e5  &
+     ,n2w5 ,n2w4 ,n2w3 ,n2w2 ,n2w ,n2 ,n2e ,n2e2 ,n2e3 ,n2e4 ,n2e5  &
+     ,nw5  ,nw4  ,nw3  ,nw2  ,nw  ,n1 ,ne  ,ne2  ,ne3  ,ne4  ,ne5   &
+     ,w5   ,w4   ,w3   ,w2   ,w1      ,e1  ,e2   ,e3   ,e4   ,e5    &
+     ,sw5  ,sw4  ,sw3  ,sw2  ,sw  ,s1 ,se  ,se2  ,se3  ,se4  ,se5   &
+     ,s2w5 ,s2w4 ,s2w3 ,s2w2 ,s2w ,s2 ,s2e ,s2e2 ,s2e3 ,s2e4 ,s2e5  &
+     ,s3w5 ,s3w4 ,s3w3 ,s3w2 ,s3w ,s3 ,s3e ,s3e2 ,s3e3 ,s3e4 ,s3e5  &
+     ,s4w5 ,s4w4 ,s4w3 ,s4w2 ,s4w ,s4 ,s4e ,s4e2 ,s4e3 ,s4e4 ,s4e5  &
+     ,s5w5 ,s5w4 ,s5w3 ,s5w2 ,s5w ,s5 ,s5e ,s5e2 ,s5e3 ,s5e4 ,s5e5
+   INTEGER glen(3), llen(3), decomp(3), decompx(3), decompy(3), decompxy(3)
+   INTEGER glen2d(2), llen2d(2), decomp2d(2), decompx2d(2), decompy2d(2), decompxy2d(2)
+   INTEGER glenx(3), gleny(3), glenxy(3)
+   INTEGER llenx(3), lleny(3), llenxy(3)
+   INTEGER glenx2d(2), gleny2d(2), glenxy2d(2)
+   INTEGER llenx2d(2), lleny2d(2), llenxy2d(2)
+   INTEGER llen_tx(3)
+   INTEGER llen_ty(3)
+   INTEGER ips_save, jps_save
+   INTEGER ipe_save, jpe_save
+   INTEGER, PRIVATE :: mpi_comm_local
+   INTEGER, PRIVATE :: nproc_lt, nproc_ln
+
+#if ( RWORDSIZE != DWORDSIZE )
+   INTERFACE add_msg_period
+     MODULE PROCEDURE add_msg_period_real, add_msg_period_integer, add_msg_period_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_xpose
+     MODULE PROCEDURE add_msg_xpose_real, add_msg_xpose_integer, add_msg_xpose_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_4pt
+     MODULE PROCEDURE add_msg_4pt_real, add_msg_4pt_integer, add_msg_4pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_8pt
+     MODULE PROCEDURE add_msg_8pt_real, add_msg_8pt_integer, add_msg_8pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_12pt
+     MODULE PROCEDURE add_msg_12pt_real, add_msg_12pt_integer, add_msg_12pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_24pt
+     MODULE PROCEDURE add_msg_24pt_real, add_msg_24pt_integer, add_msg_24pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_48pt
+     MODULE PROCEDURE add_msg_48pt_real, add_msg_48pt_integer, add_msg_48pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_80pt
+     MODULE PROCEDURE add_msg_80pt_real, add_msg_80pt_integer, add_msg_80pt_doubleprecision
+   END INTERFACE
+   INTERFACE add_msg_120pt
+     MODULE PROCEDURE add_msg_120pt_real, add_msg_120pt_integer, add_msg_120pt_doubleprecision
+   END INTERFACE
+   INTERFACE wrf_dm_maxval
+     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
+   END INTERFACE
+   INTERFACE wrf_dm_minval
+     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
+   END INTERFACE
+
+#define TRUE_RSL_REAL     RSL_REAL
+#define TRUE_RSL_REAL_F90 RSL_REAL_F90
+#else
+   INTERFACE add_msg_period
+     MODULE PROCEDURE add_msg_period_real, add_msg_period_integer
+   END INTERFACE
+   INTERFACE add_msg_xpose
+     MODULE PROCEDURE add_msg_xpose_real, add_msg_xpose_integer
+   END INTERFACE
+   INTERFACE add_msg_4pt
+     MODULE PROCEDURE add_msg_4pt_real, add_msg_4pt_integer
+   END INTERFACE
+   INTERFACE add_msg_8pt
+     MODULE PROCEDURE add_msg_8pt_real, add_msg_8pt_integer
+   END INTERFACE
+   INTERFACE add_msg_12pt
+     MODULE PROCEDURE add_msg_12pt_real, add_msg_12pt_integer
+   END INTERFACE
+   INTERFACE add_msg_24pt
+     MODULE PROCEDURE add_msg_24pt_real, add_msg_24pt_integer
+   END INTERFACE
+   INTERFACE add_msg_48pt
+     MODULE PROCEDURE add_msg_48pt_real, add_msg_48pt_integer
+   END INTERFACE
+   INTERFACE add_msg_80pt
+     MODULE PROCEDURE add_msg_80pt_real, add_msg_80pt_integer
+   END INTERFACE
+   INTERFACE add_msg_120pt
+     MODULE PROCEDURE add_msg_120pt_real, add_msg_120pt_integer
+   END INTERFACE
+   INTERFACE wrf_dm_maxval
+     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
+   END INTERFACE
+   INTERFACE wrf_dm_minval
+     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer
+   END INTERFACE
+
+#define TRUE_RSL_REAL     RSL_DOUBLE
+#define TRUE_RSL_REAL_F90 RSL_DOUBLE_F90
+#endif
+
+CONTAINS
+
+   SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
+
+! 
+! This is a routine provided by the rsl external comm layer.
+! and is defined in external/RSL/module_dm.F, which is copied
+! into frame/module_dm.F at compile time.  Changes to frame/module_dm.F
+! will be lost.
+!
+! Given a total number of tasks, P, work out a two-dimensional mesh of
+! processors that is MINM processors in the M dimension and MINN
+! processors in the N dimension. The algorithm attempts to find two
+! numbers that divide the total number of processors without a remainder.
+! The best it might do, sometimes, is 1 and P. It attempts to divide
+! the M dimension over the smaller number.
+! 
+! The PROCMIN arguments are a holdover from MM5. The represent the
+! minimum number of processors the algorithm is allowed to use for M and
+! N. This is a holdover from MM5 which had static (compile-time) array
+! sizes ; PROCMIN_M and PROCMIN_N  should always be 1 in WRF.
+! 
+! 
+
+      INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
+      MINI = 2*P
+      MINM = 1
+      MINN = P
+      DO M = 1, P
+        IF ( MOD( P, M ) .EQ. 0 ) THEN
+          N = P / M
+          IF ( ABS(M-N) .LT. MINI                &
+               .AND. M .GE. PROCMIN_M            &
+               .AND. N .GE. PROCMIN_N            &
+             ) THEN
+            MINI = ABS(M-N)
+            MINM = M
+            MINN = N
+          ENDIF
+        ENDIF
+      ENDDO
+      IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
+        WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH.  STOPPING.'
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE(0,*)' PROCMIN_M ', PROCMIN_M
+        WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' P         ', P
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' MINM      ', MINM
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' MINN      ', MINN
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        CALL wrf_error_fatal ( 'module_dm: mpaspect' )
+      ENDIF
+   RETURN
+   END SUBROUTINE MPASPECT
+
+
+   SUBROUTINE wrf_dm_initialize
+! 
+! This is a routine provided by the RSL external comm layer.
+! and is defined in external/RSL/module_dm.F, which is copied
+! into frame/module_dm.F at compile time.  Changes to frame/module_dm.F
+! will be lost.
+!
+! This routine is used to complete initialization the rsl external comm
+! layer, once the namelist.input file has been read-in and broadcast to
+! all the tasks.  It must be called after the call to init_module_dm.
+! 
+! Wrf_dm_initialize calls RSL_SET_REGULAR_DECOMP to set up a regular
+! domain decompostion (subdomains will be rectangular) and then looks to
+! see if the namelist variables nproc_x and nproc_y have been set.  If
+! these have been set it uses these to map the MPI tasks to a
+! two-dimensional processor mesh.  Otherwise, it uses the mpaspect routine to compute the mesh.  The
+! dimensions of the mesh are then provided to rsl with call to RSL_MESH.
+! 
+! The WRF EM core uses the default pad area (the area of extra memory
+! that will be allocated around each local processor subdomain). The
+! default, defined in external/RSL/RSL/rsl.h, is 4. Other dycores, such
+! as NMM, may need a different size.  A non-default pad area is set in
+! rsl using a call to RSL_SET_PADAREA.
+! 
+! 
+      CALL RSL_SET_REGULAR_DECOMP
+      CALL nl_get_nproc_x ( 1, nproc_ln )
+      CALL nl_get_nproc_y ( 1, nproc_lt )
+! check if user has specified in the namelist
+      IF ( nproc_ln .GT. 0 .OR. nproc_lt .GT. 0 ) THEN
+        ! if only nproc_ln is specified then make it 1-d decomp in i
+        IF      ( nproc_ln .GT. 0 .AND. nproc_lt .EQ. -1 ) THEN
+          nproc_lt = rsl_nproc / nproc_ln
+        ! if only nproc_lt is specified then make it 1-d decomp in j
+        ELSE IF ( nproc_ln .EQ. -1 .AND. nproc_lt .GT. 0 ) THEN
+          nproc_ln = rsl_nproc / nproc_lt
+        ENDIF
+        ! make sure user knows what they're doing
+        IF ( nproc_ln * nproc_lt .NE. rsl_nproc ) THEN
+          WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL): nproc_x * nproc_y in namelist ne ',rsl_nproc
+          CALL wrf_error_fatal ( wrf_err_message )
+        ENDIF
+      ELSE
+        ! When neither is specified, work out mesh with MPASPECT
+        ! Pass nproc_ln and nproc_nt so that number of procs in 
+        ! i-dim (nproc_ln) is equal or lesser.
+        CALL mpaspect( rsl_nproc , nproc_ln , nproc_lt , 1 , 1 )
+      ENDIF
+       !                X          Y
+      CALL RSL_MESH( nproc_ln, nproc_lt )
+#ifdef NMM_CORE
+      CALL rsl_set_padarea ( 6 )
+#endif
+      CALL nl_set_nproc_x ( 1, nproc_ln )
+      CALL nl_set_nproc_y ( 1, nproc_lt )
+      invalid_message_value = RSL_INVALID
+      x_period_flag         = RSL_M
+      y_period_flag         = RSL_N
+      RETURN
+   END SUBROUTINE wrf_dm_initialize
+
+! period additions, 200505
+
+   SUBROUTINE reset_period
+      IMPLICIT NONE
+      CALL rsl_create_message ( msg )
+   END SUBROUTINE reset_period
+
+   SUBROUTINE add_msg_period_real( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(msg,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+   END SUBROUTINE add_msg_period_real
+
+   SUBROUTINE add_msg_period_integer( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(msg,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+   END SUBROUTINE add_msg_period_integer
+
+#if (  RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_period_doubleprecision( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(msg,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+   END SUBROUTINE add_msg_period_doubleprecision
+#endif
+
+! xpose additions, 20000302
+
+   SUBROUTINE reset_msgs_xpose
+      IMPLICIT NONE
+      CALL rsl_create_message ( msg_z )
+      CALL rsl_create_message ( msg_x )
+      CALL rsl_create_message ( msg_y )
+   END SUBROUTINE reset_msgs_xpose
+
+   SUBROUTINE add_msg_xpose_real( fld_z, fld_x, fld_y, dim )
+      IMPLICIT NONE
+      real fld_z(*), fld_x(*), fld_y(*)
+      integer dim
+      if (      dim == 3 ) then
+        CALL rsl_build_message(msg_z,TRUE_RSL_REAL_F90,fld_z,dim,decomp(1),glen(1),llen(1))
+        CALL rsl_build_message(msg_y,TRUE_RSL_REAL_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1))  ! msg_y->msg_x 20020908
+        CALL rsl_build_message(msg_x,TRUE_RSL_REAL_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1))  ! msg_x->msg_y 20020908
+      endif
+   END SUBROUTINE add_msg_xpose_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_xpose_doubleprecision( fld_z, fld_x, fld_y, dim )
+      IMPLICIT NONE
+      doubleprecision fld_z(*), fld_x(*), fld_y(*)
+      integer dim
+      if (      dim == 3 ) then
+        CALL rsl_build_message(msg_z,RSL_DOUBLE_F90,fld_z,dim,decomp(1),glen(1),llen(1))
+        CALL rsl_build_message(msg_y,RSL_DOUBLE_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1))  ! msg_y->msg_x 20020908
+        CALL rsl_build_message(msg_x,RSL_DOUBLE_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1))  ! msg_x->msg_y 20020908
+      endif
+   END SUBROUTINE add_msg_xpose_doubleprecision
+#endif
+
+
+   SUBROUTINE add_msg_xpose_integer ( fld_z, fld_x, fld_y, dim )
+      IMPLICIT NONE
+      integer fld_z(*), fld_x(*), fld_y(*)
+      integer dim
+      if (      dim == 3 ) then
+        CALL rsl_build_message(msg_z,RSL_INTEGER_F90,fld_z,dim,decomp(1),glen(1),llen(1))
+        CALL rsl_build_message(msg_y,RSL_INTEGER_F90,fld_x,dim,decomp(1),glen(1),llen_tx(1))  ! msg_y->msg_x 20020908
+        CALL rsl_build_message(msg_x,RSL_INTEGER_F90,fld_y,dim,decomp(1),glen(1),llen_ty(1))  ! msg_x->msg_y 20020908
+      endif
+   END SUBROUTINE add_msg_xpose_integer
+
+   SUBROUTINE define_xpose ( did, xp )
+      IMPLICIT NONE
+      INTEGER did , xp
+      CALL rsl_create_xpose ( xp )
+      CALL rsl_describe_xpose ( did , xp , msg_z , msg_x , msg_y )
+   END SUBROUTINE define_xpose
+
+! end xpose additions, 20000302
+
+!      n5w5 ,n5w4 ,n5w3 ,n5w2 ,n5w ,n5 ,n5e ,n5e2 ,n5e3 ,n5e4 ,n5e5  &
+!     ,n4w5 ,n4w4 ,n4w3 ,n4w2 ,n4w ,n4 ,n4e ,n4e2 ,n4e3 ,n4e4 ,n4e5  &
+!     ,n3w5 ,n3w4 ,n3w3 ,n3w2 ,n3w ,n3 ,n3e ,n3e2 ,n3e3 ,n3e4 ,n3e5  &
+!     ,n2w5 ,n2w4 ,n2w3 ,n2w2 ,n2w ,n2 ,n2e ,n2e2 ,n2e3 ,n2e4 ,n2e5  &
+!     ,nw5  ,nw4  ,nw3  ,nw2  ,nw  ,n1 ,ne  ,ne2  ,ne3  ,ne4  ,ne5   &
+!     ,w5   ,w4   ,w3   ,w2   ,w1      ,e1  ,e2   ,e3   ,e4   ,e5    &
+!     ,sw5  ,sw4  ,sw3  ,sw2  ,sw  ,s1 ,se  ,se2  ,se3  ,se4  ,se5   &
+!     ,s2w5 ,s2w4 ,s2w3 ,s2w2 ,s2w ,s2 ,s2e ,s2e2 ,s2e3 ,s2e4 ,s2e5  &
+!     ,s3w5 ,s3w4 ,s3w3 ,s3w2 ,s3w ,s3 ,s3e ,s3e2 ,s3e3 ,s3e4 ,s3e5  &
+!     ,s4w5 ,s4w4 ,s4w3 ,s4w2 ,s4w ,s4 ,s4e ,s4e2 ,s4e3 ,s4e4 ,s4e5  &
+!     ,s5w5 ,s5w4 ,s5w3 ,s5w2 ,s5w ,s5 ,s5e ,s5e2 ,s5e3 ,s5e4 ,s5e5
+
+   SUBROUTINE reset_msgs_120pt
+      CALL reset_msgs_80pt
+#if 0
+      CALL rsl_create_message(n5w5)
+      CALL rsl_create_message(n5w4)
+      CALL rsl_create_message(n5w3)
+      CALL rsl_create_message(n5w2)
+      CALL rsl_create_message(n5w )
+      CALL rsl_create_message(n5)
+      CALL rsl_create_message(n5e )
+      CALL rsl_create_message(n5e2)
+      CALL rsl_create_message(n5e3)
+      CALL rsl_create_message(n5e4)
+      CALL rsl_create_message(n5e5)
+      CALL rsl_create_message(n4w5)
+      CALL rsl_create_message(n3w5)
+      CALL rsl_create_message(n2w5)
+      CALL rsl_create_message(nw5)
+      CALL rsl_create_message(w5)
+      CALL rsl_create_message(sw5)
+      CALL rsl_create_message(s2w5)
+      CALL rsl_create_message(s3w5)
+      CALL rsl_create_message(s4w5)
+      CALL rsl_create_message(n4e5)
+      CALL rsl_create_message(n3e5)
+      CALL rsl_create_message(n2e5)
+      CALL rsl_create_message(ne5)
+      CALL rsl_create_message(e5)
+      CALL rsl_create_message(se5)
+      CALL rsl_create_message(s2e5)
+      CALL rsl_create_message(s3e5)
+      CALL rsl_create_message(s4e5)
+      CALL rsl_create_message(s5w5)
+      CALL rsl_create_message(s5w4)
+      CALL rsl_create_message(s5w3)
+      CALL rsl_create_message(s5w2)
+      CALL rsl_create_message(s5w )
+      CALL rsl_create_message(s5)
+      CALL rsl_create_message(s5e )
+      CALL rsl_create_message(s5e2)
+      CALL rsl_create_message(s5e3)
+      CALL rsl_create_message(s5e4)
+      CALL rsl_create_message(s5e5)
+#endif
+   END SUBROUTINE reset_msgs_120pt
+
+   SUBROUTINE reset_msgs_80pt
+#if 1
+      CALL rsl_create_message(msg_msg)
+#else
+      CALL reset_msgs_48pt
+      CALL rsl_create_message(n4w4)
+      CALL rsl_create_message(n4w3)
+      CALL rsl_create_message(n4w2)
+      CALL rsl_create_message(n4w )
+      CALL rsl_create_message(n4)
+      CALL rsl_create_message(n4e )
+      CALL rsl_create_message(n4e2)
+      CALL rsl_create_message(n4e3)
+      CALL rsl_create_message(n4e4)
+      CALL rsl_create_message(n3w4)
+      CALL rsl_create_message(n2w4)
+      CALL rsl_create_message(nw4)
+      CALL rsl_create_message(w4)
+      CALL rsl_create_message(sw4)
+      CALL rsl_create_message(s2w4)
+      CALL rsl_create_message(s3w4)
+      CALL rsl_create_message(n3e4)
+      CALL rsl_create_message(n2e4)
+      CALL rsl_create_message(ne4)
+      CALL rsl_create_message(e4)
+      CALL rsl_create_message(se4)
+      CALL rsl_create_message(s2e4)
+      CALL rsl_create_message(s3e4)
+      CALL rsl_create_message(s4w4)
+      CALL rsl_create_message(s4w3)
+      CALL rsl_create_message(s4w2)
+      CALL rsl_create_message(s4w )
+      CALL rsl_create_message(s4)
+      CALL rsl_create_message(s4e )
+      CALL rsl_create_message(s4e2)
+      CALL rsl_create_message(s4e3)
+      CALL rsl_create_message(s4e4)
+#endif
+   END SUBROUTINE reset_msgs_80pt
+
+   SUBROUTINE reset_msgs_48pt
+      CALL reset_msgs_24pt
+      CALL rsl_create_message(n3w3)
+      CALL rsl_create_message(n3w2)
+      CALL rsl_create_message(n3w )
+      CALL rsl_create_message(n3)
+      CALL rsl_create_message(n3e )
+      CALL rsl_create_message(n3e2)
+      CALL rsl_create_message(n3e3)
+      CALL rsl_create_message(n2w3)
+      CALL rsl_create_message(n2e3)
+      CALL rsl_create_message(nw3)
+      CALL rsl_create_message(ne3)
+      CALL rsl_create_message(w3)
+      CALL rsl_create_message(e3)
+      CALL rsl_create_message(sw3)
+      CALL rsl_create_message(se3)
+      CALL rsl_create_message(s2w3)
+      CALL rsl_create_message(s2e3)
+      CALL rsl_create_message(s3w3)
+      CALL rsl_create_message(s3w2)
+      CALL rsl_create_message(s3w )
+      CALL rsl_create_message(s3)
+      CALL rsl_create_message(s3e )
+      CALL rsl_create_message(s3e2)
+      CALL rsl_create_message(s3e3)
+      RETURN
+   END SUBROUTINE reset_msgs_48pt
+
+   SUBROUTINE reset_msgs_24pt
+      CALL reset_msgs_12pt
+      CALL rsl_create_message(n2w2)
+      CALL rsl_create_message(n2w)
+      CALL rsl_create_message(n2e)
+      CALL rsl_create_message(n2e2)
+      CALL rsl_create_message(nw2)
+      CALL rsl_create_message(ne2)
+      CALL rsl_create_message(sw2)
+      CALL rsl_create_message(se2)
+      CALL rsl_create_message(s2w2)
+      CALL rsl_create_message(s2w)
+      CALL rsl_create_message(s2e)
+      CALL rsl_create_message(s2e2)
+      RETURN
+   END SUBROUTINE reset_msgs_24pt
+
+   SUBROUTINE reset_msgs_12pt
+      CALL reset_msgs_8pt
+      call rsl_create_message(n2)
+      call rsl_create_message(w2)
+      call rsl_create_message(e2)
+      call rsl_create_message(s2)
+      RETURN
+   END SUBROUTINE reset_msgs_12pt
+
+   SUBROUTINE reset_msgs_8pt
+      call reset_msgs_4pt
+      call rsl_create_message(ne)
+      call rsl_create_message(nw)
+      call rsl_create_message(se)
+      call rsl_create_message(sw)
+      RETURN
+   END SUBROUTINE reset_msgs_8pt
+
+   SUBROUTINE reset_msgs_4pt
+      call rsl_create_message(n1)
+      call rsl_create_message(w1)
+      call rsl_create_message(e1)
+      call rsl_create_message(s1)
+      RETURN
+   END SUBROUTINE reset_msgs_4pt
+
+   SUBROUTINE reset_msgs_y_shift
+      call rsl_create_message(s5)
+      call rsl_create_message(s4)
+      call rsl_create_message(s3)
+      call rsl_create_message(s2)
+      call rsl_create_message(s1)
+      call rsl_create_message(n1)
+      call rsl_create_message(n2)
+      call rsl_create_message(n3)
+      call rsl_create_message(n4)
+      call rsl_create_message(n5)
+      RETURN
+   END SUBROUTINE reset_msgs_y_shift
+
+   SUBROUTINE reset_msgs_x_shift
+      call rsl_create_message(w5)
+      call rsl_create_message(w4)
+      call rsl_create_message(w3)
+      call rsl_create_message(w2)
+      call rsl_create_message(w1)
+      call rsl_create_message(e1)
+      call rsl_create_message(e2)
+      call rsl_create_message(e3)
+      call rsl_create_message(e4)
+      call rsl_create_message(e5)
+      RETURN
+   END SUBROUTINE reset_msgs_x_shift
+
+   SUBROUTINE add_msg_x_shift_real ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_x_shift_real
+   SUBROUTINE add_msg_y_shift_real ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(s5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n4,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n5,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(s5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n4,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n5,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_y_shift_real
+
+   SUBROUTINE add_msg_x_shift_integer ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_x_shift_integer
+   SUBROUTINE add_msg_y_shift_integer ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(s5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n4,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n5,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(s5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n4,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n5,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_y_shift_integer
+
+   SUBROUTINE add_msg_x_shift_doubleprecision ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_x_shift_doubleprecision
+   SUBROUTINE add_msg_y_shift_doubleprecision ( fld, kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(s5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n4,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n5,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(s5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n4,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n5,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_y_shift_doubleprecision
+
+   SUBROUTINE add_msg_4pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim   
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_4pt_real
+
+#if (  RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_4pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_4pt_doubleprecision
+#endif
+
+
+   SUBROUTINE add_msg_4pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim   
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim  > 1 ) then
+        CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n1,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_4pt_integer
+
+   SUBROUTINE add_msg_8pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim   
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_4pt ( fld , kdim )
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(nw,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(nw,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_8pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_8pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_4pt ( fld , kdim )
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(nw,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(nw,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_8pt_doubleprecision
+#endif
+
+
+   SUBROUTINE add_msg_8pt_integer( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim  
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_4pt ( fld , kdim )
+      if (      kdim >  1 ) then
+        CALL rsl_build_message(nw,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(nw,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_8pt_integer
+
+   SUBROUTINE add_msg_12pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_12pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_12pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_12pt_doubleprecision
+#endif
+
+
+   SUBROUTINE add_msg_12pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_12pt_integer
+
+   SUBROUTINE add_msg_24pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n2w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n2w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_24pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_24pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n2w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n2w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_24pt_doubleprecision
+#endif
+
+
+   SUBROUTINE add_msg_24pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_8pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n2w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n2w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_24pt_integer
+
+   SUBROUTINE add_msg_48pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_24pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n3w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e2,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e3,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n3w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e2,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e3,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_48pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_48pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_24pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n3w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e2,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e3,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n3w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e2,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e3,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_48pt_doubleprecision
+#endif
+
+   SUBROUTINE add_msg_48pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      CALL add_msg_24pt ( fld , kdim )
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(n3w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n3e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(n2e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(nw3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(ne3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(sw3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(se3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s2e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3w,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e2,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+        CALL rsl_build_message(s3e3,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(n3w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n3e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(n2e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(nw3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(ne3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(sw3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(se3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s2e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3w,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e2,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+        CALL rsl_build_message(s3e3,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_48pt_integer
+
+
+   SUBROUTINE add_msg_80pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(msg_msg,TRUE_RSL_REAL_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg_msg,TRUE_RSL_REAL_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_80pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_80pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim   
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(msg_msg,RSL_DOUBLE_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg_msg,RSL_DOUBLE_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_80pt_doubleprecision 
+#endif
+
+   SUBROUTINE add_msg_80pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = kdim    ; ll(2) = kdim
+           gl(3) = glen(3) ; ll(3) = llen(3)
+         CASE ( DATA_ORDER_XYZ )
+           gl(1) = glen(1) ; ll(1) = llen(1)
+           gl(2) = glen(2) ; ll(2) = llen(2)
+           gl(3) = kdim    ; ll(3) = kdim
+         CASE DEFAULT
+      END SELECT
+      if      ( kdim >  1 ) then
+        CALL rsl_build_message(msg_msg,RSL_INTEGER_F90,fld,3,decomp(1),gl(1),ll(1))
+      else if ( kdim == 1 ) then
+        CALL rsl_build_message(msg_msg,RSL_INTEGER_F90,fld,2,decomp2d(1),glen2d(1),llen2d(1))
+      endif
+      RETURN
+   END SUBROUTINE add_msg_80pt_integer
+
+   SUBROUTINE add_msg_120pt_real ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      real fld(*)
+      CALL add_msg_80pt ( fld , kdim )
+      RETURN
+   END SUBROUTINE add_msg_120pt_real
+
+#if ( RWORDSIZE != DWORDSIZE )
+   SUBROUTINE add_msg_120pt_doubleprecision ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      doubleprecision fld(*)
+      CALL add_msg_80pt ( fld , kdim )
+      RETURN
+   END SUBROUTINE add_msg_120pt_doubleprecision
+#endif
+
+   SUBROUTINE add_msg_120pt_integer ( fld , kdim )
+      IMPLICIT NONE
+      integer kdim, gl(3), ll(3)
+      integer fld(*)
+      CALL add_msg_80pt ( fld , kdim )
+      RETURN
+   END SUBROUTINE add_msg_120pt_integer
+
+   SUBROUTINE stencil_y_shift ( did , stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid
+      INTEGER i
+      DO i = 1, 48
+        messages(i) = n1
+      ENDDO
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
+      RETURN
+   END SUBROUTINE stencil_y_shift
+
+   SUBROUTINE stencil_x_shift ( did , stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid
+      INTEGER i
+      DO i = 1, 48
+        messages(i) = w1
+      ENDDO
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
+      RETURN
+   END SUBROUTINE stencil_x_shift
+
+   SUBROUTINE stencil_4pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid
+      messages(1) =          n1
+      messages(2) =   w1
+      messages(3) =                 e1
+      messages(4) =          s1
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_4PT, messages )
+      RETURN
+   END SUBROUTINE stencil_4pt
+
+   SUBROUTINE stencil_8pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid
+      messages(1) =   nw
+      messages(2) =          n1
+      messages(3) =                 ne
+      messages(4) =   w1
+      messages(5) =                 e1
+      messages(6) =   sw
+      messages(7) =          s1
+      messages(8) =                 se
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_8PT, messages )
+      RETURN
+   END SUBROUTINE stencil_8pt
+
+   SUBROUTINE stencil_12pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid
+      messages(1)  =                 n2
+      messages(2)  =          nw
+      messages(3)  =                 n1
+      messages(4)  =                           ne
+      messages(5)  =  w2
+      messages(6)  =          w1                  
+      messages(7)  =                           e1
+      messages(8)  =                                    e2
+      messages(9)  =          sw
+      messages(10) =                 s1
+      messages(11) =                           se
+      messages(12) =                 s2
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_12PT, messages )
+      RETURN
+   END SUBROUTINE stencil_12pt
+
+   SUBROUTINE stencil_24pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid, i
+      messages( 1) = n2w2
+      messages( 2) = n2w
+      messages( 3) = n2
+      messages( 4) = n2e
+      messages( 5) = n2e2
+      messages( 6) = nw2
+      messages( 7) = nw
+      messages( 8) = n1
+      messages( 9) = ne
+      messages(10) = ne2
+      messages(11) = w2
+      messages(12) = w1
+      messages(13) = e1
+      messages(14) = e2
+      messages(15) = sw2
+      messages(16) = sw
+      messages(17) = s1
+      messages(18) = se
+      messages(19) = se2
+      messages(20) = s2w2
+      messages(21) = s2w
+      messages(22) = s2
+      messages(23) = s2e
+      messages(24) = s2e2
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_24PT, messages )
+      RETURN
+   END SUBROUTINE stencil_24pt
+
+   SUBROUTINE stencil_48pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid, i
+      messages( 1) = n3w3
+      messages( 2) = n3w2
+      messages( 3) = n3w
+      messages( 4) = n3
+      messages( 5) = n3e
+      messages( 6) = n3e2
+      messages( 7) = n3e3
+      messages( 8) = n2w3
+      messages( 9) = n2w2
+      messages(10) = n2w
+      messages(11) = n2
+      messages(12) = n2e
+      messages(13) = n2e2
+      messages(14) = n2e3
+      messages(15) = nw3
+      messages(16) = nw2
+      messages(17) = nw
+      messages(18) = n1
+      messages(19) = ne
+      messages(20) = ne2
+      messages(21) = ne3
+      messages(22) = w3
+      messages(23) = w2
+      messages(24) = w1
+      messages(25) = e1
+      messages(26) = e2
+      messages(27) = e3
+      messages(28) = sw3
+      messages(29) = sw2
+      messages(30) = sw
+      messages(31) = s1
+      messages(32) = se
+      messages(33) = se2
+      messages(34) = se3
+      messages(35) = s2w3
+      messages(36) = s2w2
+      messages(37) = s2w
+      messages(38) = s2
+      messages(39) = s2e
+      messages(40) = s2e2
+      messages(41) = s2e3
+      messages(42) = s3w3
+      messages(43) = s3w2
+      messages(44) = s3w
+      messages(45) = s3
+      messages(46) = s3e
+      messages(47) = s3e2
+      messages(48) = s3e3
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_48PT, messages )
+      RETURN
+   END SUBROUTINE stencil_48pt
+
+   SUBROUTINE stencil_80pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid, i
+#if 1
+      do i = 1, 80
+         messages(i) = msg_msg
+      enddo
+#else
+messages(1)=    n4w4
+messages(2)=    n4w3
+messages(3)=    n4w2
+messages(4)=    n4w
+messages(5)=    n4
+messages(6)=    n4e
+messages(7)=    n4e2
+messages(8)=    n4e3
+messages(9)=    n4e4
+messages(10)=   n3w4
+messages(11)=   n3w3
+messages(12)=   n3w2
+messages(13)=   n3w
+messages(14)=   n3
+messages(15)=   n3e
+messages(16)=   n3e2
+messages(17)=   n3e3
+messages(18)=   n3e4
+messages(19)=   n2w4
+messages(20)=   n2w3
+messages(21)=   n2w2
+messages(22)=   n2w
+messages(23)=   n2
+messages(24)=   n2e
+messages(25)=   n2e2
+messages(26)=   n2e3
+messages(27)=   n2e4
+messages(28)=   nw4
+messages(29)=   nw3
+messages(30)=   nw2
+messages(31)=   nw
+messages(32)=   n1
+messages(33)=   ne
+messages(34)=   ne2
+messages(35)=   ne3
+messages(36)=   ne4
+messages(37)=   w4
+messages(38)=   w3
+messages(39)=   w2
+messages(40)=   w1
+messages(41)=   e1
+messages(42)=   e2
+messages(43)=   e3
+messages(44)=   e4
+messages(45)=   sw4
+messages(46)=   sw3
+messages(47)=   sw2
+messages(48)=   sw
+messages(49)=   s1
+messages(50)=   se
+messages(51)=   se2
+messages(52)=   se3
+messages(53)=   se4
+messages(54)=   s2w4
+messages(55)=   s2w3
+messages(56)=   s2w2
+messages(57)=   s2w
+messages(58)=   s2
+messages(59)=   s2e
+messages(60)=   s2e2
+messages(61)=   s2e3
+messages(62)=   s2e4
+messages(63)=   s3w4
+messages(64)=   s3w3
+messages(65)=   s3w2
+messages(66)=   s3w
+messages(67)=   s3
+messages(68)=   s3e
+messages(69)=   s3e2
+messages(70)=   s3e3
+messages(71)=   s3e4
+messages(72)=   s4w4
+messages(73)=   s4w3
+messages(74)=   s4w2
+messages(75)=   s4w
+messages(76)=   s4
+messages(77)=   s4e
+messages(78)=   s4e2
+messages(79)=   s4e3
+messages(80)=   s4e4
+#endif
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_80PT, messages )
+      RETURN
+   END SUBROUTINE stencil_80pt
+
+   SUBROUTINE stencil_120pt ( did, stenid )
+      IMPLICIT NONE
+      INTEGER did, stenid, i
+#if 1
+      do i = 1, 120
+         messages(i) = msg_msg
+      enddo
+#else
+messages(1)=    n5w5
+messages(2)=    n5w4
+messages(3)=    n5w3
+messages(4)=    n5w2
+messages(5)=    n5w
+messages(6)=    n5
+messages(7)=    n5e
+messages(8)=    n5e2
+messages(9)=    n5e3
+messages(10)=   n5e4
+messages(11)=   n5e5
+messages(12)=   n4w5
+messages(13)=   n4w4
+messages(14)=   n4w3
+messages(15)=   n4w2
+messages(16)=   n4w
+messages(17)=   n4
+messages(18)=   n4e
+messages(19)=   n4e2
+messages(20)=   n4e3
+messages(21)=   n4e4
+messages(22)=   n4e5
+messages(23)=   n3w5
+messages(24)=   n3w4
+messages(25)=   n3w3
+messages(26)=   n3w2
+messages(27)=   n3w
+messages(28)=   n3
+messages(29)=   n3e
+messages(30)=   n3e2
+messages(31)=   n3e3
+messages(32)=   n3e4
+messages(33)=   n3e5
+messages(34)=   n2w5
+messages(35)=   n2w4
+messages(36)=   n2w3
+messages(37)=   n2w2
+messages(38)=   n2w
+messages(39)=   n2
+messages(40)=   n2e
+messages(41)=   n2e2
+messages(42)=   n2e3
+messages(43)=   n2e4
+messages(44)=   n2e5
+messages(45)=   nw5
+messages(46)=   nw4
+messages(47)=   nw3
+messages(48)=   nw2
+messages(49)=   nw
+messages(50)=   n1
+messages(51)=   ne
+messages(52)=   ne2
+messages(53)=   ne3
+messages(54)=   ne4
+messages(55)=   ne5
+messages(56)=   w5
+messages(57)=   w4
+messages(58)=   w3
+messages(59)=   w2
+messages(60)=   w1
+messages(61)=   e1
+messages(62)=   e2
+messages(63)=   e3
+messages(64)=   e4
+messages(65)=   e5
+messages(66)=   sw5
+messages(67)=   sw4
+messages(68)=   sw3
+messages(69)=   sw2
+messages(70)=   sw
+messages(71)=   s1
+messages(72)=   se
+messages(73)=   se2
+messages(74)=   se3
+messages(75)=   se4
+messages(76)=   se5
+messages(77)=   s2w5
+messages(78)=   s2w4
+messages(79)=   s2w3
+messages(80)=   s2w2
+messages(81)=   s2w
+messages(82)=   s2
+messages(83)=   s2e
+messages(84)=   s2e2
+messages(85)=   s2e3
+messages(86)=   s2e4
+messages(87)=   s2e5
+messages(88)=   s3w5
+messages(89)=   s3w4
+messages(90)=   s3w3
+messages(91)=   s3w2
+messages(92)=   s3w
+messages(93)=   s3
+messages(94)=   s3e
+messages(95)=   s3e2
+messages(96)=   s3e3
+messages(97)=   s3e4
+messages(98)=   s3e5
+messages(99)=   s4w5
+messages(100)=  s4w4
+messages(101)=  s4w3
+messages(102)=  s4w2
+messages(103)=  s4w
+messages(104)=  s4
+messages(105)=  s4e
+messages(106)=  s4e2
+messages(107)=  s4e3
+messages(108)=  s4e4
+messages(109)=  s4e5
+messages(110)=  s5w5
+messages(111)=  s5w4
+messages(112)=  s5w3
+messages(113)=  s5w2
+messages(114)=  s5w
+messages(115)=  s5
+messages(116)=  s5e
+messages(117)=  s5e2
+messages(118)=  s5e3
+messages(119)=  s5e4
+messages(120)=  s5e5
+#endif
+      CALL rsl_create_stencil( stenid )
+      CALL rsl_describe_stencil ( did, stenid, RSL_120PT, messages )
+      RETURN
+   END SUBROUTINE stencil_120pt
+
+   SUBROUTINE period_def ( did, perid, w )
+      IMPLICIT NONE
+      INTEGER did, perid, w
+      CALL rsl_create_period( perid )
+      CALL rsl_describe_period ( did, perid, w, msg )
+      RETURN
+   END SUBROUTINE period_def
+
+   SUBROUTINE setup_halo_rsl( grid )
+       USE module_domain
+       IMPLICIT NONE
+       TYPE(domain) , INTENT (INOUT) :: grid 
+      INTEGER i, kms, ims, jms
+   ! executable
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_ZXY )
+            kms = grid%sm31
+            ims = grid%sm32
+            jms = grid%sm33
+            decomp(1) = RSL_NOTDECOMPOSED
+            decomp(2) = RSL_M
+            decomp(3) = RSL_N
+            decomp2d(1) = RSL_M
+            decomp2d(2) = RSL_N
+            glen2d(1) = grid%ed32 - grid%sd32 + 1
+            glen2d(2) = grid%ed33 - grid%sd33 + 1
+            llen2d(1) = grid%em32 - grid%sm32 + 1
+            llen2d(2) = grid%em33 - grid%sm33 + 1
+         CASE ( DATA_ORDER_XYZ )
+            kms = grid%sm33
+            ims = grid%sm31
+            jms = grid%sm32
+            decomp(1) = RSL_M
+            decomp(2) = RSL_N
+            decomp(3) = RSL_NOTDECOMPOSED
+            decomp2d(1) = RSL_M
+            decomp2d(2) = RSL_N
+            glen2d(1) = grid%ed31 - grid%sd31 + 1
+            glen2d(2) = grid%ed32 - grid%sd32 + 1
+            llen2d(1) = grid%em31 - grid%sm31 + 1
+            llen2d(2) = grid%em32 - grid%sm32 + 1
+         CASE ( DATA_ORDER_XZY )
+            kms = grid%sm32
+            ims = grid%sm31
+            jms = grid%sm33
+            decomp(1) = RSL_M
+            decomp(2) = RSL_NOTDECOMPOSED
+            decomp(3) = RSL_N
+            decomp2d(1) = RSL_M
+            decomp2d(2) = RSL_N
+            glen2d(1) = grid%ed31 - grid%sd31 + 1
+            glen2d(2) = grid%ed33 - grid%sd33 + 1
+            llen2d(1) = grid%em31 - grid%sm31 + 1
+            llen2d(2) = grid%em33 - grid%sm33 + 1
+         CASE ( DATA_ORDER_YXZ )
+            kms = grid%sm33
+            ims = grid%sm32
+            jms = grid%sm31
+            decomp(1) = RSL_N
+            decomp(2) = RSL_M
+            decomp(3) = RSL_NOTDECOMPOSED
+            decomp2d(1) = RSL_N
+            decomp2d(2) = RSL_M
+            glen2d(1) = grid%ed32 - grid%sd32 + 1
+            glen2d(2) = grid%ed31 - grid%sd31 + 1
+            llen2d(1) = grid%em32 - grid%sm32 + 1
+            llen2d(2) = grid%em31 - grid%sm31 + 1
+      END SELECT
+
+      glen(1)   = grid%ed31 - grid%sd31 + 1
+      glen(2)   = grid%ed32 - grid%sd32 + 1
+      glen(3)   = grid%ed33 - grid%sd33 + 1
+      llen(1)   = grid%em31 - grid%sm31 + 1
+      llen(2)   = grid%em32 - grid%sm32 + 1
+      llen(3)   = grid%em33 - grid%sm33 + 1
+
+   END SUBROUTINE setup_halo_rsl
+
+
+   SUBROUTINE setup_xpose_rsl( grid )
+       USE module_domain
+       IMPLICIT NONE
+       TYPE(domain) , INTENT (INOUT) :: grid 
+      INTEGER i, kms, ims, jms
+
+      CALL setup_halo_rsl ( grid )
+
+      llen_tx(1) = grid%em31x - grid%sm31x + 1
+      llen_tx(2) = grid%em32x - grid%sm32x + 1
+      llen_tx(3) = grid%em33x - grid%sm33x + 1
+      llen_ty(1) = grid%em31y - grid%sm31y + 1
+      llen_ty(2) = grid%em32y - grid%sm32y + 1
+      llen_ty(3) = grid%em33y - grid%sm33y + 1
+
+   END SUBROUTINE setup_xpose_rsl
+
+   SUBROUTINE setup_period_rsl( grid )
+       USE module_domain
+       IMPLICIT NONE
+       TYPE(domain) , INTENT (INOUT) :: grid 
+      INTEGER i, kms, ims, jms
+
+      CALL setup_xpose_rsl ( grid )
+
+   ! Define periodic BC's -- for the period routines, the glen
+   ! array contains the actual logical size of the field (that is,
+   ! staggering is explicitly stated).  Llen is not affected.
+
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_XZY )
+
+      glen(1)    = grid%ed31 - grid%sd31
+      glen(2)    = grid%ed32 - grid%sd32 + 1
+      glen(3)    = grid%ed33 - grid%sd33
+      glenx(1)   = glen(1)
+      glenx(2)   = glen(2)
+      glenx(3)   = glen(3)
+      gleny(1)   = glen(1)
+      gleny(2)   = glen(2)
+      gleny(3)   = glen(3)
+      glenxy(1)   = glen(1)
+      glenxy(2)   = glen(2)
+      glenxy(3)   = glen(3)
+      llenx(1)   = llen(1)
+      llenx(2)   = llen(2)
+      llenx(3)   = llen(3)
+      lleny(1)   = llen(1)
+      lleny(2)   = llen(2)
+      lleny(3)   = llen(3)
+      llenxy(1)   = llen(1)
+      llenxy(2)   = llen(2)
+      llenxy(3)   = llen(3)
+
+      glen2d(1)    = grid%ed31 - grid%sd31
+      glen2d(2)    = grid%ed33 - grid%sd33
+      glenx2d(1)   = glen2d(1)
+      glenx2d(2)   = glen2d(2)
+      gleny2d(1)   = glen2d(1)
+      gleny2d(2)   = glen2d(2)
+      glenxy2d(1)  = glen2d(1)
+      glenxy2d(2)  = glen2d(2)
+      llenx2d(1)   = llen2d(1)
+      llenx2d(2)   = llen2d(2)
+      lleny2d(1)   = llen2d(1)
+      lleny2d(2)   = llen2d(2)
+      llenxy2d(1)   = llen2d(1)
+      llenxy2d(2)   = llen2d(2)
+
+      decompx(1)   = RSL_M_STAG
+      decompx(2)   = RSL_NOTDECOMPOSED
+      decompx(3)   = RSL_N
+      decompy(1)   = RSL_M
+      decompy(2)   = RSL_NOTDECOMPOSED
+      decompy(3)   = RSL_N_STAG
+      decompxy(1)  = RSL_M_STAG
+      decompxy(2)  = RSL_NOTDECOMPOSED
+      decompxy(3)  = RSL_N_STAG
+
+      decomp2d(1)  = RSL_M
+      decomp2d(2)  = RSL_N
+
+      decompx2d(1)  = RSL_M_STAG
+      decompx2d(2)  = RSL_N
+
+      decompy2d(1)  = RSL_M
+      decompy2d(2)  = RSL_N_STAG
+
+      decompxy2d(1)  = RSL_M_STAG
+      decompxy2d(2)  = RSL_N_STAG
+
+         CASE DEFAULT
+            CALL wrf_error_fatal ( "module_dm: setup_period_rsl: unsuppported data order" )
+
+      END SELECT
+
+      RETURN
+   END SUBROUTINE setup_period_rsl
+
+!------------------------------------------------------------------
+   INTEGER FUNCTION intermediate_mapping ( w1, w2, info, m, n, py, px )
+      IMPLICIT NONE
+      INTEGER, DIMENSION(*)   :: w1, w2
+      REAL, DIMENSION(*)      :: info
+      INTEGER, INTENT(IN)     :: m, n, py, px
+      INTEGER                 :: nest_m, nest_n, nri, nrj, nest_domdesc, shw
+! 
+! This is a routine provided by the rsl external comm layer.
+! and is defined in external/RSL/module_dm.F, which is copied
+! into frame/module_dm.F at compile time.  Changes to frame/module_dm.F
+! will be lost.
+! 
+! This routine is related to nesting and is used by the rsl domain
+! decomposition algorithm to decompose an domain that serves as an
+! intermediary between the parent domain and the nest. This intermediate
+! domain is at the coarse domain's resolution but it is only large enough
+! to cover the region of the nested domain plus an extra number of cells
+! out onto the coarse domain around the region of the nest (this number
+! is specified by the namelist variable shw, default 2). The intermediate
+! domain is decomposed using the nested domain's decomposition
+! information so that all interpolations from coarse domain data to the
+! nest may be done locally on the processor without communication.  (The
+! communication occurs during the transfer of data between the parent
+! domain and the intermediate domain.  See interp_domain_em_part1, interp_domain_em_part2, force_domain_em_part2, feedback_domain_em_part1, and feedback_domain_em_part2.)
+! 
+! This routine and it's companion intermediate_mapping2 call the rsl
+! routine GET_DOMAIN_DECOMP passing it the rsl domain descriptor for the
+! nest to retrieve from rsl the nested decomposition.  This information
+! is then used to decomposed the intermediate domain.
+! 
+! Rsl is given the intermediate_mapping function to use when decomposing
+! the intermediate domain with a call to:
+! 
+!   CALL set_def_decomp_fcn1 ( intermediate_domdesc, intermediate_mapping )
+! 
+! inside the routine patch_domain_rsl
+! that is also defined in external/RSL/module_dm.F.
+!
+! 
+
+      nest_m = int(info(1)+.01) ; nest_n = int(info(2)+.01) ; nest_domdesc = int(info(3)+.01)
+      nri = int(info(4)+.01)    ; nrj    = int(info(5)+.01)
+      shw = int(info(6)+.01)
+      CALL  intermediate_mapping2 ( w1, w2, info, m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw )
+      intermediate_mapping = 0
+      RETURN
+   END FUNCTION intermediate_mapping
+
+   SUBROUTINE intermediate_mapping2 ( w1, w2, info, m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw )
+      IMPLICIT NONE
+      INTEGER, DIMENSION(*)   :: w1, w2
+      REAL, DIMENSION(*)      :: info
+      INTEGER, INTENT(IN)     :: m, n, nest_m, nest_n, nest_domdesc, py, px, nri, nrj, shw
+      INTEGER                 :: nest_decomp( nest_m, nest_n )
+      INTEGER                 :: i, j
+! 
+! See intermediate_mapping.
+! 
+
+
+      CALL GET_DOMAIN_DECOMP ( nest_domdesc, nest_decomp, nest_m*nest_n )
+      DO j = 1, nest_n, nrj
+        DO i = 1, nest_m, nri
+          w2((i/nri+1+shw) + (j/nrj+1-1+shw)*m) = nest_decomp(i,j)
+        ENDDO
+      ENDDO
+#if 1
+      ! fill out the stencil to the edges of the intermediate domain
+      do j = 1,n
+        do i = 1,shw
+          w2(i+(j-1)*m) = w2(shw+1+(j-1)*m)
+        enddo
+        do i = m,m-shw-1,-1
+          w2(i+(j-1)*m) = w2(m-shw-2+(j-1)*m)
+        enddo
+      enddo
+      do i = 1,m
+        do j = 1,shw
+          w2(i+(j-1)*m) = w2(i+(shw+1-1)*m)
+        enddo
+        do j = n,n-shw-1,-1
+          w2(i+(j-1)*m) = w2(i+(n-shw-2-1)*m)
+        enddo
+      enddo
+#endif
+
+      RETURN
+   END SUBROUTINE intermediate_mapping2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE patch_domain_rsl( id  , domdesc , parent, parent_id , parent_domdesc , &
+                                sd1 , ed1 , sp1 , ep1 , sm1 , em1 ,        &
+                                sd2 , ed2 , sp2 , ep2 , sm2 , em2 ,        &
+                                sd3 , ed3 , sp3 , ep3 , sm3 , em3 ,        &
+                                            sp1x , ep1x , sm1x , em1x ,        &
+                                            sp2x , ep2x , sm2x , em2x ,        &
+                                            sp3x , ep3x , sm3x , em3x ,        &
+                                            sp1y , ep1y , sm1y , em1y ,        &
+                                            sp2y , ep2y , sm2y , em2y ,        &
+                                            sp3y , ep3y , sm3y , em3y ,        &
+                                bdx , bdy )
+
+      USE module_domain
+      USE module_machine
+
+      IMPLICIT NONE
+      INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
+      INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
+                               sm1 , em1 , sm2 , em2 , sm3 , em3
+      INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
+                               sm1x , em1x , sm2x , em2x , sm3x , em3x
+      INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
+                               sm1y , em1y , sm2y , em2y , sm3y , em3y
+      INTEGER, INTENT(IN)   :: id
+      INTEGER, INTENT(OUT)  :: domdesc
+      INTEGER, INTENT(IN)   :: parent_id
+      INTEGER, INTENT(IN)   :: parent_domdesc
+      TYPE(domain),POINTER  :: parent
+
+! 
+! This is a routine provided by the rsl external comm layer.
+! and is defined in external/RSL/module_dm.F, which is copied
+! into frame/module_dm.F at compile time.  Changes to frame/module_dm.F
+! will be lost.
+! 
+! This routine is called by wrf_dm_patch_domain, the rsl
+! package-supplied routine that is called by wrf_patch_domain in the course of
+! setting up a new domain when running WRF on distributed memory parallel
+! computers.  This provides the rsl-specific mechanisms for defining and
+! decomposing a domain, and for associating it within rsl to it's parent
+! domain (in the case of a nest).
+!
+! The routine takes as input arguments the domain id, the index of the
+! domain in the namelist (top-most domain is id=1) the parent's id and
+! rsl domain descriptor (if there is a parent), and the the global
+! (undecomposed) dimensions of the new domain. The routine returns the
+! patch dimensions (computational extent),  memory dimensions (local
+! array sizes on each task), and an rsl domain descriptor for the new
+! domain.  The width of the x and y boundary regions is also passed in
+! (defined in share/module_bc.F) and
+! are used in the calculation of the memory dimensions.
+! 
+! Nesting 
+! 
+! This routine also defines, decomposes, and associates the intermediate
+! domain that is used to transfer forcing and feedback data between a
+! nest and its parent domain.
+! 
+! The relationship between a parent domain, the nest, and this
+! intermediate domain is stored partly in rsl and partly in WRF as fields
+! in the TYPE(domain) data structure (defined in frame/module_domain.F).
+! 
+! Basically, the rsl-maintained relationship is between the parent domain
+! and the intermediate domain; for purposes of interprocessor
+! communication and forcing and feedback, rsl considers the nest a
+! standalone domain. This is because all of the rsl-mediated
+! communication for moving data between processors for forcing and
+! feedback is between the parent and the intermediate domain.  The
+! movement of data between the intermediate domain and the nest is all
+! on-processor, and therefore does not involve rsl to a large extent.
+! 
+! The WRF-maintained relationship between a parent and a nest is
+! represented through pointers in TYPE(domain).  The parent domain
+! maintains an array of pointers to its children through the
+! nests field of TYPE(domain).  The nest has a back-pointer to
+! its parent through parents (there is only ever one parent of a
+! nest in WRF).  The nest also holds the pointer to the intermediate
+! domain, called intermediate_grid.
+! 
+! The actual forcing and feedback between parent, nest, and intermediate
+! domains are handled by other routines defined in
+! external/RSL/module_dm.F. See See interp_domain_em_part1, interp_domain_em_part2, force_domain_em_part2, feedback_domain_em_part1, and feedback_domain_em_part2.)
+!
+! 
+
+! Local variables
+      INTEGER               :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
+      INTEGER               :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
+                               c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
+      INTEGER               :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
+                               c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
+      INTEGER               :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
+                               c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
+
+      INTEGER               :: mloc , nloc , zloc         ! all k on same proc
+      INTEGER               :: mloc_x , nloc_x , zloc_x   ! all x on same proc
+      INTEGER               :: mloc_y , nloc_y , zloc_y   ! all y on same proc
+      INTEGER               :: c_mloc , c_nloc , c_zloc         ! all k on same proc
+      INTEGER               :: c_mloc_x , c_nloc_x , c_zloc_x   ! all x on same proc
+      INTEGER               :: c_mloc_y , c_nloc_y , c_zloc_y   ! all y on same proc
+      INTEGER               :: mglob , nglob
+      INTEGER               :: idim , jdim , kdim , i
+      INTEGER , PARAMETER   :: rsl_jjx_x = 2047
+      INTEGER , DIMENSION( rsl_jjx_x ) :: rsl_js_x0 , rsl_je_x0 , rsl_is_x0 , rsl_ie_x0
+      INTEGER                          :: rsl_xinest_x0 , rsl_idif_x0 , rsl_jdif_x0
+      INTEGER               :: i_parent_start , j_parent_start
+      INTEGER               :: ids, ide, jds, jde, kds, kde
+      INTEGER               :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
+      INTEGER               :: parent_grid_ratio
+      INTEGER               :: shw
+      INTEGER               :: idim_cd, jdim_cd, intermediate_domdesc
+      INTEGER               :: intermediate_mloc, intermediate_nloc
+      INTEGER               :: intermediate_mglob, intermediate_nglob
+      REAL                  :: info(7)
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER  :: nest_grid
+
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_ZXY )
+            idim = ed2-sd2+1
+            jdim = ed3-sd3+1
+            kdim = ed1-sd1+1
+         CASE ( DATA_ORDER_XYZ )
+            idim = ed1-sd1+1
+            jdim = ed2-sd2+1
+            kdim = ed3-sd3+1
+         CASE ( DATA_ORDER_XZY )
+            idim = ed1-sd1+1
+            jdim = ed3-sd3+1
+            kdim = ed2-sd2+1
+         CASE ( DATA_ORDER_YXZ)
+            idim = ed2-sd2+1
+            jdim = ed1-sd1+1
+            kdim = ed3-sd3+1
+      END SELECT
+      if ( id == 1 ) then
+! 
+!  Main Domain 
+!
+! The top-level WRF domain (id = 1) is set up when alloc_and_configure_domain is
+! called from wrf.  This is done here in
+! rsl_patch_domain with a call to RSL_MOTHER_DOMAIN3D.  The global domain
+! dimensions are converted to the length of each dimension in i, j, and k
+! for the domain (based on model_data_order, which is defined in frame/module_driver_constants.F,
+! based on the dimspec entries in the Registry.  In WRF the X/I dimension
+! corresponds to the the first dimension, the Z/K dimension the second,
+! and the Y/J the third.
+!
+! An rsl tag denoting the largest stencil to be used on the domain is
+! also provided. This is RSL_24PT for the EM core; the NMM core uses a
+! wider maximum stencil, RSL_120PT.  On return, the RSL domain descriptor
+! for the domain will be defined along with rsl's advice on the minimum
+! memory required for the memory dimensions on this task.
+! 
+! Rsl supports
+! alternate decompositions of the domain -- X/Z and Y/Z -- and
+! transposition operations between these decompositions. These are used
+! in WRF 3DVAR but not in the EM version of the WRF model itself, which
+! is always only an X/Y decomposition.
+!
+! As a diagnostic, the rsl routine SHOW_DOMAIN_DECOMP is called, which
+! outputs a text file with information on the decomposition to the
+! file show_domain_0000 from processor zero.
+!
+! The actual memory dimensions that patch_domain_rsl are computed in a
+! call to compute_memory_dims_using_rsl,
+! also defined in external/RSL/module_dm.F. Once these have been computed
+! the patch_domain_rsl returns.
+! 
+! 
+
+#ifndef NMM_CORE
+         CALL rsl_mother_domain3d(domdesc, RSL_24PT,               &
+#else
+         CALL rsl_mother_domain3d(domdesc, RSL_120PT,               &
+#endif
+                                  idim   ,  jdim   ,  kdim   ,     &
+                                  mloc   ,  nloc   ,  zloc   ,     &
+                                  mloc_y ,  nloc_y ,  zloc_y ,     &   ! x->y 20020908
+                                  mloc_x ,  nloc_x ,  zloc_x       )   ! y->x 20020908
+         CALL show_domain_decomp(domdesc)
+         ! this computes the dimension information for the
+         ! nest and passes these back
+         CALL compute_memory_dims_using_rsl (          &
+                   domdesc ,                           &
+                   mloc   ,  nloc   ,  zloc   ,        &
+                   mloc_x ,  nloc_x ,  zloc_x ,        &
+                   mloc_y ,  nloc_y ,  zloc_y ,        &
+                   sd1,  ed1,  sd2,  ed2,  sd3,  ed3,  &
+                   sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
+                   sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                   sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                   sm1,  em1,  sm2,  em2,  sm3,  em3,  &
+                   sm1x, em1x, sm2x, em2x, sm3x, em3x, &
+                   sm1y, em1y, sm2y, em2y, sm3y, em3y  )
+
+      else
+
+! 
+!  Nested Domain 
+! For nested domains (id greater than 1), the patch_domain_rsl first
+! defines the nest itself in rsl as a stand-alone domain (as far as RSL
+! knows it has no parent), then sets up the the intermediate domain that,
+! from rsl's point of view, is a nest of the parent with a refinement
+! ratio of 1 to 1 (same resolution).
+! 
+! As with the top-most domain, the nested domain is defined using
+! RSL_MOTHER_DOMAIN3D and its memory dimensions are computed calling
+! compute_memory_dims_using_rsl, as above.
+!
+! 
+         !
+         ! first spawn the actual nest. It is not
+         ! directly associated in rsl with the parent
+         ! so we spawn it as an unassociated domain
+         ! (another "mother")
+         !
+#ifndef NMM_CORE
+         CALL rsl_mother_domain3d(domdesc, RSL_24PT,               &
+#else
+         CALL rsl_mother_domain3d(domdesc, RSL_120PT,               &
+#endif
+                                  idim   ,  jdim   ,  kdim   ,     &
+                                  mloc   ,  nloc   ,  zloc   ,     &
+                                  mloc_y ,  nloc_y ,  zloc_y ,     &     ! x->y 20020910
+                                  mloc_x ,  nloc_x ,  zloc_x       )     ! y->x 20020910
+         CALL show_domain_decomp(domdesc)
+         ! this computes the dimension information for the
+         ! nest and passes these back
+         CALL compute_memory_dims_using_rsl (          &
+                   domdesc ,                           &
+                   mloc   ,  nloc   ,  zloc   ,        &
+                   mloc_x ,  nloc_x ,  zloc_x ,        &
+                   mloc_y ,  nloc_y ,  zloc_y ,        &
+                   sd1,  ed1,  sd2,  ed2,  sd3,  ed3,  &
+                   sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
+                   sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                   sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                   sm1,  em1,  sm2,  em2,  sm3,  em3,  &
+                   sm1x, em1x, sm2x, em2x, sm3x, em3x, &
+                   sm1y, em1y, sm2y, em2y, sm3y, em3y  )
+
+! 
+! Once the nest is defined, the intermediate
+! domain is defined and associated as a nest with the parent.
+! Here, SET_DEF_DECOMP_FCN1 is called, which directs rsl to use a special decomposition function,
+! intermediate_mapping, that
+! generates a decomposition of the intermediate domain in which
+! intermediate domain points are assigned to the same task as the nested
+! points they overlay (allowing the interpolation to be task-local).
+! This applies only to the intermediate domain; the default decmposition function
+! for other domains is not affected.
+! This decomposition algorithm also requires knowledge of the dimensions
+! of the nest, the nests rsl descriptor (defined above), the nesting
+! ratio, and the extra amount the intermediate domain should cover in the
+! coarse domain to allow for the stencil of the interpolator (the sint routine.  This information is packed into an
+! "info" vector that is provided to rsl with a call to
+! SET_DEF_DECOMP_INFO.
+! 
+! 
+
+
+         CALL nl_get_shw( id, shw )
+         CALL nl_get_i_parent_start( id , i_parent_start )
+         CALL nl_get_j_parent_start( id , j_parent_start )
+         CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
+
+         info(1) = idim               ! nest i dimension for intermediate mapping
+         info(2) = jdim               ! nest j dimension for intermediate mapping
+         info(3) = domdesc            ! nest domain descriptor
+         info(4) = parent_grid_ratio  ! nesting ratio in i
+         info(5) = parent_grid_ratio  ! nesting ratio in j
+         info(6) = shw                ! stencil half-width
+
+# if 1
+   ! tells which descriptor will be given back next when intermediate domain is spawned below
+   ! that is used to associate the decomposition information from the nested domain with
+   ! this intermediate domain, so that it will be decomposed identically, through 
+   ! the intermediate mapping function.
+         CALL get_next_domain_descriptor ( intermediate_domdesc )
+         CALL set_def_decomp_fcn1 ( intermediate_domdesc, intermediate_mapping )
+         CALL set_def_decomp_info ( intermediate_domdesc, info )
+# endif
+
+         ! now spawn the intermediate domain that will serve as the
+         ! nest-decomposed area of the CD domain, onto which data
+         ! will be transferred from the CD for interpolation
+         ! ** need to make sure the decomposition matches the
+         ! ** nested decomposition
+
+! 
+! The undecomposed dimensions of the intermediate domain are computed along
+! with the location of the intermediate domain's lower left-hand point and these
+! are passed to the RSL_SPAWN_REGULAR_NEST1 routine, which defines the intermediate
+! domain as a nest with 1:1 refinement within the parent domain. The memory dimensions
+! of the intermediate domain are computed by calling COMPUTE_MEMORY_DIMS_USING_RSL
+! and then the intermediate domain is allocated as a WRF grid of TYPE(domain).
+! The flow of control here resembles that of 
+! alloc_and_configure_domain, in 
+! frame/module_domain.F.
+! 
+
+         idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
+         jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
+
+         c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
+         c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
+         c_kds = sd2                ; c_kde = ed2                   ! IKJ ONLY
+
+         CALL RSL_SPAWN_REGULAR_NEST1(                  &
+                intermediate_domdesc,                   &
+                parent_domdesc,                         &
+#ifndef NMM_CORE
+                RSL_24PT,                               &
+#else
+                RSL_120PT,                               &
+#endif
+                c_ids, c_jds,                               &
+                idim_cd,jdim_cd,                        &
+                1, 1,                                   &
+                intermediate_mloc,intermediate_nloc,    &
+                intermediate_mglob,intermediate_nglob)
+
+         zloc = kdim
+         ! compute dims for intermediate domain
+         CALL show_domain_decomp(intermediate_domdesc)
+         CALL compute_memory_dims_using_rsl (          &
+                   intermediate_domdesc ,              &
+                   intermediate_mloc   ,  intermediate_nloc   ,  zloc   ,        &
+                   c_mloc_x ,  c_nloc_x ,  c_zloc_x ,        &
+                   c_mloc_y ,  c_nloc_y ,  c_zloc_y ,        &
+                   c_ids,  c_ide,  c_kds,  c_kde,  c_jds,  c_jde,  &   ! IKJ ONLY
+                   c_sp1,  c_ep1,  c_sp2,  c_ep2,  c_sp3,  c_ep3, &
+                   c_sp1x, c_ep1x, c_sp2x, c_ep2x, c_sp3x, c_ep3x, &
+                   c_sp1y, c_ep1y, c_sp2y, c_ep2y, c_sp3y, c_ep3y, &
+                   c_sm1,  c_em1,  c_sm2,  c_em2,  c_sm3,  c_em3,  &
+                   c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &
+                   c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y  )
+         ! since the RSL_SPAWN_REGULAR_NEST1 does not do the vert dimension
+         ! we need to set that manually  >>>>> IKJ ONLY
+         c_sp2 = c_kds   !IKJ ONLY
+         c_ep2 = c_kde   !IKJ ONLY
+         c_sm2 = c_kds   !IKJ ONLY
+         c_em2 = c_kde   !IKJ ONLY
+
+         ! global dims are same as CD
+         ! good for IKJ only
+         c_sd1 = parent%sd31       ; c_ed1 = parent%ed31
+         c_sd2 = parent%sd32       ; c_ed2 = parent%ed32
+         c_sd3 = parent%sd33       ; c_ed3 = parent%ed33
+
+
+         ! Sequence of calls to create a new, intermediate domain
+         ! data structures that can be used to store the CD data
+         ! that will be used as input to the forcing interpolation
+         ! on each processor.
+         ALLOCATE ( intermediate_grid )
+         ALLOCATE ( intermediate_grid%parents( max_parents ) )
+         ALLOCATE ( intermediate_grid%nests( max_nests ) )
+
+         NULLIFY( intermediate_grid%sibling )
+         DO i = 1, max_nests
+            NULLIFY( intermediate_grid%nests(i)%ptr )
+         ENDDO
+         NULLIFY  (intermediate_grid%next)
+         NULLIFY  (intermediate_grid%same_level)
+         NULLIFY  (intermediate_grid%i_start)
+         NULLIFY  (intermediate_grid%j_start)
+         NULLIFY  (intermediate_grid%i_end)
+         NULLIFY  (intermediate_grid%j_end)
+
+         intermediate_grid%id = id
+         intermediate_grid%domdesc = intermediate_domdesc
+         intermediate_grid%num_nests = 0
+         intermediate_grid%num_siblings = 0
+         intermediate_grid%num_parents = 1
+         intermediate_grid%max_tiles   = 0
+         intermediate_grid%num_tiles_spec   = 0
+         ! hook up some pointers
+         
+! 
+! However, the pointers in the nested hierachy must be set up differently
+! in this case.  First, the pointer to the nests TYPE(domain) is
+! retrieved in a somewhat roundabout way, by searching the domain
+! hierarcy rooted at head_grid (defined in frame/module_domain.F) with a
+! call to find_grid_by_id.  The nested
+! grid has already been added to the hierarchy by WRF because that is
+! done in alloc_and_configure_domain
+! before wrf_patch_domain is called,
+! but the arguments to patch_domain_rsl, here, do not include a pointer to
+! the nest domain, only the id (could be changed).  Once the pointer
+! to the nested grid's domain data structure is located, the nest's
+! intermediate_grid pointer is set to the the domain data struture for
+! the newly created created intermediate_domain.  In a curious twist of
+! geneology, however, the intermediate_grid (from WRF domain hierarchy
+! point of view) is set to consider the nest its parent. This is because,
+! from the WRF framework's point of view, the intermediate domain does
+! not exist (it only exists because of code in external/RSL/module_dm.F,
+! an external-package supplied module).  It remains only to allocate
+! the fields in the intermediate domain's domain data type, set a few
+! other fields such as dx, dy, and dt (to the parent domain's values) and 
+! return.
+! 
+! 
+
+         CALL find_grid_by_id ( id, head_grid, nest_grid )
+         nest_grid%intermediate_grid => intermediate_grid  ! nest grid now has a pointer to this baby
+         intermediate_grid%parents(1)%ptr => nest_grid     ! the intermediate grid considers nest its parent
+         intermediate_grid%num_parents = 1
+
+         c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
+         c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
+
+         intermediate_grid%sm31x                           = c_sm1x
+         intermediate_grid%em31x                           = c_em1x
+         intermediate_grid%sm32x                           = c_sm2x
+         intermediate_grid%em32x                           = c_em2x
+         intermediate_grid%sm33x                           = c_sm3x
+         intermediate_grid%em33x                           = c_em3x
+         intermediate_grid%sm31y                           = c_sm1y
+         intermediate_grid%em31y                           = c_em1y
+         intermediate_grid%sm32y                           = c_sm2y
+         intermediate_grid%em32y                           = c_em2y
+         intermediate_grid%sm33y                           = c_sm3y
+         intermediate_grid%em33y                           = c_em3y
+
+
+#ifdef SGIALTIX
+         ! allocate space for the intermediate domain
+         CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2, .TRUE. , &   ! use same id as nest
+                               c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3,       &
+                               c_sm1,  c_em1,  c_sm2,  c_em2,  c_sm3,  c_em3,  &
+                               c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &   ! x-xpose
+                               c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y  )   ! y-xpose
+#endif
+
+         intermediate_grid%sd31                            =   c_sd1
+         intermediate_grid%ed31                            =   c_ed1
+         intermediate_grid%sp31                            = c_sp1
+         intermediate_grid%ep31                            = c_ep1
+         intermediate_grid%sm31                            = c_sm1
+         intermediate_grid%em31                            = c_em1
+         intermediate_grid%sd32                            =   c_sd2
+         intermediate_grid%ed32                            =   c_ed2
+         intermediate_grid%sp32                            = c_sp2
+         intermediate_grid%ep32                            = c_ep2
+         intermediate_grid%sm32                            = c_sm2
+         intermediate_grid%em32                            = c_em2
+         intermediate_grid%sd33                            =   c_sd3
+         intermediate_grid%ed33                            =   c_ed3
+         intermediate_grid%sp33                            = c_sp3
+         intermediate_grid%ep33                            = c_ep3
+         intermediate_grid%sm33                            = c_sm3
+         intermediate_grid%em33                            = c_em3
+
+         CALL med_add_config_info_to_grid ( intermediate_grid )
+
+         intermediate_grid%dx = parent%dx
+         intermediate_grid%dy = parent%dy
+         intermediate_grid%dt = parent%dt
+
+         CALL wrf_dm_define_comms ( intermediate_grid )
+
+      endif
+
+      RETURN
+  END SUBROUTINE patch_domain_rsl
+
+  SUBROUTINE compute_memory_dims_using_rsl (        &
+                domdesc ,                           &
+                mloc   ,  nloc   ,  zloc   ,        &
+                mloc_x ,  nloc_x ,  zloc_x ,        &
+                mloc_y ,  nloc_y ,  zloc_y ,        &
+                sd1,  ed1,  sd2,  ed2,  sd3,  ed3,  &
+                sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
+                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                sm1,  em1,  sm2,  em2,  sm3,  em3,  &
+                sm1x, em1x, sm2x, em2x, sm3x, em3x, &
+                sm1y, em1y, sm2y, em2y, sm3y, em3y  )
+      USE module_machine
+      IMPLICIT NONE
+      ! Arguments
+      INTEGER, INTENT(IN ) :: domdesc
+      INTEGER, INTENT(IN ) :: mloc , nloc , zloc         ! all k on same proc
+      INTEGER, INTENT(IN ) :: mloc_x , nloc_x , zloc_x   ! all x on same proc
+      INTEGER, INTENT(IN ) :: mloc_y , nloc_y , zloc_y   ! all y on same proc
+      INTEGER, INTENT(IN ) :: sd1, ed1, sd2, ed2, sd3, ed3
+      INTEGER, INTENT(OUT) :: sp1, ep1, sp2, ep2, sp3, ep3
+      INTEGER, INTENT(OUT) :: sp1x, ep1x, sp2x, ep2x, sp3x, ep3x
+      INTEGER, INTENT(OUT) :: sp1y, ep1y, sp2y, ep2y, sp3y, ep3y
+      INTEGER, INTENT(OUT) :: sm1, em1, sm2, em2, sm3, em3
+      INTEGER, INTENT(OUT) :: sm1x, em1x, sm2x, em2x, sm3x, em3x
+      INTEGER, INTENT(OUT) :: sm1y, em1y, sm2y, em2y, sm3y, em3y
+! 
+! For a given domain (referred to by it's rsl domain descriptor) interrogate 
+! rsl and compute the patch and memory dimensions for the section of the
+! domain that is computed on this task.  rsl has this information already
+! and it is necessary only to (1) assign the information to the correct
+! dimension in WRF, based on the setting of model_data_order (
+! defined in frame/module_driver_constants.F,
+! based on the dimspec entries in the Registry), and (2) convert the
+! start and end of each dimension
+! from local (as they are carried in rsl, a holdover from MM5) to global.
+! 
+! 
+      ! Local data
+      INTEGER , PARAMETER   :: rsl_jjx_x = 2047
+      INTEGER , DIMENSION( rsl_jjx_x ) :: rsl_js_x0 , rsl_je_x0 , rsl_is_x0 , rsl_ie_x0
+      INTEGER                          :: rsl_xinest_x0 , rsl_idif_x0 , rsl_jdif_x0
+
+      CALL RSL_REG_RUN_INFOP(domdesc , 0 ,               &
+                             rsl_jjx_x ,                 &
+                             rsl_xinest_x0 ,             &
+                             rsl_is_x0 , rsl_ie_x0 ,     &
+                             rsl_js_x0 , rsl_je_x0 ,     &
+                             rsl_idif_x0 , rsl_jdif_x0   )
+
+      SELECT CASE ( model_data_order )
+         CASE ( DATA_ORDER_ZXY )
+
+           CALL rsl_reg_patchinfo_mn ( domdesc ,                       &
+                       sp2  , ep2  , sp3  , ep3  ,  sp1  , ep1   )
+           sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
+           sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
+           sm2 = sp2 - rsl_padarea
+           em2 = sm2 + mloc - 1
+           sm3 = sp3 - rsl_padarea
+           em3 = sm3 + nloc - 1
+           sm1 = sp1
+           em1 = sm1 + zloc - 1
+
+           CALL rsl_reg_patchinfo_nz ( domdesc ,                       &                    ! switched m->n 20020910
+                       sp2x , ep2x , sp3x , ep3x ,  sp1x , ep1x  )
+           sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
+           sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
+           sm2x = sp2x - rsl_padarea
+           em2x = sm2x + mloc_x - 1
+           sm3x = sp3x - rsl_padarea
+           em3x = sm3x + nloc_x - 1
+           sm1x = sp1x
+           em1x = sm1x + zloc_x - 1
+
+           CALL rsl_reg_patchinfo_mz ( domdesc ,                       &                    ! switched n->m 20020910
+                       sp2y , ep2y , sp3y , ep3y ,  sp1y , ep1y  )
+           sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
+           sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
+           sm2y = sp2y - rsl_padarea
+           em2y = sm2y + mloc_y - 1
+           sm3y = sp3y - rsl_padarea
+           em3y = sm3y + nloc_y - 1
+           sm1y = sp1y
+           em1y = sm1y + zloc_y - 1
+
+         CASE ( DATA_ORDER_XZY )
+
+           CALL rsl_reg_patchinfo_mn ( domdesc ,                       &
+                       sp1  , ep1  , sp3  , ep3  ,  sp2  , ep2   )
+
+           sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
+           sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
+
+           sm1 = sp1 - rsl_padarea
+           em1 = sm1 + mloc - 1
+           sm3 = sp3 - rsl_padarea
+           em3 = sm3 + nloc - 1
+           sm2 = sp2
+           em2 = sm2 + zloc - 1
+
+           CALL rsl_reg_patchinfo_nz ( domdesc ,                       &   ! switched m->n 20020908
+                       sp1x , ep1x , sp3x , ep3x ,  sp2x , ep2x  )
+           sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
+           sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
+           sm1x = sp1x - rsl_padarea
+           em1x = sm1x + mloc_x - 1
+           sm3x = sp3x - rsl_padarea
+           em3x = sm3x + nloc_x - 1
+           sm2x = sp2x
+           em2x = sm2x + zloc_x - 1
+
+           CALL rsl_reg_patchinfo_mz ( domdesc ,                       &   ! switched n->m 20020908
+                       sp1y , ep1y , sp3y , ep3y ,  sp2y , ep2y  )
+           sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
+           sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
+           sm1y = sp1y - rsl_padarea
+           em1y = sm1y + mloc_y - 1
+           sm3y = sp3y - rsl_padarea
+           em3y = sm3y + nloc_y - 1
+           sm2y = sp2y
+           em2y = sm2y + zloc_y - 1
+
+         CASE ( DATA_ORDER_XYZ )
+
+           CALL rsl_reg_patchinfo_mn ( domdesc ,                       &
+                       sp1  , ep1  , sp2  , ep2  ,  sp3  , ep3   )
+           sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
+           sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
+           sm1 = sp1 - rsl_padarea
+           em1 = sm1 + mloc - 1
+           sm2 = sp2 - rsl_padarea
+           em2 = sm2 + nloc - 1
+           sm3 = sp3
+           em3 = sm3 + zloc - 1
+
+           CALL rsl_reg_patchinfo_nz ( domdesc ,                       &     ! switched m->n 20020910
+                       sp1x , ep1x , sp2x , ep2x ,  sp3x , ep3x  )
+           sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
+           sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
+           sm1x = sp1x - rsl_padarea
+           em1x = sm1x + mloc_x - 1
+           sm2x = sp2x - rsl_padarea
+           em2x = sm2x + nloc_x - 1
+           sm3x = sp3x
+           em3x = sm3x + zloc_x - 1
+
+           CALL rsl_reg_patchinfo_mz ( domdesc ,                       &     ! switched n->m 20020910
+                       sp1y , ep1y , sp2y , ep2y ,  sp3y , ep3y  )
+           sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
+           sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
+           sm1y = sp1y - rsl_padarea
+           em1y = sm1y + mloc_y - 1
+           sm2y = sp2y - rsl_padarea
+           em2y = sm2y + nloc_y - 1
+           sm3y = sp3y
+           em3y = sm3y + zloc_y - 1
+
+         CASE ( DATA_ORDER_YXZ )
+
+           CALL rsl_reg_patchinfo_mn ( domdesc ,                       &
+                       sp2  , ep2  , sp1  , ep1  ,  sp3  , ep3   )
+
+           sp1 = sp1 - ( 1 - sd1 ) ; ep1 = ep1 - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2 = sp2 - ( 1 - sd2 ) ; ep2 = ep2 - ( 1 - sd2 )
+           sp3 = sp3 - ( 1 - sd3 ) ; ep3 = ep3 - ( 1 - sd3 )
+           sm2 = sp2 - rsl_padarea
+           em2 = sm2 + mloc - 1
+           sm1 = sp1 - rsl_padarea
+           em1 = sm1 + nloc - 1
+           sm3 = sp3
+           em3 = sm3 + zloc - 1
+
+           CALL rsl_reg_patchinfo_nz ( domdesc ,                       &     ! switched n->m 20020910
+                       sp2x , ep2x , sp1x , ep1x ,  sp3x , ep3x  )
+           sp1x = sp1x - ( 1 - sd1 ) ; ep1x = ep1x - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2x = sp2x - ( 1 - sd2 ) ; ep2x = ep2x - ( 1 - sd2 )
+           sp3x = sp3x - ( 1 - sd3 ) ; ep3x = ep3x - ( 1 - sd3 )
+           sm2x = sp2x - rsl_padarea
+           em2x = sm2x + mloc_x - 1
+           sm1x = sp1x - rsl_padarea
+           em1x = sm1x + nloc_x - 1
+           sm3x = sp3x
+           em3x = sm3x + zloc_x - 1
+
+           CALL rsl_reg_patchinfo_mz ( domdesc ,                       &     ! switched m->n 20020910
+                       sp2y , ep2y , sp1y , ep1y ,  sp3y , ep3y  )
+           sp1y = sp1y - ( 1 - sd1 ) ; ep1y = ep1y - ( 1 - sd1 )   ! adjust if domain start not 1
+           sp2y = sp2y - ( 1 - sd2 ) ; ep2y = ep2y - ( 1 - sd2 )
+           sp3y = sp3y - ( 1 - sd3 ) ; ep3y = ep3y - ( 1 - sd3 )
+           sm2y = sp2y - rsl_padarea
+           em2y = sm2y + mloc_y - 1
+           sm1y = sp1y - rsl_padarea
+           em1y = sm1y + nloc_y - 1
+           sm3y = sp3y
+           em3y = sm3y + zloc_y - 1
+
+      END SELECT
+
+      RETURN
+   END SUBROUTINE compute_memory_dims_using_rsl
+
+   SUBROUTINE init_module_dm
+      IMPLICIT NONE
+      INTEGER ierr, mytask
+      EXTERNAL rsl_patch_decomp
+! 
+! This is the first part of the initialization of rsl for distributed
+! memory parallel execution.  The routine first interrogates MPI to find
+! out if it needs to be intialized (it may not, since 
+! init_module_wrf_quilt may
+! have done this already) and if so, calls mpi_init.  Standard output
+! and standard error on each process is directed to a separate file
+! with a call to wrf_termio_dup and,
+! in the case where we are calling mpi_init here, MPI_COMM_WORLD
+! is set as the communicator (it would not be in the case of quilting).
+! 
+! Finally, rsl itself is initialized and the default decomposition
+! algorithm in rsl is set to the rsl-provided algorithm RSL_PATCH_DECOMP.
+!
+! Certain parts of this algorithm are #ifdef'd out in case -DSTUBMPI
+! is specified in the configure.wrf file at compile time.  This allows
+! rsl's nesting functionality to be used on a single processor (for nesting, for example) without using MPI.
+! 
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      LOGICAL mpi_inited
+      CALL mpi_initialized( mpi_inited, ierr )
+      IF ( .NOT. mpi_inited ) THEN
+        ! If MPI has not been initialized then initialize it and 
+        ! make comm_world the communicator
+        ! Otherwise, something else (e.g. quilt-io) has already 
+        ! initialized MPI, so just grab the communicator that
+        ! should already be stored and use that.
+        CALL mpi_init ( ierr )
+        CALL wrf_termio_dup
+        CALL wrf_set_dm_communicator ( MPI_COMM_WORLD )
+      ENDIF
+      CALL wrf_get_dm_communicator( mpi_comm_local )
+      CALL wrf_termio_dup
+#endif
+      CALL rsl_initialize1( mpi_comm_local )
+      CALL set_def_decomp_fcn ( rsl_patch_decomp )
+   END SUBROUTINE init_module_dm
+
+! internal, used below for switching the argument to MPI calls
+! if reals are being autopromoted to doubles in the build of WRF
+   INTEGER function getrealmpitype()
+#ifndef STUBMPI
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER rtypesize, dtypesize, ierr
+      CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
+      CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
+      IF ( RWORDSIZE .EQ. rtypesize ) THEN
+        getrealmpitype = MPI_REAL
+      ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
+        getrealmpitype = MPI_DOUBLE_PRECISION
+      ELSE
+        CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
+      ENDIF
+#else
+! required dummy initialization for function that is never called
+      getrealmpitype = 1
+#endif
+      RETURN
+   END FUNCTION getrealmpitype
+
+   REAL FUNCTION wrf_dm_max_real ( inval )
+      IMPLICIT NONE
+      REAL inval, retval
+      INTEGER ierr
+! 
+! Collective operation. Each processor calls passing a local value; on return
+! all processors are passed back the maximum of all values passed.
+!
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MAX, mpi_comm_local, ierr )
+      wrf_dm_max_real = retval
+#else
+      wrf_dm_max_real = inval
+#endif
+   END FUNCTION wrf_dm_max_real
+
+   REAL FUNCTION wrf_dm_min_real ( inval )
+      IMPLICIT NONE
+      REAL inval, retval
+      INTEGER typesize, op
+      INTEGER ierr
+! 
+! Collective operation. Each processor calls passing a local value; on return
+! all processors are passed back the minumum of all values passed.
+!
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_MIN, mpi_comm_local, ierr )
+      wrf_dm_min_real = retval
+#else
+      wrf_dm_min_real = inval
+#endif
+   END FUNCTION wrf_dm_min_real
+
+   REAL FUNCTION wrf_dm_sum_real ( inval )
+      IMPLICIT NONE
+      INTEGER ierr
+      INTEGER typesize, op
+      REAL inval, retval
+! 
+! Collective operation. Each processor calls passing a local value; on return
+! all processors are passed back the sum of all values passed.
+!
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype() , MPI_SUM, mpi_comm_local, ierr )
+      wrf_dm_sum_real = retval
+#else
+      wrf_dm_sum_real = inval
+#endif
+   END FUNCTION wrf_dm_sum_real
+
+   INTEGER FUNCTION wrf_dm_sum_integer ( inval )
+      IMPLICIT NONE
+      INTEGER inval, retval, ierr
+! 
+! Collective operation. Each processor calls passing a local value; on return
+! all processors are passed back the sum of all values passed.
+!
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, mpi_comm_local, ierr )
+      wrf_dm_sum_integer = retval
+#else
+      wrf_dm_sum_integer = inval
+#endif
+   END FUNCTION wrf_dm_sum_integer
+
+
+   SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
+      IMPLICIT NONE
+      REAL val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_maxval_real
+
+   SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
+      IMPLICIT NONE
+      REAL val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the minimum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_real
+
+   SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
+      IMPLICIT NONE
+      DOUBLE PRECISION val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_maxval_doubleprecision
+
+   SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
+      IMPLICIT NONE
+      DOUBLE PRECISION val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the minimum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_doubleprecision
+
+
+   SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
+      IMPLICIT NONE
+      INTEGER val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_maxval_integer
+
+   SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
+      IMPLICIT NONE
+      INTEGER val, val_all( rsl_nproc )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,rsl_nproc)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the minimum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, rsl_nproc
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_integer
+
+   SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
+      USE module_domain
+      TYPE (domain),INTENT(INOUT) :: parent, nest
+      INTEGER, INTENT(IN)         :: dx, dy
+      CALL rsl_move_nest ( parent%domdesc, nest%domdesc, dx, dy )
+   END SUBROUTINE wrf_dm_move_nest
+
+!------------------------------------------------------------------------------
+   SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
+                                   mp_local_uobmask,            &
+                                   mp_local_vobmask,            &
+                                   mp_local_cobmask, errf )
+
+!------------------------------------------------------------------------------
+!  PURPOSE: Do MPI allgatherv operation across processors to get the
+!           errors at each observation point on all processors. 
+!
+!------------------------------------------------------------------------------
+#ifndef STUBMPI
+    INCLUDE 'mpif.h'
+
+    INTEGER, INTENT(IN)   :: nsta                ! Observation index.
+    INTEGER, INTENT(IN)   :: nerrf               ! Number of error fields.
+    INTEGER, INTENT(IN)   :: niobf               ! Number of observations.
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_UOBMASK(NIOBF)
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_VOBMASK(NIOBF)
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_COBMASK(NIOBF)
+    REAL, INTENT(INOUT)   :: errf(nerrf, niobf)
+
+! Local declarations
+    integer i, n, nlocal_dot, nlocal_crs
+    REAL UVT_BUFFER(NIOBF)    ! Buffer for holding U, V, or T
+    REAL QRK_BUFFER(NIOBF)    ! Buffer for holding Q or RKO
+    REAL SFP_BUFFER(NIOBF)    ! Buffer for holding Surface pressure
+    INTEGER N_BUFFER(NIOBF)
+    REAL FULL_BUFFER(NIOBF)
+    INTEGER IFULL_BUFFER(NIOBF)
+    INTEGER IDISPLACEMENT(1024)   ! HARD CODED MAX NUMBER OF PROCESSORS
+    INTEGER ICOUNT(1024)          ! HARD CODED MAX NUMBER OF PROCESSORS
+
+    INTEGER :: MPI_COMM_COMP      ! MPI group communicator
+    INTEGER :: NPROCS             ! Number of processors
+    INTEGER :: IERR               ! Error code from MPI routines
+
+! Get communicator for MPI operations.
+    CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+
+! Get rank of monitor processor and broadcast to others.
+    CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
+
+! DO THE U FIELD
+   NLOCAL_DOT = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_UOBMASK(N) ) THEN      ! USE U-POINT MASK
+       NLOCAL_DOT = NLOCAL_DOT + 1
+       UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N)        ! U WIND COMPONENT
+       SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N)        ! SURFACE PRESSURE
+       QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N)        ! RKO
+       N_BUFFER(NLOCAL_DOT) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   I = 1
+
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! U
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT U-POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! RKO
+   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+
+! DO THE V FIELD
+   NLOCAL_DOT = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_VOBMASK(N) ) THEN         ! USE V-POINT MASK
+       NLOCAL_DOT = NLOCAL_DOT + 1
+       UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N)    ! V WIND COMPONENT
+       SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N)    ! SURFACE PRESSURE
+       N_BUFFER(NLOCAL_DOT) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   I = 1
+
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! V
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT V-POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+
+! DO THE CROSS FIELDS, T AND Q
+   NLOCAL_CRS = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_COBMASK(N) ) THEN       ! USE MASS-POINT MASK
+       NLOCAL_CRS = NLOCAL_CRS + 1
+       UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N)     ! TEMPERATURE
+       QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N)     ! MOISTURE
+       SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N)     ! SURFACE PRESSURE
+       N_BUFFER(NLOCAL_CRS) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! T
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+
+   DO N = 1, NSTA
+     ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! Q
+   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT MASS POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+#endif
+   END SUBROUTINE get_full_obs_vector
+
+END MODULE module_dm
+
+!=========================================================================
+! wrf_dm_patch_domain has to be outside the module because it is called
+! by a routine in module_domain but depends on module domain
+
+
+SUBROUTINE wrf_dm_patch_domain ( id  , domdesc , parent_id , parent_domdesc , &
+                          sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
+                          sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
+                          sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
+                                      sp1x , ep1x , sm1x , em1x , &
+                                      sp2x , ep2x , sm2x , em2x , &
+                                      sp3x , ep3x , sm3x , em3x , &
+                                      sp1y , ep1y , sm1y , em1y , &
+                                      sp2y , ep2y , sm2y , em2y , &
+                                      sp3y , ep3y , sm3y , em3y , &
+                          bdx , bdy )
+   USE module_domain
+   USE module_dm
+   IMPLICIT NONE
+
+   INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
+   INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
+                            sm1 , em1 , sm2 , em2 , sm3 , em3
+   INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
+                            sm1x , em1x , sm2x , em2x , sm3x , em3x
+   INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
+                            sm1y , em1y , sm2y , em2y , sm3y , em3y
+   INTEGER, INTENT(INOUT):: id  , domdesc , parent_id , parent_domdesc
+
+   TYPE(domain), POINTER :: parent, grid_ptr
+
+! 
+! The rsl-package supplied routine that computes the patch and memory dimensions
+! for this task. See also patch_domain_rsl
+! 
+! 
+
+   ! this is necessary because we cannot pass parent directly into 
+   ! wrf_dm_patch_domain because creating the correct interface definitions
+   ! would generate a circular USE reference between module_domain and module_dm
+   ! see comment this date in module_domain for more information. JM 20020416
+
+   NULLIFY( parent )
+   grid_ptr => head_grid
+   CALL find_grid_by_id( parent_id , grid_ptr , parent )
+
+   CALL patch_domain_rsl ( id  , domdesc , parent, parent_id , parent_domdesc , & 
+                           sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & 
+                           sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
+                           sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
+                                       sp1x , ep1x , sm1x , em1x , &
+                                       sp2x , ep2x , sm2x , em2x , &
+                                       sp3x , ep3x , sm3x , em3x , &
+                                       sp1y , ep1y , sm1y , em1y , &
+                                       sp2y , ep2y , sm2y , em2y , &
+                                       sp3y , ep3y , sm3y , em3y , &
+                           bdx , bdy )
+
+
+   RETURN
+END SUBROUTINE wrf_dm_patch_domain
+
+SUBROUTINE wrf_termio_dup
+  IMPLICIT NONE
+  INTEGER mytask, ntasks, ierr
+! 
+! Redirect standard output and standard error to separate files for each processor.
+!
+! 
+#ifndef STUBMPI
+  INCLUDE 'mpif.h'
+  CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
+  CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
+#else
+  ntasks = 1
+  mytask = 0
+#endif
+  write(0,*)'starting wrf task ',mytask,' of ',ntasks
+  CALL rsl_error_dup1( mytask )
+END SUBROUTINE wrf_termio_dup
+
+SUBROUTINE wrf_get_myproc( myproc )
+  IMPLICIT NONE
+! 
+! Pass back the task number (usually MPI rank) on this process.
+!
+! 
+# include "rsl.inc"
+  INTEGER myproc
+  myproc = rsl_myproc
+  RETURN
+END SUBROUTINE wrf_get_myproc
+
+SUBROUTINE wrf_get_nproc( nproc )
+  IMPLICIT NONE
+# include "rsl.inc"
+  INTEGER nproc
+! 
+! Pass back the number of distributed-memory tasks.
+!
+! 
+  nproc = rsl_nproc_all
+  RETURN
+END SUBROUTINE wrf_get_nproc
+
+SUBROUTINE wrf_get_nprocx( nprocx )
+  IMPLICIT NONE
+# include "rsl.inc"
+  INTEGER nprocx
+! 
+! Pass back the number of distributed-memory tasks decomposing the X dimension of the domain.
+!
+! 
+  nprocx = rsl_nproc_min
+  RETURN
+END SUBROUTINE wrf_get_nprocx
+
+SUBROUTINE wrf_get_nprocy( nprocy )
+  IMPLICIT NONE
+# include "rsl.inc"
+  INTEGER nprocy
+! 
+! Pass back the number of distributed-memory tasks decomposing the Y dimension of the domain.
+!
+! 
+  nprocy = rsl_nproc_maj
+  RETURN
+END SUBROUTINE wrf_get_nprocy
+
+SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER size
+#ifndef NEC
+   INTEGER*1 BUF(size)
+#else
+   CHARACTER*1 BUF(size)
+#endif
+! 
+! Collective operation. Given a buffer and a size in bytes on task zero, broadcast and return that buffer on all tasks.
+!
+! 
+   CALL rsl_mon_bcast( buf , size )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_bytes
+
+SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! 
+! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
+!
+! 
+   CHARACTER*(*) buf
+   INTEGER ibuf(256),i,n
+   CHARACTER*256 tstr
+   n = n1
+   ! Root task is required to have the correct value of N1, other tasks
+   ! might not have the correct value.
+   CALL wrf_dm_bcast_integer( n , 1 )
+   IF (n .GT. 256) n = 256
+   IF (n .GT. 0 ) then
+     DO i = 1, n
+       ibuf(I) = ichar(buf(I:I))
+     ENDDO
+     CALL wrf_dm_bcast_integer( ibuf, n )
+     buf = ''
+     DO i = 1, n
+       buf(i:i) = char(ibuf(i))
+     ENDDO
+   ENDIF
+   RETURN
+END SUBROUTINE wrf_dm_bcast_string
+
+SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+   INTEGER  buf(*)
+! 
+! Collective operation. Given an array of integers and length on task zero, broadcast and return that array of values on all tasks.
+!
+! 
+   CALL rsl_mon_bcast( BUF , N1 * IWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_integer
+
+SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! 
+! Collective operation. Given an array of doubles and length on task zero, broadcast and return that array of values on all tasks.
+!
+! 
+   DOUBLEPRECISION  buf(*)
+   CALL rsl_mon_bcast( BUF , N1 * DWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_double
+
+SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! 
+! Collective operation. Given an array of reals and length on task zero, broadcast and return that array of values on all tasks.
+!
+! 
+   REAL  buf(*)
+   CALL rsl_mon_bcast( BUF , N1 * RWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_real
+
+SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! 
+! Collective operation. Given an array of logicals and length on task zero, broadcast and return that array of values on all tasks.
+!
+! 
+   LOGICAL  buf(*)
+   CALL rsl_mon_bcast( BUF , N1 * LWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_logical
+
+SUBROUTINE wrf_dm_halo ( domdesc , comms , stencil_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , stencil_id
+   CALL rsl_exch_stencil ( domdesc , comms( stencil_id ) )
+   RETURN
+END SUBROUTINE wrf_dm_halo
+
+SUBROUTINE wrf_dm_xpose_z2y ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_mn_mz ( domdesc , comms( xpose_id ) )      ! switched nz->mz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_z2y
+
+SUBROUTINE wrf_dm_xpose_y2z ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_mz_mn ( domdesc , comms( xpose_id ) )      ! switched nz->mz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_y2z
+
+SUBROUTINE wrf_dm_xpose_y2x ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_mz_nz ( domdesc , comms( xpose_id ) )      ! switched nz<->mz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_y2x
+
+SUBROUTINE wrf_dm_xpose_x2y ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_nz_mz ( domdesc , comms( xpose_id ) )      ! switched nz<->mz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_x2y
+
+SUBROUTINE wrf_dm_xpose_x2z ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_nz_mn ( domdesc , comms( xpose_id ) )      ! switched mz->nz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_x2z
+
+SUBROUTINE wrf_dm_xpose_z2x ( domdesc , comms , xpose_id )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , xpose_id
+   CALL rsl_xpose_mn_nz ( domdesc , comms( xpose_id ) )      ! switched mz->nz 20020910
+   RETURN
+END SUBROUTINE wrf_dm_xpose_z2x
+
+#if 0
+SUBROUTINE wrf_dm_boundary ( domdesc , comms , period_id , &
+                             periodic_x , periodic_y )
+   USE module_dm
+   IMPLICIT NONE
+   INTEGER domdesc , comms(*) , period_id
+   LOGICAL , INTENT(IN)      :: periodic_x, periodic_y
+# include "rsl.inc"
+
+   IF ( periodic_x ) THEN
+     CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_M )
+   END IF
+   IF ( periodic_y ) THEN
+     CALL rsl_exch_period ( domdesc , comms( period_id ) , RSL_N )
+   END IF
+   RETURN
+END SUBROUTINE wrf_dm_boundary
+#endif
+
+SUBROUTINE wrf_dm_define_comms ( grid )
+   USE module_domain
+   USE module_dm
+   IMPLICIT NONE
+   TYPE(domain) , INTENT (INOUT) :: grid 
+   INTEGER dyn_opt
+   INTEGER idum1, idum2, icomm
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+#include "deref_kludge.h"
+
+   CALL nl_get_dyn_opt( 1, dyn_opt )
+
+   CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+
+! rsl interface has been restructured so there is no longer a 
+! need to call a dyncore specific define_comms routine here.
+! Removed 6/2001. JM
+
+   DO icomm = 1, max_comms
+     grid%comms(icomm) = invalid_message_value
+   ENDDO
+   grid%shift_x = invalid_message_value
+   grid%shift_y = invalid_message_value
+
+   RETURN
+END SUBROUTINE wrf_dm_define_comms
+
+SUBROUTINE write_68( grid, v , s , &
+                   ids, ide, jds, jde, kds, kde, &
+                   ims, ime, jms, jme, kms, kme, &
+                   its, ite, jts, jte, kts, kte )
+  USE module_domain
+  IMPLICIT NONE
+  TYPE(domain) , INTENT (INOUT) :: grid 
+  CHARACTER *(*) s
+  INTEGER ids, ide, jds, jde, kds, kde, &
+          ims, ime, jms, jme, kms, kme, &
+          its, ite, jts, jte, kts, kte
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
+# include "rsl.inc"
+
+  INTEGER i,j,k
+
+  logical, external :: wrf_dm_on_monitor
+  real globbuf( ids:ide, kds:kde, jds:jde )
+  character*3 ord, stag
+
+  if ( kds == kde ) then
+    ord = 'xy'
+    stag = 'xy'
+  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
+                     ids, ide, jds, jde, kds, kde, &
+                     ims, ime, jms, jme, kms, kme, &
+                     its, ite, jts, jte, kts, kte )
+  else
+
+    stag = 'xyz' 
+    ord = 'xzy'
+  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
+                     ids, ide, kds, kde, jds, jde, &
+                     ims, ime, kms, kme, jms, jme, &
+                     its, ite, kts, kte, jts, jte )
+  endif
+
+
+  if ( wrf_dm_on_monitor() ) THEN
+    WRITE(68,*) ide-ids+1, jde-jds+1 , s
+    DO j = jds, jde
+    DO i = ids, ide
+       WRITE(68,*) globbuf(i,1,j)
+    ENDDO
+    ENDDO
+  endif
+
+  RETURN
+END
+
+   SUBROUTINE wrf_abort
+! 
+! Kill the run. Calls MPI_ABORT.
+!
+! 
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+#else
+      STOP
+#endif
+   END SUBROUTINE wrf_abort
+
+   SUBROUTINE wrf_dm_shutdown
+# include "rsl.inc"
+! 
+! Shutdown (gracefully) the underlying comm layer.
+!
+! 
+      CALL RSL_SHUTDOWN
+      RETURN
+   END SUBROUTINE wrf_dm_shutdown
+
+   LOGICAL FUNCTION wrf_dm_on_monitor()
+      LOGICAL rsl_iammonitor
+      EXTERNAL rsl_iammonitor
+! 
+! Return true on task zero, false otherwise.
+!
+! 
+      wrf_dm_on_monitor = rsl_iammonitor()
+      RETURN
+   END FUNCTION wrf_dm_on_monitor
+
+   INTEGER FUNCTION wrf_dm_monitor_rank()
+      USE module_dm
+      IMPLICIT NONE
+      INTEGER retval
+      CALL rsl_monitor_proc( retval ) 
+      wrf_dm_monitor_rank = retval 
+      RETURN
+   END FUNCTION wrf_dm_monitor_rank
+
+   SUBROUTINE wrf_get_dm_communicator ( communicator )
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: communicator
+! 
+! Return the communicator the underlying comm layer is using.
+!
+! 
+      CALL rsl_get_communicator ( communicator )
+      RETURN
+   END SUBROUTINE wrf_get_dm_communicator
+
+   SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: iocommunicator
+! 
+! Return the io communicator the underlying comm layer is using.  Not used.
+!
+! 
+      CALL rsl_get_communicator ( iocommunicator )  ! same as regular communicator
+      RETURN
+   END SUBROUTINE wrf_get_dm_iocommunicator
+
+   SUBROUTINE wrf_set_dm_communicator ( communicator )
+      IMPLICIT NONE
+      INTEGER , INTENT(IN) :: communicator
+! 
+! Set the communicator the underlying comm layer is to use.
+!
+! 
+      CALL rsl_set_communicator ( communicator )
+      RETURN
+   END SUBROUTINE wrf_set_dm_communicator
+
+   SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
+      IMPLICIT NONE
+      INTEGER , INTENT(IN) :: iocommunicator
+! 
+! Set the io communicator the underlying comm layer is to use. Not used.
+!
+! 
+!      CALL rsl_set_communicator ( iocommunicator )  ! same as regular communicator
+      RETURN
+   END SUBROUTINE wrf_set_dm_iocommunicator
+
+
+!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       REAL globbuf(*)
+       REAL buf(*)
+! 
+! Collective operation. Given a buffer of type real corresponding to a 2- or 3-dimensional patch on a local processor,
+! return on task zero the global array assembled from the pieces stored on each processor.
+! 
+! 
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_real 
+
+   SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       DOUBLEPRECISION globbuf(*)
+       DOUBLEPRECISION buf(*)
+! 
+! Collective operation. Given a buffer of type double corresponding to a 2- or 3-dimensional patch on a local processor,
+! return on task zero the global array assembled from the pieces stored on each processor.
+! 
+! 
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RSL_DOUBLE,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_double
+
+
+   SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       INTEGER globbuf(*)
+       INTEGER buf(*)
+! 
+! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
+! return on task zero the global array assembled from the pieces stored on each processor.
+! 
+! 
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_integer 
+
+   SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       INTEGER globbuf(*)
+       INTEGER buf(*)
+! 
+! Collective operation. Given a buffer of type integer corresponding to a 2- or 3-dimensional patch on a local processor,
+! return on task zero the global array assembled from the pieces stored on each processor.
+!
+! 
+
+       IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
+         CALL wrf_error_fatal( "module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" ) 
+       ENDIF
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,rsl_integer,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_logical
+
+   SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,type,&
+                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
+       USE module_driver_constants
+       USE module_timing
+       USE module_wrf_error
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A 
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc,type
+       REAL globbuf(*)
+       REAL buf(*)
+
+       LOGICAL, EXTERNAL :: has_char
+       INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
+       INTEGER i, j, k, ord, ord2d, ndim
+       INTEGER mlen, nlen, zlen
+
+       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
+       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
+       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
+
+       ndim = len(TRIM(ordering))
+
+       CALL rsl_get_glen( domdesc, glen(1), glen(2), glen(3) )
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xyz','xy' )
+           ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
+            ! the non-staggered variables come in at one-less than
+            ! domain dimensions, but RSL wants full domain spec, so 
+            ! adjust if not staggered
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'yxz','yx' )
+           ord = io3d_jik_internal ; ord2d = io2d_ji_internal
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'zxy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
+           ord = io3d_kij_internal ; ord2d = io2d_ij_internal
+#if 0
+         CASE ( 'zyx' )
+           ord = io3d_kji_internal ; ord2d = io2d_ji_internal
+         CASE ( 'yzx' )
+           ord = io3d_jki_internal ; ord2d = io2d_ji_internal
+#endif
+         CASE ( 'xzy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
+           ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
+         CASE DEFAULT
+           ord = -1 ; ord2d = -1
+       END SELECT
+
+
+       glen(1) = DE1-DS1+1   ; glen(2) = DE2-DS2+1   ; glen(3) = DE3-DS3+1
+       llen(1) = ME1-MS1+1   ; llen(2) = ME2-MS2+1   ; llen(3) = ME3-MS3+1
+       glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
+       llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
+
+       IF ( wrf_at_debug_level(500) ) THEN
+         CALL start_timing
+       ENDIF
+
+       IF ( ndim .EQ. 3 ) THEN
+         CALL rsl_write(globbuf,ord,buf,domdesc,type,glen,llen)
+       ELSE
+         CALL rsl_write(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
+       ENDIF
+       IF ( wrf_at_debug_level(500) ) THEN
+         CALL end_timing('wrf_patch_to_global_generic')
+       ENDIF
+       RETURN
+    END SUBROUTINE wrf_patch_to_global_generic
+
+!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       REAL globbuf(*)
+       REAL buf(*)
+! 
+! Collective operation. Given a global 2- or 3-dimensional array of type real on task zero,
+! return the appropriate decomposed section (patch) on each processor.
+! 
+! 
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,TRUE_RSL_REAL,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_real
+
+    SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       DOUBLEPRECISION globbuf(*)
+       DOUBLEPRECISION buf(*)
+! 
+! Collective operation. Given a global 2- or 3-dimensional array of type double on task zero,
+! return the appropriate decomposed section (patch) on each processor.
+! 
+! 
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RSL_DOUBLE,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_double
+
+
+    SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       INTEGER globbuf(*)
+       INTEGER buf(*)
+! 
+! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
+! return the appropriate decomposed section (patch) on each processor.
+! 
+! 
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_integer
+
+    SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       LOGICAL globbuf(*)
+       LOGICAL buf(*)
+! 
+! Collective operation. Given a global 2- or 3-dimensional array of type integer on task zero,
+! return the appropriate decomposed section (patch) on each processor.
+!
+! 
+
+       IF ( LWORDSIZE .NE. IWORDSIZE ) THEN
+         CALL wrf_error_fatal( "RSL module_dm: LWORDSIZE != IWORDSIZE on this machine. RSL cannot cast" ) 
+       ENDIF
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,rsl_integer,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_logical
+
+    SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,type,&
+                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
+       USE module_driver_constants
+       IMPLICIT NONE
+#include "rsl.inc"
+       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A 
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc,type
+       REAL globbuf(*)
+       REAL buf(*)
+       LOGICAL, EXTERNAL :: has_char
+
+       INTEGER i,j,k,ord,ord2d,ndim
+       INTEGER glen(3),llen(3),glen2d(3),llen2d(3)
+
+       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
+       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
+       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
+
+       ndim = len(TRIM(ordering))
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xyz','xy' )
+           ord = io3d_ijk_internal ; ord2d = io2d_ij_internal
+            ! the non-staggered variables come in at one-less than
+            ! domain dimensions, but RSL wants full domain spec, so 
+            ! adjust if not staggered
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'yxz','yx' )
+           ord = io3d_jik_internal ; ord2d = io2d_ji_internal
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'zxy' )
+           ord = io3d_kij_internal ; ord2d = io2d_ij_internal
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
+#if 0
+         CASE ( 'zyx' )
+           ord = io3d_kji_internal ; ord2d = io2d_ji_internal
+         CASE ( 'yzx' )
+           ord = io3d_jki_internal ; ord2d = io2d_ji_internal
+#endif
+         CASE ( 'xzy' )
+           ord = io3d_ikj_internal ; ord2d = io2d_ij_internal
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
+         CASE DEFAULT
+           ord = -1 ; ord2d = -1
+       END SELECT
+
+       glen(1) = DE1-DS1+1   ; glen(2) = DE2-DS2+1   ; glen(3) = DE3-DS3+1
+       llen(1) = ME1-MS1+1   ; llen(2) = ME2-MS2+1   ; llen(3) = ME3-MS3+1
+       glen2d(1) = DE1-DS1+1 ; glen2d(2) = DE2-DS2+1
+       llen2d(1) = ME1-MS1+1 ; llen2d(2) = ME2-MS2+1
+
+       IF ( ndim .EQ. 3 ) THEN
+         CALL rsl_read(globbuf,ord,buf,domdesc,type,glen,llen)
+       ELSE
+         CALL rsl_read(globbuf,ord2d,buf,domdesc,type,glen2d,llen2d)
+       ENDIF
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_generic
+
+
+!------------------------------------------------------------------
+
+#if ( EM_CORE == 1 )
+
+!------------------------------------------------------------------
+
+   SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags   &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "em_dummy_new_decl.inc"
+#include "em_i1_decl.inc"
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+! 
+! Description is to do...
+! 
+
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#      include "em_data_calls.inc"
+#endif
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#  include "em_nest_interpdown_unpack.inc"
+
+#include "HALO_EM_FORCE_DOWN.inc"
+
+      ! code here to interpolate the data into the nested domain
+#  include "em_nest_forcedown_interp.inc"
+
+      RETURN
+   END SUBROUTINE force_domain_em_part2
+
+
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+#include "em_dummy_new_decl.inc"
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+
+!
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  intermediate_grid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#  include "em_nest_interpdown_pack.inc"
+
+      CALL rsl_bcast_msgs
+
+      RETURN
+   END SUBROUTINE interp_domain_em_part1
+
+   SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "em_dummy_new_decl.inc"
+#include "em_i1_decl.inc"
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#      include "em_data_calls.inc"
+#endif
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1 
+
+#  include "em_nest_interpdown_unpack.inc"
+
+#include "HALO_EM_INTERP_DOWN.inc"
+      ! code here to interpolate the data into the nested domain
+
+#  include "em_nest_interpdown_interp.inc"
+
+      RETURN
+   END SUBROUTINE interp_domain_em_part2
+
+!------------------------------------------------------------------
+! This routine exists only to call a halo on a domain (the nest)
+! gets called from feedback_domain_em_part1, below.  This is needed
+! because the halo code expects the fields being exchanged to have
+! been dereferenced from the grid data structure, but in feedback_domain_em_part1
+! the grid data structure points to the coarse domain, not the nest.
+! And we want the halo exchange on the nest, so that the code in 
+! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
+!
+   SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+)
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_state_description
+!
+      TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of 
+                                                  ! soil temp, moisture, etc., has vertical dim
+                                                  ! of soil categories
+#include "em_dummy_new_decl.inc"
+
+#ifdef DM_PARALLEL
+#      include "em_data_calls.inc"
+#endif
+
+#ifdef DM_PARALLEL
+# include "HALO_EM_INTERP_UP.inc"
+#endif
+
+   END SUBROUTINE feedback_nest_prep
+
+   SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "em_dummy_new_decl.inc"
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE(domain), POINTER :: xgrid
+      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTERFACE 
+          SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+)
+             USE module_domain
+             USE module_configure
+             USE module_dm
+             USE module_state_description
+!
+             TYPE (grid_config_rec_type)            :: config_flags
+             TYPE(domain), TARGET                   :: grid
+#include "em_dummy_new_decl.inc"
+          END SUBROUTINE feedback_nest_prep
+
+      END INTERFACE
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,                  &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+      ips_save = ngrid%i_parent_start   ! used in feedback_domain_em_part2 below
+      jps_save = ngrid%j_parent_start
+      ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
+      jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
+
+      CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
+      CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
+
+      xgrid => grid
+      grid => ngrid 
+
+      CALL feedback_nest_prep ( grid, nconfig_flags    &
+!
+#include "em_actual_new_args.inc"
+!
+)
+
+      grid => xgrid
+      CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+
+#  include "em_nest_feedbackup_interp.inc"
+
+      RETURN
+   END SUBROUTINE feedback_domain_em_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+#include "em_dummy_new_decl.inc"
+#include "em_i1_decl.inc"
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      REAL          :: nest_influence
+      LOGICAL, EXTERNAL  :: em_cd_feedback_mask
+
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#      include "em_data_calls.inc"
+#endif
+
+      nest_influence = 1.
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  intermediate_grid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#  include "em_nest_feedbackup_pack.inc"
+
+      CALL rsl_merge_msgs
+
+#define NEST_INFLUENCE(A,B) A = B
+#  include "em_nest_feedbackup_unpack.inc"
+
+      ! smooth coarse grid 
+
+      CALL get_ijk_from_grid (  ngrid,                           &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+#  include "HALO_EM_INTERP_UP.inc"
+#  include "em_nest_feedbackup_smooth.inc"
+
+      RETURN
+   END SUBROUTINE feedback_domain_em_part2
+
+#endif
+
+!------------------------------------------------------------------
+
+#if ( NMM_CORE == 1 )
+!==============================================================================
+! NMM nesting infrastructure extended from EM core. This is gopal's doing.
+!==============================================================================
+
+   SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part1
+
+   SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part2
+
+   SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE force_domain_nmm_part1
+
+   SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE force_domain_nmm_part2
+
+   SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE feedback_domain_nmm_part1
+
+   SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_utility
+      IMPLICIT NONE
+
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+
+#include "nmm_dummy_decl.inc"
+      TYPE (grid_config_rec_type)            :: config_flags
+
+      CALL wrf_error_fatal ( 'module_dm: NMM nesting does not support RSL' )
+
+      RETURN
+   END SUBROUTINE feedback_domain_nmm_part2
+
+!=================================================================================
+!   End of gopal's doing
+!=================================================================================
+#endif
+
+
+
+#ifndef STUBMPI
+
+   SUBROUTINE wrf_gatherv_real (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            getrealmpitype()         ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            getrealmpitype()                       , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_real
+
+   SUBROUTINE wrf_gatherv_integer (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_INTEGER         ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_INTEGER                       , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_integer
+
+   SUBROUTINE wrf_gatherv_double (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! if we were not indexing the globbuf and Field arrays it would not even matter
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_DOUBLE_PRECISION         ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_DOUBLE_PRECISION                      , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_double
+
+!new stuff 20070124
+   SUBROUTINE wrf_scatterv_real (                             &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            getrealmpitype()               , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            getrealmpitype() ,               &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_real
+
+   SUBROUTINE wrf_scatterv_double (                           &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! if we were not indexing the globbuf and Field arrays it would not even matter
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_DOUBLE_PRECISION           , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_DOUBLE_PRECISION         ,   &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_double
+
+   SUBROUTINE wrf_scatterv_integer (                          &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_INTEGER                    , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_INTEGER         ,            &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_integer
+! end new stuff 20070124
+
+#endif
diff --git a/wrfv2_fire/external/RSL/rsl_cpp_flags b/wrfv2_fire/external/RSL/rsl_cpp_flags
new file mode 100644
index 00000000..0963508b
--- /dev/null
+++ b/wrfv2_fire/external/RSL/rsl_cpp_flags
@@ -0,0 +1,34 @@
+-DWRF_RSL_LF_NCOMMS=33
+-DHALO_LF_INIT=1
+-DHALO_LF_A=2
+-DHALO_LF_B=3
+-DHALO_LF_C=4
+-DHALO_LF_D=5
+-DHALO_LF_E=6
+-DHALO_LF_MOIST=7
+-DHALO_LF_CHEM=8
+-DPERIOD_BDY_LF_A=9
+-DPERIOD_BDY_LF_B=10
+-DPERIOD_BDY_LF_C=11
+-DPERIOD_BDY_LF_D=12
+-DPERIOD_BDY_LF_MOIST=13
+-DPERIOD_BDY_LF_CHEM=14
+-DPERIOD_BDY_LF_INIT=15
+-DPERIOD_BDY_LF_MOUNTAIN=16
+-DHALO_RK_INIT=17
+-DHALO_RK_A=18
+-DHALO_RK_B=19
+-DHALO_RK_C=20
+-DHALO_RK_D=21
+-DHALO_RK_E=22
+-DHALO_RK_MOIST=23
+-DHALO_RK_CHEM=24
+-DPERIOD_BDY_RK_A=25
+-DPERIOD_BDY_RK_B=26
+-DPERIOD_BDY_RK_C=27
+-DPERIOD_BDY_RK_D=28
+-DPERIOD_BDY_RK_MOIST=29
+-DPERIOD_BDY_RK_CHEM=30
+-DPERIOD_BDY_RK_INIT=31
+-DPERIOD_BDY_RK_MOUNTAIN=32
+-DHALO_RK_PHYS_A=33
diff --git a/wrfv2_fire/external/RSL_LITE/buf_for_proc.c b/wrfv2_fire/external/RSL_LITE/buf_for_proc.c
new file mode 100755
index 00000000..bcb67263
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/buf_for_proc.c
@@ -0,0 +1,167 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#include 
+#include 
+#include "rsl_lite.h"
+#include "mpi.h"
+
+typedef struct bufdesc {
+  char * buf ;
+  int size ;
+} bufdesc_t ;
+
+/* buftab[RSL_SENDBUF] is send buffer descriptor,
+   buftab[RSL_RECVBUF] is recv buffer descriptor. */
+static bufdesc_t buftab[2][RSL_MAXPROC] ;
+static int first = 1 ;
+
+/* 
+   buffer_for_proc
+
+   returns a pointer to a buffer already allocated for processor P if
+   it is big enough; otherwise, it frees the existing buffer, if there
+   is one and then allocates a new one that is big enough.  If RSL_FREEBUF
+   is called for a P, the two buffers (send and recv) are truncated and
+   freed and NULL is returned.
+
+   You are guaranteed to get back the same buffer as the previous call
+   for a given P, as long as the size is less than the size passed to
+   the previous call.  Thus, you can use this routine to manage the
+   pointers to the buffers for P and avoid having to set up arrays
+   of pointers in the routines that use these buffers.
+
+*/
+
+char mess[1024] ;
+
+char *
+buffer_for_proc( P, size, code )
+  int P ;   /* processor number */
+  int size,		/* requested size */
+      code ;		/* RSL_SENDBUF, RSL_RECVBUF, or RSL_FREEBUF */
+{
+  int p ;
+  int i, j ;
+  char * ret ;
+
+  ret = NULL ;
+  if ( first )
+  {
+    for ( p = 0 ; p < RSL_MAXPROC ; p++ )
+    {
+      buftab[0][p].buf  = NULL ;    
+      buftab[1][p].buf  = NULL ;    
+      buftab[0][p].size = 0 ;    
+      buftab[1][p].size = 0 ;    
+    }
+    first = 0 ;
+  }
+  if ( P < 0 || P >= RSL_MAXPROC )
+  {
+    sprintf(mess,"Bad P argument to buffer_for_proc.  P = %d. Has RSL_MESH been called?\n",P) ;
+    RSL_TEST_ERR( 1, mess ) ;
+  }
+  if ( code == RSL_FREEBUF )
+  {
+/* fprintf(stderr,"buffer_for_proc freeing buffer %d\n",P) ; */
+    if ( buftab[0][P].buf != NULL ) RSL_FREE( buftab[0][P].buf ) ;
+    if ( buftab[1][P].buf != NULL ) RSL_FREE( buftab[1][P].buf ) ;
+    buftab[0][P].buf  = NULL ;    
+    buftab[1][P].buf  = NULL ;    
+    buftab[0][P].size = 0 ;    
+    buftab[1][P].size = 0 ;    
+/* show_tot_size() ; */
+  }
+  else if ( code == RSL_SENDBUF || code == RSL_RECVBUF )
+  {
+    if ( buftab[code][P].size < size )
+    {
+#if 0
+fprintf(stderr,"buffer_for_proc %s %d : was %d, increasing to %d\n",
+         (code == RSL_SENDBUF)?"RSL_SENDBUF":"RSL_RECVBUF",
+	 P,buftab[code][P].size, size+512) ;
+#endif
+      if ( buftab[code][P].buf != NULL ) RSL_FREE( buftab[code][P].buf ) ;
+      buftab[code][P].buf = RSL_MALLOC(char,size+512) ;
+      buftab[code][P].size = size+512 ;
+/* show_tot_size() ; */
+    }
+    ret = buftab[code][P].buf ;
+  }
+  return(ret) ;
+}
+
+show_tot_size()
+{
+  int P ;
+  int acc ;
+  acc = 0 ;
+  for ( P = 0 ; P < RSL_MAXPROC ; P++ )
+  {
+    acc += buftab[0][P].size ;
+    acc += buftab[1][P].size ;
+  }
+  fprintf(stderr,"Total bytes allocated for buffers: %d\n", acc ) ;
+}
+
+int
+buffer_size_for_proc( P, code )
+  int P ;
+  int code ;
+{
+  return( buftab[code][P].size ) ;
+}
diff --git a/wrfv2_fire/external/RSL_LITE/c_code.c b/wrfv2_fire/external/RSL_LITE/c_code.c
new file mode 100755
index 00000000..ddeea10a
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/c_code.c
@@ -0,0 +1,476 @@
+#include 
+#include 
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#include "mpi.h"
+#include "rsl_lite.h"
+
+#define F_PACK
+
+RSL_LITE_ERROR_DUP1 ( int *me )
+{
+    int newfd ;
+    char filename[256] ;
+    char hostname[256] ;
+
+    gethostname( hostname, 256 ) ;
+
+/* redirect standard out*/
+    sprintf(filename,"rsl.out.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+        perror("error_dup: cannot open rsl.out.nnnn") ;
+        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+        return ;
+    }
+    if( dup2( newfd, STANDARD_OUTPUT ) < 0 )
+    {
+        perror("error_dup: dup2 fails to change output descriptor") ;
+        fprintf(stderr,"...sending output to standard output and continuing.\n") ;
+        close(newfd) ;
+        return ;
+    }
+
+/* redirect standard error */
+    sprintf(filename,"rsl.error.%04d",*me) ;
+    if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+    {
+        perror("error_dup: cannot open rsl.error.log") ;
+        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+        return ;
+    }
+    if( dup2( newfd, STANDARD_ERROR ) < 0 )
+    {
+        perror("error_dup: dup2 fails to change error descriptor") ;
+        fprintf(stderr,"...sending error to standard error and continuing.\n") ;
+        close(newfd) ;
+        return ;
+    }
+    fprintf( stdout, "taskid: %d hostname: %s\n",*me,hostname) ;
+    fprintf( stderr, "taskid: %d hostname: %s\n",*me,hostname) ;
+
+}
+
+BYTE_BCAST ( char * buf, int * size, int * Fcomm )
+{
+    MPI_Comm *comm, dummy_comm ;
+
+    comm = &dummy_comm ;
+    *comm = MPI_Comm_f2c( *Fcomm ) ;
+#ifdef crayx1
+    if (*size % sizeof(int) == 0) {
+       MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, 0, *comm ) ;
+    } else {
+       MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
+    }
+#else
+    MPI_Bcast ( buf, *size, MPI_BYTE, 0, *comm ) ;
+#endif
+}
+
+static int yp_curs, ym_curs, xp_curs, xm_curs ;
+
+RSL_LITE_INIT_EXCH ( 
+                int * Fcomm0,
+                int * shw0,
+                int * n3dR0, int *n2dR0, int * typesizeR0 , 
+                int * n3dI0, int *n2dI0, int * typesizeI0 , 
+                int * n3dD0, int *n2dD0, int * typesizeD0 , 
+                int * n3dL0, int *n2dL0, int * typesizeL0 , 
+                int * me0, int * np0 , int * np_x0 , int * np_y0 ,
+                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int n3dR, n2dR, typesizeR ;
+  int n3dI, n2dI, typesizeI ;
+  int n3dD, n2dD, typesizeD ;
+  int n3dL, n2dL, typesizeL ;
+  int shw ;
+  int me, np, np_x, np_y ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int yp, ym, xp, xm ;
+  int nbytes ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  shw = *shw0 ;
+  n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
+  n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
+  n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
+  n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+
+#if 1
+
+  if ( np_y > 1 ) {
+    nbytes = typesizeR*(ipe-ips+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
+             typesizeI*(ipe-ips+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
+             typesizeD*(ipe-ips+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
+             typesizeL*(ipe-ips+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
+    MPI_Cart_shift ( *comm0, 0, 1, &ym, &yp ) ;
+    if ( yp != MPI_PROC_NULL ) {
+       buffer_for_proc ( yp , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( ym != MPI_PROC_NULL ) {
+       buffer_for_proc ( ym , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+  if ( np_x > 1 ) {
+    nbytes = typesizeR*(jpe-jps+1+2*shw)*shw*(n3dR*(kpe-kps+1)+n2dR) +
+             typesizeI*(jpe-jps+1+2*shw)*shw*(n3dI*(kpe-kps+1)+n2dI) +
+             typesizeD*(jpe-jps+1+2*shw)*shw*(n3dD*(kpe-kps+1)+n2dD) +
+             typesizeL*(jpe-jps+1+2*shw)*shw*(n3dL*(kpe-kps+1)+n2dL) ;
+    MPI_Cart_shift ( *comm0, 1, 1, &xm, &xp ) ;
+    if ( xp != MPI_PROC_NULL ) {
+       buffer_for_proc ( xp , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( xm != MPI_PROC_NULL ) {
+       buffer_for_proc ( xm , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+}
+
+RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * xstag0, /* not used */
+           int *me0, int * np0 , int * np_x0 , int * np_y0 , 
+           int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+           int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
+           int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int me, np, np_x, np_y ;
+  int shw , typesize ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ims , ime , jms , jme , kms , kme ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int xy ;   /* y = 0 , x = 1 */
+  int pu ;   /* pack = 0 , unpack = 1 */
+  register int i, j, k, t ;
+#ifdef crayx1
+  register int i2,i3,i4,i_offset;
+#endif
+  char *p ;
+  int da_buf ;
+  int yp, ym, xp, xm ;
+  int nbytes, ierr ;
+  register int *pi, *qi ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int js, je, ks, ke, is, ie, wcount ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  shw = *shw0 ; typesize = *typesize0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+  xy = *xy0 ;
+  pu = *pu0 ;
+
+/* need to adapt for other memory orders */
+
+#define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
+#define IMAX(A) (((A)>ids)?(A):ids)
+#define IMIN(A) (((A)jds)?(A):jds)
+#define JMIN(A) (((A) 1 && xy == 0 ) {
+    MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
+    if ( yp != MPI_PROC_NULL ) {
+      p = buffer_for_proc( yp , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        js = jpe-shw+1     ; je = jpe ;
+        ks = kps           ; ke = kpe ;
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        nbytes = buffer_size_for_proc( yp, da_buf ) ;
+	if ( yp_curs + RANGE( jpe-shw+1, jpe, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack up, %d > %d\n",
+	      yp_curs + RANGE( jpe-shw+1, jpe, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 99) ;
+        }
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie, 
+                                              &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      } else {
+        js = jpe+1         ; je = jpe+shw ;
+        ks = kps           ; ke = kpe ;
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+	}
+      }
+    }
+    if ( ym != MPI_PROC_NULL ) {
+      p = buffer_for_proc( ym , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        js = jps           ; je = jps+shw-1 ;
+        ks = kps           ; ke = kpe ;
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        nbytes = buffer_size_for_proc( ym, da_buf ) ;
+	if ( ym_curs + RANGE( jps, jps+shw-1, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack dn, %d > %d\n",
+	      ym_curs + RANGE( jps, jps+shw-1, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 99) ;
+        }
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+	}
+      } else {
+        js = jps-shw       ; je = jps-1 ;
+        ks = kps           ; ke = kpe ;
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+  }
+
+  if ( np_x > 1 && xy == 1 ) {
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( xp != MPI_PROC_NULL ) {
+      p = buffer_for_proc( xp , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ipe-shw+1     ; ie = ipe ;
+        nbytes = buffer_size_for_proc( xp, da_buf ) ;
+        if ( xp_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
+	      xp_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 99) ;
+        }
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                              &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+	}
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ipe+1         ; ie = ipe+shw ;
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+    if ( xm != MPI_PROC_NULL ) {
+      p = buffer_for_proc( xm , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ips           ; ie = ips+shw-1 ;
+        nbytes = buffer_size_for_proc( xm, da_buf ) ;
+        if ( xm_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack, X left , %d > %d\n",
+	      xm_curs + RANGE( jps-shw, jpe+shw, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 99) ;
+        }
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                              &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+        }
+	else if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                             &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ips-shw       ; ie = ips-1 ;
+        if ( typesize == sizeof(long int) && sizeof( long int ) != sizeof(int) ) {
+          F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                                &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+        } 
+        else if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                               &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+  }
+}
+
+static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
+static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
+
+RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, ierr ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  if ( np_y > 1 ) {
+    MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
+    if ( yp != MPI_PROC_NULL ) {
+      ierr=MPI_Irecv ( buffer_for_proc( yp, yp_curs, RSL_RECVBUF ), yp_curs, MPI_CHAR, yp, me, comm, &yp_recv ) ;
+    }
+    if ( ym != MPI_PROC_NULL ) {
+      ierr=MPI_Irecv ( buffer_for_proc( ym, ym_curs, RSL_RECVBUF ), ym_curs, MPI_CHAR, ym, me, comm, &ym_recv ) ;
+    }
+    if ( yp != MPI_PROC_NULL ) {
+      ierr=MPI_Isend ( buffer_for_proc( yp, 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
+    }
+    if ( ym != MPI_PROC_NULL ) {
+      ierr=MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
+    }
+    if ( yp != MPI_PROC_NULL ) MPI_Wait( &yp_recv, &stat ) ; 
+    if ( ym != MPI_PROC_NULL ) MPI_Wait( &ym_recv, &stat ) ; 
+    if ( yp != MPI_PROC_NULL ) MPI_Wait( &yp_send, &stat ) ; 
+    if ( ym != MPI_PROC_NULL ) MPI_Wait( &ym_send, &stat ) ;
+  }
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+#else 
+fprintf(stderr,"RSL_LITE_EXCH_Y disabled\n") ;
+#endif
+}
+
+RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  if ( np_x > 1 ) {
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( xp != MPI_PROC_NULL ) {
+      MPI_Irecv ( buffer_for_proc( xp, xp_curs, RSL_RECVBUF ), xp_curs, MPI_CHAR, xp, me, comm, &xp_recv ) ;
+    }
+    if ( xm != MPI_PROC_NULL ) {
+      MPI_Irecv ( buffer_for_proc( xm, xm_curs, RSL_RECVBUF ), xm_curs, MPI_CHAR, xm, me, comm, &xm_recv ) ;
+    }
+    if ( xp != MPI_PROC_NULL ) {
+      MPI_Isend ( buffer_for_proc( xp, 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
+    }
+    if ( xm != MPI_PROC_NULL ) {
+      MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
+    }
+    if ( xp != MPI_PROC_NULL ) MPI_Wait( &xp_recv, &stat ) ; 
+    if ( xm != MPI_PROC_NULL ) MPI_Wait( &xm_recv, &stat ) ; 
+    if ( xp != MPI_PROC_NULL ) MPI_Wait( &xp_send, &stat ) ; 
+    if ( xm != MPI_PROC_NULL ) MPI_Wait( &xm_send, &stat ) ;
+  }
+#else 
+fprintf(stderr,"RSL_LITE_EXCH_X disabled\n") ;
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+}
+
+#include 
+RSL_INTERNAL_MILLICLOCK ()
+{
+    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 = 1000 * isec + usec / 1000 ;
+    return(msecs) ;
+}
+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) ;
+}
diff --git a/wrfv2_fire/external/RSL_LITE/cycle.c b/wrfv2_fire/external/RSL_LITE/cycle.c
new file mode 100644
index 00000000..ec1877a0
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/cycle.c
@@ -0,0 +1,356 @@
+#include 
+#include 
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#include "mpi.h"
+#include "rsl_lite.h"
+
+#define  UP_EVEN(A)   ((A)+abs((A)%2))
+#define  DOWN_EVEN(A) ((A) - abs((A)%2))
+#define  UP_ODD(A)    ((A) + abs(((A)+1)%2))
+#define  DOWN_ODD(A)  ((A) - abs(((A)+1)%2))
+#define  MIN(A,B)     ((A)<(B)?(A):(B))
+#define  MAX(A,B)     ((A)>(B)?(A):(B))
+
+static int *y_curs_src = NULL ;
+static int *x_curs_src = NULL ;
+static int *y_curs_dst = NULL ;
+static int *x_curs_dst = NULL ;
+static int *x_peermask_src = NULL ;
+static int *x_peermask_dst = NULL ;
+static int *nbytes_src = NULL ; 
+static int *nbytes_dst = NULL ; 
+static MPI_Request *x_recv = NULL ,  *x_send = NULL ;
+
+RSL_LITE_INIT_CYCLE (  int * Fcomm ,
+                int * xy0 , int * inout0 ,
+                int * n3dR0, int *n2dR0, int * typesizeR0 , 
+                int * n3dI0, int *n2dI0, int * typesizeI0 , 
+                int * n3dD0, int *n2dD0, int * typesizeD0 , 
+                int * n3dL0, int *n2dL0, int * typesizeL0 , 
+                int * me0, int * np0 , int * np_x0 , int * np_y0 ,
+                int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int n3dR, n2dR, typesizeR ;
+  int n3dI, n2dI, typesizeI ;
+  int n3dD, n2dD, typesizeD ;
+  int n3dL, n2dL, typesizeL ;
+  int xy, inout ;
+  int me, np, np_x, np_y, np_dim ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int ips_send , ipe_send ;
+  int npts, i, ii, j, jj, m, n, ps, pe, ops, ope ;
+  int Px, Py, P, Q, swap, coords[2] ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  xy = *xy0 ;
+  inout = *inout0 ;     /* 1 is in (uncycled to cycled) 0 is out */
+  n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
+  n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
+  n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
+  n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+
+  if ( nbytes_src == NULL ) nbytes_src = RSL_MALLOC ( int , np ) ;
+  if ( nbytes_dst == NULL ) nbytes_dst = RSL_MALLOC ( int , np ) ;
+  if ( x_curs_src == NULL ) x_curs_src = RSL_MALLOC ( int , np ) ;
+  if ( x_curs_dst == NULL ) x_curs_dst = RSL_MALLOC ( int , np ) ;
+  if ( x_peermask_src == NULL ) x_peermask_src = RSL_MALLOC ( int , np ) ;
+  if ( x_peermask_dst == NULL ) x_peermask_dst = RSL_MALLOC ( int , np ) ;
+  if ( x_recv == NULL ) x_recv = RSL_MALLOC ( MPI_Request , np ) ;
+  if ( x_send == NULL ) x_send = RSL_MALLOC ( MPI_Request , np ) ;
+  for ( i = 0 ; i < np ; i++ ) { nbytes_src[i] = 0 ; x_curs_src[i] = 0 ; x_peermask_src[i] = 0 ; }
+  for ( i = 0 ; i < np ; i++ ) { nbytes_dst[i] = 0 ; x_curs_dst[i] = 0 ; x_peermask_dst[i] = 0 ; }
+
+  if ( xy == 1 ) {   /* xy = 1, cycle in X, otherwise Y */
+    np_dim = np_x ;
+    ps = ips ;
+    pe = ipe ;
+    ops = jps ;
+    ope = jpe ;
+    m = (ide-ids+1)/np_dim ;
+    n = (m*np_dim)/m ;
+  } else {
+    np_dim = np_y ;
+    ps = jps ;
+    pe = jpe ;
+    ops = ips ;
+    ope = ipe ;
+    m = (jde-jds+1)/np_dim ;
+    n = (m*np_dim)/m ;
+  }
+
+  for ( i = ps ; i <= MIN(pe,m*np_dim) ; i++ ) {
+    ii = (i/n) + (i%n)*m ;
+    jj = (i/m) + (i%m)*n ;
+    if ( xy == 1 ) {
+      TASK_FOR_POINT ( &ii , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+      TASK_FOR_POINT ( &jj , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &Q ) ;
+    } else {
+      TASK_FOR_POINT ( &ips , &ii , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+      TASK_FOR_POINT ( &ips , &jj , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &Q ) ;
+    }
+    if ( inout == 0 ) { swap = P ; P = Q ; Q = swap ; }
+
+    nbytes_src[P] += typesizeR*(ope-ops+1)*(n3dR*(kpe-kps+1)+n2dR) +
+                     typesizeI*(ope-ops+1)*(n3dI*(kpe-kps+1)+n2dI) +
+                     typesizeD*(ope-ops+1)*(n3dD*(kpe-kps+1)+n2dD) +
+                     typesizeL*(ope-ops+1)*(n3dL*(kpe-kps+1)+n2dL) ;
+
+    nbytes_dst[Q] += typesizeR*(ope-ops+1)*(n3dR*(kpe-kps+1)+n2dR) +
+                     typesizeI*(ope-ops+1)*(n3dI*(kpe-kps+1)+n2dI) +
+                     typesizeD*(ope-ops+1)*(n3dD*(kpe-kps+1)+n2dD) +
+                     typesizeL*(ope-ops+1)*(n3dL*(kpe-kps+1)+n2dL) ;
+  }
+
+  for ( P = 0 ; P < np ; P++ ) {
+       buffer_for_proc ( P , nbytes_src[P], RSL_SENDBUF ) ;
+       buffer_for_proc ( P , nbytes_dst[P], RSL_RECVBUF ) ;
+  }
+}
+
+RSL_LITE_PACK_CYCLE ( int * Fcomm, char * buf , int * inout0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 ,
+           int *me0, int * np0 , int * np_x0 , int * np_y0 , 
+           int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+           int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
+           int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int me, np, np_x, np_y, np_dim ;
+  int inout , typesize ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ims , ime , jms , jme , kms , kme ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int xstag ;  /* 0 not stag, 1 stag */
+  int xy ;   /* y = 0 , x = 1 */
+  int pu ;   /* pack = 0 , unpack = 1 */
+  int i, ii, j, jj, m, n  ;
+  int ps, pe, ops, ope ;
+  register int k, t ;
+#ifdef crayx1
+  register int i2,i3,i4,i_offset;
+#endif
+  char *p ;
+  int da_buf ;
+  int Px, Py, P, coords[2] ;
+  int ierr = 0 ;
+  register int *pi, *qi ;
+  float f ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  xstag = *xstag0 ;
+  inout = *inout0 ; typesize = *typesize0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+  xy = *xy0 ;
+  pu = *pu0 ;
+
+/* need to adapt for other memory orders */
+#define IMAX(A) (((A)>ids)?(A):ids)
+#define IMIN(A) (((A)jds)?(A):jds)
+#define JMIN(A) (((A) 1 && xy == 1 ) {
+
+    for ( i = ips ; i <= MIN(ipe,m*np_dim-1) ; i++ ) {
+      if ( pu == 0 ) {
+        ii = (inout)?(i/n)+(i%n)*m:(i/m)+(i%m)*n  ;
+        TASK_FOR_POINT ( &ii , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+        coords[1] = Px ; coords[0] = Py ;
+        MPI_Cart_rank( *comm, coords, &P ) ;
+        p = buffer_for_proc( P , 0 , da_buf ) ;
+	if ( typesize == sizeof(int) ) {
+          for ( j = jps ; j <= jpe ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs_src[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *pi++ = *qi++ ;
+	      x_curs_src[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( j = jps ; j <= jpe ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                *(p+x_curs_src[P]) = 
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) ;
+                x_curs_src[P]++ ;
+              }
+            }
+          }
+	}
+      } else {
+        ii = (inout)?(i/m)+(i%m)*n:(i/n)+(i%n)*m  ;
+        TASK_FOR_POINT ( &ii , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+        coords[1] = Px ; coords[0] = Py ;
+        MPI_Cart_rank( *comm, coords, &P ) ;
+        p = buffer_for_proc( P , 0 , da_buf ) ;
+	if ( typesize == sizeof(int) ) {
+          for ( j = jps ; j <= jpe ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs_dst[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *qi++ = *pi++ ;
+	      x_curs_dst[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( j = jps ; j <= jpe ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) =
+                *(p+x_curs_dst[P]) ;
+                x_curs_dst[P]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  } else if ( np_y > 1 && xy == 0 ) {
+    for ( j = jps ; j <= MIN(jpe,m*np_dim-1) ; j++ ) {
+      if ( pu == 0 ) {
+        jj = (inout)?(j/n) + (j%n)*m:(j/m) + (j%m)*n ;
+        TASK_FOR_POINT ( &ips , &jj , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+        coords[1] = Px ; coords[0] = Py ;
+        MPI_Cart_rank( *comm, coords, &P ) ;
+        p = buffer_for_proc( P , 0 , da_buf ) ;
+	if ( typesize == sizeof(int) ) {
+          for ( i = ips ; i <= ipe ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs_src[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *pi++ = *qi++ ;
+	      x_curs_src[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( i = ips ; i <= ipe ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                *(p+x_curs_src[P]) = 
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) ;
+                x_curs_src[P]++ ;
+              }
+            }
+          }
+	}
+      } else {
+        jj = (inout)?(j/m) + (j%m)*n:(j/n) + (j%n)*m ;
+        TASK_FOR_POINT ( &ips , &jj , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+        coords[1] = Px ; coords[0] = Py ;
+        MPI_Cart_rank( *comm, coords, &P ) ;
+        p = buffer_for_proc( P , 0 , da_buf ) ;
+	if ( typesize == sizeof(int) ) {
+          for ( i = ips ; i <= ipe ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs_dst[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *qi++ = *pi++ ;
+	      x_curs_dst[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( i = ips ; i <= ipe ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) =
+                *(p+x_curs_dst[P]) ;
+                x_curs_dst[P]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
+RSL_LITE_CYCLE ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, nb ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int i, P ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+
+/* fprintf(stderr,"RSL_LITE_CYCLE\n") ; */
+
+  for ( P = 0 ; P < np ; P++ ) {
+      nb = buffer_size_for_proc( P, RSL_RECVBUF ) ;
+/* fprintf(stderr,"posting irecv from %d, nb = %d\n",P,nb) ; */
+      MPI_Irecv ( buffer_for_proc( P, 0, RSL_RECVBUF ), nb, MPI_CHAR, P, me, comm, &(x_recv[P]) ) ;
+/* fprintf(stderr,"sending to         %d, nb = %d\n",P,x_curs_src[P]) ; */
+      MPI_Isend ( buffer_for_proc( P, 0, RSL_SENDBUF ), x_curs_src[P], MPI_CHAR, P, P, comm, &(x_send[P]) ) ;
+  }
+  for ( P = 0 ; P < np ; P++ ) {
+      MPI_Wait( &x_recv[P], &stat ) ; 
+      MPI_Wait( &x_send[P], &stat ) ; 
+  }
+#else 
+fprintf(stderr,"RSL_LITE_CYCLE disabled\n") ;
+#endif
+  for ( i = 0 ; i < np ; i++ ) {  x_curs_src[i] = 0 ; x_curs_dst[i] ; }
+}
+
diff --git a/wrfv2_fire/external/RSL_LITE/f_pack.F90 b/wrfv2_fire/external/RSL_LITE/f_pack.F90
new file mode 100644
index 00000000..8c33aea8
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/f_pack.F90
@@ -0,0 +1,645 @@
+      MODULE duplicate_of_driver_constants
+! These definitions must be the same as frame/module_driver_constants
+! and also the same as the definitions in rsl_lite.h
+         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
+      END MODULE duplicate_of_driver_constants
+
+      SUBROUTINE f_pack_int ( inbuf, outbuf, memorder, js, je, ks, ke,            &
+     &                    is, ie, jms, jme, kms, kme, ims, ime, curs )
+        USE duplicate_of_driver_constants
+        IMPLICIT NONE
+        INTEGER, INTENT(IN) ::  memorder
+        INTEGER ims, ime, jms, jme, kms, kme
+        INTEGER inbuf(*), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            CALL f_pack_int_ijk( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YXZ )
+            CALL f_pack_int_jik( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_XZY )
+            CALL f_pack_int_ikj( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YZX )
+            CALL f_pack_int_jki( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZXY )
+            CALL f_pack_int_kij( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZYX )
+            CALL f_pack_int_kji( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+        END SELECT
+        RETURN
+      END SUBROUTINE f_pack_int
+     
+      SUBROUTINE f_pack_lint ( inbuf, outbuf, memorder, js, je, ks, ke,           &
+     &                     is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        USE duplicate_of_driver_constants
+        IMPLICIT NONE
+        INTEGER, INTENT(IN) ::  memorder
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(*), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            CALL f_pack_lint_ijk( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YXZ )
+            CALL f_pack_lint_jik( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_XZY )
+            CALL f_pack_lint_ikj( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YZX )
+            CALL f_pack_lint_jki( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZXY )
+            CALL f_pack_lint_kij( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZYX )
+            CALL f_pack_lint_kji( inbuf, outbuf, js, je, ks, ke, is, ie,           &
+     &                           jms, jme, kms, kme, ims, ime, curs )
+        END SELECT
+        RETURN
+      END SUBROUTINE f_pack_lint
+     
+      SUBROUTINE f_unpack_int ( inbuf, outbuf, memorder, js, je, ks, ke,           &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        USE duplicate_of_driver_constants
+        IMPLICIT NONE
+        INTEGER, INTENT(IN) ::  memorder
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(*), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            CALL f_unpack_int_ijk( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YXZ )
+            CALL f_unpack_int_jik( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_XZY )
+            CALL f_unpack_int_ikj( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YZX )
+            CALL f_unpack_int_jki( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZXY )
+            CALL f_unpack_int_kij( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZYX )
+            CALL f_unpack_int_kji( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+        END SELECT
+        RETURN
+      END SUBROUTINE f_unpack_int
+     
+      SUBROUTINE f_unpack_lint ( inbuf, outbuf, memorder, js, je, ks,               &
+     &                 ke, is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        USE duplicate_of_driver_constants
+        IMPLICIT NONE
+        INTEGER, INTENT(IN) ::  memorder
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(*), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            CALL f_unpack_lint_ijk( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YXZ )
+            CALL f_unpack_lint_jik( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_XZY )
+            CALL f_unpack_lint_ikj( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_YZX )
+            CALL f_unpack_lint_jki( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZXY )
+            CALL f_unpack_lint_kij( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+          CASE ( DATA_ORDER_ZYX )
+            CALL f_unpack_lint_kji( inbuf, outbuf, js, je, ks, ke,                   &
+     &                      is, ie, jms, jme, kms, kme, ims, ime, curs )
+        END SELECT
+        RETURN
+      END SUBROUTINE f_unpack_lint
+
+!ikj
+      SUBROUTINE f_pack_int_ikj ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(ims:ime,kms:kme,jms:jme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO k = ks, ke
+            DO i = is, ie
+              outbuf(p) = inbuf(i,k,j)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_ikj
+     
+      SUBROUTINE f_pack_lint_ikj ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(ims:ime,kms:kme,jms:jme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO k = ks, ke
+            DO i = is, ie
+              outbuf(p) = inbuf(i,k,j)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_ikj
+     
+      SUBROUTINE f_unpack_int_ikj ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(ims:ime,kms:kme,jms:jme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO k = ks, ke
+            DO i = is, ie
+              outbuf(i,k,j) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_ikj
+     
+      SUBROUTINE f_unpack_lint_ikj ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(ims:ime,kms:kme,jms:jme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO k = ks, ke
+            DO i = is, ie
+              outbuf(i,k,j) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_ikj
+
+!jki
+      SUBROUTINE f_pack_int_jki ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(jms:jme,kms:kme,ims:ime), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+            DO i = is, ie
+          DO k = ks, ke
+        DO j = js, je
+              outbuf(p) = inbuf(j,k,i)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_jki
+     
+      SUBROUTINE f_pack_lint_jki ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(jms:jme,kms:kme,ims:ime), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+            DO i = is, ie
+          DO k = ks, ke
+        DO j = js, je
+              outbuf(p) = inbuf(j,k,i)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_jki
+     
+      SUBROUTINE f_unpack_int_jki ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(jms:jme,kms:kme,ims:ime), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+            DO i = is, ie
+          DO k = ks, ke
+        DO j = js, je
+              outbuf(j,k,i) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_jki
+     
+      SUBROUTINE f_unpack_lint_jki ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(jms:jme,kms:kme,ims:ime), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+            DO i = is, ie
+          DO k = ks, ke
+        DO j = js, je
+              outbuf(j,k,i) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_jki
+
+!ijk
+      SUBROUTINE f_pack_int_ijk ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(ims:ime,jms:jme,kms:kme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO j = js, je
+            DO i = is, ie
+              outbuf(p) = inbuf(i,j,k)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_ijk
+     
+      SUBROUTINE f_pack_lint_ijk ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(ims:ime,jms:jme,kms:kme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO j = js, je
+            DO i = is, ie
+              outbuf(p) = inbuf(i,j,k)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_ijk
+     
+      SUBROUTINE f_unpack_int_ijk ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(ims:ime,jms:jme,kms:kme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO j = js, je
+            DO i = is, ie
+              outbuf(i,j,k) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_ijk
+     
+      SUBROUTINE f_unpack_lint_ijk ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(ims:ime,jms:jme,kms:kme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO j = js, je
+            DO i = is, ie
+              outbuf(i,j,k) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_ijk
+     
+!jik
+      SUBROUTINE f_pack_int_jik ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(jms:jme,ims:ime,kms:kme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO i = is, ie
+            DO j = js, je
+              outbuf(p) = inbuf(j,i,k)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_jik
+     
+      SUBROUTINE f_pack_lint_jik ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(jms:jme,ims:ime,kms:kme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO i = is, ie
+            DO j = js, je
+              outbuf(p) = inbuf(j,i,k)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_jik
+     
+      SUBROUTINE f_unpack_int_jik ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(jms:jme,ims:ime,kms:kme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO i = is, ie
+            DO j = js, je
+              outbuf(j,i,k) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_jik
+     
+      SUBROUTINE f_unpack_lint_jik ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(jms:jme,ims:ime,kms:kme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO k = ks, ke
+          DO i = is, ie
+            DO j = js, je
+              outbuf(j,i,k) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_jik
+
+!kij
+      SUBROUTINE f_pack_int_kij ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(kms:kme,ims:ime,jms:jme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO i = is, ie
+            DO k = ks, ke
+              outbuf(p) = inbuf(k,i,j)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_kij
+     
+      SUBROUTINE f_pack_lint_kij ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(kms:kme,ims:ime,jms:jme), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO i = is, ie
+            DO k = ks, ke
+              outbuf(p) = inbuf(k,i,j)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_kij
+     
+      SUBROUTINE f_unpack_int_kij ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(kms:kme,ims:ime,jms:jme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO i = is, ie
+            DO k = ks, ke
+              outbuf(k,i,j) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_kij
+     
+      SUBROUTINE f_unpack_lint_kij ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(kms:kme,ims:ime,jms:jme), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+        DO j = js, je
+          DO i = is, ie
+            DO k = ks, ke
+              outbuf(k,i,j) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_kij
+
+!kji
+      SUBROUTINE f_pack_int_kji ( inbuf, outbuf, js, je, ks, ke,              &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER inbuf(kms:kme,jms:jme,ims:ime), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+          DO i = is, ie
+        DO j = js, je
+            DO k = ks, ke
+              outbuf(p) = inbuf(k,j,i)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_int_kji
+     
+      SUBROUTINE f_pack_lint_kji ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 inbuf(kms:kme,jms:jme,ims:ime), outbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+          DO i = is, ie
+        DO j = js, je
+            DO k = ks, ke
+              outbuf(p) = inbuf(k,j,i)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_pack_lint_kji
+     
+      SUBROUTINE f_unpack_int_kji ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER outbuf(kms:kme,jms:jme,ims:ime), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+          DO i = is, ie
+        DO j = js, je
+            DO k = ks, ke
+              outbuf(k,j,i) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_int_kji
+     
+      SUBROUTINE f_unpack_lint_kji ( inbuf, outbuf, js, je, ks, ke,            &
+     &                is, ie, jms, jme, kms, kme, ims, ime, curs ) 
+        IMPLICIT NONE
+        INTEGER jms, jme, kms, kme, ims, ime
+        INTEGER*8 outbuf(kms:kme,jms:jme,ims:ime), inbuf(*)
+        INTEGER js, je, ks, ke, is, ie, curs
+        ! Local
+        INTEGER i,j,k,p
+        p = 1
+          DO i = is, ie
+        DO j = js, je
+            DO k = ks, ke
+              outbuf(k,j,i) = inbuf(p)
+              p = p + 1
+            ENDDO
+          ENDDO
+        ENDDO
+        curs = p - 1
+        RETURN
+      END SUBROUTINE f_unpack_lint_kji
+
diff --git a/wrfv2_fire/external/RSL_LITE/f_xpose.F90 b/wrfv2_fire/external/RSL_LITE/f_xpose.F90
new file mode 100755
index 00000000..8939e572
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/f_xpose.F90
@@ -0,0 +1,366 @@
+      subroutine trans_z2x ( np, comm, dir, r_wordsize, i_wordsize, memorder, &
+                               a, &
+                               sd1, ed1, sd2, ed2, sd3, ed3, & 
+                               sp1, ep1, sp2, ep2, sp3, ep3, & 
+                               sm1, em1, sm2, em2, sm3, em3, & 
+                               ax, &
+                               sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, & 
+                               sm1x, em1x, sm2x, em2x, sm3x, em3x )
+         USE duplicate_of_driver_constants
+         implicit none
+         include 'mpif.h'
+         integer, intent(in) :: sd1, ed1, sd2, ed2, sd3, ed3, & 
+                                sp1, ep1, sp2, ep2, sp3, ep3, & 
+                                sm1, em1, sm2, em2, sm3, em3, & 
+                                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, & 
+                                sm1x, em1x, sm2x, em2x, sm3x, em3x
+         integer, intent(in) :: np, comm, r_wordsize, i_wordsize
+         integer, intent(in) :: dir ! 1 is a->ax, otherwise ax->a
+         integer, intent(in) :: memorder
+
+!local
+         integer   ::         ids, ide, jds, jde, kds, kde, & 
+                              ips, ipe, jps, jpe, kps, kpe, & 
+                              ims, ime, jms, jme, kms, kme, & 
+                              ipsx, ipex, jpsx, jpex, kpsx, kpex, & 
+                              imsx, imex, jmsx, jmex, kmsx, kmex
+
+         integer, dimension((ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*min(1,(r_wordsize/i_wordsize)))         :: a
+         integer, dimension((ep1x-sp1x+1)*(ep2x-ep2x+1)*(ep3x-sp3x+1)*min(1,(r_wordsize/i_wordsize)))   :: ax
+         integer, dimension(0:(ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*min(1,(r_wordsize/i_wordsize)))       :: zbuf
+         integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*min(1,(r_wordsize/i_wordsize))) :: xbuf
+
+         integer pencil(4), allpencils(4,np)
+         integer sendcnts(np), sdispls(np), recvcnts(np), rdispls(np)
+         integer allsendcnts(np+2,np), is(np), ie(np), ks(np),ke(np)
+         integer sendcurs(np), recvcurs(np)
+         integer i,j,k,p,sc,sp,rp,yp,zp,curs,zbufsz,cells,nkcells,ivectype,ierr
+
+         SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            ids  = sd1  ; ide  = ed1  ; jds  = sd2  ; jde  = ed2  ; kds  = sd3  ; kde  = ed3
+            ips  = sp1  ; ipe  = ep1  ; jps  = sp2  ; jpe  = ep2  ; kps  = sp3  ; kpe  = ep3
+            ims  = sm1  ; ime  = em1  ; jms  = sm2  ; jme  = em2  ; kms  = sm3  ; kme  = em3
+            ipsx = sp1x ; ipex = ep1x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp3x ; kpex = ep3x
+            imsx = sm1x ; imex = em1x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm3x ; kmex = em3x
+          CASE ( DATA_ORDER_YXZ )
+            ids  = sd2  ; ide  = ed2  ; jds  = sd1  ; jde  = ed1  ; kds  = sd3  ; kde  = ed3
+            ips  = sp2  ; ipe  = ep2  ; jps  = sp1  ; jpe  = ep1  ; kps  = sp3  ; kpe  = ep3
+            ims  = sm2  ; ime  = em2  ; jms  = sm1  ; jme  = em1  ; kms  = sm3  ; kme  = em3
+            ipsx = sp2x ; ipex = ep2x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp3x ; kpex = ep3x
+            imsx = sm2x ; imex = em2x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm3x ; kmex = em3x
+          CASE ( DATA_ORDER_XZY )
+            ids  = sd1  ; ide  = ed1  ; jds  = sd3  ; jde  = ed3  ; kds  = sd2  ; kde  = ed2
+            ips  = sp1  ; ipe  = ep1  ; jps  = sp3  ; jpe  = ep3  ; kps  = sp2  ; kpe  = ep2
+            ims  = sm1  ; ime  = em1  ; jms  = sm3  ; jme  = em3  ; kms  = sm2  ; kme  = em2
+            ipsx = sp1x ; ipex = ep1x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp2x ; kpex = ep2x
+            imsx = sm1x ; imex = em1x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm2x ; kmex = em2x
+          CASE ( DATA_ORDER_YZX )
+            ids  = sd3  ; ide  = ed3  ; jds  = sd1  ; jde  = ed1  ; kds  = sd2  ; kde  = ed2
+            ips  = sp3  ; ipe  = ep3  ; jps  = sp1  ; jpe  = ep1  ; kps  = sp2  ; kpe  = ep2
+            ims  = sm3  ; ime  = em3  ; jms  = sm1  ; jme  = em1  ; kms  = sm2  ; kme  = em2
+            ipsx = sp3x ; ipex = ep3x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp2x ; kpex = ep2x
+            imsx = sm3x ; imex = em3x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm2x ; kmex = em2x
+          CASE ( DATA_ORDER_ZXY )
+            ids  = sd2  ; ide  = ed2  ; jds  = sd3  ; jde  = ed3  ; kds  = sd1  ; kde  = ed1
+            ips  = sp2  ; ipe  = ep2  ; jps  = sp3  ; jpe  = ep3  ; kps  = sp1  ; kpe  = ep1
+            ims  = sm2  ; ime  = em2  ; jms  = sm3  ; jme  = em3  ; kms  = sm1  ; kme  = em1
+            ipsx = sp2x ; ipex = ep2x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp1x ; kpex = ep1x
+            imsx = sm2x ; imex = em2x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm1x ; kmex = em1x
+          CASE ( DATA_ORDER_ZYX )
+            ids  = sd3  ; ide  = ed3  ; jds  = sd2  ; jde  = ed2  ; kds  = sd1  ; kde  = ed1
+            ips  = sp3  ; ipe  = ep3  ; jps  = sp2  ; jpe  = ep2  ; kps  = sp1  ; kpe  = ep1
+            ims  = sm3  ; ime  = em3  ; jms  = sm2  ; jme  = em2  ; kms  = sm1  ; kme  = em1
+            ipsx = sp3x ; ipex = ep3x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp1x ; kpex = ep1x
+            imsx = sm3x ; imex = em3x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm1x ; kmex = em1x
+         END SELECT
+
+         sendcnts = 0 ; recvcnts = 0
+
+         xbuf = 0 
+         zbuf = 0 
+
+! work out send/recv sizes to each processor in X dimension
+         pencil(1) = ips 
+         pencil(2) = ipe 
+         pencil(3) = kpsx
+         pencil(4) = kpex
+         call mpi_allgather( pencil, 4, MPI_INTEGER, allpencils, 4, MPI_INTEGER, comm, ierr )
+         do p = 1, np
+           is(p) = allpencils(1,p)
+           ie(p) = allpencils(2,p)
+           ks(p) = allpencils(3,p)
+           ke(p) = allpencils(4,p)
+         enddo
+! pack send buffer
+         sendcurs = 0 
+         sdispls = 0
+         sc = 0
+         do p = 1, np
+           if ( r_wordsize .eq. i_wordsize ) then
+             if ( dir .eq. 1 ) then
+               call f_pack_int ( a, zbuf(sc), memorder,                                     &
+     &                                        jps, jpe, ks(p), ke(p), ips, ipe,             &
+     &                                        jms, jme, kms, kme, ims, ime, sendcurs(p) )
+             else
+               call f_pack_int ( ax, xbuf(sc), memorder,                                    &
+     &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),         &
+     &                                        jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
+             endif
+           else if ( r_wordsize .eq. 8 ) THEN
+             if ( dir .eq. 1 ) then
+               call f_pack_lint ( a, zbuf(sc), memorder,                                    &
+     &                                        jps, jpe, ks(p), ke(p), ips, ipe,             &
+     &                                        jms, jme, kms, kme, ims, ime, sendcurs(p) )
+             else
+               call f_pack_lint ( ax, xbuf(sc), memorder,                                   &
+     &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),         &
+     &                                        jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
+             endif
+           else
+             write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
+             call mpi_abort(ierr)
+           endif
+           sc = sc + sendcurs(p)
+           sendcnts(p) = sendcurs(p)
+           if ( p .GT. 1 ) sdispls(p) = sdispls(p-1) + sendcnts(p-1)
+         enddo
+! work out receive counts and displs
+         rdispls = 0
+         recvcnts = 0
+         do p = 1, np
+           if ( dir .eq. 1 ) then
+             recvcnts(p) = (ie(p)-is(p)+1)*(kpex-kpsx+1)*(jpex-jpsx+1) * min(1,(r_wordsize/i_wordsize))
+           else
+             recvcnts(p) = (ke(p)-ks(p)+1)*(ipe-ips+1)*(jpe-jps+1) * min(1,(r_wordsize/i_wordsize))
+           endif
+           if ( p .GT. 1 ) rdispls(p) = rdispls(p-1) + recvcnts(p-1)
+         enddo
+! do the transpose
+         if ( dir .eq. 1 ) then
+           call mpi_alltoallv(zbuf, sendcnts, sdispls, MPI_INTEGER,              &
+                              xbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
+         else
+           call mpi_alltoallv(xbuf, sendcnts, sdispls, MPI_INTEGER,              &
+                              zbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
+         endif
+! unpack
+         do p = 1, np
+           if ( r_wordsize .eq. i_wordsize ) then
+             if ( dir .eq. 1 ) then
+               call f_unpack_int ( xbuf(rdispls(p)), ax, memorder,                        &
+     &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),       &
+     &                                        jmsx, jmex, kmsx, kmex, imsx, imex, curs )
+             else
+               call f_unpack_int ( zbuf(rdispls(p)), a, memorder,                         &
+     &                                        jps, jpe, ks(p), ke(p), ips, ipe,           &
+     &                                        jms, jme, kms, kme, ims, ime, curs )
+             endif
+           else if ( r_wordsize .eq. 8 ) THEN
+             if ( dir .eq. 1 ) then
+               call f_unpack_lint ( xbuf(rdispls(p)), ax, memorder,                       &
+     &                                        jpsx, jpex, kpsx, kpex, is(p), ie(p),       &
+     &                                        jmsx, jmex, kmsx, kmex, imsx, imex, curs )
+             else
+               call f_unpack_lint ( zbuf(rdispls(p)), a, memorder,                        &
+     &                                        jps, jpe, ks(p), ke(p), ips, ipe,           &
+     &                                        jms, jme, kms, kme, ims, ime, curs )
+             endif
+           else
+             write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
+             call mpi_abort(ierr)
+           endif
+         enddo
+         return
+      end subroutine trans_z2x
+
+      subroutine trans_x2y ( np, comm, dir, r_wordsize, i_wordsize, memorder, &
+                               ax, &
+                               sd1, ed1, sd2, ed2, sd3, ed3, &
+                               sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                               sm1x, em1x, sm2x, em2x, sm3x, em3x, &
+                               ay, &
+                               sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                               sm1y, em1y, sm2y, em2y, sm3y, em3y )
+         USE duplicate_of_driver_constants
+         implicit none
+         include 'mpif.h'
+         integer, intent(in) :: memorder
+         integer, intent(in) ::  sd1, ed1, sd2, ed2, sd3, ed3, &
+                                 sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                                 sm1x, em1x, sm2x, em2x, sm3x, em3x, &
+                                 sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                                 sm1y, em1y, sm2y, em2y, sm3y, em3y
+
+         integer, intent(in) :: np, comm, r_wordsize, i_wordsize
+         integer, intent(in) :: dir ! 1 is a->ax, otherwise ax->a
+
+         integer, dimension((ep1x-sp1x+1)*(ep2x-ep2x+1)*(ep3x-sp3x+1)*min(1,(r_wordsize/i_wordsize)))   :: ax
+         integer, dimension((ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*min(1,(r_wordsize/i_wordsize)))   :: ay
+         integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*min(1,(r_wordsize/i_wordsize))) :: xbuf
+         integer, dimension(0:(ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*min(1,(r_wordsize/i_wordsize))) :: ybuf
+
+!local
+         integer              ids, ide, jds, jde, kds, kde, & 
+                              ipsx, ipex, jpsx, jpex, kpsx, kpex, & 
+                              imsx, imex, jmsx, jmex, kmsx, kmex, &
+                              ipsy, ipey, jpsy, jpey, kpsy, kpey, & 
+                              imsy, imey, jmsy, jmey, kmsy, kmey
+         integer pencil(4), allpencils(4,np)
+         integer sendcnts(np), sdispls(np), recvcnts(np), rdispls(np)
+         integer allsendcnts(np+2,np), is(np), ie(np), js(np), je(np)
+         integer sendcurs(np), recvcurs(np)
+         integer i,j,k,p,sc,sp,rp,yp,zp,curs,xbufsz,cells,nkcells,ivectype,ierr
+
+         SELECT CASE ( memorder )
+          CASE ( DATA_ORDER_XYZ )
+            ids  = sd1  ; ide  = ed1  ; jds  = sd2  ; jde  = ed2  ; kds  = sd3  ; kde  = ed3
+            ipsx = sp1x ; ipex = ep1x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp3x ; kpex = ep3x
+            imsx = sm1x ; imex = em1x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm3x ; kmex = em3x
+            ipsy = sp1y ; ipey = ep1y ; jpsy = sp2y ; jpey = ep2y ; kpsy = sp3y ; kpey = ep3y
+            imsy = sm1y ; imey = em1y ; jmsy = sm2y ; jmey = em2y ; kmsy = sm3y ; kmey = em3y
+          CASE ( DATA_ORDER_YXZ )
+            ids  = sd2  ; ide  = ed2  ; jds  = sd1  ; jde  = ed1  ; kds  = sd3  ; kde  = ed3
+            ipsx = sp2x ; ipex = ep2x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp3x ; kpex = ep3x
+            imsx = sm2x ; imex = em2x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm3x ; kmex = em3x
+            ipsy = sp2y ; ipey = ep2y ; jpsy = sp1y ; jpey = ep1y ; kpsy = sp3y ; kpey = ep3y
+            imsy = sm2y ; imey = em2y ; jmsy = sm1y ; jmey = em1y ; kmsy = sm3y ; kmey = em3y
+          CASE ( DATA_ORDER_XZY )
+            ids  = sd1  ; ide  = ed1  ; jds  = sd3  ; jde  = ed3  ; kds  = sd2  ; kde  = ed2
+            ipsx = sp1x ; ipex = ep1x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp2x ; kpex = ep2x
+            imsx = sm1x ; imex = em1x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm2x ; kmex = em2x
+            ipsy = sp1y ; ipey = ep1y ; jpsy = sp3y ; jpey = ep3y ; kpsy = sp2y ; kpey = ep2y
+            imsy = sm1y ; imey = em1y ; jmsy = sm3y ; jmey = em3y ; kmsy = sm2y ; kmey = em2y
+          CASE ( DATA_ORDER_YZX )
+            ids  = sd3  ; ide  = ed3  ; jds  = sd1  ; jde  = ed1  ; kds  = sd2  ; kde  = ed2
+            ipsx = sp3x ; ipex = ep3x ; jpsx = sp1x ; jpex = ep1x ; kpsx = sp2x ; kpex = ep2x
+            imsx = sm3x ; imex = em3x ; jmsx = sm1x ; jmex = em1x ; kmsx = sm2x ; kmex = em2x
+            ipsy = sp3y ; ipey = ep3y ; jpsy = sp1y ; jpey = ep1y ; kpsy = sp2y ; kpey = ep2y
+            imsy = sm3y ; imey = em3y ; jmsy = sm1y ; jmey = em1y ; kmsy = sm2y ; kmey = em2y
+          CASE ( DATA_ORDER_ZXY )
+            ids  = sd2  ; ide  = ed2  ; jds  = sd3  ; jde  = ed3  ; kds  = sd1  ; kde  = ed1
+            ipsx = sp2x ; ipex = ep2x ; jpsx = sp3x ; jpex = ep3x ; kpsx = sp1x ; kpex = ep1x
+            imsx = sm2x ; imex = em2x ; jmsx = sm3x ; jmex = em3x ; kmsx = sm1x ; kmex = em1x
+            ipsy = sp2y ; ipey = ep2y ; jpsy = sp3y ; jpey = ep3y ; kpsy = sp1y ; kpey = ep1y
+            imsy = sm2y ; imey = em2y ; jmsy = sm3y ; jmey = em3y ; kmsy = sm1y ; kmey = em1y
+          CASE ( DATA_ORDER_ZYX )
+            ids  = sd3  ; ide  = ed3  ; jds  = sd2  ; jde  = ed2  ; kds  = sd1  ; kde  = ed1
+            ipsx = sp3x ; ipex = ep3x ; jpsx = sp2x ; jpex = ep2x ; kpsx = sp1x ; kpex = ep1x
+            imsx = sm3x ; imex = em3x ; jmsx = sm2x ; jmex = em2x ; kmsx = sm1x ; kmex = em1x
+            ipsy = sp3y ; ipey = ep3y ; jpsy = sp2y ; jpey = ep2y ; kpsy = sp1y ; kpey = ep1y
+            imsy = sm3y ; imey = em3y ; jmsy = sm2y ; jmey = em2y ; kmsy = sm1y ; kmey = em1y
+         END SELECT
+
+         sendcnts = 0 ; recvcnts = 0
+
+         xbuf = 0 
+         ybuf = 0 
+
+! work out send/recv sizes to each processor in X dimension
+         pencil(1) = jpsx
+         pencil(2) = jpex
+         pencil(3) = ipsy
+         pencil(4) = ipey
+
+         call mpi_allgather( pencil, 4, MPI_INTEGER, allpencils, 4, MPI_INTEGER, comm, ierr )
+         do p = 1, np
+           js(p) = allpencils(1,p)
+           je(p) = allpencils(2,p)
+           is(p) = allpencils(3,p)
+           ie(p) = allpencils(4,p)
+         enddo
+
+write(0,*)'x2y np ',np
+write(0,*)'x2y dir ', dir
+write(0,*)'x2y js ',js
+write(0,*)'x2y je ',je
+write(0,*)'x2y is ',is
+write(0,*)'x2y ie ',ie
+
+
+! pack send buffer
+         sendcurs = 0 
+         sdispls = 0
+         sc = 0
+         do p = 1, np
+           if ( r_wordsize .eq. i_wordsize ) then
+             if ( dir .eq. 1 ) then
+               call f_pack_int ( ax, xbuf(sc), memorder,                                    &
+     &                                         jpsx, jpex, kpsx, kpex, is(p), ie(p),        &
+     &                                         jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
+             else
+               call f_pack_int ( ay, ybuf(sc), memorder,                                    &
+     &                                         js(p), je(p), kpsy, kpey, ipsy, ipey,        &
+     &                                         jmsy, jmey, kmsy, kmey, imsy, imey, sendcurs(p) )
+             endif
+           else if ( r_wordsize .eq. 8 ) THEN
+             if ( dir .eq. 1 ) then
+               call f_pack_lint ( ax, xbuf(sc), memorder,                                    &
+     &                                          jpsx, jpex, kpsx, kpex, is(p), ie(p),        &
+     &                                          jmsx, jmex, kmsx, kmex, imsx, imex, sendcurs(p) )
+             else
+               call f_pack_lint ( ay, ybuf(sc), memorder,                                    &
+     &                                          js(p), je(p), kpsy, kpey, ipsy, ipey,        &
+     &                                          jmsy, jmey, kmsy, kmey, imsy, imey, sendcurs(p) )
+             endif
+           else
+             write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
+             call mpi_abort(ierr)
+           endif
+           sc = sc + sendcurs(p)
+           sendcnts(p) = sendcurs(p)
+           if ( p .GT. 1 ) sdispls(p) = sdispls(p-1) + sendcnts(p-1)
+         enddo
+
+! work out receive counts and displs
+         rdispls = 0
+         recvcnts = 0
+         do p = 1, np
+           if ( dir .eq. 1 ) then
+             recvcnts(p) = (je(p)-js(p)+1)*(kpey-kpsy+1)*(ipey-ipsy+1) * min(1,(r_wordsize/i_wordsize))
+           else
+             recvcnts(p) = (ie(p)-is(p)+1)*(kpex-kpsx+1)*(jpex-jpsx+1) * min(1,(r_wordsize/i_wordsize))
+           endif
+           if ( p .GT. 1 ) rdispls(p) = rdispls(p-1) + recvcnts(p-1)
+         enddo
+
+! do the transpose
+         if ( dir .eq. 1 ) then
+write(0,*) ' x2y  alltoallv x->y sendcnts ',sendcnts
+write(0,*) ' x2y  alltoallv x->y recvcnts ',recvcnts
+           call mpi_alltoallv(xbuf, sendcnts, sdispls, MPI_INTEGER,              &
+                              ybuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
+         else
+           call mpi_alltoallv(ybuf, sendcnts, sdispls, MPI_INTEGER,              &
+                              xbuf, recvcnts, rdispls, MPI_INTEGER, comm, ierr )
+         endif
+! unpack
+         do p = 1, np
+           if ( r_wordsize .eq. i_wordsize ) then
+             if ( dir .eq. 1 ) then
+               call f_unpack_int ( ybuf(rdispls(p)), ay, memorder,                                  &
+     &                                                   js(p), je(p), kpsy, kpey, ipsy, ipey,      &
+     &                                                   jmsy, jmey, kmsy, kmey, imsy, imey, curs )
+             else
+               call f_unpack_int ( xbuf(rdispls(p)), ax, memorder,                                  &
+     &                                                   jpsx, jpex, kpsx, kpex, is(p), ie(p),      &
+     &                                                   jmsx, jmex, kmsx, kmex, imsx, imex, curs )
+             endif
+           else if ( r_wordsize .eq. 8 ) THEN
+             if ( dir .eq. 1 ) then
+               call f_unpack_lint ( ybuf(rdispls(p)), ay, memorder,                                 &
+     &                                                    js(p), je(p), kpsy, kpey, ipsy, ipey,     &
+     &                                                    jmsy, jmey, kmsy, kmey, imsy, imey, curs )
+             else
+               call f_unpack_lint ( xbuf(rdispls(p)), ax, memorder,                                 &
+     &                                                    jpsx, jpex, kpsx, kpex, is(p), ie(p),     &
+     &                                                    jmsx, jmex, kmsx, kmex, imsx, imex, curs )
+             endif
+           else
+             write(0,*)'RSL_LITE internal error: type size mismatch ',__FILE__,__LINE__
+             call mpi_abort(ierr)
+           endif
+         enddo
+         return
+      end subroutine trans_x2y
+
diff --git a/wrfv2_fire/external/RSL_LITE/gen_comms.c b/wrfv2_fire/external/RSL_LITE/gen_comms.c
new file mode 100644
index 00000000..6d9907fa
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/gen_comms.c
@@ -0,0 +1,1713 @@
+#include 
+#include 
+#include 
+
+#include "protos.h"
+#include "registry.h"
+#include "data.h"
+
+/* For detecting variables that are members of a derived type */
+#define NULLCHARPTR   (char *) 0
+static int parent_type;
+
+int
+gen_halos ( char * dirname , char * incname , node_t * halos )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
+  char commuse[NAMELEN] ;
+#define MAX_VDIMS 100
+  char vdims[MAX_VDIMS][2][80] ;
+  char s[NAMELEN], e[NAMELEN] ;
+  int vdimcurs ;
+  int maxstenwidth, stenwidth ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN] ;
+  int zdex ;
+  int n2dR, n3dR ;
+  int n2dI, n3dI ;
+  int n2dD, n3dD ;
+  int n4d ;
+  int i, foundvdim ;
+  int subgrid ;
+#define MAX_4DARRAYS 1000
+  char name_4d[MAX_4DARRAYS][NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = halos ; p != NULL ; p = p->next )
+  {
+    if ( incname == NULL ) {
+      strcpy( commname, p->name ) ;
+      make_upper_case(commname) ;
+    } 
+    else {
+      strcpy( commname, incname ) ;
+    }
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+    /* get maximum stencil width */
+    maxstenwidth = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
+      stenwidth = atoi (t2) ;
+      if ( stenwidth == 0 )
+       { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
+      if      ( stenwidth == 4   || stenwidth == 8  ) stenwidth = 1 ;
+      else if ( stenwidth == 12  || stenwidth == 24 ) stenwidth = 2 ;
+      else if ( stenwidth == 48 ) stenwidth = 3 ;
+      else if ( stenwidth == 80 ) stenwidth = 4 ;
+      else if ( stenwidth == 120 ) stenwidth = 5 ;
+      else if ( stenwidth == 168 ) stenwidth = 6 ;
+      else
+       { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
+      if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+    print_warning(fp,fname) ;
+
+fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
+
+/* count up the number of 2d and 3d real arrays and their types */
+    n2dR = 0 ; n3dR = 0 ;
+    n2dI = 0 ; n3dI = 0 ;
+    n2dD = 0 ; n3dD = 0 ;
+    n4d = 0 ;
+    vdimcurs = 0 ;
+    subgrid = -1 ;      /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+          { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
+        else
+        {
+          if ( subgrid == -1 ) {   /* first one */
+            subgrid = q->subgrid ;
+          } else if ( subgrid != q->subgrid ) {
+            fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
+          }
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
+            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of halo exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
+          else if ( q->boundary_array )
+            { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
+          else
+          {
+
+            /* 20061004 -- collect all the vertical dimensions so we can use a MAX
+	       on them when calling RSL_LITE_INIT_EXCH */
+
+            if ( q->ndims == 3 || q->node_kind & FOURD ) {
+              if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
+                zdex = get_index_for_coord( q , COORD_Z ) ;
+                if      ( dimd->len_defined_how == DOMAIN_STANDARD ) { 
+                  strcpy(s,"kps") ;
+                  strcpy(e,"kpe") ;
+                }
+                else if ( dimd->len_defined_how == NAMELIST ) {
+                  if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
+                    strcpy(s,"1") ;
+                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                  } else {
+                    sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
+                    sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                  }
+                }
+                else if ( dimd->len_defined_how == CONSTANT ) {
+                  sprintf(s,"%d",dimd->coord_start) ;
+                  sprintf(e,"%d",dimd->coord_end) ; 
+                }
+                for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
+                  if ( !strcmp( vdims[i][1], e ) ) {
+                    foundvdim = 1 ; break ;
+                  }
+                }
+                if ( ! foundvdim ) {
+                  if (vdimcurs < 100 ) {
+                    strcpy( vdims[vdimcurs][0], s ) ;
+                    strcpy( vdims[vdimcurs][1], e ) ;
+                    vdimcurs++ ;
+                  } else {
+                    fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
+                    fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
+                    fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
+                    exit(5) ;
+                  }
+                }
+              }
+            }
+
+            if ( q->node_kind & FOURD ) {
+              if ( n4d < MAX_4DARRAYS ) {
+                strcpy( name_4d[n4d], q->name ) ;
+              } else { 
+                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
+                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
+                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
+                exit(5) ;
+              }
+              n4d++ ;
+            }
+            else
+            {
+              if        ( ! strcmp( q->type->name, "real") ) {
+                if         ( q->ndims == 3 )      { n3dR++ ; }
+	        else    if ( q->ndims == 2 )      { n2dR++ ; }
+	      } else if ( ! strcmp( q->type->name, "integer") ) {
+                if         ( q->ndims == 3 )      { n3dI++ ; }
+	        else    if ( q->ndims == 2 )      { n2dI++ ; }
+	      } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
+                if         ( q->ndims == 3 )      { n3dD++ ; }
+	        else    if ( q->ndims == 2 )      { n2dD++ ; }
+	      }
+	    }
+	  }
+	}
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+
+/* generate the stencil init statement for Y transfer */
+#if 0
+fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %d for Y %s')\n",maxstenwidth,fname) ;
+#endif
+    if ( subgrid != 0 ) {
+      fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
+    }
+    fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d, &\n",maxstenwidth) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+	fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    if ( subgrid == 0 ) {
+      fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
+      for ( i = 0 ; i < vdimcurs ; i++ ) {
+        fprintf(fp,",%s &\n",vdims[i][1] ) ;
+      }
+      fprintf(fp,"))\n") ;
+    } else {
+      fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
+    }
+
+/* generate packs prior to stencil exchange in Y */
+    gen_packs( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ;
+/* generate stencil exchange in Y */
+    fprintf(fp,"   CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after stencil exchange in Y */
+    gen_packs( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
+
+/* generate the stencil init statement for X transfer */
+    fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d , &\n",maxstenwidth) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    if ( subgrid == 0 ) {
+      fprintf(fp,"      ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
+      for ( i = 0 ; i < vdimcurs ; i++ ) {
+        fprintf(fp,",%s &\n",vdims[i][1] ) ;
+      }
+      fprintf(fp,"))\n") ;
+    } else {
+      fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
+    }
+/* generate packs prior to stencil exchange in X */
+    gen_packs( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ;
+/* generate stencil exchange in X */
+    fprintf(fp,"   CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after stencil exchange in X */
+    gen_packs( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
+    if ( subgrid != 0 ) {
+      fprintf(fp,"ENDIF\n") ;
+    }
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )   
+{
+  node_t * q ;
+  node_t * dimd ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
+  char commuse[NAMELEN] ;
+  int maxstenwidth, stenwidth ;
+  char * t1, * t2 , *wordsize ;
+  char varref[NAMELEN] ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
+  int zdex ;
+
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+          { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
+        else
+        {
+
+          strcpy( varref, t2 ) ;
+          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+             if ( !strncmp( q->use,  "dyn_", 4 )) {
+                  char * core ;
+                  core = q->use+4 ;
+                  sprintf(varref,"grid%%%s_%s",core,t2) ;
+             } else {
+                  sprintf(varref,"grid%%%s",t2) ;
+             }
+          }
+
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
+          else if ( q->boundary_array ) { ; }
+          else
+          { 
+            if      ( ! strcmp( q->type->name, "real") )            { wordsize = "RWORDSIZE" ; }
+            else if ( ! strcmp( q->type->name, "integer") )         { wordsize = "IWORDSIZE" ; }
+            else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
+            if ( q->node_kind & FOURD )
+            {
+              node_t *member ;
+              zdex = get_index_for_coord( q , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 )
+              {
+                set_mem_order( q->members, memord , NAMELEN) ;
+fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
+fprintf(fp," CALL %s ( %s,%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n",
+                       packname, commname, varref , shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
+fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+if ( q->subgrid == 0 ) {
+fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
+fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
+fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
+} else {
+fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
+fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
+fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
+}
+fprintf(fp,"ENDDO\n") ;
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else
+            {
+              set_mem_order( q, memord , NAMELEN) ;
+#if 0
+fprintf(fp,"CALL wrf_debug(3,'call %s %s shw=%d ws=%s xy=%d pu=%d m=%s')\n",packname,t2,shw,wordsize,xy,pu,memord) ;
+fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, kds, kde\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, kms, kme\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, kps, kpe\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+#endif
+              if       ( q->ndims == 3 ) {
+
+                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
+                zdex = get_index_for_coord( q , COORD_Z ) ;
+                if ( dimd != NULL )
+                {
+                  char s[256], e[256] ;
+
+                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
+#if 0
+fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, kds, kde\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, kms, kme\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, kps, kpe\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+#endif
+                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
+                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+                    if ( q->subgrid == 0 ) {
+                      fprintf(fp,"ids, ide, jds, jde, kds, kde,             &\n") ;
+                      fprintf(fp,"ims, ime, jms, jme, kms, kme,             &\n") ;
+                      fprintf(fp,"ips, ipe, jps, jpe, kps, kpe              )\n") ;
+                    } else {
+fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
+fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
+fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
+                    }
+                  }
+                  else if ( dimd->len_defined_how == NAMELIST )
+                  {
+                    if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
+                      strcpy(s,"1") ;
+                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                    } else {
+                      sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
+                      sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
+                    }
+#if 0
+fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, %s, %s\n",s,e ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, %s, %s\n",s,e ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, %s, %s\n",s,e ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+#endif
+                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
+                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+                    if ( q->subgrid == 0 ) {
+                      fprintf(fp,"ids, ide, jds, jde, %s, %s,             &\n",s,e) ;
+                      fprintf(fp,"ims, ime, jms, jme, %s, %s,             &\n",s,e) ;
+                      fprintf(fp,"ips, ipe, jps, jpe, %s, %s              )\n",s,e) ;
+                    } else {
+fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
+fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
+fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
+                    }
+                  }
+                  else if ( dimd->len_defined_how == CONSTANT )
+                  {
+#if 0
+fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, %d, %d\n",dimd->coord_start,dimd->coord_end ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+#endif
+                    fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
+                    fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+                    if ( q->subgrid == 0 ) {
+                      fprintf(fp,"ids, ide, jds, jde, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
+                      fprintf(fp,"ims, ime, jms, jme, %d, %d,             &\n",dimd->coord_start,dimd->coord_end) ;
+                      fprintf(fp,"ips, ipe, jps, jpe, %d, %d              )\n",dimd->coord_start,dimd->coord_end) ;
+                    } else {
+fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
+fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
+fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
+                    }
+                  }
+                }
+              } else if ( q->ndims == 2 ) {
+#if 0
+fprintf(fp,"write(wrf_err_message,*)' d ',ids, ide, jds, jde, 1, 1\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' m ',ims, ime, jms, jme, 1, 1\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+fprintf(fp,"write(wrf_err_message,*)' p ',ips, ipe, jps, jpe, 1, 1\n" ) ;
+fprintf(fp,"CALL wrf_debug(3,wrf_err_message)\n") ;
+#endif
+                fprintf(fp,"CALL %s ( %s, %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, q->stag_x?1:0 ) ;
+                fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+                if ( q->subgrid == 0 ) {
+                  fprintf(fp,"ids, ide, jds, jde, 1  , 1  ,             &\n") ;
+                  fprintf(fp,"ims, ime, jms, jme, 1  , 1  ,             &\n") ;
+                  fprintf(fp,"ips, ipe, jps, jpe, 1  , 1                )\n") ;
+                } else {
+fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
+fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
+fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
+                }
+              }
+#if 0
+fprintf(fp,"CALL wrf_debug(3,'back from %s')\n", packname) ;
+#endif
+            }
+          }
+          
+        }
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+}
+
+int
+gen_periods ( char * dirname , node_t * periods )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
+  char commuse[NAMELEN] ;
+  int maxperwidth, perwidth ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char varref[NAMELEN] ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN] ;
+  int zdex ;
+  int n2dR, n3dR ;
+  int n2dI, n3dI ;
+  int n2dD, n3dD ;
+  int n4d ;
+  int i ;
+#define MAX_4DARRAYS 1000
+  char name_4d[MAX_4DARRAYS][NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = periods ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+    /* get maximum period width */
+    maxperwidth = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
+      perwidth = atoi (t2) ;
+      if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+    print_warning(fp,fname) ;
+
+fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
+
+/* count up the number of 2d and 3d real arrays and their types */
+    n2dR = 0 ; n3dR = 0 ;
+    n2dI = 0 ; n3dI = 0 ;
+    n2dD = 0 ; n3dD = 0 ;
+    n4d = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+          { fprintf(stderr,"WARNING 1 : %s in peridod spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
+        else
+        {
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
+            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of period exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
+          else if ( q->boundary_array )
+            { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
+          else
+          {
+            if ( q->node_kind & FOURD ) {
+              if ( n4d < MAX_4DARRAYS ) {
+                strcpy( name_4d[n4d], q->name ) ;
+              } else { 
+                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
+                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
+                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
+                exit(5) ;
+              }
+              n4d++ ;
+            }
+            else
+            {
+              if        ( ! strcmp( q->type->name, "real") ) {
+                if         ( q->ndims == 3 )      { n3dR++ ; }
+	        else    if ( q->ndims == 2 )      { n2dR++ ; }
+	      } else if ( ! strcmp( q->type->name, "integer") ) {
+                if         ( q->ndims == 3 )      { n3dI++ ; }
+	        else    if ( q->ndims == 2 )      { n2dI++ ; }
+	      } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
+                if         ( q->ndims == 3 )      { n3dD++ ; }
+	        else    if ( q->ndims == 2 )      { n2dD++ ; }
+	      }
+	    }
+	  }
+	}
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+
+    fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
+
+/* generate the stencil init statement for X transfer */
+    fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
+/* generate packs prior to exchange in X */
+    gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
+/* generate exchange in X */
+    fprintf(fp,"   CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after exchange in X */
+    gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
+    fprintf(fp,"END IF\n") ;
+
+
+    fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
+/* generate the init statement for Y transfer */
+    fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
+/* generate packs prior to exchange in Y */
+    gen_packs( fp, p, maxperwidth, 0, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;  
+/* generate exchange in Y */
+    fprintf(fp,"   CALL RSL_LITE_EXCH_PERIOD_Y ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after exchange in Y */
+    gen_packs( fp, p, maxperwidth, 0, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;  
+    fprintf(fp,"END IF\n") ;
+
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_swaps ( char * dirname , node_t * swaps )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
+  char commuse[NAMELEN] ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN] ;
+  int zdex ;
+  int n2dR, n3dR ;
+  int n2dI, n3dI ;
+  int n2dD, n3dD ;
+  int n4d ;
+  int i, xy ;
+#define MAX_4DARRAYS 1000
+  char name_4d[MAX_4DARRAYS][NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = swaps ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+    print_warning(fp,fname) ;
+
+  for ( xy = 0 ; xy < 2 ; xy++ ) {
+
+fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
+
+/* count up the number of 2d and 3d real arrays and their types */
+    n2dR = 0 ; n3dR = 0 ;
+    n2dI = 0 ; n3dI = 0 ;
+    n2dD = 0 ; n3dD = 0 ;
+    n4d = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+          { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
+        else
+        {
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
+            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of swaps exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
+          else if ( q->boundary_array )
+            { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
+          else
+          {
+            if ( q->node_kind & FOURD ) {
+              if ( n4d < MAX_4DARRAYS ) {
+                strcpy( name_4d[n4d], q->name ) ;
+              } else { 
+                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
+                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
+                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
+                exit(5) ;
+              }
+              n4d++ ;
+            }
+            else
+            {
+              if        ( ! strcmp( q->type->name, "real") ) {
+                if         ( q->ndims == 3 )      { n3dR++ ; }
+	        else    if ( q->ndims == 2 )      { n2dR++ ; }
+	      } else if ( ! strcmp( q->type->name, "integer") ) {
+                if         ( q->ndims == 3 )      { n3dI++ ; }
+	        else    if ( q->ndims == 2 )      { n2dI++ ; }
+	      } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
+                if         ( q->ndims == 3 )      { n3dD++ ; }
+	        else    if ( q->ndims == 2 )      { n2dD++ ; }
+	      }
+	    }
+	  }
+	}
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+
+    fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
+
+/* generate the init statement for X swap */
+    fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
+    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
+/* generate packs prior to stencil exchange  */
+    gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
+/* generate stencil exchange in X */
+    fprintf(fp,"   CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after stencil exchange  */
+    gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
+
+    fprintf(fp,"END IF\n") ;
+
+  }
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_cycles ( char * dirname , node_t * cycles )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
+  char commuse[NAMELEN] ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN] ;
+  int zdex ;
+  int n2dR, n3dR ;
+  int n2dI, n3dI ;
+  int n2dD, n3dD ;
+  int n4d ;
+  int i, xy, inout ;
+#define MAX_4DARRAYS 1000
+  char name_4d[MAX_4DARRAYS][NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = cycles ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s.inc",commname) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
+      continue ; 
+    }
+
+    /* get inout */
+    inout = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    strcpy( tmp2 , t1 ) ;
+    if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
+    inout = atoi (t2) ;
+
+    print_warning(fp,fname) ;
+
+  for ( xy = 0 ; xy < 2 ; xy++ ) {
+
+fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
+
+/* count up the number of 2d and 3d real arrays and their types */
+    n2dR = 0 ; n3dR = 0 ;
+    n2dI = 0 ; n3dI = 0 ;
+    n2dD = 0 ; n3dD = 0 ;
+    n4d = 0 ;
+    strcpy( tmp, p->comm_define ) ;
+    strcpy( commuse, p->use ) ;
+    t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+    for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ;  /* truncate all of these */
+    while ( t1 != NULL )
+    {
+      strcpy( tmp2 , t1 ) ;
+      if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
+       { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
+      t2 = strtok_rentr(NULL,",", &pos2) ;
+      while ( t2 != NULL )
+      {
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
+          { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
+        else
+        {
+          if      (  strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
+            { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of cycles exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
+          else if ( q->boundary_array )
+            { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
+          else
+          {
+            if ( q->node_kind & FOURD ) {
+              if ( n4d < MAX_4DARRAYS ) {
+                strcpy( name_4d[n4d], q->name ) ;
+              } else { 
+                fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
+                fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
+                fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
+                exit(5) ;
+              }
+              n4d++ ;
+            }
+            else
+            {
+              if        ( ! strcmp( q->type->name, "real") ) {
+                if         ( q->ndims == 3 )      { n3dR++ ; }
+	        else    if ( q->ndims == 2 )      { n2dR++ ; }
+	      } else if ( ! strcmp( q->type->name, "integer") ) {
+                if         ( q->ndims == 3 )      { n3dI++ ; }
+	        else    if ( q->ndims == 2 )      { n2dI++ ; }
+	      } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
+                if         ( q->ndims == 3 )      { n3dD++ ; }
+	        else    if ( q->ndims == 2 )      { n2dD++ ; }
+	      }
+	    }
+	  }
+	}
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+
+    fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
+
+/* generate the init statement for X swap */
+    fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
+    if ( n4d > 0 ) {
+      fprintf(fp,  "     %d  &\n", n3dR ) ;
+      for ( i = 0 ; i < n4d ; i++ ) {
+        fprintf(fp,"   + num_%s   &\n", name_4d[i] ) ;
+      }
+      fprintf(fp,"     , %d, RWORDSIZE, &\n", n2dR ) ;
+    } else {
+      fprintf(fp,"     %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
+    }
+    fprintf(fp,"     %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
+    fprintf(fp,"     %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
+    fprintf(fp,"      0,  0, LWORDSIZE, &\n" ) ;
+    fprintf(fp,"      mytask, ntasks, ntasks_x, ntasks_y,   &\n" ) ;
+    fprintf(fp,"      ids, ide, jds, jde, kds, kde,   &\n") ;
+    fprintf(fp,"      ips, ipe, jps, jpe, kps, kpe    )\n") ;
+/* generate packs prior to stencil exchange  */
+    gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
+/* generate stencil exchange in X */
+    fprintf(fp,"   CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
+/* generate unpacks after stencil exchange  */
+    gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
+
+    fprintf(fp,"END IF\n") ;
+
+  }
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+int
+gen_xposes ( char * dirname )
+{
+  node_t * p, * q ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  char tmp[4096], tmp2[4096], tmp3[4096] ;
+  char commuse[4096] ;
+  FILE * fp ;
+  char * t1, * t2 ;
+  char * pos1 , * pos2 ;
+  char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
+  char ** x ;
+  char post[NAMELEN], varname[NAMELEN], memord[10] ;
+  char indices_z[NAMELEN], varref_z[NAMELEN] ;
+  char indices_x[NAMELEN], varref_x[NAMELEN] ;
+  char indices_y[NAMELEN], varref_y[NAMELEN] ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  for ( p = Xposes ; p != NULL ; p = p->next )
+  {
+    for ( x = xposedir ; *x ; x++ )
+    {
+      strcpy( commname, p->name ) ;
+      make_upper_case(commname) ;
+      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
+      else                       { sprintf(fname,"%s_%s.inc",commname,*x) ; }
+      if ((fp = fopen( fname , "w" )) == NULL ) 
+      {
+        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
+        continue ; 
+      }
+
+      print_warning(fp,fname) ;
+
+      strcpy( tmp, p->comm_define ) ;
+      strcpy( commuse, p->use ) ;
+      t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
+      while ( t1 != NULL )
+      {
+        strcpy( tmp2 , t1 ) ;
+
+/* Z array */
+        t2 = strtok_rentr(tmp2,",", &pos2) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref_z, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref_z,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref_z,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_Z_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices_z,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices_z, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+
+/* X array */
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref_x, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref_x,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref_x,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_X_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices_x,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices_x, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+
+/* Y array */
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+        if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )    
+         { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
+        strcpy( varref_y, t2 ) ;
+        if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+           if ( !strncmp( q->use,  "dyn_", 4 )) {
+                char * core ;
+                core = q->use+4 ;
+                sprintf(varref_y,"grid%%%s_%s",core,t2) ;
+           } else {
+                sprintf(varref_y,"grid%%%s",t2) ;
+           }
+        }
+        if ( q->proc_orient != ALL_Y_ON_PROC ) 
+         { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
+        if ( q->ndims != 3 )
+         { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        if ( q->boundary_array )
+         { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
+        strcpy (indices_y,"");
+        if ( sw_deref_kludge &&  strchr (t2, '%') != NULLCHARPTR )
+        {
+          sprintf(post,")") ;
+          sprintf(indices_y, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
+        }
+        t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+      }
+      set_mem_order( q, memord , NAMELEN) ;
+      if        ( !strcmp( *x , "z2x" ) ) {
+        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n"   ) ;
+      } else if ( !strcmp( *x , "x2z" ) ) {
+        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n"   ) ;
+      } else if ( !strcmp( *x , "x2y" ) ) {
+        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
+        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
+        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
+      } else if ( !strcmp( *x , "y2x" ) ) {
+        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
+        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
+        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
+      } else if ( !strcmp( *x , "y2z" ) ) {
+        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
+        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
+        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
+        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x)\n"   ) ;
+      } else if ( !strcmp( *x , "z2y" ) ) {
+        fprintf(fp,"  call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in Z decomp\n" , varref_z  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n"         ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x )\n"   ) ;
+        fprintf(fp,"  call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
+        fprintf(fp,"                   %s, &  ! variable in X decomp\n" , varref_x  ) ;
+        fprintf(fp,"                   grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n"         ) ;
+        fprintf(fp,"                   grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n"   ) ;
+        fprintf(fp,"                   %s, &  ! variable in Y decomp\n" , varref_y  ) ;
+        fprintf(fp,"                   grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n"   ) ;
+        fprintf(fp,"                   grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n"   ) ;
+      }
+
+      close_the_file(fp) ;
+    }
+skiperific:
+    ;
+  }
+  return(0) ;
+}
+
+int
+gen_comm_descrips ( char * dirname )
+{
+  node_t * p ;
+  char * fn = "dm_comm_cpp_flags" ;
+  char commname[NAMELEN] ;
+  char fname[NAMELEN] ;
+  FILE * fp ;
+  int ncomm ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
+  else                       { sprintf(fname,"%s",fn) ; }
+
+  if ((fp = fopen( fname , "w" )) == NULL )
+  {
+    fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
+  }
+
+  return(0) ;
+}
+
+/*
+
+
+
+*/
+
+/* for each core, generate the halo updates to allow shifting all state data */
+int
+gen_shift (  char * dirname )
+{
+  int i, ncore ;
+  FILE * fp ;
+  node_t *p, *q, *dimd ;
+  char * corename ;
+  char **direction ;
+  char *directions[] = { "x", "y", 0L } ;
+  char fname[NAMELEN], vname[NAMELEN], vname2[NAMELEN], core[NAMELEN] ;
+  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
+  int zdex ;
+  node_t Shift ;
+int said_it = 0 ;
+int said_it2 = 0 ;
+
+  for ( direction = directions ; *direction != NULL ; direction++ )
+  {
+  for ( ncore = 0 ; ncore < get_num_cores() ; ncore++ )
+  {
+    corename = get_corename_i(ncore) ;
+    if ( dirname == NULL || corename == NULL ) return(1) ;
+    sprintf(fname,"%s_shift_halo_%s",corename,*direction) ;
+
+    Shift.next = NULL ;
+    sprintf( Shift.use, "dyn_%s", corename ) ;
+    strcpy( Shift.comm_define, "48:" ) ;
+    for ( p = Domain.fields ; p != NULL ; p = p->next ) {
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
+          ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
+      {
+
+/* special cases in WRF */
+if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
+     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
+     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
+  if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
+                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
+                                fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
+  said_it = 1 ; }
+  continue ;
+}
+
+/* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
+        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
+if ( p->subgrid != 0 ) {  /* moving nests not implemented for subgrid variables */
+  if ( sw_move && ! said_it2 ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for subgrid variables \n") ;
+  said_it2 = 1 ; }
+  continue ;
+}
+          if ( p->type->type_type == SIMPLE )
+          {
+            for ( i = 1 ; i <= p->ntl ; i++ )
+            {
+              if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
+              else              sprintf(vname,"%s",p->name ) ;
+              strcat( Shift.comm_define, vname ) ;
+              strcat( Shift.comm_define, "," ) ;
+            }
+          }
+        }
+      }
+    }
+    if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
+
+    gen_halos( dirname , fname, &Shift ) ;
+
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_shift_halo_%s.inc",dirname,corename,*direction) ; }
+    else                       { sprintf(fname,"%s_shift_halo_%s.inc",corename,*direction) ; }
+    if ((fp = fopen( fname , "a" )) == NULL ) return(1) ;
+
+/* now generate the shifts themselves */
+    for ( p = Domain.fields ; p != NULL ; p = p->next )
+    {
+
+/* special cases in WRF */
+if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
+     !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
+     !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
+  continue ;
+}
+
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
+	  ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
+      {
+
+        if ( p->node_kind & FOURD ) {
+          sprintf(core,"") ;
+        } else {
+          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s_",corename) ;
+          else                                sprintf(core,"") ;
+        }
+
+	if ( p->type->type_type == SIMPLE )
+	{
+	  for ( i = 1 ; i <= p->ntl ; i++ )
+	  {
+            
+            if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
+            else              sprintf(vname,"%s",p->name ) ;
+            if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
+            else              sprintf(vname2,"%s%s",core,p->name ) ;
+
+	    if ( p->node_kind & FOURD )
+            {
+              node_t *member ;
+              zdex = get_index_for_coord( p , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 )
+              {
+                    if ( !strcmp( *direction, "x" ) )
+                    {
+fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
+fprintf(fp, "   %s ( ips:min(ide%s,ipe),:,jms:jme,itrace) = %s (ips+px:min(ide%s,ipe)+px,:,jms:jme,itrace)\n",
+                       vname, p->members->stag_x?"":"-1", vname, p->members->stag_x?"":"-1" ) ;
+fprintf(fp, "  ENDDO\n" ) ;
+                    }
+                    else
+                    {
+fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
+fprintf(fp, "   %s ( ims:ime,:,jps:min(jde%s,jpe),itrace) = %s (ims:ime,:,jps+py:min(jde%s,jpe)+py,itrace)\n",
+                       vname, p->members->stag_y?"":"-1", vname, p->members->stag_y?"":"-1" ) ;
+fprintf(fp, "  ENDDO\n" ) ;
+                    }
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else
+	    {
+	      char * vdim ;
+	      vdim = "" ;
+	      if ( p->ndims == 3 ) vdim = ":," ;
+              if ( !strcmp( *direction, "x" ) )
+              {
+                fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),%sjms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,%sjms:jme)\n", vname2,  p->stag_x?"":"-1", vdim, vname2, p->stag_x?"":"-1", vdim ) ;
+              }
+              else
+	      {
+                fprintf(fp,"grid%%%s (ims:ime,%sjps:min(jde%s,jpe)) = grid%%%s (ims:ime,%sjps+py:min(jde%s,jpe)+py)\n", vname2, vdim,  p->stag_y?"":"-1", vname2, vdim, p->stag_y?"":"-1" ) ;
+              }
+            }
+	  }
+	}
+      }
+    }
+
+    close_the_file(fp) ;
+  }
+  }
+}
+
+int
+gen_datacalls ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fn = "data_calls.inc" ;
+  char fname[NAMELEN] ;
+
+  for ( i = 0 ; i < get_num_cores() ; i++ )
+  {
+    corename = get_corename_i(i) ;
+    if ( dirname == NULL || corename == NULL ) return(1) ;
+    if ( strlen(dirname) > 0 )
+     { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+    else
+     { sprintf(fname,"%s_%s",corename,fn) ; }
+    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+    print_warning(fp,fname) ;
+    close_the_file(fp) ;
+  }
+  return(0) ;
+}
+
+/*****************/
+/*****************/
+
+gen_nest_packing ( char * dirname )
+{
+  gen_nest_pack( dirname ) ;
+  gen_nest_unpack( dirname ) ;
+}
+
+#define PACKIT 1
+#define UNPACKIT 2
+
+int
+gen_nest_pack ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
+  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
+  int ipath ;
+  char ** fnp ; char * fn ;
+  char * shw_str ;
+  char fname[NAMELEN] ;
+  node_t *node, *p, *dim ;
+  int xdex, ydex, zdex ;
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  int d2, d3, sw ;
+  char *info_name ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+    for ( i = 0 ; i < get_num_cores() ; i++ )
+    {
+      corename = get_corename_i(i) ;
+      if ( dirname == NULL || corename == NULL ) return(1) ;
+      if ( strlen(dirname) > 0 ) {
+       if ( strlen( corename ) > 0 )
+         { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+       else
+         { sprintf(fname,"%s/%s",dirname,fn) ; }
+      } else { 
+       if ( strlen( corename ) > 0 ) 
+          { sprintf(fname,"%s_%s",corename,fn) ; }
+       else
+          { sprintf(fname,"%s",fn) ; }
+      }
+      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+      print_warning(fp,fname) ;
+
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
+
+      if ( d2 + d3 > 0 ) {
+        if ( down_path[ipath] == INTERP_UP )
+        {
+          info_name = "rsl_lite_to_parent_info" ;
+          sw = 0 ;
+        }
+        else
+        {
+          info_name = "rsl_lite_to_child_info" ;
+          sw = 1 ;
+        }
+
+        fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
+
+        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
+        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
+if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
+        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
+if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
+        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
+        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
+        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
+        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
+
+        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+  
+        gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
+
+        fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE                               &\n",info_name ) ;
+        fprintf(fp,"                        ,cips,cipe,cjps,cjpe                               &\n") ;
+if (sw) fprintf(fp,"                        ,iids,iide,ijds,ijde                               &\n") ;
+        fprintf(fp,"                        ,nids,nide,njds,njde                               &\n") ;
+if (sw) fprintf(fp,"                        ,pgr , sw                                          &\n") ;
+        fprintf(fp,"                        ,ntasks_x,ntasks_y                                 &\n") ; 
+        fprintf(fp,"                        ,icoord,jcoord                                     &\n") ;
+        fprintf(fp,"                        ,idim_cd,jdim_cd                                   &\n") ;
+        fprintf(fp,"                        ,pig,pjg,retval )\n") ;
+
+        fprintf(fp,"ENDDO\n") ;
+      }
+      close_the_file(fp) ;
+    }
+  }
+  return(0) ;
+}
+
+int
+gen_nest_unpack ( char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  char * corename ;
+  char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
+  int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
+  int ipath ;
+  char ** fnp ; char * fn ;
+  char fname[NAMELEN] ;
+  node_t *node, *p, *dim ;
+  int xdex, ydex, zdex ;
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char *info_name ;
+  char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  int d2, d3 ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+    for ( i = 0 ; i < get_num_cores() ; i++ )
+    {
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      corename = get_corename_i(i) ;
+      if ( dirname == NULL || corename == NULL ) return(1) ;
+      if ( strlen(dirname) > 0 )
+       { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
+      else
+       { sprintf(fname,"%s_%s",corename,fn) ; }
+      if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+      print_warning(fp,fname) ;
+
+      count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
+
+      if ( d2 + d3 > 0 ) {
+        if ( down_path[ipath] == INTERP_UP )
+        {
+          info_name = "rsl_lite_from_child_info" ;
+        }
+        else
+        {
+          info_name = "rsl_lite_from_parent_info" ;
+        }
+
+        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
+        fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
+        gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
+        fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
+        fprintf(fp,"ENDDO\n") ;
+      }
+      close_the_file(fp) ;
+    }
+  }
+  return(0) ;
+}
+
+int
+gen_nest_packunpack ( FILE *fp , node_t * node , char * corename, int dir, int down_path )
+{
+  int i ;
+  node_t *p, *p1, *dim ;
+  int d2, d3, xdex, ydex, zdex ;
+  int io_mask ;
+  char * grid ; 
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN], vname2[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
+  char c, d ;
+
+  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
+  {
+
+    if ( p1->node_kind & FOURD )
+    {
+      if ( p1->members->next )
+        io_mask = p1->members->next->io_mask ;
+      else
+        continue ;
+    }
+    else
+    {
+      io_mask = p1->io_mask ;
+    }
+    p = p1 ;
+
+    if ( io_mask & down_path )
+    {
+      if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
+      {
+        if ( p->node_kind & FOURD ) {
+          if (!strncmp( p->members->next->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
+          else                                               sprintf(core,"") ;
+          if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
+          else                             sprintf(tag,"") ;
+          set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
+          zdex = get_index_for_coord( p->members , COORD_Z ) ;
+          xdex = get_index_for_coord( p->members , COORD_X ) ;
+          ydex = get_index_for_coord( p->members , COORD_Y ) ;
+        } else {
+          if (!strncmp( p->use, "dyn_", 4))   sprintf(core,"%s",corename) ;
+          else                                sprintf(core,"") ;
+          if ( p->ntl > 1 ) sprintf(tag,"_2") ;
+          else              sprintf(tag,"") ;
+          set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
+          zdex = get_index_for_coord( p , COORD_Z ) ;
+          xdex = get_index_for_coord( p , COORD_X ) ;
+          ydex = get_index_for_coord( p , COORD_Y ) ;
+        }
+
+        if ( down_path == INTERP_UP )
+        {
+          c = ( dir == PACKIT )?'n':'p' ;
+          d = ( dir == PACKIT )?'2':'1' ;
+        } else {
+          c = ( dir == UNPACKIT )?'n':'p' ;
+          d = ( dir == UNPACKIT )?'2':'1' ;
+        }
+
+        if ( zdex >= 0 ) {
+          if      ( xdex == 0 && zdex == 1 && ydex == 2 )  sprintf(dexes,"pig,k,pjg") ;
+          else if ( zdex == 0 && xdex == 1 && ydex == 2 )  sprintf(dexes,"k,pig,pjg") ;
+          else if ( xdex == 0 && ydex == 1 && zdex == 2 )  sprintf(dexes,"pig,pjg,k") ;
+        } else {
+          if ( xdex == 0 && ydex == 1 )  sprintf(dexes,"pig,pjg") ;
+          if ( ydex == 0 && xdex == 1 )  sprintf(dexes,"pjg,pig") ;
+        }
+
+        /* construct variable name */
+        if ( p->node_kind & FOURD )
+        {
+          sprintf(vname,"%s%s(%s,itrace)",p->name,tag,dexes) ;
+          if ( strlen(core) > 0 )
+            sprintf(vname2,"%s_%s%s(%s,itrace)",core,p->use,tag,dexes) ;
+          else
+            sprintf(vname2,"%s%s(%s,itrace)",p->name,tag,dexes) ;
+        }
+        else
+        {
+          sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
+          if ( strlen(core) > 0 )
+            sprintf(vname2,"%s_%s%s(%s)",core,p->name,tag,dexes) ;
+          else
+            sprintf(vname2,"%s%s(%s)",p->name,tag,dexes) ;
+        }
+
+        grid = "grid%" ;
+        if ( p->node_kind & FOURD )
+	{
+           grid = "" ;
+fprintf(fp,"DO itrace =  PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
+	}
+
+        if ( dir == UNPACKIT ) 
+        {
+          if ( down_path == INTERP_UP )
+	  {
+            if ( zdex >= 0 ) {
+fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
+            }
+fprintf(fp,"IF ( %s_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
+                 corename, p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], grid, vname2 ) ;
+            } else {
+              fprintf(fp,"%s%s = xv(1) ;\n", grid,vname2) ;
+            }
+fprintf(fp,"ENDIF\n") ;
+          }
+          else
+          {
+            if ( zdex >= 0 ) {
+fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
+                                    ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname2) ;
+            } else {
+fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname2) ;
+            }
+          }
+        }
+        else
+        {
+          if ( down_path == INTERP_UP )
+	  {
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
+                           ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname2) ;
+            }
+          }
+          else
+          {
+            if ( zdex >= 0 ) {
+fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
+                           ddim[zdex][0], ddim[zdex][1], grid, vname2, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname2) ;
+            }
+          }
+        }
+        if ( p->node_kind & FOURD )
+	{
+fprintf(fp,"ENDDO\n") ;
+	}
+      }
+    }
+  }
+
+  return(0) ;
+}
+
+/*****************/
+
+int
+count_fields ( node_t * node , int * d2 , int * d3 , char * corename , int down_path )
+{
+  node_t * p ;
+  int zdex ;
+/* count up the total number of levels from all fields */
+  for ( p = node ;  p != NULL ; p = p->next )
+  {
+    if ( p->node_kind == FOURD ) 
+    {
+      count_fields( p->members , d2 , d3 , corename , down_path ) ;  /* RECURSE */
+    }
+    else
+    {
+      if ( p->io_mask & down_path )
+      {
+        if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
+        {
+          if ( p->node_kind == FOURD )
+            zdex = get_index_for_coord( p->members , COORD_Z ) ;
+          else
+            zdex = get_index_for_coord( p , COORD_Z ) ;
+  
+          if ( zdex < 0 ) {
+            (*d2)++ ;   /* if no zdex then only 2 d */
+          } else {
+            (*d3)++ ;   /* if has a zdex then 3 d */
+          }
+        }
+      }
+    }
+  }
+  return(0) ;
+}
+
+/*****************/
+
+int
+gen_comms ( char * dirname )
+{
+  if ( sw_dm_parallel )
+    fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
+
+  gen_halos( "inc" , NULL, Halos ) ;
+  gen_shift( "inc" ) ;
+  gen_periods( "inc", Periods ) ;
+  gen_swaps( "inc", Swaps ) ;
+  gen_cycles( "inc", Cycles ) ;
+  gen_xposes( "inc" ) ;
+  gen_comm_descrips( "inc" ) ;
+  gen_datacalls( "inc" ) ;
+  gen_nest_packing( "inc" ) ;
+
+  return(0) ;
+}
+
diff --git a/wrfv2_fire/external/RSL_LITE/makefile b/wrfv2_fire/external/RSL_LITE/makefile
new file mode 100644
index 00000000..039302c8
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/makefile
@@ -0,0 +1,52 @@
+OBJSL   = c_code.o buf_for_proc.o rsl_malloc.o rsl_bcast.o task_for_point.o period.o swap.o cycle.o f_pack.o f_xpose.o
+OBJS    = $(OBJSL)
+OPTS    =
+FFLAGS  =  $(OPTS)
+LIBS    = 
+M4      = m4 -Uinclude -Uindex -Ulen
+AR      = ar
+CFLAGS = 
+
+.SUFFIXES:      .F90 .F .f .o .code
+
+all : librsl_lite.a
+
+librsl_lite.a:          $(OBJS)
+			/bin/rm -f librsl_lite.a
+			$(AR) cr librsl_lite.a $(OBJSL)
+
+c_code.o:	        c_code.c
+			$(CC) $(CFLAGS) -c c_code.c
+
+period.o:	        period.c
+			$(CC) $(CFLAGS) -c period.c
+
+swap.o:	                swap.c
+			$(CC) $(CFLAGS) -c swap.c
+
+cycle.o:	        cycle.c
+			$(CC) $(CFLAGS) -c cycle.c
+
+rsl_bcast.o:	        rsl_bcast.c
+			$(CC) $(CFLAGS) -c rsl_bcast.c
+
+rsl_malloc.o:	        rsl_malloc.c
+			$(CC) $(CFLAGS) -c rsl_malloc.c
+
+task_for_point.o:	task_for_point.c
+			$(CC) $(CFLAGS) -c task_for_point.c
+
+buf_for_proc.o:	        buf_for_proc.c
+			$(CC) $(CFLAGS) -c buf_for_proc.c
+
+f_pack.o:	        f_pack.F90
+			$(FC) $(FFLAGS) -c f_pack.F90
+
+f_xpose.o:	        f_xpose.F90 f_pack.o
+			$(FC) $(FFLAGS) -c f_xpose.F90
+
+clean : 
+			/bin/rm -f *.f *.o *.mod
+
+superclean : clean
+			/bin/rm -f *.a
diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F
new file mode 100644
index 00000000..90e597a3
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/module_dm.F
@@ -0,0 +1,3536 @@
+!WRF:PACKAGE:RSL 
+!
+MODULE module_dm
+
+   USE module_machine
+   USE module_configure
+   USE module_state_description
+   USE module_wrf_error
+   USE module_driver_constants
+   IMPLICIT NONE
+
+#if ( NMM_CORE == 1 ) || defined( WRF_CHEM ) 
+   INTEGER, PARAMETER :: max_halo_width = 6
+#else
+   INTEGER, PARAMETER :: max_halo_width = 5
+#endif
+
+   INTEGER :: ips_save, ipe_save, jps_save, jpe_save, itrace
+
+   INTEGER ntasks, ntasks_y, ntasks_x, mytask, mytask_x, mytask_y
+   INTEGER local_communicator, local_communicator_periodic, local_iocommunicator
+   INTEGER local_communicator_x, local_communicator_y ! subcommunicators for rows and cols of mesh
+   LOGICAL :: dm_debug_flag = .FALSE.
+
+   INTERFACE wrf_dm_maxval
+     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
+   END INTERFACE
+
+   INTERFACE wrf_dm_minval                       ! gopal's doing
+     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
+   END INTERFACE
+
+CONTAINS
+
+
+   SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
+      IMPLICIT NONE
+      INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N
+      MINI = 2*P
+      MINM = 1
+      MINN = P
+      DO M = 1, P
+        IF ( MOD( P, M ) .EQ. 0 ) THEN
+          N = P / M
+          IF ( ABS(M-N) .LT. MINI                &
+               .AND. M .GE. PROCMIN_M            &
+               .AND. N .GE. PROCMIN_N            &
+             ) THEN
+            MINI = ABS(M-N)
+            MINM = M
+            MINN = N
+          ENDIF
+        ENDIF
+      ENDDO
+      IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
+        WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH.  STOPPING.'
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE(0,*)' PROCMIN_M ', PROCMIN_M
+        WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' P         ', P
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' MINM      ', MINM
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        WRITE( wrf_err_message , * )' MINN      ', MINN
+        CALL wrf_message ( TRIM ( wrf_err_message ) )
+        CALL wrf_error_fatal ( 'module_dm: mpaspect' )
+      ENDIF
+   RETURN
+   END SUBROUTINE MPASPECT
+
+   SUBROUTINE wrf_dm_initialize
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER :: local_comm, local_comm2, new_local_comm, group, newgroup, p, p1, ierr
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks
+      INTEGER comdup
+      INTEGER, DIMENSION(2) :: dims, coords
+      LOGICAL, DIMENSION(2) :: isperiodic
+      LOGICAL :: reorder_mesh
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL mpi_comm_size( local_comm, ntasks, ierr )
+      CALL nl_get_nproc_x ( 1, ntasks_x )
+      CALL nl_get_nproc_y ( 1, ntasks_y )
+      CALL nl_get_reorder_mesh( 1, reorder_mesh )
+
+! check if user has specified in the namelist
+      IF ( ntasks_x .GT. 0 .OR. ntasks_y .GT. 0 ) THEN
+        ! if only ntasks_x is specified then make it 1-d decomp in i
+        IF      ( ntasks_x .GT. 0 .AND. ntasks_y .EQ. -1 ) THEN
+          ntasks_y = ntasks / ntasks_x
+        ! if only ntasks_y is specified then make it 1-d decomp in j
+        ELSE IF ( ntasks_x .EQ. -1 .AND. ntasks_y .GT. 0 ) THEN
+          ntasks_x = ntasks / ntasks_y
+        ENDIF
+        ! make sure user knows what they're doing
+        IF ( ntasks_x * ntasks_y .NE. ntasks ) THEN
+          WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL_LITE): nproc_x * nproc_y in namelist ne ',ntasks
+          CALL wrf_error_fatal ( wrf_err_message )
+        ENDIF
+      ELSE
+        ! When neither is specified, work out mesh with MPASPECT
+        ! Pass nproc_ln and nproc_nt so that number of procs in
+        ! i-dim (nproc_ln) is equal or lesser.
+        CALL mpaspect ( ntasks, ntasks_x, ntasks_y, 1, 1 )
+      ENDIF
+      WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y
+      CALL wrf_message( wrf_err_message )
+
+      CALL mpi_comm_rank( local_comm, mytask, ierr )
+! extra code to reorder the communicator 20051212jm
+      IF ( reorder_mesh ) THEN
+write(0,*)'reordering mesh'
+        ALLOCATE (ranks(ntasks))
+        CALL mpi_comm_dup ( local_comm , local_comm2, ierr )
+        CALL mpi_comm_group ( local_comm2, group, ierr )
+        DO p1=1,ntasks
+          p = p1 - 1
+          ranks(p1) = mod( p , ntasks_x ) * ntasks_y + p / ntasks_x  
+        ENDDO
+        CALL mpi_group_incl( group, ntasks, ranks, newgroup, ierr )
+        DEALLOCATE (ranks)
+        CALL mpi_comm_create( local_comm2, newgroup, new_local_comm , ierr )
+      ELSE
+        new_local_comm = local_comm
+      ENDIF
+! end extra code to reorder the communicator 20051212jm
+      dims(1) = ntasks_y  ! rows
+      dims(2) = ntasks_x  ! columns
+      isperiodic(1) = .false.
+      isperiodic(2) = .false.
+      CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierr )
+      dims(1) = ntasks_y  ! rows
+      dims(2) = ntasks_x  ! columns
+      isperiodic(1) = .true.
+      isperiodic(2) = .true.
+      CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator_periodic, ierr )
+! debug
+      CALL mpi_comm_rank( local_communicator_periodic, mytask, ierr )
+      CALL mpi_cart_coords( local_communicator_periodic, mytask, 2, coords, ierr )
+        write(0,*)'periodic coords ',mytask, coords
+
+      CALL mpi_comm_rank( local_communicator, mytask, ierr )
+      CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierr )
+        write(0,*)'non periodic coords ',mytask, coords
+      mytask_x = coords(2)   ! col task (x)
+      mytask_y = coords(1)   ! row task (y)
+      CALL nl_set_nproc_x ( 1, ntasks_x )
+      CALL nl_set_nproc_y ( 1, ntasks_y )
+
+! 20061228 set up subcommunicators for processors in X, Y coords of mesh
+! note that local_comm_x has all the processors in a row (X=0:nproc_x-1);
+! in other words, local_comm_x has all the processes with the same rank in Y
+      CALL MPI_Comm_dup( new_local_comm, comdup, ierr )
+      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_dup fails in 20061228 mod')
+      CALL MPI_Comm_split(comdup,mytask_y,mytask,local_communicator_x,ierr)
+      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for x in 20061228 mod')
+      CALL MPI_Comm_split(comdup,mytask_x,mytask,local_communicator_y,ierr)
+      IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for y in 20061228 mod')
+! end 20061228
+
+      CALL wrf_set_dm_communicator ( local_communicator )
+      RETURN
+   END SUBROUTINE wrf_dm_initialize
+
+   SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
+                                sd1 , ed1 , sp1 , ep1 , sm1 , em1 ,        &
+                                sd2 , ed2 , sp2 , ep2 , sm2 , em2 ,        &
+                                sd3 , ed3 , sp3 , ep3 , sm3 , em3 ,        &
+                                      sp1x , ep1x , sm1x , em1x , &
+                                      sp2x , ep2x , sm2x , em2x , &
+                                      sp3x , ep3x , sm3x , em3x , &
+                                      sp1y , ep1y , sm1y , em1y , &
+                                      sp2y , ep2y , sm2y , em2y , &
+                                      sp3y , ep3y , sm3y , em3y , &
+                                bdx , bdy )
+
+      USE module_domain
+      USE module_machine
+
+      IMPLICIT NONE
+      INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
+      INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
+                               sm1 , em1 , sm2 , em2 , sm3 , em3
+      INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
+                               sm1x , em1x , sm2x , em2x , sm3x , em3x
+      INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
+                               sm1y , em1y , sm2y , em2y , sm3y , em3y
+      INTEGER, INTENT(IN)   :: id, parent_id
+      TYPE(domain),POINTER  :: parent
+
+! Local variables
+      INTEGER               :: ids, ide, jds, jde, kds, kde
+      INTEGER               :: ims, ime, jms, jme, kms, kme
+      INTEGER               :: ips, ipe, jps, jpe, kps, kpe
+      INTEGER               :: imsx, imex, jmsx, jmex, kmsx, kmex
+      INTEGER               :: ipsx, ipex, jpsx, jpex, kpsx, kpex
+      INTEGER               :: imsy, imey, jmsy, jmey, kmsy, kmey
+      INTEGER               :: ipsy, ipey, jpsy, jpey, kpsy, kpey
+
+      INTEGER               :: c_sd1 , c_ed1 , c_sd2 , c_ed2 , c_sd3 , c_ed3
+      INTEGER               :: c_sp1 , c_ep1 , c_sp2 , c_ep2 , c_sp3 , c_ep3 , &
+                               c_sm1 , c_em1 , c_sm2 , c_em2 , c_sm3 , c_em3
+      INTEGER               :: c_sp1x , c_ep1x , c_sp2x , c_ep2x , c_sp3x , c_ep3x , &
+                               c_sm1x , c_em1x , c_sm2x , c_em2x , c_sm3x , c_em3x
+      INTEGER               :: c_sp1y , c_ep1y , c_sp2y , c_ep2y , c_sp3y , c_ep3y , &
+                               c_sm1y , c_em1y , c_sm2y , c_em2y , c_sm3y , c_em3y
+
+      INTEGER               :: c_ids, c_ide, c_jds, c_jde, c_kds, c_kde
+      INTEGER               :: c_ims, c_ime, c_jms, c_jme, c_kms, c_kme
+      INTEGER               :: c_ips, c_ipe, c_jps, c_jpe, c_kps, c_kpe
+
+      INTEGER               :: idim , jdim , kdim , rem , a, b
+      INTEGER               :: i, j, ni, nj, Px, Py, P
+
+      INTEGER               :: parent_grid_ratio, i_parent_start, j_parent_start
+      INTEGER               :: shw
+      INTEGER               :: idim_cd, jdim_cd
+
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER  :: nest_grid
+
+
+      SELECT CASE ( model_data_order )
+         ! need to finish other cases
+         CASE ( DATA_ORDER_ZXY )
+            ids = sd2 ; ide = ed2 
+            jds = sd3 ; jde = ed3 
+            kds = sd1 ; kde = ed1 
+         CASE ( DATA_ORDER_XYZ )
+            ids = sd1 ; ide = ed1 
+            jds = sd2 ; jde = ed2 
+            kds = sd3 ; kde = ed3 
+         CASE ( DATA_ORDER_XZY )
+            ids = sd1 ; ide = ed1 
+            jds = sd3 ; jde = ed3 
+            kds = sd2 ; kde = ed2 
+         CASE ( DATA_ORDER_YXZ)
+            ids = sd2 ; ide = ed2 
+            jds = sd1 ; jde = ed1 
+            kds = sd3 ; kde = ed3 
+      END SELECT
+
+      CALL compute_memory_dims_rsl_lite ( 0 , bdx, bdy,   &
+                   ids,  ide,  jds,  jde,  kds,  kde, &
+                   ims,  ime,  jms,  jme,  kms,  kme, &
+                   imsx, imex, jmsx, jmex, kmsx, kmex, &
+                   imsy, imey, jmsy, jmey, kmsy, kmey, &
+                   ips,  ipe,  jps,  jpe,  kps,  kpe, &
+                   ipsx, ipex, jpsx, jpex, kpsx, kpex, &
+                   ipsy, ipey, jpsy, jpey, kpsy, kpey )
+
+     ! ensure that the every parent domain point has a full set of nested points under it
+     ! even at the borders. Do this by making sure the number of nest points is a multiple of
+     ! the nesting ratio. Note that this is important mostly to the intermediate domain, which
+     ! is the subject of the scatter gather comms with the parent
+
+      IF ( id .GT. 1 ) THEN
+         CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
+         if ( mod(ime,parent_grid_ratio) .NE. 0 ) ime = ime + parent_grid_ratio - mod(ime,parent_grid_ratio)
+         if ( mod(jme,parent_grid_ratio) .NE. 0 ) jme = jme + parent_grid_ratio - mod(jme,parent_grid_ratio)
+      ENDIF
+
+      SELECT CASE ( model_data_order )
+         CASE ( DATA_ORDER_ZXY )
+            sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
+            sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
+            sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
+            sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
+            sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
+            sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
+            sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
+            sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
+            sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
+         CASE ( DATA_ORDER_ZYX )
+            sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
+            sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
+            sp1 = kps ; ep1 = kpe ; sm1 = kms ; em1 = kme
+            sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
+            sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
+            sp1x = kpsx ; ep1x = kpex ; sm1x = kmsx ; em1x = kmex
+            sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
+            sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
+            sp1y = kpsy ; ep1y = kpey ; sm1y = kmsy ; em1y = kmey
+         CASE ( DATA_ORDER_XYZ )
+            sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
+            sp2 = jps ; ep2 = jpe ; sm2 = jms ; em2 = jme
+            sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
+            sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
+            sp2x = jpsx ; ep2x = jpex ; sm2x = jmsx ; em2x = jmex
+            sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
+            sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
+            sp2y = jpsy ; ep2y = jpey ; sm2y = jmsy ; em2y = jmey
+            sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
+         CASE ( DATA_ORDER_YXZ)
+            sp2 = ips ; ep2 = ipe ; sm2 = ims ; em2 = ime
+            sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
+            sp3 = kps ; ep3 = kpe ; sm3 = kms ; em3 = kme
+            sp2x = ipsx ; ep2x = ipex ; sm2x = imsx ; em2x = imex
+            sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
+            sp3x = kpsx ; ep3x = kpex ; sm3x = kmsx ; em3x = kmex
+            sp2y = ipsy ; ep2y = ipey ; sm2y = imsy ; em2y = imey
+            sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
+            sp3y = kpsy ; ep3y = kpey ; sm3y = kmsy ; em3y = kmey
+         CASE ( DATA_ORDER_XZY )
+            sp1 = ips ; ep1 = ipe ; sm1 = ims ; em1 = ime
+            sp3 = jps ; ep3 = jpe ; sm3 = jms ; em3 = jme
+            sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
+            sp1x = ipsx ; ep1x = ipex ; sm1x = imsx ; em1x = imex
+            sp3x = jpsx ; ep3x = jpex ; sm3x = jmsx ; em3x = jmex
+            sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
+            sp1y = ipsy ; ep1y = ipey ; sm1y = imsy ; em1y = imey
+            sp3y = jpsy ; ep3y = jpey ; sm3y = jmsy ; em3y = jmey
+            sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
+         CASE ( DATA_ORDER_YZX )
+            sp3 = ips ; ep3 = ipe ; sm3 = ims ; em3 = ime
+            sp1 = jps ; ep1 = jpe ; sm1 = jms ; em1 = jme
+            sp2 = kps ; ep2 = kpe ; sm2 = kms ; em2 = kme
+            sp3x = ipsx ; ep3x = ipex ; sm3x = imsx ; em3x = imex
+            sp1x = jpsx ; ep1x = jpex ; sm1x = jmsx ; em1x = jmex
+            sp2x = kpsx ; ep2x = kpex ; sm2x = kmsx ; em2x = kmex
+            sp3y = ipsy ; ep3y = ipey ; sm3y = imsy ; em3y = imey
+            sp1y = jpsy ; ep1y = jpey ; sm1y = jmsy ; em1y = jmey
+            sp2y = kpsy ; ep2y = kpey ; sm2y = kmsy ; em2y = kmey
+      END SELECT
+
+      IF ( id.EQ.1 ) THEN
+         WRITE(wrf_err_message,*)'*************************************'
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'Parent domain'
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'*************************************'
+         CALL wrf_message( TRIM(wrf_err_message) )
+      ENDIF
+
+      IF ( id .GT. 1 ) THEN
+
+         CALL nl_get_shw( id, shw )
+         CALL nl_get_i_parent_start( id , i_parent_start )
+         CALL nl_get_j_parent_start( id , j_parent_start )
+         CALL nl_get_parent_grid_ratio( id, parent_grid_ratio )
+
+         SELECT CASE ( model_data_order )
+            CASE ( DATA_ORDER_ZXY )
+               idim = ed2-sd2+1
+               jdim = ed3-sd3+1
+               kdim = ed1-sd1+1
+               c_kds = sd1                ; c_kde = ed1
+            CASE ( DATA_ORDER_ZYX )
+               idim = ed3-sd3+1
+               jdim = ed2-sd2+1
+               kdim = ed1-sd1+1
+               c_kds = sd1                ; c_kde = ed1
+            CASE ( DATA_ORDER_XYZ )
+               idim = ed1-sd1+1
+               jdim = ed2-sd2+1
+               kdim = ed3-sd3+1
+               c_kds = sd3                ; c_kde = ed3
+            CASE ( DATA_ORDER_YXZ)
+               idim = ed2-sd2+1
+               jdim = ed1-sd1+1
+               kdim = ed3-sd3+1
+               c_kds = sd3                ; c_kde = ed3
+            CASE ( DATA_ORDER_XZY )
+               idim = ed1-sd1+1
+               jdim = ed3-sd3+1
+               kdim = ed2-sd2+1
+               c_kds = sd2                ; c_kde = ed2
+            CASE ( DATA_ORDER_YZX )
+               idim = ed3-sd3+1
+               jdim = ed1-sd1+1
+               kdim = ed2-sd2+1
+               c_kds = sd2                ; c_kde = ed2
+         END SELECT
+
+         idim_cd = idim / parent_grid_ratio + 1 + 2*shw + 1
+         jdim_cd = jdim / parent_grid_ratio + 1 + 2*shw + 1
+
+         c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
+         c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
+
+         ! we want the intermediate domain to be decomposed the
+         ! the same as the underlying nest. So try this:
+
+! At such time as NMM nesting is able to use RSL_LITE (would require
+! a number of other mods to this file for that to happen), this should
+! be updated along the lines of what's done in compute_memory_dims_rsl_lite
+! below. See note dated 20051020.  JM
+
+         c_ips = -1
+         nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
+         DO i = c_ids, c_ide
+            ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
+            IF ( Px .EQ. mytask_x ) THEN
+               c_ipe = i
+               IF ( c_ips .EQ. -1 ) c_ips = i
+            ENDIF
+         ENDDO
+
+         c_jps = -1
+         ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
+         DO j = c_jds, c_jde
+            nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
+            IF ( Py .EQ. mytask_y ) THEN
+               c_jpe = j
+               IF ( c_jps .EQ. -1 ) c_jps = j
+            ENDIF
+         ENDDO
+
+! extend the patch dimensions out shw along edges of domain
+         IF ( mytask_x .EQ. 0 ) THEN
+           c_ips = c_ips - shw
+         ENDIF
+         IF ( mytask_x .EQ. ntasks_x-1 ) THEN
+           c_ipe = c_ipe + shw
+         ENDIF
+         c_ims = max( c_ips - max(shw,max_halo_width), c_ids - bdx ) - 1
+         c_ime = min( c_ipe + max(shw,max_halo_width), c_ide + bdx ) + 1
+
+! handle j dims
+! extend the patch dimensions out shw along edges of domain
+         IF ( mytask_y .EQ. 0 ) THEN
+            c_jps = c_jps - shw
+         ENDIF
+         IF ( mytask_y .EQ. ntasks_y-1 ) THEN
+            c_jpe = c_jpe + shw
+         ENDIF
+         c_jms = max( c_jps - max(shw,max_halo_width), c_jds - bdx ) - 1
+         c_jme = min( c_jpe + max(shw,max_halo_width), c_jde + bdx ) + 1
+! handle k dims
+         c_kps = 1
+         c_kpe = c_kde
+         c_kms = 1
+         c_kme = c_kde
+
+         WRITE(wrf_err_message,*)'*************************************'
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'Nesting domain'
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',ids,ide,jds,jde
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',ims,ime,jms,jme
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',ips,ipe,jps,jpe
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'INTERMEDIATE domain'
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ids,ide,jds,jde ',c_ids,c_ide,c_jds,c_jde
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ims,ime,jms,jme ',c_ims,c_ime,c_jms,c_jme
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'ips,ipe,jps,jpe ',c_ips,c_ipe,c_jps,c_jpe
+         CALL wrf_message( TRIM(wrf_err_message) )
+         WRITE(wrf_err_message,*)'*************************************'
+         CALL wrf_message( TRIM(wrf_err_message) )
+
+         SELECT CASE ( model_data_order )
+            CASE ( DATA_ORDER_ZXY )
+               c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
+               c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
+               c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
+            CASE ( DATA_ORDER_ZYX )
+               c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
+               c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
+               c_sd1 = c_kds ; c_ed1 = c_kde ; c_sp1 = c_kps ; c_ep1 = c_kpe ; c_sm1 = c_kms ; c_em1 = c_kme
+            CASE ( DATA_ORDER_XYZ )
+               c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
+               c_sd2 = c_jds ; c_ed2 = c_jde ; c_sp2 = c_jps ; c_ep2 = c_jpe ; c_sm2 = c_jms ; c_em2 = c_jme
+               c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
+            CASE ( DATA_ORDER_YXZ)
+               c_sd2 = c_ids ; c_ed2 = c_ide ; c_sp2 = c_ips ; c_ep2 = c_ipe ; c_sm2 = c_ims ; c_em2 = c_ime
+               c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
+               c_sd3 = c_kds ; c_ed3 = c_kde ; c_sp3 = c_kps ; c_ep3 = c_kpe ; c_sm3 = c_kms ; c_em3 = c_kme
+            CASE ( DATA_ORDER_XZY )
+               c_sd1 = c_ids ; c_ed1 = c_ide ; c_sp1 = c_ips ; c_ep1 = c_ipe ; c_sm1 = c_ims ; c_em1 = c_ime
+               c_sd3 = c_jds ; c_ed3 = c_jde ; c_sp3 = c_jps ; c_ep3 = c_jpe ; c_sm3 = c_jms ; c_em3 = c_jme
+               c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
+            CASE ( DATA_ORDER_YZX )
+               c_sd3 = c_ids ; c_ed3 = c_ide ; c_sp3 = c_ips ; c_ep3 = c_ipe ; c_sm3 = c_ims ; c_em3 = c_ime
+               c_sd1 = c_jds ; c_ed1 = c_jde ; c_sp1 = c_jps ; c_ep1 = c_jpe ; c_sm1 = c_jms ; c_em1 = c_jme
+               c_sd2 = c_kds ; c_ed2 = c_kde ; c_sp2 = c_kps ; c_ep2 = c_kpe ; c_sm2 = c_kms ; c_em2 = c_kme
+         END SELECT
+
+         ALLOCATE ( intermediate_grid )
+         ALLOCATE ( intermediate_grid%parents( max_parents ) )
+         ALLOCATE ( intermediate_grid%nests( max_nests ) )
+
+         NULLIFY( intermediate_grid%sibling )
+         DO i = 1, max_nests
+            NULLIFY( intermediate_grid%nests(i)%ptr )
+         ENDDO
+         NULLIFY  (intermediate_grid%next)
+         NULLIFY  (intermediate_grid%same_level)
+         NULLIFY  (intermediate_grid%i_start)
+         NULLIFY  (intermediate_grid%j_start)
+         NULLIFY  (intermediate_grid%i_end)
+         NULLIFY  (intermediate_grid%j_end)
+         intermediate_grid%id = id
+         intermediate_grid%num_nests = 0
+         intermediate_grid%num_siblings = 0
+         intermediate_grid%num_parents = 1
+         intermediate_grid%max_tiles   = 0
+         intermediate_grid%num_tiles_spec   = 0
+         CALL find_grid_by_id ( id, head_grid, nest_grid )
+
+         nest_grid%intermediate_grid => intermediate_grid  ! nest grid now has a pointer to this baby
+         intermediate_grid%parents(1)%ptr => nest_grid     ! the intermediate grid considers nest its parent
+         intermediate_grid%num_parents = 1
+
+         c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
+         c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
+
+         intermediate_grid%sm31x                           = c_sm1x
+         intermediate_grid%em31x                           = c_em1x
+         intermediate_grid%sm32x                           = c_sm2x
+         intermediate_grid%em32x                           = c_em2x
+         intermediate_grid%sm33x                           = c_sm3x
+         intermediate_grid%em33x                           = c_em3x
+         intermediate_grid%sm31y                           = c_sm1y
+         intermediate_grid%em31y                           = c_em1y
+         intermediate_grid%sm32y                           = c_sm2y
+         intermediate_grid%em32y                           = c_em2y
+         intermediate_grid%sm33y                           = c_sm3y
+         intermediate_grid%em33y                           = c_em3y
+
+#ifdef SGIALTIX
+         ! allocate space for the intermediate domain
+         CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., &   ! use same id as nest
+                               c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3,       &
+                               c_sm1,  c_em1,  c_sm2,  c_em2,  c_sm3,  c_em3,  &
+                               c_sm1x, c_em1x, c_sm2x, c_em2x, c_sm3x, c_em3x, &   ! x-xpose
+                               c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y  )   ! y-xpose
+#endif
+         intermediate_grid%sd31                            =   c_sd1
+         intermediate_grid%ed31                            =   c_ed1
+         intermediate_grid%sp31                            = c_sp1
+         intermediate_grid%ep31                            = c_ep1
+         intermediate_grid%sm31                            = c_sm1
+         intermediate_grid%em31                            = c_em1
+         intermediate_grid%sd32                            =   c_sd2
+         intermediate_grid%ed32                            =   c_ed2
+         intermediate_grid%sp32                            = c_sp2
+         intermediate_grid%ep32                            = c_ep2
+         intermediate_grid%sm32                            = c_sm2
+         intermediate_grid%em32                            = c_em2
+         intermediate_grid%sd33                            =   c_sd3
+         intermediate_grid%ed33                            =   c_ed3
+         intermediate_grid%sp33                            = c_sp3
+         intermediate_grid%ep33                            = c_ep3
+         intermediate_grid%sm33                            = c_sm3
+         intermediate_grid%em33                            = c_em3
+
+         CALL med_add_config_info_to_grid ( intermediate_grid )
+
+         intermediate_grid%dx = parent%dx
+         intermediate_grid%dy = parent%dy
+         intermediate_grid%dt = parent%dt
+      ENDIF
+
+      RETURN
+  END SUBROUTINE patch_domain_rsl_lite
+
+  SUBROUTINE compute_memory_dims_rsl_lite  (      &
+                   shw , bdx,  bdy ,              &
+                   ids,  ide,  jds,  jde,  kds,  kde, &
+                   ims,  ime,  jms,  jme,  kms,  kme, &
+                   imsx, imex, jmsx, jmex, kmsx, kmex, &
+                   imsy, imey, jmsy, jmey, kmsy, kmey, &
+                   ips,  ipe,  jps,  jpe,  kps,  kpe, &
+                   ipsx, ipex, jpsx, jpex, kpsx, kpex, &
+                   ipsy, ipey, jpsy, jpey, kpsy, kpey )
+
+    USE module_machine
+    IMPLICIT NONE
+    INTEGER, INTENT(IN)               ::  shw, bdx, bdy
+    INTEGER, INTENT(IN)     ::  ids, ide, jds, jde, kds, kde
+    INTEGER, INTENT(OUT)    ::  ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(OUT)    ::  imsx, imex, jmsx, jmex, kmsx, kmex
+    INTEGER, INTENT(OUT)    ::  imsy, imey, jmsy, jmey, kmsy, kmey
+    INTEGER, INTENT(OUT)    ::  ips, ipe, jps, jpe, kps, kpe
+    INTEGER, INTENT(OUT)    ::  ipsx, ipex, jpsx, jpex, kpsx, kpex
+    INTEGER, INTENT(OUT)    ::  ipsy, ipey, jpsy, jpey, kpsy, kpey
+
+    INTEGER Px, Py, P, i, j, k
+
+#if ( ! NMM_CORE == 1 )
+
+! xy decomposition
+
+    ips = -1
+    j = jds ;
+    DO i = ids, ide
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
+       IF ( Px .EQ. mytask_x ) THEN
+          ipe = i
+          IF ( ips .EQ. -1 ) ips = i
+       ENDIF
+    ENDDO
+    jps = -1
+    i = ids ;
+    DO j = jds, jde
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpe = j
+          IF ( jps .EQ. -1 ) jps = j
+       ENDIF
+    ENDDO
+
+! 
+! description of transpose decomposition strategy for RSL LITE. 20061231jm
+!
+! Here is the tranpose scheme that is implemented for RSL_LITE. Upper-case
+! XY corresponds to the dimension of the processor mesh, lower-case xyz
+! corresponds to grid dimension.
+! 
+!      xy        zy        zx
+! 
+!     XxYy <--> XzYy <--> XzYx <- note x decomposed over Y procs
+!       ^                  ^
+!       |                  |
+!       +------------------+  <- this edge is costly; see below
+! 
+! The aim is to avoid all-to-all communication over whole
+! communicator. Instead, when possible, use a transpose scheme that requires
+! all-to-all within dimensional communicators; that is, communicators
+! defined for the processes in a rank or column of the processor mesh. Note,
+! however, it is not possible to create a ring of transposes between
+! xy-yz-xz decompositions without at least one of the edges in the ring
+! being fully all-to-all (in other words, one of the tranpose edges must
+! rotate and not just transpose a plane of the model grid within the
+! processor mesh). The issue is then, where should we put this costly edge
+! in the tranpose scheme we chose? To avoid being completely arbitrary, 
+! we chose a scheme most natural for models that use parallel spectral
+! transforms, where the costly edge is the one that goes from the xz to
+! the xy decomposition.  (May be implemented as just a two step transpose
+! back through yz).
+!
+! Additional notational convention, below. The 'x' or 'y' appended to the
+! dimension start or end variable refers to which grid dimension is all
+! on-processor in the given decomposition. That is ipsx and ipex are the
+! start and end for the i-dimension in the zy decomposition where x is
+! on-processor. ('z' is assumed for xy decomposition and not appended to
+! the ips, ipe, etc. variable names).
+! 
+
+! XzYy decomposition
+
+    kpsx = -1
+    j = jds ;
+    DO k = kds, kde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py )
+       IF ( Px .EQ. mytask_x ) THEN
+          kpex = k
+          IF ( kpsx .EQ. -1 ) kpsx = k
+       ENDIF
+    ENDDO
+
+    jpsx = -1
+    k = kds ;
+    DO j = jds, jde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpex = j
+          IF ( jpsx .EQ. -1 ) jpsx = j
+       ENDIF
+    ENDDO
+
+! XzYx decomposition  (note, x grid dim is decomposed over Y processor dim)
+
+    kpsy = kpsx   ! same as above
+    kpey = kpex   ! same as above
+
+    ipsy = -1
+    k = kds ;
+    DO i = ids, ide
+       CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px ) ! x and y for proc mesh reversed
+       IF ( Py .EQ. mytask_y ) THEN
+          ipey = i
+          IF ( ipsy .EQ. -1 ) ipsy = i
+       ENDIF
+    ENDDO
+
+
+#else
+
+! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
+! adjust decomposition to reflect.  20051020 JM
+    ips = -1
+    j = jds ;
+    DO i = ids, ide-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py )
+       IF ( Px .EQ. mytask_x ) THEN
+          ipe = i
+          IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1
+          IF ( ips .EQ. -1 ) ips = i
+       ENDIF
+    ENDDO
+    jps = -1
+    i = ids ;
+    DO j = jds, jde-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpe = j
+          IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1
+          IF ( jps .EQ. -1 ) jps = j
+       ENDIF
+    ENDDO
+#endif
+
+! extend the patch dimensions out shw along edges of domain
+    IF ( mytask_x .EQ. 0 ) THEN
+       ips = ips - shw
+       ipsy = ipsy - shw
+    ENDIF
+    IF ( mytask_x .EQ. ntasks_x-1 ) THEN
+       ipe = ipe + shw
+       ipey = ipey + shw
+    ENDIF
+    IF ( mytask_y .EQ. 0 ) THEN
+       jps = jps - shw
+       jpsx = jpsx - shw
+    ENDIF
+    IF ( mytask_y .EQ. ntasks_y-1 ) THEN
+       jpe = jpe + shw
+       jpex = jpex + shw
+    ENDIF
+
+    kps = 1
+    kpe = kde-kds+1
+
+    kms = 1
+    kme = kpe
+    kmsx = kpsx
+    kmex = kpex
+    kmsy = kpsy
+    kmey = kpey
+
+    ims = max( ips - max(shw,max_halo_width), ids - bdx ) - 1
+    ime = min( ipe + max(shw,max_halo_width), ide + bdx ) + 1
+    imsx = ids
+    imex = ide
+    ipsx = imsx
+    ipex = imex
+    imsy = ipsy
+    imey = ipey
+
+    jms = max( jps - max(shw,max_halo_width), jds - bdy ) - 1
+    jme = min( jpe + max(shw,max_halo_width), jde + bdy ) + 1
+    jmsx = jpsx
+    jmex = jpex
+    jmsy = jds
+    jmey = jde
+    jpsy = jmsy
+    jpey = jmey
+
+  END SUBROUTINE compute_memory_dims_rsl_lite
+
+! internal, used below for switching the argument to MPI calls
+! if reals are being autopromoted to doubles in the build of WRF
+   INTEGER function getrealmpitype()
+#ifndef STUBMPI
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER rtypesize, dtypesize, ierr
+      CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
+      CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
+      IF ( RWORDSIZE .EQ. rtypesize ) THEN
+        getrealmpitype = MPI_REAL
+      ELSE IF ( RWORDSIZE .EQ. dtypesize ) THEN
+        getrealmpitype = MPI_DOUBLE_PRECISION
+      ELSE
+        CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' )
+      ENDIF
+#else
+! required dummy initialization for function that is never called
+      getrealmpitype = 1
+#endif
+      RETURN
+   END FUNCTION getrealmpitype
+
+   REAL FUNCTION wrf_dm_max_real ( inval )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      REAL inval, retval
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, local_communicator, ierr )
+      wrf_dm_max_real = retval
+   END FUNCTION wrf_dm_max_real
+
+   REAL FUNCTION wrf_dm_min_real ( inval )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      REAL inval, retval
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, local_communicator, ierr )
+      wrf_dm_min_real = retval
+   END FUNCTION wrf_dm_min_real
+
+   REAL FUNCTION wrf_dm_sum_real ( inval )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      REAL inval, retval
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, local_communicator, ierr )
+      wrf_dm_sum_real = retval
+   END FUNCTION wrf_dm_sum_real
+
+   INTEGER FUNCTION wrf_dm_sum_integer ( inval )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER inval, retval
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, local_communicator, ierr )
+      wrf_dm_sum_integer = retval
+   END FUNCTION wrf_dm_sum_integer
+
+   SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      REAL val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+      INTEGER i
+
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
+      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), local_communicator, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+   END SUBROUTINE wrf_dm_maxval_real
+
+   SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      DOUBLE PRECISION val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+      INTEGER i
+
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
+      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, local_communicator, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+   END SUBROUTINE wrf_dm_maxval_doubleprecision
+
+   SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+      INTEGER i
+
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr )
+      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, local_communicator, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .GT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+   END SUBROUTINE wrf_dm_maxval_integer
+
+!  For HWRF some additional computation is required. This is gopal's doing
+
+   SUBROUTINE wrf_dm_minval_real ( val, idex, jdex )
+      IMPLICIT NONE
+      REAL val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_REAL, val_all , 1, MPI_REAL, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_real
+
+   SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex )
+      IMPLICIT NONE
+      DOUBLE PRECISION val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_doubleprecision
+
+   SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex )
+      IMPLICIT NONE
+      INTEGER val, val_all( ntasks )
+      INTEGER idex, jdex, ierr
+      INTEGER dex(2)
+      INTEGER dex_all (2,ntasks)
+! 
+! Collective operation. Each processor calls passing a local value and its index; on return
+! all processors are passed back the maximum of all values passed and its index.
+!
+! 
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      dex(1) = idex ; dex(2) = jdex
+      CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr )
+      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
+      val = val_all(1)
+      idex = dex_all(1,1) ; jdex = dex_all(2,1)
+      DO i = 2, ntasks
+        IF ( val_all(i) .LT. val ) THEN
+           val = val_all(i)
+           idex = dex_all(1,i)
+           jdex = dex_all(2,i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_minval_integer     ! End of gopal's doing
+
+   SUBROUTINE init_module_dm
+      IMPLICIT NONE
+      INTEGER mpi_comm_local, ierr, mytask, nproc
+      INCLUDE 'mpif.h'
+      LOGICAL mpi_inited
+      CALL mpi_initialized( mpi_inited, ierr )
+      IF ( .NOT. mpi_inited ) THEN
+	! If MPI has not been initialized then initialize it and 
+	! make comm_world the communicator
+	! Otherwise, something else (e.g. quilt-io) has already 
+	! initialized MPI, so just grab the communicator that
+	! should already be stored and use that.
+	CALL mpi_init ( ierr )
+        CALL wrf_termio_dup
+	CALL wrf_set_dm_communicator ( MPI_COMM_WORLD )
+      ENDIF
+      CALL wrf_get_dm_communicator( mpi_comm_local )
+   END SUBROUTINE init_module_dm
+
+! stub
+   SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
+      USE module_domain
+      IMPLICIT NONE
+      TYPE (domain), INTENT(INOUT) :: parent, nest
+      INTEGER, INTENT(IN)          :: dx,dy
+      RETURN
+   END SUBROUTINE wrf_dm_move_nest
+
+!------------------------------------------------------------------------------
+   SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
+                                   mp_local_uobmask,            &
+                                   mp_local_vobmask,            &
+                                   mp_local_cobmask, errf )
+      
+!------------------------------------------------------------------------------
+!  PURPOSE: Do MPI allgatherv operation across processors to get the
+!           errors at each observation point on all processors. 
+!       
+!------------------------------------------------------------------------------
+#ifndef STUBMPI
+    INCLUDE 'mpif.h'
+        
+    INTEGER, INTENT(IN)   :: nsta                ! Observation index.
+    INTEGER, INTENT(IN)   :: nerrf               ! Number of error fields.
+    INTEGER, INTENT(IN)   :: niobf               ! Number of observations.
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_UOBMASK(NIOBF)
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_VOBMASK(NIOBF)
+    LOGICAL, INTENT(IN)   :: MP_LOCAL_COBMASK(NIOBF)
+    REAL, INTENT(INOUT)   :: errf(nerrf, niobf)
+        
+! Local declarations
+    integer i, n, nlocal_dot, nlocal_crs
+    REAL UVT_BUFFER(NIOBF)    ! Buffer for holding U, V, or T
+    REAL QRK_BUFFER(NIOBF)    ! Buffer for holding Q or RKO
+    REAL SFP_BUFFER(NIOBF)    ! Buffer for holding Surface pressure
+    INTEGER N_BUFFER(NIOBF)
+    REAL FULL_BUFFER(NIOBF)
+    INTEGER IFULL_BUFFER(NIOBF)
+    INTEGER IDISPLACEMENT(1024)   ! HARD CODED MAX NUMBER OF PROCESSORS
+    INTEGER ICOUNT(1024)          ! HARD CODED MAX NUMBER OF PROCESSORS
+
+    INTEGER :: MPI_COMM_COMP      ! MPI group communicator
+    INTEGER :: NPROCS             ! Number of processors
+    INTEGER :: IERR               ! Error code from MPI routines
+
+! Get communicator for MPI operations.
+    CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+
+! Get rank of monitor processor and broadcast to others.
+    CALL MPI_COMM_SIZE( MPI_COMM_COMP, NPROCS, IERR )
+
+! DO THE U FIELD
+   NLOCAL_DOT = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_UOBMASK(N) ) THEN      ! USE U-POINT MASK
+       NLOCAL_DOT = NLOCAL_DOT + 1
+       UVT_BUFFER(NLOCAL_DOT) = ERRF(1,N)        ! U WIND COMPONENT
+       SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N)        ! SURFACE PRESSURE
+       QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N)        ! RKO
+       N_BUFFER(NLOCAL_DOT) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   I = 1
+
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! U
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT U-POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! RKO
+   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+
+! DO THE V FIELD
+   NLOCAL_DOT = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_VOBMASK(N) ) THEN         ! USE V-POINT MASK
+       NLOCAL_DOT = NLOCAL_DOT + 1
+       UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N)    ! V WIND COMPONENT
+       SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N)    ! SURFACE PRESSURE
+       N_BUFFER(NLOCAL_DOT) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   I = 1
+
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! V
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT V-POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+
+! DO THE CROSS FIELDS, T AND Q
+   NLOCAL_CRS = 0
+   DO N = 1, NSTA
+     IF ( MP_LOCAL_COBMASK(N) ) THEN       ! USE MASS-POINT MASK
+       NLOCAL_CRS = NLOCAL_CRS + 1
+       UVT_BUFFER(NLOCAL_CRS) = ERRF(3,N)     ! TEMPERATURE
+       QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N)     ! MOISTURE
+       SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N)     ! SURFACE PRESSURE
+       N_BUFFER(NLOCAL_CRS) = N
+     ENDIF
+   ENDDO
+   CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, &
+                      ICOUNT,1,MPI_INTEGER,     &
+                      MPI_COMM_COMP,IERR)
+   IDISPLACEMENT(1) = 0
+   DO I = 2, NPROCS
+     IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1)
+   ENDDO
+   CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER,    &
+                        IFULL_BUFFER, ICOUNT, IDISPLACEMENT,  &
+                        MPI_INTEGER, MPI_COMM_COMP, IERR)
+! T
+   CALL MPI_ALLGATHERV( UVT_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+
+   DO N = 1, NSTA
+     ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! Q
+   CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+! SURF PRESS AT MASS POINTS
+   CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+#endif
+   END SUBROUTINE get_full_obs_vector
+
+END MODULE module_dm
+
+!=========================================================================
+! wrf_dm_patch_domain has to be outside the module because it is called
+! by a routine in module_domain but depends on module domain
+
+SUBROUTINE wrf_dm_patch_domain ( id  , domdesc , parent_id , parent_domdesc , &
+                          sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
+                          sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
+                          sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
+                                      sp1x , ep1x , sm1x , em1x , &
+                                      sp2x , ep2x , sm2x , em2x , &
+                                      sp3x , ep3x , sm3x , em3x , &
+                                      sp1y , ep1y , sm1y , em1y , &
+                                      sp2y , ep2y , sm2y , em2y , &
+                                      sp3y , ep3y , sm3y , em3y , &
+                          bdx , bdy )
+   USE module_domain
+   USE module_dm
+   IMPLICIT NONE
+
+   INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
+   INTEGER, INTENT(OUT)  :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , &
+                            sm1 , em1 , sm2 , em2 , sm3 , em3
+   INTEGER               :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &
+                            sm1x , em1x , sm2x , em2x , sm3x , em3x
+   INTEGER               :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &
+                            sm1y , em1y , sm2y , em2y , sm3y , em3y
+   INTEGER, INTENT(INOUT):: id  , domdesc , parent_id , parent_domdesc
+
+   TYPE(domain), POINTER :: parent
+   TYPE(domain), POINTER :: grid_ptr
+
+   ! this is necessary because we cannot pass parent directly into 
+   ! wrf_dm_patch_domain because creating the correct interface definitions
+   ! would generate a circular USE reference between module_domain and module_dm
+   ! see comment this date in module_domain for more information. JM 20020416
+
+   NULLIFY( parent )
+   grid_ptr => head_grid
+   CALL find_grid_by_id( parent_id , grid_ptr , parent )
+
+   CALL patch_domain_rsl_lite ( id  , parent, parent_id , &
+                           sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & 
+                           sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
+                           sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
+                                      sp1x , ep1x , sm1x , em1x , &
+                                      sp2x , ep2x , sm2x , em2x , &
+                                      sp3x , ep3x , sm3x , em3x , &
+                                      sp1y , ep1y , sm1y , em1y , &
+                                      sp2y , ep2y , sm2y , em2y , &
+                                      sp3y , ep3y , sm3y , em3y , &
+                           bdx , bdy )
+
+   RETURN
+END SUBROUTINE wrf_dm_patch_domain
+
+SUBROUTINE wrf_termio_dup
+  IMPLICIT NONE
+  INCLUDE 'mpif.h'
+  INTEGER mytask, ntasks, ierr
+  CALL mpi_comm_size(MPI_COMM_WORLD, ntasks, ierr )
+  CALL mpi_comm_rank(MPI_COMM_WORLD, mytask, ierr )
+  write(0,*)'starting wrf task ',mytask,' of ',ntasks
+  CALL rsl_error_dup1( mytask )
+END SUBROUTINE wrf_termio_dup
+
+SUBROUTINE wrf_get_myproc( myproc )
+  USE module_dm
+  IMPLICIT NONE
+  INTEGER myproc
+  myproc = mytask
+  RETURN
+END SUBROUTINE wrf_get_myproc
+
+SUBROUTINE wrf_get_nproc( nproc )
+  USE module_dm
+  IMPLICIT NONE
+  INTEGER nproc
+  nproc = ntasks
+  RETURN
+END SUBROUTINE wrf_get_nproc
+
+SUBROUTINE wrf_get_nprocx( nprocx )
+  USE module_dm
+  IMPLICIT NONE
+  INTEGER nprocx
+  nprocx = ntasks_x
+  RETURN
+END SUBROUTINE wrf_get_nprocx
+
+SUBROUTINE wrf_get_nprocy( nprocy )
+  USE module_dm
+  IMPLICIT NONE
+  INTEGER nprocy
+  nprocy = ntasks_y
+  RETURN
+END SUBROUTINE wrf_get_nprocy
+
+SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER size
+#ifndef NEC
+   INTEGER*1 BUF(size)
+#else
+   CHARACTER*1 BUF(size)
+#endif
+   CALL BYTE_BCAST ( buf , size, local_communicator )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_bytes
+
+SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! 
+! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
+!
+! 
+   CHARACTER*(*) buf
+   INTEGER ibuf(256),i,n
+   CHARACTER*256 tstr
+   n = n1
+   ! Root task is required to have the correct value of N1, other tasks 
+   ! might not have the correct value.  
+   CALL wrf_dm_bcast_integer( n , 1 )
+   IF (n .GT. 256) n = 256
+   IF (n .GT. 0 ) then
+     DO i = 1, n
+       ibuf(I) = ichar(buf(I:I))
+     ENDDO
+     CALL wrf_dm_bcast_integer( ibuf, n )
+     buf = ''
+     DO i = 1, n
+       buf(i:i) = char(ibuf(i))
+     ENDDO
+   ENDIF
+   RETURN
+END SUBROUTINE wrf_dm_bcast_string
+
+SUBROUTINE wrf_dm_bcast_integer( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+   INTEGER  buf(*)
+   CALL wrf_dm_bcast_bytes ( BUF , N1 * IWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_integer
+
+SUBROUTINE wrf_dm_bcast_double( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! since we were not indexing the globbuf and Field arrays it does not matter
+   REAL  buf(*)
+   CALL wrf_dm_bcast_bytes ( BUF , N1 * DWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_double
+
+SUBROUTINE wrf_dm_bcast_real( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+   REAL  buf(*)
+   CALL wrf_dm_bcast_bytes ( BUF , N1 * RWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_real
+
+SUBROUTINE wrf_dm_bcast_logical( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+   LOGICAL  buf(*)
+   CALL wrf_dm_bcast_bytes ( BUF , N1 * LWORDSIZE )
+   RETURN
+END SUBROUTINE wrf_dm_bcast_logical
+
+SUBROUTINE write_68( grid, v , s , &
+                   ids, ide, jds, jde, kds, kde, &
+                   ims, ime, jms, jme, kms, kme, &
+                   its, ite, jts, jte, kts, kte )
+  USE module_domain
+  IMPLICIT NONE
+  TYPE(domain) , INTENT (INOUT) :: grid 
+  CHARACTER *(*) s
+  INTEGER ids, ide, jds, jde, kds, kde, &
+          ims, ime, jms, jme, kms, kme, &
+          its, ite, jts, jte, kts, kte
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) :: v
+
+  INTEGER i,j,k,ierr
+
+  logical, external :: wrf_dm_on_monitor
+  real globbuf( ids:ide, kds:kde, jds:jde )
+  character*3 ord, stag
+
+  if ( kds == kde ) then
+    ord = 'xy'
+    stag = 'xy'
+  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
+                     ids, ide, jds, jde, kds, kde, &
+                     ims, ime, jms, jme, kms, kme, &
+                     its, ite, jts, jte, kts, kte )
+  else
+
+    stag = 'xyz' 
+    ord = 'xzy'
+  CALL wrf_patch_to_global_real ( v, globbuf, grid%domdesc, stag, ord, &
+                     ids, ide, kds, kde, jds, jde, &
+                     ims, ime, kms, kme, jms, jme, &
+                     its, ite, kts, kte, jts, jte )
+  endif
+
+
+  if ( wrf_dm_on_monitor() ) THEN
+    WRITE(68,*) ide-ids+1, jde-jds+1 , s
+    DO j = jds, jde
+    DO i = ids, ide
+       WRITE(68,*) globbuf(i,1,j)
+    ENDDO
+    ENDDO
+  endif
+
+  RETURN
+END
+
+   SUBROUTINE wrf_abort
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER ierr
+      CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+   END SUBROUTINE wrf_abort
+
+   SUBROUTINE wrf_dm_shutdown
+      IMPLICIT NONE
+      INTEGER ierr
+      CALL MPI_FINALIZE( ierr )
+      RETURN
+   END SUBROUTINE wrf_dm_shutdown
+
+   LOGICAL FUNCTION wrf_dm_on_monitor()
+      USE module_dm
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      INTEGER tsk, ierr, mpi_comm_local
+      CALL wrf_get_dm_communicator( mpi_comm_local )
+      CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr )
+      wrf_dm_on_monitor = tsk .EQ. 0
+      RETURN
+   END FUNCTION wrf_dm_on_monitor
+
+   INTEGER FUNCTION wrf_dm_monitor_rank()
+      USE module_dm
+      IMPLICIT NONE
+      wrf_dm_monitor_rank = 0
+      RETURN
+   END FUNCTION wrf_dm_monitor_rank
+
+   SUBROUTINE wrf_get_dm_communicator ( communicator )
+      USE module_dm
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: communicator
+      communicator = local_communicator
+      RETURN
+   END SUBROUTINE wrf_get_dm_communicator
+
+   SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
+      USE module_dm
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: iocommunicator
+      iocommunicator = local_iocommunicator
+      RETURN
+   END SUBROUTINE wrf_get_dm_iocommunicator
+
+   SUBROUTINE wrf_set_dm_communicator ( communicator )
+      USE module_dm
+      IMPLICIT NONE
+      INTEGER , INTENT(IN) :: communicator
+      local_communicator = communicator
+      RETURN
+   END SUBROUTINE wrf_set_dm_communicator
+
+   SUBROUTINE wrf_set_dm_iocommunicator ( iocommunicator )
+      USE module_dm
+      IMPLICIT NONE
+      INTEGER , INTENT(IN) :: iocommunicator
+      local_iocommunicator = iocommunicator
+      RETURN
+   END SUBROUTINE wrf_set_dm_iocommunicator
+
+
+!!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       REAL globbuf(*)
+       REAL buf(*)
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,RWORDSIZE,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_real 
+
+   SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! since we were not indexing the globbuf and Field arrays it does not matter
+       REAL globbuf(*)
+       REAL buf(*)
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,DWORDSIZE,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_double
+
+
+   SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       INTEGER globbuf(*)
+       INTEGER buf(*)
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,IWORDSIZE,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_integer 
+
+
+   SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       LOGICAL globbuf(*)
+       LOGICAL buf(*)
+
+       CALL wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,LWORDSIZE,&
+                                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                         MS1,ME1,MS2,ME2,MS3,ME3,&
+                                         PS1,PE1,PS2,PE2,PS3,PE3 )
+
+       RETURN
+   END SUBROUTINE wrf_patch_to_global_logical
+
+#ifdef DEREF_KLUDGE
+#  define FRSTELEM (1)
+#else
+#  define FRSTELEM
+#endif
+
+   SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typesize,&
+                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
+       USE module_driver_constants
+       USE module_timing
+       USE module_wrf_error
+       USE module_dm
+       IMPLICIT NONE
+       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A 
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       INTEGER                         ids,ide,jds,jde,kds,kde,&
+                                       ims,ime,jms,jme,kms,kme,&
+                                       ips,ipe,jps,jpe,kps,kpe
+       CHARACTER *(*) stagger,ordering
+       LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
+       INTEGER fid,domdesc,typesize,ierr
+       REAL globbuf(*)
+       REAL buf(*)
+
+       INTEGER i, j, k,  ndim
+       INTEGER  Patch(3,2), Gpatch(3,2,ntasks)
+    ! allocated further down, after the D indices are potentially recalculated for staggering
+       REAL, ALLOCATABLE :: tmpbuf( : )
+       REAL locbuf( (PE1a-PS1a+1)*(PE2a-PS2a+1)*(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
+
+       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
+       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
+       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xy', 'yx' )
+           ndim = 2
+         CASE DEFAULT
+           ndim = 3   ! where appropriate
+       END SELECT
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xyz','xy' )
+            ! the non-staggered variables come in at one-less than
+            ! domain dimensions, but code wants full domain spec, so
+            ! adjust if not staggered
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'yxz','yx' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'zxy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
+         CASE ( 'xzy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
+         CASE DEFAULT
+       END SELECT
+
+     ! moved to here to be after the potential recalculations of D dims
+       IF ( wrf_dm_on_monitor() ) THEN
+         ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
+       ELSE
+         ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
+       ENDIF
+       IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_patch_to_global_generic')
+ 
+       Patch(1,1) = ps1 ; Patch(1,2) = pe1    ! use patch dims
+       Patch(2,1) = ps2 ; Patch(2,2) = pe2
+       Patch(3,1) = ps3 ; Patch(3,2) = pe3
+
+       IF      ( typesize .EQ. RWORDSIZE ) THEN
+         CALL just_patch_r ( buf , locbuf , size(locbuf), &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
+         CALL just_patch_i ( buf , locbuf , size(locbuf), &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
+         CALL just_patch_d ( buf , locbuf , size(locbuf), &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
+         CALL just_patch_l ( buf , locbuf , size(locbuf), &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ENDIF
+
+! defined in external/io_quilt
+       CALL collect_on_comm0 (  local_communicator , IWORDSIZE ,  &
+                                Patch , 6 ,                       &
+                                GPatch , 6*ntasks                 )
+
+       CALL collect_on_comm0 (  local_communicator , typesize ,  &
+                                locbuf , (pe1-ps1+1)*(pe2-ps2+1)*(pe3-ps3+1),   &
+                                tmpbuf FRSTELEM , (de1-ds1+1)*(de2-ds2+1)*(de3-ds3+1) )
+
+       ndim = len(TRIM(ordering))
+
+       IF ( wrf_at_debug_level(500) ) THEN
+         CALL start_timing
+       ENDIF
+
+       IF ( ndim .GE. 2 .AND. wrf_dm_on_monitor() ) THEN
+
+         IF      ( typesize .EQ. RWORDSIZE ) THEN
+	   CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf ,             &
+				   DS1, DE1, DS2, DE2, DS3, DE3 , &
+				   GPATCH                         )
+	 ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
+	   CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf ,             &
+				   DS1, DE1, DS2, DE2, DS3, DE3 , &
+				   GPATCH                         )
+	 ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
+	   CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf ,             &
+				   DS1, DE1, DS2, DE2, DS3, DE3 , &
+				   GPATCH                         )
+	 ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
+	   CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf ,             &
+				   DS1, DE1, DS2, DE2, DS3, DE3 , &
+				   GPATCH                         )
+	 ENDIF
+
+       ENDIF
+
+       IF ( wrf_at_debug_level(500) ) THEN
+         CALL end_timing('wrf_patch_to_global_generic')
+       ENDIF
+       DEALLOCATE( tmpbuf )
+       RETURN
+    END SUBROUTINE wrf_patch_to_global_generic
+
+  SUBROUTINE just_patch_i ( inbuf , outbuf, noutbuf,     &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER                         , INTENT(IN)  :: noutbuf
+    INTEGER    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    INTEGER    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(IN) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2
+          DO i = PS1, PE1
+            outbuf( icurs )  = inbuf( i, j, k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE just_patch_i
+
+  SUBROUTINE just_patch_r ( inbuf , outbuf, noutbuf,     &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER                      , INTENT(IN)  :: noutbuf
+    REAL    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    REAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
+! Local
+    INTEGER               :: i,j,k   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2 
+          DO i = PS1, PE1
+            outbuf( icurs )  = inbuf( i, j, k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE just_patch_r
+
+  SUBROUTINE just_patch_d ( inbuf , outbuf, noutbuf,     &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER                                  , INTENT(IN)  :: noutbuf
+    DOUBLE PRECISION    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    DOUBLE PRECISION    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2 
+          DO i = PS1, PE1
+            outbuf( icurs )  = inbuf( i, j, k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE just_patch_d
+
+  SUBROUTINE just_patch_l ( inbuf , outbuf, noutbuf,     &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER                         , INTENT(IN)  :: noutbuf
+    LOGICAL    , DIMENSION(noutbuf) , INTENT(OUT) :: outbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    LOGICAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(in) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2 
+          DO i = PS1, PE1
+            outbuf( icurs )  = inbuf( i, j, k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE just_patch_l
+
+
+  SUBROUTINE patch_2_outbuf_r( inbuf, outbuf,            &
+                               DS1,DE1,DS2,DE2,DS3,DE3,  &
+                               GPATCH ) 
+    USE module_dm
+    IMPLICIT NONE
+    REAL    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    REAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( i, j, k ) = inbuf( icurs )
+            icurs = icurs + 1
+	  ENDDO
+	ENDDO
+      ENDDO
+    ENDDO
+
+    RETURN
+  END SUBROUTINE patch_2_outbuf_r
+
+  SUBROUTINE patch_2_outbuf_i( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    INTEGER    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( i, j, k ) = inbuf( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE patch_2_outbuf_i
+
+  SUBROUTINE patch_2_outbuf_d( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    DOUBLE PRECISION    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    DOUBLE PRECISION    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( i, j, k ) = inbuf( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE patch_2_outbuf_d
+
+  SUBROUTINE patch_2_outbuf_l( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    LOGICAL    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    LOGICAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(out) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( i, j, k ) = inbuf( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE patch_2_outbuf_l
+
+!!!!!!!!!!!!!!!!!!!!!!! GLOBAL TO PATCH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       REAL globbuf(*)
+       REAL buf(*)
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,RWORDSIZE,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_real
+
+    SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! since we were not indexing the globbuf and Field arrays it does not matter
+       REAL globbuf(*)
+       REAL buf(*)
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,DWORDSIZE,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_double
+
+
+    SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       INTEGER globbuf(*)
+       INTEGER buf(*)
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,IWORDSIZE,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_integer
+
+    SUBROUTINE wrf_global_to_patch_logical (globbuf,buf,domdesc,stagger,ordering,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       IMPLICIT NONE
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc
+       LOGICAL globbuf(*)
+       LOGICAL buf(*)
+
+       CALL wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,LWORDSIZE,&
+                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_logical
+
+    SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typesize,&
+                                       DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3a )
+       USE module_dm
+       USE module_driver_constants
+       IMPLICIT NONE
+       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A 
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       CHARACTER *(*) stagger,ordering
+       INTEGER fid,domdesc,typesize,ierr
+       REAL globbuf(*)
+       REAL buf(*)
+       LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
+
+       INTEGER i,j,k,ord,ord2d,ndim
+       INTEGER  Patch(3,2), Gpatch(3,2,ntasks)
+       REAL, ALLOCATABLE :: tmpbuf( : )
+       REAL locbuf( (PE1a-PS1a+1)*(PE2a-PS2a+1)*(PE3a-PS3a+1)/RWORDSIZE*typesize+32 )
+
+       DS1 = DS1a ; DE1 = DE1a ; DS2=DS2a ; DE2 = DE2a ; DS3 = DS3a ; DE3 = DE3a
+       MS1 = MS1a ; ME1 = ME1a ; MS2=MS2a ; ME2 = ME2a ; MS3 = MS3a ; ME3 = ME3a
+       PS1 = PS1a ; PE1 = PE1a ; PS2=PS2a ; PE2 = PE2a ; PS3 = PS3a ; PE3 = PE3a
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xy', 'yx' )
+           ndim = 2
+         CASE DEFAULT
+           ndim = 3   ! where appropriate
+       END SELECT
+
+       SELECT CASE ( TRIM(ordering) )
+         CASE ( 'xyz','xy' )
+            ! the non-staggered variables come in at one-less than
+            ! domain dimensions, but code wants full domain spec, so
+            ! adjust if not staggered
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE2 = DE2+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'yxz','yx' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE1 = DE1+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE3 = DE3+1
+         CASE ( 'zxy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE2 = DE2+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE1 = DE1+1
+         CASE ( 'xzy' )
+           IF ( .NOT. has_char( stagger, 'x' ) ) DE1 = DE1+1
+           IF ( .NOT. has_char( stagger, 'y' ) ) DE3 = DE3+1
+           IF ( ndim .EQ. 3 .AND. .NOT. has_char( stagger, 'z' ) ) DE2 = DE2+1
+         CASE DEFAULT
+       END SELECT
+
+     ! moved to here to be after the potential recalculations of D dims
+       IF ( wrf_dm_on_monitor() ) THEN
+         ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr )
+       ELSE
+         ALLOCATE ( tmpbuf ( 1 ), STAT=ierr )
+       ENDIF
+       IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_global_to_patch_generic')
+
+       Patch(1,1) = ps1 ; Patch(1,2) = pe1    ! use patch dims
+       Patch(2,1) = ps2 ; Patch(2,2) = pe2
+       Patch(3,1) = ps3 ; Patch(3,2) = pe3
+
+! defined in external/io_quilt
+       CALL collect_on_comm0 (  local_communicator , IWORDSIZE ,  &
+                                Patch , 6 ,                       &
+                                GPatch , 6*ntasks                 )
+
+       ndim = len(TRIM(ordering))
+
+       IF ( wrf_dm_on_monitor() .AND. ndim .GE. 2 ) THEN
+         IF      ( typesize .EQ. RWORDSIZE ) THEN
+           CALL outbuf_2_patch_r ( globbuf , tmpbuf FRSTELEM ,    &
+                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3 , &
+                                   GPATCH                         )
+         ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
+           CALL outbuf_2_patch_i ( globbuf , tmpbuf FRSTELEM ,    &
+                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
+                                   GPATCH                         )
+         ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
+           CALL outbuf_2_patch_d ( globbuf , tmpbuf FRSTELEM ,    &
+                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
+                                   GPATCH                         )
+         ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
+           CALL outbuf_2_patch_l ( globbuf , tmpbuf FRSTELEM ,    &
+                                   DS1, DE1, DS2, DE2, DS3, DE3 , &
+                                   GPATCH                         )
+         ENDIF
+       ENDIF
+
+       CALL dist_on_comm0 (  local_communicator , typesize ,  &
+                             tmpbuf FRSTELEM , (de1-ds1+1)*(de2-ds2+1)*(de3-ds3+1) , &
+                             locbuf    , (pe1-ps1+1)*(pe2-ps2+1)*(pe3-ps3+1) )
+
+       IF      ( typesize .EQ. RWORDSIZE ) THEN
+         CALL all_sub_r ( locbuf , buf ,             &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+
+       ELSE IF ( typesize .EQ. IWORDSIZE ) THEN
+         CALL all_sub_i ( locbuf , buf ,             &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ELSE IF ( typesize .EQ. DWORDSIZE ) THEN
+         CALL all_sub_d ( locbuf , buf ,             &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ELSE IF ( typesize .EQ. LWORDSIZE ) THEN
+         CALL all_sub_l ( locbuf , buf ,             &
+                                   PS1, PE1, PS2, PE2, PS3, PE3 , &
+                                   MS1, ME1, MS2, ME2, MS3, ME3   )
+       ENDIF
+
+
+       DEALLOCATE ( tmpbuf )
+       RETURN
+    END SUBROUTINE wrf_global_to_patch_generic
+
+  SUBROUTINE all_sub_i ( inbuf , outbuf,              &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    INTEGER    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2
+          DO i = PS1, PE1
+            outbuf( i, j, k )  = inbuf ( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE all_sub_i
+
+  SUBROUTINE all_sub_r ( inbuf , outbuf,              &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    REAL       , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    REAL       , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2
+          DO i = PS1, PE1
+            outbuf( i, j, k )  = inbuf ( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+
+    RETURN
+  END SUBROUTINE all_sub_r
+
+  SUBROUTINE all_sub_d ( inbuf , outbuf,              &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    DOUBLE PRECISION    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    DOUBLE PRECISION    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2
+          DO i = PS1, PE1
+            outbuf( i, j, k )  = inbuf ( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE all_sub_d
+
+  SUBROUTINE all_sub_l ( inbuf , outbuf,              &
+                               PS1,PE1,PS2,PE2,PS3,PE3,  &
+                               MS1,ME1,MS2,ME2,MS3,ME3   )
+    USE module_dm
+    IMPLICIT NONE
+    LOGICAL    , DIMENSION(*) , INTENT(IN) :: inbuf
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    INTEGER   PS1,PE1,PS2,PE2,PS3,PE3
+    LOGICAL    , DIMENSION( MS1:ME1,MS2:ME2,MS3:ME3 ) , INTENT(OUT) :: outbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+      DO k = PS3, PE3
+        DO j = PS2, PE2
+          DO i = PS1, PE1
+            outbuf( i, j, k )  = inbuf ( icurs )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    RETURN
+  END SUBROUTINE all_sub_l
+
+  SUBROUTINE outbuf_2_patch_r( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3, &
+                               MS1, ME1, MS2, ME2, MS3, ME3 , &
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    REAL    , DIMENSION(*) , INTENT(OUT) :: outbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    INTEGER   MS1,ME1,MS2,ME2,MS3,ME3
+    REAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( icurs ) = inbuf( i,j,k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE outbuf_2_patch_r
+
+  SUBROUTINE outbuf_2_patch_i( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    INTEGER    , DIMENSION(*) , INTENT(OUT) :: outbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    INTEGER    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( icurs ) = inbuf( i,j,k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE outbuf_2_patch_i
+
+  SUBROUTINE outbuf_2_patch_d( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    DOUBLE PRECISION    , DIMENSION(*) , INTENT(OUT) :: outbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    DOUBLE PRECISION    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( icurs ) = inbuf( i,j,k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE outbuf_2_patch_d
+
+  SUBROUTINE outbuf_2_patch_l( inbuf, outbuf,         &
+                               DS1,DE1,DS2,DE2,DS3,DE3,&
+                               GPATCH )
+    USE module_dm
+    IMPLICIT NONE
+    LOGICAL    , DIMENSION(*) , INTENT(OUT) :: outbuf
+    INTEGER   DS1,DE1,DS2,DE2,DS3,DE3,GPATCH(3,2,ntasks)
+    LOGICAL    , DIMENSION( DS1:DE1,DS2:DE2,DS3:DE3 ) , INTENT(IN) :: inbuf
+! Local
+    INTEGER               :: i,j,k,n   ,  icurs
+    icurs = 1
+    DO n = 1, ntasks
+      DO k = GPATCH( 3,1,n ), GPATCH( 3,2,n )
+        DO j = GPATCH( 2,1,n ), GPATCH( 2,2,n )
+          DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n )
+            outbuf( icurs ) = inbuf( i,j,k )
+            icurs = icurs + 1
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+    RETURN
+  END SUBROUTINE outbuf_2_patch_l
+
+
+
+!------------------------------------------------------------------
+
+#if ( EM_CORE == 1 )
+
+!------------------------------------------------------------------
+
+   SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#include "em_nest_interpdown_unpack.inc"
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_EM_FORCE_DOWN.inc"
+
+      ! code here to interpolate the data into the nested domain
+#  include "em_nest_forcedown_interp.inc"
+
+      RETURN
+   END SUBROUTINE force_domain_em_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      INTEGER iparstrt,jparstrt,sw
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
+                                iims, iime, ijms, ijme, ikms, ikme,    &
+                                iips, iipe, ijps, ijpe, ikps, ikpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
+      INTEGER local_comm, myproc, nproc
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  intermediate_grid ,              &
+                                iids, iide, ijds, ijde, ikds, ikde,    &
+                                iims, iime, ijms, ijme, ikms, ikme,    &
+                                iips, iipe, ijps, ijpe, ikps, ikpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
+      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
+      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
+      CALL nl_get_shw            ( intermediate_grid%id, sw )
+      icoord =    iparstrt - sw
+      jcoord =    jparstrt - sw
+      idim_cd = iide - iids + 1
+      jdim_cd = ijde - ijds + 1
+
+      nlev  = ckde - ckds + 1
+
+#include "em_nest_interpdown_pack.inc"
+
+      CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
+
+      RETURN
+   END SUBROUTINE interp_domain_em_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+      INTEGER myproc
+      INTEGER ierr
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1 
+
+#include "em_nest_interpdown_unpack.inc"
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_EM_INTERP_DOWN.inc"
+
+#  include "em_nest_interpdown_interp.inc"
+
+      RETURN
+   END SUBROUTINE interp_domain_em_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+)
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_state_description
+      IMPLICIT NONE
+!
+      TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of 
+                                                  ! soil temp, moisture, etc., has vertical dim
+                                                  ! of soil categories
+#include 
+
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER       :: idum1, idum2
+
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#ifdef DM_PARALLEL
+#include "HALO_EM_INTERP_UP.inc"
+#endif
+
+   END SUBROUTINE feedback_nest_prep
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE(domain), POINTER :: xgrid
+      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER local_comm, myproc, nproc, idum1, idum2
+
+      INTERFACE
+          SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+)
+             USE module_domain
+             USE module_configure
+             USE module_dm
+             USE module_state_description
+!
+             TYPE (grid_config_rec_type)            :: config_flags
+             TYPE(domain), TARGET                   :: grid
+#include 
+          END SUBROUTINE feedback_nest_prep
+      END INTERFACE
+!
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+!
+! intermediate grid
+      CALL get_ijk_from_grid (  grid ,                                 &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+! nest grid
+      CALL get_ijk_from_grid (  ngrid ,                                &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+      ips_save = ngrid%i_parent_start   ! used in feedback_domain_em_part2 below
+      jps_save = ngrid%j_parent_start
+      ipe_save = ngrid%i_parent_start + (nide-nids+1) / ngrid%parent_grid_ratio - 1
+      jpe_save = ngrid%j_parent_start + (njde-njds+1) / ngrid%parent_grid_ratio - 1
+
+! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
+! in a separate routine because the HALOs need the data to be dereference from the
+! grid data structure and, in this routine, the dereferenced fields are related to
+! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
+! domain, switch grid to point to ngrid, invoke feedback_nest_prep,  then restore grid
+! to point to intermediate domain.
+
+      CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
+      CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
+      xgrid => grid
+      grid => ngrid
+
+      CALL feedback_nest_prep ( grid, nconfig_flags    &
+!
+#include "em_actual_new_args.inc"
+!
+)
+
+! put things back so grid is intermediate grid
+
+      grid => xgrid
+      CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+
+! "interp" (basically copy) ngrid onto intermediate grid
+
+#include "em_nest_feedbackup_interp.inc"
+
+      RETURN
+   END SUBROUTINE feedback_domain_em_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "em_dummy_new_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_utility
+      IMPLICIT NONE
+
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+      INTEGER icoord, jcoord, idim_cd, jdim_cd
+      INTEGER local_comm, myproc, nproc
+      INTEGER iparstrt, jparstrt, sw
+      REAL    nest_influence
+
+      character*256 :: timestr
+      integer ierr
+
+      LOGICAL, EXTERNAL  :: em_cd_feedback_mask
+
+! On entry to this routine, 
+!  "grid" refers to the parent domain
+!  "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
+!  "ngrid" refers to the nest, which is only needed for smoothing on the parent because 
+!          the nest feedback data has already been transferred during em_nest_feedbackup_interp
+!          in part1, above.
+! The way these settings c and n dimensions are set, below, looks backwards but from the point 
+! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by 
+! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
+! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
+! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
+! sign that says "DIP" than fix the dip,  at this point it was easier just to write this comment. JM
+!
+      nest_influence = 1.
+
+      CALL domain_clock_get( grid, current_timestr=timestr )
+
+      CALL get_ijk_from_grid (  intermediate_grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  grid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
+      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
+      CALL nl_get_shw            ( intermediate_grid%id, sw )
+      icoord =    iparstrt - sw
+      jcoord =    jparstrt - sw
+      idim_cd = cide - cids + 1
+      jdim_cd = cjde - cjds + 1
+
+      nlev  = ckde - ckds + 1
+
+#include "em_nest_feedbackup_pack.inc"
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+      CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
+
+#define NEST_INFLUENCE(A,B) A = B
+#include "em_nest_feedbackup_unpack.inc"
+
+      ! smooth coarse grid
+      CALL get_ijk_from_grid (  ngrid,                           &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_EM_INTERP_UP.inc"
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+
+#include "em_nest_feedbackup_smooth.inc"
+
+      RETURN
+   END SUBROUTINE feedback_domain_em_part2
+#endif
+
+#if ( NMM_CORE == 1 && NMM_NEST == 1 )
+!==============================================================================
+! NMM nesting infrastructure extended from EM core. This is gopal's doing.
+!==============================================================================
+
+   SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      INTEGER iparstrt,jparstrt,sw
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          iids, iide, ijds, ijde, ikds, ikde,    &
+                                iims, iime, ijms, ijme, ikms, ikme,    &
+                                iips, iipe, ijps, ijpe, ikps, ikpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
+      INTEGER local_comm, myproc, nproc
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+#define COPY_IN
+#include 
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  intermediate_grid ,              &
+                                iids, iide, ijds, ijde, ikds, ikde,    &
+                                iims, iime, ijms, ijme, ikms, ikme,    &
+                                iips, iipe, ijps, ijpe, ikps, ikpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      CALL nl_get_parent_grid_ratio ( ngrid%id, pgr )
+      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
+      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
+      CALL nl_get_shw            ( intermediate_grid%id, sw )
+      icoord =    iparstrt - sw
+      jcoord =    jparstrt - sw
+      idim_cd = iide - iids + 1
+      jdim_cd = ijde - ijds + 1
+
+      nlev  = ckde - ckds + 1
+
+#include "nmm_nest_interpdown_pack.inc"
+
+      CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
+
+#define COPY_OUT
+#include 
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+      INTEGER myproc
+      INTEGER ierr
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+#include "deref_kludge.h"
+
+#define COPY_IN
+#include 
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1 
+
+#include "nmm_nest_interpdown_unpack.inc"
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_NMM_INTERP_DOWN1.inc"
+
+#include "nmm_nest_interpdown_interp.inc"
+
+#define COPY_OUT
+#include 
+
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_timing
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+#define COPY_IN
+#include 
+!
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+
+      CALL get_ijk_from_grid (  intermediate_grid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#include "nmm_nest_forcedown_pack.inc"
+
+!   WRITE(0,*)'I have completed PACKING of BCs data successfully'
+
+#define COPY_OUT
+#include 
+      RETURN
+   END SUBROUTINE force_domain_nmm_part1
+
+!==============================================================================================
+
+   SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+integer myproc
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+#include "deref_kludge.h"
+
+#define COPY_IN
+#include 
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  ngrid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+#include "nmm_nest_interpdown_unpack.inc"
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_NMM_FORCE_DOWN1.inc"
+
+      ! code here to interpolate the data into the nested domain
+#include "nmm_nest_forcedown_interp.inc"
+
+#define COPY_OUT
+#include 
+
+      RETURN
+   END SUBROUTINE force_domain_nmm_part2
+
+!================================================================================
+!
+! This routine exists only to call a halo on a domain (the nest)
+! gets called from feedback_domain_em_part1, below.  This is needed
+! because the halo code expects the fields being exchanged to have
+! been dereferenced from the grid data structure, but in feedback_domain_em_part1
+! the grid data structure points to the coarse domain, not the nest.
+! And we want the halo exchange on the nest, so that the code in
+! em_nest_feedbackup_interp.inc will work correctly on multi-p. JM 20040308
+!
+
+   SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+)
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_state_description
+      IMPLICIT NONE
+!
+      TYPE(domain), TARGET :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of
+                                                  ! soil temp, moisture, etc., has vertical dim
+                                                  ! of soil categories
+#include 
+
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER       :: idum1, idum2
+
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+#include "deref_kludge.h"
+
+#define COPY_IN
+#include 
+
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#ifdef DM_PARALLEL
+#include "HALO_NMM_WEIGHTS.inc"
+#endif
+
+#define COPY_OUT
+#include 
+
+   END SUBROUTINE feedback_nest_prep_nmm
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE(domain), POINTER :: xgrid
+      TYPE (grid_config_rec_type)            :: config_flags, nconfig_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER local_comm, myproc, nproc, idum1, idum2
+
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+
+      INTERFACE
+          SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+)
+             USE module_domain
+             USE module_configure
+             USE module_dm
+             USE module_state_description
+!
+             TYPE (grid_config_rec_type)            :: config_flags
+             TYPE(domain), TARGET                   :: grid
+#include 
+          END SUBROUTINE feedback_nest_prep_nmm
+      END INTERFACE
+!
+#define COPY_IN
+#include 
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+
+!
+! intermediate grid
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+! nest grid
+      CALL get_ijk_from_grid (  ngrid ,                  &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nlev  = ckde - ckds + 1
+
+      ips_save = ngrid%i_parent_start  ! +1 not used in ipe_save & jpe_save
+      jps_save = ngrid%j_parent_start  !  because of one extra namelist point
+      ipe_save = ngrid%i_parent_start + (nide-nids) / ngrid%parent_grid_ratio
+      jpe_save = ngrid%j_parent_start + (njde-njds) / ngrid%parent_grid_ratio
+
+! feedback_nest_prep invokes a halo exchange on the ngrid. It is done this way
+! in a separate routine because the HALOs need the data to be dereference from the
+! grid data structure and, in this routine, the dereferenced fields are related to
+! the intermediate domain, not the nest itself. Save the current grid pointer to intermediate
+! domain, switch grid to point to ngrid, invoke feedback_nest_prep,  then restore grid
+! to point to intermediate domain.
+
+      CALL model_to_grid_config_rec ( ngrid%id , model_config_rec , nconfig_flags )
+      CALL set_scalar_indices_from_config ( ngrid%id , idum1 , idum2 )
+      xgrid => grid
+      grid => ngrid
+#include "deref_kludge.h"
+      CALL feedback_nest_prep_nmm ( grid, config_flags    &
+!
+#include "nmm_actual_args.inc"
+!
+)
+
+! put things back so grid is intermediate grid
+
+      grid => xgrid
+      CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+
+! "interp" (basically copy) ngrid onto intermediate grid
+
+#include "nmm_nest_feedbackup_interp.inc"
+
+#define COPY_OUT
+#include 
+      RETURN
+   END SUBROUTINE feedback_domain_nmm_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "nmm_dummy_args.inc"
+!
+                 )
+      USE module_domain
+      USE module_configure
+      USE module_dm
+      USE module_utility
+      IMPLICIT NONE
+
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER :: ngrid
+
+#include 
+      INTEGER nlev, msize
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      TYPE (grid_config_rec_type)            :: config_flags
+      REAL xv(500)
+      INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe
+      INTEGER       ::          nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+      INTEGER icoord, jcoord, idim_cd, jdim_cd
+      INTEGER local_comm, myproc, nproc
+      INTEGER iparstrt, jparstrt, sw
+
+      character*256 :: timestr
+      integer ierr
+
+      REAL    nest_influence
+      LOGICAL, EXTERNAL  :: nmm_cd_feedback_mask
+#ifdef DEREF_KLUDGE
+!  see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm
+   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33
+   INTEGER     :: sm31x, em31x, sm32x, em32x, sm33x, em33x
+   INTEGER     :: sm31y, em31y, sm32y, em32y, sm33y, em33y
+#endif
+#include "deref_kludge.h"
+
+#define COPY_IN
+#include 
+
+! On entry to this routine,
+!  "grid" refers to the parent domain
+!  "intermediate_grid" refers to local copy of parent domain that overlies this patch of nest
+!  "ngrid" refers to the nest, which is only needed for smoothing on the parent because
+!          the nest feedback data has already been transferred during em_nest_feedbackup_interp
+!          in part1, above.
+! The way these settings c and n dimensions are set, below, looks backwards but from the point
+! of view of the RSL routine rsl_lite_to_parent_info(), call to which is included by
+! em_nest_feedbackup_pack, the "n" domain represents the parent domain and the "c" domain
+! represents the intermediate domain. The backwards lookingness should be fixed in the gen_comms.c
+! registry routine that accompanies RSL_LITE but, just as it's sometimes easier to put up a road
+! sign that says "DIP" than fix the dip,  at this point it was easier just to write this comment. JM
+!
+
+      nest_influence = 0.5
+#define NEST_INFLUENCE(A,B) A = nest_influence*(B) + (1.0-nest_influence)*(A)
+
+
+      CALL domain_clock_get( grid, current_timestr=timestr )
+
+      CALL get_ijk_from_grid (  intermediate_grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+      CALL get_ijk_from_grid (  grid ,              &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe    )
+
+      nide = nide - 1   !dusan
+      njde = njde - 1   !dusan
+
+      CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt )
+      CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt )
+      CALL nl_get_shw            ( intermediate_grid%id, sw )
+      icoord =    iparstrt  - sw
+      jcoord =    jparstrt  - sw
+      idim_cd = cide - cids + 1
+      jdim_cd = cjde - cjds + 1
+
+      nlev  = ckde - ckds + 1
+
+#include "nmm_nest_feedbackup_pack.inc"
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+      CALL rsl_lite_merge_msgs( myproc, nproc, local_comm )
+
+#include "nmm_nest_feedbackup_unpack.inc"
+
+
+      ! smooth coarse grid
+
+      CALL get_ijk_from_grid (  ngrid,                                 &
+                                nids, nide, njds, njde, nkds, nkde,    &
+                                nims, nime, njms, njme, nkms, nkme,    &
+                                nips, nipe, njps, njpe, nkps, nkpe     )
+      CALL get_ijk_from_grid (  grid ,              &
+                                ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe    )
+
+#include "HALO_NMM_INTERP_UP.inc"
+
+      CALL get_ijk_from_grid (  grid ,                   &
+                                cids, cide, cjds, cjde, ckds, ckde,    &
+                                cims, cime, cjms, cjme, ckms, ckme,    &
+                                cips, cipe, cjps, cjpe, ckps, ckpe    )
+
+#include "nmm_nest_feedbackup_smooth.inc"
+
+#define COPY_OUT
+#include 
+      RETURN
+   END SUBROUTINE feedback_domain_nmm_part2
+
+!=================================================================================
+!   End of gopal's doing
+!=================================================================================
+#endif
+
+!------------------------------------------------------------------
+
+   SUBROUTINE wrf_gatherv_real (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            getrealmpitype() ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            getrealmpitype()               , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_real
+
+   SUBROUTINE wrf_gatherv_double (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! if we were not indexing the globbuf and Field arrays it would not even matter
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_DOUBLE_PRECISION         ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_DOUBLE_PRECISION                       , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_double
+
+   SUBROUTINE wrf_gatherv_integer (Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_gatherv( Field( field_ofst ),      &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_INTEGER         ,               &    ! sendtype
+                            globbuf( glob_ofst ) ,                 &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_INTEGER                       , &    ! recvtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_gatherv_integer
+
+!new stuff 20070124
+   SUBROUTINE wrf_scatterv_real (                             &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            getrealmpitype()               , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            getrealmpitype() ,               &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_real
+
+   SUBROUTINE wrf_scatterv_double (                           &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   USE module_dm
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+! this next declaration is REAL, not DOUBLE PRECISION because it will be autopromoted
+! to double precision by the compiler when WRF is compiled for 8 byte reals. Only reason
+! for having this separate routine is so we pass the correct MPI type to mpi_scatterv
+! if we were not indexing the globbuf and Field arrays it would not even matter
+   REAL, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_DOUBLE_PRECISION           , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_DOUBLE_PRECISION         ,   &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_double
+
+   SUBROUTINE wrf_scatterv_integer (                          &
+                                globbuf, glob_ofst ,          &    ! recvbuf
+                                counts                      , &    ! recvcounts
+                                Field, field_ofst,            &
+                                my_count ,                    &    ! sendcount
+                                displs                      , &    ! displs
+                                root                        , &    ! root
+                                communicator                , &    ! communicator
+                                ierr )
+   IMPLICIT NONE
+   INCLUDE 'mpif.h'
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+
+           CALL mpi_scatterv(                                &
+                            globbuf( glob_ofst ) ,           &    ! recvbuf
+                            counts                         , &    ! recvcounts
+                            displs                         , &    ! displs
+                            MPI_INTEGER                    , &    ! recvtype
+                            Field( field_ofst ),             &    ! sendbuf
+                            my_count ,                       &    ! sendcount
+                            MPI_INTEGER         ,            &    ! sendtype
+                            root                           , &    ! root
+                            communicator                   , &    ! communicator
+                            ierr )
+
+   END SUBROUTINE wrf_scatterv_integer
+! end new stuff 20070124
+
+SUBROUTINE wrf_dm_define_comms ( grid )
+   USE module_domain
+   IMPLICIT NONE
+   TYPE(domain) , INTENT (INOUT) :: grid
+   RETURN
+END SUBROUTINE wrf_dm_define_comms
+
+   SUBROUTINE set_dm_debug 
+    USE module_dm
+    IMPLICIT NONE
+    dm_debug_flag = .TRUE.
+   END SUBROUTINE set_dm_debug
+   SUBROUTINE reset_dm_debug 
+    USE module_dm
+    IMPLICIT NONE
+    dm_debug_flag = .FALSE.
+   END SUBROUTINE reset_dm_debug
+   SUBROUTINE get_dm_debug ( arg )
+    USE module_dm
+    IMPLICIT NONE
+    LOGICAL arg
+    arg = dm_debug_flag
+   END SUBROUTINE get_dm_debug
diff --git a/wrfv2_fire/external/RSL_LITE/period.c b/wrfv2_fire/external/RSL_LITE/period.c
new file mode 100755
index 00000000..28c110a3
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/period.c
@@ -0,0 +1,422 @@
+#include 
+#include 
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#include "mpi.h"
+#include "rsl_lite.h"
+
+#define F_PACK
+
+static int yp_curs, ym_curs, xp_curs, xm_curs ;
+
+RSL_LITE_INIT_PERIOD ( 
+                int * Fcomm0,
+                int * shw0,
+                int * n3dR0, int *n2dR0, int * typesizeR0 , 
+                int * n3dI0, int *n2dI0, int * typesizeI0 , 
+                int * n3dD0, int *n2dD0, int * typesizeD0 , 
+                int * n3dL0, int *n2dL0, int * typesizeL0 , 
+                int * me0, int * np0 , int * np_x0 , int * np_y0 ,
+                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int n3dR, n2dR, typesizeR ;
+  int n3dI, n2dI, typesizeI ;
+  int n3dD, n2dD, typesizeD ;
+  int n3dL, n2dL, typesizeL ;
+  int shw ;
+  int me, np, np_x, np_y ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int yp, ym, xp, xm ;
+  int nbytes ;
+  int coords[2] ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  shw = *shw0 ;
+  n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
+  n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
+  n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
+  n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+
+/*
+ This assumes that the topoology associated with the communicator is periodic
+ the period routines should be called with "local_communicator_periodic", which
+ is set up in module_dm.F for RSL_LITE.  Registry generated code automatically
+ does this (gen_comms.c for RSL_LITE).
+*/
+  if ( np_y > 1 ) {
+    nbytes = typesizeR*(ipe-ips+1+2*shw)*(shw+1)*(n3dR*(kpe-kps+1)+n2dR) +
+             typesizeI*(ipe-ips+1+2*shw)*(shw+1)*(n3dI*(kpe-kps+1)+n2dI) +
+             typesizeD*(ipe-ips+1+2*shw)*(shw+1)*(n3dD*(kpe-kps+1)+n2dD) +
+             typesizeL*(ipe-ips+1+2*shw)*(shw+1)*(n3dL*(kpe-kps+1)+n2dL) ;
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
+    if ( yp != MPI_PROC_NULL && coords[0] == np_y - 1 ) {  /* process on top of mesh */
+       buffer_for_proc ( yp , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( ym != MPI_PROC_NULL && coords[0] == 0 ) {         /* process on bottom of mesh */
+       buffer_for_proc ( ym , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+  if ( np_x > 1 ) {
+    nbytes = typesizeR*(jpe-jps+1+2*shw)*(shw+1)*(n3dR*(kpe-kps+1)+n2dR) +
+             typesizeI*(jpe-jps+1+2*shw)*(shw+1)*(n3dI*(kpe-kps+1)+n2dI) +
+             typesizeD*(jpe-jps+1+2*shw)*(shw+1)*(n3dD*(kpe-kps+1)+n2dD) +
+             typesizeL*(jpe-jps+1+2*shw)*(shw+1)*(n3dL*(kpe-kps+1)+n2dL) ;
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( xm != MPI_PROC_NULL && coords[1] == np_x - 1 ) { /* process on right hand side of mesh */
+       buffer_for_proc ( xp , nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( xp != MPI_PROC_NULL && coords[1] == 0 ) {        /* process on left hand side of mesh */
+       buffer_for_proc ( xm,  nbytes, RSL_RECVBUF ) ;
+       buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+}
+
+
+RSL_LITE_PACK_PERIOD ( int* Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * stag0 ,
+           int *me0, int * np0 , int * np_x0 , int * np_y0 , 
+           int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+           int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
+           int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int me, np, np_x, np_y ;
+  int shw , typesize ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ims , ime , jms , jme , kms , kme ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int stag ;  /* 0 not stag, 1 stag */
+  int xy ;   /* y = 0 , x = 1 */
+  int pu ;   /* pack = 0 , unpack = 1 */
+  register int i, j, k, t ;
+#ifdef crayx1
+  register int i2,i3,i4,i_offset;
+#endif
+  char *p ;
+  int the_buf ;
+  int yp, ym, xp, xm ;
+  int nbytes, ierr ;
+  register int *pi, *qi ;
+  int coords[2] ;
+  int js, je, ks, ke, is, ie, wcount ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  stag = *stag0 ;
+  shw = *shw0 ; typesize = *typesize0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+  xy = *xy0 ;
+  pu = *pu0 ;
+
+#define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*((E3)-(S3)+1)*((E4)-(S4)+1))
+#if 0
+#define IMAX(A) (((A)>ids)?(A):ids)
+#define IMIN(A) (((A)jds)?(A):jds)
+#define JMIN(A) (((A) ide) since
+   this will handle corner points for doubly periodic updates (he wrote hopefully) */
+#define IMAX(A) (A)
+#define IMIN(A) (A)
+#define JMAX(A) (A)
+#define JMIN(A) (A)
+#endif
+
+  the_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
+
+  if ( np_x > 1 && xy == 1 ) {   /* exchange period in x dim */
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( coords[1] == np_x - 1 ) {                /* process on right hand edge of domain */
+      p = buffer_for_proc( xp , 0 , the_buf ) ;
+      if ( pu == 0 ) {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ipe-shw       ; ie = ipe-1         ;
+        nbytes = buffer_size_for_proc( xp , the_buf ) ;
+        if ( xp_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ipe-shw, ipe-1, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack_period_x, right hand X to %d, %d > %d\n",xp,
+	      xp_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ipe-shw, ipe-1, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == sizeof(long int) ) {
+          F_PACK_LINT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+xp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                       &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+	}
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ipe           ; ie = ipe+shw-1+stag ;
+        if ( typesize == sizeof(long int) ) {
+          F_UNPACK_LINT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+xp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+    if ( coords[1] == 0 ) {         /* process on left hand edge of domain */
+      p = buffer_for_proc( xm , 0 , the_buf ) ;
+      if ( pu == 0 ) {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ips           ; ie = ips+shw-1+stag ;
+        nbytes = buffer_size_for_proc( xm , the_buf ) ;
+        if ( xm_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ips, ips+shw-1+stag, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack_period_x,  left hand X to %d , %d > %d\n",xm,
+	      xm_curs + RANGE( JMAX(jps-shw), JMIN(jpe+shw), kps, kpe, ips, ips+shw-1+stag, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == sizeof(long int) ) {
+          F_PACK_LINT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+xm_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                       &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ips-shw       ; ie = ips-1           ;
+        if ( typesize == sizeof(long int) ) {
+          F_UNPACK_LINT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+xm_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          xm_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+  }
+  if ( np_y > 1 && xy == 0 ) {    /* exchange period in Y dim */
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
+    if ( coords[0] == np_y - 1 ) {                /* process on top edge of domain */
+      p = buffer_for_proc( yp , 0 , the_buf ) ;
+      if ( pu == 0 ) {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jpe-shw       ; je = jpe-1         ;
+        nbytes = buffer_size_for_proc( yp , the_buf ) ;
+        if ( yp_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jpe-shw, jpe-1, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack_period_y, right hand Y to %d, %d > %d\n",yp,
+	      yp_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jpe-shw, jpe-1, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == sizeof(long int) ) {
+          F_PACK_LINT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+yp_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                       &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+	}
+      } else {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jpe           ; je = jpe+shw-1+stag ;
+        if ( typesize == sizeof(long int) ) {
+          F_UNPACK_LINT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+yp_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          yp_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+    if ( coords[0] == 0 ) {         /* process on bottom edge of domain */
+      p = buffer_for_proc( ym , 0 , the_buf ) ;
+      if ( pu == 0 ) {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jps           ; je = jps+shw-1+stag ;
+        nbytes = buffer_size_for_proc( ym , the_buf ) ;
+        if ( ym_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jps, jps+shw-1+stag, 1, typesize ) > nbytes ) {
+	  fprintf(stderr,"memory overwrite in rsl_lite_pack_period_y,  left hand Y to %d , %d > %d\n",xm,
+	      ym_curs + RANGE( IMAX(ips-shw), IMIN(ipe+shw), kps, kpe, jps, jps+shw-1+stag, 1, typesize ), nbytes ) ;
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == sizeof(long int) ) {
+          F_PACK_LINT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                        &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_PACK_INT ( buf, p+ym_curs, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                       &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      } else {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jps-shw       ; je = jps-1           ;
+        if ( typesize == sizeof(long int) ) {
+          F_UNPACK_LINT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                          &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+        } else
+	if ( typesize == sizeof(int) ) {
+          F_UNPACK_INT ( p+ym_curs, buf, imemord, &js, &je, &ks, &ke, &is, &ie,
+                                         &jms,&jme,&kms,&kme,&ims,&ime, &wcount ) ;
+          ym_curs += wcount*typesize ;
+	}
+	else {
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+        }
+      }
+    }
+  }
+}
+
+static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
+static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
+
+RSL_LITE_EXCH_PERIOD_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, nbytes ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int coords[2] ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+
+  if ( np_x > 1 ) {
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( coords[1] == np_x - 1 ) {   /* proc on right hand side of domain */
+      nbytes = buffer_size_for_proc( xp, RSL_RECVBUF ) ;
+      MPI_Irecv ( buffer_for_proc( xp , xp_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, xp, me, comm, &xp_recv ) ;
+    }
+    if ( coords[1] == 0 ) {          /* proc on left hand side of domain */
+      nbytes = buffer_size_for_proc( xm, RSL_RECVBUF ) ;
+      MPI_Irecv ( buffer_for_proc( xm, xm_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, xm, me, comm, &xm_recv ) ;
+    }
+    if ( coords[1] == np_x - 1 ) {   /* proc on right hand side of domain */
+      MPI_Isend ( buffer_for_proc( xp , 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
+    }
+    if ( coords[1] == 0 ) {          /* proc on left hand side of domain */
+      MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
+    }
+    if ( coords[1] == np_x - 1 ) MPI_Wait( &xp_recv, &stat ) ; 
+    if ( coords[1] == 0        ) MPI_Wait( &xm_recv, &stat ) ; 
+    if ( coords[1] == np_x - 1 ) MPI_Wait( &xp_send, &stat ) ; 
+    if ( coords[1] == 0        ) MPI_Wait( &xm_send, &stat ) ;
+  }
+#else 
+fprintf(stderr,"RSL_LITE_EXCH_PERIOD_X disabled\n") ;
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+}
+
+RSL_LITE_EXCH_PERIOD_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, nbytes ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int coords[2] ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+
+  if ( np_y > 1 ) {
+    MPI_Comm_rank( *comm0, &me ) ;
+    MPI_Cart_coords( *comm0, me, 2, coords ) ;
+    MPI_Cart_shift( *comm0, 0, 1, &ym, &yp ) ;
+    if ( coords[0] == np_y - 1 ) {   /* proc on top of domain */
+      nbytes = buffer_size_for_proc( yp, RSL_RECVBUF ) ;
+      MPI_Irecv ( buffer_for_proc( yp , yp_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, yp, me, comm, &yp_recv ) ;
+    }
+    if ( coords[0] == 0 ) {          /* proc on bottom of domain */
+      nbytes = buffer_size_for_proc( ym, RSL_RECVBUF ) ;
+      MPI_Irecv ( buffer_for_proc( ym, ym_curs, RSL_RECVBUF ), nbytes, MPI_CHAR, ym, me, comm, &ym_recv ) ;
+    }
+    if ( coords[0] == np_y - 1 ) {   /* proc on top of domain */
+      MPI_Isend ( buffer_for_proc( yp , 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
+    }
+    if ( coords[0] == 0 ) {          /* proc on bottom of domain */
+      MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
+    }
+    if ( coords[0] == np_y - 1 ) MPI_Wait( &yp_recv, &stat ) ;
+    if ( coords[0] == 0        ) MPI_Wait( &ym_recv, &stat ) ;
+    if ( coords[0] == np_y - 1 ) MPI_Wait( &yp_send, &stat ) ;
+    if ( coords[0] == 0        ) MPI_Wait( &ym_send, &stat ) ;
+  }
+#else
+fprintf(stderr,"RSL_LITE_EXCH_PERIOD_Y disabled\n") ;
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+}
+
diff --git a/wrfv2_fire/external/RSL_LITE/rsl_bcast.c b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c
new file mode 100755
index 00000000..9587f2a5
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c
@@ -0,0 +1,629 @@
+/* #define LEARN_BCAST */
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#define MOD_9707
+
+#include 
+#include 
+#include "mpi.h"
+#include "rsl_lite.h"
+
+char mess[4096] ;
+
+typedef struct bcast_point_desc {
+  int ig ;
+  int jg ;
+} bcast_point_desc_t ;
+
+
+static destroy_par_info ( p )
+  char * p ;
+{
+  if ( p != NULL ) RSL_FREE( p ) ;
+}
+
+static rsl_list_t *Xlist, *Xp, *Xprev ;
+static rsl_list_t *stage ;
+static int stage_len = 0 ;              /* 96/3/15 */
+
+static int  Sendbufsize ;
+static int  Sendbufcurs ;
+static char *Sendbuf ;
+static int  Sdisplacements[RSL_MAXPROC] ;
+static int  Ssizes[RSL_MAXPROC] ;
+
+static int  Recsizeindex ;
+
+static int  Rbufsize ;
+static int  Rbufcurs ;
+static int  Rpointcurs ;
+static char *Recvbuf ;
+static int  Rdisplacements[RSL_MAXPROC+1] ;
+static int  Rsizes[RSL_MAXPROC] ;
+static int  Rreclen ;
+
+static int s_d ;
+static int s_nst ;
+static int s_msize ;
+static int s_idim ;
+static int s_jdim ;
+static int s_idim_nst ;
+static int s_jdim_nst ;
+static int s_irax_n ;
+static int s_irax_m ;
+static int s_ntasks_x ;
+static int s_ntasks_y ;
+static rsl_list_t **Plist ;
+static int Psize[RSL_MAXPROC] ;
+static char *s_parent_msgs ;
+static int s_parent_msgs_curs ;
+static int s_remaining ;  /* number of bytes left in a parent message before
+                           the next point descriptor */
+
+/* add a field to a message outgoing for the specified child domain cell */
+/* relies on rsl_ready_bcast having been called already */
+/* sends are specified in terms of coarse domain */
+
+static int s_i, s_j, s_ig, s_jg, s_cm, s_cn,
+           s_nig, s_njg ;
+
+static int Pcurs ;
+static rsl_list_t *Pptr ; 
+
+#ifdef LEARN_BCAST
+static int s_putmsg = 0 ;
+#endif
+
+/* parent->nest */
+RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p,
+                         cips_p, cipe_p, cjps_p, cjpe_p, /* patch dims of SOURCE DOMAIN */
+                         iids_p, iide_p, ijds_p, ijde_p, /* domain dims of INTERMEDIATE DOMAIN */
+                         nids_p, nide_p, njds_p, njde_p, /* domain dims of CHILD DOMAIN */
+                         pgr_p,  shw_p ,                 /* nest ratio and stencil half width */
+                         ntasks_x_p , ntasks_y_p ,       /* proc counts in x and y */
+                         icoord_p, jcoord_p,
+                         idim_cd_p, jdim_cd_p,
+                         ig_p, jg_p,
+                         retval_p )
+  
+  int_p
+     Fcomm                            /* Fortran version of MPI communicator */
+    ,cips_p, cipe_p, cjps_p, cjpe_p   /* (i) c.d. patch dims */
+    ,iids_p, iide_p, ijds_p, ijde_p   /* (i) n.n. global dims */
+    ,nids_p, nide_p, njds_p, njde_p   /* (i) n.n. global dims */
+    ,pgr_p                            /* nesting ratio */
+    ,ntasks_x_p , ntasks_y_p          /* proc counts in x and y */
+    ,icoord_p       /* i coordinate of nest in cd */
+    ,jcoord_p       /* j coordinate of nest in cd */
+    ,shw_p          /* stencil half width */
+    ,idim_cd_p      /* i width of nest in cd */
+    ,jdim_cd_p      /* j width of nest in cd */
+    ,msize_p        /* (I) Message size in bytes. */
+    ,ig_p           /* (O) Global N index of parent domain point. */
+    ,jg_p           /* (O) Global N index of parent domain point. */
+    ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
+{
+  int P, Px, Py ;
+
+  rsl_list_t *q ;
+  int *r ;
+  int i, j, ni, nj ;
+  int coords[2] ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  if ( Plist == NULL ) {
+    s_ntasks_x = *ntasks_x_p ;
+    s_ntasks_y = *ntasks_y_p ;
+    /* construct Plist */
+    Sendbufsize = 0 ;
+    Plist = RSL_MALLOC( rsl_list_t * , s_ntasks_x * s_ntasks_y ) ;  /* big enough for nest points */
+    for ( j = 0 ; j < s_ntasks_x * s_ntasks_y ; j++ ) {
+       Plist[j] = NULL ;
+       Sdisplacements[j] = 0 ;
+       Ssizes[j] = 0 ;
+    }
+    for ( j = *cjps_p ; j <= *cjpe_p ; j++ )
+    {
+      for ( i = *cips_p ; i <= *cipe_p ; i++ )
+      {
+	if ( ( *jcoord_p <= j && j <= *jcoord_p+*jdim_cd_p-1 ) && ( *icoord_p <= i && i <= *icoord_p+*idim_cd_p-1 ) ) {
+           ni = ( i - (*icoord_p + *shw_p) ) * *pgr_p + 1 + 1 ; /* add 1 to give center point */
+           nj = ( j - (*jcoord_p + *shw_p) ) * *pgr_p + 1 + 1 ;
+
+	   TASK_FOR_POINT ( &ni, &nj, nids_p, nide_p, njds_p, njde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py ) ;
+           coords[1] = Px ; coords[0] = Py ;
+           MPI_Cart_rank( *comm, coords, &P ) ;
+
+	   q = RSL_MALLOC( rsl_list_t , 1 ) ;
+	   q->info1 = i ;
+	   q->info2 = j ;
+	   q->next = Plist[P] ;
+	   Plist[P] = q ;
+	   Sendbufsize += *msize_p + 3 * sizeof( int ) ;  /* point data plus 3 ints for i, j, and size */
+        }
+      }
+    }
+    Sendbuf = RSL_MALLOC( char , Sendbufsize ) ;
+    Sendbufcurs = 0 ;
+    Recsizeindex = -1 ;
+    Pcurs = -1 ;
+    Pptr = NULL ;
+  }
+
+  if ( Pptr != NULL ) {
+    Pptr = Pptr->next ;
+  } 
+
+  if ( Recsizeindex >= 0 ) {
+          r = (int *) &(Sendbuf[Recsizeindex]) ;
+          *r = Sendbufcurs - Recsizeindex + 2 * sizeof(int) ;
+          Ssizes[Pcurs] += *r ;
+  }
+
+  while ( Pptr == NULL ) {
+      Pcurs++ ;
+      while ( Pcurs < s_ntasks_x * s_ntasks_y && Plist[Pcurs] == NULL  ) Pcurs++ ;
+      if ( Pcurs < s_ntasks_x * s_ntasks_y ) {
+        Sdisplacements[Pcurs] = Sendbufcurs ;
+        Ssizes[Pcurs] = 0 ;
+        Pptr = Plist[Pcurs] ;
+      } else {
+        *retval_p = 0 ;
+#if 0
+fprintf(stderr,"TO _INFO: %d %d %d \n",*ig_p,*jg_p, *retval_p) ;
+#endif
+        return ;  /* done */
+      }
+  }
+
+  *ig_p = Pptr->info1 ;
+  *jg_p = Pptr->info2 ;
+
+  r = (int *) &(Sendbuf[Sendbufcurs]) ;
+  *r++ = Pptr->info1 ; Sendbufcurs += sizeof(int) ;  /* ig to buffer */
+  *r++ = Pptr->info2 ; Sendbufcurs += sizeof(int) ;  /* jg to buffer */
+  Recsizeindex = Sendbufcurs ;
+  *r++ =           0 ; Sendbufcurs += sizeof(int) ;  /* store start for size */
+  *retval_p = 1 ;
+
+#if 0
+fprintf(stderr,"TO  INFO: %d %d %d \n",*ig_p,*jg_p, *retval_p) ;
+#endif
+
+  return ;
+}
+
+/********************************************/
+
+/* nest->parent */
+RSL_LITE_TO_PARENT_INFO ( Fcomm, msize_p,
+                          nips_p, nipe_p, njps_p, njpe_p, /* patch dims of SOURCE DOMAIN (CHILD) */
+                          cids_p, cide_p, cjds_p, cjde_p, /* domain dims of TARGET DOMAIN (PARENT) */
+                          ntasks_x_p , ntasks_y_p ,       /* proc counts in x and y */
+                          icoord_p, jcoord_p,
+                          idim_cd_p, jdim_cd_p,
+                          ig_p, jg_p,
+                          retval_p )
+  int_p
+     Fcomm                            /* Fortran version of MPI communicator */
+    ,nips_p, nipe_p, njps_p, njpe_p   /* (i) n.d. patch dims */
+    ,cids_p, cide_p, cjds_p, cjde_p   /* (i) n.n. global dims */
+    ,ntasks_x_p , ntasks_y_p          /* proc counts in x and y */
+    ,icoord_p       /* i coordinate of nest in cd */
+    ,jcoord_p       /* j coordinate of nest in cd */
+    ,idim_cd_p      /* i width of nest in cd */
+    ,jdim_cd_p      /* j width of nest in cd */
+    ,msize_p        /* (I) Message size in bytes. */
+    ,ig_p           /* (O) Global N index of parent domain point. */
+    ,jg_p           /* (O) Global N index of parent domain point. */
+    ,retval_p ;     /* (O) =1 if a valid point returned; =0 (zero) otherwise. */
+{
+  int P, Px, Py ;
+  rsl_list_t *q ;
+  int *r ;
+  int i, j ;
+  int coords[2] ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  if ( Plist == NULL ) {
+    s_ntasks_x = *ntasks_x_p ;
+    s_ntasks_y = *ntasks_y_p ;
+    /* construct Plist */
+    Sendbufsize = 0 ;
+    Plist = RSL_MALLOC( rsl_list_t * , s_ntasks_x * s_ntasks_y ) ;
+    for ( j = 0 ; j < s_ntasks_x * s_ntasks_y ; j++ ) {
+       Plist[j] = NULL ;
+       Sdisplacements[j] = 0 ;
+       Ssizes[j] = 0 ;
+    }
+    for ( j = *njps_p ; j <= *njpe_p ; j++ )
+    {
+      for ( i = *nips_p ; i <= *nipe_p ; i++ )
+      {
+	if ( ( *jcoord_p <= j && j <= *jcoord_p+*jdim_cd_p-1 ) && ( *icoord_p <= i && i <= *icoord_p+*idim_cd_p-1 ) ) {
+	  TASK_FOR_POINT ( &i, &j, cids_p, cide_p, cjds_p, cjde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py ) ;
+          coords[1] = Px ; coords[0] = Py ;
+          MPI_Cart_rank( *comm, coords, &P ) ;
+	  q = RSL_MALLOC( rsl_list_t , 1 ) ;
+	  q->info1 = i ;
+	  q->info2 = j ;
+	  q->next = Plist[P] ;
+	  Plist[P] = q ;
+	  Sendbufsize += *msize_p + 3 * sizeof( int ) ;  /* point data plus 3 ints for i, j, and size */
+        }
+      }
+    }
+    Sendbuf = RSL_MALLOC( char , Sendbufsize ) ;
+    Sendbufcurs = 0 ;
+    Recsizeindex = -1 ;
+    Pcurs = -1 ;
+    Pptr = NULL ;
+  }
+  if ( Pptr != NULL ) {
+    Pptr = Pptr->next ;
+  } 
+
+  if ( Recsizeindex >= 0 ) {
+          r = (int *) &(Sendbuf[Recsizeindex]) ;
+          *r = Sendbufcurs - Recsizeindex + 2 * sizeof(int) ;
+          Ssizes[Pcurs] += *r ;
+  }
+
+  while ( Pptr == NULL ) {
+      Pcurs++ ;
+      while ( Pcurs < s_ntasks_x * s_ntasks_y && Plist[Pcurs] == NULL ) Pcurs++ ;
+      if ( Pcurs < s_ntasks_x * s_ntasks_y ) {
+        Sdisplacements[Pcurs] = Sendbufcurs ;
+        Ssizes[Pcurs] = 0 ;
+        Pptr = Plist[Pcurs] ;
+      } else {
+        *retval_p = 0 ;
+        return ;  /* done */
+      }
+  }
+
+  *ig_p = Pptr->info1 ;
+  *jg_p = Pptr->info2 ;
+
+  r = (int *) &(Sendbuf[Sendbufcurs]) ;
+  *r++ = Pptr->info1 ; Sendbufcurs += sizeof(int) ;  /* ig to buffer */
+  *r++ = Pptr->info2 ; Sendbufcurs += sizeof(int) ;  /* jg to buffer */
+  Recsizeindex = Sendbufcurs ;
+  *r++ =           0 ; Sendbufcurs += sizeof(int) ;  /* store start for size */
+  *retval_p = 1 ;
+
+  return ;
+}
+
+
+/********************************************/
+
+/*@
+  RSL_TO_CHILD_MSG -- Pack force data into a message for a nest point.
+
+@*/
+
+/* parent->nest */
+RSL_LITE_TO_CHILD_MSG ( nbuf_p, buf )
+  int_p
+    nbuf_p ;     /* (I) Number of bytes to be packed. */
+  char *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+{
+   rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
+}
+
+/* nest->parent */
+RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf )
+  int_p
+    nbuf_p ;     /* (I) Number of bytes to be packed. */
+  char *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+{
+   rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ;
+}
+
+/* common code */
+rsl_lite_to_peerpoint_msg ( nbuf_p, buf )
+  int_p
+    nbuf_p ;     /* (I) Number of bytes to be packed. */
+  char *
+    buf ;        /* (I) Buffer containing the data to be packed. */
+{
+  int nbuf ;
+  int *p, *q ;
+  char *c, *d ;
+  int i ;
+
+  RSL_TEST_ERR(buf==NULL,"2nd argument is NULL.  Field allocated?") ;
+
+  nbuf = *nbuf_p ;
+
+  if ( Sendbufcurs + nbuf >= Sendbufsize ) {
+    sprintf(mess,"RSL_LITE_TO_CHILD_MSG: Sendbufcurs + nbuf (%d) would exceed Sendbufsize (%d)\n",
+           Sendbufcurs + nbuf , Sendbufsize ) ;
+    RSL_TEST_ERR(1,mess) ;
+  }
+
+  if ( nbuf % sizeof(int) == 0 ) {
+    for ( p = (int *)buf, q = (int *) &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i += sizeof(int) )
+    {
+      *q++ = *p++ ;
+    }
+  }
+  else
+  {
+    for ( c = buf, d = &(Sendbuf[Sendbufcurs]), i = 0 ; i < nbuf ; i++ )
+    {
+      *d++ = *c++ ;
+    }
+  }
+
+  Sendbufcurs += nbuf ;
+
+}
+
+/********************************************/
+
+/* parent->nest */
+RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_p, comm0 )
+  int_p mytask_p, ntasks_p, comm0 ;
+{
+  rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm0 ) ;
+}
+
+/* nest->parent */
+RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_p, comm0 )
+  int_p mytask_p, ntasks_p, comm0 ;
+{
+  rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm0 ) ;
+}
+
+/* common code */
+rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm0 )
+  int_p mytask_p, ntasks_p, comm0 ;
+{
+  int P ;
+  char *work ;
+  int * r ;
+  bcast_point_desc_t pdesc ;
+  int curs ;
+  int msglen, mdest, mtag ;
+  int ntasks, mytask ;
+  int ii, i, j ;
+  int ig, jg ;
+  int *Psize_all ;
+  int *sp, *bp ;
+  int rc ;
+
+  ntasks = *ntasks_p ;
+  mytask = *mytask_p ;
+
+  RSL_TEST_ERR( Plist == NULL,
+    "RSL_BCAST_MSGS: rsl_to_child_info not called first" ) ;
+
+  RSL_TEST_ERR( ntasks == RSL_MAXPROC ,
+    "RSL_BCAST_MSGS: raise the compile time value of MAXPROC" ) ;
+  
+  Psize_all = RSL_MALLOC( int, ntasks * ntasks ) ;
+
+  MPI_Allgather( Ssizes, ntasks, MPI_INT , Psize_all, ntasks, MPI_INT, *comm0 ) ;
+
+  for ( j = 0 ; j < ntasks ; j++ ) 
+    Rsizes[j] = 0 ;
+
+  for ( j = 0 ; j < ntasks ; j++ ) 
+  {
+    Rsizes[j] += Psize_all[ INDEX_2( j , mytask , ntasks ) ] ;
+  }
+
+  for ( Rbufsize = 0, P = 0, Rdisplacements[0] = 0 ; P < ntasks ; P++ )
+  {
+    Rdisplacements[P+1] = Rsizes[P] + Rdisplacements[P] ;
+    Rbufsize += Rsizes[P] ;
+  }
+
+  /* this will be freed later */
+
+  Recvbuf = RSL_MALLOC( char , Rbufsize + 3 * sizeof(int) ) ; /* for sentinal record */
+  Rbufcurs = 0 ;
+  Rreclen = 0 ;
+
+  rc = MPI_Alltoallv ( Sendbuf, Ssizes, Sdisplacements, MPI_BYTE , 
+                       Recvbuf, Rsizes, Rdisplacements, MPI_BYTE ,  *comm0 ) ;
+
+/* add sentinel to the end of Recvbuf */
+
+  r = (int *)&(Recvbuf[Rbufsize + 2 * sizeof(int)]) ;
+  *r = RSL_INVALID ;
+
+  RSL_FREE( Sendbuf ) ;
+  RSL_FREE( Psize_all ) ;
+
+  for ( j = 0 ; j < *ntasks_p ; j++ )  {
+    destroy_list ( &(Plist[j]), NULL ) ;
+  }
+  RSL_FREE( Plist ) ;
+  Plist = NULL ;
+
+}
+
+/********************************************/
+
+/* parent->nest */
+RSL_LITE_FROM_PARENT_INFO ( ig_p, jg_p, retval_p )
+  int_p
+    ig_p        /* (O) Global index in M dimension of nest. */
+   ,jg_p        /* (O) Global index in N dimension of nest. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
+}
+
+/* nest->parent */
+RSL_LITE_FROM_CHILD_INFO ( ig_p, jg_p, retval_p )
+  int_p
+    ig_p        /* (O) Global index in M dimension of nest. */
+   ,jg_p        /* (O) Global index in N dimension of nest. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ;
+}
+
+/* common code */
+rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p )
+  int_p
+    ig_p        /* (O) Global index in M dimension of nest. */
+   ,jg_p        /* (O) Global index in N dimension of nest. */
+   ,retval_p ;  /* (O) Return value; =1 valid point, =0 done. */
+{
+  int ii ;
+
+  Rbufcurs = Rbufcurs + Rreclen ;
+  Rpointcurs = 0 ;
+  *ig_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
+  *jg_p    = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
+/* read sentinel */
+  Rreclen  = *(int *)&( Recvbuf[Rbufcurs + Rpointcurs ] ) ; Rpointcurs += sizeof(int) ;
+  *retval_p = 1 ;
+  if ( Rreclen == RSL_INVALID ) {
+    *retval_p = 0 ;
+    RSL_FREE( Recvbuf ) ;
+  }
+     
+#if 0
+fprintf(stderr,"FROM  INFO: %d %d %d %d %d %d\n",*ig_p,*jg_p,Rreclen, Rpointcurs, Rbufcurs + Rpointcurs, *retval_p) ;
+#endif
+  return ;
+}
+
+/********************************************/
+
+/* parent->nest */
+RSL_LITE_FROM_PARENT_MSG ( len_p, buf )
+  int_p
+    len_p ;          /* (I) Number of bytes to unpack. */
+  int *
+    buf ;            /* (O) Destination buffer. */
+{
+  rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
+}
+
+/* nest->parent */
+RSL_LITE_FROM_CHILD_MSG ( len_p, buf )
+  int_p
+    len_p ;          /* (I) Number of bytes to unpack. */
+  int *
+    buf ;            /* (O) Destination buffer. */
+{
+  rsl_lite_from_peerpoint_msg ( len_p, buf ) ;
+}
+
+/* common code */
+rsl_lite_from_peerpoint_msg ( len_p, buf )
+  int_p
+    len_p ;          /* (I) Number of bytes to unpack. */
+  int *
+    buf ;            /* (O) Destination buffer. */
+{
+  int *p, *q ;
+  char *c, *d ;
+  int i ;
+
+  if ( *len_p % sizeof(int) == 0 ) {
+    for ( p = (int *)&(Recvbuf[Rbufcurs+Rpointcurs]), q = buf , i = 0 ; i < *len_p ; i += sizeof(int) ) 
+    {
+      *q++ = *p++ ;
+    }
+  } else {
+    for ( c = &(Recvbuf[Rbufcurs+Rpointcurs]), d = (char *) buf , i = 0 ; i < *len_p ; i++ )
+    {
+      *d++ = *c++ ;
+    }
+  }
+
+  Rpointcurs += *len_p ;
+}
+
+/********************************************/
+
+destroy_list( list, dfcn )
+  rsl_list_t ** list ;          /* pointer to pointer to list */
+  int (*dfcn)() ;               /* pointer to function for destroying
+                                   the data field of the list */
+{
+  rsl_list_t *p, *trash ;
+  if ( list == NULL ) return(0) ;
+  if ( *list == NULL ) return(0) ;
+  for ( p = *list ; p != NULL ; )
+  {
+    if ( dfcn != NULL ) (*dfcn)( p->data ) ;
+    trash = p ;
+    p = p->next ;
+    RSL_FREE( trash ) ;
+  }
+  *list = NULL ;
+  return(0) ;
+}
+
+/********************************************/
diff --git a/wrfv2_fire/external/RSL_LITE/rsl_lite.h b/wrfv2_fire/external/RSL_LITE/rsl_lite.h
new file mode 100644
index 00000000..054c0b78
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/rsl_lite.h
@@ -0,0 +1,154 @@
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define RSL_LITE_ERROR_DUP1 rsl_error_dup1
+#      define BYTE_BCAST byte_bcast
+#      define RSL_LITE_INIT_EXCH rsl_lite_init_exch
+#      define RSL_LITE_EXCH_Y rsl_lite_exch_y
+#      define RSL_LITE_EXCH_X rsl_lite_exch_x
+#      define RSL_LITE_PACK  rsl_lite_pack
+#      define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs
+#      define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg
+#      define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info
+#      define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg
+#      define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info
+#      define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs
+#      define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg
+#      define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info
+#      define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg
+#      define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info
+#      define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock
+#      define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock
+#      define TASK_FOR_POINT task_for_point
+#      define RSL_LITE_INIT_PERIOD rsl_lite_init_period
+#      define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y
+#      define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x
+#      define RSL_LITE_PACK_PERIOD  rsl_lite_pack_period
+#      define RSL_LITE_INIT_SWAP rsl_lite_init_swap
+#      define RSL_LITE_SWAP rsl_lite_swap
+#      define RSL_LITE_PACK_SWAP  rsl_lite_pack_swap
+#      define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle
+#      define RSL_LITE_CYCLE rsl_lite_cycle
+#      define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle
+#      define F_PACK_LINT f_pack_lint
+#      define F_PACK_INT f_pack_int
+#      define F_UNPACK_LINT f_unpack_lint
+#      define F_UNPACK_INT f_unpack_int
+# else
+#   ifdef F2CSTYLE
+#      define RSL_LITE_ERROR_DUP1 rsl_error_dup1__
+#      define BYTE_BCAST byte_bcast__
+#      define RSL_LITE_INIT_EXCH rsl_lite_init_exch__
+#      define RSL_LITE_EXCH_Y rsl_lite_exch_y__
+#      define RSL_LITE_EXCH_X rsl_lite_exch_x__
+#      define RSL_LITE_PACK  rsl_lite_pack__
+#      define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs__
+#      define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg__
+#      define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info__
+#      define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg__
+#      define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info__
+#      define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs__
+#      define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg__
+#      define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info__
+#      define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg__
+#      define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info__
+#      define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock__
+#      define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock__
+#      define TASK_FOR_POINT task_for_point__
+#      define RSL_LITE_INIT_PERIOD rsl_lite_init_period__
+#      define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y__
+#      define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x__
+#      define RSL_LITE_PACK_PERIOD  rsl_lite_pack_period__
+#      define RSL_LITE_INIT_SWAP rsl_lite_init_swap__
+#      define RSL_LITE_SWAP rsl_lite_swap__
+#      define RSL_LITE_PACK_SWAP  rsl_lite_pack_swap__
+#      define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle__
+#      define RSL_LITE_CYCLE rsl_lite_cycle__
+#      define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle__
+#      define F_PACK_LINT f_pack_lint__
+#      define F_PACK_INT f_pack_int__
+#      define F_UNPACK_LINT f_unpack_lint__
+#      define F_UNPACK_INT f_unpack_int__
+#   else
+#      define RSL_LITE_ERROR_DUP1 rsl_error_dup1_
+#      define BYTE_BCAST byte_bcast_
+#      define RSL_LITE_INIT_EXCH rsl_lite_init_exch_
+#      define RSL_LITE_EXCH_Y rsl_lite_exch_y_
+#      define RSL_LITE_EXCH_X rsl_lite_exch_x_
+#      define RSL_LITE_PACK  rsl_lite_pack_
+#      define RSL_LITE_BCAST_MSGS rsl_lite_bcast_msgs_
+#      define RSL_LITE_TO_CHILD_MSG rsl_lite_to_child_msg_
+#      define RSL_LITE_TO_CHILD_INFO rsl_lite_to_child_info_
+#      define RSL_LITE_FROM_PARENT_MSG rsl_lite_from_parent_msg_
+#      define RSL_LITE_FROM_PARENT_INFO rsl_lite_from_parent_info_
+#      define RSL_LITE_MERGE_MSGS rsl_lite_merge_msgs_
+#      define RSL_LITE_TO_PARENT_MSG rsl_lite_to_parent_msg_
+#      define RSL_LITE_TO_PARENT_INFO rsl_lite_to_parent_info_
+#      define RSL_LITE_FROM_CHILD_MSG rsl_lite_from_child_msg_
+#      define RSL_LITE_FROM_CHILD_INFO rsl_lite_from_child_info_
+#      define RSL_INTERNAL_MILLICLOCK rsl_internal_milliclock_
+#      define RSL_INTERNAL_MICROCLOCK rsl_internal_microclock_
+#      define TASK_FOR_POINT task_for_point_
+#      define RSL_LITE_INIT_PERIOD rsl_lite_init_period_
+#      define RSL_LITE_EXCH_PERIOD_Y rsl_lite_exch_period_y_
+#      define RSL_LITE_EXCH_PERIOD_X rsl_lite_exch_period_x_
+#      define RSL_LITE_PACK_PERIOD  rsl_lite_pack_period_
+#      define RSL_LITE_INIT_SWAP rsl_lite_init_swap_
+#      define RSL_LITE_SWAP rsl_lite_swap_
+#      define RSL_LITE_PACK_SWAP rsl_lite_pack_swap_
+#      define RSL_LITE_INIT_CYCLE rsl_lite_init_cycle_
+#      define RSL_LITE_CYCLE rsl_lite_cycle_
+#      define RSL_LITE_PACK_CYCLE rsl_lite_pack_cycle_
+#      define F_PACK_LINT f_pack_lint_
+#      define F_PACK_INT f_pack_int_
+#      define F_UNPACK_LINT f_unpack_lint_
+#      define F_UNPACK_INT f_unpack_int_
+#   endif
+# endif
+#endif
+
+#define RSL_SENDBUF 0
+#define RSL_RECVBUF 1
+#define RSL_FREEBUF 3
+#define RSL_MAXPROC 10000
+#define RSL_INVALID -1
+
+/* this must be the same as defined in frame/module_driver_constants.F */
+#define   DATA_ORDER_XYZ   1
+#define   DATA_ORDER_YXZ   2
+#define   DATA_ORDER_ZXY   3
+#define   DATA_ORDER_ZYX   4
+#define   DATA_ORDER_XZY   5
+#define   DATA_ORDER_YZX   6
+
+
+#define RSL_MALLOC(T,N)  (T *)rsl_malloc(__FILE__,__LINE__,(sizeof(T))*(N))
+#define RSL_FREE(P)      rsl_free(P)
+
+char * buffer_for_proc ( int P, int size, int code ) ;
+void * rsl_malloc( char * f, int l, int s ) ;
+typedef int * int_p ;
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+#define INDEX_3(A,B,NB,C,NC)  INDEX_2( (A), INDEX_2( (B), (C), (NC) ), (NB)*(NC) )
+
+#define RSL_FATAL(N)     MPI_Abort(MPI_COMM_WORLD, 9)
+#define RSL_TEST_ERR(T,M) {if(T){fprintf(stderr,"rsl_lite error (\"%s\":%d) %s\n",__FILE__,__LINE__,M);RSL_FATAL(5);}}
+
+#ifndef MPI2_SUPPORT
+typedef int MPI_Fint;
+#  define MPI_Comm_c2f(comm) (MPI_Fint)(comm)
+#  define MPI_Comm_f2c(comm) (MPI_Comm)(comm)
+#endif
+
+typedef struct rsl_list {
+  struct rsl_list * next ;
+  void * data ;                 /* pointer to some node */
+#ifdef crayx1
+  int info1 ;                   /* blank info field */
+  int info2 ;                   /* blank info field */
+#else
+  short info1 ;                 /* blank info field */
+  short info2 ;                 /* blank info field */
+#endif
+} rsl_list_t ;
+
diff --git a/wrfv2_fire/external/RSL_LITE/rsl_malloc.c b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c
new file mode 100755
index 00000000..f12df0b7
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c
@@ -0,0 +1,253 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+
+#if 0
+#define PADIT		/* add page at beginning and end of allocation */
+#endif
+#if 0
+# define BASE_MALLOC   fence_malloc
+# define BASE_FREE     fence_free
+#else
+# define BASE_MALLOC   malloc
+# define BASE_FREE     free
+#endif
+
+#include 
+#include 
+#include 
+#ifdef T3D
+#include 
+#endif
+#include "mpi.h"
+#include "rsl_lite.h"
+
+/*
+extern int EF_ALIGNMENT;
+extern int EF_PROTECT_BELOW;
+extern int EF_PROTECT_FREE;
+*/
+
+/* define STUG to enable tracking of allocs and frees (performance and space penalty) */
+#ifdef STUG
+#define MAXSTUG  1000000
+struct stugtype {
+   char *  ddr ;
+   int     sz  ;
+} stug[MAXSTUG] ;
+static int stugfirst =1 ;
+int outy = 0 ;
+int nouty = 0 ;
+int maxstug = 0 ;
+int maxouty = 0 ;
+int bbb ;
+#endif
+
+
+static char zero_length_storage[] = "" ;
+
+#if !(defined(vpp) || defined(vpp2) || defined(SUN) || defined(XT3_Catamount))
+static struct mallinfo minf ;
+#endif
+
+static char *last_f ;
+static int last_l ;
+static int last_s ;
+
+#ifdef O2K
+static struct mallinfo mallinfo() {} ;
+#endif
+
+void * rsl_malloc(f,l,s)
+   char * f ;
+   int l, s ;
+{
+   char mess[128] ;
+   void *retval ;
+   int s2, tries ;
+
+/*
+EF_PROTECT_BELOW = 0 ;
+EF_PROTECT_FREE = 1 ;
+*/
+
+#ifdef STUG
+   if ( stugfirst == 1 ) {
+      stugfirst = 0 ;
+      for ( bbb = 0 ; bbb < MAXSTUG ; bbb++ ) {
+         stug[bbb].ddr = 0L ;
+         stug[bbb].sz  = 0 ;
+      }
+   }
+#endif
+
+   if ( s == 0 )
+   {
+     retval = (void *) zero_length_storage ;
+   }
+   else 
+   {
+#ifdef PADIT
+     s2 = s + 1024 ;
+#else
+     s2 = s ;
+#endif
+     tries = 0 ;
+     while ((retval=(void *)BASE_MALLOC(s2))==(void *)NULL)
+     {
+       tries++ ;
+       sprintf(mess,
+"rsl_malloc failed allocating %d bytes, called %s, line %d, try %d\n",
+       s,f,l,tries) ;
+       perror(mess) ;
+#if !(defined(vpp) || defined(vpp2) || defined(SUN) || defined(XT3_Catamount))
+       minf = mallinfo() ;
+       fprintf(stderr,"mallinfo: arena %d\n",minf.arena)  ;
+       fprintf(stderr,"mallinfo: ordblks %d\n",minf.ordblks)  ;
+       fprintf(stderr,"mallinfo: smblks %d\n",minf.smblks)  ;
+       fprintf(stderr,"mallinfo: hblks %d\n",minf.hblks)  ;
+       fprintf(stderr,"mallinfo: hblkhd %d\n",minf.hblkhd)  ;
+       fprintf(stderr,"mallinfo: usmblks %d\n",minf.usmblks)  ;
+       fprintf(stderr,"mallinfo: fsmblks %d\n",minf.fsmblks)  ;
+       fprintf(stderr,"mallinfo: uordblks %d\n",minf.uordblks)  ;
+       fprintf(stderr,"mallinfo: fordblks %d\n",minf.fordblks)  ;
+       fprintf(stderr,"mallinfo: keepcost %d\n",minf.keepcost)  ;
+#ifdef SUNINFO
+       fprintf(stderr,"mallinfo: mkfast %d\n",minf.mkfast)  ;
+       fprintf(stderr,"mallinfo: nblks %d\n",minf.nblks)  ;
+       fprintf(stderr,"mallinfo: grain %d\n",minf.grain)  ;
+       fprintf(stderr,"mallinfo: uordbytes %d\n",minf.uordbytes)  ;
+       fprintf(stderr,"mallinfo: allocated %d\n",minf.allocated)  ;
+       fprintf(stderr,"mallinfo: treeoverhead %d\n",minf.treeoverhead)  ;
+#endif
+#endif
+       if ( tries >= 2 )
+       { 
+	 system("lsps -a") ;
+	 sleep(1) ;
+       }
+       if ( tries >= 3 ) 
+       {
+	 system("lsps -a") ;
+	 RSL_FATAL(2) ;
+       }
+     }
+   }
+#if !(defined(vpp)||defined(vpp2)) || defined(sx) || defined(alphavector)
+   if ( s > 0 )
+     bzero( retval, s2 ) ;	/* return zero'd storage always */
+#else
+   if ( s > 0 )
+   { int l, lb ;
+     l = s2/sizeof(int) ;
+     lb = l*sizeof(int) ;
+     vizero_( retval, &l  ) ;
+     l = s2-lb ;
+     vbzero_( retval+lb, &l ) ;	/* return zero'd storage always */
+   }
+#endif
+
+#ifdef PADIT
+   retval = retval + 512 ;
+#endif
+
+#ifdef STUG
+for ( bbb = 0 ; bbb < MAXSTUG ; bbb++ )
+{
+   if ( stug[bbb].ddr == 0 ) break ;
+}
+if ( bbb < MAXSTUG ) {
+   stug[bbb].ddr = retval ;
+   stug[bbb].sz  = s ;
+   outy += stug[bbb].sz ;
+/* fprintf(stderr,"+ %10d.  %08x   %10d  %10d\n", bbb, stug[bbb].ddr, stug[bbb].sz, outy ) ; */
+   nouty ++ ;
+   if ( nouty > maxstug ) maxstug = nouty ;
+   if ( outy > maxouty ) maxouty = outy ;
+}else{
+fprintf(stderr,"stug full %d\n",bbb) ;
+RSL_FATAL(2) ;
+}
+#endif
+   return(retval) ;
+}
+
+rsl_free( p )
+   char * p ;
+{
+   if ( p == zero_length_storage ) return ;    /* fix from ANU */
+
+#ifdef STUG
+for ( bbb = 0 ; bbb < MAXSTUG ; bbb++ ) 
+{
+   if ( stug[bbb].ddr == p ) {
+      outy -= stug[bbb].sz ;
+/* fprintf(stderr,"- %10d.  %08x   %10d  %10d\n", bbb, stug[bbb].ddr, stug[bbb].sz, outy ) ; */
+      nouty -- ;
+      stug[bbb].ddr = 0L ;
+      break ;
+   }
+}
+#endif
+
+#ifdef PADIT
+   BASE_FREE ( p-512 ) ;
+#else
+   BASE_FREE ( p ) ;
+#endif
+   p = NULL ;
+}
+
+
diff --git a/wrfv2_fire/external/RSL_LITE/swap.c b/wrfv2_fire/external/RSL_LITE/swap.c
new file mode 100644
index 00000000..c2a5a3b0
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/swap.c
@@ -0,0 +1,326 @@
+#include 
+#include 
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#include "mpi.h"
+#include "rsl_lite.h"
+
+#define  UP_EVEN(A)   ((A)+abs((A)%2))
+#define  DOWN_EVEN(A) ((A) - abs((A)%2))
+#define  UP_ODD(A)    ((A) + abs(((A)+1)%2))
+#define  DOWN_ODD(A)  ((A) - abs(((A)+1)%2))
+#define  MIN(A,B)     ((A)<(B)?(A):(B))
+#define  MAX(A,B)     ((A)>(B)?(A):(B))
+
+static int *y_curs = NULL ;
+static int *x_curs = NULL ;
+static int *x_peermask = NULL ;
+static int *nbytes = NULL ; 
+static MPI_Request *x_recv = NULL , *x_send = NULL ;
+
+RSL_LITE_INIT_SWAP ( 
+                int * Fcomm ,
+                int * xy0 ,
+                int * n3dR0, int *n2dR0, int * typesizeR0 , 
+                int * n3dI0, int *n2dI0, int * typesizeI0 , 
+                int * n3dD0, int *n2dD0, int * typesizeD0 , 
+                int * n3dL0, int *n2dL0, int * typesizeL0 , 
+                int * me0, int * np0 , int * np_x0 , int * np_y0 ,
+                int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int n3dR, n2dR, typesizeR ;
+  int n3dI, n2dI, typesizeI ;
+  int n3dD, n2dD, typesizeD ;
+  int n3dL, n2dL, typesizeL ;
+  int xy ;
+  int me, np, np_x, np_y ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int ips_send , ipe_send ;
+  int npts, i, ii, j, m, n, ps, pe, ops, ope ;
+  int Px, Py, P, coords[2] ;
+  int ips_swap, ipe_swap ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  xy = *xy0 ;
+  n3dR = *n3dR0 ; n2dR = *n2dR0 ; typesizeR = *typesizeR0 ;
+  n3dI = *n3dI0 ; n2dI = *n2dI0 ; typesizeI = *typesizeI0 ;
+  n3dD = *n3dD0 ; n2dD = *n2dD0 ; typesizeD = *typesizeD0 ;
+  n3dL = *n3dL0 ; n2dL = *n2dL0 ; typesizeL = *typesizeL0 ;
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+
+  if ( nbytes == NULL ) nbytes = RSL_MALLOC ( int , np ) ;
+  if ( x_curs == NULL ) x_curs = RSL_MALLOC ( int , np ) ;
+  if ( x_peermask == NULL ) x_peermask = RSL_MALLOC ( int , np ) ;
+  if ( x_recv == NULL ) x_recv = RSL_MALLOC ( MPI_Request , np ) ;
+  if ( x_send == NULL ) x_send = RSL_MALLOC ( MPI_Request , np ) ;
+  for ( i = 0 ; i < np ; i++ ) { nbytes[i] = 0 ; x_curs[i] = 0 ; x_peermask[i] = 0 ; }
+
+  if ( xy == 1 ) {   /* xy = 1, swap in X, otherwise Y */
+    n = (ide-ids+1)/4*2 ;
+    m = n*2 ;
+    ps = ips ;
+    pe = ipe ;
+    ops = jps ;
+    ope = jpe ;
+  } else {
+    n = (jde-jds+1)/4*2 ;
+    m = n*2 ;
+    ps = jps ;
+    pe = jpe ;
+    ops = ips ;
+    ope = ipe ;
+  }
+
+  for ( i = UP_ODD( ps ) ; i <= MIN(pe,m) ; i+=2 ) {
+    ii = abs(i+n) % m ;
+    if ( xy == 1 ) {
+      TASK_FOR_POINT ( &ii , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+    } else {
+      TASK_FOR_POINT ( &ips , &ii , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+    }
+    nbytes[P] += typesizeR*(ope-ops+1)*(n3dR*(kpe-kps+1)+n2dR) +
+                 typesizeI*(ope-ops+1)*(n3dI*(kpe-kps+1)+n2dI) +
+                 typesizeD*(ope-ops+1)*(n3dD*(kpe-kps+1)+n2dD) +
+                 typesizeL*(ope-ops+1)*(n3dL*(kpe-kps+1)+n2dL) ;
+    x_peermask[P] = 1 ;
+  }
+
+  for ( P = 0 ; P < np ; P++ ) {
+     if ( x_peermask[P] ) {
+       buffer_for_proc ( P , nbytes[P], RSL_RECVBUF ) ;
+       buffer_for_proc ( P , nbytes[P], RSL_SENDBUF ) ;
+     }
+  }
+}
+
+RSL_LITE_PACK_SWAP ( int * Fcomm , char * buf , int * odd0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 ,
+           int *me0, int * np0 , int * np_x0 , int * np_y0 , 
+           int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+           int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 ,
+           int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+  int me, np, np_x, np_y ;
+  int odd , typesize ;
+  int ids , ide , jds , jde , kds , kde ;
+  int ims , ime , jms , jme , kms , kme ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int xstag ;  /* 0 not stag, 1 stag */
+  int xy ;   /* y = 0 , x = 1 */
+  int pu ;   /* pack = 0 , unpack = 1 */
+  int i, ii, j, jj, m, n  ;
+  int ps, pe, ops, ope ;
+  register int k, t ;
+#ifdef crayx1
+  register int i2,i3,i4,i_offset;
+#endif
+  char *p ;
+  int da_buf ;
+  int Px, Py, P, coords[2] ;
+  int ierr = 0 ;
+  register int *pi, *qi ;
+  float f ;
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  xstag = *xstag0 ;
+  odd = *odd0 ; typesize = *typesize0 ;
+  ids = *ids0-1 ; ide = *ide0-1 ; jds = *jds0-1 ; jde = *jde0-1 ; kds = *kds0-1 ; kde = *kde0-1 ;
+  ims = *ims0-1 ; ime = *ime0-1 ; jms = *jms0-1 ; jme = *jme0-1 ; kms = *kms0-1 ; kme = *kme0-1 ;
+  ips = *ips0-1 ; ipe = *ipe0-1 ; jps = *jps0-1 ; jpe = *jpe0-1 ; kps = *kps0-1 ; kpe = *kpe0-1 ;
+  xy = *xy0 ;
+  pu = *pu0 ;
+
+/* need to adapt for other memory orders */
+#define RANGE(S1,E1,S2,E2,S3,E3,S4,E4) (((E1)-(S1)+1)*((E2)-(S2)+1)*(((E3)-(S3)+1)/2)*((E4)-(S4)+1))
+#define IMAX(A) (((A)>ids)?(A):ids)
+#define IMIN(A) (((A)jds)?(A):jds)
+#define JMIN(A) (((A) 1 && xy == 1 ) {
+
+    for ( i = UP_ODD(ips) ; i <= MIN(ipe,m) ; i+=2 ) {
+      ii = abs(i+n) % m ;
+      TASK_FOR_POINT ( &ii , &jps , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+      p = buffer_for_proc( P , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+	if ( typesize == sizeof(int) ) {
+          for ( j = JMAX(jps) ; j <= JMIN(jpe) ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *pi++ = *qi++ ;
+	      x_curs[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( j = JMAX(jps) ; j <= JMIN(jpe) ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                *(p+x_curs[P]) = 
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) ;
+                x_curs[P]++ ;
+              }
+            }
+          }
+	}
+      } else {
+	if ( typesize == sizeof(int) ) {
+          for ( j = JMAX(jps) ; j <= JMIN(jpe) ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *qi++ = *pi++ ;
+	      x_curs[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( j = JMAX(jps) ; j <= JMIN(jpe) ; j++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) =
+                *(p+x_curs[P]) ;
+                x_curs[P]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  } else if ( np_y > 1 && xy == 0 ) {
+    for ( j = UP_ODD(jps) ; j <= MIN(jpe,m) ; j+=2 ) {
+      jj = abs(j+n) % m ;
+      TASK_FOR_POINT ( &ips , &jj , &ids, &ide , &jds, &jde , &np_x , &np_y , &Px, &Py ) ;
+      coords[1] = Px ; coords[0] = Py ;
+      MPI_Cart_rank( *comm, coords, &P ) ;
+      p = buffer_for_proc( P , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+	if ( typesize == sizeof(int) ) {
+          for ( i = IMAX(ips) ; i <= IMIN(ipe) ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *pi++ = *qi++ ;
+	      x_curs[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( i = IMAX(ips) ; i <= IMIN(ipe) ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                *(p+x_curs[P]) = 
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) ;
+                x_curs[P]++ ;
+              }
+            }
+          }
+	}
+      } else {
+	if ( typesize == sizeof(int) ) {
+          for ( i = IMAX(ips) ; i <= IMIN(ipe) ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+	      pi = (int *)(p+x_curs[P]) ;
+	      qi = (int *)((buf + typesize*( (i-ims) + (ime-ims+1)*(
+                                             (k-kms) + (j-jms)*(kme-kms+1))))) ;
+	      *qi++ = *pi++ ;
+	      x_curs[P] += typesize ;
+	    }
+	  }
+	}
+	else {
+          for ( i = IMAX(ips) ; i <= IMIN(ipe) ; i++ ) {
+            for ( k = kps ; k <= kpe ; k++ ) {
+              for ( t = 0 ; t < typesize ; t++ ) {
+                               *(buf + t + typesize*(
+                                      (i-ims) + (ime-ims+1)*(
+                                      (k-kms) + (j-jms)*(kme-kms+1))) ) =
+                *(p+x_curs[P]) ;
+                x_curs[P]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
+RSL_LITE_SWAP ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, nb ;
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int i, P ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+#if 1
+
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+
+/* fprintf(stderr,"RSL_LITE_SWAP\n") ; */
+
+  for ( P = 0 ; P < np ; P++ ) {
+    if ( x_peermask[P] ) {
+      nb = buffer_size_for_proc( P, RSL_RECVBUF ) ;
+/* fprintf(stderr,"posting irecv from %d, nb = %d\n",P,nb) ; */
+      MPI_Irecv ( buffer_for_proc( P, x_curs[P], RSL_RECVBUF ), nb, MPI_CHAR, P, me, comm, &(x_recv[P]) ) ;
+/* fprintf(stderr,"sending to         %d, nb = %d\n",P,x_curs[P]) ; */
+      MPI_Isend ( buffer_for_proc( P, 0,         RSL_SENDBUF ), x_curs[P], MPI_CHAR, P, P, comm, &(x_send[P]) ) ;
+    }
+  }
+  for ( P = 0 ; P < np ; P++ ) {
+    if ( x_peermask[P] ) {
+      MPI_Wait( &x_recv[P], &stat ) ; 
+      MPI_Wait( &x_send[P], &stat ) ; 
+    }
+  }
+#else 
+fprintf(stderr,"RSL_LITE_SWAP disabled\n") ;
+#endif
+  for ( i = 0 ; i < np ; i++ ) {  x_curs[i] = 0 ;  }
+}
+
diff --git a/wrfv2_fire/external/RSL_LITE/task_for_point.c b/wrfv2_fire/external/RSL_LITE/task_for_point.c
new file mode 100644
index 00000000..5cb94d4d
--- /dev/null
+++ b/wrfv2_fire/external/RSL_LITE/task_for_point.c
@@ -0,0 +1,97 @@
+#include 
+#include "rsl_lite.h"
+
+/* updated 20051021, new algorithm distributes the remainder, if any, at either ends of the dimension
+   rather than the first remainder number of processors in the dimension. Idea is that the processes
+   on the ends have less work because they're boundary processes.  New alg works like this:
+                     a                         b
+         + + + + + + o o o o o o o o o o o o o + + + + + +
+
+   + represents a process with an extra point (npoints is n/p+1), o processors that don't (n/p)
+   a and b are the starting process indices in the dimension of the new section of o or x.
+   JM
+*/
+
+TASK_FOR_POINT ( i_p , j_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p , Px_p, Py_p )
+  int_p i_p , j_p , Px_p , Py_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p ;
+{
+  int i , j , ids, ide, jds, jde, npx, npy ;  /* inputs */
+  int Px, Py ;                                /* output */
+  int idim, jdim ;
+  int rem, a, b ;
+  i = *i_p - 1 ;
+  j = *j_p - 1 ;
+  npx = *npx_p ;
+  npy = *npy_p ;
+  ids = *ids_p - 1 ; ide = *ide_p - 1 ;
+  jds = *jds_p - 1 ; jde = *jde_p - 1 ;
+  idim = ide - ids + 1 ;
+  jdim = jde - jds + 1 ;
+
+  i = i >= ids ? i : ids ; i = i <= ide ? i : ide ;
+  rem = idim % npx ;
+  a = ( rem / 2 ) * ( (idim / npx) + 1 ) ;
+  b = a + ( npx - rem ) * ( idim / npx ) ;
+  if ( i-ids < a ) {
+    Px = (i-ids) / ( (idim / npx) + 1 ) ;
+  }
+  else if ( i-ids < b ) {
+    Px = ( a / ( (idim / npx) + 1 ) ) + (i-a-ids) / ( ( b - a ) / ( npx - rem ) )     ;
+  }
+  else {
+    Px = ( a / ( (idim / npx) + 1 ) ) + (b-a-ids) / ( ( b - a ) / ( npx - rem ) ) +
+                                        (i-b-ids) / ( ( idim / npx ) + 1 )  ;
+  }
+
+  j = j >= jds ? j : jds ; j = j <= jde ? j : jde ;
+  rem = jdim % npy ;
+  a = ( rem / 2 ) * ( (jdim / npy) + 1 ) ;
+  b = a + ( npy - rem ) * ( jdim / npy ) ;
+  if ( j-jds < a ) {
+    Py = (j-jds) / ( (jdim / npy) + 1 ) ;
+  }
+  else if ( j-jds < b ) {
+    Py = ( a / ( (jdim / npy) + 1 ) ) + (j-a-jds) / ( ( b - a ) / ( npy - rem ) )     ;
+  }
+  else {
+    Py = ( a / ( (jdim / npy) + 1 ) ) + (b-a-jds) / ( ( b - a ) / ( npy - rem ) ) +
+                                        (j-b-jds) / ( ( jdim / npy ) + 1 )  ;
+  }
+
+  *Px_p = Px ;
+  *Py_p = Py ;
+}
+
+#if 0
+main()
+{
+  int ips[100], ipe[100] ;
+  int jps[100], jpe[100] ;
+  int shw, i , j , ids, ide, jds, jde, npx, npy ;  /* inputs */
+  int Px, Py, P ;                             /* output */
+  printf("i, j, ids, ide, jds, jde, npx, npy\n") ;
+  scanf("%d %d %d %d %d %d %d %d",&i, &j, &ids,&ide,&jds,&jde,&npx,&npy ) ;
+  shw =0 ;
+  for ( i = 0 ; i < 100 ; i++ ) { ips[i] = 9999999 ; ipe[i] = -99999999 ; }
+  for ( i = 0 ; i < 100 ; i++ ) { jps[i] = 9999999 ; jpe[i] = -99999999 ; }
+#if 1
+  for ( j = jds-shw ; j <= jde+shw ; j++ )
+  {
+  for ( i = ids-shw ; i <= ide+shw ; i++ )
+  {
+#endif
+  TASK_FOR_POINT ( &i , &j ,
+                   &ids, &ide, &jds, &jde , &npx , &npy ,
+                   &Px, &Py ) ;
+/*  printf("%3d",P) ; */
+#if 1
+  }
+/*  printf("\n") ; */
+  }
+for ( i = 0 ; i < npx*npy ; i++ ) {
+  fprintf(stderr,"%3d. ips %d ipe %d (%d) jps %d jpe %d (%d)\n", i, ips[i], ipe[i], ipe[i]-ips[i]+1, jps[i], jpe[i], jpe[i]-jps[i]+1 ) ;
+}
+#endif
+}
+#endif
+
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Alarm.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Alarm.F90
new file mode 100644
index 00000000..601552e7
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Alarm.F90
@@ -0,0 +1,960 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF Alarm Module
+      module ESMF_AlarmMod
+!
+!==============================================================================
+!
+! This file contains the Alarm class definition and all Alarm class 
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include 
+
+!===============================================================================
+!BOPI
+!
+! !MODULE: ESMF_AlarmMod
+!
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ class {\tt ESMC\_Alarm}
+!
+! See {\tt ../include/ESMC\_Alarm.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit from ESMF base class
+      use ESMF_BaseMod
+
+      ! associated derived types
+      use ESMF_TimeIntervalMod, only : ESMF_TimeInterval, &
+                                       ESMF_TimeIntervalAbsValue
+      use ESMF_TimeMod,         only : ESMF_Time
+
+      implicit none
+
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+     private
+!------------------------------------------------------------------------------
+!     ! ESMF_Alarm
+!
+!     ! F90 class type to match C++ Alarm class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+
+! internals for ESMF_Alarm
+      type ESMF_AlarmInt
+        type(ESMF_TimeInterval) :: RingInterval
+        type(ESMF_Time)  :: RingTime
+        type(ESMF_Time)  :: PrevRingTime
+        type(ESMF_Time)  :: StopTime
+        integer :: ID
+        integer :: AlarmMutex
+        logical :: Ringing
+        logical :: Enabled
+        logical :: RingTimeSet
+        logical :: RingIntervalSet
+        logical :: StopTimeSet
+      end type
+
+! Actual public type:  this bit allows easy mimic of "deep" ESMF_AlarmCreate
+! in ESMF 2.1.0+.  Note that ESMF_AlarmCreate is in a separate module to avoid 
+! cyclic dependence.  
+! NOTE:  DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE.  It emulates ESMF 
+!        shallow-copy-masquerading-as-reference-copy insanity.  
+      type ESMF_Alarm
+        type(ESMF_AlarmInt), pointer :: alarmint
+      end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_Alarm
+      public ESMF_AlarmInt   ! needed on AIX but not PGI
+!------------------------------------------------------------------------------
+
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_AlarmDestroy
+      public ESMF_AlarmSet
+      public ESMF_AlarmGet
+!      public ESMF_AlarmGetRingInterval
+!      public ESMF_AlarmSetRingInterval
+!      public ESMF_AlarmGetRingTime
+!      public ESMF_AlarmSetRingTime
+!      public ESMF_AlarmGetPrevRingTime
+!      public ESMF_AlarmSetPrevRingTime
+!      public ESMF_AlarmGetStopTime
+!      public ESMF_AlarmSetStopTime
+      public ESMF_AlarmEnable
+      public ESMF_AlarmDisable
+      public ESMF_AlarmRingerOn
+      public ESMF_AlarmRingerOff
+      public ESMF_AlarmIsRinging
+!      public ESMF_AlarmCheckRingTime
+      public operator(==)
+ 
+! Required inherited and overridden ESMF_Base class methods
+
+!      public ESMF_AlarmRead
+!      public ESMF_AlarmWrite
+      public ESMF_AlarmValidate
+      public ESMF_AlarmPrint
+
+! !PRIVATE MEMBER FUNCTIONS:
+      private ESMF_AlarmEQ
+!EOPI
+
+!==============================================================================
+!
+! INTERFACE BLOCKS
+!
+!==============================================================================
+!BOP
+! !INTERFACE:
+      interface operator(==)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_AlarmEQ
+
+! !DESCRIPTION:
+!     This interface overloads the == operator for the {\tt ESMF\_Alarm} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+
+!------------------------------------------------------------------------------
+!
+! This section includes the Set methods.
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmSet - Initializes an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmSet(alarm, RingTime, RingInterval, &
+                               StopTime, Enabled, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_Time), intent(in), optional :: RingTime
+      type(ESMF_TimeInterval), intent(in), optional :: RingInterval
+      type(ESMF_Time), intent(in), optional :: StopTime
+      logical, intent(in), optional :: Enabled
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Initializes an {\tt ESMF\_Alarm}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to initialize
+!     \item[{[RingTime]}]
+!          Optional ring time for one-shot or first repeating alarm
+!     \item[{[RingInterval]}]
+!          Optional ring interval for repeating alarms
+!     \item[{[StopTime]}]
+!          Optional stop time for repeating alarms
+!     \item[Enabled]
+!          Alarm enabled/disabled
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.1, TMG4.7
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        alarm%alarmint%RingTimeSet = .FALSE.
+        alarm%alarmint%RingIntervalSet = .FALSE.
+        alarm%alarmint%StopTimeSet = .FALSE.
+        IF ( PRESENT( RingInterval ) ) THEN
+          ! force RingInterval to be positive
+          alarm%alarmint%RingInterval = &
+            ESMF_TimeIntervalAbsValue( RingInterval )
+          alarm%alarmint%RingIntervalSet = .TRUE.
+        ENDIF
+        IF ( PRESENT( RingTime ) ) THEN
+          alarm%alarmint%RingTime = RingTime
+          alarm%alarmint%RingTimeSet = .TRUE.
+        ENDIF
+        IF ( PRESENT( StopTime ) ) THEN
+          alarm%alarmint%StopTime = StopTime
+          alarm%alarmint%StopTimeSet = .TRUE.
+        ENDIF
+        alarm%alarmint%Enabled = .TRUE.
+        IF ( PRESENT( Enabled ) ) THEN
+          alarm%alarmint%Enabled = Enabled
+        ENDIF
+        IF ( PRESENT( rc ) ) THEN
+          rc = ESMF_SUCCESS
+        ENDIF
+        alarm%alarmint%Ringing = .FALSE.
+        alarm%alarmint%Enabled = .TRUE.
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+
+      end subroutine ESMF_AlarmSet
+
+
+
+! Deallocate memory for ESMF_Alarm
+      SUBROUTINE ESMF_AlarmDestroy( alarm, rc )
+         TYPE(ESMF_Alarm), INTENT(INOUT) :: alarm
+         INTEGER,          INTENT(  OUT), OPTIONAL :: rc
+         IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+           DEALLOCATE( alarm%alarmint )
+         ENDIF
+         ! TBH:  ignore deallocate errors, for now
+         IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      END SUBROUTINE ESMF_AlarmDestroy
+
+
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmGetRingInterval - Get an alarm's ring interval
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmGetRingInterval(alarm, RingInterval, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_TimeInterval), intent(out) :: RingInterval
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Alarm}'s ring interval
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to get the ring interval
+!     \item[RingInterval]
+!          The {\tt Alarm}'s ring interval
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.7
+!EOP
+      RingInterval = alarm%alarmint%RingInterval
+
+      end subroutine ESMF_AlarmGetRingInterval
+ 
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmSetRingInterval - Set an alarm's ring interval
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmSetRingInterval(alarm, RingInterval, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_TimeInterval), intent(in) :: RingInterval
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Alarm}'s ring interval
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to set the ring interval
+!     \item[RingInterval]
+!          The {\tt Alarm}'s ring interval
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.5.2, TMG4.7
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmSetRingInterval not supported' )
+      end subroutine ESMF_AlarmSetRingInterval
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmGetRingTime - Get an alarm's time to ring
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmGetRingTime(alarm, RingTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_Time), intent(out) :: RingTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Alarm}'s time to ring
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to get the ring time
+!     \item[RingTime]
+!          The {\tt ESMF\_Alarm}'s ring time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.7, TMG4.8
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmGetRingTime not supported' )
+      end subroutine ESMF_AlarmGetRingTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmSetRingTime - Set an alarm's time to ring
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmSetRingTime(alarm, RingTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_Time), intent(in) :: RingTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Alarm}'s time to ring
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to set the ring time
+!     \item[RingTime]
+!          The {\tt ESMF\_Alarm}'s ring time to set
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.5.1, TMG4.7, TMG4.8
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmSetRingTime not supported' )
+      end subroutine ESMF_AlarmSetRingTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmGet - Get an alarm's parameters -- compatibility with ESMF 2.0.1
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmGet(alarm, PrevRingTime, RingInterval, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_Time), intent(out), optional :: PrevRingTime
+      type(ESMF_TimeInterval), intent(out), optional :: RingInterval
+      integer, intent(out), optional :: rc
+      integer :: ierr
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Alarm}'s previous ring time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to get the previous ring time
+!     \item[PrevRingTime]
+!          The {\tt ESMF\_Alarm}'s previous ring time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.7, TMG4.8
+!EOP
+
+      ierr = ESMF_SUCCESS
+
+      IF ( PRESENT(PrevRingTime) ) THEN
+        CALL ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc=ierr)
+      ENDIF
+      IF ( PRESENT(RingInterval) ) THEN
+        CALL ESMF_AlarmGetRingInterval(alarm, RingInterval, rc=ierr)
+      ENDIF
+
+      IF ( PRESENT(rc) ) THEN
+        rc = ierr
+      ENDIF
+
+      end subroutine ESMF_AlarmGet
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmGetPrevRingTime - Get an alarm's previous ring time
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_Time), intent(out) :: PrevRingTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Alarm}'s previous ring time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to get the previous ring time
+!     \item[PrevRingTime]
+!          The {\tt ESMF\_Alarm}'s previous ring time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.7, TMG4.8
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        PrevRingTime = alarm%alarmint%PrevRingTime
+        IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+      end subroutine ESMF_AlarmGetPrevRingTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmSetPrevRingTime - Set an alarm's previous ring time
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmSetPrevRingTime(alarm, PrevRingTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_Time), intent(in) :: PrevRingTime
+      integer, intent(out), optional :: rc
+   
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Alarm}'s previous ring time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to set the previous ring time
+!     \item[PrevRingTime]
+!          The {\tt ESMF\_Alarm}'s previous ring time to set
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.7, TMG4.8
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmSetPrevRingTime not supported' )
+      end subroutine ESMF_AlarmSetPrevRingTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmGetStopTime - Get an alarm's stop time
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmGetStopTime(alarm, StopTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_Time), intent(out) :: StopTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Alarm}'s stop time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to get the stop time
+!     \item[StopTime]
+!          The {\tt ESMF\_Alarm}'s stop time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.5.2, TMG4.7
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmGetStopTime not supported' )
+      end subroutine ESMF_AlarmGetStopTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmSetStopTime - Set an alarm's stop time
+!
+! !INTERFACE:
+      subroutine ESMF_AlarmSetStopTime(alarm, StopTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_Time), intent(in) :: StopTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Alarm}'s stop time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to set the stop time
+!     \item[StopTime]
+!          The {\tt ESMF\_Alarm}'s stop time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.5.2, TMG4.7
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmSetStopTime not supported' )
+      end subroutine ESMF_AlarmSetStopTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmEnable - Enables an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmEnable(alarm, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Enables an {\tt ESMF\_Alarm} to function
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to enable
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.5.3
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        alarm%alarmint%Enabled = .TRUE.
+        IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+      end subroutine ESMF_AlarmEnable
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmDisable - Disables an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmDisable(alarm, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Disables an {\tt ESMF\_Alarm}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to disable
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.5.3
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        alarm%alarmint%Enabled = .FALSE.
+        IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+      end subroutine ESMF_AlarmDisable
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmRingerOn - Turn on an alarm
+
+
+! !INTERFACE:
+      subroutine ESMF_AlarmRingerOn(alarm, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      integer, intent(out), optional :: rc
+    
+! !DESCRIPTION:
+!     Turn on an {\tt ESMF\_Alarm}; sets ringing state
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to turn on
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG4.6
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        IF ( alarm%alarmint%Enabled ) THEN
+          alarm%alarmint%Ringing = .TRUE.
+          IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+        ELSE
+          alarm%alarmint%Ringing = .FALSE.
+          IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+        ENDIF
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+
+      end subroutine ESMF_AlarmRingerOn
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmRingerOff - Turn off an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmRingerOff(alarm, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      integer, intent(out), optional :: rc
+    
+! !DESCRIPTION:
+!     Turn off an {\tt ESMF\_Alarm}; unsets ringing state
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to turn off   
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.6
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        alarm%alarmint%Ringing = .FALSE.
+        IF ( alarm%alarmint%Enabled ) THEN
+          IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+        ELSE
+          IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+        ENDIF
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+      end subroutine ESMF_AlarmRingerOff
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmIsRinging - Check if alarm is ringing
+
+! !INTERFACE:
+      function ESMF_AlarmIsRinging(alarm, rc)
+!
+! !RETURN VALUE:
+      logical :: ESMF_AlarmIsRinging
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Check if {\tt ESMF\_Alarm} is ringing.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to check for ringing state  
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.4
+!EOP
+      IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+        IF ( alarm%alarmint%Enabled ) THEN
+          ESMF_AlarmIsRinging = alarm%alarmint%Ringing
+          IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+        ELSE
+          ESMF_AlarmIsRinging = .FALSE.
+          IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+        ENDIF
+      ELSE
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ENDIF
+      end function ESMF_AlarmIsRinging
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmCheckRingTime - Method used by a clock to check whether to trigger an alarm
+!
+! !INTERFACE:
+      function ESMF_AlarmCheckRingTime(alarm, ClockCurrTime, positive, rc)
+!
+! !RETURN VALUE:
+      logical :: ESMF_AlarmCheckRingTime
+!
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(inout) :: alarm
+      type(ESMF_Time), intent(in) :: ClockCurrTime
+      integer, intent(in) :: positive
+      integer, intent(out), optional :: rc
+!
+! !DESCRIPTION:
+!     Main method used by a {\tt ESMF\_Clock} to check whether to trigger
+!     the {\tt ESMF\_Alarm} 
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to check if time to ring   
+!     \item[ClockCurrTime]
+!          The {\tt ESMF\_Clock}'s current time
+!     \item[positive]
+!          Whether to check ring time in the positive or negative direction
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG4.4, TMG4.6
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmCheckRingTime not supported' )
+      ESMF_AlarmCheckRingTime = .FALSE.  ! keep compilers happy
+      end function ESMF_AlarmCheckRingTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmEQ - Compare two alarms for equality
+!
+! !INTERFACE:
+      function ESMF_AlarmEQ(alarm1, alarm2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_AlarmEQ
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm1
+      type(ESMF_Alarm), intent(in) :: alarm2
+
+! !DESCRIPTION:
+!     Compare two alarms for equality; return true if equal, false otherwise
+!     Maps to overloaded (==) operator interface function
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm1]
+!          The first {\tt ESMF\_Alarm} to compare
+!     \item[alarm2]
+!          The second {\tt ESMF\_Alarm} to compare
+!     \end{description}
+!
+! !REQUIREMENTS:  
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmEQ not supported ' )
+      ESMF_AlarmEQ = .FALSE.       ! keep compilers happy
+      end function ESMF_AlarmEQ
+
+!------------------------------------------------------------------------------
+!
+! This section defines the overridden Read, Write, Validate and Print methods
+! from the ESMF_Base class
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmRead - restores an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmRead(alarm, RingInterval, RingTime, &
+                           PrevRingTime, StopTime, Ringing, &
+                           Enabled, ID, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(out) :: alarm
+      type(ESMF_TimeInterval), intent(in) :: RingInterval
+      type(ESMF_Time), intent(in) :: RingTime
+      type(ESMF_Time), intent(in) :: PrevRingTime
+      type(ESMF_Time), intent(in) :: StopTime
+      logical, intent(in) :: Ringing
+      logical, intent(in) :: Enabled
+      integer, intent(in) :: ID
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Restores an {\tt ESMF\_Alarm}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to restore
+!     \item[RingInterval]
+!          The ring interval for repeating alarms
+!     \item[RingTime]
+!          Ring time for one-shot or first repeating alarm
+!     \item[PrevRingTime]
+!          The {\tt ESMF\_Alarm}'s previous ring time
+!     \item[StopTime]
+!          Stop time for repeating alarms
+!     \item[Ringing]
+!          The {\tt ESMF\_Alarm}'s ringing state
+!     \item[Enabled]
+!          {\tt ESMF\_Alarm} enabled/disabled
+!     \item[ID]
+!          The {\tt ESMF\_Alarm}'s ID
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmRead not supported' )
+      end subroutine ESMF_AlarmRead
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_AlarmWrite - saves an alarm
+
+! !INTERFACE:
+      subroutine ESMF_AlarmWrite(alarm, RingInterval, RingTime, &
+                            PrevRingTime, StopTime, Ringing, &
+                            Enabled, ID, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      type(ESMF_TimeInterval), intent(out) :: RingInterval
+      type(ESMF_Time), intent(out) :: RingTime
+      type(ESMF_Time), intent(out) :: PrevRingTime
+      type(ESMF_Time), intent(out) :: StopTime
+      logical, intent(out) :: Ringing
+      logical, intent(out) :: Enabled
+      integer, intent(out) :: ID
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Saves an {\tt ESMF\_Alarm}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          The object instance to save
+!     \item[RingInterval]
+!          Ring interval for repeating alarms
+!     \item[RingTime]
+!          Ring time for one-shot or first repeating alarm
+!     \item[PrevRingTime]
+!          The {\tt ESMF\_Alarm}'s previous ring time
+!     \item[StopTime]
+!          Stop time for repeating alarms
+!     \item[Ringing]
+!          The {\tt ESMF\_Alarm}'s ringing state
+!     \item[Enabled]
+!          {\tt ESMF\_Alarm} enabled/disabled
+!     \item[ID]
+!          The {\tt ESMF\_Alarm}'s ID
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmWrite not supported' )
+      end subroutine ESMF_AlarmWrite
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmValidate - Validate an Alarm's properties
+
+! !INTERFACE:
+      subroutine ESMF_AlarmValidate(alarm, opts, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      character (len=*), intent(in), optional :: opts
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Perform a validation check on a {\tt ESMF\_Alarm}'s properties
+!
+!     The arguments are:  
+!     \begin{description}
+!     \item[alarm]
+!          {\tt ESMF\_Alarm} to validate
+!     \item[{[opts]}]
+!          Validate options
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description} 
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmValidate not supported' )
+      end subroutine ESMF_AlarmValidate
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AlarmPrint - Print out an Alarm's properties
+
+! !INTERFACE:
+      subroutine ESMF_AlarmPrint(alarm, opts, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(in) :: alarm
+      character (len=*), intent(in), optional :: opts
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     To support testing/debugging, print out a {\tt ESMF\_Alarm}'s
+!     properties.
+! 
+!     The arguments are:
+!     \begin{description}
+!     \item[alarm]
+!          {\tt ESMF\_Alarm} to print out
+!     \item[{[opts]}]
+!          Print options
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+      CALL wrf_error_fatal( 'ESMF_AlarmPrint not supported' )
+      end subroutine ESMF_AlarmPrint
+
+!------------------------------------------------------------------------------
+
+      end module ESMF_AlarmMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_AlarmClock.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_AlarmClock.F90
new file mode 100644
index 00000000..bb724945
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_AlarmClock.F90
@@ -0,0 +1,96 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF Alarm-Clock Module
+      module ESMF_AlarmClockMod
+!
+!==============================================================================
+!
+! This file contains the AlarmCreate method.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include 
+
+!===============================================================================
+!BOPI
+!
+! !MODULE: ESMF_AlarmClockMod
+!
+! !DESCRIPTION:
+! Separate module that uses both ESMF_AlarmMod and ESMF_ClockMod.  
+! Separation is needed to avoid cyclic dependence.  
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ class {\tt ESMC\_Alarm}
+!
+! See {\tt ../include/ESMC\_Alarm.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit ESMF_Alarm and ESMF_Clock
+      use ESMF_AlarmMod, only : ESMF_Alarm, ESMF_AlarmSet
+      use ESMF_ClockMod, only : ESMF_Clock, ESMF_ClockAddAlarm
+
+      ! associated derived types
+      use ESMF_TimeIntervalMod, only : ESMF_TimeInterval
+      use ESMF_TimeMod,         only : ESMF_Time
+
+      implicit none
+
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+     private
+!------------------------------------------------------------------------------
+
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_AlarmCreate
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+
+
+! Create ESMF_Alarm using ESMF 2.1.0+ semantics
+      FUNCTION ESMF_AlarmCreate( clock, RingTime, RingInterval, &
+                                 StopTime, Enabled, rc )
+
+        ! return value
+        type(ESMF_Alarm) :: ESMF_AlarmCreate
+        ! !ARGUMENTS:
+        type(ESMF_Clock), intent(inout), optional :: clock
+        type(ESMF_Time), intent(in), optional :: RingTime
+        type(ESMF_TimeInterval), intent(in), optional :: RingInterval
+        type(ESMF_Time), intent(in), optional :: StopTime
+        logical, intent(in), optional :: Enabled
+        integer, intent(out), optional :: rc
+        ! locals
+        type(ESMF_Alarm) :: alarmtmp
+         ! TBH:  ignore allocate errors, for now
+        ALLOCATE( alarmtmp%alarmint )
+        CALL ESMF_AlarmSet( alarmtmp,                  &
+                            RingTime=RingTime,         &
+                            RingInterval=RingInterval, &
+                            StopTime=StopTime,         &
+                            Enabled=Enabled,           &
+                            rc=rc )
+        IF ( PRESENT ( clock ) ) THEN
+          CALL ESMF_ClockAddAlarm( clock, alarmtmp, rc )
+        ENDIF
+        ESMF_AlarmCreate = alarmtmp
+      END FUNCTION ESMF_AlarmCreate
+
+
+!------------------------------------------------------------------------------
+
+      end module ESMF_AlarmClockMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Base.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Base.F90
new file mode 100644
index 00000000..5d2ed88c
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Base.F90
@@ -0,0 +1,1082 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+! ESMF Base Module
+!
+! (all lines between the !BOP and !EOP markers will be included in the
+! automated document processing.)
+!------------------------------------------------------------------------------
+
+!------------------------------------------------------------------------------
+! module definition
+
+      module ESMF_BaseMod
+ 
+!BOP
+! !MODULE: ESMF_BaseMod - Base class for all ESMF classes
+!
+! !DESCRIPTION:
+!
+! The code in this file implements the Base defined type
+!  and functions which operate on all types.  This is an
+!  interface to the actual C++ base class implementation in the ../src dir.
+!
+! See the ESMF Developers Guide document for more details.
+!
+!------------------------------------------------------------------------------
+
+! !USES:
+      implicit none
+!
+! !PRIVATE TYPES:
+      private
+
+!------------------------------------------------------------------------------
+!
+!    Global integer parameters, used frequently
+
+      integer, parameter :: ESMF_SUCCESS = 0, ESMF_FAILURE = -1
+      integer, parameter :: ESMF_MAXSTR = 128
+      integer, parameter :: ESMF_MAXDIM = 7, &
+                            ESMF_MAXDECOMPDIM=3, &
+                            ESMF_MAXGRIDDIM=2
+     
+      integer, parameter :: ESMF_MAJOR_VERSION = 2
+      integer, parameter :: ESMF_MINOR_VERSION = 1
+      integer, parameter :: ESMF_REVISION      = 1
+      integer, parameter :: ESMF_PATCHLEVEL    = 0
+      character(32), parameter :: ESMF_VERSION_STRING = "2.1.1"
+
+!------------------------------------------------------------------------------
+!
+      type ESMF_Status
+      private
+          integer :: status
+      end type
+
+      type(ESMF_Status), parameter :: ESMF_STATE_UNINIT = ESMF_Status(1), &
+                                      ESMF_STATE_READY = ESMF_Status(2), &
+                                      ESMF_STATE_UNALLOCATED = ESMF_Status(3), &
+                                      ESMF_STATE_ALLOCATED = ESMF_Status(4), &
+                                      ESMF_STATE_BUSY = ESMF_Status(5), &
+                                      ESMF_STATE_INVALID = ESMF_Status(6)
+ 
+!------------------------------------------------------------------------------
+!
+      type ESMF_Pointer
+      private
+          integer*8 :: ptr
+      end type
+
+      type(ESMF_Pointer), parameter :: ESMF_NULL_POINTER = ESMF_Pointer(0), &
+                                       ESMF_BAD_POINTER = ESMF_Pointer(-1)
+
+
+!------------------------------------------------------------------------------
+!
+      !! TODO: I believe if we define an assignment(=) operator to convert
+      !!   a datatype into integer, then we could use the type and kind as
+      !!   targets in a select case() statement and make the contents private.
+      !!   (see pg 248 of the "big book")
+      type ESMF_DataType
+      !!private
+          integer :: dtype
+      end type
+
+      type(ESMF_DataType), parameter :: ESMF_DATA_INTEGER = ESMF_DataType(1), &
+                                        ESMF_DATA_REAL = ESMF_DataType(2), &
+                                        ESMF_DATA_LOGICAL = ESMF_DataType(3), &
+                                        ESMF_DATA_CHARACTER = ESMF_DataType(4)
+
+!------------------------------------------------------------------------------
+
+      integer, parameter :: &
+                   ESMF_KIND_I1 = selected_int_kind(2), &
+                   ESMF_KIND_I2 = selected_int_kind(4), &
+                   ESMF_KIND_I4 = selected_int_kind(9), &
+                   ESMF_KIND_I8 = selected_int_kind(18), &
+                   ESMF_KIND_R4 = selected_real_kind(3,25), &
+                   ESMF_KIND_R8 = selected_real_kind(6,45), &
+                   ESMF_KIND_C8 = selected_real_kind(3,25), &
+                   ESMF_KIND_C16 = selected_real_kind(6,45)
+
+!------------------------------------------------------------------------------
+
+      type ESMF_DataValue
+      private
+          type(ESMF_DataType) :: dt
+          integer :: rank
+          ! how do you do values of all types here ? TODO
+          ! in C++ i'd do a union w/ overloaded access funcs
+          integer :: vi
+          !integer, dimension (:), pointer :: vip
+          !real :: vr
+          !real, dimension (:), pointer :: vrp
+          !logical :: vl
+          !logical, pointer :: vlp
+          !character (len=ESMF_MAXSTR) :: vc
+          !character, pointer :: vcp
+      end type
+
+!------------------------------------------------------------------------------
+!
+      type ESMF_Attribute
+      private
+          character (len=ESMF_MAXSTR) :: attr_name
+          type (ESMF_DataType) :: attr_type
+          type (ESMF_DataValue) :: attr_value
+      end type
+
+!------------------------------------------------------------------------------
+!
+      !! TODO: this should be a shallow object, with a simple init() and
+      !!  get() function, and the contents should go back to being private.
+      type ESMF_AxisIndex
+!     !!private
+          integer :: l
+          integer :: r
+          integer :: max
+          integer :: decomp
+          integer :: gstart
+      end type
+
+      !! TODO: same comment as above.
+      type ESMF_MemIndex
+!     !!private
+          integer :: l
+          integer :: r
+          integer :: str
+          integer :: num
+      end type
+
+!------------------------------------------------------------------------------
+!
+      type ESMF_BasePointer
+      private
+          integer*8 :: base_ptr
+      end type
+
+      integer :: global_count = 0
+
+!------------------------------------------------------------------------------
+!
+!     ! WARNING: must match corresponding values in ../include/ESMC_Base.h
+      type ESMF_Logical
+      private
+          integer :: value
+      end type
+
+      type(ESMF_Logical), parameter :: ESMF_TF_UNKNOWN  = ESMF_Logical(1), &
+                                       ESMF_TF_TRUE     = ESMF_Logical(2), &
+                                       ESMF_TF_FALSE    = ESMF_Logical(3)
+
+!------------------------------------------------------------------------------
+!
+      type ESMF_Base
+      private
+         integer :: ID
+         integer :: ref_count
+         type (ESMF_Status) :: base_status
+         character (len=ESMF_MAXSTR) :: name
+     end type
+
+! !PUBLIC TYPES:
+
+      public ESMF_STATE_INVALID
+!      public ESMF_STATE_UNINIT, ESMF_STATE_READY, &
+!             ESMF_STATE_UNALLOCATED, ESMF_STATE_ALLOCATED, &
+!             ESMF_STATE_BUSY
+
+      public ESMF_DATA_INTEGER, ESMF_DATA_REAL, &
+             ESMF_DATA_LOGICAL, ESMF_DATA_CHARACTER
+
+      public ESMF_KIND_I1, ESMF_KIND_I2, ESMF_KIND_I4, ESMF_KIND_I8, & 
+             ESMF_KIND_R4, ESMF_KIND_R8, ESMF_KIND_C8, ESMF_KIND_C16
+
+      public ESMF_NULL_POINTER, ESMF_BAD_POINTER
+
+
+      public ESMF_FAILURE, ESMF_SUCCESS
+      public ESMF_MAXSTR
+      public ESMF_MAXDIM, ESMF_MAXDECOMPDIM, ESMF_MAXGRIDDIM
+     
+      public ESMF_MAJOR_VERSION, ESMF_MINOR_VERSION, ESMF_REVISION
+      public ESMF_VERSION_STRING 
+
+      public ESMF_Status, ESMF_Pointer, ESMF_DataType
+      public ESMF_DataValue, ESMF_Attribute
+!      public ESMF_MemIndex
+!      public ESMF_BasePointer
+      public ESMF_Base
+
+      public ESMF_AxisIndex, ESMF_AxisIndexGet
+!      public ESMF_AxisIndexInit
+      public ESMF_Logical
+!      public ESMF_TF_TRUE, ESMF_TF_FALSE
+
+! !PUBLIC MEMBER FUNCTIONS:
+!
+! !DESCRIPTION:
+!     The following routines apply to any type in the system.  
+!     The attribute routines can be inherited as-is.  The other
+!     routines need to be specialized by the higher level objects.
+!
+!   Base class methods
+!      public ESMF_BaseInit
+   
+!      public ESMF_BaseGetConfig
+!      public ESMF_BaseSetConfig
+
+!      public ESMF_BaseGetInstCount
+
+!      public ESMF_BaseSetID
+!      public ESMF_BaseGetID
+
+!      public ESMF_BaseSetRefCount
+!      public ESMF_BaseGetRefCount
+
+!      public ESMF_BaseSetStatus
+!      public ESMF_BaseGetStatus
+
+!   Virtual methods to be defined by derived classes
+!      public ESMF_Read
+!      public ESMF_Write
+!      public ESMF_Validate
+!      public ESMF_Print
+
+!  Attribute methods
+      public ESMF_AttributeSet
+      public ESMF_AttributeGet
+      public ESMF_AttributeGetCount
+      public ESMF_AttributeGetbyNumber
+      public ESMF_AttributeGetNameList
+      public ESMF_AttributeSetList
+      public ESMF_AttributeGetList
+      public ESMF_AttributeSetObjectList
+      public ESMF_AttributeGetObjectList
+      public ESMF_AttributeCopy
+      public ESMF_AttributeCopyAll
+ 
+!  Misc methods
+      public ESMF_SetName
+      public ESMF_GetName
+      public ESMF_SetPointer
+      public ESMF_SetNullPointer
+      public ESMF_GetPointer
+
+!  Print methods for calling by higher level print functions
+!  (they have little formatting other than the actual values)
+      public ESMF_StatusString, ESMF_DataTypeString
+
+!  Overloaded = operator functions
+      public operator(.eq.), operator(.ne.), assignment(=)
+!
+!
+!EOP
+
+!------------------------------------------------------------------------------
+
+! overload .eq. & .ne. with additional derived types so you can compare 
+!  them as if they were simple integers.
+ 
+
+interface operator (.eq.)
+ module procedure ESMF_sfeq
+ module procedure ESMF_dteq
+ module procedure ESMF_pteq
+ module procedure ESMF_tfeq
+ module procedure ESMF_aieq
+end interface
+
+interface operator (.ne.)
+ module procedure ESMF_sfne
+ module procedure ESMF_dtne
+ module procedure ESMF_ptne
+ module procedure ESMF_tfne
+ module procedure ESMF_aine
+end interface
+
+interface assignment (=)
+ module procedure ESMF_dtas
+ module procedure ESMF_ptas
+end interface
+
+!------------------------------------------------------------------------------
+
+      contains
+
+!------------------------------------------------------------------------------
+! function to compare two ESMF_Status flags to see if they're the same or not
+
+function ESMF_sfeq(sf1, sf2)
+ logical ESMF_sfeq
+ type(ESMF_Status), intent(in) :: sf1, sf2
+
+ ESMF_sfeq = (sf1%status .eq. sf2%status)
+end function
+
+function ESMF_sfne(sf1, sf2)
+ logical ESMF_sfne
+ type(ESMF_Status), intent(in) :: sf1, sf2
+
+ ESMF_sfne = (sf1%status .ne. sf2%status)
+end function
+
+!------------------------------------------------------------------------------
+! function to compare two ESMF_DataTypes to see if they're the same or not
+
+function ESMF_dteq(dt1, dt2)
+ logical ESMF_dteq
+ type(ESMF_DataType), intent(in) :: dt1, dt2
+
+ ESMF_dteq = (dt1%dtype .eq. dt2%dtype)
+end function
+
+function ESMF_dtne(dt1, dt2)
+ logical ESMF_dtne
+ type(ESMF_DataType), intent(in) :: dt1, dt2
+
+ ESMF_dtne = (dt1%dtype .ne. dt2%dtype)
+end function
+
+subroutine ESMF_dtas(intval, dtval)
+ integer, intent(out) :: intval
+ type(ESMF_DataType), intent(in) :: dtval
+
+ intval = dtval%dtype
+end subroutine
+
+
+!------------------------------------------------------------------------------
+! function to compare two ESMF_Pointers to see if they're the same or not
+
+function ESMF_pteq(pt1, pt2)
+ logical ESMF_pteq
+ type(ESMF_Pointer), intent(in) :: pt1, pt2
+
+ ESMF_pteq = (pt1%ptr .eq. pt2%ptr)
+end function
+
+function ESMF_ptne(pt1, pt2)
+ logical ESMF_ptne
+ type(ESMF_Pointer), intent(in) :: pt1, pt2
+
+ ESMF_ptne = (pt1%ptr .ne. pt2%ptr)
+end function
+
+subroutine ESMF_ptas(ptval, intval)
+ type(ESMF_Pointer), intent(out) :: ptval
+ integer, intent(in) :: intval
+
+ ptval%ptr = intval
+end subroutine
+
+!------------------------------------------------------------------------------
+! function to compare two ESMF_Logicals to see if they're the same or not
+! also need assignment to real f90 logical?
+
+function ESMF_tfeq(tf1, tf2)
+ logical ESMF_tfeq
+ type(ESMF_Logical), intent(in) :: tf1, tf2
+
+ ESMF_tfeq = (tf1%value .eq. tf2%value)
+end function
+
+function ESMF_tfne(tf1, tf2)
+ logical ESMF_tfne
+ type(ESMF_Logical), intent(in) :: tf1, tf2
+
+ ESMF_tfne = (tf1%value .ne. tf2%value)
+end function
+
+!------------------------------------------------------------------------------
+! function to compare two ESMF_AxisIndex to see if they're the same or not
+
+function ESMF_aieq(ai1, ai2)
+ logical ESMF_aieq
+ type(ESMF_AxisIndex), intent(in) :: ai1, ai2
+
+ ESMF_aieq = ((ai1%l .eq. ai2%l) .and. &
+              (ai1%r .eq. ai2%r) .and. &
+              (ai1%max .eq. ai2%max) .and. &
+              (ai1%decomp .eq. ai2%decomp) .and. &
+              (ai1%gstart .eq. ai2%gstart))
+
+end function
+
+function ESMF_aine(ai1, ai2)
+ logical ESMF_aine
+ type(ESMF_AxisIndex), intent(in) :: ai1, ai2
+
+ ESMF_aine = ((ai1%l .ne. ai2%l) .or. &
+              (ai1%r .ne. ai2%r) .or. &
+              (ai1%max .ne. ai2%max) .or. &
+              (ai1%decomp .ne. ai2%decomp) .or. &
+              (ai1%gstart .ne. ai2%gstart))
+
+end function
+
+!------------------------------------------------------------------------------
+!------------------------------------------------------------------------------
+! 
+! Base methods
+!
+!------------------------------------------------------------------------------
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_BaseInit - initialize a Base object
+!
+! !INTERFACE:
+      subroutine ESMF_BaseInit(base, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base) :: base                 
+      integer, intent(out), optional :: rc     
+
+!
+! !DESCRIPTION:
+!     Set initial state on a Base object.
+!
+!     \begin{description}
+!     \item [base]
+!           In the Fortran interface, this must in fact be a {\tt Base}
+!           derived type object.  It is expected that all specialized 
+!           derived types will include a {\tt Base} object as the first
+!           entry.
+!     \item [{[rc]}]
+!           Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!
+!     \end{description}
+!
+!EOP
+
+      logical :: rcpresent                          ! Return code present   
+
+!     !Initialize return code
+      rcpresent = .FALSE.
+      if(present(rc)) then
+        rcpresent = .TRUE.
+        rc = ESMF_FAILURE
+      endif
+
+      global_count = global_count + 1
+      base%ID = global_count
+      base%ref_count = 1
+      base%base_status = ESMF_STATE_READY
+      base%name = "undefined"
+
+      if (rcpresent) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_BaseInit
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_SetName - set the name of this object
+!
+! !INTERFACE:
+      subroutine ESMF_SetName(anytype, name, namespace, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base) :: anytype                 
+      character (len = *), intent(in), optional :: name   
+      character (len = *), intent(in), optional :: namespace
+      integer, intent(out), optional :: rc     
+
+!
+! !DESCRIPTION:
+!     Associate a name with any object in the system.
+!
+!     \begin{description}
+!     \item [anytype]
+!           In the Fortran interface, this must in fact be a {\tt Base}
+!           derived type object.  It is expected that all specialized 
+!           derived types will include a {\tt Base} object as the first
+!           entry.
+!     \item [[name]]
+!           Object name.  An error will be returned if a duplicate name 
+!           is specified.  If a name is not given a unique name will be
+!           generated and can be queried by the {\tt ESMF_GetName} routine.
+!     \item [[namespace]]
+!           Object namespace (e.g. "Application", "Component", "Grid", etc).
+!           If given, the name will be checked that it is unique within
+!           this namespace.  If not given, the generated name will be 
+!           unique within this namespace.  If namespace is not specified,
+!           a default "global" namespace will be assumed and the same rules
+!           for names will be followed.
+!     \item [[rc]]
+!           Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!
+!     \end{description}
+!
+! 
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5, FLD1.5.3
+      logical :: rcpresent                          ! Return code present   
+      character (len = ESMF_MAXSTR) :: ournamespace ! Namespace if not given
+      character (len = ESMF_MAXSTR) :: defaultname  ! Name if not given
+      integer, save :: seqnum = 0       ! HACK - generate uniq names
+                                        ! but not coordinated across procs
+
+!     !Initialize return code
+      rcpresent = .FALSE.
+      if(present(rc)) then
+        rcpresent = .TRUE.
+        rc = ESMF_FAILURE
+      endif
+
+!     ! TODO: this code should generate a unique name if a name
+!     !   is not given.  If a namespace is given, the name has to
+!     !   be unique within that namespace.  Example namespaces could
+!     !   be: Applications, Components, Fields/Bundles, Grids.
+!      
+!     ! Construct a default namespace if one is not given
+      if((.not. present(namespace)) .or. (namespace .eq. "")) then
+          ournamespace = "global"
+      else
+          ournamespace = namespace
+      endif
+!     ! Construct a default name if one is not given
+      if((.not. present(name)) .or. (name .eq. "")) then
+
+          write(defaultname, 20) trim(ournamespace), seqnum
+20        format(A,I3.3)
+          seqnum = seqnum + 1
+          anytype%name = defaultname
+      else
+          anytype%name = name
+      endif
+
+      if (rcpresent) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_SetName
+
+!-------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_GetName - get the name of this object
+!
+! !INTERFACE:
+      subroutine ESMF_GetName(anytype, name, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF object/type
+      character (len = *), intent(out) :: name           ! object/type name
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+!     Return the name of any type in the system.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5, FLD1.5.3
+
+      name = anytype%name
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_GetName
+
+
+!-------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AttributeSet - set attribute on an ESMF type
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeSet(anytype, name, value, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      character (len = *), intent(in) :: name            ! attribute name
+      type(ESMF_DataValue), intent(in) :: value              ! attribute value
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+!     Associate a (name,value) pair with any type in the system.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5, FLD1.5.3
+
+      end subroutine ESMF_AttributeSet
+
+
+!-------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_AttributeGet - get attribute from an ESMF type
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGet(anytype, name, type, value, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype           ! any ESMF type
+      character (len = *), intent(in) :: name          ! attribute name
+      type(ESMF_DataType), intent(out) :: type             ! all possible data types
+      type(ESMF_DataValue), intent(out) :: value           ! attribute value
+      integer, intent(out), optional :: rc             ! return code
+
+!
+! !DESCRIPTION:
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5.1, FLD1.5.3
+
+      end subroutine ESMF_AttributeGet
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeGetCount - get an ESMF object's number of attributes
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGetCount(anytype, count, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      integer, intent(out) :: count                      ! attribute count
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Returns number of attributes present.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.7.5
+
+      end subroutine ESMF_AttributeGetCount
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeGetbyNumber - get an ESMF object's attribute by num ber
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGetbyNumber(anytype, number, name, type, value, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      integer, intent(in) :: number                      ! attribute number
+      character (len = *), intent(in) :: name            ! attribute name
+      type(ESMF_DataType), intent(out) :: type               ! all possible data types
+      type(ESMF_DataValue), intent(out) :: value             ! attribute value
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Allows the caller to get attributes by number instead of by name.
+! This can be useful in iterating through all attributes in a loop.
+!
+!EOP
+! !REQUIREMENTS: 
+
+      end subroutine ESMF_AttributeGetbyNumber
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+!IROUTINE:  ESMF_AttributeGetNameList - get an ESMF object's attribute name list
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGetNameList(anytype, count, namelist, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      integer, intent(out) :: count                      ! attribute count
+      character (len = *), dimension (:), intent(out) :: namelist   ! attribute names
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Return a list of all attribute names without returning the values.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.7.3
+
+      end subroutine ESMF_AttributeGetNameList
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeSetList - set an ESMF object's attributes 
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeSetList(anytype, namelist, valuelist, rc)
+
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      character (len = *), dimension (:), intent(in) :: namelist    ! attribute names
+      type(ESMF_DataValue), dimension (:), intent(in) :: valuelist      ! attribute values
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Set multiple attributes on an object in one call.  Depending on what is
+! allowed by the interface, all attributes may have to have the same type.
+!
+!EOP
+! !REQUIREMENTS:  (none.  added for completeness)
+
+      end subroutine ESMF_AttributeSetList
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeGetList - get an ESMF object's attributes
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGetList(anytype, namelist, typelist, valuelist, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: anytype             ! any ESMF type
+      character (len = *), dimension (:), intent(in) :: namelist    ! attribute names
+      type(ESMF_DataType), dimension (:), intent(out) :: typelist       ! all possible data types
+      type(ESMF_DataValue), dimension (:), intent(out) :: valuelist     ! attribute values
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Get multiple attributes from an object in a single call.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.7.4
+
+      end subroutine ESMF_AttributeGetList
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeSetObjectList - set an attribute on multiple ESMF objects 
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeSetObjectList(anytypelist, name, value, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), dimension (:), intent(in) :: anytypelist     ! list of any ESMF types
+      character (len = *), intent(in) :: name            ! attribute name
+      type(ESMF_DataValue), dimension (:), intent(in) :: value          ! attribute value
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Set the same attribute on multiple objects in one call.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5.5 (pri 2)
+
+      end subroutine ESMF_AttributeSetObjectList
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+!
+! !IROUTINE:  ESMF_AttributeGetObjectList - get an attribute from multiple ESMF objects 
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeGetObjectList(anytypelist, name, typelist, valuelist, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), dimension (:), intent(in) :: anytypelist     ! list of any ESMF types
+      character (len = *), intent(in) :: name            ! attribute name
+      type(ESMF_DataType), dimension (:), intent(out) :: typelist       ! all possible data types
+      type(ESMF_DataValue), dimension (:), intent(out) :: valuelist     ! attribute values
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! Get the same attribute name from multiple objects in one call.
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5.5 (pri 2)
+
+      end subroutine ESMF_AttributeGetObjectList
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE:  ESMF_AttributeCopy - copy an attribute between two objects
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeCopy(name, source, destination, rc)
+!
+! !ARGUMENTS:
+      character (len = *), intent(in) :: name            ! attribute name
+      type(ESMF_Base), intent(in) :: source              ! any ESMF type
+      type(ESMF_Base), intent(in) :: destination         ! any ESMF type
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! The specified attribute associated with the source object is
+! copied to the destination object.  << does this assume overwriting the
+! attribute if it already exists in the output or does this require yet
+! another arg to say what to do with collisions? >>
+
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5.4
+
+      end subroutine ESMF_AttributeCopy
+
+
+!-------------------------------------------------------------------------
+!BOP
+!
+!IROUTINE:  ESMC_AttributeCopyAll - copy attributes between two objects
+
+!
+! !INTERFACE:
+      subroutine ESMF_AttributeCopyAll(source, destination, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Base), intent(in) :: source              ! any ESMF type
+      type(ESMF_Base), intent(in) :: destination         ! any ESMF type
+      integer, intent(out), optional :: rc               ! return code
+
+!
+! !DESCRIPTION:
+! All attributes associated with the source object are copied to the
+! destination object.  Some attributes will have to be considered
+! {\tt read only} and won't be updated by this call.  (e.g. an attribute
+! like {\tt name} must be unique and therefore can't be duplicated.)
+
+!
+!EOP
+! !REQUIREMENTS:  FLD1.5.4
+
+      end subroutine ESMF_AttributeCopyAll
+
+!=========================================================================
+! Misc utility routines, perhaps belongs in a utility file?
+!-------------------------------------------------------------------------
+!BOP
+!
+!IROUTINE:  ESMC_AxisIndexInit - initialize an AxisIndex object
+
+!
+! !INTERFACE:
+      subroutine ESMF_AxisIndexInit(ai, l, r, max, decomp, gstart, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_AxisIndex), intent(inout) :: ai
+      integer, intent(in) :: l, r, max, decomp, gstart
+      integer, intent(out), optional :: rc  
+!
+! !DESCRIPTION:
+!   Set the contents of an AxisIndex type.
+
+!
+!EOP
+! !REQUIREMENTS:
+
+      ai%l = l
+      ai%r = r
+      ai%max = max
+      ai%decomp = decomp
+      ai%gstart = gstart
+
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_AxisIndexInit
+
+!BOP
+!
+!IROUTINE:  ESMC_AxisIndexInit - initialize an AxisIndex object
+
+!
+! !INTERFACE:
+      subroutine ESMF_AxisIndexGet(ai, l, r, max, decomp, gstart, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_AxisIndex), intent(inout) :: ai
+      integer, intent(out), optional :: l, r, max, decomp, gstart
+      integer, intent(out), optional :: rc  
+!
+! !DESCRIPTION:
+!   Get the contents of an AxisIndex type.
+
+!
+!EOP
+! !REQUIREMENTS:
+
+      if (present(l)) l = ai%l
+      if (present(r)) r = ai%r
+      if (present(max)) max = ai%max
+      if (present(decomp)) decomp = ai%decomp
+      if (present(gstart)) gstart = ai%gstart
+
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_AxisIndexGet
+
+!-------------------------------------------------------------------------
+!-------------------------------------------------------------------------
+!BOP
+!
+!IROUTINE:  ESMF_SetPointer - set an opaque value
+
+!
+! !INTERFACE:
+      subroutine ESMF_SetPointer(ptype, contents, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Pointer) :: ptype 
+      integer*8, intent(in) :: contents
+      integer, intent(out), optional :: rc  
+
+!
+! !DESCRIPTION:
+!   Set the contents of an opaque pointer type.
+
+!
+!EOP
+! !REQUIREMENTS:
+      ptype%ptr = contents
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_SetPointer
+
+!-------------------------------------------------------------------------
+!BOP
+!
+!IROUTINE:  ESMF_SetNullPointer - set an opaque value
+
+!
+! !INTERFACE:
+      subroutine ESMF_SetNullPointer(ptype, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Pointer) :: ptype 
+      integer, intent(out), optional :: rc  
+
+!
+! !DESCRIPTION:
+!   Set the contents of an opaque pointer type.
+
+!
+!EOP
+! !REQUIREMENTS:
+      integer*8, parameter :: nullp = 0
+
+      ptype%ptr = nullp
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_SetNullPointer
+!------------------------------------------------------------------------- 
+!BOP 
+!  !IROUTINE:  ESMF_GetPointer - get an opaque value 
+!  
+! !INTERFACE: 
+      function ESMF_GetPointer(ptype, rc) 
+!
+! !RETURN VALUE:
+      integer*8 :: ESMF_GetPointer
+
+! !ARGUMENTS:
+      type(ESMF_Pointer), intent(in) :: ptype 
+      integer, intent(out), optional :: rc  
+
+!
+! !DESCRIPTION:
+!   Get the contents of an opaque pointer type.
+
+!
+!EOP
+! !REQUIREMENTS:
+      ESMF_GetPointer = ptype%ptr
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end function ESMF_GetPointer
+
+!------------------------------------------------------------------------- 
+! misc print routines
+!------------------------------------------------------------------------- 
+!BOP 
+!  !IROUTINE:  ESMF_StatusString - Return status as a string
+!  
+! !INTERFACE: 
+      subroutine ESMF_StatusString(status, string, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Status), intent(in) :: status
+      character(len=*), intent(out) :: string
+      integer, intent(out), optional :: rc  
+
+!
+! !DESCRIPTION:
+!   Return a status variable as a string.
+
+!
+!EOP
+! !REQUIREMENTS:
+
+      if (status .eq. ESMF_STATE_UNINIT) string = "Uninitialized"
+      if (status .eq. ESMF_STATE_READY) string = "Ready"
+      if (status .eq. ESMF_STATE_UNALLOCATED) string = "Unallocated"
+      if (status .eq. ESMF_STATE_ALLOCATED) string = "Allocated"
+      if (status .eq. ESMF_STATE_BUSY) string = "Busy"
+      if (status .eq. ESMF_STATE_INVALID) string = "Invalid"
+ 
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_StatusString
+
+!------------------------------------------------------------------------- 
+!BOP 
+!  !IROUTINE:  ESMF_DataTypeString - Return DataType as a string
+!  
+! !INTERFACE: 
+      subroutine ESMF_DataTypeString(datatype, string, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_DataType), intent(in) :: datatype
+      character(len=*), intent(out) :: string
+      integer, intent(out), optional :: rc  
+
+!
+! !DESCRIPTION:
+!   Return a datatype variable as a string.
+
+!
+!EOP
+! !REQUIREMENTS:
+
+      if (datatype .eq. ESMF_DATA_INTEGER) string = "Integer"
+      if (datatype .eq. ESMF_DATA_REAL) string = "Real"
+      if (datatype .eq. ESMF_DATA_LOGICAL) string = "Logical"
+      if (datatype .eq. ESMF_DATA_CHARACTER) string = "Character"
+ 
+      if (present(rc)) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_DataTypeString
+
+!-------------------------------------------------------------------------
+!
+!-------------------------------------------------------------------------
+! put Print and Validate skeletons here - but they should be
+!  overridden by higher level more specialized functions.
+!-------------------------------------------------------------------------
+
+      end module ESMF_BaseMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_BaseTime.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_BaseTime.F90
new file mode 100644
index 00000000..618548e0
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_BaseTime.F90
@@ -0,0 +1,318 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF BaseTime Module
+      module ESMF_BaseTimeMod
+!
+!==============================================================================
+!
+! This file contains the BaseTime class definition and all BaseTime class
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+
+#include 
+!
+!===============================================================================
+!BOPI
+! !MODULE: ESMF_BaseTimeMod - Base ESMF time definition 
+!
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! This module serves only as the common Time definition inherited
+! by {\tt ESMF\_TimeInterval} and {\tt ESMF\_Time}
+!
+! See {\tt ../include/ESMC\_BaseTime.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      use ESMF_BaseMod    ! ESMF Base class
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+!     ! ESMF_BaseTime
+!
+!     ! Base class type to match C++ BaseTime class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+
+      type ESMF_BaseTime
+        integer(ESMF_KIND_I8) :: S   ! whole seconds
+        integer(ESMF_KIND_I8) :: Sn  ! fractional seconds, numerator
+        integer(ESMF_KIND_I8) :: Sd  ! fractional seconds, denominator
+      end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_BaseTime
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+!
+! overloaded operators
+      public operator(+)
+      private ESMF_BaseTimeSum
+      public operator(-)
+      private ESMF_BaseTimeDifference
+      public operator(/)
+      private ESMF_BaseTimeQuotI
+      private ESMF_BaseTimeQuotI8
+      public operator(.EQ.)
+      private ESMF_BaseTimeEQ
+      public operator(.NE.)
+      private ESMF_BaseTimeNE
+      public operator(.LT.)
+      private ESMF_BaseTimeLT
+      public operator(.GT.)
+      private ESMF_BaseTimeGT
+      public operator(.LE.)
+      private ESMF_BaseTimeLE
+      public operator(.GE.)
+      private ESMF_BaseTimeGE
+
+!==============================================================================
+!
+! INTERFACE BLOCKS
+!
+!==============================================================================
+      interface operator(+)
+        module procedure ESMF_BaseTimeSum
+      end interface
+      interface operator(-)
+        module procedure ESMF_BaseTimeDifference
+      end interface
+      interface operator(/)
+        module procedure ESMF_BaseTimeQuotI,ESMF_BaseTimeQuotI8
+      end interface
+      interface operator(.EQ.)
+        module procedure ESMF_BaseTimeEQ
+      end interface
+      interface operator(.NE.)
+        module procedure ESMF_BaseTimeNE
+      end interface
+      interface operator(.LT.)
+        module procedure ESMF_BaseTimeLT
+      end interface
+      interface operator(.GT.)
+        module procedure ESMF_BaseTimeGT
+      end interface
+      interface operator(.LE.)
+        module procedure ESMF_BaseTimeLE
+      end interface
+      interface operator(.GE.)
+        module procedure ESMF_BaseTimeGE
+      end interface
+
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+
+
+! Add two basetimes
+      FUNCTION ESMF_BaseTimeSum( basetime1, basetime2 )
+        TYPE(ESMF_BaseTime) :: ESMF_BaseTimeSum
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        ! locals
+        INTEGER (ESMF_KIND_I8) :: Sn1, Sd1, Sn2, Sd2, lcd
+!  PRINT *,'DEBUG:  BEGIN ESMF_BaseTimeSum()'
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime1%S = ',basetime1%S
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime1%Sn = ',basetime1%Sn
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime1%Sd = ',basetime1%Sd
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime2%S = ',basetime2%S
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime2%Sn = ',basetime2%Sn
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  basetime2%Sd = ',basetime2%Sd
+        ESMF_BaseTimeSum   = basetime1
+        ESMF_BaseTimeSum%S = ESMF_BaseTimeSum%S + basetime2%S
+        Sn1 = basetime1%Sn
+        Sd1 = basetime1%Sd
+        Sn2 = basetime2%Sn
+        Sd2 = basetime2%Sd
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  Sn1 = ',Sn1
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  Sd1 = ',Sd1
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  Sn2 = ',Sn2
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  Sd2 = ',Sd2
+        IF      ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  no fractions'
+          ESMF_BaseTimeSum%Sn = 0
+          ESMF_BaseTimeSum%Sd = 0
+        ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN
+          ESMF_BaseTimeSum%Sn = Sn1
+          ESMF_BaseTimeSum%Sd = Sd1
+        ELSE IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN
+          ESMF_BaseTimeSum%Sn = Sn2
+          ESMF_BaseTimeSum%Sd = Sd2
+        ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN
+          CALL compute_lcd( Sd1 , Sd2 , lcd )
+          ESMF_BaseTimeSum%Sd = lcd
+          ESMF_BaseTimeSum%Sn = (Sn1 * lcd / Sd1) + (Sn2 * lcd / Sd2)
+        ENDIF
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  ESMF_BaseTimeSum%S = ',ESMF_BaseTimeSum%S
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  ESMF_BaseTimeSum%Sn = ',ESMF_BaseTimeSum%Sn
+!  PRINT *,'DEBUG:  ESMF_BaseTimeSum():  ESMF_BaseTimeSum%Sd = ',ESMF_BaseTimeSum%Sd
+        CALL normalize_basetime( ESMF_BaseTimeSum )
+!  PRINT *,'DEBUG:  END ESMF_BaseTimeSum()'
+      END FUNCTION ESMF_BaseTimeSum
+
+
+! Subtract two basetimes
+      FUNCTION ESMF_BaseTimeDifference( basetime1, basetime2 )
+        TYPE(ESMF_BaseTime) :: ESMF_BaseTimeDifference
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        ! locals
+        TYPE(ESMF_BaseTime) :: neg2
+
+        neg2%S  = -basetime2%S
+        neg2%Sn = -basetime2%Sn
+        neg2%Sd =  basetime2%Sd
+
+        ESMF_BaseTimeDifference = basetime1 + neg2
+
+      END FUNCTION ESMF_BaseTimeDifference
+
+
+! Divide basetime by 8-byte integer
+      FUNCTION ESMF_BaseTimeQuotI8( basetime, divisor )
+        TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI8
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime
+        INTEGER(ESMF_KIND_I8), INTENT(IN) :: divisor
+        ! locals
+        INTEGER(ESMF_KIND_I8) :: d, n, dinit
+
+!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A:  S,Sn,Sd = ', &
+!  basetime%S,basetime%Sn,basetime%Sd
+!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A:  divisor = ', divisor
+        IF ( divisor == 0_ESMF_KIND_I8 ) THEN
+          CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI8:  divide by zero' )
+        ENDIF
+
+!$$$ move to default constructor
+        ESMF_BaseTimeQuotI8%S  = 0
+        ESMF_BaseTimeQuotI8%Sn = 0
+        ESMF_BaseTimeQuotI8%Sd = 0
+
+        ! convert to a fraction and divide by multipling the denonminator by 
+        ! the divisor
+        IF ( basetime%Sd == 0 ) THEN
+          dinit = 1_ESMF_KIND_I8
+        ELSE
+          dinit = basetime%Sd
+        ENDIF
+        n = basetime%S * dinit + basetime%Sn
+        d = dinit * divisor
+!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() B:  n,d = ',n,d
+        CALL simplify( n, d, ESMF_BaseTimeQuotI8%Sn, ESMF_BaseTimeQuotI8%Sd )
+!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() C:  S,Sn,Sd = ', &
+!  ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd
+        CALL normalize_basetime( ESMF_BaseTimeQuotI8 )
+!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() D:  S,Sn,Sd = ', &
+!  ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd
+      END FUNCTION ESMF_BaseTimeQuotI8
+
+! Divide basetime by integer
+      FUNCTION ESMF_BaseTimeQuotI( basetime, divisor )
+        TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime
+        INTEGER, INTENT(IN) :: divisor
+        IF ( divisor == 0 ) THEN
+          CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI:  divide by zero' )
+        ENDIF
+        ESMF_BaseTimeQuotI = basetime / INT( divisor, ESMF_KIND_I8 )
+      END FUNCTION ESMF_BaseTimeQuotI
+
+
+! .EQ. for two basetimes
+      FUNCTION ESMF_BaseTimeEQ( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeEQ
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeEQ = ( retval .EQ. 0 )
+      END FUNCTION ESMF_BaseTimeEQ
+
+
+! .NE. for two basetimes
+      FUNCTION ESMF_BaseTimeNE( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeNE
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeNE = ( retval .NE. 0 )
+      END FUNCTION ESMF_BaseTimeNE
+
+
+! .LT. for two basetimes
+      FUNCTION ESMF_BaseTimeLT( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeLT
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeLT = ( retval .LT. 0 )
+      END FUNCTION ESMF_BaseTimeLT
+
+
+! .GT. for two basetimes
+      FUNCTION ESMF_BaseTimeGT( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeGT
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeGT = ( retval .GT. 0 )
+      END FUNCTION ESMF_BaseTimeGT
+
+
+! .LE. for two basetimes
+      FUNCTION ESMF_BaseTimeLE( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeLE
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeLE = ( retval .LE. 0 )
+      END FUNCTION ESMF_BaseTimeLE
+
+
+! .GE. for two basetimes
+      FUNCTION ESMF_BaseTimeGE( basetime1, basetime2 )
+        LOGICAL :: ESMF_BaseTimeGE
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1
+        TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2
+        INTEGER :: retval
+        CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, &
+                     basetime2%S, basetime2%Sn, basetime2%Sd, &
+                     retval )
+        ESMF_BaseTimeGE = ( retval .GE. 0 )
+      END FUNCTION ESMF_BaseTimeGE
+
+
+      end module ESMF_BaseTimeMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Calendar.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Calendar.F90
new file mode 100644
index 00000000..6e5388c8
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Calendar.F90
@@ -0,0 +1,284 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF Calendar Module
+      module ESMF_CalendarMod
+!
+!==============================================================================
+!
+! This file contains the Calendar class definition and all Calendar class
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include 
+
+!==============================================================================
+!BOPI
+! !MODULE: ESMF_CalendarMod
+!
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ class { \tt ESMC\_Calendar} implementation
+!
+! See {\tt ../include/ESMC\_Calendar.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit from ESMF base class
+      use ESMF_BaseMod
+
+      ! inherit from base time class
+      use ESMF_BaseTimeMod
+
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+
+
+
+      INTEGER, PARAMETER :: MONTHS_PER_YEAR = 12
+      INTEGER, PARAMETER :: mday(MONTHS_PER_YEAR)   &
+                          = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+      INTEGER, PARAMETER :: mdayleap(MONTHS_PER_YEAR) &
+                          = (/31,29,31,30,31,30,31,31,30,31,30,31/)
+      INTEGER, DIMENSION(365) :: daym
+      INTEGER, DIMENSION(366) :: daymleap
+      INTEGER :: mdaycum(0:MONTHS_PER_YEAR)
+      INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR)
+      TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR)
+      TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR)
+
+
+!------------------------------------------------------------------------------
+!     ! ESMF_CalendarType
+!
+!     ! F90 "enum" type to match C++ ESMC_CalendarType enum
+
+      type ESMF_CalendarType
+      private
+        integer :: caltype
+      end type
+
+      type(ESMF_CalendarType), parameter :: &
+                               ESMF_CAL_GREGORIAN =  ESMF_CalendarType(1), &
+                               ESMF_CAL_JULIAN =     ESMF_CalendarType(2), &
+                           ! like Gregorian, except Feb always has 28 days
+                               ESMF_CAL_NOLEAP =     ESMF_CalendarType(3), & 
+                           ! 12 months, 30 days each
+                               ESMF_CAL_360DAY =     ESMF_CalendarType(4), & 
+                           ! user defined
+                               ESMF_CAL_GENERIC =    ESMF_CalendarType(5), &
+                           ! track base time seconds only
+                               ESMF_CAL_NOCALENDAR = ESMF_CalendarType(6)
+
+!------------------------------------------------------------------------------
+!     ! ESMF_Calendar
+!
+!     ! F90 class type to match C++ Calendar class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+!
+!------------------------------------------------------------------------------
+!
+!     ! ESMF_DaysPerYear
+!
+      type ESMF_DaysPerYear
+      private
+        integer :: D        ! whole days per year
+! Fractional days-per-year are not yet used in this implementation.  
+!        integer :: Dn       ! fractional days per year numerator
+!        integer :: Dd       ! fractional days per year denominator
+      end type              ! e.g. for Venus, D=0, Dn=926, Dd=1000
+!
+!------------------------------------------------------------------------------
+!     ! ESMF_Calendar
+!
+!
+      type ESMF_Calendar
+      private
+        type(ESMF_CalendarType) :: Type
+! TBH:  When NO_DT_COMPONENT_INIT is set, code that uses F95 compile-time 
+! TBH:  initialization of components of derived types is not included.  
+! TBH:  Some older compilers, like PGI 5.x do not support this F95 feature.  
+#ifdef NO_DT_COMPONENT_INIT
+        logical :: Set
+#else
+        logical :: Set = .false.
+#endif
+        integer, dimension(MONTHS_PER_YEAR) :: DaysPerMonth
+        integer :: SecondsPerDay
+        integer :: SecondsPerYear
+        type(ESMF_DaysPerYear) :: DaysPerYear
+      end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC DATA:
+   TYPE(ESMF_Calendar), public, save, pointer :: defaultCal   ! Default Calendar
+
+
+!
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public MONTHS_PER_YEAR
+      public mday
+      public mdayleap
+      public monthbdys
+      public monthbdysleap
+      public daym
+      public daymleap
+      public mdaycum
+      public mdayleapcum
+      public ESMF_CalendarType
+      public ESMF_CAL_GREGORIAN, ESMF_CAL_NOLEAP, &
+             ESMF_CAL_360DAY, ESMF_CAL_NOCALENDAR
+!      public ESMF_CAL_JULIAN
+!      public ESMF_CAL_GENERIC
+      public ESMF_Calendar
+
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_CalendarCreate
+
+! Required inherited and overridden ESMF_Base class methods
+
+      public ESMF_CalendarInitialized ! Only in this implementation, intended
+                                      ! to be private within ESMF methods
+!EOPI
+
+!==============================================================================
+
+      contains
+
+
+!==============================================================================
+!BOP
+! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type
+
+! !INTERFACE:
+      ! Private name; call using ESMF_CalendarCreate()
+      function ESMF_CalendarCreate(name, calendartype, rc)
+
+! !RETURN VALUE:
+      type(ESMF_Calendar) :: ESMF_CalendarCreate
+
+! !ARGUMENTS:
+      character (len=*),       intent(in),  optional :: name
+      type(ESMF_CalendarType), intent(in)            :: calendartype
+      integer,                 intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Creates and sets a {\tt calendar} to the given built-in
+!     {\tt ESMF\_CalendarType}. 
+!
+!     This is a private method; invoke via the public overloaded entry point
+!     {\tt ESMF\_CalendarCreate()}.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[{[name]}]
+!          The name for the newly created calendar.  If not specified, a
+!          default unique name will be generated: "CalendarNNN" where NNN
+!          is a unique sequence number from 001 to 999.
+!     \item[calendartype]
+!          The built-in {\tt ESMF\_CalendarType}.  Valid values are:
+!            {\tt ESMF\_CAL\_360DAY}, {\tt ESMF\_CAL\_GREGORIAN},
+!            {\tt ESMF\_CAL\_JULIANDAY}, {\tt ESMF\_CAL\_NOCALENDAR}, and
+!            {\tt ESMF\_CAL\_NOLEAP}.
+!          See the "Time Manager Reference" document for a description of
+!          each calendar type.
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!    
+!EOP
+! !REQUIREMENTS:
+!     TMGn.n.n
+      type(ESMF_DaysPerYear) :: dayspy
+
+      if ( present(rc) ) rc = ESMF_FAILURE
+! Calendar type is hard-coded.  Use ESMF library if more flexibility is 
+! needed.  
+#ifdef NO_LEAP_CALENDAR
+      if ( calendartype%caltype  /= ESMF_CAL_NOLEAP%caltype ) then
+         write(6,*) 'Not a valid calendar type for this implementation'
+         write(6,*) 'This implementation only allows ESMF_CAL_NOLEAP'
+         write(6,*) 'calender type set to     = ', calendartype%caltype
+         write(6,*) 'NO_LEAP calendar type is = ', ESMF_CAL_NOLEAP%caltype
+         return
+      end if
+      ESMF_CalendarCreate%Type = ESMF_CAL_NOLEAP
+#else
+      if ( calendartype%caltype  /= ESMF_CAL_GREGORIAN%caltype ) then
+         write(6,*) 'Not a valid calendar type for this implementation'
+         write(6,*) 'This implementation only allows ESMF_CAL_GREGORIAN'
+         write(6,*) 'calender type set to     = ', calendartype%caltype
+         write(6,*) 'GREGORIAN calendar type is = ', ESMF_CAL_GREGORIAN%caltype
+         return
+      end if
+      ESMF_CalendarCreate%Type = ESMF_CAL_GREGORIAN
+#endif
+! This is a bug on some systems -- need initial value set by compiler at 
+! startup.  
+! However, note that some older compilers do not support compile-time 
+! initialization of data members of Fortran derived data types.  For example, 
+! PGI 5.x compilers do not support this F95 feature.  See 
+! NO_DT_COMPONENT_INIT.  
+      ESMF_CalendarCreate%Set = .true.
+      ESMF_CalendarCreate%SecondsPerDay = SECONDS_PER_DAY
+! DaysPerYear and SecondsPerYear are incorrect for Gregorian calendars...  
+      dayspy%D = size(daym)
+!TBH:  TODO:  Replace DaysPerYear and SecondsPerYear with methods 
+!TBH:  TODO:  since they only make sense for the NO_LEAP calendar!  
+      ESMF_CalendarCreate%DaysPerYear = dayspy
+      ESMF_CalendarCreate%SecondsPerYear = ESMF_CalendarCreate%SecondsPerDay &
+                                       * dayspy%D
+!TBH:  TODO:  use mdayleap for leap-year calendar
+      ESMF_CalendarCreate%DaysPerMonth(:) = mday(:)
+
+      if ( present(rc) ) rc = ESMF_SUCCESS
+
+      end function ESMF_CalendarCreate
+
+
+!==============================================================================
+!BOP
+! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created
+
+! !INTERFACE:
+      function ESMF_CalendarInitialized(calendar)
+
+! !RETURN VALUE:
+      logical ESMF_CalendarInitialized
+
+! !ARGUMENTS:
+      type(ESMF_Calendar), intent(in)            :: calendar
+
+! !DESCRIPTION:
+!EOP
+! !REQUIREMENTS:
+!     TMGn.n.n
+! Note that return value from this function will be bogus for older compilers 
+! that do not support compile-time initialization of data members of Fortran 
+! derived data types.  For example, PGI 5.x compilers do not support this F95 
+! feature.  At the moment, the call to this fuction is #ifdefd out when the 
+! leap-year calendar is used so this is not an issue for WRF (see 
+! NO_DT_COMPONENT_INIT).  
+        ESMF_CalendarInitialized = calendar%set
+
+     end function ESMF_CalendarInitialized
+
+      end module ESMF_CalendarMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Clock.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Clock.F90
new file mode 100644
index 00000000..20877274
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Clock.F90
@@ -0,0 +1,1337 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF Clock Module
+      module ESMF_ClockMod
+!     
+!==============================================================================
+!     
+! This file contains the Clock class definition and all Clock class methods.
+!     
+!------------------------------------------------------------------------------
+! INCLUDES
+#include  
+
+!==============================================================================
+!BOPI
+! !MODULE: ESMF_ClockMod
+!     
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ class {\tt ESMC\_Time} implementation
+!     
+! See {\tt ../include/ESMC\_Clock.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit from ESMF base class
+      use ESMF_BaseMod
+
+      ! associated derived types
+      use ESMF_TimeIntervalMod   ! , only : ESMF_TimeInterval, &
+                                 !          ESMF_TimeIntervalIsPositive
+      use ESMF_TimeMod           ! , only : ESMF_Time
+      use ESMF_AlarmMod,        only : ESMF_Alarm
+
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+!     ! ESMF_Clock
+!     
+!     ! F90 class type to match C++ Clock class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+
+! internals for ESMF_Clock
+      type ESMF_ClockInt
+        type(ESMF_TimeInterval) :: TimeStep
+        type(ESMF_Time)  :: StartTime
+        type(ESMF_Time)  :: StopTime
+        type(ESMF_Time)  :: RefTime
+        type(ESMF_Time)  :: CurrTime
+        type(ESMF_Time)  :: PrevTime
+        integer(ESMF_KIND_I8) :: AdvanceCount
+        integer :: ClockMutex
+        integer :: NumAlarms
+        ! Note:  to mimic ESMF 2.1.0+, AlarmList is maintained 
+        ! within ESMF_Clock even though copies of each alarm are 
+        ! returned from ESMF_AlarmCreate() at the same time they 
+        ! are copied into the AlarmList!  This duplication is not 
+        ! as hideous as it might be because the ESMF_Alarm type 
+        ! has data members that are all POINTERs (thus the horrible 
+        ! shallow-copy-masquerading-as-reference-copy hack works).  
+        type(ESMF_Alarm), pointer, dimension(:) :: AlarmList
+      end type
+
+! Actual public type:  this bit allows easy mimic of "deep" ESMF_ClockCreate 
+! in ESMF 2.1.0+
+! NOTE:  DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE.  It emulates ESMF 
+!        shallow-copy-masquerading-as-reference-copy.  
+      type ESMF_Clock
+        type(ESMF_ClockInt), pointer  :: clockint
+      end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_Clock
+      public ESMF_ClockInt   ! needed on AIX but not PGI
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_ClockCreate
+      public ESMF_ClockDestroy
+      public ESMF_ClockSet
+!      public ESMF_ClockSetOLD
+      public ESMF_ClockGet
+!      public ESMF_ClockGetAdvanceCount
+!      public ESMF_ClockGetTimeStep
+!      public ESMF_ClockSetTimeStep
+!      public ESMF_ClockGetCurrTime
+!      public ESMF_ClockSetCurrTime
+!      public ESMF_ClockGetStartTime
+!      public ESMF_ClockGetStopTime
+!      public ESMF_ClockGetRefTime
+!      public ESMF_ClockGetPrevTime
+!      public ESMF_ClockGetCurrSimTime
+!      public ESMF_ClockGetPrevSimTime
+! This must be public for ESMF_AlarmClockMod...  
+      public ESMF_ClockAddAlarm
+      public ESMF_ClockGetAlarmList
+!      public ESMF_ClockGetNumAlarms
+!      public ESMF_ClockSyncToWallClock
+      public ESMF_ClockAdvance
+      public ESMF_ClockIsStopTime
+      public ESMF_ClockStopTimeDisable
+
+! Required inherited and overridden ESMF_Base class methods
+
+!      public ESMF_ClockRead
+!      public ESMF_ClockWrite
+      public ESMF_ClockValidate
+      public ESMF_ClockPrint
+!EOPI
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+!
+! This section includes the Set methods.
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockSetOLD - Initialize a clockint
+
+! !INTERFACE:
+      subroutine ESMF_ClockSetOLD(clockint, TimeStep, StartTime, &
+                                  StopTime, RefTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_ClockInt), intent(out) :: clockint
+      type(ESMF_TimeInterval), intent(in), optional :: TimeStep
+      type(ESMF_Time), intent(in) :: StartTime
+      type(ESMF_Time), intent(in) :: StopTime
+      type(ESMF_Time), intent(in), optional :: RefTime
+      integer, intent(out), optional :: rc
+! Local
+      integer i
+    
+! !DESCRIPTION:
+!     Initialize an {\tt ESMF\_Clock}
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[clockint]
+!          The object instance to initialize
+!     \item[{[TimeStep]}]
+!          The {\tt ESMF\_Clock}'s time step interval
+!     \item[StartTime]
+!          The {\tt ESMF\_Clock}'s starting time
+!     \item[StopTime]
+!          The {\tt ESMF\_Clock}'s stopping time
+!     \item[{[RefTime]}]
+!          The {\tt ESMF\_Clock}'s reference time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!     
+! !REQUIREMENTS:
+!     TMG3.1, TMG3.4.4
+!EOP
+      IF ( PRESENT(TimeStep) ) clockint%TimeStep = TimeStep
+      IF ( PRESENT(RefTime) )THEN
+         clockint%RefTime = RefTime
+      ELSE
+         clockint%RefTime = StartTime
+      END IF
+      clockint%CurrTime = StartTime
+      clockint%StartTime = StartTime
+      clockint%StopTime = StopTime
+      clockint%NumAlarms = 0
+      clockint%AdvanceCount = 0
+      ALLOCATE(clockint%AlarmList(MAX_ALARMS))
+      ! TBH:  This incredible hack can be removed once ESMF_*Validate() 
+      ! TBH:  can tell if a deep ESMF_* was created or not.  
+      DO i = 1, MAX_ALARMS
+        NULLIFY( clockint%AlarmList( i )%alarmint )
+      ENDDO
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockSetOLD
+
+
+! !IROUTINE: ESMF_ClockSet - Set clock properties -- for compatibility with ESMF 2.0.1
+
+! !INTERFACE:
+      subroutine ESMF_ClockSet(clock, TimeStep, StartTime, StopTime, &
+                               RefTime, CurrTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(inout) :: clock
+      type(ESMF_TimeInterval), intent(in), optional :: TimeStep
+      type(ESMF_Time), intent(in), optional :: StartTime
+      type(ESMF_Time), intent(in), optional :: StopTime
+      type(ESMF_Time), intent(in), optional :: RefTime
+      type(ESMF_Time), intent(in), optional :: CurrTime
+      integer, intent(out), optional :: rc
+! Local
+      integer ierr
+    
+! !DESCRIPTION:
+!     Initialize an {\tt ESMF\_Clock}
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to initialize
+!     \item[{[TimeStep]}]
+!          The {\tt ESMF\_Clock}'s time step interval
+!     \item[StartTime]
+!          The {\tt ESMF\_Clock}'s starting time
+!     \item[StopTime]
+!          The {\tt ESMF\_Clock}'s stopping time
+!     \item[{[RefTime]}]
+!          The {\tt ESMF\_Clock}'s reference time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!     
+! !REQUIREMENTS:
+!     TMG3.1, TMG3.4.4
+!EOP
+      ierr = ESMF_SUCCESS
+      IF ( PRESENT(TimeStep) ) THEN
+        CALL ESMF_ClockSetTimeStep ( clock, TimeStep, rc=ierr )
+      ENDIF
+      IF ( PRESENT(RefTime) ) clock%clockint%RefTime = RefTime
+      IF ( PRESENT(StartTime) ) clock%clockint%StartTime = StartTime
+      IF ( PRESENT(StopTime) ) clock%clockint%StopTime = StopTime
+      IF ( PRESENT(CurrTime) ) THEN
+        CALL ESMF_ClockSetCurrTime(clock, CurrTime, rc=ierr)
+      ENDIF
+      IF ( PRESENT(rc) ) rc = ierr
+
+      end subroutine ESMF_ClockSet
+
+
+! Create ESMF_Clock using ESMF 2.1.0+ semantics
+      FUNCTION ESMF_ClockCreate( name, TimeStep, StartTime, StopTime, &
+                                 RefTime, rc )
+        ! return value
+        type(ESMF_Clock) :: ESMF_ClockCreate
+        ! !ARGUMENTS:
+        character (len=*),       intent(in),  optional :: name
+        type(ESMF_TimeInterval), intent(in), optional :: TimeStep
+        type(ESMF_Time), intent(in) :: StartTime
+        type(ESMF_Time), intent(in) :: StopTime
+        type(ESMF_Time), intent(in), optional :: RefTime
+        integer, intent(out), optional :: rc
+        ! locals
+        type(ESMF_Clock) :: clocktmp
+         ! TBH:  ignore allocate errors, for now
+        ALLOCATE( clocktmp%clockint )
+        CALL ESMF_ClockSetOLD( clocktmp%clockint,   &
+                               TimeStep= TimeStep,  &
+                               StartTime=StartTime, &
+                               StopTime= StopTime,  &
+                               RefTime=RefTime, rc=rc )
+        ESMF_ClockCreate = clocktmp
+      END FUNCTION ESMF_ClockCreate
+
+
+! Deallocate memory for ESMF_Clock
+      SUBROUTINE ESMF_ClockDestroy( clock, rc )
+         TYPE(ESMF_Clock), INTENT(INOUT) :: clock
+         INTEGER,          INTENT(  OUT), OPTIONAL :: rc
+         ! TBH:  ignore deallocate errors, for now
+         DEALLOCATE( clock%clockint%AlarmList )
+         DEALLOCATE( clock%clockint )
+         IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      END SUBROUTINE ESMF_ClockDestroy
+
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGet - Get clock properties -- for compatibility with ESMF 2.0.1 
+
+! !INTERFACE:
+      subroutine ESMF_ClockGet(clock, StartTime, CurrTime,       &
+                               AdvanceCount, StopTime, TimeStep, &
+                               PrevTime, RefTime, &
+                               rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out), optional :: StartTime
+      type(ESMF_Time), intent(out), optional :: CurrTime
+      type(ESMF_Time), intent(out), optional :: StopTime
+      type(ESMF_Time), intent(out), optional :: PrevTime
+      type(ESMF_Time), intent(out), optional :: RefTime
+      integer(ESMF_KIND_I8), intent(out), optional :: AdvanceCount
+      type(ESMF_TimeInterval), intent(out), optional :: TimeStep
+      integer, intent(out), optional :: rc
+      integer :: ierr
+
+! !DESCRIPTION:
+!     Returns the number of times the {\tt ESMF\_Clock} has been advanced
+!     (time stepped)
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the advance count from
+!     \item[StartTime]
+!          The start time
+!     \item[CurrTime]
+!          The current time
+!     \item[AdvanceCount]
+!          The number of times the {\tt ESMF\_Clock} has been advanced
+!     \item[StopTime]
+!          The {\tt ESMF\_Clock}'s stopping time
+!     \item[{[TimeStep]}]
+!          The {\tt ESMF\_Clock}'s time step interval
+!     \item[{[PrevTime]}]
+!          The {\tt ESMF\_Clock}'s previous current time
+!     \item[{[PrevTime]}]
+!          The {\tt ESMF\_Clock}'s reference time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG3.5.1
+!EOP
+      ierr = ESMF_SUCCESS
+
+      IF ( PRESENT (StartTime) ) THEN
+        CALL ESMF_ClockGetStartTime( clock, StartTime=StartTime, rc=ierr )
+      ENDIF
+      IF ( PRESENT (CurrTime) ) THEN
+        CALL ESMF_ClockGetCurrTime( clock , CurrTime, ierr )
+      ENDIF
+      IF ( PRESENT (StopTime) ) THEN
+        CALL ESMF_ClockGetStopTime( clock , StopTime, ierr )
+      ENDIF
+      IF ( PRESENT (AdvanceCount) ) THEN
+        CALL ESMF_ClockGetAdvanceCount(clock, AdvanceCount, ierr)
+      ENDIF
+      IF ( PRESENT (TimeStep) ) THEN
+        CALL ESMF_ClockGetTimeStep(clock, TimeStep, ierr)
+      ENDIF
+      IF ( PRESENT (PrevTime) ) THEN
+        CALL ESMF_ClockGetPrevTime(clock, PrevTime, ierr)
+      ENDIF
+      IF ( PRESENT (RefTime) ) THEN
+        CALL ESMF_ClockGetRefTime(clock, RefTime, ierr)
+      ENDIF
+
+      IF ( PRESENT (rc) ) THEN
+        rc = ierr
+      ENDIF
+    
+      end subroutine ESMF_ClockGet
+
+
+! !IROUTINE: ESMF_ClockGetAdvanceCount - Get the clock's advance count
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetAdvanceCount(clock, AdvanceCount, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      integer(ESMF_KIND_I8), intent(out) :: AdvanceCount
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Returns the number of times the {\tt ESMF\_Clock} has been advanced
+!     (time stepped)
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the advance count from
+!     \item[AdvanceCount]
+!          The number of times the {\tt ESMF\_Clock} has been advanced
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG3.5.1
+!EOP
+
+      AdvanceCount = clock%clockint%AdvanceCount
+
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockGetAdvanceCount
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetTimeStep - Get a clock's timestep interval
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetTimeStep(clock, TimeStep, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_TimeInterval), intent(out) :: TimeStep
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s timestep interval
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the time step from
+!     \item[TimeStep]
+!          The time step
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.2
+!EOP
+
+      TimeStep = clock%clockint%TimeStep
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockGetTimeStep
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockSetTimeStep - Set a clock's timestep interval
+
+! !INTERFACE:
+      subroutine ESMF_ClockSetTimeStep(clock, TimeStep, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(out) :: clock
+      type(ESMF_TimeInterval), intent(in) :: TimeStep
+      integer, intent(out), optional      :: rc
+
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Clock}'s timestep interval
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to set the time step
+!     \item[TimeStep]
+!          The time step
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.4.2
+!EOP
+
+      clock%clockint%TimeStep = TimeStep
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_ClockSetTimeStep
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetCurrTime - Get a clock's current time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetCurrTime(clock, CurrTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out) :: CurrTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s current time     
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the current time from
+!     \item[CurrTime]
+!          The current time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.4
+!EOP
+
+      CurrTime = clock%clockint%CurrTime
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+      end subroutine ESMF_ClockGetCurrTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockSetCurrTime - Set a clock's current time
+
+! !INTERFACE:
+      subroutine ESMF_ClockSetCurrTime(clock, CurrTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(out) :: clock
+      type(ESMF_Time), intent(in) :: CurrTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Clock}'s current time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to set the current time from
+!     \item[CurrTime]
+!          The current time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.4.3
+!EOP
+
+      clock%clockint%CurrTime = CurrTime
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockSetCurrTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetStartTime - Get a clock's start time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetStartTime(clock, StartTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out) :: StartTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s start time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the start time from
+!     \item[StartTime]
+!          The start time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.3
+!EOP
+
+      StartTime = clock%clockint%StartTime
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockGetStartTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetStopTime - Get a clock's stop time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetStopTime(clock, StopTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out) :: StopTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s stop time
+! 
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the stop time from
+!     \item[StopTime]
+!          The stop time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.3
+!EOP
+
+      StopTime = clock%clockint%StopTime
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockGetStopTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetRefTime - Get a clock's reference time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetRefTime(clock, RefTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out) :: RefTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s reference time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the reference time from
+!     \item[RefTime]
+!          The reference time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.3
+!EOP
+      refTime = clock%clockint%RefTime
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+      end subroutine ESMF_ClockGetRefTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetPrevTime - Get a clock's previous current time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetPrevTime(clock, PrevTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Time), intent(out) :: PrevTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s previous current time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the previous current time from
+!     \item[PrevTime]
+!          The previous current time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.4
+!EOP
+
+! hack for bug in PGI 5.1-x
+!      prevTime = Clock%clockint%CurrTime - Clock%clockint%TimeStep
+      prevTime = ESMF_TimeDec( Clock%clockint%CurrTime, &
+                               Clock%clockint%TimeStep )
+
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+      end subroutine ESMF_ClockGetPrevTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetCurrSimTime - Get a clock's current simulation time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetCurrSimTime(clock, CurrSimTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_TimeInterval), intent(out) :: CurrSimTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s current simulation time
+! 
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the current simulation time from
+!     \item[CurrSimTime]
+!          The current simulation time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.5
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockGetCurrSimTime not supported' )
+      end subroutine ESMF_ClockGetCurrSimTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetPrevSimTime - Get a clock's previous simulation time
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetPrevSimTime(clock, PrevSimTime, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_TimeInterval), intent(out) :: PrevSimTime
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s previous simulation time
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the previous simulation time from
+!     \item[PrevSimTime]
+!          The previous simulation time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG3.5.5
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockGetPrevSimTime not supported' )
+      end subroutine ESMF_ClockGetPrevSimTime
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockAddAlarm - Add an alarm to a clock's alarm list
+
+! !INTERFACE:
+      subroutine ESMF_ClockAddAlarm(clock, Alarm, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(inout) :: clock
+      type(ESMF_Alarm), intent(inout) :: Alarm
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Add an {\tt ESMF\_Alarm} to an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to add an {\tt ESMF\_Alarm} to
+!     \item[Alarm]
+!          The {\tt ESMF\_Alarm} to add to the {\tt ESMF\_Clock}'s
+!          {\tt ESMF\_Alarm} list
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!   
+! !REQUIREMENTS:
+!     TMG4.1, TMG4.2
+!EOP
+    
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      clock%clockint%NumAlarms = clock%clockint%NumAlarms + 1
+      IF ( clock%clockint%NumAlarms > SIZE (clock%clockint%AlarmList) ) THEN
+        CALL wrf_error_fatal ( 'ESMF_ClockAddAlarm:  too many alarms' )
+      ELSE IF ( .NOT. ASSOCIATED( Alarm%alarmint ) ) THEN
+        CALL wrf_error_fatal ( &
+               'ESMF_ClockAddAlarm:  alarm not created' )
+      ELSE
+        IF ( Alarm%alarmint%RingTimeSet ) THEN
+           Alarm%alarmint%PrevRingTime = Alarm%alarmint%RingTime
+        ELSE
+!TBH:  This has the nasty side-effect of forcing us to explicitly turn on 
+!TBH:  alarms that are created with RingInterval only, if we want them to start 
+!TBH:  ringing right away.  And this is done (see 
+!TBH:  COMPUTE_VORTEX_CENTER_ALARM).  Straighten this out...  
+           Alarm%alarmint%PrevRingTime = clock%clockint%CurrTime
+        ENDIF
+        Alarm%alarmint%Ringing = .FALSE.
+
+        ! finally, load the alarm into the list
+        clock%clockint%AlarmList(clock%clockint%NumAlarms) = Alarm
+      ENDIF
+    
+      end subroutine ESMF_ClockAddAlarm
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetAlarmList - Get a clock's alarm list
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetAlarmList(clock, AlarmList, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_Alarm), pointer :: AlarmList(:)
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list     
+!   
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the {\tt ESMF\_Alarm} list from
+!     \item[AlarmList]
+!          The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!   
+! !REQUIREMENTS:
+!     TMG4.3
+!EOP
+
+      AlarmList => clock%clockint%AlarmList
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_ClockGetAlarmList
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetNumAlarms - Get the number of alarms in a clock's alarm list
+
+! !INTERFACE:
+      subroutine ESMF_ClockGetNumAlarms(clock, NumAlarms, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      integer, intent(out) :: NumAlarms
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Get the number of {\tt ESMF\_Alarm}s in an {\tt ESMF\_Clock}'s
+!       {\tt ESMF\_Alarm} list     
+!   
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to get the number of {\tt ESMF\_Alarm}s from
+!     \item[NumAlarms]
+!          The number of {\tt ESMF\_Alarm}s in the {\tt ESMF\_Clock}'s
+!            {\tt ESMF\_Alarm} list
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!   
+! !REQUIREMENTS:
+!     TMG4.3
+!EOP
+
+      NumAlarms = clock%clockint%NumAlarms
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockGetNumAlarms
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockSyncToWallClock - Set clock's current time to wall clock time
+
+! !INTERFACE:
+      subroutine ESMF_ClockSyncToWallClock(clock, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(inout) :: clock
+      integer, intent(out), optional :: rc
+    
+! !DESCRIPTION:
+!     Set an {\tt ESMF\_Clock}'s current time to wall clock time     
+!   
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to synchronize to wall clock time
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!   
+! !REQUIREMENTS:
+!     TMG3.4.5
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockSyncToWallClock not supported' )
+      end subroutine ESMF_ClockSyncToWallClock
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockAdvance - Advance a clock's current time by one time step
+
+! !INTERFACE:
+      subroutine ESMF_ClockAdvance(clock, RingingAlarmList, &
+                                   NumRingingAlarms, rc)
+
+use esmf_timemod
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(inout) :: clock
+      type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out), optional :: &
+                                        RingingAlarmList
+      integer, intent(out), optional :: NumRingingAlarms
+      integer, intent(out), optional :: rc
+! Local
+      logical pred1, pred2, pred3
+      integer i, n
+      type(ESMF_Alarm) :: alarm
+      logical :: positive_timestep
+!   
+! !DESCRIPTION:
+!     Advance an {\tt ESMF\_Clock}'s current time by one time step
+!  
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to advance
+!     \item[{[RingingAlarmList]}]
+!          Return a list of any ringing alarms after the time step
+!     \item[{[NumRingingAlarms]}]
+!          The number of ringing alarms returned
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!  
+! !REQUIREMENTS:
+!     TMG3.4.1
+!EOP
+! hack for bug in PGI 5.1-x
+!      clock%clockint%CurrTime = clock%clockint%CurrTime + &
+!                                clock%clockint%TimeStep
+      clock%clockint%CurrTime = ESMF_TimeInc( clock%clockint%CurrTime, &
+                                              clock%clockint%TimeStep )
+      positive_timestep = ESMF_TimeIntervalIsPositive( clock%clockint%TimeStep )
+
+      IF ( Present(NumRingingAlarms) ) NumRingingAlarms = 0
+      clock%clockint%AdvanceCount = clock%clockint%AdvanceCount + 1
+      DO i = 1, MAX_ALARMS
+        alarm = clock%clockint%AlarmList(i)
+        ! TBH:  This is really dangerous.  We need to be able to NULLIFY 
+        ! TBH:  alarmint at compile-time (F95 synax) to make this safe.  
+!$$$TBH:  see if F95 compile-time pointer-nullification is supported by all 
+!$$$TBH:  compilers we support
+        IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+          IF ( alarm%alarmint%Enabled ) THEN
+            IF ( alarm%alarmint%RingIntervalSet ) THEN
+              pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE.
+              ! alarm cannot ring if clock has passed the alarms stop time
+              IF ( alarm%alarmint%StopTimeSet ) THEN
+                IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!                  PRED1 = clock%clockint%CurrTime > alarm%alarmint%StopTime
+                  PRED1 = ESMF_TimeGT( clock%clockint%CurrTime, &
+                                       alarm%alarmint%StopTime )
+                ELSE
+                  ! in this case time step is negative and stop time is 
+                  ! less than start time
+!                  PRED1 = clock%clockint%CurrTime < alarm%alarmint%StopTime
+                  PRED1 = ESMF_TimeLT( clock%clockint%CurrTime, &
+                                       alarm%alarmint%StopTime )
+                ENDIF
+              ENDIF
+              ! one-shot alarm:  check for ring time 
+! TBH:  Need to remove duplicated code.  Need to enforce only one of 
+! TBH:  alarm%alarmint%RingTimeSet or alarm%alarmint%RingIntervalSet ever 
+! TBH:  being .TRUE. and simplify the logic.  Also, the simpler 
+! TBH:  implementation in the duplicated code below should be sufficient.  
+              IF ( alarm%alarmint%RingTimeSet ) THEN
+                IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!                   PRED2 = ( alarm%alarmint%RingTime <= clock%clockint%CurrTime     &
+!                          .AND. clock%clockint%CurrTime < alarm%alarmint%RingTime + &
+!                                clock%clockint%TimeStep )
+                   PRED2 = ( ESMF_TimeLE( alarm%alarmint%RingTime,       &
+                                          clock%clockint%CurrTime )      &
+                             .AND. ESMF_TimeLT( clock%clockint%CurrTime, &
+                               ESMF_TimeInc( alarm%alarmint%RingTime,    &
+                                             clock%clockint%TimeStep ) ) )
+                ELSE
+                  ! in this case time step is negative and stop time is 
+                  ! less than start time
+! hack for bug in PGI 5.1-x
+!                   PRED2 = ( alarm%alarmint%RingTime >= clock%clockint%CurrTime     &
+!                          .AND. clock%clockint%CurrTime > alarm%alarmint%RingTime + &
+!                                clock%clockint%TimeStep )
+                   PRED2 = ( ESMF_TimeGE( alarm%alarmint%RingTime,       &
+                                          clock%clockint%CurrTime )      &
+                             .AND. ESMF_TimeGT( clock%clockint%CurrTime, &
+                               ESMF_TimeInc( alarm%alarmint%RingTime,    &
+                                             clock%clockint%TimeStep ) ) )
+                ENDIF
+              ENDIF
+              ! repeating alarm:  check for ring interval
+              IF ( alarm%alarmint%RingIntervalSet ) THEN
+                IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!                   PRED3 = ( alarm%alarmint%PrevRingTime + alarm%alarmint%RingInterval <= &
+!                             clock%clockint%CurrTime )
+
+                   PRED3 = ( ESMF_TimeLE( ESMF_TimeInc(                  &
+                                          alarm%alarmint%PrevRingTime,   &
+                                          alarm%alarmint%RingInterval ), &
+                             clock%clockint%CurrTime ) )
+                ELSE
+                  ! in this case time step is negative and stop time is 
+                  ! less than start time
+                  ! ring interval must always be positive
+! hack for bug in PGI 5.1-x
+!                   PRED3 = ( alarm%alarmint%PrevRingTime - alarm%alarmint%RingInterval >= &
+!                             clock%clockint%CurrTime )
+
+                   PRED3 = ( ESMF_TimeGE( ESMF_TimeDec(                  &
+                                          alarm%alarmint%PrevRingTime,   &
+                                          alarm%alarmint%RingInterval ), &
+                             clock%clockint%CurrTime ) )
+                ENDIF
+              ENDIF
+              IF ( ( .NOT. ( pred1 ) ) .AND. &
+                   ( ( pred2 ) .OR. ( pred3 ) ) ) THEN
+                 alarm%alarmint%Ringing = .TRUE.
+                 IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!                   IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime + &
+!                                                    alarm%alarmint%RingInterval
+                   IF ( PRED3 )                                   &
+                     alarm%alarmint%PrevRingTime =                &
+                       ESMF_TimeInc( alarm%alarmint%PrevRingTime, &
+                                     alarm%alarmint%RingInterval )
+                 ELSE
+                   ! in this case time step is negative and stop time is 
+                   ! less than start time
+                   ! ring interval must always be positive
+! hack for bug in PGI 5.1-x
+!                   IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime - &
+!                                                    alarm%alarmint%RingInterval
+                   IF ( PRED3 )                                   &
+                     alarm%alarmint%PrevRingTime =                &
+                       ESMF_TimeDec( alarm%alarmint%PrevRingTime, &
+                                     alarm%alarmint%RingInterval )
+                 ENDIF
+                 IF ( PRESENT( RingingAlarmList ) .AND. &
+                      PRESENT ( NumRingingAlarms ) ) THEN
+                   NumRingingAlarms = NumRingingAlarms + 1
+                   RingingAlarmList( NumRingingAlarms ) = alarm
+                 ENDIF
+              ENDIF
+            ELSE IF ( alarm%alarmint%RingTimeSet ) THEN
+! TBH:  Need to remove duplicated code.  Need to enforce only one of 
+! TBH:  alarm%alarmint%RingTimeSet or alarm%alarmint%RingIntervalSet ever 
+! TBH:  being .TRUE. and simplify the logic.  Also, the simpler 
+! TBH:  implementation in here should be sufficient.  
+              IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!                IF ( alarm%alarmint%RingTime <= clock%clockint%CurrTime ) THEN
+                IF ( ESMF_TimeLE( alarm%alarmint%RingTime, &
+                                  clock%clockint%CurrTime ) ) THEN
+                   alarm%alarmint%Ringing = .TRUE.
+                   IF ( PRESENT( RingingAlarmList ) .AND. &
+                        PRESENT ( NumRingingAlarms ) ) THEN
+                     NumRingingAlarms = NumRingingAlarms + 1
+                     RingingAlarmList( NumRingingAlarms ) = alarm
+                   ENDIF
+                ENDIF
+              ELSE
+                ! in this case time step is negative and stop time is 
+                ! less than start time
+! hack for bug in PGI 5.1-x
+!                IF ( alarm%alarmint%RingTime >= clock%clockint%CurrTime ) THEN
+                IF ( ESMF_TimeGE( alarm%alarmint%RingTime, &
+                                  clock%clockint%CurrTime ) ) THEN
+                   alarm%alarmint%Ringing = .TRUE.
+                   IF ( PRESENT( RingingAlarmList ) .AND. &
+                        PRESENT ( NumRingingAlarms ) ) THEN
+                     NumRingingAlarms = NumRingingAlarms + 1
+                     RingingAlarmList( NumRingingAlarms ) = alarm
+                   ENDIF
+                ENDIF
+              ENDIF
+            ENDIF
+            IF ( alarm%alarmint%StopTimeSet ) THEN
+! TBH:  what is this for???  
+            ENDIF
+          ENDIF
+        ENDIF
+        clock%clockint%AlarmList(i) = alarm
+      ENDDO
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    
+      end subroutine ESMF_ClockAdvance
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockStopTimeDisable - NOOP for compatibility with ESMF 2.1.0+
+
+! !INTERFACE:
+      subroutine ESMF_ClockStopTimeDisable(clock, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      integer, intent(out), optional :: rc
+
+      rc = ESMF_SUCCESS
+
+      end subroutine ESMF_ClockStopTimeDisable
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockIsStopTime - Has the clock reached its stop time ?
+
+! !INTERFACE:
+      function ESMF_ClockIsStopTime(clock, rc)
+!
+! !RETURN VALUE:
+      logical :: ESMF_ClockIsStopTime
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      integer, intent(out), optional :: rc
+      logical :: positive_timestep
+
+! !DESCRIPTION:
+!     Return true if {\tt ESMF\_Clock} has reached its stop time, false 
+!     otherwise     
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to check
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+
+! !REQUIREMENTS:
+!     TMG3.5.6
+!EOP
+
+      positive_timestep = ESMF_TimeIntervalIsPositive( clock%clockint%TimeStep )
+      IF ( positive_timestep ) THEN
+! hack for bug in PGI 5.1-x
+!        if ( clock%clockint%CurrTime .GE. clock%clockint%StopTime ) THEN
+        if ( ESMF_TimeGE( clock%clockint%CurrTime, &
+                          clock%clockint%StopTime ) ) THEN
+          ESMF_ClockIsStopTime = .TRUE.
+        else
+          ESMF_ClockIsStopTime = .FALSE.
+        endif
+      ELSE
+! hack for bug in PGI 5.1-x
+!        if ( clock%clockint%CurrTime .LE. clock%clockint%StopTime ) THEN
+        if ( ESMF_TimeLE( clock%clockint%CurrTime, &
+                          clock%clockint%StopTime ) ) THEN
+          ESMF_ClockIsStopTime = .TRUE.
+        else
+          ESMF_ClockIsStopTime = .FALSE.
+        endif
+      ENDIF
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    
+      end function ESMF_ClockIsStopTime
+
+!------------------------------------------------------------------------------
+!
+! This section defines the overridden Read, Write, Validate and Print methods
+! from the ESMF_Base class
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockRead - Restores a clock
+
+! !INTERFACE:
+      subroutine ESMF_ClockRead(clock, TimeStep, StartTime, StopTime, &
+                                RefTime, CurrTime, PrevTime, AdvanceCount, &
+                                AlarmList, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(out) :: clock
+      type(ESMF_TimeInterval), intent(in) :: TimeStep
+      type(ESMF_Time), intent(in) :: StartTime
+      type(ESMF_Time), intent(in) :: StopTime
+      type(ESMF_Time), intent(in) :: RefTime
+      type(ESMF_Time), intent(in) :: CurrTime
+      type(ESMF_Time), intent(in) :: PrevTime
+      integer(ESMF_KIND_I8), intent(in) :: AdvanceCount
+      type(ESMF_Alarm), dimension(MAX_ALARMS), intent(in) :: AlarmList
+      integer, intent(out), optional :: rc
+    
+! !DESCRIPTION:
+!     Restore an {\tt ESMF\_Clock}
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to restore
+!     \item[TimeStep]
+!          The {\tt ESMF\_Clock}'s time step interval
+!     \item[StartTime]
+!          The {\tt ESMF\_Clock}'s starting time
+!     \item[StopTime]
+!          The {\tt ESMF\_Clock}'s stopping time
+!     \item[RefTime]
+!          The {\tt ESMF\_Clock}'s reference time
+!     \item[CurrTime]
+!          The {\tt ESMF\_Clock}'s current time
+!     \item[PrevTime]
+!          The {\tt ESMF\_Clock}'s previous time
+!     \item[AdvanceCount]
+!          The number of times the {\tt ESMF\_Clock} has been advanced
+!     \item[AlarmList]
+!          The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!     
+! !REQUIREMENTS:
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockRead not supported' )
+      end subroutine ESMF_ClockRead
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockWrite - Saves a clock
+
+! !INTERFACE:
+      subroutine ESMF_ClockWrite(clock, TimeStep, StartTime, StopTime, &
+                            RefTime, CurrTime, PrevTime, AdvanceCount, &
+                            AlarmList, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      type(ESMF_TimeInterval), intent(out) :: TimeStep
+      type(ESMF_Time), intent(out) :: StartTime
+      type(ESMF_Time), intent(out) :: StopTime
+      type(ESMF_Time), intent(out) :: RefTime
+      type(ESMF_Time), intent(out) :: CurrTime
+      type(ESMF_Time), intent(out) :: PrevTime
+      integer(ESMF_KIND_I8), intent(out) :: AdvanceCount
+      type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out) :: AlarmList
+      integer, intent(out), optional :: rc
+    
+! !DESCRIPTION:
+!     Save an {\tt ESMF\_Clock}
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          The object instance to save
+!     \item[TimeStep]
+!          The {\tt ESMF\_Clock}'s time step interval
+!     \item[StartTime]
+!          The {\tt ESMF\_Clock}'s starting time
+!     \item[StopTime]
+!          The {\tt ESMF\_Clock}'s stopping time
+!     \item[RefTime]
+!          The {\tt ESMF\_Clock}'s reference time
+!     \item[CurrTime]
+!          The {\tt ESMF\_Clock}'s current time
+!     \item[PrevTime]
+!          The {\tt ESMF\_Clock}'s previous time
+!     \item[AdvanceCount]
+!          The number of times the {\tt ESMF\_Clock} has been advanced
+!     \item[AlarmList]
+!          The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!     
+! !REQUIREMENTS:
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockWrite not supported' )
+      end subroutine ESMF_ClockWrite
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_ClockValidate - Validate a Clock's properties
+
+! !INTERFACE:
+      subroutine ESMF_ClockValidate(clock, opts, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      character (len=*), intent(in), optional :: opts
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     Perform a validation check on an {\tt ESMF\_Clock}'s properties
+!
+!     The arguments are:  
+!     \begin{description}
+!     \item[clock]
+!          {\tt ESMF\_Clock} to validate
+!     \item[{[opts]}]
+!          Validate options
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description} 
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockValidate not supported' )
+      end subroutine ESMF_ClockValidate
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_ClockPrint - Print out a Clock's properties
+
+! !INTERFACE:
+      subroutine ESMF_ClockPrint(clock, opts, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Clock), intent(in) :: clock
+      character (len=*), intent(in), optional :: opts
+      integer, intent(out), optional :: rc
+
+! !DESCRIPTION:
+!     To support testing/debugging, print out an {\tt ESMF\_Clock}'s
+!     properties.
+! 
+!     The arguments are:
+!     \begin{description}
+!     \item[clock]
+!          {\tt ESMF\_Clock} to print out
+!     \item[{[opts]}]
+!          Print options
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+      CALL wrf_error_fatal( 'ESMF_ClockPrint not supported' )
+      end subroutine ESMF_ClockPrint
+
+!------------------------------------------------------------------------------
+
+      end module ESMF_ClockMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Fraction.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Fraction.F90
new file mode 100644
index 00000000..fea9ba79
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Fraction.F90
@@ -0,0 +1,79 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+! ESMF Fraction Module
+!
+!==============================================================================
+!
+!     ESMF Fraction Module
+      module ESMF_FractionMod
+!
+!==============================================================================
+!
+! This file contains the Fraction class definition and all Fraction
+! class methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+!
+!===============================================================================
+!BOPI
+!
+! !MODULE: ESMF_FractionMod
+!
+! !DESCRIPTION:
+! Part of ESMF F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ implementaion of class {\tt ESMC\_Fraction}
+!
+! See {\tt ../include/ESMC\_Fraction.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+!     ! ESMF_Fraction
+!
+      type ESMF_Fraction
+      private
+        integer :: n    ! Integer fraction (exact) n/d; numerator
+        integer :: d    ! Integer fraction (exact) n/d; denominator
+      end type
+!
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_Fraction
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+
+! !PRIVATE MEMBER FUNCTIONS:
+
+!EOPI
+
+!==============================================================================
+
+!      contains
+
+!==============================================================================
+!
+! Wrappers to C++ fraction routines
+!
+!------------------------------------------------------------------------------
+!
+
+!------------------------------------------------------------------------------
+
+      end module ESMF_FractionMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Macros.inc b/wrfv2_fire/external/esmf_time_f90/ESMF_Macros.inc
new file mode 100644
index 00000000..44bee666
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Macros.inc
@@ -0,0 +1,35 @@
+#if 0
+
+Earth System Modeling Framework
+Copyright 2002-2003, University Corporation for Atmospheric Research,
+Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+Laboratory, University of Michigan, National Centers for Environmental
+Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+NASA Goddard Space Flight Center.
+Licensed under the GPL.
+
+Do not have C++ or F90 style comments in here because this file is processed
+by both C++ and F90 compilers.
+
+These lines prevent this file from being read more than once if it
+ends up being included multiple times.
+#endif
+
+#ifndef ESMF_MACROS_INC
+#define ESMF_MACROS_INC
+
+#if 0
+
+former file contents moved to ESMF_BaseMod
+so user code can be compiled without requiring
+the preprocessor.
+
+#endif 
+
+#if 0
+i left the following macro here in case it is needed for our internal use.
+#endif
+
+#define ESMF_SRCLINE __FILE__, __LINE__
+
+#endif 
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Mod.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Mod.F90
new file mode 100644
index 00000000..8c4c260c
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Mod.F90
@@ -0,0 +1,17 @@
+! TBH:  This version is for use with the ESMF library embedded in the WRF 
+! TBH:  distribution.  
+MODULE ESMF_Mod
+   USE esmf_alarmmod
+   USE esmf_basemod
+   USE esmf_basetimemod
+   USE esmf_calendarmod
+   USE esmf_clockmod
+   USE esmf_fractionmod
+   USE esmf_timeintervalmod
+   USE esmf_timemod
+   USE esmf_alarmclockmod
+   USE esmf_stubs   ! add new dummy interfaces and typedefs here as needed
+#include 
+   INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS
+!
+END MODULE ESMF_Mod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Stubs.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Stubs.F90
new file mode 100644
index 00000000..f367161f
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Stubs.F90
@@ -0,0 +1,125 @@
+! Various dummy type definitions and routines for the sole purpose of 
+! mimicking newer ESMF interface features without necessarily implementing 
+! them.  
+
+MODULE ESMF_Stubs
+
+   IMPLICIT NONE
+
+   PRIVATE
+
+! Bogus typedefs
+   TYPE ESMF_Grid
+      INTEGER :: dummy
+   END TYPE
+
+   TYPE ESMF_GridComp
+      INTEGER :: dummy
+   END TYPE
+
+   TYPE ESMF_State
+      INTEGER :: dummy
+   END TYPE
+
+   TYPE ESMF_VM
+      INTEGER :: dummy
+   END TYPE
+
+   TYPE ESMF_MsgType
+      INTEGER :: mtype
+   END TYPE
+   TYPE(ESMF_MsgType), PARAMETER  ::      &
+      ESMF_LOG_INFO  =   ESMF_MsgType(1), &
+      ESMF_LOG_WARNING = ESMF_MsgType(2), &
+      ESMF_LOG_ERROR =   ESMF_MsgType(3)
+
+   TYPE ESMF_LOG
+      INTEGER :: dummy
+   END TYPE
+
+   LOGICAL, private, save :: initialized = .false.
+
+   PUBLIC ESMF_Grid, ESMF_GridComp, ESMF_State, ESMF_VM
+   PUBLIC ESMF_Initialize, ESMF_Finalize, ESMF_IsInitialized
+   PUBLIC ESMF_LogWrite, ESMF_LOG, ESMF_MsgType
+   PUBLIC ESMF_LOG_INFO, ESMF_LOG_WARNING, ESMF_LOG_ERROR
+
+CONTAINS
+
+
+! NOOP
+   SUBROUTINE ESMF_Initialize( vm, defaultCalendar, rc )
+      USE esmf_basemod
+      USE esmf_calendarmod
+      TYPE(ESMF_VM),           INTENT(IN   ), OPTIONAL :: vm
+      TYPE(ESMF_CalendarType), INTENT(IN   ), OPTIONAL :: defaultCalendar
+      INTEGER,                 INTENT(  OUT), OPTIONAL :: rc
+
+      TYPE(ESMF_CalendarType) :: defaultCalType
+      INTEGER :: status
+
+      IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      ! Initialize the default time manager calendar
+      IF ( PRESENT(defaultCalendar) )THEN
+         defaultCalType = defaultCalendar
+      ELSE
+         defaultCalType = ESMF_CAL_NOLEAP
+      END IF
+      allocate( defaultCal )
+      defaultCal = ESMF_CalendarCreate( calendarType=defaultCalType, &
+                        rc=status)
+
+      ! initialize tables in time manager
+      CALL initdaym
+
+      IF (status .ne. ESMF_SUCCESS) THEN
+          PRINT *, "Error initializing the default time manager calendar"
+          RETURN
+      END IF
+      initialized = .true.
+
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+   END SUBROUTINE ESMF_Initialize
+
+
+   FUNCTION ESMF_IsInitialized()
+      LOGICAL ESMF_IsInitialized
+      ESMF_IsInitialized = initialized
+   END FUNCTION ESMF_IsInitialized
+
+
+! NOOP
+   SUBROUTINE ESMF_Finalize( rc )
+      USE esmf_basemod
+      INTEGER, INTENT(  OUT), OPTIONAL :: rc
+#if (defined SPMD) || (defined COUP_CSM)
+#include 
+#endif
+      INTEGER :: ier
+
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+#if (defined SPMD) || (defined COUP_CSM)
+      CALL MPI_Finalize( ier ) 
+      IF ( ier .ne. mpi_success )THEN
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      END IF
+#endif
+   END SUBROUTINE ESMF_Finalize
+
+! NOOP
+   SUBROUTINE ESMF_LogWrite( msg, MsgType, line, file, method, log, rc )
+      USE esmf_basemod
+      CHARACTER(LEN=*), INTENT(IN) :: msg
+      TYPE(ESMF_MsgType), INTENT(IN) :: msgtype
+      INTEGER, INTENT(IN), OPTIONAL :: line
+      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file
+      CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: method
+      TYPE(ESMF_LOG),TARGET,OPTIONAL :: log
+      INTEGER, INTENT(OUT),OPTIONAL :: rc
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+   END SUBROUTINE ESMF_LogWrite
+
+
+END MODULE ESMF_Stubs
+
+
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_Time.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_Time.F90
new file mode 100644
index 00000000..0c80d50e
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_Time.F90
@@ -0,0 +1,1185 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF Time Module
+      module ESMF_TimeMod
+!
+!==============================================================================
+!
+! This file contains the Time class definition and all Time class methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include 
+
+!==============================================================================
+!BOPI
+! !MODULE: ESMF_TimeMod
+!
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ class {\tt ESMC\_Time} implementation
+!
+! See {\tt ../include/ESMC\_Time.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit from ESMF base class
+      use ESMF_BaseMod
+
+      ! inherit from base time class
+      use ESMF_BaseTimeMod
+
+      ! associated derived types
+      use ESMF_TimeIntervalMod
+      use ESMF_CalendarMod
+      use ESMF_Stubs
+
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+!     ! ESMF_Time
+!
+!     ! F90 class type to match C++ Time class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+
+     type ESMF_Time
+       type(ESMF_BaseTime) :: basetime           ! inherit base class
+       ! time instant is expressed as year + basetime
+       integer :: YR
+       type(ESMF_Calendar), pointer :: calendar  ! associated calendar
+     end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_Time
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_TimeGet
+      public ESMF_TimeSet
+
+! Required inherited and overridden ESMF_Base class methods
+
+      public ESMF_TimeCopy
+
+! !PRIVATE MEMBER FUNCTIONS:
+
+      private ESMF_TimeGetDayOfYear
+      private ESMF_TimeGetDayOfYearInteger
+
+! Inherited and overloaded from ESMF_BaseTime
+
+      ! NOTE:  ESMF_TimeInc, ESMF_TimeDec, ESMF_TimeDiff, ESMF_TimeEQ, 
+      !        ESMF_TimeNE, ESMF_TimeLT, ESMF_TimeGT, ESMF_TimeLE, and 
+      !        ESMF_TimeGE are PUBLIC only to work around bugs in the 
+      !        PGI 5.1-x compilers.  They should all be PRIVATE.  
+
+      public operator(+)
+      public ESMF_TimeInc
+
+      public operator(-)
+      public ESMF_TimeDec
+      public ESMF_TimeDec2
+      public ESMF_TimeDiff
+
+      public operator(.EQ.)
+      public ESMF_TimeEQ
+
+      public operator(.NE.)
+      public ESMF_TimeNE
+
+      public operator(.LT.)
+      public ESMF_TimeLT
+
+      public operator(.GT.)
+      public ESMF_TimeGT
+
+      public operator(.LE.)
+      public ESMF_TimeLE
+
+      public operator(.GE.)
+      public ESMF_TimeGE
+
+!EOPI
+
+!==============================================================================
+!
+! INTERFACE BLOCKS
+!
+!==============================================================================
+!BOP
+! !INTERFACE:
+      interface ESMF_TimeGetDayOfYear
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeGetDayOfYearInteger
+
+! !DESCRIPTION:
+!     This interface overloads the {\tt ESMF\_GetDayOfYear} method
+!     for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(+)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeInc, ESMF_TimeInc2
+
+! !DESCRIPTION:
+!     This interface overloads the + operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface assignment (=)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeCopy
+
+! !DESCRIPTION:
+!     This interface overloads the = operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(-)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeDec, ESMF_TimeDec2
+
+! !DESCRIPTION:
+!     This interface overloads the - operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(-)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeDiff
+
+! !DESCRIPTION:
+!     This interface overloads the - operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.EQ.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeEQ
+
+! !DESCRIPTION:
+!     This interface overloads the .EQ. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.NE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeNE
+
+! !DESCRIPTION:
+!     This interface overloads the .NE. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.LT.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeLT
+
+! !DESCRIPTION:
+!     This interface overloads the .LT. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.GT.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeGT
+
+! !DESCRIPTION:
+!     This interface overloads the .GT. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.LE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeLE
+
+! !DESCRIPTION:
+!     This interface overloads the .LE. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.GE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeGE
+
+! !DESCRIPTION:
+!     This interface overloads the .GE. operator for the {\tt ESMF\_Time} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+!
+! Generic Get/Set routines which use F90 optional arguments
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeGet - Get value in user-specified units
+
+! !INTERFACE:
+      subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, &
+                              US, NS, d_, h_, m_, s_, ms_, us_, ns_, Sn, Sd, &
+                              dayOfYear, dayOfYear_r8, dayOfYear_intvl,      &
+                              timeString, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time
+      integer, intent(out), optional :: YY
+      integer(ESMF_KIND_I8), intent(out), optional :: YRl
+      integer, intent(out), optional :: MM
+      integer, intent(out), optional :: DD
+      integer, intent(out), optional :: D
+      integer(ESMF_KIND_I8), intent(out), optional :: Dl
+      integer, intent(out), optional :: H
+      integer, intent(out), optional :: M
+      integer, intent(out), optional :: S
+      integer(ESMF_KIND_I8), intent(out), optional :: Sl
+      integer, intent(out), optional :: MS
+      integer, intent(out), optional :: US
+      integer, intent(out), optional :: NS
+      double precision, intent(out), optional :: d_
+      double precision, intent(out), optional :: h_
+      double precision, intent(out), optional :: m_
+      double precision, intent(out), optional :: s_
+      double precision, intent(out), optional :: ms_
+      double precision, intent(out), optional :: us_
+      double precision, intent(out), optional :: ns_
+      integer, intent(out), optional :: Sn
+      integer, intent(out), optional :: Sd
+      integer, intent(out), optional :: dayOfYear
+      ! dayOfYear_r8 = 1.0 at 0Z on 1 January, 1.5 at 12Z on
+      ! 1 January, etc.
+      real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8
+      character (len=*), intent(out), optional :: timeString
+      type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl
+      integer, intent(out), optional :: rc
+
+      type(ESMF_TimeInterval) :: day_step
+      integer :: ierr
+
+! !DESCRIPTION:
+!     Get the value of the {\tt ESMF\_Time} in units specified by the user
+!     via F90 optional arguments.
+!
+!     Time manager represents and manipulates time internally with integers
+!     to maintain precision. Hence, user-specified floating point values are
+!     converted internally from integers.
+!
+!     See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for
+!     complete description.
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The object instance to query
+!     \item[{[YY]}]
+!          Integer year CCYR (>= 32-bit)
+!     \item[{[YRl]}]
+!          Integer year CCYR (large, >= 64-bit)
+!     \item[{[MM]}]
+!          Integer month 1-12
+!     \item[{[DD]}]
+!          Integer day of the month 1-31
+!     \item[{[D]}]
+!          Integer Julian days (>= 32-bit)
+!     \item[{[Dl]}]
+!          Integer Julian days (large, >= 64-bit)
+!     \item[{[H]}]
+!          Integer hours
+!     \item[{[M]}]
+!          Integer minutes
+!     \item[{[S]}]
+!          Integer seconds (>= 32-bit)
+!     \item[{[Sl]}]
+!          Integer seconds (large, >= 64-bit)
+!     \item[{[MS]}]
+!          Integer milliseconds
+!     \item[{[US]}]
+!          Integer microseconds
+!     \item[{[NS]}]
+!          Integer nanoseconds
+!     \item[{[d\_]}]
+!          Double precision days
+!     \item[{[h\_]}]
+!          Double precision hours
+!     \item[{[m\_]}]
+!          Double precision minutes
+!     \item[{[s\_]}]
+!          Double precision seconds
+!     \item[{[ms\_]}]
+!          Double precision milliseconds
+!     \item[{[us\_]}]
+!          Double precision microseconds
+!     \item[{[ns\_]}]
+!          Double precision nanoseconds
+!     \item[{[Sn]}]
+!          Integer fractional seconds - numerator
+!     \item[{[Sd]}]
+!          Integer fractional seconds - denominator
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG2.1, TMG2.5.1, TMG2.5.6
+!EOP
+      TYPE(ESMF_Time) :: begofyear
+      INTEGER :: year, month, dayofmonth, hour, minute, second
+      REAL(ESMF_KIND_R8) :: rsec
+
+      ierr = ESMF_SUCCESS
+
+      IF ( PRESENT( YY ) ) THEN
+        YY = time%YR
+      ENDIF
+      IF ( PRESENT( MM ) ) THEN
+        CALL timegetmonth( time, MM )
+      ENDIF
+      IF ( PRESENT( DD ) ) THEN
+        CALL timegetdayofmonth( time, DD )
+      ENDIF
+!
+!$$$ Push HMS down into ESMF_BaseTime from EVERYWHERE
+!$$$ and THEN add ESMF scaling behavior when other args are present...  
+      IF ( PRESENT( H ) ) THEN
+        H = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR
+      ENDIF
+      IF ( PRESENT( M ) ) THEN
+        M = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE
+      ENDIF
+      IF ( PRESENT( S ) ) THEN
+        S = mod( time%basetime%S, SECONDS_PER_MINUTE )
+      ENDIF
+      ! TBH:  HACK to allow DD and S to behave as in ESMF 2.1.0+ when 
+      ! TBH:  both are present and H and M are not.  
+      IF ( PRESENT( S ) .AND. PRESENT( DD ) ) THEN
+        IF ( ( .NOT. PRESENT( H ) ) .AND. ( .NOT. PRESENT( M ) ) ) THEN
+          S = mod( time%basetime%S, SECONDS_PER_DAY )
+        ENDIF
+      ENDIF
+      IF ( PRESENT( MS ) ) THEN
+        IF ( time%basetime%Sd /= 0 ) THEN
+          MS = NINT( ( time%basetime%Sn*1.0D0 / time%basetime%Sd*1.0D0 ) * 1000.0D0 )
+        ELSE
+          MS = 0
+        ENDIF
+      ENDIF
+      IF ( PRESENT( Sd ) .AND. PRESENT( Sn ) ) THEN
+        Sd = time%basetime%Sd
+        Sn = time%basetime%Sn
+      ENDIF
+      IF ( PRESENT( dayOfYear ) ) THEN
+        CALL ESMF_TimeGetDayOfYear( time, dayOfYear, rc=ierr )
+      ENDIF
+      IF ( PRESENT( dayOfYear_r8 ) ) THEN
+        ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold 
+        ! number of seconds in a year...  
+        rsec = REAL( time%basetime%S, ESMF_KIND_R8 )
+        IF ( time%basetime%Sd /= 0 ) THEN
+          rsec = rsec + ( REAL( time%basetime%Sn, ESMF_KIND_R8 ) / &
+                          REAL( time%basetime%Sd, ESMF_KIND_R8 ) )
+        ENDIF
+        dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 )
+        ! start at 1
+        dayOfYear_r8 = dayOfYear_r8 + 1.0_ESMF_KIND_R8
+      ENDIF
+      IF ( PRESENT( timeString ) ) THEN
+        ! This duplication for YMD is an optimization that avoids calling 
+        ! timegetmonth() and timegetdayofmonth() when it is not needed.  
+        year = time%YR
+        CALL timegetmonth( time, month )
+        CALL timegetdayofmonth( time, dayofmonth )
+!$$$ push HMS down into ESMF_BaseTime
+        hour = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR
+        minute = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE
+        second = mod( time%basetime%S, SECONDS_PER_MINUTE )
+        CALL ESMFold_TimeGetString( year, month, dayofmonth, &
+                                    hour, minute, second, timeString )
+      ENDIF
+      IF ( PRESENT( dayOfYear_intvl ) ) THEN
+        year = time%YR
+        CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, &
+                           calendar=time%calendar, rc=ierr )
+        IF ( ierr == ESMF_FAILURE)THEN
+           rc = ierr
+           RETURN
+        END IF
+        CALL ESMF_TimeIntervalSet( day_step, d=1, s=0, rc=ierr )
+        dayOfYear_intvl = time - begofyear + day_step
+      ENDIF
+
+      IF ( PRESENT( rc ) ) THEN
+        rc = ierr
+      ENDIF
+
+      end subroutine ESMF_TimeGet
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeSet - Initialize via user-specified unit set
+
+! !INTERFACE:
+      subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, &
+                              MS, US, NS, d_, h_, m_, s_, ms_, us_, ns_, &
+                              Sn, Sd, calendar, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Time), intent(inout) :: time
+      integer, intent(in), optional :: YY
+      integer(ESMF_KIND_I8), intent(in), optional :: YRl
+      integer, intent(in), optional :: MM
+      integer, intent(in), optional :: DD
+      integer, intent(in), optional :: D
+      integer(ESMF_KIND_I8), intent(in), optional :: Dl
+      integer, intent(in), optional :: H
+      integer, intent(in), optional :: M
+      integer, intent(in), optional :: S
+      integer(ESMF_KIND_I8), intent(in), optional :: Sl
+      integer, intent(in), optional :: MS
+      integer, intent(in), optional :: US
+      integer, intent(in), optional :: NS
+      double precision, intent(in), optional :: d_
+      double precision, intent(in), optional :: h_
+      double precision, intent(in), optional :: m_
+      double precision, intent(in), optional :: s_
+      double precision, intent(in), optional :: ms_
+      double precision, intent(in), optional :: us_
+      double precision, intent(in), optional :: ns_
+      integer, intent(in), optional :: Sn
+      integer, intent(in), optional :: Sd
+      type(ESMF_Calendar), intent(in), target, optional :: calendar
+      integer, intent(out), optional :: rc
+      ! locals
+      INTEGER :: ierr
+
+! !DESCRIPTION:
+!     Initializes a {\tt ESMF\_Time} with a set of user-specified units
+!     via F90 optional arguments.
+!
+!     Time manager represents and manipulates time internally with integers
+!     to maintain precision. Hence, user-specified floating point values are
+!     converted internally to integers.
+!
+!     See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for
+!     complete description.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The object instance to initialize
+!     \item[{[YY]}]
+!          Integer year CCYR (>= 32-bit)
+!     \item[{[YRl]}]
+!          Integer year CCYR (large, >= 64-bit)
+!     \item[{[MM]}]
+!          Integer month 1-12
+!     \item[{[DD]}]
+!          Integer day of the month 1-31
+!     \item[{[D]}]
+!          Integer Julian days (>= 32-bit)
+!     \item[{[Dl]}]
+!          Integer Julian days (large, >= 64-bit)
+!     \item[{[H]}]
+!          Integer hours
+!     \item[{[M]}]
+!          Integer minutes
+!     \item[{[S]}]
+!          Integer seconds (>= 32-bit)
+!     \item[{[Sl]}]
+!          Integer seconds (large, >= 64-bit)
+!     \item[{[MS]}]
+!          Integer milliseconds
+!     \item[{[US]}]
+!          Integer microseconds
+!     \item[{[NS]}]
+!          Integer nanoseconds
+!     \item[{[d\_]}]
+!          Double precision days
+!     \item[{[h\_]}]
+!          Double precision hours
+!     \item[{[m\_]}]
+!          Double precision minutes
+!     \item[{[s\_]}]
+!          Double precision seconds
+!     \item[{[ms\_]}]
+!          Double precision milliseconds
+!     \item[{[us\_]}]
+!          Double precision microseconds
+!     \item[{[ns\_]}]
+!          Double precision nanoseconds
+!     \item[{[Sn]}]
+!          Integer fractional seconds - numerator
+!     \item[{[Sd]}]
+!          Integer fractional seconds - denominator
+!     \item[{[cal]}]
+!          Associated {\tt Calendar}
+!     \item[{[tz]}]
+!          Associated timezone (hours offset from GMT, e.g. EST = -5)
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+!  PRINT *,'DEBUG:  BEGIN ESMF_TimeSet()'
+!$$$ push this down into ESMF_BaseTime constructor
+      time%basetime%S  = 0
+      time%basetime%Sn = 0
+      time%basetime%Sd = 0
+
+      IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      time%YR = 0
+      IF ( PRESENT( YY ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  YY = ',YY
+        time%YR = YY
+      ENDIF
+      IF ( PRESENT( MM ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  MM = ',MM
+        CALL timeaddmonths( time, MM, ierr )
+        IF ( ierr == ESMF_FAILURE ) THEN
+          IF ( PRESENT( rc ) ) THEN
+            rc = ESMF_FAILURE
+            RETURN
+          ELSE
+            CALL wrf_error_fatal( 'ESMF_TimeSet:  MM out of range' )
+          ENDIF
+        ENDIF
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  back from timeaddmonths'
+      ENDIF
+      IF ( PRESENT( DD ) ) THEN
+!$$$ no check for DD in range of days of month MM yet
+!$$$ Must separate D and DD for correct interface!
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  DD = ',DD
+        time%basetime%S = time%basetime%S + &
+          ( SECONDS_PER_DAY * INT( (DD-1), ESMF_KIND_I8 ) )
+      ENDIF
+!$$$ push H,M,S,Sn,Sd,MS down into ESMF_BaseTime constructor
+      IF ( PRESENT( H ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  H = ',H
+        time%basetime%S = time%basetime%S + &
+          ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) )
+      ENDIF
+      IF ( PRESENT( M ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  M = ',M
+        time%basetime%S = time%basetime%S + &
+          ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) )
+      ENDIF
+      IF ( PRESENT( S ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  S = ',S
+        time%basetime%S = time%basetime%S + &
+          INT( S, ESMF_KIND_I8 )
+      ENDIF
+      IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN
+        CALL wrf_error_fatal( &
+          "ESMF_TimeSet:  Must specify Sd if Sn is specified")
+      ENDIF
+      IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN
+        CALL wrf_error_fatal( &
+          "ESMF_TimeSet:  Must not specify both Sd and MS")
+      ENDIF
+      time%basetime%Sn = 0
+      time%basetime%Sd = 0
+      IF ( PRESENT( MS ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  MS = ',MS
+        time%basetime%Sn = MS
+        time%basetime%Sd = 1000_ESMF_KIND_I8
+      ELSE IF ( PRESENT( Sd ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  Sd = ',Sd
+        time%basetime%Sd = Sd
+        IF ( PRESENT( Sn ) ) THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  Sn = ',Sn
+          time%basetime%Sn = Sn
+        ENDIF
+      ENDIF
+      IF ( PRESENT(calendar) )THEN
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  using passed-in calendar'
+! Note that the ugly hack of wrapping the call to ESMF_CalendarInitialized() 
+! inside this #ifdef is due to lack of support for compile-time initialization 
+! of components of Fortran derived types.  Some older compilers like PGI 5.1-x 
+! do not support this F95 feature.  In this case we only lose a safety check.  
+#ifndef NO_DT_COMPONENT_INIT
+        IF ( .not. ESMF_CalendarInitialized( calendar ) )THEN
+           call wrf_error_fatal( "Error:: ESMF_CalendarCreate not "// &
+                                 "called on input Calendar")
+        END IF
+#endif
+        time%Calendar => calendar
+      ELSE
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  using default calendar'
+        IF ( .not. ESMF_IsInitialized() )THEN
+           call wrf_error_fatal( "Error:: ESMF_Initialize not called")
+        END IF
+        time%Calendar => defaultCal
+      END IF
+
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  calling normalize_time()'
+!$$$DEBUG
+!IF ( time%basetime%Sd > 0 ) THEN
+!  PRINT *,'DEBUG ESMF_TimeSet() before normalize:  S,Sn,Sd = ', &
+!    time%basetime%S, time%basetime%Sn, time%basetime%Sd
+!ENDIF
+!$$$END DEBUG
+      CALL normalize_time( time )
+!$$$DEBUG
+!IF ( time%basetime%Sd > 0 ) THEN
+!  PRINT *,'DEBUG ESMF_TimeSet() after normalize:  S,Sn,Sd = ', &
+!    time%basetime%S, time%basetime%Sn, time%basetime%Sd
+!ENDIF
+!$$$END DEBUG
+
+!  PRINT *,'DEBUG:  ESMF_TimeSet():  back from normalize_time()'
+      IF ( PRESENT( rc ) ) THEN
+        rc = ESMF_SUCCESS
+      ENDIF
+
+      end subroutine ESMF_TimeSet
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMFold_TimeGetString - Get time instant value in string format
+
+! !INTERFACE:
+      subroutine ESMFold_TimeGetString( year, month, dayofmonth, &
+                                        hour, minute, second, TimeString )
+
+! !ARGUMENTS:
+      integer, intent(in) :: year
+      integer, intent(in) :: month
+      integer, intent(in) :: dayofmonth
+      integer, intent(in) :: hour
+      integer, intent(in) :: minute
+      integer, intent(in) :: second
+      character*(*), intent(out) :: TimeString
+! !DESCRIPTION:
+!     Convert {\tt ESMF\_Time}'s value into ISO 8601 format YYYY-MM-DDThh:mm:ss
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The object instance to convert
+!     \item[TimeString]
+!          The string to return
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG2.4.7
+!EOP
+
+!PRINT *,'DEBUG:  ESMF_TimePrint():  YR,S,Sn,Sd = ',time%YR,time%basetime%S,time%basetime%Sn,time%basetime%Sd
+!PRINT *,'DEBUG:  ESMF_TimePrint():  year = ',year
+!PRINT *,'DEBUG:  ESMF_TimePrint():  month, dayofmonth = ',month,dayofmonth
+!PRINT *,'DEBUG:  ESMF_TimePrint():  hour = ',hour
+!PRINT *,'DEBUG:  ESMF_TimePrint():  minute = ',minute
+!PRINT *,'DEBUG:  ESMF_TimePrint():  second = ',second
+
+!$$$here...  add negative sign for YR<0
+!$$$here...  add Sn, Sd ??
+      write(TimeString,FMT="(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)") &
+             year,month,dayofmonth,hour,minute,second
+
+      end subroutine ESMFold_TimeGetString
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeGetDayOfYearInteger - Get time instant's day of the year as an integer value
+!
+! !INTERFACE:
+      subroutine ESMF_TimeGetDayOfYearInteger(time, DayOfYear, rc)
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time
+      integer, intent(out) :: DayOfYear
+      integer, intent(out), optional :: rc
+!
+! !DESCRIPTION:
+!     Get the day of the year the given {\tt ESMF\_Time} instant falls on
+!     (1-365).  Returned as an integer value
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The object instance to query
+!     \item[DayOfYear]
+!          The {\tt ESMF\_Time} instant's day of the year (1-365)
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!EOP
+      ! requires that time be normalized
+!$$$ bug when Sn>0?  test
+!$$$ add tests
+      DayOfYear = ( time%basetime%S / SECONDS_PER_DAY ) + 1
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+      end subroutine ESMF_TimeGetDayOfYearInteger
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeInc - Increment time instant with a time interval
+!
+! !INTERFACE:
+      function ESMF_TimeInc(time, timeinterval)
+!
+! !RETURN VALUE:
+      type(ESMF_Time) :: ESMF_TimeInc
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+! !LOCAL:
+      integer   :: rc
+!
+! !DESCRIPTION:
+!     Increment {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval},
+!     return resulting {\tt ESMF\_Time} instant
+!
+!     Maps overloaded (+) operator interface function to
+!     {\tt ESMF\_BaseTime} base class
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The given {\tt ESMF\_Time} to increment
+!     \item[timeinterval]
+!          The {\tt ESMF\_TimeInterval} to add to the given {\tt ESMF\_Time}
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2
+!EOP
+
+      ! copy ESMF_Time specific properties (e.g. calendar, timezone) 
+      ESMF_TimeInc = time
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeSum(time, timeinterval, ESMF_TimeInc)
+
+      end function ESMF_TimeInc
+!
+! this is added for certain compilers that don't deal with commutativity
+!
+      function ESMF_TimeInc2(timeinterval, time)
+      type(ESMF_Time) :: ESMF_TimeInc2
+      type(ESMF_Time), intent(in) :: time
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      ESMF_TimeInc2 = ESMF_TimeInc( time, timeinterval )
+      end function ESMF_TimeInc2
+!
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeDec - Decrement time instant with a time interval
+!
+! !INTERFACE:
+      function ESMF_TimeDec(time, timeinterval)
+!
+! !RETURN VALUE:
+      type(ESMF_Time) :: ESMF_TimeDec
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+! !LOCAL:
+      integer   :: rc
+!
+! !DESCRIPTION:
+!     Decrement {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval},
+!     return resulting {\tt ESMF\_Time} instant
+!
+!     Maps overloaded (-) operator interface function to
+!     {\tt ESMF\_BaseTime} base class
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time]
+!          The given {\tt ESMF\_Time} to decrement
+!     \item[timeinterval]
+!          The {\tt ESMF\_TimeInterval} to subtract from the given
+!          {\tt ESMF\_Time}
+!     \end{description}
+!     
+! !REQUIREMENTS:
+!     TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2
+!EOP
+
+      ! copy ESMF_Time specific properties (e.g. calendar, timezone) 
+      ESMF_TimeDec = time
+
+      ! call ESMC_BaseTime base class function
+       call c_ESMC_BaseTimeDec(time, timeinterval, ESMF_TimeDec)
+
+      end function ESMF_TimeDec
+
+!
+! this is added for certain compilers that don't deal with commutativity
+!
+      function ESMF_TimeDec2(timeinterval, time)
+      type(ESMF_Time) :: ESMF_TimeDec2
+      type(ESMF_Time), intent(in) :: time
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      ESMF_TimeDec2 = ESMF_TimeDec( time, timeinterval )
+      end function ESMF_TimeDec2
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeDiff - Return the difference between two time instants
+!
+! !INTERFACE:
+      function ESMF_TimeDiff(time1, time2)
+!
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeDiff
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+! !LOCAL:
+      integer :: rc
+
+! !DESCRIPTION:
+!     Return the {\tt ESMF\_TimeInterval} difference between two
+!     {\tt ESMF\_Time} instants
+!
+!     Maps overloaded (-) operator interface function to
+!     {\tt ESMF\_BaseTime} base class
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          The first {\tt ESMF\_Time} instant
+!     \item[time2]
+!          The second {\tt ESMF\_Time} instant
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      CALL ESMF_TimeIntervalSet( ESMF_TimeDiff, rc=rc )
+      call c_ESMC_BaseTimeDiff(time1, time2, ESMF_TimeDiff)
+
+      end function ESMF_TimeDiff
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeEQ - Compare two times for equality
+!
+! !INTERFACE:
+      function ESMF_TimeEQ(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeEQ
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+!
+! !DESCRIPTION:
+!     Return true if both given {\tt ESMF\_Time} instants are equal, false
+!     otherwise.  Maps overloaded (==) operator interface function to
+!     {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! invoke C to C++ entry point for ESMF_BaseTime base class function
+      call c_ESMC_BaseTimeEQ(time1, time2, ESMF_TimeEQ)
+
+      end function ESMF_TimeEQ
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeNE - Compare two times for non-equality
+!
+! !INTERFACE:
+      function ESMF_TimeNE(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeNE
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+
+! !DESCRIPTION:
+!     Return true if both given {\tt ESMF\_Time} instants are not equal, false
+!     otherwise.  Maps overloaded (/=) operator interface function to
+!     {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeNE(time1, time2, ESMF_TimeNE)
+
+      end function ESMF_TimeNE
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeLT - Time instant 1 less than time instant 2 ?
+!
+! !INTERFACE:
+      function ESMF_TimeLT(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeLT
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+!
+! !DESCRIPTION:
+!     Return true if first {\tt ESMF\_Time} instant is less than second
+!     {\tt ESMF\_Time} instant, false otherwise.  Maps overloaded (<)
+!     operator interface function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeLT(time1, time2, ESMF_TimeLT)
+
+      end function ESMF_TimeLT
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeGT - Time instant 1 greater than time instant 2 ?
+!
+! !INTERFACE:
+      function ESMF_TimeGT(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeGT
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+!
+! !DESCRIPTION:
+!     Return true if first {\tt ESMF\_Time} instant is greater than second
+!     {\tt ESMF\_Time} instant, false otherwise.  Maps overloaded (>) operator
+!     interface function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeGT(time1, time2, ESMF_TimeGT)
+
+      end function ESMF_TimeGT
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeLE - Time instant 1 less than or equal to time instant 2 ?
+!
+! !INTERFACE:
+      function ESMF_TimeLE(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeLE
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+!
+! !DESCRIPTION:
+!     Return true if first {\tt ESMF\_Time} instant is less than or equal to
+!     second {\tt ESMF\_Time} instant, false otherwise.  Maps overloaded (<=)
+!     operator interface function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeLE(time1, time2, ESMF_TimeLE)
+
+      end function ESMF_TimeLE
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeGE - Time instant 1 greater than or equal to time instant 2 ?
+!
+! !INTERFACE:
+      function ESMF_TimeGE(time1, time2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeGE
+!
+! !ARGUMENTS:
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+!
+! !DESCRIPTION:
+!     Return true if first {\tt ESMF\_Time} instant is greater than or equal to
+!     second {\tt ESMF\_Time} instant, false otherwise.  Maps overloaded (>=)
+!     operator interface function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[time1]
+!          First time instant to compare
+!     \item[time2]
+!          Second time instant to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeGE(time1, time2, ESMF_TimeGE)
+
+      end function ESMF_TimeGE
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeCopy - Copy a time-instance
+
+! !INTERFACE:
+      subroutine ESMF_TimeCopy(timeout, timein)
+
+! !ARGUMENTS:
+      type(ESMF_Time), intent(out) :: timeout
+      type(ESMF_Time), intent(in) :: timein
+
+! !DESCRIPTION:
+!     Copy a time-instance to a new instance.
+!
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+   
+      timeout%basetime = timein%basetime
+      timeout%YR       = timein%YR
+      timeout%Calendar => timein%Calendar
+
+      end subroutine ESMF_TimeCopy
+
+      end module ESMF_TimeMod
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeInterval.F90 b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeInterval.F90
new file mode 100644
index 00000000..1be28c63
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeInterval.F90
@@ -0,0 +1,1259 @@
+!
+! Earth System Modeling Framework
+! Copyright 2002-2003, University Corporation for Atmospheric Research,
+! Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+! Laboratory, University of Michigan, National Centers for Environmental
+! Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+! NASA Goddard Space Flight Center.
+! Licensed under the GPL.
+!
+!==============================================================================
+!
+!     ESMF TimeInterval Module
+      module ESMF_TimeIntervalMod
+!
+!==============================================================================
+!
+! This file contains the TimeInterval class definition and all TimeInterval
+! class methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include 
+!
+!===============================================================================
+!BOPI
+! !MODULE: ESMF_TimeIntervalMod
+!
+! !DESCRIPTION:
+! Part of Time Manager F90 API wrapper of C++ implemenation
+!
+! Defines F90 wrapper entry points for corresponding
+! C++ implementaion of class {\tt ESMC\_TimeInterval}
+!
+! See {\tt ../include/ESMC\_TimeInterval.h} for complete description
+!
+!------------------------------------------------------------------------------
+! !USES:
+      ! inherit from ESMF base class
+      use ESMF_BaseMod
+
+      ! inherit from base time class
+      use ESMF_BaseTimeMod
+
+      ! associated derived types
+      use ESMF_FractionMod, only : ESMF_Fraction
+      use ESMF_CalendarMod
+
+      implicit none
+!
+!------------------------------------------------------------------------------
+! !PRIVATE TYPES:
+      private
+!------------------------------------------------------------------------------
+!     ! ESMF_TimeInterval
+!
+!     ! F90 class type to match C++ TimeInterval class in size only;
+!     !  all dereferencing within class is performed by C++ implementation
+
+      type ESMF_TimeInterval
+        ! time interval is expressed as basetime
+        type(ESMF_BaseTime) :: basetime  ! inherit base class
+        ! Relative year and month fields support monthly or yearly time 
+        ! intervals.  Many operations are undefined when these fields are 
+        ! non-zero!  
+        INTEGER :: YR                    ! relative year
+        INTEGER :: MM                    ! relative month
+      end type
+
+!------------------------------------------------------------------------------
+! !PUBLIC TYPES:
+      public ESMF_TimeInterval
+!------------------------------------------------------------------------------
+!
+! !PUBLIC MEMBER FUNCTIONS:
+      public ESMF_TimeIntervalGet
+      public ESMF_TimeIntervalSet
+      public ESMFold_TimeIntervalGetString
+      public ESMF_TimeIntervalAbsValue
+      public ESMF_TimeIntervalNegAbsValue
+
+! Required inherited and overridden ESMF_Base class methods
+
+!!!!!!!!! added 20051012, JM
+!      public WRFADDITION_TimeIntervalDIVQuot 
+!!!!!!!!! renamed to simplify testing 20060320, TH
+      public ESMF_TimeIntervalDIVQuot 
+
+      ! This convenience routine is only used by other modules in 
+      ! esmf_time_f90.  
+      public ESMF_TimeIntervalIsPositive
+
+
+! !PRIVATE MEMBER FUNCTIONS:
+ 
+! overloaded operator functions
+ 
+      public operator(/)
+      private ESMF_TimeIntervalQuotI
+
+      public operator(*)
+      private ESMF_TimeIntervalProdI
+
+! Inherited and overloaded from ESMF_BaseTime
+
+      public operator(+)
+      private ESMF_TimeIntervalSum
+
+      public operator(-)
+      private ESMF_TimeIntervalDiff
+
+      public operator(.EQ.)
+      private ESMF_TimeIntervalEQ
+
+      public operator(.NE.)
+      private ESMF_TimeIntervalNE
+
+      public operator(.LT.)
+      private ESMF_TimeIntervalLT
+
+      public operator(.GT.)
+      private ESMF_TimeIntervalGT
+
+      public operator(.LE.)
+      private ESMF_TimeIntervalLE
+
+      public operator(.GE.)
+      private ESMF_TimeIntervalGE
+!EOPI
+
+!==============================================================================
+!
+! INTERFACE BLOCKS
+!
+!==============================================================================
+!BOP
+! !INTERFACE:
+      interface operator(*)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalProdI
+
+! !DESCRIPTION:
+!     This interface overloads the * operator for the {\tt ESMF\_TimeInterval}
+!     class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(/)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalQuotI
+
+! !DESCRIPTION:
+!     This interface overloads the / operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(+)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalSum
+
+! !DESCRIPTION:
+!     This interface overloads the + operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(-)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalDiff
+
+! !DESCRIPTION:
+!     This interface overloads the - operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.EQ.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalEQ
+
+! !DESCRIPTION:
+!     This interface overloads the .EQ. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.NE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalNE
+
+! !DESCRIPTION:
+!     This interface overloads the .NE. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.LT.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalLT
+
+! !DESCRIPTION:
+!     This interface overloads the .LT. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.GT.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalGT
+
+! !DESCRIPTION:
+!     This interface overloads the .GT. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.LE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalLE
+
+! !DESCRIPTION:
+!     This interface overloads the .LE. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+!BOP
+! !INTERFACE:
+      interface operator(.GE.)
+
+! !PRIVATE MEMBER FUNCTIONS:
+      module procedure ESMF_TimeIntervalGE
+
+! !DESCRIPTION:
+!     This interface overloads the .GE. operator for the
+!     {\tt ESMF\_TimeInterval} class
+!
+!EOP
+      end interface
+!
+!------------------------------------------------------------------------------
+
+!==============================================================================
+
+      contains
+
+!==============================================================================
+!
+! Generic Get/Set routines which use F90 optional arguments
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeIntervalGet - Get value in user-specified units
+
+! !INTERFACE:
+      subroutine ESMF_TimeIntervalGet(timeinterval, D, d_r8, S, Sn, Sd, &
+                                      TimeString, rc )
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      integer, intent(out), optional :: D
+      real(ESMF_KIND_R8),      intent(out), optional :: d_r8
+      integer, intent(out), optional :: S
+      integer, intent(out), optional :: Sn
+      integer, intent(out), optional :: Sd
+      character*(*), optional, intent(out) :: TimeString
+      integer, intent(out), optional :: rc
+
+
+! !DESCRIPTION:
+!     Get the value of the {\tt ESMF\_TimeInterval} in units specified by the
+!     user via F90 optional arguments.
+!
+!     Time manager represents and manipulates time internally with integers 
+!     to maintain precision.  Hence, user-specified floating point values are
+!     converted internally from integers.
+!
+!     See {\tt ../include/ESMC\_BaseTime.h} and
+!     {\tt ../include/ESMC\_TimeInterval.h} for complete description.
+!     
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The object instance to query
+!     \item[{[YY]}]
+!          Integer years (>= 32-bit)
+!     \item[{[YYl]}]
+!          Integer years (large, >= 64-bit)
+!     \item[{[MO]}]
+!          Integer months (>= 32-bit)
+!     \item[{[MOl]}]
+!          Integer months (large, >= 64-bit)
+!     \item[{[D]}]
+!          Integer days (>= 32-bit)
+!     \item[{[Dl]}]
+!          Integer days (large, >= 64-bit)
+!     \item[{[H]}]
+!          Integer hours
+!     \item[{[M]}]
+!          Integer minutes
+!     \item[{[S]}]
+!          Integer seconds (>= 32-bit)
+!     \item[{[Sl]}]
+!          Integer seconds (large, >= 64-bit)
+!     \item[{[MS]}]
+!          Integer milliseconds
+!     \item[{[US]}]
+!          Integer microseconds
+!     \item[{[NS]}]
+!          Integer nanoseconds
+!     \item[{[d\_]}]
+!          Double precision days
+!     \item[{[h\_]}]
+!          Double precision hours
+!     \item[{[m\_]}]
+!          Double precision minutes
+!     \item[{[s\_]}]
+!          Double precision seconds
+!     \item[{[ms\_]}]
+!          Double precision milliseconds
+!     \item[{[us\_]}]
+!          Double precision microseconds
+!     \item[{[ns\_]}]
+!          Double precision nanoseconds
+!     \item[{[Sn]}]
+!          Integer fractional seconds - numerator
+!     \item[{[Sd]}]
+!          Integer fractional seconds - denominator
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.1
+!EOP
+      INTEGER(ESMF_KIND_I8) :: seconds
+      INTEGER :: ierr
+
+      ierr = ESMF_SUCCESS
+      seconds = timeinterval%basetime%S
+      ! note that S is overwritten below (if present) if other args are also 
+      ! present
+      IF ( PRESENT(S) ) S = seconds
+      IF ( PRESENT( D ) ) THEN
+        D = seconds / SECONDS_PER_DAY
+        IF ( PRESENT(S) ) S = MOD( seconds, SECONDS_PER_DAY )
+      ENDIF
+      IF ( PRESENT( d_r8 ) ) THEN
+        D_r8 = REAL( seconds, ESMF_KIND_R8 ) / &
+               REAL( SECONDS_PER_DAY, ESMF_KIND_R8 )
+        IF ( PRESENT(S) ) S = MOD( seconds, SECONDS_PER_DAY )
+      ENDIF
+      IF ( PRESENT(Sn) ) THEN
+        Sn = timeinterval%basetime%Sn
+      ENDIF
+      IF ( PRESENT(Sd) ) THEN
+        Sd = timeinterval%basetime%Sd
+      ENDIF
+      IF ( PRESENT( timeString ) ) THEN
+        CALL ESMFold_TimeIntervalGetString( timeinterval, timeString, rc=ierr )
+      ENDIF
+      IF ( PRESENT(rc) ) rc = ierr
+    
+      end subroutine ESMF_TimeIntervalGet
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeIntervalSet - Initialize via user-specified unit set
+
+! !INTERFACE:
+      subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, &
+                                      H, M, S, Sl, MS, US, NS, &
+                                      d_, h_, m_, s_, ms_, us_, ns_, &
+                                      Sn, Sd, rc)
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(out) :: timeinterval
+      integer, intent(in), optional :: YY
+      integer(ESMF_KIND_I8), intent(in), optional :: YYl
+      integer, intent(in), optional :: MM
+      integer(ESMF_KIND_I8), intent(in), optional :: MOl
+      integer, intent(in), optional :: D
+      integer(ESMF_KIND_I8), intent(in), optional :: Dl
+      integer, intent(in), optional :: H
+      integer, intent(in), optional :: M
+      integer, intent(in), optional :: S
+      integer(ESMF_KIND_I8), intent(in), optional :: Sl
+      integer, intent(in), optional :: MS
+      integer, intent(in), optional :: US
+      integer, intent(in), optional :: NS
+      double precision, intent(in), optional :: d_
+      double precision, intent(in), optional :: h_
+      double precision, intent(in), optional :: m_
+      double precision, intent(in), optional :: s_
+      double precision, intent(in), optional :: ms_
+      double precision, intent(in), optional :: us_
+      double precision, intent(in), optional :: ns_
+      integer, intent(in), optional :: Sn
+      integer, intent(in), optional :: Sd
+      integer, intent(out), optional :: rc
+      ! locals
+      INTEGER :: nfeb
+
+! !DESCRIPTION:
+!     Set the value of the {\tt ESMF\_TimeInterval} in units specified by
+!     the user via F90 optional arguments
+!
+!     Time manager represents and manipulates time internally with integers 
+!     to maintain precision.  Hence, user-specified floating point values are
+!     converted internally to integers.
+!
+!     See {\tt ../include/ESMC\_BaseTime.h} and
+!     {\tt ../include/ESMC\_TimeInterval.h} for complete description.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The object instance to initialize
+!     \item[{[YY]}]
+!          Integer number of interval years (>= 32-bit)
+!     \item[{[YYl]}]
+!          Integer number of interval years (large, >= 64-bit)
+!     \item[{[MM]}]
+!          Integer number of interval months (>= 32-bit)
+!     \item[{[MOl]}]
+!          Integer number of interval months (large, >= 64-bit)
+!     \item[{[D]}]
+!          Integer number of interval days (>= 32-bit)
+!     \item[{[Dl]}]
+!          Integer number of interval days (large, >= 64-bit)
+!     \item[{[H]}]
+!          Integer hours
+!     \item[{[M]}]
+!          Integer minutes
+!     \item[{[S]}]
+!          Integer seconds (>= 32-bit)
+!     \item[{[Sl]}]
+!          Integer seconds (large, >= 64-bit)
+!     \item[{[MS]}]
+!          Integer milliseconds
+!     \item[{[US]}]
+!          Integer microseconds
+!     \item[{[NS]}]
+!          Integer nanoseconds
+!     \item[{[d\_]}]
+!          Double precision days
+!     \item[{[h\_]}]
+!          Double precision hours
+!     \item[{[m\_]}]
+!          Double precision minutes
+!     \item[{[s\_]}]
+!          Double precision seconds
+!     \item[{[ms\_]}]
+!          Double precision milliseconds
+!     \item[{[us\_]}]
+!          Double precision microseconds
+!     \item[{[ns\_]}]
+!          Double precision nanoseconds
+!     \item[{[Sn]}]
+!          Integer fractional seconds - numerator
+!     \item[{[Sd]}]
+!          Integer fractional seconds - denominator
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMGn.n.n
+!EOP
+
+      IF ( PRESENT(rc) ) rc = ESMF_FAILURE
+      ! note that YR and MM are relative
+      timeinterval%YR = 0
+      IF ( PRESENT( YY ) ) THEN
+        timeinterval%YR = YY
+      ENDIF
+      timeinterval%MM = 0
+      IF ( PRESENT( MM ) ) THEN
+        timeinterval%MM = MM
+      ENDIF
+      ! Rollover months to years
+      IF      ( abs(timeinterval%MM) .GE. MONTHS_PER_YEAR ) THEN
+        timeinterval%YR = timeinterval%YR + timeinterval%MM/MONTHS_PER_YEAR
+        timeinterval%MM = mod(timeinterval%MM,MONTHS_PER_YEAR)
+      ENDIF
+
+      timeinterval%basetime%S = 0
+      ! For 365-day calendar, immediately convert years to days since we know 
+      ! how to do it in this case.  
+!$$$ replace this hack with something saner...
+      IF ( nfeb( 2004 ) == 28 ) THEN
+        timeinterval%basetime%S = timeinterval%basetime%S + &
+          ( 365_ESMF_KIND_I8 * &
+            INT( timeinterval%YR, ESMF_KIND_I8 ) * SECONDS_PER_DAY )
+        timeinterval%YR = 0
+      ENDIF
+      IF ( PRESENT( D ) ) THEN
+        timeinterval%basetime%S = timeinterval%basetime%S + &
+          ( SECONDS_PER_DAY * INT( D, ESMF_KIND_I8 ) )
+      ENDIF
+!$$$ Push H,M,S,Sn,Sd,MS down into BaseTime constructor from EVERYWHERE
+!$$$ and THEN add ESMF scaling behavior when other args are present...  
+      IF ( PRESENT( H ) ) THEN
+        timeinterval%basetime%S = timeinterval%basetime%S + &
+          ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) )
+      ENDIF
+      IF ( PRESENT( M ) ) THEN
+        timeinterval%basetime%S = timeinterval%basetime%S + &
+          ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) )
+      ENDIF
+      IF ( PRESENT( S ) ) THEN
+        timeinterval%basetime%S = timeinterval%basetime%S + &
+          INT( S, ESMF_KIND_I8 )
+      ENDIF
+      IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN
+        CALL wrf_error_fatal( &
+          "ESMF_TimeIntervalSet:  Must specify Sd if Sn is specified")
+      ENDIF
+      IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN
+        CALL wrf_error_fatal( &
+          "ESMF_TimeIntervalSet:  Must not specify both Sd and MS")
+      ENDIF
+      timeinterval%basetime%Sn = 0
+      timeinterval%basetime%Sd = 0
+      IF ( PRESENT( MS ) ) THEN
+        timeinterval%basetime%Sn = MS
+        timeinterval%basetime%Sd = 1000_ESMF_KIND_I8
+      ELSE IF ( PRESENT( Sd ) ) THEN
+        timeinterval%basetime%Sd = Sd
+        IF ( PRESENT( Sn ) ) THEN
+          timeinterval%basetime%Sn = Sn
+        ENDIF
+      ENDIF
+      CALL normalize_timeint( timeinterval )
+
+      IF ( PRESENT(rc) ) rc = ESMF_SUCCESS
+
+      end subroutine ESMF_TimeIntervalSet
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMFold_TimeIntervalGetString - Get time interval value in string format
+
+! !INTERFACE:
+      subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc)
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      character*(*),  intent(out) :: TimeString
+      integer, intent(out), optional :: rc
+      ! locals
+      integer :: signnormtimeint
+      LOGICAL :: negative
+      INTEGER(ESMF_KIND_I8) :: iS, iSn, iSd, H, M, S
+      character (len=1) :: signstr
+
+! !DESCRIPTION:
+!     Convert {\tt ESMF\_TimeInterval}'s value into string format
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The object instance to convert
+!     \item[TimeString]
+!          The string to return
+!     \item[{[rc]}]
+!          Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.9
+!EOP
+
+! NOTE:  YR, MM, Sn, and Sd are not yet included in the returned string...  
+!PRINT *,'DEBUG ESMFold_TimeIntervalGetString():  YR,MM,S,Sn,Sd = ', &
+!        timeinterval%YR, &
+!        timeinterval%MM, &
+!        timeinterval%basetime%S, &
+!        timeinterval%basetime%Sn, &
+!        timeinterval%basetime%Sd
+
+      negative = ( signnormtimeint( timeInterval ) == -1 )
+      IF ( negative ) THEN
+        iS = -timeinterval%basetime%S
+        iSn = -timeinterval%basetime%Sn
+        signstr = '-'
+      ELSE
+        iS = timeinterval%basetime%S
+        iSn = timeinterval%basetime%Sn
+        signstr = ''
+      ENDIF 
+      iSd = timeinterval%basetime%Sd
+
+      H = mod( iS, SECONDS_PER_DAY ) / SECONDS_PER_HOUR
+      M = mod( iS, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE
+      S = mod( iS, SECONDS_PER_MINUTE )
+
+!$$$here...  need to print Sn and Sd when they are used ???
+
+      write(TimeString,FMT="(A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") &
+        TRIM(signstr), ( iS / SECONDS_PER_DAY ), H, M, S
+
+!write(0,*)'TimeIntervalGetString Sn ',timeinterval%basetime%Sn,' Sd ',timeinterval%basetime%Sd
+
+      rc = ESMF_SUCCESS
+
+      end subroutine ESMFold_TimeIntervalGetString
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalAbsValue - Get the absolute value of a time interval
+
+! !INTERFACE:
+      function ESMF_TimeIntervalAbsValue(timeinterval)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalAbsValue
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+! !LOCAL:
+      integer    :: rc
+
+! !DESCRIPTION:
+!     Return a {\tt ESMF\_TimeInterval}'s absolute value.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The object instance to take the absolute value of.
+!          Absolute value returned as value of function.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.8
+!EOP
+      CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalAbsValue arg1' )
+      ESMF_TimeIntervalAbsValue = timeinterval
+!$$$here...  move implementation into BaseTime
+      ESMF_TimeIntervalAbsValue%basetime%S  = &
+        abs(ESMF_TimeIntervalAbsValue%basetime%S)
+      ESMF_TimeIntervalAbsValue%basetime%Sn = &
+        abs(ESMF_TimeIntervalAbsValue%basetime%Sn )
+
+      end function ESMF_TimeIntervalAbsValue
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalNegAbsValue - Get the negative absolute value of a time interval
+
+! !INTERFACE:
+      function ESMF_TimeIntervalNegAbsValue(timeinterval)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalNegAbsValue
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+! !LOCAL:
+      integer    :: rc
+
+! !DESCRIPTION:
+!     Return a {\tt ESMF\_TimeInterval}'s negative absolute value.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The object instance to take the negative absolute value of.
+!          Negative absolute value returned as value of function.
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.8
+!EOP
+      CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalNegAbsValue arg1' )
+    
+      ESMF_TimeIntervalNegAbsValue = timeinterval
+!$$$here...  move implementation into BaseTime
+      ESMF_TimeIntervalNegAbsValue%basetime%S  = &
+        -abs(ESMF_TimeIntervalNegAbsValue%basetime%S)
+      ESMF_TimeIntervalNegAbsValue%basetime%Sn = &
+        -abs(ESMF_TimeIntervalNegAbsValue%basetime%Sn )
+
+      end function ESMF_TimeIntervalNegAbsValue
+
+!------------------------------------------------------------------------------
+!
+! This section includes overloaded operators defined only for TimeInterval
+! (not inherited from BaseTime)
+! Note:  these functions do not have a return code, since F90 forbids more
+! than 2 arguments for arithmetic overloaded operators
+!
+!------------------------------------------------------------------------------
+
+!!!!!!!!!!!!!!!!!! added jm 20051012
+! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder
+      function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2)
+
+! !RETURN VALUE:
+      INTEGER :: ESMF_TimeIntervalDIVQuot 
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !LOCAL
+      INTEGER :: retval, isgn, rc
+      type(ESMF_TimeInterval) :: zero, i1,i2
+
+! !DESCRIPTION:
+!     Returns timeinterval1 divided by timeinterval2 as a fraction quotient.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          The dividend
+!     \item[timeinterval2]
+!          The divisor
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.5
+!EOP
+
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDIVQuot arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDIVQuot arg2' )
+
+      call ESMF_TimeIntervalSet( zero, rc=rc )
+      i1 = timeinterval1
+      i2 = timeinterval2
+      isgn = 1
+      if ( i1 .LT. zero ) then
+        i1 = ESMF_TimeIntervalProdI(i1, -1)
+        isgn = -isgn
+      endif
+      if ( i2 .LT. zero ) then
+        i2 = ESMF_TimeIntervalProdI(i2, -1)
+        isgn = -isgn
+      endif
+! repeated subtraction
+      retval = 0
+      DO WHILE (  i1 .GE. i2 )
+        i1 = i1 - i2
+        retval = retval + 1
+      ENDDO
+      retval = retval * isgn
+
+      ESMF_TimeIntervalDIVQuot = retval
+
+      end function ESMF_TimeIntervalDIVQuot
+!!!!!!!!!!!!!!!!!!
+
+
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalQuotI - Divide time interval by an integer, return time interval result 
+
+! !INTERFACE:
+      function ESMF_TimeIntervalQuotI(timeinterval, divisor)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalQuotI
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      integer, intent(in) :: divisor
+
+! !DESCRIPTION:
+!     Divides a {\tt ESMF\_TimeInterval} by an integer divisor, returns
+!     quotient as a {\tt ESMF\_TimeInterval}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The dividend
+!     \item[divisor]
+!          Integer divisor
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.6, TMG5.3, TMG7.2
+!EOP
+
+!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A:  S,Sn,Sd = ', &
+!  timeinterval%basetime%S,timeinterval%basetime%Sn,timeinterval%basetime%Sd
+!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A:  divisor = ', divisor
+
+      CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalQuotI arg1' )
+
+      IF ( divisor == 0 ) THEN
+        CALL wrf_error_fatal( 'ESMF_TimeIntervalQuotI:  divide by zero' )
+      ENDIF
+      ESMF_TimeIntervalQuotI = timeinterval
+!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() B:  S,Sn,Sd = ', &
+!  ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd
+      ESMF_TimeIntervalQuotI%basetime = &
+        timeinterval%basetime / divisor
+!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() C:  S,Sn,Sd = ', &
+!  ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd
+
+      CALL normalize_timeint( ESMF_TimeIntervalQuotI )
+!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() D:  S,Sn,Sd = ', &
+!  ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd
+
+      end function ESMF_TimeIntervalQuotI
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:   ESMF_TimeIntervalProdI - Multiply a time interval by an integer
+
+! !INTERFACE:
+      function ESMF_TimeIntervalProdI(timeinterval, multiplier)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalProdI
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+      integer, intent(in) :: multiplier
+! !LOCAL:
+      integer    :: rc
+
+! !DESCRIPTION:
+!     Multiply a {\tt ESMF\_TimeInterval} by an integer, return product as a
+!     {\tt ESMF\_TimeInterval}
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          The multiplicand
+!     \item[mutliplier]
+!          Integer multiplier
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.7, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1' )
+
+      CALL ESMF_TimeIntervalSet( ESMF_TimeIntervalProdI, rc=rc )
+!$$$move this into overloaded operator(*) in BaseTime
+      ESMF_TimeIntervalProdI%basetime%S  = &
+        timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 )
+      ESMF_TimeIntervalProdI%basetime%Sn = &
+        timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 )
+      ! Don't multiply Sd
+      ESMF_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd
+      CALL normalize_timeint( ESMF_TimeIntervalProdI )
+
+      end function ESMF_TimeIntervalProdI
+
+!------------------------------------------------------------------------------
+!
+! This section includes the inherited ESMF_BaseTime class overloaded operators
+!
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalSum - Add two time intervals together
+
+! !INTERFACE:
+      function ESMF_TimeIntervalSum(timeinterval1, timeinterval2)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalSum
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+! !LOCAL:
+      integer                             :: rc
+! !DESCRIPTION:
+!     Add two {\tt ESMF\_TimeIntervals}, return sum as a
+!     {\tt ESMF\_TimeInterval}.  Maps overloaded (+) operator interface
+!     function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          The augend 
+!     \item[timeinterval2]
+!          The addend
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, 
+!                 TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalSum arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalSum arg2' )
+
+      ESMF_TimeIntervalSum = timeinterval1
+      ESMF_TimeIntervalSum%basetime = ESMF_TimeIntervalSum%basetime + &
+                                      timeinterval2%basetime
+
+      CALL normalize_timeint( ESMF_TimeIntervalSum )
+
+      end function ESMF_TimeIntervalSum
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalDiff - Subtract one time interval from another
+   
+! !INTERFACE:
+      function ESMF_TimeIntervalDiff(timeinterval1, timeinterval2)
+
+! !RETURN VALUE:
+      type(ESMF_TimeInterval) :: ESMF_TimeIntervalDiff
+
+! !ARGUMENTS: 
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+! !LOCAL:
+      integer                             :: rc
+! !DESCRIPTION:
+!     Subtract timeinterval2 from timeinterval1, return remainder as a 
+!     {\tt ESMF\_TimeInterval}.
+!     Map overloaded (-) operator interface function to {\tt ESMF\_BaseTime}
+!     base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          The minuend 
+!     \item[timeinterval2]
+!          The subtrahend
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDiff arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDiff arg2' )
+
+      ESMF_TimeIntervalDiff = timeinterval1
+      ESMF_TimeIntervalDiff%basetime = ESMF_TimeIntervalDiff%basetime - &
+                                       timeinterval2%basetime
+      CALL normalize_timeint( ESMF_TimeIntervalDiff )
+
+      end function ESMF_TimeIntervalDiff
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE: ESMF_TimeIntervalEQ - Compare two time intervals for equality
+
+! !INTERFACE:
+      function ESMF_TimeIntervalEQ(timeinterval1, timeinterval2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalEQ
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+!DESCRIPTION:
+!     Return true if both given time intervals are equal, false otherwise.
+!     Maps overloaded (==) operator interface function to {\tt ESMF\_BaseTime}
+!     base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalEQ arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalEQ arg2' )
+
+!$$$here...  move all this out of Meat.F90 ?  
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntEQ(timeinterval1, timeinterval2, ESMF_TimeIntervalEQ)
+
+      end function ESMF_TimeIntervalEQ
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalNE - Compare two time intervals for inequality
+
+! !INTERFACE:
+      function ESMF_TimeIntervalNE(timeinterval1, timeinterval2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalNE
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !DESCRIPTION:
+!     Return true if both given time intervals are not equal, false otherwise.
+!     Maps overloaded (/=) operator interface function to {\tt ESMF\_BaseTime}
+!     base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalNE arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalNE arg2' )
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntNE(timeinterval1, timeinterval2, ESMF_TimeIntervalNE)
+
+      end function ESMF_TimeIntervalNE
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalLT - Time interval 1 less than time interval 2 ?
+
+! !INTERFACE:
+      function ESMF_TimeIntervalLT(timeinterval1, timeinterval2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalLT
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !DESCRIPTION:
+!     Return true if first time interval is less than second time interval,
+!     false otherwise. Maps overloaded (<) operator interface function to
+!     {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalLT arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalLT arg2' )
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntLT(timeinterval1, timeinterval2, ESMF_TimeIntervalLT)
+
+      end function ESMF_TimeIntervalLT
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalGT - Time interval 1 greater than time interval 2?
+
+! !INTERFACE:
+      function ESMF_TimeIntervalGT(timeinterval1, timeinterval2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalGT
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !DESCRIPTION:
+!     Return true if first time interval is greater than second time interval,
+!     false otherwise.  Maps overloaded (>) operator interface function to
+!     {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalGT arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalGT arg2' )
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntGT(timeinterval1, timeinterval2, ESMF_TimeIntervalGT)
+
+      end function ESMF_TimeIntervalGT
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalLE - Time interval 1 less than or equal to time interval 2 ?
+
+! !INTERFACE:
+      function ESMF_TimeIntervalLE(timeinterval1, timeinterval2)
+
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalLE
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !DESCRIPTION:
+!     Return true if first time interval is less than or equal to second time
+!     interval, false otherwise.
+!     Maps overloaded (<=) operator interface function to {\tt ESMF\_BaseTime}
+!     base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalLE arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalLE arg2' )
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntLE(timeinterval1, timeinterval2, ESMF_TimeIntervalLE)
+
+      end function ESMF_TimeIntervalLE
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalGE - Time interval 1 greater than or equal to time interval 2 ?
+
+! !INTERFACE:
+      function ESMF_TimeIntervalGE(timeinterval1, timeinterval2)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalGE
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !DESCRIPTION:
+!     Return true if first time interval is greater than or equal to second
+!     time interval, false otherwise. Maps overloaded (>=) operator interface
+!     function to {\tt ESMF\_BaseTime} base class.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          First time interval to compare
+!     \item[timeinterval2]
+!          Second time interval to compare
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.3, TMG2.4.3, TMG7.2
+!EOP
+      CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalGE arg1' )
+      CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalGE arg2' )
+
+      ! call ESMC_BaseTime base class function
+      call c_ESMC_BaseTimeIntGE(timeinterval1, timeinterval2, ESMF_TimeIntervalGE)
+
+      end function ESMF_TimeIntervalGE
+
+
+!------------------------------------------------------------------------------
+!BOP
+! !IROUTINE:  ESMF_TimeIntervalIsPositive - Time interval greater than zero?
+
+! !INTERFACE:
+      function ESMF_TimeIntervalIsPositive(timeinterval)
+!
+! !RETURN VALUE:
+      logical :: ESMF_TimeIntervalIsPositive
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval
+
+! !LOCALS:
+      type(ESMF_TimeInterval) :: zerotimeint
+      integer :: rcint
+
+! !DESCRIPTION:
+!     Return true if time interval is greater than zero,  
+!     false otherwise. 
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval]
+!          Time interval to compare
+!     \end{description}
+!EOP
+      CALL timeintchecknormalized( timeinterval, &
+                                   'ESMF_TimeIntervalIsPositive arg' )
+
+      CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint )
+      IF ( rcint /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal( &
+          'ESMF_TimeIntervalIsPositive:  ESMF_TimeIntervalSet failed' )
+      ENDIF
+! hack for bug in PGI 5.1-x
+!      ESMF_TimeIntervalIsPositive = timeinterval > zerotimeint
+      ESMF_TimeIntervalIsPositive = ESMF_TimeIntervalGT( timeinterval, &
+                                                         zerotimeint )
+      end function ESMF_TimeIntervalIsPositive
+
+      end module ESMF_TimeIntervalMod
+
+
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc
new file mode 100644
index 00000000..2349491a
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc
@@ -0,0 +1,60 @@
+#if 0
+ 
+Earth System Modeling Framework
+Copyright 2002-2003, University Corporation for Atmospheric Research,
+Massachusetts Institute of Technology, Geophysical Fluid Dynamics
+Laboratory, University of Michigan, National Centers for Environmental
+Prediction, Los Alamos National Laboratory, Argonne National Laboratory,
+NASA Goddard Space Flight Center.
+Licensed under the GPL.
+
+Do not have C++ or F90 style comments in here because this file is processed
+by both C++ and F90 compilers.
+#endif
+
+#ifndef ESMF_TimeMgr_INC
+#define ESMF_TimeMgr_INC
+
+#if 0
+!BOP
+-------------------------------------------------------------------------
+
+ !DESCRIPTION:
+
+ ESMF TimeMgr include file for F90
+ The code in this file implements constants and macros for the TimeMgr...
+
+-------------------------------------------------------------------------
+!EOP
+#endif
+
+#include 
+
+#define SECONDS_PER_DAY 86400_ESMF_KIND_I8
+#define SECONDS_PER_HOUR 3600_ESMF_KIND_I8
+#define SECONDS_PER_MINUTE 60_ESMF_KIND_I8
+#define HOURS_PER_DAY 24_ESMF_KIND_I8
+
+! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in 
+! ../../frame/module_domain.F !!!  Eliminate this dependence with 
+! grow-as-you-go AlarmList in ESMF_Clock...  
+#define MAX_ALARMS 28
+
+! TBH:  TODO:  Hook this into the WRF build so WRF can use either "no-leap" or 
+! TBH:         Gregorian calendar.  Now WRF is hard-wired to use Gregorian.  
+#undef NO_LEAP_CALENDAR
+#ifdef COUP_CSM
+#define NO_LEAP_CALENDAR
+#endif
+
+! TBH:  When NO_DT_COMPONENT_INIT is set, code that uses F95 compile-time 
+! TBH:  initialization of components of derived types is not included.  
+! TBH:  Some older compilers like PGI 5.x do not support this F95 
+! TBH:  feature.
+#ifdef NO_LEAP_CALENDAR
+#undef NO_DT_COMPONENT_INIT
+#else
+#define NO_DT_COMPONENT_INIT
+#endif
+
+#endif
diff --git a/wrfv2_fire/external/esmf_time_f90/Makefile b/wrfv2_fire/external/esmf_time_f90/Makefile
new file mode 100644
index 00000000..2eb9fa02
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/Makefile
@@ -0,0 +1,100 @@
+# To build this by itself, use the make target esmf_time_f90_only 
+# from the top-level WRF Makefile.  
+# > cd ../..
+# configure
+# make esmf_time_f90_only
+
+.SUFFIXES: .F90 .o .f
+
+# get rid of single quotes after comments
+# WARNING:  This will break if a quoted string is followed by a comment that has
+#           a single quote.
+SED_FTN = sed -e "/\!.*'/s/'//g"
+
+RM = /bin/rm -f
+AR = ar
+#RANLIB	= ranlib
+RANLIB	= echo
+
+OBJS = ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \
+        Meat.o ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o   \
+        ESMF_TimeInterval.o ESMF_Stubs.o ESMF_Mod.o \
+        module_symbols_util.o \
+	module_utility.o ESMF_AlarmClock.o
+
+default: libesmf_time.a
+
+tests: Test1_ESMF.exe Test1_WRFU.exe
+
+libesmf_time.a : $(OBJS)
+	$(RM) libesmf_time.a
+	$(AR) ru libesmf_time.a $(OBJS)
+	$(RANLIB) libesmf_time.a
+
+Test1_ESMF.f : Test1.F90
+	$(RM) Test1_ESMF.b Test1_ESMF.f
+	cp Test1.F90 Test1_ESMF.b
+	$(CPP) -C -P -I. Test1_ESMF.b > Test1_ESMF.f
+
+Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o
+	$(FC) -o Test1_ESMF.exe Test1_ESMF.o libesmf_time.a
+
+Test1_WRFU.f : Test1.F90
+	$(RM) Test1_WRFU.b Test1_WRFU.f
+	sed -e "s/ESMF_Mod/module_utility/g" -e "s/ESMF_/WRFU_/g" Test1.F90 > Test1_WRFU.b
+	$(CPP) -C -P -I. Test1_WRFU.b > Test1_WRFU.f
+
+Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o
+	$(FC) -o Test1_WRFU.exe Test1_WRFU.o libesmf_time.a
+
+.F90.o :
+	$(RM) $@
+	$(SED_FTN) $*.F90 > $*.b
+	$(CPP) -C -P -I. $*.b > $*.f
+	$(RM) $*.b
+	$(FC) -c $*.f
+
+.F90.f :
+	$(RM) $@
+	$(SED_FTN) $*.F90 > $*.b
+	$(CPP) -C -P -I. $*.b > $*.f
+	$(RM) $*.b
+
+.f.o :
+	$(RM) $@
+	$(RM) $*.b
+	$(FC) -c $*.f
+
+clean : testclean
+
+testclean: 
+	$(RM) *.b *.f *.o libesmf_time.a *.mod Test1*.exe
+
+superclean: testclean
+	$(RM) Test1*.out make_tests.out
+
+# DEPENDENCIES : only dependencies after this line 
+
+#$$$ update dependencies!  
+
+ESMF_Alarm.o : ESMF_BaseTime.o ESMF_Time.o ESMF_TimeInterval.o
+ESMF_BaseTime.o : ESMF_Base.o
+ESMF_Clock.o : ESMF_BaseTime.o ESMF_Time.o ESMF_TimeInterval.o
+ESMF_AlarmClock.o : ESMF_Alarm.o ESMF_Clock.o
+ESMF_Time.o : ESMF_BaseTime.o ESMF_TimeInterval.o ESMF_Calendar.o \
+              ESMF_Stubs.o
+ESMF_Base.o :
+ESMF_Calendar.o : ESMF_BaseTime.o
+ESMF_Fraction.o : ESMF_BaseTime.o
+ESMF_TimeInterval.o : ESMF_BaseTime.o ESMF_Calendar.o ESMF_Fraction.o
+ESMF_Mod.o : ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \
+        ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o    \
+        ESMF_TimeInterval.o Meat.o ESMF_Stubs.o ESMF_AlarmClock.o
+Meat.o : ESMF_Alarm.o ESMF_BaseTime.o ESMF_Clock.o ESMF_Time.o \
+        ESMF_Base.o ESMF_Calendar.o ESMF_Fraction.o    \
+        ESMF_TimeInterval.o
+ESMF_Stubs.o : ESMF_Base.o ESMF_Calendar.o
+module_utility.o :  ESMF_Mod.o module_symbols_util.o
+module_symbols_util.o :  ESMF_Mod.o
+Test1.o :  module_utility.o
+
diff --git a/wrfv2_fire/external/esmf_time_f90/Meat.F90 b/wrfv2_fire/external/esmf_time_f90/Meat.F90
new file mode 100644
index 00000000..e9c72676
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/Meat.F90
@@ -0,0 +1,893 @@
+#include 
+
+! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match.  
+! Also, enforce consistency.  
+! YR and MM fields are ignored.  
+SUBROUTINE normalize_basetime( basetime )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  IMPLICIT NONE
+  TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime
+!PRINT *,'DEBUG:  BEGIN normalize_basetime()'
+  ! Consistency check...  
+  IF ( basetime%Sd < 0 ) THEN
+    CALL wrf_error_fatal( &
+      'normalize_basetime:  denominator of seconds cannot be negative' )
+  ENDIF
+  IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN
+    CALL wrf_error_fatal( &
+      'normalize_basetime:  denominator of seconds cannot be zero when numerator is non-zero' )
+  ENDIF
+  ! factor so abs(Sn) < Sd
+  IF ( basetime%Sd > 0 ) THEN
+    IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN
+!PRINT *,'DEBUG:  normalize_basetime() A1:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+      basetime%S = basetime%S + ( basetime%Sn / basetime%Sd )
+      basetime%Sn = mod( basetime%Sn, basetime%Sd )
+!PRINT *,'DEBUG:  normalize_basetime() A2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+    ENDIF
+    ! change sign of Sn if it does not match S
+    IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN
+!PRINT *,'DEBUG:  normalize_basetime() B1:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+      basetime%S = basetime%S - 1_ESMF_KIND_I8
+      basetime%Sn = basetime%Sn + basetime%Sd
+!PRINT *,'DEBUG:  normalize_basetime() B2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+    ENDIF
+    IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN
+!PRINT *,'DEBUG:  normalize_basetime() C1:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+      basetime%S = basetime%S + 1_ESMF_KIND_I8
+      basetime%Sn = basetime%Sn - basetime%Sd
+!PRINT *,'DEBUG:  normalize_basetime() C2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
+    ENDIF
+  ENDIF
+!PRINT *,'DEBUG:  END normalize_basetime()'
+END SUBROUTINE normalize_basetime
+
+
+
+! A normalized time has time%basetime >= 0, time%basetime less than the current 
+! year expressed as a timeInterval, and time%YR can take any value
+SUBROUTINE normalize_time( time )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  INTEGER(ESMF_KIND_I8) :: nsecondsinyear
+  ! locals
+  TYPE(ESMF_BaseTime) :: cmptime, zerotime
+  INTEGER :: rc
+  LOGICAL :: done
+
+  ! first, normalize basetime
+  ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
+  CALL normalize_basetime( time%basetime )
+
+!$$$ add tests for these edge cases
+
+  ! next, underflow negative seconds into YEARS
+  ! time%basetime must end up non-negative
+!$$$ push this down into ESMF_BaseTime constructor
+  zerotime%S  = 0
+  zerotime%Sn = 0
+  zerotime%Sd = 0
+  DO WHILE ( time%basetime < zerotime )
+    time%YR = time%YR - 1 
+!$$$ push this down into ESMF_BaseTime constructor
+    cmptime%S  = nsecondsinyear( time%YR )
+    cmptime%Sn = 0
+    cmptime%Sd = 0
+    time%basetime = time%basetime + cmptime
+  ENDDO
+
+  ! next, overflow seconds into YEARS
+  done = .FALSE.
+  DO WHILE ( .NOT. done )
+!$$$ push this down into ESMF_BaseTime constructor
+    cmptime%S  = nsecondsinyear( time%YR )
+    cmptime%Sn = 0
+    cmptime%Sd = 0
+    IF ( time%basetime >= cmptime ) THEN
+      time%basetime = time%basetime - cmptime
+      time%YR = time%YR + 1 
+    ELSE
+      done = .TRUE.
+    ENDIF
+  ENDDO
+END SUBROUTINE normalize_time
+
+
+
+SUBROUTINE normalize_timeint( timeInt )
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt
+
+  ! normalize basetime
+  ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
+  ! YR and MM are ignored
+  CALL normalize_basetime( timeInt%basetime )
+END SUBROUTINE normalize_timeint
+
+
+
+
+FUNCTION signnormtimeint ( timeInt )
+  ! Compute the sign of a time interval.  
+  ! YR and MM fields are *IGNORED*.  
+  ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs.
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
+  INTEGER :: signnormtimeint
+  LOGICAL :: positive, negative
+
+  positive = .FALSE.
+  negative = .FALSE.
+  signnormtimeint = 0
+  ! Note that Sd is required to be non-negative.  This is enforced in 
+  ! normalize_timeint().  
+  ! Note that Sn is required to be zero when Sd is zero.  This is enforced 
+  ! in normalize_timeint().  
+  IF ( ( timeInt%basetime%S > 0 ) .OR. &
+       ( timeInt%basetime%Sn > 0 ) ) THEN
+    positive = .TRUE.
+  ENDIF
+  IF ( ( timeInt%basetime%S < 0 ) .OR. &
+       ( timeInt%basetime%Sn < 0 ) ) THEN
+    negative = .TRUE.
+  ENDIF
+  IF ( positive .AND. negative ) THEN
+    CALL wrf_error_fatal( &
+      'signnormtimeint:  signs of fields cannot be mixed' )
+  ELSE IF ( positive ) THEN
+    signnormtimeint = 1
+  ELSE IF ( negative ) THEN
+    signnormtimeint = -1
+  ENDIF
+END FUNCTION signnormtimeint
+
+
+! Exits with error message if timeInt is not normalized.  
+SUBROUTINE timeintchecknormalized( timeInt, msgstr )
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
+  CHARACTER(LEN=*), INTENT(IN) :: msgstr
+  ! locals
+  CHARACTER(LEN=256) :: outstr
+  IF ( ( timeInt%YR /= 0 ) .OR. &
+       ( timeInt%MM /= 0 ) ) THEN
+    outstr = 'un-normalized TimeInterval not allowed:  '//TRIM(msgstr)
+    CALL wrf_error_fatal( outstr )
+  ENDIF
+END SUBROUTINE timeintchecknormalized
+
+
+! added from share/module_date_time in WRF.
+FUNCTION nfeb ( year ) RESULT (num_days)
+      ! Compute the number of days in February for the given year
+      IMPLICIT NONE
+      INTEGER :: year
+      INTEGER :: num_days
+! TBH:  TODO:  Replace this hack with run-time decision based on 
+! TBH:  TODO:  passed-in calendar.  
+#ifdef NO_LEAP_CALENDAR
+      num_days = 28 ! By default, February has 28 days ...
+#else
+      num_days = 28 ! By default, February has 28 days ...
+      IF (MOD(year,4).eq.0) THEN
+         num_days = 29  ! But every four years, it has 29 days ...
+         IF (MOD(year,100).eq.0) THEN
+            num_days = 28  ! Except every 100 years, when it has 28 days ...
+            IF (MOD(year,400).eq.0) THEN
+               num_days = 29  ! Except every 400 years, when it has 29 days.
+            END IF
+         END IF
+      END IF
+#endif
+END FUNCTION nfeb
+
+
+
+FUNCTION ndaysinyear ( year ) RESULT (num_diy)
+  ! Compute the number of days in the given year
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: year
+  INTEGER :: num_diy
+  INTEGER :: nfeb
+  IF ( nfeb( year ) .EQ. 29 ) THEN
+    num_diy = 366
+  ELSE
+    num_diy = 365
+  ENDIF
+END FUNCTION ndaysinyear
+
+
+
+FUNCTION nsecondsinyear ( year ) RESULT (numseconds)
+  ! Compute the number of seconds in the given year
+  USE esmf_basemod
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: year
+  INTEGER(ESMF_KIND_I8) :: numseconds
+  INTEGER :: ndaysinyear
+  numseconds = SECONDS_PER_DAY * INT( ndaysinyear(year) , ESMF_KIND_I8 )
+END FUNCTION nsecondsinyear
+
+
+
+SUBROUTINE initdaym 
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE ESMF_CalendarMod
+  IMPLICIT NONE
+  INTEGER i,j,m
+  m = 1
+  mdaycum(0) = 0
+!$$$ push this down into ESMF_BaseTime constructor
+  monthbdys(0)%S  = 0
+  monthbdys(0)%Sn = 0
+  monthbdys(0)%Sd = 0
+  DO i = 1,MONTHS_PER_YEAR
+    DO j = 1,mday(i)
+      daym(m) = i
+      m = m + 1
+    ENDDO
+    mdaycum(i) = mdaycum(i-1) + mday(i)
+!$$$ push this down into ESMF_BaseTime constructor
+    monthbdys(i)%S  = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 )
+    monthbdys(i)%Sn = 0
+    monthbdys(i)%Sd = 0
+  ENDDO
+  m = 1
+  mdayleapcum(0) = 0
+!$$$ push this down into ESMF_BaseTime constructor
+  monthbdysleap(0)%S  = 0
+  monthbdysleap(0)%Sn = 0
+  monthbdysleap(0)%Sd = 0
+  DO i = 1,MONTHS_PER_YEAR
+    DO j = 1,mdayleap(i)
+      daymleap(m) = i
+      m = m + 1
+    ENDDO
+    mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i)
+!$$$ push this down into ESMF_BaseTime constructor
+    monthbdysleap(i)%S  = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 )
+    monthbdysleap(i)%Sn = 0
+    monthbdysleap(i)%Sd = 0
+  ENDDO
+END SUBROUTINE initdaym
+
+
+!$$$ useful, but not used at the moment...  
+SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear)
+  use ESMF_CalendarMod
+IMPLICIT NONE
+      INTEGER, INTENT(IN)  :: YR,MM,DD   ! DD is day of month
+      INTEGER, INTENT(OUT) :: dayinyear
+      INTEGER i
+      integer nfeb
+
+      dayinyear = 0
+      DO i = 1,MM-1
+        if (i.eq.2) then
+          dayinyear = dayinyear + nfeb(YR)
+        else
+          dayinyear = dayinyear + mday(i)
+        endif
+      ENDDO
+      dayinyear = dayinyear + DD
+END SUBROUTINE compute_dayinyear
+
+
+
+SUBROUTINE timegetmonth( time, MM )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE esmf_calendarmod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time
+  INTEGER, INTENT(OUT) :: MM
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: i
+  TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
+  IF ( nfeb(time%YR) == 29 ) THEN
+    MMbdys => monthbdysleap
+  ELSE
+    MMbdys => monthbdys
+  ENDIF
+  MM = -1
+  DO i = 1,MONTHS_PER_YEAR
+    IF ( ( time%basetime >= MMbdys(i-1) ) .AND. ( time%basetime < MMbdys(i) ) ) THEN
+      MM = i
+      EXIT
+    ENDIF
+  ENDDO
+  IF ( MM == -1 ) THEN
+    CALL wrf_error_fatal( 'timegetmonth:  could not extract month of year from time' )
+  ENDIF
+END SUBROUTINE timegetmonth
+
+
+!$$$ may need to change dependencies in Makefile...  
+
+SUBROUTINE timegetdayofmonth( time, DD )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE esmf_calendarmod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time
+  INTEGER, INTENT(OUT) :: DD
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+  TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
+  TYPE(ESMF_BaseTime) :: tmpbasetime
+!$$$ fix this so init just points MMbdys to the one we want for this calendar?
+  IF ( nfeb(time%YR) == 29 ) THEN
+    MMbdys => monthbdysleap
+  ELSE
+    MMbdys => monthbdys
+  ENDIF
+  CALL timegetmonth( time, MM )
+  tmpbasetime = time%basetime - MMbdys(MM-1)
+  DD = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1
+END SUBROUTINE timegetdayofmonth
+
+
+! Increment Time by number of seconds between start of year and start 
+! of month MM.  
+! 1 <= MM <= 12
+! Time is NOT normalized.  
+SUBROUTINE timeaddmonths( time, MM, ierr )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE esmf_calendarmod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  INTEGER, INTENT(IN) :: MM
+  INTEGER, INTENT(OUT) :: ierr
+  ! locals
+  INTEGER :: nfeb
+  TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
+  ierr = ESMF_SUCCESS
+!  PRINT *,'DEBUG:  BEGIN timeaddmonths()'
+  IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN
+    CALL wrf_message( 'ERROR timeaddmonths():  MM out of range' )
+    ierr = ESMF_FAILURE
+  ENDIF
+!  PRINT *,'DEBUG:  timeaddmonths(): MM = ',MM
+!$$$ fix this so init just points MMbdys to the one we want for this calendar?
+!  PRINT *,'DEBUG:  timeaddmonths(): time%YR = ',time%YR
+!  PRINT *,'DEBUG:  timeaddmonths(): time%basetime%S = ',time%basetime%S
+!  PRINT *,'DEBUG:  timeaddmonths(): time%basetime%Sn = ',time%basetime%Sn
+!  PRINT *,'DEBUG:  timeaddmonths(): time%basetime%Sd = ',time%basetime%Sd
+  IF ( nfeb(time%YR) == 29 ) THEN
+!  PRINT *,'DEBUG:  timeaddmonths(): leap year'
+    MMbdys => monthbdysleap
+  ELSE
+!  PRINT *,'DEBUG:  timeaddmonths(): not leap year'
+    MMbdys => monthbdys
+  ENDIF
+!  PRINT *,'DEBUG:  timeaddmonths(): done pointing to MMbdys'
+!  PRINT *,'DEBUG:  timeaddmonths(): MMbdys(',MM-1,')%S = ',MMbdys(MM-1)%S
+!  PRINT *,'DEBUG:  timeaddmonths(): MMbdys(',MM-1,')%Sn = ',MMbdys(MM-1)%Sn
+!  PRINT *,'DEBUG:  timeaddmonths(): MMbdys(',MM-1,')%Sd = ',MMbdys(MM-1)%Sd
+!$$$ dumps core here...  
+  time%basetime = time%basetime + MMbdys(MM-1)
+!  PRINT *,'DEBUG:  END timeaddmonths()'
+END SUBROUTINE timeaddmonths
+
+
+! Increment Time by number of seconds in the current month.  
+! Time is NOT normalized.  
+SUBROUTINE timeincmonth( time )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE esmf_calendarmod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+  CALL timegetmonth( time, MM )
+  IF ( nfeb(time%YR) == 29 ) THEN
+    time%basetime%S = time%basetime%S + &
+      ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
+  ELSE
+    time%basetime%S = time%basetime%S + &
+      ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
+  ENDIF
+END SUBROUTINE timeincmonth
+
+
+
+! Decrement Time by number of seconds in the previous month.  
+! Time is NOT normalized.  
+SUBROUTINE timedecmonth( time )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE esmf_calendarmod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+  CALL timegetmonth( time, MM )  ! current month, 1-12
+  ! find previous month
+  MM = MM - 1
+  IF ( MM == 0 ) THEN
+    ! wrap around Jan -> Dec
+    MM = MONTHS_PER_YEAR
+  ENDIF
+  IF ( nfeb(time%YR) == 29 ) THEN
+    time%basetime%S = time%basetime%S - &
+      ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
+  ELSE
+    time%basetime%S = time%basetime%S - &
+      ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
+  ENDIF
+END SUBROUTINE timedecmonth
+
+
+
+! spaceship operator for Times
+SUBROUTINE timecmp(time1, time2, retval )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  IMPLICIT NONE
+  INTEGER, INTENT(OUT) :: retval
+!
+! !ARGUMENTS:
+  TYPE(ESMF_Time), INTENT(IN) :: time1
+  TYPE(ESMF_Time), INTENT(IN) :: time2
+  IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF
+  IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF
+  CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, &
+               time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, &
+               retval )
+END SUBROUTINE timecmp
+
+
+
+! spaceship operator for TimeIntervals
+SUBROUTINE timeintcmp(timeint1, timeint2, retval )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  INTEGER, INTENT(OUT) :: retval
+!
+! !ARGUMENTS:
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' )
+  CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' )
+  CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, &
+               timeint1%basetime%Sd,                      &
+               timeint2%basetime%S, timeint2%basetime%Sn, &
+               timeint2%basetime%Sd, retval )
+END SUBROUTINE timeintcmp
+
+
+
+! spaceship operator for seconds + Sn/Sd
+SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval )
+  USE esmf_basemod
+  IMPLICIT NONE
+  INTEGER, INTENT(OUT) :: retval
+!
+! !ARGUMENTS:
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2
+! local
+  INTEGER(ESMF_KIND_I8) :: lcd, n1, n2
+
+  n1 = Sn1
+  n2 = Sn2
+  if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then
+    CALL compute_lcd( Sd1, Sd2, lcd )
+    if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 )
+    if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 )
+  endif
+
+  if ( S1 .GT. S2 ) retval = 1
+  if ( S1 .LT. S2 ) retval = -1
+  IF ( S1 .EQ. S2 ) THEN
+    IF (n1 .GT. n2) retval = 1
+    IF (n1 .LT. n2) retval = -1
+    IF (n1 .EQ. n2) retval = 0
+  ENDIF
+END SUBROUTINE seccmp
+
+
+SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+IMPLICIT NONE
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .EQ. 0)
+END SUBROUTINE c_esmc_basetimeeq
+SUBROUTINE c_esmc_basetimege(time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .EQ. 1 .OR. res .EQ. 0)
+END SUBROUTINE c_esmc_basetimege
+SUBROUTINE c_esmc_basetimegt(time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+IMPLICIT NONE
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .EQ. 1)
+END SUBROUTINE c_esmc_basetimegt
+SUBROUTINE c_esmc_basetimele(time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+IMPLICIT NONE
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .EQ. -1 .OR. res .EQ. 0)
+END SUBROUTINE c_esmc_basetimele
+SUBROUTINE c_esmc_basetimelt(time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+IMPLICIT NONE
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .EQ. -1)
+END SUBROUTINE c_esmc_basetimelt
+SUBROUTINE c_esmc_basetimene(time1, time2, outflag)
+  USE esmf_alarmmod
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_calendarmod
+  USE esmf_clockmod
+  USE esmf_fractionmod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+IMPLICIT NONE
+      logical, intent(OUT) :: outflag
+      type(ESMF_Time), intent(in) :: time1
+      type(ESMF_Time), intent(in) :: time2
+      integer res 
+      CALL timecmp(time1,time2,res)
+      outflag = (res .NE. 0)
+END SUBROUTINE c_esmc_basetimene
+
+SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .EQ. 0)
+END SUBROUTINE c_esmc_basetimeinteq
+SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .NE. 0)
+END SUBROUTINE c_esmc_basetimeintne
+SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .LT. 0)
+END SUBROUTINE c_esmc_basetimeintlt
+SUBROUTINE c_esmc_basetimeintgt(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .GT. 0)
+END SUBROUTINE c_esmc_basetimeintgt
+SUBROUTINE c_esmc_basetimeintle(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .LE. 0)
+END SUBROUTINE c_esmc_basetimeintle
+SUBROUTINE c_esmc_basetimeintge(timeint1, timeint2, outflag)
+  USE esmf_timeintervalmod
+  IMPLICIT NONE
+  LOGICAL, INTENT(OUT) :: outflag
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
+  INTEGER :: res 
+  CALL timeintcmp(timeint1,timeint2,res)
+  outflag = (res .GE. 0)
+END SUBROUTINE c_esmc_basetimeintge
+
+SUBROUTINE compute_lcd( e1, e2, lcd )
+  USE esmf_basemod
+      IMPLICIT NONE
+      INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2
+      INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd
+      INTEGER, PARAMETER ::  nprimes = 9
+      INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
+      INTEGER i
+      INTEGER(ESMF_KIND_I8) d1, d2, p
+
+      d1 = e1 ; d2 = e2
+      IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF
+      IF ( d1 .EQ. 0 ) d1 = d2 
+      IF ( d2 .EQ. 0 ) d2 = d1 
+      IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF
+      lcd = d1 * d2
+      DO i = 1, nprimes
+        p = primes(i)
+        DO WHILE (lcd/p .NE. 0 .AND. &
+          mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) 
+          lcd = lcd / p 
+        END DO
+      ENDDO
+END SUBROUTINE compute_lcd
+
+SUBROUTINE simplify( ni, di, no, do ) 
+  USE esmf_basemod
+    IMPLICIT NONE
+    INTEGER(ESMF_KIND_I8), INTENT(IN)  :: ni, di
+    INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
+    INTEGER, PARAMETER ::  nprimes = 9
+    INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
+    INTEGER(ESMF_KIND_I8) :: pr, d, n
+    INTEGER :: np
+    LOGICAL keepgoing
+    IF ( ni .EQ. 0 ) THEN
+      do = 1
+      no = 0
+      RETURN
+    ENDIF
+    IF ( mod( di , ni ) .EQ. 0 ) THEN
+      do = di / ni
+      no = 1
+      RETURN
+    ENDIF
+    d = di
+    n = ni
+    DO np = 1, nprimes
+      pr = primes(np)
+      keepgoing = .TRUE.
+      DO WHILE ( keepgoing )
+        keepgoing = .FALSE.
+        IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
+          d = d / pr
+          n = n / pr
+          keepgoing = .TRUE.
+        ENDIF
+      ENDDO
+    ENDDO
+    do = d
+    no = n
+    RETURN
+END SUBROUTINE simplify
+
+
+!$$$ this should be named "c_esmc_timesum" or something less misleading
+SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
+  TYPE(ESMF_Time), INTENT(INOUT) :: timeOut
+  ! locals
+  INTEGER :: m
+  timeOut = time1
+  timeOut%basetime = timeOut%basetime + timeinterval%basetime
+  DO m = 1, abs(timeinterval%MM)
+    IF ( timeinterval%MM > 0 ) THEN
+      CALL timeincmonth( timeOut )
+    ELSE
+      CALL timedecmonth( timeOut )
+    ENDIF
+  ENDDO
+  timeOut%YR = timeOut%YR + timeinterval%YR
+  CALL normalize_time( timeOut )
+END SUBROUTINE c_esmc_basetimesum
+
+
+!$$$ this should be named "c_esmc_timedec" or something less misleading
+SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time1
+  TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
+  TYPE(ESMF_Time), INTENT(OUT) :: timeOut
+  ! locals
+  TYPE (ESMF_TimeInterval)  :: neginterval 
+  neginterval = timeinterval
+!$$$push this down into a unary negation operator on TimeInterval
+  neginterval%basetime%S = -neginterval%basetime%S
+  neginterval%basetime%Sn = -neginterval%basetime%Sn
+  neginterval%YR = -neginterval%YR
+  neginterval%MM = -neginterval%MM
+  timeOut = time1 + neginterval
+END SUBROUTINE c_esmc_basetimedec
+
+
+!$$$ this should be named "c_esmc_timediff" or something less misleading
+SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timeintervalmod
+  USE esmf_timemod
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time1
+  TYPE(ESMF_Time), INTENT(IN) :: time2
+  TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut
+  ! locals
+  INTEGER(ESMF_KIND_I8) :: nsecondsinyear
+  INTEGER :: yr
+  CALL ESMF_TimeIntervalSet( timeIntOut )
+  timeIntOut%basetime = time1%basetime - time2%basetime
+  ! convert difference in years to basetime...  
+  IF ( time1%YR > time2%YR ) THEN
+    DO yr = time2%YR, ( time1%YR - 1 )
+      timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr )
+    ENDDO
+  ELSE IF ( time2%YR > time1%YR ) THEN
+    DO yr = time1%YR, ( time2%YR - 1 )
+      timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr )
+    ENDDO
+  ENDIF
+!$$$ add tests for multi-year differences
+  CALL normalize_timeint( timeIntOut )
+END SUBROUTINE c_esmc_basetimediff
+
+
+! some extra wrf stuff
+
+
+! Convert fraction to string with leading sign.
+! If fraction simplifies to a whole number or if
+! denominator is zero, return empty string.
+! INTEGER*8 interface.  
+SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
+  USE ESMF_basemod
+  IMPLICIT NONE
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
+  CHARACTER (LEN=*), INTENT(OUT) :: frac_str
+  IF ( denominator > 0 ) THEN
+    IF ( mod( numerator, denominator ) /= 0 ) THEN
+      IF ( numerator > 0 ) THEN
+        WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
+      ELSE   ! numerator < 0
+        WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
+      ENDIF
+    ELSE   ! includes numerator == 0 case
+      frac_str = ''
+    ENDIF
+  ELSE   ! no-fraction case
+    frac_str = ''
+  ENDIF
+END SUBROUTINE fraction_to_stringi8
+
+
+! Convert fraction to string with leading sign.
+! If fraction simplifies to a whole number or if
+! denominator is zero, return empty string.
+! INTEGER interface.  
+SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
+  USE ESMF_basemod
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: numerator
+  INTEGER, INTENT(IN) :: denominator
+  CHARACTER (LEN=*), INTENT(OUT) :: frac_str
+  ! locals
+  INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
+  numerator_i8 = INT( numerator, ESMF_KIND_I8 )
+  denominator_i8 = INT( denominator, ESMF_KIND_I8 )
+  CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
+END SUBROUTINE fraction_to_string
+
+
+SUBROUTINE print_a_time( time )
+   use ESMF_basemod
+   use ESMF_Timemod
+   IMPLICIT NONE
+   type(ESMF_Time) time
+   character*128 :: s
+   integer rc
+   CALL ESMF_TimeGet( time, timeString=s, rc=rc )
+   print *,'Print a time|',TRIM(s),'|'
+   write(0,*)'Print a time|',TRIM(s),'|'
+   return
+END SUBROUTINE print_a_time
+
+SUBROUTINE print_a_timeinterval( time )
+   use ESMF_basemod
+   use ESMF_TimeIntervalmod
+   IMPLICIT NONE
+   type(ESMF_TimeInterval) time
+   character*128 :: s
+   integer rc
+   CALL ESMFold_TimeIntervalGetString( time, s, rc )
+   print *,'Print a time interval|',TRIM(s),'|'
+   write(0,*)'Print a time interval|',TRIM(s),'|'
+   return
+END SUBROUTINE print_a_timeinterval
+
diff --git a/wrfv2_fire/external/esmf_time_f90/Test1.F90 b/wrfv2_fire/external/esmf_time_f90/Test1.F90
new file mode 100644
index 00000000..ae7d29fc
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/Test1.F90
@@ -0,0 +1,1718 @@
+!
+! Sub-system tests for esmf_time_f90
+!
+! Someday, switch over to funit!  
+!
+
+MODULE my_tests
+  USE ESMF_Mod
+  IMPLICIT NONE
+
+  ! Set this to .TRUE. to make wrf_error_fatal3() print a message on failure 
+  ! instead of stopping the program.  Use for testing only (since we cannot 
+  ! catch exceptions in Fortran90!!)  
+  LOGICAL :: WRF_ERROR_FATAL_PRINT = .FALSE.
+
+CONTAINS
+
+  ! Test printing of an ESMF_Time or ESMF_TimeInterval object.  
+  !
+  ! Correct results are also passed in through this interface and compared 
+  ! with computed results.  PASS/FAIL messages are printed.  
+  !
+  SUBROUTINE test_print(  t_yy,  t_mm,  t_dd,  t_h,  t_m,  t_s, t_sn, t_sd, &
+                         ti_yy, ti_mm, ti_dd, ti_h, ti_m, ti_s, ti_sn, ti_sd, &
+                         res_str, testname, expect_error )
+    INTEGER, INTENT(IN), OPTIONAL :: t_YY
+    INTEGER, INTENT(IN), OPTIONAL :: t_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: t_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: t_H
+    INTEGER, INTENT(IN), OPTIONAL :: t_M
+    INTEGER, INTENT(IN), OPTIONAL :: t_S
+    INTEGER, INTENT(IN), OPTIONAL :: t_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: t_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: ti_YY
+    INTEGER, INTENT(IN), OPTIONAL :: ti_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: ti_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: ti_H
+    INTEGER, INTENT(IN), OPTIONAL :: ti_M
+    INTEGER, INTENT(IN), OPTIONAL :: ti_S
+    INTEGER, INTENT(IN), OPTIONAL :: ti_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: ti_Sd
+    CHARACTER (LEN=*), INTENT(IN) :: res_str
+    CHARACTER (LEN=*), INTENT(IN), OPTIONAL :: testname
+    LOGICAL, OPTIONAL, INTENT(IN) :: expect_error
+    ! locals
+    INTEGER :: it_YY
+    INTEGER :: it_MM  ! month
+    INTEGER :: it_DD  ! day of month
+    INTEGER :: it_H
+    INTEGER :: it_M
+    INTEGER :: it_S
+    INTEGER :: it_Sn
+    INTEGER :: it_Sd
+    INTEGER :: iti_YY
+    INTEGER :: iti_MM  ! month
+    INTEGER :: iti_DD  ! day of month
+    INTEGER :: iti_H
+    INTEGER :: iti_M
+    INTEGER :: iti_S
+    INTEGER :: iti_Sn
+    INTEGER :: iti_Sd
+    LOGICAL :: is_t 
+    LOGICAL :: is_ti
+    CHARACTER (LEN=512) :: itestname
+    LOGICAL :: iexpect_error
+    INTEGER rc
+    TYPE(ESMF_Time)           :: t
+    TYPE(ESMF_TimeInterval)   :: ti
+    CHARACTER(LEN=ESMF_MAXSTR) :: str, computed_str, frac_str
+    CHARACTER(LEN=17) :: type_str
+    INTEGER :: res_len, computed_len, Sn, Sd
+    LOGICAL :: test_passed
+
+!  PRINT *,'DEBUG:  BEGIN test_print()'
+    it_YY = 0
+    it_MM = 1
+    it_DD = 1
+    it_H = 0
+    it_M = 0
+    it_S = 0
+    it_Sn = 0
+    it_Sd = 0
+    iti_YY = 0
+    iti_MM = 0
+    iti_DD = 0
+    iti_H = 0
+    iti_M = 0
+    iti_S = 0
+    iti_Sn = 0
+    iti_Sd = 0
+    itestname = ''
+    iexpect_error = .FALSE.
+
+    IF ( PRESENT( t_YY ) ) it_YY = t_YY
+    IF ( PRESENT( t_MM ) ) it_MM = t_MM
+    IF ( PRESENT( t_DD ) ) it_DD = t_DD
+    IF ( PRESENT( t_H ) ) it_H = t_H
+    IF ( PRESENT( t_M ) ) it_M = t_M
+    IF ( PRESENT( t_S ) ) it_S = t_S
+    IF ( PRESENT( t_Sn ) ) it_Sn = t_Sn
+    IF ( PRESENT( t_Sd ) ) it_Sd = t_Sd
+    IF ( PRESENT( ti_YY ) ) iti_YY = ti_YY
+    IF ( PRESENT( ti_MM ) ) iti_MM = ti_MM
+    IF ( PRESENT( ti_DD ) ) iti_DD = ti_DD
+    IF ( PRESENT( ti_H ) ) iti_H = ti_H
+    IF ( PRESENT( ti_M ) ) iti_M = ti_M
+    IF ( PRESENT( ti_S ) ) iti_S = ti_S
+    IF ( PRESENT( ti_Sn ) ) iti_Sn = ti_Sn
+    IF ( PRESENT( ti_Sd ) ) iti_Sd = ti_Sd
+    IF ( PRESENT( testname ) ) itestname = TRIM(testname)
+    IF ( PRESENT( expect_error ) ) iexpect_error = expect_error
+
+    ! Ensure that optional arguments are consistent...
+    is_t = ( PRESENT( t_YY ) .OR. PRESENT( t_MM ) .OR. &
+             PRESENT( t_DD ) .OR. PRESENT( t_H ) .OR.  &
+             PRESENT( t_M )  .OR. PRESENT( t_S ) .OR.  &
+             PRESENT( t_Sn )  .OR. PRESENT( t_Sd ) )
+    is_ti = ( PRESENT( ti_YY ) .OR. PRESENT( ti_MM ) .OR. &
+              PRESENT( ti_DD ) .OR. PRESENT( ti_H ) .OR.  &
+              PRESENT( ti_M )  .OR. PRESENT( ti_S ) .OR.  &
+              PRESENT( ti_Sn )  .OR. PRESENT( ti_Sd ) )
+    IF ( is_t .EQV. is_ti ) THEN
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , &
+        'ERROR test_print:  inconsistent args' )
+    ENDIF
+
+!PRINT *,'DEBUG:  test_print():  init objects'
+    ! Initialize object to be tested
+    ! modify behavior of wrf_error_fatal3 for tests expected to fail
+    IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .TRUE.
+    Sn = 0
+    Sd = 0
+    IF ( is_t ) THEN
+      type_str = 'ESMF_Time'
+!PRINT *,'DEBUG:  test_print():  calling ESMF_TimeSet()'
+!PRINT *,'DEBUG:  test_print():  YY,MM,DD,H,M,S,Sn,Sd = ', it_YY,it_MM,it_DD,it_H,it_M,it_S,it_Sn,it_Sd
+      CALL ESMF_TimeSet( t, YY=it_YY, MM=it_MM, DD=it_DD , &
+                             H=it_H, M=it_M, S=it_S, Sn=it_Sn, Sd=it_Sd, rc=rc )
+!PRINT *,'DEBUG:  test_print():  back from ESMF_TimeSet()'
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+!PRINT *,'DEBUG:  test_print():  calling ESMF_TimeGet()'
+      CALL ESMF_TimeGet( t, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+!PRINT *,'DEBUG:  test_print():  back from ESMF_TimeGet(), computed_str = ',TRIM(computed_str)
+    ELSE
+      type_str = 'ESMF_TimeInterval'
+!PRINT *,'DEBUG:  test_print():  calling ESMF_TimeIntervalSet()'
+      CALL ESMF_TimeIntervalSet( ti, YY=iti_YY, MM=iti_MM, &
+                                      D=iti_DD ,           &
+                                      H=iti_H, M=iti_M,    &
+                                      S=iti_S, Sn=iti_Sn, Sd=iti_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeIntervalSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+!PRINT *,'DEBUG:  test_print():  calling ESMF_TimeIntervalGet()'
+      CALL ESMF_TimeIntervalGet( ti, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+    ENDIF
+    ! handle fractions
+    IF ( Sd > 0 ) THEN
+      IF ( Sn > 0 ) THEN
+        WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(Sn), Sd
+      ELSE IF ( Sn < 0 ) THEN
+        WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(Sn), Sd
+      ELSE
+        frac_str = ''
+      ENDIF
+      computed_str = TRIM(computed_str)//TRIM(frac_str)
+    ENDIF
+    ! restore default behavior of wrf_error_fatal3
+    IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .FALSE.
+!PRINT *,'DEBUG:  test_print():  done init objects'
+
+!PRINT *,'DEBUG:  test_print():  check result'
+    ! check result
+    test_passed = .FALSE.
+    res_len = LEN_TRIM(res_str)
+    computed_len = LEN_TRIM(computed_str)
+    IF ( res_len == computed_len ) THEN
+      IF ( computed_str(1:computed_len) == res_str(1:res_len) ) THEN
+        test_passed = .TRUE.
+      ENDIF
+    ENDIF
+    IF ( test_passed ) THEN
+      WRITE(*,FMT='(A)') 'PASS:  '//TRIM(itestname)
+    ELSE
+      WRITE(*,'(9A)') 'FAIL:  ',TRIM(itestname),':  printing ',TRIM(type_str), &
+        '  expected <', TRIM(res_str),'>  but computed <',TRIM(computed_str),'>'
+    ENDIF
+!PRINT *,'DEBUG:  END test_print()'
+
+  END SUBROUTINE test_print
+
+
+
+  ! Test the following arithmetic operations on ESMF_Time and 
+  ! ESMF_TimeInterval objects:
+  !  ESMF_Time         = ESMF_Time         + ESMF_TimeInterval
+  !  ESMF_Time         = ESMF_TimeInterval + ESMF_Time
+  !  ESMF_Time         = ESMF_Time         - ESMF_TimeInterval
+  !  ESMF_TimeInterval = ESMF_Time         - ESMF_Time        
+  !  ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval
+  !  ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval
+  !  ESMF_TimeInterval = ESMF_TimeInterval * INTEGER
+  !  ESMF_TimeInterval = ESMF_TimeInterval / INTEGER
+  !
+  ! Correct results are also passed in through this interface and compared 
+  ! with computed results.  PASS/FAIL messages are printed.  
+  !
+  ! Operations are expressed as res = op1 +|- op2
+  !
+  SUBROUTINE test_arithmetic( add_op, multiply_op,                                       &
+     op1_t_yy,  op1_t_mm,  op1_t_dd,  op1_t_h,  op1_t_m,  op1_t_s,  op1_t_sn,  op1_t_sd, &
+    op1_ti_yy, op1_ti_mm, op1_ti_dd, op1_ti_h, op1_ti_m, op1_ti_s, op1_ti_sn, op1_ti_sd, &
+     op2_t_yy,  op2_t_mm,  op2_t_dd,  op2_t_h,  op2_t_m,  op2_t_s,  op2_t_sn,  op2_t_sd, &
+    op2_ti_yy, op2_ti_mm, op2_ti_dd, op2_ti_h, op2_ti_m, op2_ti_s, op2_ti_sn, op2_ti_sd, &
+    op2_int,                                                                             &
+     res_t_yy,  res_t_mm,  res_t_dd,  res_t_h,  res_t_m,  res_t_s,  res_t_sn,  res_t_sd, &
+    res_ti_yy, res_ti_mm, res_ti_dd, res_ti_h, res_ti_m, res_ti_s, res_ti_sn, res_ti_sd, &
+    res_int, testname, expect_error )
+    LOGICAL, INTENT(IN), OPTIONAL :: add_op      ! .TRUE.=add, .FALSE.=subtract
+    LOGICAL, INTENT(IN), OPTIONAL :: multiply_op ! .TRUE.=multiply, .FALSE.=divide
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_YY
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_H
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_M
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_S
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: op1_t_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_YY
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_H
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_M
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_S
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: op1_ti_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_YY
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_H
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_M
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_S
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: op2_t_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_YY
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_H
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_M
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_S
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: op2_ti_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: op2_int
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_YY
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_H
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_M
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_S
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: res_t_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_YY
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_H
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_M
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_S
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: res_ti_Sd
+    INTEGER, INTENT(IN), OPTIONAL :: res_int
+    CHARACTER (LEN=*), OPTIONAL, INTENT(IN) :: testname
+    LOGICAL, OPTIONAL, INTENT(IN) :: expect_error
+    ! locals
+    LOGICAL :: iadd_op
+    LOGICAL :: isubtract_op
+    LOGICAL :: imultiply_op
+    LOGICAL :: idivide_op
+    INTEGER :: iop1_t_YY
+    INTEGER :: iop1_t_MM  ! month
+    INTEGER :: iop1_t_DD  ! day of month
+    INTEGER :: iop1_t_H
+    INTEGER :: iop1_t_M
+    INTEGER :: iop1_t_S
+    INTEGER :: iop1_t_Sn
+    INTEGER :: iop1_t_Sd
+    INTEGER :: iop1_ti_YY
+    INTEGER :: iop1_ti_MM  ! month
+    INTEGER :: iop1_ti_DD  ! day of month
+    INTEGER :: iop1_ti_H
+    INTEGER :: iop1_ti_M
+    INTEGER :: iop1_ti_S
+    INTEGER :: iop1_ti_Sn
+    INTEGER :: iop1_ti_Sd
+    INTEGER :: iop2_t_YY
+    INTEGER :: iop2_t_MM  ! month
+    INTEGER :: iop2_t_DD  ! day of month
+    INTEGER :: iop2_t_H
+    INTEGER :: iop2_t_M
+    INTEGER :: iop2_t_S
+    INTEGER :: iop2_t_Sn
+    INTEGER :: iop2_t_Sd
+    INTEGER :: iop2_ti_YY
+    INTEGER :: iop2_ti_MM  ! month
+    INTEGER :: iop2_ti_DD  ! day of month
+    INTEGER :: iop2_ti_H
+    INTEGER :: iop2_ti_M
+    INTEGER :: iop2_ti_S
+    INTEGER :: iop2_ti_Sn
+    INTEGER :: iop2_ti_Sd
+    INTEGER :: ires_t_YY
+    INTEGER :: ires_t_MM  ! month
+    INTEGER :: ires_t_DD  ! day of month
+    INTEGER :: ires_t_H
+    INTEGER :: ires_t_M
+    INTEGER :: ires_t_S
+    INTEGER :: ires_t_Sn
+    INTEGER :: ires_t_Sd
+    INTEGER :: ires_ti_YY
+    INTEGER :: ires_ti_MM  ! month
+    INTEGER :: ires_ti_DD  ! day of month
+    INTEGER :: ires_ti_H
+    INTEGER :: ires_ti_M
+    INTEGER :: ires_ti_S
+    INTEGER :: ires_ti_Sn
+    INTEGER :: ires_ti_Sd
+    LOGICAL :: op1_is_t , op2_is_t , res_is_t
+    LOGICAL :: op1_is_ti, op2_is_ti, res_is_ti, op2_is_int
+    LOGICAL :: res_is_int
+    INTEGER :: num_ops, num_op1, num_op2, num_res
+    LOGICAL :: unsupported_op, test_passed
+    CHARACTER (LEN=512) :: itestname
+    LOGICAL :: iexpect_error
+    INTEGER :: rc
+    INTEGER :: computed_int, Sn, Sd
+    TYPE(ESMF_Time)           :: op1_t , op2_t , res_t, computed_t
+    TYPE(ESMF_TimeInterval)   :: op1_ti, op2_ti, res_ti, computed_ti
+    CHARACTER(LEN=ESMF_MAXSTR) :: str, op1_str, op2_str, res_str, computed_str, frac_str
+    CHARACTER(LEN=1) :: op_str
+    CHARACTER(LEN=17) :: op1_type_str, op2_type_str, res_type_str
+
+    iadd_op = .FALSE.
+    isubtract_op = .FALSE.
+    imultiply_op = .FALSE.
+    idivide_op = .FALSE.
+    iop1_t_YY = 0
+    iop1_t_MM = 1
+    iop1_t_DD = 1
+    iop1_t_H = 0
+    iop1_t_M = 0
+    iop1_t_S = 0
+    iop1_t_Sn = 0
+    iop1_t_Sd = 0
+    iop1_ti_YY = 0
+    iop1_ti_MM = 0
+    iop1_ti_DD = 0
+    iop1_ti_H = 0
+    iop1_ti_M = 0
+    iop1_ti_S = 0
+    iop1_ti_Sn = 0
+    iop1_ti_Sd = 0
+    iop2_t_YY = 0
+    iop2_t_MM = 1
+    iop2_t_DD = 1
+    iop2_t_H = 0
+    iop2_t_M = 0
+    iop2_t_S = 0
+    iop2_t_Sn = 0
+    iop2_t_Sd = 0
+    iop2_ti_YY = 0
+    iop2_ti_MM = 0
+    iop2_ti_DD = 0
+    iop2_ti_H = 0
+    iop2_ti_M = 0
+    iop2_ti_S = 0
+    iop2_ti_Sn = 0
+    iop2_ti_Sd = 0
+    ires_t_YY = 0
+    ires_t_MM = 1
+    ires_t_DD = 1
+    ires_t_H = 0
+    ires_t_M = 0
+    ires_t_S = 0
+    ires_t_Sn = 0
+    ires_t_Sd = 0
+    ires_ti_YY = 0
+    ires_ti_MM = 0
+    ires_ti_DD = 0
+    ires_ti_H = 0
+    ires_ti_M = 0
+    ires_ti_S = 0
+    ires_ti_Sn = 0
+    ires_ti_Sd = 0
+    itestname = ''
+    iexpect_error = .FALSE.
+
+    IF ( PRESENT( add_op ) ) THEN
+      iadd_op = add_op
+      isubtract_op = ( .NOT. add_op )
+    ENDIF
+    IF ( PRESENT( multiply_op ) ) THEN
+      imultiply_op = multiply_op
+      idivide_op = ( .NOT. multiply_op )
+    ENDIF
+    num_ops = 0
+    IF ( iadd_op )      num_ops = num_ops + 1
+    IF ( isubtract_op ) num_ops = num_ops + 1
+    IF ( imultiply_op ) num_ops = num_ops + 1
+    IF ( idivide_op )   num_ops = num_ops + 1
+    IF ( num_ops /= 1 ) THEN
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , &
+        'ERROR test_arithmetic:  inconsistent operation' )
+    ENDIF
+    IF ( PRESENT( op1_t_YY ) ) iop1_t_YY = op1_t_YY
+    IF ( PRESENT( op1_t_MM ) ) iop1_t_MM = op1_t_MM
+    IF ( PRESENT( op1_t_DD ) ) iop1_t_DD = op1_t_DD
+    IF ( PRESENT( op1_t_H ) ) iop1_t_H = op1_t_H
+    IF ( PRESENT( op1_t_M ) ) iop1_t_M = op1_t_M
+    IF ( PRESENT( op1_t_S ) ) iop1_t_S = op1_t_S
+    IF ( PRESENT( op1_t_Sn ) ) iop1_t_Sn = op1_t_Sn
+    IF ( PRESENT( op1_t_Sd ) ) iop1_t_Sd = op1_t_Sd
+    IF ( PRESENT( op1_ti_YY ) ) iop1_ti_YY = op1_ti_YY
+    IF ( PRESENT( op1_ti_MM ) ) iop1_ti_MM = op1_ti_MM
+    IF ( PRESENT( op1_ti_DD ) ) iop1_ti_DD = op1_ti_DD
+    IF ( PRESENT( op1_ti_H ) ) iop1_ti_H = op1_ti_H
+    IF ( PRESENT( op1_ti_M ) ) iop1_ti_M = op1_ti_M
+    IF ( PRESENT( op1_ti_S ) ) iop1_ti_S = op1_ti_S
+    IF ( PRESENT( op1_ti_Sn ) ) iop1_ti_Sn = op1_ti_Sn
+    IF ( PRESENT( op1_ti_Sd ) ) iop1_ti_Sd = op1_ti_Sd
+    IF ( PRESENT( op2_t_YY ) ) iop2_t_YY = op2_t_YY
+    IF ( PRESENT( op2_t_MM ) ) iop2_t_MM = op2_t_MM
+    IF ( PRESENT( op2_t_DD ) ) iop2_t_DD = op2_t_DD
+    IF ( PRESENT( op2_t_H ) ) iop2_t_H = op2_t_H
+    IF ( PRESENT( op2_t_M ) ) iop2_t_M = op2_t_M
+    IF ( PRESENT( op2_t_S ) ) iop2_t_S = op2_t_S
+    IF ( PRESENT( op2_t_Sn ) ) iop2_t_Sn = op2_t_Sn
+    IF ( PRESENT( op2_t_Sd ) ) iop2_t_Sd = op2_t_Sd
+    IF ( PRESENT( op2_ti_YY ) ) iop2_ti_YY = op2_ti_YY
+    IF ( PRESENT( op2_ti_MM ) ) iop2_ti_MM = op2_ti_MM
+    IF ( PRESENT( op2_ti_DD ) ) iop2_ti_DD = op2_ti_DD
+    IF ( PRESENT( op2_ti_H ) ) iop2_ti_H = op2_ti_H
+    IF ( PRESENT( op2_ti_M ) ) iop2_ti_M = op2_ti_M
+    IF ( PRESENT( op2_ti_S ) ) iop2_ti_S = op2_ti_S
+    IF ( PRESENT( op2_ti_Sn ) ) iop2_ti_Sn = op2_ti_Sn
+    IF ( PRESENT( op2_ti_Sd ) ) iop2_ti_Sd = op2_ti_Sd
+    IF ( PRESENT( res_t_YY ) ) ires_t_YY = res_t_YY
+    IF ( PRESENT( res_t_MM ) ) ires_t_MM = res_t_MM
+    IF ( PRESENT( res_t_DD ) ) ires_t_DD = res_t_DD
+    IF ( PRESENT( res_t_H ) ) ires_t_H = res_t_H
+    IF ( PRESENT( res_t_M ) ) ires_t_M = res_t_M
+    IF ( PRESENT( res_t_S ) ) ires_t_S = res_t_S
+    IF ( PRESENT( res_t_Sn ) ) ires_t_Sn = res_t_Sn
+    IF ( PRESENT( res_t_Sd ) ) ires_t_Sd = res_t_Sd
+    IF ( PRESENT( res_ti_YY ) ) ires_ti_YY = res_ti_YY
+    IF ( PRESENT( res_ti_MM ) ) ires_ti_MM = res_ti_MM
+    IF ( PRESENT( res_ti_DD ) ) ires_ti_DD = res_ti_DD
+    IF ( PRESENT( res_ti_H ) ) ires_ti_H = res_ti_H
+    IF ( PRESENT( res_ti_M ) ) ires_ti_M = res_ti_M
+    IF ( PRESENT( res_ti_S ) ) ires_ti_S = res_ti_S
+    IF ( PRESENT( res_ti_Sn ) ) ires_ti_Sn = res_ti_Sn
+    IF ( PRESENT( res_ti_Sd ) ) ires_ti_Sd = res_ti_Sd
+    IF ( PRESENT( testname ) ) itestname = TRIM(testname)
+    IF ( PRESENT( expect_error ) ) iexpect_error = expect_error
+
+    ! Ensure that optional arguments are consistent...
+    op1_is_t = ( PRESENT( op1_t_YY ) .OR. PRESENT( op1_t_MM ) .OR. &
+                 PRESENT( op1_t_DD ) .OR. PRESENT( op1_t_H ) .OR.  &
+                 PRESENT( op1_t_M )  .OR. PRESENT( op1_t_S ) .OR.  &
+                 PRESENT( op1_t_Sn )  .OR. PRESENT( op1_t_Sd ) )
+    op1_is_ti = ( PRESENT( op1_ti_YY ) .OR. PRESENT( op1_ti_MM ) .OR. &
+                  PRESENT( op1_ti_DD ) .OR. PRESENT( op1_ti_H ) .OR.  &
+                  PRESENT( op1_ti_M )  .OR. PRESENT( op1_ti_S ) .OR.  &
+                  PRESENT( op1_ti_Sn )  .OR. PRESENT( op1_ti_Sd ) )
+    op2_is_t = ( PRESENT( op2_t_YY ) .OR. PRESENT( op2_t_MM ) .OR. &
+                 PRESENT( op2_t_DD ) .OR. PRESENT( op2_t_H ) .OR.  &
+                 PRESENT( op2_t_M )  .OR. PRESENT( op2_t_S ) .OR.  &
+                 PRESENT( op2_t_Sn )  .OR. PRESENT( op2_t_Sd ) )
+    op2_is_ti = ( PRESENT( op2_ti_YY ) .OR. PRESENT( op2_ti_MM ) .OR. &
+                  PRESENT( op2_ti_DD ) .OR. PRESENT( op2_ti_H ) .OR.  &
+                  PRESENT( op2_ti_M )  .OR. PRESENT( op2_ti_S ) .OR.  &
+                  PRESENT( op2_ti_Sn )  .OR. PRESENT( op2_ti_Sd ) )
+    op2_is_int = ( PRESENT( op2_int ) )
+    res_is_t = ( PRESENT( res_t_YY ) .OR. PRESENT( res_t_MM ) .OR. &
+                 PRESENT( res_t_DD ) .OR. PRESENT( res_t_H ) .OR.  &
+                 PRESENT( res_t_M )  .OR. PRESENT( res_t_S ) .OR.  &
+                 PRESENT( res_t_Sn )  .OR. PRESENT( res_t_Sd ) )
+    res_is_ti = ( PRESENT( res_ti_YY ) .OR. PRESENT( res_ti_MM ) .OR. &
+                  PRESENT( res_ti_DD ) .OR. PRESENT( res_ti_H ) .OR.  &
+                  PRESENT( res_ti_M )  .OR. PRESENT( res_ti_S ) .OR.  &
+                  PRESENT( res_ti_Sn )  .OR. PRESENT( res_ti_Sd ) )
+    res_is_int = ( PRESENT( res_int ) )
+    num_op1 = 0
+    IF ( op1_is_t   ) num_op1 = num_op1 + 1
+    IF ( op1_is_ti  ) num_op1 = num_op1 + 1
+    IF ( num_op1 /= 1 ) THEN
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , &
+        'ERROR test_arithmetic:  inconsistent args for op1' )
+    ENDIF
+    num_op2 = 0
+    IF ( op2_is_t   ) num_op2 = num_op2 + 1
+    IF ( op2_is_ti  ) num_op2 = num_op2 + 1
+    IF ( op2_is_int ) num_op2 = num_op2 + 1
+    IF ( num_op2 /= 1 ) THEN
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , &
+        'ERROR test_arithmetic:  inconsistent args for op2' )
+    ENDIF
+    num_res = 0
+    IF ( res_is_t   ) num_res = num_res + 1
+    IF ( res_is_ti  ) num_res = num_res + 1
+    IF ( res_is_int ) num_res = num_res + 1
+    IF ( num_res /= 1 ) THEN
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , &
+        'ERROR test_arithmetic:  inconsistent args for result' )
+    ENDIF
+
+    ! Initialize op1
+    IF ( op1_is_t ) THEN
+      op1_type_str = 'ESMF_Time'
+      CALL ESMF_TimeSet( op1_t, YY=iop1_t_YY, MM=iop1_t_MM, DD=iop1_t_DD , &
+                                 H=iop1_t_H, M=iop1_t_M, S=iop1_t_S, Sn=iop1_t_Sn, Sd=iop1_t_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeGet( op1_t, timeString=op1_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      op1_str = TRIM(op1_str)//TRIM(frac_str)
+    ELSE
+      op1_type_str = 'ESMF_TimeInterval'
+      CALL ESMF_TimeIntervalSet( op1_ti, YY=iop1_ti_YY, MM=iop1_ti_MM, &
+                                          D=iop1_ti_DD ,               &
+                                          H=iop1_ti_H, M=iop1_ti_M,    &
+                                          S=iop1_ti_S, Sn=iop1_ti_Sn, Sd=iop1_ti_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeIntervalSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeIntervalGet( op1_ti, timeString=op1_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      op1_str = TRIM(op1_str)//TRIM(frac_str)
+    ENDIF
+    ! Initialize op2
+    IF ( op2_is_t ) THEN
+      op2_type_str = 'ESMF_Time'
+      CALL ESMF_TimeSet( op2_t, YY=iop2_t_YY, MM=iop2_t_MM, DD=iop2_t_DD , &
+                                 H=iop2_t_H, M=iop2_t_M, S=iop2_t_S, Sn=iop2_t_Sn, Sd=iop2_t_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeGet( op2_t, timeString=op2_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      op2_str = TRIM(op2_str)//TRIM(frac_str)
+    ELSE IF ( op2_is_ti ) THEN
+      op2_type_str = 'ESMF_TimeInterval'
+      CALL ESMF_TimeIntervalSet( op2_ti, YY=iop2_ti_YY, MM=iop2_ti_MM, &
+                                          D=iop2_ti_DD ,               &
+                                          H=iop2_ti_H, M=iop2_ti_M,    &
+                                          S=iop2_ti_S, Sn=iop2_ti_Sn, Sd=iop2_ti_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeIntervalSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeIntervalGet( op2_ti, timeString=op2_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      op2_str = TRIM(op2_str)//TRIM(frac_str)
+    ELSE
+      op2_type_str = 'INTEGER'
+      IF ( op2_int > 0 ) THEN
+        WRITE(op2_str,FMT="('+',I8.8)") ABS(op2_int)
+      ELSE
+        WRITE(op2_str,FMT="('-',I8.8)") ABS(op2_int)
+      ENDIF
+    ENDIF
+    ! Initialize res
+    IF ( res_is_t ) THEN  ! result is ESMF_Time
+      res_type_str = 'ESMF_Time'
+      CALL ESMF_TimeSet( res_t, YY=ires_t_YY, MM=ires_t_MM, DD=ires_t_DD , &
+                                 H=ires_t_H, M=ires_t_M, S=ires_t_S, Sn=ires_t_Sn, Sd=ires_t_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeGet( res_t, timeString=res_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      res_str = TRIM(res_str)//TRIM(frac_str)
+    ELSE IF ( res_is_ti ) THEN  ! result is ESMF_TimeInterval
+      res_type_str = 'ESMF_TimeInterval'
+      CALL ESMF_TimeIntervalSet( res_ti, YY=ires_ti_YY, MM=ires_ti_MM, &
+                                          D=ires_ti_DD ,               &
+                                          H=ires_ti_H, M=ires_ti_M,    &
+                                          S=ires_ti_S, Sn=ires_ti_Sn, Sd=ires_ti_Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                             TRIM(itestname)//'ESMF_TimeIntervalSet() ', &
+                             __FILE__ , &
+                             __LINE__  )
+      CALL ESMF_TimeIntervalGet( res_ti, timeString=res_str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      ! handle fractions
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      res_str = TRIM(res_str)//TRIM(frac_str)
+    ELSE  ! result is INTEGER
+      res_type_str = 'INTEGER'
+      IF ( res_int > 0 ) THEN
+        WRITE(res_str,FMT="('+',I8.8)") ABS(res_int)
+      ELSE
+        WRITE(res_str,FMT="('-',I8.8)") ABS(res_int)
+      ENDIF
+    ENDIF
+
+    ! perform requested operation
+    unsupported_op = .FALSE.
+    ! modify behavior of wrf_error_fatal3 for operator being tested
+    IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .TRUE.
+    ! add
+    IF ( iadd_op ) THEN
+      op_str = '+'
+      IF ( res_is_t ) THEN  ! result is ESMF_Time
+        IF ( op1_is_t .AND. op2_is_ti ) THEN
+          !  ESMF_Time         = ESMF_Time         + ESMF_TimeInterval
+          computed_t = op1_t + op2_ti
+        ELSE IF ( op1_is_ti .AND. op2_is_t ) THEN
+          !  ESMF_Time         = ESMF_TimeInterval + ESMF_Time
+          computed_t = op1_ti + op2_t
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ELSE  ! result is ESMF_TimeInterval
+        IF ( op1_is_ti .AND. op2_is_ti ) THEN
+          !  ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval
+          computed_ti = op1_ti + op2_ti
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ENDIF
+    ! subtract
+    ELSE  IF ( isubtract_op ) THEN
+      op_str = '-'
+      IF ( res_is_t ) THEN  ! result is ESMF_Time
+        IF ( op1_is_t .AND. op2_is_ti ) THEN
+          !  ESMF_Time         = ESMF_Time         - ESMF_TimeInterval
+          computed_t = op1_t - op2_ti
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ELSE  ! result is ESMF_TimeInterval
+        IF ( op1_is_t .AND. op2_is_t ) THEN
+          !  ESMF_TimeInterval = ESMF_Time         - ESMF_Time        
+          computed_ti = op1_t - op2_t
+        ELSE IF ( op1_is_ti .AND. op2_is_ti ) THEN
+          !  ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval
+          computed_ti = op1_ti - op2_ti
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ENDIF
+    ELSE  IF ( imultiply_op ) THEN
+      op_str = '*'
+      IF ( res_is_ti ) THEN  ! result is ESMF_TimeInterval
+        IF ( op1_is_ti .AND. op2_is_int ) THEN
+          !  ESMF_TimeInterval = ESMF_TimeInterval * INTEGER
+          computed_ti = op1_ti * op2_int
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ENDIF
+    ELSE  IF ( idivide_op ) THEN
+      op_str = '/'
+      IF ( res_is_ti ) THEN  ! result is ESMF_TimeInterval
+        IF ( op1_is_ti .AND. op2_is_int ) THEN
+          !  ESMF_TimeInterval = ESMF_TimeInterval / INTEGER
+          computed_ti = op1_ti / op2_int
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ELSE IF ( res_is_int ) THEN  ! result is INTEGER
+        IF ( op1_is_ti .AND. op2_is_ti ) THEN
+          !  INTEGER = ESMF_TimeInterval / ESMF_TimeInterval
+          ! number of whole time intervals
+          computed_int = ESMF_TimeIntervalDIVQuot( op1_ti , op2_ti )
+        ELSE
+          unsupported_op = .TRUE.
+        ENDIF
+      ENDIF
+    ENDIF
+    ! restore default behavior of wrf_error_fatal3
+    IF ( iexpect_error ) WRF_ERROR_FATAL_PRINT = .FALSE.
+    IF ( unsupported_op ) THEN
+      WRITE(str,*) 'ERROR test_arithmetic ',TRIM(itestname), &
+        ':  unsupported operation (',                           &
+        TRIM(res_type_str),' = ',TRIM(op1_type_str),' ',TRIM(op_str),' ', &
+        TRIM(op2_type_str),')'
+      CALL wrf_error_fatal3( __FILE__ , __LINE__ , str )
+    ENDIF
+
+    ! check result
+    test_passed = .FALSE.
+    IF ( res_is_t ) THEN  ! result is ESMF_Time
+      IF ( computed_t == res_t ) THEN
+        test_passed = .TRUE.
+      ELSE
+        CALL ESMF_TimeGet( computed_t, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc )
+        CALL test_check_error( ESMF_SUCCESS, rc, &
+                              TRIM(itestname)//'ESMF_TimeGet() ', &
+                              __FILE__ , &
+                              __LINE__  )
+        ! handle fractions
+        CALL fraction_to_string( Sn, Sd, frac_str )
+        computed_str = TRIM(computed_str)//TRIM(frac_str)
+      ENDIF
+    ELSE IF ( res_is_ti ) THEN  ! result is ESMF_TimeInterval
+      IF ( computed_ti == res_ti ) THEN
+        test_passed = .TRUE.
+      ELSE
+        CALL ESMF_TimeIntervalGet( computed_ti, timeString=computed_str, Sn=Sn, Sd=Sd, rc=rc )
+        CALL test_check_error( ESMF_SUCCESS, rc, &
+                              TRIM(itestname)//'ESMF_TimeGet() ', &
+                              __FILE__ , &
+                              __LINE__  )
+        ! handle fractions
+        CALL fraction_to_string( Sn, Sd, frac_str )
+        computed_str = TRIM(computed_str)//TRIM(frac_str)
+      ENDIF
+    ELSE  ! result is INTEGER
+      IF ( computed_int == res_int ) THEN
+        test_passed = .TRUE.
+      ELSE
+        IF ( computed_int > 0 ) THEN
+          WRITE(computed_str,FMT="('+',I8.8)") ABS(computed_int)
+        ELSE
+          WRITE(computed_str,FMT="('-',I8.8)") ABS(computed_int)
+        ENDIF
+      ENDIF
+    ENDIF
+    IF ( test_passed ) THEN
+      WRITE(*,FMT='(A)') 'PASS:  '//TRIM(itestname)
+    ELSE
+      WRITE(*,*) 'FAIL:  ',TRIM(itestname),':  (',                        &
+        TRIM(res_type_str),' = ',TRIM(op1_type_str),' ',TRIM(op_str),' ', &
+        TRIM(op2_type_str),')  expected ',                                &
+        TRIM(res_str),' = ',TRIM(op1_str),' ',TRIM(op_str),' ',           &
+        TRIM(op2_str),'  but computed ',TRIM(computed_str)
+    ENDIF
+
+  END SUBROUTINE test_arithmetic
+
+
+
+  ! simple clock creation and advance with add-subtract tests thrown in
+  ! no self checks (yet)
+  SUBROUTINE test_clock_advance(                                              &
+    start_yy, start_mm, start_dd, start_h, start_m, start_s,                  &
+     stop_yy,  stop_mm,  stop_dd,  stop_h,  stop_m,  stop_s,                  &
+    timestep_d, timestep_h, timestep_m, timestep_s, timestep_sn, timestep_sd, &
+    testname, increment_S, increment_Sn, increment_Sd )
+    INTEGER, INTENT(IN), OPTIONAL :: start_YY
+    INTEGER, INTENT(IN), OPTIONAL :: start_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: start_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: start_H
+    INTEGER, INTENT(IN), OPTIONAL :: start_M
+    INTEGER, INTENT(IN), OPTIONAL :: start_S
+    INTEGER, INTENT(IN), OPTIONAL :: stop_YY
+    INTEGER, INTENT(IN), OPTIONAL :: stop_MM  ! month
+    INTEGER, INTENT(IN), OPTIONAL :: stop_DD  ! day of month
+    INTEGER, INTENT(IN), OPTIONAL :: stop_H
+    INTEGER, INTENT(IN), OPTIONAL :: stop_M
+    INTEGER, INTENT(IN), OPTIONAL :: stop_S
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_D  ! day
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_H
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_M
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_S
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_Sn
+    INTEGER, INTENT(IN), OPTIONAL :: timestep_Sd
+    CHARACTER (LEN=*), OPTIONAL, INTENT(IN) :: testname
+    INTEGER, INTENT(IN), OPTIONAL :: increment_S  ! add and subtract this 
+    INTEGER, INTENT(IN), OPTIONAL :: increment_Sn ! value each time step
+    INTEGER, INTENT(IN), OPTIONAL :: increment_Sd
+
+    ! locals
+    INTEGER :: istart_YY
+    INTEGER :: istart_MM  ! month
+    INTEGER :: istart_DD  ! day of month
+    INTEGER :: istart_H
+    INTEGER :: istart_M
+    INTEGER :: istart_S
+    INTEGER :: istop_YY
+    INTEGER :: istop_MM  ! month
+    INTEGER :: istop_DD  ! day of month
+    INTEGER :: istop_H
+    INTEGER :: istop_M
+    INTEGER :: istop_S
+    INTEGER :: itimestep_D  ! day
+    INTEGER :: itimestep_H
+    INTEGER :: itimestep_M
+    INTEGER :: itimestep_S
+    INTEGER :: itimestep_Sn
+    INTEGER :: itimestep_Sd
+    CHARACTER (LEN=512) :: itestname, itestfullname
+    INTEGER :: iincrement_S
+    INTEGER :: iincrement_Sn
+    INTEGER :: iincrement_Sd
+    INTEGER :: Sn, Sd
+    INTEGER rc
+    TYPE(ESMF_Time)           :: start_time, stop_time, current_time
+    TYPE(ESMF_Clock), POINTER :: domain_clock
+    TYPE(ESMF_TimeInterval)   :: timestep, increment
+    TYPE(ESMF_Time)           :: add_time, subtract_time
+    INTEGER :: itimestep
+    REAL(ESMF_KIND_R8) :: dayr8
+    CHARACTER(LEN=ESMF_MAXSTR) :: str, frac_str
+
+    istart_YY = 0
+    istart_MM = 1
+    istart_DD = 1
+    istart_H = 0
+    istart_M = 0
+    istart_S = 0
+    istop_YY = 0
+    istop_MM = 1
+    istop_DD = 1
+    istop_H = 0
+    istop_M = 0
+    istop_S = 0
+    itimestep_D = 0
+    itimestep_H = 0
+    itimestep_M = 0
+    itimestep_S = 0
+    itimestep_Sn = 0
+    itimestep_Sd = 0
+    itestname = ''
+    iincrement_S = 0
+    iincrement_Sn = 0
+    iincrement_Sd = 0
+
+    IF ( PRESENT( start_YY ) ) istart_YY = start_YY
+    IF ( PRESENT( start_MM ) ) istart_MM = start_MM
+    IF ( PRESENT( start_DD ) ) istart_DD = start_DD
+    IF ( PRESENT( start_H ) ) istart_H = start_H
+    IF ( PRESENT( start_M ) ) istart_M = start_M
+    IF ( PRESENT( start_S ) ) istart_S = start_S
+    IF ( PRESENT( stop_YY ) ) istop_YY = stop_YY
+    IF ( PRESENT( stop_MM ) ) istop_MM = stop_MM
+    IF ( PRESENT( stop_DD ) ) istop_DD = stop_DD
+    IF ( PRESENT( stop_H ) ) istop_H = stop_H
+    IF ( PRESENT( stop_M ) ) istop_M = stop_M
+    IF ( PRESENT( stop_S ) ) istop_S = stop_S
+    IF ( PRESENT( timestep_D ) ) itimestep_D = timestep_D
+    IF ( PRESENT( timestep_H ) ) itimestep_H = timestep_H
+    IF ( PRESENT( timestep_M ) ) itimestep_M = timestep_M
+    IF ( PRESENT( timestep_S ) ) itimestep_S = timestep_S
+    IF ( PRESENT( timestep_Sn ) ) itimestep_Sn = timestep_Sn
+    IF ( PRESENT( timestep_Sd ) ) itimestep_Sd = timestep_Sd
+    IF ( PRESENT( testname ) ) itestname = TRIM(testname)//'_'
+    IF ( PRESENT( increment_S ) ) iincrement_S = increment_S
+    IF ( PRESENT( increment_Sn ) ) iincrement_Sn = increment_Sn
+    IF ( PRESENT( increment_Sd ) ) iincrement_Sd = increment_Sd
+
+    ! Initialize start time, stop time, time step, clock for simple case. 
+    itestfullname = TRIM(itestname)//'SETUP'
+    CALL ESMF_TimeSet( start_time, YY=istart_YY, MM=istart_MM, DD=istart_DD , &
+                                   H=istart_H, M=istart_M, S=istart_S, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeSet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_TimeGet( start_time, timeString=str, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  start_time = <',TRIM(str),'>'
+
+    CALL ESMF_TimeSet( stop_time, YY=istop_YY, MM=istop_MM, DD=istop_DD , &
+                                   H=istop_H, M=istop_M, S=istop_S, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeSet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_TimeGet( stop_time, timeString=str, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  stop_time = <',TRIM(str),'>'
+
+    CALL ESMF_TimeIntervalSet( timestep, D=itimestep_D, H=itimestep_H, &
+                                         M=itimestep_M, S=itimestep_S, &
+                                         Sn=itimestep_Sn, Sd=itimestep_Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeIntervalSet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_TimeIntervalGet( timestep, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeIntervalGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    ! handle fractions
+    CALL fraction_to_string( Sn, Sd, frac_str )
+    str = TRIM(str)//TRIM(frac_str)
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  timestep = <',TRIM(str),'>'
+
+    CALL ESMF_TimeIntervalSet( increment, S=iincrement_S, &
+                               Sn=iincrement_Sn, Sd=iincrement_Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeIntervalSet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_TimeIntervalGet( increment, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeIntervalGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    ! handle fractions
+    CALL fraction_to_string( Sn, Sd, frac_str )
+    str = TRIM(str)//TRIM(frac_str)
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  increment = <',TRIM(str),'>'
+
+    ALLOCATE( domain_clock )
+    domain_clock = ESMF_ClockCreate( TimeStep= timestep,  &
+                                     StartTime=start_time, &
+                                     StopTime= stop_time,  &
+                                     rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_ClockCreate() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_ClockGet( domain_clock, CurrTime=current_time, &
+                        rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_ClockGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+
+    CALL ESMF_TimeGet( current_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    CALL fraction_to_string( Sn, Sd, frac_str )
+    str = TRIM(str)//TRIM(frac_str)
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  clock current_time = <',TRIM(str),'>'
+
+    CALL ESMF_TimeGet( current_time, dayOfYear_r8=dayr8, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    WRITE(*,FMT='(A,A,F10.6,A)') TRIM(itestfullname),':  current_time dayOfYear_r8 = < ',dayr8,' >'
+
+    subtract_time = current_time - increment
+    CALL ESMF_TimeGet( subtract_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    CALL fraction_to_string( Sn, Sd, frac_str )
+    str = TRIM(str)//TRIM(frac_str)
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  current_time-increment = <',TRIM(str),'>'
+
+    add_time = current_time + increment
+    CALL ESMF_TimeGet( add_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+    CALL test_check_error( ESMF_SUCCESS, rc, &
+                          TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                          __FILE__ , &
+                          __LINE__  )
+    CALL fraction_to_string( Sn, Sd, frac_str )
+    str = TRIM(str)//TRIM(frac_str)
+    WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  current_time+increment = <',TRIM(str),'>'
+
+    ! Advance clock.  
+    itestfullname = TRIM(itestname)//'ADVANCE'
+    itimestep = 0
+    DO WHILE ( .NOT. ESMF_ClockIsStopTime(domain_clock ,rc=rc) )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_ClockIsStopTime() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      itimestep = itimestep + 1
+
+      CALL ESMF_ClockAdvance( domain_clock, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_ClockAdvance() ', &
+                            __FILE__ , &
+                            __LINE__  )
+
+      CALL ESMF_ClockGet( domain_clock, CurrTime=current_time, &
+                          rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_ClockGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+
+      CALL ESMF_TimeGet( current_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      str = TRIM(str)//TRIM(frac_str)
+      WRITE(*,FMT='(A,A,I6.6,A,A,A)') TRIM(itestfullname),':  count = ', &
+        itimestep,'  current_time = <',TRIM(str),'>'
+
+      subtract_time = current_time - increment
+      CALL ESMF_TimeGet( subtract_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      str = TRIM(str)//TRIM(frac_str)
+      WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  current_time-increment = <',TRIM(str),'>'
+
+      add_time = current_time + increment
+      CALL ESMF_TimeGet( add_time, timeString=str, Sn=Sn, Sd=Sd, rc=rc )
+      CALL test_check_error( ESMF_SUCCESS, rc, &
+                            TRIM(itestfullname)//'ESMF_TimeGet() ', &
+                            __FILE__ , &
+                            __LINE__  )
+      CALL fraction_to_string( Sn, Sd, frac_str )
+      str = TRIM(str)//TRIM(frac_str)
+      WRITE(*,FMT='(A,A,A,A)') TRIM(itestfullname),':  current_time+increment = <',TRIM(str),'>'
+
+    ENDDO
+
+    DEALLOCATE( domain_clock )
+  
+  END SUBROUTINE test_clock_advance
+
+END MODULE my_tests
+
+
+#if defined( TIME_F90_ONLY ) 
+
+! TBH:  Improve the build of Test1.exe to use WRF versions of these 
+! TBH:  routines and remove these hacked-in duplicates!!  
+
+SUBROUTINE wrf_abort
+  IMPLICIT NONE
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI )
+  INCLUDE 'mpif.h'
+  INTEGER ierr
+  CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+#else
+  STOP
+#endif
+END SUBROUTINE wrf_abort
+
+SUBROUTINE wrf_message( str )
+  IMPLICIT NONE
+  CHARACTER*(*) str
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI)
+  write(0,*) str
+#endif
+  print*, str
+END SUBROUTINE wrf_message
+
+! intentionally write to stderr only
+SUBROUTINE wrf_message2( str )
+  IMPLICIT NONE
+  CHARACTER*(*) str
+  write(0,*) str
+END SUBROUTINE wrf_message2
+
+SUBROUTINE wrf_error_fatal3( file_str, line, str )
+  USE my_tests
+  IMPLICIT NONE
+  CHARACTER*(*) file_str
+  INTEGER , INTENT (IN) :: line  ! only print file and line if line > 0
+  CHARACTER*(*) str
+  CHARACTER*256 :: line_str
+  write(line_str,'(i6)') line
+  ! special behavior for testing since Fortran cannot catch exceptions
+ IF ( WRF_ERROR_FATAL_PRINT ) THEN
+  ! just print message and continue
+  CALL wrf_message( 'ERROR IN FILE:  '//TRIM(file_str)//'  LINE:  '//TRIM(line_str) )
+ ELSE
+  ! normal behavior
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI )
+  CALL wrf_message( '-------------- FATAL CALLED ---------------' )
+  ! only print file and line if line is positive
+  IF ( line > 0 ) THEN
+    CALL wrf_message( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
+  ENDIF
+  CALL wrf_message( str )
+  CALL wrf_message( '-------------------------------------------' )
+#else
+  CALL wrf_message2( '-------------- FATAL CALLED ---------------' )
+  ! only print file and line if line is positive
+  IF ( line > 0 ) THEN
+    CALL wrf_message( 'FATAL CALLED FROM FILE:  '//file_str//'  LINE:  '//TRIM(line_str) )
+  ENDIF
+  CALL wrf_message2( str )
+  CALL wrf_message2( '-------------------------------------------' )
+#endif
+  CALL wrf_abort
+ ENDIF
+END SUBROUTINE wrf_error_fatal3
+
+SUBROUTINE wrf_error_fatal( str )
+  IMPLICIT NONE
+  CHARACTER*(*) str
+  CALL wrf_error_fatal3 ( ' ', 0, str )
+END SUBROUTINE wrf_error_fatal
+
+#endif
+
+
+! Check to see if expected value == actual value
+! If not, print message and exit.
+SUBROUTINE test_check_error( expected, actual, str, file_str, line )
+  IMPLICIT NONE
+  INTEGER , INTENT (IN) :: expected
+  INTEGER , INTENT (IN) :: actual
+  CHARACTER*(*) str
+  CHARACTER*(*) file_str
+  INTEGER , INTENT (IN) :: line
+  CHARACTER (LEN=512)   :: rc_str
+  CHARACTER (LEN=512)   :: str_with_rc
+  IF ( expected .ne. actual ) THEN
+    WRITE (rc_str,*) '  Routine returned error code = ',actual
+    str_with_rc = 'FAIL:  '//TRIM(str)//TRIM(rc_str)
+    CALL wrf_error_fatal3( file_str, line, str_with_rc )
+  ENDIF
+END SUBROUTINE test_check_error
+
+
+
+PROGRAM time_manager_test
+  USE ESMF_Mod
+  USE my_tests
+  IMPLICIT NONE
+  INTEGER :: rc
+
+  PRINT *,'BEGIN TEST SUITE'
+
+  CALL ESMF_Initialize( defaultCalendar=ESMF_CAL_GREGORIAN, rc=rc )
+  CALL test_check_error( ESMF_SUCCESS, rc, &
+                        'ESMF_Initialize() ', &
+                        __FILE__ , &
+                        __LINE__  )
+!  PRINT *,'DEBUG:  back from ESMF_Initialize(), rc = ',rc
+
+!  CALL test_print(  t_yy,  t_mm,  t_dd,  t_h,  t_m,  t_s, &
+!                   ti_yy, ti_mm, ti_dd, ti_h, ti_m, ti_s, &
+!                   res_str, testname )
+
+  ! Print times
+  ! "vanilla" tests
+!  PRINT *,'DEBUG:  calling 1st test_print()'
+  CALL test_print( t_yy=2001,  t_mm=12,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+    res_str='2001-12-03_01:20:10', testname='printT_1' )
+!  PRINT *,'DEBUG:  back from 1st test_print()'
+  CALL test_print( t_yy=0,  t_mm=1,  t_dd=1,  t_h=0,  t_m=0,  t_s=0, &
+    res_str='0000-01-01_00:00:00', testname='printT_2' )
+  CALL test_print( t_yy=2003,  t_mm=12,  t_dd=30,  t_h=23,  t_m=59,  t_s=50, &
+    res_str='2003-12-30_23:59:50', testname='printT_3' )
+  CALL test_print( t_yy=2003,  t_mm=12,  t_dd=31,  t_h=23,  t_m=59,  t_s=50, &
+    res_str='2003-12-31_23:59:50', testname='printT_4' )
+  CALL test_print( t_yy=2004,  t_mm=12,  t_dd=30,  t_h=23,  t_m=59,  t_s=50, &
+    res_str='2004-12-30_23:59:50', testname='printT_5' )
+  CALL test_print( t_yy=2004,  t_mm=12,  t_dd=31,  t_h=23,  t_m=59,  t_s=50, &
+    res_str='2004-12-31_23:59:50', testname='printT_6' )
+!$$$  NOTE that this fails -- need to fix up output string for negative year
+!  CALL test_print( t_yy=-2004,  t_mm=12,  t_dd=31,  t_h=23,  t_m=59,  t_s=50, &
+!    res_str='-2004-12-31_23:59:50', testname='printT_6' )
+
+  ! these test default behavior of test harness
+  CALL test_print( t_s=0, &
+    res_str='0000-01-01_00:00:00', testname='printT_D1' )
+  CALL test_print( t_yy=0, &
+    res_str='0000-01-01_00:00:00', testname='printT_D2' )
+
+  ! fractions
+  CALL test_print( t_yy=2001,  t_mm=12,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+    t_sn=1, t_sd=3, &
+    res_str='2001-12-03_01:20:10+01/03', testname='printT_F1' )
+  CALL test_print( t_yy=2001,  t_mm=12,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+    t_sn=4, t_sd=3, &
+    res_str='2001-12-03_01:20:11+01/03', testname='printT_F2' )
+  CALL test_print( t_yy=2001,  t_mm=12,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+    t_sn=12, t_sd=3, &
+    res_str='2001-12-03_01:20:14', testname='printT_F3' )
+  CALL test_print( t_yy=2001,  t_mm=12,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+    t_sn=-1, t_sd=3, &
+    res_str='2001-12-03_01:20:09+02/03', testname='printT_F4' )
+
+  ! ERROR, MM out of range
+!$$$here...  fix so this just prints "ERROR:  " in failure case
+!$$$here...  also need "expect_fail" to reverse sense of PASS/FAIL message for 
+!$$$here...  tests that should fail
+!  CALL test_print( t_yy=2001,  t_mm=13,  t_dd=3,  t_h=1,  t_m=20,  t_s=10, &
+!    res_str='2002-01-03_01:20:10', testname='printT_E1', expect_error=.TRUE. )
+
+  ! Print time intervals
+  ! "vanilla" tests
+  CALL test_print( ti_yy=0,  ti_mm=0,  ti_dd=0,  ti_h=0,  ti_m=0,  ti_s=0, &
+    res_str='0000000000_000:000:000', testname='printTI_1' )
+  CALL test_print( ti_yy=0,  ti_mm=0,  ti_dd=500,  ti_h=0,  ti_m=0,  ti_s=7270, &
+    res_str='0000000500_002:001:010', testname='printTI_2' )
+
+  ! these test default behavior of test harness
+  CALL test_print( ti_s=0, &
+    res_str='0000000000_000:000:000', testname='printTI_D1' )
+  CALL test_print( ti_yy=0, &
+    res_str='0000000000_000:000:000', testname='printTI_D2' )
+
+  ! these test negative values
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=-3,  ti_h=-1,  ti_m=-20,  ti_s=-10, &
+    res_str='-0000000003_001:020:010', testname='printTI_N1' )
+
+  ! these test mixed values
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=-3,  ti_h=1,  ti_m=20,  ti_s=10, &
+    res_str='-0000000002_022:039:050', testname='printTI_M1' )
+
+  ! fractions
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=3,  ti_h=1,  ti_m=20,  ti_s=10, &
+    ti_sn=1, ti_sd=3, &
+    res_str='0000000003_001:020:010+01/03', testname='printTI_F1' )
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=3,  ti_h=1,  ti_m=20,  ti_s=10, &
+    ti_sn=5, ti_sd=3, &
+    res_str='0000000003_001:020:011+02/03', testname='printTI_F2' )
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=-3,  ti_h=-1,  ti_m=-20,  ti_s=-10, &
+    ti_sn=-1, ti_sd=3, &
+    res_str='-0000000003_001:020:010-01/03', testname='printTI_F3' )
+  CALL test_print( ti_yy=0000,  ti_mm=0,  ti_dd=-3,  ti_h=-1,  ti_m=-20,  ti_s=-10, &
+    ti_sn=1, ti_sd=3, &
+    res_str='-0000000003_001:020:009-02/03', testname='printTI_F4' )
+
+  ! these test non-normalized values
+!  CALL test_print( ti_yy=2001,  ti_mm=1,  ti_dd=3,  ti_h=1,  ti_m=20,  ti_s=10, &
+!    res_str='02001-001-003_001:020:010', testname='printTI_NN1', expect_error=.TRUE. )
+!  CALL test_print( ti_yy=2001,  ti_mm=12,  ti_dd=3,  ti_h=1,  ti_m=20,  ti_s=10, &
+!    res_str='02002-000-003_001:020:010', testname='printTI_NN2', expect_error=.TRUE. )
+!  CALL test_print( ti_yy=2002,  ti_mm=5,  ti_dd=500,  ti_h=0,  ti_m=0,  ti_s=7270, &
+!    res_str='02002-005-500_002:001:010', testname='printTI_NN3', expect_error=.TRUE. )
+
+  ! Addition tests
+  ! ESMF_Time = ESMF_Time + ESMF_TimeInterval
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2001,  op1_t_mm=12,  op1_t_dd=3,  op1_t_h=1,  op1_t_m=20,  op1_t_s=10, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2001,  res_t_mm=12,  res_t_dd=3,  res_t_h=4,  res_t_m=30,  res_t_s=20, &
+    testname='AddT_T_TI1' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2001,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2002,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI2' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2003,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI3' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI4' )
+  ! this case hung after the CCSM contribution
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=31,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI5' )
+! NOTE:  CCSM folks need to decide what it means to add "1 month" to Feb. 29.  And all the 
+!        other very similar cases.  Then, write this unit test!  
+!  CALL test_arithmetic( add_op=.TRUE.,                                             &
+!     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+!    op2_ti_yy=   2, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+!     res_t_yy=2007,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+!    testname='AddT_T_TI6' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm=12,  res_t_dd=30,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI7' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2006,  res_t_mm=01,  res_t_dd=01,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI8' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2003,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=29,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI9' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2003,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=30,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI10' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2003,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=31,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI11' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2003,  op1_t_mm=12,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=368, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm=01,  res_t_dd=01,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI12' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=03,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm=03,  res_t_dd=30,  res_t_h=8,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI13' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=03,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=365, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm=03,  res_t_dd=31,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI14' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=03,  op1_t_dd=30,  op1_t_h=4,  op1_t_m=30,  op1_t_s=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2005,  res_t_mm=04,  res_t_dd=01,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_T_TI15' )
+  ! ESMF_Time = ESMF_Time + ESMF_TimeInterval with fractions
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+     op1_t_sn=01,  op1_t_sd=03, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+    op2_ti_sn=01, op2_ti_sd=03, &
+     res_t_yy=2005,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+     res_t_sn=02,  res_t_sd=03, &
+    testname='AddT_T_TI_F1' )
+  ! this should fail (and does)
+!  CALL test_arithmetic( add_op=.TRUE.,                                             &
+!     op1_t_yy=2004,  op1_t_mm=12,  op1_t_dd=31,  op1_t_h=22,  op1_t_m=30,  op1_t_s=00, &
+!     op1_t_sn=01,  op1_t_sd=03, &
+!    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+!    op2_ti_sn=01, op2_ti_sd=03, &
+!     res_t_yy=2005,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+!     res_t_sn=01,  res_t_sd=03, &
+!    testname='AddT_T_TI_F2' )
+  ! ESMF_Time = ESMF_TimeInterval + ESMF_Time
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+    op1_ti_yy=   0, op1_ti_mm= 0, op1_ti_dd=0, op1_ti_h=3, op1_ti_m=10, op1_ti_s=10, &
+     op2_t_yy=2001,  op2_t_mm=12,  op2_t_dd=3,  op2_t_h=1,  op2_t_m=20,  op2_t_s=10, &
+     res_t_yy=2001,  res_t_mm=12,  res_t_dd=3,  res_t_h=4,  res_t_m=30,  res_t_s=20, &
+    testname='AddT_TI_T1' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+    op1_ti_yy=   0, op1_ti_mm= 0, op1_ti_dd=0, op1_ti_h=4, op1_ti_m=10, op1_ti_s=10, &
+     op2_t_yy=2001,  op2_t_mm=12,  op2_t_dd=31,  op2_t_h=22,  op2_t_m=30,  op2_t_s=00, &
+     res_t_yy=2002,  res_t_mm= 1,  res_t_dd=1,  res_t_h=2,  res_t_m=40,  res_t_s=10, &
+    testname='AddT_TI_T2' )
+  ! ESMF_TimeInterval = ESMF_TimeInterval + ESMF_TimeInterval
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=4, res_ti_h=2, res_ti_m=30, res_ti_s=20, &
+    testname='AddTI_TI_TI1' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-3, op1_ti_h=-1, op1_ti_m=-20, op1_ti_s=-10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-2, res_ti_h=0, res_ti_m=-10, res_ti_s=00, &
+    testname='AddTI_TI_TI2' )
+  CALL test_arithmetic( add_op=.TRUE.,                                             &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-3, op1_ti_h=-1, op1_ti_m=-20, op1_ti_s=-10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-1, op2_ti_h=-1, op2_ti_m=-10, op2_ti_s=-10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-4, res_ti_h=-2, res_ti_m=-30, res_ti_s=-20, &
+    testname='AddTI_TI_TI3' )
+
+  ! Subtraction tests
+  ! ESMF_Time = ESMF_Time - ESMF_TimeInterval
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2001,  op1_t_mm=12,  op1_t_dd=3,  op1_t_h=1,  op1_t_m=20,  op1_t_s=10, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2001,  res_t_mm=12,  res_t_dd=2,  res_t_h=22, res_t_m=10,  res_t_s=0,  &
+    testname='SubtractT_T_TI1' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2005,  op1_t_mm=1,   op1_t_dd=1,  op1_t_h=0,  op1_t_m=00,  op1_t_s=0,  &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=31, res_t_h=23, res_t_m=59,  res_t_s=50, &
+    testname='SubtractT_T_TI2' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2004,  op1_t_mm=1,   op1_t_dd=1,  op1_t_h=0,  op1_t_m=00,  op1_t_s=0,  &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, &
+     res_t_yy=2003,  res_t_mm=12,  res_t_dd=31, res_t_h=23, res_t_m=59,  res_t_s=50, &
+    testname='SubtractT_T_TI3' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2003,  op1_t_mm=1,   op1_t_dd=1,  op1_t_h=0,  op1_t_m=00,  op1_t_s=0,  &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=10, &
+     res_t_yy=2002,  res_t_mm=12,  res_t_dd=31, res_t_h=23, res_t_m=59,  res_t_s=50, &
+    testname='SubtractT_T_TI4' )
+  CALL test_arithmetic( add_op=.FALSE.,                                             &
+     op1_t_yy=2005,  op1_t_mm=04,  op1_t_dd=01,  op1_t_h=2,  op1_t_m=40,  op1_t_s=10, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=366, op2_ti_h=22, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=03,  res_t_dd=30,  res_t_h=4,  res_t_m=30,  res_t_s=00, &
+    testname='SubtractT_T_TI5' )
+  CALL test_arithmetic( add_op=.FALSE.,                                             &
+     op1_t_yy=2006,  op1_t_mm=01,  op1_t_dd=01,  op1_t_h=8,  op1_t_m=40,  op1_t_s=10, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=367, op2_ti_h=4, op2_ti_m=10, op2_ti_s=10, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=30,  res_t_h=4,  res_t_m=30,  res_t_s=00, &
+    testname='SubtractT_T_TI6' )
+  ! ESMF_Time = ESMF_Time - ESMF_TimeInterval with fractions
+  CALL test_arithmetic( add_op=.FALSE.,                                             &
+     op1_t_yy=2005,  op1_t_mm=01,  op1_t_dd=01,  op1_t_h=00,  op1_t_m=00,  op1_t_s=00, &
+     op1_t_sn=00,  op1_t_sd=00, &
+    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=0, op2_ti_m=00, op2_ti_s=01, &
+    op2_ti_sn=01, op2_ti_sd=03, &
+     res_t_yy=2004,  res_t_mm=12,  res_t_dd=31,  res_t_h=23,  res_t_m=59,  res_t_s=58, &
+     res_t_sn=02,  res_t_sd=03, &
+    testname='SubtractT_T_TI_F1' )
+  ! ESMF_TimeInterval = ESMF_Time - ESMF_Time
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2001,  op1_t_mm=12,  op1_t_dd=3,  op1_t_h=1,  op1_t_m=20,  op1_t_s=10, &
+     op2_t_yy=2001,  op2_t_mm=12,  op2_t_dd=1,  op2_t_h=1,  op2_t_m=10,  op2_t_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0,  &
+    testname='SubtractTI_T_T1' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2002,  op1_t_mm=1,   op1_t_dd=1,  op1_t_h=0,  op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2001,  op2_t_mm=12,  op2_t_dd=31, op2_t_h=23, op2_t_m=59,  op2_t_s=50, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, &
+    testname='SubtractTI_T_T2' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2005,  op1_t_mm=1,   op1_t_dd=1,  op1_t_h=0,  op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2004,  op2_t_mm=12,  op2_t_dd=31, op2_t_h=23, op2_t_m=59,  op2_t_s=50, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, &
+    testname='SubtractTI_T_T3' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2003,  op1_t_mm=03,  op1_t_dd=01, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2003,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=23, op2_t_m=59,  op2_t_s=50, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=10, &
+    testname='SubtractTI_T_T4' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2004,  op1_t_mm=03,  op1_t_dd=01, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2004,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=23, op2_t_m=59,  op2_t_s=50, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=1, res_ti_h=0, res_ti_m=00, res_ti_s=10, &
+    testname='SubtractTI_T_T5' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2002,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2002,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T6' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2003,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2002,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=365, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T7' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2004,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2003,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=365, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T8' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2005,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2004,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T9' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2003,  op1_t_mm=03,  op1_t_dd=01, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2002,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T10' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2005,  op1_t_mm=03,  op1_t_dd=01, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2004,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=367, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T11' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2005,  op1_t_mm=03,  op1_t_dd=01, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=2004,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=23, op2_t_m=59,  op2_t_s=50, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=366, res_ti_h=0, res_ti_m=00, res_ti_s=10, &
+    testname='SubtractTI_T_T12' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=2004,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=23, op1_t_m=59,  op1_t_s=50, &
+     op2_t_yy=2005,  op2_t_mm=03,  op2_t_dd=01, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-366, res_ti_h=0, res_ti_m=00, res_ti_s=-10, &
+    testname='SubtractTI_T_T13' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+     op1_t_yy=-2002,  op1_t_mm=02,  op1_t_dd=28, op1_t_h=00, op1_t_m=00,  op1_t_s=00, &
+     op2_t_yy=-2002,  op2_t_mm=02,  op2_t_dd=28, op2_t_h=00, op2_t_m=00,  op2_t_s=00, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=0, res_ti_h=0, res_ti_m=00, res_ti_s=00, &
+    testname='SubtractTI_T_T14' )
+  ! ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0,  &
+    testname='SubtractTI_TI_TI1' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-1, op2_ti_h=-1, op2_ti_m=-10, op2_ti_s=-10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=4, res_ti_h=2, res_ti_m=30, res_ti_s=20,  &
+    testname='SubtractTI_TI_TI2' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-1, op1_ti_h=-1, op1_ti_m=-10, op1_ti_s=-10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=-3, op2_ti_h=-1, op2_ti_m=-20, op2_ti_s=-10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=00,  &
+    testname='SubtractTI_TI_TI3' )
+  ! Negative result ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=1, op1_ti_h=1, op1_ti_m=10, op1_ti_s=10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=3, op2_ti_h=1, op2_ti_m=20, op2_ti_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-2, res_ti_h=0, res_ti_m=-10, res_ti_s=0,  &
+    testname='SubtractTI_TI_TIN1' )
+  CALL test_arithmetic( add_op=.FALSE.,                                            &
+    op1_ti_yy=0000, op1_ti_mm=00, op1_ti_dd=-1, op1_ti_h=-1, op1_ti_m=-10, op1_ti_s=-10, &
+    op2_ti_yy=0000, op2_ti_mm=00, op2_ti_dd=3, op2_ti_h=1, op2_ti_m=20, op2_ti_s=10, &
+    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=-4, res_ti_h=-2, res_ti_m=-30, res_ti_s=-20,  &
+    testname='SubtractTI_TI_TIN2' )
+
+  ! Un-normalized ESMF_TimeInterval = ESMF_TimeInterval - ESMF_TimeInterval
+  ! this is an error
+!  CALL test_arithmetic( add_op=.FALSE.,                                            &
+!    op1_ti_yy=2001, op1_ti_mm=11, op1_ti_dd=3, op1_ti_h=1, op1_ti_m=20, op1_ti_s=10, &
+!    op2_ti_yy=2001, op2_ti_mm=11, op2_ti_dd=1, op2_ti_h=1, op2_ti_m=10, op2_ti_s=10, &
+!    res_ti_yy=0000, res_ti_mm=00, res_ti_dd=2, res_ti_h=0, res_ti_m=10, res_ti_s=0,  &
+!    testname='SubtractTI_TI_TIU1', expect_error=.TRUE. )
+
+  ! this one should FAIL, and does
+!  CALL test_arithmetic( add_op=.TRUE.,                                             &
+!     op1_t_yy=2001,  op1_t_mm=12,  op1_t_dd=3,  op1_t_h=1,  op1_t_m=20,  op1_t_s=10, &
+!    op2_ti_yy=   0, op2_ti_mm= 0, op2_ti_dd=0, op2_ti_h=3, op2_ti_m=10, op2_ti_s=10, &
+!     res_t_yy=2002,  res_t_mm=12,  res_t_dd=3,  res_t_h=4,  res_t_m=30,  res_t_s=20, &
+!    testname='AddTT1' )
+
+  ! Multiplication tests
+  ! ESMF_TimeInterval = ESMF_TimeInterval * INTEGER
+  CALL test_arithmetic( multiply_op=.TRUE.,                &
+    op1_ti_dd=3,  op1_ti_h=12,  op1_ti_m=18,  op1_ti_s=33, &
+    op2_int=2,                                             &
+    res_ti_dd=6,  res_ti_h=24, res_ti_m=37,  res_ti_s=06,  &
+    testname='MultiplyTI_TI_INT1' )
+  CALL test_arithmetic( multiply_op=.TRUE.,                &
+    op1_ti_dd=350,  op1_ti_h=23,  op1_ti_m=50,  op1_ti_s=50, &
+    op2_int=2,                                             &
+    res_ti_dd=701,  res_ti_h=23, res_ti_m=41,  res_ti_s=40,&
+    testname='MultiplyTI_TI_INT2' )
+  CALL test_arithmetic( multiply_op=.TRUE.,                &
+    op1_ti_s=01, op1_ti_sn=03, op1_ti_sd=04,               &
+    op2_int=8,                                             &
+    res_ti_s=14,                                           &
+    testname='MultiplyTI_TI_INT3' )
+
+  ! Division tests
+  ! ESMF_TimeInterval = ESMF_TimeInterval / INTEGER
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=3,  op1_ti_h=12,  op1_ti_m=18,  op1_ti_s=33, &
+    op2_int=3,                                             &
+    res_ti_dd=1,  res_ti_h=04, res_ti_m=06,  res_ti_s=11,  &
+    testname='DivideTI_TI_INT1' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=3,  op1_ti_h=12,  op1_ti_m=18,  op1_ti_s=33, &
+    op2_int=4,                                             &
+    res_ti_dd=0,  res_ti_h=21, res_ti_m=04,  res_ti_s=38,  &
+    res_ti_sn=1,  res_ti_sd=4,                             &
+    testname='DivideTI_TI_INT2' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_s=01, op1_ti_sn=03, op1_ti_sd=04,               &
+    op2_int=5,                                             &
+    res_ti_s=0, res_ti_sn=7,  res_ti_sd=20,                &
+    testname='DivideTI_TI_INT3' )
+  ! INTEGER = ESMF_TimeInterval / ESMF_TimeInterval
+  ! this operator truncates to whole integers
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=3,  op1_ti_h=12,  op1_ti_m=18,  op1_ti_s=33, &
+    op2_ti_dd=3,  op2_ti_h=12,  op2_ti_m=18,  op2_ti_s=33, &
+    res_int=1,                                             &
+    testname='DivideINT_TI_TI1' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=6,  op1_ti_h=24,  op1_ti_m=36,  op1_ti_s=66, &
+    op2_ti_dd=3,  op2_ti_h=12,  op2_ti_m=18,  op2_ti_s=33, &
+    res_int=2,                                             &
+    testname='DivideINT_TI_TI2' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=0,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=00, &
+    op2_ti_dd=3,  op2_ti_h=12,  op2_ti_m=18,  op2_ti_s=33, &
+    res_int=0,                                             &
+    testname='DivideINT_TI_TI3' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=1,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=00, &
+    op2_ti_dd=0,  op2_ti_h=01,  op2_ti_m=00,  op2_ti_s=00, &
+    res_int=24,                                            &
+    testname='DivideINT_TI_TI4' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=1,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=00, &
+    op2_ti_dd=0,  op2_ti_h=00,  op2_ti_m=01,  op2_ti_s=00, &
+    res_int=1440,                                          &
+    testname='DivideINT_TI_TI5' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=1,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=00, &
+    op2_ti_dd=0,  op2_ti_h=00,  op2_ti_m=00,  op2_ti_s=01, &
+    res_int=86400,                                         &
+    testname='DivideINT_TI_TI6' )
+  ! rounding
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=0,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=03, &
+    op2_ti_dd=0,  op2_ti_h=00,  op2_ti_m=00,  op2_ti_s=02, &
+    res_int=1,                                             &
+    testname='DivideINT_TI_TIR1' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=1,  op1_ti_h=00,  op1_ti_m=00,  op1_ti_s=02, &
+    op2_ti_dd=1,  op2_ti_h=00,  op2_ti_m=00,  op2_ti_s=03, &
+    res_int=0,                                             &
+    testname='DivideINT_TI_TIR2' )
+  ! fractional operands
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_m=00,  op1_ti_s=00, op1_ti_sn=03, op1_ti_sd=04, &
+    op2_ti_m=00,  op2_ti_s=00, op2_ti_sn=03, op2_ti_sd=04, &
+    res_int=1,                                             &
+    testname='DivideINT_TI_TIF1' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_m=00,  op1_ti_s=00, op1_ti_sn=06, op1_ti_sd=08, &
+    op2_ti_m=00,  op2_ti_s=00, op2_ti_sn=03, op2_ti_sd=04, &
+    res_int=1,                                             &
+    testname='DivideINT_TI_TIF2' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_m=00,  op1_ti_s=00, op1_ti_sn=03, op1_ti_sd=04, &
+    op2_ti_m=00,  op2_ti_s=00, op2_ti_sn=04, op2_ti_sd=03, &
+    res_int=0,                                             &
+    testname='DivideINT_TI_TIF3' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_m=00,  op1_ti_s=02, op1_ti_sn=03, op1_ti_sd=04, &
+    op2_ti_m=00,  op2_ti_s=01, op2_ti_sn=01, op2_ti_sd=03, &
+    res_int=2,                                             &
+    testname='DivideINT_TI_TIF4' )
+  ! negative operands
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=-6,  op1_ti_h=-24,  op1_ti_m=-36,  op1_ti_s=-66, &
+    op2_ti_dd=3,  op2_ti_h=12,  op2_ti_m=18,  op2_ti_s=33, &
+    res_int=-2,                                             &
+    testname='DivideINT_TI_TIN1' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=6,  op1_ti_h=24,  op1_ti_m=36,  op1_ti_s=66, &
+    op2_ti_dd=-3,  op2_ti_h=-12,  op2_ti_m=-18,  op2_ti_s=-33, &
+    res_int=-2,                                             &
+    testname='DivideINT_TI_TIN2' )
+  CALL test_arithmetic( multiply_op=.FALSE.,               &
+    op1_ti_dd=-6,  op1_ti_h=-24,  op1_ti_m=-36,  op1_ti_s=-66, &
+    op2_ti_dd=-3,  op2_ti_h=-12,  op2_ti_m=-18,  op2_ti_s=-33, &
+    res_int=2,                                             &
+    testname='DivideINT_TI_TIN3' )
+
+!$$$here...  modify these to add self-test PASS/FAIL output
+  CALL test_clock_advance(                                                    &
+    start_yy=2002, start_mm=12, start_dd=27, start_h=3, start_m=0, start_s=0, &
+     stop_yy=2002,  stop_mm=12,  stop_dd=28,  stop_h=8,  stop_m=0,  stop_s=0, &
+    timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=600,                 &
+    testname="SimpleClockAdvance" )
+
+  CALL test_clock_advance(                                                    &
+    start_yy=2003, start_mm=12, start_dd=29, start_h=9, start_m=0, start_s=0, &
+     stop_yy=2004,  stop_mm=1,   stop_dd=2,   stop_h=9,  stop_m=0,  stop_s=0, &
+    timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=3600,                &
+    testname="StdYearClockAdvance", increment_S=10 )
+
+  CALL test_clock_advance(                                                    &
+    start_yy=2004, start_mm=12, start_dd=29, start_h=9, start_m=0, start_s=0, &
+     stop_yy=2005,  stop_mm=1,   stop_dd=2,   stop_h=9,  stop_m=0,  stop_s=0, &
+    timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=3600,                &
+    testname="LeapYearClockAdvance", increment_S=10 )
+
+  ! NRCM domain 3 case:  120 seconds / 9 
+  ! 18 timesteps through end of leap year
+  CALL test_clock_advance(                                                    &
+    start_yy=2004, start_mm=12, start_dd=31, start_h=23, start_m=58, start_s=0,&
+     stop_yy=2005,  stop_mm=1,   stop_dd=1,   stop_h=0,  stop_m=2,  stop_s=0, &
+    timestep_d=0, timestep_h=0, timestep_m=0, timestep_s=13,                  &
+    timestep_sn=1, timestep_sd=3,                                             &
+    testname="LeapYearFractionClockAdvance",                                  &
+    increment_S=1, increment_Sn=1, increment_Sd=3 )
+
+  CALL ESMF_Finalize( rc=rc )
+  CALL test_check_error( ESMF_SUCCESS, rc, &
+                        'ESMF_Finalize() ', &
+                        __FILE__ , &
+                        __LINE__  )
+
+  PRINT *,'END TEST SUITE'
+
+END PROGRAM time_manager_test
+
diff --git a/wrfv2_fire/external/esmf_time_f90/Test1.out.correct b/wrfv2_fire/external/esmf_time_f90/Test1.out.correct
new file mode 100644
index 00000000..a07bddbf
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/Test1.out.correct
@@ -0,0 +1,1275 @@
+ BEGIN TEST SUITE
+PASS:  printT_1
+PASS:  printT_2
+PASS:  printT_3
+PASS:  printT_4
+PASS:  printT_5
+PASS:  printT_6
+PASS:  printT_D1
+PASS:  printT_D2
+PASS:  printT_F1
+PASS:  printT_F2
+PASS:  printT_F3
+PASS:  printT_F4
+PASS:  printTI_1
+PASS:  printTI_2
+PASS:  printTI_D1
+PASS:  printTI_D2
+PASS:  printTI_N1
+PASS:  printTI_M1
+PASS:  printTI_F1
+PASS:  printTI_F2
+PASS:  printTI_F3
+PASS:  printTI_F4
+PASS:  AddT_T_TI1
+PASS:  AddT_T_TI2
+PASS:  AddT_T_TI3
+PASS:  AddT_T_TI4
+PASS:  AddT_T_TI5
+PASS:  AddT_T_TI7
+PASS:  AddT_T_TI8
+PASS:  AddT_T_TI9
+PASS:  AddT_T_TI10
+PASS:  AddT_T_TI11
+PASS:  AddT_T_TI12
+PASS:  AddT_T_TI13
+PASS:  AddT_T_TI14
+PASS:  AddT_T_TI15
+PASS:  AddT_T_TI_F1
+PASS:  AddT_TI_T1
+PASS:  AddT_TI_T2
+PASS:  AddTI_TI_TI1
+PASS:  AddTI_TI_TI2
+PASS:  AddTI_TI_TI3
+PASS:  SubtractT_T_TI1
+PASS:  SubtractT_T_TI2
+PASS:  SubtractT_T_TI3
+PASS:  SubtractT_T_TI4
+PASS:  SubtractT_T_TI5
+PASS:  SubtractT_T_TI6
+PASS:  SubtractT_T_TI_F1
+PASS:  SubtractTI_T_T1
+PASS:  SubtractTI_T_T2
+PASS:  SubtractTI_T_T3
+PASS:  SubtractTI_T_T4
+PASS:  SubtractTI_T_T5
+PASS:  SubtractTI_T_T6
+PASS:  SubtractTI_T_T7
+PASS:  SubtractTI_T_T8
+PASS:  SubtractTI_T_T9
+PASS:  SubtractTI_T_T10
+PASS:  SubtractTI_T_T11
+PASS:  SubtractTI_T_T12
+PASS:  SubtractTI_T_T13
+PASS:  SubtractTI_T_T14
+PASS:  SubtractTI_TI_TI1
+PASS:  SubtractTI_TI_TI2
+PASS:  SubtractTI_TI_TI3
+PASS:  SubtractTI_TI_TIN1
+PASS:  SubtractTI_TI_TIN2
+PASS:  MultiplyTI_TI_INT1
+PASS:  MultiplyTI_TI_INT2
+PASS:  MultiplyTI_TI_INT3
+PASS:  DivideTI_TI_INT1
+PASS:  DivideTI_TI_INT2
+PASS:  DivideTI_TI_INT3
+PASS:  DivideINT_TI_TI1
+PASS:  DivideINT_TI_TI2
+PASS:  DivideINT_TI_TI3
+PASS:  DivideINT_TI_TI4
+PASS:  DivideINT_TI_TI5
+PASS:  DivideINT_TI_TI6
+PASS:  DivideINT_TI_TIR1
+PASS:  DivideINT_TI_TIR2
+PASS:  DivideINT_TI_TIF1
+PASS:  DivideINT_TI_TIF2
+PASS:  DivideINT_TI_TIF3
+PASS:  DivideINT_TI_TIF4
+PASS:  DivideINT_TI_TIN1
+PASS:  DivideINT_TI_TIN2
+PASS:  DivideINT_TI_TIN3
+SimpleClockAdvance_SETUP:  start_time = <2002-12-27_03:00:00>
+SimpleClockAdvance_SETUP:  stop_time = <2002-12-28_08:00:00>
+SimpleClockAdvance_SETUP:  timestep = <0000000000_000:010:000>
+SimpleClockAdvance_SETUP:  increment = <0000000000_000:000:000>
+SimpleClockAdvance_SETUP:  clock current_time = <2002-12-27_03:00:00>
+SimpleClockAdvance_SETUP:  current_time dayOfYear_r8 = < 361.125000 >
+SimpleClockAdvance_SETUP:  current_time-increment = <2002-12-27_03:00:00>
+SimpleClockAdvance_SETUP:  current_time+increment = <2002-12-27_03:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000001  current_time = <2002-12-27_03:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_03:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_03:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000002  current_time = <2002-12-27_03:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_03:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_03:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000003  current_time = <2002-12-27_03:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_03:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_03:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000004  current_time = <2002-12-27_03:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_03:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_03:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000005  current_time = <2002-12-27_03:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_03:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_03:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000006  current_time = <2002-12-27_04:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000007  current_time = <2002-12-27_04:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000008  current_time = <2002-12-27_04:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000009  current_time = <2002-12-27_04:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000010  current_time = <2002-12-27_04:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000011  current_time = <2002-12-27_04:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_04:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_04:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000012  current_time = <2002-12-27_05:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000013  current_time = <2002-12-27_05:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000014  current_time = <2002-12-27_05:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000015  current_time = <2002-12-27_05:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000016  current_time = <2002-12-27_05:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000017  current_time = <2002-12-27_05:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_05:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_05:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000018  current_time = <2002-12-27_06:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000019  current_time = <2002-12-27_06:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000020  current_time = <2002-12-27_06:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000021  current_time = <2002-12-27_06:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000022  current_time = <2002-12-27_06:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000023  current_time = <2002-12-27_06:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_06:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_06:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000024  current_time = <2002-12-27_07:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000025  current_time = <2002-12-27_07:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000026  current_time = <2002-12-27_07:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000027  current_time = <2002-12-27_07:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000028  current_time = <2002-12-27_07:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000029  current_time = <2002-12-27_07:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_07:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_07:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000030  current_time = <2002-12-27_08:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000031  current_time = <2002-12-27_08:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000032  current_time = <2002-12-27_08:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000033  current_time = <2002-12-27_08:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000034  current_time = <2002-12-27_08:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000035  current_time = <2002-12-27_08:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_08:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_08:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000036  current_time = <2002-12-27_09:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000037  current_time = <2002-12-27_09:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000038  current_time = <2002-12-27_09:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000039  current_time = <2002-12-27_09:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000040  current_time = <2002-12-27_09:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000041  current_time = <2002-12-27_09:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_09:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_09:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000042  current_time = <2002-12-27_10:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000043  current_time = <2002-12-27_10:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000044  current_time = <2002-12-27_10:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000045  current_time = <2002-12-27_10:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000046  current_time = <2002-12-27_10:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000047  current_time = <2002-12-27_10:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_10:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_10:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000048  current_time = <2002-12-27_11:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000049  current_time = <2002-12-27_11:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000050  current_time = <2002-12-27_11:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000051  current_time = <2002-12-27_11:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000052  current_time = <2002-12-27_11:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000053  current_time = <2002-12-27_11:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_11:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_11:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000054  current_time = <2002-12-27_12:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000055  current_time = <2002-12-27_12:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000056  current_time = <2002-12-27_12:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000057  current_time = <2002-12-27_12:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000058  current_time = <2002-12-27_12:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000059  current_time = <2002-12-27_12:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_12:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_12:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000060  current_time = <2002-12-27_13:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000061  current_time = <2002-12-27_13:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000062  current_time = <2002-12-27_13:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000063  current_time = <2002-12-27_13:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000064  current_time = <2002-12-27_13:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000065  current_time = <2002-12-27_13:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_13:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_13:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000066  current_time = <2002-12-27_14:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000067  current_time = <2002-12-27_14:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000068  current_time = <2002-12-27_14:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000069  current_time = <2002-12-27_14:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000070  current_time = <2002-12-27_14:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000071  current_time = <2002-12-27_14:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_14:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_14:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000072  current_time = <2002-12-27_15:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000073  current_time = <2002-12-27_15:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000074  current_time = <2002-12-27_15:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000075  current_time = <2002-12-27_15:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000076  current_time = <2002-12-27_15:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000077  current_time = <2002-12-27_15:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_15:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_15:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000078  current_time = <2002-12-27_16:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000079  current_time = <2002-12-27_16:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000080  current_time = <2002-12-27_16:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000081  current_time = <2002-12-27_16:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000082  current_time = <2002-12-27_16:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000083  current_time = <2002-12-27_16:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_16:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_16:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000084  current_time = <2002-12-27_17:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000085  current_time = <2002-12-27_17:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000086  current_time = <2002-12-27_17:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000087  current_time = <2002-12-27_17:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000088  current_time = <2002-12-27_17:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000089  current_time = <2002-12-27_17:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_17:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_17:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000090  current_time = <2002-12-27_18:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000091  current_time = <2002-12-27_18:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000092  current_time = <2002-12-27_18:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000093  current_time = <2002-12-27_18:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000094  current_time = <2002-12-27_18:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000095  current_time = <2002-12-27_18:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_18:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_18:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000096  current_time = <2002-12-27_19:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000097  current_time = <2002-12-27_19:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000098  current_time = <2002-12-27_19:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000099  current_time = <2002-12-27_19:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000100  current_time = <2002-12-27_19:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000101  current_time = <2002-12-27_19:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_19:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_19:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000102  current_time = <2002-12-27_20:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000103  current_time = <2002-12-27_20:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000104  current_time = <2002-12-27_20:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000105  current_time = <2002-12-27_20:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000106  current_time = <2002-12-27_20:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000107  current_time = <2002-12-27_20:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_20:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_20:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000108  current_time = <2002-12-27_21:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000109  current_time = <2002-12-27_21:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000110  current_time = <2002-12-27_21:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000111  current_time = <2002-12-27_21:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000112  current_time = <2002-12-27_21:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000113  current_time = <2002-12-27_21:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_21:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_21:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000114  current_time = <2002-12-27_22:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000115  current_time = <2002-12-27_22:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000116  current_time = <2002-12-27_22:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000117  current_time = <2002-12-27_22:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000118  current_time = <2002-12-27_22:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000119  current_time = <2002-12-27_22:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_22:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_22:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000120  current_time = <2002-12-27_23:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000121  current_time = <2002-12-27_23:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000122  current_time = <2002-12-27_23:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000123  current_time = <2002-12-27_23:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000124  current_time = <2002-12-27_23:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000125  current_time = <2002-12-27_23:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-27_23:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-27_23:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000126  current_time = <2002-12-28_00:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000127  current_time = <2002-12-28_00:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000128  current_time = <2002-12-28_00:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000129  current_time = <2002-12-28_00:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000130  current_time = <2002-12-28_00:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000131  current_time = <2002-12-28_00:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_00:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_00:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000132  current_time = <2002-12-28_01:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000133  current_time = <2002-12-28_01:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000134  current_time = <2002-12-28_01:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000135  current_time = <2002-12-28_01:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000136  current_time = <2002-12-28_01:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000137  current_time = <2002-12-28_01:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_01:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_01:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000138  current_time = <2002-12-28_02:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000139  current_time = <2002-12-28_02:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000140  current_time = <2002-12-28_02:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000141  current_time = <2002-12-28_02:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000142  current_time = <2002-12-28_02:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000143  current_time = <2002-12-28_02:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_02:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_02:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000144  current_time = <2002-12-28_03:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000145  current_time = <2002-12-28_03:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000146  current_time = <2002-12-28_03:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000147  current_time = <2002-12-28_03:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000148  current_time = <2002-12-28_03:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000149  current_time = <2002-12-28_03:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_03:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_03:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000150  current_time = <2002-12-28_04:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000151  current_time = <2002-12-28_04:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000152  current_time = <2002-12-28_04:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000153  current_time = <2002-12-28_04:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000154  current_time = <2002-12-28_04:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000155  current_time = <2002-12-28_04:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_04:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_04:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000156  current_time = <2002-12-28_05:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000157  current_time = <2002-12-28_05:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000158  current_time = <2002-12-28_05:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000159  current_time = <2002-12-28_05:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000160  current_time = <2002-12-28_05:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000161  current_time = <2002-12-28_05:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_05:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_05:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000162  current_time = <2002-12-28_06:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000163  current_time = <2002-12-28_06:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000164  current_time = <2002-12-28_06:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000165  current_time = <2002-12-28_06:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000166  current_time = <2002-12-28_06:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000167  current_time = <2002-12-28_06:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_06:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_06:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000168  current_time = <2002-12-28_07:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:00:00>
+SimpleClockAdvance_ADVANCE:  count = 000169  current_time = <2002-12-28_07:10:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:10:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:10:00>
+SimpleClockAdvance_ADVANCE:  count = 000170  current_time = <2002-12-28_07:20:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:20:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:20:00>
+SimpleClockAdvance_ADVANCE:  count = 000171  current_time = <2002-12-28_07:30:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:30:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:30:00>
+SimpleClockAdvance_ADVANCE:  count = 000172  current_time = <2002-12-28_07:40:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:40:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:40:00>
+SimpleClockAdvance_ADVANCE:  count = 000173  current_time = <2002-12-28_07:50:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_07:50:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_07:50:00>
+SimpleClockAdvance_ADVANCE:  count = 000174  current_time = <2002-12-28_08:00:00>
+SimpleClockAdvance_ADVANCE:  current_time-increment = <2002-12-28_08:00:00>
+SimpleClockAdvance_ADVANCE:  current_time+increment = <2002-12-28_08:00:00>
+StdYearClockAdvance_SETUP:  start_time = <2003-12-29_09:00:00>
+StdYearClockAdvance_SETUP:  stop_time = <2004-01-02_09:00:00>
+StdYearClockAdvance_SETUP:  timestep = <0000000000_001:000:000>
+StdYearClockAdvance_SETUP:  increment = <0000000000_000:000:010>
+StdYearClockAdvance_SETUP:  clock current_time = <2003-12-29_09:00:00>
+StdYearClockAdvance_SETUP:  current_time dayOfYear_r8 = < 363.375000 >
+StdYearClockAdvance_SETUP:  current_time-increment = <2003-12-29_08:59:50>
+StdYearClockAdvance_SETUP:  current_time+increment = <2003-12-29_09:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000001  current_time = <2003-12-29_10:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_09:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_10:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000002  current_time = <2003-12-29_11:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_10:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_11:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000003  current_time = <2003-12-29_12:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_11:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_12:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000004  current_time = <2003-12-29_13:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_12:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_13:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000005  current_time = <2003-12-29_14:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_13:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_14:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000006  current_time = <2003-12-29_15:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_14:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_15:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000007  current_time = <2003-12-29_16:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_15:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_16:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000008  current_time = <2003-12-29_17:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_16:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_17:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000009  current_time = <2003-12-29_18:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_17:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_18:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000010  current_time = <2003-12-29_19:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_18:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_19:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000011  current_time = <2003-12-29_20:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_19:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_20:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000012  current_time = <2003-12-29_21:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_20:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_21:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000013  current_time = <2003-12-29_22:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_21:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_22:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000014  current_time = <2003-12-29_23:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_22:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-29_23:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000015  current_time = <2003-12-30_00:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-29_23:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_00:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000016  current_time = <2003-12-30_01:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_00:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_01:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000017  current_time = <2003-12-30_02:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_01:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_02:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000018  current_time = <2003-12-30_03:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_02:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_03:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000019  current_time = <2003-12-30_04:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_03:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_04:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000020  current_time = <2003-12-30_05:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_04:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_05:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000021  current_time = <2003-12-30_06:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_05:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_06:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000022  current_time = <2003-12-30_07:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_06:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_07:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000023  current_time = <2003-12-30_08:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_07:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_08:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000024  current_time = <2003-12-30_09:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_08:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_09:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000025  current_time = <2003-12-30_10:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_09:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_10:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000026  current_time = <2003-12-30_11:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_10:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_11:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000027  current_time = <2003-12-30_12:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_11:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_12:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000028  current_time = <2003-12-30_13:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_12:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_13:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000029  current_time = <2003-12-30_14:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_13:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_14:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000030  current_time = <2003-12-30_15:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_14:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_15:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000031  current_time = <2003-12-30_16:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_15:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_16:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000032  current_time = <2003-12-30_17:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_16:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_17:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000033  current_time = <2003-12-30_18:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_17:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_18:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000034  current_time = <2003-12-30_19:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_18:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_19:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000035  current_time = <2003-12-30_20:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_19:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_20:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000036  current_time = <2003-12-30_21:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_20:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_21:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000037  current_time = <2003-12-30_22:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_21:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_22:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000038  current_time = <2003-12-30_23:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_22:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-30_23:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000039  current_time = <2003-12-31_00:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-30_23:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_00:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000040  current_time = <2003-12-31_01:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_00:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_01:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000041  current_time = <2003-12-31_02:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_01:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_02:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000042  current_time = <2003-12-31_03:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_02:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_03:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000043  current_time = <2003-12-31_04:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_03:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_04:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000044  current_time = <2003-12-31_05:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_04:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_05:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000045  current_time = <2003-12-31_06:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_05:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_06:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000046  current_time = <2003-12-31_07:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_06:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_07:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000047  current_time = <2003-12-31_08:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_07:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_08:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000048  current_time = <2003-12-31_09:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_08:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_09:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000049  current_time = <2003-12-31_10:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_09:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_10:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000050  current_time = <2003-12-31_11:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_10:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_11:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000051  current_time = <2003-12-31_12:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_11:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_12:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000052  current_time = <2003-12-31_13:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_12:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_13:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000053  current_time = <2003-12-31_14:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_13:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_14:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000054  current_time = <2003-12-31_15:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_14:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_15:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000055  current_time = <2003-12-31_16:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_15:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_16:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000056  current_time = <2003-12-31_17:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_16:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_17:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000057  current_time = <2003-12-31_18:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_17:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_18:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000058  current_time = <2003-12-31_19:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_18:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_19:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000059  current_time = <2003-12-31_20:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_19:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_20:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000060  current_time = <2003-12-31_21:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_20:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_21:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000061  current_time = <2003-12-31_22:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_21:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_22:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000062  current_time = <2003-12-31_23:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_22:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2003-12-31_23:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000063  current_time = <2004-01-01_00:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2003-12-31_23:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_00:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000064  current_time = <2004-01-01_01:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_00:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_01:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000065  current_time = <2004-01-01_02:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_01:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_02:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000066  current_time = <2004-01-01_03:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_02:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_03:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000067  current_time = <2004-01-01_04:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_03:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_04:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000068  current_time = <2004-01-01_05:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_04:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_05:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000069  current_time = <2004-01-01_06:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_05:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_06:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000070  current_time = <2004-01-01_07:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_06:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_07:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000071  current_time = <2004-01-01_08:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_07:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_08:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000072  current_time = <2004-01-01_09:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_08:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_09:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000073  current_time = <2004-01-01_10:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_09:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_10:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000074  current_time = <2004-01-01_11:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_10:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_11:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000075  current_time = <2004-01-01_12:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_11:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_12:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000076  current_time = <2004-01-01_13:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_12:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_13:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000077  current_time = <2004-01-01_14:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_13:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_14:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000078  current_time = <2004-01-01_15:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_14:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_15:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000079  current_time = <2004-01-01_16:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_15:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_16:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000080  current_time = <2004-01-01_17:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_16:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_17:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000081  current_time = <2004-01-01_18:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_17:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_18:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000082  current_time = <2004-01-01_19:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_18:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_19:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000083  current_time = <2004-01-01_20:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_19:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_20:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000084  current_time = <2004-01-01_21:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_20:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_21:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000085  current_time = <2004-01-01_22:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_21:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_22:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000086  current_time = <2004-01-01_23:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_22:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-01_23:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000087  current_time = <2004-01-02_00:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-01_23:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_00:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000088  current_time = <2004-01-02_01:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_00:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_01:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000089  current_time = <2004-01-02_02:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_01:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_02:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000090  current_time = <2004-01-02_03:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_02:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_03:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000091  current_time = <2004-01-02_04:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_03:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_04:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000092  current_time = <2004-01-02_05:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_04:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_05:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000093  current_time = <2004-01-02_06:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_05:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_06:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000094  current_time = <2004-01-02_07:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_06:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_07:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000095  current_time = <2004-01-02_08:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_07:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_08:00:10>
+StdYearClockAdvance_ADVANCE:  count = 000096  current_time = <2004-01-02_09:00:00>
+StdYearClockAdvance_ADVANCE:  current_time-increment = <2004-01-02_08:59:50>
+StdYearClockAdvance_ADVANCE:  current_time+increment = <2004-01-02_09:00:10>
+LeapYearClockAdvance_SETUP:  start_time = <2004-12-29_09:00:00>
+LeapYearClockAdvance_SETUP:  stop_time = <2005-01-02_09:00:00>
+LeapYearClockAdvance_SETUP:  timestep = <0000000000_001:000:000>
+LeapYearClockAdvance_SETUP:  increment = <0000000000_000:000:010>
+LeapYearClockAdvance_SETUP:  clock current_time = <2004-12-29_09:00:00>
+LeapYearClockAdvance_SETUP:  current_time dayOfYear_r8 = < 364.375000 >
+LeapYearClockAdvance_SETUP:  current_time-increment = <2004-12-29_08:59:50>
+LeapYearClockAdvance_SETUP:  current_time+increment = <2004-12-29_09:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000001  current_time = <2004-12-29_10:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_09:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_10:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000002  current_time = <2004-12-29_11:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_10:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_11:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000003  current_time = <2004-12-29_12:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_11:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_12:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000004  current_time = <2004-12-29_13:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_12:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_13:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000005  current_time = <2004-12-29_14:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_13:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_14:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000006  current_time = <2004-12-29_15:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_14:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_15:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000007  current_time = <2004-12-29_16:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_15:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_16:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000008  current_time = <2004-12-29_17:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_16:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_17:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000009  current_time = <2004-12-29_18:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_17:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_18:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000010  current_time = <2004-12-29_19:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_18:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_19:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000011  current_time = <2004-12-29_20:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_19:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_20:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000012  current_time = <2004-12-29_21:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_20:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_21:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000013  current_time = <2004-12-29_22:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_21:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_22:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000014  current_time = <2004-12-29_23:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_22:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-29_23:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000015  current_time = <2004-12-30_00:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-29_23:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_00:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000016  current_time = <2004-12-30_01:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_00:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_01:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000017  current_time = <2004-12-30_02:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_01:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_02:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000018  current_time = <2004-12-30_03:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_02:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_03:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000019  current_time = <2004-12-30_04:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_03:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_04:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000020  current_time = <2004-12-30_05:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_04:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_05:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000021  current_time = <2004-12-30_06:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_05:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_06:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000022  current_time = <2004-12-30_07:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_06:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_07:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000023  current_time = <2004-12-30_08:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_07:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_08:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000024  current_time = <2004-12-30_09:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_08:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_09:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000025  current_time = <2004-12-30_10:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_09:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_10:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000026  current_time = <2004-12-30_11:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_10:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_11:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000027  current_time = <2004-12-30_12:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_11:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_12:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000028  current_time = <2004-12-30_13:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_12:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_13:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000029  current_time = <2004-12-30_14:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_13:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_14:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000030  current_time = <2004-12-30_15:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_14:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_15:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000031  current_time = <2004-12-30_16:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_15:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_16:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000032  current_time = <2004-12-30_17:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_16:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_17:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000033  current_time = <2004-12-30_18:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_17:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_18:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000034  current_time = <2004-12-30_19:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_18:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_19:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000035  current_time = <2004-12-30_20:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_19:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_20:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000036  current_time = <2004-12-30_21:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_20:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_21:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000037  current_time = <2004-12-30_22:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_21:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_22:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000038  current_time = <2004-12-30_23:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_22:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-30_23:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000039  current_time = <2004-12-31_00:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-30_23:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_00:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000040  current_time = <2004-12-31_01:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_00:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_01:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000041  current_time = <2004-12-31_02:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_01:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_02:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000042  current_time = <2004-12-31_03:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_02:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_03:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000043  current_time = <2004-12-31_04:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_03:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_04:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000044  current_time = <2004-12-31_05:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_04:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_05:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000045  current_time = <2004-12-31_06:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_05:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_06:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000046  current_time = <2004-12-31_07:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_06:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_07:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000047  current_time = <2004-12-31_08:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_07:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_08:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000048  current_time = <2004-12-31_09:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_08:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_09:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000049  current_time = <2004-12-31_10:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_09:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_10:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000050  current_time = <2004-12-31_11:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_10:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_11:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000051  current_time = <2004-12-31_12:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_11:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_12:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000052  current_time = <2004-12-31_13:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_12:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_13:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000053  current_time = <2004-12-31_14:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_13:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_14:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000054  current_time = <2004-12-31_15:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_14:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_15:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000055  current_time = <2004-12-31_16:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_15:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_16:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000056  current_time = <2004-12-31_17:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_16:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_17:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000057  current_time = <2004-12-31_18:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_17:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_18:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000058  current_time = <2004-12-31_19:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_18:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_19:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000059  current_time = <2004-12-31_20:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_19:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_20:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000060  current_time = <2004-12-31_21:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_20:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_21:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000061  current_time = <2004-12-31_22:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_21:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_22:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000062  current_time = <2004-12-31_23:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_22:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000063  current_time = <2005-01-01_00:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000064  current_time = <2005-01-01_01:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_01:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000065  current_time = <2005-01-01_02:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_01:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_02:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000066  current_time = <2005-01-01_03:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_02:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_03:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000067  current_time = <2005-01-01_04:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_03:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_04:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000068  current_time = <2005-01-01_05:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_04:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_05:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000069  current_time = <2005-01-01_06:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_05:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_06:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000070  current_time = <2005-01-01_07:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_06:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_07:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000071  current_time = <2005-01-01_08:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_07:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_08:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000072  current_time = <2005-01-01_09:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_08:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_09:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000073  current_time = <2005-01-01_10:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_09:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_10:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000074  current_time = <2005-01-01_11:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_10:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_11:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000075  current_time = <2005-01-01_12:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_11:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_12:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000076  current_time = <2005-01-01_13:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_12:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_13:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000077  current_time = <2005-01-01_14:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_13:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_14:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000078  current_time = <2005-01-01_15:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_14:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_15:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000079  current_time = <2005-01-01_16:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_15:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_16:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000080  current_time = <2005-01-01_17:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_16:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_17:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000081  current_time = <2005-01-01_18:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_17:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_18:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000082  current_time = <2005-01-01_19:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_18:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_19:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000083  current_time = <2005-01-01_20:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_19:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_20:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000084  current_time = <2005-01-01_21:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_20:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_21:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000085  current_time = <2005-01-01_22:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_21:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_22:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000086  current_time = <2005-01-01_23:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_22:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_23:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000087  current_time = <2005-01-02_00:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_23:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_00:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000088  current_time = <2005-01-02_01:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_00:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_01:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000089  current_time = <2005-01-02_02:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_01:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_02:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000090  current_time = <2005-01-02_03:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_02:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_03:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000091  current_time = <2005-01-02_04:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_03:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_04:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000092  current_time = <2005-01-02_05:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_04:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_05:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000093  current_time = <2005-01-02_06:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_05:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_06:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000094  current_time = <2005-01-02_07:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_06:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_07:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000095  current_time = <2005-01-02_08:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_07:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_08:00:10>
+LeapYearClockAdvance_ADVANCE:  count = 000096  current_time = <2005-01-02_09:00:00>
+LeapYearClockAdvance_ADVANCE:  current_time-increment = <2005-01-02_08:59:50>
+LeapYearClockAdvance_ADVANCE:  current_time+increment = <2005-01-02_09:00:10>
+LeapYearFractionClockAdvance_SETUP:  start_time = <2004-12-31_23:58:00>
+LeapYearFractionClockAdvance_SETUP:  stop_time = <2005-01-01_00:02:00>
+LeapYearFractionClockAdvance_SETUP:  timestep = <0000000000_000:000:013+01/03>
+LeapYearFractionClockAdvance_SETUP:  increment = <0000000000_000:000:001+01/03>
+LeapYearFractionClockAdvance_SETUP:  clock current_time = <2004-12-31_23:58:00>
+LeapYearFractionClockAdvance_SETUP:  current_time dayOfYear_r8 = < 366.998611 >
+LeapYearFractionClockAdvance_SETUP:  current_time-increment = <2004-12-31_23:57:58+02/03>
+LeapYearFractionClockAdvance_SETUP:  current_time+increment = <2004-12-31_23:58:01+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000001  current_time = <2004-12-31_23:58:13+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:58:12>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:58:14+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000002  current_time = <2004-12-31_23:58:26+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:58:25+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:58:28>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000003  current_time = <2004-12-31_23:58:40>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:58:38+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:58:41+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000004  current_time = <2004-12-31_23:58:53+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:58:52>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:58:54+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000005  current_time = <2004-12-31_23:59:06+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:05+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:59:08>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000006  current_time = <2004-12-31_23:59:20>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:18+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:59:21+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000007  current_time = <2004-12-31_23:59:33+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:32>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:59:34+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000008  current_time = <2004-12-31_23:59:46+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:45+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2004-12-31_23:59:48>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000009  current_time = <2005-01-01_00:00:00>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2004-12-31_23:59:58+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:01+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000010  current_time = <2005-01-01_00:00:13+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:00:12>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:14+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000011  current_time = <2005-01-01_00:00:26+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:00:25+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:28>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000012  current_time = <2005-01-01_00:00:40>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:00:38+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:41+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000013  current_time = <2005-01-01_00:00:53+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:00:52>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:00:54+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000014  current_time = <2005-01-01_00:01:06+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:01:05+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:01:08>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000015  current_time = <2005-01-01_00:01:20>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:01:18+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:01:21+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000016  current_time = <2005-01-01_00:01:33+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:01:32>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:01:34+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000017  current_time = <2005-01-01_00:01:46+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:01:45+01/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:01:48>
+LeapYearFractionClockAdvance_ADVANCE:  count = 000018  current_time = <2005-01-01_00:02:00>
+LeapYearFractionClockAdvance_ADVANCE:  current_time-increment = <2005-01-01_00:01:58+02/03>
+LeapYearFractionClockAdvance_ADVANCE:  current_time+increment = <2005-01-01_00:02:01+01/03>
+ END TEST SUITE
diff --git a/wrfv2_fire/external/esmf_time_f90/module_symbols_util.F90 b/wrfv2_fire/external/esmf_time_f90/module_symbols_util.F90
new file mode 100644
index 00000000..74d9c7f8
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/module_symbols_util.F90
@@ -0,0 +1,122 @@
+! 
+! WARNING:  This file was automatically generated by the findsymbol script 
+! based on WRFV2_20050512_1410.  The following process was used:  
+! 
+! 1) Run the findsymbol script on a machine that has Ruby installed to 
+!    generate this file.  Type "findsymbol -h" for help using findsymbol.  
+!    For example:  
+! >> hender IN loquat:/loquat2/hender/Ruby/FortranTools/ >> findsymbol -d /users/hender/Tasks/WRF_ESMF/WRFV2_20050512_1410_WORK/WRFV2/external/esmf_time_f90 -S ESMF_ -p -g WRFU_ -o ESMF_Mod -n module_symbols_util > & ! module_symbols_util.F90
+! 
+! 2) Added this comment block by hand.
+!
+      MODULE module_symbols_util
+
+        USE ESMF_Mod, WRFU_ALARM => ESMF_ALARM
+        USE ESMF_Mod, WRFU_ALARMCREATE => ESMF_ALARMCREATE
+        USE ESMF_Mod, WRFU_ALARMDESTROY => ESMF_ALARMDESTROY
+        USE ESMF_Mod, WRFU_ALARMDISABLE => ESMF_ALARMDISABLE
+        USE ESMF_Mod, WRFU_ALARMENABLE => ESMF_ALARMENABLE
+        USE ESMF_Mod, WRFU_ALARMGET => ESMF_ALARMGET
+        USE ESMF_Mod, WRFU_ALARMISRINGING => ESMF_ALARMISRINGING
+        USE ESMF_Mod, WRFU_ALARMPRINT => ESMF_ALARMPRINT
+        USE ESMF_Mod, WRFU_ALARMRINGEROFF => ESMF_ALARMRINGEROFF
+        USE ESMF_Mod, WRFU_ALARMRINGERON => ESMF_ALARMRINGERON
+        USE ESMF_Mod, WRFU_ALARMSET => ESMF_ALARMSET
+        USE ESMF_Mod, WRFU_ALARMVALIDATE => ESMF_ALARMVALIDATE
+        USE ESMF_Mod, WRFU_ATTRIBUTE => ESMF_ATTRIBUTE
+        USE ESMF_Mod, WRFU_ATTRIBUTECOPY => ESMF_ATTRIBUTECOPY
+        USE ESMF_Mod, WRFU_ATTRIBUTECOPYALL => ESMF_ATTRIBUTECOPYALL
+        USE ESMF_Mod, WRFU_ATTRIBUTEGET => ESMF_ATTRIBUTEGET
+        USE ESMF_Mod, WRFU_ATTRIBUTEGETBYNUMBER => ESMF_ATTRIBUTEGETBYNUMBER
+        USE ESMF_Mod, WRFU_ATTRIBUTEGETCOUNT => ESMF_ATTRIBUTEGETCOUNT
+        USE ESMF_Mod, WRFU_ATTRIBUTEGETLIST => ESMF_ATTRIBUTEGETLIST
+        USE ESMF_Mod, WRFU_ATTRIBUTEGETNAMELIST => ESMF_ATTRIBUTEGETNAMELIST
+        USE ESMF_Mod, WRFU_ATTRIBUTEGETOBJECTLIST => ESMF_ATTRIBUTEGETOBJECTLIST
+        USE ESMF_Mod, WRFU_ATTRIBUTESET => ESMF_ATTRIBUTESET
+        USE ESMF_Mod, WRFU_ATTRIBUTESETLIST => ESMF_ATTRIBUTESETLIST
+        USE ESMF_Mod, WRFU_ATTRIBUTESETOBJECTLIST => ESMF_ATTRIBUTESETOBJECTLIST
+        USE ESMF_Mod, WRFU_AXISINDEX => ESMF_AXISINDEX
+        USE ESMF_Mod, WRFU_AXISINDEXGET => ESMF_AXISINDEXGET
+        USE ESMF_Mod, WRFU_BAD_POINTER => ESMF_BAD_POINTER
+        USE ESMF_Mod, WRFU_BASE => ESMF_BASE
+        USE ESMF_Mod, WRFU_BASETIME => ESMF_BASETIME
+        USE ESMF_Mod, WRFU_CALENDAR => ESMF_CALENDAR
+        USE ESMF_Mod, WRFU_CALENDARTYPE => ESMF_CALENDARTYPE
+        USE ESMF_Mod, WRFU_CAL_360DAY => ESMF_CAL_360DAY
+        USE ESMF_Mod, WRFU_CAL_GREGORIAN => ESMF_CAL_GREGORIAN
+        USE ESMF_Mod, WRFU_CAL_NOCALENDAR => ESMF_CAL_NOCALENDAR
+        USE ESMF_Mod, WRFU_CAL_NOLEAP => ESMF_CAL_NOLEAP
+        USE ESMF_Mod, WRFU_CLOCK => ESMF_CLOCK
+        USE ESMF_Mod, WRFU_CLOCKADDALARM => ESMF_CLOCKADDALARM
+        USE ESMF_Mod, WRFU_CLOCKADVANCE => ESMF_CLOCKADVANCE
+        USE ESMF_Mod, WRFU_CLOCKCREATE => ESMF_CLOCKCREATE
+        USE ESMF_Mod, WRFU_CLOCKDESTROY => ESMF_CLOCKDESTROY
+        USE ESMF_Mod, WRFU_CLOCKGET => ESMF_CLOCKGET
+        USE ESMF_Mod, WRFU_CLOCKGETALARMLIST => ESMF_CLOCKGETALARMLIST
+        USE ESMF_Mod, WRFU_CLOCKISSTOPTIME => ESMF_CLOCKISSTOPTIME
+        USE ESMF_Mod, WRFU_CLOCKPRINT => ESMF_CLOCKPRINT
+        USE ESMF_Mod, WRFU_CLOCKSET => ESMF_CLOCKSET
+        USE ESMF_Mod, WRFU_CLOCKSTOPTIMEDISABLE => ESMF_CLOCKSTOPTIMEDISABLE
+        USE ESMF_Mod, WRFU_CLOCKVALIDATE => ESMF_CLOCKVALIDATE
+        USE ESMF_Mod, WRFU_DATATYPE => ESMF_DATATYPE
+        USE ESMF_Mod, WRFU_DATATYPESTRING => ESMF_DATATYPESTRING
+        USE ESMF_Mod, WRFU_DATAVALUE => ESMF_DATAVALUE
+        USE ESMF_Mod, WRFU_DATA_CHARACTER => ESMF_DATA_CHARACTER
+        USE ESMF_Mod, WRFU_DATA_INTEGER => ESMF_DATA_INTEGER
+        USE ESMF_Mod, WRFU_DATA_LOGICAL => ESMF_DATA_LOGICAL
+        USE ESMF_Mod, WRFU_DATA_REAL => ESMF_DATA_REAL
+        USE ESMF_Mod, WRFU_FAILURE => ESMF_FAILURE
+        USE ESMF_Mod, WRFU_FINALIZE => ESMF_FINALIZE
+        USE ESMF_Mod, WRFU_FRACTION => ESMF_FRACTION
+        USE ESMF_Mod, WRFU_GETNAME => ESMF_GETNAME
+        USE ESMF_Mod, WRFU_GETPOINTER => ESMF_GETPOINTER
+        USE ESMF_Mod, WRFU_GRID => ESMF_GRID
+        USE ESMF_Mod, WRFU_GRIDCOMP => ESMF_GRIDCOMP
+        USE ESMF_Mod, WRFU_INITIALIZE => ESMF_INITIALIZE
+        USE ESMF_Mod, WRFU_ISINITIALIZED => ESMF_ISINITIALIZED
+        USE ESMF_Mod, WRFU_KIND_C16 => ESMF_KIND_C16
+        USE ESMF_Mod, WRFU_KIND_C8 => ESMF_KIND_C8
+        USE ESMF_Mod, WRFU_KIND_I1 => ESMF_KIND_I1
+        USE ESMF_Mod, WRFU_KIND_I2 => ESMF_KIND_I2
+        USE ESMF_Mod, WRFU_KIND_I4 => ESMF_KIND_I4
+        USE ESMF_Mod, WRFU_KIND_I8 => ESMF_KIND_I8
+        USE ESMF_Mod, WRFU_KIND_R4 => ESMF_KIND_R4
+        USE ESMF_Mod, WRFU_KIND_R8 => ESMF_KIND_R8
+        USE ESMF_Mod, WRFU_LOG => ESMF_LOG
+        USE ESMF_Mod, WRFU_LOGICAL => ESMF_LOGICAL
+        USE ESMF_Mod, WRFU_LOGWRITE => ESMF_LOGWRITE
+        USE ESMF_Mod, WRFU_LOG_ERROR => ESMF_LOG_ERROR
+        USE ESMF_Mod, WRFU_LOG_INFO => ESMF_LOG_INFO
+        USE ESMF_Mod, WRFU_LOG_WARNING => ESMF_LOG_WARNING
+        USE ESMF_Mod, WRFU_MAJOR_VERSION => ESMF_MAJOR_VERSION
+        USE ESMF_Mod, WRFU_MAXDECOMPDIM => ESMF_MAXDECOMPDIM
+        USE ESMF_Mod, WRFU_MAXDIM => ESMF_MAXDIM
+        USE ESMF_Mod, WRFU_MAXGRIDDIM => ESMF_MAXGRIDDIM
+        USE ESMF_Mod, WRFU_MAXSTR => ESMF_MAXSTR
+        USE ESMF_Mod, WRFU_MINOR_VERSION => ESMF_MINOR_VERSION
+        USE ESMF_Mod, WRFU_MSGTYPE => ESMF_MSGTYPE
+        USE ESMF_Mod, WRFU_NULL_POINTER => ESMF_NULL_POINTER
+        USE ESMF_Mod, WRFU_POINTER => ESMF_POINTER
+        USE ESMF_Mod, WRFU_REVISION => ESMF_REVISION
+        USE ESMF_Mod, WRFU_SETNAME => ESMF_SETNAME
+        USE ESMF_Mod, WRFU_SETNULLPOINTER => ESMF_SETNULLPOINTER
+        USE ESMF_Mod, WRFU_SETPOINTER => ESMF_SETPOINTER
+        USE ESMF_Mod, WRFU_STATE => ESMF_STATE
+        USE ESMF_Mod, WRFU_STATE_INVALID => ESMF_STATE_INVALID
+        USE ESMF_Mod, WRFU_STATUS => ESMF_STATUS
+        USE ESMF_Mod, WRFU_STATUSSTRING => ESMF_STATUSSTRING
+        USE ESMF_Mod, WRFU_SUCCESS => ESMF_SUCCESS
+        USE ESMF_Mod, WRFU_TIME => ESMF_TIME
+        USE ESMF_Mod, WRFU_TIMEGET => ESMF_TIMEGET
+        USE ESMF_Mod, WRFU_TIMEINTERVAL => ESMF_TIMEINTERVAL
+        USE ESMF_Mod, WRFU_TIMEINTERVALABSVALUE => ESMF_TIMEINTERVALABSVALUE
+        USE ESMF_Mod, WRFU_TIMEINTERVALDIVQUOT => ESMF_TIMEINTERVALDIVQUOT
+        USE ESMF_Mod, WRFU_TIMEINTERVALGET => ESMF_TIMEINTERVALGET
+        USE ESMF_Mod, WRFU_TIMEINTERVALNEGABSVALUE => ESMF_TIMEINTERVALNEGABSVALUE
+        USE ESMF_Mod, WRFU_TIMEINTERVALSET => ESMF_TIMEINTERVALSET
+        USE ESMF_Mod, WRFU_TIMESET => ESMF_TIMESET
+        USE ESMF_Mod, WRFU_VERSION_STRING => ESMF_VERSION_STRING
+        USE ESMF_Mod, WRFU_VM => ESMF_VM
+
+      END MODULE module_symbols_util
+
diff --git a/wrfv2_fire/external/esmf_time_f90/module_utility.F90 b/wrfv2_fire/external/esmf_time_f90/module_utility.F90
new file mode 100644
index 00000000..e818cc5b
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/module_utility.F90
@@ -0,0 +1,7 @@
+
+      MODULE module_utility
+
+        USE module_symbols_util
+
+      END MODULE module_utility
+
diff --git a/wrfv2_fire/external/esmf_time_f90/testall.csh b/wrfv2_fire/external/esmf_time_f90/testall.csh
new file mode 100755
index 00000000..9f808274
--- /dev/null
+++ b/wrfv2_fire/external/esmf_time_f90/testall.csh
@@ -0,0 +1,46 @@
+#!/bin/csh
+#
+# Build and run Test1.exe and compare results with known-good output
+#
+set selflong = $0
+set self = $selflong:t
+
+if ( ! -f ../../configure.wrf ) then
+  echo "ERROR:  must run ../../configure before building esmf_time_f90 unit tests"
+  exit -1
+endif
+
+# build
+set allpass = "true"
+make superclean >& /dev/null
+cd ../.. ; make esmf_time_f90_only >&! external/esmf_time_f90/make_tests.out ; cd external/esmf_time_f90
+# run tests for both ESMF_ and WRFU_ interfaces...  
+set testoutok = "Test1.out.correct"
+foreach tst ( "ESMF" "WRFU" )
+  set testname = "Test1_${tst}"
+  ./${testname}.exe >&! ${testname}.out || echo "ERROR ${testname}:  failed to execute ./${testname}.exe, see make_tests.out" && exit 20
+  # evaluate test results
+  diff ${testoutok} ${testname}.out >& /dev/null
+  set ok = $status
+  if ( $ok == 0 ) then
+    echo "PASS ${testname}"
+  else
+    set allpass = "false"
+    echo
+    echo "FAIL ${testname}"
+    echo
+    which xxdiff >& /dev/null
+    set ok = $status
+    if ( $ok == 0 ) then
+      xxdiff ${testoutok} ${testname}.out
+    else
+      diff ${testoutok} ${testname}.out
+    endif
+  endif
+end
+# clean up if all tests passed
+if ( $allpass == "true" ) then
+#  make testclean >& /dev/null
+  make superclean >& /dev/null
+endif
+
diff --git a/wrfv2_fire/external/io_esmf/README.io_esmf b/wrfv2_fire/external/io_esmf/README.io_esmf
new file mode 100644
index 00000000..8df0e5f4
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/README.io_esmf
@@ -0,0 +1,85 @@
+file README.io_esmf
+Tom Henderson                                          03/08/07
+
+
+GENERAL NOTES
+
+This version of WRF has been tested with ESMF 2.2.0rp1 and with ESMF 2.2.2r.  
+Since ESMF interfaces are still evolving, it is possible that this version of 
+WRF will not work with newer versions of ESMF.  
+
+New environment variables ESMFLIB and ESMFINC may be set to trigger 
+build using a separately installed ESMF library instead of the default 
+library embedded in external/esmf_time_f90/.  These new environment variables 
+must be set to point to library and module paths for the separately 
+installed ESMF library before WRF "configure" is run.  For example, an 
+installation of ESMF on bluesky built with default ESMF settings in 
+/home/bluesky/hender/esmf requires the following settings:  
+  ESMFLIB /home/bluesky/hender/esmf/lib/libO/AIX.default.32.default
+  ESMFINC /home/bluesky/hender/esmf/mod/modO/AIX.default.32.default
+(Note that the portions of the pathnames following 
+"/home/bluesky/hender/esmf/" are defined by ESMF and described in the ESMF 
+documentation.)  
+
+When ESMFLIB and ESMFINC are set, a new main program is built in 
+main/wrf_SST_ESMF.exe.  This program is a sample coupled application in 
+which WRF is coupled to a very simple "data-ocean" component named SST via 
+a very simple coupler.  While this is a functional example of coupling WRF 
+to another ESMF component, it should be considered *HIGHLY EXPERIMENTAL*.  
+The implementation is quite primitive and has severe limitations.  
+Most important, it is only possible to couple with another component that 
+uses the exact same grid as WRF due to limitations of ESMF at the time this 
+work was originally done.  Also, the ESMF component only works with the 
+DM-Parallel RSL build and has only been tested on AIX.  These and a large 
+number of other issues are described in external/io_esmf/TODO.list.  
+
+Since external/io_esmf is an implementation of the WRF I/O and coupling 
+API (WRF IOAPI), ESMF coupling can be controlled by the user in the same 
+manner as other WRF I/O.  Specifically, contents of ESMF import and export 
+states are defined in the Registry (see Registry.EM_SST for example) and 
+timing of coupling is defined in namelist.input.  In the case of the WRF-SST 
+coupling example, the SST component simply reads SST values stored in a file 
+and sends it to WRF.  Since the SST component also uses the WRF IOAPI and 
+the format and metadata of SST data files is compatible with the WRF IOAPI, 
+it is possible to switch from coupled operation to stand-alone operation (in 
+which WRF reads the SST data directly via auxinput5), simply by changing 
+the io_form in the namelist.  A test that can be run to validate this claim 
+can be found in test/em_esmf_exp (see test/em_esmf_exp/README_WRF_CPL_SST.txt). 
+
+This is a work-in-progress!  
+
+
+NOTES ABOUT THE EVENT LOOP FOR WRF+CPL+SST
+
+The event loop (time-stepping loop) in the ESMF driver program in 
+main/wrf_SST_ESMF.F is a serial analog of concurrent coupling performed using
+the Model Coupling Environment Library (MCEL) by Michalakes and Bettencourt 
+(http://www.mmm.ucar.edu/wrf/WG2/Tigers/IOAPI/index.html).  Specifically, 
+the "read" of the WRF ImportState and the "write" of the WRF ExportState both 
+occur during subroutine med_before_solve_io() which is called before the main 
+WRF solver (which advances a domain by one time-step).  This approach is 
+suitable for "loose" coupling in which precise time synchronization between 
+components is not critical.  Such "loose" coupling is appropriate for some 
+ocean-atmosphere systems.  The WRF+CPL+SST event loop contains the following 
+steps:  
+ - SST run phase 1
+ - CPL SST to WRF
+ - CPL WRF to SST
+ - WRF run
+ - SST run phase 2
+However, coupling of components that require more precise synchronization, 
+such as land-atmosphere coupling, requires "tighter" coupling.  Also, it is 
+not always convenient to split a component into multiple run phases (or 
+multiple components).  A more suitable event loop for this case might contain 
+the following steps:  
+ - LAND run
+ - CPL LAND to WRF
+ - WRF run
+ - CPL WRF to LAND
+This requires modifying WRF so the "output" calls that "write" the WRF 
+ExportState occur in subroutine med_after_solve_io() in file 
+share/mediation_integrate.F.  
+We plan to make this modification in a future revision of WRF and allow users 
+to control where the WRF ExportState is set at run-time via a namelist 
+variable.  
+
diff --git a/wrfv2_fire/external/io_esmf/TODO.list b/wrfv2_fire/external/io_esmf/TODO.list
new file mode 100644
index 00000000..4fc25e3c
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/TODO.list
@@ -0,0 +1,145 @@
+TODO.list
+Tom Henderson                                                           5/19/06
+
+WRF-ESMF TODO LIST:  
+
+
+WRF-ESMF is still new and experimental and has many limitations.  Many of 
+these are mentioned in the task list that follows.  
+
+
+"X" == "DONE"  
+
+The "ESMF" referred to below is version 2.2.0rp1.  
+
++ Design and Implementation:
+   - Modifying WRF so the "output" calls that set the WRF ExportState can 
+     occur in subroutine med_after_solve_io in file 
+     share/mediation_integrate.F.  We plan to make this modification in a 
+     future revision of WRF and allow users to control where the WRF 
+     ExportState is set at run-time via a namelist variable.  Or we may make 
+     the new behavior the default since it is more natural for sequential 
+     coupling.  
+   - Get rid of masses of "DEBUG" code.  
+   - Clean up/correct comments.  
+   - Fix ESMF+RSL_LITE.  Currently, only ESMF+RSL works.  
+       Patch and memory extents differ between RSL and RSL_LITE, see
+       /users/hender/Tasks/WRF_ESMF/RSL_LITE_broken/README for details.  
+   - Finish sequence diagram for the coupling interactions in
+     /users/hender/Tasks/WRF_ESMF/SequenceDiagram.txt ...
+     - OR, use more recent ppt slides...  
+   - Upgrade SST component so it can run on a subset of processors.  
+       This requires breaking the domdesc dependence for SST so SST can be 
+       run on fewer processes.  SST will need to call wrf_dm_patch_domain(), 
+       probably modified to avoid dependence on TYPE(domain) and certainly 
+       modified to avoid dependence on head_grid.  
+   - Upgrade external/io_esmf/ so more data types are supported.  
+   - Upgrade external/io_esmf/ so 3D arrays are supported (just loop over "K" 
+     at first with hard-coded names like "U_k_1", "U_k_2", etc.).  Then 
+     switch to ESMF for this once it can do it.  (Can ESMF do this yet?  
+     Check.)  
+   - Extend external/io_esmf/ (etc.) so more than one I/O stream can be used 
+     for ESMF coupling.  This would involve nested import and export states.  
+   - Exchange staggered 2D grids and test-validate (x, y, and z staggerings).  
+     Current hacked implementation should be able to handle this for 
+     horizontal staggerings, but need to test in case bugs are lurking...  
+   - Upgrade external/io_esmf/ so metadata is exchanged correctly.  Right now, 
+     metadata is ignored.  This would allow sharing of metadata and simplify 
+     implementation of components that were aware of WRF metadata.  Ultimately, 
+     CF is the right thing here...  
+   - Fix output formatting so DOMAIN_TIME_TEST works the same way 
+     both with and without ESMF.  
+   - Fix ext_esmf_ioclose so it actually destroys ESMF objects again.  This
+     is #ifdef'd out at the moment due to difficulties with destruction.  (At 
+     present, ESMF requires users to deallocate anything they allocate, but 
+     provides no introspection so a user can figure out if who allocated 
+     something.  This leads to obfuscation of implementations...)  
+   X Make WRF-ESMF build recognize ESMF environment variables?
+     Could remove stanzas from arch/configure.defaults and avoid lots
+     of duplication and documentation.
+   - If possible, upgrade WRF ESMF component to get number of MPI tasks from 
+     VM instead of from MPI.  This may be tricky or even impractical due to 
+     startup issues...  
+   - CF conventions:  
+     * Numerous tasks here, not really a "WRF-ESMF" issue, but related...  
+         Will there be CF conventions for startTime, stopTime, timeStep, 
+         couplingInterval?
+   - Other ESMF bugs/issues:  
+     * Rip out the current hacks for grid creation in external/io_esmf/ once 
+       ESMF can support WRF map projections.  Use the "sieve" method of 
+       io_mcel.  This will take a bit of work...  
+     * Restore ESMF_LogErr calls once ESMF fixes them so they no longer 
+       truncate all of our messages (trivial for us...).  
+        * Ask when ESMF_LogErr will allow us to specify LUN.  This will
+          make it easier for us to use this utility.  
+     * Upgrade external/io_esmf/ to avoid manual CICO once ESMF can mimic WRF 
+       memory layouts.  
+     * Index ordering is hard-coded.  Fix this once ESMF supports it and 
+       connect to "MemoryOrder" argument.  
+     * Take a look at my list of reported ESMF bugs and add any I haven't 
+       reported.  
+     * Calls to ESMF_LogSet in main/wrf_ESMFApp.F cause core dumps -- why?  
+     * Calls to ESMF_ArraySpecSet() in external/io_esmf/ quietly do the wrong 
+       thing.  Why?  Once they work, uncomment this code to avoid 
+       per-data-type duplication of hard-coded alternative (gaaak).  See 
+       string DOESNOTWORK.  
+     * ESMF cannot handle "extra" rows-columns implied by horizontal
+       staggering for regional models like WRF.  Upgrade once ESMF supports 
+       this.  
+       * Re-connect "Stagger" argument to ESMF "horzrelloc" argument.  
+         Uncomment this code in external/io_esmf/.  
+       * Until then, maybe use nested ESMF_States to handle it.  This is ugly 
+         though because there are no conventions for such a thing so it will 
+         introduce dependencies with other components.  Balaji's recent 
+         proposal to standardize grid metadata within CF would be useful 
+         if we go this way.  
+     * Why can I specify start indices in the call to 
+       ESMF_GridDistribute[Vector]() but not in the call to ESMF_GridSet() ?
+     * Remove implementation of WRFU_TimeIntervalDIVQuot in 
+       external/io_esmf/module_esmf_extensions.F90 once ESMF supports this 
+       directly.  
+     * Lack of sane (or any) iterators for ESMF_State and other container 
+       classes leads to nasty user code...  
+     * Lack of adherence to Orthodox Canonical Form leads to really nasty 
+       user code.  Probably not worth tilting at this windmill again...  
+     * Many others...  
+   - Misc. bugs/issues:
+     * Investigate odd debug prints from med_hist_out, output_wrf, input_wrf
+        med_hist_out : opening sstout_d01_000000 for writing.  86
+          I think the "86" should be "0"
+        output_wrf: fid,filestate =  2 65
+          I think the "65" should be "0"
+        input_wrf: fid,filestate =  3 804370368
+          I think the "804370368" should be something else...
+     * Find out why one new message now appears in stdout (weird).  
+         This happens with a "no-esmf" build and with an "esmf" build.  
+           INPUT LANDUSE = USGS
+           LANDUSE TYPE = USGS FOUND 24  CATEGORIES 2  SEASONS WATER CATEGORY =  16  SNOW CATEGORY =  24
+     * Replace hand-coded checks of "rc" with use of new ESMF error handler to 
+       streamline code.  
+         See /loquat2/hender/Tasks/WRF_ESMF/ESMF_FieldFromUserEx.F90
+         See /loquat2/hender/Tasks/WRF_ESMF/UserCodeMod.F90
+     * See if "#ifndef ESMFIO" hack can be removed from share/input_wrf.F.  
+     * Get rid of module_symbols.F90.  Encapsulate any remaining "WRFU" calls 
+       via module_domain.  
+     * Rip out WRF_CHEM from set_timekeeping.F and test...
++ Upgrade to ESMF 2.2.2r+
+   - Add an ESMF_LOG_NONE option to the "defaultLogType" argument 
+     of ESMF_Initialize() to turn off ESMF's default error logging.  
+   - Add an ESMF_KEEPMPI option to the "terminationflag" argument 
+     of ESMF_Finalize() to allow ESMF finalization without MPI 
+     shutdown.  Then clean up the current shutdown mess.  
++ Documentation:
+   - General description of and guidelines for coupling WRF with another
+     ESMF component.
+   X Description of WRF-CPL-SST "demo"
+     X Description of SST and CPL demo components
+     * Sequence diagram of component interactions
+     X Limitations of demo
+     * How to extend the demo
++ Testing
+   - Add WRF-CPL-SST tests to regtest.csh.  
+     * Generate jun01 sst warming data set and work with Dave to add new 
+       "ESMF_SST" tests to regtest.csh.  
+     * Debug (it's there but doesn't work yet).  
+
diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_open_for_read.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_open_for_read.F90
new file mode 100644
index 00000000..6f3feecd
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/ext_esmf_open_for_read.F90
@@ -0,0 +1,67 @@
+!--- open_for_read_begin
+SUBROUTINE ext_esmf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                         DataHandle , Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  CHARACTER*(*)               :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*)               :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Local declarations
+  INTEGER :: i
+  TYPE(ESMF_State), POINTER :: importstate
+  TYPE(ESMF_StateType) :: statetype
+  INTEGER :: rc, itemCount
+
+  CALL int_get_fresh_handle(i)
+  okay_to_write(i) = .false.
+  okay_to_read(i) = .false.
+  opened_for_read(i) = .true.
+  opened_for_write(i) = .false.
+  DataHandle = i
+
+  ! Grab the current importState and ensure that it is empty
+  CALL ESMF_ImportStateGetCurrent(importstate, rc)
+  IF ( rc /= ESMF_SUCCESS ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_read:  ESMF_ImportStateGetCurrent failed" )
+  ENDIF
+  ! For now, If the import state is not empty, whine and die.
+!$$$ Eventually, use nested states to allow than one auxinput stream 
+!$$$ to be supported via ESMF.  
+!$$$ Eventually, get smart about interacting with "needed" and "optional" 
+!$$$ named state items
+  CALL ESMF_StateGet( importstate, itemCount=itemCount, &
+                      statetype=statetype, rc=rc )
+  IF ( rc /= ESMF_SUCCESS ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_read:  ESMF_ImportStateGet failed" )
+  ENDIF
+  IF ( statetype /= ESMF_STATE_IMPORT ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_read:  not an import state" )
+  ENDIF
+  IF ( itemCount /= 0 ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_read:  import state not empty, io_esmf is currently limited to only one auxinput stream" )
+  ENDIF
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_esmf_open_for_read_begin
+
+
+!--- open_for_read_commit
+SUBROUTINE ext_esmf_open_for_read_commit( DataHandle , Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER , INTENT(IN ) :: DataHandle
+  INTEGER , INTENT(OUT) :: Status
+
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      okay_to_read( DataHandle ) = .true.
+    ENDIF
+  ENDIF
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_esmf_open_for_read_commit
+
diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_open_for_write.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_open_for_write.F90
new file mode 100644
index 00000000..175cd51e
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/ext_esmf_open_for_write.F90
@@ -0,0 +1,67 @@
+!--- open_for_write_begin
+SUBROUTINE ext_esmf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                          DataHandle , Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  CHARACTER*(*)               :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*)               :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Local declarations
+  INTEGER :: i
+  TYPE(ESMF_State), POINTER :: exportstate
+  TYPE(ESMF_StateType) :: statetype
+  INTEGER :: rc, itemCount
+
+  CALL int_get_fresh_handle(i)
+  okay_to_write(i) = .false.
+  okay_to_read(i) = .false.
+  opened_for_read(i) = .false.
+  opened_for_write(i) = .true.
+  DataHandle = i
+
+  ! Grab the current exportState and ensure that it is empty
+  CALL ESMF_ExportStateGetCurrent(exportstate, rc)
+  IF ( rc /= ESMF_SUCCESS ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_write:  ESMF_ExportStateGetCurrent failed" )
+  ENDIF
+  ! For now, If the export state is not empty, whine and die.
+!$$$ Eventually, use nested states to allow than one auxhist stream 
+!$$$ to be supported via ESMF.  
+!$$$ Eventually, get smart about interacting with "needed" and "optional" 
+!$$$ named state items
+  CALL ESMF_StateGet( exportstate, itemCount=itemCount, &
+                      statetype=statetype, rc=rc )
+  IF ( rc /= ESMF_SUCCESS ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_write:  ESMF_ExportStateGet failed" )
+  ENDIF
+  IF ( statetype /= ESMF_STATE_EXPORT ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_write:  not an export state" )
+  ENDIF
+  IF ( itemCount /= 0 ) THEN
+    CALL wrf_error_fatal("ext_esmf_open_for_write:  export state not empty, io_esmf is currently limited to only one auxhist stream" )
+  ENDIF
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_esmf_open_for_write_begin
+
+
+!--- open_for_write_commit
+SUBROUTINE ext_esmf_open_for_write_commit( DataHandle , Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER , INTENT(IN ) :: DataHandle
+  INTEGER , INTENT(OUT) :: Status
+
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      okay_to_write( DataHandle ) = .true.
+    ENDIF
+  ENDIF
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_esmf_open_for_write_commit
+
diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90
new file mode 100644
index 00000000..04160fec
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90
@@ -0,0 +1,384 @@
+
+!$$$here...  TBH:  remove duplication between ext_esmf_read_field and 
+!$$$here...  TBH:  ext_esmf_write_field
+
+!$$$here...  TBH:  how to deal with time?  (via current ESMF_Clock)
+!$$$here...  TBH:  to begin, use it as an error check!  
+
+
+!--- read_field
+SUBROUTINE ext_esmf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
+                                 DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                                 DomainStart , DomainEnd ,                                    &
+                                 MemoryStart , MemoryEnd ,                                    &
+                                 PatchStart , PatchEnd ,                                      &
+                                 Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER       ,INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) ,intent(inout) :: DateStr
+  CHARACTER*(*) ,intent(inout) :: VarName
+  integer       ,intent(inout) :: FieldType
+  integer       ,intent(inout) :: Comm
+  integer       ,intent(inout) :: IOComm
+  integer       ,intent(inout) :: DomainDesc
+  character*(*) ,intent(inout) :: MemoryOrder
+  character*(*) ,intent(inout) :: Stagger
+  character*(*) ,intent(inout) :: DimNames(*)
+  integer       ,intent(inout) :: DomainStart(*), DomainEnd(*)
+  integer       ,intent(inout) :: MemoryStart(*), MemoryEnd(*)
+  integer       ,intent(inout) :: PatchStart(*),  PatchEnd(*)
+  REAL          ,INTENT(INOUT) :: Field(*)
+  integer       ,intent(out)   :: Status
+  ! Local declarations
+  INTEGER :: ids,ide,jds,jde,kds,kde
+  INTEGER :: ims,ime,jms,jme,kms,kme
+  INTEGER :: ips,ipe,jps,jpe,kps,kpe
+  TYPE(ESMF_State), POINTER :: importstate
+  TYPE(ESMF_Field) :: tmpField
+  TYPE(ESMF_Array) :: tmpArray
+  TYPE(ESMF_ArraySpec) :: arrayspec
+  TYPE(ESMF_DataKind) :: esmf_kind
+  TYPE(ESMF_DataType) :: esmf_type
+  TYPE(ESMF_RelLoc) :: horzRelloc
+  REAL(ESMF_KIND_R4), POINTER :: data_esmf_real_ptr(:,:)
+  REAL(ESMF_KIND_R4), POINTER :: tmp_esmf_r4_ptr(:,:)
+  INTEGER(ESMF_KIND_I4), POINTER :: data_esmf_int_ptr(:,:)
+  INTEGER, PARAMETER :: esmf_rank = 2
+  INTEGER :: DomainEndFull(esmf_rank), idefull, jdefull, ict, i, j
+  INTEGER :: PatchEndFull(esmf_rank), ipefull, jpefull
+  ! esmf_counts is redundant.  remove it as soon as ESMF_ArrayCreate no 
+  ! longer requires it
+  INTEGER :: esmf_counts(esmf_rank)
+  INTEGER :: rc
+  LOGICAL, EXTERNAL :: has_char
+  character*256 mess
+!$$$DEBUG
+INTEGER, SAVE :: numtimes=0   ! track number of calls
+CHARACTER(LEN=256) :: timestamp
+!REAL :: debug_real(MemoryStart(1):MemoryEnd(1),MemoryStart(2):MemoryEnd(2))
+!$$$END DEBUG
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_read_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_read_field: DataHandle not opened" )
+  ENDIF
+  IF ( .NOT. opened_for_read( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_read_field: DataHandle not opened for read" )
+  ENDIF
+
+write(mess,*)'ext_esmf_read_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
+call wrf_debug( 300, TRIM(mess) )
+
+  IF      ( FieldType .EQ. WRF_REAL ) THEN
+    esmf_type = ESMF_DATA_REAL
+    esmf_kind = ESMF_R4
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+!    esmf_type = ESMF_DATA_REAL
+!    esmf_kind = ESMF_R8
+    CALL wrf_error_fatal( 'ext_esmf_read_field, WRF_DOUBLE not yet supported')
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    esmf_type = ESMF_DATA_INTEGER
+    esmf_kind = ESMF_I4
+!$$$ implement this (below)
+    CALL wrf_error_fatal( 'ext_esmf_read_field, WRF_INTEGER not yet implemented')
+  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
+    CALL wrf_error_fatal( 'ext_esmf_read_field, WRF_LOGICAL not yet supported')
+  ENDIF
+
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+  kms = MemoryStart(3) ; kme = MemoryEnd(3)
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1)
+  jps = PatchStart(2) ; jpe = PatchEnd(2)
+  kps = PatchStart(3) ; kpe = PatchEnd(3)
+
+  ids = DomainStart(1) ; ide = DomainEnd(1)
+  jds = DomainStart(2) ; jde = DomainEnd(2)
+  kds = DomainStart(3) ; kde = DomainEnd(3)
+
+  ! For now, treat all arrays as 2D...  
+!$$$ Eventually, use ../io_netcdf subroutines Transpose() and reorder() 
+!$$$ (and etc.) to handle general array ranks and index orderings.  
+!$$$ Some copies of these exist in ../../frame/module_io.F.  
+!$$$ Then use ESMF_ArrayDataMap class to handle index mapping.  
+  IF ( kms /= kme ) THEN
+    CALL wrf_error_fatal( 'ext_esmf_read_field:  rank > 2 not yet supported')
+  ENDIF
+
+! The non-staggered variables come in at one-less than
+! domain dimensions, but io_esmf is currently hacked to use full
+! domain spec, so adjust if not staggered.
+! $$$ TBD:  Remove EndFull hackery once ESMF can support staggered 
+! $$$ TBD:  grids in regional models.  (This hack works around the current 
+! $$$ TBD:  need to use only larger staggered dimensions for ESMF_Arrays.)  
+  CALL ioesmf_endfullhack( esmf_rank, DomainEnd, PatchEnd, Stagger, &
+                           DomainEndFull, PatchEndFull )
+  idefull = DomainEndFull(1)
+  jdefull = DomainEndFull(2)
+  ipefull = PatchEndFull(1)
+  jpefull = PatchEndFull(2)
+
+write(mess,*) ' ext_esmf_read_field: okay_to_read: ', DataHandle, okay_to_read(DataHandle)
+call wrf_debug( 300, TRIM(mess) )
+
+  ! case 1: the file is opened for read but not committed ("training")
+  IF ( .NOT. okay_to_read( DataHandle ) )  THEN
+
+    ! Training:  build the ESMF import state
+write(mess,*) ' ext_esmf_read_field: TRAINING READ:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+    ! First, build the ESMF_Grid for this DataHandle, if it does not 
+    ! already exist
+    CALL ioesmf_create_grid( DataHandle, esmf_rank, MemoryOrder, Stagger,      &
+                             DomainStart(1:esmf_rank), DomainEnd(1:esmf_rank), &
+                             MemoryStart(1:esmf_rank), MemoryEnd(1:esmf_rank), &
+                             PatchStart(1:esmf_rank), PatchEnd(1:esmf_rank) )
+    ! Grab the current importState and add to it...
+    CALL ESMF_ImportStateGetCurrent( importstate, rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_read_field, training:  ESMF_ImportStateGetCurrent failed" )
+    ENDIF
+! BEGIN DOESNOTWORK
+! The following code does not work for reasons as-yet unknown.  
+! A likely suspect is lbounds and ubounds which fail in other interfaces in 
+! ESMF 2.2.0rp1 ...  
+    ! Build ESMF objects...  
+    ! Build an ESMF_ArraySpec.  The use of ESMF_ArraySpec and ESMF_Array 
+    ! objects allows some of the code that follows to be type-kind-independent.  
+!    CALL ESMF_ArraySpecSet(arrayspec, rank=esmf_rank, type=esmf_type, &
+!                                      kind=esmf_kind, rc=rc)
+!    IF ( rc /= ESMF_SUCCESS ) THEN
+!      CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_ArraySpecSet failed" )
+!    ENDIF
+    ! Build an ESMF_Array
+    ! Implementation note:  since we do not yet have full control over how 
+    ! ESMF chooses to lay out a "patch" within "memory", we must copy by 
+    ! hand.  (Reasons include lack of support in ESMF for asymmetric halos, 
+    ! addition of "extra" rows/columns to optimize alignment on some machines, 
+    ! handling of periodic boundary conditions, etc.)  Thus, there 
+    ! is no point in using larger "memory" sizes to build the array -- patch 
+    ! is fine.  Also, since we must copy anyway, might as well let ESMF manage 
+    ! the memory for simplicity.  
+!$$$ Once ESMF can match WRF memory-patch mapping, replace this with a more 
+!$$$ efficient solution that does not require a copy.  
+! $$$ esmf_counts is redundant.  Remove it as soon as ESMF_ArrayCreate no 
+! $$$ longer requires it.  
+!    esmf_counts(1:esmf_rank) = DomainEndFull(1:esmf_rank) - &
+!                               DomainStart(1:esmf_rank) + 1
+!    tmpArray = ESMF_ArrayCreate(arrayspec, counts=esmf_counts,      &
+!                                lbounds=DomainStart(1:esmf_rank),   &
+!                                ubounds=DomainEndFull(1:esmf_rank), &
+!                                rc=rc)
+!    IF ( rc /= ESMF_SUCCESS ) THEN
+!      WRITE(mess,*) ' ext_esmf_read_field: ESMF_ArrayCreate failed, rc = ', rc
+!      CALL wrf_error_fatal( TRIM(mess) )
+!    ENDIF
+    ! Determine grid staggering for this Field
+!    IF ( has_char( Stagger, 'x' ) .AND. has_char( Stagger, 'y' ) ) THEN
+!      CALL wrf_error_fatal( &
+!        "ext_esmf_read_field:  ESMF does not yet support XY staggering for C-grid" )
+!    ELSE IF ( has_char( Stagger, 'x' ) ) THEN
+!      horzrelloc=ESMF_CELL_WFACE
+!    ELSE IF ( has_char( Stagger, 'y' ) ) THEN
+!      horzrelloc=ESMF_CELL_SFACE
+!    ELSE
+!      horzrelloc=ESMF_CELL_CENTER
+!    ENDIF
+    ! Build an ESMF_Field
+    ! Note:  though it is counter-intuitive, ESMF uses 
+    ! shallow-copy-masquerading-as-reference to implement the 
+    ! pseudo-equivalent of POINTER assignment under-the-hood.  What this means 
+    ! here is that it is OK to pass deep object tmpArray into 
+    ! ESMF_FieldCreate() and then return from this subroutine.  Even though 
+    ! tmpArray goes out of scope, it is OK.  However, if tmpArray were to be 
+    ! modified after this call, the changes would not be guaranteed to always 
+    ! appear in tmpField.  It works that way now, but ESMF Core team has 
+    ! plans that may make it break in the future.  Build-it, attach-it, 
+    ! flush-it will work.  Build-it, attach-it, modify-it, flush-it may not 
+    ! always work.  
+    ! "Pie, pie and a fox..."  
+    ! Note:  unique Field name is required by ESMF_StateAddField().  
+!$$$here...  use CF "standard_name" once the WRF Registry supports it
+!    tmpField = ESMF_FieldCreate( grid( DataHandle )%ptr, tmpArray,          &
+!                                 copyflag=ESMF_DATA_REF,                    &
+!                                 horzrelloc=horzrelloc, name=TRIM(VarName), &
+!                                 rc=rc )
+! END DOESNOTWORK
+    !$$$here...  This is a complete HACK for debugging!!  Need to compute 
+    !$$$here...  horzrelloc from Stagger as above...  
+    horzrelloc=ESMF_CELL_CENTER
+    !$$$ TODO:  Add code for other data types here...  
+    ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) )
+    CALL wrf_debug ( 100, 'ext_esmf_read_field: calling ESMF_FieldCreate' )
+    tmpField = ESMF_FieldCreate(         &
+                 grid( DataHandle )%ptr, &
+                 tmp_esmf_r4_ptr,        &
+                 copyflag=ESMF_DATA_REF, &
+                 horzrelloc=horzrelloc,  &
+                 name=TRIM(VarName),     &
+                 rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      WRITE(mess,*) ' ext_esmf_read_field: ESMF_FieldCreate failed, rc = ', rc
+      CALL wrf_error_fatal( TRIM(mess) )
+    ENDIF
+    CALL wrf_debug ( 100, 'ext_esmf_read_field: back from ESMF_FieldCreate' )
+    WRITE(mess,*) 'ext_esmf_read_field: tmp_esmf_r4_ptr(',         &
+      LBOUND(tmp_esmf_r4_ptr,1),':',UBOUND(tmp_esmf_r4_ptr,1),',', &
+      LBOUND(tmp_esmf_r4_ptr,2),':',UBOUND(tmp_esmf_r4_ptr,2),')'
+    CALL wrf_debug ( 100 , TRIM(mess) )
+    ! Add the Field to the import state...  
+!$$$here...  for now, just build ESMF_Fields and stuff them in
+!$$$here...  later, use a single ESMF_Bundle
+    CALL ESMF_StateAddField( importstate, tmpField, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_StateAddField failed" )
+    ENDIF
+write(mess,*) ' ext_esmf_read_field: END TRAINING READ:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+  ! case 2: opened for read and committed
+  ELSE IF ( okay_to_read( DataHandle ) )  THEN
+
+write(mess,*) ' ext_esmf_read_field: ACTUAL READ:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+!$$$DEBUG
+! count calls...
+numtimes = numtimes + 1
+CALL get_current_time_string( timestamp )
+!$$$END DEBUG
+
+    ! read:  extract data from the ESMF import state
+    ! Grab the current importState
+    CALL ESMF_ImportStateGetCurrent( importstate, rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_ImportStateGetCurrent failed" )
+    ENDIF
+    ! grab the Field
+    CALL ESMF_StateGetField( importstate, fieldName=TRIM(VarName), &
+                             field=tmpfield, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_StateGetField failed" )
+    ENDIF
+!$$$DEBUG
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 1' )
+CALL ESMF_FieldPrint( tmpField, rc=rc )
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 1' )
+!$$$END DEBUG
+
+    ! grab a pointer to the import state data and copy data into Field
+    IF      ( FieldType .EQ. WRF_REAL ) THEN
+      CALL ESMF_FieldGetDataPointer( tmpField, data_esmf_real_ptr, &
+                                     ESMF_DATA_REF, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_FieldGetDataPointer(r4) failed" )
+      ENDIF
+      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchEndFull(1) /= UBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_real_ptr,2) ) .OR. &
+           ( PatchEndFull(2) /= UBOUND(data_esmf_real_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',          &
+          __FILE__ ,                                                         &
+          ', line ',                                                         &
+          __LINE__ ,                                                         &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEndFull(1),',',      &
+                                 PatchStart(2),':',PatchEndFull(2),          &
+          ', data_esmf_real_ptr(BOUNDS) = ',                                 &
+          LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
+          LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
+        CALL wrf_error_fatal ( TRIM(mess) )
+      ENDIF
+!$$$DEBUG
+WRITE( mess,* ) 'DEBUG:  ext_esmf_read_field:  ips:ipe,jps:jpe = ',  &
+  ips,':',ipe,',',jps,':',jpe,                                       &
+  ', data_esmf_real_ptr(BOUNDS) = ',                                 &
+  LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
+  LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
+CALL wrf_debug( 300, TRIM(mess) )
+!DO j= jms, jme
+!  DO i= ims, ime
+!    debug_real(i,j) = -(i*1000.0 + j)/100000.0     ! obvious bad value for debugging
+!  ENDDO
+!ENDDO
+!debug_real(ips:ipe,jps:jpe) = data_esmf_real_ptr(ips:ipe,jps:jpe)
+!CALL wrf_debug( 100, 'DEBUG:  ext_esmf_read_field:  writing DEBUG1_WRFcmp_import'//TRIM(VarName)//'_'//TRIM(timestamp) )
+!OPEN( UNIT=985, FILE='DEBUG1_WRFcmp_import'//TRIM(VarName)//'_'//TRIM(timestamp), FORM='formatted' )
+!WRITE (985,'(a,a,i4)') TRIM(VarName),' ',numtimes
+!DO j = jps, jpe
+!  DO i = ips, ipe
+!    WRITE (985,*) '(',i,',',j,'):  ',debug_real(i,j)
+!  ENDDO
+!ENDDO
+!CLOSE (985)
+!$$$END DEBUG
+      CALL ioesmf_extract_data_real( data_esmf_real_ptr, Field,            &
+                                     ips, ipefull, jps, jpefull, kps, kpe, &
+                                     ims, ime, jms, jme, kms, kme )
+!$$$DEBUG
+!ict = 0
+!DO j= jms, jme
+!  DO i= ims, ime
+!    ict = ict + 1
+!    IF ( (iipe) .OR. (jjpe) ) THEN
+!      debug_real(i,j) = -(i*1000.0 + j)/100000.0     ! obvious bad value for debugging
+!    ELSE
+!      debug_real(i,j) = Field(ict)
+!    ENDIF
+!  ENDDO
+!ENDDO
+!CALL wrf_debug( 100, 'DEBUG:  ext_esmf_read_field:  writing DEBUG1_WRFcmp_read_Field'//TRIM(VarName)//'_'//TRIM(timestamp) )
+!OPEN( UNIT=985, FILE='DEBUG1_WRFcmp_read_Field'//TRIM(VarName)//'_'//TRIM(timestamp), FORM='formatted' )
+!WRITE (985,'(a,a,i4)') TRIM(VarName),' ',numtimes
+!DO j = jps, jpe
+!  DO i = ips, ipe
+!    WRITE (985,*) '(',i,',',j,'):  ',debug_real(i,j)
+!  ENDDO
+!ENDDO
+!CLOSE (985)
+!$$$END DEBUG
+    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+      CALL ESMF_FieldGetDataPointer( tmpField, data_esmf_int_ptr, &
+                                     ESMF_DATA_REF, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_FieldGetDataPointer(i4) failed" )
+      ENDIF
+      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchEndFull(1) /= UBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_int_ptr,2) ) .OR. &
+           ( PatchEndFull(2) /= UBOUND(data_esmf_int_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',        &
+          __FILE__ ,                                                       &
+          ', line ',                                                       &
+          __LINE__ ,                                                       &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEndFull(1),',',    &
+                                 PatchStart(2),':',PatchEndFull(2),        &
+          ', data_esmf_int_ptr(BOUNDS) = ',                                &
+          LBOUND(data_esmf_int_ptr,1),':',UBOUND(data_esmf_int_ptr,1),',', &
+          LBOUND(data_esmf_int_ptr,2),':',UBOUND(data_esmf_int_ptr,2)
+        CALL wrf_error_fatal ( TRIM(mess) )
+      ENDIF
+      CALL ioesmf_extract_data_int( data_esmf_int_ptr, Field,             &
+                                    ips, ipefull, jps, jpefull, kps, kpe, &
+                                    ims, ime, jms, jme, kms, kme )
+    ENDIF
+write(mess,*) ' ext_esmf_read_field: END ACTUAL READ:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+  ENDIF
+
+!$$$DEBUG
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 2' )
+CALL ESMF_FieldPrint( tmpField, rc=rc )
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 2' )
+!$$$END DEBUG
+
+  Status = 0
+
+  RETURN
+
+END SUBROUTINE ext_esmf_read_field
+
diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90
new file mode 100644
index 00000000..0c4bb55d
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90
@@ -0,0 +1,384 @@
+
+!$$$here...  TBH:  remove duplication between ext_esmf_read_field and 
+!$$$here...  TBH:  ext_esmf_write_field
+
+!$$$here...  TBH:  how to deal with time?  (via current ESMF_Clock)
+!$$$here...  TBH:  to begin, use it as an error check!  
+
+
+!--- write_field
+SUBROUTINE ext_esmf_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
+                                  DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                                  DomainStart , DomainEnd ,                                    &
+                                  MemoryStart , MemoryEnd ,                                    &
+                                  PatchStart , PatchEnd ,                                      &
+                                  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER       ,INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) ,intent(inout) :: DateStr
+  CHARACTER*(*) ,intent(inout) :: VarName
+  integer       ,intent(inout) :: FieldType
+  integer       ,intent(inout) :: Comm
+  integer       ,intent(inout) :: IOComm
+  integer       ,intent(inout) :: DomainDesc
+  character*(*) ,intent(inout) :: MemoryOrder
+  character*(*) ,intent(inout) :: Stagger
+  character*(*) ,intent(inout) :: DimNames(*)
+  integer       ,intent(inout) :: DomainStart(*), DomainEnd(*)
+  integer       ,intent(inout) :: MemoryStart(*), MemoryEnd(*)
+  integer       ,intent(inout) :: PatchStart(*),  PatchEnd(*)
+  REAL          ,INTENT(INOUT) :: Field(*)
+  integer       ,intent(out)   :: Status
+  ! Local declarations
+  INTEGER :: ids,ide,jds,jde,kds,kde
+  INTEGER :: ims,ime,jms,jme,kms,kme
+  INTEGER :: ips,ipe,jps,jpe,kps,kpe
+  TYPE(ESMF_State), POINTER :: exportstate
+  TYPE(ESMF_Field) :: tmpField
+  TYPE(ESMF_Array) :: tmpArray
+  TYPE(ESMF_ArraySpec) :: arrayspec
+  TYPE(ESMF_DataKind) :: esmf_kind
+  TYPE(ESMF_DataType) :: esmf_type
+  TYPE(ESMF_RelLoc) :: horzRelloc
+  REAL(ESMF_KIND_R4), POINTER :: data_esmf_real_ptr(:,:)
+  REAL(ESMF_KIND_R4), POINTER :: tmp_esmf_r4_ptr(:,:)
+  INTEGER(ESMF_KIND_I4), POINTER :: data_esmf_int_ptr(:,:)
+  INTEGER, PARAMETER :: esmf_rank = 2
+  INTEGER :: DomainEndFull(esmf_rank), idefull, jdefull, ict, i, j
+  INTEGER :: PatchEndFull(esmf_rank), ipefull, jpefull
+  ! esmf_counts is redundant.  remove it as soon as ESMF_ArrayCreate no 
+  ! longer requires it
+  INTEGER :: esmf_counts(esmf_rank)
+  INTEGER :: rc
+  LOGICAL, EXTERNAL :: has_char
+  character*256 mess
+!$$$DEBUG
+INTEGER, SAVE :: numtimes=0   ! track number of calls
+CHARACTER(LEN=256) :: timestamp
+!REAL :: debug_real(MemoryStart(1):MemoryEnd(1),MemoryStart(2):MemoryEnd(2))
+!$$$END DEBUG
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_write_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_write_field: DataHandle not opened" )
+  ENDIF
+  IF ( .NOT. opened_for_write( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_esmf_write_field: DataHandle not opened for write" )
+  ENDIF
+
+write(mess,*)'ext_esmf_write_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
+call wrf_debug( 300, TRIM(mess) )
+
+  IF      ( FieldType .EQ. WRF_REAL ) THEN
+    esmf_type = ESMF_DATA_REAL
+    esmf_kind = ESMF_R4
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+!    esmf_type = ESMF_DATA_REAL
+!    esmf_kind = ESMF_R8
+    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_DOUBLE not yet supported')
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    esmf_type = ESMF_DATA_INTEGER
+    esmf_kind = ESMF_I4
+!$$$ implement this (below)
+    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_INTEGER not yet implemented')
+  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
+    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_LOGICAL not yet supported')
+  ENDIF
+
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+  kms = MemoryStart(3) ; kme = MemoryEnd(3)
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1)
+  jps = PatchStart(2) ; jpe = PatchEnd(2)
+  kps = PatchStart(3) ; kpe = PatchEnd(3)
+
+  ids = DomainStart(1) ; ide = DomainEnd(1)
+  jds = DomainStart(2) ; jde = DomainEnd(2)
+  kds = DomainStart(3) ; kde = DomainEnd(3)
+
+  ! For now, treat all arrays as 2D...  
+!$$$ Eventually, use ../io_netcdf subroutines Transpose() and reorder() 
+!$$$ (and etc.) to handle general array ranks and index orderings.  
+!$$$ Some copies of these exist in ../../frame/module_io.F.  
+!$$$ Then use ESMF_ArrayDataMap class to handle index mapping.  
+  IF ( kms /= kme ) THEN
+    CALL wrf_error_fatal( 'ext_esmf_write_field:  rank > 2 not yet supported')
+  ENDIF
+
+! The non-staggered variables come in at one-less than
+! domain dimensions, but io_esmf is currently hacked to use full
+! domain spec, so adjust if not staggered.
+! $$$ TBD:  Remove EndFull hackery once ESMF can support staggered 
+! $$$ TBD:  grids in regional models.  (This hack works around the current 
+! $$$ TBD:  need to use only larger staggered dimensions for ESMF_Arrays.)  
+  CALL ioesmf_endfullhack( esmf_rank, DomainEnd, PatchEnd, Stagger, &
+                           DomainEndFull, PatchEndFull )
+  idefull = DomainEndFull(1)
+  jdefull = DomainEndFull(2)
+  ipefull = PatchEndFull(1)
+  jpefull = PatchEndFull(2)
+
+write(mess,*) ' ext_esmf_write_field: okay_to_write: ', DataHandle, okay_to_write(DataHandle)
+call wrf_debug( 300, TRIM(mess) )
+
+  ! case 1: the file is opened for write but not committed ("training")
+  IF ( .NOT. okay_to_write( DataHandle ) )  THEN
+
+    ! Training:  build the ESMF export state
+write(mess,*) ' ext_esmf_write_field: TRAINING WRITE:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+    ! First, build the ESMF_Grid for this DataHandle, if it does not 
+    ! already exist
+    CALL ioesmf_create_grid( DataHandle, esmf_rank, MemoryOrder, Stagger,      &
+                             DomainStart(1:esmf_rank), DomainEnd(1:esmf_rank), &
+                             MemoryStart(1:esmf_rank), MemoryEnd(1:esmf_rank), &
+                             PatchStart(1:esmf_rank), PatchEnd(1:esmf_rank) )
+    ! Grab the current exportState and add to it...
+    CALL ESMF_ExportStateGetCurrent( exportstate, rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field, training:  ESMF_ExportStateGetCurrent failed" )
+    ENDIF
+! BEGIN DOESNOTWORK
+! The following code does not work for reasons as-yet unknown.  
+! A likely suspect is lbounds and ubounds which fail in other interfaces in 
+! ESMF 2.2.0rp1 ...  
+    ! Build ESMF objects...  
+    ! Build an ESMF_ArraySpec.  The use of ESMF_ArraySpec and ESMF_Array 
+    ! objects allows some of the code that follows to be type-kind-independent.  
+!    CALL ESMF_ArraySpecSet(arrayspec, rank=esmf_rank, type=esmf_type, &
+!                                      kind=esmf_kind, rc=rc)
+!    IF ( rc /= ESMF_SUCCESS ) THEN
+!      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_ArraySpecSet failed" )
+!    ENDIF
+    ! Build an ESMF_Array
+    ! Implementation note:  since we do not yet have full control over how 
+    ! ESMF chooses to lay out a "patch" within "memory", we must copy by 
+    ! hand.  (Reasons include lack of support in ESMF for asymmetric halos, 
+    ! addition of "extra" rows/columns to optimize alignment on some machines, 
+    ! handling of periodic boundary conditions, etc.)  Thus, there 
+    ! is no point in using larger "memory" sizes to build the array -- patch 
+    ! is fine.  Also, since we must copy anyway, might as well let ESMF manage 
+    ! the memory for simplicity.  
+!$$$ Once ESMF can match WRF memory-patch mapping, replace this with a more 
+!$$$ efficient solution that does not require a copy.  
+! $$$ esmf_counts is redundant.  Remove it as soon as ESMF_ArrayCreate no 
+! $$$ longer requires it.  
+!    esmf_counts(1:esmf_rank) = DomainEndFull(1:esmf_rank) - &
+!                               DomainStart(1:esmf_rank) + 1
+!    tmpArray = ESMF_ArrayCreate(arrayspec, counts=esmf_counts,      &
+!                                lbounds=DomainStart(1:esmf_rank),   &
+!                                ubounds=DomainEndFull(1:esmf_rank), &
+!                                rc=rc)
+!    IF ( rc /= ESMF_SUCCESS ) THEN
+!      WRITE(mess,*) ' ext_esmf_write_field: ESMF_ArrayCreate failed, rc = ', rc
+!      CALL wrf_error_fatal( TRIM(mess) )
+!    ENDIF
+    ! Determine grid staggering for this Field
+!    IF ( has_char( Stagger, 'x' ) .AND. has_char( Stagger, 'y' ) ) THEN
+!      CALL wrf_error_fatal( &
+!        "ext_esmf_write_field:  ESMF does not yet support XY staggering for C-grid" )
+!    ELSE IF ( has_char( Stagger, 'x' ) ) THEN
+!      horzrelloc=ESMF_CELL_WFACE
+!    ELSE IF ( has_char( Stagger, 'y' ) ) THEN
+!      horzrelloc=ESMF_CELL_SFACE
+!    ELSE
+!      horzrelloc=ESMF_CELL_CENTER
+!    ENDIF
+    ! Build an ESMF_Field
+    ! Note:  though it is counter-intuitive, ESMF uses 
+    ! shallow-copy-masquerading-as-reference to implement the 
+    ! pseudo-equivalent of POINTER assignment under-the-hood.  What this means 
+    ! here is that it is OK to pass deep object tmpArray into 
+    ! ESMF_FieldCreate() and then return from this subroutine.  Even though 
+    ! tmpArray goes out of scope, it is OK.  However, if tmpArray were to be 
+    ! modified after this call, the changes would not be guaranteed to always 
+    ! appear in tmpField.  It works that way now, but ESMF Core team has 
+    ! plans that may make it break in the future.  Build-it, attach-it, 
+    ! flush-it will work.  Build-it, attach-it, modify-it, flush-it may not 
+    ! always work.  
+    ! "Pie, pie and a fox..."  
+    ! Note:  unique Field name is required by ESMF_StateAddField().  
+!$$$here...  use CF "standard_name" once the WRF Registry supports it
+!    tmpField = ESMF_FieldCreate( grid( DataHandle )%ptr, tmpArray,          &
+!                                 copyflag=ESMF_DATA_REF,                    &
+!                                 horzrelloc=horzrelloc, name=TRIM(VarName), &
+!                                 rc=rc )
+! END DOESNOTWORK
+    !$$$here...  This is a complete HACK for debugging!!  Need to compute 
+    !$$$here...  horzrelloc from Stagger as above...  
+    horzrelloc=ESMF_CELL_CENTER
+    !$$$ TODO:  Add code for other data types here...  
+    ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) )
+    CALL wrf_debug ( 100, 'ext_esmf_write_field: calling ESMF_FieldCreate' )
+    tmpField = ESMF_FieldCreate(         &
+                 grid( DataHandle )%ptr, &
+                 tmp_esmf_r4_ptr,        &
+                 copyflag=ESMF_DATA_REF, &
+                 horzrelloc=horzrelloc,  &
+                 name=TRIM(VarName),     &
+                 rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      WRITE(mess,*) ' ext_esmf_write_field: ESMF_FieldCreate failed, rc = ', rc
+      CALL wrf_error_fatal( TRIM(mess) )
+    ENDIF
+    CALL wrf_debug ( 100, 'ext_esmf_write_field: back from ESMF_FieldCreate' )
+    WRITE(mess,*) 'ext_esmf_write_field: tmp_esmf_r4_ptr(',        &
+      LBOUND(tmp_esmf_r4_ptr,1),':',UBOUND(tmp_esmf_r4_ptr,1),',', &
+      LBOUND(tmp_esmf_r4_ptr,2),':',UBOUND(tmp_esmf_r4_ptr,2),')'
+    CALL wrf_debug ( 100 , TRIM(mess) )
+    ! Add the Field to the export state...  
+!$$$here...  for now, just build ESMF_Fields and stuff them in
+!$$$here...  later, use a single ESMF_Bundle
+    CALL ESMF_StateAddField( exportstate, tmpField, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateAddField failed" )
+    ENDIF
+write(mess,*) ' ext_esmf_write_field: END TRAINING WRITE:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+  ! case 2: opened for write and committed
+  ELSE IF ( okay_to_write( DataHandle ) )  THEN
+
+write(mess,*) ' ext_esmf_write_field: ACTUAL WRITE:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+!$$$DEBUG
+! count calls...
+numtimes = numtimes + 1
+CALL get_current_time_string( timestamp )
+!$$$END DEBUG
+
+    ! write:  insert data into the ESMF export state
+    ! Grab the current exportState
+    CALL ESMF_ExportStateGetCurrent( exportstate, rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_ExportStateGetCurrent failed" )
+    ENDIF
+    ! grab the Field
+    CALL ESMF_StateGetField( exportstate, fieldName=TRIM(VarName), &
+                             field=tmpfield, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateGetField failed" )
+    ENDIF
+!$$$DEBUG
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 1' )
+CALL ESMF_FieldPrint( tmpField, rc=rc )
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 1' )
+!$$$END DEBUG
+
+    ! grab a pointer to the export state data and copy data from Field
+    IF      ( FieldType .EQ. WRF_REAL ) THEN
+      CALL ESMF_FieldGetDataPointer( tmpField, data_esmf_real_ptr, &
+                                     ESMF_DATA_REF, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_FieldGetDataPointer(r4) failed" )
+      ENDIF
+      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchEndFull(1) /= UBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_real_ptr,2) ) .OR. &
+           ( PatchEndFull(2) /= UBOUND(data_esmf_real_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',          &
+          __FILE__ ,                                                         &
+          ', line ',                                                         &
+          __LINE__ ,                                                         &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEndFull(1),',',      &
+                                 PatchStart(2),':',PatchEndFull(2),          &
+          ', data_esmf_real_ptr(BOUNDS) = ',                                 &
+          LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
+          LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
+        CALL wrf_error_fatal ( TRIM(mess) )
+      ENDIF
+!$$$DEBUG
+WRITE( mess,* ) 'DEBUG:  ext_esmf_write_field:  ips:ipe,jps:jpe = ', &
+  ips,':',ipe,',',jps,':',jpe,                                       &
+  ', data_esmf_real_ptr(BOUNDS) = ',                                 &
+  LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
+  LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
+CALL wrf_debug( 300, TRIM(mess) )
+!ict = 0
+!DO j= jms, jme
+!  DO i= ims, ime
+!    ict = ict + 1
+!    IF ( (iipe) .OR. (jjpe) ) THEN
+!      debug_real(i,j) = -(i*1000.0 + j)/100000.0     ! obvious bad value for debugging
+!    ELSE
+!      debug_real(i,j) = Field(ict)
+!    ENDIF
+!  ENDDO
+!ENDDO
+!CALL wrf_debug( 100, 'DEBUG:  ext_esmf_write_field:  writing DEBUG1_WRFcmp_write_Field'//TRIM(VarName)//'_'//TRIM(timestamp) )
+!OPEN( UNIT=985, FILE='DEBUG1_WRFcmp_write_Field'//TRIM(VarName)//'_'//TRIM(timestamp), FORM='formatted' )
+!WRITE (985,'(a,a,i4)') TRIM(VarName),' ',numtimes
+!DO j = jps, jpe
+!  DO i = ips, ipe
+!    WRITE (985,*) '(',i,',',j,'):  ',debug_real(i,j)
+!  ENDDO
+!ENDDO
+!CLOSE (985)
+!$$$END DEBUG
+      CALL ioesmf_insert_data_real( Field, data_esmf_real_ptr,            &
+                                    ips, ipefull, jps, jpefull, kps, kpe, &
+                                    ims, ime, jms, jme, kms, kme )
+!$$$DEBUG
+!DO j= jms, jme
+!  DO i= ims, ime
+!    debug_real(i,j) = -(i*1000.0 + j)/100000.0     ! obvious bad value for debugging
+!  ENDDO
+!ENDDO
+!debug_real(ips:ipe,jps:jpe) = data_esmf_real_ptr(ips:ipe,jps:jpe)
+!CALL wrf_debug( 100, 'DEBUG:  ext_esmf_write_field:  writing DEBUG1_WRFcmp_export'//TRIM(VarName)//'_'//TRIM(timestamp) )
+!OPEN( UNIT=985, FILE='DEBUG1_WRFcmp_export'//TRIM(VarName)//'_'//TRIM(timestamp), FORM='formatted' )
+!WRITE (985,'(a,a,i4)') TRIM(VarName),' ',numtimes
+!DO j = jps, jpe
+!  DO i = ips, ipe
+!    WRITE (985,*) '(',i,',',j,'):  ',debug_real(i,j)
+!  ENDDO
+!ENDDO
+!CLOSE (985)
+!$$$END DEBUG
+    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+      CALL ESMF_FieldGetDataPointer( tmpField, data_esmf_int_ptr, &
+                                     ESMF_DATA_REF, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_FieldGetDataPointer(i4) failed" )
+      ENDIF
+      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchEndFull(1) /= UBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_int_ptr,2) ) .OR. &
+           ( PatchEndFull(2) /= UBOUND(data_esmf_int_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',        &
+          __FILE__ ,                                                       &
+          ', line ',                                                       &
+          __LINE__ ,                                                       &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEndFull(1),',',    &
+                                 PatchStart(2),':',PatchEndFull(2),        &
+          ', data_esmf_int_ptr(BOUNDS) = ',                                &
+          LBOUND(data_esmf_int_ptr,1),':',UBOUND(data_esmf_int_ptr,1),',', &
+          LBOUND(data_esmf_int_ptr,2),':',UBOUND(data_esmf_int_ptr,2)
+        CALL wrf_error_fatal ( TRIM(mess) )
+      ENDIF
+      CALL ioesmf_insert_data_int( Field, data_esmf_int_ptr,             &
+                                   ips, ipefull, jps, jpefull, kps, kpe, &
+                                   ims, ime, jms, jme, kms, kme )
+    ENDIF
+write(mess,*) ' ext_esmf_write_field: END ACTUAL WRITE:  DataHandle = ', DataHandle
+call wrf_debug( 300, TRIM(mess) )
+
+  ENDIF
+
+!$$$DEBUG
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 2' )
+CALL ESMF_FieldPrint( tmpField, rc=rc )
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 2' )
+!$$$END DEBUG
+
+  Status = 0
+
+  RETURN
+
+END SUBROUTINE ext_esmf_write_field
+
diff --git a/wrfv2_fire/external/io_esmf/io_esmf.F90 b/wrfv2_fire/external/io_esmf/io_esmf.F90
new file mode 100644
index 00000000..d83d9aaa
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/io_esmf.F90
@@ -0,0 +1,1859 @@
+
+MODULE module_ext_esmf
+
+  USE ESMF_Mod
+  USE module_esmf_extensions
+
+  IMPLICIT NONE
+
+  TYPE grid_ptr
+    TYPE(ESMF_Grid), POINTER :: ptr
+    ! use these for error-checking for now...
+    INTEGER :: ide_save
+    INTEGER :: jde_save
+    INTEGER :: kde_save
+    LOGICAL :: in_use
+  END TYPE grid_ptr
+
+  ! TBH:  should package this state into an object...  
+  INTEGER, PARAMETER :: int_num_handles = 99
+  LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, okay_to_read,       &
+                                         opened_for_write, opened_for_read, &
+                                         int_handle_in_use
+  TYPE(grid_ptr) :: grid(int_num_handles)
+
+  ! convenience...
+  CHARACTER (256) :: msg
+
+#include "wrf_io_flags.h"
+#include "wrf_status_codes.h"
+
+  CONTAINS
+
+    LOGICAL FUNCTION int_valid_handle( handle )
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) ::  handle
+      int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles ) 
+    END FUNCTION int_valid_handle
+
+    SUBROUTINE int_get_fresh_handle( retval )
+      INTEGER i, retval
+
+      retval = -1
+! dont use first 8 handles
+      DO i = 8, int_num_handles
+        IF ( .NOT. int_handle_in_use(i) )  THEN
+          retval = i
+          GOTO 33
+        ENDIF
+      ENDDO
+33    CONTINUE
+      IF ( retval < 0 )  THEN
+        CALL wrf_error_fatal( "io_esmf.F90: int_get_fresh_handle() out of handles")
+      ENDIF
+      int_handle_in_use(retval) = .TRUE.
+    END SUBROUTINE int_get_fresh_handle
+
+! parse comma separated list of VARIABLE=VALUE strings and return the
+! value for the matching variable if such exists, otherwise return
+! the empty string
+SUBROUTINE get_value ( varname , str , retval )
+  IMPLICIT NONE
+  CHARACTER*(*) ::    varname
+  CHARACTER*(*) ::    str
+  CHARACTER*(*) ::    retval
+
+  CHARACTER (128) varstr, tstr
+  INTEGER i,j,n,varstrn
+  LOGICAL nobreak, nobreakouter
+
+  varstr = TRIM(varname)//"="
+  varstrn = len(TRIM(varstr))
+  n = len(TRIM(str))
+  retval = ""
+  i = 1
+  nobreakouter = .TRUE.
+  DO WHILE ( nobreakouter )
+    j = 1
+    nobreak = .TRUE.
+    tstr = ""
+    DO WHILE ( nobreak )
+      nobreak = .FALSE.
+      IF ( i .LE. n ) THEN
+        IF (str(i:i) .NE. ',' ) THEN
+           tstr(j:j) = str(i:i)
+           nobreak = .TRUE.
+        ENDIF
+      ENDIF
+      j = j + 1
+      i = i + 1
+    ENDDO
+    IF ( i .GT. n ) nobreakouter = .FALSE.
+    IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
+      retval(1:) = TRIM(tstr(varstrn+1:))
+      nobreakouter = .FALSE.
+    ENDIF
+  ENDDO
+  RETURN
+END SUBROUTINE get_value
+
+
+    !--- ioinit
+    SUBROUTINE init_module_ext_esmf
+      IMPLICIT NONE
+      INTEGER :: i
+      DO i = 1, int_num_handles
+        WRITE( msg,* ) 'init_module_ext_esmf:  calling ioesmf_nullify_grid(',i,')'
+        CALL wrf_debug ( 5, TRIM(msg) )
+        CALL ioesmf_nullify_grid( i )
+      ENDDO
+      RETURN
+    END SUBROUTINE init_module_ext_esmf
+
+
+  ! allgather for integers, ESMF_style (since ESMF does not do this yet)
+  SUBROUTINE GatherIntegerScalars_ESMF( inval, pe, numprocs, outvals )
+    INTEGER, INTENT(IN   ) :: inval                 ! input scalar on this task
+    INTEGER, INTENT(IN   ) :: pe                    ! task id
+    INTEGER, INTENT(IN   ) :: numprocs              ! number of tasks
+    INTEGER, INTENT(  OUT) :: outvals(0:numprocs-1) ! gathered output vector
+    ! Local declarations
+    TYPE(ESMF_VM) :: vm
+    INTEGER(ESMF_KIND_I4) :: allSnd(0:numprocs-1)
+    INTEGER(ESMF_KIND_I4) :: allRcv(0:numprocs-1)
+    INTEGER :: rc
+
+    ! get current ESMF virtual machine for communication
+    CALL ESMF_VMGetCurrent(vm, rc)
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
+                     __FILE__ ,                    &
+                     ', line',                     &
+                     __LINE__
+      CALL wrf_error_fatal ( msg )
+    ENDIF
+    allSnd = 0_ESMF_KIND_I4
+    allSnd(pe) = inval
+    ! Hack due to lack of ESMF_VMAllGather().  
+    CALL ESMF_VMAllReduce(vm, allSnd, allRcv, numprocs, ESMF_SUM, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      WRITE( msg,* ) 'Error in ESMF_VMAllReduce', &
+                     __FILE__ ,                     &
+                     ', line',                      &
+                     __LINE__
+      CALL wrf_error_fatal ( msg )
+    ENDIF
+    outvals = allRcv
+
+  END SUBROUTINE GatherIntegerScalars_ESMF
+
+
+END MODULE module_ext_esmf
+
+
+
+  ! Indexes for non-staggered variables come in at one-less than
+  ! domain dimensions, but io_esmf is currently hacked to use full 
+  ! domain spec, so adjust if not staggered.  
+  ! $$$ TBD:  remove this hackery once ESMF can support staggered 
+  ! $$$ TBD:  grids in regional models
+  SUBROUTINE ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
+                                 DomainEndFull, PatchEndFull )
+    IMPLICIT NONE
+    INTEGER,       INTENT(IN   ) :: numdims
+    INTEGER,       INTENT(IN   ) :: DomainEnd(numdims)
+    INTEGER,       INTENT(IN   ) :: PatchEnd(numdims)
+    CHARACTER*(*), INTENT(IN   ) :: Stagger
+    INTEGER,       INTENT(  OUT) :: DomainEndFull(numdims)
+    INTEGER,       INTENT(  OUT) :: PatchEndFull(numdims)
+    LOGICAL, EXTERNAL :: has_char
+    DomainEndFull(1:numdims) = DomainEnd(1:numdims)
+    IF ( .NOT. has_char( Stagger, 'x' ) ) DomainEndFull(1) = DomainEndFull(1) + 1
+    IF ( .NOT. has_char( Stagger, 'y' ) ) DomainEndFull(2) = DomainEndFull(2) + 1
+    PatchEndFull(1:numdims) = PatchEnd(1:numdims)
+    IF ( .NOT. has_char( Stagger, 'x' ) ) THEN
+      IF ( DomainEnd(1) == PatchEnd(1) ) PatchEndFull(1) = DomainEndFull(1)
+    ENDIF
+    IF ( .NOT. has_char( Stagger, 'y' ) ) THEN
+      IF ( DomainEnd(2) == PatchEnd(2) ) PatchEndFull(2) = DomainEndFull(2)
+    ENDIF
+  END SUBROUTINE ioesmf_endfullhack
+
+
+  ! Create the ESMF_Grid associated with index DataHandle.  
+  ! TBH:  Note that periodicity is not supported by this interface.  If 
+  ! TBH:  periodicity is needed, pass in via SysDepInfo in the call to 
+  ! TBH:  ext_esmf_ioinit().  
+  ! TBH:  Note that lat/lon coordinates are not supported by this interface 
+  ! TBH:  since general curvilinear coordindates (needed for map projections 
+  ! TBH:  used by WRF such as polar stereographic, mercator, lambert conformal)
+  ! TBH:  are not supported by ESMF as of ESMF 2.1.1.  Once they are supported, 
+  ! TBH:  add them via the "sieve" method used in ../io_mcel/.  
+  SUBROUTINE ioesmf_create_grid( DataHandle, numdims,    &
+                                 MemoryOrder, Stagger,   &
+                                 DomainStart, DomainEnd, &
+                                 MemoryStart, MemoryEnd, &
+                                 PatchStart, PatchEnd )
+    USE module_ext_esmf
+    IMPLICIT NONE
+    INTEGER,       INTENT(IN   ) :: DataHandle
+    INTEGER,       INTENT(IN   ) :: numdims
+    CHARACTER*(*), INTENT(IN   ) :: MemoryOrder            ! not used yet
+    CHARACTER*(*), INTENT(IN   ) :: Stagger
+    INTEGER,       INTENT(IN   ) :: DomainStart(numdims), DomainEnd(numdims)
+    INTEGER,       INTENT(IN   ) :: MemoryStart(numdims), MemoryEnd(numdims)
+    INTEGER,       INTENT(IN   ) :: PatchStart(numdims),  PatchEnd(numdims)
+    INTEGER :: DomainEndFull(numdims)
+    INTEGER :: PatchEndFull(numdims)
+
+    WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  begin, DataHandle = ', DataHandle
+    CALL wrf_debug ( 5, TRIM(msg) )
+    ! For now, blindly create a new grid if it does not already exist for 
+    ! this DataHandle
+! TBH:  Note that this approach will result in duplicate ESMF_Grids when 
+! TBH:  io_esmf is used for input and output.  The first ESMF_Grid will 
+! TBH:  be associated with the input handle and the second will be associated 
+! TBH:  with the output handle.  
+    IF ( .NOT. grid( DataHandle )%in_use ) THEN
+      IF ( ASSOCIATED( grid( DataHandle )%ptr ) ) THEN
+        CALL wrf_error_fatal ( 'ASSERTION ERROR:  grid(',DataHandle,') should be NULL' )
+      ENDIF
+      IF ( numdims /= 2 ) THEN
+        CALL wrf_error_fatal ( 'ERROR:  only 2D arrays supported so far with io_esmf' )
+      ELSE
+        WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  creating grid(',DataHandle,')%ptr'
+        CALL wrf_debug ( 5, TRIM(msg) )
+        ALLOCATE( grid( DataHandle )%ptr )
+        grid( DataHandle )%in_use = .TRUE.
+        ! The non-staggered variables come in at one-less than
+        ! domain dimensions, but io_esmf is currently hacked to use full 
+        ! domain spec, so adjust if not staggered.  
+        ! $$$ TBD:  remove this hackery once ESMF can support staggered 
+        ! $$$ TBD:  grids in regional models
+        CALL ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
+                                 DomainEndFull, PatchEndFull )
+! $$$ TBD:  at the moment this is hard-coded for 2D arrays
+! $$$ TBD:  use MemoryOrder to set these properly!
+! $$$ TBD:  also, set these once only
+! $$$ TBD:  maybe even rip this out since it depends on a hack in input_wrf.F ...
+        grid( DataHandle )%ide_save = DomainEndFull(1)
+        grid( DataHandle )%jde_save = DomainEndFull(2)
+        grid( DataHandle )%kde_save = 1
+        WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  DomainEndFull = ', DomainEndFull
+        CALL wrf_debug ( 5, TRIM(msg) )
+        WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  PatchEndFull = ', PatchEndFull
+        CALL wrf_debug ( 5, TRIM(msg) )
+        CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid:  Calling ioesmf_create_grid_int()' )
+        CALL ioesmf_create_grid_int( grid( DataHandle )%ptr,     &
+                              numdims,                    &
+                              DomainStart, DomainEndFull, &
+                              MemoryStart, MemoryEnd,     &
+                              PatchStart, PatchEndFull )
+        CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid:  back from ioesmf_create_grid_int()' )
+        WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  done creating grid(',DataHandle,')%ptr'
+        CALL wrf_debug ( 5, TRIM(msg) )
+      ENDIF
+    ENDIF
+    WRITE( msg,* ) 'DEBUG ioesmf_create_grid:  end'
+    CALL wrf_debug ( 5, TRIM(msg) )
+
+  END SUBROUTINE ioesmf_create_grid
+
+
+
+  ! Create an ESMF_Grid that matches a WRF decomposition.  
+  ! TBH:  Note that periodicity is not supported by this interface.  If 
+  ! TBH:  periodicity is needed, pass in via SysDepInfo in the call to 
+  ! TBH:  ext_esmf_ioinit().  
+  ! TBH:  Note that lat/lon coordinates are not supported by this interface 
+  ! TBH:  since general curvilinear coordindates (needed for map projections 
+  ! TBH:  used by WRF such as polar stereographic, mercator, lambert conformal)
+  ! TBH:  are not supported by ESMF as of ESMF 2.1.1.  Once they are supported, 
+  ! TBH:  add them via the "sieve" method used in ../io_mcel/.  
+  ! $$$ TBD:  Note that DomainEnd and PatchEnd must currently include "extra" 
+  ! $$$ TBD:  points for non-periodic staggered arrays.  It may be possible to 
+  ! $$$ TBD:  remove this hackery once ESMF can support staggered 
+  ! $$$ TBD:  grids in regional models.  
+  SUBROUTINE ioesmf_create_grid_int( esmfgrid, numdims,      &
+                              DomainStart, DomainEnd, &
+                              MemoryStart, MemoryEnd, &
+                              PatchStart, PatchEnd )
+    USE module_ext_esmf
+    IMPLICIT NONE
+    TYPE(ESMF_Grid), INTENT(INOUT) :: esmfgrid
+    INTEGER,         INTENT(IN   ) :: numdims
+    INTEGER,         INTENT(IN   ) :: DomainStart(numdims), DomainEnd(numdims)
+    INTEGER,         INTENT(IN   ) :: MemoryStart(numdims), MemoryEnd(numdims)
+    INTEGER,         INTENT(IN   ) :: PatchStart(numdims),  PatchEnd(numdims)
+    ! Local declarations
+    INTEGER :: numprocs     ! total number of tasks
+    INTEGER, ALLOCATABLE :: ipatchStarts(:), jpatchStarts(:)
+    INTEGER :: numprocsX    ! number of tasks in "i" dimension
+    INTEGER :: numprocsY    ! number of tasks in "j" dimension
+    INTEGER, ALLOCATABLE :: permuteTasks(:)
+    INTEGER :: globalXcount ! staggered domain count in "i" dimension
+    INTEGER :: globalYcount ! staggered domain count in "j" dimension
+    INTEGER :: myXstart     ! task-local start in "i" dimension
+    INTEGER :: myYstart     ! task-local start in "j" dimension
+    INTEGER :: myXend       ! staggered task-local end in "i" dimension
+    INTEGER :: myYend       ! staggered task-local end in "j" dimension
+    INTEGER, ALLOCATABLE :: allXStart(:)
+    INTEGER, ALLOCATABLE :: allXCount(:)
+    INTEGER, ALLOCATABLE :: dimXCount(:)
+    INTEGER, ALLOCATABLE :: allYStart(:)
+    INTEGER, ALLOCATABLE :: allYCount(:)
+    INTEGER, ALLOCATABLE :: dimYCount(:)
+    REAL(ESMF_KIND_R8), ALLOCATABLE :: coordX(:)
+    REAL(ESMF_KIND_R8), ALLOCATABLE :: coordY(:)
+    INTEGER, ALLOCATABLE :: cellCounts(:,:)
+    INTEGER, ALLOCATABLE :: globalStarts(:,:)
+    INTEGER :: rc
+    INTEGER :: myXcount      ! task-local count in "i" dimension
+    INTEGER :: myYcount      ! task-local count in "j" dimension
+    INTEGER :: globalCellCounts(2)
+    INTEGER :: numprocsXY(2)
+    INTEGER :: myPE, i, j, pe, is, ie, js, je, is_min, js_min, ie_max, je_max
+    INTEGER :: ips, ipe, jps, jpe, ids, ide, jds, jde
+    TYPE(ESMF_VM) :: vm
+    TYPE(ESMF_DELayout) :: taskLayout
+    CHARACTER (32) :: gridname
+    INTEGER, SAVE :: gridID = 0
+
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  begin...' )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  numdims = ',numdims
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  DomainStart = ',DomainStart(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  DomainEnd = ',DomainEnd(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  MemoryStart = ',MemoryStart(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  MemoryEnd = ',MemoryEnd(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  PatchStart = ',PatchStart(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  PatchEnd = ',PatchEnd(1:numdims)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      ! First, determine number of tasks and number of tasks in each decomposed 
+      ! dimension (ESMF 2.2.0 is restricted to simple task layouts)
+      ! get current ESMF virtual machine and inquire...  
+      CALL ESMF_VMGetCurrent(vm, rc)
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_VMGetCurrent', &
+                       __FILE__ ,                    &
+                       ', line',                     &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      ! TBH:  Note (PET==MPI process) assumption here.  This is OK in ESMF 
+      ! TBH:  2.2.0 but may change in a future ESMF release.  If so, we will 
+      ! TBH:  need another way to do this.  May want to grab mpiCommunicator 
+      ! TBH:  instead and ask it directly for number of MPI tasks.  Of course, 
+      ! TBH:  what if this is a serial run?  
+      CALL ESMF_VMGet(vm, petCount=numprocs, localPet=myPE, rc=rc)
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_VMGet', &
+                       __FILE__ ,             &
+                       ', line',              &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      ALLOCATE( ipatchStarts(0:numprocs-1), jpatchStarts(0:numprocs-1) )
+      CALL GatherIntegerScalars_ESMF(PatchStart(1), myPE, numprocs, ipatchStarts)
+      CALL GatherIntegerScalars_ESMF(PatchStart(2), myPE, numprocs, jpatchStarts)
+      numprocsX = 0
+      numprocsY = 0
+      DO pe = 0, numprocs-1
+        IF ( PatchStart(1) == ipatchStarts(pe) ) THEN
+          numprocsX = numprocsX + 1
+        ENDIF
+        IF ( PatchStart(2) == jpatchStarts(pe) ) THEN
+          numprocsY = numprocsY + 1
+        ENDIF
+      ENDDO
+      DEALLOCATE( ipatchStarts, jpatchStarts )
+      ! sanity check
+      IF ( numprocs /= numprocsX*numprocsY ) THEN
+        CALL wrf_error_fatal ( 'ASSERTION FAILED:  numprocs /= numprocsX*numprocsY' )
+      ENDIF
+      ! Next, create ESMF_DELayout
+      numprocsXY = (/ numprocsX, numprocsY /)
+      ! transpose tasks to match RSL
+      ! TBH:  1-to-1 DE to PET mapping is assumed below...  
+      ALLOCATE( permuteTasks(0:numprocs-1) )
+      pe = 0
+      DO j = 0, numprocsY-1
+        DO i = 0, numprocsX-1
+! (/ 0 2 1 3 /)
+        permuteTasks(pe) = (i*numprocsY) + j
+! (/ 0 1 2 3 /)
+!        permuteTasks(pe) = pe
+        pe = pe + 1
+        ENDDO
+      ENDDO
+!$$$DEBUG
+!      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_VMPrint' )
+!      CALL ESMF_VMPrint( vm=vm, rc=rc )
+!      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_VMPrint' )
+!$$$END DEBUG
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  numprocsXY = ',numprocsXY
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  permuteTasks = ',permuteTasks
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_DELayoutCreate' )
+      taskLayout = ESMF_DELayoutCreate( vm, numprocsXY, petList=permuteTasks, rc=rc ) 
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_DELayoutCreate', &
+                       __FILE__ ,                      &
+                       ', line',                       &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_DELayoutCreate' )
+      DEALLOCATE( permuteTasks )
+!$$$DEBUG
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_DELayoutPrint 1' )
+      CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_DELayoutPrint 1' )
+!$$$END DEBUG
+      ! Compute indices for staggered grids because ESMF does not yet support addition of 
+      ! extra data points for staggered dimensions as is common in regional models.  
+      ! $$$ TBD:  Remove this hack once ESMF can handle it.  
+      ! the [ij][dp][se] bits are for convenience...  
+      ids = DomainStart(1); ide = DomainEnd(1); 
+      jds = DomainStart(2); jde = DomainEnd(2); 
+      ips = PatchStart(1);  ipe = PatchEnd(1); 
+      jps = PatchStart(2);  jpe = PatchEnd(2); 
+      globalXcount = ide - ids + 1
+      globalYcount = jde - jds + 1
+      ! task-local numbers of points in patch for staggered arrays
+      myXstart = ips
+      myYstart = jps
+      ! staggered-only for now
+      myXend = ipe
+      myYend = jpe
+!      myXend = min(ipe, ide-1)
+!      myYend = min(jpe, jde-1)
+      myXcount = myXend - myXstart + 1
+      myYcount = myYend - myYstart + 1
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered     ips = ', ips
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered     ipe = ', min(ipe, ide-1)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered i count = ', myXCount
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered     jps = ', jps
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered     jpe = ', min(jpe, jde-1)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  WRF non-staggered j count = ', myYCount
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered     ips = ', ips
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered     ipe = ', ipe
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered i count = ', ipe-ips+1
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered     jps = ', jps
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered     jpe = ', jpe
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  WRF     staggered j count = ', jpe-jps+1
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      ! gather task-local information on all tasks since 
+      ! ESMF_GridDistribute[Block] interface require global knowledge to set up 
+      ! decompositions (@#$%)
+      ! Recall that coordX and coordY are coordinates of *vertices*, not cell centers.  
+      ! Thus they must be 1 bigger than the number of cells.  
+      ALLOCATE( allXStart(0:numprocs-1),  allXCount(0:numprocs-1),  &
+                allYStart(0:numprocs-1),  allYCount(0:numprocs-1),  &
+                dimXCount(0:numprocsX-1), dimYCount(0:numprocsY-1), &
+                coordX(globalXcount+1),   coordY(globalYcount+1) )
+      CALL GatherIntegerScalars_ESMF(myXcount, myPE, numprocs, allXCount)
+      CALL GatherIntegerScalars_ESMF(myXstart, myPE, numprocs, allXStart)
+      CALL GatherIntegerScalars_ESMF(myYcount, myPE, numprocs, allYCount)
+      CALL GatherIntegerScalars_ESMF(myYstart, myPE, numprocs, allYStart)
+
+      ! HACK:  ESMF does not yet support mercator, polar-stereographic, or 
+      ! HACK:  lambert-conformal projections.  Therefore, we're using fake 
+      ! HACK:  coordinates here.  This means that WRF will either have to 
+      ! HACK:  couple to models that run on the same coorindate such that 
+      ! HACK:  grid points are co-located or something else will have to 
+      ! HACK:  perform the inter-grid interpolation computations.  Replace 
+      ! HACK:  this once ESMF is upgraded to support the above map 
+      ! HACK:  projections (via general curvilinear coordinates).  
+      CALL wrf_message( 'WARNING:  Using artificial coordinates for ESMF coupling.' )
+      CALL wrf_message( 'WARNING:  ESMF coupling interpolation will be incorrect' )
+      CALL wrf_message( 'WARNING:  unless grid points in the coupled components' )
+      CALL wrf_message( 'WARNING:  are co-located.  This limitation will be removed' )
+      CALL wrf_message( 'WARNING:  once ESMF coupling supports generalized' )
+      CALL wrf_message( 'WARNING:  curvilinear coordintates needed to represent' )
+      CALL wrf_message( 'WARNING:  common map projections used by WRF and other' )
+      CALL wrf_message( 'WARNING:  regional models.' )
+      ! Note that ESMF defines coordinates at *vertices*
+      coordX(1) = 0.0
+      DO i = 2, SIZE(coordX)
+        coordX(i) = coordX(i-1) + 1.0
+      ENDDO
+      coordY(1) = 0.0
+      DO j = 2, SIZE(coordY)
+        coordY(j) = coordY(j-1) + 1.0
+      ENDDO
+      ! Create an ESMF_Grid
+      ! For now we create only a 2D grid suitable for simple coupling of 2D 
+      ! surface fields.  Later, create and subset one or more 3D grids.  
+!TBH $$$:  NOTE that we'll have to use ESMF_GRID_HORZ_STAGGER_E_?? for NMM.  
+!TBH $$$:  E-grid is not yet supported by ESMF.  Eventually pass staggering 
+!TBH $$$:  info into this routine.  For now, hard-code it for WRF-ARW.  
+      gridID = gridID + 1
+      WRITE ( gridname,'(a,i0)' ) 'WRF_grid_', gridID
+!$$$DEBUG
+CALL wrf_debug ( 5 , 'DEBUG WRF:  Calling ESMF_GridCreateHorzXY()' )
+WRITE( msg,* ) 'DEBUG WRF:  SIZE(coordX) = ', SIZE(coordX)
+CALL wrf_debug ( 5 , TRIM(msg) )
+WRITE( msg,* ) 'DEBUG WRF:  SIZE(coordY) = ', SIZE(coordY)
+CALL wrf_debug ( 5 , TRIM(msg) )
+DO i = 1, SIZE(coordX)
+  WRITE( msg,* ) 'DEBUG WRF:  coord1(',i,') = ', coordX(i)
+  CALL wrf_debug ( 5 , TRIM(msg) )
+ENDDO
+DO j = 1, SIZE(coordY)
+  WRITE( msg,* ) 'DEBUG WRF:  coord2(',j,') = ', coordY(j)
+  CALL wrf_debug ( 5 , TRIM(msg) )
+ENDDO
+WRITE( msg,* ) 'DEBUG WRF:  horzstagger = ', ESMF_GRID_HORZ_STAGGER_C_SW
+CALL wrf_debug ( 5 , TRIM(msg) )
+WRITE( msg,* ) 'DEBUG WRF:  name = ', TRIM(gridname)
+CALL wrf_debug ( 5 , TRIM(msg) )
+!$$$END DEBUG
+      esmfgrid = ESMF_GridCreateHorzXY(                     &
+                   coord1=coordX, coord2=coordY,            &
+                   horzstagger=ESMF_GRID_HORZ_STAGGER_C_SW, &
+! use this for 3D Grids once it is stable
+!                  coordorder=ESMF_COORD_ORDER_XZY,         &
+                   name=TRIM(gridname), rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridCreateHorzXY', &
+                       __FILE__ ,                        &
+                       ', line',                         &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+CALL wrf_debug ( 5 , 'DEBUG WRF:  back OK from ESMF_GridCreateHorzXY()' )
+      ! distribute the ESMF_Grid
+      ! ignore repeated values
+      is_min = MINVAL(allXStart)
+      js_min = MINVAL(allYStart)
+      i = 0
+      j = 0
+      WRITE( msg,* ) 'DEBUG:  is_min = ',is_min,'  allXStart = ',allXStart
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  js_min = ',js_min,'  allYStart = ',allYStart
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  allXCount = ',allXCount
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  allYCount = ',allYCount
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      DO pe = 0, numprocs-1
+        IF (allXStart(pe) == is_min) THEN
+          IF (j >= numprocsY) THEN
+            WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreateHorzXY', &
+                           __FILE__ ,                                   &
+                           ', line',                                    &
+                           __LINE__
+            CALL wrf_error_fatal ( msg )
+          ENDIF
+      WRITE( msg,* ) 'DEBUG:  dimYCount(',j,') == allYCount(',pe,')'
+      CALL wrf_debug ( 5 , TRIM(msg) )
+          dimYCount(j) = allYCount(pe)
+          j = j + 1
+        ENDIF
+        IF (allYStart(pe) == js_min) THEN
+          IF (i >= numprocsX) THEN
+            WRITE( msg,* ) 'ASSERTION FAILED in ESMF_GridCreateHorzXY', &
+                           __FILE__ ,                                   &
+                           ', line',                                    &
+                           __LINE__
+            CALL wrf_error_fatal ( msg )
+          ENDIF
+      WRITE( msg,* ) 'DEBUG:  dimXCount(',i,') == allXCount(',pe,')'
+      CALL wrf_debug ( 5 , TRIM(msg) )
+          dimXCount(i) = allXCount(pe)
+          i = i + 1
+        ENDIF
+      ENDDO
+      WRITE( msg,* ) 'DEBUG:  i = ',i,'  dimXCount = ',dimXCount
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  j = ',j,'  dimYCount = ',dimYCount
+      CALL wrf_debug ( 5 , TRIM(msg) )
+!$$$DEBUG
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_DELayoutPrint 2' )
+      CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_DELayoutPrint 2' )
+!$$$END DEBUG
+! $$$  crashes here with "-g" ...
+      CALL ESMF_GridDistribute( esmfgrid,                  &
+                                delayout=taskLayout,       &
+                                countsPerDEDim1=dimXCount, &
+                                countsPerDEDim2=dimYCount, &
+                                rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridDistribute ', &
+                       __FILE__ ,                       &
+                       ', line ',                       &
+                       __LINE__ ,                       &
+                       ', error code = ',rc
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+CALL wrf_debug ( 5 , 'DEBUG WRF:  Calling ESMF_GridValidate()' )
+      CALL ESMF_GridValidate( esmfgrid, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridValidate ',   &
+                       __FILE__ ,                       &
+                       ', line ',                       &
+                       __LINE__ ,                       &
+                       ', error code = ',rc
+! TBH:  debugging error exit here...  
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+CALL wrf_debug ( 5 , 'DEBUG WRF:  back OK from ESMF_GridValidate()' )
+      DEALLOCATE( allXStart, allXCount, allYStart, allYCount, &
+                  dimXCount, dimYCount, coordX, coordY )
+
+      ! Print out the ESMF decomposition info for debug comparison with WRF 
+      ! decomposition info.  
+      ALLOCATE( cellCounts(0:numprocs-1,2), globalStarts(0:numprocs-1,2) )
+
+!      CALL ESMF_GridGet( esmfgrid,                               &
+!                         horzrelloc=ESMF_CELL_CENTER,            &
+!                         globalStartPerDEPerDim=globalStarts,    &
+!                         cellCountPerDEPerDim=cellCounts,        &
+!                         globalCellCountPerDim=globalCellCounts, &
+!                         rc=rc )
+!      IF ( rc /= ESMF_SUCCESS ) THEN
+!        WRITE( msg,* ) 'Error in ESMF_GridGet', &
+!                       __FILE__ ,               &
+!                       ', line',                &
+!                       __LINE__
+!        CALL wrf_error_fatal ( msg )
+!      ENDIF
+! note that global indices in ESMF_Grid always start at zero
+!      WRITE( msg,* ) 'DEBUG:  ESMF task-id = ',myPE
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered     ips = ',1+globalStarts(myPE,1)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered     ipe = ',1+globalStarts(myPE,1) + cellCounts(myPE,1) - 1
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered i count = ',  cellCounts(myPE,1)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered     jps = ',1+globalStarts(myPE,2)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered     jpe = ',1+globalStarts(myPE,2) + cellCounts(myPE,2) - 1
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      WRITE( msg,* ) 'DEBUG:  ESMF non-staggered j count = ',  cellCounts(myPE,2)
+!      CALL wrf_debug ( 5 , TRIM(msg) )
+!      is_min = globalStarts(0,1)
+!      js_min = globalStarts(0,2)
+!      ie_max = globalStarts(0,1) + cellCounts(0,1) - 1
+!      je_max = globalStarts(0,2) + cellCounts(0,2) - 1
+!      DO pe = 1, (numprocsX*numprocsY)-1
+!        js = globalStarts(pe,2)
+!        je = globalStarts(pe,2) + cellCounts(pe,2) - 1
+!        IF ( js < js_min ) js_min = js
+!        IF ( je > je_max ) je_max = je
+!        is = globalStarts(pe,1)
+!        ie = globalStarts(pe,1) + cellCounts(pe,1) - 1
+!        IF ( is < is_min ) is_min = is
+!        IF ( ie > ie_max ) ie_max = ie
+!      ENDDO
+
+      ! extract information about staggered grids for debugging
+      CALL ESMF_GridGet( esmfgrid,                               &
+                         horzrelloc=ESMF_CELL_WFACE,             &
+                         globalStartPerDEPerDim=globalStarts,    &
+                         cellCountPerDEPerDim=cellCounts,        &
+                         globalCellCountPerDim=globalCellCounts, &
+                         rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridGet', &
+                       __FILE__ ,               &
+                       ', line',                &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+! note that global indices in ESMF_Grid always start at zero
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered     ips = ',1+globalStarts(myPE,1)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered     ipe = ',1+globalStarts(myPE,1) + cellCounts(myPE,1) - 1
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered i count = ',  cellCounts(myPE,1)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      CALL ESMF_GridGet( esmfgrid,                               &
+                         horzrelloc=ESMF_CELL_SFACE,             &
+                         globalStartPerDEPerDim=globalStarts,    &
+                         cellCountPerDEPerDim=cellCounts,        &
+                         globalCellCountPerDim=globalCellCounts, &
+                         rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridGet', &
+                       __FILE__ ,               &
+                       ', line',                &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+! note that global indices in ESMF_Grid always start at zero
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered     jps = ',1+globalStarts(myPE,2)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered     jpe = ',1+globalStarts(myPE,2) + cellCounts(myPE,2) - 1
+      CALL wrf_debug ( 5 , TRIM(msg) )
+      WRITE( msg,* ) 'DEBUG:  ESMF     staggered j count = ',  cellCounts(myPE,2)
+      CALL wrf_debug ( 5 , TRIM(msg) )
+
+      DEALLOCATE( cellCounts, globalStarts )
+
+      CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int:  print esmfgrid BEGIN...' )
+      CALL ESMF_GridPrint( esmfgrid, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridPrint', &
+                       __FILE__ ,                        &
+                       ', line',                         &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int:  print esmfgrid END' )
+
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  returning...' )
+
+  END SUBROUTINE ioesmf_create_grid_int
+
+
+
+  ! Destroy the ESMF_Grid associated with index DataHandle.  
+  ! grid( DataHandle )%ptr is DEALLOCATED (NULLIFIED)
+  SUBROUTINE ioesmf_destroy_grid( DataHandle )
+    USE module_ext_esmf
+    IMPLICIT NONE
+    INTEGER, INTENT(IN   ) :: DataHandle
+    ! Local declarations
+    INTEGER :: id, rc
+    TYPE(ESMF_DELayout) :: taskLayout
+    LOGICAL :: noneLeft
+    IF ( grid( DataHandle )%in_use ) THEN
+WRITE( msg,* ) 'DEBUG:  ioesmf_destroy_grid( ',DataHandle,' ) begin...'
+CALL wrf_debug ( 5 , TRIM(msg) )
+      CALL ESMF_GridGet( grid( DataHandle )%ptr, delayout=taskLayout, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridGet', &
+                       __FILE__ ,               &
+                       ', line',                &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      ! I "know" I created this...  (not really, but ESMF cannot tell me!)
+      CALL ESMF_DELayoutDestroy( taskLayout, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_DELayoutDestroy', &
+                       __FILE__ ,                       &
+                       ', line',                        &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      CALL ESMF_GridDestroy( grid( DataHandle )%ptr, rc=rc )
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridDestroy', &
+                       __FILE__ ,                   &
+                       ', line',                    &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+      DEALLOCATE( grid( DataHandle )%ptr )
+      CALL ioesmf_nullify_grid( DataHandle )
+WRITE( msg,* ) 'DEBUG:  ioesmf_destroy_grid( ',DataHandle,' ) end'
+CALL wrf_debug ( 5 , TRIM(msg) )
+    ENDIF
+
+  END SUBROUTINE ioesmf_destroy_grid
+
+
+  ! Nullify the grid_ptr associated with index DataHandle.  
+  ! grid( DataHandle )%ptr must not be associated
+  ! DataHandle must be in a valid range
+  SUBROUTINE ioesmf_nullify_grid( DataHandle )
+    USE module_ext_esmf
+    IMPLICIT NONE
+    INTEGER, INTENT(IN   ) :: DataHandle
+    NULLIFY( grid( DataHandle )%ptr )
+    grid( DataHandle )%in_use = .FALSE.
+    grid( DataHandle )%ide_save = 0
+    grid( DataHandle )%jde_save = 0
+    grid( DataHandle )%kde_save = 0
+  END SUBROUTINE ioesmf_nullify_grid
+
+
+!$$$here...  use generic explicit interfaces?  if not, why not?  
+ !$$$ remove duplication!
+ SUBROUTINE ioesmf_extract_data_real( data_esmf_real, Field,      &
+                                      ips, ipe, jps, jpe, kps, kpe, &
+                                      ims, ime, jms, jme, kms, kme )
+   USE module_ext_esmf
+   IMPLICIT NONE
+   INTEGER,            INTENT(IN   ) :: ips, ipe, jps, jpe, kps, kpe
+   INTEGER,            INTENT(IN   ) :: ims, ime, jms, jme, kms, kme
+   REAL(ESMF_KIND_R4), INTENT(IN   ) :: data_esmf_real( ips:ipe, jps:jpe )
+   REAL,               INTENT(  OUT) :: Field( ims:ime, jms:jme, kms:kme )
+   Field( ips:ipe, jps:jpe, kms ) = data_esmf_real( ips:ipe, jps:jpe )
+ END SUBROUTINE ioesmf_extract_data_real
+
+
+ !$$$ remove duplication!
+ SUBROUTINE ioesmf_extract_data_int( data_esmf_int, Field,         &
+                                     ips, ipe, jps, jpe, kps, kpe, &
+                                     ims, ime, jms, jme, kms, kme )
+   USE module_ext_esmf
+   IMPLICIT NONE
+   INTEGER,               INTENT(IN   ) :: ips, ipe, jps, jpe, kps, kpe
+   INTEGER,               INTENT(IN   ) :: ims, ime, jms, jme, kms, kme
+   INTEGER(ESMF_KIND_I4), INTENT(IN   ) :: data_esmf_int( ips:ipe, jps:jpe )
+   INTEGER,               INTENT(  OUT) :: Field( ims:ime, jms:jme, kms:kme )
+   Field( ips:ipe, jps:jpe, kms ) = data_esmf_int( ips:ipe, jps:jpe )
+ END SUBROUTINE ioesmf_extract_data_int
+
+
+ !$$$ remove duplication!
+ SUBROUTINE ioesmf_insert_data_real( Field, data_esmf_real,        &
+                                     ips, ipe, jps, jpe, kps, kpe, &
+                                     ims, ime, jms, jme, kms, kme )
+   USE module_ext_esmf
+   IMPLICIT NONE
+   INTEGER,               INTENT(IN   ) :: ips, ipe, jps, jpe, kps, kpe
+   INTEGER,               INTENT(IN   ) :: ims, ime, jms, jme, kms, kme
+   REAL,                  INTENT(IN   ) :: Field( ims:ime, jms:jme, kms:kme )
+   REAL(ESMF_KIND_R4),    INTENT(  OUT) :: data_esmf_real( ips:ipe, jps:jpe )
+   ! $$$ TBD:  Remove this hack once we no longer have to store non-staggered 
+   ! $$$ TBD:  arrays in space dimensioned for staggered arrays.  
+   data_esmf_real = 0.0_ESMF_KIND_R4
+   data_esmf_real( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
+ END SUBROUTINE ioesmf_insert_data_real
+
+
+ !$$$ remove duplication!
+ SUBROUTINE ioesmf_insert_data_int( Field, data_esmf_int,         &
+                                    ips, ipe, jps, jpe, kps, kpe, &
+                                    ims, ime, jms, jme, kms, kme )
+   USE module_ext_esmf
+   IMPLICIT NONE
+   INTEGER,               INTENT(IN   ) :: ips, ipe, jps, jpe, kps, kpe
+   INTEGER,               INTENT(IN   ) :: ims, ime, jms, jme, kms, kme
+   INTEGER,               INTENT(IN   ) :: Field( ims:ime, jms:jme, kms:kme )
+   INTEGER(ESMF_KIND_I4), INTENT(  OUT) :: data_esmf_int( ips:ipe, jps:jpe )
+   ! $$$ TBD:  Remove this hack once we no longer have to store non-staggered 
+   ! $$$ TBD:  arrays in space dimensioned for staggered arrays.  
+   data_esmf_int = 0.0_ESMF_KIND_I4
+   data_esmf_int( ips:ipe, jps:jpe ) = Field( ips:ipe, jps:jpe, kms )
+ END SUBROUTINE ioesmf_insert_data_int
+
+
+!--------------
+
+SUBROUTINE ext_esmf_ioinit( SysDepInfo, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  CHARACTER*(*), INTENT(IN) :: SysDepInfo
+  INTEGER Status
+  CALL init_module_ext_esmf
+  Status = 0 
+END SUBROUTINE ext_esmf_ioinit
+
+!--- open_for_read 
+SUBROUTINE ext_esmf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                    DataHandle , Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_open_for_read not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN  
+END SUBROUTINE ext_esmf_open_for_read
+
+
+!--- inquire_opened
+SUBROUTINE ext_esmf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = 0
+
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  begin, DataHandle = ', DataHandle
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  int_valid_handle(',DataHandle,') = ', &
+                 int_valid_handle( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  int_handle_in_use(',DataHandle,') = ', &
+                 int_handle_in_use( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  opened_for_read(',DataHandle,') = ', &
+                 opened_for_read( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  okay_to_read(',DataHandle,') = ', &
+                 okay_to_read( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  opened_for_write(',DataHandle,') = ', &
+                 opened_for_write( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  okay_to_write(',DataHandle,') = ', &
+                 okay_to_write( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+
+!$$$ need to cache file name and match with FileName argument and return 
+!$$$ FileStatus = WRF_FILE_NOT_OPENED if they do not match
+
+  FileStatus = WRF_FILE_NOT_OPENED
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      IF ( opened_for_read ( DataHandle ) ) THEN
+        IF ( okay_to_read( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_READ
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE IF ( opened_for_write( DataHandle ) ) THEN
+        IF ( okay_to_write( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_WRITE
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE
+        FileStatus = WRF_FILE_NOT_OPENED
+      ENDIF
+    ENDIF
+    WRITE( msg,* ) 'ERROR ext_esmf_inquire_opened:  file handle ',DataHandle,' is invalid'
+    CALL wrf_error_fatal ( TRIM(msg) )
+  ENDIF
+
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_opened:  end, FileStatus = ', FileStatus
+  CALL wrf_debug ( 5 , TRIM(msg) )
+
+  Status = 0
+  
+  RETURN
+END SUBROUTINE ext_esmf_inquire_opened
+
+!--- inquire_filename
+SUBROUTINE ext_esmf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER *80   SysDepInfo
+  Status = 0
+
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  begin, DataHandle = ', DataHandle
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  int_valid_handle(',DataHandle,') = ', &
+                 int_valid_handle( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  int_handle_in_use(',DataHandle,') = ', &
+                 int_handle_in_use( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  opened_for_read(',DataHandle,') = ', &
+                 opened_for_read( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  okay_to_read(',DataHandle,') = ', &
+                 okay_to_read( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  opened_for_write(',DataHandle,') = ', &
+                 opened_for_write( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  okay_to_write(',DataHandle,') = ', &
+                 okay_to_write( DataHandle )
+  CALL wrf_debug ( 5 , TRIM(msg) )
+
+!$$$ need to cache file name and return via FileName argument
+
+  FileStatus = WRF_FILE_NOT_OPENED
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      IF ( opened_for_read ( DataHandle ) ) THEN
+        IF ( okay_to_read( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_READ
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE IF ( opened_for_write( DataHandle ) ) THEN
+        IF ( okay_to_write( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_WRITE
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE
+        FileStatus = WRF_FILE_NOT_OPENED
+      ENDIF
+    ENDIF
+    WRITE( msg,* ) 'ERROR ext_esmf_inquire_filename:  file handle ',DataHandle,' is invalid'
+    CALL wrf_error_fatal ( TRIM(msg) )
+  ENDIF
+
+  WRITE( msg,* ) 'DEBUG ext_esmf_inquire_filename:  end, FileStatus = ', FileStatus
+  CALL wrf_debug ( 5 , TRIM(msg) )
+
+  Status = 0
+  RETURN
+END SUBROUTINE ext_esmf_inquire_filename
+
+!--- sync
+SUBROUTINE ext_esmf_iosync ( DataHandle, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  Status = 0
+  RETURN
+END SUBROUTINE ext_esmf_iosync
+
+!--- close
+SUBROUTINE ext_esmf_ioclose ( DataHandle, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER DataHandle, Status
+  ! locals
+  TYPE state_ptr
+    TYPE(ESMF_State), POINTER :: stateptr
+  END TYPE state_ptr
+  TYPE(state_ptr) :: states(2)
+  TYPE(ESMF_State), POINTER :: state
+  INTEGER :: numItems, numFields, i, istate
+  TYPE(ESMF_StateItemType), ALLOCATABLE :: itemTypes(:)
+  TYPE(ESMF_Field) :: tmpField
+  REAL, POINTER :: tmp_ptr(:,:)
+  CHARACTER (len=ESMF_MAXSTR), ALLOCATABLE :: itemNames(:)
+  CHARACTER (len=ESMF_MAXSTR) :: str
+  INTEGER :: rc
+
+! TODO:  The code below hangs with this error message:  
+! TODO:  "ext_esmf_ioclose:  ESMF_FieldGetDataPointer( LANDMASK) failed"
+! TODO:  Fix this so ESMF objects actually get destroyed to avoid memory 
+! TODO:  leaks and other extraordinary nastiness.  
+  CALL wrf_debug( 5, 'ext_esmf_ioclose:  WARNING:  not destroying ESMF objects' )
+#if 0
+  ! $$$ Need to upgrade this to use nested ESMF_States if we want support 
+  ! $$$ more than one auxin and one auxhist stream for ESMF.  
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      ! Iterate through importState *and* exportState, find each ESMF_Field, 
+      ! extract its data pointer and deallocate it, then destroy the 
+      ! ESMF_Field.  
+      CALL ESMF_ImportStateGetCurrent(states(1)%stateptr, rc)
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal( 'ext_esmf_ioclose:  ESMF_ImportStateGetCurrent failed' )
+      ENDIF
+      CALL ESMF_ExportStateGetCurrent(states(2)%stateptr, rc)
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        CALL wrf_error_fatal( 'ext_esmf_ioclose:  ESMF_ExportStateGetCurrent failed' )
+      ENDIF
+      DO istate=1, 2
+        state => states(istate)%stateptr   ! all this to avoid assignment (@#$%)
+        ! Since there are no convenient iterators for ESMF_State (@#$%),
+        ! write a lot of code...
+        ! Figure out how many items are in the ESMF_State
+        CALL ESMF_StateGet(state, itemCount=numItems, rc=rc)
+        IF ( rc /= ESMF_SUCCESS) THEN
+          CALL wrf_error_fatal ( 'ext_esmf_ioclose:  ESMF_StateGet(numItems) failed' )
+        ENDIF
+        ! allocate an array to hold the types of all items
+        ALLOCATE( itemTypes(numItems) )
+        ! allocate an array to hold the names of all items
+        ALLOCATE( itemNames(numItems) )
+        ! get the item types and names
+        CALL ESMF_StateGet(state, stateitemtypeList=itemTypes, &
+                           itemNameList=itemNames, rc=rc)
+        IF ( rc /= ESMF_SUCCESS) THEN
+          WRITE(str,*) 'ext_esmf_ioclose:  ESMF_StateGet itemTypes failed with rc = ', rc
+          CALL wrf_error_fatal ( str )
+        ENDIF
+        ! count how many items are ESMF_Fields
+        numFields = 0
+        DO i=1,numItems
+          IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
+            numFields = numFields + 1
+          ENDIF
+        ENDDO
+        IF ( numFields > 0) THEN
+          ! finally, extract nested ESMF_Fields by name, if there are any
+          ! (should be able to do this by index at least -- @#%$)
+          DO i=1,numItems
+            IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN
+              CALL ESMF_StateGetField( state, TRIM(itemNames(i)), &
+                                       tmpField, rc=rc )
+              IF ( rc /= ESMF_SUCCESS) THEN
+                WRITE(str,*) 'ext_esmf_ioclose:  ESMF_StateGetField(',TRIM(itemNames(i)),') failed'
+                CALL wrf_error_fatal ( str )
+              ENDIF
+              ! destroy pointer in field
+              CALL ESMF_FieldGetDataPointer( tmpField, tmp_ptr, rc=rc )
+              IF (rc /= ESMF_SUCCESS) THEN
+                WRITE( str , * )                                   &
+                  'ext_esmf_ioclose:  ESMF_FieldGetDataPointer( ', &
+                  TRIM(itemNames(i)),') failed'
+                CALL wrf_error_fatal ( TRIM(str) )
+              ENDIF
+              DEALLOCATE( tmp_ptr )
+              ! destroy field
+              CALL ESMF_FieldDestroy( tmpField, rc=rc )
+              IF (rc /= ESMF_SUCCESS) THEN
+                WRITE( str , * )                            &
+                  'ext_esmf_ioclose:  ESMF_FieldDestroy( ', &
+                  TRIM(itemNames(i)),') failed'
+                CALL wrf_error_fatal ( TRIM(str) )
+              ENDIF
+            ENDIF
+          ENDDO
+        ENDIF
+        ! deallocate locals
+        DEALLOCATE( itemTypes )
+        DEALLOCATE( itemNames )
+      ENDDO
+      ! destroy ESMF_Grid associated with DataHandle
+      CALL ioesmf_destroy_grid( DataHandle )
+    ENDIF
+  ENDIF
+#endif
+  Status = 0
+  RETURN
+END SUBROUTINE ext_esmf_ioclose
+
+!--- ioexit
+SUBROUTINE ext_esmf_ioexit( Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER :: i
+  Status = 0
+! TODO:  The code below causes ext_ncd_ioclose() to fail in the 
+! TODO:  SST component for reasons as-yet unknown.  
+! TODO:  Fix this so ESMF objects actually get destroyed to avoid memory 
+! TODO:  leaks and other extraordinary nastiness.  
+  CALL wrf_debug( 5, 'ext_esmf_ioexit:  WARNING:  not destroying ESMF objects' )
+#if 0
+  DO i = 1, int_num_handles
+    ! close any remaining open DataHandles
+    CALL ext_esmf_ioclose ( i, Status )
+    ! destroy ESMF_Grid for this DataHandle
+    CALL ioesmf_destroy_grid( i )
+  ENDDO
+  CALL wrf_debug ( 5 , &
+    'ext_esmf_ioexit:  DEBUG:  done cleaning up ESMF objects' )
+#endif
+  RETURN  
+END SUBROUTINE ext_esmf_ioexit
+
+!--- get_next_time
+SUBROUTINE ext_esmf_get_next_time ( DataHandle, DateStr, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_next_time: DataHandle not opened" )
+  ENDIF
+  CALL wrf_message( "ext_esmf_get_next_time() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_next_time
+
+!--- set_time
+SUBROUTINE ext_esmf_set_time ( DataHandle, DateStr, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message( "ext_esmf_set_time() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_set_time
+
+!--- get_var_info
+SUBROUTINE ext_esmf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
+                                   DomainStart , DomainEnd , WrfType, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: VarName
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)         ,intent(out)    :: Stagger
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_var_info: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_esmf.F90: ext_esmf_get_var_info: DataHandle not opened" )
+  ENDIF
+  CALL wrf_message( "ext_esmf_get_var_info() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_info
+
+!--- get_next_var
+SUBROUTINE ext_esmf_get_next_var ( DataHandle, VarName, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: VarName
+  INTEGER ,       INTENT(OUT) :: Status
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_esmf/io_esmf.F90: ext_esmf_get_next_var: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_esmf/io_esmf.F90: ext_esmf_get_next_var: DataHandle not opened" )
+  ENDIF
+  CALL wrf_message( "ext_esmf_get_next_var() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_next_var
+
+!--- get_dom_ti_real
+SUBROUTINE ext_esmf_get_dom_ti_real ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Outcount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message( "ext_esmf_get_dom_ti_real() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_ti_real 
+
+!--- put_dom_ti_real
+SUBROUTINE ext_esmf_put_dom_ti_real ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message( "ext_esmf_put_dom_ti_real() not supported yet")
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_ti_real 
+
+!--- get_dom_ti_double
+SUBROUTINE ext_esmf_get_dom_ti_double ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_ti_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_ti_double 
+
+!--- put_dom_ti_double
+SUBROUTINE ext_esmf_put_dom_ti_double ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_ti_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_ti_double 
+
+!--- get_dom_ti_integer
+SUBROUTINE ext_esmf_get_dom_ti_integer ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = 0
+  IF      ( Element == 'WEST-EAST_GRID_DIMENSION' ) THEN
+    Data(1) = grid( DataHandle )%ide_save
+    Outcount = 1
+  ELSE IF ( Element == 'SOUTH-NORTH_GRID_DIMENSION' ) THEN
+    Data(1) = grid( DataHandle )%jde_save
+    Outcount = 1
+  ELSE IF ( Element == 'BOTTOM-TOP_GRID_DIMENSION' ) THEN
+    Data(1) = grid( DataHandle )%kde_save
+    Outcount = 1
+  ELSE
+    CALL wrf_message('ext_esmf_get_dom_ti_integer not fully supported yet')
+    Status = WRF_WARN_NOTSUPPORTED
+  ENDIF
+
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_ti_integer 
+
+!--- put_dom_ti_integer
+SUBROUTINE ext_esmf_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  INTEGER ,       INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_ti_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_ti_integer 
+
+!--- get_dom_ti_logical
+SUBROUTINE ext_esmf_get_dom_ti_logical ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_ti_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_ti_logical 
+
+!--- put_dom_ti_logical
+SUBROUTINE ext_esmf_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_ti_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_ti_logical 
+
+!--- get_dom_ti_char
+SUBROUTINE ext_esmf_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_ti_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_ti_char 
+
+!--- put_dom_ti_char
+SUBROUTINE ext_esmf_put_dom_ti_char ( DataHandle, Element,  Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_ti_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_ti_char 
+
+!--- get_dom_td_real
+SUBROUTINE ext_esmf_get_dom_td_real ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_td_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_td_real 
+
+!--- put_dom_td_real
+SUBROUTINE ext_esmf_put_dom_td_real ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_td_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_td_real 
+
+!--- get_dom_td_double
+SUBROUTINE ext_esmf_get_dom_td_double ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_td_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_td_double 
+
+!--- put_dom_td_double
+SUBROUTINE ext_esmf_put_dom_td_double ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_td_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_td_double 
+
+!--- get_dom_td_integer
+SUBROUTINE ext_esmf_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_td_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_td_integer 
+
+!--- put_dom_td_integer
+SUBROUTINE ext_esmf_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_td_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_td_integer 
+
+!--- get_dom_td_logical
+SUBROUTINE ext_esmf_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_td_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_td_logical 
+
+!--- put_dom_td_logical
+SUBROUTINE ext_esmf_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_td_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_td_logical 
+
+!--- get_dom_td_char
+SUBROUTINE ext_esmf_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_dom_td_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_dom_td_char 
+
+!--- put_dom_td_char
+SUBROUTINE ext_esmf_put_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_dom_td_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_dom_td_char 
+
+!--- get_var_ti_real
+SUBROUTINE ext_esmf_get_var_ti_real ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_ti_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_ti_real 
+
+!--- put_var_ti_real
+SUBROUTINE ext_esmf_put_var_ti_real ( DataHandle,Element,  Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_ti_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_ti_real 
+
+!--- get_var_ti_double
+SUBROUTINE ext_esmf_get_var_ti_double ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_ti_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_ti_double 
+
+!--- put_var_ti_double
+SUBROUTINE ext_esmf_put_var_ti_double ( DataHandle,Element,  Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_ti_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_ti_double 
+
+!--- get_var_ti_integer
+SUBROUTINE ext_esmf_get_var_ti_integer ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_ti_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_ti_integer 
+
+!--- put_var_ti_integer
+SUBROUTINE ext_esmf_put_var_ti_integer ( DataHandle,Element,  Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_ti_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_ti_integer 
+
+!--- get_var_ti_logical
+SUBROUTINE ext_esmf_get_var_ti_logical ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_ti_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_ti_logical 
+
+!--- put_var_ti_logical
+SUBROUTINE ext_esmf_put_var_ti_logical ( DataHandle,Element,  Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_ti_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_ti_logical 
+
+!--- get_var_ti_char
+SUBROUTINE ext_esmf_get_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER locDataHandle, code
+  CHARACTER*132 locElement, locVarName
+  CALL wrf_message('ext_esmf_get_var_ti_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_ti_char 
+
+!--- put_var_ti_char
+SUBROUTINE ext_esmf_put_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  INTEGER                 :: Count
+  CALL wrf_message('ext_esmf_put_var_ti_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_ti_char 
+
+!--- get_var_td_real
+SUBROUTINE ext_esmf_get_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_td_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_td_real 
+
+!--- put_var_td_real
+SUBROUTINE ext_esmf_put_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_td_real not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_td_real 
+
+!--- get_var_td_double
+SUBROUTINE ext_esmf_get_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_td_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_td_double 
+
+!--- put_var_td_double
+SUBROUTINE ext_esmf_put_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_td_double not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_td_double 
+
+!--- get_var_td_integer
+SUBROUTINE ext_esmf_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_td_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_td_integer 
+
+!--- put_var_td_integer
+SUBROUTINE ext_esmf_put_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_td_integer not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_td_integer 
+
+!--- get_var_td_logical
+SUBROUTINE ext_esmf_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_td_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_td_logical 
+
+!--- put_var_td_logical
+SUBROUTINE ext_esmf_put_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_td_logical not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_td_logical 
+
+!--- get_var_td_char
+SUBROUTINE ext_esmf_get_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_get_var_td_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_get_var_td_char 
+
+!--- put_var_td_char
+SUBROUTINE ext_esmf_put_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  USE module_ext_esmf
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_esmf_put_var_td_char not supported yet')
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_esmf_put_var_td_char 
+
+
diff --git a/wrfv2_fire/external/io_esmf/makefile b/wrfv2_fire/external/io_esmf/makefile
new file mode 100644
index 00000000..d919ad7e
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/makefile
@@ -0,0 +1,41 @@
+# these settings for compiling standalone on Compaq. Type "make -r"
+#CPP = /lib/cpp 
+#FC  = f90 -free
+
+.SUFFIXES: .F90 .o
+
+AR = ar
+#RANLIB	= ranlib
+RANLIB	= echo
+
+OBJS = module_symbols_util.o \
+       module_esmf_extensions.o \
+       module_utility.o \
+       io_esmf.o \
+       ext_esmf_open_for_read.o \
+       ext_esmf_open_for_write.o \
+       ext_esmf_read_field.o \
+       ext_esmf_write_field.o
+
+TARGET = libwrfio_esmf.a
+
+$(TARGET) : $(OBJS)
+	$(AR) ru $(TARGET) $(OBJS)
+	$(RANLIB) $(TARGET)
+
+.F90.o :
+	$(CPP) -I../ioapi_share -C -P -DESMF_COUPLING $*.F90 > $*.f
+	$(FC) -c -g -I../ioapi_share $*.f
+
+superclean: 
+	/bin/rm -f *.f *.o $(TARGET) *.mod
+
+# DEPENDENCIES : only dependencies after this line 
+
+module_utility.o : module_symbols_util.o module_esmf_extensions.o
+io_esmf.o : module_esmf_extensions.o
+ext_esmf_open_for_read.o : io_esmf.o
+ext_esmf_open_for_write.o : io_esmf.o
+ext_esmf_read_field.o : io_esmf.o
+ext_esmf_write_field.o : io_esmf.o
+
diff --git a/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90 b/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90
new file mode 100644
index 00000000..ac0c5d30
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90
@@ -0,0 +1,537 @@
+
+! "module_esmf_extensions" is responsible for yet-to-be-implemented ESMF 
+! features used by the io_esmf package.  Once ESMF development is complete, 
+! this module may be removed.  
+
+! NOTE for implementation of ESMF_*GetCurrent():  
+!
+! This implementation uses interfaces that pass Fortran POINTERs around 
+! to avoid forcing use of overloaded assignment operators for shallow 
+! copies.  The goal of this approach is to be as insulated as possible 
+! from ESMF object implementations.  This avoids having to explicitly 
+! copy-in *AND* copy-out through the standard component init(), run(), 
+! and final() interfaces just to attach references to ESMF objects to 
+! other objects.  The explicit CICO *might* be required if we 
+! instead attached shallow copies of the objects to other objects!  
+! "Might" means it is not required now because ESMF objects are 
+! implemented as simple pointers.  However, Nancy Collins says that 
+! the ESMF core team plans to add more state on the Fortran side of the 
+! ESMF objects, so copy-out will eventually be required.  Thus we use 
+! POINTERs to attach references, as in other languages.  Why ESMF 
+! component interfaces aren't passing POINTERs to Fortran objects is 
+! not clear (TBH)...  
+!
+
+MODULE module_esmf_extensions
+
+  USE ESMF_Mod
+
+  IMPLICIT NONE
+
+  PRIVATE
+
+
+  ! private data
+
+  ! Data for ESMF_*GetCurrent()
+  ! These flags are set to .TRUE. iff current objects are valid.  
+  LOGICAL, SAVE                :: current_clock_valid = .FALSE.
+  TYPE(ESMF_Clock), POINTER    :: current_clock
+  LOGICAL, SAVE                :: current_importstate_valid = .FALSE.
+  TYPE(ESMF_State), POINTER    :: current_importstate
+  LOGICAL, SAVE                :: current_exportstate_valid = .FALSE.
+  TYPE(ESMF_State), POINTER    :: current_exportstate
+  LOGICAL, SAVE                :: current_gridcomp_valid = .FALSE.
+  TYPE(ESMF_GridComp), POINTER :: current_gridcomp
+
+  ! Flag for "is-initialized" inquiry
+  ! NOTE:  esmf_is_initialized is not reset to .FALSE. when ESMF_Finalize is called
+  LOGICAL, SAVE                :: esmf_is_initialized = .FALSE.
+
+
+  ! public routines
+  ! These convenience interfaces have been proposed to the ESMF core team.  
+  ! "get current" variants
+  PUBLIC ESMF_ClockGetCurrent
+  PUBLIC ESMF_ImportStateGetCurrent
+  PUBLIC ESMF_ExportStateGetCurrent
+  PUBLIC ESMF_GridCompGetCurrent
+  ! "is-initialized" inquiry
+  PUBLIC WRFU_IsInitialized
+
+  ! extensions to standard ESMF interfaces
+  ! these extensions conform to documented plans for ESMF extensions
+  ! they should be removed as ESMF implementations are released
+  PUBLIC WRFU_TimeGet
+
+  ! public routines to be replaced by ESMF internal implementations
+  ! These interfaces will not be public because ESMF will always be able 
+  ! to call them in the right places without user intervention.  
+  ! "get current" variants
+  PUBLIC ESMF_ClockSetCurrent
+  PUBLIC ESMF_ImportStateSetCurrent
+  PUBLIC ESMF_ExportStateSetCurrent
+  PUBLIC ESMF_GridCompSetCurrent
+  PUBLIC ESMF_SetCurrent
+  ! "is-initialized" inquiry
+  PUBLIC ESMF_SetInitialized
+
+!!!!!!!!! added 20051012, JM
+  ! Need to request that this interface be added...  
+  PUBLIC WRFU_TimeIntervalDIVQuot
+
+  ! duplicated routines from esmf_time_f90
+  ! move these to a common shared location later...  
+  PUBLIC fraction_to_string
+
+  ! hack for bug in PGI 5.1-x
+  PUBLIC ESMF_TimeLE
+  PUBLIC ESMF_TimeGE
+
+  ! convenience function
+  PUBLIC ESMF_TimeIntervalIsPositive
+
+CONTAINS
+
+
+! Add "is initialized" behavior to ESMF interface
+  FUNCTION WRFU_IsInitialized()
+    LOGICAL WRFU_IsInitialized
+    WRFU_IsInitialized = esmf_is_initialized
+  END FUNCTION WRFU_IsInitialized
+
+! Add "is initialized" behavior to ESMF interface
+! This interface will go away as it will be done inside ESMF_Initialize().  
+  SUBROUTINE ESMF_SetInitialized()
+    esmf_is_initialized = .TRUE.
+  END SUBROUTINE ESMF_SetInitialized
+
+
+
+! -------------------------- ESMF-public method -------------------------------
+!BOP
+! !IROUTINE: ESMF_ClockGetCurrent - Get current ESMF_Clock
+! !INTERFACE:
+  SUBROUTINE ESMF_ClockGetCurrent(clock, rc)
+! !ARGUMENTS:
+    TYPE(ESMF_Clock), POINTER      :: clock
+    INTEGER, INTENT(OUT), OPTIONAL :: rc
+!
+! !DESCRIPTION:
+!   Get the {\tt ESMF\_Clock} object of the current execution context.
+!
+!   The arguments are:
+!   \begin{description}
+!   \item[clock]
+!     Upon return this holds the {\tt ESMF\_Clock} object of the current context.
+!   \item[{[rc]}]
+!     Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!   \end{description}
+!
+!EOP
+! !REQUIREMENTS:  SSSn.n, GGGn.n
+!------------------------------------------------------------------------------
+    ! Assume failure until success
+    IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+    IF ( current_clock_valid ) THEN
+      clock => current_clock
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    ENDIF
+  END SUBROUTINE ESMF_ClockGetCurrent
+!------------------------------------------------------------------------------
+
+
+
+! -------------------------- ESMF-public method -------------------------------
+!BOP
+! !IROUTINE: ESMF_ImportStateGetCurrent - Get current import ESMF_State
+! !INTERFACE:
+  SUBROUTINE ESMF_ImportStateGetCurrent(importstate, rc)
+! !ARGUMENTS:
+    TYPE(ESMF_State), POINTER      :: importstate
+    INTEGER, INTENT(OUT), OPTIONAL :: rc
+!
+! !DESCRIPTION:
+!   Get the import {\tt ESMF\_State} object of the current execution context.
+!
+!   The arguments are:
+!   \begin{description}
+!   \item[importstate]
+!     Upon return this holds the import {\tt ESMF\_State} object of the current context.
+!   \item[{[rc]}]
+!     Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!   \end{description}
+!
+!EOP
+! !REQUIREMENTS:  SSSn.n, GGGn.n
+!------------------------------------------------------------------------------
+    ! Assume failure until success
+    IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+    IF ( current_importstate_valid ) THEN
+      importstate => current_importstate
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    ENDIF
+  END SUBROUTINE ESMF_ImportStateGetCurrent
+!------------------------------------------------------------------------------
+
+
+
+! -------------------------- ESMF-public method -------------------------------
+!BOP
+! !IROUTINE: ESMF_ExportStateGetCurrent - Get current export ESMF_State
+! !INTERFACE:
+  SUBROUTINE ESMF_ExportStateGetCurrent(exportstate, rc)
+! !ARGUMENTS:
+    TYPE(ESMF_State), POINTER      :: exportstate
+    INTEGER, INTENT(OUT), OPTIONAL :: rc
+!
+! !DESCRIPTION:
+!   Get the export {\tt ESMF\_State} object of the current execution context.
+!
+!   The arguments are:
+!   \begin{description}
+!   \item[exportstate]
+!     Upon return this holds the export {\tt ESMF\_State} object of the current context.
+!   \item[{[rc]}]
+!     Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!   \end{description}
+!
+!EOP
+! !REQUIREMENTS:  SSSn.n, GGGn.n
+!------------------------------------------------------------------------------
+    ! Assume failure until success
+    IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+    IF ( current_exportstate_valid ) THEN
+      exportstate => current_exportstate
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    ENDIF
+  END SUBROUTINE ESMF_ExportStateGetCurrent
+!------------------------------------------------------------------------------
+
+
+
+! -------------------------- ESMF-public method -------------------------------
+!BOP
+! !IROUTINE: ESMF_GridCompGetCurrent - Get current ESMF_GridComp
+! !INTERFACE:
+  SUBROUTINE ESMF_GridCompGetCurrent(gridcomp, rc)
+! !ARGUMENTS:
+    TYPE(ESMF_GridComp), POINTER   :: gridcomp
+    INTEGER, INTENT(OUT), OPTIONAL :: rc
+!
+! !DESCRIPTION:
+!   Get the {\tt ESMF\_GridComp} object of the current execution context.
+!
+!   The arguments are:
+!   \begin{description}
+!   \item[gridcomp]
+!     Upon return this holds the {\tt ESMF\_GridComp} object of the current context.
+!   \item[{[rc]}]
+!     Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
+!   \end{description}
+!
+!EOP
+! !REQUIREMENTS:  SSSn.n, GGGn.n
+!------------------------------------------------------------------------------
+    ! Assume failure until success
+    IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+    IF ( current_gridcomp_valid ) THEN
+      gridcomp => current_gridcomp
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+    ENDIF
+  END SUBROUTINE ESMF_GridCompGetCurrent
+!------------------------------------------------------------------------------
+
+
+
+
+! Temporary method, to be replaced by ESMF internal implementation
+! Sets the current ESMF_Clock to clock.  
+  SUBROUTINE ESMF_ClockSetCurrent(clock)
+    TYPE(ESMF_Clock), POINTER :: clock
+    current_clock => clock
+    current_clock_valid = .TRUE.
+  END SUBROUTINE ESMF_ClockSetCurrent
+!------------------------------------------------------------------------------
+
+
+! Temporary method, to be replaced by ESMF internal implementation
+! Sets the current import ESMF_State to importstate.  
+  SUBROUTINE ESMF_ImportStateSetCurrent(importstate)
+    TYPE(ESMF_State), POINTER :: importstate
+    current_importstate => importstate
+    current_importstate_valid = .TRUE.
+  END SUBROUTINE ESMF_ImportStateSetCurrent
+!------------------------------------------------------------------------------
+
+
+! Temporary method, to be replaced by ESMF internal implementation
+! Sets the current export ESMF_State to exportstate.  
+  SUBROUTINE ESMF_ExportStateSetCurrent(exportstate)
+    TYPE(ESMF_State), POINTER :: exportstate
+    current_exportstate => exportstate
+    current_exportstate_valid = .TRUE.
+  END SUBROUTINE ESMF_ExportStateSetCurrent
+!------------------------------------------------------------------------------
+
+
+! Temporary method, to be replaced by ESMF internal implementation
+! Sets the current ESMF_GridComp to gridcomp.  
+  SUBROUTINE ESMF_GridCompSetCurrent(gridcomp)
+    TYPE(ESMF_GridComp), POINTER :: gridcomp
+    current_gridcomp => gridcomp
+    current_gridcomp_valid = .TRUE.
+  END SUBROUTINE ESMF_GridCompSetCurrent
+!------------------------------------------------------------------------------
+
+
+! Temporary method, to be replaced by ESMF internal implementation
+! Convenience interface to set everything at once...  
+  ! This routine sets the current ESMF_GridComp, import and export
+  ! ESMF_States, and the current ESMF_Clock.
+  ! NOTE:  It will be possible to remove this routine once ESMF supports
+  !        interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(),
+  !        ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent().
+  SUBROUTINE ESMF_SetCurrent( gcomp, importState, exportState, clock )
+    TYPE(ESMF_GridComp), OPTIONAL, POINTER :: gcomp
+    TYPE(ESMF_State),    OPTIONAL, POINTER :: importState
+    TYPE(ESMF_State),    OPTIONAL, POINTER :: exportState
+    TYPE(ESMF_Clock),    OPTIONAL, POINTER :: clock
+    IF ( PRESENT( gcomp ) ) THEN
+      CALL ESMF_GridCompSetCurrent( gcomp )
+      CALL ESMF_ImportStateSetCurrent( importState )
+      CALL ESMF_ExportStateSetCurrent( exportState )
+      CALL ESMF_ClockSetCurrent( clock )
+    ENDIF
+  END SUBROUTINE ESMF_SetCurrent
+!------------------------------------------------------------------------------
+
+
+
+! begin hack for bug in PGI 5.1-x
+  function ESMF_TimeLE(time1, time2)
+    logical :: ESMF_TimeLE
+    type(ESMF_Time), intent(in) :: time1
+    type(ESMF_Time), intent(in) :: time2
+    ESMF_TimeLE = (time1.LE.time2)
+  end function ESMF_TimeLE
+  function ESMF_TimeGE(time1, time2)
+    logical :: ESMF_TimeGE
+    type(ESMF_Time), intent(in) :: time1
+    type(ESMF_Time), intent(in) :: time2
+    ESMF_TimeGE = (time1.GE.time2)
+  end function ESMF_TimeGE
+! end hack for bug in PGI 5.1-x
+
+! convenience function
+  function ESMF_TimeIntervalIsPositive(timeinterval)
+    logical :: ESMF_TimeIntervalIsPositive
+    type(ESMF_TimeInterval), intent(in) :: timeinterval
+    type(ESMF_TimeInterval) :: zerotimeint
+    integer :: rcint
+    CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint )
+    ESMF_TimeIntervalIsPositive = (timeinterval .GT. zerotimeint)
+  end function ESMF_TimeIntervalIsPositive
+
+
+
+
+! Note:  this implementation is largely duplicated from external/esmf_time_f90
+!!!!!!!!!!!!!!!!!! added jm 20051012
+! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder
+      function WRFU_TimeIntervalDIVQuot(timeinterval1, timeinterval2)
+
+! !RETURN VALUE:
+      INTEGER :: WRFU_TimeIntervalDIVQuot
+
+! !ARGUMENTS:
+      type(ESMF_TimeInterval), intent(in) :: timeinterval1
+      type(ESMF_TimeInterval), intent(in) :: timeinterval2
+
+! !LOCAL
+      INTEGER :: retval, isgn, rc
+      type(ESMF_TimeInterval) :: zero, i1,i2
+
+! !DESCRIPTION:
+!     Returns timeinterval1 divided by timeinterval2 as a fraction quotient.
+!
+!     The arguments are:
+!     \begin{description}
+!     \item[timeinterval1]
+!          The dividend
+!     \item[timeinterval2]
+!          The divisor
+!     \end{description}
+!
+! !REQUIREMENTS:
+!     TMG1.5.5
+!EOP
+      call ESMF_TimeIntervalSet( zero, rc=rc )
+      i1 = timeinterval1
+      i2 = timeinterval2
+      isgn = 1
+      if ( i1 .LT. zero ) then
+        i1 = i1 * (-1)
+        isgn = -isgn
+      endif
+      if ( i2 .LT. zero ) then
+        i2 = i2 * (-1)
+        isgn = -isgn
+      endif
+! repeated subtraction
+      retval = 0
+      DO WHILE (  i1 .GE. i2 )
+        i1 = i1 - i2
+        retval = retval + 1
+      ENDDO
+      retval = retval * isgn
+
+      WRFU_TimeIntervalDIVQuot = retval
+
+      end function WRFU_TimeIntervalDIVQuot
+!!!!!!!!!!!!!!!!!!
+
+
+
+  ! implementations of extensions to standard ESMF interfaces
+  ! these extensions conform to documented plans for ESMF extensions
+  ! they should be removed as ESMF implementations are released
+
+      ! extend ESMF_TimeGet() to make dayOfYear_r8 work...  
+      subroutine WRFU_TimeGet(time, yy, yy_i8, &
+                                    mm, dd, &
+                                    d, d_i8, &
+                                    h, m, &
+                                    s, s_i8, &
+                                    ms, us, ns, &
+                                    d_r8, h_r8, m_r8, s_r8, &
+                                    ms_r8, us_r8, ns_r8, &
+                                    sN, sD, &
+                                    calendar, calendarType, timeZone, &
+                                    timeString, timeStringISOFrac, &
+                                    dayOfWeek, midMonth, &
+                                    dayOfYear,  dayOfYear_r8, &
+                                    dayOfYear_intvl, rc)
+
+      type(ESMF_Time),         intent(in)            :: time
+      integer(ESMF_KIND_I4),   intent(out), optional :: yy
+      integer(ESMF_KIND_I8),   intent(out), optional :: yy_i8
+      integer,                 intent(out), optional :: mm
+      integer,                 intent(out), optional :: dd
+      integer(ESMF_KIND_I4),   intent(out), optional :: d
+      integer(ESMF_KIND_I8),   intent(out), optional :: d_i8
+      integer(ESMF_KIND_I4),   intent(out), optional :: h
+      integer(ESMF_KIND_I4),   intent(out), optional :: m
+      integer(ESMF_KIND_I4),   intent(out), optional :: s
+      integer(ESMF_KIND_I8),   intent(out), optional :: s_i8
+      integer(ESMF_KIND_I4),   intent(out), optional :: ms
+      integer(ESMF_KIND_I4),   intent(out), optional :: us
+      integer(ESMF_KIND_I4),   intent(out), optional :: ns
+      real(ESMF_KIND_R8),      intent(out), optional :: d_r8  ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: h_r8  ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: m_r8  ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: s_r8  ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: ms_r8 ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: us_r8 ! not implemented
+      real(ESMF_KIND_R8),      intent(out), optional :: ns_r8 ! not implemented
+      integer(ESMF_KIND_I4),   intent(out), optional :: sN
+      integer(ESMF_KIND_I4),   intent(out), optional :: sD
+      type(ESMF_Calendar),     intent(out), optional :: calendar
+      type(ESMF_CalendarType), intent(out), optional :: calendarType
+      integer,                 intent(out), optional :: timeZone
+      character (len=*),       intent(out), optional :: timeString
+      character (len=*),       intent(out), optional :: timeStringISOFrac
+      integer,                 intent(out), optional :: dayOfWeek
+      type(ESMF_Time),         intent(out), optional :: midMonth
+      integer(ESMF_KIND_I4),   intent(out), optional :: dayOfYear
+      real(ESMF_KIND_R8),      intent(out), optional :: dayOfYear_r8 ! NOW implemented
+      type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl
+      integer,                 intent(out), optional :: rc
+      REAL(ESMF_KIND_R8) :: rsec
+      INTEGER(ESMF_KIND_I4) :: year, seconds, Sn, Sd
+      INTEGER(ESMF_KIND_I8), PARAMETER :: SECONDS_PER_DAY = 86400_ESMF_KIND_I8
+
+      call ESMF_TimeGet(time, yy, yy_i8, &
+                              mm, dd, &
+                              d, d_i8, &
+                              h, m, &
+                              s, s_i8, &
+                              ms, us, ns, &
+                              d_r8, h_r8, m_r8, s_r8, &
+                              ms_r8, us_r8, ns_r8, &
+                              sN, sD, &
+                              calendar, calendarType, timeZone, &
+                              timeString, timeStringISOFrac, &
+                              dayOfWeek, midMonth, &
+                              dayOfYear,  dayOfYear_r8, &
+                              dayOfYear_intvl, rc)
+      IF ( rc == ESMF_SUCCESS ) THEN
+        IF ( PRESENT( dayOfYear_r8 ) ) THEN
+          ! get seconds since start of year and fractional seconds
+          CALL ESMF_TimeGet( time, yy=year, s=seconds, sN=Sn, sD=Sd, rc=rc )
+          IF ( rc == ESMF_SUCCESS ) THEN
+            ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold
+            ! number of seconds in a year...
+            rsec = REAL( seconds, ESMF_KIND_R8 )
+            IF ( Sd /= 0 ) THEN
+              rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) )
+            ENDIF
+            dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 )
+            ! start at 1
+            dayOfYear_r8 = dayOfYear_r8 + 1.0_ESMF_KIND_R8
+          ENDIF
+        ENDIF
+      ENDIF
+
+      end subroutine WRFU_TimeGet
+
+!------------------------------------------------------------------------------
+
+
+! duplicated routines from esmf_time_f90
+! move these to a common shared location later...  
+
+! Convert fraction to string with leading sign.
+! If fraction simplifies to a whole number or if
+! denominator is zero, return empty string.
+! INTEGER*8 interface.  
+SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
+  INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
+  CHARACTER (LEN=*), INTENT(OUT) :: frac_str
+  IF ( denominator > 0 ) THEN
+    IF ( mod( numerator, denominator ) /= 0 ) THEN
+      IF ( numerator > 0 ) THEN
+        WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
+      ELSE   ! numerator < 0
+        WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
+      ENDIF
+    ELSE   ! includes numerator == 0 case
+      frac_str = ''
+    ENDIF
+  ELSE   ! no-fraction case
+    frac_str = ''
+  ENDIF
+END SUBROUTINE fraction_to_stringi8
+
+
+! Convert fraction to string with leading sign.
+! If fraction simplifies to a whole number or if
+! denominator is zero, return empty string.
+! INTEGER interface.  
+SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
+  INTEGER, INTENT(IN) :: numerator
+  INTEGER, INTENT(IN) :: denominator
+  CHARACTER (LEN=*), INTENT(OUT) :: frac_str
+  ! locals
+  INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
+  numerator_i8 = INT( numerator, ESMF_KIND_I8 )
+  denominator_i8 = INT( denominator, ESMF_KIND_I8 )
+  CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
+END SUBROUTINE fraction_to_string
+
+! end of duplicated routines from esmf_time_f90
+
+
+END MODULE module_esmf_extensions
+
diff --git a/wrfv2_fire/external/io_esmf/module_symbols_util.F90 b/wrfv2_fire/external/io_esmf/module_symbols_util.F90
new file mode 100644
index 00000000..231171a7
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/module_symbols_util.F90
@@ -0,0 +1,132 @@
+! 
+! NOTE:  This file will be removed once encapsulation of bare ESMF 
+!        calls is complete within WRF non-external source code.  
+!
+      MODULE module_symbols_util
+
+        USE ESMF_Mod, WRFU_ALARM => ESMF_ALARM
+        USE ESMF_Mod, WRFU_ALARMCREATE => ESMF_ALARMCREATE
+        USE ESMF_Mod, WRFU_ALARMDESTROY => ESMF_ALARMDESTROY
+        USE ESMF_Mod, WRFU_ALARMDISABLE => ESMF_ALARMDISABLE
+        USE ESMF_Mod, WRFU_ALARMENABLE => ESMF_ALARMENABLE
+        USE ESMF_Mod, WRFU_ALARMGET => ESMF_ALARMGET
+        USE ESMF_Mod, WRFU_ALARMISENABLED => ESMF_ALARMISENABLED
+        USE ESMF_Mod, WRFU_ALARMISRINGING => ESMF_ALARMISRINGING
+        USE ESMF_Mod, WRFU_ALARMISSTICKY => ESMF_ALARMISSTICKY
+        USE ESMF_Mod, WRFU_ALARMLISTTYPE => ESMF_ALARMLISTTYPE
+        USE ESMF_Mod, WRFU_ALARMLIST_ALL => ESMF_ALARMLIST_ALL
+        USE ESMF_Mod, WRFU_ALARMLIST_NEXTRINGING => ESMF_ALARMLIST_NEXTRINGING
+        USE ESMF_Mod, WRFU_ALARMLIST_PREVRINGING => ESMF_ALARMLIST_PREVRINGING
+        USE ESMF_Mod, WRFU_ALARMLIST_RINGING => ESMF_ALARMLIST_RINGING
+        USE ESMF_Mod, WRFU_ALARMNOTSTICKY => ESMF_ALARMNOTSTICKY
+        USE ESMF_Mod, WRFU_ALARMPRINT => ESMF_ALARMPRINT
+        USE ESMF_Mod, WRFU_ALARMREADRESTART => ESMF_ALARMREADRESTART
+        USE ESMF_Mod, WRFU_ALARMRINGEROFF => ESMF_ALARMRINGEROFF
+        USE ESMF_Mod, WRFU_ALARMRINGERON => ESMF_ALARMRINGERON
+        USE ESMF_Mod, WRFU_ALARMSET => ESMF_ALARMSET
+        USE ESMF_Mod, WRFU_ALARMSTICKY => ESMF_ALARMSTICKY
+        USE ESMF_Mod, WRFU_ALARMVALIDATE => ESMF_ALARMVALIDATE
+        USE ESMF_Mod, WRFU_ALARMWASPREVRINGING => ESMF_ALARMWASPREVRINGING
+        USE ESMF_Mod, WRFU_ALARMWILLRINGNEXT => ESMF_ALARMWILLRINGNEXT
+        USE ESMF_Mod, WRFU_ALARMWRITERESTART => ESMF_ALARMWRITERESTART
+
+        USE ESMF_Mod, WRFU_CALENDAR => ESMF_CALENDAR
+        USE ESMF_Mod, WRFU_CALENDARCREATE => ESMF_CALENDARCREATE
+        USE ESMF_Mod, WRFU_CALENDARDESTROY => ESMF_CALENDARDESTROY
+        USE ESMF_Mod, WRFU_CALENDARFINALIZE => ESMF_CALENDARFINALIZE
+        USE ESMF_Mod, WRFU_CALENDARGET => ESMF_CALENDARGET
+        USE ESMF_Mod, WRFU_CALENDARINITIALIZE => ESMF_CALENDARINITIALIZE
+        USE ESMF_Mod, WRFU_CALENDARISLEAPYEAR => ESMF_CALENDARISLEAPYEAR
+        USE ESMF_Mod, WRFU_CALENDARPRINT => ESMF_CALENDARPRINT
+        USE ESMF_Mod, WRFU_CALENDARREADRESTART => ESMF_CALENDARREADRESTART
+        USE ESMF_Mod, WRFU_CALENDARSET => ESMF_CALENDARSET
+        USE ESMF_Mod, WRFU_CALENDARSETDEFAULT => ESMF_CALENDARSETDEFAULT
+        USE ESMF_Mod, WRFU_CALENDARTYPE => ESMF_CALENDARTYPE
+        USE ESMF_Mod, WRFU_CALENDARVALIDATE => ESMF_CALENDARVALIDATE
+        USE ESMF_Mod, WRFU_CALENDARWRITERESTART => ESMF_CALENDARWRITERESTART
+        USE ESMF_Mod, WRFU_CAL_360DAY => ESMF_CAL_360DAY
+        USE ESMF_Mod, WRFU_CAL_CUSTOM => ESMF_CAL_CUSTOM
+        USE ESMF_Mod, WRFU_CAL_GREGORIAN => ESMF_CAL_GREGORIAN
+        USE ESMF_Mod, WRFU_CAL_JULIAN => ESMF_CAL_JULIAN
+        USE ESMF_Mod, WRFU_CAL_JULIANDAY => ESMF_CAL_JULIANDAY
+        USE ESMF_Mod, WRFU_CAL_NOCALENDAR => ESMF_CAL_NOCALENDAR
+        USE ESMF_Mod, WRFU_CAL_NOLEAP => ESMF_CAL_NOLEAP
+        USE ESMF_Mod, WRFU_CLOCK => ESMF_CLOCK
+        USE ESMF_Mod, WRFU_CLOCKADVANCE => ESMF_CLOCKADVANCE
+        USE ESMF_Mod, WRFU_CLOCKCREATE => ESMF_CLOCKCREATE
+        USE ESMF_Mod, WRFU_CLOCKDESTROY => ESMF_CLOCKDESTROY
+        USE ESMF_Mod, WRFU_CLOCKGET => ESMF_CLOCKGET
+        USE ESMF_Mod, WRFU_CLOCKGETALARM => ESMF_CLOCKGETALARM
+        USE ESMF_Mod, WRFU_CLOCKGETALARMLIST => ESMF_CLOCKGETALARMLIST
+        USE ESMF_Mod, WRFU_CLOCKGETNEXTTIME => ESMF_CLOCKGETNEXTTIME
+        USE ESMF_Mod, WRFU_CLOCKISDONE => ESMF_CLOCKISDONE
+        USE ESMF_Mod, WRFU_CLOCKISREVERSE => ESMF_CLOCKISREVERSE
+        USE ESMF_Mod, WRFU_CLOCKISSTOPTIME => ESMF_CLOCKISSTOPTIME
+        USE ESMF_Mod, WRFU_CLOCKISSTOPTIMEENABLED => ESMF_CLOCKISSTOPTIMEENABLED
+        USE ESMF_Mod, WRFU_CLOCKPRINT => ESMF_CLOCKPRINT
+        USE ESMF_Mod, WRFU_CLOCKREADRESTART => ESMF_CLOCKREADRESTART
+        USE ESMF_Mod, WRFU_CLOCKSET => ESMF_CLOCKSET
+        USE ESMF_Mod, WRFU_CLOCKSTOPTIMEDISABLE => ESMF_CLOCKSTOPTIMEDISABLE
+        USE ESMF_Mod, WRFU_CLOCKSTOPTIMEENABLE => ESMF_CLOCKSTOPTIMEENABLE
+        USE ESMF_Mod, WRFU_CLOCKSYNCTOREALTIME => ESMF_CLOCKSYNCTOREALTIME
+        USE ESMF_Mod, WRFU_CLOCKVALIDATE => ESMF_CLOCKVALIDATE
+        USE ESMF_Mod, WRFU_CLOCKWRITERESTART => ESMF_CLOCKWRITERESTART
+        USE ESMF_Mod, WRFU_FINALIZE => ESMF_FINALIZE
+        USE ESMF_Mod, WRFU_INITIALIZE => ESMF_INITIALIZE
+        USE ESMF_Mod, WRFU_KIND_C16 => ESMF_KIND_C16
+        USE ESMF_Mod, WRFU_KIND_C8 => ESMF_KIND_C8
+        USE ESMF_Mod, WRFU_KIND_I1 => ESMF_KIND_I1
+        USE ESMF_Mod, WRFU_KIND_I2 => ESMF_KIND_I2
+        USE ESMF_Mod, WRFU_KIND_I4 => ESMF_KIND_I4
+        USE ESMF_Mod, WRFU_KIND_I8 => ESMF_KIND_I8
+        USE ESMF_Mod, WRFU_KIND_R4 => ESMF_KIND_R4
+        USE ESMF_Mod, WRFU_KIND_R8 => ESMF_KIND_R8
+        USE ESMF_Mod, WRFU_LOG => ESMF_LOG
+        USE ESMF_Mod, WRFU_LOGCLOSE => ESMF_LOGCLOSE
+        USE ESMF_Mod, WRFU_LOGFINALIZE => ESMF_LOGFINALIZE
+        USE ESMF_Mod, WRFU_LOGFLUSH => ESMF_LOGFLUSH
+        USE ESMF_Mod, WRFU_LOGFOUNDALLOCERROR => ESMF_LOGFOUNDALLOCERROR
+        USE ESMF_Mod, WRFU_LOGFOUNDERROR => ESMF_LOGFOUNDERROR
+        USE ESMF_Mod, WRFU_LOGGET => ESMF_LOGGET
+        USE ESMF_Mod, WRFU_LOGINITIALIZE => ESMF_LOGINITIALIZE
+        USE ESMF_Mod, WRFU_LOGMSGFOUNDALLOCERROR => ESMF_LOGMSGFOUNDALLOCERROR
+        USE ESMF_Mod, WRFU_LOGMSGFOUNDERROR => ESMF_LOGMSGFOUNDERROR
+        USE ESMF_Mod, WRFU_LOGMSGSETERROR => ESMF_LOGMSGSETERROR
+        USE ESMF_Mod, WRFU_LOGOPEN => ESMF_LOGOPEN
+        USE ESMF_Mod, WRFU_LOGSET => ESMF_LOGSET
+        USE ESMF_Mod, WRFU_LOGWRITE => ESMF_LOGWRITE
+        USE ESMF_Mod, WRFU_LOG_ERROR => ESMF_LOG_ERROR
+        USE ESMF_Mod, WRFU_LOG_HALTERROR => ESMF_LOG_HALTERROR
+        USE ESMF_Mod, WRFU_LOG_HALTNEVER => ESMF_LOG_HALTNEVER
+        USE ESMF_Mod, WRFU_LOG_HALTWARNING => ESMF_LOG_HALTWARNING
+        USE ESMF_Mod, WRFU_LOG_INFO => ESMF_LOG_INFO
+        USE ESMF_Mod, WRFU_LOG_MULTI => ESMF_LOG_MULTI
+        USE ESMF_Mod, WRFU_LOG_SINGLE => ESMF_LOG_SINGLE
+        USE ESMF_Mod, WRFU_LOG_WARNING => ESMF_LOG_WARNING
+        USE ESMF_Mod, WRFU_MAXSTR => ESMF_MAXSTR
+        USE ESMF_Mod, WRFU_R4 => ESMF_R4
+        USE ESMF_Mod, WRFU_R8 => ESMF_R8
+        USE ESMF_Mod, WRFU_SUCCESS => ESMF_SUCCESS
+        USE ESMF_Mod, WRFU_TIME => ESMF_TIME
+! See module_esmf_extensions for extensions to this interface.  Uncomment 
+! the line below once ESMF supports the extensions.  
+!        USE ESMF_Mod, WRFU_TIMEGET => ESMF_TIMEGET
+        USE ESMF_Mod, WRFU_TIMEINTERVAL => ESMF_TIMEINTERVAL
+        USE ESMF_Mod, WRFU_TIMEINTERVALABSVALUE => ESMF_TIMEINTERVALABSVALUE
+        USE ESMF_Mod, WRFU_TIMEINTERVALGET => ESMF_TIMEINTERVALGET
+        USE ESMF_Mod, WRFU_TIMEINTERVALNEGABSVALUE => ESMF_TIMEINTERVALNEGABSVALUE
+        USE ESMF_Mod, WRFU_TIMEINTERVALPRINT => ESMF_TIMEINTERVALPRINT
+        USE ESMF_Mod, WRFU_TIMEINTERVALREADRESTART => ESMF_TIMEINTERVALREADRESTART
+        USE ESMF_Mod, WRFU_TIMEINTERVALSET => ESMF_TIMEINTERVALSET
+        USE ESMF_Mod, WRFU_TIMEINTERVALVALIDATE => ESMF_TIMEINTERVALVALIDATE
+        USE ESMF_Mod, WRFU_TIMEINTERVALWRITERESTART => ESMF_TIMEINTERVALWRITERESTART
+        USE ESMF_Mod, WRFU_TIMEISLEAPYEAR => ESMF_TIMEISLEAPYEAR
+        USE ESMF_Mod, WRFU_TIMEISSAMECALENDAR => ESMF_TIMEISSAMECALENDAR
+        USE ESMF_Mod, WRFU_TIMEPRINT => ESMF_TIMEPRINT
+        USE ESMF_Mod, WRFU_TIMEREADRESTART => ESMF_TIMEREADRESTART
+        USE ESMF_Mod, WRFU_TIMESET => ESMF_TIMESET
+        USE ESMF_Mod, WRFU_TIMESYNCTOREALTIME => ESMF_TIMESYNCTOREALTIME
+        USE ESMF_Mod, WRFU_TIMEVALIDATE => ESMF_TIMEVALIDATE
+        USE ESMF_Mod, WRFU_TIMEWRITERESTART => ESMF_TIMEWRITERESTART
+
+      END MODULE module_symbols_util
diff --git a/wrfv2_fire/external/io_esmf/module_utility.F90 b/wrfv2_fire/external/io_esmf/module_utility.F90
new file mode 100644
index 00000000..bf21c2d2
--- /dev/null
+++ b/wrfv2_fire/external/io_esmf/module_utility.F90
@@ -0,0 +1,9 @@
+
+      MODULE module_utility
+
+        USE module_symbols_util
+        ! Not-yet-implemented ESMF features
+        USE module_esmf_extensions
+
+      END MODULE module_utility
+
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/FTP_getfile.c b/wrfv2_fire/external/io_grib1/MEL_grib1/FTP_getfile.c
new file mode 100644
index 00000000..8fd4d5f6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/FTP_getfile.c
@@ -0,0 +1,177 @@
+#include 
+#include 
+
+#include "dprints.h"		/* Debug printing & function prototypes*/
+#include "gribfuncs.h"		/* function prototypes */
+/*
+*
+********************************************************************
+* A. FUNCTION:  FTP_getfile
+*       builds and executes a Bourne script file to retreive
+*       the file specified from remote site via Ftp call;
+*       Execute script to establish ftp session (under Userid 'anonymous' 
+*       & passwd 'gribsimp22'):
+*       Host info is retrieved from file "$pathnm/tables.cfg" whose content
+*       is a one line entry= "eifel.nrlmry.navy.mil receive/GRIB_TABLES"
+*
+*    INTERFACE:
+*       int     FTP_getfile (filenm, loc_pathnm, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*       (I)  char *filenm;       Name of file to ftp
+*       (I)  char *loc_pathnm;   Full path leading to config file 'tables.cfg'
+*       (O)  char *errmsg;       Empty array, Returns filled if error occurs;
+*
+*    RETURN CODE:
+*        0> sucessfully ftp-ed;
+*        1> error:  create script/ftp err/missing table.cfg;
+********************************************************************
+*/
+
+#if PROTOTYPE_NEEDED
+int 	FTP_getfile (char *filenm, char *loc_pathnm, char *errmsg)
+
+#else
+int	FTP_getfile (filenm, loc_pathnm, errmsg)
+	char *filenm; 
+	char *loc_pathnm; 
+	char *errmsg;
+#endif
+{
+FILE    *f1=NULL, *f2=NULL;
+char    *func="FTP_getfile";
+char    filename[200];
+char    hostnm[100];    /* name of remote site  */
+char    usernm[100];    /* using anonymous  */
+char    passwd[100];    /* anonymous  */
+char    pathnm[100];    /* full path of remote file to get  */
+int     stat;		/* return status */
+int     n;              /* working var */
+
+  DPRINT3 ("Entering %s (%s/%s)\n", func, loc_pathnm, filenm);
+/*
+*
+* A.1       SET up name of local config file     !$local_path/tables.cfg
+*           IF (unable to open config file)
+*               RETURN 1  !errmsg filled
+*           ENDIF
+*/
+
+   /*   USE SAME CONFIG FILE -- 
+	no matter if dnloading "g1tab* , or neon2gr*, or orig_ctr"
+   */
+  sprintf (filename, "%s/tables.cfg", loc_pathnm);
+  DPRINT1 ("Read Remote host info from '%s'\n", filename);
+  if ((f1=fopen (filename, "r"))==NULL) {
+        sprintf(errmsg,"%s: failed to open '%s' for reading;\n",func,filename);
+        stat=(1); goto BYE;
+        }
+/*
+*
+* A.2       READ hostname and remote pathname from file, then close it;
+*           !config entry->    "eifel.nrlmry.navy.mil receive/GRIB_TABLES"
+*
+* A.3       CLOSE config file;
+*/
+   n = fscanf (f1, "%s%s", hostnm, pathnm);
+   fclose(f1);     /* close Config File */
+/*
+*
+* A.4       IF (read failed) RETURN 1  !errmsg filled;
+*/
+  if (n  != 2) {
+        sprintf(errmsg,"%s: Fail to read 2 args from '%s'\n", func, filename);
+        stat=(1); goto BYE;
+        }
+
+/*
+*
+* A.6       SET password to "gribsimp22", userid to "anonymous"
+*/
+  strcpy (passwd, "gribsimp22");
+
+ /* Ready to build Bourne script: */
+/*
+*
+* A.7       IF (create temp script file fails)
+*               RETURN 1   !errmsg filled
+*           ENDIF
+*/
+  if ((f1=fopen ("temp_ftp_script","w"))==NULL) {
+        sprintf(errmsg,"%s:  failed to build FTP script\n", func);
+        stat=(1); goto BYE;
+        }
+/*
+*
+* A.8       CREATE ftp script to download Host's "receive/GRIB_TABLES/$fn"
+*           to $localPath/$fn locally; 
+*
+* A.9       CLOSE temp file
+*/
+        fprintf (f1,
+		"#!/bin/sh\nexec 1>&-;exec 2>&-\nftp -in %s << STOP\n" \
+		"user anonymous %s\ncd %s\nlcd %s\nget %s\nquit\n" \
+		"STOP\nexit\n", 
+		hostnm,  passwd, pathnm, loc_pathnm, filenm);
+        fclose(f1);
+
+        DPRINT5 ("execute ftp script: \n"
+		"   #!/bin/sh\n   exec 1>&-;exec 2>&-\n"
+		"   ftp -in %s << STOP\n   user anonymous %s\n"
+		"   cd %s\n   lcd %s\n   get %s\n   quit\n   STOP\n   exit\n",
+		hostnm,  passwd, pathnm, loc_pathnm, filenm);
+/*
+*
+* A.10      EXECUTE script to download lookup file
+*
+* A.11      REMOVE temp script
+*/
+  fprintf(stdout,"Attempting to get remote '%s'\n", filenm);
+  n= system ("chmod 755 temp_ftp_script;temp_ftp_script");
+  unlink ("temp_ftp_script");
+
+/*
+*
+* A.12      IF (execute script failed)
+*               RETURN 1   !errmsg filled
+*           ENDIF
+*/
+  if (n!=0) {   /* ck Stat of Systm call */
+        sprintf(errmsg,"%s:  system call to ftp failed\n", func);
+        stat=(1); goto BYE;
+        }
+
+/*
+*
+* A.13      CHECK if ftp-ed file is available & readable
+*           IF (failed)
+*               RETURN 1   !errmsg filled
+*           ENDIF
+*/
+  sprintf (filename, "%s/%s", loc_pathnm, filenm);
+  if ((f2= fopen(filename, "rb+"))==NULL) {
+        sprintf(errmsg,"%s: '%s' not avail on %s in %s\n\n", func,
+        filenm, hostnm, pathnm);
+        stat=(1); goto BYE;
+        }
+
+  DPRINT0("file downloaded successfully\n");
+  stat= 0;
+
+BYE:
+/*
+*
+* A.14      CLOSE up ftp-ed file
+*/
+  if (f2) fclose(f2);
+
+/*
+* A.15      RETURN 0 !success
+*/
+DPRINT2 ("Leaving %s, Stat=%d\n", func, stat);
+return(stat);
+/*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/Makefile b/wrfv2_fire/external/io_grib1/MEL_grib1/Makefile
new file mode 100644
index 00000000..05db3207
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/Makefile
@@ -0,0 +1,103 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I. -I.. -I../grib1_util
+BUILD_DIR = ../../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = ..
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+ARFLAGS      = ruv
+
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib1
+DEP_LIBS = 
+OBJS =  FTP_getfile.o \
+	apply_bitmap.o \
+	display_gribhdr.o \
+	gbyte.o \
+	grib_dec.o \
+	grib_enc.o \
+	grib_seek.o \
+	gribgetbds.o \
+	gribgetbms.o \
+	gribgetgds.o \
+	gribgetpds.o \
+	gribhdr2file.o \
+	gribputbds.o \
+	gribputgds.o \
+	gribputpds.o \
+	hdr_print.o \
+	init_dec_struct.o \
+	init_enc_struct.o \
+	init_gribhdr.o \
+	init_struct.o \
+	ld_dec_lookup.o \
+	ld_enc_input.o \
+	ld_enc_lookup.o \
+	ld_grib_origctrs.o \
+	make_default_grbfn.o \
+	make_grib_log.o \
+	map_lvl.o \
+	map_parm.o \
+	pack_spatial.o \
+	prt_inp_struct.o \
+	upd_child_errmsg.o \
+	prt_badmsg.o \
+	swap.o\
+	grib_uthin.o\
+	set_bytes.o
+
+# 
+# List the header files that should be installed.
+#
+HDRS =	gribfuncs.h \
+	grib.h \
+	input.h
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/README b/wrfv2_fire/external/io_grib1/MEL_grib1/README
new file mode 100644
index 00000000..06c171dc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/README
@@ -0,0 +1,14 @@
+10/6/99
+Todd A. Hutchinson
+TASC (WSI Contractor)
+
+The code in this directory builds a library which is used to read and write 
+grib data.  The code is a modified subset of the Navy's Master Environmental 
+Laboratory's grib library.  The MEL grib library was ported to linux, then
+taken apart to fit into the standard directory structure and Makefile structure
+that we use as part of WxPredictor.
+
+For more information on the MEL Grib Library, go to 
+http://mel.dmso.mil/mel_tools/user_software.html.
+
+
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/apply_bitmap.c b/wrfv2_fire/external/io_grib1/MEL_grib1/apply_bitmap.c
new file mode 100644
index 00000000..3759bfc4
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/apply_bitmap.c
@@ -0,0 +1,234 @@
+#include 
+#include 
+
+#include "dprints.h"		/* debug prints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+*********************************************************************
+* A. FUNCTION:  apply_bitmap
+*       apply the bitmap to the float array.  The input float array is
+*       expanded and filled with 'fill_value' in places where data
+*       points are missing.
+*
+*    INTERFACE:
+*      int  apply_bitmap (bms, pgrib_data, fill_value, bds_head, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  BMS_INPUT *bms;
+*           pointer to the internal BitMap header structure;  bit set means
+*           datapoint is present, bit clear means datapoint is missing.
+*     (I&O) float **pgrib_data;  
+*           pointer to Data that was unpacked from BDS's bitstr;  Incoming
+*           size is bms->ulbits_set or (ROW*COL - #missingpts) elements;
+*      (I)  float fill_value;    
+*           float value used for missing datapoints in expanded array;
+*      (O)  BDS_HEAD_INPUT *bds_head; 
+*           attribute 'ulGrid_size' to be updated;
+*      (O)  char *errmsg;
+*           Empty array that's returned filled if error occurred; 
+*
+*    RETURN CODE:
+*      0>  Success; float **pgrib_data probably have been expanded, OR
+*          Predefined bitmap used, no action taken (float array unchanged);
+*      1>  NULL bitmap encountered, errmsg filled;
+*      2>  Error Mallocing space for data array, errmsg filled;
+*      3>  Tried to access more than available in message, errmsg filled;
+*      4>  No bits set in BMS, errmsg filled;
+**********************************************************************
+*/ 
+#if PROTOTYPE_NEEDED
+
+int apply_bitmap ( BMS_INPUT *bms, float **pgrib_data, float fill_value,
+		BDS_HEAD_INPUT *bds_head, char *errmsg)
+#else
+
+int apply_bitmap ( bms, pgrib_data, fill_value, bds_head, errmsg)
+		BMS_INPUT *bms; 
+		float **pgrib_data; 
+		float fill_value;
+		BDS_HEAD_INPUT *bds_head; 
+		char *errmsg;
+
+#endif
+{
+  char  *func= "apply_bitmap";
+  int   i,j;			/* temp var */
+  int   val;			/* temp var */
+  int	buf_indx;		/* index for expanded float *buff array */
+  int   gribdata_indx;		/* index for float *Grid_data array */
+  int	tot_bits_set;		/* must be < expanded size */
+  char  *pbms; 			/* BIT ptr beg. at BMS data array */
+  float	*fbuff;		 	/* holds expanded float array */
+  int	 gridsize;		/* expanded size r*c */
+
+/*
+* 
+* A.0     DEBUG printing
+*/
+  DPRINT1 ("Enter %s()\n", func);
+
+/*
+*
+* A.1     IF (using pre-defined bitmap)
+*            FILL errmsg ! 'case not supported' 
+*            RETURN 0  !success
+*         ENDIF
+*/
+  if (bms->uslength == 6) /* References pre-defined bitmap */
+    {
+      /* Not currently supported.  User can add code inside this IF
+       * to retreive the bitmap from local storage if available.
+       * For now, code prints warning and leaves data array alone */
+      fprintf(stdout,
+		"\n%s Warning: Predefined bitmap encountered! Not supported; " \
+      		"Must apply bitmap to data externally.\n", func);
+      DPRINT1("Leaving %s: Predefined bitmap used, no action taken\n",func);
+      return(0);
+    }
+           
+/*
+*
+* A.2     IF (Bitmap pointer is NULL)
+*            FILL errmsg  !null pointer
+*            RETURN 1   
+*         ENDIF
+*/
+  if (bms->bit_map==NULL) {
+	DPRINT1 ("Leaving %s:  bitmap is Null, no action taken\n", func);
+	return(1); 
+	}
+
+/*
+*
+* A.3     IF (count of bits set in BMS is Zero)
+*            FILL errmsg
+*            RETURN 4   !no bits set
+*         ENDIF
+*/
+   if ((tot_bits_set=bms->ulbits_set) == 0) {
+       sprintf(errmsg,"%s: No bits set in bitmap.  No data retrieved!!\n",func); 
+       DPRINT1("Leaving %s: No bits set in bitmap\n",func); 
+       return(4);
+   }
+
+/*
+*
+* A.4     CALCULATE grid_size from total number of bits in BMS;
+*/
+  /* = (BMS length)*8 bits - 48 header bits - # of unsused bits */
+  gridsize=(bms->uslength)*8 - 48 - bms->usUnused_bits;
+
+  DPRINT2 ("Apply Bitmap: expanding array from [%d] to [%d]; ",
+  tot_bits_set, gridsize);
+
+/* 
+*
+* A.5     ALLOCATE storage for expanded array 
+*         IF (Malloc error) 
+*            RETURN 2 
+*         ENDIF
+*/
+  fbuff= (float *)malloc (gridsize * sizeof(float));
+  if (fbuff==(float *)NULL)
+	{ 
+          sprintf(errmsg, "%s: Error mallocing %ld bytes\n", func,gridsize);
+          DPRINT1 ("Leaving %s, malloc error\n",func);
+          return(2); 
+	}
+
+/*
+*
+* A.6     FOR (each point expected)
+*/
+  pbms= bms->bit_map;	/* pts to char arry bstr of BMS */
+  gribdata_indx=0;	/* index for incoming float arr */
+  for (buf_indx=0; buf_indx < gridsize; ++pbms) {
+
+/*
+* A.6.1      GET next byte from Bitmap Section Data 
+*/
+	val= (int)*pbms & 0x0000ff ;	/* BMS bitstream */
+
+/*
+* A.6.2      LOOP, check each Bit of byte read (left to rightmost)
+*/
+	for (j=7; j>=0 && buf_indx < gridsize; j--) {
+/*
+* A.6.2.1       IF (bit is set)  !means datapoint is present
+*/
+	    if (val & (1<ulGrid_size= (unsigned long)gridsize;  /* store new sz */
+
+/*
+*
+* A.8      FREE old float array 
+*/
+  free (*pgrib_data);
+
+/*
+*
+* A.9      ASSIGN new expanded array to pointer
+*/
+  *pgrib_data= fbuff;	/* give it addr of expanded arr */
+/*
+*
+* A.10     RETURN 0 !success
+*/
+  DPRINT1("Leaving %s, Stat=0", func);
+  return (0); 
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/display_gribhdr.c b/wrfv2_fire/external/io_grib1/MEL_grib1/display_gribhdr.c
new file mode 100644
index 00000000..fba1c6f5
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/display_gribhdr.c
@@ -0,0 +1,175 @@
+/* FILE:  display_gribhdr.c  		10-OCT-96 by Alice Nakajima/SAIC */
+#include               /* standard I/O header file     */
+#include 
+
+#include "dprints.h"		/* function prototypes */
+#include "gribfuncs.h"		/* prototypes */
+
+#define COLS	10		/* # of cols to print per line */
+#define HALFWAY	COLS/2		/* half of #cols */
+
+/*
+**********************************************************************
+* A. FUNCTION:   display_gribhdr
+*      do a byte dump for each of the defined GRIB Sections in the 
+*      GRIB message currently stored in the Grib Header struct.
+*
+*    INTERFACE:       
+*       void display_gribhdr (gribhdr)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  GRIB_HDR *gribhdr;
+*           holds Grib header info to be printed to standard output;
+*    
+*    RETURNS:  nothing;  
+**********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void display_gribhdr ( GRIB_HDR *hdr)
+#else
+void display_gribhdr ( hdr)
+	GRIB_HDR *hdr;
+#endif
+{
+  char *func="dislay_gribhr";
+   unsigned char *ptr, *ptr2;
+   long  i, j, cnt, skip;
+   char title[200];
+
+   fprintf(stdout, "In %s: showing Grib msg in Grib Hdr:\n", func);
+/*
+*
+* A.1      IF (the entire_msg buffer is NULL) THEN
+*              PRINT error
+*              RETURN
+*          ENDIF
+*/
+   if (hdr->entire_msg == NULL) {
+	fprintf(stdout,"Entire Msg Buffer is Null, cannot proceed;\n");
+	goto RETURN;
+	}
+/*
+*
+* A.2      IF (sum of section lengths does not equal Total Msg length) THEN
+*              PRINT warning
+*          ELSE 
+*              PRINT msg_length
+*          ENDIF
+*/
+   if (hdr->msg_length != (hdr->ids_len + hdr->pds_len + hdr->gds_len 
+			   + hdr->bms_len + hdr->bds_len + hdr->eds_len))
+	fprintf(stdout,"\n*******************************************\n"\
+	"WARNING: Msg_length=%d but SUM of sect lengths= %d "\
+	"(%d+%d+%d+%d+%d+%d);\n*******************************************\n",
+   	hdr->msg_length,
+        hdr->ids_len+hdr->pds_len+hdr->gds_len+hdr->bms_len+
+	hdr->bds_len+hdr->eds_len, 
+	hdr->ids_len, hdr->pds_len, hdr->gds_len , hdr->bms_len, 
+	hdr->bds_len, hdr->eds_len);
+   else  
+	fprintf(stdout,"Msg_length=%d;  IDS=%ld,"\
+	"PDS=%ld, GDS=%ld, BMS=%ld, BDS=%ld, EDS=%ld;\n",
+   	hdr->msg_length,
+	hdr->ids_len, hdr->pds_len, hdr->gds_len , hdr->bms_len, 
+	hdr->bds_len, hdr->eds_len);
+
+   fprintf(stdout,"Printing each defined section, upto 100 bytes only\n");
+/*
+*
+* A.3      PRINT Identification Defn Section if defined;
+*          FUNCTION hdr_print   !dump out its content
+*/
+   if (hdr->ids_ptr == NULL)  fprintf(stdout,"Section 0 is Null, len=%ld;\n",
+	hdr->ids_len);
+   else {
+	cnt= (hdr->ids_len > 100 ? 100 : hdr->ids_len);
+	sprintf(title,"Section 0 Content Len=%ld (upto 100 bytes)", 
+	hdr->ids_len);
+	hdr_print (title, hdr->ids_ptr, cnt);
+	}
+	
+/*
+*
+* A.4      PRINT Product Defn Section if defined;
+*          FUNCTION hdr_print   !dump out its content
+*/
+   if (hdr->pds_ptr == NULL)  fprintf(stdout,"Product Data Section is Null, "\
+	"len=%ld;\n", hdr->pds_len);
+   else {
+	cnt= (hdr->pds_len > 100 ? 100 : hdr->pds_len);
+	sprintf(title,"PDS Content (offs=%ld, Len=%ld)",
+	(long)(hdr->pds_ptr - hdr->entire_msg), hdr->pds_len);
+	hdr_print (title, hdr->pds_ptr, cnt);
+	}
+	    
+/*
+*
+* A.5      PRINT Grid Defn Section if defined;
+*          FUNCTION hdr_print   !dump out its content
+*/
+   if (hdr->gds_ptr == NULL)  fprintf(stdout,"Grid Defn Section is Null, "\
+	"len=%ld;\n", hdr->gds_len);
+   else {
+	cnt= (hdr->gds_len > 100 ? 100 : hdr->gds_len);
+	sprintf(title,"GDS Content (offs=%ld, Len=%ld)",
+	(long)(hdr->gds_ptr - hdr->entire_msg), hdr->gds_len);
+	hdr_print (title, hdr->gds_ptr, cnt);
+	}
+	
+/*
+*
+* A.6      PRINT Bitmap Data Section if defined;
+*          FUNCTION hdr_print   !dump out its content upto 100 bytes
+*/
+   if (hdr->bms_ptr == NULL)  fprintf(stdout,"Bitmap Section is Null, "\
+	"len=%ld;\n", hdr->bms_len);
+   else {
+	cnt= (hdr->bms_len > 100 ? 100 : hdr->bms_len);
+	sprintf(title,"BMS Content (offs=%ld, Len=%ld)",
+	(long)(hdr->bms_ptr - hdr->entire_msg), hdr->bms_len);
+	hdr_print (title, hdr->bms_ptr, cnt);
+	}
+	
+/*
+*
+* A.7      PRINT Binary Defn Section if defined;
+*          FUNCTION hdr_print   !dump out its content upto 100 bytes
+*/
+   if (hdr->bds_ptr == NULL)  fprintf(stdout,"Binary Data Section is Null, "\
+	"len=%ld;\n", hdr->bds_len);
+   else {
+	cnt= (hdr->bds_len > 100 ? 100 : hdr->bds_len);
+	sprintf(title,"BDS Content (offs=%ld, Len=%ld)",
+	(long)(hdr->bds_ptr - hdr->entire_msg), hdr->bds_len);
+	hdr_print (title, hdr->bds_ptr, cnt);
+	}
+	
+/*
+*
+* A.8      PRINT End Defn Section if defined;
+*          FUNCTION hdr_print   !dump out its content
+*/
+   if (hdr->eds_ptr == NULL)  fprintf(stdout,"End Data Section is Null, "\
+	"len=%ld;\n", hdr->eds_len);
+   else {
+        cnt= (hdr->eds_len > 100 ? 100 : hdr->eds_len);
+	sprintf(title, "End Data Section (offs=%ld, size=%ld) ",
+	(long) (hdr->eds_ptr - hdr->entire_msg), hdr->eds_len); 
+	hdr_print (title, hdr->eds_ptr, cnt);
+	}
+
+RETURN:
+/*
+*
+* A.9      RETURN to caller  !return nothing
+*/
+   fprintf(stdout, "%s complete;\n", func);
+   return;
+
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/dprints.h b/wrfv2_fire/external/io_grib1/MEL_grib1/dprints.h
new file mode 100644
index 00000000..7d612bc5
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/dprints.h
@@ -0,0 +1,79 @@
+/* file:  dprints.h				12/30/96 Nakajima/SAIC/MRY
+*/
+#include 
+
+#define p_char(expr)    fprintf(stdout," (char) " #expr "= %c\n",expr)
+#define p_string(expr)  fprintf(stdout," (char *) " #expr "= %s\n",expr)
+#define p_ushort(expr)  fprintf(stdout," (uns. short) " #expr "= %u\n",expr)
+#define p_short(expr)   fprintf(stdout," (short) " #expr "= %d\n",expr)
+#define p_int(expr)     fprintf(stdout," (int) " #expr "= %d\n",expr)
+#define p_long(expr)    fprintf(stdout," (long) " #expr "= %ld\n",expr)
+#define p_ulong(expr)   fprintf(stdout," (uns.long) " #expr "= %u\n",expr)
+#define p_float(expr)   fprintf(stdout," (float) " #expr "= %.5f\n",expr)
+#define p_double(expr)  fprintf(stdout," (double) " #expr "= %.5lf\n",expr)
+
+
+#ifdef  VERBOSE	
+/************************************************ 
+ *    DEBUG IS DESIRED (compiled with -DVERBOSE)  
+ ************************************************/
+#define VERB_ON          	1
+#define LIB_VERSION             	"verbose"
+#define DISPLAY_GRIBHDR(gh)    	  	display_gribhdr(gh)
+#define HDR_PRINT(str,addr,sz)  	hdr_print(str,addr,sz)
+#define PRT_INP_STRUCT(a,b,c,d,e)	 prt_inp_struct(a,b,c,d,e)
+#define DPRINT0(fmt)  			fprintf(stdout,(fmt))
+#define DPRINT1(fmt,a)  		fprintf(stdout,(fmt),(a))
+#define DPRINT2(fmt,a,b)  		fprintf(stdout,(fmt),(a),(b))
+#define DPRINT3(fmt,a,b,c)  		fprintf(stdout,(fmt),(a),(b),(c))
+#define DPRINT4(fmt,a,b,c,d)  		fprintf(stdout,(fmt),(a),(b),(c),(d))
+#define DPRINT5(fmt,a,b,c,d,e)  	fprintf(stdout,(fmt),\
+					(a),(b),(c),(d),(e))
+#define DPRINT6(fmt,a,b,c,d,e,f)   	fprintf(stdout,(fmt),\
+					(a),(b),(c),(d),(e),(f))
+#define DPRINT7(fmt,a,b,c,d,e,f,g) 	fprintf(stdout,(fmt), \
+					(a),(b),(c),(d),(e), (f),(g))
+#define DPRINT8(fmt,a,b,c,d,e,f,g,h) 	fprintf(stdout,(fmt),\
+					(a),(b),(c),(d),(e),(f),(g),(h))
+#define DPRINT9(fmt,a,b,c,d,e,f,g,h,i)  fprintf(stdout,(fmt),\
+					(a),(b),(c),(d),(e),(f),(g),(h),(i))
+#define P_CHAR(x)    			p_char(x)
+#define P_STRING(x)  			p_string(x)
+#define P_USHORT(x) 			p_ushort(x)
+#define P_SHORT(x)   			p_short(x)
+#define P_INT(x)    			p_int(x)
+#define P_LONG(x)    			p_long(x)
+#define P_ULONG(x)   			p_ulong(x)
+#define P_FLOAT(x)   			p_float(x)
+#define P_DOUBLE(x)  			p_double(x)
+
+#else
+/***********************************************
+*    ELSE TURN ALL DEBUG PRINTING OFF                 
+*    null out function calls
+************************************************/
+#define VERB_ON        0
+#define LIB_VERSION             "non-verbose"
+#define DISPLAY_GRIBHDR(gh)            	{}
+#define HDR_PRINT(title,addr,sz)   	{}
+#define PRT_INP_STRUCT(a,b,c,d,e)	{}
+#define DPRINT0(fmt)                    {}
+#define DPRINT1(fmt,s)                  {}
+#define DPRINT2(fmt,a,b)                {}
+#define DPRINT3(fmt,a,b,c)              {}
+#define DPRINT4(fmt,a,b,c,d)            {}
+#define DPRINT5(fmt,a,b,c,d,e)          {}
+#define DPRINT6(fmt,a,b,c,d,e,f)        {}
+#define DPRINT7(fmt,a,b,c,d,e,f,g)      {}
+#define DPRINT8(fmt,a,b,c,d,e,f,g,h)    {}
+#define DPRINT9(fmt,a,b,c,d,e,f,g,h,i)  {}
+#define P_CHAR(expr)    		{}
+#define P_STRING(expr)  		{}
+#define P_USHORT(expr)  		{}
+#define P_SHORT(expr)   		{}
+#define P_INT(expr)     		{}
+#define P_LONG(expr)    		{}
+#define P_ULONG(expr)   		{}
+#define P_FLOAT(expr)   		{}
+#define P_DOUBLE(expr)  		{}
+#endif
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gbyte.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gbyte.c
new file mode 100644
index 00000000..6b4602fc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gbyte.c
@@ -0,0 +1,533 @@
+/* gbyte.c:
+  ADAPTED FROM THE ORIGINAL FORTRAN VERSION OF GBYTE BY:
+ 
+              DR. ROBERT C. GAMMILL, CONSULTANT
+              NATIONAL CENTER FOR ATMOSPHERIC RESEARCH
+              MAY 1972
+ 
+              CHANGES FOR FORTRAN 90
+              AUGUST 1990  RUSSELL E. JONES
+              NATIONAL WEATHER SERVICE
+              GBYTE RUN WITHOUT CHANGES ON THE FOLLOWING COMPILERS
+              MICROSOFT FORTRAN 5.0 OPTIMIZING COMPILER
+              SVS 32 386 FORTRAN 77 VERSION V2.8.1B
+              SUN FORTRAN 1.3, 1.4
+              DEC VAX FORTRAN
+              SILICONGRAPHICS 3.3, 3.4 FORTRAN 77
+              IBM370 VS COMPILER
+              INTERGRAPH GREEN HILLS FORTRAN CLIPPER 1.8.4B
+*/
+#include 
+#include 
+
+#include "dprints.h"	/* debug prints & func prototypes */
+#include "gribfuncs.h"		/* prototypes */
+#include "isdb.h"		/* WORD_BIT_CNT defn */
+
+/* Added by Todd Hutchinson, 8/10/05*/
+/* 
+ * gbyte requires the word bit count to be 32.  In order for this to work
+ *    on platforms with 8 byte longs, we must set WORD_BIT_CNT to 32 for
+ *    gbyte.
+ */
+
+#ifdef WORD_BIT_CNT
+#undef WORD_BIT_CNT
+#endif
+#define WORD_BIT_CNT 32  /* gbyte.c requires the word bit count to be 32! */
+
+/*
+*
+*****************************************************************
+* A.  FUNCTION:   gbyte
+*       extracts data of specified length from the specified offset
+*       from beginning of the given Data block.
+*
+*    INTERFACE:
+*      void   gbyte (inchar, iout, iskip, nbits)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) char *inchar;
+*          The fullword in memory from which unpacking is to
+*          begin, successive fullwords will be fetched as required.
+*      (O) unsigned long *iout;
+*          The value read from in memory that's returned.
+*    (I&O) unsigned long  *iskip;
+*          a fullword integer specifying the inital offset
+*          in bits of the first byte, counted from the
+*          leftmost bit in Inchar.  Gets updated upon exit;
+*      (I) unsigned long nbits;
+*          a fullword integer specifying the number of bits
+*          in each byte to be unpacked.  Legal byte widths
+*          are in the range 1 - 32, bytes of width  less than 32
+*          will be right justified in the low-order positions
+*          of the unpacked fullwords with high-order zero fill.
+*
+*    RETURN CODE:  none;
+*****************************************************************
+*
+*/
+
+#if PROTOTYPE_NEEDED
+void 	gbyte (char *inchar, unsigned long *iout, unsigned long *iskip,
+		unsigned long nbits)
+#else
+void gbyte (inchar, iout, iskip, nbits)
+	  char *inchar;         /* input */
+	  unsigned long *iout;  /* output, is the value returned */
+	  unsigned long *iskip; /* input, gets updated */
+	  unsigned long nbits;  /* input */
+#endif
+{
+   long masks[32];
+   long	icon,index,ii,mover,movel;
+   unsigned long temp, mask, inlong;
+
+
+/*
+* A.1      INITIALIZE mask possibilities of all bits set from LSB to
+*          a particular bit position;  !bit position range: 0 to 31
+*/
+   masks[0] = 1; 
+   masks[1] = 3;
+   masks[2] = 7;
+   masks[3] = 15; 
+   masks[4] = 31;
+   masks[5] = 63;
+   masks[6] = 127;
+   masks[7] = 255;
+   masks[8] = 511;
+   masks[9] = 1023;
+   masks[10] = 2047;
+   masks[11] = 4095;
+   masks[12] = 8191;
+   masks[13] = 16383;
+   masks[14] = 32767;
+   masks[15] = 65535;
+   masks[16] = 131071;
+   masks[17] = 262143;
+   masks[18] = 524287;
+   masks[19] = 1048575; 
+   masks[20] = 2097151; 
+   masks[21] = 4194303;
+   masks[22] = 8388607; 
+   masks[23] = 16777215;
+   masks[24] = 33554431;
+   masks[25] = 67108863;
+   masks[26] = 134217727;
+   masks[27] = 268435455; 
+   masks[28] = 536870911; 
+   masks[29] = 1073741823;
+   masks[30] = 2147483647;
+   masks[31] = -1;
+
+/* NBYTE MUST BE LESS THAN OR EQUAL TO WORD_BIT_CNT
+
+*
+* A.2      IF (trying to retrieve more than numbits_perword) THEN  !here, 32
+*              RETURN
+*          ENDIF
+*/
+   icon = WORD_BIT_CNT - nbits;
+   if ( icon < 0 )
+   {
+      return;
+   }
+/*
+*
+* A.3      SET up mask needed for specified #bits to retrieve
+*/
+   mask = masks[nbits-1];
+/*
+*
+* A.4      CALCULATE Index !Byte offset from 'inchar' where retrieval begins
+*/
+   index = *iskip / WORD_BIT_CNT;
+/*
+*
+* A.5      CALCULATE Bit position within byte Index where retrieval begins
+*/
+   ii = *iskip % WORD_BIT_CNT;
+
+/*
+*
+* A.6      CALCULATE #times to Right-shift the retrieved data so it 
+*          is right adjusted
+*/
+   mover = icon - ii;
+
+/*
+*
+* A.7.a    IF (need to right-adjust the byte) THEN
+*/
+   if ( mover > 0 )
+   {
+
+/*
+* A.7.a.1     RETRIEVE 4 continuous byte from offset Index in block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)inchar[index*4] << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* A.7.a.2     RIGHT adjust this value
+*/
+     *iout = inlong >> mover;
+/*
+* A.7.a.3     MASK out the bits wanted only    !result in *out
+*/
+     *iout = (*iout & mask);
+   } /* If */
+
+
+/*
+* A.7.b    ELSE IF (byte is split across a word break) THEN
+*/
+   else if ( mover < 0 )
+   {
+/*
+*             !
+*             !Get the valid bits out of the FIRST WORD
+*             !
+* A.7.b.1     CALCULATE #times to move retrieve data left so
+*             the 1st significant bit aligns with MSB of word
+* A.7.b.2     CALCULATE #times to move data that's aligned 
+*             with MSB so that it aligns with LSB of word
+*/
+      movel = -mover;
+      mover = WORD_BIT_CNT - movel;   /* WORD_BIT_CNT is 32 */
+
+/*
+* A.7.b.3     RETRIEVE 4-byte word from offset Index from block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* A.7.b.4     SHIFT retrieve this data all the way left !Left portion
+*/
+
+/*
+*             !
+*             !Now Get the valid bits out of the SECOND WORD
+*             !
+* A.7.b.5     RETRIEVE the next 4-byte word from block
+*/
+      *iout = inlong << movel;
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4+4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+5 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+6 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+7 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/* 
+* A.7.b.6     SHIFT this data all the way right   !Right portion
+* A.7.b.7     OR the Left portion and Right portion together
+* A.7.b.8     MASK out the #bits wanted only     !result in *iout
+*/
+      temp  = inlong >> mover;
+      *iout = *iout|temp;
+      *iout &= mask;
+/*
+  THE BYTE IS ALREADY RIGHT ADJUSTED.
+*/
+   }
+   else
+/*
+* A.7.c    ELSE    !the byte is already adjusted, no shifts needed
+*/
+   {
+/*
+* A.7.c.1     RETRIEVE the next 4-byte word from block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* A.7.c.2     MASK out the bits wanted only    !result in *out
+*/
+      *iout = inlong&mask;
+   }
+/*
+* A.7.c    ENDIF    !the byte is already adjusted
+*/
+
+/*
+*
+* A.8      DEBUG printing
+*/
+  DPRINT3 ("gbyte(skip=%d %d bits)= %lu stored as ", *iskip, nbits, *iout);
+/*
+*
+* A.9      BUMP pointer up
+*/
+	*iskip += nbits;
+/* 
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+*****************************************************************
+* B.  FUNCTION:   gbyte_quiet
+*       called to extract data of specified length from
+*       specified offset from a block of type char;  
+*       Identical to gbyte() except it does not print out in debug mode;
+*
+*    INTERFACE:
+*      void gbyte_quiet (inchar, iout, iskip, nbits)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) char *inchar
+*          The fullword in memory from which unpacking is to
+*          begin, successive fullwords will be fetched as required.
+*      (O) unsigned long *iout
+*          The value read from memory that's being returned.
+*    (I&O) unsigned long  *iskip
+*          a fullword integer specifying the inital offset
+*          in bits of the first byte, counted from the
+*          leftmost bit in Inchar.  Gets updated upon exit;
+*      (I) unsigned long nbits
+*          a fullword integer specifying the number of bits
+*          in each byte to be unpacked.  Legal byte widths
+*          are in the range 1 - 32, bytes of width  less than 32
+*          will be right justified in the low-order positions
+*          of the unpacked fullwords with high-order zero fill.
+*
+*    RETURN CODE:  none;
+*****************************************************************
+*
+*/
+
+#if PROTOTYPE_NEEDED
+void gbyte_quiet (char *inchar, unsigned long *iout, unsigned long *iskip,
+		unsigned long nbits)
+#else
+void gbyte_quiet (inchar, iout, iskip, nbits)
+	  char *inchar;         /* input */
+	  unsigned long *iout;  /* output, is the value returned */
+	  unsigned long *iskip; /* input, gets updated */
+	  unsigned long nbits;  /* input */
+
+#endif
+{
+   long masks[32];
+   long	icon,index,ii,mover,movel;
+   unsigned long temp, mask, inlong;
+
+
+/*
+* B.1      INITIALIZE mask possibilities of all bits set from LSB to
+*          a particular bit position;  !bit position range: 0 to 31
+*/
+   masks[0] = 1; 
+   masks[1] = 3;
+   masks[2] = 7;
+   masks[3] = 15; 
+   masks[4] = 31;
+   masks[5] = 63;
+   masks[6] = 127;
+   masks[7] = 255;
+   masks[8] = 511;
+   masks[9] = 1023;
+   masks[10] = 2047;
+   masks[11] = 4095;
+   masks[12] = 8191;
+   masks[13] = 16383;
+   masks[14] = 32767;
+   masks[15] = 65535;
+   masks[16] = 131071;
+   masks[17] = 262143;
+   masks[18] = 524287;
+   masks[19] = 1048575; 
+   masks[20] = 2097151; 
+   masks[21] = 4194303;
+   masks[22] = 8388607; 
+   masks[23] = 16777215;
+   masks[24] = 33554431;
+   masks[25] = 67108863;
+   masks[26] = 134217727;
+   masks[27] = 268435455; 
+   masks[28] = 536870911; 
+   masks[29] = 1073741823;
+   masks[30] = 2147483647;
+   masks[31] = -1;
+
+/* NBYTE MUST BE LESS THAN OR EQUAL TO WORD_BIT_CNT
+
+*
+* B.2      IF (trying to retrieve more than numbits_perword) THEN  !here, 32
+*              RETURN
+*          ENDIF
+*/
+   icon = WORD_BIT_CNT - nbits;
+   if ( icon < 0 )
+   {
+      return;
+   }
+/*
+*
+* B.3      SET up mask needed for specified #bits to retrieve
+*/
+   mask = masks[nbits-1];
+/*
+*
+* B.4      CALCULATE Index !Byte offset from 'inchar' where retrieval begins
+*/
+   index = *iskip / WORD_BIT_CNT;
+/*
+*
+* B.5      CALCULATE Bit position within byte Index where retrieval begins
+*/
+   ii = *iskip % WORD_BIT_CNT;
+
+/*
+*
+* B.6      CALCULATE #times to Right-shift the retrieved data so it 
+*          is right adjusted
+*/
+   mover = icon - ii;
+
+/*
+*
+* B.7.a    IF (need to right-adjust the byte) THEN
+*/
+   if ( mover > 0 )
+   {
+
+/*
+* B.7.a.1     RETRIEVE 4 continuous byte from offset Index in block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)inchar[index*4] << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* B.7.a.2     RIGHT adjust this value
+*/
+     *iout = inlong >> mover;
+/*
+* B.7.a.3     MASK out the bits wanted only    !result in *out
+*/
+     *iout = (*iout & mask);
+   } /* If */
+
+
+/*
+* B.7.b    ELSE IF (byte is split across a word break) THEN
+*/
+   else if ( mover < 0 )
+   {
+/*
+*             !
+*             !Get the valid bits out of the FIRST WORD
+*             !
+* B.7.b.1     CALCULATE #times to move retrieve data left so
+*             the 1st significant bit aligns with MSB of word
+* B.7.b.2     CALCULATE #times to move data that's aligned 
+*             with MSB so that it aligns with LSB of word
+*/
+      movel = -mover;
+      mover = WORD_BIT_CNT - movel;   /* WORD_BIT_CNT is 32 */
+
+/*
+* B.7.b.3     RETRIEVE 4-byte word from offset Index from block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* B.7.b.4     SHIFT retrieve this data all the way left !Left portion
+*/
+
+/*
+*             !
+*             !Now Get the valid bits out of the SECOND WORD
+*             !
+* B.7.b.5     RETRIEVE the next 4-byte word from block
+*/
+      *iout = inlong << movel;
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4+4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+5 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+6 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+7 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/* 
+* B.7.b.6     SHIFT this data all the way right   !Right portion
+* B.7.b.7     OR the Left portion and Right portion together
+* B.7.b.8     MASK out the #bits wanted only     !result in *iout
+*/
+      temp  = inlong >> mover;
+      *iout = *iout|temp;
+      *iout &= mask;
+/*
+  THE BYTE IS ALREADY RIGHT ADJUSTED.
+*/
+   }
+   else
+/*
+* B.7.c    ELSE    !the byte is already adjusted, no shifts needed
+*/
+   {
+/*
+* B.7.c.1     RETRIEVE the next 4-byte word from block
+*/
+     {
+       unsigned long l0, l1, l2, l3;
+       l0 = (unsigned long)(0x000000FF & inchar[index*4]) << 24;
+       l1 = (unsigned long)(0x000000FF & inchar[index*4+1 ]) << 16;
+       l2 = (unsigned long)(0x000000FF & inchar[index*4+2 ]) << 8;
+       l3 = (unsigned long)(0x000000FF & inchar[index*4+3 ]);
+       inlong = l0 + l1 + l2 + l3;
+     }
+/*
+* B.7.c.2     MASK out the bits wanted only    !result in *out
+*/
+      *iout = inlong&mask;
+   }
+/*
+* B.7.c    ENDIF    !the byte is already adjusted
+*/
+
+/*
+*
+* B.8      BUMP pointer up
+*/
+	*iskip += nbits;
+/* 
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib.h b/wrfv2_fire/external/io_grib1/MEL_grib1/grib.h
new file mode 100644
index 00000000..7983c22c
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib.h
@@ -0,0 +1,401 @@
+/*** FILE:  grib.h ***/
+/* Revisions:
+10/16/97/atn:  +usData_type to mercator, space view structs 
+11/04/97/atn:  reduced DEF+MSG_LEN  from 250k;
+02/18/98/atn:  + Projection codes; -ENC_DELIMITOR; -struct space_view;
+04/22/98/atn:  + extension flag;
+*/
+
+#define EXTENSION_FLAG 99	/* Implies extensions if equals PDS Oct41 */
+#define DEF_MSG_LEN    50000		/* size of GRIB HDR 's entire_msg */
+#define MAX_PROJ_SIZE  46               /* MaxSize of GDS minus 6 bytes*/
+					/* Currently set to LATLON; */
+/*#define MAX_INP_PROJ_SIZE 72*/	/* Size of Max Input GDS block, */
+					/* currently set to GDS_LATLON_INPUT */
+/* Todd Hutchinson 8/11/05 */
+/*
+ * The above definition for MAX_INP_PROJ_SIZE only works with machines that
+ *    have 4 byte long ints.  Here, we will quadruple this to handle up to 
+ *    16 byte long ints.  This was an issue on the IBM in 64 bit mode.
+ */
+#define MAX_INP_PROJ_SIZE 288
+
+/* WMO projection codes 
+	***  MUST keep parallel to 'prjn_name' array       *** 
+	***  IF altered, must also update the 'PRJ_COUNT'  *** 
+*/
+#define LATLON_PRJ		0
+#define MERC_PRJ		1
+#define LAMB_PRJ		3
+#define GAUSS_PRJ 	 	4
+#define POLAR_PRJ		5
+#define ALBERS_PRJ		8
+#define ROT_LATLON_PRJ		10
+#define OBLIQ_LAMB_PRJ		13
+#define ROT_GAUSS_PRJ	 	14
+#define STR_LATLON_PRJ		20
+#define STR_GAUSS_PRJ   	24
+#define STR_ROT_LATLON_PRJ	30
+#define STR_ROT_GAUSS_PRJ 	34
+
+#define PRJ_COUNT		35	/* num of elements in prjn_name[] */
+
+/* WMO projection names (use WMO codes above to index) */
+static char* 	prjn_name[] = {
+	"(0) Latitude/Longitude Grid",
+	"(1) Mercator Grid",
+	"(2) Unsupported Grid",
+	"(3) Lambert Grid",
+	"(4) Gaussian Grid",
+	"(5) Polar Grid",
+	"(6) Unsupported Grid",
+	"(7) Unsupported Grid",
+	"(8) Albers equal-area Grid",
+	"(9) Unsupported Grid",
+	"(10) Rotated Latitude/Longitude Grid",
+	"(11) Unsupported Grid",
+	"(12) Unsupported Grid",
+	"(13) Oblique Lambert Grid",
+	"(14) Rotated Gaussian Grid",
+	"(15) Unsupported Grid",
+	"(16) Unsupported Grid",
+	"(17) Unsupported Grid",
+	"(18) Unsupported Grid",
+	"(19) Unsupported Grid",
+	"(20) Stretched Latlon Grid",
+	"(21) Unsupported Grid",
+	"(22) Unsupported Grid",
+	"(23) Unsupported Grid",
+	"(24) Stretched Gaussian Grid",
+	"(25) Unsupported Grid",
+	"(26) Unsupported Grid",
+	"(27) Unsupported Grid",
+	"(28) Unsupported Grid",
+	"(29) Unsupported Grid",
+	"(30) Stretched Rotated Latlon Grid",
+	"(31) Unsupported Grid",
+	"(32) Unsupported Grid",
+	"(33) Unsupported Grid",
+	"(34) Stretched Rotated Gaussian Grid"
+	};
+	
+/*.................................................................*/
+typedef struct GRIB_HDR {	/* holds one Grib Msg & its info */
+   char shuffled;                       /* set if sections are out of order */
+   long	msg_length;			/* length in bytes of entire msg */
+   long ids_len;			/* length in bytes of Ident Sect  */
+   long pds_len; 			/* length in bytes of Prod Defn Sect */
+   long gds_len; 			/* length in bytes of Grid Defn Sect */
+   long bms_len; 			/* length in bytes of Bitmap Sect */
+   long bds_len; 			/* length in bytes of Bin Data Sect */
+   long eds_len; 			/* length in bytes of Ending Sect */
+   long abs_size;			/* num bytes malloced to entire_msg*/
+   unsigned char *entire_msg;		/* arr holding entire Grib msg */
+   unsigned char *ids_ptr;		/* pts to 'GRIB' w/in entire msg */
+   unsigned char *pds_ptr;		/* pts to PDS w/in entire msg */
+   unsigned char *gds_ptr;		/* pts to GDS w/in entire msg */
+   unsigned char *bms_ptr;		/* pts to BMS w/in entire msg */
+   unsigned char *bds_ptr;		/* pts to BDS w/in entire msg */
+   unsigned char *eds_ptr;		/* pts to '7777' w/in entire msg */
+}  GRIB_HDR;
+
+typedef struct PDS_INPUT{             /*  User input structure - PDS */
+   unsigned short   uslength;            /* PDS Length - depends on extensions */
+   unsigned short   usEd_num;            /* GRIB Edition number - #1 (IndS)  */
+   unsigned short   usParm_tbl;          /* Parameter table number (1)    */
+   unsigned short   usCenter_id;         /* Id of originating center (Table 0)*/
+   unsigned short   usProc_id;           /* Generating process Id number (Table A) */
+   unsigned short   usGrid_id;           /* Grid Identification (Table B)  */
+   unsigned short   usGds_bms_id;        /* GDS and BMS flag (Table 1)     */
+   unsigned short   usParm_id;           /* Parameter and unit id (Table 2) */
+   unsigned short   usLevel_id;          /* Type of level or layer id (Table 3/3a) */
+   unsigned short   usLevel_octets;      /* number of octets used in Table 3 (0, 1, 2 values) */
+   unsigned short   usHeight1;           /* Height1, pressure1,etc of level (Table 3)*/
+   unsigned short   usHeight2;           /* Height2, pressure2,etc of level (Table 3)*/
+   unsigned short   usYear;              /* Year of century -Initial or ref. */
+   unsigned short   usMonth;             /* Month of year   -time of forecast */
+   unsigned short   usDay;               /* Day of month                  */
+   unsigned short   usHour;              /* Hour of day                   */
+   unsigned short   usMinute;            /* Minute of hour                */
+   unsigned short   usFcst_unit_id;      /* Forecast time unit (Table 4)  */
+   unsigned long    usP1;                /* Period of time (Number of time units)  */
+   unsigned long    usP2;                /* Time interval between forecasts  */
+   unsigned short   usTime_range;        /* Time range indicator (Table 5)   */
+   unsigned short   usTime_range_avg;    /* Number included in average if flag set */
+   unsigned short   usTime_range_mis;    /* Number missing from average      */
+   unsigned short   usCentury;           /* Centry of Initial time (19)      */
+   unsigned short   usCenter_sub;        /* Oct 26: Sub Center id          */
+   short            sDec_sc_fctr;        /* Decimal scale factor             */
+   unsigned short   ausZero[12];         /* Reserved                         */
+   unsigned short   usExt_flag;	 	 /* Oct 41: Grib extensions usage flag*/
+   unsigned short   usSecond;		 /* Second of Minute	             */
+   unsigned short   usTrack_num;	 /* Tracking ID for data set	     */
+   unsigned short   usParm_sub;		 /* Sub-Table Entry for parameter and unit (Table 2) */
+   unsigned short   usSub_tbl;           /* Sub-Table version number */
+   /* WSI Extended PDS fields */
+   unsigned short PDS_41;          /* Forecast time 1 unit id - Table 4 */
+   long           PDS_42;          /* forecast time 1 (up to 4 bytes) */
+   unsigned short PDS_46;          /* Forecast time 2 unit id - Table 4 */
+   long           PDS_47;          /* forecast time 2 */
+   unsigned short PDS_51;          /* Time range indicator - Table 5 */
+  unsigned short PDS_52;           /* Top of atmosphere--used with sigma coord*/
+}PDS_INPUT;
+
+typedef struct GDS_LAM_INPUT {     /* Input: Lambert Conformal Grid */
+   unsigned short   usData_type;     /* Data representation type ( Table 6)    */
+   int		    iNx;                 /* Nx - # of points along x-axis   */
+   int		    iNy;                 /* Ny - # of points along y-axis   */
+   long             lLat1;               /* Latitude of first grid point    */
+   long             lLon1;               /* Longitude of first grid point   */
+   unsigned short   usRes_flag;          /* Resolution and component flag (Table 7)*/
+   long             lLon_orient;         /* Orientaion of grid - longitude  */
+   unsigned long    ulDx;                /* X-direction grid length         */
+   unsigned long    ulDy;                /* Y-direction grid length         */
+   unsigned short   usProj_flag;         /* Projection center flag          */
+   unsigned short   usScan_mode;         /* Scan mode                       */
+   long             lLat_cut1;           /* First latitude which secant cone cuts  */
+   long             lLat_cut2;           /* Second latitude from pole       */
+   long             lLat_southpole;      /* Latitude of southern pole (millidegree)*/
+   long             lLon_southpole;      /* Longitude of southern pole      */
+   int		    usZero;              /* Reserved (set to 0)             */
+}GDS_LAM_INPUT;
+
+typedef struct GDS_LATLON_INPUT{   /* Input: Latitude/Longitude Grid */
+   unsigned short   usData_type;     /* Data representation type ( Table 6)    */
+   int		    usNi;                /* Number of points along a parallel */
+   int		    usNj;                /* Number of points along a meridian */
+   long             lLat1;               /* Latitude of first grid point      */
+   long             lLon1;               /* Longitude of first grid point     */
+   unsigned short   usRes_flag;          /* Resolution and component flag (Table 7)*/
+   long             lLat2;               /* Latitude of last grid point       */
+   long             lLon2;               /* Longitude of last grid point      */
+   int              iDi;                 /* I-direction increment             */
+   int              iDj;                 /* J-direction increment             */
+   unsigned short   usScan_mode;         /* Scanning mode (Table 8)           */
+   long		    usZero;              /* Reserved (set to 0)               */
+   long             lLat_southpole;      /* Latitude of southern pole (millidegree)*/
+   long             lLon_southpole;      /* Longitude of southern pole        */
+   long             lRotate;             /* Angle of rotation                 */
+   long             lPole_lat;           /* Latitude of pole of stretching (millidegree) */
+   long             lPole_lon;           /* Longitude of pole of stretching   */
+   long             lStretch;            /* Stretching factor                 */
+}GDS_LATLON_INPUT;
+
+typedef struct GDS_PS_INPUT {     /* Input: Polar Stereographic Grid */
+   unsigned short   usData_type;     /* Data representation type ( Table 6)    */
+   unsigned short   usNx;                /* Nx - # of points along x-axis */
+   unsigned short   usNy;                /* Ny - # of points along y-axis */
+   long             lLat1;               /* Latitude of first grid point */
+   long             lLon1;               /* Longitude of first grid point */
+   unsigned short   usRes_flag;          /* Resolution and component flag (Table 7) */
+   long             lLon_orient;         /* Orientaion of grid - longitude */
+   unsigned long    ulDx;                /* X-direction grid length */
+   unsigned long    ulDy;                /* Y-direction grid length */
+   unsigned short   usProj_flag;         /* Projection center flag */
+   unsigned short   usScan_mode;         /* Scan mode */
+   unsigned short   usZero;              /* Reserved (set to 0) */
+} GDS_PS_INPUT;
+
+typedef struct mercator  /*  mercator grids */
+   {
+   unsigned short   usData_type;     /* Data representation type ( Table 6)    */
+   int cols;               /* Ni - Number of points along a latitude circle */
+   int rows;               /* Nj - Number of points along a longitude meridian */
+   long first_lat;         /* La1 - Latitude of first grid point */
+   long first_lon;         /* Lo1 - Longitude of first grid point */
+   unsigned short   usRes_flag;  /* Resolution and component flag (Table 7)*/
+   long La2;               /* latitude of last grid point, or # point / row */
+   long Lo2;               /* longitude of last grid point, or # point / column */
+   long latin;             /* Latin - the latitude at which the mercator 
+                                      projection intersects the earth */
+   unsigned short   usZero1;   /* Reserved (set to 0)                    */
+   unsigned short   usScan_mode; /* Scanning mode (Table 8)                */
+   float lon_inc;       /* Di - the longitudinal direction increment 
+                           (west to east) */
+   float lat_inc;       /* Dj - the latitudinal direction increment 
+                           (south to north) */
+   long             usZero;              /* Reserved (set to 0)                    */
+ }mercator;
+
+typedef struct BDS_HEAD_INPUT {          /* BDS Header Input                */
+   unsigned long    length;              /* BDS Length */
+   unsigned short   usBDS_flag;          /* BDS flag (Table 11)                    */
+   int              Bin_sc_fctr;         /* Binary scale factor                    */
+   float            fReference;          /* Reference value (minimum value)        */
+   unsigned short   usBit_pack_num;      /* Number of bits into which data is packed*/
+   unsigned long    ulGrid_size;         /* Number of grid points                  */
+   float            fPack_null;          /* Pack_null value for packing data       */
+}BDS_HEAD_INPUT;
+
+typedef struct GDS_HEAD_INPUT {        /* internal GDS Header Input */
+   unsigned short   usNum_v;             /* Number of vertical cords   */
+   unsigned short   usPl_Pv;             /* PV or PL location  */
+   unsigned short   usData_type;         /* Data representation type (Table 6)     */
+   unsigned short   uslength;            /* GDS Length - depends on projection */
+   int              *thin;               /* array to hold sizes of thinned rows */
+}GDS_HEAD_INPUT;
+
+typedef struct IDS_GRIB {              /* IDS -Indicator Section 0               */
+   unsigned char   szId[4];              /* "GRIB" Identifier                      */
+   unsigned char   achTtl_length[3];     /* Total length of GRIB msg               */
+   unsigned char   chEd_num;             /* GRIB Edition number  - #1              */
+} IDS_GRIB;
+
+typedef struct PDS_GRIB {              /* PDS -Product Definition Section 1       */
+   unsigned char    achPDS_length[3];    /* Section length (in octets)             */
+   unsigned char    chParm_tbl;          /* Parameter table number (1)             */
+   unsigned char    chCenter_id;         /* Id of originating center (Table 0)     */
+   unsigned char    chProc_id;           /* Generating process Id number (Table A) */
+   unsigned char    chGrid_id;           /* Grid Identification (Table B)          */
+   unsigned char    chGds_bms_id;        /* GDS and BMS flag (Table 1)             */
+   unsigned char    chParm_id;           /* Parameter and unit id (Table 2)        */
+   unsigned char    chLevel_id;          /* Type of level or layer id (Table 3/3a) */
+   unsigned char    achHeight[2];        /* Height, pressure,etc of level (Table 3)*/
+   unsigned char    chYear;              /* Year of century     -Initial or ref.   */
+   unsigned char    chMonth;             /* Month of year       -time of forecast  */
+   unsigned char    chDay;               /* Day of month                           */
+   unsigned char    chHour;              /* Hour of day                            */
+   unsigned char    chMinute;            /* Minute of hour                         */
+   unsigned char    chFcst_unit_id;      /* Forecast time unit (Table 4)           */
+   unsigned char    chP1;                /* Period of time (Number of time units)  */
+   unsigned char    chP2;                /* Time interval between forecasts        */
+   unsigned char    chTime_range;        /* Time range indicator (Table 5)         */
+   unsigned char    achTime_range_avg[2]; /* Number included in average if flag set */
+   unsigned char    chTime_range_mis;    /* Number missing from average            */
+   unsigned char    chCentury;           /* Centry of Initial time (19)            */
+   unsigned char    chCenter_sub;        /* Oct-26: Sub Center Id  */
+   unsigned char    achDec_sc_fctr[2];   /* Decimal scale factor                   */
+   unsigned char    achZero[12];         /* Reserved                               */
+
+   /* WSI Extended PDS fields */
+   unsigned char PDS_41;                 /* Forecast time 1 unit id - Table 4 */
+   unsigned char PDS_42[4];              /* forecast time 1 (up to 4 bytes) */
+   unsigned char PDS_46;                 /* Forecast time 2 unit id - Table 4 */
+   unsigned char PDS_47[4];              /* forecast time 2 */
+   unsigned char PDS_51;                 /* Time range indicator - Table 5 */
+   unsigned char PDS_52[2];           /* Top of atmosphere--used with sigma coord*/
+  
+  /* 
+   * The following was removed by Todd Hutchinson, WSI, 4/11/2002 
+   *   The extended pds section is now replaced with the values above
+   */
+  /* unsigned char    chExt_flag;          Oct-41: Grib extensions usage flag*/
+  /* unsigned char    chSecond;            Second of Minute                       */
+  /* unsigned char    chTrack_num[2];      Tracking ID for data set               */
+  /* unsigned char    chParm_sub;          Sub-Table Entry for parameter and unit (Table 2) */
+  /* unsigned char    chSub_tbl;           Sub-Table Version number */
+} PDS_GRIB;
+
+typedef struct GDS_HEAD {              /* GDS header                              */
+   unsigned char    achGDS_length[3];    /* Section length (in octets)             */
+   unsigned char    chNV;                /* # of vertical coord. parameters (not used)*/
+   unsigned char    chPV;                /* Location of vert. coord., 255 if none  */ 
+   unsigned char    chData_type;         /* Data representation type (Table 6)     */
+} GDS_HEAD;
+
+typedef struct LAMBERT {               /* Lambert Conformal Grid                  */
+   unsigned char    achNx[2];                /* Nx - # of points along x-axis          */
+   unsigned char    achNy[2];                /* Ny - # of points along y-axis          */
+   unsigned char    achLat1[3];          /* Latitude of first grid point           */
+   unsigned char    achLon1[3];          /* Longitude of first grid point          */
+   unsigned char    chRes_flag;          /* Resolution and component flag (Table 7)*/
+   unsigned char    achLon_orient[3];    /* Orientaion of grid - longitude         */
+   unsigned char    achDx[3];            /* X-direction grid length                */
+   unsigned char    achDy[3];            /* Y-direction grid length                */
+   unsigned char    chProj_flag;         /* Projection center flag                 */
+   unsigned char    chScan_mode;         /* Scan mode                              */
+   unsigned char    achLat_cut1[3];      /* First latitude which secant cone cuts  */
+   unsigned char    achLat_cut2[3];      /* Second latitude from pole              */
+   unsigned char    achLat_southpole[3]; /* Latitude of southern pole (millidegree)*/
+   unsigned char    achLon_southpole[3]; /* Longitude of southern pole             */
+   unsigned char    achZero[2];              /* Reserved (set to 0)                    */
+} LAMBERT;
+
+typedef struct POLAR {                   /* Polar Stereographic Grid */
+   unsigned char    achNx[2];            /* Nx - # of points along x-axis */
+   unsigned char    achNy[2];            /* Ny - # of points along y-ayis */
+   unsigned char    achLat1[3];          /* Latitude of first grid point */
+   unsigned char    achLon1[3];          /* Longitude of first grid point */
+   unsigned char    chRes_flag;          /* Resolution and component flag (Table 7) */
+   unsigned char    achLon_orient[3];    /* Orientaion of grid - longitude */
+   unsigned char    achDx[3];            /* X-direction grid length */
+   unsigned char    achDy[3];            /* Y-direction grid length */
+   unsigned char    chProj_flag;         /* Projection center flag */
+   unsigned char    chScan_mode;         /* Scan mode */
+   unsigned char    achZero[4];          /* Reserved (set to 0) */
+} POLAR;
+
+typedef struct MERCATOR {                /* Mercator Grid */
+  unsigned char     achNi[2];            /* Ni - Number of points along latitude circle */
+  unsigned char     achNj[2];            /* Nj - Number of points along longtitude meridian */
+  unsigned char     achLat1[3];          /* Latitude of first grid point */
+  unsigned char     achLon1[3];          /* Longtitude of first grid point */
+  unsigned char     chRes_flag;          /* Resolution and component flag (Table 7) */
+  unsigned char     achLat2[3];          /* latitude of last grid point */
+  unsigned char     achLon2[3];          /* longitude of last grid point */
+  unsigned char     achLatin[3];         /* latitude(s) at which the Mercator projection
+					    cylinder intersects the earth */
+  unsigned char     achZero1;            /* Reserved (set to 0) */
+  unsigned char     chScan_mode;         /* Scan mode */
+  unsigned char     achDi[3];            /* longitudinal direction increment (meters) */
+  unsigned char     achDj[3];            /* latitudinal direction increment (meters) */
+  unsigned char     achZero2[8];         /* Reserved (set to 0) */
+} MERCATOR;
+
+typedef struct LATLON {                  /* Input: Latitude/Longitude Grid          */
+   unsigned char    achNi[2];            /* Number of points along a parallel      */
+   unsigned char    achNj[2] ;           /* Number of points along a meridian      */
+   unsigned char    achLat1[3];          /* Latitude of first grid point           */
+   unsigned char    achLon1[3];          /* Longitude of first grid point          */
+   unsigned char    chRes_flag;          /* Resolution and component flag (Table 7)*/
+   unsigned char    achLat2[3];          /* Latitude of last grid point            */
+   unsigned char    achLon2[3];          /* Longitude of last grid point           */
+   unsigned char    achDi[2];             /* I-direction increment                  */
+   unsigned char    achDj[2];             /* J-direction increment                  */
+   unsigned char    chScan_mode;         /* Scanning mode (Table 8)                */
+   unsigned char    achZero[4];              /* Reserved (set to 0)                    */
+   unsigned char    achLat_southpole[3]; /* Latitude of southern pole (millidegree)*/
+   unsigned char    achLon_southpole[3]; /* Longitude of southern pole             */
+   unsigned char    achRotate[4];        /* Angle of rotation                      */
+   unsigned char    achPole_lat[3];      /* Latitude of pole of stretching (millidegree) */
+   unsigned char    achPole_lon[3];      /* Longitude of pole of stretching        */
+   unsigned char    achStretch[4];       /* Stretching factor                      */
+} LATLON;
+
+typedef struct BDS_HEAD {                /* Binary Data Section 4                     */
+   unsigned char    achBDS_length[3];    /* Section length                         */
+   unsigned char    chBDS_flag;          /* Flag (Table 11)                        */
+   unsigned char    achBin_sc_fctr[2];   /* Binary Scale Factor                    */
+   unsigned char    achReference[4];     /* Reference value (minimum value)IBM format*/
+   unsigned char    chBit_pack_num;      /* Number of bits into which data is packed*/
+} BDS_HEAD;
+
+typedef struct EDS_GRIB {                /* End Section 5                           */
+   unsigned char    szEDS_id[4];         /* "7777" Ascii characters                */
+} EDS_GRIB;
+
+typedef struct grid_desc_sec     /* Grid Description Section */
+{
+   struct GDS_HEAD_INPUT   head;     /* GDS Header section - common to all */
+   struct GDS_LATLON_INPUT llg;      /* Latitude/Longitude or Gaussian grids */
+   struct GDS_LAM_INPUT    lam;      /* lambert conformal grids */
+   struct GDS_PS_INPUT     pol;      /* polar stereographic grids */
+   struct mercator         merc;         /* mercator grids */
+}grid_desc_sec;
+
+typedef struct BMS_GRIB 		/* Bit Map Section 3 			*/
+{
+  unsigned char	 achBMS_length[3];	/* Section length			*/
+  unsigned char	 chUnused_bits;		/* #unused bits in bitmap stream	*/
+  unsigned char  achBMS_id[2];		/* 0 or a predefined bitmap id		*/
+} BMS_GRIB;
+
+typedef struct BMS_INPUT	/* User Input structure - BMS */
+{
+  unsigned long  uslength;	/* section length */
+  unsigned short usUnused_bits;	/* number of Unused bits */
+  unsigned short usBMS_id;	/* 0 or a predefined id  */
+  unsigned long  ulbits_set;	/* num of datapts present */
+  char		*bit_map;	/* pts to beg. of BM bstream */
+} BMS_INPUT;
+
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib_dec.c b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_dec.c
new file mode 100644
index 00000000..39ea75e0
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_dec.c
@@ -0,0 +1,272 @@
+#include               /* standard I/O header file          */
+#include 
+#include 
+#include "dprints.h"		/* for dprints & func prototype*/
+#include "gribfuncs.h"		/* prototypes */
+
+/* PROGRAMMER : Steve Lowe and Todd Kienitz, SAIC Monterey
+   DATE       : February 7, 1996
+                Oct. 1996 by Alice Nakajima, SAIC Monterey
+*
+*********************************************************************
+* A.  FUNCTION:  grib_dec
+*     decode a Gridded Binary (GRIB edition 1) format message
+*
+*    INTERFACE:
+*      int grib_dec (curr_ptr, pds, gds, bds_head, bms, ppgrib_data, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *curr_ptr;
+*           pointer to block containing GRIB message to decode;
+*      (O)  PDS_INPUT  *pds ;
+*           to be filled with decoded Product Defn Section info;
+*      (O)  grid_desc_sec  *gds;
+*           to be filled with decoded Binary Data Section info;
+*      (O)  BDS_HEAD_INPUT *bds_head;
+*           to be filled with decoded Binary Data Section info;
+*      (O)  BMS_INPUT *bms;
+*           to be filled with decoded Bitmap Section info;
+*      (O)  float **ppgrib_data;
+*           points to NULL upon entry; upon successful exit, points to newly
+*           malloced Float array filled with unpacked and restored data;
+*      (O)  char *errmsg;
+*           Empty array, Returned filled if error occurred;
+*
+*     RETURN CODE:
+*        0> Success, **ppgrib_data now points to a block containing
+*           the unpacked & restored data (float);
+*        1> Fail: first 4 bytes of curr_ptr is not 'GRIB'
+*        2> Fail: last 4 bytes of curr_ptr is not '7777'
+*        3> Fail: not Grib Edition 1
+*        4> Fail: unknown projection type;
+***********************************************************************
+*/
+
+#if PROTOTYPE_NEEDED
+int   grib_dec (char *curr_ptr, PDS_INPUT  *pds, grid_desc_sec  *gds,
+        	BDS_HEAD_INPUT *bds_head, BMS_INPUT *bms, float **ppgrib_data,
+        	char *errmsg)
+#else
+int grib_dec (curr_ptr, pds, gds, bds_head, bms, ppgrib_data, errmsg)
+  char          *curr_ptr; /*input= ptr to 1st byte of GRIB message block*/
+  PDS_INPUT     *pds;      /* output=ptr to Internal PDS struct*/
+  grid_desc_sec *gds;      /* output=ptr to Internal GDS struct*/
+  BDS_HEAD_INPUT*bds_head; /*out=ptr to Internal BDS header struct*/
+  BMS_INPUT     *bms;      /*output=ptr to Internal bitmap section struct*/
+  float         **ppgrib_data; /*outp=ptr to nothing upon entry; upon exit, */
+                           /* points to a newly malloced array of floats;  */
+  char          *errmsg;   /* output= empty unless Error happens */
+#endif
+{
+  char *func="grib_dec";
+  unsigned long lMessageSize;       /* message and section size */
+  long edition;                     /* GRIB edition number */
+  int flag;                         /* tests if a condition has happened */
+  int gds_flag;			    /* set if Gds present */
+  int nReturn = 0;
+  unsigned long skip;
+  float *outdata;
+  int xsize;
+  int j;
+
+/*
+*
+* A.0     DEBUG printing
+*/
+ DPRINT1 ("Entering %s\n", func);
+ DPRINT6 (
+  "curr_ptr=%ld, pds=%ld, gds=%ld\nbds_head=%ld, bms=%ld, ppgrib_data=%ld\n",
+  curr_ptr, pds, gds, bds_head, bms, ppgrib_data);
+/*
+*
+* A.1     IF (incoming pointer is not at 'GRIB') 
+*            RETURN 1  !errmsg filled
+*         ENDIF
+*/
+if(strncmp(curr_ptr,"GRIB",4) != 0) {
+  sprintf (errmsg,"%s:  no 'GRIB' at beg. of this msg\n", func);
+  nReturn= (1);   /* GRIB not found */
+ }
+
+/*
+*
+* A.2     FUNCTION gbyte   !get total message length from IDS 
+*/
+skip=32;
+gbyte(curr_ptr,&lMessageSize,&skip,24);
+DPRINT0 ("lMessageSize\n");
+
+/*
+*
+* A.3     IF (Message does not end with '7777') 
+*            RETURN 2  !errmsg filled
+*         ENDIF
+*/
+if(strncmp((curr_ptr + lMessageSize - 4),"7777",4)!=0) {
+  DPRINT1 ("%s:  no '7777' at end of this msg\n", func);
+  sprintf (errmsg,"%s:  no '7777' at end of this msg\n", func);
+  nReturn= 2; goto BYE;
+  }
+
+/*
+*
+* A.4     EXTRACT the  GRIB edition out of Section 0
+*         IF (not GRIB edition 1)
+*            RETURN 3  !errmsg filled
+*         ENDIF
+*/
+edition = (long) curr_ptr[7];        /* get edition */
+pds->usEd_num = (unsigned short) edition;
+if(edition != 1) {
+  DPRINT1 ("%s:  error, not Grib Edition 1 \n", func);
+  sprintf (errmsg,"%s:  not Grib Edition 1 \n", func);
+  nReturn=(3);   goto BYE;
+  }
+
+/*
+*
+* A.5     MOVE pointer to the Product Definition section
+*/
+curr_ptr = curr_ptr + 8;
+
+/* 
+*
+* A.6     FUNCTION gribgetpds  !decode the PDS 
+*         RETURN error code if fails  !errmsg filled
+*/
+if( nReturn= gribgetpds(curr_ptr, pds, errmsg)) {
+   DPRINT2 ("%s:  error=%d  in grib get pds;\n", func, nReturn);
+   upd_child_errmsg (func, errmsg);
+   goto BYE;
+  }
+
+/* 
+*
+* A.7     MOVE pointer to the end of PDS
+*/
+curr_ptr += pds->uslength;
+
+/*
+*
+* A.8     IF (GDS is present)
+*/
+gds_flag = pds->usGds_bms_id >> 7 & 1;
+if(gds_flag)  /* grid description section present */
+  {
+/*
+* A.8.1      FUNCTION gribgetgds   !decode GDS
+*            RETURN error code if fails  !errmsg filled
+*/
+   if( nReturn=gribgetgds(curr_ptr, gds, errmsg)) {
+      DPRINT2 ("%s:  error=%d  in grib get GDS;\n", func, nReturn);
+      upd_child_errmsg (func, errmsg);
+      goto BYE;
+       }
+
+/* 
+* A.8.2      MOVE the cursor to the next section (either BMS/BDS)
+*/
+   curr_ptr += gds->head.uslength;
+/* 
+* A.8.3      SET the number of data points depending on Projection
+*/
+   switch(gds->head.usData_type)
+  {
+     case LATLON_PRJ:    	/* Lat/Lon Grid */
+     case GAUSS_PRJ:    	/* Gaussian Latitude/Longitude grid */
+     case ROT_LATLON_PRJ:   	/* Rotated Lat/Lon */
+     case ROT_GAUSS_PRJ:   	/* Rotated Gaussian */
+     case STR_LATLON_PRJ:   	/* Stretched Lat/Lon */
+     case STR_GAUSS_PRJ :   	/* Stretched Gaussian */
+     case STR_ROT_LATLON_PRJ :  /* Stretched and Rotated Lat/Lon */
+     case STR_ROT_GAUSS_PRJ :   /* Stretched and Rotated Gaussian */
+       	bds_head->ulGrid_size = gds->llg.usNi * gds->llg.usNj;       
+	break;
+
+     case MERC_PRJ:  		/* Mercator Grid */
+       	bds_head->ulGrid_size = gds->merc.cols * gds->merc.rows; 
+	break;
+
+     case LAMB_PRJ:  		/* Lambert Conformal */
+     case ALBERS_PRJ:  		/* Albers equal-area */
+     case OBLIQ_LAMB_PRJ: 	/* Oblique Lambert Conformal */
+       	bds_head->ulGrid_size = gds->lam.iNx * gds->lam.iNy; 
+	break;
+
+     case POLAR_PRJ:  		/* Polar Stereographic */
+       	bds_head->ulGrid_size = gds->pol.usNx * gds->pol.usNy; 
+	break;
+
+     default: /* unknown */
+       DPRINT2 ("%s: unknown usData_type=%d\n",func,gds->head.usData_type);
+       sprintf(errmsg,"%s: unknown usData_type=%d\n", 
+	func, gds->head.usData_type);
+       nReturn= (4); goto BYE;
+     }
+  }
+/*
+* A.8     ENDIF (GDS is present)
+*/
+
+/*
+*
+* A.9     IF (bitmap Section is present)
+*/
+flag = pds->usGds_bms_id >> 6 & 1;
+if(flag)  /* bit map section present */
+  {
+/*
+* A.9.1      FUNCTION gribgetbms   !decode BMS
+*            RETURN error code if fails  !errmsg filled
+*/
+   if( nReturn=gribgetbms(curr_ptr,bms,gds_flag, bds_head->ulGrid_size,errmsg)) 
+   { 
+     DPRINT2 ("%s:  error=%d  in grib get BMS;\n",func,nReturn);
+     upd_child_errmsg (func, errmsg);
+     goto BYE;
+   } 
+
+/* 
+* A.9.2      MOVE the cursor to beginning of Binary Data Section
+*/
+     curr_ptr += bms->uslength;
+
+  } /* Bms present */
+/*
+* A.9     ENDIF  !bms present
+*/
+
+
+/*
+*
+* A.10    FUNCTION  gribgetbds()
+*         RETURN error code if failed  !errmsg filled
+*/
+  if(nReturn=gribgetbds(curr_ptr, pds->sDec_sc_fctr, bms, gds, ppgrib_data, 
+		bds_head, errmsg)) 
+   { 
+     DPRINT2 ("%s:  error=%d  in grib get BDS;\n",func,nReturn);
+     upd_child_errmsg (func, errmsg);
+     goto BYE;
+    }
+ 
+/*
+* 
+* A.11    SET return code to 0  !no errors
+*/
+  nReturn = 0;
+
+/*
+*
+* A.12    RETURN return code;
+*/
+BYE:
+  DPRINT2  ("Exit %s, Stat=%d\n", func, nReturn);
+  return(nReturn);
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+} 
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib_enc.c b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_enc.c
new file mode 100644
index 00000000..0be136d7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_enc.c
@@ -0,0 +1,599 @@
+/*
+ REVISIONS:
+ 10/15/96 A. Nakajima, SAIC:  removed 'write_grib' call; make combined lib;
+ 11/03/97 /ATN  -Realloc
+*/
+#include 
+#include 
+#include 
+#ifdef XT3_Catamount
+#include 
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#else
+#include 
+#endif
+#include "dprints.h"		/* for dprints */
+#include "grib_lookup.h"	/* parm/model/lvl defn */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+****************************************************************************
+* A.  FUNCTION:  grib_enc
+*        to encode a GRIB Edition 1 message using the three
+*        input internal structures (DATA_INPUT, USER_INPUT, GEOM_IN),
+*        and the Floating point data array;  
+*        It's ok for Float array to be null if Grib Hdr shows that
+*        it contains a predefined BDS;  that case, just exits w/ no errs;
+*
+*    INTERFACE:
+*      int grib_enc (Data_Input, User_Input, Geom_In, pfData_Array, gh, errmsg)
+*      
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  DATA_INPUT Data_Input;
+*           Structure containing input field information.  
+*      (I)  USER_INPUT User_Input;
+*           Structure containing encoder configuration data.
+*      (I)  GEOM_IN Geom_In;
+*           Structure containing grid geometry description.
+*    (I&O)  float *pfData_Array;
+*           array of float data to be packed and stored in the Binary Data 
+*           Section.  Float array may be Null if the Grib Header already
+*           contains a Binary Data Section in its attribute 'entire_msg'.
+*           That case is referred to as the 'Shuffle Mode' which results
+*           in the encoder to only create the sections which are not already
+*           in entire_msg;  
+*           Note: non-null data array will be returned with the data being 
+*           scaled up by the Decimal Scale Factor.
+*    (I&O)  GRIB_HDR *gh;
+*           Pre-malloced structure used to hold the encoded GRIB message 
+*           and its info.  It contains a large array to hold the encoded
+*           message, pointers to each of the Section along with their length,
+*           and a flag 'shuffled' which determines how the message is encoded.
+*           If 'shuffled' is zero upon entry, all 6 sections will be created 
+*           and array (float *pfData_Array) must contain the float data.
+*           If 'shuffled' is set upon entry, there is already one or more
+*           sections in Entire_msg;  Each of these pre-included sections
+*           sections will have a Non-Null pointer & a non-Zero length. 
+*           The encoder will then only create the missing sections and
+*           append them at the end of the existing sections in array
+*           'entire_msg', hence these sections may not be in the proper 
+*           order expected by GRIB.
+*      (O)  char *errmsg
+*           Empty array, returned filled if error occurred;
+*
+*    RETURN VALUE:  
+*       0>  no errors;   
+*           GRIB_HDR is returned with the encoded message in 'entire_msg',
+*           w/ total message length in msg_length,
+*           w/ pointers to each defined Grib Header Sections in
+*           ids_ptr, pds_ptr, gds_ptr, bms_ptr, gds_ptr, eds_ptr,
+*           and each section length in ids_len, pds_len, gds_len, bms_len,
+*           bds_len, eds_len;  Note that the sections may not be in order if
+*           the 'shuffled' bit is set;
+*       1>  failed,  msg in errmsg;
+****************************************************************************/
+#if PROTOTYPE_NEEDED
+int grib_enc   (DATA_INPUT Data_Input, USER_INPUT User_Input, GEOM_IN Geom_In,
+        	float *pfData_Array, GRIB_HDR *gh, char *errmsg)
+#else
+int grib_enc   (Data_Input, User_Input, Geom_In, pfData_Array, gh, errmsg)
+		DATA_INPUT Data_Input; 
+		USER_INPUT User_Input; 
+		GEOM_IN Geom_In;
+        	float *pfData_Array; 
+		GRIB_HDR *gh; 
+		char *errmsg;
+#endif
+{
+   PDS_INPUT 		*pPDS_Input= 0;		/* internal Pds struc */
+   GDS_HEAD_INPUT       *pGDS_Head_Input = 0;   /* Internal Gds struc */
+   void                 *pvGDS_Proj_Input = 0;	/* depends on Projection*/
+   BDS_HEAD_INPUT       *pBDS_Head_Input = 0;   /* Internal Bds struc */
+   char			*func= "grib_enc";
+   char 		*Sevens= "7777";
+   int                  gdsbms_flag= 0;		/* whether to include them */
+   unsigned char	*px;			/* working ptr w/in EntireMsg */
+   long			lTemp;			/* working var */
+   int			n,Stat= 1;		/* default to error */
+
+   DPRINT1 ("Entering %s...\n", func);
+/*
+*
+* A.1          IF (ptr is null or if the Entire_msg buffer is null) THEN
+*                 RETURN 1 !errmsg filled
+*              ENDIF
+*/
+   if (!gh || !gh->entire_msg) 
+	{  
+	sprintf (errmsg, "%s: expecting non-null GRIB_HDR struct\n", func);
+	goto BYE; 
+	}
+
+/*
+*
+* A.2          CREATE storage for the Internal structures;
+*                  ! PDS_INPUT
+*                  ! GDS_HEAD_INPUT
+*                  ! GDS_Proj_Input set to MAX_INP_PROJ_SIZE defined in grib.h
+*                  ! BDS_HEAD_INPUT
+*              RETURN with Malloc Err in errmsg if fails;
+*              INITIALIZE Internal structures
+*/
+   if (! (pPDS_Input= (PDS_INPUT *)malloc(sizeof(PDS_INPUT))) ||
+       ! (pGDS_Head_Input =(GDS_HEAD_INPUT*)malloc(sizeof(GDS_HEAD_INPUT))) ||
+       ! (pvGDS_Proj_Input= (void *) malloc (MAX_INP_PROJ_SIZE))  ||
+       ! (pBDS_Head_Input =(BDS_HEAD_INPUT*)malloc(sizeof(BDS_HEAD_INPUT))))
+	{
+        sprintf(errmsg,"%s:  failed to make storage for Internal Structs\n",
+	func);
+	goto BYE; 
+	}
+   memset ((void *) pPDS_Input, '\0', sizeof(PDS_INPUT));
+   memset ((void *) pGDS_Head_Input, '\0', sizeof (GDS_HEAD_INPUT));
+   memset ((void *) pvGDS_Proj_Input,'\0', MAX_INP_PROJ_SIZE);
+   memset ((void *) pBDS_Head_Input, '\0', sizeof (BDS_HEAD_INPUT));
+
+/*
+*
+* A.3          IF (creating all sections) 
+*              ! ** (shuffled == 0) **
+*              ! user passed Float data in, and the GribHdr's
+*              ! Entire_Msg array has no valid data in it;
+*              ! Must 'put' all Sections 0 thru 5 into Grib Hdr in that order;
+* A.3.a        THEN
+*/
+   if (! gh->shuffled) 
+        { 
+	/* Create All Sections mode:  user must send float data */
+        DPRINT0 ("(SHUFFLE=0)  Create ALL sections mode\n");
+
+/*
+* A.3.a.1          RETURN if Float array is Null;  !errmsg filled
+*/
+	if ( !pfData_Array) 
+	  {
+	   sprintf(errmsg,
+	  "%s:   No DataArray avail to encode\n",func);
+	   goto BYE;
+	   }
+
+/*
+* A.3.a.2          CLEAR out the length and section ptrs
+*                  ASSIGN beginning of Entire Msg to 'px', as location to 
+*                  append things to;
+*/
+	gh->msg_length= gh->eds_len= gh->pds_len= gh->gds_len= 0;
+	gh->bms_len= gh->bds_len= gh->eds_len= 0;
+	gh->eds_ptr= gh->pds_ptr= gh->gds_ptr= NULL;
+	gh->bms_ptr= gh->bds_ptr= gh->eds_ptr= NULL;
+	px = gh->entire_msg; /* append from here on */
+/*
+*
+* A.3.a.3          BUILD IDS SECTION
+*                  SET up pointer to IDS
+*                  SET up IDS length  (8 for Edition 1)
+*                  WRITE the Ident Data Section to Grib Hdr
+*                  UPDATE 'px' to end of IDS !where to write next section
+*/
+	gh->ids_len = 8; 
+	gh->msg_length += 8L;
+	gh->ids_ptr = px;
+	memcpy  ((void *) gh->ids_ptr, (void *)"GRIB....", 8);
+	px = gh->entire_msg + gh->msg_length;
+	DPRINT3 ("%s: 'putting' IDS (%ld), msg_len=%ld\n",
+	func, gh->ids_len,gh->msg_length);
+
+/*
+*
+* A.3.a.4          FUNCTION gribputpds   !Build PDS Section into GRIB_HDR
+*                  IF failed
+*                  THEN return with error !errmsg filled
+*                  ELSE  bump 'px' to end of this section
+*/
+        if (n= gribputpds (Data_Input, User_Input, pPDS_Input, &gh, errmsg)) 
+	 { 
+	   upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+	else   px = gh->entire_msg + gh->msg_length;
+
+	DPRINT3("%s: Encoding PDS (%ld), msg_len=%ld\n",
+	func, gh->pds_len,gh->msg_length);
+
+/*
+*
+* A.3.a.5          FUNCTION gribputgds  !Build GDS Section into GRIB_HDR
+*                  IF failed
+*                  THEN return with error !errmsg filled
+*                  ELSE  bump 'px' to end of this section
+*/
+ if ((int) (User_Input.usGds_bms_id) >= 128)
+      {
+           if ( n = gribputgds (Geom_In, 
+	    	       pGDS_Head_Input, &pvGDS_Proj_Input, &gh, errmsg) )
+	     { 
+	       upd_child_errmsg (func, errmsg);
+	       goto BYE; 
+	     }
+           else   px = gh->entire_msg + gh->msg_length;
+
+           DPRINT3 ("%s: Encoding  GDS (%ld), msg_len=%ld\n",
+	    func, gh->gds_len,gh->msg_length);
+      }
+        else DPRINT1 ("%s: SKIPPING GDS!\n", func);
+
+/*
+*
+* A.3.a.6          Force no BMS by default
+*/
+	gh->bms_ptr=0; gh->bms_len= 0; 
+	DPRINT1 ("%s: Skipping BMS by default\n", func);
+
+/*
+*
+* A.3.a.7          FUNCTION gribputbds  Build BDS Section into GRIB_HDR
+*                  IF failed
+*                  THEN return with error !errmsg filled
+*                  ELSE  bump 'px' to end of this section
+*/
+        if (n= gribputbds (User_Input, Geom_In.nx*Geom_In.ny, 
+			pPDS_Input->sDec_sc_fctr, 
+			pfData_Array, 
+			pBDS_Head_Input, &gh, errmsg)) 
+	 { 
+	   upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+       else   px = gh->entire_msg + gh->msg_length;
+
+       DPRINT3 ("%s: Encoding BDS (%ld), msg_len=%ld\n",
+		func, gh->bds_len,gh->msg_length);
+
+/*
+*
+* A.3.a.8          IF (Entire Msg buffer isn't big enough to hold EDS)
+*                  THEN
+*                     FUNCTION Expand_gribhdr    !make it 4 bytes larger
+*                     RETURN with Error if fails !errmsg filled
+*                  ENDIF
+*                  SET up pointer to EDS
+*                  WRITE Grib EDS section to the end of Data !"7777"
+*                  UPDATE Grib Hdr's Eds_Ptr, Eds_Len 
+*/
+       if (gh->msg_length > gh->abs_size 
+	&& Expand_gribhdr (gh, gh->msg_length, errmsg) != 0)
+	 { 
+	   upd_child_errmsg (func, errmsg); 
+	   goto BYE; 
+	 }
+
+       gh->eds_ptr= px;
+       gh->eds_len= 4;
+       gh->msg_length += gh->eds_len;
+       memcpy ((void *)gh->eds_ptr, (void*)Sevens, 4);
+       DPRINT3 ("%s: 'putting' EDS (%ld), msg_len=%ld\n",
+       func, gh->eds_len,gh->msg_length);
+
+  } /* END SHUFFLED == 0 SECTION */
+
+/*
+* A.3.b        ELSE 
+*              ! ** (shuffled == 1) **
+*              ! means that user has already put 1/more GRIB sections 
+*              ! in GRIB_HDR struct's Entire_Msg;  The already included
+*              ! Sections may not be in proper GRIB-format order, and have 
+*              ! non-null Pointers and non-zero length;  Msg_Length also 
+*              ! reflects total length of all included sections;  
+*              ! -if the Float data is Null, the Bds must already be included
+*              ! in the Grib Hdr;  Func will return error if the Bds pointer
+*              ! is Null or the Bds Len is zero;  
+*              ! -if the incoming Float data has data and the Grib hdr shows
+*              ! that BMS is already defined then the func will Ignore the
+*              ! float data;
+*              ! otherwise, the float data will be used to create a new
+*              ! Binary Data Section;
+*              ! Only need to 'put' the Sections that have not already been 
+*              ! included in the Grib Header;  
+*/
+   else {  /* Shuffle Mode:  Create Missing Sections mode */
+
+/*
+* A.3.b.1          IF (there is discrepency in section pointers and length)
+*                      RETURN 1  !errmsg filled
+*                  ENDIF
+*/
+	if (  (gh->ids_ptr && !gh->ids_len) || (gh->ids_len && !gh->ids_ptr)
+	   || (gh->pds_ptr && !gh->pds_len) || (gh->pds_len && !gh->pds_ptr)
+	   || (gh->gds_ptr && !gh->gds_len) || (gh->gds_len && !gh->gds_ptr)
+	   || (gh->bms_ptr && !gh->bms_len) || (gh->bms_len && !gh->bms_ptr)
+	   || (gh->bds_ptr && !gh->bds_len) || (gh->bds_len && !gh->bds_ptr)
+	   || (gh->eds_ptr && !gh->eds_len) || (gh->eds_len && !gh->eds_ptr)
+	   || (gh->entire_msg && !gh->msg_length) 
+	   || (gh->msg_length && !gh->entire_msg)  )
+	    {
+	    sprintf (errmsg,
+	    "%s:  GribHdr Length/Ptr to sections are not consistent\n", func); 
+	    goto BYE;  
+	    }
+
+/*
+* A.3.b.2          IF (no float array was passed in AND 
+*                      Grib Hdr shows BDS is undefined) THEN
+*                      RETURN 1 !errmsg filed
+*                  ENDIF
+*/
+	if ( !pfData_Array && !gh->bds_ptr) {
+	   sprintf(errmsg, 
+	   "%s:  No DataArray avail to encode Bds\n",
+	   func);
+	   goto BYE;
+	   }
+
+/*
+* A.3.b.3          IF (user did send in float array AND 
+*                      Grib Hdr shows BDS is already defined) THEN
+*                      PRINT warning   !won't encode float array
+*                  ENDIF
+*/
+	if ( pfData_Array && gh->bds_ptr && gh->bds_len>0) {
+	   DPRINT2 ("%s: GribHdr already has a BDS (Len=%ld), " \
+	   " not going to encode the Float Data\n" , func, gh->bds_len);
+	 }
+
+	DPRINT7 ("(SHUFFLE=1)  gribhdr contains msg with totlen=%ld\n" \
+	        "   IDS(%d), PDS(%d), GDS(%d), BMS(%d), BDS(%d), EDS(%d)\n",
+		gh->msg_length, gh->ids_len, gh->pds_len, gh->gds_len,
+		gh->bms_len, gh->bds_len, gh->eds_len);
+
+/*
+* A.3.b.4          ASSIGN to local ptr 'px' the address of Msg_length bytes
+*                  away from Entire Msg, as location to append things to;
+*/
+	 px = gh->entire_msg + gh->msg_length; /* append from here */
+	  
+/*
+*
+* A.3.b.5          IF (GribHdr has no IDS yet)
+*                  THEN
+*                      SET up pointer to IDS
+*                      SET up IDS length  (8 for Edition 1)
+*                      WRITE the Ident Data Section to Grib Hdr
+*                      !use dummy message length for now
+*                      UPDATE 'px' to end of IDS !where to write next section
+*                  ENDIF
+*/
+   if ( gh->ids_ptr==NULL ) 
+     {
+	gh->ids_len = 8; 
+	gh->msg_length += 8L;
+	gh->ids_ptr = px;
+	memcpy  ((void *) gh->ids_ptr, (void *)"GRIB....", 8);
+	px = gh->entire_msg + gh->msg_length;
+	DPRINT3 ("%s: 'putting' IDS (%ld), msg_len=%ld\n",
+	func, gh->ids_len,gh->msg_length);
+    }
+  else DPRINT1 ("%s: skip writing IDS\n", func);
+
+/*
+*
+* A.3.b.6          IF (GribHdr has no PDS yet)
+*                  THEN
+*                      FUNCTION gribputpds  !Build PDS Section into GRIB_HDR
+*                      IF failed
+*                      THEN return with error !errmsg filled
+*                      ELSE  bump 'px' to end of this section
+*                  ENDIF
+*/
+   if ( gh->pds_ptr==NULL)  
+     {
+        if (n= gribputpds (Data_Input, User_Input, pPDS_Input, &gh, errmsg)) 
+	 { 
+	   DPRINT2 ("%s:  got err=%d in Grib Put Pds()\n",func,n);
+	   upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+	else   px = gh->entire_msg + gh->msg_length;
+
+	DPRINT3("%s: 'putting' PDS (%ld), msg_len=%ld\n",
+	func, gh->pds_len,gh->msg_length);
+     }
+  else DPRINT1("%s:  skip writing PDS\n", func);
+
+/*
+*
+* A.3.b.7          IF (GribHdr has no GDS yet)
+*                  THEN
+*                      FUNCTION gribputgds  !Build GDS Section into GRIB_HDR
+*                      IF failed
+*                      THEN return with error !errmsg filled
+*                      ELSE  bump 'px' to end of this section
+*                  ENDIF
+*/
+
+   if ((gh->gds_ptr==NULL) && (User_Input.usGds_bms_id >= 128))
+    {
+       if ( n = gribputgds (Geom_In, 
+	    	   pGDS_Head_Input, &pvGDS_Proj_Input, &gh, errmsg) )
+	 { 
+	   DPRINT2 ("%s:  got err=%d in Grib Put Gds()\n",func,n);
+	   upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+       else   px = gh->entire_msg + gh->msg_length;
+
+       DPRINT3 ("%s: 'putting' GDS (%ld), msg_len=%ld\n",
+	func, gh->gds_len,gh->msg_length);
+    }
+  else DPRINT1 ("%s:  skip writing GDS\n", func);
+
+/* 
+*
+* A.3.b.8          CHECK consistency on Gds/Bms flag
+*                  IF (GDS is included) 
+*                  THEN SET the GdsPresent bit
+*                  ELSE CLEAR the GdsPresent bit 
+*                  ENDIF
+*/
+  gdsbms_flag = (int)gh->pds_ptr[7] & 0x000000FF;
+  DPRINT1 ("orig gds/bms flag, pds[7] = 0x%x\n", gdsbms_flag);
+
+  if (gh->gds_ptr == NULL) {
+	 gdsbms_flag &= ~(0x00000080); 	
+	 DPRINT2 ("%s: GDS missing, so CLEAR 0x80;  newFLG=0x%x, \n", 
+	 func, gdsbms_flag);
+	}
+  else { 
+	 gdsbms_flag |= (0x00000080); 
+	 DPRINT2 ("%s: GDS Present, so SET 0x80;  newFLG=0x%x, \n", 
+	 func, gdsbms_flag);
+	 /* 
+ 	    DONOT set grid id to 255, since it is possible for user to
+	    define a new grid with id w/in range, and still include GDS;
+ 	  */
+	}
+
+/* 
+*
+* A.3.b.9          IF (BMS is there) THEN
+*                      SET the BmsPresent bit
+*                  ELSE
+*                      CLEAR the BmsPresent bit
+*                  ENDIF
+*/
+  if (gh->bms_ptr == NULL) {
+	 gdsbms_flag &= ~(0x00000040);
+	 DPRINT2 ("%s: no BMS, so CLEAR 0x40; new FLG=0x%x",func,gdsbms_flag);
+	}
+  else { gdsbms_flag |= (0x00000040);
+	 DPRINT2("%s: BMS Present, so SET 0x40; new FLG=0x%x",func,gdsbms_flag);
+	}
+
+   gh->pds_ptr[7] = (unsigned char)gdsbms_flag;
+   DPRINT1 ("; PDS_ptr[7]= %x\n",gh->pds_ptr[7]);
+
+/*
+*
+* A.3.b.10         IF (GribHdr has no BDS yet) THEN 
+*                      FUNCTION gribputBds  !Build BDS Section into GRIB_HDR
+*                      !**NOT doing anything to Data even if BMS is included ***
+*                      IF failed
+*                      THEN return with error !errmsg filled
+*                      ELSE  bump 'px' to end of this section
+*                  ENDIF
+*/
+   if ( gh->bds_ptr==NULL )
+    {
+        if (n= gribputbds (User_Input, Geom_In.nx*Geom_In.ny, 
+			pPDS_Input->sDec_sc_fctr, 
+			pfData_Array, 
+			pBDS_Head_Input, &gh, errmsg)) 
+	 { 
+	   DPRINT2 ("%s:  got err=%d in Grib Put BDS()\n",func,n);
+	   upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+       else   px = gh->entire_msg + gh->msg_length;
+
+       DPRINT3 ("%s: 'putting' BDS (%ld), msg_len=%ld\n",
+		func, gh->bds_len,gh->msg_length);
+    }
+  else DPRINT1("%s: skip writing BDS\n", func);
+
+/*
+*
+* A.3.b.11         IF (GribHdr has no EDS yet)
+*                  THEN
+*                    IF (Entire Msg buffer isn't big enough to hold EDS)
+*                     FUNCTION Expand_gribhdr    !make it 4 bytes larger
+*                     RETURN with Error if fails !errmsg filled
+*                  ENDIF
+*                  SET up pointer to EDS
+*                  WRITE Grib EDS section to the end of Data !"7777"
+*                  UPDATE Grib Hdr's Eds_Ptr, Eds_Len 
+*/
+   if ( gh->eds_ptr==NULL ) 
+   {
+       if (gh->msg_length+5L > gh->abs_size ) {
+    	  DPRINT1 ("Need to expand gribhdr (%ld) to hold EDS\n", 
+	  gh->abs_size);	  
+          /*if (NULL == (realloc (gh->entire_msg, gh->msg_length))) */
+
+	  if (Expand_gribhdr (gh, gh->msg_length+5L, errmsg) ) {
+	     upd_child_errmsg (func, errmsg);
+	     goto BYE;
+	  }
+	  DPRINT1("gribhdr now has abs_size of %ld\n",
+	  gh->abs_size);
+
+	}  /* size changed */
+
+       gh->eds_ptr= px;
+       gh->eds_len= 4;
+       gh->msg_length += gh->eds_len;
+       memcpy ((void *)gh->eds_ptr, (void*)Sevens, 4);
+       DPRINT3 ("%s: 'putting' EDS (%ld), msg_len=%ld\n",
+       func, gh->eds_len,gh->msg_length);
+  }
+  else DPRINT1 ("%s:  skip writing EDS\n", func);
+
+/*
+* A.3          ENDIF
+*/
+        } /* END SHUFFLED == 1 SECTION */
+
+/*
+*
+* A.4          UPDATE Total Msg Length in Grib Hdr's Ident Data Sect
+*/
+   set_bytes(gh->msg_length, 3, gh->ids_ptr+4);
+   
+   /* 1 is for the Edition  1 */   
+   set_bytes(1,1,gh->ids_ptr+7);
+
+/*
+*
+* A.5          SET status to 0  ! no errors
+*/
+   Stat = 0;
+   
+
+BYE:
+/*
+*
+* A.6          PRINT message if error occurred
+*/
+  if (errmsg[0]!='\0') DPRINT1("%s\n", errmsg);
+/*
+*
+* A.7          FREE up space of local Input structures
+*
+* A.8          RETURN stat
+*/
+  /* 
+   * Changed by Todd Hutchinson, TASC
+   * With this original code, not all memory was being freed
+   */
+  /* Original
+  if (! pPDS_Input)  free(pPDS_Input);
+  if (! pGDS_Head_Input) free(pGDS_Head_Input);
+  if (! pvGDS_Proj_Input) free(pvGDS_Proj_Input);
+  if (! pBDS_Head_Input) free(pBDS_Head_Input);
+  */
+  /* New: */
+  free(pPDS_Input);
+  free(pGDS_Head_Input);
+  free(pvGDS_Proj_Input);
+  free(pBDS_Head_Input);
+
+  DPRINT3 ("Leaving %s (Msglen=%ld), stat=%d\n", func, gh->msg_length,Stat);
+  return Stat;
+
+/*
+*
+* END OF FUNCTION
+*
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib_lookup.h b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_lookup.h
new file mode 100644
index 00000000..5ffcdee1
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_lookup.h
@@ -0,0 +1,154 @@
+/* FILE:  grib_lookup.h   
+ Decoder Lookup Table (ie. g1tab_128_2.2) shows how to convert from GRIB
+ units to DB units;
+ Encoder Lookup Table (ie. neons2grib.2.2) shows how to convert from DB
+ units to GRIB units;
+
+Revisions:
+12/96 A.Nakajima +debug print
+07/97 atn: +LPRINT, +List_xxx;
+...............................................................*/
+#include 
+#include 
+#include 
+
+#ifndef  TABLES_H
+#define  TABLES_H
+#define  ADD_DEC   	1L
+#define  ADD_ENC   	2L
+#define  NEW_ENTRY 	3L
+#define  NO_NUM	   	INT_MAX	/* +32767 */
+#define  NO_FNUM   	FLT_MAX   	/*  1E+37 */
+#define  LPRINT 	if (logfile!=NULL) fprintf
+
+enum { 
+   NOTFOUND, FOUND, NULL_OK, NO_NULL, NO_SPACE, SPACE_OK, YES, NO, 
+   OK, SKIP, ABORT 
+   };
+
+/* 
+*   Use this to index the db_tbl_name[] array, so any changes would
+*   require updating db_tbl_name[] also.  
+*  To add new Parm tables, insert it before the Model_Type;
+*/
+enum struct_types {
+    	Parm0_Type=0, ParmA_Type, ParmB_Type,ParmC_Type, ParmD_Type, ParmE_Type,
+    	Model_Type, Level_Type, Geom_Type
+  };
+#define  MAX_PARM_TBLS   	(ParmE_Type-Parm0_Type + 1)
+
+static char *db_tbl_name[]= {
+    	"PARMTBL-0","PARMTBL-A","PARMTBL-B","PARMTBL-C","PARMTBL-D","PARMTBL-E",
+    	"MODEL-TBL","LEVEL-TBL","GEOM-TBL"
+   };
+
+#define  NPARM 	   256
+#define  NLEV 	   256
+#define  NGEOM 	   256
+#define  NMODEL    256
+#define  NOCTR 	   256
+#define  NCTRS     256
+
+#define  EMPTY_PARM(x)  	(!(x)->grib_dsc[0] && !(x)->db_name[0])
+#define  EMPTY_LEVEL(x) 	(!(x)->grib_dsc[0]  && !(x)->db_name[0])
+#define  EMPTY_MODEL(x) 	(!(x)->grib_dsc[0] && !(x)->db_name[0])
+#define  EMPTY_GEOM(x)  	(!(x)->grib_dsc[0] && !(x)->db_name[0])
+
+#define  PARMTBL_INDX(Parm_id, Parm_sub)   \
+	(Parm_id>249 && Parm_sub!=0 ? ((Parm_id-249)*NPARM+Parm_sub):Parm_id)
+#define  LIST_GEOM(unit,cell)  	\
+	 fprintf((unit),"Geom=%03d:\n    grib_dsc='%s'\n    db_name='%s'\n\n",\
+	 	(cell)->usGeom_id, (cell)->grib_dsc, (cell)->db_name);
+#define  LIST_PARM(unit,curr_Type,cell)	\
+	 fprintf ((unit),						\
+     		"%s  Parm_id=%d,  Parm_sub=%d  (Index= %d):\n" 		\
+     		"    Descr='%s' Unit='%s'\n"				\
+     		"    DBName='%s' Scl=%.3f Offs=%.3f DSF=%d\n\n",	\
+		db_tbl_name[curr_Type],					\
+     		(cell)->usParm_id,  (cell)->usParm_sub,			\
+     		PARMTBL_INDX ((cell)->usParm_id,(cell)->usParm_sub),	\
+     		(cell)->grib_dsc, (cell)->grib_unit_dsc, (cell)->db_name, \
+     		(cell)->fScale, (cell)->fOffset, (cell)->sDSF);
+#define  LIST_LVL(unit,cell)		\
+	fprintf ((unit), 						\
+		"Level=%03d: '%s' %d octs\n   name1='%s'\n"		\
+		"   name2='%s'\n   db_name='%s' Scl=%.3f Offs=%.3f\n\n",  \
+        	(cell)->usLevel_id, (cell)->grib_dsc, (cell)->num_octets, \
+		(cell)->lvl_name_1, (cell)->lvl_name_2, (cell)->db_name, \
+		(cell)->fScale, (cell)->fOffset);
+#define  LIST_MODEL(unit,cell)		\
+	fprintf ((unit),		\
+		"Model=%03d:\n    grib_dscr='%s'\n    db_name='%s'\n\n",\
+   		(cell)->usModel_id, (cell)->grib_dsc, (cell)->db_name);
+
+/******************************************************************
+ The following structs hold Parameter, Level, Model and Geom info;
+ They are loaded from the external 'lookup tables';
+ The following structs are used as ARRAY of structures, where # elements
+ depends on what type of structs they are (usually 256 as defined in 
+ the # defines lines above;
+ ******************************************************************/
+
+typedef struct parm_defn  { /****  PARAMETER:   GRIB vs. Neons */
+     /* for a given ParmId & ParmSub, get Index within Db_Parm_Tbl
+	via PARMTBL_INDX(Parm_id, Parm_sub)
+	Index 249 through 255 denote Sub-Tables Defs only when Parm_sub > 0;
+	In that case usParm_id tells which Sub-Tbl we're in and usParm_sub
+	tells which element of that Table to access;
+	SubTbl-A  usParm_id 249  usParm_sub
+
+	and
+        Db_Parm_Tbl[0-249,255],
+		{  usParm_id = usGribCode (1-255); SubParm=0; }
+        Db_Parm_Tbl[250-254],
+		{  usParm_id = 249/250/251/252/253/254; SubParm= usGribCode; }
+        for Main Parameter defns (Db_Parm_Tbl[0-255],
+		{  usParm_id= usGribCode (1-255); SubParm=0; }
+	Sub-Tbls A/B/C/D/E defns (Db_Parm_Tbl[256-511], [512-767] ...)
+		{  usParm_id= 250/251/252/253/254; Parmsub= usGribCode(1-255);}
+	where usGribCode is between 0-255 (DECODR: 1st col, ENCODR= 3rd col)
+     */
+
+  unsigned short usParm_id; /* see above */
+  unsigned short usParm_sub;/* see above */
+
+  char   grib_dsc[75];      /* DECODR: field parameter -   2nd col */
+  char   grib_unit_dsc[25]; /* DECODR: units -             3rd col */
+
+  char   db_name[31];       /* ENCODR: neons field name    1st col */
+  /*char   chTable_code;    /- ENCODR: 0/a/b/c/d/e table 2nd col   */
+  float  fScale;  	    /* ENCODR: binary Scale Fctor  4th col */
+  float  fOffset;           /* ENCODR: Unit offset         5th col */
+  short  sDSF;              /* ENCODR: Decimal scalefactor 6th col */
+} PARM_DEFN;
+
+
+typedef struct lvl_defn {   /****  LEVEL:  GRIB vs. Neons  */
+  unsigned short    usLevel_id;	  /* DECDR: line1 col1 &  ENCDR:  2nd col  */
+  char   grib_dsc[100];      /* DECDR: meaning of code figure line1: 2nd col*/
+  int    num_octets;         /* DECDR: #octets for contents- line1: 3rd col*/
+  char   lvl_name_1[100];    /* DECDR: contents of octets 11 & 12  : line2 */
+  char   lvl_name_2[100];    /* DECDR: contents of octets 11 & 12  : line3 */
+
+  char   db_name[31];        /* ENCODR: db db_name      1st col */
+  float  fScale;  	    /* ENCODR: binary Scale Fctor  3rd col */
+  float  fOffset;           /* ENCODR: offset              4th col */
+}  LVL_DEFN;
+
+typedef struct mdl_defn { /****  MODEL:    GRIB vs. Neons */
+  unsigned short  usModel_id;/* ENCDR & DECDR: 1st col */
+  char grib_dsc[61];         /* DECDR:   2nd col */
+  char db_name[31];          /* ENCDR:   2nd col */
+} MODEL_DEFN;
+
+typedef struct geom_defn {   /***  GEOM :   Grib vs. Neons ****/
+  unsigned short  usGeom_id; /* ENCDR & DECODR TBL: 1st col */
+  char grib_dsc[61];         /* DECODR LOOKUP TBL:   2nd col */
+  char db_name [31];         /* ENCDR LOOKUP TBL:   2nd col */
+} GEOM_DEFN;
+/*................................................................*/
+
+typedef struct  ctr_defn {  /**** ORIGINATING CENTERS INFO *****/
+  char ctr_dsc[100];	    /* orig_ctrs:  description of center */
+}  CTR_DEFN;
+#endif
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib_seek.c b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_seek.c
new file mode 100644
index 00000000..4e17f24d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_seek.c
@@ -0,0 +1,612 @@
+/* File:  grib_seek.c 		based on Decoder's trqgetmsg() func;
+   Revised by:
+   28oct96 Alice T. Nakajima (ATN), SAIC, Monterey
+   18jun97 ATN check Edition before reading in entire msg;
+   27aug97 ATN *SEEK_SET to 0 (gcc complains)
+   20Oct97 ATN print #bytes read when fread fails;
+   03nov97 ATN -Realloc
+   22oct98 ATN *error msg;
+*/
+#include 
+#include 
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+**********************************************************************
+* A.  FUNCTION: grib_seek
+*       search the input file starting at the given offset for a GRIB 
+*       message.  If found, return it in GRIB_HDR structure.
+*
+*    INTERFACE:
+*       int grib_seek (InFile, offset, Read_Index,  gh, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *InFile;
+*           name of input file to search for message;
+*     (I&O) long  *offset;
+*           number of bytes to skip from the beginning of file;
+*           gets updated upon leaving to absolute #bytes from beginning of
+*           file to beginning of message found;
+*      (I)  int  Read_Index; 
+*           if set, only proceed if 'GRIB' starts exactly at the given 
+*           byte offset;
+*      (O)  GRIB_HDR *gh;
+*           empty upon entry;  to hold the Message found and its info;
+*      (O)  char *errmsg;
+*           empty array, only filled if error occurred;
+*
+*    RETURN CODE:  
+*      0> no errors, may or may not have a valid message;
+*	  If no Msg was Found: 
+*          a)  errmsg will hold the Warning msg;
+*	   If a valid Msg was Found: 
+*	   a) long *offset: if succesful, gets updated to absolute 
+*             beginning of Mesg;
+*          b) struct GRIB_HDR holds its info:
+*            entire_msg:  is assigned to newly MAlloced 
+*                    unsigned char * array to hold entire message;
+*	     msg_length:  size of entire_msg array in bytes;
+*	     ids_len, pds_len, gds_len, bms_len, bds_len, eds_len:
+*                    size of each defined sections in bytes;
+*            ids_ptr:  pts to message's Ident Data Sect;
+*            pds_ptr:  pts to message's Prod Defn Sect;
+*            gds_ptr:  pts to message's Grid Defn Sect;
+*            bms_ptr:  pts to message's Bitmap Defn Sect;
+*            bds_ptr:  pts to message's Binary Data Sect;
+*            eds_ptr:  pts to message's End Data Sect;
+*         c) errmsg remains empty;
+*      1> fseek/fread error, all ptrs in grib_hdr set to null; errmsg filled;
+*      2> got end of file, all ptrs in grib_hdr set to null; errmsg filled;
+*      3> Null entire_msg pointer; errmsg filled;
+*      4> unable to open input file; errmsg filled;
+*
+**********************************************************************
+*/
+
+#if PROTOTYPE_NEEDED
+int 	grib_seek (	char *InFile, long *offset, int Read_Index, 
+			GRIB_HDR *gh, char *errmsg)
+#else
+int	grib_seek (InFile, offset, Read_Index,gh,errmsg)
+			char *InFile; 
+			long *offset; 
+			int Read_Index; 
+			GRIB_HDR *gh;
+			char *errmsg;
+#endif
+{
+   char *func="grib_seek";
+   FILE  *fp=NULL;
+   int status=0;
+
+   DPRINT3 ("Entering %s\nfile=%s, offs=%ld \n", func, InFile, *offset);
+
+/*
+*
+* A.2       OPEN Input file 
+*           IF (fails) RETURN w/ error stat 4 !errmsg filled
+*/
+   if ((fp = fopen (InFile, "rb")) == NULL) {
+     DPRINT2 ("%s: Cannot open input file %s\n", func,InFile );
+     sprintf (errmsg,"%s: Cannot open input file '%s'\n", func,InFile );
+     status = 4;
+     goto DONE;
+   }
+
+   status = grib_fseek(fp,offset,Read_Index,gh,errmsg);
+
+DONE:
+/*
+*
+* A.4        CLOSE input file;     !get here when found no messages
+*
+*/
+   if (fp) fclose(fp); 
+
+/*
+* A.6        RETURN with status 
+*/
+   return (status); 
+
+}
+
+
+
+#if PROTOTYPE_NEEDED
+int 	grib_fseek (	FILE *fp, long *offset, int Read_Index, 
+			GRIB_HDR *gh, char *errmsg)
+#else
+int	grib_fseek (fp, offset, Read_Index,gh,errmsg)
+			FILE *fp; 
+			long *offset; 
+			int Read_Index; 
+			GRIB_HDR *gh;
+			char *errmsg;
+#endif
+ {
+   char *func="grib_fseek";
+   char  *GG, sm_blk[5004], *fwa_msg=NULL;
+   unsigned long lMessageSize;
+   unsigned long Edition;
+   long pos;            /* current byte offs fr. beg. of file */
+   int bytenum;         /* Index w/in sm_blk */
+   int bytestoread=5004; /* #bytes to read into sm_blk at a time */
+   int check_limit;     /* #bytes in sm_blk to check */ 
+   int gotone = 0;	/* set if found good msg */
+   int nread;           /* #bytes got back from Read */
+   int status;
+   unsigned long iskip;           /* for getbyte */
+   int gdsbmsflag, bit_set, sect_len; /* working vars */
+   char *ptr, *end_ptr;
+
+   DPRINT2 ("Entering %s\n, offs=%ld \n", func, *offset);
+/*
+* A.1       INIT variables
+*           !gh structure is cleared out
+*/
+   if (gh->entire_msg==NULL) {
+	DPRINT1 ( "%s:  expecting non-null Grib Hdr;\n",func);
+	sprintf(errmsg, "%s:  expecting non-NULL Grib Hdr;\n",func);
+	status= 3;  
+	goto DONE;
+	}
+
+   gh->msg_length = 0;
+   gh->ids_ptr=gh->pds_ptr= 0;
+   gh->gds_ptr=gh->bms_ptr=gh->bds_ptr=gh->eds_ptr=0;
+   memset ((void *)gh->entire_msg, '\0', gh->abs_size);
+   DPRINT2 ("gh= %ld, gh->entire_msg=%ld\n", gh, gh->entire_msg);
+
+/*
+*
+* A.3       FOR (loop while no error)     !read a block at a time
+*/
+   
+   for (status=0, pos= *offset, gotone= 0; status == 0; pos += check_limit)
+   {
+/*
+* A.3.1        IF (cannot SET file position to correct place)
+*              THEN
+*                 SET Status to 1 !fseek err
+*                 CONTINUE (Loop around to A.3)
+*              ENDIF
+*/
+     if (fseek(fp, pos, 0)!=0) { 
+	DPRINT2 ("%s: Got fseek error to pos= %ld\n",func, pos);
+	sprintf(errmsg,"%s: Got fseek error to pos= %ld\n",func,pos);
+	perror("");
+	status = 1; 
+	goto DONE; 
+	}
+
+/*
+* A.3.2        IF (read less than 40 bytes)
+*              THEN
+*                 FILL error buffer
+*                 RETURN status 2  !eof or <40 bytes left, errmsg filled
+*              ENDIF
+*/
+     nread= fread (sm_blk,sizeof(char), bytestoread,fp);
+     if (nread <= 40) 
+	{ 
+	  if (nread<=4) {
+		DPRINT0 ("No bytes left to check for msg;\n"); 
+		/* Errmsg left blank cuz its just EOF */
+		}
+	  else {
+	    sprintf(errmsg,"%s: skip last %d bytes, too few for a Msg\n",
+	    func, nread);
+	    DPRINT1 ("Only read %d bytes, too few to check for msg;\n",nread); 
+	    }
+	  status= 2; 
+	  goto DONE; 
+	}
+     else check_limit= nread - 4; 
+
+/*
+*              ! search block for the next the 'G'
+*              ! load entire Msg if everything is ok;
+*              ! if No 'G' found, then quit right away if no 'G'
+*              ! if GRIB is not at absolute Offset address, quit too;
+*              ! 
+* A.3.3        WHILE (there is another 'G' in this block) DO
+*/
+     bytenum= 0;
+     while ((GG= (char *) memchr (sm_blk, 'G', check_limit)))
+	{
+/*--- Saw 'G' ---*/
+/*
+* A.3.3.1          IF ('RIB' is not after 'G') THEN
+*                     IF (Offset from Index file) THEN  
+*                        ABORT search;   !Break out of loop
+*                     ELSE
+*                        CLEAR out the 'G' in temp block
+*                        CONTINUE  !Loop around to A.3.3
+*                     ENDIF
+*                  ENDIF
+*/
+	   if (strncmp(GG, "GRIB",4))    /* not 'RIB' after the 'G' */
+		if ( Read_Index) 
+		   break;     /* Offset IS from Indexfile:  Quit here */
+		else  
+		{	      /* offset is NOT fr. IndexFile:  keep looping; */
+		   *GG='-';   /* no RIB after G, clear it 		*/
+		   continue;  /* let Memchr find next G in block      	*/
+		}
+
+/*--- Saw 'G R I B' ----*/
+/*
+* A.3.3.2           CALCULATE byte position within this block
+*                   where this message begins
+*/
+	   bytenum = GG - sm_blk;  /* byte pos w/in this block */
+
+/*
+* A.3.3.3           IF (offset is from Indexfile  AND
+*                       string GRIB found is not at Absolute IndexFile's offset)
+*                   THEN abort search; ENDIF
+*/
+	  DPRINT1 ("Found string 'GRIB' at %ld\n", pos+bytenum);
+	  if (Read_Index &&  *offset != (bytenum + pos))  {
+	      sprintf(errmsg,
+	      "%s:   No Grib msg found at offset= %ld;  check Index File\n",
+	      func, *offset);
+	      break;		/* Abort here, Ret w/ no errros & no msg too */
+	    }
+
+/*--- Read Mesg Length, Edition ---*/
+/*
+* A.3.3.4          FUNCTION gbyte !extract lMessageSize
+*/
+	  iskip=32;
+          gbyte (sm_blk+bytenum ,&lMessageSize, &iskip,24);
+          DPRINT0 ("lMessageSize\n");
+
+/*--- Make sure it's Edition 1 first ---*/
+/*
+* A.3.3.5          FUNCTION gbyte !extract Grib Edition Number
+*                  IF (not edition 1) THEN
+*                      CLEAR out the 'G' in temp block
+*                      CONTINUE  !Loop around to A.3.3
+*                  ENDIF
+*/
+	  gbyte (sm_blk+bytenum, &Edition, &iskip, 8);
+	  DPRINT0 ("Edition\n");
+	  if (Edition != 1) {
+	      DPRINT1 ("Edition (%d) is not 1, start over\n",
+	      Edition);
+              *GG='-';   /* blank out G of current GRIB location found */
+              continue;  /* let Memchr find next G in block        */
+	   }
+
+
+/*
+* A.3.3.6          IF (cannot MOVE ptr to start of the message) THEN
+*                     RETURN status 1   !errmsg filled
+*                  ENDIF
+*/
+          if (fseek(fp, (long)(pos+bytenum), 0)!=0) {
+		DPRINT2 (
+		"%s: FSEEK error to pos+bytenum= %ld\n",
+		func, pos+bytenum);
+		sprintf(errmsg,
+		"%s: FSEEK error to pos+bytenum= %ld\n",
+		func, pos+bytenum);
+		status= 1;
+		goto DONE;
+		}
+
+/*
+* A.3.3.7          INIT all section length to zero
+*/
+	  gh->ids_len= gh->pds_len= gh->gds_len= 0;
+	  gh->bds_len= gh->bms_len= gh->eds_len= 0;
+
+/*
+* A.3.3.8          EXPAND Entire_Msg array if it's smaller than msglen
+*                  RETURN Malloc Err (stat=2) if fails  !errmsg filled
+*/
+	   if (lMessageSize > gh->abs_size  ) {
+	      
+/* 	      if (realloc((void *)gh->entire_msg, lMessageSize) == NULL) {..}
+*	      gh->abs_size = lMessageSize;
+*/
+	      if (Expand_gribhdr (gh, lMessageSize, errmsg)) {
+	          upd_child_errmsg (func, errmsg);
+		  status = 1;   /* to get out of Outer loop */
+		  goto DONE;
+	       }
+
+	      DPRINT1 ("Expanded entire_msg to be %ld bytes long\n",
+	      gh->abs_size);
+      	    } /* size changed */
+
+/*--- READ ENTIRE MSG into GRIB HEADER's Entire_Msg ---*/
+/*
+*
+* A.3.3.9          READ the entire message into Grib Hdr's Entire_Msg;
+*                  IF (failed) THEN
+*                      RETURN Fread error stat=1  !errmsg filled
+*                  ENDIF
+*/
+	  fwa_msg = (char *)gh->entire_msg;
+          if ((nread=fread (fwa_msg, 1, lMessageSize, fp)) != lMessageSize) 
+	    {
+            DPRINT2 ( "%s:  failed to Fread EntireMsg (sz=%ld)\n",
+	    func, lMessageSize);
+	    sprintf(errmsg,
+            "%s has truncated msg @offs=%ld (got %ld out of %ld bytes)\n",
+            func, *offset, nread, lMessageSize);
+	    status= 1;  /* to get out of Outer loop */
+	    goto DONE;  /* get out of WHILE */
+	    }
+
+/*--- if see '7777', asssign GH's pointers & len  ---*/
+/*
+* A.3.3.10         IF ('7777' is where expected) THEN
+*/
+          if (!strncmp((fwa_msg + lMessageSize - 4),"7777",4))
+		/*  && fwa_msg[7]==1)  */
+	  {  
+ 	        end_ptr = fwa_msg + lMessageSize;
+
+		DPRINT0 ("Found string '7777' where expected\n");
+		gh->msg_length= lMessageSize;
+/*
+* A.3.3.10.a.1         STORE loc & len of section 0 into Grib Hdr;
+*/
+		gh->ids_ptr= (unsigned char *)fwa_msg;    /* mark sect 0 */
+		gh->ids_len= 8L;
+
+/*
+* A.3.3.10.a.2         STORE loc & len of PDS into Grib Hdr; 
+*                     FUNCTION gbyte   !get 3-byte length
+*/
+	        ptr=  fwa_msg + gh->ids_len;
+		gh->pds_ptr= (unsigned char *)ptr;            /* mark PDS */
+		iskip= 0; gbyte(ptr ,(unsigned long *)&gh->pds_len,&iskip,24); 
+		DPRINT0 (" pds length\n");
+		iskip= 8*7; gbyte(ptr ,(unsigned long*)&gdsbmsflag, &iskip, 8);
+		DPRINT1 (" (%x hex) Gds/Bms flag\n", gdsbmsflag);
+/*
+* A.3.3.10.a.3         IF (location of next Section  is out of bound) THEN
+*                        PRINT message;
+*                        GOTO drop this msg;
+*                     ENDIF
+*/
+		ptr += gh->pds_len;
+	        if (ptr > end_ptr) {
+		    sprintf(errmsg,
+		    "%s:  corrupt PDSlen= %ld, Totlen=%ld, drop msg @%ld;\n"
+		    , func,  gh->pds_len, gh->msg_length, *offset);
+		    gh->pds_len= 0;  		     /* reset */
+		    goto DROPMSG_N_LOOP;
+		    }
+
+/*
+*                     IF (Debug) FUNCTION hdr_print  !print PDS
+*/
+	        DPRINT1 ("gh->pds_len= %ld\n", gh->pds_len);
+		HDR_PRINT("Grib_Seek's PDS",gh->pds_ptr, gh->pds_len);
+
+/*
+* A.3.3.10.a.4         IF (GDS is present) THEN
+*                        STORE location & len of GDS into Grib Hdr's Gds_Ptr
+*                        FUNCTION gbyte   !get 3-byte length
+*                        IF (location of next Section  is out of bound) THEN
+*                           PRINT message;
+*                           DROP this msg & try to find another;
+*                        ENDIF
+*                        IF (Debug) FUNCTION hdr_print  !print GDS
+*                     ENDIF
+*/
+		bit_set= gdsbmsflag >> 7 & 1;	/* mark GDS if present */
+		if (bit_set) {
+		    gh->gds_ptr= (unsigned char *)ptr;
+		    iskip= 0; gbyte(ptr,(unsigned long*)&gh->gds_len,&iskip,24);
+		    DPRINT0 (" Gds length\n");
+		    ptr += gh->gds_len;	/* bump PTR to sect*/
+	             if (ptr > end_ptr) {
+		       sprintf(errmsg,
+     		       "%s: corrupt GDSlen= %ld, Totlen=%ld, drop msg @%ld\n"
+		        , func,  gh->gds_len, gh->msg_length, *offset);
+		        gh->gds_len= 0;  		/* reset */
+		        goto DROPMSG_N_LOOP;
+     		        }
+		       DPRINT1 ("gh->gds_len= %ld\n", gh->gds_len);
+		       HDR_PRINT("Grib_Seek's GDS",gh->gds_ptr,gh->gds_len);
+		    }
+
+/*
+* A.3.3.10.a.5         IF (BMS is present) THEN
+*                        STORE location & len of BMS into Grib Hdr's Bms_Ptr
+*                        FUNCTION gbyte   !get 3-byte length
+*                        IF (location of next Section  is out of bound) THEN
+*                           PRINT message;
+*                           DROP this msg & try to find another;
+*                        ENDIF
+*                        IF (Debug) FUNCTION hdr_print   !byte dump
+*                     ENDIF 
+*/
+		bit_set= gdsbmsflag >> 6 & 1;	/* mark BMS if present */
+		if (bit_set) {
+		    gh->bms_ptr= (unsigned char *)ptr; 	
+		    iskip= 0; gbyte(ptr,(unsigned long*)&gh->bms_len,&iskip,24); 
+		    DPRINT0 (" Bms length\n");
+
+		    ptr += gh->bms_len;		/* bump PTR to sect */
+	            if (ptr > end_ptr) {
+		       sprintf(errmsg,
+		       "%s: corrupt BMSlen= %ld, Totlen=%ld, drop msg @%ld\n"
+			, func, gh->bms_len, gh->msg_length, *offset);
+		        gh->bms_len= 0;  		/* reset */
+		        goto DROPMSG_N_LOOP;
+     		        }
+		     DPRINT1 ("gh->bms_len= %ld\n", gh->bms_len);
+		     HDR_PRINT ("Grib_Seek's BMS", gh->bms_ptr, 
+				(gh->bms_len>100? 100: gh->bms_len));
+		  }
+/*
+* A.3.3.10.a.6        STORE location and length of BDS into Grib Hdr's Bds_Ptr
+*                    FUNCTION gbyte !get 3-byte length
+*                    IF (location of next Section  is out of bound) THEN
+*                        PRINT message;
+*                        DROP this msg & try to find another;
+*                    ENDIF
+*                    IF (Debug) FUNCTION hdr_print   !byte dump
+*/
+
+		gh->bds_ptr= (unsigned char *)ptr; 	/* mark BDS */
+		iskip= 0; gbyte(ptr,(unsigned long*)&gh->bds_len,&iskip,24);
+		DPRINT0 (" Bds length\n");
+
+		ptr += gh->bds_len;
+	        if (ptr > end_ptr) {
+		    sprintf(errmsg,
+		    "%s:  corrupt BDSlen= %ld, Totlen=%ld, drop msg @%ld\n"
+		    , func, gh->gds_len, gh->msg_length, *offset);
+		    gh->gds_len= 0;  /* reset */
+		    goto DROPMSG_N_LOOP;
+		    }
+		    DPRINT1 ("gh->bds_len= %ld\n", gh->bds_len);
+	  	    HDR_PRINT ("Grib_Seek's BDS", gh->bds_ptr, 
+			(gh->bds_len>100? 100: gh->bds_len));
+
+/*
+* A.3.3.10.a.7        STORE location & len of EDS into Grib Hdr's Eds_Ptr
+*/
+		gh->eds_ptr= (unsigned char *)ptr;  /* mark EDS */
+		gh->eds_len= 4;   
+
+/*
+* A.3.3.10.a.8        SET 'gotone' flag 
+*                    ! Return with Msg in Grib hdr, and good stat
+*/
+	    	gotone=1; 	/* to get out of FOR loop */
+		status=0; 	/* Return with Msg , good stat */
+	        goto DONE; 
+/*
+* A.3.3.10          ENDIF 
+*/
+	   } /* saw 77s  */
+	else 
+	if (Read_Index) {
+		sprintf(errmsg,
+		"%s:  no 7777 found for msg at %ld, check indexfile\n",
+		func, *offset);
+		}
+
+/*
+*
+*          !====================================================
+*          ! Drop Msg Area:   Only get here if :
+*          ! - first G found not at Indexfile's offset;
+*          ! - no RIB after G;
+*          ! - GRIB string found not at Indexfile's offset;
+*          ! - no 7777 at expected offset;
+*          ! - got Corrupted Length; 
+*          !====================================================
+*/
+DROPMSG_N_LOOP:
+	   /* ERRMSG must already be loaded and the corrupted len reset to 0
+	      so that Display GH won't go out of bound...
+	    */
+	   DPRINT1 ("\nDropping, cause=> %s\n", errmsg);
+
+/*
+* A.3.3.11         IF (Debug mode) THEN 
+*                     FUNCTION display_gribhdr    !show what got loaded sofar
+*                  ENDIF
+*/
+	  if (gh->msg_length > 0) 
+	  DISPLAY_GRIBHDR(gh); /* before dropping msg*/
+
+/*
+*                  ! no message found yet, OR Msg Section lens are corrupted 
+* A.3.3.12         CLEAR out header struct   !data in array is not valid
+*/      
+   	  gh->msg_length =0;
+	  gh->ids_ptr=gh->pds_ptr= gh->eds_ptr=0;
+   	  gh->gds_ptr=gh->bms_ptr=gh->bds_ptr= 0;
+   	  memset ((void *)gh->entire_msg, '\0', gh->abs_size);
+
+/*
+* A.3.3.13         IF (Offset was read from Indexfile)   !quit searching
+* A.3.3.13.a       THEN
+*                      PUT Error msg in buffer
+*                      RETURN with No Error status
+* A.3.3.13.b       ELSE
+*                      CLEAR out 'G' in tmp block        !go find next 'G' 
+*                  ENDIF
+*/
+	  if (Read_Index) {
+	      status = 0; 	/* Ret w/ no errors     */
+	      goto DONE;	/* send CAUSE back in Errmsg */
+	     }
+	  else {
+	     *GG='-';    /* let Memchr find next 'G' in curr. block */
+	     DPRINT1 ("'GRIB' at location %ld is not a valid message\n",
+	     bytenum+pos);
+	     errmsg[0]='\0';  /* clear out buff */
+	     }
+/*
+* A.3.3         ENDWHILE 
+*/
+     }  /* WHILE seeing 'G'*/
+
+
+     if (Read_Index) {  /* Catch 3 cases:
+			 - if no 'G' at all ;
+			 - if no RIB after G ;
+			 - if found GRIB but not at expected place
+			*/
+	   sprintf(errmsg,
+	   "%s:  No Grib Msg found at IndexFile's offset = %ld; "\
+	   " Check Index File\n" , func, *offset);
+	   status = 0;  /* Return w/no errors  */
+	   goto DONE;	/* but w/ Warn Msg in buff*/
+	}
+
+/*
+A.3.4           DEBUG print  !no Sect0 found in this block
+*/
+      DPRINT2 ("No Section 0 found between address %ld and %ld\n", 
+      pos, pos+check_limit);
+/*
+*
+* A.3       ENDFOR    !Outer Loop,  stay until Status changes
+*/
+  }  /* check entire file */
+
+
+
+DONE:
+
+/*
+* 
+* A.5        IF (found a msg) THEN
+*                BUMP caller's Offset to absolute Begining of Msg found;
+*                DEBUG Print
+*            ENDIF
+*/
+   if (gotone)  
+       {
+       *offset = (long)(pos+bytenum);  /* bump offset to abs. beg. of Msg */
+       DPRINT3 ("Exiting %s w/stat=%d, offs=%d, msg in GRIB_HDR\n", 
+	func, status, *offset);
+       }
+   else DPRINT2 ("Exiting %s w/stat=%d, no messages\n", func, status);
+
+/*
+* A.6        RETURN with status 
+*/
+   return (status); 
+/*
+*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/grib_uthin.c b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_uthin.c
new file mode 100644
index 00000000..ecae8c73
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/grib_uthin.c
@@ -0,0 +1,71 @@
+#include 
+#include 
+#include 
+
+/*****************************************************************************
+ *
+ * This function "unthins" thinned grib grids.
+ * Todd Hutchinson
+ * 9/24/99
+ * tahutchinson@tasc.com
+ *
+ * Interface:
+ *   Input:
+ *     *in       - 1-d array holding input grib data (an irregular thinned 
+ *                 grid)
+ *     *rowsizes - an array holding the sizes of the thinned rows
+ *     ysize     - the number of rows
+ * 
+ *   Ouput:
+ *     *out      - 1-d array holding output grid (a rectangular unthinned grid)
+ *     *xsize    - the number of columns in the output array
+ *   
+ *   Return value
+ *      1 for success, <0 for failure
+ ******************************************************************************/
+
+int grib_unthin(float *in,float *out,int *rowsizes, int ysize, int *xsize)
+{  
+  int in_index = 0;
+  int out_index = 0;
+  int inrow_index;
+  float a, b;
+  int i, j;
+  float weight;
+
+  /* Find maximum value */
+  *xsize = 0;
+  for (j = 0; j *xsize) {
+      *xsize = rowsizes[j];
+    }
+  }
+
+  for (j=0; j= b) {
+	  inrow_index++;
+	  b = (((float)(*xsize)-1)/((float)rowsizes[j]-1))*(inrow_index+1);
+	  in_index++;
+	}
+	a = (((float)(*xsize)-1)/((float)rowsizes[j]-1))*(inrow_index);
+	weight = (i - a)/(b-a);
+	if (weight == 0) out[out_index] = in[in_index];
+	else 
+	  out[out_index] = in[in_index]+weight*(in[in_index+1]-in[in_index]);
+	out_index++;
+	/* Advance to next row */
+	if (i == (*xsize - 1)) in_index++;
+      }
+    }
+  }
+
+  return 1;
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribfuncs.h b/wrfv2_fire/external/io_grib1/MEL_grib1/gribfuncs.h
new file mode 100644
index 00000000..a05f0fde
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribfuncs.h
@@ -0,0 +1,119 @@
+#include 
+#include "grib.h"	/* all gribs structs */
+#include "input.h"	/* GEOM+IN, DATA+INPUT, USER_INPUT */
+
+/* check Compiler,  prototypes needed for ANSI-C */
+
+/*#if defined( __cplusplus ) || defined( __STDC__ ) || defined( __GNUC__ )*/
+/* Changed by Todd Hutchinson to force the need for PROTOTYPE */
+#if 1
+
+#define PROTOTYPE_NEEDED 1
+
+int Expand_gribhdr (GRIB_HDR *, long, char *);
+int prt_badmsg (GRIB_HDR  *gh, char *errmsg);
+int make_grib_log (char *,char *,unsigned long,long,PDS_INPUT,
+		grid_desc_sec,BDS_HEAD_INPUT,BMS_INPUT,float *,char *);
+int FTP_getfile (char *,char *,char *);
+int apply_bitmap (BMS_INPUT *,float **,float,BDS_HEAD_INPUT *,char *);
+int create_inpLambert (GEOM_IN,void **,char *);
+int create_inpLatlon (GEOM_IN,void **,char *);
+void create_inpPDS (DATA_INPUT,USER_INPUT,PDS_INPUT *);
+int create_inpPolar  (GEOM_IN,void **,char *);
+void display_gribhdr (GRIB_HDR *hdr);
+void free_gribhdr (GRIB_HDR **);
+void gbyte (char *,unsigned long *,unsigned long *,unsigned long);
+void gbyte_quiet (char *,unsigned long *,unsigned long *,unsigned long);
+int grib_dec (char *,PDS_INPUT *,grid_desc_sec *,BDS_HEAD_INPUT *,
+		BMS_INPUT *,float **,char *);
+int grib_enc (DATA_INPUT,USER_INPUT,GEOM_IN,float *,GRIB_HDR *,char *);
+float grib_ibm_local(unsigned long ibm_float);
+int grib_seek (char *,long *,int,GRIB_HDR *,char *);
+int gribgetbds (char *,short,BMS_INPUT *,grid_desc_sec *,float **,
+		BDS_HEAD_INPUT *, char *);
+int gribgetbms (char *,BMS_INPUT *,int,unsigned long,char *);
+int gribgetgds (char *,grid_desc_sec *,char *);
+int gribgetpds (char *,PDS_INPUT *,char *);
+int gribhdr2file (GRIB_HDR *,FILE *,char *);
+int gribputbds (USER_INPUT,long,short,float *,BDS_HEAD_INPUT *,
+		GRIB_HDR **,char *);
+int gribputgds (GEOM_IN,GDS_HEAD_INPUT *,void **,GRIB_HDR **,char *);
+int gribputpds(DATA_INPUT,USER_INPUT,PDS_INPUT *,GRIB_HDR**,char *);
+void hdr_print (char *,unsigned char *,int );
+void init_dec_struct (PDS_INPUT *,grid_desc_sec *,BMS_INPUT *,BDS_HEAD_INPUT *);
+void init_enc_struct (DATA_INPUT *,GEOM_IN *,USER_INPUT *);
+int init_gribhdr (GRIB_HDR **,char *);
+void init_struct (void *, int);
+int inp2Grib_Lambert (void **,LAMBERT *,long *,char *);
+int inp2grib_Latlon (void **,LATLON *,long *,char *);
+int inp2grib_PDS (PDS_INPUT *,PDS_GRIB **,char *);
+int inp2grib_PolarSt (void **,POLAR  *,long *,char *);
+int ld_dec_lookup (char *,char *);
+int ld_enc_config (char *,USER_INPUT *,char *);
+int ld_enc_ffinfo (char *, DATA_INPUT *,char *);
+int ld_enc_geomfile (char *,GEOM_IN *,char *);
+int ld_enc_ieeeff (char *,float *,int,char *);
+int ld_enc_lookup (char *,char *);
+int ld_grib_origctrs (char *,char *,char *);
+unsigned long grib_local_ibm (double local_float);
+void make_default_grbfn (DATA_INPUT,USER_INPUT,char *);
+int map_lvl (char *,DATA_INPUT *,float *,float *,char *);
+int map_parm (char *,DATA_INPUT *,float *,float *,char *);
+int pack_spatial (long *,unsigned short *,float *,float *,
+		unsigned long **,short,long *,char *);
+void prt_inp_struct (PDS_INPUT *,grid_desc_sec *, BMS_INPUT *,
+		struct BDS_HEAD_INPUT *,float **);
+void upd_child_errmsg (char *,char *);
+void w3ft33_(float *ain,float **out, int *nsflag);
+#else
+#define PROTOTYPE_NEEDED 0
+
+int Expand_gribhdr ();
+int prt_badmsg ();
+int  make_grib_log ();
+int FTP_getfile  ();
+int apply_bitmap ();
+int create_inpLambert ();
+int create_inpLatlon  ();
+void create_inpPDS ();
+int create_inpPolar   ();
+void display_gribhdr ();
+void free_gribhdr ();
+void gbyte ();
+void gbyte_quiet ();
+int grib_dec ();
+int grib_enc ();
+float grib_ibm_local();
+int grib_seek ();
+int gribgetbds ();
+int gribgetbms ();
+int gribgetgds ();
+int gribgetpds ();
+int gribhdr2file ();
+int gribputbds ( );
+int gribputgds ();
+int gribputpds();
+void hdr_print ();
+void init_dec_struct ();
+void init_enc_struct ();
+int init_gribhdr ();
+void init_struct ();
+int inp2Grib_Lambert ();
+int inp2grib_Latlon  ();
+int inp2grib_PDS ();
+int inp2grib_PolarSt ();
+int ld_dec_lookup ();
+int ld_enc_config ();
+int ld_enc_ffinfo ();
+int ld_enc_geomfile ();
+int ld_enc_ieeeff ();
+int ld_enc_lookup ();
+int ld_grib_origctrs ();
+unsigned long grib_local_ibm ();
+void make_default_grbfn ();
+int map_lvl ();
+int map_parm ();
+int pack_spatial ();
+void prt_inp_struct ();
+void upd_child_errmsg ();
+#endif
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbds.c
new file mode 100644
index 00000000..abc3e526
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbds.c
@@ -0,0 +1,439 @@
+#include 
+#include 
+#include  
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+/*
+  REVISION/MODIFICATION HISTORY:
+       03/07/94 written by Mugur Georgescu CSC, Monterey CA
+       02/01/96 modified by Steve Lowe SAIC, Monterey CA
+       04/17/96 modified by Alice Nakajima SAIC, Monterey CA
+       06/19/96 add hdrprint;/nakajima
+* 
+* ********************************************************************
+* A.  FUNCTION:  gribgetbds 
+*       decodes the Binary Data Section of the GRIB message 
+*       and filling grib_data float array.
+*
+*    INTERFACE:
+*       int gribgetbds (curr_ptr, deci_scale, bms, gds, 
+*                       ppgrib_data, bds_head, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *curr_ptr;
+*           points to first Octet of the BDS to be decoded;
+*      (I)  short  deci_scale;
+*           decimal scaling factor to be applied to data;
+*      (I)  BMS_INPUT *bms;
+*           points to the decoded internal Bit Map Section Struct 
+*      (I/O) grid_desc_sec *gds
+*           points to decoded internal grid definition struct
+*      (O)  float **ppgrib_data;
+*           double pointer to array of float, null upon entry;
+*           upon successful exit, holds the unpacked and restored float data
+*           in a newly malloced array;
+*      (O)  BDS_HEAD_INPUT *bds_head; 
+*           points to Binary Data Sect hdr struct, empty upon entry;
+*           to be filled with decoded BDS info;
+*      (O)  char  *errmsg;
+*           Only returned filled when error occurred;
+*
+*      RETURN CODE:
+*        0>   no errors
+*        1>   unrecognized packing algorithm
+*        2>   number of points does not match bitmap
+*        3>   number of points does not match grid size in GDS
+*        4>   malloc error
+* ********************************************************************
+*/
+
+#if PROTOTYPE_NEEDED
+int gribgetbds ( char *curr_ptr, short  deci_scale, BMS_INPUT *bms,
+        grid_desc_sec *gds, float **ppgrib_data,
+        BDS_HEAD_INPUT *bds_head, char  *errmsg)
+#else
+int gribgetbds (curr_ptr, deci_scale, bms, gds, ppgrib_data, 
+		bds_head, errmsg)
+		char *curr_ptr; 
+		short  deci_scale; 
+		BMS_INPUT *bms;
+		grid_desc_sec *gds;
+		float **ppgrib_data; 
+		BDS_HEAD_INPUT *bds_head; 
+		char  *errmsg;
+#endif
+{
+char *func="gribgetbds";
+char *in = curr_ptr;      /* pointer to beginning of BDS */
+long length;              /* size of the Binary Data Section */
+long scale;               /* scaling factor */
+float ref_val;            /* reference value (minimum value) */
+unsigned long something;  /* generic value from message */
+long data_width;          /* number of bits that data occupies */
+int halfBYTE4;            /* the first 4 bits in 4-th byte */
+int status=0;
+int sign;                 /* sign + or - */
+float dscale;             /* 10 to the decimal scaling power */
+float bscale;             /* 2 to the binary scaling power   */
+unsigned long skip=0;              /* number of bits to be skipped */
+long c_ristic;            /* characteristic for float representation */
+long mantissa;            /* mantissa for float representation */
+long numpts;              /* number of bits left at end of bitstream */
+unsigned long data_pts;   /* number of data points in bitstream */
+unsigned long num_calc;	  /* temp work var */
+float *grib_data=0;       /* local work array for grid data */
+float fdata=0;            /* data value stored in reference */
+int	i,j;         /* array counter */
+int xsize, ysize; 
+float *outdata;
+
+  DPRINT1 ("Entering %s()\n", func);
+/*
+*
+* A.1       FUNCTION gbyte !get bds length
+*/
+
+  gbyte(in,(unsigned long *) &length,&skip,24);
+  DPRINT0 ("bds_head->length\n");
+  bds_head->length = (unsigned long) length;
+
+/*
+*
+* A.2       FUNCTION gbyte !get BDS flag 
+*/
+  gbyte(in, (unsigned long *) &halfBYTE4, &skip, 4);
+  DPRINT0 ("bds_head->usBDS_flag\n");
+  bds_head->usBDS_flag = (short) halfBYTE4;  /* get BDS Flag (Table 11) */
+
+/*
+*
+* A.3       IF (unsupported packing algorithm)  THEN
+*               RETURN 1
+*           ENDIF
+*/
+  /* need to check on packing algorithm */
+  if (halfBYTE4)  /* unrecognized packing algorithm */
+    {
+     DPRINT1 ("%s:  error, unrecognized packing algorithm\n", func);
+     sprintf(errmsg, "%s:  unrecognized packing algorithm\n", func);
+     status= (1);
+     goto BYE;
+    }
+
+/*
+*
+* A.4       FUNCTION gbyte !get number of unused bits
+*/
+  gbyte(in,(unsigned long *) &numpts,&skip,4); /* get #bits at end of BDS */
+  DPRINT0 ("numpts\n");
+
+/*
+*
+* A.5       FUNCTION gbyte !get Binary Scale Factor
+*/
+  gbyte(in,&something,&skip,16);
+  DPRINT0 ("Sign & bds_head->Bin_sc_fctr\n");
+  sign = (int)(something >> 15) & 1;  /* get sign for scale */
+  scale = (int)(something) & 32767;   /* get scale */
+  if(sign)                            /* scale negative */
+     scale = -scale;                  /* multiply scale by -1 */
+  bds_head->Bin_sc_fctr = (int) scale;  /* get binary scale factor */
+  DPRINT1 ("Binary Scale Factor = %d\n", scale);
+
+/*
+*
+* A.6       CALCULATE Reference value from IBM representation
+*             !FUNCTION gbyte !get the sign of reference
+*             !FUNCTION gbyte !get charateristic
+*             !FUNCTION gbyte !get the mantissa
+*/
+  gbyte(in,&something,&skip,8);
+  DPRINT0 ("Sign & Reference)\n");
+  sign = (int)(something >> 7) & 1; /* get the sign for reference value */
+
+  skip -= 7;
+  gbyte(in,(unsigned long *)&c_ristic,&skip,7); /*characteristic for the float*/
+  DPRINT0 ("c_ristic\n");
+
+  gbyte(in,(unsigned long*)&mantissa,&skip,24); /*mantissa for the float */
+  DPRINT0 ("mantissa\n");
+  c_ristic -= 64;                   /* subtract 64 from characteristic */
+  ref_val = (float) mantissa * (float)(pow(16.0,(double)c_ristic)) * 
+	    (pow(2.0,-24.0));
+  if(sign)                          /* negative reference value */
+     ref_val = -ref_val;            /* multiply ref_val by -1 */
+  bds_head->fReference = (float)ref_val;
+  DPRINT1 ("Reference = %f\n", ref_val);
+
+/*
+*
+* A.7       FUNCTION gbyte !get data width
+*/
+  gbyte(in, (unsigned long*) &data_width,&skip,8);       /* get data width */
+  DPRINT0 ("bds_head->usBit_pack_num\n");
+  bds_head->usBit_pack_num = (short)data_width;
+
+/*
+*
+* A.8       SET Binary and Decimal Scale Factors
+*/
+  /* set binary scale */
+  bscale = (float)pow (2.0,(double) scale);
+
+  /* set decimal scale */
+  dscale = (float)pow (10.0, (double) deci_scale);
+
+  DPRINT2 ("Scaled-up BSF= (2**%d) = %f\n", scale, bscale);
+  DPRINT2 ("Scaled-up DSF= (10**%d) = %f\n", deci_scale,dscale);
+
+/*
+*
+* A.9       IF (data_width is zero) THEN
+*               ! grid contains a constant value
+*               IF expected grid size is invalid THEN
+*                  FORCE grid size of 1
+*               ENDIF
+*               ALLOCATE array for grid of expected grid size
+*               FILL grid with the constant value
+*               RETURN 0 !success
+*           ENDIF
+*/
+  if (!data_width)   /* grid contains constant value, success, all done */
+  {
+/* Used to send back array of 1 element:
+#     bds_head->ulGrid_size = 1;
+#     fdata = (float) (ref_val / dscale);
+#     *ppgrib_data = (float *) malloc(sizeof(float));
+#     **ppgrib_data = fdata;
+*/
+
+     fdata = (float) (ref_val / dscale);
+     if (bds_head->ulGrid_size <= 0) {
+	fprintf(stdout,
+	"WARNING:  gribgetbds detects bad ulGrid_size (%ld); "\
+	"Set to 1 to hold constant value %lf\n", bds_head->ulGrid_size, fdata);
+	bds_head->ulGrid_size = 1;
+	}
+    
+     grib_data =(float *) malloc(bds_head->ulGrid_size * sizeof(float));
+     if (!grib_data) {
+	sprintf(errmsg,
+	"%s: failed to create array[%d] for grid to hold Constant data", 
+	func, bds_head->ulGrid_size);
+	goto BYE;
+	}
+
+     *ppgrib_data = grib_data;		/* store address */
+     for (i=0; i < bds_head->ulGrid_size ; ) 
+	grib_data[i++] = fdata;		/* fill grid with constant val */
+
+     DPRINT3("%s:  grid[%ld] contains convant value %lf\n",
+	func, bds_head->ulGrid_size, fdata);
+
+     status = (0);  /* no errors */
+     goto BYE;
+  }
+
+  /* fill the data array with values from message */
+  /*     - Assume that GDS may not be included so that
+   *         the number of grid points may not be defined.       
+   *     - Compute space to malloc based on BDS length,
+   *         data_width, and numpts.
+   *     - if grid_size from GDS is zero, use
+   *         computed number of points.
+   */
+
+/*
+*
+* A.10      CALCULATE number of data points actually in BDS
+*/
+  num_calc = ((length - 11)*8 - numpts) / data_width;
+
+  /* Check the number of points computed against info in the BMS
+     or GDS, if they are available */
+
+/*
+*
+* A.11      IF (BMS is present and has included bitmap) THEN
+*               IF (#calculated not same as #bits set in BMS) THEN
+*                   RETURN 2
+*               ENDIF
+*/
+
+  if (bms->uslength > 6)
+  {
+      if (bms->ulbits_set != num_calc) {
+	DPRINT3 ("%s:  BMS present, #datapts calculated (%d) " \
+	"not same as BMS's set bits (%d)\n",func, num_calc, bms->ulbits_set);
+
+	sprintf(errmsg,"%s:  BMS present, #datapts calculated (%d) " \
+	"not same as BMS's set bits (%d)\n",func, num_calc, bms->ulbits_set);
+	status= (2); goto BYE;
+	}
+  }
+/*
+* A.11.1    ELSE  !no bms
+*               IF (GDS is present AND
+*                   #calculated not same as GDS's grid size)
+*               THEN
+*                   RETURN 3
+*               ENDIF
+*/
+  
+  else
+    
+  {    
+      if (bds_head->ulGrid_size && bds_head->ulGrid_size != num_calc) {
+	DPRINT0("Averting failure of grid size test\n");
+	/*
+	DPRINT3 ( "%s:  GDS present, #datapts calculated (%d) " \
+	   "not same as GDS's grid size (%d)\n",
+	   func,num_calc,bds_head->ulGrid_size);
+
+	   sprintf(errmsg,"%s:  GDS present, #datapts calculated (%d) " \
+	   "not same as GDS's grid size (%d)\n",
+	   func,num_calc,bds_head->ulGrid_size);
+	   status=(3); goto BYE;
+	*/
+	 }          
+  }
+    
+  
+/*
+* A.11      ENDIF (BMS present)
+*/
+
+  /* Only reach this point if number of points in BDS matches info
+     in BMS or GDS.  This number is unchecked if no BMS or GDS. */
+
+  /* Make sure number of points in BDS is value used for extracting */
+/*
+*
+* A.12      SET #datapoints
+*/
+  bds_head->ulGrid_size = num_calc;
+  data_pts= num_calc;
+
+/*
+*
+* A.13      ALLOCATE storage for float array size
+*           IF (error) THEN
+*               RETURN 4
+*           ENDIF
+*/
+  grib_data =(float *) malloc(data_pts * sizeof(float));
+  if (grib_data==NULL) { 
+	DPRINT1 ("%s: failed to malloc Grib_Data\n",func);
+	sprintf(errmsg,"%s: failed to malloc Grib_Data\n",func);
+	status=(4); goto BYE; }
+
+/*
+*
+* A.14      SET data array pointer to local data array
+*/
+  *ppgrib_data = grib_data;
+
+/*
+*
+* A.15      FOR (each data point) DO
+*               FUNCTION gbyte_quiet   !get data_width bits
+*               INCREMENT skip by data_width
+*               COMPUTE and STORE value in float array
+*           ENDDO
+*/
+
+  DPRINT3 ( "Restore float data by = (float)(%f + X * %f)) / %f;\n",
+  ref_val, bscale, dscale);
+
+  for(i=0;i < data_pts ;i++)  
+     {
+     gbyte_quiet(in,&something,&skip,data_width);
+     grib_data[i]= (float)(ref_val + (something * bscale))/dscale;
+     }
+
+/*
+ * Unthin grid if it is thinned
+ */
+  if (gds->head.thin != NULL) {
+    if ((gds->head.usData_type == LATLON_PRJ) || 
+	(gds->head.usData_type == GAUSS_PRJ) ||
+	(gds->head.usData_type == ROT_LATLON_PRJ) ||
+	(gds->head.usData_type == ROT_GAUSS_PRJ) ||
+	(gds->head.usData_type == STR_LATLON_PRJ) ||
+	(gds->head.usData_type == STR_GAUSS_PRJ) ||
+	(gds->head.usData_type == STR_ROT_LATLON_PRJ) ||
+	(gds->head.usData_type == STR_ROT_GAUSS_PRJ)) {
+      ysize = gds->llg.usNj;
+    } else if (gds->head.usData_type == MERC_PRJ) {
+      ysize = gds->merc.rows;
+    } else if (gds->head.usData_type == POLAR_PRJ) {
+      ysize = gds->pol.usNy;
+    } else if ((gds->head.usData_type == LAMB_PRJ) ||
+	       (gds->head.usData_type == ALBERS_PRJ) ||
+	       (gds->head.usData_type == OBLIQ_LAMB_PRJ)) {
+      ysize = gds->lam.iNy;
+    } else {
+       DPRINT2 ("%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       sprintf(errmsg,"%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       status=1;         /* set status to failure */
+    }
+
+    xsize = 0;
+    for (j = 0; jhead.thin[j] > xsize) {
+	xsize = gds->head.thin[j];
+      }
+    }
+    outdata = (float *)malloc(ysize*xsize*sizeof(float));
+    grib_unthin(grib_data,outdata,gds->head.thin,ysize,
+	  &xsize);
+    free(grib_data);
+    grib_data = (float *)malloc(sizeof(float)*ysize*xsize);
+    *ppgrib_data = grib_data;
+    memcpy(grib_data,outdata,sizeof(float)*ysize*xsize);
+    free(outdata);
+    free(gds->head.thin);
+    gds->head.thin = NULL;
+    if ((gds->head.usData_type == LATLON_PRJ) || 
+	(gds->head.usData_type == GAUSS_PRJ) ||
+	(gds->head.usData_type == ROT_LATLON_PRJ) ||
+	(gds->head.usData_type == ROT_GAUSS_PRJ) ||
+	(gds->head.usData_type == STR_LATLON_PRJ) ||
+	(gds->head.usData_type == STR_GAUSS_PRJ) ||
+	(gds->head.usData_type == STR_ROT_LATLON_PRJ) ||
+	(gds->head.usData_type == STR_ROT_GAUSS_PRJ)) {
+      gds->llg.usNi = xsize;
+      gds->llg.iDi = abs(gds->llg.lLat2 - gds->llg.lLat1)/(xsize-1);
+    } else if (gds->head.usData_type == MERC_PRJ) {
+      gds->merc.cols = xsize;
+    } else if (gds->head.usData_type == POLAR_PRJ) {
+      gds->pol.usNx = xsize;
+    } else if ((gds->head.usData_type == LAMB_PRJ) ||
+	       (gds->head.usData_type == ALBERS_PRJ) ||
+	       (gds->head.usData_type == OBLIQ_LAMB_PRJ)) {
+      gds->lam.iNx = xsize;
+    } else {
+       DPRINT2 ("%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       sprintf(errmsg,"%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       status=1;         /* set status to failure */
+    }
+  }
+
+  DPRINT0 ("Sample of first 30 unpacked & restored datapoints=\n");
+  for (i=0; i < 30; i+=5)
+     DPRINT6 ("%03d:  %f %f %f %f %f\n",
+	i, grib_data[i], grib_data[i+1],grib_data[i+2],
+	grib_data[i+3], grib_data[i+4] );
+  
+BYE:
+/*
+*
+* A.16      RETURN Status;
+*/
+  DPRINT2 ("Exiting %s, status=%d\n", func, status);
+  return(status); 
+/* 
+* END OF FUNCTION
+*
+*/
+}    
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbms.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbms.c
new file mode 100644
index 00000000..dad610f8
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetbms.c
@@ -0,0 +1,186 @@
+/*  gribgetbms.c 		June 17, 1996 by Alice Nakajima, SAIC   */
+#include 
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+************************************************************************
+* A.  FUNCTION:   gribgetbms
+*       decode the Bitmap Section from the provided pointer location
+*       and store its info in the internal BMS structure.
+*       Pre-defined Bitmap case is not supported.
+*               
+*    INTERFACE:
+*       int   gribgetbms ( curr_ptr, bms, gds_flag, ulGrid_size, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)   char *curr_ptr;
+*            pointer to location where Bitmap Section to decode is expected;
+*      (O)   BMS_INPUT *bms;
+*            pointer to empty BMS structure; will hold decoded BMS info;
+*      (I)   int gds_flag;      
+*            flag set if GDS is present
+*      (I)   unsigned long ulGrid_size;  
+*            size of grid as in Binary Data Section struct
+*      (O)   char *errmsg
+*            returned filled if error occurred;
+* 
+*     RETURN CODE:
+*     0>  BMS info stored in BMS structure if not using pre-defined bitmap;
+*     1>  error, corrupted bms; msg in errmsg;
+************************************************************************
+*/
+
+#if PROTOTYPE_NEEDED
+int   gribgetbms ( char *curr_ptr, BMS_INPUT *bms, int gds_flag,
+		unsigned long ulGrid_size, char *errmsg)
+#else
+int   gribgetbms (curr_ptr, bms, gds_flag, ulGrid_size, errmsg)
+		char *curr_ptr; 
+		BMS_INPUT *bms; 
+		int gds_flag;
+		unsigned long ulGrid_size; 
+		char *errmsg;
+#endif
+{
+  char *func= "gribgetbms";
+  char  *pp;
+  int totbits,val, bitpos,stopbit;  /* tmp working vars */
+  unsigned long SectLength;       /* message and section size */
+  unsigned long ulvar;		    /* tmp var */
+  unsigned long skip=0;
+
+/*
+*
+* A.0      INIT Status to no error
+*/
+int   status=0;
+
+     DPRINT0 ("Entering gribgetbms():\n");
+/* 
+*
+* A.1      FUNCTION gbyte   !get bitmap length
+*/
+    skip=0;
+    gbyte(curr_ptr,(unsigned long *)&SectLength,&skip,24); 
+    DPRINT0 ("SectLength\n");
+    bms->uslength= (unsigned long) SectLength;
+
+/* 
+*
+* A.2      FUNCTION gbyte   !get number of unused bits
+*/
+    gbyte(curr_ptr,&ulvar,&skip,8); 
+    DPRINT0 ("bms->usUnused_bits\n");
+    bms->usUnused_bits= (unsigned short) ulvar;
+
+/* 
+*
+* A.3      FUNCTION gbyte   !get bitmap id (non-zero for a pre-defined bitmap)
+*/
+    gbyte(curr_ptr,&ulvar,&skip,16); 
+    DPRINT0 ("bms->usBMS_id\n");
+    bms->usBMS_id= (unsigned short) ulvar;
+
+/*
+*
+* A.4      IF (Bitmap follows)   !not a predefined bitmap
+*/
+    if ( bms->uslength > 6)     /* Bitmap follows */
+       {
+
+/* 
+* A.4.1       CALCULATE Num of bits in bitmap
+*/
+         /* = (BMS length)*8 bits - 48 header bits - # of unsused bits */
+         totbits=SectLength*8 - 48 - bms->usUnused_bits;
+
+/*
+* A.4.2       IF (GDS is present AND 
+*                      #bits differs from Grid Size)        !Corrupted BMS
+*                 RETURN 1
+*             ENDIF
+*/
+          if (gds_flag && totbits != ulGrid_size) {
+		DPRINT3( "%s: corrupted BMS, gds_flag set but "\
+		"totbits %d != ulgrid_sz %d\n" 
+		, func, totbits, ulGrid_size);
+
+		sprintf(errmsg, "%s: corrupted BMS, gds_flag set but "\
+		"totbits %d != ulgrid_sz %d\n" , func, totbits, ulGrid_size);
+		status=  (1); /* Corrupted BMS */
+	 	goto BYE;
+		}
+
+/*
+* A.4.3       ASSIGN bitmap pointer to 6th byte of BMS
+*/
+          bms->bit_map =  curr_ptr + 6;
+          pp= bms->bit_map; 
+          bms->ulbits_set= 0; 
+/* 
+*
+* A.4.4       !SUM up total number of bits set
+*             FOR (Each 8-bit block of Total Bits Present in BMS)
+*/
+          for ( ; totbits > 0 ; totbits-=8) 
+          {
+/*
+* A.4.4.1       IF (any of the 8 bits are set) 
+*/
+             if ((val=(int)*pp++) != 0) 
+               {
+
+/*
+* A.4.4.1.1        IF (not within 8 bits of end of bitmap)
+*                      SET stopbit to 0
+*                  ELSE
+*                      SET stopbit to end of bitmap
+*                  ENDIF
+*/
+                 if (totbits > 8) stopbit=0;   /* check all 8 bits */
+                 else stopbit= 7-totbits+1;    /* stop at end of bitmap */
+
+/*
+* A.4.4.1.2        SUM up number of bits set in this BMS byte
+*/
+                 for (bitpos= 7; bitpos >= stopbit; bitpos--)
+                    if (val >> bitpos & 0x0001) bms->ulbits_set += 1;
+/*
+* A.4.4.1       ENDIF  ! any of 8 exists
+*/
+               }
+/*
+* A.4.4     ENDFOR   !each 8-bit loop
+*/
+           }
+/*
+* A.4      ENDIF	!Bitmap follows
+*/
+	}  
+
+/*  else {
+        / * Predefined Bitmap - not supported!! Could add function here 
+	    to load a bitmap from local storage * /
+         bms->uslength=6;	
+         bms->bit_map= Load_predefined_bms (bms->usBMS_id);
+       }
+*/
+
+
+BYE:
+/*
+*
+* A.5     DEBUG Print
+*
+* A.6     RETURN Status 
+*/
+    DPRINT2 ("Exiting %s, Status=%d;\n", func, status);
+    return (status);
+/*
+* END OF FUNCTION
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetgds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetgds.c
new file mode 100644
index 00000000..e667b914
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetgds.c
@@ -0,0 +1,694 @@
+#include 
+#include 
+#include "dprints.h"		/* for dprints & func prototypes  */
+#include "gribfuncs.h"		/* prototypes */
+/*
+  REVISION/MODIFICATION HISTORY:
+       03/07/94 written by Mugur Georgescu CSC, Monterey CA
+       02/01/96 modified by Steve Lowe SAIC, Monterey CA
+       06/19/96 modified by Alice Nakajima SAIC, Monterey CA
+       10/15/97/ATN init usData_type in Projection struct too
+       02/18/98/atn replace projection ids with constants
+*
+******************************************************************* 
+* A.  FUNCTION  gribgetgds 
+*       Decode the Grid Description Section (GDS) from the provided 
+*       pointer location and store its the in the internal GDS structure;
+*
+*    INTERFACE:
+*       int gribgetgds (curr_ptr, gds, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *curr_ptr;        points to 1st octet of GDS
+*      (O)  grid_desc_sec *gds;    internal GDS structure to be filled
+*      (O)  char *errmsg;          returned filled if error occurred
+*
+*    RETURN CODE:
+*       0>  success, struct grid_desc_sec filled;
+*       1>  unsupported projection number, errmsg filled;
+*       2>  section length too short, errmsg filled;
+******************************************************************* 
+*/
+
+#if PROTOTYPE_NEEDED
+int gribgetgds ( char *curr_ptr, grid_desc_sec *gds, char *errmsg)
+#else
+int gribgetgds ( curr_ptr, gds, errmsg)
+		char *curr_ptr; 
+		grid_desc_sec *gds; 
+		char *errmsg;
+#endif
+{
+char *func= "gribgetgds";
+char *in = curr_ptr;      /* pointer to the message */
+unsigned long skip;             /* bits to be skipped */
+unsigned long something;  /* value extracted from message */
+int sign;                 /* sign + or - */
+int status;
+FILE *fp;
+int i;
+ 
+ DPRINT1 ("Entering %s\n", func);
+/*
+*
+* A.0      INIT status to good, skip to 0
+*/
+ status=0;  skip=0;
+/*
+*
+* A.1      FUNCTION gbyte  !GDS length 
+*          IF (length < 32 bytes) THEN
+*             SET error status of 2   !length too short
+*             CONTINUE to load as much info as possible into
+*             structure 'grid_desc_sec' but will return with error
+*          ENDIF
+*/
+ gbyte(in,&something,&skip,24); DPRINT0 ("gds->head.uslength\n");
+ gds->head.uslength = (unsigned short) something;  
+ if (gds->head.uslength < 32) {
+    sprintf(errmsg,
+    "GDS length too short (%ld).  Will attempt to load struct grid_desc_sec\n",
+    gds->head.uslength);
+    status = 2;		/* corrupt length */
+   }
+
+/* 
+*
+* A.2      FUNCTION gbyte  !parm_nv
+*/
+ gbyte(in,&something,&skip,8); DPRINT0 ("gds->head.usNum_v\n");
+ gds->head.usNum_v =(short) something;             
+/* 
+*
+* A.3      FUNCTION gbyte  !parm_pv_pl
+*/
+ gbyte(in,&something,&skip,8); DPRINT0 ("gds->head.usPl_Pv\n");
+ gds->head.usPl_Pv = (short) something;            
+
+/* 
+*
+* A.4      FUNCTION gbyte  !data representation type
+*/
+ gbyte(in,&something,&skip,8); DPRINT0 ("gds->head.usData_type\n");
+ gds->head.usData_type = (short) something;        
+
+/* Remainder of GDS is projection dependent */
+/*
+*
+* A.5      SWITCH (data type)
+*/
+
+ switch(gds->head.usData_type)
+  {
+   case LATLON_PRJ:    	/* Lat/Lon Grid */
+   case GAUSS_PRJ:    	/* Gaussian Latitude/Longitude grid */
+   case ROT_LATLON_PRJ:   	/* Rotated Lat/Lon */
+   case ROT_GAUSS_PRJ:   	/* Rotated Gaussian */
+   case STR_LATLON_PRJ:   	/* Stretched Lat/Lon */
+   case STR_GAUSS_PRJ :   	/* Stretched Gaussian */
+   case STR_ROT_LATLON_PRJ :  /* Stretched and Rotated Lat/Lon */
+   case STR_ROT_GAUSS_PRJ :   /* Stretched and Rotated Gaussian */
+/*
+*           case latlon: 
+*           case gaussian_latlon:
+*           case rotated gaussian:
+*           case stretched latlon:
+*           case stretched gaussian:
+*           case stretched & rotated latlon:
+*           case stretched & rotated gaussian:
+*                 Mark the Projection type 
+*                 FUNCTION gbyte !get Number of Columns
+*/
+       gds->llg.usData_type = gds->head.usData_type;
+
+       gbyte(in, &something, &skip, 16); 
+       DPRINT0 ("gds->llg.usNi\n");
+       gds->llg.usNi = (int) something;                   /* get Ni */
+
+/*
+*                 FUNCTION gbyte !get Number of Rows
+*/
+       gbyte(in, &something, &skip, 16);
+       DPRINT0 ("gds->llg.usNj\n");
+       gds->llg.usNj = (int) something;                   /* get Nj */
+
+/*
+*                 FUNCTION gbyte !get Latitude of First point
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("Sign & gds->llg.lLat1 \n");
+       sign = (int)(something >> 23) & 1;                 /* get sign */
+       gds->llg.lLat1 = (long) (something) & 8388607;     /* get La1 */
+       if(sign)                                           /* negative value */
+          gds->llg.lLat1 = - gds->llg.lLat1;              /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of First point
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("Sign & gds->llg.lLon1 \n");
+       sign = (int)(something >> 23) & 1;                 /* get sign */
+       gds->llg.lLon1 = (long) (something) & 8388607;     /* get Lo1 */
+       if(sign)                                           /* negative value */
+           gds->llg.lLon1 = - gds->llg.lLon1;             /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get resolution & comp flags
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("gds->llg.usRes_flag\n");
+       gds->llg.usRes_flag = (short) something;           /* get resolution & comp flags */
+
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("Sign & gds->llg.lLat2 \n");
+/*
+*                 FUNCTION gbyte !get Latitude of Last point
+*/
+       sign = (int)(something >> 23) & 1;                 /* get sign */
+       gds->llg.lLat2 = (long) (something) & 8388607;     /* get La2 */
+       if(sign)                                           /* negative value */
+          gds->llg.lLat2 = - gds->llg.lLat2;              /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of Last point
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("Sign & gds->llg.lLon2 \n");
+       sign = (int)(something >> 23) & 1;                 /* get sign */
+       gds->llg.lLon2 = (long) (something) & 8388607;     /* get Lo2 */
+       if(sign)                                           /* negative value */
+          gds->llg.lLon2 = - gds->llg.lLon2;              /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitudinal Increment
+*/
+       gbyte(in,&something,&skip,16);
+       DPRINT0 ("gds->llg.iDi\n");
+       gds->llg.iDi = (int) something;			  /* get Di */
+
+/*
+*                 FUNCTION gbyte !get Latitudinal Increment
+*/
+       gbyte(in,&something,&skip,16);
+       DPRINT0 ("gds->llg.iDj\n");
+       gds->llg.iDj = (int) something;			  /* get Dj */
+
+/*
+*                 FUNCTION gbyte !get scanning mode
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("gds->llg.usScan_mode\n");
+       gds->llg.usScan_mode = (short) something;    /* get scaning mode flag */
+
+/*
+*                 FUNCTION gbyte !get reserved octets 29-32
+*/
+       gbyte(in,&something,&skip,32);
+       DPRINT0 ("gds->llg.usZero\n");
+       gds->llg.usZero = (long) something; /* get reserved octets 29 - 32 */
+
+       if (gds->head.usNum_v > 0) {
+/*
+*                 FUNCTION gbyte !get south pole lat
+*/
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("Sign & gds->llg.lLat_southpole \n");
+	 sign = (int)(something >> 23) & 1;                      /* get sign */
+	 gds->llg.lLat_southpole = (long)(something) & 8388607; /* southpole lat*/
+	 if(sign)                                            /* negative value */
+	   gds->llg.lLat_southpole = - gds->llg.lLat_southpole; /* multiply -1 */
+	 
+/*
+*                 FUNCTION gbyte !get south pole lon
+*/
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("Sign & gds->llg.lLon_southpole \n");
+	 sign = (int)(something >> 23) & 1;                      /* get sign */
+	 gds->llg.lLon_southpole =(long)(something) & 8388607; /* southpole lon*/
+	 if(sign)                 /* negative value , multiply by -1 */
+	   gds->llg.lLon_southpole = - gds->llg.lLon_southpole; 
+	 
+/*
+*                 FUNCTION gbyte !angle of rotation
+*/
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("gds->llg.lRotate\n");
+	 gds->llg.lRotate = (long) something;          /* get angle of rotation */
+	 
+/*
+*                 FUNCTION gbyte !get lat pole stretching
+*/
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("Sign & gds->llg.lPole_lat \n");
+	 sign = (int)(something >> 23) & 1;                 /* get sign */
+	 gds->llg.lPole_lat = (long)something & 8388607; /* lat pole stretching */
+	 if(sign)                                           /* negative value */
+	   gds->llg.lPole_lat = - gds->llg.lPole_lat;      /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get lon pole stretching
+*/
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("Sign & gds->llg.lPole_lon \n");
+	 sign = (int)(something >> 23) & 1;                 /* get sign */
+	 gds->llg.lPole_lon= (long)(something) & 8388607; /* lon pole stretching*/
+	 if(sign)                                           /* negative value */
+	   gds->llg.lPole_lon = - gds->llg.lPole_lon;      /* multiply by -1 */
+	 
+	 gbyte(in,&something,&skip,24);
+	 DPRINT0 ("gds->llg.lStretch\n");
+	 gds->llg.lStretch = (long) something;
+       }
+
+/*
+ *                FUNCTION gbyte !get number of columns in each row
+ */
+       if (gds->llg.usNi == 65535) {
+	 if (gds->head.thin == NULL) {
+	   gds->head.thin = (int *)malloc(gds->llg.usNj*sizeof(int));
+	 } else {
+	   gds->head.thin = (int *)realloc(gds->head.thin,
+					   gds->llg.usNj*sizeof(int));
+	 }
+	 if (gds->head.thin == NULL) {
+	   sprintf(errmsg,
+		   "%s: failed to create array[%d] for thinned grid information", 
+		   func, gds->head.thin);
+	   goto BYE;
+	 }
+	 for (i = 0; illg.usNj; i++) {
+	   gbyte(in,&something,&skip,16);
+	   gds->head.thin[i] = (short)something;
+	 }
+       } else {
+	 gds->head.thin = NULL;
+       }
+       break;
+
+    case MERC_PRJ:    /* Mercator Projection Grid               */
+/*
+*           case Mercator Projection Grid:
+*                 Mark the Projection type 
+*                 FUNCTION gbyte !get Number of Columns
+*/
+       gds->merc.usData_type = gds->head.usData_type;
+
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->merc.cols\n");
+       gds->merc.cols = (int) something;                  /* get Ni */
+/*
+*                 FUNCTION gbyte !get Number of Rows
+*/
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->merc.rows\n");
+       gds->merc.rows = (int) something;                  /* get Nj */
+
+/*
+*                 FUNCTION gbyte !get Latitude of First Point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->merc.first_lat\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->merc.first_lat = (long) (something) & 8388607;  /* get La1 */
+       if(sign)                                             /* negative value */
+          gds->merc.first_lat = - gds->merc.first_lat;      /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of First Point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->merc.first_lon\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->merc.first_lon = (long) (something) & 8388607;  /* get Lo1 */
+       if(sign)                                             /* negative value */
+          gds->merc.first_lon = - gds->merc.first_lon;      /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get resolution & comp flag
+*/
+       gbyte(in,&something,&skip,8); 
+       DPRINT0 ("gds->merc.usRes_flag\n");
+       gds->merc.usRes_flag = (short) something;  /* resolution & comp flags */
+
+/*
+*                 FUNCTION gbyte !get Latitude of Last point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->merc.La2\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->merc.La2 = (long) (something) & 8388607;        /* get La2 */
+       if(sign)                                             /* negative value */
+          gds->merc.La2 = - gds->merc.La2;                  /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of Last point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->merc.Lo2\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->merc.Lo2 = (long) (something) & 8388607;        /* get Lo2 */
+       if(sign)                                             /* negative value */
+          gds->merc.Lo2 = - gds->merc.Lo2;                  /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Latitude where projection intersects Earth
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->merc.latin\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->merc.latin = (long) (something) & 8388607;      /* get latin */
+       if(sign)                                             /* negative value */
+          gds->merc.latin = - gds->merc.latin;              /* multiply by -1 */
+
+       skip += 8;      /* skip over the reserved octet */
+
+/*
+*                 FUNCTION gbyte !get scanning mode flag
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("gds->merc.usScan_mode\n");
+       gds->merc.usScan_mode = (short) something;            /* get scaning mode flag */
+
+/*
+*                 FUNCTION gbyte !get Longitudinal Increment
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->merc.lon_inc\n");
+       gds->merc.lon_inc = (float) something;               /* get Di */
+
+/*
+*                 FUNCTION gbyte !get Latitudinal Increment
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->merc.lat_inc\n");
+       gds->merc.lat_inc = (float) something;               /* get Dj */
+
+       gbyte(in,&something,&skip,32);
+       DPRINT0 ("gds->merc.usZero\n");
+       gds->merc.usZero = (long) something;
+
+       if (gds->merc.cols == 65535) {
+	 gds->head.thin = (int *)calloc(gds->merc.rows,sizeof(int));
+	 if (gds->head.thin == NULL) {
+	   sprintf(errmsg,
+		   "%s: failed to create array[%d] for thinned grid information", 
+		   func, gds->head.thin);
+	   goto BYE;
+	 }
+	 for (i = 0; imerc.rows; i++) {
+	   gbyte(in,&something,&skip,16);
+	   gds->head.thin[i] = (short)something;
+	 }
+       } else {
+	 gds->head.thin = NULL;
+       }
+
+       break;
+
+    case POLAR_PRJ:    /* Polar Stereographic Projection Grid    */
+/*
+*           case Polar Stereographic Projection Grid:
+*                 Mark the Projection type 
+*                 FUNCTION gbyte !get Number of Columns
+*/
+       gds->pol.usData_type = gds->head.usData_type;
+
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->pol.usNx\n");
+       gds->pol.usNx = (short) something;                   /* get Nx */
+
+/*
+*                 FUNCTION gbyte !get Number of Rows
+*/
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->pol.usNy\n");
+       gds->pol.usNy = (short) something;                   /* get Ny */
+
+/*
+*                 FUNCTION gbyte !get Latitude of First point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->pol.lLat1\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->pol.lLat1 = (long)  (something) & 8388607;      /* get La1 */
+       if(sign)                                             /* negative value */
+          gds->pol.lLat1 = - gds->pol.lLat1;                /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of First point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->pol.lLon1\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->pol.lLon1 = (long) (something) & 8388607;       /* get Lo1 */
+       if(sign)                                             /* negative value */
+          gds->pol.lLon1 = - gds->pol.lLon1;                /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get resolution & comp flag
+*/
+       gbyte(in,&something,&skip,8); 
+       DPRINT0 ("gds->pol.usRes_flag\n");
+       gds->pol.usRes_flag = (short) something;             /* get resolution & comp flags */
+
+/*
+*                 FUNCTION gbyte !get Orientation Longitude
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->pol.lLon_orient\n");
+       sign = (int)(something >> 23) & 1;                    /* get sign */
+       gds->pol.lLon_orient = (long) (something) & 8388607;  /* Orientation */
+       if(sign)      /* negative value , multiply by -1 */
+          gds->pol.lLon_orient = - gds->pol.lLon_orient;
+
+/*
+*                 FUNCTION gbyte !get Increment along a Row
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("gds->pol.ulDx\n");
+       gds->pol.ulDx = (float) something;                   /* get Dx */
+
+/*
+*                 FUNCTION gbyte !get Increment along a Column
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("gds->pol.ulDy\n");
+       gds->pol.ulDy = (float) something;                   /* get Dy */
+
+/*
+*                 FUNCTION gbyte !get projection center flag
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("gds->pol.usProj_flag\n");
+       gds->pol.usProj_flag = (short) something;  /* Projection center flag */
+
+/*
+*                 FUNCTION gbyte !get scanning mode
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("gds->pol.usScan_mode\n");
+       gds->pol.usScan_mode = (short) something;     /* get scaning mode flag */
+
+/*
+*                 FUNCTION gbyte !reserved zero
+*/
+       gbyte(in,&something,&skip,32);
+       DPRINT0 ("gds->pol.usZero\n");
+       gds->pol.usZero = (int) something;            /* get Reserved zero */
+
+       if (gds->pol.usNx == 65535) {
+	 gds->head.thin = (int *)calloc(gds->pol.usNy,sizeof(int));
+	 if (gds->head.thin == NULL) {
+	   sprintf(errmsg,
+		   "%s: failed to create array[%d] for thinned grid information", 
+		   func, gds->head.thin);
+	   goto BYE;
+	 }
+	 for (i = 0; ipol.usNy; i++) {
+	   gbyte(in,&something,&skip,16);
+	   gds->head.thin[i] = (short)something;
+	 }
+       } else {
+	 gds->head.thin = NULL;
+       }
+
+       break;
+
+   case LAMB_PRJ:  		/* Lambert Conformal */
+   case ALBERS_PRJ:  		/* Albers equal-area */
+   case OBLIQ_LAMB_PRJ: 	/* Oblique Lambert Conformal */
+/*
+*           case Lambert conformal, secant or tangent, conical or bipolar:
+*           case Albers equal-area, secant or tangent, conical or bipolar:
+*           case Oblique Lambert conformal:
+*                 Mark the Projection type 
+*                 FUNCTION gbyte !get Number of Columns
+*/
+       gds->lam.usData_type = gds->head.usData_type;
+
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->lam.iNx\n");
+       gds->lam.iNx = (int) something;                      /* get Nx */
+
+/*
+*                 FUNCTION gbyte !get Number of Rows
+*/
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->lam.iNy\n");
+       gds->lam.iNy = (int) something;                      /* get Ny */
+
+/*
+*                 FUNCTION gbyte !get Latitude of First Point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->lam.lLat1\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->lam.lLat1 = (long)  (something) & 8388607;      /* get La1 */
+       if(sign)                                             /* negative value */
+          gds->lam.lLat1 = - gds->lam.lLat1;                /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get Longitude of First Point
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->lam.lLon1)\n");
+       sign = (int)(something >> 23) & 1;                   /* get sign */
+       gds->lam.lLon1 = (long) (something) & 8388607;       /* get Lo1 */
+       if(sign)                                             /* negative value */
+          gds->lam.lLon1 = - gds->lam.lLon1;                /* multiply by -1 */
+
+/*
+*                 FUNCTION gbyte !get resolution & comp flag
+*/
+       gbyte(in,&something,&skip,8); 
+       DPRINT0 ("gds->lam.usRes_flag\n");
+       gds->lam.usRes_flag = (short) something;  /* resolution & comp flags */
+
+/*
+*                 FUNCTION gbyte !get Orientation Longitude
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->lam.lLon_orient)\n");
+       sign = (int)(something >> 23) & 1;                    /* get sign */
+       gds->lam.lLon_orient = (long) (something) & 8388607;  /* Orientation */
+       if(sign)              /* negative value , multiply by -1 */
+          gds->lam.lLon_orient = - gds->lam.lLon_orient;     
+
+/*
+*                 FUNCTION gbyte !get Increment along a Row
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->lam.ulDx\n");
+       gds->lam.ulDx = (float) something;                    /* get Dx */
+
+/*
+*                 FUNCTION gbyte !get Increment along a Column
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->lam.ulDy\n");
+       gds->lam.ulDy = (float) something;                    /* get Dy */
+
+/*
+*                 FUNCTION gbyte !get Projection Center
+*/
+       gbyte(in,&something,&skip,8); 
+       DPRINT0 ("gds->lam.usProj_flag\n");
+       gds->lam.usProj_flag= (short) something;  /* Projection center flag */
+
+/*
+*                 FUNCTION gbyte !get scanning mode flag
+*/
+       gbyte(in,&something,&skip,8); 
+       DPRINT0 ("gds->usScan_mode\n");
+       gds->lam.usScan_mode = (short) something;    /* get scaning mode flag */
+
+/*
+*                 FUNCTION gbyte !get First lat from pole that intersects Earth
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->lLat_cut1\n");
+       gds->lam.lLat_cut1 = (long) something;                /* get latin_1 */
+
+/*
+*                 FUNCTION gbyte !get Second lat from pole that intersects Earth
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("gds->lLat_cut2\n");
+       gds->lam.lLat_cut2 = (long) something;                /* get latin_2 */
+
+/*
+*                 FUNCTION gbyte !get lat of south pole
+*/
+       gbyte(in,&something,&skip,24);
+       DPRINT0 ("Sign & gds->lLat_southpole\n");
+       sign = (int)(something >> 23) & 1;                        /* get sign */
+       gds->lam.lLat_southpole = (long) (something) & 8388607;   /* lat S.pole*/
+       if(sign)      /* negative value , multiply by -1 */ 
+           gds->lam.lLat_southpole = - gds->lam.lLat_southpole;
+
+/*
+*                 FUNCTION gbyte !get lon of South pole
+*/
+       gbyte(in,&something,&skip,24); 
+       DPRINT0 ("Sign & gds->lLon_southpole\n");
+       sign = (int)(something >> 23) & 1;                        /* get sign */
+       gds->lam.lLon_southpole = (long) (something) & 8388607;/* lon S.pole */
+       if(sign)     /* negative value, multiply by -1 */ 
+           gds->lam.lLon_southpole = - gds->lam.lLon_southpole;
+
+/*
+*                 FUNCTION gbyte !get Reserved zero
+*/
+       gbyte(in,&something,&skip,16); 
+       DPRINT0 ("gds->lam.usZero\n");
+       gds->lam.usZero = (int) something;                    /* Reserved zero */
+
+       gds->head.thin = NULL;
+
+       if (gds->lam.iNx == 65535) {
+	 gds->head.thin = (int *)calloc(gds->lam.iNy,sizeof(int));
+	 if (gds->head.thin == NULL) {
+	   sprintf(errmsg,
+		   "%s: failed to create array[%d] for thinned grid information", 
+		   func, gds->head.thin);
+	   goto BYE;
+	 }
+	 for (i = 0; ilam.iNy; i++) {
+	   gbyte(in,&something,&skip,16);
+	   gds->head.thin[i] = (short)something;
+	 }
+       } else {
+	 gds->head.thin = NULL;
+       }
+
+       break;
+
+    default :             /* other cases not implemented in this version */
+/*
+*             default:   ! unsupported data types
+*                 SET Status to bad
+*/
+       DPRINT2 ("%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       sprintf(errmsg,"%s:  unknown datatype=%d\n",func, gds->head.usData_type);
+       status=1;         /* set status to failure */
+       break;
+/*
+*
+* A.5      ENDSWITCH
+*/
+  }  /* end switch on data type */
+
+/*
+*
+* A.6      DEBUG Print
+*
+* A.7      RETURN (status)
+*/
+ BYE:
+  DPRINT2 ("Exiting %s, stat=%d\n", func,status);
+  return(status);
+/*
+*  END OF FUNCTION 
+*
+*/
+}  
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetpds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetpds.c
new file mode 100644
index 00000000..181034d9
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribgetpds.c
@@ -0,0 +1,374 @@
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+/* REVISION/MODIFICATION HISTORY:
+       03/07/94 written by Mugur Georgescu CSC, Monterey CA
+       02/01/96 modified by Steve Lowe SAIC, Monterey CA
+       06/18/96 modified by Alice T. Nakajima (ATN), SAIC, Monterey CA 
+       01/22/98 ATN, MRY SAIC
+       04/22/98 ATN change requirement for using extensions.
+*
+************************************************************************
+* A.  FUNCTION  gribgetpds
+*       Decode the Product Definition Section (PDS) from the provided 
+*       pointer location and store the info in the internal PDS structure.
+*
+*    INTERFACE:
+*       int gribgetpds (curr_ptr, pds, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *curr_ptr;    pointer to first octet of PDS
+*      (O)  PDS_INPUT *pds;    empty PDS structure to be filled
+*      (O)  char *errmsg;      returned filled if error occurred
+* 
+*     RETURN CODE:
+*     0>  Always,  PDS info stored in Pds structure;
+************************************************************************
+*/
+int get_factor(int unit);
+#if PROTOTYPE_NEEDED
+int gribgetpds ( char *curr_ptr, PDS_INPUT *pds, char *errmsg)
+#else
+
+int gribgetpds ( curr_ptr, pds, errmsg)
+		char *curr_ptr; 
+		PDS_INPUT *pds; 
+		char *errmsg;
+#endif
+{
+char *in = curr_ptr;      /* pointer to the message */
+unsigned long skip=0;              /* bits to be skipped */
+unsigned long something;  /* value extracted from message */
+int sign;                 /* sign + or - */
+ int unit;
+ int P1, P2;
+
+ DPRINT0 ("Entering gribgetpds()\n");
+/*
+*
+* A.1       FUNCTION gbyte !3-byte PDS length
+*/
+ gbyte(in,&something,&skip,24); 
+ DPRINT0 ("pds->uslength\n");
+ pds->uslength = (unsigned short) something;       
+
+/*
+*
+* A.2       FUNCTION gbyte !parameter table version
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usParm_tbl\n");
+ pds->usParm_tbl = (unsigned short) something;     
+
+/*
+*
+* A.3       FUNCTION gbyte !center identification
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usCenter_id\n");
+ pds->usCenter_id = (unsigned short) something;    
+
+/*
+*
+* A.4       FUNCTION gbyte !generating process id
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usProc_id\n");
+ pds->usProc_id = (unsigned short) something;      
+
+/*
+*
+* A.5       FUNCTION gbyte !grid identification
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usGrid_id\n");
+ pds->usGrid_id = (unsigned short) something;      
+
+/*
+*
+* A.6       FUNCTION gbyte !flag of GDS, BMS presence
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usGds_bms_id\n");
+ pds->usGds_bms_id = (unsigned short) something;   
+
+/*
+*
+* A.7       FUNCTION gbyte !parameter indicator and units 
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usParm_id\n");
+ pds->usParm_id = (unsigned short) something;      
+
+/*
+*
+* A.8       FUNCTION gbyte !level type indicator
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usLevel_id\n");
+ pds->usLevel_id = (unsigned short) something;  
+
+ /* switch on Level_id to determine if level or layer */
+/*
+*
+* A.9       SWITCH (level_id)
+*/
+ switch(pds->usLevel_id)
+    {
+    case 101: /* layer between two isobaric surfaces */
+    case 104: /* layer between two specified altitudes */
+    case 106: /* layer between two specified height levels above ground */
+    case 108: /* layer between two sigma levels */
+    case 110: /* layer between two hybrid levels */
+    case 112: /* layer between two depths below land surface */
+    case 114: /* layer between two isentropic levels */
+    case 121: /* layer between two isobaric surfaces (high precision) */
+    case 128: /* layer between two sigma levels (high precision) */
+    case 141: /* layer between two isobaric surfaces (mixed precision) */
+/*
+*              layer:
+*                 FUNCTION gbyte !top of layer
+*                 FUNCTION gbyte !bottom of layer
+*/
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("pds->usHeight1\n");
+       pds->usHeight1 = (unsigned short) something;  /* top layer */
+       gbyte(in,&something,&skip,8);
+       DPRINT0 ("pds->usHeight2\n");
+       pds->usHeight2 = (unsigned short) something;  /* bottom layer */
+       break;
+
+    default:  /* all others (levels) */
+/*
+*              default:  !assume a level
+*                 FUNCTION gbyte !level value
+*                 SET Height2 to ZERO
+*/
+       gbyte(in,&something,&skip,16);
+      DPRINT0 ("pds->usHeight1\n");
+       pds->usHeight1 = (unsigned short) something;
+       pds->usHeight2 = 0.0;                
+       break;
+    }
+/*
+* A.9       ENDSWITCH
+*/
+
+/*
+*
+* A.10      FUNCTION gbyte !year of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usYear\n");
+ pds->usYear = (unsigned short) something;   
+
+/*
+*
+* A.11      FUNCTION gbyte !month of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usMonth\n");
+ pds->usMonth = (unsigned short) something;   
+
+/*
+*
+* A.12      FUNCTION gbyte !day of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usDay\n");
+ pds->usDay = (unsigned short) something;      
+
+/*
+*
+* A.13      FUNCTION gbyte !hour of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usHour\n");
+ pds->usHour = (unsigned short) something;      
+
+/*
+*
+* A.14      FUNCTION gbyte !minute of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usMinute\n");
+ pds->usMinute = (unsigned short) something;     
+
+/*
+*
+* A.15      FUNCTION gbyte !forecast time unit
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usFcst_unit_id\n");
+ pds->usFcst_unit_id = (unsigned short) something;
+
+/*
+*
+* A.16      FUNCTION gbyte !forecast period 1
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usP1\n");
+ pds->usP1 = (unsigned short) something;         
+
+/*
+*
+* A.17      FUNCTION gbyte !forecast period 2
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usP2\n");
+ pds->usP2 = (unsigned short) something;          
+
+/*
+*
+* A.18      FUNCTION gbyte !time range indicator
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usTime_range\n");
+ pds->usTime_range = (unsigned short) something;   
+
+/*
+*
+* A.19      FUNCTION gbyte !#included in average
+*/
+ gbyte(in,&something,&skip,16); 
+ DPRINT0 ("pds->usTime_range_avg\n");
+ pds->usTime_range_avg = (unsigned short) something;
+
+/*
+*
+* A.20      FUNCTION gbyte !#missing from average
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usTime_range_mis\n");
+ pds->usTime_range_mis = (unsigned short) something;
+
+/*
+*
+* A.21      FUNCTION gbyte !century of Reference Data/Time
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usCentury\n");
+ pds->usCentury = (unsigned short) something;  
+
+/*
+*
+* A.22      FUNCTION gbyte !originating Sub-Center  (Oct 26)
+*/
+ gbyte(in,&something,&skip,8); 
+ DPRINT0 ("pds->usCenter_sub (Oct 26)\n");
+ pds->usCenter_sub = 	(unsigned short) something;
+
+/*
+*
+* A.23      FUNCTION gbyte !decimal scale factor
+*/
+ gbyte(in,&something,&skip,16); 
+      DPRINT0 ("Sign & pds->sDec_sc_fctr\n");
+ sign = (int)(something >> 15) & 1;                /* sign bit*/
+ pds->sDec_sc_fctr = (short) (something) & 32767;  /* Decimal sclfctr D */
+ if(sign)                                          /* negative Dec. sclfctr*/
+    pds->sDec_sc_fctr = - pds->sDec_sc_fctr;       /* multiply by -1 */
+
+ /*
+  * This is the WSI extension for forecast time unit
+  */
+
+ if (pds->usTime_range == 255)
+   {
+
+     /* Skip ahead to byte 41 */
+     skip += 96;
+     
+     /* Get forecast time unit for P1 from byte 41 */
+     gbyte(in,&something,&skip,8);
+     unit = (unsigned short)something;
+     
+     /* Get P1 */
+     gbyte(in,&something,&skip,32);
+     P1 = (unsigned int)something;
+     pds->usP1 = get_factor(unit)*P1;
+
+     /* Get forecast time unit for P2 from byte 46 */
+     gbyte(in,&something,&skip,8);
+     unit = (unsigned short)something;
+
+     /* Get P2 */
+     gbyte(in,&something,&skip,32);
+     P2 = (unsigned int)something;
+     pds->usP2 = get_factor(unit)*P2;
+
+     /* Get Time Range Indicator */
+     gbyte(in,&something,&skip,8);
+     pds->usTime_range = (unsigned short)something;
+
+     /* 
+      * Set forecast time unit to seconds, since we've converted usP1 and usP2
+      *   to seconds.
+      */
+     pds->usFcst_unit_id = 254;
+   }
+
+/*
+* A.26      DEBUG Print
+*/
+  DPRINT0 ("Exiting gribgetpds(), status=0\n");
+
+/*
+* 
+* A.27      RETURN 0  !success
+*/
+return(0);
+/*
+* END OF FUNCTION
+*
+*
+*/
+} 
+/*****************************************************************************
+ *
+ * returns the multiplication factor to convert grib forecast times to 
+ *   seconds.
+ *
+ * Input: 
+ *    unit_id  - grib forecast unit id, from Table 4.
+ *
+ * Return:
+ *    conversion factor
+ *****************************************************************************/
+int get_factor(int unit)
+{
+  int factor;
+  
+  switch (unit) {
+  case 0:
+    factor = 60;
+    break;
+  case 1:
+    factor = 60*60;
+    break;
+  case 2:
+    factor = 60*60*24;
+    break;
+  case 10:
+    factor = 60*60*3;
+    break; 
+  case 11:
+    factor = 60*60*3;
+    break;
+  case 12:
+    factor = 60*60*12;
+    break;
+  case 50:
+    /* This is a WSI (non-standard) time unit of 5 minutes */
+    factor = 5*60;
+    break;
+  case 254:
+    factor = 1;
+    break;
+  default:
+    fprintf(stderr,"Invalid unit for forecast time: %d\n",unit);
+    factor = 0;
+  }
+  return factor;
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribhdr2file.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribhdr2file.c
new file mode 100644
index 00000000..41c248bc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribhdr2file.c
@@ -0,0 +1,222 @@
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+/*
+*
+************************************************************************
+* A.  FUNCTION  gribhdr2file
+*       write out the Grib message stored in GRIB_HDR struct to stream;
+*       if the 'shuffle' flag is set, write each individual section out, else
+*       write 'entire_msg' all at once;
+*               
+*    INTERFACE:
+*       int    gribhdr2file (gh, fn, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) GRIB_HDR *gh    holds the GRIB message to be written out
+*      (I) FILE *stream    open strem to write to
+*      (O) char *errmsg    array returned empty unless error occurred;
+*
+*     RETURN CODE:
+*     0>  no errors,  GRIB file successfully created;
+*     1>  error; errmsg is filled;
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int    gribhdr2file ( GRIB_HDR *gh, FILE *stream, char *errmsg)
+#else
+int    gribhdr2file ( gh, stream, errmsg)
+			GRIB_HDR *gh; 
+			FILE *stream; 
+			char *errmsg;
+#endif
+{
+  int fd;
+  int stat;
+  char *func= "gribhdr2file";
+
+  fd = fileno(stream);
+  if (fd == -1) 
+    {
+      DPRINT1 ("%s: Invalid file stream encountered.\n", func);
+      return 1;
+      
+    }
+
+  stat = gribhdr2filed ( gh, fd, errmsg);
+  return stat;
+  
+}
+
+
+/*
+*
+************************************************************************
+* A.  FUNCTION  gribhdr2file
+*       write out the Grib message stored in GRIB_HDR struct to file 
+*       descriptor;
+*       if the 'shuffle' flag is set, write each individual section out, else
+*       write 'entire_msg' all at once;
+*               
+*    INTERFACE:
+*       int    gribhdr2file (gh, fn, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) GRIB_HDR *gh    holds the GRIB message to be written out
+*      (I) int f1          open file descriptor to write to
+*      (O) char *errmsg    array returned empty unless error occurred;
+*
+*     RETURN CODE:
+*     0>  no errors,  GRIB file successfully created;
+*     1>  error; errmsg is filled;
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int    gribhdr2filed ( GRIB_HDR *gh, int f1, char *errmsg)
+#else
+int    gribhdr2filed ( gh, f1, errmsg)
+			GRIB_HDR *gh; 
+			int f1; 
+			char *errmsg;
+#endif
+{
+/*
+*
+* A.0     DEFAULT to error status of 1
+*/
+char *func= "gribhdr2file";
+int  stat=1;		
+char wrstring[4];
+ int check;
+
+/*
+*
+* A.1     IF (entire msg array is null or msg length is 0)
+*         THEN 
+*            RETURN error stat !errmsg filled
+*         ENDIF
+*/
+  DPRINT1("Entering %s\n", func);
+  if (gh->entire_msg == NULL || gh->msg_length <= 0) {
+	DPRINT1 ("%s: GRIB_HDR message buffer is null, OR msg_length=0\n",func);
+	sprintf(errmsg,"%s: GRIB_HDR message buffer is null, OR msg_length=0\n",
+	func);
+	goto BYE;
+	}	
+
+/*
+*
+* A.2     IF (in Shuffle mode)
+*         THEN 
+*            IF (length of EDS/PDS/BDS/EDS is 0) THEN
+*               RETURN error stat !errmsg filled
+*            ENDIF
+*         ENDIF
+*/
+  if (gh->shuffled) {
+	if (!gh->ids_len|| !gh->pds_len || !gh->bds_len|| !gh->eds_len) {
+	   DPRINT1("%s:  Shuffle mode: Zero length encountered, quit\n", func);
+	   sprintf(errmsg,
+	   "%s:  Shuffle mode: Zero length encountered, quit\n", func);
+	   goto BYE; }
+	DPRINT1 ("%s:   this mesg is in shuffled mode;\n", func);
+	}
+
+/*
+*
+* A.4     IF (in shuffled mode) 
+* A.4.a   THEN
+*/
+  if (gh->shuffled) {
+/*
+* A.4.a.1    IF (fails to write IDS OR fails to write PDS OR
+*                (GDS exists AND fails to write GDS) OR 
+*                (BMS exists AND fails to write BMS) OR 
+*                fails to write BDS or fails to write EDS)
+*            THEN
+*               RETURN error stat !errmsg filled
+*            ENDIF
+*/
+     if (write (f1, gh->ids_ptr , gh->ids_len) != gh->ids_len)
+        {
+          DPRINT1 ("%s:  failed to write IDS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write IDS to file\n", func);
+          goto BYE;
+        }
+     if (write (f1, gh->pds_ptr , gh->pds_len) != gh->pds_len)
+        {
+          DPRINT1 ("%s:  failed to write PDS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write PDS to file\n", func);
+          goto BYE;
+        }
+     if (gh->gds_len)
+     if (write (f1, gh->gds_ptr , gh->gds_len) != gh->gds_len)
+        {
+          DPRINT1 ("%s:  failed to write GDS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write GDS to file\n", func);
+          goto BYE;
+        }
+     if (gh->bms_len)
+     if (write (f1, gh->bms_ptr , gh->bms_len) != gh->bms_len)
+        {
+          DPRINT1 ("%s:  failed to write BMS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write BMS to file\n", func);
+          goto BYE;
+        }
+     if (write (f1, gh->bds_ptr , gh->bds_len) != gh->bds_len)
+        {
+          DPRINT1 ("%s:  failed to write BDS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write BDS to file\n", func);
+          goto BYE;
+        }
+     if (write (f1, gh->eds_ptr , gh->eds_len) != gh->eds_len)
+        {
+          DPRINT1 ("%s:  failed to write EDS to file\n", func);
+          sprintf(errmsg,"%s:  failed to write EDS to file\n", func);
+          goto BYE;
+        }
+     DPRINT0 ("ALL Sections to written to file successfully\n");
+     }
+/*
+* A.4.b   ELSE
+*/
+   else {
+        DPRINT0 ("Writing gh->entire_msg (non-shuffled)\n");
+/*
+* A.4.b.1    IF (fails to write msg_length byte straight from Entire_msg)
+*            THEN
+*                RETURN error stat !errmsg filled
+*            ENDIF
+*/
+        if ((check = write (f1, gh->entire_msg, gh->msg_length)) != 
+	    gh->msg_length) {
+	    DPRINT1( "%s:  failed to write GH's entire Msg to file\n",func);
+	    sprintf(errmsg,
+	    "%s:  failed to write GH's entire Msg to file %d\n",func,check);
+	    /*	    goto BYE;  */
+	   }
+  	DPRINT0 ("write GH's entire_msg to file successful\n");
+/*
+* A.4     ENDIF
+*/
+        }
+/*
+*
+* A.5     DONE, set status to 0  !no errors
+*/
+  stat = 0;
+
+BYE:
+
+/*
+*
+* A.7     RETURN with stat
+*/
+  DPRINT2 ("Leaving %s, stat=%d;\n", func, stat);
+  return stat;
+/*
+*
+* END OF FUNCTION
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribputbds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputbds.c
new file mode 100644
index 00000000..7daee370
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputbds.c
@@ -0,0 +1,247 @@
+#include 
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+******************************************************************************
+* A.  FUNCTION:  gribputbds
+*       Use the information provided to create a  Binary Data Section of
+*       the GRIB format and store it in the GRIB_HDR structure;
+*
+*    INTERFACE:
+*      int   gribputbds (user_input, lgrid_size, sDec_sc_fctr, pfData_Array,
+*                         pBDS_Head_Input,  pgrib_hdr, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  USER_INPUT user_input;   
+*           Structure containing encoder configuration data
+*      (I)  long lgrid_size;         
+*           number of datapoints expected for this projection
+*      (I)  short sDec_sc_fctr;
+*           Decimal Scle Factor used when packing up data 
+*    (I&O)  float *pfData_Array;
+*           float array to be packed up.  Returned scaled up by Dec Scale Fctr.
+*      (O)  BDS_HEAD_INPUT *pBDS_Head_Input  
+*           returned filled;
+*    (I&O)  GRIB_HDR **pgrib_hdr;    
+*           structure to hold encoded BDS and its info
+*      (O)  char *errmsg
+*           empty array, returned filled if error occurred;
+*
+*     RETURN CODE:
+*      0> no errors; GRIB_HDR now has a valid Binary Data Section;
+*         BDS_HEAD_INPUT filled also;
+*      1> error occurred, errmsg filled;
+*         either GRIB_HDR structure is corrupted, or
+*         non-shuffle mode but the Data array is Null, or
+*         failed to pack the Data array up, or 
+*         failed to expand 'entire_msg' in GRIB_HDR to support encoded BDS;
+******************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int   gribputbds ( USER_INPUT user_input, long lgrid_size,
+		short sDec_sc_fctr, float *pfData_Array,
+		BDS_HEAD_INPUT *pBDS_Head_Input, GRIB_HDR **pgrib_hdr,
+		char *errmsg)
+#else
+int   gribputbds ( user_input, lgrid_size, sDec_sc_fctr, pfData_Array,
+		   pBDS_Head_Input, pgrib_hdr, errmsg)
+ 
+		  USER_INPUT    user_input;             /* input */
+		  long          lgrid_size;             /* input */
+		  short                 sDec_sc_fctr;   /* input */
+		  float                 *pfData_Array;  /* input */
+		  BDS_HEAD_INPUT  *pBDS_Head_Input;     /* output */
+		  GRIB_HDR      **pgrib_hdr;            /* input & output */
+		  char          *errmsg;                /* output */
+		 
+#endif
+{
+/*
+*
+* A.0       DEFAULT to Error Stat
+*/
+char *func= "gribputbds";
+long lBDS_length= 0;    /* Rnd2_len bytes */
+void *pvbstr= 0;	/* remains null until after Inp2true_bds */
+GRIB_HDR *gh;		/* working var */
+long newsize;		/* working var */
+void  create_inpBDS();
+int  n, stat=1;
+
+    DPRINT1 ("\nEntering %s() ...\n",func);
+/*
+*
+* A.1       ASSIGN the GRIB_HDR pointer to local ptr;
+*           IF (it's null OR entire_msg is null) THEN
+*              RETURN error !errmsg filled
+*           ENDIF
+*/
+    gh= *pgrib_hdr;
+    if (!gh || !gh->entire_msg) {
+	DPRINT1( "%s:  Grib Header or its Entire_msg is NULL\n", func);
+	sprintf(errmsg,"%s:  Grib Header or its Entire_msg is NULL\n", func);
+	goto BYE;
+	}
+
+/*
+*
+* A.2       IF (the floating point array is null) THEN
+*/
+    if (pfData_Array == NULL) {
+
+/*
+* A.2.1         IF (creating all sections mode) 
+* A.2.1.a       THEN
+*                  RETURN error      !cannot go on w/o float array
+*/
+ 	  if  (! gh->shuffled) {
+	       DPRINT1 ("%s:  Float array is Null, cannot proceed;\n",func);
+	       sprintf(errmsg,
+		"%s:  Float array is Null, cannot proceed;\n",func);
+		goto BYE;
+	       }
+/*
+* A.2.1.b       ELSE   /# Create all sections mode #/
+*                  !bds must already exist & has non-zero length, else error;
+*
+*                  IF (bds is null or bdslen <=0) THEN
+*                      RETURN error    !errmsg filled
+*                  ELSE
+*                      RETURN no error !bds already defined & has nonzero len
+*                  ENDIF
+*/
+	  else {  /* create all mode */
+		if (gh->bds_ptr== NULL || gh->bds_len<=0) 
+		   {
+	            DPRINT3 ( "%s:  No FloatData avail and GribHdr "\
+		    "has no BDS yet (ptr=%ld len=%ld)\n"
+		     ,func,gh->bds_ptr,gh->bds_len); 
+	            sprintf(errmsg, 
+		    "%s:  No FloatData avail and GribHdr has no BDS yet"\
+		    "(ptr=%ld len=%ld)\n",func,gh->bds_ptr,gh->bds_len); 
+		    }
+		else { 
+		    stat= 0;
+	            DPRINT2 ("%s: No need to proceed, GribHdr already "\
+		    "has a BDS  (len=%ld)\n", func, gh->bds_len);  
+		   }
+/*
+* A.2.1         ENDIF
+*/
+	       } /* if */
+
+/*
+* A.2.2         RETURN with Stat   !not decoding anything
+*/
+	goto BYE;  /* quit */
+/*
+*
+* A.2       ENDIF    !no float data
+*/
+      }  /* no flt data */
+
+
+    DPRINT0 ("Need to pack Float Data & Store in (Char*);\n");
+
+/*
+*
+* A.3         FILL the BDS Head Input struct;
+*/
+   pBDS_Head_Input->Bin_sc_fctr = 0;     /* INPUT NOT USED AT THIS TIME */
+   pBDS_Head_Input->fReference = 0.0;    /* INPUT NOT USED AT THIS TIME */
+   pBDS_Head_Input->usBit_pack_num = user_input.usBit_pack_num;
+                                         /* #bits used for packing, 0=default*/
+   pBDS_Head_Input->ulGrid_size = (unsigned long) lgrid_size;  /* Grid size */
+   pBDS_Head_Input->fPack_null = 1e10;   /* Pack null value */
+
+   DPRINT3 ("\t bds_head_input->usBit_pack_num = %u\n" \
+           "\t bds_head_input->ulGrid_size = %u\n" \
+          "\t bds_head_input->fPack_null = %f\n",
+          pBDS_Head_Input->usBit_pack_num, pBDS_Head_Input->ulGrid_size,
+          pBDS_Head_Input->fPack_null );
+   
+/*
+*
+* A.4       FUNCTION pack_spatial !packs data into binary bitstream
+*           IF (error in pack grid routine)
+*           THEN
+*               RETURN with error !errmsg filled
+*           ENDIF
+*/
+     if ((n= pack_spatial ( (long *)&(pBDS_Head_Input->ulGrid_size),
+                    &(pBDS_Head_Input->usBit_pack_num),
+                    &(pBDS_Head_Input->fPack_null),
+                    pfData_Array, 
+		    (unsigned long **) &pvbstr, 
+		    sDec_sc_fctr, &lBDS_length, errmsg)) )
+          {
+          DPRINT2 ("%s:  Pack Spatial returned err=%d\n", func, n);
+          upd_child_errmsg (func, errmsg);
+          goto BYE;
+          }
+
+/*
+*
+* A.5       CALCULATE new message length including new BDS
+*             (Include 4 bytes for EDS to avoid another realloc)
+*/
+     newsize=  gh->msg_length + lBDS_length + 4;
+
+/* 
+*
+* A.6       IF gribhdr's buffer is too small AND
+*               FUCTION Expand_gribhdr failed 
+*           THEN
+*               RETURN with error   !errmsg filled
+*           ENDIF
+*/
+     if (newsize > gh->abs_size 
+	&& Expand_gribhdr (gh, newsize, errmsg) !=0) 
+	{
+	upd_child_errmsg (func, errmsg);
+	goto BYE;
+	}
+
+/*
+*
+* A.7       STORE bds & its info into Grib Hdr
+*           !copy true BDS struct over into entire message array
+*           !update message length also in Grib Hdr
+*           !save length of bds into Internal Struct too
+*/
+    gh->bds_ptr= gh->entire_msg + gh->msg_length;
+    memcpy ((void *) gh->bds_ptr, pvbstr, lBDS_length);
+    gh->bds_len    = lBDS_length;
+    gh->msg_length += gh->bds_len;
+
+    /* Added by Todd Hutchinson, TASC  4/16/99*/
+    /* This stops a memory leak */
+    free(pvbstr);
+
+    pBDS_Head_Input->length = lBDS_length;  /* update the Input struct too */
+
+    DPRINT2("%s: copied %ld bytes from pvbstr to BDSPTR\n", func, lBDS_length);
+
+/*
+*
+* A.8       CHANGE status to no errors
+*/
+    stat = 0;
+
+BYE:
+/*
+*
+* A.9       RETURN w/ Stat
+*/
+    DPRINT2 ("Leaving %s,  Stat=%d\n", func , stat);
+    return (stat);
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribputgds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputgds.c
new file mode 100644
index 00000000..d4e86b79
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputgds.c
@@ -0,0 +1,1472 @@
+#include 
+#include 
+#include 
+#ifdef XT3_Catamount
+#include 
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#else
+#include 
+#endif
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+#include 
+
+/*
+************************************************************************
+* A. FUNCTION  gribputgds
+*      used to decode Grib's Grid Defn Section.  It returns with both
+*      internal structures GDS_HEAD_INPUT and VOID* projblock filled,
+*      and also with true GDS already appended to GribHeader's Entire_Msg;
+*
+*    INTERFACE:
+*      int   gribputgds (Geom_In, pGDS_Head_Input, ppvGDS_Proj_Input,
+*                        ppgrib_hdr, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  GEOM_IN  Geom_In
+*           Geometry information used as input;
+*      (O)  GDS_HEAD_INPUT *pGDS_Head_Input
+*           this is the internal GDS structure.  Attributes (uslength, 
+*           usData_type, chData_type, usNum_v and usPl_Pv) gets updated;
+*      (O)  void  **ppvGDS_Proj_Input;  
+*           This is a pre-alloced storage of type Void and has length of
+*           MAX_INP_PROJ_SIZE bytes long.  How this block is filled depends 
+*           on the type of Projection it is.  Projections currently supported 
+*           are Spherical, Lambert, and Polar Stereographic. 
+*     (I&O) GRIB_HDR  **ppgrib_hdr
+*           may already have one or more of the other Grib Sections
+*           (IDS, PDS, BMS, BDS, or EDS).   Upon successful exit, will
+*           also contain a GDS section.
+*      (O)  char  *errmsg               
+*           empty array, returned filled if error occurred;
+*
+*      RETURN CODE:
+*      0>  no errors;  GDS appended to GRIB_HDR's entire_msg, its info 
+*          stored in bds_len & bds_ptr;  msg_length updated too;
+*      1>  error, grib hdr is null; errmsg filled;
+************************************************************************
+*/
+
+/*
+NCAR AIX does not have lrint, make one up.
+*/
+#ifdef NCARIBM_NOC99
+#define lrint(dbl) ((long)rint(dbl))
+#endif
+
+#if PROTOTYPE_NEEDED
+int   gribputgds ( GEOM_IN  Geom_In, GDS_HEAD_INPUT *pGDS_Head_Input,
+		void  **ppvGDS_Proj_Input, GRIB_HDR  **ppgrib_hdr,
+		char  *errmsg)
+#else
+int   gribputgds ( Geom_In, pGDS_Head_Input, ppvGDS_Proj_Input, 
+						ppgrib_hdr, errmsg)
+		GEOM_IN  Geom_In; 
+		GDS_HEAD_INPUT *pGDS_Head_Input;
+		void  **ppvGDS_Proj_Input; 
+		GRIB_HDR  **ppgrib_hdr;
+		char  *errmsg;
+#endif
+{
+/*
+* A.0       DEFAULT to err stat 1
+*/
+  char		  *func= "gribputgds";
+  char		  *pgds=0;	 /* true grib, GDS_HEAD + Proj block */
+  GDS_HEAD 	  *pGDS_Head=0;	 /* first 6 bytes of PGDS */
+  void 		  *pvGDS_Proj=0;  /* projection info, PGDS 7th byte and on... */
+  long 		  lProj_sz ;	 /* size of True-Grib projection block  */
+  long		  new_msgsz;	 /* size after adding GDS */
+  GRIB_HDR	  *gh=0;	 /* temp ptr to struct */
+  unsigned char   ucflag;
+  int		  tempsz, stat=  1;
+
+GDS_LATLON_INPUT *mp;
+
+
+  DPRINT0 ("\nEntering  gribputgds .....\n");
+/*
+*
+* A.1       IF (Grib Hdr is null) THEN
+*               RETURN error Stat !null ptrs msg in errmsg
+*           ENDIF
+*/
+   gh = *ppgrib_hdr; 
+   if (!gh || !gh->entire_msg) {
+ 	DPRINT1("%s: grib header is null\n", func);
+ 	sprintf(errmsg,"%s: grib header is null\n", func);
+	goto BYE;
+	}
+
+/*
+*
+* A.3       ALLOCATE space for True Grib Structs GDS_HEAD & VOID *proj;
+*           IF (fails) THEN
+*              RETURN with bad Stat !errmsg filled
+*           ELSE  
+*              CLEAR out structs
+*           ENDIF
+*/
+
+   if (! (pgds= (char *) malloc(sizeof (GDS_HEAD) + MAX_PROJ_SIZE))) { 
+	DPRINT1 ("%s: MALloced true Grib struct failed\n",func);
+	sprintf(errmsg,"%s: MALloced true Grib struct failed\n",func);
+	goto BYE; 
+	}
+   else memset ((void *)pgds, '\0', sizeof(GDS_HEAD) + MAX_PROJ_SIZE);
+
+/*
+*
+* A.4       ASSIGN (GDS_HEAD *pGDS_Head) to be beginning of local PGDS block 
+*           ASSIGN (void *pvGDS_Proj) to byte #7 of local PGDS block
+*/
+   pGDS_Head  = (GDS_HEAD *) pgds;
+   pvGDS_Proj = (void *) (pgds + sizeof(GDS_HEAD));
+	 
+/*
+*
+* A.5       INIT some fields of GDS_HEAD & GDS_HEAD_INPUT structs
+*/
+   pGDS_Head->chNV 	    = ( unsigned char ) 0;
+   pGDS_Head->chPV 	    = ( unsigned char ) 255;
+   pGDS_Head_Input->usNum_v = 0;    /* INPUT NOT USED AT THIS TIME */
+   pGDS_Head_Input->usPl_Pv = 255;    
+
+ 
+/*
+*
+*           !now fill true GRIB Grid Defn Sect depending on Projection type
+* A.6.a     IF (projection is Spherical) THEN
+*/
+   if ((strcmp(Geom_In.prjn_name,"spherical")==0) || 
+       (strcmp(Geom_In.prjn_name,"gaussian") == 0)){
+/*
+* A.6.a.1      FUNCTION create_inpLatlon !create internal Latlon struct 
+*                                        !using GEOM_IN & USER_INPUT
+* A.6.a.2      FUNCTION inp2grib_Latlon  !use internal Latlon struct to 
+*                                        !make true Latlon Grib Gds
+* A.6.a.3      IF (either failed) THEN
+*                  FUNCTION upd_child_errmsg   !tack funcname to errmsg
+*                  RETURN with error     !errmsg filled
+*              ENDIF
+*/
+
+     if ( create_inpLatlon(Geom_In, ppvGDS_Proj_Input,errmsg)
+          || inp2grib_Latlon (ppvGDS_Proj_Input, 
+		       (LATLON *)(pgds+sizeof(GDS_HEAD)),&lProj_sz, errmsg))
+	 { 
+	  upd_child_errmsg (func, errmsg); goto BYE; 
+	 }
+
+/*
+* A.6.a.4      STORE Gds len, DataType=0 into internal GDS struct
+*/
+     pGDS_Head_Input->uslength = sizeof(GDS_HEAD) + lProj_sz;
+     if (strcmp(Geom_In.prjn_name,"spherical")==0) {
+       pGDS_Head_Input->usData_type = LATLON_PRJ;
+       pGDS_Head->chData_type = 0;
+     } else {
+       pGDS_Head_Input->usData_type = GAUSS_PRJ;
+       pGDS_Head->chData_type = 4;
+     }
+   }
+
+/*
+* A.6.b     ELSE IF (projection is Lambert) THEN
+*/
+   else if (strcmp(Geom_In.prjn_name,"lambert")==0)
+   {
+ /*
+* A.6.b.1      FUNCTION create_inpLambert !create internal Lambert struct 
+*                                         !using GEOM_IN & USER_INPUT
+* A.6.b.2      FUNCTION inp2grib_Lambert  !use internal Lambert struct to 
+*                                         !make true Lambert Grib Gds
+* A.6.b.3      IF (either failed) THEN
+*                  FUNCTION upd_child_errmsg   !tack funcname to errmsg
+*                  RETURN with error           !errmsg filled
+*              ENDIF
+*/
+    if ( create_inpLambert(Geom_In,ppvGDS_Proj_Input,errmsg)
+        || inp2grib_Lambert( ppvGDS_Proj_Input, 
+		    (LAMBERT *)(pgds+sizeof(GDS_HEAD)), &lProj_sz, errmsg))
+	 { 
+	   upd_child_errmsg (func, errmsg); goto BYE; 
+	 }
+
+/*
+* A.6.b.4      STORE Gds len, DataType=3 into internal GDS struct
+*/
+     pGDS_Head_Input->uslength = sizeof(GDS_HEAD) + lProj_sz;
+     pGDS_Head_Input->usData_type = LAMB_PRJ; 
+     pGDS_Head->chData_type = 3;
+   }
+
+/*
+* A.6.c     ELSE if (projection is Polar_Stereo) THEN
+*/
+   else if (strcmp(Geom_In.prjn_name,"polar_stereo")==0)
+   {
+/*
+* A.6.c.1      FUNCTION create_inpPolar 
+*              !create internal Polar struct using GEOM_IN & USER_INPUT
+* A.6.c.2      FUNCTION inp2grib_PolarSt
+*              !use internal PolarSt struct to make true PolarSt Grib Gds
+* A.6.c.3      IF (either failed) THEN
+*                  FUNCTION upd_child_errmsg   !tack funcname to errmsg
+*                  RETURN with error           !errmsg filled
+*              ENDIF
+*/
+/* make True Grib PPVGDS_PROJ & SIZE using internal ppvGds_proj_input :  */
+
+     if (create_inpPolar(Geom_In, ppvGDS_Proj_Input,errmsg)
+         || inp2grib_PolarSt(ppvGDS_Proj_Input, 
+	     	(void *)(pgds+sizeof(GDS_HEAD)),&lProj_sz, errmsg) )
+	 { 
+	   upd_child_errmsg (func, errmsg); goto BYE; 
+	 }
+
+/*
+* A.6.c.4      STORE Gds len, DataType=5 into internal GDS struct
+*/
+     pGDS_Head_Input->uslength = sizeof(GDS_HEAD) + lProj_sz;
+     pGDS_Head_Input->usData_type = POLAR_PRJ; 
+     pGDS_Head->chData_type = 5;
+   }
+
+/*
+* A.6.c     ELSE if (projection is Mercator) THEN
+*/
+   else if (strcmp(Geom_In.prjn_name,"mercator")==0)
+   {
+/*
+* A.6.c.1      FUNCTION create_inpMercator
+*              !create internal Mercator struct using GEOM_IN & USER_INPUT
+* A.6.c.2      FUNCTION inp2grib_Mercator
+*              !use internal Mercator struct to make true PolarSt Grib Gds
+* A.6.c.3      IF (either failed) THEN
+*                  FUNCTION upd_child_errmsg   !tack funcname to errmsg
+*                  RETURN with error           !errmsg filled
+*              ENDIF
+*/
+/* make True Grib PPVGDS_PROJ & SIZE using internal ppvGds_proj_input :  */
+
+     if (create_inpMercator(Geom_In, ppvGDS_Proj_Input,errmsg)
+         || inp2grib_Mercator(ppvGDS_Proj_Input, 
+	     	(void *)(pgds+sizeof(GDS_HEAD)),&lProj_sz, errmsg) )
+	 { 
+	   upd_child_errmsg (func, errmsg); goto BYE; 
+	 }
+
+/*
+* A.6.c.4      STORE Gds len, DataType=5 into internal GDS struct
+*/
+     pGDS_Head_Input->uslength = sizeof(GDS_HEAD) + lProj_sz;
+     pGDS_Head_Input->usData_type = MERC_PRJ; 
+     pGDS_Head->chData_type = 1;
+   }
+
+/*
+* A.6.d     ELSE   ! Projection unknown
+*/
+   else {
+/*
+*              RETURN with error           !errmsg filled
+*/
+     DPRINT2 ("%s: Projection '%s' unknown\n",func,Geom_In.prjn_name);
+     sprintf (errmsg,"%s: Projection '%s' unknown\n",func,Geom_In.prjn_name);
+     goto BYE;
+/*
+* A.6.d     ENDIF
+*/
+   }
+
+/*
+*
+* A.7       STORE ptr to Gds and its Length in Grib hdr
+*/
+  gh->gds_ptr     = gh->entire_msg + gh->msg_length;
+  gh->gds_len     = sizeof(GDS_HEAD) + lProj_sz;
+  DPRINT3 ("Gds length= (%ld + %ld)= %ld \n", 
+  sizeof(GDS_HEAD), lProj_sz, gh->gds_len);
+
+/*
+*
+* A.8       STORE Gds length in the True Grib GDS block too
+*/
+  set_bytes(gh->gds_len, 3, pGDS_Head->achGDS_length);
+
+/*
+*
+* A.9       IF gribhdr's buffer is too small AND
+*               FUCTION Expand_gribhdr failed 
+*           THEN
+*               RETURN with error   !errmsg filled
+*           ENDIF
+*/
+  new_msgsz= gh->msg_length + gh->gds_len;
+
+      if (new_msgsz  > gh->abs_size
+        && Expand_gribhdr (gh, new_msgsz, errmsg) !=0)
+        {
+        upd_child_errmsg (func, errmsg);
+        goto BYE;
+        }
+
+/*
+*
+* A.10      UPDATE Grib Header Struct
+*           !copy true BDS block into Grib Header's Entire_Msg array;
+*           !add gds length to Message length 
+*/
+   memcpy ((void *)gh->gds_ptr, (void *)pgds, gh->gds_len);
+   gh->msg_length += gh->gds_len;
+   DPRINT1 ("copying %ld bytes from PGDS to gh->GDS_PTR \n", gh->gds_len);
+/*
+* 
+* A.11      CHANGE return Status to no errors
+*/
+   stat = 0;
+
+BYE:
+/*
+*
+* A.12      FREE up storage
+*
+* A.13      RETURN Status
+*/
+   if (pgds) free (pgds);
+   DPRINT3 ("Leaving %s, stat=%d, errmsg='%s'\n", func,stat,errmsg);
+   return stat;
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+*********************************************************************
+* B. FUNCTION:  create_inpLambert
+*       Fills Lambert Projection structure. 
+*
+*    INTERFACE:
+*       int create_inpLambert ( geom_in, ppvGDS_Proj_Input, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*     (I)  GEOM_IN geom_in            Holds info to fill local Lambert block
+*     (O)  void **ppvGDS_Proj_Input   pre-allocated block to be filled;
+*     (O)  char *errmsg               returns filled if error occurred
+*
+*     RETURN CODE
+*      0> success, ppvGDS_Proj_Input holds Lambert projection information;
+*      1> the input pre-MAlloced projection block is null;  errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int create_inpLambert (GEOM_IN geom_in, void **ppvGDS_Proj_Input, char *errmsg)
+#else
+int create_inpLambert (geom_in, ppvGDS_Proj_Input, errmsg)
+		GEOM_IN geom_in; void **ppvGDS_Proj_Input; char *errmsg;
+#endif
+{
+char *func= "create_inpLambert";
+/*
+*
+* B.1       DEFAULT status of 0
+*/
+   int            nStatus = 0;
+   double	  cut1, cut2, tmp;
+   GDS_LAM_INPUT  *pGDS_Lam_Input;
+
+   DPRINT1 ( "   Entering %s.....\n", func );
+/*
+*
+* B.2       IF (incoming projection block is Null)
+*           THEN
+*              FILL errmsg
+*              SET return status to error
+*/
+   if (!(pGDS_Lam_Input= (GDS_LAM_INPUT *) *ppvGDS_Proj_Input) )
+     {
+      DPRINT1 ( "%s: ppvGDS_Proj_Input is null\n", func);
+      sprintf(errmsg, "%s: ppvGDS_Proj_Input is null\n", func);
+      nStatus = 1;
+      }
+/*
+* B.2.b     ELSE
+*               USE info from GEOM_IN to fill the Lambert GDS struct
+*/
+   else
+   {
+   pGDS_Lam_Input->usData_type = LAMB_PRJ; /* data type flag (Tbl  ) */
+   pGDS_Lam_Input->iNx = (int) geom_in.nx; /* #pts along x-axis */
+   pGDS_Lam_Input->iNy = (int) geom_in.ny;/* #pts along y-axis */  
+  /* latitude & lon of 1st grid point */
+   pGDS_Lam_Input->lLat1 = lrint(geom_in.first_lat *1000.); 
+   pGDS_Lam_Input->lLon1 = lrint((geom_in.first_lon) *1000.); 
+   pGDS_Lam_Input->usRes_flag = geom_in.usRes_flag;/*Resolution flags Tbl7*/
+   pGDS_Lam_Input->lLon_orient=lrint(geom_in.parm_3 *1000.);/*grid orient */
+   pGDS_Lam_Input->ulDx=(unsigned long)lrint(geom_in.x_int_dis*1000.);/*Xdir gridlen*/
+   pGDS_Lam_Input->ulDy=(unsigned long)lrint(geom_in.y_int_dis*1000.);/*Ydir gridlen*/
+   if ((geom_in.y_int_dis != 0) && (geom_in.x_int_dis != 0))
+         pGDS_Lam_Input->usRes_flag = pGDS_Lam_Input->usRes_flag + 0x80;
+   if (geom_in.parm_1 > 0) 
+     pGDS_Lam_Input->usProj_flag = 0;              /* projection flag */
+   else
+     pGDS_Lam_Input->usProj_flag = 1<<7;              /* projection flag */
+   pGDS_Lam_Input->usScan_mode = geom_in.scan; /* order of grid points (Tbl8)*/
+  /*  Make sure CUT1 is closest to Pole  */
+   cut1 = geom_in.parm_1;
+   cut2 = geom_in.parm_2;
+   if (cut1 >= 0.) {
+      if (cut2 > cut1) { tmp = cut1; cut1 = cut2; cut2 = tmp; }
+      }
+   else {
+      if (cut2 < cut1) { tmp = cut1; cut1 = cut2; cut2 = tmp; }
+      }
+    
+   pGDS_Lam_Input->lLat_cut1=lrint(cut1 *1000.);/* 1stlat fr pole secant cuts*/
+   pGDS_Lam_Input->lLat_cut2=lrint(cut2 *1000.);/* 2ndlat fr pole secant cuts*/
+   pGDS_Lam_Input->lLat_southpole = -90000; /* lat of southern pole (millidegrees) */
+   pGDS_Lam_Input->lLon_southpole = 0; /* lon of souther pole (millidegrees) */
+   pGDS_Lam_Input->usZero = 0;         /* filler zeroes */
+
+/*
+*               DEBUG print
+*/
+   DPRINT3("\t%s: usData_type = %u (%s)\n",
+   func,pGDS_Lam_Input->usData_type, prjn_name[pGDS_Lam_Input->usData_type] );
+   DPRINT2("\t%s: iNx = %d\n", func,pGDS_Lam_Input->iNx );
+   DPRINT2("\t%s: iNy = %d\n", func,pGDS_Lam_Input->iNy );
+   DPRINT2("\t%s: lLat1 = %d\n", func,pGDS_Lam_Input->lLat1 );
+   DPRINT2("\t%s: lLon1 = %d\n", func,pGDS_Lam_Input->lLon1 );
+   DPRINT2("\t%s: lLon_orient = %d\n", func,pGDS_Lam_Input->lLon_orient);
+   DPRINT2("\t%s: ulDx = %u\n", func, pGDS_Lam_Input->ulDx );
+   DPRINT2("\t%s: ulDy = %u\n", func, pGDS_Lam_Input->ulDy );
+   DPRINT2("\t%s: lLat_cut1 = %d\n", func, pGDS_Lam_Input->lLat_cut1);
+   DPRINT2("\t%s: lLat_cut2 = %d\n", func, pGDS_Lam_Input->lLat_cut2);
+   DPRINT2("\t%s: usRes_flag = %u\n", func,pGDS_Lam_Input->usRes_flag);
+   DPRINT2("\t%s: usProj_flag = %u\n", func,pGDS_Lam_Input->usProj_flag);
+   DPRINT2("\t%s: usScan_mode = %u\n", func,pGDS_Lam_Input->usScan_mode);
+/*
+* B.2       ENDIF
+*/
+   }
+
+   DPRINT1("   Exiting %s.......\n" ,func);  
+/*
+*
+* B.3       RETURN status
+*/
+   return ( nStatus );
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+*********************************************************************
+* C. FUNCTION:  create_inpPolar
+*      Fills Polar Stereographic Projection structure.  
+*
+*    INTERFACE:
+*      int create_inpPolar (geom_in, ppvGDS_Proj_Input, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) GEOM_IN geom_in          holds info to fill local Polar block
+*      (O) void **ppvGDS_Proj_Input  block to filled with Polar Stereo info
+*      (O) char *errmsg              empty array filled if error occurs
+*
+*    RETURN CODE:
+*       0> success, ppvGDS_Proj_Input holds Polar projection info;
+*       1> the input pre-Malloced projection block is null; errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int create_inpPolar (GEOM_IN geom_in, void **ppvGDS_Proj_Input, char *errmsg)
+#else
+int create_inpPolar (geom_in, ppvGDS_Proj_Input, errmsg)
+		GEOM_IN geom_in; void **ppvGDS_Proj_Input; char *errmsg;
+#endif
+{
+char	*func="create_inpPolar";
+/*
+*
+* C.1       DEFAULT status of 0
+*/
+   GDS_PS_INPUT   *pGDS_PS_Input;
+   int            nStatus = 0;
+
+   DPRINT1 ("   Entering %s.....\n",func );
+/*
+*
+* C.2       IF (incoming projection block is Null)
+* C.2.a     THEN
+*              FILL errmsg
+*              CHANGE return Status to error
+*/
+   if (!(pGDS_PS_Input= (GDS_PS_INPUT *) *ppvGDS_Proj_Input) )
+     {
+      DPRINT1  ("%s: ppvGDS_Proj_Input is null\n", func);
+      sprintf(errmsg,"%s: ppvGDS_Proj_Input is null\n", func);
+      nStatus = 1;
+      }
+
+   else {
+/* 
+* C.2.b     ELSE
+* C.2.b.1      FILL elements of Polar Stereo structure 
+*/
+   pGDS_PS_Input->usData_type = POLAR_PRJ;   /* data type flag (Tbl  ) */
+   pGDS_PS_Input->usNx = (unsigned short) geom_in.nx;/* #pts along x-axis*/
+   pGDS_PS_Input->usNy = (unsigned short) geom_in.ny;/* #pts along y-axiz*/  
+   pGDS_PS_Input->lLat1 = lrint(geom_in.first_lat *1000.);/*lat of 1st gridpt*/
+   pGDS_PS_Input->lLon1 = lrint(geom_in.first_lon *1000.);/*lon of 1st gridpt*/
+   pGDS_PS_Input->usRes_flag = geom_in.usRes_flag;/* resolution flags Tbl7 */
+   pGDS_PS_Input->lLon_orient = lrint(geom_in.parm_2 *1000.);/*grid orient*/
+   pGDS_PS_Input->ulDx=(unsigned long)lrint(geom_in.x_int_dis*1000.);/*Xdir gridlen*/
+   pGDS_PS_Input->ulDy=(unsigned long)lrint(geom_in.y_int_dis*1000.);/*Ydir gridlen*/
+   if ((geom_in.y_int_dis != 0) && (geom_in.x_int_dis != 0))
+         pGDS_PS_Input->usRes_flag = pGDS_PS_Input->usRes_flag + 0x80;
+   if (geom_in.first_lat > 0) 
+     pGDS_PS_Input->usProj_flag = 0;  /* projection flag */
+   else 
+     pGDS_PS_Input->usProj_flag = 1<<7;  /* projection flag */
+
+   pGDS_PS_Input->usScan_mode = geom_in.scan; /* order of grid points (Tbl 8) */
+   pGDS_PS_Input->usZero = 0;       /* filler zeroes */
+
+/* 
+* C.2.b.2      DEBUG print
+*/
+   DPRINT3 ("\t%s: usData_type = %u (%s)\n",func,pGDS_PS_Input->usData_type,
+   prjn_name [pGDS_PS_Input->usData_type] );
+   DPRINT2("\t%s: usNx = %u\n", func,pGDS_PS_Input->usNx );
+   DPRINT2("\t%s: usNy = %u\n", func,pGDS_PS_Input->usNy );
+   DPRINT2("\t%s: lLat1 = %d\n", func,pGDS_PS_Input->lLat1 );
+   DPRINT2("\t%s: lLon1 = %d\n", func,pGDS_PS_Input->lLon1 );
+   DPRINT2("\t%s: lLon_orient = %d\n", func,pGDS_PS_Input->lLon_orient);
+   DPRINT2("\t%s: ulDx = %u\n", func,pGDS_PS_Input->ulDx);
+   DPRINT2("\t%s: ulDy = %u\n", func,pGDS_PS_Input->ulDy);
+   DPRINT2("\t%s: usRes_flag = %u\n", func,pGDS_PS_Input->usRes_flag);
+   DPRINT2("\t%s: usProj_flag = %u\n", func,pGDS_PS_Input->usProj_flag);
+   DPRINT2("\t%s: usScan_mode = %u\n", func,pGDS_PS_Input->usScan_mode);
+/*
+* C.2.b     ENDIF
+*/
+   }
+
+   DPRINT1("   Exiting %s.......\n" ,func);  
+/*
+*
+* C.3       RETURN status
+*/
+   return ( nStatus );
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+
+/*
+*
+*********************************************************************
+* D. FUNCTION:  create_inpLatlon
+*       Fills Latitude Longitude Projection structure.  
+*
+*    INTERFACE:
+*       int create_inpLatlon ( geom_in, ppvGDS_Proj_Input, errmsg) 
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) GEOM_IN geom_in           holds geom info to fill local Lat/Lon block
+*      (O) void **ppvGDS_Proj_Input  to be filled with LatLon projection info
+*      (O) char *errmsg              empty array, filled if error occurred
+*
+*     OUTPUT:
+*       0> success, ppGDS_Proj_Input filled with Lat/Lon projection info
+*       1> pre-Malloced Projection block is null;  errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int create_inpLatlon (GEOM_IN geom_in, void **ppvGDS_Proj_Input, char *errmsg)
+#else
+int create_inpLatlon (geom_in, ppvGDS_Proj_Input, errmsg)
+		GEOM_IN geom_in; void **ppvGDS_Proj_Input; char *errmsg;
+#endif
+{
+char *func= "Create_InpLatLon";
+/*
+*
+* D.0       DEFAULT to return status of 0
+*/
+   GDS_LATLON_INPUT  *pGDS_Latlon_Input;
+   int            nStatus = 0;
+
+   DPRINT1 ("  Entering %s......\n" ,func);
+/*
+*
+* D.2       IF (incoming projection block is Null)
+*           THEN
+*              FILL errmsg
+*              CHANGE stat to 1
+*/
+   if (!(pGDS_Latlon_Input= (GDS_LATLON_INPUT *) *ppvGDS_Proj_Input) )
+     {
+      DPRINT1 (" %s: ppvGDS_Proj_Input is null\n", func);
+      sprintf(errmsg," %s: ppvGDS_Proj_Input is null\n", func);
+      nStatus = 1; 
+	} 
+/* 
+* D.2.b     ELSE 
+* D.2.b.1      FILL elements of the Lat/Lon GDS block 
+*/
+   else
+   {
+   
+   pGDS_Latlon_Input->usData_type = LATLON_PRJ;  /* data type flag (Tbl  )*/
+   pGDS_Latlon_Input->usNi=(unsigned short)geom_in.nx;/*#pts along x-axis 109*/
+   pGDS_Latlon_Input->usNj=(unsigned short)geom_in.ny;/* #pts along y-axiz 82*/
+   pGDS_Latlon_Input->lLat1=lrint(geom_in.first_lat*1000.);/*lat of 1stgridpt*/
+   pGDS_Latlon_Input->lLon1=lrint(geom_in.first_lon*1000.);/*lon of 1stgridpt*/
+   pGDS_Latlon_Input->usRes_flag=geom_in.usRes_flag;/*resolution flags Tbl7*/
+   pGDS_Latlon_Input->lLat2 =lrint(geom_in.last_lat*1000.);/*lat of 2ndgridpt*/
+   pGDS_Latlon_Input->lLon2 =lrint(geom_in.last_lon*1000.);/*lon of 2ndgridpt*/
+   pGDS_Latlon_Input->iDi = lrint(geom_in.parm_2 *1000.);/* i-dir incr*/
+   pGDS_Latlon_Input->iDj = lrint(geom_in.parm_1 *1000.);/* j-dir incr*/
+   if ((geom_in.parm_1 != 0) && (geom_in.parm_2 != 0))
+         pGDS_Latlon_Input->usRes_flag = pGDS_Latlon_Input->usRes_flag + 0x80;
+   pGDS_Latlon_Input->usScan_mode = geom_in.scan; /* order ofgridpts (Tbl 8)*/
+   pGDS_Latlon_Input->usZero = 0;  /* filler zeroes*/
+   pGDS_Latlon_Input->lLat_southpole= -90000;/* lat of southern pole (millidegrees)*/
+   pGDS_Latlon_Input->lLon_southpole= 0;/* lon of southern pole (millidegrees)*/
+   pGDS_Latlon_Input->lRotate = 0;/* angle of rotation*/
+   pGDS_Latlon_Input->lPole_lat = 0;/* lat of pole of stretching (mdeg)*/
+   pGDS_Latlon_Input->lPole_lon = 0; /* lon of pole of stretching*/
+   pGDS_Latlon_Input->lStretch = 0;/* stretching factor*/
+
+/*
+* D.2.b.2      DEBUG print
+*/
+   DPRINT3("\t%s: usData_type = %u (%s)\n", func,pGDS_Latlon_Input->usData_type,
+	prjn_name[pGDS_Latlon_Input->usData_type] );
+   DPRINT2("\t%s: usNi = %u\n",func,pGDS_Latlon_Input->usNi );
+   DPRINT2("\t%s: usNj = %u\n",func,pGDS_Latlon_Input->usNj );
+   DPRINT2("\t%s: lLat1 = %d\n",func,pGDS_Latlon_Input->lLat1 );
+   DPRINT2("\t%s: lLon1 = %d\n",func,pGDS_Latlon_Input->lLon1 );
+   DPRINT2("\t%s: lLat2 = %d\n",func,pGDS_Latlon_Input->lLat2 );
+   DPRINT2("\t%s: lLon2 = %d\n",func,pGDS_Latlon_Input->lLon2 );
+   DPRINT2("\t%s: iDi = %u\n",func,pGDS_Latlon_Input->iDi );
+   DPRINT2("\t%s: iDj = %u\n",func,pGDS_Latlon_Input->iDj );
+   DPRINT2("\t%s: usRes_flag = %u\n",func,pGDS_Latlon_Input->usRes_flag );
+   DPRINT2("\t%s: usScan_mode = %u\n",func,pGDS_Latlon_Input->usScan_mode );
+   DPRINT2("\t%s: lLat_southpole = %ld\n",func,pGDS_Latlon_Input->lLat_southpole);
+   DPRINT2("\t%s: lLon_southpole = %ld\n",func,pGDS_Latlon_Input->lLon_southpole);
+   DPRINT2("\t%s: lRotate = %ld\n",func,pGDS_Latlon_Input->lRotate );
+   DPRINT2("\t%s: lPole_lat = %ld\n",func,pGDS_Latlon_Input->lPole_lat );
+   DPRINT2("\t%s: lPole_lon = %ld\n",func,pGDS_Latlon_Input->lPole_lon );
+   DPRINT2("\t%s: lStretch = %ld\n",func,pGDS_Latlon_Input->lStretch );
+/*
+* D.2.b    ENDIF
+*/
+   }
+/*
+*
+* D.3      RET2URN status
+*/
+   DPRINT1("   Exiting %s.......\n" ,func);  
+   return ( nStatus );
+/*
+* END OF FUNCTION
+*
+*/ 
+}
+
+/*
+*
+*********************************************************************
+* FUNCTION:  create_inpMercator
+*      Fills Mercator Projection structure.  
+*
+*    INTERFACE:
+*      int create_inpMercator (geom_in, ppvGDS_Proj_Input, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) GEOM_IN geom_in          holds info to fill local Mercator block
+*      (O) void **ppvGDS_Proj_Input  block to filled with Mercator info
+*      (O) char *errmsg              empty array filled if error occurs
+*
+*    RETURN CODE:
+*       0> success, ppvGDS_Proj_Input holds Mercator projection info;
+*       1> the input pre-Malloced projection block is null; errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int create_inpMercator (GEOM_IN geom_in, void **ppvGDS_Proj_Input, char *errmsg)
+#else
+int create_inpMercator (geom_in, ppvGDS_Proj_Input, errmsg)
+		GEOM_IN geom_in; void **ppvGDS_Proj_Input; char *errmsg;
+#endif
+{
+char	*func="create_inpMercator";
+/*
+*
+* C.1       DEFAULT status of 0
+*/
+   mercator       *pGDS_mercator_Input;
+   int            nStatus = 0;
+
+   DPRINT1 ("   Entering %s.....\n",func );
+/*
+*
+* C.2       IF (incoming projection block is Null)
+* C.2.a     THEN
+*              FILL errmsg
+*              CHANGE return Status to error
+*/
+   if (!(pGDS_mercator_Input= (mercator *) *ppvGDS_Proj_Input) )
+     {
+      DPRINT1  ("%s: ppvGDS_Proj_Input is null\n", func);
+      sprintf(errmsg,"%s: ppvGDS_Proj_Input is null\n", func);
+      nStatus = 1;
+      }
+
+   else {
+/* 
+* C.2.b     ELSE
+* C.2.b.1      FILL elements of Polar Stereo structure 
+*/
+   pGDS_mercator_Input->usData_type = MERC_PRJ;   /* data type flag (Tbl  ) */
+   pGDS_mercator_Input->cols = (unsigned short) geom_in.nx;/* #pts along x-axis*/
+   pGDS_mercator_Input->rows = (unsigned short) geom_in.ny;/* #pts along y-axiz*/  
+   pGDS_mercator_Input->first_lat = lrint(geom_in.first_lat *1000.);/*lat of 1st gridpt*/
+   pGDS_mercator_Input->first_lon = lrint(geom_in.first_lon *1000.);/*lon of 1st gridpt*/
+   pGDS_mercator_Input->usRes_flag = geom_in.usRes_flag;/* resolution flags Tbl7 */
+   pGDS_mercator_Input->La2 = lrint(geom_in.last_lat *1000.);/*lat of last gridpt*/
+   pGDS_mercator_Input->Lo2 = lrint(geom_in.last_lon *1000.);/*lon of last gridpt*/
+   pGDS_mercator_Input->latin = lrint(geom_in.parm_1 *1000.);/*reference latitude*/
+   pGDS_mercator_Input->usZero1 = 0; /* filler zeroes */
+   pGDS_mercator_Input->usScan_mode = geom_in.scan; /* order of grid points (Tbl 8) */
+   pGDS_mercator_Input->lon_inc = lrint(geom_in.parm_2 *1000.);/*longitude increment*/
+   pGDS_mercator_Input->lat_inc = lrint(geom_in.parm_3 *1000.);/*latitude increment*/
+   pGDS_mercator_Input->usZero = 0;  /* filler zeroes */
+
+/* 
+* C.2.b.2      DEBUG print
+*/
+   DPRINT3 ("\t%s: usData_type = %u (%s)\n",func,pGDS_mercator_Input->usData_type,
+   prjn_name [pGDS_mercator_Input->usData_type] );
+   DPRINT2("\t%s: cols = %u\n", func,pGDS_mercator_Input->cols );
+   DPRINT2("\t%s: rows = %u\n", func,pGDS_mercator_Input->rows );
+   DPRINT2("\t%s: first_lat = %d\n", func,pGDS_mercator_Input->first_lat );
+   DPRINT2("\t%s: first_lon = %d\n", func,pGDS_mercator_Input->first_lon );
+   DPRINT2("\t%s: usRes_flag = %d\n", func,pGDS_mercator_Input->usRes_flag);
+   DPRINT2("\t%s: La2 = %d\n", func,pGDS_mercator_Input->La2);
+   DPRINT2("\t%s: Lo2 = %d\n", func,pGDS_mercator_Input->Lo2);
+   DPRINT2("\t%s: latin = %d\n", func,pGDS_mercator_Input->latin);
+   DPRINT2("\t%s: usZero1 = %d\n", func,pGDS_mercator_Input->usZero1);
+   DPRINT2("\t%s: usScan_mode = %d\n", func,pGDS_mercator_Input->usScan_mode);
+   DPRINT2("\t%s: lon_inc = %f\n", func,pGDS_mercator_Input->lon_inc);
+   DPRINT2("\t%s: lat_inc = %f\n", func,pGDS_mercator_Input->lat_inc);
+/*
+* C.2.b     ENDIF
+*/
+   }
+
+   DPRINT1("   Exiting %s.......\n" ,func);  
+/*
+*
+* C.3       RETURN status
+*/
+   return ( nStatus );
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+
+
+
+
+
+
+
+/*
+*
+****************************************************************************
+* E. FUNCTION:  inp2gribLambert
+*      This routine fills the special Lambert Projection structure for
+*      the GDS.
+*
+*    INTERFACE:
+*       int inp2grib_Lambert (ppvGDS_Proj_Input, pLambert, lProj_size, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) void  **ppvGDS_Proj_Input; 
+*          pointer to struct holds Input Projection data 
+*      (O) LAMBERT *pLambert;
+*          block to be filled with Lambert Projection information
+*      (O) long  *lProj_size;
+*          to be filled with size of LAMBERT struct;
+*      (O) char *errmsg;
+*          empty array, filled if error occurred;
+*
+*    RETURN CODE:
+*      0> success,  pLambert and lProj_size filled;
+*      1> got null pointers; errmsg filled;
+****************************************************************************/
+
+#if PROTOTYPE_NEEDED
+int   inp2grib_Lambert (void **ppvGDS_Proj_Input, LAMBERT  *pLambert,
+			long *lProj_size, char *errmsg)
+#else
+int   inp2grib_Lambert (ppvGDS_Proj_Input, pLambert, lProj_size, errmsg)
+			void **ppvGDS_Proj_Input; LAMBERT  *pLambert;
+			long *lProj_size; char *errmsg;
+#endif
+{
+/*
+* E.1       INIT status to success
+*
+* E.2       DEBUG printing
+*/
+   GDS_LAM_INPUT     *vProjInp = 0;
+   long              lTemp = 0;
+   int               nStatus = 0;
+   char		     *func= "inp2grib_Lambert";
+   long              tmp_byte4;
+   DPRINT1 ("   Entering %s.....\n",func);
+
+/*
+* 
+* E.3       MAKE local ptr vProjInp point to Input Projection data block arg
+*/
+   vProjInp = ( GDS_LAM_INPUT * ) *ppvGDS_Proj_Input;    /* read fr this */
+
+/*
+* 
+* E.4       IF (either of the user's struct pointers are NUL) THEN
+*              SET status = 1
+*              RETURN
+*           ENDIF
+*/
+   if (!vProjInp || !pLambert)   {
+	DPRINT1 ("%s: the VOID *ppvGDS_Proj_Input block is null\n",func);
+	sprintf(errmsg, "%s: the VOID *ppvGDS_Proj_Input block is null\n",func);
+	nStatus=  1; 
+	goto BYE; 
+	}
+
+/*
+* E.5       FILL local block type LAMBERT
+*/
+  
+      set_bytes(vProjInp->iNx, 2, pLambert->achNx);
+      
+      set_bytes(vProjInp->iNy, 2, pLambert->achNy);
+
+/* convert lLat1 to 3chars */
+      set_bytes(vProjInp->lLat1, 3, pLambert->achLat1);
+
+/* convert lLon1 to 3chars */
+      set_bytes(vProjInp->lLon1, 3, pLambert->achLon1);
+
+      pLambert->chRes_flag = ( unsigned char ) vProjInp->usRes_flag;
+
+/* convert lLon_orient to 3 bytes */
+      set_bytes(vProjInp->lLon_orient, 3, pLambert->achLon_orient);
+
+/* convert ulDx to 3 bytes */
+      set_bytes(vProjInp->ulDx, 3, pLambert->achDx);
+   
+/* convert ulDy to 3 bytes */
+      set_bytes(vProjInp->ulDy, 3, pLambert->achDy);
+
+      pLambert->chProj_flag = ( unsigned char ) vProjInp->usProj_flag;
+      pLambert->chScan_mode = ( unsigned char ) vProjInp->usScan_mode;
+
+/* convert lLat_cut1 to 3 chars */
+      set_bytes(vProjInp->lLat_cut1, 3, pLambert->achLat_cut1);
+
+/* convert lLat_cut2 to 3 chars */
+      set_bytes(vProjInp->lLat_cut2, 3, pLambert->achLat_cut2);
+
+/* convert lLat_southpole to 3chars */
+      set_bytes(vProjInp->lLat_southpole, 3, pLambert->achLat_southpole);
+
+/* convert lLon_southpole to 3 chars */
+      set_bytes(vProjInp->lLon_southpole, 3, pLambert->achLon_southpole);
+
+      set_bytes(vProjInp->usZero, 2, pLambert->achZero);
+
+/*
+*
+* E.6       DEBUG print Grib LAMBERT block
+*/
+  DPRINT3("\t%s: achNx [%02d,%02d]\n", func,
+  pLambert->achNx[0],pLambert->achNx[1]);
+  DPRINT3("\t%s: achNy [%02d,%02d]\n", func, 
+  pLambert->achNy[0],pLambert->achNy[1]);
+  DPRINT4("\t%s: achLat1 [%02d,%02d,%02d]\n", func, 
+  pLambert->achLat1[0], pLambert->achLat1[1], pLambert->achLat1[2]);
+  DPRINT4("\t%s: achLon1 [%02d,%02d,%02d]\n", func,
+  pLambert->achLon1[0], pLambert->achLon1[1], pLambert->achLon1[2]);
+  DPRINT2("\t%s: chRes_flag [%02d]\n", func, pLambert->chRes_flag);
+  DPRINT4("\t%s: achLon_orient [%02d,%02d,%02d]\n", func, 
+  pLambert->achLon_orient[0], pLambert->achLon_orient[1], 
+  pLambert->achLon_orient[2]);
+  DPRINT4("\t%s: achDx [%02d,%02d,%02d]\n", func,
+  pLambert->achDx[0], pLambert->achDx[1], pLambert->achDx[2]);
+  DPRINT4("\t%s: achDy [%02d,%02d,%02d]\n", func, 
+  pLambert->achDy[0], pLambert->achDy[1], pLambert->achDy[2]);
+  DPRINT2("\t%s: chProj_flag [%02d]\n", func, pLambert->chProj_flag);
+  DPRINT2("\t%s: chScan_mode [%02d]\n", func, pLambert->chScan_mode);
+  DPRINT4("\t%s: achLat_cut1 [%02d,%02d,%02d]\n", func, 
+  pLambert->achLat_cut1[0], 
+  pLambert->achLat_cut1[1], pLambert->achLat_cut1[2]);
+  DPRINT4("\t%s: achLat_cut2 [%02d,%02d,%02d]\n", func, 
+  pLambert->achLat_cut2[0], 
+  pLambert->achLat_cut2[1], pLambert->achLat_cut2[2]);
+  DPRINT4("\t%s: achLat_southpole [%02d,%02d,%02d]\n",func,
+  pLambert->achLat_southpole[0], 
+  pLambert->achLat_southpole[1], pLambert->achLat_southpole[2] );
+  DPRINT4("\t%s: achLon_southpole [%02d,%02d,%02d]\n",func,
+  pLambert->achLon_southpole[0], 
+  pLambert->achLon_southpole[1], pLambert->achLon_southpole[2] );
+  DPRINT3("\t%s: achZero [%02d,%02d]\n", func, 
+  pLambert->achZero[0], pLambert->achZero[1]);
+/*******/
+
+/*
+*
+* E.7       STORE proj size of LAMBERT struct in  lProj_size 
+*/
+      
+      *lProj_size = sizeof (LAMBERT);
+
+BYE:
+      DPRINT3 ("   Exiting %s (lProj_size=%ld), stat=%d\n", func,
+      *lProj_size, nStatus);
+/*
+*
+* E.9       RETURN status
+*/
+   return ( nStatus );
+/* 
+* 
+* END OF FUNCTION
+*/ 
+}
+
+/*
+*
+****************************************************************************
+* F. FUNCTION:  inp2grib_PolarSt
+*      This routine fills the special Polar Stereo Projection structure for
+*      the GDS.
+*
+*    INTERFACE:
+*       int inp2grib_PolarSt ( ppvGDS_Proj_Input, Polar, lProj_size ,errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) void **ppvGDS_Proj_Input;  
+*          holds input projection data
+*      (O) POLAR *Polar;		
+*          to be filled with Polar Stereographic projection info
+*      (O) long *lProj_size;        
+*          to be filled with size of structure POLAR 
+*      (O) char *errmsg              
+*          empty array, filled if error occurred
+*
+*   RETURN CODE:
+*      0> success, Polar and lProj_size filled;
+*      1> pointers are null, errmsg filled;
+****************************************************************************/
+
+#if PROTOTYPE_NEEDED
+int   inp2grib_PolarSt  (void **ppvGDS_Proj_Input, POLAR *Polar, 
+			long *lProj_size , char *errmsg)
+#else
+int   inp2grib_PolarSt  (ppvGDS_Proj_Input, Polar, lProj_size , errmsg)
+			void **ppvGDS_Proj_Input; POLAR *Polar; 
+			long *lProj_size ; char *errmsg;
+#endif
+{
+/*
+* 
+* F.1       INIT variables !default stat=good
+*/
+   GDS_PS_INPUT      *pProjInp = 0;
+   int               lTemp = 0;
+   int               nStatus = 0;
+   char		     *func="inp2grib_PolarSt";
+
+   DPRINT1 ("\t Entering %s.....\n", func);
+/*
+*
+* F.2       POINT local pProjInp to incoming ppvGDS_Proj_Input
+*/
+   pProjInp = ( GDS_PS_INPUT *) *ppvGDS_Proj_Input;
+
+/*
+*
+* F.3       IF (true grib Polar proj block OR input Polar block is null) THEN
+*               SET Status=  1 
+*               RETURN;
+*           ENDIF
+*/
+    if (!Polar || !pProjInp ) 
+	{
+        DPRINT1 ( "%s:  Polar or pProjInp is null\n", func);
+        sprintf(errmsg,"%s:  Polar or pProjInp is null\n", func);
+	nStatus=  1; goto BYE; 
+	}
+
+/*
+*
+* F.4        FILL local struct from pProjInp
+*/
+/* convert usNx to 2 chars */
+      set_bytes(pProjInp->usNx, 2, Polar->achNx);
+   
+/* convert usNy to 2 chars */
+      set_bytes(pProjInp->usNy, 2, Polar->achNy);
+
+/* convert lLat1 to 3 chars */
+      set_bytes(pProjInp->lLat1, 3, Polar->achLat1);
+
+/* convert lLon1 to 3 chars */
+      set_bytes(pProjInp->lLon1, 3, Polar->achLon1);
+
+      Polar->chRes_flag = ( unsigned char ) pProjInp->usRes_flag;
+
+/* convert lLon_orient to 3 chars */
+      set_bytes(pProjInp->lLon_orient, 3, Polar->achLon_orient);
+
+/* convert ulDx to 3 char */
+      set_bytes(pProjInp->ulDx, 3, Polar->achDx);
+   
+/* convert ulDy to 3chars */
+      set_bytes(pProjInp->ulDy, 3, Polar->achDy);
+
+      Polar->chProj_flag = ( unsigned char ) pProjInp->usProj_flag;
+      Polar->chScan_mode = ( unsigned char ) pProjInp->usScan_mode;
+
+/* 4 bytes of zero */
+      memset((void*) Polar->achZero, '\0', 4);
+
+/* 
+*
+* F.5       DEBUG print GRIB Projection block
+*/
+  DPRINT3("\t%s: achNx [%02d,%02d]\n",func, Polar->achNx[0],Polar->achNx[1]);
+  DPRINT3("\t%s: achNy [%02d,%02d]\n",func, Polar->achNy[0],Polar->achNy[1]);
+  DPRINT4("\t%s: achLat1 [%02d,%02d,%02d]\n",func, Polar->achLat1[0],
+  Polar->achLat1[1], Polar->achLat1[2]);
+  DPRINT4("\t%s: achLon1 [%02d,%02d,%02d]\n",func, Polar->achLon1[0],
+   Polar->achLon1[1] , Polar->achLon1[2]);
+  DPRINT2("\t%s: chRes_flag [%02d]\n",func, Polar->chRes_flag);
+  DPRINT4("\t%s: achLon_orient [%02d,%02d,%02d]\n",func, 
+  Polar->achLon_orient[0], Polar->achLon_orient[1], Polar->achLon_orient[2]);
+  DPRINT4("\t%s: achDx [%02d,%02d,%02d]\n",func, Polar->achDx[0],
+  Polar->achDx[1], Polar->achDx[2]);
+  DPRINT4("\t%s: achDy [%02d,%02d,%02d]\n",func, Polar->achDy[0],
+  Polar->achDy[1], Polar->achDy[2]);
+  DPRINT2("\t%s: chProj_flag [%02d]\n",func, Polar->chProj_flag);
+  DPRINT2("\t%s: chScan_mode [%02d]\n",func, Polar->chScan_mode);
+  DPRINT5("\t%s: achZero [%02d,%02d,%02d,%02d]\n",func, Polar->achZero[0],
+  Polar->achZero[1],  Polar->achZero[2],  Polar->achZero[3]);
+/*******/
+
+/*
+*
+* F.7        STORE size of POLAR struct in lProj_size
+*/
+      *lProj_size = sizeof (POLAR);
+
+BYE:
+   DPRINT3 ("   Exiting %s (lProj_size=%ld), stat=%d\n", func,
+      *lProj_size, nStatus);
+/*
+*
+* F.8       RETURN Stat  ! 0 or  1
+*/
+   return ( nStatus );
+/* 
+* 
+* END OF FUNCTION
+*
+*
+*/ 
+}
+
+/*
+*
+****************************************************************************
+* G. FUNCTION:  inp2grib_Latlon
+*      This routine fills the Latitude Longitude Projection structure for
+*      the GDS.
+*
+*    INTERFACE:
+*       int inp2grib_Latlon ( ppvGDS_Proj_Input, pLatlon, lProj_size ,errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) void **ppvGDS_Proj_Input;  
+*          holds input projection data
+*      (O) LATLON *pLatlon;
+*          to be filled with Lat/Lon projection info
+*      (O) long *lProj_size;        
+*          to be filled with size of structure LATLON
+*      (O) char *errmsg;
+*          empty array, filled if error occurred
+*
+*    RETURN CODE:
+*      0>  success, pLatlon and lProj_size filled;
+*      1>  got null pointers, errmsg filled;
+****************************************************************************/
+#if PROTOTYPE_NEEDED
+int    inp2grib_Latlon  (void **ppvGDS_Proj_Input, LATLON *pLatlon,
+			long *lProj_size, char *errmsg)
+#else
+int    inp2grib_Latlon  (ppvGDS_Proj_Input, pLatlon, lProj_size, errmsg)
+			void **ppvGDS_Proj_Input; LATLON *pLatlon;
+			long *lProj_size; char *errmsg;
+#endif
+{
+   GDS_LATLON_INPUT  *Inp = 0;
+   int               lTemp = 0;
+   char 	*func= "inp2grib_Latlon";
+/*
+*
+* G.1       INIT status to success
+*/
+   int               nStatus = 0;
+   DPRINT1 ( "   Entering %s.....\n", func );
+/*
+*
+* G.2        ASSIGN arguments to local pointers
+*/
+  Inp  = (GDS_LATLON_INPUT *) *ppvGDS_Proj_Input;
+/*
+   DPRINT3("\n%s: usData_type = %u (%s)\n", func, Inp->usData_type,
+   prjn_name[Inp->usData_type] );
+   DPRINT2("\t%s: usNi = %u\n",func, Inp->usNi );
+   DPRINT2("\t%s: usNj = %u\n",func, Inp->usNj );
+   DPRINT2("\t%s: lLat1 = %d\n",func, Inp->lLat1 );
+   DPRINT2("\t%s: lLon1 = %d\n",func, Inp->lLon1 );
+   DPRINT2("\t%s: lLat2 = %d\n",func, Inp->lLat2 );
+   DPRINT2("\t%s: lLon2 = %d\n",func, Inp->lLon2 );
+   DPRINT2("\t%s: iDi = %u\n",func, Inp->iDi );
+   DPRINT2("\t%s: iDj = %u\n",func, Inp->iDj );
+   DPRINT2("\t%s: usRes_flag = %u\n",func, Inp->usRes_flag );
+   DPRINT2("\t%s: usScan_mode = %u\n",func, Inp->usScan_mode );
+   DPRINT2("\t%s: lLat_southpole = %ld\n",func, Inp->lLat_southpole);
+   DPRINT2("\t%s: lLon_southpole = %ld\n",func, Inp->lLon_southpole);
+   DPRINT2("\t%s: lRotate = %ld\n",func, Inp->lRotate );
+   DPRINT2("\t%s: lPole_lat = %ld\n",func, Inp->lPole_lat );
+   DPRINT2("\t%s: lPole_lon = %ld\n",func, Inp->lPole_lon );
+   DPRINT2("\t%s: lStretch = %ld\n",func, Inp->lStretch );
+*/
+
+/*
+*
+* G.3        IF (pointers passed in are null) THEN
+*                SET status to  1
+*                RETURN
+*            ENDIF
+*/
+  if ( !Inp || !pLatlon) { 
+	   DPRINT1 ("%s:  lLatlon_inp || pLatlon is null\n",func);
+	   sprintf(errmsg, "%s:  lLatlon_inp || pLatlon is null\n", func);
+	   nStatus =  1; 
+	   goto BYE; 
+	 }
+
+/*
+*
+* G.4       FILL local struct from Inp
+*/
+/* convert usNi & usNj to 2 chars */
+      set_bytes(Inp->usNi, 2, pLatlon->achNi);
+
+      set_bytes(Inp->usNj, 2, pLatlon->achNj);
+   
+/* convert lLat1 to 3chars */
+      set_bytes(Inp->lLat1, 3, pLatlon->achLat1);
+
+/* convert lLon1 to 3chars */
+      set_bytes(Inp->lLon1, 3, pLatlon->achLon1);
+
+      pLatlon->chRes_flag = ( unsigned char ) Inp->usRes_flag;
+
+/* convert lLat2 to 3chars */
+      set_bytes(Inp->lLat2, 3, pLatlon->achLat2);
+
+/* convert lLon2 to 3chars */
+      set_bytes(Inp->lLon2, 3, pLatlon->achLon2);
+
+/* convert lon increment to 2chars */
+      set_bytes(Inp->iDi, 2, pLatlon->achDi);
+
+/* convert lat increment to 2chars */
+      set_bytes(Inp->iDj, 2, pLatlon->achDj);
+
+/* 1 byte scan mode */
+      pLatlon->chScan_mode = ( unsigned char ) Inp->usScan_mode;
+
+/* 4 bytes of reserved zero */
+      memset ((void*)pLatlon->achZero, '\0', 4);
+
+/* convert lLat_southpole to 3chars */
+      set_bytes(Inp->lLat_southpole, 3, pLatlon->achLat_southpole);
+
+/* convert lLon_southpole to 3chars */
+      set_bytes(Inp->lLon_southpole, 3, pLatlon->achLon_southpole);
+
+/* convert lRotate to 4chars */
+      set_bytes(Inp->lRotate, 4, pLatlon->achRotate);
+
+/* convert lPole_lat to 3chars */
+      set_bytes(Inp->lPole_lat, 3, pLatlon->achPole_lat);
+
+/* convert lPole_lon to 3chars */
+      set_bytes(Inp->lPole_lon, 3, pLatlon->achPole_lon);
+
+/* convert lStretch to 4 chars */
+      set_bytes(Inp->lStretch, 4, pLatlon->achStretch);
+
+/*
+*
+* G.5       DEBUG print Input Proj Block & their equivalence in the Char array;
+*/
+  DPRINT3("\t%s: achNi [%02d,%02d]\n",func,pLatlon->achNi[0],pLatlon->achNi[1]);
+  DPRINT3("\t%s: achNj [%02d,%02d]\n",func,pLatlon->achNj[0],pLatlon->achNj[1]);
+  DPRINT4("\t%s: achLat1 [%02d,%02d,%02d]\n", 
+	func, pLatlon->achLat1[0],pLatlon->achLat1[1],pLatlon->achLat1[2]);
+  DPRINT4("\t%s: achLon1 [%02d,%02d,%02d]\n", func, 
+	pLatlon->achLon1[0],pLatlon->achLon1[1],pLatlon->achLon1[2]);
+  DPRINT2("\t%s: chRes_flag [%02d]\n", func, pLatlon->chRes_flag	);
+  DPRINT4("\t%s: achLat2 [%02d,%02d,%02d]\n", 
+	func, pLatlon->achLat2[0], pLatlon->achLat2[1], pLatlon->achLat2[2]);
+  DPRINT4("\t%s: achLon2 [%02d,%02d,%02d]\n", 
+	func, pLatlon->achLon2[0], pLatlon->achLon2[1], pLatlon->achLon2[2]);
+  DPRINT3("\t%s: achDi [%02d,%02d]\n",func,pLatlon->achDi[0],pLatlon->achDi[1]);
+  DPRINT3("\t%s: achDj [%02d,%02d]\n",func,pLatlon->achDj[0],pLatlon->achDj[1]);
+  DPRINT2("\t%s: chScan_mode [%02d]\n", func, pLatlon->chScan_mode);
+  DPRINT5("\t%s: achZero [%02d,%02d,%02d,%02d]\n", 
+	func, pLatlon->achZero[0],pLatlon->achZero[1],pLatlon->achZero[2],
+	pLatlon->achZero[3]);
+  DPRINT4("\t%s achLat_southpole [%02d,%02d,%02d]\n",
+        func, pLatlon->achLat_southpole[0],pLatlon->achLat_southpole[1],
+        pLatlon->achLat_southpole[2]);
+  DPRINT4("\t%s achLon_southpole [%02d,%02d,%02d]\n",
+        func, pLatlon->achLon_southpole[0],pLatlon->achLon_southpole[1],
+        pLatlon->achLon_southpole[2]);
+  DPRINT5("\t%s achRotate [%02d,%02d,%02d,%02d]\n",
+        func, pLatlon->achRotate[0],pLatlon->achRotate[1],
+        pLatlon->achRotate[2], pLatlon->achRotate[3]);
+  DPRINT4("\t%s achPole_lat [%02d,%02d,%02d]\n",
+        func, pLatlon->achPole_lat[0],pLatlon->achPole_lat[1],
+        pLatlon->achPole_lat[2]);
+  DPRINT4("\t%s achPole_lon [%02d,%02d,%02d]\n",
+        func, pLatlon->achPole_lon[0],pLatlon->achPole_lon[1],
+        pLatlon->achPole_lon[2]);
+  DPRINT5("\t%s achStretch [%02d,%02d,%02d,%02d]\n",
+    	func, pLatlon->achStretch[0],pLatlon->achStretch[1],
+	pLatlon->achStretch[2], pLatlon->achStretch[3]);
+/*******/
+/*
+*
+* G.6       STORE size of LATLON struct in lProj_size
+*/
+      *lProj_size = sizeof (LATLON);
+
+
+BYE:
+   DPRINT3 ("   Exiting %s (lProj_size=%ld), stat=%d\n", func,
+      *lProj_size, nStatus);
+/*
+*
+* G.7       RETURN stat 
+*/
+   return ( nStatus );
+/* 
+* 
+* END OF FUNCTION
+*
+*
+*/ 
+}
+/*
+*
+****************************************************************************
+* F. FUNCTION:  inp2grib_Mercator
+*      This routine fills the special Mercator Projection structure for
+*      the GDS.
+*
+*    INTERFACE:
+*       int inp2grib_Mercator ( ppvGDS_Proj_Input, Polar, lProj_size ,errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) void **ppvGDS_Proj_Input;  
+*          holds input projection data
+*      (O) MERCATOR *Mercator;		
+*          to be filled with Polar Stereographic projection info
+*      (O) long *lProj_size;        
+*          to be filled with size of structure POLAR 
+*      (O) char *errmsg              
+*          empty array, filled if error occurred
+*
+*   RETURN CODE:
+*      0> success, Mercator and lProj_size filled;
+*      1> pointers are null, errmsg filled;
+****************************************************************************/
+
+#if PROTOTYPE_NEEDED
+int   inp2grib_Mercator (void **ppvGDS_Proj_Input, MERCATOR *Mercator, 
+			long *lProj_size , char *errmsg)
+#else
+int   inp2grib_Mercator (ppvGDS_Proj_Input, Mercator, lProj_size , errmsg)
+			void **ppvGDS_Proj_Input; MERCATOR *Mercator; 
+			long *lProj_size ; char *errmsg;
+#endif
+{
+/*
+* 
+* F.1       INIT variables !default stat=good
+*/
+   mercator          *ProjInp = 0;
+   int               lTemp = 0;
+   int               nStatus = 0;
+   char		     *func="inp2grib_PolarSt";
+
+   DPRINT1 ("\t Entering %s.....\n", func);
+/*
+*
+* F.2       POINT local pProjInp to incoming ppvGDS_Proj_Input
+*/
+   ProjInp = ( mercator *) *ppvGDS_Proj_Input;
+
+/*
+*
+* F.3       IF (true grib Mercator proj block OR input Polar block is null) THEN
+*               SET Status=  1 
+*               RETURN;
+*           ENDIF
+*/
+    if (!Mercator || !ProjInp ) 
+	{
+        DPRINT1 ( "%s:  Mercator or ProjInp is null\n", func);
+        sprintf(errmsg,"%s: Mercator or ProjInp is null\n", func);
+	nStatus=  1; goto BYE; 
+	}
+
+/*
+*
+* F.4        FILL local struct from pProjInp
+*/
+/* convert cols to 2 chars */
+      set_bytes(ProjInp->cols, 2, Mercator->achNi);
+   
+/* convert rows to 2 chars */
+      set_bytes(ProjInp->rows, 2, Mercator->achNj);
+
+/* convert first_lat to 3 chars */
+      set_bytes(ProjInp->first_lat, 3, Mercator->achLat1);
+
+/* convert first_lon to 3 chars */
+      set_bytes(ProjInp->first_lon, 3, Mercator->achLon1);
+
+      Mercator->chRes_flag = ( unsigned char ) ProjInp->usRes_flag;
+
+/* convert La2 to 3 chars */
+      set_bytes(ProjInp->La2, 3, Mercator->achLat2);
+
+/* convert Lo2 to 3 chars */
+      set_bytes(ProjInp->Lo2, 3, Mercator->achLon2);
+
+/* convert lLon_orient to 3 chars */
+      set_bytes(ProjInp->latin, 3, Mercator->achLatin);
+
+/* convert zero fill */
+      Mercator->achZero1 = ( unsigned char ) ProjInp->usZero1;
+
+      Mercator->chScan_mode = ( unsigned char ) ProjInp->usScan_mode;
+
+/* convert ulDx to 3 char */
+      set_bytes(ProjInp->lon_inc, 3, Mercator->achDi);
+
+/* convert ulDy to 3chars */
+      set_bytes(ProjInp->lat_inc, 3, Mercator->achDj);
+
+      Mercator->chScan_mode = ( unsigned char ) ProjInp->usScan_mode;
+
+/* 8 bytes of zero */
+      memset((void*) Mercator->achZero2, '\0', 8);
+
+/* 
+*
+* F.5       DEBUG print GRIB Projection block
+*/
+  DPRINT3("\t%s: achNi [%02d,%02d]\n",func,Mercator->achNi[0],Mercator->achNi[1]);
+  DPRINT3("\t%s: achNj [%02d,%02d]\n",func, Mercator->achNj[0],Mercator->achNj[1]);
+  DPRINT4("\t%s: achLat1 [%02d,%02d,%02d]\n",func, Mercator->achLat1[0],
+  Mercator->achLat1[1], Mercator->achLat1[2]);
+  DPRINT4("\t%s: achLon1 [%02d,%02d,%02d]\n",func, Mercator->achLon1[0],
+   Mercator->achLon1[1] , Mercator->achLon1[2]);
+  DPRINT2("\t%s: chRes_flag [%02d]\n",func, Mercator->chRes_flag);
+  DPRINT4("\t%s: achLatint [%02d,%02d,%02d]\n",func, 
+  Mercator->achLatin[0], Mercator->achLatin[1], Mercator->achLatin[2]);
+  DPRINT4("\t%s: achDi [%02d,%02d,%02d]\n",func, Mercator->achDi[0],
+  Mercator->achDi[1], Mercator->achDi[2]);
+  DPRINT4("\t%s: achDj [%02d,%02d,%02d]\n",func, Mercator->achDj[0],
+  Mercator->achDj[1], Mercator->achDj[2]);
+  DPRINT5("\t%s: achZero2 [%02d,%02d,%02d,%02d]\n",func, Mercator->achZero2[0],
+  Mercator->achZero2[1],  Mercator->achZero2[2],  Mercator->achZero2[3]);
+/*******/
+
+/*
+*
+* F.7        STORE size of POLAR struct in lProj_size
+*/
+      *lProj_size = sizeof (MERCATOR);
+
+BYE:
+   DPRINT3 ("   Exiting %s (lProj_size=%ld), stat=%d\n", func,
+      *lProj_size, nStatus);
+/*
+*
+* F.8       RETURN Stat  ! 0 or  1
+*/
+   return ( nStatus );
+/* 
+* 
+* END OF FUNCTION
+*
+*
+*/ 
+}
+/*
+Old round--this is different from standard gnu round (gnu round returns a 
+float).  Depending on compile options, sometimes gnu round was used, other
+times this function was used.  Removed and replaced by lrint by T. Hutchinson,
+WSI.  4/14/05.
+long round(double value)
+{
+  long retval;
+  retval=lrint(value);
+  return retval;
+}
+*/
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/gribputpds.c b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputpds.c
new file mode 100644
index 00000000..3176bbc4
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/gribputpds.c
@@ -0,0 +1,511 @@
+/* FILENAME:   gribputpds.c */
+#include 
+#include 
+#include 
+#include 
+#ifdef XT3_Catamount
+#include 
+#else
+#include 
+#endif
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+****************************************************************************
+* A.  FUNCTION:  gribputpds
+*       Use the information provided to create a Product Defn Section of
+*       the GRIB format and store it in the GRIB_HDR structure;
+*
+*    INTERFACE:
+*       int gribputpds (Data_Input, User_Input, pPDS_Input, ppgrib_hdr, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  DATA_INPUT Data_Input;
+*           Structure containing info of this field (ids used in the Sections)
+*      (I)  USER_INPUT User_Input;
+*           Structure containing encoder configuration data
+*      (O)  PDS_INPUT  *pPDS_Input;
+*           points to an empty Structure;   to be filled with PDS info
+*           retrieved from  Data_Input and User_Input.
+*     (I&O) GRIB_HDR **ppgrib_hdr;
+*           points to Grib Header Structure;  May already have 1 or more
+*           GRIB sections in it;  Will have PDS appended to its 'entire_msg',
+*           'pds_ptr', 'pds_len' and 'mesg_len' updated also.
+*      (O)  char *errmsg;
+*           empty array, returned filled if error occurred
+* 
+*    RETURN CODE:
+*       0>  no errors;
+*           Grib Header structure now has PDS newly appended to its
+*           entire_msg buffer, its sections length, message length,
+*           and section pointers are updated.
+*	1>  error, errmsg filled;
+*           failed to make storage for PDS_GRIB, or
+*           failed to enlarge 'entire_msg' to hold new PDS block;
+*      99>  error in create_inpPDS() or inp2grib_PDS(); errmsg filled;
+****************************************************************************/
+
+#if PROTOTYPE_NEEDED
+int gribputpds ( DATA_INPUT 	Data_Input,
+		USER_INPUT 	User_Input,
+		PDS_INPUT 	*pPDS_Input,
+		GRIB_HDR 	**ppgrib_hdr,
+		char 		*errmsg)
+#else
+int gribputpds ( Data_Input, User_Input, pPDS_Input, ppgrib_hdr, errmsg)
+		DATA_INPUT 	Data_Input;
+		USER_INPUT 	User_Input;
+		PDS_INPUT 	*pPDS_Input;
+		GRIB_HDR 	**ppgrib_hdr;
+		char 		*errmsg;
+#endif
+{
+   PDS_GRIB  *pPDS_Grib=0; /* true GRIB format for pds */
+   GRIB_HDR  *gh;	   /* working var */
+   int       stat= 0;	   /* status */
+   long	     newsize=0L;   /* size of msg after adding PDS block */
+   /*void      create_inpPDS ();
+   int       inp2grib_PDS ();*/
+   char	     *func= "GribPutPDS";
+
+  DPRINT1("\nEntering %s()......\n", func);
+/*
+*
+* A.1       FUNCTION create_inpPDS   	        !void
+*           !create internal struct PDS_INPUT from DATA_INPUT & USER_INPUT
+*/
+   create_inpPDS (Data_Input, User_Input, pPDS_Input);
+
+/*
+*
+* A.2       MALLOC local struct PDS_GRIB, clear it out;
+*           IF (fails) THEN
+*               SET bad stat
+*               RETURN
+*           ELSE 
+*               CLEAR out the struct
+*           ENDIF
+*/
+  if ( !(pPDS_Grib= (PDS_GRIB *)malloc(sizeof(PDS_GRIB))) )
+    {	
+     sprintf(errmsg,"%s:  failed storage for PDS_GRIB\n",func);
+     stat=1; goto BYE; 
+    }
+   else memset ((void *)pPDS_Grib, '\0', sizeof(PDS_GRIB));
+
+/*
+*
+* A.3       FUNCTION inp2grib_PDS   
+*           !convert internal PDS_INPUT to true Grib format PDS_GRIB
+*           IF (error) THEN
+*               SAVE error from func in stat
+*               RETURN
+*           ENDIF
+*/
+   if (stat = inp2grib_PDS (pPDS_Input, &pPDS_Grib, errmsg))
+	 { upd_child_errmsg (func, errmsg);
+	   goto BYE; 
+	 }
+/*
+*
+* A.4       CALCULATE new msg length after adding new PDS
+*/
+  DPRINT0("putting Pds into Grib Hdr struct\n");
+
+  gh= *ppgrib_hdr;
+  newsize= gh->msg_length + sizeof(PDS_GRIB);
+
+/*
+*
+* A.5       IF gribhdr's buffer is too small AND
+*               FUCTION Expand_gribhdr failed 
+*           THEN
+*               SET stat = 1
+*               RETURN with error   !errmsg filled
+*           ENDIF
+*/
+     if (newsize > gh->abs_size
+        && Expand_gribhdr (gh, newsize, errmsg) !=0)
+        {
+        stat = 1;
+        upd_child_errmsg (func, errmsg);
+        goto BYE;
+        }
+
+/*
+*
+* A.6       COPY Pds and its info into Grib Header
+*           !copy PDS_GRIB struct to the end of Entire_msg array;
+*           !store pds pointer and length
+*           !update msg length
+*/
+   gh->pds_ptr= gh->entire_msg + gh->msg_length;
+   memcpy ((void *) gh->pds_ptr, (void *) pPDS_Grib, sizeof (PDS_GRIB));
+   gh->pds_len    = sizeof(PDS_GRIB);
+   gh->msg_length += gh->pds_len;
+
+   DPRINT1 ("copied PDS_GRIB(%ld) bytes from pPDS_Grib to PDS_PTR\n",
+     	sizeof(PDS_GRIB));
+
+/*
+*
+* A.7       FREE up local struct PDS_GRIB
+*
+* A.8       RETURN to caller with stat
+*/
+BYE:
+   if (pPDS_Grib!=NULL) free (pPDS_Grib);
+   DPRINT2 ("Leaving %s(), stat=%d\n", func,stat);
+   return stat;
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+*********************************************************************
+* B. FUNCTION:  create_inpPDS
+*        Fill the internal Product Defn Section structure with info
+*        retrieved from the 2 input structures DATA_INPUT and USER_INPUT.
+*
+*    INTERFACE:
+*        void  create_inpPDS (Data_Input, User_Input, pPDS_Input)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  DATA_INPUT Data_Input;   holds ids to be used in Sections
+*      (I)  USER_INPUT User_Input;   holds encoder configuration info
+*      (O)  PDS_INPUT *pPDS_Input;   pre-allocated structure to be filled;
+*
+*    RETURN CODE:   none;
+**********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void  create_inpPDS ( DATA_INPUT Data_Input, USER_INPUT User_Input,
+			PDS_INPUT *pPDS_Input)
+#else
+void  create_inpPDS ( Data_Input, User_Input, pPDS_Input)
+			DATA_INPUT Data_Input; 
+			USER_INPUT User_Input;
+			PDS_INPUT *pPDS_Input;
+#endif
+{
+int i;
+
+   DPRINT0 ( "Entering create_inpPDS ()\n" );
+/*
+*
+* B.1       LOAD info from struct USER_INPUT into struct PDS_INPUT 
+*/
+
+/* assigns the values from USER_INPUT to PDS_Input */
+   pPDS_Input->usEd_num = (unsigned short) 1; /* GRIB Edition num */
+   pPDS_Input->usParm_tbl = User_Input.usParm_tbl; /* GRIB TblVersion num */
+   pPDS_Input->usSub_tbl = User_Input.usSub_tbl; /* Local TblVersion num */
+   pPDS_Input->usCenter_id = User_Input.usCenter_id; /* Originating Ctr-Tbl0*/
+   pPDS_Input->usProc_id = Data_Input.usProc_id; /* Model id */
+   pPDS_Input->usGrid_id = Data_Input.usGrid_id; /* Grid id num */
+   pPDS_Input->usGds_bms_id = User_Input.usGds_bms_id; /* GDS/BMS flag-Tbl1 */
+   pPDS_Input->usParm_id = Data_Input.usParm_id; /* Parameter& Units id -Tbl2 */
+   pPDS_Input->usParm_sub = Data_Input.usParm_sub_id;/* Sub-Tblentry for Tbl2 */
+   pPDS_Input->usLevel_id = Data_Input.usLevel_id; /* Type of level/layer-Tbl3*/ /* Height, pressure of level 1  and 2 */ 
+   pPDS_Input->usHeight1 =(unsigned short)Data_Input.nLvl_1 ; 
+   pPDS_Input->usHeight2 =(unsigned short)Data_Input.nLvl_2 ; 
+   pPDS_Input->usYear =(unsigned short)( Data_Input.nYear % 100 ); /* Year */
+   pPDS_Input->usMonth =(unsigned short)Data_Input.nMonth; /* Month */
+   pPDS_Input->usDay =(unsigned short)Data_Input.nDay;/* Day of month */
+   pPDS_Input->usHour =(unsigned short)Data_Input.nHour; /* Hour of day */
+   pPDS_Input->usMinute =(unsigned short)Data_Input.nMinute; /* Minute of hour*/
+   pPDS_Input->usSecond =(unsigned short)Data_Input.nSecond; /* Secs of Min */
+   pPDS_Input->usFcst_unit_id = Data_Input.usFcst_id; /*ForecastTime unit-Tbl4*/
+   /* Period of time (tau)- 0 for analysis */
+   pPDS_Input->usP1 = Data_Input.usFcst_per1;
+   /* Period of time between analyses */
+   pPDS_Input->usP2 = Data_Input.usFcst_per2;
+   /* Time range indicator-Tbl5 */
+   pPDS_Input->usTime_range = Data_Input.usTime_range_id;
+   /* Num in average */
+   pPDS_Input->usTime_range_avg = Data_Input.usTime_range_avg;
+   /* Num missing from average */
+   pPDS_Input->usTime_range_mis = Data_Input.usTime_range_mis; 
+
+   /* Century of reference time */
+   if (Data_Input.nYear % 100 == 0) {
+     pPDS_Input->usCentury = (unsigned short)( Data_Input.nYear / 100 );
+     pPDS_Input->usYear += 100;
+   } else {
+     pPDS_Input->usCentury =(unsigned short)( Data_Input.nYear / 100 + 1);
+   }
+
+   /* Decimal scale factor */
+   pPDS_Input->sDec_sc_fctr = (short) Data_Input.nDec_sc_fctr;
+   /* reserved bytes */
+   for ( i=0 ; i< 12 ; i++)pPDS_Input->ausZero[i] = 0; /* Reserved- Set to 0 */
+   /* Oct-26 was reserved, now holds Sub-Center Id */
+   pPDS_Input->usCenter_sub =  User_Input.usCenter_sub;
+   /* Oct-41:  show that Grib Extensions are used */
+   pPDS_Input->usExt_flag = (unsigned short)EXTENSION_FLAG; 
+   /* Tracking ID for data set */
+   pPDS_Input->usTrack_num = User_Input.usTrack_num; 
+
+   /* WSI Extended PDS section: Used for extended and higher resolution time periods */
+   pPDS_Input->PDS_41 = Data_Input.PDS_41;
+   pPDS_Input->PDS_42 = Data_Input.PDS_42;
+   pPDS_Input->PDS_46 = Data_Input.PDS_46;
+   pPDS_Input->PDS_47 = Data_Input.PDS_47;
+   pPDS_Input->PDS_51 = Data_Input.PDS_51;
+   pPDS_Input->PDS_52 = Data_Input.PDS_52;
+
+/*
+*
+* B.2       ASSIGN size of PDS_GRIB into uslength of struct PDS_INPUT
+	    ** If encoding MEL GRIB messages, Pds Length should be 46 and
+	    Octet 41 should equal the Extension Flag.
+*/
+   pPDS_Input->uslength = sizeof(PDS_GRIB);
+
+/*
+*
+* B.3       DEBUG Print
+*/
+   DPRINT1("\t create_inpPDS:  uslength = %u (Size of PDS_GRIB)\n",
+   pPDS_Input->uslength );
+   DPRINT1("\t create_inpPDS:  usEd_num = %u\n", pPDS_Input->usEd_num );
+   DPRINT1("\t create_inpPDS:  usParm_tbl = %u\n", pPDS_Input->usParm_tbl );
+   DPRINT1("\t create_inpPDS:  usSub_tbl = %u\n", pPDS_Input->usSub_tbl);
+   DPRINT1("\t create_inpPDS:  usCenter_id = %u\n", pPDS_Input->usCenter_id );
+   DPRINT2("\t create_inpPDS:  usCenter_sub Oct26=%u, usExt_flag Oct41=%u\n", 
+	pPDS_Input->usCenter_sub, pPDS_Input->usExt_flag);
+   DPRINT1("\t create_inpPDS:  usProc_id = %u\n", pPDS_Input->usProc_id );
+   DPRINT1("\t create_inpPDS:  usGrid_id = %u\n", pPDS_Input->usGrid_id );
+   DPRINT1("\t create_inpPDS:  usGds_bms_id = %u\n", pPDS_Input->usGds_bms_id);
+   DPRINT1("\t create_inpPDS:  usParm_id = %u\n", pPDS_Input->usParm_id );
+   DPRINT1("\t create_inpPDS:  usParm_sub = %u\n", pPDS_Input->usParm_sub);
+   DPRINT1("\t create_inpPDS:  usLevel_id = %u\n", pPDS_Input->usLevel_id );
+   DPRINT1("\t create_inpPDS:  usHeight1 = %u\n", pPDS_Input->usHeight1 );
+   DPRINT1("\t create_inpPDS:  usHeight2 = %u\n", pPDS_Input->usHeight2 );
+   DPRINT1("\t create_inpPDS:  usCentury = %u\n", pPDS_Input->usCentury );
+   DPRINT1("\t create_inpPDS:  usYear = %u\n", pPDS_Input->usYear );
+   DPRINT1("\t create_inpPDS:  usDay = %u\n", pPDS_Input->usDay );
+   DPRINT1("\t create_inpPDS:  usHour = %u\n", pPDS_Input->usHour );
+   DPRINT1("\t create_inpPDS:  usMinute = %u\n", pPDS_Input->usMinute );
+   DPRINT1("\t create_inpPDS:  usSecond = %u\n", pPDS_Input->usSecond );
+   DPRINT1("\t create_inpPDS:  usP1 = %u\n", pPDS_Input->usP1);
+   DPRINT1("\t create_inpPDS:  sDec_sc_fctr  = %d\n", pPDS_Input->sDec_sc_fctr);
+   DPRINT1("\t create_inpPDS:  usTrack_num = %u\n", pPDS_Input->usTrack_num);
+   DPRINT0("\t create_inpPDS:  WSI Extended PDS Section: \n");
+   DPRINT1("\t create_inpPDS:  PDS_41 (Forecast time 1 unit id): %u\n",pPDS_Input->PDS_41);
+   DPRINT1("\t create_inpPDS:  PDS_42 (Forecast time 1): %u\n",pPDS_Input->PDS_42);
+   DPRINT1("\t create_inpPDS:  PDS_46 (Forecast time 2 unit id): %u\n",pPDS_Input->PDS_46);
+   DPRINT1("\t create_inpPDS:  PDS_47 (Forecast time 2 unit id): %u\n",pPDS_Input->PDS_47);
+   DPRINT1("\t create_inpPDS:  PDS_51 (Time range indicator): %u\n",pPDS_Input->PDS_51);
+   DPRINT1("\t create_inpPDS:  PDS_52 (Top of atm): %u\n",pPDS_Input->PDS_52);
+
+   
+/*
+*
+* B.4       RETURN w/nothing
+*/
+   DPRINT0 ("Exiting create_inpPDS with no errors;\n");  
+
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+****************************************************************************
+* C. FUNCTION:  inp2grib_PDS
+*      Use the data from the internal structure to fill the Product 
+*      Definition Section structure.
+*
+*    INTERFACE:
+*      int inp2grib_PDS ( pPDS_Input, ppPDS_Grib, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  PDS_INPUT *pPDS_Input;
+*           internal PDS structure, used for input
+*      (O)  PDS_GRIB  **ppPDS_GRIB ;
+*           pre-allocated structure to be filled;
+*      (O)  char *errmsg;
+*           empty array, returned filled if error occured;
+*
+*   RETURN CODE:
+*      0> no errors;  PDS_GRIB filled;
+*     99> unexpected null pointers, Errmsg filled;
+****************************************************************************/
+
+#if PROTOTYPE_NEEDED
+int inp2grib_PDS ( PDS_INPUT 	*pPDS_Input,
+		PDS_GRIB 	**ppPDS_Grib,
+		char 		*errmsg)
+#else
+int inp2grib_PDS ( pPDS_Input, ppPDS_Grib, errmsg)
+		PDS_INPUT 	*pPDS_Input;
+		PDS_GRIB 	**ppPDS_Grib;
+		char 		*errmsg;
+#endif
+{
+   char		    *func= "inp2grib_PDS";
+   unsigned char    ach3bytes[3];
+   unsigned long    ulPDS_length = 0;
+   short            sDec_sc_fctr = 0;
+   int              nStatus = 0;
+   int              i; 		/* loop counter */
+   long		    lTemp;	/* working var */
+   PDS_GRIB         *tpds; 	/* true grib pds, working var */
+   short            tmp_byte2;  /* working var */
+   long             tmp_byte4;  /* working var */
+
+   DPRINT0  ( "Entering inp2grib_PDS......\n" );
+
+/*
+*
+* C.1       IF (either Internal PDS_INPUT or True Grib PDS_GRIB is null) THEN
+*              SET status = 99;
+*              RETURN
+*           ENDIF
+*/
+      if ( !ppPDS_Grib  || !pPDS_Input) {
+	   sprintf(errmsg,
+	   "%s: either PDS_GRIB /PDS_INPUT/or both are Null\n",func);
+	   nStatus= 99;
+	   goto BYE;
+	}
+
+/*
+*
+* C.2       ASSIGN local ptr to point to PDS_GRIB struct;
+*/
+      tpds = *ppPDS_Grib;
+
+/*
+*
+* C.3       CREATE true Grib struct PDS_GRIB from internal PDS_INPUT
+*/
+      tpds->chParm_tbl =  ( unsigned char ) pPDS_Input->usParm_tbl;
+
+      /* Commented out by Todd Hutchinson, WSI, when Extended PDS was replaced */
+      /* tpds->chSub_tbl =  ( unsigned char ) pPDS_Input->usSub_tbl; */
+
+      tpds->chCenter_id = ( unsigned char ) pPDS_Input->usCenter_id;
+      tpds->chProc_id = ( unsigned char ) pPDS_Input->usProc_id;
+      tpds->chGrid_id = ( unsigned char ) pPDS_Input->usGrid_id;
+      tpds->chGds_bms_id = ( unsigned char ) pPDS_Input->usGds_bms_id;
+      tpds->chParm_id = ( unsigned char ) pPDS_Input->usParm_id;
+
+      /* Commented out by Todd Hutchinson, WSI, when Extended PDS was replaced */
+      /* tpds->chParm_sub= (unsigned char )  pPDS_Input->usParm_sub; */
+
+      tpds->chLevel_id = ( unsigned char ) pPDS_Input->usLevel_id;
+
+      switch(pPDS_Input->usLevel_id){
+        case   1:  /* surface(of the Earth, includes sea surface) level  */
+        case   2:  /* cloud base level  */
+        case   3:  /* cloud top level  */
+        case   4:  /* 0 deg C isotherm level */
+        case   5:  /* adiabatic condensation level  */
+        case   6:  /* maximum wind speed level  */
+        case   7:  /* tropopause level  */
+        case   8:  /* nominal top of atmosphere level  */
+        case   9:  /* sea bottom level  */
+        case 100:  /* isobaric level            */
+        case 103:  /* fixed height level        */
+        case 105:  /* fixed height above ground */
+        case 107:  /* sigma level               */
+        case 111:  /* depth below land surface  */
+        case 113:  /* isentropic (theta) level  */
+        case 115:  /* sigma-z level  */
+        case 119:  /* Eta Level */
+        case 125:  /* height level above ground (high precision) */
+        case 160:  /* depth below sea level     */
+        case 200:  /* entire atmosphere considered as a single layer */
+        case 201:  /* entire ocean considered as a single layer */
+        case 212:  /* low cloud bottom level */
+        case 213:  /* low cloud top level */
+        case 222:  /* middle cloud bottom level */
+        case 223:  /* middle cloud top level */
+        case 232:  /* high cloud bottom level */
+        case 233:  /* high cloud top level */
+	  set_bytes(pPDS_Input->usHeight1, 2, tpds->achHeight);
+          break;
+        default:
+	  set_bytes(pPDS_Input->usHeight2, 1, (tpds->achHeight));
+	  set_bytes(pPDS_Input->usHeight1, 1, (tpds->achHeight)+1);
+          break;
+      }
+
+      tpds->chYear = ( unsigned char ) pPDS_Input->usYear;
+      tpds->chMonth = ( unsigned char ) pPDS_Input->usMonth;
+      tpds->chDay = ( unsigned char ) pPDS_Input->usDay;
+      tpds->chHour = ( unsigned char ) pPDS_Input->usHour;
+      tpds->chMinute = ( unsigned char ) pPDS_Input->usMinute;
+      tpds->chFcst_unit_id = ( unsigned char ) pPDS_Input->usFcst_unit_id;
+      tpds->chP1 = ( unsigned char ) pPDS_Input->usP1;
+      tpds->chP2 = ( unsigned char ) pPDS_Input->usP2;
+      tpds->chTime_range = ( unsigned char ) pPDS_Input->usTime_range;
+
+      set_bytes(pPDS_Input->usTime_range_avg,2,tpds->achTime_range_avg);
+
+      tpds->chTime_range_mis = ( unsigned char ) pPDS_Input->usTime_range_mis;
+      tpds->chCentury = ( unsigned char ) pPDS_Input->usCentury;
+      tpds->chCenter_sub = ( unsigned char ) pPDS_Input->usCenter_sub;
+      DPRINT1("Octet-26:  tpds->usCenter_sub= %d\n", (int)tpds->chCenter_sub);
+
+      set_bytes(pPDS_Input->sDec_sc_fctr,2,tpds->achDec_sc_fctr);
+
+      for(i=0;i<12;++i)
+        tpds->achZero[i]= ( unsigned char ) pPDS_Input->ausZero[i];
+
+      /* Commented out by Todd Hutchinson, WSI, when Extended PDS was replaced */
+      /*
+      tpds->chExt_flag = (unsigned char) pPDS_Input->usExt_flag;
+      DPRINT1("Octet41:   tpds->chExt_flag= %d\n", (int)tpds->chExt_flag);
+
+      tpds->chSecond = ( unsigned char ) pPDS_Input->usSecond;
+      memcpy((void *)tpds->chTrack_num, 
+		(void *)&(pPDS_Input->usTrack_num), 2);
+      */
+      
+      /* Added by Todd Hutchinson, WSI.  Extended WSI PDS section */
+
+      tpds->PDS_41 = (unsigned char)pPDS_Input->PDS_41;
+
+      set_bytes(pPDS_Input->PDS_42,4,tpds->PDS_42);
+
+      tpds->PDS_46 = (unsigned char)pPDS_Input->PDS_46;
+
+      set_bytes(pPDS_Input->PDS_47,4,tpds->PDS_47);
+
+      tpds->PDS_51 = (unsigned char)pPDS_Input->PDS_51;
+
+      set_bytes(pPDS_Input->PDS_52,2,tpds->PDS_52);
+
+      ulPDS_length= sizeof (PDS_GRIB);
+      DPRINT1 ( "\t length of PDS_GRIB is %d\n", ulPDS_length );
+
+      set_bytes(ulPDS_length, 3, tpds->achPDS_length);
+
+     HDR_PRINT("encoded PDS", (unsigned char*)tpds, (int)ulPDS_length); 
+/*
+*
+* C.4       RETURN with Status
+*/
+BYE:
+      DPRINT1 ( "Exiting inp2grib_PDS(), stat=%d\n", nStatus);
+      return ( nStatus );
+/* 
+* 
+* END OF FUNCTION
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/hdr_print.c b/wrfv2_fire/external/io_grib1/MEL_grib1/hdr_print.c
new file mode 100644
index 00000000..06d3d983
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/hdr_print.c
@@ -0,0 +1,66 @@
+/* FILENAME:   hdr_print.c */
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+* 
+********************************************************************
+* A. FUNCTION:  hdr_print
+*      print specified number of bytes from the block provided.
+*      does not require Debug flag to be set;
+*
+*    INTERFACE:
+*      void  hdr_print (title, block, bytestoprint)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *title;		Title string to print
+*      (I)  unsigned char *block;       Block whose content to print
+*      (I)  int bytestoprint;           Number of bytes to print 
+*
+*    RETURN CODE:   none;
+********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void  hdr_print (char *title, unsigned char *block, int bytestoprint)
+#else
+void  hdr_print (title, block, bytestoprint)
+		char *title; unsigned char *block; int bytestoprint;
+#endif
+{
+int i=0;
+/*
+*
+* A.1       PRINT title string
+*/
+   fprintf(stdout,"hdr_print %d bytes of '%s'=", bytestoprint, title);
+
+/*
+* 
+* A.2       WHILE (more bytes to print) DO
+*                PRINT byte value
+*           ENDDO
+*/
+   while (i < bytestoprint)
+    {
+	if (i % 8 == 0) {
+	   if (i+7>= bytestoprint-1)
+		fprintf(stdout,"\n[%2d-%2d]:  ",i+1, bytestoprint);
+      	   else fprintf(stdout,"\n[%2d-%2d]:  ",i+1, i+8);
+	}
+	fprintf(stdout,"%03u ", block[i++]);
+	if (i % 4 == 0) fprintf(stdout, "| ");
+    }
+   fprintf(stdout,"\n");
+/*
+*
+* A.3      RETURN w/nothing
+*/
+   fprintf(stdout,"Exiting hdr_print, no return code\n");
+/*
+*
+* END OF FUNCTION
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/init_dec_struct.c b/wrfv2_fire/external/io_grib1/MEL_grib1/init_dec_struct.c
new file mode 100644
index 00000000..1dcbf237
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/init_dec_struct.c
@@ -0,0 +1,78 @@
+/* FILENAME:   init_dec_struct.c 
+   DATE:         05 FEB 1996
+   PROGRAMMER:   STEVE LOWE, SAIC
+   Revisions:
+   17apr96 Alice Nakajima, SAIC: added BMS initialization
+   11jun96 Nakajima: replaced with Memset
+   10oct96 Nakajima: renamed from init_struct() to init_dec_struct()
+*/
+#include 
+#include 
+#include 
+#include "dprints.h"	/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+*
+*************************************************************************
+* A. FUNCTION:  init_dec_struct
+*       initializes the four internal Decoder structures 
+*    
+*    INTERFACE:
+*       void init_dec_struct ( pds, gds, bms, bds_head)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (O)  PDS_INPUT      *pds;      internal PDS struct to be initialized
+*      (O)  grid_desc_sec  *gds;      internal GDS struct to be initialized
+*      (O)  BMS_INPUT      *bms;      internal BMS struct to be initialized
+*      (O)  BDS_HEAD_INPUT *bds_head; internal BDS struct to be initialized
+*
+*    RETURN CODE:  none
+*************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void init_dec_struct (  PDS_INPUT      *pds, grid_desc_sec  *gds,
+			BMS_INPUT      *bms, BDS_HEAD_INPUT *bds_head)
+#else
+void init_dec_struct (pds,gds,bms,bds_head)
+        PDS_INPUT      *pds;
+        grid_desc_sec  *gds;
+        BMS_INPUT      *bms;
+        BDS_HEAD_INPUT *bds_head;
+#endif
+{
+/* 
+*
+* A.0       DEBUG printing
+*/
+  DPRINT0 ("Inside init_dec_struct()\n");
+
+/* 
+*
+* A.1       INITIALIZE Product Description Section struct elements
+*/
+  memset ((void *)pds, '\0', sizeof(PDS_INPUT)); 
+
+/* 
+*
+* A.2       INITIALIZE Grid Description Section struct elements 
+*
+* A.3       INITIALIZE Bitmap Map Section  header struct elements to zero
+*
+* A.4       INITIALIZE Binary Data Section Header Struct elements  to zero
+*/
+  memset ((void *)gds, '\0', sizeof(grid_desc_sec)); 
+  gds->head.usData_type = 255;
+  memset ((void *)bms, '\0', sizeof(BMS_INPUT));
+  memset ((void *)bds_head, '\0', sizeof(BDS_HEAD_INPUT));
+
+/* 
+*
+* A.5       DEBUG printing
+*/
+  DPRINT0("Leaving init_dec_struct(), no return code\n");
+/*
+* END OF FUNCTION
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/init_enc_struct.c b/wrfv2_fire/external/io_grib1/MEL_grib1/init_enc_struct.c
new file mode 100644
index 00000000..9e5ce13f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/init_enc_struct.c
@@ -0,0 +1,61 @@
+/* FILENAME:     init_enc_struct.c
+   DATE:         15 FEB 1996
+   PROGRAMMER:   STEVE LOWE, SAIC
+   REVISED BY:   ALICE NAKAJIMA, SAIC
+ */
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+/*
+*
+************************************************************************
+* A. FUNCTION:  init_enc_struct
+*       initializes structures DATA_INPUT and GEOM_IN
+*
+*    INTERFACE:
+*       void init_enc_struct (data_input, geom_in, user_input)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (O) DATA_INPUT *data_input;    encoder struct to be initialized
+*      (O) GEOM_IN  *geom_in;         encoder struct to be initialized
+*      (O) USER_INPUT *user_input;    encoder struct to be initialized
+*
+*      RETURN CODE:   none
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void init_enc_struct ( DATA_INPUT *data_input, GEOM_IN  *geom_in,
+			USER_INPUT *user_input)
+#else
+void init_enc_struct ( data_input, geom_in, user_input)
+			DATA_INPUT *data_input; 
+			GEOM_IN  *geom_in;
+			USER_INPUT *user_input;
+#endif
+{
+  DPRINT0 ("Entering init_enc_struct()\n");
+/*
+*
+* A.1       CLEAR elements of DATA_INPUT Structure
+*
+* A.2       CLEAR elements of GEOM_IN Structure
+*
+* A.3       CLEAR elements of USER_INPUT Structure 
+*/
+  memset ((void *)data_input, '\0', sizeof (DATA_INPUT));
+  memset ((void *)geom_in, '\0', sizeof (GEOM_IN));
+  memset ((void *)user_input, '\0', sizeof (USER_INPUT));
+
+  DPRINT0 ("Exiting init_enc_struct()\n");
+/*
+*
+* A.4        RETURN
+*/
+  return;
+
+/*
+* END OF FUNCTION
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/init_gribhdr.c b/wrfv2_fire/external/io_grib1/MEL_grib1/init_gribhdr.c
new file mode 100644
index 00000000..ea0be982
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/init_gribhdr.c
@@ -0,0 +1,290 @@
+/*  File:  init_gribhdr.c		Alice T. Nakajima, SAIC, 10/96
+    funcs to make storage and free up storage for Grib header struct
+*/
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+/*
+*
+****************************************************************************
+* A. FUNCTION  init_gribhdr
+*       Allocates storage for Grib Header and its entire_msg and initialize
+*       every of its attributes.
+*
+*    INTERFACE:
+*       int     init_gribhdr (ppgrib_hdr, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (O)  GRIB_HDR **ppgrib_hdr;
+*           Grib Header structure, Null upon entry;  Returns pointing to a 
+*           newly created storage.  Its attribute 'entire_msg' will point
+*           to a block of size indicated in 'abs_size' (initially set to
+*           DEF_MSG_LEN bytes, see grib.h).  'entire_msg' may later be 
+*           expanded by other functions if required, but 'abs_size' must
+*           be updated to the expanded byte length.
+*      (O)  char *errmsg;
+*           empty array, returned filled if error occurred;
+*
+*    RETURNS:  
+*     0>  no error; storage for grib header and its entire_msg array created
+*         and cleared;  msg_length and all section lengths are set to zero, 
+*         all section pointers are Null; abs_size is set to DEF_MSG_LEN;
+*         'shuffled' flag is set to zero;
+*     1>  failed, see errmsg;
+****************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int  init_gribhdr ( GRIB_HDR **ppgrib_hdr, char *errmsg)
+#else
+int  init_gribhdr ( ppgrib_hdr, errmsg)
+		GRIB_HDR **ppgrib_hdr; char *errmsg;
+#endif
+{
+/*
+* A.0       DEFAULT to error status
+*/
+char *func= "init_gribhdr";
+int	stat=1;
+
+   DPRINT1 ("Entering %s\n", func);
+/*
+*
+* A.1       ALLOCATE storage for struct GRIB_HDR
+*           IF (fails) THEN
+*               RETURN  error
+*           ELSE
+*               CLEAR out struct GRIB_HDR
+*           ENDIF
+*/
+   *ppgrib_hdr= (GRIB_HDR *)malloc(sizeof(GRIB_HDR));
+   if (*ppgrib_hdr == NULL) {
+
+	DPRINT1 ("%s:  failed to create storage for GRIB_HDR\n", func);
+	sprintf (errmsg, "%s:  failed to create storage for GRIB_HDR\n", func);
+	goto BYE;
+	}
+   else memset ((void *)*ppgrib_hdr, '\0', sizeof(GRIB_HDR));
+   DPRINT2 ("Allocate storage of GRIB_HDR struct, addr=%ld (%ld bytes)\n", 
+   *ppgrib_hdr, sizeof(GRIB_HDR));
+
+/*
+*
+* A.2       ALLOCATE storage for struct GRIB_HDR's Entire_Msg array
+*           !size DEF_MSG_LEN bytes as defined in 'grib.h'
+*           IF (fails) THEN
+*               FREE Grib Header
+*               RETURN error
+*           ELSE
+*               STORE absolute size of Entire_Msg in header's Abs_Size
+*               CLEAR out array Entire_Msg of struct
+*               SET status to good
+*           ENDIF
+*/
+   
+   (*ppgrib_hdr)->entire_msg=  (void *)malloc(DEF_MSG_LEN);
+   if ((*ppgrib_hdr)->entire_msg == NULL) {
+	DPRINT1 ( "%s:  failed to create storage for GRIB_HDR's Msg\n", func);
+	sprintf (errmsg, "%s:  failed to create storage for GRIB_HDR's Msg\n", 
+	func);
+	free (*ppgrib_hdr);
+	}
+   else {
+	(*ppgrib_hdr)->abs_size = (long)DEF_MSG_LEN;
+	memset ((void *)(*ppgrib_hdr)->entire_msg, '\0', DEF_MSG_LEN);
+	DPRINT2 (
+	"Allocate storage for GRIB_HDR->entire_msg, addr=%ld, sz= %ld bytes \n",
+	(*ppgrib_hdr)->entire_msg, (*ppgrib_hdr)->abs_size);
+	stat=0;
+	}
+
+
+/*
+*
+* A.3       RETURN status 
+*/
+BYE:
+   DPRINT2 ("Leaving %s,  stat=%d;\n", func,stat);
+   return (stat);
+
+/*
+*
+* END OF FUNCTION
+*
+*
+*/
+}
+
+/*
+*
+****************************************************************************
+* B. FUNCTION:  free_gribhdr
+*      to free up storage of Grib Header structure and all its attributes.
+*
+*    INTERFACE:
+*      void    free_gribhdr (ppgrib_hdr)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (O)  GRIB_HDR **ppgrib_hdr;
+*           Grib Header structure whose storage is released;
+*
+*    RETURN CODE:  none;
+****************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void	free_gribhdr ( GRIB_HDR **ppgrib_hdr)
+#else
+void	free_gribhdr ( ppgrib_hdr)
+			GRIB_HDR **ppgrib_hdr;
+#endif
+{
+   char *func="free_gribhdr";
+   DPRINT1 ("Entering %s\n", func);
+/*
+*
+* B.1       IF (this struct is not null) {
+*               IF (struct's entire_msg is not null)
+*                   FREE entire msg array
+*               ENDIF
+*               FREE struct itself
+*               SET it to null
+*           ENDIF
+*/
+   if (*ppgrib_hdr != NULL) {
+       	if ((*ppgrib_hdr)->entire_msg != NULL) free((*ppgrib_hdr)->entire_msg);
+	free (*ppgrib_hdr);
+	*ppgrib_hdr= NULL;
+   }
+   DPRINT1 ("Leaving %s, no return code\n", func);
+/*
+*
+* END OF FUNCTION
+*
+*/
+}
+
+/*
+***********************************************************************
+* C. FUNCTION:  Expand_gribhdr
+*      to make Grib Header structure 's entire_msg buffer larger
+*      than its current abs_size.
+*
+*    INTERFACE:
+*      int   Expand_gribhdr (gh, newsize, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*    (I&O)  GRIB_HDR *gh;
+*           Grib Header structure whose buffer is to be expanded;
+*      (I)  long newsize;
+*           size to expand entire_msg to;
+*      (O)  char *errmsg;
+*           empty array, returned filled if error occurred;
+*
+*    RETURN CODE:  
+*      0>  newsize is smaller or equal to current size and function
+*          with return with GRIB header unchanged;  OR,
+*          successful, entire_msg now is larger & abs_size has
+*          been updated;  all of the section pointers are also 
+*          updated to point to correct location within the new
+*          larger block.
+*      1>  error occurred, Errmsg filled;
+****************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int	Expand_gribhdr (GRIB_HDR *gh, long newsize, char *errmsg)
+#else
+int	Expand_gribhdr (gh, newsize, errmsg)
+GRIB_HDR	*gh;
+long		newsize;
+char		*errmsg;
+#endif
+{
+   char *func="Expand_gribhdr";
+   unsigned char  *Buff;			/* temp array */
+
+   DPRINT1 ("Entering %s\n", func);
+/*
+* C.0       IF (grib hdr struct pointer or entire_msg is null) 
+*              RETURN with error
+*           ENDIF
+*/
+   if (gh == (GRIB_HDR *)NULL || gh->entire_msg == (unsigned char *)NULL)  {
+	sprintf(errmsg,"%s: either GRIB_HDR or Entire_msg is Null\n",
+	func);
+        DPRINT1 ("Leaving %s, with error (NULL Grib Header)\n", func);
+	return (1);
+   }
+
+/*
+* C.1       IF (new size is smaller than abs_size) THEN
+*              PRINT warning
+*              RETURN with no errors
+*           ENDIF
+*/
+   if (newsize <= gh->abs_size) {
+	fprintf(stdout,
+	"%s:  cannot expand to %ld bytes (must be bigger than abs_size= %ld)\n",
+	func, newsize, gh->abs_size);
+	return (0);
+   }
+
+   DPRINT2 ("Require %ld bytes and curr abs_size= %ld\n", 
+   newsize, gh->abs_size);
+
+/*
+* C.2       ALLOCATE a new block of 'newsize' bytes
+*           RETURN on error
+*/
+   Buff =  (unsigned char *)malloc (newsize);
+   if (Buff == NULL) {
+	sprintf(errmsg,"%s: failed to create new array (%d bytes)\n",
+	func, newsize);
+        DPRINT1 ("Leaving %s, with Malloc error\n", func);
+	return (1);
+   } 
+
+/*
+* C.3       CLEAR new array out 
+*/
+   memset ((void*)Buff, '\0', newsize);
+
+/*
+* C.4       COPY content of old buffer into new buffer
+*/
+   if (gh->msg_length > 0) {
+	DPRINT1(
+	"Copy %ld bytes of data from old buffer to new one\n",
+	gh->msg_length);
+
+	memcpy ((void*)Buff, (void*)gh->entire_msg, gh->msg_length);
+   }
+
+/*
+* C.6       UPDATE each Section that's present to point to
+*           proper location within the new larger buffer
+*/
+   if (gh->ids_ptr !=NULL) gh->ids_ptr= Buff + (gh->ids_ptr - gh->entire_msg);
+   if (gh->pds_ptr !=NULL) gh->pds_ptr= Buff + (gh->pds_ptr - gh->entire_msg);
+   if (gh->gds_ptr !=NULL) gh->gds_ptr= Buff + (gh->gds_ptr - gh->entire_msg);
+   if (gh->bms_ptr !=NULL) gh->bms_ptr= Buff + (gh->bms_ptr - gh->entire_msg);
+   if (gh->bds_ptr !=NULL) gh->bds_ptr= Buff + (gh->bds_ptr - gh->entire_msg);
+   if (gh->eds_ptr !=NULL) gh->eds_ptr= Buff + (gh->eds_ptr - gh->entire_msg);
+
+/*
+* C.5       FREE the old buffer & assign the new one to GRIB_HDR
+*/
+   free ((void *) gh->entire_msg);
+   gh->entire_msg = (unsigned char *)Buff;
+   
+/*
+* C.6       UPDATE alloc_size of GRIB_HDR
+*/
+   gh->abs_size = newsize;
+   DPRINT1 ("expanded  gh->abs_size = %ld\n", gh->abs_size);
+
+   DPRINT1 ("Leaving %s, no errors\n", func);
+   return (0);
+/*
+* END OF FUNCTION
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/init_struct.c b/wrfv2_fire/external/io_grib1/MEL_grib1/init_struct.c
new file mode 100644
index 00000000..bf81ed17
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/init_struct.c
@@ -0,0 +1,55 @@
+/* FILENAME:     init_struct.c
+   DATE:         15 FEB 1997
+   PROGRAMMER:   STEVE LOWE, SAIC
+
+   27aug97 Alice Nakajima (ATN):  changed 'size_t size' to 'int' (gcc complains)
+*/ 
+#include 
+#include 
+#include "dprints.h"	/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*
+************************************************************************
+* A. FUNCTION:   init_struct
+*       initializes structures DATA_INPUT and GEOM_IN
+*
+*    INTERFACE:
+*       void init_struct (generic, size)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (O)  void    *generic;   address of block to be cleared out
+*      (I)  int     size;       size of block in bytes
+*
+*    RETURN CODE:   none
+************************************************************************
+*
+*/
+#if PROTOTYPE_NEEDED
+void  init_struct ( void *generic, int size)
+#else
+void  init_struct ( generic, size)
+		void *generic; int size;
+#endif
+{
+
+  DPRINT0 ("Entering init_struct()\n");
+/*
+*
+* A.1       CLEAR elements of Structure
+*/
+  memset ((void *)generic, '\0', size);
+
+  DPRINT0 ("Exiting init_struct()\n");
+/*
+*
+* A.2        RETURN
+*/
+  return;
+
+/*
+* END OF FUNCTION
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/input.h b/wrfv2_fire/external/io_grib1/MEL_grib1/input.h
new file mode 100644
index 00000000..1982ed69
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/input.h
@@ -0,0 +1,68 @@
+typedef struct DATA_INPUT {
+   unsigned short usProc_id;       /* Generating Process ID Number (Table A) */
+   unsigned short usGrid_id;       /* Grid Identification (Table B)          */
+   unsigned short usParm_id;       /* GRIB parameter id */
+   unsigned short usParm_sub_id;   /* GRIB parameter sub-id */
+   unsigned short usLevel_id;      /* GRIB level id */
+   int            nLvl_1;          /* 1st level value - scaled to an integer*/
+   int            nLvl_2;          /* 2nd level value - scaled to an integer*/
+   int            nYear;           /* year of data e.g. 1993 */
+   int            nMonth;          /* month of year e.g. 8 */
+   int            nDay;            /* day of month e.g. 31 */
+   int            nHour;           /* hour of day e.g. 0 */
+   int            nMinute;         /* minute of hour e.g. 0 */
+   int            nSecond;         /* second of minute e.g. 0 */
+   unsigned short usFcst_id;       /*  Forecast time unit id - Table 4 */
+   unsigned short usFcst_per1;     /* forecast time 1 (tau) e.g. 0. */
+   unsigned short usFcst_per2;     /* forecast time 2 (tau) e.g. 0. */
+   unsigned short usTime_range_id; /* Time range indicator - Table 5 */
+   unsigned short usTime_range_avg;/* Number in average */
+   unsigned short usTime_range_mis;/* Number missing from average */
+   int            nDec_sc_fctr;    /* Decimal scale factor */
+   /* WSI Extended PDS fields */
+   unsigned short PDS_41;          /* Forecast time 1 unit id - Table 4 */
+   int            PDS_42;          /* forecast time 1 (up to 4 bytes) */
+   unsigned short PDS_46;          /* Forecast time 2 unit id - Table 4 */
+   int            PDS_47;          /* forecast time 2 */
+   unsigned short PDS_51;          /* Time range indicator - Table 5 */
+  unsigned short  PDS_52;          /* Top of atmosphere--used with sigma coord*/
+} DATA_INPUT;
+
+typedef struct GEOM_IN {        /* info from tables grid_reg_geom/as_reg_im */
+    char   prjn_name[21];       /* projection name */
+    char   stor_dsc[21];        /* (+x in +y)/(+x in -y)/(-y in +x)/etc */
+    long   nx;                  /* count of columns */
+    long   ny;                  /* count of rows */
+    double lat;                 /* lat of origin in degrees */
+    double lon;                 /* lon of origin in degrees */
+    double orig_ix;             /* column # for origin, left column is 1 */
+    double orig_iy;             /* row # for origin; top row is 1 */
+    double x_int_dis;           /* distance interval between columns in km */
+    double y_int_dis;           /* distance interval between rows in km */
+    double parm_1;              /* geom parm 1, depends on projection
+				 * Spherical:	j Direction Increment (Latitude)
+				 * Lambert:*/	
+    double parm_2;              /* geom parm 2, depends on projection */
+    double parm_3;              /* geom parm 3, depends on projection */
+/* Do NOT MODIFY parameters before this point */
+/* Additional Parameters Required by GRIB */
+    double first_lat;		/* latitude of grid point (1,1) */
+    double first_lon;		/* longitude of grid point (1,1) */
+    double last_lat;		/* latitude of grid point (nx,ny) */
+    double last_lon;		/* longitude of grid point (nx,ny) */
+    unsigned short scan;	/* Scan mode value from Table 8 */
+    unsigned short usRes_flag;  /* Resolution and Component Flags (Table 7)    */
+} GEOM_IN;
+
+typedef struct USER_INPUT {         /* user's input from input.dat            */
+/* PDS Section */
+    unsigned char  chCase_id;   /* User defined case ID (1 digit alphanumeric)*/
+    unsigned short usParm_tbl;  /* GRIB Table Version Number             */
+    unsigned short usSub_tbl;   /* Local Table Version Number            */
+    unsigned short usCenter_id; /* ID of Originating Center (Table 0)     */
+    unsigned short usGds_bms_id;/* GDS and BMS Flag (Table 1)             */
+    unsigned short usCenter_sub;/* Sub-Table Entry for originating Ctr (Tbl 0)*/
+    unsigned short usTrack_num; /* Tracking ID for data set               */
+    unsigned short usBDS_flag;  /* Binary Data Section Flag (Table 11)    */
+    unsigned short usBit_pack_num; /* Number of bits into which data is packed*/
+} USER_INPUT;
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/isdb.h b/wrfv2_fire/external/io_grib1/MEL_grib1/isdb.h
new file mode 100644
index 00000000..0feac04e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/isdb.h
@@ -0,0 +1,123 @@
+#ifndef ISDB_INCLUDE
+#define ISDB_INCLUDE
+
+#ifdef _NET_NEONS
+#include 
+#endif /* _NET_NEONS */
+
+/* max value from rand; HW/OS dependent */
+#define MAX_RAND 2147483647.  	/* SUN */		
+/* #define MAX_RAND 32767.	*/		/* HP, Solaris */
+
+/* Vers 4.2.1 was installed 10/01/97 on Kelvin */
+#define NEONS_VRSN_MAJOR  4	/* major release version of NEONS software */
+#define NEONS_VRSN_MINOR  2	/* minor release version of NEONS software */
+#define NEONS_VRSN_MINOR2 1	/* (sub) minor release version of software */
+				/* (for bug fixes) 			   */
+
+#define BYTE_BIT_CNT  8		/* count of bits per byte */
+#define WORD_BIT_CNT  sizeof(long)*BYTE_BIT_CNT /* count of bits per word */
+#define WORD_BYTE_CNT 4		/* count of bytes per word */
+ 
+#define	OPN_RD    1		/* open database for read only */
+#define	OPN_WR_RD 2		/* open database for write+read */
+
+#define MAX_FILE_CNT  15	/* maximum count of open files */
+
+#define ISDB_MODE   0666 	/* mode for image files placed into db */
+#define LOCK_MODE   0200 	/* mode for locking files while writing */
+#define INGEST_OWN "dba"   	/* owner of image files before loaded in db */ 
+#define INGEST_MODE 0644 	/* mode for ingest files before loaded in db */ 
+
+
+#define CLNDR_HOUR   0		/* calendar time, units = hours */
+#define CLIMO_DAY    1		/* climatology time, units = day in year */
+#define CLIMO_WEEK   2		/* climatology time, units = week in year */
+#define CLIMO_MONTH  3		/* climatology time, units = month in year */
+#define CLIMO_SEASON 4		/* climatology time, units = season in year */
+
+typedef struct {		/* date structure */
+   int year;			/* year number since 0 BC */
+   int month;			/* month number in year */
+   int day;			/* day number in month */
+   int type;			/* time coordinate type, default time type */
+				/* is calendar time 			   */
+} DATE;
+
+typedef struct {		/* info from table as_band */
+    long   chan_num;		/* channel number within sensor */
+    char   band_name[31];	/* name of band */
+    long   bit_cnt;		/* count of bits in pixel */
+    float  scl_fctr;		/* scaling factor */
+    float  reference;		/* reference value */
+    char   unit_name[31];	/* name of physical units */
+} AS_BAND;
+
+typedef struct {		/* info from tables grid_reg_geom/as_reg_im */
+    char   prjn_name[21];	/* projection name */
+    char   stor_dsc[21];	/* (+x in +y)/(+x in -y)/(-y in +x)/etc */ 
+    long   nx;			/* count of columns */
+    long   ny;			/* count of rows */
+    double lat;			/* lat of origin in degrees */
+    double lon;			/* lon of origin in degrees */
+#ifdef OLD_REG_GEOM
+    long orig_ix;		/* column # for origin, left column is 1 */
+    long orig_iy;		/* row # for origin; top row is 1 */
+    float x_int_dis;		/* distance interval between columns in km */
+    float y_int_dis;		/* distance interval between rows in km */
+    float parm_1;		/* geom parm 1, depends on projection */
+    float parm_2;		/* geom parm 2, depends on projection */
+    float parm_3;		/* geom parm 3, depends on projection */
+#else
+    double orig_ix;		/* column # for origin, left column is 1 */
+    double orig_iy;		/* row # for origin; top row is 1 */
+    double x_int_dis;		/* distance interval between columns in km */
+    double y_int_dis;		/* distance interval between rows in km */
+    double parm_1;		/* geom parm 1, depends on projection */
+    double parm_2;		/* geom parm 2, depends on projection */
+    double parm_3;		/* geom parm 3, depends on projection */
+#endif /* OLD_REG_GEOM */
+} REG_GEOM;
+
+typedef struct {		/* info from table as_sat_im */
+    long   bgn_lin_num;		/* beginning line number in orbit or pass */ 
+    long   bgn_smp_num;		/* beginning sample number in scan line */
+    long   lin_int;		/* lin interval relative to sensor scan mode */
+    long   smp_int;		/* smp interval relative to sensor scan mode */
+    float  roll_ang;		/* satellite roll angle in degrees */
+    float  pch_ang;		/* satellite pitch angle in degrees */
+    float  yaw_ang;		/* satellite yaw angle in degrees */
+} SAT_GEOM;
+
+typedef struct {		/* info from table grid_spct_geom */
+    char   stor_dsc[21];	/* (+x in +y)/(+x in -y)/(-y in +x)/etc */ 
+    char   trnc_type[21];	/* spectral truncation type (triangular/etc) */ 
+    long   coef_cnt;		/* count of complex coefficients used */ 
+    long   max_lat_wav_num;	/* max latitudinal wavenumber (M in GRIB) */
+    long   max_lon_wav_num_1;	/* max longitudinal wavenumber 1 (J in GRIB) */
+    long   max_lon_wav_num_2;	/* max longitudinal wavenumber 2 (K in GRIB) */
+} SPCT_GEOM;
+
+typedef struct {		/* info from table sat_oe */
+    char   seq_name[21];	/* orb-elem sequence name */
+    DATE   date;		/* date for orbital elements */
+    double hour;		/* hour of day for orbital elements */
+    double parm_1;		/* orb-elem parm 1 value */
+    double parm_2;		/* orb-elem parm 2 value */
+    double parm_3;		/* orb-elem parm 3 value */
+    double parm_4;		/* orb-elem parm 4 value */
+    double parm_5;		/* orb-elem parm 5 value */
+    double parm_6;		/* orb-elem parm 6 value */
+    double parm_7;		/* orb-elem parm 7 value */
+} ORB_ELEM;
+
+typedef struct {		/* bit-map structure */
+   short lin_cnt;		/* count of lines in bitmap */
+   short smp_cnt;		/* count of samples per line in bitmap */
+   short pad_bit_cnt;		/* count of bits for padding lines in bitmap */
+   short ofst_byte_cnt;		/* byte offset into bitmap array where actual
+				   bitmap data begins */
+   unsigned char *bmap;		/* unsigned char array containing bitmap */
+} BITMAP;
+
+#endif  /* ISDB_INCLUDE */
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/ld_dec_lookup.c b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_dec_lookup.c
new file mode 100644
index 00000000..c5705810
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_dec_lookup.c
@@ -0,0 +1,768 @@
+/*  FILENAME:   ld_dec_lookup.c 
+Revision logs:
+16Jul97 /atn: clear Decoder section of structs only; chg warnings to Stdout;
+*/
+#include 
+#include 
+#include 
+#include "grib_lookup.h"  	/* combined lookup structs */
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*.....................................................
+*  ld_dec_lookup.c defines the following global vars:
+*.....................................................
+*  PARM_DEFN  db_parm_tbl[NPARM*MAX_PARM_TBLS]   Parameter Conversion info
+*  LVL_DEFN   db_lvl_tbl[NLEV]                  Level Conversion info
+*  MODEL_DEFN db_mdl_tbl[NMODEL]                 Model Conversion info
+*  GEOM_DEFN  db_geom_tbl[NGEOM]                 Geom Conversion info
+*              
+*/
+PARM_DEFN   db_parm_tbl [NPARM*MAX_PARM_TBLS];/* GLOBVAR parm conversion info*/
+LVL_DEFN    db_lvl_tbl [NLEV];    /* GLOBVAR level conversion info */
+MODEL_DEFN  db_mdl_tbl [NMODEL];  /* GLOBVAR model conversion info */
+GEOM_DEFN   db_geom_tbl [NGEOM];  /* GLOBVAR Geom conversion info */
+
+/*
+**********************************************************************
+* A.  FUNCTION:      ld_dec_lookup
+*        This function reads in the information from an external Lookup
+*        table (ie: g1tab_2.1).  This info is used to convert
+*        from the Database's parameter names to the GRIB Code Numbers.
+*
+*    INTERFACE:
+*       int ld_dec_lookup (lookup_fn,  errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *lookup_fn
+*           Name of Lookup file to read from (ie:  /abspath/g1tab_128_2.1)
+*      (O)  char *errmsg
+*           empty array, returned filled if error occurred;
+*
+*     RETURN CODE:
+*        0>  successful, the 4 database tables Filled;
+*        1>  file open error or got error/eof while reading;  errmsg filled;
+**********************************************************************
+*
+-    REQUIREMENTS:  *** do not use the TAB character !!! ***
+-     Rules for creating Decoder Lookup file:
+-     a)  lines starting out with  '#' is Comment lines & are skipped;   
+-     b)  the tables within the file are defined in this order:
+-         'GRIB Table 2',
+-         'GRIB Table 2 - Sub A',
+-         'GRIB Table 2 - Sub B',
+-         'GRIB Table 2 - Sub C',
+-         'GRIB Table 2 - Sub D',
+-         'GRIB Table 2 - Sub E',
+-         'GRIB Table 3: Level Definitions',
+-         'GRIB Table - Generating Process Definitions (Octet 6 of PDS)',
+-         'GRIB Table - Pre-defined geometries (Octet 7 of PDS)'
+-     c)  Each Header section MUST start out with "GRIB Table";
+-         All Header Section except that of the LEVEL tbl MUST end with a line 
+-         containing atleast 4 consecutives '=';
+-     e)  Header lines are any number of lines before the '===' line which is
+-         considered as a the last line of this section's Header;
+-     f)  the Parameter defn (Table 2 & subTables) must have at least 2 spaces
+-         between the Field Parameter and Unit fields;
+-
+-     While getting entries for current table, the program assumes it has
+-     gotten to the end of current Table if Hdr SEction for next Table 
+-     (string "GRIB Table").
+*/
+
+#if PROTOTYPE_NEEDED
+int  ld_dec_lookup ( char *lookup_fn, char *errmsg)
+#else
+int  ld_dec_lookup ( lookup_fn, errmsg)
+		     char *lookup_fn; 
+		     char *errmsg;
+#endif
+{
+  FILE  *infile;
+  char  *func="ld_dec_lookup", line[200], temp[200], dummy;
+  char  *ptr2, *ptr, strGribCode[50], grib_dsc[150], grib_unit_dsc[150]; 
+  char  strScale[50], strOffset[50], strDSF[50];
+  char  lvl_name_1[150], lvl_name_2[150];
+  int   LineRead, indx, sub, stat=1, num, cnt, iOctets;
+  char  strOctets[30];  
+  int	GribCode;
+  PARM_DEFN *parmptr;	/* ptr to cell w/in Parm array */
+
+  DPRINT1 ("Entering %s\n", func);
+/*
+* A.0       CLEAR out all the lookup arrays's decoder part
+*/
+  for (num=0; num < NPARM ; num++) {
+	db_parm_tbl[num].usParm_id=  num;
+	db_parm_tbl[num].usParm_sub= 0;       /* not used for main tbl */
+	db_parm_tbl[num].grib_dsc[0] ='\0';
+	db_parm_tbl[num].grib_unit_dsc[0] ='\0';
+	}
+  for (num=NPARM; num < NPARM * MAX_PARM_TBLS; num++) {  /* for sub-tbls */
+	db_parm_tbl[num].usParm_id=  249 + num / NPARM;
+	db_parm_tbl[num].usParm_sub= num % NPARM;
+	db_parm_tbl[num].grib_dsc[0] ='\0';
+	db_parm_tbl[num].grib_unit_dsc[0] ='\0';
+	}
+
+  for (num=0; num < NLEV; num++) {
+        db_lvl_tbl[num].usLevel_id =  num;
+	db_lvl_tbl[num].grib_dsc[0] = '\0';
+	db_lvl_tbl[num].lvl_name_1[0] = '\0';
+	db_lvl_tbl[num].lvl_name_2[0] = '\0';
+	db_lvl_tbl[num].num_octets = 0;
+	}
+
+  for (num=0; num < NMODEL; num++) {
+	db_mdl_tbl[num].usModel_id  = num;
+	db_mdl_tbl[num].grib_dsc[0] = '\0';
+	}
+
+  for (num=0; num < NGEOM; num++) {
+	db_geom_tbl[num].usGeom_id  = num;
+	db_geom_tbl[num].grib_dsc[0] = '\0';
+	}
+
+/*
+*
+* A.1       OPEN Lookup file for reading
+*           RETURN 1 if fails;
+*/
+  infile = fopen(lookup_fn, "r");
+  if (infile==NULL) { 
+	DPRINT2 ("%s:  failed to open %s\n", func, lookup_fn);
+	sprintf (errmsg ,"%s:  failed to open %s\n", func, lookup_fn);
+	goto BYE;
+	}
+  DPRINT1 ("Loading Decoder file= '%s'\n", lookup_fn);
+
+/**** PARM SECTION (TABLE 0/A/B/C/D/E) ***
+ To be loaded continuously where Main tbl range is 0-255, B is 256-511, ...
+Sample:
+   GRIB Table 2
+   Code Figure    Field Parameter                                       Unit
+   ===========    ===============                                       ====
+   000            Reserved                                              *
+   001            Pressure                                              Pa
+   002            Pressure reduced to MSL                               Pa
+   003            Pressure tendency                                     Pa/s
+   #####################################################################
+   GRIB Table 2 - Sub A
+   Code Figure    Field Parameter                                       Unit
+   ===========    ===============                                       ====
+   ######################################################################
+   GRIB Table 2 - Sub B
+   Code Figure    Field Parameter                                       Unit
+   ===========    ===============                                       ====
+   ######################################################################
+   GRIB Table 2 - Sub C
+   Code Figure    Field Parameter                                       Unit
+   ===========    ===============                                       ====
+   ######################################################################
+   GRIB Table 2 - Sub D
+   Code Figure    Field Parameter                                       Unit
+   ===========    ===============                                       ====
+   ######################################################################
+
+*
+*           *** Parameter Conversion info ***
+* A.2       FOR (each Parameter Table/subTable to load) DO
+*/
+ LineRead = 0;
+ for (sub=0; sub < 6; sub++)   { /* 6 Parm tables altogether (0/A/B/C/D/E) */
+/*
+* A.2.1       CALCULATE the index offset for this Table within the Parm array
+*/
+     indx = sub * 256; 
+
+/*
+* A.2.2       KEEP reading until end of comment line (line with '====')
+*             RETURN error if fails
+*/
+     /* Read until last of Header line */
+     for (line[0]='\0'; ! strstr(line,"====") ; ) 
+     {
+       fgets(line, sizeof(line), infile);  ++LineRead;
+       if (feof(infile) || ferror(infile)) 
+         { sprintf(errmsg,
+	   "%s: got EOF/ERROR before PARM TABLE #%d info (Line %d in %s)\n", 
+	    func, sub, LineRead, lookup_fn);
+	   goto BYE;
+         }
+      }
+
+/*
+* A.2.3       FOR (successfully read a line from file) DO
+*                LOOP if it's a comment line
+*                BREAK out if already got to next Section (see "GRIB Table")
+*                DROP line if it's a empty line
+*/
+  DPRINT2("*** %s: Start reading Tbl2- sub#%d ***\n", func, sub);
+  for (cnt=0 ; fgets(line, sizeof(line), infile)!=NULL; ) 
+    { 
+        ++LineRead;
+       /* skip additional comments,  Break if already got to next Table Defn,
+	else replace tabs with spaces, newlines with null 
+       */
+	for (ptr=line; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+        if (strstr(line, "GRIB Table ") != NULL) break;  /* END OF CURR SECT */
+        while (ptr=strchr(line,'\t')) *ptr=' '; 
+        if (ptr=strchr(line,'\n')) *ptr='\0'; 
+/*
+*                EXTRACT line partially  !Parmid, 1st word of Description
+*                DROP line out if extraction fails;
+*                DROP line if parmid is invalid or out or range
+*                >> Note: valid parm id range is 0-255 for main table, 
+*                1-255 for sub tables.
+*/
+	/* DO a partial read, get parm_id and 1st word of Description */
+    	if ((num=sscanf (line,"%s%s", strGribCode, temp )) !=2) {
+	    if (num>0) fprintf(stdout,
+	    "Warning: drop incomplete %s Line %d\n" ,lookup_fn, LineRead); 
+	     continue;
+	  }
+
+       /* Make sure Parmid field has a Number */
+       if (strspn (strGribCode, "0123456789") != strlen(strGribCode)) {
+	   fprintf(stdout,"Warning: Invalid Parmid '%s', drop line#%d in %s\n", 
+	   strGribCode, LineRead, lookup_fn);
+	   continue; }
+
+       GribCode =  atoi(strGribCode);
+       /* check if id is out of range */
+       if (GribCode < 0 || GribCode >= NPARM) {
+	   fprintf(stdout, 
+	   "Warning: Parm id '%d' out of range, drop %s:Line %d\n",
+	   GribCode, lookup_fn, LineRead); continue; }
+
+       /* 
+	  Can only have Parm code 0 in Main table;
+	  Donot load if parm is 0 and this is a Sub table;
+	*/
+       if (GribCode == 0 && sub!=0) {
+	   fprintf(stdout,
+	   "Warning: cannot have Gribcode 0 in Sub-tables, drop %s:Line %d\n",
+	   lookup_fn, LineRead); continue; 
+	}
+
+/* 
+*                EXTRACT Grib_Dsc & Grib_Unit_Dsc from line (both multi words)
+*                !these 2 fields must be separated by atleast 2 spaces;
+*                DROP line if cannot find Grib_Dsc/Unit;
+*/
+	/*
+	  Now, get Grib_Desc and Grib_Unit_Dsc fields, both multi words...
+	   TEMP has 1st word of the Grib_Desc;  This field ends when
+	   we see 2 consecutive spaces;
+	   locate Grib_Desc, move max of 75, then cap it where there are
+           4 consecutive spaces 
+	*/
+        if (!(ptr= strstr (line, temp)) || !(ptr2= strstr (ptr, "  ")))
+          { fprintf(stdout, 
+	    "Warning:  cannot find Grib_Dsc, drop line#%d in %s\n",
+	    LineRead, lookup_fn); continue;
+	  }
+        strncpy (grib_dsc, ptr, ptr2-ptr); /*sizeof(grib_dsc)-1); */
+	grib_dsc[ptr2 - ptr] = '\0';
+
+	/* Grib_Dsc now contains both "Desc & Unit", find where Unit begins
+	   (look for 2 consecutive spaces) then put null terminator to cap
+	   off Grib_Dsc 
+        if ((ptr= strstr (grib_dsc, "  ")) == NULL)
+	*/
+
+	while (*ptr2==' ') ptr2++;
+	if (! *ptr2) 
+          { fprintf(stdout, "Warning: cannot find Unit, drop Line %d in %s\n" , 
+	    LineRead, lookup_fn);
+	    continue;
+	  }
+	else strcpy (grib_unit_dsc, ptr2);
+	for (ptr=grib_unit_dsc + strlen(grib_unit_dsc)-1; *ptr==' '; ptr--)
+		*ptr='\0';   /* remove ending spaces */
+
+/*	
+        *ptr= '\0';    	/# cap off GribDsc, where delimitor begins #/
+	for (ptr= grib_unit_dsc+strlen(grib_unit_dsc) -1; 
+	     *ptr=='\n' || *ptr == ' '; --ptr)
+	    *ptr='\0';		/# rm ending spaces in Unit #/
+*/
+	
+      
+/*
+*                DROP defn if this parmid is already defined;
+*/
+      parmptr =  db_parm_tbl + indx + GribCode;
+      if (parmptr->grib_dsc[0] != '\0') { 
+         fprintf(stdout,
+         "Warning: duplic Parm defn #%d (Index=%d), drop line %d in %s\n",
+         GribCode, PARMTBL_INDX (parmptr->usParm_id, parmptr->usParm_sub),
+	 LineRead, lookup_fn);
+         continue;
+       }
+/*
+*                STORE info in the array cell whose index is 'parm_id'
+*                !undefined parm ids are all set to zero;
+*/
+      /* depending on which Table Code it is, entry will be stored in
+	 its corresponding Parameter Range;  
+	 >>> ENTRIES ARE STORED IN ARRAY CELL WHOSE INDEX IS 'PARM_ID'
+         >>> UNDEFINED IDS WILL HAVE CELL WITH EMPTY DEFNS;
+      */
+      /* Store entry just read in Parm Defn Array */
+
+      if (sub == 0) { /* Main Table only */
+	      parmptr->usParm_id = (unsigned short)GribCode;
+	      parmptr->usParm_sub = 0;
+	   }
+      else {	/* for all Sub-Tables (non-zero sub) */
+	      parmptr->usParm_id = sub + 249;  /* range 250 to 254 only */
+	      parmptr->usParm_sub = (unsigned short)GribCode;
+	   }
+      strcpy (parmptr->grib_dsc, grib_dsc);
+      strcpy (parmptr->grib_unit_dsc, grib_unit_dsc);
+
+      DPRINT7(
+	"(+D) T2-%d cd=%d: Parm=%d, ParmSub=%d, INDX=%d, Dscr='%s' Unit='%s'\n"
+	,sub, GribCode,
+	parmptr->usParm_id, parmptr->usParm_sub, indx+GribCode,
+	parmptr->grib_dsc, parmptr->grib_unit_dsc);
+
+      ++cnt;    /* keep track of #entries loaded */
+/*
+* A.2.3       ENDFOR 
+*/
+   }
+   DPRINT2 ("Parameter table#%d has %d entries\n", sub, cnt);
+
+/*
+* A.2       ENDFOR   !load all 6 Parameter tables
+*/
+} /* load all 6 parm tables */
+  
+
+/******** GRIB's LEVEL TABLE *******
+Sample:
+   ######################################################################
+   GRIB Table 3: Level Definitions
+   Line 1: Level ID | Number of Octets | Meaning
+   Line 2: Contents of octet 11 (optional)
+   Line 3: Contents of octet 12 (optional)
+   001  0  Ground or water surface
+   002  0  Cloud base level
+   ...
+   100  2  Isobaric surface
+   Pressure in hPa
+   ...
+   101  1  Layer between two isobaric surfaces
+   Pressure of top in kPa
+   Pressure of bottom in kPa
+   ######################################################################
+
+*
+*           *** Level Conversion info ***
+* A.3       LOOP until last line of comments ("Line3:" or "====");
+*           RETURN error if fails
+*/
+
+  DPRINT1 ("*** %s: Start reading Level Defns  ***\n", func);
+  /* Read until the last line of Comments */
+  for (line[0]='\0'; ! strstr(line,"====") && ! strstr(line,"Line 3:") ; ) 
+  {
+    fgets(line, sizeof(line), infile); 
+    ++LineRead;
+    if (feof(infile) || ferror(infile)) 
+      { sprintf(errmsg,
+	"%s: got EOF/ERROR before loading LEVEL info (Line %d in %s)\n",
+	func, LineRead, lookup_fn);
+	goto BYE;
+      }
+   }
+
+/*
+* A.4       LOOP (successfully read a line from file) DO
+*              SKIP if comment line 
+*              BREAK out of loop if see next section "GRIB Table"
+*/
+  for (cnt=0; fgets(line, sizeof(line), infile) != NULL; )  
+  {
+    ++LineRead;
+    /* skip additional comments,  Break if already got to next Table Defn,
+	else replace tabs with spaces, newlines with null 
+    */
+    for (ptr=line; *ptr==' '; ptr++); if (*ptr == '#') continue;  
+    if (strstr(line, "GRIB Table ") != NULL) break; /* end of CURR SECT */
+     while (ptr=strchr(line,'\t')) *ptr=' '; 
+     if (ptr=strchr(line,'\n')) *ptr='\0'; 
+
+/*
+*              EXTRACT next GRIB's Level info into Level Array:
+*              DROP line if extraction fails;
+*              ! line 1 format:  lvl id, #octets and Level_description
+*              DROP line if level_id is invalid or out of range
+*              DROP line if unable to extract level description 
+*/
+    /* --- Read Line 1 of Level:  frmt=  (Lvlid #octs  Multiwords Dscr) --*/
+    if ((num= sscanf (line, "%s%s%s", strGribCode, strOctets, temp))!= 3) {
+	 if (num>0) fprintf(stdout,
+	"Warning: dropping incomplete Level defn (%s:Line %d)\n",
+	lookup_fn,LineRead); 
+	 continue;
+	}
+	
+    /* Make sure Parmid field has a Number, and is within Range  */
+    if (strspn (strGribCode, "0123456789") != strlen(strGribCode)) {
+	   fprintf(stdout,"Warning: Invalid Levelid '%s', drop Line=%d in %s\n",
+	   strGribCode, LineRead, lookup_fn); 
+	   continue; }
+    else GribCode =  atoi(strGribCode);
+
+    if (GribCode < 0 || GribCode >= NLEV) {
+	 fprintf(stdout, 
+	 "Warning: Level Gribcode '%d' out of range, drop (Line %d in %s)",
+	 GribCode, LineRead, lookup_fn); 
+	 continue; 
+	}
+
+    /* Make sure #Octets field has a Number, and is within Range */
+    if (strspn (strOctets, "0123456789") != strlen(strOctets)) {
+	   fprintf(stdout,
+	   "Warning:  Invalid NumOctets '%s' for Lvl %d, drop line#%d in %s\n", 
+	   strOctets, GribCode, LineRead, lookup_fn); 
+	   continue;
+	}
+    else iOctets = atoi(strOctets);
+    if (iOctets < 0 || iOctets > 2) {
+	   fprintf(stdout,
+	   "Warning: Octets '%d' out of range (0-2 only), drop Line %d in %s\n",
+	   iOctets, LineRead, lookup_fn); 
+	   continue; 
+	}
+
+    /* TEMP here has 1st word of Lvl Descr, need to get rest of it */ 
+        if ((ptr= strstr (line, temp)) == NULL)
+          { fprintf(stdout,
+	   "Warning:   Cannot find Lvl_Dsc, drop line#%d in %s\n",
+	     LineRead, lookup_fn);
+            continue;
+	  }
+
+        strncpy (grib_dsc, ptr, sizeof(grib_dsc)-1); 
+ 	if (ptr=strstr(grib_dsc,"  ")) *ptr='\0'; /* rm trail blanks */
+/*
+*              IF (0 #octets)
+*                 SET lvl_name_1 and _2 to null;
+*              ELSE if (1 #octets)
+*                 READ in 2 more lines   !for lvl_name_1 & lvl_name_2
+*              ELSE  !2 octets
+*                 READ in 1 more line    !for lvl_name_1
+*                 SET lvl_name_2 to null;
+*              ENDIF
+*/
+    /* --- Get Optional Lvl_1 and Lvl_2 lines, depneding on #octs */
+    switch (iOctets) {
+        case 0:  lvl_name_1[0]= '\0'; lvl_name_2[0]= '\0';break;
+	case 1:  if (!fgets(lvl_name_1, sizeof(lvl_name_1), infile) ||
+		     !fgets(lvl_name_2, sizeof(lvl_name_2), infile)) {
+		    fprintf(stdout,
+		    "Warning: failed to get LvlName1/LvlName2; "
+		    "drop Level %d defn (Line#%d in %s)\n",
+		    GribCode, LineRead,  lookup_fn); 
+		    continue;
+		  }
+    		 LineRead += 2; break;
+	case 2:  if (!fgets(lvl_name_1, sizeof(lvl_name_1), infile) )
+		  { 
+		    fprintf(stdout,
+		    "Warning: failed to get LvlName1; "
+		    "drop Level %d defn (Line#%d in %s)\n",
+		    GribCode, LineRead,  lookup_fn); 
+		    continue;
+		  }
+		 lvl_name_2[0]='\0'; ++LineRead; break;
+         }
+
+   /* replace tabs w/space, replace Newline with Null terminator,
+      and  rm trail blanks ;
+   */
+   if (lvl_name_1[0]) {
+	 while (ptr=strchr(lvl_name_1,'\t')) *ptr=' '; 
+	if (ptr=strchr(lvl_name_1,'\n')) *ptr='\0'; 
+	if (ptr=strstr(lvl_name_1,"  ")) *ptr='\0'; 
+	}
+   if (lvl_name_2[0]) {
+	 while (ptr=strchr(lvl_name_2,'\t')) *ptr=' '; 
+	if (ptr=strchr(lvl_name_2,'\n')) *ptr='\0'; 
+	if (ptr=strstr(lvl_name_2,"  ")) *ptr='\0'; 
+	}
+
+/*
+*              DROP defn if this ID has already been defined;
+*/ 
+    if (db_lvl_tbl[GribCode].grib_dsc[0] != '\0') {
+        fprintf(stdout,
+        "Warning: drop duplic Level %d defn, currently at line %d in %s\n",
+	GribCode, LineRead, lookup_fn);
+	continue;
+    }
+
+/*
+*              STORE all this info into Level Array cell whose index
+*              equals the Level_id
+*/
+    db_lvl_tbl[GribCode].usLevel_id  = (unsigned short)GribCode;
+    strncpy (db_lvl_tbl[GribCode].grib_dsc, grib_dsc, 
+	    sizeof(db_lvl_tbl[GribCode].grib_dsc)-1);
+    db_lvl_tbl[GribCode].num_octets  = iOctets;
+    strncpy (db_lvl_tbl[GribCode].lvl_name_1, lvl_name_1, 
+	    sizeof(db_lvl_tbl[GribCode].lvl_name_1)-1);
+    strncpy (db_lvl_tbl[GribCode].lvl_name_2, lvl_name_2, 
+	    sizeof(db_lvl_tbl[GribCode].lvl_name_2)-1);
+
+/*
+*              DEBUG print
+*/
+    switch (iOctets) {
+     case 0:
+        DPRINT3("(+D) Lvl=%d Dsc='%s' %d octs\n",
+	db_lvl_tbl[GribCode].usLevel_id,
+	db_lvl_tbl[GribCode].grib_dsc,
+	db_lvl_tbl[GribCode].num_octets);break;
+     case 1:
+      DPRINT5(
+	"(+D) Lvl=%d Dsc='%s' %d octs\n     Name1='%s'\n     Name2='%s'\n",
+	db_lvl_tbl[GribCode].usLevel_id,
+	db_lvl_tbl[GribCode].grib_dsc,
+	db_lvl_tbl[GribCode].num_octets,
+	db_lvl_tbl[GribCode].lvl_name_1,
+	db_lvl_tbl[GribCode].lvl_name_2);break;
+     case 2:
+        DPRINT4 ("(+D) Lvl=%d Dsc='%s'  %d octs\n     Name1='%s'\n",
+	db_lvl_tbl[GribCode].usLevel_id,
+	db_lvl_tbl[GribCode].grib_dsc,
+	db_lvl_tbl[GribCode].num_octets,
+	db_lvl_tbl[GribCode].lvl_name_1);break;
+     }
+	 
+    ++cnt;  /* number loaded */
+/*
+* A.4       ENDFOR !Level defns
+*/
+  }
+  DPRINT1 ("Level table has %d entries\n", cnt);
+
+
+/*** GRIB MODEL TABLE***
+Sample:
+	######################################################################
+	GRIB Table - Generating Process Definitions (Octet 6 of PDS)
+	Code Figure    Model Name
+	===========    ==========
+	001            NORAPS
+	002            COAMPS
+	003            NOGAPS
+*
+*           *** Model Conversion info ***
+* A.5       WHILE (line is comment or header line) skip line;
+*           RETURN error if fails
+*/
+  DPRINT1 ("*** %s: Start reading Model Defns  ***\n", func);
+  /* Read until the last line of Comments */
+  for (line[0]='\0'; ! strstr(line,"====") ; ) 
+  {
+    fgets(line, sizeof(line), infile); ++LineRead;
+    if (feof(infile) || ferror(infile)) 
+      { sprintf(errmsg,
+	"%s: got EOF/ERROR before loading MODEL info %s Line %d\n", 
+	func, lookup_fn, LineRead);
+	goto BYE;
+      }
+   }
+
+/*
+*
+* A.6       FOR (successfully read a line from file) DO
+*              DROP line if comment
+*              BREAK out if see next section "GRIB Table"
+*/
+  for (cnt=0; fgets(line, sizeof(line), infile)!=NULL; ) 
+   {
+    ++LineRead;
+    /* skip additional comments,  Break if already got to next Table Defn,
+	else replace tabs with spaces, newlines with null 
+    */
+     for (ptr=line; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+     if (strstr(line, "GRIB Table ") != NULL) break; /* end of CURR SECT */
+     while (ptr=strchr(line,'\t')) *ptr=' '; 
+     if (ptr=strchr(line,'\n')) *ptr='\0'; 
+/*
+*              EXTRACT from line the GRIB's Model info ;
+*              DROP line if extraction fails;
+*              ! frmat:    model_name model_id;
+*              DROP line if modelid is invalid or out of range
+*/
+     if ((num= sscanf (line, "%s%s", strGribCode, temp))  !=2) {
+	 if (num > 0) fprintf(stdout,
+	"Warning: Drop incomplete Model line %d in %s\n", LineRead, lookup_fn); 
+	 continue;
+	}
+     if (strspn (strGribCode, "0123456789") != strlen(strGribCode)) {
+	   fprintf(stdout,"Warning:  Invalid Level '%s', drop line=%d in %s\n", 
+	   strGribCode, LineRead, lookup_fn); 
+	   continue; 
+	}
+     else GribCode =  atoi(strGribCode);
+
+     if (GribCode < 0 || GribCode >= NMODEL) {
+	 fprintf(stdout,
+	 "Warning: Model '%d' out of range, drop %s Line %d\n",
+	 GribCode, lookup_fn, LineRead); 
+	 continue; 
+	}
+
+/*
+*              DROP line if this model is already defined
+*/
+     if (db_mdl_tbl[GribCode].grib_dsc[0] != '\0') { 
+               fprintf(stdout, 
+		"Warning: duplic Model#%d defn , drop (%s Line %d)\n",
+		 GribCode, lookup_fn, LineRead);
+               continue;
+            }
+/*
+*              STORE model info into model array cell whose index
+*              equals the model_id;
+*/
+     db_mdl_tbl[GribCode].usModel_id = (unsigned short)GribCode;
+     strncpy (db_mdl_tbl[GribCode].grib_dsc, 
+	line+(strstr(line,temp)-line),
+	sizeof(db_mdl_tbl[GribCode].grib_dsc)-1);  /* 1/more words */
+     DPRINT2 ("(+D) Mdl=%d,  Gribdscr=%s\n", 
+     db_mdl_tbl[GribCode].usModel_id, db_mdl_tbl[GribCode].grib_dsc);
+     ++cnt;  /* number loaded */
+/*
+* A.6       ENDFOR 
+*/
+   }
+  DPRINT1 ("Model table has %d entries\n", cnt);
+     
+
+/*** GRIB GEOMETRY TABLE*** 
+Sample:
+	######################################################################
+	GRIB Table - Pre-defined geometries (Octet 7 of PDS)
+	Code Figure    Geometry Name
+	===========    =============
+	001            mediterranean_109x82
+	002            persian_gulf_NORAPS_63x63
+	003            global_144x288
+	255            Undefined grid, description in GDS
+*
+*           *** Geometry Conversion info ***
+* A.7       WHILE (line is comment or header line) skip line;
+*           RETURN error if fails
+*/
+
+  DPRINT1 ("*** %s: Start reading Geom Defns  ***\n", func);
+  /* Read until the last line of Comments */
+  for (line[0]='\0'; ! strstr(line,"====") ; ) {
+    fgets(line, sizeof(line), infile); 
+    ++LineRead;
+    if (feof(infile) || ferror(infile)) 
+      { sprintf(errmsg,
+	"%s: got EOF/ERROR before loading GEOM info, %s Line %d\n",
+	func, lookup_fn, LineRead);
+	goto BYE;
+      }
+   }
+
+/*
+* A.8       FOR (successfully read a line from file) DO
+*              DROP line if comment
+*              BREAK out if see next section "GRIB Table"
+*/
+  for (cnt=0; fgets(line, sizeof(line), infile)!=NULL; ) 
+   {
+    ++LineRead;
+    /* skip additional comments,  Break if already got to next Table Defn,
+	else replace tabs with spaces, newlines with null 
+    */
+     for (ptr=line; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+     if (strstr(line, "GRIB Table ") != NULL) break; /* end of CURR SECT */
+     while (ptr=strchr(line,'\t')) *ptr=' '; 
+     if (ptr=strchr(line,'\n')) *ptr='\0'; 
+
+/*
+*              EXTRACT next GRIB's Geometry info into Geometry Array;
+*              DROP line if extraction fails;
+*              !format:  geom_id geom_descr
+*              DROP line if geom_id is invalid or out of range
+*/
+     if ((num= sscanf (line, "%s%s", strGribCode, temp))  !=2) {
+	 if (num > 0) fprintf(stdout,
+	"Warning: drop incomplete Geom line %d in %s\n", LineRead, lookup_fn);
+	 continue;
+	}
+
+     if (strspn (strGribCode, "0123456789") != strlen(strGribCode)) {
+	   fprintf(stdout,"Warning: Invalid Geom_id '%s', drop %s line=%d\n", 
+	   strGribCode, lookup_fn, LineRead); 
+	   continue; }
+     else GribCode =  atoi(strGribCode);
+
+     if (GribCode < 0 || GribCode >= NGEOM) {
+	 fprintf(stdout, "Warning: Geomid '%d' out of range, drop %s Line %d\n",
+	 GribCode, lookup_fn, LineRead); 
+	 continue; 
+	}
+
+/*
+*              DROP line if geom_id is already defined
+*/
+     if (db_geom_tbl[GribCode].grib_dsc[0] != '\0') { 
+               fprintf(stdout, "Warning: duplic GeomID=%d, drop %s line %d\n",
+		GribCode,  lookup_fn, LineRead);
+               continue;
+            }
+/*
+*              STORE this geom info into array cell whose index
+*              equals the geom_id;
+*/
+     db_geom_tbl[GribCode].usGeom_id = (unsigned short)GribCode;
+     strncpy (db_geom_tbl[GribCode].grib_dsc, 
+	line+(strstr(line,temp)-line),
+	sizeof(db_geom_tbl[GribCode].grib_dsc)-1);  /* 1/more words */
+
+     ++cnt;  /* number loaded */
+     DPRINT2("(+D) Geom=%d,  Gribdscr=%s\n", 
+     db_geom_tbl[GribCode].usGeom_id, db_geom_tbl[GribCode].grib_dsc);
+/*
+* A.8       ENDFOR 
+*/
+   }
+  DPRINT1 ("Geometry table has %d entries\n", cnt);
+
+/*
+* 
+* A.9      SET status to 0 !success
+*/
+  stat=0;
+
+/*
+*
+* A.10     CLOSE Lookup file;
+*/
+BYE:
+  if (infile) fclose(infile);
+  DPRINT2 ("Leaving %s, stat=%d\n", func,stat);
+/*
+*
+* A.11     RETURN with status
+*/
+  return (stat);
+/*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_input.c b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_input.c
new file mode 100644
index 00000000..b8a91192
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_input.c
@@ -0,0 +1,699 @@
+/*
+file:  ld_enc_input.c   (Ld_enc_config, Ld_enc_ieeeff, Ld_enc_ffinfo)
+Original version from previous Encoder Library;
+Revisions:
+10/28/96 by Alice T. Nakajima, SAIC
+	replaced hard-coded $CONFIG_PATH[]/input.dat, 
+	now passes in the name of the file (with absolute path)
+	to ld as well as the Usr Input struct;
+*/
+#include 
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*********************************************************************
+* A. FUNCTION:  ld_enc_config
+*      fill struct holding user's input from config_fn that
+*      is passed in by user
+*
+*    INTERFACE:
+*      int     ld_enc_config (config_fn, User_Input, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *config_fn;         name of file to load from;
+*      (O)  USER_INPUT *User_Input;  filled with data read from file;
+*      (O)  char *errmsg             returned filled if error occurred;
+*
+*    RETURN CODE:   
+*       0>  success, file is read and closed, user_input is filled 
+*       1>  error opening file;  errmsg filled;
+*       2>  failed to get all expected arguments; errmsg filled;
+*       3>  ferror in file; errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int  ld_enc_config (char *config_fn, USER_INPUT *User_Input, char *errmsg)
+#else
+int  ld_enc_config (config_fn, User_Input, errmsg)
+		char *config_fn; USER_INPUT *User_Input; char *errmsg;
+#endif
+{
+/* 
+*
+* A.1       DEFAULT to error stat=1;
+*/
+  char		 *func="ld_enc_config"; /* name of Func */
+  char           temp[100], dummy[100], line[200], *p1;  
+  int		 stat= 1;
+  int		 linenum=1;  /* number of lines got from the files */
+  int            num_expected= 9;  /* expecting 9 args from file */
+  FILE           *infile;   /* user input file */
+
+  DPRINT1 ("Entering %s\n", func);
+/*
+*
+* A.2       OPEN Encoder Config file for reading
+*/
+  infile = fopen(config_fn, "r");
+  if (infile==NULL) { 
+	DPRINT2 ("%s: Failed to open %s\n", func,config_fn);
+	sprintf (errmsg,"%s: Failed to open %s\n", func,config_fn);
+	goto BYE;  
+	}
+
+  DPRINT2 ("loading %d args from file:\n'%s'\n", num_expected, config_fn);
+
+/*
+*
+* A.3       WHILE (still more lines AND no error yet) DO
+*/          
+  while (!feof(infile) && !ferror(infile)) 
+  {
+/*
+* A.3.1        GET a line from the file, quit loop if failed;
+*              !format:   value  opt_comments
+* A.3.2        IF line is empty OR is a comment, Loop again;
+*/          
+        if (fgets (line, sizeof(line)-1, infile) == NULL)  break;
+	for (p1=line; *p1 && (iscntrl(*p1)|| isspace(*p1)); p1++);
+	if (p1==NULL || *p1=='#') continue;
+/*
+* A.3.3        EXTRACT first non-space argument
+*              IF (fails)  QUIT;
+*              ELSE convert argument into a number
+*/
+        if (sscanf (line, "%s%s", temp, dummy) < 1) {
+          DPRINT1 ( "%s:  failed to extract 1 arg from line\n", func);
+          sprintf (errmsg, "%s:  failed to extract arg from line:\n%s", 
+	  func, line); 
+	  break; 
+	  }
+
+	DPRINT2("  case %d, data=%s:  ", linenum, temp);
+
+/*
+* A.3.4        SWITCH (what line number we're on)
+*              ... USER_INPUT info ...
+*                  line  1:  fill User_Input->chCase_id
+*                  line  2:  fill User_Input->usParm_tbl
+*                  line  3:  fill User_Input->usSub_tbl, ->usZero (oct26)
+*                  line  4:  fill User_Input->usCenter_id
+*                  line  5:  fill User_Input->usCenter_sub
+*                  line  6:  fill User_Input->usTrack_num
+*                  line  7:  if 1, set (0x80) bit of User_Input->usGds_bms_id
+*                  line  8:  if 1, set (0x40) bit of User_Input->usGds_bms_id
+*                  line  9:  filll User_Input->usBit_pack_num
+*                  else   :  print skip line msg
+*              ENDSWITCH
+*/
+
+        switch (linenum++) {
+
+	/* USER_INPUT info: */
+         case  1: User_Input->chCase_id= temp[0]; 
+		  P_CHAR (User_Input->chCase_id); break;
+         case  2: User_Input->usParm_tbl= (unsigned short)atoi(temp); 
+		  P_USHORT (User_Input->usParm_tbl); break;
+         case  3: User_Input->usSub_tbl= (unsigned short)atoi(temp);
+		  P_USHORT (User_Input->usSub_tbl ); break;
+         case  4: User_Input->usCenter_id= (unsigned short)atoi(temp);
+		  P_USHORT (User_Input->usCenter_id ); break;
+         case  5: User_Input->usCenter_sub= (unsigned short)atoi(temp);
+		  P_USHORT (User_Input->usCenter_sub ); break;
+         case  6: User_Input->usTrack_num= (unsigned short)atoi(temp);
+		  P_USHORT (User_Input->usTrack_num ); break;
+         case  7: if (atoi(temp)) 
+		  User_Input->usGds_bms_id=0x80; 
+		  P_USHORT (User_Input->usGds_bms_id ); break;
+         case  8: if (atoi(temp)) 
+		  User_Input->usGds_bms_id +=(unsigned short)0x40;
+		  P_USHORT (User_Input->usGds_bms_id ); break;
+         case  9: User_Input->usBit_pack_num= (unsigned short)atoi(temp);
+		  P_USHORT (User_Input->usBit_pack_num ); break;
+         default: fprintf(stdout,
+		  "%s Warning: excess line from Configfile skipped=\n%s\n", 
+		  func, line); 
+		  break;
+	 }
+/*
+* A.3       ENDWHILE !more to read
+*/
+    } /* while */
+
+/*
+*
+* A.4       IF (got a reading error) THEN
+*              RETURN Stat 3
+*           ENDIF 
+*/
+  if (ferror(infile))  {
+        DPRINT1 ( "%s:  got ferror(infile)\n", func);
+        sprintf(errmsg, "%s: got ferror(infile)\n", func);
+	stat=3; 
+	}
+
+/*
+*
+* A.5       CLOSE the input file
+*/
+  if (infile) fclose (infile);
+
+/*
+*
+* A.6       IF (only received less than #required arguments) THEN
+*               PRINT warning
+*           ELSE
+*               CHANGE return status to no errors
+*           ENDIF
+*/
+  if (linenum-1 < num_expected) 
+    {
+     DPRINT4 ("%s: failed to load %s (%d/%d)\n", 
+     func, config_fn, linenum-1, num_expected);
+     sprintf(errmsg, "%s: failed to load %s (%d/%d)",
+     func, config_fn, linenum-1, num_expected);
+     stat= 2;
+     }
+  else  stat = 0;
+
+/*
+*
+* A.7       RETURN with stat
+*/
+BYE:
+  DPRINT2 ("Leaving %s, stat=%d;\n", func,stat);
+  return (stat);
+/*
+*
+* END OF FUNCTION 
+*
+*
+*/ 
+}
+
+/*
+*********************************************************************
+* B. FUNCTION:  ld_enc_ieeeff
+*       load user's pre-malloced float array with data from
+*       binary flat file passed in by user (ie:  FF*);
+*
+*    INTERFACE:
+*       int     ld_enc_ieeeff (ieee_fn, farr, elements, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) char *ieee_fn   name of IEEE Flat file (w/fullpath) to read
+*      (O) float *farr     pre-malloced array to store data from read from file
+*      (I) int elements;   number of float elements to read from file;
+*      (O) char *errmsg    returned filled if error occurred;
+*
+*    RETURN CODE:   
+*       0>  success, file is read and closed, float arr is filled 
+*       1>  error opening file; errmsg filled;
+*       2>  failed to get all expected elements;  errmsg filled;
+*       3>  incoming float array is null;  errmsg filled;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int	ld_enc_ieeeff ( char 	*ieee_fn,
+			float 	*farr,
+			int 	elements,
+			char	*errmsg)
+#else
+int	ld_enc_ieeeff ( ieee_fn, farr, elements, errmsg)
+			char 	*ieee_fn;
+			float 	*farr;
+			int 	elements;
+			char	*errmsg;
+#endif
+{
+/* 
+*
+* B.1       DEFAULT no error stat=0
+*/
+  char		 *func="ld_enc_ieeeff";
+  FILE           *infile= 0;
+  int		 stat= 0;
+
+
+  DPRINT1 ("Entering %s\n",func);
+/* 
+*
+* B.2       IF (float array is null) THEN
+*               SET stat =3
+*                RETURN
+*           ENDIF
+*/
+  if (farr == NULL) {
+	DPRINT1 ("%s:  unexpected null Float array\n", func);
+	sprintf (errmsg,"%s:  unexpected null Float array\n", func);
+	stat = 3; goto BYE;
+	}
+/*
+*
+* B.3       OPEN the IEEE file for reading   !was 'temp.dat'
+*           IF (failed) RETURN err 1;
+*/
+  infile = fopen(ieee_fn, "r");
+  if (infile==NULL) 
+	{ DPRINT2 ("%s: Failed to open %s\n", func,ieee_fn);
+	  sprintf (errmsg,"%s: Failed to open %s\n", func,ieee_fn);
+	  stat = 1; goto BYE;
+	}
+  DPRINT1 ("Read %s\n", ieee_fn);
+
+/*
+*
+* B.4       READ float data from file
+*           IF (didn't get all) THEN
+*              SET status to 2
+*              RETURN
+*           ENDIF
+*/          
+      if ( fread(farr, sizeof(float), elements, infile) != elements)
+        { 
+        DPRINT3 ( "%s: failed to load %s (expecting %d float elements)\n",
+        func, ieee_fn, elements);
+        sprintf(errmsg,"%s: failed to load %s (expecting %d float elements)\n",
+        func, ieee_fn, elements);
+	stat= 2; 
+	}
+      else DPRINT1 ("Number of float elements read = %d\n", elements);
+
+BYE:
+/*
+*
+* B.5       CLOSE the input file 
+*/
+  if (infile) fclose (infile);
+
+/*
+*
+* B.6       RETURN with stat
+*/
+  DPRINT2 ("Leaving %s, stat=%d\n", func,stat);
+  return (stat);
+/*
+*
+* END OF FUNCTION 
+*
+*
+*/ 
+}
+
+/*
+*********************************************************************
+* C.  FUNCTION:  ld_enc_ffinfo
+*      fill DATA_INPUT struct from file whose name is passed in
+*
+*    INTERFACE:
+*      int  ld_enc_ffinfo (ieee_info_fn, Data_Input, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *ieee_info_fn      name of config info file to load
+*      (O)  DATA_INPUT *Data_Input  to be filled with data read from config file
+*      (O)  char *errmsg            filled if error occurred;
+*
+*     RETURN CODE:   
+*       0;  success, file is read and closed, struct is filled 
+*       1:  error opening file; 
+*       2:  failed to get all expected arguments;
+*       3:  Ferror;
+**********************************************************************/
+
+#if PROTOTYPE_NEEDED
+int	ld_enc_ffinfo ( char 		*ieee_info_fn,
+			DATA_INPUT  	*Data_Input,
+			char		*errmsg)
+#else
+int	ld_enc_ffinfo ( ieee_info_fn, Data_Input, errmsg)
+			char 		*ieee_info_fn;
+			DATA_INPUT  	*Data_Input;
+			char		*errmsg;
+#endif
+{
+/* 
+*
+* C.1       DEFAULT to no error stat= 0;
+*/
+  int		 stat= 0;
+  FILE           *infile;   /* user input file */
+  char		 *func="ld_enc_ffinfo";
+  char           temp[100], dummy[100], line[200], *p1;  
+  int		 linenum=1;  /* number of lines got from the files */
+  int            num_expected= 13;  /* expecting 13 args from file */
+  int            mdl_indx, i, iTemp;
+
+  DPRINT1 ("Entering %s\n",func);
+
+/*
+*
+* C.2       OPEN input file for reading
+*/
+  infile = fopen(ieee_info_fn, "r");
+  if (infile==NULL) { 
+	DPRINT2 ("%s: Failed to open %s\n", func,ieee_info_fn);
+	sprintf (errmsg,"%s: Failed to open %s\n", func,ieee_info_fn);
+	stat=1; goto BYE;  
+	}
+
+/*
+*
+* C.3       WHILE (still more lines AND no error yet) DO
+* C.3.1        GET a line from the file, quit loop if failed;
+*              !format:   value  opt_comments
+* C.3.2        IF line is empty OR is a comment, Loop again;
+*/          
+  while (!feof(infile) && !ferror(infile) ) 
+   {
+        if (fgets (line, sizeof(line)-1, infile) == NULL)  break;
+	for (p1=line; *p1 && (iscntrl(*p1)|| isspace(*p1)); p1++);
+	if (p1==NULL || *p1=='#') continue;
+/*
+* C.3.3        EXTRACT arguments from line
+*              IF (fails)  QUIT;
+*              ELSE convert the 2nd argument into an integer 
+*/
+        if ((i=sscanf (line, "%s", temp)) != 1)
+        { 
+	  DPRINT2( "%s:  failed to extract 1 arg reading %s\n", 
+	  func,ieee_info_fn); 
+	  sprintf(errmsg, "%s:  failed to extract 1 arg reading %s\n", 
+	  func,ieee_info_fn); 
+	  break; 
+	}
+	else iTemp = atoi(temp);
+	DPRINT2("  case %d, value=%d:  ", linenum, iTemp);
+
+/*
+* C.3.4        SWITCH (what line number we're on)
+*                  line  1: fill Data_Input->usProc_id field;
+*                  line  2: fill Data_Input->usGrid_id field;
+*                  line  3: fill Data_Input->usParm_id field;
+*                  line  4: fill Data_Input->usParm_sub_id field;
+*                  line  5: fill Data_Input->usLevel_id field;
+*                  line  6: fill Data_Input->nLvl_1 field;
+*                  line  7: fill Data_Input->nLvl_2 field;
+*                  line  8: fill Data_Input->nYear field;
+*                  line  9: fill Data_Input->nMonth field;
+*                  line 10: fill Data_Input->nDay field;
+*                  line 11: fill Data_Input->nHour field
+*                  line 12: fill Data_Input->usFcst_per1 field;
+*                  line 13: fill Data_Input->nDec_sc_fctr field;
+*              ENDSWITCH
+*/
+        switch (linenum++) {
+         case  1: Data_Input->usProc_id = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usProc_id); break;
+         case  2: Data_Input->usGrid_id = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usGrid_id); break;
+         case  3: Data_Input->usParm_id = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usParm_id); break;
+         case  4: Data_Input->usParm_sub_id = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usParm_sub_id); break;
+         case  5: Data_Input->usLevel_id = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usLevel_id); break;
+         case  6: Data_Input->nLvl_1 = iTemp;
+		  P_INT (Data_Input->nLvl_1); break;
+         case  7: Data_Input->nLvl_2 = iTemp;
+		  P_INT (Data_Input->nLvl_2); break;
+         case  8: Data_Input->nYear = iTemp;
+		  P_INT (Data_Input->nYear); break;
+         case  9: Data_Input->nMonth = iTemp;
+		  P_INT (Data_Input->nMonth); break;
+         case 10: Data_Input->nDay = iTemp;
+		  P_INT (Data_Input->nDay); break;
+         case 11: Data_Input->nHour = iTemp;
+		  P_INT (Data_Input->nHour); break;
+         case 12: Data_Input->usFcst_per1 = (unsigned short) iTemp;
+		  P_USHORT (Data_Input->usFcst_per1); break;
+         case 13: Data_Input->nDec_sc_fctr = iTemp;
+		  P_INT (Data_Input->nDec_sc_fctr); break;
+         default: fprintf(stdout,
+		  "%s Warning: excess line from file skipped=\n%s\n", 
+		  func, line); 
+		  break;
+        }
+/*
+* C.3       ENDWHILE !more to read
+*/
+    } /* while */
+
+/*
+*
+* C.4       IF (got a reading error) THEN
+*              RETURN Stat 3
+*           ENDIF 
+*/
+  if (ferror(infile))  {
+        DPRINT1 ( "%s:  got ferror(infile)\n", func);
+        sprintf(errmsg, "%s: got ferror(infile)\n", func);
+	fclose(infile);
+	stat=3; goto BYE;
+	}
+
+/*
+*
+* C.5       CLOSE the input file
+*/
+  fclose (infile);
+
+/*
+*
+* C.6       IF (only received less than #required arguments) THEN
+*               PRINT warning
+*/
+  if (linenum-1 < num_expected) {
+     DPRINT4 ( "%s: failed to load %s (%d/%d)\n",
+     func, ieee_info_fn, linenum-1, num_expected);
+
+     sprintf(errmsg, "%s: failed to load %s (%d/%d)\n",
+     func, ieee_info_fn, linenum-1, num_expected);
+     stat= 2;
+     }
+/*
+*           ELSE 
+*              HARDCODE usFcst_id to 1 (code for Hours)
+*           ENDIF
+*/
+  else {
+     Data_Input->usFcst_id        = 1;    /* Fcst Time Unit default to Hours */
+     DPRINT0("Hard-Code HOURS -> "); P_USHORT (Data_Input->usFcst_id);
+    }
+
+/*
+*
+* C.7       RETURN with stat
+*/
+BYE:
+  DPRINT2 ("Leaving %s(), stat=%d;\n", func, stat);
+  return (stat);
+/*
+*
+* END OF FUNCTION 
+*
+*
+*/ 
+}
+/*
+*********************************************************************
+* D.  FUNCTION:  ld_enc_geomfile
+*       fill GEOM_IN struct from file whose name is passed in.
+*     
+*    INTERFACE:
+*      int     ld_enc_geomfile (geom_fn, Geom_In, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *geom_fn          name of geom info file to load
+*      (O)  GEOM_IN *Geom_In       to hold geom info read from file 
+*      (O)  char  *errmsg          returned filled if error occurred
+*
+*     RETURN CODE:   
+*       0>  success, file is read and closed, struct is filled 
+*       1>  error opening file;  errmsg filled;
+*       2>  failed to get all expected arguments; errmsg filled;
+*       3>  Ferror; errmsg filled;
+**********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int	ld_enc_geomfile (char *geom_fn, GEOM_IN *Geom_In, char	*errmsg)
+#else
+int	ld_enc_geomfile (geom_fn, Geom_In, errmsg)
+			char *geom_fn; 
+			GEOM_IN *Geom_In; 
+			char	*errmsg;
+#endif
+{
+/* 
+*
+* D.1       DEFAULT to no error stat= 0;
+*/
+  int		 i, stat= 0;
+  FILE           *infile;   /* user input file */
+  char		 *func="ld_enc_geomfile";
+  char           temp[100], dummy[100], line[200], *p1;
+  int		 linenum=1;  /* number of lines got from the files */
+  int            num_expected= 15;  /* expecting 15 args from file */
+
+  DPRINT1 ("Entering %s\n",func);
+/*
+*
+* D.2       OPEN input file for reading
+*/
+  infile = fopen(geom_fn, "r");
+  if (infile==NULL) { 
+	DPRINT2 ("%s: Failed to open %s\n", func,geom_fn);
+	sprintf (errmsg,"%s: Failed to open %s\n", func,geom_fn);
+	stat=1; goto BYE;  
+	}
+
+/*
+*
+* D.3       WHILE (still more lines AND no error yet) DO
+* D.3.1        GET a line from the file, quit loop if failed;
+*              !format:   value  opt_comments
+* D.3.2        IF line is empty OR is a comment, Loop again;
+*/          
+  while (!feof(infile) && !ferror(infile) && linenum <= num_expected) 
+  {
+        if (fgets (line, sizeof(line)-1, infile) == NULL)  break;
+	for (p1=line; *p1 && (iscntrl(*p1)|| isspace(*p1)); p1++);
+	if (p1==NULL || *p1=='#') continue;
+/*
+* D.3.3        EXTRACT non-space arguments from line
+*              !format:   value  opt_comments
+*              IF (fails)  set Stat to error 2
+*              ELSE convert the 2nd argument into an integer 
+*/
+        if (sscanf (line, "%s%s", temp, dummy) < 1) {
+          DPRINT3 ("%s:  failed to extract arg from line %d of %s\n", 
+	  func, linenum, geom_fn); 
+          sprintf(errmsg,"%s:  failed to extract arg from line %d of %s\n", 
+	  func, linenum, geom_fn); 
+	  stat=2;
+	  break;
+	}
+
+	DPRINT2("  case %2d val=%10s: ", linenum, temp);
+/*
+* D.3.4        SWITCH (what line number we're on)
+*              ... GEOM_IN info ...
+*                  line  1:  fill Geom_In->prjn_name
+*                  line  2:  fill Geom_In->nx
+*                  line  3:  fill Geom_In->ny
+*                  line  4:  fill Geom_In->x_int_dis
+*                  line  5:  fill Geom_In->y_int_dis
+*                  line  6:  fill Geom_In->parm_1
+*                  line  7:  fill Geom_In->parm_2
+*                  line  8:  fill Geom_In->parm_3
+*                  line  9:  fill Geom_In->first_lat
+*                  line 10:  fill Geom_In->first_lon
+*                  line 11:  fill Geom_In->last_lat
+*                  line 12:  fill Geom_In->last_lon
+*                  line 13:  fill Geom_In->scan
+*              ... More info (previously in file input.dat)...
+*                  line 14:  if 1, set (0x40) bit of Geom_In->usRes_flag
+*                  line 15:  if 1, set (0x08) bit of Geom_In->usRes_flag
+*                  else   :  print skip line msg
+*              ENDSWITCH
+*/
+        switch (linenum++) 
+        {
+	/* ...Geometry info */
+         case  1: strcpy (Geom_In->prjn_name, temp);
+		  P_STRING (Geom_In->prjn_name); break;
+         case  2: Geom_In->nx = (long) atoi(temp);
+		  P_INT (Geom_In->nx); break;
+         case  3: Geom_In->ny = (long) atoi(temp);
+                  P_INT (Geom_In->ny); break;
+         case  4: Geom_In->x_int_dis= (double) atof(temp);
+		  P_DOUBLE (Geom_In->x_int_dis); break;
+         case  5: Geom_In->y_int_dis= (double) atof(temp);
+                  P_DOUBLE (Geom_In->y_int_dis); break;
+         case  6: Geom_In->parm_1= (double) atof(temp);
+		  P_DOUBLE (Geom_In->parm_1); break;
+         case  7: Geom_In->parm_2= (double) atof(temp);
+                  P_DOUBLE (Geom_In->parm_2); break;
+         case  8: Geom_In->parm_3= (double) atof(temp);
+                  P_DOUBLE (Geom_In->parm_3); break;
+         case  9: Geom_In->first_lat= (double) atof(temp);
+		  P_DOUBLE (Geom_In->first_lat); break;
+         case 10: Geom_In->first_lon= (double) atof(temp);
+                  P_DOUBLE (Geom_In->first_lon); break;
+         case 11: Geom_In->last_lat= (double) atof(temp);
+		  P_DOUBLE (Geom_In->last_lat); break;
+         case 12: Geom_In->last_lon= (double) atof(temp);
+                  P_DOUBLE (Geom_In->last_lon); break;
+         case 13: Geom_In->scan= (unsigned short) atoi(temp);
+                  P_USHORT (Geom_In->scan); break;
+
+	/*... Misc. info */
+         case 14: if (atoi(temp)) 
+		  Geom_In->usRes_flag =(unsigned short)0x40;
+		  P_USHORT (Geom_In->usRes_flag ); break;
+         case 15: if (atoi(temp)) 
+		  Geom_In->usRes_flag +=(unsigned short)0x08;
+		  P_USHORT (Geom_In->usRes_flag ); break;
+         default: fprintf(stdout,
+		  "%s Warning: excess line from file skipped=\n%s\n", 
+		  func, line); 
+		  break;
+        }
+/*
+* D.3       ENDWHILE !more to read
+*/
+    } /* while */
+
+/*
+*
+* D.4       IF (got a reading error) THEN
+*              RETURN Stat 3
+*           ENDIF 
+*/
+  if (ferror(infile))  {
+        DPRINT1 ( "%s:  got ferror(infile)\n", func);
+        sprintf(errmsg, "%s: got ferror(infile)\n", func);
+	fclose(infile);
+	stat=3; goto BYE;
+	}
+
+/*
+*
+* D.5       CLOSE the input file
+*/
+  fclose (infile);
+  
+/*
+*
+* D.6       IF (Status is Good ) THEN
+*               IF (received less than #required arguments) PRINT warning
+*           ENDIF
+*/
+  if (stat == 0 ) {
+     if (linenum <= num_expected) {
+        DPRINT3 ( "%s: only loaded %d/%d args into Geom_In\n", 
+        func, linenum-1, num_expected);
+
+        sprintf(errmsg, "%s: only loaded %d/%d args into Geom_In\n", 
+        func, linenum-1, num_expected);
+        stat= 2;
+        }
+     else DPRINT1 ("Got all %d arguments; \n", num_expected);
+   }
+
+/*
+*
+* D.7       RETURN with stat
+*/
+BYE:
+  DPRINT2 ("Leaving %s, stat=%d;\n", func, stat);
+  return (stat);
+/*
+*
+* END OF FUNCTION 
+*
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_lookup.c b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_lookup.c
new file mode 100644
index 00000000..8605aac1
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_enc_lookup.c
@@ -0,0 +1,503 @@
+/* Revision logs:
+16Jul97 /atn:  only clr Encoder section of db tables; chg warning to stdout;
+*/
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include "grib_lookup.h"  	/* combined lookup structs */
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+extern PARM_DEFN   db_parm_tbl[];  /* parm conversion info */
+extern LVL_DEFN    db_lvl_tbl[];   /* level conversion info */
+extern MODEL_DEFN  db_mdl_tbl[];   /* model conversion info */
+extern GEOM_DEFN   db_geom_tbl[];  /* Geom conversion info */
+/*
+****************************************************************************
+* A. FUNCTION: ld_enc_lookup
+*      This function reads in the information from an external Lookup
+*      table used by the GRIB Encoder (ie: neons2grib.tab).  This info 
+*      is used to convert Databse codes to the GRIB Code Numbers.
+*
+*    INTERFACE:
+*      int ld_enc_lookup (lookup_fn, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *lookup_fn;   Name of Lookup file to read from;
+*      (O)  char *errmsg       REturned filled if error occurred;
+*
+*     RETURN CODE:
+*       0>  successful, the following pre-defined arrays required for
+*           encoding GRIB messages are filled=
+*           PARM_DEFN  db_parm_tbl[NPARM * MAX_PARM_TBLS]; (parameter info)
+*           LVL_DEFN db_lvl_tbl[NLEV];      (level info)
+*           MODEL_DEFN db_mdl_tbl[NMODEL];  (model info)
+*           GEOM_DEFN db_geom_tbl[NGEOM];   (geometry info)
+*       1>  file open error or got error/eof while reading;  errmsg filled;
+****************************************************************************
+- only break out of curr Loop if sees next section's header string;
+
+*/
+#if PROTOTYPE_NEEDED
+int ld_enc_lookup ( char *lookup_fn, char *errmsg)
+
+#else
+int ld_enc_lookup ( lookup_fn, errmsg)
+		char *lookup_fn; char *errmsg;
+#endif
+{
+  FILE  *infile;
+  char  *func="ld_enc_lookup";     /* name of function */
+  char  *ptr, temp[200], TableCode, dummy[100]; 
+  int   stat=1, num, LineRead, cnt, code=0, indx0= 0;
+  int   Indx, indxA=0, indxB=0, indxC=0, indxD=0, indxE= 0;
+  int   *indxptr;
+  char	*px;
+  char             achDBsField[30];  /* DBs Field Name                  */
+  char		   strDSF[50],strGribCode[50], strScale[50], strOffset[50];
+  char             subtbl[20];    /* (0:maintbl) or (a/b/c/d/e:subtabl)*/
+  int	GribCode;         /* GRIB Code Number                  */
+  float            fScale;             /* Scale                             */
+  float            fOffset;            /* Offset                            */
+  short            sDSF;               /* DSF                               */
+  PARM_DEFN 	   *parmptr;	       /* ptr to desired cell w/in Parm arr*/
+
+  DPRINT2 ("Entering %s\nlookup %s\n", func, lookup_fn);
+/*
+*
+* A.0       CLEAR out all lookup arrays  ! Encoder section only
+*/
+ for (num=0; num < NPARM ; num++) {
+        db_parm_tbl[num].usParm_id=  num;
+        db_parm_tbl[num].usParm_sub= 0;       /* not used for main tbl */
+        db_parm_tbl[num].db_name[0] = '\0';
+        db_parm_tbl[num].fScale     = 1.;
+        db_parm_tbl[num].fOffset    = 0.;
+        db_parm_tbl[num].sDSF 	    = 0;
+        }
+  for (num=NPARM; num < NPARM * MAX_PARM_TBLS; num++) {  /* for sub-tbls */
+        db_parm_tbl[num].usParm_id=  250 + num / NPARM;
+        db_parm_tbl[num].usParm_sub= num % NPARM;
+        db_parm_tbl[num].db_name[0] = '\0';
+        db_parm_tbl[num].fScale     = 1.;
+        db_parm_tbl[num].fOffset    = 0.;
+        db_parm_tbl[num].sDSF 	    = 0;
+        }
+
+  for (num=0; num < NLEV; num++) {
+        db_lvl_tbl[num].usLevel_id =  num;
+        db_lvl_tbl[num].db_name[0] = '\0';
+        db_lvl_tbl[num].fScale	   =  1.;
+        db_lvl_tbl[num].fOffset	   =  0.;
+        }
+
+  for (num=0; num < NMODEL; num++) {
+        db_mdl_tbl[num].usModel_id  = num;
+        db_mdl_tbl[num].db_name[0] = '\0';
+        }
+
+  for (num=0; num < NGEOM; num++) {
+        db_geom_tbl[num].usGeom_id  = num;
+        db_geom_tbl[num].db_name[0] = '\0';
+        }
+/*
+*
+* A.1       OPEN Lookup file for reading
+*           RETURN 1 if fails;
+*/
+  infile = fopen(lookup_fn, "r");
+  if (infile==NULL) { 
+	DPRINT2 ("%s:  failed to open %s\n", func, lookup_fn);
+	sprintf (errmsg ,"%s:  failed to open %s\n", func, lookup_fn);
+	goto BYE;
+	}
+
+/****Database's PARM TABLE -- (0/A/B/C/D/E) ***
+Sample:
+NEONS to GRIB Parameter Table
+NEONS FIELD             TABLE CODE    GRIB CODE     SCALE     OFFSET     DSF
+===========             ==========    =========     =====     ======     ===
+pres                        0           001           1.0        0.0      1
+pres                        0           002           1.0        0.0      1
+*
+*           *** Database's Parameter Defn conversion info ***
+* A.2       KEEP reading until last of Header/Comment line (see '===')
+*           RETURN error if fails
+*/
+  LineRead = 0;
+
+  while (strstr (temp, "===") == NULL) {
+  	fgets(temp, sizeof(temp), infile); /* skip Comment/Header lines */
+	LineRead++; 
+        if (feof(infile) || ferror(infile)) {
+    	   DPRINT1 ("%s: got EOF/ERROR before loading DBs PARM info\n", func);
+    	   sprintf(errmsg,
+    	   "%s: got EOF/ERROR before loading DBs PARM info (%s:line %d)\n",
+	    func , lookup_fn, LineRead);
+    	   goto BYE;
+    	  }
+	}
+/*
+*
+* A.3       FOR (successfully read a line from file) DO
+*              BREAK out of loop if sees Header of next Table
+*              EXTRACT next DBs's Parameter info from line read
+*              IF (fails) SKIP rest of Parm defn ;
+*              !parm_name, tblcode, parmid, scalefctr, offset, Decsclfctr;
+*              DROP line if Parm id is out of range
+*              DROP line if Table Code is not (0/A/B/C/D/E)
+*              DROP defn if Code has already been defined;
+*              STORE in Parm Array cell whose index equals Parmid
+*           ENDFOR
+*/
+  for (cnt=0; fgets(temp, sizeof(temp), infile)!=NULL; ) {
+      
+	LineRead++; 
+	for (ptr=temp; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+        if (strstr(temp, "to GRIB Level Table") != NULL) 
+		break;  /* END OF CURR SECT */
+
+    	if ((num= sscanf (temp,"%s%s%s%s%s%s%s", achDBsField, subtbl, 
+	    strGribCode, strScale, strOffset, strDSF, dummy)) != 6) 
+	  {
+	    if (num>0)
+	    fprintf(stdout,"Warning: unmatched Parm args, drop line %d in %s\n", 
+		LineRead, lookup_fn);
+	    continue;
+	  }
+
+       for (px=strGribCode; *px; px++) 
+	  if (!isdigit(*px)) {
+		fprintf(stdout,
+		"Warning: invalid GRIB code, drop line %d in %s\n",
+		LineRead, lookup_fn);
+		continue;
+		}
+
+       GribCode =  atoi(strGribCode);
+       fScale     = (float) atof(strScale);
+       fOffset    = (float) atof(strOffset);
+       sDSF       = (short) atoi(strDSF);
+
+       if (GribCode < 0 || GribCode >= NPARM) {
+	   fprintf(stdout,
+	   "Warning:  ParmId '%d' out of range, drop line %d in %s\n",
+	   GribCode,  LineRead, lookup_fn); continue; }
+
+	if (strlen(subtbl) > 1) { fprintf(stdout,
+	   "Warning:  Invalid bad TableCode '%s', drop line %d in %s;\n",
+	   subtbl, LineRead, lookup_fn); continue; }
+
+      /* depending on which Table Code it is, entry will be stored in
+	 its corresponding Parameter Table;  
+	 >>> if Tablecode is '0', store at array index PARM_ID;
+	 >>> if Tablecode is 'A/B/C/D/E',
+	 >>> then store at array index [NPARM*(PARM_ID-249) + PARM_SUB];
+         >>> UNDEFINED IDS WILL HAVE EMPTY CELLS;
+      */
+      TableCode = (isalpha(*subtbl) ? tolower(*subtbl) : *subtbl);
+
+      if   (TableCode=='0')  {
+		Indx = 0;
+      		parmptr 	    = db_parm_tbl + GribCode;
+		parmptr->usParm_id  = (unsigned short) GribCode;
+                parmptr->usParm_sub = 0; 
+	}
+      else if (TableCode>= 'a' && TableCode <= 'e')  {
+	      if (GribCode==0) {
+		fprintf(stdout,
+	     	"Warning: Cannot use Parmid 0 for sub-tbl, drop line %d in %s\n"
+		,  LineRead, lookup_fn);
+		continue;
+		}
+	        Indx = 256 * (TableCode-'a'+1);   /* 'a':256-.. 'b':512-.. */ 
+      		parmptr = db_parm_tbl + Indx + GribCode; /* actual Index */
+	        parmptr->usParm_id  = 250 + (TableCode-'a');
+	        parmptr->usParm_sub = (unsigned short) GribCode;
+        }
+      else {  fprintf(stdout,
+	      "Warning:  Invalid Table '%s' (0,A-E only), drop line %d in %s\n",
+	      subtbl,  LineRead, lookup_fn);
+	      continue;
+        }
+	
+      if (parmptr->db_name[0] != '\0')
+	    { /* drop line if Duplicate */
+               fprintf(stdout,
+	   "Warning: duplic Parm %d in Tbl %c (Index=%d), drop line %d in %s\n",
+		parmptr->usParm_id, TableCode,
+		PARMTBL_INDX(parmptr->usParm_id, parmptr->usParm_sub),
+		LineRead, lookup_fn);
+              continue;
+            }
+
+      strcpy (parmptr->db_name, achDBsField);
+      parmptr->fScale = fScale;
+      parmptr->fOffset = fOffset;
+      parmptr->sDSF = sDSF;
+      ++cnt;    /* keep track of #entries loaded */
+
+      DPRINT9(
+ "(+)T2-%c cd=%d:  Parm=%d sub=%d, INDX=%d, dbnm=%s Scl=%.2f Ofs=%.2f D=%d\n"
+	, TableCode, GribCode,
+	parmptr->usParm_id, parmptr->usParm_sub,Indx+GribCode,  
+	parmptr->db_name, parmptr->fScale, parmptr->fOffset, parmptr->sDSF);
+   }
+  
+/*
+*          DEBUG print
+*/
+ DPRINT1("Parameter table has %d entries\n", cnt);
+
+
+/******** Database's LEVEL TABLE *******
+Sample:
+NEONS to GRIB Level Table (FNMOC VERSION)
+NEONS Level Type        GRIB CODE     SCALE     OFFSET
+================        =========     =====     ======
+surface                   001           1.0        0.0
+isth_lvl                  004           0.0      273.16
+trpp_lvl                  007           1.0        0.0
+*
+*           *** DBs's Level Defn conversion info ***
+* A.4       KEEP reading until last of Header/Comment line (see '===')
+*           RETURN error if fails
+*/
+  while (strstr (temp, "====") == NULL) {
+        fgets(temp, sizeof(temp), infile); /* skip Comment/Header lines */
+	LineRead++; 
+  	if (feof(infile) || ferror(infile)) {
+	  DPRINT1 ("%s: got EOF/ERROR before loading DBs LEVEL info\n",func);
+	  sprintf(errmsg,
+	  "%s: got EOF/ERROR before loading LEVEL info (line %d in %s)\n",
+	  func , LineRead, lookup_fn);
+	  goto BYE;
+	}
+   }
+
+/*
+* A.5       FOR (successfully read a line from file) DO
+*              BREAK out of loop if sees Header of next Table
+*              EXTRACT next DBs's Level info into Level Array:
+*              !format= level_type, level_id, scale, offset
+*              DROP line if not enough arguments
+*              DROP line if Duplicate Parm defn
+*              STORE in Level  Array cell whose index equals Level id
+*           ENDFOR
+*/
+  for (cnt=0; fgets(temp, sizeof(temp), infile) != NULL; )  
+  {
+    LineRead++;
+    if (strstr(temp, "to GRIB Model Table") != NULL) 
+	break;  /* Assume end of section */
+    for (ptr=temp; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+    if ((num= sscanf (temp, "%s%s%s%s%s", 
+	      achDBsField, strGribCode, strScale, strOffset, dummy)) != 4) 
+	{
+	  if (num>0)
+	    fprintf(stdout,"Warning: unmatched Level args, drop line %d in %s\n",
+	    LineRead, lookup_fn);
+	  continue;
+	}
+
+    GribCode =  atoi(strGribCode);
+    fScale     = (float) atof(strScale);
+    fOffset    = (float) atof(strOffset);
+
+    if (GribCode < 0 || GribCode >= NLEV) {
+	 fprintf(stdout,
+	"Warning: Level_id '%d' out of range, drop line %d in %s\n"
+	,GribCode, LineRead, lookup_fn); 
+	 continue; 
+	}
+
+    if (db_lvl_tbl[GribCode].db_name[0] != '\0') {
+	fprintf(stdout,
+	"Warning: duplic Level %d, drop defn ending on line %d in %s\n",
+	GribCode, LineRead, lookup_fn);
+	continue;
+	}
+
+    db_lvl_tbl[GribCode].usLevel_id  = (unsigned short) GribCode;
+    strncpy (db_lvl_tbl[GribCode].db_name, achDBsField, 
+	    sizeof(db_lvl_tbl[GribCode].db_name)-1);
+    db_lvl_tbl[GribCode].fScale  = fScale;
+    db_lvl_tbl[GribCode].fOffset = fOffset;
+    ++cnt;  /* number loaded */
+
+    DPRINT4("(+)  Level=%d,  db_name=%s,  Scl=%f, Offs=%f\n", 
+	db_lvl_tbl[GribCode].usLevel_id, db_lvl_tbl[GribCode].db_name,
+	db_lvl_tbl[GribCode].fScale, db_lvl_tbl[GribCode].fOffset);
+  }
+  
+/*
+*          DEBUG print
+*/
+  DPRINT1("Level table has %d entries\n", cnt);
+
+
+/*** Database's MODEL TABLE***
+Sample:
+NEONS to GRIB Model ID Table (FNMOC VERSION)
+NEONS Model Name        GRIB CODE
+================        =========
+NORAPS                    001
+COAMPS                    002
+*
+*           *** Database 's Model Defn conversion info ***
+* A.6       KEEP reading until last of Header/Comment line (see '===')
+*           RETURN error if fails
+*/
+  while (strstr (temp, "====") == NULL) {
+        fgets(temp, sizeof(temp), infile); /* skip Comment/Header lines */
+	LineRead++;
+        if (feof(infile) || ferror(infile)) {
+          DPRINT1 ("%s: got EOF/ERROR before loading MODEL info\n",func);
+          sprintf(errmsg,
+          "%s: got EOF/ERROR before loading MODEL info (line %d in %s)\n",
+          func , LineRead, lookup_fn);
+          goto BYE;
+        }
+    }
+/*
+* A.7       FOR (successfully read a line from file) DO
+*              BREAK out of loop if sees Header of next Table
+*              EXTRACT next DBs's Model info into Model Array;
+*              DROP line if not enough arguments
+*              DROP line if Duplicate model defn
+*              ! format= model_name, model_id;
+*              STORE in Model  Array cell whose index equals Model id
+*           ENDFOR
+*/
+  for (cnt=0; fgets(temp, sizeof(temp), infile)!=NULL; ) 
+   {
+     LineRead++;
+     for (ptr=temp; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+     if (strstr(temp, "to GRIB Geometry Table") != NULL) 
+	break; /*  Assume end of section */
+     if ((num= sscanf (temp, "%s%s%s", achDBsField, strGribCode,dummy))  !=2) {
+          if (num>0)
+            fprintf(stdout,"Warning: unmatched Model args, drop line %d in %s\n",
+            LineRead, lookup_fn);
+          continue;
+        }
+    
+     GribCode =  atoi(strGribCode);
+     if (GribCode < 0 || GribCode >= NMODEL) {
+         fprintf(stdout,
+           "Warning:  Model_id '%d' out of range, drop line %d in %s",
+           GribCode, LineRead, lookup_fn); continue; }
+
+    if (db_mdl_tbl[GribCode].db_name[0] != '\0') {
+	fprintf(stdout,
+	"Warning: duplic Model %d, drop defn ending on line %d in %s\n",
+	GribCode, LineRead, lookup_fn);
+	continue;
+	}
+
+     db_mdl_tbl[GribCode].usModel_id = (unsigned short) GribCode;
+     strcpy (db_mdl_tbl[GribCode].db_name, achDBsField);
+     ++cnt;  /* number loaded */
+     DPRINT2("(+)  Model=%d,  db_name=%s\n", 
+	db_mdl_tbl[GribCode].usModel_id, db_mdl_tbl[GribCode].db_name);
+   }
+    
+/*
+*          DEBUG print
+*/
+  DPRINT1("Model table has %d entries\n", cnt);
+     
+
+/*** Database's GEOMETRY TABLE*** 
+Sample:
+NEONS to GRIB Geometry Table
+NEONS Geometry Name     GRIB CODE
+===================     =========
+mediterranean_109x82       001
+persian_gulf_NORAPS_63x63  002
+global_144x288             003
+*
+*           *** Database's Geometry Defn conversion info ***
+* A.8       KEEP reading until last of Header/Comment line (see '===')
+*           RETURN error if fails
+*/
+  while (strstr (temp, "====") == NULL) {
+     fgets(temp, sizeof(temp), infile); /* skip Comment/Header lines */
+     LineRead++; 
+     if (feof(infile) || ferror(infile)) {
+          DPRINT1 ("%s: got EOF/ERROR before loading DBs GEOM info\n",func);
+          sprintf(errmsg,
+          "%s: got EOF/ERROR before loading GEOM info (line %d in %s)\n",
+          func , LineRead, lookup_fn);
+          goto BYE;
+        }
+    }
+/*
+* A.9       FOR (successfully read a line from file) DO
+*              EXTRACT next DBs's Geometry info into Geometry Array;
+*              IF (fails) SKIP rest of Geometry defn ;
+*              !format= parm_name, parm_id, scalefctr, offset, dec scale factor;
+*              STORE in Geom  Array cell whose index equals Geom id
+*           ENDFOR
+*/
+  for (cnt=0; fgets(temp, sizeof(temp), infile)!=NULL; ) {
+    LineRead++;
+    for (ptr=temp; *ptr==' '; ptr++) ; if (*ptr == '#') continue;  
+    if ((num= sscanf (temp, "%s%s%s", achDBsField, strGribCode, dummy))  !=2) {
+          if (num>0)
+            fprintf(stdout,"Warning: unmatched Geom args, drop line %d in %s\n",
+            LineRead, lookup_fn);
+          continue; 
+        }
+
+    GribCode =  atoi(strGribCode);
+    if (GribCode < 0 || GribCode >= NGEOM) {
+         fprintf(stdout,
+           "Warning:  Geom_id '%d' out of range, drop line %d in %s\n",
+           GribCode, LineRead, lookup_fn); continue; }
+
+    if (db_geom_tbl[GribCode].db_name[0] != '\0') {
+	fprintf(stdout,
+	"Warning: duplic Geom %d, drop defn ending on line %d in %s\n",
+	GribCode, LineRead, lookup_fn);
+	continue;
+	}
+
+    db_geom_tbl[GribCode].usGeom_id= (unsigned short) GribCode; 
+    strcpy (db_geom_tbl[GribCode].db_name, achDBsField);
+    ++cnt;
+    DPRINT2("(+) geom=%d,  db_name=%s\n", 
+	db_geom_tbl[GribCode].usGeom_id, db_geom_tbl[GribCode].db_name);
+   }
+   
+/*
+*          DEBUG print
+*/
+  DPRINT1("Geometry table has %d entries\n", cnt);
+
+/*
+* 
+* A.10     SET status to 0 !success
+*/
+  stat=0;
+
+/*
+*
+* A.11     CLOSE Lookup file;
+*/
+BYE:
+  if (infile) fclose(infile);
+  DPRINT2 ("Leaving %s(), stat=%d\n", func,stat);
+/*
+*
+* A.12     RETURN with status
+*/
+  return (stat);
+/*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/ld_grib_origctrs.c b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_grib_origctrs.c
new file mode 100644
index 00000000..5429eca2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/ld_grib_origctrs.c
@@ -0,0 +1,164 @@
+#include 
+#include 
+#include 
+#include "grib_lookup.h"
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+CTR_DEFN 	db_ctr_tbl[NCTRS];   /* GLOBVARS */
+
+/*
+***************************************************************************
+* A. FUNCTION:  ld_grib_origctrs
+*      Load Originating Centers information from named file into
+*      an array of structures of type CTR_DEFN.  
+*
+*    INTERFACE:
+*      int     ld_grib_origctrs (orig_ctr_fn, pathnm,  errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) char	*orig_ctr_fn;    name of file to load
+*      (I) char *pathnm;         path where input file resides
+*      (O) char *errmsg;         returned filled if error occurred
+*
+*    RETURN CODE:
+*        0: no errors; db_ctrs_tbl array filled;
+*       -1: bad, errmsg is filled;
+***************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int  ld_grib_origctrs ( char *orig_ctr_fn, char *pathnm, char *errmsg)
+#else
+int  ld_grib_origctrs ( orig_ctr_fn, pathnm, errmsg)
+		char *orig_ctr_fn; char *pathnm; char *errmsg;
+#endif
+{
+/*
+*
+* A.0       DEFAULT to bad Status;
+*/
+char *func="ld_grib_origctrs", *ptr;
+char  strGribCode[200],Line[200], fn[200], mybuff[200];
+int ftp_already=0, usGribCode, cnt=0, stat= -1;
+FILE  *fLook;
+
+/*
+*
+* A.1       PREPARE name and path of orig ctr file
+*           CLEAR out the lookup arrays
+*/
+  DPRINT1 ("Entering %s\n", func);
+  sprintf (fn, "%s/%s", pathnm, orig_ctr_fn);
+  DPRINT1 ("Try to load= %s\n", fn);
+  memset ((void*)db_ctr_tbl, '\0', NCTRS * sizeof(CTR_DEFN));
+
+/*
+*
+* A.2       IF (unable to open OrigCtr file for reading) THEN
+*               RETURN with error status;
+*           ENDIF
+*/
+   if ( (fLook= fopen(fn,"r")) == NULL) 
+     {
+	 sprintf(errmsg,"%s: failed to load '%s';\n", func, orig_ctr_fn);
+	 goto BYE;	/* return with error status */
+     }
+
+
+      /*  Now, read:  *** ORIG_CTRS ****
+      Sample:
+
+     GRIB Table 0 - Originating Center Definitions (Octet 5 of PDS)
+     Code Figure    Model Name
+     ===========    ==========
+     007            US Weather Service - National Meteorological Center (NMC)
+     057            US Air Force - Air Force Global Weather Central
+     058            Fleet Numerical Meteorology and Oceanography Center (FNMOC)
+     059            NOAA Forecast Systems Laboratory (FSL)
+     097            European Space Agency (ESA)
+     098            European Centre for Medium Range Weather Forecasts (ECMWF)
+     128            Naval Research Laboratory (NRL) Monterey, CA
+     129            Center for Air/Sea Technology (CAST)
+     */
+
+/*
+*
+* A.3       SKIP over the comments lines 
+*/
+     /* Read until last of Header line */
+     for (Line[0]='\0'; ! strstr(Line,"====") ; ) 
+     {
+       fgets(Line, sizeof(Line), fLook); 
+       if (feof(fLook) || ferror(fLook)) 
+         { sprintf(errmsg,
+	   "%s: got EOF/ERROR skipping over Header lines in %s\n", func,fn);
+	   goto BYE;
+         }
+      }
+
+/*
+* A.4       WHILE (not end of file yet)
+*/
+    cnt=0;
+    while (!feof(fLook) && !ferror(fLook))
+      {
+/*
+*             READ a line  !stop if fails
+*             SKIP line if it doesn't have 2 args or ctr_id out of range
+*             STORE center info into db_ctr_tbl array, cell #usGribCode;
+*/
+		if (fgets(Line, sizeof(Line), fLook) == NULL) break;
+
+	       /* skip additional comments, 
+		replace tabs with spaces, newlines with null
+	       */
+		if (Line[0]=='#') continue;
+		while (ptr=strchr(Line,'\t')) *ptr=' ';
+		if (ptr=strchr(Line,'\n')) *ptr='\0';
+
+                if (sscanf(Line,"%s%s",strGribCode, mybuff) != 2) continue;
+
+	       /* Make sure Ctr_Id field has a Number */
+	       if (strspn (strGribCode, "0123456789") != strlen(strGribCode)) {
+		   sprintf(errmsg,"%s:  Invalid Ctr_id '%s', LINE=\n%s\n",
+		   func,strGribCode, Line);
+		   goto BYE; }
+
+	       	usGribCode = (unsigned short) atoi(strGribCode);
+		if (usGribCode<0 || usGribCode>= NOCTR) continue;
+
+                /* copy over to Neon Tbl, descr has more than 1 words */
+                strncpy(db_ctr_tbl[usGribCode].ctr_dsc, 
+			strstr(Line, mybuff), 
+			sizeof(db_ctr_tbl[usGribCode].ctr_dsc) -1);
+                ++cnt;
+	        DPRINT2 ("(+)  ctr_id=%d, descr=%s\n", usGribCode, 
+		db_ctr_tbl[usGribCode].ctr_dsc); 
+/*
+*           ENDWHILE    !read entries
+*/
+      } 
+
+/*
+*
+* A.5       SET Status to no errors
+*/
+    DPRINT1 ("File 'orig_ctrs' has %d entries\n", cnt);
+    stat = 0;
+
+BYE:
+/*
+*
+* A.6       CLOSE "orig_ctrs" if file is opened
+*
+* A.7       RETURN with status
+*/
+    if (fLook)  close(fLook);
+    DPRINT2 ("Exiting %s, Stat=%d\n", func, stat);
+    return (stat);
+/*
+*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/make_default_grbfn.c b/wrfv2_fire/external/io_grib1/MEL_grib1/make_default_grbfn.c
new file mode 100644
index 00000000..286109b6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/make_default_grbfn.c
@@ -0,0 +1,61 @@
+#include 
+#include 
+#include "dprints.h"
+#include "gribfuncs.h"		/* prototypes */
+#include "grib_lookup.h"	/* macros */
+
+/*
+****************************************************************************
+* A.  FUNCTION:   make_default_grbfn
+*        build and return default filename for current message to be encoded
+*        using the information from structures DATA_INPUT and USER_INPUT.
+*
+*    INTERFACE:
+*      void  make_default_grbfn (DATA_INPUT di, USER_INPUT ui, char *default_fn)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) DATA_INPUT  di;     contains info of msg to be encoded
+*      (I) USER_INPUT  ui;     contains the required chCase_id
+*      (O) char *default_fn;   empty string atleast 42 characters long
+*
+*     RETURN CODE: none; default_fn string contains name with format
+*       'Mid_Gid_yyyymmddhhtau_PIndx_Lid.lvl1.c.grb';
+****************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void    make_default_grbfn  (DATA_INPUT di, USER_INPUT ui, char *default_fn)
+#else
+void    make_default_grbfn  (di,ui,default_fn)
+		DATA_INPUT di; 
+                USER_INPUT ui; 
+                char *default_fn;
+#endif
+{
+/*
+* A.1   Build the default filename:  MMM_GGG_yyyymmddhhtau_PIndx.lvl1.c.grb
+*       where
+*         MMM   : 3-dibit model id from DATA_INPUT
+*         GGG   : 3-digit geom id from DATA_INPUT
+*         yyyy  : 4-digit year of reference date/time from DATA_INPUT
+*          mm   : 2-digit month of reference date/time from DATA_INPUT
+*          dd   : 2-digit day of reference date/time from DATA_INPUT
+*          hh   : 2-digit hour of reference date/time from DATA_INPUT
+*         tau   : 3-digit forecast period  from DATA_INPUT
+*       PIndx   : 4-digit Parameter Index computed from DATA_INPUT's 
+*                 Parmid & ParmSubid
+*         Lid   : 3-digit Level id from DATA_INPUT
+*        lvl1   : 5-digit Level 1  from DATA_INPUT
+*           c   : 1-digit Case id from USER_INPUT
+*        .grb   : 4-char string, as is
+*/
+  sprintf (default_fn, 
+        "%03d_%03d_%04d%02d%02d%02d%03d_%04d_%03d.%05d.%c.grb",
+        di.usProc_id, di.usGrid_id, di.nYear, di.nMonth, di.nDay, 
+        di.nHour, di.usFcst_per1, 
+	(int)PARMTBL_INDX (di.usParm_id, di.usParm_sub_id),
+	di.usLevel_id, di.nLvl_1, 
+        ui.chCase_id);
+
+  DPRINT1("make_default_grb_fn built '%s'\n", default_fn);
+}
+
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/make_grib_log.c b/wrfv2_fire/external/io_grib1/MEL_grib1/make_grib_log.c
new file mode 100644
index 00000000..038b0528
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/make_grib_log.c
@@ -0,0 +1,851 @@
+/* Program    : make_grib_log (was printer.c)
+   Programmer : Todd J. Kienitz, SAIC
+   Date       : January 10, 1996
+   Purpose    : To produce the information file output of the GRIB message.
+   Revisions  : 
+   04/17/96 Steve Lowe, SAIC:  modified data print-out
+   04/22/96 Alice Nakajima (ATN), SAIC:  added BMS summary
+   12/12/96 ATN:  implement combined Decoder/Encdoer structs
+	    replaced  (table2 tab2[], table3 tab3[], tables mgotab); 
+   06/14/97 ATN:  print upto encoded pricision.
+   02/22/98 ATN:  replace projection id with constants, add printing for
+     prjns: Rotated Lat/Lon, Stretched Lat/Lon, Stretched Rotated Lat/Lon,
+     Rotated Gaussian, Stretched Gauss, Stretched Rotated Gaussian ,
+     Oblique Lambert, and for Albers equal-area.
+   09/10/98 ATN:  extension flag printing.
+*/
+#include 
+#include 
+#include 
+#include "grib_lookup.h"	/* combined encoder/decoder structs */
+#include "dprints.h"		/* for debug printing */
+#include "gribfuncs.h"		/* prototypes */
+
+/* 
+**********************************************************************
+* A. FUNCTION: make_grib_log
+*      Produces debug file GRIB.log from the GRIB message in the Grib Header 
+*
+*    INTERFACE:
+*      int   make_grib_log (input_fn, lookup_fn, msg_length, offset,
+*                           pds, gds, bds, bms, grib_data, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) char *input_fn;            name of input GRIB file 
+*      (I) char *lookup_fn;           name of Lookup file, nil if not used 
+*      (I) unsigned long msg_length;  total length of GRIB message
+*      (I) long offset;               starting location of GRIB message in bytes
+*      (I) PDS_INPUT pds;             product definition section structure
+*      (I) grid_desc_sec gds;         grid description section structure
+*      (I) BDS_HEAD_INPUT bds;        binary data section header structure
+*      (I) BMS_INPUT bms;             bit map definition section structure
+*      (I) float *grib_data;          array of decoded data
+*
+*     ACCESSES GLOBAL VARS:
+*        int UseTables;
+*            set to one if lookup table used
+*        CTRS_DEFN  db_ctr_tbl[NCTRS];
+*            predefined array holding Originating Center info
+*        PARM_DEFN db_parm_tbl [MAX_PARM_TBLS * NPARM];
+*            predefined arr of Parameter info 
+*        LVL_DEFN db_lvl_tbl [NLVL];
+*            predefined arr of Level info struct
+*        MODEL_DEFN db_mdl_tbl [NMODEL];
+*            predefined arr of Model info struct
+*        GEOM_DEFN db_geom_tbl [NGEOM];
+*            predefined arr of Geometry info struct
+*
+*     RETURN CODE:  
+*       0> no errors; file GRIB.log has been created;
+*       1> error, errmsg filled;
+**********************************************************************
+*/
+extern int 	  UseTables; 	 /* set means use lookup tbl defns */
+extern PARM_DEFN  db_parm_tbl[]; /* parameter conversion info */
+extern MODEL_DEFN db_mdl_tbl[];  /* model conversion info */
+extern LVL_DEFN   db_lvl_tbl[];  /* level conversion info */
+extern GEOM_DEFN  db_geom_tbl[]; /* Geom conversion info  */
+extern CTR_DEFN   db_ctr_tbl[];  /* Ctr conversion info  */
+
+#if PROTOTYPE_NEEDED
+int   make_grib_log ( 	char *input_fn, 
+			char *lookup_fn, 
+			unsigned long msg_length, 
+			long offset, 
+			PDS_INPUT pds, 
+			grid_desc_sec gds,
+     		       	BDS_HEAD_INPUT bds, 
+			BMS_INPUT bms, 
+			float *grib_data, 
+			char *errmsg)
+#else
+int   make_grib_log (input_fn, lookup_fn, msg_length, offset,
+		     pds, gds, bds, bms, grib_data,errmsg)
+	char *input_fn;
+	char *lookup_fn; 
+	unsigned long msg_length; 
+	long offset; 
+	PDS_INPUT pds; 
+	grid_desc_sec gds;
+	BDS_HEAD_INPUT bds; 
+	BMS_INPUT bms; 
+	float *grib_data; 
+	char *errmsg;
+#endif
+
+{
+  char *func="make_grib_log";
+  int i, indx, k, fd, numpts=100;
+  float dsf, res, min, max;
+  FILE *fp;
+
+/*
+*
+* A.0   DEBUG printing
+*/
+  DPRINT1 ("Entering %s\n", func);
+
+/* 
+*
+* A.1   OPEN file "GRIB.log" in APPEND mode
+*/
+  fp=fopen ("GRIB.log", "a+");
+  if (!fp) {
+	DPRINT1("%s:  failed to open 'GRIB.log' for appending, skip logfile\n",
+	func); 
+	sprintf (errmsg, "%s:  failed to open 'GRIB.log'\n", func); 
+	return (1);
+	}
+
+/*
+*
+* A.2   WRITE Indicator Section information to file
+*       !message length
+*       !GRIB Edition number
+*/
+  fseek(fp, 0L, 2);
+  if (ftell(fp) == 0L)
+  fprintf (fp, 	"%s: InFile= %s\n%s: Lookup=%d, fn='%s'\n\n" ,
+	   func, input_fn, func,UseTables, lookup_fn);
+
+  fprintf (fp, "**** VALID MESSAGE FOUND AT %ld BYTES ****\n" , offset);
+
+  fprintf(fp, "\n********* SECTION 0 IDS *********\n" );
+  fprintf(fp, "Total Message length = %ld\nEdition Number = %d\n",
+	   msg_length, pds.usEd_num);
+/*
+*
+* A.3   WRITE Product Definition Section information to file
+*       !Section length
+*       !Parameter Table version
+*       !Parameter Sub-Table version if defined and flagged by Extension flag
+*       !Tracking id if defined and flagged by Extension flag
+*/
+  fprintf(fp, "\n********* SECTION 1 PDS *********\n" \
+  	"Section length = %d\nTable version = %d\n",
+	 pds.uslength, pds.usParm_tbl);
+
+  if (pds.usExt_flag == (unsigned short)EXTENSION_FLAG ) 
+   {
+    if (pds.usSub_tbl != 0) 
+        fprintf(fp,"Local Table version = %d\n",pds.usSub_tbl);
+    if(pds.usTrack_num  != 0) 
+	fprintf(fp,"Tracking ID = %d\n",pds.usTrack_num);
+   }
+   
+/*
+*       !Originating Center id
+*       !IF (using tables) Name of Originating Center
+*/
+  fprintf(fp,"Originating Center id = %d\n",pds.usCenter_id);
+  if (UseTables)
+     if ( db_ctr_tbl[pds.usCenter_id].ctr_dsc[0] )
+        fprintf(fp,"Originating Center = %s\n",
+	db_ctr_tbl[pds.usCenter_id].ctr_dsc);
+     else
+        fprintf(fp,"Originating Center ID %d not defined in current table.\n",
+	pds.usCenter_id);
+
+/*
+*       !Sub-Table Entry for Originating Center if non-zero and if
+*       !extension flag is set
+*/
+  if (pds.usExt_flag == (unsigned short)EXTENSION_FLAG && 
+	pds.usCenter_sub != 0) 
+     fprintf(fp,"Sub-Table Entry Originating Center = %d\n",pds.usCenter_sub);
+
+/*
+*       !Extension flag
+*/
+  fprintf(fp,"Extension flag = %d (extensions %s)\n", pds.usExt_flag,
+  (pds.usExt_flag == (unsigned short)EXTENSION_FLAG ? "used" : "not used"));
+
+/*
+*       !Model Identification
+*       !IF (using tables) Model Description
+*/
+  fprintf(fp,"Model id = %d\n",pds.usProc_id);
+  if (UseTables)
+     if ( db_mdl_tbl[pds.usProc_id].grib_dsc[0] )
+        fprintf(fp,"Model Description = %s\n",
+	db_mdl_tbl[pds.usProc_id].grib_dsc);
+     else
+        fprintf(fp,"Model ID %d not defined in current table.\n",
+	pds.usProc_id);
+
+/*
+*       !Grid Identification
+*       !IF (using tables) Grid Description
+*/
+  fprintf(fp,"Grid id = %d\n",pds.usGrid_id);
+  if (UseTables) 
+     if ( db_geom_tbl[pds.usGrid_id].grib_dsc[0] )
+        fprintf(fp,"Grid Description = %s\n",
+	db_geom_tbl[pds.usGrid_id].grib_dsc);
+     else
+        fprintf(fp,"Grid ID %d not defined in current table.\n",
+	pds.usGrid_id);
+
+/*
+*       !Parameter Identification
+*/
+  fprintf(fp,"Parameter id = %d\n",pds.usParm_id);
+
+/*
+*       !IF (usExt_flag is set AND
+*       !    (Parm id between 250 and 254) AND (Sub Parm ID defined)))
+*       !    PRINT Parm_sub 
+*       !ENDIF
+*/
+  if (pds.usExt_flag == (unsigned short)EXTENSION_FLAG &&
+	  pds.usParm_id>=250 && pds.usParm_id<=254 && pds.usParm_sub!=0)
+          fprintf(fp,"Parameter sub-id = %d\n",pds.usParm_sub);
+
+
+/*
+*       !IF (using lookup table) THEN
+*       !  CALCULATE index in Parm Conversion Array to use
+*       !  let index= (usParm_Id - 249)*256 + usParm_sub;
+*       !
+*       !   IF this index in Parm Conversion Array is defined THEN
+*       !       PRINT its grib_dsc and grib_unit_dsc
+*       !   ELSE 
+*       !       PRINT it's not defined mesage
+*       !   ENDIF
+*       !ENDIF
+*/
+  if(UseTables) 
+   {
+      indx = PARMTBL_INDX (pds.usParm_id, pds.usParm_sub);
+
+      if ( db_parm_tbl[indx].grib_dsc[0] ) {
+         fprintf(fp,"Parameter name = %s\n",db_parm_tbl[indx].grib_dsc);
+         fprintf(fp,"Parameter units = %s\n",db_parm_tbl[indx].grib_unit_dsc);
+          }
+      else fprintf(fp,"Parameter ID %d not defined in current table.\n",
+	 pds.usParm_id);
+    }
+
+/*
+*       !Level Id 
+*       !IF (using tables)
+*       !  Level description
+*       !  SWITCH (number of octets to store Height1)
+*       !     2: Level = Height1
+*       !     1: Bottom of Layer = Height1
+*       !        Top of Layer = Height2
+*       !     0: (no Height value required)
+*       !     default: (corrupt table entry or message)
+*       !  ENDSWITCH
+*       !ELSE (not using tables)
+*       !  Level = Height1  (Level assumed)
+*       !ENDIF
+*/
+  fprintf(fp,"Level_type = %d\n",pds.usLevel_id);
+  if(UseTables) {
+    if ( db_lvl_tbl[pds.usLevel_id].grib_dsc[0] ) {
+       fprintf(fp,"Level description = %s\n", 
+		db_lvl_tbl[pds.usLevel_id].grib_dsc);
+       switch(db_lvl_tbl[pds.usLevel_id].num_octets){
+         case 2:
+           fprintf(fp,"%s = %u\n",
+  	   db_lvl_tbl[pds.usLevel_id].lvl_name_1, pds.usHeight1);
+           break;
+         case 1:
+           fprintf(fp,"%s = %u\n%s = %u\n",
+  	   db_lvl_tbl[pds.usLevel_id].lvl_name_1, pds.usHeight1,
+  	   db_lvl_tbl[pds.usLevel_id].lvl_name_2, pds.usHeight2);
+           break;
+         case 0:
+           break;
+         default:
+           fprintf(fp,"***Number of octets for table 3 undefined - possibly "
+                   "corrupt dataset.***\n");
+       }
+    }else
+       fprintf(fp,"Level ID %d not defined in current table.\n",
+	pds.usLevel_id);
+  } /* end UseTables 'if' statement */
+  else fprintf(fp,"Level = %u\n",pds.usHeight1);
+
+/*
+*       !Reference Date/Time:
+*       !  Century
+*       !  Year
+*       !  Month
+*       !  Day
+*       !  Hour
+*       !  Minute
+*       !  Second if defined
+*/
+  fprintf(fp,
+     "Reference Date/Time of Data Set:\n" \
+     "   Century = %d\n   Year = %d\n   Month = %d\n   Day = %d\n"\
+     "   Hour = %d\n   Minute = %d\n",
+     pds.usCentury,pds.usYear,pds.usMonth,pds.usDay,pds.usHour,pds.usMinute);
+
+  if(pds.usExt_flag == (unsigned short)EXTENSION_FLAG)
+	fprintf(fp,"   Second = %d\n",pds.usSecond);
+
+/*
+*       !Forecast Time Unit
+*       !  Forecast Period 1
+*       !  Forecast Period 2
+*/
+  switch(pds.usFcst_unit_id){
+    case 0: fprintf(fp,"Forecast Time Unit = Minute\n"); break;
+    case 1: fprintf(fp,"Forecast Time Unit = Hour\n"); break;
+    case 2: fprintf(fp,"Forecast Time Unit = Day\n"); break;
+    case 3: fprintf(fp,"Forecast Time Unit = Month\n"); break;
+    case 4: fprintf(fp,"Forecast Time Unit = Year\n"); break;
+    case 5: fprintf(fp,"Forecast Time Unit = Decade (10 years)\n"); break;
+    case 6: fprintf(fp,"Forecast Time Unit = Normal (30 years)\n"); break;
+    case 7: fprintf(fp,"Forecast Time Unit = Century (100 years)\n"); break;
+    case 254: fprintf(fp,"Forecast Time Unit = Second\n"); break;
+    default: fprintf(fp,"Forecast Time Unit = UNDEFINED!!\n");
+  }
+  fprintf(fp,"   Forecast Period 1 = %d\n",pds.usP1);
+  fprintf(fp,"   Forecast Period 2 = %d\n",pds.usP2);
+
+/*
+*       !Time Range Indicator
+*       !Number in Average
+*       !Number Missing
+*/
+  fprintf(fp,"Time Range = %d\n",pds.usTime_range);
+  fprintf(fp,"Number in Average = %d\n",pds.usTime_range_avg);
+  fprintf(fp,"Number Missing = %d\n",pds.usTime_range_mis);
+
+/*
+*       !Decimal Scale Factor
+*/
+  fprintf(fp,"Decimal Scale Factor = %d\n",pds.sDec_sc_fctr);
+
+/*
+*
+* A.4   IF (GDS included) THEN
+* A.4.1    WRITE Grid Definition Section information to file
+*            !Section length
+*            !Parm_nv
+*            !Parm_pv_pl
+*            !Data type
+*/
+  if(pds.usGds_bms_id >> 7 & 1) {
+
+     fprintf(fp,"\n********* SECTION 2 GDS *********\n");
+     fprintf(fp,"Section length = %d\n",gds.head.uslength);
+     fprintf(fp,"Parm_nv = %d\n",gds.head.usNum_v);
+     fprintf(fp,"Parm_pv_pl = %d\n",gds.head.usPl_Pv);
+     fprintf(fp,"Data_type = %d\n",gds.head.usData_type);
+   
+/*
+* A.4.2    SWITCH (Data Type, Table 6)
+*                 !  For each Data Type, write the following to file:
+*                 !     Number of points along rows/columns of grid
+*                 !     Reference Lat/Lon information
+*                 !     Resolution and Component Flags (Table 7)
+*                 !       Direction increments if given
+*                 !       Assumption of Earth shape
+*                 !       U&V component orientation
+*                 !     Scanning mode flags (Table 8)
+*              Default: Projection not supported, exit;
+*/
+     fprintf(fp,"Projection = %s\n", prjn_name[gds.head.usData_type]);
+     switch(gds.head.usData_type)
+     {
+
+/*
+*               Case  0: Lat/Lon projection
+*               Case 10: Rotated Lat/Lon projection
+*               Case 20: Stretched Lat/Lon projection
+*               Case 30: Stretched Rotated Lat/Lon projection
+*/
+    case LATLON_PRJ:    	/* Lat/Lon Grid */
+    case ROT_LATLON_PRJ:   	/* Rotated Lat/Lon */
+    case STR_LATLON_PRJ:   	/* Stretched Lat/Lon */
+    case STR_ROT_LATLON_PRJ :  /* Stretched and Rotated Lat/Lon */
+
+      fprintf(fp,"Number of points along a parallel = %d\n",gds.llg.usNi);
+      fprintf(fp,"Number of points along a meridian = %d\n",gds.llg.usNj);
+      fprintf(fp,"Latitude of first grid point = %.3f deg\n",
+      ((float)gds.llg.lLat1)/1000.);
+      fprintf(fp,"Longitude of first grid point = %.3f deg\n",
+      ((float)gds.llg.lLon1)/1000.);
+      fprintf(fp,"Latitude of last grid point = %.3f deg\n",
+      ((float)gds.llg.lLat2)/1000.);
+      fprintf(fp,"Longitude of last grid point = %.3f deg\n",
+      ((float)gds.llg.lLon2)/1000.);
+
+      fprintf(fp,"Resolution and Component Flags: \n");
+      if ((gds.llg.usRes_flag >> 7) & 1) {
+         fprintf(fp,"    Longitudinal increment = %f deg\n",
+	((float)gds.llg.iDi)/1000.);
+         fprintf(fp,"    Latitudinal increment = %f deg\n",
+	((float)gds.llg.iDj)/1000.);
+      }else fprintf(fp,"    Direction increments not given.\n");
+      if ((gds.llg.usRes_flag >> 6) & 1)
+           fprintf(fp,"    Earth assumed oblate spherical.\n");
+      else fprintf(fp,"    Earth assumed spherical.\n");
+      if ((gds.llg.usRes_flag >> 3) & 1)
+           fprintf(fp,"    U&V components resolved relative to +I and "
+                   "+J\n");
+      else fprintf(fp,"    U&V components resolved relative to east "
+                   "and north.\n");
+
+      fprintf(fp,"Scanning Mode Flags: \n");
+      if ((gds.llg.usScan_mode >> 7) & 1)
+           fprintf(fp,"    Points scan in -I direction.\n");
+      else fprintf(fp,"    Points scan in +I direction.\n");
+      if ((gds.llg.usScan_mode >> 6) & 1)
+           fprintf(fp,"    Points scan in +J direction.\n");
+      else fprintf(fp,"    Points scan in -J direction.\n");
+      if ((gds.llg.usScan_mode >> 5) & 1)
+           fprintf(fp,"    Adjacent points in J direction are "
+                   "consecutive.\n");
+      else fprintf(fp,"    Adjacent points in I direction are "
+                   "consecutive.\n");
+
+      /* added 02/98
+	This code pertains only to the Stretch/Rotate grids,
+	so skip over if it's a LATLON_PRJN type;
+	*/
+      if (gds.head.usData_type != LATLON_PRJ) 
+	{
+	fprintf(fp,"    Latitude of southern pole = %.3f deg\n",
+	((float)gds.llg.lLat_southpole)/1000.);
+	fprintf(fp,"    Longitude of southern pole = %.3f deg\n",
+	((float)gds.llg.lLon_southpole)/1000.);
+
+	/* conv from 'saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb' representation
+	   a single precision floating point value */
+	fprintf(fp,"    Angle of rotation = %.3f\n", 
+	grib_ibm_local ((unsigned long) gds.llg.lRotate));
+
+	fprintf(fp,"    Latitude of pole of stretching = %.3f deg\n",
+	((float)gds.llg.lPole_lat)/1000.);
+	fprintf(fp,"    Longitude of pole of stretching = %.3f deg\n",
+	((float)gds.llg.lPole_lon)/1000.);
+
+	/* conv from 'saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb' representation
+           a single precision floating point value */
+	fprintf(fp,"    Stretching factor = %.3f\n", 
+	grib_ibm_local ((unsigned long)gds.llg.lStretch));
+	}
+      break;
+
+/*
+*               Case 1: Mercator Projection
+*/
+    case MERC_PRJ:    /* Mercator Projection Grid    */
+
+      fprintf(fp,"Number of points along a parallel = %d\n",gds.merc.cols);
+      fprintf(fp,"Number of points along a meridian = %d\n",gds.merc.rows);
+      fprintf(fp,"Latitude of first grid point = %.3f deg\n",
+      ((float)gds.merc.first_lat)/1000.);
+      fprintf(fp,"Longitude of first grid point = %.3f deg\n",
+      ((float)gds.merc.first_lon)/1000.);
+      fprintf(fp,"Latitude of last grid point = %.3f deg\n",
+      ((float)gds.merc.La2)/1000.);
+      fprintf(fp,"Longitude of last grid point = %.3f deg\n",
+      ((float)gds.merc.Lo2)/1000.);
+      fprintf(fp,"Latitude of intersection with Earth = %.3f deg\n",
+      ((float)gds.merc.latin)/1000.);
+
+      fprintf(fp,"Resolution and Component Flags: \n");
+      if ((gds.merc.usRes_flag >> 7) & 1) {
+         fprintf(fp,"    Longitudinal increment = %f deg\n",
+	 ((float)gds.merc.lon_inc)/1000.);
+         fprintf(fp,"    Latitudinal increment = %f deg\n",
+	 ((float)gds.merc.lat_inc)/1000.);
+      }else fprintf(fp,"    Direction increments not given.\n");
+      if ((gds.merc.usRes_flag >> 6) & 1)
+           fprintf(fp,"    Earth assumed oblate spherical.\n");
+      else fprintf(fp,"    Earth assumed spherical.\n");
+      if ((gds.merc.usRes_flag >> 3) & 1)
+           fprintf(fp,"    U&V components resolved relative to +I and "
+                   "+J\n");
+      else fprintf(fp,"    U&V components resolved relative to east "
+                   "and north.\n");
+
+      fprintf(fp,"Scanning Mode Flags: \n");
+      if ((gds.merc.usScan_mode >> 7) & 1)
+           fprintf(fp,"    Points scan in -I direction.\n");
+      else fprintf(fp,"    Points scan in +I direction.\n");
+      if ((gds.merc.usScan_mode >> 6) & 1)
+           fprintf(fp,"    Points scan in +J direction.\n");
+      else fprintf(fp,"    Points scan in -J direction.\n");
+      if ((gds.merc.usScan_mode >> 5) & 1)
+           fprintf(fp,"    Adjacent points in J direction are "
+                   "consecutive.\n");
+      else fprintf(fp,"    Adjacent points in I direction are "
+                   "consecutive.\n");
+      break;
+
+/*
+*               Case  3: Lambert Conformal Projection
+*               Case 13: Oblique Lambert Conformal Projection
+*               Case  8: Alberts equal-area secant/tangent conic/bipolar Prj
+*/
+    case LAMB_PRJ:  		/* Lambert Conformal */
+    case OBLIQ_LAMB_PRJ:  	/* Oblique Lambert Conformal */
+    case ALBERS_PRJ:  		/* Albers equal-area */
+                  
+      fprintf(fp,"Number of points along X-axis = %d\n",gds.lam.iNx);
+      fprintf(fp,"Number of points along Y-axis = %d\n",gds.lam.iNy);
+      fprintf(fp,"Latitude of first grid point = %.3f deg\n",
+      ((float)gds.lam.lLat1)/1000.);
+      fprintf(fp,"Longitude of first grid point = %.3f deg\n",
+      ((float)gds.lam.lLon1)/1000.);
+      fprintf(fp,"Orientation of grid = %.3f deg\n",
+      ((float)gds.lam.lLon_orient)/1000.);
+      fprintf(fp,"First Latitude Cut = %.3f deg\n",
+      ((float)gds.lam.lLat_cut1)/1000.);
+      fprintf(fp,"Second Latitude Cut = %.3f deg\n",
+      ((float)gds.lam.lLat_cut2)/1000.);
+
+      fprintf(fp,"Resolution and Component Flags: \n");
+      if ((gds.lam.usRes_flag >> 7) & 1) {
+            fprintf(fp,"    X-direction increment = %d meters\n",
+            gds.lam.ulDx);
+            fprintf(fp,"    Y-direction increment = %d meters\n",
+            gds.lam.ulDy);
+      }else fprintf(fp,"    Direction increments not given.\n");
+      if ((gds.lam.usRes_flag >> 6) & 1)
+           fprintf(fp,"    Earth assumed oblate spherical.\n");
+      else fprintf(fp,"    Earth assumed spherical.\n");
+      if ((gds.lam.usRes_flag >> 3) & 1)
+           fprintf(fp,"    U&V components resolved relative to +I and "
+                   "+J\n");
+      else fprintf(fp,"    U&V components resolved relative to east "
+                   "and north.\n");
+
+      fprintf(fp,"Scanning Mode Flags: \n");
+      if ((gds.lam.usScan_mode >> 7) & 1)
+           fprintf(fp,"    Points scan in -I direction.\n");
+      else fprintf(fp,"    Points scan in +I direction.\n");
+      if ((gds.lam.usScan_mode >> 6) & 1)
+           fprintf(fp,"    Points scan in +J direction.\n");
+      else fprintf(fp,"    Points scan in -J direction.\n");
+      if ((gds.lam.usScan_mode >> 5) & 1)
+           fprintf(fp,"    Adjacent points in J direction are "
+                   "consecutive.\n");
+      else fprintf(fp,"    Adjacent points in I direction are "
+                   "consecutive.\n");
+
+      /* 02/98 This code pertains only to the Albers projection */
+      if (gds.head.usData_type == ALBERS_PRJ) 
+	{
+	fprintf(fp,"    Latitude of the southern pole = %.3f\n",
+        ((float)gds.lam.lLat_southpole)/1000.);
+	fprintf(fp,"    Longitude of the southern pole = %.3f\n",
+        ((float)gds.lam.lLon_southpole)/1000.);
+      	}
+      break;
+
+/*
+*               Case  4: Gaussian Lat/Lon Projection
+*               Case 14: Rotated Gaussian Lat/Lon Projection
+*               Case 24: Stretched Gaussian Lat/Lon Projection
+*               Case 34: Stretched Rotated Gaussian Lat/Lon Projection
+*/
+    case GAUSS_PRJ:    		/* Gaussian Latitude/Longitude Grid */
+    case ROT_GAUSS_PRJ:   	/* Rotated Gaussian */
+    case STR_GAUSS_PRJ :   	/* Stretched Gaussian */
+    case STR_ROT_GAUSS_PRJ :   	/* Stretched and Rotated Gaussian */
+
+      fprintf(fp,"Number of points along a parallel = %d\n",gds.llg.usNi);
+      fprintf(fp,"Number of points along a meridian = %d\n",gds.llg.usNj);
+      fprintf(fp,"Latitude of first grid point = %.3f deg\n",
+      ((float)gds.llg.lLat1)/1000.);
+      fprintf(fp,"Longitude of first grid point = %.3f deg\n",
+      ((float)gds.llg.lLon1)/1000.);
+      fprintf(fp,"Latitude of last grid point = %.3f deg\n",
+      ((float)gds.llg.lLat2)/1000.);
+      fprintf(fp,"Longitude of last grid point = %.3f deg\n",
+      ((float)gds.llg.lLon2)/1000.);
+
+      fprintf(fp,"Resolution and Component Flags: \n");
+      if ((gds.llg.usRes_flag >> 7) & 1) {
+         fprintf(fp,"    i direction increment = %f deg\n",
+	((float)gds.llg.iDi)/1000.);
+         fprintf(fp,
+	"    Number of parallels between pole and equator = %d\n",
+	gds.llg.iDj);
+      }else fprintf(fp,"    Direction increments not given.\n");
+      if ((gds.llg.usRes_flag >> 6) & 1)
+           fprintf(fp,"    Earth assumed oblate spherical.\n");
+      else fprintf(fp,"    Earth assumed spherical.\n");
+      if ((gds.llg.usRes_flag >> 3) & 1)
+           fprintf(fp,"    U&V components resolved relative to +I and "
+                   "+J\n");
+      else fprintf(fp,"    U&V components resolved relative to east "
+                   "and north.\n");
+
+      fprintf(fp,"Scanning Mode Flags: \n");
+      if ((gds.llg.usScan_mode >> 7) & 1)
+           fprintf(fp,"    Points scan in -I direction.\n");
+      else fprintf(fp,"    Points scan in +I direction.\n");
+      if ((gds.llg.usScan_mode >> 6) & 1)
+           fprintf(fp,"    Points scan in +J direction.\n");
+      else fprintf(fp,"    Points scan in -J direction.\n");
+      if ((gds.llg.usScan_mode >> 5) & 1)
+           fprintf(fp,"    Adjacent points in J direction are "
+                   "consecutive.\n");
+      else fprintf(fp,"    Adjacent points in I direction are "
+                   "consecutive.\n");
+
+      /* added 02/98
+	This code pertains only to the Stretch/Rotate grids
+	*/
+      if (gds.head.usData_type != GAUSS_PRJ) 
+	{
+	fprintf(fp,"    Latitude of southern pole = %.3f deg\n",
+	((float)gds.llg.lLat_southpole)/1000.);
+	fprintf(fp,"    Longitude of southern pole = %.3f deg\n",
+	((float)gds.llg.lLon_southpole)/1000.);
+	
+       /* conv from 'saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb' representation
+           a single precision floating point value */
+        fprintf(fp,"    Angle of rotation = %.3f\n",
+        grib_ibm_local ((unsigned long) gds.llg.lRotate));
+
+	fprintf(fp,"    Latitude of pole of stretching = %.3f deg\n",
+	(float)gds.llg.lPole_lat);
+	fprintf(fp,"    Longitude of pole of stretching = %.3f deg\n",
+	(float)gds.llg.lPole_lon);
+	
+	/* conv from 'saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb' representation
+           a single precision floating point value */
+	fprintf(fp,"    Stretching factor = %.3f\n", 
+	grib_ibm_local ((unsigned long)gds.llg.lStretch));
+	}
+      break;
+
+/*
+*               Case 5: Polar Sterographic Projection
+*/
+    case POLAR_PRJ:    /* Polar Stereographic Projection Grid    */
+      fprintf(fp,"Number of points along X-axis = %d\n",gds.pol.usNx);
+      fprintf(fp,"Number of points along Y-axis = %d\n",gds.pol.usNy);
+      fprintf(fp,"Latitude of first grid point = %.3f deg\n",
+	((float)gds.pol.lLat1)/1000.);
+      fprintf(fp,"Longitude of first grid point = %.3f deg\n",
+	((float)gds.pol.lLon1)/1000.);
+      fprintf(fp,"Orientation of grid = %.3f deg\n",
+	((float)gds.pol.lLon_orient)/1000.);
+      fprintf(fp,"Projection Center: ");
+      if ((gds.pol.usProj_flag >> 7) & 1)
+           fprintf(fp,"South Pole\n");
+      else fprintf(fp,"North Pole\n");
+
+      fprintf(fp,"Resolution and Component Flags: \n");
+      if ((gds.pol.usRes_flag >> 7) & 1) {
+         fprintf(fp,"    X-direction grid length = %d meters\n",gds.pol.ulDx);
+         fprintf(fp,"    Y-direction grid length = %d meters\n",gds.pol.ulDy);
+      }else fprintf(fp,"    Direction increments not given.\n");
+      if ((gds.pol.usRes_flag >> 6) & 1)
+           fprintf(fp,"    Earth assumed oblate spherical.\n");
+      else fprintf(fp,"    Earth assumed spherical.\n");
+      if ((gds.pol.usRes_flag >> 3) & 1)
+           fprintf(fp,"    U&V components resolved relative to +I and "
+                   "+J\n");
+      else fprintf(fp,"    U&V components resolved relative to east "
+                   "and north.\n");
+
+      fprintf(fp,"Scanning Mode Flags: \n");
+      if ((gds.pol.usScan_mode >> 7) & 1)
+           fprintf(fp,"    Points scan in -I direction.\n");
+      else fprintf(fp,"    Points scan in +I direction.\n");
+      if ((gds.pol.usScan_mode >> 6) & 1)
+           fprintf(fp,"    Points scan in +J direction.\n");
+      else fprintf(fp,"    Points scan in -J direction.\n");
+      if ((gds.pol.usScan_mode >> 5) & 1)
+           fprintf(fp,"    Adjacent points in J direction are "
+                   "consecutive.\n");
+      else fprintf(fp,"    Adjacent points in I direction are "
+                   "consecutive.\n");
+      break;
+
+    default:   /* Bad projection:  ignore & continue */ 
+      fprintf(stdout, "\n\n***%s WARNING ***:\nProjection %d is INVALID;\n\n",
+      func, gds.head.usData_type);
+
+      fprintf(fp,"================================================\n"\
+	         "%s:  projection %d is not currently implemented\n"\
+      		"================================================\n",
+      func, gds.head.usData_type);
+      break;
+
+/*
+* A.4.2    ENDSWITCH (Data Type)
+*/
+     } /* Switch */
+
+  } /* gds included */
+/*
+*
+* A.4     ELSE 
+*             PRINT no Gds message
+* A.4     ENDIF
+*/
+  else fprintf(fp,"\n******* NO SECTION 2 GDS *********\n" );
+
+
+/*
+*
+* A.5   IF (Bitmap Section is present)
+*       THEN
+*          WRITE Bitmap Section information to file
+*       ELSE
+*          PRINT no bms mesg
+*       ENDIF
+*/
+  if(pds.usGds_bms_id >> 6 & 1) {
+    fprintf(fp,"\n********* SECTION 3 BMS **********\n" );
+    fprintf(fp,"Section length = %ld\n", bms.uslength);
+    if (bms.uslength <= 6)
+      fprintf(fp,"Bitmap is predefined (Not in message).\n");
+    else fprintf(fp,"Bitmap is included with message.\n");
+    fprintf(fp,"Bitmap ID = %d \n", bms.usBMS_id);
+    fprintf(fp,"Number of unused bits = %d\n", bms.usUnused_bits);
+    fprintf(fp,"Number of datapoints set = %ld\n", bms.ulbits_set);
+  }else{
+    fprintf(fp,"\n******* NO SECTION 3 BMS *********\n" );
+  }
+
+/*
+*
+* A.6   WRITE out Binary Data Section Information to file 
+*       !Section Length
+*/
+  fprintf(fp,"\n********* SECTION 4 BDS *********\n" );
+  fprintf(fp,"Section length = %ld\n",bds.length);
+
+/*
+*       !Table 11 Flags
+*/       
+  fprintf(fp,"Table 11 Flags:\n");
+  if ((bds.usBDS_flag >> 7) & 1)
+       fprintf(fp,"    Spherical harmonic coefficients.\n");
+  else fprintf(fp,"    Grid-point data.\n");
+  if ((bds.usBDS_flag >> 6) & 1)
+       fprintf(fp,"    Second-order packing.\n");
+  else fprintf(fp,"    Simple Packing.\n");
+  if ((bds.usBDS_flag >> 5) & 1)
+       fprintf(fp,"    Integer values.\n");
+  else fprintf(fp,"    Floating point values.\n");
+  if ((bds.usBDS_flag >> 4) & 1)
+       fprintf(fp,"    Octet 14 contains additional flag bits.\n");
+  else fprintf(fp,"    No additional flags at octet 14.\n");
+
+/*
+*       !Decimal Scale Factor (Repeated from PDS)
+*/
+  fprintf(fp,"\nDecimal Scale Factor = %d\n",pds.sDec_sc_fctr);
+
+/*
+*       !Binary Scale Factor
+*       !Bit Width
+*       !Number of Data Points
+*/
+  fprintf(fp,"Binary scale factor = %d\n", bds.Bin_sc_fctr);
+  fprintf(fp,"Bit width = %d\n", bds.usBit_pack_num);
+  fprintf(fp,"Number of data points = %ld\n",bds.ulGrid_size);
+
+/*
+* A.6.1   WRITE Data Summary to file
+*         !Compute Data Min/Max and Resolution
+*/
+  dsf = (float) pow( (double) 10, (double) pds.sDec_sc_fctr);
+  res = (float) pow((double)2,(double)bds.Bin_sc_fctr) / dsf;
+  min = bds.fReference / dsf;
+  max = (float) (pow((double)2, (double)bds.usBit_pack_num) - 1);
+  max = min + max * res;
+  fprintf(fp,"Data Minimum = %f\n", min );
+  fprintf(fp,"Data Maximum = %f\n", max );
+  fprintf(fp,"Resolution = %f\n",res );
+
+/*
+*         !Compute Format Specifier for printing Data
+*/
+  fd = (int) -1 * (float) log10((double) res) + .5; 
+  if (fd <= 0)
+  {
+    fd = 0;
+    fprintf(fp,"DATA will be displayed as integers (res > 0.1).\n");
+  }
+
+/*
+*         !WRITE First 100 Data Points to file up to Encoded Precision
+*/
+  if (bds.ulGrid_size > 1) {
+  if (bds.ulGrid_size < 100) numpts = bds.ulGrid_size;
+  fprintf(fp,"\nDATA ARRAY: (first %d)\n",numpts);
+  if (fd > 0)  {
+	for (i=0; i
+#include 
+#include "dprints.h"	  /* for debug printing  */
+#include "grib_lookup.h"  /* LVL_DEFN */
+#include "gribfuncs.h"		/* prototypes */
+
+extern LVL_DEFN    db_lvl_tbl[NLEV];     /* defined in ld_dec_lookup.c */
+
+/*
+************************************************************************
+* A. FUNCTION:  map_lvl
+*       Map the given Level_type to its appropriate usLevelid, scale up the
+*       Level_1 and Level_2 to GRIB unit and also return the Scale Factor, 
+*       Reference.
+*
+*    INTERFACE:
+*       int map_lvl (lvl_type, data_input, lvl_scl_fctr, lvl_reference, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)   char *lvl_type;
+*            name of Level to look for in the array of Level structures;
+*      (I&O) DATA_INPUT *data_input;
+*            structure holding data pertaining to current message required by
+*            the encoder;  Three of its attributes get filled (usLevel_id, 
+*            nLvl_1, nLvl_2);
+*      (O)   float *lvl_scl_fctr, float *lvl_reference;
+*            numbers needed to scale the Level up to GRIB unit.
+*            multiply the level value by the Scale Factor, then add to the
+*            Reference to convert to GRIB unit;
+*      (O)   char *errmsg;
+*            empty array, returned filled if error occurred;
+*
+*      RETURN CODE:
+*        0: success, DATA_INPUT filled, fbuff may have changed;
+*        1: parameter not found, errmsg filled; 
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int   map_lvl ( char		*lvl_type,
+		DATA_INPUT  	*data_input,
+		float		*lvl_scl_fctr,
+		float		*lvl_reference,
+		char		*errmsg)
+#else
+int   map_lvl ( lvl_type, data_input, lvl_scl_fctr, lvl_reference,errmsg)
+		char		*lvl_type;
+		DATA_INPUT  	*data_input;
+		float		*lvl_scl_fctr;
+		float		*lvl_reference;
+		char		*errmsg;
+#endif
+{
+char	*func= "map_lvl";
+int	indx= 0;		/* index for array */
+int	found = 0;		/* set if located level  */
+LVL_DEFN   *PL;			/* working var */
+
+ DPRINT1 ("Entering %s\n", func);
+/*
+* A.1       SEARCH the Level info table for the given Level Type
+*/
+   for (PL=db_lvl_tbl; indx < NLEV ; PL=(++indx +db_lvl_tbl)) 
+	if (PL->db_name[0] && !strcmp (PL->db_name, lvl_type))  {
+		found=1; break; 
+	   }
+/*
+*
+* A.2       IF (cannot find it) THEN
+*              FILL errmsg with message
+*              RETURN 1  ! bad status
+*           ENDIF
+*/
+   if (!found) { 
+	DPRINT1 ("No '%s' in db_lvl_tbl;\n", lvl_type);
+	sprintf (errmsg, "%s:  no '%s' in db_lvl_tbl;", func, lvl_type);
+	return (1); 
+	}
+/*
+*
+* A.3       SCALE up nLvl_1 and nLvl_2 to GRIB's unit
+*/
+   data_input->nLvl_1 = (int)(data_input->nLvl_1 * PL->fScale + PL->fOffset);
+   data_input->nLvl_2 = (int)(data_input->nLvl_2 * PL->fScale + PL->fOffset);
+   
+/*
+*
+* A.4       FILL in Level_id DATA_INPUT struct
+*           FILL in caller's Scale factor & Reference
+*/
+   data_input->usLevel_id       = PL->usLevel_id;
+   *lvl_scl_fctr	 	= PL->fScale; 
+   *lvl_reference 		= PL->fOffset;
+
+/*
+*
+* A.5       RETURN with no errors
+*/
+   DPRINT6 (
+    "Found '%s'\nfill Data_Input->usLevel_id=%d; *lvl_scl=%lf, *lvl_ref=%lf\n"\
+    "Scaled up Data_Input->nLvl_1= %d\nScaled up Data_Input->Lvl_2= %d\n",
+    lvl_type,
+    data_input->usLevel_id , *lvl_scl_fctr ,*lvl_reference,
+    data_input->nLvl_1, data_input->nLvl_2);
+  
+   DPRINT1 ("Exiting %s with no errors\n", func);
+   return (0);
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/map_parm.c b/wrfv2_fire/external/io_grib1/MEL_grib1/map_parm.c
new file mode 100644
index 00000000..18b2d049
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/map_parm.c
@@ -0,0 +1,139 @@
+#include 
+#include 
+#include "dprints.h"	  /* for debug printing  */
+#include "grib_lookup.h"  /* PARM_DEFN */
+#include "gribfuncs.h"		/* prototypes */
+
+/* DB_PARM_TBL is defined in ld_enc_inputs.c:
+#  as of 4/9/97 this tbl is the master Parameter Table holding
+#  MAX_PARM_TBLS  sets of 256 parameters (previously known as 
+#  Tbl 0/A/B/C/D/E).
+#  Index that are divisable by 256 are reserved and not used;
+#    indices   000-255:  Main parameter tbl (000 is reserved & not used)
+#    indices   256-511:  subtable A (256 is reserved & not used)
+#    indices   512-767:  subtable B (512 is reserved & not used)
+#    indices  768-1023:  subtable C (768 is reserved & not used)
+#    indices 1024-1279:  subtable D (1024 is reserved & not used)
+#    indices 1080-1535:  subtable E (1080 is reserved & not used)
+*/
+extern PARM_DEFN    db_parm_tbl[];
+
+/*
+************************************************************************
+* A. FUNCTION:  map_parm
+*      Map the given Parm_name to its appropriate usParm_id and usParm_sub
+*      within the Parameter Lookup table, and also return its
+*      Scale Factor and Reference which the caller can apply to the
+*      float dta at a later time.
+*
+*    INTERFACE
+*      int  map_parm (parm_name, data_input, parm_scl, parm_ref, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  char *parm_name
+*           Name of Parameter to look for in the array of Parameter structs
+*      (I&O) DATA_INPUT *data_input
+*           attributes (usParm_id, usParm_sub_id, nDec_sc_fctr) are filled;
+*      (O)  float *parm_scl       
+*           used along with parm_ref to convert data to GRIB unit
+*      (O)  float *parm_ref       
+*           used along with parm_scl to convert data to GRIB unit
+*                      
+*    RETURN CODE:
+*      0> success, DATA_INPUT, parm_scl and parm_ref filled 
+*      1> parameter not found, errmsg filled; 
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int     map_parm ( char		*parm_name,
+		DATA_INPUT  	*data_input,
+		float		*parm_scl, 
+		float		*parm_ref,
+		char		*errmsg)
+
+#else
+int     map_parm ( parm_name, data_input, parm_scl, parm_ref, errmsg)
+		char		*parm_name;
+		DATA_INPUT  	*data_input;
+		float		*parm_scl;
+		float		*parm_ref;
+		char		*errmsg;
+#endif
+{
+char	*func= "map_parm";
+int	indx= 0;		/* index for array */
+int	found = 0;		/* set if located parm */
+PARM_DEFN   *P;			/* working var */
+
+  DPRINT1 ("Entering %s\n", func);
+
+/*
+* A.1       SEARCH the Parameter info table for the given Parm Name
+*/
+   for (P=db_parm_tbl; indx < NPARM*MAX_PARM_TBLS; P=(++indx +db_parm_tbl)) 
+	if (P->db_name[0] && !strcmp (P->db_name, parm_name))  {
+		found=1; break; 
+	   }
+/*
+*
+* A.2       IF (cannot find it) THEN
+*              FILL errmsg with message
+*              RETURN 1  ! bad status
+*           ENDIF
+*/
+   if (!found) { 
+	DPRINT1 ("No '%s' in db_parm_tbl;\n", parm_name);
+	sprintf (errmsg, "%s: no '%s' in db_parm_tbl", func, parm_name);
+        DPRINT1 ("Exiting  %s, with errors\n", func);
+	return (1); 
+	}
+/*
+*
+* A.3       FILL in Parmid, subParmid, nDec_sc_fctr of DATA_INPUT struct
+*           FILL in Parm_scl and Parm_ref for caller
+*/
+   data_input->usParm_id      = P->usParm_id;
+   data_input->usParm_sub_id  = P->usParm_sub;
+   data_input->nDec_sc_fctr   = P->sDSF;
+   *parm_scl		= P->fScale;
+   *parm_ref		= P->fOffset;
+
+   DPRINT4 (
+   "Found '%s'\nfill Data_Input->Parm_id=%d; \nfill Data_Input->Parm_sub=%d;"\
+   "\nfill Data_Input->DSF=%d\n",
+   parm_name, data_input->usParm_id, data_input->usParm_sub_id,
+   data_input->nDec_sc_fctr);
+
+/*
+#*
+* A.4       /# comment #/
+#* A.4       IF (there is a scl fctr  OR nonzero Offset) THEN
+#*               APPLY Scale Fctr and Offset to Float data
+#*               for all data points in grid 
+#*           ENDIF
+##/
+#  ... where... data_pts was passed in as an argument...
+#
+#   if (P->fScale != 1.0 || P->fOffset != 0.0) {
+#	DPRINT3 ("Scaling FloatArr[%d pts] w/ Scale=%lf, Off=%lf\n",
+#	data_pts,  P->fScale , P->fOffset);
+#
+#      	for (indx=0; indx < data_pts; ++indx)
+#		fbuff[indx]=  fbuff[indx] * P->fScale + P->fOffset;
+#	}
+#   else { DPRINT2("Not scaling float dta  (Scl=%lf, Offs=%lf)\n",
+#   	 P->fScale , P->fOffset); 
+#	}
+*/
+   
+/*
+*
+* A.5       RETURN with no errors
+*/
+   DPRINT1 ("Exiting %s with no errors\n", func);
+   return (0);
+/*
+*
+* END OF FUNCTION
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/pack_spatial.c b/wrfv2_fire/external/io_grib1/MEL_grib1/pack_spatial.c
new file mode 100644
index 00000000..1b6c20af
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/pack_spatial.c
@@ -0,0 +1,650 @@
+/* 20jun97/atn:  always scaling data up whether dsf is -/+; 
+*/
+#include  
+#include 
+#include  
+#include 
+#ifdef XT3_Catamount
+#include 
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#else
+#include 
+#endif
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+#include "isdb.h"		/* WORD_BIT_CNT defn */
+
+/*
+****************************************************************
+* A. FUNCTION:   pack_spatial
+*      pack gridded data values into a bitstream 
+*
+*    INTERFACE:
+*      int     pack_spatial (pt_cnt, bit_cnt, pack_null, fbuff, ppbitstream,
+*                           dec_scl_fctr, BDSlength, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*     (I) long *pt_cnt;                count of points in grid 
+*     (I) long *bit_cnt;               count of bits to pack value in.  
+*                                      will be calculated if set to zero
+*     (I) float *pack_null;            parameter value for null (huge number) 
+*   (I&O) float *fbuff;                array containing grid values to pack
+*                                     returned scaled up by Decimal Scale Factor
+*     (O) unsigned long **ppbitstream; Null upon entry; 
+*                                      returned pointing to new Storage 
+*                                      holding packed bitstream;
+*     (I) short dec_scl_fctr;          decimal scale factor to apply to data
+*     (O) long  *BDSlength;            updated with #bytes in packed bitstream
+*     (O) char  *errmsg                returned filled if error occurred
+*
+*    RETURN CODE: 
+*      0> success, ppbitstream contains packed values
+*   else> error: errmsg holds msg;
+****************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int	pack_spatial ( long   		*pt_cnt,
+			unsigned short	*bit_cnt,
+			float		*pack_null,
+			float 		*fbuff,
+			unsigned long 	**ppbitstream,
+			short   	dec_scl_fctr,
+			long    	*BDSlength,
+			char    	*errmsg)
+
+#else
+int	pack_spatial (  pt_cnt, bit_cnt, pack_null, fbuff, ppbitstream,
+			dec_scl_fctr, BDSlength, errmsg)
+			long   		*pt_cnt;
+			unsigned short	*bit_cnt;
+			float		*pack_null;
+			float 		*fbuff;
+			unsigned long  	**ppbitstream;
+			short   	dec_scl_fctr;
+			long    	*BDSlength;
+			char    	*errmsg;
+#endif
+{
+    char *func="pack_spatial";
+    long ipt;			/* index over points */
+    int null_flag;		/* flag indicating presence of null values */
+    int bit1;			/* starting bit in current word */ 
+    int empty;			/* number of empty bits in word */ 
+    int diff;			/* difference of empty - bit1 */ 
+    long max_value;		/* max value storable in bit_cnt bits */
+    unsigned long itemp;	/* temporary unsigned integer */
+    unsigned long *bstr;	/* pointer running across bitstream */
+    int pack_bit_cnt;		/* count of bits to pack parameter values */ 
+    int unused_bit_cnt; 	/* count of unused bits for i2 words */
+    /*long byte4_cnt;		/- count of bytes using i4 words */
+    long byte2_cnt;		/* count of bytes using i2 words */
+    short scl_fctr;		/* scaling factor for grid values */
+    double pow_scl;		/* 2 ** (-scl_fctr) */
+    double pwr10toD;		/* 10 ** (D) */
+    float reference;		/* reference = minimum value in grid */
+    float max_grid;		/* maximum value in grid */
+    float ftemp;		/* temporary float containing grid value */
+    unsigned long *pBitstream;
+    unsigned long grib_local_ibm();
+    int wordnum;
+    int zero_cnt;
+    int prec_too_high = 0;
+    unsigned char bdshdr[14];   /* Character array to temporarily hold bds
+                                 *   header */
+    int hdrwords;
+
+    DPRINT1 ( "Entering %s....\n", func );
+
+/*
+*
+* A.1       IF (no data in grid) THEN
+*              PRINT message
+*              RETURN Stat= -1
+*           ENDIF
+*/
+    if (*pt_cnt <= 0) {
+	DPRINT2 ("%s; invalid pt_cnt = %d\n", func,*pt_cnt);
+	sprintf(errmsg, "%s; invalid pt_cnt = %d\n", func,*pt_cnt);
+	return (-1);
+    }
+
+/*
+*
+* A.2       IF (number of bits to pack into is greater than 30) THEN
+*               PRINT message
+*               RETURN Stat= -1
+*           ENDIF
+*           SET pack_bit_cnt for local use
+*/
+    if ( *bit_cnt > 30 ) {
+	DPRINT2 ("%s; invalid bit_cnt = %d\n", func,*bit_cnt);
+	sprintf(errmsg, "%s; invalid bit_cnt = %d\n", func,*bit_cnt);
+	return (-1);
+    }
+    pack_bit_cnt	= (int) *bit_cnt; 
+    DPRINT1 ("  use Pack_bit_cnt= %d\n", pack_bit_cnt);
+
+/*
+*  		
+* A.3      FOR (each data point) DO
+*              SCALE all values of data array  !multiply by 10**DSF
+*          ENDDO
+*/
+	pwr10toD=  pow ( 10., (double) dec_scl_fctr );
+	for (ipt=0; ipt < *pt_cnt; ipt++)  fbuff[ipt] *= pwr10toD;
+
+        DPRINT2 ("  Decimal Scale Fctr= %d, scale data by 10**dsf "\
+	"(Fbuff *= %lf)\n", dec_scl_fctr,  pwr10toD);
+/*
+*
+* A.4       INIT reference, max_grid, null_flag 
+*/
+    reference  	= 1.e30;
+    max_grid  	= -1.e30;
+    null_flag 	= 0;
+
+/*
+*
+* A.5       FOR (each data point) DO
+*              IF (value < reference) THEN
+*                  SET reference to this value   !smallest value
+*              ENDIF
+*              IF (value > max_grid AND not a missing value ) THEN
+*                  SET max_grid to this value    !largest value
+*              ENDIF
+*              IF (value >= missing value ) THEN
+*                  SET null_flag to 1            !grid contains nulls
+*              ENDIF
+*           ENDDO
+  Find reference (minimum) and maximum values of the grid points 
+*/
+    for (ipt = 0; ipt < *pt_cnt; ipt++) {
+	ftemp	= *(fbuff+ipt);
+	if (ftemp < reference) reference = ftemp;    /* REF is SCALED UP */
+	if (ftemp > max_grid && ftemp < *pack_null) max_grid = ftemp;
+	if (ftemp >= *pack_null) null_flag = 1;
+    }
+
+    DPRINT2 ("  Max before taking out Ref =%.4lf\n  Null flag=%d\n",
+    max_grid, null_flag);
+
+/*  Compute maximum range of grid (max_grid - reference) */
+/*
+*
+* A.6       IF (max value is same as smallest value AND
+*               null_flag is zero) THEN
+*               CLEAR pack_bit_cnt  !constant values, no nulls
+*               CLEAR max_grid      !set grid range to 0
+*/
+    if (((max_grid - reference) < 1.0) && null_flag == 0) {   
+	pack_bit_cnt = 0;
+        max_grid =  0;
+
+/*
+* A.6.a     ELSE IF (max value is same as smallest value AND
+*                    null_flag is set) THEN
+*               SET max_grid to 1      !const values, some nulls
+*/
+    } else if (((max_grid - reference) < 1.0) && null_flag == 1) {
+	max_grid = 1.;
+
+/*
+* A.6.b     ELSE IF (max value <= -1.e29 AND null_flag is set) THEN
+*               PRINT message
+*               RETURN Stat= -1
+*/
+    } else if (max_grid <= -1.e29 && null_flag == 1) {
+	DPRINT1 ("%s; Grid contains all NULLS\n",func);
+	sprintf(errmsg, "%s; Grid contains all NULLS\n",func);
+	return (-1);
+
+/*
+* A.6.c     ELSE IF (max value not equal to reference) THEN
+*               SET max_grid (max_grid-reference) !non-constant values w/wo nulls
+*/
+    } else if (max_grid != reference) {
+	max_grid -= reference;
+
+/*
+* A.6       ENDIF
+*/
+    }
+
+/*
+* 
+* A.7       DEBUG print grid range and reference value
+*/
+    DPRINT2 ( "  Reference = %f\n  Max_grid (range) = %f\n",  
+    reference, max_grid);
+
+/*  Find minimum number of bits to pack data */
+/*
+*
+* A.8.a     IF (grid range is not zero) THEN
+*/
+    if ( max_grid != 0 )    
+    {
+
+/*
+*
+* A.8.a.1      DEBUG print input bit width
+*              IF (input bit_num is zero) THEN
+*                 CALCULATE number of bits needed to store grid range
+*                 DEBUG print calculated bit count
+*              ENDIF
+*/
+       DPRINT1 ( "  Input bit cnt = %d\n", pack_bit_cnt );
+       if ( pack_bit_cnt == 0 )
+       {
+          pack_bit_cnt = (int)(floor(log10((double)max_grid) / log10(2.)) +1); 
+          DPRINT1 ( "  Calculated bit cnt = %d\n", pack_bit_cnt );
+       }
+       if ( (pack_bit_cnt < 0) || (pack_bit_cnt > 30) )
+       {
+          DPRINT1 ("%s: Calculated bit count OUT OF RANGE [0 - 30] !!\n", func);
+          sprintf (errmsg, "%s: Calculated bit count OUT OF RANGE!! bit_cnt: %d  max: %f\n", func,pack_bit_cnt,max_grid);
+          return (-1);
+       }
+/*
+*
+* A.8.a.2      CALCULATE various byte counters
+*              !itemp: #bits required for header + grid
+*              !Byte2_cnt: #bytes rounded up to next 2-byte bdry
+*              !Byte4_cnt: #bytes rounded up to next 4-byte bdry
+*              !Unused_bit_cnt: #unused bits at end using byte2_cnt
+*              DEBUG print expected length and unused bits
+*/
+       itemp = *pt_cnt * pack_bit_cnt + 11 * BYTE_BIT_CNT;
+       byte2_cnt = (long) ceil(((double) itemp / BYTE_BIT_CNT) / 2.) * 2;
+       /*byte4_cnt = (long) ceil(((double) itemp / BYTE_BIT_CNT) / 4.) * 4;*/
+       unused_bit_cnt = byte2_cnt * BYTE_BIT_CNT - itemp;
+       DPRINT1 ( "  Calculated length = %ld bytes (Rnd2)\n", byte2_cnt);
+       DPRINT1 ( "  Bitstream padding = %ld bits\n",unused_bit_cnt);
+
+/*
+*
+* A.8.a.3      CALCULATE maximum storable value 
+*              CALCULATE scl_fctr required to fit grid range
+*                        into available bit width
+*/
+       max_value = (long) pow(2., (double) pack_bit_cnt) - 1;
+       if (max_value < 2) max_value = 2;
+       scl_fctr	= -(short) floor(log10((double) (max_value-1) / 
+		  	  (double) max_grid) / log10(2.));
+       pow_scl 	= pow(2., (double) -scl_fctr); 
+       DPRINT1 ( "  Calculated Binary scale = %d\n",scl_fctr);
+    }
+
+/*
+*
+* A.8.b     ELSE       !max_grid = 0, all zero data or constant values
+*              SET number of bits to pack to zero
+*              SET lengths to 12 bytes
+*              SET unused bits to 8 (1 byte of padding)
+*              SET scl_fctr to 0
+*              DEBUG print constant grid
+*           ENDIF
+*/
+    else
+    {
+       pack_bit_cnt = 0;
+       byte2_cnt = 12;
+       /*byte4_cnt = 12;*/
+       unused_bit_cnt	= 8;
+       scl_fctr	= 0;
+       DPRINT0 ( "  Constant grid.  Using bit cnt = 0\n");
+    }
+
+/*
+*
+* A.9       MALLOC space for bitstream (Rnd2_cnt)
+*           IF (failed) THEN
+*              PRINT error mesg
+*              RETURN Stat= 999;
+*           ENDIF
+*/ 
+    pBitstream = ( unsigned long * ) malloc ( sizeof( unsigned long ) * 
+					      byte2_cnt );
+    if ( !pBitstream )
+    {
+       DPRINT1 ("%s:  MAlloc failed pBitstream\n", func );
+       sprintf(errmsg, "%s:  MAlloc failed pBitstream\n", func );
+       return (999);
+    }
+
+/*
+*
+* A.10      SET ptr to bitstream
+*           UPDATE bit_cnt for input structure
+*/
+    *bit_cnt = (unsigned short) pack_bit_cnt;
+    DPRINT1 ("  Updated input bit cnt to %d\n", *bit_cnt);
+    bstr = pBitstream;
+ 
+/*
+*
+* A.11      ZERO out entire bitstream
+*/
+   zero_cnt = ceil(byte2_cnt / (float)sizeof(long)) * sizeof(long);
+   memset ((void *)pBitstream, '\0', zero_cnt);
+
+/*
+*
+* A.12      PUT packing info into first 11 bytes: 
+*           NOTE: The Table 11 Flag stored in the first
+*                 4 bits of Octet 4 is HARDCODED to 0000.
+*                 This implies Simple packing of float
+*                 grid point data with no additional flags.
+*           Octet 1-3  = Byte2_cnt
+*           Octet 4    = Table 11 Flag & unused_bit_cnt
+*           Octet 5-6  = Scl_fctr
+*           Octet 7-10 = Reference truncated to DSF precision
+*           Octet 11   = Pack_bit_cnt
+*           Octet 12   = Bitstream starts (bit 25 of word 3)
+*/
+
+
+   set_bytes_u(byte2_cnt, 3, bdshdr);
+
+   itemp = unused_bit_cnt;
+   set_bytes_u(itemp, 1, bdshdr+3);
+
+   set_bytes_u(scl_fctr, 2, bdshdr+4);
+
+   DPRINT1 ("  Reference (%f) ", reference);
+   reference   =  floor((double) reference + .5);
+   DPRINT1 ("truncated to DSF precision= %lf\n", reference);
+   itemp        = grib_local_ibm(reference);
+   DPRINT1 ("  Reference converted to local IBM format= 0x%x\n", itemp);
+
+   set_bytes_u(itemp, 4, bdshdr+6);
+
+   set_bytes_u(pack_bit_cnt, 1, bdshdr+10);
+
+   bit1 = 25;
+
+   memcpy(bstr,bdshdr,11);
+
+   /* 
+    * For non-internet byte order machines (i.e., linux), 
+    * We reverse the order of the last byte in the bds header, since
+    *   it will be reversed once again below.
+    */
+   hdrwords = 11/(WORD_BIT_CNT/BYTE_BIT_CNT);
+   set_bytes_u(bstr[hdrwords], WORD_BIT_CNT/BYTE_BIT_CNT,
+              (char *)(bstr+hdrwords) );
+
+   bstr += hdrwords;
+
+
+/*
+    itemp	= unused_bit_cnt;
+    *bstr	= (byte2_cnt << 8) | itemp;
+    bstr++;
+    *bstr	= scl_fctr;
+
+    DPRINT1 ("  Reference (%f) ", reference);
+    reference   =  floor((double) reference + .5);
+    DPRINT1 ("truncated to DSF precision= %lf\n", reference);
+    itemp	= grib_local_ibm(reference);
+    DPRINT1 ("  Reference converted to local IBM format= 0x%x\n", itemp);
+
+    *bstr	= (*bstr << 16) | (itemp >> 16);
+    bstr++;
+    *bstr	= (itemp << 16) | (pack_bit_cnt << 8);
+    bit1	= 25;  	*/	 /* starting bit within current bstr word */
+
+/*
+*
+* A.13      IF (grid values are not constant) THEN
+*/ 
+    if (pack_bit_cnt > 0) {
+
+
+/*
+* A.13.1       SET empty value
+*/
+   	empty = WORD_BIT_CNT - pack_bit_cnt + 1;
+
+	for (ipt=0; ipt < 5; ipt++) DPRINT4 (
+	    " ITEMP= (*(fbuff+ipt) - reference) * pow_scl + .5=\n"\
+	    "        (%lf -%lf) * %lf + .5 = %lf\n",
+	    *(fbuff+ipt), reference, pow_scl, 
+	    (*(fbuff+ipt) - reference) * pow_scl + .5);
+	   
+/*
+* A.13.2       FOR (each point in bitstream) DO
+*/
+	for (ipt = 0; ipt < *pt_cnt; ipt++) {
+
+/*
+* A.13.2.1         IF ( data value < pack_null) THEN
+*                     SET itemp to (value - reference) * pow_scl + .5;
+*                  ELSE
+*                     SET itemp to max value;
+*                  ENDIF
+*/
+	    if (*(fbuff+ipt) < *pack_null) {
+	    	itemp  = (*(fbuff+ipt) - reference) * pow_scl + .5;
+	    } else {
+	    	itemp  = max_value; 
+		DPRINT1 ("%s: Setting to max_value: Precision may be too high !!\n", func);
+		sprintf (errmsg, "%s: Setting grid point to max value, precision may be too high", func);
+		/*		return (-1); */
+	    }
+
+/*
+* A.13.2.2         COMPUTE if data point can fit in current word
+*/
+	    diff	= empty - bit1;
+
+/*
+* A.13.2.3.a       IF (data point falls within word ) THEN
+*                      SHIFT value to the correct bit position 
+*                      COMBINE it with data in current word of bitstream
+*                      CALCULATE starting bit in curr word for next time
+*/
+	    if (diff > 0)
+            {
+		*bstr 	|= itemp << diff;
+		bit1 	+= pack_bit_cnt;
+	    }
+
+/*
+* A.13.2.3.b       ELSE IF (data point ends at word boundary) THEN
+*                      COMBINE value with data in current word of bitstream
+*                      SET starting bit to 1
+*                      BUMP word counter in bitstream up by 1 word
+*/
+	    else if (diff == 0) 
+            {
+	        *bstr |= itemp;
+	        bit1   = 1;
+	        bstr++;
+	    }
+
+/*
+* A.13.2.3.c       ELSE     !point crosses word boundary
+*                      STORE "diff" bits of value in current word of bitstream
+*                      BUMP word counter in bitstream up by 1 word
+*                      STORE remaining bits of value in next word
+*                      CALCULATE starting bit in curr word for next time
+*                  ENDIF    !word location check
+*/
+	    else  		/* pixel crosses word boundary */
+            {
+	        *bstr |= itemp >> -diff;
+	        bstr++;
+	        *bstr |= itemp << (WORD_BIT_CNT + diff);
+	        bit1   = -diff + 1;
+    	    }
+
+/*
+* A.13.2        ENDFOR loop over grid points
+*/
+       }
+
+/*
+* A.13       ENDIF (pack_bit_cnt > 0)
+*/
+    }
+
+/* For little endian machines, swap the bytes in the bstr pointer */
+    /*    for (wordnum = 0; */
+    for (wordnum = hdrwords;
+	 wordnum < ceil(byte2_cnt/(float)(WORD_BIT_CNT/BYTE_BIT_CNT)); 
+	 wordnum++) {
+      set_bytes_u(pBitstream[wordnum], WORD_BIT_CNT/BYTE_BIT_CNT, 
+		  (char *)(pBitstream+wordnum) );
+    }
+
+/*
+*
+* A.14       ASSIGN bitstream block to ppbitstream pointer
+*            SET BDSlength (size rnded to next 2 byte boundary)
+*            RETURN Status 0  ! success
+*/
+    *ppbitstream = pBitstream;
+    *BDSlength = (long) byte2_cnt;
+
+    DPRINT1 ("Exiting pack_spatial, BDS len=%ld,  Status=0\n" , *BDSlength);
+
+    if (prec_too_high) {
+	fprintf(stderr,"pack_spatial: Warning: Precision for a parameter may be too high in gribmap.txt\n");
+    }
+    return (0);
+/*
+* END OF FUNCTION
+*
+*/
+}
+
+/*
+*
+**************************************************************
+* B. FUNCTION  grib_local_ibm
+*      convert local_float from local floating point to
+*      IBM floating point stored in a 4-byte integer.
+*
+*    INTERFACE:
+*      unsigned long grib_local_ibm (local_float)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  double local_float      float value in local format
+*
+*    RETURNS:
+*       the actual IBM floating point value
+**************************************************************
+*
+*/
+#if PROTOTYPE_NEEDED
+unsigned long grib_local_ibm (double local_float)
+#else
+unsigned long grib_local_ibm (local_float)
+double local_float;
+#endif
+{
+    long a, b; 
+    unsigned long ibm_float;
+/*
+*
+* B.1.a     IF (local float value is zero) THEN
+*               SET the ibm float to zero too
+*/
+    if (local_float == 0.) { 
+        ibm_float = 0;
+    } else {
+/*
+* B.1.b     ELSE
+*              CONVERT to IBM floating point
+*              ! IBM floating point is stored in 4 bytes as:  
+*              ! saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb
+*              ! where s is sign bit, 0 -> positive, 1 -> negative
+*              !       a is 7-bit characteristic
+*              !       b is 24-bit fraction
+*              ! s, a and b are obtained from local_float (local 32-bit float) as
+*              !       s = sign(local_float)
+*              !       a = ceil(log10(local_float) / log10(16.)) + 64 
+*              !       b = local_float / 16**(a-64) * 2**24
+* B.1.b     ENDIF
+*/
+        a = ceil(log10(fabs(local_float)) / log10(16.)) + 64;
+	/* Added by Todd Hutchinson, 8/13/99 */
+	/* This fixes a problem when local_float == 256, etc. */
+	if ( fmod((log10(fabs(local_float))/log10(16.)),1.) == 0) {
+	  a++;
+	}
+/*      Local_float == +/-1. is a special case because of log function */
+        if ( (local_float == 1.) || (local_float == -1.)) a = 65;
+        b = (long) (fabs(local_float) * pow(16.,(double) (70 - a)) +.5)
+            & 0x00ffffff; 
+        ibm_float = (((local_float > 0.) ? 0 : 1) << 31) | (a << 24) | b;
+    }
+/*
+*
+* B.2       RETURN the ibm float value
+*/
+    return ibm_float;
+/*
+*
+* END OF FUNCTION
+*
+*/ }
+
+/*
+*
+**************************************************************
+* C. FUNCTION:   grib_ibm_local
+*      convert local_float from IBM floating point to
+*      local floating point.
+*
+*    INTERFACE:
+*      float grib_ibm_local(ibm_float)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  double local_float      float value in local format
+*
+*     RETURNS:
+*        the actual local floating point
+**************************************************************
+*/
+#if PROTOTYPE_NEEDED
+float grib_ibm_local( unsigned long ibm_float)
+#else
+float grib_ibm_local( ibm_float)
+unsigned long ibm_float;
+#endif
+{
+/*
+  Convert ibm_float from IBM floating point stored in a 4-byte integer 
+  to local floating point.
+*
+* C.1       DETERMINE local floating point
+*           ! IBM floating point is stored in 4 bytes as:  
+*           ! saaaaaaa bbbbbbbb bbbbbbbb bbbbbbbb
+*           ! where s is sign bit, 0 -> positive, 1 -> negative
+*           !       a is 7-bit characteristic
+*           !       b is 24-bit fraction
+*           ! local_float (local 32-bit float) is recovered from 
+*           ! s, a and b as
+*           ! local_float = (-1)**s * 2**(-24) * b * 16**(a-64)
+*/
+
+    long a, b;
+    float local_float;
+
+    a = (ibm_float >> 24) & 0x0000007f;
+    b = ibm_float & 0x00ffffff;
+    local_float = (float) b * pow(16., (double) (a - 70));
+    if (ibm_float >> 31) local_float = -local_float;
+/*
+*
+* C.2       RETURN floating point
+*/
+    return local_float;
+/*
+* END OF FUNCTION
+*
+*/ 
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/prt_badmsg.c b/wrfv2_fire/external/io_grib1/MEL_grib1/prt_badmsg.c
new file mode 100644
index 00000000..2be1ed33
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/prt_badmsg.c
@@ -0,0 +1,328 @@
+#include 
+#include 
+#include "gribfuncs.h"
+/*
+**************************************************************************
+* A.  FUNCTION:  prt_badmsg
+*     Print out as much information as possible from the GRIB message
+*     currently in GRIB_HDR structure.  This may be an erroneous or
+*     a partial message.
+*
+*    INTERFACE:
+*      int  prt_badmsg (gh, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I)  GRIB_HDR *gh;
+*           pointer to Grib header structure.
+*      (O)  char *errmsg;
+*           Empty array, Returned filled if error is found;
+*
+*     RETURN CODE:
+*        0> decoded message without any errors; 
+*        1> error, errmsg buffer filled;
+***********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+int       prt_badmsg (GRIB_HDR *gh, char *errmsg)
+#else
+int       prt_badmsg (gh, errmsg)
+GRIB_HDR  *gh; 	                   /*input= Grib Header struct */
+char      *errmsg;                 /* output= empty unless Error happens */
+#endif
+{
+  PDS_INPUT     pds;           /* local PDS struct  */
+  grid_desc_sec gds;           /* local GDS struct  */
+  BDS_HEAD_INPUT bds_head;     /* local BDS header struct  */
+  BMS_INPUT     bms;           /* local bitmap section struct  */
+  float         *grib_data;    /* local ptr to float data  */
+  PDS_INPUT     *Tpds = NULL;  /* Null until valid PDS found*/
+  grid_desc_sec *Tgds = NULL;  /* Null until valid GDS found*/
+  BDS_HEAD_INPUT *Tbds= NULL;  /* Null until valid BDS found*/
+  BMS_INPUT     *Tbms = NULL;  /* Null until valid BMS found*/
+  char *func="prt_badmsg";     /* Function name */
+  char *curr_ptr;  		/* pts to beginning of GRIB message */
+  unsigned long lMessageSize;       /* message length  */
+  unsigned long  edition;                     /* GRIB edition number */
+  int bms_flag = 0;                 /* set if Bms present*/
+  int gds_flag = 0;                 /* set if Gds present */
+  int nReturn = 1;		    /* status, default is bad  */
+  unsigned long skip;
+
+/*
+*
+* A.1     CLEAR out local structures
+*/
+ fprintf(stdout,"\nEntering %s:  getting info from GRIB Header\n", func);
+ memset ((void *)&pds, '\0', sizeof(PDS_INPUT));
+ memset ((void *)&gds, '\0', sizeof(grid_desc_sec));
+ memset ((void *)&bds_head, '\0', sizeof(BDS_HEAD_INPUT));
+ memset ((void *)&bms, '\0', sizeof(BMS_INPUT));
+ grib_data = (float *)NULL;
+
+/*
+*
+* A.2     IF (incoming pointer is not at 'GRIB') 
+*            RETURN 1  !errmsg filled
+*         ENDIF
+*/
+curr_ptr = (char *)gh->entire_msg;  
+if(strncmp(curr_ptr,"GRIB",4) != 0) {
+  sprintf(errmsg,"%s:  no 'GRIB' at beg. of this msg.  Cannot continue.\n", 
+  func);
+  goto BYE;
+ }
+fprintf(stdout,"See 'GRIB'\n");
+
+/*
+*
+* A.3     FUNCTION gbyte   !get total message length from IDS 
+*/
+skip=32;
+gbyte(curr_ptr,&lMessageSize,&skip,24);
+if (lMessageSize <= 8) {
+	sprintf(errmsg,"Message length too short (%ld), cannot continue\n",
+	lMessageSize);
+	goto BYE;
+	}
+fprintf(stdout,"Message Length = %ld\n", lMessageSize);
+
+/*
+*
+* A.4     PRINT warning message if Message length > Buffer size
+*/
+if (lMessageSize > gh->abs_size) 
+	fprintf(stdout,
+	"*** Messagelen (%ld) > buffersize (%ld), MAY BE CORRUPTED ***\n",
+	lMessageSize, gh->abs_size);
+
+/*
+*
+* A.5     EXTRACT the  GRIB edition out of Section 0
+*/
+gbyte (curr_ptr,&edition, &skip,8);
+fprintf(stdout,"Edition = %ld\n", edition);
+
+/*
+*
+* A.6     MOVE pointer to the Product Definition section
+*/
+curr_ptr = curr_ptr + 8;
+fprintf(stdout,"Expect PDS to start at offset %ld\n", 
+(long)curr_ptr - (long)gh->entire_msg);
+
+/*
+*
+* A.7     FUNCTION gribgetpds  !decode the PDS
+*         RETURN error code if fails  !errmsg filled
+*         SAVE pointer to PDS block for printing later
+*/
+if( nReturn= gribgetpds(curr_ptr, &pds, errmsg)) {
+   fprintf(stdout,"%s:  %s;\n", func, errmsg);
+   goto BYE;
+  }
+fprintf(stdout,"got PDS\n");
+Tpds = &pds;
+
+/*
+*
+* A.8     PRINT warning if PDS length < 28 bytes
+*/
+if (pds.uslength < 28) 
+	fprintf(stdout,"*** PDS (%ld) < 28 bytes, MAY BE CORRUPTED ***\n",
+	pds.uslength);
+
+/*
+*
+* A.9     MOVE pointer to the end of PDS
+*/
+curr_ptr += pds.uslength;
+if ((long)curr_ptr > (long)gh->entire_msg + (gh->abs_size -1L)) {
+     fprintf(stdout,"PDS size is much too big, cannot step past it\n");
+     goto BYE;	
+   }	
+fprintf(stdout,"Expect next section to start at offset %ld\n", 
+(long)curr_ptr - (long)gh->entire_msg);
+
+/*
+*
+* A.10    IF (GDS is present)
+*/
+if ((gds_flag = pds.usGds_bms_id >> 7 & 1)) 
+  {
+/*
+* A.10.1      FUNCTION gribgetgds   !Exit on error
+*             SAVE pointer to GDS block for printing later
+*/
+   if ((nReturn=gribgetgds(curr_ptr, &gds, errmsg)) != 0) goto BYE;
+   fprintf(stdout,"got GDS\n");
+   Tgds = &gds;
+
+/*
+* A.10.2      SET ulGrid_size based on Projection type
+*/
+   switch(gds.head.usData_type)
+     {
+     case LATLON_PRJ:    	/* Lat/Lon Grid */
+     case GAUSS_PRJ:    	/* Gaussian Latitude/Longitude grid */
+     case ROT_LATLON_PRJ:   	/* Rotated Lat/Lon */
+     case ROT_GAUSS_PRJ:   	/* Rotated Gaussian */
+     case STR_LATLON_PRJ:   	/* Stretched Lat/Lon */
+     case STR_GAUSS_PRJ :   	/* Stretched Gaussian */
+     case STR_ROT_LATLON_PRJ :  /* Stretched and Rotated Lat/Lon */
+     case STR_ROT_GAUSS_PRJ :   /* Stretched and Rotated Gaussian */
+        bds_head.ulGrid_size = gds.llg.usNi * gds.llg.usNj; break;
+
+     case MERC_PRJ:  		/* Mercator Grid */
+        bds_head.ulGrid_size = gds.merc.cols * gds.merc.rows; break;
+
+     case LAMB_PRJ:  		/* Lambert Conformal */
+     case ALBERS_PRJ:  		/* Albers equal-area */
+     case OBLIQ_LAMB_PRJ: 	/* Oblique Lambert Conformal */
+        bds_head.ulGrid_size = gds.lam.iNx * gds.lam.iNy; break;
+
+     case POLAR_PRJ:  /* Polar Stereographic */
+        bds_head.ulGrid_size = gds.pol.usNx * gds.pol.usNy; break;
+
+     default: 
+        fprintf(stdout,"%s: unsupported usData_type=%d\n",
+	func, gds.head.usData_type);
+        sprintf(errmsg,"%s: unsupported usData_type=%d\n",
+        func, gds.head.usData_type);
+	nReturn= (1); goto BYE; 
+     }
+
+/*
+* A.10.3      PRINT warning if GDS length < 32 bytes
+*/
+   if (gds.head.uslength < 32) 
+	fprintf(stdout,"*** GDS (%d bytes) < 32 bytes, MAY BE CORRUPTED ***\n",
+	gds.head.uslength);
+
+/*
+* A.10.4      MOVE the cursor to the next section (either BMS/BDS)
+*/
+     curr_ptr += gds.head.uslength;
+     if ((long)curr_ptr > (long)gh->entire_msg + (gh->abs_size -1L)) {
+	fprintf(stdout,"GDS size is much too big, cannot step past it\n");
+	goto BYE;
+     }
+/*
+* A.10     ENDIF (GDS is present)
+*/
+  } /* gds present */
+ else fprintf(stdout,"Flag shows NO Grid Defn Sect included\n");
+
+
+fprintf(stdout,"Expect next section to start at offset %ld\n", 
+(long)curr_ptr - (long)gh->entire_msg);
+bms_flag = pds.usGds_bms_id >> 6 & 1;
+/*
+*
+* A.11     IF (bitmap Section is present)
+*/
+if(bms_flag)  /* bit map section present */
+  {
+/*
+* A.11.1      FUNCTION gribgetbms   !decode BMS
+*             RETURN error code if fails  !errmsg filled
+*             SAVE pointer to BMS block for printing later
+*/
+   if( nReturn=
+	gribgetbms(curr_ptr,&bms,gds_flag, bds_head.ulGrid_size,errmsg))
+   {
+     fprintf(stdout,"%s:  error=%d  in grib get BMS;\n",func,nReturn);
+     goto BYE;
+   }
+   fprintf(stdout,"got BMS\n");
+   Tbms = &bms;
+
+/*
+* A.11.2      PRINT warning if BMS length < 7 bytes
+*/
+   if (bms.uslength < 7) 
+	fprintf(stdout,"*** BMS (%d bytes) < 7 bytes, MAY BE CORRUPTED ***\n",
+	bms.uslength);
+
+/*
+* A.11.3      MOVE the cursor to beginning of Binary Data Section
+*/
+     curr_ptr += bms.uslength;
+     if ((long)curr_ptr > (long)gh->entire_msg + (gh->abs_size -1L)) {
+	fprintf(stdout,"BMS size is much too big, cannot step past it\n");
+	goto BYE;
+     }
+/*
+* A.11     ENDIF  !bms present
+*/
+  } /* Bms present */
+ else fprintf(stdout,"Flag shows NO Bit Map Section included\n");
+
+
+fprintf(stdout,"Expect BDS to start at offset %ld\n", 
+(long)curr_ptr - (long)gh->entire_msg);
+/*
+*
+* A.12    FUNCTION  gribgetbds()
+*         RETURN error code if failed  !errmsg filled
+*         SAVE pointer to BDS for printing later
+*/
+  if(nReturn=gribgetbds(curr_ptr, pds.sDec_sc_fctr, &bms, &gds, &grib_data,
+                &bds_head, errmsg))
+   { fprintf(stdout,"%s:  error=%d  in grib get BDS;\n",func,nReturn);
+     goto BYE;
+    }
+  fprintf(stdout,"got BDS\n");
+  Tbds= &bds_head;
+   
+/*
+* A.13    PRINT warning if BDS < 11 bytes
+*/
+   if (bds_head.length < 11) 
+	fprintf(stdout,"*** BDS (%d bytes) < 11 bytes, MAY BE CORRUPTED ***\n",
+	bds_head.length);
+
+/*
+* A.14    BUMP pointer to next section  !return on failure
+*/
+  curr_ptr += bds_head.length;
+     if ((long)curr_ptr > (long)gh->entire_msg + (gh->abs_size -1L)) {
+	fprintf(stdout,"BDS size is much too big, cannot step past it\n");
+	goto BYE;
+     }
+
+/*
+* A.15    CHECK for '7777' string 
+*         SET return code to 0 if found string 
+*/
+  fprintf(stdout,"Expect 7777 to start at offset %ld\n", 
+  (long)curr_ptr - (long)gh->entire_msg);
+  if (strncmp (curr_ptr, "7777", 4))
+	fprintf(stdout,"'7777' is NOT at expected location\n");
+  else  {
+	fprintf(stdout,"see '7777' at offset %ld\n",
+	(long)curr_ptr - (long)gh->entire_msg);
+  	nReturn = 0;
+	}
+
+
+BYE:
+/*
+*
+* A.16    FUNCTION prt_inp_struct !print as many sections as possible
+*/
+  fprintf(stdout,"\nNow will print all avail sections=\n");
+  prt_inp_struct (Tpds, Tgds, Tbms, Tbds, &grib_data);
+
+/*
+*
+* A.17    FREE data array
+*/
+ if (grib_data != NULL) free (grib_data);
+
+/*
+*
+* A.18    RETURN with exit status
+*/
+  fprintf(stdout,"Exiting %s\n", func); 
+  return (nReturn);
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/prt_inp_struct.c b/wrfv2_fire/external/io_grib1/MEL_grib1/prt_inp_struct.c
new file mode 100644
index 00000000..250ca780
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/prt_inp_struct.c
@@ -0,0 +1,460 @@
+/* File:  prt_inp_struct.c		Alice Nakajima, SAIC, 10/96
+   Func to print content of all of the Internal structs
+Revisions:
+09/10/98 atn:  display whether or not GRIB extensions are used.
+10/22/98 atn:  +typecast for compiler;
+*/
+#include 
+#include 
+#include 
+#include "grib_lookup.h"	/* for Parm/Ctr/Levl/Mdl_defn */
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/* 
+   Defines following Global var:
+   int UseTables;   flag set if using lookuptbl
+ 
+   Uses the external tables, defined in ld_enc_inputs.c:
+   PARM_DEFN  db_parm_tbl[256*MAX_PARM_TBLS]  holds Parameter lookup info;
+   LVL_DEFN   db_lvl_tbl[NLEVS]  holds Level lookup info;
+   MODEL_DEFN db_mdl_tbl[NMODEL] hold Model lookup info;
+   GEOM_DEFN  db_geom_tbl[NGEOM]   holds Geom lookup info;
+               
+*/
+int UseTables=0;       /* GLOBALVAR:   default is no lookup table used */
+
+extern PARM_DEFN  db_parm_tbl[];  	/* parameter conversion info */
+extern MODEL_DEFN db_mdl_tbl[]; 	/* model conversion info */
+extern LVL_DEFN   db_lvl_tbl[]; 	/* level conversion info */
+extern GEOM_DEFN  db_geom_tbl[];	/* Geom conversion info  */
+extern CTR_DEFN   db_ctr_tbl[];  	/* Ctr conversion info  */
+
+/*
+*
+************************************************************************
+* A. FUNCTION:  prt_inp_input
+*      to print content of the Internal Grib structures
+*
+*    INTERFACE:
+*      void  prt_inp_struct (pds, gds, bms_input, bds_head_input, ppfarr)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*      (I) PDS_INPUT *pds;                
+*          internal Product Defn Section struct to print
+*      (I) grid_desc_sec  *gds;  
+*          internal Grid Defn struct to print
+*      (I) BMS_INPUT *bms_input;          
+*          internal Bitmap Section  to print
+*      (I) struct BDS_HEAD_INPUT *bds_head_input; 
+*          internal 11-byte hdr of Binary Data Section to print
+*      (I) float **ppfarr;    
+*          unpacked & restored float data array to print
+*
+*    RETURN CODE: none
+************************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void	prt_inp_struct (PDS_INPUT 	*pds,
+			grid_desc_sec   *gds,
+			BMS_INPUT 	*bms_input,
+			struct BDS_HEAD_INPUT *bds_head_input,
+			float 		**ppfarr)
+#else
+void	prt_inp_struct (pds, gds, bms_input, bds_head_input, ppfarr)
+	PDS_INPUT 	*pds;
+	grid_desc_sec   *gds;
+	BMS_INPUT 	*bms_input;
+	struct BDS_HEAD_INPUT *bds_head_input;
+	float 		**ppfarr;
+#endif
+{
+  char *func= "prt_inp_struct"; /* name of function */
+  float *farr;			/* ptr to float data aray */
+  double pwr10toD;		/* 10 to the Decimal Scl fctr */
+  int D;			/* Decimal Scl Fctr */
+  int indx,i;			/* index */
+
+   fprintf(stdout,"\n--- Entering %s ---\n", func);
+/*
+*
+* A.1       IF (PDS_INPUT struct is null) THEN
+*               PRINT message
+*           ELSE
+*               PRINT out all of its fields, values and type
+*           ENDIF
+*/
+   if (pds == NULL) fprintf(stdout,"**** PDS_INPUT is null****\n");
+   else
+   {             
+     fprintf(stdout,"***  PDS_INPUT ****\n");
+     p_ushort (pds->uslength);        
+     p_ushort (pds->usEd_num);       
+     p_ushort (pds->usParm_tbl);    
+     p_ushort (pds->usCenter_id);  
+     if (UseTables)
+        if ( db_ctr_tbl[pds->usCenter_id].ctr_dsc[0] )
+        fprintf(stdout,"\tCtr_dsc=%s\n", db_ctr_tbl[pds->usCenter_id].ctr_dsc);
+        else 
+	fprintf(stdout,
+	"\tOriginating Center ID %d not defined in current table.\n",
+	pds->usCenter_id);
+
+     p_ushort (pds->usProc_id);   
+     if (UseTables)
+     if ( db_mdl_tbl[pds->usProc_id].grib_dsc[0] )
+        fprintf(stdout,"\tModel Description = %s\n",
+	db_mdl_tbl[pds->usProc_id].grib_dsc);
+     	else
+        fprintf(stdout,"\tModel ID %d not defined in current table.\n",
+	pds->usProc_id);
+
+     p_ushort (pds->usGrid_id);  
+     if (UseTables) 
+     if ( db_geom_tbl[pds->usGrid_id].grib_dsc [0] )
+        fprintf(stdout,"\tGrid Description = %s\n",
+	db_geom_tbl[pds->usGrid_id].grib_dsc);
+     else
+        fprintf(stdout,"\tGrid ID %d not defined in current table.\n",
+	pds->usGrid_id);
+
+     p_ushort (pds->usGds_bms_id); 
+     p_ushort (pds->usParm_id);   
+
+     /*
+      * The sub-tables cannot have GribCode Zero since it's Reserved
+      * if the center doesn't use sub tables then they must set ParmSub to 0
+      * when ParmId is between 250 (Tbl-A) and 254 (Tbl-E);
+      */
+     if (pds->usParm_id>=250 && pds->usParm_id<=254 && pds->usParm_sub!=0)
+        {
+          indx = 256 * (pds->usParm_id - 249) + pds->usParm_sub;
+          p_ushort (pds->usParm_sub);
+	  fprintf(stdout,"  (pid=%d, psub=%d) is Sub-ParmTbl Indx = %d\n",
+	  pds->usParm_id, pds->usParm_sub, indx);
+        }
+      else  {
+	  indx = pds->usParm_id;
+	  fprintf(stdout,
+	  "  usParm_sub not used (%ld), default to ParmTbl Indx= %d\n",
+	  pds->usParm_sub, indx);
+	}
+
+     if(UseTables) {
+      if ( db_parm_tbl[indx].grib_dsc[0] ) {
+         fprintf(stdout,"\tParameter = %s\n",db_parm_tbl[indx].grib_dsc);
+         fprintf(stdout,"\tUnits = %s\n",db_parm_tbl[indx].grib_unit_dsc);
+      }else
+         fprintf(stdout,"\tParameter ID %d not defined in current table.\n",
+	 pds->usParm_id);
+      }
+
+     p_ushort (pds->usLevel_id); 
+     p_ushort (pds->usLevel_octets); 
+     p_ushort (pds->usHeight1);     
+     p_ushort (pds->usHeight2);    
+    if(UseTables) {
+       if ( db_lvl_tbl[pds->usLevel_id].grib_dsc[0] ) {
+          fprintf(stdout,"\tLevel description = %s\n", 
+   		db_lvl_tbl[pds->usLevel_id].grib_dsc);
+          switch(db_lvl_tbl[pds->usLevel_id].num_octets){
+            case 2: fprintf(stdout,"\t%s = %u\n",
+     	   	db_lvl_tbl[pds->usLevel_id].lvl_name_1, pds->usHeight1);
+              	break;
+            case 1: fprintf(stdout,"\t%s = %u\n\t%s = %u\n",
+     	   	db_lvl_tbl[pds->usLevel_id].lvl_name_1, pds->usHeight1,
+     	   	db_lvl_tbl[pds->usLevel_id].lvl_name_2, pds->usHeight2);
+              	break;
+            case 0: break;
+            default:
+              fprintf(stdout,"***Number of octets for table 3 undefined - possibly "
+              "corrupt dataset.***\n");
+          }
+       }
+     else fprintf(stdout,"Level ID %d not defined in current table.\n",
+   	pds->usLevel_id);
+    } /* end UseTables 'if' statement */
+
+     p_ushort (pds->usYear);      
+     p_ushort (pds->usMonth);    
+     p_ushort (pds->usDay);     
+     p_ushort (pds->usHour);   
+     p_ushort (pds->usMinute);
+     p_ushort (pds->usFcst_unit_id);   
+     p_ushort (pds->usP1);            
+     p_ushort (pds->usP2);           
+     p_ushort (pds->usTime_range);  
+     p_ushort (pds->usTime_range_avg);
+     p_ushort (pds->usTime_range_mis);
+     p_ushort (pds->usCentury); 
+     p_ushort (pds->usCenter_sub);   
+     p_short  (pds->sDec_sc_fctr);
+     /* p_ushort (pds->ausZero[0]);
+     p_ushort (pds->ausZero[1]);
+     p_ushort (pds->ausZero[2]);
+     p_ushort (pds->ausZero[3]);
+     p_ushort (pds->ausZero[4]);
+     p_ushort (pds->ausZero[5]);
+     p_ushort (pds->ausZero[6]);
+     p_ushort (pds->ausZero[7]);
+     p_ushort (pds->ausZero[8]);
+     p_ushort (pds->ausZero[9]);
+     p_ushort (pds->ausZero[10]);
+     p_ushort (pds->ausZero[11]); */
+
+     if (pds->usExt_flag == (unsigned short)EXTENSION_FLAG) {
+       fprintf(stdout,
+       " (uns. short) pds->usExt_flag  = %u (Extensions used)\n",
+       pds->usExt_flag);
+       p_ushort (pds->usSecond);
+       p_ushort (pds->usTrack_num);
+       p_ushort (pds->usParm_sub);	
+       p_ushort (pds->usSub_tbl); 
+      }
+     else fprintf(stdout,
+ 	" (uns. short) pds->usExt_flag  = %u (not used)\n" \
+ 	" (uns. short) pds->usSecond    = not avail\n" \
+ 	" (uns. short) pds->usTrack_num = not avail\n" \
+ 	" (uns. short) pds->usParm_sub  = not avail\n" \
+ 	" (uns. short) pds->usSub_tbl   = not avail\n", pds->usExt_flag );
+
+   }
+
+/*
+*
+* A.2       IF (GDS struct is null) THEN
+*               PRINT message
+*           ELSE
+*               TEST the Projection type, skip if not a supported one;
+*               PRINT out all of its fields, values and type
+*               SWITCH (type of projection)
+*                 > LatLon (0), Gaussian (4), 
+*                 > Rotated LatLon (10), Rotated Gaussian (14), 
+*                 > Stretched LatLon (20), Stretched Gaussian (24), 
+*                 > Stretched Rotated Latlon(30), Stretched Rotated Gauss(34):
+*                      CAST the projection block to type GDS_LATLON_INPUT
+*                      and print its fields, value and type;
+*                 > Lambert (3), Albers (8), Oblique Lambert Conf (13):
+*                      CAST the projection block to type GDS_LAM_INPUT
+*                      and print its fields, value and type;
+*                 > Polar (5):  
+*                      CAST the projection block to type GDS_PS_INPUT
+*                      and print its fields, value and type;
+*                 default: PRINT error  !unsupported projection
+*               ENDSWITCH
+*           ENDIF
+*/
+  if (gds == NULL) {
+	fprintf(stdout,"\n*** GDS is null ***\n");
+	goto CHECK_BMS;
+	}
+
+  fprintf(stdout,"\n*** GDS_HEAD_INPUT ***\n"); 
+  fprintf(stdout,"sizeof(GDS_GRIB + projblk)= ");
+  p_ushort (gds->head.uslength);
+  p_ushort (gds->head.usNum_v);
+  p_ushort (gds->head.usPl_Pv);
+
+  /* test to see if the Data type is out of bound, or if it's
+ 	currently not supported;  if so, print msg got print next section.
+  */
+  if (gds->head.usData_type >= (unsigned short) PRJ_COUNT  ||
+     strstr((char*)prjn_name[gds->head.usData_type],(char*)"Unsupported Grid")) 
+    {
+	fprintf(stdout,
+	"Warning:  Projection #%d is not supported, skip this section\n",
+	gds->head.usData_type);
+	goto CHECK_BMS;
+    }
+     
+  p_string (prjn_name[gds->head.usData_type]);
+  switch (gds->head.usData_type) 
+       	 {
+           case LATLON_PRJ:
+           case GAUSS_PRJ:
+           case ROT_LATLON_PRJ:
+           case ROT_GAUSS_PRJ:
+           case STR_LATLON_PRJ:
+           case STR_GAUSS_PRJ :
+           case STR_ROT_LATLON_PRJ :
+           case STR_ROT_GAUSS_PRJ :
+		   p_int (gds->llg.usNi);      
+		   p_int (gds->llg.usNj);     
+		   p_long (gds->llg.lLat1);   
+		   p_long (gds->llg.lLon1);  
+		   p_ushort (gds->llg.usRes_flag);
+		   p_long (gds->llg.lLat2);    
+		   p_long (gds->llg.lLon2);   
+		   p_int (gds->llg.iDi);    
+		   p_int (gds->llg.iDj);   
+		   p_ushort (gds->llg.usScan_mode);
+
+		   if (gds->head.usData_type == LATLON_PRJ ||
+		       gds->head.usData_type == GAUSS_PRJ) 
+		   break;
+
+		   /* 	02/98
+		   remaining code is for the Stretch/Rotate parameters 
+		   */
+		   p_long (gds->llg.lLat_southpole);
+		   p_long (gds->llg.lLon_southpole);
+		   fprintf(stdout,"gds->llg.lRotate (%ld) tofloat= %.3f\n",
+		   gds->llg.lRotate , 
+		   grib_ibm_local((unsigned long)gds->llg.lRotate));
+		   p_long (gds->llg.lPole_lat);    
+		   p_long (gds->llg.lPole_lon);   
+		   fprintf(stdout,"gds->llg.lStretch (%ld) tofloat= %.3f\n"
+		   ,gds->llg.lStretch, 
+		   grib_ibm_local((unsigned long)gds->llg.lStretch));
+		break;
+
+	   case MERC_PRJ:
+		   p_int (gds->merc.cols); 
+		   p_int (gds->merc.rows);
+		   p_long (gds->merc.first_lat); 
+		   p_long (gds->merc.first_lon);
+		   p_ushort (gds->merc.usRes_flag);          
+		   p_long (gds->merc.La2); 
+		   p_long (gds->merc.Lo2);
+		   p_long (gds->merc.latin);
+		   p_ushort (gds->merc.usScan_mode);          
+		   p_float (gds->merc.lon_inc); 
+		   p_float (gds->merc.lat_inc);
+		break;
+
+           case LAMB_PRJ:  
+           case ALBERS_PRJ:  
+           case OBLIQ_LAMB_PRJ:  
+		   p_int (gds->lam.iNx);                 
+		   p_int (gds->lam.iNy);                 
+		   p_long (gds->lam.lLat1);               
+		   p_long (gds->lam.lLon1);               
+		   p_ushort (gds->lam.usRes_flag);          
+		   p_long (gds->lam.lLon_orient);         
+		   p_ulong (gds->lam.ulDx);                
+		   p_ulong (gds->lam.ulDy);                
+		   p_ushort (gds->lam.usProj_flag);         
+		   p_ushort (gds->lam.usScan_mode);         
+		   p_long (gds->lam.lLat_cut1);          
+		   p_long (gds->lam.lLat_cut2);           
+
+		   if (gds->head.usData_type == LAMB_PRJ) break;
+		   p_long (gds->lam.lLat_southpole);      
+		   p_long (gds->lam.lLon_southpole);      
+		 break;
+
+           case POLAR_PRJ:  
+		   p_ushort (gds->pol.usNx);                
+		   p_ushort (gds->pol.usNy);                
+		   p_long (gds->pol.lLat1);               
+		   p_long (gds->pol.lLon1);               
+		   p_ushort (gds->pol.usRes_flag);          
+		   p_long (gds->pol.lLon_orient);         
+		   p_ulong (gds->pol.ulDx);                
+		   p_ulong (gds->pol.ulDy);                
+		   p_ushort (gds->pol.usProj_flag);         
+		   p_ushort (gds->pol.usScan_mode);         
+		 break;
+		
+	   default:  fprintf(stdout,
+		"Warning:  print code not available for Projection %d\n",
+		gds->head.usData_type);
+
+          } /* SWitch */
+
+
+CHECK_BMS:
+/*
+*
+* A.3       IF (BMS_INPUT struct is null) THEN
+*               PRINT message
+*           ELSE
+*               PRINT out all of its fields, values and type
+*           ENDIF
+*/
+   
+  if (bms_input==NULL || bms_input->uslength <= 0) 
+      fprintf(stdout,"\n*** BMS_INPUT is Null (no bms)  ***\n"); 
+  else {
+      fprintf(stdout,"\n*** BMS_INPUT  ***\n"); 
+      p_ushort (bms_input->uslength);
+      p_ushort (bms_input->usUnused_bits);
+      p_ushort (bms_input->usBMS_id);
+      p_ulong (bms_input->ulbits_set);
+      fprintf(stdout,"(not going to print CHAR *bit_map)\n");
+    } 
+
+/*
+*
+* A.4       IF (BDS_INPUT struct is null) THEN
+*               PRINT message
+*           ELSE
+*               PRINT out all of its fields, values and type
+*           ENDIF
+*/
+  if (bds_head_input == NULL) 
+	fprintf(stdout,"\n*** BDS_HEAD_INPUT is null ***\n");
+  else {
+    fprintf(stdout,"\n*** BDS_HEAD_INPUT ***\n");
+    p_ulong (bds_head_input->length);
+    p_ushort (bds_head_input->usBDS_flag);
+    p_int (bds_head_input->Bin_sc_fctr);
+    p_float (bds_head_input->fReference); 
+    p_ushort (bds_head_input->usBit_pack_num);
+    p_ulong (bds_head_input->ulGrid_size);  
+    p_float (bds_head_input->fPack_null);  
+  }
+
+/*
+*
+* A.5       IF (Float array is null) THEN
+*               PRINT message
+*           ELSE
+*               PRINT out up to 100 of its values (after taking out
+*               the Decimal Scale Factor)
+*           ENDIF
+*/
+  if (ppfarr == 0) fprintf(stdout,"\n*** FLOAT array is null ***\n");
+  else {
+     farr= *ppfarr;
+     fprintf(stdout,
+	"\n*** FLOAT ARRAY has %ld elements (print upto first 100) ***\n",
+	bds_head_input->ulGrid_size);
+
+     if (pds != NULL) {
+	D= pds->sDec_sc_fctr;
+	pwr10toD=  pow ( 10., (double) D );
+        fprintf(stdout,"Dec_sc_fctr=%d\n", D );
+	}
+    else { 
+	D= 0; pwr10toD = 1.; 
+	fprintf(stdout,"No PDS avail, assume Dec Scl Fctr to be 0\n");
+	}
+	
+     /* Data was scaled up in Pack_Spatial in order to get the INT values
+	to pack, so now need to change it back to its true value by
+ 	taking out the Decimal Scale Factor 
+     */
+     if (D >= 0)
+        for (i=0; iulGrid_size && i < 100; i=i+5)
+        fprintf(stdout,"%3d-  %.*f  %.*f  %.*f  %.*f  %.*f\n", 
+	i+1, 
+	D, farr[i], D, farr[i+1], D, farr[i+2], D, farr[i+3], D, farr[i+4] );
+     else 
+        for (i=0; iulGrid_size && i < 100; i=i+5)
+        fprintf(stdout,"%3d-  %.0f  %.0f  %.0f  %.0f  %.0f\n", 
+	i+1, farr[i], farr[i+1], farr[i+2], farr[i+3], farr[i+4] );
+   }
+/*
+*
+* A.6       RETURN w/nothing
+*
+*/
+  fprintf(stdout,"--- Leaving %s ---\n\n", func);
+
+/*
+*
+* END OF FUNCTION
+*
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/set_bytes.c b/wrfv2_fire/external/io_grib1/MEL_grib1/set_bytes.c
new file mode 100644
index 00000000..b7b7aa34
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/set_bytes.c
@@ -0,0 +1,29 @@
+#include 
+#include "isdb.h"
+
+void set_bytes(long in, int numbytes, char *out)
+{
+  int i;
+  long tmp;
+
+  tmp = abs(in);
+
+  for (i=0; i < numbytes; i++)
+    {
+      out[numbytes-1-i] = (tmp << (sizeof(long) - (i+1))*BYTE_BIT_CNT) 
+				 >> (sizeof(long) - 1)*BYTE_BIT_CNT;
+    }
+  if ( in < 0 ) out[0] |= 0x0080;
+}
+
+
+void set_bytes_u(unsigned long in, int numbytes, unsigned char *out)
+{
+  int i;
+
+  for (i=0; i < numbytes; i++)
+    {
+      out[numbytes-1-i] = (in << (sizeof(unsigned long) - (i+1))*BYTE_BIT_CNT) 
+				 >> (sizeof(unsigned long) - 1)*BYTE_BIT_CNT;
+    }
+}
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/swap.c b/wrfv2_fire/external/io_grib1/MEL_grib1/swap.c
new file mode 100644
index 00000000..5e20e146
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/swap.c
@@ -0,0 +1,24 @@
+#include 
+#include 
+void *swap_byte4(long *theInt)
+{
+  char tmp[4];
+  int i;
+
+  for (i=0; i
+
+main()
+{
+  int i;
+  long longint = -10342;
+  char charstring[sizeof(long)];
+  char charstring_orig[sizeof(long)];
+
+  memcpy(charstring_orig,(void *)&longint,8);
+  set_bytes(longint,3,charstring);
+  for (i=0; i < sizeof(long); i++) 
+    {
+      fprintf(stderr,"new:  %d: %d\n",i,charstring[i]);
+      /*      fprintf(stderr,"orig: %d: %d\n",i,charstring_orig[i]); */
+    }
+}
+
diff --git a/wrfv2_fire/external/io_grib1/MEL_grib1/upd_child_errmsg.c b/wrfv2_fire/external/io_grib1/MEL_grib1/upd_child_errmsg.c
new file mode 100644
index 00000000..500ce681
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/MEL_grib1/upd_child_errmsg.c
@@ -0,0 +1,56 @@
+#include 
+#include 
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+
+/*
+*********************************************************************
+* A. FUNCTION:  upd_child_errmsg
+*       Tacks the given function name in front of the error message array
+*       to show which level of the Nested Function calls the error 
+*       occured at;
+*
+*    INTERFACE:
+*       void    upd_child_errmsg (parent, errmsg)
+*
+*    ARGUMENTS (I=input, O=output, I&O=input and output):
+*       (I)   char *parent;    name of caller function
+*       (I&O) char *errmsg;    already contain error message upon entry;
+*                              will get name of parent tacked in front of 
+*                              existing array content;
+*    RETURN:   none;
+*********************************************************************
+*/
+#if PROTOTYPE_NEEDED
+void	upd_child_errmsg (char *parent, char *errmsg)
+#else
+void	upd_child_errmsg (parent, errmsg)
+char *parent; 
+char *errmsg;
+#endif
+{
+char temp[500], *func="upd_child_errmsg";
+
+    DPRINT1 ("Entering %s\n", func);
+    DPRINT2 ("Tacking '%s' in front of '%s'\n", parent, errmsg);
+/*
+*
+* A.1       IF (the error message is null) THEN
+*               RETURN error msg "FuncName:  no Error msg avail!"
+*           ELSE
+*               RETURN error msg "FuncName: " + errmsg
+*           ENDIF
+*/
+    if (errmsg[0]=='\0') 
+	 sprintf (errmsg, "%s:  no Error msg avail!\n", parent); 
+    else {
+	 sprintf (temp, "%s: %s", parent, errmsg);
+         strncpy (errmsg, temp, 500);
+	}
+
+    DPRINT1 ("ErrMsg is now-> %s\n", errmsg);
+    DPRINT1 ("Leaving %s\n", func);
+/*
+*  END OF FUNCTION
+*/
+}
diff --git a/wrfv2_fire/external/io_grib1/Makefile b/wrfv2_fire/external/io_grib1/Makefile
new file mode 100644
index 00000000..bca46714
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/Makefile
@@ -0,0 +1,93 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I. -I./MEL_grib1 -Igrib1_util -I../io_grib_share
+BUILD_DIR = $(IO_GRIB_SHARE_DIR)../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = .
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = $(INCLUDEDIRS)
+CXX_INCLUDES = $(INCLUDEDIRS)
+F_INCLUDES   = $(INCLUDEDIRS)
+ARFLAGS      = cruv
+
+FORMAT = $(FREE)
+
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib1
+SYS_DEFINES =
+DEP_LIBS = 
+OBJS =  \
+	grib1_routines.o \
+	gribmap.o \
+	io_grib1.o \
+	trim.o
+
+#
+#  List of subdirectories to which to pass make commands.
+#
+LIB_DIRS = \
+	MEL_grib1 \
+	grib1_util \
+	WGRIB
+EXE_DIRS =
+SUB_DIRS = $(LIB_DIRS) $(EXE_DIRS)
+
+#
+#  Clean up old build files
+#
+superclean:
+	/bin/rm -f *.o > /dev/null 2>&1
+	/bin/rm -f *.f90 > /dev/null 2>&1
+	/bin/rm -f *.mod > /dev/null 2>&1
+	/bin/rm -f *.a > /dev/null 2>&1
+	/bin/rm -f wgrid > /dev/null 2>&1
+	( cd grib1_util ; make clean )
+	( cd MEL_grib1 ; make clean )
+	( cd WGRIB ; make clean )
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib1/README.io_grib1 b/wrfv2_fire/external/io_grib1/README.io_grib1
new file mode 100644
index 00000000..9fe1375c
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/README.io_grib1
@@ -0,0 +1,159 @@
+io_grib1
+
+Author: Todd Hutchinson
+        WSI
+        thutchinson@wsi.com
+
+5 August 2004
+8 February 2005 - Updated by Todd Hutchinson.  Section V was updated to 
+                  clarify the description of the decimal scale factor field 
+                  in the gribmap file.
+12 July 2005    - Updated by Todd Hutchinson.  GRIB version 1 input capability 
+                  was added to WRF. All sections in this README were updated to
+                  add information relevant for grib input capability.
+
+
+I. Introduction
+
+io_grib1 is a WRF module that allows for input and output of WRF data in GRIB 
+   version 1 format.
+
+Why would anyone use GRIB output?  
+  GRIB stores data in a compressed format so output files are much smaller 
+    than in other formats such as netCDF.  In addition, encoding in GRIB format
+    is very efficient and can be faster than writing out netCDF formatted 
+    data, especially for large grids.  (See Section V for more on performance).
+
+II. Running WRF
+  1. Set namelist entry or entries io_form_ to 5
+  2. Run WRF as you normally would, for example:
+     cd test/em_real
+     ./wrf.exe
+
+IV. Examining GRIB output with wgrib
+  1. wgrib is installed within external/io_grib1 
+     (See http://wesley.wwb.noaa.gov/wgrib.html for more information.)
+  2. Define the GRIBTAB environment variable:
+        For bourne shell users:
+          export GRIBTAB=/run/gribmap.txt
+        For csh users
+          setenv GRIBTAB /run/gribmap.txt
+  3. To get a listing of the records in the GRIB data:
+        /external/io_grib1/wgrib wrfout_d01_000000
+
+IV. Quilting
+  If you are running WRF using MPI, you may use a seperate processor for
+    quilting just as is done with netCDF.  Simply set the namelist variable
+    nio_tasks_per_group to 1 (or more).
+
+V. Details
+  1. gribmap.txt file
+     io_grib1 makes use of a GRIB table for encoding the WRF data into GRIB 
+        format.  The GRIB table that io_grib1 uses is contained in the 
+        WRF run directory, and is called gribmap.txt.  This file is read at
+        run-time by io_grib1.  Settings in this file are used to encode the 
+	corresponding parameters in the GRIB output files.  You may modify 
+	this file to suit your needs.
+
+      The file has the following format:
+
+      the first line of a table (note: there may be several tables in a 
+                                 gribmap.txt file)
+      -1:CENTER:SUBCENTER:PARAMETER_TABLE_VERSION
+          "-1" is an indicator for the start of a table
+          "CENTER" is generating center (PDS 5, i.e., for NCEP, this is 7)
+          "SUBCENTER" is the generating sub-center (PDS 26)
+          "PARAMETER_TABLE_VERSION" is the parameter table version (PDS 4)
+
+      Subsequent lines:
+      GRIBID::::
+          "GRIBID" is the GRIB parameter id (PDS 9).
+          "PARAMETER" is the abbreviated parameter name.   
+          "DESCRIPTION" is a description of the parameter.
+          "WRF VAR" is a comma-seperated list of WRF variables that will be
+                    encoded as with PARAMETER described in the line and with 
+                    the CENTER, SUBCENTER and PARAMETER_TABLE_VERSION listed 
+                    at the beginning of the table.  WRF VAR must use 
+                    the WRF variable names that are defined in the "DNAME" 
+                    column in the WRF Registry.
+          "DECSCL" is the decimal scale factor.  It is the number of digits
+                    to the right of the decimal point that will be saved in
+                    the output data.  This number may be less than zero, in 
+                    which case, the precision of data will be truncated the 
+                    specified number of digits to the left of the decimal 
+                    point. 
+                       Examples:
+                         -2 : Data will be encoded at the hundreds level, 
+	                      i.e., 102425.231 will be encoded as 102400
+                          3 : Data will be encoded at the thousandths level, 
+			      i.e., 102425.231243 will be encoded as 1024.231
+      Example:
+           1:PRES:Pressure [Pa]:P,PSFC:1
+             In this example, GRIB parameter 1, abbreviated PRES, is 
+                pressure in pascals.  WRF variables P and PSFC (as listed in
+                the WRF Registry) will be encoded as PRES.  The data will have
+                one decimals of precision, i.e., 101323.1 Pa.
+           62:NCPCP:Large scale precipitation [kg/m^2]:NCPCP:2
+             In this example, GRIB parameter 62, abbreviated NCPCP, is 
+                Large-scale precipitation.  The WRF variables NCPCP (as listed 
+                in the WRF Registry) will be encoded as NCPCP.  The data will 
+                have two decimals of precision, i.e., 1.23 kg/m^2 (i.e., 
+                1.23 mm).
+
+      Note:
+          For GRIB encoding, parameters 1-127 are the standard parameters
+            described by the WMO GRIB convention.  Interpretation of parameters
+            128-254 vary depending on the setting of the CENTER, SUBCENTER, 
+            and PARAMETER_TABLE_VERSION.  In the default gribmap.txt file,
+            the CENTER and SUBCENTER are both set to be 255.  Five tables
+            with PARAMETER_TABLE_VERSION's varying between 2 and 6 are 
+            specified in the default gribmap.txt file.
+
+  2. Variable dimensions.
+      A GRIB file is a set of records of data.  Each record is a 2-dimensional,
+        horizontal field, i.e., temperature on a pressure surface,
+        In the case of the WRF Eulerian mass model, we have variables on Eta 
+        coordinates, so, we have, i.e., temperature on the 0.995 Eta level.
+      WRF outputs 3, 2 and 1-dimensional fields and point data.  3-dimensional 
+        (i.e., u-component of wind) fields are stored in GRIB as a series of 
+        horizontal 2-dimensional fields.  WRF horizontal 2-d fields are stored 
+        simply as horizontal 2-d fields (i.e., surface pressure).  
+        One-dimensional fields with dimension varying in the vertical (i.e., 
+        the vertical coordinate ZN), are stored as a set of 1x1 grids valid
+        at the center of the grid.  So, the third vertical level (ZN) is 
+        encoded as a 1x1 grid, valid at the center of the grid.  Point data
+        is also stored as a 1x1 grid valid at the center of the grid.
+      
+VI. Performance
+   GRIB output has proven to be very fast, as compared to netcdf output.
+
+   Listed below is a comparison of file size and run-time for io_grib1 and
+   io_netcdf.  WRF was run twice, once with GRIB output and once with netcdf
+   output.  In both cases, 32 CPUS (on 16 machines) were dedicated to 
+   model integration, and one was CPU dedicated to I/O and quilting (using 
+   nio_tasks_per_group = 1).  The run had a domain with 360x485 grid points 
+  (12 km spacing) and 10-minute output.  The model was run out to 3 hours.
+
+   Shown is the file size for one-output time, the total model run-time 
+   and the time for I/O as listed in the WRF output.  In addition, the 
+   additional time that is required for a time-step just after model output
+   is listed.
+
+   Format    File Size    Run time     I/O time   additional time after output
+   netCDF     368 MB       719 s         1.26 s            3.3 s
+   GRIB v1    109 MB       519 s         0.28 s            1.9 s
+
+
+VII. Testing
+   We (at WSI) have tested io_grib1 with WRF running on linux (redhat v 9.0).  
+   We typically use the intel fortran compiler (v8.0) and the gnu C compiler, 
+   so, that configuration has the most testing.  We have also done limited
+   testing with the Portland Group Compiler on linux.  We have not tested any
+   other platforms or compilers.
+
+io_grib1
+
+Author: Todd Hutchinson
+        WSI
+        thutchinson@wsi.com
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/BDSunpk.c b/wrfv2_fire/external/io_grib1/WGRIB/BDSunpk.c
new file mode 100644
index 00000000..0d824d25
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/BDSunpk.c
@@ -0,0 +1,133 @@
+#include 
+#include 
+#include 
+#include 
+#include "grib.h"
+#include "pds4.h"
+#include "bms.h"
+#include "bds.h"
+
+/* 1996				wesley ebisuzaki
+ *
+ * Unpack BDS section
+ *
+ * input: *bits, pointer to packed integer data
+ *        *bitmap, pointer to bitmap (undefined data), NULL if none
+ *        n_bits, number of bits per packed integer
+ *        n, number of data points (includes undefined data)
+ *        ref, scale: flt[] = ref + scale*packed_int
+ * output: *flt, pointer to output array
+ *        undefined values filled with UNDEFINED
+ *
+ * note: code assumes an integer > 32 bits
+ *
+ * 7/98 v1.2.1 fix bug for bitmaps and nbit >= 25 found by Larry Brasfield
+ * 2/01 v1.2.2 changed jj from long int to double
+ * 3/02 v1.2.3 added unpacking extensions for spectral data 
+ *             Luis Kornblueh, MPIfM 
+ */
+
+static unsigned int mask[] = {0,1,3,7,15,31,63,127,255};
+static unsigned int map_masks[8] = {128, 64, 32, 16, 8, 4, 2, 1};
+static double shift[9] = {1.0, 2.0, 4.0, 8.0, 16.0, 32.0, 64.0, 128.0, 256.0};
+
+void BDS_unpack(float *flt, unsigned char *bds, unsigned char *bitmap,
+	int n_bits, int n, double ref, double scale) {
+
+    unsigned char *bits;
+
+    int i, mask_idx, t_bits, c_bits, j_bits;
+    unsigned int j, map_mask, tbits, jmask, bbits;
+    double jj;
+
+    if (BDS_Harmonic(bds)) {
+        bits = bds + 15;
+        /* fill in global mean */
+        *flt++ = BDS_Harmonic_RefValue(bds);
+        n -= 1; 
+    }
+    else {
+        bits = bds + 11;  
+    }
+
+    tbits = bbits = 0;
+
+    /* assume integer has 32+ bits */
+    if (n_bits <= 25) {
+        jmask = (1 << n_bits) - 1;
+        t_bits = 0;
+
+        if (bitmap) {
+	    for (i = 0; i < n; i++) {
+		/* check bitmap */
+		mask_idx = i & 7;
+		if (mask_idx == 0) bbits = *bitmap++;
+	        if ((bbits & map_masks[mask_idx]) == 0) {
+		    *flt++ = UNDEFINED;
+		    continue;
+	        }
+
+	        while (t_bits < n_bits) {
+	            tbits = (tbits * 256) + *bits++;
+	            t_bits += 8;
+	        }
+	        t_bits -= n_bits;
+	        j = (tbits >> t_bits) & jmask;
+	        *flt++ = ref + scale*j;
+            }
+        }
+        else {
+	    for (i = 0; i < n; i++) {
+                while (t_bits < n_bits) {
+                    tbits = (tbits * 256) + *bits++;
+                    t_bits += 8;
+                }
+                t_bits -= n_bits;
+                flt[i] = (tbits >> t_bits) & jmask;
+            }
+	    /* at least this vectorizes :) */
+	    for (i = 0; i < n; i++) {
+		flt[i] = ref + scale*flt[i];
+	    }
+        }
+    }
+    else {
+	/* older unoptimized code, not often used */
+        c_bits = 8;
+        map_mask = 128;
+        while (n-- > 0) {
+	    if (bitmap) {
+	        j = (*bitmap & map_mask);
+	        if ((map_mask >>= 1) == 0) {
+		    map_mask = 128;
+		    bitmap++;
+	        }
+	        if (j == 0) {
+		    *flt++ = UNDEFINED;
+		    continue;
+	        }
+	    }
+
+	    jj = 0.0;
+	    j_bits = n_bits;
+	    while (c_bits <= j_bits) {
+	        if (c_bits == 8) {
+		    jj = jj * 256.0  + (double) (*bits++);
+		    j_bits -= 8;
+	        }
+	        else {
+		    jj = (jj * shift[c_bits]) + (double) (*bits & mask[c_bits]);
+		    bits++;
+		    j_bits -= c_bits;
+		    c_bits = 8;
+	        }
+	    }
+	    if (j_bits) {
+	        c_bits -= j_bits;
+	        jj = (jj * shift[j_bits]) + (double) ((*bits >> c_bits) & mask[j_bits]);
+	    }
+	    *flt++ = ref + scale*jj;
+        }
+    }
+    return;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/Changes b/wrfv2_fire/external/io_grib1/WGRIB/Changes
new file mode 100644
index 00000000..97eda5c2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/Changes
@@ -0,0 +1,167 @@
+v1.8.0.9i: 12/04 fixed typo introduced 11/04 (table 129, entry 192)
+v1.8.0.9h: 11/04 updated table ncep-129 (strange entry)
+v1.8.0.9g: 9/04 fix if (gds && GDS_Harmonic_type(gds) == 1)
+           found by Graziano Giuliani 
+v1.8.0.9f: 8/04 added ecmwf table 151
+v1.8.0.9e: 8/04 changes of CFS time ranges
+v1.8.0.9d: 7/04 fixed reanal grib table NLON -> ELON
+v1.8.0.9c: 6/04 chaged UVI defn ncep opn table
+v1.8.0.9b: 6/04 added table 132 (global reanalysis)
+v1.8.0.9a: 6/04 updated table 129,130
+v1.8.0.9: 5/04 added new time codes 132-135, changed time code 51 (clim)
+v1.8.0.8: 4/04 added -ncep_ens option
+v1.8.0.7e: 3/04 multiple user tables (fix open)
+v1.8.0.7d: 3/04 extern minute -> extern int minute
+v1.8.0.7c: 3/04 for clim (51) don't print 'anl'
+v1.8.0.7b: 2/04 update NCEP grib table 129
+v1.8.0.7a: 11/03 update NCEP grib table 131
+v1.8.0.7: 10/03 Mods fron Norwegian Meteorological Institute
+                fixed ec table 131, and enhansed ex_ext.c
+v1.8.0.6: 9/03 added time codes 128-131 (for RR)
+v1.8.0.5: 9/03 fix scan mode and change format
+v1.8.0.4: 9/03 new dwd tables and -dwdgrib option (thanks to Helmut P. Frank)
+               updated formats_update.txt for -dwdgrib option
+v1.8.0.3k: 7/03 fixed N/S vs grid wind diagnostic with -v option
+                  found by Dusan Jovic
+v1.8.0.3j: 6/03 fixed level 206 (was 205)
+v1.8.0.3i: 5/03 updated ncep table 131 
+v1.8.0.3h: 5/03 updated ncep table 131
+v1.8.0.3g: 4/03 ecmwf table 128, 140 (names from ECMWF web site), updated 131
+v1.8.0.3f: 4/03 updated ncep131, ncep130, ncep-opn
+v1.8.0.3e: 3/03 fix level 141, update tables 130 and 131
+v1.8.0.3d: 2/03 added prelim ncep grib tables 130 and 131
+v1.8.0.3c: 1/03 Reanalysis Project updates: scan mode in english, 
+    grid vs NS winds, and dusan.jovic@noaa.gov: ss2dEGRID support
+v1.8.0.3b: 1/03 minor update: changed units of CICE in NCEP tables
+v1.8.0.3a: 11/02 update ncep_opn and add ncep_129 table
+v1.8.0.3: 10/02 update levels and ncep_opn grib table
+v1.8.0.2: 10/02 check gds before grib_check, redid level 117
+v1.8.0.1: 10/02 added cptec gribtable 254
+v1.8: 4/1/02: Decode of simple packed spectral data and some cleanup of the
+     triangular grid (Luis Kornblueh, Max-Plank Institute of Meteorology)
+v1.7.4.1a 12/01: added new entry to OMB grib table (REV)
+v1.7.4.1 12/01: D. Haalman (METEO SERVICE weather research GmbH) 
+               rewrote seekgrib.c
+v1.7.4   10/01: Merged changes made by  Helmut P. Frank (DWD) to current 
+                source code.  This adds DWD tables 1, 201, 202, and 203 
+                as well as support for triangular grids based on an icosahedron
+1.7.3.6: 5/01: added fractional mb, center to levels.c
+1.7.3.5: 2/01: Handle grib files with precision greater than 31 bits
+1.7.3.4a: 9/00: check for missing grib file
+1.7.3.4: 8/00: polar stereo + lambert, always print direction increments
+1.7.3.2: 6/00: undefined direction increments set to zero on -V output
+1.7.3.1: 8/99: added new levels
+1.7.3:   5/99: updated NCEP opn grib table
+1.7.2:   5/99: fixed fictious error message with thinned grids and bitmaps
+1.7.1:   2/99: fixed error in wrtieee_header affects only -H option
+1.7.0b7: 1/99: preliminary support for NCEP ensembles
+1.7.0b6: 1/99: changed "x12 hours" format to "hr" format
+1.7.0b5: 1/99: fixed 3/6/12 hour forecast time units
+1.7.0b4 11/98: updated (128,160) and new (129,130,131,140,150,170,180)
+        ECMWF tables
+1.7.0b3 10/98: added new time units
+1.7.0b2 8/98: allow blank gribtab lines in definition, --v
+1.7.0b 8/98: added "km" to Mercator meta-data
+1.7: 7/98: fixed bitmap when nbits > 24 (theoretical bug)
+1.6.2.5 5/98: fixed -H code so that all of GDS is written
+1.6.2.4 4/98 beta: reanalysis ID code: needed for users of 1997 Reanalysis data
+1.6.2.2 2/98 beta: rotated lat long grid (10)
+1.6.2   1/98 added Arakawa E-grid meta-data
+1.6.1b  changed 03TOT to O3TOT in ncep operational table
+           note: typo originated in the original NCEP documentation
+1.6.1a  12/97 made ncep_opn the default table
+1.6.1   9/97 Added the "-d all" option
+1.6.0   9/97 non-beta version, added operational NCEP table,
+        optimized the ieee writes (2.5x faster on Cray, 20% on linux),
+        new help screen
+1.5.0b14 fix century mark: year=100 not 0
+1.5.0b13 -4yr, use 4 digit year code
+1.5.0b12 lat-long thinned grid support
+1.5.0b11 Added -H option (PDS/GDS output to binary files)
+1.5.0b10 Changed"0hr fcst" to "anl" for TR=10 and fcstlen = 0 (non-beta release)
+1.5.0b9 Thinned grids support (preliminary)
+1.5.0b8 Changed bitmap message
+1.5.0b7 -PDS -GDS work for all inventories
+1.5.0b6 Added -verf to print "verification" time, new grib2ctl for -verf
+1.5.0b5 Added Lambert Conformal, -PDS and -GDS
+1.5.0b1 Added ECMWF parameter table #128
+
+1.5.0a  wgrib failing with no GDS and constant field.  Cannot determine 
+(9/96)  the size of data without a center-dependent lookup table.
+        Set length size of data to 1.
+
+1.5.0   -v option: major changes, now an inventory
+(9/96)  -V option: added century to date code, list parameter table number,
+           added description of variable
+        Added parameter table (NCEP-128) for the ocean modeling branch of NCEP.
+        Added user-defined parameter tables.
+        Note: changes are incompatible with grib2ctl.  Get new version.
+         (old version works by changing "wgrib -v" to "wgrib -V".)
+        V1.5.0 is the first version to be parameter-table aware.  As a
+         result, wgrib will give a warning if it cannot find a matching
+         parameter table.  The warning can be eliminated by either using
+         a user-defined parameter table or by adding your table into
+         the wgrib source.  (Contact w. ebisuzaki, Wesley.Ebisuzaki@noaa.gov).
+        Built-in tables: NCEP-2, NCEP-128, ECMWF-160.
+        Much faster flt2ieee routine, changed rounding factor in flt2ieee
+         so that IEEE machines gets the correct last bit.
+        Increased NTRY to 100 to accommodate Automation div headers.
+        The 1.4.x series didn't last long (1 revision, 3/96 to 7/96).
+
+1.4.1a  Several optimizations of the grib routines for reduced CPU usage.
+(6/96)  Updated the NCEP parameter table and altered the print statement
+        for climatological fields.
+
+
+1.4 ******************************************************************
+1.4 
+1.4 BUG: Prior to v1.4, when the start of the grib message was less
+1.4  than 160 bytes from the end of the file, wgrib would not find
+1.4  the message.  This would only occur if a short grib message (< 160 bytes)
+1.4  ended the file.  Basically I had assumed that a grib message
+1.4  had to be 160+ bytes in length.  Well someone at NCEP decided
+1.4  to write 84-byte grib messages!  About the only field that
+1.4  can be described in a 84-byte message is uniform value of zero.
+1.4
+1.4  Fixed a bug in the return code, and made the code 10% faster.
+1.4
+1.4  Since this is a bug fix PLEASE upgrade to version 1.4.
+1.4  Why not? It's free!  (3/96)
+1.4
+1.4 ******************************************************************
+
+
+1.3.4h  Complaint about wgrib failing if the file has no GDS.  Since a GDS
+(2/96)  is recommended (and is in every file that I have seen) I've never 
+        included the code to create a GDS for prespecified grids.  This 
+        version is a temporary fix. It sets the array size to NX x 1.
+        [7/96: This temporary fix will have to do.  The GDS prespecified 
+        grids are center dependent.  Since I don't have the tables, nothing
+        is planned.]
+
+1.3.4f  updated ECMWF parameter table (from M. Fiorino)
+(11/95)	support for the ECMWF stream parameter
+	clean compiles using acc (SunOS) (acc is pickier than gcc -Wall)
+
+1.3.4e  writing grib files made much faster
+(11/95)
+1.3.4d  minor change in error statement format
+(9/95)
+1.3.4c  didn't check for case where number of bits = 0! in NMC bug check
+(7/95)
+1.3.4   added check for bad bds "used bits" parameter (look for NMC bug)
+(7/95)
+1.3.3:  (preliminary) ECMWF parameter table added
+(5/95)
+1.3.2:  preliminary polar stereographics map support
+(4/95)
+
+To Do:
+   decode spherical harmonics (need some examples to test on)
+   complex packing?
+
+Adding new parameter tables is pretty easy and I'm willing to add new
+parameter tables for "operational centers". (Note, the GRIB center
+identification numbers are assigned by the WMO.)
+
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/Makefile b/wrfv2_fire/external/io_grib1/WGRIB/Makefile
new file mode 100644
index 00000000..06bd444f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/Makefile
@@ -0,0 +1,29 @@
+.IGNORE:
+
+.SUFFIXES: .c .o
+
+CC=cc
+
+.c.o:
+	$(CC) -c -O2 $<
+
+obj=wgrib_main.o seekgrib.o ibm2flt.o readgrib.o intpower.o cnames.o BDSunpk.o \
+  flt2ieee.o wrtieee.o levels.o PDStimes.o missing.o  \
+  nceptable_reanal.o nceptable_opn.o ensemble.o \
+  ombtable.o ec_ext.o gribtable.o gds_grid.o PDS_date.o ectable_128.o \
+  ectable_129.o ectable_130.o ectable_131.o ectable_140.o ectable_150.o \
+  ectable_151.o ectable_160.o ectable_170.o ectable_180.o nceptab_129.o \
+  dwdtable_002.o dwdtable_201.o dwdtable_202.o dwdtable_203.o \
+  cptectable_254.o nceptab_130.o nceptab_131.o
+
+all: wgrib
+
+archive: wgrib
+
+wgrib: $(obj)
+	$(CC) -o wgrib $(obj) -lm
+	( cd .. ; \rm -f wgrib ; \ln -sf WGRIB/wgrib wgrib ; cd WGRIB )
+
+clean:	
+	\rm -f $(obj) wgrib
+	( cd .. ; \rm -f wgrib ; cd WGRIB )
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/PDS_date.c b/wrfv2_fire/external/io_grib1/WGRIB/PDS_date.c
new file mode 100644
index 00000000..0d15e361
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/PDS_date.c
@@ -0,0 +1,213 @@
+#include 
+#include 
+#include 
+#include 
+#include "pds4.h"
+#include "grib.h"
+
+/*
+ * PDS_date.c  v1.2 wesley ebisuzaki
+ *
+ * prints a string with a date code
+ *
+ * PDS_date(pds,option, v_time)
+ *   options=0  .. 2 digit year
+ *   options=1  .. 4 digit year
+ *
+ *   v_time=0   .. initial time
+ *   v_time=1   .. verification time
+ *
+ * assumption: P1 and P2 are unsigned integers (not clear from doc)
+ *
+ * v1.2 years that are multiple of 400 are leap years, not 500
+ * v1.2.1  make the change to the source code for v1.2
+ * v1.2.2  add 3/6/12 hour forecast time units
+ */
+
+static int msg_count = 0;
+extern int minute;
+
+int PDS_date(unsigned char *pds, int option, int v_time) {
+
+    int year, month, day, hour, min;
+
+    if (v_time == 0) {
+        year = PDS_Year4(pds);
+        month = PDS_Month(pds);
+        day  = PDS_Day(pds);
+        hour = PDS_Hour(pds);
+    }
+    else {
+        if (verf_time(pds, &year, &month, &day, &hour) != 0) {
+	    if (msg_count++ < 5) fprintf(stderr, "PDS_date: problem\n");
+	}
+    }
+    min =  PDS_Minute(pds);
+
+    switch(option) {
+	case 0:
+	    printf("%2.2d%2.2d%2.2d%2.2d", year % 100, month, day, hour);
+	    if (minute) printf("-%2.2d", min);
+	    break;
+	case 1:
+	    printf("%4.4d%2.2d%2.2d%2.2d", year, month, day, hour);
+	    if (minute) printf("-%2.2d", min);
+	    break;
+	default:
+	    fprintf(stderr,"missing code\n");
+	    exit(8);
+    }
+    return 0;
+}
+
+#define  FEB29   (31+29)
+static int monthjday[12] = {
+        0,31,59,90,120,151,181,212,243,273,304,334};
+
+static int leap(int year) {
+	if (year % 4 != 0) return 0;
+	if (year % 100 != 0) return 1;
+	return (year % 400 == 0);
+}
+
+
+int add_time(int *year, int *month, int *day, int *hour, int dtime, int unit) {
+    int y, m, d, h, jday, i;
+
+    y = *year;
+    m = *month;
+    d = *day;
+    h = *hour;
+
+    if (unit == YEAR) {
+	*year = y + dtime;
+	return 0;
+    }
+    if (unit == DECADE) {
+	*year =  y + (10 * dtime);
+	return 0;
+    }
+    if (unit == CENTURY) {
+	*year = y + (100 * dtime);
+	return 0;
+    }
+    if (unit == NORMAL) {
+	*year = y + (30 * dtime);
+	return 0;
+    }
+    if (unit == MONTH) {
+	dtime += (m - 1);
+	*year = y + (dtime / 12);
+	*month = 1 + (dtime % 12);
+	return 0;
+    }
+
+    if (unit == SECOND) {
+	dtime /= 60;
+	unit = MINUTE;
+    }
+    if (unit == MINUTE) {
+	dtime /= 60;
+	unit = HOUR;
+    }
+
+    if (unit == HOURS3) {
+        dtime *= 3;
+        unit = HOUR;
+    }
+    else if (unit == HOURS6) {
+        dtime *= 6;
+        unit = HOUR;
+    }
+    else if (unit == HOURS12) {
+        dtime *= 12;
+        unit = HOUR;
+    }
+
+    if (unit == HOUR) {
+	dtime += h;
+	*hour = dtime % 24;
+	dtime = dtime / 24;
+        unit = DAY;
+    }
+
+    /* this is the hard part */
+
+    if (unit == DAY) {
+	/* set m and day to Jan 0, and readjust dtime */
+	jday = d + monthjday[m-1];
+	if (leap(y) && m > 2) jday++;
+        dtime += jday;
+
+        /* 4 year chuncks */
+	i = dtime / (4 * 365 + 1);
+	if (i) {
+	    /* assume century years are leap */
+	    y = y + i*4;
+	    dtime -= i*(4 * 365 + 1);
+            /* see if we have gone past feb 28, 1900, 2000, etc */
+	    if ((y - 1) / 100 != (*year-1) / 100) {
+	        /* crossed the feb 28, xx00 */
+	        /* correct for only one century mark */
+		if ((y / 100) % 4 != 0) dtime++;
+	    }
+	}
+
+	/* one year chunks */
+	while (dtime > 365 + leap(y)) {
+	    dtime -= (365 + leap(y));
+	    y++;
+	}
+
+	/* calculate the month and day */
+
+	if (leap(y) && dtime == FEB29) {
+	    m = 2;
+	    d = 29;
+	}
+	else {
+	    if (leap(y) && dtime > FEB29) dtime--;
+	    for (i = 11; monthjday[i] >= dtime; --i);
+	    m = i + 1;
+	    d = dtime - monthjday[i];
+	}
+	*year = y;
+	*month = m;
+	*day = d;
+	return 0;
+   }
+   fprintf(stderr,"add_time: undefined time unit %d\n", unit);
+   return 1;
+}
+
+
+/*
+ * verf_time:
+ *
+ * this routine returns the "verification" time
+ * should have behavior similar to gribmap
+ *
+ */
+
+int verf_time(unsigned char *pds, int *year, int *month, int *day, int *hour) {
+    int tr, dtime, unit;
+
+    *year = PDS_Year4(pds);
+    *month = PDS_Month(pds);
+    *day  = PDS_Day(pds);
+    *hour = PDS_Hour(pds);
+
+    /* find time increment */
+
+    dtime = PDS_P1(pds);
+    tr = PDS_TimeRange(pds);
+    unit = PDS_ForecastTimeUnit(pds);
+
+    if (tr == 10) dtime = PDS_P1(pds) * 256 + PDS_P2(pds);
+    if (tr > 1 && tr < 6 ) dtime = PDS_P2(pds);
+
+    if (dtime == 0) return 0;
+
+    return add_time(year, month, day, hour, dtime, unit);
+}
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/PDStimes.c b/wrfv2_fire/external/io_grib1/WGRIB/PDStimes.c
new file mode 100644
index 00000000..2bcc9449
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/PDStimes.c
@@ -0,0 +1,216 @@
+#include 
+#include 
+#include 
+#include 
+#include "pds4.h"
+#include "grib.h"
+
+/*
+ * PDStimes.c   v1.2 wesley ebisuzaki
+ *
+ * prints something readable for time code in grib file
+ *
+ * not all cases decoded
+ * for NCEP/NCAR Reanalysis
+ *
+ * v1.2.1 1/99 fixed forecast time unit table
+ * v1.2.2 10/01 add time_range = 11 (at DWD)  Helmut P. Frank
+ */
+
+static char *units[] = {
+	"min", "hr", "d", "mon", "yr",
+	"decade", "normal", "century", "??", "??", " x3 hours", " x6 hours",
+        " x12 hours",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", "??", "??", "??", "??", "??", "??", "??", "??", "??",
+        "??", " sec"}; 
+
+void PDStimes(int time_range, int p1, int p2, int time_unit) {
+
+	char *unit;
+	enum {anal, fcst, unknown} type;
+	int fcst_len = 0;
+
+	if (time_unit >= 0 && time_unit <= sizeof(units)/sizeof(char *))
+             unit = units[time_unit];
+	else unit = "";
+
+
+        /* change x3/x6/x12 to hours */
+
+        if (time_unit == HOURS3) {
+	    p1 *= 3; p2 *= 3;
+	    time_unit = HOUR;
+        }
+        else if (time_unit == HOURS6) {
+	    p1 *= 6; p2 *= 6;
+	    time_unit = HOUR;
+        }
+        else if (time_unit == HOURS12) {
+	    p1 *= 12; p2 *= 12;
+	    time_unit = HOUR;
+        }
+
+	if (time_unit >= 0 && time_unit <= sizeof(units)/sizeof(char *))
+             unit = units[time_unit];
+	else unit = "";
+
+	/* figure out if analysis or forecast */
+	/* in GRIB, there is a difference between init and uninit analyses */
+	/* not case at NMC .. no longer run initialization */
+	/* ignore diff between init an uninit analyses */
+
+	switch (time_range) {
+
+	case 0:
+	case 1:
+	case 113:
+	case 114:
+	case 118:
+		if (p1 == 0) type = anal;
+		else {
+			type = fcst;
+			fcst_len = p1;
+		}
+		break;
+	case 10: /* way NMC uses it, should be unknown? */
+		type = fcst;
+		fcst_len = p1*256 + p2;
+		if (fcst_len == 0) type = anal;
+		break;
+
+	case 51:
+		type = unknown;
+		break;
+	case 123:
+	case 124:
+		type = anal;
+		break;
+
+	case 135:
+		type = anal;
+		break;
+
+	default: type = unknown;
+		break;
+	}
+
+	/* ----------------------------------------------- */
+
+	if (type == anal) printf("anl:");
+	else if (type == fcst) printf("%d%s fcst:",fcst_len,unit);
+
+
+	if (time_range == 123 || time_range == 124) {
+		if (p1 != 0) printf("start@%d%s:",p1,unit);
+	}
+
+
+	/* print time range */
+
+
+	switch (time_range) {
+
+	case 0:
+	case 1:
+	case 10:
+		break;
+	case 2: printf("valid %d-%d%s:",p1,p2,unit);
+		break;
+	case 3: printf("%d-%d%s ave:",p1,p2,unit);
+		break;
+	case 4: printf("%d-%d%s acc:",p1,p2,unit);
+		break;
+	case 5: printf("%d-%d%s diff:",p1,p2,unit);
+		break;
+	case 11: if (p1 > 0) {
+		    printf("init fcst %d%s:",p1,unit);
+		}
+		else {
+	            printf("time?:");
+		}
+		break;
+	case 51: if (p1 == 0) {
+		    /* printf("clim %d%s:",p2,unit); */
+		    printf("0-%d%s product:ave@1yr:",p2,unit);
+		}
+		else if (p1 == 1) {
+		    /* printf("clim (diurnal) %d%s:",p2,unit); */
+		    printf("0-%d%s product:same-hour,ave@1yr:",p2,unit);
+		}
+		else {
+		    printf("clim? p1=%d? %d%s?:",p1,p2,unit);
+		}
+		break;
+	case 113:
+	case 123:
+		printf("ave@%d%s:",p2,unit);
+		break;
+	case 114:
+	case 124:
+		printf("acc@%d%s:",p2,unit);
+		break;
+	case 115:
+		printf("ave of fcst:%d to %d%s:",p1,p2,unit);
+		break;
+	case 116:
+		printf("acc of fcst:%d to %d%s:",p1,p2,unit);
+		break;
+	case 118: 
+		printf("var@%d%s:",p2,unit);
+		break;
+	case 128:
+		printf("%d-%d%s fcst acc:ave@24hr:", p1, p2, unit);
+		break;
+	case 129:
+		printf("%d-%d%s fcst acc:ave@%d%s:", p1, p2, unit, p2-p1,unit);
+		break;
+	case 130:
+		printf("%d-%d%s fcst ave:ave@24hr:", p1, p2, unit);
+		break;
+	case 131:
+		printf("%d-%d%s fcst ave:ave@%d%s:", p1, p2, unit,p2-p1,unit);
+		break;
+		/* for CFS */
+	case 132:
+		printf("%d-%d%s anl:ave@1yr:", p1, p2, unit);
+		break;
+	case 133:
+		printf("%d-%d%s fcst:ave@1yr:", p1, p2, unit);
+		break;
+	case 134:
+		printf("%d-%d%s fcst-anl:rms@1yr:", p1, p2, unit);
+		break;
+	case 135:
+		printf("%d-%d%s fcst-fcst_mean:rms@1yr:", p1, p2, unit);
+		break;
+	case 136:
+		printf("%d-%d%s anl-anl_mean:rms@1yr:", p1, p2, unit);
+		break;
+		
+
+	default: printf("time?:");
+	}
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/README b/wrfv2_fire/external/io_grib1/WGRIB/README
new file mode 100644
index 00000000..5e981cc2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/README
@@ -0,0 +1,24 @@
+The wgrib program is by Wesley Ebisuzaki.  He can be
+reached at Wesley.Ebisuzaki@noaa.gov
+
+The wgrib homepage is:
+http://www.cpc.ncep.noaa.gov/products/wesley/wgrib.html
+
+This has source available, help, hints, docs, beta
+releases, etc.
+
+- - - - - - 
+
+Simple usage of the wgrib program (under the "howto:
+grib -> ieee" section of the web page:
+
+usage similar to diffwrf
+wgrib -s GRIBFILE | wgrib -s -i GRIBFILE
+This generates an ieee binary file called dump
+
+wgrib -s GRIBFILE | wgrib -s -i -text GRIBFILE
+This generates a text file called dump (text is
+50-100x slower than ieee)
+
+wgrib -s GRIBFILE | wgrib -s -i -text -o outfile GRIBFILE
+This generates a text file called outfile
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/bds.h b/wrfv2_fire/external/io_grib1/WGRIB/bds.h
new file mode 100644
index 00000000..b05212aa
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/bds.h
@@ -0,0 +1,49 @@
+/* 
+ * version 1.2.1 of grib headers  w. ebisuzaki 
+ *         1.2.2 added access to spectral reference value l. kornblueh
+ */
+
+#ifndef INT2
+#define INT2(a,b)   ((1-(int) ((unsigned) (a & 0x80) >> 6)) * (int) (((a & 0x7f) << 8) + b))
+#endif
+
+#define BDS_LEN(bds)		((int) ((bds[0]<<16)+(bds[1]<<8)+bds[2]))
+#define BDS_Flag(bds)		(bds[3])
+
+#define BDS_Grid(bds)		((bds[3] & 128) == 0)
+#define BDS_Harmonic(bds)	(bds[3] & 128)
+
+#define BDS_Packing(bds)	((bds[3] & 64) != 0)
+#define BDS_SimplePacking(bds)	((bds[3] & 64) == 0)
+#define BDS_ComplexPacking(bds)	((bds[3] & 64) != 0)
+
+#define BDS_OriginalType(bds)	((bds[3] & 32) != 0)
+#define BDS_OriginalFloat(bds)	((bds[3] & 32) == 0)
+#define BDS_OriginalInt(bds)	((bds[3] & 32) != 0)
+
+#define BDS_MoreFlags(bds)      ((bds[3] & 16) != 0)
+#define BDS_UnusedBits(bds)	((int) (bds[3] & 15))
+
+#define BDS_BinScale(bds)	INT2(bds[4],bds[5])
+
+#define BDS_RefValue(bds)	(ibm2flt(bds+6))
+#define BDS_NumBits(bds)	((int) bds[10])
+
+#define BDS_Harmonic_RefValue(bds) (ibm2flt(bds+11))
+
+#define BDS_DataStart(bds)      ((int) (11 + BDS_MoreFlags(bds)*3))
+
+/* breaks if BDS_NumBits(bds) == 0 */
+#define BDS_NValues(bds)        (((BDS_LEN(bds) - BDS_DataStart(bds))*8 - \
+				BDS_UnusedBits(bds)) / BDS_NumBits(bds))
+
+/*
+#define BDS_NValues(bds)        ((BDS_NumBits(bds) == 0) ? 0 : \
+				(((BDS_LEN(bds) - BDS_DataStart(bds))*8 - \
+				BDS_UnusedBits(bds)) / BDS_NumBits(bds)))
+*/
+
+
+/* undefined value -- if bitmap */
+#define UNDEFINED		9.999e20
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/bms.h b/wrfv2_fire/external/io_grib1/WGRIB/bms.h
new file mode 100644
index 00000000..c594cd74
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/bms.h
@@ -0,0 +1,8 @@
+/* version 1.2 of grib headers  w. ebisuzaki */
+
+#define BMS_LEN(bms)		((bms) == NULL ? 0 : (bms[0]<<16)+(bms[1]<<8)+bms[2])
+#define BMS_UnusedBits(bms)	((bms) == NULL ? 0 : bms[3])
+#define BMS_StdMap(bms)		((bms) == NULL ? 0 : ((bms[4]<<8) + bms[5]))
+#define BMS_bitmap(bms)		((bms) == NULL ? NULL : (bms)+6)
+#define BMS_nxny(bms)		((((bms) == NULL) || BMS_StdMap(bms)) \
+	? 0 : (BMS_LEN(bms)*8 - 48 - BMS_UnusedBits(bms)))
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/cnames.c b/wrfv2_fire/external/io_grib1/WGRIB/cnames.c
new file mode 100644
index 00000000..1ebba7bc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/cnames.c
@@ -0,0 +1,141 @@
+#include 
+#include 
+#include 
+#include "cnames.h"
+#include "pds4.h"
+#include "grib.h"
+
+/* cnames.c 				Wesley Ebisuzaki
+ *
+ * returns strings with either variable name or comment field
+ * v1.4 4/98
+ * reanalysis can use process 180 and subcenter 0
+ *
+ * Add DWD tables 2, 201, 202, 203      Helmut P. Frank, DWD, FE13
+ *                                      Thu Aug 23 09:28:34 GMT 2001
+ */
+
+
+extern  struct ParmTable parm_table_ncep_opn[256];
+extern  struct ParmTable parm_table_ncep_reanal[256];
+extern  struct ParmTable parm_table_nceptab_129[256];
+extern  struct ParmTable parm_table_omb[256];
+extern  struct ParmTable parm_table_nceptab_130[256];
+extern  struct ParmTable parm_table_nceptab_131[256];
+
+extern  struct ParmTable parm_table_ecmwf_128[256];
+extern  struct ParmTable parm_table_ecmwf_129[256];
+extern  struct ParmTable parm_table_ecmwf_130[256];
+extern  struct ParmTable parm_table_ecmwf_131[256];
+extern  struct ParmTable parm_table_ecmwf_140[256];
+extern  struct ParmTable parm_table_ecmwf_150[256];
+extern  struct ParmTable parm_table_ecmwf_151[256];
+extern  struct ParmTable parm_table_ecmwf_160[256];
+extern  struct ParmTable parm_table_ecmwf_170[256];
+extern  struct ParmTable parm_table_ecmwf_180[256];
+extern  struct ParmTable parm_table_user[256];
+extern  struct ParmTable parm_table_dwd_002[256];
+extern  struct ParmTable parm_table_dwd_201[256];
+extern  struct ParmTable parm_table_dwd_202[256];
+extern  struct ParmTable parm_table_dwd_203[256];
+extern  struct ParmTable parm_table_cptec_254[256];
+
+extern enum Def_NCEP_Table def_ncep_table;
+
+/*
+ * returns pointer to the parameter table
+ */
+
+
+
+static struct ParmTable *Parm_Table(unsigned char *pds) {
+
+    int i, center, subcenter, ptable, process;
+    static int missing_count = 0, reanal_opn_count = 0;
+
+    center = PDS_Center(pds);
+    subcenter = PDS_Subcenter(pds);
+    ptable = PDS_Vsn(pds);
+
+#ifdef P_TABLE_FIRST
+    i = setup_user_table(center, subcenter, ptable);
+    if (i == 1) return &parm_table_user[0];
+#endif
+    /* figure out if NCEP opn or reanalysis */
+    if (center == NMC && ptable <= 3) {
+	if (subcenter == 1) return &parm_table_ncep_reanal[0];
+        process = PDS_Model(pds);
+	if (subcenter != 0 || (process != 80 && process != 180) || 
+		(ptable != 1 && ptable != 2)) 
+            return &parm_table_ncep_opn[0];
+
+	/* at this point could be either the opn or reanalysis table */
+	if (def_ncep_table == opn_nowarn) return &parm_table_ncep_opn[0];
+	if (def_ncep_table == rean_nowarn) return &parm_table_ncep_reanal[0];
+        if (reanal_opn_count++ == 0) {
+	    fprintf(stderr, "Using NCEP %s table, see -ncep_opn, -ncep_rean options\n",
+               (def_ncep_table == opn) ?  "opn" : "reanalysis");
+	}
+        return (def_ncep_table == opn) ?  &parm_table_ncep_opn[0] 
+		: &parm_table_ncep_reanal[0];
+    }
+
+    if (center == NMC) {
+        if (ptable == 128) return &parm_table_omb[0];
+        if (ptable == 129) return &parm_table_nceptab_129[0];
+        if (ptable == 130) return &parm_table_nceptab_130[0];
+        if (ptable == 131) return &parm_table_nceptab_131[0];
+        if (ptable == 132) return &parm_table_ncep_reanal[0];
+    }
+    if (center == ECMWF) {
+        if (ptable == 128) return &parm_table_ecmwf_128[0];
+        if (ptable == 129) return &parm_table_ecmwf_129[0];
+        if (ptable == 130) return &parm_table_ecmwf_130[0];
+        if (ptable == 131) return &parm_table_ecmwf_131[0];
+        if (ptable == 140) return &parm_table_ecmwf_140[0];
+        if (ptable == 150) return &parm_table_ecmwf_150[0];
+        if (ptable == 151) return &parm_table_ecmwf_151[0];
+        if (ptable == 160) return &parm_table_ecmwf_160[0];
+        if (ptable == 170) return &parm_table_ecmwf_170[0];
+        if (ptable == 180) return &parm_table_ecmwf_180[0];
+    }
+    if (center == DWD) {
+        if (ptable ==   2) return &parm_table_dwd_002[0];
+        if (ptable == 201) return &parm_table_dwd_201[0];
+        if (ptable == 202) return &parm_table_dwd_202[0];
+        if (ptable == 203) return &parm_table_dwd_203[0];
+    }
+    if (center == CPTEC) {
+	if (ptable == 254) return &parm_table_cptec_254[0];
+    }
+
+#ifndef P_TABLE_FIRST
+    i = setup_user_table(center, subcenter, ptable);
+    if (i == 1) return &parm_table_user[0];
+#endif
+
+    if ((ptable > 3 || (PDS_PARAM(pds)) > 127) && missing_count++ == 0) {
+	fprintf(stderr,
+            "\nUndefined parameter table (center %d-%d table %d), using NCEP-opn\n",
+            center, subcenter, ptable);
+    }
+    return &parm_table_ncep_opn[0];
+}
+
+/*
+ * return name field of PDS_PARAM(pds)
+ */
+
+char *k5toa(unsigned char *pds) {
+
+    return (Parm_Table(pds) + PDS_PARAM(pds))->name;
+}
+
+/*
+ * return comment field of the PDS_PARAM(pds)
+ */
+
+char *k5_comments(unsigned char *pds) {
+
+    return (Parm_Table(pds) + PDS_PARAM(pds))->comment;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/cnames.h b/wrfv2_fire/external/io_grib1/WGRIB/cnames.h
new file mode 100644
index 00000000..17453d87
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/cnames.h
@@ -0,0 +1,29 @@
+/* cnames_file.c */
+
+/* search order for parameter names
+ *
+ * #define P_TABLE_FIRST
+ * look at external parameter table first
+ *
+ * otherwise use builtin NCEP-2 or ECMWF-160 first
+ */
+/* #define P_TABLE_FIRST */
+
+/* search order for external parameter table
+ * 1) environment variable GRIBTAB
+ * 2) environment variable gribtab
+ * 3) the file 'gribtab' in current directory
+ */
+
+
+/* cnames.c */
+/* then default values */
+char *k5toa(unsigned char *pds);
+char *k5_comments(unsigned char *pds);
+int setup_user_table(int center, int subcenter, int ptable);
+
+
+struct ParmTable {
+	char *name, *comment;
+};
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/cptectable_254.c b/wrfv2_fire/external/io_grib1/WGRIB/cptectable_254.c
new file mode 100644
index 00000000..f5431f56
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/cptectable_254.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_cptec_254[256] = {
+   /* 0 */ {"var0", "undefined"},
+   /* 1 */ {"PRES", "Pressure [hPa]"},
+   /* 2 */ {"psnm", "Pressure reduced to MSL [hPa]"},
+   /* 3 */ {"tsps", "Pressure tendency [Pa/s]"},
+   /* 4 */ {"var4", "undefined"},
+   /* 5 */ {"var5", "undefined"},
+   /* 6 */ {"geop", "Geopotential [dam]"},
+   /* 7 */ {"zgeo", "Geopotential height [gpm]"},
+   /* 8 */ {"gzge", "Geometric height [m]"},
+   /* 9 */ {"var9", "undefined"},
+   /* 10 */ {"var10", "undefined"},
+   /* 11 */ {"temp", "ABSOLUTE TEMPERATURE [K]"},
+   /* 12 */ {"vtmp", "VIRTUAL TEMPERATURE [K]"},
+   /* 13 */ {"ptmp", "POTENTIAL TEMPERATURE [K]"},
+   /* 14 */ {"psat", "PSEUDO-ADIABATIC POTENTIAL TEMPERATURE [K]"},
+   /* 15 */ {"mxtp", "MAXIMUM TEMPERATURE [K]"},
+   /* 16 */ {"mntp", "MINIMUM TEMPERATURE [K]"},
+   /* 17 */ {"tpor", "DEW POINT TEMPERATURE [K]"},
+   /* 18 */ {"dptd", "DEW POINT DEPRESSION [K]"},
+   /* 19 */ {"lpsr", "LAPSE RATE [K/m]"},
+   /* 20 */ {"var20", "undefined"},
+   /* 21 */ {"rds1", "RADAR SPECTRA(1) [non-dim]"},
+   /* 22 */ {"rds2", "RADAR SPECTRA(2) [non-dim]"},
+   /* 23 */ {"rds3", "RADAR SPECTRA(3) [non-dim]"},
+   /* 24 */ {"var24", "undefined"},
+   /* 25 */ {"tpan", "TEMPERATURE ANOMALY [K]"},
+   /* 26 */ {"psan", "PRESSURE ANOMALY [Pa hPa]"},
+   /* 27 */ {"zgan", "GEOPOT HEIGHT ANOMALY [m]"},
+   /* 28 */ {"wvs1", "WAVE SPECTRA(1) [non-dim]"},
+   /* 29 */ {"wvs2", "WAVE SPECTRA(2) [non-dim]"},
+   /* 30 */ {"wvs3", "WAVE SPECTRA(3) [non-dim]"},
+   /* 31 */ {"wind", "WIND DIRECTION  [deg]"},
+   /* 32 */ {"wins", "WIND SPEED [m/s]"},
+   /* 33 */ {"uvel", "ZONAL WIND (U) [m/s]"},
+   /* 34 */ {"vvel", "MERIDIONAL WIND (V) [m/s]"},
+   /* 35 */ {"fcor", "STREAM FUNCTION [m2/s]"},
+   /* 36 */ {"potv", "VELOCITY POTENTIAL [m2/s]"},
+   /* 37 */ {"var37", "undefined"},
+   /* 38 */ {"sgvv", "SIGMA COORD VERT VEL [sec/sec]"},
+   /* 39 */ {"omeg", "OMEGA [Pa/s]"},
+   /* 40 */ {"omg2", "VERTICAL VELOCITY [m/s]"},
+   /* 41 */ {"abvo", "ABSOLUTE VORTICITY        [10**5/sec]"},
+   /* 42 */ {"abdv", "ABSOLUTE DIVERGENCE [10**5/sec]"},
+   /* 43 */ {"vort", "VORTICITY  [1/s]"},
+   /* 44 */ {"divg", "DIVERGENCE [1/s]"},
+   /* 45 */ {"vucs", "VERTICAL U-COMP SHEAR [1/sec]"},
+   /* 46 */ {"vvcs", "VERT V-COMP SHEAR [1/sec]"},
+   /* 47 */ {"dirc", "DIRECTION OF CURRENT [deg]"},
+   /* 48 */ {"spdc", "SPEED OF CURRENT [m/s]"},
+   /* 49 */ {"ucpc", "U-COMPONENT OF CURRENT [m/s]"},
+   /* 50 */ {"vcpc", "V-COMPONENT OF CURRENT [m/s]"},
+   /* 51 */ {"umes", "SPECIFIC HUMIDITY [kg/kg]"},
+   /* 52 */ {"umrl", "RELATIVE HUMIDITY [no Dim]"},
+   /* 53 */ {"hmxr", "HUMIDITY MIXING RATIO [kg/kg]"},
+   /* 54 */ {"agpl", "INST. PRECIPITABLE WATER [Kg/m2]"},
+   /* 55 */ {"vapp", "VAPOUR PRESSURE [Pa hpa]"},
+   /* 56 */ {"sadf", "SATURATION DEFICIT        [Pa hPa]"},
+   /* 57 */ {"evap", "EVAPORATION [Kg/m2/day]"},
+   /* 58 */ {"var58", "undefined"},
+   /* 59 */ {"prcr", "PRECIPITATION RATE        [kg/m2/day]"},
+   /* 60 */ {"thpb", "THUNDER PROBABILITY [%]"},
+   /* 61 */ {"prec", "TOTAL PRECIPITATION [Kg/m2/day]"},
+   /* 62 */ {"prge", "LARGE SCALE PRECIPITATION [Kg/m2/day]"},
+   /* 63 */ {"prcv", "CONVECTIVE PRECIPITATION [Kg/m2/day]"},
+   /* 64 */ {"neve", "SNOWFALL [Kg/m2/day]"},
+   /* 65 */ {"wenv", "WAT EQUIV ACC SNOW DEPTH [kg/m2]"},
+   /* 66 */ {"nvde", "SNOW DEPTH        [cm]"},
+   /* 67 */ {"mxld", "MIXED LAYER DEPTH [m cm]"},
+   /* 68 */ {"tthd", "TRANS THERMOCLINE DEPTH [m cm]"},
+   /* 69 */ {"mthd", "MAIN THERMOCLINE DEPTH [m cm]"},
+   /* 70 */ {"mtha", "MAIN THERMOCLINE ANOM [m cm]"},
+   /* 71 */ {"cbnv", "CLOUD COVER [0-1]"},
+   /* 72 */ {"cvnv", "CONVECTIVE CLOUD COVER [0-1]"},
+   /* 73 */ {"lwnv", "LOW CLOUD COVER [0-1]"},
+   /* 74 */ {"mdnv", "MEDIUM CLOUD COVER        [0-1]"},
+   /* 75 */ {"hinv", "HIGH CLOUD COVER [0-1]"},
+   /* 76 */ {"wtnv", "CLOUD WATER [kg/m2]"},
+   /* 77 */ {"bli", "BEST LIFTED INDEX (TO 500 HPA) [K]"},
+   /* 78 */ {"var78", "undefined"},
+   /* 79 */ {"var79", "undefined"},
+   /* 80 */ {"var80", "undefined"},
+   /* 81 */ {"lsmk", "LAND SEA MASK [0,1]"},
+   /* 82 */ {"dslm", "DEV SEA_LEV FROM MEAN [m]"},
+   /* 83 */ {"zorl", "ROUGHNESS LENGTH [m]"},
+   /* 84 */ {"albe", "ALBEDO [%]"},
+   /* 85 */ {"dstp", "DEEP SOIL TEMPERATURE [K]"},
+   /* 86 */ {"soic", "SOIL MOISTURE CONTENT [Kg/m2]"},
+   /* 87 */ {"vege", "VEGETATION        [%]"},
+   /* 88 */ {"var88", "undefined"},
+   /* 89 */ {"dens", "DENSITY [kg/m3]"},
+   /* 90 */ {"var90", "Undefined"},
+   /* 91 */ {"icec", "ICE CONCENTRATION [fraction]"},
+   /* 92 */ {"icet", "ICE THICKNESS [m]"},
+   /* 93 */ {"iced", "DIRECTION OF ICE DRIFT [deg]"},
+   /* 94 */ {"ices", "SPEED OF ICE DRIFT        [m/s]"},
+   /* 95 */ {"iceu", "U-COMP OF ICE DRIFT [m/s]"},
+   /* 96 */ {"icev", "V-COMP OF ICE DRIFT [m/s]"},
+   /* 97 */ {"iceg", "ICE GROWTH        [m]"},
+   /* 98 */ {"icdv", "ICE DIVERGENCE [sec/sec]"},
+   /* 99 */ {"var99", "undefined"},
+   /* 100 */ {"shcw", "SIG HGT COM WAVE/SWELL [m]"},
+   /* 101 */ {"wwdi", "DIRECTION OF WIND WAVE [deg]"},
+   /* 102 */ {"wwsh", "SIG HGHT OF WIND WAVES [m]"},
+   /* 103 */ {"wwmp", "MEAN PERIOD WIND WAVES [sec]"},
+   /* 104 */ {"swdi", "DIRECTION OF SWELL WAVE [deg]"},
+   /* 105 */ {"swsh", "SIG HEIGHT SWELL WAVES [m]"},
+   /* 106 */ {"swmp", "MEAN PERIOD SWELL WAVES [sec]"},
+   /* 107 */ {"prwd", "PRIMARY WAVE DIRECTION [deg]"},
+   /* 108 */ {"prmp", "PRIM WAVE MEAN PERIOD [s]"},
+   /* 109 */ {"swdi", "SECOND WAVE DIRECTION [deg]"},
+   /* 110 */ {"swmp", "SECOND WAVE MEAN PERIOD [s]"},
+   /* 111 */ {"ocas", "SHORT WAVE ABSORBED AT GROUND [W/m2]"},
+   /* 112 */ {"slds", "NET LONG WAVE AT BOTTOM [W/m2]"},
+   /* 113 */ {"nswr", "NET SHORT-WAV RAD(TOP) [W/m2]"},
+   /* 114 */ {"role", "OUTGOING LONG WAVE AT TOP [W/m2]"},
+   /* 115 */ {"lwrd", "LONG-WAV RAD [W/m2]"},
+   /* 116 */ {"swea", "SHORT WAVE ABSORBED BY EARTH/ATMOSPHERE  [W/m2]"},
+   /* 117 */ {"glbr", "GLOBAL RADIATION [W/m2 ]"},
+   /* 118 */ {"var118", "undefined"},
+   /* 119 */ {"var119", "undefined"},
+   /* 120 */ {"var120", "undefined"},
+   /* 121 */ {"clsf", "LATENT HEAT FLUX FROM SURFACE [W/m2]"},
+   /* 122 */ {"cssf", "SENSIBLE HEAT FLUX FROM SURFACE [W/m2]"},
+   /* 123 */ {"blds", "BOUND LAYER DISSIPATION [W/m2]"},
+   /* 124 */ {"var124", "undefined"},
+   /* 125 */ {"var125", "undefined"},
+   /* 126 */ {"var126", "undefined"},
+   /* 127 */ {"imag", "IMAGE [image^data]"},
+   /* 128 */ {"tp2m", "2 METRE TEMPERATURE [K]"},
+   /* 129 */ {"dp2m", "2 METRE DEWPOINT TEMPERATURE [K]"},
+   /* 130 */ {"u10m", "10 METRE U-WIND COMPONENT [m/s]"},
+   /* 131 */ {"v10m", "10 METRE V-WIND COMPONENT [m/s]"},
+   /* 132 */ {"topo", "TOPOGRAPHY [m]"},
+   /* 133 */ {"gsfp", "GEOMETRIC MEAN SURFACE PRESSURE [hPa]"},
+   /* 134 */ {"lnsp", "LN SURFACE PRESSURE [hPa]"},
+   /* 135 */ {"pslc", "SURFACE PRESSURE [hPa]"},
+   /* 136 */ {"pslm", "M S L PRESSURE (MESINGER METHOD) [hPa]"},
+   /* 137 */ {"mask", "MASK  [-/+]"},
+   /* 138 */ {"mxwu", "MAXIMUM U-WIND [m/s]"},
+   /* 139 */ {"mxwv", "MAXIMUM V-WIND [m/s]"},
+   /* 140 */ {"cape", "CONVECTIVE AVAIL. POT.ENERGY [m2/s2]"},
+   /* 141 */ {"cine", "CONVECTIVE INHIB. ENERGY [m2/s2]"},
+   /* 142 */ {"lhcv", "CONVECTIVE LATENT HEATING [K/s]"},
+   /* 143 */ {"mscv", "CONVECTIVE MOISTURE SOURCE [1/s]"},
+   /* 144 */ {"scvm", "SHALLOW CONV. MOISTURE SOURCE [1/s]"},
+   /* 145 */ {"scvh", "SHALLOW CONVECTIVE HEATING [K/s]"},
+   /* 146 */ {"mxwp", "MAXIMUM WIND PRESS. LVL  [hPa]"},
+   /* 147 */ {"ustr", "STORM MOTION U-COMPONENT [m/s]"},
+   /* 148 */ {"vstr", "STORM MOTION V-COMPONENT [m/s]"},
+   /* 149 */ {"cbnt", "MEAN CLOUD COVER [0-1]"},
+   /* 150 */ {"pcbs", "PRESSURE AT CLOUD BASE [hPa]"},
+   /* 151 */ {"pctp", "PRESSURE AT CLOUD TOP [hPa]"},
+   /* 152 */ {"fzht", "FREEZING LEVEL HEIGHT [m]"},
+   /* 153 */ {"fzrh", "FREEZING LEVEL RELATIVE HUMIDITY [%]"},
+   /* 154 */ {"fdlt", "FLIGHT LEVELS TEMPERATURE [K]"},
+   /* 155 */ {"fdlu", "FLIGHT LEVELS U-WIND [m/s]"},
+   /* 156 */ {"fdlv", "FLIGHT LEVELS V-WIND [m/s]"},
+   /* 157 */ {"tppp", "TROPOPAUSE PRESSURE   [hPa]"},
+   /* 158 */ {"tppt", "TROPOPAUSE TEMPERATURE [K]"},
+   /* 159 */ {"tppu", "TROPOPAUSE U-WIND COMPONENT [m/s]"},
+   /* 160 */ {"tppv", "TROPOPAUSE v-WIND COMPONENT [m/s]"},
+   /* 161 */ {"var161", "undefined"},
+   /* 162 */ {"gvdu", "GRAVITY WAVE DRAG DU/DT [m/s2]"},
+   /* 163 */ {"gvdv", "GRAVITY WAVE DRAG DV/DT [m/s2]"},
+   /* 164 */ {"gvus", "GRAVITY WAVE DRAG SFC ZONAL STRESS  [Pa]"},
+   /* 165 */ {"gvvs", "GRAVITY WAVE DRAG SFC MERIDIONAL STRESS [Pa]"},
+   /* 166 */ {"var166", "undefined"},
+   /* 167 */ {"dvsh", "DIVERGENCE OF SPECIFIC HUMIDITY [1/s]"},
+   /* 168 */ {"hmfc", "HORIZ. MOISTURE FLUX CONV.  [1/s]"},
+   /* 169 */ {"vmfl", "VERT. INTEGRATED MOISTURE FLUX CONV. [kg/(m2*s)]"},
+   /* 170 */ {"vadv", "VERTICAL MOISTURE ADVECTION  [kg/(kg*s)]"},
+   /* 171 */ {"nhcm", "NEG. HUM. CORR. MOISTURE SOURCE [kg/(kg*s)]"},
+   /* 172 */ {"lglh", "LARGE SCALE LATENT HEATING   [K/s]"},
+   /* 173 */ {"lgms", "LARGE SCALE MOISTURE SOURCE  [1/s]"},
+   /* 174 */ {"smav", "SOIL MOISTURE AVAILABILITY  [0-1]"},
+   /* 175 */ {"tgrz", "SOIL TEMPERATURE OF ROOT ZONE [K]"},
+   /* 176 */ {"bslh", "BARE SOIL LATENT HEAT [Ws/m2]"},
+   /* 177 */ {"evpp", "POTENTIAL SFC EVAPORATION [m]"},
+   /* 178 */ {"rnof", "RUNOFF [kg/m2/s)]"},
+   /* 179 */ {"pitp", "INTERCEPTION LOSS [W/m2]"},
+   /* 180 */ {"vpca", "VAPOR PRESSURE OF CANOPY AIR SPACE [mb]"},
+   /* 181 */ {"qsfc", "SURFACE SPEC HUMIDITY   [kg/kg]"},
+   /* 182 */ {"ussl", "SOIL WETNESS OF SURFACE [0-1]"},
+   /* 183 */ {"uzrs", "SOIL WETNESS OF ROOT ZONE [0-1]"},
+   /* 184 */ {"uzds", "SOIL WETNESS OF DRAINAGE ZONE [0-1]"},
+   /* 185 */ {"amdl", "STORAGE ON CANOPY [m]"},
+   /* 186 */ {"amsl", "STORAGE ON GROUND [m]"},
+   /* 187 */ {"tsfc", "SURFACE TEMPERATURE [K]"},
+   /* 188 */ {"tems", "SURFACE ABSOLUTE TEMPERATURE [K]"},
+   /* 189 */ {"tcas", "TEMPERATURE OF CANOPY AIR SPACE [K]"},
+   /* 190 */ {"ctmp", "TEMPERATURE AT CANOPY [K]"},
+   /* 191 */ {"tgsc", "GROUND/SURFACE COVER TEMPERATURE [K]"},
+   /* 192 */ {"uves", "SURFACE ZONAL WIND (U) [m/s]"},
+   /* 193 */ {"usst", "SURFACE ZONAL WIND STRESS [Pa]"},
+   /* 194 */ {"vves", "SURFACE MERIDIONAL WIND (V) [m/s]"},
+   /* 195 */ {"vsst", "SURFACE MERIDIONAL WIND STRESS [Pa]"},
+   /* 196 */ {"suvf", "SURFACE MOMENTUM FLUX [W/m2]"},
+   /* 197 */ {"iswf", "INCIDENT SHORT WAVE FLUX [W/m2]"},
+   /* 198 */ {"ghfl", "TIME AVE GROUND HT FLX   [W/m2]"},
+   /* 199 */ {"var199", "undefined"},
+   /* 200 */ {"lwbc", "NET LONG WAVE AT BOTTOM (CLEAR) [W/m2]"},
+   /* 201 */ {"lwtc", "OUTGOING LONG WAVE AT TOP (CLEAR) [W/m2]"},
+   /* 202 */ {"swec", "SHORT WV ABSRBD BY EARTH/ATMOS (CLEAR) [W/m2]"},
+   /* 203 */ {"ocac", "SHORT WAVE ABSORBED AT GROUND (CLEAR) [W/m2]"},
+   /* 204 */ {"var204", "undefined"},
+   /* 205 */ {"lwrh", "LONG WAVE RADIATIVE HEATING  [K/s]"},
+   /* 206 */ {"swrh", "SHORT WAVE RADIATIVE HEATING [K/s]"},
+   /* 207 */ {"olis", "DOWNWARD LONG WAVE AT BOTTOM [W/m2]"},
+   /* 208 */ {"olic", "DOWNWARD LONG WAVE AT BOTTOM (CLEAR) [W/m2]"},
+   /* 209 */ {"ocis", "DOWNWARD SHORT WAVE AT GROUND [W/m2]"},
+   /* 210 */ {"ocic", "DOWNWARD SHORT WAVE AT GROUND (CLEAR) [W/m2]"},
+   /* 211 */ {"oles", "UPWARD LONG WAVE AT BOTTOM [W/m2]"},
+   /* 212 */ {"oces", "UPWARD SHORT WAVE AT GROUND [W/m2]"},
+   /* 213 */ {"swgc", "UPWARD SHORT WAVE AT GROUND (CLEAR) [W/m2]"},
+   /* 214 */ {"roce", "UPWARD SHORT WAVE AT TOP [W/m2]"},
+   /* 215 */ {"swtc", "UPWARD SHORT WAVE AT TOP (CLEAR) [W/m2]"},
+   /* 216 */ {"var216", "undefined"},
+   /* 217 */ {"var217", "undefined"},
+   /* 218 */ {"hhdf", "HORIZONTAL HEATING DIFFUSION [K/s]"},
+   /* 219 */ {"hmdf", "HORIZONTAL MOISTURE DIFFUSION [1/s]"},
+   /* 220 */ {"hddf", "HORIZONTAL DIVERGENCE DIFFUSION [1/s2]"},
+   /* 221 */ {"hvdf", "HORIZONTAL VORTICITY DIFFUSION [1/s2]"},
+   /* 222 */ {"vdms", "VERTICAL DIFF. MOISTURE SOURCE [1/s]"},
+   /* 223 */ {"vdfu", "VERTICAL DIFFUSION DU/DT [m/s2]"},
+   /* 224 */ {"vdfv", "VERTICAL DIFFUSION DV/DT [m/s2]"},
+   /* 225 */ {"vdfh", "VERTICAL DIFFUSION HEATING [K/s]"},
+   /* 226 */ {"umrs", "SURFACE RELATIVE HUMIDITY [no Dim]"},
+   /* 227 */ {"vdcc", "VERTICAL DIST TOTAL CLOUD COVER [no Dim]"},
+   /* 228 */ {"var228", "undefined"},
+   /* 229 */ {"var229", "undefined"},
+   /* 230 */ {"usmt", "TIME MEAN SURFACE ZONAL WIND (U) [m/s]"},
+   /* 231 */ {"vsmt", "TIME MEAN SURFACE MERIDIONAL WIND (V) [m/s]"},
+   /* 232 */ {"tsmt", "TIME MEAN SURFACE ABSOLUTE TEMPERATURE [K]"},
+   /* 233 */ {"rsmt", "TIME MEAN SURFACE RELATIVE HUMIDITY [no Dim]"},
+   /* 234 */ {"atmt", "TIME MEAN ABSOLUTE TEMPERATURE [K]"},
+   /* 235 */ {"stmt", "TIME MEAN DEEP SOIL TEMPERATURE [K]"},
+   /* 236 */ {"ommt", "TIME MEAN DERIVED OMEGA [Pa/s]"},
+   /* 237 */ {"dvmt", "TIME MEAN DIVERGENCE [1/s]"},
+   /* 238 */ {"zhmt", "TIME MEAN GEOPOTENTIAL HEIGHT [m]"},
+   /* 239 */ {"lnmt", "TIME MEAN LOG SURFACE PRESSURE [ln(cbar)]"},
+   /* 240 */ {"mkmt", "TIME MEAN MASK [-/+]"},
+   /* 241 */ {"vvmt", "TIME MEAN MERIDIONAL WIND (V) [m/s]"},
+   /* 242 */ {"omtm", "TIME MEAN OMEGA  [cbar/s]"},
+   /* 243 */ {"ptmt", "TIME MEAN POTENTIAL TEMPERATURE [K]"},
+   /* 244 */ {"pcmt", "TIME MEAN PRECIP. WATER  [kg/m2]"},
+   /* 245 */ {"rhmt", "TIME MEAN RELATIVE HUMIDITY [%]"},
+   /* 246 */ {"mpmt", "TIME MEAN SEA LEVEL PRESSURE [hPa]"},
+   /* 247 */ {"simt", "TIME MEAN SIGMADOT [1/s]"},
+   /* 248 */ {"uemt", "TIME MEAN SPECIFIC HUMIDITY [kg/kg]"},
+   /* 249 */ {"fcmt", "TIME MEAN STREAM FUNCTION| m2/s]"},
+   /* 250 */ {"psmt", "TIME MEAN SURFACE PRESSURE [hPa]"},
+   /* 251 */ {"tmmt", "TIME MEAN SURFACE TEMPERATURE [K]"},
+   /* 252 */ {"pvmt", "TIME MEAN VELOCITY POTENTIAL [m2/s]"},
+   /* 253 */ {"tvmt", "TIME MEAN VIRTUAL TEMPERATURE [K]"},
+   /* 254 */ {"vtmt", "TIME MEAN VORTICITY [1/s]"},
+   /* 255 */ {"uvmt", "TIME MEAN ZONAL WIND (U) [m/s]"},
+};
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_002.c b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_002.c
new file mode 100644
index 00000000..77c15407
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_002.c
@@ -0,0 +1,266 @@
+#include "cnames.h"
+
+/*
+ * GRIB table 2 at DWD
+ *     Helmut P. Frank, 30.08.2001
+ * updated 24.07.2003: PMSL, DD, FF, W, FR_ICE, H_ICE
+ */
+
+struct ParmTable parm_table_dwd_002[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"PS", "pressure [Pa]"},
+    /* 2 */ {"PMSL", "pressure reduced to MSL [Pa]"},
+    /* 3 */ {"p-tendency", "pressure tendency [Pa/s]"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"FI", "geopotential [(m**2)/(s**2)]"},
+    /* 7 */ {"geopot h", "geopotential height [gpm]"},
+    /* 8 */ {"geomet h", "geometrical height [m]"},
+    /* 9 */ {"dev of h", "standard deviation of height [m]"},
+    /* 10 */ {"TO3", "total ozone [Dobson Units]"},
+    /* 11 */ {"T", "temperature [K]"},
+    /* 12 */ {"virt.temp.", "virtual temperature [K]"},
+    /* 13 */ {"pot. temp.", "potential temperature [K]"},
+    /* 14 */ {"pseudo-pot", "pseudo-adiabatic potential temperature [K]"},
+    /* 15 */ {"TMAX", "maximum temperature [K]"},
+    /* 16 */ {"TMIN", "minimum temperature [K]"},
+    /* 17 */ {"TD", "dew-point temperature [K]"},
+    /* 18 */ {"dew-pnt de", "dew-point depression (or deficit) [K]"},
+    /* 19 */ {"lapse rate", "laps rate [K/m]"},
+    /* 20 */ {"visibility", "visibility [m]"},
+    /* 21 */ {"radar sp 1", "radar spectra (1) [non-dim]"},
+    /* 22 */ {"radar sp 2", "radar spectra (2) [non-dim]"},
+    /* 23 */ {"radar sp 3", "radar spectra (3) [non-dim]"},
+    /* 24 */ {"pli to 500", "parcel lifted index (to 500 hPa) [K]"},
+    /* 25 */ {"temp anom", "temperature anomaly [K]"},
+    /* 26 */ {"pres anom", "pressure anomaly [Pa]"},
+    /* 27 */ {"geop anom", "geopotential height anomaly [gpm]"},
+    /* 28 */ {"wave sp 1", "wave spaectra(1) [non-dim]"},
+    /* 29 */ {"wave sp 2", "wave spaectra(2) [non-dim]"},
+    /* 30 */ {"wave sp 3", "wave spaectra(3) [non-dim]"},
+    /* 31 */ {"DD", "wind direction [degree true]"},
+    /* 32 */ {"FF", "wind speed [m/s]"},
+    /* 33 */ {"U", "u-component (zonal) of wind [m/s]"},
+    /* 34 */ {"V", "v-component (merdional) of wind [m/s]"},
+    /* 35 */ {"stream fun", "stream function [(m**2)/s]"},
+    /* 36 */ {"vel potent", "velocity potential [(m**2)/s]"},
+    /* 37 */ {"M.stream f", "Montgomery stream function [(m**2)/(s**2)]"},
+    /* 38 */ {"sigma vert", "sigma co-ordinate vertical velocity [1/s]"},
+    /* 39 */ {"OMEGA", "vertical velocity [Pa/s]"},
+    /* 40 */ {"W", "vertical velocity [m/s]"},
+    /* 41 */ {"abs vortic", "absolute vorticity [1/s]"},
+    /* 42 */ {"abs diverg", "absolute divergence [1/s]"},
+    /* 43 */ {"rel vortic", "relative vorticity [1/s]"},
+    /* 44 */ {"rel diverg", "relative divergence [1/s]"},
+    /* 45 */ {"vert.u-shr", "vertical u-component shear [1/s]"},
+    /* 46 */ {"vert.v-shr", "vertical v-component shear [1/s]"},
+    /* 47 */ {"dir of cur", "direction of current [degree true]"},
+    /* 48 */ {"spd of cur", "speed of current [m/s]"},
+    /* 49 */ {"currcomp U", "u-component of current [m/s]"},
+    /* 50 */ {"currcomp V", "v-component of current [m/s]"},
+    /* 51 */ {"QV", "specific humidity [kg/kg]"},
+    /* 52 */ {"RELHUM", "relative humidity [%]"},
+    /* 53 */ {"hum mixrat", "humidity mixing ratio [kg/kg]"},
+    /* 54 */ {"TQV", "total precipitable water [kg/m**2]"},
+    /* 55 */ {"vapor pres", "vapor pressure [Pa]"},
+    /* 56 */ {"sat.defic.", "saturation deficit [Pa]"},
+    /* 57 */ {"evaporat.", "evaporation [kg/(m**2)]"},
+    /* 58 */ {"TQI", "total cloud ice content [kg/m**2]"},
+    /* 59 */ {"prec. rate", "precipitation rate [kg/((m**2)*s)]"},
+    /* 60 */ {"thunderst.", "thunderstorm probability [%]"},
+    /* 61 */ {"TOT_PREC", "total precipitation [kg/(m**2)]"},
+    /* 62 */ {"ls precip.", "large scale precipitation [kg/(m**2)]"},
+    /* 63 */ {"conv prec.", "convective precipitation [kg/(m**2)]"},
+    /* 64 */ {"snowf.rate", "snowfall rate water equivalent [kg/((m**2)*s)]"},
+    /* 65 */ {"W_SNOW", "water equivalent of accumulated snow depth [kg/(m**2)]"},
+    /* 66 */ {"snow depth", "snow depth [m]"},
+    /* 67 */ {"mix lay de", "mixed layer depth [m]"},
+    /* 68 */ {"tr therm d", "transient thermocline depth [m]"},
+    /* 69 */ {"ma therm d", "main thermocline depth [m]"},
+    /* 70 */ {"m therm da", "main thermocline depth anomaly [m]"},
+    /* 71 */ {"CLCT", "total cloud cover [%]"},
+    /* 72 */ {"CLC_CON", "convective cloud cover [%]"},
+    /* 73 */ {"CLCL", "low cloud cover [%]"},
+    /* 74 */ {"CLCM", "medium cloud cover [%]"},
+    /* 75 */ {"CLCH", "high cloud cover [%]"},
+    /* 76 */ {"TQC", "total cloud water content [kg/m**2]"},
+    /* 77 */ {"bli to 500", "best lifted index (to 500 hPa) [K]"},
+    /* 78 */ {"SNOW_CON", "convective snow [kg/(m**2)]"},
+    /* 79 */ {"SNOW_GSP", "large scale snow [kg/(m**2)]"},
+    /* 80 */ {"water temp", "water temperature [K]"},
+    /* 81 */ {"FR_LAND", "land cover (1=land, 0=sea) [1]"},
+    /* 82 */ {"dev sea-le", "deviation of sea-level from mean [m]"},
+    /* 83 */ {"Z0", "surface roughness [m]"},
+    /* 84 */ {"ALB_RAD", "albedo [%]"},
+    /* 85 */ {"T_soil", "soil temperature [K]"},
+    /* 86 */ {"W_soil", "soil moisture content [kg/(m**2)]"},
+    /* 87 */ {"PLCOV", "vegetation (plant cover) [%]"},
+    /* 88 */ {"salinity", "salinity [kg/kg]"},
+    /* 89 */ {"density", "density [kg/(m**3)]"},
+    /* 90 */ {"RUNOFF", "water run-off [kg/(m**2)]"},
+    /* 91 */ {"FR_ICE", "ice cover (1=ice, 0=no ice) [1]"},
+    /* 92 */ {"H_ICE", "ice thickness [m]"},
+    /* 93 */ {"dir ice dr", "direction of ice drift [degree true]"},
+    /* 94 */ {"sp ice dr", "speed of ice drift [m/s]"},
+    /* 95 */ {"ice dr u", "u-component of ice drift [m/s]"},
+    /* 96 */ {"ice dr v", "v-component of ice drift [m/s]"},
+    /* 97 */ {"ice growth", "ice growth rate [m/s]"},
+    /* 98 */ {"ice diverg", "ice divergence [1/s]"},
+    /* 99 */ {"snow melt", "snow melt [kg/(m**2)]"},
+    /* 100 */ {"winwav/swe", "significant height of comb. wind waves and swell [m]"},
+    /* 101 */ {"dir of wav", "direction of wind waves [degree true]"},
+    /* 102 */ {"hei of wav", "significant height of wind waves [m]"},
+    /* 103 */ {"MP of wiwa", "mean period of wind waves [s]"},
+    /* 104 */ {"dir of swe", "direction of swell [degree true]"},
+    /* 105 */ {"hei of swe", "significant height of swell [m]"},
+    /* 106 */ {"MP of swel", "mean period of swell [s]"},
+    /* 107 */ {"pr wave di", "primary wave direction [degree true]"},
+    /* 108 */ {"pr wave pe", "primary wave period [s]"},
+    /* 109 */ {"se wave di", "secondary wave direction [degree true]"},
+    /* 110 */ {"se wave pe", "secondary wave period [s]"},
+    /* 111 */ {"ASOB_S", "net short-wave radiation (surface) [W/(m**2)]"},
+    /* 112 */ {"ATHB_S", "net long-wave radiation (surface) [W/(m**2)]"},
+    /* 113 */ {"ASOB_T", "net short-wave radiation (top of atmosphere) [W/(m**2)]"},
+    /* 114 */ {"ATHB_T", "net long-wave radiation (top of atmosphere) [W/(m**2)]"},
+    /* 115 */ {"l-w rad.", "long-wave radiation [W/(m**2)]"},
+    /* 116 */ {"s-w rad.", "short-wave radiation [W/(m**2)]"},
+    /* 117 */ {"global rad", "global radiation [W/(m**2)]"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"ALHFL_S", "latent heat flux [W/(m**2)]"},
+    /* 122 */ {"ASHFL_S", "sensible heat flux [W/(m**2)]"},
+    /* 123 */ {"bound l di", "boundary layer dissipation [W/(m**2)]"},
+    /* 124 */ {"AUMFL_S", "momentum flux, u component [N/(m**2)]"},
+    /* 125 */ {"AVMFL_S", "momentum flux, v component [N/(m**2)]"},
+    /* 126 */ {"wind mix e", "wind mixing energy [J]"},
+    /* 127 */ {"image data", "image data []"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"geopot h", "geopotential height (ECMF) [gpm]"},
+    /* 130 */ {"temperatur", "temperature (ECMF) [K]"},
+    /* 131 */ {"wind compU", "u-component of wind (ECMF) [m/s]"},
+    /* 132 */ {"wind compV", "v-component of wind (ECMF) [m/s]"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"soil temp.", "soil temperature (ECMF) [K]"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"var141", "undefined"},
+    /* 142 */ {"ls precip.", "large scale precipitation (ECMF) [kg/(m**2)]"},
+    /* 143 */ {"conv prec.", "convective precipitation (ECMF) [kg/(m**2)]"},
+    /* 144 */ {"snowfall", "snowfall (ECMF) [m of water equivalent]"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"pressure", "pressure reduced to MSL (ECMF) [Pa]"},
+    /* 152 */ {"var152", "undefined"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"var155", "undefined"},
+    /* 156 */ {"geopot h", "geopotential height (ECMF) [gpm]"},
+    /* 157 */ {"rel. humid", "relative humidity (ECMF) [%]"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"cloud cov.", "total cloud cover (ECMF) [%]"},
+    /* 165 */ {"10m-wind U", "u-component of 10m-wind (ECMF) [m/s]"},
+    /* 166 */ {"10m-wind V", "v-component of 10m-wind (ECMF) [m/s]"},
+    /* 167 */ {"2m temper", "2m temperature (ECMF) [K]"},
+    /* 168 */ {"2m due-p.", "2m due-point temperature (ECMF) [K]"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"var170", "undefined"},
+    /* 171 */ {"var171", "undefined"},
+    /* 172 */ {"var172", "undefined"},
+    /* 173 */ {"var173", "undefined"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"var176", "undefined"},
+    /* 177 */ {"var177", "undefined"},
+    /* 178 */ {"var178", "undefined"},
+    /* 179 */ {"var179", "undefined"},
+    /* 180 */ {"var180", "undefined"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"var201", "undefined"},
+    /* 202 */ {"var202", "undefined"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"var205", "undefined"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"total prec", "total precipitation (ECMF) [m]"},
+    /* 229 */ {"seaway 01", "seaway 01 (ECMF) []"},
+    /* 230 */ {"seaway 02", "seaway 02 (ECMF) []"},
+    /* 231 */ {"seaway 03", "seaway 03 (ECMF) []"},
+    /* 232 */ {"seaway 04", "seaway 04 (ECMF) []"},
+    /* 233 */ {"seaway 05", "seaway 05 (ECMF) []"},
+    /* 234 */ {"seaway 06", "seaway 06 (ECMF) []"},
+    /* 235 */ {"seaway 07", "seaway 07 (ECMF) []"},
+    /* 236 */ {"seaway 08", "seaway 08 (ECMF) []"},
+    /* 237 */ {"seaway 09", "seaway 09 (ECMF) []"},
+    /* 238 */ {"seaway 10", "seaway 10 (ECMF) []"},
+    /* 239 */ {"seaway 11", "seaway 11 (ECMF) []"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_201.c b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_201.c
new file mode 100644
index 00000000..e0b46948
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_201.c
@@ -0,0 +1,266 @@
+#include "cnames.h"
+
+/*
+ * GRIB table 201 at DWD
+ *     Helmut P. Frank, 30.08.2001
+ * updated 24.07.2003:  DQC_GSP, DQI_GSP, T_SO, W_SO, W_SO_ICE, T_ICE
+ */
+
+struct ParmTable parm_table_dwd_201[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"dw sw flux", "downward shortwave radiant flux density [W/m**2]"},
+    /* 2 */ {"uw sw flux", "upward shortwave radiant flux density [W/m**2]"},
+    /* 3 */ {"dw lw flux", "downward longwave radiant flux density [W/m**2]"},
+    /* 4 */ {"uw lw flux", "upward longwave radiant flux density [W/m**2]"},
+    /* 5 */ {"APAB_S", "downwd photosynthetic active radiant flux density [W/m**2]"},
+    /* 6 */ {"net s flux", "net shortwave flux [W/m**2]"},
+    /* 7 */ {"net l flux", "net longwave flux [W/m**2]"},
+    /* 8 */ {"net flux", "total net radiative flux density [W/m**2]"},
+    /* 9 */ {"dw sw clfr", "downw shortw radiant flux density, cloudfree part [W/m**2]"},
+    /* 10 */ {"uw sw cldy", "upw shortw radiant flux density, cloudy part [W/m**2]"},
+    /* 11 */ {"dw lw clfr", "downw longw radiant flux density, cloudfree part [W/m**2]"},
+    /* 12 */ {"uw lw cldy", "upw longw radiant flux density, cloudy part [W/m**2]"},
+    /* 13 */ {"SOHR_RAD", "shortwave radiative heating rate [K/s]"},
+    /* 14 */ {"THHR_RAD", "longwave radiative heating rate [K/s]"},
+    /* 15 */ {"rad heat", "total radiative heating rate [K/s]"},
+    /* 16 */ {"soilheat S", "soil heat flux, surface [W/m**2]"},
+    /* 17 */ {"soilheat L", "soil heat flux, bottom of layer [W/m**2]"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"CLC", "cloud cover, grid scale + convective [1]"},
+    /* 30 */ {"clc gr sc", "cloud cover, grid scale  (0...1) [1]"},
+    /* 31 */ {"QC", "specific cloud water content, grid scale [kg/kg]"},
+    /* 32 */ {"clw gs vi", "cloud water content, grid scale, vert integrated [kg/m**2]"},
+    /* 33 */ {"QI", "specific cloud ice   content, grid scale [kg/kg]"},
+    /* 34 */ {"cli gs vi", "cloud ice content, grid scale, vert integrated [kg/m**2]"},
+    /* 35 */ {"src gr sc", "specific rainwater content, grid scale [kg/kg]"},
+    /* 36 */ {"ssc gr sc", "specific snow content, grid scale [kg/kg]"},
+    /* 37 */ {"src gs vi", "specific rainwater content, gs, vert. integrated [kg/m**2]"},
+    /* 38 */ {"ssc gs vi", "specific snow content, gs, vert. integrated [kg/m**2]"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"tot water", "vert. integral of humidity, cloud water (and ice) [kg/(m**2)]"},
+    /* 42 */ {"hum div", "vert. integral of divergence of tot. water content [kg/(m**2)]"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"CH_CM_CL", "cloud covers CH_CM_CL (000...888) [1]"},
+    /* 51 */ {"cl cov. CH", "cloud cover CH (0..8) [1]"},
+    /* 52 */ {"cl cov. CM", "cloud cover CM (0..8) [1]"},
+    /* 53 */ {"cl cov. CL", "cloud cover CL (0..8) [1]"},
+    /* 54 */ {"cloud cov.", "total cloud cover (0..8) [1]"},
+    /* 55 */ {"fog", "fog (0..8) [1]"},
+    /* 56 */ {"fog", "fog [1]"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"clc con ci", "cloud cover, convective cirrus  (0...1) [1]"},
+    /* 61 */ {"clw con", "specific cloud water content, convective clouds [kg/kg]"},
+    /* 62 */ {"clw con vi", "cloud water content, conv clouds, vert integrated [kg/m**2]"},
+    /* 63 */ {"cli con", "specific cloud ice content, convective clouds [kg/kg]"},
+    /* 64 */ {"cli con vi", "cloud ice content, conv clouds, vert integrated [kg/m**2]"},
+    /* 65 */ {"mass fl co", "convective mass flux [kg/(s*m**2)]"},
+    /* 66 */ {"upd vel co", "updraft velocity, convection [m/s]"},
+    /* 67 */ {"entr p co", "entrainment parameter, convection [m**(-1)]"},
+    /* 68 */ {"HBAS_CON", "cloud base, convective clouds (above msl) [m]"},
+    /* 69 */ {"HTOP_CON", "cloud top, convective clouds (above msl) [m]"},
+    /* 70 */ {"con layers", "convective layers (00...77)  (BKE) [1]"},
+    /* 71 */ {"KO-index", "KO-index [1]"},
+    /* 72 */ {"BAS_CON", "convection base index [1]"},
+    /* 73 */ {"TOP_CON", "convection top index [1]"},
+    /* 74 */ {"DT_CON", "convective temperature tendency [K/s]"},
+    /* 75 */ {"DQV_CON", "convective tendency of specific humidity [s**(-1)]"},
+    /* 76 */ {"H ten co", "convective tendency of total heat [J/(kg*s)]"},
+    /* 77 */ {"QDW ten co", "convective tendency of total water [s**(-1)]"},
+    /* 78 */ {"DU_CON", "convective momentum tendency (X-component) [m/s**2]"},
+    /* 79 */ {"DV_CON", "convective momentum tendency (Y-component) [m/s**2]"},
+    /* 80 */ {"vor ten co", "convective vorticity tendency [s**(-2)]"},
+    /* 81 */ {"div ten co", "convective divergence tendency [s**(-2)]"},
+    /* 82 */ {"HTOP_DC", "top of dry convection (above msl) [m]"},
+    /* 83 */ {"top ind dc", "dry convection top index [1]"},
+    /* 84 */ {"HZEROCL", "height of 0 degree Celsius isotherm above msl [m]"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"QRS_GSP", "spec. content of precip. particles [kg/kg]"},
+    /* 100 */ {"PRR_GSP", "surface precipitation rate, rain, grid scale [kg/(s*m**2)]"},
+    /* 101 */ {"PRS_GSP", "surface precipitation rate, snow, grid scale [kg/(s*m**2)]"},
+    /* 102 */ {"RAIN_GSP", "surface precipitation amount, rain, grid scale [kg/m**2]"},
+    /* 103 */ {"condens gs", "condensation rate, grid scale [kg/(kg*s)]"},
+    /* 104 */ {"autocon gs", "autoconversion rate, grid scale   (C+C  --> R) [kg/(kg*s)]"},
+    /* 105 */ {"accret gs", "accretion rate, grid scale        (R+C  --> R) [kg/(kg*s)]"},
+    /* 106 */ {"nucleat gs", "nucleation rate, grid scale       (C+C  --> S) [kg/(kg*s)]"},
+    /* 107 */ {"riming gs", "riming rate, grid scale           (S+C  --> S) [kg/(kg*s)]"},
+    /* 108 */ {"deposit gs", "deposition rate, grid scale       (S+V <--> S) [kg/(kg*s)]"},
+    /* 109 */ {"melting gs", "melting rate, grid scale          (S    --> R) [kg/(kg*s)]"},
+    /* 110 */ {"evapor gs", "evaporation rate, grid scale      (R+V <--  R) [kg/(kg*s)]"},
+    /* 111 */ {"PRR_CON", "surface precipitation rate, rain, convective [kg/(s*m**2)]"},
+    /* 112 */ {"PRS_CON", "surface precipitation rate, snow, convective [kg/(s*m**2)]"},
+    /* 113 */ {"RAIN_CON", "surface precipitation amount, rain, convective [kg/m**2]"},
+    /* 114 */ {"condens co", "condensation rate, convective [kg/(kg*s)]"},
+    /* 115 */ {"autocon co", "autoconversion rate, convective [kg/(kg*s)]"},
+    /* 116 */ {"accret co", "accretion rate, convective [kg/(kg*s)]"},
+    /* 117 */ {"nucleat co", "nucleation rate, convective [kg/(kg*s)]"},
+    /* 118 */ {"riming co", "riming rate, convective [kg/(kg*s)]"},
+    /* 119 */ {"sublim co", "sublimation rate, convective [kg/(kg*s)]"},
+    /* 120 */ {"melting co", "melting rate, convective [kg/(kg*s)]"},
+    /* 121 */ {"evapor co", "evaporation rate, convective [kg/(kg*s)]"},
+    /* 122 */ {"rain am", "rain amount, grid-scale plus convective [kg/m**2]"},
+    /* 123 */ {"snow am", "snow amount, grid-scale plus convective [kg/m**2]"},
+    /* 124 */ {"DT_GSP", "temperature tendency, grid-scale condensation [K/s]"},
+    /* 125 */ {"DQV_GSP", "tendency of specific humidity, grid-scale precip. [s**(-1)]"},
+    /* 126 */ {"H ten gs", "tendency of total heat, grid-scale condensation [J/(kg*s)]"},
+    /* 127 */ {"DQC_GSP", "tendency of spec. clod liquid water due to grid-scale precip. [s**(-1)]"},
+    /* 128 */ {"snowfall", "snowfall  (dimension"},
+    /* 129 */ {"DQI_GSP", "tendency of spec. cloud ice due to grid-scale precip. [s**(-1)]"},
+    /* 130 */ {"var130", "undefined"},
+    /* 131 */ {"var131", "undefined"},
+    /* 132 */ {"var132", "undefined"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"pprime", "deviation of pressure from reference value [Pa]"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"var141", "undefined"},
+    /* 142 */ {"var142", "undefined"},
+    /* 143 */ {"var143", "undefined"},
+    /* 144 */ {"var144", "undefined"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"hdi coeff", "coefficient of horizontal diffusion [m**2/s]"},
+    /* 151 */ {"dissp rate", "dissipation rate [W/(Pa*m**2)]"},
+    /* 152 */ {"TKE", "turbulent kinetic energy [(m/s)**2]"},
+    /* 153 */ {"TKVM", "coefficient of vertical diffusion, momentum [m**2/s]"},
+    /* 154 */ {"TKVH", "coefficient of vertical diffusion, heat [m**2/s]"},
+    /* 155 */ {"vdi coe cw", "coefficient of vertical diffusion, cloud water [m**2/s]"},
+    /* 156 */ {"vdi coe ci", "coefficient of vertical diffusion, cloud ice [m**2/s]"},
+    /* 157 */ {"vdi coe vp", "coefficient of vertical diffusion, water vapour [m**2/s]"},
+    /* 158 */ {"dis len m", "turbulent dissipation length for momentum [m]"},
+    /* 159 */ {"dis len h", "turbulent dissipation length for heat [m]"},
+    /* 160 */ {"var u mom", "variance of u-component of momentum [(m/s)**2]"},
+    /* 161 */ {"var v mom", "variance of v-component of momentum [(m/s)**2]"},
+    /* 162 */ {"var w mom", "variance of w-component of momentum [(m/s)**2]"},
+    /* 163 */ {"var temp", "variance of temperature [K**2]"},
+    /* 164 */ {"var cl wat", "variance of specific cloud water content [(kg/kg)**2]"},
+    /* 165 */ {"var cl ice", "variance of specific cloud ice content [(kg/kg)**2]"},
+    /* 166 */ {"var vap mr", "variance of water vapour mixing ratio [(kg/kg)**2]"},
+    /* 167 */ {"c wat flux", "turbulent vertical flux of spec cloud water [m/s]"},
+    /* 168 */ {"c ice flux", "turbulent vertical flux of spec cloud ice [m/s]"},
+    /* 169 */ {"w vap flux", "turbulent vertical flux of water vapour mix ratio [m/s]"},
+    /* 170 */ {"TCM", "drag coefficient CD [1]"},
+    /* 171 */ {"TCH", "transfer coefficient CH (sensible heat) [1]"},
+    /* 172 */ {"tr coef CQ", "transfer coefficient CQ (latent heat) [1]"},
+    /* 173 */ {"PBL-top h", "PBL-top h [m]"},
+    /* 174 */ {"T-jump  h", "temperature jump at PBL-top [K]"},
+    /* 175 */ {"q-jump  h", "specific humidity jump at PBL-top [kg/kg]"},
+    /* 176 */ {"entr at h", "entrainment at PBL-top [kg/(s*m**2)]"},
+    /* 177 */ {"mass fl h", "upward mass flux at PBL-top [kg/(s*m**2)]"},
+    /* 178 */ {"cl cov PBL", "cloud cover of PBL-clouds (0...1) [1]"},
+    /* 179 */ {"cl wat PBL", "specific cloud water content of PBL-clouds [kg/kg]"},
+    /* 180 */ {"cl top PBL", "cloud top of PBL-clouds [m]"},
+    /* 181 */ {"cl bas PBL", "cloud base of PBL-clouds [m]"},
+    /* 182 */ {"moun wav X", "vertical mountain wave momentum flux (X component) [kg/(m*s**2)]"},
+    /* 183 */ {"moun wav Y", "vertical mountain wave momentum flux (Y component) [kg/(m*s**2)]"},
+    /* 184 */ {"wave Ri", "wave Richardson number [1]"},
+    /* 185 */ {"wav div X", "mountain wave momentum flux divergence (X comp) [m/s**2]"},
+    /* 186 */ {"wav div Y", "mountain wave momentum flux divergence (Y comp) [m/s**2]"},
+    /* 187 */ {"VMAX_10M", "maximum wind velocity [m/s]"},
+    /* 188 */ {"wav dis vi", "mountain wave dissipation, vert integrated [W/m**2]"},
+    /* 189 */ {"wv en flux", "vertical wave energy flux [kg*m/s**4]"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"T_SO", "soil temperature [K]"},
+    /* 198 */ {"W_SO", "soil water content [kg/m**2]"},
+    /* 199 */ {"W_SO_ICE", "soil ice water content [kg/m**2]"},
+    /* 200 */ {"W_I", "water content of interception store [kg/(m**2)]"},
+    /* 201 */ {"interc ice", "icebit for interception store [1]"},
+    /* 202 */ {"snow fract", "snow fraction [1]"},
+    /* 203 */ {"T_SNOW", "snow temperature [K]"},
+    /* 204 */ {"foliag tem", "foliage temperature [K]"},
+    /* 205 */ {"infiltrat", "infiltration [m/s]"},
+    /* 206 */ {"runoff", "runoff [m/s]"},
+    /* 207 */ {"soil evap", "bare soil evaporation [m/s]"},
+    /* 208 */ {"plant tran", "plant transpiration [m/s]"},
+    /* 209 */ {"inter evap", "interception store evaporation [m/s]"},
+    /* 210 */ {"water evap", "evaporation from water surfaces [m/s]"},
+    /* 211 */ {"aero resis", "aerodynamic resistance [s/m]"},
+    /* 212 */ {"plant res", "plant resistance [s/m]"},
+    /* 213 */ {"soil res", "soil resistance [s/m]"},
+    /* 214 */ {"total evap", "total evaporation (water, soil, plants) [m/s]"},
+    /* 215 */ {"T_ICE", "ice surface temperature [K]"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"var228", "undefined"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"XYZ", "S1 [1]"},
+    /* 231 */ {"S2", "S2 [1]"},
+    /* 232 */ {"S3", "S3 [1]"},
+    /* 233 */ {"S4", "S4 [1]"},
+    /* 234 */ {"S5", "S5 [1]"},
+    /* 235 */ {"S6", "S6 [1]"},
+    /* 236 */ {"S7", "S7 [1]"},
+    /* 237 */ {"S8", "S8 [1]"},
+    /* 238 */ {"S9", "S9 [1]"},
+    /* 239 */ {"S10", "S10 [1]"},
+    /* 240 */ {"S11", "S11 [1]"},
+    /* 241 */ {"OBS TS oc", "OBS Gewitter (occasional) [1]"},
+    /* 242 */ {"OBS TS fq", "OBS Gewitter (frequent) [1]"},
+    /* 243 */ {"MOS pTS oc", "MOS Gewitter-Wahrscheinlichkeit (occasional) [1]"},
+    /* 244 */ {"MOS pTS fq", "MOS Gewitter-Wahrscheinlichkeit (frequent) [1]"},
+    /* 245 */ {"MOS TS cov", "MOS Gewitteranteil (occasional - frequent (1 - 2)) [1]"},
+    /* 246 */ {"S17", "S17 [1]"},
+    /* 247 */ {"S18", "S18 [1]"},
+    /* 248 */ {"S19", "S19 [1]"},
+    /* 249 */ {"S20", "S20 [1]"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_202.c b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_202.c
new file mode 100644
index 00000000..62bdf9b9
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_202.c
@@ -0,0 +1,267 @@
+#include "cnames.h"
+
+/*
+ * GRIB table 202 at DWD
+ *     Helmut P. Frank, 30.08.2001
+ * updated 24.07.2003: UV_Ind_F_h, BasicUV_IF, UV_Ind_W_h, UV_IndmaxF,
+ *                     "gesamt O3", UV_IndmaxW, "h UV_IndMx"
+ */
+
+struct ParmTable parm_table_dwd_202[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"Seeg_peak", "jonswap parameter fm [s**(-1)]"},
+    /* 2 */ {"Seeg_alpha", "jonswap parameter alpha [1]"},
+    /* 3 */ {"Seeg_gamma", "jonswap parameter gamma [1]"},
+    /* 4 */ {"Seeg_dir", "Seegang direction [degree true]"},
+    /* 5 */ {"Seeg_energ", "Seegang energy densitiy [(m**2)*(s**2)]"},
+    /* 6 */ {"Seeg_icemk", "Seegang ice mask [1]"},
+    /* 7 */ {"peak p sw", "peak period of swell [s]"},
+    /* 8 */ {"peak p ww", "peak period of wind waves [s]"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"Var. Geop.", "Varianz Geopotential [(m/s)**4]"},
+    /* 21 */ {"Var. T", "Varianz Temperatur [K**2]"},
+    /* 22 */ {"Var. u", "Varianz Zonalwind [(m/s)**2]"},
+    /* 23 */ {"Var. v", "Varianz Meridionalwind [(m/s)**2]"},
+    /* 24 */ {"Var. q", "Varianz spezifische Feuchte [(kg/kg)**2]"},
+    /* 25 */ {"Mer. Imptr", "Meridionaler Impulstransport [(m/s)**2]"},
+    /* 26 */ {"Mer. TrEpt", "Meridionaler Transport potentieller Energie [(m/s)**3]"},
+    /* 27 */ {"Mer. TrsW", "Meridionaler Transport sensibler Waerme [K*(m/s)]"},
+    /* 28 */ {"Mer. TrlW", "Meridionaler Transport latenter Waerme [(kg/kg)*(m/s)]"},
+    /* 29 */ {"Ver. TrEpt", "Vertikaler Transport potentieller Energie [(m/s)**2*(Pa/s)]"},
+    /* 30 */ {"Ver. TrsW", "Vertikaler Transport sensibler Waerme [K*(Pa/s)]"},
+    /* 31 */ {"Ver.TrlW", "Vertikaler Transport latenter Waerme [(kg/kg)*(Pa/s)]"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"VarAF Geop", "Varianz des Analyse-Fehlers Geopotential [(m/s)**4]"},
+    /* 41 */ {"VarAF u", "Varianz des Analyse-Fehlers Zonalwind [(m/s)**2]"},
+    /* 42 */ {"VarAF v", "Varianz des Analyse-Fehlers Meridionalwind [(m/s)**2]"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"DU_SSO", "undefined"},
+    /* 45 */ {"DV_SSO", "undefined"},
+    /* 46 */ {"SSO_STDH", "standard deviation of subgrid scale orogr. height [m]"},
+    /* 47 */ {"SSO_GAMMA", "anisotropy of topography [1]"},
+    /* 48 */ {"SSO_THETA", "angle betw. principal axis of orogr. and global E [1]"},
+    /* 49 */ {"SSO_SIGMA", "mean slope of subgrid scale orography [1]"},
+    /* 50 */ {"oro varian", "subgrid-scale variance of orography [m**2]"},
+    /* 51 */ {"E-W oro va", "E-W component of subgrid-scale variance of orogr [m**2]"},
+    /* 52 */ {"N-S oro va", "N-S component of subgrid-scale variance of orogr [m**2]"},
+    /* 53 */ {"NW-SE o va", "NW-SE component of subgrid-scale variance of orogr [m**2]"},
+    /* 54 */ {"NE-SW o va", "NE-SW component of subgrid-scale variance of orogr [m**2]"},
+    /* 55 */ {"inl w frac", "fraction of inland water [1]"},
+    /* 56 */ {"surf emiss", "surface emissivity [1]"},
+    /* 57 */ {"SOILTYP", "soil texture [1]"},
+    /* 58 */ {"soil color", "soil color [1]"},
+    /* 59 */ {"soil drain", "soil drainage [1]"},
+    /* 60 */ {"ground wat", "ground water table [m]"},
+    /* 61 */ {"LAI", "leaf area index [1]"},
+    /* 62 */ {"ROOT", "root depth [m]"},
+    /* 63 */ {"root dens", "root density [1]"},
+    /* 64 */ {"HMO3", "height of maximum of ozone concentration [Pa]"},
+    /* 65 */ {"VIO3", "total vertically integrated ozone content [Pa]"},
+    /* 66 */ {"ld-sea msk", "land-sea mask [1]"},
+    /* 67 */ {"PLCOV_MX", "ground fraction covered by plants (vegetation p.) [1]"},
+    /* 68 */ {"PLCOV_MN", "ground fraction covered by plants (time of rest) [1]"},
+    /* 69 */ {"LAI_MX", "leaf area index (vegetation period) [1]"},
+    /* 70 */ {"LAI_MN", "leaf area index (time of rest) [1]"},
+    /* 71 */ {"Orographie", "Orographie + Land-Meer-Verteilung [m]"},
+    /* 72 */ {"r length m", "roughness length momentum [m]"},
+    /* 73 */ {"r length h", "roughness length heat [m]"},
+    /* 74 */ {"var smc", "variance of soil moisture content [kg**2/m**4]"},
+    /* 75 */ {"FOR_E", "fractional coverage with evergreen forest [1]"},
+    /* 76 */ {"FOR_D", "fractional coverage with deciduous forest [1]"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"AER_DES", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"tidal tend", "tidal tendencies [(m/s)**2]"},
+    /* 102 */ {"diab heatg", "sum of diabatic heating terms [K/s]"},
+    /* 103 */ {"adiab heat", "total adiabatic heating [K/s]"},
+    /* 104 */ {"adv q tend", "advective tendency of specific humidity [s**(-1)]"},
+    /* 105 */ {"nadv q ten", "non-advective tendency of specific humidity [s**(-1)]"},
+    /* 106 */ {"adv m te X", "advective momentum tendency (X component) [m/s**2]"},
+    /* 107 */ {"adv m te Y", "advective momentum tendency (Y component) [m/s**2]"},
+    /* 108 */ {"nad m te X", "non-advective momentum tendency (X component) [m/s**2]"},
+    /* 109 */ {"nad m te Y", "non-advective momentum tendency (Y component) [m/s**2]"},
+    /* 110 */ {"torque", "sum of mountain and frictional torque [kg*(m/s)**2]"},
+    /* 111 */ {"budget val", "budget values [1]"},
+    /* 112 */ {"scale fact", "scale factor [1]"},
+    /* 113 */ {"Coriol par", "Coriolis parameter [s**(-1)]"},
+    /* 114 */ {"PHI", "latitude [degr N]"},
+    /* 115 */ {"RLA", "longitude [degr E]"},
+    /* 116 */ {"relax fact", "relaxation factor (lateral boundary, LAM) [1]"},
+    /* 117 */ {"climsstint", "climatic sea surface temp interpolated in time [degr C]"},
+    /* 118 */ {"pot vortic", "potential vorticity [K*m**2/(s*kg)]"},
+    /* 119 */ {"ln ps", "log surface pressure [1]"},
+    /* 120 */ {"EXP_SI", "undefined"},
+    /* 121 */ {"RHS_SI", "undefined"},
+    /* 122 */ {"DTTDIV", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"var129", "undefined"},
+    /* 130 */ {"var130", "undefined"},
+    /* 131 */ {"var131", "undefined"},
+    /* 132 */ {"var132", "undefined"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"var141", "undefined"},
+    /* 142 */ {"var142", "undefined"},
+    /* 143 */ {"var143", "undefined"},
+    /* 144 */ {"var144", "undefined"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"SO2-conc", "SO2-concentration [10**(-6)*g/m**3]"},
+    /* 151 */ {"SO2-dryd", "SO2-dry deposition [10**(-3)*g/m**2]"},
+    /* 152 */ {"SO2-wetd", "SO2-wet deposition [10**(-3)*g/m**2]"},
+    /* 153 */ {"SO4-conc", "SO4-concentration [10**(-6)*g/m**3]"},
+    /* 154 */ {"SO4-dryd", "SO4-dry deposition [10**(-3)*g/m**2]"},
+    /* 155 */ {"SO4-wetd", "SO4-wet deposition [10**(-3)*g/m**2]"},
+    /* 156 */ {"NO-conc", "NO-concentration [10**(-6)*g/m**3]"},
+    /* 157 */ {"NO-dryd", "NO-dry deposition [10**(-3)*g/m**2]"},
+    /* 158 */ {"NO-wetd", "NO-wet deposition [10**(-3)*g/m**2]"},
+    /* 159 */ {"NO2-conc", "NO2-concentration [10**(-6)*g/m**3]"},
+    /* 160 */ {"NO2-dryd", "NO2-dry deposition [10**(-3)*g/m**2]"},
+    /* 161 */ {"NO2-wetd", "NO2-wet deposition [10**(-3)*g/m**2]"},
+    /* 162 */ {"NO3-conc", "NO3-concentration [10**(-6)*g/m**3]"},
+    /* 163 */ {"NO3-dryd", "NO3-dry deposition [10**(-3)*g/m**2]"},
+    /* 164 */ {"NO3-wetd", "NO3-wet deposition [10**(-3)*g/m**2]"},
+    /* 165 */ {"HNO3-conc", "HNO3-concentration [10**(-6)*g/m**3]"},
+    /* 166 */ {"HNO3-dryd", "HNO3-dry deposition [10**(-3)*g/m**2]"},
+    /* 167 */ {"HNO3-wetd", "HNO3-wet deposition [10**(-3)*g/m**2]"},
+    /* 168 */ {"NH3-conc", "NH3-concentration [10**(-6)*g/m**3]"},
+    /* 169 */ {"NH3-dryd", "NH3-dry deposition [10**(-3)*g/m**2]"},
+    /* 170 */ {"NH3-wetd", "NH3-wet deposition [10**(-3)*g/m**2]"},
+    /* 171 */ {"NH4-conc", "NH4-concentration [10**(-6)*g/m**3]"},
+    /* 172 */ {"NH4-dryd", "NH4-dry deposition [10**(-3)*g/m**2]"},
+    /* 173 */ {"NH4-wetd", "NH4-wet deposition [10**(-3)*g/m**2]"},
+    /* 174 */ {"O3-conc", "O3-concentration [10**(-6)*g/m**3]"},
+    /* 175 */ {"PAN-conc", "PAN-concentration [10**(-6)*g/m**3]"},
+    /* 176 */ {"PAN-dryd", "PAN-dry deposition [10**(-3)*g/m**2]"},
+    /* 177 */ {"OH-conc", "OH-concentration [10**(-6)*g/m**3]"},
+    /* 178 */ {"O3-dryd", "O3-dry deposition [10**(-3)*g/m**2]"},
+    /* 179 */ {"O3-wetd", "O3-wet deposition [10**(-3)*g/m**2]"},
+    /* 180 */ {"O3", "O3-mixing ratio [kg/kg]"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"I131-conc", "I131-concentration [Bq/m**3]"},
+    /* 201 */ {"I131-dryd", "I131-dry deposition [Bq/m**2]"},
+    /* 202 */ {"I131-wetd", "I131-wet deposition [Bq/m**2]"},
+    /* 203 */ {"Cs137-conc", "Cs137-concentration [Bq/m**3]"},
+    /* 204 */ {"Cs137-dryd", "Cs1370dry deposition [Bq/m**2]"},
+    /* 205 */ {"Cs137-wetd", "Cs137-wet deposition [Bq/m**2]"},
+    /* 206 */ {"Te132-conc", "Te132-concentration [Bq/m**3]"},
+    /* 207 */ {"Te132-dryd", "Te132-dry deposition [Bq/m**2]"},
+    /* 208 */ {"Te132-wetd", "Te132-wet deposition [Bq/m**2]"},
+    /* 209 */ {"Zr95-conc", "Zr95-concentration [Bq/m**3]"},
+    /* 210 */ {"Zr95-dryd", "Zr95-dry deposition [Bq/m**2]"},
+    /* 211 */ {"Zr95-wetd", "Zr95-wet deposition [Bq/m**2]"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"var228", "undefined"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"var230", "undefined"},
+    /* 231 */ {"var231", "undefined"},
+    /* 232 */ {"var232", "undefined"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"UV_Ind_F_h", "UV_Index corr. for albedo+altitude,cloudless(F), h [1]"},
+    /* 241 */ {"BasicUV_IF", "Basic UV_Index m.s.l.,fixed albedo,cloudless(F), h [1]"},
+    /* 242 */ {"UV_Ind_W_h", "UV_Index corrected for albedo+altitude+clouds(W),h [1]"},
+    /* 243 */ {"UV_IndmaxF", "UV_Index cloudless (F), daily maximum [1]"},
+    /* 244 */ {"SB-Index", "Sonnenbrand-Index [(W*10**(-3))/m**2]"},
+    /* 245 */ {"SB-Index W", "Sonnenbrand-Index bei mittl. Bewoelkung (08z-12z) [(W*10**(-3))/m**2]"},
+    /* 246 */ {"Kan.UVB-WI", "Kanadischer UVB-Warnindex (bew|lkungsreduziert) [(W*10**(-3))/m**2]"},
+    /* 247 */ {"gesamt O3", "total column ozone (Gesamtozon) [Dobson Unit, DU]"},
+    /* 248 */ {"UV_IndmaxW", "UV_Index clouded (W), daily maximum [1]"},
+    /* 249 */ {"h UV_IndMx", "time of UV_Index maximum [h UTC]"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_203.c b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_203.c
new file mode 100644
index 00000000..2155a185
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/dwdtable_203.c
@@ -0,0 +1,265 @@
+#include "cnames.h"
+
+/*
+ * GRIB table 203 at DWD
+ *     Helmut P. Frank, 30.08.2001
+ */
+
+struct ParmTable parm_table_dwd_203[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"pressure", "pressure [hPa]"},
+    /* 2 */ {"geopot h", "geopotential height [10 * gpm]"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"temperatur", "temperature [1*degree Celsius]"},
+    /* 5 */ {"dew-pnt te", "dew-point temperature [1*degree Celsius]"},
+    /* 6 */ {"windcompXY", "wind components X/Y (X*100000 + ((Y*10)+5000)) [m/s]"},
+    /* 7 */ {"geomet h", "geometrical height [kft]"},
+    /* 8 */ {"geomet h", "geometrical height [hft]"},
+    /* 9 */ {"wind di/sp", "wind direction and speed (dd*1000 + ff) [1*degree, 1*kt]"},
+    /* 10 */ {"3 h pr cha", "3 hour pressure change [Pa/(3*h)]"},
+    /* 11 */ {"Schnee-Mge", "Schneemenge [mm]"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"Bod-Wass-G", "Bodenwassergehalt [mm]"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"stab. ind.", "stability index [K]"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"max wind", "maximum wind velocity [kt]"},
+    /* 20 */ {"wind di/sp", "wind direction and speed (dd*1000 + ff) [5*degrees, 1*(m/s)]"},
+    /* 21 */ {"wind di/sp", "wind direction and speed (dd*1000 + ff) [5*degrees, 1*kt]"},
+    /* 22 */ {"wave di/he", "direction and height of wind waves (dd*1000 + h) [1*degree, 1*cm]"},
+    /* 23 */ {"swe. di/he", "direction and height of swell (dd*1000 + h) [1*degree, 1*cm]"},
+    /* 24 */ {"wave m d/h", "mean direction and height of waves (dd*1000 + h) [1*degree, 1*cm]"},
+    /* 25 */ {"wind speed", "wind speed [kt]"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"wind compX", "wind component X-direction [kt]"},
+    /* 28 */ {"wind compY", "wind component Y-direction [kt]"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"abs voradv", "absolute vorticity advection [1/(s**2)]"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"vert. vel.", "vertical velocity [hPa/h]"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"max. temp.", "maximum temperature [1*degree Celsius]"},
+    /* 56 */ {"min. temp.", "minimum temperature [1*degree Celsius]"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"clo", "value of isolation of clothes [1]"},
+    /* 59 */ {"pmva", "predected mean vote (angepasst) [1]"},
+    /* 60 */ {"feeled t", "feeled temperature [1*degree Celsius]"},
+    /* 61 */ {"sea temper", "sea temperature [1*degree Celsius]"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"Globalstr.", "Summe der Globalstrahlung ueber einen Zeitraum [kWh/m**2]"},
+    /* 87 */ {"Nied-GW-GE", "Niederschlagsart+Gewitter+Glatteis (T23-i) (0..99) [1]"},
+    /* 88 */ {"NiedGW-Art", "Niederschlagsart+Gewitter (T23-intern)     (0..99) [1]"},
+    /* 89 */ {"NiedGE-Art", "Niederschlagsart+Glatteis (T23-intern)     (0..99) [1]"},
+    /* 90 */ {"NiedBewArt", "Kombination Niederschl.-Bew.-Blautherm. (283..407) [1]"},
+    /* 91 */ {"Konv.U-Gr.", "Hoehe der Konvektionsuntergrenze ueber Grund [m]"},
+    /* 92 */ {"Nied.-Art", "Niederschlagsart -ww- (T23-intern)         (0..99) [1]"},
+    /* 93 */ {"Konv.-Art", "Konvektionsart                              (0..4) [1]"},
+    /* 94 */ {"Konv.UG-nn", "Hoehe der Konvektionsuntergrenze ueber nn [m]"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"Wetter(ww)", "Wetter (verschluesselt nach ww-Tabelle"},
+    /* 100 */ {"geostr Vor", "geostrophische Vorticity [1/s]"},
+    /* 101 */ {"Geo VorAdv", "geostrophische  Vorticityadvektion [1/s**2]"},
+    /* 102 */ {"VerGraVoAd", "vert. Gradient der geostr. Vorticityadvektion [m/(kg*s)]"},
+    /* 103 */ {"Geo TemAdv", "geostrophische Schichtdickenadvektion [m**3/(kg*s)]"},
+    /* 104 */ {"Lap TemAdv", "Kruemmung der geostr. Schichtdickenadvektion [m/(kg*s)]"},
+    /* 105 */ {"Omega Forc", "Forcing rechte Seite Omegagleichung [m/(kg*s)]"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"Schichtd.A", "Schichtdicken-Advektion [m**3/(kg*s)]"},
+    /* 108 */ {"AdGeVoThWi", "Advektion von geostr. Vorticity mit dem therm Wind [m/(kg*s)]"},
+    /* 109 */ {"Wind-Div.", "Winddivergenz [1/s]"},
+    /* 110 */ {"Q", "Q-vector direction and speed (dd*1000 + fff*1E13) [5*deg,1E13*m**2/kg/s]"},
+    /* 111 */ {"Qx", "Q-Vektor X-Komponente [m**2/(kg*s)]"},
+    /* 112 */ {"Qy", "Q-Vektor Y-Komponente [m**2/(kg*s)]"},
+    /* 113 */ {"Div Q", "Divergenz Q [m/(kg*s)]"},
+    /* 114 */ {"FrontoGeQn", "Frontogenesefunktion, Q isother-senkrecht-Kompon. [m**2/(kg*s)]"},
+    /* 115 */ {"Qs (geo)", "Qs (geo),Komp. Q-Vektor parallel zu den Isothermen [m**2/(kg*s)]"},
+    /* 116 */ {"DivQn(geo)", "Divergenz Qn  geostrophisch [m/(kg*s)]"},
+    /* 117 */ {"DivQs(geo)", "Divergenz Qs  geostrophisch [m/(kg*s)]"},
+    /* 118 */ {"Fronto Gen", "Frontogenesefunktion [K**2/(m**2*s)]"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"FrontoGenP", "Frontogenese-Parameter [1]"},
+    /* 125 */ {"Qs-Vektor", "Qs, Komp. Q-Vektor parallel zu den Isothermen [m**2/(kg*s)]"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"Div Qs", "Divergenz Qs [m/(kg*s)]"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"var129", "undefined"},
+    /* 130 */ {"IPV", "Isentrope potentielle Vorticity [K*m**2/(s*kg)]"},
+    /* 131 */ {"Wind KompX", "Wind X-Komponente auf isentropen Flaechen [m/s]"},
+    /* 132 */ {"Wind KompY", "Wind Y-Komponente auf isentropen Flaechen [m/s]"},
+    /* 133 */ {"Druck-Ise.", "Druck einer isentropen Flaeche [hPa]"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"KO-Index", "KO-Index [K]"},
+    /* 141 */ {"TT-Index", "Totals-Totals-Index [K]"},
+    /* 142 */ {"S-Index", "S-Index [K]"},
+    /* 143 */ {"Stein-Ind", "Steinbeck-Index [1]"},
+    /* 144 */ {"Baily-Ind", "Baily-Index [1]"},
+    /* 145 */ {"Microburst", "Microburst-Index [1]"},
+    /* 146 */ {"Cat-Index", "Clear Air Turbulence Index [1/s]"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"Lab-Energ", "Labilit{tsenergie [J/g]"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"Virt T", "Virtuelle Temperatur [K]"},
+    /* 151 */ {"Pseudo T", "Pseudo-Temperatur [K]"},
+    /* 152 */ {"Pseudo Pot", "Pseudopotentielle Temperatur [K]"},
+    /* 153 */ {"Aequi T", "Aequivalent-Temperatur [K]"},
+    /* 154 */ {"Aequi Pot", "Aequivalentpotentielle Temperatur [K]"},
+    /* 155 */ {"var155", "undefined"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"Bas St Wol", "Untergrenze strat. Bew|lkung [hft]"},
+    /* 161 */ {"Bas St Wol", "Untergrenze strat. Bew|lkung [hPa]"},
+    /* 162 */ {"Bas Cu Wol", "Untergrenze cumul. Bew|lkung [hft]"},
+    /* 163 */ {"Bas Cu Wol", "Untergrenze cumul. Bew|lkung [hPa]"},
+    /* 164 */ {"Top St Wol", "Obergrenze strat. Bew|lkung [hft]"},
+    /* 165 */ {"Top St Wol", "Obergrenze strat. Bew|lkung [hPa]"},
+    /* 166 */ {"Top Cu Wol", "Obergrenze cumul. Bew|lkung [hft]"},
+    /* 167 */ {"Top Cu Wol", "Obergrenze cumul. Bew|lkung [hPa]"},
+    /* 168 */ {"var168", "undefined"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"Bas Tur Wo", "Untergrenze Wolkenturbulenz [hft]"},
+    /* 171 */ {"Bas Tur Wo", "Untergrenze Wolkenturbulenz [hPa]"},
+    /* 172 */ {"Top Tur Wo", "Obergrenze Wolkenturbulenz [hft]"},
+    /* 173 */ {"Top Tur Wo", "Obergrenze Wolkenturbulenz [hPa]"},
+    /* 174 */ {"Bas Eis Wo", "Untergrenze Vereisung in Wolken [hft]"},
+    /* 175 */ {"Bas Eis Wo", "Untergrenze Vereisung in Wolken [hPa]"},
+    /* 176 */ {"Top Eis Wo", "Obergrenze Vereisung in Wolken [hft]"},
+    /* 177 */ {"Top Eis Wo", "Obergrenze Vereisung in Wolken [hPa]"},
+    /* 178 */ {"Int Tur Wo", "Intensitaet der Turbulenz in Wolken  (0..4) [1]"},
+    /* 179 */ {"Int Eis Wo", "Intensitaet der Vereisung  (0..4) [1]"},
+    /* 180 */ {"var180", "undefined"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"Sichtweite", "Sichtweite [m]"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"IcingGuess", "Icing Regime 1.Guess(1=gen,2=conv,3=strat,4=freez) [1]"},
+    /* 196 */ {"IcingGrade", "Icing Grade (1=LGT,2=MOD,3=SEV) [1]"},
+    /* 197 */ {"IcingRegim", "Icing Regime(1=general,2=convect,3=strat,4=freez) [1]"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"Gru Wetter", "Wetter - Grundzustand   (ww"},
+    /* 201 */ {"Lok Wetter", "Wetter - 1. lokale Abweichung  (ww"},
+    /* 202 */ {"Lok Wetter", "Wetter - 2. lokale Abweichung  (ww"},
+    /* 203 */ {"CLDEPTH", "cloud depth (grey scale"},
+    /* 204 */ {"CLCT_MOD", "modified total cloud cover  (0..1) [1]"},
+    /* 205 */ {"curr weath", "current weather (symbol number"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"Cu", "Cumulus  (0..1) [1]"},
+    /* 212 */ {"Cb", "Cumulimbus  (0..1) [1]"},
+    /* 213 */ {"Sc", "Stratocumulus  (0..1) [1]"},
+    /* 214 */ {"Ac", "Altocumulus  (0..1) [1]"},
+    /* 215 */ {"Ci", "Cirrus  (0..1) [1]"},
+    /* 216 */ {"St", "Stratus  (0..1) [1]"},
+    /* 217 */ {"As", "Altostratus  (0..1) [1]"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"Bedeckung", "Bedeckung in Stufen [1]"},
+    /* 222 */ {"Konvektion", "Konvektion  ja/nein [1]"},
+    /* 223 */ {"MN >90%", "Gesamtbedeckung > 90%  ja/nein [1]"},
+    /* 224 */ {"RF700 >89%", "relative Feuchte 700 hPa >= 90%  ja/nein [1]"},
+    /* 225 */ {"RR12 zentr", "Niederschlag 12 std. zentriert [mm]"},
+    /* 226 */ {"RR12 <=0.5", "Niederschlag 12 std. zentriert, Werte <= 0.5mm [mm]"},
+    /* 227 */ {"RR12 SA>60", "RR12 zentriert, Schneeanteil > 60%  ja/nein [1]"},
+    /* 228 */ {"RR12 Kv>60", "RR12 zentriert, konvektiver Anteil > 60%  ja/nein [1]"},
+    /* 229 */ {"SRR12ff", "Starkniederschlag in Stufen (12 std. Folgezeitr) [1]"},
+    /* 230 */ {"RRMAX/STD", "Maximaler Starkniederschlag / std [mm/h]"},
+    /* 231 */ {"RRMAX/MIN", "Maximaler Starkniederschlag / min [mm/min]"},
+    /* 232 */ {"SN12ff >15", "Schneefall (12std. Folgezeitraum) > 15 mm  ja/nein [1]"},
+    /* 233 */ {"RRgefr12ff", "gefrierender Regen (12std. Folgezeitraum)  ja/nein [1]"},
+    /* 234 */ {"FFboe", "Boeenstaerke in Stufen [1]"},
+    /* 235 */ {"Gewitter", "Gewitter in Stufen [1]"},
+    /* 236 */ {"Tx2m12h ze", "2m Maximumtemperatur 12h zentriert [Grad Celsius]"},
+    /* 237 */ {"Tn2m12h ze", "2m Minimumtemperatur 12h zentriert [Grad Celsius]"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"SCHWUELIND", "Schwuele-Index [1]"},
+    /* 252 */ {"SMOGSTUFEN", "Smog-Intensitaetsstufen [1]"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"SMOGHOEHE", "Obergrenze Smog  ( Inversionshoehe ) [m]"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ec_ext.c b/wrfv2_fire/external/io_grib1/WGRIB/ec_ext.c
new file mode 100644
index 00000000..4fb98c20
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ec_ext.c
@@ -0,0 +1,78 @@
+#include 
+#include 
+#include 
+#include 
+
+#include "pds4.h"
+#include "grib.h"
+
+/*
+ * EC_ext	v1.0 wesley ebisuzaki
+ *
+ * prints something readable from the EC stream parameter
+ *
+ * prefix and suffix are only printed if EC_ext has text
+ */
+
+void EC_ext(unsigned char *pds, char *prefix, char *suffix) {
+
+    /* int i;
+    printf("\n");
+    for (i=0; i < PDS_LEN(pds); i++) {
+      printf("%x ",pds[i]);
+    }
+    */
+    /*
+     10/03/2000: R.Rudsar : subroutine changed.
+                 Tests for EcType and extra test for EcStream 1035
+    */
+    if (PDS_Center(pds) == ECMWF && PDS_LEN(pds) >= 43) {
+
+        switch(PDS_EcType(pds)) {
+	    case 10:
+		printf("%sControl forecast%s", prefix, suffix);
+		break;
+	    case 11:
+		printf("%sPerturbed forecasts%s", prefix, suffix);
+		break;
+	    case 14:
+		printf("%sCluster means%s", prefix, suffix);
+		break;
+	    case 15:
+		printf("%sCluster std. dev.%s", prefix, suffix);
+		break;
+	    case 16:
+		printf("%sForecast probability%s", prefix, suffix);
+		break;
+	    case 17:
+		printf("%sEnsemble means%s", prefix, suffix);
+		break;
+	    case 18:
+		printf("%sEnsemble std. dev.%s", prefix, suffix);
+		break;
+	    default:
+		printf("%sECMWF type?%s", prefix, suffix);
+		break;
+	}
+    }
+    if (PDS_Center(pds) == ECMWF && PDS_LEN(pds) >= 45) {
+
+        switch(PDS_EcStream(pds)) {
+	    case 1035:
+		printf("%sensemble forecasts%s", prefix, suffix);
+		break;
+	    case 1043:
+		printf("%smon mean%s", prefix, suffix);
+		break;
+	    case 1070:
+		printf("%smon (co)var%s", prefix, suffix);
+		break;
+	    case 1071:
+		printf("%smon mean from daily%s", prefix, suffix);
+		break;
+	    default:
+		printf("%sECMWF stream?%s", prefix, suffix);
+		break;
+	}
+    }
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_128.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_128.c
new file mode 100644
index 00000000..bab950cb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_128.c
@@ -0,0 +1,264 @@
+#include "cnames.h"
+
+/*
+  Helmut Frank, updated 24.07.2003: UVB, PAR, CAPE
+*/
+
+struct ParmTable parm_table_ecmwf_128[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"STRF", "Stream function [m**2 s**-1]"},
+      /* 2 */ {"VPOT", "Velocity potential [m**2 s**-1]"},
+      /* 3 */ {"PT", "Potential temperature [K]"},
+      /* 4 */ {"EQPT", "Equivalent potential temperature [K]"},
+      /* 5 */ {"SEPT", "Saturated equivalent potential temperature [K]"},
+      /* 6 */ {"var6", "Reserved for Metview"},
+      /* 7 */ {"var7", "Reserved for Metview"},
+      /* 8 */ {"var8", "Reserved for Metview"},
+      /* 9 */ {"var9", "Reserved for Metview"},
+      /* 10 */ {"var10", "Reserved for Metview"},
+      /* 11 */ {"UDVW", "U component of divergent wind [m s**-1]"},
+      /* 12 */ {"VDVW", "V component of divergent wind [m s**-1]"},
+      /* 13 */ {"URTW", "U component of rotational wind [m s**-1]"},
+      /* 14 */ {"VRTW", "V component of rotational wind [m s**-1]"},
+      /* 15 */ {"var15", "Reserved for Metview"},
+      /* 16 */ {"var16", "Reserved for Metview"},
+      /* 17 */ {"var17", "Reserved for Metview"},
+      /* 18 */ {"var18", "Reserved for Metview"},
+      /* 19 */ {"var19", "Reserved for Metview"},
+      /* 20 */ {"var20", "Reserved for Metview"},
+      /* 21 */ {"UCTP", "Unbalanced component of temperature [K]"},
+      /* 22 */ {"UCLN", "Unbalanced component of logarithm of surface pressure"},
+      /* 23 */ {"UCDV", "Unbalanced component of divergence [s**-1]"},
+      /* 24 */ {"var24", "Reserved for future unbalanced components"},
+      /* 25 */ {"var25", "Reserved for future unbalanced components"},
+      /* 26 */ {"CL", "Lake cover [(0-1)]"},
+      /* 27 */ {"CVL", "Low vegetation cover [(0-1)]"},
+      /* 28 */ {"CVH", "High vegetation cover [(0-1)]"},
+      /* 29 */ {"TVL", "Type of low vegetation"},
+      /* 30 */ {"TVH", "Type of high vegetation"},
+      /* 31 */ {"CI", "Sea-ice cover [(0-1)]"},
+      /* 32 */ {"ASN", "Snow albedo [(0-1)]"},
+      /* 33 */ {"RSN", "Snow density [kg m**-3]"},
+      /* 34 */ {"SSTK", "Sea surface temperature [K]"},
+      /* 35 */ {"ISTL1", "Ice surface temperature layer 1 [K]"},
+      /* 36 */ {"ISTL2", "Ice surface temperature layer 2 [K]"},
+      /* 37 */ {"ISTL3", "Ice surface temperature layer 3 [K]"},
+      /* 38 */ {"ISTL4", "Ice surface temperature layer 4 [K]"},
+      /* 39 */ {"SWVL1", "Volumetric soil water layer 1 [m**3 m**-3]"},
+      /* 40 */ {"SWVL2", "Volumetric soil water layer 2 [m**3 m**-3]"},
+      /* 41 */ {"SWVL3", "Volumetric soil water layer 3 [m**3 m**-3]"},
+      /* 42 */ {"SWVL4", "Volumetric soil water layer 4 [m**3 m**-3]"},
+      /* 43 */ {"SLT", "Soil type"},
+      /* 44 */ {"ES", "Snow evaporation [m of water]"},
+      /* 45 */ {"SMLT", "Snowmelt [m of water]"},
+      /* 46 */ {"SDUR", "Solar duration [s]"},
+      /* 47 */ {"DSRP", "Direct solar radiation [w m**-2]"},
+      /* 48 */ {"MAGSS", "Magnitude of surface stress [N m**-2 s]"},
+      /* 49 */ {"10FG", "Wind gust at 10 metres [m s**-1]"},
+      /* 50 */ {"LSPF", "Large-scale precipitation fraction [s]"},
+      /* 51 */ {"MX2T24", "Maximum 2 metre temperature [K]"},
+      /* 52 */ {"MN2T24", "Minimum 2 metre temperature [K]"},
+      /* 53 */ {"MONT", "Montgomery potential [m**2 s**-2]"},
+      /* 54 */ {"PRES", "Pressure [Pa]"},
+      /* 55 */ {"var55", "undefined"},
+      /* 56 */ {"var56", "undefined"},
+      /* 57 */ {"UVB", "Downward UV radiation at the surface (Ultra-violet band B) [W m**-2]"},
+      /* 58 */ {"PAR", "Photosynthetically active radiation at the surface [W m**-2]"},
+      /* 59 */ {"CAPE", "Convective available potential energy [J kg**-1]"},
+      /* 60 */ {"PV", "Potential vorticity [K m**2 kg**-1 s**-1]"},
+      /* 61 */ {"var61", "undefined"},
+      /* 62 */ {"var62", "undefined"},
+      /* 63 */ {"var63", "undefined"},
+      /* 64 */ {"var64", "undefined"},
+      /* 65 */ {"var65", "undefined"},
+      /* 66 */ {"var66", "undefined"},
+      /* 67 */ {"var67", "undefined"},
+      /* 68 */ {"var68", "undefined"},
+      /* 69 */ {"var69", "undefined"},
+      /* 70 */ {"var70", "undefined"},
+      /* 71 */ {"var71", "undefined"},
+      /* 72 */ {"var72", "undefined"},
+      /* 73 */ {"var73", "undefined"},
+      /* 74 */ {"var74", "undefined"},
+      /* 75 */ {"var75", "undefined"},
+      /* 76 */ {"var76", "undefined"},
+      /* 77 */ {"var77", "undefined"},
+      /* 78 */ {"var78", "undefined"},
+      /* 79 */ {"var79", "undefined"},
+      /* 80 */ {"var80", "undefined"},
+      /* 81 */ {"var81", "undefined"},
+      /* 82 */ {"var82", "undefined"},
+      /* 83 */ {"var83", "undefined"},
+      /* 84 */ {"var84", "undefined"},
+      /* 85 */ {"var85", "undefined"},
+      /* 86 */ {"var86", "undefined"},
+      /* 87 */ {"var87", "undefined"},
+      /* 88 */ {"var88", "undefined"},
+      /* 89 */ {"var89", "undefined"},
+      /* 90 */ {"var90", "undefined"},
+      /* 91 */ {"var91", "undefined"},
+      /* 92 */ {"var92", "undefined"},
+      /* 93 */ {"var93", "undefined"},
+      /* 94 */ {"var94", "undefined"},
+      /* 95 */ {"var95", "undefined"},
+      /* 96 */ {"var96", "undefined"},
+      /* 97 */ {"var97", "undefined"},
+      /* 98 */ {"var98", "undefined"},
+      /* 99 */ {"var99", "undefined"},
+      /* 100 */ {"100", "Experimental product [Undefined]"},
+      /* 101 */ {"101", "Experimental product [Undefined]"},
+      /* 102 */ {"102", "Experimental product [Undefined]"},
+      /* 103 */ {"103", "Experimental product [Undefined]"},
+      /* 104 */ {"104", "Experimental product [Undefined]"},
+      /* 105 */ {"105", "Experimental product [Undefined]"},
+      /* 106 */ {"106", "Experimental product [Undefined]"},
+      /* 107 */ {"107", "Experimental product [Undefined]"},
+      /* 108 */ {"108", "Experimental product [Undefined]"},
+      /* 109 */ {"109", "Experimental product [Undefined]"},
+      /* 110 */ {"110", "Experimental product [Undefined]"},
+      /* 111 */ {"111", "Experimental product [Undefined]"},
+      /* 112 */ {"112", "Experimental product [Undefined]"},
+      /* 113 */ {"113", "Experimental product [Undefined]"},
+      /* 114 */ {"114", "Experimental product [Undefined]"},
+      /* 115 */ {"115", "Experimental product [Undefined]"},
+      /* 116 */ {"116", "Experimental product [Undefined]"},
+      /* 117 */ {"117", "Experimental product [Undefined]"},
+      /* 118 */ {"118", "Experimental product [Undefined]"},
+      /* 119 */ {"119", "Experimental product [Undefined]"},
+      /* 120 */ {"120", "Experimental product [Undefined]"},
+      /* 121 */ {"var121", "undefined"},
+      /* 122 */ {"var122", "undefined"},
+      /* 123 */ {"var123", "undefined"},
+      /* 124 */ {"var124", "undefined"},
+      /* 125 */ {"var125", "undefined"},
+      /* 126 */ {"var126", "undefined"},
+      /* 127 */ {"AT", "Atmospheric tide"},
+      /* 128 */ {"BV", "Budget values"},
+      /* 129 */ {"Z", "Geopotential [m**2 s**-2]"},
+      /* 130 */ {"T", "Temperature [K]"},
+      /* 131 */ {"U", "U velocity [m s**-1]"},
+      /* 132 */ {"V", "V velocity [m s**-1]"},
+      /* 133 */ {"Q", "Specific humidity [kg kg**-1]"},
+      /* 134 */ {"SP", "Surface pressure [Pa]"},
+      /* 135 */ {"W", "Vertical velocity [Pa s**-1]"},
+      /* 136 */ {"TCW", "Total column water [kg m**-2]"},
+      /* 137 */ {"TCWV", "Total column water vapour [kg m**-2]"},
+      /* 138 */ {"VO", "Vorticity (relative) [s**-1]"},
+      /* 139 */ {"STL1", "Soil temperature level 1 [K]"},
+      /* 140 */ {"SWL1", "Soil wetness level 1 [m of water]"},
+      /* 141 */ {"SD", "Snow depth [m of water equivalent]"},
+      /* 142 */ {"LSP", "Stratiform precipitation [m]"},
+      /* 143 */ {"CP", "Convective precipitation [m]"},
+      /* 144 */ {"SF", "Snowfall (convective + stratiform) [m of water equivalent]"},
+      /* 145 */ {"BLD", "Boundary layer dissipation [W m**-2 s]"},
+      /* 146 */ {"SSHF", "Surface sensible heat flux [W m**-2 s]"},
+      /* 147 */ {"SLHF", "Surface latent heat flux [W m**-2 s]"},
+      /* 148 */ {"CHNK", "Charnock"},
+      /* 149 */ {"SNR", "Surface net radiation [W m**-2 s]"},
+      /* 150 */ {"TNR", "Top net radiation"},
+      /* 151 */ {"MSL", "Mean sea-level pressure [Pa]"},
+      /* 152 */ {"LNSP", "Logarithm of surface pressure"},
+      /* 153 */ {"SWHR", "Short-wave heating rate [K]"},
+      /* 154 */ {"LWHR", "Long-wave heating rate [K]"},
+      /* 155 */ {"D", "Divergence [s**-1]"},
+      /* 156 */ {"GH", "Height [m]"},
+      /* 157 */ {"R", "Relative humidity [%]"},
+      /* 158 */ {"TSP", "Tendency of surface pressure [Pa s**-1]"},
+      /* 159 */ {"BLH", "Boundary layer height [m]"},
+      /* 160 */ {"SDOR", "Standard deviation of orography"},
+      /* 161 */ {"ISOR", "Anisotropy of sub-gridscale orography"},
+      /* 162 */ {"ANOR", "Angle of sub-gridscale orography [rad]"},
+      /* 163 */ {"SLOR", "Slope of sub-gridscale orography"},
+      /* 164 */ {"TCC", "Total cloud cover [(0 - 1)]"},
+      /* 165 */ {"10U", "10 metre U wind component [m s**-1]"},
+      /* 166 */ {"10V", "10 metre V wind component [m s**-1]"},
+      /* 167 */ {"2T", "2 metre temperature [K]"},
+      /* 168 */ {"2D", "2 metre dewpoint temperature [K]"},
+      /* 169 */ {"SSRD", "Surface solar radiation downwards [W m**-2 s]"},
+      /* 170 */ {"STL2", "Soil temperature level 2 [K]"},
+      /* 171 */ {"SWL2", "Soil wetness level 2 [m of water]"},
+      /* 172 */ {"LSM", "Land/sea mask [(0, 1)]"},
+      /* 173 */ {"SR", "Surface roughness [m]"},
+      /* 174 */ {"AL", "Albedo [(0 - 1)]"},
+      /* 175 */ {"STRD", "Surface thermal radiation downwards [W m**-2 s]"},
+      /* 176 */ {"SSR", "Surface solar radiation [W m**-2 s]"},
+      /* 177 */ {"STR", "Surface thermal radiation [W m**-2 s]"},
+      /* 178 */ {"TSR", "Top solar radiation [W m**-2 s]"},
+      /* 179 */ {"TTR", "Top thermal radiation [W m**-2 s]"},
+      /* 180 */ {"EWSS", "East/West surface stress [N m**-2 s]"},
+      /* 181 */ {"NSSS", "North/South surface stress [N m**-2 s]"},
+      /* 182 */ {"E", "Evaporation [m of water]"},
+      /* 183 */ {"STL3", "Soil temperature level 3 [K]"},
+      /* 184 */ {"SWL3", "Soil wetness level 3 [m of water]"},
+      /* 185 */ {"CCC", "Convective cloud cover [(0 - 1)]"},
+      /* 186 */ {"LCC", "Low cloud cover [(0 - 1)]"},
+      /* 187 */ {"MCC", "Medium cloud cover [(0 - 1)]"},
+      /* 188 */ {"HCC", "High cloud cover [(0 - 1)]"},
+      /* 189 */ {"SUND", "Sunshine duration [s]"},
+      /* 190 */ {"EWOV", "EW component of subgrid orographic variance [m**2]"},
+      /* 191 */ {"NSOV", "NS component of subgrid orographic variance [m**2]"},
+      /* 192 */ {"NWOV", "NWSE component of subgrid orographic variance [m**2]"},
+      /* 193 */ {"NEOV", "NESW component of subgrid orographic variance [m**2]"},
+      /* 194 */ {"BTMP", "Brightness temperature [K]"},
+      /* 195 */ {"LGWS", "Lat. component of gravity wave stress [N m**-2 s]"},
+      /* 196 */ {"MGWS", "Meridional component of gravity wave stress [N m**-2 s]"},
+      /* 197 */ {"GWD", "Gravity wave dissipation [W m**-2 s]"},
+      /* 198 */ {"SRC", "Skin reservoir content [m of water]"},
+      /* 199 */ {"VEG", "Vegetation fraction [(0 - 1)]"},
+      /* 200 */ {"VSO", "Variance of sub-gridscale orography [m**2]"},
+      /* 201 */ {"MX2T", "Maximum 2 metre temperature since previous post-processing [K]"},
+      /* 202 */ {"MN2T", "Minimum 2 metre temperature since previous post-processing [K]"},
+      /* 203 */ {"O3", "Ozone mass mixing ratio [kg kg**-1]"},
+      /* 204 */ {"PAW", "Precipiation analysis weights"},
+      /* 205 */ {"RO", "Runoff [m]"},
+      /* 206 */ {"TCO3", "Total column ozone [Dobson]"},
+      /* 207 */ {"10SI", "10 meter windspeed [m s**-1]"},
+      /* 208 */ {"TSRC", "Top net solar radiation, clear sky [W m**-2]"},
+      /* 209 */ {"TTRC", "Top net thermal radiation, clear sky [W m**-2]"},
+      /* 210 */ {"SSRC", "Surface net solar radiation, clear sky [W m**-2]"},
+      /* 211 */ {"STRC", "Surface net thermal radiation, clear sky [W m**-2]"},
+      /* 212 */ {"SI", "Solar insolation [W m**-2]"},
+      /* 213 */ {"var213", "undefined"},
+      /* 214 */ {"DHR", "Diabatic heating by radiation [K]"},
+      /* 215 */ {"DHVD", "Diabatic heating by vertical diffusion [K]"},
+      /* 216 */ {"DHCC", "Diabatic heating by cumulus convection [K]"},
+      /* 217 */ {"DHLC", "Diabatic heating large-scale condensation [K]"},
+      /* 218 */ {"VDZW", "Vertical diffusion of zonal wind [m s**-1]"},
+      /* 219 */ {"VDMW", "Vertical diffusion of meridional wind [m s**-1]"},
+      /* 220 */ {"EWGD", "EW gravity wave drag tendency [m s**-1]"},
+      /* 221 */ {"NSGD", "NS gravity wave drag tendency [m s**-1]"},
+      /* 222 */ {"CTZW", "Convective tendency of zonal wind [m s**-1]"},
+      /* 223 */ {"CTMW", "Convective tendency of meridional wind [m s**-1]"},
+      /* 224 */ {"VDH", "Vertical diffusion of humidity [kg kg**-1]"},
+      /* 225 */ {"HTCC", "Humidity tendency by cumulus convection [kg kg**-1]"},
+      /* 226 */ {"HTLC", "Humidity tendency large-scale condensation [kg kg**-1]"},
+      /* 227 */ {"CRNH", "Change from removing negative humidity [kg kg**-1]"},
+      /* 228 */ {"TP", "Total precipitation [m]"},
+      /* 229 */ {"IEWS", "Instantaneous X surface stress [N m**-2]"},
+      /* 230 */ {"INSS", "Instantaneous Y surface stress [N m**-2]"},
+      /* 231 */ {"ISHF", "Instantaneous surface heat flux [W m**-2]"},
+      /* 232 */ {"IE", "Instantaneous moisture flux [kg m**-2 s]"},
+      /* 233 */ {"ASQ", "Apparent surface humidity [kg kg**-1]"},
+      /* 234 */ {"LSRH", "Logarithm of surface roughness length for heat"},
+      /* 235 */ {"SKT", "Skin temperature [K]"},
+      /* 236 */ {"STL4", "Soil temperature level 4 [K]"},
+      /* 237 */ {"SWL4", "Soil wetness level 4 [m]"},
+      /* 238 */ {"TSN", "Temperature of snow layer [K]"},
+      /* 239 */ {"CSF", "Convective snowfall [m of water equivalent]"},
+      /* 240 */ {"LSF", "Large-scale snowfall [m of water equivalent]"},
+      /* 241 */ {"ACF", "Accumulated cloud fraction tendency [(-1 to 1)]"},
+      /* 242 */ {"ALW", "Accumulated liquid water tendency [(-1 to 1)]"},
+      /* 243 */ {"FAL", "Forecast albedo [(0 - 1)]"},
+      /* 244 */ {"FSR", "Forecast surface roughness [m]"},
+      /* 245 */ {"FLSR", "Forecast log of surface roughness for heat"},
+      /* 246 */ {"CLWC", "Cloud liquid water content [kg kg**-1]"},
+      /* 247 */ {"CIWC", "Cloud ice water content [kg kg**-1]"},
+      /* 248 */ {"CC", "Cloud cover [(0 - 1)]"},
+      /* 249 */ {"AIW", "Accumulated ice water tendency [(-1 to 1)]"},
+      /* 250 */ {"ICE", "Ice age [1,0]"},
+      /* 251 */ {"ATTE", "Adiabatic tendency of temperature [K]"},
+      /* 252 */ {"ATHE", "Adiabatic tendency of humidity [kg kg**-1]"},
+      /* 253 */ {"ATZE", "Adiabatic tendency of zonal wind [m s**-1]"},
+      /* 254 */ {"ATMW", "Adiabatic tendency of meridional wind [m s**-1]"},
+      /* 255 */ {"var255", "Indicates a missing value"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_129.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_129.c
new file mode 100644
index 00000000..30565b66
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_129.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_129[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"AT", "Atmospheric tide+ -"},
+    /* 128 */ {"BV", "Budget values+ -"},
+    /* 129 */ {"Z", "Geopotential (at the surface=orography) m**2 s**-2"},
+    /* 130 */ {"T", "Temperature K"},
+    /* 131 */ {"U", "U-velocity m s**-1"},
+    /* 132 */ {"V", "V-velocity m s**-1"},
+    /* 133 */ {"Q", "Specific humidity kg kg**-1"},
+    /* 134 */ {"SP", "Surface pressure Pa"},
+    /* 135 */ {"W", "Vertical velocity Pa s**-1"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"PWC", "Precipitable water content kg m**-2"},
+    /* 138 */ {"VO", "Vorticity (relative) s**-1"},
+    /* 139 */ {"ST", "Surf.temp/soil temp lev 1 (from 930804) K"},
+    /* 140 */ {"SSW", "Surf soil wet/soil wet lev1(from 930803) m (of water)"},
+    /* 141 */ {"SD", "Snow depth m (of water equivalent)"},
+    /* 142 */ {"LSP", "Large scale precipitation* m"},
+    /* 143 */ {"CP", "Convective precipitation* m"},
+    /* 144 */ {"SF", "Snow fall* m(of water equivalent)"},
+    /* 145 */ {"BLD", "Boundary layer dissipation* W m**-2 s"},
+    /* 146 */ {"SSHF", "Surface sensible heat flux* W m**-2 s"},
+    /* 147 */ {"SLHF", "Surface latent heat flux* W m**-2 s"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"MSL", "Mean sea level pressure Pa"},
+    /* 152 */ {"LNSP", "Log surface pressure -"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"D", "Divergence s**-1"},
+    /* 156 */ {"GH", "Height (geopotential) m"},
+    /* 157 */ {"R", "Relative humidity %"},
+    /* 158 */ {"TSP", "Tendency of surface pressure Pa s**-1"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"SDOR", "Standard deviation of orography -"},
+    /* 161 */ {"ISOR", "Anisotropy of subgrid scale orography -"},
+    /* 162 */ {"ANOR", "Angle of subgrid scale orography -"},
+    /* 163 */ {"SLOR", "Slope of subgrid scale orography -"},
+    /* 164 */ {"TCC", "Total cloud cover (0 - 1)"},
+    /* 165 */ {"10U", "10 metre u wind component m s**-1"},
+    /* 166 */ {"10V", "10 metre v wind component m s**-1"},
+    /* 167 */ {"2T", "2 metre temperature K"},
+    /* 168 */ {"2D", "2 metre dewpoint temperature K"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"DST", "Deep soil tmp/soil temp lev2(frm 930804) K"},
+    /* 171 */ {"DSW", "Deep soil wet/soil wet lev2(from 930803) m (of water)"},
+    /* 172 */ {"LSM", "Land/sea mask (0"},
+    /* 173 */ {"SR", "Surface roughness m"},
+    /* 174 */ {"AL", "Albedo -"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"SSR", "Surface solar radiation* W m**-2 s"},
+    /* 177 */ {"STR", "Surface thermal radiation* W m**-2 s"},
+    /* 178 */ {"TSR", "Top solar radiation* W m**-2 s"},
+    /* 179 */ {"TTR", "Top thermal radiation* W m**-2 s"},
+    /* 180 */ {"EWSS", "East/West surface stress* N m**-2 s"},
+    /* 181 */ {"NSSS", "North/South surface stress* N m**-2 s"},
+    /* 182 */ {"E", "Evaporation* m (of water)"},
+    /* 183 */ {"CDST", "Clim deep soil tmp/soil tmp lev3(930804) K"},
+    /* 184 */ {"CDSW", "Clim deep soil wet/soil wet lev3(930803) m (of water)"},
+    /* 185 */ {"CCC", "Convective cloud cover (0 - 1)"},
+    /* 186 */ {"LCC", "Low cloud cover (0 - 1)"},
+    /* 187 */ {"MCC", "Medium cloud cover (0 - 1)"},
+    /* 188 */ {"HCC", "High cloud cover (0 - 1)"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"EWOV", "EW component subgrid scale orographic variance m**2"},
+    /* 191 */ {"NSOV", "NS component subgrid scale orographic variance m**2"},
+    /* 192 */ {"NWOV", "NWSE component subgrid scale orographic variance m**2"},
+    /* 193 */ {"NEOV", "NESW component subgrid scale orographic variance m**2"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"LGWS", "Latitudinal component of gravity wave stress* N m**-2 s"},
+    /* 196 */ {"MGWS", "Meridional component of gravity wave stress* N m**-2 s"},
+    /* 197 */ {"GWD", "Gravity wave dissipation* W m**-2 s"},
+    /* 198 */ {"SRC", "Skin reservoir content m (of water)"},
+    /* 199 */ {"VEG", "Percentage of vegetation %"},
+    /* 200 */ {"VSO", "Variance of sub-grid scale orography m**2"},
+    /* 201 */ {"MX2T", "Max temp. at 2m since previous post-processing K"},
+    /* 202 */ {"MN2T", "Min temp. at 2m since previous post-processing K"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"PAW", "Precip. analysis weights -"},
+    /* 205 */ {"RO", "Runoff* m"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"TP", "Total precipitation? m"},
+    /* 229 */ {"IEWS", "Instantaneous X surface stress N m**-2"},
+    /* 230 */ {"INSS", "Instantaneous Y surface stress N m**-2"},
+    /* 231 */ {"ISHF", "Instantaneous surface Heat Flux W m**-2"},
+    /* 232 */ {"IE", "Instantaneous Moisture Flux (evaporation) kg m**-2 s"},
+    /* 233 */ {"ASQ", "Apparent Surface Humidity kg kg**-1"},
+    /* 234 */ {"LSRH", "Logarithm of surface roughness length for heat -"},
+    /* 235 */ {"SKT", "Skin Temperature K"},
+    /* 236 */ {"STL4", "Soil temperature level 4 K"},
+    /* 237 */ {"SWL4", "Soil wetness level 4 m"},
+    /* 238 */ {"TSN", "Temperature of snow layer K"},
+    /* 239 */ {"CSF", "Convective snow-fall* m (of water equivalent)"},
+    /* 240 */ {"LSF", "Large scale snow-fall* m (of water equivalent)"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"FAL", "Forecast albedo -"},
+    /* 244 */ {"FSR", "Forecast surface roughness m"},
+    /* 245 */ {"FLSR", "Forecast logarithm of surface roughness for heat -"},
+    /* 246 */ {"CLWC", "Cloud liquid water content kg kg**-1"},
+    /* 247 */ {"CIWC", "Cloud ice water content kg kg**-1"},
+    /* 248 */ {"CC", "Cloud cover (0 - 1)"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"", "Ice Age (0 first-year 1 multi-year)"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_130.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_130.c
new file mode 100644
index 00000000..d101fd62
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_130.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_130[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"var129", "undefined"},
+    /* 130 */ {"var130", "undefined"},
+    /* 131 */ {"var131", "undefined"},
+    /* 132 */ {"var132", "undefined"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"var141", "undefined"},
+    /* 142 */ {"var142", "undefined"},
+    /* 143 */ {"var143", "undefined"},
+    /* 144 */ {"var144", "undefined"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"var151", "undefined"},
+    /* 152 */ {"var152", "undefined"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"var155", "undefined"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"var164", "undefined"},
+    /* 165 */ {"var165", "undefined"},
+    /* 166 */ {"var166", "undefined"},
+    /* 167 */ {"var167", "undefined"},
+    /* 168 */ {"var168", "undefined"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"var170", "undefined"},
+    /* 171 */ {"var171", "undefined"},
+    /* 172 */ {"var172", "undefined"},
+    /* 173 */ {"var173", "undefined"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"var176", "undefined"},
+    /* 177 */ {"var177", "undefined"},
+    /* 178 */ {"var178", "undefined"},
+    /* 179 */ {"var179", "undefined"},
+    /* 180 */ {"var180", "undefined"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"var201", "undefined"},
+    /* 202 */ {"var202", "undefined"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"var205", "undefined"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"TSRU", "Top solar radiation upward W m**-2"},
+    /* 209 */ {"TTRU", "Top thermal radiation upward W m**-2"},
+    /* 210 */ {"TSUC", "Top solar radiation upward clear sky W m**-2"},
+    /* 211 */ {"TTUC", "Top thermal radiation upward clear sky W m**-2"},
+    /* 212 */ {"CLW", "Cloud liquid water kg kg**-1"},
+    /* 213 */ {"CF", "Cloud fraction 0-1"},
+    /* 214 */ {"DHR", "Diabatic heating by radiation K s**-1"},
+    /* 215 */ {"DHVD", "Diabatic heating by vertical diffusion K s**-1"},
+    /* 216 */ {"DHCC", "Diabatic heating by cumulus convection K s**-1"},
+    /* 217 */ {"DHLC", "Diabatic heating by large-scale condensation K s**-1"},
+    /* 218 */ {"VDZW", "Vertical diffusion of zonal wind m**2 s**-3"},
+    /* 219 */ {"VDMW", "Vertical diffusion of meridional wind m**2 s**-3"},
+    /* 220 */ {"EWGD", "EW gravity wave drag m**2 s**-3"},
+    /* 221 */ {"NSGD", "NS gravity wave drag m**2 s**-3"},
+    /* 222 */ {"CTZW", "Convective tendency of zonal wind m**2 s**-3"},
+    /* 223 */ {"CTMW", "Convective tendency of meridional wind m**2 s**-3"},
+    /* 224 */ {"VDH", "Vertical diffusion of humidity kg kg**-1 s**-1"},
+    /* 225 */ {"HTCC", "Humidity tendency by cumulus convection kg kg**-1 s**-1"},
+    /* 226 */ {"HTLC", "Humidity tendency by large-scale condensation kg kg**-1 s**-1"},
+    /* 227 */ {"CRNH", "Change from removing negative humidity kg kg**-1 s**-1"},
+    /* 228 */ {"ATT", "Adiabatic tendency of temperature K s**-1"},
+    /* 229 */ {"ATH", "Adiabatic tendency of humidity kg kg**-1 s**-1"},
+    /* 230 */ {"ATZW", "Adiabatic tendency of zonal wind m**2 s**-3"},
+    /* 231 */ {"ATMW", "Adiabatic tendency of meridional wind m**2 s**-3"},
+    /* 232 */ {"MVV", "Mean vertical velocity Pa s**-1"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_131.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_131.c
new file mode 100644
index 00000000..414b22d6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_131.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_131[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"var129", "undefined"},
+    /* 130 */ {"TAP", "Temperature anomaly probability % K"},
+    /* 131 */ {"var131", "undefined"},
+    /* 132 */ {"var132", "undefined"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"var141", "undefined"},
+    /* 142 */ {"var142", "undefined"},
+    /* 143 */ {"var143", "undefined"},
+    /* 144 */ {"var144", "undefined"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"var151", "undefined"},
+    /* 152 */ {"var152", "undefined"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"var155", "undefined"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"var164", "undefined"},
+    /* 165 */ {"10SP", "10 metre speed probability % m s**-1"},
+    /* 166 */ {"var166", "undefined"},
+    /* 167 */ {"2TP", "2 metre temperature probability %"},
+    /* 168 */ {"var168", "undefined"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"var170", "undefined"},
+    /* 171 */ {"var171", "undefined"},
+    /* 172 */ {"var172", "undefined"},
+    /* 173 */ {"var173", "undefined"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"var176", "undefined"},
+    /* 177 */ {"var177", "undefined"},
+    /* 178 */ {"var178", "undefined"},
+    /* 179 */ {"var179", "undefined"},
+    /* 180 */ {"var180", "undefined"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"var201", "undefined"},
+    /* 202 */ {"var202", "undefined"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"var205", "undefined"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"TPP", "Total precipitation probability % m"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"var230", "undefined"},
+    /* 231 */ {"var231", "undefined"},
+    /* 232 */ {"var232", "undefined"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_140.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_140.c
new file mode 100644
index 00000000..295ceb11
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_140.c
@@ -0,0 +1,260 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_ecmwf_140[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"var1", "undefined"},
+      /* 2 */ {"var2", "undefined"},
+      /* 3 */ {"var3", "undefined"},
+      /* 4 */ {"var4", "undefined"},
+      /* 5 */ {"var5", "undefined"},
+      /* 6 */ {"var6", "undefined"},
+      /* 7 */ {"var7", "undefined"},
+      /* 8 */ {"var8", "undefined"},
+      /* 9 */ {"var9", "undefined"},
+      /* 10 */ {"var10", "undefined"},
+      /* 11 */ {"var11", "undefined"},
+      /* 12 */ {"var12", "undefined"},
+      /* 13 */ {"var13", "undefined"},
+      /* 14 */ {"var14", "undefined"},
+      /* 15 */ {"var15", "undefined"},
+      /* 16 */ {"var16", "undefined"},
+      /* 17 */ {"var17", "undefined"},
+      /* 18 */ {"var18", "undefined"},
+      /* 19 */ {"var19", "undefined"},
+      /* 20 */ {"var20", "undefined"},
+      /* 21 */ {"var21", "undefined"},
+      /* 22 */ {"var22", "undefined"},
+      /* 23 */ {"var23", "undefined"},
+      /* 24 */ {"var24", "undefined"},
+      /* 25 */ {"var25", "undefined"},
+      /* 26 */ {"var26", "undefined"},
+      /* 27 */ {"var27", "undefined"},
+      /* 28 */ {"var28", "undefined"},
+      /* 29 */ {"var29", "undefined"},
+      /* 30 */ {"var30", "undefined"},
+      /* 31 */ {"var31", "undefined"},
+      /* 32 */ {"var32", "undefined"},
+      /* 33 */ {"var33", "undefined"},
+      /* 34 */ {"var34", "undefined"},
+      /* 35 */ {"var35", "undefined"},
+      /* 36 */ {"var36", "undefined"},
+      /* 37 */ {"var37", "undefined"},
+      /* 38 */ {"var38", "undefined"},
+      /* 39 */ {"var39", "undefined"},
+      /* 40 */ {"var40", "undefined"},
+      /* 41 */ {"var41", "undefined"},
+      /* 42 */ {"var42", "undefined"},
+      /* 43 */ {"var43", "undefined"},
+      /* 44 */ {"var44", "undefined"},
+      /* 45 */ {"var45", "undefined"},
+      /* 46 */ {"var46", "undefined"},
+      /* 47 */ {"var47", "undefined"},
+      /* 48 */ {"var48", "undefined"},
+      /* 49 */ {"var49", "undefined"},
+      /* 50 */ {"var50", "undefined"},
+      /* 51 */ {"var51", "undefined"},
+      /* 52 */ {"var52", "undefined"},
+      /* 53 */ {"var53", "undefined"},
+      /* 54 */ {"var54", "undefined"},
+      /* 55 */ {"var55", "undefined"},
+      /* 56 */ {"var56", "undefined"},
+      /* 57 */ {"var57", "undefined"},
+      /* 58 */ {"var58", "undefined"},
+      /* 59 */ {"var59", "undefined"},
+      /* 60 */ {"var60", "undefined"},
+      /* 61 */ {"var61", "undefined"},
+      /* 62 */ {"var62", "undefined"},
+      /* 63 */ {"var63", "undefined"},
+      /* 64 */ {"var64", "undefined"},
+      /* 65 */ {"var65", "undefined"},
+      /* 66 */ {"var66", "undefined"},
+      /* 67 */ {"var67", "undefined"},
+      /* 68 */ {"var68", "undefined"},
+      /* 69 */ {"var69", "undefined"},
+      /* 70 */ {"var70", "undefined"},
+      /* 71 */ {"var71", "undefined"},
+      /* 72 */ {"var72", "undefined"},
+      /* 73 */ {"var73", "undefined"},
+      /* 74 */ {"var74", "undefined"},
+      /* 75 */ {"var75", "undefined"},
+      /* 76 */ {"var76", "undefined"},
+      /* 77 */ {"var77", "undefined"},
+      /* 78 */ {"var78", "undefined"},
+      /* 79 */ {"var79", "undefined"},
+      /* 80 */ {"var80", "undefined"},
+      /* 81 */ {"var81", "undefined"},
+      /* 82 */ {"var82", "undefined"},
+      /* 83 */ {"var83", "undefined"},
+      /* 84 */ {"var84", "undefined"},
+      /* 85 */ {"var85", "undefined"},
+      /* 86 */ {"var86", "undefined"},
+      /* 87 */ {"var87", "undefined"},
+      /* 88 */ {"var88", "undefined"},
+      /* 89 */ {"var89", "undefined"},
+      /* 90 */ {"var90", "undefined"},
+      /* 91 */ {"var91", "undefined"},
+      /* 92 */ {"var92", "undefined"},
+      /* 93 */ {"var93", "undefined"},
+      /* 94 */ {"var94", "undefined"},
+      /* 95 */ {"var95", "undefined"},
+      /* 96 */ {"var96", "undefined"},
+      /* 97 */ {"var97", "undefined"},
+      /* 98 */ {"var98", "undefined"},
+      /* 99 */ {"var99", "undefined"},
+      /* 100 */ {"var100", "undefined"},
+      /* 101 */ {"var101", "undefined"},
+      /* 102 */ {"var102", "undefined"},
+      /* 103 */ {"var103", "undefined"},
+      /* 104 */ {"var104", "undefined"},
+      /* 105 */ {"var105", "undefined"},
+      /* 106 */ {"var106", "undefined"},
+      /* 107 */ {"var107", "undefined"},
+      /* 108 */ {"var108", "undefined"},
+      /* 109 */ {"var109", "undefined"},
+      /* 110 */ {"var110", "undefined"},
+      /* 111 */ {"var111", "undefined"},
+      /* 112 */ {"var112", "undefined"},
+      /* 113 */ {"var113", "undefined"},
+      /* 114 */ {"var114", "undefined"},
+      /* 115 */ {"var115", "undefined"},
+      /* 116 */ {"var116", "undefined"},
+      /* 117 */ {"var117", "undefined"},
+      /* 118 */ {"var118", "undefined"},
+      /* 119 */ {"var119", "undefined"},
+      /* 120 */ {"var120", "undefined"},
+      /* 121 */ {"var121", "undefined"},
+      /* 122 */ {"var122", "undefined"},
+      /* 123 */ {"var123", "undefined"},
+      /* 124 */ {"var124", "undefined"},
+      /* 125 */ {"var125", "undefined"},
+      /* 126 */ {"var126", "undefined"},
+      /* 127 */ {"var127", "undefined"},
+      /* 128 */ {"var128", "undefined"},
+      /* 129 */ {"var129", "undefined"},
+      /* 130 */ {"var130", "undefined"},
+      /* 131 */ {"var131", "undefined"},
+      /* 132 */ {"var132", "undefined"},
+      /* 133 */ {"var133", "undefined"},
+      /* 134 */ {"var134", "undefined"},
+      /* 135 */ {"var135", "undefined"},
+      /* 136 */ {"var136", "undefined"},
+      /* 137 */ {"var137", "undefined"},
+      /* 138 */ {"var138", "undefined"},
+      /* 139 */ {"var139", "undefined"},
+      /* 140 */ {"var140", "undefined"},
+      /* 141 */ {"var141", "undefined"},
+      /* 142 */ {"var142", "undefined"},
+      /* 143 */ {"var143", "undefined"},
+      /* 144 */ {"var144", "undefined"},
+      /* 145 */ {"var145", "undefined"},
+      /* 146 */ {"var146", "undefined"},
+      /* 147 */ {"var147", "undefined"},
+      /* 148 */ {"var148", "undefined"},
+      /* 149 */ {"var149", "undefined"},
+      /* 150 */ {"var150", "undefined"},
+      /* 151 */ {"var151", "undefined"},
+      /* 152 */ {"var152", "undefined"},
+      /* 153 */ {"var153", "undefined"},
+      /* 154 */ {"var154", "undefined"},
+      /* 155 */ {"var155", "undefined"},
+      /* 156 */ {"var156", "undefined"},
+      /* 157 */ {"var157", "undefined"},
+      /* 158 */ {"var158", "undefined"},
+      /* 159 */ {"var159", "undefined"},
+      /* 160 */ {"var160", "undefined"},
+      /* 161 */ {"var161", "undefined"},
+      /* 162 */ {"var162", "undefined"},
+      /* 163 */ {"var163", "undefined"},
+      /* 164 */ {"var164", "undefined"},
+      /* 165 */ {"var165", "undefined"},
+      /* 166 */ {"var166", "undefined"},
+      /* 167 */ {"var167", "undefined"},
+      /* 168 */ {"var168", "undefined"},
+      /* 169 */ {"var169", "undefined"},
+      /* 170 */ {"var170", "undefined"},
+      /* 171 */ {"var171", "undefined"},
+      /* 172 */ {"var172", "undefined"},
+      /* 173 */ {"var173", "undefined"},
+      /* 174 */ {"var174", "undefined"},
+      /* 175 */ {"var175", "undefined"},
+      /* 176 */ {"var176", "undefined"},
+      /* 177 */ {"var177", "undefined"},
+      /* 178 */ {"var178", "undefined"},
+      /* 179 */ {"var179", "undefined"},
+      /* 180 */ {"var180", "undefined"},
+      /* 181 */ {"var181", "undefined"},
+      /* 182 */ {"var182", "undefined"},
+      /* 183 */ {"var183", "undefined"},
+      /* 184 */ {"var184", "undefined"},
+      /* 185 */ {"var185", "undefined"},
+      /* 186 */ {"var186", "undefined"},
+      /* 187 */ {"var187", "undefined"},
+      /* 188 */ {"var188", "undefined"},
+      /* 189 */ {"var189", "undefined"},
+      /* 190 */ {"var190", "undefined"},
+      /* 191 */ {"var191", "undefined"},
+      /* 192 */ {"var192", "undefined"},
+      /* 193 */ {"var193", "undefined"},
+      /* 194 */ {"var194", "undefined"},
+      /* 195 */ {"var195", "undefined"},
+      /* 196 */ {"var196", "undefined"},
+      /* 197 */ {"var197", "undefined"},
+      /* 198 */ {"var198", "undefined"},
+      /* 199 */ {"var199", "undefined"},
+      /* 200 */ {"var200", "undefined"},
+      /* 201 */ {"var201", "undefined"},
+      /* 202 */ {"var202", "undefined"},
+      /* 203 */ {"var203", "undefined"},
+      /* 204 */ {"var204", "undefined"},
+      /* 205 */ {"var205", "undefined"},
+      /* 206 */ {"var206", "undefined"},
+      /* 207 */ {"var207", "undefined"},
+      /* 208 */ {"var208", "undefined"},
+      /* 209 */ {"var209", "undefined"},
+      /* 210 */ {"var210", "undefined"},
+      /* 211 */ {"var211", "undefined"},
+      /* 212 */ {"var212", "undefined"},
+      /* 213 */ {"var213", "undefined"},
+      /* 214 */ {"var214", "undefined"},
+      /* 215 */ {"var215", "undefined"},
+      /* 216 */ {"var216", "undefined"},
+      /* 217 */ {"var217", "undefined"},
+      /* 218 */ {"var218", "undefined"},
+      /* 219 */ {"var219", "undefined"},
+      /* 220 */ {"MP1", "Mean wave period based on first moment [s]"},
+      /* 221 */ {"MP2", "Mean wave period based on second moment [s]"},
+      /* 222 */ {"WDW", "Wave spectral directional width"},
+      /* 223 */ {"P1WW", "Mean wave period based on first moment for wind waves [s]"},
+      /* 224 */ {"P2WW", "Mean wave period based on second moment for wind waves [s]"},
+      /* 225 */ {"DWWW", "Wave spectral directional width for wind waves"},
+      /* 226 */ {"P1PS", "Mean wave period based on first moment for swell [s]"},
+      /* 227 */ {"P2PS", "Mean wave period based on second moment for swell [s]"},
+      /* 228 */ {"DWPS", "Wave spectral directional width for swell"},
+      /* 229 */ {"SWH", "Significant wave height [m]"},
+      /* 230 */ {"MWD", "Mean wave direction [degrees]"},
+      /* 231 */ {"PP1D", "Peak period of 1D spectra [s]"},
+      /* 232 */ {"MWP", "Mean wave period [s]"},
+      /* 233 */ {"CDWW", "Coefficient of drag with waves"},
+      /* 234 */ {"SHWW", "Significant height of wind waves [m]"},
+      /* 235 */ {"MDWW", "Mean direction of wind waves [degrees]"},
+      /* 236 */ {"MPWW", "Mean period of wind waves [s]"},
+      /* 237 */ {"SHPS", "Significant height of primary swell [m]"},
+      /* 238 */ {"MDPS", "Mean direction of primary swell [degrees]"},
+      /* 239 */ {"MPPS", "Mean period of primary swell [s]"},
+      /* 240 */ {"SDHS", "Standard deviation wave height [m]"},
+      /* 241 */ {"MU10", "Mean of 10 metre windspeed [m s**-1]"},
+      /* 242 */ {"MDWI", "Mean wind direction [degrees]"},
+      /* 243 */ {"SDU", "Standard deviation of 10 metre wind speed [m s**-1]"},
+      /* 244 */ {"MSQS", "Mean square slope of waves [dimensionless]"},
+      /* 245 */ {"WIND", "10 metre wind speed [m s**-1]"},
+      /* 246 */ {"AWH", "Altimeter wave height [m]"},
+      /* 247 */ {"ACWH", "Altimeter corrected wave height [m]"},
+      /* 248 */ {"ARRC", "Altimeter range relative correction"},
+      /* 249 */ {"DWI", "10 metre wind direction [degrees]"},
+      /* 250 */ {"2DSP", "2D wave spectra (multiple) [m**2 s]"},
+      /* 251 */ {"2DFD", "2D wave spectra (single) [m**2 s]"},
+      /* 252 */ {"var252", "undefined"},
+      /* 253 */ {"var253", "undefined"},
+      /* 254 */ {"var254", "undefined"},
+      /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_150.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_150.c
new file mode 100644
index 00000000..7d293a21
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_150.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_150[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"NONE", "Ocean potential temperature deg C"},
+    /* 130 */ {"NONE", "Ocean salinity psu"},
+    /* 131 */ {"NONE", "Ocean potential density(reference = surface) kg m**-3 -1000"},
+    /* 132 */ {"var132", "undefined"},
+    /* 133 */ {"NONE", "Ocean u velocity m s**-1"},
+    /* 134 */ {"NONE", "Ocean v velocity m s**-1"},
+    /* 135 */ {"NONE", "Ocean w velocity m s**-1"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"NONE", "Richardson number -"},
+    /* 138 */ {"var138", "undefined"},
+    /* 139 */ {"NONE", "u*v product m s**-2"},
+    /* 140 */ {"NONE", "u*T product m s**-1 deg C"},
+    /* 141 */ {"NONE", "v*T product m s**-1 deg C"},
+    /* 142 */ {"NONE", "u*u product m s**-2"},
+    /* 143 */ {"NONE", "v*v product m s**-2"},
+    /* 144 */ {"NONE", "uv - u~v~ (u~ is time-mean of u) m s**-2"},
+    /* 145 */ {"NONE", "uT - u~T~ m s**-1 deg C"},
+    /* 146 */ {"NONE", "vT - v~T~ m s**-1 deg C"},
+    /* 147 */ {"NONE", "uu - u~u~ m s**-2"},
+    /* 148 */ {"NONE", "vv - v~v~ m s**-2"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"var151", "undefined"},
+    /* 152 */ {"NONE", "Sea level (departure from geoid tides removed)"},
+    /* 153 */ {"NONE", "Barotropic stream function -"},
+    /* 154 */ {"NONE", "Mixed layer depth (Tcr=0.5 C for HOPE model) m"},
+    /* 155 */ {"NONE", "Depth (eg of isothermal surface) m"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"var164", "undefined"},
+    /* 165 */ {"var165", "undefined"},
+    /* 166 */ {"var166", "undefined"},
+    /* 167 */ {"var167", "undefined"},
+    /* 168 */ {"NONE", "U-stress Pa"},
+    /* 169 */ {"NONE", "V-stress Pa"},
+    /* 170 */ {"NONE", "Turbulent Kinetic Energy input -"},
+    /* 171 */ {"NONE", "Net surface heat flux (+ve = down) -"},
+    /* 172 */ {"NONE", "Surface solar radiation -"},
+    /* 173 */ {"NONE", "P-E -"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"var176", "undefined"},
+    /* 177 */ {"var177", "undefined"},
+    /* 178 */ {"var178", "undefined"},
+    /* 179 */ {"var179", "undefined"},
+    /* 180 */ {"NONE", "Diagnosed SST eror deg C"},
+    /* 181 */ {"NONE", "Heat flux correction W m**-2"},
+    /* 182 */ {"NONE", "Observed SST deg C"},
+    /* 183 */ {"NONE", "Observed heat flux W m**-2"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"var201", "undefined"},
+    /* 202 */ {"var202", "undefined"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"var205", "undefined"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"var228", "undefined"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"var230", "undefined"},
+    /* 231 */ {"var231", "undefined"},
+    /* 232 */ {"var232", "undefined"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_151.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_151.c
new file mode 100644
index 00000000..96a13445
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_151.c
@@ -0,0 +1,260 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_ecmwf_151[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"T", "Accum. potential temperature deg C"},
+      /* 2 */ {"", "Accum. salinity"},
+      /* 3 */ {"", "Accum. U-velocity m s**-1"},
+      /* 4 */ {"", "Accum. V-velocity m s**-1"},
+      /* 5 */ {"V", "Accum. W-velocity m s**-1"},
+      /* 6 */ {"ST", "Accum. modulus of strain rate tensor s**-1"},
+      /* 7 */ {"VS", "Accum. vertical viscosity m**2 s**-1"},
+      /* 8 */ {"DF", "Accum. vertical diffusivity m**2 s**-1"},
+      /* 9 */ {"EP", "Accum. depth m"},
+      /* 10 */ {"STH", "Accum. sigma-theta kg m**-3"},
+      /* 11 */ {"RN", "Accum. Richardson number -"},
+      /* 12 */ {"UV", "Accum. u*v product m**2 s**-2"},
+      /* 13 */ {"UT", "Accum. u*T product m s**-1 deg C"},
+      /* 14 */ {"VT", "Accum. v*T product m s**-1 deg C"},
+      /* 15 */ {"UU", "Accum. u*u product m**2 s**-2"},
+      /* 16 */ {"VV", "Accum. v*v product m**2 s**-2"},
+      /* 17 */ {"SL", "Accum. sea level (tides removed) m"},
+      /* 18 */ {"var18", "undefined"},
+      /* 19 */ {"BSF", "Accum. barotropic streamfunction m**3 s**-1"},
+      /* 20 */ {"MLD", "Accum. mixed layer depth m"},
+      /* 21 */ {"var21", "undefined"},
+      /* 22 */ {"var22", "undefined"},
+      /* 23 */ {"var23", "undefined"},
+      /* 24 */ {"var24", "undefined"},
+      /* 25 */ {"TAX", "Accum. U-stress Pa"},
+      /* 26 */ {"TAY", "Accum. V-stress Pa"},
+      /* 27 */ {"TKI", "Accum. turbulent kinetic energy input W m**-2"},
+      /* 28 */ {"NSF", "Accum. net surface heat flux W m**-2"},
+      /* 29 */ {"ASR", "Accum. absorbed solar radiation W m**-2"},
+      /* 30 */ {"PME", "Accum. precipitation - evaporation m s**-1"},
+      /* 31 */ {"SST", "Accum. specified SST deg C"},
+      /* 32 */ {"SHF", "Accum. specified surface heat flux W m**-2"},
+      /* 33 */ {"DTE", "Accum. diagnosed SST error deg C"},
+      /* 34 */ {"HFC", "Accum. heat flux correction W m**-2"},
+      /* 35 */ {"var35", "undefined"},
+      /* 36 */ {"var36", "undefined"},
+      /* 37 */ {"var37", "undefined"},
+      /* 38 */ {"var38", "undefined"},
+      /* 39 */ {"var39", "undefined"},
+      /* 40 */ {"var40", "undefined"},
+      /* 41 */ {"var41", "undefined"},
+      /* 42 */ {"var42", "undefined"},
+      /* 43 */ {"var43", "undefined"},
+      /* 44 */ {"var44", "undefined"},
+      /* 45 */ {"var45", "undefined"},
+      /* 46 */ {"var46", "undefined"},
+      /* 47 */ {"var47", "undefined"},
+      /* 48 */ {"var48", "undefined"},
+      /* 49 */ {"var49", "undefined"},
+      /* 50 */ {"var50", "undefined"},
+      /* 51 */ {"var51", "undefined"},
+      /* 52 */ {"var52", "undefined"},
+      /* 53 */ {"var53", "undefined"},
+      /* 54 */ {"var54", "undefined"},
+      /* 55 */ {"var55", "undefined"},
+      /* 56 */ {"var56", "undefined"},
+      /* 57 */ {"var57", "undefined"},
+      /* 58 */ {"var58", "undefined"},
+      /* 59 */ {"var59", "undefined"},
+      /* 60 */ {"var60", "undefined"},
+      /* 61 */ {"var61", "undefined"},
+      /* 62 */ {"var62", "undefined"},
+      /* 63 */ {"var63", "undefined"},
+      /* 64 */ {"var64", "undefined"},
+      /* 65 */ {"var65", "undefined"},
+      /* 66 */ {"var66", "undefined"},
+      /* 67 */ {"var67", "undefined"},
+      /* 68 */ {"var68", "undefined"},
+      /* 69 */ {"var69", "undefined"},
+      /* 70 */ {"var70", "undefined"},
+      /* 71 */ {"var71", "undefined"},
+      /* 72 */ {"var72", "undefined"},
+      /* 73 */ {"var73", "undefined"},
+      /* 74 */ {"var74", "undefined"},
+      /* 75 */ {"var75", "undefined"},
+      /* 76 */ {"var76", "undefined"},
+      /* 77 */ {"var77", "undefined"},
+      /* 78 */ {"var78", "undefined"},
+      /* 79 */ {"var79", "undefined"},
+      /* 80 */ {"var80", "undefined"},
+      /* 81 */ {"var81", "undefined"},
+      /* 82 */ {"var82", "undefined"},
+      /* 83 */ {"var83", "undefined"},
+      /* 84 */ {"var84", "undefined"},
+      /* 85 */ {"var85", "undefined"},
+      /* 86 */ {"var86", "undefined"},
+      /* 87 */ {"var87", "undefined"},
+      /* 88 */ {"var88", "undefined"},
+      /* 89 */ {"var89", "undefined"},
+      /* 90 */ {"var90", "undefined"},
+      /* 91 */ {"var91", "undefined"},
+      /* 92 */ {"var92", "undefined"},
+      /* 93 */ {"var93", "undefined"},
+      /* 94 */ {"var94", "undefined"},
+      /* 95 */ {"var95", "undefined"},
+      /* 96 */ {"var96", "undefined"},
+      /* 97 */ {"var97", "undefined"},
+      /* 98 */ {"var98", "undefined"},
+      /* 99 */ {"var99", "undefined"},
+      /* 100 */ {"var100", "undefined"},
+      /* 101 */ {"var101", "undefined"},
+      /* 102 */ {"var102", "undefined"},
+      /* 103 */ {"var103", "undefined"},
+      /* 104 */ {"var104", "undefined"},
+      /* 105 */ {"var105", "undefined"},
+      /* 106 */ {"var106", "undefined"},
+      /* 107 */ {"var107", "undefined"},
+      /* 108 */ {"var108", "undefined"},
+      /* 109 */ {"var109", "undefined"},
+      /* 110 */ {"var110", "undefined"},
+      /* 111 */ {"var111", "undefined"},
+      /* 112 */ {"var112", "undefined"},
+      /* 113 */ {"var113", "undefined"},
+      /* 114 */ {"var114", "undefined"},
+      /* 115 */ {"var115", "undefined"},
+      /* 116 */ {"var116", "undefined"},
+      /* 117 */ {"var117", "undefined"},
+      /* 118 */ {"var118", "undefined"},
+      /* 119 */ {"var119", "undefined"},
+      /* 120 */ {"var120", "undefined"},
+      /* 121 */ {"var121", "undefined"},
+      /* 122 */ {"var122", "undefined"},
+      /* 123 */ {"var123", "undefined"},
+      /* 124 */ {"var124", "undefined"},
+      /* 125 */ {"var125", "undefined"},
+      /* 126 */ {"var126", "undefined"},
+      /* 127 */ {"NONE", "RESERVED"},
+      /* 128 */ {"NONE", "RESERVED"},
+      /* 129 */ {"PT", "Potential temperature deg C"},
+      /* 130 */ {"S", "Salinity"},
+      /* 131 */ {"U", "U-velocity m s**-1"},
+      /* 132 */ {"V", "V-velocity m s**-1"},
+      /* 133 */ {"WV", "W-velocity m s**-1"},
+      /* 134 */ {"MST", "Modulus of strain rate tensor s**-1"},
+      /* 135 */ {"VVS", "Vertical viscosity m**2 s**-1"},
+      /* 136 */ {"VDF", "Vertical diffusivity m**2 s**-1"},
+      /* 137 */ {"DEP", "Depth m"},
+      /* 138 */ {"STH", "Sigma-theta kg m**-3"},
+      /* 139 */ {"RN", "Richardson number -"},
+      /* 140 */ {"var140", "undefined"},
+      /* 141 */ {"var141", "undefined"},
+      /* 142 */ {"var142", "undefined"},
+      /* 143 */ {"var143", "undefined"},
+      /* 144 */ {"var144", "undefined"},
+      /* 145 */ {"SL", "Sea level (tides removed) m"},
+      /* 146 */ {"SFT", "Sea floor topography m"},
+      /* 147 */ {"BSF", "Barotropic streamfunction m**3 s**-1"},
+      /* 148 */ {"MLD", "Mixed layer depth m"},
+      /* 149 */ {"var149", "undefined"},
+      /* 150 */ {"var150", "undefined"},
+      /* 151 */ {"var151", "undefined"},
+      /* 152 */ {"NONE", "RESERVED"},
+      /* 153 */ {"TAX", "U-stress Pa"},
+      /* 154 */ {"TAY", "V-stress Pa"},
+      /* 155 */ {"TKI", "Turbulent kinetic energy input W m**-2"},
+      /* 156 */ {"NSF", "Net surface heat flux W m**-2"},
+      /* 157 */ {"ASR", "Absorbed solar radiation W m**-2"},
+      /* 158 */ {"PME", "Precipitation - evaporation m s**-1"},
+      /* 159 */ {"SST", "Specified SST deg C"},
+      /* 160 */ {"SHF", "Specified surface heat flux W m**-2"},
+      /* 161 */ {"DTE", "Diagnosed SST error deg C"},
+      /* 162 */ {"HFC", "Heat flux correction W m**-2"},
+      /* 163 */ {"var163", "undefined"},
+      /* 164 */ {"var164", "undefined"},
+      /* 165 */ {"var165", "undefined"},
+      /* 166 */ {"var166", "undefined"},
+      /* 167 */ {"var167", "undefined"},
+      /* 168 */ {"var168", "undefined"},
+      /* 169 */ {"var169", "undefined"},
+      /* 170 */ {"var170", "undefined"},
+      /* 171 */ {"var171", "undefined"},
+      /* 172 */ {"var172", "undefined"},
+      /* 173 */ {"var173", "undefined"},
+      /* 174 */ {"var174", "undefined"},
+      /* 175 */ {"var175", "undefined"},
+      /* 176 */ {"var176", "undefined"},
+      /* 177 */ {"var177", "undefined"},
+      /* 178 */ {"var178", "undefined"},
+      /* 179 */ {"var179", "undefined"},
+      /* 180 */ {"var180", "undefined"},
+      /* 181 */ {"var181", "undefined"},
+      /* 182 */ {"var182", "undefined"},
+      /* 183 */ {"var183", "undefined"},
+      /* 184 */ {"var184", "undefined"},
+      /* 185 */ {"var185", "undefined"},
+      /* 186 */ {"var186", "undefined"},
+      /* 187 */ {"var187", "undefined"},
+      /* 188 */ {"var188", "undefined"},
+      /* 189 */ {"var189", "undefined"},
+      /* 190 */ {"var190", "undefined"},
+      /* 191 */ {"var191", "undefined"},
+      /* 192 */ {"var192", "undefined"},
+      /* 193 */ {"var193", "undefined"},
+      /* 194 */ {"var194", "undefined"},
+      /* 195 */ {"var195", "undefined"},
+      /* 196 */ {"var196", "undefined"},
+      /* 197 */ {"var197", "undefined"},
+      /* 198 */ {"var198", "undefined"},
+      /* 199 */ {"var199", "undefined"},
+      /* 200 */ {"var200", "undefined"},
+      /* 201 */ {"var201", "undefined"},
+      /* 202 */ {"var202", "undefined"},
+      /* 203 */ {"var203", "undefined"},
+      /* 204 */ {"var204", "undefined"},
+      /* 205 */ {"var205", "undefined"},
+      /* 206 */ {"var206", "undefined"},
+      /* 207 */ {"var207", "undefined"},
+      /* 208 */ {"var208", "undefined"},
+      /* 209 */ {"var209", "undefined"},
+      /* 210 */ {"var210", "undefined"},
+      /* 211 */ {"var211", "undefined"},
+      /* 212 */ {"var212", "undefined"},
+      /* 213 */ {"var213", "undefined"},
+      /* 214 */ {"var214", "undefined"},
+      /* 215 */ {"var215", "undefined"},
+      /* 216 */ {"var216", "undefined"},
+      /* 217 */ {"var217", "undefined"},
+      /* 218 */ {"var218", "undefined"},
+      /* 219 */ {"var219", "undefined"},
+      /* 220 */ {"var220", "undefined"},
+      /* 221 */ {"var221", "undefined"},
+      /* 222 */ {"var222", "undefined"},
+      /* 223 */ {"var223", "undefined"},
+      /* 224 */ {"var224", "undefined"},
+      /* 225 */ {"var225", "undefined"},
+      /* 226 */ {"var226", "undefined"},
+      /* 227 */ {"var227", "undefined"},
+      /* 228 */ {"var228", "undefined"},
+      /* 229 */ {"var229", "undefined"},
+      /* 230 */ {"var230", "undefined"},
+      /* 231 */ {"var231", "undefined"},
+      /* 232 */ {"var232", "undefined"},
+      /* 233 */ {"var233", "undefined"},
+      /* 234 */ {"var234", "undefined"},
+      /* 235 */ {"var235", "undefined"},
+      /* 236 */ {"var236", "undefined"},
+      /* 237 */ {"var237", "undefined"},
+      /* 238 */ {"var238", "undefined"},
+      /* 239 */ {"var239", "undefined"},
+      /* 240 */ {"var240", "undefined"},
+      /* 241 */ {"var241", "undefined"},
+      /* 242 */ {"var242", "undefined"},
+      /* 243 */ {"var243", "undefined"},
+      /* 244 */ {"var244", "undefined"},
+      /* 245 */ {"var245", "undefined"},
+      /* 246 */ {"var246", "undefined"},
+      /* 247 */ {"var247", "undefined"},
+      /* 248 */ {"var248", "undefined"},
+      /* 249 */ {"var249", "undefined"},
+      /* 250 */ {"var250", "undefined"},
+      /* 251 */ {"var251", "undefined"},
+      /* 252 */ {"var252", "undefined"},
+      /* 253 */ {"var253", "undefined"},
+      /* 254 */ {"var254", "undefined"},
+      /* 255 */ {"NONE", "RESERVED"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_160.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_160.c
new file mode 100644
index 00000000..dfc1593d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_160.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_160[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"AT", "Atmospheric tide+ -"},
+    /* 128 */ {"BV", "Budget values+ -"},
+    /* 129 */ {"Z", "Geopotential / orography m**2 s**-2"},
+    /* 130 */ {"T", "Temperature K"},
+    /* 131 */ {"U", "U-velocity m s**-1"},
+    /* 132 */ {"V", "V-velocity m s**-1"},
+    /* 133 */ {"Q", "Specific humidity kg kg**-1"},
+    /* 134 */ {"SP", "Surface pressure Pa"},
+    /* 135 */ {"W", "Vertical velocity Pa s**-1"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"PWC", "Precipitable water content kg m**-2"},
+    /* 138 */ {"VO", "Vorticity (relative) s**-1"},
+    /* 139 */ {"STL1", "Soil temperature level 1 K"},
+    /* 140 */ {"SWL1", "Soil wetness level 1 m"},
+    /* 141 */ {"SD", "Snow depth m (of water)"},
+    /* 142 */ {"LSP", "Large scale precipitation kg m**-2 s**-1"},
+    /* 143 */ {"CP", "Convective precipitation kg m**-2 s**-1"},
+    /* 144 */ {"SF", "Snow fall kg m**-2 s**-1"},
+    /* 145 */ {"BLD", "Boundary layer dissipation W m**-2"},
+    /* 146 */ {"SSHF", "Surface sensible heat flux W m**-2"},
+    /* 147 */ {"SLHF", "Surface latent heat flux W m**-2"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"var149", "undefined"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"MSL", "Mean sea level pressure Pa"},
+    /* 152 */ {"LNSP", "Ln surface pressure -"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"D", "Divergence s**-1"},
+    /* 156 */ {"GH", "Height (geopotential) m"},
+    /* 157 */ {"R", "Relative humidity (0 - 1)"},
+    /* 158 */ {"TSP", "Tendency of surface pressure Pa s**-1"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"TCC", "Total cloud cover (0 - 1)"},
+    /* 165 */ {"10U", "10 metre u wind component m s**-1"},
+    /* 166 */ {"10V", "10 metre v wind component m s**-1"},
+    /* 167 */ {"2T", "2 metre temperature K"},
+    /* 168 */ {"2D", "2 metre dewpoint temperature K"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"STL2", "Soil temperature level 2 K"},
+    /* 171 */ {"SWL2", "Soil wetness level 2 m"},
+    /* 172 */ {"LSM", "Land/sea mask (0 - 1)"},
+    /* 173 */ {"SR", "Surface roughness m"},
+    /* 174 */ {"AL", "Albedo (0 - 1)"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"SSR", "Surface solar radiation W m**-2"},
+    /* 177 */ {"STR", "Surface thermal radiation W m**-2"},
+    /* 178 */ {"TSR", "Top solar radiation W m**-2"},
+    /* 179 */ {"TTR", "Top thermal radiation W m**-2"},
+    /* 180 */ {"EWSS", "East/west surface stress N m**-2 s**-1"},
+    /* 181 */ {"NSSS", "North/south surface stress N m**-2 s**-1"},
+    /* 182 */ {"E", "Evaporation kg m**-2 s**-1"},
+    /* 183 */ {"STL3", "Soil temperature level 3 K"},
+    /* 184 */ {"SWL3", "Soil wetness level 3 m"},
+    /* 185 */ {"CCC", "Convective cloud cover (0 - 1)"},
+    /* 186 */ {"LCC", "Low cloud cover (0 - 1)"},
+    /* 187 */ {"MCC", "Medium cloud cover (0 - 1)"},
+    /* 188 */ {"HCC", "High cloud cover (0 - 1)"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"EWOV", "EW component of sub-grid scale orographic variance m**2"},
+    /* 191 */ {"NSOV", "NS component of sub-grid scale orographic variance m**2"},
+    /* 192 */ {"NWOV", "NWSE component sub-grid scale orographic variance m**2"},
+    /* 193 */ {"NEOV", "NESW component sub-grid scale orographic variance m**2"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"LGWS", "Latitudinal component of gravity wave stress N m**-2 s"},
+    /* 196 */ {"MGWS", "Meridional component of gravity wave stress N m**-2 s"},
+    /* 197 */ {"GWD", "Gravity wave dissipation W m**-2 s"},
+    /* 198 */ {"SRC", "Skin reservoir content m (of water)"},
+    /* 199 */ {"VEG", "Percentage of vegetation %"},
+    /* 200 */ {"VSO", "Variance of sub-grid scale orography m**2"},
+    /* 201 */ {"MX2T", "Max temp.2m during averaging time K"},
+    /* 202 */ {"MN2T", "Min temp.2m during averaging time K"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"PAW", "Precip. analysis weights -"},
+    /* 205 */ {"RO", "Runoff kg m**-2 s**-1"},
+    /* 206 */ {"ZZ", "St.Dev. of Geopotential m**2 s**-2"},
+    /* 207 */ {"TZ", "Covar Temp & Geopotential K m**2 s**-2"},
+    /* 208 */ {"TT", "St.Dev. of Temperature K"},
+    /* 209 */ {"QZ", "Covar Sp.Hum. & Geopotential m**2 s**-2"},
+    /* 210 */ {"QT", "Covar Sp.Hum & Temp. K"},
+    /* 211 */ {"QQ", "St.Dev. of Specific humidity (0 - 1)"},
+    /* 212 */ {"UZ", "Covar U-comp. & Geopotential m**3 s**-3"},
+    /* 213 */ {"UT", "Covar U-comp. & Temp. K m s**-1"},
+    /* 214 */ {"UQ", "Covar U-comp. & Sp.Hum. m s**-1"},
+    /* 215 */ {"UU", "St.Dev. of U-velocity m s**-1"},
+    /* 216 */ {"VZ", "Covar V-comp. & Geopotential m**3 s**-3"},
+    /* 217 */ {"VT", "Covar V-comp. & Temp. K m s**-1"},
+    /* 218 */ {"VQ", "Covar V-comp. & Sp.Hum. m s**-1"},
+    /* 219 */ {"VU", "Covar V-comp. & U-comp m**2 s**-2"},
+    /* 220 */ {"VV", "St.Dev. of V-comp m s**-1"},
+    /* 221 */ {"WZ", "Covar W-comp. & Geopotential Pa m**2 s**-3"},
+    /* 222 */ {"WT", "Covar W-comp. & Temp. K Pa s**-1"},
+    /* 223 */ {"WQ", "Covar W-comp. & Sp.Hum. Pa s**-1"},
+    /* 224 */ {"WU", "Covar W-comp. & U-comp. Pa m s**-2"},
+    /* 225 */ {"WV", "Covar W-comp. & V-comp. Pa m s**-2"},
+    /* 226 */ {"WW", "St.Dev. of Vertical velocity Pa s**-1"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"TP", "Total precipitation m"},
+    /* 229 */ {"IEWS", "Instantaneous X surface stress N m**-2"},
+    /* 230 */ {"INSS", "Instantaneous Y surface stress N m**-2"},
+    /* 231 */ {"ISHF", "Instantaneous surface Heat Flux W m**-2"},
+    /* 232 */ {"IE", "Instantaneous Moisture Flux (evaporation) kg m**-2 s**-1"},
+    /* 233 */ {"ASQ", "Apparent Surface Humidity kg kg**-1"},
+    /* 234 */ {"LSRH", "Logarithm of surface roughness length for heat. -"},
+    /* 235 */ {"SKT", "Skin Temperature K"},
+    /* 236 */ {"STL4", "Soil temperature level 4 K"},
+    /* 237 */ {"SWL4", "Soil wetness level 4 m"},
+    /* 238 */ {"TSN", "Temperature of snow layer K"},
+    /* 239 */ {"CSF", "Convective snow-fall kg m**-2 s**-1"},
+    /* 240 */ {"LSF", "Large scale snow-fall kg m**-2 s**-1"},
+    /* 241 */ {"CLWC", "Cloud liquid water content kg kg**-1"},
+    /* 242 */ {"CC", "Cloud cover (at given level) (0 - 1)"},
+    /* 243 */ {"FAL", "Forecast albedo -"},
+    /* 244 */ {"FSR", "Forecast surface roughness m"},
+    /* 245 */ {"FLSR", "Forecast logarithm of surface roughness for heat. -"},
+    /* 246 */ {"10WS", "10m. Windspeed (irresp of dir.) m s**-1"},
+    /* 247 */ {"MOFL", "Momentum flux (irresp of dir.) N m**-2"},
+    /* 248 */ {"HSD", "Heaviside (beta) function (0 - 1)"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_170.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_170.c
new file mode 100644
index 00000000..0d51447b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_170.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_170[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"Z", "Geopotential m**2 s**-2"},
+    /* 130 */ {"T", "Temperature K"},
+    /* 131 */ {"U", "U-velocity m s**-1"},
+    /* 132 */ {"V", "V-velocity m s**-1"},
+    /* 133 */ {"var133", "undefined"},
+    /* 134 */ {"var134", "undefined"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"var137", "undefined"},
+    /* 138 */ {"VO", "Vorticity (relative) s**-1"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"SWL1", "Soil wetness level 1 m"},
+    /* 141 */ {"SD", "Snow depth m (of water equivalent)"},
+    /* 142 */ {"var142", "undefined"},
+    /* 143 */ {"var143", "undefined"},
+    /* 144 */ {"var144", "undefined"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"var146", "undefined"},
+    /* 147 */ {"var147", "undefined"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"TSW", "Total soil moisture m"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"MSL", "Mean sea level pressure Pa"},
+    /* 152 */ {"var152", "undefined"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"D", "Divergence s**-1"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"var164", "undefined"},
+    /* 165 */ {"var165", "undefined"},
+    /* 166 */ {"var166", "undefined"},
+    /* 167 */ {"var167", "undefined"},
+    /* 168 */ {"var168", "undefined"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"var170", "undefined"},
+    /* 171 */ {"SWL2", "Soil wetness level 2 m"},
+    /* 172 */ {"var172", "undefined"},
+    /* 173 */ {"var173", "undefined"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"var176", "undefined"},
+    /* 177 */ {"var177", "undefined"},
+    /* 178 */ {"var178", "undefined"},
+    /* 179 */ {"TTR", "Top thermal radiation W m-2"},
+    /* 180 */ {"var180", "undefined"},
+    /* 181 */ {"var181", "undefined"},
+    /* 182 */ {"var182", "undefined"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"SWL3", "Soil wetness level 3 m"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"MX2T", "Max temp at 2m since previous postprocess K"},
+    /* 202 */ {"MN2T", "Min temp at 2m since previous postprocess K"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"var205", "undefined"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"TP", "Total precipitation m"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"var230", "undefined"},
+    /* 231 */ {"var231", "undefined"},
+    /* 232 */ {"var232", "undefined"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ectable_180.c b/wrfv2_fire/external/io_grib1/WGRIB/ectable_180.c
new file mode 100644
index 00000000..1bd53f6e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ectable_180.c
@@ -0,0 +1,261 @@
+#include "cnames.h"
+
+
+struct ParmTable parm_table_ecmwf_180[256] = {
+    /* 0 */ {"var0", "undefined"},
+    /* 1 */ {"var1", "undefined"},
+    /* 2 */ {"var2", "undefined"},
+    /* 3 */ {"var3", "undefined"},
+    /* 4 */ {"var4", "undefined"},
+    /* 5 */ {"var5", "undefined"},
+    /* 6 */ {"var6", "undefined"},
+    /* 7 */ {"var7", "undefined"},
+    /* 8 */ {"var8", "undefined"},
+    /* 9 */ {"var9", "undefined"},
+    /* 10 */ {"var10", "undefined"},
+    /* 11 */ {"var11", "undefined"},
+    /* 12 */ {"var12", "undefined"},
+    /* 13 */ {"var13", "undefined"},
+    /* 14 */ {"var14", "undefined"},
+    /* 15 */ {"var15", "undefined"},
+    /* 16 */ {"var16", "undefined"},
+    /* 17 */ {"var17", "undefined"},
+    /* 18 */ {"var18", "undefined"},
+    /* 19 */ {"var19", "undefined"},
+    /* 20 */ {"var20", "undefined"},
+    /* 21 */ {"var21", "undefined"},
+    /* 22 */ {"var22", "undefined"},
+    /* 23 */ {"var23", "undefined"},
+    /* 24 */ {"var24", "undefined"},
+    /* 25 */ {"var25", "undefined"},
+    /* 26 */ {"var26", "undefined"},
+    /* 27 */ {"var27", "undefined"},
+    /* 28 */ {"var28", "undefined"},
+    /* 29 */ {"var29", "undefined"},
+    /* 30 */ {"var30", "undefined"},
+    /* 31 */ {"var31", "undefined"},
+    /* 32 */ {"var32", "undefined"},
+    /* 33 */ {"var33", "undefined"},
+    /* 34 */ {"var34", "undefined"},
+    /* 35 */ {"var35", "undefined"},
+    /* 36 */ {"var36", "undefined"},
+    /* 37 */ {"var37", "undefined"},
+    /* 38 */ {"var38", "undefined"},
+    /* 39 */ {"var39", "undefined"},
+    /* 40 */ {"var40", "undefined"},
+    /* 41 */ {"var41", "undefined"},
+    /* 42 */ {"var42", "undefined"},
+    /* 43 */ {"var43", "undefined"},
+    /* 44 */ {"var44", "undefined"},
+    /* 45 */ {"var45", "undefined"},
+    /* 46 */ {"var46", "undefined"},
+    /* 47 */ {"var47", "undefined"},
+    /* 48 */ {"var48", "undefined"},
+    /* 49 */ {"var49", "undefined"},
+    /* 50 */ {"var50", "undefined"},
+    /* 51 */ {"var51", "undefined"},
+    /* 52 */ {"var52", "undefined"},
+    /* 53 */ {"var53", "undefined"},
+    /* 54 */ {"var54", "undefined"},
+    /* 55 */ {"var55", "undefined"},
+    /* 56 */ {"var56", "undefined"},
+    /* 57 */ {"var57", "undefined"},
+    /* 58 */ {"var58", "undefined"},
+    /* 59 */ {"var59", "undefined"},
+    /* 60 */ {"var60", "undefined"},
+    /* 61 */ {"var61", "undefined"},
+    /* 62 */ {"var62", "undefined"},
+    /* 63 */ {"var63", "undefined"},
+    /* 64 */ {"var64", "undefined"},
+    /* 65 */ {"var65", "undefined"},
+    /* 66 */ {"var66", "undefined"},
+    /* 67 */ {"var67", "undefined"},
+    /* 68 */ {"var68", "undefined"},
+    /* 69 */ {"var69", "undefined"},
+    /* 70 */ {"var70", "undefined"},
+    /* 71 */ {"var71", "undefined"},
+    /* 72 */ {"var72", "undefined"},
+    /* 73 */ {"var73", "undefined"},
+    /* 74 */ {"var74", "undefined"},
+    /* 75 */ {"var75", "undefined"},
+    /* 76 */ {"var76", "undefined"},
+    /* 77 */ {"var77", "undefined"},
+    /* 78 */ {"var78", "undefined"},
+    /* 79 */ {"var79", "undefined"},
+    /* 80 */ {"var80", "undefined"},
+    /* 81 */ {"var81", "undefined"},
+    /* 82 */ {"var82", "undefined"},
+    /* 83 */ {"var83", "undefined"},
+    /* 84 */ {"var84", "undefined"},
+    /* 85 */ {"var85", "undefined"},
+    /* 86 */ {"var86", "undefined"},
+    /* 87 */ {"var87", "undefined"},
+    /* 88 */ {"var88", "undefined"},
+    /* 89 */ {"var89", "undefined"},
+    /* 90 */ {"var90", "undefined"},
+    /* 91 */ {"var91", "undefined"},
+    /* 92 */ {"var92", "undefined"},
+    /* 93 */ {"var93", "undefined"},
+    /* 94 */ {"var94", "undefined"},
+    /* 95 */ {"var95", "undefined"},
+    /* 96 */ {"var96", "undefined"},
+    /* 97 */ {"var97", "undefined"},
+    /* 98 */ {"var98", "undefined"},
+    /* 99 */ {"var99", "undefined"},
+    /* 100 */ {"var100", "undefined"},
+    /* 101 */ {"var101", "undefined"},
+    /* 102 */ {"var102", "undefined"},
+    /* 103 */ {"var103", "undefined"},
+    /* 104 */ {"var104", "undefined"},
+    /* 105 */ {"var105", "undefined"},
+    /* 106 */ {"var106", "undefined"},
+    /* 107 */ {"var107", "undefined"},
+    /* 108 */ {"var108", "undefined"},
+    /* 109 */ {"var109", "undefined"},
+    /* 110 */ {"var110", "undefined"},
+    /* 111 */ {"var111", "undefined"},
+    /* 112 */ {"var112", "undefined"},
+    /* 113 */ {"var113", "undefined"},
+    /* 114 */ {"var114", "undefined"},
+    /* 115 */ {"var115", "undefined"},
+    /* 116 */ {"var116", "undefined"},
+    /* 117 */ {"var117", "undefined"},
+    /* 118 */ {"var118", "undefined"},
+    /* 119 */ {"var119", "undefined"},
+    /* 120 */ {"var120", "undefined"},
+    /* 121 */ {"var121", "undefined"},
+    /* 122 */ {"var122", "undefined"},
+    /* 123 */ {"var123", "undefined"},
+    /* 124 */ {"var124", "undefined"},
+    /* 125 */ {"var125", "undefined"},
+    /* 126 */ {"var126", "undefined"},
+    /* 127 */ {"var127", "undefined"},
+    /* 128 */ {"var128", "undefined"},
+    /* 129 */ {"Z", "Geopotential (at the surface=orography) m**2 s**-2"},
+    /* 130 */ {"T", "Temperature K"},
+    /* 131 */ {"U", "U-velocity m s**-1"},
+    /* 132 */ {"V", "V-velocity m s**-1"},
+    /* 133 */ {"Q", "Specific humidity kg kg**-1"},
+    /* 134 */ {"SP", "Surface pressure Pa"},
+    /* 135 */ {"var135", "undefined"},
+    /* 136 */ {"var136", "undefined"},
+    /* 137 */ {"TCWV", "Total column water vapour kg m**-2"},
+    /* 138 */ {"VO", "Vorticity (relative) s**-1"},
+    /* 139 */ {"var139", "undefined"},
+    /* 140 */ {"var140", "undefined"},
+    /* 141 */ {"SD", "Snow depth m (of water equivalent)"},
+    /* 142 */ {"LSP", "Large scale precipitation* m"},
+    /* 143 */ {"CP", "Convective precipitation* m"},
+    /* 144 */ {"SF", "Snow fall m(of water equivalent)"},
+    /* 145 */ {"var145", "undefined"},
+    /* 146 */ {"SSHF", "Surface sensible heat flux W m**-2 s"},
+    /* 147 */ {"SLHF", "Surface latent heat flux W m**-2 s"},
+    /* 148 */ {"var148", "undefined"},
+    /* 149 */ {"TSW", "Total soil wetness m"},
+    /* 150 */ {"var150", "undefined"},
+    /* 151 */ {"MSL", "Mean sea level pressure Pa"},
+    /* 152 */ {"var152", "undefined"},
+    /* 153 */ {"var153", "undefined"},
+    /* 154 */ {"var154", "undefined"},
+    /* 155 */ {"D", "Divergence s**-1"},
+    /* 156 */ {"var156", "undefined"},
+    /* 157 */ {"var157", "undefined"},
+    /* 158 */ {"var158", "undefined"},
+    /* 159 */ {"var159", "undefined"},
+    /* 160 */ {"var160", "undefined"},
+    /* 161 */ {"var161", "undefined"},
+    /* 162 */ {"var162", "undefined"},
+    /* 163 */ {"var163", "undefined"},
+    /* 164 */ {"TCC", "Total cloud cover (0 - 1)"},
+    /* 165 */ {"10U", "10 metre u wind component m s**-1"},
+    /* 166 */ {"10V", "10 metre v wind component m s**-1"},
+    /* 167 */ {"2T", "2 metre temperature K"},
+    /* 168 */ {"2D", "2 metre dewpoint temperature K"},
+    /* 169 */ {"var169", "undefined"},
+    /* 170 */ {"var170", "undefined"},
+    /* 171 */ {"var171", "undefined"},
+    /* 172 */ {"LSM", "Land/sea mask (0"},
+    /* 173 */ {"var173", "undefined"},
+    /* 174 */ {"var174", "undefined"},
+    /* 175 */ {"var175", "undefined"},
+    /* 176 */ {"SSR", "Surface solar radiation (net) J m**-2 s"},
+    /* 177 */ {"STR", "Surface thermal radiation (net) J m**-2 s"},
+    /* 178 */ {"TSR", "Top solar radiation (net) J m**-2 s"},
+    /* 179 */ {"TTR", "Top thermal radiation (net) J m**-2 s"},
+    /* 180 */ {"EWSS", "East/West surface stress N m**-2 s"},
+    /* 181 */ {"NSSS", "North/South surface stress N m**-2 s"},
+    /* 182 */ {"E", "Evaporation (surface) m (of water)"},
+    /* 183 */ {"var183", "undefined"},
+    /* 184 */ {"var184", "undefined"},
+    /* 185 */ {"var185", "undefined"},
+    /* 186 */ {"var186", "undefined"},
+    /* 187 */ {"var187", "undefined"},
+    /* 188 */ {"var188", "undefined"},
+    /* 189 */ {"var189", "undefined"},
+    /* 190 */ {"var190", "undefined"},
+    /* 191 */ {"var191", "undefined"},
+    /* 192 */ {"var192", "undefined"},
+    /* 193 */ {"var193", "undefined"},
+    /* 194 */ {"var194", "undefined"},
+    /* 195 */ {"var195", "undefined"},
+    /* 196 */ {"var196", "undefined"},
+    /* 197 */ {"var197", "undefined"},
+    /* 198 */ {"var198", "undefined"},
+    /* 199 */ {"var199", "undefined"},
+    /* 200 */ {"var200", "undefined"},
+    /* 201 */ {"var201", "undefined"},
+    /* 202 */ {"var202", "undefined"},
+    /* 203 */ {"var203", "undefined"},
+    /* 204 */ {"var204", "undefined"},
+    /* 205 */ {"RO", "Runoff (total) m"},
+    /* 206 */ {"var206", "undefined"},
+    /* 207 */ {"var207", "undefined"},
+    /* 208 */ {"var208", "undefined"},
+    /* 209 */ {"var209", "undefined"},
+    /* 210 */ {"var210", "undefined"},
+    /* 211 */ {"var211", "undefined"},
+    /* 212 */ {"var212", "undefined"},
+    /* 213 */ {"var213", "undefined"},
+    /* 214 */ {"var214", "undefined"},
+    /* 215 */ {"var215", "undefined"},
+    /* 216 */ {"var216", "undefined"},
+    /* 217 */ {"var217", "undefined"},
+    /* 218 */ {"var218", "undefined"},
+    /* 219 */ {"var219", "undefined"},
+    /* 220 */ {"var220", "undefined"},
+    /* 221 */ {"var221", "undefined"},
+    /* 222 */ {"var222", "undefined"},
+    /* 223 */ {"var223", "undefined"},
+    /* 224 */ {"var224", "undefined"},
+    /* 225 */ {"var225", "undefined"},
+    /* 226 */ {"var226", "undefined"},
+    /* 227 */ {"var227", "undefined"},
+    /* 228 */ {"var228", "undefined"},
+    /* 229 */ {"var229", "undefined"},
+    /* 230 */ {"var230", "undefined"},
+    /* 231 */ {"var231", "undefined"},
+    /* 232 */ {"var232", "undefined"},
+    /* 233 */ {"var233", "undefined"},
+    /* 234 */ {"var234", "undefined"},
+    /* 235 */ {"var235", "undefined"},
+    /* 236 */ {"var236", "undefined"},
+    /* 237 */ {"var237", "undefined"},
+    /* 238 */ {"var238", "undefined"},
+    /* 239 */ {"var239", "undefined"},
+    /* 240 */ {"var240", "undefined"},
+    /* 241 */ {"var241", "undefined"},
+    /* 242 */ {"var242", "undefined"},
+    /* 243 */ {"var243", "undefined"},
+    /* 244 */ {"var244", "undefined"},
+    /* 245 */ {"var245", "undefined"},
+    /* 246 */ {"var246", "undefined"},
+    /* 247 */ {"var247", "undefined"},
+    /* 248 */ {"var248", "undefined"},
+    /* 249 */ {"var249", "undefined"},
+    /* 250 */ {"var250", "undefined"},
+    /* 251 */ {"var251", "undefined"},
+    /* 252 */ {"var252", "undefined"},
+    /* 253 */ {"var253", "undefined"},
+    /* 254 */ {"var254", "undefined"},
+    /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ensemble.c b/wrfv2_fire/external/io_grib1/WGRIB/ensemble.c
new file mode 100644
index 00000000..5e2a5f47
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ensemble.c
@@ -0,0 +1,103 @@
+#include 
+#include 
+#include 
+#include 
+#include "grib.h"
+#include "pds4.h"
+#include "cnames.h"
+
+/*
+ * ensemble.c   v0.1 wesley ebisuzaki
+ *
+ * prints ensemble meta-data
+ *
+ * only for NCEP and ECMWF
+ *
+ * output format:
+ *
+ *       ECMWF
+ *  ens=n/N:       n:  0=ctl, +/-ve
+ *                 N:  total number of members
+ *
+ *       NCEP
+ *  ens=n/type:    n:  0=ctl, +/-ve, CLUST, PROD/
+ *                 type: Mn, WtdMn, SDev, NSDev
+ */
+
+extern int ncep_ens;
+
+void ensemble(unsigned char *pds, int mode) {
+
+    int pdslen;
+    unsigned char ctmp;
+    char char_end;
+
+    pdslen = PDS_LEN(pds);
+    char_end = mode == 2 ? ' ' : ':';
+
+    if ((PDS_Center(pds) == NMC || ncep_ens) && pdslen >= 45 && pds[40] == 1) {
+
+	/* control run */
+
+	if (pds[41] == 1) {
+	    if (mode != 2) {
+		printf("ens%c0:", pds[42] == 1 ? '+' : '-');
+	    }
+	    else {
+		printf("%s-res_ens_control ", pds[42] == 1 ? "hi" : "low");
+	    }
+	}
+
+	/* perturbation run */
+
+	else if (pds[41] == 2 || pds[41] == 3) {
+	    if (mode != 2) {
+	        printf("ens%c%d:", pds[41] == 3 ? '+' : '-', pds[42]);
+	    }
+	    else {
+		printf("ens_perturbation=%c%d ",pds[41] == 3 ? '+' : '-', 
+		    pds[42]);
+	    }
+	}
+
+	/* ensemble mean */
+
+	else if (pds[41] == 5) {
+	    /* makes no sense to say "ensemble mean" for prob forecasts */
+            if (PDS_PARAM(pds) != 191 && PDS_PARAM(pds) != 192) {
+	        if (mode != 2 || pdslen < 61) {
+		    printf("ens-mean%c", char_end);
+		}
+		else {
+		    printf("ensemble-mean(%d members) ",pds[60]);
+		}
+	    }
+	}
+
+	/* other case .. debug code */
+
+	else {
+		printf("ens %d/%d/%d/%d:", pds[41],pds[42],pds[43],pds[44]);
+	}
+
+	/* NCEP probability limits */
+
+	if ((PDS_PARAM(pds) == 191 || PDS_PARAM(pds) == 192) && pdslen >= 47) {
+	    ctmp = PDS_PARAM(pds);
+	    PDS_PARAM(pds) = pds[45];
+	    if (pds[46] == 1 && pdslen >= 51) {
+		printf("prob(%s<%f)%c", k5toa(pds), ibm2flt(pds+47),char_end);
+	    }
+	    else if (pds[46] == 2 && pdslen >= 54) {
+		printf("prob(%s>%f)%c", k5toa(pds), ibm2flt(pds+51), char_end);
+	    }
+	    else if (pds[46] == 3 && pdslen >= 54) {
+		printf("prob(%f<%s<%f)%c", ibm2flt(pds+47), k5toa(pds), 
+			ibm2flt(pds+51), char_end);
+	    }
+            PDS_PARAM(pds) = ctmp;
+	}
+
+    }
+    /* ECMWF test should go here */
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/flt2ieee.c b/wrfv2_fire/external/io_grib1/WGRIB/flt2ieee.c
new file mode 100644
index 00000000..abb63979
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/flt2ieee.c
@@ -0,0 +1,67 @@
+#include 
+#include 
+#include 
+#include 
+#include "grib.h"
+
+/*
+ * convert a float to an ieee single precision number v1.1
+ * (big endian)
+ *                      Wesley Ebisuzaki
+ *
+ * bugs: doesn't handle subnormal numbers
+ * bugs: assumes length of integer >= 25 bits
+ */
+
+int flt2ieee(float x, unsigned char *ieee) {
+
+	int sign, exp;
+        unsigned int umant;
+	double mant;
+
+	if (x == 0.0) {
+		ieee[0] = ieee[1] = ieee[2] = ieee[3] = 0;
+		return 0;
+	}
+
+	/* sign bit */
+	if (x < 0.0) {
+		sign = 128;
+		x = -x;
+	}
+	else sign = 0;
+	mant = frexp((double) x, &exp);
+
+        /* 2^24 = 16777216 */
+
+	umant = mant * 16777216 + 0.5;
+	if (umant >= 16777216) {
+            umant = umant / 2;
+            exp++;
+        }
+        /* bit 24 should be a 1 .. not used in ieee format */
+
+	exp = exp - 1 + 127;
+
+	if (exp < 0) {
+		/* signed zero */
+		ieee[0] = sign;
+		ieee[1] = ieee[2] = ieee[3] = 0;
+		return 0;
+	}
+	if (exp > 255) {
+		/* signed infinity */
+		ieee[0] = sign + 127;
+		ieee[1] = 128;
+                ieee[2] = ieee[3] = 0;
+                return 0;
+	}
+	/* normal number */
+
+	ieee[0] = sign + (exp >> 1);
+
+        ieee[3] = umant & 255;
+        ieee[2] = (umant >> 8) & 255;
+        ieee[1] = ((exp & 1) << 7) + ((umant >> 16) & 127);
+	return 0;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/gds.h b/wrfv2_fire/external/io_grib1/WGRIB/gds.h
new file mode 100644
index 00000000..d758bc81
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/gds.h
@@ -0,0 +1,170 @@
+/* version 1.4.3 of grib headers  w. ebisuzaki */
+/* this version is incomplete */
+/* 5/00 - dx/dy or di/dj controlled by bit 1 of resolution byte */
+/* 8/00 - dx/dy or di/dj for polar and lambert not controlled by res. byte */
+/* Added headers for the triangular grid of the gme model of DWD
+         Helmut P. Frank, 13.09.2001 */
+/* Clean up of triangular grid properties access and added spectral information
+         Luis Kornblueh, 27.03.2002 */
+
+#ifndef INT3
+#define INT3(a,b,c) ((1-(int) ((unsigned) (a & 0x80) >> 6)) * (int) (((a & 127) << 16)+(b<<8)+c))
+#endif
+#ifndef INT2
+#define INT2(a,b)   ((1-(int) ((unsigned) (a & 0x80) >> 6)) * (int) (((a & 127) << 8) + b))
+#endif
+
+#ifndef UINT4
+#define UINT4(a,b,c,d) ((int) ((a << 24) + (b << 16) + (c << 8) + (d)))
+#endif
+
+#ifndef UINT3
+#define UINT3(a,b,c) ((int) ((a << 16) + (b << 8) + (c)))
+#endif
+
+#ifndef UINT2
+#define UINT2(a,b) ((int) ((a << 8) + (b)))
+#endif
+
+
+#define GDS_Len1(gds)		(gds[0])
+#define GDS_Len2(gds)		(gds[1])
+#define GDS_Len3(gds)		(gds[2])
+#define GDS_LEN(gds)		((int) ((gds[0]<<16)+(gds[1]<<8)+gds[2]))
+
+#define GDS_NV(gds)		(gds[3])
+#define GDS_DataType(gds)	(gds[5])
+
+#define GDS_LatLon(gds)		(gds[5] == 0)
+#define GDS_Mercator(gds)	(gds[5] == 1)
+#define GDS_Gnomonic(gds)	(gds[5] == 2)
+#define GDS_Lambert(gds)	(gds[5] == 3)
+#define GDS_Gaussian(gds)	(gds[5] == 4)
+#define GDS_Polar(gds)		(gds[5] == 5)
+#define GDS_RotLL(gds)		(gds[5] == 10)
+#define GDS_Harmonic(gds)	(gds[5] == 50)
+#define GDS_Triangular(gds)	(gds[5] == 192)
+#define GDS_ssEgrid(gds)	(gds[5] == 201)	/* semi-staggered E grid */
+#define GDS_fEgrid(gds)		(gds[5] == 202) /* filled E grid */
+#define GDS_ss2dEgrid(gds)	(gds[5] == 203) /* semi-staggered E grid 2 d*/
+
+#define GDS_has_dy(mode)	((mode) & 128)
+#define GDS_LatLon_nx(gds)	((int) ((gds[6] << 8) + gds[7]))
+#define GDS_LatLon_ny(gds)	((int) ((gds[8] << 8) + gds[9]))
+#define GDS_LatLon_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_LatLon_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_LatLon_mode(gds)	(gds[16])
+#define GDS_LatLon_La2(gds)	INT3(gds[17],gds[18],gds[19])
+#define GDS_LatLon_Lo2(gds)	INT3(gds[20],gds[21],gds[22])
+
+#define GDS_LatLon_dx(gds)      (gds[16] & 128 ? INT2(gds[23],gds[24]) : 0)
+#define GDS_LatLon_dy(gds)      (gds[16] & 128 ? INT2(gds[25],gds[26]) : 0)
+#define GDS_Gaussian_nlat(gds)  ((gds[25]<<8)+gds[26])
+
+#define GDS_LatLon_scan(gds)	(gds[27])
+
+#define GDS_Polar_nx(gds)	((gds[6] << 8) + gds[7])
+#define GDS_Polar_ny(gds)	((gds[8] << 8) + gds[9])
+#define GDS_Polar_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_Polar_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_Polar_mode(gds)	(gds[16])
+#define GDS_Polar_Lov(gds)	INT3(gds[17],gds[18],gds[19])
+#define GDS_Polar_scan(gds)	(gds[27])
+#define GDS_Polar_Dx(gds)	INT3(gds[20], gds[21], gds[22])
+#define GDS_Polar_Dy(gds)	INT3(gds[23], gds[24], gds[25])
+#define GDS_Polar_pole(gds)	((gds[26] & 128) == 128)
+
+#define GDS_Lambert_nx(gds)	((gds[6] << 8) + gds[7])
+#define GDS_Lambert_ny(gds)	((gds[8] << 8) + gds[9])
+#define GDS_Lambert_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_Lambert_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_Lambert_mode(gds)	(gds[16])
+#define GDS_Lambert_Lov(gds)	INT3(gds[17],gds[18],gds[19])
+#define GDS_Lambert_dx(gds)	INT3(gds[20],gds[21],gds[22])
+#define GDS_Lambert_dy(gds)	INT3(gds[23],gds[24],gds[25])
+#define GDS_Lambert_NP(gds)	((gds[26] & 128) == 0)
+#define GDS_Lambert_scan(gds)   (gds[27])
+#define GDS_Lambert_Latin1(gds)	INT3(gds[28],gds[29],gds[30])
+#define GDS_Lambert_Latin2(gds)	INT3(gds[31],gds[32],gds[33])
+#define GDS_Lambert_LatSP(gds)	INT3(gds[34],gds[35],gds[36])
+#define GDS_Lambert_LonSP(gds)	INT3(gds[37],gds[37],gds[37])
+
+#define GDS_ssEgrid_n(gds)	UINT2(gds[6],gds[7])
+#define GDS_ssEgrid_n_dum(gds)  UINT2(gds[8],gds[9])
+#define GDS_ssEgrid_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_ssEgrid_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_ssEgrid_mode(gds)	(gds[16])
+#define GDS_ssEgrid_La2(gds)	UINT3(gds[17],gds[18],gds[19])
+#define GDS_ssEgrid_Lo2(gds)	UINT3(gds[20],gds[21],gds[22])
+#define GDS_ssEgrid_di(gds)	(gds[16] & 128 ? INT2(gds[23],gds[24]) : 0)
+#define GDS_ssEgrid_dj(gds)	(gds[16] & 128 ? INT2(gds[25],gds[26]) : 0)
+#define GDS_ssEgrid_scan(gds)	(gds[27])
+
+#define GDS_fEgrid_n(gds)	UINT2(gds[6],gds[7])
+#define GDS_fEgrid_n_dum(gds)   UINT2(gds[8],gds[9])
+#define GDS_fEgrid_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_fEgrid_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_fEgrid_mode(gds)	(gds[16])
+#define GDS_fEgrid_La2(gds)	UINT3(gds[17],gds[18],gds[19])
+#define GDS_fEgrid_Lo2(gds)	UINT3(gds[20],gds[21],gds[22])
+#define GDS_fEgrid_di(gds)	(gds[16] & 128 ? INT2(gds[23],gds[24]) : 0)
+#define GDS_fEgrid_dj(gds)	(gds[16] & 128 ? INT2(gds[25],gds[26]) : 0)
+#define GDS_fEgrid_scan(gds)	(gds[27])
+
+#define GDS_ss2dEgrid_nx(gds)     UINT2(gds[6],gds[7])
+#define GDS_ss2dEgrid_ny(gds)     UINT2(gds[8],gds[9])
+#define GDS_ss2dEgrid_La1(gds)    INT3(gds[10],gds[11],gds[12])
+#define GDS_ss2dEgrid_Lo1(gds)    INT3(gds[13],gds[14],gds[15])
+#define GDS_ss2dEgrid_mode(gds)   (gds[16])
+#define GDS_ss2dEgrid_La2(gds)    INT3(gds[17],gds[18],gds[19])
+#define GDS_ss2dEgrid_Lo2(gds)    INT3(gds[20],gds[21],gds[22])
+#define GDS_ss2dEgrid_di(gds)     (gds[16] & 128 ? INT2(gds[23],gds[24]) : 0)
+#define GDS_ss2dEgrid_dj(gds)     (gds[16] & 128 ? INT2(gds[25],gds[26]) : 0)
+#define GDS_ss2dEgrid_scan(gds)   (gds[27])
+
+
+#define GDS_Merc_nx(gds)	UINT2(gds[6],gds[7])
+#define GDS_Merc_ny(gds)	UINT2(gds[8],gds[9])
+#define GDS_Merc_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_Merc_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_Merc_mode(gds)	(gds[16])
+#define GDS_Merc_La2(gds)	INT3(gds[17],gds[18],gds[19])
+#define GDS_Merc_Lo2(gds)	INT3(gds[20],gds[21],gds[22])
+#define GDS_Merc_Latin(gds)	INT3(gds[23],gds[24],gds[25])
+#define GDS_Merc_scan(gds)	(gds[27])
+#define GDS_Merc_dx(gds)        (gds[16] & 128 ? INT3(gds[28],gds[29],gds[30]) : 0)
+#define GDS_Merc_dy(gds)        (gds[16] & 128 ? INT3(gds[31],gds[32],gds[33]) : 0)
+
+/* rotated Lat-lon grid */
+
+#define GDS_RotLL_nx(gds)	UINT2(gds[6],gds[7])
+#define GDS_RotLL_ny(gds)	UINT2(gds[8],gds[9])
+#define GDS_RotLL_La1(gds)	INT3(gds[10],gds[11],gds[12])
+#define GDS_RotLL_Lo1(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_RotLL_mode(gds)	(gds[16])
+#define GDS_RotLL_La2(gds)	INT3(gds[17],gds[18],gds[19])
+#define GDS_RotLL_Lo2(gds)	INT3(gds[20],gds[21],gds[22])
+#define GDS_RotLL_dx(gds)       (gds[16] & 128 ? INT2(gds[23],gds[24]) : 0)
+#define GDS_RotLL_dy(gds)       (gds[16] & 128 ? INT2(gds[25],gds[26]) : 0)
+#define GDS_RotLL_scan(gds)	(gds[27])
+#define GDS_RotLL_LaSP(gds)	INT3(gds[32],gds[33],gds[34])
+#define GDS_RotLL_LoSP(gds)	INT3(gds[35],gds[36],gds[37])
+#define GDS_RotLL_RotAng(gds)	ibm2flt(&(gds[38]))
+
+/* Triangular grid of DWD */
+#define GDS_Triangular_ni2(gds)	INT2(gds[6],gds[7])
+#define GDS_Triangular_ni3(gds)	INT2(gds[8],gds[9])
+#define GDS_Triangular_ni(gds)	INT3(gds[13],gds[14],gds[15])
+#define GDS_Triangular_nd(gds)  INT3(gds[10],gds[11],gds[12])
+
+/* Harmonics data */
+#define GDS_Harmonic_nj(gds)     ((int) ((gds[6] << 8) + gds[7])) 
+#define GDS_Harmonic_nk(gds)     ((int) ((gds[8] << 8) + gds[9])) 
+#define GDS_Harmonic_nm(gds)     ((int) ((gds[10] << 8) + gds[11])) 
+#define GDS_Harmonic_type(gds)   (gds[12])
+#define GDS_Harmonic_mode(gds)   (gds[13])
+
+/* index of NV and PV */
+#define GDS_PV(gds)		((gds[3] == 0) ? -1 : (int) gds[4] - 1)
+#define GDS_PL(gds)		((gds[4] == 255) ? -1 : (int) gds[3] * 4 + (int) gds[4] - 1)
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/gds_grid.c b/wrfv2_fire/external/io_grib1/WGRIB/gds_grid.c
new file mode 100644
index 00000000..e339c965
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/gds_grid.c
@@ -0,0 +1,162 @@
+#include 
+#include 
+#include "grib.h"
+#include "bds.h"
+#include "gds.h"
+
+/*
+ * get grid size from GDS
+ *
+ * added calculation of nxny of spectral data and clean up of triangular
+ * grid nnxny calculation     l. kornblueh 
+ * 7/25/03 wind fix Dusan Jovic
+ * 9/17/03 fix scan mode
+ */
+
+int GDS_grid(unsigned char *gds, unsigned char *bds, int *nx, int *ny, 
+             long int *nxny) {
+
+    int i, d, ix, iy, pl;
+    long int isum;
+
+    *nx = ix = GDS_LatLon_nx(gds);
+    *ny = iy = GDS_LatLon_ny(gds);
+    *nxny = ix * iy;
+
+    /* thin grid */
+
+    if (GDS_Gaussian(gds) || GDS_LatLon(gds)) {
+	if (ix == 65535) {
+	    *nx = -1;
+	    /* reduced grid */
+	    isum = 0;
+	    pl = GDS_PL(gds);
+	    for (i = 0; i < iy; i++) {
+		isum += gds[pl+i*2]*256 + gds[pl+i*2+1];
+	    }
+	    *nxny = isum;
+	}
+	return 0;
+    }
+    if (GDS_Triangular(gds)) {
+        i = GDS_Triangular_ni(gds);
+        d = GDS_Triangular_nd(gds);
+	*nx = *nxny = d * (i + 1) * (i + 1);
+        *ny = 1;
+	return 0;
+    }
+    if (GDS_Harmonic(gds)) {
+        /* this code assumes j, k, m are consistent with bds */
+        *nx = *nxny = (8*(BDS_LEN(bds)-15)-BDS_UnusedBits(bds))/
+		BDS_NumBits(bds)+1;
+           if ((8*(BDS_LEN(bds)-15)-BDS_UnusedBits(bds)) % BDS_NumBits(bds)) {
+	       fprintf(stderr,"inconsistent harmonic BDS\n");
+           }
+        *ny = 1;
+    }
+    return 0;
+}
+
+#define NCOL 15
+void GDS_prt_thin_lon(unsigned char *gds) {
+    int iy, i, col, pl;
+
+    iy = GDS_LatLon_ny(gds);
+    iy = (iy + 1) / 2;
+    iy = GDS_LatLon_ny(gds);
+
+    if ((pl = GDS_PL(gds)) == -1) {
+	fprintf(stderr,"\nprogram error: GDS_prt_thin\n");
+	return;
+    }
+    for (col = i = 0; i < iy; i++) {
+	if (col == 0) printf("   ");
+	printf("%5d", (gds[pl+i*2] << 8) + gds[pl+i*2+1]);
+	col++;
+	if (col == NCOL) {
+	    col = 0;
+	    printf("\n");
+	}
+    }
+    if (col != 0) printf("\n");
+}
+
+/*
+ * prints out wind rel to grid or earth
+ */
+
+static char *scan_mode[8] = {
+	"WE:NS",
+	"NS:WE",
+
+	"WE:SN",
+	"SN:WE",
+
+        "EW:NS",
+	"NS:EW",
+
+	"EW:SN",
+	"SN:EW" };
+
+
+void GDS_winds(unsigned char *gds, int verbose) {
+    int scan = -1, mode = -1;
+
+    if (gds != NULL) {
+        if (GDS_LatLon(gds)) {
+	    scan = GDS_LatLon_scan(gds);
+	    mode = GDS_LatLon_mode(gds);
+	}
+	else if (GDS_Mercator(gds)) {
+	    scan =GDS_Merc_scan(gds);
+	    mode =GDS_Merc_mode(gds);
+	}
+	/* else if (GDS_Gnomonic(gds)) { */
+	else if (GDS_Lambert(gds)) {
+	    scan = GDS_Lambert_scan(gds);
+	    mode = GDS_Lambert_mode(gds);
+	}
+	else if (GDS_Gaussian(gds)) {
+	    scan = GDS_LatLon_scan(gds);
+	    mode = GDS_LatLon_mode(gds);
+	}
+	else if (GDS_Polar(gds)) {
+	    scan = GDS_Polar_scan(gds);
+	    mode = GDS_Polar_mode(gds);
+	}
+	else if (GDS_RotLL(gds)) {
+	    scan = GDS_RotLL_scan(gds);
+	    mode = GDS_RotLL_mode(gds);
+	}
+	/* else if (GDS_Triangular(gds)) { */
+	else if (GDS_ssEgrid(gds)) {
+	    scan = GDS_ssEgrid_scan(gds);
+	    mode = GDS_ssEgrid_mode(gds);
+	}
+	else if (GDS_fEgrid(gds)) {
+	    scan = GDS_fEgrid_scan(gds);
+	    mode = GDS_fEgrid_mode(gds);
+	}
+	else if (GDS_ss2dEgrid(gds)) {
+	    scan = GDS_ss2dEgrid_scan(gds);
+	    mode = GDS_ss2dEgrid_mode(gds);
+	}
+    }
+    if (verbose == 1) {
+	if (mode != -1) {
+	    if (mode & 8) printf("winds in grid direction:");
+	    else printf("winds are N/S:"); 
+	}
+    }
+    else if (verbose == 2) {
+	if (scan != -1) {
+	    printf(" scan: %s", scan_mode[(scan >> 5) & 7]);
+        }
+	if (mode != -1) {
+	    if (mode & 8) printf(" winds(grid) ");
+	    else printf(" winds(N/S) "); 
+	}
+    }
+}
+
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/grib.h b/wrfv2_fire/external/io_grib1/WGRIB/grib.h
new file mode 100644
index 00000000..90a5574a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/grib.h
@@ -0,0 +1,44 @@
+enum Def_NCEP_Table {rean, opn, rean_nowarn, opn_nowarn};
+
+unsigned char *seek_grib(FILE *file, long *pos, long *len_grib, 
+        unsigned char *buffer, unsigned int buf_len);
+
+int read_grib(FILE *file, long pos, long len_grib, unsigned char *buffer);
+
+double ibm2flt(unsigned char *ibm);
+ 
+void BDS_unpack(float *flt, unsigned char *bds, unsigned char *bitmap,
+        int n_bits, int n, double ref, double scale);
+
+double int_power(double x, int y);
+
+int flt2ieee(float x, unsigned char *ieee);
+
+int wrtieee(float *array, int n, int header, FILE *output);
+int wrtieee_header(unsigned int n, FILE *output);
+
+void levels(int, int, int);
+ 
+void PDStimes(int time_range, int p1, int p2, int time_unit);
+
+int missing_points(unsigned char *bitmap, int n);
+
+void EC_ext(unsigned char *pds, char *prefix, char *suffix);
+
+int GDS_grid(unsigned char *gds, unsigned char *bds, int *nx, int *ny, 
+             long int *nxny);
+
+void GDS_prt_thin_lon(unsigned char *gds);
+
+void GDS_winds(unsigned char *gds, int verbose);
+
+int PDS_date(unsigned char *pds, int option, int verf_time);
+
+int add_time(int *year, int *month, int *day, int *hour, int dtime, int unit);
+
+int verf_time(unsigned char *pds, int *year, int *month, int *day, int *hour);
+
+void print_pds(unsigned char *pds, int print_PDS, int print_PDS10, int verbose);
+void print_gds(unsigned char *gds, int print_GDS, int print_GDS10, int verbose);
+
+void ensemble(unsigned char *pds, int mode);
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/gribtable.c b/wrfv2_fire/external/io_grib1/WGRIB/gribtable.c
new file mode 100644
index 00000000..561465b0
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/gribtable.c
@@ -0,0 +1,131 @@
+#include 
+#include 
+#include 
+#include 
+#include "cnames.h"
+
+#define START -1
+
+static int user_center = 0, user_subcenter = 0, user_ptable = 0;
+static enum {filled, not_found, not_checked, no_file, init} status = init;
+
+struct ParmTable parm_table_user[256];
+
+/*
+ * sets up user parameter table
+ */
+
+int setup_user_table(int center, int subcenter, int ptable) {
+
+    int i, j, c0, c1, c2;
+    static FILE *input;
+    static int file_open = 0;
+    char *filename, line[300];
+
+    if (status == init) {
+	for (i = 0; i < 256; i++) {
+	    parm_table_user[i].name = parm_table_user[i].comment = NULL;
+	}
+	status = not_checked;
+    }
+
+    if (status == no_file) return 0;
+
+    if ((user_center == -1 || center == user_center) &&
+	    (user_subcenter == -1 || subcenter == user_subcenter) &&
+	    (user_ptable == -1 || ptable == user_ptable)) {
+
+	if (status == filled) return 1;
+	if (status == not_found) return 0;
+    }
+
+    /* open gribtab file if not open */
+
+    if (!file_open) {
+        filename = getenv("GRIBTAB");
+        if (filename == NULL) filename = getenv("gribtab");
+        if (filename == NULL) filename = "gribtab";
+
+        if ((input = fopen(filename,"r")) == NULL) {
+            status = no_file;
+            return 0;
+        }
+	file_open = 1;
+    }
+    else {
+	rewind(input);
+    }
+
+    user_center = center;
+    user_subcenter = subcenter;
+    user_ptable = ptable;
+
+    /* scan for center & subcenter and ptable */
+    for (;;) {
+        if (fgets(line, 299, input) == NULL) {
+	    status = not_found;
+            return 0;
+        }
+	if (atoi(line) != START) continue;
+	i = sscanf(line,"%d:%d:%d:%d", &j, ¢er, &subcenter, &ptable);
+        if (i != 4) {
+	    fprintf(stderr,"illegal gribtab center/subcenter/ptable line: %s\n", line);
+            continue;
+        }
+	if ((center == -1 || center == user_center) &&
+	    (subcenter == -1 || subcenter == user_subcenter) &&
+	    (ptable == -1 || ptable == user_ptable)) break;
+    }
+
+    user_center = center;
+    user_subcenter = subcenter;
+    user_ptable = ptable;
+
+    /* free any used memory */
+    if (parm_table_user[i].name != NULL) {
+        for (i = 0; i < 256; i++) {
+	    free(parm_table_user[i].name);
+            free(parm_table_user[i].comment);
+        }
+    }
+
+    /* read definitions */
+
+    for (;;) {
+        if (fgets(line, 299, input) == NULL) break;
+	if ((i = atoi(line)) == START) break;
+	line[299] = 0;
+
+	/* find the colons and end-of-line */
+	for (c0 = 0; line[c0] != ':' && line[c0] != 0; c0++) ;
+        /* skip blank lines */
+        if (line[c0] == 0) continue;
+
+	for (c1 = c0 + 1; line[c1] != ':' && line[c1] != 0; c1++) ;
+	c2 = strlen(line);
+        if (line[c2-1] == '\n') line[--c2] = '\0';
+        if (c2 <= c1) {
+	    fprintf(stderr,"illegal gribtab line:%s\n", line);
+	    continue;
+	}
+	line[c0] = 0;
+	line[c1] = 0;
+
+	parm_table_user[i].name = (char *) malloc(c1 - c0);
+	parm_table_user[i].comment = (char *) malloc(c2 - c1);
+	strcpy(parm_table_user[i].name, line+c0+1);
+	strcpy(parm_table_user[i].comment, line+c1+1);
+    }
+
+    /* now to fill in undefined blanks */
+    for (i = 0; i < 255; i++) {
+	if (parm_table_user[i].name == NULL) {
+	    parm_table_user[i].name = (char *) malloc(7);
+	    sprintf(parm_table_user[i].name, "var%d", i);
+	    parm_table_user[i].comment = (char *) malloc(strlen("undefined")+1);
+	    strcpy(parm_table_user[i].comment, "undefined");
+        }
+    }
+    status = filled;
+    return 1;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ibm2flt.c b/wrfv2_fire/external/io_grib1/WGRIB/ibm2flt.c
new file mode 100644
index 00000000..769bd1de
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ibm2flt.c
@@ -0,0 +1,43 @@
+#include 
+#include 
+
+/* ibm2flt       wesley ebisuzaki
+ *
+ * v1.1 .. faster
+ * v1.1 .. if mant == 0 -> quick return
+ *
+ */
+
+
+double ibm2flt(unsigned char *ibm) {
+
+	int positive, power;
+	unsigned int abspower;
+	long int mant;
+	double value, exp;
+
+	mant = (ibm[1] << 16) + (ibm[2] << 8) + ibm[3];
+        if (mant == 0) return 0.0;
+
+	positive = (ibm[0] & 0x80) == 0;
+	power = (int) (ibm[0] & 0x7f) - 64;
+	abspower = power > 0 ? power : -power;
+
+
+	/* calc exp */
+	exp = 16.0;
+	value = 1.0;
+	while (abspower) {
+		if (abspower & 1) {
+			value *= exp;
+		}
+		exp = exp * exp;
+		abspower >>= 1;
+	}
+
+	if (power < 0) value = 1.0 / value;
+	value = value * mant / 16777216.0;
+	if (positive == 0) value = -value;
+	return value;
+}
+	
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/intpower.c b/wrfv2_fire/external/io_grib1/WGRIB/intpower.c
new file mode 100644
index 00000000..43112ed1
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/intpower.c
@@ -0,0 +1,31 @@
+#include 
+#include 
+
+/*
+ * w. ebisuzaki
+ *
+ *  return x**y
+ *
+ *
+ *  input: double x
+ *	   int y
+ */
+double int_power(double x, int y) {
+
+	double value;
+
+	if (y < 0) {
+		y = -y;
+		x = 1.0 / x;
+	}
+	value = 1.0;
+
+	while (y) {
+		if (y & 1) {
+			value *= x;
+		}
+		x = x * x;
+		y >>= 1;
+	}
+	return value;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/levels.c b/wrfv2_fire/external/io_grib1/WGRIB/levels.c
new file mode 100644
index 00000000..349ae1bb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/levels.c
@@ -0,0 +1,178 @@
+#include 
+#include 
+#include "pds4.h"
+#include "grib.h"
+
+/* wesley ebisuzaki v1.0
+ *
+ * levels.c
+ *
+ * prints out a simple description of kpds6, kpds7
+ *    (level/layer data)
+ *  kpds6 = octet 10 of the PDS
+ *  kpds7 = octet 11 and 12 of the PDS
+ *    (kpds values are from NMC's grib routines)
+ *  center = PDS_Center(pds) .. NMC, ECMWF, etc
+ *
+ * the description of the levels is 
+ *   (1) incomplete
+ *   (2) include some NMC-only values (>= 200?)
+ *
+ * v1.1 wgrib v1.7.3.1 updated with new levels
+ * v1.2 added new level and new parameter
+ * v1.2.1 modified level 117 pv units
+ * v1.2.2 corrected level 141
+ * v1.2.3 fixed layer 206 (was 205)
+ */
+
+void levels(int kpds6, int kpds7, int center) {
+
+	int o11, o12;
+
+	/* octets 11 and 12 */
+	o11 = kpds7 / 256;
+	o12 = kpds7 % 256;
+
+
+	switch (kpds6) {
+
+	case 1: printf("sfc");
+		break;
+	case 2: printf("cld base");
+		break;
+	case 3: printf("cld top");
+		break;
+	case 4: printf("0C isotherm");
+		break;
+	case 5: printf("cond lev");
+		break;
+	case 6: printf("max wind lev");
+		break;
+	case 7: printf("tropopause");
+		break;
+	case 8: printf("nom. top");
+		break;
+	case 9: printf("sea bottom");
+		break;
+	case 200:
+	case 10: printf("atmos col");
+		break;
+
+	case 12:
+	case 212: printf("low cld bot");
+		break;
+	case 13:
+	case 213: printf("low cld top");
+		break;
+	case 14:
+	case 214: printf("low cld lay");
+		break;
+	case 22:
+	case 222: printf("mid cld bot");
+		break;
+	case 23:
+	case 223: printf("mid cld top");
+		break;
+	case 24:
+	case 224: printf("mid cld lay");
+		break;
+	case 32:
+	case 232: printf("high cld bot");
+		break;
+	case 33:
+	case 233: printf("high cld top");
+		break;
+	case 34:
+	case 234: printf("high cld lay");
+		break;
+
+	case 201: printf("ocean column");
+		break;
+	case 204: printf("high trop freezing lvl");
+		break;
+	case 206: printf("grid-scale cld bot");
+		break;
+	case 207: printf("grid-scale cld top");
+		break;
+	case 209: printf("bndary-layer cld bot");
+		break;
+	case 210: printf("bndary-layer cld top");
+		break;
+	case 211: printf("bndary-layer cld layer");
+		break;
+	case 242: printf("convect-cld bot");
+		break;
+	case 243: printf("convect-cld top");
+		break;
+	case 244: printf("convect-cld layer");
+		break;
+	case 246: printf("max e-pot-temp lvl");
+		break;
+	case 247: printf("equilibrium lvl");
+		break;
+	case 248: printf("shallow convect-cld bot");
+		break;
+	case 249: printf("shallow convect-cld top");
+		break;
+	case 251: printf("deep convect-cld bot");
+		break;
+	case 252: printf("deep convect-cld top");
+		break;
+
+	case 100: printf("%d mb",kpds7);
+	 	break;
+	case 101: printf("%d-%d mb",o11*10,o12*10);
+	 	break;
+	case 102: printf("MSL");
+	 	break;
+	case 103: printf("%d m above MSL",kpds7);
+	 	break;
+	case 104: printf("%d-%d m above msl",o11*100,o12*100);
+	 	break;
+	case 105: printf("%d m above gnd",kpds7);
+	 	break;
+	case 106: printf("%d-%d m above gnd",o11*100,o12*100);
+	 	break;
+	case 107: printf("sigma=%.4f",kpds7/10000.0);
+	 	break;
+	case 108: printf("sigma %.2f-%.2f",o11/100.0,o12/100.0);
+	 	break;
+	case 109: printf("hybrid lev %d",kpds7);
+	 	break;
+	case 110: printf("hybrid %d-%d",o11,o12);
+	 	break;
+	case 111: printf("%d cm down",kpds7);
+	 	break;
+	case 112: printf("%d-%d cm down",o11,o12);
+	 	break;
+	case 113: printf("%dK",kpds7);
+	 	break;
+	case 114: printf("%d-%dK",475-o11,475-o12);
+	 	break;
+	case 115: printf("%d mb above gnd",kpds7);
+	 	break;
+	case 116: printf("%d-%d mb above gnd",o11,o12);
+	 	break;
+	case 117: printf("%d pv units",INT2(o11,o12)); /* units are suspect */
+	 	break;
+	case 119: printf("%.5f (ETA level)",kpds7/10000.0);
+	 	break;
+	case 120: printf("%.2f-%.2f (ETA levels)",o11/100.0,o12/100.0);
+	 	break;
+	case 121: printf("%d-%d mb",1100-o11,1100-o12);
+	 	break;
+	case 125: printf("%d cm above gnd",kpds7);
+	 	break;
+	case 126: 
+		if (center == NMC) printf("%.2f mb",kpds7*0.01);
+	 	break;
+	case 128: printf("%.3f-%.3f (sigma)",1.1-o11/1000.0, 1.1-o12/1000.0);
+	 	break;
+	case 141: printf("%d-%d mb",o11*10,1100-o12);
+	 	break;
+	case 160: printf("%d m below sea level",kpds7);
+	 	break;
+	default:
+	 	break;
+	}
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/missing.c b/wrfv2_fire/external/io_grib1/WGRIB/missing.c
new file mode 100644
index 00000000..062b8af1
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/missing.c
@@ -0,0 +1,48 @@
+#include 
+#include 
+#include "grib.h"
+
+/*
+ *  number of missing data points w. ebisuzaki
+ *
+ *  v1.1: just faster my dear
+ *  v1.2: just faster my dear
+ *
+ */
+
+static int bitsum[256] = {
+    8, 7, 7, 6, 7, 6, 6, 5, 7, 6, 6, 5, 6, 5, 5, 4, 
+    7, 6, 6, 5, 6, 5, 5, 4, 6, 5, 5, 4, 5, 4, 4, 3, 
+    7, 6, 6, 5, 6, 5, 5, 4, 6, 5, 5, 4, 5, 4, 4, 3, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    7, 6, 6, 5, 6, 5, 5, 4, 6, 5, 5, 4, 5, 4, 4, 3, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    5, 4, 4, 3, 4, 3, 3, 2, 4, 3, 3, 2, 3, 2, 2, 1, 
+    7, 6, 6, 5, 6, 5, 5, 4, 6, 5, 5, 4, 5, 4, 4, 3, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    5, 4, 4, 3, 4, 3, 3, 2, 4, 3, 3, 2, 3, 2, 2, 1, 
+    6, 5, 5, 4, 5, 4, 4, 3, 5, 4, 4, 3, 4, 3, 3, 2, 
+    5, 4, 4, 3, 4, 3, 3, 2, 4, 3, 3, 2, 3, 2, 2, 1, 
+    5, 4, 4, 3, 4, 3, 3, 2, 4, 3, 3, 2, 3, 2, 2, 1, 
+    4, 3, 3, 2, 3, 2, 2, 1, 3, 2, 2, 1, 2, 1, 1, 0};
+
+
+int missing_points(unsigned char *bitmap, int n) {
+
+    int count;
+    unsigned int tmp;
+    if (bitmap == NULL) return 0;
+
+    count = 0;
+    while (n >= 8) {
+	tmp = *bitmap++;
+	n -= 8;
+        count += bitsum[tmp];
+    }
+    tmp = *bitmap | ((1 << (8 - n)) - 1);
+    count += bitsum[tmp];
+
+    return count;
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/nceptab_129.c b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_129.c
new file mode 100644
index 00000000..31daab76
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_129.c
@@ -0,0 +1,260 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_nceptab_129[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"PRES", "Pressure [Pa]"},
+      /* 2 */ {"PRMSL", "Pressure reduced to MSL [Pa]"},
+      /* 3 */ {"PTEND", "Pressure tendency [Pa/s]"},
+      /* 4 */ {"PVORT", "Pot. vorticity [km^2/kg/s]"},
+      /* 5 */ {"ICAHT", "ICAO Standard Atmosphere Reference Height [M]"},
+      /* 6 */ {"GP", "Geopotential [m^2/s^2]"},
+      /* 7 */ {"HGT", "Geopotential height [gpm]"},
+      /* 8 */ {"DIST", "Geometric height [m]"},
+      /* 9 */ {"HSTDV", "Std dev of height [m]"},
+      /* 10 */ {"TOZNE", "Total ozone [Dobson]"},
+      /* 11 */ {"TMP", "Temp. [K]"},
+      /* 12 */ {"VTMP", "Virtual temp. [K]"},
+      /* 13 */ {"POT", "Potential temp. [K]"},
+      /* 14 */ {"EPOT", "Pseudo-adiabatic pot. temp. [K]"},
+      /* 15 */ {"TMAX", "Max. temp. [K]"},
+      /* 16 */ {"TMIN", "Min. temp. [K]"},
+      /* 17 */ {"DPT", "Dew point temp. [K]"},
+      /* 18 */ {"DEPR", "Dew point depression [K]"},
+      /* 19 */ {"LAPR", "Lapse rate [K/m]"},
+      /* 20 */ {"VIS", "Visibility [m]"},
+      /* 21 */ {"RDSP1", "Radar spectra (1) [non-dim]"},
+      /* 22 */ {"RDSP2", "Radar spectra (2) [non-dim]"},
+      /* 23 */ {"RDSP3", "Radar spectra (3) [non-dim]"},
+      /* 24 */ {"PLI", "Parcel lifted index (to 500 hPa) [K]"},
+      /* 25 */ {"TMPA", "Temp. anomaly [K]"},
+      /* 26 */ {"PRESA", "Pressure anomaly [Pa]"},
+      /* 27 */ {"GPA", "Geopotential height anomaly [gpm]"},
+      /* 28 */ {"WVSP1", "Wave spectra (1) [non-dim]"},
+      /* 29 */ {"WVSP2", "Wave spectra (2) [non-dim]"},
+      /* 30 */ {"WVSP3", "Wave spectra (3) [non-dim]"},
+      /* 31 */ {"WDIR", "Wind direction [deg]"},
+      /* 32 */ {"WIND", "Wind speed [m/s]"},
+      /* 33 */ {"UGRD", "u wind [m/s]"},
+      /* 34 */ {"VGRD", "v wind [m/s]"},
+      /* 35 */ {"STRM", "Stream function [m^2/s]"},
+      /* 36 */ {"VPOT", "Velocity potential [m^2/s]"},
+      /* 37 */ {"MNTSF", "Montgomery stream function [m^2/s^2]"},
+      /* 38 */ {"SGCVV", "Sigma coord. vertical velocity [/s]"},
+      /* 39 */ {"VVEL", "Pressure vertical velocity [Pa/s]"},
+      /* 40 */ {"DZDT", "Geometric vertical velocity [m/s]"},
+      /* 41 */ {"ABSV", "Absolute vorticity [/s]"},
+      /* 42 */ {"ABSD", "Absolute divergence [/s]"},
+      /* 43 */ {"RELV", "Relative vorticity [/s]"},
+      /* 44 */ {"RELD", "Relative divergence [/s]"},
+      /* 45 */ {"VUCSH", "Vertical u shear [/s]"},
+      /* 46 */ {"VVCSH", "Vertical v shear [/s]"},
+      /* 47 */ {"DIRC", "Direction of current [deg]"},
+      /* 48 */ {"SPC", "Speed of current [m/s]"},
+      /* 49 */ {"UOGRD", "u of current [m/s]"},
+      /* 50 */ {"VOGRD", "v of current [m/s]"},
+      /* 51 */ {"SPFH", "Specific humidity [kg/kg]"},
+      /* 52 */ {"RH", "Relative humidity [%]"},
+      /* 53 */ {"MIXR", "Humidity mixing ratio [kg/kg]"},
+      /* 54 */ {"PWAT", "Precipitable water [kg/m^2]"},
+      /* 55 */ {"VAPP", "Vapor pressure [Pa]"},
+      /* 56 */ {"SATD", "Saturation deficit [Pa]"},
+      /* 57 */ {"EVP", "Evaporation [kg/m^2]"},
+      /* 58 */ {"CICE", "Cloud Ice [kg/m^2]"},
+      /* 59 */ {"PRATE", "Precipitation rate [kg/m^2/s]"},
+      /* 60 */ {"TSTM", "Thunderstorm probability [%]"},
+      /* 61 */ {"APCP", "Total precipitation [kg/m^2]"},
+      /* 62 */ {"NCPCP", "Large scale precipitation [kg/m^2]"},
+      /* 63 */ {"ACPCP", "Convective precipitation [kg/m^2]"},
+      /* 64 */ {"SRWEQ", "Snowfall rate water equiv. [kg/m^2/s]"},
+      /* 65 */ {"WEASD", "Accum. snow [kg/m^2]"},
+      /* 66 */ {"SNOD", "Snow depth [m]"},
+      /* 67 */ {"MIXHT", "Mixed layer depth [m]"},
+      /* 68 */ {"TTHDP", "Transient thermocline depth [m]"},
+      /* 69 */ {"MTHD", "Main thermocline depth [m]"},
+      /* 70 */ {"MTHA", "Main thermocline anomaly [m]"},
+      /* 71 */ {"TCDC", "Total cloud cover [%]"},
+      /* 72 */ {"CDCON", "Convective cloud cover [%]"},
+      /* 73 */ {"LCDC", "Low level cloud cover [%]"},
+      /* 74 */ {"MCDC", "Mid level cloud cover [%]"},
+      /* 75 */ {"HCDC", "High level cloud cover [%]"},
+      /* 76 */ {"CWAT", "Cloud water [kg/m^2]"},
+      /* 77 */ {"BLI", "Best lifted index (to 500 hPa) [K]"},
+      /* 78 */ {"SNOC", "Convective snow [kg/m^2]"},
+      /* 79 */ {"SNOL", "Large scale snow [kg/m^2]"},
+      /* 80 */ {"WTMP", "Water temp. [K]"},
+      /* 81 */ {"LAND", "Land cover (land=1;sea=0) [fraction]"},
+      /* 82 */ {"DSLM", "Deviation of sea level from mean [m]"},
+      /* 83 */ {"SFCR", "Surface roughness [m]"},
+      /* 84 */ {"ALBDO", "Albedo [%]"},
+      /* 85 */ {"TSOIL", "Soil temp. [K]"},
+      /* 86 */ {"SOILM", "Soil moisture content [kg/m^2]"},
+      /* 87 */ {"VEG", "Vegetation [%]"},
+      /* 88 */ {"SALTY", "Salinity [kg/kg]"},
+      /* 89 */ {"DEN", "Density [kg/m^3]"},
+      /* 90 */ {"WATR", "Water runoff [kg/m^2]"},
+      /* 91 */ {"ICEC", "Ice concentration (ice=1;no ice=0) [fraction]"},
+      /* 92 */ {"ICETK", "Ice thickness [m]"},
+      /* 93 */ {"DICED", "Direction of ice drift [deg]"},
+      /* 94 */ {"SICED", "Speed of ice drift [m/s]"},
+      /* 95 */ {"UICE", "u of ice drift [m/s]"},
+      /* 96 */ {"VICE", "v of ice drift [m/s]"},
+      /* 97 */ {"ICEG", "Ice growth rate [m/s]"},
+      /* 98 */ {"ICED", "Ice divergence [/s]"},
+      /* 99 */ {"SNOM", "Snow melt [kg/m^2]"},
+      /* 100 */ {"HTSGW", "Sig height of wind waves and swell [m]"},
+      /* 101 */ {"WVDIR", "Direction of wind waves [deg]"},
+      /* 102 */ {"WVHGT", "Sig height of wind waves [m]"},
+      /* 103 */ {"WVPER", "Mean period of wind waves [s]"},
+      /* 104 */ {"SWDIR", "Direction of swell waves [deg]"},
+      /* 105 */ {"SWELL", "Sig height of swell waves [m]"},
+      /* 106 */ {"SWPER", "Mean period of swell waves [s]"},
+      /* 107 */ {"DIRPW", "Primary wave direction [deg]"},
+      /* 108 */ {"PERPW", "Primary wave mean period [s]"},
+      /* 109 */ {"DIRSW", "Secondary wave direction [deg]"},
+      /* 110 */ {"PERSW", "Secondary wave mean period [s]"},
+      /* 111 */ {"NSWRS", "Net short wave (surface) [W/m^2]"},
+      /* 112 */ {"NLWRS", "Net long wave (surface) [W/m^2]"},
+      /* 113 */ {"NSWRT", "Net short wave (top) [W/m^2]"},
+      /* 114 */ {"NLWRT", "Net long wave (top) [W/m^2]"},
+      /* 115 */ {"LWAVR", "Long wave [W/m^2]"},
+      /* 116 */ {"SWAVR", "Short wave [W/m^2]"},
+      /* 117 */ {"GRAD", "Global radiation [W/m^2]"},
+      /* 118 */ {"BRTMP", "Brightness temperature [K]"},
+      /* 119 */ {"LWRAD", "Radiance with respect to wave no. [W/m/sr]"},
+      /* 120 */ {"SWRAD", "Radiance with respect ot wave len. [W/m^3/sr]"},
+      /* 121 */ {"LHTFL", "Latent heat flux [W/m^2]"},
+      /* 122 */ {"SHTFL", "Sensible heat flux [W/m^2]"},
+      /* 123 */ {"BLYDP", "Boundary layer dissipation [W/m^2]"},
+      /* 124 */ {"UFLX", "Zonal momentum flux [N/m^2]"},
+      /* 125 */ {"VFLX", "Meridional momentum flux [N/m^2]"},
+      /* 126 */ {"WMIXE", "Wind mixing energy [J]"},
+      /* 127 */ {"IMGD", "Image data []"},
+      /* 128 */ {"PAOT", "Probability anomaly of temp [%]"},
+      /* 129 */ {"PAOP", "Probability anomaly of precip [%]"},
+      /* 130 */ {"var130", "undefined"},
+      /* 131 */ {"FRAIN", "Rain fraction of total liquid water []"},
+      /* 132 */ {"FICE", "Ice fraction of total condensate []"},
+      /* 133 */ {"FRIME", "Rime factor []"},
+      /* 134 */ {"CUEFI", "Convective cloud efficiency []"},
+      /* 135 */ {"TCOND", "Total condensate [kg/kg]"},
+      /* 136 */ {"TCOLW", "Total column cloud water [kg/m/m]"},
+      /* 137 */ {"TCOLI", "Total column cloud ice [kg/m/m]"},
+      /* 138 */ {"TCOLR", "Total column rain [kg/m/m]"},
+      /* 139 */ {"TCOLS", "Total column snow [kg/m/m]"},
+      /* 140 */ {"TCOLC", "Total column condensate [kg/m/m]"},
+      /* 141 */ {"PLPL", "Pressure of level from which parcel was lifted [Pa]"},
+      /* 142 */ {"HLPL", "Height of level from which parcel was lifted [Pa]"},
+      /* 143 */ {"CEMS", "Cloud emissivity [fraction]"},
+      /* 144 */ {"COPD", "Cloud optical depth [non-dim]"},
+      /* 145 */ {"PSIZ", "Effective particle size [microns]"},
+      /* 146 */ {"TCWAT", "Total water cloud [%]"},
+      /* 147 */ {"TCICE", "Total ice cloud [%]"},
+      /* 148 */ {"var148", "undefined"},
+      /* 149 */ {"var149", "undefined"},
+      /* 150 */ {"PTAN", "Probabilty of Temp. above normal [%]"},
+      /* 151 */ {"PTNN", "Probabilty of Temp. near normal [%]"},
+      /* 152 */ {"PTbN", "Probabilty of Temp. below normal [%]"},
+      /* 153 */ {"PPAN", "Probabilty of Precip. above normal [%]"},
+      /* 154 */ {"PPNN", "Probabilty of Precip. near normal [%]"},
+      /* 155 */ {"PPbN", "Probabilty of Precip. below normal [%]"},
+      /* 156 */ {"var156", "undefined"},
+      /* 157 */ {"var157", "undefined"},
+      /* 158 */ {"var158", "undefined"},
+      /* 159 */ {"var159", "undefined"},
+      /* 160 */ {"var160", "undefined"},
+      /* 161 */ {"var161", "undefined"},
+      /* 162 */ {"var162", "undefined"},
+      /* 163 */ {"var163", "undefined"},
+      /* 164 */ {"var164", "undefined"},
+      /* 165 */ {"var165", "undefined"},
+      /* 166 */ {"var166", "undefined"},
+      /* 167 */ {"var167", "undefined"},
+      /* 168 */ {"var168", "undefined"},
+      /* 169 */ {"var169", "undefined"},
+      /* 170 */ {"ELRDI", "Ellrod Index [non-dim]"},
+      /* 171 */ {"TSEC", "Seconds prior to initial reference time ?? [sec]"},
+      /* 172 */ {"var172", "undefined"},
+      /* 173 */ {"var173", "undefined"},
+      /* 174 */ {"var174", "undefined"},
+      /* 175 */ {"var175", "undefined"},
+      /* 176 */ {"var176", "undefined"},
+      /* 177 */ {"var177", "undefined"},
+      /* 178 */ {"var178", "undefined"},
+      /* 179 */ {"var179", "undefined"},
+      /* 180 */ {"OZCON", "Ozone concentration [ppb]"},
+      /* 181 */ {"OZCAT", "Categorical ozone concentration [?]"},
+      /* 182 */ {"KH", "vertical heat eddy diffusivity [m^2/s]"},
+      /* 183 */ {"SIGV", "Sigma level value ?? [non-dim]"},
+      /* 184 */ {"var184", "undefined"},
+      /* 185 */ {"var185", "undefined"},
+      /* 186 */ {"var186", "undefined"},
+      /* 187 */ {"var187", "undefined"},
+      /* 188 */ {"var188", "undefined"},
+      /* 189 */ {"var189", "undefined"},
+      /* 190 */ {"USCT", "Scatterometer est. U wind component [m/s]"},
+      /* 191 */ {"VSCT", "Scatterometer est. V wind component [m/s]"},
+      /* 192 */ {"var192", "undefined"},
+      /* 193 */ {"var193", "undefined"},
+      /* 194 */ {"var194", "undefined"},
+      /* 195 */ {"var195", "undefined"},
+      /* 196 */ {"var196", "undefined"},
+      /* 197 */ {"var197", "undefined"},
+      /* 198 */ {"var198", "undefined"},
+      /* 199 */ {"var199", "undefined"},
+      /* 200 */ {"DUVB", "UV-B Downward Solar Flux [W/m^2]"},
+      /* 201 */ {"CDUVB", "Clear Sky UV-B Downward Solar Flux [W/m^2]"},
+      /* 202 */ {"THFLX", "Total downward heat flux at surface [W/m^2]"},
+      /* 203 */ {"var203", "undefined"},
+      /* 204 */ {"var204", "undefined"},
+      /* 205 */ {"var205", "undefined"},
+      /* 206 */ {"var206", "undefined"},
+      /* 207 */ {"var207", "undefined"},
+      /* 208 */ {"var208", "undefined"},
+      /* 209 */ {"var209", "undefined"},
+      /* 210 */ {"var210", "undefined"},
+      /* 211 */ {"var211", "undefined"},
+      /* 212 */ {"var212", "undefined"},
+      /* 213 */ {"var213", "undefined"},
+      /* 214 */ {"var214", "undefined"},
+      /* 215 */ {"var215", "undefined"},
+      /* 216 */ {"var216", "undefined"},
+      /* 217 */ {"var217", "undefined"},
+      /* 218 */ {"var218", "undefined"},
+      /* 219 */ {"var219", "undefined"},
+      /* 220 */ {"var220", "undefined"},
+      /* 221 */ {"var221", "undefined"},
+      /* 222 */ {"var222", "undefined"},
+      /* 223 */ {"var223", "undefined"},
+      /* 224 */ {"var224", "undefined"},
+      /* 225 */ {"var225", "undefined"},
+      /* 226 */ {"var226", "undefined"},
+      /* 227 */ {"var227", "undefined"},
+      /* 228 */ {"var228", "undefined"},
+      /* 229 */ {"var229", "undefined"},
+      /* 230 */ {"var230", "undefined"},
+      /* 231 */ {"var231", "undefined"},
+      /* 232 */ {"var232", "undefined"},
+      /* 233 */ {"var233", "undefined"},
+      /* 234 */ {"var234", "undefined"},
+      /* 235 */ {"var235", "undefined"},
+      /* 236 */ {"var236", "undefined"},
+      /* 237 */ {"var237", "undefined"},
+      /* 238 */ {"var238", "undefined"},
+      /* 239 */ {"var239", "undefined"},
+      /* 240 */ {"var240", "undefined"},
+      /* 241 */ {"var241", "undefined"},
+      /* 242 */ {"var242", "undefined"},
+      /* 243 */ {"var243", "undefined"},
+      /* 244 */ {"var244", "undefined"},
+      /* 245 */ {"var245", "undefined"},
+      /* 246 */ {"var246", "undefined"},
+      /* 247 */ {"var247", "undefined"},
+      /* 248 */ {"var248", "undefined"},
+      /* 249 */ {"var249", "undefined"},
+      /* 250 */ {"var250", "undefined"},
+      /* 251 */ {"var251", "undefined"},
+      /* 252 */ {"var252", "undefined"},
+      /* 253 */ {"var253", "undefined"},
+      /* 254 */ {"var254", "undefined"},
+      /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/nceptab_130.c b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_130.c
new file mode 100644
index 00000000..30792d89
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_130.c
@@ -0,0 +1,260 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_nceptab_130[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"PRES", "Pressure [Pa]"},
+      /* 2 */ {"PRMSL", "Pressure reduced to MSL [Pa]"},
+      /* 3 */ {"PTEND", "Pressure tendency [Pa/s]"},
+      /* 4 */ {"PVORT", "Pot. vorticity [km^2/kg/s]"},
+      /* 5 */ {"ICAHT", "ICAO Standard Atmosphere Reference Height [M]"},
+      /* 6 */ {"GP", "Geopotential [m^2/s^2]"},
+      /* 7 */ {"HGT", "Geopotential height [gpm]"},
+      /* 8 */ {"DIST", "Geometric height [m]"},
+      /* 9 */ {"HSTDV", "Std dev of height [m]"},
+      /* 10 */ {"TOZNE", "Total ozone [Dobson]"},
+      /* 11 */ {"TMP", "Temp. [K]"},
+      /* 12 */ {"VTMP", "Virtual temp. [K]"},
+      /* 13 */ {"POT", "Potential temp. [K]"},
+      /* 14 */ {"EPOT", "Pseudo-adiabatic pot. temp. [K]"},
+      /* 15 */ {"TMAX", "Max. temp. [K]"},
+      /* 16 */ {"TMIN", "Min. temp. [K]"},
+      /* 17 */ {"DPT", "Dew point temp. [K]"},
+      /* 18 */ {"DEPR", "Dew point depression [K]"},
+      /* 19 */ {"LAPR", "Lapse rate [K/m]"},
+      /* 20 */ {"VIS", "Visibility [m]"},
+      /* 21 */ {"RDSP1", "Radar spectra (1) [non-dim]"},
+      /* 22 */ {"RDSP2", "Radar spectra (2) [non-dim]"},
+      /* 23 */ {"RDSP3", "Radar spectra (3) [non-dim]"},
+      /* 24 */ {"PLI", "Parcel lifted index (to 500 hPa) [K]"},
+      /* 25 */ {"TMPA", "Temp. anomaly [K]"},
+      /* 26 */ {"PRESA", "Pressure anomaly [Pa]"},
+      /* 27 */ {"GPA", "Geopotential height anomaly [gpm]"},
+      /* 28 */ {"WVSP1", "Wave spectra (1) [non-dim]"},
+      /* 29 */ {"WVSP2", "Wave spectra (2) [non-dim]"},
+      /* 30 */ {"WVSP3", "Wave spectra (3) [non-dim]"},
+      /* 31 */ {"WDIR", "Wind direction [deg]"},
+      /* 32 */ {"WIND", "Wind speed [m/s]"},
+      /* 33 */ {"UGRD", "u wind [m/s]"},
+      /* 34 */ {"VGRD", "v wind [m/s]"},
+      /* 35 */ {"STRM", "Stream function [m^2/s]"},
+      /* 36 */ {"VPOT", "Velocity potential [m^2/s]"},
+      /* 37 */ {"MNTSF", "Montgomery stream function [m^2/s^2]"},
+      /* 38 */ {"SGCVV", "Sigma coord. vertical velocity [/s]"},
+      /* 39 */ {"VVEL", "Pressure vertical velocity [Pa/s]"},
+      /* 40 */ {"DZDT", "Geometric vertical velocity [m/s]"},
+      /* 41 */ {"ABSV", "Absolute vorticity [/s]"},
+      /* 42 */ {"ABSD", "Absolute divergence [/s]"},
+      /* 43 */ {"RELV", "Relative vorticity [/s]"},
+      /* 44 */ {"RELD", "Relative divergence [/s]"},
+      /* 45 */ {"VUCSH", "Vertical u shear [/s]"},
+      /* 46 */ {"VVCSH", "Vertical v shear [/s]"},
+      /* 47 */ {"DIRC", "Direction of current [deg]"},
+      /* 48 */ {"SPC", "Speed of current [m/s]"},
+      /* 49 */ {"UOGRD", "u of current [m/s]"},
+      /* 50 */ {"VOGRD", "v of current [m/s]"},
+      /* 51 */ {"SPFH", "Specific humidity [kg/kg]"},
+      /* 52 */ {"RH", "Relative humidity [%]"},
+      /* 53 */ {"MIXR", "Humidity mixing ratio [kg/kg]"},
+      /* 54 */ {"PWAT", "Precipitable water [kg/m^2]"},
+      /* 55 */ {"VAPP", "Vapor pressure [Pa]"},
+      /* 56 */ {"SATD", "Saturation deficit [Pa]"},
+      /* 57 */ {"EVP", "Evaporation [kg/m^2]"},
+      /* 58 */ {"CICE", "Cloud Ice [kg/m^2]"},
+      /* 59 */ {"PRATE", "Precipitation rate [kg/m^2/s]"},
+      /* 60 */ {"TSTM", "Thunderstorm probability [%]"},
+      /* 61 */ {"APCP", "Total precipitation [kg/m^2]"},
+      /* 62 */ {"NCPCP", "Large scale precipitation [kg/m^2]"},
+      /* 63 */ {"ACPCP", "Convective precipitation [kg/m^2]"},
+      /* 64 */ {"SRWEQ", "Snowfall rate water equiv. [kg/m^2/s]"},
+      /* 65 */ {"WEASD", "Accum. snow [kg/m^2]"},
+      /* 66 */ {"SNOD", "Snow depth [m]"},
+      /* 67 */ {"MIXHT", "Mixed layer depth [m]"},
+      /* 68 */ {"TTHDP", "Transient thermocline depth [m]"},
+      /* 69 */ {"MTHD", "Main thermocline depth [m]"},
+      /* 70 */ {"MTHA", "Main thermocline anomaly [m]"},
+      /* 71 */ {"TCDC", "Total cloud cover [%]"},
+      /* 72 */ {"CDCON", "Convective cloud cover [%]"},
+      /* 73 */ {"LCDC", "Low level cloud cover [%]"},
+      /* 74 */ {"MCDC", "Mid level cloud cover [%]"},
+      /* 75 */ {"HCDC", "High level cloud cover [%]"},
+      /* 76 */ {"CWAT", "Cloud water [kg/m^2]"},
+      /* 77 */ {"BLI", "Best lifted index (to 500 hPa) [K]"},
+      /* 78 */ {"SNOC", "Convective snow [kg/m^2]"},
+      /* 79 */ {"SNOL", "Large scale snow [kg/m^2]"},
+      /* 80 */ {"WTMP", "Water temp. [K]"},
+      /* 81 */ {"LAND", "Land cover (land=1;sea=0) [fraction]"},
+      /* 82 */ {"DSLM", "Deviation of sea level from mean [m]"},
+      /* 83 */ {"SFCR", "Surface roughness [m]"},
+      /* 84 */ {"ALBDO", "Albedo [%]"},
+      /* 85 */ {"TSOIL", "Soil temp. [K]"},
+      /* 86 */ {"SOILM", "Soil moisture content [kg/m^2]"},
+      /* 87 */ {"VEG", "Vegetation [%]"},
+      /* 88 */ {"SALTY", "Salinity [kg/kg]"},
+      /* 89 */ {"DEN", "Density [kg/m^3]"},
+      /* 90 */ {"WATR", "Water runoff [kg/m^2]"},
+      /* 91 */ {"ICEC", "Ice concentration (ice=1;no ice=0) [fraction]"},
+      /* 92 */ {"ICETK", "Ice thickness [m]"},
+      /* 93 */ {"DICED", "Direction of ice drift [deg]"},
+      /* 94 */ {"SICED", "Speed of ice drift [m/s]"},
+      /* 95 */ {"UICE", "u of ice drift [m/s]"},
+      /* 96 */ {"VICE", "v of ice drift [m/s]"},
+      /* 97 */ {"ICEG", "Ice growth rate [m/s]"},
+      /* 98 */ {"ICED", "Ice divergence [/s]"},
+      /* 99 */ {"SNOM", "Snow melt [kg/m^2]"},
+      /* 100 */ {"HTSGW", "Sig height of wind waves and swell [m]"},
+      /* 101 */ {"WVDIR", "Direction of wind waves [deg]"},
+      /* 102 */ {"WVHGT", "Sig height of wind waves [m]"},
+      /* 103 */ {"WVPER", "Mean period of wind waves [s]"},
+      /* 104 */ {"SWDIR", "Direction of swell waves [deg]"},
+      /* 105 */ {"SWELL", "Sig height of swell waves [m]"},
+      /* 106 */ {"SWPER", "Mean period of swell waves [s]"},
+      /* 107 */ {"DIRPW", "Primary wave direction [deg]"},
+      /* 108 */ {"PERPW", "Primary wave mean period [s]"},
+      /* 109 */ {"DIRSW", "Secondary wave direction [deg]"},
+      /* 110 */ {"PERSW", "Secondary wave mean period [s]"},
+      /* 111 */ {"NSWRS", "Net short wave (surface) [W/m^2]"},
+      /* 112 */ {"NLWRS", "Net long wave (surface) [W/m^2]"},
+      /* 113 */ {"NSWRT", "Net short wave (top) [W/m^2]"},
+      /* 114 */ {"NLWRT", "Net long wave (top) [W/m^2]"},
+      /* 115 */ {"LWAVR", "Long wave [W/m^2]"},
+      /* 116 */ {"SWAVR", "Short wave [W/m^2]"},
+      /* 117 */ {"GRAD", "Global radiation [W/m^2]"},
+      /* 118 */ {"BRTMP", "Brightness temperature [K]"},
+      /* 119 */ {"LWRAD", "Radiance with respect to wave no. [W/m/sr]"},
+      /* 120 */ {"SWRAD", "Radiance with respect ot wave len. [W/m^3/sr]"},
+      /* 121 */ {"LHTFL", "Latent heat flux [W/m^2]"},
+      /* 122 */ {"SHTFL", "Sensible heat flux [W/m^2]"},
+      /* 123 */ {"BLYDP", "Boundary layer dissipation [W/m^2]"},
+      /* 124 */ {"UFLX", "Zonal momentum flux [N/m^2]"},
+      /* 125 */ {"VFLX", "Meridional momentum flux [N/m^2]"},
+      /* 126 */ {"WMIXE", "Wind mixing energy [J]"},
+      /* 127 */ {"IMGD", "Image data []"},
+      /* 128 */ {"var128", "undefined"},
+      /* 129 */ {"var129", "undefined"},
+      /* 130 */ {"var130", "undefined"},
+      /* 131 */ {"var131", "undefined"},
+      /* 132 */ {"var132", "undefined"},
+      /* 133 */ {"var133", "undefined"},
+      /* 134 */ {"var134", "undefined"},
+      /* 135 */ {"var135", "undefined"},
+      /* 136 */ {"var136", "undefined"},
+      /* 137 */ {"var137", "undefined"},
+      /* 138 */ {"var138", "undefined"},
+      /* 139 */ {"var139", "undefined"},
+      /* 140 */ {"var140", "undefined"},
+      /* 141 */ {"var141", "undefined"},
+      /* 142 */ {"var142", "undefined"},
+      /* 143 */ {"var143", "undefined 143"},
+      /* 144 */ {"SOILW", "Volumetric soil moisture (frozen + liquid) [fraction]"},
+      /* 145 */ {"PEVPR", "Potential evaporation rate [W/m^2]"},
+      /* 146 */ {"VEGT", "Vegetation canopy temperature [K]"},
+      /* 147 */ {"BARET", "Bare soil surface skin temperature [K]"},
+      /* 148 */ {"AVSFT", "Average surface skin temperature [K]"},
+      /* 149 */ {"RADT", "Effective radiative skin temperature [K]"},
+      /* 150 */ {"SSTOR", "Surface water storage [Kg/m^2]"},
+      /* 151 */ {"LSOIL", "Liquid soil moisture content (non-frozen) [Kg/m^2]"},
+      /* 152 */ {"EWATR", "Open water evaporation (standing water) [W/m^2]"},
+      /* 153 */ {"var153", "undefined"},
+      /* 154 */ {"var154", "undefined"},
+      /* 155 */ {"GFLUX", "Ground Heat Flux [W/m^2]"},
+      /* 156 */ {"CIN", "Convective inhibition [J/Kg]"},
+      /* 157 */ {"CAPE", "Convective available potential energy [J/Kg]"},
+      /* 158 */ {"TKE", "Turbulent Kinetic Energy [J/Kg]"},
+      /* 159 */ {"MXSALB", "Maximum snow albedo [%]"},
+      /* 160 */ {"SOILL", "Liquid volumetric soil moisture (non-frozen) [fraction]"},
+      /* 161 */ {"ASNOW", "Frozen precipitation (e.g. snowfall) [Kg/m^2]"},
+      /* 162 */ {"ARAIN", "Liquid precipitation (rainfall) [Kg/m^2]"},
+      /* 163 */ {"GWREC", "Groundwater recharge [Kg/m^2]"},
+      /* 164 */ {"QREC", "Flood plain recharge [Kg/m^2]"},
+      /* 165 */ {"SNOWT", "Snow temperature, depth-avg [K]"},
+      /* 166 */ {"VBDSF", "Visible beam downward solar flux [W/m^2]"},
+      /* 167 */ {"VDDSF", "Visible diffuse downward solar flux [W/m^2]"},
+      /* 168 */ {"NBDSF", "Near IR beam downward solar flux [W/m^2]"},
+      /* 169 */ {"NDDSF", "Near IR diffuse downward solar flux [W/m^2]"},
+      /* 170 */ {"SNFALB", "Snow-free albedo [%]"},
+      /* 171 */ {"RLYRS", "Number of soil layers in root zone [non-dim]"},
+      /* 172 */ {"MFLX", "Momentum flux [N/m^2]"},
+      /* 173 */ {"var173", "undefined"},
+      /* 174 */ {"var174", "undefined"},
+      /* 175 */ {"var175", "undefined"},
+      /* 176 */ {"NLAT", "Latitude (-90 to +90) [deg]"},
+      /* 177 */ {"ELON", "East longitude (0-360) [deg]"},
+      /* 178 */ {"var178", "undefined"},
+      /* 179 */ {"ACOND", "Aerodynamic conductance [m/s]"},
+      /* 180 */ {"SNOAG", "Snow age [s]"},
+      /* 181 */ {"CCOND", "Canopy conductance [m/s]"},
+      /* 182 */ {"LAI", "Leaf area index (0-9) [non-dim]"},
+      /* 183 */ {"SFCRH", "Roughness length for heat [m]"},
+      /* 184 */ {"SALBD", "Snow albedo (over snow cover area only) [%]"},
+      /* 185 */ {"var185", "undefined"},
+      /* 186 */ {"var186", "undefined"},
+      /* 187 */ {"NDVI", "Normalized Difference Vegetation Index []"},
+      /* 188 */ {"DRIP", "Canopy drip [Kg/m^2]"},
+      /* 189 */ {"var189", "undefined"},
+      /* 190 */ {"var190", "undefined"},
+      /* 191 */ {"var191", "undefined"},
+      /* 192 */ {"var192", "undefined"},
+      /* 193 */ {"var193", "undefined"},
+      /* 194 */ {"var194", "undefined"},
+      /* 195 */ {"var195", "undefined"},
+      /* 196 */ {"var196", "undefined"},
+      /* 197 */ {"var197", "undefined"},
+      /* 198 */ {"SBSNO", "Sublimation (evaporation from snow) [W/m^2]"},
+      /* 199 */ {"EVBS", "Direct evaporation from bare soil [W/m^2]"},
+      /* 200 */ {"EVCW", "Canopy water evaporation [W/m^2]"},
+      /* 201 */ {"var201", "undefined"},
+      /* 202 */ {"var202", "undefined"},
+      /* 203 */ {"RSMIN", "Minimal stomatal resistance [s/m]"},
+      /* 204 */ {"DSWRF", "Downward shortwave radiation flux [W/m^2]"},
+      /* 205 */ {"DLWRF", "Downward longwave radiation flux [W/m^2]"},
+      /* 206 */ {"var206", "undefined"},
+      /* 207 */ {"MSTAV", "Moisture availability [%]"},
+      /* 208 */ {"SFEXC", "Exchange coefficient [(Kg/m^3)(m/s)]"},
+      /* 209 */ {"var209", "undefined"},
+      /* 210 */ {"TRANS", "Transpiration [W/m^2]"},
+      /* 211 */ {"USWRF", "Upward short wave radiation flux [W/m^2]"},
+      /* 212 */ {"ULWRF", "Upward long wave radiation flux [W/m^2]"},
+      /* 213 */ {"var213", "undefined"},
+      /* 214 */ {"var214", "undefined"},
+      /* 215 */ {"var215", "undefined"},
+      /* 216 */ {"var216", "undefined"},
+      /* 217 */ {"var217", "undefined"},
+      /* 218 */ {"var218", "undefined"},
+      /* 219 */ {"WILT", "Wilting point [fraction]"},
+      /* 220 */ {"FLDCP", "Field Capacity [fraction]"},
+      /* 221 */ {"HPBL", "Planetary boundary layer height [m]"},
+      /* 222 */ {"SLTYP", "Surface slope type [Index]"},
+      /* 223 */ {"CNWAT", "Plant canopy surface water [Kg/m^2]"},
+      /* 224 */ {"SOTYP", "Soil type [Index]"},
+      /* 225 */ {"VGTYP", "Vegetation type [Index]"},
+      /* 226 */ {"BMIXL", "Blackadars mixing length scale [m]"},
+      /* 227 */ {"AMIXL", "Asymptotic mixing length scale [m]"},
+      /* 228 */ {"PEVAP", "Potential evaporation [Kg/m^2]"},
+      /* 229 */ {"SNOHF", "Snow phase-change heat flux [W/m^2]"},
+      /* 230 */ {"SMREF", "Transpiration stress-onset (soil moisture) [fraction]"},
+      /* 231 */ {"SMDRY", "Direct evaporation cease (soil moisture) [fraction]"},
+      /* 232 */ {"var232", "undefined"},
+      /* 233 */ {"var233", "undefined"},
+      /* 234 */ {"BGRUN", "Subsurface runoff (baseflow) [Kg/m^2]"},
+      /* 235 */ {"SSRUN", "Surface runoff (non-infiltrating) [Kg/m^2]"},
+      /* 236 */ {"var236", "undefined"},
+      /* 237 */ {"var237", "undefined"},
+      /* 238 */ {"SNOWC", "Snow cover [%]"},
+      /* 239 */ {"SNOT", "Snow temperature [K]"},
+      /* 240 */ {"POROS", "Soil porosity [fraction]"},
+      /* 241 */ {"var241", "undefined"},
+      /* 242 */ {"var242", "undefined"},
+      /* 243 */ {"var243", "undefined"},
+      /* 244 */ {"var244", "undefined"},
+      /* 245 */ {"var245", "undefined"},
+      /* 246 */ {"RCS", "Solar parameter in canopy conductance [fraction]"},
+      /* 247 */ {"RCT", "Temperature parameter in canopy conductance [fraction]"},
+      /* 248 */ {"RCQ", "Humidity parameter in canopy conductance [fraction]"},
+      /* 249 */ {"RCSOL", "Soil moisture parameter in canopy conductance [fraction]"},
+      /* 250 */ {"var250", "undefined"},
+      /* 251 */ {"var251", "undefined"},
+      /* 252 */ {"CD", "Surface drag coefficient [non-dim]"},
+      /* 253 */ {"FRICV", "Surface friction velocity [m/s]"},
+      /* 254 */ {"RI", "Richardson number [non-dim]"},
+      /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/nceptab_131.c b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_131.c
new file mode 100644
index 00000000..0dba3b52
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/nceptab_131.c
@@ -0,0 +1,260 @@
+#include "cnames.h"
+
+struct ParmTable parm_table_nceptab_131[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"PRES", "Pressure [Pa]"},
+      /* 2 */ {"PRMSL", "Pressure reduced to MSL [Pa]"},
+      /* 3 */ {"PTEND", "Pressure tendency [Pa/s]"},
+      /* 4 */ {"PVORT", "Pot. vorticity [km^2/kg/s]"},
+      /* 5 */ {"ICAHT", "ICAO Standard Atmosphere Reference Height [M]"},
+      /* 6 */ {"GP", "Geopotential [m^2/s^2]"},
+      /* 7 */ {"HGT", "Geopotential height [gpm]"},
+      /* 8 */ {"DIST", "Geometric height [m]"},
+      /* 9 */ {"HSTDV", "Std dev of height [m]"},
+      /* 10 */ {"TOZNE", "Total ozone [Dobson]"},
+      /* 11 */ {"TMP", "Temp. [K]"},
+      /* 12 */ {"VTMP", "Virtual temp. [K]"},
+      /* 13 */ {"POT", "Potential temp. [K]"},
+      /* 14 */ {"EPOT", "Pseudo-adiabatic pot. temp. [K]"},
+      /* 15 */ {"TMAX", "Max. temp. [K]"},
+      /* 16 */ {"TMIN", "Min. temp. [K]"},
+      /* 17 */ {"DPT", "Dew point temp. [K]"},
+      /* 18 */ {"DEPR", "Dew point depression [K]"},
+      /* 19 */ {"LAPR", "Lapse rate [K/m]"},
+      /* 20 */ {"VIS", "Visibility [m]"},
+      /* 21 */ {"RDSP1", "Radar spectra (1) [non-dim]"},
+      /* 22 */ {"RDSP2", "Radar spectra (2) [non-dim]"},
+      /* 23 */ {"RDSP3", "Radar spectra (3) [non-dim]"},
+      /* 24 */ {"PLI", "Parcel lifted index (to 500 hPa) [K]"},
+      /* 25 */ {"TMPA", "Temp. anomaly [K]"},
+      /* 26 */ {"PRESA", "Pressure anomaly [Pa]"},
+      /* 27 */ {"GPA", "Geopotential height anomaly [gpm]"},
+      /* 28 */ {"WVSP1", "Wave spectra (1) [non-dim]"},
+      /* 29 */ {"WVSP2", "Wave spectra (2) [non-dim]"},
+      /* 30 */ {"WVSP3", "Wave spectra (3) [non-dim]"},
+      /* 31 */ {"WDIR", "Wind direction [deg]"},
+      /* 32 */ {"WIND", "Wind speed [m/s]"},
+      /* 33 */ {"UGRD", "u wind [m/s]"},
+      /* 34 */ {"VGRD", "v wind [m/s]"},
+      /* 35 */ {"STRM", "Stream function [m^2/s]"},
+      /* 36 */ {"VPOT", "Velocity potential [m^2/s]"},
+      /* 37 */ {"MNTSF", "Montgomery stream function [m^2/s^2]"},
+      /* 38 */ {"SGCVV", "Sigma coord. vertical velocity [/s]"},
+      /* 39 */ {"VVEL", "Pressure vertical velocity [Pa/s]"},
+      /* 40 */ {"DZDT", "Geometric vertical velocity [m/s]"},
+      /* 41 */ {"ABSV", "Absolute vorticity [/s]"},
+      /* 42 */ {"ABSD", "Absolute divergence [/s]"},
+      /* 43 */ {"RELV", "Relative vorticity [/s]"},
+      /* 44 */ {"RELD", "Relative divergence [/s]"},
+      /* 45 */ {"VUCSH", "Vertical u shear [/s]"},
+      /* 46 */ {"VVCSH", "Vertical v shear [/s]"},
+      /* 47 */ {"DIRC", "Direction of current [deg]"},
+      /* 48 */ {"SPC", "Speed of current [m/s]"},
+      /* 49 */ {"UOGRD", "u of current [m/s]"},
+      /* 50 */ {"VOGRD", "v of current [m/s]"},
+      /* 51 */ {"SPFH", "Specific humidity [kg/kg]"},
+      /* 52 */ {"RH", "Relative humidity [%]"},
+      /* 53 */ {"MIXR", "Humidity mixing ratio [kg/kg]"},
+      /* 54 */ {"PWAT", "Precipitable water [kg/m^2]"},
+      /* 55 */ {"VAPP", "Vapor pressure [Pa]"},
+      /* 56 */ {"SATD", "Saturation deficit [Pa]"},
+      /* 57 */ {"EVP", "Evaporation [kg/m^2]"},
+      /* 58 */ {"CICE", "Cloud Ice [kg/m^2]"},
+      /* 59 */ {"PRATE", "Precipitation rate [kg/m^2/s]"},
+      /* 60 */ {"TSTM", "Thunderstorm probability [%]"},
+      /* 61 */ {"APCP", "Total precipitation [kg/m^2]"},
+      /* 62 */ {"NCPCP", "Large scale precipitation [kg/m^2]"},
+      /* 63 */ {"ACPCP", "Convective precipitation [kg/m^2]"},
+      /* 64 */ {"SRWEQ", "Snowfall rate water equiv. [kg/m^2/s]"},
+      /* 65 */ {"WEASD", "Accum. snow [kg/m^2]"},
+      /* 66 */ {"SNOD", "Snow depth [m]"},
+      /* 67 */ {"MIXHT", "Mixed layer depth [m]"},
+      /* 68 */ {"TTHDP", "Transient thermocline depth [m]"},
+      /* 69 */ {"MTHD", "Main thermocline depth [m]"},
+      /* 70 */ {"MTHA", "Main thermocline anomaly [m]"},
+      /* 71 */ {"TCDC", "Total cloud cover [%]"},
+      /* 72 */ {"CDCON", "Convective cloud cover [%]"},
+      /* 73 */ {"LCDC", "Low level cloud cover [%]"},
+      /* 74 */ {"MCDC", "Mid level cloud cover [%]"},
+      /* 75 */ {"HCDC", "High level cloud cover [%]"},
+      /* 76 */ {"CWAT", "Cloud water [kg/m^2]"},
+      /* 77 */ {"BLI", "Best lifted index (to 500 hPa) [K]"},
+      /* 78 */ {"SNOC", "Convective snow [kg/m^2]"},
+      /* 79 */ {"SNOL", "Large scale snow [kg/m^2]"},
+      /* 80 */ {"WTMP", "Water temp. [K]"},
+      /* 81 */ {"LAND", "Land cover (land=1;sea=0) [fraction]"},
+      /* 82 */ {"DSLM", "Deviation of sea level from mean [m]"},
+      /* 83 */ {"SFCR", "Surface roughness [m]"},
+      /* 84 */ {"ALBDO", "Albedo [%]"},
+      /* 85 */ {"TSOIL", "Soil temp. [K]"},
+      /* 86 */ {"SOILM", "Soil moisture content [kg/m^2]"},
+      /* 87 */ {"VEG", "Vegetation [%]"},
+      /* 88 */ {"SALTY", "Salinity [kg/kg]"},
+      /* 89 */ {"DEN", "Density [kg/m^3]"},
+      /* 90 */ {"WATR", "Water runoff [kg/m^2]"},
+      /* 91 */ {"ICEC", "Ice concentration (ice=1;no ice=0) [fraction]"},
+      /* 92 */ {"ICETK", "Ice thickness [m]"},
+      /* 93 */ {"DICED", "Direction of ice drift [deg]"},
+      /* 94 */ {"SICED", "Speed of ice drift [m/s]"},
+      /* 95 */ {"UICE", "u of ice drift [m/s]"},
+      /* 96 */ {"VICE", "v of ice drift [m/s]"},
+      /* 97 */ {"ICEG", "Ice growth rate [m/s]"},
+      /* 98 */ {"ICED", "Ice divergence [/s]"},
+      /* 99 */ {"SNOM", "Snow melt [kg/m^2]"},
+      /* 100 */ {"HTSGW", "Sig height of wind waves and swell [m]"},
+      /* 101 */ {"WVDIR", "Direction of wind waves [deg]"},
+      /* 102 */ {"WVHGT", "Sig height of wind waves [m]"},
+      /* 103 */ {"WVPER", "Mean period of wind waves [s]"},
+      /* 104 */ {"SWDIR", "Direction of swell waves [deg]"},
+      /* 105 */ {"SWELL", "Sig height of swell waves [m]"},
+      /* 106 */ {"SWPER", "Mean period of swell waves [s]"},
+      /* 107 */ {"DIRPW", "Primary wave direction [deg]"},
+      /* 108 */ {"PERPW", "Primary wave mean period [s]"},
+      /* 109 */ {"DIRSW", "Secondary wave direction [deg]"},
+      /* 110 */ {"PERSW", "Secondary wave mean period [s]"},
+      /* 111 */ {"NSWRS", "Net short wave (surface) [W/m^2]"},
+      /* 112 */ {"NLWRS", "Net long wave (surface) [W/m^2]"},
+      /* 113 */ {"NSWRT", "Net short wave (top) [W/m^2]"},
+      /* 114 */ {"NLWRT", "Net long wave (top) [W/m^2]"},
+      /* 115 */ {"LWAVR", "Long wave [W/m^2]"},
+      /* 116 */ {"SWAVR", "Short wave [W/m^2]"},
+      /* 117 */ {"GRAD", "Global radiation [W/m^2]"},
+      /* 118 */ {"BRTMP", "Brightness temperature [K]"},
+      /* 119 */ {"LWRAD", "Radiance with respect to wave no. [W/m/sr]"},
+      /* 120 */ {"SWRAD", "Radiance with respect ot wave len. [W/m^3/sr]"},
+      /* 121 */ {"LHTFL", "Latent heat flux [W/m^2]"},
+      /* 122 */ {"SHTFL", "Sensible heat flux [W/m^2]"},
+      /* 123 */ {"BLYDP", "Boundary layer dissipation [W/m^2]"},
+      /* 124 */ {"UFLX", "Zonal momentum flux [N/m^2]"},
+      /* 125 */ {"VFLX", "Meridional momentum flux [N/m^2]"},
+      /* 126 */ {"WMIXE", "Wind mixing energy [J]"},
+      /* 127 */ {"IMGD", "Image data []"},
+      /* 128 */ {"MSLSA", "Mean sea level pressure (Std Atm) [Pa]"},
+      /* 129 */ {"var129", "undefined"},
+      /* 130 */ {"MSLET", "Mean sea level pressure (ETA model) [Pa]"},
+      /* 131 */ {"LFTX", "Surface lifted index [K]"},
+      /* 132 */ {"4LFTX", "Best (4-layer) lifted index [K]"},
+      /* 133 */ {"var133", "undefined"},
+      /* 134 */ {"PRESN", "Pressure (nearest grid point) [Pa]"},
+      /* 135 */ {"MCONV", "Horizontal moisture divergence [kg/kg/s]"},
+      /* 136 */ {"VWSH", "Vertical speed shear [1/s]"},
+      /* 137 */ {"var137", "undefined"},
+      /* 138 */ {"var138", "undefined"},
+      /* 139 */ {"PVMW", "Potential vorticity (mass-weighted) [1/s/m]"},
+      /* 140 */ {"CRAIN", "Categorical rain [yes=1;no=0]"},
+      /* 141 */ {"CFRZR", "Categorical freezing rain [yes=1;no=0]"},
+      /* 142 */ {"CICEP", "Categorical ice pellets [yes=1;no=0]"},
+      /* 143 */ {"CSNOW", "Categorical snow [yes=1;no=0]"},
+      /* 144 */ {"SOILW", "Volumetric soil moisture (frozen + liquid) [fraction]"},
+      /* 145 */ {"PEVPR", "Potential evaporation rate [W/m^2]"},
+      /* 146 */ {"VEGT", "Vegetation canopy temperature [K]"},
+      /* 147 */ {"BARET", "Bare soil surface skin temperature [K]"},
+      /* 148 */ {"AVSFT", "Average surface skin temperature [K]"},
+      /* 149 */ {"RADT", "Effective radiative skin temperature [K]"},
+      /* 150 */ {"SSTOR", "Surface water storage [kg/m^2]"},
+      /* 151 */ {"LSOIL", "Liquid soil moisture content (non-frozen) [kg/m^2]"},
+      /* 152 */ {"EWATR", "Open water evaporation (standing water) [W/m^2]"},
+      /* 153 */ {"CLWMR", "Cloud water [kg/kg]"},
+      /* 154 */ {"var154", "undefined"},
+      /* 155 */ {"GFLUX", "Ground Heat Flux [W/m^2]"},
+      /* 156 */ {"CIN", "Convective inhibition [J/kg]"},
+      /* 157 */ {"CAPE", "Convective available potential energy [J/kg]"},
+      /* 158 */ {"TKE", "Turbulent Kinetic Energy [J/kg]"},
+      /* 159 */ {"MXSALB", "Maximum snow albedo [%]"},
+      /* 160 */ {"SOILL", "Liquid volumetric soil moisture (non-frozen) [fraction]"},
+      /* 161 */ {"ASNOW", "Frozen precipitation (e.g. snowfall) [kg/m^2]"},
+      /* 162 */ {"ARAIN", "Liquid precipitation (rainfall) [kg/m^2]"},
+      /* 163 */ {"GWREC", "Groundwater recharge [kg/m^2]"},
+      /* 164 */ {"QREC", "Flood plain recharge [kg/m^2]"},
+      /* 165 */ {"SNOWT", "Snow temperature, depth-avg [K]"},
+      /* 166 */ {"VBDSF", "Visible beam downward solar flux [W/m^2]"},
+      /* 167 */ {"VDDSF", "Visible diffuse downward solar flux [W/m^2]"},
+      /* 168 */ {"NBDSF", "Near IR beam downward solar flux [W/m^2]"},
+      /* 169 */ {"NDDSF", "Near IR diffuse downward solar flux [W/m^2]"},
+      /* 170 */ {"SNFALB", "Snow-free albedo [%]"},
+      /* 171 */ {"RLYRS", "Number of soil layers in root zone [non-dim]"},
+      /* 172 */ {"FLX", "Momentum flux N/m2 [M]"},
+      /* 173 */ {"LMH", "Mass point model surface [non-dim]"},
+      /* 174 */ {"LMV", "Velocity point model surface [non-dim]"},
+      /* 175 */ {"MLYNO", "Model layer number (from bottom up) [non-dim]"},
+      /* 176 */ {"NLAT", "Latitude (-90 to +90) [deg]"},
+      /* 177 */ {"ELON", "East longitude (0-360) [deg]"},
+      /* 178 */ {"ICMR", "Ice mixing ratio [kg/kg]"},
+      /* 179 */ {"ACOND", "Aerodynamic conductance [m/s]"},
+      /* 180 */ {"SNOAG", "Snow age [s]"},
+      /* 181 */ {"CCOND", "Canopy conductance [m/s]"},
+      /* 182 */ {"LAI", "Leaf area index (0-9) [non-dim]"},
+      /* 183 */ {"SFCRH", "Roughness length for heat [m]"},
+      /* 184 */ {"SALBD", "Snow albedo (over snow cover area only) [%]"},
+      /* 185 */ {"var185", "undefined"},
+      /* 186 */ {"var186", "undefined"},
+      /* 187 */ {"NDVI", "Normalized Difference Vegetation Index []"},
+      /* 188 */ {"DRIP", "Rate of water dropping from canopy to gnd [kg/m^2]"},
+      /* 189 */ {"LANDN", "Land cover (nearest neighbor) [sea=0,land=1]"},
+      /* 190 */ {"HLCY", "Storm relative helicity [m^2/s^2]"},
+      /* 191 */ {"NLATN", "Latitude (nearest neigbhbor) (-90 to +90) [deg]"},
+      /* 192 */ {"ELONN", "East longitude (nearest neigbhbor) (0-360) [deg]"},
+      /* 193 */ {"var193", "undefined"},
+      /* 194 */ {"CPOFP", "Prob. of frozen precipitation [%]"},
+      /* 195 */ {"var195", "undefined"},
+      /* 196 */ {"USTM", "u-component of storm motion [m/s]"},
+      /* 197 */ {"VSTM", "v-component of storm motion [m/s]"},
+      /* 198 */ {"SBSNO", "Sublimation (evaporation from snow) [W/m^2]"},
+      /* 199 */ {"EVBS", "Direct evaporation from bare soil [W/m^2]"},
+      /* 200 */ {"EVCW", "Canopy water evaporation [W/m^2]"},
+      /* 201 */ {"var201", "undefined"},
+      /* 202 */ {"APCPN", "Total precipitation (nearest grid point) [kg/m^2]"},
+      /* 203 */ {"RSMIN", "Minimal stomatal resistance [s/m]"},
+      /* 204 */ {"DSWRF", "Downward shortwave radiation flux [W/m^2]"},
+      /* 205 */ {"DLWRF", "Downward longwave radiation flux [W/m^2]"},
+      /* 206 */ {"ACPCPN", "Convective precipitation (nearest grid point) [kg/m^2]"},
+      /* 207 */ {"MSTAV", "Moisture availability [%]"},
+      /* 208 */ {"SFEXC", "Exchange coefficient [(kg/m^3)(m/s)]"},
+      /* 209 */ {"var209", "undefined"},
+      /* 210 */ {"TRANS", "Transpiration [W/m^2]"},
+      /* 211 */ {"USWRF", "Upward short wave radiation flux [W/m^2]"},
+      /* 212 */ {"ULWRF", "Upward long wave radiation flux [W/m^2]"},
+      /* 213 */ {"CDLYR", "Non-convective cloud [%]"},
+      /* 214 */ {"CPRAT", "Convective precip. rate [kg/m^2/s]"},
+      /* 215 */ {"var215", "undefined"},
+      /* 216 */ {"TTRAD", "Temp. tendency by all radiation [K/s]"},
+      /* 217 */ {"var217", "undefined"},
+      /* 218 */ {"HGTN", "Geopotential Height (nearest grid point) [gpm]"},
+      /* 219 */ {"WILT", "Wilting point [fraction]"},
+      /* 220 */ {"FLDCP", "Field Capacity [fraction]"},
+      /* 221 */ {"HPBL", "Planetary boundary layer height [m]"},
+      /* 222 */ {"SLTYP", "Surface slope type [Index]"},
+      /* 223 */ {"CNWAT", "Plant canopy surface water [kg/m^2]"},
+      /* 224 */ {"SOTYP", "Soil type [Index]"},
+      /* 225 */ {"VGTYP", "Vegetation type [Index]"},
+      /* 226 */ {"BMIXL", "Blackadars mixing length scale [m]"},
+      /* 227 */ {"AMIXL", "Asymptotic mixing length scale [m]"},
+      /* 228 */ {"PEVAP", "Potential evaporation [kg/m^2]"},
+      /* 229 */ {"SNOHF", "Snow phase-change heat flux [W/m^2]"},
+      /* 230 */ {"SMREF", "Transpiration stress-onset (soil moisture) [fraction]"},
+      /* 231 */ {"SMDRY", "Direct evaporation cease (soil moisture) [fraction]"},
+      /* 232 */ {"WVINC", "water vapor added by precip assimilation [kg/m^2]"},
+      /* 233 */ {"WCINC", "water condensate added by precip assimilaition [kg/m^2]"},
+      /* 234 */ {"BGRUN", "Subsurface runoff (baseflow) [kg/m^2]"},
+      /* 235 */ {"SSRUN", "Surface runoff (non-infiltrating) [kg/m^2]"},
+      /* 236 */ {"var236", "undefined"},
+      /* 237 */ {"WVCONV", "Water vapor flux convergence (vertical int) [kg/m^2]"},
+      /* 238 */ {"SNOWC", "Snow cover [%]"},
+      /* 239 */ {"SNOT", "Snow temperature [K]"},
+      /* 240 */ {"POROS", "Soil porosity [fraction]"},
+      /* 241 */ {"WCCONV", "Water condensate flux convergence (vertical int) [kg/m^2]"},
+      /* 242 */ {"WVUFLX", "Water vapor zonal flux (vertical int)[kg/m]"},
+      /* 243 */ {"WVVFLX", "Water vapor meridional flux (vertical int) [kg/m]"},
+      /* 244 */ {"WCUFLX", "Water condensate zonal flux (vertical int) [kg/m]"},
+      /* 245 */ {"WCVFLX", "Water condensate meridional flux (vertical int) [kg/m]"},
+      /* 246 */ {"RCS", "Solar parameter in canopy conductance [fraction]"},
+      /* 247 */ {"RCT", "Temperature parameter in canopy conductance [fraction]"},
+      /* 248 */ {"RCQ", "Humidity parameter in canopy conductance [fraction]"},
+      /* 249 */ {"RCSOL", "Soil moisture parameter in canopy conductance [fraction]"},
+      /* 250 */ {"SWHR", "Solar radiative heating [K/s]"},
+      /* 251 */ {"LWHR", "Longwave radiative heating [K/s]"},
+      /* 252 */ {"CD", "Surface drag coefficient [non-dim]"},
+      /* 253 */ {"FRICV", "Surface friction velocity [m/s]"},
+      /* 254 */ {"RI", "Richardson number [non-dim]"},
+      /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/nceptable_opn.c b/wrfv2_fire/external/io_grib1/WGRIB/nceptable_opn.c
new file mode 100644
index 00000000..7d2e505c
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/nceptable_opn.c
@@ -0,0 +1,267 @@
+#include "cnames.h"
+
+/*
+ * parameter table for NCEP (operations)
+ * center = 7, subcenter != 2 parameter table = 1, 2, 3 etc
+ * note: see reanalysis parameter table for problems
+ * updated 3/2003
+ */
+
+struct ParmTable parm_table_ncep_opn[256] = {
+      /* 0 */ {"var0", "undefined"},
+      /* 1 */ {"PRES", "Pressure [Pa]"},
+      /* 2 */ {"PRMSL", "Pressure reduced to MSL [Pa]"},
+      /* 3 */ {"PTEND", "Pressure tendency [Pa/s]"},
+      /* 4 */ {"PVORT", "Pot. vorticity [km^2/kg/s]"},
+      /* 5 */ {"ICAHT", "ICAO Standard Atmosphere Reference Height [M]"},
+      /* 6 */ {"GP", "Geopotential [m^2/s^2]"},
+      /* 7 */ {"HGT", "Geopotential height [gpm]"},
+      /* 8 */ {"DIST", "Geometric height [m]"},
+      /* 9 */ {"HSTDV", "Std dev of height [m]"},
+      /* 10 */ {"TOZNE", "Total ozone [Dobson]"},
+      /* 11 */ {"TMP", "Temp. [K]"},
+      /* 12 */ {"VTMP", "Virtual temp. [K]"},
+      /* 13 */ {"POT", "Potential temp. [K]"},
+      /* 14 */ {"EPOT", "Pseudo-adiabatic pot. temp. [K]"},
+      /* 15 */ {"TMAX", "Max. temp. [K]"},
+      /* 16 */ {"TMIN", "Min. temp. [K]"},
+      /* 17 */ {"DPT", "Dew point temp. [K]"},
+      /* 18 */ {"DEPR", "Dew point depression [K]"},
+      /* 19 */ {"LAPR", "Lapse rate [K/m]"},
+      /* 20 */ {"VIS", "Visibility [m]"},
+      /* 21 */ {"RDSP1", "Radar spectra (1) [non-dim]"},
+      /* 22 */ {"RDSP2", "Radar spectra (2) [non-dim]"},
+      /* 23 */ {"RDSP3", "Radar spectra (3) [non-dim]"},
+      /* 24 */ {"PLI", "Parcel lifted index (to 500 hPa) [K]"},
+      /* 25 */ {"TMPA", "Temp. anomaly [K]"},
+      /* 26 */ {"PRESA", "Pressure anomaly [Pa]"},
+      /* 27 */ {"GPA", "Geopotential height anomaly [gpm]"},
+      /* 28 */ {"WVSP1", "Wave spectra (1) [non-dim]"},
+      /* 29 */ {"WVSP2", "Wave spectra (2) [non-dim]"},
+      /* 30 */ {"WVSP3", "Wave spectra (3) [non-dim]"},
+      /* 31 */ {"WDIR", "Wind direction [deg]"},
+      /* 32 */ {"WIND", "Wind speed [m/s]"},
+      /* 33 */ {"UGRD", "u wind [m/s]"},
+      /* 34 */ {"VGRD", "v wind [m/s]"},
+      /* 35 */ {"STRM", "Stream function [m^2/s]"},
+      /* 36 */ {"VPOT", "Velocity potential [m^2/s]"},
+      /* 37 */ {"MNTSF", "Montgomery stream function [m^2/s^2]"},
+      /* 38 */ {"SGCVV", "Sigma coord. vertical velocity [/s]"},
+      /* 39 */ {"VVEL", "Pressure vertical velocity [Pa/s]"},
+      /* 40 */ {"DZDT", "Geometric vertical velocity [m/s]"},
+      /* 41 */ {"ABSV", "Absolute vorticity [/s]"},
+      /* 42 */ {"ABSD", "Absolute divergence [/s]"},
+      /* 43 */ {"RELV", "Relative vorticity [/s]"},
+      /* 44 */ {"RELD", "Relative divergence [/s]"},
+      /* 45 */ {"VUCSH", "Vertical u shear [/s]"},
+      /* 46 */ {"VVCSH", "Vertical v shear [/s]"},
+      /* 47 */ {"DIRC", "Direction of current [deg]"},
+      /* 48 */ {"SPC", "Speed of current [m/s]"},
+      /* 49 */ {"UOGRD", "u of current [m/s]"},
+      /* 50 */ {"VOGRD", "v of current [m/s]"},
+      /* 51 */ {"SPFH", "Specific humidity [kg/kg]"},
+      /* 52 */ {"RH", "Relative humidity [%]"},
+      /* 53 */ {"MIXR", "Humidity mixing ratio [kg/kg]"},
+      /* 54 */ {"PWAT", "Precipitable water [kg/m^2]"},
+      /* 55 */ {"VAPP", "Vapor pressure [Pa]"},
+      /* 56 */ {"SATD", "Saturation deficit [Pa]"},
+      /* 57 */ {"EVP", "Evaporation [kg/m^2]"},
+      /* 58 */ {"CICE", "Cloud Ice [kg/m^2]"},
+      /* 59 */ {"PRATE", "Precipitation rate [kg/m^2/s]"},
+      /* 60 */ {"TSTM", "Thunderstorm probability [%]"},
+      /* 61 */ {"APCP", "Total precipitation [kg/m^2]"},
+      /* 62 */ {"NCPCP", "Large scale precipitation [kg/m^2]"},
+      /* 63 */ {"ACPCP", "Convective precipitation [kg/m^2]"},
+      /* 64 */ {"SRWEQ", "Snowfall rate water equiv. [kg/m^2/s]"},
+      /* 65 */ {"WEASD", "Accum. snow [kg/m^2]"},
+      /* 66 */ {"SNOD", "Snow depth [m]"},
+      /* 67 */ {"MIXHT", "Mixed layer depth [m]"},
+      /* 68 */ {"TTHDP", "Transient thermocline depth [m]"},
+      /* 69 */ {"MTHD", "Main thermocline depth [m]"},
+      /* 70 */ {"MTHA", "Main thermocline anomaly [m]"},
+      /* 71 */ {"TCDC", "Total cloud cover [%]"},
+      /* 72 */ {"CDCON", "Convective cloud cover [%]"},
+      /* 73 */ {"LCDC", "Low level cloud cover [%]"},
+      /* 74 */ {"MCDC", "Mid level cloud cover [%]"},
+      /* 75 */ {"HCDC", "High level cloud cover [%]"},
+      /* 76 */ {"CWAT", "Cloud water [kg/m^2]"},
+      /* 77 */ {"BLI", "Best lifted index (to 500 hPa) [K]"},
+      /* 78 */ {"SNOC", "Convective snow [kg/m^2]"},
+      /* 79 */ {"SNOL", "Large scale snow [kg/m^2]"},
+      /* 80 */ {"WTMP", "Water temp. [K]"},
+      /* 81 */ {"LAND", "Land cover (land=1;sea=0) [fraction]"},
+      /* 82 */ {"DSLM", "Deviation of sea level from mean [m]"},
+      /* 83 */ {"SFCR", "Surface roughness [m]"},
+      /* 84 */ {"ALBDO", "Albedo [%]"},
+      /* 85 */ {"TSOIL", "Soil temp. [K]"},
+      /* 86 */ {"SOILM", "Soil moisture content [kg/m^2]"},
+      /* 87 */ {"VEG", "Vegetation [%]"},
+      /* 88 */ {"SALTY", "Salinity [kg/kg]"},
+      /* 89 */ {"DEN", "Density [kg/m^3]"},
+      /* 90 */ {"WATR", "Water runoff [kg/m^2]"},
+      /* 91 */ {"ICEC", "Ice concentration (ice=1;no ice=0) [fraction]"},
+      /* 92 */ {"ICETK", "Ice thickness [m]"},
+      /* 93 */ {"DICED", "Direction of ice drift [deg]"},
+      /* 94 */ {"SICED", "Speed of ice drift [m/s]"},
+      /* 95 */ {"UICE", "u of ice drift [m/s]"},
+      /* 96 */ {"VICE", "v of ice drift [m/s]"},
+      /* 97 */ {"ICEG", "Ice growth rate [m/s]"},
+      /* 98 */ {"ICED", "Ice divergence [/s]"},
+      /* 99 */ {"SNOM", "Snow melt [kg/m^2]"},
+      /* 100 */ {"HTSGW", "Sig height of wind waves and swell [m]"},
+      /* 101 */ {"WVDIR", "Direction of wind waves [deg]"},
+      /* 102 */ {"WVHGT", "Sig height of wind waves [m]"},
+      /* 103 */ {"WVPER", "Mean period of wind waves [s]"},
+      /* 104 */ {"SWDIR", "Direction of swell waves [deg]"},
+      /* 105 */ {"SWELL", "Sig height of swell waves [m]"},
+      /* 106 */ {"SWPER", "Mean period of swell waves [s]"},
+      /* 107 */ {"DIRPW", "Primary wave direction [deg]"},
+      /* 108 */ {"PERPW", "Primary wave mean period [s]"},
+      /* 109 */ {"DIRSW", "Secondary wave direction [deg]"},
+      /* 110 */ {"PERSW", "Secondary wave mean period [s]"},
+      /* 111 */ {"NSWRS", "Net short wave (surface) [W/m^2]"},
+      /* 112 */ {"NLWRS", "Net long wave (surface) [W/m^2]"},
+      /* 113 */ {"NSWRT", "Net short wave (top) [W/m^2]"},
+      /* 114 */ {"NLWRT", "Net long wave (top) [W/m^2]"},
+      /* 115 */ {"LWAVR", "Long wave [W/m^2]"},
+      /* 116 */ {"SWAVR", "Short wave [W/m^2]"},
+      /* 117 */ {"GRAD", "Global radiation [W/m^2]"},
+      /* 118 */ {"BRTMP", "Brightness temperature [K]"},
+      /* 119 */ {"LWRAD", "Radiance with respect to wave no. [W/m/sr]"},
+      /* 120 */ {"SWRAD", "Radiance with respect ot wave len. [W/m^3/sr]"},
+      /* 121 */ {"LHTFL", "Latent heat flux [W/m^2]"},
+      /* 122 */ {"SHTFL", "Sensible heat flux [W/m^2]"},
+      /* 123 */ {"BLYDP", "Boundary layer dissipation [W/m^2]"},
+      /* 124 */ {"UFLX", "Zonal momentum flux [N/m^2]"},
+      /* 125 */ {"VFLX", "Meridional momentum flux [N/m^2]"},
+      /* 126 */ {"WMIXE", "Wind mixing energy [J]"},
+      /* 127 */ {"IMGD", "Image data []"},
+      /* 128 */ {"MSLSA", "Mean sea level pressure (Std Atm) [Pa]"},
+      /* 129 */ {"MSLMA", "Mean sea level pressure (MAPS) [Pa]"},
+      /* 130 */ {"MSLET", "Mean sea level pressure (ETA model) [Pa]"},
+      /* 131 */ {"LFTX", "Surface lifted index [K]"},
+      /* 132 */ {"4LFTX", "Best (4-layer) lifted index [K]"},
+      /* 133 */ {"KX", "K index [K]"},
+      /* 134 */ {"SX", "Sweat index [K]"},
+      /* 135 */ {"MCONV", "Horizontal moisture divergence [kg/kg/s]"},
+      /* 136 */ {"VWSH", "Vertical speed shear [1/s]"},
+      /* 137 */ {"TSLSA", "3-hr pressure tendency (Std Atmos Red) [Pa/s]"},
+      /* 138 */ {"BVF2", "Brunt-Vaisala frequency^2 [1/s^2]"},
+      /* 139 */ {"PVMW", "Potential vorticity (mass-weighted) [1/s/m]"},
+      /* 140 */ {"CRAIN", "Categorical rain [yes=1;no=0]"},
+      /* 141 */ {"CFRZR", "Categorical freezing rain [yes=1;no=0]"},
+      /* 142 */ {"CICEP", "Categorical ice pellets [yes=1;no=0]"},
+      /* 143 */ {"CSNOW", "Categorical snow [yes=1;no=0]"},
+      /* 144 */ {"SOILW", "Volumetric soil moisture [fraction]"},
+      /* 145 */ {"PEVPR", "Potential evaporation rate [W/m^2]"},
+      /* 146 */ {"CWORK", "Cloud work function [J/kg]"},
+      /* 147 */ {"U-GWD", "Zonal gravity wave stress [N/m^2]"},
+      /* 148 */ {"V-GWD", "Meridional gravity wave stress [N/m^2]"},
+      /* 149 */ {"PV", "Potential vorticity [m^2/s/kg]"},
+      /* 150 */ {"COVMZ", "Covariance between u and v [m^2/s^2]"},
+      /* 151 */ {"COVTZ", "Covariance between u and T [K*m/s]"},
+      /* 152 */ {"COVTM", "Covariance between v and T [K*m/s]"},
+      /* 153 */ {"CLWMR", "Cloud water [kg/kg]"},
+      /* 154 */ {"O3MR", "Ozone mixing ratio [kg/kg]"},
+      /* 155 */ {"GFLUX", "Ground heat flux [W/m^2]"},
+      /* 156 */ {"CIN", "Convective inhibition [J/kg]"},
+      /* 157 */ {"CAPE", "Convective Avail. Pot. Energy [J/kg]"},
+      /* 158 */ {"TKE", "Turbulent kinetic energy [J/kg]"},
+      /* 159 */ {"CONDP", "Lifted parcel condensation pressure [Pa]"},
+      /* 160 */ {"CSUSF", "Clear sky upward solar flux [W/m^2]"},
+      /* 161 */ {"CSDSF", "Clear sky downward solar flux [W/m^2]"},
+      /* 162 */ {"CSULF", "Clear sky upward long wave flux [W/m^2]"},
+      /* 163 */ {"CSDLF", "Clear sky downward long wave flux [W/m^2]"},
+      /* 164 */ {"CFNSF", "Cloud forcing net solar flux [W/m^2]"},
+      /* 165 */ {"CFNLF", "Cloud forcing net long wave flux [W/m^2]"},
+      /* 166 */ {"VBDSF", "Visible beam downward solar flux [W/m^2]"},
+      /* 167 */ {"VDDSF", "Visible diffuse downward solar flux [W/m^2]"},
+      /* 168 */ {"NBDSF", "Near IR beam downward solar flux [W/m^2]"},
+      /* 169 */ {"NDDSF", "Near IR diffuse downward solar flux [W/m^2]"},
+      /* 170 */ {"RWMR", "Rain water mixing ratio [kg/kg]"},
+      /* 171 */ {"SNMR", "Snow mixing ratio [kg/kg]"},
+      /* 172 */ {"MFLX", "Momentum flux [N/m^2]"},
+      /* 173 */ {"LMH", "Mass point model surface [non-dim]"},
+      /* 174 */ {"LMV", "Velocity point model surface [non-dim]"},
+      /* 175 */ {"MLYNO", "Model layer number (from bottom up) [non-dim]"},
+      /* 176 */ {"NLAT", "Latitude (-90 to +90) [deg]"},
+      /* 177 */ {"ELON", "East longitude (0-360) [deg]"},
+      /* 178 */ {"ICMR", "Ice mixing ratio [kg/kg]"},
+      /* 179 */ {"GRMR", "Graupel mixing ratio [kg/kg]"},
+      /* 180 */ {"GUST", "Surface wind gust [m/s]"},
+      /* 181 */ {"LPSX", "x-gradient of log pressure [1/m]"},
+      /* 182 */ {"LPSY", "y-gradient of log pressure [1/m]"},
+      /* 183 */ {"HGTX", "x-gradient of height [m/m]"},
+      /* 184 */ {"HGTY", "y-gradient of height [m/m]"},
+      /* 185 */ {"TURB", "Turbulence SIGMET/AIRMET [non-dim]"},
+      /* 186 */ {"ICNG", "Icing SIGMET/AIRMET [non-dim]"},
+      /* 187 */ {"LTNG", "Lightning [non-dim]"},
+      /* 188 */ {"DRIP", "Rate of water dropping from canopy to gnd [kg/m^2]"},
+      /* 189 */ {"VPTMP", "Virtual pot. temp. [K]"},
+      /* 190 */ {"HLCY", "Storm relative helicity [m^2/s^2]"},
+      /* 191 */ {"PROB", "Prob. from ensemble [non-dim]"},
+      /* 192 */ {"PROBN", "Prob. from ensemble norm. to clim. expect. [non-dim]"},
+      /* 193 */ {"POP", "Prob. of precipitation [%]"},
+      /* 194 */ {"CPOFP", "Prob. of frozen precipitation [%]"},
+      /* 195 */ {"CPOZP", "Prob. of freezing precipitation [%]"},
+      /* 196 */ {"USTM", "u-component of storm motion [m/s]"},
+      /* 197 */ {"VSTM", "v-component of storm motion [m/s]"},
+      /* 198 */ {"NCIP", "No. concen. ice particles []"},
+      /* 199 */ {"EVBS", "Direct evaporation from bare soil [W/m^2]"},
+      /* 200 */ {"EVCW", "Canopy water evaporation [W/m^2]"},
+      /* 201 */ {"ICWAT", "Ice-free water surface [%]"},
+      /* 202 */ {"CWDI", "Convective weather detection index []"},
+      /* 203 */ {"VAFTAD", "VAFTAD?? [??]"},
+      /* 204 */ {"DSWRF", "Downward short wave flux [W/m^2]"},
+      /* 205 */ {"DLWRF", "Downward long wave flux [W/m^2]"},
+      /* 206 */ {"UVI", "Ultraviolet index [W/m^2]"},
+      /* 207 */ {"MSTAV", "Moisture availability [%]"},
+      /* 208 */ {"SFEXC", "Exchange coefficient [(kg/m^3)(m/s)]"},
+      /* 209 */ {"MIXLY", "No. of mixed layers next to surface [integer]"},
+      /* 210 */ {"TRANS", "Transpiration [W/m^2]"},
+      /* 211 */ {"USWRF", "Upward short wave flux [W/m^2]"},
+      /* 212 */ {"ULWRF", "Upward long wave flux [W/m^2]"},
+      /* 213 */ {"CDLYR", "Non-convective cloud [%]"},
+      /* 214 */ {"CPRAT", "Convective precip. rate [kg/m^2/s]"},
+      /* 215 */ {"TTDIA", "Temp. tendency by all physics [K/s]"},
+      /* 216 */ {"TTRAD", "Temp. tendency by all radiation [K/s]"},
+      /* 217 */ {"TTPHY", "Temp. tendency by non-radiation physics [K/s]"},
+      /* 218 */ {"PREIX", "Precip index (0.0-1.00) [fraction]"},
+      /* 219 */ {"TSD1D", "Std. dev. of IR T over 1x1 deg area [K]"},
+      /* 220 */ {"NLGSP", "Natural log of surface pressure [ln(kPa)]"},
+      /* 221 */ {"HPBL", "Planetary boundary layer height [m]"},
+      /* 222 */ {"5WAVH", "5-wave geopotential height [gpm]"},
+      /* 223 */ {"CNWAT", "Plant canopy surface water [kg/m^2]"},
+      /* 224 */ {"SOTYP", "Soil type (Zobler) [0..9]"},
+      /* 225 */ {"VGTYP", "Vegetation type (as in SiB) [0..13]"},
+      /* 226 */ {"BMIXL", "Blackadar's mixing length scale [m]"},
+      /* 227 */ {"AMIXL", "Asymptotic mixing length scale [m]"},
+      /* 228 */ {"PEVAP", "Pot. evaporation [kg/m^2]"},
+      /* 229 */ {"SNOHF", "Snow phase-change heat flux [W/m^2]"},
+      /* 230 */ {"5WAVA", "5-wave geopot. height anomaly [gpm]"},
+      /* 231 */ {"MFLUX", "Convective cloud mass flux [Pa/s]"},
+      /* 232 */ {"DTRF", "Downward total radiation flux [W/m^2]"},
+      /* 233 */ {"UTRF", "Upward total radiation flux [W/m^2]"},
+      /* 234 */ {"BGRUN", "Baseflow-groundwater runoff [kg/m^2]"},
+      /* 235 */ {"SSRUN", "Storm surface runoff [kg/m^2]"},
+      /* 236 */ {"SIPD", "Supercooled large droplet (SLD) icing pot. diagn. []"},
+      /* 237 */ {"O3TOT", "Total ozone [kg/m^2]"},
+      /* 238 */ {"SNOWC", "Snow cover [%]"},
+      /* 239 */ {"SNOT", "Snow temp. [K]"},
+      /* 240 */ {"COVTW", "Covariance T and w [K*m/s]"},
+      /* 241 */ {"LRGHR", "Large scale condensation heating [K/s]"},
+      /* 242 */ {"CNVHR", "Deep convective heating [K/s]"},
+      /* 243 */ {"CNVMR", "Deep convective moistening [kg/kg/s]"},
+      /* 244 */ {"SHAHR", "Shallow convective heating [K/s]"},
+      /* 245 */ {"SHAMR", "Shallow convective moistening [kg/kg/s]"},
+      /* 246 */ {"VDFHR", "Vertical diffusion heating [K/s]"},
+      /* 247 */ {"VDFUA", "Vertical diffusion zonal accel [m/s^2]"},
+      /* 248 */ {"VDFVA", "Vertical diffusion meridional accel [m/s^2]"},
+      /* 249 */ {"VDFMR", "Vertical diffusion moistening [kg/kg/s]"},
+      /* 250 */ {"SWHR", "Solar radiative heating [K/s]"},
+      /* 251 */ {"LWHR", "Longwave radiative heating [K/s]"},
+      /* 252 */ {"CD", "Drag coefficient [non-dim]"},
+      /* 253 */ {"FRICV", "Friction velocity [m/s]"},
+      /* 254 */ {"RI", "Richardson number [non-dim]"},
+      /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/nceptable_reanal.c b/wrfv2_fire/external/io_grib1/WGRIB/nceptable_reanal.c
new file mode 100644
index 00000000..b82401be
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/nceptable_reanal.c
@@ -0,0 +1,275 @@
+#include "cnames.h"
+
+/*
+ * parameter table for the NCEP/NCAR Reanalysis Project
+ * center = 7, subcenter = 0/2, parameter table = 1/2
+ * in a SNAFU the operational and reanalysis tables diverged
+ * and both retained the same parameter table numbers (1,2)
+ *
+ * some of the Reanalysis files have subcenter=2 while others
+ * use subcenter=0  (subcenter field is not standard (7/97))
+ *
+ * Some ways to tell Reanalysis files from OPN files
+ *  Reanalysis: always generated by process 80 - T62 28 level model
+ * Original subcenter=0 Reanalysis files had 
+ *  2.5x2.5 (144x73) lat-long grid or 192x94 Gaussian grid (PDS grid=255?)
+ */
+
+struct ParmTable parm_table_ncep_reanal[256] = {
+   /* 0 */ {"var0", "undefined"},
+   /* 1 */ {"PRES", "Pressure [Pa]"},
+   /* 2 */ {"PRMSL", "Pressure reduced to MSL [Pa]"},
+   /* 3 */ {"PTEND", "Pressure tendency [Pa/s]"},
+   /* 4 */ {"var4", "undefined"},
+   /* 5 */ {"var5", "undefined"},
+   /* 6 */ {"GP", "Geopotential [m^2/s^2]"},
+   /* 7 */ {"HGT", "Geopotential height [gpm]"},
+   /* 8 */ {"DIST", "Geometric height [m]"},
+   /* 9 */ {"HSTDV", "Std dev of height [m]"},
+   /* 10 */ {"HVAR", "Variance of height [m^2]"},
+   /* 11 */ {"TMP", "Temp. [K]"},
+   /* 12 */ {"VTMP", "Virtual temp. [K]"},
+   /* 13 */ {"POT", "Potential temp. [K]"},
+   /* 14 */ {"EPOT", "Pseudo-adiabatic pot. temp. [K]"},
+   /* 15 */ {"TMAX", "Max. temp. [K]"},
+   /* 16 */ {"TMIN", "Min. temp. [K]"},
+   /* 17 */ {"DPT", "Dew point temp. [K]"},
+   /* 18 */ {"DEPR", "Dew point depression [K]"},
+   /* 19 */ {"LAPR", "Lapse rate [K/m]"},
+   /* 20 */ {"VISIB", "Visibility [m]"},
+   /* 21 */ {"RDSP1", "Radar spectra (1) [non-dim]"},
+   /* 22 */ {"RDSP2", "Radar spectra (2) [non-dim]"},
+   /* 23 */ {"RDSP3", "Radar spectra (3) [non-dim]"},
+   /* 24 */ {"var24", "undefined"},
+   /* 25 */ {"TMPA", "Temp. anomaly [K]"},
+   /* 26 */ {"PRESA", "Pressure anomaly [Pa]"},
+   /* 27 */ {"GPA", "Geopotential height anomaly [gpm]"},
+   /* 28 */ {"WVSP1", "Wave spectra (1) [non-dim]"},
+   /* 29 */ {"WVSP2", "Wave spectra (2) [non-dim]"},
+   /* 30 */ {"WVSP3", "Wave spectra (3) [non-dim]"},
+   /* 31 */ {"WDIR", "Wind direction [deg]"},
+   /* 32 */ {"WIND", "Wind speed [m/s]"},
+   /* 33 */ {"UGRD", "u wind [m/s]"},
+   /* 34 */ {"VGRD", "v wind [m/s]"},
+   /* 35 */ {"STRM", "Stream function [m^2/s]"},
+   /* 36 */ {"VPOT", "Velocity potential [m^2/s]"},
+   /* 37 */ {"MNTSF", "Montgomery stream function [m^2/s^2]"},
+   /* 38 */ {"SGCVV", "Sigma coord. vertical velocity [/s]"},
+   /* 39 */ {"VVEL", "Pressure vertical velocity [Pa/s]"},
+   /* 40 */ {"DZDT", "Geometric vertical velocity [m/s]"},
+   /* 41 */ {"ABSV", "Absolute vorticity [/s]"},
+   /* 42 */ {"ABSD", "Absolute divergence [/s]"},
+   /* 43 */ {"RELV", "Relative vorticity [/s]"},
+   /* 44 */ {"RELD", "Relative divergence [/s]"},
+   /* 45 */ {"VUCSH", "Vertical u shear [/s]"},
+   /* 46 */ {"VVCSH", "Vertical v shear [/s]"},
+   /* 47 */ {"DIRC", "Direction of current [deg]"},
+   /* 48 */ {"SPC", "Speed of current [m/s]"},
+   /* 49 */ {"UOGRD", "u of current [m/s]"},
+   /* 50 */ {"VOGRD", "v of current [m/s]"},
+   /* 51 */ {"SPFH", "Specific humidity [kg/kg]"},
+   /* 52 */ {"RH", "Relative humidity [%]"},
+   /* 53 */ {"MIXR", "Humidity mixing ratio [kg/kg]"},
+   /* 54 */ {"PWAT", "Precipitable water [kg/m^2]"},
+   /* 55 */ {"VAPP", "Vapor pressure [Pa]"},
+   /* 56 */ {"SATD", "Saturation deficit [Pa]"},
+   /* 57 */ {"EVP", "Evaporation [kg/m^2]"},
+   /* 58 */ {"CICE", "Cloud Ice [kg/kg]"},
+   /* 59 */ {"PRATE", "Precipitation rate [kg/m^2/s]"},
+   /* 60 */ {"TSTM", "Thunderstorm probability [%]"},
+   /* 61 */ {"APCP", "Total precipitation [kg/m^2]"},
+   /* 62 */ {"NCPCP", "Large scale precipitation [kg/m^2]"},
+   /* 63 */ {"ACPCP", "Convective precipitation [kg/m^2]"},
+   /* 64 */ {"SRWEQ", "Snowfall rate water equiv. [kg/m^2/s]"},
+   /* 65 */ {"WEASD", "Accum. snow [kg/m^2]"},
+   /* 66 */ {"SNOD", "Snow depth [m]"},
+   /* 67 */ {"MIXHT", "Mixed layer depth [m]"},
+   /* 68 */ {"TTHDP", "Transient thermocline depth [m]"},
+   /* 69 */ {"MTHD", "Main thermocline depth [m]"},
+   /* 70 */ {"MTHA", "Main thermocline anomaly [m]"},
+   /* 71 */ {"TCDC", "Total cloud cover [%]"},
+   /* 72 */ {"CDCON", "Convective cloud cover [%]"},
+   /* 73 */ {"LCDC", "Low level cloud cover [%]"},
+   /* 74 */ {"MCDC", "Mid level cloud cover [%]"},
+   /* 75 */ {"HCDC", "High level cloud cover [%]"},
+   /* 76 */ {"CWAT", "Cloud water [kg/m^2]"},
+   /* 77 */ {"var77", "undefined"},
+   /* 78 */ {"SNOC", "Convective snow [kg/m^2]"},
+   /* 79 */ {"SNOL", "Large scale snow [kg/m^2]"},
+   /* 80 */ {"WTMP", "Water temp. [K]"},
+   /* 81 */ {"LAND", "Land-sea mask [1=land; 0=sea]"},
+   /* 82 */ {"DSLM", "Deviation of sea level from mean [m]"},
+   /* 83 */ {"SFCR", "Surface roughness [m]"},
+   /* 84 */ {"ALBDO", "Albedo [%]"},
+   /* 85 */ {"TSOIL", "Soil temp. [K]"},
+   /* 86 */ {"SOILM", "Soil moisture content [kg/m^2]"},
+   /* 87 */ {"VEG", "Vegetation [%]"},
+   /* 88 */ {"SALTY", "Salinity [kg/kg]"},
+   /* 89 */ {"DEN", "Density [kg/m^3]"},
+   /* 90 */ {"RUNOF", "Runoff [kg/m^2]"},
+   /* 91 */ {"ICEC", "Ice concentration [ice=1;no ice=0]"},
+   /* 92 */ {"ICETK", "Ice thickness [m]"},
+   /* 93 */ {"DICED", "Direction of ice drift [deg]"},
+   /* 94 */ {"SICED", "Speed of ice drift [m/s]"},
+   /* 95 */ {"UICE", "u of ice drift [m/s]"},
+   /* 96 */ {"VICE", "v of ice drift [m/s]"},
+   /* 97 */ {"ICEG", "Ice growth rate [m/s]"},
+   /* 98 */ {"ICED", "Ice divergence [/s]"},
+   /* 99 */ {"SNOM", "Snow melt [kg/m^2]"},
+   /* 100 */ {"HTSGW", "Sig height of wind waves and swell [m]"},
+   /* 101 */ {"WVDIR", "Direction of wind waves [deg]"},
+   /* 102 */ {"WVHGT", "Sig height of wind waves [m]"},
+   /* 103 */ {"WVPER", "Mean period of wind waves [s]"},
+   /* 104 */ {"SWDIR", "Direction of swell waves [deg]"},
+   /* 105 */ {"SWELL", "Sig height of swell waves [m]"},
+   /* 106 */ {"SWPER", "Mean period of swell waves [s]"},
+   /* 107 */ {"DIRPW", "Primary wave direction [deg]"},
+   /* 108 */ {"PERPW", "Primary wave mean period [s]"},
+   /* 109 */ {"DIRSW", "Secondary wave direction [deg]"},
+   /* 110 */ {"PERSW", "Secondary wave mean period [s]"},
+   /* 111 */ {"NSWRS", "Net short wave (surface) [W/m^2]"},
+   /* 112 */ {"NLWRS", "Net long wave (surface) [W/m^2]"},
+   /* 113 */ {"NSWRT", "Net short wave (top) [W/m^2]"},
+   /* 114 */ {"NLWRT", "Net long wave (top) [W/m^2]"},
+   /* 115 */ {"LWAVR", "Long wave [W/m^2]"},
+   /* 116 */ {"SWAVR", "Short wave [W/m^2]"},
+   /* 117 */ {"GRAD", "Global radiation [W/m^2]"},
+   /* 118 */ {"var118", "undefined"},
+   /* 119 */ {"var119", "undefined"},
+   /* 120 */ {"var120", "undefined"},
+   /* 121 */ {"LHTFL", "Latent heat flux [W/m^2]"},
+   /* 122 */ {"SHTFL", "Sensible heat flux [W/m^2]"},
+   /* 123 */ {"BLYDP", "Boundary layer dissipation [W/m^2]"},
+   /* 124 */ {"UFLX", "Zonal momentum flux [N/m^2]"},
+   /* 125 */ {"VFLX", "Meridional momentum flux [N/m^2]"},
+   /* 126 */ {"WMIXE", "Wind mixing energy [J]"},
+   /* 127 */ {"IMGD", "Image data [integer]"},
+   /* 128 */ {"MSLSA", "Mean sea level pressure (Std Atm) [Pa]"},
+   /* 129 */ {"MSLMA", "Mean sea level pressure (MAPS) [Pa]"},
+   /* 130 */ {"MSLET", "Mean sea level pressure (ETA model) [Pa]"},
+   /* 131 */ {"LFTX", "Surface lifted index [K]"},
+   /* 132 */ {"4LFTX", "Best (4-layer) lifted index [K]"},
+   /* 133 */ {"KX", "K index [K]"},
+   /* 134 */ {"SX", "Sweat index [K]"},
+   /* 135 */ {"MCONV", "Horizontal moisture divergence [kg/kg/s]"},
+   /* 136 */ {"VSSH", "Vertical speed shear [1/s]"},
+   /* 137 */ {"TSLSA", "3-hr pressure tendency [Pa/s]"},
+   /* 138 */ {"BVF2", "Brunt-Vaisala frequency^2 [1/s^2]"},
+   /* 139 */ {"PVMW", "Potential vorticity (mass-weighted) [1/s/m]"},
+   /* 140 */ {"CRAIN", "Categorical rain [yes=1;no=0]"},
+   /* 141 */ {"CFRZR", "Categorical freezing rain [yes=1;no=0]"},
+   /* 142 */ {"CICEP", "Categorical ice pellets [yes=1;no=0]"},
+   /* 143 */ {"CSNOW", "Categorical snow [yes=1;no=0]"},
+   /* 144 */ {"SOILW", "Volumetric soil moisture [fraction]"},
+   /* 145 */ {"PEVPR", "Potential evaporation rate [W/m^2]"},
+   /* 146 */ {"CWORK", "Cloud work function [J/kg]"},
+   /* 147 */ {"U-GWD", "Zonal gravity wave stress [N/m^2]"},
+   /* 148 */ {"V-GWD", "Meridional gravity wave stress [N/m^2]"},
+   /* 149 */ {"PV___", "Potential vorticity [m^2/s/kg]"},
+   /* 150 */ {"var150", "undefined"},
+   /* 151 */ {"var151", "undefined"},
+   /* 152 */ {"var152", "undefined"},
+   /* 153 */ {"MFXDV", "Moisture flux divergence [gr/gr*m/s/m]"},
+   /* 154 */ {"var154", "undefined"},
+   /* 155 */ {"GFLUX", "Ground heat flux [W/m^2]"},
+   /* 156 */ {"CIN", "Convective inhibition [J/kg]"},
+   /* 157 */ {"CAPE", "Convective Avail. Pot. Energy [J/kg]"},
+   /* 158 */ {"TKE", "Turbulent kinetic energy [J/kg]"},
+   /* 159 */ {"CONDP", "Lifted parcel condensation pressure [Pa]"},
+   /* 160 */ {"CSUSF", "Clear sky upward solar flux [W/m^2]"},
+   /* 161 */ {"CSDSF", "Clear sky downward solar flux [W/m^2]"},
+   /* 162 */ {"CSULF", "Clear sky upward long wave flux [W/m^2]"},
+   /* 163 */ {"CSDLF", "Clear sky downward long wave flux [W/m^2]"},
+   /* 164 */ {"CFNSF", "Cloud forcing net solar flux [W/m^2]"},
+   /* 165 */ {"CFNLF", "Cloud forcing net long wave flux [W/m^2]"},
+   /* 166 */ {"VBDSF", "Visible beam downward solar flux [W/m^2]"},
+   /* 167 */ {"VDDSF", "Visible diffuse downward solar flux [W/m^2]"},
+   /* 168 */ {"NBDSF", "Near IR beam downward solar flux [W/m^2]"},
+   /* 169 */ {"NDDSF", "Near IR diffuse downward solar flux [W/m^2]"},
+   /* 170 */ {"USTR", "U wind stress [N/m^2]"},
+   /* 171 */ {"VSTR", "V wind stress [N/m^2]"},
+   /* 172 */ {"MFLX", "Momentum flux [N/m^2]"},
+   /* 173 */ {"LMH", "Mass point model surface [integer]"},
+   /* 174 */ {"LMV", "Velocity point model surface [integer]"},
+   /* 175 */ {"SGLYR", "Nearby model level [integer]"},
+   /* 176 */ {"NLAT", "Latitude [deg]"},
+   /* 177 */ {"ELON", "Longitude [deg]"},
+   /* 178 */ {"UMAS", "Mass weighted u [gm/m*K*s]"},
+   /* 179 */ {"VMAS", "Mass weighted v [gm/m*K*s]"},
+   /* 180 */ {"XPRATE", "corrected precip [kg/m^2/s]"},
+   /* 181 */ {"LPSX", "x-gradient of log pressure [1/m]"},
+   /* 182 */ {"LPSY", "y-gradient of log pressure [1/m]"},
+   /* 183 */ {"HGTX", "x-gradient of height [m/m]"},
+   /* 184 */ {"HGTY", "y-gradient of height [m/m]"},
+   /* 185 */ {"STDZ", "Std dev of Geop. hgt. [m]"},
+   /* 186 */ {"STDU", "Std dev of zonal wind [m/s]"},
+   /* 187 */ {"STDV", "Std dev of meridional wind [m/s]"},
+   /* 188 */ {"STDQ", "Std dev of spec. hum. [gm/gm]"},
+   /* 189 */ {"STDT", "Std dev of temp. [K]"},
+   /* 190 */ {"CBUW", "Covar. u and omega [m/s*Pa/s]"},
+   /* 191 */ {"CBVW", "Covar. v and omega [m/s*Pa/s]"},
+   /* 192 */ {"CBUQ", "Covar. u and specific hum [m/s*gm/gm]"},
+   /* 193 */ {"CBVQ", "Covar. v and specific hum [m/s*gm/gm]"},
+   /* 194 */ {"CBTW", "Covar. T and omega [K*Pa/s]"},
+   /* 195 */ {"CBQW", "Covar. spec. hum and omega [gm/gm*Pa/s]"},
+   /* 196 */ {"CBMZW", "Covar. v and u [m^2/s^2]"},
+   /* 197 */ {"CBTZW", "Covar. u and T [K*m/s]"},
+   /* 198 */ {"CBTMW", "Covar. v and T [K*m/s]"},
+   /* 199 */ {"STDRH", "Std dev of Rel. Hum. [%]"},
+   /* 200 */ {"SDTZ", "Std dev of time tend of geop. hgt [m]"},
+   /* 201 */ {"ICWAT", "Ice-free water surface [%]"},
+   /* 202 */ {"SDTU", "Std dev of time tend of zonal wind [m/s]"},
+   /* 203 */ {"SDTV", "Std dev of time tend of merid wind [m/s]"},
+   /* 204 */ {"DSWRF", "Downward solar radiation flux [W/m^2]"},
+   /* 205 */ {"DLWRF", "Downward long wave flux [W/m^2]"},
+   /* 206 */ {"SDTQ", "Std dev of time tend of spec. hum [gm/gm]"},
+   /* 207 */ {"MSTAV", "Moisture availability [%]"},
+   /* 208 */ {"SFEXC", "Exchange coefficient [kg*m/m^3/s]"},
+   /* 209 */ {"MIXLY", "No. of mixed layers next to sfc [integer]"},
+   /* 210 */ {"SDTT", "Std dev of time tend of temp. [K]"},
+   /* 211 */ {"USWRF", "Upward solar radiation flux [W/m^2]"},
+   /* 212 */ {"ULWRF", "Upward long wave flux [W/m^2]"},
+   /* 213 */ {"CDLYR", "Non-convective cloud [%]"},
+   /* 214 */ {"CPRAT", "Convective precip. rate [kg/m^2/s]"},
+   /* 215 */ {"TTDIA", "Temp. tendency by all physics [K/s]"},
+   /* 216 */ {"TTRAD", "Temp. tendency by all radiation [K/s]"},
+   /* 217 */ {"TTPHY", "Temp. tendency by nonrad physics [K/s]"},
+   /* 218 */ {"PREIX", "Precipitation index [fraction]"},
+   /* 219 */ {"TSD1D", "Std dev of IR T over 1x1 deg area [K]"},
+   /* 220 */ {"NLSGP", "Natural log of surface pressure [ln(kPa)]"},
+   /* 221 */ {"SDTRH", "Std dev of time tend of rel hum [%]"},
+   /* 222 */ {"5WAVH", "5-wave geopotential height [gpm]"},
+   /* 223 */ {"CNWAT", "Plant canopy surface water [kg/m^2]"},
+   /* 224 */ {"PLTRS", "Max. stomato plant resistance [s/m]"},
+   /* 225 */ {"RHCLD", "RH-type cloud cover [%]"},
+   /* 226 */ {"BMIXL", "Blackadar's mixing length scale [m]"},
+   /* 227 */ {"AMIXL", "Asymptotic mixing length scale [m]"},
+   /* 228 */ {"PEVAP", "Pot. evaporation [kg/m^2]"},
+   /* 229 */ {"SNOHF", "Snow melt heat flux [W/m^2]"},
+   /* 230 */ {"SNOEV", "Snow sublimation heat flux [W/m^2]"},
+   /* 231 */ {"MFLUX", "Convective cloud mass flux [Pa/s]"},
+   /* 232 */ {"DTRF", "Downward total radiation flux [W/m^2]"},
+   /* 233 */ {"UTRF", "Upward total radiation flux [W/m^2]"},
+   /* 234 */ {"BGRUN", "Baseflow-groundwater runoff [kg/m^2]"},
+   /* 235 */ {"SSRUN", "Storm surface runoff [kg/m^2]"},
+   /* 236 */ {"var236", "undefined"},
+   /* 237 */ {"OZONE", "Total column ozone [Dobson]"},
+   /* 238 */ {"SNOWC", "Snow cover [%]"},
+   /* 239 */ {"SNOT", "Snow temp. [K]"},
+   /* 240 */ {"GLCR", "Permanent snow points [mask]"},
+   /* 241 */ {"LRGHR", "Large scale condensation heating [K/s]"},
+   /* 242 */ {"CNVHR", "Deep convective heating [K/s]"},
+   /* 243 */ {"CNVMR", "Deep convective moistening [kg/kg/s]"},
+   /* 244 */ {"SHAHR", "Shallow convective heating [K/s]"},
+   /* 245 */ {"SHAMR", "Shallow convective moistening [kg/kg/s]"},
+   /* 246 */ {"VDFHR", "Vertical diffusion heating [K/s]"},
+   /* 247 */ {"VDFUA", "Vertical diffusion zonal accel [m/s^2]"},
+   /* 248 */ {"VDFVA", "Vertical diffusion meridional accel [m/s^2]"},
+   /* 249 */ {"VDFMR", "Vertical diffusion moistening [kg/kg/s]"},
+   /* 250 */ {"SWHR", "Solar radiative heating [K/s]"},
+   /* 251 */ {"LWHR", "Longwave radiative heating [K/s]"},
+   /* 252 */ {"CD", "Drag coefficient [non-dim]"},
+   /* 253 */ {"FRICV", "Friction velocity [m/s]"},
+   /* 254 */ {"RI", "Richardson number [non-dim]"},
+   /* 255 */ {"var255", "undefined"},
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/ombtable.c b/wrfv2_fire/external/io_grib1/WGRIB/ombtable.c
new file mode 100644
index 00000000..1ec14fab
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/ombtable.c
@@ -0,0 +1,265 @@
+#include "cnames.h"
+
+/* parameter table for ocean modeling branch (OMB) of NCEP */
+/* center = 7, subcenter = EMC, parameter table = 128 */
+
+/* 12/31/2001 added REV */
+
+struct ParmTable parm_table_omb[256] = {
+ {"var0", "Reserved"},
+ {"var1", "Reserved"},
+ {"GHz6", "6.6 GHz - K"},
+ {"GHz10", "10.7 GHz - K"},
+ {"GHz18", "18.0 GHz - K"},
+ {"GHz19V", "SSMI 19 GHz, Vertical Polarization - K"},
+ {"GHz19H", "SSMI 19 GHz, Horizontal Polarization - K"},
+ {"GHz21", "21.0 GHz - K"},
+ {"GHz22V", "SSMI 22 GHz, Vertical Polarization - K"},
+ {"GHz37V", "SSMI 37 GHz, Vertical Polarization - K"},
+ {"GHz37H", "SSMI 37 GHz, Horizontal Polarization - K"},
+ {"MSU1", "MSU Ch 1 - 50.30 GHz - K"},
+ {"MSU2", "MSU Ch 2 - 53.74 GHz - K"},
+ {"MSU3", "MSU Ch 3 - 54.96 GHz - K"},
+ {"MSU4", "MSU Ch 4 - 57.95 GHz - K"},
+ {"GHz85V", "SSMI 85 GHz, Vertical Polarization - K"},
+ {"GHz85H", "SSMI 85 GHz, Horizontal Polarization - K"},
+ {"GHz91", "91.65 GHz - K"},
+ {"GHz150", "150 GHz - K"},
+ {"GHz183pm7", "183 +- 7 GHz - K"},
+ {"GHz183pm3", "183 +- 3 GHz - K"},
+ {"GHz183pm1", "183 +- 1 GHz - K"},
+ {"SSMT1C1", "SSM/T1 - ch 1 - K"},
+ {"SSMT1C2", "SSM/T1 - ch 2 - K"},
+ {"SSMT1C3", "SSM/T1 - ch 3 - K"},
+ {"SSMT1C4", "SSM/T1 - ch 4 - K"},
+ {"SSMT1C5", "SSM/T1 - ch 5 - K"},
+ {"SSMT1C6", "SSM/T1 - ch 6 - K"},
+ {"SSMT1C7", "SSM/T1 - ch 7 - K"},
+ {"var29", "Reserved"},
+ {"var30", "Reserved"},
+ {"var31", "Reserved"},
+ {"var32", "Reserved"},
+ {"var33", "Reserved"},
+ {"var34", "Reserved"},
+ {"var35", "Reserved"},
+ {"var36", "Reserved"},
+ {"var37", "Reserved"},
+ {"var38", "Reserved"},
+ {"var39", "Reserved"},
+ {"var40", "Reserved"},
+ {"var41", "Reserved"},
+ {"var42", "Reserved"},
+ {"var43", "Reserved"},
+ {"var44", "Reserved"},
+ {"var45", "Reserved"},
+ {"var46", "Reserved"},
+ {"var47", "Reserved"},
+ {"var48", "Reserved"},
+ {"var49", "Reserved"},
+ {"var50", "Reserved"},
+ {"var51", "Reserved"},
+ {"var52", "Reserved"},
+ {"var53", "Reserved"},
+ {"var54", "Reserved"},
+ {"var55", "Reserved"},
+ {"var56", "Reserved"},
+ {"var57", "Reserved"},
+ {"var58", "Reserved"},
+ {"var59", "Reserved"},
+ {"MI14.95", "HIRS/2 ch 1 - 14.95 micron - K"},
+ {"MI14.71", "HIRS/2, GOES 14.71 micron - K"},
+ {"MI14.49", "HIRS/2 ch 3 - 14.49 micron - K"},
+ {"MI14.37", "GOES I-M - 14.37 micron - K"},
+ {"MI14.22", "HIRS/2 ch 4 - 14.22 micron - K"},
+ {"MI14.06", "GOES I-M - 14.06 micron - K"},
+ {"MI13.97", "HIRS/2 ch 5 - 13.97 micron - K"},
+ {"MI13.64", "HIRS/2, GOES 13.64 micron - K"},
+ {"MI13.37", "GOES I-M - 13.37 micron - K"},
+ {"MI13.35", "HIRS/2 ch 7 - 13.35 micron - K"},
+ {"MI12.66", "GOES I-M - 12.66 micron - K"},
+ {"MI12.02", "GOES I-M - 12.02 micron - K"},
+ {"MI12.00", "AVHRR ch 5 - 12.0 micron - K"},
+ {"MI11.11", "HIRS/2 ch 8 - 11.11 micron - K"},
+ {"MI11.03", "GOES I-M - 11.03 micron - K"},
+ {"MI10.80", "AVHRR ch 4 - 10.8 micron - K"},
+ {"MI9.71", "HIRS/2, GOES - 9.71 micron - K"},
+ {"var77", "Reserved"},
+ {"var78", "Reserved"},
+ {"var79", "Reserved"},
+ {"MI8.16", "HIRS/2 ch 10 - 8.16 micron - K"},
+ {"MI7.43", "GOES I-M - 7.43 micron - K"},
+ {"MI7.33", "HIRS/2 ch 11 - 7.33 micron - K"},
+ {"MI7.02", "GOES I-M - 7.02 micron - K"},
+ {"MI6.72", "HIRS/2 ch 12 - 6.72 micron - K"},
+ {"MI6.51", "GOES I-M - 6.51 micron - K"},
+ {"MI4.57", "HIRS/2, GOES - 4.57 micron - K"},
+ {"MI4.52", "HIRS/2, GOES - 4.52 micron - K"},
+ {"MI4.46", "HIRS/2 ch 15 - 4.46 micron - K"},
+ {"MI4.45", "GOES I-M - 4.45 micron - K"},
+ {"MI4.40", "HIRS/2 ch 16 - 4.40 micron - K"},
+ {"MI4.24", "HIRS/2 ch 17 - 4.24 micron - K"},
+ {"MI4.13", "GOES I-M - 4.13 micron - K"},
+ {"MI4.00", "HIRS/2 ch 18 - 4.00 micron - K"},
+ {"MI8.16", "GOES I-M - 3.98 micron - K"},
+ {"MI8.16", "HIRS/2 Window - 3.76 micron - K"},
+ {"MI8.16", "AVHRR, GOES - 3.74 micron - K"},
+ {"var97", "Reserved"},
+ {"var98", "Reserved"},
+ {"var99", "Reserved"},
+ {"MI0.91", "AVHRR ch 2 - 0.91 micron - K"},
+ {"MI0.696", "GOES I-M - 0.696 micron - K"},
+ {"MI0.69", "HIRS/2 Vis - 0.69 micron - K"},
+ {"MI0.63", "AVHRR ch 1 - 0.63 micron - K"},
+ {"var104", "Reserved"},
+ {"var105", "Reserved"},
+ {"var106", "Reserved"},
+ {"var107", "Reserved"},
+ {"var108", "Reserved"},
+ {"var109", "Reserved"},
+ {"var110", "Reserved"},
+ {"var111", "Reserved"},
+ {"var112", "Reserved"},
+ {"var113", "Reserved"},
+ {"var114", "Reserved"},
+ {"var115", "Reserved"},
+ {"var116", "Reserved"},
+ {"var117", "Reserved"},
+ {"var118", "Reserved"},
+ {"var119", "Reserved"},
+ {"var120", "Reserved"},
+ {"var121", "Reserved"},
+ {"var122", "Reserved"},
+ {"var123", "Reserved"},
+ {"var124", "Reserved"},
+ {"var125", "Reserved"},
+ {"var126", "Reserved"},
+ {"var127", "Reserved"},
+ {"AVDEPTH", "Ocean depth - mean - m"},
+ {"DEPTH", "Ocean depth - instantaneous - m"},
+ {"ELEV", "Ocean surface elevation relative to geoid - m"},
+ {"MXEL24", "Max ocean surface elevation in last 24 hours - m"},
+ {"MNEL24", "Min ocean surface elevation in last 24 hours - m"},
+ {"var133", "Reserved"},
+ {"var134", "Reserved"},
+ {"O2", "Oxygen -Mol/kg"},
+ {"PO4", "PO4 - Mol/kg"},
+ {"NO3", "NO3 - Mol/kg"},
+ {"SiO4", "SiO4 - Mol/kg"},
+ {"CO2aq", "CO2 (aq) - Mol/kg"},
+ {"HCO3", "HCO3 - - Mol/kg"},
+ {"CO3", "CO3 -- - Mol/kg"},
+ {"TCO2", "TCO2 - Mol/kg"},
+ {"TALK", "TALK - Mol/kg"},
+ {"var144", "Reserved"},
+ {"var145", "Reserved"},
+ {"S11", "S11 - 1,1 component of ice stress tensor"},
+ {"S12", "S12 - 1,2 component of ice stress tensor"},
+ {"S22", "S22 - 2,2 component of ice stress tensor"},
+ {"INV1", "T1 - First invariant of stress tensor"},
+ {"INV2", "T2 - Second invariant of stress tensor"},
+ {"var151", "Reserved"},
+ {"var152", "Reserved"},
+ {"var153", "Reserved"},
+ {"var154", "Reserved"},
+ {"WVRGH", "Wave Roughness"},
+ {"WVSTRS", "Wave Stresses"},
+ {"WHITE", "Whitecap coverage"},
+ {"SWDIRWID", "Swell direction width"},
+ {"SWFREWID", "Swell frequency width"},
+ {"WVAGE", "Wave age"},
+ {"PWVAGE", "Physical Wave age"},
+ {"var162", "Reserved"},
+ {"var163", "Reserved"},
+ {"var164", "Reserved"},
+ {"LTURB", "Master length scale (turbulence) - m"},
+ {"var166", "Reserved"},
+ {"var167", "Reserved"},
+ {"var168", "Reserved"},
+ {"var169", "Reserved"},
+ {"AIHFLX", "Net Air-Ice heat flux - W/m^2"},
+ {"AOHFLX", "Net Air-Ocean heat flux - W/m^2"},
+ {"IOHFLX", "Net Ice-Ocean heat flux - W/m^2"},
+ {"IOSFLX", "Net Ice-Ocean salt flux - kg/s"},
+ {"var174", "Reserved"},
+ {"OMLT", "Ocean Mixed Layer Temperature - K"},
+ {"OMLS", "Ocean Mixed Layer Salinity - kg/kg"},
+ {"var177", "Reserved"},
+ {"var178", "Reserved"},
+ {"var179", "Reserved"},
+ {"var180", "Reserved"},
+ {"var181", "Reserved"},
+ {"var182", "Reserved"},
+ {"var183", "Reserved"},
+ {"var184", "Reserved"},
+ {"var185", "Reserved"},
+ {"var186", "Reserved"},
+ {"var187", "Reserved"},
+ {"var188", "Reserved"},
+ {"var189", "Reserved"},
+ {"var190", "Reserved"},
+ {"var191", "Reserved"},
+ {"var192", "Reserved"},
+ {"var193", "Reserved"},
+ {"var194", "Reserved"},
+ {"var195", "Reserved"},
+ {"var196", "Reserved"},
+ {"var197", "Reserved"},
+ {"var198", "Reserved"},
+ {"var199", "Reserved"},
+ {"var200", "Reserved"},
+ {"var201", "Reserved"},
+ {"var202", "Reserved"},
+ {"var203", "Reserved"},
+ {"var204", "Reserved"},
+ {"var205", "Reserved"},
+ {"var206", "Reserved"},
+ {"var207", "Reserved"},
+ {"var208", "Reserved"},
+ {"var209", "Reserved"},
+ {"var210", "Reserved"},
+ {"var211", "Reserved"},
+ {"var212", "Reserved"},
+ {"var213", "Reserved"},
+ {"var214", "Reserved"},
+ {"var215", "Reserved"},
+ {"var216", "Reserved"},
+ {"var217", "Reserved"},
+ {"var218", "Reserved"},
+ {"var219", "Reserved"},
+ {"var220", "Reserved"},
+ {"var221", "Reserved"},
+ {"var222", "Reserved"},
+ {"var223", "Reserved"},
+ {"var224", "Reserved"},
+ {"var225", "Reserved"},
+ {"var226", "Reserved"},
+ {"var227", "Reserved"},
+ {"var228", "Reserved"},
+ {"var229", "Reserved"},
+ {"var230", "Reserved"},
+ {"var231", "Reserved"},
+ {"var232", "Reserved"},
+ {"var233", "Reserved"},
+ {"var234", "Reserved"},
+ {"var235", "Reserved"},
+ {"var236", "Reserved"},
+ {"var237", "Reserved"},
+ {"var238", "Reserved"},
+ {"var239", "Reserved"},
+ {"var240", "Reserved"},
+ {"var241", "Reserved"},
+ {"var242", "Reserved"},
+ {"var243", "Reserved"},
+ {"var244", "Reserved"},
+ {"var245", "Reserved"},
+ {"var246", "Reserved"},
+ {"var247", "Reserved"},
+ {"var248", "Reserved"},
+ {"var249", "Reserved"},
+ {"var250", "Reserved"},
+ {"var251", "Reserved"},
+ {"var252", "Reserved"},
+ {"var253", "Reserved"},
+ {"REV", "Relative Error Variance [non-dim]"},
+ {"var255", "Reserved"}
+};
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/pds4.h b/wrfv2_fire/external/io_grib1/WGRIB/pds4.h
new file mode 100644
index 00000000..182d860a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/pds4.h
@@ -0,0 +1,90 @@
+/* version 3.4 of grib headers  w. ebisuzaki */
+/* this version is incomplete */
+/* add center DWD    Helmut P. Frank */
+/* 10/02 add center CPTEC */
+
+#ifndef INT2
+#define INT2(a,b)   ((1-(int) ((unsigned) (a & 0x80) >> 6)) * (int) (((a & 0x7f) << 8) + b))
+#endif
+
+#define PDS_Len1(pds)		(pds[0])
+#define PDS_Len2(pds)		(pds[1])
+#define PDS_Len3(pds)		(pds[2])
+#define PDS_LEN(pds)		((int) ((pds[0]<<16)+(pds[1]<<8)+pds[2]))
+#define PDS_Vsn(pds)		(pds[3])
+#define PDS_Center(pds)		(pds[4])
+#define PDS_Model(pds)		(pds[5])
+#define PDS_Grid(pds)		(pds[6])
+#define PDS_HAS_GDS(pds)	((pds[7] & 128) != 0)
+#define PDS_HAS_BMS(pds)	((pds[7] & 64) != 0)
+#define PDS_PARAM(pds)		(pds[8])
+#define PDS_L_TYPE(pds)		(pds[9])
+#define PDS_LEVEL1(pds)		(pds[10])
+#define PDS_LEVEL2(pds)		(pds[11])
+
+#define PDS_KPDS5(pds)		(pds[8])
+#define PDS_KPDS6(pds)		(pds[9])
+#define PDS_KPDS7(pds)		((int) ((pds[10]<<8) + pds[11]))
+
+/* this requires a 32-bit default integer machine */
+#define PDS_Field(pds)		((pds[8]<<24)+(pds[9]<<16)+(pds[10]<<8)+pds[11])
+
+#define PDS_Year(pds)		(pds[12])
+#define PDS_Month(pds)		(pds[13])
+#define PDS_Day(pds)		(pds[14])
+#define PDS_Hour(pds)		(pds[15])
+#define PDS_Minute(pds)		(pds[16])
+#define PDS_ForecastTimeUnit(pds)	(pds[17])
+#define PDS_P1(pds)		(pds[18])
+#define PDS_P2(pds)		(pds[19])
+#define PDS_TimeRange(pds)	(pds[20])
+#define PDS_NumAve(pds)		((int) ((pds[21]<<8)+pds[22]))
+#define PDS_NumMissing(pds)	(pds[23])
+#define PDS_Century(pds)	(pds[24])
+#define PDS_Subcenter(pds)	(pds[25])
+#define PDS_DecimalScale(pds)	INT2(pds[26],pds[27])
+/* old #define PDS_Year4(pds)   (pds[12] + 100*(pds[24] - (pds[12] != 0))) */
+#define PDS_Year4(pds)          (pds[12] + 100*(pds[24] - 1))
+
+/* various centers */
+#define NMC			7
+#define ECMWF			98
+#define DWD			78
+#define CMC			54
+#define CPTEC			46
+
+/* ECMWF Extensions */
+
+#define PDS_EcLocalId(pds)	(PDS_LEN(pds) >= 41 ? (pds[40]) : 0)
+#define PDS_EcClass(pds)	(PDS_LEN(pds) >= 42 ? (pds[41]) : 0)
+#define PDS_EcType(pds)		(PDS_LEN(pds) >= 43 ? (pds[42]) : 0)
+#define PDS_EcStream(pds)	(PDS_LEN(pds) >= 45 ? (INT2(pds[43], pds[44])) : 0)
+
+#define PDS_EcENS(pds)		(PDS_LEN(pds) >= 52 && pds[40] == 1 && \
+				pds[43] * 256 + pds[44] == 1035 && pds[50] != 0)
+#define PDS_EcFcstNo(pds)	(pds[50])
+#define PDS_EcNoFcst(pds)	(pds[51])
+
+
+/* NCEP Extensions */
+
+#define PDS_NcepENS(pds)	(PDS_LEN(pds) >= 44 && pds[25] == 2 && pds[40] == 1)
+#define PDS_NcepFcstType(pds)	(pds[41])
+#define PDS_NcepFcstNo(pds)	(pds[42])
+#define PDS_NcepFcstProd(pds)	(pds[43])
+
+/* time units */
+
+#define MINUTE  0
+#define HOUR    1
+#define DAY     2
+#define MONTH   3
+#define YEAR    4
+#define DECADE  5
+#define NORMAL  6
+#define CENTURY 7
+#define HOURS3  10
+#define HOURS6  11
+#define HOURS12  12
+#define SECOND  254
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/readgrib.c b/wrfv2_fire/external/io_grib1/WGRIB/readgrib.c
new file mode 100644
index 00000000..27c6dd16
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/readgrib.c
@@ -0,0 +1,31 @@
+/*
+ * read_grib.c
+ *
+ * reads grib message
+ *
+ * input: pos, byte position of grib message
+ *        len_grib, length of grib message
+ * output: *buffer, grib message
+ *
+ * note: call seek_grib first
+ *
+ * v1.0 9/94 Wesley Ebisuzaki
+ *
+ */
+#include 
+#include 
+#include 
+#include "grib.h"
+
+int read_grib(FILE *file, long pos, long len_grib, unsigned char *buffer) {
+
+    int i;
+
+
+    if (fseek(file, pos, SEEK_SET) == -1) {
+	    return 0;
+    }
+
+    i = fread(buffer, sizeof (unsigned char), len_grib, file);
+    return (i == len_grib);
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/seekgrib.c b/wrfv2_fire/external/io_grib1/WGRIB/seekgrib.c
new file mode 100644
index 00000000..dc64385f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/seekgrib.c
@@ -0,0 +1,72 @@
+/*
+ * find next grib header
+ *
+ * file = what do you think?
+ * pos = initial position to start looking at  ( = 0 for 1st call)
+ *       returns with position of next grib header (units=bytes)
+ * len_grib = length of the grib record (bytes)
+ * buffer[buf_len] = buffer for reading/writing
+ *
+ * returns (char *) to start of GRIB header+PDS
+ *         NULL if not found
+ *
+ * adapted from SKGB (Mark Iredell)
+ *
+ * v1.1 9/94 Wesley Ebisuzaki
+ * v1.2 3/96 Wesley Ebisuzaki handles short records at end of file
+ * v1.3 8/96 Wesley Ebisuzaki increase NTRY from 3 to 100 for the folks
+ *      at Automation decided a 21 byte WMO bulletin header wasn't long 
+ *      enough and decided to go to an 8K header.  
+ * v1.4 11/10/2001 D. Haalman, looks at entire file, does not try
+ *      to read past EOF
+ */
+#include 
+#include 
+#include 
+#include "grib.h"
+
+#ifndef min
+   #define min(a,b)  ((a) < (b) ? (a) : (b))
+#endif
+
+#define NTRY 100
+/* #define LEN_HEADER_PDS (28+42+100) */
+#define LEN_HEADER_PDS (28+8)
+
+unsigned char *seek_grib(FILE *file, long *pos, long *len_grib, 
+        unsigned char *buffer, unsigned int buf_len) {
+
+    int i, j, len;
+
+    j = 1;
+    clearerr(file);
+    while ( !feof(file) ) {
+
+        if (fseek(file, *pos, SEEK_SET) == -1) break;
+        i = fread(buffer, sizeof (unsigned char), buf_len, file);     
+        if (ferror(file)) break;
+        len = i - LEN_HEADER_PDS;
+     
+        for (i = 0; i < len; i++) {
+            if (buffer[i] == 'G' && buffer[i+1] == 'R' && buffer[i+2] == 'I'
+                && buffer[i+3] == 'B' && buffer[i+7] == 1) {
+                    *pos = i + *pos;
+                    *len_grib = (buffer[i+4] << 16) + (buffer[i+5] << 8) +
+                            buffer[i+6];
+                    return (buffer+i);
+            }
+        }
+
+	if (j++ == NTRY) {
+	    fprintf(stderr,"found unidentified data \n");
+           /* break; // stop seeking after NTRY records */  
+        }
+
+	*pos = *pos + (buf_len - LEN_HEADER_PDS);
+    }
+
+    *len_grib = 0;
+    return (unsigned char *) NULL;
+}
+
+
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/src2all b/wrfv2_fire/external/io_grib1/WGRIB/src2all
new file mode 100755
index 00000000..3f7264b4
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/src2all
@@ -0,0 +1,35 @@
+#!/bin/sh
+#
+# combine source code into one module
+# easier to compile -- no make file needed
+#
+# pretty generic script -- just echos, cats and greps.
+# 
+
+echo "combining source code into one module"
+echo "output is wgrib.c"
+set -x
+
+h="bds.h bms.h cnames.h gds.h grib.h pds4.h"
+c="wgrib_main.c seekgrib.c ibm2flt.c readgrib.c intpower.c cnames.c \
+	BDSunpk.c flt2ieee.c wrtieee.c levels.c PDStimes.c missing.c \
+        nceptable_opn.c nceptable_reanal.c  nceptab_131.c nceptab_130.c \
+        ectable_128.c ectable_129.c ectable_130.c ectable_131.c \
+        ectable_140.c ectable_150.c ectable_151.c ectable_160.c ectable_170.c \
+        ectable_180.c nceptab_129.c \
+        ombtable.c ec_ext.c gds_grid.c gribtable.c PDS_date.c ensemble.c \
+	dwdtable_002.c dwdtable_201.c dwdtable_202.c dwdtable_203.c cptectable_254.c"
+
+echo >wgrib.c "#include "
+echo >>wgrib.c "#include "
+echo >>wgrib.c "#include "
+echo >>wgrib.c "#include "
+echo >>wgrib.c "#include "
+echo >>wgrib.c "#include "
+
+
+cat $h >>wgrib.c
+
+cat $c | grep -v '#include' >> wgrib.c
+
+tar -cvf wgrib.tar $h $c src2all makefile Changes
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/wgrib_main.c b/wrfv2_fire/external/io_grib1/WGRIB/wgrib_main.c
new file mode 100644
index 00000000..1f9fbe7f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/wgrib_main.c
@@ -0,0 +1,839 @@
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+
+#include "pds4.h"
+#include "gds.h"
+#include "bms.h"
+#include "bds.h"
+#include "cnames.h"
+#include "grib.h"
+
+#define VERSION "v1.8.0.9i  (12-03-04) Wesley Ebisuzaki\n\t\tDWD-tables 2,201-203 (8-19-2003) Helmut P. Frank\n\t\tspectral: Luis Kornblueh (MPI)"
+
+#define CHECK_GRIB
+
+/*
+ * wgrib.c extract/inventory grib records
+ *
+ *                              Wesley Ebisuzaki
+ *
+ * 11/94 - v1.0
+ * 11/94 - v1.1: arbitary size grids, -i option
+ * 11/94 - v1.2: bug fixes, ieee option, more info
+ * 1/95  - v1.2.4: fix headers for SUN acc
+ * 2/95  - v1.2.5: add num_ave in -s listing
+ * 2/95  - v1.2.6: change %d to %ld
+ * 2/95  - v1.2.7: more output, added some polar stereographic support
+ * 2/95  - v1.2.8: max min format changed %f to %g, tidying up more info
+ * 3/95  - v1.3.0: fix bug with bitmap, allow numbers > UNDEFINED
+ * 3/95  - v1.3.1: print number of missing points (verbose)
+ * 3/95  - v1.3.2: -append option added
+ * 4/95  - v1.3.2a,b: more output, polar stereo support (-V option)
+ * 4/95  - v1.3.3: added ECMWF parameter table (prelim)
+ * 6/95  - v1.3.4: nxny from BDS rather than gds?
+ * 9/95  - v1.3.4d: speedup in grib write
+ * 11/95 - v1.3.4f: new ECMWF parameter table (from Mike Fiorino), EC logic
+ * 2/96  - v1.3.4g-h: prelim fix for GDS-less grib files
+ * 2/96  - v1.3.4i: faster missing(), -V: "pos n" -> "n" (field 2)
+ * 3/96  - v1.4: fix return code (!inventory), and short records near EOF
+ * 6/96  - v1.4.1a: faster grib->binary decode, updated ncep parameter table, mod. in clim. desc
+ * 7/96  - v1.5.0: parameter-table aware, -v option changed, added "comments"
+ *                 increased NTRY to 100 in seek_grib
+ * 11/96 - v1.5.0b: added ECMWF parameter table 128
+ * 1/97 - v1.5.0b2: if nxny != nx*ny { nx = nxny; ny = 1 }
+ * 3/97 - v1.5.0b5: added: -PDS -GDS, Lambert Conformal
+ * 3/97 - v1.5.0b6: added: -verf
+ * 4/97 - v1.5.0b7: added -PDS10, -GDS10 and enhanced -PDS -GDS
+ * 4/97 - v1.5.0b8: "bitmap missing x" -> "bitmap: x undef"
+ * 5/97 - v1.5.0b9: thinned grids meta data
+ * 5/97 - v1.5.0b10: changed 0hr fcst to anal for TR=10 and P1=P2=0
+ * 5/97 - v1.5.0b10: added -H option
+ * 6/97 - v1.5.0b12: thinned lat-long grids -V option
+ * 6/97 - v1.5.0b13: -4yr
+ * 6/97 - v1.5.0b14: fix century mark Y=100 not 0
+ * 7/97 - v1.5.0b15: add ncep opn grib table
+ * 12/97 - v1.6.1.a: made ncep_opn the default table
+ * 12/97 - v1.6.1.b: changed 03TOT to O3TOT in operational ncep table
+ * 1/98  - v1.6.2: added Arakawa E grid meta-data
+ * 1/98  - v1.6.2.1: added some mode data, Scan -> scan
+ * 4/98  - v1.6.2.4: reanalysis id code: subcenter==0 && process==180
+ * 5/98  - v1.6.2.5: fix -H code to write all of GDS
+ * 7/98  - v1.7: fix decoding bug for bitmap and no. bits > 24 (theoretical bug)
+ * 7/98  - v1.7.0.b1: add km to Mercator meta-data
+ * 5/99  - v1.7.2: bug with thinned grids & bitmaps (nxny != nx*ny)
+ * 5/99  - v1.7.3: updated NCEP opn grib table
+ * 8/99  - v1.7.3.1: updated level information
+ * 9/00  - v1.7.3.4a: check for missing grib file
+ * 2/01  - v1.7.3.5: handle data with precision greater than 31 bits
+ * 8/01  - vDWD   : added DWD GRIB tables 201, 202, 203, Helmut P. Frank
+ * 9/01  - vDWD   : added output "Triangular grid", Helmut P. Frank
+ * 9/01  - v1.7.4: merged Hemut P. Frank's changes to current wgrib source code
+ * 3/02  - vMPIfM: added support for spectral data type
+ * 4/02  - v1.8:   merge vMPIfM changes, some fixes/generalizations
+ * 10/02  - v1.8.0.1: added cptec table 254
+ * 10/02  - v1.8.0.2: no test of grib test if no gds, level 117 redone
+ * 10/02  - v1.8.0.3: update ncep_opn grib and levels
+ * 11/02  - v1.8.0.3a: updated ncep_opn and ncep table 129
+ * 9/03 - v1.8.0.4: update dwd tables (Helmut P. Frank), -dwdgrib option
+ * 9/03 - v1.8.0.5: fix scan mode and change format
+ * 10/03 - v1.8.0.7: Changes from Norwegian Met. Inst (ec tab #131, ex_ext)
+ * 10/03 - v1.8.0.8: added -ncep_ens option
+ *
+ */
+
+/*
+ * MSEEK = I/O buffer size for seek_grib
+ */
+
+#define MSEEK 1024
+#define BUFF_ALLOC0	40000
+
+
+#ifndef min
+#define min(a,b)  ((a) < (b) ? (a) : (b))
+#define max(a,b)  ((a) < (b) ? (b) : (a))
+#endif
+
+#ifndef DEF_T62_NCEP_TABLE
+#define DEF_T62_NCEP_TABLE	rean
+#endif
+enum Def_NCEP_Table def_ncep_table = DEF_T62_NCEP_TABLE;
+int minute = 0;
+int ncep_ens = 0;
+
+int main(int argc, char **argv) {
+
+    unsigned char *buffer;
+    float *array;
+    double temp, rmin, rmax;
+    int i, nx, ny, file_arg;
+    long int len_grib, pos = 0, nxny, buffer_size, n_dump, count = 1;
+    unsigned char *msg, *pds, *gds, *bms, *bds, *pointer;
+    FILE *input, *dump_file = NULL;
+    char line[200];
+    enum {BINARY, TEXT, IEEE, GRIB, NONE} output_type = NONE;
+    enum {DUMP_ALL, DUMP_RECORD, DUMP_POSITION, DUMP_LIST, INVENTORY} 
+	mode = INVENTORY;
+    enum {none, dwd, simple} header = simple;
+
+    long int dump = -1;
+    int verbose = 0, append = 0, v_time = 0, year_4 = 0, output_PDS_GDS = 0;
+    int print_GDS = 0, print_GDS10 = 0, print_PDS = 0, print_PDS10 = 0;
+    char *dump_file_name = "dump", open_parm[3];
+    int return_code = 0;
+
+    if (argc == 1) {
+	fprintf(stderr, "\nPortable Grib decoder for %s etc.\n",
+	    (def_ncep_table == opn_nowarn || def_ncep_table == opn) ?
+	    "NCEP Operations" : "NCEP/NCAR Reanalysis");
+	fprintf(stderr, "   it slices, dices    %s\n", VERSION);
+	fprintf(stderr, "   usage: %s [grib file] [options]\n\n", argv[0]);
+
+	fprintf(stderr, "Inventory/diagnostic-output selections\n");
+	fprintf(stderr, "   -s/-v                   short/verbose inventory\n");
+	fprintf(stderr, "   -V                      diagnostic output (not inventory)\n");
+	fprintf(stderr, "   (none)                  regular inventory\n");
+
+	fprintf(stderr, " Options\n");
+	fprintf(stderr, "   -PDS/-PDS10             print PDS in hex/decimal\n");
+	fprintf(stderr, "   -GDS/-GDS10             print GDS in hex/decimal\n");
+	fprintf(stderr, "   -verf                   print forecast verification time\n");
+	fprintf(stderr, "   -ncep_opn/-ncep_rean    default T62 NCEP grib table\n");
+	fprintf(stderr, "   -4yr                    print year using 4 digits\n");
+	fprintf(stderr, "   -min                    print minutes\n");
+	fprintf(stderr, "   -ncep_ens               ensemble info encoded in ncep format\n");
+
+	fprintf(stderr, "Decoding GRIB selection\n");
+	fprintf(stderr, "   -d [record number|all]  decode record number\n");
+	fprintf(stderr, "   -p [byte position]      decode record at byte position\n");
+	fprintf(stderr, "   -i                      decode controlled by stdin (inventory list)\n");
+	fprintf(stderr, "   (none)                  no decoding\n");
+
+	fprintf(stderr, " Options\n");
+	fprintf(stderr, "   -text/-ieee/-grib/-bin  convert to text/ieee/grib/bin (default)\n");
+	fprintf(stderr, "   -nh/-h                  output will have no headers/headers (default)\n");
+	fprintf(stderr, "   -dwdgrib                output dwd headers, grib (do not append)\n");
+	fprintf(stderr, "   -H                      output will include PDS and GDS (-bin/-ieee only)\n");
+	fprintf(stderr, "   -append                 append to output file\n");
+	fprintf(stderr, "   -o [file]               output file name, 'dump' is default\n");
+	exit(8);
+    }
+    file_arg = 0;
+    for (i = 1; i < argc; i++) {
+	if (strcmp(argv[i],"-PDS") == 0) {
+	    print_PDS = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-PDS10") == 0) {
+	    print_PDS10 = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-GDS") == 0) {
+	    print_GDS = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-GDS10") == 0) {
+	    print_GDS10 = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-v") == 0) {
+	    verbose = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-V") == 0) {
+	    verbose = 2;
+	    continue;
+	}
+	if (strcmp(argv[i],"-s") == 0) {
+	    verbose = -1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-text") == 0) {
+	    output_type = TEXT;
+	    continue;
+	}
+	if (strcmp(argv[i],"-bin") == 0) {
+	    output_type = BINARY;
+	    continue;
+	}
+	if (strcmp(argv[i],"-ieee") == 0) {
+	    output_type = IEEE;
+	    continue;
+	}
+	if (strcmp(argv[i],"-grib") == 0) {
+	    output_type = GRIB;
+	    continue;
+	}
+	if (strcmp(argv[i],"-nh") == 0) {
+	    header = none;
+	    continue;
+	}
+	if (strcmp(argv[i],"-h") == 0) {
+	    header = simple;
+	    continue;
+	}
+	if (strcmp(argv[i],"-dwdgrib") == 0) {
+	    header = dwd;
+	    output_type = GRIB;
+	    continue;
+	}
+	if (strcmp(argv[i],"-append") == 0) {
+	    append = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-verf") == 0) {
+	    v_time = 1;
+	    continue;
+        }
+	if (strcmp(argv[i],"-d") == 0) {
+	    if (strcmp(argv[i+1],"all") == 0) {
+	        mode = DUMP_ALL;
+	    }
+	    else {
+	        dump = atol(argv[i+1]);
+	        mode = DUMP_RECORD;
+	    }
+	    i++;
+	    if (output_type == NONE) output_type = BINARY;
+	    continue;
+	}
+	if (strcmp(argv[i],"-p") == 0) {
+	    pos = atol(argv[i+1]);
+	    i++;
+	    dump = 1;
+	    if (output_type == NONE) output_type = BINARY;
+	    mode = DUMP_POSITION;
+	    continue;
+	}
+	if (strcmp(argv[i],"-i") == 0) {
+	    if (output_type == NONE) output_type = BINARY;
+	    mode = DUMP_LIST;
+	    continue;
+	}
+	if (strcmp(argv[i],"-H") == 0) {
+	    output_PDS_GDS = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-NH") == 0) {
+	    output_PDS_GDS = 0;
+	    continue;
+	}
+	if (strcmp(argv[i],"-4yr") == 0) {
+	    year_4 = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-ncep_opn") == 0) {
+	    def_ncep_table = opn_nowarn;
+	    continue;
+	}
+	if (strcmp(argv[i],"-ncep_rean") == 0) {
+	    def_ncep_table = rean_nowarn;
+	    continue;
+	}
+	if (strcmp(argv[i],"-o") == 0) {
+	    dump_file_name = argv[i+1];
+	    i++;
+	    continue;
+	}
+	if (strcmp(argv[i],"--v") == 0) {
+	    printf("wgrib: %s\n", VERSION);
+	    exit(0);
+	}
+	if (strcmp(argv[i],"-min") == 0) {
+	    minute = 1;
+	    continue;
+	}
+	if (strcmp(argv[i],"-ncep_ens") == 0) {
+	    ncep_ens = 1;
+	    continue;
+	}
+	if (file_arg == 0) {
+	    file_arg = i;
+	}
+	else {
+	    fprintf(stderr,"argument: %s ????\n", argv[i]);
+	}
+    }
+    if (file_arg == 0) {
+	fprintf(stderr,"no GRIB file to process\n");
+	exit(8);
+    }
+    if ((input = fopen(argv[file_arg],"rb")) == NULL) {
+        fprintf(stderr,"could not open file: %s\n", argv[file_arg]);
+        exit(7);
+    }
+
+    if ((buffer = (unsigned char *) malloc(BUFF_ALLOC0)) == NULL) {
+	fprintf(stderr,"not enough memory\n");
+    }
+    buffer_size = BUFF_ALLOC0;
+
+    /* open output file */
+    if (mode != INVENTORY) {
+	open_parm[0] = append ? 'a' : 'w'; open_parm[1] = 'b'; open_parm[2] = '\0';
+	if (output_type == TEXT) open_parm[1] = '\0';
+
+	if ((dump_file = fopen(dump_file_name,open_parm)) == NULL) {
+	    fprintf(stderr,"could not open dump file\n");
+	    exit(8);
+        }
+	if (header == dwd && output_type == GRIB) wrtieee_header(0, dump_file);
+    }
+
+    /* skip dump - 1 records */
+    for (i = 1; i < dump; i++) {
+	msg = seek_grib(input, &pos, &len_grib, buffer, MSEEK);
+	if (msg == NULL) {
+	    fprintf(stderr, "ran out of data or bad file\n");
+	    exit(8);
+	}
+	pos += len_grib;
+    }
+    if (dump > 0) count += dump - 1;
+    n_dump = 0;
+
+    for (;;) {
+	if (n_dump == 1 && (mode == DUMP_RECORD || mode == DUMP_POSITION)) break;
+	if (mode == DUMP_LIST) {
+	    if (fgets(line,sizeof(line), stdin) == NULL) break;
+            line[sizeof(line) - 1] = 0;
+            if (sscanf(line,"%ld:%ld:", &count, &pos) != 2) {
+		fprintf(stderr,"bad input from stdin\n");
+                fprintf(stderr,"   %s\n", line);
+	        exit(8);
+	    }
+	}
+
+	msg = seek_grib(input, &pos, &len_grib, buffer, MSEEK);
+	if (msg == NULL) {
+	    if (mode == INVENTORY || mode == DUMP_ALL) break;
+	    fprintf(stderr,"missing GRIB record(s)\n");
+	    exit(8);
+	}
+
+        /* read all whole grib record */
+        if (len_grib + msg - buffer > buffer_size) {
+            buffer_size = len_grib + msg - buffer + 1000;
+            buffer = (unsigned char *) realloc((void *) buffer, buffer_size);
+            if (buffer == NULL) {
+                fprintf(stderr,"ran out of memory\n");
+                exit(8);
+            }
+        }
+        read_grib(input, pos, len_grib, buffer);
+
+	/* parse grib message */
+
+	msg = buffer;
+        pds = (msg + 8);
+        pointer = pds + PDS_LEN(pds);
+#ifdef DEBUG
+	printf("LEN_GRIB= 0x%x\n", len_grib);
+	printf("PDS_LEN= 0x%x: at 0x%x\n", PDS_LEN(pds),pds-msg);
+#endif
+        if (PDS_HAS_GDS(pds)) {
+            gds = pointer;
+            pointer += GDS_LEN(gds);
+#ifdef DEBUG
+	    printf("GDS_LEN= 0x%x: at 0x%x\n", GDS_LEN(gds), gds-msg);
+#endif
+        }
+        else {
+            gds = NULL;
+        }
+
+        if (PDS_HAS_BMS(pds)) {
+            bms = pointer;
+            pointer += BMS_LEN(bms);
+#ifdef DEBUG
+	    printf("BMS_LEN= 0x%x: at 0x%x\n", BMS_LEN(bms),bms-msg);
+#endif
+        }
+        else {
+            bms = NULL;
+        }
+
+        bds = pointer;
+        pointer += BDS_LEN(bds);
+#ifdef DEBUG
+	printf("BDS_LEN= 0x%x: at 0x%x\n", BDS_LEN(bds),bds-msg);
+#endif
+
+#ifdef DEBUG
+	printf("END_LEN= 0x%x: at 0x%x\n", 4,pointer-msg);
+	if (pointer-msg+4 != len_grib) {
+	    fprintf(stderr,"Len of grib message is inconsistent.\n");
+	}
+#endif
+
+        /* end section - "7777" in ascii */
+        if (pointer[0] != 0x37 || pointer[1] != 0x37 ||
+            pointer[2] != 0x37 || pointer[3] != 0x37) {
+            fprintf(stderr,"\n\n    missing end section\n");
+            fprintf(stderr, "%2x %2x %2x %2x\n", pointer[0], pointer[1], 
+		pointer[2], pointer[3]);
+#ifdef DEBUG
+	    printf("ignoring missing end section\n");
+#else
+	    exit(8);
+#endif
+        }
+
+	/* figure out size of array */
+	if (gds != NULL) {
+	    GDS_grid(gds, bds, &nx, &ny, &nxny);
+	}
+	else if (bms != NULL) {
+	    nxny = nx = BMS_nxny(bms);
+	    ny = 1;
+	}
+	else {
+	    if (BDS_NumBits(bds) == 0) {
+                nxny = nx = 1;
+                fprintf(stderr,"Missing GDS, constant record .. cannot "
+                    "determine number of data points\n");
+	    }
+	    else {
+	        nxny = nx = BDS_NValues(bds);
+	    }
+	    ny = 1;
+	}
+
+#ifdef CHECK_GRIB
+	if (gds && ! GDS_Harmonic(gds)) {
+	/* this grib check only works for simple packing */
+	/* turn off if harmonic */
+	    if (BDS_NumBits(bds) != 0) {
+	        i = BDS_NValues(bds);
+	        if (bms != NULL) {
+	            i += missing_points(BMS_bitmap(bms),nxny);
+	        }
+	        if (i != nxny) {
+	            fprintf(stderr,"grib header at record %ld: two values of nxny %ld %d\n",
+			count,nxny,i);
+		    fprintf(stderr,"   LEN %d DataStart %d UnusedBits %d #Bits %d nxny %ld\n",
+			BDS_LEN(bds), BDS_DataStart(bds),BDS_UnusedBits(bds),
+			BDS_NumBits(bds), nxny);
+		    return_code = 15;
+		    nxny = nx = i;
+		    ny = 1;
+	        }
+	    }
+ 
+        }
+#endif
+ 
+        if (verbose <= 0) {
+	    printf("%ld:%ld:d=", count, pos);
+	    PDS_date(pds,year_4,v_time);
+	    printf(":%s:", k5toa(pds));
+
+            if (verbose == 0) printf("kpds5=%d:kpds6=%d:kpds7=%d:TR=%d:P1=%d:P2=%d:TimeU=%d:",
+	        PDS_PARAM(pds),PDS_KPDS6(pds),PDS_KPDS7(pds),
+	        PDS_TimeRange(pds),PDS_P1(pds),PDS_P2(pds),
+                PDS_ForecastTimeUnit(pds));
+	    levels(PDS_KPDS6(pds), PDS_KPDS7(pds),PDS_Center(pds)); printf(":");
+	    PDStimes(PDS_TimeRange(pds),PDS_P1(pds),PDS_P2(pds),
+                PDS_ForecastTimeUnit(pds));
+	    if (PDS_Center(pds) == ECMWF) EC_ext(pds,"",":");
+	    ensemble(pds, verbose);
+	    printf("NAve=%d",PDS_NumAve(pds));
+	    if (print_PDS || print_PDS10) print_pds(pds, print_PDS, print_PDS10, verbose);
+	    if (gds && (print_GDS || print_GDS10)) print_gds(gds, print_GDS, print_GDS10, verbose);
+            printf("\n");
+       }
+       else if (verbose == 1) {
+	    printf("%ld:%ld:D=", count, pos);
+            PDS_date(pds, 1, v_time);
+	    printf(":%s:", k5toa(pds));
+	    levels(PDS_KPDS6(pds), PDS_KPDS7(pds), PDS_Center(pds)); printf(":");
+            printf("kpds=%d,%d,%d:",
+	        PDS_PARAM(pds),PDS_KPDS6(pds),PDS_KPDS7(pds));
+	    PDStimes(PDS_TimeRange(pds),PDS_P1(pds),PDS_P2(pds),
+                PDS_ForecastTimeUnit(pds));
+	    if (PDS_Center(pds) == ECMWF) EC_ext(pds,"",":");
+	    ensemble(pds, verbose);
+	    GDS_winds(gds, verbose);
+            printf("\"%s", k5_comments(pds));
+	    if (print_PDS || print_PDS10) print_pds(pds, print_PDS, print_PDS10, verbose);
+	    if (gds && (print_GDS || print_GDS10)) print_gds(gds, print_GDS, print_GDS10, verbose);
+            printf("\n");
+	}
+        else if (verbose == 2) {
+	    printf("rec %ld:%ld:date ", count, pos);
+	    PDS_date(pds, 1, v_time);
+	    printf(" %s kpds5=%d kpds6=%d kpds7=%d levels=(%d,%d) grid=%d ", 
+	        k5toa(pds), PDS_PARAM(pds), PDS_KPDS6(pds), PDS_KPDS7(pds), 
+                PDS_LEVEL1(pds), PDS_LEVEL2(pds), PDS_Grid(pds));
+	        levels(PDS_KPDS6(pds),PDS_KPDS7(pds),PDS_Center(pds));
+
+	    printf(" ");
+	    if (PDS_Center(pds) == ECMWF) EC_ext(pds,""," ");
+	    ensemble(pds, verbose);
+	    PDStimes(PDS_TimeRange(pds),PDS_P1(pds),PDS_P2(pds),
+                 PDS_ForecastTimeUnit(pds));
+	    if (bms != NULL) 
+		printf(" bitmap: %d undef", missing_points(BMS_bitmap(bms),nxny));
+            printf("\n  %s=%s\n", k5toa(pds), k5_comments(pds));
+	
+            printf("  timerange %d P1 %d P2 %d TimeU %d  nx %d ny %d GDS grid %d "
+		"num_in_ave %d missing %d\n", 
+	        PDS_TimeRange(pds),PDS_P1(pds),PDS_P2(pds), 
+                PDS_ForecastTimeUnit(pds), nx, ny, 
+                gds == NULL ? -1 : GDS_DataType(gds), 
+                PDS_NumAve(pds), PDS_NumMissing(pds));
+
+	    printf("  center %d subcenter %d process %d Table %d", 
+		PDS_Center(pds),PDS_Subcenter(pds),PDS_Model(pds),
+                PDS_Vsn(pds));
+	    GDS_winds(gds, verbose);
+	    printf("\n");
+
+	    if (gds && GDS_LatLon(gds) && nx != -1) 
+		printf("  latlon: lat  %f to %f by %f  nxny %ld\n"
+                       "          long %f to %f by %f, (%d x %d) scan %d "
+                       "mode %d bdsgrid %d\n",
+		  0.001*GDS_LatLon_La1(gds), 0.001*GDS_LatLon_La2(gds),
+		  0.001*GDS_LatLon_dy(gds), nxny, 0.001*GDS_LatLon_Lo1(gds),
+		  0.001*GDS_LatLon_Lo2(gds), 0.001*GDS_LatLon_dx(gds),
+	    	  nx, ny, GDS_LatLon_scan(gds), GDS_LatLon_mode(gds),
+		  BDS_Grid(bds));
+	    else if (gds && GDS_LatLon(gds) && nx == -1) {
+		printf("  thinned latlon: lat  %f to %f by %f  nxny %ld\n"
+                       "          long %f to %f, %ld grid pts   (%d x %d) scan %d"
+			" mode %d bdsgrid %d\n",
+		  0.001*GDS_LatLon_La1(gds), 0.001*GDS_LatLon_La2(gds),
+		  0.001*GDS_LatLon_dy(gds), nxny, 0.001*GDS_LatLon_Lo1(gds),
+		  0.001*GDS_LatLon_Lo2(gds),
+	    	  nxny, nx, ny, GDS_LatLon_scan(gds), GDS_LatLon_mode(gds),
+		  BDS_Grid(bds));
+		  GDS_prt_thin_lon(gds);
+	    }
+	    else if (gds && GDS_Gaussian(gds) && nx != -1)
+		printf("  gaussian: lat  %f to %f\n"
+                       "            long %f to %f by %f, (%d x %d) scan %d"
+			" mode %d bdsgrid %d\n",
+		  0.001*GDS_LatLon_La1(gds), 0.001*GDS_LatLon_La2(gds),
+		  0.001*GDS_LatLon_Lo1(gds), 0.001*GDS_LatLon_Lo2(gds), 
+		  0.001*GDS_LatLon_dx(gds),
+	    	  nx, ny, GDS_LatLon_scan(gds), GDS_LatLon_mode(gds),
+		  BDS_Grid(bds));
+	    else if (gds && GDS_Gaussian(gds) && nx == -1) {
+		printf("  thinned gaussian: lat  %f to %f\n"
+                       "     lon %f   %ld grid pts   (%d x %d) scan %d"
+			" mode %d bdsgrid %d  nlat:\n",
+		  0.001*GDS_LatLon_La1(gds), 0.001*GDS_LatLon_La2(gds),
+		  0.001*GDS_LatLon_Lo1(gds),
+	    	  nxny, nx, ny, GDS_LatLon_scan(gds), GDS_LatLon_mode(gds),
+		  BDS_Grid(bds));
+		  GDS_prt_thin_lon(gds);
+	    }
+	    else if (gds && GDS_Polar(gds))
+		printf("  polar stereo: Lat1 %f Long1 %f Orient %f\n"
+			"     %s pole (%d x %d) Dx %d Dy %d scan %d mode %d\n",
+		    0.001*GDS_Polar_La1(gds),0.001*GDS_Polar_Lo1(gds),
+		    0.001*GDS_Polar_Lov(gds),
+		    GDS_Polar_pole(gds) == 0 ? "north" : "south", nx,ny,
+		    GDS_Polar_Dx(gds),GDS_Polar_Dy(gds),
+		    GDS_Polar_scan(gds), GDS_Polar_mode(gds));
+	    else if (gds && GDS_Lambert(gds))
+		printf("  Lambert Conf: Lat1 %f Lon1 %f Lov %f\n"
+                       "      Latin1 %f Latin2 %f LatSP %f LonSP %f\n"
+                       "      %s (%d x %d) Dx %f Dy %f scan %d mode %d\n",
+                     0.001*GDS_Lambert_La1(gds),0.001*GDS_Lambert_Lo1(gds),
+                     0.001*GDS_Lambert_Lov(gds),
+                     0.001*GDS_Lambert_Latin1(gds), 0.001*GDS_Lambert_Latin2(gds),
+                     0.001*GDS_Lambert_LatSP(gds), 0.001*GDS_Lambert_LonSP(gds),
+                      GDS_Lambert_NP(gds) ? "North Pole": "South Pole",
+                     GDS_Lambert_nx(gds), GDS_Lambert_ny(gds),
+                     0.001*GDS_Lambert_dx(gds), 0.001*GDS_Lambert_dy(gds),
+                     GDS_Lambert_scan(gds), GDS_Lambert_mode(gds));
+	    else if (gds && GDS_Mercator(gds))
+		printf("  Mercator: lat  %f to %f by %f km  nxny %ld\n"
+                       "          long %f to %f by %f km, (%d x %d) scan %d"
+			" mode %d Latin %f bdsgrid %d\n",
+		  0.001*GDS_Merc_La1(gds), 0.001*GDS_Merc_La2(gds),
+		  0.001*GDS_Merc_dy(gds), nxny, 0.001*GDS_Merc_Lo1(gds),
+		  0.001*GDS_Merc_Lo2(gds), 0.001*GDS_Merc_dx(gds),
+	    	  nx, ny, GDS_Merc_scan(gds), GDS_Merc_mode(gds), 
+		  0.001*GDS_Merc_Latin(gds), BDS_Grid(bds));
+	    else if (gds && GDS_ssEgrid(gds))
+		printf("  Semi-staggered Arakawa E-Grid: lat0 %f lon0 %f nxny %d\n"
+                       "    dLat %f dLon %f (%d x %d) scan %d mode %d\n",
+		  0.001*GDS_ssEgrid_La1(gds), 0.001*GDS_ssEgrid_Lo1(gds), 
+                  GDS_ssEgrid_n(gds)*GDS_ssEgrid_n_dum(gds), 
+                  0.001*GDS_ssEgrid_dj(gds), 0.001*GDS_ssEgrid_di(gds), 
+                  GDS_ssEgrid_Lo2(gds), GDS_ssEgrid_La2(gds),
+                  GDS_ssEgrid_scan(gds), GDS_ssEgrid_mode(gds));
+            else if (gds && GDS_ss2dEgrid(gds))
+                printf("  Semi-staggered Arakawa E-Grid (2D): lat0 %f lon0 %f nxny %d\n"
+                       "    dLat %f dLon %f (tlm0d %f tph0d %f) scan %d mode %d\n",
+                   0.001*GDS_ss2dEgrid_La1(gds), 0.001*GDS_ss2dEgrid_Lo1(gds),
+                   GDS_ss2dEgrid_nx(gds)*GDS_ss2dEgrid_ny(gds),
+                   0.001*GDS_ss2dEgrid_dj(gds), 0.001*GDS_ss2dEgrid_di(gds),
+                   0.001*GDS_ss2dEgrid_Lo2(gds), 0.001*GDS_ss2dEgrid_La2(gds),
+                   GDS_ss2dEgrid_scan(gds), GDS_ss2dEgrid_mode(gds));
+	    else if (gds && GDS_fEgrid(gds)) 
+		printf("  filled Arakawa E-Grid: lat0 %f lon0 %f nxny %d\n"
+                       "    dLat %f dLon %f (%d x %d) scan %d mode %d\n",
+		  0.001*GDS_fEgrid_La1(gds), 0.001*GDS_fEgrid_Lo1(gds), 
+                  GDS_fEgrid_n(gds)*GDS_fEgrid_n_dum(gds), 
+                  0.001*GDS_fEgrid_dj(gds), 0.001*GDS_fEgrid_di(gds), 
+                  GDS_fEgrid_Lo2(gds), GDS_fEgrid_La2(gds),
+                  GDS_fEgrid_scan(gds), GDS_fEgrid_mode(gds));
+	    else if (gds && GDS_RotLL(gds))
+		printf("  rotated LatLon grid  lat %f to %f  lon %f to %f\n"
+		       "    nxny %ld  (%d x %d)  dx %d dy %d  scan %d  mode %d\n"
+		       "    transform: south pole lat %f lon %f  rot angle %f\n", 
+		   0.001*GDS_RotLL_La1(gds), 0.001*GDS_RotLL_La2(gds), 
+		   0.001*GDS_RotLL_Lo1(gds), 0.001*GDS_RotLL_Lo2(gds),
+		   nxny, GDS_RotLL_nx(gds), GDS_RotLL_ny(gds),
+		   GDS_RotLL_dx(gds), GDS_RotLL_dy(gds),
+		   GDS_RotLL_scan(gds), GDS_RotLL_mode(gds),
+		   0.001*GDS_RotLL_LaSP(gds), 0.001*GDS_RotLL_LoSP(gds),
+		   GDS_RotLL_RotAng(gds) );
+	    else if (gds && GDS_Gnomonic(gds))
+		printf("  Gnomonic grid\n");
+	    else if (gds && GDS_Harmonic(gds))
+		printf("  Harmonic (spectral):  pentagonal spectral truncation: nj %d nk %d nm %d\n",
+		       GDS_Harmonic_nj(gds), GDS_Harmonic_nk(gds),
+		       GDS_Harmonic_nm(gds));
+		if (gds && GDS_Harmonic_type(gds) == 1)
+		  printf("  Associated Legendre polynomials\n");
+            else if (gds && GDS_Triangular(gds))
+                printf("  Triangular grid:  nd %d ni %d (= 2^%d x 3^%d)\n",
+		    GDS_Triangular_nd(gds), GDS_Triangular_ni(gds), 
+                    GDS_Triangular_ni2(gds), GDS_Triangular_ni3(gds) );
+	    if (print_PDS || print_PDS10) 
+                print_pds(pds, print_PDS, print_PDS10, verbose);
+	    if (gds && (print_GDS || print_GDS10)) 
+                 print_gds(gds, print_GDS, print_GDS10, verbose);
+	}
+
+	if (mode != INVENTORY && output_type == GRIB) {
+	    if (header == dwd) wrtieee_header((int) len_grib, dump_file);
+	    fwrite((void *) msg, sizeof(char), len_grib, dump_file);
+	    if (header == dwd) wrtieee_header((int) len_grib, dump_file);
+	    n_dump++;
+	}
+
+	if ((mode != INVENTORY && output_type != GRIB) || verbose > 1) {
+	    /* decode numeric data */
+ 
+            if ((array = (float *) malloc(sizeof(float) * nxny)) == NULL) {
+                fprintf(stderr,"memory problems\n");
+                exit(8);
+            }
+
+	    temp = int_power(10.0, - PDS_DecimalScale(pds));
+
+ 	    BDS_unpack(array, bds, BMS_bitmap(bms), BDS_NumBits(bds), nxny,
+			   temp*BDS_RefValue(bds),temp*int_power(2.0, BDS_BinScale(bds)));
+
+	    if (verbose > 1) {
+		rmin = FLT_MAX;
+		rmax = -FLT_MAX;
+	        for (i = 0; i < nxny; i++) {
+		    if (fabs(array[i]-UNDEFINED) > 0.0001*UNDEFINED) {
+	                rmin = min(rmin,array[i]);
+	                rmax = max(rmax,array[i]);
+		    }
+	        }
+	        printf("  min/max data %g %g  num bits %d "
+			" BDS_Ref %g  DecScale %d BinScale %d\n", 
+		    rmin, rmax, BDS_NumBits(bds), BDS_RefValue(bds),
+		    PDS_DecimalScale(pds), BDS_BinScale(bds));
+	    }
+
+	    if (mode != INVENTORY && output_type != GRIB) {
+		/* dump code */
+		if (output_PDS_GDS == 1) {
+		    /* insert code here */
+	            if (output_type == BINARY || output_type == IEEE) {
+			/* write PDS */
+			i = PDS_LEN(pds) + 4;
+	                if (header == simple && output_type == BINARY) 
+				fwrite((void *) &i, sizeof(int), 1, dump_file);
+	                if (header == simple && output_type == IEEE) wrtieee_header(i, dump_file);
+	                fwrite((void *) "PDS ", 1, 4, dump_file);
+	                fwrite((void *) pds, 1, i - 4, dump_file);
+	                if (header == simple && output_type == BINARY) 
+				fwrite((void *) &i, sizeof(int), 1, dump_file);
+	                if (header == simple && output_type == IEEE) wrtieee_header(i, dump_file);
+
+			/* write GDS */
+			i = (gds) ?  GDS_LEN(gds) + 4 : 4;
+	                if (header == simple && output_type == BINARY) 
+				fwrite((void *) &i, sizeof(int), 1, dump_file);
+	                if (header == simple && output_type == IEEE) wrtieee_header(i, dump_file);
+	                fwrite((void *) "GDS ", 1, 4, dump_file);
+	                if (gds) fwrite((void *) gds, 1, i - 4, dump_file);
+	                if (header == simple && output_type == BINARY) 
+				fwrite((void *) &i, sizeof(int), 1, dump_file);
+	                if (header == simple && output_type == IEEE) wrtieee_header(i, dump_file);
+		    }
+		} 
+
+	        if (output_type == BINARY) {
+	            i = nxny * sizeof(float);
+	            if (header == simple) fwrite((void *) &i, sizeof(int), 1, dump_file);
+	            fwrite((void *) array, sizeof(float), nxny, dump_file);
+	            if (header == simple) fwrite((void *) &i, sizeof(int), 1, dump_file);
+	        }
+		else if (output_type == IEEE) {
+		    wrtieee(array, nxny, header, dump_file);
+		}
+	        else if (output_type == TEXT) {
+	            /* number of points in grid */
+	            if (header == simple) {
+		        if (nx <= 0 || ny <= 0 || nxny != nx*ny) {
+                            fprintf(dump_file, "%ld %d\n", nxny, 1);
+			}
+			else {
+			    fprintf(dump_file, "%d %d\n", nx, ny);
+			}
+		    }
+	            for (i = 0; i < nxny; i++) {
+		        fprintf(dump_file,"%g\n", array[i]);
+		    }
+	        }
+	        n_dump++;
+	    }
+	    free(array);
+	    if (verbose > 0) printf("\n");
+	}
+	    
+        pos += len_grib;
+        count++;
+    }
+
+    if (mode != INVENTORY) {
+	if (header == dwd && output_type == GRIB) wrtieee_header(0, dump_file);
+	if (ferror(dump_file)) {
+		fprintf(stderr,"error writing %s\n",dump_file_name);
+		exit(8);
+	}
+    }
+    fclose(input);
+    return (return_code);
+}
+
+void print_pds(unsigned char *pds, int print_PDS, int print_PDS10, int verbose) {
+    int i, j;
+
+    j = PDS_LEN(pds);
+    if (verbose < 2) {
+        if (print_PDS && verbose < 2) {
+            printf(":PDS=");
+            for (i = 0; i < j; i++) {
+                printf("%2.2x", (int) pds[i]);
+            }
+        }
+        if (print_PDS10 && verbose < 2) {
+            printf(":PDS10=");
+            for (i = 0; i < j; i++) {
+                printf(" %d", (int) pds[i]);
+            }
+        }
+    }
+    else {
+        if (print_PDS) {
+            printf("  PDS(1..%d)=",j);
+            for (i = 0; i < j; i++) {
+                if (i % 20 == 0) printf("\n    %4d:",i+1);
+                printf(" %3.2x", (int) pds[i]);
+            }
+            printf("\n");
+        }
+        if (print_PDS10) {
+            printf("  PDS10(1..%d)=",j);
+            for (i = 0; i < j; i++) {
+                if (i % 20 == 0) printf("\n    %4d:",i+1);
+                printf(" %3d", (int) pds[i]);
+            }
+            printf("\n");
+        }
+    }
+}
+
+void print_gds(unsigned char *gds, int print_GDS, int print_GDS10, int verbose) {
+    int i, j;
+
+    j = GDS_LEN(gds);
+    if (verbose < 2) {
+        if (print_GDS && verbose < 2) {
+            printf(":GDS=");
+            for (i = 0; i < j; i++) {
+                printf("%2.2x", (int) gds[i]);
+            }
+        }
+        if (print_GDS10 && verbose < 2) {
+            printf(":GDS10=");
+            for (i = 0; i < j; i++) {
+                printf(" %d", (int) gds[i]);
+            }
+        }
+    }
+    else {
+        if (print_GDS) {
+            printf("  GDS(1..%d)=",j);
+            for (i = 0; i < j; i++) {
+                if (i % 20 == 0) printf("\n    %4d:",i+1);
+                printf(" %3.2x", (int) gds[i]);
+            }
+            printf("\n");
+        }
+        if (print_GDS10) {
+            printf("  GDS10(1..%d)=",j);
+            for (i = 0; i < j; i++) {
+                if (i % 20 == 0) printf("\n    %4d:",i+1);
+                printf(" %3d", (int) gds[i]);
+            }
+            printf("\n");
+        }
+    }
+}
diff --git a/wrfv2_fire/external/io_grib1/WGRIB/wrtieee.c b/wrfv2_fire/external/io_grib1/WGRIB/wrtieee.c
new file mode 100644
index 00000000..4e2decfb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/WGRIB/wrtieee.c
@@ -0,0 +1,82 @@
+#include 
+#include 
+#include 
+#include "grib.h"
+
+
+/* wesley ebisuzaki v1.3
+ *
+ * write ieee file -- big endian format
+ *
+ * input float *array		data to be written
+ *	 int n			size of array
+ *	 int header		1 for f77 style header 0 for none
+ *				(header is 4 byte header
+ *	 FILE *output		output file
+ *
+ * v1.2 7/97 buffered, faster
+ * v1.3 2/99 fixed (typo) error in wrtieee_header found by
+ *     Bob Farquhar
+ */
+
+#define BSIZ 1024*4
+
+int wrtieee(float *array, int n, int header, FILE *output) {
+
+	unsigned long int l;
+	int i, nbuf;
+	unsigned char buff[BSIZ];
+	unsigned char h4[4];
+
+	nbuf = 0;
+	if (header) {
+		l = n * 4;
+		for (i = 0; i < 4; i++) {
+			h4[i] = l & 255;
+			l >>= 8;
+		}
+		buff[nbuf++] = h4[3];
+		buff[nbuf++] = h4[2];
+		buff[nbuf++] = h4[1];
+		buff[nbuf++] = h4[0];
+	}
+	for (i = 0; i < n; i++) {
+		if (nbuf >= BSIZ) {
+		    fwrite(buff, 1, BSIZ, output);
+		    nbuf = 0;
+		}
+		flt2ieee(array[i], buff + nbuf);
+		nbuf += 4;
+	}
+	if (header) {
+		if (nbuf == BSIZ) {
+		    fwrite(buff, 1, BSIZ, output);
+		    nbuf = 0;
+		}
+		buff[nbuf++] = h4[3];
+		buff[nbuf++] = h4[2];
+		buff[nbuf++] = h4[1];
+		buff[nbuf++] = h4[0];
+	}
+	if (nbuf) fwrite(buff, 1, nbuf, output);
+	return 0;
+}
+
+/* write a big-endian 4 byte integer .. f77 IEEE  header */
+
+int wrtieee_header(unsigned int n, FILE *output) {
+	unsigned h4[4];
+
+	h4[0] = n & 255;
+	h4[1] = (n >> 8) & 255;
+	h4[2] = (n >> 16) & 255;
+	h4[3] = (n >> 24) & 255;
+
+	putc(h4[3],output);
+	putc(h4[2],output);
+	putc(h4[1],output);
+	putc(h4[0],output);
+
+	return 0;
+}
+
diff --git a/wrfv2_fire/external/io_grib1/diffwrf b/wrfv2_fire/external/io_grib1/diffwrf
new file mode 100755
index 00000000..5648bd05
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/diffwrf
@@ -0,0 +1,35 @@
+#!/bin/csh
+
+if ( ${#argv} != 2 ) then
+	echo usage: diffwrf gribfile1 gribfile2
+	exit ( 1 )
+endif
+
+set file1 = $1
+set file2 = $2
+	
+if ( -e fort.88 ) rm fort.88 
+if ( -e fort.98 ) rm fort.98 
+
+if ( -e outfile1 ) rm outfile1
+if ( -e outfile2 ) rm outfile2
+
+if ( ( ! -e $file1 ) || ( ! -e $file2 ) ) then
+	touch fort.88
+	exit ( 0 ) 
+endif
+
+../../external/io_grib1/wgrib -s $file1 | ../../external/io_grib1/wgrib -s -i -o outfile1 $file1 >& /dev/null
+../../external/io_grib1/wgrib -s $file2 | ../../external/io_grib1/wgrib -s -i -o outfile2 $file2 >& /dev/null
+
+cmp outfile1 outfile2
+
+set ok = $status
+
+if ( $ok == 0 ) then
+	
+else
+	touch fort.88
+endif
+
+exit ( 0 ) 
diff --git a/wrfv2_fire/external/io_grib1/grib1_routines.c b/wrfv2_fire/external/io_grib1/grib1_routines.c
new file mode 100644
index 00000000..bf5ad51d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_routines.c
@@ -0,0 +1,1280 @@
+/*
+****************************************************************************
+*
+*  Routines for indexing, reading and writing grib files.  Routines
+*    are designed to be called by Fortran.
+*
+*  All routines return 0 for success, 1 for failure, unless otherwise noted. 
+*
+*  Todd Hutchinson
+*  WSI
+*  05/17/2005
+*
+****************************************************************************
+*/
+
+#include "grib1_routines.h"
+#include "gridnav.h"
+#include 
+#include 
+#include 
+#include 
+
+char *trim (char *str);
+int index_metadata(GribInfo *gribinfo, MetaData *metadata, int fid);
+int index_times(GribInfo *gribinfo, Times *times);
+int find_time(Times *times, char valid_time[15]);
+int get_gridnav_projection(int wrf_projection);
+int get_byte(int input_int, int bytenum);
+
+/* 
+ * Allocate space for the fileindex structure
+ */
+
+int ALLOC_INDEX_FILE(FileIndex *fileindex)
+{
+  int status = 0;
+  
+  fileindex->gribinfo = (GribInfo *)malloc(sizeof(GribInfo));
+  if (fileindex->gribinfo == NULL) {
+    fprintf(stderr,"Allocating fileindex->gribinfo failed.\n");
+    status = 1;
+    return status;
+  }
+  
+  fileindex->metadata = (MetaData *)malloc(sizeof(MetaData));
+  if (fileindex->metadata == NULL) {
+    fprintf(stderr,"Allocating fileindex->metadata failed.\n");
+    status = 1;
+    return status;
+  }
+  fileindex->metadata->elements = NULL;
+  
+  fileindex->times = (Times *)malloc(sizeof(Times));
+  if (fileindex->times == NULL) {
+    fprintf(stderr,"Allocating fileindex->times failed.\n");
+    status = 1;
+    return status;
+  }
+  fileindex->times->elements = NULL;
+  
+  return status;
+}
+
+
+void FREE_INDEX_FILE(FileIndex *fileindex)
+{
+  int status = 0;
+  
+  rg_free_gribinfo_elements(fileindex->gribinfo);
+  free(fileindex->gribinfo);
+
+  free(fileindex->metadata->elements);
+  free(fileindex->metadata);
+
+  free(fileindex->times->elements);
+  free(fileindex->times);
+
+}
+
+
+int INDEX_FILE(int *fid, FileIndex *fileindex)
+{
+
+  int status;
+  /* Index the grib records */
+
+  status = rg_setup_gribinfo_i(fileindex->gribinfo,*fid,1);
+  if (status < 0) {
+    fprintf(stderr,"Error setting up gribinfo structure.\n");
+    return 1;
+  }
+
+  /* Index the metadata section */
+
+  status = index_metadata(fileindex->gribinfo, fileindex->metadata, *fid);
+  if (status != 0) {
+    fprintf(stderr,"Error setting up metadata structure.\n");
+    return 1;
+  }
+
+  /* Setup a list of times based on times in grib records */
+
+  status = index_times(fileindex->gribinfo, fileindex->times);
+  if (status != 0) {
+    fprintf(stderr,"Error indexing times in grib file.\n");
+    return 1;
+  }
+  
+  return 0;
+}
+
+
+int GET_FILEINDEX_SIZE(int *size)
+{
+  *size = sizeof(FileIndex);
+  return *size;
+}
+
+
+int GET_NUM_TIMES(FileIndex *fileindex, int *numtimes)
+{
+  *numtimes = (fileindex->times)->num_elements;
+  return *numtimes;
+}
+
+
+int GET_TIME(FileIndex *fileindex, int *idx, char time[])
+{
+  int num_times;
+  int year, month, day, minute, hour, second;
+  char time2[100];
+
+  num_times = GET_NUM_TIMES(fileindex,&num_times);
+  if (*idx > num_times) 
+    {
+      fprintf(stderr,"Tried to get time %d, but only %d times exist\n",
+	      *idx, num_times);
+      return 1;
+    }
+
+  strcpy(time,fileindex->times->elements[*idx-1].valid_time);
+  
+  /* Reformat time to meet WRF time format */
+
+  sscanf(time, "%4d%2d%2d%2d%2d%2d", 
+	 &year, &month, &day, &hour, &minute, &second);
+  sprintf(time2, "%04d-%02d-%02d_%02d:%02d:%02d", 
+	  year, month, day, hour, minute, second);
+  strncpy(time,time2,19);
+
+  return 0;
+}
+
+
+int GET_LEVEL1(FileIndex *fileindex, int *idx, int *level1)
+{
+
+  *level1 = (fileindex->gribinfo)->elements[*idx].usHeight1;
+
+  return *level1;
+
+}
+
+
+int GET_LEVEL2(FileIndex *fileindex, int *idx, int *level2)
+{
+
+  *level2 = (fileindex->gribinfo)->elements[*idx].usHeight2;
+
+  return *level2;
+
+}
+
+
+int index_metadata(GribInfo *gribinfo, MetaData *metadata, int fid)
+{
+  int status=0;
+  int end;
+  char string[11];
+  int found_metadata=0;
+  int idx;
+  int pos;
+  int fileend;
+  int seekpos;
+  int bytesread;
+  char line[1000];
+  char element[100],datestr[100],varname[100];
+  char value[1000];
+  int incomment;
+  int charidx;
+  int elemidx=0;
+  FILE *stream;
+
+
+  /* Associate a FILE *stream with the file id */
+  stream = fdopen(fid,"r");
+  if (stream == NULL) 
+    {
+      perror("Error associating stream with file descriptor");
+      status = -1;
+      return status;
+    }
+  
+  /* 
+   * First, set the position to end of grib data (the 
+   *   metadata section comes after the grib data).
+   */
+  idx = rg_num_elements(gribinfo) - 1;
+  end = rg_get_end(gribinfo,idx);
+  pos = end + 1;
+  fileend = lseek(fid,0,SEEK_END);
+
+  /*
+   * Now, start searching for metadata 
+   */
+  while (pos < (fileend - 10))
+    {
+      seekpos = pos;
+      pos = lseek(fid,seekpos,SEEK_SET);
+      if (pos != seekpos) 
+	{
+	  fprintf(stderr,"Error seeking %d bytes in file\n",end);
+	  perror("");
+	  return 1;
+	}
+
+      bytesread = read(fid,string,10);
+      if (bytesread != 10) 
+	{
+	  fprintf(stderr,"Invalid read, pos: %d :\n",pos);
+	  perror("");
+	  pos += 1;
+	  continue;
+	}
+
+      if (strncmp(string,"",10) == 0) 
+	{
+	  /* We found it, so break out ! */
+	  found_metadata = 1;
+	  break;
+	}
+      pos += 1;
+    }
+
+
+  /* Now, read metadata, line by line */
+  incomment = 0;
+  while(fgets(line,1000,stream) != NULL)
+    {
+      trim(line);
+
+      /* Set comment flag, if we found a comment */
+      if (strncmp(line,"",3) == 0)
+		{
+		  strcpy(line,line+charidx+3);
+		  incomment = 0;
+		  break;
+		}
+	      else
+		{
+		  charidx++;
+		}
+	    }
+	}
+
+      if (incomment) continue;
+  
+
+      /* Check for end of metadata */
+      if (strncmp(line,"",11) == 0) 
+	{
+	  /* We found end of data, so, break out */
+	  break;
+	}
+
+      /* Skip blank lines */
+      if (strlen(line) == 0) continue;
+
+
+      /* Parse line */
+      trim(line);
+      strcpy(element,"none");
+      strcpy(datestr,"none");
+      strcpy(varname,"none");
+      strcpy(value,"none");
+      if (sscanf(line,"%[^;=];%[^;=];%[^;=]=%[^\n]",varname,datestr,
+		 element,value) == 4)
+	{
+	}
+      else if (sscanf(line,"%[^;=];%[^;=]=%[^\n]",datestr,element,value) == 3)
+	{
+	  strcpy(varname,"none");
+	}
+      else if (sscanf(line,"%[^;=]=%[^\n]",element,value) == 2)
+	{
+	  strcpy(varname,"none");
+	  strcpy(datestr,"none");
+	}
+      else 
+	{
+	  strcpy(varname,"none");
+	  strcpy(datestr,"none");
+	  strcpy(element,"none");
+	  strcpy(value,"none");
+	  fprintf(stderr,"Invalid line in metadata: \n%s",line);
+	}
+
+      trim(varname);
+      trim(datestr);
+      trim(element);
+      trim(value);
+
+      metadata->elements = 
+	(MetaData_Elements *)realloc( metadata->elements, 
+				     (elemidx+1)*sizeof(MetaData_Elements) );
+      strcpy(metadata->elements[elemidx].VarName,varname);
+      strcpy(metadata->elements[elemidx].DateStr,datestr);
+      strcpy(metadata->elements[elemidx].Element,element);
+      strcpy(metadata->elements[elemidx].Value,value);
+
+      elemidx++;
+	
+    }
+
+  metadata->num_elements = elemidx;
+  
+  return 0;
+}
+
+
+
+
+int index_times(GribInfo *gribinfo, Times *times)
+{
+  int idx;
+  int status;
+  int numtimes=0;
+  int date;
+  char valid_time[15];
+  char tmp[15];
+  int swapped;
+
+  times->num_elements = 0;
+
+  /* Loop through elements, and build list of times */
+
+  for (idx=0; idx < gribinfo->num_elements; idx++) 
+    {
+      /* Calculate valid time */
+      status = rg_get_valid_time(gribinfo,idx,valid_time);
+      if (status != 0) 
+	{
+	  fprintf(stderr,"Could not retrieve valid time for index: %d\n",idx);
+	  continue;
+	}
+
+      /* 
+       * Check if this time is already contained in times
+       *  If not, allocate space for it, and add it to list 
+       */
+      if (find_time(times,valid_time) < 0) 
+	{
+	  times->num_elements++;
+	  times->elements = 
+	    (Times_Elements *)
+	    realloc(times->elements,times->num_elements*sizeof(Times_Elements));
+	  if (times->elements == NULL) 
+	    {
+	      fprintf(stderr,"Allocating times->elements failed.\n");
+	      status = 1;
+	      return status;
+	    }
+	  strcpy(times->elements[times->num_elements - 1].valid_time,valid_time);
+	}
+    }
+
+  /* Sort times */
+  swapped = 1;
+  while (swapped)
+    {
+      swapped=0;
+      for (idx=1; idx < times->num_elements; idx++) 
+	{
+	  if (strcmp(times->elements[idx-1].valid_time,
+		     times->elements[idx].valid_time) > 0)
+	    {
+	      strcpy(tmp,times->elements[idx-1].valid_time);
+	      strcpy(times->elements[idx-1].valid_time,
+		     times->elements[idx].valid_time);
+	      strcpy(times->elements[idx].valid_time, tmp);
+	      swapped = 1;
+	    }
+	}
+    }
+
+  return 0;
+}
+
+
+
+int find_time(Times *times, char valid_time[15])
+{
+  int idx;
+  int found_elem = -1;
+
+  for (idx = 0; idx < times->num_elements; idx++) 
+    {
+      if (strcmp(times->elements[idx].valid_time,valid_time) == 0) 
+	{
+	  found_elem = idx;
+	  break;
+	}
+    }
+
+  return found_elem;
+
+}
+
+
+int GET_METADATA_VALUE(FileIndex *fileindex, char ElementIn[], 
+		       char DateStrIn[], char VarNameIn[], char Value[], 
+		       int *stat, int strlen1, int strlen2, int strlen3, 
+		       int strlen4, int strlen5)
+{
+  int elemidx;
+  int elemnum;
+  char VarName[200];
+  char DateStr[200];
+  char Element[200];
+  int Value_Len;
+
+  *stat = 0;
+
+  strncpy(Element,ElementIn,strlen2);
+  Element[strlen2] = '\0';
+  strncpy(DateStr,DateStrIn,strlen3);
+  DateStr[strlen3] = '\0';
+  strncpy(VarName,VarNameIn,strlen4);
+  VarName[strlen4] = '\0';
+  Value_Len = strlen5;
+
+  elemnum = -1;
+  for (elemidx = 0; elemidx < fileindex->metadata->num_elements; elemidx++)
+    {
+      if (strcmp(Element,fileindex->metadata->elements[elemidx].Element) == 0)
+	{
+	  if (strcmp(DateStr,fileindex->metadata->elements[elemidx].DateStr) 
+	      == 0)
+	    {
+	      if (strcmp(VarName,
+			 fileindex->metadata->elements[elemidx].VarName) == 0)
+		{
+		  elemnum = elemidx;
+		  break;
+		}
+	    }
+	}
+    }
+
+  if (elemnum != -1)
+    {
+      strncpy(Value, fileindex->metadata->elements[elemnum].Value, Value_Len);
+    } 
+  else
+    {
+      strncpy(Value, "none", Value_Len);
+      *stat = 1;
+    }
+
+  /* 
+   * Pad end of string with one space.  This allows Fortran internal
+   *   read function to work properly.
+   */
+  if (strlen(Value) < Value_Len) 
+    {
+      strcpy(Value + strlen(Value), " ");
+    }
+
+  return elemidx;
+}
+
+
+int GET_GRIB_INDEX(FileIndex *fileindex, int *center, int *subcenter, 
+		   int *parmtbl, int *parmid, char DateStrIn[], 
+		   int *leveltype, int *level1, int *level2, int *fcsttime1,
+		   int *fcsttime2, int *index, int strlen1, int strlen2)
+{
+  char DateStr[1000];
+  FindGrib findgrib;
+
+  strncpy(DateStr,DateStrIn,strlen2);
+  DateStr[strlen2] = '\0';
+  grib_time_format(DateStr,DateStr);
+
+  rg_init_findgrib(&findgrib);
+
+  strncpy(findgrib.initdate,DateStrIn,strlen2);
+  findgrib.initdate[strlen2] = '\0';
+  findgrib.parmid          = *parmid;
+  findgrib.leveltype       = *leveltype;
+  findgrib.level1          = *level1;
+  findgrib.level2          = *level2;
+  findgrib.fcsttime1       = *fcsttime1;
+  findgrib.fcsttime2       = *fcsttime2;
+  findgrib.center_id       = *center;
+  findgrib.subcenter_id    = *subcenter;
+  findgrib.parmtbl_version = *parmtbl;
+  
+  *index = rg_get_index(fileindex->gribinfo, &findgrib);
+
+  return *index;
+
+}
+
+
+int GET_GRIB_INDEX_GUESS(FileIndex *fileindex, int *center, int *subcenter, 
+			 int *parmtbl, int *parmid, char DateStrIn[], 
+			 int *leveltype, int *level1, int *level2, 
+			 int *fcsttime1,int *fcsttime2, int *guessidx, 
+			 int *index, int strlen1, int strlen2)
+{
+  char DateStr[1000];
+  FindGrib findgrib;
+
+  strncpy(DateStr,DateStrIn,strlen2);
+  DateStr[strlen2] = '\0';
+  grib_time_format(DateStr,DateStr);
+
+  rg_init_findgrib(&findgrib);
+
+  strncpy(findgrib.initdate,DateStrIn,strlen2);
+  findgrib.initdate[strlen2] = '\0';
+  findgrib.parmid          = *parmid;
+  findgrib.leveltype       = *leveltype;
+  findgrib.level1          = *level1;
+  findgrib.level2          = *level2;
+  findgrib.fcsttime1       = *fcsttime1;
+  findgrib.fcsttime2       = *fcsttime2;
+  findgrib.center_id       = *center;
+  findgrib.subcenter_id    = *subcenter;
+  findgrib.parmtbl_version = *parmtbl;
+  
+  *index = rg_get_index_guess(fileindex->gribinfo, &findgrib, *guessidx);
+
+  return *index;
+
+}
+
+
+int GET_GRIB_CENTER(FileIndex *fileindex, int *parmid, int *center)
+{
+
+  *center = rg_get_center_id(fileindex->gribinfo,*parmid);
+
+  return *center;
+
+}
+
+
+int GET_GRIB_SUBCENTER(FileIndex *fileindex, int *parmid, int *subcenter)
+{
+
+  *subcenter = rg_get_subcenter_id(fileindex->gribinfo,*parmid);
+
+  return *subcenter;
+
+}
+
+
+int GET_GRIB_TBLVERSION(FileIndex *fileindex, int *parmid, int *parmtbl)
+{
+
+  *parmtbl = rg_get_parmtbl(fileindex->gribinfo,*parmid);
+
+  return *parmtbl;
+
+}
+
+
+int GET_GRIB_PROCID(FileIndex *fileindex, int *parmid, int *proc_id)
+{
+
+  *proc_id = rg_get_proc_id(fileindex->gribinfo,*parmid);
+
+  return *proc_id;
+
+}
+
+
+int GET_GRIB_INDEX_VALIDTIME(FileIndex *fileindex, int *center, 
+		   int *subcenter, int *parmtbl, int *parmid, 
+		   char DateStrIn[], int *leveltype, int *level1, int *level2,
+		   int *index, int strlen1, int strlen2)
+{
+  char DateStr[1000];
+  FindGrib findgrib;
+
+  strncpy(DateStr,DateStrIn,strlen2);
+  DateStr[strlen2] = '\0';
+  grib_time_format(DateStr,DateStr);
+
+  rg_init_findgrib(&findgrib);
+
+  strncpy(findgrib.validdate,DateStr,strlen2);
+  findgrib.initdate[strlen2] = '\0';
+  findgrib.parmid          = *parmid;
+  findgrib.leveltype       = *leveltype;
+  findgrib.level1          = *level1;
+  findgrib.level2          = *level2;
+  findgrib.center_id       = *center;
+  findgrib.subcenter_id    = *subcenter;
+  findgrib.parmtbl_version = *parmtbl;
+  
+  *index = rg_get_index(fileindex->gribinfo, &findgrib);
+
+  return *index;
+}
+
+
+int GET_GRIB_INDEX_VALIDTIME_GUESS(FileIndex *fileindex, int *center, 
+				   int *subcenter, int *parmtbl, int *parmid, 
+				   char DateStrIn[], int *leveltype, 
+				   int *level1, int *level2, int *guessidx, 
+				   int *index, int strlen1, int strlen2)
+{
+  char DateStr[1000];
+  FindGrib findgrib;
+
+  strncpy(DateStr,DateStrIn,strlen2);
+  DateStr[strlen2] = '\0';
+  grib_time_format(DateStr,DateStr);
+
+  rg_init_findgrib(&findgrib);
+
+  strncpy(findgrib.validdate,DateStr,strlen2);
+  findgrib.initdate[strlen2] = '\0';
+  findgrib.parmid          = *parmid;
+  findgrib.leveltype       = *leveltype;
+  findgrib.level1          = *level1;
+  findgrib.level2          = *level2;
+  findgrib.center_id       = *center;
+  findgrib.subcenter_id    = *subcenter;
+  findgrib.parmtbl_version = *parmtbl;
+  
+  *index = rg_get_index_guess(fileindex->gribinfo, &findgrib, *guessidx);
+
+  return *index;
+}
+
+
+int GET_GRIB_INDICES(FileIndex *fileindex, int *center, int *subcenter, 
+		     int *parmtbl,int *parmid, char DateStrIn[], 
+		     int *leveltype, int *level1, int *level2, int *fcsttime1,
+		     int *fcsttime2, int *indices, int *num_indices, 
+		     int strlen1, int strlen2)
+{
+  char DateStr[1000];
+  int status;
+  FindGrib findgrib;
+
+  strncpy(DateStr,DateStrIn,strlen2);
+  DateStr[strlen2] = '\0';
+  grib_time_format(DateStr,DateStr);
+
+  rg_init_findgrib(&findgrib);
+
+  strncpy(findgrib.initdate,DateStrIn,strlen2);
+  findgrib.initdate[strlen2] = '\0';
+  trim(findgrib.initdate);
+  findgrib.parmid          = *parmid;
+  findgrib.leveltype       = *leveltype;
+  findgrib.level1          = *level1;
+  findgrib.level2          = *level2;
+  findgrib.fcsttime1       = *fcsttime1;
+  findgrib.fcsttime2       = *fcsttime2;
+  findgrib.center_id       = *center;
+  findgrib.subcenter_id    = *subcenter;
+  findgrib.parmtbl_version = *parmtbl;
+
+  *num_indices = rg_get_indices(fileindex->gribinfo, &findgrib, indices);
+
+  return (*num_indices);
+
+}
+
+
+int GET_GRID_INFO_SIZE(int *size)
+{
+
+  *size = sizeof(Grid_Info);
+
+  return *size;
+
+}
+
+
+int LOAD_GRID_INFO(char *varnameIn, char *initdateIn, int *leveltype, 
+		   int *level1, int *level2, float *fcst_time, 
+		   int *accum_period, int *grid_id, int *projection, 
+		   int *xpoints, int *ypoints, float *center_lat, 
+		   float *center_lon, float *Di, float *Dj,float *central_lon,
+		   int *proj_center_flag, float *latin1, 
+		   float *latin2, Grib1_Tables *grib_tables,
+		   Grid_Info *grid_info, int strlen1, int strlen2)
+{
+
+  char varname[1000], initdate[1000];
+
+  strncpy(varname,varnameIn,strlen1);
+  varname[strlen1] = '\0';
+  strncpy(initdate,initdateIn,strlen2);
+  initdate[strlen2] = '\0';
+
+  strcpy(grid_info->varname, varname);
+  strcpy(grid_info->initdate, initdate);
+  grid_info->leveltype        = *leveltype;
+  grid_info->level1           = *level1 ;
+  grid_info->level2           = *level2 ;
+  grid_info->fcst_time        = *fcst_time ;
+  grid_info->accum_period     = *accum_period ;
+  grid_info->grid_id          = *grid_id ;
+  grid_info->projection       = *projection ;
+  grid_info->xpoints          = *xpoints ;
+  grid_info->ypoints          = *ypoints ;
+  grid_info->center_lat       = *center_lat ;
+  grid_info->center_lon       = *center_lon;
+  grid_info->Di               = *Di ;
+  grid_info->Dj               = *Dj ;
+  grid_info->central_lon      = *central_lon ;
+  grid_info->proj_center_flag = *proj_center_flag ;
+  grid_info->latin1           = *latin1 ;
+  grid_info->latin2           = *latin2 ;
+  grid_info->grib_tables      = copy_grib_tables(grib_tables);
+
+  return 0;
+
+}
+
+int PRINT_GRID_INFO(Grid_Info *grid_info)
+{
+
+  fprintf(stdout,"varname        =%s\n",grid_info->varname);
+  fprintf(stdout,"initdate       =%s\n",grid_info->initdate);
+  fprintf(stdout,"leveltype      =%d\n",grid_info->leveltype);
+  fprintf(stdout,"level1         =%d\n",grid_info->level1);
+  fprintf(stdout,"level2         =%d\n",grid_info->level2);
+  fprintf(stdout,"fcst_time      =%f\n",grid_info->fcst_time);
+  fprintf(stdout,"accum_period   =%d\n",grid_info->accum_period);
+  fprintf(stdout,"grid_id        =%d\n",grid_info->grid_id);
+  fprintf(stdout,"projection     =%d\n",grid_info->projection);
+  fprintf(stdout,"xpoints        =%d\n",grid_info->xpoints);
+  fprintf(stdout,"ypoints        =%d\n",grid_info->ypoints);
+  fprintf(stdout,"center_lat     =%f\n",grid_info->center_lat);
+  fprintf(stdout,"center_lon     =%f\n",grid_info->center_lon);
+  fprintf(stdout,"Di             =%f\n",grid_info->Di);
+  fprintf(stdout,"Dj             =%f\n",grid_info->Dj);
+  fprintf(stdout,"central_lon    =%f\n",grid_info->central_lon);
+  fprintf(stdout,"proj_center_flag =%d\n",grid_info->proj_center_flag);
+  fprintf(stdout,"latin1         =%f\n",grid_info->latin1);
+  fprintf(stdout,"latin2         =%f\n",grid_info->latin2);
+
+  return 0;
+
+}
+
+
+int GET_SIZEOF_GRID(FileIndex *fileindex, int *index, int *numcols, 
+		    int *numrows)
+{
+
+  *numcols = rg_get_numcols(fileindex->gribinfo,*index);
+
+  *numrows = rg_get_numrows(fileindex->gribinfo,*index);
+
+  return (*numcols)*(*numrows);
+
+}
+
+
+void FREE_GRID_INFO(Grid_Info *grid_info)
+{
+  FREE_GRIBMAP(grid_info->grib_tables);
+}
+
+
+int READ_GRIB(FileIndex *fileindex, int *fid, int *index, float *data)
+{
+  int status;
+
+  status = rg_get_data_1d(fileindex->gribinfo,*index,data);
+
+  return status;
+}
+
+#define WRF_LATLON 0
+#define WRF_LAMBERT 1
+#define WRF_POLAR_STEREO 2
+#define WRF_MERCATOR 3
+
+#define LINESIZE 300
+
+#define SECS_IN_SEC 1
+#define SECS_IN_MIN 60
+#define MINS_IN_HOUR 60
+#define MINS_IN_5MINS 5
+#define HOURS_IN_DAY 24
+
+#define MAX_FCST 65535
+#define MAX_FCST_SECS MAX_FCST*SECS_IN_SEC
+#define MAX_FCST_MINS MAX_FCST*SECS_IN_MIN
+#define MAX_FCST_5MINS MAX_FCST*MINS_IN_5MINS*SECS_IN_MIN
+#define MAX_FCST_HOURS MAX_FCST*MINS_IN_HOUR*SECS_IN_MIN
+#define MAX_FCST_DAYS MAX_FCST*HOURS_IN_DAY*MINS_IN_HOUR*SECS_IN_MIN
+
+#define MAX1B_FCST 256
+#define MAX1B_FCST_SECS MAX1B_FCST*SECS_IN_SEC
+#define MAX1B_FCST_MINS MAX1B_FCST*SECS_IN_MIN
+#define MAX1B_FCST_5MINS MAX1B_FCST*MINS_IN_5MINS*SECS_IN_MIN
+#define MAX1B_FCST_HOURS MAX1B_FCST*MINS_IN_HOUR*SECS_IN_MIN
+#define MAX1B_FCST_DAYS MAX1B_FCST*HOURS_IN_DAY*MINS_IN_HOUR*SECS_IN_MIN
+
+#define PI 3.1415
+typedef struct {
+  int time_range;
+  int fcst_unit;
+  int P1;
+  int P2;
+
+  int time_range_ext;
+  int fcst_unit_ext_1;
+  int fcst_unit_ext_2;
+  int P1_ext;
+  int P2_ext;
+} FcstTimeStruct;
+
+int get_fcst_time(int accum_period, int fcst_secs, FcstTimeStruct *fcst_time);
+
+/****************************************************************************
+ *
+ * This function takes in metadata in the grid_info structure, output data in 
+ *   the *data array, and calls routines to write the metadata and data 
+ *   in grib version 1 format the open file descriptor filefd.
+ *
+ ****************************************************************************/
+
+int WRITE_GRIB(Grid_Info *grid_info, int *filefd, float *data)
+{
+
+  GRIB_HDR *gh=NULL;
+  DATA_INPUT data_input;
+  GEOM_IN geom_in;
+  USER_INPUT user_input;
+  int grid_projection;
+  int status;
+  float x_center, y_center;
+  GridNav gridnav;
+  float first_lat, first_lon, last_lat, last_lon;
+  int year, month, day, hour, minute;
+  float second;
+  char varname2[1000];
+  int table_index;
+  int fcst_unit;
+  int time_range;
+  int P1, P2;
+  int fcst_unit_ext_1, fcst_unit_ext_2;
+  int P1_ext, P2_ext;
+  int time_range_ext;
+  char errmsg[1000];
+  int center, subcenter, parmtbl;
+  int tablenum;
+  FcstTimeStruct fcst_time;
+
+  strcpy(varname2,grid_info->varname);
+  trim(varname2);
+
+  sscanf(grid_info->initdate,"%d-%d-%d_%d:%d:%f",
+	 &year,&month,&day,&hour,&minute,&second);
+
+  /* Get coords of center of grid */
+  x_center = (grid_info->xpoints + 1)/2.;
+  y_center = (grid_info->ypoints + 1)/2.;
+
+  grid_projection = get_gridnav_projection(grid_info->projection);
+
+ /* Initialize grid structure */
+  status = GRID_init(grid_info->center_lat, grid_info->central_lon, 
+		     grid_projection,
+		     grid_info->latin1, grid_info->latin2, 
+		     grid_info->xpoints, grid_info->ypoints, grid_info->Di, 
+		     grid_info->Dj,
+		     grid_info->center_lat, grid_info->center_lon, 
+		     x_center, y_center,
+		     &gridnav);
+  if (!status)
+    {
+      fprintf(stderr,"write_grib: error from GRID_init\n");
+    }
+
+  /* get lat/lon of lower left corner */
+  status = GRID_to_latlon(&gridnav, 1, 1, &first_lat, &first_lon);
+  if (!status)
+    {
+      fprintf(stderr,
+	      "write_grib: error from GRID_to_latlon for first lat/lon\n");
+    }
+
+  /* get lat/lon of upper right corner */
+  status = GRID_to_latlon(&gridnav, grid_info->xpoints, grid_info->ypoints, 
+			  &last_lat, &last_lon);
+  if (!status)
+    {
+      fprintf(stderr,
+	      "write_grib: error from GRID_to_latlon for last lat/lon\n");
+    }
+
+  /* Read the grib parameter table */
+  status = GET_GRIB_PARAM(grid_info->grib_tables, varname2, ¢er,
+			   &subcenter, &parmtbl, &tablenum, &table_index,
+			  1,strlen(varname2));
+  if (table_index < 0)
+    {
+      fprintf(stderr,\
+              "Skipping %s, Could not find parameter for %s in gribmap.txt\n",\
+              varname2,varname2);
+      return 1;
+    }
+
+  /* 
+   * We skip any parameters that are listed in parameter 255 in gribmap.txt.
+   * Parameter 255 is used to indicate that a WRF parameter should not be 
+   * output.  It is useful for parameters that are requested to be output in
+   * the WRF Registry, but are already implicitly output in grib.
+   */
+
+  if (table_index == 255)
+    {
+      return 0;
+    }
+
+  /* 
+   * Setup the geom_in structure for the grib library.  Here, we set
+   *  the generic parms.  Below, we set the projection specific parms
+   */
+  geom_in.nx = grid_info->xpoints;
+  geom_in.ny = grid_info->ypoints;
+  geom_in.first_lat = first_lat;
+  geom_in.first_lon = first_lon;
+  geom_in.last_lat = last_lat;
+  geom_in.last_lon = last_lon;
+  geom_in.scan = 64;
+
+  switch (grid_info->projection) 
+    {
+    case WRF_LATLON:
+      strcpy(geom_in.prjn_name,"spherical");
+      geom_in.parm_1 = grid_info->Dj;
+      geom_in.parm_2 = grid_info->Di;
+      geom_in.parm_3 = -1;
+      geom_in.usRes_flag = 0;  /* 
+				* Set to 0 here, MEL grib library will reset
+				*  to 128 to indicate that direction 
+				*  increments are given.
+				*/
+      break;
+    case WRF_MERCATOR:
+      strcpy(geom_in.prjn_name,"mercator");
+      geom_in.parm_1 = grid_info->latin1;
+      geom_in.parm_2 = grid_info->Di;
+      geom_in.parm_3 = grid_info->Dj;
+      geom_in.usRes_flag = 128;
+      break;
+    case WRF_LAMBERT:
+      strcpy(geom_in.prjn_name,"lambert");
+      geom_in.usRes_flag = 0;   /* Set to 0 here, MEL grib library will reset 
+				 * to 128.
+				 */
+      geom_in.parm_3 = grid_info->central_lon;
+      geom_in.x_int_dis = grid_info->Di;
+      geom_in.y_int_dis = grid_info->Dj;
+      geom_in.parm_1 = grid_info->latin1;
+      geom_in.parm_2 = grid_info->latin2;
+      break;
+    case WRF_POLAR_STEREO:
+      strcpy(geom_in.prjn_name,"polar_stereo");
+      geom_in.usRes_flag = 0;   /* Set to 0 here, MEL grib library will reset 
+				 * to 128.
+				 */
+
+      geom_in.parm_3 = -1;
+      geom_in.x_int_dis = grid_info->Di*(1.+sin(60. * PI/180.))
+	/ (1.+sin(abs(grid_info->latin1) * PI/180.));
+      geom_in.y_int_dis = grid_info->Dj*(1.+sin(60. * PI/180.))
+	/ (1.+sin(abs(grid_info->latin1) * PI/180.));
+      geom_in.parm_1 = -1;
+      geom_in.parm_2 = grid_info->central_lon;
+      break;
+    default:
+      fprintf(stderr,"Error, invalid projection: %d\n",grid_info->projection);
+      return 1;
+    }
+
+  /* 
+   * Setup the data_input structure.
+   */
+  data_input.nDec_sc_fctr = 
+    grid_info->grib_tables->grib_table_info[tablenum].dec_sc_factor[table_index];
+  data_input.usProc_id = 220;
+  data_input.usGrid_id = grid_info->grid_id;
+  data_input.usParm_id = 
+    grid_info->grib_tables->grib_table_info[tablenum].parm_id[table_index];
+  data_input.usParm_sub_id = 
+    grid_info->grib_tables->grib_table_info[tablenum].subcenter;
+  data_input.usLevel_id = grid_info->leveltype;
+
+  if (grid_info->leveltype == 112) {
+    data_input.nLvl_1 = grid_info->level2;
+    data_input.nLvl_2 = grid_info->level1;
+  } else {
+    data_input.nLvl_1 = grid_info->level1;
+    data_input.nLvl_2 = grid_info->level2;
+  }
+
+  data_input.nYear = year;
+  data_input.nMonth = month;
+  data_input.nDay = day;
+  data_input.nHour = hour;
+  data_input.nMinute = minute;
+  data_input.nSecond = second;
+
+  status = get_fcst_time(grid_info->accum_period, grid_info->fcst_time, 
+			 &fcst_time);
+
+  data_input.usFcst_id = fcst_time.fcst_unit;
+  data_input.usFcst_per1 = fcst_time.P1;
+  data_input.usFcst_per2 = fcst_time.P2;
+  data_input.usTime_range_id = fcst_time.time_range;
+  data_input.usTime_range_avg = 0;
+  data_input.usTime_range_mis = 0;
+  /* 
+   * This is for WSI's extended PDS section 
+   */
+  data_input.PDS_41 = fcst_time.fcst_unit_ext_1;
+  data_input.PDS_42 = fcst_time.P1_ext;
+  data_input.PDS_46 = fcst_time.fcst_unit_ext_2;
+  data_input.PDS_47 = fcst_time.P2_ext;
+  data_input.PDS_51 = fcst_time.time_range_ext;
+  data_input.PDS_52 = 0;
+
+
+  data_input.nDec_sc_fctr = 
+    grid_info->grib_tables->grib_table_info[tablenum].dec_sc_factor[table_index];
+  user_input.usCenter_id = 
+    grid_info->grib_tables->grib_table_info[tablenum].center;
+  user_input.usParm_tbl = 
+    grid_info->grib_tables->grib_table_info[tablenum].parmtbl;
+  user_input.chCase_id='0';
+  user_input.usSub_tbl = 0;
+  user_input.usCenter_sub = 
+    grid_info->grib_tables->grib_table_info[tablenum].subcenter;
+  user_input.usTrack_num = 0;
+  user_input.usGds_bms_id = 128;
+  user_input.usBDS_flag = 0;
+  user_input.usBit_pack_num = 0;
+
+  status = init_gribhdr(&gh,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"write_grib: Error writing %s: \n\t%s\n",varname2,errmsg);
+    return 1;
+  }
+
+  status = grib_enc(data_input,user_input,geom_in,data,gh,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"write_grib: Error writing %s: \n\t%s\n",varname2,errmsg);
+    fprintf (stderr,"\tCheck precision for %s in gribmap.txt.\n",
+	     varname2);
+    return 1;
+  }
+
+  status = gribhdr2filed(gh,*filefd,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"write_grib: Error writing %s: \n\t%s\n",varname2,errmsg);
+    return 1;
+  }
+
+  free_gribhdr(&gh);
+
+  return 0;
+}
+
+/***************************************************************************
+ * Function to set up a structure containing forecast time parameters
+ *  This encodes the standard grib forecast time parameters as well
+ *  as WSI's extended forecast time parameters.
+ ***************************************************************************/
+
+int get_fcst_time(int accum_period, int fcst_secs, FcstTimeStruct *ft)
+{
+  /* 
+   * Added ability to output a "5-minute" forecast time unit for the
+   *   sake of WxProducer.  This allows WxPro to ingest data beyond
+   *   18 hours, and accumulation data beyond 255 units.
+   */
+
+  /*
+   * Initialize.
+   */
+  ft->time_range = 0;
+  ft->fcst_unit = 0;
+  ft->P1 = 0;
+  ft->P2 = 0;
+  ft->fcst_unit_ext_1 = 0;
+  ft->fcst_unit_ext_2 = 0;
+  ft->P1_ext = 0;
+  ft->P2_ext = 0;
+  ft->time_range_ext = 0;
+
+  if (accum_period == 0) 
+    {
+      if (fcst_secs < MAX_FCST_SECS)
+	{
+	  ft->time_range = 10;
+	  ft->fcst_unit = 254;
+	  ft->P1 = get_byte(fcst_secs,2);
+	  ft->P2 = get_byte(fcst_secs,1);
+	}
+      else if (((fcst_secs % SECS_IN_MIN) == 0) &&
+	       (fcst_secs < MAX_FCST_MINS))
+	{
+	  ft->time_range = 10;
+	  ft->fcst_unit = 0;
+	  ft->P1 = get_byte(fcst_secs/SECS_IN_MIN,2);
+	  ft->P2 = get_byte(fcst_secs/SECS_IN_MIN,1);
+	}
+      else if (((fcst_secs % SECS_IN_MIN*MINS_IN_HOUR) == 0) && 
+	       (fcst_secs < MAX_FCST_HOURS))
+	{
+	  ft->time_range = 10;
+	  ft->fcst_unit = 1;
+	  ft->P1 = get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_HOUR),2);
+	  ft->P2 = get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_HOUR),1);      
+	}
+      /* 
+       * MAX_FCST_DAYS is causing an integer overflow, so, we'll just skip 
+       *   the check here.  It's very unlikely that someone would exceed this
+       *   anyway (5.6 million days!)
+       */
+      /*
+      else if (((fcst_secs % SECS_IN_MIN*MINS_IN_HOUR*HOURS_IN_DAY) == 0) &&
+	       (fcst_secs < MAX_FCST_DAYS))
+      */
+      else if (((fcst_secs % SECS_IN_MIN*MINS_IN_HOUR*HOURS_IN_DAY) == 0))
+	{
+	  ft->time_range = 10;
+	  ft->fcst_unit = 2;
+	  ft->P1 = 
+	    get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_HOUR*HOURS_IN_DAY),2);
+	  ft->P2 = 
+	    get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_HOUR*HOURS_IN_DAY),1);
+	}
+      else if (((fcst_secs % SECS_IN_MIN*MINS_IN_5MINS) == 0)
+	       && (fcst_secs < MAX_FCST_5MINS))
+	{
+	  ft->time_range = 10;
+	  ft->fcst_unit = 50;
+	  ft->P1 = get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_5MINS),2);
+	  ft->P2 = get_byte(fcst_secs/(SECS_IN_MIN*MINS_IN_5MINS),1);
+	}
+      else 
+	{
+	  ft->time_range = 255;
+	  ft->fcst_unit = 0;
+	  ft->P1 = 0;
+	  ft->P2 = 0;
+	  
+	  ft->fcst_unit_ext_1 = 254;
+	  ft->fcst_unit_ext_2 = 254;
+	  ft->P1_ext = fcst_secs;
+	  ft->P2_ext = 0;
+	  ft->time_range_ext = 0;
+	}
+    }
+  else  /* Accumulation period is not 0 */
+    {
+      if ((fcst_secs < MAX1B_FCST_HOURS) &&
+	  (fcst_secs%(SECS_IN_MIN*MINS_IN_HOUR) == 0) && 
+	  (accum_period%(SECS_IN_MIN*MINS_IN_HOUR) == 0))
+	{
+	  ft->time_range = 4;
+	  ft->fcst_unit = 1;
+	  ft->P1 = (fcst_secs-accum_period)/(SECS_IN_MIN*MINS_IN_HOUR);
+	  ft->P2 = fcst_secs/(SECS_IN_MIN*MINS_IN_HOUR);
+	}
+      else if ((fcst_secs < MAX1B_FCST_MINS) &&
+	       ((fcst_secs-accum_period)%SECS_IN_MIN == 0) && 
+	       (fcst_secs%SECS_IN_MIN == 0))
+	{
+	  ft->time_range = 4;
+	  ft->fcst_unit = 0;
+	  ft->P1 = (fcst_secs-accum_period)/SECS_IN_MIN;
+	  ft->P2 = fcst_secs/SECS_IN_MIN;
+	}
+      else if (fcst_secs < MAX1B_FCST_SECS)
+	{
+	  ft->time_range = 4;
+	  ft->fcst_unit = 254;
+	  ft->P1 = fcst_secs-accum_period;
+	  ft->P2 = fcst_secs;
+	}
+      else if ((fcst_secs < MAX1B_FCST_5MINS) && 
+	       (fcst_secs%(SECS_IN_MIN*MINS_IN_5MINS) == 0) &&
+	       (accum_period%(SECS_IN_MIN*MINS_IN_5MINS) == 0)) 
+	{
+	  ft->time_range = 4;
+	  ft->fcst_unit = 50;
+	  ft->P1 = (fcst_secs-accum_period)/(SECS_IN_MIN*MINS_IN_5MINS);
+	  ft->P2 = fcst_secs/(SECS_IN_MIN*MINS_IN_5MINS);
+	}
+      else
+	{
+	  ft->time_range = 255;
+	  ft->fcst_unit = 0;
+	  ft->P1 = 0;
+	  ft->P2 = 0;
+	  
+	  ft->fcst_unit_ext_1 = 254;
+	  ft->fcst_unit_ext_2 = 254;
+	  ft->P1_ext = fcst_secs - accum_period;
+	  ft->P2_ext = accum_period;
+	  ft->time_range_ext = 203;    /* Duration */
+	}
+    }
+  return 0;
+}
+
+
+/******************************************************************************
+ * returns a byt from an input integer
+ *****************************************************************************/
+
+int get_byte(int input_int, int bytenum)
+{
+  int out;
+  out = ((input_int >> (bytenum-1)*8) & ~(~0 <<8));
+  return out;
+}
+
+/*************************************************************************
+ * Converts from WRF time format to time format required by grib routines
+ *************************************************************************/
+int grib_time_format(char *DateStr, char *DateStrIn)
+{
+  int year,month,day,hour,minute,second;
+
+  trim(DateStrIn);
+  if (DateStrIn[0] == '*') {
+    strcpy(DateStr,"*");
+  }
+  else
+    {
+      sscanf(DateStrIn,"%04d-%02d-%02d_%02d:%02d:%02d",
+	     &year,&month,&day,&hour,&minute,&second);
+      sprintf(DateStr,"%04d%02d%02d%02d%02d%02d",
+	      year,month,day,hour,minute,second);
+    }
+
+  return 0;
+}
diff --git a/wrfv2_fire/external/io_grib1/grib1_routines.h b/wrfv2_fire/external/io_grib1/grib1_routines.h
new file mode 100644
index 00000000..83061c1d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_routines.h
@@ -0,0 +1,233 @@
+#include "gribfuncs.h"
+#include "read_grib.h"
+#include "gribmap.h"
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define GET_FILEINDEX_SIZE get_fileindex_size
+#      define INDEX_FILE index_file
+#      define GET_METADATA_VALUE get_metadata_value
+#      define GET_GRIB_INDEX get_grib_index
+#      define GET_GRIB_INDEX_GUESS get_grib_index_guess
+#      define GET_GRIB_INDEX_VALIDTIME get_grib_index_validtime
+#      define GET_GRIB_INDEX_VALIDTIME_GUESS get_grib_index_validtime_guess
+#      define GET_GRIB_INDICES get_grib_indices
+#      define ALLOC_INDEX_FILE alloc_index_file
+#      define FREE_INDEX_FILE free_index_file
+#      define GET_NUM_TIMES get_num_times
+#      define GET_LEVEL1 get_level1
+#      define GET_LEVEL2 get_level2
+#      define GET_TIME get_time
+#      define GET_GRID_INFO_SIZE get_grid_info_size
+#      define LOAD_GRID_INFO load_grid_info
+#      define FREE_GRID_INFO free_grid_info
+#      define PRINT_GRID_INFO print_grid_info
+#      define READ_GRIB read_grib
+#      define WRITE_GRIB write_grib
+#      define GET_GRIB_SEARCH_SIZE get_grib_search_size
+#      define LOAD_GRIB_SEARCH load_grib_search
+#      define FREE_GRIB_SEARCH free_grib_search
+#      define GET_SIZEOF_GRID get_sizeof_grid
+#      define GET_GRIB_CENTER get_grib_center
+#      define GET_GRIB_SUBCENTER get_grib_subcenter
+#      define GET_GRIB_TBLVERSION get_grib_tblversion
+#      define GET_GRIB_PROCID get_grib_procid
+# else
+#   ifdef F2CSTYLE
+#      define GET_FILEINDEX_SIZE get_fileindex_size__
+#      define INDEX_FILE index_file__
+#      define GET_METADATA_VALUE get_metadata_value__
+#      define GET_GRIB_INDEX get_grib_index__
+#      define GET_GRIB_INDEX_GUESS get_grib_index_guess__
+#      define GET_GRIB_INDEX_VALIDTIME_GUESS get_grib_index_validtime_guess__
+#      define GET_GRIB_INDICES get_grib_indices__
+#      define ALLOC_INDEX_FILE alloc_index_file__
+#      define FREE_INDEX_FILE free_index_file__
+#      define GET_NUM_TIMES get_num_times__
+#      define GET_LEVEL1 get_level1__
+#      define GET_LEVEL2 get_level2__
+#      define GET_TIME get_time__
+#      define GET_GRID_INFO_SIZE get_grid_info_size__
+#      define LOAD_GRID_INFO load_grid_info__
+#      define FREE_GRID_INFO free_grid_info__
+#      define PRINT_GRID_INFO print_grid_info__
+#      define READ_GRIB read_grib__
+#      define WRITE_GRIB write_grib__
+#      define GET_GRIB_SEARCH_SIZE get_grib_search_size__
+#      define LOAD_GRIB_SEARCH load_grib_search__
+#      define FREE_GRIB_SEARCH free_grib_search__
+#      define GET_SIZEOF_GRID get_sizeof_grid__
+#      define GET_GRIB_CENTER get_grib_center__
+#      define GET_GRIB_SUBCENTER get_grib_subcenter__
+#      define GET_GRIB_TBLVERSION get_grib_tblversion__
+#      define GET_GRIB_PROCID get_grib_procid__
+#   else
+#      define GET_FILEINDEX_SIZE get_fileindex_size_
+#      define INDEX_FILE index_file_
+#      define GET_METADATA_VALUE get_metadata_value_
+#      define GET_GRIB_INDEX get_grib_index_
+#      define GET_GRIB_INDEX_GUESS get_grib_index_guess_
+#      define GET_GRIB_INDEX_VALIDTIME get_grib_index_validtime_
+#      define GET_GRIB_INDEX_VALIDTIME_GUESS get_grib_index_validtime_guess_
+#      define GET_GRIB_INDICES get_grib_indices_
+#      define ALLOC_INDEX_FILE alloc_index_file_
+#      define FREE_INDEX_FILE free_index_file_
+#      define GET_NUM_TIMES get_num_times_
+#      define GET_LEVEL1 get_level1_
+#      define GET_LEVEL2 get_level2_
+#      define GET_TIME get_time_
+#      define GET_GRID_INFO_SIZE get_grid_info_size_
+#      define LOAD_GRID_INFO load_grid_info_
+#      define FREE_GRID_INFO free_grid_info_
+#      define PRINT_GRID_INFO print_grid_info_
+#      define READ_GRIB read_grib_
+#      define WRITE_GRIB write_grib_
+#      define GET_GRIB_SEARCH_SIZE get_grib_search_size_
+#      define LOAD_GRIB_SEARCH load_grib_search_
+#      define FREE_GRIB_SEARCH free_grib_search_
+#      define GET_SIZEOF_GRID get_sizeof_grid_
+#      define GET_GRIB_CENTER get_grib_center_
+#      define GET_GRIB_SUBCENTER get_grib_subcenter_
+#      define GET_GRIB_TBLVERSION get_grib_tblversion_
+#      define GET_GRIB_PROCID get_grib_procid_
+#   endif
+# endif
+#endif
+
+typedef struct {
+  char VarName[100];
+  char DateStr[100];
+  char Element[100];
+  char Value[1000];
+} MetaData_Elements;
+
+typedef struct {
+  int num_elements;
+  MetaData_Elements *elements;
+} MetaData;
+
+typedef struct {
+  char valid_time[30];
+} Times_Elements;
+
+typedef struct {
+  int num_elements;
+  Times_Elements *elements;
+} Times;
+
+typedef struct {
+  MetaData *metadata;
+  GribInfo *gribinfo;
+  Times *times;
+} FileIndex;
+
+typedef struct {
+  char varname[200];
+  char initdate[20];
+  int leveltype;
+  int level1;
+  int level2;
+  float fcst_time;
+  int accum_period;
+  int grid_id;
+  int projection;
+  int xpoints;
+  int ypoints;
+  float center_lat;
+  float center_lon;
+  float Di;
+  float Dj;
+  float central_lon;
+  int proj_center_flag;
+  float latin1;
+  float latin2;
+  Grib1_Tables *grib_tables;
+} Grid_Info;
+
+int GET_FILEINDEX_SIZE(int *size);
+
+int ALLOC_INDEX_FILE(FileIndex *fileindex);
+void FREE_INDEX_FILE(FileIndex *fileindex);
+
+int INDEX_FILE(int *fid, FileIndex *fileindex);
+
+int GET_METADATA_VALUE(FileIndex *fileindex, char Element[], char DateStr[], 
+		       char VarName[], char Value[], int *stat, int strlen1, 
+		       int strlen2, int strlen3, int strlen4, int strlen5);
+
+int GET_GRIB_INDEX(FileIndex *fileindex,
+		   int *center, int *subcenter, int *parmtbl,
+		   int *parmid, char DateStrIn[], 
+		   int *leveltype, int *level1, int *level2, int *fcsttime1,
+		   int *fcsttime2, int *index, int strlen1, int strlen2);
+
+int GET_GRIB_INDEX_GUESS(FileIndex *fileindex, int *center, int *subcenter, 
+			 int *parmtbl, int *parmid, char DateStrIn[], 
+			 int *leveltype, int *level1, int *level2, 
+			 int *fcsttime1,int *fcsttime2, int *guessidx, 
+			 int *index, int strlen1, int strlen2);
+
+int GET_GRIB_INDICES(FileIndex *fileindex, int *center, int *subcenter, 
+		     int *parmtbl,int *parmid, char DateStrIn[], 
+		     int *leveltype, int *level1, int *level2, int *fcsttime1,
+		     int *fcsttime2, int *indices, int *num_indices, 
+		     int strlen1, int strlen2);
+
+int GET_NUM_TIMES(FileIndex *fileindex, int *numtimes);
+
+int GET_TIME(FileIndex *fileindex, int *idx, char time[]);
+
+int GET_GRID_INFO_SIZE(int *size);
+
+int LOAD_GRID_INFO(char *varname, char *initdate, int *leveltype, 
+		   int *level1, int *level2, float *fcst_time, 
+		   int *accum_period, int *grid_id, int *projection, 
+		   int *xpoints, int *ypoints, float *center_lat, 
+		   float *center_lon, float *Di, float *Dj,float *central_lon,
+		   int *proj_center_flag, float *latin1, 
+		   float *latin2, Grib1_Tables *grib_tables,
+		   Grid_Info *grid_info, int strlen1, int strlen2);
+
+int PRINT_GRID_INFO(Grid_Info *grid_info);
+
+int WRITE_GRIB(Grid_Info *grid_info, int *filefd, float *data);
+
+int READ_GRIB(FileIndex *fileindex, int *fid, int *index, float *data);
+
+int GET_SIZEOF_GRID(FileIndex *fileindex, int *index, int *numcols, 
+		    int *numrows);
+
+int GET_LEVEL1(FileIndex *fileindex, int *idx, int *level1);
+
+int GET_LEVEL2(FileIndex *fileindex, int *idx, int *level2);
+
+int GET_GRIB_INDEX_VALIDTIME(FileIndex *fileindex, 
+			     int *center, int *subcenter, int *parmtbl,
+			     int *parmid, 
+			     char DateStrIn[], int *leveltype, int *level1, 
+			     int *level2, int *index, int strlen1, 
+			     int strlen2);
+
+int GET_GRIB_INDEX_VALIDTIME_GUESS(FileIndex *fileindex, int *center, 
+				   int *subcenter, int *parmtbl, int *parmid, 
+				   char DateStrIn[], int *leveltype, 
+				   int *level1, int *level2, int *guessidx, 
+				   int *index, int strlen1, int strlen2);
+
+int GET_GRIB_CENTER(FileIndex *fileindex, int *parmid, int *center);
+
+int GET_GRIB_SUBCENTER(FileIndex *fileindex, int *parmid, int *subcenter);
+
+int GET_GRIB_TBLVERSION(FileIndex *fileindex, int *parmid, int *parmtbl);
+
+int GET_GRIB_PROCID(FileIndex *fileindex, int *parmid, int *proc_id);
+
+int GET_REGION_CENTER(char *MemoryOrderIn, int *projection, 
+		      float *domain_center_lat, 
+		      float *domain_center_lon, int *full_xsize, 
+		      int *full_ysize, float *dx, float *dy, 
+		      float *proj_central_lon, 
+		      int *proj_center_flag, float *truelat1, 
+		      float *truelat2, int *region_xsize, int *region_ysize, 
+		      float *region_center_lat, float *region_center_lon, 
+		      int strlen1);
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/Makefile b/wrfv2_fire/external/io_grib1/grib1_util/Makefile
new file mode 100644
index 00000000..5c75c6e8
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/Makefile
@@ -0,0 +1,63 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+# Specity location for Makefiles that are included.
+#
+BUILD_DIR = ../../io_grib_share/build
+INCLUDEDIRS = -I. -I.. -I ../MEL_grib1
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = ..
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I. -I../MEL_grib1
+CXX_INCLUDES = -I. -I../MEL_grib1
+ARFLAGS      = ruv
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+UNIT_TEST = test_rg
+LIB_NAME = io_grib1
+DEP_LIBS =  -L$(LIB_DEST) -lMEL_grib1
+OBJS =  alloc_2d.o \
+	read_grib.o \
+	write_grib.o
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.c b/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.c
new file mode 100644
index 00000000..5f0c6406
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.c
@@ -0,0 +1,54 @@
+#include "stdio.h"
+#include 
+
+/**************************************************************************
+ * alloc_float_2d - dynamically allocates a two dimensional array
+ * 
+ * Input:
+ *   firsdim   - the number of elements in the first dimension of the array
+ *   seconddim - the number of elements in the second dimension of the array
+ * Return:
+ *   On success, a newly allocated two-dimensional array 
+ *   On failure, NULL
+ * 
+ ***************************************************************************/
+float **alloc_float_2d(int firstdim,int seconddim)
+{
+  float **outvar;
+  int row, row2;
+
+  outvar = (float **)calloc(firstdim,sizeof(float *));
+  if (outvar == NULL) return NULL;
+  for (row=0; row < firstdim; row++) {
+    outvar[row] = (float *)calloc(seconddim,sizeof(float));
+    if (outvar[row] == NULL) {
+      for (row2 = 0; row2 < row; row2++) {
+	free(outvar[row]);
+      }
+      free(outvar);
+      return NULL;
+    }
+  }
+  return outvar;
+}
+
+/**************************************************************************
+ * free_float_2d - frees memory held by a two dimensional array
+ * 
+ * Input:
+ *   var       - the two-dimensional array to be freed
+ *   firsdim   - the number of elements in the first dimension of the array
+ *   seconddim - the number of elements in the second dimension of the array
+ * Return:
+ *   None
+ * 
+ ***************************************************************************/
+
+void free_float_2d(float **var, int firstdim, int seconddim)
+{
+  int row;
+  for (row=0; row < firstdim; row++) {
+    free(var[row]);
+  }
+  free(var);
+}
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.h b/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.h
new file mode 100644
index 00000000..12181d27
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/alloc_2d.h
@@ -0,0 +1,2 @@
+float **alloc_float_2d(int firstdim,int seconddim);
+void free_float_2d(float **var, int firstdim, int seconddim);
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/cfortran.h b/wrfv2_fire/external/io_grib1/grib1_util/cfortran.h
new file mode 100644
index 00000000..81d0bfa9
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/cfortran.h
@@ -0,0 +1,2278 @@
+
+#define pgiFortran
+
+/* cfortran.h  4.1 */          /* anonymous ftp@zebra.desy.de */
+/* Burkhard Burow  burow@desy.de                 1990 - 1998. */
+
+#ifndef __CFORTRAN_LOADED
+#define __CFORTRAN_LOADED
+
+/* 
+   THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
+   SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
+   MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
+*/
+
+/* 
+  Avoid symbols already used by compilers and system *.h:
+  __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c
+
+ */
+
+
+/* First prepare for the C compiler. */
+
+#ifndef ANSI_C_preprocessor /* i.e. user can override. */
+#ifdef __CF__KnR
+#define ANSI_C_preprocessor 0
+#else
+#ifdef __STDC__
+#define ANSI_C_preprocessor 1
+#else
+#define _cfleft             1
+#define _cfright 
+#define _cfleft_cfright     0
+#define ANSI_C_preprocessor _cfleft/**/_cfright
+#endif
+#endif
+#endif
+
+#if ANSI_C_preprocessor
+#define _0(A,B)   A##B
+#define  _(A,B)   _0(A,B)  /* see cat,xcat of K&R ANSI C p. 231 */
+#define _2(A,B)   A##B     /* K&R ANSI C p.230: .. identifier is not replaced */
+#define _3(A,B,C) _(A,_(B,C))
+#else                      /* if it turns up again during rescanning.         */
+#define  _(A,B)   A/**/B
+#define _2(A,B)   A/**/B
+#define _3(A,B,C) A/**/B/**/C
+#endif
+
+#if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
+#define VAXUltrix
+#endif
+
+#include      /* NULL [in all machines stdio.h]                      */
+#include     /* strlen, memset, memcpy, memchr.                     */
+#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
+#include     /* malloc,free                                         */
+#else
+#include     /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/
+#ifdef apollo
+#define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
+#endif
+#endif
+
+#if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx))
+#define __CF__KnR     /* Sun, LynxOS and VAX Ultrix cc only supports K&R.     */
+                      /* Manually define __CF__KnR for HP if desired/required.*/
+#endif                /*       i.e. We will generate Kernighan and Ritchie C. */
+/* Note that you may define __CF__KnR before #include cfortran.h, in order to
+generate K&R C instead of the default ANSI C. The differences are mainly in the
+function prototypes and declarations. All machines, except the Apollo, work
+with either style. The Apollo's argument promotion rules require ANSI or use of
+the obsolete std_$call which we have not implemented here. Hence on the Apollo,
+only C calling FORTRAN subroutines will work using K&R style.*/
+
+
+/* Remainder of cfortran.h depends on the Fortran compiler. */
+
+#ifdef CLIPPERFortran
+#define f2cFortran
+#endif
+
+/* VAX/VMS does not let us \-split long #if lines. */ 
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(pgiFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If no Fortran compiler is given, we choose one for the machines we know.   */
+#if defined(lynx) || defined(VAXUltrix)
+#define f2cFortran    /* Lynx:      Only support f2c at the moment.
+                         VAXUltrix: f77 behaves like f2c.
+                           Support f2c or f77 with gcc, vcc with f2c. 
+                           f77 with vcc works, missing link magic for f77 I/O.*/
+#endif
+#if defined(__hpux)             /* 921107: Use __hpux instead of __hp9000s300 */
+#define       hpuxFortran       /*         Should also allow hp9000s7/800 use.*/
+#endif
+#if       defined(apollo)
+#define           apolloFortran /* __CF__APOLLO67 also defines some behavior. */
+#endif
+#if          defined(sun) || defined(__sun) 
+#define              sunFortran
+#endif
+#if       defined(_IBMR2)
+#define            IBMR2Fortran
+#endif
+#if        defined(_CRAY)
+#define             CRAYFortran /*       _CRAYT3E also defines some behavior. */
+#endif
+#if        defined(_SX)
+#define               SXFortran
+#endif
+#if         defined(mips) || defined(__mips)
+#define             mipsFortran
+#endif
+#if          defined(vms) || defined(__vms)
+#define              vmsFortran
+#endif
+#if      defined(__alpha) && defined(__unix__)
+#define              DECFortran
+#endif
+#if   defined(__convex__)
+#define           CONVEXFortran
+#endif
+#if   defined(VISUAL_CPLUSPLUS)
+#define     PowerStationFortran
+#endif
+#endif /* ...Fortran */
+#endif /* ...Fortran */
+
+/* Split #if into 2 because some HP-UX can't handle long #if */
+#if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran)||defined(pgiFortran))
+#if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
+/* If your compiler barfs on ' #error', replace # with the trigraph for #     */
+ #error "cfortran.h:  Can't find your environment among:\
+    - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...)     \
+    - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000     \
+    - VAX   VMS CC 3.1 and FORTRAN 5.4.                                  \
+    - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0.                           \
+    - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2          \
+    - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7.            \
+    - CRAY                                                               \
+    - NEC SX-4 SUPER-UX                                                  \
+    - CONVEX                                                             \
+    - Sun                                                                \
+    - PowerStation Fortran with Visual C++                               \
+    - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730    \
+    - LynxOS: cc or gcc with f2c.                                        \
+    - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77.             \
+    -            f77 with vcc works; but missing link magic for f77 I/O. \
+    -            NO fort. None of gcc, cc or vcc generate required names.\
+    - f2c    : Use #define    f2cFortran, or cc -Df2cFortran             \
+    - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran          \
+    - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \
+    - Absoft Pro Fortran: Use #define AbsoftProFortran \
+    - Portland Group Fortran: Use #define pgiFortran"
+/* Compiler must throw us out at this point! */
+#endif
+#endif
+
+
+#if defined(VAXC) && !defined(__VAXC)
+#define OLD_VAXC
+#pragma nostandard                       /* Prevent %CC-I-PARAMNOTUSED.       */
+#endif
+
+/* Throughout cfortran.h we use: UN = Uppercase Name.  LN = Lowercase Name.   */
+
+#if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(extname) || defined(pgiFortran)
+#define CFC_(UN,LN)            _(LN,_)      /* Lowercase FORTRAN symbols.     */
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)
+#else 
+#if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran)
+#ifdef _CRAY          /* (UN), not UN, circumvents CRAY preprocessor bug.     */
+#define CFC_(UN,LN)            (UN)         /* Uppercase FORTRAN symbols.     */
+#else                 /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */
+#define CFC_(UN,LN)            UN           /* Uppercase FORTRAN symbols.     */
+#endif
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)  /* CRAY insists on arg.'s here.   */
+#else  /* For following machines one may wish to change the fcallsc default.  */
+#define CF_SAME_NAMESPACE
+#ifdef vmsFortran
+#define CFC_(UN,LN)            LN           /* Either case FORTRAN symbols.   */
+     /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
+     /* because VAX/VMS doesn't do recursive macros.                          */
+#define orig_fcallsc(UN,LN)    UN
+#else      /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */
+#define CFC_(UN,LN)            LN           /* Lowercase FORTRAN symbols.     */
+#define orig_fcallsc(UN,LN)    CFC_(UN,LN)
+#endif /*  vmsFortran */
+#endif /* CRAYFortran PowerStationFortran */
+#endif /* ....Fortran */
+
+#define fcallsc(UN,LN)               orig_fcallsc(UN,LN)
+#define preface_fcallsc(P,p,UN,LN)   CFC_(_(P,UN),_(p,LN))
+#define  append_fcallsc(P,p,UN,LN)   CFC_(_(UN,P),_(LN,p))
+
+#define C_FUNCTION(UN,LN)            fcallsc(UN,LN)      
+#define FORTRAN_FUNCTION(UN,LN)      CFC_(UN,LN)
+
+#ifndef COMMON_BLOCK
+#ifndef CONVEXFortran
+#ifndef CLIPPERFortran
+#if     !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran))
+#define COMMON_BLOCK(UN,LN)          CFC_(UN,LN)
+#else
+#define COMMON_BLOCK(UN,LN)          _(_C,LN)
+#endif  /* AbsoftUNIXFortran or AbsoftProFortran */
+#else
+#define COMMON_BLOCK(UN,LN)          _(LN,__)
+#endif  /* CLIPPERFortran */
+#else
+#define COMMON_BLOCK(UN,LN)          _3(_,LN,_)
+#endif  /* CONVEXFortran */
+#endif  /* COMMON_BLOCK */
+
+#ifndef DOUBLE_PRECISION
+#if defined(CRAYFortran) && !defined(_CRAYT3E)
+#define DOUBLE_PRECISION long double
+#else
+#define DOUBLE_PRECISION double
+#endif
+#endif
+
+#ifndef FORTRAN_REAL
+#if defined(CRAYFortran) &&  defined(_CRAYT3E)
+#define FORTRAN_REAL double
+#else
+#define FORTRAN_REAL float
+#endif
+#endif
+
+#ifdef CRAYFortran
+#ifdef _CRAY
+#include 
+#else
+#include "fortran.h"  /* i.e. if crosscompiling assume user has file. */
+#endif
+#define FLOATVVVVVVV_cfPP (FORTRAN_REAL *)   /* Used for C calls FORTRAN.     */
+/* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/
+#define VOIDP  (void *)  /* When FORTRAN calls C, we don't know if C routine 
+                            arg.'s have been declared float *, or double *.   */
+#else
+#define FLOATVVVVVVV_cfPP
+#define VOIDP
+#endif
+
+#ifdef vmsFortran
+#if    defined(vms) || defined(__vms)
+#include 
+#else
+#include "descrip.h"  /* i.e. if crosscompiling assume user has file. */
+#endif
+#endif
+
+#ifdef sunFortran
+#if defined(sun) || defined(__sun)
+#include      /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT.  */
+#else
+#include "math.h"     /* i.e. if crosscompiling assume user has file. */
+#endif
+/* At least starting with the default C compiler SC3.0.1 of SunOS 5.3,
+ * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in
+ * , since sun C no longer promotes C float return values to doubles.
+ * Therefore, only use them if defined.
+ * Even if gcc is being used, assume that it exhibits the Sun C compiler
+ * behavior in order to be able to use *.o from the Sun C compiler.
+ * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc.
+ */
+#endif
+
+#ifndef apolloFortran
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) extern DEFINITION NAME
+#define CF_NULL_PROTO
+#else                                         /* HP doesn't understand #elif. */
+/* Without ANSI prototyping, Apollo promotes float functions to double.    */
+/* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
+#define CF_NULL_PROTO ...
+#ifndef __CF__APOLLO67
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME __attribute((__section(NAME)))
+#else
+#define COMMON_BLOCK_DEF(DEFINITION, NAME) \
+ DEFINITION NAME #attribute[section(NAME)]
+#endif
+#endif
+
+#ifdef __cplusplus
+#undef  CF_NULL_PROTO
+#define CF_NULL_PROTO  ...
+#endif
+
+
+#ifndef USE_NEW_DELETE
+#ifdef __cplusplus
+#define USE_NEW_DELETE 1
+#else
+#define USE_NEW_DELETE 0
+#endif
+#endif
+#if USE_NEW_DELETE
+#define _cf_malloc(N) new char[N]
+#define _cf_free(P)   delete[] P
+#else
+#define _cf_malloc(N) (char *)malloc(N)
+#define _cf_free(P)   free(P)
+#endif
+
+#ifdef mipsFortran
+#define CF_DECLARE_GETARG         int f77argc; char **f77argv
+#define CF_SET_GETARG(ARGC,ARGV)  f77argc = ARGC; f77argv = ARGV
+#else
+#define CF_DECLARE_GETARG
+#define CF_SET_GETARG(ARGC,ARGV)
+#endif
+
+#ifdef OLD_VAXC                          /* Allow %CC-I-PARAMNOTUSED.         */
+#pragma standard                         
+#endif
+
+#define AcfCOMMA ,
+#define AcfCOLON ;
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES USED WITHIN CFORTRAN.H                          */
+
+#define _cfMIN(A,B) (As) {                           /* Need this to handle NULL string.*/
+  while (e>s && *--e==t);            /* Don't follow t's past beginning. */
+  e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
+} return s; }
+
+/* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally 
+points to the terminating '\0' of s, but may actually point to anywhere in s.
+s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
+If es) {                      /* Watch out for neg. length string.*/
+  while (e>s && *--e==t);            /* Don't follow t's past beginning. */
+  e[*e==t?0:1] = '\0';               /* Handle s[0]=t correctly.       */
+} return s; }
+
+/* Note the following assumes that any element which has t's to be chopped off,
+does indeed fill the entire element. */
+#ifndef __CF__KnR
+static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
+#else
+static char *vkill_trailing(      cstr,     elem_len,     sizeofcstr,      t)
+                            char* cstr; int elem_len; int sizeofcstr; char t;
+#endif
+{ int i;
+for (i=0; i= 4.3 gives message:
+       zow35> cc -c -DDECFortran cfortest.c
+       cfe: Fatal: Out of memory: cfortest.c
+       zow35>
+   Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine
+   if using -Aa, otherwise we have a problem.
+ */
+#ifndef MAX_PREPRO_ARGS
+#if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR)))
+#define MAX_PREPRO_ARGS 31
+#else
+#define MAX_PREPRO_ARGS 99
+#endif
+#endif
+
+#if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+/* In addition to explicit Absoft stuff, only Absoft requires:
+   - DEFAULT coming from _cfSTR.
+     DEFAULT could have been called e.g. INT, but keep it for clarity.
+   - M term in CFARGT14 and CFARGT14FS.
+ */
+#define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0)
+#define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0)
+#define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0)
+#define DEFAULT_cfABSOFT1
+#define LOGICAL_cfABSOFT1
+#define  STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING
+#define DEFAULT_cfABSOFT2
+#define LOGICAL_cfABSOFT2
+#define  STRING_cfABSOFT2 ,unsigned D0
+#define DEFAULT_cfABSOFT3
+#define LOGICAL_cfABSOFT3
+#define  STRING_cfABSOFT3 ,D0
+#else
+#define ABSOFT_cf1(T0)
+#define ABSOFT_cf2(T0)
+#define ABSOFT_cf3(T0)
+#endif
+
+/* _Z introduced to cicumvent IBM and HP silly preprocessor warning.
+   e.g. "Macro CFARGT14 invoked with a null argument."
+ */
+#define _Z
+
+#define  CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)                \
+ S(T1,1)   S(T2,2)   S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)       \
+ S(T8,8)   S(T9,9)   S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)
+#define  CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ S(T1,1)   S(T2,2)   S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)       \
+ S(T8,8)   S(T9,9)   S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)      \
+ S(TF,15)  S(TG,16)  S(TH,17)   S(TI,18)   S(TJ,19)   S(TK,20)   S(TL,21)      \
+ S(TM,22)  S(TN,23)  S(TO,24)   S(TP,25)   S(TQ,26)   S(TR,27)
+
+#define  CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)           \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)     \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)    \
+ M       CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define  CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1)  \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1)             \
+ M       CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#if !(defined(PowerStationFortran)||defined(hpuxFortran800))
+/*  Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields:
+      SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c
+      "c.c", line 406: warning: argument mismatch
+    Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok.
+    Behavior is most clearly seen in example:
+      #define A 1 , 2
+      #define  C(X,Y,Z) x=X. y=Y. z=Z.
+      #define  D(X,Y,Z) C(X,Y,Z)
+      D(x,A,z)
+    Output from preprocessor is: x = x . y = 1 . z = 2 .
+ #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+       CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+*/
+#define  CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)             \
+ F(T1,1,0) F(T2,2,1) F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)     \
+ F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)    \
+ M       CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define  CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1)  \
+ F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1)             \
+ M       CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+#define  CFARGT20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0)  F(T2,2,1)  F(T3,3,1)  F(T4,4,1)  F(T5,5,1)  F(T6,6,1)  F(T7,7,1)   \
+ F(T8,8,1)  F(T9,9,1)  F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1)  \
+ F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1)             \
+ S(T1,1)    S(T2,2)    S(T3,3)    S(T4,4)    S(T5,5)    S(T6,6)    S(T7,7)     \
+ S(T8,8)    S(T9,9)    S(TA,10)   S(TB,11)   S(TC,12)   S(TD,13)   S(TE,14)    \
+ S(TF,15)   S(TG,16)   S(TH,17)   S(TI,18)   S(TJ,19)   S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0)  F(T2,A2,2,1)  F(T3,A3,3,1) F(T4,A4,4,1)  F(T5,A5,5,1)  F(T6,A6,6,1)  \
+ F(T7,A7,7,1)  F(T8,A8,8,1)  F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1)      S(T2,2)       S(T3,3)       S(T4,4)       \
+ S(T5,5)       S(T6,6)       S(T7,7)      S(T8,8)       S(T9,9)       S(TA,10)      \
+ S(TB,11)      S(TC,12)      S(TD,13)     S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0)  F(T2,A2,2,1)  F(T3,A3,3,1)  F(T4,A4,4,1)  F(T5,A5,5,1)  F(T6,A6,6,1)  \
+ F(T7,A7,7,1)  F(T8,A8,8,1)  F(T9,A9,9,1)  F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
+ F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
+ F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1)       S(T2,2)       S(T3,3)       S(T4,4)       \
+ S(T5,5)       S(T6,6)       S(T7,7)       S(T8,8)       S(T9,9)       S(TA,10)      \
+ S(TB,11)      S(TC,12)      S(TD,13)      S(TE,14)      S(TF,15)      S(TG,16)      \
+ S(TH,17)      S(TI,18)      S(TJ,19)      S(TK,20)
+#endif
+#else
+#define  CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)             \
+ F(T1,1,0) S(T1,1) F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1) S(T5,5) F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14)
+#define  CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+ F(T1,1,0)  S(T1,1)  F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1)  S(T5,5)  F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1)  S(T9,9)  F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)  \
+ F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24)  \
+ F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27)
+
+#define  CFARGT20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+ F(T1,1,0)  S(T1,1)  F(T2,2,1)  S(T2,2)  F(T3,3,1)  S(T3,3)  F(T4,4,1)  S(T4,4)  \
+ F(T5,5,1)  S(T5,5)  F(T6,6,1)  S(T6,6)  F(T7,7,1)  S(T7,7)  F(T8,8,1)  S(T8,8)  \
+ F(T9,9,1)  S(T9,9)  F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
+ F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
+ F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)
+#define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
+ F(T1,A1,1,0)  S(T1,1)  F(T2,A2,2,1)  S(T2,2)  F(T3,A3,3,1)  S(T3,3)           \
+ F(T4,A4,4,1)  S(T4,4)  F(T5,A5,5,1)  S(T5,5)  F(T6,A6,6,1)  S(T6,6)           \
+ F(T7,A7,7,1)  S(T7,7)  F(T8,A8,8,1)  S(T8,8)  F(T9,A9,9,1)  S(T9,9)           \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12)          \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14)
+#if MAX_PREPRO_ARGS>31
+#define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+ F(T1,A1,1,0)  S(T1,1)  F(T2,A2,2,1)  S(T2,2)  F(T3,A3,3,1)  S(T3,3)           \
+ F(T4,A4,4,1)  S(T4,4)  F(T5,A5,5,1)  S(T5,5)  F(T6,A6,6,1)  S(T6,6)           \
+ F(T7,A7,7,1)  S(T7,7)  F(T8,A8,8,1)  S(T8,8)  F(T9,A9,9,1)  S(T9,9)           \
+ F(TA,AA,10,1) S(TA,10) F(TB,AB,11,1) S(TB,11) F(TC,AC,12,1) S(TC,12)          \
+ F(TD,AD,13,1) S(TD,13) F(TE,AE,14,1) S(TE,14) F(TF,AF,15,1) S(TF,15)          \
+ F(TG,AG,16,1) S(TG,16) F(TH,AH,17,1) S(TH,17) F(TI,AI,18,1) S(TI,18)          \
+ F(TJ,AJ,19,1) S(TJ,19) F(TK,AK,20,1) S(TK,20)                
+#endif
+#endif
+
+
+#define PROTOCCALLSFSUB1( UN,LN,T1) \
+        PROTOCCALLSFSUB14(UN,LN,T1,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB2( UN,LN,T1,T2) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB3( UN,LN,T1,T2,T3) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB4( UN,LN,T1,T2,T3,T4) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define PROTOCCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define PROTOCCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+
+
+#ifndef FCALLSC_QUALIFIER
+#ifdef VISUAL_CPLUSPLUS
+#define FCALLSC_QUALIFIER __stdcall
+#else
+#define FCALLSC_QUALIFIER
+#endif
+#endif
+
+#ifdef __cplusplus
+#define CFextern extern "C"
+#else
+#define CFextern extern
+#endif
+
+
+#ifdef CFSUBASFUN
+#define PROTOCCALLSFSUB0(UN,LN) \
+   PROTOCCALLSFFUN0( VOID,UN,LN)
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+   PROTOCCALLSFFUN14(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+   PROTOCCALLSFFUN20(VOID,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#else
+/* Note: Prevent compiler warnings, null #define PROTOCCALLSFSUB14/20 after 
+   #include-ing cfortran.h if calling the FORTRAN wrapper within the same 
+   source code where the wrapper is created. */
+#define PROTOCCALLSFSUB0(UN,LN)     CFextern void FCALLSC_QUALIFIER CFC_(UN,LN)();
+#ifndef __CF__KnR
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+ CFextern void FCALLSC_QUALIFIER CFC_(UN,LN)( CFARGT14(NCF,KCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) );
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)\
+ CFextern void FCALLSC_QUALIFIER CFC_(UN,LN)( CFARGT20(NCF,KCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) );
+#else
+#define PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)     \
+         PROTOCCALLSFSUB0(UN,LN)
+#define PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+         PROTOCCALLSFSUB0(UN,LN)
+#endif
+#endif
+
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+
+#define CCALLSFSUB1( UN,LN,T1,                        A1)         \
+        CCALLSFSUB5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFSUB2( UN,LN,T1,T2,                     A1,A2)      \
+        CCALLSFSUB5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFSUB3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
+        CCALLSFSUB5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFSUB4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
+        CCALLSFSUB5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFSUB5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFSUB6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFSUB7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFSUB8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFSUB9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+        CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFSUB10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFSUB11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFSUB12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFSUB13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+        CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#ifdef __cplusplus
+#define CPPPROTOCLSFSUB0( UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#else
+#define CPPPROTOCLSFSUB0(UN,LN) \
+        PROTOCCALLSFSUB0(UN,LN)
+#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)     \
+        PROTOCCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+        PROTOCCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#endif
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB0(UN,LN) CCALLSFFUN0(UN,LN)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)
+#else
+/* do{...}while(0) allows if(a==b) FORT(); else BORT(); */
+#define CCALLSFSUB0( UN,LN) do{CPPPROTOCLSFSUB0(UN,LN) CFC_(UN,LN)();}while(0)
+#define CCALLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+do{VVCF(T1,A1,B1) VVCF(T2,A2,B2) VVCF(T3,A3,B3) VVCF(T4,A4,B4) VVCF(T5,A5,B5)  \
+   VVCF(T6,A6,B6) VVCF(T7,A7,B7) VVCF(T8,A8,B8) VVCF(T9,A9,B9) VVCF(TA,AA,B10) \
+   VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14)             \
+   CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)          \
+   ACF(LN,T1,A1,1)  ACF(LN,T2,A2,2)  ACF(LN,T3,A3,3)                           \
+   ACF(LN,T4,A4,4)  ACF(LN,T5,A5,5)  ACF(LN,T6,A6,6)  ACF(LN,T7,A7,7)          \
+   ACF(LN,T8,A8,8)  ACF(LN,T9,A9,9)  ACF(LN,TA,AA,10) ACF(LN,TB,AB,11)         \
+   ACF(LN,TC,AC,12) ACF(LN,TD,AD,13) ACF(LN,TE,AE,14)                          \
+   CFC_(UN,LN)( CFARGTA14(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) );\
+   WCF(T1,A1,1)  WCF(T2,A2,2)  WCF(T3,A3,3)  WCF(T4,A4,4)  WCF(T5,A5,5)        \
+   WCF(T6,A6,6)  WCF(T7,A7,7)  WCF(T8,A8,8)  WCF(T9,A9,9)  WCF(TA,AA,10)       \
+   WCF(TB,AB,11) WCF(TC,AC,12) WCF(TD,AD,13) WCF(TE,AE,14)      }while(0)
+#endif
+
+
+#if MAX_PREPRO_ARGS>31
+#define CCALLSFSUB15(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,0,0,0,0,0)
+#define CCALLSFSUB16(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,0,0,0,0)
+#define CCALLSFSUB17(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,0,0,0)
+#define CCALLSFSUB18(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,0,0)
+#define CCALLSFSUB19(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ)\
+        CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,0)
+
+#ifdef CFSUBASFUN
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+        CCALLSFFUN20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK)
+#else
+#define CCALLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH, \
+        TI,TJ,TK, A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
+do{VVCF(T1,A1,B1)  VVCF(T2,A2,B2)  VVCF(T3,A3,B3)  VVCF(T4,A4,B4)  VVCF(T5,A5,B5)   \
+   VVCF(T6,A6,B6)  VVCF(T7,A7,B7)  VVCF(T8,A8,B8)  VVCF(T9,A9,B9)  VVCF(TA,AA,B10)  \
+   VVCF(TB,AB,B11) VVCF(TC,AC,B12) VVCF(TD,AD,B13) VVCF(TE,AE,B14) VVCF(TF,AF,B15)  \
+   VVCF(TG,AG,B16) VVCF(TH,AH,B17) VVCF(TI,AI,B18) VVCF(TJ,AJ,B19) VVCF(TK,AK,B20)  \
+   CPPPROTOCLSFSUB20(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)  \
+   ACF(LN,T1,A1,1)  ACF(LN,T2,A2,2)  ACF(LN,T3,A3,3)  ACF(LN,T4,A4,4)          \
+   ACF(LN,T5,A5,5)  ACF(LN,T6,A6,6)  ACF(LN,T7,A7,7)  ACF(LN,T8,A8,8)          \
+   ACF(LN,T9,A9,9)  ACF(LN,TA,AA,10) ACF(LN,TB,AB,11) ACF(LN,TC,AC,12)         \
+   ACF(LN,TD,AD,13) ACF(LN,TE,AE,14) ACF(LN,TF,AF,15) ACF(LN,TG,AG,16)         \
+   ACF(LN,TH,AH,17) ACF(LN,TI,AI,18) ACF(LN,TJ,AJ,19) ACF(LN,TK,AK,20)         \
+   CFC_(UN,LN)( CFARGTA20(AACF,JCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) ); \
+ WCF(T1,A1,1)  WCF(T2,A2,2)  WCF(T3,A3,3)  WCF(T4,A4,4)  WCF(T5,A5,5)  WCF(T6,A6,6)  \
+ WCF(T7,A7,7)  WCF(T8,A8,8)  WCF(T9,A9,9)  WCF(TA,AA,10) WCF(TB,AB,11) WCF(TC,AC,12) \
+ WCF(TD,AD,13) WCF(TE,AE,14) WCF(TF,AF,15) WCF(TG,AG,16) WCF(TH,AH,17) WCF(TI,AI,18) \
+ WCF(TJ,AJ,19) WCF(TK,AK,20) }while(0)
+#endif
+#endif         /* MAX_PREPRO_ARGS */
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR C TO CALL FORTRAN FUNCTIONS                 */
+
+/*N.B. PROTOCCALLSFFUNn(..) generates code, whether or not the FORTRAN
+  function is called. Therefore, especially for creator's of C header files
+  for large FORTRAN libraries which include many functions, to reduce
+  compile time and object code size, it may be desirable to create
+  preprocessor directives to allow users to create code for only those
+  functions which they use.                                                */
+
+/* The following defines the maximum length string that a function can return.
+   Of course it may be undefine-d and re-define-d before individual
+   PROTOCCALLSFFUNn(..) as required. It would also be nice to have this derived
+   from the individual machines' limits.                                      */
+#define MAX_LEN_FORTRAN_FUNCTION_STRING 0x4FE
+
+/* The following defines a character used by CFORTRAN.H to flag the end of a
+   string coming out of a FORTRAN routine.                                 */
+#define CFORTRAN_NON_CHAR 0x7F
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define _SEP_(TN,C,cfCOMMA)     _(__SEP_,C)(TN,cfCOMMA)
+#define __SEP_0(TN,cfCOMMA)  
+#define __SEP_1(TN,cfCOMMA)     _Icf(2,SEP,TN,cfCOMMA,0)
+#define        INT_cfSEP(T,B) _(A,B)
+#define       INTV_cfSEP(T,B) INT_cfSEP(T,B)
+#define      INTVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define     INTVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define    INTVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   INTVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define  INTVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define INTVVVVVVV_cfSEP(T,B) INT_cfSEP(T,B)
+#define       PINT_cfSEP(T,B) INT_cfSEP(T,B)
+#define      PVOID_cfSEP(T,B) INT_cfSEP(T,B)
+#define    ROUTINE_cfSEP(T,B) INT_cfSEP(T,B)
+#define     SIMPLE_cfSEP(T,B) INT_cfSEP(T,B)
+#define       VOID_cfSEP(T,B) INT_cfSEP(T,B)    /* For FORTRAN calls C subr.s.*/
+#define     STRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define    STRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define    PSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PSTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PNSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PPSTRING_cfSEP(T,B) INT_cfSEP(T,B)
+#define    ZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+#define   PZTRINGV_cfSEP(T,B) INT_cfSEP(T,B)
+                         
+#if defined(SIGNED_BYTE) || !defined(UNSIGNED_BYTE)
+#ifdef OLD_VAXC
+#define INTEGER_BYTE               char    /* Old VAXC barfs on 'signed char' */
+#else
+#define INTEGER_BYTE        signed char    /* default */
+#endif
+#else
+#define INTEGER_BYTE        unsigned char
+#endif
+#define    BYTEVVVVVVV_cfTYPE INTEGER_BYTE
+#define  DOUBLEVVVVVVV_cfTYPE DOUBLE_PRECISION 
+#define   FLOATVVVVVVV_cfTYPE FORTRAN_REAL
+#define     INTVVVVVVV_cfTYPE int
+#define LOGICALVVVVVVV_cfTYPE int
+#define    LONGVVVVVVV_cfTYPE long
+#define   SHORTVVVVVVV_cfTYPE short
+#define          PBYTE_cfTYPE INTEGER_BYTE
+#define        PDOUBLE_cfTYPE DOUBLE_PRECISION 
+#define         PFLOAT_cfTYPE FORTRAN_REAL
+#define           PINT_cfTYPE int
+#define       PLOGICAL_cfTYPE int
+#define          PLONG_cfTYPE long
+#define         PSHORT_cfTYPE short
+
+#define CFARGS0(A,T,V,W,X,Y,Z) _3(T,_cf,A)
+#define CFARGS1(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V)
+#define CFARGS2(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W)
+#define CFARGS3(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X)
+#define CFARGS4(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y)
+#define CFARGS5(A,T,V,W,X,Y,Z) _3(T,_cf,A)(V,W,X,Y,Z)
+
+#define  _Icf(N,T,I,X,Y)                 _(I,_cfINT)(N,T,I,X,Y,0)
+#define _Icf4(N,T,I,X,Y,Z)               _(I,_cfINT)(N,T,I,X,Y,Z)
+#define           BYTE_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define         DOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INT,B,X,Y,Z,0)
+#define          FLOAT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define            INT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define        LOGICAL_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define           LONG_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          SHORT_cfINT(N,A,B,X,Y,Z)        DOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          PBYTE_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define        PDOUBLE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,PINT,B,X,Y,Z,0)
+#define         PFLOAT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define           PINT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define       PLOGICAL_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          PLONG_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define         PSHORT_cfINT(N,A,B,X,Y,Z)       PDOUBLE_cfINT(N,A,B,X,Y,Z)
+#define          BYTEV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define         BYTEVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define        BYTEVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define       BYTEVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define      BYTEVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     BYTEVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    BYTEVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define        DOUBLEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTV,B,X,Y,Z,0)
+#define       DOUBLEVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVV,B,X,Y,Z,0)
+#define      DOUBLEVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVV,B,X,Y,Z,0)
+#define     DOUBLEVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVV,B,X,Y,Z,0)
+#define    DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVV,B,X,Y,Z,0)
+#define   DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVV,B,X,Y,Z,0)
+#define  DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,INTVVVVVVV,B,X,Y,Z,0)
+#define         FLOATV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define        FLOATVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define       FLOATVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define      FLOATVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define     FLOATVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    FLOATVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define   FLOATVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define           INTV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define          INTVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define         INTVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define        INTVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define       INTVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define      INTVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     INTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define       LOGICALV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define      LOGICALVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define     LOGICALVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define    LOGICALVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define   LOGICALVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define  LOGICALVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define LOGICALVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define          LONGV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define         LONGVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define        LONGVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define       LONGVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define      LONGVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define     LONGVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    LONGVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define         SHORTV_cfINT(N,A,B,X,Y,Z)       DOUBLEV_cfINT(N,A,B,X,Y,Z)
+#define        SHORTVV_cfINT(N,A,B,X,Y,Z)      DOUBLEVV_cfINT(N,A,B,X,Y,Z)
+#define       SHORTVVV_cfINT(N,A,B,X,Y,Z)     DOUBLEVVV_cfINT(N,A,B,X,Y,Z)
+#define      SHORTVVVV_cfINT(N,A,B,X,Y,Z)    DOUBLEVVVV_cfINT(N,A,B,X,Y,Z)
+#define     SHORTVVVVV_cfINT(N,A,B,X,Y,Z)   DOUBLEVVVVV_cfINT(N,A,B,X,Y,Z)
+#define    SHORTVVVVVV_cfINT(N,A,B,X,Y,Z)  DOUBLEVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define   SHORTVVVVVVV_cfINT(N,A,B,X,Y,Z) DOUBLEVVVVVVV_cfINT(N,A,B,X,Y,Z)
+#define          PVOID_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,B,B,X,Y,Z,0)
+#define        ROUTINE_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+/*CRAY coughs on the first,
+  i.e. the usual trouble of not being able to
+  define macros to macros with arguments. 
+  New ultrix is worse, it coughs on all such uses.
+ */
+/*#define       SIMPLE_cfINT                    PVOID_cfINT*/
+#define         SIMPLE_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define           VOID_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define         STRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        STRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        PSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PSTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PNSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PPSTRING_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define        ZTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define       PZTRINGV_cfINT(N,A,B,X,Y,Z)         PVOID_cfINT(N,A,B,X,Y,Z)
+#define           CF_0_cfINT(N,A,B,X,Y,Z)
+                         
+
+#define   UCF(TN,I,C)  _SEP_(TN,C,cfCOMMA) _Icf(2,U,TN,_(A,I),0)
+#define  UUCF(TN,I,C)  _SEP_(TN,C,cfCOMMA) _SEP_(TN,1,I) 
+#define UUUCF(TN,I,C)  _SEP_(TN,C,cfCOLON) _Icf(2,U,TN,_(A,I),0)
+#define        INT_cfU(T,A) _(T,VVVVVVV_cfTYPE)   A
+#define       INTV_cfU(T,A) _(T,VVVVVV_cfTYPE)  * A
+#define      INTVV_cfU(T,A) _(T,VVVVV_cfTYPE)   * A
+#define     INTVVV_cfU(T,A) _(T,VVVV_cfTYPE)    * A
+#define    INTVVVV_cfU(T,A) _(T,VVV_cfTYPE)     * A
+#define   INTVVVVV_cfU(T,A) _(T,VV_cfTYPE)      * A
+#define  INTVVVVVV_cfU(T,A) _(T,V_cfTYPE)       * A
+#define INTVVVVVVV_cfU(T,A) _(T,_cfTYPE)        * A
+#define       PINT_cfU(T,A) _(T,_cfTYPE)        * A
+#define      PVOID_cfU(T,A) void  *A 
+#define    ROUTINE_cfU(T,A) void (*A)(CF_NULL_PROTO) 
+#define       VOID_cfU(T,A) void   A    /* Needed for C calls FORTRAN sub.s.  */
+#define     STRING_cfU(T,A) char  *A    /*            via VOID and wrapper.   */
+#define    STRINGV_cfU(T,A) char  *A
+#define    PSTRING_cfU(T,A) char  *A
+#define   PSTRINGV_cfU(T,A) char  *A
+#define    ZTRINGV_cfU(T,A) char  *A
+#define   PZTRINGV_cfU(T,A) char  *A
+
+/* VOID breaks U into U and UU. */
+#define       INT_cfUU(T,A) _(T,VVVVVVV_cfTYPE) A
+#define      VOID_cfUU(T,A)             /* Needed for FORTRAN calls C sub.s.  */
+#define    STRING_cfUU(T,A) char *A 
+
+
+#define      BYTE_cfPU(A)   CFextern INTEGER_BYTE      FCALLSC_QUALIFIER A
+#define    DOUBLE_cfPU(A)   CFextern DOUBLE_PRECISION  FCALLSC_QUALIFIER A
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define     FLOAT_cfPU(A)   CFextern FORTRAN_REAL      FCALLSC_QUALIFIER A
+#else                                                      
+#define     FLOAT_cfPU(A)   CFextern FLOATFUNCTIONTYPE FCALLSC_QUALIFIER A
+#endif                                                     
+#define       INT_cfPU(A)   CFextern int   FCALLSC_QUALIFIER   A
+#define   LOGICAL_cfPU(A)   CFextern int   FCALLSC_QUALIFIER   A
+#define      LONG_cfPU(A)   CFextern long  FCALLSC_QUALIFIER   A
+#define     SHORT_cfPU(A)   CFextern short FCALLSC_QUALIFIER   A
+#define    STRING_cfPU(A)   CFextern void  FCALLSC_QUALIFIER   A
+#define      VOID_cfPU(A)   CFextern void  FCALLSC_QUALIFIER   A
+
+#define    BYTE_cfE INTEGER_BYTE     A0;
+#define  DOUBLE_cfE DOUBLE_PRECISION A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfE FORTRAN_REAL  A0;
+#else
+#define   FLOAT_cfE FORTRAN_REAL AA0;   FLOATFUNCTIONTYPE A0;
+#endif
+#define     INT_cfE int    A0;
+#define LOGICAL_cfE int    A0;
+#define    LONG_cfE long   A0;
+#define   SHORT_cfE short  A0;
+#define    VOID_cfE
+#ifdef vmsFortran
+#define  STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];        \
+                       static fstring A0 =                                     \
+             {MAX_LEN_FORTRAN_FUNCTION_STRING,DSC$K_DTYPE_T,DSC$K_CLASS_S,AA0};\
+               memset(AA0, CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+                                    *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#else
+#ifdef CRAYFortran
+#define  STRING_cfE static char AA0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];        \
+                   static _fcd A0; *(AA0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';\
+                memset(AA0,CFORTRAN_NON_CHAR, MAX_LEN_FORTRAN_FUNCTION_STRING);\
+                            A0 = _cptofcd(AA0,MAX_LEN_FORTRAN_FUNCTION_STRING);
+#else
+/* 'cc: SC3.0.1 13 Jul 1994' barfs on char A0[0x4FE+1]; 
+ * char A0[0x4FE +1]; char A0[1+0x4FE]; are both OK.     */
+#define STRING_cfE static char A0[1+MAX_LEN_FORTRAN_FUNCTION_STRING];          \
+                       memset(A0, CFORTRAN_NON_CHAR,                           \
+                              MAX_LEN_FORTRAN_FUNCTION_STRING);                \
+                       *(A0+MAX_LEN_FORTRAN_FUNCTION_STRING)='\0';
+#endif
+#endif
+/* ESTRING must use static char. array which is guaranteed to exist after
+   function returns.                                                     */
+
+/* N.B.i) The diff. for 0 (Zero) and >=1 arguments.
+       ii)That the following create an unmatched bracket, i.e. '(', which
+          must of course be matched in the call.
+       iii)Commas must be handled very carefully                         */
+#define    INT_cfGZ(T,UN,LN) A0=CFC_(UN,LN)(
+#define   VOID_cfGZ(T,UN,LN)    CFC_(UN,LN)(
+#ifdef vmsFortran
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)(&A0
+#else
+#if defined(CRAYFortran) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)( A0
+#else
+#define STRING_cfGZ(T,UN,LN)    CFC_(UN,LN)( A0,MAX_LEN_FORTRAN_FUNCTION_STRING
+#endif
+#endif
+
+#define     INT_cfG(T,UN,LN)    INT_cfGZ(T,UN,LN)
+#define    VOID_cfG(T,UN,LN)   VOID_cfGZ(T,UN,LN)
+#define  STRING_cfG(T,UN,LN) STRING_cfGZ(T,UN,LN), /*, is only diff. from _cfG*/
+
+#define    BYTEVVVVVVV_cfPP
+#define     INTVVVVVVV_cfPP     /* These complement FLOATVVVVVVV_cfPP. */
+#define  DOUBLEVVVVVVV_cfPP
+#define LOGICALVVVVVVV_cfPP
+#define    LONGVVVVVVV_cfPP
+#define   SHORTVVVVVVV_cfPP
+#define          PBYTE_cfPP
+#define           PINT_cfPP
+#define        PDOUBLE_cfPP
+#define       PLOGICAL_cfPP
+#define          PLONG_cfPP
+#define         PSHORT_cfPP
+#define         PFLOAT_cfPP FLOATVVVVVVV_cfPP
+
+#define BCF(TN,AN,C)        _SEP_(TN,C,cfCOMMA) _Icf(2,B,TN,AN,0)
+#define        INT_cfB(T,A) (_(T,VVVVVVV_cfTYPE)) A
+#define       INTV_cfB(T,A)            A
+#define      INTVV_cfB(T,A)           (A)[0]
+#define     INTVVV_cfB(T,A)           (A)[0][0]
+#define    INTVVVV_cfB(T,A)           (A)[0][0][0]
+#define   INTVVVVV_cfB(T,A)           (A)[0][0][0][0]
+#define  INTVVVVVV_cfB(T,A)           (A)[0][0][0][0][0]
+#define INTVVVVVVV_cfB(T,A)           (A)[0][0][0][0][0][0]
+#define       PINT_cfB(T,A) _(T,_cfPP)&A
+#define     STRING_cfB(T,A) (char *)   A
+#define    STRINGV_cfB(T,A) (char *)   A
+#define    PSTRING_cfB(T,A) (char *)   A
+#define   PSTRINGV_cfB(T,A) (char *)   A
+#define      PVOID_cfB(T,A) (void *)   A
+#define    ROUTINE_cfB(T,A) (cfCAST_FUNCTION)A
+#define    ZTRINGV_cfB(T,A) (char *)   A
+#define   PZTRINGV_cfB(T,A) (char *)   A
+                                                                
+#define SCF(TN,NAME,I,A)    _(TN,_cfSTR)(3,S,NAME,I,A,0,0)
+#define  DEFAULT_cfS(M,I,A)
+#define  LOGICAL_cfS(M,I,A)
+#define PLOGICAL_cfS(M,I,A)
+#define   STRING_cfS(M,I,A) ,sizeof(A)
+#define  STRINGV_cfS(M,I,A) ,( (unsigned)0xFFFF*firstindexlength(A) \
+                              +secondindexlength(A))
+#define  PSTRING_cfS(M,I,A) ,sizeof(A)
+#define PSTRINGV_cfS(M,I,A) STRINGV_cfS(M,I,A)
+#define  ZTRINGV_cfS(M,I,A)
+#define PZTRINGV_cfS(M,I,A)
+
+#define   HCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOMMA, H,_(C,I),0,0)
+#define  HHCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOMMA,HH,_(C,I),0,0)
+#define HHHCF(TN,I)         _(TN,_cfSTR)(3,H,cfCOLON, H,_(C,I),0,0)
+#define  H_CF_SPECIAL       unsigned
+#define HH_CF_SPECIAL
+#define  DEFAULT_cfH(M,I,A)
+#define  LOGICAL_cfH(S,U,B)
+#define PLOGICAL_cfH(S,U,B)
+#define   STRING_cfH(S,U,B) _(A,S) _(U,_CF_SPECIAL) B
+#define  STRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define  PSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PSTRINGV_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PNSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define PPSTRING_cfH(S,U,B) STRING_cfH(S,U,B)
+#define  ZTRINGV_cfH(S,U,B)
+#define PZTRINGV_cfH(S,U,B)
+
+/* Need VOID_cfSTR because Absoft forced function types go through _cfSTR. */
+/* No spaces inside expansion. They screws up macro catenation kludge.     */
+#define           VOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         DOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          FLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define            INT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        LOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICAL,A,B,C,D,E)
+#define           LONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          SHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         BYTEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        BYTEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       BYTEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      BYTEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     BYTEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    BYTEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        DOUBLEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       DOUBLEVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      DOUBLEVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     DOUBLEVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    DOUBLEVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   DOUBLEVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define  DOUBLEVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         FLOATV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        FLOATVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       FLOATVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      FLOATVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     FLOATVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    FLOATVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   FLOATVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           INTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          INTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         INTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        INTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       INTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      INTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     INTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      LOGICALVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     LOGICALVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    LOGICALVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   LOGICALVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define  LOGICALVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define LOGICALVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         LONGVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        LONGVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       LONGVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      LONGVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     LONGVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    LONGVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         SHORTV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        SHORTVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       SHORTVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define      SHORTVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define     SHORTVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define    SHORTVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define   SHORTVVVVVVV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define          PBYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        PDOUBLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         PFLOAT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define           PINT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define       PLOGICAL_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLOGICAL,A,B,C,D,E)
+#define          PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         PSHORT_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         STRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRING,A,B,C,D,E)
+#define        PSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRING,A,B,C,D,E)
+#define        STRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,STRINGV,A,B,C,D,E)
+#define       PSTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PSTRINGV,A,B,C,D,E)
+#define       PNSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PNSTRING,A,B,C,D,E)
+#define       PPSTRING_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PPSTRING,A,B,C,D,E)
+#define          PVOID_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        ROUTINE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define         SIMPLE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,DEFAULT,A,B,C,D,E)
+#define        ZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,ZTRINGV,A,B,C,D,E)
+#define       PZTRINGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PZTRINGV,A,B,C,D,E)
+#define           CF_0_cfSTR(N,T,A,B,C,D,E)
+
+/* See ACF table comments, which explain why CCF was split into two. */
+#define CCF(NAME,TN,I)     _(TN,_cfSTR)(5,C,NAME,I,_(A,I),_(B,I),_(C,I))
+#define  DEFAULT_cfC(M,I,A,B,C)
+#define  LOGICAL_cfC(M,I,A,B,C)  A=C2FLOGICAL( A);
+#define PLOGICAL_cfC(M,I,A,B,C) *A=C2FLOGICAL(*A);
+#ifdef vmsFortran
+#define   STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),B.f.dsc$a_pointer=A,         \
+        C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.f.dsc$w_length=B.clen:     \
+          (memset((A)+B.clen,' ',C-B.clen-1),A[B.f.dsc$w_length=C-1]='\0'));
+      /* PSTRING_cfC to beware of array A which does not contain any \0.      */
+#define  PSTRING_cfC(M,I,A,B,C) (B.dsc$a_pointer=A, C==sizeof(char*) ?         \
+             B.dsc$w_length=strlen(A):  (A[C-1]='\0',B.dsc$w_length=strlen(A), \
+       memset((A)+B.dsc$w_length,' ',C-B.dsc$w_length-1), B.dsc$w_length=C-1));
+#else
+#define   STRING_cfC(M,I,A,B,C) (B.clen=strlen(A),                             \
+                C==sizeof(char*)||C==(unsigned)(B.clen+1)?B.flen=B.clen:       \
+                        (memset((A)+B.clen,' ',C-B.clen-1),A[B.flen=C-1]='\0'));
+#define  PSTRING_cfC(M,I,A,B,C) (C==sizeof(char*)? B=strlen(A):                \
+                    (A[C-1]='\0',B=strlen(A),memset((A)+B,' ',C-B-1),B=C-1));
+#endif
+          /* For CRAYFortran for (P)STRINGV_cfC, B.fs is set, but irrelevant. */
+#define  STRINGV_cfC(M,I,A,B,C) \
+        AATRINGV_cfA(    A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define PSTRINGV_cfC(M,I,A,B,C) \
+       APATRINGV_cfA(    A,B,(C/0xFFFF)*(C%0xFFFF),C/0xFFFF,C%0xFFFF)
+#define  ZTRINGV_cfC(M,I,A,B,C) \
+        AATRINGV_cfA(    A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1),       \
+                              (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1   )
+#define PZTRINGV_cfC(M,I,A,B,C) \
+       APATRINGV_cfA(    A,B, (_3(M,_ELEMS_,I))*((_3(M,_ELEMLEN_,I))+1),       \
+                              (_3(M,_ELEMS_,I)), (_3(M,_ELEMLEN_,I))+1   )
+
+#define     BYTE_cfCCC(A,B) &A
+#define   DOUBLE_cfCCC(A,B) &A
+#if !defined(__CF__KnR)
+#define    FLOAT_cfCCC(A,B) &A
+                               /* Although the VAX doesn't, at least the      */
+#else                          /* HP and K&R mips promote float arg.'s of     */
+#define    FLOAT_cfCCC(A,B) &B /* unprototyped functions to double. Cannot    */
+#endif                         /* use A here to pass the argument to FORTRAN. */
+#define      INT_cfCCC(A,B) &A
+#define  LOGICAL_cfCCC(A,B) &A
+#define     LONG_cfCCC(A,B) &A
+#define    SHORT_cfCCC(A,B) &A
+#define    PBYTE_cfCCC(A,B)  A
+#define  PDOUBLE_cfCCC(A,B)  A
+#define   PFLOAT_cfCCC(A,B)  A
+#define     PINT_cfCCC(A,B)  A
+#define PLOGICAL_cfCCC(A,B)  B=A       /* B used to keep a common W table. */
+#define    PLONG_cfCCC(A,B)  A
+#define   PSHORT_cfCCC(A,B)  A
+
+#define CCCF(TN,I,M)           _SEP_(TN,M,cfCOMMA) _Icf(3,CC,TN,_(A,I),_(B,I))
+#define        INT_cfCC(T,A,B) _(T,_cfCCC)(A,B) 
+#define       INTV_cfCC(T,A,B)  A
+#define      INTVV_cfCC(T,A,B)  A
+#define     INTVVV_cfCC(T,A,B)  A
+#define    INTVVVV_cfCC(T,A,B)  A
+#define   INTVVVVV_cfCC(T,A,B)  A
+#define  INTVVVVVV_cfCC(T,A,B)  A
+#define INTVVVVVVV_cfCC(T,A,B)  A
+#define       PINT_cfCC(T,A,B) _(T,_cfCCC)(A,B) 
+#define      PVOID_cfCC(T,A,B)  A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfCC(T,A,B) &A
+#else
+#define    ROUTINE_cfCC(T,A,B)  A
+#endif
+#define     SIMPLE_cfCC(T,A,B)  A
+#ifdef vmsFortran
+#define     STRING_cfCC(T,A,B) &B.f
+#define    STRINGV_cfCC(T,A,B) &B
+#define    PSTRING_cfCC(T,A,B) &B
+#define   PSTRINGV_cfCC(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define     STRING_cfCC(T,A,B) _cptofcd(A,B.flen)
+#define    STRINGV_cfCC(T,A,B) _cptofcd(B.s,B.flen)
+#define    PSTRING_cfCC(T,A,B) _cptofcd(A,B)
+#define   PSTRINGV_cfCC(T,A,B) _cptofcd(A,B.flen)
+#else
+#define     STRING_cfCC(T,A,B)  A
+#define    STRINGV_cfCC(T,A,B)  B.fs
+#define    PSTRING_cfCC(T,A,B)  A
+#define   PSTRINGV_cfCC(T,A,B)  B.fs
+#endif
+#endif
+#define    ZTRINGV_cfCC(T,A,B)   STRINGV_cfCC(T,A,B)
+#define   PZTRINGV_cfCC(T,A,B)  PSTRINGV_cfCC(T,A,B)
+
+#define    BYTE_cfX  return A0;
+#define  DOUBLE_cfX  return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfX  return A0;
+#else
+#define   FLOAT_cfX  ASSIGNFLOAT(AA0,A0); return AA0;
+#endif
+#define     INT_cfX  return A0;
+#define LOGICAL_cfX  return F2CLOGICAL(A0);
+#define    LONG_cfX  return A0;
+#define   SHORT_cfX  return A0;
+#define    VOID_cfX  return   ;
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define  STRING_cfX  return kill_trailing(                                     \
+                                      kill_trailing(AA0,CFORTRAN_NON_CHAR),' ');
+#else
+#define  STRING_cfX  return kill_trailing(                                     \
+                                      kill_trailing( A0,CFORTRAN_NON_CHAR),' ');
+#endif
+
+#define CFFUN(NAME) _(__cf__,NAME)
+
+/* Note that we don't use LN here, but we keep it for consistency. */
+#define CCALLSFFUN0(UN,LN) CFFUN(UN)()
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define CCALLSFFUN1( UN,LN,T1,                        A1)         \
+        CCALLSFFUN5 (UN,LN,T1,CF_0,CF_0,CF_0,CF_0,A1,0,0,0,0)
+#define CCALLSFFUN2( UN,LN,T1,T2,                     A1,A2)      \
+        CCALLSFFUN5 (UN,LN,T1,T2,CF_0,CF_0,CF_0,A1,A2,0,0,0)
+#define CCALLSFFUN3( UN,LN,T1,T2,T3,                  A1,A2,A3)   \
+        CCALLSFFUN5 (UN,LN,T1,T2,T3,CF_0,CF_0,A1,A2,A3,0,0)
+#define CCALLSFFUN4( UN,LN,T1,T2,T3,T4,               A1,A2,A3,A4)\
+        CCALLSFFUN5 (UN,LN,T1,T2,T3,T4,CF_0,A1,A2,A3,A4,0)
+#define CCALLSFFUN5( UN,LN,T1,T2,T3,T4,T5,            A1,A2,A3,A4,A5)          \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,0,0,0,0,0)
+#define CCALLSFFUN6( UN,LN,T1,T2,T3,T4,T5,T6,         A1,A2,A3,A4,A5,A6)       \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,0,0,0,0)
+#define CCALLSFFUN7( UN,LN,T1,T2,T3,T4,T5,T6,T7,      A1,A2,A3,A4,A5,A6,A7)    \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,0,0,0)
+#define CCALLSFFUN8( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,   A1,A2,A3,A4,A5,A6,A7,A8) \
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,0,0)
+#define CCALLSFFUN9( UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,A1,A2,A3,A4,A5,A6,A7,A8,A9)\
+        CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,0)
+#define CCALLSFFUN10(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,0,0,0,0)
+#define CCALLSFFUN11(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,0,0,0)
+#define CCALLSFFUN12(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,0,0)
+#define CCALLSFFUN13(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD)\
+        CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,0)
+
+#define CCALLSFFUN14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE)\
+((CFFUN(UN)(  BCF(T1,A1,0) BCF(T2,A2,1) BCF(T3,A3,1) BCF(T4,A4,1) BCF(T5,A5,1) \
+              BCF(T6,A6,1) BCF(T7,A7,1) BCF(T8,A8,1) BCF(T9,A9,1) BCF(TA,AA,1) \
+              BCF(TB,AB,1) BCF(TC,AC,1) BCF(TD,AD,1) BCF(TE,AE,1)              \
+           SCF(T1,LN,1,A1)  SCF(T2,LN,2,A2)  SCF(T3,LN,3,A3)  SCF(T4,LN,4,A4)  \
+           SCF(T5,LN,5,A5)  SCF(T6,LN,6,A6)  SCF(T7,LN,7,A7)  SCF(T8,LN,8,A8)  \
+           SCF(T9,LN,9,A9)  SCF(TA,LN,10,AA) SCF(TB,LN,11,AB) SCF(TC,LN,12,AC) \
+           SCF(TD,LN,13,AD) SCF(TE,LN,14,AE))))
+
+/*  N.B. Create a separate function instead of using (call function, function
+value here) because in order to create the variables needed for the input
+arg.'s which may be const.'s one has to do the creation within {}, but these
+can never be placed within ()'s. Therefore one must create wrapper functions.
+gcc, on the other hand may be able to avoid the wrapper functions. */
+
+/* Prototypes are needed to correctly handle the value returned correctly. N.B.
+Can only have prototype arg.'s with difficulty, a la G... table since FORTRAN
+functions returning strings have extra arg.'s. Don't bother, since this only
+causes a compiler warning to come up when one uses FCALLSCFUNn and CCALLSFFUNn
+for the same function in the same source code. Something done by the experts in
+debugging only.*/    
+
+#define PROTOCCALLSFFUN0(F,UN,LN)                                              \
+_(F,_cfPU)( CFC_(UN,LN))(CF_NULL_PROTO);                                       \
+static _Icf(2,U,F,CFFUN(UN),0)() {_(F,_cfE) _Icf(3,GZ,F,UN,LN) ABSOFT_cf1(F));_(F,_cfX)}
+
+#define PROTOCCALLSFFUN1( T0,UN,LN,T1)                                         \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN2( T0,UN,LN,T1,T2)                                      \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN3( T0,UN,LN,T1,T2,T3)                                   \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define PROTOCCALLSFFUN4( T0,UN,LN,T1,T2,T3,T4)                                \
+        PROTOCCALLSFFUN5 (T0,UN,LN,T1,T2,T3,T4,CF_0)
+#define PROTOCCALLSFFUN5( T0,UN,LN,T1,T2,T3,T4,T5)                             \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN6( T0,UN,LN,T1,T2,T3,T4,T5,T6)                          \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN7( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7)                       \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN8( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)                    \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define PROTOCCALLSFFUN9( T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)                 \
+        PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define PROTOCCALLSFFUN10(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)              \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN11(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)           \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define PROTOCCALLSFFUN12(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)        \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define PROTOCCALLSFFUN13(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)     \
+        PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+/* HP/UX 9.01 cc requires the blank between '_Icf(3,G,T0,UN,LN) CCCF(T1,1,0)' */
+
+#ifndef __CF__KnR
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)(     \
+   CFARGT14FS(UCF,HCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )          \
+{       CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    _(T0,_cfE) \
+ CCF(LN,T1,1)  CCF(LN,T2,2)  CCF(LN,T3,3)  CCF(LN,T4,4)  CCF(LN,T5,5)          \
+ CCF(LN,T6,6)  CCF(LN,T7,7)  CCF(LN,T8,8)  CCF(LN,T9,9)  CCF(LN,TA,10)         \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14)    _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1)   WCF(T2,A2,2)   WCF(T3,A3,3)   WCF(T4,A4,4)  WCF(T5,A5,5)       \
+ WCF(T6,A6,6)   WCF(T7,A7,7)   WCF(T8,A8,8)   WCF(T9,A9,9)  WCF(TA,A10,10)     \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#else
+#define PROTOCCALLSFFUN14(T0,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  \
+ _(T0,_cfPU)(CFC_(UN,LN))(CF_NULL_PROTO); static _Icf(2,U,T0,CFFUN(UN),0)(     \
+   CFARGT14FS(UUCF,HHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )        \
+ CFARGT14FS(UUUCF,HHHCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) ;        \
+{       CFARGT14S(VCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    _(T0,_cfE) \
+ CCF(LN,T1,1)  CCF(LN,T2,2)  CCF(LN,T3,3)  CCF(LN,T4,4)  CCF(LN,T5,5)          \
+ CCF(LN,T6,6)  CCF(LN,T7,7)  CCF(LN,T8,8)  CCF(LN,T9,9)  CCF(LN,TA,10)         \
+ CCF(LN,TB,11) CCF(LN,TC,12) CCF(LN,TD,13) CCF(LN,TE,14)    _Icf(3,G,T0,UN,LN) \
+ CFARGT14(CCCF,JCF,ABSOFT_cf1(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+ WCF(T1,A1,1)   WCF(T2,A2,2)   WCF(T3,A3,3)   WCF(T4,A4,4)   WCF(T5,A5,5)      \
+ WCF(T6,A6,6)   WCF(T7,A7,7)   WCF(T8,A8,8)   WCF(T9,A9,9)   WCF(TA,A10,10)    \
+ WCF(TB,A11,11) WCF(TC,A12,12) WCF(TD,A13,13) WCF(TE,A14,14) _(T0,_cfX)}
+#endif
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR FORTRAN TO CALL C ROUTINES                  */
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define   DCF(TN,I)
+#define  DDCF(TN,I)
+#define DDDCF(TN,I)
+#else
+#define   DCF(TN,I)          HCF(TN,I)
+#define  DDCF(TN,I)         HHCF(TN,I)
+#define DDDCF(TN,I)        HHHCF(TN,I)
+#endif
+
+#define QCF(TN,I)       _(TN,_cfSTR)(1,Q,_(B,I), 0,0,0,0)
+#define  DEFAULT_cfQ(B)
+#define  LOGICAL_cfQ(B)
+#define PLOGICAL_cfQ(B)
+#define  STRINGV_cfQ(B) char *B; unsigned int _(B,N);
+#define   STRING_cfQ(B) char *B=NULL;
+#define  PSTRING_cfQ(B) char *B=NULL;
+#define PSTRINGV_cfQ(B) STRINGV_cfQ(B)
+#define PNSTRING_cfQ(B) char *B=NULL;
+#define PPSTRING_cfQ(B)
+
+#ifdef     __sgi   /* Else SGI gives warning 182 contrary to its C LRM A.17.7 */
+#define ROUTINE_orig    *(void**)& 
+#else
+#define ROUTINE_orig     (void *)  
+#endif
+
+#define ROUTINE_1     ROUTINE_orig   
+#define ROUTINE_2     ROUTINE_orig   
+#define ROUTINE_3     ROUTINE_orig   
+#define ROUTINE_4     ROUTINE_orig   
+#define ROUTINE_5     ROUTINE_orig   
+#define ROUTINE_6     ROUTINE_orig   
+#define ROUTINE_7     ROUTINE_orig   
+#define ROUTINE_8     ROUTINE_orig   
+#define ROUTINE_9     ROUTINE_orig   
+#define ROUTINE_10    ROUTINE_orig   
+#define ROUTINE_11    ROUTINE_orig   
+#define ROUTINE_12    ROUTINE_orig   
+#define ROUTINE_13    ROUTINE_orig   
+#define ROUTINE_14    ROUTINE_orig   
+#define ROUTINE_15    ROUTINE_orig   
+#define ROUTINE_16    ROUTINE_orig   
+#define ROUTINE_17    ROUTINE_orig   
+#define ROUTINE_18    ROUTINE_orig   
+#define ROUTINE_19    ROUTINE_orig   
+#define ROUTINE_20    ROUTINE_orig   
+#define ROUTINE_21    ROUTINE_orig   
+#define ROUTINE_22    ROUTINE_orig   
+#define ROUTINE_23    ROUTINE_orig   
+#define ROUTINE_24    ROUTINE_orig   
+#define ROUTINE_25    ROUTINE_orig   
+#define ROUTINE_26    ROUTINE_orig   
+#define ROUTINE_27    ROUTINE_orig   
+
+#define TCF(NAME,TN,I,M)              _SEP_(TN,M,cfCOMMA) _(TN,_cfT)(NAME,I,_(A,I),_(B,I),_(C,I))
+#define           BYTE_cfT(M,I,A,B,D) *A
+#define         DOUBLE_cfT(M,I,A,B,D) *A
+#define          FLOAT_cfT(M,I,A,B,D) *A
+#define            INT_cfT(M,I,A,B,D) *A
+#define        LOGICAL_cfT(M,I,A,B,D)  F2CLOGICAL(*A)
+#define           LONG_cfT(M,I,A,B,D) *A
+#define          SHORT_cfT(M,I,A,B,D) *A
+#define          BYTEV_cfT(M,I,A,B,D)  A
+#define        DOUBLEV_cfT(M,I,A,B,D)  A
+#define         FLOATV_cfT(M,I,A,B,D)  VOIDP A
+#define           INTV_cfT(M,I,A,B,D)  A
+#define       LOGICALV_cfT(M,I,A,B,D)  A
+#define          LONGV_cfT(M,I,A,B,D)  A
+#define         SHORTV_cfT(M,I,A,B,D)  A
+#define         BYTEVV_cfT(M,I,A,B,D)  (void *)A /* We have to cast to void *,*/
+#define        BYTEVVV_cfT(M,I,A,B,D)  (void *)A /* since we don't know the   */
+#define       BYTEVVVV_cfT(M,I,A,B,D)  (void *)A /* dimensions of the array.  */
+#define      BYTEVVVVV_cfT(M,I,A,B,D)  (void *)A /* i.e. Unfortunately, can't */
+#define     BYTEVVVVVV_cfT(M,I,A,B,D)  (void *)A /* check that the type       */
+#define    BYTEVVVVVVV_cfT(M,I,A,B,D)  (void *)A /* matches the prototype.    */
+#define       DOUBLEVV_cfT(M,I,A,B,D)  (void *)A
+#define      DOUBLEVVV_cfT(M,I,A,B,D)  (void *)A
+#define     DOUBLEVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    DOUBLEVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   DOUBLEVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define  DOUBLEVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define        FLOATVV_cfT(M,I,A,B,D)  (void *)A
+#define       FLOATVVV_cfT(M,I,A,B,D)  (void *)A
+#define      FLOATVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     FLOATVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    FLOATVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   FLOATVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define          INTVV_cfT(M,I,A,B,D)  (void *)A  
+#define         INTVVV_cfT(M,I,A,B,D)  (void *)A  
+#define        INTVVVV_cfT(M,I,A,B,D)  (void *)A  
+#define       INTVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      INTVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     INTVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      LOGICALVV_cfT(M,I,A,B,D)  (void *)A
+#define     LOGICALVVV_cfT(M,I,A,B,D)  (void *)A
+#define    LOGICALVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   LOGICALVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define  LOGICALVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define LOGICALVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define         LONGVV_cfT(M,I,A,B,D)  (void *)A
+#define        LONGVVV_cfT(M,I,A,B,D)  (void *)A
+#define       LONGVVVV_cfT(M,I,A,B,D)  (void *)A
+#define      LONGVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     LONGVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    LONGVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define        SHORTVV_cfT(M,I,A,B,D)  (void *)A
+#define       SHORTVVV_cfT(M,I,A,B,D)  (void *)A
+#define      SHORTVVVV_cfT(M,I,A,B,D)  (void *)A
+#define     SHORTVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define    SHORTVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define   SHORTVVVVVVV_cfT(M,I,A,B,D)  (void *)A
+#define          PBYTE_cfT(M,I,A,B,D)  A
+#define        PDOUBLE_cfT(M,I,A,B,D)  A
+#define         PFLOAT_cfT(M,I,A,B,D)  VOIDP A
+#define           PINT_cfT(M,I,A,B,D)  A
+#define       PLOGICAL_cfT(M,I,A,B,D)  ((*A=F2CLOGICAL(*A)),A)
+#define          PLONG_cfT(M,I,A,B,D)  A
+#define         PSHORT_cfT(M,I,A,B,D)  A
+#define          PVOID_cfT(M,I,A,B,D)  A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define        ROUTINE_cfT(M,I,A,B,D)  _(ROUTINE_,I)  (*A)
+#else
+#define        ROUTINE_cfT(M,I,A,B,D)  _(ROUTINE_,I)    A
+#endif
+/* A == pointer to the characters
+   D == length of the string, or of an element in an array of strings
+   E == number of elements in an array of strings                             */
+#define TTSTR(    A,B,D)                                                       \
+           ((B=_cf_malloc(D+1))[D]='\0', memcpy(B,A,D), kill_trailing(B,' '))
+#define TTTTSTR(  A,B,D)   (!(D<4||A[0]||A[1]||A[2]||A[3]))?NULL:              \
+                            memchr(A,'\0',D)                 ?A   : TTSTR(A,B,D)
+#define TTTTSTRV( A,B,D,E) (_(B,N)=E,B=_cf_malloc(_(B,N)*(D+1)), (void *)      \
+  vkill_trailing(f2cstrv(A,B,D+1, _(B,N)*(D+1)), D+1,_(B,N)*(D+1),' '))
+#ifdef vmsFortran
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(A->dsc$a_pointer, B,           \
+                                             A->dsc$w_length , A->dsc$l_m[0])
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define       PPSTRING_cfT(M,I,A,B,D)           A->dsc$a_pointer
+#else
+#ifdef CRAYFortran
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(_fcdtocp(A),B,_fcdlen(A),      \
+                              num_elem(_fcdtocp(A),_fcdlen(A),_3(M,_STRV_A,I)))
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( _fcdtocp(A),B,_fcdlen(A))
+#define       PPSTRING_cfT(M,I,A,B,D)           _fcdtocp(A)
+#else
+#define         STRING_cfT(M,I,A,B,D)  TTTTSTR( A,B,D)
+#define        STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(A,B,D, num_elem(A,D,_3(M,_STRV_A,I)))
+#define        PSTRING_cfT(M,I,A,B,D)    TTSTR( A,B,D)
+#define       PPSTRING_cfT(M,I,A,B,D)           A
+#endif
+#endif
+#define       PNSTRING_cfT(M,I,A,B,D)    STRING_cfT(M,I,A,B,D)
+#define       PSTRINGV_cfT(M,I,A,B,D)   STRINGV_cfT(M,I,A,B,D)
+#define           CF_0_cfT(M,I,A,B,D)
+
+#define RCF(TN,I)           _(TN,_cfSTR)(3,R,_(A,I),_(B,I),_(C,I),0,0)
+#define  DEFAULT_cfR(A,B,D)
+#define  LOGICAL_cfR(A,B,D)
+#define PLOGICAL_cfR(A,B,D) *A=C2FLOGICAL(*A);
+#define   STRING_cfR(A,B,D) if (B) _cf_free(B);
+#define  STRINGV_cfR(A,B,D) _cf_free(B);
+/* A and D as defined above for TSTRING(V) */
+#define RRRRPSTR( A,B,D)    if (B) memcpy(A,B, _cfMIN(strlen(B),D)),           \
+                  (D>strlen(B)?memset(A+strlen(B),' ', D-strlen(B)):0), _cf_free(B);
+#define RRRRPSTRV(A,B,D)    c2fstrv(B,A,D+1,(D+1)*_(B,N)), _cf_free(B);
+#ifdef vmsFortran
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( A->dsc$a_pointer,B,A->dsc$w_length)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A->dsc$a_pointer,B,A->dsc$w_length)
+#else
+#ifdef CRAYFortran
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( _fcdtocp(A),B,_fcdlen(A))
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(_fcdtocp(A),B,_fcdlen(A))
+#else
+#define  PSTRING_cfR(A,B,D) RRRRPSTR( A,B,D)
+#define PSTRINGV_cfR(A,B,D) RRRRPSTRV(A,B,D)
+#endif
+#endif
+#define PNSTRING_cfR(A,B,D) PSTRING_cfR(A,B,D)
+#define PPSTRING_cfR(A,B,D)
+
+#define    BYTE_cfFZ(UN,LN) INTEGER_BYTE     FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define  DOUBLE_cfFZ(UN,LN) DOUBLE_PRECISION FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define     INT_cfFZ(UN,LN) int   FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define LOGICAL_cfFZ(UN,LN) int   FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define    LONG_cfFZ(UN,LN) long  FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define   SHORT_cfFZ(UN,LN) short FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#define    VOID_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#ifndef __CF__KnR
+/* The void is req'd by the Apollo, to make this an ANSI function declaration.
+   The Apollo promotes K&R float functions to double. */
+#define   FLOAT_cfFZ(UN,LN) FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(void
+#ifdef vmsFortran
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(fstring *AS
+#else
+#ifdef CRAYFortran
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(_fcd     AS
+#else
+#if  defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(char    *AS
+#else
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(char    *AS, unsigned D0
+#endif
+#endif
+#endif
+#else
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfFZ(UN,LN) FORTRAN_REAL      FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define   FLOAT_cfFZ(UN,LN) FLOATFUNCTIONTYPE FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#endif
+#if defined(vmsFortran) || defined(CRAYFortran) || defined(AbsoftUNIXFortran)
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(AS
+#else
+#define  STRING_cfFZ(UN,LN) void  FCALLSC_QUALIFIER fcallsc(UN,LN)(AS, D0
+#endif
+#endif
+
+#define    BYTE_cfF(UN,LN)     BYTE_cfFZ(UN,LN)
+#define  DOUBLE_cfF(UN,LN)   DOUBLE_cfFZ(UN,LN)
+#ifndef __CF_KnR
+#define   FLOAT_cfF(UN,LN)  FORTRAN_REAL FCALLSC_QUALIFIER fcallsc(UN,LN)(
+#else
+#define   FLOAT_cfF(UN,LN)    FLOAT_cfFZ(UN,LN)
+#endif
+#define     INT_cfF(UN,LN)      INT_cfFZ(UN,LN)
+#define LOGICAL_cfF(UN,LN)  LOGICAL_cfFZ(UN,LN)
+#define    LONG_cfF(UN,LN)     LONG_cfFZ(UN,LN)
+#define   SHORT_cfF(UN,LN)    SHORT_cfFZ(UN,LN)
+#define    VOID_cfF(UN,LN)     VOID_cfFZ(UN,LN)
+#define  STRING_cfF(UN,LN)   STRING_cfFZ(UN,LN),
+
+#define     INT_cfFF
+#define    VOID_cfFF
+#ifdef vmsFortran
+#define  STRING_cfFF           fstring *AS; 
+#else
+#ifdef CRAYFortran
+#define  STRING_cfFF           _fcd     AS;
+#else
+#define  STRING_cfFF           char    *AS; unsigned D0;
+#endif
+#endif
+
+#define     INT_cfL            A0=
+#define  STRING_cfL            A0=
+#define    VOID_cfL                        
+
+#define    INT_cfK
+#define   VOID_cfK
+/* KSTRING copies the string into the position provided by the caller. */
+#ifdef vmsFortran
+#define STRING_cfK                                                             \
+ memcpy(AS->dsc$a_pointer,A0,_cfMIN(AS->dsc$w_length,(A0==NULL?0:strlen(A0))));\
+ AS->dsc$w_length>(A0==NULL?0:strlen(A0))?                                     \
+  memset(AS->dsc$a_pointer+(A0==NULL?0:strlen(A0)),' ',                        \
+         AS->dsc$w_length-(A0==NULL?0:strlen(A0))):0;
+#else
+#ifdef CRAYFortran
+#define STRING_cfK                                                             \
+ memcpy(_fcdtocp(AS),A0, _cfMIN(_fcdlen(AS),(A0==NULL?0:strlen(A0))) );        \
+ _fcdlen(AS)>(A0==NULL?0:strlen(A0))?                                          \
+  memset(_fcdtocp(AS)+(A0==NULL?0:strlen(A0)),' ',                             \
+         _fcdlen(AS)-(A0==NULL?0:strlen(A0))):0;
+#else
+#define STRING_cfK         memcpy(AS,A0, _cfMIN(D0,(A0==NULL?0:strlen(A0))) ); \
+                 D0>(A0==NULL?0:strlen(A0))?memset(AS+(A0==NULL?0:strlen(A0)), \
+                                            ' ', D0-(A0==NULL?0:strlen(A0))):0;
+#endif
+#endif
+
+/* Note that K.. and I.. can't be combined since K.. has to access data before
+R.., in order for functions returning strings which are also passed in as
+arguments to work correctly. Note that R.. frees and hence may corrupt the
+string. */
+#define    BYTE_cfI  return A0;
+#define  DOUBLE_cfI  return A0;
+#if ! (defined(FLOATFUNCTIONTYPE)&&defined(ASSIGNFLOAT)&&defined(RETURNFLOAT))
+#define   FLOAT_cfI  return A0;
+#else
+#define   FLOAT_cfI  RETURNFLOAT(A0);
+#endif
+#define     INT_cfI  return A0;
+#ifdef hpuxFortran800
+/* Incredibly, functions must return true as 1, elsewhere .true.==0x01000000. */
+#define LOGICAL_cfI  return ((A0)?1:0);
+#else
+#define LOGICAL_cfI  return C2FLOGICAL(A0);
+#endif
+#define    LONG_cfI  return A0;
+#define   SHORT_cfI  return A0;
+#define  STRING_cfI  return   ;
+#define    VOID_cfI  return   ;
+
+#ifdef OLD_VAXC                                  /* Allow %CC-I-PARAMNOTUSED. */
+#pragma standard
+#endif
+
+#define FCALLSCSUB0( CN,UN,LN)             FCALLSCFUN0(VOID,CN,UN,LN)
+#define FCALLSCSUB1( CN,UN,LN,T1)          FCALLSCFUN1(VOID,CN,UN,LN,T1)
+#define FCALLSCSUB2( CN,UN,LN,T1,T2)       FCALLSCFUN2(VOID,CN,UN,LN,T1,T2)
+#define FCALLSCSUB3( CN,UN,LN,T1,T2,T3)    FCALLSCFUN3(VOID,CN,UN,LN,T1,T2,T3)
+#define FCALLSCSUB4( CN,UN,LN,T1,T2,T3,T4) \
+    FCALLSCFUN4(VOID,CN,UN,LN,T1,T2,T3,T4)
+#define FCALLSCSUB5( CN,UN,LN,T1,T2,T3,T4,T5) \
+    FCALLSCFUN5(VOID,CN,UN,LN,T1,T2,T3,T4,T5)
+#define FCALLSCSUB6( CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+    FCALLSCFUN6(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6)       
+#define FCALLSCSUB7( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+    FCALLSCFUN7(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7)
+#define FCALLSCSUB8( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+    FCALLSCFUN8(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8)
+#define FCALLSCSUB9( CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+    FCALLSCFUN9(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9)
+#define FCALLSCSUB10(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+   FCALLSCFUN10(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA)
+#define FCALLSCSUB11(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+   FCALLSCFUN11(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB)
+#define FCALLSCSUB12(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+   FCALLSCFUN12(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC)
+#define FCALLSCSUB13(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+   FCALLSCFUN13(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD)
+#define FCALLSCSUB14(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
+   FCALLSCFUN14(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
+#define FCALLSCSUB15(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+   FCALLSCFUN15(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF)
+#define FCALLSCSUB16(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+   FCALLSCFUN16(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG)
+#define FCALLSCSUB17(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+   FCALLSCFUN17(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH)
+#define FCALLSCSUB18(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+   FCALLSCFUN18(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI)
+#define FCALLSCSUB19(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+   FCALLSCFUN19(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ)
+#define FCALLSCSUB20(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+   FCALLSCFUN20(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK)
+#define FCALLSCSUB21(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+   FCALLSCFUN21(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL)
+#define FCALLSCSUB22(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+   FCALLSCFUN22(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM)
+#define FCALLSCSUB23(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+   FCALLSCFUN23(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN)
+#define FCALLSCSUB24(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+   FCALLSCFUN24(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO)
+#define FCALLSCSUB25(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+   FCALLSCFUN25(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP)
+#define FCALLSCSUB26(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+   FCALLSCFUN26(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ)
+#define FCALLSCSUB27(CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
+   FCALLSCFUN27(VOID,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
+
+
+#define FCALLSCFUN1( T0,CN,UN,LN,T1) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN2( T0,CN,UN,LN,T1,T2) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,CF_0,CF_0,CF_0)
+#define FCALLSCFUN3( T0,CN,UN,LN,T1,T2,T3) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,CF_0,CF_0)
+#define FCALLSCFUN4( T0,CN,UN,LN,T1,T2,T3,T4) \
+        FCALLSCFUN5 (T0,CN,UN,LN,T1,T2,T3,T4,CF_0)
+#define FCALLSCFUN5( T0,CN,UN,LN,T1,T2,T3,T4,T5) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN6( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN7( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,CF_0,CF_0,CF_0)
+#define FCALLSCFUN8( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,CF_0,CF_0)
+#define FCALLSCFUN9( T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9) \
+        FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,CF_0)
+#define FCALLSCFUN10(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN11(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,CF_0,CF_0,CF_0)
+#define FCALLSCFUN12(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,CF_0,CF_0)
+#define FCALLSCFUN13(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD) \
+        FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,CF_0)
+
+
+#define FCALLSCFUN15(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN16(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN17(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,CF_0,CF_0,CF_0)
+#define FCALLSCFUN18(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,CF_0,CF_0)
+#define FCALLSCFUN19(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ) \
+        FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,CF_0)
+#define FCALLSCFUN20(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN21(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,CF_0,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN22(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,CF_0,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN23(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,CF_0,CF_0,CF_0,CF_0)
+#define FCALLSCFUN24(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,CF_0,CF_0,CF_0)
+#define FCALLSCFUN25(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,CF_0,CF_0)
+#define FCALLSCFUN26(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ) \
+        FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,CF_0)
+
+
+#ifndef __CF__KnR
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf2(T0))   \
+        {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) )  \
+ {                 CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(    TCF(LN,T1,1,0)  TCF(LN,T2,2,1) \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1) TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1) \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) );                          _Icf(0,K,T0,0,0) \
+                   CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  _(T0,_cfI) }
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)   \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT27(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) ) \
+ {                 CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)   \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(     TCF(LN,T1,1,0)  TCF(LN,T2,2,1)  \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1)  TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1)  \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1)  TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+    TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+    TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+                   CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  _(T0,_cfI) }
+
+#else
+#define FCALLSCFUN0(T0,CN,UN,LN) CFextern _(T0,_cfFZ)(UN,LN) ABSOFT_cf3(T0)) _Icf(0,FF,T0,0,0)\
+        {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT14(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) _Icf(0,FF,T0,0,0) \
+       CFARGT14FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE);   \
+ {                 CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(  TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+    TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+    TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) );                          _Icf(0,K,T0,0,0) \
+                   CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)  _(T0,_cfI)}
+
+#define FCALLSCFUN27(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  \
+                                 CFextern _(T0,_cfF)(UN,LN)                    \
+ CFARGT27(NNCF,DDCF,ABSOFT_cf3(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)) _Icf(0,FF,T0,0,0) \
+       CFARGT27FS(NNNCF,DDDCF,_Z,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR); \
+ {                 CFARGT27S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(     TCF(LN,T1,1,0)  TCF(LN,T2,2,1)  \
+    TCF(LN,T3,3,1)  TCF(LN,T4,4,1)  TCF(LN,T5,5,1)  TCF(LN,T6,6,1)  TCF(LN,T7,7,1)  \
+    TCF(LN,T8,8,1)  TCF(LN,T9,9,1)  TCF(LN,TA,10,1) TCF(LN,TB,11,1) TCF(LN,TC,12,1) \
+    TCF(LN,TD,13,1) TCF(LN,TE,14,1) TCF(LN,TF,15,1) TCF(LN,TG,16,1) TCF(LN,TH,17,1) \
+    TCF(LN,TI,18,1) TCF(LN,TJ,19,1) TCF(LN,TK,20,1) TCF(LN,TL,21,1) TCF(LN,TM,22,1) \
+    TCF(LN,TN,23,1) TCF(LN,TO,24,1) TCF(LN,TP,25,1) TCF(LN,TQ,26,1) TCF(LN,TR,27,1) ); _Icf(0,K,T0,0,0) \
+                   CFARGT27S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)  _(T0,_cfI)}
+
+#endif
+
+
+#endif   /* __CFORTRAN_LOADED */
+
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/dump b/wrfv2_fire/external/io_grib1/grib1_util/dump
new file mode 100644
index 00000000..329450c1
Binary files /dev/null and b/wrfv2_fire/external/io_grib1/grib1_util/dump differ
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/gribsize.incl b/wrfv2_fire/external/io_grib1/grib1_util/gribsize.incl
new file mode 100644
index 00000000..60b0e708
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/gribsize.incl
@@ -0,0 +1,3 @@
+#define IGRIBXMAX 361
+#define JGRIBXMAX 181
+#define KGRIBXMAX 38
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c
new file mode 100644
index 00000000..adc8b239
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c
@@ -0,0 +1,2458 @@
+ /**************************************************************************
+ * Todd Hutchinson          4/20/98
+ * tahutchinson@tasc.com    (781) 942-2000 x3108
+ * TASC 
+ * 55 Walkers Brook Drive
+ * Reading, MA  01867
+ *
+ * Functions in this file are used for decoding grib data.  Please see the
+ * headers before each function for a full descrption.
+ *
+ * Routines in this file call functions in the Naval Research Lab's grib 
+ * library.  The grib library is freely available from 
+ * http://www-mel.nrlmry.navy.mil/cgi-bin/order_grib.  This library should
+ * be installed on your system prior to using the routines in this file.
+ * Documentation for this library is available from
+ *  Master Environmental Grib Library user's manual
+ *  http://mel.dmso.mil/docs/grib.pdf
+ * Note: the standard NRL grib library does not support 
+ * "Little-Endian" platforms such as linux.  There is a version of the NRL 
+ * grib library within the WxPredictor project which does support linux.
+ *
+ * This file references the cfortran.h header file to ease the use of calling 
+ * this function from a fortran routine.  cfortran.h is a header file that 
+ * allows for simple machine-independent calls between c and fortran.  The 
+ * package is available via anonymous ftp at zebra.desy.de.
+ *
+ * The grib document "A GUIDE TO THE CODE FORM FM 92-IX Ext. GRIB" may be
+ * useful to your understanding of this code.  This document is available 
+ * via anonymous ftp from nic.fb4.noaa.gov.  Check the readme file in the
+ * root directory for further instructions.
+ *
+ ****************************************************************************/
+
+#define ERRSIZE 2000
+#define ALLOCSIZE 30
+#define MISSING -999
+
+#define EARTH_RADIUS 6371.229        /* in km */
+#define PI           3.141592654
+#define PI_OVER_180  PI/180.
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#ifdef MACOS
+#include "/usr/include/time.h"
+#else
+#include 
+#endif
+#include "cfortran.h"
+#include "gribfuncs.h"
+#include "gribsize.incl"
+#include "read_grib.h"
+
+/* Function Declarations */
+
+void remove_element(int array[],int index, int size);
+int advance_time(int *century, int year, int month, int day, int hour,
+		 int amount, int unit);
+char *advance_time_str(char startdatein[], int amount, char enddate[]);
+int date_diff(int date1,int century1,int date2,int century2);
+int hours_since_1900(int date,int century);
+int isLeapYear(int year);
+int get_factor2(int unit);
+int compare_record(GribInfo *gribinfo, FindGrib *findgrib, int gribnum);
+
+/* 
+ *These lines allow fortran routines to call the c routines.  They are
+ * used by macros defined in cfortran.h
+ */
+#define get_pressure_levels_STRV_A1 TERM_CHARS(' ',1)
+/*
+FCALLSCFUN6(INT, get_pressure_levels,GET_PRESSURE_LEVELS,
+	    get_pressure_levels,STRINGV,INTV,INTV,INTV,INT,INT)
+#define setup_gribinfo_STRV_A1 TERM_CHARS(' ',1)
+FCALLSCFUN2(INT,setup_gribinfo,SETUP_GRIBINFO,setup_gribinfo,STRINGV,INT)
+#define get_msl_indices_STRV_A1 TERM_CHARS(' ',1)
+FCALLSCFUN9(INT, get_msl_indices,GET_MSL_INDICES,get_msl_indices,
+	    STRINGV,INTV,INTV,INTV,INTV,INTV,INT,INTV,INTV)
+FCALLSCFUN5(INT, get_index,GET_INDEX,get_index,INT,INT,INT,INT,INT)
+#define read_grib_STRV_A1 TERM_CHARS(' ',1)
+FCALLSCFUN7(INT,get_dates,GET_DATES,get_dates,INTV,INTV,INTV,INT,INTV,
+	    INTV,INTV)
+FCALLSCFUN7(INT, read_grib,READ_GRIB,read_grib,
+	    STRINGV,INT,INT,INT,INT,FLOATVV,PVOID)
+FCALLSCFUN8(INT, get_index_near_date,GET_INDEX_NEAR_DATE,get_index_near_date,
+            STRING,INT,INT,INT,INTV,INTV,INTV,INT)
+*/
+/* The value for usLevel_id for isobaric levels */
+#define ISOBARIC_LEVEL_ID 100  
+
+/*************************************************************************
+ * This function reads and decodes grib records in a list of input files 
+ * and stores information about each grib record in the gribinfo array 
+ * structure.  The gribinfo structure can then be accessed by any function 
+ * within this file.
+ * 
+ * Interface:
+ *   Input:
+ *      gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *      files - a string array containing the names of the files containing
+ *              the grib data.  If called from a fortran routine, the
+ *              fortran routine must set the character size of the array to
+ *              be STRINGSIZE-1. The last filled element in the array should
+ *              be "END".
+ *      use_fcst - if TRUE, forecast fields will be included in the gribinfo
+ *              structure, otherwise, only analysis fields will be included.
+ *
+ *    Return:
+ *       1  - successful call to setup_gribinfo
+ *       -1 - call to setup_gribinfo failed
+ *
+ ***************************************************************************/
+
+int rg_setup_gribinfo(GribInfo *gribinfo, char files[][STRINGSIZE],
+		      int use_fcst)
+{
+  FILE *fp;
+  int filenum;
+  int nReturn;
+  int idx;
+  int status;
+  int start_elem;
+  
+  /* Loop through input files */
+  filenum = 0;
+  while ((strcmp(files[filenum], "end") != 0 ) && 
+	 (strcmp(files[filenum], "END") != 0 )) {
+    
+    /* 
+     * This forces gribinfo to be fully initialized.
+     */
+    if (filenum == 0) 
+      {
+	gribinfo->num_elements = 0;
+      }
+
+    start_elem = gribinfo->num_elements;
+
+    fp = fopen(files[filenum],"r");
+    if (fp == NULL)
+      {
+	fprintf(stderr,"Could not open %s\n",files[filenum]);
+	nReturn = -1;
+	break;
+      }
+    
+    status = rg_setup_gribinfo_f(gribinfo, fp, use_fcst);
+    if (status != 1) 
+      {
+	fprintf(stderr, 
+	    "rg_setup_gribinfo_f returned non-zero status (%d), skipping %s\n",
+		status,files[filenum]);
+	continue;
+      }
+
+    for (idx=start_elem; idx < gribinfo->num_elements; idx++) 
+      {
+	strcpy(gribinfo->elements[idx].filename,
+	       files[filenum]);
+      }
+
+    
+    filenum++;
+    nReturn = 1;
+  }
+
+  return nReturn;
+}
+
+
+
+/*************************************************************************
+ *
+ * Similar to rg_setup_gribinfo, except, a unix file descriptor is passed in, 
+ * rather than a list of files to open.
+ *
+ *************************************************************************/
+
+int rg_setup_gribinfo_i(GribInfo *gribinfo, int fid, int use_fcst)
+{
+  FILE *fp;
+  int status;
+  
+  fp = fdopen(fid,"r");
+  if (fp == NULL)
+    {
+      fprintf(stderr,"Could not open file descriptor %d\n",fid);
+      status = -1;
+      return status;
+    }
+  
+  /* This forces gribinfo to be initialized for the first time */
+  gribinfo->num_elements = 0;
+  
+  status = rg_setup_gribinfo_f(gribinfo, fp, use_fcst);
+  if (status != 1) 
+    {
+      fprintf(stderr, 
+	      "rg_setup_gribinfo_f returned non-zero status (%d)\n",
+	      status);
+    }
+  
+  return status;
+}
+
+/*************************************************************************
+ *
+ * Similar to rg_setup_gribinfo, except, a file pointer is passed in, rather
+ * than a list of files to open.
+ * 
+ * If gribinfo->num_elements is 0, gribinfo is initialized, otherwise, 
+ *    gribinfo is appended to.
+ *
+ *************************************************************************/
+
+int rg_setup_gribinfo_f(GribInfo *gribinfo, FILE *fp, int use_fcst)
+{
+  char errmsg[ERRSIZE];
+  int nReturn=0;
+  long offset;
+  int filenum;
+  int Rd_Indexfile=0;
+  GRIB_HDR *gh1;
+  long tmpoffset=0;
+  int century;
+  int year4d;
+  int fcsttime1=0;
+  int fcsttime2=0;
+  int factor=0;
+
+  /* Set the number of elements to be zero initially */
+  if (gribinfo->num_elements <= 0)
+    {
+      /* Allocate space for gribinfo */
+      gribinfo->elements = (Elements *)calloc(ALLOCSIZE,sizeof(Elements));
+      if (gribinfo->elements == NULL) {
+	sprintf(errmsg,"Could not allocate %d bytes for gribinfo->elements\n",
+		ALLOCSIZE*sizeof(Elements));
+	goto bail_out;
+      }
+    }
+  
+  /* Make storage for Grib Header */
+  nReturn = init_gribhdr(&gh1, errmsg);
+  /* 
+   * The grib library is setup such that, when init_gribhdr == 0, it was 
+   * successful.  If it is 1, it failed.
+   */
+  if (nReturn == 1) goto bail_out;
+  
+  /* Scan through message */
+  for (offset = 0L; nReturn == 0; offset += gh1->msg_length) {
+    if ((gribinfo->num_elements > 0) && 
+	(gribinfo->num_elements%ALLOCSIZE == 0))
+      gribinfo->elements = 
+	(Elements *)realloc(gribinfo->elements,
+			    (gribinfo->num_elements+ALLOCSIZE)*
+			    sizeof(Elements));
+
+    if (gribinfo->elements == NULL) {
+      sprintf(errmsg,"Could not allocate %d bytes for gribinfo\n",
+	      (gribinfo->num_elements + ALLOCSIZE)*sizeof(Elements));
+      goto bail_out;
+    }
+
+    /* Setup the File pointer */
+    gribinfo->elements[gribinfo->num_elements].fp = fp;
+
+    gribinfo->elements[gribinfo->num_elements].pds = 
+      (PDS_INPUT *)malloc(1*sizeof(PDS_INPUT));
+    gribinfo->elements[gribinfo->num_elements].gds = 
+      (grid_desc_sec *)malloc(1*sizeof(grid_desc_sec));
+    gribinfo->elements[gribinfo->num_elements].bms = 
+      (BMS_INPUT *)malloc(1*sizeof(BMS_INPUT));
+    gribinfo->elements[gribinfo->num_elements].bds_head = 
+      (BDS_HEAD_INPUT *)malloc(1*sizeof(BDS_HEAD_INPUT));
+    errmsg[0] = '\0';
+    nReturn = 
+      grib_fseek(fp,&offset, Rd_Indexfile, gh1, errmsg);
+    if (nReturn != 0) {
+      if (nReturn == 2) break;   /* End of file error */
+      else {
+	fprintf(stderr, "Grib_fseek returned non zero status (%d)\n",
+		nReturn);
+	goto bail_out;
+      }
+    }
+    if (errmsg[0] != '\0')
+      { /* NO errors but got a Warning msg from seek */
+	fprintf(stderr,"%s; Skip Decoding...\n",errmsg);
+	errmsg[0] = '\0';   
+	gh1->msg_length = 1L;    /* set to 1 to bump offset up */
+	continue;
+      }
+      
+    if (gh1->msg_length < 0) {
+      fprintf(stderr, "Error:  message returned had bad length (%ld)\n",
+	      gh1->msg_length);
+      goto bail_out;
+    }
+    else if (gh1->msg_length == 0) {
+      fprintf(stderr, "msg_length is Zero\n");
+      gh1->msg_length = 1L;
+      continue;
+    }
+    init_dec_struct(gribinfo->elements[gribinfo->num_elements].pds, 
+		    gribinfo->elements[gribinfo->num_elements].gds, 
+		    gribinfo->elements[gribinfo->num_elements].bms, 
+		    gribinfo->elements[gribinfo->num_elements].bds_head);
+    
+    /* 
+     * gribgetpds is an undocumented function within the grib library.
+     * gribgetpds grabs the pds section from the grib message without
+     * decoding the entire grib message.  The interface is as follows:
+     *     first input param: a pointer to the beginning of the pds 
+     *                        section.
+     *     second input param: a pointer to a structure which will hold
+     *                        the pds information
+     *     third param: the error message.
+     * 
+     * If gribgetpds ever fails, it can be replaced with the following 
+     *    nReturn = grib_dec((char *)gh1->entire_msg, &pds, &gds, &bds_head, 
+     *              &bms, &grib_data, errmsg);
+     * 
+     * This will degrade performance since this grib_dec decodes the 
+     *    entire grib message.
+     */
+    
+    nReturn = gribgetpds((char*)(gh1->entire_msg + 8),
+			 gribinfo->elements[gribinfo->num_elements].pds,
+			 errmsg);
+    if (nReturn != 0) goto bail_out;
+
+    /* Get gds if present */
+    if (gribinfo->elements[gribinfo->num_elements].pds->usGds_bms_id >> 7 
+	& 1) {
+      nReturn = 
+	gribgetgds((char*)
+		   (gh1->entire_msg+8+
+		    gribinfo->elements[gribinfo->num_elements].pds->uslength),
+		   gribinfo->elements[gribinfo->num_elements].gds,errmsg);
+      if (nReturn != 0) goto bail_out;
+    }
+
+    /* Get bms section if present */
+    if (gribinfo->elements[gribinfo->num_elements].pds->usGds_bms_id >> 6 
+	& 1) {
+      /*
+	fprintf(stderr,"grids with bms section not currently supported\n");
+	return -1;
+      */
+    }
+    
+    gribinfo->elements[gribinfo->num_elements].usGrid_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usGrid_id;
+    gribinfo->elements[gribinfo->num_elements].usParm_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usParm_id;
+    gribinfo->elements[gribinfo->num_elements].usLevel_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usLevel_id;
+    gribinfo->elements[gribinfo->num_elements].usHeight1 = 
+      gribinfo->elements[gribinfo->num_elements].pds->usHeight1;
+    gribinfo->elements[gribinfo->num_elements].usHeight2 = 
+      gribinfo->elements[gribinfo->num_elements].pds->usHeight2;
+    gribinfo->elements[gribinfo->num_elements].center_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usCenter_id;
+    gribinfo->elements[gribinfo->num_elements].parmtbl = 
+      gribinfo->elements[gribinfo->num_elements].pds->usParm_tbl;
+    gribinfo->elements[gribinfo->num_elements].proc_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usProc_id;
+    gribinfo->elements[gribinfo->num_elements].subcenter_id = 
+      gribinfo->elements[gribinfo->num_elements].pds->usCenter_sub;
+    gribinfo->elements[gribinfo->num_elements].offset = offset;
+    gribinfo->elements[gribinfo->num_elements].end = 
+      offset + gh1->msg_length - 1;
+  
+    if (use_fcst) {
+      century = gribinfo->elements[gribinfo->num_elements].pds->usCentury;
+      
+      if (gribinfo->elements[gribinfo->num_elements].pds->usTime_range == 10)
+	{
+	  fcsttime1 = gribinfo->elements[gribinfo->num_elements].pds->usP1*256 + 
+	    gribinfo->elements[gribinfo->num_elements].pds->usP2;
+	  fcsttime2 = 0;
+	}
+      else if (gribinfo->elements[gribinfo->num_elements].pds->usTime_range 
+	       == 203) {
+	/* This is the WSI extension to grib.  203 indicates "duration" */
+	fcsttime1 = gribinfo->elements[gribinfo->num_elements].pds->usP1;
+	fcsttime2 = gribinfo->elements[gribinfo->num_elements].pds->usP1 +
+	  gribinfo->elements[gribinfo->num_elements].pds->usP2;
+      } else {
+	fcsttime1 = gribinfo->elements[gribinfo->num_elements].pds->usP1;
+	fcsttime2 = gribinfo->elements[gribinfo->num_elements].pds->usP2;
+      }
+      
+      gribinfo->elements[gribinfo->num_elements].date = 
+	advance_time(¢ury,
+		     gribinfo->elements[gribinfo->num_elements].pds->usYear,
+		     gribinfo->elements[gribinfo->num_elements].pds->usMonth,
+		     gribinfo->elements[gribinfo->num_elements].pds->usDay,
+		     gribinfo->elements[gribinfo->num_elements].pds->usHour,
+		     fcsttime1,
+		     gribinfo->elements[gribinfo->num_elements].pds->usFcst_unit_id);
+    } 
+    else {
+      gribinfo->elements[gribinfo->num_elements].date = 
+	gribinfo->elements[gribinfo->num_elements].pds->usHour*1 + 
+	gribinfo->elements[gribinfo->num_elements].pds->usDay*100 + 
+	gribinfo->elements[gribinfo->num_elements].pds->usMonth*10000 + 
+	gribinfo->elements[gribinfo->num_elements].pds->usYear*1000000;
+    } 
+    gribinfo->elements[gribinfo->num_elements].century = 
+      gribinfo->elements[gribinfo->num_elements].pds->usCentury;
+    
+    year4d = 
+	(gribinfo->elements[gribinfo->num_elements].pds->usCentury - 1) * 100
+	+ gribinfo->elements[gribinfo->num_elements].pds->usYear;
+
+    sprintf(gribinfo->elements[gribinfo->num_elements].initdate,
+	    "%04d%02d%02d%02d%02d%02d",
+	    year4d,
+	    gribinfo->elements[gribinfo->num_elements].pds->usMonth,
+	    gribinfo->elements[gribinfo->num_elements].pds->usDay,
+	    gribinfo->elements[gribinfo->num_elements].pds->usHour,
+	    gribinfo->elements[gribinfo->num_elements].pds->usMinute,
+	    0);	      
+    
+    factor = 
+      get_factor2(gribinfo->elements[gribinfo->num_elements].pds->usFcst_unit_id);
+    gribinfo->elements[gribinfo->num_elements].fcsttime1 = 
+      fcsttime1 * factor;
+    gribinfo->elements[gribinfo->num_elements].fcsttime2 = 
+      fcsttime2 * factor;
+    
+    advance_time_str(gribinfo->elements[gribinfo->num_elements].initdate,
+		     gribinfo->elements[gribinfo->num_elements].fcsttime1,
+		     gribinfo->elements[gribinfo->num_elements].valid_time);
+
+    gribinfo->num_elements++;
+  }
+  
+  free_gribhdr(&gh1);
+  return 1;
+  
+  /* The error condition */
+ bail_out:
+  if (errmsg[0] != '\0') fprintf(stderr,"\n***ERROR: %s: %s\n",
+				 "setup_grib",errmsg);
+  if (gribinfo->elements != NULL) free(gribinfo->elements);
+  perror("System Error ");
+  return -1;
+}
+
+/*****************************************************************************
+ *
+ * Retrieve pressure levels from grib data.  This function will pass the 
+ * pressure levels for which the input parameter is available at all input 
+ * times back to the calling routine.  
+ *
+ * Interface
+ *      Input: 
+ *         gribinfo - pointer to a previously allocated gribinfo structure.  
+ *                 The gribinfo structure is filled in this function.
+ *         dates: an array of dates to check for data
+ *                format: yymmddhh
+ *                If called from a fortran routine, the fortran routine must 
+ *                set the character size of the array to be STRINGSIZE-1
+ *         centuries: an array holding the centuries for each of the 
+ *                dates in the array dates.
+ *         parm_id: the input parameter id.  From table 2 of the grib manual.
+ *      Output:
+ *         finallevels: an array of pressure levels which are contained in 
+ *                the grib data at all input times.
+ *      Return:
+ *         the number of levels in the levels array.  The levels are listing
+ *         in descending (by value) order, i.e., the value with the highest
+ *         pressure (lowest vertical level) is the first element.
+ *
+ ****************************************************************************/
+
+int rg_get_pressure_levels(GribInfo *gribinfo, int dates[], int centuries[], 
+			int parm_id[], int finallevels[],int min_pres,
+			int numparms)
+{
+  int datenum;
+  int gribnum;
+  int *levelnum;
+  int levelincluded;
+  int i,j;
+  int contains_level;
+  int **tmplevels;
+  int numfinallevels = 0;
+  int parmnum;
+  int tmpval;
+  
+  /* Allocate space */
+  levelnum = (int *)calloc(numparms,sizeof(int));
+  tmplevels = (int **)calloc(numparms,sizeof(int *));
+  for (j = 0; j < numparms; j++) {
+    tmplevels[j] = (int *)calloc(1000,sizeof(int));
+    if (tmplevels[j] == NULL) {
+      tmplevels = NULL;
+      break;
+    }
+  }
+  if ((levelnum == NULL) || (tmplevels == NULL)) {
+    fprintf(stderr,
+	    "get_pressure_levels: Allocation of space failed, returning\n");
+    return -1;
+  }
+  
+  /* Loop through all parameters */
+  for (parmnum = 0; parmnum < numparms; parmnum++) {
+
+    levelnum[parmnum] = 0;
+
+  /* Get the array of pressure levels available at the first input time */
+    datenum = 0;
+    for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+      if (gribinfo->elements[gribnum].date == dates[datenum]) {
+	if (gribinfo->elements[gribnum].century == centuries[datenum]) {
+	  if (gribinfo->elements[gribnum].usLevel_id == ISOBARIC_LEVEL_ID) {
+	    if (gribinfo->elements[gribnum].usParm_id == parm_id[parmnum]) {
+	      if (gribinfo->elements[gribnum].usHeight1 >= min_pres) {
+		levelincluded = 0;
+		for (j=0; j < levelnum[parmnum]; j++) {
+		  if (tmplevels[parmnum][j] == 
+		      gribinfo->elements[gribnum].usHeight1) {
+		    levelincluded = 1;
+		    break;
+		  }
+		}
+		if (levelincluded == 0) {
+		  tmplevels[parmnum][levelnum[parmnum]] = 
+		    gribinfo->elements[gribnum].usHeight1;
+		  levelnum[parmnum]++;
+		}
+	      }
+	    }
+	  }
+	}
+      }
+    }
+    
+    /* Remove levels that are not contained at all subsequent times */
+    datenum++;
+    while (dates[datenum] != -99){
+      for (j = 0; j < levelnum[parmnum]; j++) {
+	contains_level = 0;
+	for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+	  if (gribinfo->elements[gribnum].date == dates[datenum]) {
+	    if (gribinfo->elements[gribnum].century == centuries[datenum]) {
+	      if (gribinfo->elements[gribnum].usLevel_id == ISOBARIC_LEVEL_ID)
+		{
+		  if (gribinfo->elements[gribnum].usParm_id == 
+		      parm_id[parmnum]) {
+		    if (tmplevels[parmnum][j] == 
+			gribinfo->elements[gribnum].usHeight1)
+		      contains_level = 1;
+		  }
+		}
+	    }
+	  }
+	}
+	if (!(contains_level)) {
+	  remove_element(tmplevels[parmnum],j,levelnum[parmnum]);
+	  levelnum[parmnum]--;
+	  j--;
+	}
+      }
+      datenum++;
+    }
+
+    /* 
+     * Put the values for levels into an array.  Remove any levels that
+     * were not found at all other levels
+     */
+    if (parmnum == 0) {
+      for (j = 0; j < levelnum[parmnum]; j++) {
+	finallevels[j] = tmplevels[parmnum][j];
+	numfinallevels++;
+      }
+    } else {
+      for (i=0; i= 0; i--) {
+      if (finallevels[i] >= tmpval) break;
+      finallevels[i+1] = finallevels[i];
+    }
+    finallevels[i+1] = tmpval;
+  }
+
+  return numfinallevels;
+}
+
+/****************************************************************************
+ *
+ * Returns an array of grib indices that correspond to particular grib fields
+ * to use as sea level pressure.  There will be exactly one element for each
+ * input time.  If a field was not found, then this function returns NULL
+ *
+ * Interface:
+ *    Input:
+ *      gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *         dates: a string array of dates to check for data.
+ *                format: yymmddhh
+ *                If called from a fortran routine, the fortran routine must 
+ *                set the character size of the array to be STRINGSIZE-1
+ *         centuries: an array holding the centuries for each of the 
+ *                dates in the array dates.
+ *         usParm_id: an array of parameter identifiers that could be
+ *                    used as a sea level pressure field (From table 2 of 
+ *                    grib documentation)
+ *         usLevel_id: the level id that could be used as a sea level pressure
+ *                    field (from table 3 of the grib documentation)
+ *         usHeight1: the height for the particular parameter and level
+ *                    (in units described by the parameter index)
+ *         numparms:  the number of parameters in each of the usParm_id, 
+ *                    usLevel_id, and usHeight1 arrays.
+ *    Output:
+ *         grib_index: an array of grib indices to use for the sea level 
+ *                    pressure.  The index to grib_index corresponds to 
+ *                    the time, i.e., the first array element of grib_index 
+ *                    corresponds to the first time, the second element to 
+ *                    the second time, etc.
+ *         
+ *            Note: Values in the input arrays, usParm_id, usLevel_id, and 
+ *                    usHeight with the same array index must correspond.
+ *
+ *    Return:
+ *          1 for success
+ *          -1 if no field was found.
+ ***************************************************************************/
+
+int rg_get_msl_indices(GribInfo *gribinfo, char dates[][STRINGSIZE],
+		    int centuries[], int usParm_id[],int usLevel_id[],
+		    int usHeight1[],int infactor[],int numparms,
+		    int grib_index[],int outfactor[])
+{
+  int parmindex;
+  int datenum = 0;
+  int gribnum;
+  int foundfield=0;
+
+  for (parmindex = 0; parmindex < numparms; parmindex++) {
+
+    datenum = 0;
+    while ((strcmp(dates[datenum], "end") != 0 ) && 
+	   (strcmp(dates[datenum], "END") != 0 )) {
+
+      for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+	if (gribinfo->elements[gribnum].date == atoi(dates[datenum])) {
+	  if (gribinfo->elements[gribnum].century == centuries[datenum]) {
+	    if ((gribinfo->elements[gribnum].usParm_id == 
+		 usParm_id[parmindex]) &&
+		(gribinfo->elements[gribnum].usLevel_id == 
+		 usLevel_id[parmindex]) &&
+		(gribinfo->elements[gribnum].usHeight1 == 
+		 usHeight1[parmindex])) {
+	      grib_index[datenum] = gribnum;
+	      outfactor[datenum] = infactor[parmindex];
+	      foundfield++;
+	      break;
+	    }
+	  }
+	}
+      }
+
+      datenum++;
+
+      /* 
+       * Break out of loop and continue on to next parameter if the current 
+       * parameter was missing from a date. 
+       */
+
+      if (foundfield != datenum) break;
+    }
+
+/* 
+ * Break out of the parameter loop once we've found a field available at all 
+ * dates 
+ */
+    if (foundfield == datenum) {
+      break;
+    }
+
+  }
+
+  if (foundfield == datenum)
+    return 1;
+  else
+    return -1;
+
+}
+
+
+/***************************************************************************
+ * 
+ * This function takes an index as input and returns a 2d grib data field
+ *
+ * Interface:
+ *    input: 
+ *      gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *       index - the index of gribinfo for which data is to be retrieved
+ *       scale - the scale factor to multiply data by, i.e., if -2, 
+ *               data will be multiplied by 10^-2.
+ *    output:
+ *       grib_out - the 2 dimensional output grib data
+ *               Warning: This 2d array is setup with i being the vertical
+ *               dimension and j being the horizontal dimension.  This
+ *               is the convention used in mesoscale numerical modeling
+ *               (the MM5 in particular), so it is used here.
+ *    return:
+ *       1 for success
+ *      -1 for failure
+ ***************************************************************************/
+
+int rg_get_grib(GribInfo *gribinfo, int index,int scale,
+	     float **grib_out,int *vect_comp_flag, 
+	     GRIB_PROJECTION_INFO_DEF *Proj, BDS_HEAD_INPUT *bds_head)
+{
+  char errmsg[ERRSIZE];
+  int nReturn=0;
+  long offset;
+  int Rd_Indexfile=0;
+  BMS_INPUT bms;
+  PDS_INPUT pds;
+  BDS_HEAD_INPUT dummy;
+  grid_desc_sec gds;
+  GRIB_HDR *gh1;
+  int i,j;
+  int expandlon = 0;
+  float *grib_data;
+
+  /* Initialize Variables */
+  errmsg[0] = '\0';
+  offset = 0L;
+  grib_data = (float *)NULL;
+
+  /* Make storage for Grib Header */
+  nReturn = init_gribhdr (&gh1, errmsg);
+  if (nReturn == 1) goto bail_out;
+  
+  /* Seek to the position in the grib data */
+  offset = gribinfo->elements[index].offset;
+  nReturn = grib_fseek(gribinfo->elements[index].fp,&offset,
+		      Rd_Indexfile,gh1,errmsg);
+  if (nReturn != 1) {
+    fprintf(stderr,"Grib_fseek returned error status (%d)\n",nReturn);
+    goto bail_out;
+  }
+  if (errmsg[0] != '\0')
+    { /* NO errors but got a Warning msg from seek */ 
+      fprintf(stderr,"%s: Skip Decoding...\n",errmsg);
+      errmsg[0] = '\0';
+    }
+  if (gh1->msg_length <= 0) {
+    fprintf(stderr,"Error: message returned had bad length (%ld)\n",
+	    gh1->msg_length);
+    goto bail_out;
+  }
+  init_dec_struct(&pds, &gds, &bms, &dummy);
+ 
+  nReturn = grib_dec((char *)gh1->entire_msg, &pds, &gds, 
+		     bds_head,
+		     &bms, &grib_data, errmsg);
+ 
+  if (nReturn != 0) goto bail_out;
+  
+  if (bms.uslength > 0) {
+    nReturn = apply_bitmap(&bms, &grib_data, FILL_VALUE, bds_head, 
+			   errmsg);
+    if (nReturn != 0) goto bail_out;
+  }
+ 
+  switch(gds.head.usData_type) {
+  case 0:
+  case 4:
+    strcpy(Proj->prjnmm,"latlon");
+    Proj->colcnt = gds.llg.usNi;
+    Proj->rowcnt = gds.llg.usNj;
+    Proj->origlat = gds.llg.lLat1/1000.;
+    Proj->origlon = gds.llg.lLon1/1000.;
+    Proj->xintdis = (gds.llg.iDi/1000.)*EARTH_RADIUS*PI_OVER_180;
+    Proj->yintdis = (gds.llg.iDj/1000.)*EARTH_RADIUS*PI_OVER_180;
+    Proj->parm1 = 0.;
+    Proj->parm2 = 0.;
+    if ((gds.llg.usRes_flag >> 3) & 1) *vect_comp_flag = 1;
+    else *vect_comp_flag = 0;
+
+    /* If the grid is a global grid, we want to set the expandlon flag
+     * so that the number of columns in the array is expanded by one and
+     * the first column of data is copied to the last column.  This
+     * allows calling routines to interpolate between first and last columns
+     * of data.
+     */
+
+    if (gds.llg.usNi*gds.llg.iDi/1000. == 360)
+      expandlon = 1;
+    else
+      expandlon = 0;
+     
+    break;
+  case 1: 
+    strcpy(Proj->prjnmm,"mercator");
+    Proj->colcnt = gds.merc.cols;
+    Proj->rowcnt = gds.merc.rows;
+    Proj->origlat = gds.merc.first_lat/1000.;
+    Proj->origlon = gds.merc.first_lon/1000.;
+    Proj->xintdis = gds.merc.lon_inc/1000.;
+    Proj->yintdis = gds.merc.lat_inc/1000.;
+    Proj->parm1 = gds.merc.latin/1000.;
+    Proj->parm2 = (gds.merc.Lo2/1000. - Proj->origlon)/gds.merc.cols;
+    if ((gds.merc.usRes_flag >> 3) & 1) *vect_comp_flag = 1;
+    else *vect_comp_flag = 0;
+    break;
+  case 3:
+    strcpy(Proj->prjnmm,"lambert");
+    Proj->colcnt = gds.lam.iNx;
+    Proj->rowcnt = gds.lam.iNy;
+    Proj->origlat = gds.lam.lLat1/1000.;
+    Proj->origlon = gds.lam.lLon1/1000.;
+    Proj->xintdis = gds.lam.ulDx/1000.;
+    Proj->yintdis = gds.lam.ulDy/1000.;
+    Proj->parm1 = gds.lam.lLat_cut1/1000.;
+    Proj->parm2 = gds.lam.lLat_cut2/1000.;
+    Proj->parm3 = gds.lam.lLon_orient/1000.;
+    if ((gds.lam.usRes_flag >> 3) & 1) *vect_comp_flag = 1;
+    else *vect_comp_flag = 0;
+    break;
+  case 5:
+    strcpy(Proj->prjnmm,"polar_stereo");
+    Proj->colcnt = gds.pol.usNx;
+    Proj->rowcnt = gds.pol.usNy;
+    Proj->origlat = gds.pol.lLat1/1000.;
+    Proj->origlon = gds.pol.lLon1/1000.;
+    Proj->xintdis = gds.pol.ulDx/1000.;
+    Proj->yintdis = gds.pol.ulDy/1000.;
+    Proj->parm1 = 60.;
+    Proj->parm2 = gds.pol.lLon_orient/1000.;   
+    if ((gds.pol.usRes_flag >> 3) & 1) *vect_comp_flag = 1;
+    else *vect_comp_flag = 0;
+    break;
+  default:
+    fprintf(stderr,"Grid not supported, gds.head.usData_type = %d\n",
+	    gds.head.usData_type);
+    fprintf(stderr,"Exiting\n");
+    exit(-1);
+    break;
+  }  
+
+  strcpy(Proj->stordsc,"+y_in_+x");
+  Proj->origx = 1;
+  Proj->origy = 1;
+
+  for (j=0; j< (Proj->rowcnt); j++) {
+    for (i=0; i<(Proj->colcnt); i++) {
+      grib_out[j][i] = grib_data[i+j*Proj->colcnt]*pow(10,scale);
+    }
+  }
+
+  if (expandlon) {
+    (Proj->colcnt)++;
+    for (j = 0; j < Proj->rowcnt; j++) {
+      grib_out[j][Proj->colcnt-1] = grib_out[j][0];
+    }
+  }
+
+  /* 
+   * You only reach here when there is no error, so return successfully.
+   */
+      
+  nReturn = 0;
+
+  if (grib_data != NULL) {
+    free_gribhdr(&gh1);
+    free(grib_data);
+  } 
+
+  return 1;
+      
+  /* The error condition */
+ bail_out:
+  if (errmsg[0] != '\0') fprintf(stderr,"\n***ERROR: %s %s\n",
+				 "get_grib",errmsg);
+  if (grib_data != NULL)
+    free(grib_data);
+  free_gribhdr(&gh1);
+  return -1;
+}
+
+/***************************************************************************
+ * 
+ * This function takes an index as input and returns a 2d grib data field
+ *
+ * Interface:
+ *    input: 
+ *      gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *       index - the index of gribinfo for which data is to be retrieved
+ *    output:
+ *       data - the 2 dimensional output grib data
+ *               Warning: This 2d array is setup with i being the vertical
+ *               dimension and j being the horizontal dimension.  This
+ *               is the convention used in mesoscale numerical modeling
+ *               (the MM5 in particular), so it is used here.
+ *    return:
+ *       1 for success
+ *      -1 for failure
+ ***************************************************************************/
+
+int rg_get_data(GribInfo *gribinfo, int index, float **data)
+{
+  float *data_1d;
+  int i,j;
+  int numrows,numcols;
+  int status;
+
+  numrows = rg_get_numrows(gribinfo,index);
+  numcols = rg_get_numcols(gribinfo,index);
+  
+  data_1d = (float *)calloc(numrows*numcols,sizeof(float));
+  if (data_1d == 0)
+    {
+      fprintf(stderr,"Allocating space for data_1d failed, index: %d\n",index);
+      return -1;
+    }
+
+  status = rg_get_data_1d(gribinfo, index, data_1d);
+  if (status != 1)
+    {
+      return status;
+    }
+
+  for (j=0; j< numrows; j++) {
+    for (i=0; i < numcols; i++) {
+      data[j][i] = data_1d[i+j*numcols];
+    }
+  }
+
+  free(data_1d);
+
+  return 1;
+  
+}
+
+/***************************************************************************
+ * 
+ * This function takes an index as input and returns a 1d grib data field
+ *
+ * Interface:
+ *    input: 
+ *      gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *       index - the index of gribinfo for which data is to be retrieved
+ *    output:
+ *       data - 1 dimensional output grib data
+ *               Warning: This 2d array is setup with i being the vertical
+ *               dimension and j being the horizontal dimension.  This
+ *               is the convention used in mesoscale numerical modeling
+ *               (the MM5 in particular), so it is used here.
+ *    return:
+ *       1 for success
+ *      -1 for failure
+ ***************************************************************************/
+
+int rg_get_data_1d(GribInfo *gribinfo, int index, float *data)
+{
+  char errmsg[ERRSIZE];
+  int nReturn=0;
+  long offset;
+  int Rd_Indexfile=0;
+  BMS_INPUT bms;
+  PDS_INPUT pds;
+  BDS_HEAD_INPUT bds_head;
+  grid_desc_sec gds;
+  GRIB_HDR *gh1;
+  int i,j;
+  int numcols, numrows;
+  float *grib_data;
+
+  /* Initialize Variables */
+  errmsg[0] = '\0';
+  offset = 0L;
+  grib_data = (float *)NULL;
+
+  /* Make storage for Grib Header */
+  nReturn = init_gribhdr (&gh1, errmsg);
+  if (nReturn == 1) goto bail_out;
+  
+  /* Seek to the position in the grib data */
+  offset = gribinfo->elements[index].offset;
+  nReturn = grib_fseek(gribinfo->elements[index].fp,&offset,
+		      Rd_Indexfile,gh1,errmsg);
+  if (nReturn != 0) {
+    fprintf(stderr,"Grib_fseek returned non-zero status (%d)\n",nReturn);
+    goto bail_out;
+  }
+  if (errmsg[0] != '\0')
+    { /* NO errors but got a Warning msg from seek */ 
+      fprintf(stderr,"%s: Skip Decoding...\n",errmsg);
+      errmsg[0] = '\0';
+    }
+  if (gh1->msg_length <= 0) {
+    fprintf(stderr,"Error: message returned had bad length (%ld)\n",
+	    gh1->msg_length);
+    goto bail_out;
+  }
+
+  init_dec_struct(&pds, &gds, &bms, &bds_head);
+ 
+  nReturn = grib_dec((char *)gh1->entire_msg, &pds, &gds, 
+		     &bds_head,
+		     &bms, &grib_data, errmsg);
+ 
+  if (nReturn != 0) goto bail_out;
+  
+  if (bms.uslength > 0) {
+    nReturn = apply_bitmap(&bms, &grib_data, FILL_VALUE, &bds_head, 
+			   errmsg);
+    if (nReturn != 0) goto bail_out;
+  }
+ 
+  /*
+   * Copy the data into the permanent array
+   */ 
+  numcols = rg_get_numcols(gribinfo,index);
+  numrows = rg_get_numrows(gribinfo,index);
+  memcpy(data,grib_data,numcols*numrows*sizeof(float));
+
+  /* 
+   * You only reach here when there is no error, so return successfully.
+   */
+      
+  nReturn = 0;
+
+  if (grib_data != NULL) {
+    free_gribhdr(&gh1);
+    free(grib_data);
+  } 
+
+  return 1;
+      
+  /* The error condition */
+ bail_out:
+  if (errmsg[0] != '\0') fprintf(stderr,"\n***ERROR: %s %s\n",
+				 "get_grib",errmsg);
+  if (grib_data != NULL)
+    free(grib_data);
+  free_gribhdr(&gh1);
+  return -1;
+}
+
+/****************************************************************************
+ * Returns the index of gribinfo corresponding to the input date, level, 
+ * height, and parameter.
+ *
+ * Interface:
+ *   Input: 
+ *      gribinfo  - pointer to a previously populated gribinfo structure.  
+ *      initdate  -  initialization date in the form yyyymmdd[HHMMSS].  If any
+ *                  part of HHMMSS is not specified, it will be set to 0.
+ *      parmid    - the parameter id in the grib file
+ *      leveltype - the leveltype id from table 3/3a of the grib document.
+ *      level1    - First level of the data in units described by leveltype.
+ *      level2    - Second level of the data in units described by leveltype.
+ *      fcsttime1 - First forecast time in seconds.
+ *      fcsttime2 - Second forecast time in seconds.
+ *    Note: If an input variable is set set to -INT_MAX, then any value
+ *                will be considered a match.
+ *    Return:
+ *       if >= 0    The index of the gribinfo data that corresponds to the
+ *                  input parameters
+ *       if < 0     No field corresponding to the input parms was found.
+ *
+ ***************************************************************************/
+
+int rg_get_index(GribInfo *gribinfo, FindGrib *findgrib)
+{
+  int gribnum;
+  int grib_index=-1;
+
+  for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+    if (compare_record(gribinfo, findgrib, gribnum) == 1)
+      {
+	grib_index = gribnum;
+	break;
+      }
+  }
+  return grib_index;
+}
+
+
+/****************************************************************************
+ * Same as rg_get_index, except that a guess for the record number is given.
+ *   This "guess" record is first checked to see if it matches, if so, 
+ *      that grib record number is just returned.  If it does not match, 
+ *      full searching ensues.
+ * Returns the index of gribinfo corresponding to the input date, level, 
+ * height, and parameter.
+ *
+ * Interface:
+ *   Input: 
+ *      Same is rg_get_index, except:
+ *      guess_index  - The index to check first.
+ *    Return:
+ *      Same as rg_get_index
+ *
+ ***************************************************************************/
+
+int rg_get_index_guess(GribInfo *gribinfo, FindGrib *findgrib, int guess_index)
+{
+  int retval;
+
+  if (compare_record(gribinfo, findgrib, guess_index) == 1) {
+    retval = guess_index;
+  } else {
+    retval = rg_get_index(gribinfo, findgrib);
+  }
+
+  return retval;
+}
+
+
+/****************************************************************************
+ * Sets all values in FindGrib to missing.
+ *
+ * Interface:
+ *   Input: 
+ *      findgrib  - pointer to a previously allocated findgrib structure.
+ *
+ *    Return:
+ *       1  for success.
+ *       -1 for failure.
+ *
+ ***************************************************************************/
+int rg_init_findgrib(FindGrib *findgrib)
+{
+  strcpy(findgrib->initdate,"*");
+  strcpy(findgrib->validdate,"*");
+  findgrib->parmid          = -INT_MAX;
+  findgrib->parmid          = -INT_MAX;
+  findgrib->leveltype       = -INT_MAX;
+  findgrib->level1          = -INT_MAX;
+  findgrib->level2          = -INT_MAX;
+  findgrib->fcsttime1       = -INT_MAX;
+  findgrib->fcsttime2       = -INT_MAX;
+  findgrib->center_id       = -INT_MAX;
+  findgrib->subcenter_id    = -INT_MAX;
+  findgrib->parmtbl_version = -INT_MAX;
+  
+  return 1;
+}
+
+/****************************************************************************
+ * Returns the indices of all gribinfo entries that match the input date, 
+ * level, height, and parameter.
+ *
+ * Interface:
+ *   Input: 
+ *      gribinfo  - pointer to a previously populated gribinfo structure.  
+ *      initdate  -  initialization date in the form yyyymmdd[HHMMSS].  If any
+ *                  part of HHMMSS is not specified, it will be set to 0.
+ *      parmid    - the parameter id in the grib file
+ *      leveltype - the leveltype id from table 3/3a of the grib document.
+ *      level1    - First level of the data in units described by leveltype.
+ *      level2    - Second level of the data in units described by leveltype.
+ *      fcsttime1 - First forecast time in seconds.
+ *      fcsttime2 - Second forecast time in seconds.
+ *      indices   - an array of indices that match
+ *      num_indices - the number of matches and output indices
+ * 
+ *    Note: If an input variable is set set to -INT_MAX, then any value
+ *                will be considered a match.
+ *    Return:
+ *          The number of matching indices.
+ *
+ ***************************************************************************/
+
+int rg_get_indices(GribInfo *gribinfo, FindGrib *findgrib, int indices[])
+{
+  int gribnum;
+  int matchnum = 0;
+
+  for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+    if (compare_record(gribinfo, findgrib, gribnum) == 1) {
+      indices[matchnum] = gribnum;
+      matchnum++;
+    }    
+  }
+  return matchnum;
+}
+
+/*************************************************************************
+ *
+ * Returns an array of dates that correspond to particular input grib fields.
+ * The dates will be sorted so that the dates increase as the index increases.
+ *
+ * Interface:
+ *    Input:
+ *         gribinfo - pointer to a previously allocated gribinfo structure.  
+ *                    The gribinfo structure is filled in this function.
+ *         usParm_id: an array of parameter identifiers that could be
+ *                    used as a sea level pressure field (From table 2 of 
+ *                    grib documentation)
+ *         usLevel_id: the level id that could be used as a sea level pressure
+ *                    field (from table 3 of the grib documentation)
+ *         usHeight1: the height for the particular parameter and level
+ *                    (in units described by the parameter index)
+ *         numparms:  the number of parameters in each of the usParm_id, 
+ *                    usLevel_id, and usHeight1 arrays.
+ *    Output:
+ *         dates:     the dates for which the input fields are available.
+ *         
+ *            Note: Values in the input arrays, usParm_id, usLevel_id, and 
+ *                    usHeight with the same array index must correspond.
+ *
+ *    Return:
+ *          The number of dates found.
+ *************************************************************************/
+
+int rg_get_dates(GribInfo *gribinfo,int usParm_id[],int usLevel_id[],
+	      int usHeight1[],int numparms,int dates[],int century[],
+	      int indices[])
+{
+  int datenum=0;
+  int gribnum;
+  int parmindex;
+  int already_included;
+  int i,j;
+  int tmpval,tmpval2,tmpval3;
+
+  /* Get the dates for the given parameters */
+
+  for (parmindex = 0; parmindex < numparms; parmindex++) {
+    for (gribnum = 0; gribnum < gribinfo->num_elements; gribnum++) {
+      if ((gribinfo->elements[gribnum].usParm_id == usParm_id[parmindex]) &&
+	  (gribinfo->elements[gribnum].usLevel_id == usLevel_id[parmindex]) &&
+	  (gribinfo->elements[gribnum].usHeight1 == usHeight1[parmindex])) {
+	already_included = 0;
+	for (i = 0; i < datenum; i++){
+	  if ((dates[datenum] == gribinfo->elements[gribnum].date) && 
+	      (century[datenum] == gribinfo->elements[gribnum].century)) {
+	    already_included = 1;
+	    break;
+	  }
+	}
+	if (!already_included) {
+	  dates[datenum] = gribinfo->elements[gribnum].date;
+	  century[datenum] = gribinfo->elements[gribnum].century;
+	  indices[datenum] = gribnum;
+	  datenum++;
+	}
+      }
+    }
+  }
+
+  /* Sort the dates into increasing order */
+  for (j = 1; j < datenum; j++) {
+    tmpval = dates[j];
+    tmpval2 = indices[j];
+    tmpval3 = century[j];
+    for (i=j-1; i >= 0; i--) {
+      if (dates[i] <= tmpval) break;
+      dates[i+1] = dates[i];
+      indices[i+1] = indices[i];
+      century[i+1] = century[i];
+    }
+    dates[i+1] = tmpval;
+    indices[i+1] = tmpval2;
+    century[i+1] = tmpval3;
+  }
+
+  return datenum;
+}
+
+/****************************************************************************
+ * This function returns the pds, gds, bms, and bms_head section of the
+ * grib element
+ *
+ * Input:
+ *   gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *              gribinfo structure is filled in this function.
+ *   index - the index of the grib record to access as indexed by 
+ *           setup_gribinfo
+ *   
+ * Output:
+ *   *pds - a pointer to a structure holding the pds information
+ *   *gds - a pointer to a structure holding the gds information
+ *   *bms - a pointer to a structure holding the bms information
+ *   *bds_head - a pointer to a structure holding the binary data section
+ *             header information
+ *
+ ***************************************************************************
+ */
+int rg_get_grib_header(GribInfo *gribinfo, int index, PDS_INPUT *pds, 
+		    grid_desc_sec *gds,BMS_INPUT *bms)
+{
+  int xsize,ysize,j;
+  
+  memcpy(pds,gribinfo->elements[index].pds,sizeof(PDS_INPUT));
+  memcpy(gds,gribinfo->elements[index].gds,sizeof(grid_desc_sec));
+  memcpy(bms,gribinfo->elements[index].bms,sizeof(BMS_INPUT));
+  
+  /* Reset the dimensions for thinned grids */
+  if (gribinfo->elements[index].gds->head.thin != NULL) {
+    if (gds->head.thin != NULL) {
+      if ((gds->head.usData_type == LATLON_PRJ) || 
+	  (gds->head.usData_type == GAUSS_PRJ) ||
+	  (gds->head.usData_type == ROT_LATLON_PRJ) ||
+	  (gds->head.usData_type == ROT_GAUSS_PRJ) ||
+	  (gds->head.usData_type == STR_LATLON_PRJ) ||
+	  (gds->head.usData_type == STR_GAUSS_PRJ) ||
+	  (gds->head.usData_type == STR_ROT_LATLON_PRJ) ||
+	  (gds->head.usData_type == STR_ROT_GAUSS_PRJ)) {
+	ysize = gds->llg.usNj;
+      } else if (gds->head.usData_type == MERC_PRJ) {
+	ysize = gds->merc.rows;
+      } else if (gds->head.usData_type == POLAR_PRJ) {
+	ysize = gds->pol.usNy;
+      } else if ((gds->head.usData_type == LAMB_PRJ) ||
+		 (gds->head.usData_type == ALBERS_PRJ) ||
+		 (gds->head.usData_type == OBLIQ_LAMB_PRJ)) {
+	ysize = gds->lam.iNy;
+      }
+
+      xsize = 0;
+      for (j = 0; jhead.thin[j] > xsize) {
+	  xsize = gds->head.thin[j];
+	}
+      }
+      
+
+      if ((gds->head.usData_type == LATLON_PRJ) || 
+	  (gds->head.usData_type == GAUSS_PRJ) ||
+	  (gds->head.usData_type == ROT_LATLON_PRJ) ||
+	  (gds->head.usData_type == ROT_GAUSS_PRJ) ||
+	  (gds->head.usData_type == STR_LATLON_PRJ) ||
+	  (gds->head.usData_type == STR_GAUSS_PRJ) ||
+	  (gds->head.usData_type == STR_ROT_LATLON_PRJ) ||
+	  (gds->head.usData_type == STR_ROT_GAUSS_PRJ)) {
+	gds->llg.usNi = xsize;
+	gds->llg.iDi = abs(gds->llg.lLat2 - gds->llg.lLat1)/(xsize-1);
+      } else if (gds->head.usData_type == MERC_PRJ) {
+	gds->merc.cols = xsize;
+      } else if (gds->head.usData_type == POLAR_PRJ) {
+	gds->pol.usNx = xsize;
+      } else if ((gds->head.usData_type == LAMB_PRJ) ||
+		 (gds->head.usData_type == ALBERS_PRJ) ||
+		 (gds->head.usData_type == OBLIQ_LAMB_PRJ)) {
+	gds->lam.iNx = xsize;
+      }
+      
+    }
+  }
+  return 1;
+}
+
+/****************************************************************************
+ * This returns the index of the gribdata for paramaters which match the input
+ * parameters and for the date closest to the input targetdate.  If dates are
+ * not found either within hours_before or hours_after the time, then a missing
+ * value is returned.
+ *
+ * Interface:
+ *   Input:
+ *     gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                  gribinfo structure is filled in this function.
+ *     targetdate:  This is the date which dates in the grib data will be 
+ *                  compared to.  (format: integer yymmddhh)
+ *     hours_before: The maximum difference in time prior to the targetdate
+ *                  for which data should be searched for.
+ *     hours_after: The maximum difference in time after the targetdate for
+ *                  which data should be searched for.
+ *     usParm_id:   an array of parameter identifiers that could be
+ *                  used as a sea level pressure field (From table 2 of 
+ *                  grib documentation)
+ *     usLevel_id:  the level id that could be used as a sea level pressure
+ *                  field (from table 3 of the grib documentation)
+ *     usHeight1:   the height for the particular parameter and level
+ *                  (in units described by the parameter index)
+ *     numparms:    the number of parameters in each of the usParm_id, 
+ *                  usLevel_id, and usHeight1 arrays.
+ *   Return:
+ *     the index of the gribdata with a time closest to the target date.
+ *     -1 if there is no time within the input time limits.
+ * 
+ ****************************************************************************/
+int rg_get_index_near_date(GribInfo *gribinfo,char targetdate[STRINGSIZE],
+			int century,int hours_before,int hours_after,
+			int usParm_id[],int usLevel_id[],int usHeight1[],
+			int numparms)
+{
+  int dates[500],indices[500],centuries[500];
+  int date_before = MISSING;
+  int date_after = MISSING;
+  int century_before,century_after;
+  int date_diff_before = MISSING;
+  int date_diff_after = MISSING;
+  int index_before,index_after;
+  int numdates,datenum;
+  int index;
+  int itargetdate;
+
+  itargetdate = atoi(targetdate);
+
+  numdates = rg_get_dates(gribinfo,usParm_id,usLevel_id,usHeight1,numparms,
+			  dates,centuries,indices);
+  if (numdates <= 0) {
+    fprintf(stderr,"get_index_near_date: No dates were found\n");
+    return -1;
+  }
+  
+  for (datenum = 0; datenum < numdates; datenum++) {
+    if ((dates[datenum] > itargetdate) && (centuries[datenum] >= century)) {
+      century_after = centuries[datenum];
+      date_after = dates[datenum];
+      index_after = indices[datenum];
+      break;
+    } else {
+      century_before = centuries[datenum];
+      date_before = dates[datenum];
+      index_before = indices[datenum];
+    }
+  }
+  
+  if (date_after != MISSING)
+    date_diff_after = date_diff(date_after,century_after,itargetdate,century);
+  if (date_before != MISSING)
+    date_diff_before = 
+      date_diff(itargetdate,century,date_before,century_before);
+
+  if ((date_after != MISSING) && (date_before != MISSING)) {
+    if ((date_diff_after <= hours_after) && 
+	(date_diff_before <= hours_before)) {
+      if (date_diff_after < date_diff_before)
+	index = index_before;
+      else
+	index = index_after;
+    } else if (date_diff_after <= hours_after) {
+	index = index_after;
+    } else if (date_diff_before <= hours_before) {
+	index = index_before;
+    } else {
+      index = -1;
+    }
+  } else if (date_after != MISSING) {
+    if (date_diff_after <= hours_after)
+      index = index_after;
+    else 
+      index = -1;
+  } else if (date_before != MISSING) {
+    if (date_diff_before <= hours_before)
+      index = index_before;
+    else
+      index = -1;
+  } else {
+    index = -1;
+  }
+
+  return index;
+  
+}
+
+/*****************************************************************************
+ *
+ * returns valid time ( = init time + forecast time)
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *    index    - index number of record to get valid time from
+ *
+ * Output:
+ *    valid_time - yyyymmddhhmmss
+ *
+ * Return:
+ *    0 for success
+ *   -1 for error
+ *    
+ *****************************************************************************/
+int rg_get_valid_time(GribInfo *gribinfo, int index, char valid_time[])
+{
+  strcpy(valid_time, gribinfo->elements[index].valid_time);
+  return 0;
+}
+
+/*****************************************************************************
+ *
+ * returns generating center id
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *    index    - index number of record to get valid time from
+ *
+ * Return:
+ *    generating center id
+ *   -1 for error
+ *    
+ *****************************************************************************/
+int rg_get_center_id(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].center_id;
+}
+
+/*****************************************************************************
+ *
+ * returns parameter table version number
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *    index    - index number of record to get valid time from
+ *
+ * Return:
+ *    parameter table version number
+ *   -1 for error
+ *    
+ *****************************************************************************/
+int rg_get_parmtbl(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].parmtbl;
+}
+
+/*****************************************************************************
+ *
+ * returns generating process id
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *    index    - index number of record to get valid time from
+ *
+ * Return:
+ *    generating process id
+ *   -1 for error
+ *    
+ *****************************************************************************/
+int rg_get_proc_id(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].proc_id;
+}
+
+/*****************************************************************************
+ *
+ * returns sub center id
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *    index    - index number of record to get valid time from
+ *
+ * Return:
+ *    sub center id
+ *   -1 for error
+ *    
+ *****************************************************************************/
+int rg_get_subcenter_id(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].subcenter_id;
+}
+
+/**************************************************************************
+ *
+ * Interpolates grib grid data to a point location.
+ *
+ * Interface:
+ *     input: 
+ *       gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                  gribinfo structure is filled in this function.
+ *       index    - the index of gribinfo for which data is to be retrieved.
+ *                  the first grib record is number 1.
+ *       column   - the column of the point in grid coordinates (can be 
+ *                  floating point number).  leftmost column is 1.
+ *       row      - the row of the point in grid coordinates (can be 
+ *                  floating point number).  bottommost row is 1.
+ *
+ *    return:
+ *       on success - the interpolated value at the column,row location.
+ *       on failure - -99999
+ * 
+ ***************************************************************************/
+
+float rg_get_point(GribInfo *gribinfo, int index, float column, float row)
+{
+  int status;
+  GRIB_PROJECTION_INFO_DEF Proj;
+  BDS_HEAD_INPUT bds_head;
+  int dummy;
+  float **grib_out;
+  float y1, y2;
+  int numrows, numcols;
+  int top, left, right, bottom;
+  float outval;
+  
+  numrows = rg_get_numrows(gribinfo, index);
+  numcols = rg_get_numcols(gribinfo, index);
+
+  grib_out = (float **)alloc_float_2d(numrows,numcols);
+  if (grib_out == NULL) {
+    fprintf(stderr,"rg_get_point: Could not allocate space for grib_out\n");
+    return -99999;
+  }
+
+  status = rg_get_data(gribinfo, index, grib_out);
+  if (status < 0) {
+    fprintf(stderr,"rg_get_point: rg_get_data failed\n");
+    return -99999;
+  }
+
+  /* Do the interpolation here */
+  bottom = floor(row);
+  top = floor(row+1);
+  left = floor(column);
+  right = floor(column+1);
+  
+  y1 = (row - bottom) * (grib_out[top][left] - grib_out[bottom][left]) + 
+    grib_out[bottom][left];
+  y2 = (row - bottom) * (grib_out[top][right] - grib_out[bottom][right]) + 
+    grib_out[bottom][right];
+  outval = (y2 - y1) * (column - left) + y1;
+
+  free_float_2d(grib_out,numrows,numcols);
+
+  return outval;
+  
+}
+
+/**************************************************************************
+ *
+ * Interpolates grib grid data to a point location.
+ *
+ * Interface:
+ *     input: 
+ *       gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                  gribinfo structure is filled in this function.
+ *       index    - the index of gribinfo for which data is to be retrieved.
+ *                  the first grib record is number 1.
+ *     input and output:
+ *       pointdata- array of pointdata structures.  Only the column and
+ *                  row values in the structures need to be filled.  On
+ *                  output, the 'value' member of pointdata is filled.
+ *     input:
+ *       numpoints- number of pointdata structures in the array.
+ *
+ *    return:
+ *       on success - the interpolated value at the column,row location.
+ *       on failure - -99999
+ * 
+ ***************************************************************************/
+int rg_get_points(GribInfo *gribinfo, int index, PointData pointdata[], 
+		   int numpoints)
+{
+  int status;
+  float **grib_out;
+  float y1, y2;
+  int numrows, numcols;
+  int top, left, right, bottom;
+  float column, row;
+  int idx;
+
+  numrows = rg_get_numrows(gribinfo, index);
+  numcols = rg_get_numcols(gribinfo, index);
+
+  grib_out = (float **)alloc_float_2d(numrows,numcols);
+  if (grib_out == NULL) {
+    fprintf(stderr,"rg_get_points: Could not allocate space for grib_out\n");
+    return -99999;
+  }
+
+  status = rg_get_data(gribinfo, index, grib_out);
+  if (status < 0) {
+    fprintf(stderr,"rg_get_points: rg_get_data failed\n");
+    return -99999;
+  }
+
+  for (idx = 0; idx < numpoints; idx++) {
+
+    /* Change from 1 based to 0 based col/row */
+    row = pointdata[idx].row;
+    column = pointdata[idx].column;
+    
+    /* Do the interpolation here */
+    bottom = floor(row);
+    top = floor(row+1);
+    left = floor(column);
+    right = floor(column+1);
+    
+    y1 = (row - bottom) * (grib_out[top][left] - grib_out[bottom][left]) + 
+      grib_out[bottom][left];
+    y2 = (row - bottom) * (grib_out[top][right] - grib_out[bottom][right]) + 
+      grib_out[bottom][right];
+    pointdata[idx].value = (y2 - y1) * (column - left) + y1;
+
+  }
+
+  free_float_2d(grib_out,numrows,numcols);
+
+  return 1;
+}
+
+/**************************************************************************
+ *
+ * Remove an element from an array and decrease, by one, indices of all 
+ * elements with an index greater than the index of the element to remove.
+ *
+ * Interface:
+ *     input: 
+ *        array - the integer array to manipulate
+ *        index - the index of the element to remove
+ *        size - the number of elements in the array
+ *
+ ***************************************************************************/
+void remove_element(int array[],int index, int size)
+{
+  int j;
+  
+  for (j = index; j < size-1; j++) {
+    array[j] = array[j+1];
+  }
+
+}
+
+/****************************************************************************
+ * Advance the time by the input amount
+ *
+ * Interface:
+ *     Input: 
+ *         century - an integer value for the century (20 for 1900's)
+ *                   If the century is advanced, this value is advanced
+ *                   and output to the calling routine.
+ *         year - a 2 digit value for the year.
+ *         month - a 2 digit value for the month.
+ *         day - the day of the month
+ *         hour - the hour of the day
+ *         amount - the amount to advance the time by.
+ *         unit - the units for the amount.  These are values from table 4
+ *                of the grib manual.
+ *    return:
+ *         a date in the form yymmddhh
+ ****************************************************************************/
+
+int advance_time(int *century, int year, int month, int day, int hour,
+		 int amount, int unit)
+{
+  int daysinmonth[] = {31,28,31,30,31,30,31,31,30,31,30,31};
+  int date;
+
+  switch(unit) {
+  case 0:
+    hour += (int)((amount/60.)+0.5);
+    break;
+  case 1:
+    hour += amount;
+    break;
+  case 2:
+    day += amount;
+    break;
+  case 3:
+    month += amount;
+    break;
+  case 4:
+    year += amount;
+    break;
+  case 5:
+    year += 10*amount;
+    break;
+  case 6:
+    year += 30*amount;
+    break;
+  case 7:
+    year += 100*amount;
+    break;
+  case 10:
+    hour += 3*amount;
+    break;
+  case 11:
+    hour += 6*amount;
+    break;
+  case 12:
+    hour += 12*amount;
+    break;
+  case 50:
+    hour += (int)((amount/12.)+0.5);
+  case 254:
+    hour += (int)((amount/(60.*60.))+0.5);
+    break;
+  default:
+    fprintf(stderr,"WARNING: Could not advance time, incorrect unit: %d\n",
+	    unit);
+    return -1;
+  }
+
+  while (hour >= 24) {
+    day++;
+    hour -= 24;
+  }
+  while (month > 12) {
+    year++;
+    month -= 12;
+  }
+
+  /* if it is a leap year, change days in month for Feb now. */ 
+  if (isLeapYear(year)) daysinmonth[1] = 29;
+
+  while (day > daysinmonth[month-1]) {
+    day -= daysinmonth[month-1];
+    month++;
+    if (month > 12) {
+      year++;
+      month -= 12;
+      if (isLeapYear(year))
+	daysinmonth[1] = 29;
+      else
+	daysinmonth[1] = 28;
+    }
+  }
+
+  if (year > 100) {
+    (*century)++;
+  }
+
+  if (year >= 100) {
+    year -= 100;
+  }
+
+  date = hour*1 + day*100 + month*10000 + year*1000000;
+
+  return date;
+
+}
+/****************************************************************************
+ * Advance the time by the input amount
+ *
+ * Interface:
+ *     Input: 
+ *         startdate  - initialization date in the form yyyymmdd[HHMMSS].  If any
+ *                        part of HHMMSS is not specified, it will be set to 0.
+ *         amount     - the amount (in seconds) to advance the time by.
+ *
+ *    Output:
+ *         enddate[] - the time advanced to: yyyymmddHHMMSS format. 
+ *
+ *    Return:
+ *          1 - success
+ *         -1 - failure
+ *
+ ****************************************************************************/
+char *advance_time_str(char startdatein[], int amount, char enddate[])
+{
+  struct tm starttp;
+  struct tm endtp;
+  char startdate[15];
+  time_t time;
+
+  strcpy(startdate,startdatein);
+  while (strlen(startdate) < 14) {
+    strcpy(startdate+(strlen(startdate)),"0");
+  }
+
+  /* This forces all calculations to use GMT time */
+  putenv("TZ=GMT0");
+  tzset();
+
+  sscanf(startdate,"%4d%2d%2d%2d%2d%2d",&(starttp.tm_year),&(starttp.tm_mon),
+	 &(starttp.tm_mday),&(starttp.tm_hour),&(starttp.tm_min),
+	 &(starttp.tm_sec));
+  starttp.tm_mon -= 1;
+  starttp.tm_year -= 1900;
+  time = mktime(&starttp);
+  time += amount;
+  localtime_r(&time, &endtp);
+  strftime(enddate,15,"%Y%m%d%H%M%S",&endtp);
+  
+  return enddate;
+}
+
+/****************************************************************************
+ * Returns the difference in time in hours between date1 and date2 
+ * (date1-date2). 
+ * 
+ * Interface:
+ *   Input:
+ *     date1,date2:  dates in yymmddhh format (integers)
+ *     century1,century2: centuries for each date (20 for 1900's).
+ *   Return:
+ *     the difference in time between the first and second dates in hours.
+ ****************************************************************************/
+int date_diff(int date1,int century1,int date2,int century2)
+{
+  return (hours_since_1900(date1,century1) - 
+	   hours_since_1900(date2,century2));
+}
+
+/****************************************************************************
+ * Returns the number of hours since Jan 1, at 00:00 1900.
+ * 
+ * Interface:
+ *   Input:
+ *     date:    integer in form yymmddhh
+ *     century: 2 digit century (20 for 1900's)
+ *   Return:
+ *     the number of hours since 00:00 Jan1, 1900.
+ *
+ ****************************************************************************/
+int hours_since_1900(int date,int century)
+{
+  int daysinmonth[] = {31,28,31,30,31,30,31,31,30,31,30,31};
+  int hour,day,month,year;
+  int days_since_1900 = 0;
+  int i;
+
+  hour = date%100;
+  day = (date%10000)/100;
+  month = (date%1000000)/10000;
+  year = (date%100000000)/1000000;
+
+  days_since_1900 += day;
+  
+  if (isLeapYear((century-1)*100 + year))
+    daysinmonth[1] = 29;
+  else 
+    daysinmonth[1] = 28;
+  
+  for (i = 0; i < (month - 1); i++)
+    days_since_1900 += daysinmonth[i];
+
+  for (i=0; i < (year + ((century - 20)*100) - 1); i++) {
+    if (isLeapYear((century - 1)*100 + year))
+      days_since_1900 += 366;
+    else
+      days_since_1900 += 365;
+  }
+
+  return days_since_1900*24 + hour;
+
+}
+
+/****************************************************************************
+ *
+ * Returns true if the input year is a leap year, otherwise returns false
+ *
+ ****************************************************************************/
+int isLeapYear(int year)
+{
+  if ( (((year % 4) == 0) && ((year % 100) != 0)) 
+       || ((year % 400) == 0) ) 
+    return 1;
+  else
+    return 0;
+						  
+}
+
+/*****************************************************************************
+ *
+ * Returns the number of grib elements (gribinfo->num_elements) processsed
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *   the number of elements in the gribinfo structure
+ ****************************************************************************/
+
+int rg_num_elements(GribInfo *gribinfo){
+
+  return gribinfo->num_elements;
+
+}
+
+/*****************************************************************************
+ *
+ * Deallocates the elements in the gribinfo structure and closes the files.
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ *****************************************************************************/
+void rg_free_gribinfo_elements(GribInfo *gribinfo)
+{
+  int i;
+  
+  for (i=0; inum_elements; i++) {
+    free(gribinfo->elements[i].pds);
+    free(gribinfo->elements[i].gds);
+    free(gribinfo->elements[i].bms);
+    free(gribinfo->elements[i].bds_head);
+    fclose(gribinfo->elements[i].fp);
+  }
+  free(gribinfo->elements);
+}
+
+/*****************************************************************************
+ *
+ * Returns the value for level1 (gribinfo->usHeight1)
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *   value for level1
+ ****************************************************************************/
+
+int rg_get_level1(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].usHeight1;
+}
+
+/*****************************************************************************
+ *
+ * Returns the value for level2 (gribinfo->usHeight2)
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *   value for level1
+ ****************************************************************************/
+
+int rg_get_level2(GribInfo *gribinfo, int index)
+{
+  return gribinfo->elements[index].usHeight2;
+}
+
+/*****************************************************************************
+ *
+ * returns number of rows in grid
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    number of rows in grid
+ *****************************************************************************/
+int rg_get_numrows(GribInfo *gribinfo,int index)
+{
+  if ((gribinfo->elements[index].gds->head.usData_type == LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == ROT_LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == ROT_GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_ROT_LATLON_PRJ)|| 
+      (gribinfo->elements[index].gds->head.usData_type == STR_ROT_GAUSS_PRJ)) 
+    {
+    return gribinfo->elements[index].gds->llg.usNj;
+  } else if (gribinfo->elements[index].gds->head.usData_type == MERC_PRJ) {
+    return gribinfo->elements[index].gds->merc.rows;
+  } else if (gribinfo->elements[index].gds->head.usData_type == LAMB_PRJ) {
+    return gribinfo->elements[index].gds->lam.iNy;
+  } else if (gribinfo->elements[index].gds->head.usData_type == POLAR_PRJ) {
+    return gribinfo->elements[index].gds->pol.usNy;
+  }
+
+}
+/*****************************************************************************
+ *
+ * returns number of columns in grid
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    number of columns in grid
+ *****************************************************************************/
+int rg_get_numcols(GribInfo *gribinfo,int index)
+{
+  if ((gribinfo->elements[index].gds->head.usData_type == LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == ROT_LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == ROT_GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_LATLON_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_GAUSS_PRJ) || 
+      (gribinfo->elements[index].gds->head.usData_type == STR_ROT_LATLON_PRJ)|| 
+      (gribinfo->elements[index].gds->head.usData_type == STR_ROT_GAUSS_PRJ)) 
+    {
+      return gribinfo->elements[index].gds->llg.usNi;
+  } else if (gribinfo->elements[index].gds->head.usData_type == MERC_PRJ) {
+    return gribinfo->elements[index].gds->merc.cols;
+  } else if (gribinfo->elements[index].gds->head.usData_type == LAMB_PRJ) {
+    return gribinfo->elements[index].gds->lam.iNx;
+  } else if (gribinfo->elements[index].gds->head.usData_type == POLAR_PRJ) {
+    return gribinfo->elements[index].gds->pol.usNx;
+  }
+
+}
+/*****************************************************************************
+ *
+ * returns the offset (in bytes) from the beginning of the file.
+ *
+ * Input:
+ *    gribinfo - pointer to a filled gribinfo structure.
+ *
+ * Return:
+ *    offset (in bytes) from beginning of file
+ *****************************************************************************/
+int rg_get_offset(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].offset;
+}
+/*****************************************************************************
+ *
+ * returns the grib record ending position (in bytes) from the beginning of 
+ *    the file.
+ *
+ * Input:
+ *    gribinfo - pointer to a filled gribinfo structure.
+ *
+ * Return:
+ *    position (in bytes) of the end of the grib record within the file.
+ *****************************************************************************/
+int rg_get_end(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].end;
+}
+/*****************************************************************************
+ *
+ * returns grib id of input grid
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    grib id of input grid
+ *****************************************************************************/
+int rg_get_gridnum(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].pds->usGrid_id;
+}
+/*****************************************************************************
+ *
+ * returns date
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    date (yymmddhh) in integer type
+ *****************************************************************************/
+int rg_get_date(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].date;
+}
+/*****************************************************************************
+ *
+ * returns century
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    century in integer type
+ *****************************************************************************/
+int rg_get_century(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].century;
+}
+/*****************************************************************************
+ *
+ * returns forecast time
+ *
+ * Input:
+ *    gribinfo - pointer to a previously allocated gribinfo structure.  The 
+ *                 gribinfo structure is filled in this function.
+ *
+ * Return:
+ *    forecast time in units described by usFcst_unit_id
+ *****************************************************************************/
+int rg_get_forecast_time(GribInfo *gribinfo,int index)
+{
+  return gribinfo->elements[index].pds->usP1;
+}
+
+/*****************************************************************************
+ *
+ * reads the gribmap file, and stores the information in the GribParameters
+ *    structure.
+ *
+ * Input:
+ *   gribmap - pointer to a previously allocated GribParameters structure.  
+ *              The gribmap structure is filled in this function.
+ *   file - the name of the gribmap file to read.
+ *
+ *   Return:
+ *      1  - successful call to setup_gribinfo
+ *     -1 - call to setup_gribinfo failed
+ *
+ *****************************************************************************/
+int rg_setup_gribmap(GribParameters *gribmap, char filename[])
+{
+  FILE *fid;
+  char line[500];
+  int id, center, subcenter, table;
+  int idx;
+  
+  fid = fopen(filename,"r");
+  if (fid == NULL)
+    {
+      fprintf(stderr,"Could not open %s\n",filename);
+      return -1;
+    }
+
+  gribmap->parms = (GribTableEntry *)malloc(sizeof(GribTableEntry));
+
+  idx = 0;
+  while (fgets(line,500,fid) != NULL)
+    {
+      /* Skip over comments at begining of gribmap file */
+      if (line[0] == '#') continue;
+
+      sscanf(line,"%d:",&id);
+      if (id == -1) 
+	{
+	  sscanf(line,"%d:%d:%d:%d",&id,¢er,&subcenter,&table);
+	} 
+      else
+	{
+	  gribmap->parms = 
+	    (GribTableEntry *)realloc(gribmap->parms,
+					(idx+1)*sizeof(GribTableEntry));
+	  gribmap->parms[idx].center = center;
+	  gribmap->parms[idx].subcenter = subcenter;
+	  gribmap->parms[idx].table = table;
+	  sscanf(line,"%d:%[^:]:%[^:]",&(gribmap->parms[idx].parmid),
+		 gribmap->parms[idx].name,
+		 gribmap->parms[idx].comment);
+	  idx++;
+	}
+    }
+
+
+  gribmap->num_entries = idx;
+
+  close(fid);
+  return 1;
+}
+
+/*****************************************************************************
+ *
+ * finds the gribmap entry described by  the gribmap file, and stores the information in the GribParameters
+ *    structure.
+ *
+ * Input:
+ *   gribmap - pointer to structure that was filled by a call to 
+ *             rg_setup_gribmap
+ *   table   - if set to -1, the first table the valid name will be used.
+ *             Otherwise, the table id must match as well.
+ *   name    - name of the parameter to find.
+ * Output
+ *   gribmap_parms - pointer to GribTableEntry structure containing 
+ *             information about the parameter that was found.
+ *
+ *   Return:
+ *      1  - successful call to setup_gribinfo
+ *     -1 - call to setup_gribinfo failed
+ *
+ *****************************************************************************/
+int rg_gribmap_parameter(GribParameters *gribmap, char name[], int table,
+			 GribTableEntry *gribmap_parms)
+{
+  int idx;
+  int found;
+
+  found = 0;
+  for (idx = 0; idx < gribmap->num_entries; idx++) 
+    {
+      
+      if (strcmp(gribmap->parms[idx].name,name) == 0)
+	{
+	  if ((table == -1) || (table == gribmap->parms[idx].table))
+	    {
+	      /* We found a match! */
+	      found = 1;
+	      break;
+	    }
+	}
+    }
+  
+  if (found) 
+    {
+      memcpy(gribmap_parms,&(gribmap->parms[idx]),sizeof(GribTableEntry));
+      return 1;
+    }
+  else
+    {
+      return -1;
+    }
+}
+
+/*****************************************************************************
+ *
+ * Deallocates the elements in the gribmap structure.
+ *
+ * Input:
+ *    gribmap - pointer to a previously allocated gribmap structure.  The 
+ *                 gribmap structure is filled in this function.
+ *
+ *****************************************************************************/
+void rg_free_gribmap_elements(GribParameters *gribmap)
+{
+  free(gribmap->parms);
+}
+
+/*****************************************************************************
+ *
+ * Compares the elements in a findgrib structure with the elements in the
+ *   gribinfo structure for the input index.  If they match, returns 1, 
+ *   otherwise, returns 0.
+ *
+ * Input:
+ *    gribinfo
+ *    findgrib
+ *    index    - the index of the grib record in gribinfo to compare to.
+ *
+ *****************************************************************************/
+int compare_record(GribInfo *gribinfo, FindGrib *findgrib, int gribnum)
+{
+
+  /* 
+   *  Note (6/20/05): This searching is very inefficient. We may need to 
+   *   improve this, since, for WRF, when searching through boundary data, 
+   *   each search is slower that the previous, since the record to be 
+   *   found turns out to be farther into the list.
+   */
+  
+  int retval = 0;
+
+  if ((findgrib->center_id == -INT_MAX) || 
+      findgrib->center_id == gribinfo->elements[gribnum].center_id) {
+    if ((findgrib->subcenter_id == -INT_MAX) ||
+	findgrib->subcenter_id == gribinfo->elements[gribnum].subcenter_id) {
+      if ((findgrib->parmtbl_version == -INT_MAX) || 
+	  findgrib->parmtbl_version == gribinfo->elements[gribnum].parmtbl) {
+	if ((strcmp(findgrib->initdate,"*") == 0) || 
+	    (strncmp(gribinfo->elements[gribnum].initdate,findgrib->initdate,
+		     strlen(findgrib->initdate)) == 0)) {
+	  if ((strcmp(findgrib->validdate,"*") == 0) || 
+	      (strncmp(gribinfo->elements[gribnum].valid_time,
+		       findgrib->validdate,
+		       strlen(findgrib->validdate)) == 0)) {
+	    if ((findgrib->parmid == -INT_MAX) || 
+		(findgrib->parmid == 
+		 gribinfo->elements[gribnum].usParm_id)) {
+	      if ((findgrib->leveltype == -INT_MAX) || 
+		  (findgrib->leveltype == 
+		   gribinfo->elements[gribnum].usLevel_id)) {
+		if ((findgrib->level1 == -INT_MAX) || 
+		    (findgrib->level1 == 
+		     gribinfo->elements[gribnum].usHeight1)) {
+		  if ((findgrib->level2 == -INT_MAX) || 
+		      (findgrib->level2 == 
+		       gribinfo->elements[gribnum].usHeight2)) {
+		    if ((findgrib->fcsttime1 == -INT_MAX) || 
+			(findgrib->fcsttime1 == 
+			 gribinfo->elements[gribnum].fcsttime1)) {
+		      if ((findgrib->fcsttime2 == -INT_MAX) || 
+			  (findgrib->fcsttime2 == 
+			   gribinfo->elements[gribnum].fcsttime2)) {
+			retval = 1;
+		      }
+		    }
+		  }
+		}
+	      }
+	    }
+	  }
+	}
+      }
+    }
+  }
+
+  return retval;
+}
+
+
+/*****************************************************************************
+ *
+ * returns the multiplication factor to convert grib forecast times to 
+ *   seconds.
+ *
+ * Input: 
+ *    unit_id  - grib forecast unit id, from Table 4.
+ *
+ * Return:
+ *    conversion factor
+ *****************************************************************************/
+int get_factor2(int unit)
+{
+  int factor;
+  
+  switch (unit) {
+  case 0:
+    factor = 60;
+    break;
+  case 1:
+    factor = 60*60;
+    break;
+  case 2:
+    factor = 60*60*24;
+    break;
+  case 10:
+    factor = 60*60*3;
+    break; 
+  case 11:
+    factor = 60*60*3;
+    break;
+  case 12:
+    factor = 60*60*12;
+    break;
+  case 50:
+    /* This is a WSI (non-standard) time unit of 5 minutes */
+    factor = 5*60;
+    break;
+  case 254:
+    factor = 1;
+    break;
+  default:
+    fprintf(stderr,"Invalid unit for forecast time: %d\n",unit);
+    factor = 0;
+  }
+  return factor;
+}
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.h b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.h
new file mode 100644
index 00000000..f2c628b6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.h
@@ -0,0 +1,169 @@
+#define STRINGSIZE 160
+
+/* The value used to fill missing data points */
+#define FILL_VALUE -9999999.
+
+typedef struct {
+  int usGrid_id;
+  int usParm_id;
+  int usLevel_id;
+  int usHeight1;
+  int usHeight2;
+  int offset;
+  int end;
+  char filename[200];
+  FILE *fp;
+  char initdate[15];
+  char valid_time[15];
+  int date;
+  int century;
+  int fcsttime1;
+  int fcsttime2;
+  int center_id;
+  int parmtbl;
+  int proc_id;
+  int subcenter_id;
+  PDS_INPUT *pds;
+  grid_desc_sec *gds;
+  BMS_INPUT *bms;
+  BDS_HEAD_INPUT *bds_head;  
+} Elements;
+
+typedef struct {
+  int num_elements;
+  Elements *elements;
+} GribInfo;
+
+typedef struct {
+  char initdate[100];
+  char validdate[100];
+  int parmid;
+  int leveltype;
+  int level1;
+  int level2;
+  int fcsttime1;
+  int fcsttime2;
+  int center_id;
+  int subcenter_id;
+  int parmtbl_version;
+} FindGrib;
+
+typedef struct {
+  int center;
+  int subcenter;
+  int table;
+  int parmid;
+  char name[STRINGSIZE];
+  char comment[STRINGSIZE];
+} GribTableEntry;
+
+typedef struct {
+  int num_entries;
+  GribTableEntry *parms;
+} GribParameters;
+
+typedef struct {
+  float column;
+  float row;
+  float value;
+  char id[20];
+} PointData;
+
+typedef struct {
+  char prjnmm[24], stordsc[24];
+  int colcnt, rowcnt;
+  float origlat, origlon, origx, origy;
+  float xintdis, yintdis, parm1, parm2, parm3;
+} GRIB_PROJECTION_INFO_DEF;
+
+/* Public function definitions */
+
+int rg_setup_gribmap(GribParameters *gribmap, char file[]);
+int rg_gribmap_parameter(GribParameters *gribmap, char name[], int table,
+			 GribTableEntry *gribmap_parms);
+void rg_free_gribmap_elements(GribParameters *gribmap);
+
+int rg_setup_gribinfo(GribInfo *gribinfo, char files[][STRINGSIZE],
+		      int use_fcst);
+int rg_setup_gribinfo_f(GribInfo *gribinfo, FILE *fp, int use_fcst);
+int rg_setup_gribinfo_i(GribInfo *gribinfo, int fid, int use_fcst);
+
+int rg_get_index(GribInfo *gribinfo, FindGrib *find_grib);
+
+int rg_get_index_guess(GribInfo *gribinfo, FindGrib *findgrib, int guess_index);
+
+int rg_get_indices(GribInfo *gribinfo, FindGrib *find_grib, int *indices);
+
+int rg_init_findgrib(FindGrib *findgrib);
+
+int rg_get_grib_header(GribInfo *gribinfo, int index, PDS_INPUT *pds, 
+		    grid_desc_sec *gds,BMS_INPUT *bms);
+
+int rg_num_elements(GribInfo *gribinfo);
+
+void rg_free_gribinfo_elements(GribInfo *gribinfo);
+
+int rg_get_numrows(GribInfo *gribinfo,int index);
+
+int rg_get_numcols(GribInfo *gribinfo,int index);
+
+int rg_get_level1(GribInfo *gribinfo, int index);
+
+int rg_get_level2(GribInfo *gribinfo, int index);
+
+int rg_get_center_id(GribInfo *gribinfo, int index);
+
+int rg_get_subcenter_id(GribInfo *gribinfo, int index);
+
+int rg_get_proc_id(GribInfo *gribinfo, int index);
+
+int rg_get_tblversion(GribInfo *gribinfo, int index);
+
+float rg_get_point(GribInfo *gribinfo, int index, float column, float row);
+
+int rg_get_points(GribInfo *gribinfo, int index, PointData *pointdata, 
+		    int numpoints);
+
+int rg_get_offset(GribInfo *gribinfo, int index);
+
+int rg_get_end(GribInfo *gribinfo, int index);
+
+int rg_get_valid_time(GribInfo *gribinfo, int index, char valid_time[]);
+
+int rg_get_data(GribInfo *gribinfo, int index, float **data);
+
+int rg_get_data_1d(GribInfo *gribinfo, int index, float *data);
+
+int rg_write_grib(PDS_INPUT *pds, grid_desc_sec *gds, char filename[],
+		  float **data);
+int rg_fwrite_grib(PDS_INPUT *pds, grid_desc_sec *gds, float **data, 
+		   FILE *fid);
+
+
+
+/* The following are public functions also.  However, the interface to many
+ *   of them needs to be reworked.  For example, it is not possible to specify
+ *   a secondary height or forecast time with many of them.
+ * Note: As of 11/11/04, the functions listed above have already been reworked.
+ */
+
+int rg_get_pressure_levels(GribInfo *gribinfo, int dates[], int centuries[], 
+			int parm_id[], int finallevels[],int min_pres,
+			int numparms);
+int rg_get_msl_indices(GribInfo *gribinfo, char dates[][STRINGSIZE],
+		    int centuries[], int usParm_id[],int usLevel_id[],
+		    int usHeight1[],int infactor[],int numparms,
+		    int grib_index[],int outfactor[]);
+int rg_get_grib(GribInfo *gribinfo, int index,int scale,
+	     float **grib_out,int *vect_comp_flag, 
+	     GRIB_PROJECTION_INFO_DEF *Proj, BDS_HEAD_INPUT *bds_head);
+int rg_get_dates(GribInfo *gribinfo,int usParm_id[],int usLevel_id[],
+	      int usHeight1[],int numparms,int dates[],int century[],
+	      int indices[]);
+int rg_get_index_near_date(GribInfo *gribinfo,char targetdate[STRINGSIZE],
+			int century,int hours_before,int hours_after,
+			int usParm_id[],int usLevel_id[],int usHeight1[],
+			int numparms);
+int rg_get_date(GribInfo *gribinfo,int index);
+int rg_get_century(GribInfo *gribinfo,int index);
+int rg_get_forecast_time(GribInfo *gribinfo,int index);
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/test_advance_time_str.c b/wrfv2_fire/external/io_grib1/grib1_util/test_advance_time_str.c
new file mode 100644
index 00000000..9388692f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/test_advance_time_str.c
@@ -0,0 +1,13 @@
+#include 
+#include 
+#include "grib.h"
+#include "read_grib.h"
+
+main(argc,argv)
+int argc;
+char *argv[];
+{
+  char enddate[15];
+  advance_time_str("200509081200",-243,enddate);
+  fprintf(stderr,"advanced to %s\n",enddate);
+}
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/test_rg_gribmap.c b/wrfv2_fire/external/io_grib1/grib1_util/test_rg_gribmap.c
new file mode 100644
index 00000000..5e79105a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/test_rg_gribmap.c
@@ -0,0 +1,36 @@
+#include 
+#include 
+#include "grib.h"
+#include "read_grib.h"
+
+main(argc,argv)
+int argc;
+char *argv[];
+{
+
+  GribParameters gribmap;
+  GribTableEntry entry;
+
+  char infile[] = "/home/tahutchinson/projects/venture/config/grib/gribmap.txt";
+  int status;
+
+  /*
+   * This function indexes the grib file and fills the gribinfo
+   *  structure.  It needs to be called before any other
+   *  rg_ functions.
+   */
+  status = rg_setup_gribmap(&gribmap,infile);
+
+  status = rg_gribmap_parameter(&gribmap,"UGRD",-1,&entry);
+  fprintf(stderr,"%d %d %d %d %s %s\n",
+	  entry.center, entry.subcenter, entry.table, entry.parmid, 
+	  entry.name, entry.comment);
+
+  status = rg_gribmap_parameter(&gribmap,"BouPTYPE",204,&entry);
+  fprintf(stderr,"%d %d %d %d %s %s\n",
+	  entry.center, entry.subcenter, entry.table, entry.parmid, 
+	  entry.name, entry.comment);
+
+  rg_free_gribmap_elements(&gribmap);
+
+}
diff --git a/wrfv2_fire/external/io_grib1/grib1_util/write_grib.c b/wrfv2_fire/external/io_grib1/grib1_util/write_grib.c
new file mode 100644
index 00000000..79dd9563
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/grib1_util/write_grib.c
@@ -0,0 +1,190 @@
+/*
+ *****************************************************************************
+ * rg_write_grib - function which encapsulates parts of the MEL grib library
+ *              writing routines.  
+ *
+ * Todd Hutchinson
+ * TASC
+ * tahutchinson@tasc.com
+ * (781)942-2000 x3108
+ * 7/1/99
+ *
+ * Interface:
+ *   Input:
+ *     pds -      a pointer to a structure which stores information about the 
+ *                grib product definition section.
+ *     gds -      a pointer to a structure which stores information about the 
+ *                grib grid definition section.
+ *     filename - This is the output grib file which will be created if 
+ *                it does not already exist.  If this file already exists,
+ *                grib records will be appended to it.
+ *     data -     a 2-d array holding the values at grid points for the grid
+ *                that is to be output.
+ *   Return:
+ *     1 for success
+ *    -1 for failure
+ *
+ *   Caveats:   This function only supports a "latlon" grid
+ *              currently, this is equivalent to a cylindrical equidistant
+ *              projection.
+ *
+ ***************************************************************************
+ */
+
+#include 
+#include 
+#include "gribfuncs.h"
+
+int rg_write_grib(PDS_INPUT *pds, grid_desc_sec *gds, char filename[],
+	       float **data)
+{
+  char tmpfile[240];
+  char tmpstring[240];
+  FILE *fid;
+  int status;
+
+  sprintf(tmpfile,"/tmp/tmpgribfile_%d",getpid());
+  fid = fopen(tmpfile,"wb");
+  if (fid == NULL) {
+    fprintf(stderr,"rg_write_grib: Could not open %s\n",tmpfile);
+    return -1;
+  }
+
+  status = rg_fwrite_grib(pds,gds,data,fid);
+  if (status != 1)
+    {
+      fprintf(stderr,"rg_write_grib: rg_fwrite_grib failed\n");
+      return -1;
+    }
+  
+  /* append tmpfile to filename */
+  sprintf(tmpstring,"cat %s >> %s",tmpfile,filename);
+  system(tmpstring);
+  unlink(tmpfile);
+ 
+  close(fid);
+
+  return(1);
+}
+
+int rg_fwrite_grib(PDS_INPUT *pds, grid_desc_sec *gds, float **data, FILE *fid)
+{
+
+  GRIB_HDR *gh=NULL;
+  DATA_INPUT data_input;
+  GEOM_IN geom_in;
+  USER_INPUT user_input;
+  char errmsg[240];
+  float *data_one_d;
+  int status;
+  int i,j;
+
+  if ((gds->head.usData_type == LATLON_PRJ) || 
+      (gds->head.usData_type == GAUSS_PRJ)) {
+    if (gds->head.usData_type == GAUSS_PRJ) {
+      strcpy(geom_in.prjn_name,"gaussian");
+    } else {
+      strcpy(geom_in.prjn_name,"spherical");
+    }
+    geom_in.nx = gds->llg.usNi;
+    geom_in.ny = gds->llg.usNj;
+    geom_in.parm_1 = (gds->llg.iDj)/1000.;
+    geom_in.parm_2 = (gds->llg.iDi)/1000.;
+    geom_in.first_lat = gds->llg.lLat1/1000.;
+    geom_in.first_lon = gds->llg.lLon1/1000.;
+    geom_in.last_lat = gds->llg.lLat2/1000.;
+    geom_in.last_lon = gds->llg.lLon2/1000.;
+    geom_in.scan = gds->llg.usScan_mode;
+    geom_in.usRes_flag = gds->llg.usRes_flag;
+  } else if (gds->head.usData_type == LAMB_PRJ) {
+    strcpy(geom_in.prjn_name,"lambert");
+    geom_in.nx = gds->lam.iNx;
+    geom_in.ny = gds->lam.iNy;
+    geom_in.x_int_dis = gds->lam.ulDx/1000.;
+    geom_in.y_int_dis = gds->lam.ulDy/1000.;
+    geom_in.parm_1 = (gds->lam.lLat_cut2)/1000.;
+    geom_in.parm_2 = (gds->lam.lLat_cut1)/1000.;
+    geom_in.parm_3 = (gds->lam.lLon_orient)/1000.;
+    geom_in.first_lat = gds->lam.lLat1/1000.;
+    geom_in.first_lon = gds->lam.lLon1/1000.;
+    geom_in.scan = gds->lam.usScan_mode;
+    geom_in.usRes_flag = gds->lam.usRes_flag;    
+  } else {
+    fprintf(stderr,"rg_fwrite_grib: invalid input projection %d\n",
+	    gds->head.usData_type);
+    return -1;
+  }
+
+  data_input.usProc_id = pds->usProc_id;
+  data_input.usGrid_id = pds->usGrid_id;
+  data_input.usParm_id = pds->usParm_id;
+  data_input.usParm_sub_id = pds->usCenter_sub;
+  data_input.usLevel_id = pds->usLevel_id;
+  data_input.nLvl_1 = pds->usHeight1;
+  data_input.nLvl_2 = pds->usHeight2;
+  data_input.nYear = pds->usYear + (pds->usCentury-1)*100;
+  data_input.nMonth = pds->usMonth;
+  data_input.nDay = pds->usDay;
+  data_input.nHour = pds->usHour;
+  data_input.nMinute = pds->usMinute;
+  data_input.nSecond = 0;
+  data_input.usFcst_id = pds->usFcst_unit_id;
+  data_input.usFcst_per1 = pds->usP1;
+  data_input.usFcst_per2 = pds->usP2;
+  data_input.usTime_range_id = pds->usTime_range;
+  data_input.usTime_range_avg = pds->usTime_range_avg;
+  data_input.usTime_range_mis = pds->usTime_range_mis;
+  /* We add an extra digit here, because the grib library seems to cut off
+   *   one more than I would prefer.
+   */
+  data_input.nDec_sc_fctr = pds->sDec_sc_fctr+1;
+
+  user_input.chCase_id='0';
+  user_input.usParm_tbl=pds->usParm_tbl;
+  user_input.usSub_tbl=pds->usSub_tbl;
+  /*
+  user_input.usCenter_id=190;
+  */
+  user_input.usCenter_id = pds->usCenter_id;
+  user_input.usCenter_sub=pds->usCenter_sub;
+  user_input.usTrack_num=0;
+  user_input.usGds_bms_id = 128;
+  user_input.usBDS_flag=0;
+  user_input.usBit_pack_num=0;
+
+ 
+  data_one_d = (float *)calloc(geom_in.nx*geom_in.ny,sizeof(float));
+  if (data_one_d == NULL) {
+    fprintf(stderr,"rg_fwrite_grib: could not allocate space for data_one_d\n");
+    return -1;
+  }
+
+  for (i=0; i
+#include 
+#include "gribmap.h"
+
+/******************************************************************************
+ *
+ * The functions in this file are used for opening/reading, and searching for
+ *   information in a grib table.
+ *
+ * All functions return 0 for success and 1 for failure, unless otherwise 
+ *   noted.
+ *****************************************************************************/
+
+int findchar(char *line, char thechar);
+
+#ifdef TEST
+int main()
+{
+  Grib1_Tables grib_tables;
+  char filename[300];
+  int parm_id;
+  int ret;
+  int tablenum;
+  int center,subcenter,parmtbl;
+  
+  strcpy(filename,"gribmap.txt");
+  LOAD_GRIB1_TABLES(filename, &grib_tables, &ret);
+
+  GET_GRIB_PARAM (&grib_tables, "TSK", ¢er,&subcenter,&parmtbl,
+		  &tablenum, &parm_id);
+  fprintf(stderr,"got parm_id: %d center: %d subcenter: %d parmtbl: %d\n",
+	  parm_id,center,subcenter,parmtbl);
+
+}
+#endif
+
+/******************************************************************************
+ *
+ * read_gribmap - reads a gribmap file and puts the information into the 
+ *                 grib_table_info structure.
+ *
+ ******************************************************************************/
+
+int READ_GRIBMAP (char *filename, Grib1_Tables *grib_tables, int *ret)
+{
+
+  FILE *mapptr;
+  char line[MAX_LINE_CHARS];
+  int dummy;
+  int parmidx;
+  int nxtidx, elemidx, charidx;
+  char elems[6][MAX_LINE_CHARS];
+  int tablenum;
+
+  /* Open parameter table file */
+  mapptr = fopen(filename, "r");
+  if (mapptr == NULL)
+    {
+      fprintf(stderr,"Could not open %s\n",filename);
+      *ret=1;
+      return 1;
+    }
+
+  /* Skip over comments at begining of gribmap file */
+  while (fgets(line,500,mapptr))
+    {
+      if (line[0] != '#') break;
+    }
+
+  tablenum = 0;
+  grib_tables->num_tables = 1;
+  grib_tables->grib_table_info = 
+    (Grib1_Table_Info *)calloc(1,sizeof(Grib1_Table_Info));
+
+  if (grib_tables->grib_table_info == NULL)
+    {
+      fprintf(stderr,"Could not allocate space for grib_table_info\n");
+      *ret = 1;
+      return 1;
+    }
+  grib_tables->grib_table_info[tablenum].num_entries = 0;
+
+  sscanf(line,"%d:%d:%d:%d",&dummy,
+	 &(grib_tables->grib_table_info[tablenum].center),
+	 &(grib_tables->grib_table_info[tablenum].subcenter),
+	 &(grib_tables->grib_table_info[tablenum].parmtbl));
+
+  /* 
+   * Read each line of parameter table, and store information in the
+   *   structure.
+   */
+  while (fgets(line,MAX_LINE_CHARS,mapptr) != NULL) 
+    {
+      /* Split up the elements that are seperated by : */
+      nxtidx = 0;
+      elemidx = 0;
+      while ((charidx = findchar(line + nxtidx,':')) >= 0)
+	{
+	  strncpy(elems[elemidx],line + nxtidx,charidx);
+	  elems[elemidx][charidx] = '\0';
+	  elemidx++;
+	  nxtidx += (charidx + 1);
+	}
+
+      parmidx = atoi(elems[0]);
+
+      /* 
+       * Check to see if this line specifies the next grib table.  If so,
+       *   break out
+       */
+      if (parmidx == -1) {
+	grib_tables->num_tables++;
+	tablenum++;
+	grib_tables->grib_table_info = 
+	  (Grib1_Table_Info *)
+	  realloc(grib_tables->grib_table_info,
+		  grib_tables->num_tables*sizeof(Grib1_Table_Info));
+	
+	if (grib_tables->grib_table_info == NULL)
+	  {
+	    fprintf(stderr,
+		    "Could not re-allocate space for grib_table_info\n");
+	    *ret = 1;
+	    return 1;
+	  }
+	grib_tables->grib_table_info[tablenum].num_entries = 0;
+	sscanf(line,"%d:%d:%d:%d",&dummy,
+	       &(grib_tables->grib_table_info[tablenum].center),
+	       &(grib_tables->grib_table_info[tablenum].subcenter),
+	       &(grib_tables->grib_table_info[tablenum].parmtbl));
+	continue;
+      }
+
+      /* Assure that we have not gone beyond 256 entries! */
+      if (grib_tables->grib_table_info[tablenum].num_entries >= 256) 
+	{
+	  fprintf(stderr,
+"Error: Invalid number of lines in table %d in, \n skipping line: %s \n",
+		  tablenum,line);
+	  break;
+	}
+
+      /* Grab the last field */
+      strcpy(elems[elemidx],line + nxtidx);
+
+      /* Split up comma-seperated field of wrf varnames */
+      nxtidx = 0;
+      elemidx = 0;
+
+      /* Allocate number of elements in wrf_param */
+      grib_tables->grib_table_info[tablenum].wrf_param[parmidx] = 
+	(char **)malloc(1*sizeof(char *));
+      if (grib_tables->grib_table_info[tablenum].wrf_param[parmidx] == NULL)
+	{
+	  fprintf(stderr, "Error allocating space for wrf_param[%d], exiting\n",
+		  parmidx);
+	  *ret = 1;
+	  return 1;
+	}
+
+      while ((charidx = findchar(elems[3]+nxtidx,',')) >= 0) 
+	{
+
+	  /* Allocate number of elements in wrf_param */
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx] = 
+	    (char **)
+	    realloc(grib_tables->grib_table_info[tablenum].wrf_param[parmidx],
+			     (elemidx+2)*sizeof(char *));
+	  if (grib_tables->grib_table_info[tablenum].wrf_param[parmidx] 
+	      == NULL)
+	    {
+	      perror("");
+	      fprintf(stderr, 
+		      "Error allocating space for wrf_param[%d], exiting\n", 
+		      parmidx);
+	      *ret = 1;
+	      return 1;
+	    }
+
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx] = 
+	    (char *)malloc((charidx+2)*sizeof(char));
+	  if (grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx]
+	      == NULL)
+	    {
+	      perror("");
+	      fprintf(stderr, 
+		      "Error allocating space for wrf_param[%d][%d], exiting\n",
+		      parmidx,elemidx);
+	      *ret = 1;
+	      return 1;
+	    }
+	  
+	  strncpy(grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx],
+		  elems[3]+nxtidx,charidx);
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx][charidx] = '\0';
+	  elemidx++;
+	  nxtidx += (charidx + 1);
+	}
+
+      /* Grab the last field */
+      if (strlen(elems[3] + nxtidx) <= 0) 
+	{
+	  /* Case for no specified WRF fields */
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx] =
+	    (char *)malloc(1*sizeof(char));
+	  if (grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx]
+	      == NULL)
+	    {
+	      perror("");
+	      fprintf(stderr, 
+		      "Error allocating space for wrf_param[%d][%d], exiting\n",
+		      parmidx,elemidx);
+	      *ret = 1;
+	      return 1;
+	    }
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx][0] 
+	    = '\0';
+	  grib_tables->grib_table_info[tablenum].num_wrf_params[parmidx] = 0;
+	}
+      else
+	{
+	  /* Allocate space for last element */
+	  grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx] =
+	    (char *)malloc((strlen(elems[3] + nxtidx)+1)*sizeof(char));
+	  if (grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx]
+	      == NULL)
+	    {
+	      perror("");
+	      fprintf(stderr, 
+		      "Error allocating space for wrf_param[%d][%d], exiting\n",
+		      parmidx,elemidx);
+	      *ret = 1;
+	      return 1;
+	    }
+	  
+	  strcpy(grib_tables->grib_table_info[tablenum].wrf_param[parmidx][elemidx],
+		 elems[3] + nxtidx);
+	  grib_tables->grib_table_info[tablenum].num_wrf_params[parmidx] = 
+	    elemidx + 1;
+	}
+  
+      grib_tables->grib_table_info[tablenum].parm_id[parmidx]=atoi(elems[0]);
+      grib_tables->grib_table_info[tablenum].dec_sc_factor[parmidx]=atoi(elems[4]);
+
+      grib_tables->grib_table_info[tablenum].num_entries++;
+    }
+
+  *ret=0;
+  return 0;
+}
+
+/******************************************************************************
+ *
+ * get_grib_param - searches through a grib_table_info structure and returns
+ *                   the index for the input "varname".
+ *
+ * returns index number, or, -1 for failure.
+ *****************************************************************************/
+
+int GET_GRIB_PARAM (Grib1_Tables *grib_tables, char *varname, int *center, 
+		    int *subcenter, int *parmtbl, int *tablenum, int *index,
+		    int strlen1, int strlen2)
+{
+  int idx;
+  int prm_idx;
+  int tableidx;
+  char varnametmp[200];
+  
+  *index = -1;
+
+  strncpy(varnametmp,varname,strlen2);
+  varnametmp[strlen2] = '\0';
+  trim(varnametmp);
+  for (tableidx = 0; tableidx < grib_tables->num_tables ;tableidx++)
+    {
+
+
+      for (idx = 0; 
+	   idx < grib_tables->grib_table_info[tableidx].num_entries;
+	   idx++) 
+	{
+	  for (prm_idx = 0; 
+	       prm_idx < 
+		 grib_tables->grib_table_info[tableidx].num_wrf_params[idx]; 
+	       prm_idx++) 
+	    {
+	      if (strcmp(varnametmp,
+			 grib_tables->grib_table_info[tableidx].wrf_param[idx][prm_idx]) 
+		  == 0) 
+		{
+		  *center = 
+		    grib_tables->grib_table_info[tableidx].center;
+		  *subcenter = grib_tables->grib_table_info[tableidx].subcenter;
+		  *parmtbl = grib_tables->grib_table_info[tableidx].parmtbl;
+		  *tablenum = tableidx;
+		  *index = idx;
+		  break;
+		}
+	    }
+	}
+      
+    }
+  return *index;
+}
+
+/******************************************************************************
+ *
+ * free_gribmap_ - returns the size (in bytes) of a grib_table_info
+ *                         structure.
+ *
+ *****************************************************************************/
+
+int FREE_GRIBMAP(Grib1_Tables *grib_tables)
+{
+  int idx, idx2;
+  int tablenum;
+  
+  for (tablenum = 0; tablenum < grib_tables->num_tables; tablenum++)
+    {
+      for (idx = 0; idx < grib_tables->grib_table_info[tablenum].num_entries; 
+	   idx++)
+	{
+	  for (idx2 = 0; 
+	       idx2 < grib_tables->grib_table_info[tablenum].num_wrf_params[idx]; 
+	       idx2++)
+	    {
+	      free(grib_tables->grib_table_info[tablenum].wrf_param[idx][idx2]);
+	    }
+	  if (grib_tables->grib_table_info[tablenum].num_wrf_params[idx] > 0)
+	    {
+	      free(grib_tables->grib_table_info[tablenum].wrf_param[idx]);
+	    }
+	}
+    }
+  free(grib_tables->grib_table_info);
+  return 0;
+}
+
+/******************************************************************************
+ *
+ * Return the character index of the first instance of "thechar" in a string.
+ *
+ ******************************************************************************/
+
+int findchar(char *line, char thechar)
+{
+  int returnidx, charnum;
+
+  returnidx = -1;
+  for (charnum = 0; charnum < strlen(line); charnum++) 
+    {
+      if (line[charnum] == thechar)
+	{
+	  returnidx = charnum;
+	  break;
+	}
+    }
+  return returnidx;
+}
+
+/******************************************************************************
+ *
+ * get_grib1_table_info_size - returns the size (in bytes) of a grib_table_info
+ *                         structure.
+ *
+ *****************************************************************************/
+
+int GET_GRIB1_TABLE_INFO_SIZE (int *size)
+{
+  *size = sizeof(Grib1_Table_Info);
+  return *size;
+}
+
+/******************************************************************************
+ *
+ * get_grib1_tables_size - returns the size (in bytes) of a grib_tables
+ *                         structure.
+ *
+ *****************************************************************************/
+
+int GET_GRIB1_TABLES_SIZE (int *size)
+{
+  *size = sizeof(Grib1_Tables);
+  return *size;
+}
+
+/******************************************************************************
+ *
+ * load_grib1_table_info - reads a gribmap file and puts the information into 
+ *                         the grib_table_info structure.
+ *
+ ******************************************************************************/
+
+int LOAD_GRIB1_TABLES (char filename[], 
+		       Grib1_Tables *grib_tables, int *ret, int strlen1)
+{
+
+  char tmpfilename[300];
+  strncpy(tmpfilename,filename,strlen1);
+  tmpfilename[strlen1] = '\0';
+
+  READ_GRIBMAP(tmpfilename, grib_tables, ret);
+
+  return *ret;
+}
+
+/******************************************************************************
+ *
+ * get_grid_info_size_ - returns the size (in bytes) of a grib_tables
+ *                         structure.
+ *
+ *****************************************************************************/
+
+int GET_GRID_INFO_SIZE (int *size)
+{
+  *size = sizeof(Grib1_Tables);
+  return *size;
+}
+
+
+/******************************************************************************
+ *
+ * copy_grib_tables - allocates and fills a grib_tables structure
+ *
+ *****************************************************************************/
+
+Grib1_Tables *copy_grib_tables(Grib1_Tables *grib_tables)
+{
+  int tblidx,prmidx,elmidx;
+  int strsiz;
+
+  Grib1_Tables *tmp;
+
+  tmp = (Grib1_Tables *)malloc(sizeof(Grib1_Tables));
+
+  memcpy(tmp,grib_tables,sizeof(Grib1_Tables));
+
+  /* Now do the grib_table_info elements within grib_tables */
+
+  tmp->grib_table_info = 
+    (Grib1_Table_Info *)
+    malloc(grib_tables->num_tables*sizeof(Grib1_Table_Info));
+  if (tmp->grib_table_info == NULL) 
+    {
+      fprintf(stderr,
+	      "copy_grib_tables: Could not allocate space for grib_table_info.  num_tables: %d\n",
+	      grib_tables->num_tables);
+      exit(1);
+    }
+
+  memcpy(tmp->grib_table_info,
+	 grib_tables->grib_table_info,
+	 grib_tables->num_tables*sizeof(Grib1_Table_Info));
+
+
+  for (tblidx = 0; tblidx < grib_tables->num_tables; tblidx++) 
+    {
+
+      for (prmidx = 0; prmidx < MAX_PARAMS; prmidx++)
+	{
+	  if (grib_tables->grib_table_info[tblidx].num_wrf_params[prmidx] <= 0)
+	    {
+	      continue;
+	    }
+
+	  tmp->grib_table_info[tblidx].wrf_param[prmidx] = (char **)
+	    malloc(grib_tables->grib_table_info[tblidx].num_wrf_params[prmidx] 
+		   * sizeof(char *));
+
+	  memcpy(tmp->grib_table_info[tblidx].wrf_param[prmidx],
+		 grib_tables->grib_table_info[tblidx].wrf_param[prmidx],
+		 grib_tables->grib_table_info[tblidx].num_wrf_params[prmidx]
+		 * sizeof(char *));
+
+	  for (elmidx = 0; 
+	       elmidx < grib_tables->grib_table_info[tblidx].num_wrf_params[prmidx]; 
+	       elmidx++) 
+	    {
+	      
+	      strsiz = 
+		strlen(grib_tables->grib_table_info[tblidx].wrf_param[prmidx][elmidx]) + 1;
+	      tmp->grib_table_info[tblidx].wrf_param[prmidx][elmidx] = 
+		(char *)
+		malloc(strsiz * sizeof(char));
+
+	      memcpy(tmp->grib_table_info[tblidx].wrf_param[prmidx][elmidx],
+		     grib_tables->grib_table_info[tblidx].wrf_param[prmidx][elmidx],
+		     strsiz * sizeof(char));
+
+	    }
+
+	}
+
+    }
+
+  return tmp;
+
+}
+
diff --git a/wrfv2_fire/external/io_grib1/gribmap.h b/wrfv2_fire/external/io_grib1/gribmap.h
new file mode 100644
index 00000000..24b56f1a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/gribmap.h
@@ -0,0 +1,56 @@
+#define MAX_LINE_CHARS 2500
+#define MAX_PARAMS 256
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define LOAD_GRIB1_TABLES load_grib1_tables
+#      define GET_GRIB_PARAM get_grib_param
+#      define FREE_GRIBMAP  free_gribmap
+#      define GET_GRIB1_TABLE_INFO_SIZE get_grib1_table_info_size
+#      define GET_GRIB1_TABLES_SIZE get_grib1_tables_size
+#      define READ_GRIBMAP read_gribmap
+# else
+#   ifdef F2CSTYLE
+#      define LOAD_GRIB1_TABLES load_grib1_tables__
+#      define GET_GRIB_PARAM get_grib_param__
+#      define FREE_GRIBMAP  free_gribmap__
+#      define GET_GRIB1_TABLES_SIZE get_grib1_tables_size__
+#      define READ_GRIBMAP read_gribmap__
+#   else
+#      define LOAD_GRIB1_TABLES load_grib1_tables_
+#      define GET_GRIB_PARAM get_grib_param_
+#      define FREE_GRIBMAP  free_gribmap_
+#      define GET_GRIB1_TABLES_SIZE get_grib1_tables_size_
+#      define READ_GRIBMAP read_gribmap_
+#   endif
+# endif
+#endif
+
+
+typedef struct {
+  int center;
+  int subcenter;
+  int parmtbl;
+  int parm_id[MAX_PARAMS];
+  int dec_sc_factor[MAX_PARAMS];
+  char **wrf_param[MAX_PARAMS];
+  int num_wrf_params[MAX_PARAMS];
+  int num_entries;
+} Grib1_Table_Info;
+
+typedef struct {
+  int num_tables;
+  Grib1_Table_Info *grib_table_info;
+} Grib1_Tables;
+
+
+int GET_GRIB_PARAM (Grib1_Tables *grib_tables, char *varname, int *center, 
+		    int *subcenter, int *parmtbl, int *tablenum, int *index,
+		    int strlen1, int strlen2);
+
+int GET_GRIB1_TABLES_SIZE (int *size);
+
+int LOAD_GRIB1_TABLES (char filename[], 
+			   Grib1_Tables *grib_tables, int *ret, int strlen1);
+
+Grib1_Tables *copy_grib_tables(Grib1_Tables *);
diff --git a/wrfv2_fire/external/io_grib1/io_grib1.F b/wrfv2_fire/external/io_grib1/io_grib1.F
new file mode 100644
index 00000000..d3f2103b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/io_grib1.F
@@ -0,0 +1,3351 @@
+!*-----------------------------------------------------------------------------
+!*
+!*  Todd Hutchinson
+!*  WSI
+!*  400 Minuteman Road
+!*  Andover, MA     01810
+!*  thutchinson@wsi.com
+!*
+!*-----------------------------------------------------------------------------
+
+!*
+!* This io_grib1 API is designed to read WRF input and write WRF output data
+!*   in grib version 1 format.  
+!*
+
+
+module gr1_data_info
+
+!*
+!* This module will hold data internal to this I/O implementation.  
+!*   The variables will be accessible by all functions (provided they have a 
+!*   "USE gr1_data_info" line).
+!*
+
+  integer                , parameter       :: FATAL            = 1
+  integer                , parameter       :: DEBUG            = 100
+  integer                , parameter       :: DateStrLen       = 19
+
+  integer                , parameter       :: firstFileHandle  = 8
+  integer                , parameter       :: maxFileHandles   = 200
+  integer                , parameter       :: maxLevels        = 1000
+  integer                , parameter       :: maxSoilLevels    = 100
+  integer                , parameter       :: maxDomains       = 500
+
+  logical ,      dimension(maxFileHandles) :: committed, opened, used
+  character*128, dimension(maxFileHandles) :: DataFile
+  integer,       dimension(maxFileHandles) :: FileFd
+  integer,       dimension(maxFileHandles) :: FileStatus
+  REAL,          dimension(maxLevels)      :: half_eta, full_eta
+  REAL,          dimension(maxSoilLevels)  :: soil_depth, soil_thickness
+  character*24                             :: StartDate = ''
+  character*24                             :: InputProgramName = ''
+  integer                                  :: projection
+  integer                                  :: wg_grid_id
+  real                                     :: dx,dy
+  real                                     :: truelat1, truelat2
+  real                                     :: center_lat, center_lon
+  real                                     :: proj_central_lon
+  real                                     :: timestep
+  character,     dimension(:), pointer     :: grib_tables
+  logical                                  :: table_filled = .FALSE.
+  character,     dimension(:), pointer     :: grid_info
+  integer                                  :: full_xsize, full_ysize
+  integer, dimension(maxDomains)           :: domains = -1
+  integer                                  :: max_domain = 0
+  
+  TYPE :: HandleVar
+     character, dimension(:), pointer      :: fileindex(:)
+     integer                               :: CurrentTime
+     integer                               :: NumberTimes
+     character (DateStrLen), dimension(:),pointer  :: Times(:)
+  ENDTYPE
+  TYPE (HandleVar), dimension(maxFileHandles) :: fileinfo
+
+  TYPE :: prevdata
+     integer :: fcst_secs_rainc
+     integer :: fcst_secs_rainnc
+     real, dimension(:,:), pointer         :: rainc, rainnc
+  END TYPE prevdata
+
+  TYPE :: initdata
+     real,         dimension(:,:), pointer :: snod
+  END TYPE initdata
+
+  TYPE (initdata), dimension(maxDomains)   :: firstdata
+
+  TYPE :: prestype
+     real,         dimension(:,:,:), pointer :: vals
+     logical                                :: newtime
+     character*120                          :: lastDateStr
+  END TYPE prestype
+
+  TYPE (prestype), dimension(maxDomains)   :: pressure
+
+  integer                                  :: center, subcenter, parmtbl
+
+  character(len=30000), dimension(maxFileHandles) :: td_output
+  character(len=30000), dimension(maxFileHandles) :: ti_output
+
+  logical                                  :: WrfIOnotInitialized = .true.
+
+end module gr1_data_info
+
+
+subroutine ext_gr1_ioinit(SysDepInfo,Status)
+
+  USE gr1_data_info
+  implicit none
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  CHARACTER*(*), INTENT(IN) :: SysDepInfo
+  integer ,intent(out) :: Status
+  integer :: i
+  integer :: size, istat
+  CHARACTER (LEN=300) :: wrf_err_message
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_ioinit')
+
+  do i=firstFileHandle, maxFileHandles
+        used(i) = .false.
+        committed(i) = .false.
+        opened(i) = .false.
+        td_output(i) = ''
+        ti_output(i) = ''
+  enddo
+  domains(:) = -1
+
+  do i = 1, maxDomains
+    pressure(i)%newtime = .false.
+    pressure(i)%lastDateStr = ''
+  enddo
+
+  FileStatus(1:maxFileHandles) = WRF_FILE_NOT_OPENED
+  WrfIOnotInitialized = .false.
+
+  Status = WRF_NO_ERR
+
+  return
+end subroutine ext_gr1_ioinit
+
+!*****************************************************************************
+
+subroutine ext_gr1_ioexit(Status)
+
+  USE gr1_data_info
+  implicit none
+#include "wrf_status_codes.h"
+  integer istat
+  integer ,intent(out) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_ioexit')
+
+  if (table_filled) then
+     CALL free_gribmap(grib_tables)
+     DEALLOCATE(grib_tables, stat=istat)
+     table_filled = .FALSE.
+  endif
+  IF ( ASSOCIATED ( grid_info ) ) THEN
+    DEALLOCATE(grid_info, stat=istat)
+  ENDIF
+  NULLIFY(grid_info)
+
+  Status = WRF_NO_ERR
+
+  return
+end subroutine ext_gr1_ioexit
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_open_for_read_begin ( FileName , Comm_compute, Comm_io, &
+     SysDepInfo, DataHandle , Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  integer                     :: ierr
+  integer                     :: size
+  integer                     :: idx
+  integer                     :: parmid
+  integer                     :: dpth_parmid
+  integer                     :: thk_parmid
+  integer                     :: leveltype
+  integer , DIMENSION(1000)   :: indices
+  integer                     :: numindices
+  real , DIMENSION(1000)      :: levels
+  real                        :: tmp
+  integer                     :: swapped
+  integer                     :: etaidx
+  integer                     :: grb_index
+  integer                     :: level1, level2
+  integer   :: tablenum
+  integer   :: stat
+  integer   :: endchar
+  integer   :: last_grb_index
+  CHARACTER (LEN=300) :: wrf_err_message
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read_begin')
+
+  CALL gr1_get_new_handle(DataHandle)
+
+  if (DataHandle .GT. 0) then
+     CALL open_file(TRIM(FileName), 'r', FileFd(DataHandle), ierr)
+     if (ierr .ne. 0) then
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+     else
+        opened(DataHandle) = .true.
+        DataFile(DataHandle) = TRIM(FileName)
+        FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
+     endif
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+     return
+  endif
+ 
+  ! Read the grib index file first
+  if (.NOT. table_filled) then
+     table_filled = .TRUE.
+     CALL GET_GRIB1_TABLES_SIZE(size)
+     ALLOCATE(grib_tables(1:size), STAT=ierr)
+     CALL LOAD_GRIB1_TABLES ("gribmap.txt", grib_tables, ierr)
+     if (ierr .ne. 0) then
+        DEALLOCATE(grib_tables)
+        WRITE( wrf_err_message , * ) &
+             'Could not open file gribmap.txt '
+        CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+        return
+     endif
+  endif
+
+  ! Begin by indexing file and reading metadata into structure.
+  CALL GET_FILEINDEX_SIZE(size)
+  ALLOCATE(fileinfo(DataHandle)%fileindex(1:size), STAT=ierr)
+
+  CALL ALLOC_INDEX_FILE(fileinfo(DataHandle)%fileindex(:))
+  CALL INDEX_FILE(FileFd(DataHandle),fileinfo(DataHandle)%fileindex(:))
+
+  ! Get times into Times variable
+  CALL GET_NUM_TIMES(fileinfo(DataHandle)%fileindex(:), &
+       fileinfo(DataHandle)%NumberTimes);
+
+  ALLOCATE(fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes), STAT=ierr)
+  do idx = 1,fileinfo(DataHandle)%NumberTimes
+     CALL GET_TIME(fileinfo(DataHandle)%fileindex(:),idx, &
+          fileinfo(DataHandle)%Times(idx))
+  enddo
+
+  ! CurrentTime starts as 0.  The first time in the file is 1.  So,
+  !   until set_time or get_next_time is called, the current time
+  !   is not set.
+  fileinfo(DataHandle)%CurrentTime = 0
+
+  CALL gr1_fill_eta_levels(fileinfo(DataHandle)%fileindex(:), &
+       FileFd(DataHandle), & 
+       grib_tables, "ZNW", full_eta)
+  CALL gr1_fill_eta_levels(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), &
+       grib_tables, "ZNU", half_eta)
+
+  ! 
+  ! Now, get the soil levels
+  !
+  CALL GET_GRIB_PARAM(grib_tables, "ZS", center, subcenter, parmtbl, &
+       tablenum, dpth_parmid)
+  CALL GET_GRIB_PARAM(grib_tables,"DZS", center, subcenter, parmtbl, &
+       tablenum, thk_parmid)
+  if (dpth_parmid == -1) then
+     call wrf_message ('Error getting grib parameter')
+  endif
+
+  leveltype = 112
+
+  CALL GET_GRIB_INDICES(fileinfo(DataHandle)%fileindex(:),center, subcenter, parmtbl, &
+       dpth_parmid,"*",leveltype, &
+       -HUGE(1),-HUGE(1), -HUGE(1),-HUGE(1),indices,numindices)
+
+  last_grb_index = -1;
+  do idx = 1,numindices
+     CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), &
+          indices(idx), soil_depth(idx))
+     !
+     ! Now read the soil thickenesses
+     !
+     CALL GET_LEVEL1(fileinfo(DataHandle)%fileindex(:),indices(idx),level1)
+     CALL GET_LEVEL2(fileinfo(DataHandle)%fileindex(:),indices(idx),level2)
+     CALL GET_GRIB_INDEX_GUESS(fileinfo(DataHandle)%fileindex(:), &
+          center, subcenter, parmtbl, thk_parmid,"*",leveltype, &
+          level1,level2,-HUGE(1),-HUGE(1), last_grb_index+1, grb_index)
+     CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:),FileFd(DataHandle),grb_index, &
+          soil_thickness(idx))
+
+     last_grb_index = grb_index
+  enddo
+  
+
+
+  !
+  ! Fill up any variables that need to be retrieved from Metadata
+  !
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), 'PROGRAM_NAME', "none", &
+       "none", InputProgramName, stat)
+  if (stat /= 0) then
+     CALL wrf_debug (DEBUG , "PROGRAM_NAME not found in input METADATA")
+  else 
+     endchar = SCAN(InputProgramName," ")
+     InputProgramName = InputProgramName(1:endchar)
+  endif
+
+  call wrf_debug ( DEBUG , 'Exiting ext_gr1_open_for_read_begin')
+
+  RETURN
+END SUBROUTINE ext_gr1_open_for_read_begin
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_open_for_read_commit( DataHandle , Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  character(len=1000) :: msg
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read_commit')
+
+  Status = WRF_NO_ERR
+  if(WrfIOnotInitialized) then
+    Status = WRF_IO_NOT_INITIALIZED
+    write(msg,*) 'ext_gr1_ioinit was not called ',__FILE__,', line', __LINE__
+    call wrf_debug ( FATAL , msg)
+    return
+  endif
+  committed(DataHandle) = .true.
+  FileStatus(DataHandle) = WRF_FILE_OPENED_FOR_READ
+
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr1_open_for_read_commit
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_open_for_read ( FileName , Comm_compute, Comm_io, &
+     SysDepInfo, DataHandle , Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read')
+
+  DataHandle = 0   ! dummy setting to quiet warning message
+  CALL ext_gr1_open_for_read_begin( FileName, Comm_compute, Comm_io, &
+       SysDepInfo, DataHandle, Status )
+  IF ( Status .EQ. WRF_NO_ERR ) THEN
+     FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
+     CALL ext_gr1_open_for_read_commit( DataHandle, Status )
+  ENDIF
+  return
+
+  RETURN  
+END SUBROUTINE ext_gr1_open_for_read
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
+     DataHandle, Status)
+  
+  USE gr1_data_info
+  implicit none
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+
+  character*(*)        ,intent(in)  :: FileName
+  integer              ,intent(in)  :: Comm
+  integer              ,intent(in)  :: IOComm
+  character*(*)        ,intent(in)  :: SysDepInfo
+  integer              ,intent(out) :: DataHandle
+  integer              ,intent(out) :: Status
+  integer :: ierr
+  CHARACTER (LEN=300) :: wrf_err_message
+  integer             :: size
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_write_begin')
+
+  if (.NOT. table_filled) then
+     table_filled = .TRUE.
+     CALL GET_GRIB1_TABLES_SIZE(size)
+     ALLOCATE(grib_tables(1:size), STAT=ierr)
+     CALL LOAD_GRIB1_TABLES ("gribmap.txt", grib_tables, ierr)
+     if (ierr .ne. 0) then
+        DEALLOCATE(grib_tables)
+        WRITE( wrf_err_message , * ) &
+             'Could not open file gribmap.txt '
+        CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+        return
+     endif
+  endif
+
+  Status = WRF_NO_ERR
+  CALL gr1_get_new_handle(DataHandle)
+  if (DataHandle .GT. 0) then
+     CALL open_file(TRIM(FileName), 'w', FileFd(DataHandle), ierr)
+     if (ierr .ne. 0) then
+        Status = WRF_WARN_WRITE_RONLY_FILE
+     else
+        opened(DataHandle) = .true.
+        DataFile(DataHandle) = TRIM(FileName)
+        FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
+     endif
+     committed(DataHandle) = .false.
+     td_output(DataHandle) = ''
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+  endif
+
+  RETURN  
+END SUBROUTINE ext_gr1_open_for_write_begin
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_open_for_write_commit( DataHandle , Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_write_commit')
+
+  IF ( opened( DataHandle ) ) THEN
+    IF ( used( DataHandle ) ) THEN
+      committed(DataHandle) = .true.
+      FileStatus(DataHandle) = WRF_FILE_OPENED_FOR_WRITE
+    ENDIF
+  ENDIF
+
+  Status = WRF_NO_ERR
+
+  RETURN  
+END SUBROUTINE ext_gr1_open_for_write_commit
+
+!*****************************************************************************
+
+subroutine ext_gr1_inquiry (Inquiry, Result, Status)
+  use gr1_data_info
+  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")
+     Result='ALLOW'
+  CASE ("SEQUENTIAL_WRITE","SEQUENTIAL_READ")
+     Result='NO'
+  CASE ("OPEN_READ", "OPEN_WRITE", "OPEN_COMMIT_WRITE")
+     Result='REQUIRE'
+  CASE ("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_gr1_inquiry
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_inquire_opened ( DataHandle, FileName , FileStat, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStat
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_inquire_opened')
+
+  FileStat = WRF_NO_ERR
+  if ((DataHandle .ge. firstFileHandle) .and. &
+       (DataHandle .le. maxFileHandles)) then
+     FileStat = FileStatus(DataHandle)
+  else
+     FileStat = WRF_FILE_NOT_OPENED
+  endif
+  
+  Status = FileStat
+
+  RETURN
+END SUBROUTINE ext_gr1_inquire_opened
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_ioclose ( DataHandle, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER DataHandle, Status
+  INTEGER istat
+  INTEGER ierr
+  character(len=1000) :: outstring
+  character :: lf
+  lf=char(10)
+     
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_ioclose')
+
+  Status = WRF_NO_ERR
+
+  CALL write_file(FileFd(DataHandle), lf//''//lf,ierr)
+  outstring = &
+       ''
+  CALL write_file(FileFd(DataHandle), trim(outstring), ierr)
+  if (trim(ti_output(DataHandle)) /= '') then
+     CALL write_file(FileFd(DataHandle), trim(ti_output(DataHandle)), ierr)
+     CALL write_file(FileFd(DataHandle), lf, ierr)
+  endif
+  if (trim(td_output(DataHandle)) /= '') then
+     CALL write_file(FileFd(DataHandle), trim(td_output(DataHandle)), ierr)
+     CALL write_file(FileFd(DataHandle), lf, ierr)
+  endif
+  CALL write_file(FileFd(DataHandle), ''//lf,ierr)
+  ti_output(DataHandle) = ''
+  td_output(DataHandle) = ''
+  if (ierr .ne. 0) then
+     Status = WRF_WARN_WRITE_RONLY_FILE
+  endif
+  CALL close_file(FileFd(DataHandle))
+
+  used(DataHandle) = .false.
+
+  RETURN
+END SUBROUTINE ext_gr1_ioclose
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_write_field( DataHandle , DateStr , VarName , &
+     Field , FieldType , Comm , IOComm, &
+     DomainDesc , MemoryOrder , Stagger , &
+     DimNames , &
+     DomainStart , DomainEnd , &
+     MemoryStart , MemoryEnd , &
+     PatchStart , PatchEnd , &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  CHARACTER*120 :: OutName
+  CHARACTER(120) :: TmpVarName
+  integer                       ,intent(in)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrder
+  character*(*)                 ,intent(in)    :: Stagger
+  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                                      :: ierror
+  character (120)                         :: msg
+  integer :: xsize, ysize, zsize
+  integer :: x, y, z
+  integer :: x_start,x_end,y_start,y_end,z_start,z_end,ndim
+  integer :: idx
+  integer :: proj_center_flag
+  logical :: vert_stag = .false.
+  integer :: levelnum
+  real, DIMENSION(:,:), POINTER :: data,tmpdata
+  integer, DIMENSION(:), POINTER :: mold
+  integer :: istat
+  integer :: accum_period
+  integer :: size
+  integer, dimension(1000) :: level1, level2
+  real, DIMENSION( 1:1,MemoryStart(1):MemoryEnd(1), &
+                   MemoryStart(2):MemoryEnd(2), &
+                   MemoryStart(3):MemoryEnd(3) ) :: Field
+  real    :: fcst_secs
+  logical :: soil_layers, fraction
+  integer :: vert_unit
+  integer :: abc(2,2,2)
+  integer :: def(8)
+  logical :: output = .true.
+  integer :: idx1, idx2, idx3
+  integer :: this_domain
+  logical :: new_domain
+  real    :: region_center_lat, region_center_lon
+  integer :: dom_xsize, dom_ysize;
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_write_field for parameter'//VarName)
+
+  !
+  ! If DateStr is all 0's, we reset it to StartDate.  For some reason, 
+  !   in idealized simulations, StartDate is 0001-01-01_00:00:00 while
+  !   the first DateStr is 0000-00-00_00:00:00.  
+  !
+  if (DateStr .eq. '0000-00-00_00:00:00') then
+     DateStr = TRIM(StartDate)
+  endif
+
+  !
+  ! Check if this is a domain that we haven't seen yet.  If so, add it to 
+  !   the list of domains.
+  !
+  this_domain = 0
+  new_domain = .false.
+  do idx = 1, max_domain
+     if (DomainDesc .eq. domains(idx)) then
+        this_domain = idx
+     endif
+  enddo
+  if (this_domain .eq. 0) then
+     max_domain = max_domain + 1
+     domains(max_domain) = DomainDesc
+     this_domain = max_domain
+     new_domain = .true.
+  endif
+
+  output = .true.
+  zsize = 1
+  xsize = 1
+  ysize = 1
+  OutName = VarName
+  soil_layers = .false.
+  fraction = .false.
+
+  ! First, handle then special cases for the boundary data.
+
+  CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndim, x_start, x_end, &
+       y_start, y_end,z_start,z_end)
+  xsize = x_end - x_start + 1
+  ysize = y_end - y_start + 1
+  zsize = z_end - z_start + 1
+
+  do idx = 1, len(MemoryOrder)
+     if ((MemoryOrder(idx:idx) .eq. 'Z') .and. &
+          (DimNames(idx) .eq. 'soil_layers_stag')) then
+        soil_layers = .true.
+     else if ((OutName .eq. 'LANDUSEF') .or. (OutName .eq. 'SOILCBOT') .or. &
+          (OutName .eq. 'SOILCTOP')) then
+        fraction = .true.
+     endif
+  enddo
+
+  if (.not. ASSOCIATED(grid_info)) then
+     CALL get_grid_info_size(size)
+     ALLOCATE(grid_info(1:size), STAT=istat)
+     if (istat .eq. -1) then
+        DEALLOCATE(grid_info)
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+        return
+     endif
+  endif
+     
+
+  if (new_domain) then
+     ALLOCATE(firstdata(this_domain)%snod(xsize,ysize))
+     firstdata(this_domain)%snod(:,:) = 0.0
+  endif
+
+  if (zsize .eq. 0) then 
+     zsize = 1
+  endif
+
+  ALLOCATE(data(1:xsize,1:ysize), STAT=istat)
+  ALLOCATE(mold(1:ysize), STAT=istat)
+  ALLOCATE(tmpdata(1:xsize,1:ysize), STAT=istat)
+
+  if (OutName .eq. 'ZNU') then
+     do idx = 1, zsize
+        half_eta(idx) = Field(1,idx,1,1)
+     enddo
+  endif
+
+  if (OutName .eq. 'ZNW') then
+     do idx = 1, zsize
+        full_eta(idx) = Field(1,idx,1,1)
+     enddo
+  endif
+
+  if (OutName .eq. 'ZS') then
+     do idx = 1, zsize
+        soil_depth(idx) = Field(1,idx,1,1)
+     enddo
+  endif
+
+  if (OutName .eq. 'DZS') then
+     do idx = 1, zsize
+        soil_thickness(idx) = Field(1,idx,1,1)
+     enddo
+  endif
+
+
+  if ((xsize .lt. 1) .or. (ysize .lt. 1)) then
+     write(msg,*) 'Cannot output field with memory order: ', &
+          MemoryOrder,Varname
+     call wrf_message(msg)
+     return
+  endif
+     
+  call get_vert_stag(OutName,Stagger,vert_stag)
+
+  do idx = 1, zsize
+     call gr1_get_levels(OutName, idx, zsize, soil_layers, vert_stag, fraction, &
+          vert_unit, level1(idx), level2(idx))
+  enddo
+
+  ! 
+  ! Get the center lat/lon for the area being output.  For some cases (such
+  !    as for boundary areas, the center of the area is different from the
+  !    center of the model grid.
+  !
+  if (index(Stagger,'X') .le. 0) then
+     dom_xsize = full_xsize - 1
+  else
+     dom_xsize = full_xsize
+  endif
+  if (index(Stagger,'Y') .le. 0) then
+     dom_ysize = full_ysize - 1
+  else
+     dom_ysize = full_ysize
+  endif
+
+  CALL get_region_center(MemoryOrder, projection, center_lat, center_lon, &
+       dom_xsize, dom_ysize, dx, dy, proj_central_lon, proj_center_flag, &
+       truelat1, truelat2, xsize, ysize, region_center_lat, region_center_lon)
+
+  if ( .not. opened(DataHandle)) then
+     Status = WRF_WARN_FILE_NOT_OPENED
+     return
+  endif
+
+
+  if (opened(DataHandle) .and. committed(DataHandle)) then
+
+
+     !
+     ! The following code to compute full pressure was removed by 
+     !  Todd Hutchinson since there are times when base-state and 
+     !  perturbation are required (i.e., for a restart)
+     !
+
+     ! 
+     ! The following is a kludge to output full pressure instead of the two 
+     !  fields of base-state pressure and pressure perturbation.
+     !
+     
+!     if ((OutName .eq. 'P') .or. (OutName.eq.'PB')) then
+!        do idx = 1, len(MemoryOrder)
+!           if (MemoryOrder(idx:idx) .eq. 'X') then
+!              idx1=idx
+!           endif
+!           if (MemoryOrder(idx:idx) .eq. 'Y') then
+!              idx2=idx
+!           endif
+!           if (MemoryOrder(idx:idx) .eq. 'Z') then
+!              idx3=idx
+!           endif
+!        enddo
+
+        ! 
+        ! Allocate space for pressure values (this variable holds 
+        !   base-state pressure or pressure perturbation to be used 
+        !   later to sum base-state and perturbation pressure to get full 
+        !   pressure).
+        !
+
+!        if (.not. ASSOCIATED(pressure(this_domain)%vals)) then
+!           ALLOCATE(pressure(this_domain)%vals(MemoryStart(1):MemoryEnd(1), &
+!                MemoryStart(2):MemoryEnd(2),MemoryStart(3):MemoryEnd(3)))
+!        endif
+!        if (DateStr .NE. &
+!             pressure(this_domain)%lastDateStr) then
+!           pressure(this_domain)%newtime = .true.
+!        endif
+!        if (pressure(this_domain)%newtime) then
+!           pressure(this_domain)%vals = Field(1,:,:,:)
+!           pressure(this_domain)%newtime = .false.
+!           output = .false.
+!        else 
+!           output = .true.
+!        endif
+!        pressure(this_domain)%lastDateStr=DateStr
+!     endif
+
+     if (output) then 
+        if (StartDate == '') then
+           StartDate = DateStr
+        endif
+        CALL geth_idts(DateStr,StartDate,fcst_secs)
+        
+        if (center_lat .lt. 0) then
+           proj_center_flag = 2
+        else
+           proj_center_flag = 1
+        endif
+         
+        do z = 1, zsize
+           SELECT CASE (MemoryOrder)
+           CASE ('XYZ')
+              data = Field(1,1:xsize,1:ysize,z)
+           CASE ('XZY')
+              data = Field(1,1:xsize,z,1:ysize)
+           CASE ('YXZ')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,x,z)
+                 enddo
+              enddo
+           CASE ('YZX')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,z,x)
+                 enddo
+              enddo
+           CASE ('ZXY')
+              data = Field(1,z,1:xsize,1:ysize)
+           CASE ('ZYX')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,z,y,x)
+                 enddo
+              enddo
+           CASE ('XY')
+              data = Field(1,1:xsize,1:ysize,1)
+           CASE ('YX')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,x,1)
+                 enddo
+              enddo
+
+           CASE ('XSZ')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,z,x)
+                 enddo
+              enddo
+           CASE ('XEZ')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,z,x)
+                 enddo
+              enddo
+           CASE ('YSZ')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,x,z,y)
+                 enddo
+              enddo
+           CASE ('YEZ')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,x,z,y)
+                 enddo
+              enddo
+
+           CASE ('XS')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,x,1)
+                 enddo
+              enddo
+           CASE ('XE')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,y,x,1)
+                 enddo
+              enddo
+           CASE ('YS')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,x,y,1)
+                 enddo
+              enddo
+           CASE ('YE')
+              do x = 1,xsize
+                 do y = 1,ysize
+                    data(x,y) = Field(1,x,y,1)
+                 enddo
+              enddo
+
+           CASE ('Z')
+              data(1,1) = Field(1,z,1,1)
+           CASE ('z')
+              data(1,1) = Field(1,z,1,1)
+           CASE ('C')
+              data = Field(1,1:xsize,1:ysize,z)
+           CASE ('c')
+              data = Field(1,1:xsize,1:ysize,z)
+           CASE ('0')
+              data(1,1) = Field(1,1,1,1)
+           END SELECT
+
+           ! 
+           ! Here, we convert any integer fields to real
+           !
+           if (FieldType == WRF_INTEGER) then
+              mold = 0
+              do idx=1,xsize
+                 !
+                 ! The parentheses around data(idx,:) are needed in order
+                 !   to fix a bug with transfer with the xlf compiler on NCAR's
+                 !   IBM (bluesky).
+                 !
+                 data(idx,:)=transfer((data(idx,:)),mold)
+              enddo
+           endif
+           ! 
+           ! Here, we do any necessary conversions to the data.
+           !
+           
+           ! Potential temperature is sometimes passed in as perturbation 
+           !   potential temperature (i.e., POT-300).  Other times (i.e., from 
+           !   WRF SI), it is passed in as full potential temperature.
+           ! Here, we convert to full potential temperature by adding 300
+           !   only if POT < 200 K.
+           !
+           if (OutName == 'T') then
+              if (data(1,1) < 200) then
+                 data = data + 300
+              endif
+           endif
+
+           ! 
+           ! For precip, we setup the accumulation period, and output a precip
+           !    rate for time-step precip.
+           !
+           if ((OutName .eq. 'RAINCV') .or. (OutName .eq. 'RAINNCV')) then
+              ! Convert time-step precip to precip rate.
+              data = data/timestep
+              accum_period = 0
+           else
+              accum_period = 0
+           endif
+
+           !
+           ! Computation of full-pressure removed since there are 
+           !  uses for base-state and perturbation (i.e., restarts
+           !
+!           if ((OutName .eq. 'P') .or. (OutName.eq.'PB')) then
+!              if (idx3 .eq. 1) then
+!                 data = data + &
+!                      pressure(this_domain)%vals(z, &
+!                      patchstart(2):patchend(2),patchstart(3):patchend(3))
+!              elseif (idx3 .eq. 2) then
+!                 data = data + &
+!                      pressure(this_domain)%vals(patchstart(1):patchend(1), &
+!                      z,patchstart(3):patchend(3))
+!              elseif (idx3 .eq. 3) then
+!                 data = data + &
+!                      pressure(this_domain)%vals(patchstart(1):patchend(1), &
+!                      patchstart(2):patchend(2),z)
+!              else
+!                 call wrf_message ('error in idx3, continuing')
+!              endif
+!
+!              OutName = 'P'
+!           endif
+
+           !
+           !    Output current level
+           !
+           CALL load_grid_info(OutName, StartDate, vert_unit, level1(z), &
+                level2(z), fcst_secs, accum_period, wg_grid_id, projection, &
+                xsize, ysize, region_center_lat, region_center_lon, dx, dy, &
+                proj_central_lon, proj_center_flag, truelat1, truelat2, &
+                grib_tables, grid_info)
+           
+           CALL write_grib(grid_info, FileFd(DataHandle), data)
+
+           CALL free_grid_info(grid_info)
+           
+        enddo
+     endif
+  endif
+
+  deallocate(data, STAT = istat)
+  deallocate(mold, STAT = istat)
+  deallocate(tmpdata, STAT = istat)
+
+  Status = WRF_NO_ERR
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr1_write_field')
+
+  RETURN
+END SUBROUTINE ext_gr1_write_field
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_read_field ( DataHandle , DateStr , VarName , Field , &
+     FieldType , Comm , IOComm, DomainDesc , MemoryOrder , Stagger ,     &
+     DimNames , DomainStart , DomainEnd , MemoryStart , MemoryEnd ,      &
+     PatchStart , PatchEnd ,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE  
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  CHARACTER (len=400) :: msg
+  integer                       ,intent(inout)    :: FieldType
+  integer                       ,intent(inout)    :: Comm
+  integer                       ,intent(inout)    :: IOComm
+  integer                       ,intent(inout)    :: DomainDesc
+  character*(*)                 ,intent(inout)    :: MemoryOrder
+  character*(*)                 ,intent(inout)    :: Stagger
+  character*(*) , dimension (*) ,intent(inout)    :: DimNames
+  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
+  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)      :: Status
+  INTEGER                       ,intent(out)      :: Field(*)
+  integer   :: ndim,x_start,x_end,y_start,y_end,z_start,z_end
+  integer   :: zidx
+  REAL, DIMENSION(:,:), POINTER :: data
+  logical                     :: vert_stag
+  logical                     :: soil_layers
+  integer                     :: level1,level2
+
+  integer                     :: parmid
+  integer                     :: vert_unit
+  integer                     :: grb_index
+  integer                     :: numcols, numrows
+  integer                     :: data_allocated
+  integer                     :: istat
+  integer                     :: tablenum
+  integer                     :: di
+  integer                     :: last_grb_index
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_read_field')
+
+  !
+  ! Get dimensions of data.  
+  ! Assume that the domain size in the input data is the same as the Domain 
+  !     Size from the input arguments.
+  !
+  
+  CALL get_dims(MemoryOrder,DomainStart,DomainEnd,ndim,x_start,x_end,y_start, &
+       y_end,z_start,z_end) 
+
+  !
+  ! Get grib parameter id
+  !
+  CALL GET_GRIB_PARAM(grib_tables, VarName, center, subcenter, parmtbl, &
+       tablenum, parmid)
+
+  !
+  ! Setup the vertical unit and levels
+  !
+  CALL get_vert_stag(VarName,Stagger,vert_stag)
+  CALL get_soil_layers(VarName,soil_layers)
+
+  !
+  ! Loop over levels, grabbing data from each level, then assembling into a 
+  !   3D array.
+  !
+  data_allocated = 0
+  last_grb_index = -1
+  do zidx = z_start,z_end
+     
+     CALL gr1_get_levels(VarName,zidx,z_end-z_start,soil_layers,vert_stag, &
+          .false., vert_unit,level1,level2)
+     
+     CALL GET_GRIB_INDEX_VALIDTIME_GUESS(fileinfo(DataHandle)%fileindex(:), center, &
+          subcenter, parmtbl, parmid,DateStr,vert_unit,level1, &
+          level2, last_grb_index + 1, grb_index)
+     if (grb_index < 0) then
+        write(msg,*)'Field not found: parmid: ',VarName,parmid,DateStr, &
+             vert_unit,level1,level2
+        call wrf_debug (DEBUG , msg)
+        cycle
+     endif
+
+     if (data_allocated .eq. 0) then
+        CALL GET_SIZEOF_GRID(fileinfo(DataHandle)%fileindex(:),grb_index,numcols,numrows)
+        allocate(data(z_start:z_end,1:numcols*numrows),stat=istat)
+        data_allocated = 1
+     endif
+
+     CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), grb_index, &
+          data(zidx,:))
+
+     !
+     ! Transpose data into the order specified by MemoryOrder, setting only 
+     !   entries within the memory dimensions
+     !
+     CALL get_dims(MemoryOrder, MemoryStart, MemoryEnd, ndim, x_start, x_end, &
+          y_start, y_end,z_start,z_end)
+
+     if(FieldType == WRF_DOUBLE) then
+        di = 2
+     else 
+        di = 1
+     endif
+
+     ! 
+     ! Here, we do any necessary conversions to the data.
+     !
+     ! The WRF executable (wrf.exe) expects perturbation potential
+     !   temperature.  However, real.exe expects full potential T.
+     ! So, if the program is WRF, subtract 300 from Potential Temperature 
+     !   to get perturbation potential temperature.
+     !
+     if (VarName == 'T') then
+        if ( &
+             (InputProgramName .eq. 'REAL_EM') .or. &
+             (InputProgramName .eq. 'IDEAL') .or. &
+             (InputProgramName .eq. 'NDOWN_EM')) then
+           data(zidx,:) = data(zidx,:) - 300
+        endif
+     endif
+
+     CALL Transpose(MemoryOrder, di, FieldType, Field, &
+          MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+          MemoryStart(3), MemoryEnd(3), &
+          data(zidx,:), zidx, numrows, numcols)
+
+     if (zidx .eq. z_end) then
+        data_allocated = 0
+        deallocate(data)
+     endif
+
+     last_grb_index = grb_index
+
+  enddo
+
+  Status = WRF_NO_ERR
+  if (grb_index < 0) Status = WRF_WARN_VAR_NF
+  call wrf_debug ( DEBUG , 'Leaving ext_gr1_read_field')
+
+  RETURN
+END SUBROUTINE ext_gr1_read_field
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_next_var ( DataHandle, VarName, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: VarName
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_next_var')
+
+  Status = WRF_WARN_NOOP
+
+  RETURN
+END SUBROUTINE ext_gr1_get_next_var
+
+!*****************************************************************************
+
+subroutine ext_gr1_end_of_frame(DataHandle, Status)
+
+  USE gr1_data_info
+  implicit none
+#include "wrf_status_codes.h"
+  integer               ,intent(in)     :: DataHandle
+  integer               ,intent(out)    :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_end_of_frame')
+
+  Status = WRF_WARN_NOOP
+
+  return
+end subroutine ext_gr1_end_of_frame
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_iosync ( DataHandle, Status )
+
+  USE gr1_data_info  
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_iosync')
+
+  Status = WRF_NO_ERR
+  if (DataHandle .GT. 0) then
+     CALL flush_file(FileFd(DataHandle))
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_iosync
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_inquire_filename ( DataHandle, FileName , FileStat, &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStat
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER *80   SysDepInfo
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_inquire_filename')
+
+  FileName = DataFile(DataHandle) 
+
+  if ((DataHandle .ge. firstFileHandle) .and. &
+       (DataHandle .le. maxFileHandles)) then
+     FileStat = FileStatus(DataHandle)
+  else
+     FileStat = WRF_FILE_NOT_OPENED
+  endif
+  
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr1_inquire_filename
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_info ( DataHandle , VarName , NDim , &
+     MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: VarName
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)         ,intent(out)    :: Stagger
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_info')
+
+  CALL wrf_message('ext_gr1_get_var_info not supported for grib version1 data')
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_info
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_set_time ( DataHandle, DateStr, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  integer       :: found_time
+  integer       :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_set_time')
+
+  found_time = 0
+  do idx = 1,fileinfo(DataHandle)%NumberTimes
+     if (fileinfo(DataHandle)%Times(idx) == DateStr) then
+        found_time = 1
+        fileinfo(DataHandle)%CurrentTime = idx
+     endif
+  enddo
+  if (found_time == 0) then 
+     Status = WRF_WARN_TIME_NF
+  else
+     Status = WRF_NO_ERR
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_set_time
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_next_time ( DataHandle, DateStr, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(OUT) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_next_time')
+
+  if (fileinfo(DataHandle)%CurrentTime == fileinfo(DataHandle)%NumberTimes) then
+     Status = WRF_WARN_TIME_EOF
+  else
+     fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime + 1
+     DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
+     Status = WRF_NO_ERR
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_next_time
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_previous_time ( DataHandle, DateStr, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_previous_time')
+
+  if (fileinfo(DataHandle)%CurrentTime <= 0) then
+     Status = WRF_WARN_TIME_EOF
+  else
+     fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime - 1
+     DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
+     Status = WRF_NO_ERR
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_previous_time
+
+!******************************************************************************
+!* Start of get_var_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_real ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(OUT)   :: Data(*)
+  INTEGER ,       INTENT(IN)    :: Count
+  INTEGER ,       INTENT(OUT)   :: OutCount
+  INTEGER ,       INTENT(OUT)   :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       Varname, Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)      :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(OUT)     :: Data(*)
+  INTEGER ,       INTENT(IN)      :: Count
+  INTEGER ,       INTENT(OUT)     :: OutCount
+  INTEGER ,       INTENT(OUT)     :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),&
+       "none",Varname,Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_double ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
+       "none", Varname, &
+       Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_integer ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)       :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(OUT)      :: Data(*)
+  INTEGER ,       INTENT(IN)       :: Count
+  INTEGER ,       INTENT(OUT)      :: OutCount
+  INTEGER ,       INTENT(OUT)      :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
+       "none", Varname, Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_logical ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)       :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(OUT)      :: Data(*)
+  INTEGER ,       INTENT(IN)       :: Count
+  INTEGER ,       INTENT(OUT)      :: OutCount
+  INTEGER ,       INTENT(OUT)      :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
+       "none", Varname, Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_ti_char ( DataHandle,Element,  Varname, Data,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_char')
+
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
+       "none", Varname, Data,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_ti_char 
+
+!******************************************************************************
+!* End of get_var_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_var_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_real ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_real')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_double ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_double')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_ti_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_real8')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_integer ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_integer')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_logical ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_logical')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr1_put_var_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_ti_char ( DataHandle,Element,  Varname, Data,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER(len=*) :: Element
+  CHARACTER(len=*) :: VarName 
+  CHARACTER(len=*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  INTEGER                     :: Count
+  CHARACTER(len=1000) :: tmpstr(1)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_char')
+
+  if (committed(DataHandle)) then
+
+     write(tmpstr(1),*)trim(Data)
+
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_ti_char 
+
+!******************************************************************************
+!* End of put_var_ti_* routines
+!******************************************************************************
+
+!******************************************************************************
+!* Start of get_var_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_double ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count, Outcount, Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: DateStr
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),DateStr,&
+       Varname,Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+RETURN
+END SUBROUTINE ext_gr1_get_var_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_real ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       Varname, Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),DateStr,&
+       Varname,Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       Varname, Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+  
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       Varname, Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_var_td_char ( DataHandle,Element,  DateStr,Varname, &
+     Data,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_char')
+
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       Varname, Data,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_var_td_char 
+
+!******************************************************************************
+!* End of get_var_td_* routines
+!******************************************************************************
+
+!******************************************************************************
+!* Start of put_var_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_double ( DataHandle, Element, DateStr, Varname, &
+     Data, Count,  Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: DateStr
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_double')
+
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr1_put_var_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_integer ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_integer')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr1_put_var_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_real ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_real')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_real8')
+
+  if (committed(DataHandle)) then
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_logical ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_logical')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_var_td_char ( DataHandle,Element,  DateStr,Varname, &
+     Data,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_char')
+
+  if (committed(DataHandle)) then
+
+     write(tmpstr(idx),*)Data
+
+     CALL gr1_build_string (td_output(DataHandle), &
+          Varname//';'//DateStr//';'//Element, tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_var_td_char 
+
+!******************************************************************************
+!* End of put_var_td_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of get_dom_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_real ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Outcount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_real8 ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_integer ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_integer Element: '//Element)
+
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = Count
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_logical ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+  INTEGER       :: endchar
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_char')
+
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_ti_double ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
+       "none", Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+RETURN
+END SUBROUTINE ext_gr1_get_dom_ti_double
+
+!******************************************************************************
+!* End of get_dom_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_dom_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_real ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr(1000)
+  character(len=2)    :: lf
+  integer             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_real')
+
+  if (Element .eq. 'DX') then
+     dx = Data(1)/1000.
+  endif
+  if (Element .eq. 'DY') then
+     dy = Data(1)/1000.
+  endif
+  if (Element .eq. 'CEN_LAT') then
+     center_lat = Data(1)
+  endif
+  if (Element .eq. 'CEN_LON') then
+     center_lon = Data(1)
+  endif  
+  if (Element .eq. 'TRUELAT1') then
+     truelat1 = Data(1)
+  endif
+  if (Element .eq. 'TRUELAT2') then
+     truelat2 = Data(1)
+  endif
+  if (Element == 'STAND_LON') then
+     proj_central_lon = Data(1)
+  endif
+  if (Element == 'DT') then
+     timestep = Data(1)
+  endif
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_real8 ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_real8')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  INTEGER ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_integer')
+
+  if (Element == 'WEST-EAST_GRID_DIMENSION') then
+     full_xsize = Data(1)
+  else if (Element == 'SOUTH-NORTH_GRID_DIMENSION') then
+     full_ysize = Data(1)
+  else if (Element == 'MAP_PROJ') then
+     projection = Data(1)
+  endif
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr1_put_dom_ti_integer')
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_logical')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_char ( DataHandle,Element,   Data,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*),     INTENT(IN)  :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr(1000)
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_char')
+
+  if (Element .eq. 'START_DATE') then
+     StartDate = Data
+  endif
+
+  if (committed(DataHandle)) then
+
+     write(tmpstr(1),*)trim(Data)
+     
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_char
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_ti_double ( DataHandle,Element, Data, Count, &
+     Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_double')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
+
+  endif
+  
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_ti_double
+
+!******************************************************************************
+!* End of put_dom_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of get_dom_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_real ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Value,stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_char')
+
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_get_dom_td_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_get_dom_td_double ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
+       "none", Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+RETURN
+END SUBROUTINE ext_gr1_get_dom_td_double
+
+!******************************************************************************
+!* End of get_dom_td_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_dom_td_* routines
+!******************************************************************************
+
+
+SUBROUTINE ext_gr1_put_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_real8')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_integer')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_td_integer
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_logical')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_td_logical
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_td_char ( DataHandle,Element, DateStr,  Data, &
+     Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER(len=*), INTENT(IN)  :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1)
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_char')
+
+  if (committed(DataHandle)) then
+
+     write(tmpstr(1),*)Data
+
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_td_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_td_double ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_double')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr1_put_dom_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr1_put_dom_td_real ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr1_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_real')
+
+  if (committed(DataHandle)) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr1_put_dom_td_real 
+
+
+!******************************************************************************
+!* End of put_dom_td_* routines
+!******************************************************************************
+
+
+!*****************************************************************************
+
+SUBROUTINE gr1_build_string (string, Element, Value, Count, Status)
+
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+
+  CHARACTER (LEN=*) , INTENT(INOUT) :: string
+  CHARACTER (LEN=*) , INTENT(IN)    :: Element
+  CHARACTER (LEN=*) , INTENT(IN)    :: Value(*)
+  INTEGER ,           INTENT(IN)    :: Count
+  INTEGER ,           INTENT(OUT)   :: Status
+
+  CHARACTER (LEN=2)                 :: lf
+  INTEGER                           :: IDX
+
+  lf=char(10)//' '
+  if (len_trim(string) == 0) then
+     string = lf//Element//' = '
+  else
+     string = trim(string)//lf//Element//' = '
+  endif
+  do idx = 1,Count
+     if (idx > 1) then
+        string = trim(string)//','
+     endif
+     string = trim(string)//' '//trim(adjustl(Value(idx)))
+  enddo
+
+  Status = WRF_NO_ERR
+
+END SUBROUTINE gr1_build_string
+
+!*****************************************************************************
+
+SUBROUTINE gr1_get_new_handle(DataHandle)
+  USE gr1_data_info
+  IMPLICIT NONE
+  
+  INTEGER ,       INTENT(OUT)  :: DataHandle
+  INTEGER :: i
+
+  DataHandle = -1
+  do i=firstFileHandle, maxFileHandles
+     if (.NOT. used(i)) then
+        DataHandle = i
+        used(i) = .true.
+        exit
+     endif
+  enddo
+
+  RETURN
+END SUBROUTINE gr1_get_new_handle
+
+
+!******************************************************************************
+
+
+SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction, &
+     vert_unit, level1, level2)
+
+  use gr1_data_info
+  IMPLICIT NONE
+
+  integer :: zidx
+  integer :: zsize
+  logical :: soil_layers
+  logical :: vert_stag
+  logical :: fraction
+  integer :: vert_unit
+  integer :: level1
+  integer :: level2
+  character (LEN=*) :: VarName
+
+  ! Setup vert_unit, and vertical levels in grib units
+
+  if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCTOP') &
+       .or. (VarName .eq. 'SOILCBOT')) then
+     vert_unit = 109;
+     level1 = zidx
+     level2 = 0
+  else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) &
+       then
+     vert_unit = 119;
+     if (vert_stag) then
+        level1 = (10000*full_eta(zidx)+0.5)
+     else
+        level1 = (10000*half_eta(zidx)+0.5)
+     endif
+     level2 = 0
+  else
+     ! Set the vertical coordinate and level for soil and 2D fields
+     if (fraction) then
+        vert_unit = 109
+        level1 = zidx
+        level2 = 0           
+     else if (soil_layers) then
+        vert_unit = 112
+        level1 = 100*(soil_depth(zidx) - 0.5*soil_thickness(zidx))+0.5
+        level2 = 100*(soil_depth(zidx) + 0.5*soil_thickness(zidx))+0.5
+     else if (VarName .eq. 'mu') then
+        vert_unit = 200
+        level1 = 0
+        level2 = 0
+     else if ((VarName .eq. 'Q2') .or. (VarName .eq. 'TH2') .or. &
+        (VarName .eq. 'T2')) then
+        vert_unit = 105
+        level1 = 2
+        level2 = 0
+     else if ((VarName .eq. 'Q10') .or. (VarName .eq. 'TH10') .or. &
+          (VarName .eq. 'U10') .or. (VarName .eq. 'V10')) then
+        vert_unit = 105
+        level1 = 10
+        level2 = 0
+     else 
+        vert_unit = 1
+        level1 = 0
+        level2 = 0
+     endif
+  endif
+
+end SUBROUTINE gr1_get_levels
+
+!*****************************************************************************
+
+
+SUBROUTINE gr1_fill_eta_levels(fileindex, FileFd, grib_tables, VarName, eta_levels)
+  IMPLICIT NONE
+
+  CHARACTER (len=*) :: fileindex
+  INTEGER   :: FileFd
+  CHARACTER (len=*) :: grib_tables
+  character (len=*) :: VarName
+  REAL,DIMENSION(*) :: eta_levels
+
+  INTEGER   :: center, subcenter, parmtbl
+  INTEGER   :: swapped
+  INTEGER   :: leveltype
+  INTEGER   :: idx
+  INTEGER   :: parmid
+  INTEGER   :: tablenum
+  REAL      :: tmp
+  INTEGER   :: numindices
+  integer , DIMENSION(1000)   :: indices
+
+  !
+  ! Read the levels from the grib file
+  !
+  CALL GET_GRIB_PARAM(grib_tables, VarName, center, subcenter, parmtbl, &
+       tablenum, parmid)
+
+  if (parmid == -1) then
+     call wrf_message ('Error getting grib parameter')
+  endif
+
+  leveltype = 119
+
+  CALL GET_GRIB_INDICES(fileindex(:), center, subcenter, parmtbl, &
+       parmid, "*", leveltype, &
+       -HUGE(1), -HUGE(1), -HUGE(1), -HUGE(1), indices, numindices)
+
+  do idx = 1,numindices
+     CALL READ_GRIB(fileindex(:),FileFd,indices(idx),eta_levels(idx))
+  enddo
+
+  !
+  ! Sort the levels--from highest (bottom) to lowest (top)
+  !
+  swapped = 1
+  sortloop : do
+     if (swapped /= 1) exit sortloop
+     swapped = 0
+     do idx=2, numindices
+        if (eta_levels(idx) > eta_levels(idx-1)) then
+          tmp = eta_levels(idx)
+          eta_levels(idx) = eta_levels(idx - 1)
+          eta_levels(idx - 1) = tmp
+          swapped = 1
+        endif
+     enddo
+  enddo sortloop
+
+end subroutine gr1_fill_eta_levels
+
diff --git a/wrfv2_fire/external/io_grib1/test.grb b/wrfv2_fire/external/io_grib1/test.grb
new file mode 100644
index 00000000..f5c4dc18
Binary files /dev/null and b/wrfv2_fire/external/io_grib1/test.grb differ
diff --git a/wrfv2_fire/external/io_grib1/test_grib1_routines.F b/wrfv2_fire/external/io_grib1/test_grib1_routines.F
new file mode 100644
index 00000000..d67742fc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_grib1_routines.F
@@ -0,0 +1,89 @@
+
+PROGRAM test_grib1_routines
+  IMPLICIT NONE
+
+  CHARACTER, DIMENSION(:), POINTER :: fileindex
+  REAL     , DIMENSION(:), POINTER :: data
+  INTEGER :: fid
+  INTEGER :: err
+  INTEGER :: ret
+  INTEGER :: size
+  INTEGER :: index
+  INTEGER :: istat
+
+  INTEGER :: parmid
+  CHARACTER(40) :: datestr
+  INTEGER :: leveltype 
+  INTEGER :: level1
+  INTEGER :: level2
+  INTEGER :: fcsttime1
+  INTEGER :: fcsttime2
+  character(200) :: value
+  character(20) :: strval
+  integer :: test
+  character(50) :: form
+  integer :: NumberTimes
+  character (19) :: Time
+  character (19), pointer  :: Times(:)
+  integer :: ierr
+  integer :: numcols, numrows
+  integer :: center, subcenter, parmtbl
+  
+
+  parmid=33
+  datestr = '2005041412'
+  leveltype = 119
+  level1 = 9965
+  level2 = -HUGE(1)
+  fcsttime1 = 0
+  fcsttime2 = -HUGE(1)
+  center = 250
+  subcenter = 2
+  parmtbl = 200
+
+  print *,'about to call GET_FILEINDEX_SIZE'
+  CALL GET_FILEINDEX_SIZE(size)
+  ALLOCATE(fileindex(1:size), STAT=istat)
+
+  print *,'about to call ALLOC_INDEX_FILE'
+  CALL ALLOC_INDEX_FILE(fileindex)
+  print *,'about to call OPEN_FILE'
+  CALL OPEN_FILE('test.grb','r',fid,err)
+  print *,'about to call INDEX_FILE'
+  CALL INDEX_FILE(fid,fileindex)
+
+  print *,'about to call GET_GRIB_INDEX'
+  CALL GET_GRIB_INDEX(fileindex, center, subcenter, parmtbl, &
+       parmid,trim(datestr),leveltype,level1,level2, &
+       fcsttime1,fcsttime2,index)
+  print *,'got grib index: ',index
+
+  print *,'about to call GET_METADATA_VALUE'
+  CALL GET_METADATA_VALUE(fileindex, 'GRIB_GRID_ID', "none", "none", &
+       Value, istat)
+
+  print *,'about to call GET_NUM_TIMES'
+  CALL GET_NUM_TIMES(fileindex, NumberTimes)
+  print *,'found ',NumberTimes,' times'
+
+  ALLOCATE(Times(1:NumberTimes), STAT=ierr)
+  print *,'about to call GET_TIME'
+  CALL GET_TIME(fileindex,1,Time)
+  print *,'Time: ',Time
+
+  print *,'about to call GET_SIZEOF_GRID'
+  CALL GET_SIZEOF_GRID(fileindex,index,numcols,numrows)
+  allocate(data(1:numcols*numrows))
+
+  print *,'about to call READ_GRIB'
+  CALL READ_GRIB(fileindex,fid,index,data)
+  print *,'data(20): ',data(20)
+
+  deallocate(data)
+
+  print *,'about to call FREE_INDEX_FILE'
+  CALL FREE_INDEX_FILE(fileindex)
+
+  print *,'program completed'
+
+END PROGRAM
diff --git a/wrfv2_fire/external/io_grib1/test_gribmap.F90 b/wrfv2_fire/external/io_grib1/test_gribmap.F90
new file mode 100644
index 00000000..c42a6a20
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_gribmap.F90
@@ -0,0 +1,21 @@
+PROGRAM test
+  IMPLICIT NONE
+
+  CHARACTER, DIMENSION(:), POINTER :: grib_table_info
+  INTEGER :: ret
+  INTEGER :: size
+  INTEGER :: index
+  INTEGER :: istat
+
+  CALL GET_GRIB1_TABLE_INFO_SIZE(size)
+  ALLOCATE(grib_table_info(1:size), STAT=istat)
+  CALL LOAD_GRIB1_TABLE_INFO("gribmap.txt",grib_table_info,ret)
+  print *,'ret: ',ret
+  print *,'again'
+  CALL GET_GRIB_PARAM (grib_table_info, "TSK", index);
+  print *,'got index: ',index
+
+
+print *,'here1'
+
+END PROGRAM
diff --git a/wrfv2_fire/external/io_grib1/test_grid_info.F90 b/wrfv2_fire/external/io_grib1/test_grid_info.F90
new file mode 100644
index 00000000..14c19f6b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_grid_info.F90
@@ -0,0 +1,40 @@
+
+
+PROGRAM test
+  IMPLICIT NONE
+
+  CHARACTER, DIMENSION(:), POINTER :: grib_table_info
+  CHARACTER, DIMENSION(:), POINTER :: grid_info
+  INTEGER :: ret
+  INTEGER :: size
+  INTEGER :: index
+  INTEGER :: istat
+  
+
+  CALL GET_GRIB1_TABLE_INFO_SIZE(size)
+  ALLOCATE(grib_table_info(1:size), STAT=istat)
+  CALL LOAD_GRIB1_TABLE_INFO("gribmap.txt",grib_table_info,ret)
+  print *,'ret: ',ret
+  print *,'again'
+  CALL GET_GRIB_PARAM (grib_table_info, "TSK", index);
+  print *,'got index: ',index
+
+  CALL GET_GRID_INFO_SIZE(size)
+  ALLOCATE(grid_info(1:size), STAT=istat)
+  CALL LOAD_GRID_INFO("test", "200509081200", 1, &
+       1.0, 1.0, 1440.0, &
+       0, 240, 1, &
+       450, 250, 45.0, &
+       -100.0, 12.0, 12.0, -101.0, &
+       1, 30.0, &
+       60.0, grib_table_info, &
+       grid_info)
+
+  print *,'here!'
+  CALL PRINT_GRID_INFO(grid_info)
+  CALL FREE_GRID_INFO(grid_info)
+
+print *,'here1'
+
+END PROGRAM
+
diff --git a/wrfv2_fire/external/io_grib1/test_io_grib1.F b/wrfv2_fire/external/io_grib1/test_io_grib1.F
new file mode 100644
index 00000000..646fd2ac
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_io_grib1.F
@@ -0,0 +1,61 @@
+PROGRAM test_io_grib2
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+
+  integer            :: Status
+  character(len=80)  :: SysDepInfo
+  character(len=80)  :: FileName = 'test.gr2'
+  integer            :: Comm
+  integer            :: IOComm
+  integer            :: DataHandle
+  integer            :: FileStat
+  real, DIMENSION( 1:1, 1:4, 1:4, 1:4) :: Field
+  integer            :: DomainDesc
+  character(len=3)   :: MemoryOrder = 'XZY'
+  character(len=3)   :: Stagger = ''
+  character(len=100) :: DimNames = ''
+  integer, dimension(3) :: DomainStart, DomainEnd, MemoryStart, &
+       MemoryEnd, PatchStart, PatchEnd
+
+  DomainStart(1) = 1
+  DomainStart(2) = 1
+  DomainStart(3) = 1
+  DomainEnd(1) = 4
+  DomainEnd(2) = 4
+  DomainEnd(3) = 4
+
+  MemoryStart(1) = 1
+  MemoryStart(2) = 1
+  MemoryStart(3) = 1
+  MemoryEnd(1) = 4
+  MemoryEnd(2) = 4
+  MemoryEnd(3) = 4
+
+  PatchStart(1) = 1
+  PatchStart(2) = 1
+  PatchStart(3) = 1
+  PatchEnd(1) = 4
+  PatchEnd(2) = 4
+  PatchEnd(3) = 4
+
+  call ext_gr1_ioinit(SysDepInfo,Status)
+
+  call ext_gr1_ioexit(Status)
+
+  call ext_gr1_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
+     DataHandle, Status)
+
+  call ext_gr1_open_for_write_commit( DataHandle , Status )
+
+  call ext_gr1_inquire_opened ( DataHandle, FileName , FileStat, Status )
+
+  Field(1,1,1,1) = 2.1
+  call ext_gr1_write_field ( DataHandle, "2005-07-27_12:00:00","POT",Field, &
+       WRF_REAL, Comm, IOComm, DomainDesc, MemoryOrder, Stagger, &
+       DimNames, DomainStart, DomainEnd, MemoryStart, MemoryEnd, &
+       PatchStart, PatchEnd, Status)
+
+
+  call ext_gr1_ioclose ( DataHandle, Status )
+
+END PROGRAM
diff --git a/wrfv2_fire/external/io_grib1/test_read_gribmap.c b/wrfv2_fire/external/io_grib1/test_read_gribmap.c
new file mode 100644
index 00000000..ed1d8516
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_read_gribmap.c
@@ -0,0 +1,23 @@
+#include 
+#include 
+
+#include "gribmap.h"
+main()
+{
+  int center, subcenter, parmtbl, parm_id, dec_sc_factor;
+  int ret;
+  int idx;
+  Grib_Table_Info grib_table_info;
+
+  /*  get_grib_param_("gribmap.txt","TMN",¢er,&subcenter,&parmtbl,&parm_id,&dec_sc_factor);
+   */
+  read_gribmap_("gribmap.txt",&grib_table_info,&ret);
+
+  fprintf(stdout,"%d:%d:%d:%d\n",grib_table_info.center,
+	  grib_table_info.subcenter,grib_table_info.parmtbl,
+	  grib_table_info.gribid);
+
+  get_grib_param_(&grib_table_info,"TMN",&idx);
+  fprintf(stdout,"idx: %d\n",idx);
+
+}
diff --git a/wrfv2_fire/external/io_grib1/test_write_grib.c b/wrfv2_fire/external/io_grib1/test_write_grib.c
new file mode 100644
index 00000000..f521cef4
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/test_write_grib.c
@@ -0,0 +1,87 @@
+#include 
+#include 
+#include "grib1_routines.h"
+
+#define LATLON 0
+#define LAMBERT 1
+#define POLAR_STEREO 2
+#define MERCATOR 3
+
+main()
+{
+  int level;
+  int projection;
+  int xdim;
+  int ydim;
+  int grid_id;
+  float center_lat, center_lon;
+  float proj_central_lon;
+  float dx, dy;
+  int south;
+  float latin1, latin2;
+  float *data;
+  int filefd;
+  int error;
+  char datestr[200];
+  int i,j;
+  float fcst_secs;
+  int accum_period;
+  int leveltype;
+  int level2;  
+  Grib1_Tables grib1_tables;
+  int ret;
+  int status;
+  Grid_Info gridinfo;
+
+  level = 9950;
+  projection = LAMBERT;
+  xdim = 422;
+  ydim = 271;
+  center_lat = 0.0;
+  center_lon = 0.0;
+  proj_central_lon = -100.0;
+  dx = 12.0;
+  dy = 12.0;
+  south = 0;
+  latin1 = 30.0;
+  latin2 = 60.0;
+  data = (float *)calloc(xdim*ydim,sizeof(float));
+  fcst_secs = 360;
+  accum_period = 0;
+  leveltype = 119;
+  level2 = 0;
+  grid_id = 255;
+
+  read_gribmap_("gribmap.txt",&grib1_tables,&ret);
+
+  open_file_("test2.grb","w",&filefd,&error,9,1);
+  strcpy(datestr,"2005-01-01_00:00:00");
+  for (i=0; i< 1; i++) {
+    for (j=0; j
+#include 
+
+char *trim (char *str)
+{
+      char *ibuf, *obuf;
+
+      if (str)
+      {
+            for (ibuf = obuf = str; *ibuf; )
+            {
+                  while (*ibuf && (isspace (*ibuf)))
+                        ibuf++;
+                  if (*ibuf && (obuf != str))
+                        *(obuf++) = ' ';
+                  while (*ibuf && (!isspace (*ibuf)))
+                        *(obuf++) = *(ibuf++);
+            }
+            *obuf = '\0';
+      }
+      return (str);
+}
+
diff --git a/wrfv2_fire/external/io_grib1/wrf_status_codes.h b/wrfv2_fire/external/io_grib1/wrf_status_codes.h
new file mode 100644
index 00000000..059d9ea7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib1/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/wrfv2_fire/external/io_grib2/Makefile b/wrfv2_fire/external/io_grib2/Makefile
new file mode 100644
index 00000000..36e34bec
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/Makefile
@@ -0,0 +1,84 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I.
+BUILD_DIR = $(IO_GRIB_SHARE_DIR)../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = .
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+F_INCLUDES   = -I. -Ig2lib -Ibacio-1.3 -I../io_grib_share
+ARFLAGS      = cruv
+
+FORMAT = $(FREE)
+
+#
+#  List of subdirectories to which to pass make commands.
+#
+LIB_DIRS = \
+	bacio-1.3 \
+	g2lib
+EXE_DIRS =
+SUB_DIRS = $(LIB_DIRS) $(EXE_DIRS)
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib2
+SYS_DEFINES =
+DEP_LIBS = 
+OBJS =  \
+	grib2tbls_types.o \
+	io_grib2.o \
+	read_grib2map.o
+
+#
+#  Clean up old build files
+#
+superclean:
+	/bin/rm -f *.o > /dev/null 2>&1
+	/bin/rm -f *.f90 > /dev/null 2>&1
+	/bin/rm -f *.mod > /dev/null 2>&1
+	/bin/rm -f *.a > /dev/null 2>&1
+	( cd bacio-1.3 ; make clean )
+	( cd g2lib ; make clean )
+
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib2/README.io_grib2 b/wrfv2_fire/external/io_grib2/README.io_grib2
new file mode 100644
index 00000000..a35b5ca2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/README.io_grib2
@@ -0,0 +1,78 @@
+io_grib2
+
+Author: Todd Hutchinson
+        WSI
+        thutchinson@wsi.com
+
+28 September 2005
+
+I. Introduction
+
+io_grib2 is a WRF module that allows for input and output of WRF data in GRIB
+version 2 format.
+
+Why would anyone use GRIB2 output?  
+  Data stored in GRIB2 format is compressed using advanced compression 
+    (i.e., JPEG2000), so output files are much smaller than in other formats 
+    such as netCDF and grib version 1.  Better compression is achieved with 
+    larger grids.
+
+II. Prerequisites
+
+  In order to compile and link WRF using the grib2 format, one system library
+  is required:
+    libjasper.a:  http://www.ece.uvic.ca/~mdadams/jasper/
+
+  The library should be installed in a system accessible place (i.e., 
+       /usr/lib).  The paths to the jasper library and include files must be 
+       specified via environment variables prior to running ./configure .  
+       Please use the following environment variables:  
+         JASPERLIB  Path to jasper library files (libjasperlib.a)
+         JASPERINC  Path to jasper include files
+       Note that if these environment variables are not defined before 
+       ./configure is run, the Grib2 I/O package will not be built.  
+
+III. Running WRF with grib2 input/output
+  1. Set namelist entry or entries io_form_ to 10
+  2. Run WRF as you normally would, for example:
+     cd test/em_real
+     ./real.exe
+     ./wrf.exe
+
+IV. Quilting
+  If you are running WRF using MPI, you may use a seperate processor for
+    quilting just as is done with netCDF.  Simply set the namelist variable
+    nio_tasks_per_group to 1 (or more).
+
+V. Details
+  1. grib2map.tbl file
+     io_grib2 makes use of a table for encoding the WRF data into GRIB2 
+        format.  The table that io_grib2 uses is contained in the 
+        WRF run directory, and is called grib2map.tbl.  This file is read at
+        run-time by io_grib2.  Settings in this file are used to encode the 
+	corresponding parameters in the output files.  You may modify 
+	this file to suit your needs.
+
+      The format of the table is described within the file itself.
+
+VI. Comparison between file formats.  
+  1. The following table shows the file sizes and run times for netcdf, grib1, 
+     and grib2 format for a 6 hour simlation of the WRF jun11 test case.  The 
+     domain size in this case is 91x82 by 28 levels.  Data was output every 
+     3 hours (for a total of 3 output times).  The simulations were run on 
+     NCAR's bluesky system.
+
+                    |  Size (MB)  | WRF Time(m:s)
+            ------------------------------------
+            NETCDF  |   38.40     |     19:31   |
+            GRIB1   |   13.42     |     21:22   |
+            GRIB2   |    4.33     |     22:36   |
+            ------------------------------------
+
+VII. New namelist variables for Grib2 I/O:  
+  The grib2 namelist variables may be optionally used to control 
+  Grib2 I/O.  They are defined in new namelist "&grib2".  Note that the 
+  &grib2 namelist must be included in file "namelist.input" even if empty.  
+  (This annoyance is ultimately due to problems with old OSF1 Fortran90 
+  compilers.)  Information on the variables is located in the WRFV2/run
+  directory: README.namelist.
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/Makefile b/wrfv2_fire/external/io_grib2/bacio-1.3/Makefile
new file mode 100644
index 00000000..8672e60e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/Makefile
@@ -0,0 +1,67 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I. 
+BUILD_DIR = ../../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = ..
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+FORMAT       = $(FREE)
+
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib2
+SYS_DEFINES = 
+DEP_LIBS = 
+FORMAT       = $(FIXED)
+ARFLAGS      = ruv
+OBJS =  \
+	bacio.v1.3.o \
+	baciof.o
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/README b/wrfv2_fire/external/io_grib2/bacio-1.3/README
new file mode 100644
index 00000000..326cc0c2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/README
@@ -0,0 +1,15 @@
+                                                           Aug 21, 2003
+                                                           W/NP11:SAG
+
+BACIO Library.
+
+This library contains Fortran 90 interface to "C"
+language I/O routines.
+
+The Fortran routines call "C" functions, which must
+follow a specific symbol naming convention used by your
+machine/loader to be linked successfully.
+If you are having trouble linking to the routines
+in this library, please make sure the appropriate 
+machine is defined in the "clib.h" file and
+recompile the library.
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/bacio.v1.3.c b/wrfv2_fire/external/io_grib2/bacio-1.3/bacio.v1.3.c
new file mode 100644
index 00000000..d7597582
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/bacio.v1.3.c
@@ -0,0 +1,541 @@
+/* Fortran-callable routines to read and write characther (bacio) and */
+/*   numeric (banio) data byte addressably                            */
+/* Robert Grumbine  16 March 1998 */
+/*  v1.1: Put diagnostic output under control of define VERBOSE or QUIET */
+/*        Add option of non-seeking read/write                           */
+/*        Return code for fewer data read/written than requested */
+/*  v1.2: Add cray compatibility  20 April 1998                  */
+
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+#include 
+
+/* Include the C library file for definition/control */
+/* Things that might be changed for new systems are there. */
+/* This source file should not (need to) be edited, merely recompiled */
+#include "clib.h"
+
+
+/* Return Codes:  */
+/*  0    All was well                                   */
+/* -1    Tried to open read only _and_ write only       */
+/* -2    Tried to read and write in the same call       */
+/* -3    Internal failure in name processing            */
+/* -4    Failure in opening file                        */
+/* -5    Tried to read on a write-only file             */ 
+/* -6    Failed in read to find the 'start' location    */
+/* -7    Tried to write to a read only file             */
+/* -8    Failed in write to find the 'start' location   */
+/* -9    Error in close                                 */
+/* -10   Read or wrote fewer data than requested        */
+
+/* Note: In your Fortran code, call bacio, not bacio_.  */
+/*int bacio_(int * mode, int * start, int * size, int * no, int * nactual,   */ 
+/*          int * fdes, const char *fname, char *data, int  namelen,         */ 
+/*          int  datanamelen)                                                */
+/* Arguments: */
+/* Mode is the integer specifying operations to be performed                 */
+/*    see the clib.inc file for the values.  Mode is obtained                */
+/*    by adding together the values corresponding to the operations          */
+/*    The best method is to include the clib.inc file and refer to the       */
+/*    names for the operations rather than rely on hard-coded values         */
+/* Start is the byte number to start your operation from.  0 is the first    */
+/*    byte in the file, not 1.                                               */
+/* Newpos is the position in the file after a read or write has been         */
+/*    performed.  You'll need this if you're doing 'seeking' read/write      */
+/* Size is the size of the objects you are trying to read.  Rely on the      */
+/*    values in the locale.inc file.  Types are CHARACTER, INTEGER, REAL,    */
+/*    COMPLEX.  Specify the correct value by using SIZEOF_type, where type   */
+/*    is one of these.  (After having included the locale.inc file)          */
+/* no is the number of things to read or write (characters, integers,        */
+/*                                                              whatever)    */
+/* nactual is the number of things actually read or written.  Check that     */
+/*    you got what you wanted.                                               */
+/* fdes is an integer 'file descriptor'.  This is not a Fortran Unit Number  */
+/*    You can use it, however, to refer to files you've previously opened.   */
+/* fname is the name of the file.  This only needs to be defined when you    */
+/*    are opening a file.  It must be (on the Fortran side) declared as      */
+/*    CHARACTER*N, where N is a length greater than or equal to the length   */
+/*    of the file name.  CHARACTER*1 fname[80] (for example) will fail.      */
+/* data is the name of the entity (variable, vector, array) that you want    */
+/*    to write data out from or read it in to.  The fact that C is declaring */
+/*    it to be a char * does not affect your fortran.                        */
+/* namelen - Do NOT specify this.  It is created automagically by the        */
+/*    Fortran compiler                                                       */
+/* datanamelen - Ditto                                                       */ 
+
+
+int BACIO
+(int * mode, int * start, int *newpos, int * size, int * no, 
+ int * nactual, int * fdes, const char *fname, char *datary, 
+ int  namelen, int  datanamelen) 
+{
+  int i, j, jret, seekret;
+  char *realname, *tempchar;
+  int tcharval;
+  size_t count;
+
+/* Initialization(s) */
+  *nactual = 0;
+
+/* Check for illegal combinations of options */
+  if (( BAOPEN_RONLY & *mode) &&
+     ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) {
+     #ifdef VERBOSE
+       printf("illegal -- trying to open both read only and write only\n");
+     #endif
+     return -1;
+  }
+  if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) {
+     #ifdef VERBOSE
+       printf("illegal -- trying to both read and write in the same call\n");
+     #endif
+     return -2;
+  }
+
+/* This section handles Fortran to C translation of strings so as to */
+/*   be able to open the files Fortran is expecting to be opened.    */
+  #ifdef CRAY90
+    namelen = _fcdlen(fcd_fname);
+    fname   = _fcdtocp(fcd_fname);
+  #endif
+
+  realname = (char *) malloc( (namelen+1) * sizeof(char) ) ;
+  if (realname == NULL) { 
+    #ifdef VERBOSE
+      printf("failed to mallocate realname %d = namelen\n", namelen);
+      fflush(stdout);
+    #endif
+    return -3;
+  }
+
+  if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || 
+       (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ||
+       (BAOPEN_RW & *mode) ) {
+    #ifdef VERBOSE
+      printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout);
+      printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout);
+    #endif
+    tempchar = (char *) malloc(sizeof(char) * 1 ) ;
+    i = 0;
+    j = 0;
+    *tempchar = fname[i];
+    tcharval = *tempchar;
+    while (i == j && i < namelen ) {
+       fflush(stdout); 
+       if ( isgraph(tcharval) ) {
+         realname[j] = fname[i];
+         j += 1;
+       }
+       i += 1;
+       *tempchar = fname[i];
+       tcharval = *tempchar;
+    }
+    #ifdef VERBOSE
+      printf("i,j = %d %d\n",i,j); fflush(stdout);
+    #endif
+    realname[j] = '\0';
+    free(tempchar);
+  } 
+   
+/* Open files with correct read/write and file permission. */
+  if (BAOPEN_RONLY & *mode) {
+    #ifdef VERBOSE
+      printf("open read only %s\n", realname);
+    #endif
+     *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY_TRUNC & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only with truncation %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY_APPEND & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only with append %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_RW & *mode) {
+    #ifdef VERBOSE
+      printf("open read-write %s\n", realname);
+    #endif
+     *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else {
+    #ifdef VERBOSE
+      printf("no openings\n");
+    #endif
+  }
+  if (*fdes < 0) {
+    #ifdef VERBOSE
+      printf("error in file descriptor! *fdes %d\n", *fdes);
+    #endif
+    return -4;
+  }
+  else {
+    #ifdef VERBOSE
+      printf("file descriptor = %d\n",*fdes );
+    #endif
+  }
+
+
+/* Read data as requested */
+  if (BAREAD & *mode &&
+   ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) {
+    #ifdef VERBOSE
+      printf("Error, trying to read while in write only mode!\n");
+    #endif
+    return -5;
+  }
+  else if (BAREAD & *mode ) {
+  /* Read in some data */
+    if (! (*mode & NOSEEK) ) {
+      seekret = lseek(*fdes, *start, SEEK_SET);
+      if (seekret == -1) {
+        #ifdef VERBOSE
+          printf("error in seeking to %d\n",*start);
+        #endif
+        return -6;
+      }
+      #ifdef VERBOSE
+      else {
+         printf("Seek successful, seek ret %d, start %d\n", seekret, *start);
+      }
+      #endif
+    }
+    #ifdef CRAY90
+      datary = _fcdtocp(fcd_datary);
+    #endif
+    if (datary == NULL) {
+      printf("Massive catastrophe -- datary pointer is NULL\n");
+      return -666;
+    }
+    #ifdef VERBOSE
+      printf("file descriptor, datary = %d %d\n", *fdes, (int) datary);
+    #endif
+    count = (size_t) *no;
+    jret = read(*fdes, (void *) datary, count);
+    if (jret != *no) {
+      #ifdef VERBOSE
+        printf("did not read in the requested number of bytes\n");
+        printf("read in %d bytes instead of %d \n",jret, *no);
+      #endif
+    }  
+    else {
+    #ifdef VERBOSE
+      printf("read in %d bytes requested \n", *no);
+    #endif
+    }
+    *nactual = jret;
+    *newpos = *start + jret;
+  }
+/* Done with reading */
+ 
+/* See if we should be writing */
+  if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) {
+    #ifdef VERBOSE
+      printf("Trying to write on a read only file \n");
+    #endif
+     return -7;
+  }
+  else if ( BAWRITE & *mode ) {
+    if (! (*mode & NOSEEK) ) {
+      seekret = lseek(*fdes, *start, SEEK_SET);
+      if (seekret == -1) {
+      #ifdef VERBOSE
+        printf("error in seeking to %d\n",*start);
+      #endif
+        return -8;
+      }
+    }
+    #ifdef CRAY90
+      datary = _fcdtocp(fcd_datary);
+    #endif
+    if (datary == NULL) {
+      printf("Massive catastrophe -- datary pointer is NULL\n");
+      return -666;
+    }
+    #ifdef VERBOSE
+      printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary);
+    #endif
+    count = (size_t) *no;
+    jret = write(*fdes, (void *) datary, count);
+    if (jret != *no) {
+    #ifdef VERBOSE
+      printf("did not write out the requested number of bytes\n");
+      printf("wrote %d bytes instead\n", jret);
+    #endif
+      *nactual = jret;
+      *newpos = *start + jret;
+    }
+    else {
+    #ifdef VERBOSE
+       printf("wrote %d bytes \n", jret);
+    #endif
+       *nactual = jret;
+       *newpos = *start + jret;
+    }
+  }
+/* Done with writing */
+    
+
+/* Close file if requested */
+  if (BACLOSE & *mode ) {
+    jret = close(*fdes);
+    if (jret != 0) { 
+    #ifdef VERBOSE
+      printf("close failed! jret = %d\n",jret);
+    #endif
+      return -9;
+    }
+  }
+/* Done closing */
+
+  free(realname);
+
+/* Check that if we were reading or writing, that we actually got what */
+/*  we expected, else return a -10.  Return 0 (success) if we're here  */
+/*  and weren't reading or writing */
+  if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) {
+    return -10;
+  }
+  else {
+    return 0;
+  }
+} 
+int BANIO
+(int * mode, int * start, int *newpos, int * size, int * no, 
+ int * nactual, int * fdes, const char *fname, char *datary, 
+ int  namelen ) 
+{
+  int i, j, jret, seekret;
+  char *realname, *tempchar;
+  int tcharval;
+
+/* Initialization(s) */
+  *nactual = 0;
+
+/* Check for illegal combinations of options */
+  if (( BAOPEN_RONLY & *mode) &&
+     ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) {
+     #ifdef VERBOSE
+       printf("illegal -- trying to open both read only and write only\n");
+     #endif
+     return -1;
+  }
+  if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) {
+     #ifdef VERBOSE
+       printf("illegal -- trying to both read and write in the same call\n");
+     #endif
+     return -2;
+  }
+
+/* This section handles Fortran to C translation of strings so as to */
+/*   be able to open the files Fortran is expecting to be opened.    */
+  #ifdef CRAY90
+    namelen = _fcdlen(fcd_fname);
+    fname   = _fcdtocp(fcd_fname);
+  #endif
+  if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || 
+       (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ||
+       (BAOPEN_RW & *mode) ) {
+    #ifdef VERBOSE
+      printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout);
+      printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout);
+    #endif
+    realname = (char *) malloc( (namelen+1) * sizeof(char) ) ;
+    if (realname == NULL) { 
+      #ifdef VERBOSE
+        printf("failed to mallocate realname %d = namelen\n", namelen);
+        fflush(stdout);
+      #endif
+      return -3;
+    }
+    tempchar = (char *) malloc(sizeof(char) * 1 ) ;
+    i = 0;
+    j = 0;
+    *tempchar = fname[i];
+    tcharval = *tempchar;
+    while (i == j && i < namelen ) {
+       fflush(stdout); 
+       if ( isgraph(tcharval) ) {
+         realname[j] = fname[i];
+         j += 1;
+       }
+       i += 1;
+       *tempchar = fname[i];
+       tcharval = *tempchar;
+    }
+    #ifdef VERBOSE
+      printf("i,j = %d %d\n",i,j); fflush(stdout);
+    #endif
+    realname[j] = '\0';
+  } 
+   
+/* Open files with correct read/write and file permission. */
+  if (BAOPEN_RONLY & *mode) {
+    #ifdef VERBOSE
+      printf("open read only %s\n", realname);
+    #endif
+     *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY_TRUNC & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only with truncation %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_WONLY_APPEND & *mode ) {
+    #ifdef VERBOSE
+      printf("open write only with append %s\n", realname);
+    #endif
+     *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else if (BAOPEN_RW & *mode) {
+    #ifdef VERBOSE
+      printf("open read-write %s\n", realname);
+    #endif
+     *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO );
+  }
+  else {
+    #ifdef VERBOSE
+      printf("no openings\n");
+    #endif
+  }
+  if (*fdes < 0) {
+    #ifdef VERBOSE
+      printf("error in file descriptor! *fdes %d\n", *fdes);
+    #endif
+    return -4;
+  }
+  else {
+    #ifdef VERBOSE
+      printf("file descriptor = %d\n",*fdes );
+    #endif
+  }
+
+
+/* Read data as requested */
+  if (BAREAD & *mode &&
+   ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) {
+    #ifdef VERBOSE
+      printf("Error, trying to read while in write only mode!\n");
+    #endif
+    return -5;
+  }
+  else if (BAREAD & *mode ) {
+  /* Read in some data */
+    if (! (*mode & NOSEEK) ) {
+      seekret = lseek(*fdes, *start, SEEK_SET);
+      if (seekret == -1) {
+        #ifdef VERBOSE
+          printf("error in seeking to %d\n",*start);
+        #endif
+        return -6;
+      }
+      #ifdef VERBOSE
+      else {
+         printf("Seek successful, seek ret %d, start %d\n", seekret, *start);
+      }
+      #endif
+    }
+    jret = read(*fdes, datary, *no*(*size) );
+    if (jret != *no*(*size) ) {
+      #ifdef VERBOSE
+        printf("did not read in the requested number of items\n");
+        printf("read in %d items of %d \n",jret/(*size), *no);
+      #endif
+      *nactual = jret/(*size);
+      *newpos = *start + jret;
+    }  
+    #ifdef VERBOSE
+      printf("read in %d items \n", jret/(*size));
+    #endif
+    *nactual = jret/(*size);
+    *newpos = *start + jret;
+  }
+/* Done with reading */
+ 
+/* See if we should be writing */
+  if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) {
+    #ifdef VERBOSE
+      printf("Trying to write on a read only file \n");
+    #endif
+     return -7;
+  }
+  else if ( BAWRITE & *mode ) {
+    if (! (*mode & NOSEEK) ) {
+      seekret = lseek(*fdes, *start, SEEK_SET);
+      if (seekret == -1) {
+      #ifdef VERBOSE
+        printf("error in seeking to %d\n",*start);
+      #endif
+        return -8;
+      }
+      #ifdef VERBOSE
+      else {
+        printf("Seek successful, seek ret %d, start %d\n", seekret, *start);
+      }
+      #endif
+    }
+    jret = write(*fdes, datary, *no*(*size));
+    if (jret != *no*(*size)) {
+    #ifdef VERBOSE
+      printf("did not write out the requested number of items\n");
+      printf("wrote %d items instead\n", jret/(*size) );
+    #endif
+      *nactual = jret/(*size) ;
+      *newpos = *start + jret;
+    }
+    else {
+    #ifdef VERBOSE
+       printf("wrote %d items \n", jret/(*size) );
+    #endif
+       *nactual = jret/(*size) ;
+       *newpos = *start + jret;
+    }
+  }
+/* Done with writing */
+    
+
+/* Close file if requested */
+  if (BACLOSE & *mode ) {
+    jret = close(*fdes);
+    if (jret != 0) { 
+    #ifdef VERBOSE
+      printf("close failed! jret = %d\n",jret);
+    #endif
+      return -9;
+    }
+  }
+/* Done closing */
+
+/* Check that if we were reading or writing, that we actually got what */
+/*  we expected, else return a -10.  Return 0 (success) if we're here  */
+/*  and weren't reading or writing */
+  if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) {
+    return -10;
+  }
+  else {
+    return 0;
+  }
+} 
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.F b/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.F
new file mode 100644
index 00000000..e4c75bf2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.F
@@ -0,0 +1,541 @@
+C-----------------------------------------------------------------------
+      MODULE BACIO_MODULE
+C$$$  F90-MODULE DOCUMENTATION BLOCK
+C
+C F90-MODULE: BACIO_MODULE   BYTE-ADDRESSABLE I/O MODULE
+C   PRGMMR: IREDELL          ORG: NP23        DATE: 98-06-04
+C
+C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS
+C   IN THE BYTE-ADDESSABLE I/O PACKAGE.
+C
+C PROGRAM HISTORY LOG:
+C   98-06-04  IREDELL
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      INTEGER,EXTERNAL:: BACIO
+      INTEGER,DIMENSION(999),SAVE:: FD=999*0
+      INTEGER,DIMENSION(20),SAVE:: BAOPTS=0
+      INCLUDE 'baciof.h'
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BASETO(NOPT,VOPT)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BASETO         BYTE-ADDRESSABLE SET OPTIONS
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: SET OPTIONS FOR BYTE-ADDRESSABLE I/O.
+C   ALL OPTIONS DEFAULT TO 0.
+C   OPTION 1: BLOCKED READING OPTION
+C             IF THE OPTION VALUE IS 1, THEN THE READING IS BLOCKED
+C             INTO FOUR 4096-BYTE BUFFERS.  THIS MAY BE EFFICIENT IF
+C             THE READS WILL BE REQUESTED IN MUCH SMALLER CHUNKS.
+C             OTHERWISE, EACH CALL TO BAREAD INITIATES A PHYSICAL READ.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BASETO(NOPT,VOPT)
+C   INPUT ARGUMENTS:
+C     NOPT         INTEGER OPTION NUMBER
+C     VOPT         INTEGER OPTION VALUE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      INTEGER NOPT,VOPT
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(NOPT.GE.1.AND.NOPT.LE.20) BAOPTS(NOPT)=VOPT
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAOPEN(LU,CFN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAOPEN         BYTE-ADDRESSABLE OPEN
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAOPEN(LU,CFN,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO OPEN
+C     CFN          CHARACTER FILENAME TO OPEN
+C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER CFN*(*)
+      CHARACTER(80) CMSG
+      INTEGER SIZE = 1
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_OPENRW,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAOPENR(LU,CFN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAOPENR        BYTE-ADDRESSABLE OPEN
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR READ ONLY.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAOPENR(LU,CFN,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO OPEN
+C     CFN          CHARACTER FILENAME TO OPEN
+C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER CFN*(*)
+      INTEGER SIZE = 1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_OPENR,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAOPENW(LU,CFN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAOPENW        BYTE-ADDRESSABLE OPEN
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAOPENW(LU,CFN,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO OPEN
+C     CFN          CHARACTER FILENAME TO OPEN
+C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER CFN*(*)
+      INTEGER SIZE = 1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_OPENWT,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAOPENWT(LU,CFN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAOPENWT       BYTE-ADDRESSABLE OPEN
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH TRUNCATION.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAOPENWT(LU,CFN,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO OPEN
+C     CFN          CHARACTER FILENAME TO OPEN
+C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER CFN*(*)
+      INTEGER SIZE = 1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_OPENWT,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAOPENWA(LU,CFN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAOPENWA       BYTE-ADDRESSABLE OPEN
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH APPEND.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAOPENWA(LU,CFN,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO OPEN
+C     CFN          CHARACTER FILENAME TO OPEN
+C                  (CONSISTING OF NONBLANK PRINTABLE CHARACTERS)
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER CFN*(*)
+      INTEGER SIZE = 1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_OPENWA,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BACLOSE(LU,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BACLOSE        BYTE-ADDRESSABLE CLOSE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BACLOSE(LU,IRET)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO CLOSE
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      INTEGER SIZE = 1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(LU.LT.001.OR.LU.GT.999) THEN
+        IRET=6
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_CLOSE,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+      IF(IRET.EQ.0) FD(LU)=0
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAREAD(LU,IB,NB,KA,A)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAREAD         BYTE-ADDRESSABLE READ
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: READ A GIVEN NUMBER OF BYTES FROM AN UNBLOCKED FILE,
+C   SKIPPING A GIVEN NUMBER OF BYTES.
+C   THE PHYSICAL I/O IS BLOCKED INTO FOUR 4096-BYTE BUFFERS
+C   IF THE BYTE-ADDRESSABLE OPTION 1 HAS BEEN SET TO 1 BY BASETO.
+C   THIS BUFFERED READING IS INCOMPATIBLE WITH NO-SEEK READING.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAREAD(LU,IB,NB,KA,A)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO READ
+C     IB           INTEGER NUMBER OF BYTES TO SKIP
+C                  (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING)
+C     NB           INTEGER NUMBER OF BYTES TO READ
+C   OUTPUT ARGUMENTS:
+C     KA           INTEGER NUMBER OF BYTES ACTUALLY READ
+C     A            CHARACTER*1 (NB) DATA READ
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER A(NB)
+      CHARACTER CFN
+      PARAMETER(NY=4096,MY=4)
+      INTEGER NS(MY),NN(MY)
+      CHARACTER Y(NY,MY)
+      DATA LUX/0/
+      SAVE JY,NS,NN,Y,LUX
+      INTEGER SIZE=1
+      INTEGER ZERO=0
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(FD(LU).LE.0) THEN
+        KA=0
+        RETURN
+      ENDIF
+      IF(IB.LT.0.AND.BAOPTS(1).EQ.1) THEN
+        KA=0
+        RETURN
+      ENDIF
+      IF(NB.LE.0) THEN
+        KA=0
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  UNBUFFERED I/O
+      IF(BAOPTS(1).NE.1) THEN
+        IF(IB.GE.0) THEN
+           
+          IRET=BACIO(BACIO_READ,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+        ELSE
+          IRET=BACIO(BACIO_READ+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,
+     &          FD(LU),CFN,A)
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  BUFFERED I/O
+C  GET DATA FROM PREVIOUS CALL IF POSSIBLE
+      ELSE
+        KA=0
+        IF(LUX.NE.LU) THEN
+          JY=0
+          NS=0
+          NN=0
+        ELSE
+          DO I=1,MY
+            IY=MOD(JY+I-1,MY)+1
+            KY=IB+KA-NS(IY)
+            IF(KA.LT.NB.AND.KY.GE.0.AND.KY.LT.NN(IY)) THEN
+              K=MIN(NB-KA,NN(IY)-KY)
+              A(KA+1:KA+K)=Y(KY+1:KY+K,IY)
+              KA=KA+K
+            ENDIF
+          ENDDO
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  SET POSITION AND READ BUFFER AND GET DATA
+        IF(KA.LT.NB) THEN
+          LUX=ABS(LU)
+          JY=MOD(JY,MY)+1
+          NS(JY)=IB+KA
+          IRET=BACIO(BACIO_READ,NS(JY),JB,SIZE,NY,NN(JY),
+     &               FD(LUX),CFN,Y(1,JY))
+          IF(NN(JY).GT.0) THEN
+            K=MIN(NB-KA,NN(JY))
+            A(KA+1:KA+K)=Y(1:K,JY)
+            KA=KA+K
+          ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CONTINUE TO READ BUFFER AND GET DATA
+          DOWHILE(NN(JY).EQ.NY.AND.KA.LT.NB)
+            JY=MOD(JY,MY)+1
+            NS(JY)=NS(JY)+NN(JY)
+            IRET=BACIO(BACIO_READ+BACIO_NOSEEK,NS(JY),JB,SIZE,NY,NN(JY),
+     &                 FD(LUX),CFN,Y(1,JY))
+            IF(NN(JY).GT.0) THEN
+              K=MIN(NB-KA,NN(JY))
+              A(KA+1:KA+K)=Y(1:K,JY)
+              KA=KA+K
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE BAWRITE(LU,IB,NB,KA,A)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: BAWRITE        BYTE-ADDRESSABLE WRITE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE,
+C   SKIPPING A GIVEN NUMBER OF BYTES.
+C
+C PROGRAM HISTORY LOG:
+C   1998-06-04  IREDELL
+C
+C USAGE:    CALL BAWRITE(LU,IB,NB,KA,A)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO WRITE
+C     IB           INTEGER NUMBER OF BYTES TO SKIP
+C                  (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING)
+C     NB           INTEGER NUMBER OF BYTES TO WRITE
+C     A            CHARACTER*1 (NB) DATA TO WRITE
+C   OUTPUT ARGUMENTS:
+C     KA           INTEGER NUMBER OF BYTES ACTUALLY WRITTEN
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER A(NB)
+      CHARACTER CFN
+      INTEGER SIZE=1
+      INTEGER ZERO=0
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(FD(LU).LE.0) THEN
+        KA=0
+        RETURN
+      ENDIF
+      IF(NB.LE.0) THEN
+        KA=0
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(IB.GE.0) THEN
+        IRET=BACIO(BACIO_WRITE,IB,JB,SIZE,NB,KA,FD(LU),CFN,A)
+      ELSE
+        IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,
+     &        FD(LU),CFN,A)
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END
+C-----------------------------------------------------------------------
+      SUBROUTINE WRYTE(LU,NB,A)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: WRYTE          WRITE DATA OUT BY BYTES
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 1998-06-04
+C
+C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE.
+C
+C PROGRAM HISTORY LOG:
+C   92-10-31  IREDELL
+C   95-10-31  IREDELL     WORKSTATION VERSION
+C   1998-06-04  IREDELL   BACIO VERSION
+C
+C USAGE:    CALL WRYTE(LU,NB,A)
+C   INPUT ARGUMENTS:
+C     LU           INTEGER UNIT TO WHICH TO WRITE
+C     NB           INTEGER NUMBER OF BYTES TO WRITE
+C     A            CHARACTER*1 (NB) DATA TO WRITE
+C
+C MODULES USED:
+C   BACIO_MODULE   BYTE-ADDRESSABLE I/O FORTRAN INTERFACE
+C
+C SUBPROGRAMS CALLED:
+C   BACIO          BYTE-ADDRESSABLE I/O C PACKAGE
+C
+C REMARKS:  A BAOPEN MUST HAVE ALREADY BEEN CALLED.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE BACIO_MODULE
+      CHARACTER A(NB)
+      CHARACTER CFN
+      INTEGER SIZE=1
+      INTEGER ZERO=0
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF(FD(LU).LE.0) THEN
+        RETURN
+      ENDIF
+      IF(NB.LE.0) THEN
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRET=BACIO(BACIO_WRITE+BACIO_NOSEEK,ZERO,JB,SIZE,NB,KA,FD(LU),
+     &        CFN,A)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.h b/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.h
new file mode 100644
index 00000000..4153e27d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/baciof.h
@@ -0,0 +1,11 @@
+!     Include file to define variables for Fortran to C interface(s)
+!     Robert Grumbine 16 March 1998
+      INTEGER,PARAMETER:: BACIO_OPENR=1      ! Open file for read only
+      INTEGER,PARAMETER:: BACIO_OPENW=2      ! Open file for write only
+      INTEGER,PARAMETER:: BACIO_OPENRW=4     ! Open file for read or write
+      INTEGER,PARAMETER:: BACIO_CLOSE=8      ! Close file
+      INTEGER,PARAMETER:: BACIO_READ=16      ! Read from the file
+      INTEGER,PARAMETER:: BACIO_WRITE=32     ! Write to the file
+      INTEGER,PARAMETER:: BACIO_NOSEEK=64    ! Start I/O from previous spot
+      INTEGER,PARAMETER:: BACIO_OPENWT=128   ! Open for write only with truncation
+      INTEGER,PARAMETER:: BACIO_OPENWA=256   ! Open for write only with append
diff --git a/wrfv2_fire/external/io_grib2/bacio-1.3/clib.h b/wrfv2_fire/external/io_grib2/bacio-1.3/clib.h
new file mode 100644
index 00000000..554ef9b8
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/bacio-1.3/clib.h
@@ -0,0 +1,43 @@
+/*     Include file to define variables for Fortran to C interface(s) */
+/*     Robert Grumbine 16 March 1998                  */
+/*     NOSEEK added 25 March 1998                  */
+/*     CRAY compatibility added 20 April 1998      */
+
+/* The following line should be either undef or define VERBOSE */
+/* The latter gives noisy debugging output, while the former */
+/*   relies solely on the return codes */
+#undef  VERBOSE
+
+/* Declare the system type, supported options are: */
+/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */
+#define IBM4
+
+
+#include 
+
+/* Do not change things below here yourself */
+
+/*     IO-related (bacio.c, banio.c) */
+#define BAOPEN_RONLY              1
+#define BAOPEN_WONLY              2
+#define BAOPEN_RW                 4
+#define BACLOSE                   8
+#define BAREAD                   16
+#define BAWRITE                  32
+#define NOSEEK                   64
+#define BAOPEN_WONLY_TRUNC      128
+#define BAOPEN_WONLY_APPEND     256
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define BACIO bacio
+# else
+#   ifdef F2CSTYLE
+#      define BACIO bacio__
+#      define BANIO banio__
+#   else
+#      define BACIO bacio_
+#      define BANIO banio_
+#   endif
+# endif
+#endif
diff --git a/wrfv2_fire/external/io_grib2/g2lib/CHANGES b/wrfv2_fire/external/io_grib2/g2lib/CHANGES
new file mode 100644
index 00000000..ae28e454
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/CHANGES
@@ -0,0 +1,66 @@
+
+g2lib-1.0   - August 2003 - Original version
+
+g2lib-1.0.1 - October 2003 - Added support for Grid Definition Template 3.31
+                             Albers Equal Area.
+                           - Added new parameters to the Parameter list in
+                             params.f
+                           - Minor documentation updates.
+
+g2lib-1.0.2 - February 2004 - Added new parameters in params.f for use with 
+                              Quickscat data and Ozone (Air Quality)
+
+g2lib-1.0.3 - May 2004 - Changed most PDT templates in module pdstemplates to 
+                         allow negative surface values.
+                       - Added new routine to gridtemplates and pdstemplates 
+                         modules to return number of entries in a specified 
+                         template.
+                       - Added New routines, getgb2p getgb2rp, used to request 
+                         a packed GRIB2 message from a file.
+                       - New module g2grids can be used to return GDT entries 
+                         for a specific grid from a file containing a list of
+                         predefined grids.
+
+g2lib-1.0.4 - August 2004 - Added functionality to support encoding of 
+                            "Missing" data values within the data field when
+                            using Data Representation Templates 5.2 
+                            (complex packing) and 5.3 (complex packing and 
+                            spatial differencing).  See octets 23 - 31 in DRTs
+                            5.2 and 5.3 for more info on missing value
+                            management.
+                          - Increased the packing efficiency of Data 
+                            Representation Templates 5.2 and 5.3 by adding 
+                            MDL/Glahn algorithm for determining effective
+                            groupings.
+
+g2lib-1.0.5 - December 2004 - WMO approved the JPEG2000 and PNG Data 
+                             Representation Templates ( 5.40000 and 5.40010,
+                             respectively ) for operational use.  The templates
+                             were assigned WMO values of 5.40 and 5.41, 
+                             respectively.  Changes were made to the source to 
+                             recognize either template number.
+                           - Fixed bug encountered when packing a near constant
+                             field with DRT 5.40 or 5.40000 (JPEG2000).
+                           - Added consistency check, provided by 
+                             Arthur Taylor/MDL, used when unpacking Data 
+                             Templates 7.2 and 7.3.
+                           - Corrected the documentation for subroutine
+                             addfield in the grib2.doc file.  Incorrect
+                             arguments were specified for this routine.
+                           - Corrected bug when packing Secondary missing
+                             values in Data Representation Templates 5.2 and
+                             5.3.
+
+g2lib-1.0.6 - April 2005 - Modified the way GETGB2 manages the GRIB2 file 
+                           indexes, so that it can be more efficient and
+                           flexible when reading from multiple
+                           GRIB2 files.
+                         - Fixed bug in PUTGB2 that caused data fields to be
+                           encoded incorrectly.
+                         - Added routine gdt2gds that converts grid information
+                           from a GRIB2 Grid Description Section (GDS) and
+                           Grid Definition Template to GRIB1 GDS info.
+
+g2lib-1.0.7 - April 2005 - Fixed bug causing seg fault when using JPEG2000 
+                           encoding algorithm on a grid with an insanely large
+                           number of data points bitmapped out.
diff --git a/wrfv2_fire/external/io_grib2/g2lib/Makefile b/wrfv2_fire/external/io_grib2/g2lib/Makefile
new file mode 100644
index 00000000..80f65a3e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/Makefile
@@ -0,0 +1,144 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I.
+BUILD_DIR = ../../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = ..
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+F_INCLUDES   = -I. -Ig2lib
+FORMAT       = $(FIXED)
+ARFLAGS      = ruv
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib2
+CPPFLAGS = -DUSE_JPEG2000
+# 
+# To have the option of using the PNG compression scheme in the grib2 output,
+#   uncomment the following line.  In addition, you will need to assure
+#   that you have libpng and libz installed on your system.  If the libraries
+#   are not in standard system locations, you will need to modify your 
+#   configure.wrf file in order to specify the locations of the libraries.
+#
+#CPPFLAGS = -DUSE_PNG -DUSE_JPEG2000
+# 
+# In addition, you will need to add the following objects to the object list
+#   below.
+#        pngpack.o \
+#        pngunpack.o \
+#        enc_png.o \
+#        dec_png.o \
+#
+#  Further, you will need to add "-lpng" to your link line in configure.wrf
+#
+# Note: PNG functionality has only been tested on Linux.
+#
+
+DEP_LIBS = 
+OBJS =  \
+	gridtemplates.o \
+        pdstemplates.o \
+        drstemplates.o \
+        gribmod.o \
+        realloc.o \
+        addfield.o \
+        addgrid.o \
+        addlocal.o \
+        getfield.o \
+        gb_info.o \
+        gf_getfld.o \
+        gf_free.o \
+        gf_unpack1.o \
+        gf_unpack2.o \
+        gf_unpack3.o \
+        gf_unpack4.o \
+        gf_unpack5.o \
+        gf_unpack6.o \
+        gf_unpack7.o \
+        gettemplates.o \
+        getlocal.o \
+        getdim.o \
+        getpoly.o \
+        gribcreate.o \
+        gribend.o \
+        gribinfo.o \
+        mkieee.o \
+        rdieee.o \
+        simpack.o \
+        simunpack.o \
+        cmplxpack.o \
+        compack.o \
+        misspack.o \
+        pack_gp.o \
+        reduce.o \
+        comunpack.o \
+        specpack.o \
+        specunpack.o \
+        jpcpack.o \
+        jpcunpack.o \
+        enc_jpeg2000.o \
+        dec_jpeg2000.o \
+        gbytesc.o \
+        skgb.o \
+        ixgb2.o \
+        getidx.o \
+        getg2i.o \
+        getg2ir.o \
+        getgb2s.o \
+        getgb2r.o \
+        getgb2l.o \
+        getgb2.o \
+        getgb2p.o \
+        getgb2rp.o \
+        putgb2.o \
+        g2grids.o \
+        gdt2gds.o \
+        mova2i.o \
+        params.o
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib2/g2lib/README b/wrfv2_fire/external/io_grib2/g2lib/README
new file mode 100644
index 00000000..e60e4aec
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/README
@@ -0,0 +1,84 @@
+                                                           Aug 21, 2003
+                                                           W/NP11:SAG
+
+g2lib Library.
+
+This library contains Fortran 90 decoder/encoder
+routines for GRIB edition 2, as well as indexing/searching
+utility routines.  The user API for the GRIB2 routines
+is described in file "grib2.doc".
+
+Some Fortran routines call "C" functions, which must
+follow a specific symbol naming convention used by your
+machine/loader to be linked successfully.
+If you are having trouble linking to the C routines
+in this library, please make sure the appropriate 
+machine is defined as an option in the CFLAGS
+variable in the makefile.  See the first few lines
+of the makefile for valid options.
+Recompile the library.
+
+We have added support for PNG and JPEG2000 image compression
+algorithms within the GRIB2 standard.  If you would like
+to compile this library to utilize these GRIB2 Templates,
+make sure that -DUSE_PNG and -DUSE_JPEG2000 are specified
+in the FDEFS variable in the makefile.  You will also need
+to download and install the external libraries listed below,
+if they are not already installed on your system.
+
+If you do not wish to bother with the external libs and
+don't need PNG and JPEG2000 support, you can remove the
+-DUSE_PNG and -DUSE_JPEG2000 flags from the FDEFS variable 
+in the makefile.
+
+
+-------------------------------------------------------------------------------
+
+     External Libraries:
+
+libjasper.a - This library is a C implementation of the JPEG-2000 Part-1 
+              standard (i.e., ISO/IEC 15444-1).  This library is required
+              if JPEG2000 support in GRIB2 is desired.  If not, remove
+              the -DUSE_JPEG2000 option from the FDEFS variable 
+              in the makefile.
+
+              Download version jasper-1.700.2 from the JasPer Project's
+              home page, http://www.ece.uvic.ca/~mdadams/jasper/.
+        
+              More information about JPEG2000 can be found at 
+              http://www.jpeg.org/JPEG2000.html.
+
+libpng.a      This library is a C implementation of the Portable Network
+              Graphics PNG image compression format.  This library is required
+              if PNG support in GRIB2 is desired.  If not, remove
+              the -DUSE_PNG option from the FDEFS variable
+              in the makefile.
+
+              If not already installed on your system, download version 
+              libpng-1.2.5 from http://www.libpng.org/pub/png/libpng.html.
+
+              More information about PNG can be found at 
+              http://www.libpng.org/pub/png/.
+
+libz.a        This library contains compression/decompression routines
+              used by libpng.a for PNG image compression support. 
+              This library is required if PNG support in GRIB2 is desired.  
+              If not, remove the -DUSE_PNG option from the FDEFS variable
+              in g2lib/makefile.
+
+              If not already installed on your system, download version 
+              zlib-1.1.4 from http://www.gzip.org/zlib/.
+
+-------------------------------------------------------------------------------
+
+A note about routine MOVA2I:
+
+Some routines in this library call subroutine MOVA2I, which is included in 
+our W3LIB library containing the GRIB1 decoder/encoder routines.  If you
+are using this library without libw3.a, you will need to compile mova2i.c 
+(included in this distribution) so it can be added to libg2.a.  Just add
+the line:
+
+        $(LIB)(mova2i.o) \
+
+to the list of routines in the makefile.
diff --git a/wrfv2_fire/external/io_grib2/g2lib/addfield.F b/wrfv2_fire/external/io_grib2/g2lib/addfield.F
new file mode 100644
index 00000000..9b686d6b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/addfield.F
@@ -0,0 +1,482 @@
+      subroutine addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen,
+     &                    coordlist,numcoord,idrsnum,idrstmpl,
+     &                    idrstmplen,fld,ngrdpts,ibmap,bmap,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addfield 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-02
+!
+! ABSTRACT: This subroutine packs up Sections 4 through 7 for a given field
+!   and adds them to a GRIB2 message.  They are Product Definition Section,
+!   Data Representation Section, Bit-Map Section and Data Section, 
+!   respectively.
+!   This routine is used with routines "gribcreate", "addlocal", "addgrid",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!   Also, subroutine addgrid must be called after gribcreate and
+!   before this routine to add the appropriate grid description to
+!   the GRIB2 message.   Also, a call to gribend is required to complete 
+!   GRIB2 message after all fields have been added.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-02  Gilbert
+! 2002-12-17  Gilbert  - Added support for new templates using
+!                        PNG and JPEG2000 algorithms/templates.
+! 2004-06-22  Gilbert  - Added check to determine if packing algorithm failed.
+!
+! USAGE:    CALL addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen,
+!                         coordlist,numcoord,idrsnum,idrstmpl,
+!                         idrstmplen,fld,ngrdpts,ibmap,bmap,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Contains the data values for the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!   ipdstmplen - Max dimension of ipdstmpl()
+!     coordlist- Array containg floating point values intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.
+!     numcoord - number of values in array coordlist.
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0 )
+!     idrstmpl - Contains the data values for the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Data
+!                Representation Template 5.N
+!                Note that some values in this template (eg. reference
+!                values, number of bits, etc...) may be changed by the
+!                data packing algorithms.
+!                Use this to specify scaling factors and order of
+!                spatial differencing, if desired.
+!   idrstmplen - Max dimension of idrstmpl()
+!     fld()    - Array of data points to pack.
+!     ngrdpts  - Number of data points in grid.
+!                i.e.  size of fld and bmap.
+!     ibmap    - Bitmap indicator ( see Code Table 6.0 )
+!                0 = bitmap applies and is included in Section 6.
+!                1-253 = Predefined bitmap applies
+!                254 = Previously defined bitmap applies to this field
+!                255 = Bit map does not apply to this product.
+!     bmap()   - Logical*1 array containing bitmap to be added. 
+!                ( if ibmap=0 or ibmap=254)
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts does not add to total 
+!                    byte count.
+!                4 = Previous Section was not 3 or 7.
+!                5 = Could not find requested Product Definition Template.
+!                6 = Section 3 (GDS) not previously defined in message
+!                7 = Tried to use unsupported Data Representationi Template
+!                8 = Specified use of a previously defined bitmap, but one
+!                    does not exist in the GRIB message.
+!                9 = GDT of one of 5.50 through 5.53 required to pack
+!                    using DRT 5.51
+!               10 = Error packing data field.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use pdstemplates
+      use drstemplates
+
+      character(len=1),intent(inout) :: cgrib(lcgrib)
+      integer,intent(in) :: ipdsnum,ipdstmpl(*)
+      integer,intent(in) :: idrsnum,numcoord,ipdstmplen,idrstmplen
+      integer,intent(in) :: lcgrib,ngrdpts,ibmap
+      real,intent(in) :: coordlist(numcoord)
+      real,target,intent(in) :: fld(ngrdpts)
+      integer,intent(out) :: ierr
+      integer,intent(inout) :: idrstmpl(*)
+      logical*1,intent(in) :: bmap(ngrdpts)
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4):: ctemp
+      character(len=1),allocatable :: cpack(:)
+      real,pointer,dimension(:) :: pfld
+      real(4) :: coordieee(numcoord),re00
+      integer(4) :: ire00,allones
+      integer :: mappds(ipdstmplen),intbmap(ngrdpts),mapdrs(idrstmplen)
+      integer,parameter :: zero=0,one=1,four=4,five=5,six=6,seven=7
+      integer,parameter :: minsize=50000
+      integer iofst,ibeg,lencurr,len,mappdslen,mapdrslen,lpos3
+      integer width,height,ndpts
+      integer lensec3,lensec4,lensec5,lensec6,lensec7
+      logical issec3,needext,isprevbmap
+ 
+      ierr=0
+      do jj=0,31
+         allones=ibset(allones,jj)
+      enddo
+!
+!  Check to see if beginning of GRIB message exists
+!
+      ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4)
+      if ( ctemp.ne.grib ) then
+        print *,'addfield: GRIB not found in given message.'
+        print *,'addfield: Call to routine gribcreate required',
+     &          ' to initialize GRIB messge.'
+        ierr=1
+        return
+      endif
+!
+!  Get current length of GRIB message
+!  
+      call g2lib_gbyte(cgrib,lencurr,96,32)
+!
+!  Check to see if GRIB message is already complete
+!  
+      ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1)
+     &      //cgrib(lencurr)
+      if ( ctemp.eq.c7777 ) then
+        print *,'addfield: GRIB message already complete.  Cannot',
+     &          ' add new section.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through all current sections of the GRIB message to
+!  find the last section number.
+!
+      issec3=.false.
+      isprevbmap=.false.
+      len=16    ! length of Section 0
+      do 
+      !    Get number and length of next section
+        iofst=len*8
+        call g2lib_gbyte(cgrib,ilen,iofst,32)
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)
+        iofst=iofst+8
+      !  Check if previous Section 3 exists and save location of
+      !  the section 3 in case needed later.
+        if (isecnum.eq.3) then
+           issec3=.true.
+           lpos3=len+1
+           lensec3=ilen
+        endif
+      !  Check if a previous defined bitmap exists
+        if (isecnum.eq.6) then
+          call g2lib_gbyte(cgrib,ibmprev,iofst,8)
+          iofst=iofst+8
+          if ((ibmprev.ge.0).and.(ibmprev.le.253)) isprevbmap=.true.
+        endif
+        len=len+ilen
+      !    Exit loop if last section reached
+        if ( len.eq.lencurr ) exit
+      !    If byte count for each section does not match current
+      !    total length, then there is a problem.
+        if ( len.gt.lencurr ) then
+          print *,'addfield: Section byte counts don''t add to total.'
+          print *,'addfield: Sum of section byte counts = ',len
+          print *,'addfield: Total byte count in Section 0 = ',lencurr
+          ierr=3
+          return
+        endif
+      enddo
+!
+!  Sections 4 through 7 can only be added after section 3 or 7.
+!
+      if ( (isecnum.ne.3) .and. (isecnum.ne.7) ) then
+        print *,'addfield: Sections 4-7 can only be added after',
+     &          ' Section 3 or 7.'
+        print *,'addfield: Section ',isecnum,' was the last found in',
+     &          ' given GRIB message.'
+        ierr=4
+        return
+!
+!  Sections 4 through 7 can only be added if section 3 was previously defined.
+!
+      elseif (.not.issec3) then
+        print *,'addfield: Sections 4-7 can only be added if Section',
+     &          ' 3 was previously included.'
+        print *,'addfield: Section 3 was not found in',
+     &          ' given GRIB message.'
+        print *,'addfield: Call to routine addgrid required',
+     &          ' to specify Grid definition.'
+        ierr=6
+        return
+      endif
+!
+!  Add Section 4  - Product Definition Section
+!
+      ibeg=lencurr*8        !   Calculate offset for beginning of section 4
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,four,iofst,8)     ! Store section number ( 4 )
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,numcoord,iofst,16)   ! Store num of coordinate values
+      iofst=iofst+16
+      call g2lib_sbyte(cgrib,ipdsnum,iofst,16)    ! Store Prod Def Template num.
+      iofst=iofst+16
+      !
+      !   Get Product Definition Template
+      !
+      call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret)
+      if (iret.ne.0) then
+        ierr=5
+        return
+      endif
+      !
+      !   Extend the Product Definition Template, if necessary.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extpdstemplate(ipdsnum,ipdstmpl,mappdslen,mappds)
+      endif
+      !
+      !   Pack up each input value in array ipdstmpl into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mappds.
+      !
+      do i=1,mappdslen
+        nbits=iabs(mappds(i))*8
+        if ( (mappds(i).ge.0).or.(ipdstmpl(i).ge.0) ) then
+          call g2lib_sbyte(cgrib,ipdstmpl(i),iofst,nbits)
+        else
+          call g2lib_sbyte(cgrib,one,iofst,1)
+          call g2lib_sbyte(cgrib,iabs(ipdstmpl(i)),iofst+1,nbits-1)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Add Optional list of vertical coordinate values
+      !   after the Product Definition Template, if necessary.
+      !
+      if ( numcoord .ne. 0 ) then
+        call mkieee(coordlist,coordieee,numcoord)
+        call g2lib_sbytes(cgrib,coordieee,iofst,32,0,numcoord)
+        iofst=iofst+(32*numcoord)
+      endif
+      !
+      !   Calculate length of section 4 and store it in octets
+      !   1-4 of section 4.
+      !
+      lensec4=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec4,ibeg,32)
+!
+!  Pack Data using appropriate algorithm
+!
+      !
+      !   Get Data Representation Template
+      !
+      call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret)
+      if (iret.ne.0) then
+        ierr=5
+        return
+      endif
+      !
+      !  contract data field, removing data at invalid grid points,
+      !  if bit-map is provided with field.
+      !
+      if ( ibmap.eq.0 .OR. ibmap.eq.254 ) then
+         allocate(pfld(ngrdpts))
+         ndpts=0;
+         do jj=1,ngrdpts
+             intbmap(jj)=0
+             if ( bmap(jj) ) then
+                intbmap(jj)=1
+                ndpts=ndpts+1
+                pfld(ndpts)=fld(jj);
+             endif
+         enddo
+      else 
+         ndpts=ngrdpts;
+         pfld=>fld;
+      endif
+      lcpack=0
+      nsize=ndpts*4
+      if (nsize .lt. minsize) nsize=minsize
+      allocate(cpack(nsize),stat=istat)
+      if (idrsnum.eq.0) then      !  Simple Packing
+        call simpack(pfld,ndpts,idrstmpl,cpack,lcpack)
+      elseif (idrsnum.eq.2.or.idrsnum.eq.3) then      !  Complex Packing
+        call cmplxpack(pfld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+      elseif (idrsnum.eq.50) then      !  Sperical Harmonic Simple Packing
+        call simpack(pfld(2),ndpts-1,idrstmpl,cpack,lcpack)
+        call mkieee(real(pfld(1)),re00,1)  ! ensure RE(0,0) value is IEEE format
+        !call g2lib_gbyte(re00,idrstmpl(5),0,32)
+        ire00=transfer(re00,ire00)
+        idrstmpl(5)=ire00
+      elseif (idrsnum.eq.51) then      !  Sperical Harmonic Complex Packing
+           call getpoly(cgrib(lpos3),lensec3,jj,kk,mm)
+           if (jj.ne.0 .AND. kk.ne.0 .AND. mm.ne.0) then
+             call specpack(pfld,ndpts,jj,kk,mm,idrstmpl,cpack,lcpack)
+           else
+             print *,'addfield: Cannot pack DRT 5.51.'
+             ierr=9
+             return
+           endif
+#ifdef USE_JPEG2000
+      elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then     !  JPEG2000 encoding
+        if (ibmap.eq.255) then
+           call getdim(cgrib(lpos3),lensec3,width,height,iscan)
+           if ( width.eq.0 .OR. height.eq.0 ) then
+              width=ndpts
+              height=1
+           elseif ( width.eq.allones .OR. height.eq.allones ) then
+              width=ndpts
+              height=1
+           elseif ( ibits(iscan,5,1) .eq. 1) then   ! Scanning mode: bit 3
+              itemp=width
+              width=height
+              height=itemp
+           endif
+        else
+           width=ndpts
+           height=1
+        endif
+        lcpack=nsize
+        call jpcpack(pfld,width,height,idrstmpl,cpack,lcpack,ierr)
+#endif  /* USE_JPEG2000 */
+#ifdef USE_PNG
+      elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then      !  PNG encoding
+        if (ibmap.eq.255) then
+           call getdim(cgrib(lpos3),lensec3,width,height,iscan)
+           if ( width.eq.0 .OR. height.eq.0 ) then
+              width=ndpts
+              height=1
+           elseif ( width.eq.allones .OR. height.eq.allones ) then
+              width=ndpts
+              height=1
+           elseif ( ibits(iscan,5,1) .eq. 1) then   ! Scanning mode: bit 3
+              itemp=width
+              width=height
+              height=itemp
+           endif
+        else
+           width=ndpts
+           height=1
+        endif
+        call pngpack(pfld,width,height,idrstmpl,cpack,lcpack)
+#endif   /* USE_PNG */
+      else
+        print *,'addfield: Data Representation Template 5.',idrsnum,
+     *          ' not yet implemented.'
+        ierr=7
+        return
+      endif
+      if ( ibmap.eq.0 .OR. ibmap.eq.254 ) then
+         deallocate(pfld)
+      endif
+      if ( lcpack .lt. 0 ) then
+        if( allocated(cpack) )deallocate(cpack)
+        ierr=10
+        return
+      endif
+
+!
+!  Add Section 5  - Data Representation Section
+!
+      ibeg=iofst            !   Calculate offset for beginning of section 5
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,five,iofst,8)     ! Store section number ( 5 )
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,ndpts,iofst,32)    ! Store num of actual data points
+      iofst=iofst+32
+      call g2lib_sbyte(cgrib,idrsnum,iofst,16)    ! Store Data Repr. Template num.
+      iofst=iofst+16
+      !
+      !   Pack up each input value in array idrstmpl into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapdrs.
+      !
+      do i=1,mapdrslen
+        nbits=iabs(mapdrs(i))*8
+        if ( (mapdrs(i).ge.0).or.(idrstmpl(i).ge.0) ) then
+          call g2lib_sbyte(cgrib,idrstmpl(i),iofst,nbits)
+        else
+          call g2lib_sbyte(cgrib,one,iofst,1)
+          call g2lib_sbyte(cgrib,iabs(idrstmpl(i)),iofst+1,nbits-1)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Calculate length of section 5 and store it in octets
+      !   1-4 of section 5.
+      !
+      lensec5=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec5,ibeg,32)
+
+!
+!  Add Section 6  - Bit-Map Section
+!
+      ibeg=iofst            !   Calculate offset for beginning of section 6
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,six,iofst,8)     ! Store section number ( 6 )
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,ibmap,iofst,8)    ! Store Bit Map indicator
+      iofst=iofst+8
+      !
+      !  Store bitmap, if supplied
+      !
+      if (ibmap.eq.0) then
+        call g2lib_sbytes(cgrib,intbmap,iofst,1,0,ngrdpts)    ! Store BitMap
+        iofst=iofst+ngrdpts
+      endif
+      !
+      !  If specifying a previously defined bit-map, make sure
+      !  one already exists in the current GRIB message.
+      !
+      if ((ibmap.eq.254).and.(.not.isprevbmap)) then
+        print *,'addfield: Requested previously defined bitmap, ',
+     &        ' but one does not exist in the current GRIB message.'
+        ierr=8
+        return
+      endif
+      !
+      !   Calculate length of section 6 and store it in octets
+      !   1-4 of section 6.  Pad to end of octect, if necessary.
+      !
+      left=8-mod(iofst,8)
+      if (left.ne.8) then
+        call g2lib_sbyte(cgrib,zero,iofst,left)     ! Pad with zeros to fill Octet
+        iofst=iofst+left
+      endif
+      lensec6=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec6,ibeg,32)
+
+!
+!  Add Section 7  - Data Section
+!
+      ibeg=iofst            !   Calculate offset for beginning of section 7
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,seven,iofst,8)     ! Store section number ( 7 )
+      iofst=iofst+8
+      !      Store Packed Binary Data values, if non-constant field
+      if (lcpack.ne.0) then
+        ioctet=iofst/8           
+        cgrib(ioctet+1:ioctet+lcpack)=cpack(1:lcpack)
+        iofst=iofst+(8*lcpack)
+      endif
+      !
+      !   Calculate length of section 7 and store it in octets
+      !   1-4 of section 7.  
+      !
+      lensec7=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec7,ibeg,32)
+
+      if( allocated(cpack) )deallocate(cpack)
+!
+!  Update current byte total of message in Section 0
+!
+      newlen=lencurr+lensec4+lensec5+lensec6+lensec7
+      call g2lib_sbyte(cgrib,newlen,96,32)
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/addgrid.F b/wrfv2_fire/external/io_grib2/g2lib/addgrid.F
new file mode 100644
index 00000000..2913fc31
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/addgrid.F
@@ -0,0 +1,228 @@
+      subroutine addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,
+     &                   ideflist,idefnum,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addgrid 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-01
+!
+! ABSTRACT: This subroutine packs up a Grid Definition Section (Section 3) 
+!   and adds it to a GRIB2 message.
+!   This routine is used with routines "gribcreate", "addlocal", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-01  Gilbert
+!
+! USAGE:    CALL addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,
+!                        ideflist,idefnum,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     igds     - Contains information needed for GRIB Grid Definition Section 3.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Contains the data values for the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!   igdstmplen - Max dimension of igdstmpl()
+!     ideflist - (Used if igds(3) .ne. 0)  This array contains the
+!                number of grid points contained in each row ( or column )
+!      idefnum - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 1, 2 or 7.
+!                5 = Could not find requested Grid Definition Template.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use gridtemplates
+
+      character(len=1),intent(inout) :: cgrib(lcgrib)
+      integer,intent(in) :: igds(*),igdstmpl(*),ideflist(idefnum)
+      integer,intent(in) :: lcgrib,idefnum,igdstmplen
+      integer,intent(out) :: ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4):: ctemp
+      integer:: mapgrid(igdstmplen)
+      integer,parameter :: one=1,three=3
+      integer lensec3,iofst,ibeg,lencurr,len,mapgridlen
+      logical needext
+ 
+      ierr=0
+!
+!  Check to see if beginning of GRIB message exists
+!
+      ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4)
+      if ( ctemp.ne.grib ) then
+        print *,'addgrid: GRIB not found in given message.'
+        print *,'addgrid: Call to routine gribcreate required',
+     &          ' to initialize GRIB messge.'
+        ierr=1
+        return
+      endif
+!
+!  Get current length of GRIB message
+!  
+      call g2lib_gbyte(cgrib,lencurr,96,32)
+!
+!  Check to see if GRIB message is already complete
+!  
+      ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1)
+     &      //cgrib(lencurr)
+      if ( ctemp.eq.c7777 ) then
+        print *,'addgrid: GRIB message already complete.  Cannot',
+     &          ' add new section.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through all current sections of the GRIB message to
+!  find the last section number.
+!
+      len=16    ! length of Section 0
+      do 
+      !    Get section number and length of next section
+        iofst=len*8
+        call g2lib_gbyte(cgrib,ilen,iofst,32)
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)
+        len=len+ilen
+      !    Exit loop if last section reached
+        if ( len.eq.lencurr ) exit
+      !    If byte count for each section doesn't match current
+      !    total length, then there is a problem.
+        if ( len.gt.lencurr ) then
+          print *,'addgrid: Section byte counts don''t add to total.'
+          print *,'addgrid: Sum of section byte counts = ',len
+          print *,'addgrid: Total byte count in Section 0 = ',lencurr
+          ierr=3
+          return
+        endif
+      enddo
+!
+!  Section 3 can only be added after sections 1, 2 and 7.
+!
+      if ( (isecnum.ne.1) .and. (isecnum.ne.2) .and. 
+     &     (isecnum.ne.7) ) then
+        print *,'addgrid: Section 3 can only be added after Section',
+     &          ' 1, 2 or 7.'
+        print *,'addgrid: Section ',isecnum,' was the last found in',
+     &          ' given GRIB message.'
+        ierr=4
+        return
+      endif
+!
+!  Add Section 3  - Grid Definition Section
+!
+      ibeg=lencurr*8        !   Calculate offset for beginning of section 3
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,three,iofst,8)     ! Store section number ( 3 )
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,igds(1),iofst,8)     ! Store source of Grid def.
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,igds(2),iofst,32)    ! Store number of data pts.
+      iofst=iofst+32
+      call g2lib_sbyte(cgrib,igds(3),iofst,8)     ! Store number of extra octets.
+      iofst=iofst+8
+      call g2lib_sbyte(cgrib,igds(4),iofst,8)     ! Store interp. of extra octets.
+      iofst=iofst+8
+      !   if Octet 6 is not equal to zero, Grid Definition Template may
+      !   not be supplied.
+      if ( igds(1).eq.0 ) then
+        call g2lib_sbyte(cgrib,igds(5),iofst,16)  ! Store Grid Def Template num.
+      else
+        call g2lib_sbyte(cgrib,65535,iofst,16)   ! Store missing value as Grid Def Template num.
+      endif
+      iofst=iofst+16
+      !
+      !   Get Grid Definition Template
+      !
+      if (igds(1).eq.0) then
+        call getgridtemplate(igds(5),mapgridlen,mapgrid,needext,
+     &                       iret)
+        if (iret.ne.0) then
+          ierr=5
+          return
+        endif
+        !
+        !   Extend the Grid Definition Template, if necessary.
+        !   The number of values in a specific template may vary
+        !   depending on data specified in the "static" part of the
+        !   template.
+        !
+        if ( needext ) then
+          call extgridtemplate(igds(5),igdstmpl,mapgridlen,mapgrid)
+        endif
+      else
+        mapgridlen=0
+      endif
+      !
+      !   Pack up each input value in array igdstmpl into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapgrid.
+      !
+      do i=1,mapgridlen
+        nbits=iabs(mapgrid(i))*8
+        if ( (mapgrid(i).ge.0).or.(igdstmpl(i).ge.0) ) then
+          call g2lib_sbyte(cgrib,igdstmpl(i),iofst,nbits)
+        else
+          call g2lib_sbyte(cgrib,one,iofst,1)
+          call g2lib_sbyte(cgrib,iabs(igdstmpl(i)),iofst+1,nbits-1)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   If requested,
+      !   Insert optional list of numbers defining number of points
+      !   in each row or column.  This is used for non regular
+      !   grids.
+      !
+      if ( igds(3).ne.0 ) then
+         nbits=igds(3)*8
+         call g2lib_sbytes(cgrib,ideflist,iofst,nbits,0,idefnum)
+         iofst=iofst+(nbits*idefnum)
+      endif
+      !
+      !   Calculate length of section 3 and store it in octets
+      !   1-4 of section 3.
+      !
+      lensec3=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec3,ibeg,32)
+
+!
+!  Update current byte total of message in Section 0
+!
+      call g2lib_sbyte(cgrib,lencurr+lensec3,96,32)
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/addlocal.F b/wrfv2_fire/external/io_grib2/g2lib/addlocal.F
new file mode 100644
index 00000000..fc1b31b0
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/addlocal.F
@@ -0,0 +1,138 @@
+      subroutine addlocal(cgrib,lcgrib,csec2,lcsec2,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addlocal 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-01
+!
+! ABSTRACT: This subroutine adds a Local Use Section (Section 2) to 
+!   a GRIB2 message.
+!   This routine is used with routines "gribcreate", "addgrid", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-01  Gilbert
+!
+! USAGE:    CALL addlocal(cgrib,lcgrib,csec2,lcsec2,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     csec2    - Character array containing information to be added to
+!                Section 2.
+!     lcsec2   - Number of bytes of character array csec2 to be added to
+!                Section 2.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 1 or 7.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(inout) :: cgrib(lcgrib)
+      character(len=1),intent(in) :: csec2(lcsec2)
+      integer,intent(in) :: lcgrib,lcsec2
+      integer,intent(out) :: ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4):: ctemp
+      integer,parameter :: two=2
+      integer lensec2,iofst,ibeg,lencurr,len
+ 
+      ierr=0
+!
+!  Check to see if beginning of GRIB message exists
+!
+      ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4)
+      if ( ctemp.ne.grib ) then
+        print *,'addlocal: GRIB not found in given message.'
+        print *,'addlocal: Call to routine gribcreate required',
+     &          ' to initialize GRIB messge.'
+        ierr=1
+        return
+      endif
+!
+!  Get current length of GRIB message
+!  
+      call g2lib_gbyte(cgrib,lencurr,96,32)
+!
+!  Check to see if GRIB message is already complete
+!  
+      ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1)
+     &      //cgrib(lencurr)
+      if ( ctemp.eq.c7777 ) then
+        print *,'addlocal: GRIB message already complete.  Cannot',
+     &          ' add new section.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through all current sections of the GRIB message to
+!  find the last section number.
+!
+      len=16    ! length of Section 0
+      do 
+      !    Get section number and length of next section
+        iofst=len*8
+        call g2lib_gbyte(cgrib,ilen,iofst,32)
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)
+        len=len+ilen
+      !    Exit loop if last section reached
+        if ( len.eq.lencurr ) exit
+      !    If byte count for each section doesn't match current
+      !    total length, then there is a problem.
+        if ( len.gt.lencurr ) then
+          print *,'addlocal: Section byte counts don''t add to total.'
+          print *,'addlocal: Sum of section byte counts = ',len
+          print *,'addlocal: Total byte count in Section 0 = ',lencurr
+          ierr=3
+          return
+        endif
+      enddo
+!
+!  Section 2 can only be added after sections 1 and 7.
+!
+      if ( (isecnum.ne.1) .and. (isecnum.ne.7) ) then
+        print *,'addlocal: Section 2 can only be added after Section',
+     &          ' 1 or Section 7.'
+        print *,'addlocal: Section ',isecnum,' was the last found in',
+     &          ' given GRIB message.'
+        ierr=4
+        return
+      endif
+!
+!  Add Section 2  - Local Use Section
+!
+      ibeg=lencurr*8        !   Calculate offset for beginning of section 2
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,two,iofst,8)     ! Store section number ( 2 )
+      istart=lencurr+5
+      cgrib(istart+1:istart+lcsec2)=csec2(1:lcsec2)
+      !
+      !   Calculate length of section 2 and store it in octets
+      !   1-4 of section 2.
+      !
+      lensec2=lcsec2+5      ! bytes
+      call g2lib_sbyte(cgrib,lensec2,ibeg,32)
+
+!
+!  Update current byte total of message in Section 0
+!
+      call g2lib_sbyte(cgrib,lencurr+lensec2,96,32)
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/cmplxpack.F b/wrfv2_fire/external/io_grib2/g2lib/cmplxpack.F
new file mode 100644
index 00000000..dd1be9e1
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/cmplxpack.F
@@ -0,0 +1,76 @@
+      subroutine cmplxpack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    cmplxpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2004-08-27
+!
+! ABSTRACT: This subroutine packs up a data field using a complex
+!   packing algorithm as defined in the GRIB2 documention.  It
+!   supports GRIB2 complex packing templates with or without
+!   spatial differences (i.e. DRTs 5.2 and 5.3).
+!   It also fills in GRIB2 Data Representation Template 5.2 or 5.3 
+!   with the appropriate values.
+!
+! PROGRAM HISTORY LOG:
+! 2004-08-27  Gilbert
+!
+! USAGE:    CALL cmplxpack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     ndpts    - The number of data values in array fld()
+!     idrsnum  - Data Representation Template number 5.N
+!                Must equal 2 or 3.
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.2 or 5.3
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                    .
+!                    .
+!                (7) = Missing value management
+!                (8) = Primary missing value
+!                (9) = Secondary missing value
+!                    .
+!                    .
+!               (17) = Order of Spatial Differencing  ( 1 or 2 )
+!                    .
+!                    .
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.3
+!                (1) = Reference value - set by compack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                    .
+!                    .
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: ndpts,idrsnum
+      real,intent(in) :: fld(ndpts)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(out) :: lcpack
+
+      
+
+      if ( idrstmpl(7) .eq. 0 ) then       ! No internal missing values
+         call compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+      elseif ( idrstmpl(7).eq.1 .OR. idrstmpl(7).eq.2) then
+         call misspack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+      else
+         print *,'cmplxpack: Don:t recognize Missing value option.'
+         lcpack=-1
+      endif
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/compack.F b/wrfv2_fire/external/io_grib2/g2lib/compack.F
new file mode 100644
index 00000000..d8978b26
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/compack.F
@@ -0,0 +1,408 @@
+      subroutine compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    compack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine packs up a data field using a complex
+!   packing algorithm as defined in the GRIB2 documention.  It
+!   supports GRIB2 complex packing templates with or without
+!   spatial differences (i.e. DRTs 5.2 and 5.3).
+!   It also fills in GRIB2 Data Representation Template 5.2 or 5.3 
+!   with the appropriate values.
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+!
+! USAGE:    CALL compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     ndpts    - The number of data values in array fld()
+!     idrsnum  - Data Representation Template number 5.N
+!                Must equal 2 or 3.
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.2 or 5.3
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                    .
+!                    .
+!                (7) = Missing value management
+!                (8) = Primary missing value
+!                (9) = Secondary missing value
+!                    .
+!                    .
+!               (17) = Order of Spatial Differencing  ( 1 or 2 )
+!                    .
+!                    .
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.3
+!                (1) = Reference value - set by compack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                    .
+!                    .
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: ndpts,idrsnum
+      real,intent(in) :: fld(ndpts)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(out) :: lcpack
+
+      real(4) :: ref
+      integer(4) :: iref
+      integer,allocatable :: ifld(:)
+      integer,allocatable :: jmin(:),jmax(:),lbit(:)
+      integer,parameter :: zero=0
+      integer,allocatable :: gref(:),gwidth(:),glen(:)
+      integer :: glength,grpwidth
+      logical :: simple_alg = .false.
+      
+      alog2=alog(2.0)
+      bscale=2.0**real(-idrstmpl(2))
+      dscale=10.0**real(idrstmpl(3))
+!
+!  Find max and min values in the data
+!
+      rmax=fld(1)
+      rmin=fld(1)
+      do j=2,ndpts
+        if (fld(j).gt.rmax) rmax=fld(j)
+        if (fld(j).lt.rmin) rmin=fld(j)
+      enddo
+!
+!  If max and min values are not equal, pack up field.
+!  If they are equal, we have a constant field, and the reference
+!  value (rmin) is the value for each point in the field and
+!  set nbits to 0.
+!
+      if (rmin.ne.rmax) then
+        iofst=0
+        allocate(ifld(ndpts))
+        allocate(gref(ndpts))
+        allocate(gwidth(ndpts))
+        allocate(glen(ndpts))
+        !
+        !  Scale original data
+        !
+        if (idrstmpl(2).eq.0) then        !  No binary scaling
+           imin=nint(rmin*dscale)
+           !imax=nint(rmax*dscale)
+           rmin=real(imin)
+           do j=1,ndpts
+             ifld(j)=nint(fld(j)*dscale)-imin
+           enddo
+        else                              !  Use binary scaling factor
+           rmin=rmin*dscale
+           !rmax=rmax*dscale
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        endif
+        !
+        !  Calculate Spatial differences, if using DRS Template 5.3
+        !
+        if (idrsnum.eq.3) then        ! spatial differences
+           if (idrstmpl(17).ne.1.and.idrstmpl(17).ne.2) idrstmpl(17)=2
+           if (idrstmpl(17).eq.1) then      ! first order
+              ival1=ifld(1)
+              do j=ndpts,2,-1
+                 ifld(j)=ifld(j)-ifld(j-1)
+              enddo
+              ifld(1)=0
+           elseif (idrstmpl(17).eq.2) then      ! second order
+              ival1=ifld(1)
+              ival2=ifld(2)
+              do j=ndpts,3,-1
+                 ifld(j)=ifld(j)-(2*ifld(j-1))+ifld(j-2)
+              enddo
+              ifld(1)=0
+              ifld(2)=0
+           endif
+           !
+           !  subtract min value from spatial diff field
+           !
+           isd=idrstmpl(17)+1
+           minsd=minval(ifld(isd:ndpts))
+           do j=isd,ndpts
+              ifld(j)=ifld(j)-minsd
+           enddo
+           !
+           !   find num of bits need to store minsd and add 1 extra bit
+           !   to indicate sign
+           !
+           temp=alog(real(abs(minsd)+1))/alog2
+           nbitsd=ceiling(temp)+1
+           !
+           !   find num of bits need to store ifld(1) ( and ifld(2)
+           !   if using 2nd order differencing )
+           !
+           maxorig=ival1
+           if (idrstmpl(17).eq.2.and.ival2.gt.ival1) maxorig=ival2
+           temp=alog(real(maxorig+1))/alog2
+           nbitorig=ceiling(temp)+1
+           if (nbitorig.gt.nbitsd) nbitsd=nbitorig
+           !   increase number of bits to even multiple of 8 ( octet )
+           if (mod(nbitsd,8).ne.0) nbitsd=nbitsd+(8-mod(nbitsd,8))
+           !
+           !  Store extra spatial differencing info into the packed
+           !  data section.
+           !
+           if (nbitsd.ne.0) then
+              !   pack first original value
+              if (ival1.ge.0) then
+                 call g2lib_sbyte(cpack,ival1,iofst,nbitsd)
+                 iofst=iofst+nbitsd
+              else
+                 call g2lib_sbyte(cpack,1,iofst,1)
+                 iofst=iofst+1
+                 call g2lib_sbyte(cpack,iabs(ival1),iofst,nbitsd-1)
+                 iofst=iofst+nbitsd-1
+              endif
+              if (idrstmpl(17).eq.2) then
+               !  pack second original value
+                 if (ival2.ge.0) then
+                    call g2lib_sbyte(cpack,ival2,iofst,nbitsd)
+                    iofst=iofst+nbitsd
+                 else
+                    call g2lib_sbyte(cpack,1,iofst,1)
+                    iofst=iofst+1
+                    call g2lib_sbyte(cpack,iabs(ival2),iofst,nbitsd-1)
+                    iofst=iofst+nbitsd-1
+                 endif
+              endif
+              !  pack overall min of spatial differences
+              if (minsd.ge.0) then
+                 call g2lib_sbyte(cpack,minsd,iofst,nbitsd)
+                 iofst=iofst+nbitsd
+              else
+                 call g2lib_sbyte(cpack,1,iofst,1)
+                 iofst=iofst+1
+                 call g2lib_sbyte(cpack,iabs(minsd),iofst,nbitsd-1)
+                 iofst=iofst+nbitsd-1
+              endif
+           endif
+         !print *,'SDp ',ival1,ival2,minsd,nbitsd
+        endif     !  end of spatial diff section
+        !
+        !   Determine Groups to be used.
+        !
+        if ( simple_alg ) then
+           !  set group length to 10 :  calculate number of groups
+           !  and length of last group
+           ngroups=ndpts/10
+           glen(1:ngroups)=10
+           itemp=mod(ndpts,10)
+           if (itemp.ne.0) then
+              ngroups=ngroups+1
+              glen(ngroups)=itemp
+           endif
+        else
+           ! Use Dr. Glahn's algorithm for determining grouping.
+           !
+           kfildo=6
+           minpk=10
+           inc=1
+           maxgrps=(ndpts/minpk)+1
+           allocate(jmin(maxgrps))
+           allocate(jmax(maxgrps))
+           allocate(lbit(maxgrps))
+           missopt=0
+           call pack_gp(kfildo,ifld,ndpts,missopt,minpk,inc,miss1,miss2,
+     &                  jmin,jmax,lbit,glen,maxgrps,ngroups,ibit,jbit,
+     &                  kbit,novref,lbitref,ier)
+           !print *,'SAGier = ',ier,ibit,jbit,kbit,novref,lbitref
+           do ng=1,ngroups
+              glen(ng)=glen(ng)+novref
+           enddo
+           deallocate(jmin)
+           deallocate(jmax)
+           deallocate(lbit)
+        endif
+        !  
+        !  For each group, find the group's reference value
+        !  and the number of bits needed to hold the remaining values
+        !
+        n=1
+        do ng=1,ngroups
+           !    find max and min values of group
+           gref(ng)=ifld(n)
+           imax=ifld(n)
+           j=n+1
+           do lg=2,glen(ng)
+              if (ifld(j).lt.gref(ng)) gref(ng)=ifld(j) 
+              if (ifld(j).gt.imax) imax=ifld(j) 
+              j=j+1
+           enddo
+           !   calc num of bits needed to hold data
+           if ( gref(ng).ne.imax ) then
+              temp=alog(real(imax-gref(ng)+1))/alog2
+              gwidth(ng)=ceiling(temp)
+           else
+              gwidth(ng)=0
+           endif
+           !   Subtract min from data
+           j=n
+           do lg=1,glen(ng)
+              ifld(j)=ifld(j)-gref(ng)
+              j=j+1
+           enddo
+           !   increment fld array counter
+           n=n+glen(ng)
+        enddo
+        !  
+        !  Find max of the group references and calc num of bits needed 
+        !  to pack each groups reference value, then
+        !  pack up group reference values
+        !
+        !write(77,*)'GREFS: ',(gref(j),j=1,ngroups)
+        igmax=maxval(gref(1:ngroups))
+        if (igmax.ne.0) then
+           temp=alog(real(igmax+1))/alog2
+           nbitsgref=ceiling(temp)
+           call g2lib_sbytes(cpack,gref,iofst,nbitsgref,0,ngroups)
+           itemp=nbitsgref*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsgref=0
+        endif
+        !
+        !  Find max/min of the group widths and calc num of bits needed
+        !  to pack each groups width value, then
+        !  pack up group width values
+        !
+        !write(77,*)'GWIDTHS: ',(gwidth(j),j=1,ngroups)
+        iwmax=maxval(gwidth(1:ngroups))
+        ngwidthref=minval(gwidth(1:ngroups))
+        if (iwmax.ne.ngwidthref) then
+           temp=alog(real(iwmax-ngwidthref+1))/alog2
+           nbitsgwidth=ceiling(temp)
+           do i=1,ngroups
+              gwidth(i)=gwidth(i)-ngwidthref
+           enddo
+           call g2lib_sbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups)
+           itemp=nbitsgwidth*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsgwidth=0
+           gwidth(1:ngroups)=0
+        endif
+        !
+        !  Find max/min of the group lengths and calc num of bits needed
+        !  to pack each groups length value, then
+        !  pack up group length values
+        !
+        !write(77,*)'GLENS: ',(glen(j),j=1,ngroups)
+        ilmax=maxval(glen(1:ngroups-1))
+        nglenref=minval(glen(1:ngroups-1))
+        nglenlast=glen(ngroups)
+        if (ilmax.ne.nglenref) then
+           temp=alog(real(ilmax-nglenref+1))/alog2
+           nbitsglen=ceiling(temp)
+           do i=1,ngroups-1
+              glen(i)=glen(i)-nglenref
+           enddo
+           call g2lib_sbytes(cpack,glen,iofst,nbitsglen,0,ngroups)
+           itemp=nbitsglen*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsglen=0
+           glen(1:ngroups)=0
+        endif
+        !
+        !  For each group, pack data values
+        !
+        !write(77,*)'IFLDS: ',(ifld(j),j=1,ndpts)
+        n=1
+        ij=0
+        do ng=1,ngroups
+           glength=glen(ng)+nglenref
+           if (ng.eq.ngroups ) glength=nglenlast
+           grpwidth=gwidth(ng)+ngwidthref
+       !write(77,*)'NGP ',ng,grpwidth,glength,gref(ng)
+           if ( grpwidth.ne.0 ) then
+              call g2lib_sbytes(cpack,ifld(n),iofst,grpwidth,0,glength)
+              iofst=iofst+(grpwidth*glength)
+           endif
+           do kk=1,glength
+              ij=ij+1
+       !write(77,*)'SAG ',ij,fld(ij),ifld(ij),gref(ng),bscale,rmin,dscale
+           enddo
+           n=n+glength
+        enddo
+        !         Pad last octet with Zeros, if necessary,
+        if (mod(iofst,8).ne.0) then
+           left=8-mod(iofst,8)
+           call g2lib_sbyte(cpack,zero,iofst,left)
+           iofst=iofst+left
+        endif
+        lcpack=iofst/8
+        !
+        if ( allocated(ifld) ) deallocate(ifld)
+        if ( allocated(gref) ) deallocate(gref)
+        if ( allocated(gwidth) ) deallocate(gwidth)
+        if ( allocated(glen) ) deallocate(glen)
+      else           !   Constant field ( max = min )
+        nbits=0
+        lcpack=0
+        nbitsgref=0
+        ngroups=0
+      endif
+
+!
+!  Fill in ref value and number of bits in Template 5.2
+!
+      call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
+!      call g2lib_gbyte(ref,idrstmpl(1),0,32)
+      iref=transfer(ref,iref)
+      idrstmpl(1)=iref
+      idrstmpl(4)=nbitsgref
+      idrstmpl(5)=0         ! original data were reals
+      idrstmpl(6)=1         ! general group splitting
+      idrstmpl(7)=0         ! No internal missing values
+      idrstmpl(8)=0         ! Primary missing value
+      idrstmpl(9)=0         ! secondary missing value
+      idrstmpl(10)=ngroups          ! Number of groups
+      idrstmpl(11)=ngwidthref       ! reference for group widths
+      idrstmpl(12)=nbitsgwidth      ! num bits used for group widths
+      idrstmpl(13)=nglenref         ! Reference for group lengths
+      idrstmpl(14)=1                ! length increment for group lengths
+      idrstmpl(15)=nglenlast        ! True length of last group
+      idrstmpl(16)=nbitsglen        ! num bits used for group lengths
+      if (idrsnum.eq.3) then
+         idrstmpl(18)=nbitsd/8      ! num bits used for extra spatial
+                                    ! differencing values
+      endif
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/comunpack.F b/wrfv2_fire/external/io_grib2/g2lib/comunpack.F
new file mode 100644
index 00000000..d114cb37
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/comunpack.F
@@ -0,0 +1,336 @@
+      subroutine comunpack(cpack,len,lensec,idrsnum,idrstmpl,ndpts,
+     &                     fld,ier)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    comunpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine unpacks a data field that was packed using a
+!   complex packing algorithm as defined in the GRIB2 documention,
+!   using info from the GRIB2 Data Representation Template 5.2 or 5.3.
+!   Supports GRIB2 complex packing templates with or without
+!   spatial differences (i.e. DRTs 5.2 and 5.3).
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+! 2004-12-29  Gilbert  -  Added test ( provided by Arthur Taylor/MDL )
+!                         to verify that group widths and lengths are
+!                         consistent with section length.
+!
+! USAGE:    CALL comunpack(cpack,len,lensec,idrsnum,idrstmpl,ndpts,fld,ier)
+!   INPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     len      - length of packed field cpack().
+!     lensec   - length of section 7 (used for error checking).
+!     idrsnum  - Data Representation Template number 5.N
+!                Must equal 2 or 3.
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.2 or 5.3
+!     ndpts    - The number of data values to unpack
+!
+!   OUTPUT ARGUMENT LIST:
+!     fld()    - Contains the unpacked data values
+!     ier      - Error return:
+!                  0 = OK
+!                  1 = Problem - inconsistent group lengths of widths.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cpack(len)
+      integer,intent(in) :: ndpts,len
+      integer,intent(in) :: idrstmpl(*)
+      real,intent(out) :: fld(ndpts)
+
+      integer,allocatable :: ifld(:),ifldmiss(:)
+      integer(4) :: ieee
+      integer,allocatable :: gref(:),gwidth(:),glen(:)
+      real :: ref,bscale,dscale,rmiss1,rmiss2
+!      real :: fldo(6045)
+      integer :: totBit, totLen
+
+      ier=0
+      !print *,'IDRSTMPL: ',(idrstmpl(j),j=1,16)
+      ieee = idrstmpl(1)
+      call rdieee(ieee,ref,1)
+      bscale = 2.0**real(idrstmpl(2))
+      dscale = 10.0**real(-idrstmpl(3))
+      nbitsgref = idrstmpl(4)
+      itype = idrstmpl(5)
+      ngroups = idrstmpl(10)
+      nbitsgwidth = idrstmpl(12)
+      nbitsglen = idrstmpl(16)
+      if (idrsnum.eq.3) then
+         nbitsd=idrstmpl(18)*8
+      endif
+
+      !   Constant field
+
+      if (ngroups.eq.0) then
+         do j=1,ndpts
+           fld(j)=ref
+         enddo
+         return
+      endif
+
+      iofst=0
+      allocate(ifld(ndpts),stat=is)
+      !print *,'ALLOC ifld: ',is,ndpts
+      allocate(gref(ngroups),stat=is)
+      !print *,'ALLOC gref: ',is
+      allocate(gwidth(ngroups),stat=is)
+      !print *,'ALLOC gwidth: ',is
+!
+!  Get missing values, if supplied
+!
+      if ( idrstmpl(7).eq.1 ) then
+         if (itype.eq.0) then
+            call rdieee(idrstmpl(8),rmiss1,1)
+         else
+            rmiss1=real(idrstmpl(8))
+         endif
+      elseif ( idrstmpl(7).eq.2 ) then
+         if (itype.eq.0) then
+            call rdieee(idrstmpl(8),rmiss1,1)
+            call rdieee(idrstmpl(9),rmiss2,1)
+         else
+            rmiss1=real(idrstmpl(8))
+            rmiss2=real(idrstmpl(9))
+         endif
+      endif
+      !print *,'RMISSs: ',rmiss1,rmiss2,ref
+! 
+!  Extract Spatial differencing values, if using DRS Template 5.3
+!
+      if (idrsnum.eq.3) then
+         if (nbitsd.ne.0) then
+              call g2lib_gbyte(cpack,isign,iofst,1)
+              iofst=iofst+1
+              call g2lib_gbyte(cpack,ival1,iofst,nbitsd-1)
+              iofst=iofst+nbitsd-1
+              if (isign.eq.1) ival1=-ival1
+              if (idrstmpl(17).eq.2) then
+                 call g2lib_gbyte(cpack,isign,iofst,1)
+                 iofst=iofst+1
+                 call g2lib_gbyte(cpack,ival2,iofst,nbitsd-1)
+                 iofst=iofst+nbitsd-1
+                 if (isign.eq.1) ival2=-ival2
+              endif
+              call g2lib_gbyte(cpack,isign,iofst,1)
+              iofst=iofst+1
+              call g2lib_gbyte(cpack,minsd,iofst,nbitsd-1)
+              iofst=iofst+nbitsd-1
+              if (isign.eq.1) minsd=-minsd
+         else
+              ival1=0
+              ival2=0
+              minsd=0
+         endif
+       !print *,'SDu ',ival1,ival2,minsd,nbitsd
+      endif
+!
+!  Extract Each Group's reference value
+!
+      !print *,'SAG1: ',nbitsgref,ngroups,iofst
+      if (nbitsgref.ne.0) then
+         call g2lib_gbytes(cpack,gref,iofst,nbitsgref,0,ngroups)
+         itemp=nbitsgref*ngroups
+         iofst=iofst+(itemp)
+         if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8))
+      else
+         gref(1:ngroups)=0
+      endif
+      !write(78,*)'GREFs: ',(gref(j),j=1,ngroups)
+!
+!  Extract Each Group's bit width
+!
+      !print *,'SAG2: ',nbitsgwidth,ngroups,iofst,idrstmpl(11)
+      if (nbitsgwidth.ne.0) then
+         call g2lib_gbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups)
+         itemp=nbitsgwidth*ngroups
+         iofst=iofst+(itemp)
+         if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8))
+      else
+         gwidth(1:ngroups)=0
+      endif
+      do j=1,ngroups
+        gwidth(j)=gwidth(j)+idrstmpl(11)
+      enddo
+      !write(78,*)'GWIDTHs: ',(gwidth(j),j=1,ngroups)
+!
+!  Extract Each Group's length (number of values in each group)
+!
+      allocate(glen(ngroups),stat=is)
+      !print *,'ALLOC glen: ',is
+      !print *,'SAG3: ',nbitsglen,ngroups,iofst,idrstmpl(14),idrstmpl(13)
+      if (nbitsglen.ne.0) then
+         call g2lib_gbytes(cpack,glen,iofst,nbitsglen,0,ngroups)
+         itemp=nbitsglen*ngroups
+         iofst=iofst+(itemp)
+         if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8))
+      else
+         glen(1:ngroups)=0
+      endif
+      do j=1,ngroups
+        glen(j)=(glen(j)*idrstmpl(14))+idrstmpl(13)
+      enddo
+      glen(ngroups)=idrstmpl(15)
+      !write(78,*)'GLENs: ',(glen(j),j=1,ngroups)
+      !print *,'GLENsum: ',sum(glen)
+!
+!  Test to see if the group widths and lengths are consistent with number of
+!  values, and length of section 7.
+!
+      totBit = 0
+      totLen = 0
+      do j=1,ngroups
+        totBit = totBit + (gwidth(j)*glen(j));
+        totLen = totLen + glen(j);
+      enddo
+      if (totLen .NE. ndpts) then
+        ier=1
+        return
+      endif
+      if ( (totBit/8) .GT. lensec) then
+        ier=1
+        return
+      endif
+!
+!  For each group, unpack data values
+!
+      if ( idrstmpl(7).eq.0 ) then        ! no missing values
+         n=1
+         do j=1,ngroups
+         !write(78,*)'NGP ',j,gwidth(j),glen(j),gref(j)
+           if (gwidth(j).ne.0) then
+             call g2lib_gbytes(cpack,ifld(n),iofst,gwidth(j),0,glen(j))
+             do k=1,glen(j)
+               ifld(n)=ifld(n)+gref(j)
+               n=n+1
+             enddo
+           else
+             ifld(n:n+glen(j)-1)=gref(j)
+             n=n+glen(j)
+           endif
+           iofst=iofst+(gwidth(j)*glen(j))
+         enddo
+      elseif ( idrstmpl(7).eq.1.OR.idrstmpl(7).eq.2 ) then
+         ! missing values included
+         allocate(ifldmiss(ndpts))
+         !ifldmiss=0
+         n=1
+         non=1
+         do j=1,ngroups
+           !print *,'SAGNGP ',j,gwidth(j),glen(j),gref(j)
+           if (gwidth(j).ne.0) then
+             msng1=(2**gwidth(j))-1
+             msng2=msng1-1
+             call g2lib_gbytes(cpack,ifld(n),iofst,gwidth(j),0,glen(j))
+             iofst=iofst+(gwidth(j)*glen(j))
+             do k=1,glen(j)
+               if (ifld(n).eq.msng1) then
+                  ifldmiss(n)=1
+               elseif (idrstmpl(7).eq.2.AND.ifld(n).eq.msng2) then
+                  ifldmiss(n)=2
+               else
+                  ifldmiss(n)=0
+                  ifld(non)=ifld(n)+gref(j)
+                  non=non+1
+               endif
+               n=n+1
+             enddo
+           else
+             msng1=(2**nbitsgref)-1
+             msng2=msng1-1
+             if (gref(j).eq.msng1) then
+                ifldmiss(n:n+glen(j)-1)=1
+                !ifld(n:n+glen(j)-1)=0
+             elseif (idrstmpl(7).eq.2.AND.gref(j).eq.msng2) then
+                ifldmiss(n:n+glen(j)-1)=2
+                !ifld(n:n+glen(j)-1)=0
+             else
+                ifldmiss(n:n+glen(j)-1)=0
+                ifld(non:non+glen(j)-1)=gref(j)
+                non=non+glen(j)
+             endif
+             n=n+glen(j)
+           endif
+         enddo
+      endif
+      !write(78,*)'IFLDs: ',(ifld(j),j=1,ndpts)
+
+      if ( allocated(gref) ) deallocate(gref)
+      if ( allocated(gwidth) ) deallocate(gwidth)
+      if ( allocated(glen) ) deallocate(glen)
+!
+!  If using spatial differences, add overall min value, and
+!  sum up recursively
+!
+      if (idrsnum.eq.3) then         ! spatial differencing
+         if (idrstmpl(17).eq.1) then      ! first order
+            ifld(1)=ival1
+            if ( idrstmpl(7).eq.0 ) then        ! no missing values
+               itemp=ndpts
+            else
+               itemp=non-1
+            endif
+            do n=2,itemp
+               ifld(n)=ifld(n)+minsd
+               ifld(n)=ifld(n)+ifld(n-1)
+            enddo
+         elseif (idrstmpl(17).eq.2) then    ! second order
+            ifld(1)=ival1
+            ifld(2)=ival2
+            if ( idrstmpl(7).eq.0 ) then        ! no missing values
+               itemp=ndpts
+            else
+               itemp=non-1
+            endif
+            do n=3,itemp
+               ifld(n)=ifld(n)+minsd
+               ifld(n)=ifld(n)+(2*ifld(n-1))-ifld(n-2)
+            enddo
+         endif
+      !write(78,*)'IFLDs: ',(ifld(j),j=1,ndpts)
+      endif
+!
+!  Scale data back to original form
+!
+      !print *,'SAGT: ',ref,bscale,dscale
+      if ( idrstmpl(7).eq.0 ) then        ! no missing values
+         do n=1,ndpts
+            fld(n)=((real(ifld(n))*bscale)+ref)*dscale
+            !write(78,*)'SAG ',n,fld(n),ifld(n),bscale,ref,1./dscale
+         enddo
+      elseif ( idrstmpl(7).eq.1.OR.idrstmpl(7).eq.2 ) then
+         ! missing values included
+         non=1
+         do n=1,ndpts
+            if ( ifldmiss(n).eq.0 ) then
+               fld(n)=((real(ifld(non))*bscale)+ref)*dscale
+               !print *,'SAG ',n,fld(n),ifld(non),bscale,ref,dscale
+               non=non+1
+            elseif ( ifldmiss(n).eq.1 ) then
+               fld(n)=rmiss1
+            elseif ( ifldmiss(n).eq.2 ) then
+               fld(n)=rmiss2
+            endif
+         enddo
+         if ( allocated(ifldmiss) ) deallocate(ifldmiss)
+      endif
+
+      if ( allocated(ifld) ) deallocate(ifld)
+
+      !open(10,form='unformatted',recl=24180,access='direct') 
+      !read(10,rec=1) (fldo(k),k=1,6045)
+      !do i =1,6045
+      !  print *,i,fldo(i),fld(i),fldo(i)-fld(i)
+      !enddo
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/dec_jpeg2000.c b/wrfv2_fire/external/io_grib2/g2lib/dec_jpeg2000.c
new file mode 100644
index 00000000..d3c5bcfe
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/dec_jpeg2000.c
@@ -0,0 +1,142 @@
+#include 
+#include 
+#include 
+#include "jasper/jasper.h"
+#include "proto.h"
+#define JAS_1_700_2
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+   int DEC_JPEG2000(char *injpc,g2int *bufsize,g2int *outfld)
+/*$$$  SUBPROGRAM DOCUMENTATION BLOCK
+*                .      .    .                                       .
+* SUBPROGRAM:    dec_jpeg2000      Decodes JPEG2000 code stream
+*   PRGMMR: Gilbert          ORG: W/NP11     DATE: 2002-12-02
+*
+* ABSTRACT: This Function decodes a JPEG2000 code stream specified in the
+*   JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using JasPer 
+*   Software version 1.500.4 (or 1.700.2) written by the University of British
+*   Columbia and Image Power Inc, and others.
+*   JasPer is available at http://www.ece.uvic.ca/~mdadams/jasper/.
+*
+* PROGRAM HISTORY LOG:
+* 2002-12-02  Gilbert
+*
+* USAGE:     int dec_jpeg2000(char *injpc,g2int *bufsize,g2int *outfld)
+*
+*   INPUT ARGUMENTS:
+*      injpc - Input JPEG2000 code stream.
+*    bufsize - Length (in bytes) of the input JPEG2000 code stream.
+*
+*   INPUT ARGUMENTS:
+*     outfld - Output matrix of grayscale image values.
+*
+*   RETURN VALUES :
+*          0 = Successful decode
+*         -3 = Error decode jpeg2000 code stream.
+*         -5 = decoded image had multiple color components.
+*              Only grayscale is expected.
+*
+* REMARKS:
+*
+*      Requires JasPer Software version 1.500.4 or 1.700.2
+*
+* ATTRIBUTES:
+*   LANGUAGE: C
+*   MACHINE:  IBM SP
+*
+*$$$*/
+
+{
+    int ier;
+    g2int i,j,k,n;
+    jas_image_t *image=0;
+    jas_stream_t *jpcstream,*istream;
+    jas_image_cmpt_t cmpt,*pcmpt;
+    char *opts=0;
+    jas_matrix_t *data;
+
+//    jas_init();
+
+//   
+//     Create jas_stream_t containing input JPEG200 codestream in memory.
+//       
+
+    jpcstream=jas_stream_memopen(injpc,*bufsize);
+
+//   
+//     Decode JPEG200 codestream into jas_image_t structure.
+//       
+    image=jpc_decode(jpcstream,opts);
+    if ( image == 0 ) {
+       printf(" jpc_decode return = %d \n",ier);
+       return -3;
+    }
+    
+    pcmpt=image->cmpts_[0];
+/*
+    printf(" SAGOUT DECODE:\n");
+    printf(" tlx %d \n",image->tlx_);
+    printf(" tly %d \n",image->tly_);
+    printf(" brx %d \n",image->brx_);
+    printf(" bry %d \n",image->bry_);
+    printf(" numcmpts %d \n",image->numcmpts_);
+    printf(" maxcmpts %d \n",image->maxcmpts_);
+#ifdef JAS_1_500_4
+    printf(" colormodel %d \n",image->colormodel_);
+#endif
+#ifdef JAS_1_700_2
+    printf(" colorspace %d \n",image->clrspc_);
+#endif
+    printf(" inmem %d \n",image->inmem_);
+    printf(" COMPONENT:\n");
+    printf(" tlx %d \n",pcmpt->tlx_);
+    printf(" tly %d \n",pcmpt->tly_);
+    printf(" hstep %d \n",pcmpt->hstep_);
+    printf(" vstep %d \n",pcmpt->vstep_);
+    printf(" width %d \n",pcmpt->width_);
+    printf(" height %d \n",pcmpt->height_);
+    printf(" prec %d \n",pcmpt->prec_);
+    printf(" sgnd %d \n",pcmpt->sgnd_);
+    printf(" cps %d \n",pcmpt->cps_);
+#ifdef JAS_1_700_2
+    printf(" type %d \n",pcmpt->type_);
+#endif
+*/
+
+//   Expecting jpeg2000 image to be grayscale only.
+//   No color components.
+//
+    if (image->numcmpts_ != 1 ) {
+       printf("dec_jpeg2000: Found color image.  Grayscale expected.\n");
+       return (-5);
+    }
+
+// 
+//    Create a data matrix of grayscale image values decoded from
+//    the jpeg2000 codestream.
+//
+    data=jas_matrix_create(jas_image_height(image), jas_image_width(image));
+    jas_image_readcmpt(image,0,0,0,jas_image_width(image),
+                       jas_image_height(image),data);
+//
+//    Copy data matrix to output integer array.
+//
+    k=0;
+    for (i=0;iheight_;i++) 
+      for (j=0;jwidth_;j++) 
+        outfld[k++]=data->rows_[i][j];
+//
+//     Clean up JasPer work structures.
+//
+    jas_matrix_destroy(data);
+    ier=jas_stream_close(jpcstream);
+    jas_image_destroy(image);
+
+    return 0;
+
+}
diff --git a/wrfv2_fire/external/io_grib2/g2lib/dec_png.c b/wrfv2_fire/external/io_grib2/g2lib/dec_png.c
new file mode 100644
index 00000000..aa85184b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/dec_png.c
@@ -0,0 +1,139 @@
+#include 
+#include 
+#include 
+#include 
+#include "proto.h"
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+struct png_stream {
+   unsigned char *stream_ptr;     /*  location to write PNG stream  */
+   g2int stream_len;               /*  number of bytes written       */
+};
+typedef struct png_stream png_stream;
+
+void user_read_data(png_structp , png_bytep , png_uint_32 );
+
+void user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length)
+/*
+        Custom read function used so that libpng will read a PNG stream
+        from memory instead of a file on disk.
+*/
+{
+     char *ptr;
+     g2int offset;
+     png_stream *mem;
+
+     mem=(png_stream *)png_get_io_ptr(png_ptr);
+     ptr=(void *)mem->stream_ptr;
+     offset=mem->stream_len;
+/*     printf("SAGrd %ld %ld %x\n",offset,length,ptr);  */
+     memcpy(data,ptr+offset,length);
+     mem->stream_len += length;
+}
+
+
+
+int DEC_PNG(unsigned char *pngbuf,g2int *width,g2int *height,char *cout)
+{
+    int interlace,color,compres,filter,bit_depth;
+    g2int j,k,n,bytes,clen;
+    png_structp png_ptr;
+    png_infop info_ptr,end_info;
+    png_bytepp row_pointers;
+    png_stream read_io_ptr;
+
+/*  check if stream is a valid PNG format   */
+
+    if ( png_sig_cmp(pngbuf,0,8) != 0) 
+       return (-3);
+
+/* create and initialize png_structs  */
+
+    png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING, (png_voidp)NULL, 
+                                      NULL, NULL);
+    if (!png_ptr)
+       return (-1);
+
+    info_ptr = png_create_info_struct(png_ptr);
+    if (!info_ptr)
+    {
+       png_destroy_read_struct(&png_ptr,(png_infopp)NULL,(png_infopp)NULL);
+       return (-2);
+    }
+
+    end_info = png_create_info_struct(png_ptr);
+    if (!end_info)
+    {
+       png_destroy_read_struct(&png_ptr,(png_infopp)info_ptr,(png_infopp)NULL);
+       return (-2);
+    }
+
+/*     Set Error callback   */
+
+    if (setjmp(png_jmpbuf(png_ptr)))
+    {
+       png_destroy_read_struct(&png_ptr, &info_ptr,&end_info);
+       return (-3);
+    }
+
+/*    Initialize info for reading PNG stream from memory   */
+
+    read_io_ptr.stream_ptr=(png_voidp)pngbuf;
+    read_io_ptr.stream_len=0;
+
+/*    Set new custom read function    */
+
+    png_set_read_fn(png_ptr,(voidp)&read_io_ptr,(png_rw_ptr)user_read_data);
+/*     png_init_io(png_ptr, fptr);   */
+
+/*     Read and decode PNG stream   */
+
+    png_read_png(png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL);
+
+/*     Get pointer to each row of image data   */
+
+    row_pointers = png_get_rows(png_ptr, info_ptr);
+
+/*     Get image info, such as size, depth, colortype, etc...   */
+
+    /*printf("SAGT:png %d %d %d\n",info_ptr->width,info_ptr->height,info_ptr->bit_depth);*/
+    (void)png_get_IHDR(png_ptr, info_ptr, (png_uint_32 *)width, (png_uint_32 *)height,
+               &bit_depth, &color, &interlace, &compres, &filter);
+
+/*     Check if image was grayscale      */
+
+/*
+    if (color != PNG_COLOR_TYPE_GRAY ) {
+       fprintf(stderr,"dec_png: Grayscale image was expected. \n");
+    }
+*/
+    if ( color == PNG_COLOR_TYPE_RGB ) {
+       bit_depth=24;
+    }
+    else if ( color == PNG_COLOR_TYPE_RGB_ALPHA ) {
+       bit_depth=32;
+    }
+/*     Copy image data to output string   */
+
+    n=0;
+    bytes=bit_depth/8;
+    clen=(*width)*bytes;
+    for (j=0;j<*height;j++) {
+      for (k=0;k
+#include 
+#include 
+#include "jasper/jasper.h"
+#define JAS_1_700_2
+#include "proto.h"
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+int ENC_JPEG2000(unsigned char *cin,g2int *pwidth,g2int *pheight,g2int *pnbits,
+                 g2int *ltype, g2int *ratio, g2int *retry, char *outjpc, 
+                 g2int *jpclen)
+/*$$$  SUBPROGRAM DOCUMENTATION BLOCK
+*                .      .    .                                       .
+* SUBPROGRAM:    enc_jpeg2000      Encodes JPEG2000 code stream
+*   PRGMMR: Gilbert          ORG: W/NP11     DATE: 2002-12-02
+*
+* ABSTRACT: This Function encodes a grayscale image into a JPEG2000 code stream
+*   specified in the JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) 
+*   using JasPer Software version 1.500.4 (or 1.700.2 ) written by the 
+*   University of British Columbia, Image Power Inc, and others.
+*   JasPer is available at http://www.ece.uvic.ca/~mdadams/jasper/.
+*
+* PROGRAM HISTORY LOG:
+* 2002-12-02  Gilbert
+* 2004-07-20  GIlbert - Added retry argument/option to allow option of
+*                       increasing the maximum number of guard bits to the
+*                       JPEG2000 algorithm.
+*
+* USAGE:    int enc_jpeg2000(unsigned char *cin,g2int *pwidth,g2int *pheight,
+*                            g2int *pnbits, g2int *ltype, g2int *ratio, 
+*                            g2int *retry, char *outjpc, g2int *jpclen)
+*
+*   INPUT ARGUMENTS:
+*      cin   - Packed matrix of Grayscale image values to encode.
+*    pwidth  - Pointer to width of image
+*    pheight - Pointer to height of image
+*    pnbits  - Pointer to depth (in bits) of image.  i.e number of bits
+*              used to hold each data value
+*    ltype   - Pointer to indicator of lossless or lossy compression
+*              = 1, for lossy compression
+*              != 1, for lossless compression
+*    ratio   - Pointer to target compression ratio.  (ratio:1)
+*              Used only when *ltype == 1.
+*    retry   - Pointer to option type.
+*              1 = try increasing number of guard bits
+*              otherwise, no additional options
+*    jpclen  - Number of bytes allocated for new JPEG2000 code stream in
+*              outjpc.
+*
+*   INPUT ARGUMENTS:
+*     outjpc - Output encoded JPEG2000 code stream
+*
+*   RETURN VALUES :
+*        > 0 = Length in bytes of encoded JPEG2000 code stream
+*         -3 = Error decode jpeg2000 code stream.
+*         -5 = decoded image had multiple color components.
+*              Only grayscale is expected.
+*
+* REMARKS:
+*
+*      Requires JasPer Software version 1.500.4 or 1.700.2
+*
+* ATTRIBUTES:
+*   LANGUAGE: C
+*   MACHINE:  IBM SP
+*
+*$$$*/
+{
+    int ier,rwcnt;
+    jas_image_t image;
+    jas_stream_t *jpcstream,*istream;
+    jas_image_cmpt_t cmpt,*pcmpt;
+#define MAXOPTSSIZE 1024
+    char opts[MAXOPTSSIZE];
+
+    g2int width,height,nbits;
+    width=*pwidth;
+    height=*pheight;
+    nbits=*pnbits;
+/*
+    printf(" enc_jpeg2000:width %ld\n",width);
+    printf(" enc_jpeg2000:height %ld\n",height);
+    printf(" enc_jpeg2000:nbits %ld\n",nbits);
+    printf(" enc_jpeg2000:jpclen %ld\n",*jpclen);
+*/
+//    jas_init();
+
+//
+//    Set lossy compression options, if requested.
+//
+    if ( *ltype != 1 ) {
+       opts[0]=(char)0;
+    }
+    else {
+       snprintf(opts,MAXOPTSSIZE,"mode=real\nrate=%f",1.0/(float)*ratio);
+    }
+    if ( *retry == 1 ) {             // option to increase number of guard bits
+       strcat(opts,"\nnumgbits=4");
+    }
+    //printf("SAGopts: %s\n",opts);
+    
+//
+//     Initialize the JasPer image structure describing the grayscale
+//     image to encode into the JPEG2000 code stream.
+//
+    image.tlx_=0;
+    image.tly_=0;
+#ifdef JAS_1_500_4 
+    image.brx_=(uint_fast32_t)width;
+    image.bry_=(uint_fast32_t)height;
+#endif 
+#ifdef JAS_1_700_2
+    image.brx_=(jas_image_coord_t)width;
+    image.bry_=(jas_image_coord_t)height;
+#endif
+    image.numcmpts_=1;
+    image.maxcmpts_=1;
+#ifdef JAS_1_500_4
+    image.colormodel_=JAS_IMAGE_CM_GRAY;         /* grayscale Image */
+#endif
+#ifdef JAS_1_700_2
+    image.clrspc_=JAS_CLRSPC_SGRAY;         /* grayscale Image */
+    image.cmprof_=0; 
+#endif
+    image.inmem_=1;
+
+    cmpt.tlx_=0;
+    cmpt.tly_=0;
+    cmpt.hstep_=1;
+    cmpt.vstep_=1;
+#ifdef JAS_1_500_4
+    cmpt.width_=(uint_fast32_t)width;
+    cmpt.height_=(uint_fast32_t)height;
+#endif
+#ifdef JAS_1_700_2
+    cmpt.width_=(jas_image_coord_t)width;
+    cmpt.height_=(jas_image_coord_t)height;
+    cmpt.type_=JAS_IMAGE_CT_COLOR(JAS_CLRSPC_CHANIND_GRAY_Y);
+#endif
+    cmpt.prec_=nbits;
+    cmpt.sgnd_=0;
+    cmpt.cps_=(nbits+7)/8;
+
+    pcmpt=&cmpt;
+    image.cmpts_=&pcmpt;
+
+//
+//    Open a JasPer stream containing the input grayscale values
+//
+    istream=jas_stream_memopen((char *)cin,height*width*cmpt.cps_);
+    cmpt.stream_=istream;
+
+//
+//    Open an output stream that will contain the encoded jpeg2000
+//    code stream.
+//
+    jpcstream=jas_stream_memopen(outjpc,(int)(*jpclen));
+
+//
+//     Encode image.
+//
+    ier=jpc_encode(&image,jpcstream,opts);
+    if ( ier != 0 ) {
+       printf(" jpc_encode return = %d \n",ier);
+       return -3;
+    }
+//
+//     Clean up JasPer work structures.
+//    
+    rwcnt=jpcstream->rwcnt_;
+    ier=jas_stream_close(istream);
+    ier=jas_stream_close(jpcstream);
+//
+//      Return size of jpeg2000 code stream
+//
+    return (rwcnt);
+
+}
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/enc_png.c b/wrfv2_fire/external/io_grib2/g2lib/enc_png.c
new file mode 100644
index 00000000..7d2ef1d2
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/enc_png.c
@@ -0,0 +1,133 @@
+#include 
+#include 
+#include 
+#include 
+#include "proto.h"
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+struct png_stream {
+   unsigned char *stream_ptr;     /*  location to write PNG stream  */
+   g2int stream_len;               /*  number of bytes written       */
+};
+typedef struct png_stream png_stream;
+
+void user_write_data(png_structp ,png_bytep , png_uint_32 );
+void user_flush_data(png_structp );
+
+void user_write_data(png_structp png_ptr,png_bytep data, png_uint_32 length)
+/*
+        Custom write function used to that libpng will write
+        to memory location instead of a file on disk
+*/
+{
+     unsigned char *ptr;
+     g2int offset;
+     png_stream *mem;
+
+     mem=(png_stream *)png_get_io_ptr(png_ptr);
+     ptr=mem->stream_ptr;
+     offset=mem->stream_len;
+/*     printf("SAGwr %ld %ld %x\n",offset,length,ptr);    */
+     /*for (j=offset,k=0;kstream_len += length;
+}
+
+
+void user_flush_data(png_structp png_ptr)
+/*
+        Dummy Custom flush function
+*/
+{
+   int *do_nothing=NULL;
+}
+
+
+int ENC_PNG(char *data,g2int *width,g2int *height,g2int *nbits,char *pngbuf)
+{
+ 
+    int color_type;
+    g2int j,bytes,pnglen,bit_depth;
+    png_structp png_ptr;
+    png_infop info_ptr;
+//    png_bytep *row_pointers[*height];
+    png_bytep **row_pointers;
+    png_stream write_io_ptr;
+
+/* create and initialize png_structs  */
+
+    png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING, (png_voidp)NULL, 
+                                      NULL, NULL);
+    if (!png_ptr)
+       return (-1);
+
+    info_ptr = png_create_info_struct(png_ptr);
+    if (!info_ptr)
+    {
+       png_destroy_write_struct(&png_ptr,(png_infopp)NULL);
+       return (-2);
+    }
+
+/*     Set Error callback   */
+
+    if (setjmp(png_jmpbuf(png_ptr)))
+    {
+       png_destroy_write_struct(&png_ptr, &info_ptr);
+       return (-3);
+    }
+
+/*    Initialize info for writing PNG stream to memory   */
+
+    write_io_ptr.stream_ptr=(png_voidp)pngbuf;
+    write_io_ptr.stream_len=0;
+
+/*    Set new custom write functions    */
+
+    png_set_write_fn(png_ptr,(voidp)&write_io_ptr,(png_rw_ptr)user_write_data,
+                    (png_flush_ptr)user_flush_data);
+/*    png_init_io(png_ptr, fptr);   */
+/*    png_set_compression_level(png_ptr, Z_BEST_COMPRESSION);  */
+
+/*     Set the image size, colortype, filter type, etc...      */
+
+/*    printf("SAGTsettingIHDR %d %d %d\n",*width,*height,bit_depth); */
+    bit_depth=*nbits;
+    color_type=PNG_COLOR_TYPE_GRAY;
+    if (*nbits == 24 ) {
+        bit_depth=8;
+        color_type=PNG_COLOR_TYPE_RGB;
+    }
+    else if (*nbits == 32 ) {
+        bit_depth=8;
+        color_type=PNG_COLOR_TYPE_RGB_ALPHA;
+    }
+    png_set_IHDR(png_ptr, info_ptr, *width, *height,
+       bit_depth, color_type, PNG_INTERLACE_NONE,
+       PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT);
+
+/*     Put image data into the PNG info structure    */
+
+    /*bytes=bit_depth/8;*/
+    bytes=*nbits/8;
+    row_pointers=malloc((*height)*sizeof(png_bytep));
+    for (j=0;j<*height;j++) row_pointers[j]=(png_bytep *)(data+(j*(*width)*bytes));
+    png_set_rows(png_ptr, info_ptr, (png_bytepp)row_pointers);
+
+/*     Do the PNG encoding, and write out PNG stream  */
+
+    png_write_png(png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL);
+
+/*     Clean up   */
+
+    png_destroy_write_struct(&png_ptr, &info_ptr);
+    free(row_pointers);
+    pnglen=write_io_ptr.stream_len;
+    return pnglen;
+
+}
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/g2grids.F b/wrfv2_fire/external/io_grib2/g2lib/g2grids.F
new file mode 100644
index 00000000..dd97999a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/g2grids.F
@@ -0,0 +1,320 @@
+      module g2grids
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    g2grids 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-04-27
+!
+! ABSTRACT: This Fortran Module allows access to predefined GRIB2 Grid 
+!   Definition Templates stored in a file.  The GDTs are represented by 
+!   a predefined number or a character abbreviation.
+!
+!   At the first request, all the grid GDT entries in the file associated
+!   with input Fortran file unit number, lunit, are read into a linked list
+!   named gridlist.  This list is searched for the requested entry.
+!
+!   Users of this Fortran module should only call routines getgridbynum
+!   and getgridbyname.
+!
+!   The format of the file scanned by routines in this module is as follows.
+!   Each line contains one Grid entry containing five fields, each separated
+!   by a colon, ":".  The fields are:
+!      1) - predefined grid number
+!      2) - Up to an 8 character abbreviation
+!      3) - Grid Definition Template number
+!      4) - Number of entries in the Grid Definition Template
+!      5) - A list of values for each entry in the Grid Definition Template.
+!
+!   As an example, this is the entry for the 1x1 GFS global grid 
+!   3:gbl_1deg:  0:19: 0 0 0 0 0 0 0 360 181 0 0 90000000 0 48 -90000000 359000000 1000000 1000000 0
+!
+!   Comments can be included in the file by specifying the symbol "#" as the
+!   first character on the line.  These lines are ignored.
+!
+!
+! PROGRAM HISTORY LOG:
+! 2004-04-27  Gilbert
+!
+! USAGE:    use g2grids
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,parameter :: MAXTEMP=200
+
+      type,private :: g2grid
+          integer :: grid_num
+          integer :: gdt_num
+          integer :: gdt_len
+          integer,dimension(MAXTEMP) :: gridtmpl
+          character(len=8) :: cdesc
+          type(g2grid),pointer :: next
+      end type g2grid
+
+      type(g2grid),pointer,private :: gridlist
+      integer :: num_grids=0
+
+      contains
+
+
+         integer function readgrids(lunit)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    readgrids
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-28
+!
+! ABSTRACT: This function reads the list of GDT entries in the file 
+!   associated with fortran unit, lunit.  All the entries are stored in a
+!   linked list called gridlist.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-28  Gilbert
+!
+! USAGE:    number=readgrids(lunit)
+!   INPUT ARGUMENT LIST:
+!     lunit   - Fortran unit number associated the the GDT file.
+!
+! RETURNS:  The number of Grid Definition Templates read in.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: lunit
+
+           integer,parameter :: linelen=1280
+           character(len=8) :: desc
+           character(len=linelen) :: cline
+           integer  ient,igdtn,igdtmpl(200),igdtlen
+           integer :: pos1,pos2,pos3,pos4
+
+           type(g2grid),pointer :: gtemp
+           type(g2grid),pointer :: prev
+           integer count
+
+           count=0
+
+           !   For each line in the file....
+           DO
+             !  Read line into buffer
+             !
+             cline(1:linelen)=' '
+             read(lunit,end=999,fmt='(a)') cline
+
+             !
+             !  Skip line if commented out
+             !
+             if (cline(1:1).eq.'#') cycle
+
+             !
+             !  find positions of delimiters, ":"
+             !
+             pos1=index(cline,':')
+             cline(pos1:pos1)=';'
+             pos2=index(cline,':')
+             cline(pos2:pos2)=';'
+             pos3=index(cline,':')
+             cline(pos3:pos3)=';'
+             pos4=index(cline,':')
+             if ( pos1.eq.0 .or. pos2.eq.0 .or. pos3.eq.0 .or. 
+     &            pos4.eq.0) cycle
+
+             !
+             !  Read each of the five fields.
+             !
+             read(cline(1:pos1-1),*) ient
+             read(cline(pos1+1:pos2-1),*) desc
+             read(cline(pos2+1:pos3-1),*) igdtn
+             read(cline(pos3+1:pos4-1),*) igdtlen
+             read(cline(pos4+1:linelen),*) (igdtmpl(j),j=1,igdtlen)
+
+             !
+             !  Allocate new type(g2grid) variable to store the GDT
+             !
+             allocate(gtemp,stat=iom)
+             count=count+1
+             gtemp%grid_num=ient
+             gtemp%gdt_num=igdtn
+             gtemp%gdt_len=igdtlen
+             gtemp%gridtmpl=igdtmpl
+             gtemp%cdesc=desc
+             nullify(gtemp%next)              ! defines end of linked list.
+             if ( count .eq. 1 ) then
+                gridlist => gtemp
+             else                       ! make sure previous entry in list
+                prev%next => gtemp      ! points to the new entry,
+             endif
+             prev => gtemp
+
+           enddo
+
+ 999       readgrids=count
+           return
+
+         end function
+
+
+         subroutine getgridbynum(lunit,number,igdtn,igdtmpl,iret)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getgridbynum 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-04-26
+!
+! ABSTRACT: This subroutine searches a file referenced by fortran unit lunit
+!   for a Grid Definition Template assigned to the requested number. 
+!   The input file format is described at the top of this module.
+!
+! PROGRAM HISTORY LOG:
+! 2004-04-26  Gilbert
+!
+! USAGE:    CALL getgridbynum(lunit,number,igdtn,igdtmpl,iret)
+!   INPUT ARGUMENT LIST:
+!     lunit    - Unit number of file containing Grid definitions 
+!     number   - Grid number of the requested Grid definition 
+!
+!   OUTPUT ARGUMENT LIST:      
+!     igdtn    - NN, indicating the number of the Grid Definition 
+!                Template 3.NN
+!     igdtmpl()- An array containing the values of each entry in
+!                the Grid Definition Template.
+!     iret     - Error return code.
+!                0 = no error
+!               -1 = Undefined Grid number.
+!                3 = Could not read any grids from file.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: lunit,number
+           integer,intent(out) :: igdtn,igdtmpl(*),iret
+
+           type(g2grid),pointer :: tempgrid
+
+           iret=0
+           igdtn=-1
+           !igdtmpl=0
+
+           !
+           !  If no grids in list, try reading them from the file.
+           !
+           if ( num_grids .eq. 0 ) then
+              num_grids=readgrids(lunit)
+           endif
+
+           if ( num_grids .eq. 0 ) then
+              iret=3                         ! problem reading file
+              return
+           endif
+
+           tempgrid => gridlist
+
+           !
+           !  Search through list
+           !
+           do while ( associated(tempgrid) )
+               if ( number .eq. tempgrid%grid_num ) then
+                  igdtn=tempgrid%gdt_num
+                  igdtmpl(1:tempgrid%gdt_len)=
+     &                        tempgrid%gridtmpl(1:tempgrid%gdt_len)
+                  return
+               else
+                  tempgrid => tempgrid%next
+               endif
+           enddo 
+ 
+           iret=-1
+           return
+ 
+         end subroutine
+
+
+         subroutine getgridbyname(lunit,name,igdtn,igdtmpl,iret)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getgridbyname 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-04-26
+!
+! ABSTRACT: This subroutine searches a file referenced by fortran unit lunit
+!   for a Grid Definition Template assigned to the requested name. 
+!   The input file format is described at the top of this module.
+!
+! PROGRAM HISTORY LOG:
+! 2004-04-26  Gilbert
+!
+! USAGE:    CALL getgridbyname(lunit,name,igdtn,igdtmpl,iret)
+!   INPUT ARGUMENT LIST:
+!     lunit    - Unit number of file containing Grid definitions 
+!     name     - Grid name of the requested Grid definition 
+!
+!   OUTPUT ARGUMENT LIST:      
+!     igdtn    - NN, indicating the number of the Grid Definition 
+!                Template 3.NN
+!     igdtmpl()- An array containing the values of each entry in
+!                the Grid Definition Template.
+!     iret     - Error return code.
+!                0 = no error
+!               -1 = Undefined Grid number.
+!                3 = Could not read any grids from file.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: lunit
+           character(len=8),intent(in) :: name
+           integer,intent(out) :: igdtn,igdtmpl(*),iret
+
+           type(g2grid),pointer :: tempgrid
+
+           iret=0
+           igdtn=-1
+           !igdtmpl=0
+
+           !
+           !  If no grids in list, try reading them from the file.
+           !
+           if ( num_grids .eq. 0 ) then
+              num_grids=readgrids(lunit)
+           endif
+
+           if ( num_grids .eq. 0 ) then
+              iret=3                         ! problem reading file
+              return
+           endif
+
+           tempgrid => gridlist
+
+           !
+           !  Search through list
+           !
+           do while ( associated(tempgrid) )
+               if ( name .eq. tempgrid%cdesc ) then
+                  igdtn=tempgrid%gdt_num
+                  igdtmpl(1:tempgrid%gdt_len)=
+     &                     tempgrid%gridtmpl(1:tempgrid%gdt_len)
+                  return
+               else
+                  tempgrid => tempgrid%next
+               endif
+           enddo 
+ 
+           iret=-1
+           return
+ 
+         end subroutine
+
+
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gb_info.F b/wrfv2_fire/external/io_grib2/g2lib/gb_info.F
new file mode 100644
index 00000000..a15d632e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gb_info.F
@@ -0,0 +1,194 @@
+      subroutine gb_info(cgrib,lcgrib,listsec0,listsec1,
+     &                    numfields,numlocal,maxlocal,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gb_info 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-25
+!
+! ABSTRACT: This subroutine searches through a GRIB2 message and
+!   returns the number of gridded fields found in the message and
+!   the number (and maximum size) of Local Use Sections.
+!   Also various checks  are performed
+!   to see if the message is a valid GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-25  Gilbert
+!
+! USAGE:    CALL gb_info(cgrib,lcgrib,listsec0,listsec1,
+!     &                    numfields,numlocal,maxlocal,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message in array cgrib.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     listsec0 - Contains information decoded from GRIB Indicator Section 0.
+!                Must be dimensioned >= 2.
+!                listsec0(1)=Discipline-GRIB Master Table Number
+!                            (see Code Table 0.0)
+!                listsec0(2)=GRIB Edition Number (currently 2)
+!                listsec0(3)=Length of GRIB message
+!     listsec1 - Contains information read from GRIB Identification Section 1.
+!                Must be dimensioned >= 13.
+!                listsec1(1)=Id of orginating centre (Common Code Table C-1)
+!                listsec1(2)=Id of orginating sub-centre (local table)
+!                listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0)
+!                listsec1(4)=GRIB Local Tables Version Number 
+!                listsec1(5)=Significance of Reference Time (Code Table 1.1)
+!                listsec1(6)=Reference Time - Year (4 digits)
+!                listsec1(7)=Reference Time - Month
+!                listsec1(8)=Reference Time - Day
+!                listsec1(9)=Reference Time - Hour
+!                listsec1(10)=Reference Time - Minute
+!                listsec1(11)=Reference Time - Second
+!                listsec1(12)=Production status of data (Code Table 1.2)
+!                listsec1(13)=Type of processed data (Code Table 1.3)
+!     numfields- The number of gridded fieldse found in the GRIB message.
+!     numlocal - The number of Local Use Sections ( Section 2 ) found in 
+!                the GRIB message.
+!     maxlocal-  The size of the largest Local Use Section ( Section 2 ).
+!                Can be used to ensure that the return array passed
+!                to subroutine getlocal is dimensioned large enough.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = Could not find Section 1, where expected.
+!                4 = End string "7777" found, but not where expected.
+!                5 = End string "7777" not found at end of message.
+!                6 = Invalid section number found.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(out) :: listsec0(3),listsec1(13)
+      integer,intent(out) :: numlocal,numfields,maxlocal,ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      integer,parameter :: zero=0,one=1
+      integer,parameter :: mapsec1len=13
+      integer,parameter :: 
+     &        mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /)
+      integer iofst,ibeg,istart
+
+      ierr=0
+      numlocal=0
+      numfields=0
+      maxlocal=0
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'gb_info:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      listsec0(3)=lengrib
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'gb_info: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Unpack Section 1 - Identification Section
+!
+      call g2lib_gbyte(cgrib,lensec1,iofst,32)        ! Length of Section 1
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Section number ( 1 )
+      iofst=iofst+8
+      if (isecnum.ne.1) then
+        print *,'gb_info: Could not find section 1.'
+        ierr=3
+        return
+      endif
+      !
+      !   Unpack each input value in array listsec1 into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapsec1.
+      !
+      do i=1,mapsec1len
+        nbits=mapsec1(i)*8
+        call g2lib_gbyte(cgrib,listsec1(i),iofst,nbits)
+        iofst=iofst+nbits
+      enddo
+      ipos=ipos+lensec1
+!
+!  Loop through the remaining sections to see if they are valid.
+!  Also count the number of times Section 2
+!  and Section 4 appear.
+!
+      do
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'gb_info: "7777" found, but not where expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'gb_info: "7777"  not found at end of GRIB message.'
+          ierr=5
+          return
+        endif
+        if ( isecnum.ge.2.AND.isecnum.le.7 ) then
+           if (isecnum.eq.2) then     ! Local Section 2
+              !   increment counter for total number of local sections found
+              numlocal=numlocal+1
+              lenposs=lensec-5
+              if ( lenposs.gt.maxlocal ) maxlocal=lenposs
+           elseif (isecnum.eq.4) then
+              !   increment counter for total number of fields found
+              numfields=numfields+1
+           endif
+        else
+           print *,'gb_info: Invalid section number found in GRIB',
+     &             ' message: ',isecnum
+           ierr=6
+           return
+        endif
+        
+      enddo
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gbytesc.F b/wrfv2_fire/external/io_grib2/g2lib/gbytesc.F
new file mode 100644
index 00000000..170c4728
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gbytesc.F
@@ -0,0 +1,127 @@
+      SUBROUTINE G2LIB_GBYTE(IN,IOUT,ISKIP,NBYTE)
+      character*1 in(*)
+      integer iout(*)
+      CALL G2LIB_GBYTES(IN,IOUT,ISKIP,NBYTE,0,1)
+      RETURN
+      END
+
+      SUBROUTINE G2LIB_SBYTE(OUT,IN,ISKIP,NBYTE)
+      character*1 out(*)
+      integer in(*)
+      CALL G2LIB_SBYTES(OUT,IN,ISKIP,NBYTE,0,1)
+      RETURN
+      END
+
+      SUBROUTINE G2LIB_GBYTES(IN,IOUT,ISKIP,NBYTE,NSKIP,N)
+C          Get bytes - unpack bits:  Extract arbitrary size values from a
+C          packed bit string, right justifying each value in the unpacked
+C          array.
+C            IN    = character*1 array input
+C            IOUT  = unpacked array output
+C            ISKIP = initial number of bits to skip
+C            NBYTE = number of bits to take
+C            NSKIP = additional number of bits to skip on each iteration
+C            N     = number of iterations
+C v1.1
+C
+      character*1 in(*)
+      integer iout(*)
+      integer ones(8), tbit, bitcnt
+      save ones
+      data ones/1,3,7,15,31,63,127,255/
+
+c     nbit is the start position of the field in bits
+      nbit = iskip
+      do i = 1, n
+         bitcnt = nbyte
+         index=nbit/8+1
+         ibit=mod(nbit,8)
+         nbit = nbit + nbyte + nskip
+
+c        first byte
+         tbit = min(bitcnt,8-ibit)
+         itmp = iand(mova2i(in(index)),ones(8-ibit))
+         if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit)
+         index = index + 1
+         bitcnt = bitcnt - tbit
+
+c        now transfer whole bytes
+         do while (bitcnt.ge.8)
+             itmp = ior(ishft(itmp,8),mova2i(in(index)))
+             bitcnt = bitcnt - 8
+             index = index + 1
+         enddo
+
+c        get data from last byte
+         if (bitcnt.gt.0) then
+             itmp = ior(ishft(itmp,bitcnt),iand(ishft(mova2i(in(index)),
+     1          -(8-bitcnt)),ones(bitcnt)))
+         endif
+
+         iout(i) = itmp
+      enddo
+
+      RETURN
+      END                                                                  
+
+      SUBROUTINE G2LIB_SBYTES(OUT,IN,ISKIP,NBYTE,NSKIP,N)
+C          Store bytes - pack bits:  Put arbitrary size values into a
+C          packed bit string, taking the low order bits from each value
+C          in the unpacked array.
+C            IOUT  = packed array output
+C            IN    = unpacked array input
+C            ISKIP = initial number of bits to skip
+C            NBYTE = number of bits to pack
+C            NSKIP = additional number of bits to skip on each iteration
+C            N     = number of iterations
+C v1.1
+C
+      character*1 out(*)
+      integer in(N), bitcnt, ones(8), tbit
+      save ones
+      data ones/    1,  3,  7, 15, 31, 63,127,255/
+
+c     number bits from zero to ...
+c     nbit is the last bit of the field to be filled
+
+      nbit = iskip + nbyte - 1
+      do i = 1, n
+         itmp = in(i)
+         bitcnt = nbyte
+         index=nbit/8+1
+         ibit=mod(nbit,8)
+         nbit = nbit + nbyte + nskip
+
+c        make byte aligned 
+         if (ibit.ne.7) then
+             tbit = min(bitcnt,ibit+1)
+             imask = ishft(ones(tbit),7-ibit)
+             itmp2 = iand(ishft(itmp,7-ibit),imask)
+             itmp3 = iand(mova2i(out(index)), 255-imask)
+             out(index) = char(ior(itmp2,itmp3))
+             bitcnt = bitcnt - tbit
+             itmp = ishft(itmp, -tbit)
+             index = index - 1
+         endif
+
+c        now byte aligned
+
+c        do by bytes
+         do while (bitcnt.ge.8)
+             out(index) = char(iand(itmp,255))
+             itmp = ishft(itmp,-8)
+             bitcnt = bitcnt - 8
+             index = index - 1
+         enddo
+
+c        do last byte
+
+         if (bitcnt.gt.0) then
+             itmp2 = iand(itmp,ones(bitcnt))
+             itmp3 = iand(mova2i(out(index)), 255-ones(bitcnt))
+             out(index) = char(ior(itmp2,itmp3))
+         endif
+      enddo
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gdt2gds.F b/wrfv2_fire/external/io_grib2/g2lib/gdt2gds.F
new file mode 100644
index 00000000..f0b67db7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gdt2gds.F
@@ -0,0 +1,266 @@
+        subroutine gdt2gds(igds,igdstmpl,idefnum,ideflist,kgds,
+     &                     igrid,iret)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C                .      .    .                                       .
+C SUBPROGRAM:    gdt2gds
+C   PRGMMR: Gilbert        ORG: W/NP11    DATE: 2003-06-17
+C
+C ABSTRACT: This routine converts grid information from a GRIB2
+C   Grid Description Section as well as its
+C   Grid Definition Template to GRIB1 GDS info.  In addition,
+C   a check is made to determine if the grid is an NCEP
+C   predefined grid.
+C
+C PROGRAM HISTORY LOG:
+C 2003-06-17  Gilbert
+C 2004-04-27  Gilbert - Added support for gaussian grids.
+C
+C USAGE:    CALL gdt2gds(igds,igdstmpl,idefnum,ideflist,kgds,igrid,iret)
+C   INPUT ARGUMENT LIST:
+C     igds()   - Contains information read from the appropriate GRIB Grid
+C                Definition Section 3 for the field being returned.
+C                Must be dimensioned >= 5.
+C                igds(1)=Source of grid definition (see Code Table 3.0)
+C                igds(2)=Number of grid points in the defined grid.
+C                igds(3)=Number of octets needed for each
+C                            additional grid points definition.
+C                            Used to define number of
+C                            points in each row ( or column ) for
+C                            non-regular grids.
+C                            = 0, if using regular grid.
+C                igds(4)=Interpretation of list for optional points
+C                            definition.  (Code Table 3.11)
+C                igds(5)=Grid Definition Template Number (Code Table 3.1)
+C     igdstmpl() - Grid Definition Template values for GDT 3.igds(5)
+C     idefnum    - The number of entries in array ideflist.  
+C                  i.e. number of rows ( or columns )
+C                  for which optional grid points are defined.
+C     ideflist() - Optional integer array containing
+C                  the number of grid points contained in each row (or column).
+C
+C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
+C     kgds()   - GRIB1 GDS as described in w3fi63 format.
+C     igrid    - NCEP predifined GRIB1 grid number
+C                set to 255, if not NCEP grid
+C     iret     - Error return value:
+C                  0  = Successful
+C                  1  = Unrecognized GRIB2 GDT number 3.igds(5)
+C
+C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
+C
+C ATTRIBUTES:
+C   LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
+C   MACHINE:  IBM SP
+C
+C$$$
+! 
+        integer,intent(in) :: idefnum
+        integer,intent(in) :: igds(*),igdstmpl(*),ideflist(*)
+        integer,intent(out) :: kgds(*),igrid,iret
+
+        integer :: kgds72(200),kgds71(200),idum(200),jdum(200)
+
+        iret=0
+        if (igds(5).eq.0) then       !  Lat/Lon grid
+           kgds(1)=0
+           kgds(2)=igdstmpl(8)            ! Ni
+           kgds(3)=igdstmpl(9)            ! Nj
+           kgds(4)=igdstmpl(12)/1000      ! Lat of 1st grid point
+           kgds(5)=igdstmpl(13)/1000      ! Long of 1st grid point
+           kgds(6)=0                      ! resolution and component flags
+           if (igdstmpl(1)==2 ) kgds(6)=64
+           if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) 
+     &         kgds(6)=kgds(6)+128
+           if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8
+           kgds(7)=igdstmpl(15)/1000      ! Lat of last grid point
+           kgds(8)=igdstmpl(16)/1000      ! Long of last grid point
+           kgds(9)=igdstmpl(17)/1000      ! Di
+           kgds(10)=igdstmpl(18)/1000     ! Dj
+           kgds(11)=igdstmpl(19)          ! Scanning mode
+           kgds(12)=0
+           kgds(13)=0
+           kgds(14)=0
+           kgds(15)=0
+           kgds(16)=0
+           kgds(17)=0
+           kgds(18)=0
+           kgds(19)=0
+           kgds(20)=255
+           kgds(21)=0
+           kgds(22)=0
+           !
+           !  Process irreg grid stuff, if necessary
+           !
+           if ( idefnum.ne.0 ) then
+              if ( igdstmpl(8).eq.-1 ) then
+                 kgds(2)=65535
+                 kgds(9)=65535
+              endif
+              if ( igdstmpl(9).eq.-1 ) then
+                 kgds(3)=65535
+                 kgds(10)=65535
+              endif
+              kgds(19)=0
+              kgds(20)=33
+              if ( kgds(1).eq.1.OR.kgds(1).eq.3 ) kgds(20)=43
+              kgds(21)=igds(2)                   ! num of grid points
+              do j=1,idefnum
+                 kgds(21+j)=ideflist(j)
+              enddo
+           endif
+        elseif (igds(5).eq.10) then       !  Mercator grid
+           kgds(1)=1                 ! Grid Definition Template number
+           kgds(2)=igdstmpl(8)            ! Ni
+           kgds(3)=igdstmpl(9)            ! Nj
+           kgds(4)=igdstmpl(10)/1000      ! Lat of 1st grid point
+           kgds(5)=igdstmpl(11)/1000      ! Long of 1st grid point
+           kgds(6)=0                      ! resolution and component flags
+           if (igdstmpl(1)==2 ) kgds(6)=64
+           if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) 
+     &         kgds(6)=kgds(6)+128
+           if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8
+           kgds(7)=igdstmpl(14)/1000      ! Lat of last grid point
+           kgds(8)=igdstmpl(15)/1000      ! Long of last grid point
+           kgds(9)=igdstmpl(13)/1000      ! Lat intersects earth
+           kgds(10)=0
+           kgds(11)=igdstmpl(16)          ! Scanning mode
+           kgds(12)=igdstmpl(18)/1000     ! Di
+           kgds(13)=igdstmpl(19)/1000     ! Dj
+           kgds(14)=0
+           kgds(15)=0
+           kgds(16)=0
+           kgds(17)=0
+           kgds(18)=0
+           kgds(19)=0
+           kgds(20)=255
+           kgds(21)=0
+           kgds(22)=0
+        elseif (igds(5).eq.30) then       ! Lambert Conformal Grid
+           kgds(1)=3
+           kgds(2)=igdstmpl(8)            ! Nx
+           kgds(3)=igdstmpl(9)            ! Ny
+           kgds(4)=igdstmpl(10)/1000      ! Lat of 1st grid point
+           kgds(5)=igdstmpl(11)/1000      ! Long of 1st grid point
+           kgds(6)=0                      ! resolution and component flags
+           if (igdstmpl(1)==2 ) kgds(6)=64
+           if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) 
+     &         kgds(6)=kgds(6)+128
+           if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8
+           kgds(7)=igdstmpl(14)/1000      ! Lon of orientation
+           kgds(8)=igdstmpl(15)/1000      ! Dx
+           kgds(9)=igdstmpl(16)/1000      ! Dy
+           kgds(10)=igdstmpl(17)          ! Projection Center Flag
+           kgds(11)=igdstmpl(18)          ! Scanning mode
+           kgds(12)=igdstmpl(19)/1000     ! Lat in 1
+           kgds(13)=igdstmpl(20)/1000     ! Lat in 2
+           kgds(14)=igdstmpl(21)/1000     ! Lat of S. Pole of projection
+           kgds(15)=igdstmpl(22)/1000     ! Lon of S. Pole of projection
+           kgds(16)=0
+           kgds(17)=0
+           kgds(18)=0
+           kgds(19)=0
+           kgds(20)=255
+           kgds(21)=0
+           kgds(22)=0
+        elseif (igds(5).eq.40) then       !  Gaussian Lat/Lon grid
+           kgds(1)=4
+           kgds(2)=igdstmpl(8)            ! Ni
+           kgds(3)=igdstmpl(9)            ! Nj
+           kgds(4)=igdstmpl(12)/1000      ! Lat of 1st grid point
+           kgds(5)=igdstmpl(13)/1000      ! Long of 1st grid point
+           kgds(6)=0                      ! resolution and component flags
+           if (igdstmpl(1)==2 ) kgds(6)=64
+           if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) 
+     &         kgds(6)=kgds(6)+128
+           if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8
+           kgds(7)=igdstmpl(15)/1000      ! Lat of last grid point
+           kgds(8)=igdstmpl(16)/1000      ! Long of last grid point
+           kgds(9)=igdstmpl(17)/1000      ! Di
+           kgds(10)=igdstmpl(18)          ! N - Number of parallels
+           kgds(11)=igdstmpl(19)          ! Scanning mode
+           kgds(12)=0
+           kgds(13)=0
+           kgds(14)=0
+           kgds(15)=0
+           kgds(16)=0
+           kgds(17)=0
+           kgds(18)=0
+           kgds(19)=0
+           kgds(20)=255
+           kgds(21)=0
+           kgds(22)=0
+        elseif (igds(5).eq.20) then       ! Polar Stereographic Grid
+           kgds(1)=5
+           kgds(2)=igdstmpl(8)            ! Nx
+           kgds(3)=igdstmpl(9)            ! Ny
+           kgds(4)=igdstmpl(10)/1000      ! Lat of 1st grid point
+           kgds(5)=igdstmpl(11)/1000      ! Long of 1st grid point
+           kgds(6)=0                      ! resolution and component flags
+           if (igdstmpl(1)==2 ) kgds(6)=64
+           if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) 
+     &         kgds(6)=kgds(6)+128
+           if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8
+           kgds(7)=igdstmpl(14)/1000      ! Lon of orientation
+           kgds(8)=igdstmpl(15)/1000      ! Dx
+           kgds(9)=igdstmpl(16)/1000      ! Dy
+           kgds(10)=igdstmpl(17)          ! Projection Center Flag
+           kgds(11)=igdstmpl(18)          ! Scanning mode
+           kgds(12)=0
+           kgds(13)=0
+           kgds(14)=0
+           kgds(15)=0
+           kgds(16)=0
+           kgds(17)=0
+           kgds(18)=0
+           kgds(19)=0
+           kgds(20)=255
+           kgds(21)=0
+           kgds(22)=0
+        else
+           Print *,'gdt2gds: Unrecognized GRIB2 GDT = 3.',igds(5)
+           iret=1
+           kgds(1:22)=0
+           return
+        endif
+!
+!   Can we determine NCEP grid number ?
+!
+        igrid=255
+        do j=254,1,-1
+        !do j=225,225
+           kgds71=0
+           kgds72=0
+           call w3fi71(j,kgds71,ierr)
+           if ( ierr.ne.0 ) cycle
+           ! convert W to E for longitudes
+           if ( kgds71(3).eq.0 ) then    ! lat/lon
+              if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7)
+              if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10)
+           elseif ( kgds71(3).eq.1 ) then    ! mercator
+              if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7)
+              if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10)
+           elseif ( kgds71(3).eq.3 ) then     ! lambert conformal
+              if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7)
+              if ( kgds71(9).lt.0 ) kgds71(9)=360000+kgds71(9)
+              if ( kgds71(18).lt.0 ) kgds71(18)=360000+kgds71(18)
+           elseif ( kgds71(3).eq.4 ) then     ! Guassian lat/lon
+              if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7)
+              if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10)
+           elseif ( kgds71(3).eq.5 ) then     ! polar stereographic
+              if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7)
+              if ( kgds71(9).lt.0 ) kgds71(9)=360000+kgds71(9)
+           endif
+           call r63w72(idum,kgds,jdum,kgds72)
+           if ( kgds72(3).eq.3 ) kgds72(14)=0    ! lambert conformal fix
+           if ( kgds72(3).eq.1 ) kgds72(15:18)=0    ! mercator fix
+           if ( kgds72(3).eq.5 ) kgds72(14:18)=0    ! polar str fix
+           !print *,'SAGT71:',(kgds71(k),k=1,30)
+           !print *,'SAGT72:',(kgds72(k),k=1,30)
+           if ( all(kgds71.eq.kgds72) ) then
+              igrid=j
+              return
+           endif
+        enddo
+
+        return
+        end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getdim.F b/wrfv2_fire/external/io_grib2/g2lib/getdim.F
new file mode 100644
index 00000000..2e66068a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getdim.F
@@ -0,0 +1,102 @@
+      subroutine getdim(csec3,lcsec3,width,height,iscan)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getdim 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-12-11
+!
+! ABSTRACT: This subroutine returns the dimensions and scanning mode of 
+!   a grid definition packed in GRIB2 Grid Definition Section 3 format.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-11  Gilbert
+!
+! USAGE:    CALL getdim(csec3,lcsec3,width,height,iscan)
+!   INPUT ARGUMENT LIST:
+!     csec3    - Character array that contains the packed GRIB2 GDS
+!    lcsec3    - Length (in octets) of section 3
+!
+!   OUTPUT ARGUMENT LIST:      
+!     width    - x (or i) dimension of the grid.
+!     height   - y (or j) dimension of the grid.
+!     iscan    - Scanning mode ( see Code Table 3.4 )
+!
+! REMARKS:  Returns width and height set to zero, if grid template
+!           not recognized.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+!      use grib_mod
+    
+      character(len=1),intent(in) :: csec3(*)
+      integer,intent(in) :: lcsec3
+      integer,intent(out) :: width,height,iscan
+      
+      integer,pointer,dimension(:) :: igdstmpl,list_opt
+      integer :: igds(5)
+      integer iofst,igdtlen,num_opt,jerr
+
+      interface
+         subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                         mapgridlen,ideflist,idefnum,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: igdstmpl,ideflist
+            integer,intent(out) :: igds(5)
+            integer,intent(out) :: ierr,idefnum
+         end subroutine gf_unpack3
+      end interface
+
+      nullify(igdstmpl,list_opt)
+        !
+      iofst=0       ! set offset to beginning of section
+      call gf_unpack3(csec3,lcsec3,iofst,igds,igdstmpl,
+     &                 igdtlen,list_opt,num_opt,jerr)
+      if (jerr.eq.0) then
+         selectcase( igds(5) )     !  Template number
+           case (0:3)   ! Lat/Lon
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(19)
+           case (10)   ! Mercator
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(16)
+           case (20)   ! Polar Stereographic
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(18)
+           case (30)   ! Lambert Conformal
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(18)
+           case (40:43)   ! Gaussian
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(19)
+           case (90)   ! Space View/Orthographic
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(17)
+           case (110)   ! Equatorial Azimuthal
+              width=igdstmpl(8)
+              height=igdstmpl(9)
+              iscan=igdstmpl(16)
+           case default
+              width=0
+              height=0
+              iscan=0
+         end select
+      else
+         width=0
+         height=0
+      endif
+        !
+      if (associated(igdstmpl)) deallocate(igdstmpl)
+      if (associated(list_opt)) deallocate(list_opt)
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getfield.F b/wrfv2_fire/external/io_grib2/g2lib/getfield.F
new file mode 100644
index 00000000..c3d5b275
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getfield.F
@@ -0,0 +1,823 @@
+      subroutine getfield(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen,
+     &                    ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen,
+     &                    coordlist,numcoord,ndpts,idrsnum,idrstmpl,
+     &                    idrslen,ibmap,bmap,fld,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getfield 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine returns the Grid Definition, Product Definition,
+!   Bit-map ( if applicable ), and the unpacked data for a given data
+!   field.  Since there can be multiple data fields packed into a GRIB2
+!   message, the calling routine indicates which field is being requested
+!   with the ifldnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL getfield(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen,
+!    &                    ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen,
+!    &                    coordlist,numcoord,ndpts,idrsnum,idrstmpl,
+!    &                    idrslen,ibmap,bmap,fld,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     ifldnum  - Specifies which field in the GRIB2 message to return.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     igds     - Contains information read from the appropriate GRIB Grid 
+!                Definition Section 3 for the field being returned.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Contains the data values for the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(2), which is returned from subroutine gribinfo.
+!     igdslen  - Number of elements in igdstmpl().  i.e. number of entries
+!                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
+!     ideflist - (Used if igds(3) .ne. 0)  This array contains the
+!                number of grid points contained in each row ( or column ).
+!                (part of Section 3)
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(3), which is returned from subroutine gribinfo.
+!     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Contains the data values for the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(4), which is returned from subroutine gribinfo.
+!     ipdslen  - Number of elements in ipdstmpl().  i.e. number of entries
+!                in Product Defintion Template 4.N  ( N=ipdsnum ).
+!     coordlist- Array containg floating point values intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.  (part of Section 4)
+!                The dimension of this array can be obtained in advance
+!                from maxvals(5), which is returned from subroutine gribinfo.
+!     numcoord - number of values in array coordlist.
+!     ndpts    - Number of data points unpacked and returned.
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0)
+!     idrstmpl - Contains the data values for the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 5.N
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(6), which is returned from subroutine gribinfo.
+!     idrslen  - Number of elements in idrstmpl().  i.e. number of entries
+!                in Data Representation Template 5.N  ( N=idrsnum ).
+!     ibmap    - Bitmap indicator ( see Code Table 6.0 )
+!                0 = bitmap applies and is included in Section 6.
+!                1-253 = Predefined bitmap applies
+!                254 = Previously defined bitmap applies to this field
+!                255 = Bit map does not apply to this product.
+!     bmap()   - Logical*1 array containing decoded bitmap. ( if ibmap=0 )
+!                The dimension of this array can be obtained in advance
+!                from maxvals(7), which is returned from subroutine gribinfo.
+!     fld()    - Array of ndpts unpacked data points.
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(7), which is returned from subroutine gribinfo.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The data field request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                6 = GRIB message did not contain the requested number of
+!                    data fields.
+!                7 = End string "7777" not found at end of message.
+!                9 = Data Representation Template 5.NN not yet implemented.
+!               10 = Error unpacking Section 3.
+!               11 = Error unpacking Section 4.
+!               12 = Error unpacking Section 5.
+!               13 = Error unpacking Section 6.
+!               14 = Error unpacking Section 7.
+!
+! REMARKS: Note that subroutine gribinfo can be used to first determine
+!          how many data fields exist in a given GRIB message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ifldnum
+      integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*)
+      integer,intent(out) :: ipdsnum,ipdstmpl(*)
+      integer,intent(out) :: idrsnum,idrstmpl(*)
+      integer,intent(out) :: ndpts,ibmap,idefnum,numcoord
+      integer,intent(out) :: ierr
+      logical*1,intent(out) :: bmap(*)
+      real,intent(out) :: fld(*),coordlist(*)
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      integer:: listsec0(2)
+      integer iofst,ibeg,istart
+      integer(4) :: ieee
+      logical have3,have4,have5,have6,have7
+
+      have3=.false.
+      have4=.false.
+      have5=.false.
+      have6=.false.
+      have7=.false.
+      ierr=0
+      numfld=0
+!
+!  Check for valid request number
+!  
+      if (ifldnum.le.0) then
+        print *,'getfield: Request for field number must be positive.'
+        ierr=3
+        return
+      endif
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'getfield:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'getfield: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through the remaining sections keeping track of the 
+!  length of each.  Also keep the latest Grid Definition Section info.
+!  Unpack the requested field number.
+!
+      do
+        !    Check to see if we are at end of GRIB message
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          !    If end of GRIB message not where expected, issue error
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'getfield: "7777" found, but not where expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        !     Get length of Section and Section number
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        !print *,' lensec= ',lensec,'    secnum= ',isecnum
+        !
+        !   If found Section 3, unpack the GDS info using the 
+        !   appropriate template.  Save in case this is the latest
+        !   grid before the requested field.
+        !
+        if (isecnum.eq.3) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen,
+     &                 ideflist,idefnum,jerr)
+          if (jerr.eq.0) then
+            have3=.true.
+          else
+            ierr=10
+            return
+          endif
+        endif
+        !
+        !   If found Section 4, check to see if this field is the
+        !   one requested.
+        !
+        if (isecnum.eq.4) then
+          numfld=numfld+1
+          if (numfld.eq.ifldnum) then
+            iofst=iofst-40       ! reset offset to beginning of section
+            call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen,
+     &                   coordlist,numcoord,jerr)
+            if (jerr.eq.0) then
+              have4=.true.
+            else
+              ierr=11
+              return
+            endif
+          endif
+        endif
+        !
+        !   If found Section 5, check to see if this field is the
+        !   one requested.
+        !
+        if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
+     &                 idrslen,jerr)
+          if (jerr.eq.0) then
+            have5=.true.
+          else
+            ierr=12
+            return
+          endif
+        endif
+        !
+        !   If found Section 6, Unpack bitmap.
+        !   Save in case this is the latest
+        !   bitmap before the requested field.
+        !
+        if (isecnum.eq.6) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call unpack6(cgrib,lcgrib,iofst,igds(2),ibmap,bmap,jerr)
+          if (jerr.eq.0) then
+            have6=.true.
+          else
+            ierr=13
+            return
+          endif
+        endif
+        !
+        !   If found Section 7, check to see if this field is the
+        !   one requested.
+        !
+        if ((isecnum.eq.7).and.(numfld.eq.ifldnum)) then
+          if (idrsnum.eq.0) then
+            call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts,fld)
+            have7=.true.
+          elseif (idrsnum.eq.2.or.idrsnum.eq.3) then
+            call comunpack(cgrib(ipos+5),lensec-6,lensec,idrsnum,
+     &                     idrstmpl,ndpts,fld,ier)
+            if ( ier .ne. 0 ) then
+                ierr=14
+                return
+            endif
+            have7=.true.
+          elseif (idrsnum.eq.50) then
+            call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts-1,
+     &                     fld(2))
+            ieee=idrstmpl(5)
+            call rdieee(ieee,fld(1),1)
+            have7=.true.
+          else
+            print *,'getfield: Data Representation Template ',idrsnum,
+     &              ' not yet implemented.'
+            ierr=9
+            return
+          endif
+        endif
+        !
+        !   Check to see if we read pass the end of the GRIB
+        !   message and missed the terminator string '7777'.
+        !
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'getfield: "7777"  not found at end of GRIB message.'
+          ierr=7
+          return
+        endif
+
+        if (have3.and.have4.and.have5.and.have6.and.have7) return
+        
+      enddo
+
+!
+!  If exited from above loop, the end of the GRIB message was reached
+!  before the requested field was found.
+!
+      print *,'getfield: GRIB message contained ',numlocal,
+     &        ' different fields.'
+      print *,'getfield: The request was for the ',ifldnum,
+     &        ' field.'
+      ierr=6
+
+      return
+      end
+
+
+      subroutine unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                   mapgridlen,ideflist,idefnum,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    unpack3 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 3 (Grid Definition Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL unpack3(cgrib,lcgrib,lensec,iofst,igds,igdstmpl,
+!    &                   mapgridlen,ideflist,idefnum,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 3.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 3, returned.
+!     igds     - Contains information read from the appropriate GRIB Grid 
+!                Definition Section 3 for the field being returned.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Contains the data values for the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!     mapgridlen- Number of elements in igdstmpl().  i.e. number of entries
+!                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
+!     ideflist - (Used if igds(3) .ne. 0)  This array contains the
+!                number of grid points contained in each row ( or column ).
+!                (part of Section 3)
+!     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!     ierr     - Error return code.
+!                0 = no error
+!                5 = "GRIB" message contains an undefined Grid Definition
+!                    Template.
+!
+! REMARKS: Uses Fortran 90 module gridtemplates.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use gridtemplates
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*)
+      integer,intent(out) :: ierr,idefnum
+
+      integer,allocatable :: mapgrid(:)
+      integer :: mapgridlen,ibyttem
+      logical needext
+
+      ierr=0
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+
+      call g2lib_gbyte(cgrib,igds(1),iofst,8)     ! Get source of Grid def.
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(2),iofst,32)    ! Get number of grid pts.
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,igds(3),iofst,8)     ! Get num octets for opt. list
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(4),iofst,8)     ! Get interpret. for opt. list
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(5),iofst,16)    ! Get Grid Def Template num.
+      iofst=iofst+16
+      if (igds(1).eq.0) then
+!      if (igds(1).eq.0.OR.igds(1).eq.255) then  ! FOR ECMWF TEST ONLY
+        allocate(mapgrid(lensec))
+        !   Get Grid Definition Template
+        call getgridtemplate(igds(5),mapgridlen,mapgrid,needext,
+     &                       iret)
+        if (iret.ne.0) then
+          ierr=5
+          return
+        endif
+      else
+!        igdstmpl=-1
+        mapgridlen=0
+        needext=.false.
+      endif
+      !
+      !   Unpack each value into array igdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapgrid.
+      !
+      ibyttem=0
+      do i=1,mapgridlen
+        nbits=iabs(mapgrid(i))*8
+        if ( mapgrid(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
+        endif
+        iofst=iofst+nbits
+        ibyttem=ibyttem+iabs(mapgrid(i))
+      enddo
+      !
+      !   Check to see if the Grid Definition Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid)
+        !   Unpack the rest of the Grid Definition Template
+        do i=mapgridlen+1,newmapgridlen
+          nbits=iabs(mapgrid(i))*8
+          if ( mapgrid(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
+          endif
+          iofst=iofst+nbits
+          ibyttem=ibyttem+iabs(mapgrid(i))
+        enddo
+        mapgridlen=newmapgridlen
+      endif
+      !
+      !   Unpack optional list of numbers defining number of points
+      !   in each row or column, if included.  This is used for non regular
+      !   grids.
+      !
+      if ( igds(3).ne.0 ) then
+         nbits=igds(3)*8
+         idefnum=(lensec-14-ibyttem)/igds(3)
+         call g2lib_gbytes(cgrib,ideflist,iofst,nbits,0,idefnum)
+         iofst=iofst+(nbits*idefnum)
+      else
+         idefnum=0
+      endif
+      if( allocated(mapgrid) ) deallocate(mapgrid)
+      return    ! End of Section 3 processing
+      end
+
+
+      subroutine unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen,
+     &                   coordlist,numcoord,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    unpack4 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 4 (Product Definition Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen,
+!    &                   coordlist,numcoord,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 4.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset of the end of Section 4, returned.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Contains the data values for the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!     mappdslen- Number of elements in ipdstmpl().  i.e. number of entries
+!                in Product Defintion Template 4.N  ( N=ipdsnum ).
+!     coordlist- Array containg floating point values intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.  (part of Section 4)
+!     numcoord - number of values in array coordlist.
+!     ierr     - Error return code.
+!                0 = no error
+!                5 = "GRIB" message contains an undefined Product Definition
+!                    Template.
+!
+! REMARKS: Uses Fortran 90 module pdstemplates.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use pdstemplates
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      real,intent(out) :: coordlist(*)
+      integer,intent(out) :: ipdsnum,ipdstmpl(*)
+      integer,intent(out) :: ierr,numcoord
+
+      real(4),allocatable :: coordieee(:)
+      integer,allocatable :: mappds(:)
+      integer :: mappdslen
+      logical needext
+
+      ierr=0
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+      allocate(mappds(lensec))
+
+      call g2lib_gbyte(cgrib,numcoord,iofst,16)    ! Get num of coordinate values
+      iofst=iofst+16
+      call g2lib_gbyte(cgrib,ipdsnum,iofst,16)    ! Get Prod. Def Template num.
+      iofst=iofst+16
+      !   Get Product Definition Template
+      call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret)
+      if (iret.ne.0) then
+        ierr=5
+        return
+      endif
+      !
+      !   Unpack each value into array ipdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mappds.
+      !
+      do i=1,mappdslen
+        nbits=iabs(mappds(i))*8
+        if ( mappds(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,ipdstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Check to see if the Product Definition Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extpdstemplate(ipdsnum,ipdstmpl,newmappdslen,mappds)
+        !   Unpack the rest of the Product Definition Template
+        do i=mappdslen+1,newmappdslen
+          nbits=iabs(mappds(i))*8
+          if ( mappds(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,ipdstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i)
+          endif
+          iofst=iofst+nbits
+        enddo
+        mappdslen=newmappdslen
+      endif
+      !
+      !   Get Optional list of vertical coordinate values
+      !   after the Product Definition Template, if necessary.
+      !
+      if ( numcoord .ne. 0 ) then
+        allocate (coordieee(numcoord))
+        call g2lib_gbytes(cgrib,coordieee,iofst,32,0,numcoord)
+        call rdieee(coordieee,coordlist,numcoord)
+        deallocate (coordieee)
+        iofst=iofst+(32*numcoord)
+      endif
+      if( allocated(mappds) ) deallocate(mappds)
+      return    ! End of Section 4 processing
+      end
+
+
+      subroutine unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
+     &                   mapdrslen,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    unpack5 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 5 (Data Representation Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
+!                        mapdrslen,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 5.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 5, returned.
+!     ndpts    - Number of data points unpacked and returned.
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0)
+!     idrstmpl - Contains the data values for the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Data
+!                Representation Template 5.N
+!     mapdrslen- Number of elements in idrstmpl().  i.e. number of entries
+!                in Data Representation Template 5.N  ( N=idrsnum ).
+!     ierr     - Error return code.
+!                0 = no error
+!                7 = "GRIB" message contains an undefined Data
+!                    Representation Template.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use drstemplates
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: ndpts,idrsnum,idrstmpl(*)
+      integer,intent(out) :: ierr
+
+C      integer,allocatable :: mapdrs(:)
+      integer,allocatable :: mapdrs(:)
+      integer :: mapdrslen
+      logical needext
+
+      ierr=0
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+      allocate(mapdrs(lensec))
+
+      call g2lib_gbyte(cgrib,ndpts,iofst,32)    ! Get num of data points
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,idrsnum,iofst,16)     ! Get Data Rep Template Num.
+      iofst=iofst+16
+      !   Gen Data Representation Template
+      call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret)
+      if (iret.ne.0) then
+        ierr=7
+        return
+      endif
+      !
+      !   Unpack each value into array ipdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mappds.
+      !
+      do i=1,mapdrslen
+        nbits=iabs(mapdrs(i))*8
+        if ( mapdrs(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Check to see if the Data Representation Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs)
+        !   Unpack the rest of the Data Representation Template
+        do i=mapdrslen+1,newmapdrslen
+          nbits=iabs(mapdrs(i))*8
+          if ( mapdrs(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
+          endif
+          iofst=iofst+nbits
+        enddo
+        mapdrslen=newmapdrslen
+      endif
+      if( allocated(mapdrs) ) deallocate(mapdrs)
+      return    ! End of Section 5 processing
+      end
+
+
+      subroutine unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    unpack6 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 6 (Bit-Map Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 6.
+!     ngpts    - Number of grid points specified in the bit-map
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 6, returned.
+!     ibmap    - Bitmap indicator ( see Code Table 6.0 )
+!                0 = bitmap applies and is included in Section 6.
+!                1-253 = Predefined bitmap applies
+!                254 = Previously defined bitmap applies to this field
+!                255 = Bit map does not apply to this product.
+!     bmap()   - Logical*1 array containing decoded bitmap. ( if ibmap=0 )
+!     ierr     - Error return code.
+!                0 = no error
+!                4 = Unrecognized pre-defined bit-map.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ngpts
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: ibmap
+      integer,intent(out) :: ierr
+      logical*1,intent(out) :: bmap(ngpts)
+
+      integer :: intbmap(ngpts)
+
+      ierr=0
+
+      iofst=iofst+32    ! skip Length of Section
+      iofst=iofst+8     ! skip section number
+
+      call g2lib_gbyte(cgrib,ibmap,iofst,8)    ! Get bit-map indicator
+      iofst=iofst+8
+
+      if (ibmap.eq.0) then               ! Unpack bitmap
+        call g2lib_gbytes(cgrib,intbmap,iofst,1,0,ngpts)
+        iofst=iofst+ngpts
+        do j=1,ngpts
+          bmap(j)=.true.
+          if (intbmap(j).eq.0) bmap(j)=.false.
+        enddo
+      elseif (ibmap.eq.254) then               ! Use previous bitmap
+        return
+      elseif (ibmap.eq.255) then               ! No bitmap in message
+        bmap(1:ngpts)=.true.
+      else
+        print *,'unpack6: Predefined bitmap ',ibmap,' not recognized.'
+        ierr=4
+      endif
+      
+      return    ! End of Section 6 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getg2i.F b/wrfv2_fire/external/io_grib2/g2lib/getg2i.F
new file mode 100644
index 00000000..ffaa9b31
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getg2i.F
@@ -0,0 +1,93 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETG2I          READS A GRIB2 INDEX FILE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 95-10-31
+C
+C ABSTRACT: READ A GRIB2 INDEX FILE AND RETURN ITS CONTENTS.
+C   VERSION 1 OF THE INDEX FILE HAS THE FOLLOWING FORMAT:
+C     81-BYTE S.LORD HEADER WITH 'GB2IX1' IN COLUMNS 42-47 FOLLOWED BY
+C     81-BYTE HEADER WITH NUMBER OF BYTES TO SKIP BEFORE INDEX RECORDS,
+C     TOTAL LENGTH IN BYTES OF THE INDEX RECORDS, NUMBER OF INDEX RECORDS,
+C     AND GRIB FILE BASENAME WRITTEN IN FORMAT ('IX1FORM:',3I10,2X,A40).
+C     EACH FOLLOWING INDEX RECORD CORRESPONDS TO A GRIB MESSAGE
+C     AND HAS THE INTERNAL FORMAT:
+C       BYTE 001 - 004: LENGTH OF INDEX RECORD
+C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
+C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
+C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
+C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
+C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
+C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
+C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
+C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
+C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
+C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
+C       BYTE 042 - 042: MESSAGE DISCIPLINE
+C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
+C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
+C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
+C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
+C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
+C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
+C
+C PROGRAM HISTORY LOG:
+C   95-10-31  IREDELL
+C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
+C 2002-01-03  GILBERT   MODIFIED FROM GETGI TO WORK WITH GRIB2 
+C
+C USAGE:    CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
+C   INPUT ARGUMENTS:
+C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE
+C   OUTPUT ARGUMENTS:
+C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
+C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
+C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
+C     NLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
+C     NNUM         INTEGER NUMBER OF INDEX RECORDS
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    2      NOT ENOUGH MEMORY TO HOLD INDEX BUFFER
+C                    3      ERROR READING INDEX FILE BUFFER
+C                    4      ERROR READING INDEX FILE HEADER
+C
+C SUBPROGRAMS CALLED:
+C   BAREAD         BYTE-ADDRESSABLE READ
+C
+C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+      INTEGER,INTENT(IN) :: LUGI
+      INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
+      CHARACTER CHEAD*162
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      NLEN=0
+      NNUM=0
+      IRET=4
+      CALL BAREAD(LUGI,0,162,LHEAD,CHEAD)
+      IF(LHEAD.EQ.162.AND.CHEAD(42:47).EQ.'GB2IX1') THEN
+        READ(CHEAD(82:162),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM
+        IF(IOS.EQ.0) THEN
+          
+          ALLOCATE(CBUF(NLEN),STAT=ISTAT)    ! ALLOCATE SPACE FOR CBUF
+          IF (ISTAT.NE.0) THEN
+             IRET=2
+             RETURN
+          ENDIF
+          IRET=0
+          CALL BAREAD(LUGI,NSKP,NLEN,LBUF,CBUF)
+          IF(LBUF.NE.NLEN) IRET=3
+
+        ENDIF
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getg2ir.F b/wrfv2_fire/external/io_grib2/g2lib/getg2ir.F
new file mode 100644
index 00000000..d58ba036
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getg2ir.F
@@ -0,0 +1,138 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETG2IR        CREATES AN INDEX OF A GRIB2 FILE
+C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2002-01-02
+C
+C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS.
+C   THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT:
+C       BYTE 001 - 004: LENGTH OF INDEX RECORD
+C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
+C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
+C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
+C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
+C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
+C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
+C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
+C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
+C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
+C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
+C       BYTE 042 - 042: MESSAGE DISCIPLINE
+C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
+C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
+C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
+C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
+C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
+C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
+C
+C PROGRAM HISTORY LOG:
+C   95-10-31  IREDELL
+C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
+C 2002-01-02  GILBERT   MODIFIED FROM GETGIR TO CREATE GRIB2 INDEXES
+C
+C USAGE:    CALL GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB FILE
+C     MSK1         INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE
+C     MSK2         INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES
+C     MNUM         INTEGER NUMBER OF GRIB MESSAGES TO SKIP (USUALLY 0)
+C   OUTPUT ARGUMENTS:
+C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
+C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
+C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
+C     NLEN         INTEGER TOTAL LENGTH OF INDEX RECORD BUFFER IN BYTES
+C     NNUM         INTEGER NUMBER OF INDEX RECORDS
+C                  (=0 IF NO GRIB MESSAGES ARE FOUND)
+C     NMESS        LAST GRIB MESSAGE IN FILE SUCCESSFULLY PROCESSED
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    1      NOT ENOUGH MEMORY AVAILABLE TO HOLD FULL INDEX 
+C                           BUFFER
+C                    2      NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER
+C
+C SUBPROGRAMS CALLED:
+C   SKGB           SEEK NEXT GRIB MESSAGE
+C   IXGB2          MAKE INDEX RECORD
+C
+C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE RE_ALLOC          ! NEEDED FOR SUBROUTINE REALLOC
+      PARAMETER(INIT=50000,NEXT=10000)
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+      INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
+      INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUFTMP
+      INTERFACE      ! REQUIRED FOR CBUF POINTER
+         SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
+           INTEGER,INTENT(IN) :: LUGB,LSKIP,LGRIB
+           CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+           INTEGER,INTENT(OUT) :: NUMFLD,MLEN,IRET
+         END SUBROUTINE IXGB2
+      END INTERFACE
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  INITIALIZE
+      IRET=0
+      IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
+      MBUF=INIT
+      ALLOCATE(CBUF(MBUF),STAT=ISTAT)    ! ALLOCATE INITIAL SPACE FOR CBUF
+      IF (ISTAT.NE.0) THEN
+         IRET=2
+         RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  SEARCH FOR FIRST GRIB MESSAGE
+      ISEEK=0
+      CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB)
+      DO M=1,MNUM
+        IF(LGRIB.GT.0) THEN
+          ISEEK=LSKIP+LGRIB
+          CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
+        ENDIF
+      ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  GET INDEX RECORDS FOR EVERY GRIB MESSAGE FOUND
+      NLEN=0
+      NNUM=0
+      NMESS=MNUM
+      DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0)
+        CALL IXGB2(LUGB,LSKIP,LGRIB,CBUFTMP,NUMFLD,NBYTES,IRET1)
+        IF (IRET1.NE.0) PRINT *,' SAGT ',NUMFLD,NBYTES,IRET1
+        IF((NBYTES+NLEN).GT.MBUF) THEN             ! ALLOCATE MORE SPACE, IF
+                                                   ! NECESSARY
+           NEWSIZE=MAX(MBUF+NEXT,MBUF+NBYTES)
+           CALL REALLOC(CBUF,NLEN,NEWSIZE,ISTAT)
+           IF ( ISTAT .NE. 0 ) THEN
+              IRET=1
+              RETURN
+           ENDIF
+           MBUF=NEWSIZE
+        ENDIF
+        !
+        !  IF INDEX RECORDS WERE RETURNED IN CBUFTMP FROM IXGB2,
+        !  COPY CBUFTMP INTO CBUF, THEN DEALLOCATE CBUFTMP WHEN DONE
+        !
+        IF ( ASSOCIATED(CBUFTMP) ) THEN
+           CBUF(NLEN+1:NLEN+NBYTES)=CBUFTMP(1:NBYTES)
+           DEALLOCATE(CBUFTMP,STAT=ISTAT)
+           IF (ISTAT.NE.0) THEN
+             PRINT *,' deallocating cbuftmp ... ',istat
+             stop 99
+           ENDIF
+           NULLIFY(CBUFTMP)
+           NNUM=NNUM+NUMFLD
+           NLEN=NLEN+NBYTES
+           NMESS=NMESS+1
+        ENDIF
+        !      LOOK FOR NEXT GRIB MESSAGE
+        ISEEK=LSKIP+LGRIB
+        CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
+      ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2.F
new file mode 100644
index 00000000..fad4c2bf
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2.F
@@ -0,0 +1,333 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2(LUGB,LUGI,J,GUESS,JDISC,JIDS,JPDTN,JPDT,JGDTN,
+     &                  JGDT,UNPACK,K,GFLD,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2         FINDS AND UNPACKS A GRIB MESSAGE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
+C
+C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE.
+C   READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
+C   TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
+C   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED.
+C   THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP
+C   AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
+C   PRODUCT DEFINTION SECTION PARAMETERS.  (A REQUESTED PARAMETER
+C   OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
+C   IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE
+C   GRIB FILE AND UNPACKED.  ITS NUMBER IS RETURNED ALONG WITH
+C   THE ASSOCIATED UNPACKED PARAMETERS.  THE BITMAP (IF ANY),
+C   AND THE DATA VALUES ARE UNPACKED ONLY IF ARGUMENT "UNPACK" IS SET TO
+C   TRUE.  IF THE GRIB FIELD IS NOT FOUND, THEN THE
+C   RETURN CODE WILL BE NONZERO.
+C
+C   The decoded information for the selected GRIB field
+C   is returned in a derived type variable, gfld.
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+C
+C PROGRAM HISTORY LOG:
+C   94-04-01  IREDELL
+C   95-10-31  IREDELL     MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
+C                         AND ALLOWED FOR UNSPECIFIED INDEX FILE
+C 2002-01-11  GILBERT     MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2
+C
+C USAGE:    CALL GETGB2(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
+C    &                  UNPACK,K,GFLD,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING 
+C                  THIS ROUTINE.
+C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
+C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE 
+C                  CALLING THIS ROUTINE.
+C                  >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T
+C                       ALREADY EXIST.
+C                  =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX
+C                       DOESN"T ALREADY EXIST.
+C                  <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI).
+C                  =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB.
+C     J            INTEGER NUMBER OF FIELDS TO SKIP
+C                  (=0 TO SEARCH FROM BEGINNING)
+C     JDISC        GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
+C                  ( IF = -1, ACCEPT ANY DISCIPLINE)
+C                  ( SEE CODE TABLE 0.0 )
+C                  0 - Meteorological products
+C                  1 - Hydrological products
+C                  2 - Land surface products
+C                  3 - Space products
+C                  10 - Oceanographic products
+C     JIDS()       INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
+C                  (=-9999 FOR WILDCARD)
+C            JIDS(1)   = IDENTIFICATION OF ORIGINATING CENTRE
+C                         ( SEE COMMON CODE TABLE C-1 )
+C            JIDS(2)   = IDENTIFICATION OF ORIGINATING SUB-CENTRE
+C            JIDS(3)   = GRIB MASTER TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.0 )
+C                       0 - Experimental
+C                       1 - Initial operational version number
+C            JIDS(4)   = GRIB LOCAL TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.1 )
+C                       0     - Local tables not used
+C                       1-254 - Number of local tables version used
+C            JIDS(5)   = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
+C                       0 - Analysis
+C                       1 - Start of forecast
+C                       2 - Verifying time of forecast
+C                       3 - Observation time
+C            JIDS(6)   = YEAR ( 4 DIGITS )
+C            JIDS(7)   = MONTH
+C            JIDS(8)   = DAY
+C            JIDS(9)   = HOUR
+C            JIDS(10)  = MINUTE
+C            JIDS(11)  = SECOND
+C            JIDS(12)  = PRODUCTION STATUS OF PROCESSED DATA
+C                         ( SEE CODE TABLE 1.3 )
+C                       0 - Operational products
+C                       1 - Operational test products
+C                       2 - Research products
+C                       3 - Re-analysis products
+C            JIDS(13)  = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
+C                       0  - Analysis products
+C                       1  - Forecast products
+C                       2  - Analysis and forecast products
+C                       3  - Control forecast products
+C                       4  - Perturbed forecast products
+C                       5  - Control and perturbed forecast products
+C                       6  - Processed satellite observations
+C                       7  - Processed radar observations
+C     JPDTN        INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
+C                  ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY )
+C     JPDT()       INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
+C                  TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     JGDTN        INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
+C                  ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY )
+C     JGDT()       INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
+C                  TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     UNPACK       LOGICAL VALUE INDICATING WHETHER TO UNPACK BITMAP/DATA
+C                  .TRUE. = UNPACK BITMAP AND DATA VALUES
+C                  .FALSE. = DO NOT UNPACK BITMAP AND DATA VALUES
+C
+C   OUTPUT ARGUMENTS:
+C     K            INTEGER FIELD NUMBER UNPACKED
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C        gfld%expanded = Logical value indicating whether the data field
+C                         was expanded to the grid in the case where a
+C                         bit-map is present.  If true, the data points in
+C                         gfld%fld match the grid points and zeros were
+C                         inserted at grid points where data was bit-mapped
+C                         out.  If false, the data values in gfld%fld were
+C                         not expanded to the grid and are just a consecutive
+C                         array of data points corresponding to each value of
+C                         "1" in gfld%bmap.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    96     ERROR READING INDEX
+C                    97     ERROR READING GRIB FILE
+C                    99     REQUEST NOT FOUND
+C                    OTHER  GF_GETFLD GRIB2 UNPACKER RETURN CODE
+C
+C SUBPROGRAMS CALLED:
+C   GETIDX         GET INDEX
+C   GETGB2S        SEARCH INDEX RECORDS
+C   GETGB2R        READ AND UNPACK GRIB RECORD
+C   GF_FREE        FREES MEMORY USED BY GFLD  ( SEE REMARKS )
+C
+C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+      INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN
+      INTEGER,INTENT(IN) :: GUESS
+      INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*)
+      LOGICAL,INTENT(IN) :: UNPACK
+      INTEGER,INTENT(OUT) :: K,IRET
+      TYPE(GRIBFIELD),INTENT(OUT) :: GFLD
+
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
+      INTERFACE
+         SUBROUTINE GETIDX(LUGB,LUGI,CBUF,NLEN,NNUM,IRGI)
+           CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+           INTEGER,INTENT(IN) :: LUGB,LUGI
+           INTEGER,INTENT(OUT) :: NLEN,NNUM,IRGI
+         END SUBROUTINE GETIDX
+      END INTERFACE
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+      IRGI=0
+      CALL GETIDX(LUGB,LUGI,CBUF,NLEN,NNUM,IRGI)
+      IF(IRGI.GT.1) THEN
+        IRET=96
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  SEARCH INDEX BUFFER
+      CALL GETGB2S(CBUF,NLEN,NNUM,J,GUESS,JDISC,JIDS,JPDTN,JPDT,JGDTN,
+     &             JGDT,JK,GFLD,LPOS,IRGS)
+      IF(IRGS.NE.0) THEN
+        IRET=99
+        CALL GF_FREE(GFLD)
+        RETURN
+      ENDIF
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ LOCAL USE SECTION, IF AVAILABLE
+      CALL GETGB2L(LUGB,CBUF(LPOS),GFLD,IRET)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ AND UNPACK GRIB RECORD
+      IF (UNPACK) THEN
+    !    NUMFLD=GFLD%IFLDNUM
+    !    CALL GF_FREE(GFLD)
+         CALL GETGB2R(LUGB,CBUF(LPOS),GFLD,IRET)
+      ENDIF
+      K=JK
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2l.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2l.F
new file mode 100644
index 00000000..a57d929b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2l.F
@@ -0,0 +1,234 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2L(LUGB,CINDEX,GFLD,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2L        EXTRACTS LOCAL USE SECTION
+C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 02-05-07
+C
+C ABSTRACT: READ AND UNPACK A LOCAL USE SECTION FROM A GRIB2 MESSAGE.
+C
+C   The decoded information for the selected GRIB field
+C   is returned in a derived type variable, gfld.
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+C
+C PROGRAM HISTORY LOG:
+C 2002-05-07  GILBERT  
+C
+C USAGE:    CALL GETGB2L(LUGB,CINDEX,GFLD,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
+C     CINDEX       INDEX RECORD OF THE GRIB FIELD  ( SEE DOCBLOCK OF
+C                  SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.)
+C   OUTPUT ARGUMENTS:
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    97     ERROR READING GRIB FILE
+C                    OTHER  GF_GETFLD GRIB UNPACKER RETURN CODE
+C
+C SUBPROGRAMS CALLED:
+C   BAREAD         BYTE-ADDRESSABLE READ
+C   GF_GETFLD       UNPACK GRIB FIELD
+C
+C REMARKS: 
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C   THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+      INTEGER,INTENT(IN) :: LUGB
+      CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
+      INTEGER,INTENT(OUT) :: IRET
+      TYPE(GRIBFIELD) :: GFLD
+
+      INTEGER :: LSKIP,SKIP2
+      CHARACTER(LEN=1):: CSIZE(4)
+      CHARACTER(LEN=1),ALLOCATABLE :: CTEMP(:)
+
+      interface
+         subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr)
+           character(len=1),intent(in) :: cgrib(lcgrib)
+           integer,intent(in) :: lcgrib
+           integer,intent(inout) :: iofst
+           integer,intent(out) :: lencsec2
+           integer,intent(out) :: ierr
+           character(len=1),pointer,dimension(:) :: csec2
+         end subroutine gf_unpack2
+      end interface
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  GET INFO
+      NULLIFY(gfld%local)
+      IRET=0
+      CALL G2LIB_GBYTE(CINDEX,LSKIP,4*8,4*8)
+      CALL G2LIB_GBYTE(CINDEX,SKIP2,8*8,4*8)
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ AND UNPACK LOCAL USE SECTION, IF PRESENT
+      IF ( SKIP2.NE.0 ) THEN
+         ISKIP=LSKIP+SKIP2
+         CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE)    ! GET LENGTH OF SECTION
+         CALL G2LIB_GBYTE(CSIZE,ILEN,0,32)
+         ALLOCATE(CTEMP(ILEN))
+         CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP)  ! READ IN SECTION
+         IF (ILEN.NE.LREAD) THEN
+            IRET=97
+            DEALLOCATE(CTEMP)
+            RETURN
+         ENDIF
+         IOFST=0
+         CALL GF_UNPACK2(CTEMP,ILEN,IOFST,gfld%locallen,
+     &                   gfld%local,ierr)
+         IF (IERR.NE.0) THEN
+            IRET=98
+            DEALLOCATE(CTEMP)
+            RETURN
+         ENDIF
+         DEALLOCATE(CTEMP)
+      ELSE
+         gfld%locallen=0
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2p.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2p.F
new file mode 100644
index 00000000..73bc2b14
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2p.F
@@ -0,0 +1,223 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
+     &                   EXTRACT,K,GRIBM,LENG,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2P        FINDS AND EXTRACTS A GRIB MESSAGE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
+C
+C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE.
+C   READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
+C   TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
+C   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED.
+C   THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP
+C   AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
+C   PRODUCT DEFINTION SECTION PARAMETERS.  (A REQUESTED PARAMETER
+C   OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
+C   IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE
+C   GRIB FILE AND RETURNED. 
+C   IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO.
+C
+C PROGRAM HISTORY LOG:
+C   94-04-01  IREDELL
+C   95-10-31  IREDELL     MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
+C                         AND ALLOWED FOR UNSPECIFIED INDEX FILE
+C 2002-01-11  GILBERT     MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2
+C 2003-12-17  GILBERT     MODIFIED FROM GETGB2 TO RETURN PACKED GRIB2 MESSAGE.
+C
+C USAGE:    CALL GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
+C    &                  EXTRACT,K,GRIBM,LENG,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING 
+C                  THIS ROUTINE.
+C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
+C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE 
+C                  CALLING THIS ROUTINE.
+C                  (=0 TO GET INDEX BUFFER FROM THE GRIB FILE)
+C     J            INTEGER NUMBER OF FIELDS TO SKIP
+C                  (=0 TO SEARCH FROM BEGINNING)
+C     JDISC        GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
+C                  ( IF = -1, ACCEPT ANY DISCIPLINE)
+C                  ( SEE CODE TABLE 0.0 )
+C                  0 - Meteorological products
+C                  1 - Hydrological products
+C                  2 - Land surface products
+C                  3 - Space products
+C                  10 - Oceanographic products
+C     JIDS()       INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
+C                  (=-9999 FOR WILDCARD)
+C            JIDS(1)   = IDENTIFICATION OF ORIGINATING CENTRE
+C                         ( SEE COMMON CODE TABLE C-1 )
+C            JIDS(2)   = IDENTIFICATION OF ORIGINATING SUB-CENTRE
+C            JIDS(3)   = GRIB MASTER TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.0 )
+C                       0 - Experimental
+C                       1 - Initial operational version number
+C            JIDS(4)   = GRIB LOCAL TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.1 )
+C                       0     - Local tables not used
+C                       1-254 - Number of local tables version used
+C            JIDS(5)   = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
+C                       0 - Analysis
+C                       1 - Start of forecast
+C                       2 - Verifying time of forecast
+C                       3 - Observation time
+C            JIDS(6)   = YEAR ( 4 DIGITS )
+C            JIDS(7)   = MONTH
+C            JIDS(8)   = DAY
+C            JIDS(9)   = HOUR
+C            JIDS(10)  = MINUTE
+C            JIDS(11)  = SECOND
+C            JIDS(12)  = PRODUCTION STATUS OF PROCESSED DATA
+C                         ( SEE CODE TABLE 1.3 )
+C                       0 - Operational products
+C                       1 - Operational test products
+C                       2 - Research products
+C                       3 - Re-analysis products
+C            JIDS(13)  = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
+C                       0  - Analysis products
+C                       1  - Forecast products
+C                       2  - Analysis and forecast products
+C                       3  - Control forecast products
+C                       4  - Perturbed forecast products
+C                       5  - Control and perturbed forecast products
+C                       6  - Processed satellite observations
+C                       7  - Processed radar observations
+C     JPDTN        INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
+C                  ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY )
+C     JPDT()       INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
+C                  TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     JGDTN        INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
+C                  ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY )
+C     JGDT()       INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
+C                  TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     EXTRACT       LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2 
+C                   MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE
+C                   GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD.
+C                  .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED
+C                           FIELD.
+C                  .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE
+C                            REQUESTED FIELD.
+C
+C   OUTPUT ARGUMENTS:
+C     K            INTEGER FIELD NUMBER RETURNED.
+C     GRIBM         RETURNED GRIB MESSAGE.
+C     LENG         LENGTH OF RETURNED GRIB MESSAGE IN BYTES.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    96     ERROR READING INDEX FILE
+C                    97     ERROR READING GRIB FILE
+C                    99     REQUEST NOT FOUND
+C
+C SUBPROGRAMS CALLED:
+C   GETG2I          READ INDEX FILE
+C   GETG2IR         READ INDEX BUFFER FROM GRIB FILE
+C   GETGB2S        SEARCH INDEX RECORDS
+C   GETGB2RP        READ A PACKED GRIB RECORD
+C   GF_FREE        FREES MEMORY USED BY GFLD  ( SEE REMARKS )
+C
+C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+      INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN
+      INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*)
+      LOGICAL,INTENT(IN) :: EXTRACT
+      INTEGER,INTENT(OUT) :: K,IRET,LENG
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
+
+      TYPE(GRIBFIELD) :: GFLD
+
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+      PARAMETER(MSK1=32000,MSK2=4000)
+
+      SAVE CBUF,NLEN,NNUM
+      DATA LUX/0/
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
+      INTERFACE
+         SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
+            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+            INTEGER,INTENT(IN) :: LUGI
+            INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
+         END SUBROUTINE GETG2I
+         SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
+     &                      NMESS,IRET)
+            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+            INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
+            INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
+         END SUBROUTINE GETG2IR
+         SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
+            INTEGER,INTENT(IN) :: LUGB
+            CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
+            LOGICAL,INTENT(IN) :: EXTRACT
+            INTEGER,INTENT(OUT) :: LENG,IRET
+            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
+         END SUBROUTINE GETGB2RP
+      END INTERFACE
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+      IRGI=0
+      IF(LUGI.GT.0.AND.LUGI.NE.LUX) THEN
+        CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRGI)
+        LUX=LUGI
+      ELSEIF(LUGI.LE.0.AND.LUGB.NE.LUX) THEN
+        MSKP=0
+        CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,CBUF,NLEN,NNUM,NMESS,IRGI)
+        LUX=LUGB
+      ENDIF
+      IF(IRGI.GT.1) THEN
+        IRET=96
+        LUX=0
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  SEARCH INDEX BUFFER
+      CALL GETGB2S(CBUF,NLEN,NNUM,J,-1,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
+     &             JK,GFLD,LPOS,IRGS)
+      IF(IRGS.NE.0) THEN
+        IRET=99
+        CALL GF_FREE(GFLD)
+        RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  EXTRACT GRIB MESSAGE FROM FILE
+      CALL GETGB2RP(LUGB,CBUF(LPOS:),EXTRACT,GRIBM,LENG,IRET)
+!      IF ( EXTRACT ) THEN
+!         PRINT *,'NOT SUPPOSED TO BE HERE.'
+!      ELSE
+!         IPOS=(LPOS+3)*8
+!         CALL G2LIB_GBYTE(CBUF,ISKIP,IPOS,32)     ! BYTES TO SKIP IN FILE
+!         IPOS=IPOS+(32*8)
+!         CALL G2LIB_GBYTE(CBUF,LENG,IPOS,32)      ! LENGTH OF GRIB MESSAGE
+!         IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
+!         CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM)
+!         IF ( LENG .NE. LREAD ) THEN
+!            IRET=97
+!            CALL GF_FREE(GFLD)
+!            RETURN
+!         ENDIF
+!      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      K=JK
+      CALL GF_FREE(GFLD)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2r.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2r.F
new file mode 100644
index 00000000..5abf13fb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2r.F
@@ -0,0 +1,304 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2R(LUGB,CINDEX,GFLD,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2R        READS AND UNPACKS A GRIB FIELD
+C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 02-01-15
+C
+C ABSTRACT: READ AND UNPACK SECTIONS 6 AND 7 FROM A GRIB2 MESSAGE.
+C
+C   This routine assumes that the "metadata" for this field
+C   already exists in derived type gribfield.  Specifically,
+C   it requires gfld%ibmap,gfld%ngrdpts,gfld%idrtnum,gfld%idrtmpl,
+C   and gfld%ndpts.
+C   
+C   The decoded information for the selected GRIB field
+C   is returned in a derived type variable, gfld.
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+C
+C PROGRAM HISTORY LOG:
+C   95-10-31  IREDELL
+C 2002-01-11  GILBERT     MODIFIED FROM GETGB1R TO WORK WITH GRIB2
+C
+C USAGE:    CALL GETGB2R(LUGB,CINDEX,GFLD,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
+C     CINDEX       INDEX RECORD OF THE GRIB FIELD  ( SEE DOCBLOCK OF
+C                  SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.)
+C   OUTPUT ARGUMENTS:
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C        gfld%expanded = Logical value indicating whether the data field
+C                         was expanded to the grid in the case where a
+C                         bit-map is present.  If true, the data points in
+C                         gfld%fld match the grid points and zeros were
+C                         inserted at grid points where data was bit-mapped
+C                         out.  If false, the data values in gfld%fld were
+C                         not expanded to the grid and are just a consecutive
+C                         array of data points corresponding to each value of
+C                         "1" in gfld%bmap.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    97     ERROR READING GRIB FILE
+C                    OTHER  GF_GETFLD GRIB UNPACKER RETURN CODE
+C
+C SUBPROGRAMS CALLED:
+C   BAREAD         BYTE-ADDRESSABLE READ
+C   GF_UNPACK6     UNAPCKS BIT_MAP SECTION
+C   GF_UNPACK7     UNAPCKS DATA SECTION 
+C
+C REMARKS: 
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C   THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this, users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+      INTEGER,INTENT(IN) :: LUGB
+      CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
+      INTEGER,INTENT(OUT) :: IRET
+      TYPE(GRIBFIELD) :: GFLD
+
+      INTEGER :: LSKIP,SKIP6,SKIP7
+      CHARACTER(LEN=1):: CSIZE(4)
+      CHARACTER(LEN=1),ALLOCATABLE :: CTEMP(:)
+      real,pointer,dimension(:) :: newfld
+
+      interface
+         subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,
+     &                         bmap,ierr)
+           character(len=1),intent(in) :: cgrib(lcgrib)
+           integer,intent(in) :: lcgrib,ngpts
+           integer,intent(inout) :: iofst
+           integer,intent(out) :: ibmap
+           integer,intent(out) :: ierr
+           logical*1,pointer,dimension(:) :: bmap
+         end subroutine gf_unpack6
+         subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl,
+     &                         idrsnum,idrstmpl,ndpts,fld,ierr)
+           character(len=1),intent(in) :: cgrib(lcgrib)
+           integer,intent(in) :: lcgrib,ndpts,idrsnum,igdsnum
+           integer,intent(inout) :: iofst
+           integer,pointer,dimension(:) :: idrstmpl,igdstmpl
+           integer,intent(out) :: ierr
+           real,pointer,dimension(:) :: fld
+         end subroutine gf_unpack7
+      end interface
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  GET INFO
+      NULLIFY(gfld%bmap,gfld%fld)
+      IRET=0
+      CALL G2LIB_GBYTE(CINDEX,LSKIP,4*8,4*8)
+      CALL G2LIB_GBYTE(CINDEX,SKIP6,24*8,4*8)
+      CALL G2LIB_GBYTE(CINDEX,SKIP7,28*8,4*8)
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ AND UNPACK BIT_MAP, IF PRESENT
+      IF ( gfld%ibmap.eq.0.OR.gfld%ibmap.eq.254 ) THEN
+         ISKIP=LSKIP+SKIP6
+         CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE)    ! GET LENGTH OF SECTION
+         CALL G2LIB_GBYTE(CSIZE,ILEN,0,32)
+         ALLOCATE(CTEMP(ILEN))
+         CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP)  ! READ IN SECTION
+         IF (ILEN.NE.LREAD) THEN
+            IRET=97
+            DEALLOCATE(CTEMP)
+            RETURN
+         ENDIF
+         IOFST=0
+         CALL GF_UNPACK6(CTEMP,ILEN,IOFST,gfld%ngrdpts,idum,
+     &                   gfld%bmap,ierr)
+         IF (IERR.NE.0) THEN
+            IRET=98
+            DEALLOCATE(CTEMP)
+            RETURN
+         ENDIF
+         DEALLOCATE(CTEMP)
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ AND UNPACK DATA FIELD 
+      ISKIP=LSKIP+SKIP7
+      CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE)    ! GET LENGTH OF SECTION
+      CALL G2LIB_GBYTE(CSIZE,ILEN,0,32)
+      ALLOCATE(CTEMP(ILEN))
+      CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP)  ! READ IN SECTION
+      IF (ILEN.NE.LREAD) THEN
+         IRET=97
+         DEALLOCATE(CTEMP)
+         RETURN
+      ENDIF
+      IOFST=0
+      CALL GF_UNPACK7(CTEMP,ILEN,IOFST,gfld%igdtnum,gfld%igdtmpl,
+     &                   gfld%idrtnum,gfld%idrtmpl,gfld%ndpts,
+     &                   gfld%fld,ierr)
+      IF (IERR.NE.0) THEN
+         IRET=98
+         DEALLOCATE(CTEMP)
+         RETURN
+      ENDIF
+      DEALLOCATE(CTEMP)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      !  If bitmap is used with this field, expand data field
+      !  to grid, if possible.
+      if ( gfld%ibmap .ne. 255 .AND. associated(gfld%bmap) ) then
+            allocate(newfld(gfld%ngrdpts))
+            !newfld=0.0
+            !newfld=unpack(lgfld%fld,lgfld%bmap,newfld)
+            n=1
+            do j=1,gfld%ngrdpts
+                if ( gfld%bmap(j) ) then
+                  newfld(j)=gfld%fld(n)
+                  n=n+1
+                else
+                  newfld(j)=0.0
+                endif
+            enddo
+            deallocate(gfld%fld);
+            gfld%fld=>newfld;
+            gfld%expanded=.true.
+      else
+         gfld%expanded=.true.
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2rp.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2rp.F
new file mode 100644
index 00000000..2e6066c6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2rp.F
@@ -0,0 +1,189 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2RP       EXTRACTS A GRIB MESSAGE FROM A FILE
+C   PRGMMR: GILBERT          ORG: W/NMC23     DATE: 2003-12-31
+C
+C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE GIVEN THE 
+C   INDEX FOR THE REQUESTED FIELD.
+C   THE GRIB MESSAGE RETURNED CAN CONTAIN ONLY THE REQUESTED FIELD
+C   (EXTRACT=.TRUE.). OR THE COMPLETE GRIB MESSAGE ORIGINALLY CONTAINING
+C   THE DESIRED FIELD CAN BE RETURNED (EXTRACT=.FALSE.) EVEN IF OTHER
+C   FIELDS WERE INCLUDED IN THE GRIB MESSAGE.
+C   IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO.
+C
+C PROGRAM HISTORY LOG:
+C 2003-12-31  GILBERT
+C
+C USAGE:    CALL GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING 
+C                  THIS ROUTINE.
+C     CINDEX       INDEX RECORD OF THE GRIB FILE  ( SEE DOCBLOCK OF
+C                  SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.)
+C     EXTRACT       LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2 
+C                   MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE
+C                   GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD.
+C                  .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED
+C                           FIELD.
+C                  .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE
+C                            REQUESTED FIELD.
+C
+C   OUTPUT ARGUMENTS:
+C     GRIBM         RETURNED GRIB MESSAGE.
+C     LENG         LENGTH OF RETURNED GRIB MESSAGE IN BYTES.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    97     ERROR READING GRIB FILE
+C
+C SUBPROGRAMS CALLED:
+C   BAREAD          BYTE-ADDRESSABLE READ
+C
+C REMARKS: NONE 
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+
+      INTEGER,INTENT(IN) :: LUGB
+      CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
+      LOGICAL,INTENT(IN) :: EXTRACT
+      INTEGER,INTENT(OUT) :: LENG,IRET
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
+ 
+      INTEGER,PARAMETER :: ZERO=0
+      CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CSEC2,CSEC6,CSEC7
+      CHARACTER(LEN=4) :: Ctemp
+
+      IRET=0
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  EXTRACT GRIB MESSAGE FROM FILE
+      IF ( EXTRACT ) THEN
+         LEN0=16
+         LEN8=4
+         CALL G2LIB_GBYTE(CINDEX,ISKIP,4*8,4*8)    ! BYTES TO SKIP IN FILE
+         CALL G2LIB_GBYTE(CINDEX,ISKP2,8*8,4*8)    ! BYTES TO SKIP FOR section 2
+         if ( iskp2 .gt. 0 ) then
+            CALL BAREAD(LUGB,ISKIP+ISKP2,4,LREAD,ctemp)
+            CALL G2LIB_GBYTE(Ctemp,LEN2,0,4*8)      ! LENGTH OF SECTION 2
+            ALLOCATE(csec2(len2))
+            CALL BAREAD(LUGB,ISKIP+ISKP2,LEN2,LREAD,csec2)
+         else
+            LEN2=0
+         endif
+         CALL G2LIB_GBYTE(CINDEX,LEN1,44*8,4*8)      ! LENGTH OF SECTION 1
+         IPOS=44+LEN1
+         CALL G2LIB_GBYTE(CINDEX,LEN3,IPOS*8,4*8)      ! LENGTH OF SECTION 3
+         IPOS=IPOS+LEN3
+         CALL G2LIB_GBYTE(CINDEX,LEN4,IPOS*8,4*8)      ! LENGTH OF SECTION 4
+         IPOS=IPOS+LEN4
+         CALL G2LIB_GBYTE(CINDEX,LEN5,IPOS*8,4*8)      ! LENGTH OF SECTION 5
+         IPOS=IPOS+LEN5
+         CALL G2LIB_GBYTE(CINDEX,LEN6,IPOS*8,4*8)      ! LENGTH OF SECTION 6
+         IPOS=IPOS+5
+         CALL G2LIB_GBYTE(CINDEX,IBMAP,IPOS*8,1*8)      ! Bitmap indicator
+         IF ( IBMAP .eq. 254 ) THEN
+            CALL G2LIB_GBYTE(CINDEX,ISKP6,24*8,4*8)    ! BYTES TO SKIP FOR section 6
+            CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp)
+            CALL G2LIB_GBYTE(Ctemp,LEN6,0,4*8)      ! LENGTH OF SECTION 6
+         ENDIF
+         !
+         !  READ IN SECTION 7 from file
+         !
+         CALL G2LIB_GBYTE(CINDEX,ISKP7,28*8,4*8)    ! BYTES TO SKIP FOR section 7
+         CALL BAREAD(LUGB,ISKIP+ISKP7,4,LREAD,ctemp)
+         CALL G2LIB_GBYTE(Ctemp,LEN7,0,4*8)      ! LENGTH OF SECTION 7
+         ALLOCATE(csec7(len7))
+         CALL BAREAD(LUGB,ISKIP+ISKP7,LEN7,LREAD,csec7)
+
+         LENG=LEN0+LEN1+LEN2+LEN3+LEN4+LEN5+LEN6+LEN7+LEN8
+         IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
+
+         ! Create Section 0
+         !
+         GRIBM(1)='G'
+         GRIBM(2)='R'
+         GRIBM(3)='I'
+         GRIBM(4)='B'
+         GRIBM(5)=CHAR(0)
+         GRIBM(6)=CHAR(0)
+         GRIBM(7)=CINDEX(42)
+         GRIBM(8)=CINDEX(41)
+         GRIBM(9)=CHAR(0)
+         GRIBM(10)=CHAR(0)
+         GRIBM(11)=CHAR(0)
+         GRIBM(12)=CHAR(0)
+         CALL G2LIB_SBYTE(GRIBM,LENG,12*8,4*8)
+         !
+         ! Copy Section 1
+         !
+         GRIBM(17:16+LEN1)=CINDEX(45:44+LEN1)
+         lencur=16+LEN1
+         ipos=44+len1
+         !
+         ! Copy Section 2, if necessary
+         !
+         if ( iskp2 .gt. 0 ) then
+           GRIBM(lencur+1:lencur+LEN2)=csec2(1:LEN2)
+           lencur=lencur+LEN2
+         endif
+         !
+         ! Copy Sections 3 through 5
+         !
+         GRIBM(lencur+1:lencur+LEN3+LEN4+LEN5)=
+     &                      CINDEX(ipos+1:ipos+LEN3+LEN4+LEN5)
+         lencur=lencur+LEN3+LEN4+LEN5
+         ipos=ipos+LEN3+LEN4+LEN5
+         !
+         ! Copy Section 6
+         !
+         if ( LEN6 .eq. 6 .AND. IBMAP .ne. 254 ) then
+            GRIBM(lencur+1:lencur+LEN6)=CINDEX(ipos+1:ipos+LEN6)
+            lencur=lencur+LEN6
+         else
+            CALL G2LIB_GBYTE(CINDEX,ISKP6,24*8,4*8)    ! BYTES TO SKIP FOR section 6
+            CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp)
+            CALL G2LIB_GBYTE(Ctemp,LEN6,0,4*8)      ! LENGTH OF SECTION 6
+            ALLOCATE(csec6(len6))
+            CALL BAREAD(LUGB,ISKIP+ISKP6,LEN6,LREAD,csec6)
+            GRIBM(lencur+1:lencur+LEN6)=csec6(1:LEN6)
+            lencur=lencur+LEN6
+            IF ( allocated(csec6)) DEALLOCATE(csec6)
+         endif
+         !
+         ! Copy Section 7
+         !
+         GRIBM(lencur+1:lencur+LEN7)=csec7(1:LEN7)
+         lencur=lencur+LEN7
+         !
+         ! Section 8
+         !
+         GRIBM(lencur+1)='7'
+         GRIBM(lencur+2)='7'
+         GRIBM(lencur+3)='7'
+         GRIBM(lencur+4)='7'
+
+         !  clean up
+         !
+         IF ( allocated(csec2)) DEALLOCATE(csec2)
+         IF ( allocated(csec7)) deallocate(csec7)
+
+      ELSE    ! DO NOT extract field from message :  Get entire message
+
+         CALL G2LIB_GBYTE(CINDEX,ISKIP,4*8,4*8)    ! BYTES TO SKIP IN FILE
+         CALL G2LIB_GBYTE(CINDEX,LENG,36*8,4*8)      ! LENGTH OF GRIB MESSAGE
+         IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
+         CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM)
+         IF ( LENG .NE. LREAD ) THEN
+            DEALLOCATE(GRIBM)
+            NULLIFY(GRIBM)
+            IRET=97
+            RETURN
+         ENDIF
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getgb2s.F b/wrfv2_fire/external/io_grib2/g2lib/getgb2s.F
new file mode 100644
index 00000000..4b7becdc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getgb2s.F
@@ -0,0 +1,537 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETGB2S(CBUF,NLEN,NNUM,J,GUESS,JDISC,JIDS,JPDTN,JPDT,
+     &                   JGDTN,JGDT,K,GFLD,LPOS,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2S        FINDS A GRIB MESSAGE
+C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 02-01-15
+C
+C ABSTRACT: FIND A GRIB MESSAGE.
+C   FIND IN THE INDEX FILE A REFERENCE TO THE GRIB FIELD REQUESTED.
+C   THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP
+C   AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND 
+C   PRODUCT DEFINTION SECTION PARAMETERS.  (A REQUESTED PARAMETER
+C   OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
+C
+C           EACH INDEX RECORD HAS THE FOLLOWING FORM:
+C       BYTE 001 - 004: LENGTH OF INDEX RECORD
+C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
+C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
+C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
+C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
+C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
+C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
+C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
+C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
+C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
+C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
+C       BYTE 042 - 042: MESSAGE DISCIPLINE
+C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
+C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
+C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
+C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
+C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
+C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
+C
+C   Most of the decoded information for the selected GRIB field
+C   is returned in a derived type variable, gfld.  
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+C   Only the unpacked bitmap and data field components are not set by this 
+C   routine.
+C
+C PROGRAM HISTORY LOG:
+C   95-10-31  IREDELL
+C 2002-01-02  GILBERT   MODIFIED FROM GETG1S TO WORK WITH GRIB2
+C
+C USAGE:    CALL GETGB2S(CBUF,NLEN,NNUM,J,GUESS,JDISC,JIDS,JPDTN,JPDT,JGDTN,
+C    &                   JGDT,K,GFLD,LPOS,IRET)
+C   INPUT ARGUMENTS:
+C     CBUF         CHARACTER*1 (NLEN) BUFFER CONTAINING INDEX DATA
+C     NLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
+C     NNUM         INTEGER NUMBER OF INDEX RECORDS
+C     J            INTEGER NUMBER OF MESSAGES TO SKIP
+C                  (=0 TO SEARCH FROM BEGINNING)
+C     GUESS        A GUESS FOR THE INDEX OF THE GRIB RECORD THAT CONTAINS
+C                   THE REQUESTED DATA.  IF GUESS IS CORRECT, SEARCHING
+C                   CAN BE SIGNFICANTLY FASTER, ESPECIALLY FOR FILES
+C                   WITH MANY RECORDS.  IF GUESS IS WRONG OR MISSING (<0), 
+C                   ALL RECORDS ARE SEARCHED
+C     JDISC        GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
+C                  ( IF = -1, ACCEPT ANY DISCIPLINE)
+C                  ( SEE CODE TABLE 0.0 )
+C                  0 - Meteorological products
+C                  1 - Hydrological products
+C                  2 - Land surface products
+C                  3 - Space products
+C                  10 - Oceanographic products
+C     JIDS()       INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
+C                  (=-9999 FOR WILDCARD)
+C            JIDS(1)   = IDENTIFICATION OF ORIGINATING CENTRE
+C                         ( SEE COMMON CODE TABLE C-1 )
+C            JIDS(2)   = IDENTIFICATION OF ORIGINATING SUB-CENTRE
+C            JIDS(3)   = GRIB MASTER TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.0 )
+C                       0 - Experimental
+C                       1 - Initial operational version number
+C            JIDS(4)   = GRIB LOCAL TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.1 )
+C                       0     - Local tables not used
+C                       1-254 - Number of local tables version used
+C            JIDS(5)   = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
+C                       0 - Analysis
+C                       1 - Start of forecast
+C                       2 - Verifying time of forecast
+C                       3 - Observation time
+C            JIDS(6)   = YEAR ( 4 DIGITS )
+C            JIDS(7)   = MONTH
+C            JIDS(8)   = DAY
+C            JIDS(9)   = HOUR
+C            JIDS(10)  = MINUTE
+C            JIDS(11)  = SECOND
+C            JIDS(12)  = PRODUCTION STATUS OF PROCESSED DATA
+C                         ( SEE CODE TABLE 1.3 )
+C                       0 - Operational products
+C                       1 - Operational test products
+C                       2 - Research products
+C                       3 - Re-analysis products
+C            JIDS(13)  = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
+C                       0  - Analysis products
+C                       1  - Forecast products
+C                       2  - Analysis and forecast products
+C                       3  - Control forecast products
+C                       4  - Perturbed forecast products
+C                       5  - Control and perturbed forecast products
+C                       6  - Processed satellite observations
+C                       7  - Processed radar observations
+C     JPDTN        INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
+C                  ( IF = -1, DON'T BOTHER MATCHING PDT )
+C     JPDT()       INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION 
+C                  TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     JGDTN        INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
+C                  ( IF = -1, DON'T BOTHER MATCHING GDT )
+C     JGDT()       INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
+C                  TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C   OUTPUT ARGUMENTS:
+C     K            INTEGER MESSAGE NUMBER FOUND
+C                  (CAN BE SAME AS J IN CALLING PROGRAM
+C                  IN ORDER TO FACILITATE MULTIPLE SEARCHES)
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C                        NOTE: This routine sets this component to .FALSE.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C                      NOTE: This component is not set by this routine.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C                      NOTE: This component is not set by this routine.
+C     LPOS         STARTING POSITION OF THE FOUND INDEX RECORD WITHIN
+C                  THE COMPLETE INDEX BUFFER, CBUF.
+C                  = 0, IF REQUEST NOT FOUND
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    1      REQUEST NOT FOUND
+C
+C REMARKS: 
+C   THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C SUBPROGRAMS CALLED:
+C   G2LIB_GBYTE            UNPACK BYTES
+C   GF_UNPACK1          UNPACK IDS
+C   GF_UNPACK4          UNPACK PDS
+C   GF_UNPACK3          UNPACK GDS
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+!      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+      CHARACTER(LEN=1),INTENT(IN) :: CBUF(NLEN)
+      INTEGER,INTENT(IN) :: NLEN,NNUM,J,JDISC,JPDTN,JGDTN
+      INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*)
+      INTEGER,INTENT(OUT) :: K,LPOS,IRET
+      TYPE(GRIBFIELD),INTENT(OUT) :: GFLD
+      INTEGER,INTENT(IN) :: GUESS
+      INTEGER :: KGDS(5)
+      LOGICAL :: MATCH1,MATCH3,MATCH4
+      INTEGER :: SKIP
+      INTEGER :: LOOPNUM
+      logical :: skip2
+!      INTEGER,POINTER,DIMENSION(:) :: KIDS,KPDT,KGDT
+!      INTEGER,POINTER,DIMENSION(:) :: IDEF
+!      REAL,POINTER,DIMENSION(:) :: COORD
+
+      interface
+         subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: ids
+            integer,intent(out) :: ierr,idslen
+         end subroutine gf_unpack1
+         subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                         mapgridlen,ideflist,idefnum,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: igdstmpl,ideflist
+            integer,intent(out) :: igds(5)
+            integer,intent(out) :: ierr,idefnum
+         end subroutine gf_unpack3
+         subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,
+     &                      mappdslen,coordlist,numcoord,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            real,pointer,dimension(:) :: coordlist
+            integer,pointer,dimension(:) :: ipdstmpl
+            integer,intent(out) :: ipdsnum
+            integer,intent(out) :: ierr,numcoord
+         end subroutine gf_unpack4
+         subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,
+     &                         idrstmpl,mapdrslen,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,intent(out) :: ndpts,idrsnum
+            integer,pointer,dimension(:) :: idrstmpl
+            integer,intent(out) :: ierr
+         end subroutine gf_unpack5
+      end interface
+      
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  INITIALIZE
+
+
+      K=0
+      SKIP = J
+      LPOS=0
+      IRET=1
+      IPOS=0
+      LOOPNUM = 1
+      skip2 = .false.
+      nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl)
+      nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  SEARCH FOR REQUEST
+      DOWHILE(IRET.NE.0)
+
+        if (guess .gt. 0) then
+           if (loopnum .eq. 1) then
+
+              ! Check if we are at end of data., If so, search from beginning
+              if (k .ge. NNUM) then
+                 loopnum = loopnum + 1
+                 cycle
+              endif
+
+             ! Set first search to be the guess index.
+              SKIP = guess - 1
+
+           else if (loopnum .eq. 2) then
+
+             ! Set 2nd search to start from beginning.
+              if (.not. skip2) then
+                 SKIP = J
+                 K = 0
+                 ipos = 0
+                 skip2 = .true.
+              endif
+
+           endif
+        endif
+
+        if (k .ge. NNUM) then
+           exit
+        endif
+        
+
+        K=K+1
+        CALL G2LIB_GBYTE(CBUF,INLEN,IPOS*8,4*8) ! GET LENGTH OF CURRENT
+                                ! INDEX RECORD
+
+        IF ( K.LE.SKIP ) THEN   ! SKIP THIS INDEX
+           IPOS=IPOS+INLEN
+           CYCLE
+        ELSE 
+           LOOPNUM = LOOPNUM + 1
+        ENDIF
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CHECK IF GRIB2 DISCIPLINE IS A MATCH
+        CALL G2LIB_GBYTE(CBUF,GFLD%DISCIPLINE,(IPOS+41)*8,1*8)
+        IF ( (JDISC.NE.-1).AND.(JDISC.NE.GFLD%DISCIPLINE) ) THEN
+           IPOS=IPOS+INLEN
+           CYCLE
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CHECK IF IDENTIFICATION SECTION IS A MATCH
+        MATCH1=.FALSE.
+        CALL G2LIB_GBYTE(CBUF,LSEC1,(IPOS+44)*8,4*8)  ! GET LENGTH OF IDS 
+        IOF=0
+        CALL GF_UNPACK1(CBUF(IPOS+45),LSEC1,IOF,GFLD%IDSECT,
+     &                  GFLD%IDSECTLEN,ICND)
+        IF ( ICND.EQ.0 ) THEN
+           MATCH1=.TRUE.
+           DO I=1,GFLD%IDSECTLEN
+              IF ( (JIDS(I).NE.-9999).AND.
+     &             (JIDS(I).NE.GFLD%IDSECT(I)) ) THEN
+                 MATCH1=.FALSE.
+                 EXIT
+              ENDIF
+           ENDDO
+        ENDIF
+        IF ( .NOT. MATCH1 ) THEN
+           DEALLOCATE(GFLD%IDSECT)
+           IPOS=IPOS+INLEN
+           CYCLE
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CHECK IF GRID DEFINITION TEMPLATE IS A MATCH
+        JPOS=IPOS+44+LSEC1
+        MATCH3=.FALSE.
+        CALL G2LIB_GBYTE(CBUF,LSEC3,JPOS*8,4*8)  ! GET LENGTH OF GDS 
+        IF ( JGDTN.EQ.-1 ) THEN
+           MATCH3=.TRUE.
+        ELSE
+           CALL G2LIB_GBYTE(CBUF,NUMGDT,(JPOS+12)*8,2*8)  ! GET GDT TEMPLATE NO.
+           IF ( JGDTN.EQ.NUMGDT ) THEN
+              IOF=0
+              CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL,
+     &                     GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND)
+              IF ( ICND.EQ.0 ) THEN
+                 MATCH3=.TRUE.
+                 DO I=1,GFLD%IGDTLEN
+                    IF ( (JGDT(I).NE.-9999).AND.
+     &                   (JGDT(I).NE.GFLD%IGDTMPL(I)) ) THEN
+                       MATCH3=.FALSE.
+                       EXIT
+                    ENDIF
+                 ENDDO
+C                 WHERE ( JGDT(1:GFLD%IGDTLEN).NE.-9999 ) 
+C     &              MATCH3=ALL(JGDT(1:GFLD%IGDTLEN).EQ.GFLD%IGDTMPL(1:GFLD%IGDTLEN))
+              ENDIF
+           ENDIF
+        ENDIF
+        IF ( .NOT. MATCH3 ) THEN
+           IF (ASSOCIATED(GFLD%IGDTMPL)) DEALLOCATE(GFLD%IGDTMPL)
+           IF (ASSOCIATED(GFLD%LIST_OPT)) DEALLOCATE(GFLD%LIST_OPT)
+           IPOS=IPOS+INLEN
+           CYCLE
+        ELSE
+           GFLD%GRIDDEF=KGDS(1)
+           GFLD%NGRDPTS=KGDS(2)
+           GFLD%NUMOCT_OPT=KGDS(3)
+           GFLD%INTERP_OPT=KGDS(4)
+           GFLD%IGDTNUM=KGDS(5)
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CHECK IF PRODUCT DEFINITION TEMPLATE IS A MATCH
+        JPOS=JPOS+LSEC3
+        MATCH4=.FALSE.
+        CALL G2LIB_GBYTE(CBUF,LSEC4,JPOS*8,4*8)  ! GET LENGTH OF PDS 
+        IF ( JPDTN.EQ.-1 ) THEN
+           MATCH4=.TRUE.
+        ELSE
+           CALL G2LIB_GBYTE(CBUF,NUMPDT,(JPOS+7)*8,2*8)  ! GET PDT TEMPLATE NO.
+           IF ( JPDTN.EQ.NUMPDT ) THEN
+              IOF=0
+              CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM,
+     &                        GFLD%IPDTMPL,GFLD%IPDTLEN,
+     &                        GFLD%COORD_LIST,GFLD%NUM_COORD,ICND)
+              IF ( ICND.EQ.0 ) THEN
+                 MATCH4=.TRUE.
+                 DO I=1,GFLD%IPDTLEN
+                    IF ( (JPDT(I).NE.-9999).AND.
+     &                   (JPDT(I).NE.GFLD%IPDTMPL(I)) ) THEN
+                       MATCH4=.FALSE.
+                       EXIT
+                    ENDIF
+                 ENDDO
+c                 WHERE ( JPDT.NE.-9999) 
+c     &              MATCH4=ALL( JPDT(1:GFLD%IPDTLEN) .EQ. GFLD%IPDTMPL(1:GFLD%IPDTLEN) )
+              ENDIF
+           ENDIF
+        ENDIF
+        IF ( .NOT. MATCH4 ) THEN
+           IF (ASSOCIATED(GFLD%IPDTMPL)) DEALLOCATE(GFLD%IPDTMPL)
+           IF (ASSOCIATED(GFLD%COORD_LIST)) DEALLOCATE(GFLD%COORD_LIST)
+        ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  IF REQUEST IS FOUND
+C  SET VALUES FOR DERIVED TYPE GFLD AND RETURN
+        IF(MATCH1.AND.MATCH3.AND.MATCH4) THEN
+           LPOS=IPOS+1
+           CALL G2LIB_GBYTE(CBUF,GFLD%VERSION,(IPOS+40)*8,1*8)
+           CALL G2LIB_GBYTE(CBUF,GFLD%IFLDNUM,(IPOS+42)*8,2*8)
+           GFLD%UNPACKED=.FALSE.
+           JPOS=IPOS+44+LSEC1
+           IF ( JGDTN.EQ.-1 ) THEN     ! UNPACK GDS, IF NOT DONE BEFORE
+              IOF=0
+              CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL,
+     &                     GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND)
+              GFLD%GRIDDEF=KGDS(1)
+              GFLD%NGRDPTS=KGDS(2)
+              GFLD%NUMOCT_OPT=KGDS(3)
+              GFLD%INTERP_OPT=KGDS(4)
+              GFLD%IGDTNUM=KGDS(5)
+           ENDIF
+           JPOS=JPOS+LSEC3
+           IF ( JPDTN.EQ.-1 ) THEN     ! UNPACK PDS, IF NOT DONE BEFORE
+              IOF=0
+              CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM,
+     &                        GFLD%IPDTMPL,GFLD%IPDTLEN,
+     &                        GFLD%COORD_LIST,GFLD%NUM_COORD,ICND)
+           ENDIF
+           JPOS=JPOS+LSEC4
+           CALL G2LIB_GBYTE(CBUF,LSEC5,JPOS*8,4*8)  ! GET LENGTH OF DRS 
+           IOF=0
+           CALL GF_UNPACK5(CBUF(JPOS+1),LSEC5,IOF,GFLD%NDPTS,
+     &                     GFLD%IDRTNUM,GFLD%IDRTMPL,
+     &                     GFLD%IDRTLEN,ICND)
+           JPOS=JPOS+LSEC5
+           CALL G2LIB_GBYTE(CBUF,GFLD%IBMAP,(JPOS+5)*8,1*8)  ! GET IBMAP
+           IRET=0
+        ELSE      ! PDT DID NOT MATCH
+           IPOS=IPOS+INLEN
+        ENDIF
+      ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getidx.F b/wrfv2_fire/external/io_grib2/g2lib/getidx.F
new file mode 100644
index 00000000..d4427b7b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getidx.F
@@ -0,0 +1,143 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETIDX         FINDS, READS OR GENERATES A GRIB2 INDEX 
+C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 2005-03-15
+C
+C ABSTRACT: FINDS, READS OR GENERATES A GRIB2 INDEX FOR THE GRIB2 FILE
+C  ASSOCIATED WITH UNIT LUGB.  IF THE INDEX ALREADY EXISTS, IT IS RETURNED.
+C  OTHERWISE, THE INDEX IS (1) READ FROM AN EXISTING INDEXFILE ASSOCIATED WITH
+C  UNIT LUGI. OR (2) GENERATED FROM THE GRIB2FILE LUGB ( IF LUGI=0 ). 
+C  USERS CAN FORCE A REGENERATION OF AN INDEX.  IF LUGI EQUALS LUGB, THE INDEX
+C  WILL BE REGENERATED FROM THE DATA IN FILE LUGB.  IF LUGI IS LESS THAN
+C  ZERO, THEN THE INDEX IS RE READ FROM INDEX FILE ABS(LUGI).  
+C
+C PROGRAM HISTORY LOG:
+C 2005-03-15  GILBERT
+C
+C USAGE:    CALL GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET)
+C
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING 
+C                  THIS ROUTINE.
+C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
+C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE 
+C                  CALLING THIS ROUTINE.
+C                  >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T 
+C                       ALREADY EXIST.
+C                  =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX 
+C                       DOESN"T ALREADY EXIST.
+C                  <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI).
+C                  =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB.
+C
+C   OUTPUT ARGUMENTS:
+C     CINDEX       CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
+C     NLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
+C     NNUM         INTEGER NUMBER OF INDEX RECORDS
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    90     UNIT NUMBER OUT OF RANGE
+C                    96     ERROR READING/CREATING INDEX FILE
+C
+C SUBPROGRAMS CALLED:
+C   GETG2I          READ INDEX FILE
+C   GETG2IR         READ INDEX BUFFER FROM GRIB FILE
+C
+C REMARKS: 
+C
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+
+      INTEGER,INTENT(IN) :: LUGB,LUGI
+      INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CINDEX
+
+      INTEGER,PARAMETER :: MAXIDX=100
+      INTEGER,PARAMETER :: MSK1=32000,MSK2=4000
+ 
+      TYPE GINDEX
+         integer :: nlen
+         integer :: nnum
+         character(len=1),pointer,dimension(:) :: cbuf
+      END TYPE GINDEX
+     
+      TYPE(GINDEX),SAVE :: IDXLIST(100)
+
+      DATA LUX/0/
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
+      INTERFACE
+         SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
+            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+            INTEGER,INTENT(IN) :: LUGI
+            INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
+         END SUBROUTINE GETG2I
+         SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
+     &                      NMESS,IRET)
+            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+            INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
+            INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
+         END SUBROUTINE GETG2IR
+      END INTERFACE
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+      LUX=0
+      IRET=0
+      IF ( LUGB.LE.0 .AND. LUGB.GT.100 ) THEN
+         IRET=90
+         RETURN
+      ENDIF
+      IF (LUGI.EQ.LUGB) THEN      ! Force regeneration of index from GRIB2 File
+         IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) 
+     &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
+         NULLIFY(IDXLIST(LUGB)%CBUF)
+         IDXLIST(LUGB)%NLEN=0
+         IDXLIST(LUGB)%NNUM=0
+         LUX=0
+      ENDIF
+      IF (LUGI.LT.0) THEN      ! Force re-read of index from indexfile
+                               ! associated with unit abs(lugi)
+         IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) 
+     &                  DEALLOCATE(IDXLIST(LUGB)%CBUF)
+         NULLIFY(IDXLIST(LUGB)%CBUF)
+         IDXLIST(LUGB)%NLEN=0
+         IDXLIST(LUGB)%NNUM=0
+         LUX=ABS(LUGI)
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  Check if index already exists in memory
+      IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) THEN
+         CINDEX => IDXLIST(LUGB)%CBUF
+         NLEN = IDXLIST(LUGB)%NLEN
+         NNUM = IDXLIST(LUGB)%NNUM
+         RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      IRGI=0
+      IF(LUX.GT.0) THEN
+        CALL GETG2I(LUX,IDXLIST(LUGB)%CBUF,NLEN,NNUM,IRGI)
+      ELSEIF(LUX.LE.0) THEN
+        MSKP=0
+        CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,IDXLIST(LUGB)%CBUF,
+     &               NLEN,NNUM,NMESS,IRGI)
+      ENDIF
+      IF(IRGI.EQ.0) THEN
+         CINDEX => IDXLIST(LUGB)%CBUF
+         IDXLIST(LUGB)%NLEN = NLEN
+         IDXLIST(LUGB)%NNUM = NNUM
+      ELSE
+         NLEN = 0
+         NNUM = 0
+         IRET=96
+         RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getlocal.F b/wrfv2_fire/external/io_grib2/g2lib/getlocal.F
new file mode 100644
index 00000000..c101a5ea
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getlocal.F
@@ -0,0 +1,168 @@
+      subroutine getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getlocal 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-25
+!
+! ABSTRACT: This subroutine returns the contents of Section 2 ( Local 
+!   Use Section ) from a GRIB2 message.  Since there can be multiple
+!   occurrences of Section 2 within a GRIB message, the calling routine
+!   indicates which occurrence is being requested with the localnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-25  Gilbert
+!
+! USAGE:    CALL getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message in array cgrib.
+!     localnum - The nth occurrence of Section 2 requested.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     csec2    - Character array containing information read from 
+!                Section 2.
+!                The dimension of this array can be obtained in advance
+!                from argument maxlocal, which is returned from subroutine 
+!                gb_info.
+!     lcsec2   - Number of bytes of character array csec2 read from
+!                Section 2.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The section 2 request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                5 = End string "7777" not found at end of message.
+!                6 = GRIB message did not contain the requested number of
+!                    Local Use Sections.
+!
+! REMARKS: Note that subroutine gb_info can be used to first determine
+!          how many Local Use sections exist in a given GRIB message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,localnum
+      character(len=1),intent(out) :: csec2(*)
+      integer,intent(out) :: lcsec2,ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      integer :: listsec0(2)
+      integer iofst,ibeg,istart,numlocal
+
+      ierr=0
+      numlocal=0
+!
+!  Check for valid request number
+!  
+      if (localnum.le.0) then
+        print *,'getlocal: Request for local section must be positive.'
+        ierr=3
+        return
+      endif
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'getlocal:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'getlocal: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through the remaining sections keeping track of the 
+!  length of each.  Also check to see that if the current occurrence
+!  of Section 2 is the same as the one requested.
+!
+      do
+        !    Check to see if we are at end of GRIB message
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          !    If end of GRIB message not where expected, issue error
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'getlocal: "7777" found, but not where expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        !     Get length of Section and Section number
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        !   If found the requested occurrence of Section 2,
+        !   return the section contents.
+        if (isecnum.eq.2) then
+          numlocal=numlocal+1
+          if (numlocal.eq.localnum) then
+            lcsec2=lensec-5
+            csec2(1:lcsec2)=cgrib(ipos+5:ipos+lensec-1)
+            return
+          endif
+        endif
+        !   Check to see if we read pass the end of the GRIB
+        !   message and missed the terminator string '7777'.
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'getlocal: "7777"  not found at end of GRIB message.'
+          ierr=5
+          return
+        endif
+        
+      enddo
+
+!
+!  If exited from above loop, the end of the GRIB message was reached
+!  before the requested occurrence of section 2 was found.
+!
+      print *,'getlocal: GRIB message contained ',numlocal,
+     &        ' local sections.'
+      print *,'getlocal: The request was for the ',localnum,
+     &        ' occurrence.'
+      ierr=6
+
+      return
+      end
+
+
+
+
+
+
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/getpoly.F b/wrfv2_fire/external/io_grib2/g2lib/getpoly.F
new file mode 100644
index 00000000..f8d22f3a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/getpoly.F
@@ -0,0 +1,80 @@
+      subroutine getpoly(csec3,lcsec3,jj,kk,mm)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getpoly 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-12-11
+!
+! ABSTRACT: This subroutine returns the J, K, and M pentagonal resolution
+!   parameters specified in a GRIB Grid Definition Section used
+!   spherical harmonic coefficients using GDT 5.50 through 5.53
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-11  Gilbert
+!
+! USAGE:    CALL getpoly(csec3,lcsec3,jj,kk,mm)
+!   INPUT ARGUMENT LIST:
+!     csec3    - Character array that contains the packed GRIB2 GDS
+!    lcsec3    - Length (in octets) of section 3
+!
+!   OUTPUT ARGUMENT LIST:      
+!         JJ   = J - pentagonal resolution parameter
+!         KK   = K - pentagonal resolution parameter
+!         MM   = M - pentagonal resolution parameter
+!
+! REMARKS:  Returns JJ, KK, and MM set to zero, if grid template
+!           not recognized.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+!      use grib_mod
+    
+      character(len=1),intent(in) :: csec3(*)
+      integer,intent(in) :: lcsec3
+      integer,intent(out) :: jj,kk,mm
+      
+      integer,pointer,dimension(:) :: igdstmpl,list_opt
+      integer :: igds(5)
+      integer iofst,igdtlen,num_opt,jerr
+
+      interface
+         subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                         mapgridlen,ideflist,idefnum,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: igdstmpl,ideflist
+            integer,intent(out) :: igds(5)
+            integer,intent(out) :: ierr,idefnum
+         end subroutine gf_unpack3
+      end interface
+
+      nullify(igdstmpl,list_opt)
+        !
+      iofst=0       ! set offset to beginning of section
+      call gf_unpack3(csec3,lcsec3,iofst,igds,igdstmpl,
+     &                 igdtlen,list_opt,num_opt,jerr)
+      if (jerr.eq.0) then
+         selectcase( igds(5) )     !  Template number
+           case (50:53)   ! Spherical harmonic coefficients
+              jj=igdstmpl(1)
+              kk=igdstmpl(2)
+              mm=igdstmpl(3)
+           case default
+              jj=0
+              kk=0
+              mm=0
+         end select
+      else
+         jj=0
+         kk=0
+         mm=0
+      endif
+        !
+      if (associated(igdstmpl)) deallocate(igdstmpl)
+      if (associated(list_opt)) deallocate(list_opt)
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gettemplates.F b/wrfv2_fire/external/io_grib2/g2lib/gettemplates.F
new file mode 100644
index 00000000..9f7867fa
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gettemplates.F
@@ -0,0 +1,244 @@
+      subroutine gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl,
+     &                    igdslen,ideflist,idefnum,ipdsnum,ipdstmpl,
+     &                    ipdslen,coordlist,numcoord,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gettemplates 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine returns the Grid Definition, and
+!   Product Definition for a given data
+!   field.  Since there can be multiple data fields packed into a GRIB2
+!   message, the calling routine indicates which field is being requested
+!   with the ifldnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen,
+!    &                    ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen,
+!    &                    coordlist,numcoord,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     ifldnum  - Specifies which field in the GRIB2 message to return.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     igds     - Contains information read from the appropriate GRIB Grid 
+!                Definition Section 3 for the field being returned.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Contains the data values for the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(2), which is returned from subroutine gribinfo.
+!     igdslen  - Number of elements in igdstmpl().  i.e. number of entries
+!                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
+!     ideflist - (Used if igds(3) .ne. 0)  This array contains the
+!                number of grid points contained in each row ( or column ).
+!                (part of Section 3)
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(3), which is returned from subroutine gribinfo.
+!     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Contains the data values for the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!                A safe dimension for this array can be obtained in advance
+!                from maxvals(4), which is returned from subroutine gribinfo.
+!     ipdslen  - Number of elements in ipdstmpl().  i.e. number of entries
+!                in Product Defintion Template 4.N  ( N=ipdsnum ).
+!     coordlist- Array containg floating point values intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.  (part of Section 4)
+!                The dimension of this array can be obtained in advance
+!                from maxvals(5), which is returned from subroutine gribinfo.
+!     numcoord - number of values in array coordlist.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The data field request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                6 = GRIB message did not contain the requested number of
+!                    data fields.
+!                7 = End string "7777" not found at end of message.
+!               10 = Error unpacking Section 3.
+!               11 = Error unpacking Section 4.
+!
+! REMARKS: Note that subroutine gribinfo can be used to first determine
+!          how many data fields exist in the given GRIB message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ifldnum
+      integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*)
+      integer,intent(out) :: ipdsnum,ipdstmpl(*)
+      integer,intent(out) :: idefnum,numcoord
+      integer,intent(out) :: ierr
+      real,intent(out) :: coordlist(*)
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      integer:: listsec0(2)
+      integer iofst,ibeg,istart
+      logical have3,have4
+
+      have3=.false.
+      have4=.false.
+      ierr=0
+      numfld=0
+!
+!  Check for valid request number
+!  
+      if (ifldnum.le.0) then
+        print *,'gettemplates: Request for field number must be ',
+     &          'positive.'
+        ierr=3
+        return
+      endif
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'gettemplates:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'gettemplates: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through the remaining sections keeping track of the 
+!  length of each.  Also keep the latest Grid Definition Section info.
+!  Unpack the requested field number.
+!
+      do
+        !    Check to see if we are at end of GRIB message
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          !    If end of GRIB message not where expected, issue error
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'gettemplates: "7777" found, but not where ',
+     &              'expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        !     Get length of Section and Section number
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        !print *,' lensec= ',lensec,'    secnum= ',isecnum
+        !
+        !   If found Section 3, unpack the GDS info using the 
+        !   appropriate template.  Save in case this is the latest
+        !   grid before the requested field.
+        !
+        if (isecnum.eq.3) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen,
+     &                 ideflist,idefnum,jerr)
+          if (jerr.eq.0) then
+            have3=.true.
+          else
+            ierr=10
+            return
+          endif
+        endif
+        !
+        !   If found Section 4, check to see if this field is the
+        !   one requested.
+        !
+        if (isecnum.eq.4) then
+          numfld=numfld+1
+          if (numfld.eq.ifldnum) then
+            iofst=iofst-40       ! reset offset to beginning of section
+            call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen,
+     &                   coordlist,numcoord,jerr)
+            if (jerr.eq.0) then
+              have4=.true.
+            else
+              ierr=11
+              return
+            endif
+          endif
+        endif
+        !
+        !   Check to see if we read pass the end of the GRIB
+        !   message and missed the terminator string '7777'.
+        !
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'gettemplates: "7777"  not found at end of GRIB ',
+     &            'message.'
+          ierr=7
+          return
+        endif
+
+        if (have3.and.have4) return
+        
+      enddo
+
+!
+!  If exited from above loop, the end of the GRIB message was reached
+!  before the requested field was found.
+!
+      print *,'gettemplates: GRIB message contained ',numlocal,
+     &        ' different fields.'
+      print *,'gettemplates: The request was for the ',ifldnum,
+     &        ' field.'
+      ierr=6
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_free.F b/wrfv2_fire/external/io_grib2/g2lib/gf_free.F
new file mode 100644
index 00000000..43fc6a4a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_free.F
@@ -0,0 +1,199 @@
+      subroutine gf_free(gfld)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_free 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine frees up memory that was used to store
+!   array values in derived type gribfield.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL gf_free(gfld)
+!   INPUT ARGUMENT LIST:
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!
+!   OUTPUT ARGUMENT LIST:      
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!        gfld%version = GRIB edition number
+!        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+!        gfld%idsect() = Contains the entries in the Identification
+!                        Section ( Section 1 )
+!                        This element is actually a pointer to an array
+!                        that holds the data.
+!            gfld%idsect(1)  = Identification of originating Centre
+!                                    ( see Common Code Table C-1 )
+!            gfld%idsect(2)  = Identification of originating Sub-centre
+!            gfld%idsect(3)  = GRIB Master Tables Version Number
+!                                    ( see Code Table 1.0 )
+!            gfld%idsect(4)  = GRIB Local Tables Version Number
+!                                    ( see Code Table 1.1 )
+!            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+!            gfld%idsect(6)  = Year ( 4 digits )
+!            gfld%idsect(7)  = Month
+!            gfld%idsect(8)  = Day
+!            gfld%idsect(9)  = Hour
+!            gfld%idsect(10)  = Minute
+!            gfld%idsect(11)  = Second
+!            gfld%idsect(12)  = Production status of processed data
+!                                    ( see Code Table 1.3 )
+!            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+!        gfld%idsectlen = Number of elements in gfld%idsect().
+!        gfld%local() = Pointer to character array containing contents
+!                       of Local Section 2, if included
+!        gfld%locallen = length of array gfld%local()
+!        gfld%ifldnum = field number within GRIB message
+!        gfld%griddef = Source of grid definition (see Code Table 3.0)
+!        gfld%ngrdpts = Number of grid points in the defined grid.
+!        gfld%numoct_opt = Number of octets needed for each 
+!                          additional grid points definition.  
+!                          Used to define number of
+!                          points in each row ( or column ) for
+!                          non-regular grids.  
+!                          = 0, if using regular grid.
+!        gfld%interp_opt = Interpretation of list for optional points 
+!                          definition.  (Code Table 3.11)
+!        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+!        gfld%igdtmpl() = Contains the data values for the specified Grid 
+!                         Definition Template ( NN=gfld%igdtnum ).  Each 
+!                         element of this integer array contains an entry (in 
+!                         the order specified) of Grid Defintion Template 3.NN
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+!                       entries in Grid Defintion Template 3.NN  
+!                       ( NN=gfld%igdtnum ).
+!        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array 
+!                          contains the number of grid points contained in 
+!                          each row ( or column ).  (part of Section 3)
+!                          This element is actually a pointer to an array
+!                          that holds the data.  This pointer is nullified
+!                          if gfld%numoct_opt=0.
+!        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+!                       in array ideflist.  i.e. number of rows ( or columns )
+!                       for which optional grid points are defined.  This value
+!                       is set to zero, if gfld%numoct_opt=0.
+!        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+!        gfld%ipdtmpl() = Contains the data values for the specified Product 
+!                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+!                         of this integer array contains an entry (in the 
+!                         order specified) of Product Defintion Template 4.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+!                       entries in Product Defintion Template 4.N  
+!                       ( N=gfdl%ipdtnum ).
+!        gfld%coord_list() = Real array containing floating point values 
+!                            intended to document the vertical discretisation
+!                            associated to model data on hybrid coordinate
+!                            vertical levels.  (part of Section 4)
+!                            This element is actually a pointer to an array
+!                            that holds the data.
+!        gfld%num_coord = number of values in array gfld%coord_list().
+!        gfld%ndpts = Number of data points unpacked and returned.
+!        gfld%idrtnum = Data Representation Template Number 
+!                       ( see Code Table 5.0)
+!        gfld%idrtmpl() = Contains the data values for the specified Data 
+!                         Representation Template ( N=gfld%idrtnum ).  Each 
+!                         element of this integer array contains an entry 
+!                         (in the order specified) of Product Defintion 
+!                         Template 5.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number 
+!                       of entries in Data Representation Template 5.N 
+!                       ( N=gfld%idrtnum ).
+!        gfld%unpacked = logical value indicating whether the bitmap and
+!                        data values were unpacked.  If false, gfld%ndpts
+!                        is set to zero, and gfld%bmap and gfld%fld 
+!                        pointers are nullified.
+!        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+!                     0 = bitmap applies and is included in Section 6.
+!                     1-253 = Predefined bitmap applies
+!                     254 = Previously defined bitmap applies to this field
+!                     255 = Bit map does not apply to this product.
+!        gfld%bmap() - Logical*1 array containing decoded bitmap, 
+!                      if ibmap=0 or ibap=254.  Otherwise nullified.
+!                      This element is actually a pointer to an array
+!                      that holds the data.
+!        gfld%fld() = Array of gfld%ndpts unpacked data points.
+!                     This element is actually a pointer to an array
+!                     that holds the data.
+!
+! REMARKS: 
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+      use grib_mod
+    
+      type(gribfield) :: gfld
+
+      if (associated(gfld%idsect)) then
+         deallocate(gfld%idsect)
+         !deallocate(gfld%idsect,stat=is)
+         !print *,'gfld%idsect: ',is
+      endif
+      nullify(gfld%idsect)
+
+      if (associated(gfld%local)) then
+         deallocate(gfld%local)
+         !deallocate(gfld%local,stat=is)
+         !print *,'gfld%local: ',is
+      endif
+      nullify(gfld%local)
+
+      if (associated(gfld%list_opt)) then
+         deallocate(gfld%list_opt)
+         !deallocate(gfld%list_opt,stat=is)
+         !print *,'gfld%list_opt: ',is
+      endif
+      nullify(gfld%list_opt)
+
+      if (associated(gfld%igdtmpl)) then
+         deallocate(gfld%igdtmpl)
+         !deallocate(gfld%igdtmpl,stat=is)
+         !print *,'gfld%igdtmpl: ',is
+      endif
+      nullify(gfld%igdtmpl)
+
+      if (associated(gfld%ipdtmpl)) then
+         deallocate(gfld%ipdtmpl)
+         !deallocate(gfld%ipdtmpl,stat=is)
+         !print *,'gfld%ipdtmpl: ',is
+      endif
+      nullify(gfld%ipdtmpl)
+
+      if (associated(gfld%coord_list)) then
+         deallocate(gfld%coord_list)
+         !deallocate(gfld%coord_list,stat=is)
+         !print *,'gfld%coord_list: ',is
+      endif
+      nullify(gfld%coord_list)
+
+      if (associated(gfld%idrtmpl)) then
+         deallocate(gfld%idrtmpl)
+         !deallocate(gfld%idrtmpl,stat=is)
+         !print *,'gfld%idrtmpl: ',is
+      endif
+      nullify(gfld%idrtmpl)
+
+      if (associated(gfld%bmap)) then
+         deallocate(gfld%bmap)
+         !deallocate(gfld%bmap,stat=is)
+         !print *,'gfld%bmap: ',is
+      endif
+      nullify(gfld%bmap)
+
+      if (associated(gfld%fld)) then
+         deallocate(gfld%fld)
+         !deallocate(gfld%fld,stat=is)
+         !print *,'gfld%fld: ',is
+      endif
+      nullify(gfld%fld)
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_getfld.F b/wrfv2_fire/external/io_grib2/g2lib/gf_getfld.F
new file mode 100644
index 00000000..82a21a0b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_getfld.F
@@ -0,0 +1,602 @@
+      subroutine gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_getfld 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine returns the Grid Definition, Product Definition,
+!   Bit-map ( if applicable ), and the unpacked data for a given data
+!   field.  All of the information returned is stored in a derived
+!   type variable, gfld.  Gfld is of type gribfield, which is defined
+!   in module grib_mod, so users of this routine will need to include
+!   the line "USE GRIB_MOD" in their calling routine.  Each component of the 
+!   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+!
+!   Since there can be multiple data fields packed into a GRIB2
+!   message, the calling routine indicates which field is being requested
+!   with the ifldnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to pass back derived type gribfield
+!                        variable through argument list, instead of
+!                        having many different arguments.
+! 2004-05-20  Gilbert  - Added check to see if previous a bit-map is specified,
+!                        but none was found.
+!
+! USAGE:    CALL gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     ifldnum  - Specifies which field in the GRIB2 message to return.
+!     unpack   - Logical value indicating whether to unpack bitmap/data
+!                .true. = unpack bitmap and data values
+!                .false. = do not unpack bitmap and data values
+!     expand   - Boolean value indicating whether the data points should be
+!                expanded to the correspond grid, if a bit-map is present.
+!                1 = if possible, expand data field to grid, inserting zero
+!                    values at gridpoints that are bitmapped out.
+!                    (SEE REMARKS2)
+!                0 = do not expand data field, leaving it an array of
+!                    consecutive data points for each "1" in the bitmap.
+!                This argument is ignored if unpack == 0 OR if the
+!                returned field does not contain a bit-map.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!            ( NOTE: See Remarks Section )
+!        gfld%version = GRIB edition number ( currently 2 )
+!        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+!        gfld%idsect() = Contains the entries in the Identification
+!                        Section ( Section 1 )
+!                        This element is actually a pointer to an array
+!                        that holds the data.
+!            gfld%idsect(1)  = Identification of originating Centre 
+!                                    ( see Common Code Table C-1 )
+!                             7 - US National Weather Service
+!            gfld%idsect(2)  = Identification of originating Sub-centre
+!            gfld%idsect(3)  = GRIB Master Tables Version Number
+!                                    ( see Code Table 1.0 )
+!                             0 - Experimental
+!                             1 - Initial operational version number
+!            gfld%idsect(4)  = GRIB Local Tables Version Number
+!                                    ( see Code Table 1.1 )
+!                             0     - Local tables not used
+!                             1-254 - Number of local tables version used
+!            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+!                             0 - Analysis
+!                             1 - Start of forecast
+!                             2 - Verifying time of forecast
+!                             3 - Observation time
+!            gfld%idsect(6)  = Year ( 4 digits )
+!            gfld%idsect(7)  = Month
+!            gfld%idsect(8)  = Day
+!            gfld%idsect(9)  = Hour
+!            gfld%idsect(10)  = Minute
+!            gfld%idsect(11)  = Second
+!            gfld%idsect(12)  = Production status of processed data
+!                                    ( see Code Table 1.3 )
+!                              0 - Operational products
+!                              1 - Operational test products
+!                              2 - Research products
+!                              3 - Re-analysis products
+!            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+!                              0  - Analysis products
+!                              1  - Forecast products
+!                              2  - Analysis and forecast products
+!                              3  - Control forecast products
+!                              4  - Perturbed forecast products
+!                              5  - Control and perturbed forecast products
+!                              6  - Processed satellite observations
+!                              7  - Processed radar observations
+!        gfld%idsectlen = Number of elements in gfld%idsect().
+!        gfld%local() = Pointer to character array containing contents
+!                       of Local Section 2, if included
+!        gfld%locallen = length of array gfld%local()
+!        gfld%ifldnum = field number within GRIB message
+!        gfld%griddef = Source of grid definition (see Code Table 3.0)
+!                      0 - Specified in Code table 3.1
+!                      1 - Predetermined grid Defined by originating centre
+!        gfld%ngrdpts = Number of grid points in the defined grid.
+!        gfld%numoct_opt = Number of octets needed for each 
+!                          additional grid points definition.  
+!                          Used to define number of
+!                          points in each row ( or column ) for
+!                          non-regular grids.  
+!                          = 0, if using regular grid.
+!        gfld%interp_opt = Interpretation of list for optional points 
+!                          definition.  (Code Table 3.11)
+!        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+!        gfld%igdtmpl() = Contains the data values for the specified Grid 
+!                         Definition Template ( NN=gfld%igdtnum ).  Each 
+!                         element of this integer array contains an entry (in 
+!                         the order specified) of Grid Defintion Template 3.NN
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+!                       entries in Grid Defintion Template 3.NN  
+!                       ( NN=gfld%igdtnum ).
+!        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array 
+!                          contains the number of grid points contained in 
+!                          each row ( or column ).  (part of Section 3)
+!                          This element is actually a pointer to an array
+!                          that holds the data.  This pointer is nullified
+!                          if gfld%numoct_opt=0.
+!        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+!                       in array ideflist.  i.e. number of rows ( or columns )
+!                       for which optional grid points are defined.  This value
+!                       is set to zero, if gfld%numoct_opt=0.
+!        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+!        gfld%ipdtmpl() = Contains the data values for the specified Product 
+!                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+!                         of this integer array contains an entry (in the 
+!                         order specified) of Product Defintion Template 4.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+!                       entries in Product Defintion Template 4.N  
+!                       ( N=gfdl%ipdtnum ).
+!        gfld%coord_list() = Real array containing floating point values 
+!                            intended to document the vertical discretisation
+!                            associated to model data on hybrid coordinate
+!                            vertical levels.  (part of Section 4)
+!                            This element is actually a pointer to an array
+!                            that holds the data.
+!        gfld%num_coord = number of values in array gfld%coord_list().
+!        gfld%ndpts = Number of data points unpacked and returned.
+!        gfld%idrtnum = Data Representation Template Number 
+!                       ( see Code Table 5.0)
+!        gfld%idrtmpl() = Contains the data values for the specified Data 
+!                         Representation Template ( N=gfld%idrtnum ).  Each 
+!                         element of this integer array contains an entry 
+!                         (in the order specified) of Product Defintion 
+!                         Template 5.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number 
+!                       of entries in Data Representation Template 5.N 
+!                       ( N=gfld%idrtnum ).
+!        gfld%unpacked = logical value indicating whether the bitmap and
+!                        data values were unpacked.  If false, 
+!                        gfld%bmap and gfld%fld pointers are nullified.
+!        gfld%expanded = Logical value indicating whether the data field
+!                         was expanded to the grid in the case where a
+!                         bit-map is present.  If true, the data points in
+!                         gfld%fld match the grid points and zeros were
+!                         inserted at grid points where data was bit-mapped
+!                         out.  If false, the data values in gfld%fld were
+!                         not expanded to the grid and are just a consecutive
+!                         array of data points corresponding to each value of
+!                         "1" in gfld%bmap.
+!        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+!                     0 = bitmap applies and is included in Section 6.
+!                     1-253 = Predefined bitmap applies
+!                     254 = Previously defined bitmap applies to this field
+!                     255 = Bit map does not apply to this product.
+!        gfld%bmap() = Logical*1 array containing decoded bitmap, 
+!                      if ibmap=0 or ibap=254.  Otherwise nullified.
+!                      This element is actually a pointer to an array
+!                      that holds the data.
+!        gfld%fld() = Array of gfld%ndpts unpacked data points.
+!                     This element is actually a pointer to an array
+!                     that holds the data.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The data field request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                6 = GRIB message did not contain the requested number of
+!                    data fields.
+!                7 = End string "7777" not found at end of message.
+!                8 = Unrecognized Section encountered.
+!                9 = Data Representation Template 5.NN not yet implemented.
+!               15 = Error unpacking Section 1.
+!               16 = Error unpacking Section 2.
+!               10 = Error unpacking Section 3.
+!               11 = Error unpacking Section 4.
+!               12 = Error unpacking Section 5.
+!               13 = Error unpacking Section 6.
+!               14 = Error unpacking Section 7.
+!               17 = Previous bitmap specified, but none exists.
+!
+! REMARKS: Note that derived type gribfield contains pointers to many
+!          arrays of data.  The memory for these arrays is allocated
+!          when the values in the arrays are set, to help minimize
+!          problems with array overloading.  Because of this users
+!          are encouraged to free up this memory, when it is no longer
+!          needed, by an explicit call to subroutine gf_free.
+!          ( i.e.   CALL GF_FREE(GFLD) )
+!
+!          Subroutine gb_info can be used to first determine
+!          how many data fields exist in a given GRIB message.
+!
+! REMARKS2: It may not always be possible to expand a bit-mapped data field.
+!           If a pre-defined bit-map is used and not included in the GRIB2
+!           message itself, this routine would not have the necessary
+!           information to expand the data.  In this case, gfld%expanded would
+!           would be set to 0 (false), regardless of the value of input
+!           argument expand.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+      use grib_mod
+    
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ifldnum
+      logical,intent(in) :: unpack,expand
+      type(gribfield),intent(out) :: gfld
+      integer,intent(out) :: ierr
+!      integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*)
+!      integer,intent(out) :: ipdsnum,ipdstmpl(*)
+!      integer,intent(out) :: idrsnum,idrstmpl(*)
+!      integer,intent(out) :: ndpts,ibmap,idefnum,numcoord
+!      logical*1,intent(out) :: bmap(*)
+!      real,intent(out) :: fld(*),coordlist(*)
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      real,pointer,dimension(:) :: newfld
+      integer:: listsec0(2),igds(5)
+      integer iofst,ibeg,istart
+      integer(4) :: ieee
+      logical*1,pointer,dimension(:) :: bmpsave
+      logical have3,have4,have5,have6,have7
+
+      interface
+         subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: ids
+            integer,intent(out) :: ierr,idslen
+         end subroutine gf_unpack1
+         subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,intent(out) :: lencsec2
+            integer,intent(out) :: ierr
+            character(len=1),pointer,dimension(:) :: csec2
+         end subroutine gf_unpack2
+         subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                         mapgridlen,ideflist,idefnum,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: igdstmpl,ideflist
+            integer,intent(out) :: igds(5)
+            integer,intent(out) :: ierr,idefnum
+         end subroutine gf_unpack3
+         subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,
+     &                      mappdslen,coordlist,numcoord,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            real,pointer,dimension(:) :: coordlist
+            integer,pointer,dimension(:) :: ipdstmpl
+            integer,intent(out) :: ipdsnum
+            integer,intent(out) :: ierr,numcoord
+         end subroutine gf_unpack4
+         subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,
+     &                         idrstmpl,mapdrslen,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib
+            integer,intent(inout) :: iofst
+            integer,intent(out) :: ndpts,idrsnum
+            integer,pointer,dimension(:) :: idrstmpl
+            integer,intent(out) :: ierr
+         end subroutine gf_unpack5
+         subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib,ngpts
+            integer,intent(inout) :: iofst
+            integer,intent(out) :: ibmap
+            integer,intent(out) :: ierr
+            logical*1,pointer,dimension(:) :: bmap
+         end subroutine gf_unpack6
+         subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl,
+     &                         idrsnum,idrstmpl,ndpts,fld,ierr)
+            character(len=1),intent(in) :: cgrib(lcgrib)
+            integer,intent(in) :: lcgrib,ndpts,idrsnum,igdsnum
+            integer,intent(inout) :: iofst
+            integer,pointer,dimension(:) :: idrstmpl,igdstmpl
+            integer,intent(out) :: ierr
+            real,pointer,dimension(:) :: fld
+         end subroutine gf_unpack7
+      end interface
+
+      have3=.false.
+      have4=.false.
+      have5=.false.
+      have6=.false.
+      have7=.false.
+      ierr=0
+      numfld=0
+      gfld%locallen=0
+      nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl)
+      nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld)
+!
+!  Check for valid request number
+!  
+      if (ifldnum.le.0) then
+        print *,'gf_getfld: Request for field number must be positive.'
+        ierr=3
+        return
+      endif
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'gf_getfld:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'gf_getfld: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Loop through the remaining sections keeping track of the 
+!  length of each.  Also keep the latest Grid Definition Section info.
+!  Unpack the requested field number.
+!
+      do
+        !    Check to see if we are at end of GRIB message
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          !    If end of GRIB message not where expected, issue error
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'gf_getfld: "7777" found, but not where expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        !     Get length of Section and Section number
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        !print *,' lensec= ',lensec,'    secnum= ',isecnum
+        !
+        !  Check to see if section number is valid
+        !
+        if ( (isecnum.lt.1).OR.(isecnum.gt.7) ) then
+          print *,'gf_getfld: Unrecognized Section Encountered=',isecnum     
+          ierr=8
+          return
+        endif
+        !
+        !   If found Section 1, decode elements in Identification Section
+        !
+        if (isecnum.eq.1) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call gf_unpack1(cgrib,lcgrib,iofst,gfld%idsect,
+     &                    gfld%idsectlen,jerr)
+          if (jerr.ne.0) then
+            ierr=15
+            return
+          endif
+        endif
+        !
+        !   If found Section 2, Grab local section
+        !   Save in case this is the latest one before the requested field.
+        !
+        if (isecnum.eq.2) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          if (associated(gfld%local)) deallocate(gfld%local)
+          call gf_unpack2(cgrib,lcgrib,iofst,gfld%locallen,
+     &                    gfld%local,jerr)
+          if (jerr.ne.0) then
+            ierr=16
+            return
+          endif
+        endif
+        !
+        !   If found Section 3, unpack the GDS info using the 
+        !   appropriate template.  Save in case this is the latest
+        !   grid before the requested field.
+        !
+        if (isecnum.eq.3) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          if (associated(gfld%igdtmpl)) deallocate(gfld%igdtmpl)
+          if (associated(gfld%list_opt)) deallocate(gfld%list_opt)
+          call gf_unpack3(cgrib,lcgrib,iofst,igds,gfld%igdtmpl,
+     &                 gfld%igdtlen,gfld%list_opt,gfld%num_opt,jerr)
+          if (jerr.eq.0) then
+            have3=.true.
+            gfld%griddef=igds(1)
+            gfld%ngrdpts=igds(2)
+            gfld%numoct_opt=igds(3)
+            gfld%interp_opt=igds(4)
+            gfld%igdtnum=igds(5)
+          else
+            ierr=10
+            return
+          endif
+        endif
+        !
+        !   If found Section 4, check to see if this field is the
+        !   one requested.
+        !
+        if (isecnum.eq.4) then
+          numfld=numfld+1
+          if (numfld.eq.ifldnum) then
+            gfld%discipline=listsec0(1)
+            gfld%version=listsec0(2)
+            gfld%ifldnum=ifldnum
+            gfld%unpacked=unpack
+            gfld%expanded=.false.
+            iofst=iofst-40       ! reset offset to beginning of section
+            call gf_unpack4(cgrib,lcgrib,iofst,gfld%ipdtnum,
+     &                      gfld%ipdtmpl,gfld%ipdtlen,gfld%coord_list,
+     &                      gfld%num_coord,jerr)
+            if (jerr.eq.0) then
+              have4=.true.
+            else
+              ierr=11
+              return
+            endif
+          endif
+        endif
+        !
+        !   If found Section 5, check to see if this field is the
+        !   one requested.
+        !
+        if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call gf_unpack5(cgrib,lcgrib,iofst,gfld%ndpts,gfld%idrtnum,
+     &                    gfld%idrtmpl,gfld%idrtlen,jerr)
+          if (jerr.eq.0) then
+            have5=.true.
+          else
+            ierr=12
+            return
+          endif
+        endif
+        !
+        !   If found Section 6, Unpack bitmap.
+        !   Save in case this is the latest
+        !   bitmap before the requested field.
+        !
+        if (isecnum.eq.6) then
+          if (unpack) then   ! unpack bitmap
+            iofst=iofst-40       ! reset offset to beginning of section
+            bmpsave=>gfld%bmap      ! save pointer to previous bitmap
+            call gf_unpack6(cgrib,lcgrib,iofst,gfld%ngrdpts,gfld%ibmap,
+     &                   gfld%bmap,jerr)
+            if (jerr.eq.0) then
+              have6=.true.
+              if (gfld%ibmap .eq. 254) then    ! use previously specified bitmap
+                 if ( associated(bmpsave) ) then
+                    gfld%bmap=>bmpsave
+                 else
+                    print *,'gf_getfld:  Previous bit-map specified,',
+     &                       ' but none exists,'
+                    ierr=17
+                    return
+                 endif
+              else                             ! get rid of it
+                 if ( associated(bmpsave) ) deallocate(bmpsave)
+              endif
+            else
+              ierr=13
+              return
+            endif
+          else    ! do not unpack bitmap
+            call g2lib_gbyte(cgrib,gfld%ibmap,iofst,8)      ! Get BitMap Indicator
+            have6=.true.
+          endif
+        endif
+        !
+        !   If found Section 7, check to see if this field is the
+        !   one requested.
+        !
+        if ((isecnum.eq.7).and.(numfld.eq.ifldnum).and.unpack) then
+          iofst=iofst-40       ! reset offset to beginning of section
+          call gf_unpack7(cgrib,lcgrib,iofst,gfld%igdtnum,
+     &                    gfld%igdtmpl,gfld%idrtnum,
+     &                    gfld%idrtmpl,gfld%ndpts,
+     &                    gfld%fld,jerr)
+          if (jerr.eq.0) then
+            have7=.true.
+            !  If bitmap is used with this field, expand data field
+            !  to grid, if possible.
+            if ( gfld%ibmap .ne. 255 .AND. associated(gfld%bmap) ) then
+               if ( expand ) then
+                  allocate(newfld(gfld%ngrdpts))
+                  !newfld(1:gfld%ngrdpts)=0.0
+                  !newfld=unpack(gfld%fld,gfld%bmap,newfld)
+                  n=1
+                  do j=1,gfld%ngrdpts
+                      if ( gfld%bmap(j) ) then
+                        newfld(j)=gfld%fld(n)
+                        n=n+1
+                      else
+                        newfld(j)=0.0
+                      endif
+                  enddo
+                  deallocate(gfld%fld);
+                  gfld%fld=>newfld;
+                  gfld%expanded=.true.
+               else 
+                  gfld%expanded=.false.
+               endif
+            else 
+               gfld%expanded=.true.
+            endif
+          else
+            print *,'gf_getfld: return from gf_unpack7 = ',jerr
+            ierr=14
+            return
+          endif
+        endif
+        !
+        !   Check to see if we read pass the end of the GRIB
+        !   message and missed the terminator string '7777'.
+        !
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'gf_getfld: "7777"  not found at end of GRIB message.'
+          ierr=7
+          return
+        endif
+        !
+        !  If unpacking requested, return when all sections have been
+        !  processed
+        !
+        if (unpack.and.have3.and.have4.and.have5.and.have6.and.have7)
+     &      return
+        !
+        !  If unpacking is not requested, return when sections 
+        !  3 through 6 have been processed
+        !
+        if ((.NOT.unpack).and.have3.and.have4.and.have5.and.have6)
+     &      return
+        
+      enddo
+
+!
+!  If exited from above loop, the end of the GRIB message was reached
+!  before the requested field was found.
+!
+      print *,'gf_getfld: GRIB message contained ',numlocal,
+     &        ' different fields.'
+      print *,'gf_getfld: The request was for the ',ifldnum,
+     &        ' field.'
+      ierr=6
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack1.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack1.F
new file mode 100644
index 00000000..320a2107
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack1.F
@@ -0,0 +1,93 @@
+      subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack1 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 1 (Identification Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
+!                        and to pass pointers to those arrays through
+!                        the argument list.
+!
+! USAGE:    CALL gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array containing Section 1 of the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 1.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 1, returned.
+!     ids      - Pointer to integer array containing information read from 
+!                Section 1, the Identification section.
+!            ids(1)  = Identification of originating Centre
+!                                 ( see Common Code Table C-1 )
+!            ids(2)  = Identification of originating Sub-centre
+!            ids(3)  = GRIB Master Tables Version Number
+!                                 ( see Code Table 1.0 )
+!            ids(4)  = GRIB Local Tables Version Number
+!                                 ( see Code Table 1.1 )
+!            ids(5)  = Significance of Reference Time (Code Table 1.2)
+!            ids(6)  = Year ( 4 digits )
+!            ids(7)  = Month
+!            ids(8)  = Day
+!            ids(9)  = Hour
+!            ids(10)  = Minute
+!            ids(11)  = Second
+!            ids(12)  = Production status of processed data
+!                                 ( see Code Table 1.3 )
+!            ids(13)  = Type of processed data ( see Code Table 1.4 )
+!     idslen   - Number of elements in ids().
+!     ierr     - Error return code.
+!                0 = no error
+!                6 = memory allocation error
+!
+! REMARKS: 
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,pointer,dimension(:) :: ids
+      integer,intent(out) :: ierr,idslen
+
+      integer,dimension(:) :: mapid(13)
+
+      data mapid /2,2,1,1,1,2,1,1,1,1,1,1,1/
+
+      ierr=0
+      idslen=13
+      nullify(ids)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+      !
+      !   Unpack each value into array ids from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapid.
+      !
+      istat=0
+      allocate(ids(idslen),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         nullify(ids)
+         return
+      endif
+      
+      do i=1,idslen
+        nbits=mapid(i)*8
+        call g2lib_gbyte(cgrib,ids(i),iofst,nbits)
+        iofst=iofst+nbits
+      enddo
+      
+      return    ! End of Section 1 processing
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack2.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack2.F
new file mode 100644
index 00000000..cefb2bc6
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack2.F
@@ -0,0 +1,72 @@
+      subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack2 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-04-09
+!
+! ABSTRACT: This subroutine unpacks Section 2 (Local Use Section)
+!           as defined in GRIB Edition 2.
+!
+! PROGRAM HISTORY LOG:
+! 2002-04-09  Gilbert
+!
+! USAGE:    CALL gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array containing Section 2 of the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 2.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 2, returned.
+!     lencsec2 - Length (in octets) of Local Use data
+!     csec2()  - Pointer to a character*1 array containing local use data
+!     ierr     - Error return code.
+!                0 = no error
+!                2 = Array passed is not section 2
+!                6 = memory allocation error
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: lencsec2
+      integer,intent(out) :: ierr
+      character(len=1),pointer,dimension(:) :: csec2
+
+      ierr=0
+      lencsec2=0
+      nullify(csec2)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32    
+      lencsec2=lensec-5
+      call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section Number
+      iofst=iofst+8     
+      ipos=(iofst/8)+1
+
+      if ( isecnum.ne.2 ) then
+         ierr=6
+         print *,'gf_unpack2: Not Section 2 data. '
+         return
+      endif
+
+      allocate(csec2(lencsec2),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         nullify(csec2)
+         return
+      endif
+      
+      csec2(1:lencsec2)=cgrib(ipos:ipos+lencsec2-1)
+      iofst=iofst+(lencsec2*8)
+
+      return    ! End of Section 2 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack3.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack3.F
new file mode 100644
index 00000000..8745fb60
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack3.F
@@ -0,0 +1,189 @@
+      subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
+     &                   mapgridlen,ideflist,idefnum,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack3 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 3 (Grid Definition Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
+!                        and to pass pointers to those arrays through
+!                        the argument list.
+!
+! USAGE:    CALL gf_unpack3(cgrib,lcgrib,lensec,iofst,igds,igdstmpl,
+!    &                   mapgridlen,ideflist,idefnum,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 3.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 3, returned.
+!     igds     - Contains information read from the appropriate GRIB Grid 
+!                Definition Section 3 for the field being returned.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Pointer to integer array containing the data values for 
+!                the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!     mapgridlen- Number of elements in igdstmpl().  i.e. number of entries
+!                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
+!     ideflist - (Used if igds(3) .ne. 0)  Pointer to integer array containing
+!                the number of grid points contained in each row ( or column ).
+!                (part of Section 3)
+!     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!     ierr     - Error return code.
+!                0 = no error
+!                5 = "GRIB" message contains an undefined Grid Definition
+!                    Template.
+!                6 = memory allocation error
+!
+! REMARKS: Uses Fortran 90 module gridtemplates and module re_alloc.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use gridtemplates
+      use re_alloc        !  needed for subroutine realloc
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,pointer,dimension(:) :: igdstmpl,ideflist
+      integer,intent(out) :: igds(5)
+      integer,intent(out) :: ierr,idefnum
+
+      integer,allocatable :: mapgrid(:)
+      integer :: mapgridlen,ibyttem
+      logical needext
+
+      ierr=0
+      nullify(igdstmpl,ideflist)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+
+      call g2lib_gbyte(cgrib,igds(1),iofst,8)     ! Get source of Grid def.
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(2),iofst,32)    ! Get number of grid pts.
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,igds(3),iofst,8)     ! Get num octets for opt. list
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(4),iofst,8)     ! Get interpret. for opt. list
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,igds(5),iofst,16)    ! Get Grid Def Template num.
+      iofst=iofst+16
+!      if (igds(1).eq.0) then
+      if (igds(1).eq.0.OR.igds(1).eq.255) then  ! FOR ECMWF TEST ONLY
+        allocate(mapgrid(lensec))
+        !   Get Grid Definition Template
+        call getgridtemplate(igds(5),mapgridlen,mapgrid,needext,
+     &                       iret)
+        if (iret.ne.0) then
+          ierr=5
+          if( allocated(mapgrid) ) deallocate(mapgrid)
+          return
+        endif
+      else
+!        igdstmpl=-1
+        mapgridlen=0
+        needext=.false.
+      endif
+      !
+      !   Unpack each value into array igdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapgrid.
+      !
+      istat=0
+      if (mapgridlen.gt.0) allocate(igdstmpl(mapgridlen),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         nullify(igdstmpl)
+         if( allocated(mapgrid) ) deallocate(mapgrid)
+         return
+      endif
+      ibyttem=0
+      do i=1,mapgridlen
+        nbits=iabs(mapgrid(i))*8
+        if ( mapgrid(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
+        endif
+        iofst=iofst+nbits
+        ibyttem=ibyttem+iabs(mapgrid(i))
+      enddo
+      !
+      !   Check to see if the Grid Definition Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid)
+        !   Unpack the rest of the Grid Definition Template
+        call realloc(igdstmpl,mapgridlen,newmapgridlen,istat)
+        do i=mapgridlen+1,newmapgridlen
+          nbits=iabs(mapgrid(i))*8
+          if ( mapgrid(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
+          endif
+          iofst=iofst+nbits
+          ibyttem=ibyttem+iabs(mapgrid(i))
+        enddo
+        mapgridlen=newmapgridlen
+      endif
+      if( allocated(mapgrid) ) deallocate(mapgrid)
+      !
+      !   Unpack optional list of numbers defining number of points
+      !   in each row or column, if included.  This is used for non regular
+      !   grids.
+      !
+      if ( igds(3).ne.0 ) then
+         nbits=igds(3)*8
+         idefnum=(lensec-14-ibyttem)/igds(3)
+         istat=0
+         if (idefnum.gt.0) allocate(ideflist(idefnum),stat=istat)
+         if (istat.ne.0) then
+            ierr=6
+            nullify(ideflist)
+            return
+         endif
+         call g2lib_gbytes(cgrib,ideflist,iofst,nbits,0,idefnum)
+         iofst=iofst+(nbits*idefnum)
+      else
+         idefnum=0
+         nullify(ideflist)
+      endif
+      
+      return    ! End of Section 3 processing
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack4.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack4.F
new file mode 100644
index 00000000..6b1a0ff8
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack4.F
@@ -0,0 +1,159 @@
+      subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,
+     &                      mappdslen,coordlist,numcoord,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack4 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 4 (Product Definition Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
+!                        and to pass pointers to those arrays through
+!                        the argument list.
+!
+! USAGE:    CALL gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen,
+!    &                   coordlist,numcoord,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 4.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset of the end of Section 4, returned.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Pointer to integer array containing the data values for 
+!                the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!     mappdslen- Number of elements in ipdstmpl().  i.e. number of entries
+!                in Product Defintion Template 4.N  ( N=ipdsnum ).
+!     coordlist- Pointer to real array containing floating point values 
+!                intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.  (part of Section 4)
+!     numcoord - number of values in array coordlist.
+!     ierr     - Error return code.
+!                0 = no error
+!                5 = "GRIB" message contains an undefined Product Definition
+!                    Template.
+!                6 = memory allocation error
+!
+! REMARKS: Uses Fortran 90 module pdstemplates and module re_alloc.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use pdstemplates
+      use re_alloc        !  needed for subroutine realloc
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      real,pointer,dimension(:) :: coordlist
+      integer,pointer,dimension(:) :: ipdstmpl
+      integer,intent(out) :: ipdsnum
+      integer,intent(out) :: ierr,numcoord
+
+      real(4),allocatable :: coordieee(:)
+      integer,allocatable :: mappds(:)
+      integer :: mappdslen
+      logical needext
+
+      ierr=0
+      nullify(ipdstmpl,coordlist)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+      allocate(mappds(lensec))
+
+      call g2lib_gbyte(cgrib,numcoord,iofst,16)    ! Get num of coordinate values
+      iofst=iofst+16
+      call g2lib_gbyte(cgrib,ipdsnum,iofst,16)    ! Get Prod. Def Template num.
+      iofst=iofst+16
+      !   Get Product Definition Template
+      call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret)
+      if (iret.ne.0) then
+        ierr=5
+        if( allocated(mappds) ) deallocate(mappds)
+        return
+      endif
+      !
+      !   Unpack each value into array ipdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mappds.
+      !
+      istat=0
+      if (mappdslen.gt.0) allocate(ipdstmpl(mappdslen),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         nullify(ipdstmpl)
+         if( allocated(mappds) ) deallocate(mappds)
+         return
+      endif
+      do i=1,mappdslen
+        nbits=iabs(mappds(i))*8
+        if ( mappds(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,ipdstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Check to see if the Product Definition Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extpdstemplate(ipdsnum,ipdstmpl,newmappdslen,mappds)
+        call realloc(ipdstmpl,mappdslen,newmappdslen,istat)
+        !   Unpack the rest of the Product Definition Template
+        do i=mappdslen+1,newmappdslen
+          nbits=iabs(mappds(i))*8
+          if ( mappds(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,ipdstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i)
+          endif
+          iofst=iofst+nbits
+        enddo
+        mappdslen=newmappdslen
+      endif
+      if( allocated(mappds) ) deallocate(mappds)
+      !
+      !   Get Optional list of vertical coordinate values
+      !   after the Product Definition Template, if necessary.
+      !
+      nullify(coordlist)
+      if ( numcoord .ne. 0 ) then
+         allocate (coordieee(numcoord),stat=istat1)
+         allocate(coordlist(numcoord),stat=istat)
+         if ((istat1+istat).ne.0) then
+            ierr=6
+            nullify(coordlist)
+            if( allocated(coordieee) ) deallocate(coordieee)
+            return
+         endif
+        call g2lib_gbytes(cgrib,coordieee,iofst,32,0,numcoord)
+        call rdieee(coordieee,coordlist,numcoord)
+        deallocate (coordieee)
+        iofst=iofst+(32*numcoord)
+      endif
+      
+      return    ! End of Section 4 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack5.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack5.F
new file mode 100644
index 00000000..6a203f5b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack5.F
@@ -0,0 +1,134 @@
+      subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
+     &                   mapdrslen,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack5 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 5 (Data Representation Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
+!                        and to pass pointers to those arrays through
+!                        the argument list.
+!
+! USAGE:    CALL gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
+!                        mapdrslen,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 5.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 5, returned.
+!     ndpts    - Number of data points unpacked and returned.
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0)
+!     idrstmpl - Pointer to an integer array containing the data values for 
+!                the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Data
+!                Representation Template 5.N
+!     mapdrslen- Number of elements in idrstmpl().  i.e. number of entries
+!                in Data Representation Template 5.N  ( N=idrsnum ).
+!     ierr     - Error return code.
+!                0 = no error
+!                6 = memory allocation error
+!                7 = "GRIB" message contains an undefined Data
+!                    Representation Template.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      use drstemplates
+      use re_alloc        !  needed for subroutine realloc
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: ndpts,idrsnum
+      integer,pointer,dimension(:) :: idrstmpl
+      integer,intent(out) :: ierr
+
+      integer,allocatable :: mapdrs(:)
+      integer :: mapdrslen
+      logical needext
+
+      ierr=0
+      nullify(idrstmpl)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32
+      iofst=iofst+8     ! skip section number
+      allocate(mapdrs(lensec))
+
+      call g2lib_gbyte(cgrib,ndpts,iofst,32)    ! Get num of data points
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,idrsnum,iofst,16)     ! Get Data Rep Template Num.
+      iofst=iofst+16
+      !   Gen Data Representation Template
+      call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret)
+      if (iret.ne.0) then
+        ierr=7
+        if( allocated(mapdrs) ) deallocate(mapdrs)
+        return
+      endif
+      !
+      !   Unpack each value into array ipdstmpl from the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mappds.
+      !
+      istat=0
+      if (mapdrslen.gt.0) allocate(idrstmpl(mapdrslen),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         nullify(idrstmpl)
+         if( allocated(mapdrs) ) deallocate(mapdrs)
+         return
+      endif
+      do i=1,mapdrslen
+        nbits=iabs(mapdrs(i))*8
+        if ( mapdrs(i).ge.0 ) then
+          call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
+        else
+          call g2lib_gbyte(cgrib,isign,iofst,1)
+          call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
+          if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
+        endif
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Check to see if the Data Representation Template needs to be
+      !   extended.
+      !   The number of values in a specific template may vary
+      !   depending on data specified in the "static" part of the
+      !   template.
+      !
+      if ( needext ) then
+        call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs)
+        call realloc(idrstmpl,mapdrslen,newmapdrslen,istat)
+        !   Unpack the rest of the Data Representation Template
+        do i=mapdrslen+1,newmapdrslen
+          nbits=iabs(mapdrs(i))*8
+          if ( mapdrs(i).ge.0 ) then
+            call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
+          else
+            call g2lib_gbyte(cgrib,isign,iofst,1)
+            call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
+            if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
+          endif
+          iofst=iofst+nbits
+        enddo
+        mapdrslen=newmapdrslen
+      endif
+      if( allocated(mapdrs) ) deallocate(mapdrs)
+
+      return    ! End of Section 5 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack6.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack6.F
new file mode 100644
index 00000000..443bbe47
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack6.F
@@ -0,0 +1,88 @@
+      subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack6 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine unpacks Section 6 (Bit-Map Section)
+!   starting at octet 6 of that Section.  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
+!                        and to pass pointers to those arrays through
+!                        the argument list.
+!
+! USAGE:    CALL gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 6.
+!     ngpts    - Number of grid points specified in the bit-map
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 6, returned.
+!     ibmap    - Bitmap indicator ( see Code Table 6.0 )
+!                0 = bitmap applies and is included in Section 6.
+!                1-253 = Predefined bitmap applies
+!                254 = Previously defined bitmap applies to this field
+!                255 = Bit map does not apply to this product.
+!     bmap()   - Pointer to a logical*1 array containing decoded bitmap. 
+!                ( if ibmap=0 )
+!     ierr     - Error return code.
+!                0 = no error
+!                4 = Unrecognized pre-defined bit-map.
+!                6 = memory allocation error
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ngpts
+      integer,intent(inout) :: iofst
+      integer,intent(out) :: ibmap
+      integer,intent(out) :: ierr
+      logical*1,pointer,dimension(:) :: bmap
+
+      integer :: intbmap(ngpts)
+
+      ierr=0
+      nullify(bmap)
+
+      iofst=iofst+32    ! skip Length of Section
+      iofst=iofst+8     ! skip section number
+
+      call g2lib_gbyte(cgrib,ibmap,iofst,8)    ! Get bit-map indicator
+      iofst=iofst+8
+
+      if (ibmap.eq.0) then               ! Unpack bitmap
+         istat=0
+         if (ngpts.gt.0) allocate(bmap(ngpts),stat=istat)
+         if (istat.ne.0) then
+            ierr=6
+            nullify(bmap)
+            return
+         endif
+         call g2lib_gbytes(cgrib,intbmap,iofst,1,0,ngpts)
+         iofst=iofst+ngpts
+         do j=1,ngpts
+           bmap(j)=.true.
+           if (intbmap(j).eq.0) bmap(j)=.false.
+         enddo
+!      elseif (ibmap.eq.254) then               ! Use previous bitmap
+!        return
+!      elseif (ibmap.eq.255) then               ! No bitmap in message
+!        bmap(1:ngpts)=.true.
+!      else
+!        print *,'gf_unpack6: Predefined bitmap ',ibmap,' not recognized.'
+!        ierr=4
+      endif
+      
+      return    ! End of Section 6 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gf_unpack7.F b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack7.F
new file mode 100644
index 00000000..57a3636b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gf_unpack7.F
@@ -0,0 +1,124 @@
+      subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl,
+     &                      idrsnum,idrstmpl,ndpts,fld,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_unpack7 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-01-24
+!
+! ABSTRACT: This subroutine unpacks GRIB2 Section 7 (Data Section).
+!
+! PROGRAM HISTORY LOG:
+! 2002-01-24  Gilbert
+! 2002-12-17  Gilbert  - Added support for new templates using 
+!                        PNG and JPEG2000 algorithms/templates.
+! 2004-12-29  Gilbert  - Added check on comunpack return code.
+!
+! USAGE:    CALL gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl,
+!    &                      idrsnum,idrstmpl,ndpts,fld,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     iofst    - Bit offset of the beginning of Section 7.
+!     igdsnum  - Grid Definition Template Number ( see Code Table 3.0)
+!                (Only required to unpack DRT 5.51)
+!     igdstmpl - Pointer to an integer array containing the data values for
+!                the specified Grid Definition
+!                Template ( N=igdsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Grid
+!                Definition Template 3.N
+!                (Only required to unpack DRT 5.51)
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0)
+!     idrstmpl - Pointer to an integer array containing the data values for
+!                the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer
+!                array contains an entry (in the order specified) of Data
+!                Representation Template 5.N
+!     ndpts    - Number of data points unpacked and returned.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     iofst    - Bit offset at the end of Section 7, returned.
+!     fld()    - Pointer to a real array containing the unpacked data field.
+!     ierr     - Error return code.
+!                0 = no error
+!                4 = Unrecognized Data Representation Template
+!                5 = One of GDT 3.50 through 3.53 required to unpack DRT 5.51
+!                6 = memory allocation error
+!                7 = corrupt section 7.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib,ndpts,igdsnum,idrsnum
+      integer,intent(inout) :: iofst
+      integer,pointer,dimension(:) :: igdstmpl,idrstmpl
+      integer,intent(out) :: ierr
+      real,pointer,dimension(:) :: fld
+
+
+      ierr=0
+      nullify(fld)
+
+      call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+      iofst=iofst+32    
+      iofst=iofst+8     ! skip section number
+
+      ipos=(iofst/8)+1
+      istat=0
+      allocate(fld(ndpts),stat=istat)
+      if (istat.ne.0) then
+         ierr=6
+         return
+      endif
+
+      if (idrsnum.eq.0) then
+        call simunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld)
+      elseif (idrsnum.eq.2.or.idrsnum.eq.3) then
+        call comunpack(cgrib(ipos),lensec-5,lensec,idrsnum,idrstmpl,
+     &                 ndpts,fld,ier)
+        if ( ier .NE. 0 ) then
+           ierr=7
+           return
+        endif
+      elseif (idrsnum.eq.50) then      !  Spectral simple
+        call simunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts-1,
+     &                 fld(2))
+        ieee=idrstmpl(5)
+        call rdieee(ieee,fld(1),1)
+      elseif (idrsnum.eq.51) then      !  Spectral complex
+        if (igdsnum.ge.50.AND.igdsnum.le.53) then
+          call specunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,
+     &                    igdstmpl(1),igdstmpl(2),igdstmpl(3),fld)
+        else
+          print *,'gf_unpack7: Cannot use GDT 3.',igdsnum,
+     &            ' to unpack Data Section 5.51.'
+          ierr=5
+          nullify(fld)
+          return
+        endif
+#ifdef USE_JPEG2000
+      elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then
+        call jpcunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld)
+#endif  /* USE_JPEG2000 */
+#ifdef USE_PNG
+      elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then
+        call pngunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld)
+#endif  /* USE_PNG */
+      else
+        print *,'gf_unpack7: Data Representation Template ',idrsnum,
+     &          ' not yet implemented.'
+        ierr=4
+        nullify(fld)
+        return
+      endif
+
+      iofst=iofst+(8*lensec)
+      
+      return    ! End of Section 7 processing
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/grib2.doc b/wrfv2_fire/external/io_grib2/g2lib/grib2.doc
new file mode 100644
index 00000000..20cedddf
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/grib2.doc
@@ -0,0 +1,1220 @@
+                             GRIB2 USERS GUIDE (FORTRAN 90)
+
+Contents:
+
+- Introduction
+- GRIB2 Encoding Routines
+- GRIB2 Decoding Routines
+- Extracting GRIB2 Fields from a GRIB2 file
+- GRIB2 Tables/Templates
+- GRIB2 Routine Docblocks
+
+===============================================================================
+ 
+                                Introduction
+
+This document briefly describes the routines available for encoding/decoding
+GRIB Edition 2 (GRIB2) messages.  A basic familiarity with GRIB is assumed.
+
+A GRIB Edition 2 message is a machine independent format for storing
+one or more gridded data fields.  Each GRIB2 message consists of the 
+following sections:
+
+SECTION 0 - Indicator Section
+SECTION 1 - Identification Section
+SECTION 2 - (Local Use Section) - optional                           }
+SECTION 3 - Grid Definition Section                     }            }
+SECTION 4 - Product Definition Section    }             }            }(repeated)
+SECTION 5 - Data Representation Section   }             }(repeated)  }
+SECTION 6 - Bit-map Section               }(repeated)   }            }
+SECTION 7 - Data Section                  }             }            }
+SECTION 8 - End Section                   }             }            }
+
+Sequences of GRIB sections 2 to 7, 3 to 7, or sections 4 to 7 may be repeated
+within a single GRIB message.  All sections within such repeated sequences
+must be present and shall appear in the numerical order noted above.
+Unrepeated sections remain in effect until redefined.
+
+The above overview was taken from WMO's FM 92-XII GRIB description
+of the experimental GRIB Edition 2 form.
+
+===============================================================================
+
+                       GRIB2 Encoding Routines
+
+Since a GRIB2 message can contain gridded fields for many parameters on
+a number of different grids, several routines are used to encode a message.
+This should give users more flexibility in how to organize data
+within one or more GRIB2 messages.
+
+To start a new GRIB2 message, call subroutine GRIBCREATE.  GRIBCREATE 
+encodes Sections 0 and 1 at the beginning of the message.  This routine 
+must be used to create each message.
+
+Subroutine ADDLOCAL can be used to add a Local Use Section ( Section 2 ).
+Note that section is optional and need not appear in a GRIB2 message.
+
+Subroutine ADDGRID is used to encode a grid definition into Section 3.
+This grid definition defines the geometry of the the data values in the
+fields that follow it.  ADDGRID can be called again to change the grid 
+definition describing subsequent data fields.
+
+Each data field is added to the GRIB2 message using routine ADDFIELD,
+which adds Sections 4, 5, 6, and 7 to the message.
+
+After all desired data fields have been added to the GRIB2 message, a
+call to routine GRIBEND is needed to add the final section 8 to the
+message and to update the length of the message.  A call to GRIBEND
+is required for each GRIB2 message.
+
+Please see the "GRIB2 Routine Docblocks" section below for subroutine
+argument usage for the routines mentioned above.
+
+===============================================================================
+
+                      GRIB2 Decoding Routines
+
+Subroutine GB_INFO can be used to find out how many Local Use sections
+and data fields are contained in a given GRIB2 message.  In addition,
+this routine also returns the number of octets of the largest Local Use 
+section in the message.  This value can be used to ensure that the 
+output array of subroutine GETLOCAL ( described below ) is dimensioned
+large enough.
+
+Subroutine GETLOCAL will return the requested occurrence of Section 2
+from a given GRIB2 message.  
+
+GF_GETFLD can be used to get all information pertaining to the nth 
+data field in the message.  The subroutine returns all the unpacked values
+for each Section and Template in a Fortran 90 derived type gribfield,
+which is defined in module GRIB_MOD.  An option exists that lets the
+user decide if the subroutine should unpack the Bit-map ( if
+applicable ) and the data values or just return the field description
+information.
+Note that derived type gribfield contains pointers to dynamically
+allocated space that holds the contents of all arrays, and users are encouraged 
+to free up this memory, when it is no longer needed, by an explicit call
+to subroutine GF_FREE.
+
+Please see the "GRIB2 Routine Docblocks" section below for subroutine
+argument usage for the routines mentioned above.
+
+===============================================================================
+
+                Extracting GRIB2 Fields from a GRIB2 file
+
+Subroutine GETGB2 can be used to extract a specified field from a file
+containing many GRIB2 messages.  GETGB2 searches an index to find the 
+location of the user specified field.  The index can be supplied from a
+seperate GRIB2 index file, or it can be generated internally.
+
+The GRIB2 file ( and the index file, if supplied ) must be opened with
+a call to subroutine BAOPEN prior to the call to GETGB2.
+
+The decoded information for the selected GRIB field is returned in a 
+derived type variable, gfld.  Gfld is of type gribfield, which is defined
+in module grib_mod, so users of this routine will need to include
+the line "USE GRIB_MOD" in their calling routine.  Each component of the
+gribfield type is described in the OUTPUT ARGUMENT LIST in the docblock
+for subroutine GETGB2 below.
+
+Note that derived type gribfield contains pointers to many arrays of data.  
+The memory for these arrays is allocated when the values in the arrays 
+are set, to help minimize problems with array overloading.  Because of this,
+users are encouraged to free up this memory, when it is no longer
+needed, by an explicit call to subroutine GF_FREE.
+
+Example usage:
+
+      use grib_mod
+      type(gribfield) :: gfld
+      integer,dimension(200) :: jids,jpdt,jgdt
+      logical :: unpack=.true.
+      ifile=10
+  ! Open GRIB2 file 
+      call baopenr(ifile,"filename",iret)
+      .
+  ! Set GRIB2 field identification values to search for
+      jdisc=
+      jids(?)=
+      jpdtn=
+      jpdt(?)=
+      jgdtn=
+      jgdt(?)=
+
+  ! Get field from file
+      call getgb2(ifile,0,j,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt,
+     &            unpack,j,gfld,iret)
+
+  ! Process field ...
+      firstval=gfld%fld(1)
+      lastval=gfld%fld(gfld%ndpts)
+      fldmax=maxval(gfld%fld)
+      fldmin=minval(gfld%fld)
+      
+  ! Free memory when done with field
+      call gf_free(gfld)
+
+      stop
+      end
+      
+Please see the "GRIB2 Routine Docblocks" section below for subroutine
+argument usage for the routines mentioned above.
+
+===============================================================================
+
+                         GRIB2 Tables/Templates
+
+WMO's GRIB2 specification "FM 92-XII GRIB - General Regularly-distributed
+Information in Binary Form" contains descriptions of each template
+and code table information.  This document can be found at
+http://www.wmo.ch/web/www/WMOCodes.html
+(PDF and MSWord formats are available)
+
+MDL has made an HTML version of the document available at
+http://www.nws.noaa.gov/tdl/iwt/grib2/frameset_grib2.htm.
+
+===============================================================================
+
+                       GRIB2 Routine Docblocks
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gribcreate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-04-28
+!
+! ABSTRACT: This subroutine initializes a new GRIB2 message and packs
+!   GRIB2 sections 0 (Indicator Section) and 1 (Identification Section).
+!   This routine is used with routines "addlocal", "addgrid", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!   Also, a call to gribend is required to complete GRIB2 message
+!   after all fields have been added.
+!
+! PROGRAM HISTORY LOG:
+! 2000-04-28  Gilbert
+!
+! USAGE:    CALL gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     listsec0 - Contains information needed for GRIB Indicator Section 0.
+!                Must be dimensioned >= 2.
+!                listsec0(1)=Discipline-GRIB Master Table Number
+!                            (see Code Table 0.0)
+!                listsec0(2)=GRIB Edition Number (currently 2)
+!     listsec1 - Contains information needed for GRIB Identification Section 1.
+!                Must be dimensioned >= 13.
+!                listsec1(1)=Id of orginating centre (Common Code Table C-1)
+!                listsec1(2)=Id of orginating sub-centre (local table)
+!                listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0)
+!                listsec1(4)=GRIB Local Tables Version Number (Code Table 1.1)
+!                listsec1(5)=Significance of Reference Time (Code Table 1.2)
+!                listsec1(6)=Reference Time - Year (4 digits)
+!                listsec1(7)=Reference Time - Month
+!                listsec1(8)=Reference Time - Day
+!                listsec1(9)=Reference Time - Hour
+!                listsec1(10)=Reference Time - Minute
+!                listsec1(11)=Reference Time - Second
+!                listsec1(12)=Production status of data (Code Table 1.3)
+!                listsec1(13)=Type of processed data (Code Table 1.4)
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Tried to use for version other than GRIB Edition 2
+!
+! REMARKS: This routine is intended for use with routines "addlocal", 
+!          "addgrid", "addfield", and "gribend" to create a complete 
+!          GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addlocal 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-01
+!
+! ABSTRACT: This subroutine adds a Local Use Section (Section 2) to 
+!   a GRIB2 message.
+!   This routine is used with routines "gribcreate", "addgrid", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-01  Gilbert
+!
+! USAGE:    CALL addlocal(cgrib,lcgrib,csec2,lcsec2,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     csec2    - Character array containing information to be added to
+!                Section 2.
+!     lcsec2   - Number of bytes of character array csec2 to be added to
+!                Section 2.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 1 or 7.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addgrid 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-01
+!
+! ABSTRACT: This subroutine packs up a Grid Definition Section (Section 3) 
+!   and adds it to a GRIB2 message.
+!   This routine is used with routines "gribcreate", "addlocal", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-01  Gilbert
+!
+! USAGE:    CALL addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,
+!                        ideflist,idefnum,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     igds     - Contains information needed for GRIB Grid Definition Section 3.
+!                Must be dimensioned >= 5.
+!                igds(1)=Source of grid definition (see Code Table 3.0)
+!                igds(2)=Number of grid points in the defined grid.
+!                igds(3)=Number of octets needed for each 
+!                            additional grid points definition.  
+!                            Used to define number of
+!                            points in each row ( or column ) for
+!                            non-regular grids.  
+!                            = 0, if using regular grid.
+!                igds(4)=Interpretation of list for optional points 
+!                            definition.  (Code Table 3.11)
+!                igds(5)=Grid Definition Template Number (Code Table 3.1)
+!     igdstmpl - Contains the data values for the specified Grid Definition
+!                Template ( NN=igds(5) ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Grid
+!                Defintion Template 3.NN
+!   igdstmplen - Max dimension of igdstmpl()
+!     ideflist - (Used if igds(3) .ne. 0)  This array contains the
+!                number of grid points contained in each row ( or column )
+!      idefnum - (Used if igds(3) .ne. 0)  The number of entries
+!                in array ideflist.  i.e. number of rows ( or columns )
+!                for which optional grid points are defined.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 1, 2 or 7.
+!                5 = Could not find requested Grid Definition Template.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    addfield 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-02
+!
+! ABSTRACT: This subroutine packs up Sections 4 through 7 for a given field
+!   and adds them to a GRIB2 message.  They are Product Definition Section,
+!   Data Representation Section, Bit-Map Section and Data Section, 
+!   respectively.
+!   This routine is used with routines "gribcreate", "addlocal", "addgrid",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!   Also, subroutine addgrid must be called after gribcreate and
+!   before this routine to add the appropriate grid description to
+!   the GRIB2 message.   Also, a call to gribend is required to complete 
+!   GRIB2 message after all fields have been added.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-02  Gilbert
+! 2002-12-17  Gilbert  - Added support for new templates using
+!                        PNG and JPEG2000 algorithms/templates.
+! 2004-06-22  Gilbert  - Added check to determine if packing algorithm failed.
+!
+! USAGE:    CALL addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen,
+!                         coordlist,numcoord,idrsnum,idrstmpl,
+!                         idrstmplen,fld,ngrdpts,ibmap,bmap,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
+!     ipdstmpl - Contains the data values for the specified Product Definition
+!                Template ( N=ipdsnum ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Product
+!                Defintion Template 4.N
+!   ipdstmplen - Max dimension of ipdstmpl()
+!     coordlist- Array containg floating point values intended to document
+!                the vertical discretisation associated to model data
+!                on hybrid coordinate vertical levels.
+!     numcoord - number of values in array coordlist.
+!     idrsnum  - Data Representation Template Number ( see Code Table 5.0 )
+!     idrstmpl - Contains the data values for the specified Data Representation
+!                Template ( N=idrsnum ).  Each element of this integer 
+!                array contains an entry (in the order specified) of Data
+!                Representation Template 5.N
+!                Note that some values in this template (eg. reference
+!                values, number of bits, etc...) may be changed by the
+!                data packing algorithms.
+!                Use this to specify scaling factors and order of
+!                spatial differencing, if desired.
+!   idrstmplen - Max dimension of idrstmpl()
+!     fld()    - Array of data points to pack.
+!     ngrdpts  - Number of data points in grid.
+!                i.e.  size of fld and bmap.
+!     ibmap    - Bitmap indicator ( see Code Table 6.0 )
+!                0 = bitmap applies and is included in Section 6.
+!                1-253 = Predefined bitmap applies
+!                254 = Previously defined bitmap applies to this field
+!                255 = Bit map does not apply to this product.
+!     bmap()   - Logical*1 array containing bitmap to be added. 
+!                ( if ibmap=0 or ibmap=254)
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  Cannot add new section.
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 3 or 7.
+!                5 = Could not find requested Product Definition Template.
+!                6 = Section 3 (GDS) not previously defined in message
+!                7 = Tried to use unsupported Data Representationi Template
+!                8 = Specified use of a previously defined bitmap, but one
+!                    does not exist in the GRIB message.
+!                9 = GDT of one of 5.50 through 5.53 required to pack
+!                    using DRT 5.51
+!               10 = Error packing data field.
+!
+! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow
+!          Section 1 or Section 7 in a GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gribend 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-02
+!
+! ABSTRACT: This subroutine finalizes a GRIB message after all grids
+!   and fields have been added.  It adds the End Section ( "7777" )
+!   to the end of the GRIB message and calculates the length and stores
+!   it in the appropriate place in Section 0.
+!   This routine is used with routines "gribcreate", "addlocal", "addgrid",
+!   and "addfield" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-02  Gilbert
+!
+! USAGE:    CALL gribend(cgrib,lcgrib,lengrib,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     lengrib  - Length of the final GRIB2 message in octets (bytes)
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 7.
+!
+! REMARKS: This routine is intended for use with routines "gribcreate", 
+!          "addlocal", "addgrid", and "addfield" to create a complete 
+!          GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gb_info 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-25
+!
+! ABSTRACT: This subroutine searches through a GRIB2 message and
+!   returns the number of gridded fields found in the message and
+!   the number (and maximum size) of Local Use Sections.
+!   Also various checks  are performed
+!   to see if the message is a valid GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-25  Gilbert
+!
+! USAGE:    CALL gb_info(cgrib,lcgrib,listsec0,listsec1,
+!     &                    numfields,numlocal,maxlocal,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message in array cgrib.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     listsec0 - Contains information decoded from GRIB Indicator Section 0.
+!                Must be dimensioned >= 2.
+!                listsec0(1)=Discipline-GRIB Master Table Number
+!                            (see Code Table 0.0)
+!                listsec0(2)=GRIB Edition Number (currently 2)
+!                listsec0(3)=Length of GRIB message
+!     listsec1 - Contains information read from GRIB Identification Section 1.
+!                Must be dimensioned >= 13.
+!                listsec1(1)=Id of orginating centre (Common Code Table C-1)
+!                listsec1(2)=Id of orginating sub-centre (local table)
+!                listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0)
+!                listsec1(4)=GRIB Local Tables Version Number 
+!                listsec1(5)=Significance of Reference Time (Code Table 1.1)
+!                listsec1(6)=Reference Time - Year (4 digits)
+!                listsec1(7)=Reference Time - Month
+!                listsec1(8)=Reference Time - Day
+!                listsec1(9)=Reference Time - Hour
+!                listsec1(10)=Reference Time - Minute
+!                listsec1(11)=Reference Time - Second
+!                listsec1(12)=Production status of data (Code Table 1.2)
+!                listsec1(13)=Type of processed data (Code Table 1.3)
+!     numfields- The number of gridded fields found in the GRIB message.
+!     numlocal - The number of Local Use Sections ( Section 2 ) found in 
+!                the GRIB message.
+!     maxlocal-  The size of the largest Local Use Section ( Section 2 ).
+!                Can be used to ensure that the return array passed
+!                to subroutine getlocal is dimensioned large enough.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = Could not find Section 1, where expected.
+!                4 = End string "7777" found, but not where expected.
+!                5 = End string "7777" not found at end of message.
+!                6 = Invalid section number found.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getlocal 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-25
+!
+! ABSTRACT: This subroutine returns the contents of Section 2 ( Local 
+!   Use Section ) from a GRIB2 message.  Since there can be multiple
+!   occurrences of Section 2 within a GRIB message, the calling routine
+!   indicates which occurrence is being requested with the localnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-25  Gilbert
+!
+! USAGE:    CALL getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message in array cgrib.
+!     localnum - The nth occurrence of Section 2 requested.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     csec2    - Character array containing information read from 
+!                Section 2.
+!                The dimension of this array can be obtained in advance
+!                from argument maxlocal, which is returned from subroutine 
+!                gb_info.
+!     lcsec2   - Number of bytes of character array csec2 read from
+!                Section 2.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The section 2 request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                5 = End string "7777" not found at end of message.
+!                6 = GRIB message did not contain the requested number of
+!                    Local Use Sections.
+!
+! REMARKS: Note that subroutine gribinfo can be used to first determine
+!          how many Local Use sections exist in a given GRIB message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_getfld 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine returns the Grid Definition, Product Definition,
+!   Bit-map ( if applicable ), and the unpacked data for a given data
+!   field.  All of the information returned is stored in a derived
+!   type variable, gfld.  Gfld is of type gribfield, which is defined
+!   in module grib_mod, so users of this routine will need to include
+!   the line "USE GRIB_MOD" in their calling routine.  Each component of the 
+!   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+!
+!   Since there can be multiple data fields packed into a GRIB2
+!   message, the calling routine indicates which field is being requested
+!   with the ifldnum argument.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+! 2002-01-24  Gilbert  - Changed to pass back derived type gribfield
+!                        variable through argument list, instead of
+!                        having many different arguments.
+!
+! USAGE:    CALL gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message array cgrib.
+!     ifldnum  - Specifies which field in the GRIB2 message to return.
+!     unpack   - Logical value indicating whether to unpack bitmap/data
+!                .true. = unpack bitmap and data values
+!                .false. = do not unpack bitmap and data values
+!     expand   - Boolean value indicating whether the data points should be
+!                expanded to the correspond grid, if a bit-map is present.
+!                1 = if possible, expand data field to grid, inserting zero
+!                    values at gridpoints that are bitmapped out.
+!                    (SEE REMARKS2)
+!                0 = do not expand data field, leaving it an array of
+!                    consecutive data points for each "1" in the bitmap.
+!                This argument is ignored if unpack == 0 OR if the
+!                returned field does not contain a bit-map.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!            ( NOTE: See Remarks Section )
+!        gfld%version = GRIB edition number ( currently 2 )
+!        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+!        gfld%idsect() = Contains the entries in the Identification
+!                        Section ( Section 1 )
+!                        This element is actually a pointer to an array
+!                        that holds the data.
+!            gfld%idsect(1)  = Identification of originating Centre 
+!                                    ( see Common Code Table C-1 )
+!                             7 - US National Weather Service
+!            gfld%idsect(2)  = Identification of originating Sub-centre
+!            gfld%idsect(3)  = GRIB Master Tables Version Number
+!                                    ( see Code Table 1.0 )
+!                             0 - Experimental
+!                             1 - Initial operational version number
+!            gfld%idsect(4)  = GRIB Local Tables Version Number
+!                                    ( see Code Table 1.1 )
+!                             0     - Local tables not used
+!                             1-254 - Number of local tables version used
+!            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+!                             0 - Analysis
+!                             1 - Start of forecast
+!                             2 - Verifying time of forecast
+!                             3 - Observation time
+!            gfld%idsect(6)  = Year ( 4 digits )
+!            gfld%idsect(7)  = Month
+!            gfld%idsect(8)  = Day
+!            gfld%idsect(9)  = Hour
+!            gfld%idsect(10)  = Minute
+!            gfld%idsect(11)  = Second
+!            gfld%idsect(12)  = Production status of processed data
+!                                    ( see Code Table 1.3 )
+!                              0 - Operational products
+!                              1 - Operational test products
+!                              2 - Research products
+!                              3 - Re-analysis products
+!            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+!                              0  - Analysis products
+!                              1  - Forecast products
+!                              2  - Analysis and forecast products
+!                              3  - Control forecast products
+!                              4  - Perturbed forecast products
+!                              5  - Control and perturbed forecast products
+!                              6  - Processed satellite observations
+!                              7  - Processed radar observations
+!        gfld%idsectlen = Number of elements in gfld%idsect().
+!        gfld%ifldnum = field number within GRIB message
+!        gfld%griddef = Source of grid definition (see Code Table 3.0)
+!                      0 - Specified in Code table 3.1
+!                      1 - Predetermined grid Defined by originating centre
+!        gfld%ngrdpts = Number of grid points in the defined grid.
+!        gfld%numoct_opt = Number of octets needed for each 
+!                          additional grid points definition.  
+!                          Used to define number of
+!                          points in each row ( or column ) for
+!                          non-regular grids.  
+!                          = 0, if using regular grid.
+!        gfld%interp_opt = Interpretation of list for optional points 
+!                          definition.  (Code Table 3.11)
+!        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+!        gfld%igdtmpl() = Contains the data values for the specified Grid 
+!                         Definition Template ( NN=gfld%igdtnum ).  Each 
+!                         element of this integer array contains an entry (in 
+!                         the order specified) of Grid Defintion Template 3.NN
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+!                       entries in Grid Defintion Template 3.NN  
+!                       ( NN=gfld%igdtnum ).
+!        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array 
+!                          contains the number of grid points contained in 
+!                          each row ( or column ).  (part of Section 3)
+!                          This element is actually a pointer to an array
+!                          that holds the data.  This pointer is nullified
+!                          if gfld%numoct_opt=0.
+!        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+!                       in array ideflist.  i.e. number of rows ( or columns )
+!                       for which optional grid points are defined.  This value
+!                       is set to zero, if gfld%numoct_opt=0.
+!        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+!        gfld%ipdtmpl() = Contains the data values for the specified Product 
+!                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+!                         of this integer array contains an entry (in the 
+!                         order specified) of Product Defintion Template 4.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+!                       entries in Product Defintion Template 4.N  
+!                       ( N=gfdl%ipdtnum ).
+!        gfld%coord_list() = Real array containing floating point values 
+!                            intended to document the vertical discretisation
+!                            associated to model data on hybrid coordinate
+!                            vertical levels.  (part of Section 4)
+!                            This element is actually a pointer to an array
+!                            that holds the data.
+!        gfld%num_coord = number of values in array gfld%coord_list().
+!        gfld%ndpts = Number of data points unpacked and returned.
+!        gfld%idrtnum = Data Representation Template Number 
+!                       ( see Code Table 5.0)
+!        gfld%idrtmpl() = Contains the data values for the specified Data 
+!                         Representation Template ( N=gfld%idrtnum ).  Each 
+!                         element of this integer array contains an entry 
+!                         (in the order specified) of Product Defintion 
+!                         Template 5.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number 
+!                       of entries in Data Representation Template 5.N 
+!                       ( N=gfld%idrtnum ).
+!        gfld%unpacked = logical value indicating whether the bitmap and
+!                        data values were unpacked.  If false, 
+!                        gfld%bmap and gfld%fld pointers are nullified.
+!        gfld%expanded = Logical value indicating whether the data field
+!                         was expanded to the grid in the case where a
+!                         bit-map is present.  If true, the data points in
+!                         gfld%fld match the grid points and zeros were
+!                         inserted at grid points where data was bit-mapped
+!                         out.  If false, the data values in gfld%fld were
+!                         not expanded to the grid and are just a consecutive
+!                         array of data points corresponding to each value of
+!                         "1" in gfld%bmap.
+!        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+!                     0 = bitmap applies and is included in Section 6.
+!                     1-253 = Predefined bitmap applies
+!                     254 = Previously defined bitmap applies to this field
+!                     255 = Bit map does not apply to this product.
+!        gfld%bmap() = Logical*1 array containing decoded bitmap, 
+!                      if ibmap=0 or ibap=254.  Otherwise nullified.
+!                      This element is actually a pointer to an array
+!                      that holds the data.
+!        gfld%fld() = Array of gfld%ndpts unpacked data points.
+!                     This element is actually a pointer to an array
+!                     that holds the data.
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = The data field request number was not positive.
+!                4 = End string "7777" found, but not where expected.
+!                6 = GRIB message did not contain the requested number of
+!                    data fields.
+!                7 = End string "7777" not found at end of message.
+!                8 = Unrecognized Section encountered.
+!                9 = Data Representation Template 5.NN not yet implemented.
+!               15 = Error unpacking Section 1.
+!               10 = Error unpacking Section 3.
+!               11 = Error unpacking Section 4.
+!               12 = Error unpacking Section 5.
+!               13 = Error unpacking Section 6.
+!               14 = Error unpacking Section 7.
+!
+! REMARKS: Note that derived type gribfield contains pointers to many
+!          arrays of data.  The memory for these arrays is allocated
+!          when the values in the arrays are set, to help minimize
+!          problems with array overloading.  Because of this users
+!          are encouraged to free up this memory, when it is no longer
+!          needed, by an explicit call to subroutine gf_free.
+!          ( i.e.   CALL GF_FREE(GFLD) )
+!
+!          Subroutine gb_info can be used to first determine
+!          how many data fields exist in a given GRIB message.
+!
+! REMARKS2: It may not always be possible to expand a bit-mapped data field.
+!           If a pre-defined bit-map is used and not included in the GRIB2
+!           message itself, this routine would not have the necessary
+!           information to expand the data.  In this case, gfld%expanded would
+!           would be set to 0 (false), regardless of the value of input
+!           argument expand.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gf_free 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
+!
+! ABSTRACT: This subroutine frees up memory that was used to store
+!   array values in derived type gribfield.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-26  Gilbert
+!
+! USAGE:    CALL gf_free(gfld)
+!   INPUT ARGUMENT LIST:
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!
+!   OUTPUT ARGUMENT LIST:      
+!     gfld - derived type gribfield ( defined in module grib_mod )
+!        gfld%version = GRIB edition number
+!        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+!        gfld%idsect() = Contains the entries in the Identification
+!                        Section ( Section 1 )
+!                        This element is actually a pointer to an array
+!                        that holds the data.
+!            gfld%idsect(1)  = Identification of originating Centre
+!                                    ( see Common Code Table C-1 )
+!            gfld%idsect(2)  = Identification of originating Sub-centre
+!            gfld%idsect(3)  = GRIB Master Tables Version Number
+!                                    ( see Code Table 1.0 )
+!            gfld%idsect(4)  = GRIB Local Tables Version Number
+!                                    ( see Code Table 1.1 )
+!            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+!            gfld%idsect(6)  = Year ( 4 digits )
+!            gfld%idsect(7)  = Month
+!            gfld%idsect(8)  = Day
+!            gfld%idsect(9)  = Hour
+!            gfld%idsect(10)  = Minute
+!            gfld%idsect(11)  = Second
+!            gfld%idsect(12)  = Production status of processed data
+!                                    ( see Code Table 1.3 )
+!            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+!        gfld%idsectlen = Number of elements in gfld%idsect().
+!        gfld%ifldnum = field number within GRIB message
+!        gfld%griddef = Source of grid definition (see Code Table 3.0)
+!        gfld%ngrdpts = Number of grid points in the defined grid.
+!        gfld%numoct_opt = Number of octets needed for each 
+!                          additional grid points definition.  
+!                          Used to define number of
+!                          points in each row ( or column ) for
+!                          non-regular grids.  
+!                          = 0, if using regular grid.
+!        gfld%interp_opt = Interpretation of list for optional points 
+!                          definition.  (Code Table 3.11)
+!        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+!        gfld%igdtmpl() = Contains the data values for the specified Grid 
+!                         Definition Template ( NN=gfld%igdtnum ).  Each 
+!                         element of this integer array contains an entry (in 
+!                         the order specified) of Grid Defintion Template 3.NN
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+!                       entries in Grid Defintion Template 3.NN  
+!                       ( NN=gfld%igdtnum ).
+!        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array 
+!                          contains the number of grid points contained in 
+!                          each row ( or column ).  (part of Section 3)
+!                          This element is actually a pointer to an array
+!                          that holds the data.  This pointer is nullified
+!                          if gfld%numoct_opt=0.
+!        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+!                       in array ideflist.  i.e. number of rows ( or columns )
+!                       for which optional grid points are defined.  This value
+!                       is set to zero, if gfld%numoct_opt=0.
+!        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+!        gfld%ipdtmpl() = Contains the data values for the specified Product 
+!                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+!                         of this integer array contains an entry (in the 
+!                         order specified) of Product Defintion Template 4.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+!                       entries in Product Defintion Template 4.N  
+!                       ( N=gfdl%ipdtnum ).
+!        gfld%coord_list() = Real array containing floating point values 
+!                            intended to document the vertical discretisation
+!                            associated to model data on hybrid coordinate
+!                            vertical levels.  (part of Section 4)
+!                            This element is actually a pointer to an array
+!                            that holds the data.
+!        gfld%num_coord = number of values in array gfld%coord_list().
+!        gfld%ndpts = Number of data points unpacked and returned.
+!        gfld%idrtnum = Data Representation Template Number 
+!                       ( see Code Table 5.0)
+!        gfld%idrtmpl() = Contains the data values for the specified Data 
+!                         Representation Template ( N=gfld%idrtnum ).  Each 
+!                         element of this integer array contains an entry 
+!                         (in the order specified) of Product Defintion 
+!                         Template 5.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number 
+!                       of entries in Data Representation Template 5.N 
+!                       ( N=gfld%idrtnum ).
+!        gfld%unpacked = logical value indicating whether the bitmap and
+!                        data values were unpacked.  If false, gfld%ndpts
+!                        is set to zero, and gfld%bmap and gfld%fld 
+!                        pointers are nullified.
+!        gfld%expanded = Logical value indicating whether the data field
+!                         was expanded to the grid in the case where a
+!                         bit-map is present.  If true, the data points in
+!                         gfld%fld match the grid points and zeros were
+!                         inserted at grid points where data was bit-mapped
+!                         out.  If false, the data values in gfld%fld were
+!                         not expanded to the grid and are just a consecutive
+!                         array of data points corresponding to each value of
+!                         "1" in gfld%bmap.
+!        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+!                     0 = bitmap applies and is included in Section 6.
+!                     1-253 = Predefined bitmap applies
+!                     254 = Previously defined bitmap applies to this field
+!                     255 = Bit map does not apply to this product.
+!        gfld%bmap() - Logical*1 array containing decoded bitmap, 
+!                      if ibmap=0 or ibap=254.  Otherwise nullified.
+!                      This element is actually a pointer to an array
+!                      that holds the data.
+!        gfld%fld() = Array of gfld%ndpts unpacked data points.
+!                     This element is actually a pointer to an array
+!                     that holds the data.
+!
+! REMARKS: 
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+
+
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: GETGB2         FINDS AND UNPACKS A GRIB MESSAGE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
+C
+C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE.
+C   READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
+C   TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
+C   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED.
+C   THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP
+C   AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
+C   PRODUCT DEFINTION SECTION PARAMETERS.  (A REQUESTED PARAMETER
+C   OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
+C   IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE
+C   GRIB FILE AND UNPACKED.  ITS NUMBER IS RETURNED ALONG WITH
+C   THE ASSOCIATED UNPACKED PARAMETERS.  THE BITMAP (IF ANY),
+C   AND THE DATA VALUES ARE UNPACKED ONLY IF ARGUMENT "UNPACK" IS SET TO
+C   TRUE.  IF THE GRIB FIELD IS NOT FOUND, THEN THE
+C   RETURN CODE WILL BE NONZERO.
+C
+C   The decoded information for the selected GRIB field
+C   is returned in a derived type variable, gfld.
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the OUTPUT ARGUMENT LIST section below.
+C
+C PROGRAM HISTORY LOG:
+C   94-04-01  IREDELL
+C   95-10-31  IREDELL     MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
+C                         AND ALLOWED FOR UNSPECIFIED INDEX FILE
+C 2002-01-11  GILBERT     MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2
+C
+C USAGE:    CALL GETGB2(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
+C    &                  UNPACK,K,GFLD,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING 
+C                  THIS ROUTINE.
+C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
+C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE 
+C                  CALLING THIS ROUTINE.
+C                  >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T
+C                       ALREADY EXIST.
+C                  =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX
+C                       DOESN"T ALREADY EXIST.
+C                  <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI).
+C                  =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB.
+C     J            INTEGER NUMBER OF FIELDS TO SKIP
+C                  (=0 TO SEARCH FROM BEGINNING)
+C     JDISC        GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
+C                  ( IF = -1, ACCEPT ANY DISCIPLINE)
+C                  ( SEE CODE TABLE 0.0 )
+C                  0 - Meteorological products
+C                  1 - Hydrological products
+C                  2 - Land surface products
+C                  3 - Space products
+C                  10 - Oceanographic products
+C     JIDS()       INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
+C                  (=-9999 FOR WILDCARD)
+C            JIDS(1)   = IDENTIFICATION OF ORIGINATING CENTRE
+C                         ( SEE COMMON CODE TABLE C-1 )
+C            JIDS(2)   = IDENTIFICATION OF ORIGINATING SUB-CENTRE
+C            JIDS(3)   = GRIB MASTER TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.0 )
+C                       0 - Experimental
+C                       1 - Initial operational version number
+C            JIDS(4)   = GRIB LOCAL TABLES VERSION NUMBER
+C                         ( SEE CODE TABLE 1.1 )
+C                       0     - Local tables not used
+C                       1-254 - Number of local tables version used
+C            JIDS(5)   = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
+C                       0 - Analysis
+C                       1 - Start of forecast
+C                       2 - Verifying time of forecast
+C                       3 - Observation time
+C            JIDS(6)   = YEAR ( 4 DIGITS )
+C            JIDS(7)   = MONTH
+C            JIDS(8)   = DAY
+C            JIDS(9)   = HOUR
+C            JIDS(10)  = MINUTE
+C            JIDS(11)  = SECOND
+C            JIDS(12)  = PRODUCTION STATUS OF PROCESSED DATA
+C                         ( SEE CODE TABLE 1.3 )
+C                       0 - Operational products
+C                       1 - Operational test products
+C                       2 - Research products
+C                       3 - Re-analysis products
+C            JIDS(13)  = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
+C                       0  - Analysis products
+C                       1  - Forecast products
+C                       2  - Analysis and forecast products
+C                       3  - Control forecast products
+C                       4  - Perturbed forecast products
+C                       5  - Control and perturbed forecast products
+C                       6  - Processed satellite observations
+C                       7  - Processed radar observations
+C     JPDTN        INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
+C                  ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY )
+C     JPDT()       INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
+C                  TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     JGDTN        INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
+C                  ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY )
+C     JGDT()       INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
+C                  TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
+C                  (=-9999 FOR WILDCARD)
+C     UNPACK       LOGICAL VALUE INDICATING WHETHER TO UNPACK BITMAP/DATA
+C                  .TRUE. = UNPACK BITMAP AND DATA VALUES
+C                  .FALSE. = DO NOT UNPACK BITMAP AND DATA VALUES
+C
+C   OUTPUT ARGUMENTS:
+C     K            INTEGER FIELD NUMBER UNPACKED
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C        gfld%expanded = Logical value indicating whether the data field
+C                         was expanded to the grid in the case where a
+C                         bit-map is present.  If true, the data points in
+C                         gfld%fld match the grid points and zeros were
+C                         inserted at grid points where data was bit-mapped
+C                         out.  If false, the data values in gfld%fld were
+C                         not expanded to the grid and are just a consecutive
+C                         array of data points corresponding to each value of
+C                         "1" in gfld%bmap.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    96     ERROR READING INDEX
+C                    97     ERROR READING GRIB FILE
+C                    99     REQUEST NOT FOUND
+C                    OTHER  GF_GETFLD GRIB2 UNPACKER RETURN CODE
+C
+C SUBPROGRAMS CALLED:
+C   GETIDX         GET INDEX
+C   GETGB2S        SEARCH INDEX RECORDS
+C   GETGB2R        READ AND UNPACK GRIB RECORD
+C   GF_FREE        FREES MEMORY USED BY GFLD  ( SEE REMARKS )
+C
+C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
+C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gribcreate.F b/wrfv2_fire/external/io_grib2/g2lib/gribcreate.F
new file mode 100644
index 00000000..7832a33b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gribcreate.F
@@ -0,0 +1,123 @@
+      subroutine gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gribcreate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-04-28
+!
+! ABSTRACT: This subroutine initializes a new GRIB2 message and packs
+!   GRIB2 sections 0 (Indicator Section) and 1 (Identification Section).
+!   This routine is used with routines "addlocal", "addgrid", "addfield",
+!   and "gribend" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!   Also, a call to gribend is required to complete GRIB2 message
+!   after all fields have been added.
+!
+! PROGRAM HISTORY LOG:
+! 2000-04-28  Gilbert
+!
+! USAGE:    CALL gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!     listsec0 - Contains information needed for GRIB Indicator Section 0.
+!                Must be dimensioned >= 2.
+!                listsec0(1)=Discipline-GRIB Master Table Number
+!                            (see Code Table 0.0)
+!                listsec0(2)=GRIB Edition Number (currently 2)
+!     listsec1 - Contains information needed for GRIB Identification Section 1.
+!                Must be dimensioned >= 13.
+!                listsec1(1)=Id of orginating centre (Common Code Table C-1)
+!                listsec1(2)=Id of orginating sub-centre (local table)
+!                listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0)
+!                listsec1(4)=GRIB Local Tables Version Number (Code Table 1.1)
+!                listsec1(5)=Significance of Reference Time (Code Table 1.2)
+!                listsec1(6)=Reference Time - Year (4 digits)
+!                listsec1(7)=Reference Time - Month
+!                listsec1(8)=Reference Time - Day
+!                listsec1(9)=Reference Time - Hour
+!                listsec1(10)=Reference Time - Minute
+!                listsec1(11)=Reference Time - Second
+!                listsec1(12)=Production status of data (Code Table 1.3)
+!                listsec1(13)=Type of processed data (Code Table 1.4)
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Tried to use for version other than GRIB Edition 2
+!
+! REMARKS: This routine is intended for use with routines "addlocal", 
+!          "addgrid", "addfield", and "gribend" to create a complete 
+!          GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(inout) :: cgrib(lcgrib)
+      integer,intent(in) :: listsec0(*),listsec1(*)
+      integer,intent(in) :: lcgrib
+      integer,intent(out) :: ierr
+      
+      character(len=4),parameter :: grib='GRIB'
+      integer,parameter :: zero=0,one=1
+      integer,parameter :: mapsec1len=13
+      integer,parameter :: 
+     &        mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /)
+      integer lensec0,iofst,ibeg
+
+      ierr=0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'gribcreate: can only code GRIB edition 2.'
+        ierr=1
+        return
+      endif
+!
+!  Pack Section 0 - Indicator Section 
+!  ( except for total length of GRIB message )
+!
+!      cgrib=' '
+      cgrib(1)=grib(1:1)                     ! Beginning of GRIB message
+      cgrib(2)=grib(2:2)   
+      cgrib(3)=grib(3:3)   
+      cgrib(4)=grib(4:4)   
+      call g2lib_sbyte(cgrib,zero,32,16)           ! reserved for future use
+      call g2lib_sbyte(cgrib,listsec0(1),48,8)     ! Discipline
+      call g2lib_sbyte(cgrib,listsec0(2),56,8)     ! GRIB edition number
+      lensec0=16      ! bytes (octets)
+!
+!  Pack Section 1 - Identification Section
+!
+      ibeg=lensec0*8        !   Calculate offset for beginning of section 1
+      iofst=ibeg+32         !   leave space for length of section
+      call g2lib_sbyte(cgrib,one,iofst,8)     ! Store section number ( 1 )
+      iofst=iofst+8
+      !
+      !   Pack up each input value in array listsec1 into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapsec1.
+      !
+      do i=1,mapsec1len
+        nbits=mapsec1(i)*8
+        call g2lib_sbyte(cgrib,listsec1(i),iofst,nbits)
+        iofst=iofst+nbits
+      enddo
+      !
+      !   Calculate length of section 1 and store it in octets
+      !   1-4 of section 1.
+      !
+      lensec1=(iofst-ibeg)/8
+      call g2lib_sbyte(cgrib,lensec1,ibeg,32)
+!
+!  Put current byte total of message into Section 0
+!
+      call g2lib_sbyte(cgrib,zero,64,32)
+      call g2lib_sbyte(cgrib,lensec0+lensec1,96,32)
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gribend.F b/wrfv2_fire/external/io_grib2/g2lib/gribend.F
new file mode 100644
index 00000000..f2b6c3a5
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gribend.F
@@ -0,0 +1,126 @@
+      subroutine gribend(cgrib,lcgrib,lengrib,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gribend 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-02
+!
+! ABSTRACT: This subroutine finalizes a GRIB message after all grids
+!   and fields have been added.  It adds the End Section ( "7777" )
+!   to the end of the GRIB message and calculates the length and stores
+!   it in the appropriate place in Section 0.
+!   This routine is used with routines "gribcreate", "addlocal", "addgrid",
+!   and "addfield" to create a complete GRIB2 message.  Subroutine
+!   gribcreate must be called first to initialize a new GRIB2 message.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-02  Gilbert
+!
+! USAGE:    CALL gribend(cgrib,lcgrib,lengrib,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array to contain the GRIB2 message
+!     lcgrib   - Maximum length (bytes) of array cgrib.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     cgrib    - Character array to contain the GRIB2 message
+!     lengrib  - Length of the final GRIB2 message in octets (bytes)
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = GRIB message was not initialized.  Need to call
+!                    routine gribcreate first.
+!                2 = GRIB message already complete.  
+!                3 = Sum of Section byte counts doesn't add to total byte count.
+!                4 = Previous Section was not 7.
+!
+! REMARKS: This routine is intended for use with routines "gribcreate", 
+!          "addlocal", "addgrid", and "addfield" to create a complete 
+!          GRIB2 message.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(inout) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(out) :: lengrib,ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4):: ctemp
+      integer iofst,ibeg,lencurr,len
+ 
+      ierr=0
+!
+!  Check to see if beginning of GRIB message exists
+!
+      ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4)
+      if ( ctemp.ne.grib ) then
+        print *,'gribend: GRIB not found in given message.'
+        ierr=1
+        return
+      endif
+!
+!  Get current length of GRIB message
+!  
+      call g2lib_gbyte(cgrib,lencurr,96,32)
+!
+!  Check to see if GRIB message is already complete
+!
+!      ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1)
+!     &      //cgrib(lencurr)
+!      if ( ctemp.eq.c7777 ) then
+!        print *,'gribend: GRIB message already complete.'
+!        ierr=2
+!        return
+!      endif
+!
+!  Loop through all current sections of the GRIB message to
+!  find the last section number.
+!
+      len=16    ! Length of Section 0
+      do 
+      !    Get number and length of next section
+        iofst=len*8
+        call g2lib_gbyte(cgrib,ilen,iofst,32)
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)
+        len=len+ilen
+      !    Exit loop if last section reached
+        if ( len.eq.lencurr ) exit
+      !    If byte count for each section doesn't match current
+      !    total length, then there is a problem.
+        if ( len.gt.lencurr ) then
+          print *,'gribend: Section byte counts don''t add to total.'
+          print *,'gribend: Sum of section byte counts = ',len
+          print *,'gribend: Total byte count in Section 0 = ',lencurr
+          ierr=3
+          return
+        endif
+      enddo
+!
+!  Can only add End Section (Section 8) after Section 7.
+!
+      if ( isecnum.ne.7 ) then
+        print *,'gribend: Section 8 can only be added after Section 7.'
+        print *,'gribend: Section ',isecnum,' was the last found in',
+     &          ' given GRIB message.'
+        ierr=4
+        return
+      endif
+!
+!  Add Section 8  - End Section
+!
+      cgrib(lencurr+1:lencurr+4)=c7777
+
+!
+!  Update current byte total of message in Section 0
+!
+      lengrib=lencurr+4
+      call g2lib_sbyte(cgrib,lengrib,96,32)
+
+      return
+      end
+
+
+
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gribinfo.F b/wrfv2_fire/external/io_grib2/g2lib/gribinfo.F
new file mode 100644
index 00000000..68751b18
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gribinfo.F
@@ -0,0 +1,243 @@
+      subroutine gribinfo(cgrib,lcgrib,listsec0,listsec1,
+     &                    numlocal,numfields,maxvals,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    gribinfo 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-25
+!
+! ABSTRACT: This subroutine searches through a GRIB2 message and
+!   returns the number of Local Use Sections and number of gridded
+!   fields found in the message.  It also performs various checks 
+!   to see if the message is a valid GRIB2 message.
+!   Last, a list of safe array dimensions is returned for use in 
+!   allocating return arrays from routines getlocal, gettemplates, and 
+!   getfields.  (See maxvals and REMARKS)
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-25  Gilbert
+!
+! USAGE:    CALL gribinfo(cgrib,lcgrib,listsec0,listsec1,
+!     &                    numlocal,numfields,ierr)
+!   INPUT ARGUMENT LIST:
+!     cgrib    - Character array that contains the GRIB2 message
+!     lcgrib   - Length (in bytes) of GRIB message in array cgrib.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     listsec0 - Contains information decoded from GRIB Indicator Section 0.
+!                Must be dimensioned >= 2.
+!                listsec0(1)=Discipline-GRIB Master Table Number
+!                            (see Code Table 0.0)
+!                listsec0(2)=GRIB Edition Number (currently 2)
+!                listsec0(3)=Length of GRIB message
+!     listsec1 - Contains information read from GRIB Identification Section 1.
+!                Must be dimensioned >= 13.
+!                listsec1(1)=Id of orginating centre (Common Code Table C-1)
+!                listsec1(2)=Id of orginating sub-centre (local table)
+!                listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0)
+!                listsec1(4)=GRIB Local Tables Version Number 
+!                listsec1(5)=Significance of Reference Time (Code Table 1.1)
+!                listsec1(6)=Reference Time - Year (4 digits)
+!                listsec1(7)=Reference Time - Month
+!                listsec1(8)=Reference Time - Day
+!                listsec1(9)=Reference Time - Hour
+!                listsec1(10)=Reference Time - Minute
+!                listsec1(11)=Reference Time - Second
+!                listsec1(12)=Production status of data (Code Table 1.2)
+!                listsec1(13)=Type of processed data (Code Table 1.3)
+!     numlocal - The number of Local Use Sections ( Section 2 ) found in 
+!                the GRIB message.
+!     numfields- The number of gridded fieldse found in the GRIB message.
+!     maxvals()- The maximum number of elements that could be returned
+!                in various arrays from this GRIB2 message. (see REMARKS)
+!                maxvals(1)=max length of local section 2 (for getlocal)
+!                maxvals(2)=max length of GDS Template (for gettemplates 
+!                                                       and getfield)
+!                maxvals(3)=max length of GDS Optional list (for getfield)
+!                maxvals(4)=max length of PDS Template (for gettemplates 
+!                                                       and getfield)
+!                maxvals(5)=max length of PDS Optional list (for getfield)
+!                maxvals(6)=max length of DRS Template (for gettemplates 
+!                                                       and getfield)
+!                maxvals(7)=max number of gridpoints (for getfield)
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Beginning characters "GRIB" not found.
+!                2 = GRIB message is not Edition 2.
+!                3 = Could not find Section 1, where expected.
+!                4 = End string "7777" found, but not where expected.
+!                5 = End string "7777" not found at end of message.
+!
+! REMARKS: Array maxvals contains the maximum possible 
+!          number of values that will be returned in argument arrays
+!          for routines getlocal, gettemplates, and getfields.  
+!          Users can use this info to determine if their arrays are 
+!          dimensioned large enough for the data that may be returned
+!          from the above routines, or to dynamically allocate arrays
+!          with a reasonable size.
+!          NOTE that the actual number of values in these arrays is returned
+!          from the routines and will likely be less than the values 
+!          calculated by this routine.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cgrib(lcgrib)
+      integer,intent(in) :: lcgrib
+      integer,intent(out) :: listsec0(3),listsec1(13),maxvals(7)
+      integer,intent(out) :: numlocal,numfields,ierr
+      
+      character(len=4),parameter :: grib='GRIB',c7777='7777'
+      character(len=4) :: ctemp
+      integer,parameter :: zero=0,one=1
+      integer,parameter :: mapsec1len=13
+      integer,parameter :: 
+     &        mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /)
+      integer iofst,ibeg,istart
+
+      ierr=0
+      numlocal=0
+      numfields=0
+      maxsec2len=1
+      maxgdstmpl=1
+      maxdeflist=1
+      maxpdstmpl=1
+      maxcoordlist=1
+      maxdrstmpl=1
+      maxgridpts=0
+!
+!  Check for beginning of GRIB message in the first 100 bytes
+!
+      istart=0
+      do j=1,100
+        ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
+        if (ctemp.eq.grib ) then
+          istart=j
+          exit
+        endif
+      enddo
+      if (istart.eq.0) then
+        print *,'gribinfo:  Beginning characters GRIB not found.'
+        ierr=1
+        return
+      endif
+!
+!  Unpack Section 0 - Indicator Section 
+!
+      iofst=8*(istart+5)
+      call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
+      iofst=iofst+8
+      call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
+      iofst=iofst+8
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
+      iofst=iofst+32
+      listsec0(3)=lengrib
+      lensec0=16
+      ipos=istart+lensec0
+!
+!  Currently handles only GRIB Edition 2.
+!  
+      if (listsec0(2).ne.2) then
+        print *,'gribinfo: can only decode GRIB edition 2.'
+        ierr=2
+        return
+      endif
+!
+!  Unpack Section 1 - Identification Section
+!
+      call g2lib_gbyte(cgrib,lensec1,iofst,32)        ! Length of Section 1
+      iofst=iofst+32
+      call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Section number ( 1 )
+      iofst=iofst+8
+      if (isecnum.ne.1) then
+        print *,'gribinfo: Could not find section 1.'
+        ierr=3
+        return
+      endif
+      !
+      !   Unpack each input value in array listsec1 into the
+      !   the appropriate number of octets, which are specified in
+      !   corresponding entries in array mapsec1.
+      !
+      do i=1,mapsec1len
+        nbits=mapsec1(i)*8
+        call g2lib_gbyte(cgrib,listsec1(i),iofst,nbits)
+        iofst=iofst+nbits
+      enddo
+      ipos=ipos+lensec1
+!
+!  Loop through the remaining sections keeping track of the 
+!  length of each.  Also count the number of times Section 2
+!  and Section 4 appear.
+!
+      do
+        ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
+        if (ctemp.eq.c7777 ) then
+          ipos=ipos+4
+          if (ipos.ne.(istart+lengrib)) then
+            print *,'gribinfo: "7777" found, but not where expected.'
+            ierr=4
+            return
+          endif
+          exit
+        endif
+        iofst=(ipos-1)*8
+        call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
+        iofst=iofst+32
+        call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
+        iofst=iofst+8
+        ipos=ipos+lensec                 ! Update beginning of section pointer
+        if (ipos.gt.(istart+lengrib)) then
+          print *,'gribinfo: "7777"  not found at end of GRIB message.'
+          ierr=5
+          return
+        endif
+        if (isecnum.eq.2) then     ! Local Section 2
+           !   increment counter for total number of local sections found
+           !   and determine largest Section 2 in message
+           numlocal=numlocal+1
+           lenposs=lensec-5
+           if ( lenposs.gt.maxsec2len ) maxsec2len=lenposs
+        elseif (isecnum.eq.3) then
+           iofst=iofst+8                      ! skip source of grid def.
+           call g2lib_gbyte(cgrib,ngdpts,iofst,32)         ! Get Num of Grid Points
+           iofst=iofst+32
+           call g2lib_gbyte(cgrib,nbyte,iofst,8)      ! Get Num octets for opt. list
+           iofst=iofst+8
+           if (ngdpts.gt.maxgridpts) maxgridpts=ngdpts
+           lenposs=lensec-14
+           if ( lenposs.gt.maxgdstmpl ) maxgdstmpl=lenposs
+           if (nbyte.ne.0) then
+              lenposs=lenposs/nbyte
+              if ( lenposs.gt.maxdeflist ) maxdeflist=lenposs
+           endif
+        elseif (isecnum.eq.4) then
+          numfields=numfields+1
+           call g2lib_gbyte(cgrib,numcoord,iofst,16)      ! Get Num of Coord Values
+           iofst=iofst+16
+           if (numcoord.ne.0) then
+              if (numcoord.gt.maxcoordlist) maxcoordlist=numcoord
+           endif
+           lenposs=lensec-9
+           if ( lenposs.gt.maxpdstmpl ) maxpdstmpl=lenposs
+        elseif (isecnum.eq.5) then
+           lenposs=lensec-11
+           if ( lenposs.gt.maxdrstmpl ) maxdrstmpl=lenposs
+        endif
+        
+      enddo
+
+      maxvals(1)=maxsec2len
+      maxvals(2)=maxgdstmpl
+      maxvals(3)=maxdeflist
+      maxvals(4)=maxpdstmpl
+      maxvals(5)=maxcoordlist
+      maxvals(6)=maxdrstmpl
+      maxvals(7)=maxgridpts
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gribmod.F b/wrfv2_fire/external/io_grib2/g2lib/gribmod.F
new file mode 100644
index 00000000..01cc75f7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gribmod.F
@@ -0,0 +1,187 @@
+      module grib_mod
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    grib_mod 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-01-23
+!
+! ABSTRACT: This Fortran Module contains the declaration
+!   of derived type gribfield.
+!   If variable gfld is declared of type gribfield 
+!   ( i.e. TYPE(GRIBFIELD) :: GFLD ), it would have the following componenets:
+!
+!        gfld%version = GRIB edition number ( currently 2 )
+!        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+!        gfld%idsect() = Contains the entries in the Identification
+!                        Section ( Section 1 )
+!                        This element is actually a pointer to an array
+!                        that holds the data.
+!            gfld%idsect(1)  = Identification of originating Centre
+!                                    ( see Common Code Table C-1 )
+!                             7 - US National Weather Service
+!            gfld%idsect(2)  = Identification of originating Sub-centre
+!            gfld%idsect(3)  = GRIB Master Tables Version Number
+!                                    ( see Code Table 1.0 )
+!                             0 - Experimental
+!                             1 - Initial operational version number
+!            gfld%idsect(4)  = GRIB Local Tables Version Number
+!                                    ( see Code Table 1.1 )
+!                             0     - Local tables not used
+!                             1-254 - Number of local tables version used
+!            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+!                             0 - Analysis
+!                             1 - Start of forecast
+!                             2 - Verifying time of forecast
+!                             3 - Observation time
+!            gfld%idsect(6)  = Year ( 4 digits )
+!            gfld%idsect(7)  = Month
+!            gfld%idsect(8)  = Day
+!            gfld%idsect(9)  = Hour
+!            gfld%idsect(10)  = Minute
+!            gfld%idsect(11)  = Second
+!            gfld%idsect(12)  = Production status of processed data
+!                                    ( see Code Table 1.3 )
+!                              0 - Operational products
+!                              1 - Operational test products
+!                              2 - Research products
+!                              3 - Re-analysis products
+!            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+!                              0  - Analysis products
+!                              1  - Forecast products
+!                              2  - Analysis and forecast products
+!                              3  - Control forecast products
+!                              4  - Perturbed forecast products
+!                              5  - Control and perturbed forecast products
+!                              6  - Processed satellite observations
+!                              7  - Processed radar observations
+!        gfld%idsectlen = Number of elements in gfld%idsect().
+!        gfld%local() = Pointer to character array containing contents
+!                       of Local Section 2, if included
+!        gfld%locallen = length of array gfld%local()
+!        gfld%ifldnum = field number within GRIB message
+!        gfld%griddef = Source of grid definition (see Code Table 3.0)
+!                      0 - Specified in Code table 3.1
+!                      1 - Predetermined grid Defined by originating centre
+!        gfld%ngrdpts = Number of grid points in the defined grid.
+!        gfld%numoct_opt = Number of octets needed for each
+!                          additional grid points definition.
+!                          Used to define number of
+!                          points in each row ( or column ) for
+!                          non-regular grids.
+!                          = 0, if using regular grid.
+!        gfld%interp_opt = Interpretation of list for optional points
+!                          definition.  (Code Table 3.11)
+!        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+!        gfld%igdtmpl() = Contains the data values for the specified Grid
+!                         Definition Template ( NN=gfld%igdtnum ).  Each
+!                         element of this integer array contains an entry (in
+!                         the order specified) of Grid Defintion Template 3.NN
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+!                       entries in Grid Defintion Template 3.NN
+!                       ( NN=gfld%igdtnum ).
+!        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+!                          contains the number of grid points contained in
+!                          each row ( or column ).  (part of Section 3)
+!                          This element is actually a pointer to an array
+!                          that holds the data.  This pointer is nullified
+!                          if gfld%numoct_opt=0.
+!        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+!                       in array ideflist.  i.e. number of rows ( or columns )
+!                       for which optional grid points are defined.  This value
+!                       is set to zero, if gfld%numoct_opt=0.
+!        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+!        gfld%ipdtmpl() = Contains the data values for the specified Product
+!                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+!                         of this integer array contains an entry (in the
+!                         order specified) of Product Defintion Template 4.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+!                       entries in Product Defintion Template 4.N
+!                       ( N=gfdl%ipdtnum ).
+!        gfld%coord_list() = Real array containing floating point values
+!                            intended to document the vertical discretisation
+!                            associated to model data on hybrid coordinate
+!                            vertical levels.  (part of Section 4)
+!                            This element is actually a pointer to an array
+!                            that holds the data.
+!        gfld%num_coord = number of values in array gfld%coord_list().
+!        gfld%ndpts = Number of data points unpacked and returned.
+!        gfld%idrtnum = Data Representation Template Number
+!                       ( see Code Table 5.0)
+!        gfld%idrtmpl() = Contains the data values for the specified Data
+!                         Representation Template ( N=gfld%idrtnum ).  Each
+!                         element of this integer array contains an entry
+!                         (in the order specified) of Product Defintion
+!                         Template 5.N.
+!                         This element is actually a pointer to an array
+!                         that holds the data.
+!        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+!                       of entries in Data Representation Template 5.N
+!                       ( N=gfld%idrtnum ).
+!        gfld%unpacked = logical value indicating whether the bitmap and
+!                        data values were unpacked.  If false,
+!                        gfld%bmap and gfld%fld pointers are nullified.
+!        gfld%expanded = Logical value indicating whether the data field
+!                         was expanded to the grid in the case where a
+!                         bit-map is present.  If true, the data points in
+!                         gfld%fld match the grid points and zeros were
+!                         inserted at grid points where data was bit-mapped
+!                         out.  If false, the data values in gfld%fld were
+!                         not expanded to the grid and are just a consecutive
+!                         array of data points corresponding to each value of
+!                         "1" in gfld%bmap.
+!        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+!                     0 = bitmap applies and is included in Section 6.
+!                     1-253 = Predefined bitmap applies
+!                     254 = Previously defined bitmap applies to this field
+!                     255 = Bit map does not apply to this product.
+!        gfld%bmap() = Logical*1 array containing decoded bitmap,
+!                      if ibmap=0 or ibap=254.  Otherwise nullified.
+!                      This element is actually a pointer to an array
+!                      that holds the data.
+!        gfld%fld() = Array of gfld%ndpts unpacked data points.
+!                     This element is actually a pointer to an array
+!                     that holds the data.
+!
+!
+! PROGRAM HISTORY LOG:
+! 2002-01-23  Gilbert
+!
+! USAGE:    use grib_mod
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=12) :: G2_VERSION="g2lib-1.0.7"
+
+      type gribfield
+          integer :: version,discipline
+          integer,pointer,dimension(:) :: idsect
+          integer :: idsectlen
+          character(len=1),pointer,dimension(:) :: local
+          integer :: locallen
+          integer :: ifldnum
+          integer :: griddef,ngrdpts
+          integer :: numoct_opt,interp_opt,num_opt
+          integer,pointer,dimension(:) :: list_opt
+          integer :: igdtnum,igdtlen
+          integer,pointer,dimension(:) :: igdtmpl
+          integer :: ipdtnum,ipdtlen
+          integer,pointer,dimension(:) :: ipdtmpl
+          integer :: num_coord
+          real,pointer,dimension(:) :: coord_list
+          integer :: ndpts,idrtnum,idrtlen
+          integer,pointer,dimension(:) :: idrtmpl
+          logical :: unpacked
+          logical :: expanded
+          integer :: ibmap
+          logical*1,pointer,dimension(:) :: bmap
+          real,pointer,dimension(:) :: fld
+      end type gribfield
+
+      end module
diff --git a/wrfv2_fire/external/io_grib2/g2lib/gridtemplates.F b/wrfv2_fire/external/io_grib2/g2lib/gridtemplates.F
new file mode 100644
index 00000000..ea33499c
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/gridtemplates.F
@@ -0,0 +1,403 @@
+      module gridtemplates
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    gridtemplates 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-09
+!
+! ABSTRACT: This Fortran Module contains info on all the available 
+!   GRIB2 Grid Definition Templates used in Section 3 (GDS).
+!   Each Template has three parts: The number of entries in the template
+!   (mapgridlen);  A map of the template (mapgrid), which contains the
+!   number of octets in which to pack each of the template values; and
+!   a logical value (needext) that indicates whether the Template needs 
+!   to be extended.  In some cases the number of entries in a template 
+!   can vary depending upon values specified in the "static" part of 
+!   the template.  ( See Template 3.120 as an example )
+!
+!   This module also contains two subroutines.  Subroutine getgridtemplate
+!   returns the octet map for a specified Template number, and
+!   subroutine extgridtemplate will calculate the extended octet map
+!   of an appropriate template given values for the "static" part of the 
+!   template.  See docblocks below for the arguments and usage of these 
+!   routines.
+!
+!   NOTE:  Array mapgrid contains the number of octets in which the 
+!   corresponding template values will be stored.  A negative value in
+!   mapgrid is used to indicate that the corresponding template entry can
+!   contain negative values.  This information is used later when packing
+!   (or unpacking) the template data values.  Negative data values in GRIB
+!   are stored with the left most bit set to one, and a negative number
+!   of octets value in mapgrid() indicates that this possibility should
+!   be considered.  The number of octets used to store the data value
+!   in this case would be the absolute value of the negative value in 
+!   mapgrid().
+!  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-09  Gilbert
+! 2003-09-02  Gilbert   -  Added GDT 3.31 - Albers Equal Area
+!
+! USAGE:    use gridtemplates
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,parameter :: MAXLEN=200,MAXTEMP=23
+
+      type gridtemplate
+          integer :: template_num
+          integer :: mapgridlen
+          integer,dimension(MAXLEN) :: mapgrid
+          logical :: needext
+      end type gridtemplate
+
+      type(gridtemplate),dimension(MAXTEMP) :: templates
+
+      data templates(1)%template_num /0/     !  Lat/Lon 
+      data templates(1)%mapgridlen /19/
+      data templates(1)%needext /.false./
+      data (templates(1)%mapgrid(j),j=1,19) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/
+
+      data templates(2)%template_num /1/     !  Rotated Lat/Lon 
+      data templates(2)%mapgridlen /22/
+      data templates(2)%needext /.false./
+      data (templates(2)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4/
+
+      data templates(3)%template_num /2/     !  Stretched Lat/Lon 
+      data templates(3)%mapgridlen /22/
+      data templates(3)%needext /.false./
+      data (templates(3)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,-4/
+
+      data templates(4)%template_num /3/     !  Stretched & Rotated Lat/Lon 
+      data templates(4)%mapgridlen /25/
+      data templates(4)%needext /.false./
+      data (templates(4)%mapgrid(j),j=1,25) 
+     &       /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4,-4,4,-4/
+
+      data templates(5)%template_num /10/     !  Mercator
+      data templates(5)%mapgridlen /19/
+      data templates(5)%needext /.false./
+      data (templates(5)%mapgrid(j),j=1,19)
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,-4,-4,4,1,4,4,4/
+
+      data templates(6)%template_num /20/     !  Polar Stereographic
+      data templates(6)%mapgridlen /18/
+      data templates(6)%needext /.false./
+      data (templates(6)%mapgrid(j),j=1,18) 
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1/
+
+      data templates(7)%template_num /30/     !  Lambert Conformal
+      data templates(7)%mapgridlen /22/
+      data templates(7)%needext /.false./
+      data (templates(7)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1,-4,-4,-4,4/
+
+      data templates(8)%template_num /40/     !  Gaussian Lat/Lon
+      data templates(8)%mapgridlen /19/
+      data templates(8)%needext /.false./
+      data (templates(8)%mapgrid(j),j=1,19) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/
+
+      data templates(9)%template_num /41/     !  Rotated Gaussian Lat/Lon
+      data templates(9)%mapgridlen /22/
+      data templates(9)%needext /.false./
+      data (templates(9)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4/
+
+      data templates(10)%template_num /42/     !  Stretched Gaussian Lat/Lon
+      data templates(10)%mapgridlen /22/
+      data templates(10)%needext /.false./
+      data (templates(10)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,-4/
+
+      data templates(11)%template_num /43/     !  Strtchd and Rot'd Gaus Lat/Lon
+      data templates(11)%mapgridlen /25/
+      data templates(11)%needext /.false./
+      data (templates(11)%mapgrid(j),j=1,25) 
+     &          /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4,-4,4,-4/
+
+      data templates(12)%template_num /50/    !  Spherical Harmonic Coefficients
+      data templates(12)%mapgridlen /5/
+      data templates(12)%needext /.false./
+      data (templates(12)%mapgrid(j),j=1,5) /4,4,4,1,1/
+
+      data templates(13)%template_num /51/   !  Rotated Spherical Harmonic Coeff
+      data templates(13)%mapgridlen /8/
+      data templates(13)%needext /.false./
+      data (templates(13)%mapgrid(j),j=1,8) /4,4,4,1,1,-4,4,4/
+
+      data templates(14)%template_num /52/   !  Stretch Spherical Harmonic Coeff
+      data templates(14)%mapgridlen /8/
+      data templates(14)%needext /.false./
+      data (templates(14)%mapgrid(j),j=1,8) /4,4,4,1,1,-4,4,-4/
+
+      data templates(15)%template_num /53/   !  Strch and Rot Spher Harm Coeffs
+      data templates(15)%mapgridlen /11/
+      data templates(15)%needext /.false./
+      data (templates(15)%mapgrid(j),j=1,11) /4,4,4,1,1,-4,4,4,-4,4,-4/
+
+      data templates(16)%template_num /90/     !  Space view Perspective
+      data templates(16)%mapgridlen /21/
+      data templates(16)%needext /.false./
+      data (templates(16)%mapgrid(j),j=1,21) 
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,4,4,4,4,1,4,4,4,4/
+
+      data templates(17)%template_num /100/    !  Triangular grid (icosahedron)
+      data templates(17)%mapgridlen /11/
+      data templates(17)%needext /.false./
+      data (templates(17)%mapgrid(j),j=1,11) /1,1,2,1,-4,4,4,1,1,1,4/
+
+      data templates(18)%template_num /110/ !  Equatorial Azimuthal equidistant
+      data templates(18)%mapgridlen /16/
+      data templates(18)%needext /.false./
+      data (templates(18)%mapgrid(j),j=1,16) 
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,4,4,1,1/
+
+       data templates(19)%template_num /120/     !  Azimuth-range 
+       data templates(19)%mapgridlen /7/
+       data templates(19)%needext /.true./
+       data (templates(19)%mapgrid(j),j=1,7) /4,4,-4,4,4,4,1/
+
+       data templates(20)%template_num /1000/     !  Cross Section Grid 
+       data templates(20)%mapgridlen /20/
+       data templates(20)%needext /.true./
+       data (templates(20)%mapgrid(j),j=1,20) 
+     &              /1,1,4,1,4,1,4,4,4,4,-4,4,1,4,4,1,2,1,1,2/
+
+       data templates(21)%template_num /1100/     !  Hovmoller Diagram Grid 
+       data templates(21)%mapgridlen /28/
+       data templates(21)%needext /.false./
+       data (templates(21)%mapgrid(j),j=1,28) 
+     &    /1,1,4,1,4,1,4,4,4,4,-4,4,1,-4,4,1,4,1,-4,1,1,-4,2,1,1,1,1,1/
+
+       data templates(22)%template_num /1200/     !  Time Section Grid 
+       data templates(22)%mapgridlen /16/
+       data templates(22)%needext /.true./
+       data (templates(22)%mapgrid(j),j=1,16) 
+     &              /4,1,-4,1,1,-4,2,1,1,1,1,1,2,1,1,2/
+
+      data templates(23)%template_num /31/     !  Albers Equal Area
+      data templates(23)%mapgridlen /22/
+      data templates(23)%needext /.false./
+      data (templates(23)%mapgrid(j),j=1,22) 
+     &              /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1,-4,-4,-4,4/
+
+      contains
+
+
+         integer function getgridindex(number)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getgridindex
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-28
+!
+! ABSTRACT: This function returns the index of specified Grid
+!   Definition Template 3.NN (NN=number) in array templates.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-28  Gilbert
+!
+! USAGE:    index=getgridindex(number)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Grid Definition
+!                Template 3.NN that is being requested.
+!
+! RETURNS:  Index of GDT 3.NN in array templates, if template exists.
+!           = -1, otherwise.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+
+           getgridindex=-1
+
+           do j=1,MAXTEMP
+              if (number.eq.templates(j)%template_num) then
+                 getgridindex=j
+                 return
+              endif
+           enddo
+
+         end function
+
+
+         subroutine getgridtemplate(number,nummap,map,needext,iret)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getgridtemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-09
+!
+! ABSTRACT: This subroutine returns grid template information for a 
+!   specified Grid Definition Template 3.NN.
+!   The number of entries in the template is returned along with a map
+!   of the number of octets occupied by each entry.  Also, a flag is
+!   returned to indicate whether the template would need to be extended.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-09  Gilbert
+!
+! USAGE:    CALL getgridtemplate(number,nummap,map,needext,iret)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Grid Definition 
+!                Template 3.NN that is being requested.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     nummap   - Number of entries in the Template
+!     map()    - An array containing the number of octets that each 
+!                template entry occupies when packed up into the GDS.
+!     needext  - Logical variable indicating whether the Grid Defintion
+!                Template has to be extended.  
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Undefine Grid Template number.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+           integer,intent(out) :: nummap,map(*),iret
+           logical,intent(out) :: needext
+
+           iret=0
+
+           index=getgridindex(number)
+
+           if (index.ne.-1) then
+              nummap=templates(index)%mapgridlen
+              needext=templates(index)%needext
+              map(1:nummap)=templates(index)%mapgrid(1:nummap)
+           else
+             nummap=0
+             needext=.false.
+             print *,'getgridtemplate: Grid Template ',number,
+     &               ' not defined.'
+             iret=1
+           endif
+
+         end subroutine
+
+
+         subroutine extgridtemplate(number,list,nummap,map)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    extgridtemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-09
+!
+! ABSTRACT: This subroutine generates the remaining octet map for a 
+!   given Grid Definition Template, if required.  Some Templates can 
+!   vary depending on data values given in an earlier part of the 
+!   Template, and it is necessary to know some of the earlier entry
+!   values to generate the full octet map of the Template.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-09  Gilbert
+!
+! USAGE:    CALL extgridtemplate(number,list,nummap,map)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Grid Definition 
+!                Template 3.NN that is being requested.
+!     list()   - The list of values for each entry in 
+!                the Grid Definition Template.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     nummap   - Number of entries in the Template
+!     map()    - An array containing the number of octets that each 
+!                template entry occupies when packed up into the GDS.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number,list(*)
+           integer,intent(out) :: nummap,map(*)
+
+           index=getgridindex(number)
+           if (index.eq.-1) return
+
+           if ( .not. templates(index)%needext ) return
+           nummap=templates(index)%mapgridlen
+           map(1:nummap)=templates(index)%mapgrid(1:nummap)
+
+           if ( number.eq.120 ) then
+              N=list(2)
+              do i=1,N
+                map(nummap+1)=2
+                map(nummap+2)=-2
+                nummap=nummap+2
+              enddo
+           elseif ( number.eq.1000 ) then
+              N=list(20)
+              do i=1,N
+                map(nummap+1)=4
+                nummap=nummap+1
+              enddo
+           elseif ( number.eq.1200 ) then
+              N=list(16)
+              do i=1,N
+                map(nummap+1)=4
+                nummap=nummap+1
+              enddo
+           endif
+
+         end subroutine
+
+         integer function getgdtlen(number)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getgdtlen
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-05-11
+!
+! ABSTRACT: This function returns the initial length (number of entries) in
+!   the "static" part of specified Grid Definition Template 3.number.
+!
+! PROGRAM HISTORY LOG:
+! 2004-05-11  Gilbert
+!
+! USAGE:    CALL getgdtlen(number)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Grid Definition
+!                Template 3.NN that is being requested.
+!
+! RETURNS:     Number of entries in the "static" part of GDT 3.number
+!              OR returns 0, if requested template is not found.
+!
+! REMARKS: If user needs the full length of a specific template that
+!    contains additional entries based on values set in the "static" part
+!    of the GDT, subroutine extgridtemplate can be used.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+
+           getgdtlen=0
+
+           index=getgridindex(number)
+
+           if (index.ne.-1) then
+              getgdtlen=templates(index)%mapgridlen
+           endif
+
+         end function
+
+
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/ixgb2.F b/wrfv2_fire/external/io_grib2/g2lib/ixgb2.F
new file mode 100644
index 00000000..13008d6b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/ixgb2.F
@@ -0,0 +1,206 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: IXGB2          MAKE INDEX RECORDS FOR FIELDS IN A GRIB2 MESSAGE
+C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2001-12-10
+C
+C ABSTRACT: THIS SUBPROGRAM GENERATES AN INDEX RECORD FOR EACH FIELD IN A
+C           GRIB2 MESSAGE.  THE INDEX RECORDS ARE WRITTEN TO INDEX BUFFER
+C           POINTED TO BY CBUF.
+C
+C           EACH INDEX RECORD HAS THE FOLLOWING FORM:
+C       BYTE 001 - 004: LENGTH OF INDEX RECORD
+C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
+C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
+C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
+C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
+C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
+C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
+C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
+C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
+C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
+C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
+C       BYTE 042 - 042: MESSAGE DISCIPLINE
+C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
+C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS) 
+C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS) 
+C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
+C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
+C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
+C
+C PROGRAM HISTORY LOG:
+C   95-10-31  IREDELL
+C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
+C 2001-12-10  GILBERT   MODIFIED FROM IXGB TO CREATE GRIB2 INDEXES
+C 2002-01-31  GILBERT   ADDED IDENTIFICATION SECTION TO INDEX RECORD
+C
+C USAGE:    CALL IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER LOGICAL UNIT OF INPUT GRIB FILE
+C     LSKIP        INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE
+C     LGRIB        INTEGER NUMBER OF BYTES IN GRIB MESSAGE
+C   OUTPUT ARGUMENTS:
+C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
+C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
+C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
+C     NUMFLD       INTEGER NUMBER OF INDEX RECORDS CREATED.
+C                  = 0, IF PROBLEMS
+C     MLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
+C     IRET         INTEGER RETURN CODE
+C                  =0, ALL OK
+C                  =1, NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER
+C                  =2, I/O ERROR IN READ
+C                  =3, GRIB MESSAGE IS NOT EDITION 2
+C                  =4, NOT ENOUGH MEMORY TO ALLOCATE EXTENT TO INDEX BUFFER
+C                  =5, UNIDENTIFIED GRIB SECTION ENCOUNTERED...PROBLEM 
+C                      SOMEWHERE.
+C
+C SUBPROGRAMS CALLED:
+C   G2LIB_GBYTE        GET INTEGER DATA FROM BYTES
+C   G2LIB_SBYTE        STORE INTEGER DATA IN BYTES
+C   BAREAD       BYTE-ADDRESSABLE READ
+C   REALLOC      RE-ALLOCATES MORE MEMORY
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE RE_ALLOC          ! NEEDED FOR SUBROUTINE REALLOC
+      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
+      PARAMETER(LINMAX=5000,INIT=50000,NEXT=10000)
+      PARAMETER(IXSKP=4,IXLUS=8,IXSGD=12,IXSPD=16,IXSDR=20,IXSBM=24,
+     &          IXDS=28,IXLEN=36,IXFLD=42,IXIDS=44)
+      PARAMETER(MXSKP=4,MXLUS=4,MXSGD=4,MXSPD=4,MXSDR=4,MXSBM=4,
+     &          MXDS=4,MXLEN=4,MXFLD=2,MXBMS=6)
+      CHARACTER CBREAD(LINMAX),CINDEX(LINMAX)
+      CHARACTER CVER,CDISC
+      CHARACTER CIDS(LINMAX),CGDS(LINMAX),CBMS(6)
+      CHARACTER(LEN=4) :: CTEMP
+      INTEGER LOCLUS,LOCGDS,LENGDS,LOCBMS
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      LOCLUS=0
+      IRET=0
+      MLEN=0
+      NUMFLD=0
+      IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
+      MBUF=INIT
+      ALLOCATE(CBUF(MBUF),STAT=ISTAT)    ! ALLOCATE INITIAL SPACE FOR CBUF
+      IF (ISTAT.NE.0) THEN
+         IRET=1
+         RETURN
+      ENDIF
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  READ SECTIONS 0 AND 1 FOR VERSIN NUMBER AND DISCIPLINE
+      IBREAD=MIN(LGRIB,LINMAX)
+      CALL BAREAD(LUGB,LSKIP,IBREAD,LBREAD,CBREAD)
+      IF(LBREAD.NE.IBREAD) THEN
+         IRET=2
+         RETURN
+      ENDIF
+      IF(CBREAD(8).NE.CHAR(2)) THEN          !  NOT GRIB EDITION 2
+         IRET=3
+         RETURN
+      ENDIF
+      CVER=CBREAD(8)
+      CDISC=CBREAD(7)
+      CALL G2LIB_GBYTE(CBREAD,LENSEC1,16*8,4*8)
+      LENSEC1=MIN(LENSEC1,IBREAD)
+      CIDS(1:LENSEC1)=CBREAD(17:16+LENSEC1)
+      IBSKIP=LSKIP+16+LENSEC1
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  LOOP THROUGH REMAINING SECTIONS CREATING AN INDEX FOR EACH FIELD
+      IBREAD=MAX(5,MXBMS)
+      DO
+         CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD)     
+         CTEMP=CBREAD(1)//CBREAD(2)//CBREAD(3)//CBREAD(4)
+         IF (CTEMP.EQ.'7777') RETURN        ! END OF MESSAGE FOUND
+         IF(LBREAD.NE.IBREAD) THEN
+            IRET=2
+            RETURN
+         ENDIF
+         CALL G2LIB_GBYTE(CBREAD,LENSEC,0*8,4*8)
+         CALL G2LIB_GBYTE(CBREAD,NUMSEC,4*8,1*8)
+
+         IF (NUMSEC.EQ.2) THEN                 ! SAVE LOCAL USE LOCATION
+            LOCLUS=IBSKIP-LSKIP
+         ELSEIF (NUMSEC.EQ.3) THEN                 ! SAVE GDS INFO
+            LENGDS=LENSEC
+            CGDS=CHAR(0)
+            CALL BAREAD(LUGB,IBSKIP,LENGDS,LBREAD,CGDS)     
+            IF(LBREAD.NE.LENGDS) THEN
+               IRET=2
+               RETURN
+            ENDIF
+            LOCGDS=IBSKIP-LSKIP
+         ELSEIF (NUMSEC.EQ.4) THEN                 ! FOUND PDS
+            CINDEX=CHAR(0)
+            CALL G2LIB_SBYTE(CINDEX,LSKIP,8*IXSKP,8*MXSKP)    ! BYTES TO SKIP
+            CALL G2LIB_SBYTE(CINDEX,LOCLUS,8*IXLUS,8*MXLUS)   ! LOCATION OF LOCAL USE
+            CALL G2LIB_SBYTE(CINDEX,LOCGDS,8*IXSGD,8*MXSGD)   ! LOCATION OF GDS
+            CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSPD,8*MXSPD)  ! LOCATION OF PDS
+            CALL G2LIB_SBYTE(CINDEX,LGRIB,8*IXLEN,8*MXLEN)    ! LEN OF GRIB2
+            CINDEX(41)=CVER
+            CINDEX(42)=CDISC
+            CALL G2LIB_SBYTE(CINDEX,NUMFLD+1,8*IXFLD,8*MXFLD)   ! FIELD NUM
+            CINDEX(IXIDS+1:IXIDS+LENSEC1)=CIDS(1:LENSEC1)
+            LINDEX=IXIDS+LENSEC1
+            CINDEX(LINDEX+1:LINDEX+LENGDS)=CGDS(1:LENGDS)
+            LINDEX=LINDEX+LENGDS
+            ILNPDS=LENSEC
+            CALL BAREAD(LUGB,IBSKIP,ILNPDS,LBREAD,CINDEX(LINDEX+1))     
+            IF(LBREAD.NE.ILNPDS) THEN
+               IRET=2
+               RETURN
+            ENDIF
+            !   CINDEX(LINDEX+1:LINDEX+ILNPDS)=CBREAD(1:ILNPDS)
+            LINDEX=LINDEX+ILNPDS
+         ELSEIF (NUMSEC.EQ.5) THEN                 ! FOUND DRS
+            CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSDR,8*MXSDR)  ! LOCATION OF DRS
+            ILNDRS=LENSEC
+            CALL BAREAD(LUGB,IBSKIP,ILNDRS,LBREAD,CINDEX(LINDEX+1))     
+            IF(LBREAD.NE.ILNDRS) THEN
+               IRET=2
+               RETURN
+            ENDIF
+            !   CINDEX(LINDEX+1:LINDEX+ILNDRS)=CBREAD(1:ILNDRS)
+            LINDEX=LINDEX+ILNDRS
+         ELSEIF (NUMSEC.EQ.6) THEN                 ! FOUND BMS
+            INDBMP=MOVA2I(CBREAD(6))
+            IF ( INDBMP.LT.254 ) THEN
+               LOCBMS=IBSKIP-LSKIP
+               CALL G2LIB_SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
+            ELSEIF ( INDBMP.EQ.254 ) THEN
+               CALL G2LIB_SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
+            ELSEIF ( INDBMP.EQ.255 ) THEN
+               CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
+            ENDIF
+            CINDEX(LINDEX+1:LINDEX+MXBMS)=CBREAD(1:MXBMS)
+            LINDEX=LINDEX+MXBMS
+            CALL G2LIB_SBYTE(CINDEX,LINDEX,0,8*4)    ! NUM BYTES IN INDEX RECORD
+         ELSEIF (NUMSEC.EQ.7) THEN                 ! FOUND DATA SECTION
+            CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXDS,8*MXDS)   ! LOC. OF DATA SEC.
+            NUMFLD=NUMFLD+1
+            IF ((LINDEX+MLEN).GT.MBUF) THEN        ! ALLOCATE MORE SPACE IF
+                                                   ! NECESSARY
+               NEWSIZE=MAX(MBUF+NEXT,MBUF+LINDEX)
+               CALL REALLOC(CBUF,MLEN,NEWSIZE,ISTAT)
+               IF ( ISTAT .NE. 0 ) THEN
+                  NUMFLD=NUMFLD-1
+                  IRET=4
+                  RETURN
+               ENDIF
+               MBUF=NEWSIZE
+            ENDIF
+            CBUF(MLEN+1:MLEN+LINDEX)=CINDEX(1:LINDEX)
+            MLEN=MLEN+LINDEX
+         ELSE                           ! UNRECOGNIZED SECTION
+            IRET=5
+            RETURN
+         ENDIF
+         IBSKIP=IBSKIP+LENSEC
+      ENDDO
+
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/jpcpack.F b/wrfv2_fire/external/io_grib2/g2lib/jpcpack.F
new file mode 100644
index 00000000..42b749ab
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/jpcpack.F
@@ -0,0 +1,236 @@
+      subroutine jpcpack(fld,width,height,idrstmpl,cpack,lcpack,ierr)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    jpcpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-17
+!
+! ABSTRACT: This subroutine packs up a data field into a JPEG2000 code stream.
+!   After the data field is scaled, and the reference value is subtracted out,
+!   it is treated as a grayscale image and passed to a JPEG2000 encoder.
+!   It also fills in GRIB2 Data Representation Template 5.40 or 5.40000 with the
+!   appropriate values.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-17  Gilbert
+! 2004-07-19  Gilbert - Added check on whether the jpeg2000 encoding was
+!                       successful.  If not, try again with different encoder
+!                       options.
+!
+! USAGE:    CALL jpcpack(fld,width,height,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     width    - number of points in the x direction
+!     height   - number of points in the y direction
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.40 or 5.40000
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                (4) = number of bits for each data value - ignored on input
+!                (5) = Original field type - currently ignored on input
+!                      Data values assumed to be reals.
+!                (6) = 0 - use lossless compression
+!                    = 1 - use lossy compression
+!                (7) = Desired compression ratio, if idrstmpl(6)=1.
+!                      Set to 255, if idrstmpl(6)=0.
+!     lcpack   - size of array cpack().
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.0
+!                (1) = Reference value - set by jpcpack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                (4) = Number of bits containing each grayscale pixel value
+!                (5) = Original field type - currently set = 0 on output.
+!                      Data values assumed to be reals.
+!                (6) = 0 - use lossless compression
+!                    = 1 - use lossy compression
+!                (7) = Desired compression ratio, if idrstmpl(6)=1
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field in cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: width,height
+      real,intent(in) :: fld(width*height)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(inout) :: lcpack
+      integer,intent(out)   :: ierr
+
+      real(4) :: ref
+      integer(4) :: iref
+      integer :: ifld(width*height),retry
+      integer,parameter :: zero=0
+      integer :: enc_jpeg2000
+      character(len=1),allocatable :: ctemp(:)
+      integer :: orig_dscalefct
+      integer :: orig_bscalefct
+      integer(8) :: maxdif,imin,imax
+      
+      ierr = 0
+
+      ndpts=width*height
+      bscale=2.0**real(-idrstmpl(2))
+      dscale=10.0**real(idrstmpl(3))
+
+      orig_bscalefct = idrstmpl(2)
+      orig_dscalefct = idrstmpl(3)
+
+!
+!  Find max and min values in the data
+!
+      rmax=fld(1)
+      rmin=fld(1)
+      do j=2,ndpts
+        if (fld(j).gt.rmax) rmax=fld(j)
+        if (fld(j).lt.rmin) rmin=fld(j)
+      enddo
+      if (idrstmpl(2).eq.0) then
+         maxdif=nint(rmax*dscale,8)-nint(rmin*dscale,8)
+      else
+         maxdif=nint((rmax-rmin)*dscale*bscale,8)
+      endif
+!
+!  If max and min values are not equal, pack up field.
+!  If they are equal, we have a constant field, and the reference
+!  value (rmin) is the value for each point in the field and
+!  set nbits to 0.
+!
+      if (rmin.ne.rmax .AND. maxdif.ne.0) then
+        !
+        !  Determine which algorithm to use based on user-supplied 
+        !  binary scale factor and number of bits.
+        !
+
+        if (idrstmpl(2).eq.0) then
+           !
+           !  No binary scaling and calculate minimum number of 
+           !  bits in which the data will fit.
+           !
+
+           nbits = 25
+
+           do while (nbits .gt. 24) 
+              imin=nint(rmin*dscale,8)
+              imax=nint(rmax*dscale,8)
+              maxdif=imax-imin
+              temp=alog(real(maxdif+1))/alog(2.0)
+              nbits=ceiling(temp)
+              !
+              ! These lines assure that we do no overflow
+              !
+              !  Todd Hutchinson, WSI 9/23/05
+              !
+              if (nbits .le. 24) then 
+                 exit
+              else
+                 idrstmpl(3) = idrstmpl(3) - 1
+                 dscale=10.0**real(idrstmpl(3))
+              endif
+           enddo
+
+           rmin=real(imin)
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(fld(j)*dscale)-imin
+           enddo
+        else
+           !
+           !  Use binary scaling factor and calculate minimum number of 
+           !  bits in which the data will fit.
+           !
+           nbits = 25
+
+           do while (nbits .gt. 24) 
+              rmin=rmin*dscale
+              rmax=rmax*dscale
+              maxdif=nint((rmax-rmin)*bscale)
+              temp=alog(real(maxdif+1))/alog(2.0)
+              nbits=ceiling(temp)
+              !
+              ! These lines assure that we do no overflow
+              !
+              !  Todd Hutchinson, WSI 9/23/05
+              !
+              if (nbits .le. 24) then 
+                 exit
+              else
+                 idrstmpl(2) = idrstmpl(2) + 1
+                 bscale=2.0**real(-idrstmpl(2))
+              endif              
+           enddo
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        endif
+
+        if (idrstmpl(2) .ne. orig_bscalefct) then 
+           write(6,'(A,I2,A,I2,A)')
+     &          ' JPCPACK: Reduced binary scale fctr from ',
+     &          orig_bscalefct,' to ',idrstmpl(2),
+     &          ' to prevent overflow'
+           ierr = 12
+        endif
+
+        if (idrstmpl(3) .ne. orig_dscalefct) then 
+           write(6,'(A,I2,A,I2,A)')
+     &          ' JPCPACK: Reduced decimal scale fctr from ',
+     &          orig_dscalefct,' to ',idrstmpl(3), 
+     &          ' to prevent overflow'
+           ierr = 11
+        endif
+
+        !
+        !  Pack data into full octets, then do JPEG2000 encode.
+        !  and calculate the length of the packed data in bytes
+        !
+        retry=0
+        nbytes=(nbits+7)/8
+        nsize=lcpack      ! needed for input to enc_jpeg2000
+        allocate(ctemp(nbytes*ndpts))
+        call g2lib_sbytes(ctemp,ifld,0,nbytes*8,0,ndpts)
+        lcpack=enc_jpeg2000(ctemp,width,height,nbits,idrstmpl(6),
+     &                      idrstmpl(7),retry,cpack,nsize)
+        if (lcpack.le.0) then
+           print *,'jpcpack: ERROR Packing JPC=',lcpack
+           if (lcpack.eq.-3) then
+              retry=1
+              print *,'jpcpack: Retrying....'
+              lcpack=enc_jpeg2000(ctemp,width,height,nbits,idrstmpl(6),
+     &                         idrstmpl(7),retry,cpack,nsize)
+              if (lcpack.le.0) then
+                 print *,'jpcpack: Retry Failed.'
+              else
+                 print *,'jpcpack: Retry Successful.'
+              endif
+           endif
+        endif
+        deallocate(ctemp)
+
+      else
+        nbits=0
+        lcpack=0
+      endif
+
+!
+!  Fill in ref value and number of bits in Template 5.0
+!
+      call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
+!      call g2lib_gbyte(ref,idrstmpl(1),0,32)
+      iref=transfer(ref,iref)
+      idrstmpl(1)=iref
+      idrstmpl(4)=nbits
+      idrstmpl(5)=0         ! original data were reals
+      if (idrstmpl(6).eq.0) idrstmpl(7)=255       ! lossy not used
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/jpcunpack.F b/wrfv2_fire/external/io_grib2/g2lib/jpcunpack.F
new file mode 100644
index 00000000..574fa73e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/jpcunpack.F
@@ -0,0 +1,66 @@
+      subroutine jpcunpack(cpack,len,idrstmpl,ndpts,fld)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    jpcunpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-17
+!
+! ABSTRACT: This subroutine unpacks a data field that was packed into a 
+!   JPEG2000 code stream
+!   using info from the GRIB2 Data Representation Template 5.40 or 5.40000.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-17  Gilbert
+!
+! USAGE:    CALL jpcunpack(cpack,len,idrstmpl,ndpts,fld)
+!   INPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     len      - length of packed field cpack().
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.40 or 5.40000
+!     ndpts    - The number of data values to unpack
+!
+!   OUTPUT ARGUMENT LIST:
+!     fld()    - Contains the unpacked data values
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cpack(len)
+      integer,intent(in) :: ndpts,len
+      integer,intent(in) :: idrstmpl(*)
+      real,intent(out) :: fld(ndpts)
+
+      integer :: ifld(ndpts)
+      integer(4) :: ieee
+      real :: ref,bscale,dscale
+      integer :: dec_jpeg2000
+
+      ieee = idrstmpl(1)
+      call rdieee(ieee,ref,1)
+      bscale = 2.0**real(idrstmpl(2))
+      dscale = 10.0**real(-idrstmpl(3))
+      nbits = idrstmpl(4)
+!
+!  if nbits equals 0, we have a constant field where the reference value
+!  is the data value at each gridpoint
+!
+      if (nbits.ne.0) then
+!         call g2lib_gbytes(cpack,ifld,0,nbits,0,ndpts)
+         iret=dec_jpeg2000(cpack,len,ifld)
+         do j=1,ndpts
+           fld(j)=((real(ifld(j))*bscale)+ref)*dscale
+         enddo
+      else
+         do j=1,ndpts
+           fld(j)=ref
+         enddo
+      endif
+
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/misspack.F b/wrfv2_fire/external/io_grib2/g2lib/misspack.F
new file mode 100644
index 00000000..77816e35
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/misspack.F
@@ -0,0 +1,499 @@
+      subroutine misspack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    misspack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine packs up a data field using a complex
+!   packing algorithm as defined in the GRIB2 documention.  It
+!   supports GRIB2 complex packing templates with or without
+!   spatial differences (i.e. DRTs 5.2 and 5.3).
+!   It also fills in GRIB2 Data Representation Template 5.2 or 5.3 
+!   with the appropriate values.
+!   This version assumes that Missing Value Management is being used and that
+!   1 or 2 missing values appear in the data.
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+! 2004-12-29  Gilbert  -  Corrected bug when encoding secondary missing values.
+!
+! USAGE:    CALL misspack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     ndpts    - The number of data values in array fld()
+!     idrsnum  - Data Representation Template number 5.N
+!                Must equal 2 or 3.
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.2 or 5.3
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                    .
+!                    .
+!                (7) = Missing value management
+!                (8) = Primary missing value
+!                (9) = Secondary missing value
+!                    .
+!                    .
+!               (17) = Order of Spatial Differencing  ( 1 or 2 )
+!                    .
+!                    .
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.3
+!                (1) = Reference value - set by misspack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                    .
+!                    .
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: ndpts,idrsnum
+      real,intent(in) :: fld(ndpts)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(out) :: lcpack
+
+      real(4) :: ref
+      integer(4) :: iref
+      integer,allocatable :: ifld(:),ifldmiss(:),jfld(:)
+      integer,allocatable :: jmin(:),jmax(:),lbit(:)
+      integer,parameter :: zero=0
+      integer,allocatable :: gref(:),gwidth(:),glen(:)
+      integer :: glength,grpwidth
+      logical :: simple_alg = .false.
+      
+      alog2=alog(2.0)
+      bscale=2.0**real(-idrstmpl(2))
+      dscale=10.0**real(idrstmpl(3))
+      missopt=idrstmpl(7)
+      if ( missopt.ne.1 .AND. missopt.ne.2 ) then
+         print *,'misspack: Unrecognized option.'
+         lcpack=-1
+         return
+      else     !  Get missing values
+         call rdieee(idrstmpl(8),rmissp,1)
+         if (missopt.eq.2) call rdieee(idrstmpl(9),rmisss,1)
+      endif
+!
+!  Find min value of non-missing values in the data,
+!  AND set up missing value mapping of the field.
+!
+      allocate(ifldmiss(ndpts))
+      rmin=huge(rmin)
+      if ( missopt .eq. 1 ) then        ! Primary missing value only
+         do j=1,ndpts
+           if (fld(j).eq.rmissp) then
+              ifldmiss(j)=1
+           else
+              ifldmiss(j)=0
+              if (fld(j).lt.rmin) rmin=fld(j)
+           endif
+         enddo
+      endif
+      if ( missopt .eq. 2 ) then        ! Primary and secondary missing values
+         do j=1,ndpts
+           if (fld(j).eq.rmissp) then
+              ifldmiss(j)=1
+           elseif (fld(j).eq.rmisss) then
+              ifldmiss(j)=2
+           else
+              ifldmiss(j)=0
+              if (fld(j).lt.rmin) rmin=fld(j)
+           endif
+         enddo
+      endif
+!
+!  Allocate work arrays:
+!  Note: -ifldmiss(j),j=1,ndpts is a map of original field indicating 
+!         which of the original data values
+!         are primary missing (1), sencondary missing (2) or non-missing (0).
+!        -jfld(j),j=1,nonmiss is a subarray of just the non-missing values from
+!         the original field.
+!
+      !if (rmin.ne.rmax) then
+        iofst=0
+        allocate(ifld(ndpts))
+        allocate(jfld(ndpts))
+        allocate(gref(ndpts))
+        allocate(gwidth(ndpts))
+        allocate(glen(ndpts))
+        !
+        !  Scale original data
+        !
+        nonmiss=0
+        if (idrstmpl(2).eq.0) then        !  No binary scaling
+           imin=nint(rmin*dscale)
+           !imax=nint(rmax*dscale)
+           rmin=real(imin)
+           do j=1,ndpts
+              if (ifldmiss(j).eq.0) then
+                nonmiss=nonmiss+1
+                jfld(nonmiss)=nint(fld(j)*dscale)-imin
+              endif
+           enddo
+        else                              !  Use binary scaling factor
+           rmin=rmin*dscale
+           !rmax=rmax*dscale
+           do j=1,ndpts
+              if (ifldmiss(j).eq.0) then
+                nonmiss=nonmiss+1
+                jfld(nonmiss)=nint(((fld(j)*dscale)-rmin)*bscale)
+              endif
+           enddo
+        endif
+        !
+        !  Calculate Spatial differences, if using DRS Template 5.3
+        !
+        if (idrsnum.eq.3) then        ! spatial differences
+           if (idrstmpl(17).ne.1.and.idrstmpl(17).ne.2) idrstmpl(17)=2
+           if (idrstmpl(17).eq.1) then      ! first order
+              ival1=jfld(1)
+              do j=nonmiss,2,-1
+                 jfld(j)=jfld(j)-jfld(j-1)
+              enddo
+              jfld(1)=0
+           elseif (idrstmpl(17).eq.2) then      ! second order
+              ival1=jfld(1)
+              ival2=jfld(2)
+              do j=nonmiss,3,-1
+                 jfld(j)=jfld(j)-(2*jfld(j-1))+jfld(j-2)
+              enddo
+              jfld(1)=0
+              jfld(2)=0
+           endif
+           !
+           !  subtract min value from spatial diff field
+           !
+           isd=idrstmpl(17)+1
+           minsd=minval(jfld(isd:nonmiss))
+           do j=isd,nonmiss
+              jfld(j)=jfld(j)-minsd
+           enddo
+           !
+           !   find num of bits need to store minsd and add 1 extra bit
+           !   to indicate sign
+           !
+           temp=alog(real(abs(minsd)+1))/alog2
+           nbitsd=ceiling(temp)+1
+           !
+           !   find num of bits need to store ifld(1) ( and ifld(2)
+           !   if using 2nd order differencing )
+           !
+           maxorig=ival1
+           if (idrstmpl(17).eq.2.and.ival2.gt.ival1) maxorig=ival2
+           temp=alog(real(maxorig+1))/alog2
+           nbitorig=ceiling(temp)+1
+           if (nbitorig.gt.nbitsd) nbitsd=nbitorig
+           !   increase number of bits to even multiple of 8 ( octet )
+           if (mod(nbitsd,8).ne.0) nbitsd=nbitsd+(8-mod(nbitsd,8))
+           !
+           !  Store extra spatial differencing info into the packed
+           !  data section.
+           !
+           if (nbitsd.ne.0) then
+              !   pack first original value
+              if (ival1.ge.0) then
+                 call g2lib_sbyte(cpack,ival1,iofst,nbitsd)
+                 iofst=iofst+nbitsd
+              else
+                 call g2lib_sbyte(cpack,1,iofst,1)
+                 iofst=iofst+1
+                 call g2lib_sbyte(cpack,iabs(ival1),iofst,nbitsd-1)
+                 iofst=iofst+nbitsd-1
+              endif
+              if (idrstmpl(17).eq.2) then
+               !  pack second original value
+                 if (ival2.ge.0) then
+                    call g2lib_sbyte(cpack,ival2,iofst,nbitsd)
+                    iofst=iofst+nbitsd
+                 else
+                    call g2lib_sbyte(cpack,1,iofst,1)
+                    iofst=iofst+1
+                    call g2lib_sbyte(cpack,iabs(ival2),iofst,nbitsd-1)
+                    iofst=iofst+nbitsd-1
+                 endif
+              endif
+              !  pack overall min of spatial differences
+              if (minsd.ge.0) then
+                 call g2lib_sbyte(cpack,minsd,iofst,nbitsd)
+                 iofst=iofst+nbitsd
+              else
+                 call g2lib_sbyte(cpack,1,iofst,1)
+                 iofst=iofst+1
+                 call g2lib_sbyte(cpack,iabs(minsd),iofst,nbitsd-1)
+                 iofst=iofst+nbitsd-1
+              endif
+           endif
+         !print *,'SDp ',ival1,ival2,minsd,nbitsd
+        endif     !  end of spatial diff section
+        !
+        !  Expand non-missing data values to original grid.
+        !
+        miss1=minval(jfld(1:nonmiss))-1
+        miss2=miss1-1
+        n=0
+        do j=1,ndpts
+           if ( ifldmiss(j).eq.0 ) then
+              n=n+1
+              ifld(j)=jfld(n)
+           elseif ( ifldmiss(j).eq.1 ) then
+              ifld(j)=miss1
+           elseif ( ifldmiss(j).eq.2 ) then
+              ifld(j)=miss2
+           endif
+        enddo
+        !
+        !   Determine Groups to be used.
+        !
+        if ( simple_alg ) then
+           !  set group length to 10 :  calculate number of groups
+           !  and length of last group
+           ngroups=ndpts/10
+           glen(1:ngroups)=10
+           itemp=mod(ndpts,10)
+           if (itemp.ne.0) then
+              ngroups=ngroups+1
+              glen(ngroups)=itemp
+           endif
+        else
+           ! Use Dr. Glahn's algorithm for determining grouping.
+           !
+           kfildo=6
+           minpk=10 
+           inc=1
+           maxgrps=(ndpts/minpk)+1
+           allocate(jmin(maxgrps))
+           allocate(jmax(maxgrps))
+           allocate(lbit(maxgrps))
+           call pack_gp(kfildo,ifld,ndpts,missopt,minpk,inc,miss1,miss2,
+     &                  jmin,jmax,lbit,glen,maxgrps,ngroups,ibit,jbit,
+     &                  kbit,novref,lbitref,ier)
+           !print *,'SAGier = ',ier,ibit,jbit,kbit,novref,lbitref
+           do ng=1,ngroups
+              glen(ng)=glen(ng)+novref
+           enddo
+           deallocate(jmin)
+           deallocate(jmax)
+           deallocate(lbit)
+        endif
+        !  
+        !  For each group, find the group's reference value (min)
+        !  and the number of bits needed to hold the remaining values
+        !
+        n=1
+        do ng=1,ngroups
+           !  how many of each type?
+           num0=count(ifldmiss(n:n+glen(ng)-1) .EQ. 0)
+           num1=count(ifldmiss(n:n+glen(ng)-1) .EQ. 1)
+           num2=count(ifldmiss(n:n+glen(ng)-1) .EQ. 2)
+           if ( num0.eq.0 ) then      ! all missing values
+              if ( num1.eq.0 ) then       ! all secondary missing
+                gref(ng)=-2
+                gwidth(ng)=0
+              elseif ( num2.eq.0 ) then       ! all primary missing
+                gref(ng)=-1
+                gwidth(ng)=0
+              else                           ! both primary and secondary
+                gref(ng)=0
+                gwidth(ng)=1
+              endif
+           else                       ! contains some non-missing data
+             !    find max and min values of group
+             gref(ng)=huge(n)
+             imax=-1*huge(n)
+             j=n
+             do lg=1,glen(ng)
+                if ( ifldmiss(j).eq.0 ) then
+                  if (ifld(j).lt.gref(ng)) gref(ng)=ifld(j) 
+                  if (ifld(j).gt.imax) imax=ifld(j) 
+                endif
+                j=j+1
+             enddo
+             if (missopt.eq.1) imax=imax+1
+             if (missopt.eq.2) imax=imax+2
+             !   calc num of bits needed to hold data
+             if ( gref(ng).ne.imax ) then
+                temp=alog(real(imax-gref(ng)+1))/alog2
+                gwidth(ng)=ceiling(temp)
+             else
+                gwidth(ng)=0
+             endif
+           endif
+           !   Subtract min from data
+           j=n
+           mtemp=2**gwidth(ng)
+           do lg=1,glen(ng)
+              if (ifldmiss(j).eq.0) then       ! non-missing
+                 ifld(j)=ifld(j)-gref(ng)
+              elseif (ifldmiss(j).eq.1) then    ! primary missing
+                 ifld(j)=mtemp-1
+              elseif (ifldmiss(j).eq.2) then    ! secondary missing
+                 ifld(j)=mtemp-2
+              endif
+              j=j+1
+           enddo
+           !   increment fld array counter
+           n=n+glen(ng)
+        enddo
+        !  
+        !  Find max of the group references and calc num of bits needed 
+        !  to pack each groups reference value, then
+        !  pack up group reference values
+        !
+        !write(77,*)'GREFS: ',(gref(j),j=1,ngroups)
+        igmax=maxval(gref(1:ngroups))
+        if (missopt.eq.1) igmax=igmax+1
+        if (missopt.eq.2) igmax=igmax+2
+        if (igmax.ne.0) then
+           temp=alog(real(igmax+1))/alog2
+           nbitsgref=ceiling(temp)
+           ! restet the ref values of any "missing only" groups.
+           mtemp=2**nbitsgref
+           do j=1,ngroups
+               if (gref(j).eq.-1) gref(j)=mtemp-1
+               if (gref(j).eq.-2) gref(j)=mtemp-2
+           enddo
+           call g2lib_sbytes(cpack,gref,iofst,nbitsgref,0,ngroups)
+           itemp=nbitsgref*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsgref=0
+        endif
+        !
+        !  Find max/min of the group widths and calc num of bits needed
+        !  to pack each groups width value, then
+        !  pack up group width values
+        !
+        !write(77,*)'GWIDTHS: ',(gwidth(j),j=1,ngroups)
+        iwmax=maxval(gwidth(1:ngroups))
+        ngwidthref=minval(gwidth(1:ngroups))
+        if (iwmax.ne.ngwidthref) then
+           temp=alog(real(iwmax-ngwidthref+1))/alog2
+           nbitsgwidth=ceiling(temp)
+           do i=1,ngroups
+              gwidth(i)=gwidth(i)-ngwidthref
+           enddo
+           call g2lib_sbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups)
+           itemp=nbitsgwidth*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsgwidth=0
+           gwidth(1:ngroups)=0
+        endif
+        !
+        !  Find max/min of the group lengths and calc num of bits needed
+        !  to pack each groups length value, then
+        !  pack up group length values
+        !
+        !write(77,*)'GLENS: ',(glen(j),j=1,ngroups)
+        ilmax=maxval(glen(1:ngroups-1))
+        nglenref=minval(glen(1:ngroups-1))
+        nglenlast=glen(ngroups)
+        if (ilmax.ne.nglenref) then
+           temp=alog(real(ilmax-nglenref+1))/alog2
+           nbitsglen=ceiling(temp)
+           do i=1,ngroups-1
+              glen(i)=glen(i)-nglenref
+           enddo
+           call g2lib_sbytes(cpack,glen,iofst,nbitsglen,0,ngroups)
+           itemp=nbitsglen*ngroups
+           iofst=iofst+itemp
+           !         Pad last octet with Zeros, if necessary,
+           if (mod(itemp,8).ne.0) then
+              left=8-mod(itemp,8)
+              call g2lib_sbyte(cpack,zero,iofst,left)
+              iofst=iofst+left
+           endif
+        else
+           nbitsglen=0
+           glen(1:ngroups)=0
+        endif
+        !
+        !  For each group, pack data values
+        !
+        !write(77,*)'IFLDS: ',(ifld(j),j=1,ndpts)
+        n=1
+        ij=0
+        do ng=1,ngroups
+           glength=glen(ng)+nglenref
+           if (ng.eq.ngroups ) glength=nglenlast
+           grpwidth=gwidth(ng)+ngwidthref
+       !write(77,*)'NGP ',ng,grpwidth,glength,gref(ng)
+           if ( grpwidth.ne.0 ) then
+              call g2lib_sbytes(cpack,ifld(n),iofst,grpwidth,0,glength)
+              iofst=iofst+(grpwidth*glength)
+           endif
+           do kk=1,glength
+              ij=ij+1
+        !write(77,*)'SAG ',ij,fld(ij),ifld(ij),gref(ng),bscale,rmin,dscale
+           enddo
+           n=n+glength
+        enddo
+        !         Pad last octet with Zeros, if necessary,
+        if (mod(iofst,8).ne.0) then
+           left=8-mod(iofst,8)
+           call g2lib_sbyte(cpack,zero,iofst,left)
+           iofst=iofst+left
+        endif
+        lcpack=iofst/8
+        !
+        if ( allocated(ifld) ) deallocate(ifld)
+        if ( allocated(jfld) ) deallocate(jfld)
+        if ( allocated(ifldmiss) ) deallocate(ifldmiss)
+        if ( allocated(gref) ) deallocate(gref)
+        if ( allocated(gwidth) ) deallocate(gwidth)
+        if ( allocated(glen) ) deallocate(glen)
+      !else           !   Constant field ( max = min )
+      !  nbits=0
+      !  lcpack=0
+      !  nbitsgref=0
+      !  ngroups=0
+      !endif
+
+!
+!  Fill in ref value and number of bits in Template 5.2
+!
+      call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
+!      call g2lib_gbyte(ref,idrstmpl(1),0,32)
+      iref=transfer(ref,iref)
+      idrstmpl(1)=iref
+      idrstmpl(4)=nbitsgref
+      idrstmpl(5)=0         ! original data were reals
+      idrstmpl(6)=1         ! general group splitting
+      idrstmpl(10)=ngroups          ! Number of groups
+      idrstmpl(11)=ngwidthref       ! reference for group widths
+      idrstmpl(12)=nbitsgwidth      ! num bits used for group widths
+      idrstmpl(13)=nglenref         ! Reference for group lengths
+      idrstmpl(14)=1                ! length increment for group lengths
+      idrstmpl(15)=nglenlast        ! True length of last group
+      idrstmpl(16)=nbitsglen        ! num bits used for group lengths
+      if (idrsnum.eq.3) then
+         idrstmpl(18)=nbitsd/8      ! num bits used for extra spatial
+                                    ! differencing values
+      endif
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/mkieee.F b/wrfv2_fire/external/io_grib2/g2lib/mkieee.F
new file mode 100644
index 00000000..1e625f8d
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/mkieee.F
@@ -0,0 +1,103 @@
+      subroutine mkieee(a,rieee,num)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    mkieee 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-09
+!
+! ABSTRACT: This subroutine stores a list of real values in 
+!   32-bit IEEE floating point format.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-09  Gilbert
+!
+! USAGE:    CALL mkieee(a,rieee,num)
+!   INPUT ARGUMENT LIST:
+!     a        - Input array of floating point values.
+!     num      - Number of floating point values to convert.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     rieee    - Output array of floating point values in 32-bit IEEE format.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      real,intent(in) :: a(num)
+      real(4),intent(out) :: rieee(num)
+      integer,intent(in) :: num
+
+      integer(4) :: ieee 
+
+      real,save :: two23
+      real,save :: two126
+      integer,save :: once=0
+
+      if ( once .EQ. 0 ) then
+         once=1
+         two23=scale(1.0,23)
+         two126=scale(1.0,126)
+      endif
+
+      alog2=alog(2.0)
+
+      do j=1,num
+        ieee=0
+
+        if (a(j).eq.0.) then
+          ieee=0
+          rieee(j)=transfer(ieee,rieee(j))
+!       write(6,fmt='(f20.10,5x,b32)') a,a
+!       write(6,fmt='(f20.10,5x,b32)') rieee,rieee
+          cycle
+        endif
+        
+!
+!  Set Sign bit (bit 31 - leftmost bit)
+!
+        if (a(j).lt.0.0) then
+          ieee=ibset(ieee,31)
+          atemp=abs(a(j))
+        else
+          ieee=ibclr(ieee,31)
+          atemp=a(j)
+        endif
+!
+!  Determine exponent n with base 2
+!
+        n=floor(alog(atemp)/alog2)
+        iexp=n+127
+        if (n.gt.127) iexp=255     ! overflow
+        if (n.lt.-127) iexp=0
+        !      set exponent bits ( bits 30-23 )
+        call mvbits(iexp,0,8,ieee,23)
+!
+!  Determine Mantissa
+! 
+        if (iexp.ne.255) then
+          if (iexp.ne.0) then
+            atemp=(atemp/(2.0**n))-1.0
+          else
+            atemp=atemp*two126
+          endif
+          imant=nint(atemp*two23)
+        else
+          imant=0
+        endif
+        !      set mantissa bits ( bits 22-0 )
+        call mvbits(imant,0,23,ieee,0)
+!
+!  Transfer IEEE bit string to real variable
+!
+        rieee(j)=transfer(ieee,rieee(j))
+!       write(6,fmt='(f20.10,5x,b32)') a,a
+!       write(6,fmt='(f20.10,5x,b32)') rieee,rieee
+
+      enddo
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/mova2i.c b/wrfv2_fire/external/io_grib2/g2lib/mova2i.c
new file mode 100644
index 00000000..a6d35395
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/mova2i.c
@@ -0,0 +1,42 @@
+/*$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C                .      .    .                                       .
+C SUBPROGRAM:    mova2i      Moves a bit string from a char*1 to int
+C   PRGMMR: Gilbert          ORG: W/NP11     DATE: 02-08-15
+C
+C ABSTRACT: This Function copies a bit string from a Character*1 variable
+C   to an integer variable.  It is intended to replace the Fortran Intrinsic
+C   Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the
+C   IBM SP.  If "a" is greater than 127 in the collating sequence,
+C   ICHAR(a) does not return the expected bit value.
+C   This function can be used for all values 0 <= ICHAR(a) <= 255.
+C
+C PROGRAM HISTORY LOG:
+C   98-12-15  Gilbert
+C
+C USAGE:     I = mova2i(a)
+C
+C   INPUT ARGUMENT :
+C
+C          a - Character*1 variable that holds the bitstring to extract
+C
+C   RETURN ARGUMENT :
+C
+C          mova2i - Integer value of the bitstring in character a
+C
+C REMARKS:
+C
+C      None
+C
+C ATTRIBUTES:
+C   LANGUAGE: C
+C   MACHINE:  IBM SP
+
+C
+C$$$i*/
+
+#include "proto.h"
+
+int MOVA2I(unsigned char *a)
+{
+    return (int)(*a);
+}
diff --git a/wrfv2_fire/external/io_grib2/g2lib/pack_gp.F b/wrfv2_fire/external/io_grib2/g2lib/pack_gp.F
new file mode 100644
index 00000000..3e9ea2cb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/pack_gp.F
@@ -0,0 +1,1195 @@
+      SUBROUTINE PACK_GP(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS,
+     1                   JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT,
+     2                   NOVREF,LBITREF,IER)            
+C
+C        FEBRUARY 1994   GLAHN   TDL   MOS-2000
+C        JUNE     1995   GLAHN   MODIFIED FOR LMISS ERROR.
+C        JULY     1996   GLAHN   ADDED MISSS
+C        FEBRUARY 1997   GLAHN   REMOVED 4 REDUNDANT TESTS FOR
+C                                MISSP.EQ.0; INSERTED A TEST TO BETTER
+C                                HANDLE A STRING OF 9999'S
+C        FEBRUARY 1997   GLAHN   ADDED LOOPS TO ELIMINATE TEST FOR 
+C                                MISSS WHEN MISSS = 0
+C        MARCH    1997   GLAHN   CORRECTED FOR SECONDARY MISSING VALUE
+C        MARCH    1997   GLAHN   CORRECTED FOR USE OF LOCAL VALUE
+C                                OF MINPK
+C        MARCH    1997   GLAHN   CORRECTED FOR SECONDARY MISSING VALUE
+C        MARCH    1997   GLAHN   CHANGED CALCULATING NUMBER OF BITS 
+C                                THROUGH EXPONENTS TO AN ARRAY (IMPROVED
+C                                OVERALL PACKING PERFORMANCE BY ABOUT
+C                                35 PERCENT!).  ALLOWED 0 BITS FOR
+C                                PACKING JMIN( ), LBIT( ), AND NOV( ).
+C        MAY      1997   GLAHN   A NUMBER OF CHANGES FOR EFFICIENCY.
+C                                MOD FUNCTIONS ELIMINATED AND ONE
+C                                IFTHEN ADDED.  JOUNT REMOVED.
+C                                RECOMPUTATION OF BITS NOT MADE UNLESS
+C                                NECESSARY AFTER MOVING POINTS FROM
+C                                ONE GROUP TO ANOTHER.  NENDB ADJUSTED
+C                                TO ELIMINATE POSSIBILITY OF VERY
+C                                SMALL GROUP AT THE END. 
+C                                ABOUT 8 PERCENT IMPROVEMENT IN
+C                                OVERALL PACKING.  ISKIPA REMOVED;
+C                                THERE IS ALWAYS A GROUP B THAT CAN
+C                                BECOME GROUP A.  CONTROL ON SIZE 
+C                                OF GROUP B (STATEMENT BELOW 150)
+C                                ADDED.  ADDED ADDA, AND USE
+C                                OF GE AND LE INSTEAD OF GT AND LT
+C                                IN LOOPS BETWEEN 150 AND 160.
+C                                IBITBS ADDED TO SHORTEN TRIPS 
+C                                THROUGH LOOP.
+C        MARCH    2000   GLAHN   MODIFIED FOR GRIB2; CHANGED NAME FROM 
+C                                PACKGP
+C        JANUARY  2001   GLAHN   COMMENTS; IER = 706 SUBSTITUTED FOR
+C                                STOPS; ADDED RETURN1; REMOVED STATEMENT
+C                                NUMBER 110; ADDED IER AND * RETURN
+C        NOVEMBER 2001   GLAHN   CHANGED SOME DIAGNOSTIC FORMATS TO 
+C                                ALLOW PRINTING LARGER NUMBERS
+C        NOVEMBER 2001   GLAHN   ADDED MISSLX( ) TO PUT MAXIMUM VALUE
+C                                INTO JMIN( ) WHEN ALL VALUES MISSING
+C                                TO AGREE WITH GRIB STANDARD.
+C        NOVEMBER 2001   GLAHN   CHANGED TWO TESTS ON MISSP AND MISSS
+C                                EQ 0 TO TESTS ON IS523.  HOWEVER,
+C                                MISSP AND MISSS CANNOT IN GENERAL BE
+C                                = 0.
+C        NOVEMBER 2001   GLAHN   ADDED CALL TO REDUCE; DEFINED ITEST
+C                                BEFORE LOOPS TO REDUCE COMPUTATION;
+C                                STARTED LARGE GROUP WHEN ALL SAME
+C                                VALUE
+C        DECEMBER 2001   GLAHN   MODIFIED AND ADDED A FEW COMMENTS
+C        JANUARY  2002   GLAHN   REMOVED LOOP BEFORE 150 TO DETERMINE
+C                                A GROUP OF ALL SAME VALUE
+C        JANUARY  2002   GLAHN   CHANGED MALLOW FROM 9999999 TO 2**30+1,
+C                                AND MADE IT A PARAMETER
+C        MARCH    2002   GLAHN   ADDED NON FATAL IER = 716, 717;
+C                                REMOVED NENDB=NXY ABOVE 150;
+C                                ADDED IERSAV=0; COMMENTS
+C
+C        PURPOSE
+C            DETERMINES GROUPS OF VARIABLE SIZE, BUT AT LEAST OF
+C            SIZE MINPK, THE ASSOCIATED MAX (JMAX( )) AND MIN (JMIN( )),
+C            THE NUMBER OF BITS NECESSARY TO HOLD THE VALUES IN EACH
+C            GROUP (LBIT( )), THE NUMBER OF VALUES IN EACH GROUP
+C            (NOV( )), THE NUMBER OF BITS NECESSARY TO PACK THE JMIN( )
+C            VALUES (IBIT), THE NUMBER OF BITS NECESSARY TO PACK THE
+C            LBIT( ) VALUES (JBIT), AND THE NUMBER OF BITS NECESSARY
+C            TO PACK THE NOV( ) VALUES (KBIT).  THE ROUTINE IS DESIGNED
+C            TO DETERMINE THE GROUPS SUCH THAT A SMALL NUMBER OF BITS
+C            IS NECESSARY TO PACK THE DATA WITHOUT EXCESSIVE
+C            COMPUTATIONS.  IF ALL VALUES IN THE GROUP ARE ZERO, THE
+C            NUMBER OF BITS TO USE IN PACKING IS DEFINED AS ZERO WHEN
+C            THERE CAN BE NO MISSING VALUES; WHEN THERE CAN BE MISSING
+C            VALUES, THE NUMBER OF BITS MUST BE AT LEAST 1 TO HAVE
+C            THE CAPABILITY TO RECOGNIZE THE MISSING VALUE.  HOWEVER,
+C            IF ALL VALUES IN A GROUP ARE MISSING, THE NUMBER OF BITS
+C            NEEDED IS 0, AND THE UNPACKER RECOGNIZES THIS.
+C            ALL VARIABLES ARE INTEGER.  EVEN THOUGH THE GROUPS ARE 
+C            INITIALLY OF SIZE MINPK OR LARGER, AN ADJUSTMENT BETWEEN
+C            TWO GROUPS (THE LOOKBACK PROCEDURE) MAY MAKE A GROUP 
+C            SMALLER THAN MINPK.  THE CONTROL ON GROUP SIZE IS THAT
+C            THE SUM OF THE SIZES OF THE TWO CONSECUTIVE GROUPS, EACH OF
+C            SIZE MINPK OR LARGER, IS NOT DECREASED.  WHEN DETERMINING
+C            THE NUMBER OF BITS NECESSARY FOR PACKING, THE LARGEST
+C            VALUE THAT CAN BE ACCOMMODATED IN, SAY, MBITS, IS
+C            2**MBITS-1; THIS LARGEST VALUE (AND THE NEXT SMALLEST
+C            VALUE) IS RESERVED FOR THE MISSING VALUE INDICATOR (ONLY)
+C            WHEN IS523 NE 0.  IF THE DIMENSION NDG
+C            IS NOT LARGE ENOUGH TO HOLD ALL THE GROUPS, THE LOCAL VALUE
+C            OF MINPK IS INCREASED BY 50 PERCENT.  THIS IS REPEATED
+C            UNTIL NDG WILL SUFFICE.  A DIAGNOSTIC IS PRINTED WHENEVER
+C            THIS HAPPENS, WHICH SHOULD BE VERY RARELY.  IF IT HAPPENS
+C            OFTEN, NDG IN SUBROUTINE PACK SHOULD BE INCREASED AND
+C            A CORRESPONDING INCREASE IN SUBROUTINE UNPACK MADE. 
+C            CONSIDERABLE CODE IS PROVIDED SO THAT NO MORE CHECKING
+C            FOR MISSING VALUES WITHIN LOOPS IS DONE THAN NECESSARY;
+C            THE ADDED EFFICIENCY OF THIS IS RELATIVELY MINOR,
+C            BUT DOES NO HARM.  FOR GRIB2, THE REFERENCE VALUE FOR
+C            THE LENGTH OF GROUPS IN NOV( ) AND FOR THE NUMBER OF
+C            BITS NECESSARY TO PACK GROUP VALUES ARE DETERMINED,
+C            AND SUBTRACTED BEFORE JBIT AND KBIT ARE DETERMINED.
+C
+C            WHEN 1 OR MORE GROUPS ARE LARGE COMPARED TO THE OTHERS,
+C            THE WIDTH OF ALL GROUPS MUST BE AS LARGE AS THE LARGEST.
+C            A SUBROUTINE REDUCE BREAKS UP LARGE GROUPS INTO 2 OR
+C            MORE TO REDUCE TOTAL BITS REQUIRED.  IF REDUCE SHOULD
+C            ABORT, PACK_GP WILL BE EXECUTED AGAIN WITHOUT THE CALL
+C            TO REDUCE.
+C
+C        DATA SET USE 
+C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) 
+C
+C        VARIABLES IN CALL SEQUENCE 
+C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE.  (INPUT)
+C               IC( ) = ARRAY TO HOLD DATA FOR PACKING.  THE VALUES
+C                       DO NOT HAVE TO BE POSITIVE AT THIS POINT, BUT
+C                       MUST BE IN THE RANGE -2**30 TO +2**30 (THE 
+C                       THE VALUE OF MALLOW).  THESE INTEGER VALUES
+C                       WILL BE RETAINED EXACTLY THROUGH PACKING AND
+C                       UNPACKING.  (INPUT)
+C                 NXY = NUMBER OF VALUES IN IC( ).  ALSO TREATED
+C                       AS ITS DIMENSION.  (INPUT)
+C              IS523  = missing value management
+C                       0=data contains no missing values
+C                       1=data contains Primary missing values
+C                       2=data contains Primary and secondary missing values
+C                       (INPUT)
+C               MINPK = THE MINIMUM SIZE OF EACH GROUP, EXCEPT POSSIBLY
+C                       THE LAST ONE.  (INPUT)
+C                 INC = THE NUMBER OF VALUES TO ADD TO AN ALREADY
+C                       EXISTING GROUP IN DETERMINING WHETHER OR NOT
+C                       TO START A NEW GROUP.  IDEALLY, THIS WOULD BE
+C                       1, BUT EACH TIME INC VALUES ARE ATTEMPTED, THE
+C                       MAX AND MIN OF THE NEXT MINPK VALUES MUST BE
+C                       FOUND.  THIS IS "A LOOP WITHIN A LOOP," AND
+C                       A SLIGHTLY LARGER VALUE MAY GIVE ABOUT AS GOOD
+C                       RESULTS WITH SLIGHTLY LESS COMPUTATIONAL TIME.
+C                       IF INC IS LE 0, 1 IS USED, AND A DIAGNOSTIC IS
+C                       OUTPUT.  NOTE:  IT IS EXPECTED THAT INC WILL
+C                       EQUAL 1.  THE CODE USES INC PRIMARILY IN THE
+C                       LOOPS STARTING AT STATEMENT 180.  IF INC
+C                       WERE 1, THERE WOULD NOT NEED TO BE LOOPS
+C                       AS SUCH.  HOWEVER, KINC (THE LOCAL VALUE OF
+C                       INC) IS SET GE 1 WHEN NEAR THE END OF THE DATA
+C                       TO FORESTALL A VERY SMALL GROUP AT THE END. 
+C                       (INPUT)
+C               MISSP = WHEN MISSING POINTS CAN BE PRESENT IN THE DATA,
+C                       THEY WILL HAVE THE VALUE MISSP OR MISSS.
+C                       MISSP IS THE PRIMARY MISSING VALUE AND  MISSS
+C                       IS THE SECONDARY MISSING VALUE .  THESE MUST
+C                       NOT BE VALUES THAT WOULD OCCUR WITH SUBTRACTING
+C                       THE MINIMUM (REFERENCE) VALUE OR SCALING.
+C                       FOR EXAMPLE, MISSP = 0 WOULD NOT BE ADVISABLE.
+C                       (INPUT)
+C               MISSS = SECONDARY MISSING VALUE INDICATOR (SEE MISSP).
+C                       (INPUT)
+C             JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX).  (OUTPUT)
+C             JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX).  THIS IS
+C                       NOT REALLY NEEDED, BUT SINCE THE MAX OF EACH
+C                       GROUP MUST BE FOUND, SAVING IT HERE IS CHEAP
+C                       IN CASE THE USER WANTS IT.  (OUTPUT)
+C             LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP
+C                       (J=1,LX).  IT IS ASSUMED THE MINIMUM OF EACH
+C                       GROUP WILL BE REMOVED BEFORE PACKING, AND THE
+C                       VALUES TO PACK WILL, THEREFORE, ALL BE POSITIVE.
+C                       HOWEVER, IC( ) DOES NOT NECESSARILY CONTAIN
+C                       ALL POSITIVE VALUES.  IF THE OVERALL MINIMUM
+C                       HAS BEEN REMOVED (THE USUAL CASE), THEN IC( )
+C                       WILL CONTAIN ONLY POSITIVE VALUES.  (OUTPUT)
+C              NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX).
+C                       (OUTPUT)
+C                 NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND
+C                       NOV( ).  (INPUT)
+C                  LX = THE NUMBER OF GROUPS DETERMINED.  (OUTPUT)
+C                IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J)
+C                       VALUES, J=1,LX.  (OUTPUT)
+C                JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J)
+C                       VALUES, J=1,LX.  (OUTPUT)
+C                KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J)
+C                       VALUES, J=1,LX.  (OUTPUT)
+C              NOVREF = REFERENCE VALUE FOR NOV( ).  (OUTPUT)
+C             LBITREF = REFERENCE VALUE FOR LBIT( ).  (OUTPUT)
+C                 IER = ERROR RETURN.
+C                       706 = VALUE WILL NOT PACK IN 30 BITS--FATAL
+C                       714 = ERROR IN REDUCE--NON-FATAL
+C                       715 = NGP NOT LARGE ENOUGH IN REDUCE--NON-FATAL
+C                       716 = MINPK INCEASED--NON-FATAL
+C                       717 = INC SET = 1--NON-FATAL
+C                       (OUTPUT)
+C                   * = ALTERNATE RETURN WHEN IER NE 0 AND FATAL ERROR.
+C
+C        INTERNAL VARIABLES 
+C               CFEED = CONTAINS THE CHARACTER REPRESENTATION
+C                       OF A PRINTER FORM FEED.
+C               IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
+C                       FORM FEED.
+C                KINC = WORKING COPY OF INC.  MAY BE MODIFIED.
+C                MINA = MINIMUM VALUE IN GROUP A.
+C                MAXA = MAXIMUM VALUE IN GROUP A.
+C               NENDA = THE PLACE IN IC( ) WHERE GROUP A ENDS.
+C              KSTART = THE PLACE IN IC( ) WHERE GROUP A STARTS.
+C               IBITA = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP A.
+C                MINB = MINIMUM VALUE IN GROUP B.
+C                MAXB = MAXIMUM VALUE IN GROUP B.
+C               NENDB = THE PLACE IN IC( ) WHERE GROUP B ENDS.
+C               IBITB = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP B.
+C                MINC = MINIMUM VALUE IN GROUP C.
+C                MAXC = MAXIMUM VALUE IN GROUP C.
+C              KTOTAL = COUNT OF NUMBER OF VALUES IN IC( ) PROCESSED.
+C               NOUNT = NUMBER OF VALUES ADDED TO GROUP A.
+C               LMISS = 0 WHEN IS523 = 0.  WHEN PACKING INTO A 
+C                       SPECIFIC NUMBER OF BITS, SAY MBITS,
+C                       THE MAXIMUM VALUE THAT CAN BE HANDLED IS
+C                       2**MBITS-1.  WHEN IS523 = 1, INDICATING
+C                       PRIMARY MISSING VALUES, THIS MAXIMUM VALUE 
+C                       IS RESERVED TO HOLD THE PRIMARY MISSING VALUE 
+C                       INDICATOR AND LMISS = 1.  WHEN IS523 = 2,
+C                       THE VALUE JUST BELOW THE MAXIMUM (I.E.,
+C                       2**MBITS-2) IS RESERVED TO HOLD THE SECONDARY 
+C                       MISSING VALUE INDICATOR AND LMISS = 2.
+C              LMINPK = LOCAL VALUE OF MINPK.  THIS WILL BE ADJUSTED
+C                       UPWARD WHENEVER NDG IS NOT LARGE ENOUGH TO HOLD
+C                       ALL THE GROUPS.
+C              MALLOW = THE LARGEST ALLOWABLE VALUE FOR PACKING.
+C              MISLLA = SET TO 1 WHEN ALL VALUES IN GROUP A ARE MISSING.
+C                       THIS IS USED TO DISTINGUISH BETWEEN A REAL
+C                       MINIMUM WHEN ALL VALUES ARE NOT MISSING
+C                       AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN
+C                       ALL VALUES ARE MISSING.  0 OTHERWISE.
+C                       NOTE THAT THIS DOES NOT DISTINGUISH BETWEEN
+C                       PRIMARY AND SECONDARY MISSINGS WHEN SECONDARY
+C                       MISSINGS ARE PRESENT.  THIS MEANS THAT 
+C                       LBIT( ) WILL NOT BE ZERO WITH THE RESULTING
+C                       COMPRESSION EFFICIENCY WHEN SECONDARY MISSINGS
+C                       ARE PRESENT.  ALSO NOTE THAT A CHECK HAS BEEN
+C                       MADE EARLIER TO DETERMINE THAT SECONDARY
+C                       MISSINGS ARE REALLY THERE.
+C              MISLLB = SET TO 1 WHEN ALL VALUES IN GROUP B ARE MISSING.
+C                       THIS IS USED TO DISTINGUISH BETWEEN A REAL
+C                       MINIMUM WHEN ALL VALUES ARE NOT MISSING
+C                       AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN
+C                       ALL VALUES ARE MISSING.  0 OTHERWISE.
+C              MISLLC = PERFORMS THE SAME FUNCTION FOR GROUP C THAT
+C                       MISLLA AND MISLLB DO FOR GROUPS B AND C,
+C                       RESPECTIVELY.
+C            IBXX2(J) = AN ARRAY THAT WHEN THIS ROUTINE IS FIRST ENTERED
+C                       IS SET TO 2**J, J=0,30. IBXX2(30) = 2**30, WHICH
+C                       IS THE LARGEST VALUE PACKABLE, BECAUSE 2**31
+C                       IS LARGER THAN THE INTEGER WORD SIZE.
+C              IFIRST = SET BY DATA STATEMENT TO 0.  CHANGED TO 1 ON
+C                       FIRST
+C                       ENTRY WHEN IBXX2( ) IS FILLED.
+C               MINAK = KEEPS TRACK OF THE LOCATION IN IC( ) WHERE THE 
+C                       MINIMUM VALUE IN GROUP A IS LOCATED.
+C               MAXAK = DOES THE SAME AS MINAK, EXCEPT FOR THE MAXIMUM.
+C               MINBK = THE SAME AS MINAK FOR GROUP B.
+C               MAXBK = THE SAME AS MAXAK FOR GROUP B.
+C               MINCK = THE SAME AS MINAK FOR GROUP C.
+C               MAXCK = THE SAME AS MAXAK FOR GROUP C.
+C                ADDA = KEEPS TRACK WHETHER OR NOT AN ATTEMPT TO ADD
+C                       POINTS TO GROUP A WAS MADE.  IF SO, THEN ADDA
+C                       KEEPS FROM TRYING TO PUT ONE BACK INTO B.
+C                       (LOGICAL)
+C              IBITBS = KEEPS CURRENT VALUE IF IBITB SO THAT LOOP
+C                       ENDING AT 166 DOESN'T HAVE TO START AT
+C                       IBITB = 0 EVERY TIME.
+C           MISSLX(J) = MALLOW EXCEPT WHEN A GROUP IS ALL ONE VALUE (AND
+C                       LBIT(J) = 0) AND THAT VALUE IS MISSING.  IN
+C                       THAT CASE, MISSLX(J) IS MISSP OR MISSS.  THIS
+C                       GETS INSERTED INTO JMIN(J) LATER AS THE 
+C                       MISSING INDICATOR; IT CAN'T BE PUT IN UNTIL
+C                       THE END, BECAUSE JMIN( ) IS USED TO CALCULATE
+C                       THE MAXIMUM NUMBER OF BITS (IBITS) NEEDED TO
+C                       PACK JMIN( ).
+C        1         2         3         4         5         6         7 X
+C
+C        NON SYSTEM SUBROUTINES CALLED 
+C           NONE
+C
+      PARAMETER (MALLOW=2**30+1)
+C
+      CHARACTER*1 CFEED
+      LOGICAL ADDA
+C
+      DIMENSION IC(NXY)
+      DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG)
+      DIMENSION MISSLX(NDG)
+C        MISSLX( ) IS AN AUTOMATIC ARRAY.
+      DIMENSION IBXX2(0:30)
+C
+      SAVE IBXX2
+C
+      DATA IFEED/12/
+      DATA IFIRST/0/
+C
+      IER=0
+      IERSAV=0
+C     CALL TIMPR(KFILDO,KFILDO,'START PACK_GP        ')
+      CFEED=CHAR(IFEED)
+C
+      IRED=0
+C        IRED IS A FLAG.  WHEN ZERO, REDUCE WILL BE CALLED.
+C        IF REDUCE ABORTS, IRED = 1 AND IS NOT CALLED.  IN
+C        THIS CASE PACK_GP EXECUTES AGAIN EXCEPT FOR REDUCE.
+C
+      IF(INC.LE.0)THEN
+         IERSAV=717
+C        WRITE(KFILDO,101)INC
+C101     FORMAT(/' ****INC ='I8,' NOT CORRECT IN PACK_GP.  1 IS USED.')
+      ENDIF
+C
+C        THERE WILL BE A RESTART OF PACK_GP IF SUBROUTINE REDUCE
+C        ABORTS.  THIS SHOULD NOT HAPPEN, BUT IF IT DOES, PACK_GP
+C        WILL COMPLETE WITHOUT SUBROUTINE REDUCE.  A NON FATAL
+C        DIAGNOSTIC RETURN IS PROVIDED.
+C
+ 102  KINC=MAX(INC,1)
+      LMINPK=MINPK
+C
+C         CALCULATE THE POWERS OF 2 THE FIRST TIME ENTERED.
+C
+      IF(IFIRST.EQ.0)THEN
+         IFIRST=1
+         IBXX2(0)=1
+C
+         DO 104 J=1,30
+         IBXX2(J)=IBXX2(J-1)*2
+ 104     CONTINUE
+C
+      ENDIF
+C
+C        THERE WILL BE A RESTART AT 105 IS NDG IS NOT LARGE ENOUGH.
+C        A NON FATAL DIAGNOSTIC RETURN IS PROVIDED.
+C
+ 105  KSTART=1
+      KTOTAL=0
+      LX=0
+      ADDA=.FALSE.
+      LMISS=0
+      IF(IS523.EQ.1)LMISS=1
+      IF(IS523.EQ.2)LMISS=2
+C
+C        *************************************
+C
+C        THIS SECTION COMPUTES STATISTICS FOR GROUP A.  GROUP A IS
+C        A GROUP OF SIZE LMINPK.
+C
+C        *************************************
+C
+      IBITA=0
+      MINA=MALLOW
+      MAXA=-MALLOW
+      MINAK=MALLOW
+      MAXAK=-MALLOW
+C
+C        FIND THE MIN AND MAX OF GROUP A.  THIS WILL INITIALLY BE OF
+C        SIZE LMINPK (IF THERE ARE STILL LMINPK VALUES IN IC( )), BUT
+C        WILL INCREASE IN SIZE IN INCREMENTS OF INC UNTIL A NEW
+C        GROUP IS STARTED.  THE DEFINITION OF GROUP A IS DONE HERE
+C        ONLY ONCE (UPON INITIAL ENTRY), BECAUSE A GROUP B CAN ALWAYS
+C        BECOME A NEW GROUP A AFTER A IS PACKED, EXCEPT IF LMINPK 
+C        HAS TO BE INCREASED BECAUSE NDG IS TOO SMALL.  THEREFORE,
+C        THE SEPARATE LOOPS FOR MISSING AND NON-MISSING HERE BUYS
+C        ALMOST NOTHING.
+C
+      NENDA=MIN(KSTART+LMINPK-1,NXY)
+      IF(NXY-NENDA.LE.LMINPK/2)NENDA=NXY
+C        ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY 
+C        MAKING THE ACTUAL GROUP LARGER.  IF A PROVISION LIKE THIS IS 
+C        NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
+C        AT THE END.  USE SEPARATE LOOPS FOR MISSING AND NO MISSING
+C        VALUES FOR EFFICIENCY.
+C
+C        DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE
+C        UNLESS NENDA = NXY.  THIS MAY ALLOW A LARGE GROUP A TO
+C        START WITH, AS WITH MISSING VALUES.   SEPARATE LOOPS FOR
+C        MISSING OPTIONS.  THIS SECTION IS ONLY EXECUTED ONCE,
+C        IN DETERMINING THE FIRST GROUP.  IT HELPS FOR AN ARRAY
+C        OF MOSTLY MISSING VALUES OR OF ONE VALUE, SUCH AS
+C        RADAR OR PRECIP DATA.
+C
+      IF(NENDA.NE.NXY.AND.IC(KSTART).EQ.IC(KSTART+1))THEN
+C           NO NEED TO EXECUTE IF FIRST TWO VALUES ARE NOT EQUAL.
+C
+         IF(IS523.EQ.0)THEN
+C              THIS LOOP IS FOR NO MISSING VALUES.
+C
+            DO 111 K=KSTART+1,NXY
+C
+               IF(IC(K).NE.IC(KSTART))THEN
+                  NENDA=MAX(NENDA,K-1)
+                  GO TO 114
+               ENDIF
+C
+ 111        CONTINUE
+C
+            NENDA=NXY
+C              FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
+C
+         ELSEIF(IS523.EQ.1)THEN
+C              THIS LOOP IS FOR PRIMARY MISSING VALUES ONLY.
+C
+            DO 112 K=KSTART+1,NXY
+C        
+               IF(IC(K).NE.MISSP)THEN
+C
+                  IF(IC(K).NE.IC(KSTART))THEN
+                     NENDA=MAX(NENDA,K-1)
+                     GO TO 114
+                  ENDIF
+C
+               ENDIF
+C
+ 112        CONTINUE
+C
+            NENDA=NXY
+C              FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
+C
+         ELSE
+C              THIS LOOP IS FOR PRIMARY AND SECONDARY MISSING VALUES.
+C
+            DO 113 K=KSTART+1,NXY
+C        
+               IF(IC(K).NE.MISSP.AND.IC(K).NE.MISSS)THEN
+C
+                  IF(IC(K).NE.IC(KSTART))THEN
+                     NENDA=MAX(NENDA,K-1)
+                     GO TO 114
+                  ENDIF
+C
+               ENDIF
+C
+ 113        CONTINUE
+C
+            NENDA=NXY
+C              FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME.
+         ENDIF
+C
+      ENDIF
+C
+ 114  IF(IS523.EQ.0)THEN
+C
+         DO 115 K=KSTART,NENDA
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+            MINAK=K
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+            MAXAK=K
+         ENDIF
+ 115     CONTINUE
+C
+      ELSEIF(IS523.EQ.1)THEN
+C
+         DO 117 K=KSTART,NENDA
+         IF(IC(K).EQ.MISSP)GO TO 117
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+            MINAK=K
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+            MAXAK=K
+         ENDIF
+ 117     CONTINUE
+C
+      ELSE
+C
+         DO 120 K=KSTART,NENDA
+         IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 120
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+            MINAK=K
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+            MAXAK=K
+         ENDIF
+ 120     CONTINUE
+C
+      ENDIF
+C
+      KOUNTA=NENDA-KSTART+1
+C
+C        INCREMENT KTOTAL AND FIND THE BITS NEEDED TO PACK THE A GROUP.
+C
+      KTOTAL=KTOTAL+KOUNTA
+      MISLLA=0
+      IF(MINA.NE.MALLOW)GO TO 125
+C        ALL MISSING VALUES MUST BE ACCOMMODATED.
+      MINA=0
+      MAXA=0
+      MISLLA=1
+      IBITB=0
+      IF(IS523.NE.2)GO TO 130
+C        WHEN ALL VALUES ARE MISSING AND THERE ARE NO
+C        SECONDARY MISSING VALUES, IBITA = 0.
+C        OTHERWISE, IBITA MUST BE CALCULATED.
+C
+ 125  ITEST=MAXA-MINA+LMISS
+C  
+      DO 126 IBITA=0,30
+      IF(ITEST.LT.IBXX2(IBITA))GO TO 130
+C***        THIS TEST IS THE SAME AS:
+C***     IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 130
+ 126  CONTINUE
+C
+C     WRITE(KFILDO,127)MAXA,MINA
+C127  FORMAT(' ****ERROR IN PACK_GP.  VALUE WILL NOT PACK IN 30 BITS.',
+C    1       '  MAXA ='I13,'  MINA ='I13,'.  ERROR AT 127.')
+      IER=706
+      GO TO 900
+C
+ 130  CONTINUE
+C
+C***D     WRITE(KFILDO,131)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA
+C***D131  FORMAT(' AT 130, KOUNTA ='I8,'  KTOTAL ='I8,'  MINA ='I8,
+C***D    1       '  MAXA ='I8,'  IBITA ='I3,'  MISLLA ='I3) 
+C
+ 133  IF(KTOTAL.GE.NXY)GO TO 200
+C
+C        *************************************
+C
+C        THIS SECTION COMPUTES STATISTICS FOR GROUP B.  GROUP B IS A
+C        GROUP OF SIZE LMINPK IMMEDIATELY FOLLOWING GROUP A.
+C
+C        *************************************
+C
+ 140  MINB=MALLOW
+      MAXB=-MALLOW
+      MINBK=MALLOW
+      MAXBK=-MALLOW
+      IBITBS=0
+      MSTART=KTOTAL+1
+C
+C        DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE.
+C        THIS WORKS WHEN THERE ARE NO MISSING VALUES.
+C
+      NENDB=1
+C
+      IF(MSTART.LT.NXY)THEN
+C
+         IF(IS523.EQ.0)THEN
+C              THIS LOOP IS FOR NO MISSING VALUES.
+C
+            DO 145 K=MSTART+1,NXY
+C
+               IF(IC(K).NE.IC(MSTART))THEN
+                  NENDB=K-1
+                  GO TO 150
+               ENDIF
+C
+ 145        CONTINUE
+C
+            NENDB=NXY
+C              FALL THROUGH THE LOOP MEANS ALL REMAINING VALUES
+C              ARE THE SAME.
+         ENDIF
+C
+      ENDIF
+C         
+ 150  NENDB=MAX(NENDB,MIN(KTOTAL+LMINPK,NXY))
+C**** 150  NENDB=MIN(KTOTAL+LMINPK,NXY)
+C
+      IF(NXY-NENDB.LE.LMINPK/2)NENDB=NXY
+C        ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY 
+C        MAKING THE ACTUAL GROUP LARGER.  IF A PROVISION LIKE THIS IS 
+C        NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP
+C        AT THE END.  USE SEPARATE LOOPS FOR MISSING AND NO MISSING
+C
+C        USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
+C        FOR EFFICIENCY.
+C
+      IF(IS523.EQ.0)THEN
+C              
+         DO 155 K=MSTART,NENDB
+         IF(IC(K).LE.MINB)THEN
+            MINB=IC(K)
+C              NOTE LE, NOT LT.  LT COULD BE USED BUT THEN A 
+C              RECOMPUTE OVER THE WHOLE GROUP WOULD BE NEEDED
+C              MORE OFTEN.  SAME REASONING FOR GE AND OTHER
+C              LOOPS BELOW.
+            MINBK=K
+         ENDIF
+         IF(IC(K).GE.MAXB)THEN
+            MAXB=IC(K)
+            MAXBK=K
+         ENDIF
+ 155     CONTINUE
+C
+      ELSEIF(IS523.EQ.1)THEN
+C
+         DO 157 K=MSTART,NENDB
+         IF(IC(K).EQ.MISSP)GO TO 157
+         IF(IC(K).LE.MINB)THEN
+            MINB=IC(K)
+            MINBK=K
+         ENDIF
+         IF(IC(K).GE.MAXB)THEN
+            MAXB=IC(K)
+            MAXBK=K
+         ENDIF
+ 157     CONTINUE
+C
+      ELSE
+C
+         DO 160 K=MSTART,NENDB
+         IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 160
+         IF(IC(K).LE.MINB)THEN
+            MINB=IC(K)
+            MINBK=K
+         ENDIF
+         IF(IC(K).GE.MAXB)THEN
+            MAXB=IC(K)
+            MAXBK=K
+         ENDIF
+ 160     CONTINUE
+C
+      ENDIF
+C
+      KOUNTB=NENDB-KTOTAL
+      MISLLB=0
+      IF(MINB.NE.MALLOW)GO TO 165
+C        ALL MISSING VALUES MUST BE ACCOMMODATED.
+      MINB=0
+      MAXB=0
+      MISLLB=1
+      IBITB=0
+C
+      IF(IS523.NE.2)GO TO 170
+C        WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
+C        MISSING VALUES, IBITB = 0.  OTHERWISE, IBITB MUST BE
+C        CALCULATED.
+C
+ 165  DO 166 IBITB=IBITBS,30
+         IF(MAXB-MINB.LT.IBXX2(IBITB)-LMISS)GO TO 170
+ 166  CONTINUE
+C
+C     WRITE(KFILDO,167)MAXB,MINB
+C167  FORMAT(' ****ERROR IN PACK_GP.  VALUE WILL NOT PACK IN 30 BITS.',
+C    1       '  MAXB ='I13,'  MINB ='I13,'.  ERROR AT 167.')
+      IER=706
+      GO TO 900
+C
+C        COMPARE THE BITS NEEDED TO PACK GROUP B WITH THOSE NEEDED
+C        TO PACK GROUP A.  IF IBITB GE IBITA, TRY TO ADD TO GROUP A.
+C        IF NOT, TRY TO ADD A'S POINTS TO B, UNLESS ADDITION TO A
+C        HAS BEEN DONE.  THIS LATTER IS CONTROLLED WITH ADDA.
+C
+ 170  CONTINUE
+C
+C***D     WRITE(KFILDO,171)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
+C***D    1                               MINB,MAXB,IBITB,MISLLB
+C***D171  FORMAT(' AT 171, KOUNTA ='I8,'  KTOTAL ='I8,'  MINA ='I8,
+C***D    1       '  MAXA ='I8,'  IBITA ='I3,'  MISLLA ='I3,
+C***D    2       '  MINB ='I8,'  MAXB ='I8,'  IBITB ='I3,'  MISLLB ='I3)  
+C
+      IF(IBITB.GE.IBITA)GO TO 180
+      IF(ADDA)GO TO 200
+C
+C        *************************************
+C
+C        GROUP B REQUIRES LESS BITS THAN GROUP A.  PUT AS MANY OF A'S
+C        POINTS INTO B AS POSSIBLE WITHOUT EXCEEDING THE NUMBER OF
+C        BITS NECESSARY TO PACK GROUP B.
+C
+C        *************************************
+C
+      KOUNTS=KOUNTA
+C        KOUNTA REFERS TO THE PRESENT GROUP A.
+      MINTST=MINB
+      MAXTST=MAXB
+      MINTSTK=MINBK
+      MAXTSTK=MAXBK
+C
+C        USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
+C        FOR EFFICIENCY.
+C
+      IF(IS523.EQ.0)THEN
+C 
+         DO 1715 K=KTOTAL,KSTART,-1
+C           START WITH THE END OF THE GROUP AND WORK BACKWARDS.
+         IF(IC(K).LT.MINB)THEN
+            MINTST=IC(K)
+            MINTSTK=K
+         ELSEIF(IC(K).GT.MAXB)THEN
+            MAXTST=IC(K)
+            MAXTSTK=K
+         ENDIF
+         IF(MAXTST-MINTST.GE.IBXX2(IBITB))GO TO 174
+C           NOTE THAT FOR THIS LOOP, LMISS = 0.
+         MINB=MINTST
+         MAXB=MAXTST
+         MINBK=MINTSTK
+         MAXBK=MAXTSTK
+         KOUNTA=KOUNTA-1
+C           THERE IS ONE LESS POINT NOW IN A.
+ 1715    CONTINUE  
+C
+      ELSEIF(IS523.EQ.1)THEN            
+C
+         DO 1719 K=KTOTAL,KSTART,-1
+C           START WITH THE END OF THE GROUP AND WORK BACKWARDS.
+         IF(IC(K).EQ.MISSP)GO TO 1718
+         IF(IC(K).LT.MINB)THEN
+            MINTST=IC(K)
+            MINTSTK=K
+         ELSEIF(IC(K).GT.MAXB)THEN
+            MAXTST=IC(K)
+            MAXTSTK=K
+         ENDIF
+         IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174
+C           FOR THIS LOOP, LMISS = 1.
+         MINB=MINTST
+         MAXB=MAXTST
+         MINBK=MINTSTK
+         MAXBK=MAXTSTK
+         MISLLB=0
+C           WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
+ 1718    KOUNTA=KOUNTA-1
+C           THERE IS ONE LESS POINT NOW IN A.
+ 1719    CONTINUE  
+C
+      ELSE             
+C
+         DO 173 K=KTOTAL,KSTART,-1
+C           START WITH THE END OF THE GROUP AND WORK BACKWARDS.
+         IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 1729
+         IF(IC(K).LT.MINB)THEN
+            MINTST=IC(K)
+            MINTSTK=K
+         ELSEIF(IC(K).GT.MAXB)THEN
+            MAXTST=IC(K)
+            MAXTSTK=K
+         ENDIF
+         IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174
+C           FOR THIS LOOP, LMISS = 2.
+         MINB=MINTST
+         MAXB=MAXTST
+         MINBK=MINTSTK
+         MAXBK=MAXTSTK
+         MISLLB=0
+C           WHEN THE POINT IS NON MISSING, MISLLB SET = 0.
+ 1729    KOUNTA=KOUNTA-1
+C           THERE IS ONE LESS POINT NOW IN A.
+ 173     CONTINUE  
+C
+      ENDIF
+C
+C        AT THIS POINT, KOUNTA CONTAINS THE NUMBER OF POINTS TO CLOSE
+C        OUT GROUP A WITH.  GROUP B NOW STARTS WITH KSTART+KOUNTA AND
+C        ENDS WITH NENDB.  MINB AND MAXB HAVE BEEN ADJUSTED AS
+C        NECESSARY TO REFLECT GROUP B (EVEN THOUGH THE NUMBER OF BITS
+C        NEEDED TO PACK GROUP B HAVE NOT INCREASED, THE END POINTS
+C        OF THE RANGE MAY HAVE).
+C
+ 174  IF(KOUNTA.EQ.KOUNTS)GO TO 200
+C        ON TRANSFER, GROUP A WAS NOT CHANGED.  CLOSE IT OUT.
+C
+C        ONE OR MORE POINTS WERE TAKEN OUT OF A.  RANGE AND IBITA
+C        MAY HAVE TO BE RECOMPUTED; IBITA COULD BE LESS THAN
+C        ORIGINALLY COMPUTED.  IN FACT, GROUP A CAN NOW CONTAIN
+C        ONLY ONE POINT AND BE PACKED WITH ZERO BITS
+C        (UNLESS MISSS NE 0).
+C
+      NOUTA=KOUNTS-KOUNTA
+      KTOTAL=KTOTAL-NOUTA
+      KOUNTB=KOUNTB+NOUTA
+      IF(NENDA-NOUTA.GT.MINAK.AND.NENDA-NOUTA.GT.MAXAK)GO TO 200
+C        WHEN THE ABOVE TEST IS MET, THE MIN AND MAX OF THE 
+C        CURRENT GROUP A WERE WITHIN THE OLD GROUP A, SO THE
+C        RANGE AND IBITA DO NOT NEED TO BE RECOMPUTED.
+C        NOTE THAT MINAK AND MAXAK ARE NO LONGER NEEDED.
+      IBITA=0
+      MINA=MALLOW
+      MAXA=-MALLOW
+C
+C        USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
+C        FOR EFFICIENCY.
+C
+      IF(IS523.EQ.0)THEN
+C 
+         DO 1742 K=KSTART,NENDA-NOUTA
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+         ENDIF
+ 1742    CONTINUE
+C
+      ELSEIF(IS523.EQ.1)THEN 
+C
+         DO 1744 K=KSTART,NENDA-NOUTA
+         IF(IC(K).EQ.MISSP)GO TO 1744
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+         ENDIF
+ 1744    CONTINUE
+C
+      ELSE 
+C
+         DO 175 K=KSTART,NENDA-NOUTA
+         IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 175
+         IF(IC(K).LT.MINA)THEN
+            MINA=IC(K)
+         ENDIF
+         IF(IC(K).GT.MAXA)THEN
+            MAXA=IC(K)
+         ENDIF
+ 175     CONTINUE
+C
+      ENDIF
+C
+      MISLLA=0
+      IF(MINA.NE.MALLOW)GO TO 1750
+C        ALL MISSING VALUES MUST BE ACCOMMODATED.
+      MINA=0
+      MAXA=0
+      MISLLA=1
+      IF(IS523.NE.2)GO TO 177
+C        WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY
+C        MISSING VALUES IBITA = 0 AS ORIGINALLY SET.  OTHERWISE,
+C        IBITA MUST BE CALCULATED.
+C
+ 1750 ITEST=MAXA-MINA+LMISS
+C
+      DO 176 IBITA=0,30
+      IF(ITEST.LT.IBXX2(IBITA))GO TO 177
+C***        THIS TEST IS THE SAME AS:
+C***         IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 177
+ 176  CONTINUE
+C
+C     WRITE(KFILDO,1760)MAXA,MINA
+C1760 FORMAT(' ****ERROR IN PACK_GP.  VALUE WILL NOT PACK IN 30 BITS.',
+C    1       '  MAXA ='I13,'  MINA ='I13,'.  ERROR AT 1760.')
+      IER=706
+      GO TO 900
+C
+ 177  CONTINUE
+      GO TO 200
+C
+C        *************************************
+C
+C        AT THIS POINT, GROUP B REQUIRES AS MANY BITS TO PACK AS GROUPA.
+C        THEREFORE, TRY TO ADD INC POINTS TO GROUP A WITHOUT INCREASING
+C        IBITA.  THIS AUGMENTED GROUP IS CALLED GROUP C.
+C
+C        *************************************
+C
+ 180  IF(MISLLA.EQ.1)THEN
+         MINC=MALLOW
+         MINCK=MALLOW
+         MAXC=-MALLOW
+         MAXCK=-MALLOW
+      ELSE
+         MINC=MINA
+         MAXC=MAXA
+         MINCK=MINAK
+         MAXCK=MINAK
+      ENDIF
+C
+      NOUNT=0
+      IF(NXY-(KTOTAL+KINC).LE.LMINPK/2)KINC=NXY-KTOTAL
+C        ABOVE STATEMENT CONSTRAINS THE LAST GROUP TO BE NOT LESS THAN
+C        LMINPK/2 IN SIZE.  IF A PROVISION LIKE THIS IS NOT INCLUDED,
+C        THERE WILL MANY TIMES BE A VERY SMALL GROUP AT THE END.
+C
+C        USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES
+C        FOR EFFICIENCY.  SINCE KINC IS USUALLY 1, USING SEPARATE
+C        LOOPS HERE DOESN'T BUY MUCH.  A MISSING VALUE WILL ALWAYS
+C        TRANSFER BACK TO GROUP A.
+C
+      IF(IS523.EQ.0)THEN
+C
+         DO 185 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
+         IF(IC(K).LT.MINC)THEN
+            MINC=IC(K)
+            MINCK=K
+         ENDIF
+         IF(IC(K).GT.MAXC)THEN
+            MAXC=IC(K)
+            MAXCK=K
+         ENDIF
+         NOUNT=NOUNT+1
+ 185     CONTINUE
+C
+      ELSEIF(IS523.EQ.1)THEN
+C
+         DO 187 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
+         IF(IC(K).EQ.MISSP)GO TO 186
+         IF(IC(K).LT.MINC)THEN
+            MINC=IC(K)
+            MINCK=K
+         ENDIF
+         IF(IC(K).GT.MAXC)THEN
+            MAXC=IC(K)
+            MAXCK=K
+         ENDIF
+ 186     NOUNT=NOUNT+1
+ 187     CONTINUE
+C
+      ELSE
+C
+         DO 190 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY)
+         IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 189
+         IF(IC(K).LT.MINC)THEN
+            MINC=IC(K)
+            MINCK=K
+         ENDIF
+         IF(IC(K).GT.MAXC)THEN
+            MAXC=IC(K)
+            MAXCK=K
+         ENDIF
+ 189     NOUNT=NOUNT+1
+ 190     CONTINUE
+C
+      ENDIF
+C
+C***D     WRITE(KFILDO,191)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA,
+C***D    1   MINC,MAXC,NOUNT,IC(KTOTAL),IC(KTOTAL+1)
+C***D191  FORMAT(' AT 191, KOUNTA ='I8,'  KTOTAL ='I8,'  MINA ='I8,
+C***D    1       '  MAXA ='I8,'  IBITA ='I3,'  MISLLA ='I3,
+C***D    2       '  MINC ='I8,'  MAXC ='I8,
+C***D    3       '  NOUNT ='I5,'  IC(KTOTAL) ='I9,'  IC(KTOTAL+1) =',I9) 
+C
+C        IF THE NUMBER OF BITS NEEDED FOR GROUP C IS GT IBITA,
+C        THEN THIS GROUP A IS A GROUP TO PACK.
+C
+      IF(MINC.EQ.MALLOW)THEN
+         MINC=MINA
+         MAXC=MAXA
+         MINCK=MINAK
+         MAXCK=MAXAK
+         MISLLC=1
+         GO TO 195
+C           WHEN THE NEW VALUE(S) ARE MISSING, THEY CAN ALWAYS
+C           BE ADDED.
+C
+      ELSE
+         MISLLC=0
+      ENDIF
+C
+      IF(MAXC-MINC.GE.IBXX2(IBITA)-LMISS) GO TO 200
+C
+C        THE BITS NECESSARY FOR GROUP C HAS NOT INCREASED FROM THE
+C        BITS NECESSARY FOR GROUP A.  ADD THIS POINT(S) TO GROUP A.
+C        COMPUTE THE NEXT GROUP B, ETC., UNLESS ALL POINTS HAVE BEEN
+C        USED.
+C 
+ 195  KTOTAL=KTOTAL+NOUNT
+      KOUNTA=KOUNTA+NOUNT
+      MINA=MINC
+      MAXA=MAXC
+      MINAK=MINCK
+      MAXAK=MAXCK
+      MISLLA=MISLLC
+      ADDA=.TRUE.
+      IF(KTOTAL.GE.NXY)GO TO 200
+C
+      IF(MINBK.GT.KTOTAL.AND.MAXBK.GT.KTOTAL)THEN
+         MSTART=NENDB+1
+C           THE MAX AND MIN OF GROUP B WERE NOT FROM THE POINTS
+C           REMOVED, SO THE WHOLE GROUP DOES NOT HAVE TO BE LOOKED
+C           AT TO DETERMINE THE NEW MAX AND MIN.  RATHER START
+C           JUST BEYOND THE OLD NENDB.
+         IBITBS=IBITB
+         NENDB=1
+         GO TO 150
+      ELSE
+         GO TO 140
+      ENDIF
+C
+C        *************************************
+C
+C        GROUP A IS TO BE PACKED.  STORE VALUES IN JMIN( ), JMAX( ),
+C        LBIT( ), AND NOV( ).
+C
+C        *************************************
+C
+ 200  LX=LX+1
+      IF(LX.LE.NDG)GO TO 205
+      LMINPK=LMINPK+LMINPK/2
+C     WRITE(KFILDO,201)NDG,LMINPK,LX
+C201  FORMAT(' ****NDG ='I5,' NOT LARGE ENOUGH.',
+C    1       '  LMINPK IS INCREASED TO 'I3,' FOR THIS FIELD.'/
+C    2       '  LX = 'I10)
+      IERSAV=716
+      GO TO 105
+C
+ 205  JMIN(LX)=MINA
+      JMAX(LX)=MAXA
+      LBIT(LX)=IBITA
+      NOV(LX)=KOUNTA
+      KSTART=KTOTAL+1
+C
+      IF(MISLLA.EQ.0)THEN
+         MISSLX(LX)=MALLOW
+      ELSE
+         MISSLX(LX)=IC(KTOTAL)
+C           IC(KTOTAL) WAS THE LAST VALUE PROCESSED.  IF MISLLA NE 0,
+C           THIS MUST BE THE MISSING VALUE FOR THIS GROUP.
+      ENDIF
+C
+C***D     WRITE(KFILDO,206)MISLLA,IC(KTOTAL),KTOTAL,LX,JMIN(LX),JMAX(LX),
+C***D    1                 LBIT(LX),NOV(LX),MISSLX(LX)
+C***D206  FORMAT(' AT 206,  MISLLA ='I2,'  IC(KTOTAL) ='I5,'  KTOTAL ='I8,
+C***D    1       '  LX ='I6,'  JMIN(LX) ='I8,'  JMAX(LX) ='I8,
+C***D    2       '  LBIT(LX) ='I5,'  NOV(LX) ='I8,'  MISSLX(LX) =',I7) 
+C
+      IF(KTOTAL.GE.NXY)GO TO 209
+C
+C        THE NEW GROUP A WILL BE THE PREVIOUS GROUP B.  SET LIMITS, ETC.
+C
+      IBITA=IBITB
+      MINA=MINB
+      MAXA=MAXB
+      MINAK=MINBK
+      MAXAK=MAXBK
+      MISLLA=MISLLB
+      NENDA=NENDB
+      KOUNTA=KOUNTB
+      KTOTAL=KTOTAL+KOUNTA
+      ADDA=.FALSE.
+      GO TO 133
+C
+C        *************************************
+C
+C        CALCULATE IBIT, THE NUMBER OF BITS NEEDED TO HOLD THE GROUP
+C        MINIMUM VALUES.
+C
+C        *************************************
+C
+ 209  IBIT=0
+C
+      DO 220 L=1,LX
+ 210  IF(JMIN(L).LT.IBXX2(IBIT))GO TO 220
+      IBIT=IBIT+1
+      GO TO 210
+ 220  CONTINUE
+C
+C        INSERT THE VALUE IN JMIN( ) TO BE USED FOR ALL MISSING
+C        VALUES WHEN LBIT( ) = 0.  WHEN SECONDARY MISSING 
+C        VALUES CAN BE PRESENT, LBIT(L) WILL NOT = 0.
+C
+      IF(IS523.EQ.1)THEN
+C
+         DO 226 L=1,LX
+C   
+         IF(LBIT(L).EQ.0)THEN
+C
+            IF(MISSLX(L).EQ.MISSP)THEN
+               JMIN(L)=IBXX2(IBIT)-1
+            ENDIF
+C
+         ENDIF
+C
+ 226     CONTINUE
+C
+      ENDIF
+C
+C        *************************************
+C
+C        CALCULATE JBIT, THE NUMBER OF BITS NEEDED TO HOLD THE BITS
+C        NEEDED TO PACK THE VALUES IN THE GROUPS.  BUT FIND AND
+C        REMOVE THE REFERENCE VALUE FIRST.
+C
+C        *************************************
+C
+C     WRITE(KFILDO,228)CFEED,LX
+C228  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP WIDTHS LBIT( ) FOR ',I8,' GROUPS'
+C    2          /' *****************************************')
+C     WRITE(KFILDO,229) (LBIT(J),J=1,MIN(LX,100))
+C229  FORMAT(/' '20I6)
+C
+      LBITREF=LBIT(1)
+C
+      DO 230 K=1,LX
+      IF(LBIT(K).LT.LBITREF)LBITREF=LBIT(K)
+ 230  CONTINUE
+C
+      IF(LBITREF.NE.0)THEN
+C
+         DO 240 K=1,LX
+         LBIT(K)=LBIT(K)-LBITREF
+ 240     CONTINUE
+C
+      ENDIF
+C
+C     WRITE(KFILDO,241)CFEED,LBITREF
+C241  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP WIDTHS LBIT( ) AFTER REMOVING REFERENCE ',
+C    2             I8,
+C    3          /' *****************************************')
+C     WRITE(KFILDO,242) (LBIT(J),J=1,MIN(LX,100))
+C242  FORMAT(/' '20I6)
+C
+      JBIT=0
+C
+      DO 320 K=1,LX
+ 310  IF(LBIT(K).LT.IBXX2(JBIT))GO TO 320
+      JBIT=JBIT+1
+      GO TO 310
+ 320  CONTINUE
+C
+C        *************************************
+C
+C        CALCULATE KBIT, THE NUMBER OF BITS NEEDED TO HOLD THE NUMBER
+C        OF VALUES IN THE GROUPS.  BUT FIND AND REMOVE THE
+C        REFERENCE FIRST.
+C
+C        *************************************
+C
+C     WRITE(KFILDO,321)CFEED,LX
+C321  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP SIZES NOV( ) FOR ',I8,' GROUPS'
+C    2          /' *****************************************')
+C     WRITE(KFILDO,322) (NOV(J),J=1,MIN(LX,100))
+C322  FORMAT(/' '20I6)
+C
+      NOVREF=NOV(1)
+C
+      DO 400 K=1,LX
+      IF(NOV(K).LT.NOVREF)NOVREF=NOV(K)
+ 400  CONTINUE
+C
+      IF(NOVREF.GT.0)THEN
+C
+         DO 405 K=1,LX
+         NOV(K)=NOV(K)-NOVREF
+ 405     CONTINUE
+C
+      ENDIF
+C
+C     WRITE(KFILDO,406)CFEED,NOVREF
+C406  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP SIZES NOV( ) AFTER REMOVING REFERENCE ',I8,
+C    2          /' *****************************************')
+C     WRITE(KFILDO,407) (NOV(J),J=1,MIN(LX,100))
+C407  FORMAT(/' '20I6)
+C     WRITE(KFILDO,408)CFEED
+C408  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP REFERENCES JMIN( )'
+C    2          /' *****************************************')
+C     WRITE(KFILDO,409) (JMIN(J),J=1,MIN(LX,100))
+C409  FORMAT(/' '20I6)
+C
+      KBIT=0
+C
+      DO 420 K=1,LX
+ 410  IF(NOV(K).LT.IBXX2(KBIT))GO TO 420
+      KBIT=KBIT+1
+      GO TO 410
+ 420  CONTINUE
+C
+C        DETERMINE WHETHER THE GROUP SIZES SHOULD BE REDUCED
+C        FOR SPACE EFFICIENCY.
+C
+      IF(IRED.EQ.0)THEN
+         CALL REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT,
+     1               NOVREF,IBXX2,IER)
+C
+         IF(IER.EQ.714.OR.IER.EQ.715)THEN
+C              REDUCE HAS ABORTED.  REEXECUTE PACK_GP WITHOUT REDUCE.
+C              PROVIDE FOR A NON FATAL RETURN FROM REDUCE.  
+            IERSAV=IER
+            IRED=1
+            IER=0
+            GO TO 102 
+         ENDIF
+C
+      ENDIF         
+C
+C     CALL TIMPR(KFILDO,KFILDO,'END   PACK_GP        ')
+      IF(IERSAV.NE.0)THEN
+         IER=IERSAV
+         RETURN
+      ENDIF
+C
+C 900  IF(IER.NE.0)RETURN1
+C
+ 900  RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/params.F b/wrfv2_fire/external/io_grib2/g2lib/params.F
new file mode 100644
index 00000000..829ea5d7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/params.F
@@ -0,0 +1,1281 @@
+      module params
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    params
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-05
+!
+! ABSTRACT: This Fortran Module contains info on all the available 
+!           GRIB Parameters.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-11  Gilbert
+! 2003-08-07  Gilbert  -  Added more parameters
+! 2003-09-26  Gilbert  -  Added more parameters
+!
+! USAGE:    use params
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,parameter :: MAXPARAM=212
+
+      type gribparam
+          integer :: g1tblver
+          integer :: grib1val
+          integer :: grib2dsc
+          integer :: grib2cat
+          integer :: grib2num
+          character(len=8) :: abbrev
+      end type gribparam
+
+      type(gribparam),dimension(MAXPARAM) :: paramlist
+
+      data paramlist(1)%g1tblver /2/ 
+      data paramlist(1)%grib1val /1/ 
+      data paramlist(1)%grib2dsc /0/ 
+      data paramlist(1)%grib2cat /3/ 
+      data paramlist(1)%grib2num /0/ 
+      data paramlist(1)%abbrev   /'PRES    '/ 
+      data paramlist(2)%g1tblver /2/ 
+      data paramlist(2)%grib1val /2/ 
+      data paramlist(2)%grib2dsc /0/ 
+      data paramlist(2)%grib2cat /3/ 
+      data paramlist(2)%grib2num /1/ 
+      data paramlist(2)%abbrev   /'PRMSL   '/ 
+      data paramlist(3)%g1tblver /2/ 
+      data paramlist(3)%grib1val /3/ 
+      data paramlist(3)%grib2dsc /0/ 
+      data paramlist(3)%grib2cat /3/ 
+      data paramlist(3)%grib2num /2/ 
+      data paramlist(3)%abbrev   /'PTEND   '/ 
+      data paramlist(4)%g1tblver /2/ 
+      data paramlist(4)%grib1val /4/ 
+      data paramlist(4)%grib2dsc /0/ 
+      data paramlist(4)%grib2cat /2/ 
+      data paramlist(4)%grib2num /14/ 
+      data paramlist(4)%abbrev   /'PVORT   '/ 
+      data paramlist(5)%g1tblver /2/ 
+      data paramlist(5)%grib1val /5/ 
+      data paramlist(5)%grib2dsc /0/ 
+      data paramlist(5)%grib2cat /3/ 
+      data paramlist(5)%grib2num /3/ 
+      data paramlist(5)%abbrev   /'ICAHT   '/ 
+      data paramlist(6)%g1tblver /2/ 
+      data paramlist(6)%grib1val /6/ 
+      data paramlist(6)%grib2dsc /0/ 
+      data paramlist(6)%grib2cat /3/ 
+      data paramlist(6)%grib2num /4/ 
+      data paramlist(6)%abbrev   /'GP      '/ 
+      data paramlist(7)%g1tblver /2/ 
+      data paramlist(7)%grib1val /7/ 
+      data paramlist(7)%grib2dsc /0/ 
+      data paramlist(7)%grib2cat /3/ 
+      data paramlist(7)%grib2num /5/ 
+      data paramlist(7)%abbrev   /'HGT     '/ 
+      data paramlist(8)%g1tblver /2/ 
+      data paramlist(8)%grib1val /8/ 
+      data paramlist(8)%grib2dsc /0/ 
+      data paramlist(8)%grib2cat /3/ 
+      data paramlist(8)%grib2num /6/ 
+      data paramlist(8)%abbrev   /'DIST    '/ 
+      data paramlist(9)%g1tblver /2/ 
+      data paramlist(9)%grib1val /9/ 
+      data paramlist(9)%grib2dsc /0/ 
+      data paramlist(9)%grib2cat /3/ 
+      data paramlist(9)%grib2num /7/ 
+      data paramlist(9)%abbrev   /'HSTDV   '/ 
+      data paramlist(10)%g1tblver /2/ 
+      data paramlist(10)%grib1val /10/ 
+      data paramlist(10)%grib2dsc /0/ 
+      data paramlist(10)%grib2cat /14/ 
+      data paramlist(10)%grib2num /0/ 
+      data paramlist(10)%abbrev   /'TOZNE   '/ 
+      data paramlist(11)%g1tblver /2/ 
+      data paramlist(11)%grib1val /11/ 
+      data paramlist(11)%grib2dsc /0/ 
+      data paramlist(11)%grib2cat /0/ 
+      data paramlist(11)%grib2num /0/ 
+      data paramlist(11)%abbrev   /'TMP     '/ 
+      data paramlist(12)%g1tblver /2/ 
+      data paramlist(12)%grib1val /12/ 
+      data paramlist(12)%grib2dsc /0/ 
+      data paramlist(12)%grib2cat /0/ 
+      data paramlist(12)%grib2num /1/ 
+      data paramlist(12)%abbrev   /'VTMP    '/ 
+      data paramlist(13)%g1tblver /2/ 
+      data paramlist(13)%grib1val /13/ 
+      data paramlist(13)%grib2dsc /0/ 
+      data paramlist(13)%grib2cat /0/ 
+      data paramlist(13)%grib2num /2/ 
+      data paramlist(13)%abbrev   /'POT     '/ 
+      data paramlist(14)%g1tblver /2/ 
+      data paramlist(14)%grib1val /14/ 
+      data paramlist(14)%grib2dsc /0/ 
+      data paramlist(14)%grib2cat /0/ 
+      data paramlist(14)%grib2num /3/ 
+      data paramlist(14)%abbrev   /'EPOT    '/ 
+      data paramlist(15)%g1tblver /2/ 
+      data paramlist(15)%grib1val /15/ 
+      data paramlist(15)%grib2dsc /0/ 
+      data paramlist(15)%grib2cat /0/ 
+      data paramlist(15)%grib2num /4/ 
+      data paramlist(15)%abbrev   /'T MAX   '/ 
+      data paramlist(16)%g1tblver /2/ 
+      data paramlist(16)%grib1val /16/ 
+      data paramlist(16)%grib2dsc /0/ 
+      data paramlist(16)%grib2cat /0/ 
+      data paramlist(16)%grib2num /5/ 
+      data paramlist(16)%abbrev   /'T MIN   '/ 
+      data paramlist(17)%g1tblver /2/ 
+      data paramlist(17)%grib1val /17/ 
+      data paramlist(17)%grib2dsc /0/ 
+      data paramlist(17)%grib2cat /0/ 
+      data paramlist(17)%grib2num /6/ 
+      data paramlist(17)%abbrev   /'DPT     '/ 
+      data paramlist(18)%g1tblver /2/ 
+      data paramlist(18)%grib1val /18/ 
+      data paramlist(18)%grib2dsc /0/ 
+      data paramlist(18)%grib2cat /0/ 
+      data paramlist(18)%grib2num /7/ 
+      data paramlist(18)%abbrev   /'DEPR    '/ 
+      data paramlist(19)%g1tblver /2/ 
+      data paramlist(19)%grib1val /19/ 
+      data paramlist(19)%grib2dsc /0/ 
+      data paramlist(19)%grib2cat /0/ 
+      data paramlist(19)%grib2num /8/ 
+      data paramlist(19)%abbrev   /'LAPR    '/ 
+      data paramlist(20)%g1tblver /2/ 
+      data paramlist(20)%grib1val /20/ 
+      data paramlist(20)%grib2dsc /0/ 
+      data paramlist(20)%grib2cat /19/ 
+      data paramlist(20)%grib2num /0/ 
+      data paramlist(20)%abbrev   /'VIS     '/ 
+      data paramlist(21)%g1tblver /2/ 
+      data paramlist(21)%grib1val /21/ 
+      data paramlist(21)%grib2dsc /0/ 
+      data paramlist(21)%grib2cat /15/ 
+      data paramlist(21)%grib2num /6/ 
+      data paramlist(21)%abbrev   /'RDSP1   '/ 
+      data paramlist(22)%g1tblver /2/ 
+      data paramlist(22)%grib1val /22/ 
+      data paramlist(22)%grib2dsc /0/ 
+      data paramlist(22)%grib2cat /15/ 
+      data paramlist(22)%grib2num /7/ 
+      data paramlist(22)%abbrev   /'RDSP2   '/ 
+      data paramlist(23)%g1tblver /2/ 
+      data paramlist(23)%grib1val /23/ 
+      data paramlist(23)%grib2dsc /0/ 
+      data paramlist(23)%grib2cat /15/ 
+      data paramlist(23)%grib2num /8/ 
+      data paramlist(23)%abbrev   /'RDSP3   '/ 
+      data paramlist(24)%g1tblver /2/ 
+      data paramlist(24)%grib1val /24/ 
+      data paramlist(24)%grib2dsc /0/ 
+      data paramlist(24)%grib2cat /7/ 
+      data paramlist(24)%grib2num /0/ 
+      data paramlist(24)%abbrev   /'PLI     '/ 
+      data paramlist(25)%g1tblver /2/ 
+      data paramlist(25)%grib1val /25/ 
+      data paramlist(25)%grib2dsc /0/ 
+      data paramlist(25)%grib2cat /0/ 
+      data paramlist(25)%grib2num /9/ 
+      data paramlist(25)%abbrev   /'TMP A   '/ 
+      data paramlist(26)%g1tblver /2/ 
+      data paramlist(26)%grib1val /26/ 
+      data paramlist(26)%grib2dsc /0/ 
+      data paramlist(26)%grib2cat /3/ 
+      data paramlist(26)%grib2num /8/ 
+      data paramlist(26)%abbrev   /'PRESA   '/ 
+      data paramlist(27)%g1tblver /2/ 
+      data paramlist(27)%grib1val /27/ 
+      data paramlist(27)%grib2dsc /0/ 
+      data paramlist(27)%grib2cat /3/ 
+      data paramlist(27)%grib2num /9/ 
+      data paramlist(27)%abbrev   /'GP A    '/ 
+      data paramlist(28)%g1tblver /2/ 
+      data paramlist(28)%grib1val /28/ 
+      data paramlist(28)%grib2dsc /10/ 
+      data paramlist(28)%grib2cat /0/ 
+      data paramlist(28)%grib2num /0/ 
+      data paramlist(28)%abbrev   /'WVSP1   '/ 
+      data paramlist(29)%g1tblver /2/ 
+      data paramlist(29)%grib1val /29/ 
+      data paramlist(29)%grib2dsc /10/ 
+      data paramlist(29)%grib2cat /0/ 
+      data paramlist(29)%grib2num /1/ 
+      data paramlist(29)%abbrev   /'WVSP2   '/ 
+      data paramlist(30)%g1tblver /2/ 
+      data paramlist(30)%grib1val /30/ 
+      data paramlist(30)%grib2dsc /10/ 
+      data paramlist(30)%grib2cat /0/ 
+      data paramlist(30)%grib2num /2/ 
+      data paramlist(30)%abbrev   /'WVSP3   '/ 
+      data paramlist(31)%g1tblver /2/ 
+      data paramlist(31)%grib1val /31/ 
+      data paramlist(31)%grib2dsc /0/ 
+      data paramlist(31)%grib2cat /2/ 
+      data paramlist(31)%grib2num /0/ 
+      data paramlist(31)%abbrev   /'WDIR    '/ 
+      data paramlist(32)%g1tblver /2/ 
+      data paramlist(32)%grib1val /32/ 
+      data paramlist(32)%grib2dsc /0/ 
+      data paramlist(32)%grib2cat /2/ 
+      data paramlist(32)%grib2num /1/ 
+      data paramlist(32)%abbrev   /'WIND    '/ 
+      data paramlist(33)%g1tblver /2/ 
+      data paramlist(33)%grib1val /33/ 
+      data paramlist(33)%grib2dsc /0/ 
+      data paramlist(33)%grib2cat /2/ 
+      data paramlist(33)%grib2num /2/ 
+      data paramlist(33)%abbrev   /'U GRD   '/ 
+      data paramlist(34)%g1tblver /2/ 
+      data paramlist(34)%grib1val /34/ 
+      data paramlist(34)%grib2dsc /0/ 
+      data paramlist(34)%grib2cat /2/ 
+      data paramlist(34)%grib2num /3/ 
+      data paramlist(34)%abbrev   /'V GRD   '/ 
+      data paramlist(35)%g1tblver /2/ 
+      data paramlist(35)%grib1val /35/ 
+      data paramlist(35)%grib2dsc /0/ 
+      data paramlist(35)%grib2cat /2/ 
+      data paramlist(35)%grib2num /4/ 
+      data paramlist(35)%abbrev   /'STRM    '/ 
+      data paramlist(36)%g1tblver /2/ 
+      data paramlist(36)%grib1val /36/ 
+      data paramlist(36)%grib2dsc /0/ 
+      data paramlist(36)%grib2cat /2/ 
+      data paramlist(36)%grib2num /5/ 
+      data paramlist(36)%abbrev   /'V POT   '/ 
+      data paramlist(37)%g1tblver /2/ 
+      data paramlist(37)%grib1val /37/ 
+      data paramlist(37)%grib2dsc /0/ 
+      data paramlist(37)%grib2cat /2/ 
+      data paramlist(37)%grib2num /6/ 
+      data paramlist(37)%abbrev   /'MNTSF   '/ 
+      data paramlist(38)%g1tblver /2/ 
+      data paramlist(38)%grib1val /38/ 
+      data paramlist(38)%grib2dsc /0/ 
+      data paramlist(38)%grib2cat /2/ 
+      data paramlist(38)%grib2num /7/ 
+      data paramlist(38)%abbrev   /'SGCVV   '/ 
+      data paramlist(39)%g1tblver /2/ 
+      data paramlist(39)%grib1val /39/ 
+      data paramlist(39)%grib2dsc /0/ 
+      data paramlist(39)%grib2cat /2/ 
+      data paramlist(39)%grib2num /8/ 
+      data paramlist(39)%abbrev   /'V VEL   '/ 
+      data paramlist(40)%g1tblver /2/ 
+      data paramlist(40)%grib1val /40/ 
+      data paramlist(40)%grib2dsc /0/ 
+      data paramlist(40)%grib2cat /2/ 
+      data paramlist(40)%grib2num /9/ 
+      data paramlist(40)%abbrev   /'DZDT    '/ 
+      data paramlist(41)%g1tblver /2/ 
+      data paramlist(41)%grib1val /41/ 
+      data paramlist(41)%grib2dsc /0/ 
+      data paramlist(41)%grib2cat /2/ 
+      data paramlist(41)%grib2num /10/ 
+      data paramlist(41)%abbrev   /'ABS V   '/ 
+      data paramlist(42)%g1tblver /2/ 
+      data paramlist(42)%grib1val /42/ 
+      data paramlist(42)%grib2dsc /0/ 
+      data paramlist(42)%grib2cat /2/ 
+      data paramlist(42)%grib2num /11/ 
+      data paramlist(42)%abbrev   /'ABS D   '/ 
+      data paramlist(43)%g1tblver /2/ 
+      data paramlist(43)%grib1val /43/ 
+      data paramlist(43)%grib2dsc /0/ 
+      data paramlist(43)%grib2cat /2/ 
+      data paramlist(43)%grib2num /12/ 
+      data paramlist(43)%abbrev   /'REL V   '/ 
+      data paramlist(44)%g1tblver /2/ 
+      data paramlist(44)%grib1val /44/ 
+      data paramlist(44)%grib2dsc /0/ 
+      data paramlist(44)%grib2cat /2/ 
+      data paramlist(44)%grib2num /13/ 
+      data paramlist(44)%abbrev   /'REL D   '/ 
+      data paramlist(45)%g1tblver /2/ 
+      data paramlist(45)%grib1val /45/ 
+      data paramlist(45)%grib2dsc /0/ 
+      data paramlist(45)%grib2cat /2/ 
+      data paramlist(45)%grib2num /15/ 
+      data paramlist(45)%abbrev   /'VUCSH   '/ 
+      data paramlist(46)%g1tblver /2/ 
+      data paramlist(46)%grib1val /46/ 
+      data paramlist(46)%grib2dsc /0/ 
+      data paramlist(46)%grib2cat /2/ 
+      data paramlist(46)%grib2num /16/ 
+      data paramlist(46)%abbrev   /'VVCSH   '/ 
+      data paramlist(47)%g1tblver /2/ 
+      data paramlist(47)%grib1val /47/ 
+      data paramlist(47)%grib2dsc /10/ 
+      data paramlist(47)%grib2cat /1/ 
+      data paramlist(47)%grib2num /0/ 
+      data paramlist(47)%abbrev   /'DIR C   '/ 
+      data paramlist(48)%g1tblver /2/ 
+      data paramlist(48)%grib1val /48/ 
+      data paramlist(48)%grib2dsc /10/ 
+      data paramlist(48)%grib2cat /1/ 
+      data paramlist(48)%grib2num /1/ 
+      data paramlist(48)%abbrev   /'SP C    '/ 
+      data paramlist(49)%g1tblver /2/ 
+      data paramlist(49)%grib1val /49/ 
+      data paramlist(49)%grib2dsc /10/ 
+      data paramlist(49)%grib2cat /1/ 
+      data paramlist(49)%grib2num /2/ 
+      data paramlist(49)%abbrev   /'UOGRD   '/ 
+      data paramlist(50)%g1tblver /2/ 
+      data paramlist(50)%grib1val /50/ 
+      data paramlist(50)%grib2dsc /10/ 
+      data paramlist(50)%grib2cat /1/ 
+      data paramlist(50)%grib2num /3/ 
+      data paramlist(50)%abbrev   /'VOGRD   '/ 
+      data paramlist(51)%g1tblver /2/ 
+      data paramlist(51)%grib1val /51/ 
+      data paramlist(51)%grib2dsc /0/ 
+      data paramlist(51)%grib2cat /1/ 
+      data paramlist(51)%grib2num /0/ 
+      data paramlist(51)%abbrev   /'SPF H   '/ 
+      data paramlist(52)%g1tblver /2/ 
+      data paramlist(52)%grib1val /52/ 
+      data paramlist(52)%grib2dsc /0/ 
+      data paramlist(52)%grib2cat /1/ 
+      data paramlist(52)%grib2num /1/ 
+      data paramlist(52)%abbrev   /'R H     '/ 
+      data paramlist(53)%g1tblver /2/ 
+      data paramlist(53)%grib1val /53/ 
+      data paramlist(53)%grib2dsc /0/ 
+      data paramlist(53)%grib2cat /1/ 
+      data paramlist(53)%grib2num /2/ 
+      data paramlist(53)%abbrev   /'MIXR    '/ 
+      data paramlist(54)%g1tblver /2/ 
+      data paramlist(54)%grib1val /54/ 
+      data paramlist(54)%grib2dsc /0/ 
+      data paramlist(54)%grib2cat /1/ 
+      data paramlist(54)%grib2num /3/ 
+      data paramlist(54)%abbrev   /'P WAT   '/ 
+      data paramlist(55)%g1tblver /2/ 
+      data paramlist(55)%grib1val /55/ 
+      data paramlist(55)%grib2dsc /0/ 
+      data paramlist(55)%grib2cat /1/ 
+      data paramlist(55)%grib2num /4/ 
+      data paramlist(55)%abbrev   /'VAPP    '/ 
+      data paramlist(56)%g1tblver /2/ 
+      data paramlist(56)%grib1val /56/ 
+      data paramlist(56)%grib2dsc /0/ 
+      data paramlist(56)%grib2cat /1/ 
+      data paramlist(56)%grib2num /5/ 
+      data paramlist(56)%abbrev   /'SAT D   '/ 
+      data paramlist(57)%g1tblver /2/ 
+      data paramlist(57)%grib1val /57/ 
+      data paramlist(57)%grib2dsc /0/ 
+      data paramlist(57)%grib2cat /1/ 
+      data paramlist(57)%grib2num /6/ 
+      data paramlist(57)%abbrev   /'EVP     '/ 
+      data paramlist(58)%g1tblver /2/ 
+      data paramlist(58)%grib1val /58/ 
+      data paramlist(58)%grib2dsc /0/ 
+      data paramlist(58)%grib2cat /6/ 
+      data paramlist(58)%grib2num /0/ 
+      data paramlist(58)%abbrev   /'C ICE   '/ 
+      data paramlist(59)%g1tblver /2/ 
+      data paramlist(59)%grib1val /59/ 
+      data paramlist(59)%grib2dsc /0/ 
+      data paramlist(59)%grib2cat /1/ 
+      data paramlist(59)%grib2num /7/ 
+      data paramlist(59)%abbrev   /'PRATE   '/ 
+      data paramlist(60)%g1tblver /2/ 
+      data paramlist(60)%grib1val /60/ 
+      data paramlist(60)%grib2dsc /0/ 
+      data paramlist(60)%grib2cat /19/ 
+      data paramlist(60)%grib2num /2/ 
+      data paramlist(60)%abbrev   /'TSTM    '/ 
+      data paramlist(61)%g1tblver /2/ 
+      data paramlist(61)%grib1val /61/ 
+      data paramlist(61)%grib2dsc /0/ 
+      data paramlist(61)%grib2cat /1/ 
+      data paramlist(61)%grib2num /8/ 
+      data paramlist(61)%abbrev   /'A PCP   '/ 
+      data paramlist(62)%g1tblver /2/ 
+      data paramlist(62)%grib1val /62/ 
+      data paramlist(62)%grib2dsc /0/ 
+      data paramlist(62)%grib2cat /1/ 
+      data paramlist(62)%grib2num /9/ 
+      data paramlist(62)%abbrev   /'NCPCP   '/ 
+      data paramlist(63)%g1tblver /2/ 
+      data paramlist(63)%grib1val /63/ 
+      data paramlist(63)%grib2dsc /0/ 
+      data paramlist(63)%grib2cat /1/ 
+      data paramlist(63)%grib2num /10/ 
+      data paramlist(63)%abbrev   /'ACPCP   '/ 
+      data paramlist(64)%g1tblver /2/ 
+      data paramlist(64)%grib1val /64/ 
+      data paramlist(64)%grib2dsc /0/ 
+      data paramlist(64)%grib2cat /1/ 
+      data paramlist(64)%grib2num /12/ 
+      data paramlist(64)%abbrev   /'SRWEQ   '/ 
+      data paramlist(65)%g1tblver /2/ 
+      data paramlist(65)%grib1val /65/ 
+      data paramlist(65)%grib2dsc /0/ 
+      data paramlist(65)%grib2cat /1/ 
+      data paramlist(65)%grib2num /13/ 
+      data paramlist(65)%abbrev   /'WEASD   '/ 
+      data paramlist(66)%g1tblver /2/ 
+      data paramlist(66)%grib1val /66/ 
+      data paramlist(66)%grib2dsc /0/ 
+      data paramlist(66)%grib2cat /1/ 
+      data paramlist(66)%grib2num /11/ 
+      data paramlist(66)%abbrev   /'SNO D   '/ 
+      data paramlist(67)%g1tblver /2/ 
+      data paramlist(67)%grib1val /67/ 
+      data paramlist(67)%grib2dsc /0/ 
+      data paramlist(67)%grib2cat /19/ 
+      data paramlist(67)%grib2num /3/ 
+      data paramlist(67)%abbrev   /'MIXHT   '/ 
+      data paramlist(68)%g1tblver /2/ 
+      data paramlist(68)%grib1val /68/ 
+      data paramlist(68)%grib2dsc /10/ 
+      data paramlist(68)%grib2cat /5/ 
+      data paramlist(68)%grib2num /2/ 
+      data paramlist(68)%abbrev   /'TTHDP   '/ 
+      data paramlist(69)%g1tblver /2/ 
+      data paramlist(69)%grib1val /69/ 
+      data paramlist(69)%grib2dsc /10/ 
+      data paramlist(69)%grib2cat /5/ 
+      data paramlist(69)%grib2num /0/ 
+      data paramlist(69)%abbrev   /'MTHD    '/ 
+      data paramlist(70)%g1tblver /2/ 
+      data paramlist(70)%grib1val /70/ 
+      data paramlist(70)%grib2dsc /10/ 
+      data paramlist(70)%grib2cat /5/ 
+      data paramlist(70)%grib2num /1/ 
+      data paramlist(70)%abbrev   /'MTH A   '/ 
+      data paramlist(71)%g1tblver /2/ 
+      data paramlist(71)%grib1val /71/ 
+      data paramlist(71)%grib2dsc /0/ 
+      data paramlist(71)%grib2cat /6/ 
+      data paramlist(71)%grib2num /1/ 
+      data paramlist(71)%abbrev   /'T CDC   '/ 
+      data paramlist(72)%g1tblver /2/ 
+      data paramlist(72)%grib1val /72/ 
+      data paramlist(72)%grib2dsc /0/ 
+      data paramlist(72)%grib2cat /6/ 
+      data paramlist(72)%grib2num /2/ 
+      data paramlist(72)%abbrev   /'CDCON   '/ 
+      data paramlist(73)%g1tblver /2/ 
+      data paramlist(73)%grib1val /73/ 
+      data paramlist(73)%grib2dsc /0/ 
+      data paramlist(73)%grib2cat /6/ 
+      data paramlist(73)%grib2num /3/ 
+      data paramlist(73)%abbrev   /'L CDC   '/ 
+      data paramlist(74)%g1tblver /2/ 
+      data paramlist(74)%grib1val /74/ 
+      data paramlist(74)%grib2dsc /0/ 
+      data paramlist(74)%grib2cat /6/ 
+      data paramlist(74)%grib2num /4/ 
+      data paramlist(74)%abbrev   /'M CDC   '/ 
+      data paramlist(75)%g1tblver /2/ 
+      data paramlist(75)%grib1val /75/ 
+      data paramlist(75)%grib2dsc /0/ 
+      data paramlist(75)%grib2cat /6/ 
+      data paramlist(75)%grib2num /5/ 
+      data paramlist(75)%abbrev   /'H CDC   '/ 
+      data paramlist(76)%g1tblver /2/ 
+      data paramlist(76)%grib1val /76/ 
+      data paramlist(76)%grib2dsc /0/ 
+      data paramlist(76)%grib2cat /6/ 
+      data paramlist(76)%grib2num /6/ 
+      data paramlist(76)%abbrev   /'C WAT   '/ 
+      data paramlist(77)%g1tblver /2/ 
+      data paramlist(77)%grib1val /77/ 
+      data paramlist(77)%grib2dsc /0/ 
+      data paramlist(77)%grib2cat /7/ 
+      data paramlist(77)%grib2num /1/ 
+      data paramlist(77)%abbrev   /'BLI     '/ 
+      data paramlist(78)%g1tblver /2/ 
+      data paramlist(78)%grib1val /78/ 
+      data paramlist(78)%grib2dsc /0/ 
+      data paramlist(78)%grib2cat /1/ 
+      data paramlist(78)%grib2num /14/ 
+      data paramlist(78)%abbrev   /'SNO C   '/ 
+      data paramlist(79)%g1tblver /2/ 
+      data paramlist(79)%grib1val /79/ 
+      data paramlist(79)%grib2dsc /0/ 
+      data paramlist(79)%grib2cat /1/ 
+      data paramlist(79)%grib2num /15/ 
+      data paramlist(79)%abbrev   /'SNO L   '/ 
+      data paramlist(80)%g1tblver /2/ 
+      data paramlist(80)%grib1val /80/ 
+      data paramlist(80)%grib2dsc /10/ 
+      data paramlist(80)%grib2cat /4/ 
+      data paramlist(80)%grib2num /0/ 
+      data paramlist(80)%abbrev   /'WTMP    '/ 
+      data paramlist(81)%g1tblver /2/ 
+      data paramlist(81)%grib1val /81/ 
+      data paramlist(81)%grib2dsc /2/ 
+      data paramlist(81)%grib2cat /0/ 
+      data paramlist(81)%grib2num /0/ 
+      data paramlist(81)%abbrev   /'LAND    '/ 
+      data paramlist(82)%g1tblver /2/ 
+      data paramlist(82)%grib1val /82/ 
+      data paramlist(82)%grib2dsc /10/ 
+      data paramlist(82)%grib2cat /4/ 
+      data paramlist(82)%grib2num /1/ 
+      data paramlist(82)%abbrev   /'DSL M   '/ 
+      data paramlist(83)%g1tblver /2/ 
+      data paramlist(83)%grib1val /83/ 
+      data paramlist(83)%grib2dsc /2/ 
+      data paramlist(83)%grib2cat /0/ 
+      data paramlist(83)%grib2num /1/ 
+      data paramlist(83)%abbrev   /'SFC R   '/ 
+      data paramlist(84)%g1tblver /2/ 
+      data paramlist(84)%grib1val /84/ 
+      data paramlist(84)%grib2dsc /0/ 
+      data paramlist(84)%grib2cat /19/ 
+      data paramlist(84)%grib2num /1/ 
+      data paramlist(84)%abbrev   /'ALBDO   '/ 
+      data paramlist(85)%g1tblver /2/ 
+      data paramlist(85)%grib1val /85/ 
+      data paramlist(85)%grib2dsc /2/ 
+      data paramlist(85)%grib2cat /0/ 
+      data paramlist(85)%grib2num /2/ 
+      data paramlist(85)%abbrev   /'TSOIL   '/ 
+      data paramlist(86)%g1tblver /2/ 
+      data paramlist(86)%grib1val /86/ 
+      data paramlist(86)%grib2dsc /2/ 
+      data paramlist(86)%grib2cat /0/ 
+      data paramlist(86)%grib2num /3/ 
+      data paramlist(86)%abbrev   /'SOIL M '/ 
+      data paramlist(87)%g1tblver /2/ 
+      data paramlist(87)%grib1val /87/ 
+      data paramlist(87)%grib2dsc /2/ 
+      data paramlist(87)%grib2cat /0/ 
+      data paramlist(87)%grib2num /4/ 
+      data paramlist(87)%abbrev   /'VEG    '/ 
+      data paramlist(88)%g1tblver /2/ 
+      data paramlist(88)%grib1val /88/ 
+      data paramlist(88)%grib2dsc /10/ 
+      data paramlist(88)%grib2cat /5/ 
+      data paramlist(88)%grib2num /3/ 
+      data paramlist(88)%abbrev   /'SALTY  '/ 
+      data paramlist(89)%g1tblver /2/ 
+      data paramlist(89)%grib1val /89/ 
+      data paramlist(89)%grib2dsc /0/ 
+      data paramlist(89)%grib2cat /3/ 
+      data paramlist(89)%grib2num /10/ 
+      data paramlist(89)%abbrev   /'DEN    '/ 
+      data paramlist(90)%g1tblver /2/ 
+      data paramlist(90)%grib1val /90/ 
+      data paramlist(90)%grib2dsc /2/ 
+      data paramlist(90)%grib2cat /0/ 
+      data paramlist(90)%grib2num /5/ 
+      data paramlist(90)%abbrev   /'WATR   '/ 
+      data paramlist(91)%g1tblver /2/ 
+      data paramlist(91)%grib1val /91/ 
+      data paramlist(91)%grib2dsc /10/ 
+      data paramlist(91)%grib2cat /2/ 
+      data paramlist(91)%grib2num /0/ 
+      data paramlist(91)%abbrev   /'ICE C  '/ 
+      data paramlist(92)%g1tblver /2/ 
+      data paramlist(92)%grib1val /92/ 
+      data paramlist(92)%grib2dsc /10/ 
+      data paramlist(92)%grib2cat /2/ 
+      data paramlist(92)%grib2num /1/ 
+      data paramlist(92)%abbrev   /'ICETK  '/ 
+      data paramlist(93)%g1tblver /2/ 
+      data paramlist(93)%grib1val /93/ 
+      data paramlist(93)%grib2dsc /10/ 
+      data paramlist(93)%grib2cat /2/ 
+      data paramlist(93)%grib2num /2/ 
+      data paramlist(93)%abbrev   /'DICED  '/ 
+      data paramlist(94)%g1tblver /2/ 
+      data paramlist(94)%grib1val /94/ 
+      data paramlist(94)%grib2dsc /10/ 
+      data paramlist(94)%grib2cat /2/ 
+      data paramlist(94)%grib2num /3/ 
+      data paramlist(94)%abbrev   /'SICED  '/ 
+      data paramlist(95)%g1tblver /2/ 
+      data paramlist(95)%grib1val /95/ 
+      data paramlist(95)%grib2dsc /10/ 
+      data paramlist(95)%grib2cat /2/ 
+      data paramlist(95)%grib2num /4/ 
+      data paramlist(95)%abbrev   /'U ICE  '/ 
+      data paramlist(96)%g1tblver /2/ 
+      data paramlist(96)%grib1val /96/ 
+      data paramlist(96)%grib2dsc /10/ 
+      data paramlist(96)%grib2cat /2/ 
+      data paramlist(96)%grib2num /5/ 
+      data paramlist(96)%abbrev   /'V ICE  '/ 
+      data paramlist(97)%g1tblver /2/ 
+      data paramlist(97)%grib1val /97/ 
+      data paramlist(97)%grib2dsc /10/ 
+      data paramlist(97)%grib2cat /2/ 
+      data paramlist(97)%grib2num /6/ 
+      data paramlist(97)%abbrev   /'ICE G  '/ 
+      data paramlist(98)%g1tblver /2/ 
+      data paramlist(98)%grib1val /98/ 
+      data paramlist(98)%grib2dsc /10/ 
+      data paramlist(98)%grib2cat /2/ 
+      data paramlist(98)%grib2num /7/ 
+      data paramlist(98)%abbrev   /'ICE D  '/ 
+      data paramlist(99)%g1tblver /2/ 
+      data paramlist(99)%grib1val /99/ 
+      data paramlist(99)%grib2dsc /0/ 
+      data paramlist(99)%grib2cat /1/ 
+      data paramlist(99)%grib2num /16/ 
+      data paramlist(99)%abbrev   /'SNO M  '/ 
+      data paramlist(100)%g1tblver /2/ 
+      data paramlist(100)%grib1val /100/ 
+      data paramlist(100)%grib2dsc /10/ 
+      data paramlist(100)%grib2cat /0/ 
+      data paramlist(100)%grib2num /3/ 
+      data paramlist(100)%abbrev   /'HTSGW  '/ 
+      data paramlist(101)%g1tblver /2/ 
+      data paramlist(101)%grib1val /101/ 
+      data paramlist(101)%grib2dsc /10/ 
+      data paramlist(101)%grib2cat /0/ 
+      data paramlist(101)%grib2num /4/ 
+      data paramlist(101)%abbrev   /'WVDIR  '/ 
+      data paramlist(102)%g1tblver /2/ 
+      data paramlist(102)%grib1val /102/ 
+      data paramlist(102)%grib2dsc /10/ 
+      data paramlist(102)%grib2cat /0/ 
+      data paramlist(102)%grib2num /5/ 
+      data paramlist(102)%abbrev   /'WVHGT  '/ 
+      data paramlist(103)%g1tblver /2/ 
+      data paramlist(103)%grib1val /103/ 
+      data paramlist(103)%grib2dsc /10/ 
+      data paramlist(103)%grib2cat /0/ 
+      data paramlist(103)%grib2num /6/ 
+      data paramlist(103)%abbrev   /'WVPER  '/ 
+      data paramlist(104)%g1tblver /2/ 
+      data paramlist(104)%grib1val /104/ 
+      data paramlist(104)%grib2dsc /10/ 
+      data paramlist(104)%grib2cat /0/ 
+      data paramlist(104)%grib2num /7/ 
+      data paramlist(104)%abbrev   /'SWDIR  '/ 
+      data paramlist(105)%g1tblver /2/ 
+      data paramlist(105)%grib1val /105/ 
+      data paramlist(105)%grib2dsc /10/ 
+      data paramlist(105)%grib2cat /0/ 
+      data paramlist(105)%grib2num /8/ 
+      data paramlist(105)%abbrev   /'SWELL  '/ 
+      data paramlist(106)%g1tblver /2/ 
+      data paramlist(106)%grib1val /106/ 
+      data paramlist(106)%grib2dsc /10/ 
+      data paramlist(106)%grib2cat /0/ 
+      data paramlist(106)%grib2num /9/ 
+      data paramlist(106)%abbrev   /'SWPER  '/ 
+      data paramlist(107)%g1tblver /2/ 
+      data paramlist(107)%grib1val /107/ 
+      data paramlist(107)%grib2dsc /10/ 
+      data paramlist(107)%grib2cat /0/ 
+      data paramlist(107)%grib2num /10/ 
+      data paramlist(107)%abbrev   /'DIRPW  '/ 
+      data paramlist(108)%g1tblver /2/ 
+      data paramlist(108)%grib1val /108/ 
+      data paramlist(108)%grib2dsc /10/ 
+      data paramlist(108)%grib2cat /0/ 
+      data paramlist(108)%grib2num /11/ 
+      data paramlist(108)%abbrev   /'PERPW  '/ 
+      data paramlist(109)%g1tblver /2/ 
+      data paramlist(109)%grib1val /109/ 
+      data paramlist(109)%grib2dsc /10/ 
+      data paramlist(109)%grib2cat /0/ 
+      data paramlist(109)%grib2num /12/ 
+      data paramlist(109)%abbrev   /'DIRSW  '/ 
+      data paramlist(110)%g1tblver /2/ 
+      data paramlist(110)%grib1val /110/ 
+      data paramlist(110)%grib2dsc /10/ 
+      data paramlist(110)%grib2cat /0/ 
+      data paramlist(110)%grib2num /13/ 
+      data paramlist(110)%abbrev   /'PERSW  '/ 
+      data paramlist(111)%g1tblver /2/ 
+      data paramlist(111)%grib1val /111/ 
+      data paramlist(111)%grib2dsc /0/ 
+      data paramlist(111)%grib2cat /4/ 
+      data paramlist(111)%grib2num /0/ 
+      data paramlist(111)%abbrev   /'NSWRS  '/ 
+      data paramlist(112)%g1tblver /2/ 
+      data paramlist(112)%grib1val /112/ 
+      data paramlist(112)%grib2dsc /0/ 
+      data paramlist(112)%grib2cat /5/ 
+      data paramlist(112)%grib2num /0/ 
+      data paramlist(112)%abbrev   /'NLWRS  '/ 
+      data paramlist(113)%g1tblver /2/ 
+      data paramlist(113)%grib1val /113/ 
+      data paramlist(113)%grib2dsc /0/ 
+      data paramlist(113)%grib2cat /4/ 
+      data paramlist(113)%grib2num /1/ 
+      data paramlist(113)%abbrev   /'NSWRT  '/ 
+      data paramlist(114)%g1tblver /2/ 
+      data paramlist(114)%grib1val /114/ 
+      data paramlist(114)%grib2dsc /0/ 
+      data paramlist(114)%grib2cat /5/ 
+      data paramlist(114)%grib2num /1/ 
+      data paramlist(114)%abbrev   /'NLWRT  '/ 
+      data paramlist(115)%g1tblver /2/ 
+      data paramlist(115)%grib1val /115/ 
+      data paramlist(115)%grib2dsc /0/ 
+      data paramlist(115)%grib2cat /5/ 
+      data paramlist(115)%grib2num /2/ 
+      data paramlist(115)%abbrev   /'LWAVR  '/ 
+      data paramlist(116)%g1tblver /2/ 
+      data paramlist(116)%grib1val /116/ 
+      data paramlist(116)%grib2dsc /0/ 
+      data paramlist(116)%grib2cat /4/ 
+      data paramlist(116)%grib2num /2/ 
+      data paramlist(116)%abbrev   /'SWAVR  '/ 
+      data paramlist(117)%g1tblver /2/ 
+      data paramlist(117)%grib1val /117/ 
+      data paramlist(117)%grib2dsc /0/ 
+      data paramlist(117)%grib2cat /4/ 
+      data paramlist(117)%grib2num /3/ 
+      data paramlist(117)%abbrev   /'G RAD  '/ 
+      data paramlist(118)%g1tblver /2/ 
+      data paramlist(118)%grib1val /118/ 
+      data paramlist(118)%grib2dsc /0/ 
+      data paramlist(118)%grib2cat /4/ 
+      data paramlist(118)%grib2num /4/ 
+      data paramlist(118)%abbrev   /'BRTMP  '/ 
+      data paramlist(119)%g1tblver /2/ 
+      data paramlist(119)%grib1val /119/ 
+      data paramlist(119)%grib2dsc /0/ 
+      data paramlist(119)%grib2cat /4/ 
+      data paramlist(119)%grib2num /5/ 
+      data paramlist(119)%abbrev   /'LWRAD  '/ 
+      data paramlist(120)%g1tblver /2/ 
+      data paramlist(120)%grib1val /120/ 
+      data paramlist(120)%grib2dsc /0/ 
+      data paramlist(120)%grib2cat /4/ 
+      data paramlist(120)%grib2num /6/ 
+      data paramlist(120)%abbrev   /'SWRAD  '/ 
+      data paramlist(121)%g1tblver /2/ 
+      data paramlist(121)%grib1val /121/ 
+      data paramlist(121)%grib2dsc /0/ 
+      data paramlist(121)%grib2cat /0/ 
+      data paramlist(121)%grib2num /10/ 
+      data paramlist(121)%abbrev   /'LHTFL  '/ 
+      data paramlist(122)%g1tblver /2/ 
+      data paramlist(122)%grib1val /122/ 
+      data paramlist(122)%grib2dsc /0/ 
+      data paramlist(122)%grib2cat /0/ 
+      data paramlist(122)%grib2num /11/ 
+      data paramlist(122)%abbrev   /'SHTFL  '/ 
+      data paramlist(123)%g1tblver /2/ 
+      data paramlist(123)%grib1val /123/ 
+      data paramlist(123)%grib2dsc /0/ 
+      data paramlist(123)%grib2cat /2/ 
+      data paramlist(123)%grib2num /20/ 
+      data paramlist(123)%abbrev   /'BLYDP  '/ 
+      data paramlist(124)%g1tblver /2/ 
+      data paramlist(124)%grib1val /124/ 
+      data paramlist(124)%grib2dsc /0/ 
+      data paramlist(124)%grib2cat /2/ 
+      data paramlist(124)%grib2num /17/ 
+      data paramlist(124)%abbrev   /'U FLX  '/ 
+      data paramlist(125)%g1tblver /2/ 
+      data paramlist(125)%grib1val /125/ 
+      data paramlist(125)%grib2dsc /0/ 
+      data paramlist(125)%grib2cat /2/ 
+      data paramlist(125)%grib2num /18/ 
+      data paramlist(125)%abbrev   /'V FLX  '/ 
+      data paramlist(126)%g1tblver /2/ 
+      data paramlist(126)%grib1val /126/ 
+      data paramlist(126)%grib2dsc /0/ 
+      data paramlist(126)%grib2cat /2/ 
+      data paramlist(126)%grib2num /19/ 
+      data paramlist(126)%abbrev   /'WMIXE  '/ 
+      data paramlist(127)%g1tblver /2/ 
+      data paramlist(127)%grib1val /127/ 
+      data paramlist(127)%grib2dsc /255/ 
+      data paramlist(127)%grib2cat /255/ 
+      data paramlist(127)%grib2num /255/ 
+      data paramlist(127)%abbrev   /'IMG D  '/ 
+!
+!  GRIB1 parameters in NCEP Local Table version 2
+!  Added 8/07/2003
+!
+      data paramlist(128)%g1tblver /2/ 
+      data paramlist(128)%grib1val /229/ 
+      data paramlist(128)%grib2dsc /0/ 
+      data paramlist(128)%grib2cat /0/ 
+      data paramlist(128)%grib2num /192/ 
+      data paramlist(128)%abbrev   /'SNOHF  '/ 
+      data paramlist(129)%g1tblver /2/ 
+      data paramlist(129)%grib1val /153/ 
+      data paramlist(129)%grib2dsc /0/ 
+      data paramlist(129)%grib2cat /1/ 
+      data paramlist(129)%grib2num /22/ 
+      data paramlist(129)%abbrev   /'CLWMR  '/ 
+      data paramlist(130)%g1tblver /2/ 
+      data paramlist(130)%grib1val /140/ 
+      data paramlist(130)%grib2dsc /0/ 
+      data paramlist(130)%grib2cat /1/ 
+      data paramlist(130)%grib2num /192/ 
+      data paramlist(130)%abbrev   /'CRAIN  '/ 
+      data paramlist(131)%g1tblver /2/ 
+      data paramlist(131)%grib1val /141/ 
+      data paramlist(131)%grib2dsc /0/ 
+      data paramlist(131)%grib2cat /1/ 
+      data paramlist(131)%grib2num /193/ 
+      data paramlist(131)%abbrev   /'CFRZR  '/ 
+      data paramlist(132)%g1tblver /2/ 
+      data paramlist(132)%grib1val /142/ 
+      data paramlist(132)%grib2dsc /0/ 
+      data paramlist(132)%grib2cat /1/ 
+      data paramlist(132)%grib2num /194/ 
+      data paramlist(132)%abbrev   /'CICEP  '/ 
+      data paramlist(133)%g1tblver /2/ 
+      data paramlist(133)%grib1val /143/ 
+      data paramlist(133)%grib2dsc /0/ 
+      data paramlist(133)%grib2cat /1/ 
+      data paramlist(133)%grib2num /195/ 
+      data paramlist(133)%abbrev   /'CSNOW  '/ 
+      data paramlist(134)%g1tblver /2/ 
+      data paramlist(134)%grib1val /214/ 
+      data paramlist(134)%grib2dsc /0/ 
+      data paramlist(134)%grib2cat /1/ 
+      data paramlist(134)%grib2num /196/ 
+      data paramlist(134)%abbrev   /'CPRAT  '/ 
+      data paramlist(135)%g1tblver /2/ 
+      data paramlist(135)%grib1val /135/ 
+      data paramlist(135)%grib2dsc /0/ 
+      data paramlist(135)%grib2cat /1/ 
+      data paramlist(135)%grib2num /197/ 
+      data paramlist(135)%abbrev   /'MCONV  '/ 
+      data paramlist(136)%g1tblver /2/ 
+      data paramlist(136)%grib1val /194/ 
+      data paramlist(136)%grib2dsc /1/ 
+      data paramlist(136)%grib2cat /1/ 
+      data paramlist(136)%grib2num /193/ 
+      data paramlist(136)%abbrev   /'CPOFP  '/ 
+      data paramlist(137)%g1tblver /2/ 
+      data paramlist(137)%grib1val /228/ 
+      data paramlist(137)%grib2dsc /0/ 
+      data paramlist(137)%grib2cat /1/ 
+      data paramlist(137)%grib2num /199/ 
+      data paramlist(137)%abbrev   /'PEVAP  '/ 
+      data paramlist(138)%g1tblver /2/ 
+      data paramlist(138)%grib1val /136/ 
+      data paramlist(138)%grib2dsc /0/ 
+      data paramlist(138)%grib2cat /2/ 
+      data paramlist(138)%grib2num /192/ 
+      data paramlist(138)%abbrev   /'VW SH  '/ 
+      data paramlist(139)%g1tblver /2/ 
+      data paramlist(139)%grib1val /172/ 
+      data paramlist(139)%grib2dsc /0/ 
+      data paramlist(139)%grib2cat /2/ 
+      data paramlist(139)%grib2num /193/ 
+      data paramlist(139)%abbrev   /'M FLX  '/ 
+      data paramlist(140)%g1tblver /2/ 
+      data paramlist(140)%grib1val /196/ 
+      data paramlist(140)%grib2dsc /0/ 
+      data paramlist(140)%grib2cat /2/ 
+      data paramlist(140)%grib2num /194/ 
+      data paramlist(140)%abbrev   /'USTM   '/ 
+      data paramlist(141)%g1tblver /2/ 
+      data paramlist(141)%grib1val /197/ 
+      data paramlist(141)%grib2dsc /0/ 
+      data paramlist(141)%grib2cat /2/ 
+      data paramlist(141)%grib2num /195/ 
+      data paramlist(141)%abbrev   /'VSTM   '/ 
+      data paramlist(142)%g1tblver /2/ 
+      data paramlist(142)%grib1val /252/ 
+      data paramlist(142)%grib2dsc /0/ 
+      data paramlist(142)%grib2cat /2/ 
+      data paramlist(142)%grib2num /196/ 
+      data paramlist(142)%abbrev   /'CD     '/ 
+      data paramlist(143)%g1tblver /2/ 
+      data paramlist(143)%grib1val /253/ 
+      data paramlist(143)%grib2dsc /0/ 
+      data paramlist(143)%grib2cat /2/ 
+      data paramlist(143)%grib2num /197/ 
+      data paramlist(143)%abbrev   /'FRICV  '/ 
+      data paramlist(144)%g1tblver /2/ 
+      data paramlist(144)%grib1val /130/ 
+      data paramlist(144)%grib2dsc /0/ 
+      data paramlist(144)%grib2cat /3/ 
+      data paramlist(144)%grib2num /192/ 
+      data paramlist(144)%abbrev   /'MSLET  '/ 
+      data paramlist(145)%g1tblver /2/ 
+      data paramlist(145)%grib1val /204/ 
+      data paramlist(145)%grib2dsc /0/ 
+      data paramlist(145)%grib2cat /4/ 
+      data paramlist(145)%grib2num /192/ 
+      data paramlist(145)%abbrev   /'DSWRF  '/ 
+      data paramlist(146)%g1tblver /2/ 
+      data paramlist(146)%grib1val /211/ 
+      data paramlist(146)%grib2dsc /0/ 
+      data paramlist(146)%grib2cat /4/ 
+      data paramlist(146)%grib2num /193/ 
+      data paramlist(146)%abbrev   /'USWRF  '/ 
+      data paramlist(147)%g1tblver /2/ 
+      data paramlist(147)%grib1val /205/ 
+      data paramlist(147)%grib2dsc /0/ 
+      data paramlist(147)%grib2cat /5/ 
+      data paramlist(147)%grib2num /192/ 
+      data paramlist(147)%abbrev   /'DLWRF  '/ 
+      data paramlist(148)%g1tblver /2/ 
+      data paramlist(148)%grib1val /212/ 
+      data paramlist(148)%grib2dsc /0/ 
+      data paramlist(148)%grib2cat /5/ 
+      data paramlist(148)%grib2num /193/ 
+      data paramlist(148)%abbrev   /'ULWRF  '/ 
+      data paramlist(149)%g1tblver /2/ 
+      data paramlist(149)%grib1val /213/ 
+      data paramlist(149)%grib2dsc /0/ 
+      data paramlist(149)%grib2cat /6/ 
+      data paramlist(149)%grib2num /192/ 
+      data paramlist(149)%abbrev   /'CDLYR  '/ 
+      data paramlist(150)%g1tblver /2/ 
+      data paramlist(150)%grib1val /132/ 
+      data paramlist(150)%grib2dsc /0/ 
+      data paramlist(150)%grib2cat /7/ 
+      data paramlist(150)%grib2num /193/ 
+      data paramlist(150)%abbrev   /'4LFTX  '/ 
+      data paramlist(151)%g1tblver /2/ 
+      data paramlist(151)%grib1val /157/ 
+      data paramlist(151)%grib2dsc /0/ 
+      data paramlist(151)%grib2cat /7/ 
+      data paramlist(151)%grib2num /6/ 
+      data paramlist(151)%abbrev   /'CAPE   '/ 
+      data paramlist(152)%g1tblver /2/ 
+      data paramlist(152)%grib1val /156/ 
+      data paramlist(152)%grib2dsc /0/ 
+      data paramlist(152)%grib2cat /7/ 
+      data paramlist(152)%grib2num /7/ 
+      data paramlist(152)%abbrev   /'CIN    '/ 
+      data paramlist(153)%g1tblver /2/ 
+      data paramlist(153)%grib1val /190/ 
+      data paramlist(153)%grib2dsc /0/ 
+      data paramlist(153)%grib2cat /7/ 
+      data paramlist(153)%grib2num /8/ 
+      data paramlist(153)%abbrev   /'HLCY   '/ 
+      data paramlist(154)%g1tblver /2/ 
+      data paramlist(154)%grib1val /131/ 
+      data paramlist(154)%grib2dsc /0/ 
+      data paramlist(154)%grib2cat /7/ 
+      data paramlist(154)%grib2num /192/ 
+      data paramlist(154)%abbrev   /'LFT X  '/ 
+      data paramlist(155)%g1tblver /2/ 
+      data paramlist(155)%grib1val /158/ 
+      data paramlist(155)%grib2dsc /0/ 
+      data paramlist(155)%grib2cat /19/ 
+      data paramlist(155)%grib2num /11/ 
+      data paramlist(155)%abbrev   /'TKE    '/ 
+      data paramlist(156)%g1tblver /2/ 
+      data paramlist(156)%grib1val /176/ 
+      data paramlist(156)%grib2dsc /0/ 
+      data paramlist(156)%grib2cat /191/ 
+      data paramlist(156)%grib2num /192/ 
+      data paramlist(156)%abbrev   /'NLAT   '/ 
+      data paramlist(157)%g1tblver /2/ 
+      data paramlist(157)%grib1val /177/ 
+      data paramlist(157)%grib2dsc /0/ 
+      data paramlist(157)%grib2cat /191/ 
+      data paramlist(157)%grib2num /193/ 
+      data paramlist(157)%abbrev   /'ELON   '/ 
+      data paramlist(158)%g1tblver /2/ 
+      data paramlist(158)%grib1val /234/ 
+      data paramlist(158)%grib2dsc /1/ 
+      data paramlist(158)%grib2cat /0/ 
+      data paramlist(158)%grib2num /192/ 
+      data paramlist(158)%abbrev   /'BGRUN  '/ 
+      data paramlist(159)%g1tblver /2/ 
+      data paramlist(159)%grib1val /235/ 
+      data paramlist(159)%grib2dsc /1/ 
+      data paramlist(159)%grib2cat /0/ 
+      data paramlist(159)%grib2num /193/ 
+      data paramlist(159)%abbrev   /'SSRUN  '/ 
+      data paramlist(160)%g1tblver /2/ 
+      data paramlist(160)%grib1val /144/ 
+      data paramlist(160)%grib2dsc /2/ 
+      data paramlist(160)%grib2cat /0/ 
+      data paramlist(160)%grib2num /192/ 
+      data paramlist(160)%abbrev   /'SOILW  '/ 
+      data paramlist(161)%g1tblver /2/ 
+      data paramlist(161)%grib1val /155/ 
+      data paramlist(161)%grib2dsc /2/ 
+      data paramlist(161)%grib2cat /0/ 
+      data paramlist(161)%grib2num /193/ 
+      data paramlist(161)%abbrev   /'GFLUX  '/ 
+      data paramlist(162)%g1tblver /2/ 
+      data paramlist(162)%grib1val /207/ 
+      data paramlist(162)%grib2dsc /2/ 
+      data paramlist(162)%grib2cat /0/ 
+      data paramlist(162)%grib2num /194/ 
+      data paramlist(162)%abbrev   /'MSTAV  '/ 
+      data paramlist(163)%g1tblver /2/ 
+      data paramlist(163)%grib1val /208/ 
+      data paramlist(163)%grib2dsc /2/ 
+      data paramlist(163)%grib2cat /0/ 
+      data paramlist(163)%grib2num /195/ 
+      data paramlist(163)%abbrev   /'SFEXC  '/ 
+      data paramlist(164)%g1tblver /2/ 
+      data paramlist(164)%grib1val /223/ 
+      data paramlist(164)%grib2dsc /2/ 
+      data paramlist(164)%grib2cat /0/ 
+      data paramlist(164)%grib2num /196/ 
+      data paramlist(164)%abbrev   /'CNWAT  '/ 
+      data paramlist(165)%g1tblver /2/ 
+      data paramlist(165)%grib1val /226/ 
+      data paramlist(165)%grib2dsc /2/ 
+      data paramlist(165)%grib2cat /0/ 
+      data paramlist(165)%grib2num /197/ 
+      data paramlist(165)%abbrev   /'BMIXL  '/ 
+      data paramlist(166)%g1tblver /2/ 
+      data paramlist(166)%grib1val /154/ 
+      data paramlist(166)%grib2dsc /0/ 
+      data paramlist(166)%grib2cat /14/ 
+      data paramlist(166)%grib2num /192/ 
+      data paramlist(166)%abbrev   /'O3MR   '/ 
+      data paramlist(167)%g1tblver /2/ 
+      data paramlist(167)%grib1val /222/ 
+      data paramlist(167)%grib2dsc /0/ 
+      data paramlist(167)%grib2cat /3/ 
+      data paramlist(167)%grib2num /193/ 
+      data paramlist(167)%abbrev   /'5WAVH  '/ 
+      data paramlist(168)%g1tblver /2/ 
+      data paramlist(168)%grib1val /145/ 
+      data paramlist(168)%grib2dsc /0/ 
+      data paramlist(168)%grib2cat /1/ 
+      data paramlist(168)%grib2num /200/ 
+      data paramlist(168)%abbrev   /'PEVPR  '/ 
+      data paramlist(169)%g1tblver /2/ 
+      data paramlist(169)%grib1val /146/ 
+      data paramlist(169)%grib2dsc /0/ 
+      data paramlist(169)%grib2cat /6/ 
+      data paramlist(169)%grib2num /193/ 
+      data paramlist(169)%abbrev   /'CWORK  '/ 
+      data paramlist(170)%g1tblver /2/ 
+      data paramlist(170)%grib1val /147/ 
+      data paramlist(170)%grib2dsc /0/ 
+      data paramlist(170)%grib2cat /3/ 
+      data paramlist(170)%grib2num /194/ 
+      data paramlist(170)%abbrev   /'U-GWD  '/ 
+      data paramlist(171)%g1tblver /2/ 
+      data paramlist(171)%grib1val /148/ 
+      data paramlist(171)%grib2dsc /0/ 
+      data paramlist(171)%grib2cat /3/ 
+      data paramlist(171)%grib2num /195/ 
+      data paramlist(171)%abbrev   /'V-GWD  '/ 
+      data paramlist(172)%g1tblver /2/ 
+      data paramlist(172)%grib1val /221/ 
+      data paramlist(172)%grib2dsc /0/ 
+      data paramlist(172)%grib2cat /3/ 
+      data paramlist(172)%grib2num /196/ 
+      data paramlist(172)%abbrev   /'HPBL   '/ 
+      data paramlist(173)%g1tblver /2/ 
+      data paramlist(173)%grib1val /230/ 
+      data paramlist(173)%grib2dsc /0/ 
+      data paramlist(173)%grib2cat /3/ 
+      data paramlist(173)%grib2num /197/ 
+      data paramlist(173)%abbrev   /'5WAVA  '/ 
+! Added 9/26/2003
+      data paramlist(174) /gribparam(130,160,2,3,192,'SOILL   ')/
+      data paramlist(175) /gribparam(130,171,2,3,193,'UNKNOWN ')/
+      data paramlist(176) /gribparam(130,219,2,0,201,'WILT    ')/
+      data paramlist(177) /gribparam(130,222,2,3,194,'SLTYP   ')/
+      data paramlist(178) /gribparam(2,224,2,3,0,'SOTYP   ')/
+      data paramlist(179) /gribparam(2,225,2,0,198,'VGTYP   ')/
+      data paramlist(180) /gribparam(130,230,2,3,195,'SMREF   ')/
+      data paramlist(181) /gribparam(130,231,2,3,196,'SMDRY   ')/
+      data paramlist(182) /gribparam(2,238,0,1,201,'SNOWC   ')/
+      data paramlist(183) /gribparam(130,240,2,3,197,'POROS   ')/
+      data paramlist(184) /gribparam(129,131,0,1,202,'FRAIN   ')/
+      data paramlist(185) /gribparam(129,132,0,6,199,'FICE    ')/
+      data paramlist(186) /gribparam(129,133,0,1,203,'FRIME   ')/
+      data paramlist(187) /gribparam(129,134,0,6,194,'CUEFI   ')/
+      data paramlist(188) /gribparam(129,135,0,6,195,'TCOND   ')/
+      data paramlist(189) /gribparam(129,136,0,6,196,'TCOLW   ')/
+      data paramlist(190) /gribparam(129,137,0,6,197,'TCOLI   ')/
+      data paramlist(191) /gribparam(129,138,0,1,204,'TCOLR   ')/
+      data paramlist(192) /gribparam(129,139,0,1,205,'TCOLS   ')/
+      data paramlist(193) /gribparam(129,140,0,6,198,'TCOLC   ')/
+      data paramlist(194) /gribparam(130,159,0,19,192,'MXSALB  ')/
+      data paramlist(195) /gribparam(130,170,0,19,193,'SNFALB  ')/
+      data paramlist(196) /gribparam(2,170,0,1,24,'RWMR    ')/
+      data paramlist(197) /gribparam(2,171,0,1,25,'SNMR    ')/
+      data paramlist(198) /gribparam(130,181,2,0,199,'CCOND   ')/
+      data paramlist(199) /gribparam(130,203,2,0,200,'RSMIN   ')/
+      data paramlist(200) /gribparam(130,246,2,0,202,'RCS     ')/
+      data paramlist(201) /gribparam(130,247,2,0,203,'RCT     ')/
+      data paramlist(202) /gribparam(130,248,2,0,204,'RCQ     ')/
+      data paramlist(203) /gribparam(130,249,2,0,205,'RCSOL   ')/
+      data paramlist(204) /gribparam(2,254,0,7,194,'RI      ')/
+      data paramlist(205) /gribparam(129,190,3,1,192,'USCT    ')/
+      data paramlist(206) /gribparam(129,191,3,1,193,'VSCT    ')/
+      data paramlist(207) /gribparam(129,171,0,191,194,'TSEC    ')/
+      data paramlist(208) /gribparam(129,180,0,14,193,'OZCON   ')/
+      data paramlist(209) /gribparam(129,181,0,14,194,'OZCAT   ')/
+      data paramlist(210) /gribparam(2,193,1,1,2,'POP     ')/
+      data paramlist(211) /gribparam(2,195,1,1,192,'CPOZP   ')/
+      data paramlist(212) /gribparam(2,180,0,2,22,'GUST    ')/
+
+
+      contains
+
+
+         subroutine param_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    param_g1_to_g2 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-05
+!
+! ABSTRACT: This subroutine returns the corresponding GRIB2 Discipline
+!   Category and Number for a given GRIB1 parameter value and table version.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-11  Gilbert
+!
+! USAGE:    CALL param_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num)
+!   INPUT ARGUMENT LIST:
+!     g1val    - GRIB1 parameter number for which discipline is requested
+!     g1ver    - GRIB1 parameter table version number
+!
+!   OUTPUT ARGUMENT LIST:      
+!     g2disc   - corresponding GRIB2 Discipline number
+!     g2cat    - corresponding GRIB2 Category number
+!     g2num    - corresponding GRIB2 Parameter number within Category g2cat
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: g1val,g1ver
+           integer,intent(out) :: g2disc,g2cat,g2num
+
+           g2disc=255
+           g2cat=255
+           g2num=255
+! for testing
+!           g2num=g1val
+! for testing
+
+           do n=1,MAXPARAM
+              if (paramlist(n)%grib1val.eq.g1val .AND.
+     &            paramlist(n)%g1tblver.eq.g1ver ) then
+                 g2disc=paramlist(n)%grib2dsc
+                 g2cat=paramlist(n)%grib2cat
+                 g2num=paramlist(n)%grib2num
+                 return
+              endif
+           enddo
+
+           print *,'param_g1_to_g2:GRIB1 param ',g1val,' not found.',
+     &             ' for table version ',g1ver
+           return
+         end subroutine
+
+         character(len=8) function param_get_abbrev(g2disc,g2cat,g2num)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    param_get_abbrev 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-01-04
+!
+! ABSTRACT: This function returns the parameter abbreviation for
+!   a given GRIB2 Discipline, Category and Parameter number.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-05  Gilbert
+!
+! USAGE:     abrev=param_get_abbrev(g2disc,g2cat,g2num)
+!   INPUT ARGUMENT LIST:
+!     g2disc   - GRIB2 discipline number (See Code Table 0.0)
+!     g2cat    - corresponding GRIB2 Category number
+!     g2num    - corresponding GRIB2 Parameter number within Category g2cat
+!
+! RETURNS:  ASCII Paramter Abbreviation
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: g2disc,g2cat,g2num
+
+           param_get_abbrev='UNKNOWN '
+
+           do n=1,MAXPARAM
+              if (paramlist(n)%grib2dsc.eq.g2disc.AND.
+     &             paramlist(n)%grib2cat.eq.g2cat.AND.
+     &             paramlist(n)%grib2num.eq.g2num) then
+                 param_get_abbrev=paramlist(n)%abbrev
+                 return
+              endif
+           enddo
+
+!           print *,'param_get_abbrev:GRIB2 param ',g2disc,g2cat,
+!     &              g2num,' not found.'
+           return
+         end function
+
+
+         subroutine param_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    param_g2_to_g1 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-01-04
+!
+! ABSTRACT: This function returns the GRIB 1 parameter number for 
+!   a given GRIB2 Discipline, Category and Parameter number.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-05  Gilbert
+!
+! USAGE:     call param_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver)
+!   INPUT ARGUMENT LIST:
+!     g2disc   - GRIB2 discipline number (See Code Table 0.0)
+!     g2cat    - corresponding GRIB2 Category number
+!     g2num    - corresponding GRIB2 Parameter number within Category g2cat
+!
+!   OUTPUT ARGUMENT LIST:      
+!     g1val    - GRIB1 parameter number for which discipline is requested
+!     g1ver    - GRIB1 parameter table version number
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: g2disc,g2cat,g2num
+           integer,intent(out) :: g1val,g1ver
+
+           g1val=255
+           g1ver=255
+
+! for testing
+!           if ( g2disc.eq.255.and.g2cat.eq.255 ) then
+!             g1val=g2num
+!             g1ver=2
+!             return
+!           endif
+! for testing
+
+           do n=1,MAXPARAM
+              if (paramlist(n)%grib2dsc.eq.g2disc.AND.
+     &             paramlist(n)%grib2cat.eq.g2cat.AND.
+     &             paramlist(n)%grib2num.eq.g2num) then
+                 g1val=paramlist(n)%grib1val
+                 g1ver=paramlist(n)%g1tblver
+                 return
+              endif
+           enddo
+
+           print *,'param_g2_to_g1:GRIB2 param ',g2disc,g2cat,
+     &              g2num,' not found.'
+           return
+         end subroutine
+
+
+      end module
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/pdstemplates.F b/wrfv2_fire/external/io_grib2/g2lib/pdstemplates.F
new file mode 100644
index 00000000..44e91d5e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/pdstemplates.F
@@ -0,0 +1,494 @@
+      module pdstemplates
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    pdstemplates 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
+!
+! ABSTRACT: This Fortran Module contains info on all the available 
+!   GRIB2 Product Definition Templates used in Section 4 (PDS).
+!   Each Template has three parts: The number of entries in the template
+!   (mapgridlen);  A map of the template (mapgrid), which contains the
+!   number of octets in which to pack each of the template values; and
+!   a logical value (needext) that indicates whether the Template needs 
+!   to be extended.  In some cases the number of entries in a template 
+!   can vary depending upon values specified in the "static" part of 
+!   the template.  ( See Template 4.3 as an example )
+!
+!   This module also contains two subroutines.  Subroutine getpdstemplate
+!   returns the octet map for a specified Template number, and
+!   subroutine extpdstemplate will calculate the extended octet map
+!   of an appropriate template given values for the "static" part of the 
+!   template.  See docblocks below for the arguments and usage of these 
+!   routines.
+!
+!   NOTE:  Array mapgrid contains the number of octets in which the 
+!   corresponding template values will be stored.  A negative value in
+!   mapgrid is used to indicate that the corresponding template entry can
+!   contain negative values.  This information is used later when packing
+!   (or unpacking) the template data values.  Negative data values in GRIB
+!   are stored with the left most bit set to one, and a negative number
+!   of octets value in mapgrid() indicates that this possibility should
+!   be considered.  The number of octets used to store the data value
+!   in this case would be the absolute value of the negative value in 
+!   mapgrid().
+!  
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-11  Gilbert
+! 2001-12-04  Gilbert  -  Added Templates 4.12, 4.12, 4.14,
+!                         4.1000, 4.1001, 4.1002, 4.1100 and 4.1101
+!
+! USAGE:    use pdstemplates
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,parameter :: MAXLEN=200,MAXTEMP=23
+
+      type pdstemplate
+          integer :: template_num
+          integer :: mappdslen
+          integer,dimension(MAXLEN) :: mappds
+          logical :: needext
+      end type pdstemplate
+
+      type(pdstemplate),dimension(MAXTEMP) :: templates
+
+      data templates(1)%template_num /0/     !  Fcst at Level/Layer
+      data templates(1)%mappdslen /15/
+      data templates(1)%needext /.false./
+      data (templates(1)%mappds(j),j=1,15) 
+     &                             /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
+
+      data templates(2)%template_num /1/     !  Ens fcst at level/layer
+      data templates(2)%mappdslen /18/
+      data templates(2)%needext /.false./
+      data (templates(2)%mappds(j),j=1,18)
+     &                        /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/
+
+      data templates(3)%template_num /2/     !  Derived Ens fcst at level/layer
+      data templates(3)%mappdslen /17/
+      data templates(3)%needext /.false./
+      data (templates(3)%mappds(j),j=1,17)
+     &                      /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1/
+
+      data templates(4)%template_num /3/     !  Ens cluster fcst rect. area
+      data templates(4)%mappdslen /31/
+      data templates(4)%needext /.true./
+      data (templates(4)%mappds(j),j=1,31)
+     &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4,
+     &        1,-1,4,-1,4/
+
+      data templates(5)%template_num /4/     !  Ens cluster fcst circ. area
+      data templates(5)%mappdslen /30/
+      data templates(5)%needext /.true./
+      data (templates(5)%mappds(j),j=1,30)
+     &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4,
+     &        1,-1,4,-1,4/
+
+      data templates(6)%template_num /5/     !  Prob fcst at level/layer
+      data templates(6)%mappdslen /22/
+      data templates(6)%needext /.false./
+      data (templates(6)%mappds(j),j=1,22)
+     &               /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,4,1,4/
+
+      data templates(7)%template_num /6/     !  Percentile fcst at level/layer
+      data templates(7)%mappdslen /16/
+      data templates(7)%needext /.false./
+      data (templates(7)%mappds(j),j=1,16)
+     &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/
+
+      data templates(8)%template_num /7/     !  Error at level/layer
+      data templates(8)%mappdslen /15/
+      data templates(8)%needext /.false./
+      data (templates(8)%mappds(j),j=1,15)
+     &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
+
+      data templates(9)%template_num /8/     !  Ave or Accum at level/layer
+      data templates(9)%mappdslen /29/
+      data templates(9)%needext /.true./
+      data (templates(9)%mappds(j),j=1,29)
+     &  /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
+
+      data templates(10)%template_num /9/     !  Prob over time interval
+      data templates(10)%mappdslen /36/
+      data templates(10)%needext /.true./
+      data (templates(10)%mappds(j),j=1,36)
+     &  /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,4,-1,4,2,1,1,1,1,1,
+     &   1,4,1,1,1,4,1,4/
+
+      data templates(11)%template_num /10/     !  Percentile over time interval
+      data templates(11)%mappdslen /30/
+      data templates(11)%needext /.true./
+      data (templates(11)%mappds(j),j=1,30)
+     &    /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,2,1,1,1,1,1,1,4,
+     &     1,1,1,4,1,4/
+
+      data templates(12)%template_num /11/     !  Ens member over time interval
+      data templates(12)%mappdslen /32/
+      data templates(12)%needext /.true./
+      data (templates(12)%mappds(j),j=1,32)
+     &    /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1,
+     &     4,1,1,1,4,1,4/
+
+      data templates(13)%template_num /12/     !  Derived Ens fcst over time int
+      data templates(13)%mappdslen /31/
+      data templates(13)%needext /.true./
+      data (templates(13)%mappds(j),j=1,31)
+     &                   /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,
+     &                    2,1,1,1,1,1,1,4,1,1,1,4,1,4/
+
+      data templates(14)%template_num /13/     !  Ens cluster fcst rect. area
+      data templates(14)%mappdslen /45/
+      data templates(14)%needext /.true./
+      data (templates(14)%mappds(j),j=1,45)
+     &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4,
+     &        1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
+
+      data templates(15)%template_num /14/     !  Ens cluster fcst circ. area
+      data templates(15)%mappdslen /44/
+      data templates(15)%needext /.true./
+      data (templates(15)%mappds(j),j=1,44)
+     &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4,
+     &        1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
+
+      data templates(16)%template_num /20/     !  Radar Product
+      data templates(16)%mappdslen /19/
+      data templates(16)%needext /.false./
+      data (templates(16)%mappds(j),j=1,19)
+     &                     /1,1,1,1,1,-4,4,2,4,2,1,1,1,1,1,2,1,3,2/
+
+      data templates(17)%template_num /30/     !  Satellite Product
+      data templates(17)%mappdslen /5/
+      data templates(17)%needext /.true./
+      data (templates(17)%mappds(j),j=1,5)
+     &                            /1,1,1,1,1/
+
+      data templates(18)%template_num /254/     !  CCITTIA5 Character String
+      data templates(18)%mappdslen /3/
+      data templates(18)%needext /.false./
+      data (templates(18)%mappds(j),j=1,3)
+     &                     /1,1,4/
+
+      data templates(19)%template_num /1000/     !  Cross section
+      data templates(19)%mappdslen /9/
+      data templates(19)%needext /.false./
+      data (templates(19)%mappds(j),j=1,9)
+     &                     /1,1,1,1,1,2,1,1,4/
+
+      data templates(20)%template_num /1001/     !  Cross section over time
+      data templates(20)%mappdslen /16/
+      data templates(20)%needext /.false./
+      data (templates(20)%mappds(j),j=1,16)
+     &                     /1,1,1,1,1,2,1,1,4,4,1,1,1,4,1,4/
+
+      data templates(21)%template_num /1002/     !  Cross section processed time
+      data templates(21)%mappdslen /15/
+      data templates(21)%needext /.false./
+      data (templates(21)%mappds(j),j=1,15)
+     &                     /1,1,1,1,1,2,1,1,4,1,1,1,4,4,2/
+
+      data templates(22)%template_num /1100/     !  Hovmoller grid
+      data templates(22)%mappdslen /15/
+      data templates(22)%needext /.false./
+      data (templates(22)%mappds(j),j=1,15)
+     &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
+
+      data templates(23)%template_num /1101/     !  Hovmoller with stat proc
+      data templates(23)%mappdslen /22/
+      data templates(23)%needext /.false./
+      data (templates(23)%mappds(j),j=1,22)
+     &               /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,4,1,1,1,4,1,4/
+
+
+      contains
+
+         integer function getpdsindex(number)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getpdsindex
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-28
+!
+! ABSTRACT: This function returns the index of specified Product
+!   Definition Template 4.NN (NN=number) in array templates.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-28  Gilbert
+!
+! USAGE:    index=getpdsindex(number)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Product Definition
+!                Template 4.NN that is being requested.
+!
+! RETURNS:  Index of PDT 4.NN in array templates, if template exists.
+!           = -1, otherwise.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+
+           getpdsindex=-1
+
+           do j=1,MAXTEMP
+              if (number.eq.templates(j)%template_num) then
+                 getpdsindex=j
+                 return
+              endif
+           enddo
+
+         end function
+
+
+
+
+         subroutine getpdstemplate(number,nummap,map,needext,iret)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getpdstemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
+!
+! ABSTRACT: This subroutine returns PDS template information for a 
+!   specified Product Definition Template 4.NN.
+!   The number of entries in the template is returned along with a map
+!   of the number of octets occupied by each entry.  Also, a flag is
+!   returned to indicate whether the template would need to be extended.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-11  Gilbert
+!
+! USAGE:    CALL getpdstemplate(number,nummap,map,needext,iret)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Product Definition 
+!                Template 4.NN that is being requested.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     nummap   - Number of entries in the Template
+!     map()    - An array containing the number of octets that each 
+!                template entry occupies when packed up into the PDS.
+!     needext  - Logical variable indicating whether the Product Defintion
+!                Template has to be extended.  
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Undefine Product Template number.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+           integer,intent(out) :: nummap,map(*),iret
+           logical,intent(out) :: needext
+
+           iret=0
+
+           index=getpdsindex(number)
+
+           if (index.ne.-1) then
+              nummap=templates(index)%mappdslen
+              needext=templates(index)%needext
+              map(1:nummap)=templates(index)%mappds(1:nummap)
+           else
+             nummap=0
+             needext=.false.
+             print *,'getpdstemplate: PDS Template ',number,
+     &               ' not defined.'
+             iret=1
+           endif
+
+         end subroutine
+
+         subroutine extpdstemplate(number,list,nummap,map)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    extpdstemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
+!
+! ABSTRACT: This subroutine generates the remaining octet map for a
+!   given Product Definition Template, if required.  Some Templates can
+!   vary depending on data values given in an earlier part of the 
+!   Template, and it is necessary to know some of the earlier entry
+!   values to generate the full octet map of the Template.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-11  Gilbert
+!
+! USAGE:    CALL extpdstemplate(number,list,nummap,map)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Product Definition 
+!                Template 4.NN that is being requested.
+!     list()   - The list of values for each entry in the 
+!                the Product Definition Template 4.NN.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     nummap   - Number of entries in the Template
+!     map()    - An array containing the number of octets that each 
+!                template entry occupies when packed up into the GDS.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number,list(*)
+           integer,intent(out) :: nummap,map(*)
+
+           index=getpdsindex(number)
+           if (index.eq.-1) return
+
+           if ( .not. templates(index)%needext ) return
+           nummap=templates(index)%mappdslen
+           map(1:nummap)=templates(index)%mappds(1:nummap)
+
+           if ( number.eq.3 ) then
+              N=list(27)
+              do i=1,N
+                map(nummap+i)=1
+              enddo
+              nummap=nummap+N
+           elseif ( number.eq.4 ) then
+              N=list(26)
+              do i=1,N
+                map(nummap+i)=1
+              enddo
+              nummap=nummap+N
+           elseif ( number.eq.8 ) then
+              if ( list(22).gt.1 ) then
+                do j=2,list(22)
+                  do k=1,6
+                    map(nummap+k)=map(23+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+           elseif ( number.eq.9 ) then
+              if ( list(29).gt.1 ) then
+                do j=2,list(29)
+                  do k=1,6
+                    map(nummap+k)=map(30+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+           elseif ( number.eq.10 ) then
+              if ( list(23).gt.1 ) then
+                do j=2,list(23)
+                  do k=1,6
+                    map(nummap+k)=map(24+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+           elseif ( number.eq.11 ) then
+              if ( list(25).gt.1 ) then
+                do j=2,list(25)
+                  do k=1,6
+                    map(nummap+k)=map(26+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+           elseif ( number.eq.12 ) then
+              if ( list(24).gt.1 ) then
+                do j=2,list(24)
+                  do k=1,6
+                    map(nummap+k)=map(25+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+           elseif ( number.eq.13 ) then
+              if ( list(38).gt.1 ) then
+                do j=2,list(38)
+                  do k=1,6
+                    map(nummap+k)=map(39+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+              N=list(27)
+              do i=1,N
+                map(nummap+i)=1
+              enddo
+              nummap=nummap+N
+           elseif ( number.eq.14 ) then
+              if ( list(37).gt.1 ) then
+                do j=2,list(37)
+                  do k=1,6
+                    map(nummap+k)=map(38+k)
+                  enddo
+                  nummap=nummap+6
+                enddo
+              endif
+              N=list(26)
+              do i=1,N
+                map(nummap+i)=1
+              enddo
+              nummap=nummap+N
+           elseif ( number.eq.30 ) then
+              do j=1,list(5)
+                map(nummap+1)=2
+                map(nummap+2)=2
+                map(nummap+3)=1
+                map(nummap+4)=1
+                map(nummap+5)=4
+                nummap=nummap+5
+              enddo
+           endif
+
+         end subroutine
+
+         integer function getpdtlen(number)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getpdtlen
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-05-11
+!
+! ABSTRACT: This function returns the initial length (number of entries) in 
+!   the "static" part of specified Product Definition Template 4.number.
+!
+! PROGRAM HISTORY LOG:
+! 2004-05-11  Gilbert
+!
+! USAGE:    CALL getpdtlen(number)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Product Definition 
+!                Template 4.NN that is being requested.
+!
+! RETURNS:     Number of entries in the "static" part of PDT 4.number
+!              OR returns 0, if requested template is not found.
+!
+! REMARKS: If user needs the full length of a specific template that
+!    contains additional entries based on values set in the "static" part
+!    of the PDT, subroutine extpdstemplate can be used.
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+
+           getpdtlen=0
+
+           index=getpdsindex(number)
+
+           if (index.ne.-1) then
+              getpdtlen=templates(index)%mappdslen
+           endif
+
+         end function
+
+
+      end module
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/pngpack.F b/wrfv2_fire/external/io_grib2/g2lib/pngpack.F
new file mode 100644
index 00000000..974241cb
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/pngpack.F
@@ -0,0 +1,158 @@
+      subroutine pngpack(fld,width,height,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    pngpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-21
+!
+! ABSTRACT: This subroutine packs up a data field into PNG image format.
+!   After the data field is scaled, and the reference value is subtracted out,
+!   it is treated as a grayscale image and passed to a PNG encoder.
+!   It also fills in GRIB2 Data Representation Template 5.41 or 5.40010 with the
+!   appropriate values.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-21  Gilbert
+!
+! USAGE:    CALL pngpack(fld,width,height,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     width    - number of points in the x direction
+!     height   - number of points in the y direction
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.41 or 5.40010
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                (4) = number of bits for each data value - ignored on input
+!                (5) = Original field type - currently ignored on input
+!                      Data values assumed to be reals.
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.41 or 5.40010
+!                (1) = Reference value - set by pngpack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                (4) = Number of bits containing each grayscale pixel value
+!                (5) = Original field type - currently set = 0 on output.
+!                      Data values assumed to be reals.
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: width,height
+      real,intent(in) :: fld(width*height)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(out) :: lcpack
+
+      real(4) :: ref
+      integer(4) :: iref
+      integer :: ifld(width*height)
+      integer,parameter :: zero=0
+      integer :: enc_png
+      character(len=1),allocatable :: ctemp(:)
+      
+      ndpts=width*height
+      bscale=2.0**real(-idrstmpl(2))
+      dscale=10.0**real(idrstmpl(3))
+!
+!  Find max and min values in the data
+!
+      rmax=fld(1)
+      rmin=fld(1)
+      do j=2,ndpts
+        if (fld(j).gt.rmax) rmax=fld(j)
+        if (fld(j).lt.rmin) rmin=fld(j)
+      enddo
+      maxdif=nint((rmax-rmin)*dscale*bscale)
+!
+!  If max and min values are not equal, pack up field.
+!  If they are equal, we have a constant field, and the reference
+!  value (rmin) is the value for each point in the field and
+!  set nbits to 0.
+!
+      if (rmin.ne.rmax .AND. maxdif.ne.0) then
+        !
+        !  Determine which algorithm to use based on user-supplied 
+        !  binary scale factor and number of bits.
+        !
+        if (idrstmpl(2).eq.0) then
+           !
+           !  No binary scaling and calculate minimum number of 
+           !  bits in which the data will fit.
+           !
+           imin=nint(rmin*dscale)
+           imax=nint(rmax*dscale)
+           maxdif=imax-imin
+           temp=alog(real(maxdif+1))/alog(2.0)
+           nbits=ceiling(temp)
+           rmin=real(imin)
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(fld(j)*dscale)-imin
+           enddo
+        else
+           !
+           !  Use binary scaling factor and calculate minimum number of 
+           !  bits in which the data will fit.
+           !
+           rmin=rmin*dscale
+           rmax=rmax*dscale
+           maxdif=nint((rmax-rmin)*bscale)
+           temp=alog(real(maxdif+1))/alog(2.0)
+           nbits=ceiling(temp)
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        endif
+        !
+        !  Pack data into full octets, then do PNG encode.
+        !  and calculate the length of the packed data in bytes
+        !
+        if (nbits.le.8) then
+            nbits=8
+        elseif (nbits.le.16) then
+            nbits=16
+        elseif (nbits.le.24) then
+            nbits=24
+        else 
+            nbits=32
+        endif
+        nbytes=(nbits/8)*ndpts
+        allocate(ctemp(nbytes))
+        call g2lib_sbytes(ctemp,ifld,0,nbits,0,ndpts)
+        !
+        !  Encode data into PNG Format.
+        !
+        lcpack=enc_png(ctemp,width,height,nbits,cpack)
+        if (lcpack.le.0) then
+           print *,'pngpack: ERROR Encoding PNG = ',lcpack
+        endif
+        deallocate(ctemp)
+
+      else
+        nbits=0
+        lcpack=0
+      endif
+
+!
+!  Fill in ref value and number of bits in Template 5.0
+!
+      call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
+!      call g2lib_gbyte(ref,idrstmpl(1),0,32)
+      iref=transfer(ref,iref)
+      idrstmpl(1)=iref
+      idrstmpl(4)=nbits
+      idrstmpl(5)=0         ! original data were reals
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/pngunpack.F b/wrfv2_fire/external/io_grib2/g2lib/pngunpack.F
new file mode 100644
index 00000000..08413bc3
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/pngunpack.F
@@ -0,0 +1,70 @@
+      subroutine pngunpack(cpack,len,idrstmpl,ndpts,fld)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    pngunpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine unpacks a data field that was packed into a
+!   PNG image format 
+!   using info from the GRIB2 Data Representation Template 5.41 or 5.40010.
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+!
+! USAGE:    CALL pngunpack(cpack,len,idrstmpl,ndpts,fld)
+!   INPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     len      - length of packed field cpack().
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.41 or 5.40010
+!     ndpts    - The number of data values to unpack
+!
+!   OUTPUT ARGUMENT LIST:
+!     fld()    - Contains the unpacked data values
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cpack(len)
+      integer,intent(in) :: ndpts,len
+      integer,intent(in) :: idrstmpl(*)
+      real,intent(out) :: fld(ndpts)
+
+      integer :: ifld(ndpts)
+      character(len=1),allocatable :: ctemp(:)
+      integer(4) :: ieee
+      real :: ref,bscale,dscale
+      integer :: dec_png,width,height
+
+      ieee = idrstmpl(1)
+      call rdieee(ieee,ref,1)
+      bscale = 2.0**real(idrstmpl(2))
+      dscale = 10.0**real(-idrstmpl(3))
+      nbits = idrstmpl(4)
+      itype = idrstmpl(5)
+!
+!  if nbits equals 0, we have a constant field where the reference value
+!  is the data value at each gridpoint
+!
+      if (nbits.ne.0) then
+         allocate(ctemp(ndpts*4))
+         iret=dec_png(cpack,width,height,ctemp)
+         call g2lib_gbytes(ctemp,ifld,0,nbits,0,ndpts)
+         deallocate(ctemp)
+         do j=1,ndpts
+           fld(j)=((real(ifld(j))*bscale)+ref)*dscale
+         enddo
+      else
+         do j=1,ndpts
+           fld(j)=ref
+         enddo
+      endif
+
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/proto.h b/wrfv2_fire/external/io_grib2/g2lib/proto.h
new file mode 100644
index 00000000..401d6a0e
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/proto.h
@@ -0,0 +1,24 @@
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define MOVA2I mova2i
+#      define DEC_JPEG2000 dec_jpeg2000
+#      define ENC_JPEG2000 enc_jpeg2000
+#      define ENC_PNG enc_png
+#      define DEC_PNG dec_png
+# else
+#   ifdef F2CSTYLE
+#      define MOVA2I mova2i__
+#      define DEC_JPEG2000 dec_jpeg2000__
+#      define ENC_JPEG2000 enc_jpeg2000__
+#      define ENC_PNG enc_png__
+#      define DEC_PNG dec_png__
+#   else
+#      define MOVA2I mova2i_
+#      define DEC_JPEG2000 dec_jpeg2000_
+#      define ENC_JPEG2000 enc_jpeg2000_
+#      define ENC_PNG enc_png_
+#      define DEC_PNG dec_png_
+#   endif
+# endif
+#endif
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/putgb2.F b/wrfv2_fire/external/io_grib2/g2lib/putgb2.F
new file mode 100644
index 00000000..a9371427
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/putgb2.F
@@ -0,0 +1,273 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE PUTGB2(LUGB,GFLD,IRET)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: PUTGB2         PACKS AND WRITES A GRIB2 MESSAGE
+C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 2002-04-22
+C
+C ABSTRACT: PACKS A SINGLE FIELD INTO A GRIB2 MESSAGE
+C   AND WRITES OUT THAT MESSAGE TO THE FILE ASSOCIATED WITH UNIT LUGB.
+C   NOTE THAT FILE/UNIT LUGB SHOULD BE OPENED WOTH A CALL TO 
+C   SUBROUTINE BAOPENW BEFORE THIS ROUTINE IS CALLED.
+C
+C   The information to be packed into the GRIB field
+C   is stored in a derived type variable, gfld.
+C   Gfld is of type gribfield, which is defined
+C   in module grib_mod, so users of this routine will need to include
+C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
+C   gribfield type is described in the INPUT ARGUMENT LIST section below.
+C
+C PROGRAM HISTORY LOG:
+C 2002-04-22  GILBERT  
+C 2005-02-28  GILBERT   - Changed dimension of array cgrib to be a multiple
+C                         of gfld%ngrdpts instead of gfld%ndpts.
+C
+C USAGE:    CALL PUTGB2(LUGB,GFLD,IRET)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
+C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENW BEFORE CALLING 
+C                  THIS ROUTINE.
+C     gfld - derived type gribfield ( defined in module grib_mod )
+C            ( NOTE: See Remarks Section )
+C        gfld%version = GRIB edition number ( currently 2 )
+C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
+C        gfld%idsect() = Contains the entries in the Identification
+C                        Section ( Section 1 )
+C                        This element is actually a pointer to an array
+C                        that holds the data.
+C            gfld%idsect(1)  = Identification of originating Centre
+C                                    ( see Common Code Table C-1 )
+C                             7 - US National Weather Service
+C            gfld%idsect(2)  = Identification of originating Sub-centre
+C            gfld%idsect(3)  = GRIB Master Tables Version Number
+C                                    ( see Code Table 1.0 )
+C                             0 - Experimental
+C                             1 - Initial operational version number
+C            gfld%idsect(4)  = GRIB Local Tables Version Number
+C                                    ( see Code Table 1.1 )
+C                             0     - Local tables not used
+C                             1-254 - Number of local tables version used
+C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
+C                             0 - Analysis
+C                             1 - Start of forecast
+C                             2 - Verifying time of forecast
+C                             3 - Observation time
+C            gfld%idsect(6)  = Year ( 4 digits )
+C            gfld%idsect(7)  = Month
+C            gfld%idsect(8)  = Day
+C            gfld%idsect(9)  = Hour
+C            gfld%idsect(10)  = Minute
+C            gfld%idsect(11)  = Second
+C            gfld%idsect(12)  = Production status of processed data
+C                                    ( see Code Table 1.3 )
+C                              0 - Operational products
+C                              1 - Operational test products
+C                              2 - Research products
+C                              3 - Re-analysis products
+C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
+C                              0  - Analysis products
+C                              1  - Forecast products
+C                              2  - Analysis and forecast products
+C                              3  - Control forecast products
+C                              4  - Perturbed forecast products
+C                              5  - Control and perturbed forecast products
+C                              6  - Processed satellite observations
+C                              7  - Processed radar observations
+C        gfld%idsectlen = Number of elements in gfld%idsect().
+C        gfld%local() = Pointer to character array containing contents
+C                       of Local Section 2, if included
+C        gfld%locallen = length of array gfld%local()
+C        gfld%ifldnum = field number within GRIB message
+C        gfld%griddef = Source of grid definition (see Code Table 3.0)
+C                      0 - Specified in Code table 3.1
+C                      1 - Predetermined grid Defined by originating centre
+C        gfld%ngrdpts = Number of grid points in the defined grid.
+C        gfld%numoct_opt = Number of octets needed for each
+C                          additional grid points definition.
+C                          Used to define number of
+C                          points in each row ( or column ) for
+C                          non-regular grids.
+C                          = 0, if using regular grid.
+C        gfld%interp_opt = Interpretation of list for optional points
+C                          definition.  (Code Table 3.11)
+C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
+C        gfld%igdtmpl() = Contains the data values for the specified Grid
+C                         Definition Template ( NN=gfld%igdtnum ).  Each
+C                         element of this integer array contains an entry (in
+C                         the order specified) of Grid Defintion Template 3.NN
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
+C                       entries in Grid Defintion Template 3.NN
+C                       ( NN=gfld%igdtnum ).
+C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
+C                          contains the number of grid points contained in
+C                          each row ( or column ).  (part of Section 3)
+C                          This element is actually a pointer to an array
+C                          that holds the data.  This pointer is nullified
+C                          if gfld%numoct_opt=0.
+C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
+C                       in array ideflist.  i.e. number of rows ( or columns )
+C                       for which optional grid points are defined.  This value
+C                       is set to zero, if gfld%numoct_opt=0.
+C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
+C        gfld%ipdtmpl() = Contains the data values for the specified Product
+C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
+C                         of this integer array contains an entry (in the
+C                         order specified) of Product Defintion Template 4.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
+C                       entries in Product Defintion Template 4.N
+C                       ( N=gfdl%ipdtnum ).
+C        gfld%coord_list() = Real array containing floating point values
+C                            intended to document the vertical discretisation
+C                            associated to model data on hybrid coordinate
+C                            vertical levels.  (part of Section 4)
+C                            This element is actually a pointer to an array
+C                            that holds the data.
+C        gfld%num_coord = number of values in array gfld%coord_list().
+C        gfld%ndpts = Number of data points unpacked and returned.
+C        gfld%idrtnum = Data Representation Template Number
+C                       ( see Code Table 5.0)
+C        gfld%idrtmpl() = Contains the data values for the specified Data
+C                         Representation Template ( N=gfld%idrtnum ).  Each
+C                         element of this integer array contains an entry
+C                         (in the order specified) of Product Defintion
+C                         Template 5.N.
+C                         This element is actually a pointer to an array
+C                         that holds the data.
+C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
+C                       of entries in Data Representation Template 5.N
+C                       ( N=gfld%idrtnum ).
+C        gfld%unpacked = logical value indicating whether the bitmap and
+C                        data values were unpacked.  If false,
+C                        gfld%bmap and gfld%fld pointers are nullified.
+C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
+C                     0 = bitmap applies and is included in Section 6.
+C                     1-253 = Predefined bitmap applies
+C                     254 = Previously defined bitmap applies to this field
+C                     255 = Bit map does not apply to this product.
+C        gfld%bmap() = Logical*1 array containing decoded bitmap,
+C                      if ibmap=0 or ibap=254.  Otherwise nullified.
+C                      This element is actually a pointer to an array
+C                      that holds the data.
+C        gfld%fld() = Array of gfld%ndpts unpacked data points.
+C                     This element is actually a pointer to an array
+C                     that holds the data.
+C
+C   OUTPUT ARGUMENTS:
+C     IRET         INTEGER RETURN CODE
+C                    0      ALL OK
+C                    2      MEMORY ALLOCATION ERROR
+C                    10     No Section 1 info available
+C                    11     No Grid Definition Template info available
+C                    12     Missing some required data field info
+C
+C SUBPROGRAMS CALLED:
+C   gribcreate     Start a new grib2 message
+C   addlocal       Add local section to a GRIB2 message
+C   addgrid        Add grid info to a GRIB2 message
+C   addfield       Add data field to a GRIB2 message
+C   gribend        End GRIB2 message
+C
+C REMARKS: 
+C
+C   Note that derived type gribfield contains pointers to many
+C   arrays of data.  The memory for these arrays is allocated
+C   when the values in the arrays are set, to help minimize
+C   problems with array overloading.  Because of this users
+C   are encouraged to free up this memory, when it is no longer
+C   needed, by an explicit call to subroutine gf_free.
+C   ( i.e.   CALL GF_FREE(GFLD) )
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN 90
+C
+C$$$
+      USE GRIB_MOD
+
+      INTEGER,INTENT(IN) :: LUGB
+      TYPE(GRIBFIELD),INTENT(IN) :: GFLD
+      INTEGER,INTENT(OUT) :: IRET
+
+      CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CGRIB
+      integer :: listsec0(2)=(/0,2/)
+      integer :: igds(5)=(/0,0,0,0,0/)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  ALLOCATE ARRAY FOR GRIB2 FIELD
+      lcgrib=gfld%ngrdpts*4
+      allocate(cgrib(lcgrib),stat=is)
+      if ( is.ne.0 ) then
+         print *,'putgb2: cannot allocate memory. ',is
+         iret=2
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CREATE NEW MESSAGE
+      listsec0(1)=gfld%discipline
+      listsec0(2)=gfld%version
+      if ( associated(gfld%idsect) ) then
+         call gribcreate(cgrib,lcgrib,listsec0,gfld%idsect,ierr)
+         if (ierr.ne.0) then
+            write(6,*) 'putgb2: ERROR creating new GRIB2 field = ',ierr
+         endif
+      else
+         print *,'putgb2: No Section 1 info available. '
+         iret=10
+         deallocate(cgrib)
+         return
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  ADD LOCAL USE SECTION TO GRIB2 MESSAGE
+      if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then
+         call addlocal(cgrib,lcgrib,gfld%local,gfld%locallen,ierr)
+         if (ierr.ne.0) then
+            write(6,*) 'putgb2: ERROR adding local info = ',ierr
+         endif
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  ADD GRID TO GRIB2 MESSAGE
+      igds(1)=gfld%griddef
+      igds(2)=gfld%ngrdpts
+      igds(3)=gfld%numoct_opt
+      igds(4)=gfld%interp_opt
+      igds(5)=gfld%igdtnum
+      if ( associated(gfld%igdtmpl) ) then
+         call addgrid(cgrib,lcgrib,igds,gfld%igdtmpl,gfld%igdtlen,
+     &                gfld%list_opt,gfld%num_opt,ierr)
+         if (ierr.ne.0) then
+            write(6,*) 'putgb2: ERROR adding grid info = ',ierr
+         endif
+      else
+         print *,'putgb2: No GDT info available. '
+         iret=11
+         deallocate(cgrib)
+         return
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  ADD DATA FIELD TO GRIB2 MESSAGE
+      if ( associated(gfld%ipdtmpl).AND.
+     &     associated(gfld%idrtmpl).AND.
+     &     associated(gfld%fld) ) then
+         call addfield(cgrib,lcgrib,gfld%ipdtnum,gfld%ipdtmpl,
+     &                 gfld%ipdtlen,gfld%coord_list,gfld%num_coord,
+     &                 gfld%idrtnum,gfld%idrtmpl,gfld%idrtlen,
+     &                 gfld%fld,gfld%ngrdpts,gfld%ibmap,gfld%bmap,
+     &                 ierr)
+         if (ierr.ne.0) then
+            write(6,*) 'putgb2: ERROR adding data field = ',ierr
+         endif
+      else
+         print *,'putgb2: Missing some field info. '
+         iret=12
+         deallocate(cgrib)
+         return
+      endif
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  CLOSE GRIB2 MESSAGE AND WRITE TO FILE
+      call gribend(cgrib,lcgrib,lengrib,ierr)
+      call wryte(lugb,lengrib,cgrib)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      deallocate(cgrib)
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/rdieee.F b/wrfv2_fire/external/io_grib2/g2lib/rdieee.F
new file mode 100644
index 00000000..3ec4eb6f
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/rdieee.F
@@ -0,0 +1,79 @@
+      subroutine rdieee(rieee,a,num)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    rdieee 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-09
+!
+! ABSTRACT: This subroutine reads a list of real values in 
+!   32-bit IEEE floating point format.
+!
+! PROGRAM HISTORY LOG:
+! 2000-05-09  Gilbert
+!
+! USAGE:    CALL rdieee(rieee,a,num)
+!   INPUT ARGUMENT LIST:
+!     rieee    - Input array of floating point values in 32-bit IEEE format.
+!     num      - Number of floating point values to convert.
+!
+!   OUTPUT ARGUMENT LIST:      
+!     a        - Output array of real values.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      real(4),intent(in) :: rieee(num)
+      real,intent(out) :: a(num)
+      integer,intent(in) :: num
+
+      integer(4) :: ieee
+
+      real,save :: two23
+      real,save :: two126
+      integer,save :: once=0
+
+      if ( once .EQ. 0 ) then
+         once=1
+         two23=scale(1.0,-23)
+         two126=scale(1.0,-126)
+      endif
+
+      do j=1,num
+!
+!  Transfer IEEE bit string to integer variable
+!
+        ieee=transfer(rieee(j),ieee)
+!
+!  Extract sign bit, exponent, and mantissa
+!
+        isign=ibits(ieee,31,1)
+        iexp=ibits(ieee,23,8)
+        imant=ibits(ieee,0,23)
+        sign=1.0
+        if (isign.eq.1) sign=-1.0
+        
+        if ( (iexp.gt.0).and.(iexp.lt.255) ) then
+          temp=2.0**(iexp-127)
+          a(j)=sign*temp*(1.0+(two23*real(imant)))
+
+        elseif ( iexp.eq.0 ) then
+          if ( imant.ne.0 ) then
+            a(j)=sign*two126*two23*real(imant)
+          else
+            a(j)=sign*0.0
+          endif
+
+        elseif ( iexp.eq.255 ) then
+          a(j)=sign*huge(a(j))
+
+        endif
+
+      enddo
+
+      return
+      end
+
diff --git a/wrfv2_fire/external/io_grib2/g2lib/realloc.F b/wrfv2_fire/external/io_grib2/g2lib/realloc.F
new file mode 100644
index 00000000..254ca548
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/realloc.F
@@ -0,0 +1,125 @@
+      module re_alloc
+
+      interface realloc
+         module procedure realloc_c1
+         module procedure realloc_r
+         module procedure realloc_i
+!!         subroutine realloc_c1(c,n,m,istat)
+!!            character(len=1),pointer,dimension(:) :: c
+!!            integer :: n,m
+!!            integer :: istat
+!!         end subroutine
+!!         subroutine realloc_r(c,n,m,istat)
+!!            real,pointer,dimension(:) :: c
+!!            integer :: n,m
+!!            integer :: istat
+!!         end subroutine
+!!         subroutine realloc_i(c,n,m,istat)
+!!            integer,pointer,dimension(:) :: c
+!!            integer :: n,m
+!!            integer :: istat
+!!         end subroutine
+      end interface
+
+      contains
+
+         subroutine realloc_c1(c,n,m,istat)
+            character(len=1),pointer,dimension(:) :: c
+            integer,intent(in) :: n,m
+            integer,intent(out) :: istat
+            integer :: num
+            character(len=1),pointer,dimension(:) :: tmp
+
+            istat=0
+            if ( (n<0) .OR. (m<=0) ) then
+               istat=10
+               return
+            endif
+ 
+            if ( .not. associated(c) ) then
+               allocate(c(m),stat=istat)   ! allocate new memory
+               return
+            endif
+
+            tmp=>c                      ! save pointer to original mem
+            nullify(c)
+            allocate(c(m),stat=istat)   ! allocate new memory
+            if ( istat /= 0 ) then
+               c=>tmp
+               return
+            endif
+            if ( n /= 0 ) then
+               num=min(n,m)
+               c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
+            endif
+            deallocate(tmp)             ! deallocate original memory
+            return
+         end subroutine
+
+         subroutine realloc_r(c,n,m,istat)
+            real,pointer,dimension(:) :: c
+            integer,intent(in) :: n,m
+            integer,intent(out) :: istat
+            integer :: num
+            real,pointer,dimension(:) :: tmp
+
+            istat=0
+            if ( (n<0) .OR. (m<=0) ) then
+               istat=10
+               return
+            endif
+ 
+            if ( .not. associated(c) ) then
+               allocate(c(m),stat=istat)   ! allocate new memory
+               return
+            endif
+
+            tmp=>c                      ! save pointer to original mem
+            nullify(c)
+            allocate(c(m),stat=istat)   ! allocate new memory
+            if ( istat /= 0 ) then
+               c=>tmp
+               return
+            endif
+            if ( n /= 0 ) then
+               num=min(n,m)
+               c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
+            endif
+            deallocate(tmp)             ! deallocate original memory
+            return
+         end subroutine
+
+         subroutine realloc_i(c,n,m,istat)
+            integer,pointer,dimension(:) :: c
+            integer,intent(in) :: n,m
+            integer,intent(out) :: istat
+            integer :: num
+            integer,pointer,dimension(:) :: tmp
+
+            istat=0
+            if ( (n<0) .OR. (m<=0) ) then
+               istat=10
+               return
+            endif
+ 
+            if ( .not. associated(c) ) then
+               allocate(c(m),stat=istat)   ! allocate new memory
+               return
+            endif
+
+            tmp=>c                      ! save pointer to original mem
+            nullify(c)
+            allocate(c(m),stat=istat)   ! allocate new memory
+            if ( istat /= 0 ) then
+               c=>tmp
+               return
+            endif
+            if ( n /= 0 ) then
+               num=min(n,m)
+               c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
+            endif
+            deallocate(tmp)             ! deallocate original memory
+            return
+         end subroutine
+
+      end module re_alloc
diff --git a/wrfv2_fire/external/io_grib2/g2lib/reduce.F b/wrfv2_fire/external/io_grib2/g2lib/reduce.F
new file mode 100644
index 00000000..110137e3
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/reduce.F
@@ -0,0 +1,343 @@
+      SUBROUTINE REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT,
+     1                  NOVREF,IBXX2,IER)            
+C
+C        NOVEMBER 2001   GLAHN   TDL   GRIB2
+C        MARCH    2002   GLAHN   COMMENT IER = 715
+C        MARCH    2002   GLAHN   MODIFIED TO ACCOMMODATE LX=1 ON ENTRY
+C
+C        PURPOSE
+C            DETERMINES WHETHER THE NUMBER OF GROUPS SHOULD BE
+C            INCREASED IN ORDER TO REDUCE THE SIZE OF THE LARGE
+C            GROUPS, AND TO MAKE THAT ADJUSTMENT.  BY REDUCING THE
+C            SIZE OF THE LARGE GROUPS, LESS BITS MAY BE NECESSARY
+C            FOR PACKING THE GROUP SIZES AND ALL THE INFORMATION
+C            ABOUT THE GROUPS.
+C
+C            THE REFERENCE FOR NOV( ) WAS REMOVED IN THE CALLING
+C            ROUTINE SO THAT KBIT COULD BE DETERMINED.  THIS
+C            FURNISHES A STARTING POINT FOR THE ITERATIONS IN REDUCE.
+C            HOWEVER, THE REFERENCE MUST BE CONSIDERED.
+C
+C        DATA SET USE 
+C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) 
+C
+C        VARIABLES IN CALL SEQUENCE 
+C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE.  (INPUT)
+C             JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX).  IT IS
+C                       POSSIBLE AFTER SPLITTING THE GROUPS, JMIN( )
+C                       WILL NOT BE THE MINIMUM OF THE NEW GROUP.
+C                       THIS DOESN'T MATTER; JMIN( ) IS REALLY THE
+C                       GROUP REFERENCE AND DOESN'T HAVE TO BE THE
+C                       SMALLEST VALUE.  (INPUT/OUTPUT)
+C             JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX). 
+C                       (INPUT/OUTPUT)
+C             LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP
+C                       (J=1,LX).  (INPUT/OUTPUT)
+C              NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX).
+C                       (INPUT/OUTPUT)
+C                  LX = THE NUMBER OF GROUPS.  THIS WILL BE INCREASED
+C                       IF GROUPS ARE SPLIT.  (INPUT/OUTPUT)
+C                 NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND
+C                       NOV( ).  (INPUT)
+C                IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J)
+C                       VALUES, J=1,LX.  (INPUT)
+C                JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J)
+C                       VALUES, J=1,LX.  (INPUT)
+C                KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J)
+C                       VALUES, J=1,LX.  IF THE GROUPS ARE SPLIT, KBIT
+C                       IS REDUCED.  (INPUT/OUTPUT)
+C              NOVREF = REFERENCE VALUE FOR NOV( ).  (INPUT)
+C            IBXX2(J) = 2**J (J=0,30).  (INPUT)
+C                 IER = ERROR RETURN.  (OUTPUT)
+C                         0 = GOOD RETURN.
+C                       714 = PROBLEM IN ALGORITHM.  REDUCE ABORTED.
+C                       715 = NGP NOT LARGE ENOUGH.  REDUCE ABORTED.
+C           NTOTBT(J) = THE TOTAL BITS USED FOR THE PACKING BITS J
+C                       (J=1,30).  (INTERNAL)
+C            NBOXJ(J) = NEW BOXES NEEDED FOR THE PACKING BITS J
+C                       (J=1,30).  (INTERNAL)
+C           NEWBOX(L) = NUMBER OF NEW BOXES (GROUPS) FOR EACH ORIGINAL
+C                       GROUP (L=1,LX) FOR THE CURRENT J.  (AUTOMATIC)
+C                       (INTERNAL)
+C          NEWBOXP(L) = SAME AS NEWBOX( ) BUT FOR THE PREVIOUS J.
+C                       THIS ELIMINATES RECOMPUTATION.  (AUTOMATIC)
+C                       (INTERNAL)
+C               CFEED = CONTAINS THE CHARACTER REPRESENTATION
+C                       OF A PRINTER FORM FEED.  (CHARACTER) (INTERNAL)
+C               IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
+C                       FORM FEED.  (INTERNAL)
+C              IORIGB = THE ORIGINAL NUMBER OF BITS NECESSARY
+C                       FOR THE GROUP VALUES.  (INTERNAL)
+C        1         2         3         4         5         6         7 X
+C
+C        NON SYSTEM SUBROUTINES CALLED 
+C           NONE
+c
+      CHARACTER*1 CFEED
+C
+      DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG)
+      DIMENSION NEWBOX(NDG),NEWBOXP(NDG)
+C        NEWBOX( ) AND NEWBOXP( ) ARE AUTOMATIC ARRAYS.
+      DIMENSION NTOTBT(31),NBOXJ(31)
+      DIMENSION IBXX2(0:30)
+C
+      DATA IFEED/12/
+C
+      IER=0
+      IF(LX.EQ.1)GO TO 410
+C        IF THERE IS ONLY ONE GROUP, RETURN.
+C
+      CFEED=CHAR(IFEED)
+C
+C        INITIALIZE NUMBER OF NEW BOXES PER GROUP TO ZERO.
+C
+      DO 110 L=1,LX
+         NEWBOX(L)=0
+ 110  CONTINUE
+C
+C        INITIALIZE NUMBER OF TOTAL NEW BOXES PER J TO ZERO.
+C
+      DO 112 J=1,31
+         NTOTBT(J)=999999999
+         NBOXJ(J)=0
+ 112  CONTINUE
+C
+      IORIGB=(IBIT+JBIT+KBIT)*LX
+C        IBIT = BITS TO PACK THE JMIN( ).
+C        JBIT = BITS TO PACK THE LBIT( ).
+C        KBIT = BITS TO PACK THE NOV( ).
+C        LX = NUMBER OF GROUPS.
+         NTOTBT(KBIT)=IORIGB
+C           THIS IS THE VALUE OF TOTAL BITS FOR THE ORIGINAL LX
+C           GROUPS, WHICH REQUIRES KBITS TO PACK THE GROUP
+C           LENGHTS.  SETTING THIS HERE MAKES ONE LESS LOOPS
+C           NECESSARY BELOW.
+C
+C        COMPUTE BITS NOW USED FOR THE PARAMETERS DEFINED.
+C
+C        DETERMINE OTHER POSSIBILITES BY INCREASING LX AND DECREASING
+C        NOV( ) WITH VALUES GREATER THAN THRESHOLDS.  ASSUME A GROUP IS
+C        SPLIT INTO 2 OR MORE GROUPS SO THAT KBIT IS REDUCED WITHOUT
+C        CHANGING IBIT OR JBIT.
+C
+      JJ=0
+C
+      DO 200 J=MIN(30,KBIT-1),2,-1
+C           VALUES GE KBIT WILL NOT REQUIRE SPLITS.  ONCE THE TOTAL
+C           BITS START INCREASING WITH DECREASING J, STOP.  ALSO, THE
+C           NUMBER OF BITS REQUIRED IS KNOWN FOR KBITS = NTOTBT(KBIT).
+C
+         NEWBOXT=0
+C
+         DO 190 L=1,LX
+C
+            IF(NOV(L).LT.IBXX2(J))THEN
+               NEWBOX(L)=0
+C                 NO SPLITS OR NEW BOXES.
+               GO TO 190
+            ELSE
+               NOVL=NOV(L)
+C
+               M=(NOV(L)-1)/(IBXX2(J)-1)+1
+C                 M IS FOUND BY SOLVING THE EQUATION BELOW FOR M:
+C                 (NOV(L)+M-1)/M LT IBXX2(J)
+C                 M GT (NOV(L)-1)/(IBXX2(J)-1)
+C                 SET M = (NOV(L)-1)/(IBXX2(J)-1)+1
+ 130           NOVL=(NOV(L)+M-1)/M
+C                 THE +M-1 IS NECESSARY.  FOR INSTANCE, 15 WILL FIT
+C                 INTO A BOX 4 BITS WIDE, BUT WON'T DIVIDE INTO
+C                 TWO BOXES 3 BITS WIDE EACH.
+C      
+               IF(NOVL.LT.IBXX2(J))THEN
+                  GO TO 185
+               ELSE
+                  M=M+1
+C***                  WRITE(KFILDO,135)L,NOV(L),NOVL,M,J,IBXX2(J)
+C*** 135              FORMAT(/' AT 135--L,NOV(L),NOVL,M,J,IBXX2(J)',6I10)               
+                  GO TO 130
+               ENDIF
+C
+C                 THE ABOVE DO LOOP WILL NEVER COMPLETE.
+            ENDIF
+C
+ 185        NEWBOX(L)=M-1
+            NEWBOXT=NEWBOXT+M-1
+ 190     CONTINUE
+C
+         NBOXJ(J)=NEWBOXT
+         NTOTPR=NTOTBT(J+1)
+         NTOTBT(J)=(IBIT+JBIT)*(LX+NEWBOXT)+J*(LX+NEWBOXT)
+C
+         IF(NTOTBT(J).GE.NTOTPR)THEN
+            JJ=J+1
+C              THE PLUS IS USED BECAUSE J DECREASES PER ITERATION.
+            GO TO 250
+         ELSE
+C
+C              SAVE THE TOTAL NEW BOXES AND NEWBOX( ) IN CASE THIS
+C              IS THE J TO USE.
+C
+            NEWBOXTP=NEWBOXT
+C
+            DO 195 L=1,LX
+               NEWBOXP(L)=NEWBOX(L)
+ 195        CONTINUE
+C
+C           WRITE(KFILDO,197)NEWBOXT,IBXX2(J)
+C197        FORMAT(/' *****************************************'
+C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
+C    2              I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
+C    3             /' *****************************************')
+C           WRITE(KFILDO,198) (NEWBOX(L),L=1,LX)
+C198        FORMAT(/' '20I6/(' '20I6))
+    
+         ENDIF
+C        
+C205     WRITE(KFILDO,209)KBIT,IORIGB
+C209     FORMAT(/' ORIGINAL BITS WITH KBIT OF',I5,' =',I10)
+C        WRITE(KFILDO,210)(N,N=2,10),(IBXX2(N),N=2,10),
+C    1                    (NTOTBT(N),N=2,10),(NBOXJ(N),N=2,10),
+C    2                    (N,N=11,20),(IBXX2(N),N=11,20),
+C    3                    (NTOTBT(N),N=11,20),(NBOXJ(N),N=11,20),
+C    4                    (N,N=21,30),(IBXX2(N),N=11,20),
+C    5                    (NTOTBT(N),N=21,30),(NBOXJ(N),N=21,30)
+C210     FORMAT(/' THE TOTAL BYTES FOR MAXIMUM GROUP LENGTHS BY ROW'//
+C    1      '   J         = THE NUMBER OF BITS PER GROUP LENGTH'/
+C    2      '   IBXX2(J)  = THE MAXIMUM GROUP LENGTH PLUS 1 FOR THIS J'/
+C    3      '   NTOTBT(J) = THE TOTAL BITS FOR THIS J'/
+C    4      '   NBOXJ(J)  = THE NEW GROUPS FOR THIS J'/
+C    5      4(/10X,9I10)/4(/10I10)/4(/10I10))
+C
+ 200  CONTINUE
+C
+ 250  PIMP=((IORIGB-NTOTBT(JJ))/FLOAT(IORIGB))*100.
+C     WRITE(KFILDO,252)PIMP,KBIT,JJ
+C252  FORMAT(/' PERCENT IMPROVEMENT =',F6.1,
+C    1        ' BY DECREASING GROUP LENGTHS FROM',I4,' TO',I4,' BITS')
+      IF(PIMP.GE.2.)THEN
+C
+C        WRITE(KFILDO,255)CFEED,NEWBOXTP,IBXX2(JJ)
+C255     FORMAT(A1,/' *****************************************'
+C    1             /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL',
+C    2             I10,' FOR GROUP MAXSIZE PLUS 1 ='I10
+C    2             /' *****************************************')
+C        WRITE(KFILDO,256) (NEWBOXP(L),L=1,LX)
+C256     FORMAT(/' '20I6)
+C
+C           ADJUST GROUP LENGTHS FOR MAXIMUM LENGTH OF JJ BITS.
+C           THE MIN PER GROUP AND THE NUMBER OF BITS REQUIRED
+C           PER GROUP ARE NOT CHANGED.  THIS MAY MEAN THAT A
+C           GROUP HAS A MIN (OR REFERENCE) THAT IS NOT ZERO.
+C           THIS SHOULD NOT MATTER TO THE UNPACKER.
+C
+         LXNKP=LX+NEWBOXTP
+C           LXNKP = THE NEW NUMBER OF BOXES
+C  
+         IF(LXNKP.GT.NDG)THEN
+C              DIMENSIONS NOT LARGE ENOUGH.  PROBABLY AN ERROR
+C              OF SOME SORT.  ABORT.
+C           WRITE(KFILDO,257)NDG,LXNPK
+C        1         2         3         4         5         6         7 X
+C257        FORMAT(/' DIMENSIONS OF JMIN, ETC. IN REDUCE =',I8,
+C    1              ' NOT LARGE ENOUGH FOR THE EXPANDED NUMBER OF',
+C    2              ' GROUPS =',I8,'.  ABORT REDUCE.')
+            IER=715
+            GO TO 410
+C              AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE 
+C              WITHOUT CALLING REDUCE.
+         ENDIF
+C
+         LXN=LXNKP
+C           LXN IS THE NUMBER OF THE BOX IN THE NEW SERIES BEING
+C           FILLED.  IT DECREASES PER ITERATION.
+         IBXX2M1=IBXX2(JJ)-1
+C           IBXX2M1 IS THE MAXIMUM NUMBER OF VALUES PER GROUP.
+C
+         DO 300 L=LX,1,-1
+C
+C              THE VALUES IS NOV( ) REPRESENT THOSE VALUES + NOVREF.
+C              WHEN VALUES ARE MOVED TO ANOTHER BOX, EACH VALUE
+C              MOVED TO A NEW BOX REPRESENTS THAT VALUE + NOVREF.
+C              THIS HAS TO BE CONSIDERED IN MOVING VALUES.
+C
+            IF(NEWBOXP(L)*(IBXX2M1+NOVREF)+NOVREF.GT.NOV(L)+NOVREF)THEN
+C                 IF THE ABOVE TEST IS MET, THEN MOVING IBXX2M1 VALUES
+C                 FOR ALL NEW BOXES WILL LEAVE A NEGATIVE NUMBER FOR
+C                 THE LAST BOX.  NOT A TOLERABLE SITUATION.
+               MOVMIN=(NOV(L)-(NEWBOXP(L))*NOVREF)/NEWBOXP(L)
+               LEFT=NOV(L)
+C                 LEFT = THE NUMBER OF VALUES TO MOVE FROM THE ORIGINAL
+C                 BOX TO EACH NEW BOX EXCEPT THE LAST.  LEFT IS THE
+C                 NUMBER LEFT TO MOVE.
+            ELSE
+               MOVMIN=IBXX2M1
+C                 MOVMIN VALUES CAN BE MOVED FOR EACH NEW BOX.
+               LEFT=NOV(L)
+C                 LEFT IS THE NUMBER OF VALUES LEFT TO MOVE.
+            ENDIF
+C
+            IF(NEWBOXP(L).GT.0)THEN
+               IF((MOVMIN+NOVREF)*NEWBOXP(L)+NOVREF.LE.NOV(L)+NOVREF.
+     1          AND.(MOVMIN+NOVREF)*(NEWBOXP(L)+1).GE.NOV(L)+NOVREF)THEN
+                  GO TO 288
+               ELSE
+C***D                 WRITE(KFILDO,287)L,MOVMIN,NOVREF,NEWBOXP(L),NOV(L)
+C***D287              FORMAT(/' AT 287 IN REDUCE--L,MOVMIN,NOVREF,',
+C***D    1                    'NEWBOXP(L),NOV(L)',5I12
+C***D    2                    ' REDUCE ABORTED.')
+C              WRITE(KFILDO,2870)
+C2870          FORMAT(/' AN ERROR IN REDUCE ALGORITHM.  ABORT REDUCE.')
+               IER=714
+               GO TO 410
+C                 AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE 
+C                 WITHOUT CALLING REDUCE.
+               ENDIF
+C
+            ENDIF
+C
+ 288        DO 290 J=1,NEWBOXP(L)+1
+               MOVE=MIN(MOVMIN,LEFT)
+               JMIN(LXN)=JMIN(L)
+               JMAX(LXN)=JMAX(L)
+               LBIT(LXN)=LBIT(L)
+               NOV(LXN)=MOVE
+               LXN=LXN-1
+               LEFT=LEFT-(MOVE+NOVREF)
+C                 THE MOVE OF MOVE VALUES REALLY REPRESENTS A MOVE OF
+C                 MOVE + NOVREF VALUES.
+ 290        CONTINUE
+C
+            IF(LEFT.NE.-NOVREF)THEN
+C***               WRITE(KFILDO,292)L,LXN,MOVE,LXNKP,IBXX2(JJ),LEFT,NOV(L),
+C***     1                          MOVMIN
+C*** 292           FORMAT(' AT 292 IN REDUCE--L,LXN,MOVE,LXNKP,',
+C***     1                'IBXX2(JJ),LEFT,NOV(L),MOVMIN'/8I12)
+            ENDIF
+C     
+ 300     CONTINUE
+C
+         LX=LXNKP
+C           LX IS NOW THE NEW NUMBER OF GROUPS.
+         KBIT=JJ
+C           KBIT IS NOW THE NEW NUMBER OF BITS REQUIRED FOR PACKING
+C           GROUP LENGHTS.
+      ENDIF
+C
+C     WRITE(KFILDO,406)CFEED,LX
+C406  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP SIZES NOV( ) AFTER REDUCTION IN SIZE',
+C    2           ' FOR'I10,' GROUPS',
+C    3          /' *****************************************')
+C     WRITE(KFILDO,407) (NOV(J),J=1,LX)
+C407  FORMAT(/' '20I6)
+C     WRITE(KFILDO,408)CFEED,LX
+C408  FORMAT(A1,/' *****************************************'
+C    1          /' THE GROUP MINIMA JMIN( ) AFTER REDUCTION IN SIZE',
+C    2           ' FOR'I10,' GROUPS',
+C    3          /' *****************************************')
+C     WRITE(KFILDO,409) (JMIN(J),J=1,LX)
+C409  FORMAT(/' '20I6)
+C
+ 410  RETURN
+      END
+      
diff --git a/wrfv2_fire/external/io_grib2/g2lib/simpack.F b/wrfv2_fire/external/io_grib2/g2lib/simpack.F
new file mode 100644
index 00000000..4195fd1c
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/simpack.F
@@ -0,0 +1,180 @@
+      subroutine simpack(fld,ndpts,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    simpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine packs up a data field using a simple
+!   packing algorithm as defined in the GRIB2 documention.  It
+!   also fills in GRIB2 Data Representation Template 5.0 with the
+!   appropriate values.
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+!
+! USAGE:    CALL simpack(fld,ndpts,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the data values to pack
+!     ndpts    - The number of data values in array fld()
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.0
+!                (1) = Reference value - ignored on input
+!                (2) = Binary Scale Factor
+!                (3) = Decimal Scale Factor
+!                (4) = Number of bits used to pack data, if value is
+!                      > 0 and  <= 31.
+!                      If this input value is 0 or outside above range
+!                      then the num of bits is calculated based on given 
+!                      data and scale factors.
+!                (5) = Original field type - currently ignored on input
+!                      Data values assumed to be reals.
+!
+!   OUTPUT ARGUMENT LIST: 
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.0
+!                (1) = Reference value - set by simpack routine.
+!                (2) = Binary Scale Factor - unchanged from input
+!                (3) = Decimal Scale Factor - unchanged from input
+!                (4) = Number of bits used to pack data, unchanged from 
+!                      input if value is between 0 and 31.
+!                      If this input value is 0 or outside above range
+!                      then the num of bits is calculated based on given 
+!                      data and scale factors.
+!                (5) = Original field type - currently set = 0 on output.
+!                      Data values assumed to be reals.
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,intent(in) :: ndpts
+      real,intent(in) :: fld(ndpts)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(inout) :: idrstmpl(*)
+      integer,intent(out) :: lcpack
+
+      real(4) :: ref
+      integer(4) :: iref
+      integer :: ifld(ndpts)
+      integer,parameter :: zero=0
+      
+      bscale=2.0**real(-idrstmpl(2))
+      dscale=10.0**real(idrstmpl(3))
+      if (idrstmpl(4).le.0.OR.idrstmpl(4).gt.31) then
+         nbits=0
+      else
+         nbits=idrstmpl(4)
+      endif
+!
+!  Find max and min values in the data
+!
+      rmax=fld(1)
+      rmin=fld(1)
+      do j=2,ndpts
+        if (fld(j).gt.rmax) rmax=fld(j)
+        if (fld(j).lt.rmin) rmin=fld(j)
+      enddo
+!
+!  If max and min values are not equal, pack up field.
+!  If they are equal, we have a constant field, and the reference
+!  value (rmin) is the value for each point in the field and
+!  set nbits to 0.
+!
+      if (rmin.ne.rmax) then
+        !
+        !  Determine which algorithm to use based on user-supplied 
+        !  binary scale factor and number of bits.
+        !
+        if (nbits.eq.0.AND.idrstmpl(2).eq.0) then
+           !
+           !  No binary scaling and calculate minumum number of 
+           !  bits in which the data will fit.
+           !
+           imin=nint(rmin*dscale)
+           imax=nint(rmax*dscale)
+           maxdif=imax-imin
+           temp=alog(real(maxdif+1))/alog(2.0)
+           nbits=ceiling(temp)
+           rmin=real(imin)
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(fld(j)*dscale)-imin
+           enddo
+        elseif (nbits.ne.0.AND.idrstmpl(2).eq.0) then
+           !
+           !  Use minimum number of bits specified by user and
+           !  adjust binary scaling factor to accomodate data.
+           !
+           rmin=rmin*dscale
+           rmax=rmax*dscale
+           maxnum=(2**nbits)-1
+           temp=alog(real(maxnum)/(rmax-rmin))/alog(2.0)
+           idrstmpl(2)=ceiling(-1.0*temp)
+           bscale=2.0**real(-idrstmpl(2))
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        elseif (nbits.eq.0.AND.idrstmpl(2).ne.0) then
+           !
+           !  Use binary scaling factor and calculate minumum number of 
+           !  bits in which the data will fit.
+           !
+           rmin=rmin*dscale
+           rmax=rmax*dscale
+           maxdif=nint((rmax-rmin)*bscale)
+           temp=alog(real(maxdif+1))/alog(2.0)
+           nbits=ceiling(temp)
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        elseif (nbits.ne.0.AND.idrstmpl(2).ne.0) then
+           !
+           !  Use binary scaling factor and use minumum number of 
+           !  bits specified by user.   Dangerous - may loose
+           !  information if binary scale factor and nbits not set
+           !  properly by user.
+           !
+           rmin=rmin*dscale
+           !   scale data
+           do j=1,ndpts
+             ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale)
+           enddo
+        endif
+        !
+        !  Pack data, Pad last octet with Zeros, if necessary,
+        !  and calculate the length of the packed data in bytes
+        !
+        call g2lib_sbytes(cpack,ifld,0,nbits,0,ndpts)
+        nbittot=nbits*ndpts
+        left=8-mod(nbittot,8)
+        if (left.ne.8) then
+          call g2lib_sbyte(cpack,zero,nbittot,left)    ! Pad with zeros to fill Octet
+          nbittot=nbittot+left
+        endif
+        lcpack=nbittot/8
+
+      else
+        nbits=0
+        lcpack=0
+      endif
+
+!
+!  Fill in ref value and number of bits in Template 5.0
+!
+      call mkieee(rmin,ref,1)   ! ensure reference value is IEEE format
+!      call g2lib_gbyte(ref,idrstmpl(1),0,32)
+      iref=transfer(ref,iref)
+      idrstmpl(1)=iref
+      idrstmpl(4)=nbits
+      idrstmpl(5)=0         ! original data were reals
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/simunpack.F b/wrfv2_fire/external/io_grib2/g2lib/simunpack.F
new file mode 100644
index 00000000..ebbebae7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/simunpack.F
@@ -0,0 +1,65 @@
+      subroutine simunpack(cpack,len,idrstmpl,ndpts,fld)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    simunpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2000-06-21
+!
+! ABSTRACT: This subroutine unpacks a data field that was packed using a 
+!   simple packing algorithm as defined in the GRIB2 documention,
+!   using info from the GRIB2 Data Representation Template 5.0.
+!
+! PROGRAM HISTORY LOG:
+! 2000-06-21  Gilbert
+!
+! USAGE:    CALL simunpack(cpack,len,idrstmpl,ndpts,fld)
+!   INPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     len      - length of packed field cpack().
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.0
+!     ndpts    - The number of data values to unpack
+!
+!   OUTPUT ARGUMENT LIST:
+!     fld()    - Contains the unpacked data values
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cpack(len)
+      integer,intent(in) :: ndpts,len
+      integer,intent(in) :: idrstmpl(*)
+      real,intent(out) :: fld(ndpts)
+
+      integer :: ifld(ndpts)
+      integer(4) :: ieee
+      real :: ref,bscale,dscale
+
+      ieee = idrstmpl(1)
+      call rdieee(ieee,ref,1)
+      bscale = 2.0**real(idrstmpl(2))
+      dscale = 10.0**real(-idrstmpl(3))
+      nbits = idrstmpl(4)
+      itype = idrstmpl(5)
+!
+!  if nbits equals 0, we have a constant field where the reference value
+!  is the data value at each gridpoint
+!
+      if (nbits.ne.0) then
+         call g2lib_gbytes(cpack,ifld,0,nbits,0,ndpts)
+         do j=1,ndpts
+           fld(j)=((real(ifld(j))*bscale)+ref)*dscale
+         enddo
+      else
+         do j=1,ndpts
+           fld(j)=ref
+         enddo
+      endif
+
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/skgb.F b/wrfv2_fire/external/io_grib2/g2lib/skgb.F
new file mode 100644
index 00000000..969f3b31
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/skgb.F
@@ -0,0 +1,78 @@
+C-----------------------------------------------------------------------
+      SUBROUTINE SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB)
+C$$$  SUBPROGRAM DOCUMENTATION BLOCK
+C
+C SUBPROGRAM: SKGB           SEARCH FOR NEXT GRIB MESSAGE
+C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 93-11-22
+C
+C ABSTRACT: THIS SUBPROGRAM SEARCHES A FILE FOR THE NEXT GRIB 1 MESSAGE.
+C   A GRIB 1 MESSAGE IS IDENTIFIED BY ITS INDICATOR SECTION, I.E.
+C   AN 8-BYTE SEQUENCE WITH 'GRIB' IN BYTES 1-4 AND 1 IN BYTE 8.
+C   IF FOUND, THE LENGTH OF THE MESSAGE IS DECODED FROM BYTES 5-7.
+C   THE SEARCH IS DONE OVER A GIVEN SECTION OF THE FILE.
+C   THE SEARCH IS TERMINATED IF AN EOF OR I/O ERROR IS ENCOUNTERED.
+C
+C PROGRAM HISTORY LOG:
+C   93-11-22  IREDELL
+C   95-10-31  IREDELL   ADD CALL TO BAREAD 
+C   97-03-14  IREDELL   CHECK FOR '7777'
+C 2001-12-05  GILBERT   MODIFIED TO ALSO LOOK FOR GRIB2 MESSAGES
+C
+C USAGE:    CALL SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB)
+C   INPUT ARGUMENTS:
+C     LUGB         INTEGER LOGICAL UNIT OF INPUT GRIB FILE
+C     ISEEK        INTEGER NUMBER OF BYTES TO SKIP BEFORE SEARCH
+C     MSEEK        INTEGER MAXIMUM NUMBER OF BYTES TO SEARCH
+C   OUTPUT ARGUMENTS:
+C     LSKIP        INTEGER NUMBER OF BYTES TO SKIP BEFORE MESSAGE
+C     LGRIB        INTEGER NUMBER OF BYTES IN MESSAGE (0 IF NOT FOUND)
+C
+C SUBPROGRAMS CALLED:
+C   BAREAD       BYTE-ADDRESSABLE READ
+C   G2LIB_GBYTE         GET INTEGER DATA FROM BYTES
+C
+C ATTRIBUTES:
+C   LANGUAGE: FORTRAN
+C
+C$$$
+      PARAMETER(LSEEK=128)
+      CHARACTER Z(LSEEK)
+      CHARACTER Z4(4)
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      LGRIB=0
+      KS=ISEEK
+      KN=MIN(LSEEK,MSEEK)
+      KZ=LSEEK
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+C  LOOP UNTIL GRIB MESSAGE IS FOUND
+      DOWHILE(LGRIB.EQ.0.AND.KN.GE.8.AND.KZ.EQ.LSEEK)
+C  READ PARTIAL SECTION
+        CALL BAREAD(LUGB,KS,KN,KZ,Z)
+        KM=KZ-8+1
+        K=0
+C  LOOK FOR 'GRIB...1' IN PARTIAL SECTION
+        DOWHILE(LGRIB.EQ.0.AND.K.LT.KM)
+          CALL G2LIB_GBYTE(Z,I4,(K+0)*8,4*8)
+          CALL G2LIB_GBYTE(Z,I1,(K+7)*8,1*8)
+          IF(I4.EQ.1196575042.AND.(I1.EQ.1.OR.I1.EQ.2)) THEN
+C  LOOK FOR '7777' AT END OF GRIB MESSAGE
+            IF (I1.EQ.1) CALL G2LIB_GBYTE(Z,KG,(K+4)*8,3*8)
+            IF (I1.EQ.2) CALL G2LIB_GBYTE(Z,KG,(K+12)*8,4*8)
+            CALL BAREAD(LUGB,KS+K+KG-4,4,K4,Z4)
+            IF(K4.EQ.4) THEN
+              CALL G2LIB_GBYTE(Z4,I4,0,4*8)
+              IF(I4.EQ.926365495) THEN
+C  GRIB MESSAGE FOUND
+                LSKIP=KS+K
+                LGRIB=KG
+              ENDIF
+            ENDIF
+          ENDIF
+          K=K+1
+        ENDDO
+        KS=KS+KM
+        KN=MIN(LSEEK,ISEEK+MSEEK-KS)
+      ENDDO
+C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      RETURN
+      END
diff --git a/wrfv2_fire/external/io_grib2/g2lib/specpack.F b/wrfv2_fire/external/io_grib2/g2lib/specpack.F
new file mode 100644
index 00000000..eb24c719
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/specpack.F
@@ -0,0 +1,124 @@
+      subroutine specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    specpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-19
+!
+! ABSTRACT: This subroutine packs a spectral data field using the complex
+!   packing algorithm for spherical harmonic data as 
+!   defined in the GRIB2 Data Representation Template 5.51.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-19  Gilbert
+!
+! USAGE:    CALL specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack)
+!   INPUT ARGUMENT LIST:
+!     fld()    - Contains the packed data values
+!     ndpts    - The number of data values to pack
+!     JJ       - J - pentagonal resolution parameter
+!     KK       - K - pentagonal resolution parameter
+!     MM       - M - pentagonal resolution parameter
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.51
+!
+!   OUTPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     lcpack   - length of packed field cpack().
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      real,intent(in) :: fld(ndpts)
+      integer,intent(in) :: ndpts,JJ,KK,MM
+      integer,intent(inout) :: idrstmpl(*)
+      character(len=1),intent(out) :: cpack(*)
+      integer,intent(out) :: lcpack
+
+      integer :: ifld(ndpts),Ts,tmplsim(5)
+      real :: bscale,dscale,unpk(ndpts),tfld(ndpts)
+      real,allocatable :: pscale(:)
+
+      bscale = 2.0**real(-idrstmpl(2))
+      dscale = 10.0**real(idrstmpl(3))
+      nbits = idrstmpl(4)
+      Js=idrstmpl(6)
+      Ks=idrstmpl(7)
+      Ms=idrstmpl(8)
+      Ts=idrstmpl(9)
+
+!
+!   Calculate Laplacian scaling factors for each possible wave number.
+!
+      allocate(pscale(JJ+MM))
+      tscale=real(idrstmpl(5))*1E-6
+      do n=Js,JJ+MM
+         pscale(n)=real(n*(n+1))**(tscale)
+      enddo
+!
+!   Separate spectral coeffs into two lists; one to contain unpacked
+!   values within the sub-spectrum Js, Ks, Ms, and the other with values 
+!   outside of the sub-spectrum to be packed.
+!
+      inc=1
+      incu=1
+      incp=1
+      do m=0,MM
+         Nm=JJ      ! triangular or trapezoidal
+         if ( KK .eq. JJ+MM ) Nm=JJ+m          ! rhombodial
+         Ns=Js      ! triangular or trapezoidal
+         if ( Ks .eq. Js+Ms ) Ns=Js+m          ! rhombodial
+         do n=m,Nm
+            if (n.le.Ns .AND. m.le.Ms) then    ! save unpacked value
+               unpk(incu)=fld(inc)         ! real part
+               unpk(incu+1)=fld(inc+1)     ! imaginary part
+               inc=inc+2
+               incu=incu+2
+            else                         ! Save value to be packed and scale
+                                         ! Laplacian scale factor
+               tfld(incp)=fld(inc)*pscale(n)         ! real part
+               tfld(incp+1)=fld(inc+1)*pscale(n)     ! imaginary part
+               inc=inc+2
+               incp=incp+2
+            endif
+         enddo
+      enddo
+
+      deallocate(pscale)
+
+      incu=incu-1
+      if (incu .ne. Ts) then
+         print *,'specpack: Incorrect number of unpacked values ',
+     &           'given:',Ts     
+         print *,'specpack: Resetting idrstmpl(9) to ',incu
+         Ts=incu
+      endif
+!
+!  Add unpacked values to the packed data array in 32-bit IEEE format
+!
+      call mkieee(unpk,cpack,Ts)
+      ipos=4*Ts
+!
+!  Scale and pack the rest of the coefficients
+! 
+      tmplsim(2)=idrstmpl(2)
+      tmplsim(3)=idrstmpl(3)
+      tmplsim(4)=idrstmpl(4)
+      call simpack(tfld,ndpts-Ts,tmplsim,cpack(ipos+1),lcpack)
+      lcpack=lcpack+ipos
+!
+!  Fill in Template 5.51
+!
+      idrstmpl(1)=tmplsim(1)
+      idrstmpl(2)=tmplsim(2)
+      idrstmpl(3)=tmplsim(3)
+      idrstmpl(4)=tmplsim(4)
+      idrstmpl(9)=Ts
+      idrstmpl(10)=1         ! Unpacked spectral data is 32-bit IEEE
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/specunpack.F b/wrfv2_fire/external/io_grib2/g2lib/specunpack.F
new file mode 100644
index 00000000..0552e481
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/specunpack.F
@@ -0,0 +1,107 @@
+      subroutine specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    specunpack
+!   PRGMMR: Gilbert          ORG: W/NP11    DATE: 2002-12-19
+!
+! ABSTRACT: This subroutine unpacks a spectral data field that was packed 
+!   using the complex packing algorithm for spherical harmonic data as 
+!   defined in the GRIB2 documention,
+!   using info from the GRIB2 Data Representation Template 5.51.
+!
+! PROGRAM HISTORY LOG:
+! 2002-12-19  Gilbert
+!
+! USAGE:    CALL specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld)
+!   INPUT ARGUMENT LIST:
+!     cpack    - The packed data field (character*1 array)
+!     len      - length of packed field cpack().
+!     idrstmpl - Contains the array of values for Data Representation
+!                Template 5.51
+!     ndpts    - The number of data values to unpack
+!     JJ       - J - pentagonal resolution parameter
+!     KK       - K - pentagonal resolution parameter
+!     MM       - M - pentagonal resolution parameter
+!
+!   OUTPUT ARGUMENT LIST:
+!     fld()    - Contains the unpacked data values
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: XL Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      character(len=1),intent(in) :: cpack(len)
+      integer,intent(in) :: ndpts,len,JJ,KK,MM
+      integer,intent(in) :: idrstmpl(*)
+      real,intent(out) :: fld(ndpts)
+
+      integer :: ifld(ndpts),Ts
+      integer(4) :: ieee
+      real :: ref,bscale,dscale,unpk(ndpts)
+      real,allocatable :: pscale(:)
+
+      ieee = idrstmpl(1)
+      call rdieee(ieee,ref,1)
+      bscale = 2.0**real(idrstmpl(2))
+      dscale = 10.0**real(-idrstmpl(3))
+      nbits = idrstmpl(4)
+      Js=idrstmpl(6)
+      Ks=idrstmpl(7)
+      Ms=idrstmpl(8)
+      Ts=idrstmpl(9)
+
+      if (idrstmpl(10).eq.1) then           ! unpacked floats are 32-bit IEEE
+         !call g2lib_gbytes(cpack,ifld,0,32,0,Ts)
+         call rdieee(cpack,unpk,Ts)          ! read IEEE unpacked floats
+         iofst=32*Ts
+         call g2lib_gbytes(cpack,ifld,iofst,nbits,0,ndpts-Ts)  ! unpack scaled data
+!
+!   Calculate Laplacian scaling factors for each possible wave number.
+!
+         allocate(pscale(JJ+MM))
+         tscale=real(idrstmpl(5))*1E-6
+         do n=Js,JJ+MM
+            pscale(n)=real(n*(n+1))**(-tscale)
+         enddo
+!
+!   Assemble spectral coeffs back to original order.
+!
+         inc=1
+         incu=1
+         incp=1
+         do m=0,MM
+            Nm=JJ      ! triangular or trapezoidal
+            if ( KK .eq. JJ+MM ) Nm=JJ+m          ! rhombodial
+            Ns=Js      ! triangular or trapezoidal
+            if ( Ks .eq. Js+Ms ) Ns=Js+m          ! rhombodial
+            do n=m,Nm
+               if (n.le.Ns .AND. m.le.Ms) then    ! grab unpacked value
+                  fld(inc)=unpk(incu)         ! real part
+                  fld(inc+1)=unpk(incu+1)     ! imaginary part
+                  inc=inc+2
+                  incu=incu+2
+               else                         ! Calc coeff from packed value
+                  fld(inc)=((real(ifld(incp))*bscale)+ref)*
+     &                      dscale*pscale(n)           ! real part
+                  fld(inc+1)=((real(ifld(incp+1))*bscale)+ref)*
+     &                      dscale*pscale(n)           ! imaginary part
+                  inc=inc+2
+                  incp=incp+2
+               endif
+            enddo
+         enddo
+
+         deallocate(pscale)
+
+      else
+         print *,'specunpack: Cannot handle 64 or 128-bit floats.'
+         fld=0.0
+         return
+      endif
+
+      return
+      end
diff --git a/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile b/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile
new file mode 100644
index 00000000..22e20169
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile
@@ -0,0 +1,69 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I.
+BUILD_DIR = ../../../io_grib_share/build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = ..
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+F_INCLUDES   = -I. -Ig2lib
+FORMAT       = 
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib2
+CPPFLAGS =
+
+DEP_LIBS = -lio_grib2 -L../.. -lio_grib_share -L../../../io_grib_share -lpng -ljasper
+
+FC = ifort -FR
+CPP = /lib/cpp -traditional -C -P
+LDD = ifort
+MAIN_OBJS =  \
+	test_g2lib.o
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/utest_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib2/g2lib/utest/test_g2lib.F b/wrfv2_fire/external/io_grib2/g2lib/utest/test_g2lib.F
new file mode 100644
index 00000000..c48e9d08
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/g2lib/utest/test_g2lib.F
@@ -0,0 +1,141 @@
+PROGRAM test_g2lib
+  implicit none
+
+  integer , dimension(13)      :: listsec1
+  integer , dimension(2)       :: listsec0
+  integer                      :: ierr
+  integer , parameter          :: lcgrib = 2000000
+  character (lcgrib)           :: cgrib
+
+  integer, dimension(5)                     :: igds
+  integer, parameter                        :: igdstmplen = 25
+  integer, dimension(igdstmplen)            :: igdstmpl
+  integer, parameter                        :: idefnum = 0
+  integer, dimension(idefnum)               :: ideflist
+
+  integer                                   :: ipdsnum
+  integer, parameter                        :: ipdstmplen = 15
+  integer, dimension(ipdstmplen)            :: ipdstmpl
+  integer                                   :: numcoord
+  integer, dimension(1)                     :: coordlist
+  integer                                   :: idrsnum
+  integer, parameter                        :: idrstmplen = 7
+  integer, dimension(idrstmplen)            :: idrstmpl
+  integer                                   :: ibmap
+  integer, dimension(1)                     :: bmap
+  integer, parameter                        :: ngrdpts=20*25
+  real                                      :: fld(ngrdpts)
+
+  ! 
+  ! Create the grib message
+  !
+  listsec0(1) = 0          ! Discipline (Table 0.0)
+  listsec0(2) = 2          ! Grib edition number
+
+  listsec1(1) = 255        ! Id of Originating Center (255 for missing)
+  listsec1(2) = 255        ! Id of originating sub-center (255 for missing)
+  listsec1(3) = 1          ! Master Table Version #
+  listsec1(4) = 1          ! Local table version #
+  listsec1(5) = 1          ! Significance of reference time, 1 indicates start of forecast
+
+  listsec1(6) = 2005       ! Year of reference
+  listsec1(7) = 09         ! Month of reference
+  listsec1(8) = 30         ! Month of reference
+  listsec1(9) = 0          ! Hour
+  listsec1(10) = 0         ! Minute
+  listsec1(11) = 0         ! Second
+  listsec1(12) = 255       ! Production Status
+  listsec1(13) = 1         ! Type of data (1 for forecast)
+
+  call gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
+  if (ierr .ne. 0) then
+     print *, 'gribcreate failed with ierr: ',ierr
+  endif
+
+
+  igds(1) = 0      ! Source of grid definition
+  igds(2) = ngrdpts! Number of points in grid
+  igds(3) = 0      ! 
+  igds(4) = 0
+
+  ! Here, setup the parameters that are common to all WRF projections
+
+  igdstmpl(1) = 1       ! Shape of earth (1 for spherical with specified radius)
+  igdstmpl(2) = 1       ! Scale factor for earth radius
+  igdstmpl(3) = 6370*1000 ! Radius of earth
+  igdstmpl(4) = 0       ! Scale factor for major axis
+  igdstmpl(5) = 0       ! Major axis
+  igdstmpl(6) = 0       ! Scale factor for minor axis
+  igdstmpl(7) = 0       ! Minor axis
+  igdstmpl(8) = 20      ! Number of points along x axis
+  igdstmpl(9) = 25      ! Number of points along y axis
+
+
+  ! This is the setup for lat/lon projection
+  igds(5) = 0
+  igdstmpl(10) = 0    ! Basic Angle of init projection (not important to us)
+  igdstmpl(11) = 0    ! Subdivision of basic angle
+  igdstmpl(12) = -20*1000000
+  igdstmpl(13) = 20*1000000
+  igdstmpl(14) = 128  ! Resolution and component flags
+  igdstmpl(15) = 0*1000000
+  igdstmpl(16) = 40*1000000
+  
+  ! Warning, the following assumes that dx and dy are valid at the equator.
+  !    It is not clear in WRF where dx and dy are valid for latlon projections
+  igdstmpl(17) = 12000 ! i-direction increment in micro degs
+  igdstmpl(18) = 12000 ! j-direction increment in micro degs
+  
+  igdstmpl(19) = 64   ! Scanning mode
+
+  call addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,ideflist,idefnum,ierr)
+  if (ierr .ne. 0) then
+     print *, 'addgrid failed with ierr: ',ierr
+  endif
+
+
+  ipdsnum = 0              ! Product definition template (0 for horiz grid)
+
+  ipdstmpl(1) = 0          ! Parameter category
+  ipdstmpl(2) = 1          ! Parameter number
+  ipdstmpl(3) = 2          ! Type of generating process (2 for forecast)
+  ipdstmpl(4) = 255        ! Background generating process id
+  ipdstmpl(5) = 255        ! Analysis or forecast generating process id
+  ipdstmpl(6) = 0          ! Data cutoff period (Hours)
+  ipdstmpl(7) = 0          ! Data cutoff period (minutes)
+  ipdstmpl(8) = 13         ! Time range indicator (13 for seconds)
+  ipdstmpl(9) = 10800      ! Forecast time
+
+  ipdstmpl(10) = 111       ! Type of first surface (111 for Eta level)
+  ipdstmpl(11) = 0         ! Scale factor for 1st surface
+  ipdstmpl(12) = 9965      ! First fixed surface
+  ipdstmpl(13) = 255    ! Type of second fixed surface
+  ipdstmpl(14) = 255 ! Scale factor for 2nd surface
+  ipdstmpl(15) = 0
+  numcoord = 0
+  coordlist(1) = 0
+  
+  ! Set Data Representation templ (40 for JPEG2000, 41 for PNG)  
+  idrsnum = 40
+  idrstmpl(1) = 255       ! Reference value - ignored on input
+  idrstmpl(2) = 0         ! Binary scale factor
+  idrstmpl(3) = 3         ! Decimal scale factor 
+  idrstmpl(4) = 0         ! number of bits for each data value - ignored on
+  idrstmpl(5) = 0         ! Original field type - ignored on input
+  idrstmpl(6) = 0         ! 0 for lossless compression
+  idrstmpl(7) = 255       ! Desired compression ratio if idrstmpl(6) != 0
+  ibmap = 255                ! Flag for bitmap
+  
+  fld = 1.2
+
+  call addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, coordlist,      &
+       numcoord, idrsnum, idrstmpl, idrstmplen, fld, ngrdpts, ibmap,          &
+       bmap, ierr)
+  
+  if (ierr .ne. 0) then
+     print *, 'addfield failed with ierr: ',ierr
+  endif
+  
+  
+end PROGRAM test_g2lib
+
diff --git a/wrfv2_fire/external/io_grib2/grib2tbls_types.F b/wrfv2_fire/external/io_grib2/grib2tbls_types.F
new file mode 100644
index 00000000..a89cca15
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/grib2tbls_types.F
@@ -0,0 +1,42 @@
+module grib2tbls_types
+
+!*
+!* This module will hold data from a grib2map.tbl table
+!*   The variables will be accessible by all functions (provided they have a
+!*   "USE grb2tbls" line).
+!*
+
+  integer, parameter                          :: MaxNames = 40
+  integer, parameter                          :: maxLineSize = 500
+
+  TYPE :: grib2Entries_type
+     integer                                  :: Disc
+     integer                                  :: Category
+     integer                                  :: ParmNum
+     character(len=maxLineSize)               :: WRFNameString
+     character(len=30), dimension(MaxNames)   :: WRFNames
+     integer                                  :: numWRFNames
+     character(len=200)                       :: Description
+     integer                                  :: DecScl
+     integer                                  :: BinScl
+     TYPE(grib2Entries_type), pointer         :: next
+     TYPE(grib2Entries_type), pointer         :: previous
+  END TYPE grib2Entries_type
+
+  TYPE :: grib2tbls_type
+     integer                                  :: center
+     integer                                  :: subcenter
+     integer                                  :: MasterTblV
+     integer                                  :: LocalTblV
+     integer                                  :: numEntries
+     TYPE(grib2Entries_type),pointer          :: ParmHead
+     TYPE(grib2Entries_type),pointer          :: ParmTail
+     TYPE(grib2tbls_type),pointer             :: next
+     TYPE(grib2tbls_type),pointer             :: previous
+  END TYPE grib2tbls_type
+
+  TYPE(grib2tbls_type), pointer               :: TblHead
+  TYPE(grib2tbls_type), pointer               :: TblTail
+
+end module grib2tbls_types
+
diff --git a/wrfv2_fire/external/io_grib2/io_grib2.F b/wrfv2_fire/external/io_grib2/io_grib2.F
new file mode 100644
index 00000000..5a6e3196
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/io_grib2.F
@@ -0,0 +1,4535 @@
+!*-----------------------------------------------------------------------------
+!*
+!*  Todd Hutchinson
+!*  WSI
+!*  400 Minuteman Road
+!*  Andover, MA     01810
+!*  thutchinson@wsi.com
+!*
+!*  August, 2005
+!*-----------------------------------------------------------------------------
+
+!*
+!* This io_grib2 API is designed to read WRF input and write WRF output data
+!*   in grib version 2 format.  
+!*
+
+
+#include "wrf_projection.h"
+
+module gr2_data_info
+
+!*
+!* This module will hold data internal to this I/O implementation.
+!*   The variables will be accessible by all functions (provided they have a
+!*   "USE gr2_data_info" line).
+!*
+
+  USE grib2tbls_types
+
+  integer                , parameter       :: FATAL            = 1
+  integer                , parameter       :: DEBUG            = 100
+  integer                , parameter       :: DateStrLen       = 19
+  integer                , parameter       :: maxMsgSize       = 300
+  integer                , parameter       :: firstFileHandle  = 8
+  integer                , parameter       :: maxFileHandles   = 200
+  integer                , parameter       :: maxLevels        = 1000
+  integer                , parameter       :: maxSoilLevels    = 100
+  integer                , parameter       :: maxDomains       = 500
+  character(200)                           :: mapfilename = 'grib2map.tbl'
+
+  integer                , parameter       :: JIDSSIZE = 13
+  integer                , parameter       :: JPDTSIZE = 15
+  integer                , parameter       :: JGDTSIZE = 30
+
+  logical                                  :: grib2map_table_filled = .FALSE.
+
+  logical                                  :: WrfIOnotInitialized = .true.
+
+  integer, dimension(maxDomains)           :: domains
+  integer                                  :: max_domain = 0
+
+  character*24                             :: StartDate = ''
+  character*24                             :: InputProgramName = ''
+  real                                     :: timestep
+  integer                                  :: full_xsize, full_ysize
+  REAL,          dimension(maxSoilLevels)  :: soil_depth, soil_thickness
+  REAL,          dimension(maxLevels)      :: half_eta, full_eta
+
+  integer                                  :: wrf_projection
+  integer                                  :: background_proc_id
+  integer                                  :: forecast_proc_id
+  integer                                  :: production_status
+  integer                                  :: compression
+  real                                     :: center_lat, center_lon
+  real                                     :: dx,dy
+  real                                     :: truelat1, truelat2
+  real                                     :: proj_central_lon
+
+  TYPE :: HandleVar
+     character, dimension(:), pointer      :: fileindex(:)
+     integer                               :: CurrentTime
+     integer                               :: NumberTimes
+     integer                               :: sizeAllocated = 0
+     logical                               :: write = .FALSE.
+     character (DateStrLen), dimension(:),allocatable  :: Times(:)
+     logical                               :: committed, opened, used
+     character*128                         :: DataFile
+     integer                               :: FileFd
+     integer                               :: FileStatus
+     integer                               :: recnum
+     real                                  :: last_scalar_time_written
+  ENDTYPE
+  TYPE (HandleVar), dimension(maxFileHandles),SAVE :: fileinfo
+
+  character(len=30000), dimension(maxFileHandles) :: td_output
+  character(len=30000), dimension(maxFileHandles) :: ti_output
+  character(len=30000), dimension(maxFileHandles) :: scalar_output
+  character(len=30000), dimension(maxFileHandles) :: global_input = ''
+  character(len=30000), dimension(maxFileHandles) :: scalar_input = ''
+
+  real                                     :: last_fcst_secs
+  real                                     :: fcst_secs
+
+  logical                                  :: half_eta_init       = .FALSE.
+  logical                                  :: full_eta_init       = .FALSE.
+  logical                                  :: soil_thickness_init = .FALSE.
+  logical                                  :: soil_depth_init     = .FALSE.
+
+end module gr2_data_info
+
+
+!*****************************************************************************
+
+subroutine ext_gr2_ioinit(SysDepInfo,Status)
+
+  USE gr2_data_info
+  implicit none
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  CHARACTER*(*), INTENT(IN) :: SysDepInfo
+  integer ,intent(out) :: Status
+  integer :: i
+  CHARACTER (LEN=300) :: wrf_err_message
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioinit')
+
+  do i=firstFileHandle, maxFileHandles
+        fileinfo(i)%used = .false.
+        fileinfo(i)%committed = .false.
+        fileinfo(i)%opened = .false.
+        td_output(i) = ''
+        ti_output(i) = ''
+        scalar_output(i) = ''
+  enddo
+  domains(:) = -1
+  last_fcst_secs = -1.0
+
+  fileinfo(1:maxFileHandles)%FileStatus = WRF_FILE_NOT_OPENED
+  WrfIOnotInitialized = .false.
+
+  Status = WRF_NO_ERR
+
+  return
+end subroutine ext_gr2_ioinit
+
+!*****************************************************************************
+
+subroutine ext_gr2_ioexit(Status)
+
+  USE gr2_data_info
+  implicit none
+#include "wrf_status_codes.h"
+  integer ,intent(out) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioexit')
+
+  Status = WRF_NO_ERR
+
+  if (grib2map_table_filled) then
+     call free_grib2map()
+     grib2map_table_filled = .FALSE.
+  endif
+
+  return
+end subroutine ext_gr2_ioexit
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_open_for_read_begin ( FileName , Comm_compute, Comm_io, &
+     SysDepInfo, DataHandle , Status )
+
+  USE gr2_data_info
+  USE grib2tbls_types
+  USE grib_mod
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER (LEN=maxMsgSize) :: msg
+
+  integer :: center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
+
+  integer :: fields_to_skip
+  integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
+       JGDT(JGDTSIZE)
+  logical :: UNPACK
+  character*(100) :: VarName
+  type(gribfield) :: gfld
+  integer         :: idx
+  character(len=DateStrLen) :: theTime,refTime
+  integer         :: time_range_convert(13)
+  integer         :: fcstsecs
+  integer         :: endchar
+  integer         :: ierr
+
+  INTERFACE
+     Subroutine load_grib2map (filename, message, status)
+       USE grib2tbls_types
+       character*(*), intent(in)                   :: filename
+       character*(*), intent(inout)                :: message
+       integer      , intent(out)                  :: status
+     END subroutine load_grib2map
+  END INTERFACE
+
+  call wrf_debug ( DEBUG , &
+       'Entering ext_gr2_open_for_read_begin, opening '//trim(FileName))
+
+  CALL gr2_get_new_handle(DataHandle)
+
+  !
+  ! Open grib file
+  !
+  if (DataHandle .GT. 0) then
+     
+     call baopenr(DataHandle,trim(FileName),status)
+
+     if (status .ne. 0) then
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+     else
+        fileinfo(DataHandle)%opened = .true.
+        fileinfo(DataHandle)%DataFile = TRIM(FileName)
+        fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+!        fileinfo(DataHandle)%CurrentTime = 1
+     endif
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+     return
+  endif
+ 
+  fileinfo(DataHandle)%recnum = -1
+
+  !
+  ! Fill up the grib2tbls structure from data in the grib2map file.
+  !
+  if (.NOT. grib2map_table_filled) then
+     grib2map_table_filled = .TRUE.
+     CALL load_grib2map(mapfilename, msg, status)
+     if (status .ne. 0) then
+        call wrf_message(trim(msg))
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+        return
+     endif
+  endif
+
+
+  !
+  ! Get the parameter info for metadata
+  !
+  VarName = "WRF_GLOBAL"
+  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+  if (status .ne. 0) then
+     write(msg,*) 'Could not find parameter for '//   &
+          trim(VarName)//'   Skipping output of '//trim(VarName)
+     call wrf_message(trim(msg))
+     Status =  WRF_GRIB2_ERR_GRIB2MAP
+     return
+  endif
+
+  !
+  ! Read the metadata
+  !
+  fields_to_skip = 0
+  
+  !
+  ! First, set all values to the wildcard, then reset values that we wish
+  !    to specify.
+  !
+  call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
+  
+  JIDS(1) = center
+  JIDS(2) = subcenter
+  JIDS(3) = MasterTblV
+  JIDS(4) = LocalTblV
+  JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
+  JIDS(13) = 1          ! Type of processed data (1 for forecast products)
+  
+  JPDTN = 0             ! Product definition template number
+  JPDT(1) = Category
+  JPDT(2) = ParmNum
+  JPDT(3) = 2           ! Generating process id
+  JPDT(9) = 0           ! Forecast time 
+
+  JGDTN    = -1         ! Indicates that any Grid Display Template is a match
+  
+  UNPACK   = .FALSE.    ! Dont unpack bitmap and data values
+
+  CALL GETGB2(DataHandle, DataHandle, fields_to_skip, -1, Disc, JIDS, JPDTN, &
+       JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, gfld, status)
+  if (status .ne. 0) then
+     if (status .eq. 99) then
+        write(msg,*)'Could not find metadata field named '//trim(VarName)
+     else
+        write(msg,*)'Retrieving grib field '//trim(VarName)//' failed, ',status
+     endif
+     call wrf_message(trim(msg))
+     status = WRF_GRIB2_ERR_GETGB2
+     return
+  endif
+
+  global_input(DataHandle) = transfer(gfld%local,global_input(DataHandle))
+  global_input(DataHandle)(gfld%locallen+1:30000) = ' '
+
+  call gf_free(gfld)
+
+  !
+  ! Read and index all scalar data
+  !
+  VarName = "WRF_SCALAR"
+  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+  if (status .ne. 0) then
+     write(msg,*) 'Could not find parameter for '//   &
+          trim(VarName)//'   Skipping reading of '//trim(VarName)
+     call wrf_message(trim(msg))
+     Status =  WRF_GRIB2_ERR_GRIB2MAP
+     return
+  endif
+
+  !
+  ! Read the metadata
+  !
+  ! First, set all values to wild, then specify necessary values
+  !
+  call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
+
+  JIDS(1) = center
+  JIDS(2) = subcenter
+  JIDS(3) = MasterTblV
+  JIDS(4) = LocalTblV
+
+  JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
+  JIDS(13) = 1          ! Type of processed data (1 for forecast products)
+  
+  JPDTN = 0             ! Product definition template number
+  JPDT(1) = Category
+  JPDT(2) = ParmNum
+  JPDT(3) = 2           ! Generating process id
+
+  JGDTN    = -1         ! Indicates that any Grid Display Template is a match
+  
+  UNPACK   = .FALSE.    ! Dont unpack bitmap and data values
+
+  fields_to_skip = 0
+  do while (status .eq. 0) 
+     CALL GETGB2(DataHandle, 0, fields_to_skip, -1, -1, JIDS, JPDTN, &
+          JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
+          gfld, status)
+     if (status .eq. 99) then
+        exit
+     else if (status .ne. 0) then
+        write(msg,*)'Finding data field '//trim(VarName)//' failed 1.'
+        call wrf_message(trim(msg))
+        Status = WRF_GRIB2_ERR_READ
+        return
+     endif
+     
+     ! Build times list here
+     write(refTime,'(I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)')      &
+          gfld%idsect(6),'-',gfld%idsect(7),'-',gfld%idsect(8),'_',&
+          gfld%idsect(9),':',gfld%idsect(10),':',gfld%idsect(11)
+
+     time_range_convert(:) = -1
+     time_range_convert(1) = 60
+     time_range_convert(2) = 60*60
+     time_range_convert(3) = 24*60*60
+     time_range_convert(10) = 3*60*60
+     time_range_convert(11) = 6*60*60
+     time_range_convert(12) = 12*60*60
+     time_range_convert(13) = 1
+     
+     if (time_range_convert(gfld%ipdtmpl(8)) .gt. 0) then
+        fcstsecs = gfld%ipdtmpl(9)*time_range_convert(gfld%ipdtmpl(8))
+     else 
+        write(msg,*)'Invalid time range in input data: ',gfld%ipdtmpl(8),&
+             ' Skipping'
+        call wrf_message(trim(msg))
+        call gf_free(gfld)
+        cycle
+     endif
+     call advance_wrf_time(refTime,fcstsecs,theTime)
+
+     call gr2_add_time(DataHandle,theTime)
+
+     fields_to_skip = fields_to_skip + fileinfo(DataHandle)%recnum
+
+     scalar_input(DataHandle) = transfer(gfld%local,scalar_input(DataHandle))
+     scalar_input(DataHandle)(gfld%locallen+1:30000) = ' '
+     
+     call gf_free(gfld)
+  enddo
+
+  !
+  ! Fill up the eta levels variables
+  !
+
+  if (.not. full_eta_init) then
+     CALL gr2_fill_levels(DataHandle, "ZNW", full_eta, ierr)
+     if (ierr .eq. 0) then
+        full_eta_init = .TRUE.
+     endif
+  endif
+  if (.not. half_eta_init) then
+     CALL gr2_fill_levels(DataHandle, "ZNU", half_eta, ierr)
+     if (ierr .eq. 0) then 
+        half_eta_init = .TRUE.
+     endif
+  endif
+  !
+  ! Fill up the soil levels
+  !
+  if (.not. soil_depth_init) then
+     call gr2_fill_levels(DataHandle,"ZS",soil_depth, ierr)
+     if (ierr .eq. 0) then
+        soil_depth_init = .TRUE.
+     endif
+  endif
+  if (.not. soil_thickness_init) then
+     call gr2_fill_levels(DataHandle,"DZS",soil_thickness, ierr)
+     if (ierr .eq. 0) then
+        soil_thickness_init = .TRUE.
+     endif
+  endif
+
+  ! 
+  ! Fill up any variables from the global metadata
+  !
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       'START_DATE', StartDate, status)
+  if (status .ne. 0) then
+     write(msg,*)'Could not find metadata value for START_DATE, continuing'
+     call wrf_message(trim(msg))
+  endif
+ 
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       'PROGRAM_NAME', InputProgramName, status)
+  if (status .ne. 0) then
+     write(msg,*)'Could not find metadata value for PROGRAM_NAME, continuing'
+     call wrf_message(trim(msg))
+  else
+     endchar = SCAN(InputProgramName," ")
+     InputProgramName = InputProgramName(1:endchar)
+  endif
+
+
+  Status = WRF_NO_ERR
+
+  call wrf_debug ( DEBUG , 'Exiting ext_gr2_open_for_read_begin')
+
+  RETURN
+END SUBROUTINE ext_gr2_open_for_read_begin
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_open_for_read_commit( DataHandle , Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  character(len=maxMsgSize) :: msg
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read_commit')
+
+  Status = WRF_NO_ERR
+  if(WrfIOnotInitialized) then
+    Status = WRF_IO_NOT_INITIALIZED
+    write(msg,*) 'ext_gr2_ioinit was not called ',__FILE__,', line', __LINE__
+    call wrf_debug ( FATAL , msg)
+    return
+  endif
+  fileinfo(DataHandle)%committed = .true.
+  fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_READ
+
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr2_open_for_read_commit
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_open_for_read ( FileName , Comm_compute, Comm_io, &
+     SysDepInfo, DataHandle , Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read')
+
+  DataHandle = 0   ! dummy setting to quiet warning message
+  CALL ext_gr2_open_for_read_begin( FileName, Comm_compute, Comm_io, &
+       SysDepInfo, DataHandle, Status )
+  IF ( Status .EQ. WRF_NO_ERR ) THEN
+    CALL ext_gr2_open_for_read_commit( DataHandle, Status )
+  ENDIF
+  return
+
+  RETURN  
+END SUBROUTINE ext_gr2_open_for_read
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
+     DataHandle, Status)
+  
+  USE gr2_data_info
+  implicit none
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+
+  character*(*)        ,intent(in)  :: FileName
+  integer              ,intent(in)  :: Comm
+  integer              ,intent(in)  :: IOComm
+  character*(*)        ,intent(in)  :: SysDepInfo
+  integer              ,intent(out) :: DataHandle
+  integer              ,intent(out) :: Status
+  integer :: ierr
+  CHARACTER (LEN=maxMsgSize) :: msg
+
+  INTERFACE
+     Subroutine load_grib2map (filename, message, status)
+       USE grib2tbls_types
+       character*(*), intent(in)                   :: filename
+       character*(*), intent(inout)                :: message
+       integer      , intent(out)                  :: status
+     END subroutine load_grib2map
+  END INTERFACE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_begin')
+
+  Status = WRF_NO_ERR
+
+  if (.NOT. grib2map_table_filled) then
+     grib2map_table_filled = .TRUE.
+     CALL load_grib2map(mapfilename, msg, status)
+     if (status .ne. 0) then
+        call wrf_message(trim(msg))
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+        return
+     endif
+  endif
+
+  CALL gr2_get_new_handle(DataHandle)
+
+  if (DataHandle .GT. 0) then
+
+     call baopenw(DataHandle,trim(FileName),ierr)
+
+     if (ierr .ne. 0) then
+        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+     else
+        fileinfo(DataHandle)%opened = .true.
+        fileinfo(DataHandle)%DataFile = TRIM(FileName)
+        fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+     endif
+     fileinfo(DataHandle)%last_scalar_time_written = -1
+     fileinfo(DataHandle)%committed = .false.
+     td_output(DataHandle) = ''
+     ti_output(DataHandle) = ''
+     scalar_output(DataHandle) = ''
+     fileinfo(DataHandle)%write = .true.
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+  endif
+
+  RETURN  
+END SUBROUTINE ext_gr2_open_for_write_begin
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_open_for_write_commit( DataHandle , Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_commit')
+
+  IF ( fileinfo(DataHandle)%opened ) THEN
+    IF ( fileinfo(DataHandle)%used ) THEN
+      fileinfo(DataHandle)%committed = .true.
+      fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_WRITE
+    ENDIF
+  ENDIF
+
+  Status = WRF_NO_ERR
+
+  RETURN  
+END SUBROUTINE ext_gr2_open_for_write_commit
+
+!*****************************************************************************
+
+subroutine ext_gr2_inquiry (Inquiry, Result, Status)
+  use gr2_data_info
+  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")
+     Result='ALLOW'
+  CASE ("SEQUENTIAL_WRITE","SEQUENTIAL_READ")
+     Result='NO'
+  CASE ("OPEN_READ", "OPEN_WRITE", "OPEN_COMMIT_WRITE")
+     Result='REQUIRE'
+  CASE ("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_gr2_inquiry
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_inquire_opened ( DataHandle, FileName , FileStat, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStat
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_opened')
+
+  FileStat = WRF_NO_ERR
+  if ((DataHandle .ge. firstFileHandle) .and. &
+       (DataHandle .le. maxFileHandles)) then
+     FileStat = fileinfo(DataHandle)%FileStatus
+  else
+     FileStat = WRF_FILE_NOT_OPENED
+  endif
+  
+  Status = FileStat
+
+  RETURN
+END SUBROUTINE ext_gr2_inquire_opened
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_ioclose ( DataHandle, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER DataHandle, Status
+  INTEGER istat
+  character(len=1000) :: outstring
+  character :: lf
+  character*(maxMsgSize) :: msg
+  integer   :: idx
+
+  lf=char(10)
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioclose')
+
+  Status = WRF_NO_ERR
+
+  if (fileinfo(DataHandle)%write .eqv. .TRUE.) then
+     call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
+          "WRF_SCALAR",fcst_secs,msg,status)
+     if (status .ne. 0) then
+        call wrf_message(trim(msg))
+        return
+     endif
+     fileinfo(DataHandle)%last_scalar_time_written = fcst_secs
+     scalar_output(DataHandle) = ''
+     
+     call gr2_fill_local_use(DataHandle,&
+          trim(ti_output(DataHandle))//trim(td_output(DataHandle)),&
+          "WRF_GLOBAL",0,msg,status)
+     if (status .ne. 0) then
+        call wrf_message(trim(msg))
+        return
+     endif
+     ti_output(DataHandle) = ''
+     td_output(DataHandle) = ''
+  endif
+
+  do idx = 1,fileinfo(DataHandle)%NumberTimes 
+     if (allocated(fileinfo(DataHandle)%Times)) then
+        deallocate(fileinfo(DataHandle)%Times)
+     endif
+  enddo
+  fileinfo(DataHandle)%NumberTimes = 0
+  fileinfo(DataHandle)%sizeAllocated = 0
+  fileinfo(DataHandle)%CurrentTime = 0
+  fileinfo(DataHandle)%write = .FALSE.
+
+  call baclose(DataHandle,status)
+  if (status .ne. 0) then
+     call wrf_message("Closing file failed, continuing")
+  else
+     fileinfo(DataHandle)%opened = .true.
+     fileinfo(DataHandle)%DataFile = ''
+     fileinfo(DataHandle)%FileStatus = WRF_FILE_NOT_OPENED
+  endif
+
+  fileinfo(DataHandle)%used = .false.
+
+  RETURN
+END SUBROUTINE ext_gr2_ioclose
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_write_field( DataHandle , DateStrIn , VarName , &
+     Field , FieldType , Comm , IOComm, &
+     DomainDesc , MemoryOrder , Stagger , &
+     DimNames , &
+     DomainStart , DomainEnd , &
+     MemoryStart , MemoryEnd , &
+     PatchStart , PatchEnd , &
+     Status )
+
+  USE gr2_data_info
+  USE grib2tbls_types
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  integer                       ,intent(in)    :: DataHandle 
+  character*(*)                 ,intent(in)    :: DateStrIn
+  character*(*)                 ,intent(in)    :: VarName
+  integer                       ,intent(in)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrder
+  character*(*)                 ,intent(in)    :: Stagger
+  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
+
+  real                          , intent(in), &
+       dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
+       MemoryStart(2):MemoryEnd(2), &
+       MemoryStart(3):MemoryEnd(3) )           :: Field
+
+
+  character (120)                              :: DateStr
+
+  character (maxMsgSize)                       :: msg
+  integer                                      :: xsize, ysize, zsize
+  integer                                      :: x, y, z
+  integer                                      :: &
+       x_start,x_end,y_start,y_end,z_start,z_end
+  integer                                      :: idx
+  integer                                      :: proj_center_flag
+  logical                                      :: vert_stag = .false.
+  real,    dimension(:,:), pointer             :: data
+  integer                                      :: istat
+  integer                                      :: accum_period
+  integer, dimension(maxLevels)                :: level1, level2
+  integer, dimension(maxLevels)                :: grib_levels
+  logical                                      :: soil_layers, fraction
+  integer                                      :: vert_unit1, vert_unit2
+  integer                                      :: vert_sclFctr1, vert_sclFctr2
+  integer                                      :: this_domain
+  logical                                      :: new_domain
+  real                                         :: &
+       region_center_lat, region_center_lon
+  integer                                      :: dom_xsize, dom_ysize;
+  integer , parameter                          :: lcgrib = 2000000
+  character (lcgrib)                           :: cgrib
+  integer                                      :: ierr
+  integer                                      :: lengrib
+
+  integer                                     :: center, subcenter, &
+       MasterTblV, LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
+  CHARACTER(len=100)  :: tmpstr
+  integer             :: ndims
+  integer             :: dim1size, dim2size, dim3size, dim3
+  integer             :: numlevels
+  integer             :: ngrdpts
+  integer             :: bytes_written
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_write_field for parameter '//&
+       VarName)
+
+  !
+  ! If DateStr is all 0s, we reset it to StartDate.  For some reason, 
+  !   in idealized simulations, StartDate is 0001-01-01_00:00:00 while
+  !   the first DateStr is 0000-00-00_00:00:00.  
+  !
+  if (DateStrIn .eq. '0000-00-00_00:00:00') then
+     DateStr = TRIM(StartDate)
+  else
+     DateStr = DateStrIn
+  endif
+
+  !
+  ! Check if this is a domain that we haven t seen yet.  If so, add it to 
+  !   the list of domains.
+  !
+  this_domain = 0
+  new_domain = .false.
+  do idx = 1, max_domain
+     if (DomainDesc .eq. domains(idx)) then
+        this_domain = idx
+     endif
+  enddo
+  if (this_domain .eq. 0) then
+     max_domain = max_domain + 1
+     domains(max_domain) = DomainDesc
+     this_domain = max_domain
+     new_domain = .true.
+  endif
+
+  zsize = 1
+  xsize = 1
+  ysize = 1
+  soil_layers = .false.
+  fraction = .false.
+
+  ! First, handle then special cases for the boundary data.
+
+  CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
+       y_start, y_end,z_start,z_end)
+  xsize = x_end - x_start + 1
+  ysize = y_end - y_start + 1
+  zsize = z_end - z_start + 1
+
+  do idx = 1, len(MemoryOrder)
+     if ((MemoryOrder(idx:idx) .eq. 'Z') .and. &
+          (DimNames(idx) .eq. 'soil_layers_stag')) then
+        soil_layers = .true.
+     else if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCBOT') .or. &
+          (VarName .eq. 'SOILCTOP')) then
+        fraction = .true.
+     endif
+  enddo
+
+  if (zsize .eq. 0) then 
+     zsize = 1
+  endif
+
+  !
+  ! Fill up the variables that hold the vertical coordinate data
+  !
+
+  if (VarName .eq. 'ZNU') then
+     do idx = 1, zsize
+        half_eta(idx) = Field(1,idx,1,1)
+     enddo
+     half_eta_init = .TRUE.
+  endif
+
+  if (VarName .eq. 'ZNW') then
+     do idx = 1, zsize
+        full_eta(idx) = Field(1,idx,1,1)
+     enddo
+     full_eta_init = .TRUE.
+  endif
+  
+  if (VarName .eq. 'ZS') then
+     do idx = 1, zsize
+        soil_depth(idx) = Field(1,idx,1,1)
+     enddo
+     soil_depth_init = .TRUE.
+  endif
+
+  if (VarName .eq. 'DZS') then
+     do idx = 1, zsize
+        soil_thickness(idx) = Field(1,idx,1,1)
+     enddo
+     soil_thickness_init = .TRUE.
+  endif
+
+  ! 
+  ! Check to assure that dimensions are valid
+  !
+
+  if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
+     write(msg,*) 'Cannot output field with memory order: ', &
+          MemoryOrder,Varname
+     call wrf_message(trim(msg))
+     return
+  endif
+     
+
+  if (fileinfo(DataHandle)%opened .and. fileinfo(DataHandle)%committed) then
+
+     if (StartDate == '') then
+        StartDate = DateStr
+     endif
+     
+     CALL geth_idts(DateStr,StartDate,fcst_secs)
+
+     !
+     ! If this is a new forecast time, and we have not written the 
+     !   last_fcst_secs scalar output yet, then write it here.
+     !
+
+     if ((abs(fcst_secs - 0.0) .gt. 0.01) .and. &
+          (last_fcst_secs .ge. 0) .and. &
+          (abs(fcst_secs - last_fcst_secs) .gt. 0.01) .and. &
+          (abs(last_fcst_secs - fileinfo(DataHandle)%last_scalar_time_written) .gt. 0.01) ) then
+        call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
+             "WRF_SCALAR",last_fcst_secs,msg,status)
+        if (status .ne. 0) then
+           call wrf_message(trim(msg))
+           return
+        endif
+        fileinfo(DataHandle)%last_scalar_time_written = last_fcst_secs
+        scalar_output(DataHandle) = ''
+     endif
+
+     call get_vert_stag(VarName,Stagger,vert_stag)
+     
+     do idx = 1, zsize
+        call gr2_get_levels(VarName, idx, zsize, soil_layers, vert_stag, &
+             fraction, vert_unit1, vert_unit2, vert_sclFctr1, &
+             vert_sclFctr2, level1(idx), level2(idx))
+     enddo
+     
+     ! 
+     ! Get the center lat/lon for the area being output.  For some cases (such
+     !    as for boundary areas, the center of the area is different from the
+     !    center of the model grid.
+     !
+     if (index(Stagger,'X') .le. 0) then
+        dom_xsize = full_xsize - 1
+     else
+        dom_xsize = full_xsize
+     endif
+     if (index(Stagger,'Y') .le. 0) then
+        dom_ysize = full_ysize - 1
+     else
+        dom_ysize = full_ysize
+     endif
+     
+
+     CALL get_region_center(MemoryOrder, wrf_projection, center_lat, &
+          center_lon, dom_xsize, dom_ysize, dx, dy, proj_central_lon, &
+          proj_center_flag, truelat1, truelat2, xsize, ysize, &
+          region_center_lat, region_center_lon)
+     
+
+     if (ndims .eq. 0) then        ! Scalar quantity
+
+        ALLOCATE(data(1:1,1:1), STAT=istat)
+
+        call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, &
+             xsize, ysize, zsize, z, FieldType, Field, data)
+        write(tmpstr,'(G17.10)')data(1,1)
+        CALL gr2_build_string (scalar_output(DataHandle), &
+             trim(adjustl(VarName)), tmpstr, 1, Status)
+
+        DEALLOCATE(data)
+
+     else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities
+
+        if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
+           dim1size = zsize
+           dim2size = 1
+           dim3size = 1
+        else                       ! Handle 2/3 D parameters
+           dim1size = xsize
+           dim2size = ysize
+           dim3size = zsize
+        endif
+        
+        ALLOCATE(data(1:dim1size,1:dim2size), STAT=istat)
+
+        CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+             LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+        if (status .ne. 0) then
+           write(msg,*) 'Could not find parameter for '//   &
+                trim(VarName)//'   Skipping output of '//trim(VarName)
+           call wrf_message(trim(msg))
+           Status =  WRF_GRIB2_ERR_GRIB2MAP
+           return
+        endif
+
+        VERTDIM : do dim3 = 1, dim3size
+
+           call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, xsize, &
+                ysize, zsize, dim3, FieldType, Field, data)
+        
+           ! 
+           ! Here, we do any necessary conversions to the data.
+           !
+           
+           ! Potential temperature is sometimes passed in as perturbation 
+           !   potential temperature (i.e., POT-300).  Other times (i.e., from 
+           !   WRF SI), it is passed in as full potential temperature.
+           ! Here, we convert to full potential temperature by adding 300
+           !   only if POT < 200 K.
+           !
+           if (VarName == 'T') then
+              if ((data(1,1) < 200) .and. (data(1,1) .ne. 0)) then
+                 data = data + 300
+              endif
+           endif
+           
+           ! 
+           ! For precip, we setup the accumulation period, and output a precip
+           !    rate for time-step precip.
+           !
+           if ((VarName .eq. 'RAINCV') .or. (VarName .eq. 'RAINNCV')) then
+              ! Convert time-step precip to precip rate.
+              data = data/timestep
+              accum_period = 0
+           else
+              accum_period = 0
+           endif
+           
+           !
+           ! Create indicator and identification sections (sections 0 and 1)
+           !
+           CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, &
+                Disc, center, subcenter, MasterTblV, LocalTblV, ierr, msg)
+           if (ierr .ne. 0) then
+              call wrf_message(trim(msg))
+              Status = WRF_GRIB2_ERR_GRIBCREATE
+              return
+           endif
+
+           !
+           ! Add the grid definition section (section 3) using a 1x1 grid
+           !
+           call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon,  &
+                wrf_projection, truelat1, truelat2, xsize, ysize, dx, dy, &
+                region_center_lat, region_center_lon, ierr, msg)
+           if (ierr .ne. 0) then
+              call wrf_message(trim(msg))
+              Status = WRF_GRIB2_ERR_ADDGRIB
+              return
+           endif
+
+           if (ndims .eq. 1) then
+              numlevels = zsize
+              grib_levels(:) = level1(:)
+              ngrdpts = zsize
+           else
+              numlevels = 2
+              grib_levels(1) = level1(dim3)
+              grib_levels(2) = level2(dim3)
+              ngrdpts = xsize*ysize
+           endif
+           
+           !
+           ! Add the Product Definition, Data representation, bitmap 
+           !      and data sections (sections 4-7)
+           !
+           
+           call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, &
+                DecScl, BinScl, fcst_secs, vert_unit1, vert_unit2, &
+                vert_sclFctr1, vert_sclFctr2, numlevels, &
+                grib_levels, ngrdpts,  background_proc_id, forecast_proc_id, &
+                compression, data, ierr, msg)
+           if (ierr .eq. 11) then
+              write(msg,'(A,I7,A)') 'WARNING: decimal scale for field '//&
+                   trim(VarName)//' at level ',grib_levels(1),&
+                   ' was reduced to fit field into 24 bits.  '//&
+                   ' Some precision may be lost!'//&
+                   '     To prevent this message, reduce decimal scale '//&
+                   'factor in '//trim(mapfilename)
+              call wrf_message(trim(msg))
+           else if (ierr .eq. 12) then
+              write(msg,'(A,I7,A)') 'WARNING: binary scale for field '//&
+                   trim(VarName)//' at level ',grib_levels(1), &
+                   ' was reduced to fit field into 24 bits.  '//&
+                   ' Some precision may be lost!'//&
+                   '     To prevent this message, reduce binary scale '//&
+                   'factor in '//trim(mapfilename)
+              call wrf_message(trim(msg))
+           else if (ierr .ne. 0) then
+              call wrf_message(trim(msg))
+              Status = WRF_GRIB2_ERR_ADDFIELD
+              return
+           endif
+
+           !
+           ! Close out the message
+           !
+           
+           call gribend(cgrib,lcgrib,lengrib,ierr)
+           if (ierr .ne. 0) then
+              write(msg,*) 'gribend failed with ierr: ',ierr     
+              call wrf_message(trim(msg))
+              Status = WRF_GRIB2_ERR_GRIBEND
+              return
+           endif
+
+           ! 
+           ! Write the data to the file
+           !
+           
+!           call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, ierr)
+           call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
+           if (bytes_written .ne. lengrib) then
+              write(msg,*) '1 Error writing cgrib to file, wrote: ', &
+                   bytes_written, ' bytes.  Tried to write ', lengrib, ' bytes'
+              call wrf_message(trim(msg))
+              Status = WRF_GRIB2_ERR_WRITE
+              return
+           endif
+
+        ENDDO VERTDIM
+        
+        DEALLOCATE(data)
+
+     endif
+
+     last_fcst_secs = fcst_secs
+
+  endif
+
+  deallocate(data, STAT = istat)
+
+  Status = WRF_NO_ERR
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr2_write_field')
+
+  RETURN
+END SUBROUTINE ext_gr2_write_field
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_read_field ( DataHandle , DateStr , VarName , Field , &
+     FieldType , Comm , IOComm, DomainDesc , MemoryOrder , Stagger ,     &
+     DimNames , DomainStart , DomainEnd , MemoryStart , MemoryEnd ,      &
+     PatchStart , PatchEnd ,  Status )
+
+  USE gr2_data_info
+  USE grib_mod
+  IMPLICIT NONE  
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER                       ,intent(in)       :: DataHandle 
+  CHARACTER*(*)                 ,intent(in)       :: DateStr
+  CHARACTER*(*)                 ,intent(in)       :: VarName
+  integer                       ,intent(inout)    :: FieldType
+  integer                       ,intent(inout)    :: Comm
+  integer                       ,intent(inout)    :: IOComm
+  integer                       ,intent(inout)    :: DomainDesc
+  character*(*)                 ,intent(inout)    :: MemoryOrder
+  character*(*)                 ,intent(inout)    :: Stagger
+  character*(*) , dimension (*) ,intent(inout)    :: DimNames
+  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
+  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)      :: Status
+  INTEGER                       ,intent(out)      :: Field(*)
+  integer                       :: xsize,ysize,zsize
+  integer                       :: x_start,x_end,y_start,y_end,z_start,z_end
+  integer                       :: ndims
+  character (len=1000)          :: Value
+  character (maxMsgSize)        :: msg
+  integer                       :: ierr
+  real                          :: Data
+  integer                       :: center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
+  integer                       :: dim1size,dim2size,dim3size,dim3
+
+  integer :: idx
+  integer :: fields_to_skip
+  integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
+       JGDT(JGDTSIZE)
+  logical :: UNPACK
+  type(gribfield) :: gfld
+  logical                                      :: soil_layers, fraction
+  logical                                      :: vert_stag = .false.
+  integer                                      :: vert_unit1, vert_unit2
+  integer                                      :: vert_sclFctr1, vert_sclFctr2
+  integer                                      :: level1, level2
+  integer                                      :: di
+  real                                         :: tmpreal
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_read_field'//fileinfo(DataHandle)%DataFile)
+  
+  CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
+       y_start, y_end,z_start,z_end)
+  xsize = x_end - x_start + 1
+  ysize = y_end - y_start + 1
+  zsize = z_end - z_start + 1
+
+  ! 
+  ! Check to assure that dimensions are valid
+  !
+
+  if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
+     write(msg,*) 'Cannot retrieve field with memory order: ', &
+          MemoryOrder,Varname
+     Status = WRF_GRIB2_ERR_READ
+     call wrf_message(trim(msg))
+     return
+  endif
+     
+
+  if (ndims .eq. 0) then    ! Scalar quantity
+
+     call gr2_get_metadata_value(scalar_input(DataHandle),trim(VarName),&
+          Value,ierr)
+     if (ierr /= 0) then
+        Status = WRF_GRIB2_ERR_READ
+        CALL wrf_message ( &
+             "gr2_get_metadata_value failed for Scalar variable "//&
+             trim(VarName))
+        return
+     endif
+
+     READ(Value,*,IOSTAT=ierr)Data
+     if (ierr .ne. 0) then
+        CALL wrf_message("Reading data from "//trim(VarName)//" failed")
+        Status = WRF_GRIB2_ERR_READ
+        return
+     endif
+
+     if (FieldType .eq. WRF_INTEGER) then
+        Field(1:1) = data
+     else if ((FieldType .eq. WRF_REAL) .or. (FieldType .eq. WRF_DOUBLE)) then
+        Field(1:1) = TRANSFER(data,Field(1),1)
+     else
+        write (msg,*)'Reading of type ',FieldType,'from grib data not supported, not reading ',VarName
+        call wrf_message(msg)
+     endif
+
+  else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities
+     
+     if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
+        dim1size = zsize
+        dim2size = 1
+        dim3size = 1
+     else                       ! Handle 2/3 D parameters
+        dim1size = xsize
+        dim2size = ysize
+        dim3size = zsize
+     endif
+     
+     CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+          LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+     if (status .ne. 0) then
+        write(msg,*) 'Could not find parameter for '//   &
+             trim(VarName)//'   Skipping output of '//trim(VarName)
+        call wrf_message(trim(msg))
+        Status =  WRF_GRIB2_ERR_GRIB2MAP
+        return
+     endif
+     
+     CALL get_vert_stag(VarName,Stagger,vert_stag)
+     CALL get_soil_layers(VarName,soil_layers)
+
+     VERTDIM : do dim3 = 1, dim3size
+
+        fields_to_skip = 0
+
+        !
+        ! First, set all values to wild, then specify necessary values
+        !
+        call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
+
+        JIDS(1) = center
+        JIDS(2) = subcenter
+        JIDS(3) = MasterTblV
+        JIDS(4) = LocalTblV
+        JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
+        
+        READ (StartDate,'(I4.4,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2)') &
+             (JIDS(idx),idx=6,11)
+        JIDS(13) = 1          ! Type of processed data(1 for forecast products)
+        
+        JPDT(1) = Category
+        JPDT(2) = ParmNum
+        JPDT(3) = 2           ! Generating process id
+
+        CALL geth_idts(DateStr,StartDate,tmpreal)  ! Forecast time 
+        
+        JPDT(9) = NINT(tmpreal)
+
+        if (ndims .eq. 1) then
+           jpdtn = 1000       ! Product definition tmplate (1000 for cross-sxn)
+        else
+           call gr2_get_levels(VarName, dim3, dim3size, soil_layers, &
+                vert_stag, .false., vert_unit1, vert_unit2, vert_sclFctr1, &
+                vert_sclFctr2, level1, level2)
+           
+           jpdtn = 0          ! Product definition template (0 for horiz grid)
+           JPDT(10) = vert_unit1     ! Type of first surface
+           JPDT(11) = vert_sclFctr1  ! Scale factor first surface
+           JPDT(12) = level1         ! First surface
+           JPDT(13) = vert_unit2     ! Type of second surface
+           JPDT(14) = vert_sclFctr2  ! Scale factor second surface
+           JPDT(15) = level2         ! Second fixed surface
+        endif
+
+        JGDTN    = -1    ! Indicates that any Grid Display Template is a match
+        
+        UNPACK   = .TRUE.! Unpack bitmap and data values
+        
+        fields_to_skip = 0
+        CALL GETGB2(DataHandle, 0, fields_to_skip, &
+             fileinfo(DataHandle)%recnum+1, &
+             Disc, JIDS, JPDTN, JPDT, JGDTN, JGDT, UNPACK, &
+             fileinfo(DataHandle)%recnum, gfld, status)
+        if (status .eq. 99) then
+           write(msg,*)'Could not find data for field '//trim(VarName)//&
+                ' in file '//trim(fileinfo(DataHandle)%DataFile)
+           call wrf_message(trim(msg))
+           Status = WRF_GRIB2_ERR_READ
+           return
+        else if (status .ne. 0) then
+           write(msg,*)'Retrieving data field '//trim(VarName)//' failed 2.',status,dim3,DataHandle
+           call wrf_message(trim(msg))
+           Status = WRF_GRIB2_ERR_READ
+           return
+        endif
+
+        if(FieldType == WRF_DOUBLE) then
+           di = 2
+        else 
+           di = 1
+        endif
+
+        ! 
+        ! Here, we do any necessary conversions to the data.
+        !
+        ! The WRF executable (wrf.exe) expects perturbation potential
+        !   temperature.  However, real.exe expects full potential T.
+        ! So, if the program is WRF, subtract 300 from Potential Temperature 
+        !   to get perturbation potential temperature.
+        !
+        if (VarName == 'T') then
+           if ( &
+                (InputProgramName .eq. 'REAL_EM') .or. &
+                (InputProgramName .eq. 'IDEAL') .or. &
+                (InputProgramName .eq. 'NDOWN_EM')) then
+              gfld%fld = gfld%fld - 300
+           endif
+        endif
+
+
+        if (ndims .eq. 1) then
+           CALL Transpose1D(MemoryOrder, di, FieldType, Field, &
+                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+                MemoryStart(3), MemoryEnd(3), &
+                gfld%fld, zsize)
+        else
+           CALL Transpose(MemoryOrder, di, FieldType, Field, &
+                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+                MemoryStart(3), MemoryEnd(3), &
+                gfld%fld, dim3, ysize,xsize)
+        endif
+!        CALL Transpose_new(MemoryOrder, di, FieldType, Field, &
+!             MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+!             MemoryStart(3), MemoryEnd(3), &
+!             gfld%fld, dim1size,dim2size,dim3)
+        
+        call gf_free(gfld)
+        
+     enddo VERTDIM
+  endif
+
+  Status = WRF_NO_ERR
+
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr2_read_field')
+
+  RETURN
+END SUBROUTINE ext_gr2_read_field
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_next_var ( DataHandle, VarName, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: VarName
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_var')
+
+  Status = WRF_WARN_NOOP
+
+  RETURN
+END SUBROUTINE ext_gr2_get_next_var
+
+!*****************************************************************************
+
+subroutine ext_gr2_end_of_frame(DataHandle, Status)
+
+  USE gr2_data_info
+  implicit none
+#include "wrf_status_codes.h"
+  integer               ,intent(in)     :: DataHandle
+  integer               ,intent(out)    :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_end_of_frame')
+
+  Status = WRF_WARN_NOOP
+
+  return
+end subroutine ext_gr2_end_of_frame
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_iosync ( DataHandle, Status )
+
+  USE gr2_data_info  
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  integer                     :: ierror
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_iosync')
+
+  Status = WRF_NO_ERR
+  if (DataHandle .GT. 0) then
+     CALL flush_file(fileinfo(DataHandle)%FileFd)
+  else
+     Status = WRF_WARN_TOO_MANY_FILES
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_iosync
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_inquire_filename ( DataHandle, FileName , FileStat, &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStat
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER *80   SysDepInfo
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_filename')
+
+  FileName = fileinfo(DataHandle)%DataFile 
+
+  if ((DataHandle .ge. firstFileHandle) .and. &
+       (DataHandle .le. maxFileHandles)) then
+     FileStat = fileinfo(DataHandle)%FileStatus
+  else
+     FileStat = WRF_FILE_NOT_OPENED
+  endif
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr2_inquire_filename
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_info ( DataHandle , VarName , NDim , &
+     MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: VarName
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)         ,intent(out)    :: Stagger
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_info')
+
+  MemoryOrder = ""
+  Stagger = ""
+  DomainStart(1) = 0
+  DomainEnd(1) = 0
+  WrfType = 0
+  NDim = 0
+
+  CALL wrf_message('ext_gr2_get_var_info not supported for grib version2 data')
+  Status = WRF_NO_ERR
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_info
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_set_time ( DataHandle, DateStr, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  integer       :: found_time
+  integer       :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_set_time')
+
+  found_time = 0
+  do idx = 1,fileinfo(DataHandle)%NumberTimes
+     if (fileinfo(DataHandle)%Times(idx) == DateStr) then
+        found_time = 1
+        fileinfo(DataHandle)%CurrentTime = idx
+     endif
+  enddo
+  if (found_time == 0) then 
+     Status = WRF_WARN_TIME_NF
+  else
+     Status = WRF_NO_ERR
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_set_time
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_next_time ( DataHandle, DateStr, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(OUT) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_time')
+
+  if (fileinfo(DataHandle)%CurrentTime == fileinfo(DataHandle)%NumberTimes) then
+     Status = WRF_WARN_TIME_EOF
+  else
+     fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime + 1
+     DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
+     Status = WRF_NO_ERR
+  endif
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr2_get_next_time, got time '//DateStr)
+
+  RETURN
+END SUBROUTINE ext_gr2_get_next_time
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_previous_time ( DataHandle, DateStr, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_previous_time')
+
+  if (fileinfo(DataHandle)%CurrentTime <= 0) then
+     Status = WRF_WARN_TIME_EOF
+  else
+     fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime - 1
+     DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
+     Status = WRF_NO_ERR
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_get_previous_time
+
+!******************************************************************************
+!* Start of get_var_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_real ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(OUT)   :: Data(*)
+  INTEGER ,       INTENT(IN)    :: Count
+  INTEGER ,       INTENT(OUT)   :: OutCount
+  INTEGER ,       INTENT(OUT)   :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER(len=100)  :: Value
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)      :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(OUT)     :: Data(*)
+  INTEGER ,       INTENT(IN)      :: Count
+  INTEGER ,       INTENT(OUT)     :: OutCount
+  INTEGER ,       INTENT(OUT)     :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(100)  :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_double ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(100)  :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_integer ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)       :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(OUT)      :: Data(*)
+  INTEGER ,       INTENT(IN)       :: Count
+  INTEGER ,       INTENT(OUT)      :: OutCount
+  INTEGER ,       INTENT(OUT)      :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_logical ( DataHandle,Element,  Varname, Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)       :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(OUT)      :: Data(*)
+  INTEGER ,       INTENT(IN)       :: Count
+  INTEGER ,       INTENT(OUT)      :: OutCount
+  INTEGER ,       INTENT(OUT)      :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(100) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_ti_char ( DataHandle,Element,  Varname, Data,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_char')
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(Element), Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_ti_char 
+
+!******************************************************************************
+!* End of get_var_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_var_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_real ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_double ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_double')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_ti_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real8')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_integer ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_integer')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_logical ( DataHandle,Element,  Varname, Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_logical')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(Varname)//';'//trim(Element), tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr2_put_var_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_ti_char ( DataHandle,Element,  Varname, Data,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER(len=*) :: Element
+  CHARACTER(len=*) :: VarName 
+  CHARACTER(len=*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  INTEGER                     :: Count
+  CHARACTER(len=1000) :: tmpstr(1)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_char')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     write(tmpstr(1),*)trim(Data)
+
+     CALL gr2_build_string (ti_output(DataHandle), &
+          trim(VarName)//';'//trim(Element), tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_ti_char 
+
+!******************************************************************************
+!* End of put_var_ti_* routines
+!******************************************************************************
+
+!******************************************************************************
+!* Start of get_var_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_double ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count, Outcount, Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: DateStr
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+RETURN
+END SUBROUTINE ext_gr2_get_var_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_real ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count, Outcount, Status )
+  
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_var_td_char ( DataHandle,Element,  DateStr,Varname, &
+     Data,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_char')
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_get_var_td_char 
+
+!******************************************************************************
+!* End of get_var_td_* routines
+!******************************************************************************
+
+!******************************************************************************
+!* Start of put_var_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_double ( DataHandle, Element, DateStr, Varname, &
+     Data, Count,  Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  CHARACTER*(*) , INTENT(IN)  :: DateStr
+  CHARACTER*(*) , INTENT(IN)  :: VarName
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_double')
+
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr2_put_var_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_integer ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_integer')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr2_put_var_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_real ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
+     Data, Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real8')
+
+  if (fileinfo(DataHandle)%committed) then
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, Count, Status)
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_logical ( DataHandle,Element,  DateStr, &
+     Varname, Data, Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_logical')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_var_td_char ( DataHandle,Element,  DateStr,Varname, &
+     Data,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_char')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     write(tmpstr(idx),*)Data
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
+          tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_var_td_char 
+
+!******************************************************************************
+!* End of put_var_td_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of get_dom_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_real ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Outcount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real')
+
+  Status = WRF_NO_ERR
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_real8 ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_integer ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_integer Element: '//Element)
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = Count
+ 
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_logical ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+  INTEGER       :: endchar
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_char')
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_ti_double ( DataHandle,Element,   Data, Count, &
+     Outcount, Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_double')
+
+  Status = WRF_NO_ERR
+   
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+ 
+RETURN
+END SUBROUTINE ext_gr2_get_dom_ti_double
+
+!******************************************************************************
+!* End of get_dom_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_dom_ti_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_real ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr(1000)
+  character(len=2)    :: lf
+  integer             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real')
+
+  if (Element .eq. 'DX') then
+     dx = Data(1)/1000.
+  endif
+  if (Element .eq. 'DY') then
+     dy = Data(1)/1000.
+  endif
+  if (Element .eq. 'CEN_LAT') then
+     center_lat = Data(1)
+  endif
+  if (Element .eq. 'CEN_LON') then
+     center_lon = Data(1)
+  endif  
+  if (Element .eq. 'TRUELAT1') then
+     truelat1 = Data(1)
+  endif
+  if (Element .eq. 'TRUELAT2') then
+     truelat2 = Data(1)
+  endif
+  if (Element == 'STAND_LON') then
+     proj_central_lon = Data(1)
+  endif
+  if (Element == 'DT') then
+     timestep = Data(1)
+  endif
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_real8 ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real8')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  INTEGER ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_integer')
+
+  if (Element == 'WEST-EAST_GRID_DIMENSION') then
+     full_xsize = Data(1)
+  else if (Element == 'SOUTH-NORTH_GRID_DIMENSION') then
+     full_ysize = Data(1)
+  else if (Element == 'MAP_PROJ') then
+     wrf_projection = Data(1)
+  else if (Element == 'BACKGROUND_PROC_ID') then
+     background_proc_id = Data(1)
+  else if (Element == 'FORECAST_PROC_ID') then
+     forecast_proc_id = Data(1)
+  else if (Element == 'PRODUCTION_STATUS') then
+     production_status = Data(1)
+  else if (Element == 'COMPRESSION') then
+     compression = Data(1)
+  endif
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, Count, Status)
+
+  endif
+
+  call wrf_debug ( DEBUG , 'Leaving ext_gr2_put_dom_ti_integer')
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_logical')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_char ( DataHandle,Element,   Data,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*),     INTENT(IN)  :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  CHARACTER(len=1000) :: tmpstr
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_char')
+
+  if (Element .eq. 'START_DATE') then
+
+     !
+     ! This is just a hack to fix a problem when outputting restart.  WRF
+     !   outputs both the initialization time and the time of the restart 
+     !   as the StartDate.  So, we ll just take the earliest.
+     !
+     if ((StartDate .eq. '') .or. (Data .le. StartDate)) then
+        StartDate = Data
+     endif
+
+  endif
+
+  if (fileinfo(DataHandle)%committed) then
+
+     write(tmpstr,*)trim(Data)
+     
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, 1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_char
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_ti_double ( DataHandle,Element, Data, Count, &
+     Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) , INTENT(IN)  :: Element
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_double')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (ti_output(DataHandle), Element, &
+          tmpstr, Count, Status)
+
+  endif
+  
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_ti_double
+
+!******************************************************************************
+!* End of put_dom_ti_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of get_dom_td_* routines
+!******************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_real ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_td_real 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,        INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real8')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_integer')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_td_integer 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,       INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_logical')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_td_logical 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER       :: stat
+
+  Status = WRF_NO_ERR
+  
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_char')
+
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Data, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_get_dom_td_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_get_dom_td_double ( DataHandle,Element, DateStr,  Data, &
+     Count, Outcount, Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  INTEGER          :: idx
+  INTEGER          :: stat
+  CHARACTER*(1000) :: VALUE
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_double')
+
+  Status = WRF_NO_ERR
+  
+  CALL gr2_get_metadata_value(global_input(DataHandle), &
+       trim(DateStr)//';'//trim(Element), Value, stat)
+  if (stat /= 0) then
+     CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
+     Status = WRF_WARN_VAR_NF
+     RETURN
+  endif
+
+  READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
+  if (stat .ne. 0) then
+     CALL wrf_message("Reading data from"//Value//"failed")
+     Status = WRF_WARN_COUNT_TOO_LONG
+     RETURN
+  endif
+  Outcount = idx
+
+RETURN
+END SUBROUTINE ext_gr2_get_dom_td_double
+
+!******************************************************************************
+!* End of get_dom_td_* routines
+!******************************************************************************
+
+
+!******************************************************************************
+!* Start of put_dom_td_* routines
+!******************************************************************************
+
+
+SUBROUTINE ext_gr2_put_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,        INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real8')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_td_real8 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_integer')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_td_integer
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,       INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_logical')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_td_logical
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_td_char ( DataHandle,Element, DateStr,  Data, &
+     Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER(len=*), INTENT(IN)  :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1)
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_char')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     write(tmpstr(1),*)Data
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          1, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_td_char 
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_td_double ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  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
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_double')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          Count, Status)
+
+  endif
+
+RETURN
+END SUBROUTINE ext_gr2_put_dom_td_double
+
+!*****************************************************************************
+
+SUBROUTINE ext_gr2_put_dom_td_real ( DataHandle,Element, DateStr,  Data, &
+     Count,  Status )
+
+  USE gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,          INTENT(IN)  :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER(len=1000) :: tmpstr(1000)
+  INTEGER             :: idx
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real')
+
+  if (fileinfo(DataHandle)%committed) then
+
+     do idx = 1,Count
+        write(tmpstr(idx),'(G17.10)')Data(idx)
+     enddo
+     
+     CALL gr2_build_string (td_output(DataHandle), &
+          trim(DateStr)//';'//trim(Element), tmpstr, &
+          Count, Status)
+
+  endif
+
+  RETURN
+END SUBROUTINE ext_gr2_put_dom_td_real 
+
+
+!******************************************************************************
+!* End of put_dom_td_* routines
+!******************************************************************************
+
+
+SUBROUTINE gr2_get_new_handle(DataHandle)
+  USE gr2_data_info
+  IMPLICIT NONE
+  
+  INTEGER ,       INTENT(OUT)  :: DataHandle
+  INTEGER :: i
+
+  DataHandle = -1
+  do i=firstFileHandle, maxFileHandles
+     if (.NOT. fileinfo(i)%used) then
+        DataHandle = i
+        fileinfo(i)%used = .true.
+        exit
+     endif
+  enddo
+
+  RETURN
+END SUBROUTINE gr2_get_new_handle
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!*****************************************************************************
+
+SUBROUTINE gr2_retrieve_data (MemoryOrder, MemoryStart, MemoryEnd, xsize, ysize, &
+     zsize, z, FieldType, Field, data)
+  
+  IMPLICIT NONE
+
+#include "wrf_io_flags.h"
+
+  character*(*)                 ,intent(in)    :: MemoryOrder
+  integer                       ,intent(in)    :: xsize, ysize, zsize
+  integer                       ,intent(in)    :: z
+  integer,dimension(*)          ,intent(in)    :: MemoryStart, MemoryEnd
+  integer                       ,intent(in)    :: FieldType
+  real                          ,intent(in),       &
+       dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
+       MemoryStart(2):MemoryEnd(2), &
+       MemoryStart(3):MemoryEnd(3) )           :: Field
+  real   ,dimension(1:xsize,1:ysize),intent(inout) :: data
+
+  integer                                      :: x, y, idx
+  integer, dimension(:,:),   pointer           :: mold
+  integer                                      :: istat
+  integer                                      :: dim1
+  
+  ALLOCATE(mold(1:xsize,1:ysize), STAT=istat)
+  if (istat .ne. 0) then
+     print *,'Could not allocate space for mold, returning'
+     return
+  endif
+
+  !
+  ! Set the size of the first dimension of the data array (dim1) to xsize.  
+  !    If the MemoryOrder is Z or z, dim1 is overridden below.
+  !
+  dim1 = xsize
+
+  SELECT CASE (MemoryOrder)
+  CASE ('XYZ')
+     data = Field(1,1:xsize,1:ysize,z)
+  CASE ('C')
+     data = Field(1,1:xsize,1:ysize,z)
+  CASE ('XZY')
+     data = Field(1,1:xsize,z,1:ysize)
+  CASE ('YXZ')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,x,z)
+        enddo
+     enddo
+  CASE ('YZX')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,z,x)
+        enddo
+     enddo
+  CASE ('ZXY')
+     data = Field(1,z,1:xsize,1:ysize)
+  CASE ('ZYX')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,z,y,x)
+        enddo
+     enddo
+  CASE ('XY')
+     data = Field(1,1:xsize,1:ysize,1)
+  CASE ('YX')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,x,1)
+        enddo
+     enddo
+     
+  CASE ('XSZ')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,z,x)
+        enddo
+     enddo
+  CASE ('XEZ')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,z,x)
+        enddo
+     enddo
+  CASE ('YSZ')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,x,z,y)
+        enddo
+     enddo
+  CASE ('YEZ')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,x,z,y)
+        enddo
+     enddo
+     
+  CASE ('XS')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,x,1)
+        enddo
+     enddo
+  CASE ('XE')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,y,x,1)
+        enddo
+     enddo
+  CASE ('YS')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,x,y,1)
+        enddo
+     enddo
+  CASE ('YE')
+     do x = 1,xsize
+        do y = 1,ysize
+           data(x,y) = Field(1,x,y,1)
+        enddo
+     enddo
+  CASE ('Z')
+     data(1:zsize,1) = Field(1,1:zsize,1,1)
+     dim1 = zsize
+  CASE ('z')
+     data(1:zsize,1) = Field(1,zsize:1,1,1)
+     dim1 = zsize
+  CASE ('0')
+     data(1,1) = Field(1,1,1,1)
+  END SELECT
+  
+  ! 
+  ! Here, we convert any integer fields to real
+  !
+  if (FieldType == WRF_INTEGER) then
+     mold = 0
+     do idx=1,dim1
+        !
+        ! The parentheses around data(idx,:) are needed in order
+        !   to fix a bug with transfer with the xlf compiler on NCARs
+        !   IBM (bluesky).
+        !
+        data(idx,:)=transfer((data(idx,:)),mold)
+     enddo
+  endif
+
+  deallocate(mold)
+  
+  return
+
+end subroutine gr2_retrieve_data
+
+!*****************************************************************************
+
+SUBROUTINE gr2_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, &
+     fraction, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
+     level1, level2)
+
+  use gr2_data_info
+  IMPLICIT NONE
+
+  integer :: zidx
+  integer :: zsize
+  logical :: soil_layers
+  logical :: vert_stag
+  logical :: fraction
+  integer :: vert_unit1, vert_unit2
+  integer :: vert_sclFctr1, vert_sclFctr2
+  integer :: level1
+  integer :: level2
+  character (LEN=*) :: VarName
+
+  ! Setup vert_unit, and vertical levels in grib units
+
+  if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCTOP') &
+       .or. (VarName .eq. 'SOILCBOT')) then
+     vert_unit1 = 105;
+     vert_unit2 = 255;
+     vert_sclFctr1 = 0
+     vert_sclFctr2 = 0
+     level1 = zidx
+     level2 = 0
+  else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) &
+       then
+     vert_unit1 = 111;
+     vert_unit2 = 255;
+     vert_sclFctr1 = 4
+     vert_sclFctr2 = 4
+     if (vert_stag) then
+        level1 = (10000*full_eta(zidx)+0.5)
+     else
+        level1 = (10000*half_eta(zidx)+0.5)
+     endif
+     level2 = 0
+  else
+     ! Set the vertical coordinate and level for soil and 2D fields
+     if (fraction) then
+        vert_unit1 = 105
+        vert_unit2 = 255
+        level1 = zidx
+        level2 = 0
+        vert_sclFctr1 = 0
+        vert_sclFctr2 = 0
+     else if (soil_layers) then
+        vert_unit1 = 106
+        vert_unit2 = 106
+        level1 = 100*(soil_depth(zidx) - 0.5*soil_thickness(zidx))+0.5
+        level2 = 100*(soil_depth(zidx) + 0.5*soil_thickness(zidx))+0.5
+        vert_sclFctr1 = 2
+        vert_sclFctr2 = 2
+     else if (VarName .eq. 'mu') then
+        vert_unit1 = 105
+        vert_unit2 = 255
+        level1 = 0
+        level2 = 0
+        vert_sclFctr1 = 0
+        vert_sclFctr2 = 0
+     else if ((VarName .eq. 'Q2') .or. (VarName .eq. 'TH2') .or. &
+        (VarName .eq. 'T2')) then
+        vert_unit1 = 103
+        vert_unit2 = 255
+        level1 = 2
+        level2 = 0
+        vert_sclFctr1 = 0
+        vert_sclFctr2 = 0
+     else if ((VarName .eq. 'Q10') .or. (VarName .eq. 'TH10') .or. &
+          (VarName .eq. 'U10') .or. (VarName .eq. 'V10')) then
+        vert_unit1 = 103
+        vert_unit2 = 255
+        level1 = 10
+        level2 = 0
+        vert_sclFctr1 = 0
+        vert_sclFctr2 = 0
+     else 
+        vert_unit1 = 1
+        vert_unit2 = 255
+        level1 = 0
+        level2 = 0
+        vert_sclFctr1 = 0
+        vert_sclFctr2 = 0
+     endif
+  endif
+
+end SUBROUTINE gr2_get_levels
+
+!*****************************************************************************
+
+subroutine gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
+     center, subcenter, MasterTblV, LocalTblV, ierr, msg)
+
+  implicit none
+
+  character*24 ,intent(in)     :: StartDate
+  character*(*),intent(inout)  :: cgrib
+  integer      ,intent(in)     :: lcgrib
+  integer      ,intent(in)     :: production_status
+  integer      ,intent(out)    :: ierr
+  character*(*),intent(out)    :: msg
+  integer , dimension(13)      :: listsec1
+  integer , dimension(2)       :: listsec0
+  integer                      :: slen
+  integer , intent(in)         :: Disc, center, subcenter, MasterTblV, LocalTblV
+
+  ! 
+  ! Create the grib message
+  !
+  listsec0(1) = Disc       ! Discipline (Table 0.0)
+  listsec0(2) = 2          ! Grib edition number
+
+  listsec1(1) = center     ! Id of Originating Center (255 for missing)
+  listsec1(2) = subcenter  ! Id of originating sub-center (255 for missing)
+  listsec1(3) = MasterTblV ! Master Table Version #
+  listsec1(4) = LocalTblV  ! Local table version #
+  listsec1(5) = 1          ! Significance of reference time, 1 indicates start of forecast
+
+  READ(StartDate(1:4),  '(I4)') listsec1(6) ! Year of reference
+
+  READ(StartDate(6:7),  '(I2)') listsec1(7) ! Month of reference
+
+  READ(StartDate(9:10), '(I2)') listsec1(8) ! Day of reference
+
+  slen = LEN(StartDate)
+
+  if (slen.GE.13) then
+     read(StartDate(12:13),'(I2)') listsec1(9)
+  else
+     listsec1(9) = 0
+  endif
+
+  if (slen.GE.16) then
+     read(StartDate(15:16),'(I2)') listsec1(10)
+  else
+     listsec1(10) = 0
+  endif
+
+  if (slen.GE.19) then
+     read(StartDate(18:19),'(I2)') listsec1(11)
+  else
+     listsec1(11) = 0
+  end if
+
+  listsec1(12) = production_status  ! Production status of data
+  listsec1(13) = 1     ! Type of data (1 indicates forecast products)
+
+  call gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
+
+  if (ierr .ne. 0) then
+     write(msg,*) 'gribcreate failed with ierr: ',ierr
+  else
+     msg = ''
+  endif
+  
+end SUBROUTINE gr2_create_w
+
+
+!*****************************************************************************
+subroutine gr2_addgrid_w(cgrib, lcgrib, central_lat, central_lon, wrf_projection, &
+     latin1, latin2, nx, ny, dx, dy, center_lat, center_lon, ierr,msg)
+  
+  implicit none
+
+  character*(*)            ,intent(inout)   :: cgrib
+  integer                  ,intent(in)      :: lcgrib
+  real                     ,intent(in)      :: central_lat
+  real                     ,intent(in)      :: central_lon
+  integer                  ,intent(in)      :: wrf_projection
+  real                     ,intent(in)      :: latin1
+  real                     ,intent(in)      :: latin2
+  integer                  ,intent(in)      :: nx
+  integer                  ,intent(in)      :: ny
+  real                     ,intent(in)      :: dx
+  real                     ,intent(in)      :: dy
+  real                     ,intent(in)      :: center_lat
+  real                     ,intent(in)      :: center_lon
+  integer                  ,intent(out)     :: ierr
+  character*(*)            ,intent(out)     :: msg
+  integer, dimension(5)                     :: igds
+  integer, parameter                        :: igdstmplen = 25
+  integer, dimension(igdstmplen)            :: igdstmpl
+  integer, parameter                        :: idefnum = 0
+  integer, dimension(idefnum)               :: ideflist
+  real                                      :: LLLa, LLLo, URLa, URLo
+  real                                      :: incrx, incry
+  real, parameter                           :: deg_to_microdeg = 1e6
+  real, parameter                           :: km_to_mm = 1e6
+  real, parameter                           :: km_to_m = 1e3
+  real, parameter                           :: PI = 3.141593
+  real, parameter                           :: DEG_TO_RAD = PI/180
+  real, parameter                           :: RAD_TO_DEG = 180/PI
+  real, parameter                           :: ERADIUS = 6370.0
+
+  igds(1) = 0      ! Source of grid definition
+  igds(2) = nx*ny  ! Number of points in grid
+  igds(3) = 0      ! 
+  igds(4) = 0
+
+  ! Here, setup the parameters that are common to all WRF projections
+
+  igdstmpl(1) = 1       ! Shape of earth (1 for spherical with specified radius)
+  igdstmpl(2) = 1       ! Scale factor for earth radius
+  igdstmpl(3) = ERADIUS*km_to_m ! Radius of earth
+  igdstmpl(4) = 0       ! Scale factor for major axis
+  igdstmpl(5) = 0       ! Major axis
+  igdstmpl(6) = 0       ! Scale factor for minor axis
+  igdstmpl(7) = 0       ! Minor axis
+  igdstmpl(8) = nx      ! Number of points along x axis
+  igdstmpl(9) = ny      ! Number of points along y axis
+  
+  !
+  ! Setup increments in "x" and "y" direction.  For LATLON projection
+  !   increments need to be in degrees.  For all other projections, 
+  !   increments are in km.
+  !
+
+  if (wrf_projection .eq. WRF_LATLON) then
+     incrx = RAD_TO_DEG*(dx/(ERADIUS*cos(latin1*DEG_TO_RAD)))
+     incry = RAD_TO_DEG*(dy/ERADIUS)
+  else
+     incrx = dx
+     incry = dy
+  endif
+
+  ! Latitude and longitude of first (i.e., lower left) grid point
+  call get_ll_latlon(central_lat, central_lon, wrf_projection, &
+       latin1, latin2, nx, ny, incrx, incry, center_lat, center_lon, &
+       LLLa, LLLo, URLa, URLo, ierr);
+
+  select case (wrf_projection)
+
+  case(WRF_LATLON)
+     igds(5) = 0
+     igdstmpl(10) = 0    ! Basic Angle of init projection (not important to us)
+     igdstmpl(11) = 0    ! Subdivision of basic angle
+     igdstmpl(12) = LLLa*deg_to_microdeg
+     igdstmpl(13) = LLLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(13))
+     igdstmpl(14) = 128  ! Resolution and component flags
+     igdstmpl(15) = URLa*deg_to_microdeg
+     igdstmpl(16) = URLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(16))
+
+     ! Warning, the following assumes that dx and dy are valid at the equator.
+     !    It is not clear in WRF where dx and dy are valid for latlon projections
+     igdstmpl(17) = incrx*deg_to_microdeg ! i-direction increment in micro degs
+     igdstmpl(18) = incry*deg_to_microdeg ! j-direction increment in micro degs
+
+     igdstmpl(19) = 64   ! Scanning mode
+  case(WRF_MERCATOR)
+     igds(5) = 10
+     igdstmpl(10) = LLLa*deg_to_microdeg
+     igdstmpl(11) = LLLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(11))
+     igdstmpl(12) = 128  ! Resolution and component flags
+     igdstmpl(13) = latin1*deg_to_microdeg  ! "True" latitude
+     igdstmpl(14) = URLa*deg_to_microdeg
+     igdstmpl(15) = URLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(15))
+     igdstmpl(16) = 64   ! Scanning mode
+     igdstmpl(17) = 0    ! Orientation of grid between i-direction and equator
+     igdstmpl(18) = dx*km_to_mm   ! i-direction increment
+     igdstmpl(19) = dy*km_to_mm   ! j-direction increment
+  case(WRF_LAMBERT)
+     igds(5) = 30
+     
+     igdstmpl(10) = LLLa*deg_to_microdeg
+     igdstmpl(11) = LLLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(11))
+     igdstmpl(12) = 128 ! Resolution and component flag
+     igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
+     igdstmpl(14) = central_lon*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(14))
+     igdstmpl(15) = dx*km_to_mm  ! x-dimension grid-spacing  in units of m^-3
+     igdstmpl(16) = dy*km_to_mm
+     if (center_lat .lt. 0) then
+        igdstmpl(17) = 1
+     else
+        igdstmpl(17) = 0
+     endif
+     igdstmpl(18) = 64   ! Scanning mode
+     igdstmpl(19) = latin1*deg_to_microdeg
+     igdstmpl(20) = latin2*deg_to_microdeg
+     igdstmpl(21) = -90*deg_to_microdeg
+     igdstmpl(22) = central_lon*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(22))
+
+  case(WRF_POLAR_STEREO)
+     igds(5) = 20
+     igdstmpl(10) = LLLa*deg_to_microdeg
+     igdstmpl(11) = LLLo*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(11))
+     igdstmpl(12) = 128 ! Resolution and component flag
+     igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
+     igdstmpl(14) = central_lon*deg_to_microdeg
+     call gr2_convert_lon(igdstmpl(14))
+     igdstmpl(15) = dx*km_to_mm  ! x-dimension grid-spacing  in units of m^-3
+     igdstmpl(16) = dy*km_to_mm
+     if (center_lat .lt. 0) then
+        igdstmpl(17) = 1
+     else
+        igdstmpl(17) = 0
+     endif
+     igdstmpl(18) = 64   ! Scanning mode
+
+  case default
+     write(msg,*) 'invalid WRF projection: ',wrf_projection
+     ierr = -1
+     return
+  end select
+
+
+  call addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,ideflist,idefnum,ierr)
+  if (ierr .ne. 0) then
+     write(msg,*) 'addgrid failed with ierr: ',ierr
+  else
+     msg = ''
+  endif
+
+end subroutine gr2_addgrid_w
+
+!*****************************************************************************
+
+subroutine gr2_addfield_w(cgrib, lcgrib, VarName, parmcat, parmnum, DecScl, &
+     BinScl, fcst_secs, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
+     numlevels, levels, ngrdpts, background_proc_id, forecast_proc_id, &
+     compression, fld, ierr, msg)
+  
+  implicit none
+
+  character*(*)            ,intent(inout)   :: cgrib
+  integer                  ,intent(in)      :: lcgrib
+  character (LEN=*)        ,intent(in)      :: VarName
+  integer                  ,intent(in)      :: parmcat,parmnum,DecScl,BinScl
+  real                     ,intent(in)      :: fcst_secs
+  integer                  ,intent(in)      :: vert_unit1, vert_unit2
+  integer                  ,intent(in)      :: vert_sclFctr1, vert_sclFctr2
+  integer                  ,intent(in)      :: numlevels
+  integer, dimension(*)    ,intent(in)      :: levels
+  integer                  ,intent(in)      :: ngrdpts
+  real                     ,intent(in)      :: fld(ngrdpts)
+  integer                  ,intent(in)      :: background_proc_id
+  integer                  ,intent(in)      :: forecast_proc_id
+  integer                  ,intent(in)      :: compression
+  integer                  ,intent(out)     :: ierr
+  character*(*)            ,intent(out)     :: msg
+  integer                                   :: ipdsnum
+  integer, parameter                        :: ipdstmplen = 15
+  integer, dimension(ipdstmplen)            :: ipdstmpl
+  integer                                   :: numcoord
+  integer, dimension(numlevels)             :: coordlist
+  integer                                   :: idrsnum
+  integer, parameter                        :: idrstmplen = 7
+  integer, dimension(idrstmplen)            :: idrstmpl
+  integer                                   :: ibmap
+  integer, dimension(1)                     :: bmap
+
+  if (numlevels .gt. 2) then
+     ipdsnum = 1000           ! Product definition tmplate (1000 for cross-sxn)
+  else
+     ipdsnum = 0              ! Product definition template (0 for horiz grid)
+  endif
+
+  ipdstmpl(1) = parmcat    ! Parameter category
+  ipdstmpl(2) = parmnum    ! Parameter number
+  ipdstmpl(3) = 2          ! Type of generating process (2 for forecast)
+  ipdstmpl(4) = background_proc_id ! Background generating process id
+  ipdstmpl(5) = forecast_proc_id   ! Analysis or forecast generating process id
+  ipdstmpl(6) = 0          ! Data cutoff period (Hours)
+  ipdstmpl(7) = 0          ! Data cutoff period (minutes)
+  ipdstmpl(8) = 13         ! Time range indicator (13 for seconds)
+  ipdstmpl(9) = NINT(fcst_secs) ! Forecast time
+
+  if (ipdsnum .eq. 1000) then
+     numcoord = numlevels
+     coordlist = levels(1:numlevels)
+
+     !
+     ! Set Data Representation templ (Use 0 for vertical cross sections,
+     !    since there seems to be a bug in g2lib for JPEG2000 and PNG)
+     !
+     idrsnum = 0
+
+  else if (ipdsnum .eq. 0) then
+     ipdstmpl(10) = vert_unit1    ! Type of first surface (111 for Eta level)
+     ipdstmpl(11) = vert_sclFctr1 ! Scale factor for 1st surface
+     ipdstmpl(12) = levels(1)     ! First fixed surface
+     ipdstmpl(13) = vert_unit2    ! Type of second fixed surface
+     ipdstmpl(14) = vert_sclFctr2 ! Scale factor for 2nd surface
+     if (numlevels .eq. 2) then 
+        ipdstmpl(15) = levels(2)
+     else
+        ipdstmpl(15) = 0
+     endif
+     numcoord = 0
+     coordlist(1) = 0
+
+     ! Set Data Representation templ (40 for JPEG2000, 41 for PNG)  
+     idrsnum = compression
+
+  endif
+
+
+  if (idrsnum == 40) then    ! JPEG 2000
+
+     idrstmpl(1) = 255       ! Reference value - ignored on input
+     idrstmpl(2) = BinScl    ! Binary scale factor
+     idrstmpl(3) = DecScl    ! Decimal scale factor 
+     idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
+     idrstmpl(5) = 0         ! Original field type - ignored on input
+     idrstmpl(6) = 0         ! 0 for lossless compression
+     idrstmpl(7) = 255       ! Desired compression ratio if idrstmpl(6) != 0
+
+  else if (idrsnum == 41) then ! PNG
+
+     idrstmpl(1) = 255       ! Reference value - ignored on input
+     idrstmpl(2) = BinScl    ! Binary scale factor
+     idrstmpl(3) = DecScl    ! Decimal scale factor 
+     idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
+     idrstmpl(5) = 0         ! Original field type - ignored on input
+
+  else if (idrsnum == 0) then! Simple packing 
+
+     idrstmpl(1) = 255       ! Reference value - ignored on input
+     idrstmpl(2) = BinScl    ! Binary scale factor
+     idrstmpl(3) = DecScl    ! Decimal scale factor 
+     idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
+     idrstmpl(5) = 0         ! Original field type - ignored on input
+     
+  else
+     
+     write (msg,*) 'addfield failed because Data Representation template',&
+          idrsnum,' is invalid'
+     ierr = 1
+     return
+
+  endif
+
+  ibmap = 255                ! Flag for bitmap
+  
+  call addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, coordlist,      &
+       numcoord, idrsnum, idrstmpl, idrstmplen, fld, ngrdpts, ibmap,          &
+       bmap, ierr)
+
+  if (ierr .ne. 0) then
+     write(msg,*) 'addfield failed with ierr: ',ierr
+  else
+     msg = ''
+  endif
+
+end subroutine gr2_addfield_w
+
+!*****************************************************************************
+
+subroutine gr2_fill_local_use(DataHandle,string,VarName,fcsts,msg,status)
+
+  use gr2_data_info
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+
+  integer,         intent(in)    :: DataHandle
+  character*(*)   ,intent(inout) :: string
+  character*(*)   ,intent(in)    :: VarName
+  integer                        :: center, subcenter, MasterTblV, LocalTblV, &
+       Disc, Category, ParmNum, DecScl, BinScl
+  integer         ,intent(out)   :: status
+  character*(*)   ,intent(out)   :: msg
+  integer , parameter            :: lcgrib = 1000000
+  character (lcgrib)             :: cgrib
+  real, dimension(1,1)           :: data
+  integer                        :: lengrib
+  integer                        :: lcsec2
+  integer                        :: fcsts
+  integer                        :: bytes_written
+  
+  ! 
+  ! Set data to a default dummy value.
+  !
+  data = 1.0
+
+  !
+  ! This statement prevents problems when calling addlocal in the grib2
+  !   library.  Basically, if addlocal is called with an empty string, it
+  !   will be encoded correctly by the grib2 routine, but the grib2 routines
+  !   that read the data (i.e., getgb2) will segfault.  This prevents that 
+  !   segfault.
+  !
+
+  if (string .eq. '') string = 'none'
+
+  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+  if (status .ne. 0) then
+     write(msg,*) 'Could not find parameter for '//   &
+          trim(VarName)//'   Skipping output of '//trim(VarName)
+     call wrf_message(trim(msg))
+     Status =  WRF_GRIB2_ERR_GRIB2MAP
+     return
+  endif
+
+  !
+  ! Create the indicator and identification sections (sections 0 and 1)
+  !
+  CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
+             center, subcenter, MasterTblV, LocalTblV, status, msg)
+  if (status .ne. 0) then
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_GRIBCREATE
+     return
+  endif
+
+  ! 
+  ! Add the local use section
+  !
+  lcsec2 = len_trim(string)
+  call addlocal(cgrib,lcgrib,string,lcsec2,status)
+  if (status .ne. 0) then
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_ADDLOCAL
+     return
+  endif
+
+  !
+  ! Add the grid definition section (section 3) using a 1x1 grid
+  !
+  call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon,  &
+       wrf_projection, truelat1, truelat2, 1, 1, dx, dy,       &
+       center_lat, center_lon, status, msg)
+  if (status .ne. 0) then
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_ADDGRIB
+     return
+  endif
+
+  !
+  ! Add the Product Definition, Data representation, bitmap 
+  !      and data sections (sections 4-7)
+  !
+  call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, DecScl, &
+       BinScl, fcsts, 1, 255, 0, 0, 1, 0, 1, &
+       background_proc_id, forecast_proc_id, compression, data, status, msg)
+  if (status .ne. 0) then
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_ADDFIELD
+     return
+  endif
+
+  !
+  ! Close out the message
+  !
+  
+  call gribend(cgrib,lcgrib,lengrib,status)
+  if (status .ne. 0) then
+     write(msg,*) 'gribend failed with status: ',status     
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_GRIBEND
+     return
+  endif
+
+  ! 
+  ! Write the data to the file
+  !
+  
+  call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
+!!  call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, status)
+  if (bytes_written .ne. lengrib) then
+     write(msg,*) '2 Error writing cgrib to file, wrote: ', &
+          bytes_written, ' bytes.  Tried to write ', lengrib, ' bytes'
+     call wrf_message(trim(msg))
+     Status = WRF_GRIB2_ERR_WRITE
+     return
+  endif
+
+  ! Set string back to the original blank value
+  if (string .eq. '') string = ''
+
+  return
+
+end subroutine gr2_fill_local_use
+
+!*****************************************************************************
+!
+! Set longitude to be in the range of 0-360 degrees.
+!
+!*****************************************************************************
+
+subroutine gr2_convert_lon(value)
+
+  IMPLICIT NONE
+
+  integer, intent(inout) :: value
+  real, parameter                           :: deg_to_microdeg = 1e6
+
+  do while (value .lt. 0) 
+     value = value + 360*deg_to_microdeg
+  enddo
+
+  do while (value .gt. 360*deg_to_microdeg) 
+     value = value - 360*deg_to_microdeg
+  enddo
+
+end subroutine gr2_convert_lon
+
+
+!*****************************************************************************
+!
+! Add a time to the list of times
+!
+!*****************************************************************************
+
+subroutine gr2_add_time(DataHandle,addTime)
+
+  USE gr2_data_info
+  IMPLICIT NONE
+
+  integer           :: DataHandle
+  character (len=*) :: addTime
+  integer           :: idx
+  logical           :: already_have = .false.
+  logical           :: swap
+  character (len=len(addTime)) :: tmp
+  character (DateStrLen), dimension(:),pointer  :: tmpTimes(:)
+  integer,parameter :: allsize = 50
+  integer           :: ierr
+  
+  already_have = .false.
+  do idx = 1,fileinfo(DataHandle)%NumberTimes 
+     if (addTime .eq. fileinfo(DataHandle)%Times(idx)) then
+        already_have = .true.
+     endif
+  enddo
+  
+  if (.not. already_have) then
+     fileinfo(DataHandle)%NumberTimes = fileinfo(DataHandle)%NumberTimes + 1
+
+     if (fileinfo(DataHandle)%NumberTimes .gt. &
+          fileinfo(DataHandle)%sizeAllocated) then
+
+        if (fileinfo(DataHandle)%NumberTimes .eq. 1) then
+
+           if (allocated(fileinfo(DataHandle)%Times)) &
+                deallocate(fileinfo(DataHandle)%Times)
+
+           allocate(fileinfo(DataHandle)%Times(allsize), stat = ierr)
+           if (ierr .ne. 0) then
+              call wrf_message('Could not allocate space for Times 1, exiting')
+              stop
+           endif
+
+           fileinfo(DataHandle)%sizeAllocated = allsize
+
+        else
+
+           allocate(tmpTimes(fileinfo(DataHandle)%NumberTimes), stat=ierr)
+
+           tmpTimes = &
+                fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes)
+
+           deallocate(fileinfo(DataHandle)%Times)
+
+           allocate(&
+                fileinfo(DataHandle)%Times(fileinfo(DataHandle)%sizeAllocated+allsize), stat=ierr)
+
+           if (ierr .ne. 0) then
+              call wrf_message('Could not allocate space for Times 2, exiting')
+              stop
+           endif
+
+           fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes) = &
+                tmpTimes
+
+           deallocate(tmpTimes)
+           
+        endif
+        
+     endif
+
+     fileinfo(DataHandle)%Times(fileinfo(DataHandle)%NumberTimes) = addTime
+  
+     ! Sort the Times array
+
+     swap = .true.
+     do while (swap)
+        swap = .false.
+        do idx = 1,fileinfo(DataHandle)%NumberTimes - 1
+           if (fileinfo(DataHandle)%Times(idx) .gt. fileinfo(DataHandle)%Times(idx+1)) then
+              tmp = fileinfo(DataHandle)%Times(idx)
+              fileinfo(DataHandle)%Times(idx) = fileinfo(DataHandle)%Times(idx+1)
+              fileinfo(DataHandle)%Times(idx+1) = tmp
+              swap = .true.
+           endif
+        enddo
+     enddo
+
+  endif
+
+  return
+
+end subroutine gr2_add_time
+
+
+!*****************************************************************************
+!
+! Fill an array of levels
+!
+!*****************************************************************************
+
+subroutine gr2_fill_levels(DataHandle,VarName,levels,ierr)
+
+  USE gr2_data_info
+  USE grib_mod
+  IMPLICIT NONE
+
+#include "wrf_status_codes.h"
+
+
+  integer            :: DataHandle
+  character (len=*)  :: VarName
+  REAL,DIMENSION(*)  :: levels
+  integer            :: ierr
+  integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
+       JGDT(JGDTSIZE)
+  type(gribfield)    :: gfld
+  integer            :: status, fields_to_skip
+  logical            :: unpack
+  integer            :: center, subcenter, MasterTblV, LocalTblV, &
+       Disc, Category, ParmNum, DecScl, BinScl
+  CHARACTER (LEN=maxMsgSize) :: msg
+
+
+  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
+       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
+  if (status .ne. 0) then
+     write(msg,*) 'Could not find parameter for '//   &
+          trim(VarName)//'   Skipping output of '//trim(VarName)
+     call wrf_message(trim(msg))
+     ierr = -1
+     return
+  endif
+
+
+  !
+  ! First, set all values to wild, then specify necessary values
+  !
+  call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
+
+  JIDS(1) = center
+  JIDS(2) = subcenter
+  JIDS(3) = MasterTblV
+  JIDS(4) = LocalTblV
+  JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
+  JIDS(13) = 1          ! Type of processed data (1 for forecast products)
+  
+  JPDTN = 1000          ! Product definition template number
+  JPDT(1) = Category
+  JPDT(2) = ParmNum
+  JPDT(3) = 2           ! Generating process id
+
+  JGDTN    = -1         ! Indicates that any Grid Display Template is a match
+  
+  UNPACK   = .TRUE.     ! Unpack bitmap and data values
+
+
+  fields_to_skip = 0
+
+  CALL GETGB2(DataHandle, 0, fields_to_skip, -1, Disc, JIDS, JPDTN, &
+       JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
+       gfld, status)
+  if (status .eq. 99) then
+     write(msg,*)'Could not find field '//trim(VarName)//&
+          ' continuing.'
+     call wrf_message(trim(msg))
+     ierr = -1
+     return
+  else if (status .ne. 0) then
+     write(msg,*)'Retrieving scalar data field '//trim(VarName)//&
+          ' failed, continuing.'
+     call wrf_message(trim(msg))
+     ierr = -1
+     return
+  endif
+  
+  levels(1:gfld%ndpts) = gfld%fld(1:gfld%ndpts)
+  ierr = 0
+  
+end subroutine gr2_fill_levels
+
+
+!*****************************************************************************
+!
+! Set values for search array arguments for getgb2 to missing.
+!
+!*****************************************************************************
+
+subroutine gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
+
+  USE gr2_data_info
+  integer :: JIDS(*), JPDT(*), JGDT(*)
+
+  do idx = 1,JIDSSIZE
+     JIDS(idx) = -9999
+  enddo
+  
+  do idx=1,JPDTSIZE
+     JPDT(idx) = -9999
+  enddo
+  
+  do idx = 1,JGDTSIZE
+     JGDT(idx) = -9999
+  enddo
+
+  return
+
+end subroutine gr2_g2lib_wildcard
+!*****************************************************************************
+!
+! Retrieve a metadata value from the input string
+!
+!*****************************************************************************
+
+subroutine gr2_get_metadata_value(instring, Key, Value, stat)
+  character(len=*),intent(in)  :: instring
+  character(len=*),intent(in)  :: Key
+  character(len=*),intent(out) :: Value
+  integer         ,intent(out) :: stat
+  integer :: Key_pos, equals_pos, line_end
+  character :: lf
+
+  lf=char(10)
+
+  Value = 'abc'
+
+  !
+  ! Find Starting position of Key
+  !
+  Key_pos = index(instring, lf//' '//Key//' =')
+  if (Key_pos .eq. 0) then
+     stat = -1
+     return
+  endif
+
+  !
+  ! Find position of the "=" after the Key
+  !
+  equals_pos = index(instring(Key_pos:len(instring)), "=") + Key_pos
+  if (equals_pos .eq. Key_pos) then
+     stat = -1
+     return
+  endif
+
+  !
+  ! Find end of line
+  !
+  line_end = index(instring(equals_pos:len(instring)), lf) + equals_pos
+
+  !
+  ! Handle the case for the last line in the string
+  !
+  if (line_end .eq. equals_pos) then
+     line_end = len(trim(instring))
+  endif
+
+  !
+  ! Set value
+  !
+  if ( (equals_pos + 1) .le. (line_end - 2) ) then
+     Value = trim(adjustl(instring(equals_pos+1:line_end-2)))
+  else
+     Value = ""
+  endif
+  
+  stat = 0
+  
+
+end subroutine gr2_get_metadata_value
+
+!*****************************************************************************
+!
+! Build onto a metadata string with the input value
+!
+!*****************************************************************************
+
+SUBROUTINE gr2_build_string (string, Element, Value, Count, Status)
+
+  IMPLICIT NONE
+#include "wrf_status_codes.h"
+
+  CHARACTER (LEN=*) , INTENT(INOUT) :: string
+  CHARACTER (LEN=*) , INTENT(IN)    :: Element
+  CHARACTER (LEN=*) , INTENT(IN)    :: Value(*)
+  INTEGER ,           INTENT(IN)    :: Count
+  INTEGER ,           INTENT(OUT)   :: Status
+
+  CHARACTER (LEN=2)                 :: lf
+  INTEGER                           :: IDX
+
+  lf=char(10)//' '
+
+  if (index(string,lf//Element//' =') .gt. 0) then
+     ! We do nothing, since we dont want to add the same variable twice.
+  else 
+     if (len_trim(string) == 0) then
+        string = lf//Element//' = '
+     else
+        string = trim(string)//lf//Element//' = '
+     endif
+     do idx = 1,Count
+        if (idx > 1) then
+           string = trim(string)//','
+        endif
+        string = trim(string)//' '//trim(adjustl(Value(idx)))
+     enddo
+  endif
+
+  Status = WRF_NO_ERR
+
+END SUBROUTINE gr2_build_string
+
diff --git a/wrfv2_fire/external/io_grib2/read_grib2map.F b/wrfv2_fire/external/io_grib2/read_grib2map.F
new file mode 100644
index 00000000..9c3db7c7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/read_grib2map.F
@@ -0,0 +1,444 @@
+!*****************************************************************************
+!
+! Routine to fill a grib2map structure (linked list).
+!
+!*****************************************************************************
+
+subroutine load_grib2map(filename, msg, ierr)
+
+  USE grib2tbls_types
+  Implicit None
+
+  character*(*), intent(in)                   :: filename
+  character*(*), intent(inout)                :: msg
+  integer      , intent(out)                  :: ierr
+  integer                                     :: status = 0
+  integer                                     :: fileunit
+  logical                                     :: foundunit
+  character*(maxLineSize)                     :: line
+  integer                                     :: firstval
+  integer                                     :: numtables = 0
+  character*(1)                               :: delim
+  integer                                     :: lastpos
+  integer                                     :: pos
+  integer                                     :: idx
+  integer                                     :: end
+  logical                                     :: lerr
+
+  ! Open the file
+
+  ! First pass:
+  !  Scan the file to determine how many tables are included, and how many
+  !     entries are in each table.
+  !
+
+  ! Find an open fileunit
+  foundunit = .false.
+  do fileunit = 10,100 
+     inquire(unit=fileunit,opened=lerr)
+     if (lerr .eqv. .false.) then
+        foundunit = .true.
+        exit
+     endif
+  enddo
+  if (foundunit .neqv. .true.) then
+     write(msg, *)'Could not find unit to open ',filename
+     ierr = -1
+     return
+  endif
+
+  ! Open the file
+  open ( unit = fileunit, file=filename, status = 'old', iostat = status)
+  if (status .ne. 0) then
+     write(msg, *)'Could not open file ',filename
+     ierr = -1
+     return
+  endif
+
+  ! Loop through each line to count the number of tables and entries in 
+  !   each table.
+  
+  READLINE: do
+     !
+     ! Read the line, skip line if line is comment, blank or invalid
+     !
+     read(fileunit,'(A)',iostat=status) line
+     line = adjustl(line)
+     if (status .lt. 0) then
+        exit
+     endif
+     if (len_trim(line) .eq. 0) then
+        cycle READLINE
+     endif
+     if (line(1:1) .eq. '#') then
+        cycle READLINE
+     endif
+
+     !
+     ! Read the first value in the line
+     !
+     read(line,*,iostat=status) firstval
+     if (status .ne. 0) then
+        print *,'Skipping Invalid line in',trim(filename),':'
+        print *,'''',trim(line),''''
+        cycle READLINE
+     endif
+
+
+     ! 
+     ! If the first value is -1, weve found a new table.  Allocate
+     !    a new member in the linked list, and add the information
+     !    to that member
+     !
+     if (firstval .eq. -1) then
+        numtables = numtables + 1
+
+        !
+        ! Create and allocate the next member of the linked list
+        !
+        if (.NOT. ASSOCIATED(TblHead)) THEN
+           ALLOCATE (TblHead, stat=status)
+           if (status .ne. 0) then
+              print *,'Could not allocate space for TblHead'
+              exit READLINE
+           endif
+           TblTail => TblHead
+        else
+           ALLOCATE (TblTail%next, STAT=status)
+           if (status .ne. 0) then
+              print *,'Could not allocate space for TblTail%next, continuing'
+              cycle READLINE
+           endif
+           TblTail%previous => TblTail
+           TblTail => TblTail%next
+        endif
+        nullify(TblTail%next)
+        nullify(TblTail%ParmHead)
+        
+        !
+        ! Parse the header line
+        !
+        lastpos = 0
+        do idx = 1,5
+           pos = index(line(lastpos+1:maxLineSize), "|")
+
+           if (pos .lt. 0) then
+              print *,'Found invalid header line: '
+              print *,'''',trim(line),''''
+              if (associated(TblTail%previous)) then
+                 TblTail => TblTail%previous
+              else
+                 nullify(TblTail)
+              endif
+              cycle READLINE
+           endif
+
+           SELECT CASE (idx)
+           CASE (1)
+              ! Do nothing, since this is just the indicator value
+           CASE (2)
+              read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%center
+              if (status .ne. 0) then
+                 print *,'Found invalid header line: '
+                 print *,'''',trim(line),''''
+                 cycle READLINE
+              endif
+           CASE (3)
+              read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%subcenter
+              if (status .ne. 0) then
+                 print *,'Found invalid header line: '
+                 print *,'''',trim(line),''''
+                 cycle READLINE
+              endif
+           CASE (4)
+              read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%MasterTblV
+              if (status .ne. 0) then
+                 print *,'Found invalid header line: '
+                 print *,'''',trim(line),''''
+                 cycle READLINE
+              endif
+           CASE (5)
+              read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%LocalTblV
+              if (status .ne. 0) then
+                 print *,'Found invalid header line: '
+                 print *,'''',trim(line),''''
+                 cycle READLINE
+              endif
+           END SELECT
+
+           lastpos = lastpos+pos
+
+        enddo
+
+#ifdef TEST
+! Test
+        print *,'Header Line: '
+        print *,TblTail%center, TblTail%subcenter, TblTail%MasterTblV, &
+              TblTail%LocalTblV
+#endif
+
+
+        !
+        ! We found the header, cycle so that the header is not interpereted
+        !   as a parameter line.
+        !
+        cycle READLINE
+
+     endif
+
+     if (.NOT. ASSOCIATED(TblTail%ParmHead)) then
+        ALLOCATE (TblTail%ParmHead, stat=status)
+        if (status .ne. 0) then
+           print *,'Could not allocate space for TblTail%ParmHead, continuing'
+           cycle READLINE
+        endif
+        TblTail%ParmTail => TblTail%ParmHead
+     else
+        ALLOCATE (TblTail%ParmTail%next, STAT=status)
+        if (status .ne. 0) then
+           print *,'Could not allocate space for TblTail%ParmTail%next, continuing'
+           cycle READLINE
+        endif
+        TblTail%ParmTail%previous => TblTail%ParmTail
+        TblTail%ParmTail => TblTail%ParmTail%next
+     endif
+     nullify(TblTail%ParmTail%next)
+
+     !
+     ! Parse the Parameter line
+     !
+     lastpos = 0
+     do idx = 1,7
+        pos = index(line(lastpos+1:maxLineSize), "|")
+        
+        if (pos .lt. 0) then
+           print *,'Found invalid header line: '
+           print *,'''',trim(line),''''
+           if (associated(TblTail%previous)) then
+              TblTail => TblTail%previous
+           else
+              nullify(TblTail)
+           endif
+           cycle READLINE
+        endif
+        
+        SELECT CASE (idx)
+        CASE (1)
+           read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Disc
+           if (status .ne. 0) then
+              print *,'Found invalid line: '
+              print *,'''',trim(line),''''
+              cycle READLINE
+           endif
+        CASE (2)
+           read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Category
+           if (status .ne. 0) then
+              print *,'Found invalid line: '
+              print *,'''',trim(line),''''
+              cycle READLINE
+           endif
+        CASE (3)
+           read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%ParmNum
+           if (status .ne. 0) then
+              print *,'Found invalid line: '
+              print *,'''',trim(line),''''
+              cycle READLINE
+           endif
+        CASE (4)
+           TblTail%ParmTail%WRFNameString = &
+                trim(adjustl(line(lastpos+1:lastpos+pos-1)))
+        CASE (5)
+           TblTail%ParmTail%Description = &
+                trim(adjustl(line(lastpos+1:lastpos+pos-1)))
+        CASE (6)
+           read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%DecScl
+           if (status .ne. 0) then
+              print *,'Found invalid line: '
+              print *,'''',trim(line),''''
+              cycle READLINE
+           endif
+        CASE (7)
+           read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%BinScl
+           if (status .ne. 0) then
+              print *,'Found invalid line: '
+              print *,'''',trim(line),''''
+              cycle READLINE
+           endif
+        END SELECT
+        
+        lastpos = lastpos+pos
+        
+     enddo
+      
+#ifdef TEST
+! Test Code
+     delim = '|'
+     write(6,'(I4,A1,I4,A1,I4,A1,A12,A1,A42,A1,I4,A1,I4,A1)')          &
+          TblTail%ParmTail%Disc,        delim,                         &
+          TblTail%ParmTail%Category,    delim,                         &
+          TblTail%ParmTail%ParmNum,     delim,                         &
+          trim(TblTail%ParmTail%WRFNameString), delim,                 &
+          trim(TblTail%ParmTail%Description), delim,                   &
+          TblTail%ParmTail%DecScl,      delim,                         &
+          TblTail%ParmTail%BinScl,      delim
+#endif
+
+     !
+     ! Parse the WRFNameString
+     !
+     status = 0
+     lastpos = 0
+     idx = 1
+     do while (pos .gt. 0) 
+        pos = index(TblTail%ParmTail%WRFNameString(lastpos+1:maxLineSize), ",")
+        if (pos .le. 0) then
+           end = lastpos+maxLineSize
+        else
+           end = lastpos+pos-1
+        endif
+        read(TblTail%ParmTail%WRFNameString(lastpos+1:end),*) &
+             TblTail%ParmTail%WRFNames(idx)
+        lastpos = lastpos + pos
+        idx = idx + 1
+     enddo
+     TblTail%ParmTail%numWRFNames = idx-1
+
+#ifdef TEST
+     write(6,*)'WRFNames: ',&
+          (trim(TblTail%ParmTail%WRFNames(idx)),' ', &
+          idx=1,TblTail%ParmTail%numWRFNames)
+#endif
+
+  enddo READLINE
+
+  close ( unit = fileunit)
+
+end subroutine load_grib2map
+
+!*****************************************************************************
+!
+! Routine to find and return the grib2 information associated with a WRF 
+!    parameter.
+!
+!*****************************************************************************
+
+subroutine get_parminfo(parmname, center, subcenter, MasterTblV, &
+     LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, ierr)
+  
+  USE grib2tbls_types
+  Implicit None
+
+  character*(*),intent(in)  :: parmname
+  integer     ,intent(out)  :: center, subcenter, MasterTblV, LocalTblV, &
+       Disc, Category, ParmNum, DecScl, BinScl
+  TYPE (grib2Entries_type), pointer            :: ParmPtr
+  TYPE (grib2tbls_type) , pointer              :: TblPtr
+  integer                                      :: idx
+  logical                                      :: found
+  integer                                      :: ierr
+
+
+  !
+  ! Loop through tables
+  !
+
+  found = .false.
+  TblPtr => TblHead
+  TABLE : DO
+
+     if ( .not. associated(TblPtr)) then
+        exit TABLE
+     endif
+
+     !
+     ! Loop through parameters
+     !
+     ParmPtr => TblPtr%ParmHead
+
+     PARAMETER : DO 
+
+        if ( .not. associated(ParmPtr)) then
+           exit PARAMETER
+        endif
+
+        ! 
+        ! Loop through WRF parameter names for the table parameter entry
+        !
+        WRFNAME : do idx = 1,ParmPtr%numWRFNames
+           if (parmname .eq. ParmPtr%WRFNames(idx)) then
+              found = .true.
+              exit TABLE
+           endif
+        enddo WRFNAME
+
+        ParmPtr => ParmPtr%next
+
+     ENDDO PARAMETER
+
+     TblPtr => TblPtr%next
+  ENDDO TABLE
+
+  if (found) then
+     center     = TblPtr%center
+     subcenter  = TblPtr%subcenter
+     MasterTblV = TblPtr%MasterTblV
+     LocalTblV  = TblPtr%LocalTblV
+     Disc       = ParmPtr%Disc
+     Category   = ParmPtr%Category
+     ParmNum    = ParmPtr%ParmNum
+     DecScl     = ParmPtr%DecScl
+     BinScl     = ParmPtr%BinScl
+     ierr       = 0
+  else
+     ierr       = 1
+  endif
+
+end subroutine get_parminfo
+
+!*****************************************************************************
+!
+! Routine to free the lists.
+!
+!*****************************************************************************
+
+subroutine free_grib2map()
+  USE grib2tbls_types
+  Implicit None
+
+  TYPE (grib2Entries_type), pointer            :: ParmPtr
+  TYPE (grib2Entries_type), pointer            :: ParmSave
+  TYPE (grib2tbls_type) , pointer              :: TblPtr
+  TYPE (grib2tbls_type) , pointer              :: TblSave
+
+  TblPtr => TblHead
+  TABLE : DO
+
+     if ( .not. associated(TblPtr)) then
+        exit TABLE
+     endif
+
+     !
+     ! Loop through parameters
+     !
+     ParmPtr => TblPtr%ParmHead
+
+     PARAMETER : DO 
+
+        if ( .not. associated(ParmPtr)) then
+           exit PARAMETER
+        endif
+
+        ParmSave => ParmPtr%next
+        deallocate(ParmPtr)
+        ParmPtr => ParmSave
+
+     ENDDO PARAMETER
+
+     
+     TblSave => TblPtr%next
+     deallocate(TblPtr)
+     TblPtr => TblSave
+
+  ENDDO TABLE
+
+end subroutine free_grib2map
diff --git a/wrfv2_fire/external/io_grib2/test_read_grib2map.F b/wrfv2_fire/external/io_grib2/test_read_grib2map.F
new file mode 100644
index 00000000..05d5fb8b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib2/test_read_grib2map.F
@@ -0,0 +1,46 @@
+PROGRAM test_read_grib2map
+
+  USE grib2tbls_types
+  Implicit None
+
+  INTERFACE
+     Subroutine load_grib2map (filename, grib2tbls)
+       USE grib2tbls_types
+       character*(*), intent(in)                   :: filename
+       TYPE(grib2tbls_type), dimension(:), pointer :: grib2tbls
+     END subroutine load_grib2map
+  END INTERFACE
+
+  TYPE(grib2tbls_type), dimension(:), pointer :: grib2tbls
+  character(200)                              :: filename = 'grib2map.tbl'
+
+  character*30              :: parmname
+  integer                   :: center, subcenter, MasterTblV, LocalTblV, &
+       Disc, Category, ParmNum, DecScl, BinScl
+  integer                   :: ierr
+
+
+  CALL load_grib2map(filename,grib2tbls)
+
+  parmname = 'T2'
+  CALL get_parminfo(parmname, center, subcenter, MasterTblV, &
+     LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, ierr)
+
+  if (ierr .ne. 0) then
+     print *,'Could not find match for parameter: ',parmname
+  else
+     print *,'Found match: '
+     print *, '  center:    ',center
+     print *, '  subcenter: ',subcenter
+     print *, '  MasterTblV ',MasterTblV
+     print *, '  LocalTblV  ',LocalTblV
+     print *, '  Disc       ',Disc
+     print *, '  Category   ',Category
+     print *, '  ParmNum    ',ParmNum
+     print *, '  DecScl     ',DecScl
+     print *, '  BinScl     ',BinScl
+  endif
+  
+  CALL free_grib2map(grib2tbls)
+
+END PROGRAM
diff --git a/wrfv2_fire/external/io_grib_share/Makefile b/wrfv2_fire/external/io_grib_share/Makefile
new file mode 100644
index 00000000..2b44f389
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/Makefile
@@ -0,0 +1,87 @@
+#------------------------------------------------------------------------------
+#  Makefile for producing libdbclient.so 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+
+.SUFFIXES:      .c .o
+
+#
+# Specity location for Makefiles that are included.
+#
+INCLUDEDIRS = -I.
+BUILD_DIR = $(IO_GRIB_SHARE_DIR)./build
+#
+# Specify directory that output library is to be put in.
+#
+LIB_DEST = .
+#
+#  SPECIFY local include directories used during compilation of source code. 
+#
+#    CXX_INCLUDES is for C++ files
+#    C_INCLUDES is for C files
+#
+C_INCLUDES   = -I.
+CXX_INCLUDES = -I.
+F_INCLUDES   = -I.
+ARFLAGS      = cruv
+
+FORMAT = $(FREE)
+
+#
+#  SPECIFY any subdirectories containing libraries that may be dynamically
+#          linked by this library.
+#
+SUB_DIRS =
+
+#
+#  SPECIFY information for building a library:
+#
+#    LIB_NAME - Fragment of name of the library to build
+#               e.g. if library file name is libfoo.so, set LIB_NAME = foo 
+#    DEP_LIBS - The tokens required to link a shared library against other
+#               shared libraries upon which it depends.  DEP_LIBS should
+#               contain -L tokens to specify where the dependent 
+#               libraries are, and -l tokens to specify libraries to link.
+#    OBJS     - List of object files that go into the library.
+#
+#  NOTES:
+#  1. Be careful about whitespace after the last character in the LIB_NAME.
+#     These spaces will generate an error when the library is made.
+#
+LIB_NAME = io_grib_share
+SYS_DEFINES =
+DEP_LIBS = 
+OBJS =  \
+	io_grib_share.o \
+	get_region_center.o \
+	gridnav.o \
+	open_file.o
+
+#
+#  List of subdirectories to which to pass make commands.
+#
+LIB_DIRS = 
+EXE_DIRS =
+SUB_DIRS = $(LIB_DIRS) $(EXE_DIRS)
+
+#
+#  Clean up old build files
+#
+superclean:
+	/bin/rm -f *.o > /dev/null 2>&1
+	/bin/rm -f *.f90 > /dev/null 2>&1
+	/bin/rm -f *.mod > /dev/null 2>&1
+	/bin/rm -f *.a > /dev/null 2>&1
+
+
+#
+#  Include the boilerplate rules for building library modules.
+#
+include $(BUILD_DIR)/library_rules.mk
+
+#
+#  Compile dependencies.  These are appended to this file by make depend. 
+#
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib_share/TEST_RESULTS b/wrfv2_fire/external/io_grib_share/TEST_RESULTS
new file mode 100644
index 00000000..88f4f1fc
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/TEST_RESULTS
@@ -0,0 +1,134 @@
+file TEST_RESULTS
+Tom Henderson
+
+A series of tests were run on AIX and OSF1 machines prior to committing 
+Todd Hutchinson's grib1 and grib2 packages to the repository.  These are 
+described in detail below.  
+
+In addition, Todd ran many tests on his Linux systems, including a pass 
+through vgrind for memory checking.  
+
+
+NOTE ONE KNOWN BUG:  
+  RUC LSM fails in lsmrucinit() when grib1 input is used (divide-by-zero 
+  error).  Not sure if this is due to compression (accuracy -- sure hope 
+  not!) or due to some mis-configuration of gribmap.txt, or something 
+  else.  
+
+
++------------------+
+| TEST DEFINITIONS |
++------------------+
+ALL TESTS were run with the jan00 test case using default settings from 
+test/em_real/namelist.input.jan01 unless otherwise indicated below.  
+
+TESTan:  Read netCDF, write netCDF, 1 MPI task
+TESTbn:  Read netCDF, write netCDF, 4 MPI tasks
+TESTcn:  Read netCDF, write netCDF bitwise identical, 1 vs. 4 MPI tasks
+TESTdn:  Write netCDF from real
+TESTqn:  Read netCDF, write netCDF, 4 MPI tasks + 2 MPI quilt tasks
+TESTrn:  TESTqn wrfout file vs. TESTan, bitwise identical
+TESTa1:  Read netCDF, write grib1, 1 MPI task
+TESTb1:  Read netCDF, write grib1, 4 MPI tasks
+TESTc1:  Read netCDF, write grib1 bitwise identical, 1 vs. 4 MPI tasks
+TESTd1:  Write grib1 from real
+TESTe1:  Read grib1, write netCDF, 1 MPI task
+TESTf1:  Read grib1, write netCDF, 4 MPI tasks
+TESTg1:  Read grib1, write netCDF bitwise identical, 1 vs. 4 MPI tasks 
+TESTh1:  TESTe1 wrfout file vs. TESTan, bitwise identical
+TESTq1:  Read netCDF, write grib1, 4 MPI tasks + 2 MPI quilt tasks
+TESTr1:  TESTq1 wrfout file vs. TESTa1, bitwise identical
+TESTa2:  Read netCDF, write grib2, 1 MPI task
+TESTb2:  Read netCDF, write grib2, 4 MPI tasks
+TESTc2:  Read netCDF, write grib2 bitwise identical, 1 vs. 4 MPI tasks
+TESTd2:  Write grib2 from real
+TESTe2:  Read grib2, write netCDF, 1 MPI task
+TESTf2:  Read grib2, write netCDF, 4 MPI tasks
+TESTg2:  Read grib2, write netCDF bitwise identical, 1 vs. 4 MPI tasks
+TESTh2:  TESTe2 wrfout file vs. TESTan, bitwise identical
+TESTq2:  Read netCDF, write grib2, 4 MPI tasks + 2 MPI quilt tasks
+TESTr2:  TESTq2 wrfout file vs. TESTa2, bitwise identical
+TESTab:  Read netCDF, write binary, 1 MPI task
+TESTbb:  Read netCDF, write binary, 4 MPI tasks
+TESTcb:  Read netCDF, write binary bitwise identical, 1 vs. 4 MPI tasks
+TESTdb:  Write binary from real
+TESTeb:  Read binary, write netCDF, 1 MPI task
+TESTfb:  Read binary, write netCDF, 4 MPI tasks
+TESTgb:  Read binary, write netCDF bitwise identical, 1 vs. 4 MPI tasks
+TESThb:  TESTeb wrfout file vs. TESTan, bitwise identical
+TESTib:  Read binary, write binary, 4 MPI tasks
+TESTjb:  TESTbb wrfout file vs. TESTib, bitwise identical
+TESTqb:  Read netCDF, write binary, 4 MPI tasks + 2 MPI quilt tasks
+TESTrb:  TESTqb wrfout file vs. TESTab, bitwise identical
+
+
++-------------------+
+| TEST RESULT TABLE |
++-------------------+
+TEST RESULT TABLE KEYS:  
+Tested Configurations:
+  v6j  bluevista, config=3, OBJECT_MODE=64,  built with    jasper
+  v6   bluevista, config=3, OBJECT_MODE=64,  built without jasper
+  s3j  bluesky,   config=3, OBJECT_MODE=32,  built with    jasper
+  s3   bluesky,   config=3, OBJECT_MODE=32,  built without jasper
+  s6j  bluesky,   config=3, OBJECT_MODE=64,  built with    jasper
+  j    joshua,    config=5, no optimization, built without jasper
+Test Results:
+  'P'  PASS
+  'P1' PASS, but see note "1"
+  'F'  FAIL
+  'X'  Skip test.  (For example, grib2 tests cannot be done without jasper).  
+  ' '  To Be Done
++------------------------------------------+---+---+---+---+---+---+
+| VERSION:   trunk_r1718_WORK       Config |v6j|v6 |s3j|s3 |s6j| j |
++------------------------------------------+---+---+---+---+---+---+
+| TESTan:  RnetCDF WnetCDF 1 MPI           | P | P | P | P | P | P |
+| TESTbn:  RnetCDF WnetCDF 4 MPI           | P | P | P | P | P | P |
+| TESTcn:  RnetCDF WnetCDF 1 vs. 4 MPI     | P | P | P | P | P | P |
+| TESTdn:  WnetCDF from real               | P | P | P | P | P | P |
+| TESTqn:  RnetCDF WnetCDF 4 MPI + 2 quilt | P | P | P | P | P | P |
+| TESTrn:  TESTan vs. TESTqn               | P | P | P | P | P | P |
+| TESTa1:  RnetCDF Wgrib1 1 MPI            | P | P | P | P | P | P |
+| TESTb1:  RnetCDF Wgrib1 4 MPI            | P | P | P | P | P | P |
+| TESTc1:  RnetCDF Wgrib1 1 vs. 4 MPI      | P | P | P | P | P | P |
+| TESTd1:  Wgrib1 from real                | P | P | P | P | P | P |
+| TESTe1:  Rgrib1 WnetCDF 1 MPI            | P | P | P | P | P | P |
+| TESTf1:  Rgrib1 WnetCDF 4 MPI            | P | P | P | P | P | P |
+| TESTg1:  Rgrib1 WnetCDF 1 vs. 4 MPI      | P | P | P | P | P | P |
+| TESTh1:  TESTe1 vs. all-netCDF           | P*| P*| P*| P*| P*|   |
+| TESTq1:  RnetCDF Wgrib1 4 MPI + 2 quilt  | P | P | P | P | P | P |
+| TESTr1:  TESTa1 vs. TESTq1               | P1| P1| P1| P1| P1| P1|
+| TESTa2:  RnetCDF Wgrib2 1 MPI            | P | X | P | X | P | X |
+| TESTb2:  RnetCDF Wgrib2 4 MPI            | P | X | P | X | P | X |
+| TESTc2:  RnetCDF Wgrib2 1 vs. 4 MPI      | P | X | P | X | P | X |
+| TESTd2:  Wgrib2 from real                | P | X | P | X | P | X |
+| TESTe2:  Rgrib2 WnetCDF 1 MPI            | P | X | P | X | P | X |
+| TESTf2:  Rgrib2 WnetCDF 4 MPI            | P | X | P | X | P | X |
+| TESTg2:  Rgrib2 WnetCDF 1 vs. 4 MPI      | P | X | P | X | P | X |
+| TESTh2:  TESTe2 vs. all-netCDF           |   | X |   | X |   | X |
+| TESTq2:  RnetCDF Wgrib2 4 MPI + 2 quilt  | P | X | P | X | P | X |
+| TESTr2:  TESTa2 vs. TESTq2               | P3| X | P3| X | P3| X |
+| TESTab:  RnetCDF Wbinary 1 MPI           | P | P | P | P | P | P |
+| TESTbb:  RnetCDF Wbinary 4 MPI           | P | P | P | P | P | P |
+| TESTcb:  RnetCDF Wbinary 1 vs. 4 MPI     | P | P | P | P | P | P2|
+| TESTdb:  Wbinary from real               | P | P | P | P | P | P |
+| TESTeb:  Rbinary WnetCDF 1 MPI           | P | P | P | P | P | P |
+| TESTfb:  Rbinary WnetCDF 4 MPI           | P | P | P | P | P | P |
+| TESTgb:  Rbinary WnetCDF 1 vs. 4 MPI     | P | P | P | P | P | P |
+| TESThb:  TESTeb vs. all-netCDF           | P | P | P | P | P | P |
+| TESTib:  Rbinary Wbinary 4 MPI           | P | P | P | P | P | P |
+| TESTjb:  TESTbb vs. TESTib               | P2| P2| P2| P2| P2| P2|
+| TESTqb:  RnetCDF Wbinary 4 MPI + 2 quilt | P | P | P | P | P | P |
+| TESTrb:  TESTab vs. TESTqb               | P2| P2| P2| P2| P2| P2|
++------------------------------------------+---+---+---+---+---+---+
+| NOTES:                                                       |
+|   * Jimy says this looks OK but someone should compare       |
+|     plots...                                                 |
+|   1 For TESTr1, some bytes differ but                        |
+|     external/io_grib1/diffwrf says files match.              |
+|   2 For TESTjb and TESTrb, some bytes differ but             |
+|     external/io_int/diffwrf says files match.                |
+|   3 For TESTr2, some bytes differ, need to test with grib2   |
+|     version of diffwrf.                                      |
++--------------------------------------------------------------+
+
diff --git a/wrfv2_fire/external/io_grib_share/build/application_rules.mk b/wrfv2_fire/external/io_grib_share/build/application_rules.mk
new file mode 100644
index 00000000..b095910a
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/application_rules.mk
@@ -0,0 +1,74 @@
+#------------------------------------------------------------------------------
+#  Make rules for building an application program.
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/application_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for building one or more applications programs.
+#  Each APPNAME is comprised of the same object files. 
+# 
+all: exe config
+
+exe: $(OBJS) 
+	@for p in $(APPNAMES); do \
+		echo "Building application program $$p..." ; \
+		$(LDD) $(DEBUG) $(OPTIMIZE) $(APP_DEFS) -o $$p $(OBJS) $(DEP_LIBS) ;\
+		mv -f $$p $(BIN_DEST) ;\
+	done
+
+#
+#  Include the RULES for compilation and installation of config files.
+#
+include $(BUILD_DIR)/compile_rules.mk
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULE for building a library
+#
+#  For exe modules, these do nothing, but we define one so that make lib 
+#  can be passed down to all source directories.
+#
+lib:
+	@echo "make lib does nothing for application modules"
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes all objects produced by this file, as well as other 
+#      extraneous artifacts of compiling and building applications.
+# 
+#      A subsequent make will both recompile the source code and recreate
+#      the executable.  clean also removes files core files and other
+#      auxilliary files created during compilation.
+#
+#  'clean_exe' removes application programs.
+#
+clean: 
+	@/bin/rm -f *.o core so_locations Makefile.bak *~ #*#
+	@/bin/rm -fr ii_files
+
+clean_exe:
+	@/bin/rm -f $(BIN_DEST)/$(APP_NAME)
+
+#
+#  RULES for creating the include dependencies.
+#
+include $(BUILD_DIR)/depend_rules.mk
+
+clean_depend: generic_clean_depend
+
+depend: generic_depend
+
diff --git a/wrfv2_fire/external/io_grib_share/build/binary_rules.mk b/wrfv2_fire/external/io_grib_share/build/binary_rules.mk
new file mode 100644
index 00000000..f97b9773
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/binary_rules.mk
@@ -0,0 +1,122 @@
+#------------------------------------------------------------------------------
+#  Make rules for installing binary files to a specified destination
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/binary_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for binary files:
+#
+#      all, binary, utest, exe, clean, clean_lib, clean_exe,
+#      clean_depend, depend.
+#
+#  Copyright (C) 2002, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for installing scripts and script modules 
+#
+#    EXE_SRC specifies a list of files that contain executable scripts.
+#    Each file in the list will be installed in the $(BIN_DEST) directory
+#    and will be given executable permissions.  If the variable EXE_EXT is
+#    set, this extension will be stripped from the end of the source file
+#    when it is installed, e.g. if EXE_SRC = "foo.pl" and EXE_EXT = ".pl",
+#    the executable installed in BIN_DEST will be named "foo". 
+#
+#    For tcl packages, MOD_SRC specifies a list of files that contain the
+#    source code that will make up the package.  MOD_NAME specifies the 
+#    file name for the package (this is typically the module name with a 
+#    ".tcl" extension). In addition, the Makefile *MUST* specify a 
+#    destination directory for installation.  Typically, this is set to a 
+#    subdirectory of BASE_DIR, e.g. MOD_DEST = $(BASE_DIR)/perllib for perl 
+#    modules. 
+#
+#    The EXE_SRC variable only needs to be set executable scripts need to be
+#    built.  Likewise MOD_SRC determines if script modules should be built.
+#    The logic to set "src" to "invalid" is used to prevent shell errors
+#    if either or both of these variables are not set. 
+#
+#    However, if MOD_SRC is set, MOD_DEST must also be set to the location
+#    of a valid directory.  The same is also true for EXE_SRC and BIN_DEST,
+#    but BIN_DEST is properly set when the buildrc resource file is sourced. 
+#
+all : binary
+
+binary:
+	@src="$(BIN_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(BIN_DEST)" ]; then \
+		echo "Error: Binary installation directory BIN_DEST not set" 1>&2;\
+		src="invalid" ;\
+	fi; fi; \
+	for s in $${src}; do \
+		if [ -f $(BIN_DEST)/$${s} ]; then \
+			echo "    Removing $(BIN_DEST)/$${s}"; \
+			rm -f $(BIN_DEST)/$${s}; \
+		fi; \
+		if [ "$${s}" = "invalid" ]; then \
+			continue;\
+		fi;\
+		echo "    Copying $$s to $(BIN_DEST)/$${s}" ; \
+		cp $$s $(BIN_DEST)/$${s} ; \
+	done; \
+
+#
+#  Include rules for installation of configuration files.
+#
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULES that are not implemented. 
+#
+archive linked_lib: .FORCE
+	@echo "    make $@ is not implemented for binary modules" 1>&2
+
+#
+#  RULE for building unit test programs. 
+#
+utest: .FORCE
+	@echo "    make $@ is not implemented for binary modules" 1>&2
+
+.FORCE:
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes any extraneous artifacts of producing script modules or
+#      executables. make clean also removes files core files and backup
+#      files. 
+#
+#  'clean_lib' removes the installed libraries or modules
+#  'clean_exe' removes the installed executable scripts
+#
+#      A subsequent make will recreate the shared library from the compiled
+#      object files.
+#
+clean_exe: 
+	@echo "    make $@ is not implemented for binary modules" 1>&2
+
+clean_lib: 
+	@echo "    make $@ is not implemented for binary modules" 1>&2
+
+clean: 
+	@echo "    Cleaning up binary directory `pwd`" ;\
+	/bin/rm -f Makefile.bak core *~ #*#
+
+#
+#  Rules for making dependencies.
+#  These are not implemented for scripts, so the rules do nothing.
+#
+depend clean_depend: .FORCE
+	@:
+
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib_share/build/compile_rules.mk b/wrfv2_fire/external/io_grib_share/build/compile_rules.mk
new file mode 100644
index 00000000..5995aca3
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/compile_rules.mk
@@ -0,0 +1,46 @@
+#------------------------------------------------------------------------------
+#  Make rules for compiling source code files. 
+#
+#  This file is intended for use in a Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/compile_rules.mk
+#
+#  It may also be include by other rule files in this directory.
+#  
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  Define all the extensions and include directories we will handle in the 
+#  compile rules. Currently it is just C and C++.
+#
+SRC_EXTENSIONS=.C .c .cpp .cxx .F90 .F .f90
+
+#
+#  RULES for compilation of C and C++ code
+#
+.SUFFIXES: .c .C .cpp .cxx .F90 .F .f90
+.C.o:
+	$(CXX) $(SYS_CXX_INCLUDES) $(SYS_C_INCLUDES) $(CXX_INCLUDES) $(CXXFLAGS) $(SYS_DEFINES) $(DEBUG) -c $<
+.c.o:
+	$(CC) $(SYS_C_INCLUDES) $(C_INCLUDES) $(CFLAGS) $(SYS_DEFINES) $(DEBUG) -c $<
+.cxx.o:
+	$(CXX) $(SYS_CXX_INCLUDES) $(SYS_C_INCLUDES) $(CXX_INCLUDES) $(CXXFLAGS) $(SYS_DEFINES) $(DEBUG) -c $<
+.cpp.o:
+	$(CXX) $(SYS_CXX_INCLUDES) $(SYS_C_INCLUDES) $(CXX_INCLUDES) $(CXXFLAGS) $(SYS_DEFINES) $(DEBUG) -c $<
+
+.F90.o:
+	$(FC) $(SYS_F_INCLUDES) $(F_INCLUDES) $(FCFLAGS) $(SYS_DEFINES) $(DEBUG) $(FORMAT) -c $<
+
+.F.o:
+	$(RM) $@
+	$(CPP) $(CPPFLAGS) $(SYS_F_INCLUDES) $(F_INCLUDES) $*.F > $*.f90
+	$(FC) $(SYS_F_INCLUDES) $(F_INCLUDES) $(FCFLAGS) $(SYS_DEFINES) $(DEBUG) $(FORMAT) -c $*.f90
+
+.f90.o:
+	$(FC) $(SYS_F_INCLUDES) $(F_INCLUDES) $(FCFLAGS) $(SYS_DEFINES) $(DEBUG) $(FORMAT) -c $<
diff --git a/wrfv2_fire/external/io_grib_share/build/config_rules.mk b/wrfv2_fire/external/io_grib_share/build/config_rules.mk
new file mode 100644
index 00000000..193af30b
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/config_rules.mk
@@ -0,0 +1,52 @@
+#------------------------------------------------------------------------------
+#  Make rules for installing optional configuration files. 
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/config_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules:
+#
+#      config 
+#
+#  Copyright (C) 2002, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  The config rules install any files under the directory config into the
+#  project's configuration directory.  Any directory structure beneath
+#  the local config directory will be preserved.  However, the special 
+#  CVS directory will NOT be copied.
+#
+config: .FORCE
+	@if [ -d config ]; then\
+		cd config;\
+		l=* ; \
+		if [ -z "$${l}" ]; then \
+			echo "Error: empty config directory.";\
+			l="CVS" ;\
+		fi;\
+		for f in $$l; do\
+			if [ "$$f" = "CVS" ]; then\
+				continue;\
+			fi;\
+			cp -ur $$f $(BASE_DIR)/config;\
+			if [ -d $$f ]; then\
+				find $(BASE_DIR)/config/$$f -name 'CVS' -exec rm -fr {} > /dev/null 2>&1 \;  ;\
+			fi;\
+		done;\
+		cd ..;\
+	fi 
+
+.FORCE:
+
+
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib_share/build/depend_rules.mk b/wrfv2_fire/external/io_grib_share/build/depend_rules.mk
new file mode 100644
index 00000000..4948a6ca
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/depend_rules.mk
@@ -0,0 +1,78 @@
+#------------------------------------------------------------------------------
+#  Make rules for determining the dependencies between source files. 
+#
+#  This file is intended for use in a Makefile via the include directive, e.g.
+#
+#      include $(BUID_DIR)/depend_rules.mk
+#
+#  It may also be include by other rule files in this directory.
+#
+#  These rules rely upon proper setting of OBJS and SRC_EXTENSIONS.
+#  
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for creating the source code dependencies.
+#
+#  These are typically used to implement the rules depend and clean_depend
+#  in other make rule files.
+#
+#  'generic_depend' creates the dependencies and appends them to a separate 
+#      file in the same directory as the source code, called .depend.   
+#      Depend uses some customized logic to determine the name of the source
+#      code file associated with each object file in OBJS.  This means that we
+#      can mix source code extensions in the same library (e.g. use C and C++
+#      source interchangeably).  See compile_rules.mk for supported file name
+#      extensions for C and C++ development.
+#
+#  'generic_clean_depend' removes the dependencies file .depend.
+#
+generic_clean_depend:
+	@rm -f .depend
+
+generic_depend: 
+	@srcs="" ;\
+	if [ -z "$(OBJS)" ]; then\
+		objs="foobar";\
+	else\
+		objs="$(OBJS)";\
+	fi;\
+	for o in $${objs}; do\
+		if [ $$o = "foobar" ]; then\
+			echo "Error: no objects were specified in OBJS.";\
+			continue;\
+		fi;\
+		b=`echo $$o | sed -e 's/\.o//'` ;\
+		f="" ;\
+		for e in $(SRC_EXTENSIONS) ; do \
+			s="$$b$$e" ;\
+			if [ -r "$$s" ]; then\
+				srcs="$${srcs} $$s" ;\
+				f=1 ;\
+				break ;\
+			fi; \
+		done ;\
+		if [ -z "$$f" ]; then\
+			echo "Could not find source file for object file $$o";\
+		fi ;\
+	done ;\
+	make_opts="";\
+	if [ "$(SYS_CXX_INCLUDES)" ]; then\
+		make_opts="-I+ $(SYS_CXX_INCLUDES)";\
+	fi;\
+	if [ "$(SYS_C_INCLUDES)" ]; then\
+		make_opts="$${make_opts} -I+ $(SYS_C_INCLUDES)";\
+	fi;\
+	if [ "$(C_INCLUDES)" ]; then\
+		make_opts="$${make_opts} -I+ $(C_INCLUDES)";\
+	fi;\
+	if [ "$(CXX_INCLUDES)" ]; then\
+		make_opts="$${make_opts} -I+ $(CXX_INCLUDES)";\
+	fi;\
+	makedepend $${make_opts} -f- $${srcs} > .depend;
diff --git a/wrfv2_fire/external/io_grib_share/build/library_rules.mk b/wrfv2_fire/external/io_grib_share/build/library_rules.mk
new file mode 100644
index 00000000..36333c69
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/library_rules.mk
@@ -0,0 +1,197 @@
+#------------------------------------------------------------------------------
+#  Make rules for producing a library module.
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/library_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for library modules:
+#
+#      all, lib, archive, linked_lib, utest, exe, clean, clean_lib, 
+#      clean_depend, depend.
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+MAKE=make
+
+#
+#  RULES that can be passed through to subdirectories. 
+#
+#    Each of these rules executes the rule on this directory, then executes
+#    the same rule on each subdirectory specified in SUB_DIRS.
+#
+#    The rules for this directory are specified as thisdir_ in
+#    this file, e.g. "thisdir_all" implements "make all" for this directory. 
+#
+#    The SUB_DIRS variable only needs to be set if building of subdirectories
+#    is desired.  In this case, the list of subdirectories ($$s) is set to the
+#    no-op value of "foobar" to prevent the shell for seeing errors in the 
+#    subsequent for loop when SUB_DIRS is not set. 
+#
+all lib archive linked_lib clean depend clean_depend clean_lib:
+	@s="$(SUB_DIRS)" ; \
+	if [ -z "$${s}" ]; then \
+		s="foobar" ;\
+	fi; \
+	for d in $$s ; do \
+		if [ "$$d" = "foobar" ]; then\
+			continue ;\
+		fi ; \
+		if [ ! -d "$$d" ]; then \
+			echo "        Error: subdir $$d is NOT a directory!"; \
+			contiuue ;\
+		fi ; \
+		if [ ! -r "$$d/Makefile" ]; then\
+			echo "        Error: subdir $$d does NOT contain a Makefile!"; \
+			continue ;\
+		fi ; \
+		echo "        Doing make $@ on library subdirectory $$d" ;\
+		cd $$d ; \
+		$(MAKE) $@;\
+		cd ..; \
+	done; \
+	$(MAKE) thisdir_$@
+
+clean_exe:
+	@echo "make clean_exe does nothing for library modules"
+
+thisdir_all: thisdir_linked_lib config 
+
+#
+#  Include the RULES for compilation and installing config files
+#
+include $(BUILD_DIR)/compile_rules.mk
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULES for building a library.
+#
+#  - 'lib' builds the library as a shared library.
+#  - 'archive' builds the library as an archive library.
+#  - 'linked_lib' builds the library as a shared library (if necessary), and
+#    links the shared library to its dependent libraries.
+#  - Specific library names are built depending on the update status of the
+#    library of the same name installed in $(LIB_DEST).
+#  - Libraries are built depending on the status of its object files (OBJS)
+#
+#  NOTE: Shared libraries are linked against the libraries upon which they
+#        depend.  This is not possible with archive libraries.
+# 
+thisdir_lib: lib$(LIB_NAME).$(LIB_EXT)
+
+lib$(LIB_NAME).$(LIB_EXT): $(LIB_DEST)/lib$(LIB_NAME).$(LIB_EXT)
+
+$(LIB_DEST)/lib$(LIB_NAME).$(LIB_EXT): $(OBJS)
+	$(CXX) $(LIB_FLAGS) -o $@ $(OBJS)
+
+thisdir_linked_lib: $(OBJS)
+	$(CXX) $(LIB_FLAGS) -o $(LIB_DEST)/lib$(LIB_NAME).$(LIB_EXT) $(OBJS) $(DEP_LIBS)
+	@if [ `echo $(LIB_NAME) | grep Pkg` ] ; then \
+		pwd = `pwd` ; \
+		cd $(LIB_DEST) ; \
+		echo "    Creating tcl package index in $(MOD_DEST)" ;\
+		exec echo "pkg_mkIndex . \*Pkg.so \*.tcl" | tclsh;\
+		cd "$$(pwd)"; \
+	fi
+
+thisdir_archive: $(OBJS) .FORCE 
+	ar $(ARFLAGS) $(LIB_DEST)/lib$(LIB_NAME).a $(OBJS)
+
+#thisdir_archive: lib$(LIB_NAME).a .FORCE
+#
+#lib$(LIB_NAME).a: $(LIB_DEST)/lib$(LIB_NAME).a .FORCE
+#
+#$(LIB_DEST)/lib$(LIB_NAME).a: .FORCE $(OBJS)
+#	ar cruv $@ $(OBJS)
+
+#
+#  RULE for building unit test programs. 
+#
+
+utest: .FORCE
+	@if [ -d utest ] ; then \
+		echo "Making unit tests for `pwd`"; \
+		cd utest; \
+		make; \
+		cd ..; \
+	fi 
+
+.FORCE:
+
+#
+#  RULE for building an executable.
+#
+#  For library modules, these do nothing, but we define one so that make exe
+#  can be passed down to all source directories.
+#
+exe:
+	@echo "make exe does nothing for library modules"
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes all objects produced by this file, as well as other 
+#      extraneous artifacts of compiling and building libraries.
+# 
+#      A subsequent make will both recompile the source code and recreate
+#      the shared library.  clean also removes files core files and other
+#      auxilliary files created during compilation.
+#
+#  'clean_lib' removes only the libraries, both shared and archive.
+#
+#      A subsequent make will recreate the shared library from the compiled
+#      object files.
+#
+thisdir_clean: thisdir_clean_lib
+	@/bin/rm -f *.o *.mod *.f90 core so_locations Makefile.bak *~ #*#
+	@/bin/rm -fr ii_files
+	@if [ -d utest ] ; then \
+		echo "        Doing make clean on utest subdirectory"; \
+		cd utest; \
+		make clean; \
+		cd ..; \
+	fi 
+
+thisdir_clean_lib: 
+	@/bin/rm -f $(LIB_DEST)/lib$(LIB_NAME).*	
+
+#
+#  RULES for creating the include dependencies.
+#
+#  'depend' creates the dependencies and appends them to the end of this file.
+#      Depend uses some customized logic to determine the name of the source
+#      code file associated with each object file in OBJS.  This means that we
+#      can mix source code extensions in the same library (e.g. use C and C++
+#      source interchangeably).  See compile_rules.mk for supported file name
+#      extensions.
+#
+#  'clean_depend' removes the dependencies from this file, which makes the
+#      Makefile much smaller.  make clean_depend should be done before
+#      checking a Makefile into revision control.
+#
+thisdir_clean_depend: generic_clean_depend 
+	@if [ -d utest ] ; then \
+		echo "        Doing make clean_depend on utest subdirectory"; \
+		cd utest; \
+		$(MAKE) clean_depend; \
+		cd ..; \
+	fi 
+
+thisdir_depend: generic_depend
+	@if [ -d utest ] ; then \
+		echo "        Doing make depend on utest subdirectory"; \
+		cd utest; \
+		$(MAKE) depend; \
+		cd ..; \
+	fi 
+
+include $(BUILD_DIR)/depend_rules.mk
+
diff --git a/wrfv2_fire/external/io_grib_share/build/package_rules.mk b/wrfv2_fire/external/io_grib_share/build/package_rules.mk
new file mode 100644
index 00000000..632fb026
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/package_rules.mk
@@ -0,0 +1,131 @@
+#------------------------------------------------------------------------------
+#  Make rules for building and installing a 3rdparty package.
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/package_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for library modules:
+#
+#      all, clean, install 
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULE for building a package. 
+#
+#  make all will decompress the package from a compressed tar file. 
+#  If decompression is successful, the tar file will be removed.
+#
+#  It will then configure, make, check, and install the package using the
+#  standard GNU mechanisms.  It uses make -i to ignore errors.
+#
+#  After the standard GNU make is complete, an executable called custom_build 
+#  will be executed, if such a script is found in the same directory as the 
+#  Makefile that includes these rules.  The custom_build executable should
+#  accept the PACKAGE and INSTALLDIR as arguments.
+# 
+#  This relies on settings for the variables:
+#    BASEDIR    - absolute path where Makefile resides.
+#    PACKAGE    - directory relative to BASEDIR containing package to build.
+#    INSTALLDIR - directory relative to BASEDIR into which to install package.
+# 
+all:
+	@if [ ! -d $(PACKAGE) ]; then \
+		if [ -e $(PACKAGE).tar.gz ]; then \
+			gunzip $(PACKAGE).tar.gz ; \
+			tar -xf $(PACKAGE).tar ; \
+			rm -f $(PACKAGE).tar ; \
+		fi ; \
+	fi ; \
+	if [ ! -d $(PACKAGE) ]; then \
+        echo "Could not find or successfully decompress package " $(PACKAGE) ;\
+		exit 1 ; \
+	fi ; \
+	if [ ! -d $(INSTALLDIR) ]; then \
+		mkdir $(INSTALLDIR) ; \
+		if [ ! -d $(INSTALLDIR) ]; then \
+			echo "Cannot create installation directory " $(INSTALLDIR) ;\
+		fi ; \
+	fi ; \
+	cd $(PACKAGE) ;\
+	sh ./configure --prefix=$(BASEDIR)/$(INSTALLDIR) ;\
+	make ;\
+	make check ;\
+	make install ;\
+	cd .. ;\
+	if [ -x ./custom_build ]; then \
+		./custom_build $(PACKAGE) $(INSTALLDIR) ;\
+	fi;
+
+#
+#  RULE for installing a package.
+#
+#    This copies files from the packages install directory into the bin,
+#    lib, or src/3rdparty directories associated with a product source tree. 
+#
+#    Relies on proper setting of INSTALLDIR (explained above).
+#    Also relies on paths setup in buildrc. 
+#
+install:
+	@cd $(INSTALLDIR) ; \
+	if [ -d bin ]; then \
+		cd bin ;\
+		echo "    Installing executables in $(BIN_DEST)" ;\
+		for f in *; do \
+			if [ ! -d $$f ]; then \
+				echo "      $$f"; \
+				cp $$f $(BIN_DEST) ;\
+			fi ;\
+		done ;\
+		cd .. ; \
+	fi; \
+	if [ -d lib ]; then \
+		cd lib ;\
+		echo "    Installing libraries in $(LIB_DEST)" ;\
+		for f in *; do \
+			if [ ! -d $$f ]; then \
+				echo "      $$f"; \
+				cp $$f $(LIB_DEST) ;\
+			fi ;\
+		done ;\
+		cd .. ; \
+	fi; \
+	if [ -d include ]; then \
+		cd include ;\
+		echo "    Installing header files in $(THIRDPARTY_DIR)" ;\
+		for f in *; do \
+			if [ ! -d $$f ]; then \
+				echo "      $$f"; \
+				cp $$f $(THIRDPARTY_DIR) ;\
+			fi ;\
+		done ;\
+		cd .. ; \
+	fi; 
+
+#
+#  RULE for cleaning up a package.
+#
+#  make clean will do both the standard GNU make clean and make distclean rules.
+#  After that, it will tar and compress the package.
+#
+clean:
+	@if [ -d $(PACKAGE) ]; then \
+		cd $(PACKAGE) ;\
+		make clean;\
+		make distclean;\
+		cd ..;\
+		tar -cf $(PACKAGE).tar $(PACKAGE);\
+		rm -fr $(PACKAGE);\
+		gzip $(PACKAGE).tar ; \
+	fi;
+
diff --git a/wrfv2_fire/external/io_grib_share/build/script_rules.mk b/wrfv2_fire/external/io_grib_share/build/script_rules.mk
new file mode 100644
index 00000000..183e2127
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/script_rules.mk
@@ -0,0 +1,186 @@
+#------------------------------------------------------------------------------
+#  Make rules for installing scripts and script-modules. 
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/script_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for library modules:
+#
+#      all, lib, archive, linked_lib, utest, exe, clean, clean_lib, clean_exe,
+#      clean_depend, depend.
+#
+#  Copyright (C) 2002, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for installing scripts and script modules 
+#
+#    EXE_SRC specifies a list of files that contain executable scripts.
+#    Each file in the list will be installed in the $(BIN_DEST) directory
+#    and will be given executable permissions.  If the variable EXE_EXT is
+#    set, this extension will be stripped from the end of the source file
+#    when it is installed, e.g. if EXE_SRC = "foo.pl" and EXE_EXT = ".pl",
+#    the executable installed in BIN_DEST will be named "foo". 
+#
+#    Installation of library modules works in a similiar fashion, with the
+#    variables MOD_SRC and MOD_EXT taking the place of EXE_SRC and EXE_EXT.
+#    In addition, the Makefile *MUST* specify a destination directory for
+#    installation.  Typically, this is set to a subdirectory of BASE_DIR,
+#    e.g. MOD_DEST = $(BASE_DIR)/perllib for perl modules. 
+#
+#    The EXE_SRC variable only needs to be set executable scripts need to be
+#    built.  Likewise MOD_SRC determines if script modules should be built.
+#    The logic to set "src" to "invalid" is used to prevent shell errors
+#    if either or both of these variables are not set. 
+#
+#    However, if MOD_SRC is set, MOD_DEST must also be set to the location
+#    of a valid directory.  The same is also true for EXE_SRC and BIN_DEST,
+#    but BIN_DEST is properly set when the buildrc resource file is sourced. 
+#
+all : exe lib config
+
+exe:
+	@src="$(EXE_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(BIN_DEST)" ]; then \
+		echo "Error: Binary installation directory BIN_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(BIN_DEST)" ]; then \
+		echo "Error: BIN_DEST directory $(BIN_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		out=`echo $${s} | egrep '.*\.cgi'` > /dev/null 2>&1; \
+		if [ "$${out}" != "" ]; then \
+		   e="$${s}" ; \
+		else \
+		   e=`echo $$s | sed -e 's/\..*//'` ; \
+		fi ; \
+		echo "    Installing $$e in $(BIN_DEST)" ; \
+		cp -f $$s $(BIN_DEST)/$$e ; \
+		chmod 555 $(BIN_DEST)/$$e ; \
+	done
+
+lib:
+	@src="$(MOD_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(MOD_DEST)" ]; then \
+		echo "Error: Module installation directory MOD_DEST not set" 1>&2;\
+	src="invalid" ;\
+	else if [ ! -d "$(MOD_DEST)" ]; then \
+		echo "Error: MOD_DEST directory $(MOD_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue;\
+		fi;\
+		e=`basename $$s $(MOD_EXT)` ; \
+		echo "    Installing $$e in $(MOD_DEST)" ; \
+		cp -f $$s $(MOD_DEST)/$$e ; \
+		chmod 444 $(MOD_DEST)/$$e ; \
+	done
+
+#
+#  Include rules for installation of configuration files.
+#
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULES that are not implemented. 
+#
+archive linked_lib: .FORCE
+	@echo "    make $@ is not implemented for script modules" 1>&2
+
+#
+#  RULE for building unit test programs. 
+#
+utest: .FORCE
+	@if [ -d utest ] ; then \
+		echo "Making unit tests for `pwd`"; \
+		cd utest; \
+		make; \
+		cd ..; \
+	fi 
+
+.FORCE:
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes any extraneous artifacts of producing script modules or
+#      executables. make clean also removes files core files and backup
+#      files. 
+#
+#  'clean_lib' removes the installed libraries or modules
+#  'clean_exe' removes the installed executable scripts
+#
+#      A subsequent make will recreate the shared library from the compiled
+#      object files.
+#
+clean_exe: 
+	@src="$(EXE_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(BIN_DEST)" ]; then \
+		echo "Error: Binary installation directory BIN_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(BIN_DEST)" ]; then \
+		echo "Error: BIN_DEST directory $(BIN_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		e=`echo $$s | sed -e 's/\..*//'` ;\
+		echo "    Removing $$e from $(BIN_DEST)" ; \
+		rm -f $(BIN_DEST)/$$e ; \
+	done
+
+clean_lib: 
+	@src="$(MOD_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(MOD_DEST)" ]; then \
+		echo "Error: Module installation directory MOD_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(MOD_DEST)" ]; then \
+		echo "Error: MOD_DEST directory $(MOD_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		e=`basename $$s $(MOD_EXT)` ; \
+		echo "    Removing $$e from $(MOD_DEST)" ; \
+		rm -f $(MOD_DEST)/$$e ; \
+	done
+
+clean: 
+	@echo "    Cleaning up script directory `pwd`" ;\
+	/bin/rm -f Makefile.bak core *~ #*#
+
+#
+#  Rules for making dependencies.
+#  These are not implemented for scripts, so the rules do nothing.
+#
+depend clean_depend: .FORCE
+	@:
+
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib_share/build/tcl_script_rules.mk b/wrfv2_fire/external/io_grib_share/build/tcl_script_rules.mk
new file mode 100644
index 00000000..a20cfae7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/tcl_script_rules.mk
@@ -0,0 +1,195 @@
+#------------------------------------------------------------------------------
+#  Make rules for installing tcl scripts and script-modules. 
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/tcl_script_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for library modules:
+#
+#      all, lib, archive, linked_lib, utest, exe, clean, clean_lib, clean_exe,
+#      clean_depend, depend.
+#
+#  Copyright (C) 2002, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for installing scripts and script modules 
+#
+#    EXE_SRC specifies a list of files that contain executable scripts.
+#    Each file in the list will be installed in the $(BIN_DEST) directory
+#    and will be given executable permissions.  If the variable EXE_EXT is
+#    set, this extension will be stripped from the end of the source file
+#    when it is installed, e.g. if EXE_SRC = "foo.pl" and EXE_EXT = ".pl",
+#    the executable installed in BIN_DEST will be named "foo". 
+#
+#    For tcl packages, MOD_SRC specifies a list of files that contain the
+#    source code that will make up the package.  MOD_NAME specifies the 
+#    file name for the package (this is typically the module name with a 
+#    ".tcl" extension). In addition, the Makefile *MUST* specify a 
+#    destination directory for installation.  Typically, this is set to a 
+#    subdirectory of BASE_DIR, e.g. MOD_DEST = $(BASE_DIR)/perllib for perl 
+#    modules. 
+#
+#    The EXE_SRC variable only needs to be set executable scripts need to be
+#    built.  Likewise MOD_SRC determines if script modules should be built.
+#    The logic to set "src" to "invalid" is used to prevent shell errors
+#    if either or both of these variables are not set. 
+#
+#    However, if MOD_SRC is set, MOD_DEST must also be set to the location
+#    of a valid directory.  The same is also true for EXE_SRC and BIN_DEST,
+#    but BIN_DEST is properly set when the buildrc resource file is sourced. 
+#
+all : exe lib config
+
+exe:
+	@src="$(EXE_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(BIN_DEST)" ]; then \
+		echo "Error: Binary installation directory BIN_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(BIN_DEST)" ]; then \
+		echo "Error: BIN_DEST directory $(BIN_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		e=`echo $$s | sed -e 's/\..*//'` ;\
+		echo "    Installing $$e in $(BIN_DEST)" ; \
+		cp -f $$s $(BIN_DEST)/$$e ; \
+		chmod 555 $(BIN_DEST)/$$e ; \
+	done
+
+lib:
+	@src="$(MOD_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(MOD_DEST)" ]; then \
+		echo "Error: Module installation directory MOD_DEST not set" 1>&2;\
+	src="invalid" ;\
+	else if [ ! -d "$(MOD_DEST)" ]; then \
+		echo "Error: MOD_DEST directory $(MOD_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	pwd=`pwd` ; \
+	if [ -f $(MOD_DEST)/$(MOD_NAME) ]; then \
+		echo "    Removing $(MOD_DEST)/$(MOD_NAME)"; \
+		rm -f $(MOD_DEST)/$(MOD_NAME); \
+	fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue;\
+		fi;\
+		echo "    Appending $$s to $(MOD_DEST)/$(MOD_NAME)" ; \
+		cat $$s >> $(MOD_DEST)/$(MOD_NAME) ; \
+		if [ $$? != 0 ]; then \
+		   echo "Error with cat $$s"; \
+		fi; \
+		ext=`echo $$s | sed -e 's/.*\.//'` ;\
+	done; \
+	chmod 444 $(MOD_DEST)/$(MOD_NAME) ; \
+	cd $(MOD_DEST) ; \
+	echo "    Creating tcl package index in $(MOD_DEST)" ;\
+	exec echo "pkg_mkIndex . \*Pkg.so \*.tcl" | tclsh;\
+	cd "$$(pwd)"
+
+#
+#  Include rules for installation of configuration files.
+#
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULES that are not implemented. 
+#
+archive linked_lib: .FORCE
+	@echo "    make $@ is not implemented for script modules" 1>&2
+
+#
+#  RULE for building unit test programs. 
+#
+utest: .FORCE
+	@if [ -d utest ] ; then \
+		echo "Making unit tests for `pwd`"; \
+		cd utest; \
+		make; \
+		cd ..; \
+	fi 
+
+.FORCE:
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes any extraneous artifacts of producing script modules or
+#      executables. make clean also removes files core files and backup
+#      files. 
+#
+#  'clean_lib' removes the installed libraries or modules
+#  'clean_exe' removes the installed executable scripts
+#
+#      A subsequent make will recreate the shared library from the compiled
+#      object files.
+#
+clean_exe: 
+	@src="$(EXE_SRC)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(BIN_DEST)" ]; then \
+		echo "Error: Binary installation directory BIN_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(BIN_DEST)" ]; then \
+		echo "Error: BIN_DEST directory $(BIN_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${src}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		e=`echo $$s | sed -e 's/\..*//'` ;\
+		echo "    Removing $$e from $(BIN_DEST)" ; \
+		rm -f $(BIN_DEST)/$$e ; \
+	done
+
+clean_lib: 
+	@name="$(MOD_NAME)" ; \
+	if [ -z "$${src}" ]; then \
+		src="invalid" ;\
+	else if [ -z "$(MOD_DEST)" ]; then \
+		echo "Error: Module installation directory MOD_DEST not set" 1>&2;\
+		src="invalid" ;\
+	else if [ ! -d "$(MOD_DEST)" ]; then \
+		echo "Error: MOD_DEST directory $(MOD_DEST) not found" 1>&2 ;\
+		src="invalid" ;\
+	fi; fi; fi; \
+	for s in $${name}; do \
+		if [ "$${s}" = "invalid" ]; then \
+			continue ; \
+		fi ; \
+		e=`basename $$s $(MOD_EXT)` ; \
+		echo "    Removing $$e from $(MOD_DEST)" ; \
+		rm -f $(MOD_DEST)/$$e ; \
+	done
+
+clean: 
+	@echo "    Cleaning up script directory `pwd`" ;\
+	/bin/rm -f Makefile.bak core *~ #*#
+
+#
+#  Rules for making dependencies.
+#  These are not implemented for scripts, so the rules do nothing.
+#
+depend clean_depend: .FORCE
+	@:
+
+# DO NOT DELETE THIS LINE -- make depend depends on it.
diff --git a/wrfv2_fire/external/io_grib_share/build/utest_rules.mk b/wrfv2_fire/external/io_grib_share/build/utest_rules.mk
new file mode 100644
index 00000000..e05368e3
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/utest_rules.mk
@@ -0,0 +1,78 @@
+#------------------------------------------------------------------------------
+#  Make rules for building one or more unit test programs.  These are used to
+#  test library modules. 
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/utest_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  This file defines the following rules for library modules:
+#
+#      all, exe
+#
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for building one or more unit test programs. 
+# 
+all: exe 
+exe: utest
+
+utest: $(MAIN_OBJS) 
+	@for o in $(MAIN_OBJS); do \
+        p=`basename $$o '.o'` ; \
+		echo "          Building test program $$p..." ; \
+		echo "$(LDD) $(DEBUG) $(OPTIMIZE) -o $$p $$o $(DEP_LIBS)" ;\
+	    $(LDD) $(DEBUG) $(OPTIMIZE) -o $$p $$o $(DEP_LIBS) ;\
+	done
+
+#
+#  Include the RULES for compilation. 
+#
+include $(BUILD_DIR)/compile_rules.mk
+
+#
+#  RULE for building a library
+#
+#  For exe modules, these do nothing, but we define one so that make lib 
+#  can be passed down to all source directories.
+#
+lib:
+	@echo "make lib does nothing for unit test modules"
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes all objects produced by this file, as well as other 
+#      extraneous artifacts of compiling and building libraries.
+# 
+#      A subsequent make will both recompile the source code and recreate
+#      the executable.  clean also removes files core files and other
+#      auxilliary files created during compilation.
+#
+clean: 
+	@/bin/rm -f *.o core so_locations Makefile.bak *~ #*#
+	@/bin/rm -fr ii_files
+	@for o in $(MAIN_OBJS); do \
+            p=`basename $$o '.o'` ; \
+	    rm -f $$p;\
+	done
+
+#
+#  RULES for creating the include dependencies.
+#
+OBJS=$(MAIN_OBJS)
+include $(BUILD_DIR)/depend_rules.mk
+
+clean_depend: generic_clean_depend
+
+depend: generic_depend
diff --git a/wrfv2_fire/external/io_grib_share/build/utility_rules.mk b/wrfv2_fire/external/io_grib_share/build/utility_rules.mk
new file mode 100644
index 00000000..17007a48
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/build/utility_rules.mk
@@ -0,0 +1,76 @@
+#------------------------------------------------------------------------------
+#  Make rules for building an application program.
+#
+#  This file is intended for use in Makefile via the include directive, e.g.
+#
+#      include $(BUILD_DIR)/application_rules.mk
+#
+#  It is assumed that the environment has been set by sourcing the build
+#  resource file (buildrc).
+# 
+#  Copyright (C) 2001, WSI Corporation
+#------------------------------------------------------------------------------
+#
+#  For portability, use the Bourne shell within Makefiles. 
+#  There have been problems using the C-shell under Linux.
+#
+SHELL=/bin/sh
+
+#
+#  RULES for building a single utility program.
+#        The program will be named $(EXE_NAME).
+#        The objects files used to create the utility should be $(OBJS).  
+#        The libraries that should be linked should be $(DEP_LIBS).
+# 
+all: exe config
+
+exe: $(OBJS) 
+	@echo "    Building utility program $(EXE_NAME)" ; \
+	$(LDD) $(DEBUG) $(OPTIMIZE) -o $(EXE_NAME) $(OBJS) $(DEP_LIBS) ;\
+	mv -f $(EXE_NAME) $(BIN_DEST) ;
+
+#
+#  Include the RULES for compilation and installation of config files
+#
+include $(BUILD_DIR)/compile_rules.mk
+include $(BUILD_DIR)/config_rules.mk
+
+#
+#  RULE for building a library
+#
+#  For exe modules, these do nothing, but we define one so that make lib 
+#  can be passed down to all source directories.
+#
+lib:
+	@echo "make lib does nothing for utility modules"
+
+#
+#  RULES for cleaning up derived files.
+#
+#  'clean' removes all objects produced by this file, as well as other 
+#      extraneous artifacts of compiling and building applications.
+# 
+#      A subsequent make will both recompile the source code and recreate
+#      the executable.  clean also removes files core files and other
+#      auxilliary files created during compilation.
+#
+#  'clean_exe' removes the utility program.
+#
+clean: 
+	@/bin/rm -f *.o core* so_locations Makefile.bak *~ #*#
+	@/bin/rm -fr ii_files
+
+clean_exe:
+	@/bin/rm -f $(BIN_DEST)/$(EXE_NAME)
+
+clean_lib:
+	@echo "       make clean_lib does nothing for utility modules"
+
+#
+#  RULES for creating the include dependencies.
+#
+include $(BUILD_DIR)/depend_rules.mk
+
+clean_depend: generic_clean_depend
+
+depend: generic_depend
diff --git a/wrfv2_fire/external/io_grib_share/get_region_center.c b/wrfv2_fire/external/io_grib_share/get_region_center.c
new file mode 100644
index 00000000..c2700fc7
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/get_region_center.c
@@ -0,0 +1,207 @@
+#include "get_region_center.h"
+#include "gridnav.h"
+#include 
+#include 
+
+#include "wrf_projection.h"
+
+int get_gridnav_projection(int wrf_projection);
+
+/****************************************************************************
+ *
+ * This function calculates the center lat and lon of a region within a larger
+ *   domain.  It is useful for calculating the center of the boundary regions
+ *   in a domain.
+ *
+ ****************************************************************************/
+
+
+int GET_REGION_CENTER(char *MemoryOrderIn, int *projection, 
+		      float *domain_center_lat, 
+		      float *domain_center_lon, int *full_xsize, 
+		      int *full_ysize, float *dx, float *dy, 
+		      float *proj_central_lon, 
+		      int *proj_center_flag, float *truelat1, 
+		      float *truelat2, int *region_xsize, int *region_ysize, 
+		      float *region_center_lat, float *region_center_lon, 
+		      int strlen1)
+{
+
+  char *MemoryOrder;
+  int grid_projection;
+  float full_xcenter, full_ycenter;
+  float region_xcenter, region_ycenter;
+  int status;
+  int orig;
+  int x_pos, y_pos;
+  GridNav gridnav;
+
+  MemoryOrder = (char *)malloc((strlen1+1)*sizeof(char));
+  memcpy(MemoryOrder,MemoryOrderIn,strlen1);
+  MemoryOrder[strlen1] = '\0';
+
+  grid_projection = get_gridnav_projection(*projection);
+
+  full_xcenter = (*full_xsize - 1) / 2.;
+  full_ycenter = (*full_ysize - 1) / 2.;
+  region_xcenter = (*region_xsize - 1) / 2.;
+  region_ycenter = (*region_ysize - 1) / 2.;
+
+  orig = 0;
+
+  if (strncmp(MemoryOrder,"XS", 2) == 0) 
+    {
+      x_pos = region_xcenter;
+      y_pos = full_ycenter;
+    }
+  else if (strncmp(MemoryOrder,"XE", 2) == 0)
+    {
+      x_pos = (*full_xsize - 1) - region_xcenter;
+      y_pos = full_ycenter;
+    }
+  else if (strncmp(MemoryOrder,"YS", 2) == 0) 
+    {
+      x_pos = full_xcenter;
+      y_pos = region_ycenter;
+    }
+  else if (strncmp(MemoryOrder,"YE", 2) == 0) 
+    {
+      x_pos = full_xcenter;
+      y_pos = (*full_ysize - 1) - region_ycenter;
+    }
+  else
+    {
+      orig = 1;
+    }
+
+  if (orig == 1)
+    {
+      *region_center_lat = *domain_center_lat;
+      *region_center_lon = *domain_center_lon;
+      status = 0;
+    } 
+  else
+    {
+      /* Initialize grid structure */
+      /*
+      status = GRID_init(grid_info->center_lat, grid_info->central_lon, 
+			 grid_projection,
+			 grid_info->latin1, grid_info->latin2, 
+			 grid_info->xpoints, grid_info->ypoints, 
+			 grid_info->Di, grid_info->Dj,
+			 grid_info->center_lat, grid_info->center_lon, 
+			 x_center, y_center,
+			 &gridnav);
+      */
+      status = GRID_init(*domain_center_lat, *proj_central_lon, 
+			 grid_projection,
+			 *truelat1, *truelat2, 
+			 *full_xsize, *full_ysize, *dx, *dy,
+			 *domain_center_lat, *domain_center_lon, 
+			 full_xcenter, full_ycenter,
+			 &gridnav);
+      if (!status)
+	{
+	  fprintf(stderr,"get_region_center: error from GRID_init\n");
+	}
+
+      /* get lat/lon of center of region */
+      status = GRID_to_latlon(&gridnav, x_pos, y_pos, region_center_lat, 
+			      region_center_lon);
+      if (!status)
+	{
+	  fprintf(stderr,
+		  "get_region_cneter: error from GRID_to_latlon for first lat/lon\n");
+	}
+      
+    }
+
+  free(MemoryOrder);
+  return status;
+
+}
+/******************************************************************************
+ * translates the grid projection identifier from the WRF id to the grib id.
+ *****************************************************************************/
+
+int get_gridnav_projection(int wrf_projection)
+{
+  int gridnav_projection;
+
+  /* Set the grid projection in the gridnav units */
+  switch (wrf_projection) 
+    {
+    case WRF_LATLON:
+      gridnav_projection = GRID_LATLON;
+      break;
+    case WRF_MERCATOR:
+      gridnav_projection = GRID_MERCATOR;
+      break;
+    case WRF_LAMBERT:
+      gridnav_projection = GRID_LAMCON;
+      break;
+    case WRF_POLAR_STEREO:
+      gridnav_projection = GRID_POLSTR;
+      break;
+    default:
+      fprintf(stderr,"Error, invalid projection: %d\n",wrf_projection);
+      gridnav_projection = -1;
+    }
+  
+  return gridnav_projection;
+}
+
+int GET_LL_LATLON(float *central_lat, float *central_lon, int *projection,
+		  float *latin1, float *latin2, int *nx, int *ny, 
+		  float *dx, float *dy, float *center_lat, float *center_lon,
+		  float *LLLa, float *LLLo, float *URLa, float *URLo, int *ierr)
+{
+
+  int grid_projection;
+  float x_center;
+  float y_center;
+  GridNav gridnav;
+  int status;
+
+  grid_projection = get_gridnav_projection(*projection);
+
+  /* Get coords of center of grid */
+  x_center = (*nx + 1)/2.;
+  y_center = (*ny + 1)/2.;
+
+ /* Initialize grid structure */
+  status = GRID_init(*central_lat, *central_lon, grid_projection,
+		     *latin1, *latin2, *nx, *ny, *dx, *dy,
+		     *center_lat, *center_lon, x_center, y_center,
+		     &gridnav);
+  if (!status)
+    {
+      fprintf(stderr,"write_grib: error from GRID_init\n");
+      *ierr = 1;
+      return;
+    }
+
+  /* get lat/lon of lower left corner */
+  status = GRID_to_latlon(&gridnav, 1, 1, LLLa, LLLo);
+  if (!status)
+    {
+      fprintf(stderr,
+	      "write_grib: error from GRID_to_latlon for first lat/lon\n");
+      *ierr = 1;
+      return;
+    }
+
+  /* get lat/lon of upper right corner */
+  status = GRID_to_latlon(&gridnav, *nx, *ny, URLa, URLo);
+  if (!status)
+    {
+      fprintf(stderr,
+	      "write_grib: error from GRID_to_latlon for first lat/lon\n");
+      *ierr = 1;
+      return;
+    }
+
+  *ierr = 0;
+  return;
+
+}
diff --git a/wrfv2_fire/external/io_grib_share/get_region_center.h b/wrfv2_fire/external/io_grib_share/get_region_center.h
new file mode 100644
index 00000000..b1d7f3ee
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/get_region_center.h
@@ -0,0 +1,14 @@
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define GET_REGION_CENTER get_region_center
+#      define GET_LL_LATLON get_ll_latlon
+# else
+#   ifdef F2CSTYLE
+#      define GET_REGION_CENTER get_region_center__
+#      define GET_LL_LATLON get_ll_latlon__
+#   else
+#      define GET_REGION_CENTER get_region_center_
+#      define GET_LL_LATLON get_ll_latlon_
+#   endif
+# endif
+#endif
diff --git a/wrfv2_fire/external/io_grib_share/gridnav.c b/wrfv2_fire/external/io_grib_share/gridnav.c
new file mode 100644
index 00000000..5fa145df
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/gridnav.c
@@ -0,0 +1,485 @@
+#include 
+#include 
+#include 
+#include "gridnav.h"
+
+#define MISSING -999
+#define PI 3.1415927
+#define RAD_TO_DEG 57.29577951
+#define EARTH_RAD 6371.200
+
+int fill_proj_parms(GridNav *gridnav);
+
+/*****************************************************************************
+ * Fills up the gridnav structure using arguments input to the function
+ *
+ * input:
+ *   central_lat - the central latitude of the projection, in degrees
+ *   central_lon - the central longitude of the projection, in degrees
+ *   projection  - the projection number (defined by #define's in gridnav.h)
+ *   truelat1    - the first "true" latitude.  Only has an effect with 
+ *                 polar stereographic and lambert projections
+ *   truelat2    - the second true latitude.  Only has an effect with lambert
+ *                 projection
+ *   num_columns - number of columns in grid
+ *   num_rows    - number of rows in grid
+ *   dx,dy       - east-west (dx) and north-south (dy) distance between grid 
+ *                 points, in degrees for latlon (i.e., cylindrical 
+ *                 equidistant) projection, in km for all other projections 
+ *                 (including mercator).
+ *   lat_origin  - latitude of grid point defined in origin_column, origin_row
+ *   lon_origin  - longitude of grid point defined in origin_column, origin_row
+ *   origin_column - column for lat_origin, long_origin pair
+ *   origin_row  - row for lat_origin, long_origin pair
+ *  
+ * output:
+ *   gridnav - filled gridnav structure
+ *
+ *****************************************************************************/
+
+int GRID_init(float central_lat, float central_lon, int projection, 
+	      float truelat1, float truelat2, int num_columns, 
+	      int num_rows, float dx, float dy, float lat_origin, 
+	      float lon_origin, float origin_column, float origin_row, 
+	      GridNav *gridnav)
+{
+
+  int status = 1;
+
+  gridnav->proj.central_lon = central_lon;
+  gridnav->proj.central_lat = central_lat;
+  gridnav->proj.map_proj = projection;
+  gridnav->proj.truelat1 = truelat1;
+  gridnav->proj.truelat2 = truelat2;
+
+  gridnav->grid.num_columns = num_columns;
+  gridnav->grid.num_rows = num_rows;
+  gridnav->grid.dx = dx;
+  gridnav->grid.dy = dy;
+  gridnav->grid.lat_origin = lat_origin;
+  gridnav->grid.lon_origin = lon_origin;
+  gridnav->grid.origin_column = origin_column;
+  gridnav->grid.origin_row = origin_row;
+
+  fill_proj_parms(gridnav);
+
+  return status;
+}
+
+/*****************************************************************************
+ * Outputs the latitude and longitude of a grid point.
+ *
+ * input:
+ *   *gridnav - a pointer to a filled gridnav structure.  The gridnav 
+ *              structure should have been filled using one of the init 
+ *              functions.
+ *   column   - the column in the grid to retrieve.
+ *   row      - the row in the grid to retrieve.
+ * 
+ * output:
+ *   *lat - pointer to output latitude
+ *   *lon - pointer to output longitude
+ *
+ *****************************************************************************/
+
+int GRID_to_latlon(GridNav *gridnav, float column, float row, float *lat, 
+		   float *lon)
+{
+    /* 
+     * Calculate the latitude and longitude for an input grid point location 
+     */
+    double X, Y, R;
+    int status = 1;
+
+    switch (gridnav->proj.map_proj)
+	{
+	case GRID_MERCATOR:
+	    *lat = 2 * RAD_TO_DEG *
+		atan(exp((gridnav->proj_transform.parm2 + gridnav->grid.dx *
+			  (row - gridnav->grid.origin_row)) /
+			 gridnav->proj_transform.parm1 )) - 90;
+	    *lon = gridnav->grid.lon_origin + RAD_TO_DEG * gridnav->grid.dx *
+		(column - gridnav->grid.origin_column) /
+		gridnav->proj_transform.parm1;
+	    break;
+
+	case GRID_LAMCON:
+	    X = (column - gridnav->grid.origin_column) * gridnav->grid.dx +
+		gridnav->proj_transform.parm6;
+	    Y = (row - gridnav->grid.origin_row) * gridnav->grid.dy +
+		gridnav->proj_transform.parm3 + gridnav->proj_transform.parm7;
+	    R = sqrt(X*X + Y*Y);
+	    *lat = gridnav->proj_transform.parm5 * 90 - 
+		2 * RAD_TO_DEG * atan(gridnav->proj_transform.parm4 * 
+				      pow(R, 1 / 
+					  gridnav->proj_transform.parm2));
+	    *lon = gridnav->proj.central_lon + 
+		RAD_TO_DEG / gridnav->proj_transform.parm2 *
+		atan(X / (gridnav->proj_transform.parm5 * -Y));
+	    while (*lon > 180) *lon -= 360;
+	    while (*lon <= -180) *lon += 360;
+	    break;
+
+	case GRID_POLSTR:
+	    X = (column - gridnav->grid.origin_column)*gridnav->grid.dx;
+	    Y = (row - gridnav->grid.origin_row)*gridnav->grid.dy + 
+		gridnav->proj_transform.parm3;
+	    R = sqrt(X*X + Y*Y);
+	    *lat = gridnav->proj_transform.parm5*90 - 2 * RAD_TO_DEG *
+		atan((gridnav->proj_transform.parm5*R/EARTH_RAD)/
+		     (1+cos(gridnav->proj_transform.parm1)));
+	    *lon = gridnav->grid.lon_origin + RAD_TO_DEG * 
+		atan(X/(gridnav->proj_transform.parm5 * -Y));
+	    while (*lon > 180) *lon -= 360;
+	    while (*lon <= -180) *lon += 360;
+	    break;
+      
+	case GRID_LATLON:
+	    *lat = (row - gridnav->grid.origin_row)*gridnav->grid.dy +
+		gridnav->grid.lat_origin;
+	    *lon = (column - gridnav->grid.origin_column)*gridnav->grid.dx +
+		gridnav->grid.lon_origin;
+	    break;
+
+	default:
+	    /* 
+	     *  Unsupported map projection: set lat-lon to no-data values. 
+	     */ 
+	    fprintf(stderr,"GRID_to_latlon: Unsupport map projection type %d\n", 
+		    gridnav->proj.map_proj); 
+	    *lon = -9999; 
+	    *lat = -9999; 
+	    status = 0; 
+	    break; 
+
+	} /* end of switch on map projection type */
+
+
+    return status;
+}
+
+
+/*****************************************************************************
+ * Outputs grid point indices, given lat/lon location.
+ *
+ * input:
+ *   *gridnav - a pointer to a filled gridnav structure.  The gridnav 
+ *              structure should have been filled using one of the init 
+ *              functions.
+ *   lat      - latitude for location
+ *   lon      - longitude for location
+ * output:
+ *   *column  - pointer to value for column
+ *   *row     - pointer to value for row
+ *
+ *****************************************************************************/
+
+int GRID_from_latlon(GridNav *gridnav, float lat, float lon, float *column, 
+		     float *row)
+{
+    double X, Y, Rs;
+    double lat_rad;
+    int status = 1;
+
+    switch (gridnav->proj.map_proj) 
+	{
+	case GRID_MERCATOR:
+	    X = gridnav->proj_transform.parm1 *
+		((lon - gridnav->grid.lon_origin) / RAD_TO_DEG);
+	    *column = gridnav->grid.origin_column + X / gridnav->grid.dx;
+	    lat_rad = lat / RAD_TO_DEG;
+	    Y = gridnav->proj_transform.parm1 * log((1 + sin(lat_rad)) / 
+						    cos(lat_rad));
+	    *row = gridnav->grid.origin_row + 
+		((Y-gridnav->proj_transform.parm2) / gridnav->grid.dy);;
+	    break;
+
+	case GRID_LAMCON:
+	    Rs = (EARTH_RAD / gridnav->proj_transform.parm2) *
+		sin(gridnav->proj_transform.parm1) *
+		pow(tan((gridnav->proj_transform.parm5 * 90 - lat) / 
+			(2 * RAD_TO_DEG))/
+		    tan(gridnav->proj_transform.parm1 / 2),
+		    gridnav->proj_transform.parm2);
+	    *row = gridnav->grid.origin_row - 
+		(1 / gridnav->grid.dy) * 
+		(gridnav->proj_transform.parm3 + 
+		 Rs * cos(gridnav->proj_transform.parm2*
+			  (lon - gridnav->proj.central_lon) / RAD_TO_DEG)) -
+		gridnav->proj_transform.parm7 / gridnav->grid.dy;
+	    *column = gridnav->grid.origin_column + 
+		( gridnav->proj_transform.parm5*
+		((Rs / gridnav->grid.dx)*
+		 sin(gridnav->proj_transform.parm2 * 
+		     (lon - gridnav->proj.central_lon) / RAD_TO_DEG) - 
+		  gridnav->proj_transform.parm6 / gridnav->grid.dx));
+	    break;
+
+	case GRID_POLSTR:
+	    Rs = EARTH_RAD * sin((gridnav->proj_transform.parm5 * 90 - lat) 
+				 / RAD_TO_DEG)*
+		((1 + cos(gridnav->proj_transform.parm1)) /
+		 (1 + cos((gridnav->proj_transform.parm5 * 90 - lat) 
+			  / RAD_TO_DEG)) );
+	    *row = gridnav->grid.origin_row - 
+		(1 / gridnav->grid.dy) * 
+		(gridnav->proj_transform.parm3 + 
+		 Rs * cos((lon - gridnav->grid.lon_origin) / RAD_TO_DEG));
+	    *column = gridnav->grid.origin_column + 
+		gridnav->proj_transform.parm5 *
+		((Rs / gridnav->grid.dx) *
+		 sin((lon - gridnav->grid.lon_origin) / RAD_TO_DEG));
+	    break;
+    
+	case GRID_LATLON:
+	    *row = ((lat - gridnav->grid.lat_origin) / gridnav->grid.dy) +
+		gridnav->grid.origin_row;
+	    /* If lon is negative, make it positive */
+	    while (lon < 0) lon += 360.;
+	    *column = ((lon - gridnav->grid.lon_origin) / gridnav->grid.dx) +
+		gridnav->grid.origin_column;
+	    break;
+
+	default:
+	    fprintf(stderr,"GRID_from_latlon: Unsupported map projection type %d\n",
+		    gridnav->proj.map_proj);
+	    *column = -9999;
+	    *row = -9999;
+	    status = 0;
+	    break;
+
+	} /* End of switch on map projection type */
+
+    return status;
+}
+
+int fill_proj_parms(GridNav *gridnav)
+{
+    double orig_lat_rad;
+    double R_orig;
+    int hemifactor;
+  
+    switch (gridnav->proj.map_proj) 
+	{
+	case GRID_MERCATOR:
+	    gridnav->proj_transform.parm1 = 
+		EARTH_RAD * cos(gridnav->proj.truelat1 / RAD_TO_DEG);
+	    orig_lat_rad = (gridnav->grid.lat_origin) / RAD_TO_DEG;
+	    gridnav->proj_transform.parm2 = 
+		gridnav->proj_transform.parm1 *
+		log((1. + sin(orig_lat_rad)) / cos(orig_lat_rad));
+	    gridnav->proj_transform.parm3 = MISSING;
+	    gridnav->proj_transform.parm4 = MISSING;
+	    gridnav->proj_transform.parm5 = MISSING;
+	    break;
+	case GRID_LAMCON:
+	    if (gridnav->proj.truelat1 >= 0) 
+		{
+		    hemifactor = 1;
+		} 
+	    else 
+		{
+		    hemifactor = -1;
+		}
+	    /* This is Psi1 in MM5 speak */
+	    gridnav->proj_transform.parm1 = 
+		hemifactor*(PI/2 - fabs(gridnav->proj.truelat1) / RAD_TO_DEG);
+	    /* This is Kappa in MM5 speak */
+            if (fabs(gridnav->proj.truelat1 - gridnav->proj.truelat2) < .01) 
+		{
+		    gridnav->proj_transform.parm2 = 
+			sin(gridnav->proj.truelat1 / RAD_TO_DEG);
+		}
+	    else 
+		{
+		    gridnav->proj_transform.parm2 = 
+			(log10(cos(gridnav->proj.truelat1 / RAD_TO_DEG)) - 
+			 log10(cos(gridnav->proj.truelat2 / RAD_TO_DEG))) /
+			(log10(tan((45 - fabs(gridnav->proj.truelat1) / 2) / RAD_TO_DEG)) - 
+			 log10(tan((45 - fabs(gridnav->proj.truelat2) / 2) / RAD_TO_DEG)));
+		}
+	    /* This is Yc in MM5 speak */
+	    gridnav->proj_transform.parm3 = 
+		-EARTH_RAD/gridnav->proj_transform.parm2 * 
+		sin(gridnav->proj_transform.parm1) *
+		pow(
+		    (tan((hemifactor * 90 - gridnav->grid.lat_origin) / 
+			 (RAD_TO_DEG * 2)) /
+		     tan(gridnav->proj_transform.parm1 / 2)),
+		    gridnav->proj_transform.parm2);
+	    gridnav->proj_transform.parm4 = 
+		tan(gridnav->proj_transform.parm1 / 2)*
+		pow(hemifactor * (gridnav->proj_transform.parm2)/
+		    (EARTH_RAD * sin(gridnav->proj_transform.parm1)),
+		    1 / gridnav->proj_transform.parm2);
+	    gridnav->proj_transform.parm5 = hemifactor;
+	    R_orig = (EARTH_RAD / gridnav->proj_transform.parm2) *
+		sin(gridnav->proj_transform.parm1) *
+		pow(tan((gridnav->proj_transform.parm5 * 90 - 
+			 gridnav->grid.lat_origin) / 
+			(2 * RAD_TO_DEG))/
+		    tan(gridnav->proj_transform.parm1 / 2),
+		    gridnav->proj_transform.parm2);
+	    /* X origin */
+	    gridnav->proj_transform.parm6 = 
+		R_orig * sin(gridnav->proj_transform.parm2 * 
+			     (gridnav->grid.lon_origin - 
+			      gridnav->proj.central_lon) / RAD_TO_DEG);
+
+	    /* Y origin */
+	    gridnav->proj_transform.parm7 = -(gridnav->proj_transform.parm3 + 
+		R_orig * cos(gridnav->proj_transform.parm2 * 
+			     (gridnav->grid.lon_origin - 
+			      gridnav->proj.central_lon) / RAD_TO_DEG));
+	    break;
+	case GRID_POLSTR:
+	    if (gridnav->proj.truelat1 > 0) 
+		{
+		    hemifactor = 1;
+		} 
+	    else 
+		{
+		    hemifactor = -1;
+		}
+
+	    /* This is Psi1 in MM5 speak */
+	    gridnav->proj_transform.parm1 = 
+		hemifactor * (PI/2 - fabs(gridnav->proj.truelat1) / RAD_TO_DEG);
+	    gridnav->proj_transform.parm2 = 
+		(1+log10(cos(gridnav->proj.truelat1 / RAD_TO_DEG))) / 
+		( -log10(tan(45 / RAD_TO_DEG - hemifactor * 
+			     gridnav->proj.truelat1 /
+			     (2 * RAD_TO_DEG) )) );
+	    /* This is Yc in MM5 speak */
+	    gridnav->proj_transform.parm3 = 
+		-EARTH_RAD * sin((hemifactor * 90 - 
+				  gridnav->grid.lat_origin) / RAD_TO_DEG)*
+		( (1 + cos(gridnav->proj_transform.parm1))/
+		  (1 + cos((hemifactor*90 - gridnav->grid.lat_origin) / 
+			   RAD_TO_DEG)) );
+	    gridnav->proj_transform.parm4 = MISSING;
+	    gridnav->proj_transform.parm5 = hemifactor;
+	    break;
+	case GRID_LATLON:
+	  gridnav->proj_transform.parm1 = MISSING;
+	  gridnav->proj_transform.parm2 = MISSING;
+	  gridnav->proj_transform.parm3 = MISSING;
+	  gridnav->proj_transform.parm4 = MISSING;
+	  gridnav->proj_transform.parm5 = MISSING;
+	  break;
+
+	default:
+	    fprintf(stderr,"GRID_init_mm5data: Invalid Projection\n");
+	    return 0;
+	}
+    return 1;
+}
+
+/*****************************************************************************
+ * Rotates u and v components of wind, from being relative to earth, to 
+ *  relative to grid.
+ *
+ * input:
+ *   *gridnav - a pointer to a filled gridnav structure.  The gridnav 
+ *              structure should have been filled using one of the init 
+ *              functions.
+ *   lon      - longitude for location
+ *   u_earth  - the u component of the wind in earth (north-relative) 
+ *              coordinates.
+ *   v_earth  - the v component of the wind in earth (north-relative) 
+ *              coordinates.
+ * output:
+ *   *u_grid  - pointer to value for u in grid coordinates
+ *   *v_grid  - pointer to value for v in grid coordinates
+ *
+ *****************************************************************************/
+
+int GRID_rotate_from_earth_coords(GridNav *gridnav, float lon, float u_earth, 
+				  float v_earth, float *u_grid, float *v_grid)
+{
+    float speed, dir;
+    float dir_grid;
+
+    /* Calculate Speed and Direction from u,v */
+    switch (gridnav->proj.map_proj) 
+	{
+	case GRID_MERCATOR:
+	    *u_grid = u_earth;
+	    *v_grid = v_earth;
+	    break;
+	case GRID_POLSTR: case GRID_LAMCON:
+	    speed = sqrt(u_earth * u_earth + v_earth * v_earth);
+	    dir = RAD_TO_DEG * atan2(-u_earth,-v_earth);
+	    while (dir >= 360) dir -= 360;
+	    while (dir < 0) dir += 360;
+	    
+	    dir_grid = dir - (lon - gridnav->proj.central_lon) * 
+		gridnav->proj_transform.parm2;
+	    while (dir_grid >= 360) dir_grid -= 360;
+	    while (dir_grid < 0) dir_grid += 360;
+	    
+	    *u_grid = -1. * speed * sin(dir_grid / RAD_TO_DEG);
+	    *v_grid = -1. * speed * cos(dir_grid / RAD_TO_DEG);
+	    break;
+	default:
+	    fprintf(stderr,
+		    "GRID_rotate_from_earth_coords: Invalid Projection\n");
+	    return 0;
+	}  /* End of switch projection */
+
+    return 1;
+}
+
+/*****************************************************************************
+ * Rotates u and v components of wind, from being relative to earth, to 
+ *  relative to grid.
+ *
+ * input:
+ *   *gridnav - a pointer to a filled gridnav structure.  The gridnav 
+ *              structure should have been filled using one of the init 
+ *              functions.
+ *   lon      - longitude for location
+ *   u_grid   - the u component of the wind in grid coordinates 
+ *   v_grid   - the v component of the wind in grid coordinates
+ *
+ * output:
+ *   *u_earth - pointer to value for u in earth-relative coordinates
+ *   *v_grid  - pointer to value for v in earth-relative coordinates
+ *
+ *****************************************************************************/
+
+int GRID_rotate_to_earth_coords(GridNav *gridnav, float lon, float u_grid, 
+				float v_grid, float *u_earth, float *v_earth)
+{
+    float speed, dir_grid;
+    float dir_earth;
+    
+    /* Calculate Speed and Direction from u,v */
+    switch (gridnav->proj.map_proj) 
+	{
+	case GRID_MERCATOR:
+	    *u_earth = u_grid;
+	    *v_earth = v_grid;
+	    break;
+	case GRID_POLSTR: case GRID_LAMCON:
+	    speed = sqrt(u_grid * u_grid + v_grid * v_grid);
+	    dir_grid = RAD_TO_DEG * atan2(-u_grid, -v_grid);
+	    while (dir_grid >= 360) dir_grid -= 360;
+	    while (dir_grid < 0) dir_grid += 360;
+	    
+	    dir_earth = dir_grid + (lon - gridnav->proj.central_lon) *
+		gridnav->proj_transform.parm2;
+	    
+	    while (dir_earth >= 360) dir_earth -= 360;
+	    while (dir_earth < 0) dir_earth += 360;
+	    
+	    *u_earth = -1. * speed * sin(dir_earth / RAD_TO_DEG);
+	    *v_earth = -1. * speed * cos(dir_earth / RAD_TO_DEG);
+	    break;
+	default:
+	    fprintf(stderr,
+		    "GRID_rotate_to_earth_coords: Invalid Projection\n");
+	    return 0;
+	}  /* End of switch projection */
+    return 1;
+}
diff --git a/wrfv2_fire/external/io_grib_share/gridnav.h b/wrfv2_fire/external/io_grib_share/gridnav.h
new file mode 100644
index 00000000..754867fd
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/gridnav.h
@@ -0,0 +1,64 @@
+/*****************************************************************************
+ * Todd Hutchinson
+ * WSI Corporation
+ * Billerica, MA
+ *****************************************************************************/
+
+/* This header contains the public interface to the GridNav API. */
+
+typedef struct {
+  float central_lat;
+  float central_lon;
+  int map_proj; 
+  float truelat1;
+  float truelat2;
+} Projection;
+
+typedef struct {
+  int num_columns;
+  int num_rows;
+  float dx;
+  float dy;
+  float lat_origin;
+  float lon_origin;
+  float origin_column;
+  float origin_row;
+} GridStruct;
+
+typedef struct {
+  double parm1;
+  double parm2;
+  double parm3;
+  double parm4;
+  double parm5;
+  double parm6;
+  double parm7;
+} ProjTransform;
+
+typedef struct {
+  Projection proj;
+  GridStruct grid;
+  ProjTransform proj_transform;
+} GridNav;
+
+
+/* Public Interface */
+
+int GRID_init(float center_lat, float center_lon, int projection, 
+	      float truelat1, float truelat2, int num_columns, 
+	      int num_rows, float dx, float dy, float lat_origin, 
+	      float lon_origin, float origin_column, float origin_row, 
+	      GridNav *gridnav);
+int GRID_to_latlon(GridNav *gridnav, float column, float row, float *lat, 
+		   float *lon);
+int GRID_from_latlon(GridNav *gridnav, float lat, float lon, float *column, 
+		     float *row);
+int GRID_rotate_from_earth_coords(GridNav *gridnav, float lon, float u_earth, 
+				  float v_earth, float *u_grid, float *v_grid);
+int GRID_rotate_to_earth_coords(GridNav *gridnav, float lon, float u_grid, 
+				float v_grid, float *u_earth, float *v_earth);
+
+#define GRID_LATLON   0
+#define GRID_MERCATOR 1
+#define GRID_LAMCON   3
+#define GRID_POLSTR   5
diff --git a/wrfv2_fire/external/io_grib_share/io_grib_share.F b/wrfv2_fire/external/io_grib_share/io_grib_share.F
new file mode 100644
index 00000000..f131f8a3
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/io_grib_share.F
@@ -0,0 +1,682 @@
+!
+! Todd Hutchinson
+! WSI
+! August 17, 2005
+!
+! Routines in this file are shared by io_grib1 and io_grib2
+!
+
+!*****************************************************************************
+
+SUBROUTINE get_dims(MemoryOrder, Start, End, ndim, x_start, x_end, y_start, &
+     y_end, z_start, z_end)
+  IMPLICIT NONE
+  CHARACTER (LEN=*)    ,INTENT(IN)    :: MemoryOrder
+  INTEGER              ,INTENT(OUT)   :: ndim,x_start,x_end,y_start
+  INTEGER              ,INTENT(OUT)   :: y_end,z_start,z_end
+  integer ,dimension(*),intent(in)    :: Start, End
+  CHARACTER (LEN=1)                   :: char
+  INTEGER                             :: idx
+  CHARACTER (LEN=3)                   :: MemoryOrderLcl
+
+  x_start = 1
+  x_end   = 1
+  y_start = 1
+  y_end   = 1
+  z_start = 1
+  z_end   = 1
+
+  !
+  ! Note: Need to add "char == 'S'" for boundary conditions
+  !
+
+  ndim = 0
+
+  ! Fix for out-of-bounds references
+  MemoryOrderLcl = '   '
+  do idx=1,len_trim(MemoryOrder)
+     MemoryOrderLcl(idx:idx) = MemoryOrder(idx:idx)
+  enddo
+  !
+  ! First, do the special boundary cases.  These do not seem to 
+  !    
+  if ((MemoryOrderLcl(1:3) .eq. 'XSZ') &
+       .or. (MemoryOrderLcl(1:3) .eq. 'XEZ')) then
+     x_start = Start(3)
+     x_end = End(3)
+     y_start = Start(1)
+     y_end = End(1)
+     z_start = Start(2)
+     z_end = End(2)
+     ndim = 3
+  else if ((MemoryOrderLcl(1:3) .eq. 'YSZ') .or. &
+       (MemoryOrderLcl(1:3) .eq. 'YEZ')) then
+     x_start = Start(1)
+     x_end = End(1)
+     y_start = Start(3)
+     y_end = End(3)
+     z_start = Start(2)
+     z_end = End(2)
+     ndim = 3
+  else if ((MemoryOrderLcl(1:2) .eq. 'YS') .or. &
+       (MemoryOrderLcl(1:2) .eq. 'YE')) then
+     x_start = Start(1)
+     x_end = End(1)
+     y_start = Start(2)
+     y_end = End(2)
+     ndim = 2
+  else if ((MemoryOrderLcl(1:2) .eq. 'XS') .or. &
+       (MemoryOrderLcl(1:2) .eq. 'XE')) then
+     x_start = Start(2)
+     x_end = End(2)
+     y_start = Start(1)
+     y_end = End(1)
+     ndim = 2
+  else if ((MemoryOrderLcl(1:1) .eq. 'C') .or. (MemoryOrderLcl(1:1) .eq. 'c')) then 
+     ! This is for "non-decomposed" fields
+     x_start = Start(1)
+     x_end = End(1)
+!     y_start = Start(2)
+!     y_end = End(2)
+!     z_start = Start(3)
+!     z_end = End(3)
+     ndim = 3
+  else
+     do idx=1,len_trim(MemoryOrderLcl)
+        char = MemoryOrderLcl(idx:idx)
+        if ((char == 'X') .or. (char == 'x')) then
+           x_start = Start(idx)
+           x_end   = End(idx)
+           ndim = ndim + 1
+        else if ((char == 'Y') .or. (char == 'y')) then
+           y_start = Start(idx)
+           y_end   = End(idx)
+           ndim = ndim + 1
+        else if ((char == 'Z') .or. (char == 'z')) then
+           z_start = Start(idx)
+           z_end   = End(idx)
+           ndim = ndim + 1
+        else if (char == '0') then
+           ! Do nothing, this indicates field is a scalar.
+           ndim = 0
+        else
+           call wrf_message('Invalid Dimension in get_dims: '//char)
+        endif
+     enddo
+  endif
+
+END SUBROUTINE get_dims
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE geth_idts (ndate, odate, idts)
+
+  IMPLICIT NONE
+
+  !  From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), 
+  !  compute the time difference.
+
+  !  on entry     -  ndate  -  the new hdate.
+  !                  odate  -  the old hdate.
+
+  !  on exit      -  idts    -  the change in time in seconds.
+
+  CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate
+  REAL              , INTENT(OUT)   :: idts
+
+  !  Local Variables
+
+  !  yrnew    -  indicates the year associated with "ndate"
+  !  yrold    -  indicates the year associated with "odate"
+  !  monew    -  indicates the month associated with "ndate"
+  !  moold    -  indicates the month associated with "odate"
+  !  dynew    -  indicates the day associated with "ndate"
+  !  dyold    -  indicates the day associated with "odate"
+  !  hrnew    -  indicates the hour associated with "ndate"
+  !  hrold    -  indicates the hour associated with "odate"
+  !  minew    -  indicates the minute associated with "ndate"
+  !  miold    -  indicates the minute associated with "odate"
+  !  scnew    -  indicates the second associated with "ndate"
+  !  scold    -  indicates the second associated with "odate"
+  !  i        -  loop counter
+  !  mday     -  a list assigning the number of days in each month
+
+  CHARACTER (LEN=24) :: tdate
+  INTEGER :: olen, nlen
+  INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew
+  INTEGER :: yrold, moold, dyold, hrold, miold, scold
+  INTEGER :: mday(12), i, newdys, olddys
+  LOGICAL :: npass, opass
+  INTEGER :: isign
+  CHARACTER (LEN=300) :: wrf_err_message
+  INTEGER :: ndfeb
+
+  IF (odate.GT.ndate) THEN
+     isign = -1
+     tdate=ndate
+     ndate=odate
+     odate=tdate
+  ELSE
+     isign = 1
+  END IF
+
+  !  Assign the number of days in a months
+
+  mday( 1) = 31
+  mday( 2) = 28
+  mday( 3) = 31
+  mday( 4) = 30
+  mday( 5) = 31
+  mday( 6) = 30
+  mday( 7) = 31
+  mday( 8) = 31
+  mday( 9) = 30
+  mday(10) = 31
+  mday(11) = 30
+  mday(12) = 31
+
+  !  Break down old hdate into parts
+
+  hrold = 0
+  miold = 0
+  scold = 0
+  olen = LEN(odate)
+
+  READ(odate(1:4),  '(I4)') yrold
+  READ(odate(6:7),  '(I2)') moold
+  READ(odate(9:10), '(I2)') dyold
+  IF (olen.GE.13) THEN
+     READ(odate(12:13),'(I2)') hrold
+     IF (olen.GE.16) THEN
+        READ(odate(15:16),'(I2)') miold
+        IF (olen.GE.19) THEN
+           READ(odate(18:19),'(I2)') scold
+        END IF
+     END IF
+  END IF
+
+  !  Break down new hdate into parts
+
+  hrnew = 0
+  minew = 0
+  scnew = 0
+  nlen = LEN(ndate)
+
+  READ(ndate(1:4),  '(I4)') yrnew
+  READ(ndate(6:7),  '(I2)') monew
+  READ(ndate(9:10), '(I2)') dynew
+  IF (nlen.GE.13) THEN
+     READ(ndate(12:13),'(I2)') hrnew
+     IF (nlen.GE.16) THEN
+        READ(ndate(15:16),'(I2)') minew
+        IF (nlen.GE.19) THEN
+           READ(ndate(18:19),'(I2)') scnew
+        END IF
+     END IF
+  END IF
+
+  !  Check that the dates make sense.
+
+  npass = .true.
+  opass = .true.
+
+  !  Check that the month of NDATE makes sense.
+
+  IF ((monew.GT.12).or.(monew.LT.1)) THEN
+     PRINT*, 'GETH_IDTS:  Month of NDATE = ', monew
+     npass = .false.
+  END IF
+
+  !  Check that the month of ODATE makes sense.
+
+  IF ((moold.GT.12).or.(moold.LT.1)) THEN
+     PRINT*, 'GETH_IDTS:  Month of ODATE = ', moold
+     opass = .false.
+  END IF
+
+  !  Check that the day of NDATE makes sense.
+
+  IF (monew.ne.2) THEN
+     ! ...... For all months but February
+     IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN
+        PRINT*, 'GETH_IDTS:  Day of NDATE = ', dynew
+        npass = .false.
+     END IF
+  ELSE IF (monew.eq.2) THEN
+     ! ...... For February
+     IF ((dynew.GT.ndfeb(yrnew)).OR.(dynew.LT.1)) THEN
+        PRINT*, 'GETH_IDTS:  Day of NDATE = ', dynew
+        npass = .false.
+     END IF
+  END IF
+
+  !  Check that the day of ODATE makes sense.
+
+  IF (moold.ne.2) THEN
+     ! ...... For all months but February
+     IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
+        PRINT*, 'GETH_IDTS:  Day of ODATE = ', dyold
+        opass = .false.
+     END IF
+  ELSE IF (moold.eq.2) THEN
+     ! ....... For February
+     IF ((dyold.GT.ndfeb(yrold)).or.(dyold.LT.1)) THEN
+        PRINT*, 'GETH_IDTS:  Day of ODATE = ', dyold
+        opass = .false.
+     END IF
+  END IF
+
+  !  Check that the hour of NDATE makes sense.
+
+  IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  Hour of NDATE = ', hrnew
+     npass = .false.
+  END IF
+
+  !  Check that the hour of ODATE makes sense.
+
+  IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  Hour of ODATE = ', hrold
+     opass = .false.
+  END IF
+
+  !  Check that the minute of NDATE makes sense.
+
+  IF ((minew.GT.59).or.(minew.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  Minute of NDATE = ', minew
+     npass = .false.
+  END IF
+
+  !  Check that the minute of ODATE makes sense.
+
+  IF ((miold.GT.59).or.(miold.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  Minute of ODATE = ', miold
+     opass = .false.
+  END IF
+
+  !  Check that the second of NDATE makes sense.
+
+  IF ((scnew.GT.59).or.(scnew.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  SECOND of NDATE = ', scnew
+     npass = .false.
+  END IF
+
+  !  Check that the second of ODATE makes sense.
+
+  IF ((scold.GT.59).or.(scold.LT.0)) THEN
+     PRINT*, 'GETH_IDTS:  Second of ODATE = ', scold
+     opass = .false.
+  END IF
+
+  IF (.not. npass) THEN
+     WRITE( wrf_err_message , * ) &
+          'module_date_time: geth_idts: Bad NDATE: ', ndate(1:nlen)
+     CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
+  END IF
+
+  IF (.not. opass) THEN
+     WRITE( wrf_err_message , * ) &
+          'module_date_time: geth_idts: Bad ODATE: ', odate(1:olen)
+     CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
+  END IF
+
+  !  Date Checks are completed.  Continue.
+
+  !  Compute number of days from 1 January ODATE, 00:00:00 until ndate
+  !  Compute number of hours from 1 January ODATE, 00:00:00 until ndate
+  !  Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
+
+  newdys = 0
+  DO i = yrold, yrnew - 1
+     newdys = newdys + (365 + (ndfeb(i)-28))
+  END DO
+
+  IF (monew .GT. 1) THEN
+     mday(2) = ndfeb(yrnew)
+     DO i = 1, monew - 1
+        newdys = newdys + mday(i)
+     END DO
+     mday(2) = 28
+  END IF
+
+  newdys = newdys + dynew-1
+
+  !  Compute number of hours from 1 January ODATE, 00:00:00 until odate
+  !  Compute number of minutes from 1 January ODATE, 00:00:00 until odate
+
+  olddys = 0
+
+  IF (moold .GT. 1) THEN
+     mday(2) = ndfeb(yrold)
+     DO i = 1, moold - 1
+        olddys = olddys + mday(i)
+     END DO
+     mday(2) = 28
+  END IF
+
+  olddys = olddys + dyold-1
+
+  !  Determine the time difference in seconds
+
+  idts = (newdys - olddys) * 86400
+  idts = idts + (hrnew - hrold) * 3600
+  idts = idts + (minew - miold) * 60
+  idts = idts + (scnew - scold)
+
+  IF (isign .eq. -1) THEN
+     tdate=ndate
+     ndate=odate
+     odate=tdate
+     idts = idts * isign
+  END IF
+
+END SUBROUTINE geth_idts
+
+!*****************************************************************************
+
+SUBROUTINE get_vert_stag(VarName,Stagger,vert_stag)
+  
+  character (LEN=*) :: VarName
+  character (LEN=*) :: Stagger
+  logical           :: vert_stag
+
+  if ((index(Stagger,'Z') > 0) .or. (VarName .eq. 'DNW') &
+       .or.(VarName .eq. 'RDNW')) then
+     vert_stag = .true.
+  else
+     vert_stag = .false.
+  endif
+end SUBROUTINE
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION ndfeb ( year ) RESULT (num_days)
+  
+  ! Compute the number of days in February for the given year
+  
+  IMPLICIT NONE
+  
+  INTEGER :: year
+  INTEGER :: num_days
+  
+  num_days = 28 ! By default, February has 28 days ...
+  IF (MOD(year,4).eq.0) THEN  
+     num_days = 29  ! But every four years, it has 29 days ...
+     IF (MOD(year,100).eq.0) THEN
+        num_days = 28  ! Except every 100 years, when it has 28 days ...
+        IF (MOD(year,400).eq.0) THEN
+           num_days = 29  ! Except every 400 years, when it has 29 days.
+        END IF
+     END IF
+  END IF
+  
+END FUNCTION ndfeb
+
+!*****************************************************************************
+
+SUBROUTINE get_dimvals(MemoryOrder,x,y,z,dims)
+
+  IMPLICIT NONE
+  CHARACTER (LEN=*)    ,INTENT(IN)    :: MemoryOrder
+  INTEGER              ,INTENT(IN)    :: x,y,z
+  INTEGER, DIMENSION(*),INTENT(OUT)   :: dims
+  INTEGER                             :: idx
+  CHARACTER (LEN=1) :: char
+  CHARACTER (LEN=3) :: MemoryOrderLcl
+
+  dims(1) = 1
+  dims(2) = 1
+  dims(3) = 1
+
+  ! Fix for out-of-bounds references
+  MemoryOrderLcl = '   '
+  do idx=1,len_trim(MemoryOrder)
+     MemoryOrderLcl(idx:idx) = MemoryOrder(idx:idx)
+  enddo
+
+  !
+  ! Note: Need to add "char == 'S'" for boundary conditions
+  !
+
+  if ((MemoryOrderLcl(1:3) .eq. 'XSZ') &
+       .or. (MemoryOrderLcl(1:3) .eq. 'XEZ')) then
+     dims(1) = y
+     dims(2) = z
+     dims(3) = x
+  else if ((MemoryOrderLcl(1:3) .eq. 'YSZ') .or. &
+       (MemoryOrderLcl(1:3) .eq. 'YEZ')) then
+     dims(1) = x
+     dims(2) = z
+     dims(3) = y
+  else if ((MemoryOrderLcl(1:2) .eq. 'YS') .or. &
+       (MemoryOrderLcl(1:2) .eq. 'YE')) then
+     dims(1) = x
+     dims(2) = y
+     dims(3) = z
+  else if ((MemoryOrderLcl(1:2) .eq. 'XS') .or. &
+       (MemoryOrderLcl(1:2) .eq. 'XE')) then
+     dims(1) = y
+     dims(2) = x
+     dims(3) = z
+  else if ((MemoryOrderLcl(1:1) .eq. 'C') .or. &
+       (MemoryOrderLcl(1:1) .eq. 'c')) then
+     ! Non-decomposed field
+     dims(1) = x
+     dims(2) = y
+     dims(3) = z
+  else 
+     do idx=1,len_trim(MemoryOrderLcl)
+        char = MemoryOrderLcl(idx:idx)
+        if ((char == 'X') .or. (char == 'x')) then
+           dims(idx) = x
+        else if ((char == 'Y') .or. (char == 'y')) then
+           dims(idx) = y
+        else if ((char == 'Z') .or. (char == 'z')) then
+           dims(idx) = z
+        else if (char == '0') then
+           ! This is a scalar, do nothing.
+        else
+           call wrf_message ('Invalid Dimension in get_dimvals: '//char)
+        endif
+     enddo
+  endif
+
+END SUBROUTINE get_dimvals
+
+!*****************************************************************************
+
+SUBROUTINE get_soil_layers(VarName,soil_layers)
+  
+  character (LEN=*) :: VarName
+  logical           :: soil_layers
+
+  if ((VarName .eq. 'ZS') .or. (VarName .eq. 'DZS') &
+       .or.(VarName .eq. 'TSLB') .or. (VarName .eq. 'SMOIS') &
+       .or. (VarName .eq. 'SH2O') .or. (VarName .eq. 'KEEPFR3DFLAG') &
+       .or. (VarName .eq. 'SMFR3D')) then
+     soil_layers = .true.
+  else
+     soil_layers = .false.
+  endif
+end SUBROUTINE
+
+!*****************************************************************************
+
+SUBROUTINE Transpose(MemoryOrder, di, FieldType, Field, &
+     Start1, End1, Start2, End2, Start3, End3, data, zidx, numrows, numcols)
+
+  IMPLICIT NONE
+
+#include "wrf_io_flags.h"
+
+  CHARACTER (LEN=*),INTENT(IN)    :: MemoryOrder
+  INTEGER          ,INTENT(IN)    :: Start1,End1,Start2,End2,Start3,End3
+  INTEGER          ,INTENT(IN)    :: di
+  integer          ,intent(inout) :: &
+       Field(di,Start1:End1,Start2:End2,Start3:End3)
+  INTEGER          ,intent(in)    :: FieldType
+  real             ,intent(in)    :: data(*)
+  INTEGER          ,INTENT(IN)    :: zidx, numcols, numrows
+  INTEGER, DIMENSION(3)           :: dims
+  INTEGER                         :: col, row
+  LOGICAL                         :: logicaltype
+  CHARACTER (LEN=1000)            :: msg
+     
+  if ((FieldType == WRF_REAL) .or. (FieldType == WRF_DOUBLE)) then
+     do col=1,numcols
+        do row=1,numrows
+           call get_dimvals(MemoryOrder,col,row,zidx,dims)
+           Field(1:di,dims(1),dims(2),dims(3)) = &
+                TRANSFER(data((row-1)*numcols+col),Field,1)
+        enddo
+     enddo
+  else if (FieldType == WRF_INTEGER) then
+     do col=1,numcols
+        do row=1,numrows
+           call get_dimvals(MemoryOrder,col,row,zidx,dims)
+           Field(1:di,dims(1),dims(2),dims(3)) = data((row-1)*numcols+col)
+        enddo
+     enddo
+  else
+     write (msg,*)'Reading of type ',FieldType,'from grib data not supported'
+     call wrf_message(msg)
+  endif
+
+!
+! This following seciton is for the logical type.  This caused some problems
+!   on certain platforms.
+! 
+!  else if (FieldType == WRF_LOGICAL) then
+!     do col=1,numcols
+!        do row=1,numrows
+!           call get_dimvals(MemoryOrder,col,row,zidx,dims)
+!           Field(1:di,dims(1),dims(2),dims(3)) = &
+!                TRANSFER(data((row-1)*numcols+col),logicaltype,1)
+!        enddo
+!     enddo
+  
+  
+end SUBROUTINE
+
+!*****************************************************************************
+
+SUBROUTINE Transpose1D(MemoryOrder, di, FieldType, Field, &
+     Start1, End1, Start2, End2, Start3, End3, data, nelems)
+
+  IMPLICIT NONE
+
+#include "wrf_io_flags.h"
+
+  CHARACTER (LEN=*),INTENT(IN)    :: MemoryOrder
+  INTEGER          ,INTENT(IN)    :: Start1,End1,Start2,End2,Start3,End3
+  INTEGER          ,INTENT(IN)    :: di
+  integer          ,intent(inout) :: &
+       Field(di,Start1:End1,Start2:End2,Start3:End3)
+  INTEGER          ,intent(in)    :: FieldType
+  real             ,intent(in)    :: data(*)
+  LOGICAL                         :: logicaltype
+  CHARACTER (LEN=1000)            :: msg
+  integer                         :: elemnum,nelems
+
+  if ((FieldType == WRF_REAL) .or. (FieldType == WRF_DOUBLE)) then
+     do elemnum=1,nelems
+        Field(1:di,elemnum,1,1) = TRANSFER(data(elemnum),Field,1)
+     enddo
+  else if (FieldType == WRF_INTEGER) then
+     do elemnum=1,nelems
+        Field(1:di,elemnum,1,1) = TRANSFER(data(elemnum),Field,1)
+     enddo
+  else
+     write (msg,*)'Reading of type ',FieldType,'from grib1 data not supported'
+     call wrf_message(msg)
+  endif
+
+!
+! This following seciton is for the logical type.  This caused some problems
+!   on certain platforms.
+! 
+!  else if (FieldType == WRF_LOGICAL) then
+!     do col=1,numcols
+!        do row=1,numrows
+!           call get_dimvals(MemoryOrder,col,row,zidx,dims)
+!           Field(1:di,dims(1),dims(2),dims(3)) = &
+!                TRANSFER(data((row-1)*numcols+col),logicaltype,1)
+!        enddo
+!     enddo
+  
+  
+end SUBROUTINE Transpose1D
+
+!*****************************************************************************
+!
+! Takes a starting date (startTime) in WRF format (yyyy-mm-dd_hh:mm:ss), 
+!   adds an input number of seconds to the time, and outputs a new date 
+!   (endTime) in WRF format.
+!
+!*****************************************************************************
+
+subroutine advance_wrf_time(startTime, addsecs, endTime)
+  implicit none
+
+  integer          , intent(in)  :: addsecs
+  character (len=*), intent(in)  :: startTime
+  character (len=*), intent(out) :: endTime
+  integer :: syear,smonth,sday,shour,smin,ssec
+  integer :: days_in_month(12)
+
+  read(startTime,'(I4.4,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2)') &
+       syear,smonth,sday,shour,smin,ssec
+  
+  ssec = ssec + addsecs
+
+  do while (ssec .ge. 60) 
+     smin = smin + 1
+     ssec = ssec - 60
+  enddo
+
+  do while (smin .ge. 60)
+     shour = shour + 1
+     smin = smin - 60
+  enddo
+
+  do while (shour .ge. 24)
+     sday = sday + 1
+     shour = shour - 24
+  enddo
+
+
+  days_in_month(1) = 31
+  if (((mod(syear,4) .eq. 0) .and. (mod(syear,100) .ne. 0)) &
+       .or. (mod(syear,400) .eq. 0)) then
+     days_in_month(2) = 29
+  else
+     days_in_month(2) = 28
+  endif
+  days_in_month(3) = 31
+  days_in_month(4) = 30
+  days_in_month(5) = 31
+  days_in_month(6) = 30
+  days_in_month(7) = 31
+  days_in_month(8) = 31
+  days_in_month(9) = 30
+  days_in_month(10) = 31
+  days_in_month(11) = 30
+  days_in_month(12) = 31
+
+
+  do while (sday .gt. days_in_month(smonth))
+     sday = sday - days_in_month(smonth)
+     smonth = smonth + 1
+     if (smonth .gt. 12) then
+        smonth = 1
+        syear = syear + 1
+     endif
+  enddo
+  
+
+  write(endTime,'(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') &
+       syear,'-',smonth,'-',sday,'_',shour,':',smin,':',ssec
+
+  return
+
+end subroutine
diff --git a/wrfv2_fire/external/io_grib_share/open_file.c b/wrfv2_fire/external/io_grib_share/open_file.c
new file mode 100644
index 00000000..2bb44e39
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/open_file.c
@@ -0,0 +1,109 @@
+#include 
+#include 
+#include 
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define OPEN_FILE open_file
+#      define CLOSE_FILE close_file
+#      define WRITE_FILE write_file
+#      define WRITE_FILE_N write_file_n
+#      define FLUSH_FILE flush_file
+# else
+#   ifdef F2CSTYLE
+#      define OPEN_FILE open_file__
+#      define CLOSE_FILE close_file__
+#      define WRITE_FILE write_file__
+#      define WRITE_FILE_N write_file_n__
+#      define FLUSH_FILE flush_file__
+#   else
+#      define OPEN_FILE open_file_
+#      define CLOSE_FILE close_file_
+#      define WRITE_FILE write_file_
+#      define WRITE_FILE_N write_file_n_
+#      define FLUSH_FILE flush_file_
+#   endif
+# endif
+#endif
+
+/* 
+ * Fortran-callable function to open/close files
+ */
+int OPEN_FILE (char *filename, char *permissions, int *outfd, int *ierr, 
+	       int strlen1, int strlen2)
+{
+  char filename2[1000];
+  char permstring[1000];
+  int permvals;
+
+  strncpy(filename2,filename,strlen1);
+  filename2[strlen1]='\0';
+
+  strncpy(permstring,permissions,strlen2);
+  permstring[strlen2]='\0';
+
+  if (strcmp(permstring,"w") == 0) {
+    permvals = O_CREAT|O_WRONLY|O_TRUNC;
+  } else {
+    permvals = O_RDONLY;
+  }
+
+  *outfd = open(filename2,permvals,0644);
+  if (*outfd == -1) 
+    {
+      fprintf(stderr,"setting ierr to -1, filename: %s\n",filename);
+      perror("");
+      *ierr = -1;
+      return -1;
+    }
+  else
+    {
+      *ierr = 0;
+      return 0;
+    }
+}
+
+int WRITE_FILE(int *fd, char *buf, int *ierr, int strlen)
+{
+  int nbytes;
+
+  nbytes = write(*fd,buf,strlen);
+  if (nbytes != strlen)
+    {
+      *ierr = -1;
+    }
+  else
+    {
+      *ierr = 0;
+    }
+  return *ierr;
+}
+
+int WRITE_FILE_N(int *fd, char *buf, int *nbytes, int *ierr)
+{
+  int bytes_written;
+
+  bytes_written = write(*fd,buf,*nbytes);
+  if (bytes_written != *nbytes)
+    {
+      *ierr = -1;
+    }
+  else
+    {
+      *ierr = 0;
+    }
+  return *ierr;
+}
+
+int CLOSE_FILE (int *fd)
+{
+  close(*fd);
+  return 0;
+}
+
+int FLUSH_FILE (int *fd)
+{
+  fsync(*fd);
+  return 0;
+}
+
diff --git a/wrfv2_fire/external/io_grib_share/wrf_io_flags.h b/wrfv2_fire/external/io_grib_share/wrf_io_flags.h
new file mode 100644
index 00000000..708939f9
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/wrf_io_flags.h
@@ -0,0 +1,16 @@
+      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
+#ifdef PROMOTE_FLOAT 
+      integer, parameter  :: WRF_FLOAT=WRF_DOUBLE
+#else      
+      integer, parameter  :: WRF_FLOAT=WRF_REAL
+#endif      
+      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
diff --git a/wrfv2_fire/external/io_grib_share/wrf_projection.h b/wrfv2_fire/external/io_grib_share/wrf_projection.h
new file mode 100644
index 00000000..5c315522
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/wrf_projection.h
@@ -0,0 +1,4 @@
+#define WRF_LATLON 0
+#define WRF_LAMBERT 1
+#define WRF_POLAR_STEREO 2
+#define WRF_MERCATOR 3
diff --git a/wrfv2_fire/external/io_grib_share/wrf_status_codes.h b/wrfv2_fire/external/io_grib_share/wrf_status_codes.h
new file mode 100644
index 00000000..008ac5ce
--- /dev/null
+++ b/wrfv2_fire/external/io_grib_share/wrf_status_codes.h
@@ -0,0 +1,142 @@
+  
+!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
+
+  integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE        = -401
+  integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL          = -402
+  integer, parameter :: WRF_GRIB2_ERR_ADDGRIB           = -403
+  integer, parameter :: WRF_GRIB2_ERR_ADDFIELD          = -404
+  integer, parameter :: WRF_GRIB2_ERR_GRIBEND           = -405
+  integer, parameter :: WRF_GRIB2_ERR_WRITE             = -406
+  integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP          = -407
+  integer, parameter :: WRF_GRIB2_ERR_GETGB2            = -408
+  integer, parameter :: WRF_GRIB2_ERR_READ              = -409
diff --git a/wrfv2_fire/external/io_int/diffwrf.F b/wrfv2_fire/external/io_int/diffwrf.F
new file mode 100644
index 00000000..acd3c755
--- /dev/null
+++ b/wrfv2_fire/external/io_int/diffwrf.F
@@ -0,0 +1,459 @@
+module read_util_module
+
+#ifdef crayx1
+#define iargc ipxfargc
+#endif
+
+contains
+
+#ifdef crayx1
+   subroutine getarg(i, harg)
+     implicit none
+     character(len=*) :: harg
+     integer :: ierr, ilen, i
+
+     call pxfgetarg(i, harg, ilen, ierr)
+     return
+   end subroutine getarg
+#endif
+
+   subroutine arguments(v2file, lmore)
+     implicit none
+     character(len=*) :: v2file
+     character(len=120) :: harg
+     logical :: lmore
+   
+     integer :: ierr, i, numarg
+     integer, external :: iargc
+   
+     numarg = iargc()
+   
+     i = 1
+     lmore = .false.
+   
+     do while ( i < numarg) 
+        call getarg(i, harg)
+        print*, 'harg = ', trim(harg)
+   
+        if (harg == "-v") then
+           i = i + 1
+           lmore = .true.
+        elseif (harg == "-h") then
+           call help
+        endif
+   
+     enddo
+   
+     call getarg(i,harg)
+     v2file = harg
+   end subroutine arguments
+   
+   subroutine help
+     implicit none
+     character(len=120) :: cmd
+     call getarg(0, cmd)
+   
+     write(*,'(/,"Usage: ", A, " [-v] v2file ")') trim(cmd)
+     write(*,'(8x, "-v     : Print extra info")')
+     write(*,'(8x, "v3file : MM5v3 file name to read.")')
+     write(*,'(8x, "-h     : print this help message and exit.",/)')
+     stop
+   end subroutine help
+end module read_util_module
+
+ program readv3
+  use read_util_module
+  use module_ext_internal
+  implicit none
+#include "wrf_status_codes.h"
+#include "wrf_io_flags.h"
+  character(len=120) :: flnm
+  character(len=120) :: flnm2
+  character(len=120) :: arg3
+  character(len=19) :: DateStr
+  character(len=19) :: DateStr2
+  character(len=31) :: VarName
+  character(len=31) :: VarName2
+  integer dh1, dh2
+
+  integer :: flag, flag2
+  integer :: iunit, iunit2
+  integer :: WrfType, WrfType2
+
+  integer :: i,j,k
+  integer :: levlim
+  integer :: cross
+  integer :: ndim, ndim2
+  real :: time, time2
+  real*8 :: a, b
+  real*8 :: sumE, sum1, sum2, diff1, diff2, serr, perr, rmse, rms1, rms2, tmp1, tmp2
+  integer digits,d1, d2
+  integer, dimension(4) :: start_index, end_index, start_index2, end_index2
+  integer , Dimension(3) :: MemS,MemE,PatS,PatE
+  character (len= 4) :: staggering,   staggering2
+  character (len= 3) :: ordering,     ordering2, ord
+  character (len=24) :: start_date,   start_date2
+  character (len=24) :: current_date, current_date2
+  character (len=31) :: name,         name2,  tmpname
+  character (len=25) :: units,        units2
+  character (len=46) :: description,  description2
+
+  character (len=80), dimension(3)  ::  dimnames
+
+  integer :: l, n
+  integer :: ikdiffs, ifdiffs
+
+  real, allocatable, dimension(:,:,:,:) :: data,data2
+
+  integer :: ierr, ierr2, ier, ier2, Status, Status_next_time, Status_next_time2, Status_next_var, Status_next_var_2
+
+  logical :: newtime = .TRUE.
+  logical :: justplot, efound
+
+  integer, external :: iargc
+  logical, external :: iveceq
+
+  levlim = -1
+
+  call ext_int_ioinit(' ', Status)
+
+  Justplot = .false.
+! get arguments
+  if ( iargc() .ge. 2 ) then
+    call getarg(1,flnm)
+    call getarg(2,flnm2)
+    ierr = 0
+    call ext_int_open_for_read( trim(flnm), 0, 0, "", dh1, Status)
+    if ( Status /= 0 ) then 
+      print*,'error opening ',flnm, ' Status = ', Status ; stop
+    endif
+    call ext_int_open_for_read( trim(flnm2), 0, 0, "", dh2, Status)
+    if ( Status /= 0 ) go to 923
+    goto 924
+923    continue
+
+! bounce here if second name is not openable -- this would mean that
+! it is a field name instead.
+
+    print*,'could not open ',flnm2
+    name = flnm2
+    Justplot = .true.
+924    continue
+  if ( iargc() .eq. 3 ) then
+    call getarg(3,arg3)
+    read(arg3,*)levlim
+    print*,'LEVLIM = ',LEVLIM
+  endif
+  else
+     print*,'Usage: command file1 file2'
+     stop
+  endif
+
+print*,'Just plot ',Justplot
+
+if ( Justplot ) then
+  print*, 'flnm = ', trim(flnm)
+
+   call ext_int_get_next_time(dh1, DateStr, Status_next_time)
+
+   DO WHILE ( Status_next_time .eq. 0 )
+    write(*,*)'Next Time ',TRIM(Datestr)
+    call ext_int_get_next_var (dh1, VarName, Status_next_var)
+    DO WHILE ( Status_next_var .eq. 0 )
+!    write(*,*)'Next Var |',TRIM(VarName),'|'
+
+      start_index = 1
+      end_index = 1
+      call ext_int_get_var_info (dh1,VarName,ndim,ordering,staggering,start_index,end_index, WrfType, ierr )
+      if(WrfType /= WRF_REAL .AND. WrfType /= WRF_DOUBLE) then
+        call ext_int_get_next_var (dh1, VarName, Status_next_var)
+        cycle
+      endif
+
+      write(*,'(A9,1x,I1,3(1x,I5),1x,A,1x,A)')&
+               VarName, ndim, end_index(1), end_index(2), end_index(3), &
+               trim(ordering), trim(DateStr)
+
+      if ( VarName .eq. name ) then
+        write(*,*)'Writing fort.88 file for ', trim(name)
+
+        allocate(data(end_index(1), end_index(2), end_index(3), 1))
+
+        if ( ndim .eq. 3 ) then
+          ord = 'XYZ'
+        else if ( ndim .eq. 2 ) then
+          ord = 'XY'
+        else if ( ndim .eq. 1 ) then
+          ord = 'Z'
+        else if ( ndim .eq. 0 ) then
+          ord = '0'
+        endif
+
+        call ext_int_read_field(dh1,DateStr,TRIM(name),data,WRF_REAL,0,0,0,ord,   &
+                            staggering,          &
+                            dimnames,         &
+                            start_index,end_index,                      & !dom              
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+
+        if ( ierr/=0 ) then
+             write(*,*)'error reading data record'
+             write(*,*)'  ndim = ', ndim
+             write(*,*)'  end_index(1) ',end_index(1)
+             write(*,*)'  end_index(2) ',end_index(2)
+             write(*,*)'  end_index(3) ',end_index(3)
+        endif
+
+
+        IF ( ndim .eq. 3 ) THEN
+        do k = start_index(2), end_index(2)
+          if ( levlim .eq. -1 .or. k .eq. levlim ) then
+            write(88,*)end_index(1),end_index(3),' ',trim(name),' ',k,' time ',n
+            do j = 1, end_index(3)
+              do i = 1, end_index(1)
+                write(88,*) data(i,k,j,1)
+              enddo
+            enddo
+          endif
+        enddo
+        ELSE IF ( ndim .eq. 2 ) THEN
+            k = 1
+            write(88,*)end_index(1),end_index(2),' ',trim(name),' ',k,' time ',n
+            do j = 1, end_index(2)
+              do i = 1, end_index(1)
+                write(88,*) data(i,j,1,1)
+              enddo
+            enddo
+        ENDIF
+        deallocate(data)
+      endif
+      call ext_int_get_next_var (dh1, VarName, Status_next_var)
+    enddo
+    call ext_int_get_next_time(dh1, DateStr, Status_next_time)
+  enddo
+else
+  print*,'Diffing ',trim(flnm),' ',trim(flnm2)
+
+  call ext_int_get_next_time(dh1, DateStr, Status_next_time)
+  call ext_int_get_next_time(dh2, DateStr2, Status_next_time2)
+
+  IF ( DateStr .NE. DateStr2 ) THEN
+    print*,'They differ big time.  Dates do not match'
+    print*,'   ',flnm,' ',DateStr
+    print*,'   ',flnm2,' ',DateStr2
+    Status_next_time = 1
+  ENDIF
+
+  DO WHILE ( Status_next_time .eq. 0 .AND. Status_next_time2 .eq. 0 )
+!write(*,*)'Next Time ',TRIM(Datestr)
+    print 76
+    call ext_int_get_next_var (dh1, VarName, Status_next_var)
+    call ext_int_get_next_var (dh2, VarName, Status_next_var)
+    DO WHILE ( Status_next_var .eq. 0 )
+
+!write(*,*)'Next Var |',TRIM(VarName),'|'
+
+      start_index = 1
+      end_index = 1
+      call ext_int_get_var_info (dh1,VarName,ndim,ordering,staggering,start_index,end_index, WrfType, ierr )
+      call ext_int_get_var_info (dh2,VarName,ndim2,ordering2,staggering2,start_index2,end_index2, WrfType2, ierr2 )
+
+!write(*,*)'ierr , err2 ',TRIM(VarName), ierr , ierr2, ' ',ordering, ' ', ordering2
+
+      IF ( ierr /= 0 ) THEN
+        write(*,*)'Big difference: ',VarName,' not found in ',flnm2
+        GOTO 1234
+      ENDIF
+      IF ( ndim /= ndim2 ) THEN
+        write(*,*)'Big difference: Number of dimensions for ',Varname,' differs in ',flnm2,'(',ndim,') /= (',ndim2
+        GOTO 1234
+      ENDIF
+
+      IF ( WrfType /= WrfType2 ) THEN
+        write(*,*)'Big difference: The types do not match', WrfType, WrfType2
+        GOTO 1234
+      ENDIF
+
+      if( WrfType == WRF_REAL) then
+
+        DO i = 1, ndim
+          IF ( end_index(i) /= end_index2(i) ) THEN
+            write(*,*)'Big difference: dim ',i,' lengths differ for ',Varname,' differ in ',flnm2
+            GOTO 1234
+          ENDIF
+        ENDDO
+
+        DO i = ndim+1,3
+          start_index(i) = 1
+          end_index(i) = 1
+          start_index2(i) = 1
+          end_index2(i) = 1
+        ENDDO
+
+!      write(*,'(A9,1x,I1,3(1x,I3),1x,A,1x,A)')&
+!               VarName, ndim, end_index(1), end_index(2), end_index(3), &
+!               trim(ordering), trim(DateStr)
+
+        allocate(data (end_index(1), end_index(2), end_index(3), 1))
+        allocate(data2(end_index(1), end_index(2), end_index(3), 1))
+
+        if ( ndim .eq. 3 ) then
+          ord = 'XYZ'
+        else if ( ndim .eq. 2 ) then
+          ord = 'XY'
+        else if ( ndim .eq. 1 ) then
+          ord = 'Z'
+        else if ( ndim .eq. 0 ) then
+          ord = '0'
+        endif
+
+        call ext_int_read_field(dh1,DateStr,TRIM(VarName),data,WRF_REAL,0,0,0,ord,   &
+                            staggering,          &
+                            dimnames,         &
+                            start_index,end_index,                      & !dom              
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+
+        IF ( ierr /= 0 ) THEN
+          write(*,*)'Error reading ',Varname,' from ',flnm
+          write(*,*)'  ndim = ', ndim
+          write(*,*)'  end_index(1) ',end_index(1)
+          write(*,*)'  end_index(2) ',end_index(2)
+          write(*,*)'  end_index(3) ',end_index(3)
+        ENDIF
+
+        call ext_int_read_field(dh2,DateStr,TRIM(VarName),data2,WRF_REAL,0,0,0,ord,   &
+                            staggering,          &
+                            dimnames,         &
+                            start_index,end_index,                      & !dom              
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+
+        IF ( ierr /= 0 ) THEN
+          write(*,*)'Error reading ',Varname,' from ',flnm2
+          write(*,*)'  ndim = ', ndim
+          write(*,*)'  end_index(1) ',end_index(1)
+          write(*,*)'  end_index(2) ',end_index(2)
+          write(*,*)'  end_index(3) ',end_index(3)
+        ENDIF
+
+        IFDIFFS=0
+        sumE = 0.0
+        sum1 = 0.0
+        sum2 = 0.0
+        diff1 = 0.0
+        diff2 = 0.0
+        n = 0
+        DO K = 1,end_index(3)-start_index(3)+1
+         IF (LEVLIM.EQ.-1.OR.K.EQ.LEVLIM.OR.NDIM.eq.2) THEN
+          cross = 0 
+          IKDIFFS = 0
+          do i = 1, end_index(1)-cross
+            do j = 1, end_index(2)-cross
+              a = data(I,J,K,1)
+              b = data2(I,J,K,1)
+              ! borrowed from  Thomas Oppe's comp program
+              sumE = sumE + ( a - b ) * ( a - b )
+              sum1 = sum1 + a * a
+              sum2 = sum2 + b * b
+              diff1 = max ( diff1 , abs ( a - b ) )
+              diff2 = max ( diff2 , abs ( b ) )
+              n = n + 1
+              IF (a .ne. b) then
+                IKDIFFS = IKDIFFS + 1
+                IFDIFFS = IFDIFFS + 1
+              ENDIF
+            ENDDO
+          ENDDO
+         ENDIF
+        enddo
+        rmsE = sqrt ( sumE / dble( n ) )
+        rms1 = sqrt ( sum1 / dble( n ) )
+        rms2 = sqrt ( sum2 / dble( n ) )
+        serr = 0.0
+        IF ( sum2 .GT. 0.0d0 ) THEN
+          serr = sqrt ( sumE / sum2 )
+        ELSE
+          IF ( sumE .GT. 0.0d0 ) serr = 1.0
+        ENDIF
+        perr = 0.0
+        IF ( diff2 .GT. 0.0d0 ) THEN
+          perr = diff1/diff2
+        ELSE
+          IF ( diff1 .GT. 0.0d0 ) perr = 1.0
+        ENDIF
+
+        digits = 0
+        IF ( rms1 - rms2 .EQ. 0.0d0 ) THEN
+          digits = 15
+        ENDIF
+        IF ( rms2 .NE. 0 ) THEN
+          tmp1 = 1.0d0/( ( abs( rms1 - rms2 ) ) / rms2 )
+          IF ( tmp1 .NE. 0 ) THEN
+            digits = log10(tmp1)
+          ENDIF
+        ENDIF
+
+        IF (IFDIFFS .NE. 0 ) THEN
+           ! create the fort.88 and fort.98 files because regression scripts will
+           ! look for these to see if there were differences.
+           write(88,*)trim(varname)
+           write(98,*)trim(varname)
+           PRINT 77,trim(varname), IFDIFFS, ndim, rms1, rms2, digits, rmsE, perr
+ 76 FORMAT (5x,'Field ',2x,'Ndifs',4x,'Dims ',6x,'RMS (1)',12x,'RMS (2)',5x,'DIGITS',4x,'RMSE',5x,'pntwise max')
+ 77 FORMAT ( A10,1x,I9,2x,I3,1x,e18.10,1x,e18.10,1x,i3,1x,e12.4,1x,e12.4 )
+        ENDIF
+        deallocate(data)
+        deallocate(data2)
+
+      endif
+1234  CONTINUE
+      call ext_int_get_next_var (dh1, VarName, Status_next_var)
+      call ext_int_get_next_var (dh2, VarName, Status_next_var)
+    enddo
+    call ext_int_get_next_time(dh1, DateStr, Status_next_time)
+    call ext_int_get_next_time(dh2, DateStr2, Status_next_time2)
+    IF ( DateStr .NE. DateStr2 ) THEN
+      print*,'They differ big time.  Dates do not match'
+      print*,'They differ big time.  Dates do not match'
+      print*,'   ',flnm,' ',DateStr
+      print*,'   ',flnm2,' ',DateStr2
+      Status_next_time = 1
+    ENDIF
+  enddo
+
+endif
+
+end program readv3
+
+logical function iveceq( a, b, n )
+  implicit none
+  integer n
+  integer a(n), b(n)
+  integer i
+  iveceq = .true.
+  do i = 1,n
+    if ( a(i) .ne. b(i) ) iveceq = .false.
+  enddo
+  return
+end function iveceq
+
+
+! stubs for routines called by module_wrf_error (used by this implementation of IO api)
+SUBROUTINE wrf_abort
+  STOP
+END SUBROUTINE wrf_abort
+
+SUBROUTINE get_current_time_string( time_str )
+  CHARACTER(LEN=*), INTENT(OUT) :: time_str
+  time_str = ''
+END SUBROUTINE get_current_time_string
+
+SUBROUTINE get_current_grid_name( grid_str )
+  CHARACTER(LEN=*), INTENT(OUT) :: grid_str
+  grid_str = ''
+END SUBROUTINE get_current_grid_name
+
diff --git a/wrfv2_fire/external/io_int/io_int.F90 b/wrfv2_fire/external/io_int/io_int.F90
new file mode 100644
index 00000000..1b0a0fd2
--- /dev/null
+++ b/wrfv2_fire/external/io_int/io_int.F90
@@ -0,0 +1,1641 @@
+! (old comment from when this file was a template)
+! This is a template for adding a package-dependent implemetnation of
+! the I/O API.  You can use the name xxx since that is already set up
+! as a placeholder in module_io.F, md_calls.m4, and the Registry, or
+! you can change the name here and in those other places.  For additional
+! information on adding a package to WRF, see the latest version of the
+! WRF Design and Implementation Document 1.1 (Draft). June 21, 2001
+!
+! Uses header manipulation routines in module_io_quilt.F
+!
+
+MODULE module_ext_internal
+
+  USE module_internal_header_util
+
+  INTEGER, PARAMETER :: int_num_handles = 99
+  LOGICAL, DIMENSION(int_num_handles) :: okay_for_io, int_handle_in_use, okay_to_commit
+  INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write
+! 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, DIMENSION(int_num_handles) :: first_operation
+! TBH:  file_status is checked by routines that call the WRF IOAPI.  It is not 
+! TBH:  yet cleanly integrated with okay_for_io, int_handle_in_use, 
+! TBH:  okay_to_commit.  Fix this later...  
+  INTEGER, DIMENSION(int_num_handles) :: file_status
+! TBH:  This flag goes along with file_status and is set as early as possible.  
+  LOGICAL, DIMENSION(int_num_handles) :: file_read_only
+  CHARACTER*128, DIMENSION(int_num_handles) :: CurrentDateInFile
+  REAL, POINTER    :: int_local_output_buffer(:)
+  INTEGER          :: int_local_output_cursor
+
+  INTEGER, PARAMETER           :: onebyte = 1
+  INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
+  INTEGER itypesize, rtypesize, typesize
+  INTEGER, DIMENSION(512)     :: hdrbuf
+  INTEGER, DIMENSION(int_num_handles)       :: handle
+  INTEGER, DIMENSION(512, int_num_handles)  :: open_file_descriptors
+
+  CHARACTER*132 last_next_var( int_num_handles )
+
+  CONTAINS
+
+    LOGICAL FUNCTION int_valid_handle( handle )
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) ::  handle
+      int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles ) 
+    END FUNCTION int_valid_handle
+
+    SUBROUTINE int_get_fresh_handle( retval )
+#include "wrf_io_flags.h"
+      INTEGER i, retval
+      retval = -1
+! dont use first 8 handles
+      DO i = 8, int_num_handles
+        IF ( .NOT. int_handle_in_use(i) )  THEN
+          retval = i
+          GOTO 33
+        ENDIF
+      ENDDO
+33    CONTINUE
+      IF ( retval < 0 )  THEN
+        CALL wrf_error_fatal("io_int.F90: int_get_fresh_handle() can not get new handle")
+      ENDIF
+      int_handle_in_use(i) = .TRUE.
+      first_operation(i) = .TRUE.
+      file_status(i) = WRF_FILE_NOT_OPENED
+      NULLIFY ( int_local_output_buffer )
+    END SUBROUTINE int_get_fresh_handle
+
+    SUBROUTINE release_handle( i )
+#include "wrf_io_flags.h"
+      INTEGER, INTENT(IN) :: i
+      IF ( i .LT. 8 .OR. i .GT. int_num_handles ) RETURN
+      IF ( .NOT. int_handle_in_use(i) ) RETURN
+      int_handle_in_use(i) = .FALSE.
+      RETURN
+    END SUBROUTINE release_handle
+
+      
+
+    !--- ioinit
+    SUBROUTINE init_module_ext_internal
+      IMPLICIT NONE
+      INTEGER i
+      CALL wrf_sizeof_integer( itypesize )
+      CALL wrf_sizeof_real   ( rtypesize )
+      DO i = 1, int_num_handles
+         last_next_var( i ) = ' '
+      ENDDO
+    END SUBROUTINE init_module_ext_internal
+
+! 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 int_ok_to_put_dom_ti( DataHandle )
+#include "wrf_io_flags.h"
+    INTEGER, INTENT(IN) :: DataHandle 
+    CHARACTER*256 :: fname
+    INTEGER :: filestate
+    INTEGER :: Status
+    LOGICAL :: dryrun, first_output, retval
+    call ext_int_inquire_filename( DataHandle, fname, filestate, Status )
+    IF ( Status /= 0 ) THEN
+      retval = .FALSE.
+    ELSE
+      dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
+      first_output = int_is_first_operation( DataHandle )
+      ! Note that we want to REPLICATE time-independent domain metadata in the 
+      ! output files so the metadata is available during reads.  Fortran 
+      ! unformatted I/O must be sequential because we don't have fixed record 
+      ! lengths.  
+      ! retval = .NOT. dryrun .AND. first_output
+      retval = .NOT. dryrun
+    ENDIF
+    int_ok_to_put_dom_ti = retval
+    RETURN
+END FUNCTION int_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 int_ok_to_get_dom_ti( DataHandle )
+#include "wrf_io_flags.h"
+    INTEGER, INTENT(IN) :: DataHandle 
+    CHARACTER*256 :: fname
+    INTEGER :: filestate
+    INTEGER :: Status
+    LOGICAL :: dryrun, retval
+    call ext_int_inquire_filename( DataHandle, fname, filestate, Status )
+    IF ( Status /= 0 ) THEN
+      retval = .FALSE.
+    ELSE
+      dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
+      retval = .NOT. dryrun
+    ENDIF
+    int_ok_to_get_dom_ti = retval
+    RETURN
+END FUNCTION int_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 int_is_first_operation( DataHandle )
+    INTEGER, INTENT(IN) :: DataHandle 
+    LOGICAL :: retval
+    retval = .FALSE.
+    IF ( int_valid_handle ( DataHandle ) ) THEN
+      IF ( int_handle_in_use( DataHandle ) ) THEN
+        retval = first_operation( DataHandle )
+      ENDIF
+    ENDIF
+    int_is_first_operation = retval
+    RETURN
+END FUNCTION int_is_first_operation
+
+END MODULE module_ext_internal
+
+SUBROUTINE ext_int_ioinit( SysDepInfo, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  CHARACTER*(*), INTENT(IN) :: SysDepInfo
+  INTEGER Status
+  CALL init_module_ext_internal
+END SUBROUTINE ext_int_ioinit
+
+!--- open_for_write
+SUBROUTINE ext_int_open_for_write( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                   DataHandle , Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  CALL ext_int_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                     DataHandle , Status )
+  IF ( Status .NE. 0 ) RETURN
+  CALL ext_int_open_for_write_commit( DataHandle , Status )
+  RETURN
+END SUBROUTINE ext_int_open_for_write
+
+!--- open_for_write_begin
+SUBROUTINE ext_int_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                         DataHandle , Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+#include "wrf_io_flags.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i, tasks_in_group, ierr, comm_io_group
+  LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+  REAL dummy
+  INTEGER io_form
+  CHARACTER*256 :: fname
+
+  CALL int_get_fresh_handle(i)
+  okay_for_io(i) = .false.
+  DataHandle = i
+
+  io_form = 100 ! dummy value
+  fname = TRIM(FileName)
+  CALL int_gen_ofwb_header( open_file_descriptors(1,i), hdrbufsize, itypesize, &
+                            fname,SysDepInfo,io_form,DataHandle )
+
+  OPEN ( unit=DataHandle, file=TRIM(FileName), form='unformatted', iostat=Status )
+
+  file_status(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
+  file_read_only(DataHandle) = .FALSE.
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_int_open_for_write_begin
+
+!--- open_for_write_commit
+SUBROUTINE ext_int_open_for_write_commit( DataHandle , Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+
+  IF ( int_valid_handle ( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      okay_for_io( DataHandle ) = .true.
+    ENDIF
+  ENDIF
+
+  first_operation( DataHandle ) = .TRUE.
+  file_status(DataHandle) = WRF_FILE_OPENED_FOR_WRITE
+
+  Status = 0
+
+  RETURN  
+END SUBROUTINE ext_int_open_for_write_commit
+
+!--- open_for_read 
+SUBROUTINE ext_int_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                               DataHandle , Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i
+  CHARACTER*256 :: fname
+
+  CALL int_get_fresh_handle(i)
+  DataHandle = i
+  CurrentDateInFile(i) = ""
+  fname = TRIM(FileName)
+
+  CALL int_gen_ofr_header( open_file_descriptors(1,i), hdrbufsize, itypesize, &
+                            fname,SysDepInfo,DataHandle )
+
+  OPEN ( unit=DataHandle, status="old", file=TRIM(FileName), form='unformatted', iostat=Status )
+  okay_for_io(DataHandle) = .true.
+  file_status(DataHandle) = WRF_FILE_OPENED_FOR_READ
+  file_read_only(DataHandle) = .TRUE.
+
+  RETURN  
+END SUBROUTINE ext_int_open_for_read
+
+!--- inquire_opened
+SUBROUTINE ext_int_inquire_opened ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER*256 :: fname
+
+  Status = 0
+
+  CALL ext_int_inquire_filename ( DataHandle, fname, FileStatus, Status )
+  IF ( fname /= TRIM(FileName) ) THEN
+    FileStatus = WRF_FILE_NOT_OPENED
+  ENDIF
+
+  Status = 0
+  
+  RETURN
+END SUBROUTINE ext_int_inquire_opened
+
+!--- inquire_filename
+SUBROUTINE ext_int_inquire_filename ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER *4096   SysDepInfo
+  INTEGER locDataHandle
+  CHARACTER*256 :: fname
+  INTEGER io_form
+  Status = 0
+  SysDepInfo = ""
+  FileStatus = WRF_FILE_NOT_OPENED
+  FileName = ""
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      ! Note that the formats for these headers differ.  
+      IF ( file_read_only(DataHandle) ) THEN
+        CALL int_get_ofr_header( open_file_descriptors(1,DataHandle), hdrbufsize, itypesize, &
+                                 fname,SysDepInfo,locDataHandle )
+      ELSE
+        CALL int_get_ofwb_header( open_file_descriptors(1,DataHandle), hdrbufsize, itypesize, &
+                                  fname,SysDepInfo,io_form,locDataHandle )
+      ENDIF
+      FileName = TRIM(fname)
+      FileStatus = file_status(DataHandle)
+    ENDIF
+  ENDIF
+  Status = 0
+END SUBROUTINE ext_int_inquire_filename
+
+!--- sync
+SUBROUTINE ext_int_iosync ( DataHandle, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = 0
+  RETURN
+END SUBROUTINE ext_int_iosync
+
+!--- close
+SUBROUTINE ext_int_ioclose ( DataHandle, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER DataHandle, Status
+
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      CLOSE ( DataHandle ) 
+    ENDIF
+    CALL release_handle(DataHandle)
+  ENDIF
+
+  Status = 0
+
+  RETURN
+END SUBROUTINE ext_int_ioclose
+
+!--- ioexit
+SUBROUTINE ext_int_ioexit( Status )
+
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER                     :: DataHandle
+  INTEGER i,ierr
+  REAL dummy
+
+  RETURN  
+END SUBROUTINE ext_int_ioexit
+
+!--- get_next_time
+SUBROUTINE ext_int_get_next_time ( DataHandle, DateStr, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER         code
+  CHARACTER*132   locElement, dummyvar
+  INTEGER istat
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locData
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+  integer loccode
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize
+  REAL, DIMENSION(1)    :: Field  ! dummy
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_time: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_time: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  DO WHILE ( .TRUE. )
+    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
+    IF ( istat .EQ. 0 ) THEN
+      code = hdrbuf(2)
+      IF ( code .EQ. int_field ) THEN
+        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
+                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
+                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
+                                 locDomainStart , locDomainEnd ,                                    &
+                                 locMemoryStart , locMemoryEnd ,                                    &
+                                 locPatchStart , locPatchEnd )
+        IF ( TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle) ) ) THEN  ! control break, return this date
+          DateStr = TRIM(locDateStr)
+          CurrentDateInFile(DataHandle) = TRIM(DateStr)
+          BACKSPACE ( unit=DataHandle )
+          Status = 0
+          GOTO 7717
+        ELSE
+          READ( unit=DataHandle, iostat=istat )
+        ENDIF
+      ELSE IF ( code .EQ. int_dom_td_char ) THEN
+        CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
+                              locDataHandle, locDateStr, locElement, locData, loccode )
+        IF ( TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle) ) ) THEN  ! control break, return this date
+          DateStr = TRIM(locDateStr)
+          CurrentDateInFile(DataHandle) = TRIM(DateStr)
+          BACKSPACE ( unit=DataHandle )
+          Status = 0
+          GOTO 7717
+        ELSE
+          READ( unit=DataHandle, iostat=istat )
+        ENDIF
+      ENDIF
+    ELSE
+      Status = 1
+      GOTO 7717
+    ENDIF
+  ENDDO
+7717 CONTINUE
+
+  RETURN
+END SUBROUTINE ext_int_get_next_time
+
+!--- set_time
+SUBROUTINE ext_int_set_time ( DataHandle, DateStr, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,        &
+                               DataHandle, "TIMESTAMP", "", TRIM(DateStr), int_set_time )
+  WRITE( unit=DataHandle ) hdrbuf
+  Status = 0
+  RETURN
+END SUBROUTINE ext_int_set_time
+
+!--- get_var_info
+SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
+                              DomainStart , DomainEnd , WrfType, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: VarName
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)         ,intent(out)    :: Stagger
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize, istat, code
+  REAL, DIMENSION(1)    :: Field   ! dummy
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_var_info: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_var_info: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  DO WHILE ( .TRUE. )
+    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
+    IF ( istat .EQ. 0 ) THEN
+      code = hdrbuf(2)
+      IF ( code .EQ. int_field ) THEN
+        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
+                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
+                                 locDomainDesc , MemoryOrder , locStagger , locDimNames ,              &
+                                 locDomainStart , locDomainEnd ,                                    &
+                                 locMemoryStart , locMemoryEnd ,                                    &
+                                 locPatchStart , locPatchEnd )
+        
+        IF ( LEN(TRIM(MemoryOrder)) .EQ. 3 ) THEN
+          NDim = 3
+        ELSE IF ( LEN(TRIM(MemoryOrder)) .EQ. 2 ) THEN
+          NDim = 2
+        ELSE IF ( TRIM(MemoryOrder) .EQ. '0' ) THEN
+          NDim = 0
+        ELSE 
+          NDim = 1
+        ENDIF
+        Stagger = locStagger
+        DomainStart(1:3) = locDomainStart(1:3)
+        DomainEnd(1:3) = locDomainEnd(1:3)
+        WrfType = locFieldType
+        BACKSPACE ( unit=DataHandle )
+        Status = 0
+        GOTO 7717
+      ENDIF
+    ELSE
+      Status = 1
+      GOTO 7717
+    ENDIF
+  ENDDO
+7717 CONTINUE
+
+RETURN
+END SUBROUTINE ext_int_get_var_info
+
+!--- get_next_var
+SUBROUTINE ext_int_get_next_var ( DataHandle, VarName, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  include 'intio_tags.h'
+  include 'wrf_status_codes.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: VarName
+  INTEGER ,       INTENT(OUT) :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+character*128 locElement, strData, dumstr
+integer loccode, loccount
+integer idata(128)
+real    rdata(128)
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize, istat, code
+  REAL, DIMENSION(1)    :: Field  ! dummy
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  DO WHILE ( .TRUE. )
+7727 CONTINUE
+    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
+    IF ( istat .EQ. 0 ) THEN
+      code = hdrbuf(2)
+#if 1
+      IF ( code .EQ. int_dom_ti_char ) THEN
+        CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                         locDataHandle, locElement, dumstr, strData, loccode )
+      ENDIF
+      IF ( code .EQ. int_dom_ti_integer ) THEN
+        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
+                                locDataHandle, locElement, iData, loccount, code )
+      ENDIF
+      IF ( code .EQ. int_dom_ti_real ) THEN
+        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
+                                locDataHandle, locElement, rData, loccount, code )
+      ENDIF
+#endif
+      IF ( code .EQ. int_field ) THEN
+        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
+                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
+                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
+                                 locDomainStart , locDomainEnd ,                                    &
+                                 locMemoryStart , locMemoryEnd ,                                    &
+                                 locPatchStart , locPatchEnd )
+
+        IF (TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle))) THEN
+          Status = WRF_WARN_VAR_EOF !-6 ! signal past last var in time frame
+          BACKSPACE ( unit=DataHandle )
+          last_next_var( DataHandle )  = ""
+          GOTO 7717
+        ELSE
+          VarName = TRIM(locVarName)
+          IF ( last_next_var( DataHandle )  .NE. VarName ) THEN
+            BACKSPACE ( unit=DataHandle )
+            last_next_var( DataHandle )  = VarName
+          ELSE
+            READ( unit=DataHandle, iostat=istat )
+            GOTO 7727
+          ENDIF
+          Status = 0
+          GOTO 7717
+        ENDIF
+      ELSE
+        GOTO 7727
+      ENDIF
+    ELSE
+      Status = 1
+      GOTO 7717
+    ENDIF
+  ENDDO
+7717 CONTINUE
+  RETURN
+END SUBROUTINE ext_int_get_next_var
+
+!--- get_dom_ti_real
+SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  REAL ,          INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Outcount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER loccount, code, istat, locDataHandle
+  CHARACTER*132                :: locElement, mess
+  LOGICAL keepgoing
+
+  Status = 0
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+     ! Do nothing unless it is time to read time-independent domain metadata.
+     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
+      keepgoing = .true.
+      DO WHILE ( keepgoing ) 
+        READ( unit=DataHandle , iostat = istat ) hdrbuf
+        IF ( istat .EQ. 0 ) THEN
+          code = hdrbuf(2)
+          IF ( code .EQ. int_dom_ti_real ) THEN
+            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
+                                    locDataHandle, locElement, Data, loccount, code )
+            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
+              IF ( loccount .GT. Count ) THEN
+                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_real: loccount .GT. Count' )
+              ENDIF
+              keepgoing = .false. ;  Status = 0
+            ENDIF
+          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_logical .OR. &
+                            code .EQ. int_dom_ti_char    .OR. code .EQ. int_dom_ti_double  .OR. &
+                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_logical .OR. &
+                            code .EQ. int_dom_td_char    .OR. code .EQ. int_dom_td_double  .OR. &
+                            code .EQ. int_dom_td_real                                  ) ) THEN
+            BACKSPACE ( unit=DataHandle )
+            keepgoing = .false. ; Status = 2
+          ENDIF
+        ELSE
+          keepgoing = .false. ; Status = 1
+        ENDIF
+      ENDDO
+     ENDIF
+    ENDIF
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_ti_real 
+
+!--- put_dom_ti_real
+SUBROUTINE ext_int_put_dom_ti_real ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  REAL ,          INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+!
+
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      ! Do nothing unless it is time to write time-independent domain metadata.
+      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
+        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
+                                DataHandle, Element, Data, Count, int_dom_ti_real )
+        WRITE( unit=DataHandle ) hdrbuf
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_put_dom_ti_real 
+
+!--- get_dom_ti_double
+SUBROUTINE ext_int_get_dom_ti_double ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Do nothing unless it is time to read time-independent domain metadata.
+  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
+    CALL wrf_error_fatal('ext_int_get_dom_ti_double not supported yet')
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_ti_double 
+
+!--- put_dom_ti_double
+SUBROUTINE ext_int_put_dom_ti_double ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Do nothing unless it is time to write time-independent domain metadata.
+  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
+    CALL wrf_error_fatal('ext_int_put_dom_ti_double not supported yet')
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_put_dom_ti_double 
+
+!--- get_dom_ti_integer
+SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER loccount, code, istat, locDataHandle
+  CHARACTER*132   locElement, mess
+  LOGICAL keepgoing
+
+  Status = 0
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+     ! Do nothing unless it is time to read time-independent domain metadata.
+     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
+      keepgoing = .true.
+      DO WHILE ( keepgoing )
+        READ( unit=DataHandle , iostat = istat ) hdrbuf
+        IF ( istat .EQ. 0 ) THEN
+          code = hdrbuf(2)
+          IF ( code .EQ. int_dom_ti_integer ) THEN
+            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
+                                    locDataHandle, locElement, Data, loccount, code )
+            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
+              IF ( loccount .GT. Count ) THEN
+                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_integer: loccount .GT. Count' )
+              ENDIF
+              keepgoing = .false. ;  Status = 0
+            ENDIF
+
+          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR.   code .EQ. int_dom_ti_logical .OR. &
+                            code .EQ. int_dom_ti_char    .OR.   code .EQ. int_dom_ti_double  .OR. &
+                            code .EQ. int_dom_td_real    .OR.   code .EQ. int_dom_td_logical .OR. &
+                            code .EQ. int_dom_td_char    .OR.   code .EQ. int_dom_td_double  .OR. &
+                            code .EQ. int_dom_td_integer )                                           ) THEN
+            BACKSPACE ( unit=DataHandle )
+            keepgoing = .false. ; Status = 1
+          ENDIF
+        ELSE
+          keepgoing = .false. ; Status = 1
+        ENDIF
+      ENDDO
+     ENDIF
+    ENDIF
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_ti_integer 
+
+!--- put_dom_ti_integer
+SUBROUTINE ext_int_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  INTEGER ,       INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+!
+  IF ( int_valid_handle ( Datahandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      ! Do nothing unless it is time to write time-independent domain metadata.
+      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
+        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, itypesize, &
+                                DataHandle, Element, Data, Count, int_dom_ti_integer )
+        WRITE( unit=DataHandle ) hdrbuf 
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_put_dom_ti_integer 
+
+!--- get_dom_ti_logical
+SUBROUTINE ext_int_get_dom_ti_logical ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Do nothing unless it is time to read time-independent domain metadata.
+  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
+    CALL wrf_message('ext_int_get_dom_ti_logical not supported yet')
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_ti_logical 
+
+!--- put_dom_ti_logical
+SUBROUTINE ext_int_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  ! Do nothing unless it is time to write time-independent domain metadata.
+  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
+    CALL wrf_message('ext_int_put_dom_ti_logical not supported yet')
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_put_dom_ti_logical 
+
+!--- get_dom_ti_char
+SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER istat, code, i
+  CHARACTER*79 dumstr, locElement
+  INTEGER locDataHandle
+  LOGICAL keepgoing
+
+  Status = 0
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+     ! Do nothing unless it is time to read time-independent domain metadata.
+     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
+      keepgoing = .true.
+      DO WHILE ( keepgoing )
+        READ( unit=DataHandle , iostat = istat ) hdrbuf
+
+        IF ( istat .EQ. 0 ) THEN
+          code = hdrbuf(2)
+          IF ( code .EQ. int_dom_ti_char ) THEN
+            CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                         locDataHandle, locElement, dumstr, Data, code )
+            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
+              keepgoing = .false. ;  Status = 0
+            ENDIF
+          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR. code .EQ. int_dom_ti_logical .OR. &
+                            code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_double  .OR. &
+                            code .EQ. int_dom_td_real    .OR. code .EQ. int_dom_td_logical .OR. &
+                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_double  .OR. &
+                            code .EQ. int_dom_td_char                                             ) ) THEN
+            BACKSPACE ( unit=DataHandle )
+            keepgoing = .false. ; Status = 1
+          ENDIF
+        ELSE
+          keepgoing = .false. ; Status = 1
+        ENDIF
+      ENDDO
+     ENDIF
+    ENDIF
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_ti_char 
+
+!--- put_dom_ti_char
+SUBROUTINE ext_int_put_dom_ti_char ( DataHandle, Element,  Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i
+  REAL dummy
+  INTEGER                 :: Count
+
+  IF ( int_valid_handle ( Datahandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      ! Do nothing unless it is time to write time-independent domain metadata.
+      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
+        CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
+                                     DataHandle, Element, "", Data, int_dom_ti_char )
+        WRITE( unit=DataHandle ) hdrbuf 
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_put_dom_ti_char 
+
+!--- get_dom_td_real
+SUBROUTINE ext_int_get_dom_td_real ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_dom_td_real 
+
+!--- put_dom_td_real
+SUBROUTINE ext_int_put_dom_td_real ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_dom_td_real 
+
+!--- get_dom_td_double
+SUBROUTINE ext_int_get_dom_td_double ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_get_dom_td_double 
+
+!--- put_dom_td_double
+SUBROUTINE ext_int_put_dom_td_double ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_put_dom_td_double 
+
+!--- get_dom_td_integer
+SUBROUTINE ext_int_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_dom_td_integer 
+
+!--- put_dom_td_integer
+SUBROUTINE ext_int_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_dom_td_integer 
+
+!--- get_dom_td_logical
+SUBROUTINE ext_int_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_dom_td_logical 
+
+!--- put_dom_td_logical
+SUBROUTINE ext_int_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_dom_td_logical 
+
+!--- get_dom_td_char
+SUBROUTINE ext_int_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data, DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER istat, code, i
+  CHARACTER*79 dumstr, locElement, locDatestr
+  INTEGER locDataHandle
+  LOGICAL keepgoing
+
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      keepgoing = .true.
+      DO WHILE ( keepgoing )
+        READ( unit=DataHandle , iostat = istat ) hdrbuf
+
+        IF ( istat .EQ. 0 ) THEN
+          code = hdrbuf(2)
+          IF ( code .EQ. int_dom_td_char ) THEN
+            CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                         locDataHandle, locDateStr, locElement, Data, code )
+            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
+              keepgoing = .false. ;  Status = 0
+            ENDIF
+          ELSE 
+            BACKSPACE ( unit=DataHandle )
+            keepgoing = .false. ; Status = 1
+          ENDIF
+        ELSE
+          keepgoing = .false. ; Status = 1
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+RETURN
+END SUBROUTINE ext_int_get_dom_td_char
+
+!--- put_dom_td_char
+SUBROUTINE ext_int_put_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data, DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i
+  REAL dummy
+  INTEGER                 :: Count
+  IF ( int_valid_handle ( Datahandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      CALL int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize,  &
+                                   DataHandle, DateStr, Element, Data, int_dom_td_char )
+      WRITE( unit=DataHandle ) hdrbuf
+    ENDIF
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_put_dom_td_char
+
+!--- get_var_ti_real
+SUBROUTINE ext_int_get_var_ti_real ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_ti_real 
+
+!--- put_var_ti_real
+SUBROUTINE ext_int_put_var_ti_real ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_ti_real 
+
+!--- get_var_ti_double
+SUBROUTINE ext_int_get_var_ti_double ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_get_var_ti_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_get_var_ti_double 
+
+!--- put_var_ti_double
+SUBROUTINE ext_int_put_var_ti_double ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_put_var_ti_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_put_var_ti_double 
+
+!--- get_var_ti_integer
+SUBROUTINE ext_int_get_var_ti_integer ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_ti_integer 
+
+!--- put_var_ti_integer
+SUBROUTINE ext_int_put_var_ti_integer ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_ti_integer 
+
+!--- get_var_ti_logical
+SUBROUTINE ext_int_get_var_ti_logical ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_ti_logical 
+
+!--- put_var_ti_logical
+SUBROUTINE ext_int_put_var_ti_logical ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_ti_logical 
+
+!--- get_var_ti_char
+SUBROUTINE ext_int_get_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER locDataHandle, code
+  CHARACTER*132 locElement, locVarName
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      READ( unit=DataHandle ) hdrbuf
+      IF ( hdrbuf(2) .EQ. int_var_ti_char ) THEN
+        CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                locDataHandle, locElement, locVarName, Data, code )
+        IF ( .NOT. ( code .EQ. int_var_ti_real    .OR.   code .EQ. int_var_ti_logical .OR. &
+                     code .EQ. int_var_ti_char    .OR.   code .EQ. int_var_ti_double ) ) THEN 
+            BACKSPACE ( unit=DataHandle )
+            Status = 1
+            return
+        ENDIF
+      ELSE
+        BACKSPACE ( unit=DataHandle )
+        Status = 1
+        return
+      ENDIF
+    ELSE
+      Status = 1
+      return
+    ENDIF
+  ELSE
+    Status = 1
+    return
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_get_var_ti_char 
+
+!--- put_var_ti_char
+SUBROUTINE ext_int_put_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+  INCLUDE 'intio_tags.h'
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  INTEGER                 :: Count
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
+                              DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char )
+      WRITE( unit=DataHandle ) hdrbuf
+    ENDIF
+  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_int_put_var_ti_char 
+
+!--- get_var_td_real
+SUBROUTINE ext_int_get_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_td_real 
+
+!--- put_var_td_real
+SUBROUTINE ext_int_put_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_td_real 
+
+!--- get_var_td_double
+SUBROUTINE ext_int_get_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_get_var_td_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_get_var_td_double 
+
+!--- put_var_td_double
+SUBROUTINE ext_int_put_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+    CALL wrf_error_fatal('ext_int_put_var_td_double not supported yet')
+RETURN
+END SUBROUTINE ext_int_put_var_td_double 
+
+!--- get_var_td_integer
+SUBROUTINE ext_int_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_td_integer 
+
+!--- put_var_td_integer
+SUBROUTINE ext_int_put_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_td_integer 
+
+!--- get_var_td_logical
+SUBROUTINE ext_int_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_td_logical 
+
+!--- put_var_td_logical
+SUBROUTINE ext_int_put_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_td_logical 
+
+!--- get_var_td_char
+SUBROUTINE ext_int_get_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_get_var_td_char 
+
+!--- put_var_td_char
+SUBROUTINE ext_int_put_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_int_put_var_td_char 
+
+!--- 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 )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+  include 'intio_tags.h'
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  integer                       ,intent(inout)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(inout)    :: DomainDesc
+  character*(*)                 ,intent(inout)    :: MemoryOrder
+  character*(*)                 ,intent(inout)    :: Stagger
+  character*(*) , dimension (*) ,intent(inout)    :: DimNames
+  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
+  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)   :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+  character*132 mess
+
+  integer ii,jj,kk,myrank
+
+
+  REAL, DIMENSION(*)    :: Field
+
+  INTEGER inttypesize, realtypesize, istat, code
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: DataHandle not opened" )
+  ENDIF
+
+  inttypesize = itypesize
+  realtypesize = rtypesize
+
+  DO WHILE ( .TRUE. ) 
+    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
+    IF ( istat .EQ. 0 ) THEN
+      code = hdrbuf(2)
+      IF ( code .EQ. int_field ) THEN
+        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
+                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
+                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
+                                 locDomainStart , locDomainEnd ,                                    &
+                                 locMemoryStart , locMemoryEnd ,                                    &
+                                 locPatchStart , locPatchEnd )
+        IF ( TRIM(locVarName) .EQ. TRIM(VarName) ) THEN
+          IF      ( FieldType .EQ. WRF_REAL ) THEN
+            CALL rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+          ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+            CALL ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+          ELSE
+            CALL wrf_message('io_int.F90: ext_int_read_field: types other than WRF_REAL not supported yet')
+            READ( unit=DataHandle )
+          ENDIF
+        ELSE
+          WRITE(mess,*)'ext_int_read_field: ',TRIM(locVarName),' NE ',TRIM(VarName)
+          CALL wrf_message(mess)
+          READ( unit=DataHandle )
+        ENDIF
+        Status = 0
+        GOTO 7717
+      ENDIF
+    ELSE
+      Status = 1
+      GOTO 7717
+    ENDIF
+  ENDDO
+
+7717 CONTINUE
+
+  first_operation( DataHandle ) = .FALSE.
+  RETURN
+
+END SUBROUTINE ext_int_read_field
+
+!--- write_field
+SUBROUTINE ext_int_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
+                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                             DomainStart , DomainEnd ,                                    &
+                             MemoryStart , MemoryEnd ,                                    &
+                             PatchStart , PatchEnd ,                                      &
+                             Status )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "wrf_io_flags.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  integer                       ,intent(in)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrder
+  character*(*)                 ,intent(in)    :: Stagger
+  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 ii,jj,kk,myrank
+
+!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+!                   MemoryStart(2):MemoryEnd(2), &
+!                   MemoryStart(3):MemoryEnd(3) ) :: Field
+
+  REAL, DIMENSION(*)    :: Field
+
+  INTEGER inttypesize, realtypesize
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: DataHandle not opened" )
+  ENDIF
+
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  IF      ( FieldType .EQ. WRF_REAL .OR. FieldType .EQ. WRF_DOUBLE) THEN
+    typesize = rtypesize
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_DOUBLE not yet supported')
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    typesize = itypesize
+  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
+    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_LOGICAL not yet supported')
+  ENDIF
+
+  IF ( okay_for_io( DataHandle ) ) THEN
+
+    CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
+                             DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
+                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                             DomainStart , DomainEnd ,                                    &
+                             MemoryStart , MemoryEnd ,                                    &
+                             PatchStart , PatchEnd )
+    WRITE( unit=DataHandle ) hdrbuf
+    IF      ( FieldType .EQ. WRF_REAL ) THEN
+      CALL rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+      CALL ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+    ENDIF
+  ENDIF
+  first_operation( DataHandle ) = .FALSE.
+  Status = 0
+  RETURN
+END SUBROUTINE ext_int_write_field
+
+SUBROUTINE rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
+  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+                   MemoryStart(2):MemoryEnd(2), &
+                   MemoryStart(3):MemoryEnd(3) ) :: Field
+  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
+  RETURN
+END SUBROUTINE rfieldwrite
+
+SUBROUTINE ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
+  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+                      MemoryStart(2):MemoryEnd(2), &
+                      MemoryStart(3):MemoryEnd(3) ) :: Field
+  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
+  RETURN
+END SUBROUTINE ifieldwrite
+
+SUBROUTINE rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+  INTEGER ,       INTENT(IN)    :: DataHandle
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
+  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+                   MemoryStart(2):MemoryEnd(2), &
+                   MemoryStart(3):MemoryEnd(3) ) :: Field
+  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
+  RETURN
+END SUBROUTINE rfieldread
+
+SUBROUTINE ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
+  INTEGER ,       INTENT(IN)    :: DataHandle
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
+  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
+  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+                      MemoryStart(2):MemoryEnd(2), &
+                      MemoryStart(3):MemoryEnd(3) ) :: Field
+  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
+  RETURN
+END SUBROUTINE ifieldread
+
diff --git a/wrfv2_fire/external/io_int/makefile b/wrfv2_fire/external/io_int/makefile
new file mode 100644
index 00000000..d7bdd7f1
--- /dev/null
+++ b/wrfv2_fire/external/io_int/makefile
@@ -0,0 +1,53 @@
+#makefile to build io_int that does binary i/o
+
+OBJSL   = io_int.o 
+OBJS    = $(OBJSL)
+FFLAGS  = $(FCFLAGS)
+LIBS    = 
+CPP1    = $(CPP) $(TRADFLAG)
+M4      = m4 -Uinclude -Uindex -Ulen
+AR      = ar
+
+.SUFFIXES:      .F90 .F .f .o .code
+
+all : libwrfio_int.a diffwrf
+
+libwrfio_int.a:		$(OBJS)
+			/bin/rm -f libwrfio_int.a
+			$(AR) cr libwrfio_int.a $(OBJSL)
+			$(RANLIB) libwrfio_int.a
+
+io_int.o:               io_int.F90 module_internal_header_util.o
+			$(CPP1)  -I../ioapi_share io_int.F90 | $(M4) - > io_int.f
+			$(FC) $(FFLAGS) -I. -I../ioapi_share -c io_int.f
+			/bin/rm -f module_internal_header_util.o
+			/bin/rm -f intio_tags.h
+
+# this is just so we can get the .mod file, it will be recompiled in frame again as part of WRF frmwk
+module_internal_header_util.o :
+			cp ../../frame/module_internal_header_util.F module_internal_header_util.b
+			cp ../../inc/intio_tags.h intio_tags.h
+			/bin/rm -f module_internal_header_util.f
+			$(CPP1)  -I../ioapi_share module_internal_header_util.b > module_internal_header_util.f
+			$(FC) $(FFLAGS) -I. -c module_internal_header_util.f
+			/bin/rm -f module_internal_header_util.b
+
+diffwrf:                diffwrf.F ../../frame/pack_utils.o ../../frame/module_machine.o ../../frame/module_wrf_error.o \
+				../../frame/wrf_debug.o libwrfio_int.a $(ESMF_MOD_DEPENDENCE)
+			if [ -f ../../frame/pack_utils.o ] ; then \
+			mv diffwrf.F diffwrf.F90    ; \
+			$(CPP1)  -I../ioapi_share diffwrf.F90 > diffwrf.f  ; \
+			$(SFC) -c $(FFLAGS) -I../ioapi_share diffwrf.f    ; \
+			mv diffwrf.F90 diffwrf.F ; \
+			$(SFC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) \
+                        ../../frame/pack_utils.o ../../frame/module_internal_header_util.o \
+                        ../../frame/module_driver_constants.o \
+			../../frame/module_machine.o ../../frame/wrf_debug.o ../../frame/module_wrf_error.o \
+			$(ESMF_IO_LIB_EXT) ; fi
+
+../../frame/pack_utils.o ../../frame/internal_header_util.o ../../frame/module_machine.o ../../frame/module_wrf_error.o \
+../../frame/wrf_debug.o $(ESMF_MOD_DEPENDENCE) :
+			@echo "Diffwrf io_int will be built later on in this compile. No need to rerun compile. "
+
+superclean:
+			/bin/rm -f *.f *.o *.mod libwrfio_int.a diffwrf 
diff --git a/wrfv2_fire/external/io_mcel/ext_mcel_open_for_read.F90 b/wrfv2_fire/external/io_mcel/ext_mcel_open_for_read.F90
new file mode 100644
index 00000000..404e1b09
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/ext_mcel_open_for_read.F90
@@ -0,0 +1,129 @@
+!--- open_for_read_begin
+SUBROUTINE ext_mcel_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                         DataHandle , Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i, tasks_in_group, ierr, comm_io_group
+  LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+  REAL dummy
+  INTEGER io_form
+  CHARACTER*80 read_mode, grid_type, filter_handle, use_mask
+  CHARACTER*256   tstr
+
+  CALL int_get_fresh_handle(i)
+  okay_to_write(i) = .false.
+  okay_to_read(i) = .false.
+  opened_for_read(i) = .true.
+  opened_for_write(i) = .false.
+  mcel_grid_defined(i) = .false.
+  mcel_finalized(i) = .false.
+  DataHandle = i
+  ListOfFields(i) = " "
+
+! recover the names of the strings that contain georeference and mask data, if avail
+  lat_r(i) = ""
+  lon_r(i) = ""
+  landmask_i(i) = ""
+  read_mode = ""
+  grid_type = "STRUCTURED"
+  filter_handle = "Filter"
+  use_mask = ""
+  CALL get_value( "LAT_R", SysDepInfo, lat_r(i) )
+  CALL get_value( "LON_R", SysDepInfo, lon_r(i) )
+  CALL get_value( "LANDMASK_I", SysDepInfo, landmask_i(i) )
+  CALL get_value( "READ_MODE", SysDepInfo, read_mode )
+write(0,*)'open_for_write_begin: SysDepInfo ', TRIM(SysDepInfo)
+write(0,*)'open_for_write_begin: read_mode ', read_mode
+  CALL get_value( "MCEL_GRIDTYPE", SysDepInfo, grid_type )
+  CALL get_value( "FILTER_HANDLE", SysDepInfo, filter_handle )
+  CALL get_value( "USE_MASK", SysDepInfo, use_mask )
+  IF ( TRIM(read_mode) .EQ. 'UPDATE' ) THEN
+    opened_for_update( i ) = .true.
+  ELSE
+    opened_for_update( i ) = .false.
+  ENDIF
+write(0,*)'opened_for_update(i) ', opened_for_update(i)
+
+  usemask(i) = MCEL_MASK_ALLVALID
+  IF ( trim(use_mask) .NE. "" ) read( use_mask , '(I)' ) usemask(i)
+write(0,*)'ofrb use_mask ',trim(use_mask)
+write(0,*)'ofrb filter_handle ',trim(filter_handle)
+write(0,*)'ofrb usemask(',i,') = ',usemask(i)
+
+  mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
+
+  CALL get_value( "MCEL_NPGLOBAL", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_npglobal
+  CALL get_value( "MCEL_MYSTART", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_mystart
+  CALL get_value( "MCEL_MNPROC", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_mnproc
+  CALL get_value( "MCEL_MYPROC", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_myproc
+  deltax = -1
+  CALL get_value( "MCEL_DELTA_X", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) deltax
+  deltay = -1
+  CALL get_value( "MCEL_DELTA_Y", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) deltay
+  originx = -1
+  CALL get_value( "MCEL_ORIGIN_X", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) originx
+  originy = -1
+  CALL get_value( "MCEL_ORIGIN_Y", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) originy
+
+  IF ( trim(grid_type) .EQ. 'UNSTRUCTURED' ) THEN
+    CALL newGrid( open_file_descriptors(2,i), 2, MCEL_GRIDTYPE_UNSTRUCTURED, &
+                  MCEL_GRIDCENT_NODAL, MCEL_GRIDCOORD_LATLONG, &
+                  ierr )
+  ELSE
+    CALL newGrid( open_file_descriptors(2,i), 2, MCEL_GRIDTYPE_STRUCTURED, &
+                  MCEL_GRIDCENT_NODAL, MCEL_GRIDCOORD_LATLONG, &
+                  ierr )
+  ENDIF
+  IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_for_read_begin: newGrid" )
+
+!  IF ( opened_for_update( i ) ) THEN
+    ! right now the name of the ior file is coming in as the file name; whereis for writing the
+    ! file name is the program name.  Needs to be resolved for this call to newfilter. 
+    ! Make the FileName the program name and find a different way to bring in the ior file; sysdepinfo? environ?
+    CALL newfilter ( open_file_descriptors(1,i), 'relfile:/' // TRIM(FileName), filter_handle, ierr )
+    IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_for_read_begin: newfilter" )
+!  ELSE
+!    CALL newProgram ( open_file_descriptors(1,i), TRIM(FileName), ierr )
+!    IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_for_read_begin: newProgram" )
+!  ENDIF
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_mcel_open_for_read_begin
+
+!--- open_for_read_commit
+SUBROUTINE ext_mcel_open_for_read_commit( DataHandle , Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER*80   FileName,SysDepInfo, mess
+  REAL dummy
+  INTEGER ierr
+
+  IF ( int_valid_handle ( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      if ( opened_for_update( DataHandle ) ) okay_to_write( DataHandle ) = .true.
+      okay_to_read( DataHandle ) = .true.
+    ENDIF
+  ENDIF
+
+! everything else will be handled in lazy fashion by first operation
+
+  Status = 0
+
+  RETURN  
+END SUBROUTINE ext_mcel_open_for_read_commit
diff --git a/wrfv2_fire/external/io_mcel/ext_mcel_open_for_write.F90 b/wrfv2_fire/external/io_mcel/ext_mcel_open_for_write.F90
new file mode 100644
index 00000000..c0cf2c71
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/ext_mcel_open_for_write.F90
@@ -0,0 +1,111 @@
+!--- open_for_write_begin
+SUBROUTINE ext_mcel_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                         DataHandle , Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i, tasks_in_group, ierr, comm_io_group
+  LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+  REAL dummy
+  INTEGER io_form
+  CHARACTER*256   fname
+  CHARACTER*256   grid_type
+  CHARACTER*256   tstr
+
+  fname = FileName
+
+  CALL int_get_fresh_handle(i)
+  okay_to_write(i) = .false.
+  okay_to_read(i) = .false.
+  opened_for_update(i) = .false.
+  opened_for_read(i) = .false.
+  opened_for_write(i) = .true.
+  mcel_grid_defined(i) = .false.
+  mcel_finalized(i) = .false.
+  DataHandle = i
+
+! right now only 2d -- extend later to 3d, 1d, 0d
+
+  CALL get_value ( 'MCEL_GRIDTYPE', SysDepInfo, grid_type )
+
+  LAT_R(i) = ""
+  LON_R(i) = ""
+  LANDMASK_I(i) = ""
+  CALL get_value( "LAT_R", SysDepInfo, LAT_R(i) )
+  CALL get_value( "LON_R", SysDepInfo, LON_R(i) )
+  CALL get_value( "LANDMASK_I", SysDepInfo, LANDMASK_I(i) )
+
+  mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1  
+
+  CALL get_value( "MCEL_NPGLOBAL", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_npglobal
+  CALL get_value( "MCEL_MYSTART", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_mystart
+  CALL get_value( "MCEL_MNPROC", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_mnproc
+  CALL get_value( "MCEL_MYPROC", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(I)' ) mcel_myproc
+
+  deltax = -1
+  CALL get_value( "MCEL_DELTA_X", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) deltax
+  deltay = -1
+  CALL get_value( "MCEL_DELTA_Y", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) deltay
+  originx = -1
+  CALL get_value( "MCEL_ORIGIN_X", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) originx
+  originy = -1
+  CALL get_value( "MCEL_ORIGIN_Y", SysDepInfo, tstr )
+  IF ( tstr .NE. "" ) READ( tstr, '(f15.8)' ) originy
+
+
+  IF ( TRIM(grid_type) .EQ. 'UNSTRUCTURED' ) THEN
+     CALL newGrid( open_file_descriptors(2,i), 2, MCEL_GRIDTYPE_UNSTRUCTURED, &
+                   MCEL_GRIDCENT_NODAL, MCEL_GRIDCOORD_LATLONG, &
+                   ierr )
+  ELSE
+
+     CALL newGrid( open_file_descriptors(2,i), 2, MCEL_GRIDTYPE_STRUCTURED, &
+                   MCEL_GRIDCENT_NODAL, MCEL_GRIDCOORD_LATLONG, &
+                   ierr )
+  ENDIF
+
+  IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_for_write_begin: newGrid" )
+
+  CALL newProgram ( open_file_descriptors(1,i), TRIM(fname), ierr )
+
+  IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_for_write_begin: newProgram" )
+
+  Status = 0
+  RETURN  
+END SUBROUTINE ext_mcel_open_for_write_begin
+
+!--- open_for_write_commit
+SUBROUTINE ext_mcel_open_for_write_commit( DataHandle , Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN ) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER*80   FileName,SysDepInfo, mess
+  REAL dummy
+  INTEGER ierr
+
+  IF ( int_valid_handle ( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      okay_to_write( DataHandle ) = .true.
+      okay_to_read( DataHandle ) = .true.
+      opened_for_update( DataHandle ) = .false.
+    ENDIF
+  ENDIF
+
+! rest of this is handled lazy on first write
+
+  Status = 0
+
+  RETURN  
+END SUBROUTINE ext_mcel_open_for_write_commit
diff --git a/wrfv2_fire/external/io_mcel/ext_mcel_read_field.F90 b/wrfv2_fire/external/io_mcel/ext_mcel_read_field.F90
new file mode 100644
index 00000000..41992d83
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/ext_mcel_read_field.F90
@@ -0,0 +1,340 @@
+!--- read_field
+SUBROUTINE ext_mcel_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
+                            DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                            DomainStart , DomainEnd ,                                    &
+                            MemoryStart , MemoryEnd ,                                    &
+                            PatchStart , PatchEnd ,                                      &
+                            Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  integer                       ,intent(inout)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(inout)    :: DomainDesc
+  character*(*)                 ,intent(inout)    :: MemoryOrder
+  character*(*)                 ,intent(inout)    :: Stagger
+  character*(*) , dimension (*) ,intent(inout)    :: DimNames
+  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
+  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)   :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+  real, allocatable, dimension(:,:) :: temp
+  doubleprecision, allocatable, dimension(:,:) :: dtemp
+  integer gSize(2)
+  INTEGER, EXTERNAL :: cast_to_int
+integer myproc
+
+  character*132 mess
+  integer ips,ipe,jps,jpe
+  integer ims,ime,jms,jme
+  integer idex,ierr,i,j
+
+  integer ii,jj,kk,myrank,ierr, mcel_type
+  real*8 data_time
+  character*14 timestr
+  
+
+
+!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+!                   MemoryStart(2):MemoryEnd(2), &
+!                   MemoryStart(3):MemoryEnd(3) ) :: Field
+  REAL, DIMENSION(*)    :: Field
+
+  INTEGER inttypesize, realtypesize, istat, code
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: DataHandle not opened" )
+  ENDIF
+
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1) 
+  jps = PatchStart(2) ; jpe = PatchEnd(2) 
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+
+write(0,*)'ext_mcel_read_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
+
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  IF      ( FieldType .EQ. WRF_REAL ) THEN
+    typesize = rtypesize
+    mcel_type = MCEL_DATATYPE_REAL
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+    mcel_type = MCEL_DATATYPE_DOUBLE
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    typesize = itypesize
+    mcel_type = MCEL_DATATYPE_INT32
+  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
+    CALL wrf_error_fatal( 'io_int.F90: ext_mcel_write_field, WRF_LOGICAL not yet supported')
+  ENDIF
+
+  ! case 1: the file is opened but not commited for update 
+write(0,*)' read_field: okay_to_read: ', DataHandle, okay_to_read(DataHandle)
+write(0,*)' read_field: opened_for_update: ', DataHandle, opened_for_update(DataHandle)
+  if ( .not. okay_to_read( DataHandle ) )  then
+    IF ( opened_for_update( DataHandle) ) THEN
+write(0,*)'ext_mcel_read_field tr calling ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName)
+      CALL ext_mcel_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
+                                  DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                                  DomainStart , DomainEnd ,                                    &
+                                  MemoryStart , MemoryEnd ,                                    &
+                                  PatchStart , PatchEnd ,                                      &
+                                  ierr )
+      IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
+           TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
+        ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
+      ENDIF
+write(0,*)'ext_mcel_read_field tr back from ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName), ierr
+    ELSE
+
+! these will have been set in the call to open_for_read_begin from sysdepinfo
+      IF ( mcel_npglobal .NE. -1 .AND. mcel_mystart .NE. -1 .AND.  &
+           mcel_mnproc   .NE. -1 .AND. mcel_myproc  .NE. -1     ) THEN
+write(0,*)'ext_mcel_read_field tr setglobalsize ', TRIM(VarName), mcel_npglobal
+        call setglobalsize(open_file_descriptors(2,DataHandle),mcel_npglobal,ierr)
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalsize")
+write(0,*)'ext_mcel_read_field tr setglobalstart ', TRIM(VarName), mcel_mystart
+        call setglobalstart(open_file_descriptors(2,DataHandle),mcel_mystart,ierr)
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalstart")
+#if 0
+        call setprocinfo(open_file_descriptors(1,DataHandle),mcel_mnproc,mcel_myproc,ierr)
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setprocinfo")
+#endif
+      ENDIF
+      mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
+
+      ! sieve the fields coming in and grab the ones we need for geo registration
+      IF      ( TRIM(VarName) .EQ. TRIM(LAT_R(DataHandle)) ) THEN
+        IF ( ALLOCATED(xlat) ) THEN
+          DEALLOCATE(xlat)
+        ENDIF
+        ALLOCATE(xlat(ips:ipe,jps:jpe))
+        IF      ( FieldType .EQ. WRF_REAL ) THEN
+          CALL copy_field_to_cache_r2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+          CALL copy_field_to_cache_d2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        ENDIF
+
+      ELSE IF ( TRIM(VarName) .EQ. TRIM(LON_R(DataHandle)) ) THEN
+        IF ( ALLOCATED(xlong) ) THEN
+          DEALLOCATE(xlong)
+        ENDIF
+        ALLOCATE(xlong(ips:ipe,jps:jpe))
+        IF      ( FieldType .EQ. WRF_REAL ) THEN
+          CALL copy_field_to_cache_r2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+          CALL copy_field_to_cache_d2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        ENDIF
+      ELSE IF ( TRIM(VarName) .EQ. TRIM(LANDMASK_I(DataHandle)) ) THEN
+        IF ( ALLOCATED(mask) ) THEN
+          DEALLOCATE(mask)
+        ENDIF
+        ALLOCATE(mask(ips:ipe,jps:jpe))
+        IF ( FieldType .EQ. WRF_INTEGER ) THEN
+          CALL copy_field_to_cache_int ( Field, mask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
+          ALLOCATE(rmask(ips:ipe,jps:jpe))
+          CALL copy_field_to_cache_r2r ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+          mask = NINT( rmask )
+          DEALLOCATE(rmask)
+        ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
+          ALLOCATE(dmask(ips:ipe,jps:jpe))
+          CALL copy_field_to_cache_d2d ( Field, dmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+          mask = NINT( dmask )
+          DEALLOCATE(dmask)
+        ENDIF
+      ELSE
+        IF ( .NOT. mcel_grid_defined( DataHandle ) ) THEN
+          mcel_grid_defined( DataHandle ) = .true.
+          gSize(1) = ipe-ips+1
+          gSize(2) = jpe-jps+1
+write(0,*)'ext_mcel_read_field tr setSize ', TRIM(VarName), gSize
+          CALL setSize ( open_file_descriptors(2,DataHandle), gSize, ierr )
+          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setSize")
+        ENDIF
+write(0,*)'ext_mcel_read_field tr addSources ', TRIM(VarName), mcel_type
+        CALL addSources ( open_file_descriptors(1,DataHandle), MCEL_SERVER,  &
+  &       TRIM(VarName),1, mcel_type, ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addSources")
+write(0,*)'ext_mcel_read_field tr addOutputs ', TRIM(VarName), mcel_type
+        CALL addOutputs ( open_file_descriptors(1,DataHandle),   &
+  &       TRIM(VarName),1, mcel_type, ierr )
+! add this field to the list that we know something about
+        ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addOutputs")
+      ENDIF
+    ENDIF
+
+  ! case 2: opened for update and committed
+!  else if ( okay_to_write( DataHandle ) .and. opened_for_update( DataHandle) )  then
+  else if ( okay_to_read( DataHandle ) )  then
+
+write(0,*)'ext_mcel_read_field ok ', Trim(VarName)
+write(0,*)'ext_mcel_read_field LAT_R ', Trim(LAT_R(DataHandle))
+write(0,*)'ext_mcel_read_field LON_R ', Trim(LON_R(DataHandle))
+write(0,*)'ext_mcel_read_field LANDMASK_I ', Trim(LANDMASK_I(DataHandle))
+    IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
+         TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
+      IF ( .NOT. mcel_finalized( DataHandle ) ) THEN
+        IF ( ALLOCATED( xlat ) .AND. ALLOCATED( xlong ) ) THEN
+write(0,*)'ext_mcel_read_field ok setlocationsXY ', Trim(VarName)
+
+!call wrf_get_myproc(myproc)
+!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlong in read_field before setMask'
+!do j=jps,jpe
+!do i=ips,ipe
+!write(90+myproc,*)xlong(i,j)
+!enddo
+!enddo
+!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlat in read_field before setMask'
+!do j=jps,jpe
+!do i=ips,ipe
+!write(90+myproc,*)xlat(i,j)
+!enddo
+!enddo
+
+          CALL setLocationsXY( open_file_descriptors(2,DataHandle), xlong, xlat, ierr )
+          IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_read_field: setLocationsXY" )
+        ELSE IF ( deltax .gt. 0. .and. deltay .gt. 0. .and. originx .gt. 0. .and. originy .gt. 0. ) THEN
+          dxm(1) = deltax
+          dxm(2) = deltay
+          call SetDX ( open_file_descriptors(2,DataHandle), dxm, ierr)
+          origin(1) = originx
+          origin(2) = originy
+          call SetOrigin ( open_file_descriptors(2,DataHandle), origin, ierr)
+        ELSE
+          CALL wrf_error_fatal( "ext_mcel_read_field:noLocationsXY or dx/dy")
+        ENDIF
+        IF ( ALLOCATED(mask) ) THEN
+
+!write(0,*)'ext_mcel_read_field ok setMask ', Trim(VarName)
+!call wrf_get_myproc(myproc)
+!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' mask in read_field before setMask'
+!do j=jps,jpe
+!do i=ips,ipe
+!write(90+myproc,*)mask(i,j)
+!enddo
+!enddo
+
+          CALL setMask ( open_file_descriptors(2,DataHandle) , mask, ierr )
+          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setMask")
+        ENDIF
+write(0,*)'ext_mcel_read_field ok setoutputgrid ', Trim(VarName)
+        CALL setoutputgrid ( open_file_descriptors(1,DataHandle), open_file_descriptors(2,DataHandle), ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setoutputgrid")
+write(0,*)'ext_mcel_read_field ok finalizefilters ', Trim(VarName)
+        CALL finalizefilters ( open_file_descriptors(1,DataHandle), ierr )
+        IF ( ierr .GT. 0 .and. ierr .ne. 3 ) THEN
+           write(mess,*)'ext_mcel_open_for_read_field: finalizefilters ierr=',ierr
+           CALL wrf_error_fatal( TRIM(mess) )
+        ENDIF
+        mcel_finalized( DataHandle ) = .TRUE.
+      ENDIF
+
+      ! a little string munging, assumes that we're getting an ISO compliant date string
+      ! basically removing the delimeters
+
+      timestr = "              "
+      timestr(1:4)   = DateStr(1:4)    ! YYYY
+      timestr(5:6)   = DateStr(6:7)    ! MM
+      timestr(7:8)   = DateStr(9:10)   ! DD
+      timestr(9:10)  = DateStr(12:13)  ! HH
+      timestr(11:12) = DateStr(15:16)  ! MM
+      timestr(13:14) = DateStr(18:19)  ! SS
+
+      CALL YYYYMMDDHHMMSS2SECS( timestr, data_time )
+
+write(0,*)'TRIM( VarName ) ',TRIM( VarName )
+write(0,*)'TRIM( ListOfFields(DataHandle) ) ',TRIM( ListOfFields(DataHandle) )
+write(0,*)'INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )', INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )
+
+      IF ( INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) ) .EQ. 0 ) THEN
+        write(mess,*)'ext_mcel_open_for_read_field: ',TRIM( VarName ),' is not a field set up for DataHandle ', DataHandle
+        CALL wrf_error_fatal( TRIM(mess) )
+      ENDIF
+
+      IF ( FieldType .EQ. WRF_REAL ) THEN
+        ALLOCATE(temp(ips:ipe,jps:jpe))
+write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
+        IF ( opened_for_update(DataHandle) ) THEN
+          CALL copy_field_to_cache_r2r ( Field, temp, ips, ipe, jps, jpe, ims, ime, jms, jme )
+!call wrf_get_myproc(myproc)
+!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field before getData'
+!do j=jps,jpe
+!do i=ips,ipe
+!write(90+myproc,*)temp(i,j)
+!enddo
+!enddo
+          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp,                 &
+            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                       &
+            MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
+!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field after getData'
+!do j=jps,jpe
+!do i=ips,ipe
+!write(90+myproc,*)temp(i,j)
+!enddo
+!enddo
+!write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
+
+        ELSE
+! the difference is there is no KEEP in the FETCHPOLICY
+write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
+          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp,                 &
+            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                      &
+            MCEL_FETCHPOLICY_BLOCK,ierr)
+write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
+        ENDIF
+        CALL copy_cache_to_field_r2r ( temp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        DEALLOCATE(temp)
+      ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+
+        ALLOCATE(dtemp(ips:ipe,jps:jpe))
+write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
+        IF ( opened_for_update(DataHandle) ) THEN
+          CALL copy_field_to_cache_d2d ( Field, dtemp, ips, ipe, jps, jpe, ims, ime, jms, jme )
+write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
+          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp,                 &
+            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                       &
+            MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
+        ELSE
+! the difference is there is no KEEP in the FETCHPOLICY
+write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
+          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp,                 &
+            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                      &
+            MCEL_FETCHPOLICY_BLOCK,ierr)
+write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
+        ENDIF
+        CALL copy_cache_to_field_d2d ( dtemp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+
+        DEALLOCATE(dtemp)
+
+      ENDIF
+    ENDIF
+  endif
+
+  Status = 0
+
+  RETURN
+
+END SUBROUTINE ext_mcel_read_field
diff --git a/wrfv2_fire/external/io_mcel/ext_mcel_write_field.F90 b/wrfv2_fire/external/io_mcel/ext_mcel_write_field.F90
new file mode 100644
index 00000000..39814841
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/ext_mcel_write_field.F90
@@ -0,0 +1,229 @@
+!--- write_field
+SUBROUTINE ext_mcel_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
+                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                             DomainStart , DomainEnd ,                                    &
+                             MemoryStart , MemoryEnd ,                                    &
+                             PatchStart , PatchEnd ,                                      &
+                             Status )
+  USE module_ext_mcel
+!  USE module_date_time   ! defined in share
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName
+  integer                       ,intent(in)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrder
+  character*(*)                 ,intent(in)    :: Stagger
+  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 ips,ipe,jps,jpe
+  integer ims,ime,jms,jme
+  integer idex,ierr,i,j
+
+  integer ii,jj,kk,myrank,mcel_type
+  integer gSize(2)
+  integer idts
+  real*8 data_time
+  CHARACTER*256 RollOverDeathDate
+  CHARACTER*80 mess, timestr
+  INTEGER, EXTERNAL :: cast_to_int
+
+!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
+!                   MemoryStart(2):MemoryEnd(2), &
+!                   MemoryStart(3):MemoryEnd(3) ) :: Field
+
+  REAL, DIMENSION(*)    :: Field
+
+  real, allocatable, dimension(:,:) :: temp
+  integer, allocatable, dimension(:,:) :: itemp
+  doubleprecision, allocatable, dimension(:,:) :: dtemp
+
+  INTEGER inttypesize, realtypesize
+
+write(0,*)"write field : called "
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_write_field: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_write_field: DataHandle not opened" )
+  ENDIF
+
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  IF      ( FieldType .EQ. WRF_REAL ) THEN
+    typesize = rtypesize
+    mcel_type = MCEL_DATATYPE_REAL
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+    mcel_type = MCEL_DATATYPE_DOUBLE
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    typesize = itypesize
+    mcel_type = MCEL_DATATYPE_INT32
+  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
+    CALL wrf_error_fatal( 'io_int.F90: ext_mcel_write_field, WRF_LOGICAL not yet supported')
+  ENDIF
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1) 
+  jps = PatchStart(2) ; jpe = PatchEnd(2) 
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+
+write(0,*)"write field : okay_to_write ",okay_to_write( DataHandle )
+
+  IF ( okay_to_write( DataHandle ) ) THEN
+    IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
+         TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
+      IF ( .NOT. mcel_finalized( DataHandle ) ) THEN
+        IF ( ALLOCATED( xlat ) .AND. ALLOCATED( xlong ) ) THEN
+          CALL setLocationsXY( open_file_descriptors(2,DataHandle), xlong, xlat, ierr )
+          IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_write_field: setLocationsXY" )
+        ELSE IF ( deltax .gt. 0. .and. deltay .gt. 0. .and. originx .gt. 0. .and. originy .gt. 0. ) THEN
+          dxm(1) = deltax
+          dxm(2) = deltay
+          call SetDX ( open_file_descriptors(2,DataHandle), dxm, ierr)
+          origin(1) = originx
+          origin(2) = originy
+          call SetOrigin ( open_file_descriptors(2,DataHandle), origin, ierr)
+        ELSE
+          CALL wrf_error_fatal( "ext_mcel_write_field:noLocationsXY")
+        ENDIF
+        IF ( ALLOCATED(mask) ) THEN
+          CALL setMask ( open_file_descriptors(2,DataHandle) , mask, ierr )
+          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setMask")
+        ENDIF
+        CALL setGrid ( open_file_descriptors(1,DataHandle), open_file_descriptors(2,DataHandle), ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setGrid")
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setoutputgrid")
+        CALL finalize ( open_file_descriptors(1,DataHandle), ierr )
+        IF ( ierr .GT. 0 ) THEN
+           write(mess,*)'ext_mcel_write_field: finalize ierr=',ierr
+           CALL wrf_error_fatal( TRIM(mess) )
+        ENDIF
+        mcel_finalized( DataHandle ) = .TRUE.
+      ENDIF
+
+      timestr(1:4)   = DateStr(1:4)    ! YYYY
+      timestr(5:6)   = DateStr(6:7)    ! MM
+      timestr(7:8)   = DateStr(9:10)   ! DD
+      timestr(9:10)  = DateStr(12:13)  ! HH
+      timestr(11:12) = DateStr(15:16)  ! MM
+      timestr(13:14) = DateStr(18:19)  ! SS
+      CALL YYYYMMDDHHMMSS2SECS( timestr, data_time )
+
+      IF ( FieldType .EQ. WRF_INTEGER ) THEN
+        ALLOCATE(itemp(ips:ipe,jps:jpe))
+        DO j = jps, jpe
+          DO i = ips, ipe
+            idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+            itemp(i,j) = cast_to_int(Field( idex ))
+          ENDDO
+        ENDDO
+        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
+                        itemp, &
+                        data_time, data_time,  &
+                        MCEL_TIMECENT_POINT, ierr )
+        DEALLOCATE(itemp)
+      ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+        ALLOCATE(dtemp(ips:ipe,jps:jpe))
+        CALL copy_field_to_cache_d2d ( Field, dtemp, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
+                        dtemp, &
+                        data_time, data_time,  &
+                        MCEL_TIMECENT_POINT, ierr )
+        DEALLOCATE(dtemp)
+      ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
+        ALLOCATE(temp(ips:ipe,jps:jpe))
+        CALL copy_field_to_cache_r2r ( Field, temp, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
+                        temp, &
+                        data_time, data_time,  &
+                        MCEL_TIMECENT_POINT, ierr )
+        DEALLOCATE(temp)
+      ENDIF
+
+      IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: storeData")
+
+    ENDIF
+  ELSE   ! opened for training
+
+    ! sieve the fields coming in and grab the ones we need for geo registration
+    IF      ( TRIM(VarName) .EQ. TRIM(LAT_R(DataHandle)) ) THEN
+      IF ( ALLOCATED(xlat) ) THEN
+        DEALLOCATE(xlat)
+      ENDIF
+      ALLOCATE(xlat(ips:ipe,jps:jpe))
+      IF      ( FieldType .EQ. WRF_REAL ) THEN
+        CALL copy_field_to_cache_r2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
+      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
+        CALL copy_field_to_cache_d2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
+      ENDIF
+    ELSE IF ( TRIM(VarName) .EQ. TRIM(LON_R(DataHandle)) ) THEN
+      IF ( ALLOCATED(xlong) ) THEN
+        DEALLOCATE(xlong)
+      ENDIF
+      ALLOCATE(xlong(ips:ipe,jps:jpe))
+      IF      ( FieldType .EQ. WRF_REAL ) THEN
+        CALL copy_field_to_cache_r2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
+      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
+        CALL copy_field_to_cache_d2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
+      ENDIF
+    ELSE IF ( TRIM(VarName) .EQ. TRIM(LANDMASK_I(DataHandle)) ) THEN
+write(0,*)'write_field: ALLOCATED(mask)', ALLOCATED(mask)
+      IF ( ALLOCATED(mask) ) THEN
+        DEALLOCATE(mask)
+      ENDIF
+      ALLOCATE(mask(ips:ipe,jps:jpe))
+      IF ( FieldType .EQ. WRF_INTEGER ) THEN
+        CALL copy_field_to_cache_int ( Field, mask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+      ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
+        ALLOCATE(rmask(ips:ipe,jps:jpe))
+        CALL copy_field_to_cache_r2r ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        mask = NINT( rmask )
+        DEALLOCATE(rmask)
+      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
+        ALLOCATE(dmask(ips:ipe,jps:jpe))
+        CALL copy_field_to_cache_d2d ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
+        mask = NINT( dmask )
+        DEALLOCATE(dmask)
+      ENDIF
+    ELSE
+      IF ( .NOT. mcel_grid_defined( DataHandle ) ) THEN
+        mcel_grid_defined( DataHandle ) = .true.
+
+        gSize(1) = ipe-ips+1
+        gSize(2) = jpe-jps+1
+        CALL setSize ( open_file_descriptors(2,DataHandle), gSize, ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setSize")
+
+! these will have been set in the call to open_for_write_begin from sysdepinfo
+        IF ( mcel_npglobal .NE. -1 .AND. mcel_mystart .NE. -1 .AND.  &
+             mcel_mnproc   .NE. -1 .AND. mcel_myproc  .NE. -1     ) THEN
+          call setglobalsize(open_file_descriptors(2,DataHandle),mcel_npglobal,ierr)
+          call setglobalstart(open_file_descriptors(2,DataHandle),mcel_mystart,ierr)
+          call setprocinfo(open_file_descriptors(1,DataHandle),mcel_mnproc,mcel_myproc,ierr)
+        ENDIF
+        mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
+
+      ENDIF
+      IF ( opened_for_read( DataHandle) ) THEN
+        CALL addSources ( open_file_descriptors(1,DataHandle), MCEL_SERVER,  &
+  &       TRIM(VarName),1, mcel_type, ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addSources")
+        CALL addOutputs ( open_file_descriptors(1,DataHandle),   &
+  &       TRIM(VarName),1, mcel_type, ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addOutputs")
+      ELSE
+        CALL addVar ( open_file_descriptors(1,DataHandle), TRIM(VarName), mcel_type, ierr )
+        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addVar")
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+  RETURN
+END SUBROUTINE ext_mcel_write_field
diff --git a/wrfv2_fire/external/io_mcel/io_mcel.F90 b/wrfv2_fire/external/io_mcel/io_mcel.F90
new file mode 100644
index 00000000..666b335c
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/io_mcel.F90
@@ -0,0 +1,1187 @@
+MODULE module_ext_mcel
+
+  INTEGER, PARAMETER :: int_num_handles = 99
+  LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, okay_to_read,                     &
+                                         opened_for_write, opened_for_update,             &
+                                         opened_for_read,                                 &
+                                         int_handle_in_use, okay_to_commit
+  LOGICAL, DIMENSION(int_num_handles) :: mcel_grid_defined, mcel_finalized
+  INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write
+  INTEGER, DIMENSION(int_num_handles) :: usemask
+  CHARACTER*256, DIMENSION(int_num_handles) :: CurrentDateInFile
+  CHARACTER*8092, DIMENSION(int_num_handles) :: ListOfFields
+  REAL, POINTER    :: int_local_output_buffer(:)
+  INTEGER          :: int_local_output_cursor
+  INTEGER          :: mcel_npglobal, mcel_mystart, mcel_mnproc, mcel_myproc
+
+  INTEGER, PARAMETER           :: onebyte = 1
+  INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
+  INTEGER itypesize, rtypesize, typesize
+  INTEGER, DIMENSION(512)     :: hdrbuf
+  INTEGER, DIMENSION(int_num_handles)       :: handle
+  INTEGER, DIMENSION(512, int_num_handles)  :: open_file_descriptors
+  INCLUDE "MCEL.inc"
+  INCLUDE 'intio_tags.h'
+  INCLUDE 'wrf_io_flags.h'
+  INCLUDE 'wrf_status_codes.h'
+  CHARACTER*80  LAT_R(int_num_handles), LON_R(int_num_handles), LANDMASK_I(int_num_handles)
+
+  REAL*8, ALLOCATABLE :: xlat(:,:), xlong(:,:)
+  REAL*8              :: deltax, deltay, dxm(2)
+  REAL*8              :: originx, originy, origin(2)
+  INTEGER, ALLOCATABLE :: mask(:,:)
+  REAL, ALLOCATABLE :: rmask(:,:)
+  DOUBLEPRECISION, ALLOCATABLE :: dmask(:,:)
+
+  CHARACTER*132 last_next_var 
+
+  CONTAINS
+
+    LOGICAL FUNCTION int_valid_handle( handle )
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) ::  handle
+      int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles ) 
+    END FUNCTION int_valid_handle
+
+    SUBROUTINE int_get_fresh_handle( retval )
+!      USE wrf_data, ONLY : wrf_data_handle
+!      USE ext_ncd_support_routines, ONLY : allocHandle
+!      type(wrf_data_handle),pointer     :: DH
+!      INTEGER i, retval, comm, Status
+      INTEGER i, retval
+
+#if 0
+      CALL allocHandle(retval,DH,Comm,Status)
+#endif
+
+      retval = -1
+! dont use first 8 handles
+      DO i = 8, int_num_handles
+        IF ( .NOT. int_handle_in_use(i) )  THEN
+          retval = i
+          GOTO 33
+        ENDIF
+      ENDDO
+33    CONTINUE
+      IF ( retval < 0 )  THEN
+        CALL wrf_error_fatal("external/io_quilt/io_int.F90: int_get_fresh_handle() can not")
+      ENDIF
+      int_handle_in_use(retval) = .TRUE.
+      NULLIFY ( int_local_output_buffer )
+    END SUBROUTINE int_get_fresh_handle
+
+! parse comma separated list of VARIABLE=VALUE strings and return the
+! value for the matching variable if such exists, otherwise return
+! the empty string
+SUBROUTINE get_value ( varname , str , retval )
+  IMPLICIT NONE
+  CHARACTER*(*) ::    varname
+  CHARACTER*(*) ::    str
+  CHARACTER*(*) ::    retval
+
+  CHARACTER (128) varstr, tstr
+  INTEGER i,j,n,varstrn
+  LOGICAL nobreak, nobreakouter
+
+  varstr = TRIM(varname)//"="
+  varstrn = len(TRIM(varstr))
+  n = len(TRIM(str))
+  retval = ""
+  i = 1
+  nobreakouter = .TRUE.
+  DO WHILE ( nobreakouter )
+    j = 1
+    nobreak = .TRUE.
+    tstr = ""
+    DO WHILE ( nobreak )
+      nobreak = .FALSE.
+      IF ( i .LE. n ) THEN
+        IF (str(i:i) .NE. ',' ) THEN
+           tstr(j:j) = str(i:i)
+           nobreak = .TRUE.
+        ENDIF
+      ENDIF
+      j = j + 1
+      i = i + 1
+    ENDDO
+    IF ( i .GT. n ) nobreakouter = .FALSE.
+    IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
+      retval(1:) = TRIM(tstr(varstrn+1:))
+      nobreakouter = .FALSE.
+    ENDIF
+  ENDDO
+  RETURN
+END SUBROUTINE get_value
+
+
+    !--- ioinit
+    SUBROUTINE init_module_ext_mcel
+      IMPLICIT NONE
+      CALL wrf_sizeof_integer( itypesize )
+      CALL wrf_sizeof_real   ( rtypesize )
+    END SUBROUTINE init_module_ext_mcel
+
+END MODULE module_ext_mcel
+
+ SUBROUTINE copy_field_to_cache_r2r ( Field, cache, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   REAL             Field(*)
+   REAL             cache(ips:ipe,jps:jpe)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        cache(i,j) = Field( idex )
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_field_to_cache_r2r
+
+ SUBROUTINE copy_field_to_cache_r2d ( Field, cache, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   REAL             Field(*)
+   DOUBLE PRECISION cache(ips:ipe,jps:jpe)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        cache(i,j) = Field( idex )
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_field_to_cache_r2d
+
+ SUBROUTINE copy_field_to_cache_d2r ( Field, cache, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   DOUBLE PRECISION Field(*) 
+   REAL             cache(ips:ipe,jps:jpe)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        cache(i,j) = Field( idex )
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_field_to_cache_d2r
+
+ SUBROUTINE copy_field_to_cache_d2d ( Field, cache, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   DOUBLE PRECISION Field(*) 
+   DOUBLE PRECISION cache(ips:ipe,jps:jpe)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        cache(i,j) = Field( idex )
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_field_to_cache_d2d
+
+ SUBROUTINE copy_field_to_cache_int ( Field, cache, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   INTEGER Field(*)
+   INTEGER cache(ips:ipe,jps:jpe)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        cache(i,j) = Field( idex )
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_field_to_cache_int
+
+ SUBROUTINE copy_cache_to_field_r2r ( cache, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   REAL            cache(ips:ipe,jps:jpe)
+   REAL            Field(*)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        Field( idex ) = cache(i,j)
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_cache_to_field_r2r
+
+ SUBROUTINE copy_cache_to_field_r2d ( cache, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   REAL             cache(ips:ipe,jps:jpe)
+   DOUBLEPRECISION  Field(*)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        Field( idex ) = cache(i,j)
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_cache_to_field_r2d
+
+ SUBROUTINE copy_cache_to_field_d2r ( cache, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   DOUBLEPRECISION  cache(ips:ipe,jps:jpe)
+   REAL             Field(*)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        Field( idex ) = cache(i,j)
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_cache_to_field_d2r
+
+ SUBROUTINE copy_cache_to_field_d2d ( cache, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
+   USE module_ext_mcel
+   INTEGER FieldType, ips, ipe, jps, jpe, ims, ime, jms, jme
+   INTEGER idex, i, j
+   DOUBLEPRECISION  cache(ips:ipe,jps:jpe)
+   DOUBLEPRECISION  Field(*)
+   DO j = jps, jpe
+     DO i = ips, ipe
+        idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+        Field( idex ) = cache(i,j)
+     ENDDO
+   ENDDO
+ END SUBROUTINE copy_cache_to_field_d2d
+
+!--------------
+
+SUBROUTINE ext_mcel_ioinit( SysDepInfo, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  CHARACTER*(*), INTENT(IN) :: SysDepInfo
+  INTEGER Status
+  CALL init_module_ext_mcel
+  Status = 0 
+END SUBROUTINE ext_mcel_ioinit
+
+!--- open_for_read 
+SUBROUTINE ext_mcel_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                               DataHandle , Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
+  CHARACTER*(*) :: SysDepInfo
+  INTEGER ,       INTENT(OUT) :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i
+
+  CALL int_get_fresh_handle(i)
+  okay_to_write(i) = .false.
+  DataHandle = i
+  CurrentDateInFile(i) = ""
+  Status = WRF_WARN_NOTSUPPORTED
+
+  RETURN  
+END SUBROUTINE ext_mcel_open_for_read
+
+
+!--- inquire_opened
+SUBROUTINE ext_mcel_inquire_opened ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = 0
+
+  FileStatus = WRF_FILE_NOT_OPENED
+  IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN
+    IF      ( int_handle_in_use( DataHandle ) .AND. opened_for_read ( DataHandle ) ) THEN
+      IF ( okay_to_read ( DataHandle ) ) THEN
+        FileStatus = WRF_FILE_OPENED_FOR_READ
+      ELSE
+        FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+      ENDIF
+    ELSE IF ( int_handle_in_use( DataHandle ) .AND. opened_for_write ( DataHandle ) ) THEN
+      IF ( okay_to_write ( DataHandle ) ) THEN
+        FileStatus = WRF_FILE_OPENED_FOR_WRITE
+      ELSE
+        FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+  
+  RETURN
+END SUBROUTINE ext_mcel_inquire_opened
+
+!--- inquire_filename
+SUBROUTINE ext_mcel_inquire_filename ( DataHandle, FileName , FileStatus, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: FileName
+  INTEGER ,       INTENT(OUT) :: FileStatus
+  INTEGER ,       INTENT(OUT) :: Status
+  CHARACTER *80   SysDepInfo
+  Status = 0
+  FileStatus = WRF_FILE_NOT_OPENED
+  IF ( int_valid_handle( DataHandle ) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      IF ( opened_for_read ( DataHandle ) ) THEN
+        IF ( okay_to_read( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_READ
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE IF ( opened_for_write( DataHandle ) ) THEN
+        IF ( okay_to_write( DataHandle ) ) THEN
+           FileStatus = WRF_FILE_OPENED_FOR_WRITE
+        ELSE
+           FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
+        ENDIF
+      ELSE
+        FileStatus = WRF_FILE_NOT_OPENED
+      ENDIF
+    ENDIF
+  ENDIF
+  Status = 0
+END SUBROUTINE ext_mcel_inquire_filename
+
+!--- sync
+SUBROUTINE ext_mcel_iosync ( DataHandle, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = 0
+  RETURN
+END SUBROUTINE ext_mcel_iosync
+
+!--- close
+SUBROUTINE ext_mcel_ioclose ( DataHandle, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER DataHandle, Status
+
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      CLOSE ( DataHandle ) 
+    ENDIF
+  ENDIF
+
+  Status = 0
+
+  RETURN
+END SUBROUTINE ext_mcel_ioclose
+
+!--- ioexit
+SUBROUTINE ext_mcel_ioexit( Status )
+
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER                     :: DataHandle
+  INTEGER i,ierr
+  REAL dummy
+
+  RETURN  
+END SUBROUTINE ext_mcel_ioexit
+
+!--- get_next_time
+SUBROUTINE ext_mcel_get_next_time ( DataHandle, DateStr, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER         code
+  CHARACTER*132   locElement, dummyvar
+  INTEGER istat
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize
+  REAL, DIMENSION( 1 ) :: Field
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_next_time: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_next_time: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+
+  Status = WRF_WARN_NOTSUPPORTED
+
+  RETURN
+END SUBROUTINE ext_mcel_get_next_time
+
+!--- set_time
+SUBROUTINE ext_mcel_set_time ( DataHandle, DateStr, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: DateStr
+  INTEGER ,       INTENT(OUT) :: Status
+
+  Status = WRF_WARN_NOTSUPPORTED
+  RETURN
+END SUBROUTINE ext_mcel_set_time
+
+!--- get_var_info
+SUBROUTINE ext_mcel_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
+                              DomainStart , DomainEnd , WrfType, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: VarName
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)         ,intent(out)    :: Stagger
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize, istat, code
+  REAL, DIMENSION( 1 ) :: Field
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_var_info: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_var_info: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+  Status = 0
+
+RETURN
+END SUBROUTINE ext_mcel_get_var_info
+
+!--- get_next_var  (not defined for IntIO)
+SUBROUTINE ext_mcel_get_next_var ( DataHandle, VarName, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: VarName
+  INTEGER ,       INTENT(OUT) :: Status
+
+!local
+  INTEGER                        :: locDataHandle
+  CHARACTER*132                  :: locDateStr
+  CHARACTER*132                  :: locVarName
+  integer                        :: locFieldType
+  integer                        :: locComm
+  integer                        :: locIOComm
+  integer                        :: locDomainDesc
+  character*132                  :: locMemoryOrder
+  character*132                  :: locStagger
+  character*132 , dimension (3)  :: locDimNames
+  integer ,dimension(3)          :: locDomainStart, locDomainEnd
+  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
+  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
+
+character*128 locElement, strData, dumstr
+integer loccode, loccount
+integer idata(128)
+real    rdata(128)
+
+  character*132 mess
+  integer ii,jj,kk,myrank
+  INTEGER inttypesize, realtypesize, istat, code
+  REAL, DIMENSION( 1 ) :: Field
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_next_var: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_get_next_var: DataHandle not opened" )
+  ENDIF
+  inttypesize = itypesize
+  realtypesize = rtypesize
+
+  Status = 0
+
+  RETURN
+END SUBROUTINE ext_mcel_get_next_var
+
+!--- get_dom_ti_real
+SUBROUTINE ext_mcel_get_dom_ti_real ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Outcount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER loccount, code, istat, locDataHandle
+  CHARACTER*132                :: locElement, mess
+  LOGICAL keepgoing
+
+  Status = 0
+
+RETURN
+END SUBROUTINE ext_mcel_get_dom_ti_real 
+
+!--- put_dom_ti_real
+SUBROUTINE ext_mcel_put_dom_ti_real ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+!
+
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_put_dom_ti_real 
+
+!--- get_dom_ti_double
+SUBROUTINE ext_mcel_get_dom_ti_double ( DataHandle,Element,   Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_mcel_get_dom_ti_double not supported yet')
+RETURN
+END SUBROUTINE ext_mcel_get_dom_ti_double 
+
+!--- put_dom_ti_double
+SUBROUTINE ext_mcel_put_dom_ti_double ( DataHandle,Element,   Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_mcel_put_dom_ti_double not supported yet')
+RETURN
+END SUBROUTINE ext_mcel_put_dom_ti_double 
+
+!--- get_dom_ti_integer
+SUBROUTINE ext_mcel_get_dom_ti_integer ( DataHandle,Element,   Data, Count, Outcount, Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER loccount, code, istat, locDataHandle
+  CHARACTER*132   locElement, mess
+  LOGICAL keepgoing
+
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_get_dom_ti_integer 
+
+!--- put_dom_ti_integer
+SUBROUTINE ext_mcel_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  INTEGER ,       INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+!
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_put_dom_ti_integer 
+
+!--- get_dom_ti_logical
+SUBROUTINE ext_mcel_get_dom_ti_logical ( DataHandle,Element,   Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_mcel_get_dom_ti_logical not supported yet')
+RETURN
+END SUBROUTINE ext_mcel_get_dom_ti_logical 
+
+!--- put_dom_ti_logical
+SUBROUTINE ext_mcel_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  CALL wrf_message('ext_mcel_put_dom_ti_logical not supported yet')
+RETURN
+END SUBROUTINE ext_mcel_put_dom_ti_logical 
+
+!--- get_dom_ti_char
+SUBROUTINE ext_mcel_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER istat, code, i
+  CHARACTER*79 dumstr, locElement
+  INTEGER locDataHandle
+  LOGICAL keepgoing
+
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_get_dom_ti_char 
+
+!--- put_dom_ti_char
+SUBROUTINE ext_mcel_put_dom_ti_char ( DataHandle, Element,  Data,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER i
+  REAL dummy
+  INTEGER                 :: Count
+
+! TBH:  Not sure what this is doing here.  2004_11_15
+! JGM:  You are right. It does not belong here.  2006_09_28
+!  IF ( int_valid_handle ( Datahandle ) ) THEN
+!    IF ( int_handle_in_use( DataHandle ) ) THEN
+!      CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
+!                                   DataHandle, Element, "", Data, int_dom_ti_char )
+!      WRITE( unit=DataHandle ) hdrbuf 
+!    ENDIF
+!  ENDIF
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_put_dom_ti_char 
+
+!--- get_dom_td_real
+SUBROUTINE ext_mcel_get_dom_td_real ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_dom_td_real 
+
+!--- put_dom_td_real
+SUBROUTINE ext_mcel_put_dom_td_real ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_dom_td_real 
+
+!--- get_dom_td_double
+SUBROUTINE ext_mcel_get_dom_td_double ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_dom_td_double 
+
+!--- put_dom_td_double
+SUBROUTINE ext_mcel_put_dom_td_double ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_dom_td_double 
+
+!--- get_dom_td_integer
+SUBROUTINE ext_mcel_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_dom_td_integer 
+
+!--- put_dom_td_integer
+SUBROUTINE ext_mcel_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_dom_td_integer 
+
+!--- get_dom_td_logical
+SUBROUTINE ext_mcel_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_dom_td_logical 
+
+!--- put_dom_td_logical
+SUBROUTINE ext_mcel_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_dom_td_logical 
+
+!--- get_dom_td_char
+SUBROUTINE ext_mcel_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_dom_td_char 
+
+!--- put_dom_td_char
+SUBROUTINE ext_mcel_put_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_dom_td_char 
+
+!--- get_var_ti_real
+SUBROUTINE ext_mcel_get_var_ti_real ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_ti_real 
+
+!--- put_var_ti_real
+SUBROUTINE ext_mcel_put_var_ti_real ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_ti_real 
+
+!--- get_var_ti_double
+SUBROUTINE ext_mcel_get_var_ti_double ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_ti_double 
+
+!--- put_var_ti_double
+SUBROUTINE ext_mcel_put_var_ti_double ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_ti_double 
+
+!--- get_var_ti_integer
+SUBROUTINE ext_mcel_get_var_ti_integer ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_ti_integer 
+
+!--- put_var_ti_integer
+SUBROUTINE ext_mcel_put_var_ti_integer ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_ti_integer 
+
+!--- get_var_ti_logical
+SUBROUTINE ext_mcel_get_var_ti_logical ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_ti_logical 
+
+!--- put_var_ti_logical
+SUBROUTINE ext_mcel_put_var_ti_logical ( DataHandle,Element,  Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_ti_logical 
+
+!--- get_var_ti_char
+SUBROUTINE ext_mcel_get_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  INTEGER locDataHandle, code
+  CHARACTER*132 locElement, locVarName
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_get_var_ti_char 
+
+!--- put_var_ti_char
+SUBROUTINE ext_mcel_put_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+  REAL dummy
+  INTEGER                 :: Count
+  Status = 0
+RETURN
+END SUBROUTINE ext_mcel_put_var_ti_char 
+
+!--- get_var_td_real
+SUBROUTINE ext_mcel_get_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_td_real 
+
+!--- put_var_td_real
+SUBROUTINE ext_mcel_put_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_td_real 
+
+!--- get_var_td_double
+SUBROUTINE ext_mcel_get_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_td_double 
+
+!--- put_var_td_double
+SUBROUTINE ext_mcel_put_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  real*8 ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_td_double 
+
+!--- get_var_td_integer
+SUBROUTINE ext_mcel_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_td_integer 
+
+!--- put_var_td_integer
+SUBROUTINE ext_mcel_put_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_td_integer 
+
+!--- get_var_td_logical
+SUBROUTINE ext_mcel_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(OUT) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT)  :: OutCount
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_td_logical 
+
+!--- put_var_td_logical
+SUBROUTINE ext_mcel_put_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  logical ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_td_logical 
+
+!--- get_var_td_char
+SUBROUTINE ext_mcel_get_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_get_var_td_char 
+
+!--- put_var_td_char
+SUBROUTINE ext_mcel_put_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
+  IMPLICIT NONE
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: DateStr
+  CHARACTER*(*) :: VarName 
+  CHARACTER*(*) :: Data
+  INTEGER ,       INTENT(OUT) :: Status
+RETURN
+END SUBROUTINE ext_mcel_put_var_td_char 
+
+SUBROUTINE ext_mcel_georegister( DataHandle, inlon, inlat,                                    &
+                                 MemoryStart , MemoryEnd ,                                    &
+                                 PatchStart , PatchEnd ,                                      &
+                                 Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  integer                       ,intent(in)    :: DataHandle
+  integer                       ,intent(inout) :: Status
+  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
+  REAL , DIMENSION(MemoryStart(1):MemoryEnd(1),MemoryStart(2):MemoryEnd(2)), INTENT(IN) :: inlon, inlat
+  integer ips,ipe,jps,jpe
+  integer ims,ime,jms,jme
+  integer idex,ierr,i,j
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_georegister: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_georegister: DataHandle not opened" )
+  ENDIF
+  IF ( mcel_finalized( DataHandle ) ) THEN
+    CALL wrf_error_fatal( "ext_mcel_georegister: called after first read/write operation" ) ;
+  ENDIF
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1)
+  jps = PatchStart(2) ; jpe = PatchEnd(2)
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+
+  IF ( ALLOCATED(xlat) ) THEN
+    DEALLOCATE(xlat)
+  ENDIF
+  IF ( ALLOCATED(xlong) ) THEN
+    DEALLOCATE(xlong)
+  ENDIF
+  ALLOCATE(xlat(ips:ipe,jps:jpe))
+  DO j = jps, jpe
+    DO i = ips, ipe
+      idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+      xlat(i,j) = inlat( i,j)  ! idex )
+    ENDDO
+  ENDDO
+  ALLOCATE(xlong(ips:ipe,jps:jpe))
+  DO j = jps, jpe
+    DO i = ips, ipe
+      idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+      xlong(i,j) = inlon( i,j ) ! idex )
+    ENDDO
+  ENDDO
+  RETURN
+END SUBROUTINE ext_mcel_georegister
+
+SUBROUTINE ext_mcel_mask ( DataHandle, inmask,                                          &
+                           MemoryStart , MemoryEnd ,                                    &
+                           PatchStart , PatchEnd ,                                      &
+                           Status )
+  USE module_ext_mcel
+  IMPLICIT NONE
+  integer                       ,intent(in)    :: DataHandle
+  integer                       ,intent(inout) :: Status
+  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
+  INTEGER , DIMENSION(MemoryStart(1):MemoryEnd(1),MemoryStart(2):MemoryEnd(2)), INTENT(IN) :: inmask
+  integer ips,ipe,jps,jpe
+  integer ims,ime,jms,jme
+  integer idex,ierr,i,j
+
+  ips = PatchStart(1) ; ipe = PatchEnd(1)
+  jps = PatchStart(2) ; jpe = PatchEnd(2)
+  ims = MemoryStart(1) ; ime = MemoryEnd(1)
+  jms = MemoryStart(2) ; jme = MemoryEnd(2)
+
+  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_mask: invalid data handle" )
+  ENDIF
+  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
+    CALL wrf_error_fatal("ext_mcel_mask: DataHandle not opened" )
+  ENDIF
+  IF ( mcel_finalized( DataHandle ) ) THEN
+    CALL wrf_error_fatal( "ext_mcel_mask: called after first read/write operation" ) ;
+  ENDIF
+
+  IF ( ALLOCATED(mask) ) THEN
+    DEALLOCATE(mask)
+  ENDIF
+  ALLOCATE(mask(ips:ipe,jps:jpe))
+  DO j = jps, jpe
+    DO i = ips, ipe
+      idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
+      mask(i,j) = inmask( i,j ) ! idex )
+    ENDDO
+  ENDDO
+  RETURN
+END SUBROUTINE ext_mcel_mask
+
+INTEGER FUNCTION cast_to_int( a )
+  INTEGER a
+  cast_to_int = a
+  RETURN
+END FUNCTION cast_to_int
+
diff --git a/wrfv2_fire/external/io_mcel/makefile b/wrfv2_fire/external/io_mcel/makefile
new file mode 100644
index 00000000..47408d62
--- /dev/null
+++ b/wrfv2_fire/external/io_mcel/makefile
@@ -0,0 +1,35 @@
+#makefile to build io_mcel that does binary i/o
+
+OBJSL   = io_mcel.o ext_mcel_open_for_read.o ext_mcel_open_for_write.o ext_mcel_read_field.o ext_mcel_write_field.o
+OBJS    = $(OBJSL)
+OPTS    =
+FFLAGS  =  $(OPTS) -w -g
+LIBS    = 
+CPP     = /lib/cpp -C -P $(TRADFLAG)
+M4      = m4 -Uinclude -Uindex -Ulen
+AR      = ar
+RANLIB  = echo
+
+.SUFFIXES:      .F90 .F .f .o .code
+
+all : libwrfio_mcel.a
+
+libwrfio_mcel.a:		$(OBJS)
+			/bin/rm -f libwrfio_mcel.a
+			$(AR) cr libwrfio_mcel.a $(OBJSL)
+			$(RANLIB) libwrfio_mcel.a
+
+.F90.o:
+			$(CPP) $*.F90 | $(M4) - > $*.f
+			$(FC) $(FFLAGS) -I../ioapi_share -c $*.f
+
+superclean:
+			/bin/rm -f *.f *.o libwrfio_mcel.a
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+ext_mcel_open_for_read.o : io_mcel.o
+ext_mcel_open_for_write.o : io_mcel.o
+ext_mcel_read_field.o : io_mcel.o
+ext_mcel_write_field.o : io_mcel.o
+
diff --git a/wrfv2_fire/external/io_netcdf/README b/wrfv2_fire/external/io_netcdf/README
new file mode 100644
index 00000000..467c2d6b
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/README
@@ -0,0 +1,38 @@
+This is a tar file of the WRF NetCDF I/O library.
+
+The tar file contains these files:
+
+-rw-r--r--   1 jacquesm ad           1968 Nov 27 13:43 README
+-rw-r--r--   1 jacquesm ad          15121 Nov 27 11:44 WRFIO.doc
+-rw-r--r--   1 jacquesm ad           4447 Nov 14 16:26 ext_get_glb_md.code
+-rw-r--r--   1 jacquesm ad           5068 Nov 17 14:56 ext_get_var_md.code
+-rw-r--r--   1 jacquesm ad           6766 Nov 17 15:12 ext_get_vartime_md.code
+-rw-r--r--   1 jacquesm ad           4106 Nov 14 15:04 ext_put_glb_md.code
+-rw-r--r--   1 jacquesm ad           4124 Nov 14 15:04 ext_put_var_md.code
+-rw-r--r--   1 jacquesm ad           7147 Nov 14 15:04 ext_put_vartime_md.code
+-rw-r--r--   1 jacquesm ad           6222 Nov 27 11:30 field_routines.F90
+-rw-r--r--   1 jacquesm ad             47 Oct 18 11:59 howto.ncdump
+-rw-r--r--   1 jacquesm ad           1218 Oct 26 15:16 makefile
+-rw-r--r--   1 jacquesm ad           2546 Nov 16 12:53 testWRFReadXYZ.F90
+-rw-r--r--   1 jacquesm ad           9555 Nov 27 11:25 testWRFReadfoo2.F90
+-rw-r--r--   1 jacquesm ad           7354 Nov 27 11:23 testWRFReadjfm.F90
+-rw-r--r--   1 jacquesm ad           2994 Nov 16 12:53 testWRFWriteXYZ.F90
+-rw-r--r--   1 jacquesm ad          16391 Nov 27 11:25 testWRFWritefoo2.F90
+-rw-r--r--   1 jacquesm ad           8896 Nov 27 11:25 testWRFWritejfm.F90
+-rw-r--r--   1 jacquesm ad            462 Oct 27 16:44 transpose.code
+-rw-r--r--   1 jacquesm ad          78533 Nov 27 11:22 wrf_io.F90
+-rw-r--r--   1 jacquesm ad           2715 Nov 21 12:06 wrf_status_codes.h
+
+The test* routines are test programs and one pair must be copied to
+testWRFWrite.F90 and testWRFRead.F90.  The other files comprise the WRF
+NetCDF I/O library.  In the makefile, you may need to redefine the path to
+NetCDF.  To run the test files, do:
+
+     make
+     testWRFWrite
+     testWRFRead
+
+testWRFWrite will create a NetCDF file called foo.nc and testWRFRead will
+read it.  Status codes and some values will be printed.
+
+
diff --git a/wrfv2_fire/external/io_netcdf/WRFIO.doc b/wrfv2_fire/external/io_netcdf/WRFIO.doc
new file mode 100644
index 00000000..9cd39d14
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/WRFIO.doc
@@ -0,0 +1,6 @@
+Documentation for WRF I/O is at
+
+   http://www.wrf-model.org/documentation_main.html
+ 
+the first link under REFERENCES.
+
diff --git a/wrfv2_fire/external/io_netcdf/diffwrf.F90 b/wrfv2_fire/external/io_netcdf/diffwrf.F90
new file mode 100644
index 00000000..d244542b
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/diffwrf.F90
@@ -0,0 +1,456 @@
+module read_util_module
+
+#ifdef crayx1
+#define iargc ipxfargc
+#endif
+
+contains
+
+#ifdef crayx1
+   subroutine getarg(i, harg)
+     implicit none
+     character(len=*) :: harg
+     integer :: ierr, ilen, i
+
+     call pxfgetarg(i, harg, ilen, ierr)
+     return
+   end subroutine getarg
+#endif
+
+   subroutine arguments(v2file, lmore)
+     implicit none
+     character(len=*) :: v2file
+     character(len=120) :: harg
+     logical :: lmore
+   
+     integer :: ierr, i, numarg
+     integer, external :: iargc
+   
+     numarg = iargc()
+   
+     i = 1
+     lmore = .false.
+   
+     do while ( i < numarg) 
+        call getarg(i, harg)
+        print*, 'harg = ', trim(harg)
+   
+        if (harg == "-v") then
+           i = i + 1
+           lmore = .true.
+        elseif (harg == "-h") then
+           call help
+        endif
+   
+     enddo
+   
+     call getarg(i,harg)
+     v2file = harg
+   end subroutine arguments
+   
+   subroutine help
+     implicit none
+     character(len=120) :: cmd
+     call getarg(0, cmd)
+   
+     write(*,'(/,"Usage: ", A, " [-v] v2file ")') trim(cmd)
+     write(*,'(8x, "-v     : Print extra info")')
+     write(*,'(8x, "v3file : MM5v3 file name to read.")')
+     write(*,'(8x, "-h     : print this help message and exit.",/)')
+     stop
+   end subroutine help
+end module read_util_module
+
+
+
+ program readv3
+  use wrf_data
+  use read_util_module
+  implicit none
+#include "wrf_status_codes.h"
+#include "netcdf.inc"
+  character(len=120) :: flnm
+  character(len=120) :: flnm2
+  character(len=120) :: arg3
+  character(len=19) :: DateStr
+  character(len=19) :: DateStr2
+  character(len=31) :: VarName
+  character(len=31) :: VarName2
+  integer dh1, dh2
+
+  integer :: flag, flag2
+  integer :: iunit, iunit2
+
+  integer :: i,j,k
+  integer :: levlim
+  integer :: cross
+  integer :: ndim, ndim2
+  integer :: WrfType, WrfType2
+  real :: time, time2
+  real*8 :: a, b
+  real*8 :: sumE, sum1, sum2, diff1, diff2, serr, perr, rmse, rms1, rms2, tmp1, tmp2
+  integer digits,d1, d2
+  integer, dimension(4) :: start_index, end_index, start_index2, end_index2
+  integer , Dimension(3) :: MemS,MemE,PatS,PatE
+  character (len= 4) :: staggering,   staggering2
+  character (len= 3) :: ordering,     ordering2, ord
+  character (len=24) :: start_date,   start_date2
+  character (len=24) :: current_date, current_date2
+  character (len=31) :: name,         name2,  tmpname
+  character (len=25) :: units,        units2
+  character (len=46) :: description,  description2
+
+  character (len=80), dimension(3)  ::  dimnames
+  character (len=80) :: SysDepInfo
+
+  integer :: l, n
+  integer :: ikdiffs, ifdiffs
+
+  real, allocatable, dimension(:,:,:,:) :: data,data2
+
+  integer :: ierr, ierr2, ier, ier2, Status, Status_next_time, Status_next_time2, Status_next_var, Status_next_var_2
+
+  logical :: newtime = .TRUE.
+  logical :: justplot, efound
+
+  integer, external :: iargc
+  logical, external :: iveceq
+
+  levlim = -1
+
+  call ext_ncd_ioinit(SysDepInfo,Status)
+  call set_wrf_debug_level ( 1 )
+
+
+  Justplot = .false.
+! get arguments
+  if ( iargc() .ge. 2 ) then
+    call getarg(1,flnm)
+    call getarg(2,flnm2)
+    ierr = 0
+    call ext_ncd_open_for_read( trim(flnm), 0, 0, "", dh1, Status)
+    if ( Status /= 0 ) then 
+      print*,'error opening ',flnm, ' Status = ', Status ; stop 
+    endif
+    call ext_ncd_open_for_read( trim(flnm2), 0, 0, "", dh2, Status)
+    if ( Status /= 0 ) go to 923
+    goto 924
+923    continue
+
+! bounce here if second name is not openable -- this would mean that
+! it is a field name instead.
+
+    print*,'could not open ',flnm2
+    name = flnm2
+    Justplot = .true.
+924    continue
+  if ( iargc() .eq. 3 ) then
+    call getarg(3,arg3)
+    read(arg3,*)levlim
+    print*,'LEVLIM = ',LEVLIM
+  endif
+  else
+     print*,'Usage: command file1 file2'
+     stop
+  endif
+
+print*,'Just plot ',Justplot
+
+if ( Justplot ) then
+  print*, 'flnm = ', trim(flnm)
+
+  call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+
+  DO WHILE ( Status_next_time .eq. 0 )
+    write(*,*)'Next Time ',TRIM(Datestr)
+    call ext_ncd_get_next_var (dh1, VarName, Status_next_var)
+    DO WHILE ( Status_next_var .eq. 0 )
+!    write(*,*)'Next Var |',TRIM(VarName),'|'
+
+      start_index = 1
+      end_index = 1
+      call ext_ncd_get_var_info (dh1,VarName,ndim,ordering,staggering,start_index,end_index, WrfType, ierr )
+      if(WrfType /= WRF_REAL .AND. WrfType /= WRF_DOUBLE) then 
+        call ext_ncd_get_next_var (dh1, VarName, Status_next_var) 
+        cycle 
+      endif 
+      write(*,'(A9,1x,I1,3(1x,I5),1x,A,1x,A)')&
+               VarName, ndim, end_index(1), end_index(2), end_index(3), &
+               trim(ordering), trim(DateStr)
+
+      if ( VarName .eq. name ) then
+        write(*,*)'Writing fort.88 file for ', trim(name)
+
+        allocate(data(end_index(1), end_index(2), end_index(3), 1))
+
+        if ( ndim .eq. 3 ) then
+          ord = 'XYZ'
+        else if ( ndim .eq. 2 ) then
+          ord = 'XY'
+        else if ( ndim .eq. 1 ) then
+          ord = 'Z'
+        else if ( ndim .eq. 0 ) then
+          ord = '0'
+        endif
+
+        call ext_ncd_read_field(dh1,DateStr,TRIM(name),data,WRF_REAL,0,0,0,ord, &
+                            staggering, dimnames ,                      &
+                            start_index,end_index,                      & !dom
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+
+        if ( ierr/=0 ) then
+             write(*,*)'error reading data record'
+             write(*,*)'  ndim = ', ndim
+             write(*,*)'  end_index(1) ',end_index(1)
+             write(*,*)'  end_index(2) ',end_index(2)
+             write(*,*)'  end_index(3) ',end_index(3)
+        endif
+
+
+#if 0
+! uncomment this to have the code give i-slices 
+        do i = 1, end_index(1)
+          if ( levlim .eq. -1 .or. i .eq. levlim ) then
+            write(88,*)end_index(2),end_index(3),' ',trim(name),' ',k,' time ',TRIM(Datestr)
+            do k = start_index(3), end_index(3)
+            do j = 1, end_index(2)
+                write(88,*) data(i,j,k,1)
+              enddo
+            enddo
+          endif
+        enddo
+#else
+! give k-slices 
+        do k = start_index(3), end_index(3)
+          if ( levlim .eq. -1 .or. k .eq. levlim ) then
+            write(88,*)end_index(1),end_index(2),' ',trim(name),' ',k,' time ',TRIM(Datestr)
+            do j = 1, end_index(2)
+              do i = 1, end_index(1)
+                write(88,*) data(i,j,k,1)
+              enddo
+            enddo
+          endif
+        enddo
+#endif
+
+        deallocate(data)
+      endif
+      call ext_ncd_get_next_var (dh1, VarName, Status_next_var)
+    enddo
+    call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+  enddo
+else
+  print*,'Diffing ',trim(flnm),' ',trim(flnm2)
+
+  call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+  call ext_ncd_get_next_time(dh2, DateStr2, Status_next_time2)
+
+  IF ( DateStr .NE. DateStr2 ) THEN
+    print*,'They differ big time.  Dates do not match'
+    print*,'   ',flnm,' ',DateStr
+    print*,'   ',flnm2,' ',DateStr2
+    Status_next_time = 1
+  ENDIF
+
+  DO WHILE ( Status_next_time .eq. 0 .AND. Status_next_time2 .eq. 0 )
+    write(*,*)'Next Time ',TRIM(Datestr)
+    print 76
+    call ext_ncd_get_next_var (dh1, VarName, Status_next_var)
+    DO WHILE ( Status_next_var .eq. 0 )
+!    write(*,*)'Next Var |',TRIM(VarName),'|'
+
+      start_index = 1
+      end_index = 1
+      start_index2 = 1
+      end_index2 = 1
+
+      call ext_ncd_get_var_info (dh1,VarName,ndim,ordering,staggering,start_index,end_index, WrfType, ierr )
+      call ext_ncd_get_var_info (dh2,VarName,ndim2,ordering2,staggering2,start_index2,end_index2, WrfType2, ierr )
+      IF ( ierr /= 0 ) THEN
+        write(*,*)'Big difference: ',VarName,' not found in ',flnm2
+        GOTO 1234
+      ENDIF
+      IF ( ndim /= ndim2 ) THEN
+        write(*,*)'Big difference: Number of dimensions for ',Varname,' differs in ',flnm2,'(',ndim,') /= (',ndim2
+        GOTO 1234
+      ENDIF
+      IF ( WrfType /= WrfType2 ) THEN
+        write(*,*)'Big difference: The types do not match'
+        GOTO 1234
+      ENDIF
+      if( WrfType == WRF_REAL) then
+        DO i = 1, ndim
+          IF ( end_index(i) /= end_index2(i) ) THEN
+            write(*,*)'Big difference: dim ',i,' lengths differ for ',Varname,' differ in ',flnm2
+            GOTO 1234
+          ENDIF
+        ENDDO
+        DO i = ndim+1,3
+          start_index(i) = 1
+          end_index(i) = 1
+          start_index2(i) = 1
+          end_index2(i) = 1
+        ENDDO
+
+!        write(*,'(A9,1x,I1,3(1x,I3),1x,A,1x,A)')&
+!                 VarName, ndim, end_index(1), end_index(2), end_index(3), &
+!                 trim(ordering), trim(DateStr)
+
+        allocate(data (end_index(1), end_index(2), end_index(3), 1))
+        allocate(data2(end_index(1), end_index(2), end_index(3), 1))
+
+        if ( ndim .eq. 3 ) then
+          ord = 'XYZ'
+        else if ( ndim .eq. 2 ) then
+          ord = 'XY'
+        else if ( ndim .eq. 1 ) then
+          ord = 'Z'
+        else if ( ndim .eq. 0 ) then
+          ord = '0'
+        endif
+
+        call ext_ncd_read_field(dh1,DateStr,TRIM(VarName),data,WRF_REAL,0,0,0,ord,&
+                            staggering, dimnames ,                      &
+                            start_index,end_index,                      & !dom 
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+
+        IF ( ierr /= 0 ) THEN
+          write(*,*)'Error reading ',Varname,' from ',flnm
+          write(*,*)'  ndim = ', ndim
+          write(*,*)'  end_index(1) ',end_index(1)
+          write(*,*)'  end_index(2) ',end_index(2)
+          write(*,*)'  end_index(3) ',end_index(3)
+        ENDIF
+        call ext_ncd_read_field(dh2,DateStr,TRIM(VarName),data2,WRF_REAL,0,0,0,ord,&
+                            staggering, dimnames ,                      &
+                            start_index,end_index,                      & !dom 
+                            start_index,end_index,                      & !mem
+                            start_index,end_index,                      & !pat
+                            ierr)
+        IF ( ierr /= 0 ) THEN
+          write(*,*)'Error reading ',Varname,' from ',flnm2
+          write(*,*)'  ndim = ', ndim
+          write(*,*)'  end_index(1) ',end_index(1)
+          write(*,*)'  end_index(2) ',end_index(2)
+          write(*,*)'  end_index(3) ',end_index(3)
+        ENDIF
+
+        IFDIFFS=0
+        sumE = 0.0
+        sum1 = 0.0
+        sum2 = 0.0
+        diff1 = 0.0
+        diff2 = 0.0
+        n = 0 
+        DO K = 1,end_index(3)-start_index(3)+1
+         IF (LEVLIM.EQ.-1.OR.K.EQ.LEVLIM.OR.NDIM.eq.2) THEN
+          cross = 0 
+          IKDIFFS = 0
+          do i = 1, end_index(1)-cross
+            do j = 1, end_index(2)-cross
+              a = data(I,J,K,1)
+              b = data2(I,J,K,1)
+              ! borrowed from  Thomas Oppe's comp program
+              sumE = sumE + ( a - b ) * ( a - b )
+              sum1 = sum1 + a * a
+              sum2 = sum2 + b * b
+              diff1 = max ( diff1 , abs ( a - b ) )
+              diff2 = max ( diff2 , abs ( b ) )
+              n = n + 1
+              IF (a .ne. b) then
+                IKDIFFS = IKDIFFS + 1
+                IFDIFFS = IFDIFFS + 1
+              ENDIF
+            ENDDO
+          ENDDO
+         ENDIF
+        enddo
+        rmsE = sqrt ( sumE / dble( n ) )
+        rms1 = sqrt ( sum1 / dble( n ) )
+        rms2 = sqrt ( sum2 / dble( n ) )
+        serr = 0.0
+        IF ( sum2 .GT. 0.0d0 ) THEN
+          serr = sqrt ( sumE / sum2 )
+        ELSE
+          IF ( sumE .GT. 0.0d0 ) serr = 1.0
+        ENDIF
+        perr = 0.0
+        IF ( diff2 .GT. 0.0d0 ) THEN
+          perr = diff1/diff2
+        ELSE
+          IF ( diff1 .GT. 0.0d0 ) perr = 1.0
+        ENDIF
+
+        IF ( rms1 - rms2 .EQ. 0.0d0 ) THEN
+          digits = 15
+        ELSE
+          IF ( rms2 .NE. 0 ) THEN
+            tmp1 = 1.0d0/( ( abs( rms1 - rms2 ) ) / rms2 )
+            IF ( tmp1 .NE. 0 ) THEN
+              digits = log10(tmp1)
+            ENDIF
+          ENDIF
+        ENDIF
+
+        IF (IFDIFFS .NE. 0 ) THEN
+           ! create the fort.88 and fort.98 files because regression scripts will
+           ! look for these to see if there were differences.
+           write(88,*)trim(varname)
+           write(98,*)trim(varname)
+           PRINT 77,trim(varname), IFDIFFS, ndim, rms1, rms2, digits, rmsE, perr
+ 76 FORMAT (5x,'Field ',2x,'Ndifs',4x,'Dims ',6x,'RMS (1)',12x,'RMS (2)',5x,'DIGITS',4x,'RMSE',5x,'pntwise max')
+ 77 FORMAT ( A10,1x,I9,2x,I3,1x,e18.10,1x,e18.10,1x,i3,1x,e12.4,1x,e12.4 )
+        ENDIF
+        deallocate(data)
+        deallocate(data2)
+
+      endif
+ 1234 CONTINUE
+      call ext_ncd_get_next_var (dh1, VarName, Status_next_var)
+    enddo
+    call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+    call ext_ncd_get_next_time(dh2, DateStr2, Status_next_time2)
+    IF ( DateStr .NE. DateStr2 ) THEN
+      print*,'They differ big time.  Dates do not match'
+      print*,'They differ big time.  Dates do not match'
+      print*,'   ',flnm,' ',DateStr
+      print*,'   ',flnm2,' ',DateStr2
+      Status_next_time = 1
+    ENDIF
+  enddo
+
+endif
+
+end program readv3
+
+logical function iveceq( a, b, n )
+  implicit none
+  integer n
+  integer a(n), b(n)
+  integer i
+  iveceq = .true.
+  do i = 1,n
+    if ( a(i) .ne. b(i) ) iveceq = .false.
+  enddo
+  return
+end function iveceq
+
+! stubs for routines called by module_wrf_error (used by netcdf implementation of IO api)
+SUBROUTINE wrf_abort
+  STOP
+END SUBROUTINE wrf_abort
+
+SUBROUTINE get_current_time_string( time_str )
+  CHARACTER(LEN=*), INTENT(OUT) :: time_str
+  time_str = ''
+END SUBROUTINE get_current_time_string
+
+SUBROUTINE get_current_grid_name( grid_str )
+  CHARACTER(LEN=*), INTENT(OUT) :: grid_str
+  grid_str = ''
+END SUBROUTINE get_current_grid_name
+
diff --git a/wrfv2_fire/external/io_netcdf/ext_ncd_get_dom_ti.code b/wrfv2_fire/external/io_netcdf/ext_ncd_get_dom_ti.code
new file mode 100644
index 00000000..fe365f15
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/ext_ncd_get_dom_ti.code
@@ -0,0 +1,157 @@
+!*------------------------------------------------------------------------------
+!*  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/wrfv2_fire/external/io_netcdf/ext_ncd_get_var_td.code b/wrfv2_fire/external/io_netcdf/ext_ncd_get_var_td.code
new file mode 100644
index 00000000..bd28dc38
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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/wrfv2_fire/external/io_netcdf/ext_ncd_get_var_ti.code b/wrfv2_fire/external/io_netcdf/ext_ncd_get_var_ti.code
new file mode 100644
index 00000000..47a161ba
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code b/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code
new file mode 100644
index 00000000..6b98425c
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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) 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/wrfv2_fire/external/io_netcdf/ext_ncd_put_var_td.code b/wrfv2_fire/external/io_netcdf/ext_ncd_put_var_td.code
new file mode 100644
index 00000000..750e1ecd
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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/wrfv2_fire/external/io_netcdf/ext_ncd_put_var_ti.code b/wrfv2_fire/external/io_netcdf/ext_ncd_put_var_ti.code
new file mode 100644
index 00000000..05bfc64c
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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/wrfv2_fire/external/io_netcdf/field_routines.F90 b/wrfv2_fire/external/io_netcdf/field_routines.F90
new file mode 100644
index 00000000..cd9bcfa7
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/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/wrfv2_fire/external/io_netcdf/makefile b/wrfv2_fire/external/io_netcdf/makefile
new file mode 100644
index 00000000..18fdb671
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/makefile
@@ -0,0 +1,47 @@
+#makefile to build a wrf_io with netCDF
+
+OBJSL   = wrf_io.o field_routines.o module_wrfsi_static.o
+OBJS    = $(OBJSL)
+CODE    = ext_ncd_get_dom_ti.code ext_ncd_get_var_td.code ext_ncd_get_var_ti.code ext_ncd_put_dom_ti.code ext_ncd_put_var_td.code ext_ncd_put_var_ti.code transpose.code 
+FFLAGS  =  $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share
+LIBS    = -L$(NETCDFPATH)/lib -lnetcdf
+CPP1    = $(CPP) -C -P $(TRADFLAG)
+M4      = m4 -Uinclude -Uindex -Ulen
+AR      = ar
+
+.SUFFIXES:      .F90 .f .o .code
+
+all : libwrfio_nf.a 
+
+libwrfio_nf.a:		$(OBJS) $(CODE)
+			/bin/rm -f libwrfio_nf.a
+			$(AR) cr libwrfio_nf.a $(OBJSL)
+			$(RANLIB) libwrfio_nf.a
+
+wrf_io.o:               wrf_io.F90 $(CODE)
+			$(CPP1) -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f
+			$(FC) $(FFLAGS) -c wrf_io.f
+
+module_wrfsi_static.o:  module_wrfsi_static.F90
+			$(CPP1) -I../ioapi_share module_wrfsi_static.F90 > module_wrfsi_static.f
+			$(FC) $(FFLAGS) -c module_wrfsi_static.f
+
+diffwrf:                diffwrf.F90
+			$(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share diffwrf.F90 > diffwrf.f
+			$(FC) -c $(FFLAGS) diffwrf.f
+			@if [ \( -f ../../frame/wrf_debug.o \) -a \( -f ../../frame/module_wrf_error.o \) -a \( -f $(ESMF_MOD_DEPENDENCE) \) ] ; then \
+			echo "diffwrf io_netcdf is being built now. "; \
+			  $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) $(LIBS) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o $(ESMF_IO_LIB_EXT) ;\
+                        else \
+			  echo "***************************************************************************** " ; \
+			  echo "*** Rerun compile to make diffwrf in external/io_netcdf directory         *** " ; \
+			  echo "***************************************************************************** " ; \
+                        fi
+
+field_routines.o:	field_routines.F90
+			$(CPP1) -I../ioapi_share field_routines.F90 > field_routines.f
+			$(FC) $(FFLAGS) -c field_routines.f
+
+superclean:
+			/bin/rm -f *.f *.o testWRFWrite testWRFRead \
+			*.mod libwrfio_nf.a diffwrf
diff --git a/wrfv2_fire/external/io_netcdf/module_wrfsi_static.F90 b/wrfv2_fire/external/io_netcdf/module_wrfsi_static.F90
new file mode 100644
index 00000000..7660e67f
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/module_wrfsi_static.F90
@@ -0,0 +1,96 @@
+MODULE wrfsi_static
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+CONTAINS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE open_wrfsi_static(dataroot,cdfid)
+  
+    IMPLICIT NONE
+    INCLUDE "netcdf.inc"
+    CHARACTER(LEN=*), INTENT(IN)   :: dataroot
+    INTEGER, INTENT(OUT)           :: cdfid
+    CHARACTER(LEN=255)            :: staticfile
+    LOGICAL                       :: static_exists
+    INTEGER                       :: status
+
+    staticfile = TRIM(dataroot) // '/static/static.wrfsi'
+    INQUIRE(FILE=staticfile, EXIST=static_exists)
+    IF (static_exists) THEN
+      status = NF_OPEN(TRIM(staticfile),NF_NOWRITE,cdfid)
+      IF (status .NE. NF_NOERR) THEN
+        PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status
+        STOP 'open_wrfsi_static'
+      END IF 
+
+    ELSE
+
+!mp
+!	search for rotlat version??
+!      PRINT '(A)', 'Static file not found ', staticfile
+!      PRINT '(A)', 'Look for NMM version'
+      staticfile = TRIM(dataroot) // '/static/static.wrfsi.rotlat'
+      INQUIRE(FILE=staticfile, EXIST=static_exists)
+		    IF (static_exists) THEN
+		 status = NF_OPEN(TRIM(staticfile),NF_NOWRITE,cdfid)
+      IF (status .NE. NF_NOERR) THEN
+        PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status
+        STOP 'open_wrfsi_static'
+      END IF
+		    ELSE
+
+      PRINT '(A)', 'rotlat Static file not found, either: ', staticfile
+      STOP 'open_wrfsi_static'
+  		    ENDIF
+
+	ENDIF
+
+    RETURN
+  END SUBROUTINE open_wrfsi_static      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE get_wrfsi_static_dims(dataroot, nx, ny)
+  
+    ! Subroutine to return the horizontal dimensions of WRF static file
+    ! contained in the input dataroot
+
+    IMPLICIT NONE
+    INCLUDE "netcdf.inc"
+    CHARACTER(LEN=*), INTENT(IN)  :: dataroot
+    INTEGER         , INTENT(OUT) :: nx
+    INTEGER         , INTENT(OUT) :: ny
+
+    INTEGER                       :: cdfid,vid, status
+
+    CALL open_wrfsi_static(dataroot,cdfid)
+    status = NF_INQ_DIMID(cdfid, 'x', vid)
+    status = NF_INQ_DIMLEN(cdfid, vid, nx)
+    status = NF_INQ_DIMID(cdfid, 'y', vid)
+    status = NF_INQ_DIMLEN(cdfid, vid, ny) 
+      PRINT '(A,I5,A,I5)', 'WRF X-dimension = ',nx, &
+        ' WRF Y-dimension = ',ny  
+    status = NF_CLOSE(cdfid)  
+    RETURN
+  END SUBROUTINE get_wrfsi_static_dims     
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE get_wrfsi_static_2d(dataroot, varname, data)
+
+    IMPLICIT NONE
+    INCLUDE "netcdf.inc"
+    ! Gets any 2D variable from the static file
+    CHARACTER(LEN=*), INTENT(IN)  :: dataroot
+    CHARACTER(LEN=*), INTENT(IN)  :: varname
+    REAL, INTENT(OUT)             :: data(:,:)
+ 
+    INTEGER                             :: cdfid, vid, status
+   
+    CALL open_wrfsi_static(dataroot,cdfid)
+    status = NF_INQ_VARID(cdfid,varname,vid)
+    status = NF_GET_VAR_REAL(cdfid,vid,data)
+    IF (status .NE. NF_NOERR) THEN
+      PRINT '(A)', 'Problem getting 2D data.'
+    ENDIF 
+    status = NF_CLOSE(cdfid) 
+    RETURN
+  END SUBROUTINE get_wrfsi_static_2d    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  
+END MODULE wrfsi_static
diff --git a/wrfv2_fire/external/io_netcdf/testWRFRead.F90 b/wrfv2_fire/external/io_netcdf/testWRFRead.F90
new file mode 100644
index 00000000..35b67602
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/testWRFRead.F90
@@ -0,0 +1,138 @@
+program testread_john
+  use wrf_data
+  implicit none
+#include "wrf_status_codes.h"
+#include 
+  character (80) FileName
+  integer Comm
+  character (80) SysDepInfo
+  integer     :: DataHandle
+  integer Status
+  integer NCID
+  real data(200)
+  integer idata(200)
+  real*8 ddata(200)
+  logical ldata(200)
+  character (80) cdata
+  integer OutCount
+  integer i,j,k
+
+  integer, parameter ::    pad = 3
+  integer, parameter ::    jds=1       , jde=6      , &
+                           ids=1       , ide=9      , &
+                           kds=1       , kde=5
+  integer, parameter ::    jms=jds-pad , jme=jde+pad , &
+                           ims=ids-pad , ime=ide+pad , &
+                           kms=kds     , kme=kde
+  integer, parameter ::    jps=jds     , jpe=jde    , &
+                           ips=ids     , ipe=ide    , &
+                           kps=kds     , kpe=kde
+
+  real u( ims:ime , kms:kme , jms:jme )
+  real v( ims:ime , kms:kme , jms:jme )
+  real rho( ims:ime , kms:kme , jms:jme )
+  real u2( ims:ime , jms:jme )
+  real u1( ims:ime )
+
+  integer int( ims:ime , kms:kme , jms:jme )
+  real*8  r8 ( ims:ime , kms:kme , jms:jme )
+
+  integer Dom
+  character*3 MemOrd
+  integer , Dimension(3) :: DomS,DomE,MemS,MemE,PatS,PatE
+  integer , Dimension(2) :: Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E
+  integer                   Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E
+  character (19) Time, DateStr
+  character (31) VarName
+  character (19) Date
+
+  print *, 'Testing wrf read'
+  Date = '2000-09-18_16:42:01'
+  call ext_init(Status)
+  print *,'After call ext_init, Status =',Status
+  FileName = 'foo.nc'
+  Comm = 1
+  SysDepInfo = 'sys info'
+  call ext_open_for_read( FileName, Comm, SysDepInfo, DataHandle, Status)
+  print *, 'Status = ',Status,DataHandle
+
+  MemOrd = "XZY"
+
+  DomS(1) = ids
+  DomE(1) = ide
+  DomS(2) = kds
+  DomE(2) = kde
+  DomS(3) = jds
+  DomE(3) = jde
+
+  PatS(1) = ips
+  PatE(1) = ipe
+  PatS(2) = kps
+  PatE(2) = kpe
+  PatS(3) = jps
+  PatE(3) = jpe
+
+  MemS(1) = ims
+  MemE(1) = ime
+  MemS(2) = kms
+  MemE(2) = kme
+  MemS(3) = jms
+  MemE(3) = jme
+
+  Dom2S(1) = ids
+  Dom2S(2) = jds
+  Dom2E(1) = ide
+  Dom2E(2) = jde
+  Mem2S(1) = ims
+  Mem2S(2) = jms
+  Mem2E(1) = ime
+  Mem2E(2) = jme
+  Pat2S(1) = ips
+  Pat2S(2) = jps
+  Pat2E(1) = ipe
+  Pat2E(2) = jpe
+
+  Dom1S = ids
+  Dom1E = ide
+  Mem1S = ims
+  Mem1E = ime
+  Pat1S = ips
+  Pat1E = ipe
+
+  call ext_get_next_time(DataHandle, Time, Status)
+  print *, Time, Status
+
+  call ext_read_field(DataHandle,Time,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' u(2,3,4) ', u(2,3,4) 
+  call ext_read_field(DataHandle,Time,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' v(4,3,2) ', v(4,3,2)
+  call ext_read_field(DataHandle,Time,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' rho(3,4,5) ' , rho(3,4,5)
+  call ext_read_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status)
+  print *,'ext_read_field Status = ',Status, ' u2(6,5) ', u2(6,5) 
+  call ext_read_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' u(2,3,4) ', u(2,3,4) 
+  call ext_read_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status)
+  print *,'ext_read_field Status = ',Status, ' u1(9) ', u1(9)
+
+  call ext_read_field(DataHandle,Time,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' int(8,5,6) ', int(8,5,6) 
+  call ext_read_field(DataHandle,Time,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'ext_read_field Status = ',Status, ' r8(7,4,5) ', r8(7,4,5) 
+
+  call ext_get_next_time(DataHandle, Time, Status)
+  print *, Time, Status
+
+  call ext_read_field(DataHandle,Time,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'> ext_read_field Status = ',Status, ' u(3,3,3) ' ,u(3,3,3)
+  call ext_read_field(DataHandle,Time,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'> ext_read_field Status = ',Status, ' v(4,4,4) ' ,v(4,4,4)
+  call ext_read_field(DataHandle,Time,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'> ext_read_field Status = ',Status, ' rho(3,4,5) ' ,rho(3,4,5)
+
+  call ext_close( DataHandle, Status)
+  print *, 'After ext_close, Status = ',Status
+  call ext_exit(Status)
+  print *,'End of test program',Status
+  stop
+  end program testread_john
diff --git a/wrfv2_fire/external/io_netcdf/testWRFWrite.F90 b/wrfv2_fire/external/io_netcdf/testWRFWrite.F90
new file mode 100644
index 00000000..33f66528
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/testWRFWrite.F90
@@ -0,0 +1,184 @@
+program testwrite_john
+  use wrf_data
+  implicit none
+#include "wrf_status_codes.h"
+#include 
+  character (80) FileName
+  integer Comm
+  character (80) SysDepInfo
+  integer     :: DataHandle
+  integer Status
+  integer NCID
+  real data(200)
+  integer idata(200)
+  real*8 ddata(200)
+  logical ldata(200)
+  character (80) cdata
+  integer OutCount
+  integer i,j,k
+
+  integer, parameter ::    pad = 3  
+  integer, parameter ::    jds=1       , jde=6      , &
+                           ids=1       , ide=9      , &
+                           kds=1       , kde=5         
+  integer, parameter ::    jms=jds-pad , jme=jde+pad , &
+                           ims=ids-pad , ime=ide+pad , &
+                           kms=kds     , kme=kde       
+  integer, parameter ::    jps=jds     , jpe=jde    , &
+                           ips=ids     , ipe=ide    , &
+                           kps=kds     , kpe=kde       
+
+  real u( ims:ime , kms:kme , jms:jme )
+  real v( ims:ime , kms:kme , jms:jme )
+  real rho( ims:ime , kms:kme , jms:jme )
+  real u2( ims:ime , jms:jme )
+  real u1( ims:ime )
+
+  integer int( ims:ime , kms:kme , jms:jme )
+  real*8  r8 ( ims:ime , kms:kme , jms:jme )
+
+  integer Dom
+  character*3 MemOrd
+  character (19) Date
+  character (19) Date2
+  integer , Dimension(3) :: DomS,DomE,MemS,MemE,PatS,PatE
+  integer , Dimension(2) :: Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E
+  integer , Dimension(1) :: Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E
+  print *, 'Testing wrf write'
+  print *, ims,ime , kms,kme , jms,jme
+  Date = '2000-09-18_16:42:01'
+  Date2 = '2000-09-18_16:52:01'
+  call ext_init(Status)
+  print *,'After call ext_init, Status =',Status
+  FileName = 'foo.nc'
+  Comm = 1
+  SysDepInfo = 'sys info'
+
+print*,'!!!!!!!!!!!!!!!!!!!!!!! ext_open_for_write_begin'
+
+  call ext_open_for_write_begin( FileName, Comm, SysDepInfo, DataHandle, Status)
+  print *, ' ext_open_for_write_begin Status = ',Status,DataHandle
+
+  MemOrd = "XZY"
+
+  DomS(1) = ids
+  DomE(1) = ide
+  DomS(2) = kds
+  DomE(2) = kde
+  DomS(3) = jds
+  DomE(3) = jde
+
+  PatS(1) = ips
+  PatE(1) = ipe
+  PatS(2) = kps
+  PatE(2) = kpe
+  PatS(3) = jps
+  PatE(3) = jpe
+
+  MemS(1) = ims
+  MemE(1) = ime
+  MemS(2) = kms
+  MemE(2) = kme
+  MemS(3) = jms
+  MemE(3) = jme
+
+  Dom2S(1) = ids
+  Dom2S(2) = jds
+  Dom2E(1) = ide
+  Dom2E(2) = jde
+  Mem2S(1) = ims
+  Mem2S(2) = jms
+  Mem2E(1) = ime
+  Mem2E(2) = jme
+  Pat2S(1) = ips
+  Pat2S(2) = jps
+  Pat2E(1) = ipe
+  Pat2E(2) = jpe
+
+  Dom1S = ids
+  Dom1E = ide
+  Mem1S = ims
+  Mem1E = ime
+  Pat1S = ips
+  Pat1E = ipe
+
+  call ext_write_field(DataHandle,Date,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+
+  call ext_open_for_write_commit(DataHandle, Status)
+  print *, '             ext_open_for_write_commit Status = ', Status,DataHandle
+
+  do j=jds,jde
+    do k=kds,kde
+      do i=ids,ide
+        u  (i,k,j) = 100*i+j+10*k
+        v  (i,k,j) = 100*i+j+10*k
+        rho(i,k,j) = 100*i+j+10*k
+        int(i,k,j) = 100*i+j+10*k
+        r8 (i,k,j) = 100*i+j+10*k
+      enddo
+    enddo
+  enddo
+  do j=jds,jde
+    do i=ids,ide
+      u2(i,j) = 10*i+j
+    enddo
+  enddo
+  do i=ids,ide
+    u1(i) = i
+  enddo
+
+  print *,'testWRFWrite u  (2,3,4) = ',u(2,3,4)
+  print *,'testWRFWrite v  (4,3,2) = ',v(4,3,2)
+  print *,'testWRFWrite rho(3,4,5) = ',rho(3,4,5)
+  print *,'testWRFWrite u2 (6,5)   = ',u2(6,5)
+  print *,'testWRFWrite u1 (9)     = ',u1(9)
+  print *,'testWRFWrite int(8,5,6) = ',int(8,5,6)
+  print *,'testWRFWrite r8 (7,4,5) = ',r8(7,4,5)
+  call ext_write_field(DataHandle,Date,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              first write: ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'             dry run : ext_write_field Status = ',Status
+
+  print *,'2nd : testWRFWrite u(3,3,3) = ',u(3,3,3)
+  print *,'2nd : testWRFWrite v(4,4,4) = ',v(4,4,4)
+  print *,'2nd : testWRFWrite rho(3,4,5) = ',rho(3,4,5)
+  call ext_write_field(DataHandle,Date2,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              2nd write : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date2,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              2nd write : ext_write_field Status = ',Status
+  call ext_write_field(DataHandle,Date2,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status)
+  print *,'              2nd write : ext_write_field Status = ',Status
+
+  call ext_close( DataHandle, Status)
+  print *, '             After ext_close, Status = ',Status
+  call ext_exit(Status)
+  print *,'              End of test program',Status
+  stop
+  end program testwrite_john
diff --git a/wrfv2_fire/external/io_netcdf/transpose.code b/wrfv2_fire/external/io_netcdf/transpose.code
new file mode 100644
index 00000000..b15487e5
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/transpose.code
@@ -0,0 +1,36 @@
+  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
+  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
+else
+!dir$ concurrent
+  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
+endif
+
+  return
diff --git a/wrfv2_fire/external/io_netcdf/vort.F90 b/wrfv2_fire/external/io_netcdf/vort.F90
new file mode 100644
index 00000000..7d3a0144
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/vort.F90
@@ -0,0 +1,265 @@
+! on linux, compile wrf then compile as:
+! pgf90 -Mfree -I ../../main -I ../../inc -I /usr/local/netcdf-pgi/include vort.F90 libwrfio_nf.a /usr/local/netcdf-pgi/lib/libnetcdf.a ../../main/libwrflib.a
+! on AIX, compile wrf then compile as:
+! /lib/cpp -C -P vort.F90 > vort.f
+! mpxlf -qfree=f90 -I ../../share -I ../../main -I ../../inc -I /usr/local/netcdf/include vort.f libwrfio_nf.a /usr/local/netcdf/lib/libnetcdf.a ../../main/libwrflib.a
+
+module read_util_module
+
+#ifdef crayx1
+#define iargc ipxfargc
+#endif
+
+contains
+
+#ifdef crayx1
+   subroutine getarg(i, harg)
+     implicit none
+     character(len=*) :: harg
+     integer :: ierr, ilen, i
+
+     call pxfgetarg(i, harg, ilen, ierr)
+     return
+   end subroutine getarg
+#endif
+
+   subroutine arguments(v2file, lmore)
+     implicit none
+     character(len=*) :: v2file
+     character(len=120) :: harg
+     logical :: lmore
+   
+     integer :: ierr, i, numarg
+     integer, external :: iargc
+   
+     numarg = iargc()
+   
+     i = 1
+     lmore = .false.
+   
+     do while ( i < numarg) 
+        call getarg(i, harg)
+        print*, 'harg = ', trim(harg)
+   
+        if (harg == "-v") then
+           i = i + 1
+           lmore = .true.
+        elseif (harg == "-h") then
+           call help
+        endif
+   
+     enddo
+   
+     call getarg(i,harg)
+     v2file = harg
+   end subroutine arguments
+   
+   subroutine help
+     implicit none
+     character(len=120) :: cmd
+     call getarg(0, cmd)
+   
+     write(*,'(/,"Usage: ", A, " [-v] v2file ")') trim(cmd)
+     write(*,'(8x, "-v     : Print extra info")')
+     write(*,'(8x, "v3file : MM5v3 file name to read.")')
+     write(*,'(8x, "-h     : print this help message and exit.",/)')
+     stop
+   end subroutine help
+end module read_util_module
+
+
+
+ program readv3
+  use wrf_data
+  use read_util_module
+  use module_compute_geop
+
+
+  implicit none
+#include "wrf_status_codes.h"
+#include 
+  character(len=120) :: flnm
+  character(len=120) :: flnm2
+  character(len=120) :: arg3
+  character(len=19) :: DateStr
+  character(len=19) :: DateStr2
+  character(len=31) :: VarName
+  character(len=31) :: VarName2
+  integer dh1, dh2
+
+  integer :: flag, flag2
+  integer :: iunit, iunit2
+
+  integer :: i,j,k
+  integer :: levlim
+  integer :: cross
+  integer :: ndim, ndim2
+  integer :: WrfType, WrfType2
+  real :: time, time2
+  real*8 :: a, b
+  real*8 :: sum1, sum2, diff1, diff2, serr, perr, rms
+  integer, dimension(4) :: start_index, end_index, start_index2, end_index2, end_index_u, end_index_uz
+  integer , Dimension(3) :: MemS,MemE,PatS,PatE
+  character (len= 4) :: staggering,   staggering2
+  character (len= 3) :: ordering,     ordering2, ord
+  character (len=24) :: start_date,   start_date2
+  character (len=24) :: current_date, current_date2
+  character (len=31) :: name,         name2,  tmpname
+  character (len=25) :: units,        units2
+  character (len=46) :: description,  description2
+
+  real, allocatable, dimension(:,:,:) :: ph, phb, p, pb
+  real, allocatable, dimension(:,:)   :: height
+
+  integer ::  ids, ide, jds, jde, kds, kde,    &
+              ims, ime, jms, jme, kms, kme,    &
+              its, ite, jts, jte, kts, kte
+  integer outcount
+
+
+  character (len=80), dimension(3)  ::  dimnames
+  character (len=80) :: SysDepInfo
+
+  integer :: l, n
+  integer :: ikdiffs, ifdiffs
+
+  real, allocatable, dimension(:,:,:,:) :: data,data2
+
+  integer :: ierr, ierr2, ier, ier2, Status, Status_next_time, Status_next_time2, Status_next_var, Status_next_var_2
+
+  logical :: newtime = .TRUE.
+  logical :: justplot, efound
+
+  integer, external :: iargc
+  logical, external :: iveceq
+
+  levlim = -1
+
+  call ext_ncd_ioinit(SysDepInfo,Status)
+  call set_wrf_debug_level ( 1 )
+
+
+  Justplot = .true.
+
+! get arguments
+!  if ( iargc() .ge. 2 ) then
+    call getarg(1,flnm)
+!    call getarg(2,flnm2)
+    ierr = 0
+    call ext_ncd_open_for_read( trim(flnm), 0, 0, "", dh1, Status)
+    if ( Status /= 0 ) then 
+      print*,'error opening ',flnm, ' Status = ', Status ; stop 
+    endif
+!    call ext_ncd_open_for_read( trim(flnm2), 0, 0, "", dh2, Status)
+!    if ( Status /= 0 ) go to 923
+!    goto 924
+!923    continue
+!
+!! bounce here if second name is not openable -- this would mean that
+!! it is a field name instead.
+!
+!    print*,'could not open ',flnm2
+!    name = flnm2
+!    Justplot = .true.
+!924    continue
+!  if ( iargc() .eq. 3 ) then
+!    call getarg(3,arg3)
+!    read(arg3,*)levlim
+!    print*,'LEVLIM = ',LEVLIM
+!  endif
+!  else
+!     print*,'Usage: command file1 file2'
+!     stop
+!  endif
+
+!print*,'Just plot ',Justplot
+
+start_index = 1
+end_index = 0
+
+CALL ext_ncd_get_dom_ti_integer(dh1,'WEST-EAST_GRID_DIMENSION',end_index(1),1,OutCount,Status)
+CALL ext_ncd_get_dom_ti_integer(dh1,'BOTTOM-TOP_GRID_DIMENSION',end_index(2),1,OutCount,Status)
+CALL ext_ncd_get_dom_ti_integer(dh1,'SOUTH-NORTH_GRID_DIMENSION',end_index(3),1,OutCount,Status)
+ord = 'XZY'
+staggering = ' '
+
+
+
+allocate(ph(end_index(1),end_index(2),end_index(3)))
+allocate(phb(end_index(1),end_index(2),end_index(3)))
+allocate(p(end_index(1),end_index(2),end_index(3)))
+allocate(pb(end_index(1),end_index(2),end_index(3)))
+allocate(height(end_index(1),end_index(3)))
+
+ids=start_index(1); ide=end_index(1); jds=start_index(3); jde=end_index(3); kds=start_index(2); kde=end_index(2)
+ims=start_index(1); ime=end_index(1);   jms=start_index(3); jme=end_index(3);   kms=start_index(2); kme=end_index(2)
+its=start_index(1); ite=end_index(1)-1; jts=start_index(3); jte=end_index(3)-1; kts=start_index(2); kte=end_index(2)-1
+
+end_index_u  = end_index - 1
+end_index_uz = end_index - 1
+end_index_uz(2) = end_index_uz(2) + 1
+
+
+
+if ( Justplot ) then
+  print*, 'flnm = ', trim(flnm)
+
+  call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+
+  DO WHILE ( Status_next_time .eq. 0 )
+    write(*,*)'Next Time ',TRIM(Datestr)
+
+    staggering = 'Z'
+    name = 'PH'
+    call ext_ncd_read_field(dh1,DateStr,TRIM(name),ph,WRF_REAL,0,0,0,ord, &
+                            staggering, dimnames ,                      &
+                            start_index,end_index_uz,                      & !dom
+                            start_index,end_index,                      & !mem
+                            start_index,end_index_uz,                      & !pat
+                            ierr)
+    name = 'PHB'
+    call ext_ncd_read_field(dh1,DateStr,TRIM(name),phb,WRF_REAL,0,0,0,ord, &
+                            staggering, dimnames ,                      &
+                            start_index,end_index_uz,                      & !dom
+                            start_index,end_index,                      & !mem
+                            start_index,end_index_uz,                      & !pat
+                            ierr)
+    staggering = ' '
+    name = 'P'
+    call ext_ncd_read_field(dh1,DateStr,TRIM(name),p,WRF_REAL,0,0,0,ord, &
+                            staggering, dimnames ,                      &
+                            start_index,end_index_u,                      & !dom
+                            start_index,end_index,                      & !mem
+                            start_index,end_index_u,                      & !pat
+                            ierr)
+    name = 'PB'
+    call ext_ncd_read_field(dh1,DateStr,TRIM(name),pb,WRF_REAL,0,0,0,ord, &
+                            staggering, dimnames ,                      &
+                            start_index,end_index_u,                      & !dom
+                            start_index,end_index,                      & !mem
+                            start_index,end_index_u,                      & !pat
+                            ierr)
+
+    CALL compute_500mb_height  ( ph, phb, p, pb,                  &
+                                   height,                          &
+                                   ids, ide, jds, jde, kds, kde,    &
+                                   ims, ime, jms, jme, kms, kme,    &
+                                   its, ite, jts, jte, kts, kte    )
+
+    write(88,*)end_index_u(1),end_index_u(3),' height ',trim(Datestr)
+    do j = 1, end_index_u(3)
+      do i = 1, end_index_u(1)
+        write(88,*) height(i,j)
+      enddo
+    enddo
+
+    call ext_ncd_get_next_time(dh1, DateStr, Status_next_time)
+  enddo
+endif
+
+end program readv3
+
+! stub for routine called by module_wrf_error (used by netcdf implementation of IO api)
+SUBROUTINE wrf_abort
+  STOP
+END SUBROUTINE wrf_abort
diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90
new file mode 100644
index 00000000..6446dca7
--- /dev/null
+++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90
@@ -0,0 +1,3388 @@
+!*------------------------------------------------------------------------------
+!*  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          = 2000
+  integer                , parameter      :: MaxTimes         = 9000
+  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
+  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.
+  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')
+      NDim = 2
+    case ('z','c')
+      NDim = 1
+    case ('0')  ! NDim=0 for scalars.  TBH:  20060502
+      NDim = 0
+    case default
+      print *, 'memory order = ',MemOrd,'  ',MemoryOrder
+      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
+
+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
+
+  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
+!for wrf_complex, double_complex
+      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
+
+end module ext_ncd_support_routines
+
+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(IN)      :: 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
+
+  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        = 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(IN)      :: 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
+
+  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        = 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(in)  :: 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)
+
+  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
+  stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
+  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    = 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
+  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
+
+  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
+  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_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
+  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,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(inout) :: 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
+  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 ',__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
+
+  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
+
+  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)),' REDIFINED  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
+    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
+    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 )
+    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(in)     :: FileName
+  integer               ,intent(out)    :: FileStatus
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    FileStatus = WRF_FILE_NOT_OPENED
+    return
+  endif
+  if(FileName /= 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 = 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,*) '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/wrfv2_fire/external/io_phdf5/INSTALL.htm b/wrfv2_fire/external/io_phdf5/INSTALL.htm
new file mode 100755
index 00000000..c2679d06
--- /dev/null
+++ b/wrfv2_fire/external/io_phdf5/INSTALL.htm
@@ -0,0 +1,1207 @@
+
+
+
+
+To integrate HDF5Build and Install the HDF5-WRF IO Module

+

+There are two HDF5 WRF IO modules, sequential and parallel.  The either or both modules can be configured as optional IO modules for WRF.

+

+The sequential HDF module (io_hdf5) uses the serial HDF5 library.  The parallel
+HDF module (io_phdf5) uses parallel HDF5 (which requires MPI-IO).

+

+The installation for the two modules is similar.

+

+Prerequisites

+

+WRF 1.3

+

+The HDF5 WRF IO modules require Version 1.3 of WRF.  Information and downloads are available at:

+ 
+
http://www.mmm.ucar.edu/wrf/users/user_main.html

+

+

+HDF5-1.6 .2 or later

+

+The HDF5 WRF IO modules require HDF5-1.6.2 or more recent. The parallel HDF5
+WRF module requires parallel HDF5 (which requires MPI IO). 

+

+Installing HDF5

+

+  

+
    
+  
  1. To obtain 
+  HDF5, download from to 
+  http://hdf.ncsa.uiuc.edu/HDF5/release/obtain5.html. Install HDF5 according to the instructions. The HDF5 library must have he Fortran 90 interface installed. 

    
+ For the sequential WRF module,  SZIP compression can be enabled.  
    2. 
+  
  2. 
+For the parallel WRF module, parallel HDF5 must be installed (this requires MPI-IO). 
    
+Set the environment variable PHDF5 = <<path where phdf5 is installed>>.
+  
+   
    3. 
+
+  
  3. For the sequential HDF WRF IO module, either serial or parallel HDF must be installed.
    
+The HDF library may be installed with the optional SZIP compression enabled. 
    
+Set the environment variable HDF5 = <<path where hdf5 is installed>>.
+  
+  
    
+  
    4. 
+

+

+Platforms

+
This prototype has been tested
+on a few platforms. The HDF WRF IO modules should work on any platform that
+WRF3.1 and HDF5 support, although the details of the configuration may need
+to be worked out.

+

+
+ + + + + + + + + + + + + + + + + +
Module
+ 		Platforms
+ 		Notes
+
Sequential
+ 		+NCSA IBM P690.
+ NCAR IBM SP3
+ PC Linux with PGI Fortran 90 Compiler, Vers. 4
+ SGI IRIX6.5-64 bit
+ 		To date, WRF3.1 does not work on Linux with PGF, version 5.
+
Parallel
+ 		+NCSA IBM P690.
+ + NCAR IBM SP3
+
+
+
+
+Installation of the HDF5 WRF IO Modules
+
+The HDF5 WRF IO modules are used by adding it to a standard WRF configuration.  This process has four main steps
+
    +
  1. Downoad the HDF WRF IO module(s)
  2. Add the HDF5 WRF IO module(s) as an "extern" module
    3. + +
  3. Modifying relevant files in the WRF distribution
    4. +
  4. Compile WRF following the usual procedures
    +
    5. + +
+The parallel, sequential, or both may be configured.
+
+1. Download the WRD-HDF5 IO modules
+
+The HDF WRF IO modules are available from:
+ +

+
+

+ 2. Add WRF-HDF5 IO module(s) to the WRF source

+ + +

+ The HDF5 WRF IO modules are added as sub-directories in the 'external' directory of the WRF source.
+

+
+ + +

cd external;
+tar xvf io_hdf5.tar
+tar xvf io_phdf5.tar
+

+
+ +

+

+ + + + + + + + + + +
contents of the sequential HDF WRF IO module:
+
+  ./io_hdf5
  ./io_hdf5/wrf-hdf5.F90
  ./io_hdf5/wrf_status_codes.h
  ./io_hdf5/Makefile
  ./io_hdf5/wrf-hdf5attr.F90
  ./io_hdf5/wrf-hdf5support.F90
  ./io_hdf5/wrf_io_flags.h
+
+ + +
+ +
+ + + + + + + + + + + + +
contents of the sequential HDF WRF IO module:
+
+  ./io_phdf5/
  ./io_phdf5/Makefile
  ./io_phdf5/wrf_status_codes.h
  ./io_phdf5/wrf-phdf5attr.F90
  ./io_phdf5/wrf-phdf5support.F90
  ./io_phdf5/wrf_io_flags.h
  ./io_phdf5/wrf-phdf5.F90
+
+ + +
+ + +

Design note:

+ +

In the sequential HDF5 WRF +IO modules, arrays larger thatn 8096 bytes are compressed by default. In +this case, the HDF5 dataset is configured to use the shuffle filter plus deflate +(GZIP) compression, with compression level 6.  
+

+ + +

In the current prototype, there is no option in the namelist for +users to change this default. To modify this behavior, it is necessary to modify the source code.
+
+To disable compression:

+ + + +
+

Edit the file 'wrf/external/io_hdf5/wrf-hdf5.F90'
+

+

Comment out the lines:

+

            +call h5pset_shuffle_f(crp_list,hdf5err)

+

                +and

+

            +call h5pset_deflate_f(crp_list,6,hdf5err)

+
+ + + + + + + + + +

To use  SZIP compression instead:

+ + +
+

For SZIP information and downloads, see the szip at  + +http://hdf.ncsa.uiuc.edu/doc_resource/SZIP/.
+

+

Edit the file 'wrf/external/io_hdf5/wrf-hdf5.F90'.

+

Comment out the lines:

+

            +call h5pset_shuffle_f(crp_list,hdf5err)

+

                +and

+

            +call h5pset_deflate_f(crp_list,6,hdf5err)

+

Uncomment the line: +

+

              +call +h5pset_szip_f(crp_list,H5_SZIP_AK13_OM_F+H5_SZIP_NN_OM_F,8,hdf5err)
+

+

Change the value +of the parameters in the function h5pset_szip_f if necessary.  See the SZIP documentation for more information about the parameters.
+

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


+

+

3. Modifications to WRF files
+

+ +

In order to add a new IO module to WRF,  several +files in the WRF source code must be changed. The following files need to be +modified:
+

+ + + + + + +
WRFV1/configure
+WRFV1/Registry/Registry
+WRFV1/arch/Config.pl
+WRFV1/arch/configure.defaults
+WRFV1/frame/md_calls.m4
+WRFV1/frame/module_io.F
+WRFV1/share/module_io_wrf.F
+WRFV1/external/Makefile
+
+
+The exact changes depend on how WRF has been configured on the sytsem.  
+

Examples of the changes to the files of the WRF1.3 distribution are available at:
+

+

  + + + ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules
+

+ +
+
+

WRF configuration files
+ +

+

The 'configure' file must be updated to add the HDF5 and PHDF5 variables.
+

+ + + + + + +
*** ../WRFV1/configure Thu Feb 6 13:10:56 2003
+--- ./WRFV1-with-hdf/configure Thu May 13 12:18:40 2004
+***************
+*** 206,211 ****
+--- 206,223 ----
+ echo "Will configure for use without NetCDF"
+ fi
+
++ if [ -n "$HDF5" ] ; then
++ echo "Will use HDF5 in dir: $HDF5"
++ else
++ echo "Will configure for use without HDF5"
++ fi
++
++ if [ -n "$PHDF5" ] ; then
++ echo "Will use PHDF5 in dir: $PHDF5"
++ else
++ echo "Will configure for use without PHDF5"
++ fi
++
+ # if the uname command exists, give it a shot and see if
+ # we can narrow the choices; otherwise, spam 'em
+ os="ARCH"
+***************
+*** 227,232 ****
+
+ # Found perl, so proceed with configuration
+ if test -n "$PERL" ; then
+! $PERL arch/Config.pl -perl=$PERL -netcdf=$NETCDF -os=$os -mach=$mach
+ fi
+
+--- 239,244 ----
+
+ # Found perl, so proceed with configuration
+ if test -n "$PERL" ; then
+! $PERL arch/Config.pl -perl=$PERL -netcdf=$NETCDF -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach
+ fi
+
+
+

The file 'Registry/Registry' must be updated to add the HDF IO modules (io_hdf5 and io_phdf5).
+

+ + + + + + +
*** ../WRFV1/Registry/Registry Wed Feb 12 09:28:28 2003
+--- ./WRFV1-with-hdf/Registry/Registry Thu May 13 12:18:39 2004
+***************
+*** 738,745 ****
+ # Four placeholders for additional packages (we can go beyond zzz
+ # but that will entail modifying frame/module_io.F and frame/md_calls.m4)
+ # Please note these are placeholders; HDF has not been implemented yet.
+! package io_hdf io_form_restart==3 - -
+! package io_xxx io_form_restart==4 - -
+ package io_yyy io_form_restart==5 - -
+ package io_zzz io_form_restart==6 - -
+
+--- 738,745 ----
+ # Four placeholders for additional packages (we can go beyond zzz
+ # but that will entail modifying frame/module_io.F and frame/md_calls.m4)
+ # Please note these are placeholders; HDF has not been implemented yet.
+! package io_hdf5 io_form_restart==3 - -
+! package io_phdf5 io_form_restart==4 - -
+ package io_yyy io_form_restart==5 - -
+ package io_zzz io_form_restart==6 - -
+
+
+

The file 'arch/Config.pl' needs to be changed to add the code to use the HDF5 and PHDF5 variables.
+

+ + + + + + +
*** ../WRFV1/arch/Config.pl Fri Mar 16 12:06:46 2001
+--- ./WRFV1-with-hdf/arch/Config.pl Thu May 13 12:18:37 2004
+***************
+*** 7,12 ****
+--- 7,14 ----
+
+ $sw_perl_path = perl ;
+ $sw_netcdf_path = "" ;
++ $sw_hdf5_path ="";
++ $sw_phdf5_path="";
+ $sw_os = "ARCH" ; # ARCH will match any
+ $sw_mach = "ARCH" ; # ARCH will match any
+
+***************
+*** 20,25 ****
+--- 22,35 ----
+ {
+ $sw_netcdf_path = substr( $ARGV[0], 8 ) ;
+ }
++ if ( substr( $ARGV[0], 1, 5 ) eq "hdf5=" )
++ {
++ $sw_hdf5_path = substr( $ARGV[0], 6 ) ;
++ }
++ if ( substr( $ARGV[0], 1, 6 ) eq "phdf5=" )
++ {
++ $sw_phdf5_path = substr( $ARGV[0], 7 ) ;
++ }
+ if ( substr( $ARGV[0], 1, 3 ) eq "os=" )
+ {
+ $sw_os = substr( $ARGV[0], 4 ) ;
+***************
+*** 89,94 ****
+--- 99,106 ----
+ {
+ $_ =~ s/CONFIGURE_PERL_PATH/$sw_perl_path/g ;
+ $_ =~ s/CONFIGURE_NETCDF_PATH/$sw_netcdf_path/g ;
++ $_ =~ s/CONFIGURE_HDF5_PATH/$sw_hdf5_path/g ;
++ $_ =~ s/CONFIGURE_PHDF5_PATH/$sw_phdf5_path/g ;
+ if ( $sw_netcdf_path )
+ { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ;
+ $_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ;
+***************
+*** 99,104 ****
+--- 111,140 ----
+ $_ =~ s:CONFIGURE_NETCDF_FLAG::g ;
+ $_ =~ s:CONFIGURE_NETCDF_LIB_PATH::g ;
+ }
++
++ if ( $sw_hdf5_path )
++
++ { $_ =~ s/CONFIGURE_WRFIO_HDF5/wrfio_hdf5/g ;
++ $_ =~ s:CONFIGURE_HDF5_FLAG:-DHDF5: ;
++ $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L../external/io_hdf5 -lwrfio_hdf5 -L$sw_hdf5_path/lib +-lhdf5_fortran -lhdf5 -lm -lz -L$sw_hdf5_path/lib -lsz: ;
++ }
++ else
++ { $_ =~ s/CONFIGURE_WRFIO_HDF5//g ;
++ $_ =~ s:CONFIGURE_HDF5_FLAG::g ;
++ $_ =~ s:CONFIGURE_HDF5_LIB_PATH::g ;
++ }
++
++ if ( $sw_phdf5_path )
++
++ { $_ =~ s/CONFIGURE_WRFIO_PHDF5/wrfio_phdf5/g ;
++ $_ =~ s:CONFIGURE_PHDF5_FLAG:-DPHDF5: ;
++ $_ =~ s:CONFIGURE_PHDF5_LIB_PATH:-L../external/io_phdf5 -lwrfio_phdf5 -L$sw_phdf5_path/lib -lhdf5_fortran -lhdf5 -lm -lz: ;
++ }
++ else
++ { $_ =~ s/CONFIGURE_WRFIO_PHDF5//g ;
++ $_ =~ s:CONFIGURE_PHDF5_FLAG::g ;
++ $_ =~ s:CONFIGURE_PHDF5_LIB_PATH::g ;
++ }
+ @machopts = ( @machopts, $_ ) ;
+ }
+ if ( substr( $_, 0, 5 ) eq "#ARCH" && $latchon == 0 )
+
+
+

The file 'arch/configure.defauts' must be edited to reflect the configuration of the current system.
+

+ + + + + + +
*** ../WRFV1/arch/configure.defaults Fri Mar 28 14:08:48 2003
+--- ./WRFV1-with-hdf/arch/configure.defaults Thu May 13 12:18:40 2004
+***************
+*** 732,758 ****
+
+
+ ###########################################################
+! #ARCH AIX DM (RSL-IO, IBM-MPI)
+ #
+ DMPARALLEL = 1
+! SFC = xlf90_r
+ SCC = xlc_r
+! FC = mpxlf90_r
+ CC = mpcc_r
+ CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \
+ -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)
+! FCOPTIM = -O2 -qarch=auto -qmaxmem=32676
+ FCDEBUG = # -g -qfullpath
+ FCBASEOPTS = -qspill=20000 $(FCDEBUG)
+ FCFLAGS = $(FCOPTIM) $(FCBASEOPTS)
+! INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_int \
+ -I../frame -I../share -I../phys -I../inc
+ EXTRAMODULES =
+ ARCHFLAGS = -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \
+! -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO
+ PERL = perl
+ REGISTRY = Registry
+! LIB = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl -lmass \
+ -L../external/io_int -lwrfio_int \
+ ../frame/internal_header_util.o ../frame/pack_utils.o
+ LDFLAGS = -bmaxstack:256000000
+--- 732,823 ----
+
+
+ ###########################################################
+! #ARCH AIX DM (RSL-IO, IBM-MPI)(PARALLEL HDF5)
+ #
+ DMPARALLEL = 1
+! SFC = xlf90_r
+ SCC = xlc_r
+! FC = mpxlf90_r
+ CC = mpcc_r
+ CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \
+ -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)
+! FCOPTIM = -O1 -qarch=auto -qmaxmem=-1
+! #FCOPTIM = -O2
+! FCDEBUG = -g -qfullpath
+! FCBASEOPTS = -qspill=20000 $(FCDEBUG)
+! FCFLAGS = $(FCOPTIM) $(FCBASEOPTS)
+! INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_phdf5 -I../external/io_int \
+! -I../frame -I../share -I../phys -I../inc
+! EXTRAMODULES =
+! ARCHFLAGS = -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \
+! -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PHDF5_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO
+! PERL = perl
+! REGISTRY = Registry
+! LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PHDF5_LIB_PATH -L../external/RSL/RSL -lrsl -lmass \
+! -L../external/io_int -lwrfio_int \
+! ../frame/internal_header_util.o ../frame/pack_utils.o
+! LDFLAGS = -bmaxstack:256000000 -bmaxdata:0x80000000
+! CPP = /lib/cpp
+! CPPFLAGS = -I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags`
+! MAX_DOMAINS = 4
+! MAX_PROC = 1024
+! AR = ar ru
+! M4 = m4 -B 8000
+! RANLIB = ranlib
+!
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PHDF5 ../external/RSL/RSL/librsl.a wrfio_int
+! ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c +>> ../tools/gen_comms.c ; \
+! /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F )
+!
+! wrfio_nf :
+! ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(SFC) +$(FCDEBUG) -qarch=auto -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h +../../inc )
+!
+! wrfio_phdf5 :
+! ( cd ../external/io_phdf5 ; make PHDF5PATH=CONFIGURE_PHDF5_PATH FC="$(FC) +$(FCDEBUG) -qarch=auto -qfree=F90 -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h +../../inc )
+!
+! wrfio_int :
+! ( cd ../external/io_int ; \
+! make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )
+!
+! ../external/RSL/RSL/librsl.a :
+! ( cd ../external/RSL/RSL ; make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 )
+!
+! # compile these without high optimization to speed compile
+! mediation_force_domain.o : mediation_force_domain.F
+! mediation_interp_domain.o : mediation_interp_domain.F
+!
+! mediation_force_domain.o \
+! mediation_interp_domain.o :
+! $(RM) $@
+! sed /\!.\*\'/s/\'//g $*.F > $*.b
+! $(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f
+! $(RM) $*.b
+! $(FC) -c $(FCBASEOPTS) $(MODULE_DIRS) $*.f
+!
+! ###########################################################
+! #ARCH AIX DM (RSL-IO, IBM-MPI)(SERIAL HDF5)
+! #
+! DMPARALLEL = 1
+! SFC = xlf90_r
+! SCC = xlc_r
+! FC = mpxlf90_r
+! CC = mpcc_r
+! CFLAGS = -DNOUNDERSCORE -DWRF_RSL_IO -I../external/RSL/RSL -DDM_PARALLEL \
+! -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)
+! FCOPTIM = -O1 -qarch=auto -qmaxmem=32676
+! #FCOPTIM = -O2
+ FCDEBUG = # -g -qfullpath
+ FCBASEOPTS = -qspill=20000 $(FCDEBUG)
+ FCFLAGS = $(FCOPTIM) $(FCBASEOPTS)
+! INCLUDE_MODULES = -I../external/io_netcdf -I../external/io_hdf5 -I../external/io_int \
+ -I../frame -I../share -I../phys -I../inc
+ EXTRAMODULES =
+ ARCHFLAGS = -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \
+! -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_HDF5_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO
+ PERL = perl
+ REGISTRY = Registry
+! LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_HDF5_LIB_PATH \
+! -L../external/RSL/RSL -lrsl -lmass \
+ -L../external/io_int -lwrfio_int \
+ ../frame/internal_header_util.o ../frame/pack_utils.o
+ LDFLAGS = -bmaxstack:256000000
+***************
+*** 764,776 ****
+ M4 = m4 -B 8000
+ RANLIB = ranlib
+
+! externals : CONFIGURE_WRFIO_NF ../external/RSL/RSL/librsl.a wrfio_int
+ ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c +>> ../tools/gen_comms.c ; \
+ /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F )
+
+ wrfio_nf :
+ ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(SFC) +$(FCDEBUG) -qarch=auto -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h +../../inc )
+
+ wrfio_int :
+ ( cd ../external/io_int ; \
+ make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )
+--- 829,844 ----
+ M4 = m4 -B 8000
+ RANLIB = ranlib
+
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_HDF5 ../external/RSL/RSL/librsl.a wrfio_int
+ ( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c +>> ../tools/gen_comms.c ; \
+ /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F >> module_dm.F )
+
+ wrfio_nf :
+ ( cd ../external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(SFC) +$(FCDEBUG) -qarch=auto -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h +../../inc )
+
++ wrfio_hdf5 :
++ ( cd ../external/io_hdf5 ; make HDF5PATH=CONFIGURE_HDF5_PATH FC="$(SFC) +$(FCDEBUG) -qarch=auto -qfree=F90 -qzerosize" ; /bin/cp wrf_io_flags.h wrf_status_codes.h +../../inc )
++
+ wrfio_int :
+ ( cd ../external/io_int ; \
+ make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )
+***************
+*** 1650,1663 ****
+ FCBASEOPTS = -byteswapio -Ktrap=fp -Mfree -tp p6 $(FCDEBUG)
+ FCFLAGS = $(FCOPTIM) $(FCBASEOPTS)
+ ARCHFLAGS = -DDEREF_KLUDGE -DIO_DEREF_KLUDGE -DIWORDSIZE=4 -DRWORDSIZE=4 -DLWORDSIZE=4 \
+! CONFIGURE_NETCDF_FLAG \
+ -DTRIEDNTRUE -DONLY_WRFMODEL_IO
+! INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_int \
+ -I../frame -I../share -I../phys -I../inc
+ EXTRAMODULES =
+ PERL = perl
+ REGISTRY = Registry
+! LIB = CONFIGURE_NETCDF_LIB_PATH \
+ ../frame/internal_header_util.o ../frame/pack_utils.o
+ LDFLAGS =
+ CPP = /lib/cpp
+--- 1718,1731 ----
+ FCBASEOPTS = -byteswapio -Ktrap=fp -Mfree -tp p6 $(FCDEBUG)
+ FCFLAGS = $(FCOPTIM) $(FCBASEOPTS)
+ ARCHFLAGS = -DDEREF_KLUDGE -DIO_DEREF_KLUDGE -DIWORDSIZE=4 -DRWORDSIZE=4 -DLWORDSIZE=4 \
+! CONFIGURE_NETCDF_FLAG CONFIGURE_HDF5_FLAG\
+ -DTRIEDNTRUE -DONLY_WRFMODEL_IO
+! INCLUDE_MODULES = -module ../main -I../external/io_netcdf -I../external/io_hdf5 -I../external/io_int \
+ -I../frame -I../share -I../phys -I../inc
+ EXTRAMODULES =
+ PERL = perl
+ REGISTRY = Registry
+! LIB = CONFIGURE_NETCDF_LIB_PATH CONFIGURE_HDF5_LIB_PATH \
+ ../frame/internal_header_util.o ../frame/pack_utils.o
+ LDFLAGS =
+ CPP = /lib/cpp
+***************
+*** 1666,1672 ****
+ M4 = m4
+ RANLIB = ranlib
+
+! externals : CONFIGURE_WRFIO_NF wrfio_int
+ ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+ wrfio_nf :
+--- 1734,1740 ----
+ M4 = m4
+ RANLIB = ranlib
+
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_HDF5 wrfio_int
+ ( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+ wrfio_nf :
+***************
+*** 1675,1680 ****
+--- 1743,1754 ----
+ FFLAGS='$(FCFLAGS) -ICONFIGURE_NETCDF_PATH/include' ; \
+ /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc )
+
++ wrfio_hdf5 :
++ ( cd ../external/io_hdf5 ; \
++ make HDF5PATH=CONFIGURE_HDF5_PATH FC=$(FC) TRADFLAG="-traditional" \
++ FFLAGS='$(FCFLAGS) -ICONFIGURE_HDF5_PATH/lib' ; \
++ /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc )
++
+ wrfio_int :
+ ( cd ../external/io_int ; \
+ make CC=$(CC) FC="$(SFC) $(FCDEBUG) $(FCBASEOPTS)" \
+
+


+ +

+
+
    +

+
+

Modifications of source code inside WRF
+

+

The io_hdf5 and/or io_phdf5 modules must be added to the WRF source. In addition, the WRF source must be modified in a few places.
+

+

The 'frame/md_calls.m4' must be modified to recognize the HDF modules.
+

+
+
+ + + + + + +
*** ../WRFV1/frame/md_calls.m4 Mon Dec 10 18:10:43 2001
+--- ./WRFV1-with-hdf/frame/md_calls.m4 Thu May 13 12:18:44 2004
+***************
+*** 70,78 ****
+ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+ ENDIF
+ #endif
+! #ifdef HDF
+! CASE ( IO_HDF )
+! CALL ext_hdf_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &
+ ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )
+ #endif
+ #ifdef XXX
+--- 70,99 ----
+ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+ ENDIF
+ #endif
+! #ifdef HDF5
+! CASE ( IO_HDF5 )
+! IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
+! CALL ext_hdf5_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &
+! ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )
+! ENDIF
+! IF ( .NOT. multi_files(io_form) ) THEN
+! ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))
+! ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )'))
+! ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))
+! ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )'))
+! ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))
+! ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )'))
+! ifelse($1,get,ifelse($4,char, `len_of_str = LEN(Data)'))
+! ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_bytes( len_of_str, IWORDSIZE )'))
+! ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_string( Data, len_of_str )'))
+! CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+! ENDIF
+!
+!
+! #endif
+! #ifdef PHDF5
+! CASE ( IO_PHDF5 )
+! CALL ext_phdf5_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &
+ ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )
+ #endif
+ #ifdef XXX
+
+
+


+The 'frame/module_io.F' file must be modified to add code to call the HDF5 modules if selected.
+

+ + + + + + +
*** ../WRFV1/frame/module_io.F Tue Dec 3 14:10:48 2002
+--- ./WRFV1-with-hdf/frame/module_io.F Thu May 13 12:18:45 2004
+***************
+*** 34,39 ****
+--- 34,48 ----
+ #ifdef NETCDF
+ CALL ext_ncd_ioinit( SysDepInfo, Status )
+ #endif
++
++ #ifdef HDF5
++ CALL ext_hdf5_ioinit(SysDepInfo, Status)
++ #endif
++
++ #ifdef PHDF5
++ CALL ext_phdf5_ioinit(SysDepInfo, Status)
++ #endif
++
+ END SUBROUTINE wrf_ioinit
+
+ !--- ioexit
+***************
+*** 47,52 ****
+--- 56,70 ----
+ #ifdef NETCDF
+ CALL ext_ncd_ioexit( Status )
+ #endif
++
++ #ifdef HDF5
++ CALL ext_hdf5_ioexit(Status)
++ #endif
++
++ #ifdef PHDF5
++ CALL ext_phdf5_ioexit(Status)
++ #endif
++
+ IF ( use_output_servers() ) CALL ext_quilt_ioexit( Status )
+ END SUBROUTINE
+
+***************
+*** 134,139 ****
+--- 152,179 ----
+ CALL ext_hdf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+ Hndl , Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
++ IF ( multi_files(io_form) ) THEN
++ CALL wrf_get_myproc ( myproc )
++ CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
++ ELSE
++ LocFilename = FileName
++ ENDIF
++ CALL ext_hdf5_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
++ Hndl , Status )
++ ENDIF
++ IF ( .NOT. multi_files(io_form) ) THEN
++ CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
++ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ ENDIF
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
++ Hndl , Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+***************
+*** 214,219 ****
+--- 254,270 ----
+ CASE ( IO_HDF )
+ CALL ext_hdf_open_for_write_commit ( Hndl , Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
++ CALL ext_hdf5_open_for_write_commit ( Hndl , Status )
++ ENDIF
++ IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_open_for_write_commit ( Hndl , Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_open_for_write_commit ( Hndl , Status )
+***************
+*** 316,321 ****
+--- 367,388 ----
+ CALL ext_hdf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+ Hndl , Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
++ CALL ext_hdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
++ Hndl , Status )
++ ENDIF
++ IF ( .NOT. multi_files(io_form) ) THEN
++ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
++ ENDIF
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
++ Hndl , Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+***************
+*** 420,425 ****
+--- 487,502 ----
+ CASE ( IO_HDF )
+ CALL ext_hdf_inquire_opened ( Hndl, FileName , FileStatus, Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF (wrf_dm_on_monitor()) CALL ext_hdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )
++ CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
++ CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status )
+***************
+*** 486,491 ****
+--- 563,578 ----
+ CASE ( IO_HDF )
+ CALL ext_hdf_inquire_filename ( Hndl, FileName , FileStatus, Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF (wrf_dm_on_monitor()) CALL ext_hdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )
++ CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
++ CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status )
+***************
+*** 607,612 ****
+--- 694,708 ----
+ CASE ( IO_HDF )
+ CALL ext_ncd_ioclose( Hndl, Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_hdf5_ioclose( Hndl, Status )
++ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_ioclose( Hndl, Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_ioclose( Hndl, Status )
+***************
+*** 675,680 ****
+--- 771,790 ----
+ CASE ( IO_HDF )
+ CALL ext_hdf_get_next_time( Hndl, DateStr, Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_hdf5_get_next_time( Hndl, DateStr, Status )
++ IF ( .NOT. multi_files(io_form) ) THEN
++ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ len_of_str = LEN(DateStr)
++ CALL wrf_dm_bcast_bytes( len_of_str, IWORDSIZE )
++ CALL wrf_dm_bcast_string ( DateStr , len_of_str )
++ ENDIF
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_get_next_time( Hndl, DateStr, Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_get_next_time( Hndl, DateStr, Status )
+***************
+*** 742,747 ****
+--- 852,866 ----
+ CASE ( IO_HDF )
+ CALL ext_hdf_set_time( Hndl, DateStr, Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_hdf5_set_time( Hndl, DateStr, Status )
++ CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_set_time( Hndl, DateStr, Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_set_time( Hndl, DateStr, Status )
+***************
+*** 875,880 ****
+--- 994,1002 ----
+ #ifdef HDF
+ EXTERNAL ext_hdf_read_field
+ #endif
++ #ifdef HDF5
++ EXTERNAL ext_hdf5_read_field
++ #endif
+ #ifdef XXX
+ EXTERNAL ext_xxx_read_field
+ #endif
+***************
+*** 911,916 ****
+--- 1033,1058 ----
+ PatchStart , PatchEnd , &
+ Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ CALL call_pkg_and_dist ( ext_hdf5_read_field, multi_files(io_form), &
++ Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
++ DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
++ DomainStart , DomainEnd , &
++ MemoryStart , MemoryEnd , &
++ PatchStart , PatchEnd , &
++ Status )
++ #endif
++ #ifdef PHDF5
++ CASE (IO_PHDF5)
++ CALL ext_phdf5_read_field ( &
++ Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
++ DomainDesc , MemoryOrder , Stagger , DimNames , &
++ DomainStart , DomainEnd , &
++ MemoryStart , MemoryEnd , &
++ PatchStart , PatchEnd , &
++ Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL call_pkg_and_dist ( ext_xxx_read_field, multi_files(io_form), &
+***************
+*** 994,999 ****
+--- 1136,1144 ----
+ #ifdef HDF
+ EXTERNAL ext_hdf_write_field
+ #endif
++ #ifdef HDF5
++ EXTERNAL ext_hdf5_write_field
++ #endif
+ #ifdef XXX
+ EXTERNAL ext_xxx_write_field
+ #endif
+***************
+*** 1028,1033 ****
+--- 1173,1198 ----
+ PatchStart , PatchEnd , &
+ Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ CALL collect_fld_and_call_pkg ( ext_hdf5_write_field, multi_files(io_form), &
++ Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
++ DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , &
++ DomainStart , DomainEnd , &
++ MemoryStart , MemoryEnd , &
++ PatchStart , PatchEnd , &
++ Status )
++ #endif
++ #ifdef PHDF5
++ CASE ( IO_PHDF5 )
++ CALL ext_phdf5_write_field ( &
++ Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
++ DomainDesc , MemoryOrder , Stagger , DimNames , &
++ DomainStart , DomainEnd , &
++ MemoryStart , MemoryEnd , &
++ PatchStart , PatchEnd , &
++ Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form), &
+***************
+*** 1115,1120 ****
+--- 1280,1293 ----
+ DomainStart , DomainEnd , &
+ Status )
+ #endif
++ #ifdef HDF5
++ CASE ( IO_HDF5 )
++ write(*,*) "NOT IMPLEMENT at HDF5"
++ ! CALL ext_hdf5_get_var_info ( Hndl , VarName , NDim , &
++ ! MemoryOrder , Stagger , &
++ ! DomainStart , DomainEnd , &
++ ! Status )
++ #endif
+ #ifdef XXX
+ CASE ( IO_XXX )
+ CALL ext_xxx_get_var_info ( Hndl , VarName , NDim , &
+
+
+


+The 'share/module_io.F' file must be modified to recognize the HDF5 options for IO.
+

+ + + + + + +
*** ../WRFV1/share/module_io_wrf.F Tue Feb 18 14:26:22 2003
+--- ./WRFV1-with-hdf/share/module_io_wrf.F Thu May 13 12:18:46 2004
+***************
+*** 1032,1037 ****
+--- 1032,1079 ----
+ ,Status )
+ ENDIF
+
++ IF (io_form .EQ. IO_HDF5) THEN
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"description" & ! Element
++ ,Var & ! Data Name
++ ,Desc & ! Data
++ ,Status )
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"units" & ! Element
++ ,Var & ! Data Name
++ ,Units & ! Data
++ ,Status )
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"stagger" & ! Element
++ ,Var & ! Data Name
++ ,Stagger & ! Data
+4/ Build WRF
+
++ ,Status )
++ ENDIF
++
++ IF (io_form .EQ. IO_PHDF5) THEN
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"description" & ! Element
++ ,Var & ! Data Name
++ ,Desc & ! Data
++ ,Status )
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"units" & ! Element
++ ,Var & ! Data Name
++ ,Units & ! Data
++ ,Status )
++ CALL wrf_put_var_ti_char( &
++ DataHandle & ! DataHandle
++ ,"stagger" & ! Element
++ ,Var & ! Data Name
++ ,Stagger & ! Data
++ ,Status )
++ ENDIF
++
+ IF ( wrf_at_debug_level(300) ) THEN
+ WRITE(wrf_err_message,*) debug_message,' Status = ',Status
+ CALL wrf_message ( TRIM(wrf_err_message) )
+
+
+

The 'Makefile' for the 'external' directory must be updated to build the new IO modules.
+

+ + + + + + +
*** ../WRFV1/external/Makefile Mon Dec 10 18:07:21 2001
+--- ./WRFV1-with-hdf/external/Makefile Thu May 13 12:18:38 2004
+***************
+*** 3,12 ****
+ ( cd RSL/RSL ; make clean )
+ ( cd io_netcdf ; make clean )
+ ( cd io_int ; make clean )
+
+ superclean : clean
+ /bin/rm -f RSL/RSL/librsl.a RSL/RSL/rsl.inc
+ /bin/rm -f io_netcdf/libwrfio_nf.a io_netcdf/diffwrf io_netcdf/*.o io_netcdf/*.f \
+ io_int/libwrfio_int.a io_int/diffwrf */*.mod
+!
+!
+--- 3,14 ----
+ ( cd RSL/RSL ; make clean )
+ ( cd io_netcdf ; make clean )
+ ( cd io_int ; make clean )
++ (cd io_hdf5; make clean)
++ (cd io_phdf5; make clean)
+
+ superclean : clean
+ /bin/rm -f RSL/RSL/librsl.a RSL/RSL/rsl.inc
+ /bin/rm -f io_netcdf/libwrfio_nf.a io_netcdf/diffwrf io_netcdf/*.o io_netcdf/*.f \
+ io_int/libwrfio_int.a io_int/diffwrf */*.mod
+! /bin/rm -f io_phdf5/*.a io_phdf5/*.o *.f *.mod
+! /bin/rm -f io_hdf5/*.a io_hdf5/*.o *.f *.mod
+
+
+
+ + +

+
+

+

Last Modified: 17 May 2004 

+
+
+ +

 

+
+ +
+ + +
+
+ diff --git a/wrfv2_fire/external/io_phdf5/Makefile b/wrfv2_fire/external/io_phdf5/Makefile new file mode 100644 index 00000000..7fc3b5dc --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/Makefile @@ -0,0 +1,39 @@ +#makefile to build a wrf-phdf5 with netCDF + +OBJSL = wrf-phdf5.o wrf-phdf5attr.o wrf-phdf5support.o +OBJS = $(OBJSL) +OPTS = -bmaxdata:0x80000000 +FFLAGS = $(OPTS) -I$(PHDF5PATH)/lib -I../ioapi_share +FORTRANLIB=-I$(PHDF5PATH)/lib $(PHDF5PATH)/lib/libhdf5_fortran.a +LIBSHDF = $(FORTRANLIB) $(PHDF5PATH)/lib/libhdf5.a +LIB =-lm -lz +CPP = /lib/cpp -C -P $(TRADFLAG) +M4 = m4 -Uinclude -Uindex -Ulen +AR = ar + +.SUFFIXES: .F90 .f90 .o .code + +all : libwrfio_phdf5.a + +libwrfio_phdf5.a: $(OBJS) + /bin/rm -f libwrfio_phdf5.a + $(AR) cr libwrfio_phdf5.a $(OBJSL) + $(RANLIB) libwrfio_phdf5.a + +wrf-phdf5support.o: wrf-phdf5support.F90 + $(CPP) -I../ioapi_share wrf-phdf5support.F90 | $(M4) - > wrf-phdf5support.f90 + $(FC) $(FFLAGS) -c wrf-phdf5support.f90 +wrf-phdf5attr.o: wrf-phdf5attr.F90 wrf-phdf5support.o + $(CPP) wrf-phdf5attr.F90 | $(M4) - > wrf-phdf5attr.f90 + $(FC) $(FFLAGS) -c wrf-phdf5attr.f90 + +wrf-phdf5.o: wrf-phdf5.F90 wrf-phdf5attr.o wrf-phdf5support.o + $(CPP) wrf-phdf5.F90 | $(M4) - > wrf-phdf5.f90 + $(FC) $(FFLAGS) -c wrf-phdf5.f90 + +clean: + /bin/rm -f *.f90 *.o *.mod + +superclean: clean + /bin/rm -f libwrfio_phdf5.a + diff --git a/wrfv2_fire/external/io_phdf5/README.phdf5 b/wrfv2_fire/external/io_phdf5/README.phdf5 new file mode 100755 index 00000000..5af517f1 --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/README.phdf5 @@ -0,0 +1,29 @@ +This directory has the parallel HDF5 WRF IO module. + +This module requires parallel HDF5, version 1.6.2 or later. + +See 'Install.htm' for instrutions. + +For more information, please see: + http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS + +---- + +The HDF5 WRF IO module was written by the the HDF Group at NCSA, the +National Center for Supercomputing Applications. + HDF Group + National Center for Supercomputing Applications + University of Illinois at Urbana-Champaign + 605 E. Springfield, Champaign IL 61820 + http://hdf.ncsa.uiuc.edu/ + +Copyright 2004 by the Board of Trustees, University of Illinois, + +Redistribution or use of this IO module, with or without modification, +is permitted for any purpose, including commercial purposes. + +This software is an unsupported prototype. Use at your own risk. + +This work was funded by the MEAD expedition at the National Center +for Supercomputing Applications, NCSA. For more information see: + http://www.ncsa.uiuc.edu/expeditions/MEAD diff --git a/wrfv2_fire/external/io_phdf5/wrf-phdf5.F90 b/wrfv2_fire/external/io_phdf5/wrf-phdf5.F90 new file mode 100644 index 00000000..0d04a994 --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/wrf-phdf5.F90 @@ -0,0 +1,5378 @@ +!/*************************************************************************** +!* The HDF5 WRF IO module was written by the the HDF Group at NCSA, the * +!* National Center for Supercomputing Applications. * +!* HDF Group * +!* National Center for Supercomputing Applications * +!* University of Illinois at Urbana-Champaign * +!* 605 E. Springfield, Champaign IL 61820 * +!* http://hdf.ncsa.uiuc.edu/ * +!* * +!* Copyright 2004 by the Board of Trustees, University of Illinois, * +!* * +!* Redistribution or use of this IO module, with or without modification, * +!* is permitted for any purpose, including commercial purposes. * +!* * +!* This software is an unsupported prototype. Use at your own risk. * +!* http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS * +!* * +!* This work was funded by the MEAD expedition at the National Center * +!* for Supercomputing Applications, NCSA. For more information see: * +!* http://www.ncsa.uiuc.edu/expeditions/MEAD * +!* * +!* * +!****************************************************************************/ + + +subroutine HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart,DomainEnd & + ,PatchStart,PatchEnd,MemoryOrder & + ,WrfDType,FieldType,groupID,TimeIndex & + ,DimRank ,DatasetName,XField,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'mpif.h' + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(inout) :: Comm + character*(*) ,intent(in) :: DateStr + integer,dimension(NVarDims) ,intent(in) :: Length + + integer,dimension(NVarDims) ,intent(in) :: DomainStart + integer,dimension(NVarDims) ,intent(in) :: DomainEnd + integer,dimension(NVarDims) ,intent(in) :: PatchStart + integer,dimension(NVarDims) ,intent(in) :: PatchEnd + + character*(*) ,intent(in) :: MemoryOrder + + integer ,intent(in) :: WrfDType + integer(hid_t) ,intent(in) :: FieldType + integer(hid_t) ,intent(in) :: groupID + integer ,intent(in) :: TimeIndex + + integer,dimension(*) ,intent(in) :: DimRank + character (*) ,intent(in) :: DatasetName + integer,dimension(*) ,intent(inout) :: XField + integer ,intent(out) :: Status + + integer(hid_t) :: dset_id + integer :: NDim + integer,dimension(NVarDims) :: VStart + integer,dimension(NVarDims) :: VCount + character (3) :: Mem0 + character (3) :: UCMem0 + type(wrf_phdf5_data_handle) ,pointer :: DH + + ! attribute defination + integer(hid_t) :: dimaspace_id ! DimRank dataspace id + integer(hid_t) :: dimattr_id ! DimRank attribute id + integer(hsize_t) ,dimension(1) :: dim_space + INTEGER(HID_T) :: dspace_id ! Raw Data memory Dataspace id + INTEGER(HID_T) :: fspace_id ! Raw Data file Dataspace id + INTEGER(HID_T) :: crp_list ! chunk identifier + integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute + integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder + integer(hid_t) :: h5_attrid ! for fieldtype,memorder + integer(hsize_t), dimension(7) :: adata_dims + integer :: routine_atype + + + integer, dimension(:),allocatable :: dimrank_data + + INTEGER(HSIZE_T), dimension(:),allocatable :: dims ! Dataset dimensions + INTEGER(HSIZE_T), dimension(:),allocatable :: sizes ! Dataset dimensions + INTEGER(HSIZE_T), dimension(:),allocatable :: chunk_dims + INTEGER(HSIZE_T), dimension(:),allocatable :: hdf5_maxdims + INTEGER(HSIZE_T), dimension(:),allocatable :: offset + INTEGER(HSIZE_T), dimension(:),allocatable :: count + INTEGER(HSIZE_T), DIMENSION(7) :: dimsfi + integer :: hdf5err + integer :: i,j + integer(size_t) :: dsetsize + + ! FOR PARALLEL IO + integer(hid_t) :: xfer_list + logical :: no_par + + + ! get the handle + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! get the rank of the dimension + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! If patch is equal to domain, the parallel is not necessary, sequential is used. + ! In this version, we haven't implemented this yet. + ! We use no_par to check whether we can use compact data storage. + no_par = .TRUE. + do i = 1,NDim + if((PatchStart(i)/=DomainStart(i)).or.(PatchEnd(i)/=DomainEnd(i))) then + no_par = .FALSE. + exit + endif + enddo + + ! change the different Memory Order to XYZ for patch and domain + if(MemoryOrder.NE.'0') then + call ExtOrder(MemoryOrder,PatchStart,Status) + call ExtOrder(MemoryOrder,PatchEnd,Status) + call ExtOrder(MemoryOrder,DomainStart,Status) + call ExtOrder(MemoryOrder,DomainEnd,Status) + endif + + ! allocating memory for dynamic arrays; + ! since the time step is always 1, we may ignore the fourth + ! dimension time; now keep it to make it consistent with sequential version + allocate(dims(NDim+1)) + allocate(count(NDim+1)) + allocate(offset(NDim+1)) + allocate(sizes(NDim+1)) + + + ! arrange offset, count for each hyperslab + dims(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1 + dims(NDim+1) = 1 + + count(NDim+1) = 1 + count(1:NDim) = Length(1:NDim) + + offset(NDim+1) = 0 + offset(1:NDim) = PatchStart(1:NDim) - 1 + + + ! allocate the dataspace to write hyperslab data + + dimsfi = 0 + do i = 1, NDim + 1 + dimsfi(i) = count(i) + enddo + + ! create the memory space id + call h5screate_simple_f(NDim+1,count,dspace_id,hdf5err,count) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + + ! create file space + call h5screate_simple_f(NDim+1,dims,fspace_id,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + ! compact storage when the patch is equal to the whole domain + ! calculate the non-decomposed dataset size + + call h5tget_size_f(FieldType,dsetsize,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + do i =1,NDim + dsetsize = dsetsize*dims(i) + enddo + if(no_par.and.(dsetsize.le.CompDsetSize)) then + call h5pcreate_f(H5P_DATASET_CREATE_F,crp_list,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + call h5pset_layout_f(crp_list,0,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,& + hdf5err,crp_list) + call h5pclose_f(crp_list,hdf5err) + else + call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,hdf5err) + endif + + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + ! select the correct hyperslab for file space id + CALL h5sselect_hyperslab_f(fspace_id, H5S_SELECT_SET_F, offset, count & + ,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + ! Create property list for collective dataset write + CALL h5pcreate_f(H5P_DATASET_XFER_F, xfer_list, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + CALL h5pset_dxpl_mpio_f(xfer_list, H5FD_MPIO_COLLECTIVE_F& + ,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + + ! write the data in memory space to file space + CALL h5dwrite_f(dset_id,FieldType,XField,dimsfi,hdf5err,& + mem_space_id =dspace_id,file_space_id =fspace_id, & + xfer_prp = xfer_list) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + CALL h5pclose_f(xfer_list,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + + if(TimeIndex == 1) then + do i =1, MaxVars + if(DH%dsetids(i) == -1) then + DH%dsetids(i) = dset_id + DH%VarNames(i) = DataSetName + exit + endif + enddo + ! Only writing attributes when TimeIndex ==1 + call write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,& + NDim,dset_id,Status) + endif + + call h5sclose_f(fspace_id,hdf5err) + call h5sclose_f(dspace_id,hdf5err) + if(TimeIndex /= 1) then + call h5dclose_f(dset_id,hdf5err) + endif + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dims) + deallocate(count) + deallocate(offset) + deallocate(sizes) + return + endif + Status = WRF_NO_ERR + return +end subroutine HDF5IOWRITE + + +subroutine ext_phdf5_ioinit(SysDepInfo, Status) + + use wrf_phdf5_data + use HDF5 + implicit none + + include 'wrf_status_codes.h' + include 'mpif.h' + + CHARACTER*(*), INTENT(IN) :: SysDepInfo + integer, intent(out) :: status + integer :: hdf5err + + ! set up some variables inside the derived type + WrfDataHandles(1:WrfDataHandleMax)%Free = .true. + ! ? + WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' + WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' + + ! set up HDF5 global variables + call h5open_f(hdf5err) + if(hdf5err .lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + return +end subroutine ext_phdf5_ioinit + + +subroutine ext_phdf5_ioclose( DataHandle, Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use hdf5 + implicit none + include 'wrf_status_codes.h' + include 'mpif.h' + + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: stat + integer :: NVar + integer :: hdferr + integer :: table_length + integer :: i + integer(hid_t) :: dtype_id + integer :: obj_count + integer(hid_t),allocatable,dimension(:) :: obj_ids + character(len=100) :: buf + integer(size_t) :: name_size + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', 906 + call wrf_debug ( WARN , msg) + return + endif + + ! THE FOLLOWING section writes dimscale information to the data set,may be put into a subroutine + + ! check the file status, should be either open_for_read or opened_and_committed + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_HDF5_ERR_FILE_OPEN + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_HDF5_ERR_DRYRUN_CLOSE + write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + ! Handle dim. scale + ! STORE "Times" as the first element of the dimensional table + + DH%DIMTABLE(1)%dim_name = 'Time' + DH%DIMTABLE(1)%Length = DH%TimeIndex + DH%DIMTABLE(1)%unlimited = 1 + + do i =1,MaxTabDims + if(DH%DIMTABLE(i)%dim_name== NO_NAME) then + exit + endif + enddo + + table_length = i-1 + call store_table(DataHandle,table_length,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + ! call h5dclose_f(DH%TimesID,hdferr) + ! if(hdferr.lt.0) then + ! Status = WRF_HDF5_ERR_DATASET_CLOSE + ! write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + ! call wrf_debug ( WARN , msg) + ! return + ! endif + continue + else + Status = WRF_HDF5_ERR_BAD_FILE_STATUS + write(msg,*) 'Fatal hdf5err BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + ! close HDF5 APIs + do NVar = 1, MaxVars + if(DH%DsetIDs(NVar) /= -1) then + call h5dclose_f(DH%DsetIDs(NVar),hdferr) + if(hdferr .ne. 0) then + Status = WRF_HDF5_ERR_DATASET_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + enddo + + do i = 1, MaxTimes + if(DH%TgroupIDs(i) /= -1) then + call h5gclose_f(DH%TgroupIDs(i),hdferr) + if(hdferr .ne. 0) then + Status = WRF_HDF5_ERR_DATASET_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + enddo + + call h5gclose_f(DH%GroupID,hdferr) + if(hdferr .ne. 0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5gclose_f(DH%DimGroupID,hdferr) + if(hdferr .ne. 0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(Status /= WRF_NO_ERR) then + write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5fclose_f(DH%FileID,hdferr) + if(hdferr .ne. 0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(Status /= WRF_NO_ERR) then + write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call free_memory(DataHandle,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_OTHERS + write(msg,*) 'Warning Status = ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + DH%Free=.true. + return +end subroutine ext_phdf5_ioclose + + +subroutine ext_phdf5_ioexit(Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + include 'mpif.h' + + integer ,intent(out) :: Status + integer :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + integer :: i + integer :: stat + + + ! free memories + do i=1,WrfDataHandleMax + if(.not.WrfDataHandles(i)%Free) then + call free_memory(i,Status) + exit + endif + enddo + + if(Status /= WRF_NO_ERR) then + write(msg,*) 'free resources error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + CALL h5close_f(hdf5err) + + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + return +end subroutine ext_phdf5_ioexit + + + +!! This routine will set up everything to read HDF5 files +subroutine ext_phdf5_open_for_read(FileName,Comm,iocomm,SysDepInfo,DataHandle,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'mpif.h' + include 'wrf_status_codes.h' + + character*(*),intent(in) :: FileName + integer ,intent(in) :: Comm + integer ,intent(in) :: iocomm + character*(*),intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + type(wrf_phdf5_data_handle),pointer :: DH + integer ,intent(out) :: Status + + integer(hid_t) :: Fileid + integer(hid_t) :: tgroupid + integer(hid_t) :: dsetid + integer(hid_t) :: dspaceid + integer(hid_t) :: dtypeid + integer(hid_t) :: acc_plist + integer :: nmembers + integer :: submembers + integer :: tmembers + integer :: ObjType + character(len= 256) :: ObjName + character(len= 256) :: GroupName + + integer :: i,j + integer(hsize_t), dimension(7) :: data_dims + integer(hsize_t), dimension(1) :: h5dims + integer(hsize_t), dimension(1) :: h5maxdims + integer :: StoredDim + integer :: NumVars + + integer :: hdf5err + integer :: info,mpi_size,mpi_rank + character(Len = MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + + + ! Allocating the data handle + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5pcreate_f(H5P_FILE_ACCESS_F,acc_plist,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + info = MPI_INFO_NULL + CALL h5pset_fapl_mpio_f(acc_plist, comm, info, hdf5err) + ! call h5pset_fapl_mpiposix_f(acc_plist,comm,.false.,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + !close every objects when closing HDF5 file. + call h5pset_fclose_degree_f(acc_plist,H5F_CLOSE_STRONG_F,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! Open the file + call h5fopen_f(FileName,H5F_ACC_RDWR_F,Fileid,hdf5err & + ,acc_plist) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_FILE_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5pclose_f(acc_plist,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! Obtain the number of group + DH%FileID = Fileid + call h5gn_members_f(Fileid,"/",nmembers,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Retrieve group id and dimensional group id, the index must be from 0 + do i = 0, nmembers - 1 + call h5gget_obj_info_idx_f(Fileid,"/",i,ObjName,ObjType,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(ObjName=='DIM_GROUP') then + + call h5gopen_f(Fileid,"/DIM_GROUP",DH%DimGroupID,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! For WRF model, the first seven character must be DATASET + else if(ObjName(1:7)=='DATASET')then + + GroupName="/"//ObjName + call h5gopen_f(Fileid,GroupName,DH%GroupID,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5gn_members_f(FileID,GroupName,submembers,Status) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + do j = 0, submembers -1 + call h5gget_obj_info_idx_f(Fileid,GroupName,j,ObjName,ObjType,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call numtochar(j+1,tname) + tgroupname = 'TIME_STAMP_'//tname + + if(ObjName(1:17)==tgroupname) then + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5gn_members_f(DH%GroupID,tgroupname,tmembers,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dopen_f(tgroupid,"Times",dsetid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dget_space_f(dsetid,dspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5sget_simple_extent_ndims_f(dspaceid,StoredDim,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + data_dims(1) = h5dims(1) + call h5dget_type_f(dsetid,dtypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dread_f(dsetid,dtypeid,DH%Times(j+1),data_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimeIndex = 0 + call h5tclose_f(dtypeid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + endif + enddo + DH%NumberTimes = submembers + + ! the total member of HDF5 dataset. + DH%NumVars = tmembers*submembers + else + Status = WRF_HDF5_ERR_OTHERS + endif + enddo + + DH%FileStatus = WRF_FILE_OPENED_FOR_READ + DH%FileName = FileName + + ! obtain dimensional scale table + call retrieve_table(DataHandle,Status) + if(Status /= WRF_NO_ERR) then + return + endif + return + +end subroutine ext_phdf5_open_for_read + + +subroutine ext_phdf5_inquire_opened(DataHandle,FileName,FileStatus,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle) ,pointer :: DH + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + FileStatus = WRF_FILE_NOT_OPENED + return + endif + if(FileName /= DH%FileName) then + FileStatus = WRF_FILE_NOT_OPENED + else + FileStatus = DH%FileStatus + endif + Status = WRF_NO_ERR + return +end subroutine ext_phdf5_inquire_opened + + +subroutine ext_phdf5_inquire_filename(DataHandle,FileName,FileStatus,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + 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_phdf5_data_handle) ,pointer :: DH + + ! This line is added to make sure the wrong file will not be opened + 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, msg) + return + endif + + FileName = DH%FileName + FileStatus = DH%FileStatus + Status = WRF_NO_ERR + + return +end subroutine ext_phdf5_inquire_filename + + +! The real routine to read HDF5 files +subroutine ext_phdf5_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & + IOComm, DomainDesc, MemoryOrder, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd, & + PatchStart,PatchEnd,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + + implicit none + include 'wrf_status_codes.h' + 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) :: MemoryOrder + 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 + + type(wrf_phdf5_data_handle) ,pointer :: DH + integer :: NDim + integer(hid_t) :: GroupID + character (VarNameLen) :: VarName + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(NVarDims) :: StoredLen + integer, dimension(NVarDims) :: TemDataStart + 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 + integer(hsize_t),dimension(7) :: data_dims + integer(hsize_t),dimension(:) ,allocatable :: h5_dims + integer(hsize_t),dimension(:) ,allocatable :: h5_maxdims + integer(hsize_t),dimension(:) ,allocatable :: DataStart + integer(hsize_t),dimension(:) ,allocatable :: Datacount + integer(hid_t) :: tgroupid + integer(hid_t) :: dsetid + integer(hid_t) :: dtype_id + integer(hid_t) :: dmemtype_id + integer(hid_t) :: dspace_id + integer(hid_t) :: memspace_id + integer :: class_type + integer :: TimeIndex + logical :: flag + integer :: hdf5err + + character(Len = MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + + + ! FOR PARALLEL IO + integer :: mpi_rank + integer(hid_t) :: xfer_list + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_HDF5_ERR_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_HDF5_ERR_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + Status = WRF_HDF5_ERR_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! obtain TimeIndex + call GetDataTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + + ! obtain the absolute name of the group where the dataset is located + call numtochar(TimeIndex,tname) + tgroupname = 'TIME_STAMP_'//tname + + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dopen_f(tgroupid,Var,dsetid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Obtain the memory datatype + select case(FieldType) + case (WRF_REAL) + dmemtype_id = H5T_NATIVE_REAL + case (WRF_DOUBLE) + dmemtype_id = H5T_NATIVE_DOUBLE + case (WRF_INTEGER) + dmemtype_id = H5T_NATIVE_INTEGER + case (WRF_LOGICAL) + dmemtype_id = DH%EnumID + case default + Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND + write(msg,*) 'Warning BAD Memory Data type in ',__FILE__,',line',__LINE__ + call wrf_debug(WARN,msg) + return + end select + + ! Obtain the datatype + call h5dget_type_f(dsetid,dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! double check whether the Fieldtype is the type of the dataset + ! we may do the force coercion between real and double + call h5tget_class_f(dtype_id,class_type,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then + if ( class_type /= H5T_FLOAT_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(FieldType == WRF_CHARACTER) then + if(class_type /= H5T_STRING_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(FieldType == WRF_INTEGER) then + if(class_type /= H5T_INTEGER_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(FieldType == WRF_LOGICAL) then + if(class_type /= H5T_ENUM_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5tequal_f(dtype_id,DH%EnumID,flag,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(flag .EQV. .FALSE.) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_HDF5_ERR_BAD_DATA_TYPE + write(msg,*)'Fatal Non-WRF supported TYPE in ',__FILE__,', line',__LINE__ + call wrf_debug(FATAL, msg) + return + endif + + ! Obtain the dataspace, check whether the dataspace is within the range + ! transpose the memory order to the disk order + call h5dget_space_f(dsetid,dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call GetDim(MemoryOrder,NDim,Status) + + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + call ExtOrder(MemoryOrder,Length,Status) + + ! Obtain the rank of the dimension + call h5sget_simple_extent_ndims_f(dspace_id,StoredDim,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! From NetCDF implementation, only do error handling + if((NDim+1) /= StoredDim) then + Status = WRF_HDF5_ERR_BAD_VARIABLE_DIM + write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + allocate(h5_dims(StoredDim)) + allocate(h5_maxdims(StoredDim)) + allocate(DataStart(StoredDim)) + allocate(DataCount(StoredDim)) + + call h5sget_simple_extent_dims_f(dspace_id,h5_dims,h5_maxdims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! This part of code needs to be adjusted, currently use NetCDF convention + do j = 1, NDim + if(Length(j) > h5_dims(j)) then + Status = WRF_HDF5_ERR_READ_PAST_EOF + write(msg,*) 'Warning READ PAST EOF in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Length(j) <= 0) then + Status = WRF_HDF5_ERR_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + + ! create memspace_id + data_dims(1:NDim) = Length(1:NDim) + data_dims(NDim+1) = 1 + + call h5screate_simple_f(NDim+1,data_dims,memspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! DataStart can start from PatchStart. + TEMDataStart(1:NDim) = PatchStart(1:NDim)-1 + + if(MemoryOrder.NE.'0') then + call ExtOrder(MemoryOrder,TEMDataStart,Status) + endif + + DataStart(1:NDim) = TEMDataStart(1:NDim) + DataStart(NDim+1) = 0 + DataCount(1:NDim) = Length(1:NDim) + DataCount(NDim+1) = 1 + + ! transpose the data XField to Field + call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2) + StoredStart = 1 + StoredLen(1:NDim) = Length(1:NDim) + + ! the dimensional information inside the disk may be greater than + ! the dimension(PatchEnd-PatchStart); here we can speed up + ! the performance by using hyperslab selection + call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2) + call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2) + + ! di is for double type data + di = 1 + if(FieldType == WRF_DOUBLE) di = 2 + allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat) + + ! use hyperslab to only read this current timestamp + call h5sselect_hyperslab_f(dspace_id,H5S_SELECT_SET_F, & + DataStart,DataCount,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! read the data in this time stamp + call h5dread_f(dsetid,dmemtype_id,XField,data_dims,hdf5err, & + memspace_id,dspace_id,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , 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_HDF5_ERR_DEALLOCATION + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + call h5dclose_f(dsetid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + deallocate(h5_dims) + deallocate(h5_maxdims) + deallocate(DataStart) + deallocate(DataCount) + else + Status = WRF_HDF5_ERR_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_phdf5_read_field + +!! This routine essentially sets up everything to write HDF5 files +SUBROUTINE ext_phdf5_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) + + use wrf_phdf5_data + use HDF5 + use ext_phdf5_support_routines + implicit none + include 'mpif.h' + include 'wrf_status_codes.h' + + character*(*) ,intent(in) :: FileName + integer ,intent(in) :: Comm + integer ,intent(in) :: IOComm + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer(hid_t) :: file5_id + integer(hid_t) :: g_id + integer(hid_t) :: gdim_id + integer :: hdferr + integer :: i + integer :: stat + character (7) :: Buffer + integer :: VDimIDs(2) + character(Len = 512) :: groupname + + ! For parallel IO + integer(hid_t) :: plist_id + integer :: hdf5_comm,info,mpi_size,mpi_rank + + + call allocHandle(DataHandle,DH,Comm,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + DH%TimeIndex = 0 + DH%Times = ZeroDate + + CALL h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + info = MPI_INFO_NULL + + CALL h5pset_fapl_mpio_f(plist_id, comm, info, hdferr) + + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5fcreate_f(FileName,H5F_ACC_TRUNC_F,file5_id,hdferr & + ,access_prp = plist_id) + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_FILE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5pclose_f(plist_id,hdferr) + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = FileName + ! should add a check to see whether the file opened has been used by previous handles + DH%VarNames (1:MaxVars) = NO_NAME + DH%MDVarNames(1:MaxVars) = NO_NAME + + ! group name information is stored at SysDepInfo + groupname = "/"//SysDepInfo +! write(*,*) "groupname ",groupname + call h5gcreate_f(file5_id,groupname,g_id,hdferr) + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! create dimensional group id + call h5gcreate_f(file5_id,"/DIM_GROUP",gdim_id,hdferr) + if(hdferr .lt. 0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + DH%FileID = file5_id + DH%GroupID = g_id + DH%DIMGroupID = gdim_id + + return + +end subroutine ext_phdf5_open_for_write_begin + +! HDF5 doesnot need this stage, basically this routine +! just updates the File status. +SUBROUTINE ext_phdf5_open_for_write_commit(DataHandle, Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer(hid_t) :: enum_type + integer :: i + 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 , msg) + return + endif + + DH%FileStatus = WRF_FILE_OPENED_AND_COMMITTED + DH%first_operation = .TRUE. + return +end subroutine ext_phdf5_open_for_write_commit + +! The real routine to write HDF5 file +subroutine ext_phdf5_write_field(DataHandle,DateStr,Var,Field,FieldType,& + Comm,IOComm,DomainDesc,MemoryOrder, & + Stagger,DimNames,DomainStart,DomainEnd,& + MemoryStart,MemoryEnd,PatchStart,PatchEnd,& + Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(inout) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + 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 + + type(wrf_phdf5_data_handle) ,pointer :: DH + integer(hid_t) :: GroupID + integer :: NDim + character (VarNameLen) :: VarName + character (3) :: MemO + character (3) :: UCMemO + integer(hid_t) :: DsetID + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: DomLength + integer ,dimension(NVarDims+1) :: DimRank + character(256),dimension(NVarDims) :: RODimNames + integer ,dimension(NVarDims) :: StoredStart + integer ,dimension(:,:,:,:),allocatable :: XField + integer ,dimension(:,:,:,:),allocatable :: BUFFER! for logical field + integer :: stat + integer :: NVar + integer :: i,j,k,m,dim_flag + integer :: i1,i2,j1,j2,k1,k2 + integer :: x1,x2,y1,y2,z1,z2 + integer :: l1,l2,m1,m2,n1,n2 + integer(hid_t) :: XType + integer :: di + character (256) :: NullName + integer :: TimeIndex + integer ,dimension(NVarDims+1) :: temprank + logical :: NotFound + + + NullName = char(0) + dim_flag = 0 + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Examine here, Nov. 7th, 2003 + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + ! obtain group id and initialize the rank of dimensional attributes + GroupID = DH%GroupID + DimRank = -1 + + ! get the rank of the dimension based on MemoryOrder string(cleaver from NetCDF) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! get the dataset name and dimensional information of the data + VarName = Var + Length(1:NDim) = PatchEnd(1:NDim) - PatchStart(1:NDim) + 1 + DomLength(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1 + + ! Transposing the data order and dim. string order, store to RODimNames + call ExtOrder(MemoryOrder,Length,Status) + call ExtOrder(MemoryOrder,DomLength,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Map datatype from WRF to HDF5 + select case (FieldType) + case (WRF_REAL) + XType = H5T_NATIVE_REAL + case (WRF_DOUBLE) + Xtype = H5T_NATIVE_DOUBLE + case (WRF_INTEGER) + XType = H5T_NATIVE_INTEGER + case (WRF_LOGICAL) + XType = DH%EnumID + case default + Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND + return + end select + + ! HANDLE with dim. scale + ! handle dimensional scale data; search and store them in a table. + ! The table is one dimensional array of compound data type. One member of + ! the type is HDF5 string, representing the name of the dim(west_east_stag eg.) + ! Another number is the length of the dimension(west_east_stag = 31) + ! In this part, we will not store TIME but leave it at the end since the time + ! index won't be known until the end of the run; since all fields(HDF5 datasets) + ! have the same timestamp, writing it once should be fine. + + ! 1) create a loop for dimensions + call GetDataTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + if(TimeIndex == 1) then + + ! 2) get the dim. name, the first dim. is reserved for time, + call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + ! 3) get the dim. length + ! 4) inside the loop, search the table for dimensional name( table module) + ! IF FOUND, go to the next dimension, return the table dimensional rank + ! (For example, find west_east_stag in the table, the rank of "west_east_stag" + ! is 3; so return 3 for the array dimrank.) + ! in the table; so through the table, we can find the information + ! such as names, length of this dimension + ! 4.1) save the rank into an array for attribute + ! if not found, go to 5) + ! 4)' the first dimension is reserved for time, so table starts from j = 2 + ! + ! 5) NOT FOUND, inside the loop add the new dimensional information to the + ! table(table module) + + ! The first dimension of the field is always "time" and "time" + ! is also the first dimension of the "table". + k = 2 + DimRank(1) = 1 + + do i = 1,NDim + do j = 2,MaxTabDims + + ! Search for the table and see if we are at the end of the table + if (DH%DIMTABLE(j)%dim_name == NO_NAME) then + + ! Sometimes the RODimNames is NULLName or ''. If that happens, + ! we will search the table from the beginning and see + ! whether the name is FAKEDIM(the default name) and the + ! current length of the dim. is the same as that of FAKEDIM; + ! if yes, use this FAKEDIM for the current field dim. + + if(RODimNames(i) ==''.or. RODimNames(i)==NullName) then + do m = 2,j + if(DomLength(i)==DH%DIMTABLE(m)%Length.and. & + DH%DIMTABLE(m)%dim_name(1:7)=='FAKEDIM')then + DimRank(k) = m + k = k + 1 + dim_flag = 1 + exit + endif + enddo + ! No FAKEDIM and the same length dim. is found, + ! Add another dimension "FAKEDIM + j", with the length + ! as DomLength(i) + if (dim_flag == 1) then + dim_flag = 0 + else + RODimNames(i) = 'FAKEDIM'//achar(j+iachar('0')) + DH%DIMTABLE(j)%dim_name = RODimNames(i) + DH%DIMTABLE(j)%length = DomLength(i) + DimRank(k) = j + k = k + 1 + endif + ! no '' or NULLName is found, then assign this RODimNames + ! to the dim. table. + else + DH%DIMTABLE(j)%dim_name = RODimNames(i) + DH%DIMTABLE(j)%length = DomLength(i) + DimRank(k) = j + k = k + 1 + endif + exit + ! If we found the current dim. in the table already,save the rank + else if(DH%DIMTABLE(j)%dim_name == RODimNames(i)) then + ! remember the rank of dimensional scale + DimRank(k) = j + k = k + 1 + exit + else + continue + endif + enddo + enddo + endif ! end of timeindex of 1 + + ! 6) create an attribute array called DimRank to store the rank of the attribute. + ! This will be done in the HDF5IOWRITE routine + + ! 7) before the end of the run, 1) update time, 2) write the table to HDF5. + + ! get the index of l1,.......for writing HDF5 file. + 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 , msg) + return + endif + + ! Transpose the real data for tools people + 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 ) + + ! handle with logical data separately,because of not able to + ! map Fortran Logical type to C type + if(FieldType .eq. WRF_LOGICAL) then + allocate(BUFFER(di,x1:x2,y1:y2,z1:z2), STAT=stat) + do k =z1,z2 + do j = y1,y2 + do i = x1,x2 + do m = 1,di + if(XField(m,i,j,k)/= 0) then + BUFFER(m,i,j,k) = 1 + else + BUFFER(m,i,j,k) = 0 + endif + enddo + enddo + enddo + enddo + call HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart, DomainEnd & + ,PatchStart,PatchEnd, MemoryOrder & + ,FieldType,XType,groupID,TimeIndex,DimRank & + ,Var,BUFFER,Status) + deallocate(BUFFER,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 + else + call HDF5IOWRITE(DataHandle,Comm,DateStr,Length, DomainStart, DomainEnd & + ,PatchStart, PatchEnd, MemoryOrder & + ,FieldType,XType,groupID,TimeIndex,DimRank & + ,Var,XField,Status) + endif + + if (Status /= WRF_NO_ERR) then + return + endif + + deallocate(XField,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 + endif + + DH%first_operation = .FALSE. + + return + +end subroutine ext_phdf5_write_field + +! set_time routine is only used for open_for_read +subroutine ext_phdf5_set_time(DataHandle, DateStr, Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle) ,pointer :: DH + integer :: i + + ! check whether the Date length is equal to DateStrLen defined at wrf_phdf5_data + ! sees not enough, leave it for the time being 3/12/2003 + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', 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__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_HDF5_ERR_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_HDF5_ERR_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + Status = WRF_HDF5_ERR_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , 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_HDF5_ERR_TIME + return + endif + enddo + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_HDF5_ERR_BAD_FILE_STATUS + write(msg,*) 'FATAL BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_phdf5_set_time + +! get_next_time routine is only used for open_for_read +subroutine ext_phdf5_get_next_time(DataHandle, DateStr, Status) + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_phdf5_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 , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_HDF5_ERR_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_HDF5_ERR_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + Status = WRF_HDF5_ERR_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + if(DH%CurrentTime >= DH%NumberTimes) then + Status = WRF_HDF5_ERR_TIME + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + DH%CurrentTime = DH%CurrentTime +1 + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_HDF5_ERR_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_phdf5_get_next_time + +! get_previous_time routine +subroutine ext_phdf5_get_previous_time(DataHandle, DateStr, Status) + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_phdf5_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 , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_HDF5_ERR_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_HDF5_ERR_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + Status = WRF_HDF5_ERR_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , 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_HDF5_ERR_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_phdf5_get_previous_time + +subroutine ext_phdf5_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Name + integer ,intent(out) :: NDim + character*(*) ,intent(out) :: MemoryOrder + character*(*) ,intent(out) :: Stagger ! Dummy for now + integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd + integer ,intent(out) :: WrfType + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle) ,pointer :: DH + integer :: VarID + integer ,dimension(NVarDims) :: VDimIDs + integer :: j + integer :: hdf5err + integer :: XType + + character(Len =MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + integer(hid_t) :: tgroupid + integer(hid_t) :: dsetid + integer(hid_t) :: dspaceid + integer :: HDF5_NDim + integer(hsize_t),dimension(:),allocatable :: h5dims + integer(hsize_t),dimension(:),allocatable :: h5maxdims + + 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_HDF5_ERR_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_HDF5_ERR_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + Status = WRF_HDF5_ERR_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) then + if(Name /= "Times") then + call numtochar(1,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dopen_f(tgroupid,Name,dsetid,hdf5err) + if(hdf5err /= 0) then + STATUS = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dget_space_f(dsetid,dspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_ndims_f(dspaceid,HDF5_NDim,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call ext_phdf5_get_var_ti_char(DataHandle,"MemoryOrder",Name,MemoryOrder,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! get the rank of the dimension + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if((NDim+1)/= HDF5_NDim)then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call ext_phdf5_get_var_ti_char(DataHandle,"Stagger",Name,Stagger,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call ext_phdf5_get_var_ti_integer(DataHandle,"FieldType",Name,WrfType,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain Domain Start and Domain End. + allocate(h5dims(NDim+1)) + allocate(h5maxdims(NDim+1)) + call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + do j =1, NDim + DomainStart(j) = 1 + DomainEnd(j) = h5dims(j) + enddo + deallocate(h5dims) + deallocate(h5maxdims) + endif + return + endif + return +end subroutine ext_phdf5_get_var_info + +! obtain the domain time independent attribute with REAL type +subroutine ext_phdf5_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real ,intent(out) :: Data(*) + real ,dimension(:),allocatable :: buffer + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer :: rank + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + ! Do nothing unless it is time to read time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + attr_type = H5T_NATIVE_REAL + + call get_attrid(DataHandle,Element,h5_attrid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + allocate(buffer(OutCount)) + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + data(1:OutCount) = buffer(1:OutCount) + + deallocate(buffer) + + return + +end subroutine ext_phdf5_get_dom_ti_real + +! obtain the domain time independent attribute with REAL8 type +subroutine ext_phdf5_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + 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 + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer :: rank + integer :: hdf5err + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + + ! Do nothing unless it is time to read time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + attr_type = H5T_NATIVE_DOUBLE + call get_attrid(DataHandle,Element,h5_attrid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine ext_phdf5_get_dom_ti_double + + +! obtain the domain time independent attribute with integer type +subroutine ext_phdf5_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer :: rank + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + ! Do nothing unless it is time to read time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + attr_type = H5T_NATIVE_INTEGER + + call get_attrid(DataHandle,Element,h5_attrid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,Data,h5_dims,Status) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine ext_phdf5_get_dom_ti_integer + + +subroutine ext_phdf5_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical ,intent(out) :: Data(*) + integer, dimension(:),allocatable :: buffer + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer :: rank + integer(hid_t) :: attr_type + type(wrf_phdf5_data_handle),pointer :: DH + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Do nothing unless it is time to read time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + attr_type = DH%EnumID + call get_attrid(DataHandle,Element,h5_attrid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + + allocate(buffer(OutCount)) + + call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + Data(1:OutCount) = buffer(1:OutCount)==1 + deallocate(buffer) + return +end subroutine ext_phdf5_get_dom_ti_logical + +! obtain the domain time independent attribute with char type +subroutine ext_phdf5_get_dom_ti_char(DataHandle,Element,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(out) :: Data + integer :: Count + integer :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer :: rank + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + ! Do nothing unless it is time to read time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + attr_type = H5T_NATIVE_CHARACTER + + call get_attrid(DataHandle,Element,h5_attrid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine ext_phdf5_get_dom_ti_char + +subroutine ext_phdf5_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_phdf5_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_phdf5_put_dom_td_real + +subroutine ext_phdf5_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_phdf5_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_phdf5_put_dom_td_double + +subroutine ext_phdf5_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_phdf5_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_phdf5_put_dom_td_logical +subroutine ext_phdf5_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_phdf5_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_phdf5_put_dom_td_integer + +subroutine ext_phdf5_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_phdf5_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_phdf5_put_dom_td_char + +subroutine ext_phdf5_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_phdf5_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_phdf5_get_dom_td_real + +subroutine ext_phdf5_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_phdf5_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_phdf5_get_dom_td_double + + +subroutine ext_phdf5_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_phdf5_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_phdf5_get_dom_td_integer + +subroutine ext_phdf5_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_phdf5_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_phdf5_get_dom_td_logical + + +subroutine ext_phdf5_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_phdf5_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_phdf5_get_dom_td_char + +subroutine ext_phdf5_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len = 256) :: DataSetName + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: fspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(1) :: dims + integer :: hdf5err + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + dims(1) = Count + + ! Get the time index + call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! Set up dataspace,property list + call GetName(Element,Var,DataSetName,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,Count,& + dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5dwrite_f(dset_id,H5T_NATIVE_REAL,Data,dims,hdf5err,dspaceid,& + fspaceid) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dclose_f(dset_id,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5sclose_f(fspaceid,hdf5err) +! call h5gclose_f(tgroupid,hdf5err) + endif + return +end subroutine ext_phdf5_put_var_td_real + +subroutine ext_phdf5_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len = 256) :: DataSetName + real*8 ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: fspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(1) :: dims + integer :: hdf5err + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + + dims(1) = Count + ! Get the time index + call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! Set up dataspace,property list + call GetName(Element,Var,DataSetName,Status) + call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,Count,& + dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status) + + if(Status /= WRF_NO_ERR) then + return + endif + + call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE,Data,dims,hdf5err,dspaceid,& + fspaceid) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(dset_id,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5sclose_f(fspaceid,hdf5err) +! call h5gclose_f(tgroupid,hdf5err) + + endif + return +end subroutine ext_phdf5_put_var_td_double + +subroutine ext_phdf5_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len = 256) :: DataSetName + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: fspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(1) :: dims + integer :: hdf5err + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + + dims(1) = Count + ! Get the time index + call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! Set up dataspace,property list + call GetName(Element,Var,DataSetName,Status) + + call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER, & + Count,dset_id,dspaceid,fspaceid,tgroupid, & + TimeIndex, Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER,Data,dims,hdf5err,dspaceid,& + fspaceid) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(dset_id,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5sclose_f(fspaceid,hdf5err) +! call h5gclose_f(tgroupid,hdf5err) + + endif + return + +end subroutine ext_phdf5_put_var_td_integer + +subroutine ext_phdf5_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len = 256) :: DataSetName + logical ,intent(in) :: Data(*) + integer ,dimension(:),allocatable :: Buffer + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: fspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(1) :: dims + integer :: hdf5err + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + allocate(buffer(count)) + do i = 1, count + if(data(i).EQV..TRUE.) then + buffer(i) = 1 + else + buffer(i) = 0 + endif + enddo + + dims(1) = Count + ! Get the time index + call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! Set up dataspace,property list + call GetName(Element,Var,DataSetName,Status) + + call setup_wrtd_dataset(DataHandle,DataSetName,DH%EnumID, & + Count,dset_id,dspaceid, & + fspaceid,tgroupid,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5dwrite_f(dset_id,DH%EnumID,Buffer,dims,hdf5err,dspaceid,& + fspaceid) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dclose_f(dset_id,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5sclose_f(fspaceid,hdf5err) +! call h5gclose_f(tgroupid,hdf5err) + deallocate(Buffer) + endif + return +end subroutine ext_phdf5_put_var_td_logical + +subroutine ext_phdf5_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len = 256) :: DataSetName + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: fspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(1) :: dims + integer :: hdf5err + integer :: i + + integer :: str_id + integer :: str_len + integer :: count + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + + dims(1) = 1 + + ! Get the time index + call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! make str id + str_len = len_trim(Data) + call make_strid(str_len,str_id,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! assign count of the string to 1 + count = 1 + + ! Set up dataspace,property list + call GetName(Element,Var,DataSetName,Status) + if(Status /= WRF_NO_ERR) then + return + endif + call setup_wrtd_dataset(DataHandle,DataSetName,str_id, & + count,dset_id,dspaceid, & + fspaceid,tgroupid,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5dwrite_f(dset_id,str_id,Data,dims,hdf5err,dspaceid,& + fspaceid) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! close the string id + call h5tclose_f(str_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dclose_f(dset_id,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5sclose_f(fspaceid,hdf5err) +! call h5gclose_f(tgroupid,hdf5err) + + endif + return + +end subroutine ext_phdf5_put_var_td_char + +subroutine ext_phdf5_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len =256) :: DataSetName + real ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: memspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(7) :: data_dims + integer :: hdf5err + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! get the time-dependent attribute name + + call GetName(Element,Var,DataSetName,Status) + + ! get time index of the time-dependent attribute + call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! For parallel, find the group and obtain the attribute. + ! set up for reading the time-dependent attribute + call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,TimeIndex,& + Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,& + Status) + if(Status /= WRF_NO_ERR) then + return + endif + + data_dims(1) = OutCount + + ! read the dataset + call h5dread_f(dset_id,H5T_NATIVE_REAL,data,data_dims,hdf5err, & + memspaceid,dspaceid,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5sclose_f(memspaceid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroupid,hdf5err) + endif + +end subroutine ext_phdf5_get_var_td_real + +subroutine ext_phdf5_get_var_td_double(DataHandle,Element,DateStr,Var,Data,& + Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len =256) :: DataSetName + real*8 ,intent(out) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: memspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(7) :: data_dims + integer :: hdf5err + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! get the time-dependent attribute name + call GetName(Element,Var,DataSetName,Status) + + ! get time index of the time-dependent attribute + call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! set up for reading the time-dependent attribute + call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,TimeIndex,& + Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,& + Status) + if(Status /= WRF_NO_ERR) then + return + endif + + data_dims(1) = OutCount + + ! read the dataset + call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,data,data_dims,hdf5err, & + memspaceid,dspaceid,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sclose_f(memspaceid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroupid,hdf5err) + + endif + +end subroutine ext_phdf5_get_var_td_double + +subroutine ext_phdf5_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,& + Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len =256) :: DataSetName + integer ,intent(out) :: Data(*) + integer ,intent(in) :: Count + INTEGER ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: memspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(7) :: data_dims + integer :: hdf5err + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! get the time-dependent attribute name + call GetName(Element,Var,DataSetName,Status) + + ! get time index of the time-dependent attribute + call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! set up for reading the time-dependent attribute + call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER,TimeIndex,& + Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,& + Status) + if(Status /= WRF_NO_ERR) then + return + endif + + data_dims(1) = OutCount + + ! read the dataset + call h5dread_f(dset_id,H5T_NATIVE_INTEGER,data,data_dims,hdf5err, & + memspaceid,dspaceid,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sclose_f(memspaceid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroupid,hdf5err) + endif +end subroutine ext_phdf5_get_var_td_integer + +subroutine ext_phdf5_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,& + Count,OutCount,Status) + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len =256) :: DataSetName + logical ,intent(out) :: Data(*) + integer, dimension(:),allocatable :: Buffer + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: memspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(7) :: data_dims + integer :: hdf5err + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! get the time-dependent attribute name + call GetName(Element,Var,DataSetName,Status) + + ! get time index of the time-dependent attribute + call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! set up for reading the time-dependent attribute + call setup_rdtd_dataset(DataHandle,DataSetName,DH%EnumID,TimeIndex,& + Count,OutCount,dset_id,memspaceid,dspaceid,& + tgroupid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + data_dims(1) = OutCount + ! read the dataset + + allocate(Buffer(OutCount)) + call h5dread_f(dset_id,DH%EnumID,buffer,data_dims,hdf5err, & + memspaceid,dspaceid,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + data(1:OutCount) = buffer(1:OutCount) == 1 + deallocate(buffer) + call h5sclose_f(memspaceid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroupid,hdf5err) + endif + +end subroutine ext_phdf5_get_var_td_logical + +subroutine ext_phdf5_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character(len =256) :: DataSetName + character*(*) ,intent(out) :: Data + integer :: Count + integer :: OutCount + integer ,intent(out) :: Status + type(wrf_phdf5_data_handle),pointer :: DH + integer :: TimeIndex + integer(hid_t) :: dset_id + integer(hid_t) :: dspaceid + integer(hid_t) :: memspaceid + integer(hid_t) :: tgroupid + integer(hsize_t),dimension(7) :: data_dims + integer :: hdf5err + + integer(hid_t) :: str_id + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! check whether the DateStr is the correct length + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + ! get the time-dependent attribute name + call GetName(Element,Var,DataSetName,Status) + + ! get time index of the time-dependent attribute + call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! set up for reading the time-dependent attribute + str_id = H5T_NATIVE_CHARACTER + Count = 1 + call setup_rdtd_dataset(DataHandle,DataSetName,str_id,TimeIndex,& + Count,OutCount,dset_id,memspaceid,dspaceid,& + tgroupid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + data_dims(1) = Count + + ! read the dataset + call h5dread_f(dset_id,str_id,data,data_dims,hdf5err, & + memspaceid,dspaceid,H5P_DEFAULT_F) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5sclose_f(memspaceid,hdf5err) + call h5sclose_f(dspaceid,hdf5err) + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroupid,hdf5err) + endif + +end subroutine ext_phdf5_get_var_td_char + +! obtain the variable time independent attribute with REAL type +subroutine ext_phdf5_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + 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 + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + attr_type = H5T_NATIVE_REAL + + call get_attrid(DataHandle,Element,h5_attrid,Status,Var) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine ext_phdf5_get_var_ti_real + +! obtain the variable time independent attribute with REAL8 type +subroutine ext_phdf5_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + 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 + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + attr_type = H5T_NATIVE_DOUBLE + + call get_attrid(DataHandle,Element,h5_attrid,Status,Var) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +end subroutine ext_phdf5_get_var_ti_double + +! obtain the variable time independent attribute with integer type +subroutine ext_phdf5_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + 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 + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + attr_type = H5T_NATIVE_INTEGER + + call get_attrid(DataHandle,Element,h5_attrid,Status,Var) + if (status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return + +end subroutine ext_phdf5_get_var_ti_integer + +! obtain the variable time independent attribute with logical type +subroutine ext_phdf5_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical ,intent(out) :: Data(*) + integer, dimension(:),allocatable :: Buffer + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hid_t) :: attr_type + type(wrf_phdf5_data_handle),pointer :: DH + integer(hsize_t), dimension(7) :: h5_dims + integer :: hdf5err + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + attr_type = DH%EnumID + call get_attrid(DataHandle,Element,h5_attrid,Status,Var) + if(Status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (status /= WRF_NO_ERR) then + return + endif + + h5_dims(1) = OutCount + + allocate(buffer(OutCount)) + call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + Data(1:OutCount) = buffer(1:OutCount)==1 + deallocate(buffer) + return + +end subroutine ext_phdf5_get_var_ti_logical + + +! obtain the domain variable independent attribute with Char type +subroutine ext_phdf5_get_var_ti_char(DataHandle,Element,Var,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + use get_attrid_routine + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + integer ,intent(out) :: Status + + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hid_t) :: attr_type + integer(hsize_t), dimension(7) :: h5_dims + integer :: Count + integer :: OutCount + integer :: hdf5err + + attr_type = H5T_NATIVE_CHARACTER + call get_attrid(DataHandle,Element,h5_attrid,Status,Var) + if (status /= WRF_NO_ERR) then + return + endif + + call check_type(DataHandle,attr_type,h5_attrid,Status) + if (status /= WRF_NO_ERR) then + return + endif + + call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,& + Count,OutCount,Status) + if (status /= WRF_NO_ERR) then + return + endif + + if(OutCount /= 1) then + Status = WRF_HDF5_ERR_ATTRIBUTE_OTHERS + endif + h5_dims(1) = OutCount + call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return + +end subroutine ext_phdf5_get_var_ti_char + + +! write the domain time independent attribute with real type +subroutine ext_phdf5_put_dom_ti_real(DataHandle,Element,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + character(VarNameLen) :: var + + ! Do nothing unless it is time to write time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + var = 'DUMMY' + routine_type = 'DOM' + routine_atype = WRF_REAL + adata_dims(1) = Count + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_dom_ti_real + +! write the domain time independent attribute with integer type +subroutine ext_phdf5_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + character(VarNameLen) :: var + + ! Do nothing unless it is time to write time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + var = 'DUMMY' + routine_type = 'DOM' + routine_atype = WRF_INTEGER + adata_dims(1) = Count + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_dom_ti_integer + +! write the domain time independent attribute with double type +subroutine ext_phdf5_put_dom_ti_double(DataHandle,Element,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8 ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + character(VarNameLen) :: var + + ! Do nothing unless it is time to write time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + var = 'DUMMY' + routine_type = 'DOM' + routine_atype = WRF_DOUBLE + adata_dims(1) = Count + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + return + +end subroutine ext_phdf5_put_dom_ti_double + +! write the domain time independent attribute with logical type +subroutine ext_phdf5_put_dom_ti_logical(DataHandle,Element,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical ,intent(in) :: Data(*) + integer ,dimension(:),allocatable :: Buffer + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer :: i + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + character(VarNameLen) :: var + + ! Do nothing unless it is time to write time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + var = 'DUMMY' + routine_type = 'DOM' + routine_atype = WRF_LOGICAL + adata_dims(1) = Count + + allocate(Buffer(Count)) + + do i = 1,Count + if(Data(i) .EQV. .TRUE.) then + Buffer(i) = 1 + else + Buffer(i) = 0 + endif + enddo + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status,DataHandle) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + deallocate(Buffer) + +end subroutine ext_phdf5_put_dom_ti_logical + + +! write the domain time independent attribute with char type +subroutine ext_phdf5_put_dom_ti_char(DataHandle,Element,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + +!!!! Need more work. + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Data + integer :: Count ! always 1 for char + integer ,intent(out) :: Status + + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 1 ! is a string type + integer(hid_t) :: hdf5err + integer :: len_str + character(VarNameLen) :: var + character(1) :: RepData =' ' + + ! Do nothing unless it is time to write time-independent domain metadata. + IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN + Status = WRF_NO_ERR + return + ENDIF + + Count = 1 + var = 'DUMMY' + routine_type = 'DOM' + routine_atype = WRF_CHARACTER + adata_dims(1) = Count + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! This part may need more work, a special case is that the length of the + ! string may be 0, HDF5 cannot handle 0 length string(?),so set the length + ! to 1 + + len_str = len_trim(Data) + if(len_str == 0) then + len_str = 1 + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(len_trim(Data) == 0) then + + call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + + call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_dom_ti_char + +! write the variable time independent attribute with real type +subroutine ext_phdf5_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + + routine_type = 'VAR' + routine_atype = WRF_REAL + adata_dims(1) = Count + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! The following two checks must be here to avoid duplicating attributes + if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_NO_ERR + return + endif + if(DH%TimeIndex > 1) then + Status = WRF_NO_ERR + return + endif + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_var_ti_real + +! write the variable time independent attribute with double type +subroutine ext_phdf5_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8 ,intent(in) :: Data(*) + character*(*) ,intent(in) :: Var + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + routine_type = 'VAR' + routine_atype = WRF_DOUBLE + adata_dims(1) = Count + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_NO_ERR + return + endif + if(DH%TimeIndex > 1) then + Status = WRF_NO_ERR + return + endif + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return + +end subroutine ext_phdf5_put_var_ti_double + +! write the variable time independent attribute with integer type +subroutine ext_phdf5_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer ,intent(in) :: Data(*) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + routine_type = 'VAR' + routine_atype = WRF_INTEGER + adata_dims(1) = Count + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! The following two checks must be here to avoid duplicating attributes + if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_NO_ERR + return + endif + if(DH%TimeIndex > 1) then + Status = WRF_NO_ERR + return + endif + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_var_ti_integer + + +! write the variable time independent attribute with logical type +subroutine ext_phdf5_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical ,intent(in) :: Data(*) + integer ,dimension(:),allocatable :: Buffer + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + integer :: i + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 0 ! not a string type + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + routine_type = 'VAR' + routine_atype = WRF_LOGICAL + adata_dims(1) = Count + + allocate(Buffer(Count)) + + do i = 1,Count + if(Data(i) .EQV. .TRUE.) then + Buffer(i) = 1 + else + Buffer(i) = 0 + endif + enddo + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! The following two checks must be here to avoid duplicating attributes + if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_NO_ERR + return + endif + + if(DH%TimeIndex > 1) then + Status = WRF_NO_ERR + return + endif + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + + call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(buffer) + return + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_var_ti_logical + +! write the variable time independent attribute with char type +subroutine ext_phdf5_put_var_ti_char(DataHandle,Element,Var,Data,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Data + character*(*) ,intent(in) :: Var + integer :: Count + integer ,intent(out) :: Status + integer(hid_t) :: h5_objid + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_aspaceid + integer(hid_t) :: h5_attrid + integer(hsize_t), dimension(7) :: adata_dims + + character*3 :: routine_type + integer :: routine_atype + integer :: str_flag = 1 ! IS string type + integer(hid_t) :: hdf5err + integer :: len_str + character(1) :: RepData = ' ' + type(wrf_phdf5_data_handle),pointer :: DH + + Count = 1 + routine_type = 'VAR' + routine_atype = WRF_CHARACTER + adata_dims(1) = Count + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! The following two checks must be here to avoid duplicating attributes + if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_NO_ERR + return + endif + + if(DH%TimeIndex > 1) then + Status = WRF_NO_ERR + return + endif + + call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + len_str = len_trim(Data) + + if(len_str .eq. 0) then + len_str = 1 + endif + + call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(len_trim(Data) == 0) then + + call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + return +end subroutine ext_phdf5_put_var_ti_char + + + +! This routine will retrieve the dimensional table, should be useful +! for tool developers. + +subroutine retrieve_table(DataHandle,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use hdf5 + implicit none + include 'wrf_status_codes.h' + + character*256,dimension(MaxTabDims) :: dim_name + integer,dimension(:),allocatable :: length + integer,dimension(:),allocatable :: unlimited + integer, intent(in) :: DataHandle + integer, intent(out) :: Status + + integer(hid_t) :: dset_id + integer(hid_t) :: dataspace_id + integer(hid_t) :: dtstr_id + integer(hid_t) :: dt1_id + integer(hid_t) :: dtint1_id + integer(hid_t) :: dtint2_id + integer(size_t) :: type_sizei + integer(size_t) :: offset + integer :: table_length + integer(size_t) :: string_size + integer(hsize_t),dimension(7) :: data_dims + integer(hsize_t) :: table_size + integer :: i + integer :: hdf5err + + type(wrf_phdf5_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 , msg) + return + endif + + call h5dopen_f(DH%DimGroupID,"h5dim_table",dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dget_space_f(dset_id,dataspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_npoints_f(dataspace_id,table_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + data_dims(1) = table_size + allocate(length(table_size)) + allocate(unlimited(table_size)) + + + ! the name of the dimension + call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + string_size = 256 + call h5tset_size_f(dtstr_id,string_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,string_size,dt1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dt1_id,"dim_name",offset,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dread_f(dset_id,dt1_id,dim_name,data_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + ! the length of the dimension + call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dread_f(dset_id,dtint1_id,length,data_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + + ! the unlimited info. of the dimension + call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dread_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_READ + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + ! Store the information to the table array + do i =1,table_size + DH%DIMTABLE(i)%dim_name = dim_name(i) + DH%DIMTABLE(i)%length = length(i) + DH%DIMTABLE(i)%unlimited = unlimited(i) + enddo + + deallocate(length) + deallocate(unlimited) + + call h5tclose_f(dtint1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtint2_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dt1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sclose_f(dataspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + return +end subroutine retrieve_table + +! store(write) the dimensional table into the HDF5 file +subroutine store_table(DataHandle,table_length,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use hdf5 + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer, intent(in) :: table_length + integer, intent(out) :: Status + + type(wrf_phdf5_data_handle),pointer :: DH + + integer(hid_t) :: group_id + integer(hid_t) :: dset_id + integer(hid_t) :: dtype_id + integer(hid_t) :: dtstr_id + integer(hid_t) :: dtstrm_id + integer(hid_t) :: dtint1_id + integer(hid_t) :: dtint2_id + integer(hid_t) :: plist_id + integer(size_t) :: type_size + integer(size_t) :: type_sizes + integer(size_t) :: type_sizei + integer(size_t) :: offset + character*256 ,dimension(MaxTabDims) :: dim_name + integer ,dimension(:),allocatable :: length + integer ,dimension(:),allocatable :: unlimited + integer(hid_t) :: dspace_id + integer(hsize_t) ,dimension(1) :: table_dims + integer :: table_rank + integer(hsize_t) ,dimension(7) :: data_dims + integer :: i,j + integer :: hdf5err + + data_dims(1) = table_length + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call create_h5filetype(dtype_id,Status) + if(Status /= WRF_NO_ERR) then + return + endif + + ! obtain group id + group_id = DH%DimGroupID + + ! create data space + table_rank = 1 + table_dims(1) = table_length + + call h5screate_simple_f(table_rank,table_dims,dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain the data + allocate(length(table_length)) + allocate(unlimited(table_length)) + + do i =1, table_length + length(i) = DH%DIMTABLE(i)%length + unlimited(i) = DH%DIMTABLE(i)%unlimited + enddo + + do i=1,table_length + do j=1,256 + dim_name(i)(j:j)=DH%DIMTABLE(i)%dim_name(j:j) + enddo + enddo + + ! under dimensional group + call h5dcreate_f(group_id,"h5dim_table",dtype_id,dspace_id,& + dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + ! create memory types + call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + ! FOR string, it needs extra handling + call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + type_size = 256 + + call h5tset_size_f(dtstr_id, type_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tget_size_f(dtstr_id, type_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,type_size,dtstrm_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dtstrm_id,"dim_name",offset,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + offset = 0 + call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + ! write data by fields in the datatype,but first create a property list + + call h5pcreate_f(H5P_DATASET_XFER_F,plist_id, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5pset_preserve_f(plist_id,.TRUE.,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_PROPERTY_LIST + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dwrite_f(dset_id,dtstrm_id,dim_name,data_dims,hdf5err,& + xfer_prp = plist_id) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dwrite_f(dset_id,dtint1_id,length,data_dims,hdf5err,& + xfer_prp = plist_id) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + call h5dwrite_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err,& + xfer_prp = plist_id) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(length) + deallocate(unlimited) + return + endif + + deallocate(length) + deallocate(unlimited) + + ! release resources + + call h5tclose_f(dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtstrm_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtint1_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtint2_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tclose_f(dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5pclose_f(plist_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sclose_f(dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine store_table + + +subroutine free_memory(DataHandle,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + include 'mpif.h' + + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + integer :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + integer :: i + integer :: stat + real*8 :: timeaw,timebw + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(DH%Free) then + Status = WRF_HDF5_ERR_OTHERS + write(msg,*) '',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + deallocate(DH%Times, STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DIMTABLE, STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_DEALLOCATION + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%MDDsetIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + deallocate(DH%DsetIDs, STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + 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_HDF5_ERR_DEALLOCATION + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine free_memory + +subroutine write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,& + NDim,dset_id,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'mpif.h' + include 'wrf_status_codes.h' + + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(in) :: WrfDType + integer,dimension(*) ,intent(in) :: DimRank + + integer ,intent(in) :: NDim + + integer(hid_t) ,intent(in) :: dset_id + integer ,intent(out) :: Status + + character (3) :: Mem0 + character (3) :: UCMem0 + type(wrf_phdf5_data_handle) ,pointer :: DH + + ! attribute defination + integer(hid_t) :: dimaspace_id ! DimRank dataspace id + integer(hid_t) :: dimattr_id ! DimRank attribute id + integer(hsize_t) ,dimension(1) :: dim_space + + integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute + integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder + integer(hid_t) :: h5_attrid ! for fieldtype,memorder + integer(hsize_t), dimension(7) :: adata_dims + integer :: routine_atype + integer, dimension(:),allocatable :: dimrank_data + integer :: hdf5err + integer :: j + + ! For time function + real*8 :: timebw + real*8 :: timeaw + integer :: total_ele + + ! + ! write dimensional rank attribute. This is the temporary fix for dim. scale + ! the first dimension is always time + allocate(dimrank_data(NDim+1)) + do j =1, NDim+1 + dimrank_data(j) = DimRank(j) + enddo + + dim_space(1) = NDim+1 + adata_dims(1) = NDim+1 + call h5screate_simple_f(1,dim_space,dimaspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dimrank_data) + return + endif + + call h5acreate_f(dset_id,'H5_DimRank',H5T_NATIVE_INTEGER,dimaspace_id, & + dimattr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dimrank_data) + return + endif + + call h5awrite_f(dimattr_id,H5T_NATIVE_INTEGER,dimrank_data,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + deallocate(dimrank_data) + return + endif + deallocate(dimrank_data) + + ! close space and attribute id + call clean_phdf5_attrids(H5T_NATIVE_INTEGER,dimaspace_id,dimattr_id,0,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + ! Write memory order and FieldType attribute, both MemoryOrder and FieldType are 1 element + adata_dims(1) = 1 + + ! output memoryorder attribute + call reorder(MemoryOrder,Mem0) + call uppercase(Mem0,UCMem0) + + routine_atype = WRF_CHARACTER + + ! The size of memoryorder string is always MemOrdLen + call create_phdf5_adtypeid(h5_atypeid,routine_atype,MemOrdLen,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Count for string attribute is always 1 + call create_phdf5_adspaceid(1,1,h5_aspaceid,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5acreate_f(dset_id,'MemoryOrder',h5_atypeid,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,h5_atypeid,UCMem0,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,1,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! output fieldtype attribute + call create_phdf5_adspaceid(1,1,h5_aspaceid,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5acreate_f(dset_id,'FieldType',H5T_NATIVE_INTEGER,h5_aspaceid, & + h5_attrid, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5awrite_f(h5_attrid,H5T_NATIVE_INTEGER,WrfDType,adata_dims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call clean_phdf5_attrids(H5T_NATIVE_INTEGER,h5_aspaceid,h5_attrid,0,Status) + if(Status.ne.WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +end subroutine write_hdf5_attributes diff --git a/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90 b/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90 new file mode 100644 index 00000000..2eb0cb29 --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90 @@ -0,0 +1,1013 @@ +!*************************************************************************** +!* The HDF5 WRF IO module was written by the the HDF Group at NCSA, the * +!* National Center for Supercomputing Applications. * +!* HDF Group * +!* National Center for Supercomputing Applications * +!* University of Illinois at Urbana-Champaign * +!* 605 E. Springfield, Champaign IL 61820 * +!* http://hdf.ncsa.uiuc.edu/ * +!* * +!* Copyright 2004 by the Board of Trustees, University of Illinois, * +!* * +!* Redistribution or use of this IO module, with or without modification, * +!* is permitted for any purpose, including commercial purposes. * +!* * +!* This software is an unsupported prototype. Use at your own risk. * +!* http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS * +!* * +!* This work was funded by the MEAD expedition at the National Center * +!* for Supercomputing Applications, NCSA. For more information see: * +!* http://www.ncsa.uiuc.edu/expeditions/MEAD * +!* * +!* * +!****************************************************************************/ + +module get_attrid_routine + + Interface get_attrid + module procedure get_attrid + end interface + +contains + + subroutine get_attrid(DataHandle,Element,h5_attrid,Status,VAR) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + character*(*) ,intent(in) :: Element + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(out) :: h5_attrid + integer(hid_t) :: dset_id + integer ,intent(out) :: Status + character*(*) ,intent(in),optional :: VAR + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + character(Len = MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + integer(hid_t) :: tgroup_id + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(present(VAR)) then + call numtochar(1,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroup_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dopen_f(tgroup_id,VAR,dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5aopen_name_f(dset_id,Element,h5_attrid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroup_id,hdf5err) + else + call h5aopen_name_f(DH%GroupID,Element,h5_attrid,hdf5err) + write(*,*) "Element ",Element + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + return + end subroutine get_attrid +end module get_attrid_routine + +subroutine create_phdf5_objid(DataHandle,obj_id,routine_type,var,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(out) :: obj_id + character*3 ,intent(in) :: routine_type + character*(*) ,intent(in) :: var + integer ,intent(out) :: Status + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + + 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(routine_type == 'DOM') then + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + obj_id = DH%GroupID + endif + + else if(routine_type == 'VAR') then + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + do i = 1, MaxVars + if(DH%VarNames(i) == var) then + obj_id = DH%dsetids(i) + exit + endif + enddo + endif + + else + Status = WRF_HDF5_ERR_DATA_ID_NOTFOUND + write(msg,*) 'CANNOT FIND DATASET ID of the attribute in',__FILE__,& + ', line',__LINE__ + endif + + return +end subroutine create_phdf5_objid + + +subroutine create_phdf5_adtypeid(h5_atypeid,routine_datatype,Count,Status,DataHandle) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer(hid_t) ,intent(out) :: h5_atypeid + integer ,intent(in) :: routine_datatype + integer ,intent(in) :: Count + integer ,intent(out) :: Status + integer(hid_t) :: hdf5err + integer, intent(in), optional :: DataHandle + integer(size_t) :: count_size + + type(wrf_phdf5_data_handle),pointer :: DH + + if(routine_datatype == WRF_LOGICAL)then + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + endif + + select case(routine_datatype) + case (WRF_REAL) + h5_atypeid = H5T_NATIVE_REAL + case (WRF_DOUBLE) + h5_atypeid = H5T_NATIVE_DOUBLE + case (WRF_INTEGER) + h5_atypeid = H5T_NATIVE_INTEGER + case (WRF_LOGICAL) + h5_atypeid = DH%EnumID + case (WRF_CHARACTER) + + call h5tcopy_f(H5T_NATIVE_CHARACTER,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + count_size = count + call h5tset_size_f(h5_atypeid,count_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tset_strpad_f(h5_atypeid,H5T_STR_SPACEPAD_F,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + case default + Status = WRF_HDF5_ERR_DATATYPE + return + end select + + Status = WRF_NO_ERR + + return +end subroutine create_phdf5_adtypeid + +subroutine create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + + use wrf_phdf5_data + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer ,intent(in) :: Count + integer ,intent(in) :: str_flag + integer ,intent(out) :: Status + + integer(hsize_t) , dimension(1) :: adims + integer(hid_t) :: hdf5err + integer(hid_t) ,intent(out) :: h5_aspaceid + integer :: arank = 1 + + ! if string, count is always 1 + if(str_flag == 1) then + adims(1) = 1 + call h5screate_simple_f(arank,adims,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + else + adims(1) = Count + call h5screate_simple_f(arank,adims,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + endif + + Status = WRF_NO_ERR + + return +end subroutine create_phdf5_adspaceid + + +subroutine clean_phdf5_attrids(h5_attr_typeid,h5_space_typeid, & + h5_attrid,str_flag,Status) + + use wrf_phdf5_data + use HDF5 + implicit none + include 'wrf_status_codes.h' + integer ,intent(out) :: Status + integer(hid_t) ,intent(in) :: h5_attr_typeid + integer(hid_t) ,intent(in) :: h5_space_typeid + integer(hid_t) ,intent(in) :: h5_attrid + integer ,intent(in) :: str_flag + integer :: hdf5err + + if(str_flag == 1) then + call h5tclose_f(h5_attr_typeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + + call h5sclose_f(h5_space_typeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5aclose_f(h5_attrid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + + return + +end subroutine clean_phdf5_attrids + + +subroutine create_h5filetype(dtype_id,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use hdf5 + implicit none + include 'wrf_status_codes.h' + + integer(hid_t),intent(out) :: dtype_id + integer(hid_t) :: dtstr_id + integer(size_t) :: type_size + integer(size_t) :: type_sizes + integer(size_t) :: type_sizei + integer(size_t) :: offset + integer, intent(out) :: Status + integer(hid_t) :: hdf5err + + call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + type_size = 256 + + call h5tset_size_f(dtstr_id,type_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_size_f(dtstr_id,type_sizes,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + type_size = type_sizes + 2*type_sizei + + call h5tcreate_f(H5T_COMPOUND_F,type_size,dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + offset = 0 + + call h5tinsert_f(dtype_id,"dim_name",offset,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset = offset + type_sizes + call h5tinsert_f(dtype_id,"dim_length",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset = offset + type_sizei + + call h5tinsert_f(dtype_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5tclose_f(dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + return +end subroutine create_h5filetype + +! check whether two types are equal, attr_type and h5_attrid +subroutine check_type(DataHandle,attr_type,h5_attrid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(in) :: attr_type + integer(hid_t) ,intent(in) :: h5_attrid + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_classid + integer(hid_t) :: h5_wrfclassid + logical :: flag + integer :: hdf5err + type(wrf_phdf5_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 , msg) + return + endif + + call h5aget_type_f(h5_attrid,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(h5_atypeid,h5_classid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(attr_type,h5_wrfclassid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if((h5_classid==H5T_STRING_F).AND.& + (attr_type==H5T_NATIVE_CHARACTER)) then + flag = .TRUE. + else + if(h5_classid .NE. h5_wrfclassid) then + flag = .FALSE. + else + flag = .TRUE. + endif + endif + + if(flag .EQV. .FALSE.) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + return + endif + + Status = WRF_NO_ERR + return +end subroutine check_type + + +subroutine retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(in) :: h5_attrid + integer(hid_t) ,intent(out) :: h5_atypeid + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_aspaceid + integer :: typeclass + integer :: hdf5err + integer :: rank + integer(hsize_t) :: npoints + + type(wrf_phdf5_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 , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + call h5aget_type_f(h5_attrid,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5aget_space_f(h5_attrid,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_ndims_f(h5_aspaceid,rank,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(rank > 1) then + ! The rank can be either 0 or 1 + Status = WRF_HDF5_ERR_OTHERS + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_npoints_f(h5_aspaceid,npoints,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + OutCount = npoints + call h5tget_class_f(h5_atypeid,typeclass,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if((npoints > Count).and.(typeclass.ne.H5T_STRING_F)) then + OutCount = Count + Status = WRF_HDF5_ERR_MORE_DATA_IN_FILE + else + OutCount = npoints + endif + endif + return +end subroutine retrieve_ti_info + +subroutine setup_wrtd_dataset(DataHandle,DataSetName,dtypeid,countmd,& + dsetid,dspace_id,fspace_id,tgroupid, & + TimeIndex,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DataSetName + integer(hid_t) ,intent(in) :: dtypeid + integer ,intent(in) :: countmd + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dsetid + integer(hid_t) ,intent(out) :: dspace_id + integer(hid_t) ,intent(out) :: fspace_id + integer(hid_t) ,intent(out) :: tgroupid + integer(hid_t) :: crp_list + integer ,intent(out) :: Status + + integer(hsize_t) ,dimension(1) :: sizes + integer(hsize_t) ,dimension(1) :: chunk_dims + integer(hsize_t) ,dimension(1) :: dims + integer(hsize_t) ,dimension(1) :: hdf5_maxdims + integer(hsize_t) ,dimension(1) :: offset + integer(hsize_t) ,dimension(1) :: count + type(wrf_phdf5_data_handle),pointer :: DH + + character(Len = MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + integer :: hdf5err + + + ! get datahandle + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + chunk_dims(1) = countmd + + dims(1) = countmd + + count(1) = countmd + + offset(1) = 0 + + sizes(1) = countmd + + hdf5_maxdims(1) = countmd + + ! create the memory space id + call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! create file space(for parallel module, each dataset per time step) + call h5screate_simple_f(1,dims,fspace_id,hdf5err,hdf5_maxdims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain the absolute name of the group where the dataset is located + call numtochar(TimeIndex,tname) + tgroupname = 'TIME_STAMP_'//tname + if(DH%TgroupIDs(TimeIndex) /= -1) then + tgroupid = DH%TgroupIDs(TimeIndex) +! call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + else + call h5gcreate_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug(WARN,msg) + return + endif + DH%TgroupIDs(TimeIndex) = tgroupid + endif + + ! create dataset + call h5dcreate_f(tgroupid,DatasetName,dtypeid,fspace_id,& + dsetid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine setup_wrtd_dataset + +subroutine extend_wrtd_dataset(DataHandle,TimeIndex,countmd,dsetid,dspaceid,& + fspaceid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(in) :: countmd + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dsetid + integer(hid_t) ,intent(out) :: dspaceid + integer(hid_t) ,intent(out) :: fspaceid + integer ,intent(out) :: Status + + integer(hsize_t) ,dimension(2) :: sizes + integer(hsize_t) ,dimension(2) :: chunk_dims + integer(hsize_t) ,dimension(2) :: dims + integer(hsize_t) ,dimension(2) :: hdf5_maxdims + integer(hsize_t) ,dimension(2) :: offset + integer(hsize_t) ,dimension(2) :: count + + integer :: hdf5err + + sizes(1) = countmd + sizes(2) = TimeIndex + offset(1) = 0 + offset(2) = TimeIndex - 1 + count(1) = countmd + count(2) = 1 + dims(1) = countmd + dims(2) = 1 + + ! extend the dataset + CALL h5dextend_f(dsetid,sizes,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain file space id + CALL h5dget_space_f(dsetid,fspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + CALL h5sselect_hyperslab_f(fspaceid, H5S_SELECT_SET_F, & + offset, count, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! create the memory space id + call h5screate_simple_f(2,dims,dspaceid,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + return +end subroutine extend_wrtd_dataset + +subroutine setup_rdtd_dataset(DataHandle,DataSetName,mtypeid,TimeIndex,& + countmd,outcountmd,dset_id,memspaceid, & + dspace_id,tgroupid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DataSetName + integer ,intent(in) :: countmd + integer ,intent(out) :: outcountmd + integer ,intent(inout) :: mtypeid + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dset_id + integer(hid_t) ,intent(out) :: dspace_id + integer(hid_t) ,intent(out) :: memspaceid + integer(hid_t) ,intent(out) :: tgroupid + integer ,intent(out) :: Status + + integer(hid_t) :: dtype_id + integer(hid_t) :: class_type + integer(hsize_t) ,dimension(1) :: sizes + integer(hsize_t) ,dimension(1) :: dims + integer(hsize_t) ,dimension(1) :: h5_dims + integer(hsize_t) ,dimension(1) :: hdf5_maxdims + integer(hsize_t) ,dimension(1) :: offset + integer(hsize_t) ,dimension(1) :: count + integer :: StoredDim + type(wrf_phdf5_data_handle),pointer :: DH + + logical :: flag + integer :: hdf5err + + character(Len = MaxTimeSLen) :: tname + character(Len = 512) :: tgroupname + ! get datahandle + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain the absolute name of the group where the dataset is located + call numtochar(TimeIndex,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + + ! Obtain HDF5 dataset id + call h5dopen_f(tgroupid,DataSetName,dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Obtain the datatype + call h5dget_type_f(dset_id,dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(dtype_id,class_type,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(mtypeid == H5T_NATIVE_REAL .or. mtypeid == H5T_NATIVE_DOUBLE) then + if( class_type /= H5T_FLOAT_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid ==H5T_NATIVE_CHARACTER) then + if(class_type /= H5T_STRING_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid == H5T_NATIVE_INTEGER) then + if(class_type /= H5T_INTEGER_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid == DH%EnumID) then + if(class_type /= H5T_ENUM_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5tequal_f(dtype_id,DH%EnumID,flag,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(flag .EQV. .FALSE.) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_HDF5_ERR_BAD_DATA_TYPE + write(msg,*)'Fatal Non-WRF supported TYPE in ',__FILE__,', line',__LINE__ + call wrf_debug(FATAL, msg) + return + endif + ! update string id + if(mtypeid == H5T_NATIVE_CHARACTER) then + mtypeid = dtype_id + endif + + ! Obtain the dataspace + call h5dget_space_f(dset_id,dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Obtain the rank of the dimension + call h5sget_simple_extent_ndims_f(dspace_id,StoredDim,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(StoredDim /=1) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5sget_simple_extent_dims_f(dspace_id,h5_dims,hdf5_maxdims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(countmd <= 0) then + Status = WRF_HDF5_ERR_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(countmd .lt. h5_dims(1)) then + outcountmd = countmd + else + outcountmd = h5_dims(1) + endif + + ! create memspace_id + dims(1) = outcountmd + + call h5screate_simple_f(1,dims,memspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset(1) = 0 + count(1) = outcountmd + + return +end subroutine setup_rdtd_dataset + +subroutine make_strid(str_len,str_id,Status) + + use wrf_phdf5_data + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: str_len + integer(hid_t),intent(out) :: str_id + integer ,intent(out) :: Status + integer(size_t) :: str_lensize + integer :: hdf5err + + Status = WRF_NO_ERR + if(str_len <= 0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tcopy_f(H5T_NATIVE_CHARACTER,str_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + str_lensize = str_len + call h5tset_size_f(str_id,str_lensize,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tset_strpad_f(str_id,H5T_STR_SPACEPAD_F,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +end subroutine make_strid diff --git a/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90btg b/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90btg new file mode 100644 index 00000000..c00fdb63 --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/wrf-phdf5attr.F90btg @@ -0,0 +1,977 @@ +!/**************************************************************************** +!* NCSA HDF * +!* * +!* National Center for Supercomputing Applications * +!* University of Illinois at Urbana-Champaign * +!* 605 E. Springfield, Champaign IL 61820 * +!* * +!* For conditions of distribution and use, see the accompanying * +!* hdf/COPYING file. * +!* * +!****************************************************************************/ + +module get_attrid_routine + +Interface get_attrid + module procedure get_attrid +end interface + + contains + +subroutine get_attrid(DataHandle,Element,h5_attrid,Status,VAR) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + character*(*) ,intent(in) :: Element + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(out) :: h5_attrid + integer(hid_t) :: dset_id + integer ,intent(out) :: Status + character*(*) ,intent(in),optional :: VAR + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + character(Len = MaxTimeSLen) :: tname + character(Len = 256) :: tgroupname + integer(hid_t) :: tgroup_id + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(present(VAR)) then + call numtochar(1,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroup_id,hdf5err) + call h5dopen_f(tgroup_id,VAR,dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5aopen_name_f(dset_id,Element,h5_attrid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5dclose_f(dset_id,hdf5err) + call h5gclose_f(tgroup_id,hdf5err) + else + call h5aopen_name_f(DH%GroupID,Element,h5_attrid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + return + end subroutine get_attrid +end module get_attrid_routine + +subroutine create_phdf5_objid(DataHandle,obj_id,routine_type,var,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(out) :: obj_id + character*3 ,intent(in) :: routine_type + character*(*) ,intent(in) :: var + integer ,intent(out) :: Status + integer(hid_t) :: hdf5err + type(wrf_phdf5_data_handle),pointer :: DH + + + 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(routine_type == 'DOM') then + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + obj_id = DH%GroupID + endif + + else if(routine_type == 'VAR') then + + if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then + do i = 1, MaxVars + if(DH%VarNames(i) == var) then + obj_id = DH%dsetids(i) + write(*,*) "obj_id at attribute",obj_id + write(*,*) "DH%VarNames(i)",DH%VarNames(i) + exit + endif + enddo + endif + + else + Status = WRF_HDF5_ERR_DATA_ID_NOTFOUND + write(msg,*) 'CANNOT FIND DATASET ID of the attribute in',__FILE__,& + ', line',__LINE__ + endif + + return +end subroutine create_phdf5_objid + + +subroutine create_phdf5_adtypeid(h5_atypeid,routine_datatype,Count,Status,DataHandle) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer(hid_t) ,intent(out) :: h5_atypeid + integer ,intent(in) :: routine_datatype + integer ,intent(in) :: Count + integer ,intent(out) :: Status + integer(hid_t) :: hdf5err + integer, intent(in), optional :: DataHandle + integer(size_t) :: count_size + + type(wrf_phdf5_data_handle),pointer :: DH + + if(routine_datatype == WRF_LOGICAL)then + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + endif + + select case(routine_datatype) + case (WRF_REAL) + h5_atypeid = H5T_NATIVE_REAL + case (WRF_DOUBLE) + h5_atypeid = H5T_NATIVE_DOUBLE + case (WRF_INTEGER) + h5_atypeid = H5T_NATIVE_INTEGER + case (WRF_LOGICAL) + h5_atypeid = DH%EnumID + case (WRF_CHARACTER) + + call h5tcopy_f(H5T_NATIVE_CHARACTER,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + count_size = count + call h5tset_size_f(h5_atypeid,count_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tset_strpad_f(h5_atypeid,H5T_STR_SPACEPAD_F,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + case default + Status = WRF_HDF5_ERR_DATATYPE + return + end select + + Status = WRF_NO_ERR + + return +end subroutine create_phdf5_adtypeid + +subroutine create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status) + + use wrf_phdf5_data + use HDF5 + implicit none + include 'wrf_status_codes.h' + + integer :: i + integer ,intent(in) :: Count + integer ,intent(in) :: str_flag + integer ,intent(out) :: Status + + integer(hsize_t) , dimension(1) :: adims + integer(hid_t) :: hdf5err + integer(hid_t) ,intent(out) :: h5_aspaceid + integer :: arank = 1 + + ! if string, count is always 1 + if(str_flag == 1) then + adims(1) = 1 + call h5screate_simple_f(arank,adims,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + else + adims(1) = Count + call h5screate_simple_f(arank,adims,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + endif + + Status = WRF_NO_ERR + + return +end subroutine create_phdf5_adspaceid + + +subroutine clean_phdf5_attrids(h5_attr_typeid,h5_space_typeid, & + h5_attrid,str_flag,Status) + + use wrf_phdf5_data + use HDF5 + implicit none + include 'wrf_status_codes.h' + integer ,intent(out) :: Status + integer(hid_t) ,intent(in) :: h5_attr_typeid + integer(hid_t) ,intent(in) :: h5_space_typeid + integer(hid_t) ,intent(in) :: h5_attrid + integer ,intent(in) :: str_flag + integer :: hdf5err + + if(str_flag == 1) then + call h5tclose_f(h5_attr_typeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + endif + + call h5sclose_f(h5_space_typeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5aclose_f(h5_attrid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_CLOSE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + + return + +end subroutine clean_phdf5_attrids + + +subroutine create_h5filetype(dtype_id,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + use hdf5 + implicit none + include 'wrf_status_codes.h' + + integer(hid_t),intent(out) :: dtype_id + integer(hid_t) :: dtstr_id + integer(size_t) :: type_size + integer(size_t) :: type_sizes + integer(size_t) :: type_sizei + integer(size_t) :: offset + integer, intent(out) :: Status + integer(hid_t) :: hdf5err + + call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + type_size = 80 + call h5tset_size_f(dtstr_id,type_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_size_f(dtstr_id,type_sizes,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + type_size = type_sizes + 2*type_sizei + call h5tcreate_f(H5T_COMPOUND_F,type_size,dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + offset = 0 + call h5tinsert_f(dtype_id,"dim_name",offset,dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset = offset + type_sizes + call h5tinsert_f(dtype_id,"dim_length",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset = offset + type_sizei + + call h5tinsert_f(dtype_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,& + hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5tclose_f(dtstr_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_CLOSE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + return +end subroutine create_h5filetype + +! check whether two types are equal, attr_type and h5_attrid +subroutine check_type(DataHandle,attr_type,h5_attrid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer(hid_t) ,intent(in) :: attr_type + integer(hid_t) ,intent(in) :: h5_attrid + integer ,intent(out) :: Status + integer(hid_t) :: h5_atypeid + integer(hid_t) :: h5_classid + integer(hid_t) :: h5_wrfclassid + logical :: flag + integer :: hdf5err + type(wrf_phdf5_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 , msg) + return + endif + + call h5aget_type_f(h5_attrid,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(h5_atypeid,h5_classid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(attr_type,h5_wrfclassid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if((h5_classid==H5T_STRING_F).AND.& + (attr_type==H5T_NATIVE_CHARACTER)) then + flag = .TRUE. + else + if(h5_classid .NE. h5_wrfclassid) then + flag = .FALSE. + else + flag = .TRUE. + endif + endif + + if(flag .EQV. .FALSE.) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + return + endif + + Status = WRF_NO_ERR + return +end subroutine check_type + + +subroutine retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,Count,OutCount,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(in) :: h5_attrid + integer(hid_t) ,intent(out) :: h5_atypeid + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + integer(hid_t) :: h5_aspaceid + integer :: hdf5err + integer :: rank + integer(hsize_t) :: npoints + + type(wrf_phdf5_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 , msg) + return + endif + + if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + + call h5aget_type_f(h5_attrid,h5_atypeid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5aget_space_f(h5_attrid,h5_aspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_ndims_f(h5_aspaceid,rank,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(rank > 1) then + ! The rank can be either 0 or 1 + Status = WRF_HDF5_ERR_OTHERS + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5sget_simple_extent_npoints_f(h5_aspaceid,npoints,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + OutCount = npoints + if(npoints > Count) then + OutCount = Count + Status = WRF_ERR_WARN_MORE_DATA_IN_FILE + else + OutCount = npoints + endif + endif + return +end subroutine retrieve_ti_info + +subroutine setup_wrtd_dataset(DataHandle,DataSetName,dtypeid,countmd,& + dsetid,dspace_id,fspace_id,tgroupid, & + TimeIndex,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DataSetName + integer(hid_t) ,intent(in) :: dtypeid + integer ,intent(in) :: countmd + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dsetid + integer(hid_t) ,intent(out) :: dspace_id + integer(hid_t) ,intent(out) :: fspace_id + integer(hid_t) ,intent(out) :: tgroupid + integer(hid_t) :: crp_list + integer ,intent(out) :: Status + + integer(hsize_t) ,dimension(1) :: sizes + integer(hsize_t) ,dimension(1) :: chunk_dims + integer(hsize_t) ,dimension(1) :: dims + integer(hsize_t) ,dimension(1) :: hdf5_maxdims + integer(hsize_t) ,dimension(1) :: offset + integer(hsize_t) ,dimension(1) :: count + type(wrf_phdf5_data_handle),pointer :: DH + + character(Len = MaxTimeSLen) :: tname + character(Len = 256) :: tgroupname + integer :: hdf5err + + + ! get datahandle + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + chunk_dims(1) = countmd + + dims(1) = countmd + + count(1) = countmd + + offset(1) = 0 + + sizes(1) = countmd + + hdf5_maxdims(1) = countmd + + ! create the memory space id + call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! create file space(for parallel module, each dataset per time step) + call h5screate_simple_f(1,dims,fspace_id,hdf5err,hdf5_maxdims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain the absolute name of the group where the dataset is located + call numtochar(TimeIndex,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + + ! create dataset + call h5dcreate_f(tgroupid,DatasetName,H5T_NATIVE_REAL,fspace_id,& + dsetid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + write(*,*) "cannot create an HDF5 dataset " + return + endif + + return + end subroutine setup_wrtd_dataset + + subroutine extend_wrtd_dataset(DataHandle,TimeIndex,countmd,dsetid,dspaceid,& + fspaceid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + integer ,intent(in) :: countmd + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dsetid + integer(hid_t) ,intent(out) :: dspaceid + integer(hid_t) ,intent(out) :: fspaceid + integer ,intent(out) :: Status + + integer(hsize_t) ,dimension(2) :: sizes + integer(hsize_t) ,dimension(2) :: chunk_dims + integer(hsize_t) ,dimension(2) :: dims + integer(hsize_t) ,dimension(2) :: hdf5_maxdims + integer(hsize_t) ,dimension(2) :: offset + integer(hsize_t) ,dimension(2) :: count + + integer :: hdf5err + + sizes(1) = countmd + sizes(2) = TimeIndex + offset(1) = 0 + offset(2) = TimeIndex - 1 + count(1) = countmd + count(2) = 1 + dims(1) = countmd + dims(2) = 1 + + ! extend the dataset + CALL h5dextend_f(dsetid,sizes,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + write(*,*) "cannot extend an HDF5 dataset in index ",TimeIndex + return + endif + + ! obtain file space id + CALL h5dget_space_f(dsetid,fspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + CALL h5sselect_hyperslab_f(fspaceid, H5S_SELECT_SET_F, & + offset, count, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + write(*,*) "cannot select hyperslab" + return + endif + + ! create the memory space id + call h5screate_simple_f(2,dims,dspaceid,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + write(*,*) "cannot create HDF5 memory data space" + return + endif + + return +end subroutine extend_wrtd_dataset + +subroutine setup_rdtd_dataset(DataHandle,DataSetName,mtypeid,TimeIndex,& + countmd,outcountmd,dset_id,memspaceid, & + dspace_id,tgroupid,Status) + + use wrf_phdf5_data + use ext_phdf5_support_routines + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DataSetName + integer ,intent(in) :: countmd + integer ,intent(out) :: outcountmd + integer ,intent(inout) :: mtypeid + integer ,intent(in) :: TimeIndex + + integer(hid_t) ,intent(out) :: dset_id + integer(hid_t) ,intent(out) :: dspace_id + integer(hid_t) ,intent(out) :: memspaceid + integer(hid_t) ,intent(out) :: tgroupid + integer ,intent(out) :: Status + + integer(hid_t) :: dtype_id + integer(hid_t) :: class_type + integer(hsize_t) ,dimension(1) :: sizes + integer(hsize_t) ,dimension(1) :: dims + integer(hsize_t) ,dimension(1) :: h5_dims + integer(hsize_t) ,dimension(1) :: hdf5_maxdims + integer(hsize_t) ,dimension(1) :: offset + integer(hsize_t) ,dimension(1) :: count + integer :: StoredDim + type(wrf_phdf5_data_handle),pointer :: DH + + logical :: flag + integer :: hdf5err + + character(Len = MaxTimeSLen) :: tname + character(Len = 256) :: tgroupname + ! get datahandle + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! obtain the absolute name of the group where the dataset is located + call numtochar(TimeIndex,tname) + tgroupname = 'TIME_STAMP_'//tname + call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err) + + ! Obtain HDF5 dataset id + call h5dopen_f(tgroupid,DataSetName,dset_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Obtain the datatype + call h5dget_type_f(dset_id,dtype_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tget_class_f(dtype_id,class_type,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(mtypeid == H5T_NATIVE_REAL .or. mtypeid == H5T_NATIVE_DOUBLE) then + if( class_type /= H5T_FLOAT_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid ==H5T_NATIVE_CHARACTER) then + if(class_type /= H5T_STRING_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid == H5T_NATIVE_INTEGER) then + if(class_type /= H5T_INTEGER_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else if(mtypeid == DH%EnumID) then + if(class_type /= H5T_ENUM_F) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call h5tequal_f(dtype_id,DH%EnumID,flag,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_OPEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(flag .EQV. .FALSE.) then + Status = WRF_HDF5_ERR_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_HDF5_ERR_BAD_DATA_TYPE + write(msg,*)'Fatal Non-WRF supported TYPE in ',__FILE__,', line',__LINE__ + call wrf_debug(FATAL, msg) + return + endif + ! update string id + if(mtypeid == H5T_NATIVE_CHARACTER) then + mtypeid = dtype_id + endif + + ! Obtain the dataspace + call h5dget_space_f(dset_id,dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Obtain the rank of the dimension + call h5sget_simple_extent_ndims_f(dspace_id,StoredDim,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(StoredDim /=1) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + call h5sget_simple_extent_dims_f(dspace_id,h5_dims,hdf5_maxdims,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + if(countmd <= 0) then + Status = WRF_HDF5_ERR_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(countmd .lt. h5_dims(1)) then + outcountmd = countmd + else + outcountmd = h5_dims(1) + endif + + ! create memspace_id + dims(1) = outcountmd + + call h5screate_simple_f(1,dims,memspaceid,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + offset(1) = 0 + count(1) = outcountmd + + return +end subroutine setup_rdtd_dataset + +subroutine make_strid(str_len,str_id,Status) + + use wrf_phdf5_data + USE HDF5 ! This module contains all necessary modules + implicit none + include 'wrf_status_codes.h' + + integer ,intent(in) :: str_len + integer(hid_t),intent(out) :: str_id + integer ,intent(out) :: Status + integer(size_t) :: str_lensize + integer :: hdf5err + + Status = WRF_NO_ERR + if(str_len <= 0) then + Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tcopy_f(H5T_NATIVE_CHARACTER,str_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + str_lensize = str_len + call h5tset_size_f(str_id,str_lensize,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tset_strpad_f(str_id,H5T_STR_SPACEPAD_F,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +end subroutine make_strid diff --git a/wrfv2_fire/external/io_phdf5/wrf-phdf5support.F90 b/wrfv2_fire/external/io_phdf5/wrf-phdf5support.F90 new file mode 100644 index 00000000..2ba06ad2 --- /dev/null +++ b/wrfv2_fire/external/io_phdf5/wrf-phdf5support.F90 @@ -0,0 +1,1395 @@ +!/*************************************************************************** +!* The HDF5 WRF IO module was written by the the HDF Group at NCSA, the * +!* National Center for Supercomputing Applications. * +!* HDF Group * +!* National Center for Supercomputing Applications * +!* University of Illinois at Urbana-Champaign * +!* 605 E. Springfield, Champaign IL 61820 * +!* http://hdf.ncsa.uiuc.edu/ * +!* * +!* Copyright 2004 by the Board of Trustees, University of Illinois, * +!* * +!* Redistribution or use of this IO module, with or without modification, * +!* is permitted for any purpose, including commercial purposes. * +!* * +!* This software is an unsupported prototype. Use at your own risk. * +!* http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS * +!* * +!* This work was funded by the MEAD expedition at the National Center * +!* for Supercomputing Applications, NCSA. For more information see: * +!* http://www.ncsa.uiuc.edu/expeditions/MEAD * +!* * +!* * +!****************************************************************************/ + +module wrf_phdf5_data + + use HDF5 + integer , parameter :: FATAL = 1 + integer , parameter :: WARN = 1 + integer , parameter :: WrfDataHandleMax = 99 + integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS + integer , parameter :: MaxTabDims = 100 ! temporary,changable + integer , parameter :: MaxVars = 2000 + integer , parameter :: MaxTimes = 9999 ! temporary, changable + integer , parameter :: MaxTimeSLen = 6 ! not exceed 1,000,000 timestamp + integer , parameter :: DateStrLen = 19 + integer , parameter :: VarNameLen = 31 + integer , parameter :: NO_DIM = 0 + integer , parameter :: NVarDims = 4 + integer , parameter :: NMDVarDims = 2 + integer , parameter :: CompDsetSize = 64256 ! set to 63K + character (8) , parameter :: NO_NAME = 'NULL' + character(4) , parameter :: hdf5_true ='TRUE' + character(5) , parameter :: hdf5_false ='FALSE' + integer , parameter :: MemOrdLen = 3 + character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' + +#include "wrf_io_flags.h" +! This is a hack. WRF IOAPI no longer supports WRF_CHARACTER. Rip this out! + integer, parameter :: WRF_CHARACTER = 1080 + + character (120) :: msg + + ! derived data type for dimensional table + type :: dim_scale + character (len = 256) :: dim_name + integer :: length + integer :: unlimited + end type dim_scale + + type :: wrf_phdf5_data_handle + character (256) :: FileName + integer :: FileStatus + integer :: Comm + integer(hid_t) :: FileID + integer(hid_t) :: GroupID + integer(hid_t) :: DimGroupID + integer(hid_t) :: EnumID + character (256) :: GroupName + character (256) :: DimGroupName + logical :: Free + logical :: Write + character (5) :: TimesName + integer :: TimeIndex + integer :: MaxTimeCount + integer :: CurrentTime !Only used for read + integer :: NumberTimes !Only used for read + character (DateStrLen), pointer :: Times(:) + integer(hid_t) :: TimesID + integer(hid_t) :: str_id + integer , pointer :: DimLengths(:) + integer , pointer :: DimIDs(:) + character (31) , pointer :: DimNames(:) + integer :: DimUnlimID + character (9) :: DimUnlimName + type (dim_scale) , pointer :: DIMTABLE(:) + integer , dimension(NVarDims) :: DimID + integer , dimension(NVarDims) :: Dimension + ! integer , pointer :: MDDsetIDs(:) + integer , pointer :: MDVarDimLens(:) + character (256) , pointer :: MDVarNames(:) + integer(hid_t) , pointer :: TgroupIDs(:) + integer(hid_t) , pointer :: DsetIDs(:) + integer(hid_t) , pointer :: MDDsetIDs(:) + ! integer(hid_t) :: DimTableID + 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 + end type wrf_phdf5_data_handle + type(wrf_phdf5_data_handle),target :: WrfDataHandles(WrfDataHandleMax) + +end module wrf_phdf5_data + + +module ext_phdf5_support_routines + + implicit none + +CONTAINS + + subroutine allocHandle(DataHandle,DH,Comm,Status) + + use wrf_phdf5_data + use HDF5 + include 'wrf_status_codes.h' + + integer ,intent(out) :: DataHandle + type(wrf_phdf5_data_handle),pointer:: DH + integer ,intent(IN) :: Comm + integer ,intent(out) :: Status + integer :: i + integer :: j + integer :: stat + integer(hid_t) :: enum_type + ! character (256) :: NullName + + ! NullName = char(0) + + do i=1,WrfDataHandleMax + if(WrfDataHandles(i)%Free) then + DH => WrfDataHandles(i) + DataHandle = i + DH%MaxTimeCount = 1 + + DH%FileID = -1 + DH%GroupID = -1 + DH%DimGroupID = -1 + + call SetUp_EnumID(enum_type,Status) + if(Status /= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal enum ALLOCATION ERROR in ',__FILE__,', line',__LINE__ + call wrf_debug ( FATAL , msg) + return + endif + DH%EnumID = enum_type + + allocate(DH%Times(MaxTimes), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__ + call wrf_debug ( FATAL , msg) + return + endif + ! wait in the future + ! DH%Times(1:MaxTimes) = NullName + + allocate(DH%DimLengths(MaxDims), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + 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_HDF5_ERR_ALLOCATION + 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_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + allocate(DH%DIMTABLE(MaxTabDims), STAT = stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + do j =1,MaxTabDims + DH%DIMTABLE(j)%dim_name = NO_NAME + DH%DIMTABLE(j)%unlimited = -1 + enddo + + allocate(DH%MDDsetIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + 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_HDF5_ERR_ALLOCATION + 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_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + + allocate(DH%DsetIDs(MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + DH%DsetIDs = -1 + + allocate(DH%TgroupIDs(MaxTimes), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + DH%TgroupIDs = -1 + + allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat) + if(stat/= 0) then + Status = WRF_HDF5_ERR_ALLOCATION + 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_HDF5_ERR_ALLOCATION + write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + exit + endif + + if(i==WrfDataHandleMax) then + Status = WRF_HDF5_ERR_TOO_MANY_FILES + write(msg,*) 'Warning TOO MANY FILES in ',"__FILE__",', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + + + DH%Free =.false. + DH%Comm = Comm + DH%Write =.false. + DH%first_operation = .TRUE. + Status = WRF_NO_ERR + end subroutine allocHandle + + ! Obtain data handler + subroutine GetDH(DataHandle,DH,Status) + + use wrf_phdf5_data + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + type(wrf_phdf5_data_handle) ,pointer :: DH + integer ,intent(out) :: Status + + if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then + Status = WRF_HDF5_ERR_BAD_DATA_HANDLE + return + endif + DH => WrfDataHandles(DataHandle) + if(DH%Free) then + Status = WRF_HDF5_ERR_BAD_DATA_HANDLE + return + endif + Status = WRF_NO_ERR + return + end subroutine GetDH + + ! Set up eumerate datatype for possible logical type + subroutine SetUp_EnumID(enum_type,Status) + + use wrf_phdf5_data + use HDF5 + implicit none + include 'wrf_status_codes.h' + integer(hid_t) ,intent(out) :: enum_type + integer ,intent(out) :: Status + integer :: hdf5err + integer, dimension(2) :: data + + data(1) = 1 + data(2) = 0 + + call h5tenum_create_f(H5T_NATIVE_INTEGER,enum_type,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tenum_insert_f(enum_type,hdf5_true,data(1),hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5tenum_insert_f(enum_type,hdf5_false,data(2),Status) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + Status = WRF_NO_ERR + return + end subroutine SetUp_EnumID + +! 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 phdf5_ok_to_put_dom_ti( DataHandle ) + use wrf_phdf5_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, first_output, retval + call ext_phdf5_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 = phdf5_is_first_operation( DataHandle ) + retval = .NOT. dryrun .AND. first_output + ENDIF + phdf5_ok_to_put_dom_ti = retval + RETURN +END FUNCTION phdf5_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 phdf5_ok_to_get_dom_ti( DataHandle ) + use wrf_phdf5_data + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, retval + call ext_phdf5_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 + phdf5_ok_to_get_dom_ti = retval + RETURN +END FUNCTION phdf5_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 phdf5_is_first_operation( DataHandle ) + use wrf_phdf5_data + INCLUDE 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + TYPE(wrf_phdf5_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 + phdf5_is_first_operation = retval + RETURN +END FUNCTION phdf5_is_first_operation + +end module ext_phdf5_support_routines + +!module wrf_phdf5_opt_data +! integer ,parameter :: MaxOptVars = 100 +!end module wrf_phdf5_opt_data + +!module opt_data_module + +!use wrf_phdf5_opt_data +! type :: field + +! logical :: Free +! integer,pointer :: darrays(:) +! integer :: index +! end type field +! type(field),target :: fieldhandle(MaxOptVars) +!end module opt_data_module + +!module opt_support_module +! implicit none +!contains +! subroutine alloc_opt_handle(ODH) +! use opt_data_module +! type(field),pointer::DH +! integer :: i + +! do i =1,MaxOptVars +! DH=>fieldhandle(i) +! DH%index = 0 +! enddo +!end module opt_support_module + +! check the date, only use the length +subroutine DateCheck(Date,Status) + use wrf_phdf5_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Date + integer ,intent(out) :: Status + + if(len(Date) /= DateStrLen) then + Status = WRF_HDF5_ERR_DATESTR_BAD_LENGTH + else + Status = WRF_NO_ERR + endif + return +end subroutine DateCheck + +! This routine is for meta-data time dependent varible attribute +subroutine GetName(Element,Var,Name,Status) + + use wrf_phdf5_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 + +! Obtain TimeIndex +subroutine GetDataTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + + use HDF5 + use wrf_phdf5_data + use ext_phdf5_support_routines + + implicit none + include 'wrf_status_codes.h' + + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character (DateStrLen), pointer :: TempTimes(:) + integer ,intent(out) :: TimeIndex + integer ,intent(out) :: Status + + type(wrf_phdf5_data_handle) ,pointer :: DH + integer :: VStart(2) + integer :: VCount(2) + integer :: stat + integer :: i + integer :: PreTimeCount + + integer :: rank + integer(hsize_t), dimension(1) :: chunk_dims =(/1/) + integer(hsize_t), dimension(1) :: dims + integer(hsize_t), dimension(1) :: hdf5_maxdims + integer(hsize_t), dimension(1) :: offset + integer(hsize_t), dimension(1) :: count + integer(hsize_t), dimension(1) :: sizes + + INTEGER(HID_T) :: dset_id ! Dataset ID + INTEGER(HID_T) :: dspace_id ! Dataspace ID + INTEGER(HID_T) :: fspace_id ! Dataspace ID + INTEGER(HID_T) :: crp_list ! chunk ID + integer(hid_t) :: str_id ! string ID + integer :: hdf5err + + integer(hid_t) :: group_id + character(Len = 512) :: groupname + + ! for debug + + character(len=100) :: buf + integer(size_t) :: name_size + integer(size_t) :: datelen_size + ! suppose the output will not exceed 100,0000 timesteps. + character(Len = MaxTimeSLen) :: tname + + + ! DH => WrfDataHandles(DataHandle), don't know why NetCDF doesn't use GetDH + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(IO == 'write') then + TimeIndex = DH%TimeIndex + if(TimeIndex <= 0) then + TimeIndex = 1 + elseif(DateStr < DH%Times(TimeIndex)) then + Status = WRF_HDF5_ERR_DATE_LT_LAST_DATE + write(msg,*) 'Warning DATE < LAST DATE in ',"__FILE__",', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DateStr == DH%Times(TimeIndex)) then + Status = WRF_NO_ERR + return + else + TimeIndex = TimeIndex + 1 + ! If exceeding the maximum timestep, updating the maximum timestep + if(TimeIndex > MaxTimes*(DH%MaxTimeCount)) then + PreTimeCount = DH%MaxTimeCount + allocate(TempTimes(PreTimeCount*MaxTimes)) + TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes & + *PreTimeCount) + DH%MaxTimeCount = DH%MaxTimeCount +1 + deallocate(DH%Times) + allocate(DH%Times(DH%MaxTimeCount*MaxTimes)) + DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes & + *PreTimeCount) + deallocate(TempTimes) + endif + endif + DH%TimeIndex = TimeIndex + DH%Times(TimeIndex) = DateStr + ! From NetCDF implementation, keep it in case it can be used. + ! VStart(1) = 1 + ! VStart(2) = TimeIndex + ! VCount(1) = DateStrLen + ! VCount(2) = 1 + + ! create memory dataspace id and file dataspace id + dims(1) = 1 + count(1) = 1 + offset(1) = TimeIndex -1 + sizes(1) = TimeIndex + + ! create group id for different time stamp + call numtochar(TimeIndex,tname) + groupname = 'TIME_STAMP_'//tname +! call h5gn_members_f(DH%GroupID,DH%GroupName,nmembers,hdf5err) +! do i = 0, nmembers - 1 +! call h5gget_obj_info_idx_f(DH%GroupID,DH%GroupName,i,ObjName, ObjType, & +! hdf5err) + +! if(ObjName(1:17) == groupname) then +! call h5gopen_f(DH%GroupID,groupname,tgroupid,hdf5err) +! exit +! endif +! enddo + + if(DH%Tgroupids(TimeIndex) == -1) then + call h5gcreate_f(DH%groupid,groupname,group_id,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + DH%Tgroupids(TimeIndex) = group_id + else +! call h5gopen_f(DH%groupid,groupname,group_id, + group_id = DH%Tgroupids(TimeIndex) + endif + + call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! create HDF5 string handler for time + if(TimeIndex == 1) then + call h5tcopy_f(H5T_NATIVE_CHARACTER, str_id, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + datelen_size = DateStrLen + call h5tset_size_f(str_id,datelen_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + str_id = DH%str_id + endif + + call h5dcreate_f(group_id,DH%TimesName,str_id,dspace_id,& + DH%TimesID, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! write the data in memory space to file space + CALL h5dwrite_f(DH%TimesID,str_id,DateStr,dims,hdf5err,dspace_id,dspace_id) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(TimeIndex == 1) then + DH%str_id = str_id + endif + + + call h5sclose_f(dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(DH%TimesID,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + else + ! This is for IO read + ! Find the timeIndex(very expensive for large + ! time stamp, should use hashing table) + + do i=1,MaxTimes*DH%MaxTimeCount + + ! For handling reading maximum timestamp greater than 9000 in the future + ! if(DH%Times(i) == NullName) then + ! Status = WRF_HDF5_ERR_TIME + ! write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",& + ! ', line', __LINE__ + ! call wrf_debug ( WARN , msg) + ! return + ! endif + + if(DH%Times(i) == DateStr) then + Status = WRF_NO_ERR + TimeIndex = i + exit + endif + + ! Need a recursive function to handle this + ! This is a potential bug + if(i == MaxTimes*DH%MaxTimeCount) then + ! PreTimeCount = DH%MaxTimeCount + ! allocate(TempTimes(PreTimeCount*MaxTimes)) + ! TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes & + ! *PreTimeCount) + ! DH%MaxTimeCount = DH%MaxTimeCount +1 + ! deallocate(DH%Times) + ! allocate(DH%Times(DH%MaxTimeCount*MaxTimes)) + ! DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes & + ! *PreTimeCount) + ! deallocate(TempTimes) + Status = WRF_HDF5_ERR_TIME + write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",& + ', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + + ! do the hyperslab selection + + endif + return +end subroutine GetDataTimeIndex + +subroutine GetAttrTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + + use HDF5 + use wrf_phdf5_data + use ext_phdf5_support_routines + + implicit none + include 'wrf_status_codes.h' + + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character (DateStrLen), pointer :: TempTimes(:) + integer ,intent(out) :: TimeIndex + integer ,intent(out) :: Status + + type(wrf_phdf5_data_handle) ,pointer :: DH + integer :: VStart(2) + integer :: VCount(2) + integer :: stat + integer :: i + integer :: PreTimeCount + + integer :: rank + integer(hsize_t), dimension(1) :: chunk_dims =(/1/) + integer(hsize_t), dimension(1) :: dims + integer(hsize_t), dimension(1) :: hdf5_maxdims + integer(hsize_t), dimension(1) :: offset + integer(hsize_t), dimension(1) :: count + integer(hsize_t), dimension(1) :: sizes + + INTEGER(HID_T) :: dset_id ! Dataset ID + INTEGER(HID_T) :: dspace_id ! Dataspace ID + INTEGER(HID_T) :: fspace_id ! Dataspace ID + INTEGER(HID_T) :: crp_list ! chunk ID + integer(hid_t) :: str_id ! string ID + integer :: hdf5err + + integer(size_t) :: datelen_size + integer(hid_t) :: group_id + character(Len = 512) :: groupname + + ! suppose the output will not exceed 100,0000 timesteps. + character(Len = MaxTimeSLen) :: tname + + ! DH => WrfDataHandles(DataHandle), don't know why NetCDF doesn't use GetDH + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_HDF5_ERR_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',"__FILE__",', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(IO == 'write') then + TimeIndex = DH%TimeIndex + if(TimeIndex <= 0) then + TimeIndex = 1 + elseif(DateStr < DH%Times(TimeIndex)) then + Status = WRF_HDF5_ERR_DATE_LT_LAST_DATE + write(msg,*) 'Warning DATE < LAST DATE in ',"__FILE__",', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DateStr == DH%Times(TimeIndex)) then + Status = WRF_NO_ERR + return + else + TimeIndex = TimeIndex + 1 + ! If exceeding the maximum timestep, updating the maximum timestep + if(TimeIndex > MaxTimes*(DH%MaxTimeCount)) then + PreTimeCount = DH%MaxTimeCount + allocate(TempTimes(PreTimeCount*MaxTimes)) + TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes & + *PreTimeCount) + DH%MaxTimeCount = DH%MaxTimeCount +1 + deallocate(DH%Times) + allocate(DH%Times(DH%MaxTimeCount*MaxTimes)) + DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes & + *PreTimeCount) + deallocate(TempTimes) + endif + endif + DH%TimeIndex = TimeIndex + DH%Times(TimeIndex) = DateStr + + ! From NetCDF implementation, keep it in case it can be used. + ! VStart(1) = 1 + ! VStart(2) = TimeIndex + ! VCount(1) = DateStrLen + ! VCount(2) = 1 + + ! create memory dataspace id and file dataspace id + dims(1) = 1 + count(1) = 1 + offset(1) = TimeIndex -1 + sizes(1) = TimeIndex + + ! create group id for different time stamp + call numtochar(TimeIndex,tname) + groupname = 'TIME_STAMP_'//tname + + if(DH%Tgroupids(TimeIndex) == -1) then + call h5gcreate_f(DH%groupid,groupname,group_id,hdf5err) + if(hdf5err .lt. 0) then + Status = WRF_HDF5_ERR_GROUP + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + DH%Tgroupids(TimeIndex) = group_id + else +! call h5gopen_f(DH%groupid,groupname,group_id, + group_id = DH%Tgroupids(TimeIndex) + endif + + call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! create HDF5 string handler for time + if(TimeIndex == 1) then + call h5tcopy_f(H5T_NATIVE_CHARACTER, str_id, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + datelen_size = DateStrLen + call h5tset_size_f(str_id,datelen_size,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATATYPE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + str_id = DH%str_id + endif + + call h5dcreate_f(group_id,DH%TimesName,str_id,dspace_id,& + DH%TimesID, hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_CREATE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + + ! write the data in memory space to file space + CALL h5dwrite_f(DH%TimesID,str_id,DateStr,dims,hdf5err,dspace_id,dspace_id) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_WRITE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + if(TimeIndex == 1) then + DH%str_id = str_id + endif + + + call h5sclose_f(dspace_id,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASPACE + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + call h5dclose_f(DH%TimesID,hdf5err) + if(hdf5err.lt.0) then + Status = WRF_HDF5_ERR_DATASET_GENERAL + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + else + ! This is for IO read + ! Find the timeIndex(very expensive for large + ! time stamp, should use hashing table) + + do i=1,MaxTimes*DH%MaxTimeCount + + + if(DH%Times(i) == DateStr) then + Status = WRF_NO_ERR + TimeIndex = i + exit + endif + + ! Need a recursive function to handle this + ! This is a potential bug + if(i == MaxTimes*DH%MaxTimeCount) then + Status = WRF_HDF5_ERR_TIME + write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",& + ', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + + ! do the hyperslab selection + + endif + return +end subroutine GetAttrTimeIndex + + +! Obtain the rank of the dimension +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') + NDim = 2 + case ('z','c','0') + NDim = 1 + case default + Status = WRF_HDF5_ERR_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine GetDim + +! Obtain the index for transposing +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 + 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 + +! shuffling the memory order to XYZ order +subroutine ExtOrder(MemoryOrder,Vector,Status) + use wrf_phdf5_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') + Vector(1) = 1 + 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_HDF5_ERR_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrder + +! shuffling the dimensional name order +subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) + use wrf_phdf5_data + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*),dimension(*) ,intent(in) :: Vector + character(256),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') + ROVector(1) = 'ext_scalar' + 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_HDF5_ERR_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*3 :: 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*3 :: 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 used in transpose routine +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) + 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 + +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)) + + + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + 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 + do k=k1,k2 + do j=j1,j2 + do i=i1,i2 + if(IO == 'write') then + 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)) + else + 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)))) + endif + enddo + enddo + enddo + return + + end select + return +end subroutine Transpose + +subroutine numtochar(TimeIndex,tname,Status) + + use wrf_phdf5_data + integer, intent(in) :: TimeIndex + character(len=MaxTimeSLen),intent(out)::tname + integer ,intent(out)::Status + integer :: i,ten_pow,temp + integer :: maxtimestep + + maxtimestep =1 + do i =1,MaxTimeSLen + maxtimestep = maxtimestep * 10 + enddo + if(TimeIndex >= maxtimestep) then + Status = WRF_HDF5_ERR_OTHERS + write(msg,*) 'Cannot exceed the maximum timestep',maxtimestep,'in',__FILE__,' line',__LINE__ + call wrf_debug(FATAL,msg) + return + endif + + ten_pow = 1 + temp =10 + do i =1,MaxTimeSLen + tname(MaxTimeSLen+1-i:MaxTimeSLen+1-i) = achar(modulo(TimeIndex/ten_pow,temp)+iachar('0')) + ten_pow = 10* ten_pow + enddo + + return +end subroutine numtochar diff --git a/wrfv2_fire/external/io_pnetcdf/README b/wrfv2_fire/external/io_pnetcdf/README new file mode 100644 index 00000000..467c2d6b --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/README @@ -0,0 +1,38 @@ +This is a tar file of the WRF NetCDF I/O library. + +The tar file contains these files: + +-rw-r--r-- 1 jacquesm ad 1968 Nov 27 13:43 README +-rw-r--r-- 1 jacquesm ad 15121 Nov 27 11:44 WRFIO.doc +-rw-r--r-- 1 jacquesm ad 4447 Nov 14 16:26 ext_get_glb_md.code +-rw-r--r-- 1 jacquesm ad 5068 Nov 17 14:56 ext_get_var_md.code +-rw-r--r-- 1 jacquesm ad 6766 Nov 17 15:12 ext_get_vartime_md.code +-rw-r--r-- 1 jacquesm ad 4106 Nov 14 15:04 ext_put_glb_md.code +-rw-r--r-- 1 jacquesm ad 4124 Nov 14 15:04 ext_put_var_md.code +-rw-r--r-- 1 jacquesm ad 7147 Nov 14 15:04 ext_put_vartime_md.code +-rw-r--r-- 1 jacquesm ad 6222 Nov 27 11:30 field_routines.F90 +-rw-r--r-- 1 jacquesm ad 47 Oct 18 11:59 howto.ncdump +-rw-r--r-- 1 jacquesm ad 1218 Oct 26 15:16 makefile +-rw-r--r-- 1 jacquesm ad 2546 Nov 16 12:53 testWRFReadXYZ.F90 +-rw-r--r-- 1 jacquesm ad 9555 Nov 27 11:25 testWRFReadfoo2.F90 +-rw-r--r-- 1 jacquesm ad 7354 Nov 27 11:23 testWRFReadjfm.F90 +-rw-r--r-- 1 jacquesm ad 2994 Nov 16 12:53 testWRFWriteXYZ.F90 +-rw-r--r-- 1 jacquesm ad 16391 Nov 27 11:25 testWRFWritefoo2.F90 +-rw-r--r-- 1 jacquesm ad 8896 Nov 27 11:25 testWRFWritejfm.F90 +-rw-r--r-- 1 jacquesm ad 462 Oct 27 16:44 transpose.code +-rw-r--r-- 1 jacquesm ad 78533 Nov 27 11:22 wrf_io.F90 +-rw-r--r-- 1 jacquesm ad 2715 Nov 21 12:06 wrf_status_codes.h + +The test* routines are test programs and one pair must be copied to +testWRFWrite.F90 and testWRFRead.F90. The other files comprise the WRF +NetCDF I/O library. In the makefile, you may need to redefine the path to +NetCDF. To run the test files, do: + + make + testWRFWrite + testWRFRead + +testWRFWrite will create a NetCDF file called foo.nc and testWRFRead will +read it. Status codes and some values will be printed. + + diff --git a/wrfv2_fire/external/io_pnetcdf/WRFIO.doc b/wrfv2_fire/external/io_pnetcdf/WRFIO.doc new file mode 100644 index 00000000..9cd39d14 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/WRFIO.doc @@ -0,0 +1,6 @@ +Documentation for WRF I/O is at + + http://www.wrf-model.org/documentation_main.html + +the first link under REFERENCES. + diff --git a/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_dom_ti.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_dom_ti.code new file mode 100644 index 00000000..71a5d55b --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_dom_ti.code @@ -0,0 +1,159 @@ +!*------------------------------------------------------------------------------ +!* 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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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(KIND=MPI_OFFSET_KIND) :: Len_okind + 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 = NFMPI_INQ_ATT(DH%NCID,NF_GLOBAL,Element, XType, Len_okind) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) & +'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + Len = Len_okind + 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__,' Element ', trim(Element) + 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__,' Element ', trim(Element) + 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__,' Element ', trim(Element) + 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 = NFMPI_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/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_td.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_td.code new file mode 100644 index 00000000..222b5ef9 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_td.code @@ -0,0 +1,229 @@ +!*------------------------------------------------------------------------------ +!* 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_pnc_support_routines + implicit none +# include "pnetcdf.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(KIND=MPI_OFFSET_KIND) :: VStart(2) + integer(KIND=MPI_OFFSET_KIND) :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: NCID + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer(KIND=MPI_OFFSET_KIND) :: Len1_okind + 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 = NFMPI_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 = NFMPI_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 = NFMPI_INQ_DIMLEN(NCID,DimIDs(1),Len1_okind) + 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 + Len1 = Len1_okind + 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 = NFMPI_GET_VARA_TEXT_ALL (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/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_ti.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_ti.code new file mode 100644 index 00000000..34351a13 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_get_var_ti.code @@ -0,0 +1,177 @@ +!*------------------------------------------------------------------------------ +!* 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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 + integer(KIND=MPI_OFFSET_KIND) :: XLen_offset + 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 + XLen_offset = i2offset(XLen) + stat = NFMPI_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen_offset) + XLen = XLen_offset + 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/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_dom_ti.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_dom_ti.code new file mode 100644 index 00000000..0be426fa --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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) then + stat = NFMPI_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 = NFMPI_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/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_var_td.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_var_td.code new file mode 100644 index 00000000..df41335b --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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(KIND=MPI_OFFSET_KIND) :: VStart(2) + integer(KIND=MPI_OFFSET_KIND) :: 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 = NFMPI_DEF_DIM(NCID,DH%DimNames(i),i2offset(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 = NFMPI_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/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_var_ti.code b/wrfv2_fire/external/io_pnetcdf/ext_pnc_put_var_ti.code new file mode 100644 index 00000000..e83cd4b2 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/ext_pnc_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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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),i2offset(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/wrfv2_fire/external/io_pnetcdf/field_routines.F90 b/wrfv2_fire/external/io_pnetcdf/field_routines.F90 new file mode 100644 index 00000000..5720ef10 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/field_routines.F90 @@ -0,0 +1,191 @@ +!*------------------------------------------------------------------------------ +!* 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_pnc_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 +!local + integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims) :: VStart_mpi, VCount_mpi + VStart_mpi = VStart + VCount_mpi = VCount + + if(IO == 'write') then + stat = NFMPI_PUT_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data) + else + stat = NFMPI_GET_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,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_pnc_RealFieldIO + +subroutine ext_pnc_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 +!local + integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims) :: VStart_mpi, VCount_mpi + VStart_mpi = VStart + VCount_mpi = VCount + + if(IO == 'write') then + stat = NFMPI_PUT_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data) + else + stat = NFMPI_GET_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,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_pnc_DoubleFieldIO + +subroutine ext_pnc_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 +!local + integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims) :: VStart_mpi, VCount_mpi + VStart_mpi = VStart + VCount_mpi = VCount + + if(IO == 'write') then + stat = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data) + else + stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,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_pnc_IntFieldIO + +subroutine ext_pnc_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 +!local + integer(KIND=MPI_OFFSET_KIND), dimension(NVarDims) :: VStart_mpi, VCount_mpi + VStart_mpi = VStart + VCount_mpi = VCount + + 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 = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Buffer) + else + stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,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_pnc_LogicalFieldIO diff --git a/wrfv2_fire/external/io_pnetcdf/makefile b/wrfv2_fire/external/io_pnetcdf/makefile new file mode 100644 index 00000000..d2887b7c --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/makefile @@ -0,0 +1,35 @@ +#makefile to build a wrf_io with netCDF + +OBJSL = wrf_io.o field_routines.o module_wrfsi_static.o +OBJS = $(OBJSL) +CODE = ext_pnc_get_dom_ti.code ext_pnc_get_var_td.code ext_pnc_get_var_ti.code ext_pnc_put_dom_ti.code ext_pnc_put_var_td.code ext_pnc_put_var_ti.code transpose.code +FFLAGS = $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share +LIBS = -L$(NETCDFPATH)/lib -lnetcdf +CPP1 = $(CPP) -C -P $(TRADFLAG) +M4 = m4 -Uinclude -Uindex -Ulen +AR = ar + +.SUFFIXES: .F90 .f .o .code + +all : libwrfio_pnf.a + +libwrfio_pnf.a: $(OBJS) $(CODE) + /bin/rm -f libwrfio_pnf.a + $(AR) cr libwrfio_pnf.a $(OBJSL) + $(RANLIB) libwrfio_pnf.a + +wrf_io.o: wrf_io.F90 $(CODE) + $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f + $(FC) $(FFLAGS) -c wrf_io.f + +module_wrfsi_static.o: module_wrfsi_static.F90 + $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share module_wrfsi_static.F90 > module_wrfsi_static.f + $(FC) $(FFLAGS) -c module_wrfsi_static.f + +field_routines.o: field_routines.F90 + $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share field_routines.F90 > field_routines.f + $(FC) $(FFLAGS) -c field_routines.f + +superclean: + /bin/rm -f *.f *.o testWRFWrite testWRFRead \ + *.mod libwrfio_pnf.a diff --git a/wrfv2_fire/external/io_pnetcdf/module_wrfsi_static.F90 b/wrfv2_fire/external/io_pnetcdf/module_wrfsi_static.F90 new file mode 100644 index 00000000..b2c4fe8b --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/module_wrfsi_static.F90 @@ -0,0 +1,96 @@ +MODULE wrfsi_static + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +CONTAINS +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE open_wrfsi_static(dataroot,cdfid) + + IMPLICIT NONE +# include "pnetcdf.inc" + CHARACTER(LEN=*), INTENT(IN) :: dataroot + INTEGER, INTENT(OUT) :: cdfid + CHARACTER(LEN=255) :: staticfile + LOGICAL :: static_exists + INTEGER :: status + + staticfile = TRIM(dataroot) // '/static/static.wrfsi' + INQUIRE(FILE=staticfile, EXIST=static_exists) + IF (static_exists) THEN + status = nfmpi_open(TRIM(staticfile),NF_NOWRITE,cdfid) + IF (status .NE. NF_NOERR) THEN + PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status + STOP 'open_wrfsi_static' + END IF + + ELSE + +!mp +! search for rotlat version?? +! PRINT '(A)', 'Static file not found ', staticfile +! PRINT '(A)', 'Look for NMM version' + staticfile = TRIM(dataroot) // '/static/static.wrfsi.rotlat' + INQUIRE(FILE=staticfile, EXIST=static_exists) + IF (static_exists) THEN + status = nfmpi_open(TRIM(staticfile),NF_NOWRITE,cdfid) + IF (status .NE. NF_NOERR) THEN + PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status + STOP 'open_wrfsi_static' + END IF + ELSE + + PRINT '(A)', 'rotlat Static file not found, either: ', staticfile + STOP 'open_wrfsi_static' + ENDIF + + ENDIF + + RETURN + END SUBROUTINE open_wrfsi_static +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE get_wrfsi_static_dims(dataroot, nx, ny) + + ! Subroutine to return the horizontal dimensions of WRF static file + ! contained in the input dataroot + + IMPLICIT NONE +# include "pnetcdf.inc" + CHARACTER(LEN=*), INTENT(IN) :: dataroot + INTEGER , INTENT(OUT) :: nx + INTEGER , INTENT(OUT) :: ny + + INTEGER :: cdfid,vid, status + + CALL open_wrfsi_static(dataroot,cdfid) + status = nfmpi_inq_dimid(cdfid, 'x', vid) + status = nfmpi_inq_dimlen(cdfid, vid, nx) + status = nfmpi_inq_dimid(cdfid, 'y', vid) + status = nfmpi_inq_dimlen(cdfid, vid, ny) + PRINT '(A,I5,A,I5)', 'WRF X-dimension = ',nx, & + ' WRF Y-dimension = ',ny + status = nfmpi_close(cdfid) + RETURN + END SUBROUTINE get_wrfsi_static_dims +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE get_wrfsi_static_2d(dataroot, varname, data) + + IMPLICIT NONE +# include "pnetcdf.inc" + ! Gets any 2D variable from the static file + CHARACTER(LEN=*), INTENT(IN) :: dataroot + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(OUT) :: data(:,:) + + INTEGER :: cdfid, vid, status + + CALL open_wrfsi_static(dataroot,cdfid) + status = nfmpi_inq_varid(cdfid,varname,vid) + status = nfmpi_get_var_real(cdfid,vid,data) + IF (status .NE. NF_NOERR) THEN + PRINT '(A)', 'Problem getting 2D data.' + ENDIF + status = nfmpi_close(cdfid) + RETURN + END SUBROUTINE get_wrfsi_static_2d +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +END MODULE wrfsi_static diff --git a/wrfv2_fire/external/io_pnetcdf/testWRFRead.F90 b/wrfv2_fire/external/io_pnetcdf/testWRFRead.F90 new file mode 100644 index 00000000..4cecb829 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/testWRFRead.F90 @@ -0,0 +1,138 @@ +program testread_john + use wrf_data + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (80) FileName + integer Comm + character (80) SysDepInfo + integer :: DataHandle + integer Status + integer NCID + real data(200) + integer idata(200) + real*8 ddata(200) + logical ldata(200) + character (80) cdata + integer OutCount + integer i,j,k + + integer, parameter :: pad = 3 + integer, parameter :: jds=1 , jde=6 , & + ids=1 , ide=9 , & + kds=1 , kde=5 + integer, parameter :: jms=jds-pad , jme=jde+pad , & + ims=ids-pad , ime=ide+pad , & + kms=kds , kme=kde + integer, parameter :: jps=jds , jpe=jde , & + ips=ids , ipe=ide , & + kps=kds , kpe=kde + + real u( ims:ime , kms:kme , jms:jme ) + real v( ims:ime , kms:kme , jms:jme ) + real rho( ims:ime , kms:kme , jms:jme ) + real u2( ims:ime , jms:jme ) + real u1( ims:ime ) + + integer int( ims:ime , kms:kme , jms:jme ) + real*8 r8 ( ims:ime , kms:kme , jms:jme ) + + integer Dom + character*3 MemOrd + integer , Dimension(3) :: DomS,DomE,MemS,MemE,PatS,PatE + integer , Dimension(2) :: Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E + integer Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E + character (19) Time, DateStr + character (31) VarName + character (19) Date + + print *, 'Testing wrf read' + Date = '2000-09-18_16:42:01' + call ext_init(Status) + print *,'After call ext_init, Status =',Status + FileName = 'foo.nc' + Comm = 1 + SysDepInfo = 'sys info' + call ext_open_for_read( FileName, Comm, SysDepInfo, DataHandle, Status) + print *, 'Status = ',Status,DataHandle + + MemOrd = "XZY" + + DomS(1) = ids + DomE(1) = ide + DomS(2) = kds + DomE(2) = kde + DomS(3) = jds + DomE(3) = jde + + PatS(1) = ips + PatE(1) = ipe + PatS(2) = kps + PatE(2) = kpe + PatS(3) = jps + PatE(3) = jpe + + MemS(1) = ims + MemE(1) = ime + MemS(2) = kms + MemE(2) = kme + MemS(3) = jms + MemE(3) = jme + + Dom2S(1) = ids + Dom2S(2) = jds + Dom2E(1) = ide + Dom2E(2) = jde + Mem2S(1) = ims + Mem2S(2) = jms + Mem2E(1) = ime + Mem2E(2) = jme + Pat2S(1) = ips + Pat2S(2) = jps + Pat2E(1) = ipe + Pat2E(2) = jpe + + Dom1S = ids + Dom1E = ide + Mem1S = ims + Mem1E = ime + Pat1S = ips + Pat1E = ipe + + call ext_get_next_time(DataHandle, Time, Status) + print *, Time, Status + + call ext_read_field(DataHandle,Time,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' u(2,3,4) ', u(2,3,4) + call ext_read_field(DataHandle,Time,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' v(4,3,2) ', v(4,3,2) + call ext_read_field(DataHandle,Time,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' rho(3,4,5) ' , rho(3,4,5) + call ext_read_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status) + print *,'ext_read_field Status = ',Status, ' u2(6,5) ', u2(6,5) + call ext_read_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' u(2,3,4) ', u(2,3,4) + call ext_read_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status) + print *,'ext_read_field Status = ',Status, ' u1(9) ', u1(9) + + call ext_read_field(DataHandle,Time,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' int(8,5,6) ', int(8,5,6) + call ext_read_field(DataHandle,Time,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'ext_read_field Status = ',Status, ' r8(7,4,5) ', r8(7,4,5) + + call ext_get_next_time(DataHandle, Time, Status) + print *, Time, Status + + call ext_read_field(DataHandle,Time,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'> ext_read_field Status = ',Status, ' u(3,3,3) ' ,u(3,3,3) + call ext_read_field(DataHandle,Time,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'> ext_read_field Status = ',Status, ' v(4,4,4) ' ,v(4,4,4) + call ext_read_field(DataHandle,Time,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,'> ext_read_field Status = ',Status, ' rho(3,4,5) ' ,rho(3,4,5) + + call ext_close( DataHandle, Status) + print *, 'After ext_close, Status = ',Status + call ext_exit(Status) + print *,'End of test program',Status + stop + end program testread_john diff --git a/wrfv2_fire/external/io_pnetcdf/testWRFWrite.F90 b/wrfv2_fire/external/io_pnetcdf/testWRFWrite.F90 new file mode 100644 index 00000000..2f913c35 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/testWRFWrite.F90 @@ -0,0 +1,184 @@ +program testwrite_john + use wrf_data + implicit none + include 'wrf_status_codes.h' + include 'netcdf.inc' + character (80) FileName + integer Comm + character (80) SysDepInfo + integer :: DataHandle + integer Status + integer NCID + real data(200) + integer idata(200) + real*8 ddata(200) + logical ldata(200) + character (80) cdata + integer OutCount + integer i,j,k + + integer, parameter :: pad = 3 + integer, parameter :: jds=1 , jde=6 , & + ids=1 , ide=9 , & + kds=1 , kde=5 + integer, parameter :: jms=jds-pad , jme=jde+pad , & + ims=ids-pad , ime=ide+pad , & + kms=kds , kme=kde + integer, parameter :: jps=jds , jpe=jde , & + ips=ids , ipe=ide , & + kps=kds , kpe=kde + + real u( ims:ime , kms:kme , jms:jme ) + real v( ims:ime , kms:kme , jms:jme ) + real rho( ims:ime , kms:kme , jms:jme ) + real u2( ims:ime , jms:jme ) + real u1( ims:ime ) + + integer int( ims:ime , kms:kme , jms:jme ) + real*8 r8 ( ims:ime , kms:kme , jms:jme ) + + integer Dom + character*3 MemOrd + character (19) Date + character (19) Date2 + integer , Dimension(3) :: DomS,DomE,MemS,MemE,PatS,PatE + integer , Dimension(2) :: Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E + integer , Dimension(1) :: Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E + print *, 'Testing wrf write' + print *, ims,ime , kms,kme , jms,jme + Date = '2000-09-18_16:42:01' + Date2 = '2000-09-18_16:52:01' + call ext_init(Status) + print *,'After call ext_init, Status =',Status + FileName = 'foo.nc' + Comm = 1 + SysDepInfo = 'sys info' + +print*,'!!!!!!!!!!!!!!!!!!!!!!! ext_open_for_write_begin' + + call ext_open_for_write_begin( FileName, Comm, SysDepInfo, DataHandle, Status) + print *, ' ext_open_for_write_begin Status = ',Status,DataHandle + + MemOrd = "XZY" + + DomS(1) = ids + DomE(1) = ide + DomS(2) = kds + DomE(2) = kde + DomS(3) = jds + DomE(3) = jde + + PatS(1) = ips + PatE(1) = ipe + PatS(2) = kps + PatE(2) = kpe + PatS(3) = jps + PatE(3) = jpe + + MemS(1) = ims + MemE(1) = ime + MemS(2) = kms + MemE(2) = kme + MemS(3) = jms + MemE(3) = jme + + Dom2S(1) = ids + Dom2S(2) = jds + Dom2E(1) = ide + Dom2E(2) = jde + Mem2S(1) = ims + Mem2S(2) = jms + Mem2E(1) = ime + Mem2E(2) = jme + Pat2S(1) = ips + Pat2S(2) = jps + Pat2E(1) = ipe + Pat2E(2) = jpe + + Dom1S = ids + Dom1E = ide + Mem1S = ims + Mem1E = ime + Pat1S = ips + Pat1E = ipe + + call ext_write_field(DataHandle,Date,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + + call ext_open_for_write_commit(DataHandle, Status) + print *, ' ext_open_for_write_commit Status = ', Status,DataHandle + + do j=jds,jde + do k=kds,kde + do i=ids,ide + u (i,k,j) = 100*i+j+10*k + v (i,k,j) = 100*i+j+10*k + rho(i,k,j) = 100*i+j+10*k + int(i,k,j) = 100*i+j+10*k + r8 (i,k,j) = 100*i+j+10*k + enddo + enddo + enddo + do j=jds,jde + do i=ids,ide + u2(i,j) = 10*i+j + enddo + enddo + do i=ids,ide + u1(i) = i + enddo + + print *,'testWRFWrite u (2,3,4) = ',u(2,3,4) + print *,'testWRFWrite v (4,3,2) = ',v(4,3,2) + print *,'testWRFWrite rho(3,4,5) = ',rho(3,4,5) + print *,'testWRFWrite u2 (6,5) = ',u2(6,5) + print *,'testWRFWrite u1 (9) = ',u1(9) + print *,'testWRFWrite int(8,5,6) = ',int(8,5,6) + print *,'testWRFWrite r8 (7,4,5) = ',r8(7,4,5) + call ext_write_field(DataHandle,Date,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'u2',u2,WRF_REAL,Comm,Dom,'XY',Dom2S,Dom2E,Mem2S,Mem2E,Pat2S,Pat2E,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'ud2',u,WRF_REAL,Comm,Dom,"XzY",DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'u1',u1,WRF_REAL,Comm,Dom,'Z',Dom1S,Dom1E,Mem1S,Mem1E,Pat1S,Pat1E,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'int',int,WRF_INTEGER,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' first write: ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date,'double',r8,WRF_DOUBLE,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' dry run : ext_write_field Status = ',Status + + print *,'2nd : testWRFWrite u(3,3,3) = ',u(3,3,3) + print *,'2nd : testWRFWrite v(4,4,4) = ',v(4,4,4) + print *,'2nd : testWRFWrite rho(3,4,5) = ',rho(3,4,5) + call ext_write_field(DataHandle,Date2,'u',u,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' 2nd write : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date2,'v',v,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' 2nd write : ext_write_field Status = ',Status + call ext_write_field(DataHandle,Date2,'rho',rho,WRF_REAL,Comm,Dom,MemOrd,DomS,DomE,MemS,MemE,PatS,PatE,Status) + print *,' 2nd write : ext_write_field Status = ',Status + + call ext_close( DataHandle, Status) + print *, ' After ext_close, Status = ',Status + call ext_exit(Status) + print *,' End of test program',Status + stop + end program testwrite_john diff --git a/wrfv2_fire/external/io_pnetcdf/transpose.code b/wrfv2_fire/external/io_pnetcdf/transpose.code new file mode 100644 index 00000000..b15487e5 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/transpose.code @@ -0,0 +1,36 @@ + 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 + 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 +else +!dir$ concurrent + 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 +endif + + return diff --git a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 new file mode 100644 index 00000000..01ed9a87 --- /dev/null +++ b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 @@ -0,0 +1,3413 @@ +!*------------------------------------------------------------------------------ +!* 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 = 2000 + integer , parameter :: MaxTimes = 9000 + 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 + end type wrf_data_handle + type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) +end module wrf_data + +module ext_pnc_support_routines + + implicit none + include 'mpif.h' + +CONTAINS + +integer(KIND=MPI_OFFSET_KIND) function i2offset(i) + integer i + i2offset = i + return +end function i2offset + +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_pnc_ioinit?' + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + DH%Free =.false. + DH%Comm = Comm + DH%Write =.false. + DH%first_operation = .TRUE. + 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 "pnetcdf.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(KIND=MPI_OFFSET_KIND) :: VStart(2) + integer(KIND=MPI_OFFSET_KIND) :: 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 = NFMPI_PUT_VARA_TEXT_ALL(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') + NDim = 2 + case ('z','c') + NDim = 1 + case ('0') ! NDim=0 for scalars. TBH: 20060502 + NDim = 0 + case default + print *, 'memory order = ',MemOrd,' ',MemoryOrder + 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 + +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 "pnetcdf.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 = NFMPI_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,Starts,Length,MemoryOrder & + ,FieldType,NCID,VarID,XField,Status) + use wrf_data + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer,dimension(NVarDims),intent(in) :: Starts + 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 + + 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 +!jm for parallel netcef VStart(1:NDim) = 1 + VStart(1:NDim) = Starts(1:NDim) + VCount(1:NDim) = Length(1:NDim) + VStart(NDim+1) = TimeIndex + VCount(NDim+1) = 1 + select case (FieldType) + case (WRF_REAL) + call ext_pnc_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + case (WRF_DOUBLE) + call ext_pnc_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + case (WRF_INTEGER) + call ext_pnc_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + case (WRF_LOGICAL) + call ext_pnc_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status) + if(Status /= WRF_NO_ERR) return + case default +!for wrf_complex, double_complex + 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 + 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_pnc_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 + retval = dryrun + 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_pnc_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 + +end module ext_pnc_support_routines + +subroutine ext_pnc_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status ) + IF ( Status .EQ. WRF_NO_ERR ) THEN + CALL ext_pnc_open_for_read_commit( DataHandle, Status ) + ENDIF + return +end subroutine ext_pnc_open_for_read + +!ends training phase; switches internal flag to enable input +!must be paired with call to ext_pnc_open_for_read_begin +subroutine ext_pnc_open_for_read_commit(DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_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_pnc_open_for_read_commit + +subroutine ext_pnc_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + character*(*) ,intent(IN) :: 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(KIND=MPI_OFFSET_KIND) :: VStart(2) + integer(KIND=MPI_OFFSET_KIND) :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + character (NF_MAX_NAME) :: Name + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pnc_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 = NFMPI_OPEN(Comm, FileName, NF_NOWRITE, MPI_INFO_NULL, 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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_GET_VARA_TEXT_ALL(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 = NFMPI_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 = NFMPI_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 = FileName + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_pnc_open_for_read_begin + +subroutine ext_pnc_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + character*(*) ,intent(IN) :: 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 + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pnc_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 = NFMPI_OPEN(Comm, FileName, NF_WRITE, MPI_INFO_NULL, 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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_GET_VARA_TEXT_ALL(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 = NFMPI_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 = NFMPI_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 = FileName + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimesVarID = VarID + DH%TimeIndex = 0 + return +end subroutine ext_pnc_open_for_update + + +SUBROUTINE ext_pnc_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + character*(*) ,intent(in) :: 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) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pnc_open_for_write_begin: ext_pnc_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_pnc_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + DH%TimeIndex = 0 + DH%Times = ZeroDate +! stat = NFMPI_CREATE(Comm, FileName, NF_CLOBBER, MPI_INFO_NULL, DH%NCID) + stat = NFMPI_CREATE(Comm, FileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), MPI_INFO_NULL, DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = FileName + stat = NFMPI_DEF_DIM(DH%NCID,DH%DimUnlimName,i2offset(NF_UNLIMITED),DH%DimUnlimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_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 = NFMPI_DEF_DIM(DH%NCID,DH%DimNames(1),i2offset(DateStrLen),DH%DimIDs(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_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 = NFMPI_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_pnc_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(1) = DateStrLen + return +end subroutine ext_pnc_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_pnc_open_for_write (DatasetName, Comm1, Comm2, & + SysDepInfo, DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_open_for_write + +SUBROUTINE ext_pnc_open_for_write_commit(DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pnc_open_for_write_commit: ext_pnc_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_pnc_open_for_write_commit ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = NFMPI_ENDDEF(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_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_pnc_open_for_write_commit + +subroutine ext_pnc_ioclose(DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_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_pnc_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_pnc_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_pnc_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + + stat = NFMPI_CLOSE(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + CALL deallocHandle( DataHandle, Status ) + DH%Free=.true. + return +end subroutine ext_pnc_ioclose + +subroutine ext_pnc_iosync( DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_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_pnc_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_pnc_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_pnc_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + stat = NFMPI_SYNC(DH%NCID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pnc_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + return +end subroutine ext_pnc_iosync + + + +subroutine ext_pnc_redef( DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 = NFMPI_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_pnc_redef + +subroutine ext_pnc_enddef( DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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 = NFMPI_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_pnc_enddef + +subroutine ext_pnc_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 + Status = WRF_NO_ERR + return +end subroutine ext_pnc_ioinit + + +subroutine ext_pnc_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_pnc_inquiry + + + + +subroutine ext_pnc_ioexit(Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_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_pnc_ioexit + +subroutine ext_pnc_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 NFMPI_GET_ATT_REAL +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_pnc_get_dom_ti.code" +end subroutine ext_pnc_get_dom_ti_real + +subroutine ext_pnc_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 NFMPI_GET_ATT_INT +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_pnc_get_dom_ti.code" +end subroutine ext_pnc_get_dom_ti_integer + +subroutine ext_pnc_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 NFMPI_GET_ATT_DOUBLE +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) +#include "ext_pnc_get_dom_ti.code" +end subroutine ext_pnc_get_dom_ti_double + +subroutine ext_pnc_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 NFMPI_GET_ATT_INT +#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 +#include "ext_pnc_get_dom_ti.code" +end subroutine ext_pnc_get_dom_ti_logical + +subroutine ext_pnc_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_pnc_get_dom_ti.code" +#undef CHAR_TYPE +end subroutine ext_pnc_get_dom_ti_char + +subroutine ext_pnc_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 NFMPI_PUT_ATT_REAL +#define ARGS NF_FLOAT,i2offset(Count),Data +#include "ext_pnc_put_dom_ti.code" +end subroutine ext_pnc_put_dom_ti_real + +subroutine ext_pnc_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 NFMPI_PUT_ATT_INT +#define ARGS NF_INT,i2offset(Count),Data +#include "ext_pnc_put_dom_ti.code" +end subroutine ext_pnc_put_dom_ti_integer + +subroutine ext_pnc_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 NFMPI_PUT_ATT_DOUBLE +#define ARGS NF_DOUBLE,i2offset(Count),Data +#include "ext_pnc_put_dom_ti.code" +end subroutine ext_pnc_put_dom_ti_double + +subroutine ext_pnc_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 NFMPI_PUT_ATT_INT +#define ARGS NF_INT,i2offset(Count),Buffer +#define LOG +#include "ext_pnc_put_dom_ti.code" +end subroutine ext_pnc_put_dom_ti_logical + +subroutine ext_pnc_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 NFMPI_PUT_ATT_TEXT +#define ARGS i2offset(len_trim(Data)),Data +#include "ext_pnc_put_dom_ti.code" +end subroutine ext_pnc_put_dom_ti_char + +subroutine ext_pnc_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 NFMPI_PUT_ATT_REAL +#define ARGS NF_FLOAT,i2offset(Count),Data +#include "ext_pnc_put_var_ti.code" +end subroutine ext_pnc_put_var_ti_real + +subroutine ext_pnc_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 NFMPI_PUT_VARA_REAL_ALL +#define NF_TYPE NF_FLOAT +#define LENGTH Count +#define ARG +#include "ext_pnc_put_var_td.code" +end subroutine ext_pnc_put_var_td_real + +subroutine ext_pnc_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 NFMPI_PUT_ATT_DOUBLE +#define ARGS NF_DOUBLE,i2offset(Count),Data +#include "ext_pnc_put_var_ti.code" +end subroutine ext_pnc_put_var_ti_double + +subroutine ext_pnc_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 NFMPI_PUT_VARA_DOUBLE_ALL +#define NF_TYPE NF_DOUBLE +#define LENGTH Count +#define ARG +#include "ext_pnc_put_var_td.code" +end subroutine ext_pnc_put_var_td_double + +subroutine ext_pnc_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 NFMPI_PUT_ATT_INT +#define ARGS NF_INT,i2offset(Count),Data +#include "ext_pnc_put_var_ti.code" +end subroutine ext_pnc_put_var_ti_integer + +subroutine ext_pnc_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 NFMPI_PUT_VARA_INT_ALL +#define NF_TYPE NF_INT +#define LENGTH Count +#define ARG +#include "ext_pnc_put_var_td.code" +end subroutine ext_pnc_put_var_td_integer + +subroutine ext_pnc_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 NFMPI_PUT_ATT_INT +#define LOG +#define ARGS NF_INT,i2offset(Count),Buffer +#include "ext_pnc_put_var_ti.code" +end subroutine ext_pnc_put_var_ti_logical + +subroutine ext_pnc_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 NFMPI_PUT_VARA_INT_ALL +#define NF_TYPE NF_INT +#define LOG +#define LENGTH Count +#define ARG +#include "ext_pnc_put_var_td.code" +end subroutine ext_pnc_put_var_td_logical + +subroutine ext_pnc_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 NFMPI_PUT_ATT_TEXT +#define ARGS i2offset(len_trim(Data)),trim(Data) +#define CHAR_TYPE +#include "ext_pnc_put_var_ti.code" +#undef CHAR_TYPE +end subroutine ext_pnc_put_var_ti_char + +subroutine ext_pnc_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 NFMPI_PUT_VARA_TEXT_ALL +#define NF_TYPE NF_CHAR +#define LENGTH len(Data) +#include "ext_pnc_put_var_td.code" +end subroutine ext_pnc_put_var_td_char + +subroutine ext_pnc_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 NFMPI_GET_ATT_REAL +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_pnc_get_var_ti.code" +end subroutine ext_pnc_get_var_ti_real + +subroutine ext_pnc_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 NFMPI_GET_VARA_REAL_ALL +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_pnc_get_var_td.code" +end subroutine ext_pnc_get_var_td_real + +subroutine ext_pnc_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 NFMPI_GET_ATT_DOUBLE +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_pnc_get_var_ti.code" +end subroutine ext_pnc_get_var_ti_double + +subroutine ext_pnc_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 NFMPI_GET_VARA_DOUBLE_ALL +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_pnc_get_var_td.code" +end subroutine ext_pnc_get_var_td_double + +subroutine ext_pnc_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 NFMPI_GET_ATT_INT +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) +#include "ext_pnc_get_var_ti.code" +end subroutine ext_pnc_get_var_ti_integer + +subroutine ext_pnc_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 NFMPI_GET_VARA_INT_ALL +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) +#include "ext_pnc_get_var_td.code" +end subroutine ext_pnc_get_var_td_integer + +subroutine ext_pnc_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 NFMPI_GET_ATT_INT +#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 +#include "ext_pnc_get_var_ti.code" +end subroutine ext_pnc_get_var_ti_logical + +subroutine ext_pnc_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 NFMPI_GET_VARA_INT_ALL +#define LENGTH min(Count,Len1) +#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 +#include "ext_pnc_get_var_td.code" +end subroutine ext_pnc_get_var_td_logical + +subroutine ext_pnc_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 NFMPI_GET_ATT_TEXT +#define COPY +#define CHAR_TYPE +#include "ext_pnc_get_var_ti.code" +#undef CHAR_TYPE +end subroutine ext_pnc_get_var_ti_char + +subroutine ext_pnc_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 NFMPI_GET_VARA_TEXT_ALL +#define LENGTH Len1 +#define CHAR_TYPE +#include "ext_pnc_get_var_td.code" +#undef CHAR_TYPE +end subroutine ext_pnc_get_var_td_char + +subroutine ext_pnc_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_pnc_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_pnc_put_dom_td_real + +subroutine ext_pnc_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_pnc_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_pnc_put_dom_td_integer + +subroutine ext_pnc_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_pnc_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_pnc_put_dom_td_double + +subroutine ext_pnc_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_pnc_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_pnc_put_dom_td_logical + +subroutine ext_pnc_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_pnc_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_pnc_put_dom_td_char + +subroutine ext_pnc_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_pnc_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_pnc_get_dom_td_real + +subroutine ext_pnc_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_pnc_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_pnc_get_dom_td_integer + +subroutine ext_pnc_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_pnc_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_pnc_get_dom_td_double + +subroutine ext_pnc_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_pnc_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_pnc_get_dom_td_logical + +subroutine ext_pnc_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_pnc_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_pnc_get_dom_td_char + + +subroutine ext_pnc_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & + IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.inc" + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(inout) :: 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 + 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_global + 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 ',__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 + + write(msg,*)'ext_pnc_write_field: called for ',TRIM(Var) + CALL wrf_debug( 100, msg ) + +!jm 20061024 + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + Length_global(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + + + call ExtOrder(MemoryOrder,Length,Status) + call ExtOrder(MemoryOrder,Length_global,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_global(j)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = NFMPI_DEF_DIM(NCID,DH%DimNames(i),i2offset(Length_global(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_global(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_global(j)) then + NotFound = .false. + exit + else + Status = WRF_WARN_DIMNAME_REDEFINED + write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDIFINED by var ', & + TRIM(Var),' ',DH%DimLengths(i),Length_global(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 = NFMPI_DEF_DIM(NCID,DH%DimNames(i),i2offset(Length_global(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_global(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_global(j) + enddo + VDimIDs(NDim+1) = DH%DimUnlimID + select case (FieldType) + case (WRF_REAL) + XType = NF_FLOAT + case (WRF_DOUBLE) + Xtype = NF_DOUBLE + case (WRF_INTEGER) + XType = NF_INT + case (WRF_LOGICAL) + XType = NF_INT + 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 = NFMPI_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pnc_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%VarIDs(NVar) = VarID + stat = NFMPI_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,i2offset(1),FieldType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pnc_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 = NFMPI_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',i2offset(3),UCMemO) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pnc_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_global(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_global(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar) + call wrf_debug ( WARN , TRIM(msg)) + return +!jm 061024 elseif(PatchStart(j) < MemoryStart(j)) then +!jm 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 + 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 ) + StoredStart(1:NDim) = PatchStart(1:NDim) + call ExtOrder(MemoryOrder,StoredStart,Status) + call FieldIO('write',DataHandle,DateStr,StoredStart,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_pnc_write_field + +subroutine ext_pnc_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_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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(KIND=MPI_OFFSET_KIND) ,dimension(NVarDims) :: StoredLen_okind + 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(KIND=MPI_OFFSET_KIND) :: 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_pnc_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_pnc_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_pnc_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 + + Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + StoredStart(1:NDim) = PatchStart(1:NDim) + + call ExtOrder(MemoryOrder,Length,Status) + + stat = NFMPI_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 = NFMPI_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 = NFMPI_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 + select case (FieldType) + case (WRF_REAL) +! 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 + case (WRF_DOUBLE) +! 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 + case (WRF_INTEGER) + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case (WRF_LOGICAL) + if(XType /= NF_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + end select + 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 = NFMPI_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_pnc_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 = NFMPI_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen_okind(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 + StoredLen(j) = StoredLen_okind(j) + if(Length(j) > StoredLen(j)) then + Status = WRF_WARN_READ_PAST_EOF + write(msg,*) 'Warning READ PAST EOF in ext_pnc_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,Length,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) + + StoredStart(1:NDim) = PatchStart(1:NDim) + call ExtOrder(MemoryOrder,StoredStart,Status) + + 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,StoredStart,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_pnc_read_field + +subroutine ext_pnc_inquire_opened( DataHandle, FileName , FileStatus, Status ) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + FileStatus = WRF_FILE_NOT_OPENED + return + endif + if(FileName /= DH%FileName) then + FileStatus = WRF_FILE_NOT_OPENED + else + FileStatus = DH%FileStatus + endif + Status = WRF_NO_ERR + return +end subroutine ext_pnc_inquire_opened + +subroutine ext_pnc_inquire_filename( Datahandle, FileName, FileStatus, Status ) + use wrf_data + use ext_pnc_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 = DH%FileName + FileStatus = DH%FileStatus + Status = WRF_NO_ERR + return +end subroutine ext_pnc_inquire_filename + +subroutine ext_pnc_set_time(DataHandle, DateStr, Status) + use wrf_data + use ext_pnc_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_pnc_set_time + +subroutine ext_pnc_get_next_time(DataHandle, DateStr, Status) + use wrf_data + use ext_pnc_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 + write(msg,*) 'Warning ext_pnc_get_next_time: DH%CurrentTime >= DH%NumberTimes ',DH%CurrentTime,DH%NumberTimes + call wrf_debug ( WARN , TRIM(msg)) + 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,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pnc_get_next_time + +subroutine ext_pnc_get_previous_time(DataHandle, DateStr, Status) + use wrf_data + use ext_pnc_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_pnc_get_previous_time + +subroutine ext_pnc_get_next_var(DataHandle, VarName, Status) + use wrf_data + use ext_pnc_support_routines + implicit none + include 'wrf_status_codes.h' +# include "pnetcdf.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_pnc_get_next_var + +subroutine ext_pnc_end_of_frame(DataHandle, Status) + use wrf_data + use ext_pnc_support_routines + implicit none +# include "pnetcdf.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_pnc_end_of_frame + +! NOTE: For scalar variables NDim is set to zero and DomainStart and +! NOTE: DomainEnd are left unmodified. +subroutine ext_pnc_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) + use wrf_data + use ext_pnc_support_routines + implicit none +# include "pnetcdf.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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_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 = NFMPI_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_pnc_get_var_info + +subroutine ext_pnc_warning_str( Code, ReturnString, Status) + use wrf_data + use ext_pnc_support_routines + implicit none +# include "pnetcdf.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_pnc_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_pnc_error_str( Code, ReturnString, Status) + use wrf_data + use ext_pnc_support_routines + implicit none +# include "pnetcdf.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_pnc_error_str diff --git a/wrfv2_fire/external/ioapi_share/makefile b/wrfv2_fire/external/ioapi_share/makefile new file mode 100644 index 00000000..7f0e04ef --- /dev/null +++ b/wrfv2_fire/external/ioapi_share/makefile @@ -0,0 +1,25 @@ +# Makefile for variants of wrf_io_flags.h and wrf_status_codes.h that live in +# ../../inc + +all: ../../inc/wrf_io_flags.h ../../inc/wrf_status_codes.h + +# The if statement below modifies WRF data type codes for builds made with +# compiler autopromotion of REAL -> DOUBLE. +../../inc/wrf_io_flags.h : wrf_io_flags.h ../../configure.wrf + ( /bin/rm -f ../../inc/wrf_io_flags.h foo_io_flags.h; \ + /bin/cp wrf_io_flags.h foo_io_flags.h; \ + if [ $(RWORDSIZE) -ne $(NATIVE_RWORDSIZE) ] ; then \ + /bin/rm -f foo_io_flags.h; \ + sed -e 's/104/105/' wrf_io_flags.h > foo_io_flags.h ;\ + fi ; \ + /bin/mv foo_io_flags.h ../../inc/wrf_io_flags.h ) + +../../inc/wrf_status_codes.h : wrf_status_codes.h + /bin/rm -f ../../inc/wrf_status_codes.h + /bin/cp wrf_status_codes.h ../../inc + +superclean: + /bin/rm -f ../../inc/wrf_io_flags.h ../../inc/wrf_status_codes.h + +# DEPENDENCIES : only dependencies after this line + diff --git a/wrfv2_fire/external/ioapi_share/wrf_io_flags.h b/wrfv2_fire/external/ioapi_share/wrf_io_flags.h new file mode 100644 index 00000000..a131b548 --- /dev/null +++ b/wrfv2_fire/external/ioapi_share/wrf_io_flags.h @@ -0,0 +1,19 @@ + 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 +#ifdef PROMOTE_FLOAT + integer, parameter :: WRF_FLOAT=WRF_DOUBLE +#else + integer, parameter :: WRF_FLOAT=WRF_REAL +#endif + 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/wrfv2_fire/external/ioapi_share/wrf_status_codes.h b/wrfv2_fire/external/ioapi_share/wrf_status_codes.h new file mode 100644 index 00000000..059d9ea7 --- /dev/null +++ b/wrfv2_fire/external/ioapi_share/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/wrfv2_fire/fire_patch_01.tar b/wrfv2_fire/fire_patch_01.tar new file mode 100644 index 00000000..743cc31e Binary files /dev/null and b/wrfv2_fire/fire_patch_01.tar differ diff --git a/wrfv2_fire/foo.f b/wrfv2_fire/foo.f new file mode 100644 index 00000000..6960afde --- /dev/null +++ b/wrfv2_fire/foo.f @@ -0,0 +1,10 @@ + FUNCTION TIMEF() + REAL*8 TIMEF + INTEGER IC, IR + CALL SYSTEM_CLOCK(COUNT=IC, COUNT_RATE=IR) + print*,ic,ir + TIMEF=REAL(IC)/REAL(IR) * 1000.0 + END + real*8 timef + print*,timef() + end diff --git a/wrfv2_fire/frame/Makefile b/wrfv2_fire/frame/Makefile new file mode 100644 index 00000000..1e5dc4f7 --- /dev/null +++ b/wrfv2_fire/frame/Makefile @@ -0,0 +1,133 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + + + +MODULES = module_driver_constants.o \ + module_domain.o \ + module_integrate.o \ + module_timing.o \ + module_configure.o \ + module_tiles.o \ + module_machine.o \ + module_nesting.o \ + module_wrf_error.o \ + module_state_description.o \ + module_sm.o \ + module_io.o \ + module_dm.o \ + module_quilt_outbuf_ops.o \ + module_io_quilt.o + +OBJS = wrf_num_bytes_between.o \ + wrf_shutdown.o \ + wrf_debug.o \ + libmassv.o \ + collect_on_comm.o + +#compile as a .o but do not link into the main library +SPECIAL = module_internal_header_util.o pack_utils.o + + +include ../configure.wrf + +LIBTARGET = framework +TARGETDIR = ./ +$(LIBTARGET) : $(MODULES) $(OBJS) $(SPECIAL) + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) + $(RANLIB) ../main/libwrflib.a + + +wrf_num_bytes_between.o : + $(CC) -c $(CFLAGS) wrf_num_bytes_between.c + +clean: + @ echo 'use the clean script' + +module_state_description.F : ../Registry/$(REGISTRY) + if [ $(WRF_EM_CORE) -eq 1 ] ; then \ + ( cd .. ; tools/registry $(ARCHFLAGS) -DNEW_BDYS Registry/$(REGISTRY) ) ; \ + else \ + ( cd .. ; tools/registry $(ARCHFLAGS) Registry/$(REGISTRY) ) ; \ + fi + + +md_calls.inc : md_calls.m4 + $(M4) md_calls.m4 > md_calls.inc + + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + + +module_configure.o: \ + module_state_description.o \ + module_wrf_error.o \ + module_driver_constants.o + +module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \ + module_domain.o \ + module_driver_constants.o \ + module_timing.o \ + module_configure.o + +module_dm_stubs.F: module_domain.o + +module_domain.o: module_driver_constants.o \ + module_configure.o \ + module_machine.o \ + module_state_description.o \ + module_wrf_error.o \ + $(ESMF_MOD_DEPENDENCE) + +module_driver_constants.o: \ + module_state_description.o \ + module_wrf_error.o + +module_integrate.o: module_domain.o \ + module_timing.o \ + module_driver_constants.o \ + module_state_description.o \ + module_nesting.o \ + module_configure.o \ + $(ESMF_MOD_DEPENDENCE) + +module_io.o : md_calls.inc \ + module_state_description.o \ + module_configure.o \ + module_driver_constants.o + +module_io_quilt.o: module_state_description.o \ + module_internal_header_util.o \ + module_quilt_outbuf_ops.o + +module_machine.o: module_driver_constants.o + +module_nesting.o: module_machine.o \ + module_driver_constants.o \ + module_configure.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_domain.o + +module_quilt_outbuf_ops.o: module_state_description.o + +module_tiles.o: module_domain.o \ + module_driver_constants.o \ + module_machine.o \ + module_configure.o \ + module_wrf_error.o + +module_timing.o: \ + module_state_description.o \ + module_wrf_error.o + +module_wrf_error.o: \ + wrf_shutdown.o \ + $(ESMF_MOD_DEPENDENCE) + +wrf_debug.o: \ + module_wrf_error.o + +# DO NOT DELETE diff --git a/wrfv2_fire/frame/collect_on_comm.c b/wrfv2_fire/frame/collect_on_comm.c new file mode 100644 index 00000000..e55f0277 --- /dev/null +++ b/wrfv2_fire/frame/collect_on_comm.c @@ -0,0 +1,215 @@ +#include +#include +#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) +# include +#endif + +#ifndef CRAY +# ifdef NOUNDERSCORE +# define COLLECT_ON_COMM collect_on_comm +# define COLLECT_ON_COMM0 collect_on_comm0 +# define DIST_ON_COMM dist_on_comm +# define DIST_ON_COMM0 dist_on_comm0 +# 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 +# else +# ifdef F2CSTYLE +# define COLLECT_ON_COMM collect_on_comm__ +# define COLLECT_ON_COMM0 collect_on_comm0__ +# define DIST_ON_COMM dist_on_comm__ +# define DIST_ON_COMM0 dist_on_comm0__ +# 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__ +# else +# define COLLECT_ON_COMM collect_on_comm_ +# define COLLECT_ON_COMM0 collect_on_comm0_ +# define DIST_ON_COMM dist_on_comm_ +# define DIST_ON_COMM0 dist_on_comm0_ +# 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_ +# endif +# endif +#endif + +COLLECT_ON_COMM ( int * comm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf ) +{ + col_on_comm ( comm, typesize , + inbuf, ninbuf , outbuf, noutbuf, 1 ) ; +} + +/* collect on node 0*/ +COLLECT_ON_COMM0 ( int * comm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf ) +{ + col_on_comm ( comm, typesize , + inbuf, ninbuf , outbuf, noutbuf, 0 ) ; +} + +col_on_comm ( int * Fcomm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf, int sw ) +{ +#if defined( DM_PARALLEL ) && !(STUBMPI) + int mytask, ntasks, p ; + int *recvcounts ; + int *displace ; + int noutbuf_loc ; + int root_task ; + MPI_Comm *comm, dummy_comm ; + + comm = &dummy_comm ; + *comm = MPI_Comm_f2c( *Fcomm ) ; + MPI_Comm_size ( *comm, &ntasks ) ; + MPI_Comm_rank ( *comm, &mytask ) ; + recvcounts = (int *) malloc( ntasks * sizeof(int)) ; + displace = (int *) malloc( ntasks * sizeof(int)) ; + root_task = ( sw == 0 ) ? 0 : ntasks-1 ; + + /* collect up recvcounts */ + MPI_Gather( ninbuf , 1 , MPI_INT , recvcounts , 1 , MPI_INT , root_task , *comm ) ; + + if ( mytask == root_task ) { + + /* figure out displacements */ + for ( p = 1 , displace[0] = 0 , noutbuf_loc = recvcounts[0] ; p < ntasks ; p++ ) { + displace[p] = displace[p-1]+recvcounts[p-1] ; + noutbuf_loc = noutbuf_loc + recvcounts[p] ; + } + + if ( noutbuf_loc > * noutbuf ) + { + fprintf(stderr,"FATAL ERROR: collect_on_comm: noutbuf_loc (%d) > noutbuf (%d)\n", + noutbuf_loc , * noutbuf ) ; + fprintf(stderr,"WILL NOT perform the collection operation\n") ; + MPI_Abort(MPI_COMM_WORLD,1) ; + } + + /* multiply everything by the size of the type */ + for ( p = 0 ; p < ntasks ; p++ ) { + displace[p] *= *typesize ; + recvcounts[p] *= *typesize ; + } + } + + MPI_Gatherv( inbuf , *ninbuf * *typesize , MPI_CHAR , + outbuf , recvcounts , displace, MPI_CHAR , + root_task , *comm ) ; + + free(recvcounts) ; + free(displace) ; +#endif + return(0) ; +} + + +DIST_ON_COMM ( int * comm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf ) +{ + dst_on_comm ( comm, typesize , + inbuf, ninbuf , outbuf, noutbuf, 1 ) ; +} + +DIST_ON_COMM0 ( int * comm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf ) +{ + dst_on_comm ( comm, typesize , + inbuf, ninbuf , outbuf, noutbuf, 0 ) ; +} + +dst_on_comm ( int * Fcomm, int * typesize , + void * inbuf, int *ninbuf , void * outbuf, int * noutbuf, int sw ) +{ +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + int mytask, ntasks, p ; + int *sendcounts ; + int *displace ; + int noutbuf_loc ; + int root_task ; + MPI_Comm *comm, dummy_comm ; + + comm = &dummy_comm ; + *comm = MPI_Comm_f2c( *Fcomm ) ; + MPI_Comm_size ( *comm, &ntasks ) ; + MPI_Comm_rank ( *comm, &mytask ) ; + sendcounts = (int *) malloc( ntasks * sizeof(int)) ; + displace = (int *) malloc( ntasks * sizeof(int)) ; + root_task = ( sw == 0 ) ? 0 : ntasks-1 ; + + /* collect up sendcounts */ + MPI_Gather( noutbuf , 1 , MPI_INT , sendcounts , 1 , MPI_INT , root_task , *comm ) ; + + if ( mytask == root_task ) { + + /* figure out displacements */ + for ( p = 1 , displace[0] = 0 , noutbuf_loc = sendcounts[0] ; p < ntasks ; p++ ) { + displace[p] = displace[p-1]+sendcounts[p-1] ; + noutbuf_loc = noutbuf_loc + sendcounts[p] ; + } + + /* multiply everything by the size of the type */ + for ( p = 0 ; p < ntasks ; p++ ) { + displace[p] *= *typesize ; + sendcounts[p] *= *typesize ; + } + } + + MPI_Scatterv( inbuf , sendcounts , displace, MPI_CHAR , + outbuf , *noutbuf * *typesize , MPI_CHAR , + root_task , *comm ) ; + + free(sendcounts) ; + free(displace) ; +#endif + return(0) ; +} + +#ifndef MACOS +# include +# include +#endif + +#if 0 + int getrusage( + int who, + struct rusage *r_usage); +#endif + +#if 0 +extern int outy ; +extern int maxstug, nouty, maxouty ; +#endif + +#if 0 +#include +#include +/* used internally for chasing memory leaks on ibm */ +rlim_ () +{ +#ifndef MACOS + + struct rusage r_usage ; + struct mallinfo minf ; + struct tms tm ; + long tick, tock ; + + tick = sysconf( _SC_CLK_TCK ) ; + times( &tm ) ; + tock = (tm.tms_utime + tm.tms_stime)*tick ; + + getrusage ( RUSAGE_SELF, &r_usage ) ; + if ( tock != 0 ) { + fprintf(stderr,"sm %ld d %ld s %ld maxrss %ld %d %d %ld\n",r_usage.ru_ixrss/tock,r_usage.ru_idrss/tock,r_usage.ru_isrss/tock, r +_usage.ru_maxrss,tick,tock,r_usage.ru_ixrss) ; + } + minf = mallinfo() ; + fprintf(stderr,"a %ld usm %ld fsm %ld uord %ld ford %ld hblkhd %d\n",minf.arena,minf.usmblks,minf.fsmblks,minf.uordblks,minf.ford +blks,minf.hblkhd) ; +# if 0 + fprintf(stderr," outy %d nouty %d maxstug %d maxouty %d \n", outy, nouty, maxstug, maxouty ) ; +# endif +#endif +} +#endif diff --git a/wrfv2_fire/frame/libmassv.F b/wrfv2_fire/frame/libmassv.F new file mode 100644 index 00000000..afdc04d8 --- /dev/null +++ b/wrfv2_fire/frame/libmassv.F @@ -0,0 +1,385 @@ +! IBM libmassv compatibility library +! + +#ifndef NATIVE_MASSV + subroutine vdiv(z,x,y,n) + real*8 x(*),y(*),z(*) + do 10 j=1,n + z(j)=x(j)/y(j) + 10 continue + return + end + + subroutine vsdiv(z,x,y,n) + real*4 x(*),y(*),z(*) + do 10 j=1,n + z(j)=x(j)/y(j) + 10 continue + return + end + + subroutine vexp(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=exp(x(j)) + 10 continue + return + end + + subroutine vsexp(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=exp(x(j)) + 10 continue + return + end + + subroutine vlog(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=log(x(j)) + 10 continue + return + end + + subroutine vslog(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=log(x(j)) + 10 continue + return + end + + subroutine vrec(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=1.d0/x(j) + 10 continue + return + end + + subroutine vsrec(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=1.d0/x(j) + 10 continue + return + end + + subroutine vrsqrt(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=1.d0/sqrt(x(j)) + 10 continue + return + end + + subroutine vsrsqrt(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=1.d0/sqrt(x(j)) + 10 continue + return + end + + subroutine vsincos(x,y,z,n) + real*8 x(*),y(*),z(*) + do 10 j=1,n + x(j)=sin(z(j)) + y(j)=cos(z(j)) + 10 continue + return + end + + subroutine vssincos(x,y,z,n) + real*4 x(*),y(*),z(*) + do 10 j=1,n + x(j)=sin(z(j)) + y(j)=cos(z(j)) + 10 continue + return + end + + subroutine vsqrt(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=sqrt(x(j)) + 10 continue + return + end + + subroutine vssqrt(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=sqrt(x(j)) + 10 continue + return + end + + subroutine vtan(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=tan(x(j)) + 10 continue + return + end + + subroutine vstan(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=tan(x(j)) + 10 continue + return + end + + subroutine vatan2(z,y,x,n) + real*8 x(*),y(*),z(*) + do 10 j=1,n + z(j)=atan2(y(j),x(j)) + 10 continue + return + end + + subroutine vsatan2(z,y,x,n) + real*4 x(*),y(*),z(*) + do 10 j=1,n + z(j)=atan2(y(j),x(j)) + 10 continue + return + end + + subroutine vasin(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=asin(x(j)) + 10 continue + return + end + + subroutine vsin(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=sin(x(j)) + 10 continue + return + end + + subroutine vssin(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=sin(x(j)) + 10 continue + return + end + + subroutine vacos(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=acos(x(j)) + 10 continue + return + end + + subroutine vcos(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=cos(x(j)) + 10 continue + return + end + + subroutine vscos(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=cos(x(j)) + 10 continue + return + end + + subroutine vcosisin(y,x,n) + complex*16 y(*) + real*8 x(*) + do 10 j=1,n + y(j)=dcmplx(cos(x(j)),sin(x(j))) + 10 continue + return + end + + subroutine vscosisin(y,x,n) + complex*8 y(*) + real*4 x(*) + do 10 j=1,n + y(j)= cmplx(cos(x(j)),sin(x(j))) + 10 continue + return + end + + subroutine vdint(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n +! y(j)=dint(x(j)) + y(j)=int(x(j)) + 10 continue + return + end + + subroutine vdnint(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n +! y(j)=dnint(x(j)) + y(j)=nint(x(j)) + 10 continue + return + end + + subroutine vlog10(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=log10(x(j)) + 10 continue + return + end + +! subroutine vlog1p(y,x,n) +! real*8 x(*),y(*) +! interface +! real*8 function log1p(%val(x)) +! real*8 x +! end function log1p +! end interface +! do 10 j=1,n +! y(j)=log1p(x(j)) +! 10 continue +! return +! end + + subroutine vcosh(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=cosh(x(j)) + 10 continue + return + end + + subroutine vsinh(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=sinh(x(j)) + 10 continue + return + end + + subroutine vtanh(y,x,n) + real*8 x(*),y(*) + do 10 j=1,n + y(j)=tanh(x(j)) + 10 continue + return + end + +! subroutine vexpm1(y,x,n) +! real*8 x(*),y(*) +! interface +! real*8 function expm1(%val(x)) +! real*8 x +! end function expm1 +! end interface +! do 10 j=1,n +! y(j)=expm1(x(j)) +! 10 continue +! return +! end + + + subroutine vsasin(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=asin(x(j)) + 10 continue + return + end + + subroutine vsacos(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=acos(x(j)) + 10 continue + return + end + + subroutine vscosh(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=cosh(x(j)) + 10 continue + return + end + +! subroutine vsexpm1(y,x,n) +! real*4 x(*),y(*) +! interface +! real*8 function expm1(%val(x)) +! real*8 x +! end function expm1 +! end interface +! do 10 j=1,n +! y(j)=expm1(real(x(j),8)) +! 10 continue +! return +! end + + subroutine vslog10(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=log10(x(j)) + 10 continue + return + end + +! subroutine vslog1p(y,x,n) +! real*4 x(*),y(*) +! interface +! real*8 function log1p(%val(x)) +! real*8 x +! end function log1p +! end interface +! do 10 j=1,n +! y(j)=log1p(real(x(j),8)) +! 10 continue +! return +! end + + + subroutine vssinh(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=sinh(x(j)) + 10 continue + return + end + + subroutine vstanh(y,x,n) + real*4 x(*),y(*) + do 10 j=1,n + y(j)=tanh(x(j)) + 10 continue + return + end +#endif + + subroutine vspow(z,y,x,n) + real*4 x(*),y(*),z(*) + do 10 j=1,n + z(j)=y(j)**x(j) + 10 continue + return + end + + subroutine vpow(z,y,x,n) + real*8 x(*),y(*),z(*) + do 10 j=1,n + z(j)=y(j)**x(j) + 10 continue + return + end + diff --git a/wrfv2_fire/frame/md_calls.m4 b/wrfv2_fire/frame/md_calls.m4 new file mode 100644 index 00000000..84b6debb --- /dev/null +++ b/wrfv2_fire/frame/md_calls.m4 @@ -0,0 +1,354 @@ +! +! WRF io macro file +! +! This file is used to generate the series of 40 meta-data get and +! put calls in the WRF I/O API. It contains an M4 macro and then +! a series of invocations of the macro to generate the subroutine +! definitions, which are then included by the file module_io.F +! + +! $1 = get|put $2=dom|var $3=type $4=[char] $5=td|ti + +define( md_call_2, +`!--- $1_$2_$6_$3$4 + +SUBROUTINE wrf_$1_$2_$6_$3$4_$5 ( DataHandle,Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, ifelse($4,char,,`Count, ifelse($1,get,`Outcount,')') Status ) +! +!
+!
+! ifelse($1,get,`Attempt to read',`Write') ifelse($4,char,,ifelse($5,arr,`Count words of '))time ifelse($6,ti,`in')dependent
+! ifelse($2,var,`attribute "Element" of variable "Varname"',`domain metadata named "Element"') ifelse($6,td,`valid at time DateStr') 
+! ifelse($1,get,`from',`to') the open dataset described by DataHandle.  
+! ifelse($2,var,`Attribute',`Metadata') of type $3$4 ifelse($2,var,`is',`are')
+! ifelse($1,put,`copied from',`stored in') ifelse($4,char,`string',ifelse($5,arr,`array',`scalar')) Data.
+! ifelse($4,char,,ifelse($5,arr,ifelse($1,get,`Actual number of words read is returned in OutCount.')))
+!
+!
+! +USE module_state_description +IMPLICIT NONE +INTEGER , INTENT(IN) :: DataHandle +CHARACTER*(*) , INTENT(IN) :: Element +ifelse($6,td,`CHARACTER*(*) , INTENT(IN) :: DateStr') +ifelse($2,var,`CHARACTER*(*) , INTENT(IN) :: VarName') + + ifelse($4,char,`CHARACTER*(*) :: Data', `ifelse($3,double,real*8,$3) :: Data ifelse($5,arr,(*),)') + +ifelse($4,char,,`INTEGER , INTENT(IN) :: Count') +ifelse($4,char,,`ifelse($1,get,`INTEGER , INTENT(OUT) :: OutCount')') +INTEGER , INTENT(OUT) :: Status + +#include +INTEGER :: len_of_str +LOGICAL :: for_out +INTEGER, EXTERNAL :: use_package +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +INTEGER :: locCount + +INTEGER io_form , Hndl + +CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_$1_$2_$6_$3$4_$5 " ) + +ifelse($3,integer,`locCount = Count') +ifelse($3,real,`locCount = Count') +ifelse($3,logical,`locCount = Count') + +Status = 0 +CALL get_handle ( Hndl, io_form , for_out, DataHandle ) +IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_ncd_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_ncd_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_ncd_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )')) + ifelse($1,get,ifelse($4,char, `len_of_str = LEN(Data)')) + ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_string( Data, len_of_str )')) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_pnc_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_pnc_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_pnc_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_phdf5_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_phdf5_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_phdf5_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_esmf_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_esmf_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_esmf_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif +#ifdef XXX + CASE ( IO_XXX ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_xxx_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_xxx_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_xxx_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif +#ifdef YYY + CASE ( IO_YYY ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_yyy_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_yyy_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_yyy_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_gr1_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_gr1_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_gr1_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )')) + ifelse($1,get,ifelse($4,char, `len_of_str = LEN(Data)')) + ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_string( Data, len_of_str )')) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_gr2_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_gr2_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_gr2_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )')) + ifelse($1,get,ifelse($4,char, `len_of_str = LEN(Data)')) + ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_string( Data, len_of_str )')) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_int_$1_$2_$6_double$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_int_$1_$2_$6_real$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_int_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,real, `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )')) + ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )')) + ifelse($1,get,ifelse($4,char, `len_of_str = LEN(Data)')) + ifelse($1,get,ifelse($4,char, `CALL wrf_dm_bcast_string( Data, len_of_str )')) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif + CASE DEFAULT + END SELECT + ELSE IF ( for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) + ELSE + Status = 0 +ENDIF +ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS +ENDIF +RETURN +END SUBROUTINE wrf_$1_$2_$6_$3$4_$5' ) + +define( md_call, +`ifelse($4,char, +`md_call_2($1,$2,$3,$4,arr,$5)' +, +`md_call_2($1,$2,$3,$4,arr,$5) +md_call_2($1,$2,$3,$4,sca,$5)' +)' +) + +define( md_interface, +`ifelse($4,char, +`INTERFACE wrf_$1_$2_$5_$3$4 + MODULE PROCEDURE wrf_$1_$2_$5_$3$4_arr +END INTERFACE' +, +`INTERFACE wrf_$1_$2_$5_$3$4 + MODULE PROCEDURE wrf_$1_$2_$5_$3$4_arr, wrf_$1_$2_$5_$3$4_sca +END INTERFACE' +)' +) + +md_interface(get,dom,real,,ti) +md_interface(put,dom,real,,ti) +md_interface(get,dom,double,,ti) +md_interface(put,dom,double,,ti) +md_interface(get,dom,integer,,ti) +md_interface(put,dom,integer,,ti) +md_interface(get,dom,logical,,ti) +md_interface(put,dom,logical,,ti) +md_interface(get,dom,,char,ti) +md_interface(put,dom,,char,ti) + +md_interface(get,dom,real,,td) +md_interface(put,dom,real,,td) +md_interface(get,dom,double,,td) +md_interface(put,dom,double,,td) +md_interface(get,dom,integer,,td) +md_interface(put,dom,integer,,td) +md_interface(get,dom,logical,,td) +md_interface(put,dom,logical,,td) +md_interface(get,dom,,char,td) +md_interface(put,dom,,char,td) + +md_interface(get,var,real,,ti) +md_interface(put,var,real,,ti) +md_interface(get,var,double,,ti) +md_interface(put,var,double,,ti) +md_interface(get,var,integer,,ti) +md_interface(put,var,integer,,ti) +md_interface(get,var,logical,,ti) +md_interface(put,var,logical,,ti) +md_interface(get,var,,char,ti) +md_interface(put,var,,char,ti) + +md_interface(get,var,real,,td) +md_interface(put,var,real,,td) +md_interface(get,var,double,,td) +md_interface(put,var,double,,td) +md_interface(get,var,integer,,td) +md_interface(put,var,integer,,td) +md_interface(get,var,logical,,td) +md_interface(put,var,logical,,td) +md_interface(get,var,,char,td) +md_interface(put,var,,char,td) + +CONTAINS + +md_call(get,dom,real,,ti) +md_call(put,dom,real,,ti) +md_call(get,dom,double,,ti) +md_call(put,dom,double,,ti) +md_call(get,dom,integer,,ti) +md_call(put,dom,integer,,ti) +md_call(get,dom,logical,,ti) +md_call(put,dom,logical,,ti) +md_call(get,dom,,char,ti) +md_call(put,dom,,char,ti) + +md_call(get,dom,real,,td) +md_call(put,dom,real,,td) +md_call(get,dom,double,,td) +md_call(put,dom,double,,td) +md_call(get,dom,integer,,td) +md_call(put,dom,integer,,td) +md_call(get,dom,logical,,td) +md_call(put,dom,logical,,td) +md_call(get,dom,,char,td) +md_call(put,dom,,char,td) + +md_call(get,var,real,,ti) +md_call(put,var,real,,ti) +md_call(get,var,double,,ti) +md_call(put,var,double,,ti) +md_call(get,var,integer,,ti) +md_call(put,var,integer,,ti) +md_call(get,var,logical,,ti) +md_call(put,var,logical,,ti) +md_call(get,var,,char,ti) +md_call(put,var,,char,ti) + +md_call(get,var,real,,td) +md_call(put,var,real,,td) +md_call(get,var,double,,td) +md_call(put,var,double,,td) +md_call(get,var,integer,,td) +md_call(put,var,integer,,td) +md_call(get,var,logical,,td) +md_call(put,var,logical,,td) +md_call(get,var,,char,td) +md_call(put,var,,char,td) + diff --git a/wrfv2_fire/frame/module_configure.F b/wrfv2_fire/frame/module_configure.F new file mode 100644 index 00000000..8abe10d2 --- /dev/null +++ b/wrfv2_fire/frame/module_configure.F @@ -0,0 +1,345 @@ +!WRF:DRIVER_LAYER:CONFIGURATION +! +MODULE module_configure + + USE module_driver_constants + USE module_state_description + USE module_wrf_error + + TYPE model_config_rec_type + SEQUENCE +! Statements that declare namelist variables are in this file +! Note that the namelist is SEQUENCE and generated such that the first item is an +! integer, first_item_in_struct and the last is an integer last_item_in_struct +! this provides a way of converting this to a buffer for passing to and from +! the driver. +#include + END TYPE model_config_rec_type + + TYPE grid_config_rec_type +#include + END TYPE grid_config_rec_type + + TYPE(model_config_rec_type) :: model_config_rec + +#include + +! special entries (put here but not enshrined in Registry for one reason or other) + + CHARACTER (LEN=4) :: mminlu = ' ' ! character string for landuse table + +CONTAINS + + +! Model layer, even though it does I/O -- special case of namelist I/O. + + SUBROUTINE initial_config +! +! This routine reads in the namelist.input file and sets +! module_config_rec, a structure of TYPE(model_config_rec_type), which is is seen via USE association by any +! subprogram that uses module_configure. The module_config_rec structure +! contains all namelist settings for all domains. Variables that apply +! to the entire run and have only one value regardless of domain are +! scalars. Variables that allow different settings for each domain are +! defined as arrays of dimension max_domains (defined in +! frame/module_driver_constants.F, from a setting passed in from +! configure.wrf). There is another type in WRF, TYPE(grid_config_rec_type), in which +! all fields pertain only to a single domain (and are all scalars). The subroutine +! model_to_grid_config_rec(), also in frame/module_configure.F, is used to retrieve +! the settings for a given domain from a TYPE(module_config_rec_type) and put them into +! a TYPE(grid_config_rec_type), variables of which type are often called config_flags +! in the WRF code. +! +! Most of the code in this routine is generated from the Registry file +! rconfig entries and included from the following files (found in the inc directory): +! +! 
+! namelist_defines.inc	declarations of namelist variables (local to this routine)
+! namelist_statements.inc	NAMELIST statements for each variable
+! namelist_defaults.inc	assignment to default values if specified in Registry
+! config_reads.inc		read statements for each namelist record
+! config_assigns.inc	assign each variable to field in module_config_rec
+!
+! +!NOTE: generated subroutines from Registry file rconfig entries are renamed nl_ +! instead of rconfig_ due to length limits for subroutine names. +! +! Note for version WRF 2.0: there is code here to force all domains to +! have the same mp_physics setting. This is because different mp_physics +! packages have different numbers of tracers but the nest forcing and +! feedback code relies on the parent and nest having the same number and +! kind of tracers. This means that the microphysics option +! specified on the highest numbered domain is the microphysics +! option for all domains in the run. This will be revisited. +! +! + IMPLICIT NONE + + INTEGER :: io_status, nml_unit + INTEGER :: i + +! define as temporaries +#include + +! Statements that specify the namelists +#include + + OPEN ( UNIT = 10 , & + FILE = "namelist.input" , & + FORM = "FORMATTED" , & + STATUS = "OLD" , & + IOSTAT = io_status ) + + IF ( io_status .NE. 0 ) THEN + CALL WRF_ERROR_FATAL ( 'ERROR OPENING namelist.input' ) + ENDIF + + nml_unit = 10 + +! Statements that set the namelist vars to default vals +# include + +! Statements that read the namelist are in this file +# define NAMELIST_READ_ERROR_LABEL 9200 +# include + +! 2004/04/28 JM (with consensus by the group of developers) +! This is needed to ensure that nesting will work, since +! different mp_physics packages have different numbers of +! tracers. Basically, this says that the microphysics option +! specified on the highest numbered domain *is* the microphysics +! option for the run. Not the best solution but okay for 2.0. +! + + DO i = 1, max_dom + mp_physics(i) = mp_physics(max_dom) + ENDDO + +! Statements that assign the variables to the cfg record are in this file +! except the namelist_derived variables where are assigned below +#undef SOURCE_RECORD +#undef DEST_RECORD +#undef SOURCE_REC_DEX +#define SOURCE_RECORD +#define DEST_RECORD model_config_rec % +#define SOURCE_REC_DEX +#include + + CLOSE ( UNIT = 10 , IOSTAT = io_status ) + + IF ( io_status .NE. 0 ) THEN + CALL WRF_ERROR_FATAL ( 'ERROR CLOSING namelist.input' ) + ENDIF + + RETURN +9200 CONTINUE + CALL wrf_error_fatal( 'module_configure: initial_config: error reading namelist' ) + + END SUBROUTINE initial_config + +#if 1 + SUBROUTINE get_config_as_buffer( buffer, buflen, ncopied ) +! note that model_config_rec_type must be defined as a sequence derived type + INTEGER, INTENT(INOUT) :: buffer(*) + INTEGER, INTENT(IN) :: buflen + INTEGER, INTENT(OUT) :: ncopied +! TYPE(model_config_rec_type) :: model_config_rec + INTEGER :: nbytes + CALL wrf_num_bytes_between ( model_config_rec%last_item_in_struct , & + model_config_rec%first_item_in_struct , & + nbytes ) +! nbytes = loc(model_config_rec%last_item_in_struct) - & +! loc(model_config_rec%first_item_in_struct) + IF ( nbytes .gt. buflen ) THEN + CALL wrf_error_fatal( & + "get_config_rec_as_buffer: buffer size to small for config_rec" ) + ENDIF + CALL wrf_mem_copy( model_config_rec, buffer, nbytes ) + ncopied = nbytes + RETURN + END SUBROUTINE get_config_as_buffer + + SUBROUTINE set_config_as_buffer( buffer, buflen ) +! note that model_config_rec_type must be defined as a sequence derived type + INTEGER, INTENT(INOUT) :: buffer(*) + INTEGER, INTENT(IN) :: buflen +! TYPE(model_config_rec_type) :: model_config_rec + INTEGER :: nbytes + CALL wrf_num_bytes_between ( model_config_rec%last_item_in_struct , & + model_config_rec%first_item_in_struct , & + nbytes ) +! nbytes = loc(model_config_rec%last_item_in_struct) - & +! loc(model_config_rec%first_item_in_struct) + IF ( nbytes .gt. buflen ) THEN + CALL wrf_error_fatal( & + "set_config_rec_as_buffer: buffer length too small to fill model config record" ) + ENDIF + CALL wrf_mem_copy( buffer, model_config_rec, nbytes ) + RETURN + END SUBROUTINE set_config_as_buffer +#else + SUBROUTINE get_config_as_buffer( buffer, buflen, ncopied ) +! note that model_config_rec_type must be defined as a sequence derived type + INTEGER*1, INTENT(INOUT) :: buffer(*) + INTEGER, INTENT(IN) :: buflen + INTEGER, INTENT(OUT) :: ncopied +! TYPE(model_config_rec_type) :: model_config_rec + INTEGER :: nbytes + nbytes = loc(model_config_rec%last_item_in_struct) - & + loc(model_config_rec%first_item_in_struct) + IF ( nbytes .gt. buflen ) THEN + CALL wrf_error_fatal( & + "get_config_rec_as_buffer: buffer size to small for config_rec" ) + ENDIF + CALL wrf_mem_copy( model_config_rec, buffer, nbytes ) + ncopied = nbytes + RETURN + END SUBROUTINE get_config_as_buffer + + SUBROUTINE set_config_as_buffer( buffer, buflen ) +! note that model_config_rec_type must be defined as a sequence derived type + INTEGER*1, INTENT(INOUT) :: buffer(*) + INTEGER, INTENT(IN) :: buflen +! TYPE(model_config_rec_type) :: model_config_rec + INTEGER :: nbytes + nbytes = loc(model_config_rec%last_item_in_struct) - & + loc(model_config_rec%first_item_in_struct) + IF ( nbytes .gt. buflen ) THEN + CALL wrf_error_fatal( & + "set_config_rec_as_buffer: buffer length too small to fill model config record" ) + ENDIF + CALL wrf_mem_copy( buffer, model_config_rec, nbytes ) + RETURN + END SUBROUTINE set_config_as_buffer +#endif + + SUBROUTINE model_to_grid_config_rec ( id_id , model_config_rec , grid_config_rec ) + INTEGER , INTENT(IN) :: id_id + TYPE ( model_config_rec_type ) , INTENT(IN) :: model_config_rec + TYPE ( grid_config_rec_type ) , INTENT(OUT) :: grid_config_rec +! +! This routine is called to populate a domain specific configuration +! record of TYPE(grid_config_rec_type) with the configuration information +! for that domain that is stored in TYPE(model_config_rec). Both types +! are defined in frame/module_configure.F. The input argument is the +! record of type model_config_rec_type contains the model-wide +! configuration information (that is, settings that apply to the model in +! general) and configuration information for each individual domain. The +! output argument is the record of type grid_config_rec_type which +! contains the model-wide configuration information and the +! domain-specific information for this domain only. In the +! model_config_rec, the domain specific information is arrays, indexed by +! the grid id's. In the grid_config_rec the domain-specific information +! is scalar and for the specific domain. The first argument to this +! routine is the grid id (top-most domain is always 1) as specified in +! the domain-specific namelist variable grid_id. +! +! The actual assignments form the model_config_rec_type to the +! grid_config_rec_type are generate from the rconfig entries in the +! Registry file and included by this routine from the file +! inc/config_assigns.inc. +! +!NOTE: generated subroutines from Registry file rconfig entries are renamed nl_ +! instead of rconfig_ due to length limits for subroutine names. +! +! +! +#undef SOURCE_RECORD +#undef SOURCE_REC_DEX +#undef DEST_RECORD +#define SOURCE_RECORD model_config_rec % +#define SOURCE_REC_DEX (id_id) +#define DEST_RECORD grid_config_rec % +#include + END SUBROUTINE model_to_grid_config_rec + +! Include the definitions of all the routines that return a namelist values +! back to the driver. These are generated by the registry + + SUBROUTINE init_module_configure + IMPLICIT NONE + ! Local vars + + INTEGER i , j + + DO j = 1, max_domains +#include + END DO + END SUBROUTINE init_module_configure + +! When the compiler has Intel Inside (TM) (that is, ifort), the large +! number of nl_get and nl_set routines inside the module causes the +! compiler to never finish with this routine. For ifort, move the +! routines outside the module. Note, the registry generates a +! USE module_configure for all the nl_get and nl_set routines +! if IFORT_KLUDGE is in effect. +#ifdef IFORT_KLUDGE + +END MODULE module_configure + +# include + +#else + +# include + +END MODULE module_configure + +#endif + +! Special (outside registry) +SUBROUTINE nl_get_mminlu ( idum , retval ) + USE module_configure + CHARACTER(LEN=4) :: retval + INTEGER idum + retval(1:4) = mminlu(1:4) ! mminlu is defined in module_configure + RETURN +END SUBROUTINE nl_get_mminlu +SUBROUTINE nl_set_mminlu ( idum, inval ) + USE module_configure + CHARACTER(LEN=4) :: inval + INTEGER idum + mminlu(1:4) = inval(1:4) ! mminlu is defined in module_configure + RETURN +END SUBROUTINE nl_set_mminlu + + +SUBROUTINE set_scalar_indices_from_config ( idomain , dummy2, dummy1 ) + USE module_driver_constants + USE module_state_description + USE module_wrf_error + USE module_configure + IMPLICIT NONE + INTEGER , INTENT(IN) :: idomain + INTEGER :: dummy1 + INTEGER :: dummy2 + +! +!This routine is called to adjust the integer variables that are defined +!in frame/module_state_description.F (Registry-generated) and that serve +!as indices into 4D tracer arrays for moisture, chemistry, etc. +!Different domains (different grid data structures) are allowed to have +!different sets of tracers so these indices can vary from domain to +!domain. However, since the indices are defined globally in +!module_state_description (a shortcoming in the current software), it is +!necessary that these indices be reset each time a different grid is to +!be computed on. +! +!The scalar idices are set according to the particular physics +!packages -- more specifically in the case of the moisture tracers, microphysics +!packages -- that are stored for each domain in model_config_rec and +!indexed by the grid id, passed in as an argument to this routine. (The +!initial_config() routine in module_configure is what reads the +!namelist.input file and sets model_config_rec.) +! +!The actual code for calculating the scalar indices on a particular +!domain is generated from the Registry state array definitions for the +!4d tracers and from the package definitions that indicate which physics +!packages use which tracers. +! +! + +#include +#include + RETURN +END SUBROUTINE set_scalar_indices_from_config diff --git a/wrfv2_fire/frame/module_dm_stubs.F b/wrfv2_fire/frame/module_dm_stubs.F new file mode 100644 index 00000000..b15b30c9 --- /dev/null +++ b/wrfv2_fire/frame/module_dm_stubs.F @@ -0,0 +1,304 @@ +!WRF:PACKAGE:NODM +! +MODULE module_dm + + CONTAINS + SUBROUTINE init_module_dm + END SUBROUTINE init_module_dm + + REAL FUNCTION wrf_dm_max_real ( inval ) + IMPLICIT NONE + REAL inval + wrf_dm_max_real = inval + END FUNCTION wrf_dm_max_real + + REAL FUNCTION wrf_dm_min_real ( inval ) + IMPLICIT NONE + REAL inval + wrf_dm_min_real = inval + END FUNCTION wrf_dm_min_real + + REAL FUNCTION wrf_dm_sum_real ( inval ) + IMPLICIT NONE + REAL inval + wrf_dm_sum_real = inval + END FUNCTION wrf_dm_sum_real + + INTEGER FUNCTION wrf_dm_sum_integer ( inval ) + IMPLICIT NONE + INTEGER inval + wrf_dm_sum_integer = inval + END FUNCTION wrf_dm_sum_integer + + SUBROUTINE wrf_dm_maxval ( val, idex, jdex ) + IMPLICIT NONE + REAL val + INTEGER idex, jdex + RETURN + END SUBROUTINE wrf_dm_maxval + +! stub + SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy ) + USE module_domain + TYPE (domain), INTENT(INOUT) :: parent, nest + INTEGER, INTENT(IN) :: dx,dy + RETURN + END SUBROUTINE wrf_dm_move_nest + +END MODULE module_dm + +!========================================================================= + +! These are stub functions that do the right thing (usually nothing) +! in case DM_PARALLEL is not compiled for. +! This file, src/module_dm_stubs.F is copied to src/module_dm.F when +! the code is built. +! If, on the other hand, a DM package is specified, the module_dm.F +! provided with that package (e.g. RSL) is copied from /external/RSL/module_dm.F +! into src/module_dm.F. +! It is important to recognize this, because changes directly to src/module_dm.F +! will be lost! + +LOGICAL FUNCTION wrf_dm_on_monitor() + wrf_dm_on_monitor = .true. +END FUNCTION wrf_dm_on_monitor + +INTEGER FUNCTION wrf_dm_monitor_rank() + wrf_dm_monitor_rank = 0 +END FUNCTION wrf_dm_monitor_rank + +SUBROUTINE wrf_get_myproc( myproc ) + IMPLICIT NONE + INTEGER myproc + myproc = 0 + RETURN +END SUBROUTINE wrf_get_myproc + +SUBROUTINE wrf_get_nproc( nprocs ) + IMPLICIT NONE + INTEGER nprocs + nprocs = 1 + RETURN +END SUBROUTINE wrf_get_nproc + +SUBROUTINE wrf_get_nprocx( nprocs ) + IMPLICIT NONE + INTEGER nprocs + nprocs = 1 + RETURN +END SUBROUTINE wrf_get_nprocx + +SUBROUTINE wrf_get_nprocy( nprocs ) + IMPLICIT NONE + INTEGER nprocs + nprocs = 1 + RETURN +END SUBROUTINE wrf_get_nprocy + +SUBROUTINE wrf_dm_bcast_string ( buf , size ) + IMPLICIT NONE + INTEGER size + INTEGER BUF(*) + RETURN +END SUBROUTINE wrf_dm_bcast_string + +SUBROUTINE wrf_dm_bcast_bytes ( buf , size ) + IMPLICIT NONE + INTEGER size + INTEGER BUF(*) + RETURN +END SUBROUTINE wrf_dm_bcast_bytes + +SUBROUTINE wrf_dm_bcast_integer( BUF, N1 ) + IMPLICIT NONE + INTEGER n1 + INTEGER buf(*) + RETURN +END SUBROUTINE wrf_dm_bcast_integer + +SUBROUTINE wrf_dm_bcast_real( BUF, N1 ) + IMPLICIT NONE + INTEGER n1 + REAL buf(*) + RETURN +END SUBROUTINE wrf_dm_bcast_real + +SUBROUTINE wrf_dm_bcast_logical( BUF, N1 ) + IMPLICIT NONE + INTEGER n1 + LOGICAL buf(*) + RETURN +END SUBROUTINE wrf_dm_bcast_logical + +SUBROUTINE wrf_dm_halo ( domdesc , comms , stencil_id ) + IMPLICIT NONE + INTEGER domdesc , comms(*) , stencil_id + RETURN +END SUBROUTINE wrf_dm_halo + +SUBROUTINE wrf_dm_boundary ( domdesc , comms , period_id , & + periodic_x , periodic_y ) + IMPLICIT NONE + INTEGER domdesc , comms(*) , period_id + LOGICAL , INTENT(IN) :: periodic_x, periodic_y + RETURN +END SUBROUTINE wrf_dm_boundary + +SUBROUTINE wrf_dm_xpose_z2x ( domdesc , comms , xpose_id ) + IMPLICIT NONE + INTEGER domdesc , comms(*), xpose_id + RETURN +END SUBROUTINE wrf_dm_xpose_z2x +SUBROUTINE wrf_dm_xpose_x2y ( domdesc , comms , xpose_id ) + IMPLICIT NONE + INTEGER domdesc , comms(*), xpose_id + RETURN +END SUBROUTINE wrf_dm_xpose_x2y +SUBROUTINE wrf_dm_xpose_y2z ( domdesc , comms , xpose_id ) + IMPLICIT NONE + INTEGER domdesc , comms(*), xpose_id + RETURN +END SUBROUTINE wrf_dm_xpose_y2z + +SUBROUTINE wrf_dm_define_comms ( grid ) + USE module_domain + IMPLICIT NONE + TYPE(domain) , INTENT (INOUT) :: grid + RETURN +END SUBROUTINE wrf_dm_define_comms + +SUBROUTINE wrf_get_dm_communicator ( communicator ) + IMPLICIT NONE + INTEGER , INTENT(OUT) :: communicator + communicator = 0 + RETURN +END SUBROUTINE wrf_get_dm_communicator + +SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator ) + IMPLICIT NONE + INTEGER , INTENT(OUT) :: iocommunicator + iocommunicator = 0 + RETURN +END SUBROUTINE wrf_get_dm_iocommunicator + +SUBROUTINE wrf_dm_shutdown + RETURN +END SUBROUTINE wrf_dm_shutdown +SUBROUTINE wrf_abort + STOP 'wrf_abort' +END SUBROUTINE wrf_abort + +SUBROUTINE wrf_patch_to_global_real (buf,globbuf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + REAL globbuf(*) + REAL buf(*) + RETURN +END SUBROUTINE wrf_patch_to_global_real + +SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + REAL globbuf(*) + REAL buf(*) + RETURN +END SUBROUTINE wrf_global_to_patch_real + + +SUBROUTINE wrf_patch_to_global_double (buf,globbuf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + DOUBLE PRECISION globbuf(*) + DOUBLE PRECISION buf(*) + RETURN +END SUBROUTINE wrf_patch_to_global_double + +SUBROUTINE wrf_global_to_patch_double (globbuf,buf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + DOUBLE PRECISION globbuf(*) + DOUBLE PRECISION buf(*) + RETURN +END SUBROUTINE wrf_global_to_patch_double + +SUBROUTINE wrf_patch_to_global_integer (buf,globbuf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + INTEGER globbuf(*) + INTEGER buf(*) + RETURN +END SUBROUTINE wrf_patch_to_global_integer + +SUBROUTINE wrf_global_to_patch_integer (globbuf,buf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + INTEGER globbuf(*) + INTEGER buf(*) + RETURN +END SUBROUTINE wrf_global_to_patch_integer + +SUBROUTINE wrf_patch_to_global_logical (buf,globbuf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + LOGICAL globbuf(*) + LOGICAL buf(*) + RETURN +END SUBROUTINE wrf_patch_to_global_logical + +SUBROUTINE wrf_global_to_patch_LOGICAL (globbuf,buf,domdesc,ndim,& + ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe ) + IMPLICIT NONE + INTEGER ids,ide,jds,jde,kds,kde,& + ims,ime,jms,jme,kms,kme,& + ips,ipe,jps,jpe,kps,kpe + INTEGER fid,domdesc,ndim,glen(3),llen(3) + LOGICAL globbuf(*) + LOGICAL buf(*) + RETURN +END SUBROUTINE wrf_global_to_patch_LOGICAL + + diff --git a/wrfv2_fire/frame/module_dm_warning b/wrfv2_fire/frame/module_dm_warning new file mode 100644 index 00000000..955e8d0b --- /dev/null +++ b/wrfv2_fire/frame/module_dm_warning @@ -0,0 +1,14 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! W A R N I N G +!! +!! This is a temporary version of module_dm.F +!! It has been compied from somewhere else +!! (If not DM_PARALLEL then this is module_dm_stubs.F; +!! otherwise, it is from one of the external package +!! directories.) +!! +!! B E A D V I S E D +!! +!! Changes to this file are liable to be LOST. +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/wrfv2_fire/frame/module_domain.F b/wrfv2_fire/frame/module_domain.F new file mode 100644 index 00000000..b0a1e0aa --- /dev/null +++ b/wrfv2_fire/frame/module_domain.F @@ -0,0 +1,2374 @@ +!WRF:DRIVER_LAYER:DOMAIN_OBJECT +! +! Following are the routines contained within this MODULE: + +! alloc_and_configure_domain 1. Allocate the space for a single domain (constants +! and null terminate pointers). +! 2. Connect the domains as a linked list. +! 3. Store all of the domain constants. +! 4. CALL alloc_space_field. + +! alloc_space_field 1. Allocate space for the gridded data required for +! each domain. + +! dealloc_space_domain 1. Reconnect linked list nodes since the current +! node is removed. +! 2. CALL dealloc_space_field. +! 3. Deallocate single domain. + +! dealloc_space_field 1. Deallocate each of the fields for a particular +! domain. + +! first_loc_integer 1. Find the first incidence of a particular +! domain identifier from an array of domain +! identifiers. + +MODULE module_domain + + USE module_driver_constants + USE module_machine + USE module_state_description + USE module_configure + USE module_wrf_error + USE module_utility + + CHARACTER (LEN=80) program_name + + ! An entire domain. This contains multiple meteorological fields by having + ! arrays (such as "data_3d") of pointers for each field. Also inside each + ! domain is a link to a couple of other domains, one is just the + ! "next" domain that is to be stored, the other is the next domain which + ! happens to also be on the "same_level". + + TYPE domain_ptr + TYPE(domain), POINTER :: ptr + END TYPE domain_ptr + + INTEGER, PARAMETER :: HISTORY_ALARM=1, AUXHIST1_ALARM=2, AUXHIST2_ALARM=3, & + AUXHIST3_ALARM=4, AUXHIST4_ALARM=5, AUXHIST5_ALARM=6, & + AUXHIST6_ALARM=7, AUXHIST7_ALARM=8, AUXHIST8_ALARM=9, & + AUXHIST9_ALARM=10, AUXHIST10_ALARM=11, AUXHIST11_ALARM=12, & + AUXINPUT1_ALARM=13, AUXINPUT2_ALARM=14, AUXINPUT3_ALARM=15, & + AUXINPUT4_ALARM=16, AUXINPUT5_ALARM=17, & + AUXINPUT6_ALARM=18, AUXINPUT7_ALARM=19, AUXINPUT8_ALARM=20, & + AUXINPUT9_ALARM=21, AUXINPUT10_ALARM=22, AUXINPUT11_ALARM=23, & + RESTART_ALARM=24, BOUNDARY_ALARM=25, INPUTOUT_ALARM=26, & ! for outputing input (e.g. for 3dvar) + ALARM_SUBTIME=27, & +#ifdef MOVE_NESTS + COMPUTE_VORTEX_CENTER_ALARM=28, & + MAX_WRF_ALARMS=28 ! WARNING: MAX_WRF_ALARMS must be + ! large enough to include all of + ! the alarms declared above. +#else + MAX_WRF_ALARMS=27 ! WARNING: MAX_WRF_ALARMS must be + ! large enough to include all of + ! the alarms declared above. +#endif + +#include + + TYPE domain + +! SEE THE INCLUDE FILE FOR DEFINITIONS OF STATE FIELDS WITHIN THE DOMAIN DATA STRUCTURE +#include + + INTEGER :: comms( max_comms ), shift_x, shift_y + + INTEGER :: id + INTEGER :: domdesc + INTEGER :: communicator + INTEGER :: iocommunicator + INTEGER,POINTER :: mapping(:,:) + INTEGER,POINTER :: i_start(:),i_end(:) + INTEGER,POINTER :: j_start(:),j_end(:) + INTEGER :: max_tiles + INTEGER :: num_tiles ! taken out of namelist 20000908 + INTEGER :: num_tiles_x ! taken out of namelist 20000908 + INTEGER :: num_tiles_y ! taken out of namelist 20000908 + INTEGER :: num_tiles_spec ! place to store number of tiles computed from + ! externally specified params + + TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: parents + TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: nests + TYPE(domain) , POINTER :: sibling ! overlapped domains at same lev + TYPE(domain) , POINTER :: intermediate_grid + INTEGER :: num_parents, num_nests, num_siblings + INTEGER , DIMENSION( max_parents ) :: child_of_parent + INTEGER , DIMENSION( max_nests ) :: active + + INTEGER , DIMENSION(0:5) :: nframes ! frames per outfile for history + ! streams (0 is main history) + + TYPE(domain) , POINTER :: next + TYPE(domain) , POINTER :: same_level + + LOGICAL , DIMENSION ( 4 ) :: bdy_mask ! which boundaries are on processor + + LOGICAL :: first_force + + ! domain dimensions + + INTEGER :: sd31, ed31, sd32, ed32, sd33, ed33, & + sd21, ed21, sd22, ed22, & + sd11, ed11 + + INTEGER :: sp31, ep31, sp32, ep32, sp33, ep33, & + sp21, ep21, sp22, ep22, & + sp11, ep11, & + sm31, em31, sm32, em32, sm33, em33, & + sm21, em21, sm22, em22, & + sm11, em11, & + sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, & + sp21x, ep21x, sp22x, ep22x, & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm21x, em21x, sm22x, em22x, & + sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & + sp21y, ep21y, sp22y, ep22y, & + sm31y, em31y, sm32y, em32y, sm33y, em33y, & + sm21y, em21y, sm22y, em22y + Type(WRFU_Clock), POINTER :: domain_clock + Type(WRFU_Time) :: start_subtime, stop_subtime + Type(WRFU_Time) :: this_bdy_time, next_bdy_time + Type(WRFU_Time) :: this_emi_time, next_emi_time + Type(WRFU_TimeInterval), DIMENSION(MAX_WRF_ALARMS) :: io_intervals + Type(WRFU_Alarm), POINTER :: alarms(:) +! This awful hackery accounts for the fact that ESMF2.2.0 objects cannot tell +! us if they have ever been created or not. So, we have to keep track of this +! ourselves to avoid destroying an object that has never been created! Rip +! this out once ESMF has useful introspection for creation... + LOGICAL :: domain_clock_created + LOGICAL, POINTER :: alarms_created(:) + + ! Have clocks and times been initialized yet? + LOGICAL :: time_set + ! This flag controls first-time-step behavior for ESMF runs + ! which require components to return to the top-level driver + ! after initializing import and export states. In WRF, this + ! initialization is done in the "training phase" of + ! med_before_solve_io(). + LOGICAL :: return_after_training_io + + END TYPE domain + + ! Now that a "domain" TYPE exists, we can use it to store a few pointers + ! to this type. These are primarily for use in traversing the linked list. + ! The "head_grid" is always the pointer to the first domain that is + ! allocated. This is available and is not to be changed. The others are + ! just temporary pointers. + + TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid + + ! To facilitate an easy integration of each of the domains that are on the + ! same level, we have an array for the head pointer for each level. This + ! removed the need to search through the linked list at each time step to + ! find which domains are to be active. + + TYPE domain_levels + TYPE(domain) , POINTER :: first_domain + END TYPE domain_levels + + TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level + + ! Use this to support debugging features, giving easy access to clock, etc. + TYPE(domain), POINTER :: current_grid + LOGICAL, SAVE :: current_grid_set = .FALSE. + + ! internal routines + PRIVATE domain_time_test_print + PRIVATE test_adjust_io_timestr + + INTERFACE get_ijk_from_grid + MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2 + END INTERFACE + + +CONTAINS + + SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy ) + IMPLICIT NONE + + TYPE( domain ), POINTER :: grid + INTEGER, INTENT(IN) :: dx, dy + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + grid%sm31 = grid%sm31 + dx + grid%em31 = grid%em31 + dx + grid%sm32 = grid%sm32 + dy + grid%em32 = grid%em32 + dy + grid%sp31 = grid%sp31 + dx + grid%ep31 = grid%ep31 + dx + grid%sp32 = grid%sp32 + dy + grid%ep32 = grid%ep32 + dy + grid%sd31 = grid%sd31 + dx + grid%ed31 = grid%ed31 + dx + grid%sd32 = grid%sd32 + dy + grid%ed32 = grid%ed32 + dy + + CASE ( DATA_ORDER_YXZ ) + grid%sm31 = grid%sm31 + dy + grid%em31 = grid%em31 + dy + grid%sm32 = grid%sm32 + dx + grid%em32 = grid%em32 + dx + grid%sp31 = grid%sp31 + dy + grid%ep31 = grid%ep31 + dy + grid%sp32 = grid%sp32 + dx + grid%ep32 = grid%ep32 + dx + grid%sd31 = grid%sd31 + dy + grid%ed31 = grid%ed31 + dy + grid%sd32 = grid%sd32 + dx + grid%ed32 = grid%ed32 + dx + + CASE ( DATA_ORDER_ZXY ) + grid%sm32 = grid%sm32 + dx + grid%em32 = grid%em32 + dx + grid%sm33 = grid%sm33 + dy + grid%em33 = grid%em33 + dy + grid%sp32 = grid%sp32 + dx + grid%ep32 = grid%ep32 + dx + grid%sp33 = grid%sp33 + dy + grid%ep33 = grid%ep33 + dy + grid%sd32 = grid%sd32 + dx + grid%ed32 = grid%ed32 + dx + grid%sd33 = grid%sd33 + dy + grid%ed33 = grid%ed33 + dy + + CASE ( DATA_ORDER_ZYX ) + grid%sm32 = grid%sm32 + dy + grid%em32 = grid%em32 + dy + grid%sm33 = grid%sm33 + dx + grid%em33 = grid%em33 + dx + grid%sp32 = grid%sp32 + dy + grid%ep32 = grid%ep32 + dy + grid%sp33 = grid%sp33 + dx + grid%ep33 = grid%ep33 + dx + grid%sd32 = grid%sd32 + dy + grid%ed32 = grid%ed32 + dy + grid%sd33 = grid%sd33 + dx + grid%ed33 = grid%ed33 + dx + + CASE ( DATA_ORDER_XZY ) + grid%sm31 = grid%sm31 + dx + grid%em31 = grid%em31 + dx + grid%sm33 = grid%sm33 + dy + grid%em33 = grid%em33 + dy + grid%sp31 = grid%sp31 + dx + grid%ep31 = grid%ep31 + dx + grid%sp33 = grid%sp33 + dy + grid%ep33 = grid%ep33 + dy + grid%sd31 = grid%sd31 + dx + grid%ed31 = grid%ed31 + dx + grid%sd33 = grid%sd33 + dy + grid%ed33 = grid%ed33 + dy + + CASE ( DATA_ORDER_YZX ) + grid%sm31 = grid%sm31 + dy + grid%em31 = grid%em31 + dy + grid%sm33 = grid%sm33 + dx + grid%em33 = grid%em33 + dx + grid%sp31 = grid%sp31 + dy + grid%ep31 = grid%ep31 + dy + grid%sp33 = grid%sp33 + dx + grid%ep33 = grid%ep33 + dx + grid%sd31 = grid%sd31 + dy + grid%ed31 = grid%ed31 + dy + grid%sd33 = grid%sd33 + dx + grid%ed33 = grid%ed33 + dx + + END SELECT data_ordering + +#if 0 + CALL dealloc_space_field ( grid ) + + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + RETURN + END SUBROUTINE adjust_domain_dims_for_move + + SUBROUTINE get_ijk_from_grid1 ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + IMPLICIT NONE + TYPE( domain ), INTENT (IN) :: grid + INTEGER, INTENT(OUT) :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey + + CALL get_ijk_from_grid2 ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ; + ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; + imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ; + ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; + CASE ( DATA_ORDER_YXZ ) + imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ; + ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; + imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ; + ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; + CASE ( DATA_ORDER_ZXY ) + imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ; + ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; + imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ; + ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; + CASE ( DATA_ORDER_ZYX ) + imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ; + ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; + imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ; + ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; + CASE ( DATA_ORDER_XZY ) + imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ; + ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; + imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ; + ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; + CASE ( DATA_ORDER_YZX ) + imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ; + ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; + imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ; + ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; + END SELECT data_ordering + END SUBROUTINE get_ijk_from_grid1 + + SUBROUTINE get_ijk_from_grid2 ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + IMPLICIT NONE + + TYPE( domain ), INTENT (IN) :: grid + INTEGER, INTENT(OUT) :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ; + ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ; + ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ; + CASE ( DATA_ORDER_YXZ ) + ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd33 ; kde = grid%ed33 ; + ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm33 ; kme = grid%em33 ; + ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp33 ; kpe = grid%ep33 ; + CASE ( DATA_ORDER_ZXY ) + ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd31 ; kde = grid%ed31 ; + ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm31 ; kme = grid%em31 ; + ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp31 ; kpe = grid%ep31 ; + CASE ( DATA_ORDER_ZYX ) + ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd31 ; kde = grid%ed31 ; + ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm31 ; kme = grid%em31 ; + ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp31 ; kpe = grid%ep31 ; + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd32 ; kde = grid%ed32 ; + ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm32 ; kme = grid%em32 ; + ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp32 ; kpe = grid%ep32 ; + CASE ( DATA_ORDER_YZX ) + ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd32 ; kde = grid%ed32 ; + ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm32 ; kme = grid%em32 ; + ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp32 ; kpe = grid%ep32 ; + END SELECT data_ordering + END SUBROUTINE get_ijk_from_grid2 + +! return the values for subgrid whose refinement is in grid%sr +! note when using this routine, it does not affect K. For K +! (vertical), it just returns what get_ijk_from_grid does + SUBROUTINE get_ijk_from_subgrid ( grid , & + ids0, ide0, jds0, jde0, kds0, kde0, & + ims0, ime0, jms0, jme0, kms0, kme0, & + ips0, ipe0, jps0, jpe0, kps0, kpe0 ) + TYPE( domain ), INTENT (IN) :: grid + INTEGER, INTENT(OUT) :: & + ids0, ide0, jds0, jde0, kds0, kde0, & + ims0, ime0, jms0, jme0, kms0, kme0, & + ips0, ipe0, jps0, jpe0, kps0, kpe0 + ! Local + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ids0 = ids + ide0 = ide * grid%sr_x + ims0 = (ims-1)*grid%sr_x+1 + ime0 = ime * grid%sr_x + ips0 = (ips-1)*grid%sr_x+1 + ipe0 = ipe * grid%sr_x + + jds0 = jds + jde0 = jde * grid%sr_y + jms0 = (jms-1)*grid%sr_y+1 + jme0 = jme * grid%sr_y + jps0 = (jps-1)*grid%sr_y+1 + jpe0 = jpe * grid%sr_y + + kds0 = kds + kde0 = kde + kms0 = kms + kme0 = kme + kps0 = kps + kpe0 = kpe + RETURN + END SUBROUTINE get_ijk_from_subgrid + + +! Default version ; Otherwise module containing interface to DM library will provide + + SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , & + sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & + sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & + sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & + sp1x , ep1x , sm1x , em1x , & + sp2x , ep2x , sm2x , em2x , & + sp3x , ep3x , sm3x , em3x , & + sp1y , ep1y , sm1y , em1y , & + sp2y , ep2y , sm2y , em2y , & + sp3y , ep3y , sm3y , em3y , & + bdx , bdy , bdy_mask ) +! +! Wrf_patch_domain is called as part of the process of initiating a new +! domain. Based on the global domain dimension information that is +! passed in it computes the patch and memory dimensions on this +! distributed-memory process for parallel compilation when DM_PARALLEL is +! defined in configure.wrf. In this case, it relies on an external +! communications package-contributed routine, wrf_dm_patch_domain. For +! non-parallel compiles, it returns the patch and memory dimensions based +! on the entire domain. In either case, the memory dimensions will be +! larger than the patch dimensions, since they allow for distributed +! memory halo regions (DM_PARALLEL only) and for boundary regions around +! the domain (used for idealized cases only). The width of the boundary +! regions to be accommodated is passed in as bdx and bdy. +! +! The bdy_mask argument is a four-dimensional logical array, each element +! of which is set to true for any boundaries that this process's patch +! contains (all four are true in the non-DM_PARALLEL case) and false +! otherwise. The indices into the bdy_mask are defined in +! frame/module_state_description.F. P_XSB corresponds boundary that +! exists at the beginning of the X-dimension; ie. the western boundary; +! P_XEB to the boundary that corresponds to the end of the X-dimension +! (east). Likewise for Y (south and north respectively). +! +! The correspondence of the first, second, and third dimension of each +! set (domain, memory, and patch) with the coordinate axes of the model +! domain is based on the setting of the variable model_data_order, which +! comes into this routine through USE association of +! module_driver_constants in the enclosing module of this routine, +! module_domain. Model_data_order is defined by the Registry, based on +! the dimspec entries which associate dimension specifiers (e.g. 'k') in +! the Registry with a coordinate axis and specify which dimension of the +! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and +! em1 correspond to the starts and ends of the global, patch, and memory +! dimensions in X; those with 2 specify Z (vertical); and those with 3 +! specify Y. Note that the WRF convention is to overdimension to allow +! for staggered fields so that sdn:edn are the starts +! and ends of the staggered domains in X. The non-staggered grid runs +! sdn:edn-1. The extra row or column on the north or +! east boundaries is not used for non-staggered fields. +! +! The domdesc and parent_domdesc arguments are for external communication +! packages (e.g. RSL) that establish and return to WRF integer handles +! for referring to operations on domains. These descriptors are not set +! or used otherwise and they are opaque, which means they are never +! accessed or modified in WRF; they are only only passed between calls to +! the external package. +! + + USE module_machine + IMPLICIT NONE + LOGICAL, DIMENSION(4), INTENT(OUT) :: bdy_mask + INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy + INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , & ! z-xpose (std) + sm1 , em1 , sm2 , em2 , sm3 , em3 + INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , & ! x-xpose + sm1x , em1x , sm2x , em2x , sm3x , em3x + INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , & ! y-xpose + sm1y , em1y , sm2y , em2y , sm3y , em3y + INTEGER, INTENT(IN) :: id , parent_id , parent_domdesc + INTEGER, INTENT(INOUT) :: domdesc + TYPE(domain), POINTER :: parent + +!local data + + INTEGER spec_bdy_width + + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + +#ifndef DM_PARALLEL + + bdy_mask = .true. ! only one processor so all 4 boundaries are there + +! this is a trivial version -- 1 patch per processor; +! use version in module_dm to compute for DM + sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3 + ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3 + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + sm1 = sp1 - bdx ; em1 = ep1 + bdx + sm2 = sp2 - bdy ; em2 = ep2 + bdy + sm3 = sp3 ; em3 = ep3 + CASE ( DATA_ORDER_YXZ ) + sm1 = sp1 - bdy ; em1 = ep1 + bdy + sm2 = sp2 - bdx ; em2 = ep2 + bdx + sm3 = sp3 ; em3 = ep3 + CASE ( DATA_ORDER_ZXY ) + sm1 = sp1 ; em1 = ep1 + sm2 = sp2 - bdx ; em2 = ep2 + bdx + sm3 = sp3 - bdy ; em3 = ep3 + bdy + CASE ( DATA_ORDER_ZYX ) + sm1 = sp1 ; em1 = ep1 + sm2 = sp2 - bdy ; em2 = ep2 + bdy + sm3 = sp3 - bdx ; em3 = ep3 + bdx + CASE ( DATA_ORDER_XZY ) + sm1 = sp1 - bdx ; em1 = ep1 + bdx + sm2 = sp2 ; em2 = ep2 + sm3 = sp3 - bdy ; em3 = ep3 + bdy + CASE ( DATA_ORDER_YZX ) + sm1 = sp1 - bdy ; em1 = ep1 + bdy + sm2 = sp2 ; em2 = ep2 + sm3 = sp3 - bdx ; em3 = ep3 + bdx + END SELECT + sm1x = sm1 ; em1x = em1 ! just copy + sm2x = sm2 ; em2x = em2 + sm3x = sm3 ; em3x = em3 + sm1y = sm1 ; em1y = em1 ! just copy + sm2y = sm2 ; em2y = em2 + sm3y = sm3 ; em3y = em3 +! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned + sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3 + sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3 + +#else +! This is supplied by the package specific version of module_dm, which +! is supplied by the external package and copied into the src directory +! when the code is compiled. The cp command will be found in the externals +! target of the configure.wrf file for this architecture. Eg: for RSL +! routine is defined in external/RSL/module_dm.F . +! Note, it would be very nice to be able to pass parent to this routine; +! however, there doesn't seem to be a way to do that in F90. That is because +! to pass a pointer to a domain structure, this call requires an interface +! definition for wrf_dm_patch_domain (otherwise it will try to convert the +! pointer to something). In order to provide an interface definition, we +! would need to either USE module_dm or use an interface block. In either +! case it generates a circular USE reference, since module_dm uses +! module_domain. JM 20020416 + + CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , & + sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & + sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & + sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & + sp1x , ep1x , sm1x , em1x , & + sp2x , ep2x , sm2x , em2x , & + sp3x , ep3x , sm3x , em3x , & + sp1y , ep1y , sm1y , em1y , & + sp2y , ep2y , sm2y , em2y , & + sp3y , ep3y , sm3y , em3y , & + bdx , bdy ) + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 ) + bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 ) + bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 ) + bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 ) + CASE ( DATA_ORDER_YXZ ) + bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 ) + bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 ) + bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 ) + bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 ) + CASE ( DATA_ORDER_ZXY ) + bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 ) + bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 ) + bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 ) + bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 ) + CASE ( DATA_ORDER_ZYX ) + bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 ) + bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 ) + bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 ) + bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 ) + CASE ( DATA_ORDER_XZY ) + bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 ) + bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 ) + bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 ) + bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 ) + CASE ( DATA_ORDER_YZX ) + bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 ) + bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 ) + bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 ) + bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 ) + END SELECT + +#endif + + RETURN + END SUBROUTINE wrf_patch_domain +! + SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) + +! +! This subroutine is used to allocate a domain data structure of +! TYPE(DOMAIN) pointed to by the argument grid, link it into the +! nested domain hierarchy, and set it's configuration information from +! the appropriate settings in the WRF namelist file. Specifically, if the +! domain being allocated and configured is nest, the parent +! argument will point to the already existing domain data structure for +! the parent domain and the kid argument will be set to an +! integer indicating which child of the parent this grid will be (child +! indices start at 1). If this is the top-level domain, the parent and +! kid arguments are ignored. WRF domains may have multiple children +! but only ever have one parent. +! +! The domain_id argument is the +! integer handle by which this new domain will be referred; it comes from +! the grid_id setting in the namelist, and these grid ids correspond to +! the ordering of settings in the namelist, starting with 1 for the +! top-level domain. The id of 1 always corresponds to the top-level +! domain. and these grid ids correspond to the ordering of settings in +! the namelist, starting with 1 for the top-level domain. +! +! Model_data_order is provide by USE association of +! module_driver_constants and is set from dimspec entries in the +! Registry. +! +! The allocation of the TYPE(DOMAIN) itself occurs in this routine. +! However, the numerous multi-dimensional arrays that make up the members +! of the domain are allocated in the call to alloc_space_field, after +! wrf_patch_domain has been called to determine the dimensions in memory +! that should be allocated. It bears noting here that arrays and code +! that indexes these arrays are always global, regardless of how the +! model is decomposed over patches. Thus, when arrays are allocated on a +! given process, the start and end of an array dimension are the global +! indices of the start and end of that process's subdomain. +! +! Configuration information for the domain (that is, information from the +! namelist) is added by the call to med_add_config_info_to_grid, defined +! in share/mediation_wrfmain.F. +! + + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN) :: domain_id + TYPE( domain ) , POINTER :: grid + TYPE( domain ) , POINTER :: parent + INTEGER , INTENT(IN) :: kid ! which kid of parent am I? + + ! Local data. + INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1 + INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2 + INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3 + + INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x + INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x + INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x + + INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y + INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y + INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y + + TYPE(domain) , POINTER :: new_grid + INTEGER :: i + INTEGER :: parent_id , parent_domdesc , new_domdesc + INTEGER :: bdyzone_x , bdyzone_y + INTEGER :: nx, ny + + +! This next step uses information that is listed in the registry as namelist_derived +! to properly size the domain and the patches; this in turn is stored in the new_grid +! data structure + + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + + CALL nl_get_s_we( domain_id , sd1 ) + CALL nl_get_e_we( domain_id , ed1 ) + CALL nl_get_s_sn( domain_id , sd2 ) + CALL nl_get_e_sn( domain_id , ed2 ) + CALL nl_get_s_vert( domain_id , sd3 ) + CALL nl_get_e_vert( domain_id , ed3 ) + nx = ed1-sd1+1 + ny = ed2-sd2+1 + + CASE ( DATA_ORDER_YXZ ) + + CALL nl_get_s_sn( domain_id , sd1 ) + CALL nl_get_e_sn( domain_id , ed1 ) + CALL nl_get_s_we( domain_id , sd2 ) + CALL nl_get_e_we( domain_id , ed2 ) + CALL nl_get_s_vert( domain_id , sd3 ) + CALL nl_get_e_vert( domain_id , ed3 ) + nx = ed2-sd2+1 + ny = ed1-sd1+1 + + CASE ( DATA_ORDER_ZXY ) + + CALL nl_get_s_vert( domain_id , sd1 ) + CALL nl_get_e_vert( domain_id , ed1 ) + CALL nl_get_s_we( domain_id , sd2 ) + CALL nl_get_e_we( domain_id , ed2 ) + CALL nl_get_s_sn( domain_id , sd3 ) + CALL nl_get_e_sn( domain_id , ed3 ) + nx = ed2-sd2+1 + ny = ed3-sd3+1 + + CASE ( DATA_ORDER_ZYX ) + + CALL nl_get_s_vert( domain_id , sd1 ) + CALL nl_get_e_vert( domain_id , ed1 ) + CALL nl_get_s_sn( domain_id , sd2 ) + CALL nl_get_e_sn( domain_id , ed2 ) + CALL nl_get_s_we( domain_id , sd3 ) + CALL nl_get_e_we( domain_id , ed3 ) + nx = ed3-sd3+1 + ny = ed2-sd2+1 + + CASE ( DATA_ORDER_XZY ) + + CALL nl_get_s_we( domain_id , sd1 ) + CALL nl_get_e_we( domain_id , ed1 ) + CALL nl_get_s_vert( domain_id , sd2 ) + CALL nl_get_e_vert( domain_id , ed2 ) + CALL nl_get_s_sn( domain_id , sd3 ) + CALL nl_get_e_sn( domain_id , ed3 ) + nx = ed1-sd1+1 + ny = ed3-sd3+1 + + CASE ( DATA_ORDER_YZX ) + + CALL nl_get_s_sn( domain_id , sd1 ) + CALL nl_get_e_sn( domain_id , ed1 ) + CALL nl_get_s_vert( domain_id , sd2 ) + CALL nl_get_e_vert( domain_id , ed2 ) + CALL nl_get_s_we( domain_id , sd3 ) + CALL nl_get_e_we( domain_id , ed3 ) + nx = ed3-sd3+1 + ny = ed1-sd1+1 + + END SELECT data_ordering + + +#ifdef RSL +! Check domain size to be sure it is within RSLs limit + IF ( nx .GE. 1024 .OR. ny .GE. 1024 ) THEN + WRITE ( wrf_err_message , * ) & + 'domain too large for RSL. Use RSL_LITE or other comm package.' + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ENDIF + +#endif + + IF ( num_time_levels > 3 ) THEN + WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', & + 'Incorrect value for num_time_levels ', num_time_levels + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ENDIF + + IF (ASSOCIATED(parent)) THEN + parent_id = parent%id + parent_domdesc = parent%domdesc + ELSE + parent_id = -1 + parent_domdesc = -1 + ENDIF + +! provided by application, WRF defines in share/module_bc.F + CALL get_bdyzone_x( bdyzone_x ) + CALL get_bdyzone_y( bdyzone_y ) + + ALLOCATE ( new_grid ) + ALLOCATE ( new_grid%parents( max_parents ) ) + ALLOCATE ( new_grid%nests( max_nests ) ) + NULLIFY( new_grid%sibling ) + DO i = 1, max_nests + NULLIFY( new_grid%nests(i)%ptr ) + ENDDO + NULLIFY (new_grid%next) + NULLIFY (new_grid%same_level) + NULLIFY (new_grid%i_start) + NULLIFY (new_grid%j_start) + NULLIFY (new_grid%i_end) + NULLIFY (new_grid%j_end) + ALLOCATE( new_grid%domain_clock ) + new_grid%domain_clock_created = .FALSE. + ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) ) ! initialize in setup_timekeeping + ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) ) + DO i = 1, MAX_WRF_ALARMS + new_grid%alarms_created( i ) = .FALSE. + ENDDO + new_grid%time_set = .FALSE. + new_grid%return_after_training_io = .FALSE. + + ! set up the pointers that represent the nest hierarchy + ! set this up *prior* to calling the patching or allocation + ! routines so that implementations of these routines can + ! traverse the nest hierarchy (through the root head_grid) + ! if they need to + + + IF ( domain_id .NE. 1 ) THEN + new_grid%parents(1)%ptr => parent + new_grid%num_parents = 1 + parent%nests(kid)%ptr => new_grid + new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent + parent%num_nests = parent%num_nests + 1 + END IF + new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain + + CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , & + + sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims + sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard) + sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & + + sp1x , ep1x , sm1x , em1x , & ! x-xpose dims + sp2x , ep2x , sm2x , em2x , & + sp3x , ep3x , sm3x , em3x , & + + sp1y , ep1y , sm1y , em1y , & ! y-xpose dims + sp2y , ep2y , sm2y , em2y , & + sp3y , ep3y , sm3y , em3y , & + + bdyzone_x , bdyzone_y , new_grid%bdy_mask & + ) + + + new_grid%domdesc = new_domdesc + new_grid%num_nests = 0 + new_grid%num_siblings = 0 + new_grid%num_parents = 0 + new_grid%max_tiles = 0 + new_grid%num_tiles_spec = 0 + new_grid%nframes = 0 ! initialize the number of frames per file (array assignment) + + CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , & + sd1, ed1, sd2, ed2, sd3, ed3, & + sm1, em1, sm2, em2, sm3, em3, & + sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose + sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose + ) +#if MOVE_NESTS +!set these here, after alloc_space_field, which initializes vc_i, vc_j to zero + new_grid%xi = -1.0 + new_grid%xj = -1.0 + new_grid%vc_i = -1.0 + new_grid%vc_j = -1.0 +#endif + + new_grid%sd31 = sd1 + new_grid%ed31 = ed1 + new_grid%sp31 = sp1 + new_grid%ep31 = ep1 + new_grid%sm31 = sm1 + new_grid%em31 = em1 + new_grid%sd32 = sd2 + new_grid%ed32 = ed2 + new_grid%sp32 = sp2 + new_grid%ep32 = ep2 + new_grid%sm32 = sm2 + new_grid%em32 = em2 + new_grid%sd33 = sd3 + new_grid%ed33 = ed3 + new_grid%sp33 = sp3 + new_grid%ep33 = ep3 + new_grid%sm33 = sm3 + new_grid%em33 = em3 + + new_grid%sp31x = sp1x + new_grid%ep31x = ep1x + new_grid%sm31x = sm1x + new_grid%em31x = em1x + new_grid%sp32x = sp2x + new_grid%ep32x = ep2x + new_grid%sm32x = sm2x + new_grid%em32x = em2x + new_grid%sp33x = sp3x + new_grid%ep33x = ep3x + new_grid%sm33x = sm3x + new_grid%em33x = em3x + + new_grid%sp31y = sp1y + new_grid%ep31y = ep1y + new_grid%sm31y = sm1y + new_grid%em31y = em1y + new_grid%sp32y = sp2y + new_grid%ep32y = ep2y + new_grid%sm32y = sm2y + new_grid%em32y = em2y + new_grid%sp33y = sp3y + new_grid%ep33y = ep3y + new_grid%sm33y = sm3y + new_grid%em33y = em3y + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ; + new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ; + new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ; + new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ; + new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ; + new_grid%em21 = em1 ; new_grid%em22 = em2 ; + new_grid%sd11 = sd1 + new_grid%ed11 = ed1 + new_grid%sp11 = sp1 + new_grid%ep11 = ep1 + new_grid%sm11 = sm1 + new_grid%em11 = em1 + CASE ( DATA_ORDER_YXZ ) + new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ; + new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ; + new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ; + new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ; + new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ; + new_grid%em21 = em1 ; new_grid%em22 = em2 ; + new_grid%sd11 = sd1 + new_grid%ed11 = ed1 + new_grid%sp11 = sp1 + new_grid%ep11 = ep1 + new_grid%sm11 = sm1 + new_grid%em11 = em1 + CASE ( DATA_ORDER_ZXY ) + new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ; + new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ; + new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ; + new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ; + new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ; + new_grid%em21 = em2 ; new_grid%em22 = em3 ; + new_grid%sd11 = sd2 + new_grid%ed11 = ed2 + new_grid%sp11 = sp2 + new_grid%ep11 = ep2 + new_grid%sm11 = sm2 + new_grid%em11 = em2 + CASE ( DATA_ORDER_ZYX ) + new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ; + new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ; + new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ; + new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ; + new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ; + new_grid%em21 = em2 ; new_grid%em22 = em3 ; + new_grid%sd11 = sd2 + new_grid%ed11 = ed2 + new_grid%sp11 = sp2 + new_grid%ep11 = ep2 + new_grid%sm11 = sm2 + new_grid%em11 = em2 + CASE ( DATA_ORDER_XZY ) + new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ; + new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ; + new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ; + new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ; + new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ; + new_grid%em21 = em1 ; new_grid%em22 = em3 ; + new_grid%sd11 = sd1 + new_grid%ed11 = ed1 + new_grid%sp11 = sp1 + new_grid%ep11 = ep1 + new_grid%sm11 = sm1 + new_grid%em11 = em1 + CASE ( DATA_ORDER_YZX ) + new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ; + new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ; + new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ; + new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ; + new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ; + new_grid%em21 = em1 ; new_grid%em22 = em3 ; + new_grid%sd11 = sd1 + new_grid%ed11 = ed1 + new_grid%sp11 = sp1 + new_grid%ep11 = ep1 + new_grid%sm11 = sm1 + new_grid%em11 = em1 + END SELECT + + CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine + +! Some miscellaneous state that is in the Registry but not namelist data + + new_grid%tiled = .false. + new_grid%patched = .false. + NULLIFY(new_grid%mapping) + +! This next set of includes causes all but the namelist_derived variables to be +! properly assigned to the new_grid record + + grid => new_grid + +#ifdef DM_PARALLEL + CALL wrf_get_dm_communicator ( grid%communicator ) + CALL wrf_dm_define_comms( grid ) +#endif + + END SUBROUTINE alloc_and_configure_domain + +! + +! This routine ALLOCATEs the required space for the meteorological fields +! for a specific domain. The fields are simply ALLOCATEd as an -1. They +! are referenced as wind, temperature, moisture, etc. in routines that are +! below this top-level of data allocation and management (in the solve routine +! and below). + + SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + + + USE module_configure + IMPLICIT NONE + + + ! Input data. + + TYPE(domain) , POINTER :: grid + INTEGER , INTENT(IN) :: id + INTEGER , INTENT(IN) :: setinitval_in ! 3 = everything, 1 = arrays only, 0 = none + INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33 + INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33 + INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y + + ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on. + ! e.g. to set both 1st and second time level, use 3 + ! to set only 1st use 1 + ! to set only 2st use 2 + INTEGER , INTENT(IN) :: tl_in + + ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated + ! false otherwise (all allocated, modulo tl above) + LOGICAL , INTENT(IN) :: inter_domain_in + + ! Local data. + INTEGER dyn_opt, idum1, idum2, spec_bdy_width + INTEGER num_bytes_allocated + REAL initial_data_value + CHARACTER (LEN=256) message + INTEGER tl + LOGICAL inter_domain + INTEGER setinitval + INTEGER sr_x, sr_y + + !declare ierr variable for error checking ALLOCATE calls + INTEGER ierr + + INTEGER :: loop + + CALL nl_get_sr_x( id , sr_x ) + CALL nl_get_sr_x( id , sr_y ) + + tl = tl_in + inter_domain = inter_domain_in + +#if ( RWORDSIZE == 8 ) + initial_data_value = 0. +#else + CALL get_initial_data_value ( initial_data_value ) +#endif + +#ifdef NO_INITIAL_DATA_VALUE + setinitval = 0 +#else + setinitval = setinitval_in +#endif + + CALL nl_get_dyn_opt( 1, dyn_opt ) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + + CALL set_scalar_indices_from_config( id , idum1 , idum2 ) + + num_bytes_allocated = 0 + + + IF ( dyn_opt == DYN_NODYN ) THEN + + IF ( grid%id .EQ. 1 ) & + CALL wrf_message ( 'DYNAMICS OPTION: dynamics disabled ' ) + +#if ALLOW_NODYN +# include +#else + WRITE(message,*) & + "To run the the NODYN option, recompile ", & + "-DALLOW_NODYN in ARCHFLAGS settings of configure.wrf" + CALL wrf_error_fatal( message ) +#endif + +#if (EM_CORE == 1) + ELSE IF ( dyn_opt == DYN_EM ) THEN + IF ( grid%id .EQ. 1 ) CALL wrf_message ( & + 'DYNAMICS OPTION: Eulerian Mass Coordinate ') +# include +#endif +#if (NMM_CORE == 1) + ELSE IF ( dyn_opt == DYN_NMM ) THEN + IF ( grid%id .EQ. 1 ) & + CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' ) +# include +#endif +#if (COAMPS_CORE == 1) + ELSE IF ( dyn_opt == DYN_COAMPS ) THEN + IF ( grid%id .EQ. 1 ) & + CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' ) +# include +#endif +#if (EXP_CORE==1) + ELSE IF ( dyn_opt == DYN_EXP ) THEN + IF ( grid%id .EQ. 1 ) & + CALL wrf_message ( 'DYNAMICS OPTION: experimental dyncore' ) +# include +#endif + + ELSE + + WRITE( wrf_err_message , * )& + 'Invalid specification of dynamics: dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ENDIF + + WRITE(message,*)& + 'alloc_space_field: domain ',id,' ',num_bytes_allocated + CALL wrf_debug( 1, message ) + + END SUBROUTINE alloc_space_field + + +! This routine is used to DEALLOCATE space for a single domain and remove +! it from the linked list. First the pointers in the linked list are fixed +! (so the one in the middle can be removed). Then the domain itself is +! DEALLOCATEd via a call to domain_destroy(). + + SUBROUTINE dealloc_space_domain ( id ) + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN) :: id + + ! Local data. + + TYPE(domain) , POINTER :: grid + LOGICAL :: found + + ! Initializations required to start the routine. + + grid => head_grid + old_grid => head_grid + found = .FALSE. + + ! The identity of the domain to delete is based upon the "id". + ! We search all of the possible grids. It is required to find a domain + ! otherwise it is a fatal error. + + find_grid : DO WHILE ( ASSOCIATED(grid) ) + IF ( grid%id == id ) THEN + found = .TRUE. + old_grid%next => grid%next + CALL domain_destroy( grid ) + EXIT find_grid + END IF + old_grid => grid + grid => grid%next + END DO find_grid + + IF ( .NOT. found ) THEN + WRITE ( wrf_err_message , * ) 'module_domain: ', & + 'dealloc_space_domain: Could not de-allocate grid id ',id + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF + + END SUBROUTINE dealloc_space_domain + + + +! This routine is used to DEALLOCATE space for a single domain type. +! First, the field data are all removed through a CALL to the +! dealloc_space_field routine. Then the pointer to the domain +! itself is DEALLOCATEd. + + SUBROUTINE domain_destroy ( grid ) + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , POINTER :: grid + + CALL dealloc_space_field ( grid ) + DEALLOCATE( grid%parents ) + DEALLOCATE( grid%nests ) + ! clean up time manager bits + CALL domain_clock_destroy( grid ) + CALL domain_alarms_destroy( grid ) + IF ( ASSOCIATED( grid%i_start ) ) THEN + DEALLOCATE( grid%i_start ) + ENDIF + IF ( ASSOCIATED( grid%i_end ) ) THEN + DEALLOCATE( grid%i_end ) + ENDIF + IF ( ASSOCIATED( grid%j_start ) ) THEN + DEALLOCATE( grid%j_start ) + ENDIF + IF ( ASSOCIATED( grid%j_end ) ) THEN + DEALLOCATE( grid%j_end ) + ENDIF + DEALLOCATE( grid ) + NULLIFY( grid ) + + END SUBROUTINE domain_destroy + + RECURSIVE SUBROUTINE show_nest_subtree ( grid ) + TYPE(domain), POINTER :: grid + INTEGER myid + INTEGER kid + IF ( .NOT. ASSOCIATED( grid ) ) RETURN + myid = grid%id + write(0,*)'show_nest_subtree ',myid + DO kid = 1, max_nests + IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN + IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN + CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' ) + ENDIF + CALL show_nest_subtree( grid%nests(kid)%ptr ) + ENDIF + ENDDO + END SUBROUTINE show_nest_subtree + + +! + +! This routine DEALLOCATEs each gridded field for this domain. For each type of +! different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd +! for every -1 (i.e., each different meteorological field). + + SUBROUTINE dealloc_space_field ( grid ) + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , POINTER :: grid + + ! Local data. + + INTEGER :: dyn_opt, ierr + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + IF ( .FALSE. ) THEN + +#if (EM_CORE == 1) + ELSE IF ( dyn_opt == DYN_EM ) THEN +# include +#endif +#if (NMM_CORE == 1) + ELSE IF ( dyn_opt == DYN_NMM ) THEN +# include +#endif +#if (COAMPS_CORE == 1) + ELSE IF ( dyn_opt == DYN_COAMPS ) THEN +# include +#endif +#if (EXP_CORE==1) + ELSE IF ( dyn_opt == DYN_EXP ) THEN +# include +#endif + ELSE + WRITE( wrf_err_message , * )'dealloc_space_field: ', & + 'Invalid specification of dynamics: dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ENDIF + + END SUBROUTINE dealloc_space_field + +! +! + RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + TYPE(domain), POINTER :: in_grid + TYPE(domain), POINTER :: result_grid +! +! This is a recursive subroutine that traverses the domain hierarchy rooted +! at the input argument in_grid, a pointer to TYPE(domain), and returns +! a pointer to the domain matching the integer argument id if it exists. +! +! + TYPE(domain), POINTER :: grid_ptr + INTEGER :: kid + LOGICAL :: found + found = .FALSE. + IF ( ASSOCIATED( in_grid ) ) THEN + IF ( in_grid%id .EQ. id ) THEN + result_grid => in_grid + ELSE + grid_ptr => in_grid + DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found ) + DO kid = 1, max_nests + IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN + CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid ) + IF ( ASSOCIATED( result_grid ) ) THEN + IF ( result_grid%id .EQ. id ) found = .TRUE. + ENDIF + ENDIF + ENDDO + IF ( .NOT. found ) grid_ptr => grid_ptr%sibling + ENDDO + ENDIF + ENDIF + RETURN + END SUBROUTINE find_grid_by_id + + + FUNCTION first_loc_integer ( array , search ) RESULT ( loc ) + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN) , DIMENSION(:) :: array + INTEGER , INTENT(IN) :: search + + ! Output data. + + INTEGER :: loc + +! +! This routine is used to find a specific domain identifier in an array +! of domain identifiers. +! +! + + ! Local data. + + INTEGER :: loop + + loc = -1 + find : DO loop = 1 , SIZE(array) + IF ( search == array(loop) ) THEN + loc = loop + EXIT find + END IF + END DO find + + END FUNCTION first_loc_integer +! + SUBROUTINE init_module_domain + END SUBROUTINE init_module_domain + + +! +! +! The following routines named domain_*() are convenience routines that +! eliminate many duplicated bits of code. They provide shortcuts for the +! most common operations on the domain_clock field of TYPE(domain). +! +! + + FUNCTION domain_get_current_time ( grid ) RESULT ( current_time ) + IMPLICIT NONE +! +! This convenience function returns the current time for domain grid. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_Time) :: current_time + ! locals + INTEGER :: rc + CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_get_current_time: WRFU_ClockGet failed' ) + ENDIF + END FUNCTION domain_get_current_time + + + FUNCTION domain_get_start_time ( grid ) RESULT ( start_time ) + IMPLICIT NONE +! +! This convenience function returns the start time for domain grid. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_Time) :: start_time + ! locals + INTEGER :: rc + CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_get_start_time: WRFU_ClockGet failed' ) + ENDIF + END FUNCTION domain_get_start_time + + + FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time ) + IMPLICIT NONE +! +! This convenience function returns the stop time for domain grid. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_Time) :: stop_time + ! locals + INTEGER :: rc + CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_get_stop_time: WRFU_ClockGet failed' ) + ENDIF + END FUNCTION domain_get_stop_time + + + FUNCTION domain_get_time_step ( grid ) RESULT ( time_step ) + IMPLICIT NONE +! +! This convenience function returns the time step for domain grid. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_TimeInterval) :: time_step + ! locals + INTEGER :: rc + CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_get_time_step: WRFU_ClockGet failed' ) + ENDIF + END FUNCTION domain_get_time_step + + + FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount ) + IMPLICIT NONE +! +! This convenience function returns the time step for domain grid. +! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + INTEGER :: advanceCount + ! locals + INTEGER(WRFU_KIND_I8) :: advanceCountLcl + INTEGER :: rc + CALL WRFU_ClockGet( grid%domain_clock, & + advanceCount=advanceCountLcl, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_get_advanceCount: WRFU_ClockGet failed' ) + ENDIF + advanceCount = advanceCountLcl + END FUNCTION domain_get_advanceCount + + + SUBROUTINE domain_alarms_destroy ( grid ) + IMPLICIT NONE +! +! This convenience routine destroys and deallocates all alarms associated +! with grid. +! +! + TYPE(domain), INTENT(INOUT) :: grid + ! Local data. + INTEGER :: alarmid + + IF ( ASSOCIATED( grid%alarms ) .AND. & + ASSOCIATED( grid%alarms_created ) ) THEN + DO alarmid = 1, MAX_WRF_ALARMS + IF ( grid%alarms_created( alarmid ) ) THEN + CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) ) + grid%alarms_created( alarmid ) = .FALSE. + ENDIF + ENDDO + DEALLOCATE( grid%alarms ) + NULLIFY( grid%alarms ) + DEALLOCATE( grid%alarms_created ) + NULLIFY( grid%alarms_created ) + ENDIF + END SUBROUTINE domain_alarms_destroy + + + SUBROUTINE domain_clock_destroy ( grid ) + IMPLICIT NONE +! +! This convenience routine destroys and deallocates the domain clock. +! +! + TYPE(domain), INTENT(INOUT) :: grid + IF ( ASSOCIATED( grid%domain_clock ) ) THEN + IF ( grid%domain_clock_created ) THEN + CALL WRFU_ClockDestroy( grid%domain_clock ) + grid%domain_clock_created = .FALSE. + ENDIF + DEALLOCATE( grid%domain_clock ) + NULLIFY( grid%domain_clock ) + ENDIF + END SUBROUTINE domain_clock_destroy + + + FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME ) + IMPLICIT NONE +! +! This convenience function returns .TRUE. if this is the last time +! step for domain grid. Thanks to Tom Black. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + LOGICAL :: LAST_TIME + LAST_TIME = domain_get_stop_time( grid ) .EQ. & + ( domain_get_current_time( grid ) + & + domain_get_time_step( grid ) ) + END FUNCTION domain_last_time_step + + + + FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time ) + IMPLICIT NONE +! +! This convenience function returns .TRUE. iff grid%clock has reached its +! stop time. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + LOGICAL :: is_stop_time + INTEGER :: rc + is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clockisstoptime: WRFU_ClockIsStopTime() failed' ) + ENDIF + END FUNCTION domain_clockisstoptime + + + + FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime ) + IMPLICIT NONE +! +! This convenience function returns .TRUE. iff grid%clock has reached its +! grid%stop_subtime. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + LOGICAL :: is_stop_subtime + INTEGER :: rc + TYPE(WRFU_TimeInterval) :: timeStep + TYPE(WRFU_Time) :: currentTime + LOGICAL :: positive_timestep + is_stop_subtime = .FALSE. + CALL domain_clock_get( grid, time_step=timeStep, & + current_time=currentTime ) + positive_timestep = ESMF_TimeIntervalIsPositive( timeStep ) + IF ( positive_timestep ) THEN +! hack for bug in PGI 5.1-x +! IF ( currentTime .GE. grid%stop_subtime ) THEN + IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN + is_stop_subtime = .TRUE. + ENDIF + ELSE +! hack for bug in PGI 5.1-x +! IF ( currentTime .LE. grid%stop_subtime ) THEN + IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN + is_stop_subtime = .TRUE. + ENDIF + ENDIF + END FUNCTION domain_clockisstopsubtime + + + + + FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime ) + IMPLICIT NONE +! +! This convenience routine returns simulation start time for domain grid as +! a time instant. +! +! If this is not a restart run, the start_time of head_grid%clock is returned +! instead. +! +! Note that simulation start time remains constant through restarts while +! the start_time of head_grid%clock always refers to the start time of the +! current run (restart or otherwise). +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_Time) :: simulationStartTime + ! Locals + INTEGER :: rc + INTEGER :: simulation_start_year, simulation_start_month, & + simulation_start_day, simulation_start_hour , & + simulation_start_minute, simulation_start_second + CALL nl_get_simulation_start_year ( 1, simulation_start_year ) + CALL nl_get_simulation_start_month ( 1, simulation_start_month ) + CALL nl_get_simulation_start_day ( 1, simulation_start_day ) + CALL nl_get_simulation_start_hour ( 1, simulation_start_hour ) + CALL nl_get_simulation_start_minute ( 1, simulation_start_minute ) + CALL nl_get_simulation_start_second ( 1, simulation_start_second ) + CALL WRFU_TimeSet( simulationStartTime, & + YY=simulation_start_year, & + MM=simulation_start_month, & + DD=simulation_start_day, & + H=simulation_start_hour, & + M=simulation_start_minute, & + S=simulation_start_second, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL nl_get_start_year ( 1, simulation_start_year ) + CALL nl_get_start_month ( 1, simulation_start_month ) + CALL nl_get_start_day ( 1, simulation_start_day ) + CALL nl_get_start_hour ( 1, simulation_start_hour ) + CALL nl_get_start_minute ( 1, simulation_start_minute ) + CALL nl_get_start_second ( 1, simulation_start_second ) + CALL wrf_debug( 150, "WARNING: domain_get_sim_start_time using head_grid start time from namelist" ) + CALL WRFU_TimeSet( simulationStartTime, & + YY=simulation_start_year, & + MM=simulation_start_month, & + DD=simulation_start_day, & + H=simulation_start_hour, & + M=simulation_start_minute, & + S=simulation_start_second, & + rc=rc ) + ENDIF + RETURN + END FUNCTION domain_get_sim_start_time + + FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start ) + IMPLICIT NONE +! +! This convenience function returns the time elapsed since start of +! simulation for domain grid. +! +! Note that simulation start time remains constant through restarts while +! the start_time of grid%clock always refers to the start time of the +! current run (restart or otherwise). +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + TYPE(WRFU_TimeInterval) :: time_since_sim_start + ! locals + TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime + lcl_simstarttime = domain_get_sim_start_time( grid ) + lcl_currtime = domain_get_current_time ( grid ) + time_since_sim_start = lcl_currtime - lcl_simstarttime + END FUNCTION domain_get_time_since_sim_start + + + + + SUBROUTINE domain_clock_get( grid, current_time, & + current_timestr, & + current_timestr_frac, & + start_time, start_timestr, & + stop_time, stop_timestr, & + time_step, time_stepstr, & + time_stepstr_frac, & + advanceCount, & + currentDayOfYearReal, & + minutesSinceSimulationStart, & + timeSinceSimulationStart, & + simulationStartTime, & + simulationStartTimeStr ) + IMPLICIT NONE + TYPE(domain), INTENT(IN) :: grid + TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: current_time + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr_frac + TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: start_time + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: start_timestr + TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: stop_time + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: stop_timestr + TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: time_step + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr_frac + INTEGER, INTENT( OUT), OPTIONAL :: advanceCount + ! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on + ! 1 January, etc. + REAL, INTENT( OUT), OPTIONAL :: currentDayOfYearReal + ! Time at which simulation started. If this is not a restart run, + ! start_time is returned instead. + TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: simulationStartTime + CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: simulationStartTimeStr + ! time interval since start of simulation, includes effects of + ! restarting even when restart uses a different timestep + TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: timeSinceSimulationStart + ! minutes since simulation start date + REAL, INTENT( OUT), OPTIONAL :: minutesSinceSimulationStart +! +! This convenience routine returns clock information for domain grid in +! various forms. The caller is responsible for ensuring that character +! string actual arguments are big enough. +! +! + ! Locals + TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime + TYPE(WRFU_Time) :: lcl_simulationStartTime + TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart + INTEGER :: days, seconds, Sn, Sd, rc + CHARACTER (LEN=256) :: tmp_str + CHARACTER (LEN=256) :: frac_str + REAL(WRFU_KIND_R8) :: currentDayOfYearR8 + IF ( PRESENT( start_time ) ) THEN + start_time = domain_get_start_time ( grid ) + ENDIF + IF ( PRESENT( start_timestr ) ) THEN + lcl_starttime = domain_get_start_time ( grid ) + CALL wrf_timetoa ( lcl_starttime, start_timestr ) + ENDIF + IF ( PRESENT( time_step ) ) THEN + time_step = domain_get_time_step ( grid ) + ENDIF + IF ( PRESENT( time_stepstr ) ) THEN + lcl_time_step = domain_get_time_step ( grid ) + CALL WRFU_TimeIntervalGet( lcl_time_step, & + timeString=time_stepstr, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_get: WRFU_TimeIntervalGet() failed' ) + ENDIF + ENDIF + IF ( PRESENT( time_stepstr_frac ) ) THEN + lcl_time_step = domain_get_time_step ( grid ) + CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, & + Sn=Sn, Sd=Sd, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_get: WRFU_TimeIntervalGet() failed' ) + ENDIF + CALL fraction_to_string( Sn, Sd, frac_str ) + time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str) + ENDIF + IF ( PRESENT( advanceCount ) ) THEN + advanceCount = domain_get_advanceCount ( grid ) + ENDIF + ! This duplication avoids assignment of time-manager objects + ! which works now in ESMF 2.2.0 but may not work in the future + ! if these objects become "deep". We have already been bitten + ! by this when the clock objects were changed from "shallow" to + ! "deep". Once again, adherence to orthodox canonical form by + ! ESMF would avoid all this crap. + IF ( PRESENT( current_time ) ) THEN + current_time = domain_get_current_time ( grid ) + ENDIF + IF ( PRESENT( current_timestr ) ) THEN + lcl_currtime = domain_get_current_time ( grid ) + CALL wrf_timetoa ( lcl_currtime, current_timestr ) + ENDIF + ! current time string including fractional part, if present + IF ( PRESENT( current_timestr_frac ) ) THEN + lcl_currtime = domain_get_current_time ( grid ) + CALL wrf_timetoa ( lcl_currtime, tmp_str ) + CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_get: WRFU_TimeGet() failed' ) + ENDIF + CALL fraction_to_string( Sn, Sd, frac_str ) + current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str) + ENDIF + IF ( PRESENT( stop_time ) ) THEN + stop_time = domain_get_stop_time ( grid ) + ENDIF + IF ( PRESENT( stop_timestr ) ) THEN + lcl_stoptime = domain_get_stop_time ( grid ) + CALL wrf_timetoa ( lcl_stoptime, stop_timestr ) + ENDIF + IF ( PRESENT( currentDayOfYearReal ) ) THEN + lcl_currtime = domain_get_current_time ( grid ) + CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_get: WRFU_TimeGet(dayOfYear_r8) failed' ) + ENDIF + currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0 + ENDIF + IF ( PRESENT( simulationStartTime ) ) THEN + simulationStartTime = domain_get_sim_start_time( grid ) + ENDIF + IF ( PRESENT( simulationStartTimeStr ) ) THEN + lcl_simulationStartTime = domain_get_sim_start_time( grid ) + CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr ) + ENDIF + IF ( PRESENT( timeSinceSimulationStart ) ) THEN + timeSinceSimulationStart = domain_get_time_since_sim_start( grid ) + ENDIF + IF ( PRESENT( minutesSinceSimulationStart ) ) THEN + lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid ) + CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, & + D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_get: WRFU_TimeIntervalGet() failed' ) + ENDIF + ! get rid of hard-coded constants + minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + & + ( REAL( seconds ) / 60. ) + IF ( Sd /= 0 ) THEN + minutesSinceSimulationStart = minutesSinceSimulationStart + & + ( ( REAL( Sn ) / REAL( Sd ) ) / 60. ) + ENDIF + ENDIF + RETURN + END SUBROUTINE domain_clock_get + + FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time ) + IMPLICIT NONE +! +! This convenience function returns .TRUE. iff grid%clock is at its +! start time. +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + LOGICAL :: is_start_time + TYPE(WRFU_Time) :: start_time, current_time + CALL domain_clock_get( grid, current_time=current_time, & + start_time=start_time ) + is_start_time = ( current_time == start_time ) + END FUNCTION domain_clockisstarttime + + FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time ) + IMPLICIT NONE +! +! This convenience function returns .TRUE. iff grid%clock is at the +! simulation start time. (It returns .FALSE. during a restart run.) +! +! + TYPE(domain), INTENT(IN) :: grid + ! result + LOGICAL :: is_sim_start_time + TYPE(WRFU_Time) :: simulationStartTime, current_time + CALL domain_clock_get( grid, current_time=current_time, & + simulationStartTime=simulationStartTime ) + is_sim_start_time = ( current_time == simulationStartTime ) + END FUNCTION domain_clockissimstarttime + + + + + SUBROUTINE domain_clock_create( grid, StartTime, & + StopTime, & + TimeStep ) + IMPLICIT NONE + TYPE(domain), INTENT(INOUT) :: grid + TYPE(WRFU_Time), INTENT(IN ) :: StartTime + TYPE(WRFU_Time), INTENT(IN ) :: StopTime + TYPE(WRFU_TimeInterval), INTENT(IN ) :: TimeStep +! +! This convenience routine creates the domain_clock for domain grid and +! sets associated flags. +! +! + ! Locals + INTEGER :: rc + grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep, & + StartTime=StartTime, & + StopTime= StopTime, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_create: WRFU_ClockCreate() failed' ) + ENDIF + grid%domain_clock_created = .TRUE. + RETURN + END SUBROUTINE domain_clock_create + + + + SUBROUTINE domain_alarm_create( grid, alarm_id, interval, & + begin_time, end_time ) + USE module_utility + IMPLICIT NONE + TYPE(domain), POINTER :: grid + INTEGER, INTENT(IN) :: alarm_id + TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval + TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time + TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time +! +! This convenience routine creates alarm alarm_id for domain grid and +! sets associated flags. +! +! + ! Locals + INTEGER :: rc +!$$$ TBH: Ideally, this could be simplified by passing all optional actual +!$$$ TBH: args into AlarmCreate. However, since operations are performed on +!$$$ TBH: the actual args in-place in the calls, they must be present for the +!$$$ TBH: operations themselves to be defined. Grrr... + LOGICAL :: interval_only, all_args, no_args + TYPE(WRFU_Time) :: startTime + interval_only = .FALSE. + all_args = .FALSE. + no_args = .FALSE. + IF ( ( .NOT. PRESENT( begin_time ) ) .AND. & + ( .NOT. PRESENT( end_time ) ) .AND. & + ( PRESENT( interval ) ) ) THEN + interval_only = .TRUE. + ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. & + ( .NOT. PRESENT( end_time ) ) .AND. & + ( .NOT. PRESENT( interval ) ) ) THEN + no_args = .TRUE. + ELSE IF ( ( PRESENT( begin_time ) ) .AND. & + ( PRESENT( end_time ) ) .AND. & + ( PRESENT( interval ) ) ) THEN + all_args = .TRUE. + ELSE + CALL wrf_error_fatal ( & + 'ERROR in domain_alarm_create: bad argument list' ) + ENDIF + CALL domain_clock_get( grid, start_time=startTime ) + IF ( interval_only ) THEN + grid%io_intervals( alarm_id ) = interval + grid%alarms( alarm_id ) = & + WRFU_AlarmCreate( clock=grid%domain_clock, & + RingInterval=interval, & + rc=rc ) + ELSE IF ( no_args ) THEN + grid%alarms( alarm_id ) = & + WRFU_AlarmCreate( clock=grid%domain_clock, & + RingTime=startTime, & + rc=rc ) + ELSE IF ( all_args ) THEN + grid%io_intervals( alarm_id ) = interval + grid%alarms( alarm_id ) = & + WRFU_AlarmCreate( clock=grid%domain_clock, & + RingTime=startTime + begin_time, & + RingInterval=interval, & + StopTime=startTime + end_time, & + rc=rc ) + ENDIF + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_alarm_create: WRFU_AlarmCreate() failed' ) + ENDIF + grid%alarms_created( alarm_id ) = .TRUE. + END SUBROUTINE domain_alarm_create + + + + SUBROUTINE domain_clock_set( grid, current_timestr, & + stop_timestr, & + time_step_seconds ) + IMPLICIT NONE + TYPE(domain), INTENT(INOUT) :: grid + CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: current_timestr + CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: stop_timestr + INTEGER, INTENT(IN ), OPTIONAL :: time_step_seconds +! +! This convenience routine sets clock information for domain grid. +! The caller is responsible for ensuring that character string actual +! arguments are big enough. +! +! + ! Locals + TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime + TYPE(WRFU_TimeInterval) :: tmpTimeInterval + INTEGER :: rc + IF ( PRESENT( current_timestr ) ) THEN + CALL wrf_atotime( current_timestr(1:19), lcl_currtime ) + CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_set: WRFU_ClockSet(CurrTime) failed' ) + ENDIF + ENDIF + IF ( PRESENT( stop_timestr ) ) THEN + CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime ) + CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_set: WRFU_ClockSet(StopTime) failed' ) + ENDIF + ENDIF + IF ( PRESENT( time_step_seconds ) ) THEN + CALL WRFU_TimeIntervalSet( tmpTimeInterval, & + S=time_step_seconds, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_set: WRFU_TimeIntervalSet failed' ) + ENDIF + CALL WRFU_ClockSet ( grid%domain_clock, & + timeStep=tmpTimeInterval, & + rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clock_set: WRFU_ClockSet(TimeStep) failed' ) + ENDIF + ENDIF + RETURN + END SUBROUTINE domain_clock_set + + + ! Debug routine to print key clock information. + ! Printed lines include pre_str. + SUBROUTINE domain_clockprint ( level, grid, pre_str ) + IMPLICIT NONE + INTEGER, INTENT( IN) :: level + TYPE(domain), INTENT( IN) :: grid + CHARACTER (LEN=*), INTENT( IN) :: pre_str + CALL wrf_clockprint ( level, grid%domain_clock, pre_str ) + RETURN + END SUBROUTINE domain_clockprint + + + ! Advance the clock associated with grid. + ! Also updates several derived time quantities in grid state. + SUBROUTINE domain_clockadvance ( grid ) + IMPLICIT NONE + TYPE(domain), INTENT(INOUT) :: grid + INTEGER :: rc + CALL domain_clockprint ( 250, grid, & + 'DEBUG domain_clockadvance(): before WRFU_ClockAdvance,' ) + CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_clockadvance: WRFU_ClockAdvance() failed' ) + ENDIF + CALL domain_clockprint ( 250, grid, & + 'DEBUG domain_clockadvance(): after WRFU_ClockAdvance,' ) + ! Update derived time quantities in grid state. + ! These are initialized in setup_timekeeping(). + CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime ) + CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian ) + RETURN + END SUBROUTINE domain_clockadvance + + + + ! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date. + ! Set start_of_simulation to TRUE iff current_time == simulation_start_time + SUBROUTINE domain_setgmtetc ( grid, start_of_simulation ) + IMPLICIT NONE + TYPE (domain), INTENT(INOUT) :: grid + LOGICAL, INTENT( OUT) :: start_of_simulation + ! locals + CHARACTER (LEN=132) :: message + TYPE(WRFU_Time) :: simStartTime + INTEGER :: hr, mn, sec, ms, rc + CALL domain_clockprint(150, grid, & + 'DEBUG domain_setgmtetc(): get simStartTime from clock,') + CALL domain_clock_get( grid, simulationStartTime=simStartTime, & + simulationStartTimeStr=message ) + CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, & + H=hr, M=mn, S=sec, MS=ms, rc=rc) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_setgmtetc: WRFU_TimeGet() failed' ) + ENDIF + WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): simulation start time = [',TRIM( message ),']' + CALL wrf_debug( 150, TRIM(wrf_err_message) ) + grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600) + WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): julyr,hr,mn,sec,ms,julday = ', & + grid%julyr,hr,mn,sec,ms,grid%julday + CALL wrf_debug( 150, TRIM(wrf_err_message) ) + WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): gmt = ',grid%gmt + CALL wrf_debug( 150, TRIM(wrf_err_message) ) + start_of_simulation = domain_ClockIsSimStartTime(grid) + RETURN + END SUBROUTINE domain_setgmtetc + + + + ! Set pointer to current grid. + ! To begin with, current grid is not set. + SUBROUTINE set_current_grid_ptr( grid_ptr ) + IMPLICIT NONE + TYPE(domain), POINTER :: grid_ptr +!PRINT *,'DEBUG: begin set_current_grid_ptr()' +!IF ( ASSOCIATED( grid_ptr ) ) THEN +! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is associated' +!ELSE +! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is NOT associated' +!ENDIF + current_grid_set = .TRUE. + current_grid => grid_ptr +!PRINT *,'DEBUG: end set_current_grid_ptr()' + END SUBROUTINE set_current_grid_ptr + + + +!****************************************************************************** +! BEGIN TEST SECTION +! Code in the test section is used to test domain methods. +! This code should probably be moved elsewhere, eventually. +!****************************************************************************** + + ! Private utility routines for domain_time_test. + SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str ) + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(IN) :: pre_str + CHARACTER (LEN=*), INTENT(IN) :: name_str + CHARACTER (LEN=*), INTENT(IN) :: res_str + CHARACTER (LEN=512) :: out_str + WRITE (out_str, & + FMT="('DOMAIN_TIME_TEST ',A,': ',A,' = ',A)") & + TRIM(pre_str), TRIM(name_str), TRIM(res_str) + CALL wrf_debug( 0, TRIM(out_str) ) + END SUBROUTINE domain_time_test_print + + ! Test adjust_io_timestr + SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, & + CT_yy, CT_mm, CT_dd, CT_h, CT_m, CT_s, & + ST_yy, ST_mm, ST_dd, ST_h, ST_m, ST_s, & + res_str, testname ) + INTEGER, INTENT(IN) :: TI_H + INTEGER, INTENT(IN) :: TI_M + INTEGER, INTENT(IN) :: TI_S + INTEGER, INTENT(IN) :: CT_YY + INTEGER, INTENT(IN) :: CT_MM ! month + INTEGER, INTENT(IN) :: CT_DD ! day of month + INTEGER, INTENT(IN) :: CT_H + INTEGER, INTENT(IN) :: CT_M + INTEGER, INTENT(IN) :: CT_S + INTEGER, INTENT(IN) :: ST_YY + INTEGER, INTENT(IN) :: ST_MM ! month + INTEGER, INTENT(IN) :: ST_DD ! day of month + INTEGER, INTENT(IN) :: ST_H + INTEGER, INTENT(IN) :: ST_M + INTEGER, INTENT(IN) :: ST_S + CHARACTER (LEN=*), INTENT(IN) :: res_str + CHARACTER (LEN=*), INTENT(IN) :: testname + ! locals + TYPE(WRFU_TimeInterval) :: TI + TYPE(WRFU_Time) :: CT, ST + LOGICAL :: test_passed + INTEGER :: rc + CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str + ! TI + CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeIntervalSet() ', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', & + __FILE__ , & + __LINE__ ) + ! CT + CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , & + H=CT_H, M=CT_M, S=CT_S, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', & + __FILE__ , & + __LINE__ ) + ! ST + CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , & + H=ST_H, M=ST_M, S=ST_S, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', & + __FILE__ , & + __LINE__ ) + ! Test + CALL adjust_io_timestr ( TI, CT, ST, computed_str ) + ! check result + test_passed = .FALSE. + IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN + IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN + test_passed = .TRUE. + ENDIF + ENDIF + ! print result + IF ( test_passed ) THEN + WRITE(*,FMT='(A)') 'PASS: '//TRIM(testname) + ELSE + WRITE(*,*) 'FAIL: ',TRIM(testname),': adjust_io_timestr(', & + TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),') expected <', & + TRIM(res_str),'> but computed <',TRIM(computed_str),'>' + ENDIF + END SUBROUTINE test_adjust_io_timestr + + ! Print lots of time-related information for testing and debugging. + ! Printed lines include pre_str and special string DOMAIN_TIME_TEST + ! suitable for grepping by test scripts. + ! Returns immediately unless self_test_domain has been set to .true. in + ! namelist /time_control/ . + SUBROUTINE domain_time_test ( grid, pre_str ) + IMPLICIT NONE + TYPE(domain), INTENT(IN) :: grid + CHARACTER (LEN=*), INTENT(IN) :: pre_str + ! locals + LOGICAL, SAVE :: one_time_tests_done = .FALSE. + REAL :: minutesSinceSimulationStart + INTEGER :: advance_count, rc + REAL :: currentDayOfYearReal + TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart + TYPE(WRFU_Time) :: simulationStartTime + CHARACTER (LEN=512) :: res_str + LOGICAL :: self_test_domain + ! + ! NOTE: test_adjust_io_timestr() (see below) is a self-test that + ! prints PASS/FAIL/ERROR messages in a standard format. All + ! of the other tests should be strucutred the same way, + ! someday. + ! + CALL nl_get_self_test_domain( 1, self_test_domain ) + IF ( self_test_domain ) THEN + CALL domain_clock_get( grid, advanceCount=advance_count ) + WRITE ( res_str, FMT="(I8.8)" ) advance_count + CALL domain_time_test_print( pre_str, 'advanceCount', res_str ) + CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal ) + WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal + CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str ) + CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart ) + WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart + CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str ) + CALL domain_clock_get( grid, current_timestr=res_str ) + CALL domain_time_test_print( pre_str, 'current_timestr', res_str ) + CALL domain_clock_get( grid, current_timestr_frac=res_str ) + CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str ) + CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart ) + CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc ) + IF ( rc /= WRFU_SUCCESS ) THEN + CALL wrf_error_fatal ( & + 'domain_time_test: WRFU_TimeIntervalGet() failed' ) + ENDIF + CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str ) + ! The following tests should only be done once, the first time this + ! routine is called. + IF ( .NOT. one_time_tests_done ) THEN + one_time_tests_done = .TRUE. + CALL domain_clock_get( grid, simulationStartTimeStr=res_str ) + CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str ) + CALL domain_clock_get( grid, start_timestr=res_str ) + CALL domain_time_test_print( pre_str, 'start_timestr', res_str ) + CALL domain_clock_get( grid, stop_timestr=res_str ) + CALL domain_time_test_print( pre_str, 'stop_timestr', res_str ) + CALL domain_clock_get( grid, time_stepstr=res_str ) + CALL domain_time_test_print( pre_str, 'time_stepstr', res_str ) + CALL domain_clock_get( grid, time_stepstr_frac=res_str ) + CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str ) + ! Test adjust_io_timestr() + ! CT = 2000-01-26_00:00:00 (current time) + ! ST = 2000-01-24_12:00:00 (start time) + ! TI = 00000_03:00:00 (time interval) + ! the resulting time string should be: + ! 2000-01-26_00:00:00 + CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, & + CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, & + ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, & + res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' ) + ! this should fail (and does) + ! CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, & + ! CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, & + ! ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, & + ! res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' ) + ENDIF + ENDIF + RETURN + END SUBROUTINE domain_time_test + +!****************************************************************************** +! END TEST SECTION +!****************************************************************************** + + +END MODULE module_domain + + +! The following routines are outside this module to avoid build dependences. + + +! Get current time as a string (current time from clock attached to the +! current_grid). Includes fractional part, if present. +! Returns empty string if current_grid is not set or if timing has not yet +! been set up on current_grid. +SUBROUTINE get_current_time_string( time_str ) + USE module_domain + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(OUT) :: time_str + ! locals + INTEGER :: debug_level_lcl +!PRINT *,'DEBUG: begin get_current_time_string()' + time_str = '' + IF ( current_grid_set ) THEN +!$$$DEBUG +!PRINT *,'DEBUG: get_current_time_string(): checking association of current_grid...' +!IF ( ASSOCIATED( current_grid ) ) THEN +! PRINT *,'DEBUG: get_current_time_string(): current_grid is associated' +!ELSE +! PRINT *,'DEBUG: get_current_time_string(): current_grid is NOT associated' +!ENDIF +!$$$END DEBUG + IF ( current_grid%time_set ) THEN +!PRINT *,'DEBUG: get_current_time_string(): calling domain_clock_get()' + ! set debug_level to zero and clear current_grid_set to avoid recursion + CALL get_wrf_debug_level( debug_level_lcl ) + CALL set_wrf_debug_level ( 0 ) + current_grid_set = .FALSE. + CALL domain_clock_get( current_grid, current_timestr_frac=time_str ) + ! restore debug_level and current_grid_set + CALL set_wrf_debug_level ( debug_level_lcl ) + current_grid_set = .TRUE. +!PRINT *,'DEBUG: get_current_time_string(): back from domain_clock_get()' + ENDIF + ENDIF +!PRINT *,'DEBUG: end get_current_time_string()' +END SUBROUTINE get_current_time_string + + +! Get current domain name as a string of form "d" where "" is +! grid%id printed in two characters, with leading zero if needed ("d01", +! "d02", etc.). +! Return empty string if current_grid not set. +SUBROUTINE get_current_grid_name( grid_str ) + USE module_domain + IMPLICIT NONE + CHARACTER (LEN=*), INTENT(OUT) :: grid_str + grid_str = '' + IF ( current_grid_set ) THEN + WRITE(grid_str,FMT="('d',I2.2)") current_grid%id + ENDIF +END SUBROUTINE get_current_grid_name + + + diff --git a/wrfv2_fire/frame/module_driver_constants.F b/wrfv2_fire/frame/module_driver_constants.F new file mode 100644 index 00000000..abb03c3e --- /dev/null +++ b/wrfv2_fire/frame/module_driver_constants.F @@ -0,0 +1,70 @@ +!WRF:DRIVER_LAYER:CONSTANTS +! +! This MODULE contains all of the constants used in the model. These +! are separated by uage within the code. + +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 + + ! 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 + + INTEGER , PARAMETER :: max_eta = 501 + + ! 2. Following related to driver leve 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 unti numbers within these bounds will be chosen for I/O unit numbers. + + INTEGER , PARAMETER :: min_file_unit = 10 + INTEGER , PARAMETER :: max_file_unit = 99 + CONTAINS + SUBROUTINE init_module_driver_constants + END SUBROUTINE init_module_driver_constants + END MODULE module_driver_constants diff --git a/wrfv2_fire/frame/module_integrate.F b/wrfv2_fire/frame/module_integrate.F new file mode 100644 index 00000000..4070d86b --- /dev/null +++ b/wrfv2_fire/frame/module_integrate.F @@ -0,0 +1,393 @@ +!WRF:DRIVER_LAYER:INTEGRATION +! + +MODULE module_integrate + +CONTAINS + +RECURSIVE SUBROUTINE integrate ( grid ) + + + + USE module_domain + USE module_driver_constants + USE module_nesting + USE module_configure + USE module_timing + USE module_utility + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , POINTER :: grid + +! module_integrate:integrate +! +! This is a driver-level routine that controls the integration of a +! domain and subdomains rooted at the domain. +! +! The integrate routine takes a domain pointed to by the argument +! grid and advances the domain and its associated nests from the +! grid's current time, stored within grid%domain_clock, to a given time +! forward in the simulation, stored as grid%stop_subtime. The +! stop_subtime value is arbitrary and does not have to be the same as +! time that the domain finished integrating. The simulation stop time +! for the grid is known to the grid's clock (grid%domain_clock) and that +! is checked with a call to domain_clockisstoptime prior to beginning the +! loop over time period that is specified by the +! current time/stop_subtime interval. +! +! The clock, the simulation stop time for the domain, and other timing +! aspects for the grid are set up in the routine +! (setup_timekeeping) at the time +! that the domain is initialized. +! The lower-level time library and the type declarations for the times +! and time intervals used are defined either in +! external/esmf_time_f90/module_utility.F90 or in +! external/io_esmf/module_utility.F90 depending on a build-time decision to +! incorporate either the embedded ESMF subset implementation contained in +! external/esmf_time_f90 or to use a site-specific installation of the ESMF +! library. This decision is made during the configuration step of the WRF +! build process. Note that arithmetic and comparison is performed on these +! data types using F90 operator overloading, also defined in that library. +! +! This routine is the lowest level of the WRF Driver Layer and for the most +! part the WRF routines that are called from here are in the topmost level +! of the Mediation Layer. Mediation layer routines typically are not +! defined in modules. Therefore, the routines that this routine calls +! have explicit interfaces specified in an interface block in this routine. +! +! As part of the Driver Layer, this routine is intended to be non model-specific +! and so a minimum of WRF-specific logic is coded at this level. Rather, there +! are a number of calls to mediation layer routines that contain this logic, some +! of which are merely stubs in WRF Mediation Layer that sits below this routine +! in the call tree. The routines that integrate calls in WRF are defined in +! share/mediation_integrate.F. +! +! Flow of control +! +! 1. Check to see that the domain is not finished +! by testing the value returned by domain_clockisstoptime for the +! domain. +! +! 2. Model_to_grid_config_rec is called to load the local config_flags +! structure with the configuration information for the grid stored +! in model_config_rec and indexed by the grid's unique integer id. These +! structures are defined in frame/module_configure.F. +! +! 3. The current time of the domain is retrieved from the domain's clock +! using domain_get_current_time. +! +! 4. Iterate forward while the current time is less than the stop subtime. +! +! 4.a. Start timing for this iteration (only on node zero in distributed-memory runs) +! +! 4.b. Call med_setup_step to allow the mediation layer to +! do anything that's needed to call the solver for this domain. In WRF this means setting +! the indices into the 4D tracer arrays for the domain. +! +! 4.c. Check for any nests that need to be started up at this time. This is done +! calling the logical function nests_to_open (defined in +! frame/module_nesting.F) which returns true and the index into the current domain's list +! of children to use for the nest when one needs to be started. +! +! 4.c.1 Call alloc_and_configure_domain to allocate +! the new nest and link it as a child of this grid. +! +! 4.c.2 Call setup_Timekeeping for the nest. +! +! 4.c.3 Initialize the nest's arrays by calling med_nest_initial. This will +! either interpolate data from this grid onto the nest, read it in from a file, or both. In a restart run, this +! is also where the nest reads in its restart file. +! +! 4.d If a nest was opened above, check for and resolve overlaps (this is not implemented in WRF 2.0, which +! supports multiple nests on the same level but does not support overlapping). +! +! 4.e Give the mediation layer an opportunity to do something before the solver is called by +! calling med_before_solve_io. In WRF this is the point at which history and +! restart data is output. +! +! 4.f Call solve_interface which calls the solver that advance the domain +! one time step, then advance the domain's clock by calling domain_clockadvance. +! The enclosing WHILE loop around this section is for handling other domains +! with which this domain may overlap. It is not active in WRF 2.0 and only +! executes one trip. +! +! 4.g Call med_calc_model_time and med_after_solve_io, which are stubs in WRF. +! +! 4.h Iterate over the children of this domain (DO kid = 1, max_nests) and check each child pointer to see +! if it is associated (and therefore, active). +! +! 4.h.1 Force the nested domain boundaries from this domain by calling med_nest_force. +! +! 4.h.2 Setup the time period over which the nest is to run. Sine the current grid has been advanced one time step +! and the nest has not, the start for the nest is this grid's current time minus one time step. The nest's stop_subtime +! is the current time, bringing the nest up the same time level as this grid, its parent. +! +! 4.h.3 Recursively call this routine, integrate, to advance the nest's time. Since it is recursive, this will +! also advance all the domains who are nests of this nest and so on. In other words, when this call returns, all +! the domains rooted at the nest will be at the current time. +! +! 4.h.4 Feedback data from the nested domain back onto this domain by calling med_nest_feedback. +! +! 4.i Write the time to compute this grid and its subtree. This marks the end of the loop begun at step 4, above. +! +! 5. Give the mediation layer an opportunity to do I/O at the end of the sequence of steps that brought the +! grid up to stop_subtime with a call to med_last_solve_io. In WRF, this +! is used to generate the final history and/or restart output when the domain reaches the end of it's integration. +! There is logic here to make sure this occurs correctly on a nest, since the nest may finish before its parent. +! + + ! Local data. + + CHARACTER*32 :: outname, rstname + TYPE(domain) , POINTER :: grid_ptr , new_nest + TYPE(domain) :: intermediate_grid + INTEGER :: step + INTEGER :: nestid , kid + LOGICAL :: a_nest_was_opened + INTEGER :: fid , rid + LOGICAL :: lbc_opened + REAL :: time, btime, bfrq + CHARACTER*256 :: message, message2 + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + INTEGER :: idum1 , idum2 , ierr , open_status + LOGICAL :: should_do_last_io + + ! interface + INTERFACE + ! mediation-supplied solver + SUBROUTINE solve_interface ( grid ) + USE module_domain + TYPE (domain) grid + END SUBROUTINE solve_interface + ! mediation-supplied routine to allow driver to pass time information + ! down to mediation/model layer + SUBROUTINE med_calc_model_time ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_calc_model_time + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform I/O before the call to the solve routine + SUBROUTINE med_before_solve_io ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_before_solve_io + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform I/O after the call to the solve routine + SUBROUTINE med_after_solve_io ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_after_solve_io + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform I/O to initialize a new nest + SUBROUTINE med_pre_nest_initial ( parent , newid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: parent + INTEGER, INTENT(IN) :: newid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_pre_nest_initial + SUBROUTINE med_nest_initial ( parent , grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: grid , parent + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_nest_initial + ! mediation-supplied routine that gives mediation layer opportunity to + ! provide parent->nest forcing + SUBROUTINE med_nest_force ( parent , grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: grid, parent + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_nest_force + +#ifdef MOVE_NESTS + SUBROUTINE med_nest_move ( parent , grid ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: grid , parent + END SUBROUTINE med_nest_move +#endif + + ! mediation-supplied routine that gives mediation layer opportunity to + ! provide parent->nest feedback + SUBROUTINE med_nest_feedback ( parent , grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: grid , parent + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_nest_feedback + + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform I/O prior to the close of this call to integrate + SUBROUTINE med_last_solve_io ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_last_solve_io + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform setup before iteration over steps in this call to integrate + SUBROUTINE med_setup_step ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_setup_step + ! mediation-supplied routine that gives mediation layer opportunity to + ! perform setup before iteration over steps in this call to integrate + SUBROUTINE med_endup_step ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_endup_step + ! mediation-supplied routine that intializes the nest from the grid + ! by interpolation + + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE + + END INTERFACE + + ! This allows us to reference the current grid from anywhere beneath + ! this point for debugging purposes. + ! In the case of operations involving already initialized parent and child, + ! the current grid is set to the child grid. +!$$$ Improve this later to track both parent and child... +!$$$ Use either an optional argument or another interface... + CALL set_current_grid_ptr( grid ) + + IF ( .NOT. domain_clockisstoptime( grid ) ) THEN + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + IF ( .NOT. grid%return_after_training_io ) THEN + CALL domain_clockprint ( 150, grid, 'DEBUG: top of integrate(),' ) + ENDIF + DO WHILE ( .NOT. domain_clockisstopsubtime(grid) ) + IF ( .NOT. grid%return_after_training_io ) THEN + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + ENDIF + CALL med_setup_step ( grid , config_flags ) + IF ( .NOT. grid%return_after_training_io ) THEN + a_nest_was_opened = .false. + ! for each nest whose time has come... + DO WHILE ( nests_to_open( grid , nestid , kid ) ) + ! nestid is index into model_config_rec (module_configure) of the grid + ! to be opened; kid is index into an open slot in grid's list of children + a_nest_was_opened = .true. + CALL med_pre_nest_initial ( grid , nestid , config_flags ) + CALL alloc_and_configure_domain ( domain_id = nestid , & + grid = new_nest , & + parent = grid , & + kid = kid ) + CALL Setup_Timekeeping (new_nest) + CALL med_nest_initial ( grid , new_nest , config_flags ) + END DO + IF ( a_nest_was_opened ) THEN + CALL set_overlaps ( grid ) ! find overlapping and set pointers + END IF + ENDIF + CALL med_before_solve_io ( grid , config_flags ) + IF ( grid%return_after_training_io ) THEN + CALL wrf_debug( 1, 'DEBUG: module_integrate() returned after training' ) + RETURN ! an ugly hack for sure, only needed for ESMF + ENDIF + grid_ptr => grid + DO WHILE ( ASSOCIATED( grid_ptr ) ) + CALL set_current_grid_ptr( grid_ptr ) + CALL wrf_debug( 100 , 'module_integrate: calling solve interface ' ) + CALL solve_interface ( grid_ptr ) + CALL domain_clockadvance ( grid_ptr ) + CALL wrf_debug( 100 , 'module_integrate: back from solve interface ' ) + ! print lots of time-related information for testing + ! switch this on with namelist variable self_test_domain + CALL domain_time_test( grid_ptr, 'domain_clockadvance' ) + grid_ptr => grid_ptr%sibling + END DO + CALL set_current_grid_ptr( grid ) + CALL med_calc_model_time ( grid , config_flags ) + CALL med_after_solve_io ( grid , config_flags ) + grid_ptr => grid + DO WHILE ( ASSOCIATED( grid_ptr ) ) + DO kid = 1, max_nests + IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) ) THEN + CALL set_current_grid_ptr( grid_ptr%nests(kid)%ptr ) + ! Recursive -- advance nests from previous time level to this time level. + CALL wrf_debug( 100 , 'module_integrate: calling med_nest_force ' ) + CALL med_nest_force ( grid_ptr , grid_ptr%nests(kid)%ptr , config_flags ) + CALL wrf_debug( 100 , 'module_integrate: back from med_nest_force ' ) + grid_ptr%nests(kid)%ptr%start_subtime = & + domain_get_current_time(grid) - domain_get_time_step(grid) + grid_ptr%nests(kid)%ptr%stop_subtime = & + domain_get_current_time(grid) + CALL integrate ( grid_ptr%nests(kid)%ptr ) + CALL wrf_debug( 100 , 'module_integrate: back from recursive call to integrate ' ) + CALL wrf_debug( 100 , 'module_integrate: calling med_nest_feedback ' ) + CALL med_nest_feedback ( grid_ptr , grid_ptr%nests(kid)%ptr , config_flags ) + CALL wrf_debug( 100 , 'module_integrate: back from med_nest_feedback ' ) +#ifdef MOVE_NESTS + IF ( .NOT. domain_clockisstoptime( head_grid ) ) THEN + CALL med_nest_move ( grid_ptr , grid_ptr%nests(kid)%ptr ) + ENDIF +#endif + END IF + END DO + grid_ptr => grid_ptr%sibling + END DO + CALL set_current_grid_ptr( grid ) + ! Report on the timing for a single time step. + IF ( wrf_dm_on_monitor() ) THEN +! begin KLUDGE +! ia32 pgi 6.0-2 and prescribed moving nest: the returned date string message2 is +! corrupt after the first specified move UNLESS the string is initialized to all +! spaces - REMOVE THIS INIT OF MESSAGE2 WHEN POSSIBLE +! 2005 10 28 + message2=' ' // & + ' ' // & + ' ' // & + ' ' +! end KLUDGE + CALL domain_clock_get ( grid, current_timestr=message2 ) + WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id + CALL end_timing ( TRIM(message) ) + END IF + CALL med_endup_step ( grid , config_flags ) + END DO + ! Avoid double writes on nests if this is not really the last time; + ! Do check for write if the parent domain is ending. + IF ( grid%id .EQ. 1 ) THEN ! head_grid + CALL med_last_solve_io ( grid , config_flags ) + ELSE + +! zip up the tree and see if any ancestor is at its stop time + + should_do_last_io = domain_clockisstoptime( head_grid ) + grid_ptr => grid + DO WHILE ( grid_ptr%id .NE. 1 ) + IF ( domain_clockisstoptime( grid_ptr ) ) should_do_last_io = .TRUE. + grid_ptr => grid_ptr%parents(1)%ptr + ENDDO + IF ( should_do_last_io ) THEN + CALL med_last_solve_io ( grid , config_flags ) + ENDIF + ENDIF + END IF + +END SUBROUTINE integrate + +END MODULE module_integrate + diff --git a/wrfv2_fire/frame/module_internal_header_util.F b/wrfv2_fire/frame/module_internal_header_util.F new file mode 100644 index 00000000..e71253bd --- /dev/null +++ b/wrfv2_fire/frame/module_internal_header_util.F @@ -0,0 +1,1081 @@ +MODULE module_internal_header_util + +! +!
+! Subroutines defined in this module are used to generate (put together) and get (take apart) 
+! data headers stored in the form of integer vectors.
+! 
+! Data headers serve two purposes:  
+!   - Provide a package-independent metadata storage and retrieval mechanism 
+!     for I/O packages that do not support native metadata.  
+!   - Provide a mechanism for communicating I/O commands from compute 
+!     tasks to quilt tasks when I/O quilt servers are enabled.  
+! 
+! Within a data header, character strings are stored one character per integer.  
+! The number of characters is stored immediately before the first character of 
+! each string.
+!
+! In an I/O package that does not support native metadata, routines 
+! int_gen_*_header() are called to pack information into data headers that 
+! are then written to files.  Routines int_get_*_header() are called to 
+! extract information from a data headers after they have been read from a 
+! file.  
+!
+! When I/O quilt server tasks are used, routines int_gen_*_header() 
+! are called by compute tasks to pack information into data headers 
+! (commands) that are then sent to the I/O quilt servers.  Routines 
+! int_get_*_header() are called by I/O quilt servers to extract 
+! information from data headers (commands) received from the compute 
+! tasks.  
+!
+!
+! + +INTERFACE int_get_ti_header + MODULE PROCEDURE int_get_ti_header_integer, int_get_ti_header_real +END INTERFACE +INTERFACE int_gen_ti_header + MODULE PROCEDURE int_gen_ti_header_integer, int_gen_ti_header_real +END INTERFACE +INTERFACE int_get_td_header + MODULE PROCEDURE int_get_td_header_integer, int_get_td_header_real +END INTERFACE +INTERFACE int_gen_td_header + MODULE PROCEDURE int_gen_td_header_integer, int_gen_td_header_real +END INTERFACE + +PRIVATE :: int_pack_string, int_unpack_string + +CONTAINS +!!!!!!!!!!!!! header manipulation routines !!!!!!!!!!!!!!! + +INTEGER FUNCTION get_hdr_tag( hdrbuf ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: hdrbuf(*) + get_hdr_tag = hdrbuf(2) + RETURN +END FUNCTION get_hdr_tag + +INTEGER FUNCTION get_hdr_rec_size( hdrbuf ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: hdrbuf(*) + get_hdr_rec_size = hdrbuf(1) + RETURN +END FUNCTION get_hdr_rec_size + +SUBROUTINE int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +! +!
+! Items and their starting locations within a "write field" data header.  
+! Assume that the data header is stored in integer vector "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = ftypesize
+!  hdrbuf(4) = DataHandle
+!  hdrbuf(5) = LEN(TRIM(DateStr))
+!  hdrbuf(6:5+n1) = DateStr                                          ! n1 = LEN(TRIM(DateStr)) + 1
+!  hdrbuf(6+n1) = LEN(TRIM(VarName))
+!  hdrbuf(7+n1:6+n1+n2) = VarName                                    ! n2 = LEN(TRIM(VarName)) + 1
+!  hdrbuf(7+n1+n2) = FieldType
+!  hdrbuf(8+n1+n2) = LEN(TRIM(MemoryOrder))
+!  hdrbuf(9+n1+n2:8+n1+n2+n3) = MemoryOrder                          ! n3 = LEN(TRIM(MemoryOrder)) + 1
+!  hdrbuf(9+n1+n2+n3) = LEN(TRIM(Stagger))
+!  hdrbuf(9+n1+n2+n3:8+n1+n2+n3+n4) = Stagger                        ! n4 = LEN(TRIM(Stagger)) + 1
+!  hdrbuf(9+n1+n2+n3+n4) = LEN(TRIM(DimNames(1)))
+!  hdrbuf(9+n1+n2+n3+n4:8+n1+n2+n3+n4+n5) = DimNames(1)              ! n5 = LEN(TRIM(DimNames(1))) + 1
+!  hdrbuf(9+n1+n2+n3+n4+n5) = LEN(TRIM(DimNames(2)))
+!  hdrbuf(9+n1+n2+n3+n4+n5:8+n1+n2+n3+n4+n5+n6) = DimNames(2)        ! n6 = LEN(TRIM(DimNames(2))) + 1
+!  hdrbuf(9+n1+n2+n3+n4+n5+n6) = LEN(TRIM(DimNames(3)))
+!  hdrbuf(9+n1+n2+n3+n4+n5+n6:8+n1+n2+n3+n4+n5+n6+n7) = DimNames(3)  ! n7 = LEN(TRIM(DimNames(3))) + 1
+!  hdrbuf(9+n1+n2+n3+n4+n5+n6+n7) = DomainStart(1)
+!  hdrbuf(10+n1+n2+n3+n4+n5+n6+n7) = DomainStart(2)
+!  hdrbuf(11+n1+n2+n3+n4+n5+n6+n7) = DomainStart(3)
+!  hdrbuf(12+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(1)
+!  hdrbuf(13+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(2)
+!  hdrbuf(14+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(3)
+!  hdrbuf(15+n1+n2+n3+n4+n5+n6+n7) = PatchStart(1)
+!  hdrbuf(16+n1+n2+n3+n4+n5+n6+n7) = PatchStart(2)
+!  hdrbuf(17+n1+n2+n3+n4+n5+n6+n7) = PatchStart(3)
+!  hdrbuf(18+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(1)
+!  hdrbuf(19+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(2)
+!  hdrbuf(20+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(3)
+!  hdrbuf(21+n1+n2+n3+n4+n5+n6+n7) = DomainDesc
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For a "write field" header it must be set to 
+!               int_field.  See file intio_tags.h for a complete list of 
+!               these tags.  
+!  ftypesize:   Size of field data type in bytes.  
+!  DataHandle:  Descriptor for an open data set.  
+!  DomainDesc:  Additional argument that may be used by some packages as a 
+!               package-specific domain descriptor.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(INOUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize, ftypesize + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*), INTENT(IN) :: DateStr + CHARACTER*(*), INTENT(IN) :: VarName + REAL, DIMENSION(*) :: Dummy + INTEGER ,intent(in) :: FieldType + INTEGER ,intent(inout) :: Comm + INTEGER ,intent(inout) :: IOComm + INTEGER ,intent(in) :: DomainDesc + CHARACTER*(*) ,intent(in) :: MemoryOrder + CHARACTER*(*) ,intent(in) :: Stagger + CHARACTER*(*) , dimension (*) ,intent(in) :: DimNames + INTEGER ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + INTEGER ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + INTEGER ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + + INTEGER i, n + + + hdrbuf(1) = 0 ! deferred -- this will be length of header + hdrbuf(2) = int_field + hdrbuf(3) = ftypesize + + i = 4 + hdrbuf(i) = DataHandle ; i = i+1 + call int_pack_string( DateStr, hdrbuf(i), n ) ; i = i + n + call int_pack_string( VarName, hdrbuf(i), n ) ; i = i + n + hdrbuf(i) = FieldType ; i = i+1 + call int_pack_string( MemoryOrder, hdrbuf(i), n ) ; i = i + n + call int_pack_string( Stagger, hdrbuf(i), n ) ; i = i + n + call int_pack_string( DimNames(1), hdrbuf(i), n ) ; i = i + n + call int_pack_string( DimNames(2), hdrbuf(i), n ) ; i = i + n + call int_pack_string( DimNames(3), hdrbuf(i), n ) ; i = i + n + hdrbuf(i) = DomainStart(1) ; i = i+1 + hdrbuf(i) = DomainStart(2) ; i = i+1 + hdrbuf(i) = DomainStart(3) ; i = i+1 + hdrbuf(i) = DomainEnd(1) ; i = i+1 + hdrbuf(i) = DomainEnd(2) ; i = i+1 + hdrbuf(i) = DomainEnd(3) ; i = i+1 + hdrbuf(i) = PatchStart(1) ; i = i+1 + hdrbuf(i) = PatchStart(2) ; i = i+1 + hdrbuf(i) = PatchStart(3) ; i = i+1 + hdrbuf(i) = PatchEnd(1) ; i = i+1 + hdrbuf(i) = PatchEnd(2) ; i = i+1 + hdrbuf(i) = PatchEnd(3) ; i = i+1 + hdrbuf(i) = DomainDesc ; i = i+1 + + hdrbufsize = (i-1) * itypesize ! return the number in bytes + hdrbuf(1) = hdrbufsize + + RETURN +END SUBROUTINE int_gen_write_field_header + + +SUBROUTINE int_get_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +! +!
+! See documentation block in int_gen_write_field_header() for 
+! a description of a "write field" header.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize, ftypesize + INTEGER , INTENT(OUT) :: DataHandle + CHARACTER*(*), INTENT(INOUT) :: DateStr + CHARACTER*(*), INTENT(INOUT) :: VarName + REAL, DIMENSION(*) :: Dummy + INTEGER :: FieldType + INTEGER :: Comm + INTEGER :: IOComm + INTEGER :: DomainDesc + CHARACTER*(*) :: MemoryOrder + CHARACTER*(*) :: Stagger + CHARACTER*(*) , dimension (*) :: DimNames + INTEGER ,dimension(*) :: DomainStart, DomainEnd + INTEGER ,dimension(*) :: MemoryStart, MemoryEnd + INTEGER ,dimension(*) :: PatchStart, PatchEnd +!Local + CHARACTER*132 mess + INTEGER i, n + + hdrbufsize = hdrbuf(1) + IF ( hdrbuf(2) .NE. int_field ) THEN + write(mess,*)'int_get_write_field_header: hdrbuf(2) ne int_field ',hdrbuf(2),int_field + CALL wrf_error_fatal ( mess ) + ENDIF + ftypesize = hdrbuf(3) + + i = 4 + DataHandle = hdrbuf(i) ; i = i+1 + call int_unpack_string( DateStr, hdrbuf(i), n ) ; i = i+n + call int_unpack_string( VarName, hdrbuf(i), n ) ; i = i+n + FieldType = hdrbuf(i) ; i = i+1 + call int_unpack_string( MemoryOrder, hdrbuf(i), n ) ; i = i+n + call int_unpack_string( Stagger, hdrbuf(i), n ) ; i = i+n + call int_unpack_string( DimNames(1), hdrbuf(i), n ) ; i = i+n + call int_unpack_string( DimNames(2), hdrbuf(i), n ) ; i = i+n + call int_unpack_string( DimNames(3), hdrbuf(i), n ) ; i = i+n + DomainStart(1) = hdrbuf(i) ; i = i+1 + DomainStart(2) = hdrbuf(i) ; i = i+1 + DomainStart(3) = hdrbuf(i) ; i = i+1 + DomainEnd(1) = hdrbuf(i) ; i = i+1 + DomainEnd(2) = hdrbuf(i) ; i = i+1 + DomainEnd(3) = hdrbuf(i) ; i = i+1 + PatchStart(1) = hdrbuf(i) ; i = i+1 + PatchStart(2) = hdrbuf(i) ; i = i+1 + PatchStart(3) = hdrbuf(i) ; i = i+1 + PatchEnd(1) = hdrbuf(i) ; i = i+1 + PatchEnd(2) = hdrbuf(i) ; i = i+1 + PatchEnd(3) = hdrbuf(i) ; i = i+1 + DomainDesc = hdrbuf(i) ; i = i+1 + + RETURN +END SUBROUTINE int_get_write_field_header + +!!!!!!!! + +!generate open for read header +SUBROUTINE int_gen_ofr_header( hdrbuf, hdrbufsize, itypesize, & + FileName, SysDepInfo, DataHandle ) +! +!
+! Items and their starting locations within a "open for read" data header.  
+! Assume that the data header is stored in integer vector "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = LEN(TRIM(FileName))
+!  hdrbuf(5:4+n1) = FileName             ! n1 = LEN(TRIM(FileName)) + 1
+!  hdrbuf(5+n1) = LEN(TRIM(SysDepInfo))
+!  hdrbuf(6+n1:5+n1+n2) = SysDepInfo     ! n2 = LEN(TRIM(SysDepInfo)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "open for read" header it must be set to 
+!               int_open_for_read.  See file intio_tags.h for a complete list of 
+!               these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  FileName:    File name.  
+!  SysDepInfo:  System dependent information used for optional additional 
+!               I/O control information.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*), INTENT(INOUT) :: FileName + CHARACTER*(*), INTENT(INOUT) :: SysDepInfo +!Local + INTEGER i, n, i1 +! + hdrbuf(1) = 0 !deferred + hdrbuf(2) = int_open_for_read + i = 3 + hdrbuf(i) = DataHandle ; i = i+1 + + call int_pack_string( TRIM(FileName), hdrbuf(i), n ) ; i = i + n + call int_pack_string( TRIM(SysDepInfo), hdrbuf(i), n ) ; i = i + n + hdrbufsize = (i-1) * itypesize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_ofr_header + +!get open for read header +SUBROUTINE int_get_ofr_header( hdrbuf, hdrbufsize, itypesize, & + FileName, SysDepInfo, DataHandle ) +! +!
+! See documentation block in int_gen_ofr_header() for 
+! a description of a "open for read" header.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER , INTENT(OUT) :: DataHandle + CHARACTER*(*), INTENT(INOUT) :: FileName + CHARACTER*(*), INTENT(INOUT) :: SysDepInfo +!Local + INTEGER i, n +! + hdrbufsize = hdrbuf(1) +! IF ( hdrbuf(2) .NE. int_open_for_read ) THEN +! CALL wrf_error_fatal ( "int_get_ofr_header: hdrbuf ne int_open_for_read") +! ENDIF + i = 3 + DataHandle = hdrbuf(i) ; i = i+1 + call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n + call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n + RETURN +END SUBROUTINE int_get_ofr_header + +!!!!!!!! + +!generate open for write begin header +SUBROUTINE int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + FileName, SysDepInfo, io_form, DataHandle ) +! +!
+! Items and their starting locations within a "open for write begin" data 
+! header.  Assume that the data header is stored in integer vector "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = io_form
+!  hdrbuf(5) = LEN(TRIM(FileName))
+!  hdrbuf(6:5+n1) = FileName             ! n1 = LEN(TRIM(FileName)) + 1
+!  hdrbuf(6+n1) = LEN(TRIM(SysDepInfo))
+!  hdrbuf(7+n1:6+n1+n2) = SysDepInfo     ! n2 = LEN(TRIM(SysDepInfo)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "open for write begin" header it must be set to 
+!               int_open_for_write_begin.  See file intio_tags.h for a complete list of 
+!               these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  io_form:     I/O format for this file (netCDF, etc.).  
+!  FileName:    File name.  
+!  SysDepInfo:  System dependent information used for optional additional 
+!               I/O control information.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER , INTENT(IN) :: io_form + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*), INTENT(INOUT) :: FileName + CHARACTER*(*), INTENT(INOUT) :: SysDepInfo +!Local + INTEGER i, n, j +! + hdrbuf(1) = 0 !deferred + hdrbuf(2) = int_open_for_write_begin + i = 3 + hdrbuf(i) = DataHandle ; i = i+1 + hdrbuf(i) = io_form ; i = i+1 +!j = i + call int_pack_string( FileName, hdrbuf(i), n ) ; i = i + n +!write(0,*)'int_gen_ofwb_header FileName ',TRIM(FileName),hdrbuf(j),n +!j = i + call int_pack_string( SysDepInfo, hdrbuf(i), n ) ; i = i + n +!write(0,*)'int_gen_ofwb_header SysDepInfo ',TRIM(SysDepInfo),hdrbuf(j),n + hdrbufsize = (i-1) * itypesize ! return the number in bytes + hdrbuf(1) = hdrbufsize +!write(0,*)'int_gen_ofwb_header hdrbuf(1) ',hdrbuf(1) + RETURN +END SUBROUTINE int_gen_ofwb_header + +!get open for write begin header +SUBROUTINE int_get_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + FileName, SysDepInfo, io_form, DataHandle ) +! +!
+! See documentation block in int_gen_ofwb_header() for 
+! a description of a "open for write begin" header.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: io_form + CHARACTER*(*), INTENT (INOUT) :: FileName + CHARACTER*(*), INTENT (INOUT) :: SysDepInfo +!Local + INTEGER i, n, j +! + hdrbufsize = hdrbuf(1) +!write(0,*)' int_get_ofwb_header next rec start ',hdrbuf(hdrbufsize+1) +! IF ( hdrbuf(2) .NE. int_open_for_write_begin ) THEN +! CALL wrf_error_fatal ( "int_get_ofwb_header: hdrbuf ne int_open_for_write_begin") +! ENDIF + i = 3 + DataHandle = hdrbuf(i) ; i = i+1 +!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1) + io_form = hdrbuf(i) ; i = i+1 +!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1) + +!j = i + call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n +!write(0,*)'int_get_ofwb_header FileName ',TRIM(FileName),hdrbuf(j),n +!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1) +!j = i + call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n +!write(0,*)'int_get_ofwb_header SysDepInfo ',TRIM(SysDepInfo),hdrbuf(j),n +!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1) +!write(0,*)'int_get_ofwb_header hdrbufsize ',hdrbufsize + RETURN +END SUBROUTINE int_get_ofwb_header + +!!!!!!!!!! + +SUBROUTINE int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , code ) +! +!
+! Items and their starting locations within a "generic handle" data header.  
+! Several types of data headers contain only a DataHandle and a header tag 
+! (I/O command).  This routine is used for all of them.  Assume that 
+! the data header is stored in integer vector "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For a "generic handle" header there are 
+!               several possible values.  In this routine, dummy argument 
+!               "code" is used as headerTag.  
+!  DataHandle:  Descriptor for an open data set.  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER ,INTENT(IN) :: DataHandle, code +!Local + INTEGER i +! + hdrbuf(1) = 0 !deferred + hdrbuf(2) = code + i = 3 + hdrbuf(i) = DataHandle ; i = i+1 + hdrbufsize = (i-1) * itypesize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_handle_header + +SUBROUTINE int_get_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , code ) +! +!
+! See documentation block in int_gen_handle_header() for 
+! a description of a "generic handle" header.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize + INTEGER ,INTENT(OUT) :: DataHandle, code +!Local + INTEGER i +! + hdrbufsize = hdrbuf(1) + code = hdrbuf(2) + i = 3 + DataHandle = hdrbuf(i) ; i = i+1 + RETURN +END SUBROUTINE int_get_handle_header + +!!!!!!!!!!!! + +SUBROUTINE int_gen_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Element, Data, Count, code ) +! +!
+! Items and their starting locations within a "time-independent integer" 
+! data header.  Assume that the data header is stored in integer vector 
+! "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = typesize
+!  hdrbuf(5) = Count
+!  hdrbuf(6:6+n1) = Data              ! n1 = (Count * typesize / itypesize) + 1
+!  hdrbuf(7+n1) = LEN(TRIM(Element))
+!  hdrbuf(8+n1:7+n1+n2) = Element     ! n2 = LEN(TRIM(Element)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "time-independent integer" header it must be 
+!               set to int_dom_ti_integer.  See file intio_tags.h for a complete 
+!               list of these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  typesize:    Size in bytes of each element of Data.  
+!  Count:       Number of elements in Data.  
+!  Data:        Data to write to file.  
+!  Element:     Name of the data.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: Element + INTEGER, INTENT(IN) :: Data(*) + INTEGER, INTENT(IN) :: DataHandle, Count, code +!Local + INTEGER i, n +! + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = hdrbufsize/itypesize + 1 ; +!write(0,*)'int_gen_ti_header_integer ',TRIM(Element) + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_ti_header_integer + +SUBROUTINE int_gen_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Element, Data, Count, code ) +! +!
+! Same as int_gen_ti_header_integer except that Data has type REAL.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: Element + REAL, INTENT(IN) :: Data(*) + INTEGER, INTENT(IN) :: DataHandle, Count, code +!Local + INTEGER i, n +! + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = hdrbufsize/itypesize + 1 ; +!write(0,*)'int_gen_ti_header_real ',TRIM(Element) + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_ti_header_real + +SUBROUTINE int_get_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Element, Data, Count, code ) +! +!
+! Same as int_gen_ti_header_integer except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: Element + INTEGER, INTENT(OUT) :: Data(*) + INTEGER, INTENT(OUT) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = 1 + CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ; +!write(0,*)'int_get_ti_header_integer ',TRIM(Element), Data(1) + hdrbufsize = hdrbuf(1) + RETURN +END SUBROUTINE int_get_ti_header_integer + +SUBROUTINE int_get_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Element, Data, Count, code ) +! +!
+! Same as int_gen_ti_header_real except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: Element + REAL, INTENT(OUT) :: Data(*) + INTEGER, INTENT(OUT) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = 1 + CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ; +!write(0,*)'int_get_ti_header_real ',TRIM(Element), Data(1) + hdrbufsize = hdrbuf(1) + RETURN +END SUBROUTINE int_get_ti_header_real + +!!!!!!!!!!!! + +SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, VarName, Data, code ) +! +!
+! Items and their starting locations within a "time-independent string" 
+! data header.  Assume that the data header is stored in integer vector 
+! "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = typesize
+!  hdrbuf(5) = LEN(TRIM(Element))
+!  hdrbuf(6:5+n1) = Element                ! n1 = LEN(TRIM(Element)) + 1
+!  hdrbuf(6+n1) = LEN(TRIM(Data))
+!  hdrbuf(7+n1:6+n1+n2) = Data             ! n2 = LEN(TRIM(Data)) + 1
+!  hdrbuf(7+n1+n2) = LEN(TRIM(VarName))
+!  hdrbuf(8+n1+n2:7+n1+n2+n3) = VarName    ! n3 = LEN(TRIM(VarName)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "time-independent string" header it must be 
+!               set to int_dom_ti_char.  See file intio_tags.h for a complete 
+!               list of these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  typesize:    1 (size in bytes of a single CHARACTER).  
+!  Element:     Name of the data.  
+!  Data:        Data to write to file.  
+!  VarName:     Variable name.  Used for *__var_ti_char but not for 
+!               *__dom_ti_char.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize + CHARACTER*(*), INTENT(IN) :: Element, Data, VarName + INTEGER, INTENT(IN) :: DataHandle, code +!Local + INTEGER :: DummyData + INTEGER i, n, Count, DummyCount +! + DummyCount = 0 + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, & + DataHandle, DummyData, DummyCount, code ) + i = hdrbufsize/itypesize+1 ; + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( VarName , hdrbuf( i ), n ) ; i = i + n + hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_ti_header_char + +SUBROUTINE int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, VarName, Data, code ) +! +!
+! Same as int_gen_ti_header_char except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize + CHARACTER*(*), INTENT(INOUT) :: Element, Data, VarName + INTEGER, INTENT(OUT) :: DataHandle, code +!Local + INTEGER i, n, DummyCount, typesize + CHARACTER * 132 dummyData +! + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, dummyData, DummyCount, code ) + i = n/itypesize+1 ; + CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n + CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n + CALL int_unpack_string ( VarName , hdrbuf( i ), n ) ; i = i + n + hdrbufsize = hdrbuf(1) + + RETURN +END SUBROUTINE int_get_ti_header_char + + +!!!!!!!!!!!! + +SUBROUTINE int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, DateStr, Element, Data, code ) +! +!
+! Items and their starting locations within a "time-dependent string" 
+! data header.  Assume that the data header is stored in integer vector 
+! "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = typesize
+!  hdrbuf(5) = LEN(TRIM(Element))
+!  hdrbuf(6:5+n1) = Element            ! n1 = LEN(TRIM(Element)) + 1
+!  hdrbuf(6+n1) = LEN(TRIM(DateStr))
+!  hdrbuf(7+n1:6+n1+n2) = DateStr      ! n2 = LEN(TRIM(DateStr)) + 1
+!  hdrbuf(7+n1+n2) = LEN(TRIM(Data))
+!  hdrbuf(8+n1+n2:7+n1+n2+n3) = Data   ! n3 = LEN(TRIM(Data)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "time-dependent string" header it must be 
+!               set to int_dom_td_char.  See file intio_tags.h for a complete 
+!               list of these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  typesize:    1 (size in bytes of a single CHARACTER).  
+!  Element:     Name of the data.  
+!  Data:        Data to write to file.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element, Data + INTEGER, INTENT(IN) :: DataHandle, code +!Local + INTEGER i, n, DummyCount, DummyData +! + DummyCount = 0 + + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, & + DataHandle, DummyData, DummyCount, code ) + i = hdrbufsize/itypesize + 1 ; + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n + hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_td_header_char + +SUBROUTINE int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, DateStr, Element, Data, code ) +! +!
+! Same as int_gen_td_header_char except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element, Data + INTEGER, INTENT(OUT) :: DataHandle, code +!Local + INTEGER i, n, Count, typesize +! + + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = n/itypesize + 1 ; + CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ; + CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ; + CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n ; + hdrbufsize = hdrbuf(1) + RETURN +END SUBROUTINE int_get_td_header_char + +SUBROUTINE int_gen_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, DateStr, Element, Data, Count, code ) +! +!
+! Items and their starting locations within a "time-dependent integer" 
+! data header.  Assume that the data header is stored in integer vector 
+! "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!  hdrbuf(3) = DataHandle
+!  hdrbuf(4) = typesize
+!  hdrbuf(5) = Count
+!  hdrbuf(6:6+n1) = Data              ! n1 = (Count * typesize / itypesize) + 1
+!  hdrbuf(7+n1) = LEN(TRIM(DateStr))
+!  hdrbuf(8+n1:7+n1+n2) = DateStr      ! n2 = LEN(TRIM(DateStr)) + 1
+!  hdrbuf(8+n1+n2) = LEN(TRIM(Element))
+!  hdrbuf(9+n1+n2:8+n1+n2+n3) = Element   ! n3 = LEN(TRIM(Element)) + 1
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "time-dependent integer" header it must be 
+!               set to int_dom_td_integer.  See file intio_tags.h for a complete 
+!               list of these tags.  
+!  DataHandle:  Descriptor for an open data set.  
+!  typesize:    1 (size in bytes of a single CHARACTER).  
+!  Element:     Name of the data.  
+!  Count:       Number of elements in Data.  
+!  Data:        Data to write to file.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element + INTEGER, INTENT(IN) :: Data(*) + INTEGER, INTENT(IN) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = hdrbufsize/itypesize + 1 ; + CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_td_header_integer + +SUBROUTINE int_gen_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, DateStr, Element, Data, Count, code ) +! +!
+! Same as int_gen_td_header_integer except that Data has type REAL.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element + REAL, INTENT(IN) :: Data(*) + INTEGER, INTENT(IN) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = hdrbufsize/itypesize + 1 ; + CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n + CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n + hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_td_header_real + +SUBROUTINE int_get_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, DateStr, Element, Data, Count, code ) +! +!
+! Same as int_gen_td_header_integer except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element + INTEGER, INTENT(OUT) :: Data(*) + INTEGER, INTENT(OUT) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = n/itypesize + 1 ; + CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ; + CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ; + hdrbufsize = hdrbuf(1) + RETURN +END SUBROUTINE int_get_td_header_integer + +SUBROUTINE int_get_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, DateStr, Element, Data, Count, code ) +! +!
+! Same as int_gen_td_header_real except that Data is read from 
+! the file.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(IN) :: itypesize, typesize + CHARACTER*(*), INTENT(INOUT) :: DateStr, Element + REAL , INTENT(OUT) :: Data(*) + INTEGER, INTENT(OUT) :: DataHandle, Count, code +!Local + INTEGER i, n +! + + CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, & + DataHandle, Data, Count, code ) + i = n/itypesize + 1 ; + CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ; + CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ; + hdrbufsize = hdrbuf(1) + RETURN +END SUBROUTINE int_get_td_header_real + +!!!!!!!!!!!!!! + +SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize ) + IMPLICIT NONE +! +!
+! Items and their starting locations within a "no-operation" 
+! data header.  Assume that the data header is stored in integer vector 
+! "hdrbuf":  
+!  hdrbuf(1) = hdrbufsize
+!  hdrbuf(2) = headerTag
+!
+! Further details for some items:  
+!  hdrbufsize:  Size of this data header in bytes.  
+!  headerTag:   "Header tag" that tells the I/O quilt servers what kind of 
+!               header this is.  For an "no-operation" header it must be 
+!               set to int_noop.  See file intio_tags.h for a complete 
+!               list of these tags.  
+!
+!
+! + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize +!Local + INTEGER i +! + hdrbuf(1) = 0 !deferred + hdrbuf(2) = int_noop + i = 3 + hdrbufsize = (i-1) * itypesize ! return the number in bytes + hdrbuf(1) = hdrbufsize + RETURN +END SUBROUTINE int_gen_noop_header + +SUBROUTINE int_get_noop_header( hdrbuf, hdrbufsize, itypesize ) +! +!
+! See documentation block in int_gen_noop_header() for 
+! a description of a "no-operation" header.  
+!
+! + IMPLICIT NONE + INCLUDE 'intio_tags.h' + INTEGER, INTENT(INOUT) :: hdrbuf(*) + INTEGER, INTENT(OUT) :: hdrbufsize + INTEGER, INTENT(INOUT) :: itypesize +!Local + INTEGER i +! + hdrbufsize = hdrbuf(1) + IF ( hdrbuf(2) .NE. int_noop ) THEN + CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne int_noop") + ENDIF + i = 3 + RETURN +END SUBROUTINE int_get_noop_header + + +! first int is length of string to follow then string encodes as ints +SUBROUTINE int_pack_string ( str, buf, n ) + IMPLICIT NONE +! +!
+! This routine is used to store a string as a sequence of integers.  
+! The first integer is the string length.  
+!
+! + CHARACTER*(*), INTENT(IN) :: str + INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints stored in buf + INTEGER, INTENT(OUT), DIMENSION(*) :: buf +!Local + INTEGER i +! + n = 1 + buf(n) = LEN(TRIM(str)) + n = n+1 + DO i = 1, LEN(TRIM(str)) + buf(n) = ichar(str(i:i)) + n = n+1 + ENDDO + n = n - 1 +END SUBROUTINE int_pack_string + +SUBROUTINE int_unpack_string ( str, buf, n ) + IMPLICIT NONE +! +!
+! This routine is used to extract a string from a sequence of integers.  
+! The first integer is the string length.  
+!
+! + CHARACTER*(*), INTENT(OUT) :: str + INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints copied from buf + INTEGER, INTENT(IN), DIMENSION(*) :: buf +!Local + INTEGER i + INTEGER strlen + + strlen = buf(1) + str = "" + DO i = 1, strlen + str(i:i) = char(buf(i+1)) + ENDDO + n = strlen + 1 +END SUBROUTINE int_unpack_string + +END MODULE module_internal_header_util + diff --git a/wrfv2_fire/frame/module_io.F b/wrfv2_fire/frame/module_io.F new file mode 100644 index 00000000..5e16d0fd --- /dev/null +++ b/wrfv2_fire/frame/module_io.F @@ -0,0 +1,4174 @@ +!WRF:DRIVER_LAYER:IO +! +#define DEBUG_LVL 500 + +MODULE module_io +! +!
+! WRF-specific package-independent interface to package-dependent WRF-specific
+! I/O packages.
+!
+! These routines have the same names as those specified in the WRF I/O API 
+! except that:
+! - Routines defined in this file and called by users of this module have 
+!   the "wrf_" prefix.  
+! - Routines defined in the I/O packages and called from routines in this 
+!   file have the "ext_" prefix.  
+! - Routines called from routines in this file to initiate communication 
+!   with I/O quilt servers have the "wrf_quilt_" prefix.  
+!
+! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest 
+! version of the WRF I/O API.  This document includes detailed descriptions 
+! of subroutines and their arguments that are not duplicated in this file.  
+!
+! We wish to be able to link to different packages depending on whether
+! the I/O is restart, initial, history, or boundary.  
+!
+! + + USE module_configure + + LOGICAL :: is_inited = .FALSE. + INTEGER, PARAMETER, PRIVATE :: MAX_WRF_IO_HANDLE = 1000 + INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE), how_opened(MAX_WRF_IO_HANDLE) + LOGICAL :: for_output(MAX_WRF_IO_HANDLE), first_operation(MAX_WRF_IO_HANDLE) + INTEGER :: filtno = 0 + LOGICAL, PRIVATE :: bdy_dist_flag = .TRUE. ! false is old style undecomposed boundary data structs, + ! true is new style decomposed boundary data structs + ! are_bdys_distributed, bdys_are_distributed and + ! bdys_not_distributed routines access this flag + +! +!
+!
+! include the file generated from md_calls.m4 using the m4 preprocessor
+! note that this file also includes the CONTAINS declaration for the module
+!
+!
+! +#include "md_calls.inc" + +!--- ioinit + +SUBROUTINE wrf_ioinit( Status ) +! +!
+! Initialize the WRF I/O system.
+!
+! + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: Status +!Local + CHARACTER(len=80) :: SysDepInfo + INTEGER :: ierr(10), minerr, maxerr +! + Status = 0 + ierr = 0 + SysDepInfo = " " + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioinit' ) + CALL init_io_handles ! defined below +#ifdef NETCDF + CALL ext_ncd_ioinit( SysDepInfo, ierr(1) ) +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr(2) ) +#endif +#ifdef PHDF5 + CALL ext_phdf5_ioinit( SysDepInfo, ierr(3) ) +#endif +#ifdef PNETCDF + CALL ext_pnc_ioinit( SysDepInfo, ierr(3) ) +#endif +#ifdef MCELIO + CALL ext_mcel_ioinit( SysDepInfo, ierr(4) ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr(5) ) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr(6) ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr(7) ) +#endif +#ifdef ESMFIO + CALL ext_esmf_ioinit( SysDepInfo, ierr(8) ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr(9) ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr(10) ) +#endif + minerr = MINVAL(ierr) + maxerr = MAXVAL(ierr) + IF ( minerr < 0 ) THEN + Status = minerr + ELSE IF ( maxerr > 0 ) THEN + Status = maxerr + ELSE + Status = 0 + ENDIF +END SUBROUTINE wrf_ioinit + +!--- ioexit + +SUBROUTINE wrf_ioexit( Status ) +! +!
+! Shut down the WRF I/O system.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: Status +!Local + LOGICAL, EXTERNAL :: use_output_servers + INTEGER :: ierr(11), minerr, maxerr +! + Status = 0 + ierr = 0 + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioexit' ) +#ifdef NETCDF + CALL ext_ncd_ioexit( ierr(1) ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( ierr(2) ) +#endif +#ifdef PHDF5 + CALL ext_phdf5_ioexit(ierr(3) ) +#endif +#ifdef PNETCDF + CALL ext_pnc_ioexit(ierr(3) ) +#endif +#ifdef MCELIO + CALL ext_mcel_ioexit( ierr(4) ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( ierr(5) ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( ierr(6) ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( ierr(7) ) +#endif +#ifdef ESMFIO + CALL ext_esmf_ioexit( ierr(8) ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( ierr(9) ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( ierr(10) ) +#endif + + IF ( use_output_servers() ) CALL wrf_quilt_ioexit( ierr(11) ) + minerr = MINVAL(ierr) + maxerr = MAXVAL(ierr) + IF ( minerr < 0 ) THEN + Status = minerr + ELSE IF ( maxerr > 0 ) THEN + Status = maxerr + ELSE + Status = 0 + ENDIF +END SUBROUTINE wrf_ioexit + +!--- open_for_write_begin + +SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +!
+! Begin data definition ("training") phase for writing to WRF dataset 
+! FileName.  
+!
+! + USE module_state_description + IMPLICIT NONE +#include "wrf_io_flags.h" + CHARACTER*(*) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER*(*), INTENT(INOUT):: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + !Local + CHARACTER*128 :: DataSet + INTEGER :: io_form + INTEGER :: Hndl + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + CHARACTER*128 :: LocFilename ! for appending the process ID if necessary + INTEGER :: myproc + CHARACTER*128 :: mess + CHARACTER*1028 :: tstr + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_begin' ) + + CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) + + IF ( DataSet .eq. 'RESTART' ) THEN + CALL nl_get_io_form_restart( 1, io_form ) + ELSE IF ( DataSet .eq. 'INPUT' ) THEN + CALL nl_get_io_form_input( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN + CALL nl_get_io_form_auxinput1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN + CALL nl_get_io_form_auxinput2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN + CALL nl_get_io_form_auxinput3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN + CALL nl_get_io_form_auxinput4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN + CALL nl_get_io_form_auxinput5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN + CALL nl_get_io_form_auxinput6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN + CALL nl_get_io_form_auxinput7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN + CALL nl_get_io_form_auxinput8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN + CALL nl_get_io_form_gfdda( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN + CALL nl_get_io_form_auxinput11( 1, io_form ) + + ELSE IF ( DataSet .eq. 'HISTORY' ) THEN + CALL nl_get_io_form_history( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN + CALL nl_get_io_form_auxhist1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN + CALL nl_get_io_form_auxhist2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN + CALL nl_get_io_form_auxhist3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN + CALL nl_get_io_form_auxhist4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN + CALL nl_get_io_form_auxhist5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN + CALL nl_get_io_form_auxhist6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN + CALL nl_get_io_form_auxhist7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN + CALL nl_get_io_form_auxhist8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN + CALL nl_get_io_form_auxhist9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN + CALL nl_get_io_form_auxhist10( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN + CALL nl_get_io_form_auxhist11( 1, io_form ) + + ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN + CALL nl_get_io_form_boundary( 1, io_form ) + ELSE ! default if nothing is set in SysDepInfo; use history + CALL nl_get_io_form_history( 1, io_form ) + ENDIF + + Status = 0 + Hndl = -1 + IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef PHDF5 + CASE (IO_PHDF5 ) + CALL ext_phdf5_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, & + Hndl, Status) +#endif +#ifdef PNETCDF + CASE (IO_PNETCDF ) + CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, & + Hndl, Status) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_yyy_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_gr1_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_gr2_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + IF ( wrf_dm_on_monitor() ) THEN + tstr = TRIM(SysDepInfo) // ',' // 'LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK' + CALL ext_mcel_open_for_write_begin ( FileName , Comm_compute, Comm_io, tstr, & + Hndl , Status ) + ENDIF + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_int_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + ENDIF +#endif + CASE DEFAULT + IF ( io_form .NE. 0 ) THEN + WRITE(mess,*)'Tried to open ',FileName,' writing: no valid io_form (',io_form,')' + CALL wrf_debug(1, mess) + Status = WRF_FILE_NOT_OPENED + ENDIF + END SELECT + ELSE IF ( use_output_servers() ) THEN + IF ( io_form .GT. 0 ) THEN + CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , io_form, Status ) + ENDIF + ELSE + Status = 0 + ENDIF + CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle ) +END SUBROUTINE wrf_open_for_write_begin + +!--- open_for_write_commit + +SUBROUTINE wrf_open_for_write_commit( DataHandle , Status ) +! +!
+! This routine switches an internal flag to enable output for the data set 
+! referenced by DataHandle. The call to wrf_open_for_write_commit() must be 
+! paired with a call to wrf_open_for_write_begin().
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CHARACTER (128) :: DataSet + INTEGER :: io_form + INTEGER :: Hndl + LOGICAL :: for_out + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +#include "wrf_io_flags.h" + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_commit' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + CALL set_first_operation( DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + CALL ext_ncd_open_for_write_commit ( Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + IF ( wrf_dm_on_monitor() ) THEN + CALL ext_mcel_open_for_write_commit ( Hndl , Status ) + ENDIF + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_open_for_write_commit ( Hndl , Status ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_open_for_write_commit ( Hndl , Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_open_for_write_commit ( Hndl , Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_open_for_write_commit ( Hndl , Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + CALL ext_yyy_open_for_write_commit ( Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_open_for_write_commit ( Hndl , Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + CALL ext_gr1_open_for_write_commit ( Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + CALL ext_gr2_open_for_write_commit ( Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_commit ( Hndl , Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_open_for_write_commit ( Hndl , Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = 0 + ENDIF + RETURN +END SUBROUTINE wrf_open_for_write_commit + +!--- open_for_read_begin + +SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +!
+! Begin data definition ("training") phase for reading from WRF dataset 
+! FileName.  
+!
+! + USE module_state_description + IMPLICIT NONE +#include "wrf_io_flags.h" + CHARACTER*(*) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER*(*) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CHARACTER*128 :: DataSet + INTEGER :: io_form + INTEGER :: Hndl + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + + CHARACTER*128 :: LocFilename ! for appending the process ID if necessary + INTEGER myproc + CHARACTER*128 :: mess, fhand + CHARACTER*1028 :: tstr + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' ) + + CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) + IF ( DataSet .eq. 'RESTART' ) THEN + CALL nl_get_io_form_restart( 1, io_form ) + ELSE IF ( DataSet .eq. 'INPUT' ) THEN + CALL nl_get_io_form_input( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN + CALL nl_get_io_form_auxinput1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN + CALL nl_get_io_form_auxinput2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN + CALL nl_get_io_form_auxinput3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN + CALL nl_get_io_form_auxinput4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN + CALL nl_get_io_form_auxinput5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN + CALL nl_get_io_form_auxinput6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN + CALL nl_get_io_form_auxinput7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN + CALL nl_get_io_form_auxinput8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN + CALL nl_get_io_form_gfdda( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN + CALL nl_get_io_form_auxinput11( 1, io_form ) + + ELSE IF ( DataSet .eq. 'HISTORY' ) THEN + CALL nl_get_io_form_history( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN + CALL nl_get_io_form_auxhist1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN + CALL nl_get_io_form_auxhist2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN + CALL nl_get_io_form_auxhist3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN + CALL nl_get_io_form_auxhist4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN + CALL nl_get_io_form_auxhist5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN + CALL nl_get_io_form_auxhist6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN + CALL nl_get_io_form_auxhist7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN + CALL nl_get_io_form_auxhist8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN + CALL nl_get_io_form_auxhist9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN + CALL nl_get_io_form_auxhist10( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN + CALL nl_get_io_form_auxhist11( 1, io_form ) + + ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN + CALL nl_get_io_form_boundary( 1, io_form ) + ELSE ! default if nothing is set in SysDepInfo; use history + CALL nl_get_io_form_history( 1, io_form ) + ENDIF + + Status = 0 + Hndl = -1 + IF ( .NOT. use_output_servers() ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_ncd_open_for_read_begin ( LocFilename , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + IF ( wrf_dm_on_monitor() ) THEN + + WRITE(fhand,'(a,i0)')"filter_",filtno + filtno = filtno + 1 +tstr = TRIM(SysDepInfo) // ',' // 'READ_MODE=UPDATE,LAT_R=XLAT,LON_R=XLONG,LANDMASK_I=LU_MASK,FILTER_HANDLE=' // TRIM(fhand) + CALL ext_mcel_open_for_read_begin ( FileName , Comm_compute, Comm_io, tstr, & + Hndl , Status ) + ENDIF + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_gr1_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_gr2_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) +#endif + CASE DEFAULT + IF ( io_form .NE. 0 ) THEN + WRITE(mess,*)'Tried to open ',FileName,' reading: no valid io_form (',io_form,')' + CALL wrf_message(mess) + ENDIF + Status = WRF_FILE_NOT_OPENED + END SELECT + ELSE + Status = 0 + ENDIF + CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle ) +END SUBROUTINE wrf_open_for_read_begin + +!--- open_for_read_commit + +SUBROUTINE wrf_open_for_read_commit( DataHandle , Status ) +! +!
+! End "training" phase for WRF dataset FileName.  The call to 
+! wrf_open_for_read_commit() must be paired with a call to 
+! wrf_open_for_read_begin().
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CHARACTER (128) :: DataSet + INTEGER :: io_form + INTEGER :: Hndl + LOGICAL :: for_out + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +#include "wrf_io_flags.h" + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_commit' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + CALL set_first_operation( DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + CALL ext_ncd_open_for_read_commit ( Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + IF ( wrf_dm_on_monitor() ) THEN + CALL ext_mcel_open_for_read_commit ( Hndl , Status ) + ENDIF + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_read_commit ( Hndl , Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_FILE_NOT_OPENED + ENDIF + RETURN +END SUBROUTINE wrf_open_for_read_commit + +!--- open_for_read + +SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +!
+! Opens a WRF dataset for reading.  
+!
+! + USE module_state_description + IMPLICIT NONE + CHARACTER*(*) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER*(*) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CHARACTER (128) :: DataSet, LocFileName + INTEGER :: io_form, myproc + INTEGER :: Hndl + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' ) + + CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) + IF ( DataSet .eq. 'RESTART' ) THEN + CALL nl_get_io_form_restart( 1, io_form ) + ELSE IF ( DataSet .eq. 'INPUT' ) THEN + CALL nl_get_io_form_input( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN + CALL nl_get_io_form_auxinput1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN + CALL nl_get_io_form_auxinput2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN + CALL nl_get_io_form_auxinput3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN + CALL nl_get_io_form_auxinput4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN + CALL nl_get_io_form_auxinput5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN + CALL nl_get_io_form_auxinput6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN + CALL nl_get_io_form_auxinput7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN + CALL nl_get_io_form_auxinput8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN + CALL nl_get_io_form_gfdda( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN + CALL nl_get_io_form_auxinput11( 1, io_form ) + + CALL nl_get_io_form_auxinput5( 1, io_form ) + ELSE IF ( DataSet .eq. 'HISTORY' ) THEN + CALL nl_get_io_form_history( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN + CALL nl_get_io_form_auxhist1( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN + CALL nl_get_io_form_auxhist2( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN + CALL nl_get_io_form_auxhist3( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN + CALL nl_get_io_form_auxhist4( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN + CALL nl_get_io_form_auxhist5( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN + CALL nl_get_io_form_auxhist6( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN + CALL nl_get_io_form_auxhist7( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN + CALL nl_get_io_form_auxhist8( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN + CALL nl_get_io_form_auxhist9( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN + CALL nl_get_io_form_auxhist10( 1, io_form ) + ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN + CALL nl_get_io_form_auxhist11( 1, io_form ) + + ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN + CALL nl_get_io_form_boundary( 1, io_form ) + ELSE ! default if nothing is set in SysDepInfo; use history + CALL nl_get_io_form_history( 1, io_form ) + ENDIF + + Hndl = -1 + Status = 0 + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + + CALL ext_ncd_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + + CALL ext_yyy_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + + CALL ext_gr1_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + + CALL ext_gr2_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN + IF ( multi_files(io_form) ) THEN + CALL wrf_get_myproc ( myproc ) + CALL append_to_filename ( LocFilename , FileName , myproc, 4 ) + ELSE + LocFilename = FileName + ENDIF + CALL ext_int_open_for_read ( LocFileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) + ENDIF + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE ) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + CALL add_new_handle( Hndl, io_form, .FALSE., DataHandle ) + RETURN +END SUBROUTINE wrf_open_for_read + +!--- inquire_opened + +SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status ) +! +!
+! Inquire if the dataset referenced by DataHandle is open.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + LOGICAL :: for_out + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + INTEGER io_form , Hndl + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_opened' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_opened ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_opened ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_opened ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_inquire_opened ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_opened ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_opened ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF (wrf_dm_on_monitor()) CALL ext_int_inquire_opened ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif + CASE DEFAULT + FileStatus = WRF_FILE_NOT_OPENED + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_inquire_opened ( Hndl, FileName , FileStatus, Status ) + ENDIF + ELSE + FileStatus = WRF_FILE_NOT_OPENED + Status = 0 + ENDIF + RETURN +END SUBROUTINE wrf_inquire_opened + +!--- inquire_filename + + +SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status ) +! +!
+! Returns the Filename and FileStatus associated with DataHandle.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL :: for_out + + INTEGER io_form , Hndl + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_filename' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_filename ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_filename ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_inquire_filename ( Hndl, FileName , FileStatus, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_filename ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_filename ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF (wrf_dm_on_monitor()) CALL ext_int_inquire_filename ( Hndl, FileName , FileStatus, Status ) + CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_inquire_filename ( Hndl, FileName , FileStatus, Status ) + ENDIF + ELSE + FileName = "" + Status = 0 + ENDIF + RETURN +END SUBROUTINE wrf_inquire_filename + +!--- sync + +SUBROUTINE wrf_iosync ( DataHandle, Status ) +! +!
+! Synchronize the disk copy of a dataset with memory buffers.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL :: for_out + + INTEGER io_form , Hndl + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_iosync' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_iosync( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_iosync( Hndl, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_iosync( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_iosync( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_iosync( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_iosync( Hndl, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_iosync( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_iosync( Hndl, Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_iosync + +!--- close + +SUBROUTINE wrf_ioclose ( DataHandle, Status ) +! +!
+! Close the dataset referenced by DataHandle.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + INTEGER io_form , Hndl + LOGICAL :: for_out + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioclose' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_ioclose( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_ioclose( Hndl, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_ioclose( Hndl, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_ioclose( Hndl, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_ioclose( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_ioclose( Hndl, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_ioclose( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_ioclose( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + CALL ext_mcel_ioclose( Hndl, Status ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_ioclose( Hndl, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_ioclose( Hndl, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_ioclose( Hndl, Status ) + ELSE + Status = 0 + ENDIF + CALL free_handle( DataHandle ) + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_ioclose + +!--- get_next_time (not defined for IntIO ) + +SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status ) +! +!
+! Returns the next time stamp.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + INTEGER io_form , Hndl, len_of_str + LOGICAL :: for_out + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_time' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_next_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_get_next_time( Hndl, DateStr, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_get_next_time( Hndl, DateStr, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_get_next_time( Hndl, DateStr, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_next_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_get_next_time( Hndl, DateStr, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_next_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_next_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_get_next_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_get_next_time( Hndl, DateStr, Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_get_next_time + +!--- get_previous_time (not defined for IntIO ) + +SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status ) +! +!
+! Returns the previous time stamp.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + INTEGER io_form , Hndl, len_of_str + LOGICAL :: for_out + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_previous_time' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_previous_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_get_previous_time( Hndl, DateStr, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_get_previous_time( Hndl, DateStr, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_previous_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_get_previous_time( Hndl, DateStr, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_previous_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_previous_time( Hndl, DateStr, Status ) + IF ( .NOT. multi_files(io_form) ) THEN + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef INTIO +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_get_previous_time( Hndl, DateStr, Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_get_previous_time + +!--- set_time + +SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status ) +! +!
+! Sets the time stamp.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + INTEGER io_form , Hndl + LOGICAL :: for_out + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_set_time' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_set_time( Hndl, DateStr, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_set_time( Hndl, DateStr, Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_set_time( Hndl, DateStr, Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_set_time( Hndl, DateStr, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_set_time( Hndl, DateStr, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_set_time( Hndl, DateStr, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_set_time( Hndl, DateStr, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_set_time( Hndl, DateStr, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_set_time( Hndl, DateStr, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_set_time( Hndl, DateStr, Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_set_time + +!--- get_next_var (not defined for IntIO) + +SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status ) +! +!
+! On reading, this routine returns the name of the next variable in the 
+! current time frame.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: VarName + INTEGER , INTENT(OUT) :: Status +#include "wrf_status_codes.h" + + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + INTEGER io_form , Hndl + LOGICAL :: for_out + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_var' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_get_next_var( Hndl, VarName, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_get_next_var( Hndl, VarName, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_get_next_var( Hndl, VarName, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_get_next_var( Hndl, VarName, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_get_next_var( Hndl, VarName, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_get_next_var( Hndl, VarName, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_get_next_var( Hndl, VarName, Status ) + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_get_next_var( Hndl, VarName, Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_get_next_var + + +! wrf_get_var_info (not implemented for IntIO) + +SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , Status ) +! +!
+! This routine applies only to a dataset that is open for read.  It returns 
+! information about a variable.  
+!
+! + USE module_state_description + IMPLICIT NONE + INTEGER ,INTENT(IN) :: DataHandle + CHARACTER*(*) ,INTENT(IN) :: VarName + INTEGER ,INTENT(OUT) :: NDim + CHARACTER*(*) ,INTENT(OUT) :: MemoryOrder + CHARACTER*(*) ,INTENT(OUT) :: Stagger + INTEGER ,dimension(*) ,INTENT(OUT) :: DomainStart, DomainEnd + INTEGER ,INTENT(OUT) :: Status +#include "wrf_status_codes.h" + INTEGER io_form , Hndl + LOGICAL :: for_out + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_var_info' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF (( multi_files(io_form) .OR. wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers()) ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5) + CALL ext_phdf5_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF) + CALL ext_pnc_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + CALL wrf_quilt_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) + ELSE + Status = 0 + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN + +END SUBROUTINE wrf_get_var_info + + + +!--------------------------------------------------------------------------------- + + +SUBROUTINE init_io_handles() +! +!
+! Initialize all I/O handles.  
+!
+! + IMPLICIT NONE + INTEGER i + IF ( .NOT. is_inited ) THEN + DO i = 1, MAX_WRF_IO_HANDLE + wrf_io_handles(i) = -999319 + ENDDO + is_inited = .TRUE. + ENDIF + RETURN +END SUBROUTINE init_io_handles + +SUBROUTINE add_new_handle( Hndl, Hopened, for_out, DataHandle ) +! +!
+! Stash the package-specific I/O handle (Hndl) and return a WRF I/O handle 
+! (DataHandle).  
+! File format ID is passed in via Hopened.  
+! for_out will be .TRUE. if this routine was called from an 
+! open-for-read/write-begin operation and .FALSE. otherwise.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: Hndl + INTEGER, INTENT(IN) :: Hopened + LOGICAL, INTENT(IN) :: for_out + INTEGER, INTENT(OUT) :: DataHandle + INTEGER i + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: multi_files + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'add_new_handle: not initialized' ) + ENDIF + IF ( multi_files( Hopened ) ) THEN + SELECT CASE ( use_package( Hopened ) ) + CASE ( IO_PHDF5 ) + CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PHDF5' ) + CASE ( IO_PNETCDF ) + CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PNETCDF' ) +#ifdef MCELIO + CASE ( IO_MCEL ) + CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for MCEL' ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for ESMF' ) +#endif + END SELECT + ENDIF + DataHandle = -1 + DO i = 1, MAX_WRF_IO_HANDLE + IF ( wrf_io_handles(i) .EQ. -999319 ) THEN + DataHandle = i + wrf_io_handles(i) = Hndl + how_opened(i) = Hopened + for_output(DataHandle) = for_out + first_operation(DataHandle) = .TRUE. + EXIT + ENDIF + ENDDO + IF ( DataHandle .EQ. -1 ) THEN + CALL wrf_error_fatal( 'add_new_handle: no handles left' ) + ENDIF + RETURN +END SUBROUTINE add_new_handle + +SUBROUTINE get_handle ( Hndl, Hopened, for_out, DataHandle ) +! +!
+! Return the package-specific handle (Hndl) from a WRF handle 
+! (DataHandle).  
+! Return file format ID via Hopened.  
+! Also, for_out will be set to .TRUE. if the file was opened 
+! with an open-for-read/write-begin operation and .FALSE. 
+! otherwise.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(OUT) :: Hndl + INTEGER, INTENT(OUT) :: Hopened + LOGICAL, INTENT(OUT) :: for_out + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*128 mess + INTEGER i + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' ) + ENDIF + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN + Hndl = wrf_io_handles(DataHandle) + Hopened = how_opened(DataHandle) + for_out = for_output(DataHandle) + ELSE + Hndl = -1 + ENDIF + RETURN +END SUBROUTINE get_handle + +SUBROUTINE set_first_operation( DataHandle ) +! +!
+! Sets internal flag to indicate that the first read or write has not yet 
+! happened for the dataset referenced by DataHandle.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' ) + ENDIF + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN + first_operation(DataHandle) = .TRUE. + ENDIF + RETURN +END SUBROUTINE set_first_operation + +SUBROUTINE reset_first_operation( DataHandle ) +! +!
+! Resets internal flag to indicate that the first read or write has already 
+! happened for the dataset referenced by DataHandle.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' ) + ENDIF + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN + first_operation(DataHandle) = .FALSE. + ENDIF + RETURN +END SUBROUTINE reset_first_operation + +LOGICAL FUNCTION is_first_operation( DataHandle ) +! +!
+! Returns .TRUE. the first read or write has not yet happened for the dataset 
+! referenced by DataHandle.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' ) + ENDIF + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN + is_first_operation = first_operation(DataHandle) + ENDIF + RETURN +END FUNCTION is_first_operation + +SUBROUTINE free_handle ( DataHandle ) +! +!
+! Trash a handle and return to "unused" pool.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + INTEGER i + IF ( .NOT. is_inited ) THEN + CALL wrf_error_fatal( 'free_handle: not initialized' ) + ENDIF + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN + wrf_io_handles(DataHandle) = -999319 + ENDIF + RETURN +END SUBROUTINE free_handle + +!-------------------------------------------------------------- + +SUBROUTINE init_module_io +! +!
+! Initialize this module.  Must be called before any other operations are 
+! attempted.  
+!
+! + CALL init_io_handles +END SUBROUTINE init_module_io + +SUBROUTINE are_bdys_distributed( res ) + IMPLICIT NONE + LOGICAL, INTENT(OUT) :: res + res = bdy_dist_flag +END SUBROUTINE are_bdys_distributed + +SUBROUTINE bdys_not_distributed + IMPLICIT NONE + bdy_dist_flag = .FALSE. +END SUBROUTINE bdys_not_distributed + +SUBROUTINE bdys_are_distributed + IMPLICIT NONE + bdy_dist_flag = .TRUE. +END SUBROUTINE bdys_are_distributed + +END MODULE module_io + + +! +!
+! Remaining routines in this file are defined outside of the module to 
+! defeat arg/param type checking.  
+!
+! +SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! Read the variable named VarName from the dataset pointed to by DataHandle.
+! This routine is a wrapper that ensures uniform treatment of logicals across 
+! platforms by reading as integer and then converting to logical.  
+!
+! + USE module_state_description + USE module_configure + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + LOGICAL , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 +#include "wrf_status_codes.h" +#include "wrf_io_flags.h" + INTEGER, ALLOCATABLE :: ICAST(:) + LOGICAL perturb_input + IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1))) + + CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) = ICAST == 1 + DEALLOCATE(ICAST) + ELSE + CALL wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + CALL nl_get_perturb_input( 1, perturb_input ) + IF ( perturb_input .AND. FieldType .EQ. WRF_FLOAT .AND. TRIM(MemoryOrder) .EQ. 'XZY' ) THEN + CALL perturb_real ( Field, DomainStart, DomainEnd, & + MemoryStart, MemoryEnd, & + PatchStart, PatchEnd ) + ENDIF + ENDIF +END SUBROUTINE wrf_read_field + +SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! Read the variable named VarName from the dataset pointed to by DataHandle.
+! Calls ext_pkg_read_field() via call_pkg_and_dist().  
+!
+! + USE module_state_description + USE module_configure + USE module_io + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 +#include "wrf_status_codes.h" + INTEGER io_form , Hndl + LOGICAL :: for_out + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers +#ifdef NETCDF + EXTERNAL ext_ncd_read_field +#endif +#ifdef MCELIO + EXTERNAL ext_mcel_read_field +#endif +#ifdef ESMFIO + EXTERNAL ext_esmf_read_field +#endif +#ifdef INTIO + EXTERNAL ext_int_read_field +#endif +#ifdef XXX + EXTERNAL ext_xxx_read_field +#endif +#ifdef YYY + EXTERNAL ext_yyy_read_field +#endif +#ifdef GRIB1 + EXTERNAL ext_gr1_read_field +#endif +#ifdef GRIB2 + EXTERNAL ext_gr2_read_field +#endif + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_read_field' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + CALL reset_first_operation( DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( .NOT. io_form .GT. 0 ) THEN + Status = 0 + ELSE IF ( .NOT. use_input_servers() ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + + CALL call_pkg_and_dist ( ext_ncd_read_field, multi_files(io_form), .false. , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5) + CALL ext_phdf5_read_field ( & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF) + CALL ext_pnc_read_field ( & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + CALL call_pkg_and_dist ( ext_mcel_read_field, multi_files(io_form), .true. , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_read_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL call_pkg_and_dist ( ext_xxx_read_field, multi_files(io_form), .false., & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL call_pkg_and_dist ( ext_yyy_read_field, multi_files(io_form), .false., & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL call_pkg_and_dist ( ext_int_read_field, multi_files(io_form), .false., & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL call_pkg_and_dist ( ext_gr1_read_field, multi_files(io_form), .false., & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL call_pkg_and_dist ( ext_gr2_read_field, multi_files(io_form), .false., & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE + CALL wrf_error_fatal('module_io.F: wrf_read_field: input_servers not implemented yet') + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_read_field1 + +SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! Write the variable named VarName to the dataset pointed to by DataHandle.
+! This routine is a wrapper that ensures uniform treatment of logicals across 
+! platforms by converting to integer before writing.  
+!
+! + USE module_state_description + USE module_configure + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + LOGICAL , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 +#include "wrf_status_codes.h" +#include "wrf_io_flags.h" + INTEGER, ALLOCATABLE :: ICAST(:) + IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1))) + ICAST = 0 + WHERE ( Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) ) + ICAST = 1 + END WHERE + CALL wrf_write_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE(ICAST) + ELSE + CALL wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + ENDIF +END SUBROUTINE wrf_write_field + +SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & + Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! Write the variable named VarName to the dataset pointed to by DataHandle.
+! Calls ext_pkg_write_field() via collect_fld_and_call_pkg().  
+!
+! + + USE module_state_description + USE module_configure + USE module_io + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 +#include "wrf_status_codes.h" + INTEGER, DIMENSION(3) :: starts, ends + INTEGER io_form , Hndl + CHARACTER*3 MemOrd + LOGICAL :: for_out, okay_to_call + INTEGER, EXTERNAL :: use_package + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +#ifdef NETCDF + EXTERNAL ext_ncd_write_field +#endif +#ifdef MCELIO + EXTERNAL ext_mcel_write_field +#endif +#ifdef ESMFIO + EXTERNAL ext_esmf_write_field +#endif +#ifdef INTIO + EXTERNAL ext_int_write_field +#endif +#ifdef XXX + EXTERNAL ext_xxx_write_field +#endif +#ifdef YYY + EXTERNAL ext_yyy_write_field +#endif +#ifdef GRIB1 + EXTERNAL ext_gr1_write_field +#endif +#ifdef GRIB2 + EXTERNAL ext_gr2_write_field +#endif + + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_write_field' ) + + Status = 0 + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + CALL reset_first_operation ( DataHandle ) + IF ( Hndl .GT. -1 ) THEN + IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN + SELECT CASE ( use_package( io_form ) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL collect_fld_and_call_pkg ( ext_ncd_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef MCELIO + CASE ( IO_MCEL ) + CALL collect_fld_and_call_pkg ( ext_mcel_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef ESMFIO + CASE ( IO_ESMF ) + CALL ext_esmf_write_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_write_field( & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL lower_case( MemoryOrder, MemOrd ) + okay_to_call = .TRUE. + IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE. + IF ( okay_to_call ) THEN + starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3) + ELSE + starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1 + ENDIF + + CALL ext_pnc_write_field( & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + starts , ends , & + Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL collect_fld_and_call_pkg ( ext_yyy_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL collect_fld_and_call_pkg ( ext_gr1_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL collect_fld_and_call_pkg ( ext_gr2_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL collect_fld_and_call_pkg ( ext_int_write_field, multi_files(io_form), & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ELSE IF ( use_output_servers() ) THEN + IF ( io_form .GT. 0 ) THEN + CALL wrf_quilt_write_field ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + ENDIF + ENDIF + ELSE + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + ENDIF + RETURN +END SUBROUTINE wrf_write_field1 + +SUBROUTINE get_value_from_pairs ( varname , str , retval ) +! +!
+! parse comma separated list of VARIABLE=VALUE strings and return the
+! value for the matching variable if such exists, otherwise return
+! the empty string
+!
+! + IMPLICIT NONE + CHARACTER*(*) :: varname + CHARACTER*(*) :: str + CHARACTER*(*) :: retval + + CHARACTER (128) varstr, tstr + INTEGER i,j,n,varstrn + LOGICAL nobreak, nobreakouter + + varstr = TRIM(varname)//"=" + varstrn = len(TRIM(varstr)) + n = len(str) + retval = "" + i = 1 + nobreakouter = .TRUE. + DO WHILE ( nobreakouter ) + j = 1 + nobreak = .TRUE. + tstr = "" +! Potential for out of bounds array ref on str(i:i) for i > n; reported by jedwards +! DO WHILE ( nobreak ) +! IF ( str(i:i) .NE. ',' .AND. i .LE. n ) THEN +! tstr(j:j) = str(i:i) +! ELSE +! nobreak = .FALSE. +! ENDIF +! j = j + 1 +! i = i + 1 +! ENDDO +! fix 20021112, JM + DO WHILE ( nobreak ) + nobreak = .FALSE. + IF ( i .LE. n ) THEN + IF (str(i:i) .NE. ',' ) THEN + tstr(j:j) = str(i:i) + nobreak = .TRUE. + ENDIF + ENDIF + j = j + 1 + i = i + 1 + ENDDO + IF ( i .GT. n ) nobreakouter = .FALSE. + IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN + retval(1:) = TRIM(tstr(varstrn+1:)) + nobreakouter = .FALSE. + ENDIF + ENDDO + RETURN +END SUBROUTINE get_value_from_pairs + +LOGICAL FUNCTION multi_files ( io_form ) +! +!
+! Returns .TRUE. iff io_form is a multi-file format.  A multi-file format 
+! results in one file for each compute process and can be used with any 
+! I/O package.  A multi-file dataset can only be read by the same number 
+! of tasks that were used to write it.  This feature can be useful for 
+! speeding up restarts on machines that support efficient parallel I/O.  
+! Multi-file formats cannot be used with I/O quilt servers.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: io_form +#ifdef DM_PARALLEL + multi_files = io_form > 99 +#else + multi_files = .FALSE. +#endif +END FUNCTION multi_files + +INTEGER FUNCTION use_package ( io_form ) +! +!
+! Returns the ID of the external I/O package referenced by io_form.  
+!
+! + IMPLICIT NONE + INTEGER, INTENT(IN) :: io_form + use_package = MOD( io_form, 100 ) +END FUNCTION use_package + + +SUBROUTINE collect_fld_and_call_pkg ( fcn, donotcollect_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! This routine handle cases where collection can be skipped and deals with 
+! different data types for Field.  
+!
+! + IMPLICIT NONE +#include "wrf_io_flags.h" + EXTERNAL fcn + LOGICAL, INTENT(IN) :: donotcollect_arg + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 + LOGICAL donotcollect + INTEGER ndims, nproc + + CALL dim_from_memorder( MemoryOrder , ndims) + CALL wrf_get_nproc( nproc ) + donotcollect = donotcollect_arg .OR. (nproc .EQ. 1) + + IF ( donotcollect ) THEN + + CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + CALL collect_double_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL collect_real_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL collect_int_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + + CALL collect_logical_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ENDIF + RETURN +END SUBROUTINE collect_fld_and_call_pkg + +SUBROUTINE collect_real_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! The sole purpose of this wrapper is to allocate a big real buffer and 
+! pass it down to collect_generic_and_call_pkg() to do the actual work.  
+!
+! + USE module_state_description + USE module_driver_constants + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + REAL , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + REAL, ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + +#ifdef DEREF_KLUDGE +# define FRSTELEM (1) +#else +# define FRSTELEM +#endif + + CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN + +END SUBROUTINE collect_real_and_call_pkg + +SUBROUTINE collect_int_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! The sole purpose of this wrapper is to allocate a big integer buffer and 
+! pass it down to collect_generic_and_call_pkg() to do the actual work.  
+!
+! + USE module_state_description + USE module_driver_constants + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + INTEGER, ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN + +END SUBROUTINE collect_int_and_call_pkg + +SUBROUTINE collect_double_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! The sole purpose of this wrapper is to allocate a big double precision 
+! buffer and pass it down to collect_generic_and_call_pkg() to do the 
+! actual work.  
+!
+! + USE module_state_description + USE module_driver_constants + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + DOUBLE PRECISION , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + DOUBLE PRECISION, ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN + +END SUBROUTINE collect_double_and_call_pkg + +SUBROUTINE collect_logical_and_call_pkg ( fcn, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! The sole purpose of this wrapper is to allocate a big logical buffer 
+! and pass it down to collect_generic_and_call_pkg() to do the actual work.  
+!
+! + USE module_state_description + USE module_driver_constants + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + LOGICAL , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + LOGICAL, ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + CALL collect_generic_and_call_pkg ( fcn, globbuf FRSTELEM , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN + +END SUBROUTINE collect_logical_and_call_pkg + + +SUBROUTINE collect_generic_and_call_pkg ( fcn, globbuf, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The collect_*_and_call_pkg routines collect a distributed array onto one 
+! processor and then call an I/O function to write the result (or in the 
+! case of replicated data simply write monitor node's copy of the data)
+! This routine calls the distributed memory communication routines that 
+! collect the array and then calls I/O function fcn to write it to disk.  
+!
+! + USE module_state_description + USE module_driver_constants + IMPLICIT NONE +#include "wrf_io_flags.h" +#if defined( DM_PARALLEL ) && ! defined(STUBMPI) +include "mpif.h" +#endif + EXTERNAL fcn + REAL , DIMENSION(*) , INTENT(INOUT) :: globbuf + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + REAL , INTENT(IN) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 MemOrd + LOGICAL, EXTERNAL :: has_char + INTEGER ids, ide, jds, jde, kds, kde + INTEGER ims, ime, jms, jme, kms, kme + INTEGER ips, ipe, jps, jpe, kps, kpe + INTEGER, ALLOCATABLE :: counts(:), displs(:) + INTEGER nproc, communicator, mpi_bdyslice_type, ierr, my_displ + INTEGER my_count + INTEGER , dimension(3) :: dom_end_rev + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + INTEGER, EXTERNAL :: wrf_dm_monitor_rank + LOGICAL distributed_field + INTEGER i,j,k,idx,lx,idx2,lx2 + INTEGER collective_root + + CALL wrf_get_nproc( nproc ) + CALL wrf_get_dm_communicator ( communicator ) + + ALLOCATE( counts( nproc ) ) + ALLOCATE( displs( nproc ) ) + CALL lower_case( MemoryOrder, MemOrd ) + + collective_root = wrf_dm_monitor_rank() + + dom_end_rev(1) = DomainEnd(1) + dom_end_rev(2) = DomainEnd(2) + dom_end_rev(3) = DomainEnd(3) + + SELECT CASE (TRIM(MemOrd)) + CASE ( 'xzy' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'zxy' ) + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'xyz' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'xy' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + CASE ( 'yxz' ) + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'yx' ) + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + CASE DEFAULT + ! do nothing; the boundary orders and others either dont care or set themselves + END SELECT + + SELECT CASE (TRIM(MemOrd)) +#ifndef STUBMPI + CASE ( 'xzy','zxy','xyz','yxz','xy','yx' ) + + distributed_field = .TRUE. + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL wrf_patch_to_global_double ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL wrf_patch_to_global_real ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL wrf_patch_to_global_integer ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL wrf_patch_to_global_logical ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ENDIF + +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CASE ( 'xsz', 'xez' ) + distributed_field = .FALSE. + IF ( nproc .GT. 1 ) THEN + jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1 ! ns strip + kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1 ! levels + ids = DomainStart(3) ; ide = DomainEnd(3) ; ! bdy_width + dom_end_rev(1) = jde + dom_end_rev(2) = kde + dom_end_rev(3) = ide + distributed_field = .TRUE. + IF ( (MemOrd .eq. 'xsz' .AND. bdy_mask( P_XSB )) .OR. & + (MemOrd .eq. 'xez' .AND. bdy_mask( P_XEB )) ) THEN + my_displ = PatchStart(1)-1 + my_count = PatchEnd(1)-PatchStart(1)+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + do i = DomainStart(3),DomainEnd(3) ! bdy_width + do k = DomainStart(2),DomainEnd(2) ! levels + lx = MemoryEnd(1)-MemoryStart(1)+1 + lx2 = dom_end_rev(1)-DomainStart(1)+1 + idx = lx*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1)) + idx2 = lx2*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1)) + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + + enddo + enddo + ENDIF + CASE ( 'xs', 'xe' ) + distributed_field = .FALSE. + IF ( nproc .GT. 1 ) THEN + jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1 ! ns strip + ids = DomainStart(2) ; ide = DomainEnd(2) ; ! bdy_width + dom_end_rev(1) = jde + dom_end_rev(2) = ide + distributed_field = .TRUE. + IF ( (MemOrd .eq. 'xs' .AND. bdy_mask( P_XSB )) .OR. & + (MemOrd .eq. 'xe' .AND. bdy_mask( P_XEB )) ) THEN + my_displ = PatchStart(1)-1 + my_count = PatchEnd(1)-PatchStart(1)+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + do i = DomainStart(2),DomainEnd(2) ! bdy_width + lx = MemoryEnd(1)-MemoryStart(1)+1 + idx = lx*(i-1) + lx2 = dom_end_rev(1)-DomainStart(1)+1 + idx2 = lx2*(i-1) + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + + enddo + ENDIF + CASE ( 'ysz', 'yez' ) + distributed_field = .FALSE. + IF ( nproc .GT. 1 ) THEN + ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1 ! ns strip + kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1 ! levels + jds = DomainStart(3) ; jde = DomainEnd(3) ; ! bdy_width + dom_end_rev(1) = ide + dom_end_rev(2) = kde + dom_end_rev(3) = jde + distributed_field = .TRUE. + IF ( (MemOrd .eq. 'ysz' .AND. bdy_mask( P_YSB )) .OR. & + (MemOrd .eq. 'yez' .AND. bdy_mask( P_YEB )) ) THEN + my_displ = PatchStart(1)-1 + my_count = PatchEnd(1)-PatchStart(1)+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + do j = DomainStart(3),DomainEnd(3) ! bdy_width + do k = DomainStart(2),DomainEnd(2) ! levels + lx = MemoryEnd(1)-MemoryStart(1)+1 + lx2 = dom_end_rev(1)-DomainStart(1)+1 + idx = lx*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1)) + idx2 = lx2*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1)) + + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + + enddo + enddo + ENDIF + CASE ( 'ys', 'ye' ) + distributed_field = .FALSE. + IF ( nproc .GT. 1 ) THEN + ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1 ! ns strip + jds = DomainStart(2) ; jde = DomainEnd(2) ; ! bdy_width + dom_end_rev(1) = ide + dom_end_rev(2) = jde + distributed_field = .TRUE. + IF ( (MemOrd .eq. 'ys' .AND. bdy_mask( P_YSB )) .OR. & + (MemOrd .eq. 'ye' .AND. bdy_mask( P_YEB )) ) THEN + my_displ = PatchStart(1)-1 + my_count = PatchEnd(1)-PatchStart(1)+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + do j = DomainStart(2),DomainEnd(2) ! bdy_width + lx = MemoryEnd(1)-MemoryStart(1)+1 + idx = lx*(j-1) + lx2 = dom_end_rev(1)-DomainStart(1)+1 + idx2 = lx2*(j-1) + + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + CALL wrf_gatherv_double( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx , & ! sendbuf + my_count , & ! sendcount + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + + enddo + ENDIF +#endif +#endif + CASE DEFAULT + distributed_field = .FALSE. + END SELECT + IF ( wrf_dm_on_monitor() ) THEN + IF ( distributed_field ) THEN + CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + DomainStart , dom_end_rev , & ! memory dims adjust out for unstag + DomainStart , DomainEnd , & + Status ) + ELSE + CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + ENDIF + ENDIF + CALL wrf_dm_bcast_bytes( Status , IWORDSIZE ) + DEALLOCATE( counts ) + DEALLOCATE( displs ) + RETURN +END SUBROUTINE collect_generic_and_call_pkg + + +SUBROUTINE call_pkg_and_dist ( fcn, donotdist_arg, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! This routine handle cases where distribution/replication can be skipped and 
+! deals with different data types for Field.
+!
+! + IMPLICIT NONE +#include "wrf_io_flags.h" + EXTERNAL fcn + LOGICAL, INTENT(IN) :: donotdist_arg, update_arg ! update means collect old field update it and dist + INTEGER , INTENT(IN) :: Hndl + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER :: Field(*) + INTEGER :: FieldType + INTEGER :: Comm + INTEGER :: IOComm + INTEGER :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) :: MemoryOrder + CHARACTER*(*) :: Stagger + CHARACTER*(*) , dimension (*) :: DimNames + INTEGER ,dimension(*) :: DomainStart, DomainEnd + INTEGER ,dimension(*) :: MemoryStart, MemoryEnd + INTEGER ,dimension(*) :: PatchStart, PatchEnd + INTEGER :: Status + LOGICAL donotdist + INTEGER ndims, nproc + + CALL dim_from_memorder( MemoryOrder , ndims) + CALL wrf_get_nproc( nproc ) + donotdist = donotdist_arg .OR. (nproc .EQ. 1) + + IF ( donotdist ) THEN + CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF (FieldType .EQ. WRF_DOUBLE) THEN + + CALL call_pkg_and_dist_double ( fcn, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF (FieldType .EQ. WRF_FLOAT) THEN + + CALL call_pkg_and_dist_real ( fcn, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + CALL call_pkg_and_dist_int ( fcn, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + + CALL call_pkg_and_dist_logical ( fcn, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + + ENDIF + RETURN +END SUBROUTINE call_pkg_and_dist + +SUBROUTINE call_pkg_and_dist_real ( fcn, update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! The sole purpose of this wrapper is to allocate a big real buffer and
+! pass it down to call_pkg_and_dist_generic() to do the actual work.
+!
+! + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + LOGICAL , INTENT(IN) :: update_arg + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + REAL , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + REAL, ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + globbuf = 0. + + CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg, & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN +END SUBROUTINE call_pkg_and_dist_real + + +SUBROUTINE call_pkg_and_dist_double ( fcn, update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! The sole purpose of this wrapper is to allocate a big double precision buffer 
+! and pass it down to call_pkg_and_dist_generic() to do the actual work.
+!
+! + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + LOGICAL , INTENT(IN) :: update_arg + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + DOUBLE PRECISION , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + DOUBLE PRECISION , ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + globbuf = 0 + + CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN +END SUBROUTINE call_pkg_and_dist_double + + +SUBROUTINE call_pkg_and_dist_int ( fcn, update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! The sole purpose of this wrapper is to allocate a big integer buffer and 
+! pass it down to call_pkg_and_dist_generic() to do the actual work.
+!
+! + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + LOGICAL , INTENT(IN) :: update_arg + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + INTEGER , ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + globbuf = 0 + + CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN +END SUBROUTINE call_pkg_and_dist_int + + +SUBROUTINE call_pkg_and_dist_logical ( fcn, update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! The sole purpose of this wrapper is to allocate a big logical buffer and 
+! pass it down to call_pkg_and_dist_generic() to do the actual work.
+!
+! + IMPLICIT NONE + EXTERNAL fcn + INTEGER , INTENT(IN) :: Hndl + LOGICAL , INTENT(IN) :: update_arg + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + logical , INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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(INOUT) :: Status + LOGICAL , ALLOCATABLE :: globbuf (:) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) ) + ELSE + ALLOCATE( globbuf( 1 ) ) + ENDIF + + globbuf = .false. + + CALL call_pkg_and_dist_generic ( fcn, globbuf FRSTELEM , update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + DEALLOCATE ( globbuf ) + RETURN +END SUBROUTINE call_pkg_and_dist_logical + +SUBROUTINE call_pkg_and_dist_generic ( fcn, globbuf , update_arg , & + Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + +! +!
+! The call_pkg_and_dist* routines call an I/O function to read a field and then 
+! distribute or replicate the field across compute tasks.  
+! This routine calls I/O function fcn to read the field from disk and then calls 
+! the distributed memory communication routines that distribute or replicate the 
+! array.  
+!
+! + USE module_state_description + USE module_driver_constants + USE module_io + IMPLICIT NONE +#include "wrf_io_flags.h" +#if defined( DM_PARALLEL ) && ! defined(STUBMPI) +include "mpif.h" +#endif + + EXTERNAL fcn + REAL, DIMENSION(*) :: globbuf + INTEGER , INTENT(IN) :: Hndl + LOGICAL , INTENT(IN) :: update_arg + CHARACTER*(*) :: DateStr + CHARACTER*(*) :: VarName + REAL :: Field(*) + INTEGER ,INTENT(IN) :: FieldType + INTEGER ,INTENT(INOUT) :: Comm + INTEGER ,INTENT(INOUT) :: IOComm + INTEGER ,INTENT(IN) :: DomainDesc + LOGICAL, DIMENSION(4) :: bdy_mask + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(IN) :: Stagger + 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 MemOrd + LOGICAL, EXTERNAL :: has_char + INTEGER ids, ide, jds, jde, kds, kde + INTEGER ims, ime, jms, jme, kms, kme + INTEGER ips, ipe, jps, jpe, kps, kpe + INTEGER , dimension(3) :: dom_end_rev + INTEGER memsize + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + INTEGER, EXTERNAL :: wrf_dm_monitor_rank + + INTEGER lx, lx2, i,j,k ,idx,idx2 + INTEGER my_count, nproc, communicator, ierr, my_displ + + INTEGER, ALLOCATABLE :: counts(:), displs(:) + + LOGICAL distributed_field + INTEGER collective_root + + CALL lower_case( MemoryOrder, MemOrd ) + + collective_root = wrf_dm_monitor_rank() + + CALL wrf_get_nproc( nproc ) + CALL wrf_get_dm_communicator ( communicator ) + + ALLOCATE(displs( nproc )) + ALLOCATE(counts( nproc )) + + dom_end_rev(1) = DomainEnd(1) + dom_end_rev(2) = DomainEnd(2) + dom_end_rev(3) = DomainEnd(3) + + SELECT CASE (TRIM(MemOrd)) + CASE ( 'xzy' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'zxy' ) + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'xyz' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'xy' ) + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + CASE ( 'yxz' ) + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1 + CASE ( 'yx' ) + IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1 + IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1 + CASE DEFAULT + ! do nothing; the boundary orders and others either dont care or set themselves + END SELECT + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(3); kde=dom_end_rev(3); + ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(2); jme= MemoryEnd(2); kms=MemoryStart(3); kme= MemoryEnd(3); + ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(2); jpe= PatchEnd(2); kps= PatchStart(3); kpe= PatchEnd(3); + CASE ( DATA_ORDER_YXZ ) + ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(3); kde=dom_end_rev(3); + ims=MemoryStart(2); ime= MemoryEnd(2); jms=MemoryStart(1); jme= MemoryEnd(1); kms=MemoryStart(3); kme= MemoryEnd(3); + ips= PatchStart(2); ipe= PatchEnd(2); jps= PatchStart(1); jpe= PatchEnd(1); kps= PatchStart(3); kpe= PatchEnd(3); + CASE ( DATA_ORDER_ZXY ) + ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(1); kde=dom_end_rev(1); + ims=MemoryStart(2); ime= MemoryEnd(2); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(1); kme= MemoryEnd(1); + ips= PatchStart(2); ipe= PatchEnd(2); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(1); kpe= PatchEnd(1); + CASE ( DATA_ORDER_ZYX ) + ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(1); kde=dom_end_rev(1); + ims=MemoryStart(3); ime= MemoryEnd(3); jms=MemoryStart(2); jme= MemoryEnd(2); kms=MemoryStart(1); kme= MemoryEnd(1); + ips= PatchStart(3); ipe= PatchEnd(3); jps= PatchStart(2); jpe= PatchEnd(2); kps= PatchStart(1); kpe= PatchEnd(1); + CASE ( DATA_ORDER_XZY ) + ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2); + ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2); + ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2); + CASE ( DATA_ORDER_YZX ) + ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(2); kde=dom_end_rev(2); + ims=MemoryStart(3); ime= MemoryEnd(3); jms=MemoryStart(1); jme= MemoryEnd(1); kms=MemoryStart(2); kme= MemoryEnd(2); + ips= PatchStart(3); ipe= PatchEnd(3); jps= PatchStart(1); jpe= PatchEnd(1); kps= PatchStart(2); kpe= PatchEnd(2); + END SELECT data_ordering + + + SELECT CASE (MemOrd) +#ifndef STUBMPI + CASE ( 'xzy', 'yzx', 'xyz', 'yxz', 'zxy', 'zyx', 'xy', 'yx' ) + distributed_field = .TRUE. + CASE ( 'xsz', 'xez', 'xs', 'xe' ) + CALL are_bdys_distributed( distributed_field ) + CASE ( 'ysz', 'yez', 'ys', 'ye' ) + CALL are_bdys_distributed( distributed_field ) +#endif + CASE DEFAULT + ! all other memory orders are replicated + distributed_field = .FALSE. + END SELECT + + IF ( distributed_field ) THEN + +! added 8/2004 for interfaces, like MCEL, that want the old values so they can be updated + IF ( update_arg ) THEN + SELECT CASE (TRIM(MemOrd)) + CASE ( 'xzy','zxy','xyz','yxz','xy','yx' ) + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL wrf_patch_to_global_double ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL wrf_patch_to_global_real ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL wrf_patch_to_global_integer ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL wrf_patch_to_global_logical ( Field , globbuf , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + ENDIF + CASE DEFAULT + END SELECT + ENDIF + + IF ( wrf_dm_on_monitor()) THEN + CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + DomainStart , dom_end_rev , & + DomainStart , DomainEnd , & + Status ) + + ENDIF + + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + + CALL lower_case( MemoryOrder, MemOrd ) + +#if defined(DM_PARALLEL) && !defined(STUBMPI) +! handle boundaries separately + IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. & + TRIM(MemOrd) .EQ. 'xs' .OR. TRIM(MemOrd) .EQ. 'xe' .OR. & + TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. & + TRIM(MemOrd) .EQ. 'ys' .OR. TRIM(MemOrd) .EQ. 'ye' ) THEN + + IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. & + TRIM(MemOrd) .EQ. 'xs' .OR. TRIM(MemOrd) .EQ. 'xe' ) THEN + + jds=DomainStart(1); jde=dom_end_rev(1); ids=DomainStart(3); ide=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2); + jms=MemoryStart(1); jme= MemoryEnd(1); ims=MemoryStart(3); ime= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2); + jps= PatchStart(1); jpe= PatchEnd(1); ips= PatchStart(3); ipe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2); + + IF ( nproc .GT. 1 ) THEN + +! Will assume that the i,j, and k dimensions correspond to the model_data_order specified by the registry -- +! eg. i is (1), j is (3), and k is (2) for XZY -- and that when these are passed in for xs/xe boundary arrays (left and right +! sides of domain) the j is fully dimensioned, i is the bdy_width, and k is k. corresponding arrangement for ys/ye +! boundaries (bottom and top). Note, however, that for the boundary arrays themselves, the innermost dimension is always +! the "full" dimension: for xs/xe, dimension 1 of the boundary arrays is j. For ys/ye, it's i. So there's a potential +! for confusion between the MODEL storage order, and which of the sd31:ed31/sd32:ed32/sd33:ed33 framework dimensions +! correspond to X/Y/Z as determined by the Registry dimespec definitions and what the storage order of the boundary +! slab arrays are (which depends on which boundaries they represent). The k memory and domain dimensions must be set +! properly for 2d (ks=1, ke=1) versus 3d fields. + + IF ( (MemOrd(1:2) .EQ. 'xs' .AND. bdy_mask( P_XSB )) .OR. & + (MemOrd(1:2) .EQ. 'xe' .AND. bdy_mask( P_XEB )) ) THEN + my_displ = jps-1 + my_count = jpe-jps+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + + do i = ips,ipe ! bdy_width + do k = kds,kde ! levels + lx = jme-jms+1 + lx2 = jde-jds+1 + idx = lx*((k-1)+(i-1)*(kme-kms+1)) + idx2 = lx2*((k-1)+(i-1)*(kde-kds+1)) + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL wrf_scatterv_double ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, jps-jms+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + CALL wrf_scatterv_real ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, jps-jms+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL wrf_scatterv_integer ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, jps-jms+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + enddo + enddo + ENDIF + ENDIF + + IF ( TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. & + TRIM(MemOrd) .EQ. 'ys' .OR. TRIM(MemOrd) .EQ. 'ye' ) THEN + + ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2); + ims=MemoryStart(1); ime= MemoryEnd(1); jms=MemoryStart(3); jme= MemoryEnd(3); kms=MemoryStart(2); kme= MemoryEnd(2); + ips= PatchStart(1); ipe= PatchEnd(1); jps= PatchStart(3); jpe= PatchEnd(3); kps= PatchStart(2); kpe= PatchEnd(2); + + IF ( nproc .GT. 1 ) THEN + IF ( (MemOrd(1:2) .EQ. 'ys' .AND. bdy_mask( P_YSB )) .OR. & + (MemOrd(1:2) .EQ. 'ye' .AND. bdy_mask( P_YEB )) ) THEN + my_displ = ips-1 + my_count = ipe-ips+1 + ELSE + my_displ = 0 + my_count = 0 + ENDIF + + CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr ) + CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr ) + + do j = jds,jde ! bdy_width + do k = kds,kde ! levels + lx = ime-ims+1 + lx2 = ide-ids+1 + idx = lx*((k-1)+(j-1)*(kme-kms+1)) + idx2 = lx2*((k-1)+(j-1)*(kde-kds+1)) + + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL wrf_scatterv_double ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, ips-ims+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL wrf_scatterv_real ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, ips-ims+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL wrf_scatterv_integer ( & + globbuf, 1+idx2 , & ! recvbuf + counts , & ! recvcounts + Field, ips-ims+1+idx , & + my_count , & ! sendcount + displs , & ! displs + collective_root , & ! root + communicator , & ! communicator + ierr ) + ENDIF + enddo + enddo + ENDIF + ENDIF + + ELSE ! not a boundary + + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + + SELECT CASE (MemOrd) + CASE ( 'xzy','xyz','yxz','zxy' ) + CALL wrf_global_to_patch_double ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + CASE ( 'xy','yx' ) + CALL wrf_global_to_patch_double ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 ) + END SELECT + + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + + SELECT CASE (MemOrd) + CASE ( 'xzy','xyz','yxz','zxy' ) + CALL wrf_global_to_patch_real ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + CASE ( 'xy','yx' ) + CALL wrf_global_to_patch_real ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 ) + END SELECT + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + + SELECT CASE (MemOrd) + CASE ( 'xzy','xyz','yxz','zxy' ) + CALL wrf_global_to_patch_integer ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + CASE ( 'xy','yx' ) + CALL wrf_global_to_patch_integer ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 ) + END SELECT + + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + + SELECT CASE (MemOrd) + CASE ( 'xzy','xyz','yxz','zxy' ) + CALL wrf_global_to_patch_logical ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) ) + CASE ( 'xy','yx' ) + CALL wrf_global_to_patch_logical ( globbuf, Field , DomainDesc, Stagger, MemOrd , & + DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1 , 1 , & + MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1 , 1 , & + PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1 , 1 ) + END SELECT + + ENDIF + ENDIF +#endif + + ELSE ! not a distributed field + + IF ( wrf_dm_on_monitor()) THEN + CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + ENDIF + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + memsize = (MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1) + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL wrf_dm_bcast_bytes( Field , DWORDSIZE*memsize ) + ELSE IF ( FieldType .EQ. WRF_FLOAT) THEN + CALL wrf_dm_bcast_bytes( Field , RWORDSIZE*memsize ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL wrf_dm_bcast_bytes( Field , IWORDSIZE*memsize ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL wrf_dm_bcast_bytes( Field , LWORDSIZE*memsize ) + ENDIF + + ENDIF + + DEALLOCATE(displs) + DEALLOCATE(counts) + RETURN +END SUBROUTINE call_pkg_and_dist_generic + +!!!!!! Miscellaneous routines + +! stole these routines from io_netcdf external package; changed names to avoid collisions +SUBROUTINE dim_from_memorder(MemoryOrder,NDim) +! +!
+! Decodes array ranks from memory order.  
+!
+! + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + INTEGER ,INTENT(OUT) :: NDim +!Local + CHARACTER*3 :: MemOrd +! + CALL Lower_Case(MemoryOrder,MemOrd) + SELECT CASE (MemOrd) + CASE ('xyz','xzy','yxz','yzx','zxy','zyx') + NDim = 3 + CASE ('xy','yx') + NDim = 2 + CASE ('z','c','0') + NDim = 1 + CASE DEFAULT + NDim = 0 + RETURN + END SELECT + RETURN +END SUBROUTINE dim_from_memorder + +SUBROUTINE lower_case(MemoryOrder,MemOrd) +! +!
+! Translates upper-case characters to lower-case.  
+!
+! + CHARACTER*(*) ,INTENT(IN) :: MemoryOrder + CHARACTER*(*) ,INTENT(OUT) :: MemOrd +!Local + 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 Lower_Case + +LOGICAL FUNCTION has_char( str, c ) +! +!
+! Returns .TRUE. iff string str contains character c.  Ignores character case.  
+!
+! + IMPLICIT NONE + CHARACTER*(*) str + CHARACTER c, d + CHARACTER*80 str1, str2, str3 + INTEGER i + + CALL lower_case( TRIM(str), str1 ) + str2 = "" + str2(1:1) = c + CALL lower_case( str2, str3 ) + d = str3(1:1) + DO i = 1, LEN(TRIM(str1)) + IF ( str1(i:i) .EQ. d ) THEN + has_char = .TRUE. + RETURN + ENDIF + ENDDO + has_char = .FALSE. + RETURN +END FUNCTION has_char + diff --git a/wrfv2_fire/frame/module_io_quilt.F b/wrfv2_fire/frame/module_io_quilt.F new file mode 100644 index 00000000..f32a5bba --- /dev/null +++ b/wrfv2_fire/frame/module_io_quilt.F @@ -0,0 +1,3261 @@ +!WRF:DRIVER_LAYER:IO +! +#define DEBUG_LVL 50 +!#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__ +#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) + +MODULE module_wrf_quilt +! +!
+! This module contains WRF-specific I/O quilt routines called by both 
+! client (compute) and server (I/O quilt) tasks.  I/O quilt servers are 
+! a run-time optimization that allow I/O operations, executed on the I/O 
+! quilt server tasks, to be overlapped with useful computation, executed on 
+! the compute tasks.  Since I/O operations are often quite slow compared to 
+! computation, this performance optimization can increase parallel 
+! efficiency.  
+!
+! Currently, one group of I/O servers can be specified at run-time.  Namelist 
+! variable "nio_tasks_per_group" is used to specify the number of I/O server 
+! tasks in this group.  In most cases, parallel efficiency is optimized when 
+! the minimum number of I/O server tasks are used.  If memory needed to cache 
+! I/O operations fits on a single processor, then set nio_tasks_per_group=1.  
+! If not, increase the number of I/O server tasks until I/O operations fit in 
+! memory.  In the future, multiple groups of I/O server tasks will be 
+! supported.  The number of groups will be specified by namelist variable 
+! "nio_groups".  For now, nio_groups must be set to 1.  Currently, I/O servers 
+! only support overlap of output operations with computation.  Also, only I/O 
+! packages that do no support native parallel I/O may be used with I/O server 
+! tasks.  This excludes PHDF5 and MCEL.  
+!
+! In this module, the I/O quilt server tasks call package-dependent 
+! WRF-specific I/O interfaces to perform I/O operations requested by the 
+! client (compute) tasks.  All of these calls occur inside subroutine 
+! quilt().  
+! 
+! The client (compute) tasks call package-independent WRF-specific "quilt I/O" 
+! interfaces that send requests to the I/O quilt servers.  All of these calls 
+! are made from module_io.F.  
+!
+! These routines have the same names and (roughly) the same arguments as those 
+! specified in the WRF I/O API except that:
+! - "Quilt I/O" routines defined in this file and called by routines in 
+!   module_io.F have the "wrf_quilt_" prefix.
+! - Package-dependent routines called from routines in this file are defined 
+!   in the external I/O packages and have the "ext_" prefix.
+!
+! Both client (compute) and server tasks call routine init_module_wrf_quilt() 
+! which then calls setup_quilt_servers() determine which tasks are compute 
+! tasks and which are server tasks.  Before the end of init_module_wrf_quilt() 
+! server tasks call routine quilt() and remain there for the rest of the model 
+! run.  Compute tasks return from init_module_wrf_quilt() to perform model 
+! computations.  
+!
+! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
+! version of the WRF I/O API.  This document includes detailed descriptions
+! of subroutines and their arguments that are not duplicated here.
+!
+! + USE module_internal_header_util + USE module_timing + + INTEGER, PARAMETER :: int_num_handles = 99 + LOGICAL, DIMENSION(int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit + INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write, io_form + REAL, POINTER :: int_local_output_buffer(:) + INTEGER :: int_local_output_cursor + LOGICAL :: quilting_enabled + LOGICAL :: disable_quilt = .FALSE. + INTEGER :: prev_server_for_handle = -1 + INTEGER :: server_for_handle(int_num_handles) + INTEGER :: reduced(2), reduced_dummy(2) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER nio_groups +#ifdef DM_PARALLEL + INTEGER mpi_comm_local + INTEGER mpi_comm_io_groups(100) + INTEGER nio_tasks_in_group + INTEGER nio_tasks_per_group + INTEGER ncompute_tasks + INTEGER ntasks + INTEGER mytask + + INTEGER, PARAMETER :: onebyte = 1 + INTEGER comm_io_servers, iserver, hdrbufsize, obufsize + INTEGER, DIMENSION(4096) :: hdrbuf + INTEGER, DIMENSION(int_num_handles) :: handle +#endif + + CONTAINS + +#if defined(DM_PARALLEL) && !defined( STUBMPI ) + INTEGER FUNCTION get_server_id ( dhandle ) +! +! Logic in the client side to know which io server +! group to send to. If the unit corresponds to a file that's +! already been opened, then we have no choice but to send the +! data to that group again, regardless of whether there are +! other server-groups. If it's a new file, we can chose a new +! server group. I.e. opening a file locks it onto a server +! group. Closing the file unlocks it. +! + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN + get_server_id = server_for_handle ( dhandle ) + ELSE + prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups ) + server_for_handle( dhandle ) = prev_server_for_handle+1 + get_server_id = prev_server_for_handle+1 + ENDIF + ELSE + CALL wrf_message('module_io_quilt: get_server_id bad dhandle' ) + ENDIF + END FUNCTION get_server_id +#endif + + SUBROUTINE set_server_id ( dhandle, value ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle, value + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + server_for_handle(dhandle) = value + ELSE + CALL wrf_message('module_io_quilt: set_server_id bad dhandle' ) + ENDIF + END SUBROUTINE set_server_id + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + SUBROUTINE int_get_fresh_handle( retval ) +! +! Find an unused "client file handle" and return it in retval. +! The "client file handle" is used to remember how a file was opened +! so clients do not need to ask the I/O quilt servers for this information. +! It is also used as a file identifier in communications with the I/O +! server task. +! +! Note that client tasks know nothing about package-specific handles. +! Only the I/O quilt servers know about them. +! + INTEGER i, retval + retval = -1 + DO i = 1, int_num_handles + IF ( .NOT. int_handle_in_use(i) ) THEN + retval = i + GOTO 33 + ENDIF + ENDDO +33 CONTINUE + IF ( retval < 0 ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not") + ENDIF + int_handle_in_use(i) = .TRUE. + NULLIFY ( int_local_output_buffer ) + END SUBROUTINE int_get_fresh_handle + + SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, & + mytask, & + ntasks, & + n_groups_arg, & + nio, & + mpi_comm_wrld, & + mpi_comm_local, & + mpi_comm_io_groups) +! +! Both client (compute) and server tasks call this routine to +! determine which tasks are compute tasks and which are I/O server tasks. +! +! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to +! contain MPI communicators as follows: +! +! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the +! compute tasks it is the group of compute tasks; for a server group it the +! communicator of tasks in the server group. +! +! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or +! more compute tasks and a single I/O server assigned to those compute tasks. +! The I/O server tasks is always the last task in these communicators. +! On a compute task, which has a single associate in each of the server +! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds +! to a different server group. +! On a server task only the first element of MPI_COMM_IO_GROUPS is used +! because each server task is part of only one io_group. +! +! I/O server tasks in each I/O server group are divided among compute tasks as +! evenly as possible. +! +! When multiple I/O server groups are used, each must have the same number of +! tasks. When the total number of extra I/O tasks does not divide evenly by +! the number of io server groups requested, the remainder tasks are not used +! (wasted). +! +! For example, communicator membership for 18 tasks with nio_groups=2 and +! nio_tasks_per_group=3 is shown below: +! +!
+! Membership for MPI_COMM_LOCAL communicators:
+!   COMPUTE TASKS:          0   1   2   3   4   5   6   7   8   9  10  11
+!   1ST I/O SERVER GROUP:  12  13  14
+!   2ND I/O SERVER GROUP:  15  16  17
+!
+! Membership for MPI_COMM_IO_GROUPS(1):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  12
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  13
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  14
+!   I/O SERVER TASK       12:   0   3   6   9  12
+!   I/O SERVER TASK       13:   1   4   7  10  13
+!   I/O SERVER TASK       14:   2   5   8  11  14
+!   I/O SERVER TASK       15:   0   3   6   9  15
+!   I/O SERVER TASK       16:   1   4   7  10  16
+!   I/O SERVER TASK       17:   2   5   8  11  17
+!
+! Membership for MPI_COMM_IO_GROUPS(2):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  15
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  16
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  17
+!   I/O SERVER TASK       12:  ** not used **
+!   I/O SERVER TASK       13:  ** not used **
+!   I/O SERVER TASK       14:  ** not used **
+!   I/O SERVER TASK       15:  ** not used **
+!   I/O SERVER TASK       16:  ** not used **
+!   I/O SERVER TASK       17:  ** not used **
+!
+! + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, & + n_groups_arg, mpi_comm_wrld + INTEGER, INTENT(OUT) :: mpi_comm_local, nio + INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups +! Local + INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize + INTEGER, DIMENSION(ntasks) :: icolor + CHARACTER*128 mess + + n_groups = n_groups_arg + IF ( n_groups .LT. 1 ) n_groups = 1 + +! +! nio is number of io tasks per group. If there arent enough tasks to satisfy +! the requirement that there be at least as many compute tasks as io tasks in +! each group, then just print a warning and dump out of quilting +! + + nio = nio_tasks_per_group + ncompute_tasks = ntasks - (nio * n_groups) + IF ( ncompute_tasks .LT. nio ) THEN + WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio + nio = 0 + ncompute_tasks = ntasks + ELSE + WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio + ENDIF + CALL wrf_message(mess) + + IF ( nio .LT. 0 ) THEN + nio = 0 + ENDIF + IF ( nio .EQ. 0 ) THEN + quilting_enabled = .FALSE. + mpi_comm_local = MPI_COMM_WORLD + mpi_comm_io_groups = MPI_COMM_WORLD + RETURN + ENDIF + quilting_enabled = .TRUE. + +! First construct the local communicators +! prepare to split the communicator by designating compute-only tasks + DO i = 1, ncompute_tasks + icolor(i) = 0 + ENDDO + ii = 1 +! and designating the groups of i/o tasks + DO i = ncompute_tasks+1, ntasks, nio + DO j = i, i+nio-1 + icolor(j) = ii + ENDDO + ii = ii+1 + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr) + +! Now construct the communicators for the io_groups; round-robining the compute tasks + DO i = 1, ncompute_tasks + icolor(i) = mod(i-1,nio) + ENDDO +! ... and add the io servers as the last task in each group + DO j = 1, n_groups + ! TBH: each I/O group will contain only one I/O server + DO i = ncompute_tasks+1,ntasks + icolor(i) = MPI_UNDEFINED + ENDDO + ii = 0 + DO i = ncompute_tasks+(j-1)*nio+1,ncompute_tasks+j*nio + icolor(i) = ii + ii = ii+1 + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_io_groups(j),ierr) +!CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr ) + ENDDO +! If I am an I/O server, figure out which group I'm in and make that group's +! communicator the first element in the mpi_comm_io_groups array (I will ignore +! all of the other elements). + IF ( mytask+1 .GT. ncompute_tasks ) THEN + niotasks = ntasks - ncompute_tasks + i = mytask - ncompute_tasks + j = i / nio + 1 + mpi_comm_io_groups(1) = mpi_comm_io_groups(j) + ENDIF + + END SUBROUTINE setup_quilt_servers + + SUBROUTINE quilt +! +! I/O server tasks call this routine and remain in it for the rest of the +! model run. I/O servers receive I/O requests from compute tasks and +! perform requested I/O operations by calling package-dependent WRF-specific +! I/O interfaces. Requests are sent in the form of "data headers". Each +! request has a unique "header" message associated with it. For requests that +! contain large amounts of data, the data is appended to the header. See +! file module_internal_header_util.F for detailed descriptions of all +! headers. +! +! We wish to be able to link to different packages depending on whether +! the I/O is restart, initial, history, or boundary. +! + USE module_state_description + USE module_quilt_outbuf_ops + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" +#include "wrf_io_flags.h" + INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr + INTEGER istat + INTEGER mytask_io_group + INTEGER :: nout_set = 0 + INTEGER :: obufsize, bigbufsize, inttypesize, chunksize, sz + REAL, DIMENSION(1) :: dummy + INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA + CHARACTER (LEN=512) :: CDATA + CHARACTER (LEN=80) :: fname + INTEGER icurs, hdrbufsize, itypesize, ftypesize, Status, fstat, io_form_arg + INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count + INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + INTEGER :: dummybuf(1) + CHARACTER (len=80) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess + INTEGER, EXTERNAL :: use_package + LOGICAL :: stored_write_record, retval + INTEGER iii, jjj, vid + +! + +! Call ext_pkg_ioinit() routines to initialize I/O packages. + SysDepInfo = " " +#ifdef NETCDF + CALL ext_ncd_ioinit( SysDepInfo, ierr) +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr) +#endif + + okay_to_commit = .false. + stored_write_record = .false. + ninbuf = 0 + ! get info. about the I/O server group that this I/O server task + ! belongs to + ! Last task in this I/O server group is the I/O server "root" + ! The I/O server "root" actually writes data to disk + ! TBH: WARNING: This is also implicit in the call to collect_on_comm(). + CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr ) + CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) + + CALL MPI_TYPE_SIZE( MPI_INTEGER, inttypesize, ierr ) + IF ( inttypesize <= 0 ) THEN + CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") + ENDIF +! infinite loop until shutdown message received +! This is the main request-handling loop. I/O quilt servers stay in this loop +! until the model run ends. + DO WHILE (.TRUE.) + +! +! Each I/O server receives requests from its compute tasks. Each request +! is contained in a data header (see module_internal_header_util.F for +! detailed descriptions of data headers). +! Each request is sent in two phases. First, sizes of all messages that +! will be sent from the compute tasks to this I/O server are summed on the +! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" +! and receives concatenated messages from the compute tasks in it via the +! call to collect_on_comm(). Note that "sizes" are generally expressed in +! *bytes* in this code so conversion to "count" (number of Fortran words) is +! required for Fortran indexing and MPI calls. +! + ! wait for info from compute tasks in the I/O group that we're ready to rock + ! obufsize will contain number of *bytes* +!JMTIMINGCALL start_timing + ! first element of reduced is obufsize, second is DataHandle + ! if needed (currently needed only for ioclose). + reduced_dummy = 0 + CALL MPI_Reduce( reduced_dummy, reduced, 2, MPI_INTEGER, & + MPI_SUM, mytask_io_group, & + mpi_comm_io_groups(1), ierr ) + obufsize = reduced(1) +!JMTIMING CALL end_timing("MPI_Reduce at top of forever loop") +!JMDEBUGwrite(0,*)'obufsize = ',obufsize +!write(0,*)'ninbuf ',ninbuf,' obufsize ', obufsize +! Negative obufsize will trigger I/O server exit. + IF ( obufsize .LT. 0 ) THEN + IF ( obufsize .EQ. -100 ) THEN ! magic number +#ifdef NETCDF + CALL ext_ncd_ioexit( Status ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( Status ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( Status ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( Status ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( Status ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( Status ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( Status ) +#endif + CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) + CALL mpi_finalize(ierr) + STOP + ELSE + CALL wrf_error_fatal('Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.') + ENDIF + ENDIF + +!JMTIMING CALL start_timing +! Obufsize of zero signals a close + +! Allocate buffer obuf to be big enough for the data the compute tasks +! will send. Note: obuf is size in *bytes* so we need to pare this +! down, since the buffer is INTEGER. + IF ( obufsize .GT. 0 ) THEN + ALLOCATE( obuf( (obufsize+1)/inttypesize ) ) + +! let's roll; get the data from the compute procs and put in obuf + CALL collect_on_comm( mpi_comm_io_groups(1), & + onebyte, & + dummy, 0, & + obuf, obufsize ) +!JMTIMING CALL end_timing( "quilt on server: collecting data from compute procs" ) + ELSE + ! Necessarily, the compute processes send the ioclose signal, + ! if there is one, after the iosync, which means they + ! will stall on the ioclose message waiting for the quilt + ! processes if we handle the way other messages are collected, + ! using collect_on_comm. This avoids this, but we need + ! a special signal (obufsize zero) and the DataHandle + ! to be closed. That handle is send as the second + ! word of the io_close message received by the MPI_Reduce above. + ! Then a header representing the ioclose message is constructed + ! here and handled below as if it were received from the + ! compute processes. The clients (compute processes) must be + ! careful to send this correctly (one compule process sends the actual + ! handle and everone else sends a zero, so the result sums to + ! the value of the handle). + ! + ALLOCATE( obuf( 4096 ) ) + ! DataHandle is provided as second element of reduced + CALL int_gen_handle_header( obuf, obufsize, itypesize, & + reduced(2) , int_ioclose ) + + ENDIF + +!write(0,*)'calling init_store_piece_of_field' +! Now all messages received from the compute clients are stored in +! obuf. Scan through obuf and extract headers and field data and store in +! internal buffers. The scan is done twice, first to determine sizes of +! internal buffers required for storage of headers and fields and second to +! actually store the headers and fields. This bit of code does not do the +! "quilting" (assembly of patches into full domains). For each field, it +! simply concatenates all received patches for the field into a separate +! internal buffer (i.e. one buffer per field). Quilting is done later by +! routine store_patch_in_outbuf(). + CALL init_store_piece_of_field + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) +!write(0,*)'mpi_type_size returns ', itypesize +! Scan obuf the first time to calculate the size of the buffer required for +! each field. Calls to add_to_bufsize_for_field() accumulate sizes. + vid = 0 + icurs = inttypesize + DO WHILE ( icurs .lt. obufsize ) + SELECT CASE ( get_hdr_tag( obuf ( icurs / inttypesize ) ) ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), accumulate + ! buffersize for this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'X-1a', chunksize, TRIM(VarName) + call add_to_bufsize_for_field( VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE DEFAULT + hdrbufsize = obuf(icurs/inttypesize) + write(VarName,'(I5.5)')vid +!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + icurs = icurs + hdrbufsize + vid = vid+1 + END SELECT + ENDDO +! Store the headers and field data in internal buffers. The first call to +! store_piece_of_field() allocates internal buffers using sizes computed by +! calls to add_to_bufsize_for_field(). + vid = 0 + icurs = inttypesize + DO WHILE ( icurs .lt. obufsize ) +!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize + SELECT CASE ( get_hdr_tag( obuf ( icurs / inttypesize ) ) ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + + call store_piece_of_field( obuf(icurs/inttypesize), VarName, hdrbufsize ) +!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName) + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), store + ! this piece of this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'A-1a', chunksize, TRIM(VarName) + call store_piece_of_field( obuf(icurs/inttypesize), VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE DEFAULT + hdrbufsize = obuf(icurs/inttypesize) + write(VarName,'(I5.5)')vid + call store_piece_of_field( obuf(icurs/inttypesize), VarName, hdrbufsize ) +!write(0,*) 'A-2', hdrbufsize, get_hdr_tag( obuf ( icurs / inttypesize ) ) , get_hdr_rec_size( obuf ( icurs / inttypesize ) ), TRIM(VarName) + icurs = icurs + hdrbufsize + vid = vid+1 + END SELECT + ENDDO + +!call mpi_comm_size( mpi_comm_local, iii, ierr ) +!write(0,*)'mpi_comm_size mpi_comm_local ',iii +!call mpi_comm_rank( mpi_comm_local, iii, ierr ) +!write(0,*)'mpi_comm_rank mpi_comm_local ',iii + +!write(0,*)'calling init_retrieve_pieces_of_field ' +! Now, for each field, retrieve headers and patches (data) from the internal +! buffers and collect them all on the I/O quilt server "root" task. + CALL init_retrieve_pieces_of_field +! Retrieve header and all patches for the first field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +!write(0,*)'calling first retrieve_pieces_of_field ',TRIM(VarName),obufsize,sz,retval +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, & + MPI_SUM, ntasks_local_group-1, & + mpi_comm_local, ierr ) +!write(0,*)'after MPI_Reduce ',sz, bigbufsize + +! Loop until there are no more fields to retrieve from the internal buffers. + DO WHILE ( retval ) + +!write(0,*)' VarName ',TRIM(VarName),' sz ',sz,' bigbufsize ',bigbufsize + +! I/O server "root" allocates space to collect headers and fields from all +! other servers in this I/O server group. + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN +!write(0,*)'allocating bufbuf ', (bigbufsize+1)/inttypesize + ALLOCATE( bigbuf( (bigbufsize+1)/inttypesize ) ) + ENDIF + +!write(0,*)'before collect_on_comm tag,size ',Trim(VarName),get_hdr_tag(obuf),get_hdr_rec_size(obuf) +! Collect buffers and fields from all I/O servers in this I/O server group +! onto the I/O server "root" + CALL collect_on_comm( mpi_comm_local, & + onebyte, & + obuf, sz, & + bigbuf, bigbufsize ) +!write(0,*)'after collect_on_comm ', sz, bigbufsize +! The I/O server "root" now handles collected requests from all compute +! tasks served by this I/O server group (i.e. all compute tasks). + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN +!jjj = 4 +!do iii = 1, ntasks_local_group +! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4)) +! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4)) +!enddo + + icurs = inttypesize ! icurs is a byte counter, but buffer is integer + + stored_write_record = .false. + +! The I/O server "root" loops over the collected requests. + DO WHILE ( icurs .lt. bigbufsize ) + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) + +!write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/inttypesize) ),get_hdr_rec_size( bigbuf(icurs/inttypesize) ) +!write(0,*)' inttypesize ',inttypesize,' itypesize ',itypesize,' icurs/inttypesize ',icurs/inttypesize +! The I/O server "root" gets the request out of the next header and +! handles it by, in most cases, calling the appropriate external I/O package +! interface. + SELECT CASE ( get_hdr_tag( bigbuf(icurs/inttypesize) ) ) +! The I/O server "root" handles the "noop" (do nothing) request. This is +! actually quite easy. "Noop" requests exist to help avoid race conditions. +! In some cases, only one compute task will everything about a request so +! other compute tasks send "noop" requests. + CASE ( int_noop ) +!write(0,*)' int_noop ' + CALL int_get_noop_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize ) + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_td_real" request. + CASE ( int_dom_td_real ) +!write(0,*)' int_dom_td_real ' + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, & + DataHandle, DateStr, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) +! The I/O server "root" handles the "put_dom_ti_real" request. + CASE ( int_dom_ti_real ) +!write(0,*)' int_dom_ti_real ' + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, & + DataHandle, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +!write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) + +! The I/O server "root" handles the "put_dom_td_integer" request. + CASE ( int_dom_td_integer ) +!write(0,*)' int_dom_td_integer ' + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, & + DataHandle, DateStr, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData ) + +! The I/O server "root" handles the "put_dom_ti_integer" request. + CASE ( int_dom_ti_integer ) +!write(0,*)' int_dom_ti_integer ' + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/inttypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/inttypesize:), hdrbufsize, inttypesize, ftypesize, & + DataHandle, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +!write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData) + +! The I/O server "root" handles the "set_time" request. + CASE ( int_set_time ) +!write(0,*)' int_set_time ' + CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, & + DataHandle, Element, VarName, CData, code ) + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_ti_char" request. + CASE ( int_dom_ti_char ) +!write(0,*)' before int_get_ti_header_char ' + CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, & + DataHandle, Element, VarName, CData, code ) +!write(0,*)' after int_get_ti_header_char ',VarName + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_var_ti_char" request. + CASE ( int_var_ti_char ) +!write(0,*)' int_var_ti_char ' + CALL int_get_ti_header_char( bigbuf(icurs/inttypesize), hdrbufsize, inttypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + + CASE ( int_ioexit ) +! ioexit is now handled by sending negative message length to server + CALL wrf_error_fatal( & + "quilt: should have handled int_ioexit already") +! The I/O server "root" handles the "ioclose" request. + CASE ( int_ioclose ) + CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + + IF ( DataHandle .GE. 1 ) THEN +!JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_ioclose(handle(DataHandle),Status) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + +! The I/O server "root" handles the "open_for_write_begin" request. + CASE ( int_open_for_write_begin ) + + CALL int_get_ofwb_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, & + FileName,SysDepInfo,io_form_arg,DataHandle ) + +!write(0,*)' int_open_for_write_begin inttypesize ',inttypesize,' itypesize ',itypesize +!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) + icurs = icurs + hdrbufsize +!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/inttypesize) ),get_hdr_rec_size( bigbuf(icurs/inttypesize) ) + + io_form(DataHandle) = io_form_arg + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_write(DataHandle) = .false. + +! The I/O server "root" handles the "open_for_write_commit" request. +! In this case, the "okay_to_commit" is simply set to .true. so "write_field" +! requests will initiate writes to disk. Actual commit will be done after +! all requests in this batch have been handled. + CASE ( int_open_for_write_commit ) + + CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, & + DataHandle , code ) +!write(0,*)' int_open_for_write_commit icurs ', icurs, hdrbufsize + icurs = icurs + hdrbufsize + okay_to_commit(DataHandle) = .true. + +! The I/O server "root" handles the "write_field" (int_field) request. +! If okay_to_write(DataHandle) is .true. then the patch in the +! header (bigbuf) is written to a globally-sized internal output buffer via +! the call to store_patch_in_outbuf(). Note that this is where the actual +! "quilting" (reassembly of patches onto a full-size domain) is done. If +! okay_to_write(DataHandle) is .false. then external I/O package interfaces +! are called to write metadata for I/O formats that support native metadata. +! +! NOTE that the I/O server "root" will only see write_field (int_field) +! requests AFTER an "iosync" request. + CASE ( int_field ) +!write(0,*)' int_field ' + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + CALL int_get_write_field_header ( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + icurs = icurs + hdrbufsize + + IF ( okay_to_write(DataHandle) ) THEN + +! WRITE(*,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', & +! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1) + + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE) THEN +! this branch has not been tested TBH: 20050406 + CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) + ELSE + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ENDIF + stored_write_record = .true. + CALL store_patch_in_outbuf ( bigbuf(icurs/inttypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + stored_write_record = .true. + CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/inttypesize), TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ftypesize = LWORDSIZE + ENDIF + icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + ELSE + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#if 0 +! since this is training and the grib output doesn't need training, disable this branch. +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + CASE ( int_iosync ) +!write(0,*)' int_iosync ' + CALL int_get_handle_header( bigbuf(icurs/inttypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + CASE DEFAULT + WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/inttypesize) ),' icurs ',icurs/inttypesize + CALL wrf_error_fatal( mess ) + END SELECT + + ENDDO +! Now, the I/O server "root" has finshed handling all commands from the latest +! call to retrieve_pieces_of_field(). + + IF (stored_write_record) THEN +!write(0,*)'calling write_outbuf ',DataHandle +! If any fields have been stored in a globally-sized internal output buffer +! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write +! them to disk now. +! NOTE that the I/O server "root" will only have called +! store_patch_in_outbuf() when handling write_field (int_field) +! commands which only arrive AFTER an "iosync" command. +!JMTIMING CALL start_timing + CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) +!JMTIMING CALL end_timing( "quilt: call to write_outbuf" ) +!write(0,*)'back from write_outbuf ',DataHandle + ENDIF + +! If one or more "open_for_write_commit" commands were encountered from the +! latest call to retrieve_pieces_of_field() then call the package-specific +! routine to do the commit. + IF (okay_to_commit(DataHandle)) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) +!write(0,*)'preparing to commit ', DataHandle, fstat, fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN +!write(0,*)'calling ext_ncd_open_for_write_commit ', handle(DataHandle), DataHandle + CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) +!write(0,*)'back from ext_ncd_open_for_write_commit ', Status + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_commit(DataHandle) = .false. + ENDIF + DEALLOCATE( bigbuf ) + ENDIF + +! Retrieve header and all patches for the next field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +!write(0,*)'calling next retrieve_pieces_of_field ',trim(VarName),obufsize,sz,retval +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL MPI_Reduce( sz, bigbufsize, 1, MPI_INTEGER, & + MPI_SUM, ntasks_local_group-1, & + mpi_comm_local, ierr ) +! Then, return to the top of the loop to collect headers and data from all +! I/O servers in this I/O server group onto the I/O server "root" and handle +! the next batch of commands. +!write(0,*)'after MPI_Reduce ',sz, bigbufsize + END DO + + DEALLOCATE( obuf ) + + ! flush output files if needed + IF (stored_write_record) THEN +!JMTIMING CALL start_timing + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_iosync( handle(DataHandle), Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_iosync( handle(DataHandle), Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_iosync( handle(DataHandle), Status ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_iosync( handle(DataHandle), Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_iosync( handle(DataHandle), Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT +!JMTIMING CALL end_timing( "quilt: flush" ) + ENDIF + + END DO + + END SUBROUTINE quilt + +! end of #endif of DM_PARALLEL +#endif + + SUBROUTINE init_module_wrf_quilt +! +! Both client (compute) and server tasks call this routine to initialize the +! module. Routine setup_quilt_servers() is called from this routine to +! determine which tasks are compute tasks and which are server tasks. Server +! tasks then call routine quilt() and remain there for the rest of the model +! run. Compute tasks return from init_module_wrf_quilt() to perform model +! computations. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER i + NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups + INTEGER ntasks, mytask, ierr, io_status + LOGICAL mpi_inited + + quilting_enabled = .FALSE. + IF ( disable_quilt ) RETURN + + DO i = 1,int_num_handles + okay_to_write(i) = .FALSE. + int_handle_in_use(i) = .FALSE. + server_for_handle(i) = 0 + int_num_bytes_to_write(i) = 0 + ENDDO + + CALL MPI_INITIALIZED( mpi_inited, ierr ) + IF ( mpi_inited ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: quilt initialization "// & + "must be called before MPI_Init") ; + ENDIF + + CALL mpi_init ( ierr ) + CALL wrf_set_dm_communicator( MPI_COMM_WORLD ) + CALL wrf_termio_dup + CALL MPI_Comm_rank ( MPI_COMM_WORLD, mytask, ierr ) ; + CALL mpi_x_comm_size ( MPI_COMM_WORLD, ntasks, ierr ) ; + + IF ( mytask .EQ. 0 ) THEN + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + nio_groups = 1 + nio_tasks_per_group = 0 + READ ( 27 , NML = namelist_quilt, IOSTAT=io_status ) + IF (io_status .NE. 0) THEN + CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" ) + ENDIF + CLOSE ( 27 ) + ENDIF + CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD, ierr ) + CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , MPI_COMM_WORLD, ierr ) + + CALL setup_quilt_servers( nio_tasks_per_group, & + mytask, & + ntasks, & + nio_groups, & + nio_tasks_in_group, & + MPI_COMM_WORLD, & + mpi_comm_local, & + mpi_comm_io_groups) + + ! provide the communicator for the integration tasks to RSL + IF ( mytask .lt. ncompute_tasks ) THEN + CALL wrf_set_dm_communicator( mpi_comm_local ) + ELSE + CALL quilt ! will not return on io server tasks + ENDIF +#endif + RETURN + END SUBROUTINE init_module_wrf_quilt +END MODULE module_wrf_quilt + +! +! Remaining routines in this file are defined outside of the module +! either to defeat arg/param type checking or to avoid an explicit use +! dependence. +! + +SUBROUTINE disable_quilting +! +! Call this in programs that you never want to be quilting (e.g. real) +! Must call before call to init_module_wrf_quilt(). +! + USE module_wrf_quilt + disable_quilt = .TRUE. + RETURN +END SUBROUTINE disable_quilting + +LOGICAL FUNCTION use_output_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_output_servers = quilting_enabled + RETURN +END FUNCTION use_output_servers + +LOGICAL FUNCTION use_input_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for read operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_input_servers = .FALSE. + RETURN +END FUNCTION use_input_servers + +SUBROUTINE wrf_quilt_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , io_form_arg, Status ) +! +! Instruct the I/O quilt servers to begin data definition ("training") phase +! for writing to WRF dataset FileName. io_form_arg indicates file format. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(IN) :: io_form_arg + INTEGER , INTENT(OUT) :: Status +! Local + CHARACTER*132 :: locFileName, locSysDepInfo + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' ) + CALL int_get_fresh_handle(i) + okay_to_write(i) = .false. + DataHandle = i + + locFileName = FileName + locSysDepInfo = SysDepInfo + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + locFileName,locSysDepInfo,io_form_arg,DataHandle ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + + iserver = get_server_id ( DataHandle ) +!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) +!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) +!JMDEBUGwrite(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = i + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin") + + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_begin + +SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) +! +! Instruct the I/O quilt servers to switch an internal flag to enable output +! for the dataset referenced by DataHandle. The call to +! wrf_quilt_open_for_write_commit() must be paired with a call to +! wrf_quilt_open_for_write_begin(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + okay_to_write( DataHandle ) = .true. + ENDIF + ENDIF + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_open_for_write_commit ) + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit") + + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_commit + +SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +! Instruct the I/O quilt servers to open WRF dataset FileName for reading. +! This routine is called only by client (compute) tasks. +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' ) + DataHandle = -1 + Status = -1 + CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" ) +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_read + +SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status ) +! +! Inquire if the dataset referenced by DataHandle is open. +! Does not require communication with I/O servers. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + + Status = 0 + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ENDIF + ENDIF + ENDIF + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_opened + +SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status ) +! +! Return the Filename and FileStatus associated with DataHandle. +! Does not require communication with I/O servers. +! +! Note that the current implementation does not actually return FileName. +! Currenlty, WRF does not use this returned value. Fixing this would simply +! require saving the file names on the client tasks in an array similar to +! okay_to_write(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(OUT) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' ) + Status = 0 + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ELSE + FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + ENDIF + ELSE + FileStatus = WRF_FILE_NOT_OPENED + ENDIF + Status = 0 + FileName = "bogusfornow" + ELSE + Status = -1 + ENDIF +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_filename + +SUBROUTINE wrf_quilt_iosync ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to synchronize the disk copy of a dataset +! with memory buffers. +! +! After the "iosync" header (request) is sent to the I/O quilt server, +! the compute tasks will then send the entire contents (headers and data) of +! int_local_output_buffer to their I/O quilt server. This communication is +! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers +! receive this data, they will write all accumulated fields to disk. +! +! Significant time may be required for the I/O quilt servers to organize +! fields and write them to disk. Therefore, the "iosync" request should be +! sent only when the compute tasks are ready to run for a while without +! needing to communicate with the servers. Otherwise, the compute tasks +! will end up waiting for the servers to finish writing to disk, thus wasting +! any performance benefits of having servers at all. +! +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + USE module_wrf_quilt + IMPLICIT NONE + include "mpif.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + INTEGER locsize , inttypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' ) + +!JMTIMING CALL start_timing + IF ( associated ( int_local_output_buffer ) ) THEN + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + locsize = int_num_bytes_to_write(DataHandle) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = locsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_iosync") + + ! send data to the i/o processor +#ifdef DEREF_KLUDGE + CALL collect_on_comm( comm_io_group, & + onebyte, & + int_local_output_buffer(1), locsize , & + dummy, 0 ) +#else + CALL collect_on_comm( comm_io_group, & + onebyte, & + int_local_output_buffer, locsize , & + dummy, 0 ) +#endif + + + int_local_output_cursor = 1 +! int_num_bytes_to_write(DataHandle) = 0 + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ELSE + CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated") + ENDIF +!JMTIMING CALL end_timing("wrf_quilt_iosync") + Status = 0 +#endif + RETURN +END SUBROUTINE wrf_quilt_iosync + +SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to close the dataset referenced by +! DataHandle. +! This routine also clears the client file handle and, if needed, deallocates +! int_local_output_buffer. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined( STUBMPI) + USE module_wrf_quilt + USE module_timing + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr + REAL dummy + +!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioclose ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +!JMDEBUGwrite(0,*)'before MPI_Reduce in ioclose: reduced ', reduced + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in ioclose") + +#if 0 + ! send data to the i/o processor +!JMTIMING CALL start_timing + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!JMTIMING CALL end_timing("collect_on_comm in io_close") +#endif + + int_handle_in_use(DataHandle) = .false. + CALL set_server_id( DataHandle, 0 ) + okay_to_write(DataHandle) = .false. + okay_to_commit(DataHandle) = .false. + int_local_output_cursor = 1 + int_num_bytes_to_write(DataHandle) = 0 + IF ( associated ( int_local_output_buffer ) ) THEN + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ENDIF + + Status = 0 +!JMTIMING CALL end_timing( "wrf_quilt_ioclose" ) + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioclose + +SUBROUTINE wrf_quilt_ioexit( Status ) +! +! Instruct the I/O quilt servers to shut down the WRF I/O system. +! Do not call any wrf_quilt_*() routines after this routine has been called. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(OUT) :: Status + INTEGER :: DataHandle + INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioexit ) ! Handle is dummy + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + + DO iserver = 1, nio_groups + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + CALL mpi_comm_rank( comm_io_group , me , ierr ) + +! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN + hdrbufsize = -100 + reduced = 0 + IF ( me .eq. 0 ) reduced(1) = hdrbufsize + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) + + ENDDO + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioexit + +SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the next time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_time + +SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the previous time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_previous_time + +SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status ) +! +! Instruct the I/O quilt servers to set the time stamp in the dataset +! referenced by DataHandle. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER :: Count +! + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + Count = 0 ! there is no count for character strings + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, "TIMESTAMP", "", Data, int_set_time ) + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + +#endif +RETURN +END SUBROUTINE wrf_quilt_set_time + +SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status ) +! +! When reading, instruct the I/O quilt servers to return the name of the next +! variable in the current time frame. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: VarName + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_var + +SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. + +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL, INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Outcount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_real + +SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +!Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! +!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + locElement = Element + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr ) + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_real ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real") + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + + Status = 0 +!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real") +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_real + +SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_double + +SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_double + +SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_integer + +SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + INTEGER , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! + +!JMTIMING CALL start_timing + locElement = Element + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr ) + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_integer ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) + +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer") + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' ) +!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_integer + +SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_logical + +SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + INTEGER i + INTEGER one_or_zero(Count) + + DO i = 1, Count + IF ( Data(i) ) THEN + one_or_zero(i) = 1 + ELSE + one_or_zero(i) = 0 + ENDIF + ENDDO + + CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status ) +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_logical + +SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) :: Data + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_char + +SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me + REAL dummy +! +!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, "", Data, int_dom_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + iserver = get_server_id ( DataHandle ) +! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) +!JMTIMING! CALL start_timing +!write(0,*)'calling MPI_Barrier' +! CALL MPI_Barrier( mpi_comm_local, ierr ) +!write(0,*)'back from MPI_Barrier' +!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char") + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced_dummy = 0 + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + +!call mpi_comm_rank( comm_io_group , me, ierr ) +!write(0,*)'calling MPI_Reduce me and tasks_in_group and comm_io_group',me,tasks_in_group ,comm_io_group + + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! nio_tasks_in_group-1 is me + comm_io_group, ierr ) + +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char") + ! send data to the i/o processor +!JMTIMING CALL start_timing + + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char") + ENDIF + ENDIF +!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char") + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_char + +SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_real + +SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_real + +SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_double + +SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_double + +SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_integer + +SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_integer + +SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_logical + +SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_logical + +SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_char + +SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct $he I/O quilt servers to write time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_char + +SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_real + +SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_real + +SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_double + +SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_double + +SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_integer + +SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_integer + +SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_logical + +SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_logical + +SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_char + +SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! + +!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char") + ! send data to the i/o processor + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF +!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_char + +SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_real + +SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_real + +SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_td_double + +SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_td_double + +SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_integer + +SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_integer + +SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_logical + +SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_logical + +SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_char + +SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_char + +SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Instruct the I/O quilt servers to read the variable named VarName from the +! dataset pointed to by DataHandle. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(INOUT) :: DateStr + CHARACTER*(*) , INTENT(INOUT) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + 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 + Status = 0 +#endif +RETURN +END SUBROUTINE wrf_quilt_read_field + +SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Prepare instructions for the I/O quilt servers to write the variable named +! VarName to the dataset pointed to by DataHandle. +! +! During a "training" write this routine accumulates number and sizes of +! messages that will be sent to the I/O server associated with this compute +! (client) task. +! +! During a "real" write, this routine begins by allocating +! int_local_output_buffer if it has not already been allocated. Sizes +! accumulated during "training" are used to determine how big +! int_local_output_buffer must be. This routine then stores "int_field" +! headers and associated field data in int_local_output_buffer. The contents +! of int_local_output_buffer are actually sent to the I/O quilt server in +! routine wrf_quilt_iosync(). This scheme allows output of multiple variables +! to be aggregated into a single "iosync" operation. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_state_description + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName +! INTEGER , INTENT(IN) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + 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 ii,jj,kk,myrank + + REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), & + MemoryStart(2):MemoryEnd(2), & + MemoryStart(3):MemoryEnd(3) ) :: Field + INTEGER locsize , typesize, inttypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i + INTEGER, EXTERNAL :: use_package + +!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' ) + + IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" ) + ENDIF + IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" ) + ENDIF + + locsize = (PatchEnd(1)-PatchStart(1)+1)* & + (PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1) + + CALL mpi_type_size( MPI_INTEGER, inttypesize, ierr ) + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL mpi_type_size( MPI_REAL, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL mpi_type_size( MPI_LOGICAL, typesize, ierr ) + ENDIF + + IF ( .NOT. okay_to_write( DataHandle ) ) THEN + + ! This is a "training" write. + ! it is not okay to actually write; what we do here is just "bookkeep": count up + ! the number and size of messages that we will output to io server associated with + ! this task + + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize + + ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode + + iserver = get_server_id ( DataHandle ) +!JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others + CALL int_gen_noop_header( hdrbuf, hdrbufsize, inttypesize ) + ENDIF + + +!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle + CALL MPI_Reduce( reduced, reduced_dummy, 2, MPI_INTEGER, & + MPI_SUM, tasks_in_group-1, & ! root = nio_tasks_in_group-1 is me + comm_io_group, ierr ) +!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun") + ! send data to the i/o processor + + CALL collect_on_comm( comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + ELSE + + IF ( .NOT. associated( int_local_output_buffer ) ) THEN + ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/inttypesize ) ) + int_local_output_cursor = 1 + ENDIF + iserver = get_server_id ( DataHandle ) +!JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver + + ! This is NOT a "training" write. It is OK to write now. + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ! Pack header into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ! Pack field data into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ENDIF + Status = 0 +!JMTIMING CALL end_timing("wrf_quilt_write_field") + +#endif + RETURN +END SUBROUTINE wrf_quilt_write_field + +SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , Status ) +! +! This routine applies only to a dataset that is open for read. It instructs +! the I/O quilt servers to return information about variable VarName. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: VarName + integer :: NDim + character*(*) :: MemoryOrder + character*(*) :: Stagger + integer ,dimension(*) :: DomainStart, DomainEnd + integer :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_info + +SUBROUTINE get_mpi_comm_io_groups( retval, isrvr ) +! +! This routine returns the compute+io communicator to which this +! compute task belongs for I/O server group "isrvr". +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INTEGER, INTENT(IN ) :: isrvr + INTEGER, INTENT(OUT) :: retval + retval = mpi_comm_io_groups(isrvr) +#endif + RETURN +END SUBROUTINE get_mpi_comm_io_groups + +SUBROUTINE get_nio_tasks_in_group( retval ) +! +! This routine returns the number of I/O server tasks in each +! I/O server group. It can be called by both clients and +! servers. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval + retval = nio_tasks_in_group +#endif + RETURN +END SUBROUTINE get_nio_tasks_in_group + + diff --git a/wrfv2_fire/frame/module_machine.F b/wrfv2_fire/frame/module_machine.F new file mode 100644 index 00000000..a6ca7861 --- /dev/null +++ b/wrfv2_fire/frame/module_machine.F @@ -0,0 +1,177 @@ +!WRF:DRIVER_LAYER:DECOMPOSITION +! + +MODULE module_machine + + USE module_driver_constants + + ! Machine characteristics and utilities here. + + ! Tile strategy defined constants + INTEGER, PARAMETER :: TILE_X = 1, TILE_Y = 2, TILE_XY = 3 + + TYPE machine_type + INTEGER :: tile_strategy + END TYPE machine_type + + TYPE (machine_type) machine_info + + 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 + machine_info%tile_strategy = TILE_Y + 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/wrfv2_fire/frame/module_nesting.F b/wrfv2_fire/frame/module_nesting.F new file mode 100644 index 00000000..09b8838f --- /dev/null +++ b/wrfv2_fire/frame/module_nesting.F @@ -0,0 +1,82 @@ +!WRF:DRIVER_LAYER:NESTING +! + + +MODULE module_nesting + + USE module_machine + USE module_driver_constants + USE module_domain + USE module_configure + USE module_utility + + LOGICAL, DIMENSION( max_domains ) :: active_domain + +CONTAINS + + LOGICAL FUNCTION nests_to_open ( parent , nestid , kid ) + IMPLICIT NONE + TYPE(domain) , INTENT(IN) :: parent + INTEGER, INTENT(OUT) :: nestid , kid + ! Local data + INTEGER :: parent_id + INTEGER :: rent + INTEGER :: s_yr,s_mm,s_dd,s_h,s_m,s_s,rc + INTEGER :: e_yr,e_mm,e_dd,e_h,e_m,e_s + INTEGER :: max_dom + TYPE (WRFU_Time) :: nest_start, nest_stop +!#define STUB_FOR_NOW +#ifndef STUB_FOR_NOW + nestid = 0 + kid = 0 + nests_to_open = .false. + CALL nl_get_max_dom( 1, max_dom ) + DO nestid = 2, max_dom + IF ( .NOT. active_domain( nestid ) ) THEN + CALL nl_get_parent_id( nestid, parent_id ) ! from namelist + IF ( parent_id .EQ. parent%id ) THEN + CALL nl_get_start_year(nestid,s_yr) ; CALL nl_get_end_year(nestid,e_yr) + CALL nl_get_start_month(nestid,s_mm) ; CALL nl_get_end_month(nestid,e_mm) + CALL nl_get_start_day(nestid,s_dd) ; CALL nl_get_end_day(nestid,e_dd) + CALL nl_get_start_hour(nestid,s_h) ; CALL nl_get_end_hour(nestid,e_h) + CALL nl_get_start_minute(nestid,s_m) ; CALL nl_get_end_minute(nestid,e_m) + CALL nl_get_start_second(nestid,s_s) ; CALL nl_get_end_second(nestid,e_s) + CALL WRFU_TimeSet( nest_start,YY=s_yr,MM=s_mm,DD=s_dd,H=s_h,M=s_m,S=s_s,rc=rc) + CALL WRFU_TimeSet( nest_stop,YY=e_yr,MM=e_mm,DD=e_dd,H=e_h,M=e_m,S=e_s,rc=rc) + IF ( nest_start .LE. domain_get_current_time(head_grid) .AND. & + nest_stop .GT. domain_get_current_time(head_grid) ) THEN + DO kid = 1 , max_nests + IF ( .NOT. ASSOCIATED ( parent%nests(kid)%ptr ) ) THEN + active_domain( nestid ) = .true. + nests_to_open = .true. + RETURN + END IF + END DO + END IF + END IF + END IF + END DO +#else + nestid = 0 + kid = 0 + nests_to_open = .false. +#endif + RETURN + END FUNCTION nests_to_open + + ! Descend tree rooted at grid and set sibling pointers for + ! grids that overlap. We need some kind of global point space + ! for working this out. + + SUBROUTINE set_overlaps ( grid ) + IMPLICIT NONE + TYPE (domain), INTENT(INOUT) :: grid + ! stub + END SUBROUTINE set_overlaps + + SUBROUTINE init_module_nesting + active_domain = .FALSE. + END SUBROUTINE init_module_nesting + +END MODULE module_nesting + diff --git a/wrfv2_fire/frame/module_quilt_outbuf_ops.F b/wrfv2_fire/frame/module_quilt_outbuf_ops.F new file mode 100644 index 00000000..d9e05258 --- /dev/null +++ b/wrfv2_fire/frame/module_quilt_outbuf_ops.F @@ -0,0 +1,495 @@ +MODULE module_quilt_outbuf_ops +! +!
+! This module contains routines and data structures used by the I/O quilt 
+! servers to assemble fields ("quilting") and write them to disk.  
+!
+! + INTEGER, PARAMETER :: tabsize = 1000 + INTEGER :: num_entries + + TYPE outrec + CHARACTER*80 :: VarName, DateStr, MemoryOrder, Stagger, DimNames(3) + INTEGER :: ndim + INTEGER, DIMENSION(3) :: DomainStart, DomainEnd + INTEGER :: FieldType + REAL, POINTER, DIMENSION(:,:,:) :: rptr + INTEGER, POINTER, DIMENSION(:,:,:) :: iptr + END TYPE outrec + + TYPE(outrec), DIMENSION(tabsize) :: outbuf_table + +CONTAINS + + SUBROUTINE init_outbuf +! +!
+! This routine re-initializes module data structures.  
+!
+! + IMPLICIT NONE + INTEGER i + DO i = 1, tabsize + outbuf_table(i)%VarName = "" + outbuf_table(i)%DateStr = "" + outbuf_table(i)%MemoryOrder = "" + outbuf_table(i)%Stagger = "" + outbuf_table(i)%DimNames(1) = "" + outbuf_table(i)%DimNames(2) = "" + outbuf_table(i)%DimNames(3) = "" + outbuf_table(i)%ndim = 0 + NULLIFY( outbuf_table(i)%rptr ) + NULLIFY( outbuf_table(i)%iptr ) + ENDDO + num_entries = 0 + END SUBROUTINE init_outbuf + + + SUBROUTINE write_outbuf ( DataHandle , io_form_arg ) +! +!
+! This routine writes all of the records stored in outbuf_table to the 
+! file referenced by DataHandle using format specified by io_form_arg.  
+! This routine calls the package-specific I/O routines to accomplish 
+! the write.  
+! It then re-initializes module data structures.  
+!
+! + USE module_state_description + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle, io_form_arg + INTEGER :: ii,ds1,de1,ds2,de2,ds3,de3 + INTEGER :: Comm, IOComm, DomainDesc ! dummy + INTEGER :: Status + CHARACTER*80 :: mess + Comm = 0 ; IOComm = 0 ; DomainDesc = 0 + DO ii = 1, num_entries + WRITE(mess,*)'writing ', & + TRIM(outbuf_table(ii)%DateStr)," ", & + TRIM(outbuf_table(ii)%VarName)," ", & + TRIM(outbuf_table(ii)%MemoryOrder) + ds1 = outbuf_table(ii)%DomainStart(1) ; de1 = outbuf_table(ii)%DomainEnd(1) + ds2 = outbuf_table(ii)%DomainStart(2) ; de2 = outbuf_table(ii)%DomainEnd(2) + ds3 = outbuf_table(ii)%DomainStart(3) ; de3 = outbuf_table(ii)%DomainEnd(3) + + SELECT CASE ( io_form_arg ) + +#ifdef NETCDF + CASE ( IO_NETCDF ) + + IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN + + CALL ext_ncd_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN + CALL ext_ncd_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + + IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN + + CALL ext_yyy_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN + CALL ext_yyy_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + + IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN + + CALL ext_gr1_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN + CALL ext_gr1_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + + IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN + + CALL ext_gr2_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN + CALL ext_gr2_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN + + CALL ext_int_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN + + CALL ext_int_write_field ( DataHandle , & + TRIM(outbuf_table(ii)%DateStr), & + TRIM(outbuf_table(ii)%VarName), & + outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3), & + outbuf_table(ii)%FieldType, & !* + Comm, IOComm, DomainDesc , & + TRIM(outbuf_table(ii)%MemoryOrder), & + TRIM(outbuf_table(ii)%Stagger), & !* + outbuf_table(ii)%DimNames , & !* + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + outbuf_table(ii)%DomainStart, & + outbuf_table(ii)%DomainEnd, & + Status ) + + ENDIF +#endif + CASE DEFAULT + END SELECT + + + IF ( ASSOCIATED( outbuf_table(ii)%rptr) ) DEALLOCATE(outbuf_table(ii)%rptr) + IF ( ASSOCIATED( outbuf_table(ii)%iptr) ) DEALLOCATE(outbuf_table(ii)%iptr) + NULLIFY( outbuf_table(ii)%rptr ) + NULLIFY( outbuf_table(ii)%iptr ) + ENDDO + CALL init_outbuf + END SUBROUTINE write_outbuf + +END MODULE module_quilt_outbuf_ops + +! don't let other programs see the definition of this; type mismatches +! on inbuf will result; may want to make a module program at some point + SUBROUTINE store_patch_in_outbuf( inbuf_r, inbuf_i, DateStr, VarName , FieldType, MemoryOrder, Stagger, DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +! +!
+! This routine does the "output quilting".  
+!
+! It stores a patch in the appropriate location in a domain-sized array 
+! within an element of the outbuf_table data structure.  DateStr, VarName, and 
+! MemoryOrder are used to uniquely identify which element of outbuf_table is 
+! associated with this array.  If no element is associated, then this routine 
+! first assigns an unused element and allocates space within that element for 
+! the globally-sized array.  This routine also stores DateStr, VarName, 
+! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within 
+! the same element of outbuf.  
+!
+! + USE module_quilt_outbuf_ops + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: FieldType + REAL , DIMENSION(*) , INTENT(IN) :: inbuf_r + INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf_i + INTEGER , DIMENSION(3) , INTENT(IN) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + CHARACTER*(*) , INTENT(IN) :: DateStr , VarName, MemoryOrder , Stagger, DimNames(3) +! Local + CHARACTER*120 mess + INTEGER :: l,m,n,ii,jj + LOGICAL :: found + + ! Find the VarName if it's in the buffer already + ii = 1 + found = .false. + DO WHILE ( .NOT. found .AND. ii .LE. num_entries ) + !TBH: need to test other attributes too! + IF ( TRIM(VarName) .EQ. TRIM(outbuf_table(ii)%VarName) ) THEN + IF ( TRIM(DateStr) .EQ. TRIM(outbuf_table(ii)%DateStr) ) THEN + IF ( TRIM(MemoryOrder) .EQ. TRIM(outbuf_table(ii)%MemoryOrder) ) THEN + found = .true. + ELSE + CALL wrf_error_fatal("store_patch_in_outbuf: memory order disagreement") + ENDIF + ELSE + CALL wrf_error_fatal("store_patch_in_outbuf: multiple dates in buffer") + ENDIF + ELSE + ii = ii + 1 + ENDIF + ENDDO + IF ( .NOT. found ) THEN + num_entries = num_entries + 1 + IF ( FieldType .EQ. WRF_FLOAT ) THEN + ALLOCATE( outbuf_table(num_entries)%rptr(DomainStart(1):DomainEnd(1), & + DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + ALLOCATE( outbuf_table(num_entries)%iptr(DomainStart(1):DomainEnd(1), & + DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) ) + ELSE + write(mess,*)"store_patch_in_outbuf: unsupported type ", FieldType + CALL wrf_error_fatal(mess) + ENDIF + outbuf_table(num_entries)%VarName = TRIM(VarName) + outbuf_table(num_entries)%DateStr = TRIM(DateStr) + outbuf_table(num_entries)%MemoryOrder = TRIM(MemoryOrder) + outbuf_table(num_entries)%Stagger = TRIM(Stagger) + outbuf_table(num_entries)%DimNames(1) = TRIM(DimNames(1)) + outbuf_table(num_entries)%DimNames(2) = TRIM(DimNames(2)) + outbuf_table(num_entries)%DimNames(3) = TRIM(DimNames(3)) + outbuf_table(num_entries)%DomainStart = DomainStart + outbuf_table(num_entries)%DomainEnd = DomainEnd + outbuf_table(num_entries)%FieldType = FieldType + ii = num_entries + ENDIF + jj = 1 + IF ( FieldType .EQ. WRF_FLOAT ) THEN + DO n = PatchStart(3),PatchEnd(3) + DO m = PatchStart(2),PatchEnd(2) + DO l = PatchStart(1),PatchEnd(1) + outbuf_table(ii)%rptr(l,m,n) = inbuf_r(jj) + jj = jj + 1 + ENDDO + ENDDO + ENDDO + ENDIF + IF ( FieldType .EQ. WRF_INTEGER ) THEN + DO n = PatchStart(3),PatchEnd(3) + DO m = PatchStart(2),PatchEnd(2) + DO l = PatchStart(1),PatchEnd(1) + outbuf_table(ii)%iptr(l,m,n) = inbuf_i(jj) + jj = jj + 1 + ENDDO + ENDDO + ENDDO + ENDIF + + RETURN + + END SUBROUTINE store_patch_in_outbuf + +!call add_to_bufsize_for_field( VarName, hdrbufsize+chunksize ) + + SUBROUTINE add_to_bufsize_for_field( VarName, Nbytes ) +! +!
+! This routine is a wrapper for C routine add_to_bufsize_for_field_c() that 
+! is used to accumulate buffer sizes.  Buffer size Nbytes is added to the 
+! curent buffer size for the buffer named VarName.  Any buffer space 
+! associated with VarName is freed.  If a buffer named VarName does not exist, 
+! a new one is assigned and its size is set to Nbytes.  
+!
+! + USE module_quilt_outbuf_ops + IMPLICIT NONE + CHARACTER*(*) , INTENT(IN) :: VarName + INTEGER , INTENT(IN) :: Nbytes +! Local + CHARACTER*120 mess + INTEGER :: i, ierr + INTEGER :: VarNameAsInts( 256 ) + VarNameAsInts( 1 ) = len(trim(VarName)) + DO i = 2, len(trim(VarName)) + 1 + VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) ) + ENDDO + CALL add_to_bufsize_for_field_c ( VarNameAsInts, Nbytes ) + RETURN + END SUBROUTINE add_to_bufsize_for_field + + SUBROUTINE store_piece_of_field( inbuf, VarName, Nbytes ) +! +!
+! This routine is a wrapper for C routine store_piece_of_field_c() that 
+! is used to store pieces of a field in an internal buffer.  Nbytes bytes of 
+! buffer inbuf are appended to the end of the internal buffer named VarName.  
+! An error occurs if either an internal buffer named VarName does not exist or 
+! if there are fewer than Nbytes bytes left in the internal buffer.  
+!
+! + USE module_quilt_outbuf_ops + IMPLICIT NONE + INTEGER , INTENT(IN) :: Nbytes + INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf + CHARACTER*(*) , INTENT(IN) :: VarName +! Local + CHARACTER*120 mess + INTEGER :: i, ierr + INTEGER :: VarNameAsInts( 256 ) + + VarNameAsInts( 1 ) = len(trim(VarName)) + DO i = 2, len(trim(VarName)) + 1 + VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) ) + ENDDO + CALL store_piece_of_field_c ( inbuf, VarNameAsInts, Nbytes, ierr ) + IF ( ierr .NE. 0 ) CALL wrf_error_fatal ( "store_piece_of_field" ) + RETURN + END SUBROUTINE store_piece_of_field + + SUBROUTINE retrieve_pieces_of_field( outbuf, VarName, obufsz, Nbytes_tot, lret ) +! +!
+! This routine is a wrapper for C routine retrieve_pieces_of_field_c() that 
+! is used to extract the entire contents (i.e. all previously stored pieces of 
+! fields) of the next internal buffer.  The name associated with this internal 
+! buffer is returned in VarName.  The number of bytes read is returned in 
+! Nbytes_tot.  Bytes are stored in outbuf whose size (in bytes) is obufsz.  
+! If there are more than obufsz bytes left in the next internal buffer, then 
+! only obufsz bytes are returned and the rest are discarded (probably an error 
+! in the making!).  The internal buffer is then freed.  Flag lret is set to 
+! .TRUE. iff there are more fields left to extract.  
+!
+! + USE module_quilt_outbuf_ops + IMPLICIT NONE + INTEGER , INTENT(IN) :: obufsz + INTEGER , INTENT(OUT) :: Nbytes_tot + INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf + CHARACTER*(*) , INTENT(OUT) :: VarName + LOGICAL :: lret ! true if more, false if not +! Local + CHARACTER*120 mess + INTEGER :: i, iret + INTEGER :: VarNameAsInts( 256 ) + + CALL retrieve_pieces_of_field_c ( outbuf, VarNameAsInts, obufsz, Nbytes_tot, iret ) + IF ( iret .NE. 0 ) THEN + lret = .FALSE. + ELSE + lret = .TRUE. + VarName = ' ' + DO i = 2, VarNameAsInts(1) + 1 + VarName(i-1:i-1) = CHAR(VarNameAsInts( i )) + ENDDO + ENDIF + RETURN + END SUBROUTINE retrieve_pieces_of_field + diff --git a/wrfv2_fire/frame/module_sm.F b/wrfv2_fire/frame/module_sm.F new file mode 100644 index 00000000..f37593a7 --- /dev/null +++ b/wrfv2_fire/frame/module_sm.F @@ -0,0 +1,55 @@ +!WRF:PACKAGE:OPENMP +! + +MODULE module_sm + +#ifdef _OPENMP + + ! There are a few functions in the OpenMP library, + ! and to use them easily, we need to define the + ! return types of these functions. + + INTEGER , EXTERNAL :: omp_get_num_threads , & + omp_get_max_threads , & + omp_get_thread_num , & + omp_get_num_procs + + LOGICAL , EXTERNAL :: omp_in_parallel +#endif + +CONTAINS + + SUBROUTINE omp_info + +#ifdef _OPENMP + + IMPLICIT NONE + + PRINT '(/A,/,A,/,A,I2/)','omp_get_num_threads:', & + 'Number of threads currently in the team executing', & + 'the parallel region = ',omp_get_num_threads() + + PRINT '(A,/,A,/,A,I2/)', 'omp_get_max_threads:', & + 'Maximum value that can be returned by the',& + 'omp_get_num_threads function = ',omp_get_max_threads() + + PRINT '(A,/,A,/,A,I2/)', 'omp_get_thread_num:', & + 'Returns the thread number, within the team, between', & + '0 and omp_get_num_threads-1, inclusive = ',omp_get_thread_num() + + PRINT '(A,/,A,/,A,I2/)', 'omp_get_num_procs:', & + 'Returns the number of processors that are available', & + 'to the program = ',omp_get_num_procs() + + PRINT '(A,/,A,/,A,L7/)','omp_in_parallel:', & + 'Returns .TRUE. if called with the dynamic extent of a region', & + 'executing in parallel, and otherwise .FALSE. = ',omp_in_parallel() + +#endif + + END SUBROUTINE omp_info + + SUBROUTINE init_module_sm + END SUBROUTINE init_module_sm + +END MODULE module_sm diff --git a/wrfv2_fire/frame/module_tiles.F b/wrfv2_fire/frame/module_tiles.F new file mode 100644 index 00000000..0830fbce --- /dev/null +++ b/wrfv2_fire/frame/module_tiles.F @@ -0,0 +1,425 @@ +!WRF:DRIVER_LAYER:TILING +! + +MODULE module_tiles + + USE module_configure + + INTERFACE set_tiles + MODULE PROCEDURE set_tiles1 , set_tiles2, set_tiles3 + END INTERFACE + +CONTAINS + +! CPP macro for error checking +#define ERROR_TEST(A,O,B) IF( A O B )THEN;WRITE(mess,'(3A4)')'A','O','B';CALL WRF_ERROR_FATAL(mess);ENDIF + +! this version is used to compute only on a boundary of some width +! The ids, ide, jds, and jde arguments specify the edge of the boundary (a way of +! accounting for staggering, and the bdyw gives the number of cells +! (idea: if bdyw is negative, have it do the reverse and specify the +! interior, less the boundary. + + SUBROUTINE set_tiles1 ( grid , ids , ide , jds , jde , bdyw ) + + USE module_domain + USE module_driver_constants + USE module_machine + USE module_wrf_error + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , INTENT(INOUT) :: grid + INTEGER , INTENT(IN) :: ids , ide , jds , jde , bdyw + + ! Local data + + INTEGER :: spx, epx, spy, epy, t, tt, ts, te + INTEGER :: smx, emx, smy, emy + INTEGER :: ntiles , num_tiles + + CHARACTER*80 :: mess + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp32 ; epy = grid%ep32 + CASE ( DATA_ORDER_YXZ ) + spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp31 ; epy = grid%ep31 + CASE ( DATA_ORDER_ZXY ) + spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp33 ; epy = grid%ep33 + CASE ( DATA_ORDER_ZYX ) + spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp32 ; epy = grid%ep32 + CASE ( DATA_ORDER_XZY ) + spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp33 ; epy = grid%ep33 + CASE ( DATA_ORDER_YZX ) + spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp31 ; epy = grid%ep31 + END SELECT data_ordering + + num_tiles = 4 + + IF ( num_tiles > grid%max_tiles ) THEN + IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF + IF ( ASSOCIATED(grid%i_end) ) THEN ; DEALLOCATE( grid%i_end ) ; NULLIFY( grid%i_end ) ; ENDIF + IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF + IF ( ASSOCIATED(grid%j_end) ) THEN ; DEALLOCATE( grid%j_end ) ; NULLIFY( grid%j_end ) ; ENDIF + ALLOCATE(grid%i_start(num_tiles)) + ALLOCATE(grid%i_end(num_tiles)) + ALLOCATE(grid%j_start(num_tiles)) + ALLOCATE(grid%j_end(num_tiles)) + grid%max_tiles = num_tiles + ENDIF + +! XS boundary + IF ( ids .ge. spx .and. ids .le. epx ) THEN + grid%i_start(1) = ids + grid%i_end(1) = min( ids+bdyw-1 , epx ) + grid%j_start(1) = max( spy , jds ) + grid%j_end(1) = min( epy , jde ) + ELSEIF ( (ids+bdyw-1) .ge. spx .and. (ids+bdyw-1) .le. epx ) THEN + grid%i_start(1) = max( ids , spx ) + grid%i_end(1) = ids+bdyw-1 + grid%j_start(1) = max( spy , jds ) + grid%j_end(1) = min( epy , jde ) + ELSE + grid%i_start(1) = 1 + grid%i_end(1) = -1 + grid%j_start(1) = 1 + grid%j_end(1) = -1 + ENDIF + +! XE boundary + IF ( ide .ge. spx .and. ide .le. epx ) THEN + grid%i_start(2) = max( ide-bdyw+1 , spx ) + grid%i_end(2) = ide + grid%j_start(2) = max( spy , jds ) + grid%j_end(2) = min( epy , jde ) + ELSEIF ( (ide-bdyw+1) .ge. spx .and. (ide-bdyw+1) .le. epx ) THEN + grid%i_start(2) = ide-bdyw+1 + grid%i_end(2) = min( ide , epx ) + grid%j_start(2) = max( spy , jds ) + grid%j_end(2) = min( epy , jde ) + ELSE + grid%i_start(2) = 1 + grid%i_end(2) = -1 + grid%j_start(2) = 1 + grid%j_end(2) = -1 + ENDIF + +! YS boundary (note that the corners may already be done by XS and XE) + IF ( jds .ge. spy .and. jds .le. epy ) THEN + grid%j_start(3) = jds + grid%j_end(3) = min( jds+bdyw-1 , epy ) + grid%i_start(3) = max( spx , ids+bdyw ) + grid%i_end(3) = min( epx , ide-bdyw ) + ELSEIF ( (jds+bdyw-1) .ge. spy .and. (jds+bdyw-1) .le. epy ) THEN + grid%j_start(3) = max( jds , spy ) + grid%j_end(3) = jds+bdyw-1 + grid%i_start(3) = max( spx , ids+bdyw ) + grid%i_end(3) = min( epx , ide-bdyw ) + ELSE + grid%j_start(3) = 1 + grid%j_end(3) = -1 + grid%i_start(3) = 1 + grid%i_end(3) = -1 + ENDIF + +! YE boundary (note that the corners may already be done by XS and XE) + IF ( jde .ge. spy .and. jde .le. epy ) THEN + grid%j_start(4) = max( jde-bdyw+1 , spy ) + grid%j_end(4) = jde + grid%i_start(4) = max( spx , ids+bdyw ) + grid%i_end(4) = min( epx , ide-bdyw ) + ELSEIF ( (jde-bdyw+1) .ge. spy .and. (jde-bdyw+1) .le. epy ) THEN + grid%j_start(4) = jde-bdyw+1 + grid%j_end(4) = min( jde , epy ) + grid%i_start(4) = max( spx , ids+bdyw ) + grid%i_end(4) = min( epx , ide-bdyw ) + ELSE + grid%j_start(4) = 1 + grid%j_end(4) = -1 + grid%i_start(4) = 1 + grid%i_end(4) = -1 + ENDIF + + grid%num_tiles = num_tiles + + RETURN + END SUBROUTINE set_tiles1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! this version is used to limit the domain or compute onto halos + SUBROUTINE set_tiles2 ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe ) + USE module_domain + USE module_driver_constants + USE module_machine + USE module_wrf_error + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , INTENT(INOUT) :: grid + INTEGER , INTENT(IN) :: ids , ide , jds , jde + INTEGER , INTENT(IN) :: ips , ipe , jps , jpe + + ! Output data. + + ! Local data. + + INTEGER :: num_tiles_x, num_tiles_y, num_tiles + INTEGER :: tile_sz_x, tile_sz_y + INTEGER :: spx, epx, spy, epy, t, tt, ts, te + INTEGER :: smx, emx, smy, emy + INTEGER :: ntiles + INTEGER :: one +#ifdef _OPENMP + INTEGER , EXTERNAL :: omp_get_max_threads +#endif + CHARACTER*80 :: mess + + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp32 ; epy = grid%ep32 + smx = grid%sm31 ; emx = grid%em31 ; smy = grid%sm32 ; emy = grid%em32 + CASE ( DATA_ORDER_YXZ ) + spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp31 ; epy = grid%ep31 + smx = grid%sm32 ; emx = grid%em32 ; smy = grid%sm31 ; emy = grid%em31 + CASE ( DATA_ORDER_ZXY ) + spx = grid%sp32 ; epx = grid%ep32 ; spy = grid%sp33 ; epy = grid%ep33 + smx = grid%sm32 ; emx = grid%em32 ; smy = grid%sm33 ; emy = grid%em33 + CASE ( DATA_ORDER_ZYX ) + spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp32 ; epy = grid%ep32 + smx = grid%sm33 ; emx = grid%em33 ; smy = grid%sm32 ; emy = grid%em32 + CASE ( DATA_ORDER_XZY ) + spx = grid%sp31 ; epx = grid%ep31 ; spy = grid%sp33 ; epy = grid%ep33 + smx = grid%sm31 ; emx = grid%em31 ; smy = grid%sm33 ; emy = grid%em33 + CASE ( DATA_ORDER_YZX ) + spx = grid%sp33 ; epx = grid%ep33 ; spy = grid%sp31 ; epy = grid%ep31 + smx = grid%sm33 ; emx = grid%em33 ; smy = grid%sm31 ; emy = grid%em31 + END SELECT data_ordering + + ERROR_TEST(ips,<,smx) + ERROR_TEST(ipe,>,emx) + ERROR_TEST(jps,<,smy) + ERROR_TEST(jpe,>,emy) + + ! Here's how the number of tiles is arrived at: + ! + ! if tile sizes are specified use those otherwise + ! if num_tiles is specified use that otherwise + ! if omp provides a value use that otherwise + ! use 1. + ! + + IF ( grid%num_tiles_spec .EQ. 0 ) THEN + CALL nl_get_numtiles( 1, num_tiles ) + IF ( num_tiles .EQ. 1 ) THEN +#ifdef _OPENMP + num_tiles = omp_get_max_threads() + WRITE(mess,'("WRF NUMBER OF TILES FROM OMP_GET_MAX_THREADS = ",I3)')num_tiles + CALL WRF_MESSAGE ( mess ) +#else + num_tiles = 1 +#endif + ENDIF +! override num_tiles setting (however gotten) if tile sizes are specified + CALL nl_get_tile_sz_x( 1, tile_sz_x ) + CALL nl_get_tile_sz_y( 1, tile_sz_y ) + IF ( tile_sz_x >= 1 .and. tile_sz_y >= 1 ) THEN + ! figure number of whole tiles and add 1 for any partials in each dim + num_tiles_x = (epx-spx+1) / tile_sz_x + if ( tile_sz_x*num_tiles_x < epx-spx+1 ) num_tiles_x = num_tiles_x + 1 + num_tiles_y = (epy-spy+1) / tile_sz_y + if ( tile_sz_y*num_tiles_y < epy-spy+1 ) num_tiles_y = num_tiles_y + 1 + num_tiles = num_tiles_x * num_tiles_y + ELSE + IF ( machine_info%tile_strategy == TILE_X ) THEN + num_tiles_x = num_tiles + num_tiles_y = 1 + ELSE IF ( machine_info%tile_strategy == TILE_Y ) THEN + num_tiles_x = 1 + num_tiles_y = num_tiles + ELSE ! Default ( machine_info%tile_strategy == TILE_XY ) THEN + one = 1 + call least_aspect( num_tiles, one, one, num_tiles_y, num_tiles_x ) + ENDIF + ENDIF + grid%num_tiles_spec = num_tiles + grid%num_tiles_x = num_tiles_x + grid%num_tiles_y = num_tiles_y + WRITE(mess,'("WRF NUMBER OF TILES = ",I3)')num_tiles + CALL WRF_MESSAGE ( mess ) + ENDIF + + num_tiles = grid%num_tiles_spec + num_tiles_x = grid%num_tiles_x + num_tiles_y = grid%num_tiles_y + + IF ( num_tiles > grid%max_tiles ) THEN + IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF + IF ( ASSOCIATED(grid%i_end) ) THEN ; DEALLOCATE( grid%i_end ) ; NULLIFY( grid%i_end ) ; ENDIF + IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF + IF ( ASSOCIATED(grid%j_end) ) THEN ; DEALLOCATE( grid%j_end ) ; NULLIFY( grid%j_end ) ; ENDIF + ALLOCATE(grid%i_start(num_tiles)) + ALLOCATE(grid%i_end(num_tiles)) + ALLOCATE(grid%j_start(num_tiles)) + ALLOCATE(grid%j_end(num_tiles)) + grid%max_tiles = num_tiles + ENDIF + + DO t = 0, num_tiles-1 + ntiles = mod(t,num_tiles_x) + CALL region_bounds( spx, epx, & + num_tiles_x, ntiles, & + ts, te ) +!!! +! This bit allows the user to specify execution out onto the halo region +! in the call to set_tiles. If the low patch boundary specified by the arguments +! is less than what the model already knows to be the patch boundary and if +! the user hasn't erred by specifying something that would fall off memory +! (safety tests are higher up in this routine, outside the IF) then adjust +! the tile boundary of the low edge tiles accordingly. Likewise for high edges. + IF ( ips .lt. spx .and. ts .eq. spx ) ts = ips ; + IF ( ipe .gt. epx .and. te .eq. epx ) te = ipe ; +!!! + grid%i_start(t+1) = max ( ts , ids ) + grid%i_end(t+1) = min ( te , ide ) + ntiles = t / num_tiles_x + CALL region_bounds( spy, epy, & + num_tiles_y, ntiles, & + ts, te ) +! + IF ( jps .lt. spy .and. ts .eq. spy ) ts = jps ; + IF ( jpe .gt. epy .and. te .eq. epy ) te = jpe ; +! + grid%j_start(t+1) = max ( ts , jds ) + grid%j_end(t+1) = min ( te , jde ) + END DO + grid%num_tiles = num_tiles + + RETURN + END SUBROUTINE set_tiles2 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! this version sets the tiles based on a passed in integer mask +! the assumption here is that the mask is relatively straigthforward +! and coverable with 2 or three rectangles. No weird stuff... + + SUBROUTINE set_tiles3 ( grid , imask, ims, ime, jms, jme, ips, ipe, jps, jpe ) + USE module_domain + USE module_driver_constants + USE module_machine + USE module_wrf_error + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , INTENT(INOUT) :: grid + INTEGER , INTENT(IN) :: ims , ime , jms , jme + INTEGER , INTENT(IN) :: ips , ipe , jps , jpe + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: imask + INTEGER :: num_tiles + INTEGER, DIMENSION(50) :: i_start, i_end, j_start, j_end + + ! Output data. + + ! Local data. + + CHARACTER*80 :: mess + + CALL set_tiles_masked ( imask, ims, ime, jms, jme, ips, ipe, jps, jpe, & + num_tiles, i_start, i_end, j_start, j_end ) + + IF ( num_tiles > grid%max_tiles ) THEN + IF ( ASSOCIATED(grid%i_start) ) THEN ; DEALLOCATE( grid%i_start ) ; NULLIFY( grid%i_start ) ; ENDIF + IF ( ASSOCIATED(grid%i_end) ) THEN ; DEALLOCATE( grid%i_end ) ; NULLIFY( grid%i_end ) ; ENDIF + IF ( ASSOCIATED(grid%j_start) ) THEN ; DEALLOCATE( grid%j_start ) ; NULLIFY( grid%j_start ) ; ENDIF + IF ( ASSOCIATED(grid%j_end) ) THEN ; DEALLOCATE( grid%j_end ) ; NULLIFY( grid%j_end ) ; ENDIF + ALLOCATE(grid%i_start(num_tiles)) + ALLOCATE(grid%i_end(num_tiles)) + ALLOCATE(grid%j_start(num_tiles)) + ALLOCATE(grid%j_end(num_tiles)) + grid%max_tiles = num_tiles + ENDIF + grid%num_tiles = num_tiles + grid%i_start(1:num_tiles) = i_start(1:num_tiles) + grid%i_end(1:num_tiles) = i_end(1:num_tiles) + grid%j_start(1:num_tiles) = j_start(1:num_tiles) + grid%j_end(1:num_tiles) = j_end(1:num_tiles) + + RETURN + END SUBROUTINE set_tiles3 + + SUBROUTINE set_tiles_masked ( imask, ims, ime, jms, jme, ips, ipe, jps, jpe, & + num_tiles, istarts, iends, jstarts, jends ) + + IMPLICIT NONE + + ! Arguments + + INTEGER , INTENT(IN) :: ims , ime , jms , jme + INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: imask + INTEGER , INTENT(IN) :: ips , ipe , jps , jpe + INTEGER , INTENT(OUT) :: num_tiles + INTEGER, DIMENSION(*) , INTENT(OUT) :: istarts, iends + INTEGER, DIMENSION(*) , INTENT(OUT) :: jstarts, jends + + ! Output data. + + ! Local data. + CHARACTER*80 :: mess + INTEGER :: i, j, ir, jr + INTEGER :: imaskcopy(ips:ipe,jps:jpe) ! copy of imask to write on + + imaskcopy = imask(ips:ipe,jps:jpe) + num_tiles = 0 + ! simple multi-pass scheme, optimize later... + DO WHILE (ANY(imaskcopy == 1)) + DO j = jps,jpe + DO i = ips,ipe + ! find first "1" and build a rectangle from it + IF ( imaskcopy(i,j) == 1 ) THEN + num_tiles = num_tiles + 1 + istarts(num_tiles) = i + iends(num_tiles) = i + jstarts(num_tiles) = j + jends(num_tiles) = j + ! don't check this point again + imaskcopy(i,j) = 0 + ! find length of first row + DO ir = istarts(num_tiles)+1,ipe + IF ( imaskcopy(ir,j) == 1 ) THEN + iends(num_tiles) = ir + ! don't check this point again + imaskcopy(ir,j) = 0 + ELSE + EXIT + ENDIF + ENDDO + ! find number of rows + DO jr = jstarts(num_tiles)+1,jpe + IF (ALL(imaskcopy(istarts(num_tiles):iends(num_tiles),jr) == 1)) THEN + jends(num_tiles) = jr + ! don't check these points again + imaskcopy(istarts(num_tiles):iends(num_tiles),jr) = 0 + ELSE + EXIT + ENDIF + ENDDO + ENDIF ! if ( imaskcopy(i,j) == 1 ) + ENDDO + ENDDO + ENDDO + RETURN + END SUBROUTINE set_tiles_masked + + + SUBROUTINE init_module_tiles + END SUBROUTINE init_module_tiles + +END MODULE module_tiles + diff --git a/wrfv2_fire/frame/module_timing.F b/wrfv2_fire/frame/module_timing.F new file mode 100644 index 00000000..90c25641 --- /dev/null +++ b/wrfv2_fire/frame/module_timing.F @@ -0,0 +1,72 @@ +!WRF:DRIVER_LAYER:UTIL +! + +MODULE module_timing + + INTEGER, PARAMETER, PRIVATE :: cnmax = 30 + INTEGER, PRIVATE, DIMENSION(cnmax) :: count_int1 , count_rate_int1 , count_max_int1 + INTEGER, PRIVATE, DIMENSION(cnmax) :: count_int2 , count_rate_int2 , count_max_int2 + INTEGER, PRIVATE :: cn = 0 + REAL, PRIVATE :: elapsed_seconds , elapsed_seconds_total = 0 + REAL, PRIVATE :: cpu_1 , cpu_2 , cpu_seconds , cpu_seconds_total = 0 + +CONTAINS + + SUBROUTINE init_module_timing + cn = 0 + END SUBROUTINE init_module_timing + + + SUBROUTINE start_timing + + IMPLICIT NONE + + cn = cn + 1 + IF ( cn .gt. cnmax ) THEN + CALL wrf_error_fatal( 'module_timing: clock nesting error (too many nests)' ) + RETURN + ENDIF + CALL SYSTEM_CLOCK ( count_int1(cn) , count_rate_int1(cn) , count_max_int1(cn) ) +! CALL CPU_TIME ( cpu_1 ) + + END SUBROUTINE start_timing + + + SUBROUTINE end_timing ( string ) + + IMPLICIT NONE + + CHARACTER *(*) :: string + + IF ( cn .lt. 1 ) THEN + CALL wrf_error_fatal( 'module_timing: clock nesting error, cn<1' ) + ELSE IF ( cn .gt. cnmax ) THEN + CALL wrf_error_fatal( 'module_timing: clock nesting error, cn>cnmax' ) + ENDIF + + CALL SYSTEM_CLOCK ( count_int2(cn) , count_rate_int2(cn) , count_max_int2(cn) ) +! CALL CPU_TIME ( cpu_2 ) + + IF ( count_int2(cn) < count_int1(cn) ) THEN + count_int2(cn) = count_int2(cn) + count_max_int2(cn) + ENDIF + + count_int2(cn) = count_int2(cn) - count_int1(cn) + elapsed_seconds = REAL(count_int2(cn)) / REAL(count_rate_int2(cn)) + elapsed_seconds_total = elapsed_seconds_total + elapsed_seconds + + WRITE(6,'(A,A,A,F10.5,A)') 'Timing for ',TRIM(string),': ',elapsed_seconds,' elapsed seconds.' +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + WRITE(0,'(A,A,A,F10.5,A)') 'Timing for ',TRIM(string),': ',elapsed_seconds,' elapsed seconds.' +#endif + +! cpu_seconds = cpu_2 - cpu_1 +! cpu_seconds_total = cpu_seconds_total + cpu_seconds +! PRINT '(A,A,A,F10.5,A)' ,'Timing for ',TRIM(string),': ',cpu_seconds,' cpu seconds.' + + cn = cn - 1 + + END SUBROUTINE end_timing + +END MODULE module_timing + diff --git a/wrfv2_fire/frame/module_wrf_error.F b/wrfv2_fire/frame/module_wrf_error.F new file mode 100644 index 00000000..38cce1e6 --- /dev/null +++ b/wrfv2_fire/frame/module_wrf_error.F @@ -0,0 +1,93 @@ +!WRF:DRIVER_LAYER:UTIL +! + +MODULE module_wrf_error + INTEGER :: wrf_debug_level = 0 + CHARACTER*256 :: wrf_err_message +CONTAINS + + LOGICAL FUNCTION wrf_at_debug_level ( level ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: level + wrf_at_debug_level = ( level .LE. wrf_debug_level ) + RETURN + END FUNCTION wrf_at_debug_level + + SUBROUTINE init_module_wrf_error + END SUBROUTINE init_module_wrf_error + +END MODULE module_wrf_error + +SUBROUTINE wrf_message( str ) + IMPLICIT NONE + CHARACTER*(*) str +#if defined( DM_PARALLEL ) && ! defined( STUBMPI) + write(0,*) TRIM(str) +#endif + print*, TRIM(str) +END SUBROUTINE wrf_message + +! intentionally write to stderr only +SUBROUTINE wrf_message2( str ) + IMPLICIT NONE + CHARACTER*(*) str + write(0,*) str +END SUBROUTINE wrf_message2 + +SUBROUTINE wrf_error_fatal3( file_str, line, str ) + USE module_wrf_error + IMPLICIT NONE + CHARACTER*(*) file_str + INTEGER , INTENT (IN) :: line ! only print file and line if line > 0 + CHARACTER*(*) str + CHARACTER*256 :: line_str + + write(line_str,'(i6)') line +#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) + CALL wrf_message( '-------------- FATAL CALLED ---------------' ) + ! only print file and line if line is positive + IF ( line > 0 ) THEN + CALL wrf_message( 'FATAL CALLED FROM FILE: '//file_str//' LINE: '//TRIM(line_str) ) + ENDIF + CALL wrf_message( str ) + CALL wrf_message( '-------------------------------------------' ) +#else + CALL wrf_message2( '-------------- FATAL CALLED ---------------' ) + ! only print file and line if line is positive + IF ( line > 0 ) THEN + CALL wrf_message( 'FATAL CALLED FROM FILE: '//file_str//' LINE: '//TRIM(line_str) ) + ENDIF + CALL wrf_message2( str ) + CALL wrf_message2( '-------------------------------------------' ) +#endif + CALL wrf_abort +END SUBROUTINE wrf_error_fatal3 + +SUBROUTINE wrf_error_fatal( str ) + USE module_wrf_error + IMPLICIT NONE + CHARACTER*(*) str + CALL wrf_error_fatal3 ( ' ', 0, str ) +END SUBROUTINE wrf_error_fatal + +! Check to see if expected value == actual value +! If not, print message and exit. +SUBROUTINE wrf_check_error( expected, actual, str, file_str, line ) + USE module_wrf_error + IMPLICIT NONE + INTEGER , INTENT (IN) :: expected + INTEGER , INTENT (IN) :: actual + CHARACTER*(*) str + CHARACTER*(*) file_str + INTEGER , INTENT (IN) :: line + CHARACTER (LEN=512) :: rc_str + CHARACTER (LEN=512) :: str_with_rc + + IF ( expected .ne. actual ) THEN + WRITE (rc_str,*) ' Routine returned error code = ',actual + str_with_rc = TRIM(str // rc_str) + CALL wrf_error_fatal3 ( file_str, line, str_with_rc ) + ENDIF +END SUBROUTINE wrf_check_error + + diff --git a/wrfv2_fire/frame/pack_utils.c b/wrfv2_fire/frame/pack_utils.c new file mode 100644 index 00000000..46279c47 --- /dev/null +++ b/wrfv2_fire/frame/pack_utils.c @@ -0,0 +1,250 @@ +#include +#include +#include + +#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 +# 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__ +# 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_ +# endif +# endif +#endif + +/* CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */ + +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 ) { + fprintf(stderr,"frame/pack_utils.c: field (%s) not found; was not set up with add_to_bufsize_for_field\n",vname ) ; + *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] ) { + fprintf(stderr, +"frame/pack_utils.c: %s would overwrite %d + %d > %d [%d]\n",vname, fld_curs[found], *chunksize, fld_bufsize[found], found ) ; + *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 ) { + if ( fld_curs[fld] > *insize ) { + fprintf(stderr,"retrieve: fld_curs[%d] (%d) > *insize (%d)\n",fld,fld_curs[fld], *insize ) ; + } + *outsize = ( fld_curs[fld] <= *insize ) ? fld_curs[fld] : *insize ; + varname[0] = (int) strlen( fld_name[fld] ) ; + for ( i = 1 ; i <= varname[0] ; i++ ) varname[i] = fld_name[fld][i-1] ; + for ( i = 0 ; i < *outsize ; i++ ) buf[i] = fld_cache[fld][i] ; + 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]-1 ; k <= pe[2]-1 ; k++ ) + for ( j = ps[1]-1 ; j <= pe[1]-1 ; j++ ) + for ( i = ps[0]-1 ; i <= pe[0]-1 ; 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) ; +} diff --git a/wrfv2_fire/frame/wrf_debug.F b/wrfv2_fire/frame/wrf_debug.F new file mode 100644 index 00000000..2a693b30 --- /dev/null +++ b/wrfv2_fire/frame/wrf_debug.F @@ -0,0 +1,43 @@ +SUBROUTINE set_wrf_debug_level ( level ) + USE module_wrf_error + IMPLICIT NONE + INTEGER , INTENT(IN) :: level + wrf_debug_level = level + RETURN +END SUBROUTINE set_wrf_debug_level + +SUBROUTINE get_wrf_debug_level ( level ) + USE module_wrf_error + IMPLICIT NONE + INTEGER , INTENT(OUT) :: level + level = wrf_debug_level + RETURN +END SUBROUTINE get_wrf_debug_level + +SUBROUTINE wrf_debug( level , str ) + USE module_wrf_error + IMPLICIT NONE + CHARACTER*(*) str + INTEGER , INTENT (IN) :: level + INTEGER :: debug_level + CHARACTER (LEN=256) :: time_str + CHARACTER (LEN=256) :: grid_str + CHARACTER (LEN=512) :: out_str + CALL get_wrf_debug_level( debug_level ) + IF ( level .LE. debug_level ) THEN +#ifdef _OPENMP + ! old behavior + CALL wrf_message( str ) +#else + ! TBH: This fails on pgf90 6.1-4 when built with OpenMP and using more + ! TBH: than one thread. It works fine multi-threaded on AIX with xlf + ! TBH: 10.1.0.0 . Hence the cpp nastiness. + ! new behavior: include domain name and time-stamp + CALL get_current_time_string( time_str ) + CALL get_current_grid_name( grid_str ) + out_str = TRIM(grid_str)//' '//TRIM(time_str)//' '//TRIM(str) + CALL wrf_message( TRIM(out_str) ) +#endif + ENDIF + RETURN +END SUBROUTINE wrf_debug diff --git a/wrfv2_fire/frame/wrf_num_bytes_between.c b/wrfv2_fire/frame/wrf_num_bytes_between.c new file mode 100644 index 00000000..05315ae4 --- /dev/null +++ b/wrfv2_fire/frame/wrf_num_bytes_between.c @@ -0,0 +1,79 @@ +#include + +#ifndef CRAY +# ifdef NOUNDERSCORE +# define WRF_NUM_BYTES_BETWEEN wrf_num_bytes_between +# define GET_INITIAL_DATA_VALUE get_initial_data_value +# define WHAT_IS_A_NAN what_is_a_nan +# define WRF_MEM_COPY wrf_mem_copy +# else +# ifdef F2CSTYLE +# define WRF_NUM_BYTES_BETWEEN wrf_num_bytes_between__ +# define GET_INITIAL_DATA_VALUE get_initial_data_value__ +# define WHAT_IS_A_NAN what_is_a_nan__ +# define WRF_MEM_COPY wrf_mem_copy__ +# else +# define WRF_NUM_BYTES_BETWEEN wrf_num_bytes_between_ +# define GET_INITIAL_DATA_VALUE get_initial_data_value_ +# define WHAT_IS_A_NAN what_is_a_nan_ +# define WRF_MEM_COPY wrf_mem_copy_ +# endif +# endif +#endif + +WRF_NUM_BYTES_BETWEEN ( a , b , n ) + char * a ; + char * b ; + int * n ; +{ + *n = a - b ; + if ( *n < 0 ) *n = -(*n) ; +} + +/*#define NAN_VALUE */ +#ifdef NAN_VALUE +GET_INITIAL_DATA_VALUE ( n ) + int * n ; +{ + *n = 0xffc00000 ; +} +#else +GET_INITIAL_DATA_VALUE ( n ) + float * n ; +{ + *n = 0. ; +} +#endif + +WHAT_IS_A_NAN ( n ) + int * n ; +{ + *n = 0xffc00000 ; +#if 0 +*n = 0. ; +fprintf(stderr,"WHAT_IS_NAN disabled\n") ; +#endif +} + +/* SUBROUTINE wrf_mem_copy( a, b, n ) + INTEGER*1, INTENT (INOUT) :: a(*), b(*) + INTEGER, INTENT (IN) :: n + INTEGER :: i + DO i = 1, n + b(i) = a(i) + ENDDO + RETURN + END SUBROUTINE wrf_mem_copy */ + +WRF_MEM_COPY ( a , b, n ) + char * a ; + char * b ; + int * n ; +{ + int i ; + for ( i = 0 ; i < *n ; i++ ) + { + *b++ = *a++ ; + } +} + diff --git a/wrfv2_fire/frame/wrf_shutdown.F b/wrfv2_fire/frame/wrf_shutdown.F new file mode 100644 index 00000000..0fab4a40 --- /dev/null +++ b/wrfv2_fire/frame/wrf_shutdown.F @@ -0,0 +1,15 @@ +!WRF:DRIVER_LAYER:UTIL +! +SUBROUTINE wrf_shutdown +#ifdef DM_PARALLEL + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + EXTERNAL wrf_dm_shutdown +#endif +#ifdef DM_PARALLEL + CALL wrf_dm_shutdown +#else + STOP +#endif +END SUBROUTINE wrf_shutdown + diff --git a/wrfv2_fire/frame/xxx_template_ioapi.F b/wrfv2_fire/frame/xxx_template_ioapi.F new file mode 100644 index 00000000..4b672d8e --- /dev/null +++ b/wrfv2_fire/frame/xxx_template_ioapi.F @@ -0,0 +1,763 @@ +! +! This is a template for adding a package-dependent implemetnation of +! the I/O API. You can use the name xxx since that is already set up +! as a placeholder in module_io.F, md_calls.m4, and the Registry, or +! you can change the name here and in those other places. For additional +! information on adding a package to WRF, see the latest version of the +! WRF Design and Implementation Document 1.1 (Draft). June 21, 2001 +! + +!--- ioinit +SUBROUTINE ext_xxx_ioinit( SysDepInfo,Status ) + IMPLICIT NONE + CHARACTER (LEN=80), INTENT(IN) :: SysDepInfo + INTEGER, INTENT(INOUT) :: Status + RETURN +END SUBROUTINE ext_xxx_ioinit + +SUBROUTINE ext_xxx_inquiry( Inquiry, Result,Status ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: Inquiry + CHARACTER *(*), INTENT(OUT) :: Result + INTEGER, INTENT(INOUT) :: Status + RETURN +END SUBROUTINE ext_xxx_inquiry + +!--- ioexit +SUBROUTINE ext_xxx_ioexit( Status ) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: Status + RETURN +END SUBROUTINE + +!--- open_for_write_begin +SUBROUTINE ext_xxx_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_open_for_write_begin + +!--- open_for_write_commit +SUBROUTINE ext_xxx_open_for_write_commit( DataHandle , Status ) + IMPLICIT NONE + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_open_for_write_commit + +!--- open_for_read +SUBROUTINE ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_open_for_read + +!--- inquire_opened +SUBROUTINE ext_xxx_inquire_opened ( DataHandle, FileName , FileStatus, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_inquire_opened + +!--- inquire_filename +SUBROUTINE ext_xxx_inquire_filename ( DataHandle, FileName , FileStatus, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(OUT) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status +END SUBROUTINE ext_xxx_inquire_filename + +!--- sync +SUBROUTINE ext_xxx_iosync ( DataHandle, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_iosync + +!--- close +SUBROUTINE ext_xxx_ioclose ( DataHandle, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_ioclose + +!--- get_next_time (not defined for IntIO ) +SUBROUTINE ext_xxx_get_next_time ( DataHandle, DateStr, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(OUT) :: DateStr + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_get_next_time + +!--- set_time +SUBROUTINE ext_xxx_set_time ( DataHandle, DateStr, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: DateStr + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_set_time + +!--- get_next_var (not defined for IntIO) +SUBROUTINE ext_xxx_get_next_var ( DataHandle, VarName, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(OUT) :: VarName + INTEGER , INTENT(OUT) :: Status + RETURN +END SUBROUTINE ext_xxx_get_next_var + +!--- get_dom_ti_real +SUBROUTINE ext_xxx_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element +RETURN +END SUBROUTINE ext_xxx_get_dom_ti_real + +!--- put_dom_ti_real +SUBROUTINE ext_xxx_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_ti_real + +!--- get_dom_ti_double +SUBROUTINE ext_xxx_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_get_dom_ti_double + +!--- put_dom_ti_double +SUBROUTINE ext_xxx_put_dom_ti_double ( DataHandle,Element, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_ti_double + +!--- get_dom_ti_integer +SUBROUTINE ext_xxx_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + integer , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_dom_ti_integer + +!--- put_dom_ti_integer +SUBROUTINE ext_xxx_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_ti_integer + +!--- get_dom_ti_logical +SUBROUTINE ext_xxx_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_dom_ti_logical + +!--- put_dom_ti_logical +SUBROUTINE ext_xxx_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_ti_logical + +!--- get_dom_ti_char +SUBROUTINE ext_xxx_get_dom_ti_char ( DataHandle,Element, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(OUT) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_dom_ti_char + +!--- put_dom_ti_char +SUBROUTINE ext_xxx_put_dom_ti_char ( DataHandle,Element, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_ti_char + +!--- get_dom_td_real +SUBROUTINE ext_xxx_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_get_dom_td_real + +!--- put_dom_td_real +SUBROUTINE ext_xxx_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_td_real + +!--- get_dom_td_double +SUBROUTINE ext_xxx_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_get_dom_td_double + +!--- put_dom_td_double +SUBROUTINE ext_xxx_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_put_dom_td_double + +!--- get_dom_td_integer +SUBROUTINE ext_xxx_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_get_dom_td_integer + +!--- put_dom_td_integer +SUBROUTINE ext_xxx_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_td_integer + +!--- get_dom_td_logical +SUBROUTINE ext_xxx_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) + IMPLICIT NONE + 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 +RETURN +END SUBROUTINE ext_xxx_get_dom_td_logical + +!--- put_dom_td_logical +SUBROUTINE ext_xxx_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_td_logical + +!--- get_dom_td_char +SUBROUTINE ext_xxx_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(OUT) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_dom_td_char + +!--- put_dom_td_char +SUBROUTINE ext_xxx_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_dom_td_char + +!--- get_var_ti_real +SUBROUTINE ext_xxx_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_ti_real + +!--- put_var_ti_real +SUBROUTINE ext_xxx_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_ti_real + +!--- get_var_ti_double +SUBROUTINE ext_xxx_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_ti_double + +!--- put_var_ti_double +SUBROUTINE ext_xxx_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_ti_double + +!--- get_var_ti_integer +SUBROUTINE ext_xxx_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_ti_integer + +!--- put_var_ti_integer +SUBROUTINE ext_xxx_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_ti_integer + +!--- get_var_ti_logical +SUBROUTINE ext_xxx_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_ti_logical + +!--- put_var_ti_logical +SUBROUTINE ext_xxx_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_ti_logical + +!--- get_var_ti_char +SUBROUTINE ext_xxx_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(OUT) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_ti_char + +!--- put_var_ti_char +SUBROUTINE ext_xxx_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_ti_char + +!--- get_var_td_real +SUBROUTINE ext_xxx_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_td_real + +!--- put_var_td_real +SUBROUTINE ext_xxx_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_td_real + +!--- get_var_td_double +SUBROUTINE ext_xxx_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_td_double + +!--- put_var_td_double +SUBROUTINE ext_xxx_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_td_double + +!--- get_var_td_integer +SUBROUTINE ext_xxx_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_td_integer + +!--- put_var_td_integer +SUBROUTINE ext_xxx_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_td_integer + +!--- get_var_td_logical +SUBROUTINE ext_xxx_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(OUT) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: OutCount + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_td_logical + +!--- put_var_td_logical +SUBROUTINE ext_xxx_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_td_logical + +!--- get_var_td_char +SUBROUTINE ext_xxx_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(OUT) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_td_char + +!--- put_var_td_char +SUBROUTINE ext_xxx_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_put_var_td_char + +!--- read_field +SUBROUTINE ext_xxx_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(INOUT) :: DateStr + CHARACTER*(*) , INTENT(INOUT) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + 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 +RETURN +END SUBROUTINE ext_xxx_read_field + +!--- write_field +SUBROUTINE ext_xxx_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + INTEGER , INTENT(IN) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + 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 +RETURN +END SUBROUTINE ext_xxx_write_field + +!--- get_var_info (not implemented for IntIO) +SUBROUTINE ext_xxx_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , Status ) + IMPLICIT NONE + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: VarName + integer ,intent(out) :: NDim + character*(*) ,intent(out) :: MemoryOrder + character*(*) ,intent(out) :: Stagger + integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd + integer ,intent(out) :: Status +RETURN +END SUBROUTINE ext_xxx_get_var_info + + +!--- end_of_frame +SUBROUTINE ext_xxx_end_of_frame(DataHandle, Status) + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + INTEGER, INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_end_of_frame + + +!--- error_str +SUBROUTINE ext_xxx_error_str( Code, ReturnString, Status) + IMPLICIT NONE + INTEGER , INTENT(IN) :: Code + CHARACTER *(*), INTENT(OUT) :: ReturnString + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_error_str + + +!--- get_previous_time +SUBROUTINE ext_xxx_get_previous_time(DataHandle, DateStr, Status) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*), INTENT(OUT) :: DateStr + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_get_previous_time + + +!--- open_for_read_begin +SUBROUTINE ext_xxx_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + IMPLICIT NONE + CHARACTER*(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm + INTEGER , INTENT(IN) :: IOComm + CHARACTER*(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_open_for_read_begin + + +!--- open_for_read_commit +SUBROUTINE ext_xxx_open_for_read_commit(DataHandle, Status) + IMPLICIT NONE + INTEGER, INTENT(IN) :: DataHandle + INTEGER, INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_open_for_read_commit + + +!--- open_for_update +SUBROUTINE ext_xxx_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status) + IMPLICIT NONE + CHARACTER*(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm + INTEGER , INTENT(IN) :: IOComm + CHARACTER*(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_open_for_update + + +!--- open_for_write +SUBROUTINE ext_xxx_open_for_write (DatasetName, Comm1, Comm2, & + SysDepInfo, DataHandle, Status) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: DatasetName + INTEGER , INTENT(IN) :: Comm1, Comm2 + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_open_for_write + + +!--- warning_str +SUBROUTINE ext_xxx_warning_str( Code, ReturnString, Status) + IMPLICIT NONE + INTEGER , INTENT(IN) :: Code + CHARACTER *(*), INTENT(OUT) :: ReturnString + INTEGER , INTENT(OUT) :: Status +RETURN +END SUBROUTINE ext_xxx_warning_str + diff --git a/wrfv2_fire/inc/.inc b/wrfv2_fire/inc/.inc new file mode 100644 index 00000000..42e09693 --- /dev/null +++ b/wrfv2_fire/inc/.inc @@ -0,0 +1,71 @@ +! +! 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. +! +! This file contains a list of the dummy arguments for +! solve or any routine (there are others) that take +! all of the state data through thier argument list. A +! subroutine definition should look like this: +! +! SUBROUTINE solve ( grid , & +! ! +! #include "solve_dummy_args.inc" +! ! +! ) +! +! Please note that the comment lines around the include are necessary. +! These arguments are defined by including solve_dummy_arg_defines.inc +! in the declaration section of the subroutine. +! +! Contains dummy arguments to solve. +! + chem_1 , & + chem_2 , & + moist_1 , & + moist_2 , & +, ru_1 , ru_2 , rv_1 , rv_2 & +, rw_1 , rw_2 , rrp_1 , rrp_2 & +, rr_1 , rr_2 , rtp_1 , rtp_2 & +, rom_1 , rom_2 , ru_1 , ru_2 & +, rv_1 , rv_2 , rw_1 , rw_2 & +, rrp_1 , rrp_2 , rr_1 , rr_2 & +, rtp_1 , rtp_2 , rom_1 , rom_2 & +, pip , pp , du , dv & +, pib , r , rtb , rrb & +, zx , zy , z , pb & +, h_diabatic , zeta_z , z_zeta , msft & +, msfu , msfv , f , e & +, sina , cosa , ht , cofwr & +, cofrz , u_base , v_base , qv_base & +, rdzu , rdzw , fzm , fzp & +, zeta , zetaw , dzeta , dzetaw & +, rdx , rdy , dts , dtseps & +, resm , zetatop , cf1 , cf2 & +, cf3 , sp31 , ep31 , sp32 & +, ep32 , sp33 , ep33 , sp34 & +, ep34 , sp21 , ep21 , sp22 & +, ep22 , sp23 , ep23 , sp11 & +, ep11 , sp12 , ep12 , sm31 & +, em31 , sm32 , em32 , sm33 & +, em33 , sm34 , em34 , sm21 & +, em21 , sm22 , em22 , sm23 & +, em23 , sm11 , em11 , sm12 & +, em12 , number_at_same_level , halo_x , halo_y & +, num_tiles , num_tiles_x , num_tiles_y , tiled & +, patched , time_step_max , max_dom , dyn_opt & +, id , level , s_we , e_we & +, s_sn , e_sn , s_vert , e_vert & +, time_step_count_start , time_step_count_end , time_step_count_output , time_step_sound & +, mother_id , i_mother_start , j_mother_start , i_mother_end & +, j_mother_end , mother_grid_ratio , mother_time_step_ratio , moad_grid_ratio & +, moad_time_step_ratio , dx , dy , dt & +, smdiv , epssm , khdif , kvdif & +, periodic_x , symmetric_xs , symmetric_xe , open_xs & +, open_xe , periodic_y , symmetric_ys , symmetric_ye & +, open_ys , open_ye , nested , specified & +, top_radiation , sd31 , ed31 , sd32 & +, ed32 , sd33 , ed33 , sd34 & +, ed34 , sd21 , ed21 , sd22 & +, ed22 , sd23 , ed23 , sd11 & +, ed11 , sd12 , ed12 , total_time_steps & diff --git a/wrfv2_fire/inc/bench_solve_em_def.h b/wrfv2_fire/inc/bench_solve_em_def.h new file mode 100644 index 00000000..be16b77f --- /dev/null +++ b/wrfv2_fire/inc/bench_solve_em_def.h @@ -0,0 +1,69 @@ +#ifdef BENCH + INTEGER, EXTERNAL :: rsl_internal_microclock + INTEGER btimex, solve_tim +#define SOLVE_START solve_tim = rsl_internal_microclock() +#define SOLVE_END solve_tim = rsl_internal_microclock() - solve_tim +#define BENCH_DECL(A) integer A +#define BENCH_INIT(A) A=0 +#define BENCH_START(A) btimex=rsl_internal_microclock() +#define BENCH_END(A) A=A+rsl_internal_microclock()-btimex +#define BENCH_REPORT(A) write(0,*)'A= ',A +BENCH_DECL(step_prep_tim) +BENCH_DECL(set_phys_bc_tim) +BENCH_DECL(init_zero_tend_tim) +BENCH_DECL(phy_prep_tim) +BENCH_DECL(rad_driver_tim) +BENCH_DECL(surf_driver_tim) +BENCH_DECL(pbl_driver_tim) +BENCH_DECL(cu_driver_tim) +BENCH_DECL(fdda_driver_tim) +BENCH_DECL(cal_phy_tend) +BENCH_DECL(comp_diff_metrics_tim) +BENCH_DECL(tke_diff_bc_tim) +BENCH_DECL(deform_div_tim) +BENCH_DECL(calc_tke_tim) +BENCH_DECL(phy_bc_tim) +BENCH_DECL(update_phy_ten_tim) +BENCH_DECL(tke_rhs_tim) +BENCH_DECL(vert_diff_tim) +BENCH_DECL(hor_diff_tim) +BENCH_DECL(rk_tend_tim) +BENCH_DECL(relax_bdy_dry_tim) +BENCH_DECL(small_step_prep_tim) +BENCH_DECL(set_phys_bc2_tim) +BENCH_DECL(advance_uv_tim) +BENCH_DECL(spec_bdy_uv_tim) +BENCH_DECL(advance_mu_t_tim) +BENCH_DECL(spec_bdy_t_tim) +BENCH_DECL(sumflux_tim) +BENCH_DECL(advance_w_tim) +BENCH_DECL(spec_bdynhyd_tim) +BENCH_DECL(cald_p_rho_tim) +BENCH_DECL(phys_bc_tim) +BENCH_DECL(calc_mu_uv_tim) +BENCH_DECL(small_step_finish_tim) +BENCH_DECL(rk_scalar_tend_tim) +BENCH_DECL(rlx_bdy_scalar_tim) +BENCH_DECL(update_scal_tim) +BENCH_DECL(flow_depbdy_tim) +BENCH_DECL(tke_adv_tim) +BENCH_DECL(chem_adv_tim) +BENCH_DECL(calc_p_rho_tim) +BENCH_DECL(diag_w_tim) +BENCH_DECL(bc_end_tim) +BENCH_DECL(advance_ppt_tim) +BENCH_DECL(moist_physics_prep_tim) +BENCH_DECL(micro_driver_tim) +BENCH_DECL(moist_phys_end_tim) +BENCH_DECL(time_filt_tim) +BENCH_DECL(bc_2d_tim) +BENCH_DECL(microswap_1) +BENCH_DECL(microswap_2) +#else +#define SOLVE_START +#define SOLVE_END +#define BENCH_INIT(A) +#define BENCH_START(A) +#define BENCH_END(A) +#define BENCH_REPORT(A) +#endif diff --git a/wrfv2_fire/inc/bench_solve_em_end.h b/wrfv2_fire/inc/bench_solve_em_end.h new file mode 100644 index 00000000..f903e012 --- /dev/null +++ b/wrfv2_fire/inc/bench_solve_em_end.h @@ -0,0 +1,53 @@ +SOLVE_END +BENCH_REPORT(solve_tim) +BENCH_REPORT(step_prep_tim) +BENCH_REPORT(set_phys_bc_tim) +BENCH_REPORT(init_zero_tend_tim) +BENCH_REPORT(phy_prep_tim) +BENCH_REPORT(rad_driver_tim) +BENCH_REPORT(surf_driver_tim) +BENCH_REPORT(pbl_driver_tim) +BENCH_REPORT(cu_driver_tim) +BENCH_REPORT(fdda_driver_tim) +BENCH_REPORT(cal_phy_tend) +BENCH_REPORT(comp_diff_metrics_tim) +BENCH_REPORT(tke_diff_bc_tim) +BENCH_REPORT(deform_div_tim) +BENCH_REPORT(calc_tke_tim) +BENCH_REPORT(phy_bc_tim) +BENCH_REPORT(update_phy_ten_tim) +BENCH_REPORT(tke_rhs_tim) +BENCH_REPORT(vert_diff_tim) +BENCH_REPORT(hor_diff_tim) +BENCH_REPORT(rk_tend_tim) +BENCH_REPORT(relax_bdy_dry_tim) +BENCH_REPORT(small_step_prep_tim) +BENCH_REPORT(set_phys_bc2_tim) +BENCH_REPORT(advance_uv_tim) +BENCH_REPORT(spec_bdy_uv_tim) +BENCH_REPORT(advance_mu_t_tim) +BENCH_REPORT(spec_bdy_t_tim) +BENCH_REPORT(sumflux_tim) +BENCH_REPORT(advance_w_tim) +BENCH_REPORT(spec_bdynhyd_tim) +BENCH_REPORT(cald_p_rho_tim) +BENCH_REPORT(phys_bc_tim) +BENCH_REPORT(calc_mu_uv_tim) +BENCH_REPORT(small_step_finish_tim) +BENCH_REPORT(rk_scalar_tend_tim) +BENCH_REPORT(rlx_bdy_scalar_tim) +BENCH_REPORT(update_scal_tim) +BENCH_REPORT(flow_depbdy_tim) +BENCH_REPORT(tke_adv_tim) +BENCH_REPORT(chem_adv_tim) +BENCH_REPORT(calc_p_rho_tim) +BENCH_REPORT(diag_w_tim) +BENCH_REPORT(bc_end_tim) +BENCH_REPORT(advance_ppt_tim) +BENCH_REPORT(moist_physics_prep_tim) +BENCH_REPORT(micro_driver_tim) +BENCH_REPORT(moist_phys_end_tim) +BENCH_REPORT(time_filt_tim) +BENCH_REPORT(bc_2d_tim) +BENCH_REPORT(microswap_1) +BENCH_REPORT(microswap_2) diff --git a/wrfv2_fire/inc/bench_solve_em_init.h b/wrfv2_fire/inc/bench_solve_em_init.h new file mode 100644 index 00000000..4c93ca0f --- /dev/null +++ b/wrfv2_fire/inc/bench_solve_em_init.h @@ -0,0 +1,52 @@ +BENCH_INIT(step_prep_tim) +BENCH_INIT(set_phys_bc_tim) +BENCH_INIT(init_zero_tend_tim) +BENCH_INIT(phy_prep_tim) +BENCH_INIT(rad_driver_tim) +BENCH_INIT(surf_driver_tim) +BENCH_INIT(pbl_driver_tim) +BENCH_INIT(cu_driver_tim) +BENCH_INIT(fdda_driver_tim) +BENCH_INIT(cal_phy_tend) +BENCH_INIT(comp_diff_metrics_tim) +BENCH_INIT(tke_diff_bc_tim) +BENCH_INIT(deform_div_tim) +BENCH_INIT(calc_tke_tim) +BENCH_INIT(phy_bc_tim) +BENCH_INIT(update_phy_ten_tim) +BENCH_INIT(tke_rhs_tim) +BENCH_INIT(vert_diff_tim) +BENCH_INIT(hor_diff_tim) +BENCH_INIT(rk_tend_tim) +BENCH_INIT(relax_bdy_dry_tim) +BENCH_INIT(small_step_prep_tim) +BENCH_INIT(set_phys_bc2_tim) +BENCH_INIT(advance_uv_tim) +BENCH_INIT(spec_bdy_uv_tim) +BENCH_INIT(advance_mu_t_tim) +BENCH_INIT(spec_bdy_t_tim) +BENCH_INIT(sumflux_tim) +BENCH_INIT(advance_w_tim) +BENCH_INIT(spec_bdynhyd_tim) +BENCH_INIT(cald_p_rho_tim) +BENCH_INIT(phys_bc_tim) +BENCH_INIT(calc_mu_uv_tim) +BENCH_INIT(small_step_finish_tim) +BENCH_INIT(rk_scalar_tend_tim) +BENCH_INIT(rlx_bdy_scalar_tim) +BENCH_INIT(update_scal_tim) +BENCH_INIT(flow_depbdy_tim) +BENCH_INIT(tke_adv_tim) +BENCH_INIT(chem_adv_tim) +BENCH_INIT(calc_p_rho_tim) +BENCH_INIT(diag_w_tim) +BENCH_INIT(bc_end_tim) +BENCH_INIT(advance_ppt_tim) +BENCH_INIT(moist_physics_prep_tim) +BENCH_INIT(micro_driver_tim) +BENCH_INIT(moist_phys_end_tim) +BENCH_INIT(time_filt_tim) +BENCH_INIT(bc_2d_tim) +BENCH_INIT(microswap_1) +BENCH_INIT(microswap_2) +SOLVE_START diff --git a/wrfv2_fire/inc/deref_kludge.h b/wrfv2_fire/inc/deref_kludge.h new file mode 100644 index 00000000..a4485b90 --- /dev/null +++ b/wrfv2_fire/inc/deref_kludge.h @@ -0,0 +1,23 @@ +#ifdef DEREF_KLUDGE + sm31 = grid%sm31 + em31 = grid%em31 + sm32 = grid%sm32 + em32 = grid%em32 + sm33 = grid%sm33 + em33 = grid%em33 + + sm31x = grid%sm31x + em31x = grid%em31x + sm32x = grid%sm32x + em32x = grid%em32x + sm33x = grid%sm33x + em33x = grid%em33x + + sm31y = grid%sm31y + em31y = grid%em31y + sm32y = grid%sm32y + em32y = grid%em32y + sm33y = grid%sm33y + em33y = grid%em33y +#endif + diff --git a/wrfv2_fire/inc/intio_tags.h b/wrfv2_fire/inc/intio_tags.h new file mode 100644 index 00000000..3808968c --- /dev/null +++ b/wrfv2_fire/inc/intio_tags.h @@ -0,0 +1,34 @@ + INTEGER, PARAMETER :: int_ioexit = 10 + INTEGER, PARAMETER :: int_open_for_write_begin = 20 + INTEGER, PARAMETER :: int_open_for_write_commit = 30 + INTEGER, PARAMETER :: int_open_for_read = 40 + INTEGER, PARAMETER :: int_inquire_opened = 60 + INTEGER, PARAMETER :: int_inquire_filename = 70 + INTEGER, PARAMETER :: int_iosync = 80 + INTEGER, PARAMETER :: int_ioclose = 90 + INTEGER, PARAMETER :: int_next_time = 100 + INTEGER, PARAMETER :: int_set_time = 110 + INTEGER, PARAMETER :: int_next_var = 120 + INTEGER, PARAMETER :: int_dom_ti_real = 140 + INTEGER, PARAMETER :: int_dom_ti_double = 160 + INTEGER, PARAMETER :: int_dom_ti_integer = 180 + INTEGER, PARAMETER :: int_dom_ti_logical = 200 + INTEGER, PARAMETER :: int_dom_ti_char = 220 + INTEGER, PARAMETER :: int_dom_td_real = 240 + INTEGER, PARAMETER :: int_dom_td_double = 260 + INTEGER, PARAMETER :: int_dom_td_integer = 280 + INTEGER, PARAMETER :: int_dom_td_logical = 300 + INTEGER, PARAMETER :: int_dom_td_char = 320 + INTEGER, PARAMETER :: int_var_ti_real = 340 + INTEGER, PARAMETER :: int_var_ti_double = 360 + INTEGER, PARAMETER :: int_var_ti_integer = 380 + INTEGER, PARAMETER :: int_var_ti_logical = 400 + INTEGER, PARAMETER :: int_var_ti_char = 420 + INTEGER, PARAMETER :: int_var_td_real = 440 + INTEGER, PARAMETER :: int_var_td_double = 460 + INTEGER, PARAMETER :: int_var_td_integer = 480 + INTEGER, PARAMETER :: int_var_td_logical = 500 + INTEGER, PARAMETER :: int_var_td_char = 520 + INTEGER, PARAMETER :: int_field = 530 + INTEGER, PARAMETER :: int_var_info = 540 + INTEGER, PARAMETER :: int_noop = 550 diff --git a/wrfv2_fire/inc/rsl_cpp_flags b/wrfv2_fire/inc/rsl_cpp_flags new file mode 100644 index 00000000..cfbb6729 --- /dev/null +++ b/wrfv2_fire/inc/rsl_cpp_flags @@ -0,0 +1,58 @@ +-DXPOSE_A=1 +-DHALO_RK_INIT=2 +-DHALO_RK_A_3=3 +-DHALO_RK_A_5=4 +-DHALO_RK_B=5 +-DHALO_RK_C=6 +-DHALO_RK_D_3=7 +-DHALO_RK_D_5=8 +-DHALO_RK_E_3=9 +-DHALO_RK_E_5=10 +-DHALO_RK_PHYS_A=11 +-DHALO_RK_PHYS_PBL=12 +-DHALO_RK_PHYS_DIFFUSION=13 +-DHALO_RK_TKE_3=14 +-DHALO_RK_TKE_5=15 +-DHALO_RK_CHEM_3=16 +-DHALO_RK_CHEM_5=17 +-DHALO_RK_MOIST_3=18 +-DHALO_RK_MOIST_5=19 +-DPERIOD_BDY_RK_MOUNTAIN=20 +-DPERIOD_BDY_RK_INIT=21 +-DPERIOD_BDY_RK_A=22 +-DPERIOD_BDY_RK_B=23 +-DPERIOD_BDY_RK_C=24 +-DPERIOD_BDY_RK_D=25 +-DPERIOD_BDY_RK_PHY_BC=26 +-DPERIOD_BDY_RK_MOIST=27 +-DPERIOD_BDY_RK_CHEM=28 +-DWRF_RSL_NCOMMS=28 +-DXPOSE_A=1 +-DHALO_RK_INIT=2 +-DHALO_RK_A_3=3 +-DHALO_RK_A_5=4 +-DHALO_RK_B=5 +-DHALO_RK_C=6 +-DHALO_RK_D_3=7 +-DHALO_RK_D_5=8 +-DHALO_RK_E_3=9 +-DHALO_RK_E_5=10 +-DHALO_RK_PHYS_A=11 +-DHALO_RK_PHYS_PBL=12 +-DHALO_RK_PHYS_DIFFUSION=13 +-DHALO_RK_TKE_3=14 +-DHALO_RK_TKE_5=15 +-DHALO_RK_CHEM_3=16 +-DHALO_RK_CHEM_5=17 +-DHALO_RK_MOIST_3=18 +-DHALO_RK_MOIST_5=19 +-DPERIOD_BDY_RK_MOUNTAIN=20 +-DPERIOD_BDY_RK_INIT=21 +-DPERIOD_BDY_RK_A=22 +-DPERIOD_BDY_RK_B=23 +-DPERIOD_BDY_RK_C=24 +-DPERIOD_BDY_RK_D=25 +-DPERIOD_BDY_RK_PHY_BC=26 +-DPERIOD_BDY_RK_MOIST=27 +-DPERIOD_BDY_RK_CHEM=28 +-DWRF_RSL_NCOMMS=28 diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl new file mode 100644 index 00000000..642ea835 --- /dev/null +++ b/wrfv2_fire/inc/version_decl @@ -0,0 +1 @@ + CHARACTER (LEN=10) :: release_version = 'V2.2 ' diff --git a/wrfv2_fire/main/Makefile b/wrfv2_fire/main/Makefile new file mode 100644 index 00000000..ec9825fa --- /dev/null +++ b/wrfv2_fire/main/Makefile @@ -0,0 +1,158 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + +MODULES = + +OBJS = + +LIBPATHS = + +include ../configure.wrf + +$(SOLVER)_wrf : wrf.o + $(RANLIB) libwrflib.a + $(LD) -o wrf.exe $(LDFLAGS) wrf.o libwrflib.a $(LIB) + +$(SOLVER)_wrf_ESMFApp : wrf_ESMFMod.o wrf_ESMFApp.o wrf_SST_ESMF.o + $(RANLIB) libwrflib.a + $(LD) -o wrf_ESMFApp.exe $(LDFLAGS) wrf_ESMFApp.o wrf_ESMFMod.o libwrflib.a $(LIB) + $(LD) -o wrf_SST_ESMF.exe $(LDFLAGS) wrf_SST_ESMF.o wrf_ESMFMod.o libwrflib.a $(LIB) + +$(SOLVER)_ideal : module_initialize ideal.o + $(RANLIB) libwrflib.a + $(LD) -o ideal.exe $(LDFLAGS) ideal.o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o libwrflib.a $(LIB) + +$(SOLVER)_real : module_initialize real_$(SOLVER).o ndown_$(SOLVER).o nup_$(SOLVER).o + $(RANLIB) libwrflib.a + $(LD) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o libwrflib.a $(LIB) + $(LD) -o ndown.exe $(LDFLAGS) ndown_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o libwrflib.a $(LIB) + $(LD) -o nup.exe $(LDFLAGS) nup_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o libwrflib.a $(LIB) + +convert_em : convert_em.o + $(RANLIB) libwrflib.a + $(LD) -o convert_em.exe $(LDFLAGS) convert_em.o libwrflib.a $(LIB) + +convert_nmm : convert_nmm.o + $(RANLIB) libwrflib.a + $(FC) -o convert_nmm.exe $(LDFLAGS) convert_nmm.o libwrflib.a $(LIB) + +real_nmm : real_nmm.o + ( cd ../dyn_nmm ; $(MAKE) module_initialize_real.o ) + $(RANLIB) libwrflib.a + $(FC) -o real_nmm.exe $(LDFLAGS) real_nmm.o ../dyn_nmm/module_initialize_real.o ../share/module_optional_si_input.o ../share/input_wrf.o ../share/module_io_domain.o libwrflib.a $(LIB) + +module_initialize : + ( cd ../dyn_$(SOLVER) ; $(MAKE) module_initialize_$(IDEAL_CASE).o ) + +## prevent real being compiled for OMP -- only for regtesting +#$(SOLVER)_real : module_initialize real_$(SOLVER).o +# $(RANLIB) libwrflib.a +# if [ -z "$(OMP)" ] ; then $(FC) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o libwrflib.a $(LIB) ; fi +# +## prevent module_initialize being compiled for OMP --remove after IBM debugging +#module_initialize : +# if [ -z "$(OMP)" ] ; then ( cd ../dyn_$(SOLVER) ; $(MAKE) module_initialize_$(IDEAL_CASE).o ) ; fi +# end of regtest changes + +clean: + @ echo 'use the clean script' + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +convert_nmm.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + +convert_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + +ideal.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../dyn_$(SOLVER)/$(CASE_MODULE) \ + $(ESMF_MOD_DEPENDENCE) + +ndown_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../frame/module_wrf_error.o \ + ../frame/module_integrate.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + ../share/module_get_file_names.o \ + ../share/module_soil_pre.o \ + ../dyn_em/module_initialize_real.o \ + ../dyn_em/module_big_step_utilities_em.o \ + $(ESMF_MOD_DEPENDENCE) + +nup_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../frame/module_wrf_error.o \ + ../frame/module_integrate.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + ../share/module_get_file_names.o \ + ../share/module_soil_pre.o \ + ../dyn_em/module_initialize_real.o \ + ../dyn_em/module_big_step_utilities_em.o \ + $(ESMF_MOD_DEPENDENCE) + +# this already built above :../dyn_em/module_initialize.real.o \ +real_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../dyn_em/module_si_io_em.o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_io_domain.o \ + ../share/module_date_time.o \ + ../share/module_optional_si_input.o \ + ../share/module_bc_time_utilities.o \ + $(ESMF_MOD_DEPENDENCE) +# ../chem/module_input_chem_data.o \ +# ../chem/module_input_chem_bioemiss.o \ + +wrf.o: ../share/module_wrf_top.o + +wrf_ESMFMod.o: ../share/module_wrf_top.o + +wrf_ESMFApp.o: wrf_ESMFMod.o + +wrf_SST_ESMF.o: wrf_ESMFMod.o + +# DO NOT DELETE diff --git a/wrfv2_fire/main/convert_em.F b/wrfv2_fire/main/convert_em.F new file mode 100644 index 00000000..1330d7b3 --- /dev/null +++ b/wrfv2_fire/main/convert_em.F @@ -0,0 +1,163 @@ +!This is a data converter program. Its actions are controlled by +!the registry and the namelist. It will read variables on the +!'i' stream output and output variables on the 'o' stream as +!indicated in the registry. The input and output forms are +!controlled by io_form_input and io_form_history in the namelist.input. + + +PROGRAM convert_data + + USE module_machine + USE module_domain + USE module_io_domain + USE module_driver_constants + USE module_configure + USE module_timing +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_input_chem_bioemiss +#endif + USE module_utility +#ifdef DM_PARALLEL + USE module_dm +#endif + + IMPLICIT NONE + +#ifdef WRF_CHEM + ! interface + INTERFACE + ! mediation-supplied + SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags) + USE module_domain + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_read_wrf_chem_bioemiss + END INTERFACE +#endif + + REAL :: time , bdyfrq + + INTEGER :: debug_level, fid, ierr + CHARACTER*256 :: timestr, inpname + + + TYPE(domain) , POINTER :: null_domain + TYPE(domain) , POINTER :: grid + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: number_at_same_level + + INTEGER :: max_dom, domain_id + INTEGER :: idum1, idum2 +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: i , j , k , idts, rc + + CHARACTER (LEN=80) :: message + + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop +real::t1,t2 + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + + ! Define the name of this program (program_name defined in module_domain) + + ! NOTE: share/input_wrf.F tests first 7 chars of this name to decide + ! whether to read P_TOP as metadata from the SI (yes, if .eq. REAL_EM) + + program_name = "CONVERT V2.1 " + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + + ! Initialize the modules used by the WRF system. Many of the CALLs made from the + ! init_modules routine are NO-OPs. Typical initializations are: the size of a + ! REAL, setting the file handles to a pre-use value, defining moisture and + ! chemistry indices, etc. + + CALL wrf_debug ( 100 , 'convert_em: calling init_modules ' ) + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + ! The configuration switches mostly come from the NAMELIST input. + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + CALL wrf_message ( program_name ) + + ! Allocate the space for the mother of all domains. + + NULLIFY( null_domain ) + CALL wrf_debug ( 100 , 'convert_em: calling alloc_and_configure_domain ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + grid => head_grid + + CALL Setup_Timekeeping ( grid ) + + + CALL wrf_debug ( 100 , 'convert_em: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + CALL wrf_debug ( 100 , 'convert_em: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + ! Initialize the WRF IO: open files, init file handles, etc. + + CALL wrf_debug ( 100 , 'convert_em: calling init_wrfio' ) + CALL init_wrfio + +#ifdef DM_PARALLEL + CALL wrf_debug ( 100 , 'convert_em: re-broadcast the configuration records' ) + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( inpname , config_flags%input_inname , grid%id , 2 , timestr ) + CALL open_r_dataset ( fid, TRIM(inpname) , grid , config_flags , "DATASET=INPUT", ierr ) + CALL input_model_input ( fid , grid , config_flags , ierr ) + + CALL med_hist_out ( head_grid , 0, config_flags ) + + CALL wrf_shutdown + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM convert_data + diff --git a/wrfv2_fire/main/ideal.F b/wrfv2_fire/main/ideal.F new file mode 100644 index 00000000..906f5fea --- /dev/null +++ b/wrfv2_fire/main/ideal.F @@ -0,0 +1,204 @@ +!IDEAL:DRIVER_LAYER +! +! create an initial data set for the WRF model based on an ideal condition +PROGRAM ideal + + USE module_machine + USE module_domain + USE module_initialize + USE module_driver_constants + USE module_configure + + USE module_timing + USE module_wrf_error + USE module_utility +#ifdef DM_PARALLEL + USE module_dm +#endif + USE module_date_time + + IMPLICIT NONE + + REAL :: time + + INTEGER :: loop , & + levels_to_process + + + TYPE(domain) , POINTER :: keep_grid, grid_ptr, null_domain, grid + TYPE(domain) :: dummy + TYPE (grid_config_rec_type) :: config_flags + TYPE (WRFU_Time) startTime, stopTime, currentTime + TYPE (WRFU_TimeInterval) stepTime + + INTEGER :: max_dom , domain_id , fid , oid , idum1 , idum2 , ierr + INTEGER :: debug_level, rc + LOGICAL :: input_from_file + + INTERFACE + SUBROUTINE med_initialdata_output ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) , POINTER :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + END SUBROUTINE med_initialdata_output + END INTERFACE + +#include "version_decl" + + +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + CHARACTER (LEN=80) :: message + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "IDEAL " // TRIM(release_version) // " PREPROCESSOR" + + ! Get the NAMELIST data for input. + + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + CALL wrf_message ( program_name ) + + + ! allocated and configure the mother domain + + NULLIFY( null_domain ) + + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + grid => head_grid + ! TBH: Note that historically, IDEAL did not set up clocks. These + ! TBH: are explicit replacements for old default initializations... They + ! TBH: are needed to ensure that time manager calls do not fail due to + ! TBH: uninitialized clock. Clean this up later... + CALL WRFU_TimeSet(startTime, YY=1, MM=1, DD=1, H=0, M=0, S=0, rc=rc) + stopTime = startTime + currentTime = startTime + ! TBH: Bogus time step value -- clock is never advanced... + CALL WRFU_TimeIntervalSet(stepTime, S=180, rc=rc) + grid%domain_clock = WRFU_ClockCreate( TimeStep= stepTime, & + StartTime=startTime, & + StopTime= stopTime, & + rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'grid%domain_clock = WRFU_ClockCreate() FAILED', & + __FILE__ , & + __LINE__ ) + CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( head_grid%id , model_config_rec , config_flags ) + CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + WRITE ( current_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2,".0000")' ) & + config_flags%start_year, & + config_flags%start_month, & + config_flags%start_day, & + config_flags%start_hour, & + config_flags%start_minute, & + config_flags%start_second + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock before 1st currTime set,' ) + WRITE (wrf_err_message,*) & + 'DEBUG assemble_output: before 1st currTime set, current_date = ',TRIM(current_date) + CALL wrf_debug ( 150 , wrf_err_message ) + CALL domain_clock_set( grid, current_timestr=current_date(1:19) ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock after 1st currTime set,' ) + + CALL wrf_debug ( 100 , 'wrf: calling init_wrfio' ) + CALL init_wrfio + +#ifdef DM_PARALLEL + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + CALL med_initialdata_output( head_grid , config_flags ) + + CALL wrf_debug ( 0 , 'wrf: SUCCESS COMPLETE IDEAL INIT' ) + CALL med_shutdown_io ( head_grid , config_flags ) + CALL wrf_shutdown + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM ideal + +SUBROUTINE med_initialdata_output ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_initialize + ! Model layer + USE module_configure + + IMPLICIT NONE + + ! Arguments + TYPE(domain) , POINTER :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: time_step_begin_restart + INTEGER :: fid , ierr , id + CHARACTER (LEN=80) :: rstname + CHARACTER (LEN=80) :: message + CHARACTER (LEN=80) :: inpname , bdyname + + ! Initialize the mother domain. + + grid%input_from_file = .false. + CALL init_domain ( grid ) + CALL calc_current_date ( grid%id, 0.) + + CALL construct_filename1 ( inpname , 'wrfinput' , grid%id , 2 ) + CALL open_w_dataset ( id, TRIM(inpname) , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE (wrf_err_message,*)'ideal: error opening wrfinput for writing ',ierr + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + CALL output_model_input ( id, grid , config_flags , ierr ) + CALL close_dataset ( id , config_flags, "DATASET=INPUT" ) + + + IF ( config_flags%specified ) THEN + + CALL construct_filename1 ( bdyname , 'wrfbdy' , grid%id , 2 ) + CALL open_w_dataset ( id, TRIM(bdyname) , grid , config_flags , output_boundary , "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE (wrf_err_message,*)'ideal: error opening wrfbdy for writing ',ierr + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + CALL output_boundary ( id, grid , config_flags , ierr ) + CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" ) + + ENDIF + + RETURN +END SUBROUTINE med_initialdata_output + diff --git a/wrfv2_fire/main/ndown_em.F b/wrfv2_fire/main/ndown_em.F new file mode 100644 index 00000000..a9827431 --- /dev/null +++ b/wrfv2_fire/main/ndown_em.F @@ -0,0 +1,1352 @@ +!WRF:DRIVER_LAYER:MAIN +! + +PROGRAM ndown_em + + USE module_machine + USE module_domain + USE module_initialize + USE module_integrate + USE module_driver_constants + USE module_configure + USE module_io_domain + USE module_utility + + USE module_timing + USE module_wrf_error +#ifdef DM_PARALLEL + USE module_dm +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!new for bc + USE module_bc + USE module_big_step_utilities_em + USE module_get_file_names +#ifdef WRF_CHEM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! for chemistry + USE module_input_chem_data +! USE module_input_chem_bioemiss +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#endif + + IMPLICIT NONE + ! interface + INTERFACE + ! mediation-supplied + SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags) + USE module_domain + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_read_wrf_chem_bioemiss + + SUBROUTINE init_domain_constants_em_ptr ( parent , nest ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: parent , nest + END SUBROUTINE init_domain_constants_em_ptr + + END INTERFACE + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!new for bc + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: its , ite , jts , jte , kts , kte + INTEGER :: spec_bdy_width + INTEGER :: i , j , k , nvchem + INTEGER :: time_loop_max , time_loop + INTEGER :: total_time_sec , file_counter + INTEGER :: julyr , julday , iswater , map_proj + INTEGER :: icnt + + REAL :: dt , new_bdy_frq + REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon + + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: cbdy3dtemp1 , cbdy3dtemp2 + REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0 + + CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char + CHARACTER(LEN=19) :: stopTimeStr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + + REAL :: time + INTEGER :: rc + + INTEGER :: loop , levels_to_process + INTEGER , PARAMETER :: max_sanity_file_loop = 100 + + TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid + TYPE (domain) :: dummy + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: number_at_same_level + INTEGER :: time_step_begin_restart + + INTEGER :: max_dom , domain_id , fid , fido, fidb , oid , idum1 , idum2 , ierr + INTEGER :: status_next_var + INTEGER :: debug_level + LOGICAL :: input_from_file , need_new_file + CHARACTER (LEN=19) :: date_string + +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + INTEGER :: idsi + CHARACTER (LEN=80) :: inpname , outname , bdyname + CHARACTER (LEN=80) :: si_inpname +character *19 :: temp19 +character *24 :: temp24 , temp24b +character(len=24) :: start_date_hold + + CHARACTER (LEN=80) :: message +integer :: ii + +#include "version_decl" + + ! Interface block for routine that passes pointers and needs to know that they + ! are receiving pointers. + + INTERFACE + + SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: parent_grid , nested_grid + END SUBROUTINE med_interp_domain + + SUBROUTINE Setup_Timekeeping( parent_grid ) + USE module_domain + TYPE(domain), POINTER :: parent_grid + END SUBROUTINE Setup_Timekeeping + + END INTERFACE + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "NDOWN_EM " // TRIM(release_version) // " PREPROCESSOR" + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + + ! Initialize the modules used by the WRF system. Many of the CALLs made from the + ! init_modules routine are NO-OPs. Typical initializations are: the size of a + ! REAL, setting the file handles to a pre-use value, defining moisture and + ! chemistry indices, etc. + + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + ! Get the NAMELIST data. This is handled in the initial_config routine. All of the + ! NAMELIST input variables are assigned to the model_config_rec structure. Below, + ! note for parallel processing, only the monitor processor handles the raw Fortran + ! I/O, and then broadcasts the info to each of the other nodes. + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + ! And here is an instance of using the information in the NAMELIST. + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + ! Allocated and configure the mother domain. Since we are in the nesting down + ! mode, we know a) we got a nest, and b) we only got 1 nest. + + NULLIFY( null_domain ) + + CALL wrf_message ( program_name ) + CALL wrf_debug ( 100 , 'ndown_em: calling alloc_and_configure_domain coarse ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + parent_grid => head_grid + + ! Set up time initializations. + + CALL Setup_Timekeeping ( parent_grid ) + + CALL domain_clock_set( head_grid, & + time_step_seconds=model_config_rec%interval_seconds ) + CALL wrf_debug ( 100 , 'ndown_em: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL wrf_debug ( 100 , 'ndown_em: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 ) + + ! Initialize the I/O for WRF. + + CALL wrf_debug ( 100 , 'ndown_em: calling init_wrfio' ) + CALL init_wrfio + + ! Some of the configuration values may have been modified from the initial READ + ! of the NAMELIST, so we re-broadcast the configuration records. + +#ifdef DM_PARALLEL + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + ! We need to current and starting dates for the output files. The times need to be incremented + ! so that the lateral BC files are not overwritten. + + WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + model_config_rec%start_year (parent_grid%id) , & + model_config_rec%start_month (parent_grid%id) , & + model_config_rec%start_day (parent_grid%id) , & + model_config_rec%start_hour (parent_grid%id) , & + model_config_rec%start_minute(parent_grid%id) , & + model_config_rec%start_second(parent_grid%id) + + WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + model_config_rec% end_year (parent_grid%id) , & + model_config_rec% end_month (parent_grid%id) , & + model_config_rec% end_day (parent_grid%id) , & + model_config_rec% end_hour (parent_grid%id) , & + model_config_rec% end_minute(parent_grid%id) , & + model_config_rec% end_second(parent_grid%id) + + ! Override stop time with value computed above. + CALL domain_clock_set( parent_grid, stop_timestr=end_date_char ) + + CALL geth_idts ( end_date_char , start_date_char , total_time_sec ) + + new_bdy_frq = model_config_rec%interval_seconds + time_loop_max = total_time_sec / model_config_rec%interval_seconds + 1 + + start_date = start_date_char // '.0000' + current_date = start_date_char // '.0000' + start_date_hold = start_date_char // '.0000' + current_date_char = start_date_char + + ! Get a list of available file names to try. This fills up the eligible_file_name + ! array with number_of_eligible_files entries. This routine issues a nonstandard + ! call (system). + + file_counter = 1 + need_new_file = .FALSE. + CALL unix_ls ( 'wrfout' , parent_grid%id ) + + ! Open the input data (wrfout_d01_xxxxxx) for reading. + + CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) ) + CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=AUXINPUT1", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), & + ' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + ! We know how many time periods to process, so we begin. + + big_time_loop_thingy : DO time_loop = 1 , time_loop_max + + ! Which date are we currently soliciting? + + CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) ) +print *,'-------->>> Processing data: loop=',time_loop,' date/time = ',date_string + current_date_char = date_string + current_date = date_string // '.0000' + start_date = date_string // '.0000' +print *,'loopmax = ', time_loop_max, ' ending date = ',end_date_char + CALL domain_clock_set( parent_grid, & + current_timestr=current_date(1:19) ) + + ! Which times are in this file, and more importantly, are any of them the + ! ones that we want? We need to loop over times in each files, loop + ! over files. + + get_the_right_time : DO + + CALL wrf_get_next_time ( fid , date_string , status_next_var ) +print *,'file date/time = ',date_string,' desired date = ',current_date_char,' status = ', status_next_var + + IF ( status_next_var .NE. 0 ) THEN + CALL wrf_debug ( 100 , 'ndown_em main: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) ) + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + file_counter = file_counter + 1 + IF ( file_counter .GT. number_of_eligible_files ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files' + CALL WRF_ERROR_FATAL ( wrf_err_message ) + END IF + CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) ) + CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), & + ' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + CYCLE get_the_right_time + ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN + CYCLE get_the_right_time + ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN + EXIT get_the_right_time + ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),'.' + CALL WRF_ERROR_FATAL ( wrf_err_message ) + END IF + END DO get_the_right_time + + CALL wrf_debug ( 100 , 'wrf: calling input_history' ) + CALL wrf_get_previous_time ( fid , date_string , status_next_var ) + CALL input_history ( fid , head_grid , config_flags, ierr ) + CALL wrf_debug ( 100 , 'wrf: back from input_history' ) + + ! Get the coarse grid info for later transfer to the fine grid domain. + + CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'DX' , dx , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'DY' , dy , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr ) + + ! First time in, do this: allocate sapce for the fine grid, get the config flags, open the + ! wrfinput and wrfbdy files. This COULD be done outside the time loop, I think, so check it + ! out and move it up if you can. + + IF ( time_loop .EQ. 1 ) THEN + + CALL wrf_message ( program_name ) + CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' ) + CALL alloc_and_configure_domain ( domain_id = 2 , & + grid = nested_grid , & + parent = parent_grid , & + kid = 1 ) + + CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 ) + + ! Set up time initializations for the fine grid. + + CALL Setup_Timekeeping ( nested_grid ) + ! Strictly speaking, nest stop time should come from model_config_rec... + CALL domain_clock_get( parent_grid, stop_timestr=stopTimeStr ) + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19), & + stop_timestr=stopTimeStr , & + time_step_seconds= & + model_config_rec%interval_seconds ) + + ! Generate an output file from this program, which will be an input file to WRF. + + CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq ) + config_flags%bdyfrq = new_bdy_frq + +#ifdef WRF_CHEM +nested_grid%chem_opt = parent_grid%chem_opt +nested_grid%chem_in_opt = parent_grid%chem_in_opt +#endif + + ! Initialize constants and 1d arrays in fine grid from the parent. + + CALL init_domain_constants_em_ptr ( parent_grid , nested_grid ) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' ) + CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 ) + CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + ! Various sizes that we need to be concerned about. + + ids = nested_grid%sd31 + ide = nested_grid%ed31 + kds = nested_grid%sd32 + kde = nested_grid%ed32 + jds = nested_grid%sd33 + jde = nested_grid%ed33 + + ims = nested_grid%sm31 + ime = nested_grid%em31 + kms = nested_grid%sm32 + kme = nested_grid%em32 + jms = nested_grid%sm33 + jme = nested_grid%em33 + + ips = nested_grid%sp31 + ipe = nested_grid%ep31 + kps = nested_grid%sp32 + kpe = nested_grid%ep32 + jps = nested_grid%sp33 + jpe = nested_grid%ep33 + + + print *, ids , ide , jds , jde , kds , kde + print *, ims , ime , jms , jme , kms , kme + print *, ips , ipe , jps , jpe , kps , kpe + + spec_bdy_width = model_config_rec%spec_bdy_width + print *,'spec_bdy_width=',spec_bdy_width + + ! This is the space needed to save the current 3d data for use in computing + ! the lateral boundary tendencies. + + ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( mbdy2dtemp1(ims:ime,1:1, jms:jme) ) + ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) ) + ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) ) + ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + + END IF + + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19), & + time_step_seconds= & + model_config_rec%interval_seconds ) + + ! Do the horizontal interpolation. + + nested_grid%imask_nostag = 1 + nested_grid%imask_xstag = 1 + nested_grid%imask_ystag = 1 + nested_grid%imask_xystag = 1 + CALL med_interp_domain ( head_grid , nested_grid ) + nested_grid%ht_int = nested_grid%ht + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF ( time_loop .EQ. 1 ) THEN + + ! Open the fine grid SI static file. + + CALL construct_filename1( si_inpname , 'wrfndi' , nested_grid%id , 2 ) + CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) ) + CALL open_r_dataset ( idsi, TRIM(si_inpname) , nested_grid , config_flags , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening FG input for reading: ' // TRIM (si_inpname) ) + END IF + + ! Input data. + + CALL wrf_debug ( 100 , 'ndown_em: calling input_aux_model_input2' ) + CALL input_aux_model_input2 ( idsi , nested_grid , config_flags , ierr ) + nested_grid%ht_input = nested_grid%ht + + ! Close this fine grid static input file. + + CALL wrf_debug ( 100 , 'ndown_em: closing fine grid static input' ) + CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" ) + + ! We need a fine grid landuse in the interpolation. So we need to generate + ! that field now. + + IF ( ( nested_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. & + ( nested_grid%isltyp(ips,jps) .GT. 0 ) ) THEN + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + nested_grid% vegcat(i,j) = nested_grid%ivgtyp(i,j) + nested_grid%soilcat(i,j) = nested_grid%isltyp(i,j) + END DO + END DO + + ELSE IF ( ( nested_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. & + ( nested_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + nested_grid%ivgtyp(i,j) = NINT(nested_grid% vegcat(i,j)) + nested_grid%isltyp(i,j) = NINT(nested_grid%soilcat(i,j)) + END DO + END DO + + ELSE + num_veg_cat = SIZE ( nested_grid%landusef , DIM=2 ) + num_soil_top_cat = SIZE ( nested_grid%soilctop , DIM=2 ) + num_soil_bot_cat = SIZE ( nested_grid%soilcbot , DIM=2 ) + + CALL land_percentages ( nested_grid%xland , & + nested_grid%landusef , nested_grid%soilctop , nested_grid%soilcbot , & + nested_grid%isltyp , nested_grid%ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(nested_grid%id) ) + + END IF + + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + nested_grid%lu_index(i,j) = nested_grid%ivgtyp(i,j) + END DO + END DO + + CALL check_consistency ( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(nested_grid%id) ) + + CALL check_consistency2( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , & + nested_grid%tmn , nested_grid%tsk , nested_grid%sst , nested_grid%xland , & + nested_grid%tslb , nested_grid%smois , nested_grid%sh2o , & + config_flags%num_soil_layers , nested_grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(nested_grid%id) ) + + END IF + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! We have 2 terrain elevations. One is from input and the other is from the + ! the horizontal interpolation. + + nested_grid%ht_fine = nested_grid%ht_input + nested_grid%ht = nested_grid%ht_int + + ! We have both the interpolated fields and the higher-resolution static fields. From these + ! the rebalancing is now done. Note also that the field nested_grid%ht is now from the + ! fine grid input file (after this call is completed). + + CALL rebalance_driver ( nested_grid ) + + ! Different things happen during the different time loops: + ! first loop - write wrfinput file, close data set, copy files to holder arrays + ! middle loops - diff 3d/2d arrays, compute and output bc + ! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file + + IF ( time_loop .EQ. 1 ) THEN + + ! Set the time info. + + print *,'current_date = ',current_date + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) +#ifdef WRF_CHEM +! +! SEP Put in chemistry data +! + IF( nested_grid%chem_opt .NE. 0 ) then +! IF( nested_grid%chem_in_opt .EQ. 0 ) then + ! Read the chemistry data from a previous wrf forecast (wrfout file) + ! Generate chemistry data from a idealized vertical profile +! message = 'STARTING WITH BACKGROUND CHEMISTRY ' + CALL wrf_message ( message ) + +! CALL input_chem_profile ( nested_grid ) + + if( nested_grid%bio_emiss_opt .eq. 2 )then + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags) + endif +! ELSE +! message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION' +! CALL wrf_message ( message ) +! ENDIF + ENDIF +#endif + + ! Output the first time period of the data. + + CALL output_model_input ( fido , nested_grid , config_flags , ierr ) + + CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( fido , 'DX' , dx , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( fido , 'DY' , dy , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'CEN_LAT' , cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'CEN_LON' , cen_lon , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'TRUELAT1' , truelat1 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'TRUELAT2' , truelat2 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fido , 'STAND_LON' , stand_lon , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fido , 'ISWATER' , iswater , 1 , ierr ) + + ! These change if the initial time for the nest is not the same as the + ! first time period in the WRF output file. + ! Now that we know the starting date, we need to set the GMT, JULYR, and JULDAY + ! values for the global attributes. This call is based on the setting of the + ! current_date string. + + CALL geth_julgmt ( julyr , julday , gmt) + CALL nl_set_julyr ( nested_grid%id , julyr ) + CALL nl_set_julday ( nested_grid%id , julday ) + CALL nl_set_gmt ( nested_grid%id , gmt ) + CALL wrf_put_dom_ti_real ( fido , 'GMT' , gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fido , 'JULYR' , julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fido , 'JULDAY' , julday , 1 , ierr ) +print *,'current_date =',current_date +print *,'julyr=',julyr +print *,'julday=',julday +print *,'gmt=',gmt + + ! Close the input (wrfout_d01_000000, for example) file. That's right, the + ! input is an output file. Who'd've thunk. + + CALL close_dataset ( fido , config_flags , "DATASET=INPUT" ) + + ! We need to save the 3d/2d data to compute a difference during the next loop. Couple the + ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor. + + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp1 , nested_grid%em_u_2 , & + 'u' , nested_grid%msfu , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp1 , nested_grid%em_v_2 , & + 'v' , nested_grid%msfv , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp1 , nested_grid%em_t_2 , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp1 , nested_grid%em_ph_2 , & + 'h' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp1 , nested_grid%moist(:,:,:,P_QV) , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + + DO j = jps , jpe + DO i = ips , ipe + mbdy2dtemp1(i,1,j) = nested_grid%em_mu_2(i,j) + END DO + END DO + + ! There are 2 components to the lateral boundaries. First, there is the starting + ! point of this time period - just the outer few rows and columns. + + CALL stuff_bdy ( ubdy3dtemp1 , nested_grid%em_u_bxs, nested_grid%em_u_bxe, & + nested_grid%em_u_bys, nested_grid%em_u_bye, & + 'U' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( vbdy3dtemp1 , nested_grid%em_v_bxs, nested_grid%em_v_bxe, & + nested_grid%em_v_bys, nested_grid%em_v_bye, & + 'V' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( tbdy3dtemp1 , nested_grid%em_t_bxs, nested_grid%em_t_bxe, & + nested_grid%em_t_bys, nested_grid%em_t_bye, & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( pbdy3dtemp1 , nested_grid%em_ph_bxs, nested_grid%em_ph_bxe, & + nested_grid%em_ph_bys, nested_grid%em_ph_bye, & + 'W' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( qbdy3dtemp1 , nested_grid%moist_bxs(:,:,:,P_QV), nested_grid%moist_bxe(:,:,:,P_QV), & + nested_grid%moist_bys(:,:,:,P_QV), nested_grid%moist_bye(:,:,:,P_QV), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( mbdy2dtemp1 , nested_grid%em_mu_bxs, nested_grid%em_mu_bxe, & + nested_grid%em_mu_bys, nested_grid%em_mu_bye, & + 'M' , spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) +#ifdef WRF_CHEM + do nvchem=1,num_chem +! if(nvchem.eq.p_o3)then +! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem +! endif + cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5) +! endif + CALL stuff_bdy ( cbdy3dtemp1 , nested_grid%chem_bxs(:,:,:,nvchem), & + nested_grid%chem_bxe(:,:,:,nvchem), & + nested_grid%chem_bys(:,:,:,nvchem), & + nested_grid%chem_bye(:,:,:,nvchem), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe) +! if(nvchem.eq.p_o3)then +! write(0,*)'filled ch_b',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem) +! endif + enddo +#endif + ELSE IF ( ( time_loop .GT. 1 ) .AND. ( time_loop .LT. time_loop_max ) ) THEN + + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp2 , nested_grid%em_u_2 , & + 'u' , nested_grid%msfu , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp2 , nested_grid%em_v_2 , & + 'v' , nested_grid%msfv , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp2 , nested_grid%em_t_2 , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp2 , nested_grid%em_ph_2 , & + 'h' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp2 , nested_grid%moist(:,:,:,P_QV) , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + + DO j = jps , jpe + DO i = ips , ipe + mbdy2dtemp2(i,1,j) = nested_grid%em_mu_2(i,j) + END DO + END DO + + ! During all of the loops after the first loop, we first compute the boundary + ! tendencies with the current data values and the previously save information + ! stored in the *bdy3dtemp1 arrays. + + CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , & + nested_grid%em_u_btxs, nested_grid%em_u_btxe , & + nested_grid%em_u_btys, nested_grid%em_u_btye , & + 'U' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_v_btxs, nested_grid%em_v_btxe , & + nested_grid%em_v_btys, nested_grid%em_v_btye , & + 'V' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_t_btxs, nested_grid%em_t_btxe , & + nested_grid%em_t_btys, nested_grid%em_t_btye , & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_ph_btxs, nested_grid%em_ph_btxe , & + nested_grid%em_ph_btys, nested_grid%em_ph_btye , & + 'W' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , & + nested_grid%moist_btxs(:,:,:,P_QV), nested_grid%moist_btxe(:,:,:,P_QV), & + nested_grid%moist_btys(:,:,:,P_QV), nested_grid%moist_btye(:,:,:,P_QV), & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , & + nested_grid%em_mu_btxs, nested_grid%em_mu_btxe , & + nested_grid%em_mu_btys, nested_grid%em_mu_btye , & + 'M' , & + spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) +#ifdef WRF_CHEM + do nvchem=1,num_chem + cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) + cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 1ch_b2',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps) +! endif + CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , & + nested_grid%chem_btxs(:,:,:,nvchem), nested_grid%chem_btxe(:,:,:,nvchem), & + nested_grid%chem_btys(:,:,:,nvchem), nested_grid%chem_btye(:,:,:,nvchem), & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 2ch_b2',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps) +! endif + enddo +#endif + IF ( time_loop .EQ. 2 ) THEN + + ! Generate an output file from this program, which will be an input file to WRF. + + CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' ) + CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 ) + CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , & + "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + END IF + + ! Both pieces of the boundary data are now available to be written. + + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) + temp24= current_date + temp24b=start_date_hold + start_date = start_date_hold + CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds ) + current_date = temp19 // '.0000' + CALL geth_julgmt ( julyr , julday , gmt) + CALL nl_set_julyr ( nested_grid%id , julyr ) + CALL nl_set_julday ( nested_grid%id , julday ) + CALL nl_set_gmt ( nested_grid%id , gmt ) + CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr ) + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) +print *,'bdy time = ',time_loop-1,' bdy date = ',current_date,' ',start_date + CALL output_boundary ( fidb , nested_grid , config_flags , ierr ) + current_date = temp24 + start_date = temp24b + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) + + IF ( time_loop .EQ. 2 ) THEN + CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr ) + END IF + + ! We need to save the 3d data to compute a difference during the next loop. Couple the + ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor. + ! We load up the boundary data again for use in the next loop. + + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j) + vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j) + tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j) + pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j) + qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j) + END DO + END DO + END DO + + DO j = jps , jpe + DO i = ips , ipe + mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j) + END DO + END DO + + ! There are 2 components to the lateral boundaries. First, there is the starting + ! point of this time period - just the outer few rows and columns. + + CALL stuff_bdy ( ubdy3dtemp1 , & + nested_grid%em_u_bxs, nested_grid%em_u_bxe , & + nested_grid%em_u_bys, nested_grid%em_u_bye , & + 'U' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( vbdy3dtemp1 , & + nested_grid%em_v_bxs, nested_grid%em_v_bxe , & + nested_grid%em_v_bys, nested_grid%em_v_bye , & + 'V' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( tbdy3dtemp1 , & + nested_grid%em_t_bxs, nested_grid%em_t_bxe , & + nested_grid%em_t_bys, nested_grid%em_t_bye , & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( pbdy3dtemp1 , & + nested_grid%em_ph_bxs, nested_grid%em_ph_bxe , & + nested_grid%em_ph_bys, nested_grid%em_ph_bye , & + 'W' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( qbdy3dtemp1 , & + nested_grid%moist_bxs(:,:,:,P_QV), nested_grid%moist_bxe(:,:,:,P_QV), & + nested_grid%moist_bys(:,:,:,P_QV), nested_grid%moist_bye(:,:,:,P_QV), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) +#ifdef WRF_CHEM + do nvchem=1,num_chem + cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem) +! endif + CALL stuff_bdy ( cbdy3dtemp1 , & + nested_grid%chem_bxs(:,:,:,nvchem), nested_grid%chem_bxe(:,:,:,nvchem), & + nested_grid%chem_bys(:,:,:,nvchem), nested_grid%chem_bye(:,:,:,nvchem), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) +! cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem) +! endif + enddo +#endif + CALL stuff_bdy ( mbdy2dtemp1 , & + nested_grid%em_mu_bxs, nested_grid%em_mu_bxe , & + nested_grid%em_mu_bys, nested_grid%em_mu_bye , & + 'M' , spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + ELSE IF ( time_loop .EQ. time_loop_max ) THEN + + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , ubdy3dtemp2 , nested_grid%em_u_2 , & + 'u' , nested_grid%msfu , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , vbdy3dtemp2 , nested_grid%em_v_2 , & + 'v' , nested_grid%msfv , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , tbdy3dtemp2 , nested_grid%em_t_2 , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , pbdy3dtemp2 , nested_grid%em_ph_2 , & + 'h' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( nested_grid%em_mu_2 , nested_grid%em_mub , qbdy3dtemp2 , nested_grid%moist(:,:,:,P_QV) , & + 't' , nested_grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + mbdy2dtemp2(:,1,:) = nested_grid%em_mu_2(:,:) + + ! During all of the loops after the first loop, we first compute the boundary + ! tendencies with the current data values and the previously save information + ! stored in the *bdy3dtemp1 arrays. +#ifdef WRF_CHEM + do nvchem=1,num_chem + cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) + cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 1ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps) +! endif + CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , & + nested_grid%chem_btxs(:,:,:,nvchem), nested_grid%chem_btxe(:,:,:,nvchem), & + nested_grid%chem_btys(:,:,:,nvchem), nested_grid%chem_btye(:,:,:,nvchem), & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe) +! if(nvchem.eq.p_o3)then +! write(0,*)'fill 2ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps) +! endif + enddo +#endif + + CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , & + nested_grid%em_u_btxs , nested_grid%em_u_btxe , & + nested_grid%em_u_btys , nested_grid%em_u_btye , & + 'U' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_v_btxs , nested_grid%em_v_btxe , & + nested_grid%em_v_btys , nested_grid%em_v_btye , & + 'V' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_t_btxs , nested_grid%em_t_btxe , & + nested_grid%em_t_btys , nested_grid%em_t_btye , & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , & + nested_grid%em_ph_btxs , nested_grid%em_ph_btxe , & + nested_grid%em_ph_btys , nested_grid%em_ph_btye , & + 'W' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , & + nested_grid%moist_btxs(:,:,:,P_QV) , nested_grid%moist_btxe(:,:,:,P_QV) , & + nested_grid%moist_btys(:,:,:,P_QV) , nested_grid%moist_btye(:,:,:,P_QV) , & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , & + nested_grid%em_mu_btxs , nested_grid%em_mu_btxe , & + nested_grid%em_mu_btys , nested_grid%em_mu_btye , & + 'M' , & + spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + IF ( time_loop .EQ. 2 ) THEN + + ! Generate an output file from this program, which will be an input file to WRF. + + CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' ) + CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 ) + CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , & + "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + + END IF + + ! Both pieces of the boundary data are now available to be written. + + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) + temp24= current_date + temp24b=start_date_hold + start_date = start_date_hold + CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds ) + current_date = temp19 // '.0000' + CALL geth_julgmt ( julyr , julday , gmt) + CALL nl_set_julyr ( nested_grid%id , julyr ) + CALL nl_set_julday ( nested_grid%id , julday ) + CALL nl_set_gmt ( nested_grid%id , gmt ) + CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr ) + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) + CALL output_boundary ( fidb , nested_grid , config_flags , ierr ) + current_date = temp24 + start_date = temp24b + CALL domain_clock_set( nested_grid, & + current_timestr=current_date(1:19) ) + + IF ( time_loop .EQ. 2 ) THEN + CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr ) + END IF + + ! Since this is the last time through here, we need to close the boundary file. + + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL close_dataset ( fidb , config_flags , "DATASET=BOUNDARY" ) + + + END IF + + ! Process which time now? + + END DO big_time_loop_thingy + + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL med_shutdown_io ( parent_grid , config_flags ) + + CALL wrf_debug ( 0 , 'ndown_em: SUCCESS COMPLETE NDOWN_EM INIT' ) + + CALL wrf_shutdown + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM ndown_em + +SUBROUTINE land_percentages ( xland , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + USE module_soil_pre + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland + + CALL process_percent_cat_new ( xland , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + +END SUBROUTINE land_percentages + +SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask + + LOGICAL :: oops + INTEGER :: oops_count , i , j + + oops = .FALSE. + oops_count = 0 + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. & + ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN + print *,'mismatch in landmask and veg type' + print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j) + oops = .TRUE. + oops_count = oops_count + 1 +landmask(i,j) = 0 +ivgtyp(i,j)=16 +isltyp(i,j)=14 + END IF + END DO + END DO + + IF ( oops ) THEN + CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' ) + END IF + +END SUBROUTINE check_consistency + +SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , & + tmn , tsk , sst , xland , & + tslb , smois , sh2o , & + num_soil_layers , id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + USE module_configure + USE module_optional_si_input + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + INTEGER , INTENT(IN) :: num_soil_layers , id + + INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp + REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o + + INTEGER :: oops1 , oops2 + INTEGER :: i , j , k + + fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) ) + + CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME ) + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN + tmn(i,j) = sst(i,j) + tsk(i,j) = sst(i,j) + ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN + tmn(i,j) = tsk(i,j) + END IF + END DO + END DO + END SELECT fix_tsk_tmn + + ! Is the TSK reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN + print *,'error in the TSK' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then + tsk(i,j)=tmn(i,j) + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + tsk(i,j)=sst(i,j) + else + CALL wrf_error_fatal ( 'TSK unreasonable' ) + end if + END IF + END DO + END DO + + ! Is the TMN reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN + print *,'error in the TMN' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then + tmn(i,j)=tsk(i,j) + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + tmn(i,j)=sst(i,j) + else + CALL wrf_error_fatal ( 'TMN unreasonable' ) + endif + END IF + END DO + END DO + + ! Is the TSLB reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN + print *,'error in the TSLB' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + print *,'tslb = ',tslb(i,:,j) + print *,'old smois = ',smois(i,:,j) + DO l = 1 , num_soil_layers + sh2o(i,l,j) = 0.0 + END DO + DO l = 1 , num_soil_layers + smois(i,l,j) = 0.3 + END DO + if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=tsk(i,j) + END DO + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=sst(i,j) + END DO + else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=tmn(i,j) + END DO + else + CALL wrf_error_fatal ( 'TSLB unreasonable' ) + endif + END IF + END DO + END DO + + ! Let us make sure (again) that the landmask and the veg/soil categories match. + +oops1=0 +oops2=0 + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. & + ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN + IF ( tslb(i,1,j) .GT. 1. ) THEN +oops1=oops1+1 + ivgtyp(i,j) = 5 + isltyp(i,j) = 8 + landmask(i,j) = 1 + xland(i,j) = 1 + ELSE IF ( sst(i,j) .GT. 1. ) THEN +oops2=oops2+1 + ivgtyp(i,j) = iswater + isltyp(i,j) = 14 + landmask(i,j) = 0 + xland(i,j) = 2 + ELSE + print *,'the landmask and soil/veg cats do not match' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'ivgtyp=',ivgtyp(i,j) + print *,'isltyp=',isltyp(i,j) + print *,'iswater=', iswater + print *,'tslb=',tslb(i,:,j) + print *,'sst=',sst(i,j) + CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' ) + END IF + END IF + END DO + END DO +if (oops1.gt.0) then +print *,'points artificially set to land : ',oops1 +endif +if(oops2.gt.0) then +print *,'points artificially set to water: ',oops2 +endif + +END SUBROUTINE check_consistency2 + +SUBROUTINE init_domain_constants_em_ptr ( parent , nest ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain), POINTER :: parent , nest + INTERFACE + SUBROUTINE init_domain_constants_em ( parent , nest ) + USE module_domain + USE module_configure + TYPE(domain) :: parent , nest + END SUBROUTINE init_domain_constants_em + END INTERFACE + CALL init_domain_constants_em ( parent , nest ) +END SUBROUTINE init_domain_constants_em_ptr diff --git a/wrfv2_fire/main/nup_em.F b/wrfv2_fire/main/nup_em.F new file mode 100644 index 00000000..c508efc3 --- /dev/null +++ b/wrfv2_fire/main/nup_em.F @@ -0,0 +1,907 @@ +!WRF:DRIVER_LAYER:MAIN +! + +! "Nest up" program in WRFV2. +! +! Description: +! +! The nest up (nup.exe) program reads from wrfout_d02_ files for +! the nest and generates wrfout_d01_ files for the same periods as +! are in the input files. The fields in the output are the fields in the +! input for state variables that have 'h' and 'u' in the I/O string of +! the Registry. In other words, these are the fields that are normally +! fed back from nest->parent during 2-way nesting. It will read and +! output over multiple files of nest data and generate an equivalent +! number of files of parent data. The dimensions of the fields in the +! output are the size of the nest fields divided by the nesting ratio. +! +! Source file: main/nup_em.F +! +! Compile with WRF: compile em_real +! +! Resulting executable: +! +! main/nup.exe +! -and- +! symbolic link in test/em_real/nup.exe +! +! Run as: nup.exe (no arguments) +! +! Namelist information: +! +! Nup.exe uses the same namelist as a nested run of the wrf.exe. +! Important settings are: +! +! &time_control +! +! start_* +! end_* +! history_interval +! frames_per_outfile +! io_form_history <2 for NetCDF> +! +! &domains +! ... +! max_dom +! e_we +! +! e_sn +! +! parent_grid_ratio +! feedback +! smooth_option +! +! &physics +! +! +! created: JM 2006 01 25 + +PROGRAM nup_em + + USE module_machine + USE module_domain + USE module_initialize + USE module_integrate + USE module_driver_constants + USE module_configure + USE module_io_domain + USE module_utility + + USE module_timing + USE module_wrf_error +#ifdef DM_PARALLEL + USE module_dm +#endif + USE read_util_module + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!new for bc + USE module_bc + USE module_big_step_utilities_em + USE module_get_file_names +#ifdef WRF_CHEM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! for chemistry + USE module_input_chem_data +! USE module_input_chem_bioemiss +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#endif + + IMPLICIT NONE + ! interface + INTERFACE + ! mediation-supplied + SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags) + USE module_domain + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_read_wrf_chem_bioemiss + SUBROUTINE nup ( parent_grid , nested_grid, in_id, out_id, newly_opened ) + USE module_domain + TYPE (domain), POINTER :: parent_grid, nested_grid + INTEGER, INTENT(IN) :: in_id, out_id ! io units + LOGICAL, INTENT(IN) :: newly_opened ! whether to add global metadata + END SUBROUTINE nup + + END INTERFACE + + TYPE(WRFU_TimeInterval) :: RingInterval + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!new for bc + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: its , ite , jts , jte , kts , kte + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: i , j , k + INTEGER :: time_loop_max , time_loop + INTEGER :: total_time_sec , file_counter + INTEGER :: julyr , julday , iswater , map_proj + INTEGER :: icnt + + REAL :: dt , new_bdy_frq + REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon + + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2 + + CHARACTER(LEN=19) :: start_timestr , current_timestr , end_timestr, timestr + CHARACTER(LEN=19) :: stopTimeStr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + + REAL :: time + INTEGER :: rc + + INTEGER :: loop , levels_to_process + INTEGER , PARAMETER :: max_sanity_file_loop = 100 + + TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid + TYPE (domain) :: dummy + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: number_at_same_level + INTEGER :: time_step_begin_restart + + INTEGER :: max_dom , domain_id , fid , fido, fidb , idum1 , idum2 , ierr + INTEGER :: status_next_var + INTEGER :: debug_level + LOGICAL :: newly_opened + CHARACTER (LEN=19) :: date_string + +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + INTEGER :: idsi, in_id, out_id + INTEGER :: e_sn, e_we, pgr + CHARACTER (LEN=80) :: inpname , outname , bdyname + CHARACTER (LEN=80) :: si_inpname + CHARACTER *19 :: temp19 + CHARACTER *24 :: temp24 , temp24b + CHARACTER *132 :: fname + CHARACTER(len=24) :: start_date_hold + + CHARACTER (LEN=80) :: message +integer :: ii + +#include "version_decl" + + ! Interface block for routine that passes pointers and needs to know that they + ! are receiving pointers. + + INTERFACE + + SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: parent_grid , nested_grid + END SUBROUTINE med_feedback_domain + + SUBROUTINE Setup_Timekeeping( parent_grid ) + USE module_domain + TYPE(domain), POINTER :: parent_grid + END SUBROUTINE Setup_Timekeeping + + END INTERFACE + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "NUP_EM " // TRIM(release_version) // " PREPROCESSOR" + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + + ! Initialize the modules used by the WRF system. Many of the CALLs made from the + ! init_modules routine are NO-OPs. Typical initializations are: the size of a + ! REAL, setting the file handles to a pre-use value, defining moisture and + ! chemistry indices, etc. + + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + ! Get the NAMELIST data. This is handled in the initial_config routine. All of the + ! NAMELIST input variables are assigned to the model_config_rec structure. Below, + ! note for parallel processing, only the monitor processor handles the raw Fortran + ! I/O, and then broadcasts the info to each of the other nodes. + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + ! And here is an instance of using the information in the NAMELIST. + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + ! set the specified boundary to zero so the feedback goes all the way + ! to the edge of the coarse domain + CALL nl_set_spec_zone( 1, 0 ) + + ! Allocated and configure the mother domain. Since we are in the nesting down + ! mode, we know a) we got a nest, and b) we only got 1 nest. + + NULLIFY( null_domain ) + +!!!! set up the parent grid (for nup_em, this is the grid we do output from) + + CALL nl_set_shw( 1, 0 ) + CALL nl_set_shw( 2, 0 ) + CALL nl_set_i_parent_start( 2, 1 ) + CALL nl_set_j_parent_start( 2, 1 ) + CALL nl_get_e_we( 2, e_we ) + CALL nl_get_e_sn( 2, e_sn ) + CALL nl_get_parent_grid_ratio( 2, pgr ) + + ! parent grid must cover the entire nest, which is always dimensioned a factor of 3 + 1 + ! so add two here temporarily, then remove later after nest is allocated. + + e_we = e_we / pgr + 2 + e_sn = e_sn / pgr + 2 + CALL nl_set_e_we( 1, e_we ) + CALL nl_set_e_sn( 1, e_sn ) + + CALL wrf_message ( program_name ) + CALL wrf_debug ( 100 , 'nup_em: calling alloc_and_configure_domain coarse ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + parent_grid => head_grid + + ! Set up time initializations. + + CALL Setup_Timekeeping ( parent_grid ) + + CALL domain_clock_set( head_grid, & + time_step_seconds=model_config_rec%interval_seconds ) + + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 ) + +!!!! set up the fine grid (for nup_em, this is the grid we do input into) + + CALL wrf_message ( program_name ) + CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' ) + CALL alloc_and_configure_domain ( domain_id = 2 , & + grid = nested_grid , & + parent = parent_grid , & + kid = 1 ) + +! now that the nest is allocated, pinch off the extra two rows/columns of the parent +! note the IKJ assumption here. + parent_grid%ed31 = parent_grid%ed31 - 2 + parent_grid%ed33 = parent_grid%ed33 - 2 + CALL nl_set_e_we( 1, e_we-2 ) + CALL nl_set_e_sn( 1, e_sn-2 ) + +write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediate_grid) + + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 ) + + ! Set up time initializations for the fine grid. + + CALL Setup_Timekeeping ( nested_grid ) + ! Adjust the time step on the clock so that it's the same as the history interval + + CALL WRFU_AlarmGet( nested_grid%alarms(HISTORY_ALARM), RingInterval=RingInterval ) + CALL WRFU_ClockSet( nested_grid%domain_clock, TimeStep=RingInterval, rc=rc ) + CALL WRFU_ClockSet( parent_grid%domain_clock, TimeStep=RingInterval, rc=rc ) + + ! Get and store the history interval from the fine grid; use for time loop + + + ! Initialize the I/O for WRF. + + CALL init_wrfio + + ! Some of the configuration values may have been modified from the initial READ + ! of the NAMELIST, so we re-broadcast the configuration records. + +#ifdef DM_PARALLEL + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + ! Open the input data (wrfout_d01_xxxxxx) for reading. + in_id = 0 + out_id = 0 + main_loop : DO WHILE ( domain_get_current_time(nested_grid) .LT. domain_get_stop_time(nested_grid) ) + + IF( WRFU_AlarmIsRinging( nested_grid%alarms( HISTORY_ALARM ), rc=rc ) ) THEN + CALL domain_clock_get( nested_grid, current_timestr=timestr ) + newly_opened = .FALSE. + IF ( in_id.EQ. 0 ) THEN + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL construct_filename2a ( fname , config_flags%history_outname , nested_grid%id , 2 , timestr ) + CALL open_r_dataset ( in_id, TRIM(fname), nested_grid , & + config_flags , 'DATASET=HISTORY' , ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE(message,*)'Failed to open ',TRIM(fname),' for reading. ' + CALL wrf_message(message) + EXIT main_loop + ENDIF + + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL construct_filename2a ( fname , config_flags%history_outname , parent_grid%id , 2 , timestr ) + CALL open_w_dataset ( out_id, TRIM(fname), parent_grid , & + config_flags , output_history, 'DATASET=HISTORY' , ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE(message,*)'Failed to open ',TRIM(fname),' for writing. ' + CALL wrf_message(message) + EXIT main_loop + ENDIF + newly_opened = .TRUE. + ENDIF + + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL input_history ( in_id, nested_grid , config_flags , ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE(message,*)'Unable to read time ',timestr + CALL wrf_message(message) + EXIT main_loop + ENDIF +! + CALL nup ( nested_grid , parent_grid, in_id, out_id, newly_opened ) +! + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL output_history ( out_id, parent_grid , config_flags , ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE(message,*)'Unable to write time ',timestr + CALL wrf_message(message) + EXIT main_loop + ENDIF + + nested_grid%nframes(0) = nested_grid%nframes(0) + 1 + IF ( nested_grid%nframes(0) >= config_flags%frames_per_outfile ) THEN + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL close_dataset ( in_id , config_flags , "DATASET=HISTORY" ) + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL close_dataset ( out_id , config_flags , "DATASET=HISTORY" ) + in_id = 0 + out_id = 0 + nested_grid%nframes(0) = 0 + ENDIF + CALL WRFU_AlarmRingerOff( nested_grid%alarms( HISTORY_ALARM ), rc=rc ) + ENDIF + CALL domain_clockadvance( nested_grid ) + CALL domain_clockadvance( parent_grid ) + ENDDO main_loop + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL med_shutdown_io ( parent_grid , config_flags ) + + CALL wrf_debug ( 0 , 'nup_em: SUCCESS COMPLETE NUP_EM INIT' ) + +! CALL wrf_shutdown + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM nup_em + +SUBROUTINE nup ( nested_grid, parent_grid , in_id, out_id, newly_opened ) + USE module_domain + USE module_io_domain + USE module_utility + USE module_timing + USE module_wrf_error +! + IMPLICIT NONE + +! Args + TYPE(domain), POINTER :: parent_grid, nested_grid + INTEGER, INTENT(IN) :: in_id, out_id ! io descriptors + LOGICAL, INTENT(IN) :: newly_opened ! whether to add global metadata +! Local + INTEGER :: julyr , julday , iswater , map_proj + INTEGER :: icnt, ierr + REAL :: dt , new_bdy_frq + REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2 + REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2 + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: its , ite , jts , jte , kts , kte + + INTERFACE + SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: parent_grid , nested_grid + END SUBROUTINE med_feedback_domain + SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: parent_grid , nested_grid + END SUBROUTINE med_interp_domain + END INTERFACE + + IF ( newly_opened ) THEN + CALL wrf_get_dom_ti_integer ( in_id , 'MAP_PROJ' , map_proj , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'DX' , dx , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'DY' , dy , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'CEN_LAT' , cen_lat , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'CEN_LON' , cen_lon , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'TRUELAT1' , truelat1 , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'TRUELAT2' , truelat2 , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( in_id , 'STAND_LON' , stand_lon , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_real ( in_id , 'GMT' , gmt , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_integer ( in_id , 'JULYR' , julyr , 1 , icnt , ierr ) +! CALL wrf_get_dom_ti_integer ( in_id , 'JULDAY' , julday , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_integer ( in_id , 'ISWATER' , iswater , 1 , icnt , ierr ) + ENDIF + + parent_grid%em_fnm = nested_grid%em_fnm + parent_grid%em_fnp = nested_grid%em_fnp + parent_grid%em_rdnw = nested_grid%em_rdnw + parent_grid%em_rdn = nested_grid%em_rdn + parent_grid%em_dnw = nested_grid%em_dnw + parent_grid%em_dn = nested_grid%em_dn + parent_grid%em_znu = nested_grid%em_znu + parent_grid%em_znw = nested_grid%em_znw + + parent_grid%zs = nested_grid%zs + parent_grid%dzs = nested_grid%dzs + + parent_grid%p_top = nested_grid%p_top + parent_grid%rdx = nested_grid%rdx * 3. + parent_grid%rdy = nested_grid%rdy * 3. + parent_grid%resm = nested_grid%resm + parent_grid%zetatop = nested_grid%zetatop + parent_grid%cf1 = nested_grid%cf1 + parent_grid%cf2 = nested_grid%cf2 + parent_grid%cf3 = nested_grid%cf3 + + parent_grid%cfn = nested_grid%cfn + parent_grid%cfn1 = nested_grid%cfn1 + +#ifdef WRF_CHEM + parent_grid%chem_opt = nested_grid%chem_opt + parent_grid%chem_in_opt = nested_grid%chem_in_opt +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Various sizes that we need to be concerned about. + + ids = parent_grid%sd31 + ide = parent_grid%ed31 + kds = parent_grid%sd32 + kde = parent_grid%ed32 + jds = parent_grid%sd33 + jde = parent_grid%ed33 + + ims = parent_grid%sm31 + ime = parent_grid%em31 + kms = parent_grid%sm32 + kme = parent_grid%em32 + jms = parent_grid%sm33 + jme = parent_grid%em33 + + ips = parent_grid%sp31 + ipe = parent_grid%ep31 + kps = parent_grid%sp32 + kpe = parent_grid%ep32 + jps = parent_grid%sp33 + jpe = parent_grid%ep33 + + nested_grid%imask_nostag = 1 + nested_grid%imask_xstag = 1 + nested_grid%imask_ystag = 1 + nested_grid%imask_xystag = 1 + +! Interpolate from nested_grid back onto parent_grid + CALL med_feedback_domain ( parent_grid , nested_grid ) + + parent_grid%ht_int = parent_grid%ht + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#if 0 + CALL construct_filename2( si_inpname , 'wrf_real_input_em' , parent_grid%id , 2 , start_date_char ) + CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) ) + CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) + CALL open_r_dataset ( idsi, TRIM(si_inpname) , parent_grid , config_flags , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrf_real_input_em for reading: ' // TRIM (si_inpname) ) + END IF + + ! Input data. + + CALL wrf_debug ( 100 , 'nup_em: calling input_aux_model_input2' ) + CALL input_aux_model_input2 ( idsi , parent_grid , config_flags , ierr ) + parent_grid%ht_input = parent_grid%ht + + ! Close this fine grid static input file. + + CALL wrf_debug ( 100 , 'nup_em: closing fine grid static input' ) + CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" ) + + ! We need a parent grid landuse in the interpolation. So we need to generate + ! that field now. + + IF ( ( parent_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. & + ( parent_grid%isltyp(ips,jps) .GT. 0 ) ) THEN + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + parent_grid% vegcat(i,j) = parent_grid%ivgtyp(i,j) + parent_grid%soilcat(i,j) = parent_grid%isltyp(i,j) + END DO + END DO + + ELSE IF ( ( parent_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. & + ( parent_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + parent_grid%ivgtyp(i,j) = NINT(parent_grid% vegcat(i,j)) + parent_grid%isltyp(i,j) = NINT(parent_grid%soilcat(i,j)) + END DO + END DO + + ELSE + num_veg_cat = SIZE ( parent_grid%landusef , DIM=2 ) + num_soil_top_cat = SIZE ( parent_grid%soilctop , DIM=2 ) + num_soil_bot_cat = SIZE ( parent_grid%soilcbot , DIM=2 ) + + CALL land_percentages ( parent_grid%xland , & + parent_grid%landusef , parent_grid%soilctop , parent_grid%soilcbot , & + parent_grid%isltyp , parent_grid%ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(parent_grid%id) ) + + END IF + + DO j = jps, MIN(jde-1,jpe) + DO i = ips, MIN(ide-1,ipe) + parent_grid%lu_index(i,j) = parent_grid%ivgtyp(i,j) + END DO + END DO + + CALL check_consistency ( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(parent_grid%id) ) + + CALL check_consistency2( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , & + parent_grid%tmn , parent_grid%tsk , parent_grid%sst , parent_grid%xland , & + parent_grid%tslb , parent_grid%smois , parent_grid%sh2o , & + config_flags%num_soil_layers , parent_grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe , & + model_config_rec%iswater(parent_grid%id) ) + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! We have 2 terrain elevations. One is from input and the other is from the + ! the horizontal interpolation. + + parent_grid%ht_fine = parent_grid%ht_input + parent_grid%ht = parent_grid%ht_int + + ! We have both the interpolated fields and the higher-resolution static fields. From these + ! the rebalancing is now done. Note also that the field parent_grid%ht is now from the + ! fine grid input file (after this call is completed). + + CALL rebalance_driver ( parent_grid ) + + ! Different things happen during the different time loops: + ! first loop - write wrfinput file, close data set, copy files to holder arrays + ! middle loops - diff 3d/2d arrays, compute and output bc + ! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file + + ! Set the time info. + + print *,'current_date = ',current_date + CALL domain_clock_set( parent_grid, & + current_timestr=current_date(1:19) ) +! +! SEP Put in chemistry data +! +#ifdef WRF_CHEM + IF( parent_grid%chem_opt .NE. 0 ) then + IF( parent_grid%chem_in_opt .EQ. 0 ) then + ! Read the chemistry data from a previous wrf forecast (wrfout file) + ! Generate chemistry data from a idealized vertical profile + message = 'STARTING WITH BACKGROUND CHEMISTRY ' + CALL wrf_message ( message ) + + CALL input_chem_profile ( parent_grid ) + + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + + CALL med_read_wrf_chem_bioemiss ( parent_grid , config_flags) + ELSE + message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION' + CALL wrf_message ( message ) + ENDIF + ENDIF +#endif + +#endif + + ! Output the first time period of the data. + + IF ( newly_opened ) THEN + CALL wrf_put_dom_ti_integer ( out_id , 'MAP_PROJ' , map_proj , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( out_id , 'DX' , dx , 1 , ierr ) +! CALL wrf_put_dom_ti_real ( out_id , 'DY' , dy , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'CEN_LAT' , cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'CEN_LON' , cen_lon , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'TRUELAT1' , truelat1 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'TRUELAT2' , truelat2 , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( out_id , 'STAND_LON' , stand_lon , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( out_id , 'ISWATER' , iswater , 1 , ierr ) + + CALL wrf_put_dom_ti_real ( out_id , 'GMT' , gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( out_id , 'JULYR' , julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( out_id , 'JULDAY' , julday , 1 , ierr ) + ENDIF + +END SUBROUTINE nup + +SUBROUTINE land_percentages ( xland , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + USE module_soil_pre + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland + + CALL process_percent_cat_new ( xland , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + +END SUBROUTINE land_percentages + +SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask + + LOGICAL :: oops + INTEGER :: oops_count , i , j + + oops = .FALSE. + oops_count = 0 + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. & + ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN + print *,'mismatch in landmask and veg type' + print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j) + oops = .TRUE. + oops_count = oops_count + 1 +landmask(i,j) = 0 +ivgtyp(i,j)=16 +isltyp(i,j)=14 + END IF + END DO + END DO + + IF ( oops ) THEN + CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' ) + END IF + +END SUBROUTINE check_consistency + +SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , & + tmn , tsk , sst , xland , & + tslb , smois , sh2o , & + num_soil_layers , id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + USE module_configure + USE module_optional_si_input + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + INTEGER , INTENT(IN) :: num_soil_layers , id + + INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp + REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o + + INTEGER :: oops1 , oops2 + INTEGER :: i , j , k + + fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) ) + + CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME ) + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN + tmn(i,j) = sst(i,j) + tsk(i,j) = sst(i,j) + ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN + tmn(i,j) = tsk(i,j) + END IF + END DO + END DO + END SELECT fix_tsk_tmn + + ! Is the TSK reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN + print *,'error in the TSK' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then + tsk(i,j)=tmn(i,j) + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + tsk(i,j)=sst(i,j) + else + CALL wrf_error_fatal ( 'TSK unreasonable' ) + end if + END IF + END DO + END DO + + ! Is the TMN reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN + print *,'error in the TMN' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then + tmn(i,j)=tsk(i,j) + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + tmn(i,j)=sst(i,j) + else + CALL wrf_error_fatal ( 'TMN unreasonable' ) + endif + END IF + END DO + END DO + + ! Is the TSLB reasonable? + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN + print *,'error in the TSLB' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j) + print *,'tslb = ',tslb(i,:,j) + print *,'old smois = ',smois(i,:,j) + DO l = 1 , num_soil_layers + sh2o(i,l,j) = 0.0 + END DO + DO l = 1 , num_soil_layers + smois(i,l,j) = 0.3 + END DO + if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=tsk(i,j) + END DO + else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=sst(i,j) + END DO + else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then + DO l = 1 , num_soil_layers + tslb(i,l,j)=tmn(i,j) + END DO + else + CALL wrf_error_fatal ( 'TSLB unreasonable' ) + endif + END IF + END DO + END DO + + ! Let us make sure (again) that the landmask and the veg/soil categories match. + +oops1=0 +oops2=0 + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. & + ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN + IF ( tslb(i,1,j) .GT. 1. ) THEN +oops1=oops1+1 + ivgtyp(i,j) = 5 + isltyp(i,j) = 8 + landmask(i,j) = 1 + xland(i,j) = 1 + ELSE IF ( sst(i,j) .GT. 1. ) THEN +oops2=oops2+1 + ivgtyp(i,j) = iswater + isltyp(i,j) = 14 + landmask(i,j) = 0 + xland(i,j) = 2 + ELSE + print *,'the landmask and soil/veg cats do not match' + print *,'i,j=',i,j + print *,'landmask=',landmask(i,j) + print *,'ivgtyp=',ivgtyp(i,j) + print *,'isltyp=',isltyp(i,j) + print *,'iswater=', iswater + print *,'tslb=',tslb(i,:,j) + print *,'sst=',sst(i,j) + CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' ) + END IF + END IF + END DO + END DO +if (oops1.gt.0) then +print *,'points artificially set to land : ',oops1 +endif +if(oops2.gt.0) then +print *,'points artificially set to water: ',oops2 +endif + +END SUBROUTINE check_consistency2 diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F new file mode 100644 index 00000000..b3a60afd --- /dev/null +++ b/wrfv2_fire/main/real_em.F @@ -0,0 +1,1013 @@ +! Create an initial data set for the WRF model based on real data. This +! program is specifically set up for the Eulerian, mass-based coordinate. +PROGRAM real_data + + USE module_machine + USE module_domain + USE module_initialize + USE module_io_domain + USE module_driver_constants + USE module_configure + USE module_timing +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_input_chem_bioemiss +#endif + USE module_utility +#ifdef DM_PARALLEL + USE module_dm +#endif + + IMPLICIT NONE + +#ifdef WRF_CHEM + ! interface + INTERFACE + ! mediation-supplied + SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags) + USE module_domain + TYPE (domain) grid + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_read_wrf_chem_bioemiss + END INTERFACE +#endif + + REAL :: time , bdyfrq + + INTEGER :: loop , levels_to_process , debug_level + + + TYPE(domain) , POINTER :: null_domain + TYPE(domain) , POINTER :: grid , another_grid + TYPE(domain) , POINTER :: grid_ptr , grid_ptr2 + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: number_at_same_level + + INTEGER :: max_dom, domain_id , grid_id , parent_id , parent_id1 , id + INTEGER :: e_we , e_sn , i_parent_start , j_parent_start + INTEGER :: idum1, idum2 +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + LOGICAL found_the_id + + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: i , j , k , idts, rc + INTEGER :: sibling_count , parent_id_hold , dom_loop + + CHARACTER (LEN=80) :: message + + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop +real::t1,t2 + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + +#include "version_decl" + + ! Define the name of this program (program_name defined in module_domain) + + ! NOTE: share/input_wrf.F tests first 7 chars of this name to decide + ! whether to read P_TOP as metadata from the SI (yes, if .eq. REAL_EM) + + program_name = "REAL_EM " // TRIM(release_version) // " PREPROCESSOR" + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + + ! Initialize the modules used by the WRF system. Many of the CALLs made from the + ! init_modules routine are NO-OPs. Typical initializations are: the size of a + ! REAL, setting the file handles to a pre-use value, defining moisture and + ! chemistry indices, etc. + + CALL wrf_debug ( 100 , 'real_em: calling init_modules ' ) + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + ! The configuration switches mostly come from the NAMELIST input. + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + CALL wrf_message ( program_name ) + + ! Allocate the space for the mother of all domains. + + NULLIFY( null_domain ) + CALL wrf_debug ( 100 , 'real_em: calling alloc_and_configure_domain ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + grid => head_grid + CALL nl_get_max_dom ( 1 , max_dom ) + + IF ( model_config_rec%interval_seconds .LE. 0 ) THEN + CALL wrf_error_fatal( 'namelist value for interval_seconds must be > 0') + ENDIF + + all_domains : DO domain_id = 1 , max_dom + + IF ( ( model_config_rec%input_from_file(domain_id) ) .OR. & + ( domain_id .EQ. 1 ) ) THEN + + IF ( domain_id .GT. 1 ) THEN + + CALL nl_get_grid_id ( domain_id, grid_id ) + CALL nl_get_parent_id ( domain_id, parent_id ) + CALL nl_get_e_we ( domain_id, e_we ) + CALL nl_get_e_sn ( domain_id, e_sn ) + CALL nl_get_i_parent_start ( domain_id, i_parent_start ) + CALL nl_get_j_parent_start ( domain_id, j_parent_start ) + WRITE (message,FMT='(A,2I3,2I4,2I3)') & + 'new allocated domain: id, par id, dims i/j, start i/j =', & + grid_id, parent_id, e_we, e_sn, i_parent_start, j_parent_start + + CALL wrf_debug ( 100 , message ) + CALL nl_get_grid_id ( parent_id, grid_id ) + CALL nl_get_parent_id ( parent_id, parent_id1 ) + CALL nl_get_e_we ( parent_id, e_we ) + CALL nl_get_e_sn ( parent_id, e_sn ) + CALL nl_get_i_parent_start ( parent_id, i_parent_start ) + CALL nl_get_j_parent_start ( parent_id, j_parent_start ) + WRITE (message,FMT='(A,2I3,2I4,2I3)') & + 'parent domain: id, par id, dims i/j, start i/j =', & + grid_id, parent_id1, e_we, e_sn, i_parent_start, j_parent_start + CALL wrf_debug ( 100 , message ) + + CALL nl_get_grid_id ( domain_id, grid_id ) + CALL nl_get_parent_id ( domain_id, parent_id ) + CALL nl_get_e_we ( domain_id, e_we ) + CALL nl_get_e_sn ( domain_id, e_sn ) + CALL nl_get_i_parent_start ( domain_id, i_parent_start ) + CALL nl_get_j_parent_start ( domain_id, j_parent_start ) + grid_ptr2 => head_grid + found_the_id = .FALSE. + CALL find_my_parent ( grid_ptr2 , grid_ptr , domain_id , parent_id , found_the_id ) + IF ( found_the_id ) THEN + + sibling_count = 0 + DO dom_loop = 2 , domain_id + CALL nl_get_parent_id ( dom_loop, parent_id_hold ) + IF ( parent_id_hold .EQ. parent_id ) THEN + sibling_count = sibling_count + 1 + END IF + END DO + CALL alloc_and_configure_domain ( domain_id = domain_id , & + grid = another_grid , & + parent = grid_ptr , & + kid = sibling_count ) + grid => another_grid + ELSE + CALL wrf_error_fatal( 'real_em.F: Could not find the parent domain') + END IF + END IF + + CALL Setup_Timekeeping ( grid ) + CALL set_current_grid_ptr( grid ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG real: clock after Setup_Timekeeping,' ) + CALL domain_clock_set( grid, & + time_step_seconds=model_config_rec%interval_seconds ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG real: clock after timeStep set,' ) + + + CALL wrf_debug ( 100 , 'real_em: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + CALL wrf_debug ( 100 , 'real_em: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + ! Initialize the WRF IO: open files, init file handles, etc. + + CALL wrf_debug ( 100 , 'real_em: calling init_wrfio' ) + CALL init_wrfio + + ! Some of the configuration values may have been modified from the initial READ + ! of the NAMELIST, so we re-broadcast the configuration records. + +#ifdef DM_PARALLEL + CALL wrf_debug ( 100 , 'real_em: re-broadcast the configuration records' ) + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + ! No looping in this layer. + + CALL wrf_debug ( 100 , 'calling med_sidata_input' ) + CALL med_sidata_input ( grid , config_flags ) + CALL wrf_debug ( 100 , 'backfrom med_sidata_input' ) + + ELSE + CYCLE all_domains + END IF + + END DO all_domains + + CALL set_current_grid_ptr( head_grid ) + + ! We are done. + + CALL wrf_debug ( 0 , 'real_em: SUCCESS COMPLETE REAL_EM INIT' ) + + CALL wrf_shutdown + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM real_data + +SUBROUTINE med_sidata_input ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + ! Model layer + USE module_configure + USE module_bc_time_utilities + USE module_initialize + USE module_optional_si_input +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_input_chem_bioemiss +#endif + + USE module_date_time + USE module_utility + + IMPLICIT NONE + + + ! Interface + INTERFACE + SUBROUTINE start_domain ( grid , allowed_to_read ) ! comes from module_start in appropriate dyn_ directory + USE module_domain + TYPE (domain) grid + LOGICAL, INTENT(IN) :: allowed_to_read + END SUBROUTINE start_domain + END INTERFACE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) :: config_flags + ! Local + INTEGER :: time_step_begin_restart + INTEGER :: idsi , ierr , myproc + CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=80) :: message + + CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char + + INTEGER :: time_loop_max , loop, rc + INTEGER :: julyr , julday + REAL :: gmt +real::t1,t2,t3,t4 + + grid%input_from_file = .true. + grid%input_from_file = .false. + + CALL compute_si_start_and_end ( model_config_rec%start_year (grid%id) , & + model_config_rec%start_month (grid%id) , & + model_config_rec%start_day (grid%id) , & + model_config_rec%start_hour (grid%id) , & + model_config_rec%start_minute(grid%id) , & + model_config_rec%start_second(grid%id) , & + model_config_rec% end_year (grid%id) , & + model_config_rec% end_month (grid%id) , & + model_config_rec% end_day (grid%id) , & + model_config_rec% end_hour (grid%id) , & + model_config_rec% end_minute(grid%id) , & + model_config_rec% end_second(grid%id) , & + model_config_rec%interval_seconds , & + model_config_rec%real_data_init_type , & + start_date_char , end_date_char , time_loop_max ) + + ! Override stop time with value computed above. + CALL domain_clock_set( grid, stop_timestr=end_date_char ) + + ! TBH: for now, turn off stop time and let it run data-driven + CALL WRFU_ClockStopTimeDisable( grid%domain_clock, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_ClockStopTimeDisable(grid%domain_clock) FAILED', & + __FILE__ , & + __LINE__ ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG med_sidata_input: clock after stopTime set,' ) + + ! Here we define the initial time to process, for later use by the code. + + current_date_char = start_date_char + start_date = start_date_char // '.0000' + current_date = start_date + + CALL nl_set_bdyfrq ( grid%id , REAL(model_config_rec%interval_seconds) ) + + !!!!!!! Loop over each time period to process. + + CALL cpu_time ( t1 ) + DO loop = 1 , time_loop_max + + internal_time_loop = loop + IF ( ( grid%id .GT. 1 ) .AND. ( loop .GT. 1 ) .AND. (model_config_rec%grid_fdda(grid%id) .EQ. 0) ) EXIT + + print *,' ' + print *,'-----------------------------------------------------------------------------' + print *,' ' + print '(A,I2,A,A,A,I4,A,I4)' , & + ' Domain ',grid%id,': Current date being processed: ',current_date, ', which is loop #',loop,' out of ',time_loop_max + + ! After current_date has been set, fill in the julgmt stuff. + + CALL geth_julgmt ( config_flags%julyr , config_flags%julday , config_flags%gmt ) + + print *,'configflags%julyr, %julday, %gmt:',config_flags%julyr, config_flags%julday, config_flags%gmt + ! Now that the specific Julian info is available, save these in the model config record. + + CALL nl_set_gmt (grid%id, config_flags%gmt) + CALL nl_set_julyr (grid%id, config_flags%julyr) + CALL nl_set_julday (grid%id, config_flags%julday) + + ! Open the input file for real. This is either the "new" one or the "old" one. The "new" one could have + ! a suffix for the type of the data format. Check to see if either is around. + + CALL cpu_time ( t3 ) + IF ( grid%dyn_opt .EQ. dyn_em ) THEN + WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ', & + TRIM(config_flags%auxinput1_inname) + CALL wrf_debug ( 100 , wrf_err_message ) + IF ( config_flags%auxinput1_inname(1:8) .NE. 'wrf_real' ) THEN + CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , & + current_date_char , config_flags%io_form_auxinput1 ) + ELSE + CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , & + current_date_char ) + END IF + CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // & + ' for input; bad date in namelist or file not in directory' ) + ENDIF + END IF + + ! Input data. + + CALL wrf_debug ( 100 , 'med_sidata_input: calling input_aux_model_input1' ) + CALL input_aux_model_input1 ( idsi , grid , config_flags , ierr ) + CALL cpu_time ( t4 ) + WRITE ( wrf_err_message , FMT='(A,I10,A)' ) 'Timing for input ',NINT(t4-t3) ,' s.' + CALL wrf_debug( 0, wrf_err_message ) + + ! Possible optional SI input. This sets flags used by init_domain. + + CALL cpu_time ( t3 ) + IF ( loop .EQ. 1 ) THEN + already_been_here = .FALSE. + CALL wrf_debug ( 100 , 'med_sidata_input: calling init_module_optional_si_input' ) + CALL init_module_optional_si_input ( grid , config_flags ) + END IF + CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_si_input' ) + CALL optional_si_input ( grid , idsi ) + + ! Initialize the mother domain for this time period with input data. + + CALL wrf_debug ( 100 , 'med_sidata_input: calling init_domain' ) + grid%input_from_file = .true. + CALL init_domain ( grid ) + CALL cpu_time ( t4 ) + WRITE ( wrf_err_message , FMT='(A,I10,A)' ) 'Timing for processing ',NINT(t4-t3) ,' s.' + CALL wrf_debug( 0, wrf_err_message ) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + ! Close this file that is output from the SI and input to this pre-proc. + + CALL wrf_debug ( 100 , 'med_sidata_input: back from init_domain' ) + CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" ) + +! CALL start_domain ( grid , .TRUE. ) + +#ifdef WRF_CHEM + IF ( loop == 1 ) THEN + IF( grid%chem_opt > 0 ) then + ! Read the chemistry data from a previous wrf forecast (wrfout file) + IF(grid%chem_in_opt == 1 ) THEN + message = 'INITIALIZING CHEMISTRY WITH OLD SIMULATION' + CALL wrf_message ( message ) + + CALL input_ext_chem_file( grid ) + + IF(grid%bio_emiss_opt == 2 ) THEN + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_bioemiss ( grid , config_flags) + END IF + + ELSEIF(grid%chem_in_opt == 0)then + ! Generate chemistry data from a idealized vertical profile + message = 'STARTING WITH BACKGROUND CHEMISTRY ' + CALL wrf_message ( message ) + + CALL input_chem_profile ( grid ) + + IF(grid%bio_emiss_opt == 2 ) THEN + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_bioemiss ( grid , config_flags) + END IF + + ELSE + message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION' + CALL wrf_message ( message ) + ENDIF + ENDIF + ENDIF +#endif + + CALL cpu_time ( t3 ) + CALL assemble_output ( grid , config_flags , loop , time_loop_max ) + CALL cpu_time ( t4 ) + WRITE ( wrf_err_message , FMT='(A,I10,A)' ) 'Timing for output ',NINT(t4-t3) ,' s.' + CALL wrf_debug( 0, wrf_err_message ) + CALL cpu_time ( t2 ) + WRITE ( wrf_err_message , FMT='(A,I4,A,I10,A)' ) 'Timing for loop # ',loop,' = ',NINT(t2-t1) ,' s.' + CALL wrf_debug( 0, wrf_err_message ) + + ! If this is not the last time, we define the next time that we are going to process. + + IF ( loop .NE. time_loop_max ) THEN + CALL geth_newdate ( current_date_char , start_date_char , loop * model_config_rec%interval_seconds ) + current_date = current_date_char // '.0000' + CALL domain_clockprint ( 150, grid, & + 'DEBUG med_sidata_input: clock before current_date set,' ) + WRITE (wrf_err_message,*) & + 'DEBUG med_sidata_input: before currTime set, current_date = ',TRIM(current_date) + CALL wrf_debug ( 150 , wrf_err_message ) + CALL domain_clock_set( grid, current_date(1:19) ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG med_sidata_input: clock after current_date set,' ) + END IF + CALL cpu_time ( t1 ) + END DO + +END SUBROUTINE med_sidata_input + +SUBROUTINE compute_si_start_and_end ( & + start_year , start_month , start_day , start_hour , start_minute , start_second , & + end_year , end_month , end_day , end_hour , end_minute , end_second , & + interval_seconds , real_data_init_type , & + start_date_char , end_date_char , time_loop_max ) + + USE module_date_time + + IMPLICIT NONE + + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop + + CHARACTER(LEN=19) :: current_date_char , start_date_char , end_date_char , next_date_char + + WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + start_year,start_month,start_day,start_hour,start_minute,start_second + WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + end_year, end_month, end_day, end_hour, end_minute, end_second + + IF ( end_date_char .LT. start_date_char ) THEN + CALL wrf_error_fatal( 'Ending date in namelist ' // end_date_char // ' prior to beginning date ' // start_date_char ) + END IF + +! start_date = start_date_char // '.0000' + + ! Figure out our loop count for the processing times. + + time_loop = 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop,' to process = ',start_date_char,'.' + current_date_char = start_date_char + loop_count : DO + CALL geth_newdate ( next_date_char , current_date_char , interval_seconds ) + IF ( next_date_char .LT. end_date_char ) THEN + time_loop = time_loop + 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop,' to process = ',next_date_char,'.' + current_date_char = next_date_char + ELSE IF ( next_date_char .EQ. end_date_char ) THEN + time_loop = time_loop + 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop,' to process = ',next_date_char,'.' + PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.' + time_loop_max = time_loop + EXIT loop_count + ELSE IF ( next_date_char .GT. end_date_char ) THEN + PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.' + time_loop_max = time_loop + EXIT loop_count + END IF + END DO loop_count +END SUBROUTINE compute_si_start_and_end + +SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) + + USE module_big_step_utilities_em + USE module_domain + USE module_io_domain + USE module_configure + USE module_date_time + USE module_bc + IMPLICIT NONE + + TYPE(domain) :: grid + TYPE (grid_config_rec_type) :: config_flags + INTEGER , INTENT(IN) :: loop , time_loop_max + + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: i , j , k , idts + + INTEGER :: id1 , interval_seconds , ierr, rc, sst_update, grid_fdda + INTEGER , SAVE :: id, id2, id5 + CHARACTER (LEN=80) :: inpname , bdyname + CHARACTER(LEN= 4) :: loop_char +character *19 :: temp19 +character *24 :: temp24 , temp24b + + REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: mbdy2dtemp1 + REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2 + REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: mbdy2dtemp2 +real::t1,t2 + + ! Various sizes that we need to be concerned about. + + ids = grid%sd31 + ide = grid%ed31 + kds = grid%sd32 + kde = grid%ed32 + jds = grid%sd33 + jde = grid%ed33 + + ims = grid%sm31 + ime = grid%em31 + kms = grid%sm32 + kme = grid%em32 + jms = grid%sm33 + jme = grid%em33 + + ips = grid%sp31 + ipe = grid%ep31 + kps = grid%sp32 + kpe = grid%ep32 + jps = grid%sp33 + jpe = grid%ep33 + + ijds = MIN ( ids , jds ) + ijde = MAX ( ide , jde ) + + ! Boundary width, scalar value. + + spec_bdy_width = model_config_rec%spec_bdy_width + interval_seconds = model_config_rec%interval_seconds + sst_update = model_config_rec%sst_update + grid_fdda = model_config_rec%grid_fdda(grid%id) + + + IF ( loop .EQ. 1 ) THEN + + ! This is the space needed to save the current 3d data for use in computing + ! the lateral boundary tendencies. + + IF ( ALLOCATED ( ubdy3dtemp1 ) ) DEALLOCATE ( ubdy3dtemp1 ) + IF ( ALLOCATED ( vbdy3dtemp1 ) ) DEALLOCATE ( vbdy3dtemp1 ) + IF ( ALLOCATED ( tbdy3dtemp1 ) ) DEALLOCATE ( tbdy3dtemp1 ) + IF ( ALLOCATED ( pbdy3dtemp1 ) ) DEALLOCATE ( pbdy3dtemp1 ) + IF ( ALLOCATED ( qbdy3dtemp1 ) ) DEALLOCATE ( qbdy3dtemp1 ) + IF ( ALLOCATED ( mbdy2dtemp1 ) ) DEALLOCATE ( mbdy2dtemp1 ) + IF ( ALLOCATED ( ubdy3dtemp2 ) ) DEALLOCATE ( ubdy3dtemp2 ) + IF ( ALLOCATED ( vbdy3dtemp2 ) ) DEALLOCATE ( vbdy3dtemp2 ) + IF ( ALLOCATED ( tbdy3dtemp2 ) ) DEALLOCATE ( tbdy3dtemp2 ) + IF ( ALLOCATED ( pbdy3dtemp2 ) ) DEALLOCATE ( pbdy3dtemp2 ) + IF ( ALLOCATED ( qbdy3dtemp2 ) ) DEALLOCATE ( qbdy3dtemp2 ) + IF ( ALLOCATED ( mbdy2dtemp2 ) ) DEALLOCATE ( mbdy2dtemp2 ) + + ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( mbdy2dtemp1(ims:ime,1:1, jms:jme) ) + ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) ) + + ! Open the wrfinput file. From this program, this is an *output* file. + + CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfinput for writing' ) + ENDIF + IF(sst_update .EQ. 1)THEN + CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 ) + CALL open_w_dataset ( id5, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' ) + ENDIF + ENDIF +! CALL calc_current_date ( grid%id , 0. ) + CALL output_model_input ( id1, grid , config_flags , ierr ) + CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) + IF(sst_update .EQ. 1)THEN + CALL output_aux_model_input5 ( id5, grid , config_flags , ierr ) + ENDIF + + ! We need to save the 3d data to compute a difference during the next loop. Couple the + ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor. + + CALL couple ( grid%em_mu_2 , grid%em_mub , ubdy3dtemp1 , grid%em_u_2 , 'u' , grid%msfu , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , vbdy3dtemp1 , grid%em_v_2 , 'v' , grid%msfv , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , tbdy3dtemp1 , grid%em_t_2 , 't' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , pbdy3dtemp1 , grid%em_ph_2 , 'h' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , qbdy3dtemp1 , grid%moist(:,:,:,P_QV) , 't' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + + DO j = jps , MIN(jde-1,jpe) + DO i = ips , MIN(ide-1,ipe) + mbdy2dtemp1(i,1,j) = grid%em_mu_2(i,j) + END DO + END DO + + IF(grid_fdda .EQ. 1)THEN +! for fdda + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + grid%fdda3d(i,k,j,p_u_ndg_old) = grid%em_u_2(i,k,j) + grid%fdda3d(i,k,j,p_v_ndg_old) = grid%em_v_2(i,k,j) + grid%fdda3d(i,k,j,p_t_ndg_old) = grid%em_t_2(i,k,j) + grid%fdda3d(i,k,j,p_q_ndg_old) = grid%moist(i,k,j,P_QV) + grid%fdda3d(i,k,j,p_ph_ndg_old) = grid%em_ph_2(i,k,j) + END DO + END DO + END DO + + DO j = jps , jpe + DO i = ips , ipe + grid%fdda2d(i,1,j,p_mu_ndg_old) = grid%em_mu_2(i,j) + END DO + END DO + ENDIF + + + ! There are 2 components to the lateral boundaries. First, there is the starting + ! point of this time period - just the outer few rows and columns. + + CALL stuff_bdy ( ubdy3dtemp1 , grid%em_u_bxs, grid%em_u_bxe, grid%em_u_bys, grid%em_u_bye, & + 'U' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( vbdy3dtemp1 , grid%em_v_bxs, grid%em_v_bxe, grid%em_v_bys, grid%em_v_bye, & + 'V' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( tbdy3dtemp1 , grid%em_t_bxs, grid%em_t_bxe, grid%em_t_bys, grid%em_t_bye, & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( pbdy3dtemp1 , grid%em_ph_bxs, grid%em_ph_bxe, grid%em_ph_bys, grid%em_ph_bye, & + 'W' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( qbdy3dtemp1 , grid%moist_bxs(:,:,:,P_QV), grid%moist_bxe(:,:,:,P_QV), & + grid%moist_bys(:,:,:,P_QV), grid%moist_bye(:,:,:,P_QV), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( mbdy2dtemp1 , grid%em_mu_bxs, grid%em_mu_bxe, grid%em_mu_bys, grid%em_mu_bye, & + 'M' , spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + + ELSE IF ( loop .GT. 1 ) THEN + + IF(sst_update .EQ. 1)THEN + CALL output_aux_model_input5 ( id5, grid , config_flags , ierr ) + ENDIF + + ! Open the boundary file. + + + IF ( loop .eq. 2 ) THEN + IF(grid%id .eq. 1)THEN + CALL construct_filename1( bdyname , 'wrfbdy' , grid%id , 2 ) + CALL open_w_dataset ( id, TRIM(bdyname) , grid , config_flags , output_boundary , "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfbdy for writing' ) + ENDIF + ENDIF + IF(grid_fdda .EQ. 1)THEN +! for fdda + CALL construct_filename1( inpname , 'wrffdda' , grid%id , 2 ) + CALL open_w_dataset ( id2, TRIM(inpname) , grid , config_flags , output_aux_model_input10 , "DATASET=AUXINPUT10", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrffdda for writing' ) + ENDIF + ENDIF + ELSE + IF ( .NOT. domain_clockisstoptime(grid) ) THEN + CALL domain_clockadvance( grid ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock after ClockAdvance,' ) + ENDIF + END IF + + + ! Couple this time period's data with total mu, and save it in the *bdy3dtemp2 arrays. + + CALL couple ( grid%em_mu_2 , grid%em_mub , ubdy3dtemp2 , grid%em_u_2 , 'u' , grid%msfu , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , vbdy3dtemp2 , grid%em_v_2 , 'v' , grid%msfv , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , tbdy3dtemp2 , grid%em_t_2 , 't' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , pbdy3dtemp2 , grid%em_ph_2 , 'h' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + CALL couple ( grid%em_mu_2 , grid%em_mub , qbdy3dtemp2 , grid%moist(:,:,:,P_QV) , 't' , grid%msft , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + + DO j = jps , jpe + DO i = ips , ipe + mbdy2dtemp2(i,1,j) = grid%em_mu_2(i,j) + END DO + END DO + + IF(grid_fdda .EQ. 1)THEN +! for fdda + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + grid%fdda3d(i,k,j,p_u_ndg_new) = grid%em_u_2(i,k,j) + grid%fdda3d(i,k,j,p_v_ndg_new) = grid%em_v_2(i,k,j) + grid%fdda3d(i,k,j,p_t_ndg_new) = grid%em_t_2(i,k,j) + grid%fdda3d(i,k,j,p_q_ndg_new) = grid%moist(i,k,j,P_QV) + grid%fdda3d(i,k,j,p_ph_ndg_new) = grid%em_ph_2(i,k,j) + END DO + END DO + END DO + + DO j = jps , jpe + DO i = ips , ipe + grid%fdda2d(i,1,j,p_mu_ndg_new) = grid%em_mu_2(i,j) + END DO + END DO + ENDIF + + ! During all of the loops after the first loop, we first compute the boundary + ! tendencies with the current data values (*bdy3dtemp2 arrays) and the previously + ! saved information stored in the *bdy3dtemp1 arrays. + + CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , REAL(interval_seconds) , & + grid%em_u_btxs, grid%em_u_btxe, & + grid%em_u_btys, grid%em_u_btye, & + 'U' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , REAL(interval_seconds) , & + grid%em_v_btxs, grid%em_v_btxe, & + grid%em_v_btys, grid%em_v_btye, & + 'V' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , REAL(interval_seconds) , & + grid%em_t_btxs, grid%em_t_btxe, & + grid%em_t_btys, grid%em_t_btye, & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , REAL(interval_seconds) , & + grid%em_ph_btxs, grid%em_ph_btxe, & + grid%em_ph_btys, grid%em_ph_btye, & + 'W' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , REAL(interval_seconds) , & + grid%moist_btxs(:,:,:,P_QV), grid%moist_btxe(:,:,:,P_QV), & + grid%moist_btys(:,:,:,P_QV), grid%moist_btye(:,:,:,P_QV), & + 'T' , & + spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , REAL(interval_seconds) , & + grid%em_mu_btxs, grid%em_mu_btxe, & + grid%em_mu_btys, grid%em_mu_btye, & + 'M' , & + spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + ! Both pieces of the boundary data are now available to be written (initial time and tendency). + ! This looks ugly, these date shifting things. What's it for? We want the "Times" variable + ! in the lateral BDY file to have the valid times of when the initial fields are written. + ! That's what the loop-2 thingy is for with the start date. We increment the start_date so + ! that the starting time in the attributes is the second time period. Why you may ask. I + ! agree, why indeed. + + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock before 1st current_date set,' ) + WRITE (wrf_err_message,*) & + 'DEBUG assemble_output: before 1st currTime set, current_date = ',TRIM(current_date) + CALL wrf_debug ( 150 , wrf_err_message ) + CALL domain_clock_set( grid, current_date(1:19) ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock after 1st current_date set,' ) + + temp24= current_date + temp24b=start_date + start_date = current_date + CALL geth_newdate ( temp19 , temp24b(1:19) , (loop-2) * model_config_rec%interval_seconds ) + current_date = temp19 // '.0000' + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock before 2nd current_date set,' ) + WRITE (wrf_err_message,*) & + 'DEBUG assemble_output: before 2nd currTime set, current_date = ',TRIM(current_date) + CALL wrf_debug ( 150 , wrf_err_message ) + CALL domain_clock_set( grid, current_date(1:19) ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock after 2nd current_date set,' ) + IF(grid%id .EQ. 1)THEN + print *,'LBC valid between these times ',current_date, ' ',start_date + CALL output_boundary ( id, grid , config_flags , ierr ) + ENDIF +! for fdda + IF(grid_fdda .EQ. 1) THEN + CALL output_aux_model_input10 ( id2, grid , config_flags , ierr ) + END IF + current_date = temp24 + start_date = temp24b + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock before 3rd current_date set,' ) + WRITE (wrf_err_message,*) & + 'DEBUG assemble_output: before 3rd currTime set, current_date = ',TRIM(current_date) + CALL wrf_debug ( 150 , wrf_err_message ) + CALL domain_clock_set( grid, current_date(1:19) ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG assemble_output: clock after 3rd current_date set,' ) + + ! OK, for all of the loops, we output the initialzation data, which would allow us to + ! start the model at any of the available analysis time periods. + +! WRITE ( loop_char , FMT = '(I4.4)' ) loop +! CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) +! IF ( ierr .NE. 0 ) THEN +! CALL wrf_error_fatal( 'real: error opening wrfinput'//loop_char//' for writing' ) +! ENDIF + +! CALL calc_current_date ( grid%id , 0. ) +! CALL output_model_input ( id1, grid , config_flags , ierr ) +! CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) + ! Is this or is this not the last time time? We can remove some unnecessary + ! stores if it is not. + IF ( loop .LT. time_loop_max ) THEN + + ! We need to save the 3d data to compute a difference during the next loop. Couple the + ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor. + ! We load up the boundary data again for use in the next loop. + + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j) + vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j) + tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j) + pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j) + qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j) + END DO + END DO + END DO + + DO j = jps , jpe + DO i = ips , ipe + mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j) + END DO + END DO + + IF(grid_fdda .EQ. 1)THEN +! for fdda + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + grid%fdda3d(i,k,j,p_u_ndg_old) = grid%fdda3d(i,k,j,p_u_ndg_new) + grid%fdda3d(i,k,j,p_v_ndg_old) = grid%fdda3d(i,k,j,p_v_ndg_new) + grid%fdda3d(i,k,j,p_t_ndg_old) = grid%fdda3d(i,k,j,p_t_ndg_new) + grid%fdda3d(i,k,j,p_q_ndg_old) = grid%fdda3d(i,k,j,p_q_ndg_new) + grid%fdda3d(i,k,j,p_ph_ndg_old) = grid%fdda3d(i,k,j,p_ph_ndg_new) + END DO + END DO + END DO + + DO j = jps , jpe + DO i = ips , ipe + grid%fdda2d(i,1,j,p_mu_ndg_old) = grid%fdda2d(i,1,j,p_mu_ndg_new) + END DO + END DO + ENDIF + + ! There are 2 components to the lateral boundaries. First, there is the starting + ! point of this time period - just the outer few rows and columns. + + CALL stuff_bdy ( ubdy3dtemp1 , grid%em_u_bxs, grid%em_u_bxe, grid%em_u_bys, grid%em_u_bye, & + 'U' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( vbdy3dtemp1 , grid%em_v_bxs, grid%em_v_bxe, grid%em_v_bys, grid%em_v_bye, & + 'V' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( tbdy3dtemp1 , grid%em_t_bxs, grid%em_t_bxe, grid%em_t_bys, grid%em_t_bye, & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( pbdy3dtemp1 , grid%em_ph_bxs, grid%em_ph_bxe, grid%em_ph_bys, grid%em_ph_bye, & + 'W' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( qbdy3dtemp1 , grid%moist_bxs(:,:,:,P_QV), grid%moist_bxe(:,:,:,P_QV), & + grid%moist_bys(:,:,:,P_QV), grid%moist_bye(:,:,:,P_QV), & + 'T' , spec_bdy_width , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + CALL stuff_bdy ( mbdy2dtemp1 , grid%em_mu_bxs, grid%em_mu_bxe, grid%em_mu_bys, grid%em_mu_bye, & + 'M' , spec_bdy_width , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + ELSE IF ( loop .EQ. time_loop_max ) THEN + + ! If this is the last time through here, we need to close the files. + + IF(grid%id .EQ. 1)CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" ) + IF(grid_fdda .EQ. 1)CALL close_dataset ( id2 , config_flags , "DATASET=AUXINPUT10" ) + IF(sst_update .EQ. 1)THEN + CALL close_dataset ( id5 , config_flags , "DATASET=AUXINPUT5" ) + ENDIF + + END IF + + END IF + +END SUBROUTINE assemble_output diff --git a/wrfv2_fire/main/real_nmm.F b/wrfv2_fire/main/real_nmm.F new file mode 100644 index 00000000..f7025cef --- /dev/null +++ b/wrfv2_fire/main/real_nmm.F @@ -0,0 +1,1279 @@ +! Create an initial data set for the WRF model based on real data. This +! program is specifically set up for the NMM core. + +PROGRAM real_data + + USE module_machine + USE module_domain + USE module_initialize + USE module_io_domain + USE module_driver_constants + USE module_configure + USE module_timing +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_input_chem_bioemiss +#endif + USE module_utility +#ifdef DM_PARALLEL + USE module_dm +#endif + + IMPLICIT NONE + + REAL :: time , bdyfrq + + INTEGER :: loop , levels_to_process , debug_level + + + TYPE(domain) , POINTER :: null_domain + TYPE(domain) , POINTER :: grid + TYPE (grid_config_rec_type) :: config_flags + INTEGER :: number_at_same_level + + INTEGER :: max_dom, domain_id + INTEGER :: idum1, idum2 +#ifdef DM_PARALLEL + INTEGER :: nbytes +! INTEGER, PARAMETER :: configbuflen = 2*1024 + INTEGER, PARAMETER :: configbuflen = 4*CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: i , j , k , idts + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + + CHARACTER (LEN=80) :: message + + INTEGER :: start_year , start_month , start_day + INTEGER :: start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , & + end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop, rc + REAL :: t1,t2 + +#include "version_decl" + + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + + ! Define the name of this program (program_name defined in module_domain) + + program_name = "REAL_NMM " // TRIM(release_version) // " PREPROCESSOR" + +#ifdef DM_PARALLEL + CALL disable_quilting +#endif + +! CALL start() + + ! Initialize the modules used by the WRF system. + ! Many of the CALLs made from the + ! init_modules routine are NO-OPs. Typical initializations + ! are: the size of a + ! REAL, setting the file handles to a pre-use value, defining moisture and + ! chemistry indices, etc. + + CALL wrf_debug ( 100 , 'real_nmm: calling init_modules ' ) + +!!!! CALL init_modules + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc ) + CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called) + + ! The configuration switches mostly come from the NAMELIST input. + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + write(message,*) 'call initial_config' + CALL wrf_message ( message ) + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + CALL wrf_message ( program_name ) + + ! Allocate the space for the mother of all domains. + + NULLIFY( null_domain ) + CALL wrf_debug ( 100 , 'real_nmm: calling alloc_and_configure_domain ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + grid => head_grid + +#include "deref_kludge.h" + CALL Setup_Timekeeping ( grid ) + CALL domain_clock_set( grid, & + time_step_seconds=model_config_rec%interval_seconds ) + CALL wrf_debug ( 100 , 'real_nmm: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 ) + + CALL wrf_debug ( 100 , 'real_nmm: calling model_to_grid_config_rec ' ) + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + write(message,*) 'after model_to_grid_config_rec, e_we, e_sn are: ', & + config_flags%e_we, config_flags%e_sn + CALL wrf_message(message) + + ! Initialize the WRF IO: open files, init file handles, etc. + + CALL wrf_debug ( 100 , 'real_nmm: calling init_wrfio' ) + CALL init_wrfio + +! Some of the configuration values may have been modified from the initial READ +! of the NAMELIST, so we re-broadcast the configuration records. + +#ifdef DM_PARALLEL + CALL wrf_debug ( 100 , 'real_nmm: re-broadcast the configuration records' ) + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + ! No looping in this layer. + + CALL med_sidata_input ( grid , config_flags ) + + ! We are done. + + CALL wrf_debug ( 0 , 'real_nmm: SUCCESS COMPLETE REAL_NMM INIT' ) + +#ifdef DM_PARALLEL + CALL wrf_dm_shutdown +#endif + + CALL WRFU_Finalize( rc=rc ) + +END PROGRAM real_data + +SUBROUTINE med_sidata_input ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + ! Model layer + USE module_configure + USE module_bc_time_utilities + USE module_initialize + USE module_optional_si_input +#ifdef WRF_CHEM + USE module_input_chem_data + USE module_input_chem_bioemiss +#endif + + USE module_si_io_nmm + + USE module_date_time + + IMPLICIT NONE + + + ! Interface + INTERFACE + SUBROUTINE start_domain ( grid , allowed_to_read ) + USE module_domain + TYPE (domain) grid + LOGICAL, INTENT(IN) :: allowed_to_read + END SUBROUTINE start_domain + END INTERFACE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) :: config_flags + ! Local + INTEGER :: time_step_begin_restart + INTEGER :: idsi , ierr , myproc + CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=132) :: message + + CHARACTER(LEN=19) :: start_date_char , end_date_char , & + current_date_char , next_date_char + + INTEGER :: time_loop_max , loop + INTEGER :: julyr , julday , LEN + + INTEGER :: io_form_auxinput1 + INTEGER, EXTERNAL :: use_package + + LOGICAL :: using_binary_wrfsi + + REAL :: gmt + REAL :: t1,t2 + + INTEGER :: numx_sm_levels_input,numx_st_levels_input + REAL,DIMENSION(100) :: smx_levels_input,stx_levels_input + + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + +#include "deref_kludge.h" + + + grid%input_from_file = .true. + grid%input_from_file = .false. + + CALL compute_si_start_and_end ( model_config_rec%start_year (grid%id) , & + model_config_rec%start_month (grid%id) , & + model_config_rec%start_day (grid%id) , & + model_config_rec%start_hour (grid%id) , & + model_config_rec%start_minute(grid%id) , & + model_config_rec%start_second(grid%id) , & + model_config_rec% end_year (grid%id) , & + model_config_rec% end_month (grid%id) , & + model_config_rec% end_day (grid%id) , & + model_config_rec% end_hour (grid%id) , & + model_config_rec% end_minute(grid%id) , & + model_config_rec% end_second(grid%id) , & + model_config_rec%interval_seconds , & + model_config_rec%real_data_init_type , & + start_date_char , end_date_char , time_loop_max ) + + ! Here we define the initial time to process, for later use by the code. + + current_date_char = start_date_char +! start_date = start_date_char // '.0000' + start_date = start_date_char + current_date = start_date + + CALL nl_set_bdyfrq ( grid%id , REAL(model_config_rec%interval_seconds) ) + + ! Loop over each time period to process. + + write(message,*) 'time_loop_max: ', time_loop_max + CALL wrf_message(message) + DO loop = 1 , time_loop_max + + internal_time_loop=loop + + write(message,*) 'loop=', loop + CALL wrf_message(message) + + write(message,*) '-----------------------------------------------------------' + CALL wrf_message(message) + + write(message,*) ' ' + CALL wrf_message(message) + write(message,'(A,A,A,I2,A,I2)') ' Current date being processed: ', & + current_date, ', which is loop #',loop,' out of ',time_loop_max + CALL wrf_message(message) + + ! After current_date has been set, fill in the julgmt stuff. + + CALL geth_julgmt ( config_flags%julyr , config_flags%julday , & + config_flags%gmt ) + + ! Now that the specific Julian info is available, + ! save these in the model config record. + + CALL nl_set_gmt (grid%id, config_flags%gmt) + CALL nl_set_julyr (grid%id, config_flags%julyr) + CALL nl_set_julday (grid%id, config_flags%julday) + + CALL nl_get_io_form_auxinput1( 1, io_form_auxinput1 ) + + using_binary_wrfsi=.false. + + + IF ( grid%dyn_opt .EQ. dyn_nmm ) THEN + + write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname) + CALL wrf_message(message) + + IF (config_flags%auxinput1_inname(1:10) .eq. 'real_input') THEN + using_binary_wrfsi=.true. + ENDIF + + SELECT CASE ( use_package(io_form_auxinput1) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + + ! Open the wrfinput file. + + current_date_char(11:11)='_' + + WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname) + CALL wrf_debug ( 100 , wrf_err_message ) + IF ( config_flags%auxinput1_inname(1:8) .NE. 'wrf_real' ) THEN + CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , & + config_flags%io_form_auxinput1 ) + ELSE + CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char ) + END IF + CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' ) + ENDIF + + + ! Input data. + + CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf') + CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr ) + + ! Possible optional SI input. This sets flags used by init_domain. + + IF ( loop .EQ. 1 ) THEN + CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' ) + CALL init_module_optional_si_input ( grid , config_flags ) +!mp END IF + CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_si_input' ) + CALL optional_si_input ( grid , idsi ) + + ENDIF + +! + CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" ) + +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + + ! Possible optional SI input. This sets flags used by init_domain. + + IF ( loop .EQ. 1 ) THEN + CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' ) + CALL init_module_optional_si_input ( grid , config_flags ) + END IF + + IF (using_binary_wrfsi) THEN + + current_date_char(11:11)='_' + CALL read_si ( grid, current_date_char ) + current_date_char(11:11)='T' + + ELSE + + write(message,*) 'binary WPS branch' + CALL wrf_message(message) + CALL wrf_error_fatal("binary WPS support deferred for initial release") + +! WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname) +! CALL wrf_debug ( 100 , wrf_err_message ) +! CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , config_flags%io_form_auxinput1 ) +! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) + +! IF ( ierr .NE. 0 ) THEN +! CALL wrf_debug( 1 , 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' ) +! CALL wrf_debug( 1 , 'will try again without the extension' ) +! CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char ) +! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) +! IF ( ierr .NE. 0 ) THEN +! CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' ) +! ENDIF +! ENDIF + + ! Input data. + +!!! believe problematic as binary data from WPS will be XYZ ordered, while this +!!! version of WRF will read in as XZY. OR read all fields in as unique +!!! Registry items that are XYZ, then swap. More memory, and more overhead, but +!!! better than having a stand alone "read_si" type code?? + +! CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf') +! CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr ) + + ! Possible optional SI input. This sets flags used by init_domain. + +! IF ( loop .EQ. 1 ) THEN +! CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_si_input' ) +! CALL init_module_optional_si_input ( grid , config_flags ) +! END IF +! CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_si_input' ) +! +! CALL optional_si_input ( grid , idsi ) +! flag_metgrid=1 + +! +! CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" ) + + ENDIF +#endif + CASE DEFAULT + CALL wrf_error_fatal('real: not valid io_form_auxinput1') + END SELECT + + ELSE + call wrf_error_fatal("WRONG DYNAMICAL CORE SELECTED FOR THIS VERSION OF REAL - CHECK dyn_opt in namelist.input file") + ENDIF + + grid%nmm_islope=1 + grid%vegfra=grid%nmm_vegfrc + grid%nmm_dfrlg=grid%nmm_dfl/9.81 + + grid%isurban=1 + grid%isoilwater=14 + + ! Initialize the mother domain for this time period with input data. + + CALL wrf_debug ( 100 , 'med_sidata_input: calling init_domain' ) + grid%input_from_file = .true. + + CALL init_domain ( grid ) + + CALL model_to_grid_config_rec ( grid%id, model_config_rec, config_flags ) + + ! Close this file that is output from the SI and input to this pre-proc. + + CALL wrf_debug ( 100 , 'med_sidata_input: back from init_domain' ) + + +!!! not sure about this, but doesnt seem like needs to be called each time + IF ( loop .EQ. 1 ) THEN + CALL start_domain ( grid , .TRUE.) + END IF + +#ifdef WRF_CHEM + IF ( loop == 1 ) THEN +! IF ( ( grid%chem_opt .EQ. RADM2 ) .OR. & +! ( grid%chem_opt .EQ. RADM2SORG ) .OR. & +! ( grid%chem_opt .EQ. RACM ) .OR. & +! ( grid%chem_opt .EQ. RACMSORG ) ) THEN + IF( grid%chem_opt > 0 ) then + ! Read the chemistry data from a previous wrf forecast (wrfout file) + IF(grid%chem_in_opt == 1 ) THEN + message = 'INITIALIZING CHEMISTRY WITH OLD SIMULATION' + CALL wrf_message ( message ) + + CALL input_ext_chem_file( grid ) + + IF(grid%bio_emiss_opt == BEIS311 ) THEN + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_bioemiss ( grid , config_flags) + END IF + + ELSEIF(grid%chem_in_opt == 0)then + ! Generate chemistry data from a idealized vertical profile + message = 'STARTING WITH BACKGROUND CHEMISTRY ' + CALL wrf_message ( message ) + + write(message,*)' ETA1 ' + CALL wrf_message ( message ) +! write(message,*) grid%nmm_eta1 +! CALL wrf_message ( message ) + + CALL input_chem_profile ( grid ) + + IF(grid%bio_emiss_opt == BEIS311 ) THEN + message = 'READING BEIS3.11 EMISSIONS DATA' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_bioemiss ( grid , config_flags) + END IF + + ELSE + message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION' + CALL wrf_message ( message ) + ENDIF + ENDIF + ENDIF +#endif + + config_flags%isurban=1 + config_flags%isoilwater=14 + + CALL assemble_output ( grid , config_flags , loop , time_loop_max ) + + ! Here we define the next time that we are going to process. + + CALL geth_newdate ( current_date_char , start_date_char , & + loop * model_config_rec%interval_seconds ) + current_date = current_date_char // '.0000' + + CALL domain_clock_set( grid, current_date(1:19) ) + + write(message,*) 'current_date= ', current_date + CALL wrf_message(message) + + END DO +END SUBROUTINE med_sidata_input + +SUBROUTINE compute_si_start_and_end ( & + start_year, start_month, start_day, start_hour, & + start_minute, start_second, & + end_year , end_month , end_day , end_hour , & + end_minute , end_second , & + interval_seconds , real_data_init_type , & + start_date_char , end_date_char , time_loop_max ) + + USE module_date_time + + IMPLICIT NONE + + INTEGER :: start_year , start_month , start_day , & + start_hour , start_minute , start_second + INTEGER :: end_year , end_month , end_day , & + end_hour , end_minute , end_second + INTEGER :: interval_seconds , real_data_init_type + INTEGER :: time_loop_max , time_loop + + CHARACTER(LEN=132) :: message + CHARACTER(LEN=19) :: current_date_char , start_date_char , & + end_date_char , next_date_char + +! WRITE ( start_date_char , FMT = & +! '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & +! start_year,start_month,start_day,start_hour,start_minute,start_second +! WRITE ( end_date_char , FMT = & +! '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & +! end_year, end_month, end_day, end_hour, end_minute, end_second + + WRITE ( start_date_char , FMT = & + '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) & + start_year,start_month,start_day,start_hour,start_minute,start_second + WRITE ( end_date_char , FMT = & + '(I4.4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)' ) & + end_year, end_month, end_day, end_hour, end_minute, end_second + +! start_date = start_date_char // '.0000' + + ! Figure out our loop count for the processing times. + + time_loop = 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop, & + ' to process = ',start_date_char,'.' + current_date_char = start_date_char + loop_count : DO + CALL geth_newdate (next_date_char, current_date_char, interval_seconds ) + IF ( next_date_char .LT. end_date_char ) THEN + time_loop = time_loop + 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop,& + ' to process = ',next_date_char,'.' + current_date_char = next_date_char + ELSE IF ( next_date_char .EQ. end_date_char ) THEN + time_loop = time_loop + 1 + PRINT '(A,I4,A,A,A)','Time period #',time_loop,& + ' to process = ',next_date_char,'.' + PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.' + time_loop_max = time_loop + EXIT loop_count + ELSE IF ( next_date_char .GT. end_date_char ) THEN + PRINT '(A,I4,A)','Total analysis times to input = ',time_loop,'.' + time_loop_max = time_loop + EXIT loop_count + END IF + END DO loop_count + write(message,*) 'done in si_start_and_end' + CALL wrf_message(message) +END SUBROUTINE compute_si_start_and_end + +SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) + +!!! replace with something? USE module_big_step_utilities_em + + USE module_domain + USE module_io_domain + USE module_configure + USE module_date_time + USE module_bc + IMPLICIT NONE + + TYPE(domain) :: grid + TYPE (grid_config_rec_type) :: config_flags + INTEGER , INTENT(IN) :: loop , time_loop_max + + INTEGER :: ids , ide , jds , jde , kds , kde + INTEGER :: ims , ime , jms , jme , kms , kme + INTEGER :: ips , ipe , jps , jpe , kps , kpe + INTEGER :: ijds , ijde , spec_bdy_width + INTEGER :: inc_h,inc_v + INTEGER :: i , j , k , idts + + INTEGER :: id1 , interval_seconds , ierr, rc + INTEGER , SAVE :: id + CHARACTER (LEN=80) :: inpname , bdyname + CHARACTER(LEN= 4) :: loop_char + CHARACTER(LEN=132) :: message +character *19 :: temp19 +character *24 :: temp24 , temp24b + + REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp1 , vbdy3dtemp1 ,& + tbdy3dtemp1 , & + cwmbdy3dtemp1 , qbdy3dtemp1,& + q2bdy3dtemp1 , pdbdy2dtemp1 + REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: ubdy3dtemp2 , vbdy3dtemp2 , & + tbdy3dtemp2 , & + cwmbdy3dtemp2 , qbdy3dtemp2, & + q2bdy3dtemp2, pdbdy2dtemp2 + REAL :: t1,t2 + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + +#include "deref_kludge.h" + + + ! Various sizes that we need to be concerned about. + + ids = grid%sd31 + ide = grid%ed31-1 ! 030730tst + kds = grid%sd32 + kde = grid%ed32-1 ! 030730tst + jds = grid%sd33 + jde = grid%ed33-1 ! 030730tst + + ims = grid%sm31 + ime = grid%em31 + kms = grid%sm32 + kme = grid%em32 + jms = grid%sm33 + jme = grid%em33 + + ips = grid%sp31 + ipe = grid%ep31-1 ! 030730tst + kps = grid%sp32 + kpe = grid%ep32-1 ! 030730tst + jps = grid%sp33 + jpe = grid%ep33-1 ! 030730tst + + if (IPE .ne. IDE) IPE=IPE+1 + if (JPE .ne. JDE) JPE=JPE+1 + + write(message,*) 'assemble output (ids,ide): ', ids,ide + CALL wrf_message(message) + write(message,*) 'assemble output (ims,ime): ', ims,ime + CALL wrf_message(message) + write(message,*) 'assemble output (ips,ipe): ', ips,ipe + CALL wrf_message(message) + + write(message,*) 'assemble output (jds,jde): ', jds,jde + CALL wrf_message(message) + write(message,*) 'assemble output (jms,jme): ', jms,jme + CALL wrf_message(message) + write(message,*) 'assemble output (jps,jpe): ', jps,jpe + CALL wrf_message(message) + + write(message,*) 'assemble output (kds,kde): ', kds,kde + CALL wrf_message(message) + write(message,*) 'assemble output (kms,kme): ', kms,kme + CALL wrf_message(message) + write(message,*) 'assemble output (kps,kpe): ', kps,kpe + CALL wrf_message(message) + + ijds = MIN ( ids , jds ) +!mptest030805 ijde = MAX ( ide , jde ) + ijde = MAX ( ide , jde ) + 1 ! to make stuff_bdy dimensions consistent with alloc + + ! Boundary width, scalar value. + + spec_bdy_width = model_config_rec%spec_bdy_width + interval_seconds = model_config_rec%interval_seconds + +!----------------------------------------------------------------------- +! + main_loop_test: IF ( loop .EQ. 1 ) THEN +! +!----------------------------------------------------------------------- + + ! This is the space needed to save the current 3d data for use in computing + ! the lateral boundary tendencies. + + ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( cwmbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( q2bdy3dtemp1(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pdbdy2dtemp1(ims:ime, 1:1 ,jms:jme) ) + + ubdy3dtemp1=0. + vbdy3dtemp1=0. + tbdy3dtemp1=0. + qbdy3dtemp1=0. + cwmbdy3dtemp1=0. + q2bdy3dtemp1=0. + pdbdy2dtemp1=0. + + ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( cwmbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( q2bdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( pdbdy2dtemp2(ims:ime, 1:1 ,jms:jme) ) + + ubdy3dtemp2=0. + vbdy3dtemp2=0. + tbdy3dtemp2=0. + qbdy3dtemp2=0. + cwmbdy3dtemp2=0. + q2bdy3dtemp2=0. + pdbdy2dtemp2=0. + + ! Open the wrfinput file. From this program, this is an *output* file. + + CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 ) + + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , & + output_model_input , "DATASET=INPUT", ierr ) + + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfinput for writing' ) + ENDIF + +! CALL calc_current_date ( grid%id , 0. ) +! grid%write_metadata = .true. + + write(message,*) 'making call to output_model_input' + CALL wrf_message(message) + + CALL output_model_input ( id1, grid , config_flags , ierr ) + +!*** +!*** CLOSE THE WRFINPUT DATASET +!*** + CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) + + ! We need to save the 3d data to compute a + ! difference during the next loop. + +! +!----------------------------------------------------------------------- +!*** SOUTHERN BOUNDARY +!----------------------------------------------------------------------- +! + + IF(JPS==JDS)THEN + J=1 + DO k = kps , MIN(kde,kpe) + DO i = ips , MIN(ide,ipe) + ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j) + tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j) + END DO + END DO + + DO i = ips , MIN(ide,ipe) + pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j) + END DO + ENDIF + +! +!----------------------------------------------------------------------- +!*** NORTHERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(JPE==JDE)THEN + J=MIN(JDE,JPE) + DO k = kps , MIN(kde,kpe) + DO i = ips , MIN(ide,ipe) + ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j) + tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j) + END DO + END DO + + DO i = ips , MIN(ide,ipe) + pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j) + END DO + ENDIF + +! +!----------------------------------------------------------------------- +!*** WESTERN BOUNDARY +!----------------------------------------------------------------------- +! + write(message,*) 'western boundary, store winds over J: ', jps, min(jpe,jde) + CALL wrf_message(message) + IF(IPS==IDS)THEN + I=1 + DO k = kps , MIN(kde,kpe) + inc_h=mod(jps+1,2) + DO j = jps+inc_h, min(jde,jpe),2 + + if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then + tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j) + if(k==1)then + write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,k,j)=',tbdy3dtemp1(i,k,j) + CALL wrf_debug(10,message) + endif + endif + END DO + END DO + + DO k = kps , MIN(kde,kpe) + inc_v=mod(jps,2) + DO j = jps+inc_v, min(jde,jpe),2 + if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then + ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j) + endif + END DO + END DO +! + inc_h=mod(jps+1,2) + DO j = jps+inc_h, min(jde,jpe),2 + if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then + pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j) + write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,1,j)=',pdbdy2dtemp1(i,1,j) + CALL wrf_debug(10,message) + endif + END DO + ENDIF +! +!----------------------------------------------------------------------- +!*** EASTERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(IPE==IDE)THEN + I=MIN(IDE,IPE) +! + DO k = kps , MIN(kde,kpe) +! +!*** Make sure the J loop is on the global boundary +! + inc_h=mod(jps+1,2) + DO j = jps+inc_h, min(jde,jpe),2 + if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then + tbdy3dtemp1(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp1(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp1(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp1(i,k,j) = grid%nmm_q2(i,k,j) + endif + END DO + END DO + + DO k = kps , MIN(kde,kpe) + inc_v=mod(jps,2) + DO j = jps+inc_v, min(jde,jpe),2 + if (J .ge. 2 .and. J .le. JDE-1 .and. mod(J,2) .eq. 0) then + ubdy3dtemp1(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp1(i,k,j) = grid%nmm_v(i,k,j) + endif + END DO + END DO +! + inc_h=mod(jps+1,2) + DO j = jps+inc_h, min(jde,jpe),2 + if (J .ge. 3 .and. J .le. JDE-2 .and. mod(J,2) .eq. 1) then + pdbdy2dtemp1(i,1,j) = grid%nmm_pd(i,j) + endif + END DO + ENDIF + + + ! There are 2 components to the lateral boundaries. + ! First, there is the starting + ! point of this time period - just the outer few rows and columns. + + + CALL stuff_bdy (ubdy3dtemp1, grid%nmm_u_b, 'N', ijds, ijde, spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdy ( vbdy3dtemp1, grid%nmm_v_b, 'N', ijds, ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdy ( tbdy3dtemp1, grid%nmm_t_b, 'N', ijds, ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( cwmbdy3dtemp1,grid%nmm_cwm_b,'N',ijds,ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( qbdy3dtemp1, grid%nmm_q_b, 'N', ijds, ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( q2bdy3dtemp1,grid%nmm_q2_b,'N', ijds, ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( pdbdy2dtemp1,grid%nmm_pd_b,'M', ijds,ijde, spec_bdy_width, & + ids , ide+1 , jds , jde+1 , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + +!----------------------------------------------------------------------- +! + ELSE IF ( loop .GT. 1 ) THEN +! +!----------------------------------------------------------------------- + + write(message,*)' assemble_output loop=',loop,' in IF block' + call wrf_message(message) + + ! Open the boundary file. + + IF ( loop .eq. 2 ) THEN + CALL construct_filename1( bdyname , 'wrfbdy' , grid%id , 2 ) + CALL open_w_dataset ( id, TRIM(bdyname) , grid , config_flags , & + output_boundary , "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrfbdy for writing' ) + ENDIF +! grid%write_metadata = .true. + ELSE +! what's this do? +! grid%write_metadata = .true. +! grid%write_metadata = .false. + CALL domain_clockadvance( grid ) + END IF + +! +!----------------------------------------------------------------------- +!*** SOUTHERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(JPS==JDS)THEN + J=1 + DO k = kps , MIN(kde,kpe) + DO i = ips , MIN(ide,ipe) + ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j) + tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j) + END DO + END DO +! + DO i = ips , MIN(ide,ipe) + pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j) + END DO + ENDIF + +! +!----------------------------------------------------------------------- +!*** NORTHERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(JPE==JDE)THEN + J=MIN(JDE,JPE) + DO k = kps , MIN(kde,kpe) + DO i = ips , MIN(ide,ipe) + ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j) + tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j) + END DO + END DO + + DO i = ips , MIN(ide,ipe) + pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j) + END DO + ENDIF +! +!----------------------------------------------------------------------- +!*** WESTERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(IPS==IDS)THEN + I=1 + DO k = kps , MIN(kde,kpe) + inc_h=mod(jps+1,2) + if(k==1)then + write(message,*)' assemble_ouput loop=',loop,' inc_h=',inc_h,' jps=',jps + call wrf_debug(10,message) + endif + DO j = jps+inc_h, MIN(jde,jpe),2 + if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then + tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j) + if(k==1)then + write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,k,j)=',tbdy3dtemp1(i,k,j) + call wrf_debug(10,message) + endif + qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j) + endif + END DO + END DO +! + DO k = kps , MIN(kde,kpe) + inc_v=mod(jps,2) + DO j = jps+inc_v, MIN(jde,jpe),2 + if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then + ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j) + endif + END DO + END DO + + inc_h=mod(jps+1,2) + DO j = jps+inc_h, MIN(jde,jpe),2 + if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then + pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j) + write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,1,j)=',pdbdy2dtemp1(i,1,j) + CALL wrf_debug(10,message) + endif + END DO + ENDIF +! +!----------------------------------------------------------------------- +!*** EASTERN BOUNDARY +!----------------------------------------------------------------------- +! + IF(IPE==IDE)THEN + I=MIN(IDE,IPE) + + DO k = kps , MIN(kde,kpe) + inc_h=mod(jps+1,2) + DO j = jps+inc_h, MIN(jde,jpe),2 + if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then + tbdy3dtemp2(i,k,j) = grid%nmm_t(i,k,j) + qbdy3dtemp2(i,k,j) = grid%nmm_q(i,k,j) + cwmbdy3dtemp2(i,k,j) = grid%nmm_cwm(i,k,j) + q2bdy3dtemp2(i,k,j) = grid%nmm_q2(i,k,j) + endif + END DO + END DO + + DO k = kps , MIN(kde,kpe) + inc_v=mod(jps,2) + DO j = jps+inc_v, MIN(jde,jpe),2 + if (J .ge. 2 .and. J .le. jde-1 .and. mod(J,2) .eq. 0) then + ubdy3dtemp2(i,k,j) = grid%nmm_u(i,k,j) + vbdy3dtemp2(i,k,j) = grid%nmm_v(i,k,j) + endif + END DO + END DO + + inc_h=mod(jps+1,2) + DO j = jps+inc_h, MIN(jde,jpe),2 + if (J .ge. 3 .and. J .le. jde-2 .and. mod(J,2) .eq. 1) then + pdbdy2dtemp2(i,1,j) = grid%nmm_pd(i,j) + endif + END DO + ENDIF +!----------------------------------------------------------------------- + ! During all of the loops after the first loop, + ! we first compute the boundary + ! tendencies with the current data values + ! (*bdy3dtemp2 arrays) and the previously + ! saved information stored in the *bdy3dtemp1 arrays. + + + CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , REAL(interval_seconds),& + grid%nmm_u_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , REAL(interval_seconds),& + grid%nmm_v_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , REAL(interval_seconds),& + grid%nmm_t_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdytend ( cwmbdy3dtemp2,cwmbdy3dtemp1,REAL(interval_seconds),& + grid%nmm_cwm_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , REAL(interval_seconds),& + grid%nmm_q_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdytend ( q2bdy3dtemp2, q2bdy3dtemp1 , REAL(interval_seconds),& + grid%nmm_q2_bt , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdytend( pdbdy2dtemp2 , pdbdy2dtemp1, REAL(interval_seconds),& + grid%nmm_pd_bt , 'M' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + ! Both pieces of the boundary data are now + ! available to be written (initial time and tendency). + ! This looks ugly, these date shifting things. + ! What's it for? We want the "Times" variable + ! in the lateral BDY file to have the valid times + ! of when the initial fields are written. + ! That's what the loop-2 thingy is for with the start date. + ! We increment the start_date so + ! that the starting time in the attributes is the + ! second time period. Why you may ask. I + ! agree, why indeed. + + temp24= current_date + temp24b=start_date + start_date = current_date + CALL geth_newdate ( temp19 , temp24b(1:19) , & + (loop-2) * model_config_rec%interval_seconds ) + current_date = temp19 // '.0000' + CALL domain_clock_set( grid, current_date(1:19) ) + write(message,*) 'LBC valid between these times ',current_date, ' ',start_date + CALL wrf_message(message) + + CALL output_boundary ( id, grid , config_flags , ierr ) + current_date = temp24 + start_date = temp24b + + ! OK, for all of the loops, we output the initialzation + ! data, which would allow us to + ! start the model at any of the available analysis time periods. + +! WRITE ( loop_char , FMT = '(I4.4)' ) loop +! CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) +! IF ( ierr .NE. 0 ) THEN +! CALL wrf_error_fatal( 'real: error opening wrfinput'//loop_char//' for writing' ) +! ENDIF +! grid%write_metadata = .true. + +! CALL calc_current_date ( grid%id , 0. ) +! CALL output_model_input ( id1, grid , config_flags , ierr ) +! CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) + + ! Is this or is this not the last time time? We can remove some unnecessary + ! stores if it is not. + + IF ( loop .LT. time_loop_max ) THEN + + ! We need to save the 3d data to compute a + ! difference during the next loop. Couple the + ! 3d fields with total mu (mub + mu_2) and the + ! stagger-specific map scale factor. + ! We load up the boundary data again for use in the next loop. + + +!mp change these limits????????? + + DO j = jps , jpe + DO k = kps , kpe + DO i = ips , ipe + ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j) + vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j) + tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j) + cwmbdy3dtemp1(i,k,j) = cwmbdy3dtemp2(i,k,j) + qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j) + q2bdy3dtemp1(i,k,j) = q2bdy3dtemp2(i,k,j) + END DO + END DO + END DO + +!mp change these limits????????? + + DO j = jps , jpe + DO i = ips , ipe + pdbdy2dtemp1(i,1,j) = pdbdy2dtemp2(i,1,j) + END DO + END DO + + ! There are 2 components to the lateral boundaries. + ! First, there is the starting + ! point of this time period - just the outer few rows and columns. + + + CALL stuff_bdy ( ubdy3dtemp1 , grid%nmm_u_b , 'N' ,& + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdy ( vbdy3dtemp1 , grid%nmm_v_b , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + CALL stuff_bdy ( tbdy3dtemp1 , grid%nmm_t_b , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( cwmbdy3dtemp1 , grid%nmm_cwm_b , 'N' , & + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( qbdy3dtemp1 , grid%nmm_q_b , 'N' ,& + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( q2bdy3dtemp1 , grid%nmm_q2_b, 'N' ,& + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , kds , kde+1 , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe+1 ) + + CALL stuff_bdy ( pdbdy2dtemp1 , grid%nmm_pd_b , 'M' ,& + ijds , ijde , spec_bdy_width , & + ids , ide+1 , jds , jde+1 , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + ELSE IF ( loop .EQ. time_loop_max ) THEN + + ! If this is the last time through here, we need to close the files. + + CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" ) + + END IF + + END IF main_loop_test + +END SUBROUTINE assemble_output diff --git a/wrfv2_fire/main/wrf.F b/wrfv2_fire/main/wrf.F new file mode 100644 index 00000000..4311bf2e --- /dev/null +++ b/wrfv2_fire/main/wrf.F @@ -0,0 +1,31 @@ +!WRF:DRIVER_LAYER:MAIN +! + +PROGRAM wrf + + USE module_wrf_top + +! +! Main program of WRF model. Responsible for starting up the model, reading in (and +! broadcasting for distributed memory) configuration data, defining and initializing +! the top-level domain, either from initial or restart data, setting up time-keeping, and +! then calling the integrate routine to advance the domain +! to the ending time of the simulation. After the integration is completed, the model +! is properly shut down. +! +! + + IMPLICIT NONE + + ! Initialize WRF model. + CALL wrf_init + + ! WRF model time-stepping. Calls integrate(). + CALL wrf_run + + ! WRF model clean-up. This calls MPI_FINALIZE() for DM parallel runs. + CALL wrf_finalize + +END PROGRAM wrf + + diff --git a/wrfv2_fire/main/wrf_ESMFApp.F b/wrfv2_fire/main/wrf_ESMFApp.F new file mode 100644 index 00000000..8e055a12 --- /dev/null +++ b/wrfv2_fire/main/wrf_ESMFApp.F @@ -0,0 +1,213 @@ +!WRF:DRIVER_LAYER:MAIN +! + +! +! Stand-alone ESMF Application Wrapper for WRF model. This file contains the +! main program and creates a top level ESMF Gridded Component. +! +! This source file is only built when ESMF coupling is used. +! +! + + +PROGRAM wrf_ESMFApp + +! +! Stand-alone ESMF Application Wrapper for WRF model. This is the main +! program that creates a top level ESMF Gridded Component. +! +! + + ! WRF registration routine + USE module_wrf_setservices, ONLY: WRF_register + ! ESMF module, defines all ESMF data types and procedures + USE ESMF_Mod + ! Not-yet-implemented ESMF features + USE module_esmf_extensions + ! Component-independent utilities + USE module_metadatautils, ONLY: GetTimesFromStates + + IMPLICIT NONE + + ! Local variables + + ! Components + TYPE(ESMF_GridComp) :: WRFcompGridded ! WRF + + ! State, Virtual Machine, and DELayout + TYPE(ESMF_VM) :: vm + TYPE(ESMF_State) :: importState, exportState + + ! A clock, some times, and a time step + TYPE(ESMF_Clock) :: driverClock + TYPE(ESMF_Time) :: startTime + TYPE(ESMF_Time) :: stopTime + TYPE(ESMF_TimeInterval) :: couplingInterval + + ! Return codes for error checks + INTEGER :: rc + + ! Warn users that this is not yet ready for general use. + PRINT *, ' W A R N I N G ' + PRINT *, ' ESMF COUPLING CAPABILITY IS EXPERIMENTAL AND UNSUPPORTED ' + PRINT *, ' IN THIS VERSION OF WRF ' + PRINT *, ' U S E A T Y O U R O W N R I S K ' + + ! This call includes everything that must be done before ESMF_Initialize() + ! is called. + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + + ! Initialize ESMF, get the default Global VM, and set + ! the default calendar to be Gregorian. + CALL ESMF_Initialize( vm=vm, defaultCalendar=ESMF_CAL_GREGORIAN, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_Initialize failed' ) + ENDIF + CALL ESMF_SetInitialized() ! eliminate this once ESMF does it internally +!TBH: these cause hangs on bluesky, PET* files never get written... +!TBH: CALL ESMF_LogSet( maxElements=1, verbose=ESMF_TRUE, flush=ESMF_TRUE, rc=rc ) +!TBH: CALL ESMF_LogSet( maxElements=1, rc=rc ) +!TBH: IF ( rc /= ESMF_SUCCESS ) THEN +!TBH: CALL wrf_error_fatal( 'ESMF_LogSet failed' ) +!TBH: ENDIF + + ! Create the top level Gridded Component, passing in the default VM. + WRFcompGridded = ESMF_GridCompCreate(vm, "WRF Model", rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompCreate failed' ) + ENDIF + + ! Create empty import and export states + importState = ESMF_StateCreate("WRF Import State", statetype=ESMF_STATE_IMPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_StateCreate(importState) failed' ) + ENDIF + exportState = ESMF_StateCreate("WRF Export State", statetype=ESMF_STATE_EXPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_StateCreate(exportState) failed' ) + ENDIF + + ! Create top-level clock. There is no way to create an "empty" clock, so + ! stuff in bogus values for start time, stop time, and time step and fix + ! them after "WRF Init" returns. + CALL ESMF_TimeSet(startTime, yy=2000, mm=1, dd=1, & + h=0, m=0, s=0, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_TimeSet(startTime) failed' ) + ENDIF + CALL ESMF_TimeSet(stopTime, yy=2000, mm=1, dd=1, & + h=12, m=0, s=0, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_TimeSet(stopTime) failed' ) + ENDIF + CALL ESMF_TimeIntervalSet(couplingInterval, s=2, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_TimeIntervalSet(couplingInterval) failed' ) + ENDIF + driverClock = ESMF_ClockCreate(timeStep=couplingInterval, startTime=startTime, & + stopTime=stopTime, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_ClockCreate failed' ) + ENDIF + + ! Register the top level Gridded Component + CALL ESMF_GridCompSetServices(WRFcompGridded, WRF_register, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompSetServices(WRFcompGridded) failed' ) + ENDIF + + ! Init, Run, and Finalize section + ! Phase 1 init returns WRF time and decomposition information as + ! exportState metadata. + CALL ESMF_GridCompInitialize(WRFcompGridded, importState, exportState, & + driverClock, phase=1, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompInitialize(WRFcompGridded phase 1) failed' ) + ENDIF + + ! For now, use settings from WRF component intialization to set up + ! top-level clock. Per suggestion from ESMF Core team, these are passed + ! back from "WRF init" as attributes on exportState. + CALL GetTimesFromStates( exportState, startTime, stopTime, couplingInterval ) + ! update driver clock + CALL ESMF_ClockDestroy(driverClock, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_ClockDestroy failed' ) + ENDIF + driverClock = ESMF_ClockCreate(timeStep=couplingInterval, startTime=startTime, & + stopTime=stopTime, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_ClockCreate(driverClock) failed' ) + ENDIF + CALL wrf_clockprint ( 150, driverClock, 'driverClock before phase 2 WRF init' ) + + ! Phase 2 init sets up WRF importState and exportState. + CALL ESMF_GridCompInitialize(WRFcompGridded, importState, exportState, & + driverClock, phase=2, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompInitialize(WRFcompGridded phase 2) failed' ) + ENDIF + + CALL wrf_debug ( 150, 'wrf_ESMFApp: begin time stepping...' ) + ! main time-stepping loop + DO WHILE ( .NOT. ESMF_ClockIsStopTime(driverClock, rc) ) + + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_ClockIsStopTime failed' ) + ENDIF + + ! Run WRF + CALL wrf_debug ( 150, 'wrf_ESMFApp: calling ESMF_GridCompRun(WRFcompGridded)...' ) + CALL ESMF_GridCompRun(WRFcompGridded, importState, exportState, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompRun failed' ) + ENDIF + CALL wrf_debug ( 150, 'wrf_ESMFApp: back from ESMF_GridCompRun(WRFcompGridded)...' ) + + ! advance clock to next coupling time step + CALL ESMF_ClockAdvance( driverClock, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_ClockAdvance failed' ) + ENDIF + CALL wrf_clockprint ( 150, driverClock, 'driverClock after ESMF_ClockAdvance' ) + + ENDDO + CALL wrf_debug ( 150, 'wrf_ESMFApp: done time stepping...' ) + + CALL wrf_debug ( 150, 'wrf_ESMFApp: calling ESMF_GridCompFinalize(WRFcompGridded)...' ) + ! clean up WRF + CALL ESMF_GridCompFinalize(WRFcompGridded, importState, exportState, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompFinalize failed' ) + ENDIF + CALL wrf_debug ( 150, 'wrf_ESMFApp: back from ESMF_GridCompFinalize(WRFcompGridded)...' ) + + ! Clean up + + CALL wrf_debug ( 150, 'wrf_ESMFApp: cleaning up ESMF objects...' ) + CALL ESMF_GridCompDestroy(WRFcompGridded, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_GridCompDestroy failed' ) + ENDIF + CALL ESMF_StateDestroy(importState, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_StateDestroy(importState) failed' ) + ENDIF + CALL ESMF_StateDestroy(exportState, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_StateDestroy(exportState) failed' ) + ENDIF + CALL ESMF_ClockDestroy(driverClock, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( 'ESMF_Destroy(driverClock) failed' ) + ENDIF + + CALL wrf_debug ( 150, 'wrf_ESMFApp: calling ESMF_Finalize()...' ) + CALL ESMF_Finalize( rc=rc ) + CALL wrf_debug ( 150, 'wrf_ESMFApp: back from ESMF_Finalize()...' ) + +END PROGRAM wrf_ESMFApp + + diff --git a/wrfv2_fire/main/wrf_ESMFMod.F b/wrfv2_fire/main/wrf_ESMFMod.F new file mode 100644 index 00000000..93c422f0 --- /dev/null +++ b/wrfv2_fire/main/wrf_ESMFMod.F @@ -0,0 +1,1255 @@ +!WRF:DRIVER_LAYER:MAIN +! + +! +! ESMF-specific modules for building WRF as an ESMF component. +! +! This source file is only built when ESMF coupling is used. +! +! + + + +MODULE module_metadatautils +! +! This module defines component-independent "model metadata" utilities +! used for ESMF coupling. +! +!$$$ Upgrade this later to support multiple coupling intervals via Alarms +!$$$ associated with top-level clock. Do this by adding TimesAttachedToState() +!$$$ inquiry function that will test an ESMF_State to see if the times are +!$$$ present via names defined in this module. Then call this for every +!$$$ component and resolve conflicts (somehow) for cases where two components +!$$$ define conflicting clocks. Of course, a component is allowed to not define +!$$$ a clock at all too... +! +!$$$ Replace meta-data names with "model metadata" conventions (when they exist) +! +!$$$ Refactor to remove duplication of hard-coded names! +! + USE ESMF_Mod + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public interfaces + PUBLIC AttachTimesToState + PUBLIC GetTimesFromStates + PUBLIC AttachDecompToState + PUBLIC GetDecompFromState + + ! private stuff + CHARACTER (ESMF_MAXSTR) :: str + + +CONTAINS + + + ! Attach time information to state as meta-data. + ! Update later to use some form of meta-data standards/conventions for + ! model "time" meta-data. + SUBROUTINE AttachTimesToState( state, startTime, stopTime, couplingInterval ) + TYPE(ESMF_State), INTENT(INOUT) :: state + TYPE(ESMF_Time), INTENT(IN ) :: startTime + TYPE(ESMF_Time), INTENT(IN ) :: stopTime + TYPE(ESMF_TimeInterval), INTENT(IN ) :: couplingInterval + ! locals + INTEGER :: rc + INTEGER :: year, month, day, hour, minute, second + INTEGER(ESMF_KIND_I4) :: timevals(6) ! big enough to hold the vars listed above + ! start time + CALL ESMF_TimeGet(startTime, yy=year, mm=month, dd=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeGet(startTime) failed' ) + ENDIF + timevals(1) = year + timevals(2) = month + timevals(3) = day + timevals(4) = hour + timevals(5) = minute + timevals(6) = second + CALL ESMF_StateSetAttribute(state, 'ComponentStartTime', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateSetAttribute(ComponentStartTime) failed' ) + ENDIF + ! stop time + CALL ESMF_TimeGet(stopTime, yy=year, mm=month, dd=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeGet(stopTime) failed' ) + ENDIF + timevals(1) = year + timevals(2) = month + timevals(3) = day + timevals(4) = hour + timevals(5) = minute + timevals(6) = second + CALL ESMF_StateSetAttribute(state, 'ComponentStopTime', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateSetAttribute(ComponentStopTime) failed' ) + ENDIF + ! coupling time step + CALL ESMF_TimeIntervalGet(couplingInterval, yy=year, mm=month, d=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeIntervalGet(couplingInterval) failed' ) + ENDIF + timevals(1) = year + timevals(2) = month + timevals(3) = day + timevals(4) = hour + timevals(5) = minute + timevals(6) = second + CALL ESMF_StateSetAttribute(state, 'ComponentCouplingInterval', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateSetAttribute(ComponentCouplingInterval) failed' ) + ENDIF + END SUBROUTINE AttachTimesToState + + + + ! Extract time information attached as meta-data from a single + ! ESMF_State. + ! Update later to use some form of meta-data standards/conventions for + ! model "time" meta-data. + SUBROUTINE GetTimesFromState( state, startTime, stopTime, couplingInterval ) + TYPE(ESMF_State), INTENT(IN ) :: state + TYPE(ESMF_Time), INTENT(INOUT) :: startTime + TYPE(ESMF_Time), INTENT(INOUT) :: stopTime + TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval + ! locals + INTEGER :: rc + INTEGER :: year, month, day, hour, minute, second + INTEGER(ESMF_KIND_I4) :: timevals(6) ! big enough to hold the vars listed above + ! start time + CALL ESMF_StateGetAttribute(state, 'ComponentStartTime', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateGetAttribute(ComponentStartTime) failed' ) + ENDIF + year = timevals(1) + month = timevals(2) + day = timevals(3) + hour = timevals(4) + minute = timevals(5) + second = timevals(6) + CALL ESMF_TimeSet(startTime, yy=year, mm=month, dd=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeSet(startTime) failed' ) + ENDIF + ! stop time + CALL ESMF_StateGetAttribute(state, 'ComponentStopTime', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateGetAttribute(ComponentStopTime) failed' ) + ENDIF + year = timevals(1) + month = timevals(2) + day = timevals(3) + hour = timevals(4) + minute = timevals(5) + second = timevals(6) + CALL ESMF_TimeSet(stopTime, yy=year, mm=month, dd=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeSet(stopTime) failed' ) + ENDIF + ! coupling time step + CALL ESMF_StateGetAttribute(state, 'ComponentCouplingInterval', & + SIZE(timevals), timevals, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateGetAttribute(ComponentCouplingInterval) failed' ) + ENDIF + year = timevals(1) + month = timevals(2) + day = timevals(3) + hour = timevals(4) + minute = timevals(5) + second = timevals(6) + CALL ESMF_TimeIntervalSet(couplingInterval, yy=year, mm=month, d=day, & + h=hour, m=minute, s=second, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_TimeIntervalSet(couplingInterval) failed' ) + ENDIF + END SUBROUTINE GetTimesFromState + + + + ! Extract time information attached as meta-data from one or more + ! ESMF_States. To use this with more than one ESMF_State, put the + ! ESMF_States into a single ESMF_State. If times differ, an attempt + ! is made to reconcile them. + SUBROUTINE GetTimesFromStates( state, startTime, stopTime, couplingInterval ) + TYPE(ESMF_State), INTENT(IN ) :: state + TYPE(ESMF_Time), INTENT(INOUT) :: startTime + TYPE(ESMF_Time), INTENT(INOUT) :: stopTime + TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval + ! locals + INTEGER :: rc + INTEGER :: numItems, numStates, i, istate + TYPE(ESMF_StateItemType), ALLOCATABLE :: itemTypes(:) + TYPE(ESMF_State) :: tmpState + CHARACTER (len=ESMF_MAXSTR), ALLOCATABLE :: itemNames(:) + TYPE(ESMF_Time), ALLOCATABLE :: startTimes(:) + TYPE(ESMF_Time), ALLOCATABLE :: stopTimes(:) + TYPE(ESMF_TimeInterval), ALLOCATABLE :: couplingIntervals(:) + +!$$$unfortunately, implementing this is an extraordinary pain in the @ss due +!$$$to lack of sane iterators for ESMF_State!!! @#$%!! + + ! Since there are no convenient iterators for ESMF_State (@#$%), + ! write a lot of code... + ! Figure out how many items are in the ESMF_State + CALL ESMF_StateGet(state, itemCount=numItems, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'ESMF_StateGet(numItems) failed' ) + ENDIF + ! allocate an array to hold the types of all items + ALLOCATE( itemTypes(numItems) ) + ! allocate an array to hold the names of all items + ALLOCATE( itemNames(numItems) ) + ! get the item types and names + CALL ESMF_StateGet(state, stateitemtypeList=itemTypes, & + itemNameList=itemNames, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_StateGet itemTypes failed with rc = ', rc + CALL wrf_error_fatal ( str ) + ENDIF + ! count how many items are ESMF_States + numStates = 0 + DO i=1,numItems + IF ( itemTypes(i) == ESMF_STATEITEM_STATE ) THEN + numStates = numStates + 1 + ENDIF + ENDDO + ALLOCATE( startTimes(numStates), stopTimes(numStates), & + couplingIntervals(numStates) ) + IF ( numStates > 0) THEN + ! finally, extract nested ESMF_States by name, if there are any + ! (should be able to do this by index at least -- @#%$) + istate = 0 + DO i=1,numItems + IF ( itemTypes(i) == ESMF_STATEITEM_STATE ) THEN + CALL ESMF_StateGetState( state, nestedStateName=TRIM(itemNames(i)), & + nestedState=tmpState, rc=rc ) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_StateGetState(',TRIM(itemNames(i)),') failed' + CALL wrf_error_fatal ( str ) + ENDIF + istate = istate + 1 + CALL GetTimesFromState( tmpState, startTimes(istate), & + stopTimes(istate), & + couplingIntervals(istate) ) + ENDIF + ENDDO + CALL ReconcileTimes( startTimes, stopTimes, couplingIntervals, & + startTime, stopTime, couplingInterval ) + ELSE + ! there are no nested ESMF_States so use parent state only + CALL GetTimesFromState( state, startTime, stopTime, & + couplingInterval ) + ENDIF + + ! deallocate locals + DEALLOCATE( itemTypes ) + DEALLOCATE( itemNames ) + DEALLOCATE( startTimes, stopTimes, couplingIntervals ) + + END SUBROUTINE GetTimesFromStates + + + ! Reconcile all times and intervals in startTimes, stopTimes, and + ! couplingIntervals and return the results in startTime, stopTime, and + ! couplingInterval. Abort if reconciliation is not possible. + SUBROUTINE ReconcileTimes( startTimes, stopTimes, couplingIntervals, & + startTime, stopTime, couplingInterval ) + TYPE(ESMF_Time), INTENT(IN ) :: startTimes(:) + TYPE(ESMF_Time), INTENT(IN ) :: stopTimes(:) + TYPE(ESMF_TimeInterval), INTENT(IN ) :: couplingIntervals(:) + TYPE(ESMF_Time), INTENT(INOUT) :: startTime + TYPE(ESMF_Time), INTENT(INOUT) :: stopTime + TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval + ! locals + INTEGER :: numTimes, numTimesTmp, i + + ! how many sets of time info? + numTimes = SIZE(startTimes) + IF ( numTimes < 2 ) THEN + CALL wrf_error_fatal ( 'SIZE(startTimes) too small' ) + ENDIF + numTimesTmp = SIZE(stopTimes) + IF ( numTimes /= numTimesTmp ) THEN + CALL wrf_error_fatal ( 'incorrect SIZE(stopTimes)' ) + ENDIF + numTimesTmp = SIZE(couplingIntervals) + IF ( numTimes /= numTimesTmp ) THEN + CALL wrf_error_fatal ( 'incorrect SIZE(couplingIntervals)' ) + ENDIF + + ! reconcile +!For now this is very simple. Fancy it up later. + DO i = 1, numTimes + IF ( i == 1 ) THEN + startTime = startTimes(i) + stopTime = stopTimes(i) + couplingInterval = couplingIntervals(i) + ELSE + IF ( startTimes(i) /= startTime ) THEN + CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent startTimes' ) + ENDIF + IF ( stopTimes(i) /= stopTime ) THEN + CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent stopTimes' ) + ENDIF + IF ( couplingIntervals(i) /= couplingInterval ) THEN + CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent couplingIntervals' ) + ENDIF + ENDIF + + ENDDO + + END SUBROUTINE ReconcileTimes + + + + !$$$ TBH: Eliminate this once this information can be derived via other + !$$$ TBH: means. + SUBROUTINE AttachDecompToState( state, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + TYPE(ESMF_State), INTENT(INOUT) :: state + INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde + INTEGER, INTENT(IN ) :: ims, ime, jms, jme, kms, kme + INTEGER, INTENT(IN ) :: ips, ipe, jps, jpe, kps, kpe + INTEGER, INTENT(IN ) :: domdesc + LOGICAL, INTENT(IN ) :: bdy_mask(4) + ! locals + INTEGER :: i, rc + ! big enough to hold the integer values listed above + INTEGER(ESMF_KIND_I4) :: intvals(19) + ! big enough to hold the logical values listed above + TYPE(ESMF_Logical) :: logvals(4) ! #$%*ing insane + + ! first the logicals + ! Usually, when writing an API for a target language, it is considered + ! good practice to use native types of the target language in the + ! interfaces. + logvals = ESMF_FALSE + DO i = 1, SIZE(bdy_mask) + IF (bdy_mask(i)) THEN + logvals(i) = ESMF_TRUE + ENDIF + ENDDO + CALL ESMF_StateSetAttribute(state, 'DecompositionLogicals', & + SIZE(logvals), logvals, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'ESMF_StateSetAttribute(DecompositionLogicals) failed' ) + ENDIF + ! now the integers + intvals(1) = ids + intvals(2) = ide + intvals(3) = jds + intvals(4) = jde + intvals(5) = kds + intvals(6) = kde + intvals(7) = ims + intvals(8) = ime + intvals(9) = jms + intvals(10) = jme + intvals(11) = kms + intvals(12) = kme + intvals(13) = ips + intvals(14) = ipe + intvals(15) = jps + intvals(16) = jpe + intvals(17) = kps + intvals(18) = kpe + intvals(19) = domdesc + CALL ESMF_StateSetAttribute(state, 'DecompositionIntegers', & + SIZE(intvals), intvals, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'ESMF_StateSetAttribute(DecompositionIntegers) failed' ) + ENDIF + END SUBROUTINE AttachDecompToState + + + + !$$$ TBH: Eliminate this once this information can be derived via other + !$$$ TBH: means. + SUBROUTINE GetDecompFromState( state, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + TYPE(ESMF_State), INTENT(IN ) :: state + INTEGER, INTENT( OUT) :: ids, ide, jds, jde, kds, kde + INTEGER, INTENT( OUT) :: ims, ime, jms, jme, kms, kme + INTEGER, INTENT( OUT) :: ips, ipe, jps, jpe, kps, kpe + INTEGER, INTENT( OUT) :: domdesc + LOGICAL, INTENT( OUT) :: bdy_mask(4) + ! locals + INTEGER :: i, rc + ! big enough to hold the integer values listed above + INTEGER(ESMF_KIND_I4) :: intvals(19) + ! big enough to hold the logical values listed above + TYPE(ESMF_Logical) :: logvals(4) ! #$%*ing insane + + ! first the logicals + CALL ESMF_StateGetAttribute(state, 'DecompositionLogicals', & + SIZE(logvals), logvals, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'ESMF_StateGetAttribute(DecompositionLogicals) failed' ) + ENDIF + ! Usually, when writing an API for a target language, it is considered + ! good practice to use native types of the target language in the + ! interfaces. + bdy_mask = .FALSE. + DO i = 1, SIZE(logvals) + IF (logvals(i) == ESMF_TRUE) THEN + bdy_mask(i) = .TRUE. + ENDIF + ENDDO + ! now the integers + CALL ESMF_StateGetAttribute(state, 'DecompositionIntegers', & + SIZE(intvals), intvals, rc=rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'ESMF_StateGetAttribute(DecompositionIntegers) failed' ) + ENDIF + ids = intvals(1) + ide = intvals(2) + jds = intvals(3) + jde = intvals(4) + kds = intvals(5) + kde = intvals(6) + ims = intvals(7) + ime = intvals(8) + jms = intvals(9) + jme = intvals(10) + kms = intvals(11) + kme = intvals(12) + ips = intvals(13) + ipe = intvals(14) + jps = intvals(15) + jpe = intvals(16) + kps = intvals(17) + kpe = intvals(18) + domdesc = intvals(19) + END SUBROUTINE GetDecompFromState + + + +END MODULE module_metadatautils + + + +MODULE module_wrf_component_top +! +! This module defines wrf_component_init1(), wrf_component_init2(), +! wrf_component_run(), and wrf_component_finalize() routines that are called +! when WRF is run as an ESMF component. +! + + USE module_wrf_top + USE ESMF_Mod + USE module_esmf_extensions + USE module_metadatautils, ONLY: AttachTimesToState, AttachDecompToState + + + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public entry points + PUBLIC wrf_component_init1 + PUBLIC wrf_component_init2 + PUBLIC wrf_component_run + PUBLIC wrf_component_finalize + + ! private stuff + CHARACTER (ESMF_MAXSTR) :: str + +CONTAINS + + + SUBROUTINE wrf_component_init1( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! WRF component init routine, phase 1. Passes relevant coupling +! information back as metadata on exportState. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_GridComp), POINTER :: p_gcomp + TYPE(ESMF_State), POINTER :: p_importState + TYPE(ESMF_State), POINTER :: p_exportState + TYPE(ESMF_Clock), POINTER :: p_clock + ! Time hackery + TYPE(ESMF_Time) :: startTime + TYPE(ESMF_Time) :: stopTime + TYPE(ESMF_TimeInterval) :: couplingInterval + ! decomposition hackery + INTEGER :: ids, ide, jds, jde, kds, kde + INTEGER :: ims, ime, jms, jme, kms, kme + INTEGER :: ips, ipe, jps, jpe, kps, kpe + INTEGER :: domdesc + LOGICAL :: bdy_mask(4) + CHARACTER(LEN=256) :: couplingIntervalString + + rc = ESMF_SUCCESS + + p_gcomp => gcomp + p_importState => importState + p_exportState => exportState + p_clock => clock + ! NOTE: It will be possible to remove this call once ESMF supports + ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(), + ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent(). + CALL ESMF_SetCurrent( gcomp=p_gcomp, importState=p_importState, & + exportState=p_exportState, clock=p_clock ) + + ! Call WRF "init" routine, suppressing call to init_modules(1) since + ! it was already done by the AppDriver. + CALL wrf_init( no_init1=.TRUE. ) + + ! For now, use settings from WRF component intialization to set up + ! top-level clock. Per suggestion from ESMF Core team, these are passed + ! back as attributes on exportState. + CALL wrf_clockprint( 100, head_grid%domain_clock, & + 'DEBUG wrf_component_init1(): head_grid%domain_clock,' ) + CALL ESMF_ClockGet(head_grid%domain_clock, startTime=startTime, & + stopTime=stopTime, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_init1: ESMF_ClockGet failed' ) + ENDIF +! CALL wrf_debug( 100, 'DEBUG wrf_component_init1(): before wrf_findCouplingInterval' ) + CALL wrf_findCouplingInterval( startTime, stopTime, couplingInterval ) +! CALL wrf_debug( 100, 'DEBUG wrf_component_init1(): after wrf_findCouplingInterval' ) + CALL ESMF_TimeIntervalGet( couplingInterval, TimeString=couplingIntervalString, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_init1: ESMF_TimeIntervalGet failed' ) + ENDIF + CALL wrf_debug( 100, 'DEBUG wrf_component_init1(): couplingInterval = '//TRIM(couplingIntervalString) ) + CALL AttachTimesToState( exportState, startTime, stopTime, couplingInterval ) + CALL wrf_getDecompInfo( ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + CALL AttachDecompToState( exportState, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + + END SUBROUTINE wrf_component_init1 + + + + SUBROUTINE wrf_component_init2( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! WRF component init routine, phase 2. Initializes importState and +! exportState. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_GridComp), POINTER :: p_gcomp + TYPE(ESMF_State), POINTER :: p_importState + TYPE(ESMF_State), POINTER :: p_exportState + TYPE(ESMF_Clock), POINTER :: p_clock + ! Time hackery + TYPE(ESMF_Time) :: startTime + TYPE(ESMF_Time) :: stopTime + TYPE(ESMF_TimeInterval) :: couplingInterval + ! decomposition hackery + INTEGER :: ids, ide, jds, jde, kds, kde + INTEGER :: ims, ime, jms, jme, kms, kme + INTEGER :: ips, ipe, jps, jpe, kps, kpe + INTEGER :: domdesc + LOGICAL :: bdy_mask(4) + TYPE(ESMF_StateType) :: statetype + INTEGER :: itemCount, i + CHARACTER (ESMF_MAXSTR) :: statename + CHARACTER (ESMF_MAXSTR), ALLOCATABLE :: itemNames(:) + TYPE(ESMF_StateItemType), ALLOCATABLE :: itemTypes(:) + + CALL wrf_debug ( 100, 'wrf_component_init2(): begin' ) + ! check exportState + CALL ESMF_StateGet( exportState, itemCount=itemCount, & + statetype=statetype, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(exportState) failed" ) + ENDIF + WRITE (str,*) 'wrf_component_init2: exportState itemCount = ', itemCount + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( statetype /= ESMF_STATE_EXPORT ) THEN + CALL wrf_error_fatal("wrf_component_init2: exportState is not an export state" ) + ENDIF + ! check importState + CALL ESMF_StateGet( importState, itemCount=itemCount, & + statetype=statetype, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(importState) failed" ) + ENDIF + WRITE (str,*) 'wrf_component_init2: importState itemCount = ', itemCount + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( statetype /= ESMF_STATE_IMPORT ) THEN + CALL wrf_error_fatal("wrf_component_init2: importState is not an import state" ) + ENDIF + + p_gcomp => gcomp + p_importState => importState + p_exportState => exportState + p_clock => clock + ! NOTE: It will be possible to remove this call once ESMF supports + ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(), + ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent(). + CALL ESMF_SetCurrent( gcomp=p_gcomp, importState=p_importState, & + exportState=p_exportState, clock=p_clock ) + + + ! This bit of hackery causes wrf_component_run to advance the head_grid + ! of WRF up to the point where import and export states have been + ! initialized and then return. + head_grid%return_after_training_io = .TRUE. + CALL wrf_component_run( gcomp, importState, exportState, clock, rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_init2: wrf_component_run failed' ) + ENDIF + + ! examine importState + WRITE (str,*) 'wrf_component_init2: EXAMINING importState...' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGet( importState, itemCount=itemCount, & + statetype=statetype, name=statename, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(importState) failed B" ) + ENDIF + IF ( statetype /= ESMF_STATE_IMPORT ) THEN + CALL wrf_error_fatal("wrf_component_init2: importState is not an import state" ) + ENDIF + WRITE (str,*) 'wrf_component_init2: importState <',TRIM(statename), & + '> itemCount = ', itemCount + CALL wrf_debug ( 100 , TRIM(str) ) + ALLOCATE ( itemNames(itemCount), itemTypes(itemCount) ) + CALL ESMF_StateGet( importState, itemNameList=itemNames, & + stateitemtypeList=itemTypes, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(importState) failed C" ) + ENDIF + DO i=1, itemCount + IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN + WRITE(str,*) 'wrf_component_init2: importState contains field <',TRIM(itemNames(i)),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + ENDIF + ENDDO + DEALLOCATE ( itemNames, itemTypes ) + WRITE (str,*) 'wrf_component_init2: DONE EXAMINING importState...' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! examine exportState + WRITE (str,*) 'wrf_component_init2: EXAMINING exportState...' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGet( exportState, itemCount=itemCount, & + statetype=statetype, name=statename, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(exportState) failed B" ) + ENDIF + IF ( statetype /= ESMF_STATE_EXPORT ) THEN + CALL wrf_error_fatal("wrf_component_init2: exportState is not an export state" ) + ENDIF + WRITE (str,*) 'wrf_component_init2: exportState <',TRIM(statename), & + '> itemCount = ', itemCount + CALL wrf_debug ( 100 , TRIM(str) ) + ALLOCATE ( itemNames(itemCount), itemTypes(itemCount) ) + CALL ESMF_StateGet( exportState, itemNameList=itemNames, & + stateitemtypeList=itemTypes, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal("wrf_component_init2: ESMF_StateGet(exportState) failed C" ) + ENDIF + DO i=1, itemCount + IF ( itemTypes(i) == ESMF_STATEITEM_FIELD ) THEN + WRITE(str,*) 'wrf_component_init2: exportState contains field <',TRIM(itemNames(i)),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + ENDIF + ENDDO + DEALLOCATE ( itemNames, itemTypes ) + WRITE (str,*) 'wrf_component_init2: DONE EXAMINING exportState...' + CALL wrf_debug ( 100 , TRIM(str) ) + + CALL wrf_debug ( 100, 'DEBUG wrf_component_init2(): end' ) + + END SUBROUTINE wrf_component_init2 + + + + SUBROUTINE wrf_component_run( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! WRF component run routine. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_GridComp), POINTER :: p_gcomp + TYPE(ESMF_State), POINTER :: p_importState + TYPE(ESMF_State), POINTER :: p_exportState + TYPE(ESMF_Clock), POINTER :: p_clock + ! timing + TYPE(ESMF_Time) :: currentTime, nextTime + TYPE(ESMF_TimeInterval) :: runLength ! how long to run in this call + CHARACTER(LEN=256) :: timeStr + + CALL wrf_debug ( 100 , 'DEBUG wrf_component_run(): begin' ) + + p_gcomp => gcomp + p_importState => importState + p_exportState => exportState + p_clock => clock + ! NOTE: It will be possible to remove this call once ESMF supports + ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(), + ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent(). + CALL ESMF_SetCurrent( gcomp=p_gcomp, importState=p_importState, & + exportState=p_exportState, clock=p_clock ) + + ! connect ESMF clock with WRF domain clock + CALL ESMF_ClockGet( clock, currTime=currentTime, timeStep=runLength, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_run: ESMF_ClockGet failed' ) + ENDIF + CALL wrf_clockprint(100, clock, & + 'DEBUG wrf_component_run(): clock,') + nextTime = currentTime + runLength + head_grid%start_subtime = currentTime + head_grid%stop_subtime = nextTime + CALL wrf_timetoa ( head_grid%start_subtime, timeStr ) + WRITE (str,*) 'wrf_component_run: head_grid%start_subtime ',TRIM(timeStr) + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_timetoa ( head_grid%stop_subtime, timeStr ) + WRITE (str,*) 'wrf_component_run: head_grid%stop_subtime ',TRIM(timeStr) + CALL wrf_debug ( 100 , TRIM(str) ) + + ! Call WRF "run" routine + CALL wrf_debug ( 100 , 'DEBUG wrf_component_run(): calling wrf_run()' ) + CALL wrf_run( ) + CALL wrf_debug ( 100 , 'DEBUG wrf_component_run(): back from wrf_run()' ) + + ! This bit of hackery will cause the next call to wrf_run() to + ! resume advance of the head_grid from the point where import and + ! export states were initialized. When grid%return_after_training_io + ! is .TRUE., wrf_run() returns right after import and export states + ! are initialized. This hack is triggered in wrf_component_init2. + IF ( head_grid%return_after_training_io ) THEN + head_grid%return_after_training_io = .FALSE. + ENDIF + + CALL wrf_debug ( 100 , 'DEBUG wrf_component_run(): end' ) + + END SUBROUTINE wrf_component_run + + + + SUBROUTINE wrf_component_finalize( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! WRF component finalize routine. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_GridComp), POINTER :: p_gcomp + TYPE(ESMF_State), POINTER :: p_importState + TYPE(ESMF_State), POINTER :: p_exportState + TYPE(ESMF_Clock), POINTER :: p_clock + INTEGER :: rc + p_gcomp => gcomp + p_importState => importState + p_exportState => exportState + p_clock => clock + ! NOTE: It will be possible to remove this call once ESMF supports + ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(), + ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent(). + CALL ESMF_SetCurrent( gcomp=p_gcomp, importState=p_importState, & + exportState=p_exportState, clock=p_clock ) + + ! Call WRF "finalize" routine, suppressing call to MPI_FINALIZE so + ! ESMF can do it (if needed) during ESMF_Finalize(). + CALL wrf_finalize( no_shutdown=.TRUE. ) + + rc = ESMF_SUCCESS + + END SUBROUTINE wrf_component_finalize + + + + SUBROUTINE wrf_findCouplingInterval( startTime, stopTime, couplingInterval ) + TYPE(ESMF_Time), INTENT(IN ) :: startTime + TYPE(ESMF_Time), INTENT(IN ) :: stopTime + TYPE(ESMF_TimeInterval), INTENT( OUT) :: couplingInterval +! +! WRF convenience routine for deducing coupling interval. The startTime +! and stopTime arguments are only used for determining a default value +! when coupling is not actually being done. +! +! The arguments are: +! startTime start time +! stopTime stop time +! couplingInterval coupling interval +! + ! locals + LOGICAL :: foundcoupling + INTEGER :: rc + INTEGER :: io_form + ! external function prototype + INTEGER, EXTERNAL :: use_package + + ! deduce coupling time-step + foundcoupling = .FALSE. +!$$$here... this bit just finds the FIRST case and extracts coupling interval +!$$$here... add error-checking for over-specification +!$$$here... add support for multiple coupling intervals later... +!$$$here... add support for coupling that does not begin immediately later... +!$$$ get rid of this hideous duplication!! + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput1( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT1_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT1_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput2( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT2_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT2_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput3( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT3_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT3_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput4( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT4_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT4_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput5( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT5_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT5_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput6( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT6_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT6_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput7( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT7_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT7_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput8( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT8_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT8_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT9_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT9_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_gfdda( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT10_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT10_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxinput11( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT11_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT11_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + + + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist1( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST1_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST1_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist2( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST2_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST2_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist3( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST3_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST3_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist4( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST4_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST4_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist5( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST5_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST5_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist6( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST6_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST6_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist7( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST7_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST7_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist8( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST8_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST8_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist9( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST9_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST9_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist10( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST10_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST10_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + IF ( .NOT. foundcoupling ) THEN + CALL nl_get_io_form_auxhist11( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST11_ALARM ), & + RingInterval=couplingInterval, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST11_ALARM) failed' ) + ENDIF + foundcoupling = .TRUE. + ENDIF + ENDIF + + ! look for erroneous use of io_form... + CALL nl_get_io_form_restart( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ERROR: ESMF cannot be used for WRF restart I/O' ) + ENDIF + CALL nl_get_io_form_input( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ERROR: ESMF cannot be used for WRF input' ) + ENDIF + CALL nl_get_io_form_history( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ERROR: ESMF cannot be used for WRF history output' ) + ENDIF + CALL nl_get_io_form_boundary( 1, io_form ) + IF ( use_package( io_form ) == IO_ESMF ) THEN + CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ERROR: ESMF cannot be used for WRF boundary I/O' ) + ENDIF + + ! If nobody uses IO_ESMF, then default is to run WRF all the way to + ! the end. + IF ( .NOT. foundcoupling ) THEN + couplingInterval = stopTime - startTime + call wrf_debug ( 1, 'WARNING: ESMF coupling not used in this WRF run' ) + ENDIF + + END SUBROUTINE wrf_findCouplingInterval + + + + SUBROUTINE wrf_getDecompInfo( ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + INTEGER, INTENT(OUT) :: ids, ide, jds, jde, kds, kde + INTEGER, INTENT(OUT) :: ims, ime, jms, jme, kms, kme + INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe, kps, kpe + INTEGER, INTENT(OUT) :: domdesc + LOGICAL, INTENT(OUT) :: bdy_mask(4) +! +! WRF convenience routine for deducing decomposition information. +! Note that domdesc is meaningful only for SPMD serial operation. +! For concurrent operation (SPMD or MPMD), we will need to create a new +! "domdesc" suitable for the task layout of the SST component. For +! MPMD serial operation, we will need to serialize domdesc and store it +! as metadata within the export state. Similar arguments apply +! to [ij][mp][se] and bdy_mask. +! +! The arguments are: +! ids, ide, jds, jde, kds, kde Domain extent. +! ims, ime, jms, jme, kms, kme Memory extent. +! ips, ipe, jps, jpe, kps, kpe Patch extent. +! domdesc Domain descriptor for external +! distributed-memory communication +! package (opaque to WRF). +! bdy_mask Boundary mask flags indicating which +! domain boundaries are on this task. +! + ! extract decomposition information from head_grid + CALL get_ijk_from_grid( head_grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + domdesc = head_grid%domdesc + bdy_mask = head_grid%bdy_mask + END SUBROUTINE wrf_getDecompInfo + + +END MODULE module_wrf_component_top + + + + +MODULE module_wrf_setservices +! +! This module defines WRF "Set Services" method wrf_register() +! used for ESMF coupling. +! + + USE module_wrf_component_top, ONLY: wrf_component_init1, & + wrf_component_init2, & + wrf_component_run, & + wrf_component_finalize + USE ESMF_Mod + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public entry point for ESMF_GridCompSetServices() + PUBLIC WRF_register + + ! private stuff + CHARACTER (ESMF_MAXSTR) :: str + +CONTAINS + + + SUBROUTINE wrf_register(gcomp, rc) + TYPE(ESMF_GridComp), INTENT(INOUT) :: gcomp + INTEGER, INTENT(OUT) :: rc +! +! +! WRF_register - Externally visible registration routine +! +! User-supplied SetServices routine. +! The Register routine sets the subroutines to be called +! as the init, run, and finalize routines. Note that these are +! private to the module. +! +! The arguments are: +! gcomp Component +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + rc = ESMF_SUCCESS + ! Register the callback routines. + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETINIT, & + wrf_component_init1, 1, rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'wrf_register: ESMF_GridCompSetEntryPoint(wrf_component_init1) failed' ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETINIT, & + wrf_component_init2, 2, rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'wrf_register: ESMF_GridCompSetEntryPoint(wrf_component_init2) failed' ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETRUN, & + wrf_component_run, ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'wrf_register: ESMF_GridCompSetEntryPoint(wrf_component_run) failed' ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETFINAL, & + wrf_component_finalize, ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'wrf_register: ESMF_GridCompSetEntryPoint(wrf_component_finalize) failed' ) + ENDIF + PRINT *,'WRF: Registered Initialize, Run, and Finalize routines' + + END SUBROUTINE wrf_register + +END MODULE module_wrf_setservices + diff --git a/wrfv2_fire/main/wrf_SST_ESMF.F b/wrfv2_fire/main/wrf_SST_ESMF.F new file mode 100644 index 00000000..f8bf35c0 --- /dev/null +++ b/wrfv2_fire/main/wrf_SST_ESMF.F @@ -0,0 +1,2049 @@ +!WRF:DRIVER_LAYER:MAIN +! + +! +! ESMF Application Wrapper for coupling WRF with a "dummy" component +! that simply reads SSTs from a file, sends to WRF, receives SST from +! WRF (two-way coupling). and checks that the SSTs match. +! +! This file contains the main program and associated modules for the +! SST "dummy" component and a simple coupler. It creates ESMF Gridded +! and Coupler Components. +! +! This source file is only built when ESMF coupling is used. +! +! + + + +! +! Modules module_sst_component_top and module_sst_setservices define the +! "SST" dummy component. +! + +MODULE module_sst_component_top +! +! This module defines sst_component_init1(), sst_component_init2(), +! sst_component_run1(), sst_component_run2(), and sst_component_finalize() +! routines that are called when SST is run as an ESMF component. +! + + USE ESMF_Mod + USE module_esmf_extensions + USE module_metadatautils, ONLY: AttachTimesToState + + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public entry points + PUBLIC sst_component_init1 + PUBLIC sst_component_init2 + PUBLIC sst_component_run1 + PUBLIC sst_component_run2 + PUBLIC sst_component_finalize + + ! private stuff + TYPE(ESMF_Grid), SAVE :: esmfgrid ! grid used in fields + CHARACTER (4096) :: str + INTEGER, SAVE :: fid ! file handle + ! decomposition information + INTEGER, SAVE :: ids, ide, jds, jde, kds, kde + INTEGER, SAVE :: ims, ime, jms, jme, kms, kme + INTEGER, SAVE :: ips, ipe, jps, jpe, kps, kpe +!$$$here... change names to remove tmp_ ... + REAL(ESMF_KIND_R4), POINTER, SAVE :: tmp_data_out_sst(:,:) + REAL(ESMF_KIND_R4), POINTER, SAVE :: tmp_data_out_landmask(:,:) + REAL(ESMF_KIND_R4), POINTER, SAVE :: tmp_data_in_sst(:,:) + REAL(ESMF_KIND_R4), POINTER, SAVE :: tmp_data_in_landmask(:,:) +!$$$DEBUG + PUBLIC :: ids, ide, jds, jde, kds, kde + PUBLIC :: ims, ime, jms, jme, kms, kme + PUBLIC :: ips, ipe, jps, jpe, kps, kpe +!$$$END DEBUG + INTEGER, SAVE :: domdesc + LOGICAL, SAVE :: bdy_mask(4) + ! MPI communicator, if needed + INTEGER, SAVE :: mpicom + ! field data + REAL, POINTER, SAVE :: file_landmask_data(:,:), file_sst_data(:,:) + ! input data file name + CHARACTER ( ESMF_MAXSTR ), SAVE :: sstinfilename + ! field names + INTEGER, PARAMETER :: datacount = 2 + INTEGER, PARAMETER :: SST_INDX = 1 + INTEGER, PARAMETER :: LANDMASK_INDX = 2 + CHARACTER(LEN=ESMF_MAXSTR), SAVE :: datanames(datacount) + TYPE real2d + REAL, POINTER :: r2d(:,:) + END TYPE real2d + TYPE(real2d) :: this_data(datacount) + + +CONTAINS + + + + ! First-phase "init" reads "SST" data file and returns "time" metadata in + ! exportState. + SUBROUTINE sst_component_init1( gcomp, importState, exportState, clock, rc ) + USE module_io + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! SST component init routine, phase 1. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + +#ifdef DM_PARALLEL + INCLUDE 'mpif.h' +#endif + + ! Local variables + CHARACTER (LEN=19) :: date_string +#ifdef DM_PARALLEL + TYPE(ESMF_VM) :: vm + INTEGER :: mpicomtmp +#endif + TYPE(ESMF_Time) :: startTime, stopTime, currentTime, dataTime + TYPE(ESMF_TimeInterval) :: timeStep + INTEGER :: ierr, num_steps, time_loop_max + INTEGER :: status_next_var + + !$$$ For now, sstinfilename is hard-coded + !$$$ Upgrade to use a variant of construct_filename() via startTime + !$$$ extracted from clock. + sstinfilename = 'sstin_d01_000000' + + ! get MPI communicator out of current VM and duplicate (if needed) +#ifdef DM_PARALLEL + CALL ESMF_VMGetCurrent(vm, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'sst_component_init1: ESMF_VMGetCurrent failed' ) + ENDIF + CALL ESMF_VMGet(vm, mpiCommunicator=mpicomtmp, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'sst_component_init1: ESMF_VMGet failed' ) + ENDIF + CALL MPI_Comm_dup( mpicomtmp, mpicom, ierr ) +#else + mpicom = 0 +#endif + ! Open the "SST" input data file for reading. + write(str,'(A,A)') 'Subroutine sst_component_init1: Opening data file ', & + TRIM(sstinfilename) + CALL wrf_message ( TRIM(str) ) + CALL wrf_open_for_read ( TRIM(sstinfilename) , & + mpicom , & + mpicom , & + "DATASET=INPUT" , & + fid , & + ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( str , FMT='(A,A,A,I8)' ) & + 'subroutine sst_component_init1: error opening ', & + TRIM(sstinfilename),' for reading ierr=',ierr + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + WRITE( str , FMT='(A,A,A,I8)' ) & + 'subroutine sst_component_init1: opened file ', & + TRIM(sstinfilename),' for reading fid=',fid + CALL wrf_debug ( 100, TRIM(str) ) + + ! How many data time levels are in the SST input file? + num_steps = -1 + time_loop_max = 0 + CALL wrf_debug ( 100, 'subroutine sst_component_init1: find time_loop_max' ) + ! compute SST start time, time step, and end time here + get_the_right_time : DO + CALL wrf_get_next_time ( fid, date_string, status_next_var ) + write(str,'(A,A)') 'Subroutine sst_component_init1: SST data startTime: ', & + date_string + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( status_next_var == 0 ) THEN + IF ( time_loop_max == 0 ) THEN + CALL wrf_atotime( date_string, startTime ) + ELSEIF ( time_loop_max == 1 ) THEN + ! assumes fixed time step! + CALL wrf_atotime( date_string, dataTime ) + timeStep = dataTime - startTime + ENDIF + time_loop_max = time_loop_max + 1 + CALL wrf_atotime( date_string, stopTime ) + ELSE + EXIT get_the_right_time + ENDIF + END DO get_the_right_time + CALL wrf_timetoa ( stopTime, date_string ) + write(str,'(A,A)') 'Subroutine sst_component_init1: SST data stopTime: ', & + date_string + CALL wrf_debug ( 100 , TRIM(str) ) + ! attach times to exportState for use by driver + CALL AttachTimesToState( exportState, startTime, stopTime, timeStep ) + + ! There should be a more elegant way to get to the beginning of the + ! file, but this will do. + CALL wrf_ioclose( fid , ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal ( 'sst_component_init1: wrf_ioclose failed' ) + ENDIF + WRITE( str , FMT='(A,I8)' ) & + 'subroutine sst_component_init1: closed file fid=',fid + CALL wrf_debug ( 100, TRIM(str) ) + + ! set up field names +!$$$ use CF conventions for "standard_name" once WRF Registry supports them +!$$$ datanames(SST_INDX) = "sea_surface_temperature" +!$$$ datanames(LANDMASK_INDX) = "land_binary_mask" + datanames(SST_INDX) = "SST" + datanames(LANDMASK_INDX) = "LANDMASK" + + rc = ESMF_SUCCESS + + END SUBROUTINE sst_component_init1 + + + + SUBROUTINE read_data( exportState, clock ) + USE module_io + TYPE(ESMF_State), INTENT(INOUT) :: exportState + TYPE(ESMF_Clock), INTENT(IN ) :: clock +! +! Reads data from file and stores. Then +! stuffs the file data into the SST exportState. +! + + #include + #include + + ! Local variables + CHARACTER (LEN=19) :: date_string + TYPE(ESMF_Time) :: currentTime, dataTime + REAL(ESMF_KIND_R4), POINTER :: out_sst_ptr(:,:), out_landmask_ptr(:,:) + TYPE(ESMF_Field) :: out_sst_field, out_landmask_field + TYPE(ESMF_Field) :: in_sst_field, in_landmask_field + INTEGER :: i, j + CHARACTER(LEN=ESMF_MAXSTR) :: fieldname, debugmsg, errormsg, timestr + INTEGER :: ierr + INTEGER :: rc + + ! This call to wrf_get_next_time will position the dataset over the next + ! time-frame in the file and return the date_string, which is used as an + ! argument to the read_field routines in the blocks of code included + ! below. + + CALL wrf_get_next_time( fid, date_string , ierr ) + WRITE(str,'(A,A)') 'Subroutine read_data: SST data time: ', & + date_string + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. & + ierr .NE. WRF_WARN_DRYRUN_READ ) THEN + CALL wrf_error_fatal ( "... May have run out of valid SST data ..." ) + ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. & + ierr .NE. WRF_WARN_DRYRUN_READ) THEN + ! check input time against current time (which will be start time at + ! beginning) + CALL wrf_atotime( date_string, dataTime ) + CALL ESMF_ClockGet( clock, CurrTime=currentTime, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'read_data: ESMF_ClockGet() failed' ) + ENDIF + CALL wrf_clockprint(150, clock, & + 'DEBUG read_data(): get currentTime from clock,') + IF ( dataTime .NE. currentTime ) THEN + CALL wrf_timetoa ( dataTime, timestr ) + WRITE( errormsg , * )'Time in file: ',trim( timestr ) + CALL wrf_message ( trim(errormsg) ) + CALL wrf_timetoa ( currentTime, timestr ) + WRITE( errormsg , * )'Time on domain: ',trim( timestr ) + CALL wrf_message ( trim(errormsg) ) + CALL wrf_error_fatal( & + "**ERROR** Time in input file not equal to time on domain **ERROR**" ) + ENDIF + ENDIF + + ! doing this in a loop only works if staggering is the same for all fields + this_data(SST_INDX)%r2d => file_sst_data + this_data(LANDMASK_INDX)%r2d => file_landmask_data + DO i=1, datacount + fieldname = TRIM(datanames(i)) + debugmsg = 'ext_read_field '//TRIM(fieldname)//' memorder XY' + errormsg = 'could not read '//TRIM(fieldname)//' data from file' + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + date_string , & ! DateStr + TRIM(fieldname) , & ! Data Name + this_data(i)%r2d , & ! Field + WRF_REAL , & ! FieldType + mpicom , & ! Comm + mpicom , & ! I/O Comm + domdesc , & ! Domain descriptor + bdy_mask , & ! bdy_mask + 'XY' , & ! MemoryOrder + '' , & ! Stagger + TRIM(debugmsg) , & ! Debug message + ids , (ide-1) , jds , (jde-1) , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , MIN( (ide-1), ipe ) , jps , MIN( (jde-1), jpe ) , 1 , 1 , & + ierr ) + IF (ierr /= 0) THEN + CALL wrf_error_fatal ( TRIM(errormsg) ) + ENDIF + ENDDO + + ! stuff fields into exportState +!$$$ change this to Bundles, eventually + CALL ESMF_StateGetField( exportState, TRIM(datanames(SST_INDX)), & + out_sst_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not find sea_surface_temperature field in exportState' ) + ENDIF + CALL ESMF_StateGetField( exportState, TRIM(datanames(LANDMASK_INDX)), & + out_landmask_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not find land_binary_mask field in exportState' ) + ENDIF + CALL ESMF_FieldGetDataPointer( out_sst_field, out_sst_ptr, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not find sea_surface_temperature data in sea_surface_temperature field' ) + ENDIF + CALL ESMF_FieldGetDataPointer( out_landmask_field, out_landmask_ptr, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not find land_binary_mask data in land_binary_mask field' ) + ENDIF + ! staggered starts/ends + DO j= jps , MIN( (jde-1), jpe ) + DO i= ips , MIN( (ide-1), ipe ) + out_sst_ptr(i,j) = file_sst_data(i,j) + out_landmask_ptr(i,j) = file_landmask_data(i,j) + ENDDO + ENDDO + + END SUBROUTINE read_data + + + + + SUBROUTINE compare_data( importState, clock ) + TYPE(ESMF_State), INTENT(INOUT) :: importState +!$$$ remove clock after debugging is finished + TYPE(ESMF_Clock), INTENT(INOUT) :: clock +! +! Gets data from coupler via importState +! and compares with data read from file and +! error-exits if they differ. +! +! The arguments are: +! importState Importstate +! + + ! Local variables + TYPE(ESMF_Field) :: in_sst_field, in_landmask_field + REAL(ESMF_KIND_R4), POINTER :: in_sst_ptr(:,:), in_landmask_ptr(:,:) + REAL, POINTER :: in_sst_ptr_real(:,:), in_landmask_ptr_real(:,:) + INTEGER :: i, j + INTEGER :: rc + LOGICAL :: landmask_ok, sst_ok +!$$$DEBUG +TYPE(ESMF_Time) :: currentTime +INTEGER, SAVE :: numtimes=0 ! track number of calls +CHARACTER(LEN=256) :: timestamp +!$$$END DEBUG + +!$$$DEBUG +! count calls... +CALL ESMF_ClockGet( clock, CurrTime=currentTime, rc=rc ) +IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'compare_data: ESMF_ClockGet() failed' ) +ENDIF +CALL wrf_timetoa ( currentTime, timestamp ) +numtimes = numtimes + 1 +WRITE(str,*) 'SST compare_data: begin, numtimes = ',numtimes,' time = ',TRIM(timestamp) +CALL wrf_debug ( 100 , TRIM(str) ) +!$$$END DEBUG + + ! extract data from the importState and compare with data from file +!$$$ change this to Bundles, eventually + CALL ESMF_StateGetField( importState, TRIM(datanames(SST_INDX)), & + in_sst_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not extract sea_surface_temperature field from importState' ) + ENDIF + CALL ESMF_StateGetField( importState, TRIM(datanames(LANDMASK_INDX)), & + in_landmask_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not extract land_binary_mask field from importState' ) + ENDIF + CALL ESMF_FieldGetDataPointer( in_sst_field, in_sst_ptr, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not extract sea_surface_temperature data from sea_surface_temperature field' ) + ENDIF + ALLOCATE( in_sst_ptr_real(ims:ime,jms:jme) ) + WRITE( str,* ) 'compare_data, ips:ipe,jps:jpe = ', & + ips,':',ipe,',',jps,':',jpe, & + ', in_sst_ptr(BOUNDS) = ', & + LBOUND(in_sst_ptr,1),':',UBOUND(in_sst_ptr,1),',', & + LBOUND(in_sst_ptr,2),':',UBOUND(in_sst_ptr,2) + CALL wrf_debug ( 100 , TRIM(str) ) + DO j= jms, jme + DO i= ims, ime + in_sst_ptr_real(i,j) = -(i*1000.0 + j)/100000.0 ! obvious bad value for debugging + ENDDO + ENDDO + in_sst_ptr_real(ips:MIN((ide-1),ipe),jps:MIN((jde-1),jpe)) = & + in_sst_ptr(ips:MIN((ide-1),ipe),jps:MIN((jde-1),jpe)) + CALL ESMF_FieldGetDataPointer( in_landmask_field, in_landmask_ptr, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( & + 'could not extract land_binary_mask data from land_binary_mask field' ) + ENDIF + ALLOCATE( in_landmask_ptr_real(ims:ime,jms:jme) ) + WRITE( str,* ) 'compare_data, ips:ipe,jps:jpe = ', & + ips,':',ipe,',',jps,':',jpe, & + ', in_landmask_ptr(BOUNDS) = ', & + LBOUND(in_landmask_ptr,1),':',UBOUND(in_landmask_ptr,1),',', & + LBOUND(in_landmask_ptr,2),':',UBOUND(in_landmask_ptr,2) + CALL wrf_debug ( 100 , TRIM(str) ) + DO j= jms, jme + DO i= ims, ime + in_landmask_ptr_real(i,j) = -(i*1000.0 + j)/100000.0 ! obvious bad value for debugging + ENDDO + ENDDO + in_landmask_ptr_real(ips:MIN((ide-1),ipe),jps:MIN((jde-1),jpe)) = & + in_landmask_ptr(ips:MIN((ide-1),ipe),jps:MIN((jde-1),jpe)) + + ! compare LANDMASK... + landmask_ok = .TRUE. + ! staggered starts/ends + LANDMASK_COMPARE : DO j= jps , MIN( (jde-1), jpe ) + DO i= ips , MIN( (ide-1), ipe ) + IF ( file_landmask_data(i,j) /= in_landmask_ptr_real(i,j) ) THEN + landmask_ok = .FALSE. + WRITE( str , * ) 'error landmask mismatch at (i,j) = (',i,',',j, & + '), values are',file_landmask_data(i,j),' and ', & + in_landmask_ptr_real(i,j) + EXIT LANDMASK_COMPARE + ENDIF + ENDDO + ENDDO LANDMASK_COMPARE +!$$$DEBUG +!CALL wrf_debug( 100, 'compare_data: writing DEBUG1_SSTcmp_FILE_LANDMASK_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_SSTcmp_FILE_LANDMASK_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') 'LANDMASK' +!DO j = jps, MIN( (jde-1), jpe ) +! DO i = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',i,',',j,'): ',file_landmask_data(i,j) +! ENDDO +!ENDDO +!CLOSE (985) +!CALL wrf_debug( 100, 'compare_data: writing DEBUG1_SSTcmp_FROM_WRF_LANDMASK_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_SSTcmp_FROM_WRF_LANDMASK_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') 'LANDMASK' +!DO j = jps, MIN( (jde-1), jpe ) +! DO i = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',i,',',j,'): ',in_landmask_ptr_real(i,j) +! ENDDO +!ENDDO +!CLOSE (985) +!$$$END DEBUG + IF ( landmask_ok ) THEN + WRITE(str,*) 'compare_data: LANDMASK compares OK' + CALL wrf_debug ( 100 , TRIM(str) ) + ELSE + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + + ! compare SST... + sst_ok = .TRUE. + ! staggered starts/ends + SST_COMPARE : DO j= jps , MIN( (jde-1), jpe ) + DO i= ips , MIN( (ide-1), ipe ) + IF ( file_sst_data(i,j) /= in_sst_ptr_real(i,j) ) THEN + sst_ok = .FALSE. + WRITE( str , * ) 'error sst mismatch at (i,j) = (',i,',',j, & + '), values are',file_sst_data(i,j),' and ', & + in_sst_ptr_real(i,j) + EXIT SST_COMPARE + ENDIF + ENDDO + ENDDO SST_COMPARE +!$$$DEBUG +!CALL wrf_debug( 100, 'compare_data: writing DEBUG1_SSTcmp_FILE_SST_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_SSTcmp_FILE_SST_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') 'SST' +!DO j = jps, MIN( (jde-1), jpe ) +! DO i = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',i,',',j,'): ',file_sst_data(i,j) +! ENDDO +!ENDDO +!CLOSE (985) +!CALL wrf_debug( 100, 'compare_data: writing DEBUG1_SSTcmp_FROM_WRF_SST_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_SSTcmp_FROM_WRF_SST_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') 'SST' +!DO j = jps, MIN( (jde-1), jpe ) +! DO i = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',i,',',j,'): ',in_sst_ptr_real(i,j) +! ENDDO +!ENDDO +!CLOSE (985) +!$$$END DEBUG + IF ( sst_ok ) THEN + WRITE(str,*) 'compare_data: SST compares OK' + CALL wrf_debug ( 100 , TRIM(str) ) + ELSE + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + + DEALLOCATE( in_sst_ptr_real, in_landmask_ptr_real ) + +!$$$DEBUG +WRITE(str,*) 'compare_data: end, numtimes = ',numtimes +CALL wrf_debug ( 100 , TRIM(str) ) +!$$$END DEBUG + + END SUBROUTINE compare_data + + + + + ! Second-phase "init" gets decomposition information from + ! importState. + SUBROUTINE sst_component_init2( gcomp, importState, exportState, clock, rc ) + USE module_metadatautils, ONLY: GetDecompFromState + USE module_io + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! SST component init routine, phase 2. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_RelLoc) :: horzRelloc + TYPE(ESMF_Field) :: out_sst_field, out_landmask_field + TYPE(ESMF_Field) :: in_sst_field, in_landmask_field + INTEGER, PARAMETER :: NUMDIMS=2 + INTEGER :: DomainStart(NUMDIMS) + INTEGER :: DomainEnd(NUMDIMS) + INTEGER :: MemoryStart(NUMDIMS) + INTEGER :: MemoryEnd(NUMDIMS) + INTEGER :: PatchStart(NUMDIMS) + INTEGER :: PatchEnd(NUMDIMS) + INTEGER :: rc, i, j + INTEGER :: ierr + + ! Get decomposition information from importState. Note that index + ! values are for staggered dimensions, following the WRF convention. +!$$$ TBH: Note that this will only work for SPMD serial operation. For +!$$$ TBH: concurrent operation (SPMD or MPMD), we will need to create a new +!$$$ TBH: "domdesc" suitable for the task layout of the SST component. For +!$$$ TBH: MPMD serial operation, we will need to extract serialized domdesc +!$$$ TBH: from export state metadata and de-serialize it. Similar arguments +!$$$ TBH: apply to [ij][mp][se] and bdy_mask. + write(str,*) 'sst_component_init2: calling GetDecompFromState' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL GetDecompFromState( importState, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + write(str,*) 'sst_component_init2: back from GetDecompFromState' + CALL wrf_debug ( 100 , TRIM(str) ) + write(str,*) 'sst_component_init2: ids, ide, jds, jde, kds, kde = ', ids, ide, jds, jde, kds, kde + CALL wrf_debug ( 100 , TRIM(str) ) + write(str,*) 'sst_component_init2: ims, ime, jms, jme, kms, kme = ', ims, ime, jms, jme, kms, kme + CALL wrf_debug ( 100 , TRIM(str) ) + write(str,*) 'sst_component_init2: ips, ipe, jps, jpe, kps, kpe = ', ips, ipe, jps, jpe, kps, kpe + CALL wrf_debug ( 100 , TRIM(str) ) + + ! allocate space for data read from disk + ALLOCATE( file_sst_data (ims:ime,jms:jme) ) + DO j= jms, jme + DO i= ims, ime + file_sst_data(i,j) = -(i*1000.0 + j)/100000.0 ! obvious bad value for debugging + ENDDO + ENDDO +!$$$ Hmmm... really need to load these pointers here? Check... + this_data(SST_INDX)%r2d => file_sst_data + ALLOCATE( file_landmask_data(ims:ime,jms:jme) ) + DO j= jms, jme + DO i= ims, ime + file_landmask_data(i,j) = -(i*1000.0 + j)/100000.0 ! obvious bad value for debugging + ENDDO + ENDDO + this_data(LANDMASK_INDX)%r2d => file_landmask_data + + ! Create ESMF_Fields in importState and exportState + ! Create ESMF_Grid. Use exactly the same method as WRF so WRFIO will + ! work (ugh). + DomainStart(1) = ids; DomainEnd(1) = ide; + DomainStart(2) = jds; DomainEnd(2) = jde; + MemoryStart(1) = ims; MemoryEnd(1) = ime; + MemoryStart(2) = jms; MemoryEnd(2) = jme; + PatchStart(1) = ips; PatchEnd(1) = ipe; + PatchStart(2) = jps; PatchEnd(2) = jpe + CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: Calling ioesmf_create_grid_int()' ) + CALL ioesmf_create_grid_int( esmfgrid, NUMDIMS, & + DomainStart, DomainEnd, & + MemoryStart, MemoryEnd, & + PatchStart, PatchEnd ) + CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: back from ioesmf_create_grid_int()' ) + ! create ESMF_Fields + !$$$ use CF standard_names later + !$$$here... This is a complete HACK!! Need to communicate horzrelloc + !$$$here... during init sometime... + horzrelloc=ESMF_CELL_CENTER + ! Note use of patch dimension for POINTERs allocated by ESMF. + CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: Calling ESMF_GridValidate(esmfgrid)' ) + CALL ESMF_GridValidate( esmfgrid, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE( str,* ) 'Error in ESMF_GridValidate ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', error code = ',rc +! TBH: debugging error exit here... + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: back OK from ESMF_GridValidate(esmfgrid)' ) +!TBH ! let ESMF allocate tmp_data_out_sst +!TBH ! Note that ESMF will deallocate it when the internal ESMF_Array object +!TBH ! is explicitly destroyed. Assuming that we can figure out how to safely +!TBH ! destroy it!!! (And we have gone around and around on this one. @#$%!) +!BELAY THAT: do it ourselves for now... + ALLOCATE( tmp_data_out_sst(ips:ipe,jps:jpe) ) + write(str,*) 'sst_component_init2: tmp_data_out_sst(', & + LBOUND(tmp_data_out_sst,1),':',UBOUND(tmp_data_out_sst,1),',',LBOUND(tmp_data_out_sst,2),':',UBOUND(tmp_data_out_sst,2),')' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_debug ( 100, 'sst_component_init2: calling ESMF_FieldCreate(out_sst_field)' ) + out_sst_field = ESMF_FieldCreate( & + esmfgrid, tmp_data_out_sst, & + copyflag=ESMF_DATA_REF, & + horzrelloc=horzrelloc, & + name=TRIM(datanames(SST_INDX)), & +! lbounds=(/ips,jps/), & +! ubounds=(/ipe,jpe/), & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE( str,* ) 'ESMF_FieldCreate(out_sst_field) failed ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', error code = ',rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + CALL wrf_debug ( 100, 'sst_component_init2: back from ESMF_FieldCreate(out_sst_field)' ) + write(str,*) 'sst_component_init2: ips:ipe,jps:jpe = ', & + ips,':',ipe,',',jps,':',jpe + CALL wrf_debug ( 100 , TRIM(str) ) + ! validate ESMF allocation + IF ( ( ips /= LBOUND(tmp_data_out_sst,1) ) .OR. ( ipe /= UBOUND(tmp_data_out_sst,1) ) .OR. & + ( jps /= LBOUND(tmp_data_out_sst,2) ) .OR. ( jpe /= UBOUND(tmp_data_out_sst,2) ) ) THEN + WRITE( str,* ) 'ESMF_FieldCreate(out_sst_field) allocation failed ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', ips:ipe,jps:jpe = ',ips,':',ipe,',',jps,':',jpe, & + ', tmp_data_out_sst(BOUNDS) = ',LBOUND(tmp_data_out_sst,1),':',UBOUND(tmp_data_out_sst,1),',', & + LBOUND(tmp_data_out_sst,2),':',UBOUND(tmp_data_out_sst,2) + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF +!TBH ! let ESMF allocate tmp_data_out_landmask +!TBH ! Note that ESMF will deallocate it when the internal ESMF_Array object +!TBH ! is explicitly destroyed. Assuming that we can figure out how to safely +!TBH ! destroy it!!! (And we have gone around and around on this one. @#$%!) +!BELAY THAT: do it ourselves for now... + ALLOCATE( tmp_data_out_landmask(ips:ipe,jps:jpe) ) + write(str,*) 'sst_component_init2: tmp_data_out_landmask(', & + LBOUND(tmp_data_out_landmask,1),':',UBOUND(tmp_data_out_landmask,1),',',LBOUND(tmp_data_out_landmask,2),':',UBOUND(tmp_data_out_landmask,2),')' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_debug ( 100, 'sst_component_init2: calling ESMF_FieldCreate(out_landmask_field)' ) + out_landmask_field = ESMF_FieldCreate( & + esmfgrid, tmp_data_out_landmask, & + copyflag=ESMF_DATA_REF, & + horzrelloc=horzrelloc, & + name=TRIM(datanames(LANDMASK_INDX)), & +! lbounds=(/ips,jps/), & +! ubounds=(/ipe,jpe/), & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_FieldCreate(out_landmask_field) failed' ) + ENDIF + CALL wrf_debug ( 100, 'sst_component_init2: back from ESMF_FieldCreate(out_landmask_field)' ) + ! validate ESMF allocation + IF ( ( ips /= LBOUND(tmp_data_out_landmask,1) ) .OR. ( ipe /= UBOUND(tmp_data_out_landmask,1) ) .OR. & + ( jps /= LBOUND(tmp_data_out_landmask,2) ) .OR. ( jpe /= UBOUND(tmp_data_out_landmask,2) ) ) THEN + WRITE( str,* ) 'ESMF_FieldCreate(out_landmask_field) allocation failed ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', ips:ipe,jps:jpe = ',ips,':',ipe,',',jps,':',jpe, & + ', tmp_data_out_landmask(BOUNDS) = ',LBOUND(tmp_data_out_landmask,1),':',UBOUND(tmp_data_out_landmask,1),',', & + LBOUND(tmp_data_out_landmask,2),':',UBOUND(tmp_data_out_landmask,2) + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF +!TBH ! let ESMF allocate tmp_data_in_sst +!TBH ! Note that ESMF will deallocate it when the internal ESMF_Array object +!TBH ! is explicitly destroyed. Assuming that we can figure out how to safely +!TBH ! destroy it!!! (And we have gone around and around on this one. @#$%!) +!BELAY THAT: do it ourselves for now... + ALLOCATE( tmp_data_in_sst(ips:ipe,jps:jpe) ) + write(str,*) 'sst_component_init2: tmp_data_in_sst(', & + LBOUND(tmp_data_in_sst,1),':',UBOUND(tmp_data_in_sst,1),',',LBOUND(tmp_data_in_sst,2),':',UBOUND(tmp_data_in_sst,2),')' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_debug ( 100, 'sst_component_init2: calling ESMF_FieldCreate(in_sst_field)' ) + in_sst_field = ESMF_FieldCreate( & + esmfgrid, tmp_data_in_sst, & + copyflag=ESMF_DATA_REF, & + horzrelloc=horzrelloc, & + name=TRIM(datanames(SST_INDX)), & +! lbounds=(/ips,jps/), & +! ubounds=(/ipe,jpe/), & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_FieldCreate(in_sst_field) failed' ) + ENDIF + CALL wrf_debug ( 100, 'sst_component_init2: back from ESMF_FieldCreate(in_sst_field)' ) + ! validate ESMF allocation + IF ( ( ips /= LBOUND(tmp_data_in_sst,1) ) .OR. ( ipe /= UBOUND(tmp_data_in_sst,1) ) .OR. & + ( jps /= LBOUND(tmp_data_in_sst,2) ) .OR. ( jpe /= UBOUND(tmp_data_in_sst,2) ) ) THEN + WRITE( str,* ) 'ESMF_FieldCreate(in_sst_field) allocation failed ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', ips:ipe,jps:jpe = ',ips,':',ipe,',',jps,':',jpe, & + ', tmp_data_in_sst(BOUNDS) = ',LBOUND(tmp_data_in_sst,1),':',UBOUND(tmp_data_in_sst,1),',', & + LBOUND(tmp_data_in_sst,2),':',UBOUND(tmp_data_in_sst,2) + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF +!TBH ! let ESMF allocate tmp_data_in_landmask +!TBH ! Note that ESMF will deallocate it when the internal ESMF_Array object +!TBH ! is explicitly destroyed. Assuming that we can figure out how to safely +!TBH ! destroy it!!! (And we have gone around and around on this one. @#$%!) +!BELAY THAT: do it ourselves for now... + ALLOCATE( tmp_data_in_landmask(ips:ipe,jps:jpe) ) + write(str,*) 'sst_component_init2: tmp_data_in_landmask(', & + LBOUND(tmp_data_in_landmask,1),':',UBOUND(tmp_data_in_landmask,1),',',LBOUND(tmp_data_in_landmask,2),':',UBOUND(tmp_data_in_landmask,2),')' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_debug ( 100, 'sst_component_init2: calling ESMF_FieldCreate(in_landmask_field)' ) + in_landmask_field = ESMF_FieldCreate( & + esmfgrid, tmp_data_in_landmask, & + copyflag=ESMF_DATA_REF, & + horzrelloc=horzrelloc, & + name=TRIM(datanames(LANDMASK_INDX)), & +! lbounds=(/ips,jps/), & +! ubounds=(/ipe,jpe/), & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_FieldCreate(in_landmask_field) failed' ) + ENDIF + CALL wrf_debug ( 100, 'sst_component_init2: back from ESMF_FieldCreate(in_landmask_field)' ) + ! validate ESMF allocation + IF ( ( ips /= LBOUND(tmp_data_in_landmask,1) ) .OR. ( ipe /= UBOUND(tmp_data_in_landmask,1) ) .OR. & + ( jps /= LBOUND(tmp_data_in_landmask,2) ) .OR. ( jpe /= UBOUND(tmp_data_in_landmask,2) ) ) THEN + WRITE( str,* ) 'ESMF_FieldCreate(in_landmask_field) allocation failed ', & + __FILE__ , & + ', line ', & + __LINE__ , & + ', ips:ipe,jps:jpe = ',ips,':',ipe,',',jps,':',jpe, & + ', tmp_data_in_landmask(BOUNDS) = ',LBOUND(tmp_data_in_landmask,1),':',UBOUND(tmp_data_in_landmask,1),',', & + LBOUND(tmp_data_in_landmask,2),':',UBOUND(tmp_data_in_landmask,2) + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + + ! attach ESMF_Field to importState + CALL ESMF_StateAddField( importState, in_sst_field, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateAddField(in_sst_field) failed' ) + ENDIF + CALL ESMF_StateAddField( importState, in_landmask_field, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateAddField(in_landmask_field) failed' ) + ENDIF + ! attach ESMF_Field to exportState + CALL ESMF_StateAddField( exportState, out_sst_field, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateAddField(out_sst_field) failed' ) + ENDIF + CALL ESMF_StateAddField( exportState, out_landmask_field, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_StateAddField(out_landmask_field) failed' ) + ENDIF + + ! Open the "SST" input data file for reading. + write(str,'(A,A)') 'sst_component_init2: Opening data file ', & + TRIM(sstinfilename) + CALL wrf_message ( TRIM(str) ) + CALL wrf_open_for_read ( TRIM(sstinfilename) , & + mpicom , & + mpicom , & + "DATASET=INPUT" , & + fid , & + ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( str , FMT='(A,A,A,I8)' ) & + 'sst_component_init2: error opening ', & + TRIM(sstinfilename),' for reading ierr=',ierr + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + WRITE( str , FMT='(A,A,A,I8)' ) & + 'subroutine sst_component_init2: opened file ', & + TRIM(sstinfilename),' for reading fid=',fid + CALL wrf_debug ( 100, TRIM(str) ) + + write(str,'(A)') 'sst_component_init2: returning rc=ESMF_SUCCESS' + CALL wrf_debug ( 100 , TRIM(str) ) + + rc = ESMF_SUCCESS + + END SUBROUTINE sst_component_init2 + + + + SUBROUTINE sst_component_run1( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! SST component run routine, phase 1. +! Read "SST" data from file and stuff into exportState. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + rc = ESMF_SUCCESS + + ! Get "SST" data from file and stuff it into exportState. + CALL read_data( exportState, clock ) + + END SUBROUTINE sst_component_run1 + + + + SUBROUTINE sst_component_run2( gcomp, importState, exportState, clock, rc ) + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! SST component run routine, phase 2. +! Get from importState, compare with file data, and error-exit +! if they differ... If they are the same, then +! stuff the file data into the exportState. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + rc = ESMF_SUCCESS + + ! Get from importState, compare with file data, and error_exit + ! if they differ... + ! This works because WRF loads its exportState BEFORE integrating. + CALL wrf_clockprint ( 50, clock, 'sst_component_run2: clock before call to compare_data()' ) + CALL compare_data( importState, clock ) + CALL wrf_clockprint ( 50, clock, 'sst_component_run2: clock after call to compare_data()' ) + + END SUBROUTINE sst_component_run2 + + + + SUBROUTINE sst_component_finalize( gcomp, importState, exportState, clock, rc ) + USE module_io + TYPE(ESMF_GridComp), TARGET, INTENT(INOUT) :: gcomp + TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock + INTEGER, INTENT( OUT) :: rc +! +! SST component finalize routine. +! +! The arguments are: +! gcomp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_Field) :: tmp_field + INTEGER :: i, ierr + + rc = ESMF_SUCCESS + + ! destroy ESMF_Fields and other "deep" objects created by this component + ! note that this component relied on ESMF to allocate data pointers during + ! calls to ESMF_FieldCreate() so it also expects ESMF to free these pointers +!$$$here... remove duplication + DO i=1, datacount + ! destroy field in importState + CALL ESMF_StateGetField( importState, TRIM(datanames(i)), tmp_field, & + rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + WRITE( str , * ) & + 'sst_component_finalize: ESMF_StateGetField( importState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + CALL ESMF_FieldDestroy( tmp_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + WRITE( str , * ) & + 'sst_component_finalize: ESMF_FieldDestroy( importState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + ! destroy field in exportState + CALL ESMF_StateGetField( exportState, TRIM(datanames(i)), tmp_field, & + rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + WRITE( str , * ) & + 'sst_component_finalize: ESMF_StateGetField( exportState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + CALL ESMF_FieldDestroy( tmp_field, rc=rc ) + IF (rc /= ESMF_SUCCESS) THEN + WRITE( str , * ) & + 'sst_component_finalize: ESMF_FieldDestroy( exportState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + ENDDO + + ! deallocate space for data read from disk + DEALLOCATE( file_sst_data, file_landmask_data ) + + ! close SST data file + WRITE( str , FMT='(A,I8)' ) & + 'subroutine sst_component_finalize: closing file fid=',fid + CALL wrf_debug ( 100, TRIM(str) ) + CALL wrf_ioclose( fid , ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal ( 'sst_component_finalize: wrf_ioclose failed' ) + ENDIF + + END SUBROUTINE sst_component_finalize + + +END MODULE module_sst_component_top + + + + +MODULE module_sst_setservices +! +! This module defines SST "Set Services" method sst_register() +! used for ESMF coupling. +! + + USE module_sst_component_top, ONLY: sst_component_init1, & + sst_component_init2, & + sst_component_run1, & + sst_component_run2, & + sst_component_finalize + USE ESMF_Mod + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public entry point for ESMF_GridCompSetServices() + PUBLIC SST_register + + ! private stuff + CHARACTER (ESMF_MAXSTR) :: str + +CONTAINS + + + SUBROUTINE sst_register(gcomp, rc) + TYPE(ESMF_GridComp), INTENT(INOUT) :: gcomp + INTEGER, INTENT(OUT) :: rc + INTEGER :: finalrc +! +! +! SST_register - Externally visible registration routine +! +! User-supplied SetServices routine. +! The Register routine sets the subroutines to be called +! as the init, run, and finalize routines. Note that these are +! private to the module. +! +! The arguments are: +! gcomp Component +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + finalrc = ESMF_SUCCESS + ! Register the callback routines. + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETINIT, & + sst_component_init1, 1, rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_GridCompSetEntryPoint(sst_component_init1) failed with rc = ', rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETINIT, & + sst_component_init2, 2, rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_GridCompSetEntryPoint(sst_component_init2) failed with rc = ', rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETRUN, & + sst_component_run1, 1, rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_GridCompSetEntryPoint(sst_component_run1) failed with rc = ', rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETRUN, & + sst_component_run2, 2, rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_GridCompSetEntryPoint(sst_component_run2) failed with rc = ', rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_SETFINAL, & + sst_component_finalize, ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS) THEN + WRITE(str,*) 'ESMF_GridCompSetEntryPoint(sst_component_finalize) failed with rc = ', rc + CALL wrf_error_fatal ( TRIM(str) ) + ENDIF + + PRINT *,'SST: Registered Initialize, Run, and Finalize routines' + + rc = finalrc + + END SUBROUTINE sst_register + +END MODULE module_sst_setservices + + + +! +! Module module_wrfsst_coupler defines the +! "WRF-SST" coupler component. It provides two-way coupling between +! the "SST" and "WRF" components. +! In its run routine it transfers data directly from the +! SST Component's export state to the WRF Component's import state. +! It also transfers data directly from the +! WRF Component's export state to the SST Component's import state. +! +! This is derived from src/demo/coupled_flow/src/CouplerMod.F90 +! created by Nancy Collins and others on the ESMF Core Team. +! +! + +MODULE module_wrfsst_coupler + + USE ESMF_Mod + + IMPLICIT NONE + + ! everything is private by default + PRIVATE + + ! Public entry point + PUBLIC WRFSSTCpl_register + + ! private data members + ! route handles and flags + TYPE(ESMF_RouteHandle), SAVE :: fromWRF_rh, fromSST_rh + LOGICAL, SAVE :: fromWRF_rh_ready = .FALSE. + LOGICAL, SAVE :: fromSST_rh_ready = .FALSE. + ! field names + INTEGER, PARAMETER :: datacount = 2 + INTEGER, PARAMETER :: SST_INDX = 1 + INTEGER, PARAMETER :: LANDMASK_INDX = 2 + CHARACTER(LEN=ESMF_MAXSTR), SAVE :: datanames(datacount) + CHARACTER(LEN=ESMF_MAXSTR) :: str + + +CONTAINS + + + SUBROUTINE WRFSSTCpl_register(comp, rc) + TYPE(ESMF_CplComp), INTENT(INOUT) :: comp + INTEGER, INTENT(OUT) :: rc +! +! +! WRFSSTCpl_register - Externally visible registration routine +! +! User-supplied SetServices routine. +! The Register routine sets the subroutines to be called +! as the init, run, and finalize routines. Note that these are +! private to the module. +! +! The arguments are: +! comp Component +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! guilty until proven innocent + rc = ESMF_FAILURE + + ! Register the callback routines. + + call ESMF_CplCompSetEntryPoint(comp, ESMF_SETINIT, WRFSSTCpl_init, & + ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_CplCompSetEntryPoint(WRFSSTCpl_init) failed' ) + ENDIF + call ESMF_CplCompSetEntryPoint(comp, ESMF_SETRUN, WRFSSTCpl_run, & + ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_CplCompSetEntryPoint(WRFSSTCpl_run) failed' ) + ENDIF + call ESMF_CplCompSetEntryPoint(comp, ESMF_SETFINAL, WRFSSTCpl_final, & + ESMF_SINGLEPHASE, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'ESMF_CplCompSetEntryPoint(WRFSSTCpl_final) failed' ) + ENDIF + + print *, "module_wrfsst_coupler: Registered Initialize, Run, and Finalize routines" + + END SUBROUTINE WRFSSTCpl_register + + + SUBROUTINE WRFSSTCpl_init(comp, importState, exportState, clock, rc) + USE module_metadatautils, ONLY: AttachDecompToState, GetDecompFromState + TYPE(ESMF_CplComp), INTENT(INOUT) :: comp + TYPE(ESMF_State), INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), INTENT(INOUT) :: clock + INTEGER, INTENT(OUT) :: rc +! +! WRF-SST coupler component init routine. This simply passes needed +! metadata from WRF to SST. Initialization of ESMF_RouteHandle objects +! is handled later via lazy evaluation. +! +! The arguments are: +! comp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + CHARACTER(ESMF_MAXSTR) :: importstatename + ! decomposition information + INTEGER :: ids, ide, jds, jde, kds, kde + INTEGER :: ims, ime, jms, jme, kms, kme + INTEGER :: ips, ipe, jps, jpe, kps, kpe + INTEGER :: domdesc + LOGICAL :: bdy_mask(4) + + PRINT *, "DEBUG: Coupler Init starting" + + ! guilty until proven innocent + rc = ESMF_FAILURE + + CALL ESMF_StateGet(importState, name=importstatename, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_init: ESMF_StateGet failed' ) + ENDIF + + IF ( TRIM(importstatename) .EQ. "WRF Export State" ) THEN + ! get metadata from WRF export state + CALL GetDecompFromState( importState, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + ! put metadata from in SST import state + CALL AttachDecompToState( exportState, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) + + + ELSE + CALL wrf_error_fatal ( 'WRFSSTCpl_init: invalid importState name' ) + ENDIF + + ! set up field names +!$$$ use CF conventions for "standard_name" once WRF Registry supports them +!$$$ datanames(SST_INDX) = "sea_surface_temperature" +!$$$ datanames(LANDMASK_INDX) = "land_binary_mask" + datanames(SST_INDX) = "SST" + datanames(LANDMASK_INDX) = "LANDMASK" + + PRINT *, "DEBUG: Coupler Init returning" + + END SUBROUTINE WRFSSTCpl_init + + + + SUBROUTINE WRFSSTCpl_run(comp, importState, exportState, clock, rc) +!$$$DEBUG +! get ips,ipe, ... from this hack for debugging + USE module_sst_component_top +!$$$END DEBUG + TYPE(ESMF_CplComp), INTENT(INOUT) :: comp + TYPE(ESMF_State), INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), INTENT(INOUT) :: clock + INTEGER, INTENT(OUT) :: rc +! +! WRF-SST coupler component run routine. +! +! The arguments are: +! comp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + ! Local variables + TYPE(ESMF_Field) :: src_field, dst_field + TYPE(ESMF_RouteHandle) :: routehandle + TYPE(ESMF_VM) :: vm + LOGICAL :: build_fromWRF_rh, build_fromSST_rh, fromWRF + CHARACTER(LEN=ESMF_MAXSTR) :: importStatename + CHARACTER(LEN=ESMF_MAXSTR) :: SST_exportStatename, WRF_exportStatename + INTEGER :: i +!$$$DEBUG + TYPE(ESMF_Time) :: currentTime + CHARACTER(LEN=256) :: timestamp, directionString + INTEGER :: ii, jj + REAL(ESMF_KIND_R4), POINTER :: tmp_data_ptr(:,:) +!$$$END DEBUG + + WRITE(str,*) 'WRFSSTCpl_run: begin' + CALL wrf_debug ( 100 , TRIM(str) ) + +!$$$DEBUG +CALL ESMF_ClockGet( clock, CurrTime=currentTime, rc=rc ) +IF (rc /= ESMF_SUCCESS) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_ClockGet() failed' ) +ENDIF +CALL wrf_timetoa ( currentTime, timestamp ) +!$$$END DEBUG + + ! guilty until proven innocent + rc = ESMF_FAILURE + + ! Which way is this coupling going? + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_StateGet(importState,name,...)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGet( importState, name=importStatename, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_StateGet(importState,name,...) failed' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: back from ESMF_StateGet, importStatename = <',TRIM(importStatename),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! first time through in each direction: create route handle and + ! associated objects + WRF_exportStatename = "WRF Export State" + SST_exportStatename = "SST Export State" + IF ( TRIM(importStatename) .EQ. TRIM(WRF_exportStatename) ) THEN + fromWRF = .TRUE. + directionString = 'WRFtoSST' + ELSE IF ( TRIM(importStatename) .EQ. TRIM(SST_exportStatename) ) THEN + fromWRF = .FALSE. + directionString = 'SSTtoWRF' + ELSE + CALL wrf_error_fatal ( 'WRFSSTCpl_run: invalid importState name' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: fromWRF = ',fromWRF + CALL wrf_debug ( 100 , TRIM(str) ) + build_fromWRF_rh = fromWRF .AND. ( .NOT. fromWRF_rh_ready ) + build_fromSST_rh = ( .NOT. fromWRF ) .AND. ( .NOT. fromSST_rh_ready ) + WRITE(str,*) 'WRFSSTCpl_run: build_fromWRF_rh = ',build_fromWRF_rh + CALL wrf_debug ( 100 , TRIM(str) ) + WRITE(str,*) 'WRFSSTCpl_run: build_fromSST_rh = ',build_fromSST_rh + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( build_fromWRF_rh .OR. build_fromSST_rh ) THEN + CALL ESMF_CplCompGet( comp, vm=vm, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_CplCompGet failed' ) + ENDIF + ! The use of literal index "1" here indicates that we don't care which + ! ESMF_Field we get so we might as well get the first one. +!$$$ Right now, staggering of all fields is identical. Do we need more than one +!$$$ routeHandle if there is more than one staggering? + WRITE(str,*) 'WRFSSTCpl_run: grabbing first field <',TRIM(datanames(1)), & + '> from import state' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGetField( importState, TRIM(datanames(1)), src_field, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_StateGetField(importState) failed' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: grabbing first field <',TRIM(datanames(1)), & + '> from export state' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGetField( exportState, TRIM(datanames(1)), dst_field, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_StateGetField(exportState) failed' ) + ENDIF + IF ( build_fromWRF_rh ) THEN + WRITE(str,*) 'WRFSSTCpl_run: creating fromWRF_rh' + CALL wrf_debug ( 100 , TRIM(str) ) + fromWRF_rh = ESMF_RouteHandleCreate( rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_RouteHandleCreate(fromWRF_rh) failed' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_FieldRedistStore(fromWRF_rh)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_FieldRedistStore( src_field, dst_field, vm, & + routehandle=fromWRF_rh, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_FieldRedistStore(fromWRF_rh) failed' ) + ENDIF + fromWRF_rh_ready = .TRUE. + ENDIF + IF ( build_fromSST_rh ) THEN + WRITE(str,*) 'WRFSSTCpl_run: creating fromSST_rh' + CALL wrf_debug ( 100 , TRIM(str) ) + fromSST_rh = ESMF_RouteHandleCreate( rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_RouteHandleCreate(fromSST_rh) failed' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_FieldRedistStore(fromSST_rh)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_FieldRedistStore( src_field, dst_field, vm, & + routehandle=fromSST_rh, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_FieldRedistStore(fromSST_rh) failed' ) + ENDIF + fromSST_rh_ready = .TRUE. + ENDIF + DO i=1, datacount + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_StateSetNeeded(importState, ',TRIM(datanames(i)),')' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateSetNeeded( importState, TRIM(datanames(i)), & + ESMF_NEEDED, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE(str,*) 'WRFSSTCpl_run: ESMF_StateSetNeeded(',TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( str ) + ENDIF + ENDDO + ENDIF + + ! In this case, the coupling is symmetric - you call redist going + ! both ways - so we only care about the coupling direction in order + ! to get the right routehandle selected. + IF ( fromWRF ) THEN + WRITE(str,*) 'WRFSSTCpl_run: routehandle = fromWRF_rh' + CALL wrf_debug ( 100 , TRIM(str) ) + routehandle = fromWRF_rh + ELSE + WRITE(str,*) 'WRFSSTCpl_run: routehandle = fromSST_rh' + CALL wrf_debug ( 100 , TRIM(str) ) + routehandle = fromSST_rh + ENDIF + + DO i=1, datacount + WRITE(str,*) 'WRFSSTCpl_run: grabbing field <',TRIM(datanames(i)),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + ! check isneeded flag here + IF ( .NOT. ESMF_StateIsNeeded( importState, TRIM(datanames(i)), rc=rc ) ) THEN + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE(str,*) 'WRFSSTCpl_run: ESMF_StateIsNeeded(',TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( str ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: skipping field <',TRIM(datanames(i)),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + CYCLE + ENDIF + + WRITE(str,*) 'WRFSSTCpl_run: processing field <',TRIM(datanames(i)),'>' + CALL wrf_debug ( 100 , TRIM(str) ) + +! The following piece of code provides an example of calling the data +! redistribution routine between two Fields in the Coupler Component. +! Unlike regrid, which translates between +! different Grids, redist translates between different DELayouts on +! the same Grid. The first two lines get the Fields from the +! States, each corresponding to a different subcomponent. One is +! an Export State and the other is an Import State. +! + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_StateGetField(importState,', & + TRIM(datanames(i)),')...' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGetField( importState, TRIM(datanames(i)), src_field, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE(str,*) 'WRFSSTCpl_run: ESMF_StateGetField(importState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( str ) + ENDIF + +!$$$$ debugging... +!$$$ CALL ESMF_CplCompRun(compCplWRFSST, exportStateSST, & +!$$$ importStateWRF, driverClock, rc=rc) +!$$$ Why is LANDMASK not on importStateWRF? May be moot now due to fix in Registry... + + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_StateGetField(exportState,', & + TRIM(datanames(i)),')...' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_StateGetField( exportState, TRIM(datanames(i)), dst_field, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + WRITE(str,*) 'WRFSSTCpl_run: ESMF_StateGetField(exportState,', & + TRIM(datanames(i)),') failed' + CALL wrf_error_fatal ( str ) + ENDIF + +! The redist routine uses information contained in the Fields and the +! Coupler VM object to call the communication routines to move the data. +! Because many Fields may share the same Grid association, the same +! routing information may be needed repeatedly. Route information is +! saved so the precomputed information can be retained. The following +! is an example of a Field redist call: +!$$$DEBUG +!CALL wrf_debug ( 100, 'WRFSSTCpl_run '//TRIM(directionString)//': calling ESMF_FieldPrint( src_field )' ) +!CALL ESMF_FieldPrint( src_field, rc=rc ) +!CALL wrf_debug ( 100, 'WRFSSTCpl_run '//TRIM(directionString)//': back from ESMF_FieldPrint( src_field )' ) +!CALL ESMF_FieldGetDataPointer( src_field, tmp_data_ptr, rc=rc ) +!IF (rc /= ESMF_SUCCESS) THEN +! WRITE(str,*) 'WRFSSTCpl_run '//TRIM(directionString)//': ESMF_FieldGetDataPointer( src_field, '//TRIM(datanames(i))//' ) returned rc = ',rc +! CALL wrf_debug ( 100 , TRIM(str) ) +! CALL wrf_error_fatal ( & +! 'WRFSSTCpl_run '//TRIM(directionString)//': ESMF_FieldGetDataPointer( src_field, ... ) failed' ) +!ENDIF +!CALL wrf_debug( 100, 'WRFSSTCpl_run: writing DEBUG1_CPLcmp_src_'//TRIM(directionString)//'_'//TRIM(datanames(i))//'_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_CPLcmp_src_'//TRIM(directionString)//'_'//TRIM(datanames(i))//'_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') TRIM(datanames(i)) +!DO jj = jps, MIN( (jde-1), jpe ) +! DO ii = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',ii,',',jj,'): ',tmp_data_ptr(ii,jj) +! ENDDO +!ENDDO +!CLOSE (985) +!$$$END DEBUG + WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_FieldRedist for <', & + TRIM(datanames(i)),'>...' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_FieldRedist( src_field, dst_field, routehandle, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_FieldRedist failed' ) + ENDIF + WRITE(str,*) 'WRFSSTCpl_run: back from ESMF_FieldRedist for <', & + TRIM(datanames(i)),'>...' + CALL wrf_debug ( 100 , TRIM(str) ) +!$$$DEBUG +!CALL wrf_debug ( 100, 'WRFSSTCpl_run '//TRIM(directionString)//': calling ESMF_FieldPrint( dst_field )' ) +!CALL ESMF_FieldPrint( dst_field, rc=rc ) +!CALL wrf_debug ( 100, 'WRFSSTCpl_run '//TRIM(directionString)//': back from ESMF_FieldPrint( dst_field )' ) +!CALL ESMF_FieldGetDataPointer( dst_field, tmp_data_ptr, rc=rc ) +!IF (rc /= ESMF_SUCCESS) THEN +! WRITE(str,*) 'WRFSSTCpl_run '//TRIM(directionString)//': ESMF_FieldGetDataPointer( dst_field, '//TRIM(datanames(i))//' ) returned rc = ',rc +! CALL wrf_debug ( 100 , TRIM(str) ) +! CALL wrf_error_fatal ( & +! 'WRFSSTCpl_run '//TRIM(directionString)//': ESMF_FieldGetDataPointer( dst_field, ... ) failed' ) +!ENDIF +!CALL wrf_debug( 100, 'WRFSSTCpl_run: writing DEBUG1_CPLcmp_dst_'//TRIM(directionString)//'_'//TRIM(datanames(i))//'_'//TRIM(timestamp) ) +!OPEN( UNIT=985, FILE='DEBUG1_CPLcmp_dst_'//TRIM(directionString)//'_'//TRIM(datanames(i))//'_'//TRIM(timestamp), FORM='formatted' ) +!WRITE (985,'(a)') TRIM(datanames(i)) +!DO jj = jps, MIN( (jde-1), jpe ) +! DO ii = ips, MIN( (ide-1), ipe ) +! WRITE (985,*) '(',ii,',',jj,'): ',tmp_data_ptr(ii,jj) +! ENDDO +!ENDDO +!CLOSE (985) +!$$$END DEBUG + + ENDDO + + WRITE(str,*) 'WRFSSTCpl_run: end' + CALL wrf_debug ( 100 , TRIM(str) ) + + END SUBROUTINE WRFSSTCpl_run + + + + SUBROUTINE WRFSSTCpl_final(comp, importState, exportState, clock, rc) + TYPE(ESMF_CplComp) :: comp + TYPE(ESMF_State), INTENT(INOUT) :: importState, exportState + TYPE(ESMF_Clock), INTENT(INOUT) :: clock + INTEGER, INTENT(OUT) :: rc +! +! WRF-SST coupler component finalize routine. +! +! The arguments are: +! comp Component +! importState Importstate +! exportState Exportstate +! clock External clock +! rc Return code; equals ESMF_SUCCESS if there are no errors, +! otherwise ESMF_FAILURE. +! + + PRINT *, "DEBUG: Coupler Final starting" + + ! guilty until proven innocent + rc = ESMF_FAILURE + + ! Only thing to do here is release redist and route handles + IF ( fromWRF_rh_ready ) THEN + CALL ESMF_FieldRedistRelease(fromWRF_rh, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_final: ESMF_FieldRedistRelease(fromWRF_rh) failed' ) + ENDIF + CALL ESMF_RouteHandleDestroy(fromWRF_rh, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_final: ESMF_RouteHandleDestroy(fromWRF_rh) failed' ) + ENDIF + ENDIF + IF ( fromSST_rh_ready ) THEN + CALL ESMF_FieldRedistRelease(fromSST_rh, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_final: ESMF_FieldRedistRelease(fromSST_rh) failed' ) + ENDIF + CALL ESMF_RouteHandleDestroy(fromSST_rh, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'WRFSSTCpl_final: ESMF_RouteHandleDestroy(fromSST_rh) failed' ) + ENDIF + ENDIF + + PRINT *, "DEBUG: Coupler Final returning" + + END SUBROUTINE WRFSSTCpl_final + + +END MODULE module_wrfsst_coupler + + + + +PROGRAM wrf_SST_ESMF + +!$$$AAAA + +!$$$TBH: update this documentation! + +! +! ESMF Application Wrapper for coupling WRF with a "dummy" component +! that simply reads SSTs from a file and sends them to WRF (one-way +! coupling). +! +! Note that, like other WRF coupling methods (MCEL, MCT), ESMF coupling is +! supported only via auxiliary input and history streams. +! +! This is the main program that creates the ESMF Gridded and Coupler +! Component. +! +! "init" looks like this: +! 1. Init phase 1 for WRF, sets WRF exportState metadata for "time" +! and "domain" information needed by WRF IOAPI (which is called from +! the SST component). It also sets up all WRF and WSF modules. Note +! that this must be called before SST phase-1 init because SST uses +! WRF IOAPI. +! 2. Init phase 1 for SST, sets "time" metadata in SST exportState. +! 3. Initialize coupler, passing decomposition metadata from WRF exportState +! to SST importState. +! 4. Resolve any "time" metadata inconsistencies and create top-level clock. +! 5. Init phase 2 for SST, gets "domain" information from importState, +! creates an ESMF_Grid based on "domain" information using the exact same +! method as WRF (so WRF IOAPI calls will work), and sets up SST +! importState and exportState. +! 6. Init phase 2 for WRF, runs up to the end of the head_grid I/O "training" +! phase (done in med_before_solve_io()). This initializes WRF +! importState and exportState prior to the first coupling step during the +! "run" loop. Note that this only works for head_grid at present because +! recursion in WRF traversal of subdomains is not dealt with yet and +! because the code that populates the WRF importState and exportState is +! not yet sophisticated enough to handle creating and destroying nested +! domains at any time during the model run. +!$$$ NOTE: At the moment, any ESMF auxio that does not begin at the start +!$$$ of the model run will FAIL due to the way WRF init phases have +!$$$ been split. A solution would be to split the WRF run into two +!$$$ phases instead and run the first part, which will stop after +!$$$ "training", at the very start of the "run" loop". The main +!$$$ implication of this change would be that WRF import and export +!$$$ states would not be valid until after first-phase run were +!$$$ called. A nasty business either way. TBH +! +!$$$here... Note that we really need nested states, one for each auxio stream!! +!$$$here... For now, only support one input and/or one output stream via +!$$$here... io_esmf. This condition is asserted in +!$$$here... ext_esmf_open_for_read_begin() and +!$$$here... ext_esmf_open_for_write_begin(). +! +! "run" loop looks like this: +! 1. Run SST phase 1, reads SST from file and writes it to SST exportState +! for coupling to WRF. +! 2. Couple SST exportState -> WRF importState. First iteration: set up +! SST->WRF routeHandle via lazy evaluation. +! 3. Run WRF. First iteration: head_grid resumes after I/O "training" +! phase. Other iterations and domains: run normally. +! Read WRF importState and write WRF exportState (via med_before_solve_io()). +! Note that WRF assigns sst -> tsk for sea points in +! share/module_soil_pre.F. +!$$$here... However, WRF does NOT assign tsk -> sst. Do we need to send TSK +!$$$here... from WRF too for self-test? +!$$$here... eventually couple LANDMASK on first iteration only +!$$$here... For concurrent coupling, must break wrf_run into two phases, first +!$$$here... phase returns after the call to med_before_solve_io(), second phase +!$$$here... resumes after the call to med_before_solve_io(). This is +!$$$here... *relatively* easy if we limit ESMF coupling to head_grid, but is +!$$$here... NOT so easy otherwise due to recursion. Also, we will need +!$$$here... dynamic ESMF_States to couple to WRF nested domains since the +!$$$here... nested domains may be created/destroyed at any time during the +!$$$here... model run! Not clear that using ESMF to couple directly to WRF +!$$$here... nested domains is a small effort, and not clear that it is needed. +! +!$$$ Note that moving init phase-2 to a first run phase and then splitting +!$$$ yet again after med_before_solve_io() would lead to three run phases for +!$$$ WRF. One could argue that since the current "everyone calls everything" +!$$$ ESMF model for "concurrent components" is suboptimal for loosely-coupled +!$$$ concurrency anyway, we should aviod the split after +!$$$ med_before_solve_io(), limit ESMF use in WRF to sequential coupling, and +!$$$ use MCEL/MCT for concurrent coupling. Food for thought... TBH +! +! 4. Couple WRF exportState -> SST importState. First iteration: set up +! WRF->SST routeHandle via lazy evaluation. +! 5. Run SST phase 2, compare SST from file with SST from WRF (via +! SST importState) and error-exit if they differ. +! 6. Advance clock and goto step 1 +! +! "finalize" is trivial, except for destruction of ESMF objects which is +! quite non-trivial at the moment. +! +! + +!$$$ TBH: Need to eliminate duplication between wrf_ESMFApp.F +!$$$ TBH: and wrf_SST_ESMF.F. + + ! WRF registration routine + USE module_wrf_setservices, ONLY: WRF_register + ! SST registration routine + USE module_sst_setservices, ONLY: SST_register + ! WRF-SST coupler registration routine + USE module_wrfsst_coupler, ONLY: WRFSSTCpl_register + ! ESMF module, defines all ESMF data types and procedures + USE ESMF_Mod + ! Not-yet-implemented ESMF features + USE module_esmf_extensions + ! Component-independent utilities + USE module_metadatautils, ONLY: GetTimesFromStates + + IMPLICIT NONE + + ! Local variables + + ! Components + TYPE(ESMF_GridComp) :: compGriddedWRF ! WRF + TYPE(ESMF_GridComp) :: compGriddedSST ! SST reader + TYPE(ESMF_CplComp) :: compCplWRFSST ! WRF-SST coupler + + ! State, Virtual Machine, and DELayout + TYPE(ESMF_VM) :: vm + TYPE(ESMF_State) :: importStateWRF, exportStateWRF + TYPE(ESMF_State) :: importStateSST, exportStateSST + + ! A clock, some times, and a time step + TYPE(ESMF_Clock) :: driverClock + TYPE(ESMF_Time) :: startTime + TYPE(ESMF_Time) :: stopTime + TYPE(ESMF_TimeInterval) :: couplingInterval + + ! other misc stuff + TYPE(ESMF_State) :: tmpState + INTEGER :: timestepdebug + + ! Return codes for error checks + INTEGER :: rc + CHARACTER (ESMF_MAXSTR) :: str + + ! debugging + CHARACTER(LEN=256) :: couplingIntervalString + + + ! Warn users that this is not yet ready for general use. + PRINT *, ' W A R N I N G ' + PRINT *, ' ESMF COUPLING CAPABILITY IS EXPERIMENTAL AND UNSUPPORTED ' + PRINT *, ' IN THIS VERSION OF WRF-SST ' + PRINT *, ' U S E A T Y O U R O W N R I S K ' + + ! This call includes everything that must be done before ESMF_Initialize() + ! is called. + CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called) + + ! Initialize ESMF, get the default Global VM, and set + ! the default calendar to be Gregorian. + CALL ESMF_Initialize( vm=vm, defaultCalendar=ESMF_CAL_GREGORIAN, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_Initialize failed' + ENDIF + ! Note: wrf_debug and wrf_error_fatal are not initialized yet + PRINT *, 'DEBUG wrf_SST_ESMF: returned from ESMF_Initialize' + CALL ESMF_SetInitialized() ! eliminate this once ESMF does it internally + + ! Create the WRF Gridded Component, passing in the default VM. + compGriddedWRF = ESMF_GridCompCreate(vm, "WRF Model", rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_GridCompCreate(WRF Model) failed' + ENDIF + + ! Create the SST Gridded Component, passing in the default VM. + compGriddedSST = ESMF_GridCompCreate(vm, "SST Dummy Model", rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_GridCompCreate(WRF Dummy Model) failed' + ENDIF + + ! Create the WRF-SST Coupler Component, passing in the default VM. + compCplWRFSST = ESMF_CplCompCreate(vm, "WRF-SST Coupler", rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_CplCompCreate failed' + ENDIF + + ! Create empty import and export states for WRF + importStateWRF = ESMF_StateCreate("WRF Import State", statetype=ESMF_STATE_IMPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_StateCreate(WRF Import State) failed' + ENDIF + exportStateWRF = ESMF_StateCreate("WRF Export State", statetype=ESMF_STATE_EXPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_StateCreate(WRF Export State) failed' + ENDIF + + ! Create empty import and export states for SST + importStateSST = ESMF_StateCreate("SST Import State", statetype=ESMF_STATE_IMPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_StateCreate(SST Import State) failed' + ENDIF + exportStateSST = ESMF_StateCreate("SST Export State", statetype=ESMF_STATE_EXPORT, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_StateCreate(SST Export State) failed' + ENDIF + + ! Register the WRF Gridded Component + CALL ESMF_GridCompSetServices(compGriddedWRF, WRF_register, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_GridCompSetServices(compGriddedWRF) failed' + ENDIF + + ! Register the SST Gridded Component + CALL ESMF_GridCompSetServices(compGriddedSST, SST_register, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_GridCompSetServices(compGriddedSST) failed' + ENDIF + + ! Register the WRF-SST Coupler Component + CALL ESMF_CplCompSetServices(compCplWRFSST, WRFSSTCpl_register, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_CplCompSetServices failed' + ENDIF + + ! Create top-level clock. There is no way to create an "empty" clock, so + ! stuff in bogus values for start time, stop time, and time step and fix + ! them after gridded component "init" phases return. + CALL ESMF_TimeSet(startTime, yy=2000, mm=1, dd=1, & + h=0, m=0, s=0, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_TimeSet(startTime) failed' + ENDIF + CALL ESMF_TimeSet(stopTime, yy=2000, mm=1, dd=1, & + h=12, m=0, s=0, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_TimeSet(stopTime) failed' + ENDIF + CALL ESMF_TimeIntervalSet(couplingInterval, s=2, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_TimeIntervalSet failed' + ENDIF + driverClock = ESMF_ClockCreate(timeStep=couplingInterval, & + startTime=startTime, & + stopTime=stopTime, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + PRINT *, 'wrf_SST_ESMF: ESMF_ClockCreate failed' + ENDIF + + ! Init, Run, and Finalize section + + ! Init... + ! initialize WRF, phase 1 + ! Phase 1 init returns WRF time and decomposition information as + ! exportState metadata. + PRINT *, 'DEBUG wrf_SST_ESMF: calling phase-1 WRF init (wrf_component_init1)' + CALL ESMF_GridCompInitialize(compGriddedWRF, importStateWRF, & + exportStateWRF, driverClock, phase=1, rc=rc) + ! Note: wrf_debug and wrf_error_fatal are now initialized + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(WRF phase 1) failed' ) + ENDIF + + ! initialize SST, phase 1 + ! Phase 1 init returns SST time information as + ! exportState metadata. + PRINT *, 'DEBUG wrf_SST_ESMF: calling phase-1 SST init (sst_component_init1)' + CALL ESMF_GridCompInitialize(compGriddedSST, importStateSST, & + exportStateSST, driverClock, phase=1, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(SST phase 1) failed' ) + ENDIF + + ! Reconcile clock settings from WRF and SST components to set up + ! top-level clock. These are passed back from each "init" as attributes + ! on exportState*. + ! Stuff both States into a single State to pass into GetTimesFromStates() + ! which is smart enough to deal with a Composite. + PRINT *, 'DEBUG wrf_SST_ESMF: reconciling clock from WRF and SST components' + tmpState = ESMF_StateCreate( rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateCreate(tmpState) failed' ) + ENDIF + CALL ESMF_StateAddState( tmpState, exportStateWRF, rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateAddState(exportStateWRF) failed' ) + ENDIF + CALL ESMF_StateAddState( tmpState, exportStateSST, rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateAddState(exportStateSST) failed' ) + ENDIF + CALL GetTimesFromStates( tmpState, startTime, stopTime, couplingInterval ) + CALL ESMF_TimeIntervalGet( couplingInterval, TimeString=couplingIntervalString, & + rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_TimeIntervalGet failed' ) + ENDIF + CALL wrf_debug( 100, 'wrf_SST_ESMF: couplingInterval = '//TRIM(couplingIntervalString) ) + CALL ESMF_StateDestroy( tmpState, rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateDestroy(tmpState) failed' ) + ENDIF + ! update driver clock + CALL ESMF_ClockDestroy(driverClock, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_ClockDestroy failed' ) + ENDIF + driverClock = ESMF_ClockCreate(timeStep=couplingInterval, & + startTime=startTime, & + stopTime=stopTime, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_ClockCreate(driverClock) failed' ) + ENDIF + PRINT *, 'DEBUG wrf_SST_ESMF: done reconciling clock from WRF and SST components' + CALL wrf_clockprint(50, driverClock, & + 'DEBUG wrf_SST_ESMF: driverClock after creation,') + + ! initialize WRF-SST Coupler + PRINT *, 'DEBUG wrf_SST_ESMF: calling phase-1 CPL init (WRFSSTCpl_init)' + CALL ESMF_CplCompInitialize(compCplWRFSST, exportStateWRF, & + importStateSST, driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_CplCompInitialize(WRF -> SST) failed' ) + ENDIF +! TBH: this bit is not needed +! CALL ESMF_CplCompInitialize(compCplWRFSST, exportStateSST, & +! importStateWRF, driverClock, rc=rc) +! IF ( rc /= ESMF_SUCCESS ) THEN +! CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_CplCompInitialize(SST -> WRF) failed' ) +! ENDIF + + ! initialize SST, phase 2 + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling phase-2 init for SST (sst_component_init2)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_GridCompInitialize(compGriddedSST, importStateSST, & + exportStateSST, driverClock, phase=2, rc=rc) + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from phase-2 init for SST' + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(SST phase 2) failed' ) + ENDIF + + ! initialize WRF, phase 2 + ! Phase 2 init sets up WRF importState and exportState. + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling phase-2 init for WRF (wrf_component_init2)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_GridCompInitialize(compGriddedWRF, importStateWRF, & + exportStateWRF, driverClock, phase=2, rc=rc) + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from phase-2 init for WRF' + CALL wrf_debug ( 100 , TRIM(str) ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(WRF phase 2) failed' ) + ENDIF + + CALL wrf_clockprint(50, driverClock, & + 'DEBUG wrf_SST_ESMF: driverClock before main time-stepping loop,') + ! Run... + ! main time-stepping loop + timestepdebug = 0 + DO WHILE ( .NOT. ESMF_ClockIsStopTime(driverClock, rc) ) + + timestepdebug = timestepdebug + 1 + WRITE(str,'(A,I8)') 'PROGRAM wrf_SST_ESMF: Top of time-stepping loop, timestepdebug = ',timestepdebug + CALL wrf_debug ( 100 , TRIM(str) ) + CALL wrf_clockprint(50, driverClock, & + 'DEBUG wrf_SST_ESMF: driverClock at top of time-stepping loop,') + + ! Run SST phase 1 + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling phase-1 run for SST (sst_component_run1)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_GridCompRun(compGriddedSST, importStateSST, exportStateSST, & + driverClock, phase=1, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompRun(SST phase 1) failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from phase-1 run for SST (sst_component_run1)' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! couple SST export -> WRF import + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling run for CPL SST->WRF (WRFSSTCpl_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_CplCompRun(compCplWRFSST, exportStateSST, & + importStateWRF, driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_CplCompRun(SST -> WRF) failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from run for CPL SST->WRF (WRFSSTCpl_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! Run WRF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling run for WRF (wrf_component_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_GridCompRun(compGriddedWRF, importStateWRF, exportStateWRF, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompRun(WRF) failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from run for WRF (wrf_component_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! couple WRF export -> SST import + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling run for CPL WRF->SST (WRFSSTCpl_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_CplCompRun(compCplWRFSST, exportStateWRF, & + importStateSST, driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_CplCompRun(WRF -> SST) failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from run for CPL WRF->SST (WRFSSTCpl_run)' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! Run SST phase 2 + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: Calling phase-2 run for SST (sst_component_run2)' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_GridCompRun(compGriddedSST, importStateSST, exportStateSST, & + driverClock, phase=2, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompRun(SST phase 2) failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: back from phase-2 run for SST (sst_component_run2)' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! advance clock to next coupling time step + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: advancing clock' + CALL wrf_debug ( 100 , TRIM(str) ) + CALL ESMF_ClockAdvance( driverClock, rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_ClockAdvance failed' ) + ENDIF + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: done advancing clock' + CALL wrf_debug ( 100 , TRIM(str) ) + + CALL wrf_clockprint(50, driverClock, & + 'DEBUG wrf_SST_ESMF: driverClock at end of time-stepping loop,') + + ENDDO + + WRITE(str,'(A)') 'PROGRAM wrf_SST_ESMF: done with time-stepping loop' + CALL wrf_debug ( 100 , TRIM(str) ) + + ! clean up SST + CALL ESMF_GridCompFinalize(compGriddedSST, importStateSST, exportStateSST, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompFinalize(compGriddedSST) failed' ) + ENDIF + + ! clean up compCplWRFSST + CALL ESMF_CplCompFinalize( compCplWRFSST, exportStateWRF, importStateSST, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_CplCompFinalize(compCplWRFSST) failed' ) + ENDIF + + ! clean up WRF + ! must do this AFTER clean up of SST since SST uses WRF IOAPI + CALL ESMF_GridCompFinalize(compGriddedWRF, importStateWRF, exportStateWRF, & + driverClock, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompFinalize(compGriddedWRF) failed' ) + ENDIF + + ! Clean up + + CALL ESMF_GridCompDestroy(compGriddedWRF, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompDestroy(compGriddedWRF) failed' ) + ENDIF + CALL ESMF_StateDestroy(importStateWRF, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateDestroy(importStateWRF) failed' ) + ENDIF + CALL ESMF_StateDestroy(exportStateWRF, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateDestroy(exportStateWRF) failed' ) + ENDIF + CALL ESMF_StateDestroy(importStateSST, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateDestroy(importStateSST) failed' ) + ENDIF + CALL ESMF_StateDestroy(exportStateSST, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_StateDestroy(exportStateSST) failed' ) + ENDIF + CALL ESMF_ClockDestroy(driverClock, rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_ClockDestroy(driverClock) failed' ) + ENDIF + + CALL ESMF_Finalize( rc=rc ) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_Finalize failed' ) + ENDIF + +END PROGRAM wrf_SST_ESMF + + diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile new file mode 100644 index 00000000..87b62e37 --- /dev/null +++ b/wrfv2_fire/phys/Makefile @@ -0,0 +1,259 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + + +MODULES = \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_gfs.o \ + module_bl_myjpbl.o \ + module_cu_kf.o \ + module_cu_bmj.o \ + module_cu_kfeta.o \ + module_cu_gd.o \ + module_cu_sas.o \ + module_mp_kessler.o \ + module_mp_ncloud5.o \ + module_mp_lin.o \ + module_mp_ncloud3.o \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + module_mp_wsm6.o \ + module_mp_etanew.o \ + module_mp_thompson.o \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_rrtm.o \ + module_ra_cam.o \ + module_ra_gfdleta.o \ + module_sf_sfclay.o \ + module_sf_gfs.o \ + module_sf_slab.o \ + module_sf_noahlsm.o \ + module_sf_urban.o \ + module_sf_lsm_nmm.o \ + module_sf_ruclsm.o \ + module_sf_sfcdiags.o \ + module_sf_myjsfc.o \ + module_physics_addtendc.o \ + module_physics_init.o \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o \ + module_progtm.o \ + module_pbl_driver.o \ + module_cumulus_driver.o \ + module_microphysics_driver.o \ + module_microphysics_zero_out.o \ + module_mixactivate.o \ + module_radiation_driver.o \ + module_surface_driver.o \ + module_diagnostics.o \ + module_fdda_psufddagd.o \ + module_fddagd_driver.o \ + module_fddaobs_rtfdda.o \ + module_fddaobs_driver.o \ + module_fire_driver.o \ + module_fr_cawfe.o + +OBJS = + +NMM_MODULES = + +LIBTARGET = physics +TARGETDIR = ./ + +$(LIBTARGET) : + if [ $(WRF_NMM_CORE) -eq 1 ] ; then \ + $(MAKE) nmm_contrib ; \ + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) $(NMM_OBJS) $(NMM_MODULES) ; \ + else \ + $(MAKE) non_nmm ; \ + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) ; \ + fi + +include ../configure.wrf + +nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) $(MODULES) $(OBJS) + +non_nmm : $(MODULES) $(OBJS) + +clean: + @ echo 'use the clean script' + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +module_bl_myjpbl.o: ../share/module_model_constants.o + +module_bl_gfs.o: module_gfs_machine.o \ + module_gfs_physcons.o + +module_cu_bmj.o: ../share/module_model_constants.o + +module_cu_kf.o: ../frame/module_wrf_error.o + +module_cu_kfeta.o: ../frame/module_wrf_error.o + +module_cu_gd.o: + +module_gfs_physcons.o: module_gfs_machine.o + +module_gfs_funcphys.o: module_gfs_machine.o \ + module_gfs_physcons.o + +module_cu_sas.o: module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o + +module_ra_gfdleta.o: ../frame/module_dm.o + +module_ra_rrtm.o: ../frame/module_wrf_error.o \ + ../frame/module_dm.o + +module_ra_cam.o: ../frame/module_wrf_error.o \ + ../frame/module_dm.o + +module_mp_lin.o : ../frame/module_wrf_error.o + +module_sf_lsm_nmm.o: ../share/module_model_constants.o \ + ../share/module_MPP.o + +module_sf_myjsfc.o: ../share/module_model_constants.o + +module_sf_gfs.o: module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o \ + module_progtm.o + +module_sf_noahlsm.o: ../share/module_model_constants.o \ + module_sf_urban.o + +module_sf_ruclsm.o: ../frame/module_wrf_error.o + +module_physics_addtendc.o: \ + module_cu_kf.o \ + module_cu_kfeta.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o + +module_physics_init.o : \ + module_ra_rrtm.o \ + module_ra_cam.o \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_gfdleta.o \ + module_sf_sfclay.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_noahlsm.o \ + module_sf_ruclsm.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_gfs.o \ + module_bl_myjpbl.o \ + module_cu_kf.o \ + module_cu_kfeta.o \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_sas.o \ + module_mp_ncloud3.o \ + module_mp_ncloud5.o \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + module_mp_wsm6.o \ + module_mp_etanew.o \ + module_fdda_psufddagd.o \ + module_fddaobs_rtfdda.o \ + module_mp_thompson.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o \ + ../share/module_model_constants.o \ + module_sf_lsm_nmm.o + +module_microphysics_driver.o: \ + module_mixactivate.o \ + module_mp_kessler.o module_mp_lin.o \ + module_mp_ncloud3.o module_mp_ncloud5.o \ + module_mp_wsm3.o module_mp_wsm5.o \ + module_mp_wsm6.o module_mp_etanew.o \ + module_mp_thompson.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + +module_cumulus_driver.o: \ + module_cu_kf.o \ + module_cu_kfeta.o \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_sas.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + +module_pbl_driver.o: \ + module_bl_myjpbl.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_gfs.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + +module_mixactivate.o: \ + module_radiation_driver.o + +module_radiation_driver.o: \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_rrtm.o \ + module_ra_cam.o \ + module_ra_gfdleta.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + +module_surface_driver.o: \ + module_sf_sfclay.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_gfs.o \ + module_sf_noahlsm.o \ + module_sf_ruclsm.o \ + module_sf_sfcdiags.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + module_sf_lsm_nmm.o + +module_diagnostics.o: ../frame/module_dm.o + +module_fddagd_driver.o: \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + module_fdda_psufddagd.o + +module_fddaobs_driver.o: \ + ../frame/module_domain.o \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + module_fddaobs_rtfdda.o + +module_fire_driver.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_fr_cawfe.o + +module_fr_cawfe.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + +# DO NOT DELETE diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F new file mode 100755 index 00000000..f747205c --- /dev/null +++ b/wrfv2_fire/phys/module_bl_gfs.F @@ -0,0 +1,1122 @@ +!LWRF:MODEL_LAYER:PHYSICS +! +MODULE module_bl_gfs + +CONTAINS + +!------------------------------------------------------------------- + SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D, P3D,PI3D, & + RUBLTEN,RVBLTEN,RTHBLTEN, & + RQVBLTEN,RQCBLTEN, & + CP,G,ROVCP,R,ROVG,FLAG_QI, & + dz8w,z,PSFC, & + UST,PBL,PSIM,PSIH, & + HFX,QFX,TSK,GZ1OZ0,WSPD,BR, & + DT,KPBL2D,EP1,KARMAN, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ! optional + qi3d,rqiblten ) +!-------------------------------------------------------------------- + USE MODULE_GFS_MACHINE, ONLY : kind_phys +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- TH3D 3D potential temperature (K) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- QC3D 3D cloud mixing ratio (Kg/Kg) +!-- QI3D 3D ice mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- PI3D 3D exner function (dimensionless) +!-- rr3D 3D dry air density (kg/m^3) +!-- RUBLTEN U tendency due to +! PBL parameterization (m/s^2) +!-- RVBLTEN V tendency due to +! PBL parameterization (m/s^2) +!-- RTHBLTEN Theta tendency due to +! PBL parameterization (K/s) +!-- RQVBLTEN Qv tendency due to +! PBL parameterization (kg/kg/s) +!-- RQCBLTEN Qc tendency due to +! PBL parameterization (kg/kg/s) +!-- RQIBLTEN Qi tendency due to +! PBL parameterization (kg/kg/s) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- G acceleration due to gravity (m/s^2) +!-- ROVCP R/CP +!-- R gas constant for dry air (J/kg/K) +!-- ROVG R/G +!-- P_QI species index for cloud ice +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- PSFC pressure at the surface (Pa) +!-- UST u* in similarity theory (m/s) +!-- PBL PBL height (m) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity stability function for heat +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- TSK surface temperature (K) +!-- GZ1OZ0 log(z/z0) where z0 is roughness length +!-- WSPD wind speed at lowest model level (m/s) +!-- BR bulk Richardson number in surface layer +!-- DT time step (s) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- KARMAN Von Karman constant +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + LOGICAL, INTENT(IN) :: flag_qi + + REAL, INTENT(IN) :: & + CP, & + DT, & + EP1, & + G, & + KARMAN, & + R, & + ROVCP, & + ROVG + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & + DZ8W, & + P3D, & + PI3D, & + QC3D, & + QV3D, & + T3D, & + TH3D, & + U3D, & + V3D, & + Z + + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & + RTHBLTEN, & + RQCBLTEN, & + RQVBLTEN, & + RUBLTEN, & + RVBLTEN + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & + BR, & + GZ1OZ0, & + HFX, & + PSFC, & + PSIM, & + PSIH, & + QFX, & + TSK + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: & + PBL, & + UST, & + WSPD + + INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & + KPBL2D + +!--------------------------- OPTIONAL VARS ------------------------------ + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + OPTIONAL, INTENT(IN) :: & + QI3D + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + OPTIONAL, INTENT(INOUT) :: & + RQIBLTEN + +!--------------------------- LOCAL VARS ------------------------------ + + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte) :: & + DEL, & + DU, & + DV, & + PHIL, & + PRSL, & + PRSLK, & + T1, & + TAU, & + U1, & + V1 + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) :: & + PHII, & + PRSI + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte, 3) :: & + Q1, & + RTG + + REAL (kind=kind_phys), DIMENSION(its:ite) :: & + DQSFC, & + DTSFC, & + DUSFC, & + DVSFC, & + EVAP, & + FH, & + FM, & + HEAT, & + HGAMQ, & + HGAMT, & + HPBL, & + PSK, & + QSS, & + RBSOIL, & + RCL, & + SPD1, & + STRESS, & + TSEA + + REAL (kind=kind_phys) :: & + CPM, & + DELTIM, & + FMTMP, & + RRHOX + + INTEGER, DIMENSION( its:ite ) :: & + KPBL + + INTEGER :: & + I, & + IM, & + J, & + K, & + KM, & + KTEM, & + KTEP, & + KX, & + L, & + NTRAC + + IM=ITE-ITS+1 + KX=KTE-KTS+1 + KTEM=KTE-1 + KTEP=KTE+1 + NTRAC=2 + DELTIM=DT + IF (flag_qi) NTRAC=3 + + + DO J=jts,jte + + DO i=its,ite + RRHOX=(R*T3D(I,KTS,J)*(1.+EP1*QV3D(I,KTS,J)))/PSFC(I,J) + CPM=CP*(1.+0.8*QV3D(i,kts,j)) + FMTMP=GZ1OZ0(i,j)-PSIM(i,j) + PSK(i)=(PSFC(i,j)*.00001)**ROVCP + FM(i)=FMTMP + FH(i)=GZ1OZ0(i,j)-PSIH(i,j) + TSEA(i)=TSK(i,j) + QSS(i)=QV3D(i,kts,j) ! not used in moninp so set to qv3d for now + HEAT(i)=HFX(i,j)/CPM*RRHOX + EVAP(i)=QFX(i,j)*RRHOX + STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP) + SPD1(i)=WSPD(i,j) + PRSI(i,kts)=PSFC(i,j)*.001 + PHII(I,kts)=0. + RCL(i)=1. + RBSOIL(I)=BR(i,j) + ENDDO + + DO k=kts,kte + DO i=its,ite + DV(I,K) = 0. + DU(I,K) = 0. + TAU(I,K) = 0. + U1(I,K) = U3D(i,k,j) + V1(I,K) = V3D(i,k,j) + T1(I,K) = T3D(i,k,j) + Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j)) + Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j)) + PRSL(I,K)=P3D(i,k,j)*.001 + ENDDO + ENDDO + + DO k=kts,kte + DO i=its,ite + PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP + ENDDO + ENDDO + + DO k=kts+1,kte + km=k-1 + DO i=its,ite + DEL(i,km)=PRSL(i,km)/ROVG*dz8w(i,km,j)/T3D(i,km,j) + PRSI(i,k)=PRSI(i,km)-DEL(i,km) + PHII(I,K)=(Z(i,k,j)-Z(i,kts,j))*G + PHIL(I,KM)=0.5*(Z(i,k,j)+Z(i,km,j)-2.*Z(i,kts,j))*G + ENDDO + ENDDO + + DO i=its,ite + DEL(i,kte)=DEL(i,ktem) + PRSI(i,ktep)=PRSI(i,kte)-DEL(i,ktem) + PHII(I,KTEP)=PHII(I,KTE)+dz8w(i,kte,j)*G + PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE) + ENDDO + + IF (flag_QI .AND. PRESENT( QI3D ) ) THEN + DO k=kts,kte + DO i=its,ite + Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j)) + ENDDO + ENDDO + ENDIF + + DO l=1,ntrac + DO k=kts,kte + DO i=its,ite + RTG(I,K,L) = 0. + ENDDO + ENDDO + ENDDO + + CALL MONINP(IM,IM,KX,NTRAC,DV,DU,TAU,RTG,U1,V1,T1,Q1, & + PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS, & + SPD1,KPBL,PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL, & + DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ) + + + DO k=kts,kte + DO i=its,ite + RVBLTEN(I,K,J)=DV(I,K) + RUBLTEN(I,K,J)=DU(I,K) + RTHBLTEN(I,K,J)=TAU(I,K)/PI3D(I,K,J) + RQVBLTEN(I,K,J)=RTG(I,K,1)/(1.-Q1(I,K,1))**2 + RQCBLTEN(I,K,J)=RTG(I,K,2)/(1.-Q1(I,K,2))**2 + ENDDO + ENDDO + + IF (flag_QI .AND. PRESENT( RQIBLTEN )) THEN + DO k=kts,kte + DO i=its,ite + RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2 + ENDDO + ENDDO + ENDIF + + DO i=its,ite + UST(i,j)=SQRT(STRESS(i)) + WSPD(i,j)=SQRT(U3D(I,KTS,J)*U3D(I,KTS,J)+ & + V3D(I,KTS,J)*V3D(I,KTS,J))+1.E-9 + PBL(i,j)=HPBL(i) + KPBL2D(i,j)=kpbl(i) + ENDDO + + ENDDO + + + END SUBROUTINE BL_GFS + +!=================================================================== + SUBROUTINE gfsinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, & + restart, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: allowed_to_read,restart + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI, P_FIRST_SCALAR + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN + INTEGER :: i, j, k, itf, jtf, ktf + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RUBLTEN(i,k,j)=0. + RVBLTEN(i,k,j)=0. + RTHBLTEN(i,k,j)=0. + RQVBLTEN(i,k,j)=0. + RQCBLTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQIBLTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gfsinit + +! -------------------------------------------------------------- +!FPP$ NOCONCUR R + SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & + & U1,V1,T1,Q1, & + & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, & +! & PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL, & + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,DELTIM, & + & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ) +! + USE MODULE_GFS_MACHINE, ONLY : kind_phys + USE MODULE_GFS_PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP & + &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt + + implicit none +! +! include 'constant.h' +! +! +! Arguments +! + integer IX, IM, KM, ntrac, KPBL(IM) +! + real(kind=kind_phys) DELTIM + real(kind=kind_phys) DV(IM,KM), DU(IM,KM), & + & TAU(IM,KM), RTG(IM,KM,ntrac), & + & U1(IX,KM), V1(IX,KM), & + & T1(IX,KM), Q1(IX,KM,ntrac), & + & PSK(IM), RBSOIL(IM), & +! & CD(IM), CH(IM), & + & FM(IM), FH(IM), & + & TSEA(IM), QSS(IM), & + & SPD1(IM), & +! & DPHI(IM), SPD1(IM), & + & PRSI(IX,KM+1), DEL(IX,KM), & + & PRSL(IX,KM), PRSLK(IX,KM), & + & PHII(IX,KM+1), PHIL(IX,KM), & + & RCL(IM), DUSFC(IM), & + & dvsfc(IM), dtsfc(IM), & + & DQSFC(IM), HPBL(IM), & + & HGAMT(IM), hgamq(IM) +! +! Locals +! + integer i,iprt,is,iun,k,kk,kmpbl,lond +! real(kind=kind_phys) betaq(IM), betat(IM), betaw(IM), & + real(kind=kind_phys) evap(IM), heat(IM), phih(IM), & + & phim(IM), rbdn(IM), rbup(IM), & + & the1(IM), stress(im), beta(im), & + & the1v(IM), thekv(IM), thermal(IM), & + & thesv(IM), ustar(IM), wscale(IM) +! & thesv(IM), ustar(IM), wscale(IM), zl1(IM) +! + real(kind=kind_phys) RDZT(IM,KM-1), & + & ZI(IM,KM+1), ZL(IM,KM), & + & DKU(IM,KM-1), DKT(IM,KM-1), DKO(IM,KM-1), & + & AL(IM,KM-1), AD(IM,KM), & + & AU(IM,KM-1), A1(IM,KM), & + & A2(IM,KM), THETA(IM,KM), & + & AT(IM,KM*(ntrac-1)) + logical pblflg(IM), sfcflg(IM), stable(IM) +! + real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, & + & cfac, conq, cont, conw, & + & conwrc, dk, dkmax, dkmin, & + & dq1, dsdz2, dsdzq, dsdzt, & + & dsig, dt, dthe1, dtodsd, & + & dtodsu, dw2, dw2min, g, & + & gamcrq, gamcrt, gocp, gor, gravi, & + & hol, pfac, prmax, prmin, prinv, & + & prnum, qmin, qtend, rbcr, & + & rbint, rdt, rdz, rdzt1, & + & ri, rimin, rl2, rlam, & + & rone, rzero, sfcfrac, & + & sflux, shr2, spdk2, sri, & + & tem, ti, ttend, tvd, & + & tvu, utend, vk, vk2, & + & vpert, vtend, xkzo, zfac, & + & zfmin, zk, tem1 +! + PARAMETER(g=grav) + PARAMETER(GOR=G/RD,GOCP=G/CP) + PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G) + PARAMETER(RLAM=150.,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) + PARAMETER(DW2MIN=0.0001,DKMIN=1.0,DKMAX=1000.,RIMIN=-100.) + PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) + PARAMETER(QMIN=1.E-8,XKZO=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) + PARAMETER(GAMCRT=3.,GAMCRQ=0.) + PARAMETER(RZERO=0.,RONE=1.) + PARAMETER(IUN=84) +! +! +!----------------------------------------------------------------------- +! + 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) + 602 FORMAT(1X,' K',' Z',' T',' TH', & + & ' TVH',' Q',' U',' V', & + & ' SP') + 603 FORMAT(1X,I5,8F9.1) + 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) + 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' & + & ,' THERMAL RBUP') + 606 FORMAT(1X,I5,6F8.2) + 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', & + & ' HGAMQ WS USTAR CD CH') + 608 FORMAT(1X,I5,9F8.2) + 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) + 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', & + & ' SR2 ',2F8.2,2E10.2) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! COMPUTE PRELIMINARY VARIABLES +! + + if (IX .lt. im) stop +! + IPRT = 0 + IF(IPRT.EQ.1) THEN +!!! LATD = 0 + LOND = 0 + ELSE +!!! LATD = 0 + LOND = 0 + ENDIF +! + gravi = 1.0 / grav + DT = 2. * DELTIM + RDT = 1. / DT + KMPBL = KM / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo +! + do k=1,kmpbl + do i=1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + enddo + enddo +! + DO K = 1,KM-1 + DO I=1,IM + RDZT(I,K) = GOR * PRSI(I,K+1) / (PRSL(I,K) - PRSL(I,K+1)) + ENDDO + ENDDO +! + DO I = 1,IM + DUSFC(I) = 0. + DVSFC(I) = 0. + DTSFC(I) = 0. + DQSFC(I) = 0. + HGAMT(I) = 0. + HGAMQ(I) = 0. + WSCALE(I) = 0. + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + PBLFLG(I) = .TRUE. + SFCFLG(I) = .TRUE. + IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. + ENDDO +!! + DO I=1,IM + RDZT1 = GOR * prSL(i,1) / DEL(i,1) +! BET1 = DT*RDZT1*SPD1(I)/T1(I,1) + BETA(I) = DT*RDZT1/T1(I,1) +! BETAW(I) = BET1*CD(I) +! BETAT(I) = BET1*CH(I) +! BETAQ(I) = DPHI(I)*BETAT(I) + ENDDO +! + DO I=1,IM +! ZL1(i) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(PRSL(I,1)/PRSI(I,1))*ROG +! USTAR(I) = SQRT(CD(I)*SPD1(I)**2) + USTAR(I) = SQRT(STRESS(I)) + ENDDO +! + DO I=1,IM + THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) + THE1(I) = THETA(I,1) + THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN)) + THERMAL(I) = THE1V(I) +! DTHE1 = (THE1(I)-TSEA(I)) +! DQ1 = (MAX(Q1(I,1,1),QMIN) - MAX(QSS(I),QMIN)) +! HEAT(I) = -CH(I)*SPD1(I)*DTHE1 +! EVAP(I) = -CH(I)*SPD1(I)*DQ1 + ENDDO +! +! +! COMPUTE THE FIRST GUESS OF PBL HEIGHT +! + DO I=1,IM + STABLE(I) = .FALSE. +! ZL(i,1) = ZL1(i) + RBUP(I) = RBSOIL(I) + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE) + RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +! + DO I = 1,IM + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + ENDDO +!! + DO I=1,IM + HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) + IF(SFCFLG(I)) THEN + HOL = MIN(HOL,-ZFMIN) + ELSE + HOL = MAX(HOL,ZFMIN) + ENDIF +! +! HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC + HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC + IF(SFCFLG(I)) THEN +! PHIM = (1.-APHI16*HOL)**(-1./4.) +! PHIH = (1.-APHI16*HOL)**(-1./2.) + TEM = 1.0 / (1. - APHI16*HOL) + PHIH(I) = SQRT(TEM) + PHIM(I) = SQRT(PHIH(I)) + ELSE + PHIM(I) = (1.+APHI5*HOL) + PHIH(I) = PHIM(I) + ENDIF + WSCALE(I) = USTAR(I)/PHIM(I) + WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) + WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) + ENDDO +! +! COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION +! UNDER UNSTABLE CONDITIONS +! + DO I = 1,IM + SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I) + IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN + HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) + HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) + VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) + VPERT = MIN(VPERT,GAMCRT) + THERMAL(I) = THERMAL(I) + MAX(VPERT,RZERO) + HGAMT(I) = MAX(HGAMT(I),RZERO) + HGAMQ(I) = MAX(HGAMQ(I),RZERO) + ELSE + PBLFLG(I) = .FALSE. + ENDIF + ENDDO +! + DO I = 1,IM + IF(PBLFLG(I)) THEN + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + ENDIF + ENDDO +! +! ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL +! + DO I = 1, IM + IF(PBLFLG(I)) THEN + STABLE(I) = .FALSE. + RBUP(I) = RBSOIL(I) + ENDIF + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE) + RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +! + DO I = 1,IM + IF(PBLFLG(I)) THEN + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. + ENDIF + ENDDO +!! +! +! COMPUTE DIFFUSION COEFFICIENTS BELOW PBL +! + DO K = 1, KMPBL + DO I=1,IM + IF(KPBL(I).GT.K) THEN + PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) + PRINV = MIN(PRINV,PRMAX) + PRINV = MAX(PRINV,PRMIN) +! ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ & +! & (HPBL(I)-ZL1(I))), ZFMIN) + ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ & + & (HPBL(I)-ZL(I,1))), ZFMIN) + DKU(i,k) = XKZO + WSCALE(I)*VK*ZI(I,K+1) & + & * ZFAC**PFAC + DKT(i,k) = DKU(i,k)*PRINV + DKO(i,k) = (DKU(i,k)-XKZO)*PRINV + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) + DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k))) + ENDIF + ENDDO + ENDDO +! +! COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) +! + DO K = 1, KM-1 + DO I=1,IM + IF(K.GE.KPBL(I)) THEN +! TI = 0.5*(T1(i,k)+T1(i,K+1)) + TI = 2.0 / (T1(i,k)+T1(i,K+1)) +! RDZ = RDZT(I,K)/TI + RDZ = RDZT(I,K) * TI +! RDZ = RDZT(I,K) + DW2 = RCL(i)*((U1(i,k)-U1(i,K+1))**2 & + & + (V1(i,k)-V1(i,K+1))**2) + SHR2 = MAX(DW2,DW2MIN)*RDZ**2 + TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN)) +! BVF2 = G*(GOCP+RDZ*(TVU-TVD))/TI + BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI + RI = MAX(BVF2/SHR2,RIMIN) + ZK = VK*ZI(I,K+1) +! RL2 = (ZK*RLAM/(RLAM+ZK))**2 +! DK = RL2*SQRT(SHR2) + RL2 = ZK*RLAM/(RLAM+ZK) + DK = RL2*RL2*SQRT(SHR2) + IF(RI.LT.0.) THEN ! UNSTABLE REGIME + SRI = SQRT(-RI) + DKU(i,k) = XKZO + DK*(1+8.*(-RI)/(1+1.746*SRI)) +! DKT(i,k) = XKZO + DK*(1+8.*(-RI)/(1+1.286*SRI)) + tem = DK*(1+8.*(-RI)/(1+1.286*SRI)) + DKT(i,k) = XKZO + tem + DKO(i,k) = tem + ELSE ! STABLE REGIME +! DKT(i,k) = XKZO + DK/(1+5.*RI)**2 + tem = DK/(1+5.*RI)**2 + DKT(i,k) = XKZO + tem + DKO(i,k) = tem + PRNUM = 1.0 + 2.1*RI + PRNUM = MIN(PRNUM,PRMAX) + DKU(i,k) = (DKT(i,k)-XKZO)*PRNUM + XKZO + ENDIF +! + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) + DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k))) +! +!!! IF(I.EQ.LOND.AND.LAT.EQ.LATD) THEN +!!! PRNUM = DKU(k)/DKT(k) +!!! WRITE(IUN,610) K,PRNUM,DKT(k),DKU(k),RL2,RI, +!!! 1 BVF2,SHR2 +!!! ENDIF +! + ENDIF + ENDDO + ENDDO +! +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE +! + DO I=1,IM + AD(I,1) = 1. + A1(I,1) = T1(i,1) + BETA(i) * HEAT(I) + A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I) +! A1(I,1) = T1(i,1)-BETAT(I)*(THETA(i,1)-TSEA(I)) +! A2(I,1) = Q1(i,1,1)-BETAQ(I)* +! & (MAX(Q1(i,1,1),QMIN)-MAX(QSS(I),QMIN)) + ENDDO +! + DO K = 1,KM-1 + DO I = 1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) + RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) +! RDZ = RDZT(I,K) + tem1 = DSIG * DKT(i,k) * RDZ + IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) +! DSDZQ = DSIG*DKT(i,k)*RDZ*(-HGAMQ(I)/HPBL(I)) + tem = 1.0 / HPBL(I) + DSDZT = tem1 * (GOCP-HGAMT(I)*tem) + DSDZQ = tem1 * (-HGAMQ(I)*tem) + A2(I,k) = A2(I,k)+DTODSD*DSDZQ + A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ + ELSE +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP) + DSDZT = tem1 * GOCP + A2(I,k+1) = Q1(i,k+1,1) + ENDIF +! DSDZ2 = DSIG*DKT(i,k)*RDZ*RDZ + DSDZ2 = tem1 * RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k) = A1(I,k)+DTODSD*DSDZT + A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT + ENDDO + ENDDO +! +! SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE +! + CALL TRIDIN(IM,KM,1,AL,AD,AU,A1,A2,AU,A1,A2) +! +! RECOVER TENDENCIES OF HEAT AND MOISTURE +! + DO K = 1,KM + DO I = 1,IM + TTEND = (A1(I,k)-T1(i,k))*RDT + QTEND = (A2(I,k)-Q1(i,k,1))*RDT + TAU(i,k) = TAU(i,k)+TTEND + RTG(I,k,1) = RTG(i,k,1)+QTEND + DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND + DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND + ENDDO + ENDDO +! +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM +! + DO I=1,IM +! AD(I,1) = 1.+BETAW(I) + AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I) + A1(I,1) = U1(i,1) + A2(I,1) = V1(i,1) +! AD(I,1) = 1.0 +! tem = 1.0 + BETA(I) * STRESS(I) / SPD1(I) +! A1(I,1) = U1(i,1) * tem +! A2(I,1) = V1(i,1) * tem + ENDDO +! + DO K = 1,KM-1 + DO I=1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) + RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1)) +! RDZ = RDZT(I,K) + DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k+1) = U1(i,k+1) + A2(I,k+1) = V1(i,k+1) + ENDDO + ENDDO +! +! SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM +! + CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) +! +! RECOVER TENDENCIES OF MOMENTUM +! + DO K = 1,KM + DO I = 1,IM + CONWRC = CONW*SQRT(RCL(i)) + UTEND = (A1(I,k)-U1(i,k))*RDT + VTEND = (A2(I,k)-V1(i,k))*RDT + DU(i,k) = DU(i,k)+UTEND + DV(i,k) = DV(i,k)+VTEND + DUSFC(I) = DUSFC(I)+CONWRC*DEL(I,K)*UTEND + DVSFC(I) = DVSFC(I)+CONWRC*DEL(I,K)*VTEND + ENDDO + ENDDO +!! +! +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR TRACERS +! + if (ntrac .ge. 2) then + DO I=1,IM + AD(I,1) = 1. + ENDDO + do k = 2, ntrac + is = (k-2) * km + do i = 1, im + AT(I,1+is) = Q1(i,1,k) + enddo + enddo +! + DO K = 1,KM-1 + DO I = 1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) + RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) + tem1 = DSIG * DKT(i,k) * RDZ + DSDZ2 = tem1 * RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + ENDDO + ENDDO + do kk = 2, ntrac + is = (kk-2) * km + do k = 1, km - 1 + do i = 1, im + AT(I,k+1+is) = Q1(i,k+1,kk) + enddo + enddo + enddo +! +! SOLVE TRIDIAGONAL PROBLEM FOR TRACERS +! + CALL TRIDIT(IM,KM,ntrac-1,AL,AD,AU,AT,AU,AT) +! +! RECOVER TENDENCIES OF TRACERS +! + do kk = 2, ntrac + is = (kk-2) * km + do k = 1, km + do i = 1, im + QTEND = (AT(I,K+is)-Q1(i,K,kk))*RDT + RTG(i,K,kk) = RTG(i,K,kk) + QTEND + enddo + enddo + enddo + endif +!! + RETURN + END SUBROUTINE MONINP +!FPP$ NOCONCUR R +!----------------------------------------------------------------------- + SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2) +!sela %INCLUDE DBTRIDI2; +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer k,n,l,i + real(kind=kind_phys) fk +! + real(kind=kind_phys) CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), & + & AU(L,N-1),A1(L,N),A2(L,N) +!----------------------------------------------------------------------- + DO I=1,L + FK = 1./CM(I,1) + AU(I,1) = FK*CU(I,1) + A1(I,1) = FK*R1(I,1) + A2(I,1) = FK*R2(I,1) + ENDDO + DO K=2,N-1 + DO I=1,L + FK = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K) = FK*CU(I,K) + A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) + A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) + ENDDO + ENDDO + DO I=1,L + FK = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) + A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) + ENDDO + DO K=N-1,1,-1 + DO I=1,L + A1(I,K) = A1(I,K)-AU(I,K)*A1(I,K+1) + A2(I,K) = A2(I,K)-AU(I,K)*A2(I,K+1) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE TRIDI2 +!FPP$ NOCONCUR R +!----------------------------------------------------------------------- + SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2) +!sela %INCLUDE DBTRIDI2; +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer is,k,kk,n,nt,l,i + real(kind=kind_phys) fk(L) +! + real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), & + & R1(L,N), R2(L,N*nt), & + & AU(L,N-1), A1(L,N), A2(L,N*nt), & + & FKK(L,2:N-1) +!----------------------------------------------------------------------- + DO I=1,L + FK(I) = 1./CM(I,1) + AU(I,1) = FK(I)*CU(I,1) + A1(I,1) = FK(I)*R1(I,1) + ENDDO + do k = 1, nt + is = (k-1) * n + do i = 1, l + a2(i,1+is) = fk(I) * r2(i,1+is) + enddo + enddo + DO K=2,N-1 + DO I=1,L + FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K) = FKK(I,K)*CU(I,K) + A1(I,K) = FKK(I,K)*(R1(I,K)-CL(I,K)*A1(I,K-1)) + ENDDO + ENDDO + do kk = 1, nt + is = (kk-1) * n + DO K=2,N-1 + DO I=1,L + A2(I,K+is) = FKK(I,K)*(R2(I,K+is)-CL(I,K)*A2(I,K+is-1)) + ENDDO + ENDDO + ENDDO + DO I=1,L + FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + A1(I,N) = FK(I)*(R1(I,N)-CL(I,N)*A1(I,N-1)) + ENDDO + do k = 1, nt + is = (k-1) * n + do i = 1, l + A2(I,N+is) = FK(I)*(R2(I,N+is)-CL(I,N)*A2(I,N+is-1)) + enddo + enddo + DO K=N-1,1,-1 + DO I=1,L + A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1) + ENDDO + ENDDO + do kk = 1, nt + is = (kk-1) * n + DO K=n-1,1,-1 + DO I=1,L + A2(I,K+is) = A2(I,K+is) - AU(I,K)*A2(I,K+is+1) + ENDDO + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE TRIDIN + SUBROUTINE TRIDIT(L,N,nt,CL,CM,CU,RT,AU,AT) +!sela %INCLUDE DBTRIDI2; +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer is,k,kk,n,nt,l,i + real(kind=kind_phys) fk(L) +! + real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), & + & RT(L,N*nt), & + & AU(L,N-1), AT(L,N*nt), & + & FKK(L,2:N-1) +!----------------------------------------------------------------------- + DO I=1,L + FK(I) = 1./CM(I,1) + AU(I,1) = FK(I)*CU(I,1) + ENDDO + do k = 1, nt + is = (k-1) * n + do i = 1, l + at(i,1+is) = fk(I) * rt(i,1+is) + enddo + enddo + DO K=2,N-1 + DO I=1,L + FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K) = FKK(I,K)*CU(I,K) + ENDDO + ENDDO + do kk = 1, nt + is = (kk-1) * n + DO K=2,N-1 + DO I=1,L + AT(I,K+is) = FKK(I,K)*(RT(I,K+is)-CL(I,K)*AT(I,K+is-1)) + ENDDO + ENDDO + ENDDO + DO I=1,L + FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + ENDDO + do k = 1, nt + is = (k-1) * n + do i = 1, l + AT(I,N+is) = FK(I)*(RT(I,N+is)-CL(I,N)*AT(I,N+is-1)) + enddo + enddo + do kk = 1, nt + is = (kk-1) * n + DO K=n-1,1,-1 + DO I=1,L + AT(I,K+is) = AT(I,K+is) - AU(I,K)*AT(I,K+is+1) + ENDDO + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE TRIDIT + +!----------------------------------------------------------------------- + + END MODULE module_bl_gfs diff --git a/wrfv2_fire/phys/module_bl_mrf.F b/wrfv2_fire/phys/module_bl_mrf.F new file mode 100644 index 00000000..8c636c1c --- /dev/null +++ b/wrfv2_fire/phys/module_bl_mrf.F @@ -0,0 +1,1400 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_bl_mrf + +CONTAINS + +!------------------------------------------------------------------- + SUBROUTINE MRF(U3D,V3D,TH3D,T3D,QV3D,QC3D,P3D,PI3D, & + RUBLTEN,RVBLTEN,RTHBLTEN, & + RQVBLTEN,RQCBLTEN, & + CP,G,ROVCP,R,ROVG, & + dz8w,z,XLV,RV,PSFC, & + ZNT,UST,ZOL,HOL,PBL,PSIM,PSIH, & + XLAND,HFX,QFX,TSK,GZ1OZ0,WSPD,BR, & + DT,DTMIN,KPBL2D, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT,& + flag_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ! Optional + QI3D,RQIBLTEN, & + regime ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- TH3D 3D potential temperature (K) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- QC3D 3D cloud mixing ratio (Kg/Kg) +!-- QI3D 3D ice mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- PI3D 3D exner function (dimensionless) +!-- rr3D 3D dry air density (kg/m^3) +!-- RUBLTEN U tendency due to +! PBL parameterization (m/s^2) +!-- RVBLTEN V tendency due to +! PBL parameterization (m/s^2) +!-- RTHBLTEN Theta tendency due to +! PBL parameterization (K/s) +!-- RQVBLTEN Qv tendency due to +! PBL parameterization (kg/kg/s) +!-- RQCBLTEN Qc tendency due to +! PBL parameterization (kg/kg/s) +!-- RQIBLTEN Qi tendency due to +! PBL parameterization (kg/kg/s) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- G acceleration due to gravity (m/s^2) +!-- ROVCP R/CP +!-- R gas constant for dry air (J/kg/K) +!-- ROVG R/G +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- XLV latent heat of vaporization (J/kg) +!-- RV gas constant for water vapor (J/kg/K) +!-- PSFC pressure at the surface (Pa) +!-- ZNT roughness length (m) +!-- UST u* in similarity theory (m/s) +!-- ZOL z/L height over Monin-Obukhov length +!-- HOL PBL height over Monin-Obukhov length +!-- PBL PBL height (m) +!-- REGIME flag indicating PBL regime (stable, unstable, etc.) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity stability function for heat +!-- XLAND land mask (1 for land, 2 for water) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- TSK surface temperature (K) +!-- GZ1OZ0 log(z/z0) where z0 is roughness length +!-- WSPD wind speed at lowest model level (m/s) +!-- BR bulk Richardson number in surface layer +!-- DT time step (s) +!-- DTMIN time step (minute) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) +!-- SVPT0 constant for saturation vapor pressure (K) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- EP2 constant for specific humidity calculation +!-- KARMAN Von Karman constant +!-- EOMEG angular velocity of earth's rotation (rad/s) +!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + +! + REAL, INTENT(IN ) :: DT,DTMIN,CP,G,ROVCP, & + ROVG,R,XLV,RV + + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + QC3D, & + P3D, & + PI3D, & + TH3D, & + T3D, & + dz8w, & + z +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: XLAND, & + HFX, & + QFX + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: HOL, & + UST, & + PBL, & + ZNT + + LOGICAL, INTENT(IN) :: FLAG_QI +! +!m The following 5 variables are changed to memory size from tile size-- +! + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: & + PSIM, & + PSIH + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + WSPD + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: & + GZ1OZ0, & + BR + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: PSFC + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: TSK + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ZOL + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT ) :: KPBL2D + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: U3D, & + V3D +! +! Optional +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(INOUT) :: REGIME + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RQIBLTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: QI3D + +! LOCAL VARS + REAL, DIMENSION( its:ite, kts:kte ) :: dz8w2d, & + z2d + + + INTEGER :: I,J,K,NK + +! + DO J=jts,jte + DO k=kts,kte + NK=kme-k + DO i=its,ite + dz8w2d(I,K) = dz8w(i,NK,j) + z2d(I,K) = z(i,NK,j) + ENDDO + ENDDO + + + CALL MRF2D(J,U3D(ims,kms,j),V3D(ims,kms,j),T3D(ims,kms,j), & + QV3D(ims,kms,j),QC3D(ims,kms,j), & + P3D(ims,kms,j),RUBLTEN(ims,kms,j),RVBLTEN(ims,kms,j),& + RTHBLTEN(ims,kms,j),RQVBLTEN(ims,kms,j), & + RQCBLTEN(ims,kms,j), & + CP,G,ROVCP,R,ROVG, & + dz8w2d,z2d,XLV,Rv, & + PSFC(ims,j),ZNT(ims,j), & + UST(ims,j),ZOL(ims,j), & + HOL(ims,j),PBL(ims,j),PSIM(ims,j), & + PSIH(ims,j),XLAND(ims,j),HFX(ims,j),QFX(ims,j), & + TSK(ims,j),GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j), & + DT,DTMIN,KPBL2D(ims,j), & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & + flag_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + !optional + QI2DTEN=RQIBLTEN(ims,kms,j), & + REGIME=REGIME(ims,j),QI2D=QI3D(ims,kms,j) ) + + + DO k=kts,kte + DO i=its,ite + RTHBLTEN(I,K,J)=RTHBLTEN(I,K,J)/PI3D(I,K,J) + ENDDO + ENDDO + + ENDDO + + END SUBROUTINE MRF + +!------------------------------------------------------------------- + SUBROUTINE MRF2D(J,U2D,V2D,T2D,QV2D,QC2D, P2D, & + U2DTEN,V2DTEN,T2DTEN, & + QV2DTEN,QC2DTEN, & + CP,G,ROVCP,R,ROVG, & + dz8w2d,z2d,XLV,RV,PSFCPA, & + ZNT,UST,ZOL,HOL,PBL,PSIM,PSIH, & + XLAND,HFX,QFX,TSK,GZ1OZ0,WSPD,BR, & + DT,DTMIN,KPBL1D, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT,& + flag_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ! optional + regime, qi2d, QI2DTEN ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! BASED ON THE "COUNTERGRADIENT" TRANSPORT TERM OF TROEN +! AND MAHRT (1986) FOR THE UNSTABLE PBL. +! THIS ROUTINE USES AN IMPLICIT APPROACH FOR VERTICAL FLUX +! DIVERGENCE AND DOES NOT REQUIRE "MITER" TIMESTEPS. +! IT INCLUDES VERTICAL DIFFUSION IN THE STABLE ATMOSPHERE +! AND MOIST VERTICAL DIFFUSION IN CLOUDS. +! SURFACE FLUXES CALCULATED AS IN HIRPBL. +! 5-LAYER SOIL MODEL OPTION REQUIRED IN SLAB DUE TO LONG TIMESTEP +! +! CODED BY SONG-YOU HONG (NCEP), IMPLEMENTED BY JIMY DUDHIA (NCAR) +! FALL 1996 +! +! REFERENCES: +! +! HONG AND PAN (1996), MON. WEA. REV. +! TROEN AND MAHRT (1986), BOUNDARY LAYER MET. +! +! CHANGES: +! INCREASE RLAM FROM 30 TO 150, AND CHANGE FREE ATMOSPHERE +! STABILITY FUNCTION TO INCREASE VERTICAL DIFFUSION +! (HONG, JUNE 1997) +! +! PUT LOWER LIMIT ON PSI FOR STABLE CONDITIONS. THIS WILL +! PREVENT FLUXES FROM BECOMING TOO SMALL (DUDHIA, OCTOBER 1997) +! +! CORRECTION TO REGIME CALCULATION. THIS WILL ALLOW POINTS IN +! REGIME 4 MUCH MORE FREQUENTLY GIVING LARGER SURFACE FLUXES +! REGIME 3 NO LONGER USES HOL < 1.5 OR THVX LAPSE-RATE CHECK +! IN MRF SCHEME. THIS WILL MAKE REGIME 3 MUCH LESS FREQUENT. +! +! ADD SURFACE PRESSURE, PS(I), ARRAY FOR EFFICIENCY +! +! FIX FOR PROBLEM WITH THIN LAYERS AND HIGH ROUGHNESS +! +! CHARNOCK CONSTANT NOW COMES FROM NAMELIST (DEFAULT SAME) +! +!------------------------------------------------------------------- + + REAL RLAM,PRMIN,PRMAX,XKZMIN,XKZMAX,RIMIN,BRCR, & + CFAC,PFAC,SFCFRAC,CKZ,ZFMIN,APHI5,APHI16,GAMCRT, & + GAMCRQ,XKA,PRT + + PARAMETER (RLAM=150.,PRMIN=0.5,PRMAX=4.) + PARAMETER (XKZMIN=0.01,XKZMAX=1000.,RIMIN=-100.) + PARAMETER (BRCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) + PARAMETER (CKZ=0.001,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) + PARAMETER (GAMCRT=3.,GAMCRQ=2.E-3) + PARAMETER (XKA=2.4E-5) + PARAMETER (PRT=1.) +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + J +! + LOGICAL, INTENT(IN) :: FLAG_QI +! + REAL, INTENT(IN ) :: DT,DTMIN,CP,G,ROVCP, & + ROVG,R,XLV,RV + + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT + + REAL, DIMENSION( ims:ime, kms:kme ) , & + INTENT(IN ) :: QV2D, & + QC2D, & + P2D, & + T2D +! + REAL, DIMENSION( ims:ime, kms:kme ) , & + INTENT(INOUT) :: U2DTEN, & + V2DTEN, & + T2DTEN, & + QV2DTEN, & + QC2DTEN + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: HOL, & + UST, & + PBL, & + ZNT + + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: XLAND, & + HFX, & + QFX +! +!m The following 5 are changed to memory size--- +! + REAL, DIMENSION( ims:ime ), INTENT(IN ) :: PSIM, & + PSIH + + REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: WSPD + + REAL, DIMENSION( ims:ime ), INTENT(IN ) :: GZ1OZ0, & + BR + + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: PSFCPA + + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: TSK + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: ZOL + + INTEGER, DIMENSION( ims:ime ) , & + INTENT(OUT ) :: KPBL1D + + REAL, DIMENSION( ims:ime, kms:kme ) , & + INTENT(IN ) :: U2D, & + V2D + +! MODULE-LOCAL VARIABLES (DEFINED IN SUBROUTINE MRF) +! + REAL, DIMENSION( its:ite, kts:kte ) , & + INTENT(IN) :: dz8w2d, & + z2d +! +! +! Optional +! + REAL, DIMENSION( ims:ime ) , & + OPTIONAL , & + INTENT(INOUT) :: REGIME + + REAL, DIMENSION( ims:ime, kms:kme ) , & + OPTIONAL , & + INTENT(IN ) :: QI2D + + REAL, DIMENSION( ims:ime, kms:kme ) , & + OPTIONAL , & + INTENT(INOUT) :: QI2DTEN + +! LOCAL VARS + + REAL, DIMENSION( its:ite, kts:kte+1 ) :: ZQ + + REAL, DIMENSION( its:ite, kts:kte ) :: & + UX,VX,QX, & + QCX,THX,THVX, & + DZQ,DZA, & + TTNP,QTNP, & + QCTNP,ZA, & + UXS,VXS, & + THXS,QXS, & + QCXS,QIX, & + QITNP,QIXS, & + UTNP,VTNP +! + REAL, DIMENSION( its:ite ) :: QIXSV,RHOX, & + WSPD1,GOVRTH, & + PBL0,THXSV, & + UXSV,VXSV, & + QXSV,QCXSV, & + QGH,TGDSA,PS + + INTEGER :: ILXM,JLXM,KL, & + KLM,KLP1,KLPBL +! + INTEGER, DIMENSION( its:ite ) :: KPBL,KPBL0 +! + REAL, DIMENSION( its:ite, kts:kte ) :: SCR3,SCR4 +! + REAL, DIMENSION( its:ite ) :: DUM1, & + XKZMKL +! + REAL, DIMENSION( its:ite ) :: ZL1,THERMAL, & + WSCALE,HGAMT, & + HGAMQ,BRDN, & + BRUP,PHIM, & + PHIH,CPM, & + DUSFC,DVSFC, & + DTSFC,DQSFC + +! + REAL, DIMENSION( its:ite, kts:kte ) :: XKZM,XKZH, & + A1,A2, & + AD,AU, & + TX +! + REAL, DIMENSION( its:ite, kts:kte ) :: AL +! + LOGICAL, DIMENSION( its:ite ) :: PBLFLG, & + SFCFLG, & + STABLE +! + REAL, DIMENSION( its:ite ) :: THGB + + INTEGER :: N,I,K,KK,L,NZOL,IMVDIF + + INTEGER :: JBGN,JEND,IBGN,IEND,NK + + REAL :: ZOLN,X,Y,CONT,CONQ,CONW,PL,THCON,TVCON,E1,DTSTEP + REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL + REAL :: DTTHX,PSIX,DTG,PSIQ,USTM + REAL :: DT4,RDT,SPDK2,FM,FH,HOL1,GAMFAC,VPERT,PRNUM + REAL :: ZFAC,XKZO,SS,RI,QMEAN,TMEAN,ALPH,CHI,ZK,RL2,DK,SRI + REAL :: BRINT,DTODSD,DSIG,RDZ,DSDZT,DSDZQ,DSDZ2,TTEND,QTEND + REAL :: UTEND,VTEND,QCTEND,QITEND,TGC,DTODSU + +!---------------------------------------------------------------------- + + KLPBL=1 + KL=kte + ILXM=ite-1 + JLXM=jte-1 + KLM=kte-1 + KLP1=kte+1 +! + CONT=1000.*CP/G + CONQ=1000.*XLV/G + CONW=1000./G + +!-- IMVDIF imvdif=1 for moist adiabat vertical diffusion + + IMVDIF=1 + +! DO i=its,ite +!!PS PSFC cmb +! PSFC(I)=PSFCPA(I)/1000. +! ENDDO + + +! +!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: +! + DO 5 I=its,ite + TGDSA(I)=TSK(I) +! PS PSFC cmb + PS(I)=PSFCPA(I)/1000. + THGB(I)=TSK(I)*(100./PS(I))**ROVCP + 5 CONTINUE +! +!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., +! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. +! +! *** NOTE *** +! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, +! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE +! TENDENCIES. +! + DO 24 K=kts,kte + NK=kme-K + DO 24 I=its,ite + UX(I,K)=U2D(I,NK) + VX(I,K)=V2D(I,NK) + 24 CONTINUE +! +!.....SCR3(I,K) STORE TEMPERATURE, +! SCR4(I,K) STORE VIRTUAL TEMPERATURE. +! + DO 30 K=kts,kte + NK=kme-K + DO 30 I=its,ite +! PL cmb + PL=P2D(I,NK)/1000. + SCR3(I,K)=T2D(I,NK) + THCON=(100./PL)**ROVCP + THX(I,K)=SCR3(I,K)*THCON + TX(I,K)=SCR3(I,K) + SCR4(I,K)=SCR3(I,K) + THVX(I,K)=THX(I,K) + QX(I,K)=0. + 30 CONTINUE +! + DO I=its,ite + QGH(i)=0. + CPM(i)=CP + ENDDO +! +! IF(IDRY.EQ.1)GOTO 80 + DO 50 K=kts,kte + NK=kme-K + DO 50 I=its,ite + QX(I,K)=QV2D(I,NK) + TVCON=(1.+EP1*QX(I,K)) + THVX(I,K)=THX(I,K)*TVCON + SCR4(I,K)=SCR3(I,K)*TVCON + 50 CONTINUE +! + DO 60 I=its,ite + E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) + QGH(I)=EP2*E1/(PS(I)-E1) + CPM(I)=CP*(1.+0.8*QX(I,KL)) + 60 CONTINUE +! +! IF(IMOIST.EQ.1)GOTO 80 + DO 70 K=kts,kte + NK=kme-K + DO 70 I=its,ite + QCX(I,K)=QC2D(I,NK) + 70 CONTINUE + + IF (flag_QI .AND. PRESENT( QI2D ) ) THEN + DO K=kts,kte + NK=kme-K + DO I=its,ite + QIX(I,K)=QI2D(I,NK) + ENDDO + ENDDO + ELSE + DO K=kts,kte + NK=kme-K + DO I=its,ite + QIX(I,K)=0. + ENDDO + ENDDO + ENDIF + + 80 CONTINUE + +! +!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND +! LEVEL, AND THE LAYER THICKNESSES. +! + DO 90 I=its,ite + ZQ(I,KLP1)=0. + RHOX(I)=PS(I)*1000./(R*SCR4(I,KL)) + 90 CONTINUE +! + DO 110 KK=kts,kte + K=kme-KK + DO 100 I=its,ite + DUM1(I)=ZQ(I,K+1) + 100 CONTINUE +! + DO 110 I=its,ite + ZQ(I,K)=dz8w2d(I,K)+DUM1(I) + 110 CONTINUE +! + DO 120 K=kts,kte + DO 120 I=its,ite + ZA(I,K)=0.5*(ZQ(I,K)+ZQ(I,K+1)) + DZQ(I,K)=ZQ(I,K)-ZQ(I,K+1) + 120 CONTINUE +! + DO 130 K=kts,kte-1 + DO 130 I=its,ite + DZA(I,K)=ZA(I,K)-ZA(I,K+1) + 130 CONTINUE + + DTSTEP=DT +! + DO 160 I=its,ite + GOVRTH(I)=G/THX(I,KL) + 160 CONTINUE +! +!-----INITIALIZE VERTICAL TENDENCIES AND +! + DO I=its,ite + DO K=kts,kte + UTNP(i,k)=0. + VTNP(i,k)=0. + TTNP(i,k)=0. + ENDDO + ENDDO +! +! IF(IDRY.EQ.1)GOTO 250 + DO 230 K=kts,kte + DO 230 I=its,ite + QTNP(I,K)=0. + 230 CONTINUE +! +! IF(IMOIST.EQ.1)GOTO 250 + DO 240 K=kts,kte + DO 240 I=its,ite + QCTNP(I,K)=0. + QITNP(I,K)=0. + 240 CONTINUE + + 250 CONTINUE +! +!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO +! AKB(1976), EQ(12). + +! DO 260 I=its,ite +! GZ1OZ0(I)=ALOG(ZA(I,KL)/ZNT(I)) +! IF((XLAND(I)-1.5).GE.0)THEN +! ZL=ZNT(I) +! ELSE +! ZL=0.01 +! ENDIF +! WSPD(I)=SQRT(UX(I,KL)*UX(I,KL)+VX(I,KL)*VX(I,KL)) +! TSKV=THGB(I)*(1.+EP1*QGH(I)*MAVAIL(I)) +! DTHVDZ=(THVX(I,KL)-TSKV) +! IF(-DTHVDZ.GE.0)THEN +! DTHVM=-DTHVDZ +! ELSE +! DTHVM=0. +! ENDIF +! VCONV=VCONVC*SQRT(DTHVM) +! WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV) +! WSPD(I)=AMAX1(WSPD(I),1.) +! BR(I)=GOVRTH(I)*ZA(I,KL)*DTHVDZ/(WSPD(I)*WSPD(I)) +! 260 CONTINUE + +!!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: +!! +!! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) +!! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). +!! +!! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: +!! +!! 1. BR .GE. 0.2; +!! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), +!! +!! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; +!! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS +!! (REGIME=2), +!! +!! 3. BR .EQ. 0.0 +!! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), +!! +!! 4. BR .LT. 0.0 +!! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). +!! +!!----- +! +! DO 320 I=its,ite +!!---- +!!-- REMOVE REGIME 3 DEPENDENCE ON PBL HEIGHT +!!-- IF(BR(I).LT.0..AND.HOL(I).GT.1.5)GOTO 310 +! +! IF(BR(I).LT.0.)GOTO 310 +!! +!!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: +!! +! IF(BR(I).LT.0.2)GOTO 270 +! REGIME(I)=1. +! PSIM(I)=-10.*GZ1OZ0(I) +!! LOWER LIMIT ON PSI IN STABLE CONDITIONS +! PSIM(I)=AMAX1(PSIM(I),-10.) +! PSIH(I)=PSIM(I) +! HOL(I)=0.0 +! PBL(I)=0.0 +! GOTO 320 +!! +!!-----CLASS 2; DAMPED MECHANICAL TURBULENCE: +!! +! 270 IF(BR(I).EQ.0.0)GOTO 280 +! REGIME(I)=2. +! PSIM(I)=-5.0*BR(I)*GZ1OZ0(I)/(1.1-5.0*BR(I)) +!! LOWER LIMIT ON PSI IN STABLE CONDITIONS +! PSIM(I)=AMAX1(PSIM(I),-10.) +!!.....AKB(1976), EQ(16). +! PSIH(I)=PSIM(I) +! HOL(I)=0.0 +! PBL(I)=0.0 +! GOTO 320 +!! +!!-----CLASS 3; FORCED CONVECTION: +!! +! 280 REGIME(I)=3. +! PSIM(I)=0.0 +! PSIH(I)=PSIM(I) +! +!! special use kte instead of kme +! +! DO 290 KK=kts,kte-1 +! K=kte-KK +! IF(THVX(I,K).GT.THVX(I,KL))GOTO 300 +! 290 CONTINUE +! STOP 290 +! 300 PBL(I)=ZQ(I,K+1) +! IF(UST(I).LT.0.01)THEN +! ZOL(I)=BR(I)*GZ1OZ0(I) +! ELSE +! ZOL(I)=KARMAN*GOVRTH(I)*ZA(I,KL)*MOL(I,J)/(UST(I)*UST(I)) +! ENDIF +! HOL(I)=-ZOL(I)*PBL(I)/ZA(I,KL) +! GOTO 320 +! +!!-----CLASS 4; FREE CONVECTION: +! +!! 310 IF(THVX(I,KLM).GT.THVX(I,KL))GOTO 280 +! +! 310 CONTINUE +! REGIME(I)=4. +! IF(UST(I).LT.0.01)THEN +! ZOL(I)=BR(I)*GZ1OZ0(I) +! ELSE +! ZOL(I)=KARMAN*GOVRTH(I)*ZA(I,KL)*MOL(I,J)/(UST(I)*UST(I)) +! ENDIF +! ZOL(I)=AMIN1(ZOL(I),0.) +! ZOL(I)=AMAX1(ZOL(I),-9.9999) +! NZOL=INT(-ZOL(I)*100.) +! RZOL=-ZOL(I)*100.-NZOL +! PSIM(I)=PSIMTB(NZOL)+RZOL*(PSIMTB(NZOL+1)-PSIMTB(NZOL)) +! PSIH(I)=PSIHTB(NZOL)+RZOL*(PSIHTB(NZOL+1)-PSIHTB(NZOL)) +!!---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS +!!--- THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL +! PSIH(I)=AMIN1(PSIH(I),0.9*GZ1OZ0(I)) +! PSIM(I)=AMIN1(PSIM(I),0.9*GZ1OZ0(I)) +! 320 CONTINUE + +!-----COMPUTE THE FRICTIONAL VELOCITY: +! ZA(1982) EQS(2.60),(2.61). + + DO 330 I=its,ite + DTG=THX(I,KL)-THGB(I) + PSIX=GZ1OZ0(I)-PSIM(I) + IF((XLAND(I)-1.5).GE.0)THEN + ZL=ZNT(I) + ELSE + ZL=0.01 + ENDIF + PSIQ=ALOG(KARMAN*UST(I)*ZA(I,KL)/XKA+ZA(I,KL)/ZL)-PSIH(I) + UST(I)=KARMAN*WSPD(I)/PSIX +! + USTM=AMAX1(UST(I),0.1) + IF((XLAND(I)-1.5).GE.0)THEN + UST(I)=UST(I) + ELSE + UST(I)=USTM + ENDIF +! MOL(I,J)=KARMAN*DTG/(GZ1OZ0(I)-PSIH(I))/PRT + 330 CONTINUE +! + DO 420 I=its,ite + WSPD1(I)=SQRT(UX(I,KL)*UX(I,KL)+VX(I,KL)*VX(I,KL))+1.E-9 + 420 CONTINUE +! +!---- COMPUTE VERTICAL DIFFUSION +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! COMPUTE PRELIMINARY VARIABLES +! +! + DT4=2.*DTSTEP + RDT=1./DT4 +! + DO I=its,ite + HGAMT(I)=0. + HGAMQ(I)=0. + WSCALE(I)=0. + KPBL(I)=KL + PBL(I)=ZQ(I,KL) + KPBL0(I)=KL + PBL0(I)=ZQ(I,KL) + PBLFLG(I)=.TRUE. + SFCFLG(I)=.TRUE. + IF(BR(I).GT.0.0)SFCFLG(I)=.FALSE. + ZL1(I)=ZA(I,KL) + THERMAL(I)=THVX(I,KL) + ENDDO + +! COMPUTE THE FIRST GUESS OF PBL HEIGHT + + DO I=its,ite + STABLE(I)=.FALSE. + BRUP(I)=BR(I) + ENDDO + DO K=KLM,KLPBL,-1 + DO I=its,ite + IF(.NOT.STABLE(I))THEN + BRDN(I)=BRUP(I) + SPDK2=MAX(UX(I,K)**2+VX(I,K)**2,1.) + BRUP(I)=(THVX(I,K)-THERMAL(I))*(G*ZA(I,K)/THVX(I,KL))/SPDK2 + KPBL(I)=K + STABLE(I)=BRUP(I).GT.BRCR + ENDIF + ENDDO + ENDDO +! + DO I=its,ite + K=KPBL(I) + IF(BRDN(I).GE.BRCR)THEN + BRINT=0. + ELSEIF(BRUP(I).LE.BRCR)THEN + BRINT=1. + ELSE + BRINT=(BRCR-BRDN(I))/(BRUP(I)-BRDN(I)) + ENDIF + PBL(I)=ZA(I,K+1)+BRINT*(ZA(I,K)-ZA(I,K+1)) + IF(PBL(I).LT.ZQ(I,KPBL(I)+1))KPBL(I)=KPBL(I)+1 + ENDDO +! + DO I=its,ite + FM=GZ1OZ0(I)-PSIM(I) + FH=GZ1OZ0(I)-PSIH(I) + HOL(I)=MAX(BR(I)*FM*FM/FH,RIMIN) + IF(SFCFLG(I))THEN + HOL(I)=MIN(HOL(I),-ZFMIN) + ELSE + HOL(I)=MAX(HOL(I),ZFMIN) + ENDIF +! + HOL1=HOL(I)*PBL(I)/ZL1(I)*SFCFRAC + HOL(I)=-HOL(I)*PBL(I)/ZL1(I) + IF(SFCFLG(I))THEN + PHIM(I)=(1.-APHI16*HOL1)**(-1./4.) + PHIH(I)=(1.-APHI16*HOL1)**(-1./2.) + ELSE + PHIM(I)=(1.+APHI5*HOL1) + PHIH(I)=PHIM(I) + ENDIF + WSCALE(I)=UST(I)/PHIM(I) + WSCALE(I)=MIN(WSCALE(I),UST(I)*APHI16) + WSCALE(I)=MAX(WSCALE(I),UST(I)/APHI5) + ENDDO + +! COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION +! UNDER UNSTABLE CONDITIONS + + DO I=its,ite + IF(SFCFLG(I))THEN + GAMFAC=CFAC/RHOX(I)/WSCALE(I) + HGAMT(I)=MIN(GAMFAC*HFX(I)/CPM(I),GAMCRT) + HGAMQ(I)=MIN(GAMFAC*QFX(I),GAMCRQ) + IF((XLAND(I)-1.5).GE.0)HGAMQ(I)=0. + VPERT=HGAMT(I)+EP1*THX(I,KL)*HGAMQ(I) + VPERT=MIN(VPERT,GAMCRT) + THERMAL(I)=THERMAL(I)+MAX(VPERT,0.) + HGAMT(I)=MAX(HGAMT(I),0.0) + HGAMQ(I)=MAX(HGAMQ(I),0.0) + ELSE + PBLFLG(I)=.FALSE. + ENDIF + ENDDO +! + DO I=its,ite + IF(PBLFLG(I))THEN + KPBL(I)=KL + PBL(I)=ZQ(I,KL) + ENDIF + ENDDO +! +! ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL +! + DO I=its,ite + IF(PBLFLG(I))THEN + STABLE(I)=.FALSE. + BRUP(I)=BR(I) + ENDIF + ENDDO + DO K=KLM,KLPBL,-1 + DO I=its,ite + IF(.NOT.STABLE(I).AND.PBLFLG(I))THEN + BRDN(I)=BRUP(I) + SPDK2=MAX((UX(I,K)**2+VX(I,K)**2),1.) + BRUP(I)=(THVX(I,K)-THERMAL(I))*(G*ZA(I,K)/THVX(I,KL))/SPDK2 + KPBL(I)=K + STABLE(I)=BRUP(I).GT.BRCR + ENDIF + ENDDO + ENDDO +! + DO I=its,ite + IF(PBLFLG(I))THEN + K=KPBL(I) + IF(BRDN(I).GE.BRCR)THEN + BRINT=0. + ELSEIF(BRUP(I).LE.BRCR)THEN + BRINT=1. + ELSE + BRINT=(BRCR-BRDN(I))/(BRUP(I)-BRDN(I)) + ENDIF + PBL(I)=ZA(I,K+1)+BRINT*(ZA(I,K)-ZA(I,K+1)) + IF(PBL(I).LT.ZQ(I,KPBL(I)+1))KPBL(I)=KPBL(I)+1 + IF(KPBL(I).LE.1)PBLFLG(I)=.FALSE. + ENDIF + ENDDO +! +! DIAGNOSTIC PBL HEIGHT WITH BRCR EFFECTIVELY ZERO (PBL0) +! + DO I=its,ite + IF(PBLFLG(I))THEN + STABLE(I)=.FALSE. + BRUP(I)=BR(I) + ENDIF + ENDDO + DO K=KLM,KLPBL,-1 + DO I=its,ite + IF(.NOT.STABLE(I).AND.PBLFLG(I))THEN + BRDN(I)=BRUP(I) + SPDK2=MAX((UX(I,K)**2+VX(I,K)**2),1.) + BRUP(I)=(THVX(I,K)-THERMAL(I))*(G*ZA(I,K)/THVX(I,KL))/SPDK2 + KPBL0(I)=K + STABLE(I)=BRUP(I).GT.0.0 + ENDIF + + ENDDO + ENDDO +! + DO I=its,ite + IF(PBLFLG(I))THEN + K=KPBL0(I) + IF(BRDN(I).GE.0.0)THEN + BRINT=0. + ELSEIF(BRUP(I).LE.0.0)THEN + BRINT=1. + ELSE + BRINT=(0.0-BRDN(I))/(BRUP(I)-BRDN(I)) + ENDIF + PBL0(I)=ZA(I,K+1)+BRINT*(ZA(I,K)-ZA(I,K+1)) + IF(PBL0(I).LT.ZQ(I,KPBL0(I)+1))KPBL0(I)=KPBL0(I)+1 + IF(KPBL0(I).LE.1)PBLFLG(I)=.FALSE. + ENDIF + ENDDO + +! +! COMPUTE DIFFUSION COEFFICIENTS BELOW PBL +! + DO K=kte,KLPBL,-1 + DO I=its,ite + IF(KPBL(I).LT.K)THEN + PRNUM=(PHIH(I)/PHIM(I)+CFAC*KARMAN*SFCFRAC) + PRNUM=MIN(PRNUM,PRMAX) + PRNUM=MAX(PRNUM,PRMIN) + ZFAC=MAX((1.-(ZQ(I,K)-ZL1(I))/(PBL(I)-ZL1(I))),ZFMIN) + XKZO=CKZ*DZA(I,K-1) + XKZM(I,K)=XKZO+WSCALE(I)*KARMAN*ZQ(I,K)*ZFAC**PFAC + XKZH(I,K)=XKZM(I,K)/PRNUM + XKZM(I,K)=MIN(XKZM(I,K),XKZMAX) + XKZM(I,K)=MAX(XKZM(I,K),XKZMIN) + XKZH(I,K)=MIN(XKZH(I,K),XKZMAX) + XKZH(I,K)=MAX(XKZH(I,K),XKZMIN) + ENDIF + ENDDO + ENDDO +! +! COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) +! + DO K=kts+1,kte + DO I=its,ite + XKZO=CKZ*DZA(I,K-1) + IF(K.LE.KPBL(I))THEN + SS=((UX(I,K-1)-UX(I,K))*(UX(I,K-1)-UX(I,K))+(VX(I,K-1)- & + VX(I,K))*(VX(I,K-1)-VX(I,K)))/(DZA(I,K-1)*DZA(I,K-1))+ & + 1.E-9 + RI=GOVRTH(I)*(THVX(I,K-1)-THVX(I,K))/(SS*DZA(I,K-1)) + IF(IMVDIF.EQ.1)THEN + IF((QCX(I,K)+QIX(I,K)).GT.0.01E-3.AND.(QCX(I,K-1)+ & + QIX(I,K-1)).GT.0.01E-3)THEN +! IN CLOUD + QMEAN=0.5*(QX(I,K)+QX(I,K-1)) + TMEAN=0.5*(SCR3(I,K)+SCR3(I,K-1)) + ALPH=XLV*QMEAN/R/TMEAN + CHI=XLV*XLV*QMEAN/CP/RV/TMEAN/TMEAN + RI=(1.+ALPH)*(RI-G*G/SS/TMEAN/CP*((CHI-ALPH)/(1.+CHI))) + ENDIF + ENDIF + ZK=KARMAN*ZQ(I,K) + RL2=(ZK*RLAM/(RLAM+ZK))**2 + DK=RL2*SQRT(SS) + IF(RI.LT.0.)THEN +! UNSTABLE REGIME + SRI=SQRT(-RI) + XKZM(I,K)=XKZO+DK*(1+8.*(-RI)/(1+1.746*SRI)) + XKZH(I,K)=XKZO+DK*(1+8.*(-RI)/(1+1.286*SRI)) + ELSE +! STABLE REGIME + XKZH(I,K)=XKZO+DK/(1+5.*RI)**2 + PRNUM=1.0+2.1*RI + PRNUM=MIN(PRNUM,PRMAX) + XKZM(I,K)=(XKZH(I,K)-XKZO)*PRNUM+XKZO + ENDIF +! + XKZM(I,K)=MIN(XKZM(I,K),XKZMAX) + XKZM(I,K)=MAX(XKZM(I,K),XKZMIN) + XKZH(I,K)=MIN(XKZH(I,K),XKZMAX) + XKZH(I,K)=MAX(XKZH(I,K),XKZMIN) + ENDIF +! + ENDDO + ENDDO + +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE + + DO I=its,ite + DO K=kts,kte + AU(i,k)=0. + AL(i,k)=0. + AD(i,k)=0. + A1(i,k)=0. + A2(i,k)=0. + ENDDO + ENDDO + + DO I=its,ite + AD(I,1)=1. + A1(I,1)=SCR3(I,KL)+HFX(I)/(RHOX(I)*CPM(I))/ZQ(I,KL)*DT4 + A2(I,1)=QX(I,KL)+QFX(I)/(RHOX(I))/ZQ(I,KL)*DT4 + ENDDO +! + DO K=kte,kts+1,-1 + KK=kme-K + DO I=its,ite + DTODSD=DT4/dz8w2d(I,K) + DTODSU=DT4/dz8w2d(I,K-1) + DSIG=z2d(I,K)-z2d(I,K-1) + DSIG=-DSIG + RDZ=1./DZA(I,K-1) + IF(PBLFLG(I).AND.KPBL(I).LT.K)THEN + DSDZT=DSIG*XKZH(I,K)*RDZ*(G/CP-HGAMT(I)/PBL(I)) + DSDZQ=DSIG*XKZH(I,K)*RDZ*(-HGAMQ(I)/PBL(I)) + A2(I,KK)=A2(I,KK)+DTODSD*DSDZQ + A2(I,KK+1)=QX(I,K-1)-DTODSU*DSDZQ + ELSE + DSDZT=DSIG*XKZH(I,K)*RDZ*(G/CP) + A2(I,KK+1)=QX(I,K-1) + ENDIF + DSDZ2=DSIG*XKZH(I,K)*RDZ*RDZ + AU(I,KK)=-DTODSD*DSDZ2 + AL(I,KK)=-DTODSU*DSDZ2 + AD(I,KK)=AD(I,KK)-AU(I,KK) + AD(I,KK+1)=1.-AL(I,KK) + A1(I,KK)=A1(I,KK)+DTODSD*DSDZT + A1(I,KK+1)=SCR3(I,K-1)-DTODSU*DSDZT + ENDDO + ENDDO + +! SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE + + CALL TRIDI2(AL,AD,AU,A1,A2,AU,A1,A2, & + its,ite,kts,kte ) + +! RECOVER TENDENCIES OF HEAT AND MOISTURE + + DO K=kte,kts,-1 + KK=kme-K + DO I=its,ite + TTEND=(A1(I,KK)-SCR3(I,K))*RDT + QTEND=(A2(I,KK)-QX(I,K))*RDT + TTNP(I,K)=TTNP(I,K)+TTEND + QTNP(I,K)=QTNP(I,K)+QTEND + ENDDO + ENDDO + +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM + + DO I=its,ite + DO K=kts,kte + AU(i,k)=0. + AL(i,k)=0. + AD(i,k)=0. + A1(i,k)=0. + A2(i,k)=0. + ENDDO + ENDDO + + DO I=its,ite + AD(I,1)=1. + A1(I,1)=UX(I,KL)-UX(I,KL)/WSPD1(I)*UST(I)*UST(I)/ZQ(I,KL) & + *DT4*(WSPD1(I)/WSPD(I))**2 + A2(I,1)=VX(I,KL)-VX(I,KL)/WSPD1(I)*UST(I)*UST(I)/ZQ(I,KL) & + *DT4*(WSPD1(I)/WSPD(I))**2 + ENDDO +! + DO K=kte,kts+1,-1 + KK=kme-K + DO I=its,ite + DTODSD=DT4/dz8w2d(I,K) + DTODSU=DT4/dz8w2d(I,K-1) + DSIG=z2d(I,K)-z2d(I,K-1) + DSIG=-DSIG + RDZ=1./DZA(I,K-1) + DSDZ2=DSIG*XKZM(I,K)*RDZ*RDZ + AU(I,KK)=-DTODSD*DSDZ2 + AL(I,KK)=-DTODSU*DSDZ2 + AD(I,KK)=AD(I,KK)-AU(I,KK) + AD(I,KK+1)=1.-AL(I,KK) + A1(I,KK+1)=UX(I,K-1) + A2(I,KK+1)=VX(I,K-1) + ENDDO + ENDDO + +! SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM + + CALL TRIDI2(AL,AD,AU,A1,A2,AU,A1,A2, & + its,ite,kts,kte ) + +! RECOVER TENDENCIES OF MOMENTUM + + DO K=kte,kts,-1 + KK=kme-K + DO I=its,ite + UTEND=(A1(I,KK)-UX(I,K))*RDT + VTEND=(A2(I,KK)-VX(I,K))*RDT + UTNP(I,K)=UTNP(I,K)+UTEND + VTNP(I,K)=VTNP(I,K)+VTEND + ENDDO + ENDDO + +! COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR CLOUD + + DO I=its,ite + DO K=kts,kte + AU(i,k)=0. + AL(i,k)=0. + AD(i,k)=0. + A1(i,k)=0. + A2(i,k)=0. + ENDDO + ENDDO + +! IF(IMOIST.EQ.1)GOTO 690 + DO I=its,ite + AD(I,1)=1. + A1(I,1)=QCX(I,KL) + A2(I,1)=QIX(I,KL) + ENDDO +! + DO K=kte,kts+1,-1 + KK=kme-K + DO I=its,ite + DTODSD=DT4/dz8w2d(I,K) + DTODSU=DT4/dz8w2d(I,K-1) + DSIG=z2d(I,K)-z2d(I,K-1) + DSIG=-DSIG + RDZ=1./DZA(I,K-1) + A1(I,KK+1)=QCX(I,K-1) + A2(I,KK+1)=QIX(I,K-1) + DSDZ2=DSIG*XKZH(I,K)*RDZ*RDZ + AU(I,KK)=-DTODSD*DSDZ2 + AL(I,KK)=-DTODSU*DSDZ2 + AD(I,KK)=AD(I,KK)-AU(I,KK) + AD(I,KK+1)=1.-AL(I,KK) + ENDDO + ENDDO + +! SOLVE TRIDIAGONAL PROBLEM FOR CLOUD + + CALL TRIDI2(AL,AD,AU,A1,A2,AU,A1,A2, & + its,ite,kts,kte ) +! + DO K=kte,kts,-1 + KK=kme-K + DO I=its,ite + QCTEND=(A1(I,KK)-QCX(I,K))*RDT + QITEND=(A2(I,KK)-QIX(I,K))*RDT + QCTNP(I,K)=QCTNP(I,K)+QCTEND + QITNP(I,K)=QITNP(I,K)+QITEND + ENDDO + ENDDO +! +!---- END OF VERTICAL DIFFUSION +! + 690 CONTINUE +! +!-----CALCULATION OF NEW VALUES DUE TO VERTICAL EXCHANGE PROCESSES IS +! COMPLETED. THE FINAL STEP IS TO ADD THE TENDENCIES CALCULATED +! IN HIRPBL TO THOSE OF MM4. + + DO 820 K=kts,kte + NK=kme-K + DO 820 I=its,ite + U2DTEN(I,NK)=UTNP(I,K) + V2DTEN(I,NK)=VTNP(I,K) + 820 CONTINUE +! +! IF(J.EQ.1.AND.IN.GT.1)GOTO 860 +!SUE JBGN=3 +!SUE JEND=JLXM-1 + +! change when nest +!SUE JBGN=2 +!SUE JEND=JLXM + + JBGN=jts + JEND=jte + IBGN=its + IEND=ite + +! IF(J.LT.JBGN.OR.J.GT.JEND)GOTO 860 +!SUE IBGN=3 +!SUE IEND=ILXM-1 + +! change when nest +!SUE IBGN=2 +!SUE IEND=ILXM + + DO 830 K=kts,kte + NK=kme-K + DO 830 I=IBGN,IEND + T2DTEN(I,NK)=TTNP(I,K) + 830 CONTINUE +! +! IF(IDRY.EQ.1)GOTO 860 + DO 840 K=kts,kte + NK=kme-K + DO 840 I=IBGN,IEND + QV2DTEN(I,NK)=QTNP(I,K) + 840 CONTINUE + +! IF(IMOIST.EQ.1)GOTO 860 + DO 850 K=kts,kte + NK=kme-K + DO 850 I=IBGN,IEND + QC2DTEN(I,NK)=QCTNP(I,K) + 850 CONTINUE + + IF(flag_QI .AND. PRESENT( QI2DTEN ) ) THEN + DO K=kts,kte + NK=kme-K + DO I=IBGN,IEND + QI2DTEN(I,NK)=QITNP(I,K) + ENDDO + ENDDO + ENDIF + + 860 CONTINUE +! +!-----APPLY ASSELIN FILTER TO TGD FOR LARGE TIME STEP: +! +! DO 885 I=its,ite +! TSK(I)=TSK(I)*(PS(I)/100.)**ROVCP +! 885 CONTINUE +! + 940 CONTINUE +! +! KPBL IS NEEDED FOR THE FDDA, AND SINCE THERE IS NO LONGER JUST ONE +! LARGE "J LOOP" IT MUST BE STORED AS (I,J)... +! +! USE NEW DIAGNOSED PBL DEPTH (CALCULATED WITH brcr=0.0) +! PBL IS USED FOR OUTPUT AND NEXT-TIME-STEP BELJAARS CALC IN SFCLAY + DO 950 I=its,ite + KPBL1D(I)=KPBL0(I) + PBL(I)=PBL0(I) + 950 CONTINUE + + END SUBROUTINE MRF2D + +!================================================================ + SUBROUTINE TRIDI2(CL,CM,CU,R1,R2,AU,A1,A2, & + its,ite,kts,kte ) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: its,ite, kts,kte + + REAL, DIMENSION( its:ite, kts+1:kte+1 ) , & + INTENT(IN ) :: CL + + REAL, DIMENSION( its:ite, kts:kte ) , & + INTENT(IN ) :: CM, & + R1, & + R2 + REAL, DIMENSION( its:ite, kts:kte ) , & + INTENT(INOUT) :: AU, & + CU, & + A1, & + A2 + + REAL :: FK + INTEGER :: I,K,L,N + +!---------------------------------------------------------------- + + L=ite + N=kte + + DO I=its,L + FK=1./CM(I,1) + AU(I,1)=FK*CU(I,1) + A1(I,1)=FK*R1(I,1) + A2(I,1)=FK*R2(I,1) + ENDDO + DO K=2,N-1 + DO I=its,L + FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K)=FK*CU(I,K) + A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) + A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) + ENDDO + ENDDO + DO I=its,L + FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) + A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) + + ENDDO + DO K=N-1,kts,-1 + DO I=its,L + A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1) + A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1) + ENDDO + ENDDO + + END SUBROUTINE TRIDI2 + +!=================================================================== + SUBROUTINE mrfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, & + restart, allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart , allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_FIRST_SCALAR + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN + INTEGER :: i, j, k, itf, jtf, ktf + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RUBLTEN(i,k,j)=0. + RVBLTEN(i,k,j)=0. + RTHBLTEN(i,k,j)=0. + RQVBLTEN(i,k,j)=0. + RQCBLTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQIBLTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE mrfinit + +!------------------------------------------------------------------- + +END MODULE module_bl_mrf + diff --git a/wrfv2_fire/phys/module_bl_myjpbl.F b/wrfv2_fire/phys/module_bl_myjpbl.F new file mode 100755 index 00000000..87805d18 --- /dev/null +++ b/wrfv2_fire/phys/module_bl_myjpbl.F @@ -0,0 +1,1492 @@ +!----------------------------------------------------------------------- +! + MODULE MODULE_BL_MYJPBL +! +!----------------------------------------------------------------------- +! + USE MODULE_MODEL_CONSTANTS +! +!----------------------------------------------------------------------- +! +! REFERENCES: Janjic (2002), NCEP Office Note 437 +! Mellor and Yamada (1982), Rev. Geophys. Space Phys. +! +! ABSTRACT: +! MYJ UPDATES THE TURBULENT KINETIC ENERGY WITH THE PRODUCTION/ +! DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM +! (USING AN IMPLICIT FORMULATION) FROM MELLOR-YAMADA +! LEVEL 2.5 AS EXTENDED BY JANJIC. EXCHANGE COEFFICIENTS FOR +! THE SURFACE AND FOR ALL LAYER INTERFACES ARE COMPUTED FROM +! MONIN-OBUKHOV THEORY. +! THE TURBULENT VERTICAL EXCHANGE IS THEN EXECUTED. +! +!----------------------------------------------------------------------- +! + INTEGER :: ITRMX=5 ! Iteration count for mixing length computation +! +! REAL,PARAMETER :: G=9.81,PI=3.1415926,R_D=287.04,R_V=461.6 & +! & ,VKARMAN=0.4 + REAL,PARAMETER :: PI=3.1415926,VKARMAN=0.4 +! REAL,PARAMETER :: CP=7.*R_D/2. + REAL,PARAMETER :: CAPA=R_D/CP + REAL,PARAMETER :: RLIVWV=XLS/XLV,ELOCP=2.72E6/CP + REAL,PARAMETER :: EPS1=1.E-12,EPS2=0. + REAL,PARAMETER :: EPSL=0.32,EPSRU=1.E-7,EPSRS=1.E-7 & + & ,EPSTRB=1.E-24 + REAL,PARAMETER :: EPSA=1.E-8,EPSIT=1.E-4,EPSU2=1.E-4,EPSUST=0.07 & + & ,FH=1.01 + REAL,PARAMETER :: ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & + & ,ELFC=0.23*0.5,GAM1=0.2222222222222222222 & + & ,PRT=1. + REAL,PARAMETER :: A1=0.659888514560862645 & + & ,A2x=0.6574209922667784586 & + & ,B1=11.87799326209552761 & + & ,B2=7.226971804046074028 & + & ,C1=0.000830955950095854396 + REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 + REAL,PARAMETER :: ELZ0=0.,ESQ=5.0,EXCM=0.001 & + & ,FHNEU=0.8,GLKBR=10.,GLKBS=30. & + & ,QVISC=2.1E-5,RFC=0.191,RIC=0.505,SMALL=0.35 & + & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & + & ,USTC=0.7,USTR=0.225,VISC=1.5E-5 & + & ,WOLD=0.15,WWST=1.2,ZTMAX=1.,ZTFC=1.,ZTMIN=-5. +! + REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC +! + REAL,PARAMETER :: BTG=BETA*G,CZIV=SMALL*GLKBS & +! & ,EP_1=R_V/R_D-1.,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & + & ,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & + & ,RB1=1./B1,RTVISC=1./TVISC,RVISC=1./VISC & + & ,ZQRZT=SQSC/SQPR +! + REAL,PARAMETER :: ADNH= 9.*A1*A2x*A2x*(12.*A1+3.*B2)*BTG*BTG & + & ,ADNM=18.*A1*A1*A2x*(B2-3.*A2x)*BTG & + & ,ANMH=-9.*A1*A2x*A2x*BTG*BTG & + & ,ANMM=-3.*A1*A2x*(3.*A2x+3.*B2*C1+18.*A1*C1-B2) & + & *BTG & + & ,BDNH= 3.*A2x*(7.*A1+B2)*BTG & + & ,BDNM= 6.*A1*A1 & + & ,BEQH= A2x*B1*BTG+3.*A2x*(7.*A1+B2)*BTG & + & ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & + & ,BNMH=-A2x*BTG & + & ,BNMM=A1*(1.-3.*C1) & + & ,BSHH=9.*A1*A2x*A2x*BTG & + & ,BSHM=18.*A1*A1*A2x*C1 & + & ,BSMH=-3.*A1*A2x*(3.*A2x+3.*B2*C1+12.*A1*C1-B2) & + & *BTG & + & ,CESH=A2x & + & ,CESM=A1*(1.-3.*C1) & + & ,CNV=EP_1*G/BTG & + & ,ELFCS=VKARMAN*BTG & + & ,FZQ1=RTVISC*QVISC*ZQRZT & + & ,FZQ2=RTVISC*QVISC*ZQRZT & + & ,FZT1=RVISC *TVISC*SQPR & + & ,FZT2=CZIV*GRRS*TVISC*SQPR & + & ,FZU1=CZIV*VISC & + & ,PIHF=0.5*PI & + & ,RFAC=RIC/(FHNEU*RFC*RFC) & + & ,RQVISC=1./QVISC & + & ,RRIC=1./RIC & + & ,USTFC=0.018/G & + & ,WNEW=1.-WOLD & + & ,WWST2=WWST*WWST +! +!----------------------------------------------------------------------- +!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: AEQH=9.*A1*A2x*A2x*B1*BTG*BTG & + & +9.*A1*A2x*A2x*(12.*A1+3.*B2)*BTG*BTG & + & ,AEQM=3.*A1*A2x*B1*(3.*A2x+3.*B2*C1+18.*A1*C1-B2)& + & *BTG+18.*A1*A1*A2x*(B2-3.*A2x)*BTG +! +!----------------------------------------------------------------------- +!*** FORBIDDEN TURBULENCE AREA +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: REQU=-AEQH/AEQM & + & ,EPSGH=1.E-9,EPSGM=REQU*EPSGH +! +!----------------------------------------------------------------------- +!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: UBRYL=(18.*REQU*A1*A1*A2x*B2*C1*BTG & + & +9.*A1*A2x*A2x*B2*BTG*BTG) & + & /(REQU*ADNM+ADNH) & + & ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY +! + REAL,PARAMETER :: AUBH=27.*A1*A2x*A2x*B2*BTG*BTG-ADNH*UBRY3 & + & ,AUBM=54.*A1*A1*A2x*B2*C1*BTG -ADNM*UBRY3 & + & ,BUBH=(9.*A1*A2x+3.*A2x*B2)*BTG-BDNH*UBRY3 & + & ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & + & ,CUBR=1. - UBRY3 & + & ,RCUBR=1./CUBR +! +!----------------------------------------------------------------------- +! + CONTAINS +! +!---------------------------------------------------------------------- + SUBROUTINE MYJPBL(DT,STEPBL,HT,DZ & + & ,PMID,PINT,TH,T,EXNER,QV,CWM,U,V,RHO & + & ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & + & ,LOWLYR,XLAND,SICE,SNOW & + & ,TKE_MYJ,EXCH_H,USTAR,ZNT,EL_MYJ,PBLH,KPBL,CT & + & ,AKHS,AKMS,ELFLX & + & ,RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: STEPBL + + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LOWLYR +! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: KPBL +! + REAL,INTENT(IN) :: DT +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HT,SICE,SNOW & + & ,TSK,XLAND +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: CWM,DZ & + & ,EXNER & + & ,PMID,PINT & + & ,QV,RHO & + & ,T,TH,U,V +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PBLH +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & + & ,INTENT(OUT) :: EL_MYJ & + & ,RQCBLTEN,RQVBLTEN & + & ,RTHBLTEN & + & ,RUBLTEN,RVBLTEN +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CT,QSFC,QZ0 & + & ,THZ0,USTAR & + & ,UZ0,VZ0,ZNT +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & + & ,INTENT(INOUT) :: EXCH_H,TKE_MYJ +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CHKLOWQ,ELFLX +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: I,J,K,KFLIP,LLOW,LMH,LMXL +! + INTEGER,DIMENSION(ITS:ITE,JTS:JTE) :: LPBL +! + REAL :: AKHS_DENS,AKMS_DENS,APEX,DCDT,DELTAZ,DQDT,DTDIF,DTDT & + & ,DTTURBL,DUDT,DVDT,EXNSFC,PSFC,PTOP,QFC1,QLOW,QOLD & + & ,RATIOMX,RDTTURBL,RG,RWMSK,SEAMASK,THNEW,THOLD,TX & + & ,ULOW,VLOW,WMSK +! + REAL,DIMENSION(KTS:KTE) :: CWMK,PK,Q2K,QK,THEK,TK,UK,VK +! + REAL,DIMENSION(KTS:KTE-1) :: AKHK,AKMK,EL,GH,GM +! + REAL,DIMENSION(KTS:KTE+1) :: ZHK +! + REAL,DIMENSION(ITS:ITE,JTS:JTE) :: THSK +! + REAL,DIMENSION(KTS:KTE,ITS:ITE) :: RHOK +! + REAL,DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE) :: APE,THE +! + REAL,DIMENSION(ITS:ITE,KTS:KTE-1,JTS:JTE) :: AKH,AKM +! + REAL,DIMENSION(ITS:ITE,KTS:KTE+1,JTS:JTE) :: ZINT +! +!*** Begin debugging + REAL :: ZSL_DIAG + INTEGER :: IMD,JMD,PRINT_DIAG +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + DTTURBL=DT*STEPBL + RDTTURBL=1./DTTURBL + DTDIF=DTTURBL + RG=1./G +! + DO J=JTS,JTE + DO K=KTS,KTE-1 + DO I=ITS,ITE + AKM(I,K,J)=0. + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO K=KTS,KTE+1 + DO I=ITS,ITE + ZINT(I,K,J)=0. + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,KTE+1,J)=HT(I,J) ! Z at bottom of lowest sigma layer +! +!!!!!!!!! +!!!!!! UNCOMMENT THESE LINES IF USING ETA COORDINATES +!!!!!!!!! +!!!!!! ZINT(I,KTE+1,J)=1.E-4 ! Z of bottom of lowest eta layer +!!!!!! ZHK(KTE+1)=1.E-4 ! Z of bottom of lowest eta layer +! + ENDDO + ENDDO +! + DO J=JTS,JTE + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + DO I=ITS,ITE + ZINT(I,K,J)=ZINT(I,K+1,J)+DZ(I,KFLIP,J) + APEX=1./EXNER(I,K,J) + APE(I,K,J)=APEX + TX=T(I,K,J) + THE(I,K,J)=(CWM(I,K,J)*(-ELOCP/TX)+1.)*TH(I,K,J) + ENDDO + ENDDO + ENDDO +! + EL_MYJ = 0. +! +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE +! +!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED +! + LMH=KTE-LOWLYR(I,J)+1 +! + PTOP=PINT(I,KTE+1,J) ! KTE+1=KME + PSFC=PINT(I,LOWLYR(I,J),J) +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +!*** AND FLIP DIRECTION SINCE MYJ SCHEME +!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP +! + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + TK(K)=T(I,KFLIP,J) + THEK(K)=THE(I,KFLIP,J) + RATIOMX=QV(I,KFLIP,J) + QK(K)=RATIOMX/(1.+RATIOMX) + CWMK(K)=CWM(I,KFLIP,J) + PK(K)=PMID(I,KFLIP,J) + UK(K)=U(I,KFLIP,J) + VK(K)=V(I,KFLIP,J) +! +!*** TKE=0.5*(q**2) ==> q**2=2.*TKE +! + Q2K(K)=2.*TKE_MYJ(I,KFLIP,J) +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,K,J) +! + ENDDO + ZHK(KTE+1)=HT(I,J) ! Z at bottom of lowest sigma layer +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=1 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=2 +!*** End debugging +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE MIXING LENGTH +!*** + CALL MIXLEN(LMH,UK,VK,TK,THEK,QK,CWMK & + & ,Q2K,ZHK,GM,GH,EL & + & ,PBLH(I,J),LPBL(I,J),LMXL,CT(I,J) & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +! +!---------------------------------------------------------------------- +!*** +!*** SOLVE FOR THE PRODUCTION/DISSIPATION OF +!*** THE TURBULENT KINETIC ENERGY +!*** +! + CALL PRODQ2(LMH,DTTURBL,USTAR(I,J),GM,GH,EL,Q2K & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +! +!---------------------------------------------------------------------- +!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL +!---------------------------------------------------------------------- +! + KPBL(I,J)=KTE-LPBL(I,J)+1 +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE EXCHANGE COEFFICIENTS IN THE FREE ATMOSPHERE +!*** + CALL DIFCOF(LMH,LMXL,GM,GH,EL,TK,Q2K,ZHK,AKMK,AKHK & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,PRINT_DIAG) ! debug +! +!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH +!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1. COUNTING +!*** COUNTING UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS EXCH_H +!*** ARE DEFINED ON THE TOPS OF THE LAYERS KTS TO KTE-1. +! + DO K=KTS,KTE-1 + KFLIP=KTE-K + AKH(I,K,J)=AKHK(K) + AKM(I,K,J)=AKMK(K) + DELTAZ=0.5*(ZHK(KFLIP)-ZHK(KFLIP+2)) + EXCH_H(I,K,J)=AKHK(KFLIP)*DELTAZ + ENDDO +! +!---------------------------------------------------------------------- +!*** +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TURBULENT KINETIC ENERGY +!*** +! + CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +! +!*** SAVE THE NEW TKE AND MIXING LENGTH. +! + DO K=KTS,KTE + KFLIP=KTE+1-K + Q2K(KFLIP)=AMAX1(Q2K(KFLIP),EPSQ2) + TKE_MYJ(I,K,J)=0.5*Q2K(KFLIP) + IF(K0..OR.SICE(I,J)>0.5)THEN + QFC1=QFC1*RLIVWV + ENDIF +! + IF(QFC1>0.)THEN + QLOW=QK(KTE+1-LLOW) + QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 + ENDIF +! + ELSE + PSFC=PINT(I,LOWLYR(I,J),J) + EXNSFC=(1.E5/PSFC)**CAPA + QSFC(I,J)=PQ0SEA/PSFC & + & *EXP(A2*(THSK(I,J)-A3*EXNSFC)/(THSK(I,J)-A4*EXNSFC)) + ENDIF +! + QZ0 (I,J)=(1.-SEAMASK)*QSFC(I,J)+SEAMASK*QZ0 (I,J) +! +!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED +! + LMH=KTE-LOWLYR(I,J)+1 +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TEMPERATURE AND WATER VAPOR +!---------------------------------------------------------------------- +! + CALL VDIFH(DTDIF,LMH,THZ0(I,J),QZ0(I,J) & + & ,AKHS_DENS,CHKLOWQ(I,J),CT(I,J) & + & ,THEK,QK,CWMK,AKHK,ZHK,RHOK(KTS,I) & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=KTS,KTE + KFLIP=KTE+1-K + THOLD=TH(I,K,J) + THNEW=THEK(KFLIP)+CWMK(KFLIP)*ELOCP*APE(I,K,J) + DTDT=(THNEW-THOLD)*RDTTURBL + QOLD=QV(I,K,J)/(1.+QV(I,K,J)) + DQDT=(QK(KFLIP)-QOLD)*RDTTURBL + DCDT=(CWMK(KFLIP)-CWM(I,K,J))*RDTTURBL +! + RTHBLTEN(I,K,J)=DTDT + RQVBLTEN(I,K,J)=DQDT/(1.-QK(KFLIP))**2 + RQCBLTEN(I,K,J)=DCDT + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=0 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=0 +!*** End debugging +! + PSFC=.01*PINT(I,LOWLYR(I,J),J) + ZSL_DIAG=0.5*DZ(I,1,J) +! +!*** Begin debugging +! IF(PRINT_DIAG==1)THEN +! +! write(6,"(a, 2i5, 2i3, 2f8.2, f6.2, 2f8.2)") & +! '{turb4 i,j, Kpbl, Kmxl, Psfc, Zsfc, Zsl, Zpbl, Zmxl = ' & +! , i, j, KPBL(i,j), KTE-LMXL+1, PSFC, ZHK(LMH+1), ZSL_diag & +! , PBLH(i,j), ZHK(LMXL)-ZHK(LMH+1) +! write(6,"(a, 2f7.2, f7.3, 3e11.4)") & +! '{turb4 tsk, thsk, qz0, q**2_0, akhs, exch_0 = ' & +! , tsk(i,j)-273.15, thsk(i,j), 1000.*qz0(i,j) & +! , 2.*tke_myj(i,1,j), akhs(i,j), akhs(i,j)*ZSL_diag +! write(6,"(a)") & +! '{turb5 k, Pmid, Pint_1, Tc, TH, DTH, GH, GM, EL, Q**2, Akh, EXCH_h, Dz, Dp' +! do k=kts,kte/2 +! KFLIP=KTE-K !-- Includes the KFLIP-1 in earlier versions +! write(6,"(a,i3, 2f8.2, 2f8.3, 3e12.4, 4e11.4, f7.2, f6.2)") & +! '{turb5 ', k, .01*pmid(i,k,j),.01*pint(i,k,j), T(i,k,j)-273.15 & +! , th(i,k,j), DTTURBL*rthblten(i,k,j), GH(KFLIP), GM(KFLIP) & +! , el_myj(i,KFLIP,j), 2.*tke_myj(i,k+1,j), akh(i,KFLIP,j) & +! , exch_h(i,k,j), dz(i,k,j), .01*(pint(i,k,j)-pint(i,k+1,j)) +! enddo +! +! ELSEIF(PRINT_DIAG==2)THEN +! +! write(6,"(a, 2i5, 2i3, 2f8.2, f6.2, 2f8.2)") & +! '}turb4 i,j, Kpbl, Kmxl, Psfc, Zsfc, Zsl, Zpbl, Zmxl = ' & +! , i, j, KPBL(i,j), KTE-LMXL+1, PSFC, ZHK(LMH+1), ZSL_diag & +! , PBLH(i,j), ZHK(LMXL)-ZHK(LMH+1) +! write(6,"(a, 2f7.2, f7.3, 3e11.4)") & +! '}turb4 tsk, thsk, qz0, q**2_0, akhs, exch_0 = ' & +! , tsk(i,j)-273.15, thsk(i,j), 1000.*qz0(i,j) & +! , 2.*tke_myj(i,1,j), akhs(i,j), akhs(i,j)*ZSL_diag +! write(6,"(a)") & +! '}turb5 k, Pmid, Pint_1, Tc, TH, DTH, GH, GM, EL, Q**2, Akh, EXCH_h, Dz, Dp' +! do k=kts,kte/2 +! KFLIP=KTE-K !-- Includes the KFLIP-1 in earlier versions +! write(6,"(a,i3, 2f8.2, 2f8.3, 3e12.4, 4e11.4, f7.2, f6.2)") & +! '}turb5 ', k, .01*pmid(i,k,j),.01*pint(i,k,j), T(i,k,j)-273.15 & +! , th(i,k,j), DTTURBL*rthblten(i,k,j), GH(KFLIP), GM(KFLIP) & +! , el_myj(i,KFLIP,j), 2.*tke_myj(i,k+1,j), akh(i,KFLIP,j) & +! , exch_h(i,k,j), dz(i,k,j), .01*(pint(i,k,j)-pint(i,k+1,j)) +! enddo +! ENDIF +!*** End debugging +! +!---------------------------------------------------------------------- + ENDDO +!---------------------------------------------------------------------- + DO I=ITS,ITE +! +!*** FILL 1-D VERTICAL ARRAYS +!*** AND FLIP DIRECTION SINCE MYJ SCHEME +!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP +! + DO K=KTS,KTE-1 + AKMK(K)=AKM(I,K,J) + AKMK(K)=AKMK(K)*(RHOK(K,I)+RHOK(K+1,I))*0.5 + ENDDO +! + LLOW=LOWLYR(I,J) + AKMS_DENS=AKMS(I,J)*RHOK(KTE+1-LLOW,I) +! + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + UK(K)=U(I,KFLIP,J) + VK(K)=V(I,KFLIP,J) + ZHK(K)=ZINT(I,K,J) + ENDDO + ZHK(KTE+1)=ZINT(I,KTE+1,J) +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** VELOCITY COMPONENTS +!---------------------------------------------------------------------- +! + CALL VDIFV(LMH,DTDIF,UZ0(I,J),VZ0(I,J) & + & ,AKMS_DENS,UK,VK,AKMK,ZHK,RHOK(KTS,I) & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) +! +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=KTS,KTE + KFLIP=KTE+1-K + DUDT=(UK(KFLIP)-U(I,K,J))*RDTTURBL + DVDT=(VK(KFLIP)-V(I,K,J))*RDTTURBL + RUBLTEN(I,K,J)=DUDT + RVBLTEN(I,K,J)=DVDT + ENDDO +! + ENDDO +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJPBL +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE MIXLEN & +!---------------------------------------------------------------------- +! ****************************************************************** +! * * +! * LEVEL 2.5 MIXING LENGTH * +! * * +! ****************************************************************** +! + &(LMH,U,V,T,THE,Q,CWM,Q2,Z,GM,GH,EL,PBLH,LPBL,LMXL,CT & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: LMH +! + INTEGER,INTENT(OUT) :: LMXL,LPBL +! + REAL,DIMENSION(KTS:KTE),INTENT(IN) :: CWM,Q,Q2,T,THE,U,V +! + REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z +! + REAL,INTENT(OUT) :: PBLH +! + REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: EL,GH,GM +! + REAL,INTENT(INOUT) :: CT +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: K,LPBLM +! + REAL :: A,ADEN,B,BDEN,AUBR,BUBR,BLMX,EL0,ELOQ2X,GHL,GML & + & ,QOL2ST,QOL2UN,QDZL,RDZ,SQ,SREL,SZQ,TEM,THM,VKRMZ +! + REAL,DIMENSION(KTS:KTE) :: Q1 +! + REAL,DIMENSION(KTS:KTE-1) :: DTH,ELM,REL +! +!---------------------------------------------------------------------- +!********************************************************************** +!--------------FIND THE HEIGHT OF THE PBL------------------------------- + LPBL=LMH +! + DO K=LMH-1,1,-1 + IF(Q2(K)<=EPSQ2*FH)THEN + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!--------------THE HEIGHT OF THE PBL------------------------------------ +! + 110 PBLH=Z(LPBL)-Z(LMH+1) +! +!----------------------------------------------------------------------- + DO K=KTS,LMH + Q1(K)=0. + ENDDO +! + DO K=1,LMH-1 + DTH(K)=THE(K)-THE(K+1) + ENDDO +! + DO K=LMH-2,1,-1 + IF(DTH(K)>0..AND.DTH(K+1)<=0.)THEN + DTH(K)=DTH(K)+CT + EXIT + ENDIF + ENDDO +! + CT=0. +!---------------------------------------------------------------------- + DO K=KTS,LMH-1 + RDZ=2./(Z(K)-Z(K+2)) + GML=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ + GM(K)=MAX(GML,EPSGM) +! + TEM=(T(K)+T(K+1))*0.5 + THM=(THE(K)+THE(K+1))*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + GHL=(DTH(K)*((Q(K)+Q(K+1)+CWM(K)+CWM(K+1))*(0.5*P608)+1.) & + & +(Q(K)-Q(K+1)+CWM(K)-CWM(K+1))*A & + & +(CWM(K)-CWM(K+1))*B)*RDZ +! + IF(ABS(GHL)<=EPSGH)GHL=EPSGH + GH(K)=GHL + ENDDO +! +!---------------------------------------------------------------------- +!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP +!---------------------------------------------------------------------- +! + LMXL=LMH +! + DO K=KTS,LMH-1 + GML=GM(K) + GHL=GH(K) +! + IF(GHL>=EPSGH)THEN + IF(GML/GHL<=REQU)THEN + ELM(K)=EPSL + LMXL=K + ELSE + AUBR=(AUBM*GML+AUBH*GHL)*GHL + BUBR= BUBM*GML+BUBH*GHL + QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR + ELOQ2X=1./QOL2ST + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) + ENDIF + ELSE + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) + ELOQ2X=1./(QOL2UN+EPSRU) ! repsr1/qol2un + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) + ENDIF + ENDDO +! + IF(ELM(LMH-1)==EPSL)LMXL=LMH +! +!---------------------------------------------------------------------- +!*** THE HEIGHT OF THE MIXED LAYER +!---------------------------------------------------------------------- +! + BLMX=Z(LMXL)-Z(LMH+1) +! +!---------------------------------------------------------------------- + DO K=LPBL,LMH + Q1(K)=SQRT(Q2(K)) + ENDDO +!---------------------------------------------------------------------- + SZQ=0. + SQ =0. +! + DO K=KTS,LMH-1 + QDZL=(Q1(K)+Q1(K+1))*(Z(K+1)-Z(K+2)) + SZQ=(Z(K+1)+Z(K+2)-Z(LMH+1)-Z(LMH+1))*QDZL+SZQ + SQ=QDZL+SQ + ENDDO +! +!---------------------------------------------------------------------- +!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA +!---------------------------------------------------------------------- +! + EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) + EL0=MAX(EL0 ,EL0MIN) +! +!---------------------------------------------------------------------- +!*** ABOVE THE PBL TOP +!---------------------------------------------------------------------- +! + LPBLM=MAX(LPBL-1,1) +! + DO K=KTS,LPBLM + EL(K)=MIN((Z(K)-Z(K+2))*ELFC,ELM(K)) + REL(K)=EL(K)/ELM(K) + ENDDO +! +!---------------------------------------------------------------------- +!*** INSIDE THE PBL +!---------------------------------------------------------------------- +! + IF(LPBL=EPSGH.AND.GML/GHL<=REQU) & + & .OR.(EQOL2<=EPS2))THEN +! +!---------------------------------------------------------------------- +!*** NO TURBULENCE +!---------------------------------------------------------------------- +! + Q2(K)=EPSQ2 + EL(K)=EPSL +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** TURBULENCE +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE NUMERATOR +!---------------------------------------------------------------------- +! + ANUM=(ANMM*GML+ANMH*GHL)*GHL + BNUM= BNMM*GML+BNMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE NUMERATOR OF THE LINEARIZED EQ. +!---------------------------------------------------------------------- +! + ARHS=-(ANUM*BDEN-BNUM*ADEN)*2. + BRHS=- ANUM*4. + CRHS=- BNUM*2. +! +!---------------------------------------------------------------------- +!*** INITIAL VALUE OF L/Q +!---------------------------------------------------------------------- +! + DLOQ1=EL(K)/SQRT(Q2(K)) +! +!---------------------------------------------------------------------- +!*** FIRST ITERATION FOR L/Q, RHS=0 +!---------------------------------------------------------------------- +! + ELOQ21=1./EQOL2 + ELOQ11=SQRT(ELOQ21) + ELOQ31=ELOQ21*ELOQ11 + ELOQ41=ELOQ21*ELOQ21 + ELOQ51=ELOQ21*ELOQ31 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN1=1./(ADEN*ELOQ41+BDEN*ELOQ21+CDEN) +! +!---------------------------------------------------------------------- +!*** D(RHS)/D(L/Q) +!---------------------------------------------------------------------- +! + RHSP1=(ARHS*ELOQ51+BRHS*ELOQ31+CRHS*ELOQ11)*RDEN1*RDEN1 +! +!---------------------------------------------------------------------- +!*** FIRST-GUESS SOLUTION +!---------------------------------------------------------------------- +! + ELOQ12=ELOQ11+(DLOQ1-ELOQ11)*EXP(RHSP1*DTTURBL) + ELOQ12=MAX(ELOQ12,EPS1) +! +!---------------------------------------------------------------------- +!*** SECOND ITERATION FOR L/Q +!---------------------------------------------------------------------- +! + ELOQ22=ELOQ12*ELOQ12 + ELOQ32=ELOQ22*ELOQ12 + ELOQ42=ELOQ22*ELOQ22 + ELOQ52=ELOQ22*ELOQ32 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN2=1./(ADEN*ELOQ42+BDEN*ELOQ22+CDEN) + RHS2 =-(ANUM*ELOQ42+BNUM*ELOQ22)*RDEN2+RB1 + RHSP2= (ARHS*ELOQ52+BRHS*ELOQ32+CRHS*ELOQ12)*RDEN2*RDEN2 + RHST2=RHS2/RHSP2 +! +!---------------------------------------------------------------------- +!*** CORRECTED SOLUTION +!---------------------------------------------------------------------- +! + ELOQ13=ELOQ12-RHST2+(RHST2+DLOQ1-ELOQ12)*EXP(RHSP2*DTTURBL) + ELOQ13=AMAX1(ELOQ13,EPS1) +! +!---------------------------------------------------------------------- +!*** TWO ITERATIONS IS ENOUGH IN MOST CASES ... +!---------------------------------------------------------------------- +! + ELOQN=ELOQ13 +! + IF(ELOQN>EPS1)THEN + Q2(K)=EL(K)*EL(K)/(ELOQN*ELOQN) + Q2(K)=AMAX1(Q2(K),EPSQ2) + IF(Q2(K)==EPSQ2)THEN + EL(K)=EPSL + ENDIF + ELSE + Q2(K)=EPSQ2 + EL(K)=EPSL + ENDIF +! +!---------------------------------------------------------------------- +!*** END OF TURBULENT BRANCH +!---------------------------------------------------------------------- +! + ENDIF +!---------------------------------------------------------------------- +!*** END OF PRODUCTION/DISSIPATION LOOP +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +!*** LOWER BOUNDARY CONDITION FOR Q2 +!---------------------------------------------------------------------- +! + Q2(LMH)=AMAX1(B1**(2./3.)*USTAR*USTAR,EPSQ2) +!---------------------------------------------------------------------- +! + END SUBROUTINE PRODQ2 +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE DIFCOF & +! ****************************************************************** +! * * +! * LEVEL 2.5 DIFFUSION COEFFICIENTS * +! * * +! ****************************************************************** + &(LMH,LMXL,GM,GH,EL,T,Q2,Z,AKM,AKH & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE,PRINT_DIAG) ! debug +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: LMH,LMXL +! + REAL,DIMENSION(KTS:KTE),INTENT(IN) :: Q2,T + REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL,GH,GM + REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z +! + REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: AKH,AKM +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: K,KINV +! + REAL :: ADEN,AKMIN,BDEN,BESH,BESM,CDEN,D2T,ELL,ELOQ2,ELOQ4,ELQDZ & + & ,ESH,ESM,GHL,GML,Q1L,RDEN,RDZ +! +!*** Begin debugging + INTEGER,INTENT(IN) :: PRINT_DIAG +! REAL :: D2Tmin +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! + DO K=1,LMH-1 + ELL=EL(K) +! + ELOQ2=ELL*ELL/Q2(K) + ELOQ4=ELOQ2*ELOQ2 +! + GML=GM(K) + GHL=GH(K) +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SM DETERMINANT +!---------------------------------------------------------------------- +! + BESM=BSMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SH DETERMINANT +!---------------------------------------------------------------------- +! + BESH=BSHM*GML+BSHH*GHL +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN=1./(ADEN*ELOQ4+BDEN*ELOQ2+CDEN) +! +!---------------------------------------------------------------------- +!*** SM AND SH +!---------------------------------------------------------------------- +! + ESM=(BESM*ELOQ2+CESM)*RDEN + ESH=(BESH*ELOQ2+CESH)*RDEN +! +!---------------------------------------------------------------------- +!*** DIFFUSION COEFFICIENTS +!---------------------------------------------------------------------- +! + RDZ=2./(Z(K)-Z(K+2)) + Q1L=SQRT(Q2(K)) + ELQDZ=ELL*Q1L*RDZ + AKM(K)=ELQDZ*ESM + AKH(K)=ELQDZ*ESH +!---------------------------------------------------------------------- + ENDDO +!---------------------------------------------------------------------- +! +!---------------------------------------------------------------------- +!*** INVERSIONS +!---------------------------------------------------------------------- +! +! IF(LMXL==LMH)THEN +! KINV=LMH +! D2Tmin=0. +! +! DO K=LMH/2,LMH-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! IF(D2T0)THEN +! write(6,"(a,3i3)") '{turb1 lmxl,lmh,kinv=',lmxl,lmh,kinv +! write(6,"(a,3i3)") '}turb1 lmxl,lmh,kinv=',lmxl,lmh,kinv +! IF(PRINT_DIAG==1)THEN +! write(6,"(a)") & +! '{turb3 k, t, d2t, rdz, z(k), z(k+2), akmin, akh ' +! ELSE +! write(6,"(a)") & +! '}turb3 k, t, d2t, rdz, z(k), z(k+2), akmin, akh ' +! ENDIF +! DO K=LMH-1,KINV-1,-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! RDZ=2./(Z(K)-Z(K+2)) +! AKMIN=0.5*RDZ +! IF(PRINT_DIAG==1)THEN +! write(6,"(a,i3,f8.3,2e12.5,2f9.2,2e12.5)") '{turb3 ' & +! ,k,t(k)-273.15,d2t,rdz,z(k),z(k+2),akmin,akh(k) +! ELSE +! write(6,"(a,i3,f8.3,2e12.5,2f9.2,2e12.5)") '}turb3 ' & +! ,k,t(k)-273.15,d2t,rdz,z(k),z(k+2),akmin,akh(k) +! ENDIF +! ENDDO +! ENDIF !- IF (print_diag > 0) THEN +! ENDIF !- IF(KINV= 1. ) then + do i = its,ite + kmin(i) = 1 + do k = kte-1,kts,-1 + if( zq(i,k) <= hpblmin ) then + kmin(i) = k + exit + end if + end do + end do + end if +! +!-----initialize vertical tendencies and +! + do i = its,ite + do k = kts,kte + utnp(i,k) = 0. + vtnp(i,k) = 0. + ttnp(i,k) = 0. + enddo + enddo +! + do k = kts,kte + do i = its,ite + qtnp(i,k) = 0. + enddo + enddo +! + do k = kts,kte + do i = its,ite + qctnp(i,k) = 0. + qitnp(i,k) = 0. + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. +!wig 12-aug-2004: Turn off check for sfc stability if using a minimum +! pbl height > 0. + if(br(i).gt.0.0 .and. hpblmin<=1.) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr)then + brint = 0. + elseif(brup(i).le.brcr)then + brint = 1. + else + brint = (brcr-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + +!wig 16-sep-2005: rig a minimum PBL heigt + if( hpblmin >= 1. .and. hpbl(i).lt.hpblmin) then + kpbl(i) = kmin(i) + hpbl(i) = hpblmin + else + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + end if + + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = gz1oz0(i)-psim(i) + fh = gz1oz0(i)-psih(i) + hol(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + hol(i) = min(hol(i),-zfmin) + else + hol(i) = max(hol(i),zfmin) + endif +! + hol1 = hol(i)*hpbl(i)/zl1(i)*sfcfrac + hol(i) = -hol(i)*hpbl(i)/zl1(i) + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(hfx(i)/rhox(i)/cpm(i) & + +ep1*thx(i,1)*qfx(i)/rhox(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cpm(i),0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i))then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cpm(i),gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = 0.0 + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i) & + /(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max((ux(i,k)**2+vx(i,k)**2),1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr + endif + enddo + enddo +! + do i = its,ite + if(pblflg(i))then + k = kpbl(i) + if(brdn(i).ge.brcr)then + brint = 0. + elseif(brup(i).le.brcr)then + brint = 1. + else + brint = (brcr-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + +!wig 16-sep-2005: rig a minimum PBL heigt + if(hpblmin >= 1. .and. hpbl(i).lt.hpblmin) then + kpbl(i) = kmin(i) + hpbl(i) = hpblmin + else + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + end if + + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) - 1 + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k))+(vx(i,k+1)- & + vx(i,k))*(vx(i,k+1)-vx(i,k)))/(dza(i,k+1)*dza(i,k+1))+ & + 1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1)then + if((qcx(i,k)+qix(i,k)).gt.0.01e-3.and.(qcx(i,k+1)+ & + qix(i,k+1)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k)+qx(i,k+1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + prpbl(i) = 1.0 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),qmin) + dthx = max(thx(i,k+1)-thx(i,k),qmin) + dqx = min(qx(i,k+1)-qx(i,k),0.0) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.qmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-qmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.qmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-qmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i)) & + /(hpbl(i)-zl1(i))),zfmin),1.) + xkzo = ckz*dza(i,k+1) + zfacent(i,k) = (1.-zfac(i,k))**3. + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2. & + /hpbl(i)**2. + prnum = (phih(i)/phim(i)+bfac*karman*sfcfrac) + prnum = 1. + (prnum-1.)*exp(prnumfac) + prnum = min(prnum,prmax) + prnum = max(prnum,prmin) + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i) & + *(1.-zfac(i,k)))**h1 + xkzm(i,k) = xkzo+wscalek(i,k)*karman*zq(i,k+1) & + *zfac(i,k)**pfac + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzm(i,k) = max(xkzm(i,k),xkzmin) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzh(i,k) = max(xkzh(i,k),xkzmin) +!wig 16-sep-2005: This code is unnecessary. exch_hx will get overwritten +! with the same values further down in this routine +! exch_hx(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = kts,kte-1 + do i = its,ite + xkzo = ckz*dza(i,k+1) + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k))+(vx(i,k+1)- & + vx(i,k))*(vx(i,k+1)-vx(i,k)))/(dza(i,k+1)*dza(i,k+1))+ & + 1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1)then + if((qcx(i,k)+qix(i,k)).gt.0.01e-3.and.(qcx(i,k+1)+ & + qix(i,k+1)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k)+qx(i,k+1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rl2 = (zk*rlam/(rlam+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + sri = sqrt(-ri) + xkzm(i,k) = xkzo+dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = xkzo+dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = xkzo+dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = (xkzh(i,k)-xkzo)*prnum+xkzo + endif +! + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzm(i,k) = max(xkzm(i,k),xkzmin) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzh(i,k) = max(xkzh(i,k),xkzmin) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) +!wig 16-sep-2005: This code is unnecessary. exch_hx will get overwritten +! further down in this routine after adjustments are made +! for entrainment. +! exch_hx(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture, and clouds +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do ic = 1,ncloud + do i = its,ite + do k = kts,kte + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)+hfx(i)/(rhox(i)*cpm(i))/zq(i,2)*dt2 + f3(i,1,1) = qx(i,1)+qfx(i)/(rhox(i))/zq(i,2)*dt2 + enddo +! + if(ncloud.ge.2) then + do ic = 2,ncloud + do i = its,ite + if(ic.eq.2) then + f3(i,1,ic) = qcx(i,1) + elseif(ic.eq.3) then + f3(i,1,ic) = qix(i,1) + endif + enddo + enddo + endif +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/dz8w2d(i,k) + dtodsu = dt2/dz8w2d(i,k+1) + rdz = 1./dza(i,k+1) + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = xkzh(i,k)*(-hgamt(i)/hpbl(i) & + -hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + dsdzq = xkzh(i,k)*(-hgamq(i)/hpbl(i) & + -qfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-dtodsu*dsdzt + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzh(i,k) = max(xkzh(i,k),xkzmin) + f1(i,k+1) = thx(i,k+1) + f3(i,k+1,1) = qx(i,k+1) + else + f1(i,k+1) = thx(i,k+1) + f3(i,k+1,1) = qx(i,k+1) + endif + dsdz2 = xkzh(i,k)*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_hx(i,k) = xkzh(i,k) + enddo + enddo +! + if(ncloud.ge.2) then + do ic = 2,ncloud + do k = kts,kte-1 + do i = its,ite + if(ic.eq.2) then + f3(i,k+1,ic) = qcx(i,k+1) + elseif(ic.eq.3) then + f3(i,k+1,ic) = qix(i,k+1) + endif + enddo + enddo + enddo + endif + +! copies here to avoid duplicate input args for tridin + + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + do ic = 1,ncloud + do k = kts,kte + do i = its,ite + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! +! solve tridiagonal problem for heat and moisture, and clouds +! + call tridin(al,ad,cu,r1,r3,au,f1,f3, & + its,ite,kts,kte,ncloud ) +! +! recover tendencies of heat and moisture +! + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k))*rdt*(tx(i,k)/thx(i,k)) + qtend = (f3(i,k,1)-qx(i,k))*rdt + ttnp(i,k) = ttnp(i,k)+ttend + qtnp(i,k) = qtnp(i,k)+qtend + enddo + enddo +! + if(ncloud.ge.2) then + do ic = 2,ncloud + do k = kte,kts,-1 + do i = its,ite + if(ic.eq.2) then + qctend = (f3(i,k,ic)-qcx(i,k))*rdt + qctnp(i,k) = qctnp(i,k)+qctend + elseif(ic.eq.3) then + qitend = (f3(i,k,ic)-qix(i,k))*rdt + if(flag_qi)qitnp(i,k) = qitnp(i,k)+qitend + endif + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = ux(i,1)-ux(i,1)/wspd1(i)*ust(i)*ust(i)/zq(i,2)*dt2 & + *(wspd1(i)/wspd(i))**2 + f2(i,1) = vx(i,1)-vx(i,1)/wspd1(i)*ust(i)*ust(i)/zq(i,2)*dt2 & + *(wspd1(i)/wspd(i))**2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/dz8w2d(i,k) + dtodsu = dt2/dz8w2d(i,k+1) + rdz = 1./dza(i,k+1) + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu=xkzm(i,k)*(-hgamu(i)/hpbl(i) & + -ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv=xkzm(i,k)*(-hgamv(i)/hpbl(i) & + -vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k)=min(xkzm(i,k),xkzmax) + xkzm(i,k)=max(xkzm(i,k),xkzmin) + f1(i,k+1)=ux(i,k+1) + f2(i,k+1)=vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + dsdz2 = xkzm(i,k)*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo + +! copies here to avoid duplicate input args for tridin + + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! +! solve tridiagonal problem for momentum +! + call tridin(al,ad,cu,r1,r2,au,f1,f2, & + its,ite,kts,kte,1 ) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + enddo + enddo +! +!---- end of vertical diffusion +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! + end subroutine ysu2d +! + subroutine tridin(cl,cm,cu,r1,r2,au,f1,f2, & + its,ite,kts,kte,nt ) +!---------------------------------------------------------------- + implicit none +!---------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real, dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real, dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + r1 + real, dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real, dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real, dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real :: fk + integer :: i,k,l,n,it +! +!---------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin +! + subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & + rqcblten,rqiblten,p_qi,p_first_scalar, & + restart, allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- +! + logical , intent(in) :: restart, allowed_to_read + integer , intent(in) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + integer , intent(in) :: p_qi,p_first_scalar + real , dimension( ims:ime , kms:kme , jms:jme ), intent(out) :: & + rublten, & + rvblten, & + rthblten, & + rqvblten, & + rqcblten, & + rqiblten + integer :: i, j, k, itf, jtf, ktf +! + jtf = min0(jte,jde-1) + ktf = min0(kte,kde-1) + itf = min0(ite,ide-1) +! + if(.not.restart)then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rublten(i,k,j) = 0. + rvblten(i,k,j) = 0. + rthblten(i,k,j) = 0. + rqvblten(i,k,j) = 0. + rqcblten(i,k,j) = 0. + enddo + enddo + enddo + endif +! + if (p_qi .ge. p_first_scalar .and. .not.restart) then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rqiblten(i,k,j) = 0. + enddo + enddo + enddo + endif +! + end subroutine ysuinit +!------------------------------------------------------------------- +end module module_bl_ysu diff --git a/wrfv2_fire/phys/module_cu_bmj.F b/wrfv2_fire/phys/module_cu_bmj.F new file mode 100644 index 00000000..507d552d --- /dev/null +++ b/wrfv2_fire/phys/module_cu_bmj.F @@ -0,0 +1,1840 @@ +!----------------------------------------------------------------------- +! +!WRF:MODEL_LAYER:PHYSICS +! +!----------------------------------------------------------------------- +! + MODULE MODULE_CU_BMJ +! +!----------------------------------------------------------------------- + USE MODULE_MODEL_CONSTANTS +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: & + & DSPC=-3000. & + & ,DTTOP=0.,EFIFC=5.0,EFIMN=0.20,EFMNT=0.70 & + & ,ELIVW=2.72E6,ENPLO=20000.,ENPUP=15000. & + & ,EPSDN=1.05,EPSDT=0. & + & ,EPSNTP=.0001,EPSNTT=.0001,EPSPR=1.E-7 & + & ,EPSUP=1.00 & + & ,FR=1.00,FSL=0.85,FSS=0.85 & + & ,FUP=0. & + & ,PBM=13000.,PFRZ=15000.,PNO=1000. & + & ,PONE=2500.,PQM=20000. & + & ,PSH=20000.,PSHU=45000. & + & ,RENDP=1./(ENPLO-ENPUP) & + & ,RHLSC=0.00,RHHSC=1.10 & + & ,ROW=1.E3 & + & ,STABDF=0.90,STABDS=0.90 & + & ,STABS=1.0,STRESH=1.10 & + & ,TREL=2400. + REAL,PARAMETER :: DSPBFL=-3875.*FR & + & ,DSP0FL=-5875.*FR & + & ,DSPTFL=-1875.*FR & + & ,DSPBFS=-3875. & + & ,DSP0FS=-5875. & + & ,DSPTFS=-1875. +! + REAL,PARAMETER :: PL=2500.,PLQ=70000.,PH=105000. & + & ,THL=210.,THH=365.,THHQ=325. +! + INTEGER,PARAMETER :: ITB=76,JTB=134,ITBQ=152,JTBQ=440 +! + INTEGER,PARAMETER :: ITREFI_MAX=3 +! +!*** ARRAYS FOR LOOKUP TABLES +! + REAL,DIMENSION(ITB),PRIVATE,SAVE :: STHE,THE0 + REAL,DIMENSION(JTB),PRIVATE,SAVE :: QS0,SQS + REAL,DIMENSION(ITBQ),PRIVATE,SAVE :: STHEQ,THE0Q + REAL,DIMENSION(ITB,JTB),PRIVATE,SAVE :: PTBL + REAL,DIMENSION(JTB,ITB),PRIVATE,SAVE :: TTBL + REAL,DIMENSION(JTBQ,ITBQ),PRIVATE,SAVE :: TTBLQ + +!*** SHARE COPIES FOR MODULE_BL_MYJPBL +! + REAL,DIMENSION(JTB) :: QS0_EXP,SQS_EXP + REAL,DIMENSION(ITB,JTB) :: PTBL_EXP +! + REAL,PARAMETER :: RDP=(ITB-1.)/(PH-PL),RDPQ=(ITBQ-1.)/(PH-PLQ) & + & ,RDQ=ITB-1,RDTH=(JTB-1.)/(THH-THL) & + & ,RDTHE=JTB-1.,RDTHEQ=JTBQ-1. & + & ,RSFCP=1./101300. +! + REAL,PARAMETER :: AVGEFI=(EFIMN+1.)*0.5 +!----------------------------------------------------------------------- +! +CONTAINS +! +!----------------------------------------------------------------------- + SUBROUTINE BMJDRV( & + & IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE & + & ,DT,ITIMESTEP,STEPCU & + & ,RAINCV,CUTOP,CUBOT,KPBL & + & ,TH,T,QV & + & ,PINT,PMID,PI,RHO,DZ8W & + & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & + & ,CLDEFI,LOWLYR,XLAND,CU_ACT_FLAG & + ! optional + & ,RTHCUTEN, RQVCUTEN & + & ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: ITIMESTEP,STEPCU +! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: KPBL,LOWLYR +! + REAL,INTENT(IN) :: CP,DT,ELIV,ELWV,G,R,TFRZ,D608 +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: XLAND +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ8W & + & ,PI,PINT & + & ,PMID,QV & + & ,RHO,T,TH +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & + & ,OPTIONAL & + & ,INTENT(INOUT) :: RQVCUTEN,RTHCUTEN +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CLDEFI,RAINCV +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CUBOT,CUTOP +! + LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CU_ACT_FLAG +! +!----------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** +!----------------------------------------------------------------------- + INTEGER :: LBOT,LPBL,LTOP +! + REAL :: DTCNVC,LANDMASK,PCPCOL,PSFC,PTOP +! + REAL,DIMENSION(KTS:KTE) :: DPCOL,DQDT,DTDT,PCOL,QCOL,TCOL +! + INTEGER :: I,J,K,KFLIP,ICLDCK,LMH +! +!*** Begin debugging convection + REAL :: DELQ,DELT,PLYR + INTEGER :: IMD,JMD + LOGICAL :: PRINT_DIAG +!*** End debugging convection +! +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! +!*** PREPARE TO CALL BMJ CONVECTION SCHEME +! +!----------------------------------------------------------------------- +! +!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP +! + ICLDCK=MOD(ITIMESTEP,STEPCU) +!----------------------------------------------------------------------- +! +!*** COMPUTE CONVECTION EVERY STEPCU*DT/60.0 MINUTES +! +!*** Begin debugging convection + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 + PRINT_DIAG=.FALSE. +!*** End debugging convection + + IF(ICLDCK==0.OR.ITIMESTEP==0)THEN +! + DO J=JTS,JTE + DO I=ITS,ITE + CU_ACT_FLAG(I,J)=.TRUE. + ENDDO + ENDDO + +! + DTCNVC=DT*STEPCU +! + DO J=JTS,JTE + DO I=ITS,ITE +! + DO K=KTS,KTE + DQDT(K)=0. + DTDT(K)=0. + ENDDO +! + RAINCV(I,J)=0. + PCPCOL=0. + PSFC=PINT(I,LOWLYR(I,J),J) + PTOP=PINT(I,KTE+1,J) ! KTE+1=KME +! +!*** CONVERT TO BMJ LAND MASK (1.0 FOR SEA; 0.0 FOR LAND) +! + LANDMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +!*** AND FLIP DIRECTION SINCE BMJ SCHEME +!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP +! + DO K=KTS,KTE + KFLIP=KTE+1-K +! +!*** CONVERT FROM MIXING RATIO TO SPECIFIC HUMIDITY +! + QCOL(K)=MAX(EPSQ,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J))) + TCOL(K)=T(I,KFLIP,J) + PCOL(K)=PMID(I,KFLIP,J) +! DPCOL(K)=PINT(I,KFLIP,J)-PINT(I,KFLIP+1,J) + DPCOL(K)=RHO(I,KFLIP,J)*G*DZ8W(I,KFLIP,J) + ENDDO +! +!*** LOWEST LAYER ABOVE GROUND MUST ALSO BE FLIPPED +! + LMH=KTE+1-LOWLYR(I,J) + LPBL=KTE+1-KPBL(I,J) +!----------------------------------------------------------------------- +!*** +!*** CALL CONVECTION +!*** +!----------------------------------------------------------------------- +!*** Begin debugging convection +! PRINT_DIAG=.FALSE. +! IF(I==IMD.AND.J==JMD)PRINT_DIAG=.TRUE. +!*** End debugging convection +!----------------------------------------------------------------------- + CALL BMJ(ITIMESTEP,I,J,DTCNVC,LMH,LANDMASK,CLDEFI(I,J) & + & ,DPCOL,PCOL,QCOL,TCOL,PSFC,PTOP & + & ,DQDT,DTDT,PCPCOL,LBOT,LTOP,LPBL & + & ,CP,R,ELWV,ELIV,G,TFRZ,D608 & + & ,PRINT_DIAG & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +!----------------------------------------------------------------------- +! +!*** COMPUTE HEATING AND MOISTENING TENDENCIES +! + IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN )) THEN + DO K=KTS,KTE + KFLIP=KTE+1-K + RTHCUTEN(I,K,J)=DTDT(KFLIP)/PI(I,K,J) +! +!*** CONVERT FROM SPECIFIC HUMIDTY BACK TO MIXING RATIO +! + RQVCUTEN(I,K,J)=DQDT(KFLIP)/(1.-QCOL(KFLIP))**2 + ENDDO + ENDIF +! +!*** ALL UNITS IN BMJ SCHEME ARE MKS, THUS CONVERT PRECIP FROM METERS +!*** TO MILLIMETERS PER STEP FOR OUTPUT. +! + RAINCV(I,J)=PCPCOL*1.E3/STEPCU +! +!*** CONVECTIVE CLOUD TOP AND BOTTOM FROM THIS CALL +! + CUTOP(I,J)=REAL(KTE+1-LTOP) + CUBOT(I,J)=REAL(KTE+1-LBOT) +! +!----------------------------------------------------------------------- +!*** Begin debugging convection + IF(PRINT_DIAG)THEN + DELT=0. + DELQ=0. + PLYR=0. + IF(LBOT>0.AND.LTOP0, CONVECTION IS ALREADY ACTIVE AT THIS POINT, +!...JUST FEED BACK THE TENDENCIES SAVED FROM THE TIME WHEN CONVECTION +!...WAS INITIATED. IF NCA<0, CONVECTION IS NOT ACTIVE +!...AND YOU MAY WANT TO CHECK TO SEE IF IT CAN BE ACTIVATED FOR THE +!...CURRENT CONDITIONS. IN PREVIOUS APLICATIONS OF THIS SCHEME, +!...THE VARIABLE ICLDCK WAS USED BELOW TO SAVE TIME BY ONLY CHECKING +!...FOR THE POSSIBILITY OF CONVECTIVE INITIATION EVERY 5 OR 10 +!...MINUTES... +! + +! 10 CONTINUE +!SUE P300=1000.*(PSB(I,J)*A(KL)+PTOP-30.)+PP3D(I,J,KL) + + P300=P0(1)-30000. +! +!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF +!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND +!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... +! +!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED +!...FROM BOTTOM-UP IN THE KF SCHEME... +! + ML=0 +!SUE tmprpsb=1./PSB(I,J) +!SUE CELL=PTOP*tmprpsb + + DO 15 K=1,KX +!SUE P0(K)=1.E3*(A(NK)*PSB(I,J)+PTOP)+PP3D(I,J,NK) +! +!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... +! + ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) + QES(K)=EP2*ES/(P0(K)-ES) + Q0(K)=AMIN1(QES(K),QV0(K)) + Q0(K)=AMAX1(0.000001,Q0(K)) + QL0(K)=0. + QI0(K)=0. + QR0(K)=0. + QS0(K)=0. + + TV0(K)=T0(K)*(1.+B61*Q0(K)) + RHOE(K)=P0(K)/(R*TV0(K)) + + DP(K)=rho(k)*g*DZQ(k) +! +!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL +! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... +! + IF(P0(K).GE.500E2)L5=K + IF(P0(K).GE.400E2)L4=K + IF(P0(K).GE.P300)LLFC=K + IF(T0(K).GT.T00)ML=K + 15 CONTINUE + + Z0(1)=.5*DZQ(1) + DO 20 K=2,KL + Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) + DZA(K-1)=Z0(K)-Z0(K-1) + 20 CONTINUE + DZA(KL)=0. + KMIX=1 + 25 LOW=KMIX + + IF(LOW.GT.LLFC)GOTO 325 + + LC=LOW + MXLAYR=0 +! +!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF +!...UNSTABLE AIR 50 TO 100 mb DEEP...TO APPROXIMATE THIS, ISOLATE A +!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL +!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 60 mb.. +! + NLAYRS=0 + DPTHMX=0. + DO 63 NK=LC,KX + DPTHMX=DPTHMX+DP(NK) + NLAYRS=NLAYRS+1 + 63 IF(DPTHMX.GT.6.E3)GOTO 64 + GOTO 325 + 64 KPBL=LC+NLAYRS-1 + KMIX=LC+1 + 18 THMIX=0. + QMIX=0. + ZMIX=0. + PMIX=0. + DPTHMX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! + DO 17 NK=LC,KPBL + DPTHMX=DPTHMX+DP(NK) + ROCPQ=0.2854*(1.-0.28*Q0(NK)) + THMIX=THMIX+DP(NK)*T0(NK)*(P00/P0(NK))**ROCPQ + QMIX=QMIX+DP(NK)*Q0(NK) + ZMIX=ZMIX+DP(NK)*Z0(NK) + 17 PMIX=PMIX+DP(NK)*P0(NK) + THMIX=THMIX/DPTHMX + QMIX=QMIX/DPTHMX + ZMIX=ZMIX/DPTHMX + PMIX=PMIX/DPTHMX + ROCPQ=0.2854*(1.-0.28*QMIX) + TMIX=THMIX*(PMIX/P00)**ROCPQ + EMIX=QMIX*PMIX/(EP2+QMIX) +! +!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL, PRESSURE +!...LEVEL OF LCL... +! + TLOG=ALOG(EMIX/ALIQ) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX- & + TDPT) + TLCL=AMIN1(TLCL,TMIX) + TVLCL=TLCL*(1.+0.608*QMIX) + CPORQ=1./ROCPQ + PLCL=P00*(TLCL/THMIX)**CPORQ + DO 29 NK=LC,KL + KLCL=NK + IF(PLCL.GE.P0(NK))GOTO 35 + 29 CONTINUE + GOTO 325 + 35 K=KLCL-1 + DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=T0(K)+(T0(KLCL)-T0(K))*DLP + QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + TVBAR=0.5*(TV0(K)+TVEN) +! ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G + ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP +! +!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER +!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0AVG IS AN +!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL +!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION +!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE +!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST +!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, +!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID +!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... +! + WKLCL=0.02*ZLCL/2.5E3 + WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3- & + WKLCL + WABS=ABS(WKL)+1.E-10 + WSIGNE=WKL/WABS + DTLCL=4.64*WSIGNE*WABS**0.33 + GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN) + WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10) + IF(TLCL+DTLCL.GT.TENV)GOTO 45 + IF(KPBL.GE.LLFC)GOTO 325 + GOTO 25 +! +!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE +!...EQUIVALENT POTENTIAL TEMPERATURE +!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... +! + 45 THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) + ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ)) + TVAVG=0.5*(TV0(KLCL)+TENV*(1.+0.608*QENV)) + PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL)) + QESE=EP2*ES/(PLCL-ES) + GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN) + WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10) + THTES(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* & + EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE)) + WTW=WLCL*WLCL + IF(WLCL.LT.0.)GOTO 25 + TVLCL=TLCL*(1.+0.608*QMIX) + RHOLCL=PLCL/(R*TVLCL) +! + LCL=KLCL + LET=LCL +! +!******************************************************************* +! * +! COMPUTE UPDRAFT PROPERTIES * +! * +!******************************************************************* +! +! +!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... +! + WU(K)=WLCL + AU0=PIE*RAD*RAD + UMF(K)=RHOLCL*AU0 + VMFLCL=UMF(K) + UPOLD=VMFLCL + UPNEW=UPOLD +! +!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), +!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE BUOYANT ENERGY, +! TRPPT IS THE TOTAL RATE OF PRECIPITATION PRODUCTION... +! + RATIO2(K)=0. + UER(K)=0. + ABE=0. + TRPPT=0. + TU(K)=TLCL + TVU(K)=TVLCL + QU(K)=QMIX + EQFRC(K)=1. + QLIQ(K)=0. + QICE(K)=0. + QLQOUT(K)=0. + QICOUT(K)=0. + DETLQ(K)=0. + DETIC(K)=0. + PPTLIQ(K)=0. + PPTICE(K)=0. + IFLAG=0 + KFRZ=LC +! +!...THE AMOUNT OF CONV AVAIL POT ENERGY (CAPE) IS CALCULATED WITH +! RESPECT TO UNDILUTE PARCEL ASCENT; EQ POT TEMP OF UNDILUTE +! PARCEL IS THTUDL, UNDILUTE TEMPERATURE IS GIVEN BY TUDL... +! + THTUDL=THETEU(K) + TUDL=TLCL +! +!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION +! PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH +! FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION +! INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE +! PREVIOUS MODEL LEVEL... +! + TTEMP=TTFRZ +! +!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, +! MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND +! MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... +! + DO 60 NK=K,KL-1 + NK1=NK+1 + RATIO2(NK1)=RATIO2(NK) +! +!...UPDATE UPDRAFT PROPERTIES AT THE NEXT MODEL LVL TO REFLECT +! ENTRAINMENT OF ENVIRONMENTAL AIR... +! + FRC1=0. + TU(NK1)=T0(NK1) + THETEU(NK1)=THETEU(NK) + QU(NK1)=QU(NK) + QLIQ(NK1)=QLIQ(NK) + QICE(NK1)=QICE(NK) + + CALL TPMIX(P0(NK1),THETEU(NK1),TU(NK1),QU(NK1),QLIQ(NK1), & + QICE(NK1),QNEWLQ,QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0, & + XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) +! +!...CHECK TO SEE IF UPDRAFT TEMP IS WITHIN THE FREEZING INTERVAL, +! IF IT IS, CALCULATE THE FRACTIONAL CONVERSION TO GLACIATION +! AND ADJUST QNEWLQ TO REFLECT THE GRADUAL CHANGE IN THETAU +! SINCE THE LAST MODEL LEVEL...THE GLACIATION EFFECTS WILL BE +! DETERMINED AFTER THE AMOUNT OF CONDENSATE AVAILABLE AFTER +! PRECIP FALLOUT IS DETERMINED...TTFRZ IS THE TEMP AT WHICH +! GLACIATION BEGINS, TBFRZ THE TEMP AT WHICH IT ENDS... +! + IF(TU(NK1).LE.TTFRZ.AND.IFLAG.LT.1)THEN + IF(TU(NK1).GT.TBFRZ)THEN + IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ + FRC1=(TTEMP-TU(NK1))/(TTFRZ-TBFRZ) + R1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) + ELSE + FRC1=(TTEMP-TBFRZ)/(TTFRZ-TBFRZ) + R1=1. + IFLAG=1 + ENDIF + QNWFRZ=QNEWLQ + QNEWIC=QNEWIC+QNEWLQ*R1*0.5 + QNEWLQ=QNEWLQ-QNEWLQ*R1*0.5 + EFFQ=(TTFRZ-TBFRZ)/(TTEMP-TBFRZ) + TTEMP=TU(NK1) + ENDIF +! +! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... +! + IF(NK.EQ.K)THEN + BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. + BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 + ENTERM=0. + DZZ=Z0(NK1)-ZLCL + ELSE + BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. + BOTERM=2.*DZA(NK)*G*BE/1.5 + ENTERM=2.*UER(NK)*WTW/UPOLD + DZZ=DZA(NK) + ENDIF + WSQ=WTW + CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM,RATE, & + QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1), G) + +!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, +! IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... +! + IF(WTW.LE.0.)GOTO 65 + WABS=SQRT(ABS(WTW)) + WU(NK1)=WTW/WABS +! +! UPDATE THE ABE FOR UNDILUTE ASCENT... +! + THTES(NK1)=T0(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QES(NK1))) & + * & + EXP((3374.6525/T0(NK1)-2.5403)*QES(NK1)*(1.+0.81* & + QES(NK1))) + UDLBE=((2.*THTUDL)/(THTES(NK)+THTES(NK1))-1.)*DZZ + IF(UDLBE.GT.0.)ABE=ABE+UDLBE*G +! +! DETERMINE THE EFFECTS OF CLOUD GLACIATION IF WITHIN THE SPECIFIED +! TEMP INTERVAL... +! + IF(FRC1.GT.1.E-6)THEN + CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QLIQ(NK1), & + QICE(NK1),RATIO2(NK1),TTFRZ,TBFRZ,QNWFRZ,RL,FRC1,EFFQ, & + IFLAG,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE & + ,CICE,DICE) + ENDIF +! +! CALL SUBROUTINE TO CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMP. +! WITHIN GLACIATION INTERVAL, THETAE MUST BE CALCULATED WITH RESPECT TO +! SAME DEGREE OF GLACIATION FOR ALL ENTRAINING AIR... +! + CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),RATIO2(NK1), & + RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + +!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... +! + REI=VMFLCL*DP(NK1)*0.03/RAD + TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) +! +!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, NO +! ENTRAINMENT IS ALLOWED AT THIS LEVEL... +! + IF(TVQU(NK1).LE.TV0(NK1))THEN + UER(NK1)=0.0 + UDR(NK1)=REI + EE2=0. + UD2=1. + EQFRC(NK1)=0. + GOTO 55 + ENDIF + LET=NK1 + TTMP=TVQU(NK1) +! +!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL +! AIR FOR ESTIMATION OF ENTRAINMENT AND DETRAINMENT RATES... +! + F1=0.95 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, & + QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, & + DLIQ,AICE,BICE,CICE,DICE) + TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU95.GT.TV0(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + GOTO 50 + ENDIF + F1=0.10 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, & + QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, & + DLIQ,AICE,BICE,CICE,DICE) + TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU10.EQ.TVQU(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + GOTO 50 + ENDIF + EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) + EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) + EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) + IF(EQFRC(NK1).EQ.1)THEN + EE2=1. + UD2=0. + GOTO 50 + ELSEIF(EQFRC(NK1).EQ.0.)THEN + EE2=0. + UD2=1. + GOTO 50 + ELSE +! +!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE +! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... +! + CALL PROF5(EQFRC(NK1),EE2,UD2) + ENDIF +! + 50 IF(NK.EQ.K)THEN + EE1=1. + UD1=0. + ENDIF +! +!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE +! FRACTIONAL VALUES IN THE LAYER... +! + UER(NK1)=0.5*REI*(EE1+EE2) + UDR(NK1)=0.5*REI*(UD1+UD2) +! +!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL +! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATION +! + 55 IF(UMF(NK)-UDR(NK1).LT.10.)THEN +! +!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL +! UPDRAFT FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE +! PREVIOUS MODEL +! + IF(UDLBE.GT.0.)ABE=ABE-UDLBE*G + LET=NK +! WRITE(98,1015)P0(NK1)/100. + GOTO 65 + ENDIF + EE1=EE2 + UD1=UD2 + UPOLD=UMF(NK)-UDR(NK1) + UPNEW=UPOLD+UER(NK1) + UMF(NK1)=UPNEW +! +!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND ICE IN +! THE DETRAINING UPDRAFT MASS... +! + DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) + DETIC(NK1)=QICE(NK1)*UDR(NK1) + QDT(NK1)=QU(NK1) + QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW + THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW + QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW + QICE(NK1)=QICE(NK1)*UPOLD/UPNEW +! +!...KFRZ IS THE HIGHEST MODEL LEVEL AT WHICH LIQUID CONDENSATE IS +! GENERATING PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF LIQUID +! PRECIP AT A GIVING MODEL LVL, PPTICE THE SAME FOR ICE, TRPPT IS +! THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE CURRENT MODEL LEVEL +! + IF(ABS(RATIO2(NK1)-1.).GT.1.E-6)KFRZ=NK1 + PPTLIQ(NK1)=QLQOUT(NK1)*(UMF(NK)-UDR(NK1)) + PPTICE(NK1)=QICOUT(NK1)*(UMF(NK)-UDR(NK1)) + TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) + IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + 60 CONTINUE +! +!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU +! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO +! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE +! BETWEEN THE LET AND CLOUD TOP... +! +!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL +! VELOCITY FIRST BECOMES NEGATIVE... +! + 65 LTOP=NK + CLDHGT=Z0(LTOP)-ZLCL +! +!...IF CLOUD TOP HGT IS LESS THAN SPECIFIED MINIMUM HEIGHT, GO BACK AND +! THE NEXT HIGHEST 60MB LAYER TO SEE IF A BIGGER CLOUD CAN BE OBTAINED +! THAT SOURCE AIR... +! +! IF(CLDHGT.LT.4.E3.OR.ABE.LT.1.)THEN + IF(CLDHGT.LT.3.E3.OR.ABE.LT.1.)THEN + DO 70 NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + 70 PPTICE(NK)=0. + GOTO 25 + ENDIF +! +!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS +! FLUX THIS LEVEL... +! + IF(LET.EQ.LTOP)THEN + UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) + DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD + DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD + TRPPT=TRPPT-(PPTLIQ(LTOP)+PPTICE(LTOP)) + UER(LTOP)=0. + UMF(LTOP)=0. + GOTO 85 + ENDIF +! +! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... +! + DPTT=0. + DO 71 NJ=LET+1,LTOP + 71 DPTT=DPTT+DP(NJ) + DUMFDP=UMF(LET)/DPTT +! +!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL +! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND +! PTOP +! + DO 75 NK=LET+1,LTOP + UDR(NK)=DP(NK)*DUMFDP + UMF(NK)=UMF(NK-1)-UDR(NK) + DETLQ(NK)=QLIQ(NK)*UDR(NK) + DETIC(NK)=QICE(NK)*UDR(NK) + TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) + PPTLIQ(NK)=(UMF(NK-1)-UDR(NK))*QLQOUT(NK) + PPTICE(NK)=(UMF(NK-1)-UDR(NK))*QICOUT(NK) + TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) + 75 CONTINUE +! +!...SEND UPDRAFT CHARACTERISTICS TO OUTPUT FILES... +! + 85 CONTINUE +! +!...EXTEND THE UPDRAFT MASS FLUX PROFILE DOWN TO THE SOURCE LAYER FOR +! THE UPDRAFT AIR...ALSO, DEFINE THETAE FOR LEVELS BELOW THE LCL... +! + DO 90 NK=1,K + IF(NK.GE.LC)THEN + IF(NK.EQ.LC)THEN + UMF(NK)=VMFLCL*DP(NK)/DPTHMX + UER(NK)=VMFLCL*DP(NK)/DPTHMX + ELSEIF(NK.LE.KPBL)THEN + UER(NK)=VMFLCL*DP(NK)/DPTHMX + UMF(NK)=UMF(NK-1)+UER(NK) + ELSE + UMF(NK)=VMFLCL + UER(NK)=0. + ENDIF + TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY + QU(NK)=QMIX + WU(NK)=WLCL + ELSE + TU(NK)=0. + QU(NK)=0. + UMF(NK)=0. + WU(NK)=0. + UER(NK)=0. + ENDIF + UDR(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + RATIO2(NK)=0. + EE=Q0(NK)*P0(NK)/(EP2+Q0(NK)) + TLOG=ALOG(EE/ALIQ) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T0(NK)-T00))*( & + T0(NK)-TDPT) + THTA=T0(NK)*(1.E5/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THETEE(NK)=THTA* & + EXP((3374.6525/TSAT-2.5403)*Q0(NK)*(1.+0.81*Q0(NK)) & + ) + THTES(NK)=THTA* & + EXP((3374.6525/T0(NK)-2.5403)*QES(NK)*(1.+0.81* & + QES(NK))) + EQFRC(NK)=1.0 + 90 CONTINUE +! + LTOP1=LTOP+1 + LTOPM1=LTOP-1 +! +!...DEFINE VARIABLES ABOVE CLOUD TOP... +! + DO 95 NK=LTOP1,KX + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + IF(NK.GT.LTOP1)THEN + TU(NK)=0. + QU(NK)=0. + WU(NK)=0. + ENDIF + THTA0(NK)=0. + THTAU(NK)=0. + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) + TG(NK)=T0(NK) + QG(NK)=Q0(NK) + QLG(NK)=0. + QIG(NK)=0. + QRG(NK)=0. + QSG(NK)=0. + 95 OMG(NK)=0. + OMG(KL+1)=0. + P150=P0(KLCL)-1.50E4 + DO 100 NK=1,LTOP + THTAD(NK)=0. + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) +! +!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION +! SCHEME +! + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) + THTAU(NK)=TU(NK)*EXN(NK) + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THTA0(NK)=T0(NK)*EXN(NK) +! +!...LVF IS THE LEVEL AT WHICH MOISTURE FLUX IS ESTIMATED AS THE BASIS +!...FOR PRECIPITATION EFFICIENCY CALCULATIONS... +! + IF(P0(NK).GT.P150)LVF=NK + 100 OMG(NK)=0. + LVF=MIN0(LVF,LET) + USR=UMF(LVF+1)*(QU(LVF+1)+QLIQ(LVF+1)+QICE(LVF+1)) + USR=AMIN1(USR,TRPPT) + IF(USR.LT.1.E-8)USR=TRPPT +! +! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, +! * TMIX-T00,PMIX,QMIX,ABE +! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., +! * WLCL,CLDHGT +! +!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL +!...AND MIDTROPOSPHERE IS USED. +! + WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) + WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) + WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) + VCONV=.5*(WSPD(KLCL)+WSPD(L5)) + if (VCONV .gt. 0.) then + TIMEC=DX/VCONV + else + TIMEC=3600. + endif +! TIMEC=DX/VCONV + TADVEC=TIMEC + TIMEC=AMAX1(1800.,TIMEC) + TIMEC=AMIN1(3600.,TIMEC) + NIC=NINT(TIMEC/DT) + TIMEC=FLOAT(NIC)*DT +! +!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. +! +! SHSIGN = CVMGT(1.,-1.,WSPD(LTOP).GT.WSPD(KLCL)) + IF(WSPD(LTOP).GT.WSPD(KLCL))THEN + SHSIGN=1. + ELSE + SHSIGN=-1. + ENDIF + VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & + (V0(LTOP)-V0(KLCL)) + VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) + PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) + PEF=AMAX1(PEF,.2) + PEF=AMIN1(PEF,.9) +! +!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. +! + CBH=(ZLCL-Z0(1))*3.281E-3 + IF(CBH.LT.3.)THEN + RCBH=.02 + ELSE + RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & + 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) + ENDIF + IF(CBH.GT.25)RCBH=2.4 + PEFCBH=1./(1.+RCBH) + PEFCBH=AMIN1(PEFCBH,.9) +! +!... MEAN PEF. IS USED TO COMPUTE RAINFALL. +! + PEFF=.5*(PEF+PEFCBH) + PEFF2=PEFF +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +! +!***************************************************************** +! * +! COMPUTE DOWNDRAFT PROPERTIES * +! * +!***************************************************************** +! +!...LET DOWNDRAFT ORIGINATE AT THE LEVEL OF MINIMUM SATURATION EQUIVALEN +!...POTENTIAL TEMPERATURE (SEQT) IN THE CLOUD LAYER, EXTEND DOWNWARD TO +!...SURFACE, OR TO THE LAYER BELOW CLOUD BASE AT WHICH ENVIR SEQT IS LES +!...THAN MIN SEQT IN THE CLOUD LAYER...LET DOWNDRAFT DETRAIN OVER A LAYE +!...OF SPECIFIED PRESSURE-DEPTH (DPDD)... +! + TDER=0. + KSTART=MAX0(KPBL,KLCL) + THTMIN=THTES(KSTART+1) + KMIN=KSTART+1 + DO 104 NK=KSTART+2,LTOP-1 + THTMIN=AMIN1(THTMIN,THTES(NK)) + IF(THTMIN.EQ.THTES(NK))KMIN=NK + 104 CONTINUE + LFS=KMIN + IF(RATIO2(LFS).GT.0.)CALL ENVIRTHT(P0(LFS),T0(LFS),Q0(LFS), & + THETEE(LFS),0.,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + EQFRC(LFS)=(THTES(LFS)-THETEU(LFS))/(THETEE(LFS)-THETEU(LFS)) + EQFRC(LFS)=AMAX1(EQFRC(LFS),0.) + EQFRC(LFS)=AMIN1(EQFRC(LFS),1.) + THETED(LFS)=THTES(LFS) +! +!...ESTIMATE THE EFFECT OF MELTING PRECIPITATION IN THE DOWNDRAFT... +! + IF(ML.GT.0)THEN + DTMLTD=0.5*(QU(KLCL)-QU(LTOP))*RLF/CP + ELSE + DTMLTD=0. + ENDIF + TZ(LFS)=T0(LFS)-DTMLTD + ES=ALIQ*EXP((TZ(LFS)*BLIQ-CLIQ)/(TZ(LFS)-DLIQ)) + QS=EP2*ES/(P0(LFS)-ES) + QD(LFS)=EQFRC(LFS)*Q0(LFS)+(1.-EQFRC(LFS))*QU(LFS) + THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QD(LFS))) + IF(QD(LFS).GE.QS)THEN + THETED(LFS)=THTAD(LFS)* & + EXP((3374.6525/TZ(LFS)-2.5403)*QS*(1.+0.81*QS)) + ELSE + CALL ENVIRTHT(P0(LFS),TZ(LFS),QD(LFS),THETED(LFS),0.,RL,EP2,ALIQ, & + BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + ENDIF + DO 107 NK=1,LFS + ND=LFS-NK + IF(THETED(LFS).GT.THTES(ND).OR.ND.EQ.1)THEN + LDB=ND +! +!...IF DOWNDRAFT NEVER BECOMES NEGATIVELY BUOYANT OR IF IT +!...IS SHALLOWER 50 mb, DON'T ALLOW IT TO OCCUR AT ALL... +! + IF(NK.EQ.1.OR.(P0(LDB)-P0(LFS)).LT.50.E2)GOTO 141 +! testing ---- no downdraft +! GOTO 141 + GOTO 110 + ENDIF + 107 CONTINUE +! +!...ALLOW DOWNDRAFT TO DETRAIN IN A SINGLE LAYER, BUT WITH DOWNDRAFT AIR +!...TYPICALLY FLUSHED UP INTO HIGHER LAYERS AS ALLOWED IN THE TOTAL +!...VERTICAL ADVECTION CALCULATIONS FARTHER DOWN IN THE CODE... +! + 110 DPDD=DP(LDB) + LDT=LDB + FRC=1. + DPT=0. +! DO 115 NK=LDB,LFS +! DPT=DPT+DP(NK) +! IF(DPT.GT.DPDD)THEN +! LDT=NK +! FRC=(DPDD+DP(NK)-DPT)/DP(NK) +! GOTO 120 +! ENDIF +! IF(NK.EQ.LFS-1)THEN +! LDT=NK +! FRC=1. +! DPDD=DPT +! GOTO 120 +! ENDIF +!115 CONTINUE + 120 CONTINUE +! +!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX.. +! + TVD(LFS)=T0(LFS)*(1.+0.608*QES(LFS)) + RDD=P0(LFS)/(R*TVD(LFS)) + A1=(1.-PEFF)*AU0 + DMF(LFS)=-A1*RDD + DER(LFS)=EQFRC(LFS)*DMF(LFS) + DDR(LFS)=0. + DO 140 ND=LFS-1,LDB,-1 + ND1=ND+1 + IF(ND.LE.LDT)THEN + DER(ND)=0. + DDR(ND)=-DMF(LDT+1)*DP(ND)*FRC/DPDD + DMF(ND)=DMF(ND1)+DDR(ND) + FRC=1. + THETED(ND)=THETED(ND1) + QD(ND)=QD(ND1) + ELSE + DER(ND)=DMF(LFS)*0.03*DP(ND)/RAD + DDR(ND)=0. + DMF(ND)=DMF(ND1)+DER(ND) + IF(RATIO2(ND).GT.0.)CALL ENVIRTHT(P0(ND),T0(ND),Q0(ND), & + THETEE(ND),0.,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) + QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) + ENDIF + 140 CONTINUE + TDER=0. +! +!...CALCULATION AN EVAPORATION RATE FOR GIVEN MASS FLUX... +! + DO 135 ND=LDB,LDT + TZ(ND)= & + TPDD(P0(ND),THETED(LDT),T0(ND),QS,QD(ND),1.0,XLV0,XLV1, & + EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE) + ES=ALIQ*EXP((TZ(ND)*BLIQ-CLIQ)/(TZ(ND)-DLIQ)) + QS=EP2*ES/(P0(ND)-ES) + DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) + RL=XLV0-XLV1*TZ(ND) + DTMP=RL*QS*(1.-RHBC)/(CP+RL*RHBC*QS*DSSDT) + T1RH=TZ(ND)+DTMP + ES=RHBC*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) + QSRH=EP2*ES/(P0(ND)-ES) +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(QSRH.LT.QD(ND))THEN + QSRH=QD(ND) +! T1RH=T1+(QS-QSRH)*RL/CP + T1RH=TZ(ND) + ENDIF + TZ(ND)=T1RH + QS=QSRH + TDER=TDER+(QS-QD(ND))*DDR(ND) + QD(ND)=QS + 135 THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) +! +!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE +!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... +! + 141 IF(TDER.LT.1.)THEN +! WRITE(98,3004)I,J + 3004 FORMAT(' ','I=',I3,2X,'J=',I3) + PPTFLX=TRPPT + CPR=TRPPT + TDER=0. + CNDTNF=0. + UPDINC=1. + LDB=LFS + DO 117 NDK=1,LTOP + DMF(NDK)=0. + DER(NDK)=0. + DDR(NDK)=0. + THTAD(NDK)=0. + WD(NDK)=0. + TZ(NDK)=0. + 117 QD(NDK)=0. + AINCM2=100. + GOTO 165 + ENDIF +! +!...ADJUST DOWNDRAFT MASS FLUX SO THAT EVAPORATION RATE IN DOWNDRAFT IS +!...CONSISTENT WITH PRECIPITATION EFFICIENCY RELATIONSHIP... +! + DEVDMF=TDER/DMF(LFS) + PPR=0. + PPTFLX=PEFF*USR + RCED=TRPPT-PPTFLX +! +!...PPR IS THE TOTAL AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE +!...UPDRAFT FROM CLOUD BASE TO THE LFS...UPDRAFT MASS FLUX WILL BE +!...INCREASED UP TO THE LFS TO ACCOUNT FOR UPDRAFT AIR MIXING WITH +!...ENVIRONMENTAL AIR TO THE UPDRAFT, SO PPR WILL INCREASE +!...PROPORTIONATELY... +! + DO 132 NM=KLCL,LFS + 132 PPR=PPR+PPTLIQ(NM)+PPTICE(NM) + IF(LFS.GE.KLCL)THEN + DPPTDF=(1.-PEFF)*PPR*(1.-EQFRC(LFS))/UMF(LFS) + ELSE + DPPTDF=0. + ENDIF +! +!...CNDTNF IS THE AMOUNT OF CONDENSATE TRANSFERRED ALONG WITH UPDRAFT +!...MASS THE DOWNDRAFT AT THE LFS... +! + CNDTNF=(QLIQ(LFS)+QICE(LFS))*(1.-EQFRC(LFS)) + DMFLFS=RCED/(DEVDMF+DPPTDF+CNDTNF) + IF(DMFLFS.GT.0.)THEN + TDER=0. + GOTO 141 + ENDIF +! +!...DDINC IS THE FACTOR BY WHICH TO INCREASE THE FIRST-GUESS DOWNDRAFT +!...MASS FLUX TO SATISFY THE PRECIP EFFICIENCY RELATIONSHIP, UPDINC IS T +!...WHICH TO INCREASE THE UPDRAFT MASS FLUX BELOW THE LFS TO ACCOUNT FOR +!...TRANSFER OF MASS FROM UPDRAFT TO DOWNDRAFT... +! +! DDINC=DMFLFS/DMF(LFS) + IF(LFS.GE.KLCL)THEN + UPDINC=(UMF(LFS)-(1.-EQFRC(LFS))*DMFLFS)/UMF(LFS) +! +!...LIMIT UPDINC TO LESS THAN OR EQUAL TO 1.5... +! + IF(UPDINC.GT.1.5)THEN + UPDINC=1.5 + DMFLFS2=UMF(LFS)*(UPDINC-1.)/(EQFRC(LFS)-1.) + RCED2=DMFLFS2*(DEVDMF+DPPTDF+CNDTNF) + PPTFLX=PPTFLX+(RCED-RCED2) + PEFF2=PPTFLX/USR + RCED=RCED2 + DMFLFS=DMFLFS2 + ENDIF + ELSE + UPDINC=1. + ENDIF + DDINC=DMFLFS/DMF(LFS) + DO 149 NK=LDB,LFS + DMF(NK)=DMF(NK)*DDINC + DER(NK)=DER(NK)*DDINC + DDR(NK)=DDR(NK)*DDINC + 149 CONTINUE + CPR=TRPPT+PPR*(UPDINC-1.) + PPTFLX=PPTFLX+PEFF*PPR*(UPDINC-1.) + PEFF=PEFF2 + TDER=TDER*DDINC +! +!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN +! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE +! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... +! + DO 155 NK=LC,LFS + UMF(NK)=UMF(NK)*UPDINC + UDR(NK)=UDR(NK)*UPDINC + UER(NK)=UER(NK)*UPDINC + PPTLIQ(NK)=PPTLIQ(NK)*UPDINC + PPTICE(NK)=PPTICE(NK)*UPDINC + DETLQ(NK)=DETLQ(NK)*UPDINC + 155 DETIC(NK)=DETIC(NK)*UPDINC +! +!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE +!...DOWNDRAFT... +! + IF(LDB.GT.1)THEN + DO 156 NK=1,LDB-1 + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + 156 CONTINUE + ENDIF + DO 157 NK=LFS+1,KX + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + 157 CONTINUE + DO 158 NK=LDT+1,LFS-1 + TZ(NK)=0. + QD(NK)=0. + 158 CONTINUE +! +! +!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE +! INFLOW INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN +! IS AVAILABLE IN THAT LAYER INITIALLY... +! + 165 AINCMX=1000. + LMAX=MAX0(KLCL,LFS) + DO 166 NK=LC,LMAX + IF((UER(NK)-DER(NK)).GT.0.)AINCM1=EMS(NK)/((UER(NK)-DER(NK))* & + TIMEC) + AINCMX=AMIN1(AINCMX,AINCM1) + 166 CONTINUE + AINC=1. + IF(AINCMX.LT.AINC)AINC=AINCMX +! +!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRFT AND DOWNDRFT...THEY +!...WILL ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE +!...STABILIZATION CLOSURE... +! + NCOUNT=0 + TDER2=TDER + PPTFL2=PPTFLX + DO 170 NK=1,LTOP + DETLQ2(NK)=DETLQ(NK) + DETIC2(NK)=DETIC(NK) + UDR2(NK)=UDR(NK) + UER2(NK)=UER(NK) + DDR2(NK)=DDR(NK) + DER2(NK)=DER(NK) + UMF2(NK)=UMF(NK) + DMF2(NK)=DMF(NK) + 170 CONTINUE + FABE=1. + STAB=0.95 + NOITR=0 + IF(AINC/AINCMX.GT.0.999)THEN + NCOUNT=0 + GOTO 255 + ENDIF + ISTOP=0 + 175 NCOUNT=NCOUNT+1 +! +!***************************************************************** +! * +! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * +! * +!***************************************************************** +! +!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO +!...SATISFY MASS CONTINUITY... +! + 185 CONTINUE + DTT=TIMEC + DO 200 NK=1,LTOP + DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) + IF(NK.GT.1)THEN + OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) + DTT1=0.75*DP(NK-1)/(ABS(OMG(NK))+1.E-10) + DTT=AMIN1(DTT,DTT1) + ENDIF + 200 CONTINUE + DO 488 NK=1,LTOP + THPA(NK)=THTA0(NK) + QPA(NK)=Q0(NK) + NSTEP=NINT(TIMEC/DTT+1) + DTIME=TIMEC/FLOAT(NSTEP) + FXM(NK)=OMG(NK)*DXSQ/G + 488 CONTINUE +! +!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... +! + DO 495 NTC=1,NSTEP +! +!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED +!...SIGN OF OMEGA... +! + DO 493 NK=1,LTOP + THFXTOP(NK)=0. + THFXBOT(NK)=0. + QFXTOP(NK)=0. + 493 QFXBOT(NK)=0. + DO 494 NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + THFXBOT(NK)=-FXM(NK)*THPA(NK-1) + QFXBOT(NK)=-FXM(NK)*QPA(NK-1) + THFXTOP(NK-1)=THFXTOP(NK-1)-THFXBOT(NK) + QFXTOP(NK-1)=QFXTOP(NK-1)-QFXBOT(NK) + ELSE + THFXBOT(NK)=-FXM(NK)*THPA(NK) + QFXBOT(NK)=-FXM(NK)*QPA(NK) + THFXTOP(NK-1)=THFXTOP(NK-1)-THFXBOT(NK) + QFXTOP(NK-1)=QFXTOP(NK-1)-QFXBOT(NK) + ENDIF + 494 CONTINUE +! +!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL.. +! + DO 492 NK=1,LTOP + THPA(NK)=THPA(NK)+(THFXBOT(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & + THTAD(NK)+THFXTOP(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & + DTIME*EMSD(NK) + QPA(NK)=QPA(NK)+(QFXBOT(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)+ & + QFXTOP(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) + + 492 CONTINUE + 495 CONTINUE + DO 498 NK=1,LTOP + THTAG(NK)=THPA(NK) + QG(NK)=QPA(NK) + 498 CONTINUE +! +!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, +!...BORROW MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO. +! + DO 499 NK=1,LTOP + IF(QG(NK).LT.0.)THEN + IF(NK.EQ.1)THEN + CALL wrf_error_fatal ( 'module_cu_kf.F: problem with kf scheme: qg = 0 at the surface' ) + ENDIF + NK1=NK+1 + IF(NK.EQ.LTOP)NK1=KLCL + TMA=QG(NK1)*EMS(NK1) + TMB=QG(NK-1)*EMS(NK-1) + TMM=(QG(NK)-1.E-9)*EMS(NK) + BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) + ACOEFF=BCOEFF*TMA/TMB + TMB=TMB*(1.-BCOEFF) + TMA=TMA*(1.-ACOEFF) + IF(NK.EQ.LTOP)THEN + QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) + IF(ABS(QVDIFF).GT.1.)THEN + PRINT *,'--WARNING-- CLOUD BASE WATER VAPOR CHANGES BY ', & + QVDIFF, & + ' PERCENT WHEN MOISTURE IS BORROWED TO PREVENT NEG VALUES', & + ' IN KAIN-FRITSCH' + ENDIF + ENDIF + QG(NK)=1.E-9 + QG(NK1)=TMA*EMSD(NK1) + QG(NK-1)=TMB*EMSD(NK-1) + ENDIF + 499 CONTINUE + TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) + IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN +! WRITE(98,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME;' +! * ,'TOPOMG, OMG =',TOPOMG,OMG(LTOP) + WRITE(6,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME;' & + ,'TOPOMG, OMG =',TOPOMG,OMG(LTOP) + ISTOP=1 + GOTO 265 + ENDIF +! +!...CONVERT THETA TO T... +! +! PAY ATTENTION ... +! + DO 230 NK=1,LTOP + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) + TG(NK)=THTAG(NK)/EXN(NK) + TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) + 230 CONTINUE +! +!******************************************************************* +! * +! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * +! * +!******************************************************************* +! +!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT +! + THMIX=0. + QMIX=0. + PMIX=0. + DO 217 NK=LC,KPBL + ROCPQ=0.2854*(1.-0.28*QG(NK)) + THMIX=THMIX+DP(NK)*TG(NK)*(P00/P0(NK))**ROCPQ + QMIX=QMIX+DP(NK)*QG(NK) + 217 PMIX=PMIX+DP(NK)*P0(NK) + THMIX=THMIX/DPTHMX + QMIX=QMIX/DPTHMX + PMIX=PMIX/DPTHMX + ROCPQ=0.2854*(1.-0.28*QMIX) + TMIX=THMIX*(PMIX/P00)**ROCPQ + ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) + QS=EP2*ES/(PMIX-ES) +! +!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... +! + IF(QMIX.GT.QS)THEN + RL=XLV0-XLV1*TMIX + CPM=CP*(1.+0.887*QMIX) + DSSDT=QS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) + DQ=(QMIX-QS)/(1.+RL*DSSDT/CPM) + TMIX=TMIX+RL/CP*DQ + QMIX=QMIX-DQ + ROCPQ=0.2854*(1.-0.28*QMIX) + THMIX=TMIX*(P00/PMIX)**ROCPQ + TLCL=TMIX + PLCL=PMIX + ELSE + QMIX=AMAX1(QMIX,0.) + EMIX=QMIX*PMIX/(EP2+QMIX) + TLOG=ALOG(EMIX/ALIQ) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX- & + TDPT) + TLCL=AMIN1(TLCL,TMIX) + CPORQ=1./ROCPQ + PLCL=P00*(TLCL/THMIX)**CPORQ + ENDIF + TVLCL=TLCL*(1.+0.608*QMIX) + DO 235 NK=LC,KL + KLCL=NK + 235 IF(PLCL.GE.P0(NK))GOTO 240 + 240 K=KLCL-1 + DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=TG(K)+(TG(KLCL)-TG(K))*DLP + QENV=QG(K)+(QG(KLCL)-QG(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + TVBAR=0.5*(TVG(K)+TVEN) +! ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G + ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP + TVAVG=0.5*(TVEN+TG(KLCL)*(1.+0.608*QG(KLCL))) + PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL)) + THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) + ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ)) + QESE=EP2*ES/(PLCL-ES) + THTESG(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* & + EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE)) +! +!...COMPUTE ADJUSTED ABE(ABEG). +! + ABEG=0. + THTUDL=THETEU(K) + DO 245 NK=K,LTOPM1 + NK1=NK+1 + ES=ALIQ*EXP((TG(NK1)*BLIQ-CLIQ)/(TG(NK1)-DLIQ)) + QESE=EP2*ES/(P0(NK1)-ES) + THTESG(NK1)=TG(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QESE))* & + EXP((3374.6525/TG(NK1)-2.5403)*QESE*(1.+0.81*QESE) & + ) +! DZZ=CVMGT(Z0(KLCL)-ZLCL,DZA(NK),NK.EQ.K) + IF(NK.EQ.K)THEN + DZZ=Z0(KLCL)-ZLCL + ELSE + DZZ=DZA(NK) + ENDIF + BE=((2.*THTUDL)/(THTESG(NK1)+THTESG(NK))-1.)*DZZ + 245 IF(BE.GT.0.)ABEG=ABEG+BE*G +! +!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING +!...THE PERIOD TIMEC... +! + IF(NOITR.EQ.1)THEN +! WRITE(98,1060)FABE + GOTO 265 + ENDIF + DABE=AMAX1(ABE-ABEG,0.1*ABE) + FABE=ABEG/(ABE+1.E-8) + IF(FABE.GT.1.)THEN +! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS ' +! *,'GRID POINT; NO CONVECTION ALLOWED!' + GOTO 325 + ENDIF + IF(NCOUNT.NE.1)THEN + DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) + IF(DFDA.GT.0.)THEN + NOITR=1 + AINC=AINCOLD + GOTO 255 + ENDIF + ENDIF + AINCOLD=AINC + FABEOLD=FABE + IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN +! WRITE(98,1055)FABE + GOTO 265 + ENDIF + IF(FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB)GOTO 265 + IF(NCOUNT.GT.10)THEN +! WRITE(98,1060)FABE + GOTO 265 + ENDIF +! +!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE +!...CONVECTIVE MASS FLUX BY THE FACTOR AINC: +! + IF(FABE.EQ.0.)THEN + AINC=AINC*0.5 + ELSE + AINC=AINC*STAB*ABE/(DABE+1.E-8) + ENDIF + 255 AINC=AMIN1(AINCMX,AINC) +!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION +!...WILL BE MINIMAL SO JUST IGNORE IT... + IF(AINC.LT.0.05)GOTO 325 +! AINC=AMAX1(AINC,0.05) + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,NSTEP,NCOUNT,FABEOLD,AINCOLD + DO 260 NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + 260 CONTINUE +! +!...GO BACK UP FOR ANOTHER ITERATION... +! + GOTO 175 + 265 CONTINUE +! +!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS +!...GRID POINT... +! +!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... +! +!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE +!...GENERATED THAT GOES INTO PRECIPITIATION + FRC2=PPTFLX/(CPR*AINC) + DO 270 NK=1,LTOP + QLPA(NK)=QL0(NK) + QIPA(NK)=QI0(NK) + QRPA(NK)=QR0(NK) + QSPA(NK)=QS0(NK) + RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 + SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 + 270 CONTINUE + DO 290 NTC=1,NSTEP +! +!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH +!...LAYER BASED ON THE SIGN OF OMEGA... +! + DO 275 NK=1,LTOP + QLFXIN(NK)=0. + QLFXOUT(NK)=0. + QIFXIN(NK)=0. + QIFXOUT(NK)=0. + QRFXIN(NK)=0. + QRFXOUT(NK)=0. + QSFXIN(NK)=0. + QSFXOUT(NK)=0. + 275 CONTINUE + DO 280 NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) + QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) + QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) + QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) + QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) + QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) + QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) + QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) + ELSE + QLFXOUT(NK)=FXM(NK)*QLPA(NK) + QIFXOUT(NK)=FXM(NK)*QIPA(NK) + QRFXOUT(NK)=FXM(NK)*QRPA(NK) + QSFXOUT(NK)=FXM(NK)*QSPA(NK) + QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) + QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) + QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) + QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) + ENDIF + 280 CONTINUE +! +!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... +! + DO 285 NK=1,LTOP + QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME* & + EMSD(NK) + QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME* & + EMSD(NK) + QRPA(NK)=QRPA(NK)+(QRFXIN(NK)+QLQOUT(NK)*UDR(NK)-QRFXOUT(NK) & + +RAINFB(NK))*DTIME*EMSD(NK) + QSPA(NK)=QSPA(NK)+(QSFXIN(NK)+QICOUT(NK)*UDR(NK)-QSFXOUT(NK) & + +SNOWFB(NK))*DTIME*EMSD(NK) + 285 CONTINUE + 290 CONTINUE + DO 295 NK=1,LTOP + QLG(NK)=QLPA(NK) + QIG(NK)=QIPA(NK) + QRG(NK)=QRPA(NK) + QSG(NK)=QSPA(NK) + 295 CONTINUE +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,NSTEP,NCOUNT,FABE,AINC +! +!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... +! + IF(ISTOP.EQ.1)THEN + WRITE(6,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & + ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & + ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' + DO 300 K=LTOP,1,-1 + DTT=(TG(K)-T0(K))*86400./TIMEC + RL=XLV0-XLV1*TG(K) + DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) + UDFRC=UDR(K)*TIMEC*EMSD(K) + UEFRC=UER(K)*TIMEC*EMSD(K) + DDFRC=DDR(K)*TIMEC*EMSD(K) + DEFRC=-DER(K)*TIMEC*EMSD(K) + WRITE (6,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)* & + 1.E4,UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC & + ,DDFRC,EMS(K)/1.E11,W0AVG1D(K)*1.E2,DETLQ(K) & + *TIMEC*EMSD(K)*1.E3,DETIC(K)*TIMEC*EMSD(K)* & + 1.E3 + 300 CONTINUE + WRITE(6,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & + 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' + DO 305 K=KX,1,-1 + DTT=TG(K)-T0(K) + TUC=TU(K)-T00 + IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. + TDC=TZ(K)-T00 + IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + QGS=ES*EP2/(P0(K)-ES) + RH0=Q0(K)/QES(K) + RHG=QG(K)/QGS + WRITE (6,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC & + ,TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))* & + 1000.,QU(K)*1000.,QD(K)*1000.,QLG(K)*1000., & + QIG(K)*1000.,QRG(K)*1000.,QSG(K)*1000.,RH0,RHG + 305 CONTINUE +! +!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A +!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... +! + IF(ISTOP.EQ.1)THEN + DO 310 K=1,KX + WRITE ( wrf_err_message , 1115 ) & + Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & + U0(K),V0(K),DP(K)/100.,W0AVG1D(K) + CALL wrf_message ( TRIM( wrf_err_message ) ) + 310 CONTINUE + CALL wrf_error_fatal ( 'module_cu_kf.F: KAIN-FRITSCH' ) + ENDIF + ENDIF + CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) +! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF +! +! EVALUATE MOISTURE BUDGET... +! + QINIT=0. + QFNL=0. + DPT=0. + DO 315 NK=1,LTOP + DPT=DPT+DP(NK) + QINIT=QINIT+Q0(NK)*EMS(NK) + QFNL=QFNL+QG(NK)*EMS(NK) + QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) + 315 CONTINUE + QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) + ERR2=(QFNL-QINIT)*100./QINIT +! WRITE(98,1110)QINIT,QFNL,ERR2 +! IF(ABS(ERR2).GT.0.05)STOP 'QVERR' + IF(ABS(ERR2).GT.0.05)CALL wrf_error_fatal( 'module_cu_kf.F: QVERR' ) + RELERR=ERR2*QINIT/(PPTFLX*TIMEC+1.E-10) +! WRITE(98,1120)RELERR +! WRITE(98,*)'TDER, CPR, USR, TRPPT =', +! *TDER,CPR*AINC,USR*AINC,TRPPT*AINC +! +!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. +! +!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM +!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... +! + IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) + NCA(I,J)=FLOAT(NIC) + DO 320 K=1,KX +! IF(IMOIST.NE.2)THEN +! +!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT +!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. +!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND +!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE +!...OF QG... +! +! RLC=XLV0-XLV1*TG(K) +! RLS=XLS0-XLS1*TG(K) +! CPM=CP*(1.+0.887*QG(K)) +! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM +! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) +! DQCDT(K)=0. +! DQIDT(K)=0. +! DQRDT(K)=0. +! DQSDT(K)=0. +! ELSE + IF(.NOT. qi_flag .and. warm_rain)THEN +! +!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... +! + CPM=CP*(1.+0.887*QG(K)) + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(.NOT. qi_flag .and. .not. warm_rain)THEN +! +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME +!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL +! + CPM=CP*(1.+0.887*QG(K)) + IF(K.LE.ML)THEN + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + ELSEIF(K.GT.ML)THEN + TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM + ENDIF + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(qi_flag) THEN +! +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE +!...TENDENCY OF HYDROMETEORS DIRECTLY... +! + DQCDT(K)=(QLG(K)-QL0(K))/TIMEC + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQRDT(K)=(QRG(K)-QR0(K))/TIMEC + IF (qs_flag ) THEN + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + ELSE + DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + ENDIF + ELSE + CALL wrf_error_fatal ( 'module_cu_kf: THIS COMBINATION OF IMOIST, IICE NOT ALLOWED' ) + ENDIF +! ENDIF + DTDT(K)=(TG(K)-T0(K))/TIMEC + DQDT(K)=(QG(K)-Q0(K))/TIMEC + 320 CONTINUE + +! RAINCV is in the unit of mm + + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC +! WRITE(98,909)RNC + 909 FORMAT(' CONVECTIVE RAINFALL =',F8.4,' CM') + + 325 CONTINUE + +1000 FORMAT(' ',10A8) +1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) +1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') +1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') +1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & + ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & + I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & + ' CAPE=',0PF7.1) +1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & + E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & + F8.1) +1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & + ,F6.3,'VWS=',F5.2) +1040 FORMAT(' ','PRECIP EFF = 100%, ENVIR CANNOT SUPPORT DOWND' & + ,'RAFTS') +!1045 FORMAT('NUMBER OF DOWNDRAFT ITERATIONS EXCEEDS 10...PPTFLX' & +! ' IS DIFFERENT FROM THAT GIVEN BY PRECIP EFF RELATION') +! FLIC HAS TROUBLE WITH THIS ONE. +1045 FORMAT('NUMBER OF DOWNDRAFT ITERATIONS EXCEEDS 10') +1050 FORMAT(' ','LCOUNT= ',I3,' PPTFLX/CPR, PEFF= ',F5.3,1X,F5.3, & + 'DMF(LFS)/UMF(LCL)= ',F5.3) +1055 FORMAT(/'*** DEGREE OF STABILIZATION =',F5.3,', NO MORE MASS F' & + ,'LUX IS ALLOWED') +!1060 FORMAT(/' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED ' & +! 'DEGREE OF STABILIZATION! FABE= ',F6.4) +1060 FORMAT(/' ITERATION DOES NOT CONVERGE. FABE= ',F6.4) + 1070 FORMAT (16A8) + 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) +1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, NSTEP=',F5.0,I3, & + 'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) + 1085 FORMAT (A3,16A7,2A8) + 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) +1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ', & + F10.0) +1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =', & + E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'PERCENT') +1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & + ' TOTAL WATER CHANGE =',F8.2,'PERCENT') + 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4 & + ) +1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3, & + 'PERCENT') + + END SUBROUTINE KFPARA + +!----------------------------------------------------------------------- + SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & + QNEWIC,QLQOUT,QICOUT,G) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + + REAL, INTENT(IN ) :: G + REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE + REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC + + REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG + + QTOT=QLIQ+QICE + QNEW=QNEWLQ+QNEWIC +! +! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY C +! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL +! LEVELS... +! + QEST=0.5*(QTOT+QNEW) + G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 + IF(G1.LT.0.0)G1=0. + WAVG=(SQRT(WTW)+SQRT(G1))/2. + CONV=RATE*DZ/WAVG +! +! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS +! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV +! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN +! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... +! + RATIO3=QNEWLQ/(QNEW+1.E-10) +! OLDQ=QTOT + QTOT=QTOT+0.6*QNEW + OLDQ=QTOT + RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-10) + QTOT=QTOT*EXP(-CONV) +! +! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT +! PARCEL AT THIS LEVEL... +! + DQ=OLDQ-QTOT + QLQOUT=RATIO4*DQ + QICOUT=(1.-RATIO4)*DQ +! +! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL +! LATE VERTICAL VELOCITY +! + PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) + WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 +! +! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE +! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... +! + QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW + QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW + QNEWLQ=0. + QNEWIC=0. + + END SUBROUTINE CONDLOAD + +!----------------------------------------------------------------------- + SUBROUTINE DTFRZNEW(TU,P,THTEU,QVAP,QLIQ,QICE,RATIO2,TTFRZ,TBFRZ, & + QNWFRZ,RL,FRC1,EFFQ,IFLAG,XLV0,XLV1,XLS0,XLS1, & + EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: XLV0,XLV1 + REAL, INTENT(IN ) :: P,TTFRZ,TBFRZ,EFFQ,XLS0,XLS1,EP2,ALIQ, & + BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE + REAL, INTENT(INOUT) :: TU,THTEU,QVAP,QLIQ,QICE,RATIO2, & + FRC1,RL,QNWFRZ + INTEGER, INTENT(INOUT) :: IFLAG + + REAL :: CCP,RV,C5,QLQFRZ,QNEW,ESLIQ,ESICE,RLC,RLS,PI,ES,RLF,A, & + B,C,DQVAP,DTFRZ,TU1,QVAP1 +!----------------------------------------------------------------------- +! +!...ALLOW GLACIATION OF THE UPDRAFT TO OCCUR AS AN APPROXIMATELY LINEAR +! FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE TTFRZ TO TBFRZ... +! + + RV=461.5 + C5=1.0723E-3 +! +!...ADJUST THE LIQUID WATER CONCENTRATIONS FROM FRESH CONDENSATE AND THA +! BROUGHT UP FROM LOWER LEVELS TO AN AMOUNT THAT WOULD BE PRESENT IF N +! LIQUID WATER HAD FROZEN THUS FAR...THIS IS NECESSARY BECAUSE THE +! EXPRESSION FOR TEMP CHANGE IS MULTIPLIED BY THE FRACTION EQUAL TO TH +! PARCEL TEMP DECREASE SINCE THE LAST MODEL LEVEL DIVIDED BY THE TOTAL +! GLACIATION INTERVAL, SO THAT EFFECTIVELY THIS APPROXIMATELY ALLOWS A +! AMOUNT OF LIQUID WATER TO FREEZE WHICH IS EQUAL TO THIS SAME FRACTIO +! OF THE LIQUID WATER THAT WAS PRESENT BEFORE THE GLACIATION PROCESS W +! INITIATED...ALSO, TO ALLOW THETAU TO CONVERT APPROXIMATELY LINEARLY +! ITS VALUE WITH RESPECT TO ICE, WE NEED TO ALLOW A PORTION OF THE FRE +! CONDENSATE TO CONTRIBUTE TO THE GLACIATION PROCESS; THE FRACTIONAL +! AMOUNT THAT APPLIES TO THIS PORTION IS 1/2 OF THE FRACTIONAL AMOUNT +! FROZEN OF THE "OLD" CONDENSATE BECAUSE THIS FRESH CONDENSATE IS ONLY +! PRODUCED GRADUALLY OVER THE LAYER...NOTE THAT IN TERMS OF THE DYNAMI +! OF THE PRECIPITATION PROCESS, IE. PRECIPITATION FALLOUT, THIS FRACTI +! AMNT OF FRESH CONDENSATE HAS ALREADY BEEN INCLUDED IN THE ICE CATEGO +! + QLQFRZ=QLIQ*EFFQ + QNEW=QNWFRZ*EFFQ*0.5 + ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) + RLC=2.5E6-2369.276*(TU-273.16) + RLS=2833922.-259.532*(TU-273.16) + RLF=RLS-RLC + CCP=1005.7*(1.+0.89*QVAP) +! +! A = D(ES)/DT IS THAT CALCULATED FROM BUCK`S (1981) EMPIRICAL FORMULAS +! FOR SATURATION VAPOR PRESSURE... +! + A=(CICE-BICE*DICE)/((TU-DICE)*(TU-DICE)) + B=RLS*EP2/P + C=A*B*ESICE/CCP + DQVAP=B*(ESLIQ-ESICE)/(RLS+RLS*C)-RLF*(QLQFRZ+QNEW)/(RLS+RLS/C) + DTFRZ=(RLF*(QLQFRZ+QNEW)+B*(ESLIQ-ESICE))/(CCP+A*B*ESICE) + TU1=TU + QVAP1=QVAP + TU=TU+FRC1*DTFRZ + QVAP=QVAP-FRC1*DQVAP + ES=QVAP*P/(EP2+QVAP) + ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) + RATIO2=(ESLIQ-ES)/(ESLIQ-ESICE) +! +! TYPICALLY, RATIO2 IS VERY CLOSE TO (TTFRZ-TU)/(TTFRZ-TBFRZ), USUALLY +! WITHIN 1% (USING TU BEFORE GALCIATION EFFECTS ARE APPLIED); IF THE +! INITIAL UPDRAFT TEMP IS BELOW TBFRZ AND RATIO2 IS STILL LESS THAN 1, +! AN ADJUSTMENT TO FRC1 AND RATIO2 IS INTRODUCED SO THAT GLACIATION +! EFFECTS ARE NOT UNDERESTIMATED; CONVERSELY, IF RATIO2 IS GREATER THAN +! FRC1 IS ADJUSTED SO THAT GLACIATION EFFECTS ARE NOT OVERESTIMATED... +! + IF(IFLAG.GT.0.AND.RATIO2.LT.1)THEN + FRC1=FRC1+(1.-RATIO2) + TU=TU1+FRC1*DTFRZ + QVAP=QVAP1-FRC1*DQVAP + RATIO2=1. + IFLAG=1 + GOTO 20 + ENDIF + IF(RATIO2.GT.1.)THEN + FRC1=FRC1-(RATIO2-1.) + FRC1=AMAX1(0.0,FRC1) + TU=TU1+FRC1*DTFRZ + QVAP=QVAP1-FRC1*DQVAP + RATIO2=1. + IFLAG=1 + ENDIF +! +! CALCULATE A HYBRID VALUE OF THETAU, ASSUMING THAT THE LATENT HEAT OF +! VAPORIZATION/SUBLIMATION CAN BE ESTIMATED USING THE SAME WEIGHTING +! FUNCTION AS THAT USED TO CALCULATE SATURATION VAPOR PRESSURE, CALCU- +! LATE NEW LIQUID WATER AND ICE CONCENTRATIONS... +! + 20 RLC=XLV0-XLV1*TU + RLS=XLS0-XLS1*TU + RL=RATIO2*RLS+(1.-RATIO2)*RLC + PI=(1.E5/P)**(0.2854*(1.-0.28*QVAP)) + THTEU=TU*PI*EXP(RL*QVAP*C5/TU*(1.+0.81*QVAP)) + IF(IFLAG.EQ.1)THEN + QICE=QICE+FRC1*DQVAP+QLIQ + QLIQ=0. + ELSE + QICE=QICE+FRC1*(DQVAP+QLQFRZ) + QLIQ=QLIQ-FRC1*QLQFRZ + ENDIF + QNWFRZ=0. + + END SUBROUTINE DTFRZNEW + +!----------------------------------------------------------------------- +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN +! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN F +! HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMA +! TABLES ED. BY ABRAMOWITZ AND STEGUN, NAT L BUREAU OF STANDARDS APPLI +! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. +! JACK KAIN +! 7/6/89 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!*********************************************************************** +!***** GAUSSIAN TYPE MIXING PROFILE....****************************** + SUBROUTINE PROF5(EQ,EE,UD) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: EQ + REAL, INTENT(INOUT) :: EE,UD + REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 + + DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & + 0.9372980,0.33267,0.166666667,0.202765151/ + X=(EQ-0.5)/SIGMA + Y=6.*EQ-3. + EY=EXP(Y*Y/(-2)) + E45=EXP(-4.5) + T2=1./(1.+P*ABS(Y)) + T1=0.500498 + C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 + C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 + IF(Y.GE.0.)THEN + EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & + EQ) + ELSE + EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & + EQ/2.-EQ) + ENDIF + EE=EE/FE + UD=UD/FE + + END SUBROUTINE PROF5 + +!----------------------------------------------------------------------- + SUBROUTINE TPMIX(P,THTU,TU,QU,QLIQ,QICE,QNEWLQ,QNEWIC,RATIO2,RL, & + XLV0,XLV1,XLS0,XLS1, & + EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: XLV0,XLV1 + REAL, INTENT(IN ) :: P,THTU,RATIO2,RL,XLS0, & + XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,& + CICE,DICE + REAL, INTENT(INOUT) :: QU,QLIQ,QICE,TU,QNEWLQ,QNEWIC + REAL :: ES,QS,PI,THTGS,F0,T1,T0,C5,RV,ESLIQ,ESICE,F1,DT,QNEW, & + DQ, QTOT,DQICE,DQLIQ,RLL,CCP + INTEGER :: ITCNT +!----------------------------------------------------------------------- +! +!...THIS SUBROUTINE ITERATIVELY EXTRACTS WET-BULB TEMPERATURE FROM EQUIV +! POTENTIAL TEMPERATURE, THEN CHECKS TO SEE IF SUFFICIENT MOISTURE IS +! AVAILABLE TO ACHIEVE SATURATION...IF NOT, TEMPERATURE IS ADJUSTED +! ACCORDINGLY, IF SO, THE RESIDUAL LIQUID WATER/ICE CONCENTRATION IS +! DETERMINED... +! + C5=1.0723E-3 + RV=461.5 +! +! ITERATE TO FIND WET BULB TEMPERATURE AS A FUNCTION OF EQUIVALENT POT +! TEMP AND PRS, ASSUMING SATURATION VAPOR PRESSURE...RATIO2 IS THE DEG +! OF GLACIATION... +! + IF(RATIO2.LT.1.E-6)THEN + ES=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=TU*PI*EXP((3374.6525/TU-2.5403)*QS*(1.+0.81*QS)) + ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN + ES=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=TU*PI*EXP((3114.834/TU-0.278296)*QS*(1.+0.81*QS)) + ELSE + ESLIQ=ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + ESICE=AICE*EXP((BICE*TU-CICE)/(TU-DICE)) + ES=(1.-RATIO2)*ESLIQ+RATIO2*ESICE + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=TU*PI*EXP(RL*QS*C5/TU*(1.+0.81*QS)) + ENDIF + F0=THTGS-THTU + T1=TU-0.5*F0 + T0=TU + ITCNT=0 + 90 IF(RATIO2.LT.1.E-6)THEN + ES=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=T1*PI*EXP((3374.6525/T1-2.5403)*QS*(1.+0.81*QS)) + ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN + ES=AICE*EXP((BICE*T1-CICE)/(T1-DICE)) + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=T1*PI*EXP((3114.834/T1-0.278296)*QS*(1.+0.81*QS)) + ELSE + ESLIQ=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) + ESICE=AICE*EXP((BICE*T1-CICE)/(T1-DICE)) + ES=(1.-RATIO2)*ESLIQ+RATIO2*ESICE + QS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*QS)) + THTGS=T1*PI*EXP(RL*QS*C5/T1*(1.+0.81*QS)) + ENDIF + F1=THTGS-THTU + IF(ABS(F1).LT.0.01)GOTO 50 + ITCNT=ITCNT+1 + IF(ITCNT.GT.10)GOTO 50 + DT=F1*(T1-T0)/(F1-F0) + T0=T1 + F0=F1 + T1=T1-DT + GOTO 90 +! +! IF THE PARCEL IS SUPERSATURATED, CALCULATE CONCENTRATION OF FRESH +! CONDENSATE... +! + 50 IF(QS.LE.QU)THEN + QNEW=QU-QS + QU=QS + GOTO 96 + ENDIF +! +! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE +! ADJUSTED...IF LIQUID WATER OR ICE IS PRESENT, IT IS ALLOWED TO EVAPO +! SUBLIMATE. +! + QNEW=0. + DQ=QS-QU + QTOT=QLIQ+QICE +! +! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS +! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MI +! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURA +! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPR +! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE +! +!...NOTE THAT THE LIQ AND ICE MAY BE PRESENT IN PROPORTIONS SLIGHTLY DIF +! THAN SUGGESTED BY THE VALUE OF RATIO2...CHECK TO MAKE SURE THAT LIQ +! ICE CONCENTRATIONS ARE NOT REDUCED TO BELOW ZERO WHEN EVAPORATION/ +! SUBLIMATION OCCURS... +! + IF(QTOT.GE.DQ)THEN + DQICE=0.0 + DQLIQ=0.0 + QLIQ=QLIQ-(1.-RATIO2)*DQ + IF(QLIQ.LT.0.)THEN + DQICE=0.0-QLIQ + QLIQ=0.0 + ENDIF + QICE=QICE-RATIO2*DQ+DQICE + IF(QICE.LT.0.)THEN + DQLIQ=0.0-QICE + QICE=0.0 + ENDIF + QLIQ=QLIQ+DQLIQ + QU=QS + GOTO 96 + ELSE + IF(RATIO2.LT.1.E-6)THEN + RLL=XLV0-XLV1*T1 + ELSEIF(ABS(RATIO2-1.).LT.1.E-6)THEN + RLL=XLS0-XLS1*T1 + ELSE + RLL=RL + ENDIF + CCP=1005.7*(1.+0.89*QU) + IF(QTOT.LT.1.E-10)THEN +! +!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: + T1=T1+RLL*(DQ/(1.+DQ))/CCP + GOTO 96 + ELSE +! +!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURA +! THE TEMPERATURE IS GIVEN BY: + T1=T1+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CCP + QU=QU+QTOT + QTOT=0. + ENDIF + QLIQ=0 + QICE=0. + ENDIF + 96 TU=T1 + QNEWLQ=(1.-RATIO2)*QNEW + QNEWIC=RATIO2*QNEW + IF(ITCNT.GT.10)PRINT*,'***** NUMBER OF ITERATIONS IN TPMIX =', & + ITCNT + + END SUBROUTINE TPMIX +!----------------------------------------------------------------------- + SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,R1,RL, & + EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P1,T1,Q1,R1,RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,& + BICE,CICE,DICE + REAL, INTENT(INOUT) :: THT1 + REAL:: T00,P00,C1,C2,C3,C4,C5,EE,TLOG,TDPT,TSAT,THT,TFPT,TLOGIC, & + TSATLQ,TSATIC + + DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834,& + 0.278296,1.0723E-3/ +! +! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... +! + + IF(R1.LT.1.E-6)THEN + EE=Q1*P1/(EP2+Q1) + TLOG=ALOG(EE/ALIQ) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) + ELSEIF(ABS(R1-1.).LT.1.E-6)THEN + EE=Q1*P1/(EP2+Q1) + TLOG=ALOG(EE/AICE) + TFPT=(CICE-DICE*TLOG)/(BICE-TLOG) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + TSAT=TFPT-(.182+1.13E-3*(TFPT-T00)-3.58E-4*(T1-T00))*(T1-TFPT) + THT1=THT*EXP((C3/TSAT-C4)*Q1*(1.+0.81*Q1)) + ELSE + EE=Q1*P1/(EP2+Q1) + TLOG=ALOG(EE/ALIQ) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLOGIC=ALOG(EE/AICE) + TFPT=(CICE-DICE*TLOGIC)/(BICE-TLOGIC) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + TSATLQ=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + TSATIC=TFPT-(.182+1.13E-3*(TFPT-T00)-3.58E-4*(T1-T00))*(T1-TFPT) + TSAT=R1*TSATIC+(1.-R1)*TSATLQ + THT1=THT*EXP(RL*Q1*C5/TSAT*(1.+0.81*Q1)) + ENDIF + + END SUBROUTINE ENVIRTHT + +!----------------------------------------------------------------------- +!************************* TPDD.FOR ************************************ +! THIS SUBROUTINE ITERATIVELY EXTRACTS TEMPERATURE FROM EQUIVALENT * +! POTENTIAL TEMP. IT IS DESIGNED FOR USE WITH DOWNDRAFT CALCULATIONS. +! IF RELATIVE HUMIDITY IS SPECIFIED TO BE LESS THAN 100%, PARCEL * +! TEMP, SPECIFIC HUMIDITY, AND LIQUID WATER CONTENT ARE ITERATIVELY * +! CALCULATED. * +!*********************************************************************** + FUNCTION TPDD(P,THTED,TGS,RS,RD,RH,XLV0,XLV1, & + EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: XLV0,XLV1 + REAL, INTENT(IN ) :: P,THTED,TGS,RD,RH,EP2,ALIQ,BLIQ, & + CLIQ,DLIQ,AICE,BICE,CICE,DICE + REAL, INTENT(INOUT) :: RS + REAL :: TPDD,ES,PI,THTGS,F0,T1,T0,CCP,F1,DT,RL,DSSDT,T1RH,RSRH + INTEGER :: ITCNT +!----------------------------------------------------------------------- + ES=ALIQ*EXP((BLIQ*TGS-CLIQ)/(TGS-DLIQ)) + RS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*RS)) + THTGS=TGS*PI*EXP((3374.6525/TGS-2.5403)*RS*(1.+0.81*RS)) + F0=THTGS-THTED + T1=TGS-0.5*F0 + T0=TGS + CCP=1005.7 +! +!...ITERATE TO FIND WET-BULB TEMPERATURE... +! + ITCNT=0 + 90 ES=ALIQ*EXP((BLIQ*T1-CLIQ)/(T1-DLIQ)) + RS=EP2*ES/(P-ES) + PI=(1.E5/P)**(0.2854*(1.-0.28*RS)) + THTGS=T1*PI*EXP((3374.6525/T1-2.5403)*RS*(1.+0.81*RS)) + F1=THTGS-THTED + IF(ABS(F1).LT.0.05)GOTO 50 + ITCNT=ITCNT+1 + IF(ITCNT.GT.10)GOTO 50 + DT=F1*(T1-T0)/(F1-F0) + T0=T1 + F0=F1 + T1=T1-DT + GOTO 90 + 50 RL=XLV0-XLV1*T1 +! +!...IF RELATIVE HUMIDITY IS SPECIFIED TO BE LESS THAN 100%, ESTIMATE THE +! TEMPERATURE AND MIXING RATIO WHICH WILL YIELD THE APPROPRIATE VALUE. +! + IF(RH.EQ.1.)GOTO 110 + DSSDT=(CLIQ-BLIQ*DLIQ)/((T1-DLIQ)*(T1-DLIQ)) + DT=RL*RS*(1.-RH)/(CCP+RL*RH*RS*DSSDT) + T1RH=T1+DT + ES=RH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) + RSRH=EP2*ES/(P-ES) +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(RSRH.LT.RD)THEN + RSRH=RD + T1RH=T1+(RS-RSRH)*RL/CCP + ENDIF + T1=T1RH + RS=RSRH + 110 TPDD=T1 + IF(ITCNT.GT.10)PRINT*,'***** NUMBER OF ITERATIONS IN TPDD = ', & + ITCNT + + END FUNCTION TPDD + +!==================================================================== + SUBROUTINE kfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + P_FIRST_SCALAR,restart,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart, allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA + + INTEGER :: i, j, k, itf, jtf, ktf + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QS .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQSCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=jts,jtf + DO i=its,itf + NCA(i,j)=-100. + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + W0AVG(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + ENDIF + + END SUBROUTINE kfinit + +!------------------------------------------------------- + +END MODULE module_cu_kf + diff --git a/wrfv2_fire/phys/module_cu_kfeta.F b/wrfv2_fire/phys/module_cu_kfeta.F new file mode 100644 index 00000000..8d663151 --- /dev/null +++ b/wrfv2_fire/phys/module_cu_kfeta.F @@ -0,0 +1,2861 @@ +MODULE module_cu_kfeta + + USE module_wrf_error + +!-------------------------------------------------------------------- +! Lookup table variables: + INTEGER, PARAMETER :: KFNT=250,KFNP=220 + REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB + REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K + REAL, DIMENSION(200),PRIVATE, SAVE :: ALU + REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP +! Note: KF Lookup table is used by subroutines KF_eta_PARA, TPMIX2, +! TPMIX2DD, ENVIRTHT +! End of Lookup table variables: + +CONTAINS + + SUBROUTINE KF_eta_CPS( & + ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,DT,KTAU,DX & + ,rho,RAINCV,NCA & + ,U,V,TH,T,W,dz8w,Pcps,pi & + ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 & + ,EP2,SVP1,SVP2,SVP3,SVPT0 & + ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & + ,QV & + ! optionals + ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & + ,RQICUTEN,RQSCUTEN & + ) +! +!------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------- + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: STEPCU + LOGICAL, INTENT(IN ) :: warm_rain + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1 + REAL, INTENT(IN ) :: CP,R,G,EP1,EP2 + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + + INTEGER, INTENT(IN ) :: KTAU + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + U, & + V, & + W, & + TH, & + T, & + QV, & + dz8w, & + Pcps, & + rho, & + pi +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + W0AVG + + REAL, INTENT(IN ) :: DT, DX +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP + + LOGICAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: CU_ACT_FLAG + +! +! Optional arguments +! + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, OPTIONAL :: & + F_QV & + ,F_QC & + ,F_QR & + ,F_QI & + ,F_QS + + +! LOCAL VARS + + LOGICAL :: flag_qr, flag_qi, flag_qs + + REAL, DIMENSION( kts:kte ) :: & + U1D, & + V1D, & + T1D, & + DZ1D, & + QV1D, & + P1D, & + RHO1D, & + W0AVG1D + + REAL, DIMENSION( kts:kte ):: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp,RTHCUMAX + + INTEGER :: i,j,k,NTST,ICLDCK +! + DXSQ=DX*DX + +!---------------------- + NTST=STEPCU + TST=float(NTST*2) + flag_qr = .FALSE. + flag_qi = .FALSE. + flag_qs = .FALSE. + IF ( PRESENT(F_QR) ) flag_qr = F_QR + IF ( PRESENT(F_QI) ) flag_qi = F_QI + IF ( PRESENT(F_QS) ) flag_qs = F_QS +! + DO J = jts,jte + DO K=kts,kte + DO I= its,ite +! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J)) +! TV=T(I,K,J)*(1.+EP1*QV(I,K,J)) +! RHOE=Pcps(I,K,J)/(R*TV) +! W0=-101.9368*SCR1/RHOE + W0=0.5*(w(I,K,J)+w(I,K+1,J)) + W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST + ENDDO + ENDDO + ENDDO +! +!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)... +! +!---------------------- + ICLDCK=MOD(KTAU,NTST) + IF(ICLDCK.EQ.0 .or. KTAU .eq. 1) then +! + DO J = jts,jte + DO I= its,ite + CU_ACT_FLAG(i,j) = .true. + ENDDO + ENDDO + + DO J = jts,jte + DO I=its,ite + + IF ( NINT(NCA(I,J)) .gt. 0 ) then + CU_ACT_FLAG(i,j) = .false. + ELSE + + DO k=kts,kte + DQDT(k)=0. + DQIDT(k)=0. + DQCDT(k)=0. + DQRDT(k)=0. + DQSDT(k)=0. + DTDT(k)=0. + ENDDO + RAINCV(I,J)=0. + CUTOP(I,J)=KTS + CUBOT(I,J)=KTE+1 +! +! assign vars from 3D to 1D + + DO K=kts,kte + U1D(K) =U(I,K,J) + V1D(K) =V(I,K,J) + T1D(K) =T(I,K,J) + RHO1D(K) =rho(I,K,J) + QV1D(K)=QV(I,K,J) + P1D(K) =Pcps(I,K,J) + W0AVG1D(K) =W0AVG(I,K,J) + DZ1D(k)=dz8w(I,K,J) + ENDDO + CALL KF_eta_PARA(I, J, & + U1D,V1D,T1D,QV1D,P1D,DZ1D, & + W0AVG1D,DT,DX,DXSQ,RHO1D, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,NCA,NTST, & + flag_QI,flag_QS,warm_rain, & + CUTOP,CUBOT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN + DO K=kts,kte + RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) +! RTHCUMAX=max(abs(RTHCUTEN(I,K,J)),RTHCUMAX) + RQVCUTEN(I,K,J)=DQDT(K) + ENDDO + ENDIF + + IF(PRESENT(rqrcuten).AND.PRESENT(rqccuten)) THEN + IF( F_QR )THEN + DO K=kts,kte + RQRCUTEN(I,K,J)=DQRDT(K) + RQCCUTEN(I,K,J)=DQCDT(K) + ENDDO + ELSE +! This is the case for Eta microphysics without 3d rain field + DO K=kts,kte + RQRCUTEN(I,K,J)=0. + RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K) + ENDDO + ENDIF + ENDIF + +!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) + + + IF(PRESENT( rqicuten )) THEN + IF ( F_QI ) THEN + DO K=kts,kte + RQICUTEN(I,K,J)=DQIDT(K) + ENDDO + ENDIF + ENDIF + + IF(PRESENT( rqscuten )) THEN + IF ( F_QS ) THEN + DO K=kts,kte + RQSCUTEN(I,K,J)=DQSDT(K) + ENDDO + ENDIF + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDIF +! + END SUBROUTINE KF_eta_CPS +! **************************************************************************** +!----------------------------------------------------------- + SUBROUTINE KF_eta_PARA (I, J, & + U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & + DT,DX,DXSQ,rhoe, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,NCA,NTST, & + F_QI,F_QS,warm_rain, & + CUTOP,CUBOT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +!----------------------------------------------------------- +!***** The KF scheme that is currently used in experimental runs of EMCs +!***** Eta model....jsk 8/00 +! + IMPLICIT NONE +!----------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + I,J,NTST + ! ,P_QI,P_QS,P_FIRST_SCALAR + + LOGICAL, INTENT(IN ) :: F_QI, F_QS + + LOGICAL, INTENT(IN ) :: warm_rain +! + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: U0, & + V0, & + T0, & + QV0, & + P0, & + rhoe, & + DZQ, & + W0AVG1D +! + REAL, INTENT(IN ) :: DT,DX,DXSQ +! + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + +! + REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP +! +!...DEFINE LOCAL VARIABLES... +! + REAL, DIMENSION( kts:kte ) :: & + Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & + QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & + UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & + UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & + THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & + QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & + DETLQ2,DETIC2,RATIO,RATIO2 + + + REAL, DIMENSION( kts:kte ) :: & + DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD, & + QDT,FXM,THTAG,THPA,THFXOUT, & + THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN, & + QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & + QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & + QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG + + + REAL, DIMENSION( kts:kte+1 ) :: OMG + REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB + REAL, DIMENSION( kts:kte ) :: & + CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG + +! LOCAL VARS + + REAL :: P00,T00,RLF,RHIC,RHBC,PIE, & + TTFRZ,TBFRZ,C5,RATE + REAL :: GDRY,ROCP,ALIQ,BLIQ, & + CLIQ,DLIQ + REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & + ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & + CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & + ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& + TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & + UPNEW,ABE,WKLCL,TTEMP,FRC1, & + QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& + DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & + THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & + UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & + THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, & + CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & + DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & + DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & + UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & + DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & + AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & + DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & + TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & + UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & + RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & + DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE + REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,& + QSS,PPTMLT,DTMELT,RHH,EVAC,BINC +! + INTEGER :: INDLU,NU,NUCHM,NNN,KLFS + REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP + REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP + + INTEGER :: KX,K,KL +! + INTEGER :: NCHECK + INTEGER, DIMENSION (kts:kte) :: KCHECK + + INTEGER :: ISTOP,ML,L5,KMIX,LOW, & + LC,MXLAYR,LLFC,NLAYRS,NK, & + KPBL,KLCL,LCL,LET,IFLAG, & + NK1,LTOP,NJ,LTOP1, & + LTOPM1,LVF,KSTART,KMIN,LFS, & + ND,NIC,LDB,LDT,ND1,NDK, & + NM,LMAX,NCOUNT,NOITR, & + NSTEP,NTC,NCHM,ISHALL,NSHALL + LOGICAL :: IPRNT + CHARACTER*1024 message +! + DATA P00,T00/1.E5,273.16/ + DATA RLF/3.339E5/ + DATA RHIC,RHBC/1.,0.90/ + DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ + DATA RATE/0.03/ +!----------------------------------------------------------- + IPRNT=.FALSE. + GDRY=-G/CP + ROCP=R/CP + NSHALL = 0 + KL=kte + KX=kte +! +! ALIQ = 613.3 +! BLIQ = 17.502 +! CLIQ = 4780.8 +! DLIQ = 32.19 + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 +! +! +!**************************************************************************** +! ! PPT FB MODS +!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS +!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS +!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS +!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS + FBFRC=0.0 ! PPT FB MODS +!...mods to allow shallow convection... + NCHM = 0 + ISHALL = 0 + DPMIN = 5.E3 +!... + P300=P0(1)-30000. +! +!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF +!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND +!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... +! +!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED +!...FROM BOTTOM-UP IN THE KF SCHEME... +! + ML=0 +!SUE tmprpsb=1./PSB(I,J) +!SUE CELL=PTOP*tmprpsb +! + DO K=1,KX +! +!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... +! + ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) + QES(K)=0.622*ES/(P0(K)-ES) + Q0(K)=AMIN1(QES(K),QV0(K)) + Q0(K)=AMAX1(0.000001,Q0(K)) + QL0(K)=0. + QI0(K)=0. + QR0(K)=0. + QS0(K)=0. + RH(K) = Q0(K)/QES(K) + DILFRC(K) = 1. + TV0(K)=T0(K)*(1.+0.608*Q0(K)) +! RHOE(K)=P0(K)/(R*TV0(K)) +! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... + DP(K)=rhoe(k)*g*DZQ(k) +! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme +! use it for shallow convection...For now, assume it is not available.... +! TKE(K) = Q2(I,J,NK) + TKE(K) = 0. + CLDHGT(K) = 0. +! IF(P0(K).GE.500E2)L5=K + IF(P0(K).GE.0.5*P0(1))L5=K + IF(P0(K).GE.P300)LLFC=K + IF(T0(K).GT.T00)ML=K + ENDDO +! +!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL + Z0(1)=.5*DZQ(1) +!cdir novector + DO K=2,KL + Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) + DZA(K-1)=Z0(K)-Z0(K-1) + ENDDO + DZA(KL)=0. +! +! +! To save time, specify a pressure interval to move up in sequential +! check of different ~50 mb deep groups of adjacent model layers in +! the process of identifying updraft source layer (USL). Note that +! this search is terminated as soon as a buoyant parcel is found and +! this parcel can produce a cloud greater than specifed minimum depth +! (CHMIN)...For now, set interval at 15 mb... +! + NCHECK = 1 + KCHECK(NCHECK)=1 + PM15 = P0(1)-15.E2 + DO K=2,LLFC + IF(P0(K).LT.PM15)THEN + NCHECK = NCHECK+1 + KCHECK(NCHECK) = K + PM15 = PM15-15.E2 + ENDIF + ENDDO +! + NU=0 + NUCHM=0 +usl: DO + NU = NU+1 + IF(NU.GT.NCHECK)THEN + IF(ISHALL.EQ.1)THEN + CHMAX = 0. + NCHM = 0 + DO NK = 1,NCHECK + NNN=KCHECK(NK) + IF(CLDHGT(NNN).GT.CHMAX)THEN + NCHM = NNN + NUCHM = NK + CHMAX = CLDHGT(NNN) + ENDIF + ENDDO + NU = NUCHM-1 + FBFRC=1. + CYCLE usl + ELSE + RETURN + ENDIF + ENDIF + KMIX = KCHECK(NU) + LOW=KMIX +!... + LC = LOW +! +!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF +!...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A +!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL +!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb.. +! + NLAYRS=0 + DPTHMX=0. + NK=LC-1 + IF ( NK+1 .LT. KTS ) THEN + WRITE(message,*)'WOULD GO OFF BOTTOM: KF_ETA_PARA I,J,NK',I,J,NK + CALL wrf_message (TRIM(message)) + ELSE + DO + NK=NK+1 + IF ( NK .GT. KTE ) THEN + WRITE(message,*)'WOULD GO OFF TOP: KF_ETA_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN + CALL wrf_message (TRIM(message)) + EXIT + ENDIF + DPTHMX=DPTHMX+DP(NK) + NLAYRS=NLAYRS+1 + IF(DPTHMX.GT.DPMIN)THEN + EXIT + ENDIF + END DO + ENDIF + IF(DPTHMX.LT.DPMIN)THEN + RETURN + ENDIF + KPBL=LC+NLAYRS-1 +! +!...******************************************************** +!...for computational simplicity without much loss in accuracy, +!...mix temperature instead of theta for evaluating convective +!...initiation (triggering) potential... +! THMIX=0. + TMIX=0. + QMIX=0. + ZMIX=0. + PMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! +!cdir novector + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*T0(NK) + QMIX=QMIX+DP(NK)*Q0(NK) + ZMIX=ZMIX+DP(NK)*Z0(NK) + PMIX=PMIX+DP(NK)*P0(NK) + ENDDO +! THMIX=THMIX/DPTHMX + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ZMIX=ZMIX/DPTHMX + PMIX=PMIX/DPTHMX + EMIX=QMIX*PMIX/(0.622+QMIX) +! +!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL... +! +! TLOG=ALOG(EMIX/ALIQ) +! ...calculate dewpoint using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=emix/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + NK = LC-1 + DO + NK = NK+1 + KLCL=NK + IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN + EXIT + ENDIF + ENDDO + IF(NK.GT.KL)THEN + RETURN + ENDIF + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=T0(K)+(T0(KLCL)-T0(K))*DLP + QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP + TVEN=TENV*(1.+0.608*QENV) +! +!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER +!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0 IS AN +!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL +!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION +!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE +!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST +!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, +!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID +!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... +! + IF(ZLCL.LT.2.E3)THEN + WKLCL=0.02*ZLCL/2.E3 + ELSE + WKLCL=0.02 + ENDIF + WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL + IF(WKL.LT.0.0001)THEN + DTLCL=0. + ELSE + DTLCL=4.64*WKL**0.33 + ENDIF +! +!...for ETA model, give parcel an extra temperature perturbation based +!...the threshold RH for condensation (U00)... +! +!...for now, just assume U00=0.75... +!...!!!!!! for MM5, SET DTRH = 0. !!!!!!!! +! U00 = 0.75 +! IF(U00.lt.1.)THEN +! QSLCL=QES(K)+(QES(KLCL)-QES(K))*DLP +! RHLCL = QENV/QSLCL +! DQSSDT = QMIX*(CLIQ-BLIQ*DLIQ)/((TLCL-DLIQ)*(TLCL-DLIQ)) +! IF(RHLCL.ge.0.75 .and. RHLCL.le.0.95)then +! DTRH = 0.25*(RHLCL-0.75)*QMIX/DQSSDT +! ELSEIF(RHLCL.GT.0.95)THEN +! DTRH = (1./RHLCL-1.)*QMIX/DQSSDT +! ELSE + DTRH = 0. +! ENDIF +! ENDIF +! IF(ISHALL.EQ.1)IPRNT=.TRUE. +! IPRNT=.TRUE. +! IF(TLCL+DTLCL.GT.TENV)GOTO 45 +! +trigger: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN +! +! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... +! + CYCLE usl +! + ELSE ! Parcel is buoyant, determine updraft +! +!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE +!...EQUIVALENT POTENTIAL TEMPERATURE +!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... +! + CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...modify calculation of initial parcel vertical velocity...jsk 11/26/97 +! + DTTOT = DTLCL+DTRH + IF(DTTOT.GT.1.E-4)THEN + GDT=2.*G*DTTOT*500./TVEN + WLCL=1.+0.5*SQRT(GDT) + WLCL = AMIN1(WLCL,3.) + ELSE + WLCL=1. + ENDIF + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + WTW=WLCL*WLCL +! + TVLCL=TLCL*(1.+0.608*QMIX) + RHOLCL=PLCL/(R*TVLCL) +! + LCL=KLCL + LET=LCL +! make RAD a function of background vertical velocity... + IF(WKL.LT.0.)THEN + RAD = 1000. + ELSEIF(WKL.GT.0.1)THEN + RAD = 2000. + ELSE + RAD = 1000.+1000*WKL/0.1 + ENDIF +! +!******************************************************************* +! * +! COMPUTE UPDRAFT PROPERTIES * +! * +!******************************************************************* +! +! +!... +!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... +! + WU(K)=WLCL + AU0=0.01*DXSQ + UMF(K)=RHOLCL*AU0 + VMFLCL=UMF(K) + UPOLD=VMFLCL + UPNEW=UPOLD +! +!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), +!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE +!...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION +!...PRODUCTION... +! + RATIO2(K)=0. + UER(K)=0. + ABE=0. + TRPPT=0. + TU(K)=TLCL + TVU(K)=TVLCL + QU(K)=QMIX + EQFRC(K)=1. + QLIQ(K)=0. + QICE(K)=0. + QLQOUT(K)=0. + QICOUT(K)=0. + DETLQ(K)=0. + DETIC(K)=0. + PPTLIQ(K)=0. + PPTICE(K)=0. + IFLAG=0 +! +!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION +!...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH +!...FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION +!...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE +!...PREVIOUS MODEL LEVEL... +! + TTEMP=TTFRZ +! +!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, +!...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND +!...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... +! +! + EE1=1. + UD1=0. + REI = 0. + DILBE = 0. +updraft: DO NK=K,KL-1 + NK1=NK+1 + RATIO2(NK1)=RATIO2(NK) + FRC1=0. + TU(NK1)=T0(NK1) + THETEU(NK1)=THETEU(NK) + QU(NK1)=QU(NK) + QLIQ(NK1)=QLIQ(NK) + QICE(NK1)=QICE(NK) + call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), & + qice(nk1),qnewlq,qnewic,XLV1,XLV0) +! +! +!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH +!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE +!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE +!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL +!...LIQUID WATER IS FROZEN AT EACH LEVEL... +! + IF(TU(NK1).LE.TTFRZ)THEN + IF(TU(NK1).GT.TBFRZ)THEN + IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ + FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) + ELSE + FRC1=1. + IFLAG=1 + ENDIF + TTEMP=TU(NK1) +! +! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE +!...IS BELOW TTFRZ... +! + QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1 + QNEWIC=QNEWIC+QNEWLQ*FRC1 + QNEWLQ=QNEWLQ-QNEWLQ*FRC1 + QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1 + QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1 + CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, & + QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + ENDIF + TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) +! +! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... +! + IF(NK.EQ.K)THEN + BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. + BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 + DZZ=Z0(NK1)-ZLCL + ELSE + BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. + BOTERM=2.*DZA(NK)*G*BE/1.5 + DZZ=DZA(NK) + ENDIF + ENTERM=2.*REI*WTW/UPOLD + + CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & + RATE,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) +! +!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, +!...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... +! + IF(WTW.LT.1.E-3)THEN + EXIT + ELSE + WU(NK1)=SQRT(WTW) + ENDIF +!...Calculate value of THETA-E in environment to entrain into updraft... +! + CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... +! + REI=VMFLCL*DP(NK1)*0.03/RAD + TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ + ELSE + DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABE=ABE+DILBE*G +! +!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL +!...ENTRAINMENT (0.5*REI) IS IMPOSED... +! + IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK + EE2=0.5 + UD2=1. + EQFRC(NK1)=0. + ELSE + LET=NK1 + TTMP=TVQU(NK1) +! +!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR... +! + F1=0.95 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU95.GT.TV0(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + F1=0.10 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + TVDIFF = ABS(TU10-TVQU(NK1)) + IF(TVDIFF.LT.1.e-3)THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) + EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) + EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) + IF(EQFRC(NK1).EQ.1)THEN + EE2=1. + UD2=0. + ELSEIF(EQFRC(NK1).EQ.0.)THEN + EE2=0. + UD2=1. + ELSE +! +!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE +! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... +! + CALL PROF5(EQFRC(NK1),EE2,UD2) + ENDIF + ENDIF + ENDIF + ENDIF ! End of Entrain/Detrain IF BLOCK +! +! +!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL +! VALUES IN THE LAYER... +! + EE2 = AMAX1(EE2,0.5) + UD2 = 1.5*UD2 + UER(NK1)=0.5*REI*(EE1+EE2) + UDR(NK1)=0.5*REI*(UD1+UD2) +! +!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL +! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS... +! + IF(UMF(NK)-UDR(NK1).LT.10.)THEN +! +!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS +! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL.. +! First, correct ABE calculation if needed... +! + IF(DILBE.GT.0.)THEN + ABE=ABE-DILBE*G + ENDIF + LET=NK +! WRITE(98,1015)P0(NK1)/100. + EXIT + ELSE + EE1=EE2 + UD1=UD2 + UPOLD=UMF(NK)-UDR(NK1) + UPNEW=UPOLD+UER(NK1) + UMF(NK1)=UPNEW + DILFRC(NK1) = UPNEW/UPOLD +! +!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND +!...ICE IN THE DETRAINING UPDRAFT MASS... +! + DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) + DETIC(NK1)=QICE(NK1)*UDR(NK1) + QDT(NK1)=QU(NK1) + QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW + THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW + QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW + QICE(NK1)=QICE(NK1)*UPOLD/UPNEW +! +!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF +!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE, +!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE +!...CURRENT MODEL LEVEL... +! + PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK) + PPTICE(NK1)=QICOUT(NK1)*UMF(NK) +! + TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) + IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + ENDIF +! + END DO updraft +! +!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU +! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO +! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BE +! THE LET AND CLOUD TOP... +! +!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOC +! FIRST BECOMES NEGATIVE... +! + LTOP=NK + CLDHGT(LC)=Z0(LTOP)-ZLCL +! +!...Instead of using the same minimum cloud height (for deep convection) +!...everywhere, try specifying minimum cloud depth as a function of TLCL... +! +! +! + IF(TLCL.GT.293.)THEN + CHMIN = 4.E3 + ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN + CHMIN = 2.E3 + 100.*(TLCL-273.) + ELSEIF(TLCL.LT.273.)THEN + CHMIN = 2.E3 + ENDIF + +! +!...If cloud top height is less than the specified minimum for deep +!...convection, save value to consider this level as source for +!...shallow convection, go back up to check next level... +! +!...Try specifying minimum cloud depth as a function of TLCL... +! +! +!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF: +! +!... 1.) if there is no CAPE, or +!... 2.) cloud top is at model level just above LCL, or +!... 3.) cloud top is within updraft source layer, or +!... 4.) cloud-top detrainment layer begins within +!... updraft source layer. +! + IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL)THEN ! No Convection Allowed + CLDHGT(LC)=0. + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO +! + ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed + ISHALL=0 + EXIT usl + ELSE +! +!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!! + ISHALL = 1 + IF(NU.EQ.NUCHM)THEN + EXIT usl ! Shallow Convection from this layer + ELSE +! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO + ENDIF + ENDIF + ENDIF trigger + END DO usl + IF(ISHALL.EQ.1)THEN + KSTART=MAX0(KPBL,KLCL) + LET=KSTART + endif +! +!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL +! THIS LEVEL... +! + IF(LET.EQ.LTOP)THEN + UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) + DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD + DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD + UER(LTOP)=0. + UMF(LTOP)=0. + ELSE +! +! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... +! + DPTT=0. + DO NJ=LET+1,LTOP + DPTT=DPTT+DP(NJ) + ENDDO + DUMFDP=UMF(LET)/DPTT +! +!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL +! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND +! + DO NK=LET+1,LTOP +! +!...entrainment is allowed at every level except for LTOP, so disallow +!...entrainment at LTOP and adjust entrainment rates between LET and LTOP +!...so the the dilution factor due to entyrianment is not changed but +!...the actual entrainment rate will change due due forced total +!...detrainment in this layer... +! + IF(NK.EQ.LTOP)THEN + UDR(NK) = UMF(NK-1) + UER(NK) = 0. + DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK) + ELSE + UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP + UER(NK)=UMF(NK)*(1.-1./DILFRC(NK)) + UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK) + DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK) + ENDIF + IF(NK.GE.LET+2)THEN + TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) + PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK) + PPTICE(NK)=UMF(NK-1)*QICOUT(NK) + TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) + ENDIF + ENDDO + ENDIF +! +! Initialize some arrays below cloud base and above cloud top... +! + DO NK=1,K + IF(NK.GE.LC)THEN + IF(NK.EQ.LC)THEN + UMF(NK)=VMFLCL*DP(NK)/DPTHMX + UER(NK)=VMFLCL*DP(NK)/DPTHMX + ELSEIF(NK.LE.KPBL)THEN + UER(NK)=VMFLCL*DP(NK)/DPTHMX + UMF(NK)=UMF(NK-1)+UER(NK) + ELSE + UMF(NK)=VMFLCL + UER(NK)=0. + ENDIF + TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY + QU(NK)=QMIX + WU(NK)=WLCL + ELSE + TU(NK)=0. + QU(NK)=0. + UMF(NK)=0. + WU(NK)=0. + UER(NK)=0. + ENDIF + UDR(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + RATIO2(NK)=0. + CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ) + EQFRC(NK)=1.0 + ENDDO +! + LTOP1=LTOP+1 + LTOPM1=LTOP-1 +! +!...DEFINE VARIABLES ABOVE CLOUD TOP... +! + DO NK=LTOP1,KX + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + IF(NK.GT.LTOP1)THEN + TU(NK)=0. + QU(NK)=0. + WU(NK)=0. + ENDIF + THTA0(NK)=0. + THTAU(NK)=0. + EMS(NK)=0. + EMSD(NK)=0. + TG(NK)=T0(NK) + QG(NK)=Q0(NK) + QLG(NK)=0. + QIG(NK)=0. + QRG(NK)=0. + QSG(NK)=0. + OMG(NK)=0. + ENDDO + OMG(KX+1)=0. + DO NK=1,LTOP + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) +! +!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCH +! + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) + THTAU(NK)=TU(NK)*EXN(NK) + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THTA0(NK)=T0(NK)*EXN(NK) + DDILFRC(NK) = 1./DILFRC(NK) + OMG(NK)=0. + ENDDO +! IF (XTIME.LT.10.)THEN +! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, +! * TMIX-T00,PMIX,QMIX,ABE +! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., +! * WLCL,CLDHGT +! ENDIF +! +!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL +!...AND MIDTROPOSPHERE IS USED. +! + WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) + WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) + WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) + VCONV=.5*(WSPD(KLCL)+WSPD(L5)) +!...for ETA model, DX is a function of location... +! TIMEC=DX(I,J)/VCONV + TIMEC=DX/VCONV + TADVEC=TIMEC + TIMEC=AMAX1(1800.,TIMEC) + TIMEC=AMIN1(3600.,TIMEC) + IF(ISHALL.EQ.1)TIMEC=2400. + NIC=NINT(TIMEC/DT) + TIMEC=FLOAT(NIC)*DT +! +!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. +! + IF(WSPD(LTOP).GT.WSPD(KLCL))THEN + SHSIGN=1. + ELSE + SHSIGN=-1. + ENDIF + VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & + (V0(LTOP)-V0(KLCL)) + VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) + PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) + PEF=AMAX1(PEF,.2) + PEF=AMIN1(PEF,.9) +! +!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. +! + CBH=(ZLCL-Z0(1))*3.281E-3 + IF(CBH.LT.3.)THEN + RCBH=.02 + ELSE + RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & + 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) + ENDIF + IF(CBH.GT.25)RCBH=2.4 + PEFCBH=1./(1.+RCBH) + PEFCBH=AMIN1(PEFCBH,.9) +! +!... MEAN PEF. IS USED TO COMPUTE RAINFALL. +! + PEFF=.5*(PEF+PEFCBH) + PEFF2 = PEFF ! JSK MODS + IF(IPRNT)THEN + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +! call flush(98) + endif +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +!***************************************************************** +! * +! COMPUTE DOWNDRAFT PROPERTIES * +! * +!***************************************************************** +! +! + TDER=0. + devap:IF(ISHALL.EQ.1)THEN + LFS = 1 + ELSE +! +!...start downdraft about 150 mb above cloud base... +! +! KSTART=MAX0(KPBL,KLCL) +! KSTART=KPBL ! Changed 7/23/99 + KSTART=KPBL+1 ! Changed 7/23/99 + KLFS = LET-1 + DO NK = KSTART+1,KL + DPPP = P0(KSTART)-P0(NK) +! IF(DPPP.GT.200.E2)THEN + IF(DPPP.GT.150.E2)THEN + KLFS = NK + EXIT + ENDIF + ENDDO + KLFS = MIN0(KLFS,LET-1) + LFS = KLFS +! +!...if LFS is not at least 50 mb above cloud base (implying that the +!...level of equil temp, LET, is just above cloud base) do not allow a +!...downdraft... +! + IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN + THETED(LFS) = THETEE(LFS) + QD(LFS) = Q0(LFS) +! +!...call tpmix2dd to find wet-bulb temp, qv... +! + call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j) + THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS)) +! +!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX... +! + TVD(LFS)=TZ(LFS)*(1.+0.608*QSS) + RDD=P0(LFS)/(R*TVD(LFS)) + A1=(1.-PEFF)*AU0 + DMF(LFS)=-A1*RDD + DER(LFS)=DMF(LFS) + DDR(LFS)=0. + RHBAR = RH(LFS)*DP(LFS) + DPTT = DP(LFS) + DO ND = LFS-1,KSTART,-1 + ND1 = ND+1 + DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS) + DDR(ND)=0. + DMF(ND)=DMF(ND1)+DER(ND) + THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) + QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) + DPTT = DPTT+DP(ND) + RHBAR = RHBAR+RH(ND)*DP(ND) + ENDDO + RHBAR = RHBAR/DPTT + DMFFRC = 2.*(1.-RHBAR) + DPDD = 0. +!...Calculate melting effect +!... first, compute total frozen precipitation generated... +! + pptmlt = 0. + DO NK = KLCL,LTOP + PPTMLT = PPTMLT+PPTICE(NK) + ENDDO + if(lc.lt.ml)then +!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as +!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large! +!...12/14/98 jsk... + DTMELT = RLF*PPTMLT/(CP*UMF(KLCL)) + else + DTMELT = 0. + endif + LDT = MIN0(LFS-1,KSTART-1) +! + call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j) +! + tz(kstart) = tz(kstart)-dtmelt + ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ)) + QSS=0.622*ES/(P0(KSTART)-ES) + THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* & + EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS)) +!.... + LDT = MIN0(LFS-1,KSTART-1) + DO ND = LDT,1,-1 + DPDD = DPDD+DP(ND) + THETED(ND) = THETED(KSTART) + QD(ND) = QD(KSTART) +! +!...call tpmix2dd to find wet bulb temp, saturation mixing ratio... +! + call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j) + qsd(nd) = qss +! +!...specify RH decrease of 20%/km in downdraft... +! + RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND)) +! +!...adjust downdraft TEMP, Q to specified RH: +! + IF(RHH.LT.1.)THEN + DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) + RL=XLV0-XLV1*TZ(ND) + DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT) + T1RH=TZ(ND)+DTMP + ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) + QSRH=0.622*ES/(P0(ND)-ES) +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(QSRH.LT.QD(ND))THEN + QSRH=QD(ND) + T1RH=TZ(ND)+(QSS-QSRH)*RL/CP + ENDIF + TZ(ND)=T1RH + QSS=QSRH + QSD(ND) = QSS + ENDIF + TVD(nd) = tz(nd)*(1.+0.608*qsd(nd)) + IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN + LDB=ND + EXIT + ENDIF + ENDDO + IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth! + DO ND=LDT,LDB,-1 + ND1 = ND+1 + DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD + DER(ND) = 0. + DMF(ND) = DMF(ND1)+DDR(ND) + TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND) + QD(ND)=QSD(nd) + THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) + ENDDO + ENDIF + ENDIF + ENDIF devap +! +!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE +!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... +! +d_mf: IF(TDER.LT.1.)THEN +! WRITE(98,3004)I,J +!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2) + PPTFLX=TRPPT + CPR=TRPPT + TDER=0. + CNDTNF=0. + UPDINC=1. + LDB=LFS + DO NDK=1,LTOP + DMF(NDK)=0. + DER(NDK)=0. + DDR(NDK)=0. + THTAD(NDK)=0. + WD(NDK)=0. + TZ(NDK)=0. + QD(NDK)=0. + ENDDO + AINCM2=100. + ELSE + DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART) + UPDINC=1. + IF(TDER*DDINC.GT.TRPPT)THEN + DDINC = TRPPT/TDER + ENDIF + TDER = TDER*DDINC + DO NK=LDB,LFS + DMF(NK)=DMF(NK)*DDINC + DER(NK)=DER(NK)*DDINC + DDR(NK)=DDR(NK)*DDINC + ENDDO + CPR=TRPPT + PPTFLX = TRPPT-TDER + PEFF=PPTFLX/TRPPT + IF(IPRNT)THEN + write(98,*)'PRECIP EFFICIENCY =',PEFF +! call flush(98) + ENDIF +! +! +!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN +! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE +! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... +! +! DO NK=LC,LFS +! UMF(NK)=UMF(NK)*UPDINC +! UDR(NK)=UDR(NK)*UPDINC +! UER(NK)=UER(NK)*UPDINC +! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC +! PPTICE(NK)=PPTICE(NK)*UPDINC +! DETLQ(NK)=DETLQ(NK)*UPDINC +! DETIC(NK)=DETIC(NK)*UPDINC +! ENDDO +! +!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE +!...DOWNDRAFT... +! + IF(LDB.GT.1)THEN + DO NK=1,LDB-1 + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF + DO NK=LFS+1,KX + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + DO NK=LDT+1,LFS-1 + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF d_mf +! +!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFL +! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILAB +! IN THAT LAYER INITIALLY... +! + AINCMX=1000. + LMAX=MAX0(KLCL,LFS) + DO NK=LC,LMAX + IF((UER(NK)-DER(NK)).GT.1.e-3)THEN + AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC) + AINCMX=AMIN1(AINCMX,AINCM1) + ENDIF + ENDDO + AINC=1. + IF(AINCMX.LT.AINC)AINC=AINCMX +! +!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL +!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION +!...CLOSURE... +! + TDER2=TDER + PPTFL2=PPTFLX + DO NK=1,LTOP + DETLQ2(NK)=DETLQ(NK) + DETIC2(NK)=DETIC(NK) + UDR2(NK)=UDR(NK) + UER2(NK)=UER(NK) + DDR2(NK)=DDR(NK) + DER2(NK)=DER(NK) + UMF2(NK)=UMF(NK) + DMF2(NK)=DMF(NK) + ENDDO + FABE=1. + STAB=0.95 + NOITR=0 + ISTOP=0 +! + IF(ISHALL.EQ.1)THEN ! First for shallow convection +! +! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available +! from a turbulence parameterization, scale cloud-base updraft mass flux as a function +! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5... +! +!...find the maximum TKE value between LC and KLCL... +! TKEMAX = 0. + TKEMAX = 5. +! DO 173 K = LC,KLCL +! NK = KX-K+1 +! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK)) +! 173 CONTINUE +! TKEMAX = AMIN1(TKEMAX,10.) +! TKEMAX = AMAX1(TKEMAX,5.) +!c TKEMAX = 10. +!c...3_24_99...DPMIN was changed for shallow convection so that it is the +!c... the same as for deep convection (5.E3). Since this doubles +!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu- +!c... lation of EVAC... +!c EVAC = TKEMAX*0.1 + EVAC = 0.5*TKEMAX*0.1 +! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC) +! AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC) + AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO + ENDIF ! Otherwise for deep convection +! use iterative procedure to find mass fluxes... +iter: DO NCOUNT=1,10 +! +!***************************************************************** +! * +! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * +! * +!***************************************************************** +! +!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO +!...SATISFY MASS CONTINUITY... +! + DTT=TIMEC + DO NK=1,LTOP + DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) + IF(NK.GT.1)THEN + OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) + ABSOMG = ABS(OMG(NK)) + ABSOMGTC = ABSOMG*TIMEC + FRDP = 0.75*DP(NK-1) + IF(ABSOMGTC.GT.FRDP)THEN + DTT1 = FRDP/ABSOMG + DTT=AMIN1(DTT,DTT1) + ENDIF + ENDIF + ENDDO + DO NK=1,LTOP + THPA(NK)=THTA0(NK) + QPA(NK)=Q0(NK) + NSTEP=NINT(TIMEC/DTT+1) + DTIME=TIMEC/FLOAT(NSTEP) + FXM(NK)=OMG(NK)*DXSQ/G + ENDDO +! +!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... +! + DO NTC=1,NSTEP +! +!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED +!...SIGN OF OMEGA... +! + DO NK=1,LTOP + THFXIN(NK)=0. + THFXOUT(NK)=0. + QFXIN(NK)=0. + QFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + THFXIN(NK)=-FXM(NK)*THPA(NK-1) + QFXIN(NK)=-FXM(NK)*QPA(NK-1) + THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK) + QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK) + ELSE + THFXOUT(NK)=FXM(NK)*THPA(NK) + QFXOUT(NK)=FXM(NK)*QPA(NK) + THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK) + QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & + THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & + DTIME*EMSD(NK) + QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- & + QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) + ENDDO + ENDDO + DO NK=1,LTOP + THTAG(NK)=THPA(NK) + QG(NK)=QPA(NK) + ENDDO +! +!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORRO +!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO... +! + DO NK=1,LTOP + IF(QG(NK).LT.0.)THEN + IF(NK.EQ.1)THEN ! JSK MODS +! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS +! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS + CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS + ENDIF ! JSK MODS + NK1=NK+1 + IF(NK.EQ.LTOP)THEN + NK1=KLCL + ENDIF + TMA=QG(NK1)*EMS(NK1) + TMB=QG(NK-1)*EMS(NK-1) + TMM=(QG(NK)-1.E-9)*EMS(NK ) + BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) + ACOEFF=BCOEFF*TMA/TMB + TMB=TMB*(1.-BCOEFF) + TMA=TMA*(1.-ACOEFF) + IF(NK.EQ.LTOP)THEN + QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) +! IF(ABS(QVDIFF).GT.1.)THEN +! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', & +! QVDIFF, & +! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', & +! 'VALUES IN KAIN-FRITSCH' +! ENDIF + ENDIF + QG(NK)=1.E-9 + QG(NK1)=TMA*EMSD(NK1) + QG(NK-1)=TMB*EMSD(NK-1) + ENDIF + ENDDO + TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) + IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN +! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; & +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) + ISTOP=1 + IPRNT=.TRUE. + EXIT iter + ENDIF +! +!...CONVERT THETA TO T... +! + DO NK=1,LTOP + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) + TG(NK)=THTAG(NK)/EXN(NK) + TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) + ENDDO + IF(ISHALL.EQ.1)THEN + EXIT iter + ENDIF +! +!******************************************************************* +! * +! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * +! * +!******************************************************************* +! +!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT +! +! THMIX=0. + TMIX=0. + QMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*TG(NK) + QMIX=QMIX+DP(NK)*QG(NK) + ENDDO + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) + QSS=0.622*ES/(PMIX-ES) +! +!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... +! + IF(QMIX.GT.QSS)THEN + RL=XLV0-XLV1*TMIX + CPM=CP*(1.+0.887*QMIX) + DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) + DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM) + TMIX=TMIX+RL/CP*DQ + QMIX=QMIX-DQ + TLCL=TMIX + ELSE + QMIX=AMAX1(QMIX,0.) + EMIX=QMIX*PMIX/(0.622+QMIX) + astrt=1.e-3 + binc=0.075 + a1=emix/aliq + tp=(a1-astrt)/binc + indlu=int(tp)+1 + value=(indlu-1)*binc+astrt + aintrp=(a1-value)/binc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + ENDIF + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + DO NK = LC,KL + KLCL=NK + IF(ZLCL.LE.Z0(NK))THEN + EXIT + ENDIF + ENDDO + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=TG(K)+(TG(KLCL)-TG(K))*DLP + QENV=QG(K)+(QG(KLCL)-QG(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) +! +!...COMPUTE ADJUSTED ABE(ABEG). +! + ABEG=0. + DO NK=K,LTOPM1 + NK1=NK+1 + THETEU(NK1) = THETEU(NK) +! + call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j) +! + TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DZZ=Z0(KLCL)-ZLCL + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ + ELSE + DZZ=DZA(NK) + DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G +! +!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT... +! + CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1)) + ENDDO +! +!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING +!...THE PERIOD TIMEC... +! + IF(NOITR.EQ.1)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT iter + ENDIF + DABE=AMAX1(ABE-ABEG,0.1*ABE) + FABE=ABEG/ABE + IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN +! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS +! *GRID POINT; NO CONVECTION ALLOWED!' + RETURN + ENDIF + IF(NCOUNT.NE.1)THEN + IF(ABS(AINC-AINCOLD).LT.0.0001)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) + IF(DFDA.GT.0.)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + ENDIF + AINCOLD=AINC + FABEOLD=FABE + IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1055)FABE +! GOTO 265 + EXIT + ENDIF + IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN + EXIT iter + ELSE + IF(NCOUNT.GT.10)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT + ENDIF +! +!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTI +!...MASS FLUX BY THE FACTOR AINC: +! + IF(FABE.EQ.0.)THEN + AINC=AINC*0.5 + ELSE + IF(DABE.LT.1.e-4)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ELSE + AINC=AINC*STAB*ABE/DABE + ENDIF + ENDIF +! AINC=AMIN1(AINCMX,AINC) + AINC=AMIN1(AINCMX,AINC) +!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS +!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS + IF(AINC.LT.0.05)then + RETURN ! JSK MODS + ENDIF +! AINC=AMAX1(AINC,0.05) ! JSK MODS + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT, +! * FABEOLD,AINCOLD +! ENDIF + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO +! +!...GO BACK UP FOR ANOTHER ITERATION... +! + ENDIF + ENDDO iter +! +!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... +! +!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS +!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS +! +! Redistribute hydormeteors according to the final mass-flux values: +! + IF(CPR.GT.0.)THEN + FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS + ELSE + FRC2=0. + ENDIF + DO NK=1,LTOP + QLPA(NK)=QL0(NK) + QIPA(NK)=QI0(NK) + QRPA(NK)=QR0(NK) + QSPA(NK)=QS0(NK) + RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + ENDDO + DO NTC=1,NSTEP +! +!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAY +!...BASED ON THE SIGN OF OMEGA... +! + DO NK=1,LTOP + QLFXIN(NK)=0. + QLFXOUT(NK)=0. + QIFXIN(NK)=0. + QIFXOUT(NK)=0. + QRFXIN(NK)=0. + QRFXOUT(NK)=0. + QSFXIN(NK)=0. + QSFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) + QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) + QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) + QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) + QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) + QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) + QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) + QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) + ELSE + QLFXOUT(NK)=FXM(NK)*QLPA(NK) + QIFXOUT(NK)=FXM(NK)*QIPA(NK) + QRFXOUT(NK)=FXM(NK)*QRPA(NK) + QSFXOUT(NK)=FXM(NK)*QSPA(NK) + QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) + QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) + QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) + QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK) + QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK) + QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + ENDDO + ENDDO + DO NK=1,LTOP + QLG(NK)=QLPA(NK) + QIG(NK)=QIPA(NK) + QRG(NK)=QRPA(NK) + QSG(NK)=QSPA(NK) + ENDDO +! +!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS +!...GRID POINT... +! +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF + IF(IPRNT)THEN + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! call flush(98) + endif +! +!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... +! +!297 IF(IPRNT)then + IF(IPRNT)then +! if(I.eq.16 .and. J.eq.41)then +! IF(ISTOP.EQ.1)THEN + write(98,*) +! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J + write(98,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., & + TLCL+DTLCL+dtrh-TENV,WKL,WKLCL + write(98,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, & + DTRH,TENV + WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, & + TMIX-T00,PMIX,QMIX,ABE + WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., & + WLCL,CLDHGT(LC) + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS + write(98,*)'PRECIP EFFICIENCY =',PEFF + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF +!!!!! HERE !!!!!!! + WRITE(98,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & + ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & + ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' + write(98,*)'just before DO 300...' +! call flush(98) + DO NK=1,LTOP + K=LTOP-NK+1 + DTT=(TG(K)-T0(K))*86400./TIMEC + RL=XLV0-XLV1*TG(K) + DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) + UDFRC=UDR(K)*TIMEC*EMSD(K) + UEFRC=UER(K)*TIMEC*EMSD(K) + DDFRC=DDR(K)*TIMEC*EMSD(K) + DEFRC=-DER(K)*TIMEC*EMSD(K) + WRITE(98,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, & + UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, & + W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* & + TIMEC*EMSD(K)*1.E3 + ENDDO + WRITE(98,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & + 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' + DO NK=1,KL + K=KX-NK+1 + DTT=TG(K)-T0(K) + TUC=TU(K)-T00 + IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. + TDC=TZ(K)-T00 + IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. + IF(T0(K).LT.T00)THEN + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ELSE + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ENDIF + QGS=ES*0.622/(P0(K)-ES) + RH0=Q0(K)/QES(K) + RHG=QG(K)/QGS + WRITE(98,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, & + TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* & + 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., & + QSG(K)*1000.,RH0,RHG + ENDDO +! +!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A +!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... +! +! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN + +! IF(ISHALL.NE.1)THEN +! write(98,4421)i,j,iyr,imo,idy,ihr,imn +! write(98)i,j,iyr,imo,idy,ihr,imn,kl +! 4421 format(7i4) +! write(98,4422)kl +! 4422 format(i6) + DO 310 NK = 1,KL + k = kl - nk + 1 + write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & + u0(k),v0(k),W0AVG1D(K),dp(k),tke(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., +! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K) + 310 CONTINUE + IF(ISTOP.EQ.1)THEN + CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' ) + ENDIF +! ENDIF + 4455 format(8f11.3) + ENDIF + CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC + +! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF +! +! EVALUATE MOISTURE BUDGET... +! + + QINIT=0. + QFNL=0. + DPT=0. + DO 315 NK=1,LTOP + DPT=DPT+DP(NK) + QINIT=QINIT+Q0(NK)*EMS(NK) + QFNL=QFNL+QG(NK)*EMS(NK) + QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) + 315 CONTINUE + QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS +! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS + ERR2=(QFNL-QINIT)*100./QINIT + IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2 + IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN +! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!' +! WRITE(99,1110)QINIT,QFNL,ERR2 + IPRNT=.TRUE. + ISTOP=1 + write(98,4422)kl + 4422 format(i6) + DO 311 NK = 1,KL + k = kl - nk + 1 +! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & +! u0(k),v0(k),W0AVG1D(K),dp(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & +! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & + U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + 311 CONTINUE +! call flush(98) + +! GOTO 297 +! STOP 'QVERR' + ENDIF + 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) + 4456 format(8f12.3) + IF(PPTFLX.GT.0.)THEN + RELERR=ERR2*QINIT/(PPTFLX*TIMEC) + ELSE + RELERR=0. + ENDIF + IF(IPRNT)THEN + WRITE(98,1120)RELERR + WRITE(98,*)'TDER, CPR, TRPPT =', & + TDER,CPR*AINC,TRPPT*AINC + ENDIF +! +!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. +! +!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM +!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... +! + IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) + NCA(I,J)=FLOAT(NIC) + IF(ISHALL.EQ.1)THEN + TIMEC = 2400. + NCA(I,J) = FLOAT(NTST) + NSHALL = NSHALL+1 + ENDIF + DO K=1,KX +! IF(IMOIST(INEST).NE.2)THEN +! +!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT +!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. +!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND +!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE +!...OF QG... +! +! RLC=XLV0-XLV1*TG(K) +! RLS=XLS0-XLS1*TG(K) +! CPM=CP*(1.+0.887*QG(K)) +! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM +! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) +! DQLDT(I,J,NK)=0. +! DQIDT(I,J,NK)=0. +! DQRDT(I,J,NK)=0. +! DQSDT(I,J,NK)=0. +! ELSE +! +!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... +! + IF(.NOT. F_QI .and. warm_rain)THEN + + CPM=CP*(1.+0.887*QG(K)) + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN +! +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME +!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL +! + CPM=CP*(1.+0.887*QG(K)) + IF(K.LE.ML)THEN + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + ELSEIF(K.GT.ML)THEN + TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM + ENDIF + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(F_QI) THEN +! +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN +!...OF HYDROMETEORS DIRECTLY... +! + DQCDT(K)=(QLG(K)-QL0(K))/TIMEC + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQRDT(K)=(QRG(K)-QR0(K))/TIMEC + IF (F_QS) THEN + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + ELSE + DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + ENDIF + ELSE +! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + ENDIF + DTDT(K)=(TG(K)-T0(K))/TIMEC + DQDT(K)=(QG(K)-Q0(K))/TIMEC + ENDDO + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm') +! write (98,909)I,J,RNC +! write (6,909)I,J,RNC +! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', +! * NCCNT +! call flush(98) +1000 FORMAT(' ',10A8) +1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) +1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') +1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') +1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & + ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & + I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & + ' CAPE=',0PF7.1) +1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & + E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & + F8.1) +1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & + ,F6.3,'VWS=',F5.2) +!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, & +! ', NO MORE MASS FLUX IS ALLOWED!') +!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED & +! &DEGREE OF STABILIZATION! FABE= ',F6.4) + 1070 FORMAT (16A8) + 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) + 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', & + 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) + 1085 FORMAT (A3,16A7,2A8) + 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) + 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0) +1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',& + E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%') +1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & + ' TOTAL WATER CHANGE =',F8.2,'%') +! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) +1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%') +! +!----------------------------------------------------------------------- +!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------ +!----------------------------------------------------------------------- +! + CUTOP(I,J)=REAL(LTOP) + CUBOT(I,J)=REAL(LCL) +! +!----------------------------------------------------------------------- + END SUBROUTINE KF_eta_PARA +!******************************************************************** +! *********************************************************************** + SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES,XLV1,XLV0 + REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC + REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, & + TEMP,QS,QNEW,DQ,QTOT,RLL,CPP + INTEGER :: IPTB,ITHTB +!----------------------------------------------------------------------- + +!c******** LOOKUP TABLE VARIABLES... **************************** +! parameter(kfnt=250,kfnp=220) +!c +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), +! * alu(200),rdpr,rdthk,plutop +!C*************************************************************** +!c +!c*********************************************************************** +!c scaling pressure and tt table index +!c*********************************************************************** +!c + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 + +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 + IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN + write(98,*)'**** OUT OF BOUNDS *********' +! call flush(98) + ENDIF +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature +!*********************************************************************** +! + temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + DQ=QS-QU + IF(DQ.LE.0.)THEN + QNEW=QU-QS + QU=QS + ELSE +! +! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE +! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE +! + QNEW=0. + QTOT=QLIQ+QICE +! +! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS +! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING +! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION +! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE +! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE. +! +!...subsaturated values only occur in calculations involving various mixtures of +!...updraft and environmental air for estimation of entrainment and detrainment. +!...For these purposes, assume that reasonable estimates can be given using +!...liquid water saturation calculations only - i.e., ignore the effect of the +!...ice phase in this process only...will not affect conservative properties... +! + IF(QTOT.GE.DQ)THEN + qliq=qliq-dq*qliq/(qtot+1.e-10) + qice=qice-dq*qice/(qtot+1.e-10) + QU=QS + ELSE + RLL=XLV0-XLV1*TEMP + CPP=1004.5*(1.+0.89*QU) + IF(QTOT.LT.1.E-10)THEN +! +!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: + TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP + ELSE +! +!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION, +! THE TEMPERATURE IS GIVEN BY: +! + TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP + QU=QU+QTOT + QTOT=0. + QLIQ=0. + QICE=0. + ENDIF + ENDIF + ENDIF + TU=TEMP + qnewlq=qnew + qnewic=0. +! + END SUBROUTINE TPMIX2 +!****************************************************************************** + SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE + REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII +!----------------------------------------------------------------------- +! +!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN +!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE +!...TTFRZ TO TBFRZ... +!...FOR COLDER TERMPERATURES, FREEZE ALL LIQUID WATER... +!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER +!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE... +! + RLC=2.5E6-2369.276*(TU-273.16) + RLS=2833922.-259.532*(TU-273.16) + RLF=RLS-RLC + CPP=1004.5*(1.+0.89*QU) +! +! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS +! FOR SATURATION VAPOR PRESSURE... +! + A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ)) + DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A) + TU = TU+DTFRZ + + ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + QS = ES*0.622/(P-ES) +! +!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE +!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA- +!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY, +!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW +!...TEMPERATURE TO THE SATURATION VALUE... +! + DQEVAP = QS-QU + QICE = QICE-DQEVAP + QU = QU+DQEVAP + PII=(1.E5/P)**(0.2854*(1.-0.28*QU)) + THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU)) +! + END SUBROUTINE DTFRZNEW +! -------------------------------------------------------------------------------- + + SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & + QNEWIC,QLQOUT,QICOUT,G) + +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + + REAL, INTENT(IN ) :: G + REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE + REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC + REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG + +! +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + QTOT=QLIQ+QICE + QNEW=QNEWLQ+QNEWIC +! +! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY +! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL +! LEVELS... +! + QEST=0.5*(QTOT+QNEW) + G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 + IF(G1.LT.0.0)G1=0. + WAVG=0.5*(SQRT(WTW)+SQRT(G1)) + CONV=RATE*DZ/WAVG +! +! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS +! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV +! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN +! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... +! + RATIO3=QNEWLQ/(QNEW+1.E-8) +! OLDQ=QTOT + QTOT=QTOT+0.6*QNEW + OLDQ=QTOT + RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8) + QTOT=QTOT*EXP(-CONV) +! +! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT +! PARCEL AT THIS LEVEL... +! + DQ=OLDQ-QTOT + QLQOUT=RATIO4*DQ + QICOUT=(1.-RATIO4)*DQ +! +! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL +! LATE VERTICAL VELOCITY +! + PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) + WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 + IF(ABS(WTW).LT.1.E-4)WTW=1.E-4 +! +! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE +! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... +! + QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW + QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW + QNEWLQ=0. + QNEWIC=0. + + END SUBROUTINE CONDLOAD + +! ---------------------------------------------------------------------- + SUBROUTINE PROF5(EQ,EE,UD) +! +!*********************************************************************** +!***** GAUSSIAN TYPE MIXING PROFILE....****************************** +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN +! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM +! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES" +! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED +! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. +! JACK KAIN +! 7/6/89 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: EQ + REAL, INTENT(INOUT) :: EE,UD + REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 + + DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & + 0.9372980,0.33267,0.166666667,0.202765151/ + X=(EQ-0.5)/SIGMA + Y=6.*EQ-3. + EY=EXP(Y*Y/(-2)) + E45=EXP(-4.5) + T2=1./(1.+P*ABS(Y)) + T1=0.500498 + C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 + C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 + IF(Y.GE.0.)THEN + EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & + EQ) + ELSE + EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & + EQ/2.-EQ) + ENDIF + EE=EE/FE + UD=UD/FE + + END SUBROUTINE PROF5 + +! ------------------------------------------------------------------------ + SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES + REAL, INTENT(INOUT) :: TS,QS + INTEGER, INTENT(IN ) :: i,j ! avail for debugging + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11 + INTEGER :: IPTB,ITHTB + CHARACTER*256 :: MESS +!----------------------------------------------------------------------- + +! +!******** LOOKUP TABLE VARIABLES (F77 format)... **************************** +! parameter(kfnt=250,kfnp=220) +! +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), & +! alu(200),rdpr,rdthk,plutop +!*************************************************************** +! +!*********************************************************************** +! scaling pressure and tt table index +!*********************************************************************** +! + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature and saturation mixing ratio +!*********************************************************************** +! + ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + END SUBROUTINE TPMIX2DD + +! ----------------------------------------------------------------------- + SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ) +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: THT1 + REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, & + T00,P00,C1,C2,C3,C4,C5 + INTEGER :: INDLU +!----------------------------------------------------------------------- + DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, & + 0.278296,1.0723E-3/ +! +! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... +! +! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00 +! + EE=Q1*P1/(0.622+Q1) +! TLOG=ALOG(EE/ALIQ) +! ...calculate LOG term using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=ee/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) +! + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) +! + END SUBROUTINE ENVIRTHT +! *********************************************************************** +!==================================================================== + SUBROUTINE kf_eta_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + P_FIRST_SCALAR,restart,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart,allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA + + INTEGER :: i, j, k, itf, jtf, ktf + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QS .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQSCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=jts,jtf + DO i=its,itf + NCA(i,j)=-100. + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + W0AVG(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + endif + + CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) + + END SUBROUTINE kf_eta_init + +!------------------------------------------------------- + + subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0) +! +! This subroutine is a lookup table. +! Given a series of series of saturation equivalent potential +! temperatures, the temperature is calculated. +! +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- +! Lookup table variables +! INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220 +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables + + INTEGER :: KP,IT,ITCNT,I + REAL :: DTH,TMIN,TOLER,PBOT,DPR, & + TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, & + ASTRT,AINC,A1,THTGS +! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0 + REAL :: ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 +! +! equivalent potential temperature increment + data dth/1./ +! minimum starting temp + data tmin/150./ +! tolerance for accuracy of temperature + data toler/0.001/ +! top pressure (pascals) + plutop=5000.0 +! bottom pressure (pascals) + pbot=110000.0 + + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 + +! +! compute parameters +! +! 1._over_(sat. equiv. theta increment) + rdthk=1./dth +! pressure increment +! + DPR=(PBOT-PLUTOP)/REAL(KFNP-1) +! dpr=(pbot-plutop)/REAL(kfnp-1) +! 1._over_(pressure increment) + rdpr=1./dpr +! compute the spread of thes +! thespd=dth*(kfnt-1) +! +! calculate the starting sat. equiv. theta +! + temp=tmin + p=plutop-dpr + do kp=1,kfnp + p=p+dpr + es=aliq*exp((bliq*temp-cliq)/(temp-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* & + (1.+0.81*qs)) + enddo +! +! compute temperatures for each sat. equiv. potential temp. +! + p=plutop-dpr + do kp=1,kfnp + thes=the0k(kp)-dth + p=p+dpr + do it=1,kfnt +! define sat. equiv. pot. temp. + thes=thes+dth +! iterate to find temperature +! find initial guess + if(it.eq.1) then + tgues=tmin + else + tgues=ttab(it-1,kp) + endif + es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* & + (1.+0.81*qs)) + f0=thgues-thes + t1=tgues-0.5*f0 + t0=tgues + itcnt=0 +! iteration loop + do itcnt=1,11 + es=aliq*exp((bliq*t1-cliq)/(t1-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs)) + f1=thtgs-thes + if(abs(f1).lt.toler)then + exit + endif +! itcnt=itcnt+1 + dt=f1*(t1-t0)/(f1-f0) + t0=t1 + f0=f1 + t1=t1-dt + enddo + ttab(it,kp)=t1 + qstab(it,kp)=qs + enddo + enddo +! +! lookup table for tlog(emix/aliq) +! +! set up intial values for lookup tables +! + astrt=1.e-3 + ainc=0.075 +! + a1=astrt-ainc + do i=1,200 + a1=a1+ainc + alu(i)=alog(a1) + enddo +! + END SUBROUTINE KF_LUTAB + +END MODULE module_cu_kfeta diff --git a/wrfv2_fire/phys/module_cu_sas.F b/wrfv2_fire/phys/module_cu_sas.F new file mode 100755 index 00000000..0694fed2 --- /dev/null +++ b/wrfv2_fire/phys/module_cu_sas.F @@ -0,0 +1,2485 @@ +! +MODULE module_cu_sas + +#ifndef IFORT_KLUDGE +USE module_configure, ONLY: nl_get_start_year, nl_get_start_month, & + nl_get_start_day, nl_get_start_hour +#endif +CONTAINS + +!----------------------------------------------------------------- + SUBROUTINE CU_SAS( & + DT,ITIMESTEP,STEPCU & + ,RAINCV,HTOP,HBOT & + ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D & + ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN & + ) + +!------------------------------------------------------------------- + USE MODULE_GFS_MACHINE , ONLY : kind_phys, kind_evod + USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys + USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & + &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & + &, CVAP => con_CVAP, CLIQ => con_CLIQ & + &, EPS => con_eps, EPSM1 => con_epsm1 & + &, ROVCP => con_rocp, RD => con_rd +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- TH3D 3D potential temperature (K) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- QC3D 3D cloud mixing ratio (Kg/Kg) +!-- QI3D 3D ice mixing ratio (Kg/Kg) +!-- P8w 3D pressure at full levels (Pa) +!-- Pcps 3D pressure (Pa) +!-- PI3D 3D exner function (dimensionless) +!-- rr3D 3D dry air density (kg/m^3) +!-- RUBLTEN U tendency due to +! PBL parameterization (m/s^2) +!-- RVBLTEN V tendency due to +! PBL parameterization (m/s^2) +!-- RTHBLTEN Theta tendency due to +! PBL parameterization (K/s) +!-- RQVBLTEN Qv tendency due to +! PBL parameterization (kg/kg/s) +!-- RQCBLTEN Qc tendency due to +! PBL parameterization (kg/kg/s) +!-- RQIBLTEN Qi tendency due to +! PBL parameterization (kg/kg/s) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- GRAV acceleration due to gravity (m/s^2) +!-- ROVCP R/CP +!-- RD gas constant for dry air (J/kg/K) +!-- ROVG R/G +!-- P_QI species index for cloud ice +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- PSFC pressure at the surface (Pa) +!-- UST u* in similarity theory (m/s) +!-- PBL PBL height (m) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity stability function for heat +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- TSK surface temperature (K) +!-- GZ1OZ0 log(z/z0) where z0 is roughness length +!-- WSPD wind speed at lowest model level (m/s) +!-- BR bulk Richardson number in surface layer +!-- DT time step (s) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- KARMAN Von Karman constant +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + + INTEGER :: ICLDCK + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ITIMESTEP, & + STEPCU + + REAL, INTENT(IN) :: & + DT + + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & + XLAND + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: & + RAINCV + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & + HBOT, & + HTOP + + LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: & + CU_ACT_FLAG + + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & + DZ8W, & + P8w, & + Pcps, & + PI3D, & + QC3D, & + QI3D, & + QV3D, & + RHO3D, & + T3D, & + U3D, & + V3D, & + W + +!--------------------------- OPTIONAL VARS ---------------------------- + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + OPTIONAL, INTENT(INOUT) :: & + RQCCUTEN, & + RQICUTEN, & + RQVCUTEN, & + RTHCUTEN + +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, OPTIONAL :: & + F_QV & + ,F_QC & + ,F_QR & + ,F_QI & + ,F_QS + + +!--------------------------- LOCAL VARS ------------------------------ + + REAL, DIMENSION(ims:ime, jms:jme) :: & + PSFC + + REAL (kind=kind_evod),save :: seed0 +! REAL (kind=kind_evod) :: seed0 + REAL (kind=kind_evod) :: wrk + + REAL (kind=kind_phys) :: & + DELT, & + DPSHC, & + RDELT, & + RSEED + + REAL (kind=kind_phys), DIMENSION(ids:ide,jds:jde) :: & + RANNUM + + REAL (kind=kind_phys), DIMENSION(its:ite) :: & + CLDWRK, & + PS, & + RCS, & + RN, & + SLIMSK, & + XKT2 + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) :: & + PRSI + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte) :: & + DEL, & + DOT, & + PHIL, & + PRSL, & + PRSLK, & + Q1, & + T1, & + U1, & + V1, & + ZI, & + ZL + + REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte, 2) :: & + QL + + INTEGER, DIMENSION(its:ite) :: & + KBOT, & + KTOP, & + KUO + + INTEGER :: & + I, & +! IGPVS, & + IM, & + J, & + JCAP, & + K, & + KM, & + KP, & + KX, & + NCLOUD + + INTEGER :: start_year,start_month,start_day,start_hour + + integer :: iseed +! integer, save :: krsize + integer :: krsize + integer, allocatable :: nrnd(:) + real :: fsec + +! DATA IGPVS/0/ + +!----------------------------------------------------------------------- +! +!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP +! + ICLDCK=MOD(ITIMESTEP,STEPCU) +!----------------------------------------------------------------------- + + + IF(ICLDCK.EQ.0.OR.ITIMESTEP.EQ.0)THEN + + DO J=JTS,JTE + DO I=ITS,ITE + CU_ACT_FLAG(I,J)=.TRUE. + ENDDO + ENDDO + + IM=ITE-ITS+1 + KX=KTE-KTS+1 + JCAP=126 + DPSHC=30_kind_phys + DELT=DT*STEPCU + RDELT=1./DELT + NCLOUD=1 + + + DO J=jms,jme + DO I=ims,ime + PSFC(i,j)=P8w(i,kms,j) + ENDDO + ENDDO + + if(itimestep.eq.0) then + CALL GFUNCPHYS + + CALL nl_get_start_year(1,start_year) + CALL nl_get_start_month(1,start_month) + CALL nl_get_start_day(1,start_day) + CALL nl_get_start_hour(1,start_hour) + + call random_seed(size=krsize) + if (.not. allocated (nrnd)) allocate (nrnd(krsize)) + + seed0 = start_year + start_month + start_day + start_hour + nrnd = start_hour + start_day*24 + call random_seed + call random_seed(put=nrnd) + call random_number(wrk) + seed0 = seed0 + nint(wrk*1000.0) + + endif + + fsec = ITIMESTEP*DT + iseed = mod(100.0*sqrt(fsec),1.0e9) + 1 + seed0 + call random_seed(size=krsize) + if (.not. allocated (nrnd)) allocate (nrnd(krsize)) + nrnd = iseed + call random_seed + call random_seed(put=nrnd) + call random_number(rannum) + +! igpvs=1 + +!------------- J LOOP (OUTER) -------------------------------------------------- + + DO J=jts,jte + +! --------------- compute zi and zl ----------------------------------------- + DO i=its,ite + ZI(I,KTS)=0.0 + ENDDO + + DO k=kts+1,kte + KM=K-1 + DO i=its,ite + ZI(I,K)=ZI(I,KM)+dz8w(i,km,j) + ENDDO + ENDDO + + DO k=kts+1,kte + KM=K-1 + DO i=its,ite + ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5 + ENDDO + ENDDO + + DO i=its,ite + ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1) + ENDDO + +! --------------- end compute zi and zl ------------------------------------- + + +! call random_number(XKT2) + DO i=its,ite + xkt2(i)=rannum(i,j) + PS(i)=PSFC(i,j)*.001 + RCS(i)=1. + SLIMSK(i)=ABS(XLAND(i,j)-2.) + ENDDO + + DO i=its,ite + PRSI(i,kts)=PS(i) + ENDDO + + DO k=kts,kte + kp=k+1 + DO i=its,ite + PRSL(I,K)=Pcps(i,k,j)*.001 + PHIL(I,K)=ZL(I,K)*GRAV + DOT(i,k)=-5.0E-4*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) + ENDDO + ENDDO + + DO k=kts,kte + DO i=its,ite + DEL(i,k)=PRSL(i,k)*GRAV/RD*dz8w(i,k,j)/T3D(i,k,j) + U1(i,k)=U3D(i,k,j) + V1(i,k)=V3D(i,k,j) + Q1(i,k)=QV3D(i,k,j)/(1.+QV3D(i,k,j)) + T1(i,k)=T3D(i,k,j) + QL(i,k,1)=QI3D(i,k,j)/(1.+QI3D(i,k,j)) + QL(i,k,2)=QC3D(i,k,j)/(1.+QC3D(i,k,j)) + PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP + ENDDO + ENDDO + + DO k=kts+1,kte+1 + km=k-1 + DO i=its,ite + PRSI(i,k)=PRSI(i,km)-del(i,km) + ENDDO + ENDDO + + + CALL SASCNV(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL, & + QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT, & + KTOP,KUO,SLIMSK,DOT,XKT2,NCLOUD) + + CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC) + + DO I=ITS,ITE + RAINCV(I,J)=RN(I)*1000./STEPCU + HBOT(I,J)=KBOT(I) + HTOP(I,J)=KTOP(I) + ENDDO + + DO K=KTS,KTE + DO I=ITS,ITE + RTHCUTEN(I,K,J)=(T1(I,K)-T3D(I,K,J))/PI3D(I,K,J)*RDELT + RQVCUTEN(I,K,J)=(Q1(I,K)/(1.-q1(i,k))-QV3D(I,K,J))*RDELT + ENDDO + ENDDO + + IF(PRESENT(RQCCUTEN))THEN + IF ( F_QC ) THEN + DO K=KTS,KTE + DO I=ITS,ITE + RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT + ENDDO + ENDDO + ENDIF + ENDIF + + IF(PRESENT(RQICUTEN))THEN + IF ( F_QI ) THEN + DO K=KTS,KTE + DO I=ITS,ITE + RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT + ENDDO + ENDDO + ENDIF + ENDIF + + + ENDDO + + ENDIF + + END SUBROUTINE CU_SAS + +!==================================================================== + SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & + RESTART,P_QC,P_QI,P_FIRST_SCALAR, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: allowed_to_read,restart + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQICUTEN + + INTEGER :: i, j, k, itf, jtf, ktf + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF (P_QC .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQCCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE sasinit + +! ------------------------------------------------------------------------ + + SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PS,PHIL,QL, & +! SUBROUTINE SASCNV(IM,IX,KM,JCAP,DLT,DEL,PRSL,PHIL,QL, & + & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, & + & DOT,XKT2,ncloud) +! for cloud water version +! parameter(ncloud=0) +! SUBROUTINE SASCNV(KM,JCAP,DELT,DEL,SL,SLK,PS,QL, +! & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, +! & DOT,xkt2,ncloud) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys,kind_evod + USE MODULE_GFS_FUNCPHYS ,ONLY : fpvs + USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & + &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & + &, CVAP => con_CVAP, CLIQ => con_CLIQ & + &, EPS => con_eps, EPSM1 => con_epsm1 + + implicit none +! +! include 'constant.h' +! + integer IM, IX, KM, JCAP, ncloud, & + & KBOT(IM), KTOP(IM), KUO(IM) + real(kind=kind_phys) DELT + real(kind=kind_phys) PS(IM), DEL(IX,KM), PRSL(IX,KM), & +! real(kind=kind_phys) DEL(IX,KM), PRSL(IX,KM), + & QL(IX,KM,2), Q1(IX,KM), T1(IX,KM), & + & U1(IX,KM), V1(IX,KM), RCS(IM), & + & CLDWRK(IM), RN(IM), SLIMSK(IM), & + & DOT(IX,KM), XKT2(IM), PHIL(IX,KM) +! + integer I, INDX, jmn, k, knumb, latd, lond, km1 +! + real(kind=kind_phys) adw, alpha, alphal, alphas, & + & aup, beta, betal, betas, & + & c0, cpoel, dellat, delta, & + & desdt, deta, detad, dg, & + & dh, dhh, dlnsig, dp, & + & dq, dqsdp, dqsdt, dt, & + & dt2, dtmax, dtmin, dv1, & + & dv1q, dv2, dv2q, dv1u, & + & dv1v, dv2u, dv2v, dv3u, & + & dv3v, dv3, dv3q, dvq1, & + & dz, dz1, e1, edtmax, & + & edtmaxl, edtmaxs, el2orc, elocp, & + & es, etah, & + & evef, evfact, evfactl, fact1, & + & fact2, factor, fjcap, fkm, & + & fuv, g, gamma, onemf, & + & onemfu, pdetrn, pdpdwn, pprime, & + & qc, qlk, qrch, qs, & + & rain, rfact, shear, tem1, & + & tem2, terr, val, val1, & + & val2, w1, w1l, w1s, & + & w2, w2l, w2s, w3, & + & w3l, w3s, w4, w4l, & + & w4s, xdby, xpw, xpwd, & + & xqc, xqrch, xlambu, mbdt, & + & tem +! +! + integer JMIN(IM), KB(IM), KBCON(IM), KBDTR(IM), & + & KT2(IM), KTCON(IM), LMIN(IM), & + & kbm(IM), kbmax(IM), kmax(IM) +! + real(kind=kind_phys) AA1(IM), ACRT(IM), ACRTFCT(IM), & + & DELHBAR(IM), DELQ(IM), DELQ2(IM), & + & DELQBAR(IM), DELQEV(IM), DELTBAR(IM), & + & DELTV(IM), DTCONV(IM), EDT(IM), & + & EDTO(IM), EDTX(IM), FLD(IM), & + & HCDO(IM), HKBO(IM), HMAX(IM), & + & HMIN(IM), HSBAR(IM), UCDO(IM), & + & UKBO(IM), VCDO(IM), VKBO(IM), & + & PBCDIF(IM), PDOT(IM), PO(IM,KM), & + & PWAVO(IM), PWEVO(IM), & +! & PSFC(IM), PWAVO(IM), PWEVO(IM), & + & QCDO(IM), QCOND(IM), QEVAP(IM), & + & QKBO(IM), RNTOT(IM), VSHEAR(IM), & + & XAA0(IM), XHCD(IM), XHKB(IM), & + & XK(IM), XLAMB(IM), XLAMD(IM), & + & XMB(IM), XMBMAX(IM), XPWAV(IM), & + & XPWEV(IM), XQCD(IM), XQKB(IM) +! +! PHYSICAL PARAMETERS + PARAMETER(G=grav) + PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP, & + & EL2ORC=HVAP*HVAP/(RV*CP)) + PARAMETER(TERR=0.,C0=.002,DELTA=fv) + PARAMETER(FACT1=(CVAP-CLIQ)/RV,FACT2=HVAP/RV-FACT1*T0C) +! LOCAL VARIABLES AND ARRAYS + real(kind=kind_phys) PFLD(IM,KM), TO(IM,KM), QO(IM,KM), & + & UO(IM,KM), VO(IM,KM), QESO(IM,KM) +! cloud water + real(kind=kind_phys) QLKO_KTCON(IM), DELLAL(IM), TVO(IM,KM), & + & DBYO(IM,KM), ZO(IM,KM), SUMZ(IM,KM), & + & SUMH(IM,KM), HEO(IM,KM), HESO(IM,KM), & + & QRCD(IM,KM), DELLAH(IM,KM), DELLAQ(IM,KM),& + & DELLAU(IM,KM), DELLAV(IM,KM), HCKO(IM,KM), & + & UCKO(IM,KM), VCKO(IM,KM), QCKO(IM,KM), & + & ETA(IM,KM), ETAU(IM,KM), ETAD(IM,KM), & + & QRCDO(IM,KM), PWO(IM,KM), PWDO(IM,KM), & + & RHBAR(IM), TX1(IM) +! + LOGICAL TOTFLG, CNVFLG(IM), DWNFLG(IM), DWNFLG2(IM), FLG(IM) +! + real(kind=kind_phys) PCRIT(15), ACRITT(15), ACRIT(15) +! SAVE PCRIT, ACRITT + DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., & + & 350.,300.,250.,200.,150./ + DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, & + & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ +! GDAS DERIVED ACRIT +! DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688, & +! & .743,.813,.886,.947,1.138,1.377,1.896/ +! + real(kind=kind_phys) TF, TCR, TCRF, RZERO, RONE + parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF)) + parameter (RZERO=0.0,RONE=1.0) +!----------------------------------------------------------------------- +! + km1 = km - 1 +! INITIALIZE ARRAYS +! + DO I=1,IM + RN(I)=0. + KBOT(I)=KM+1 + KTOP(I)=0 + KUO(I)=0 + CNVFLG(I) = .TRUE. + DTCONV(I) = 3600. + CLDWRK(I) = 0. + PDOT(I) = 0. + KT2(I) = 0 + QLKO_KTCON(I) = 0. + DELLAL(I) = 0. + ENDDO +!! + DO K = 1, 15 + ACRIT(K) = ACRITT(K) * (975. - PCRIT(K)) + ENDDO + DT2 = DELT +!cmr dtmin = max(dt2,1200.) + val = 1200. + dtmin = max(dt2, val ) +!cmr dtmax = max(dt2,3600.) + val = 3600. + dtmax = max(dt2, val ) +! MODEL TUNABLE PARAMETERS ARE ALL HERE + MBDT = 10. + EDTMAXl = .3 + EDTMAXs = .3 + ALPHAl = .5 + ALPHAs = .5 + BETAl = .15 + betas = .15 + BETAl = .05 + betas = .05 +! EVEF = 0.07 + evfact = 0.3 + evfactl = 0.3 + PDPDWN = 0. + PDETRN = 200. + xlambu = 1.e-4 + fjcap = (float(jcap) / 126.) ** 2 +!cmr fjcap = max(fjcap,1.) + val = 1. + fjcap = max(fjcap,val) + fkm = (float(km) / 28.) ** 2 +!cmr fkm = max(fkm,1.) + fkm = max(fkm,val) + W1l = -8.E-3 + W2l = -4.E-2 + W3l = -5.E-3 + W4l = -5.E-4 + W1s = -2.E-4 + W2s = -2.E-3 + W3s = -1.E-3 + W4s = -2.E-5 +!CCCC IF(IM.EQ.384) THEN + LATD = 92 + lond = 189 +!CCCC ELSEIF(IM.EQ.768) THEN +!CCCC LATD = 80 +!CCCC ELSE +!CCCC LATD = 0 +!CCCC ENDIF +! +! DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER +! AND THE MAXIMUM THETAE FOR UPDRAFT +! + DO I=1,IM + KBMAX(I) = KM + KBM(I) = KM + KMAX(I) = KM + TX1(I) = 1.0 / PS(I) + ENDDO +! + DO K = 1, KM + DO I=1,IM + IF (prSL(I,K)*tx1(I) .GT. 0.45) KBMAX(I) = K + 1 + IF (prSL(I,K)*tx1(I) .GT. 0.70) KBM(I) = K + 1 + IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I) = MIN(KM,K + 1) + ENDDO + ENDDO + DO I=1,IM + KBMAX(I) = MIN(KBMAX(I),KMAX(I)) + KBM(I) = MIN(KBM(I),KMAX(I)) + ENDDO +! +! CONVERT SURFACE PRESSURE TO MB FROM CB +! +!! + DO K = 1, KM + DO I=1,IM + if (K .le. kmax(i)) then + PFLD(I,k) = PRSL(I,K) * 10.0 + PWO(I,k) = 0. + PWDO(I,k) = 0. + TO(I,k) = T1(I,k) + QO(I,k) = Q1(I,k) + UO(I,k) = U1(I,k) + VO(I,k) = V1(I,k) + DBYO(I,k) = 0. + SUMZ(I,k) = 0. + SUMH(I,k) = 0. + endif + ENDDO + ENDDO + +! +! COLUMN VARIABLES +! P IS PRESSURE OF THE LAYER (MB) +! T IS TEMPERATURE AT T-DT (K)..TN +! Q IS MIXING RATIO AT T-DT (KG/KG)..QN +! TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN +! QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 +! + DO K = 1, KM + DO I=1,IM + if (k .le. kmax(i)) then + !jfe QESO(I,k) = 10. * FPVS(T1(I,k)) + ! + QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa + ! + QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) + !cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val1 = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val1) + !cmr QO(I,k) = max(QO(I,k),1.e-10) + val2 = 1.e-10 + QO(I,k) = max(QO(I,k), val2 ) + ! QO(I,k) = MIN(QO(I,k),QESO(I,k)) + TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) + endif + ENDDO + ENDDO + +! +! HYDROSTATIC HEIGHT ASSUME ZERO TERR +! + DO K = 1, KM + DO I=1,IM + ZO(I,k) = PHIL(I,k) / G + ENDDO + ENDDO +! COMPUTE MOIST STATIC ENERGY + DO K = 1, KM + DO I=1,IM + if (K .le. kmax(i)) then +! tem = G * ZO(I,k) + CP * TO(I,k) + tem = PHIL(I,k) + CP * TO(I,k) + HEO(I,k) = tem + HVAP * QO(I,k) + HESO(I,k) = tem + HVAP * QESO(I,k) +! HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) + endif + ENDDO + ENDDO +! +! DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY +! THIS IS THE LEVEL WHERE UPDRAFT STARTS +! + DO I=1,IM + HMAX(I) = HEO(I,1) + KB(I) = 1 + ENDDO +!! + DO K = 2, KM + DO I=1,IM + if (k .le. kbm(i)) then + IF(HEO(I,k).GT.HMAX(I).AND.CNVFLG(I)) THEN + KB(I) = K + HMAX(I) = HEO(I,k) + ENDIF + endif + ENDDO + ENDDO +! DO K = 1, KMAX - 1 +! TOL(k) = .5 * (TO(I,k) + TO(I,k+1)) +! QOL(k) = .5 * (QO(I,k) + QO(I,k+1)) +! QESOL(I,k) = .5 * (QESO(I,k) + QESO(I,k+1)) +! HEOL(I,k) = .5 * (HEO(I,k) + HEO(I,k+1)) +! HESOL(I,k) = .5 * (HESO(I,k) + HESO(I,k+1)) +! ENDDO + DO K = 1, KM1 + DO I=1,IM + if (k .le. kmax(i)-1) then + DZ = .5 * (ZO(I,k+1) - ZO(I,k)) + DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) +!jfe ES = 10. * FPVS(TO(I,k+1)) +! + ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa +! + PPRIME = PFLD(I,k+1) + EPSM1 * ES + QS = EPS * ES / PPRIME + DQSDP = - QS / PPRIME + DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) + DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) + GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) + DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) + DQ = DQSDT * DT + DQSDP * DP + TO(I,k) = TO(I,k+1) + DT + QO(I,k) = QO(I,k+1) + DQ + PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) + endif + ENDDO + ENDDO +! + DO K = 1, KM1 + DO I=1,IM + if (k .le. kmax(I)-1) then +!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) +! + QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa +! + QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1*QESO(I,k)) +!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val1 = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val1) +!cmr QO(I,k) = max(QO(I,k),1.e-10) + val2 = 1.e-10 + QO(I,k) = max(QO(I,k), val2 ) +! QO(I,k) = MIN(QO(I,k),QESO(I,k)) + HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & + & CP * TO(I,k) + HVAP * QO(I,k) + HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & + & CP * TO(I,k) + HVAP * QESO(I,k) + UO(I,k) = .5 * (UO(I,k) + UO(I,k+1)) + VO(I,k) = .5 * (VO(I,k) + VO(I,k+1)) + endif + ENDDO + ENDDO +! k = kmax +! HEO(I,k) = HEO(I,k) +! hesol(k) = HESO(I,k) +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +! PRINT *, ' HEO =' +! PRINT 6001, (HEO(I,K),K=1,KMAX) +! PRINT *, ' HESO =' +! PRINT 6001, (HESO(I,K),K=1,KMAX) +! PRINT *, ' TO =' +! PRINT 6002, (TO(I,K)-273.16,K=1,KMAX) +! PRINT *, ' QO =' +! PRINT 6003, (QO(I,K),K=1,KMAX) +! PRINT *, ' QSO =' +! PRINT 6003, (QESO(I,K),K=1,KMAX) +! ENDIF +! +! LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION +! + DO I=1,IM + IF(CNVFLG(I)) THEN + INDX = KB(I) + HKBO(I) = HEO(I,INDX) + QKBO(I) = QO(I,INDX) + UKBO(I) = UO(I,INDX) + VKBO(I) = VO(I,INDX) + ENDIF + FLG(I) = CNVFLG(I) + KBCON(I) = KMAX(I) + ENDDO +!! + DO K = 1, KM + DO I=1,IM + if (k .le. kbmax(i)) then + IF(FLG(I).AND.K.GT.KB(I)) THEN + HSBAR(I) = HESO(I,k) + IF(HKBO(I).GT.HSBAR(I)) THEN + FLG(I) = .FALSE. + KBCON(I) = K + ENDIF + ENDIF + endif + ENDDO + ENDDO + DO I=1,IM + IF(CNVFLG(I)) THEN + PBCDIF(I) = -PFLD(I,KBCON(I)) + PFLD(I,KB(I)) + PDOT(I) = 10.* DOT(I,KBCON(I)) + IF(PBCDIF(I).GT.150.) CNVFLG(I) = .FALSE. + IF(KBCON(I).EQ.KMAX(I)) CNVFLG(I) = .FALSE. + ENDIF + ENDDO +!! + TOTFLG = .TRUE. + DO I=1,IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +! FOUND LFC, CAN DEFINE REST OF VARIABLES + 6001 FORMAT(2X,-2P10F12.2) + 6002 FORMAT(2X,10F12.2) + 6003 FORMAT(2X,3P10F12.2) + +! +! DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON +! + DO I = 1, IM + alpha = alphas + if(SLIMSK(I).eq.1.) alpha = alphal + IF(CNVFLG(I)) THEN + IF(KB(I).EQ.1) THEN + DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1) + ELSE + DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) & + & - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1)) + ENDIF + IF(KBCON(I).NE.KB(I)) THEN +!cmr XLAMB(I) = -ALOG(ALPHA) / DZ + XLAMB(I) = - LOG(ALPHA) / DZ + ELSE + XLAMB(I) = 0. + ENDIF + ENDIF + ENDDO +! DETERMINE UPDRAFT MASS FLUX + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i) .and. CNVFLG(I)) then + ETA(I,k) = 1. + ETAU(I,k) = 1. + ENDIF + ENDDO + ENDDO + DO K = KM1, 2, -1 + DO I = 1, IM + if (k .le. kbmax(i)) then + IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + ETA(I,k) = ETA(I,k+1) * EXP(-XLAMB(I) * DZ) + ETAU(I,k) = ETA(I,k) + ENDIF + endif + ENDDO + ENDDO + DO I = 1, IM + IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN + DZ = .5 * (ZO(I,2) - ZO(I,1)) + ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ) + ETAU(I,1) = ETA(I,1) + ENDIF + ENDDO +! +! WORK UP UPDRAFT CLOUD PROPERTIES +! + DO I = 1, IM + IF(CNVFLG(I)) THEN + INDX = KB(I) + HCKO(I,INDX) = HKBO(I) + QCKO(I,INDX) = QKBO(I) + UCKO(I,INDX) = UKBO(I) + VCKO(I,INDX) = VKBO(I) + PWAVO(I) = 0. + ENDIF + ENDDO +! +! CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES +! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN + FACTOR = ETA(I,k-1) / ETA(I,k) + ONEMF = 1. - FACTOR + HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & + & .5 * (HEO(I,k) + HEO(I,k+1)) + UCKO(I,k) = FACTOR * UCKO(I,k-1) + ONEMF * & + & .5 * (UO(I,k) + UO(I,k+1)) + VCKO(I,k) = FACTOR * VCKO(I,k-1) + ONEMF * & + & .5 * (VO(I,k) + VO(I,k+1)) + DBYO(I,k) = HCKO(I,k) - HESO(I,k) + ENDIF + IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN + HCKO(I,k) = HCKO(I,k-1) + UCKO(I,k) = UCKO(I,k-1) + VCKO(I,k) = VCKO(I,k-1) + DBYO(I,k) = HCKO(I,k) - HESO(I,k) + ENDIF + endif + ENDDO + ENDDO +! DETERMINE CLOUD TOP + DO I = 1, IM + FLG(I) = CNVFLG(I) + KTCON(I) = 1 + ENDDO +! DO K = 2, KMAX +! KK = KMAX - K + 1 +! IF(DBYO(I,kK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN +! KTCON(I) = KK + 1 +! FLG(I) = .FALSE. +! ENDIF +! ENDDO + DO K = 2, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(DBYO(I,k).LT.0..AND.FLG(I).AND.K.GT.KBCON(I)) THEN + KTCON(I) = K + FLG(I) = .FALSE. + ENDIF + endif + ENDDO + ENDDO + DO I = 1, IM + IF(CNVFLG(I).AND.(PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))).LT.150.) & + & CNVFLG(I) = .FALSE. + ENDDO + TOTFLG = .TRUE. + DO I = 1, IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +! +! SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM +! + DO I = 1, IM + HMIN(I) = HEO(I,KBCON(I)) + LMIN(I) = KBMAX(I) + JMIN(I) = KBMAX(I) + ENDDO + DO I = 1, IM + DO K = KBCON(I), KBMAX(I) + IF(HEO(I,k).LT.HMIN(I).AND.CNVFLG(I)) THEN + LMIN(I) = K + 1 + HMIN(I) = HEO(I,k) + ENDIF + ENDDO + ENDDO +! +! Make sure that JMIN(I) is within the cloud +! + DO I = 1, IM + IF(CNVFLG(I)) THEN + JMIN(I) = MIN(LMIN(I),KTCON(I)-1) + XMBMAX(I) = .1 + JMIN(I) = MAX(JMIN(I),KBCON(I)+1) + ENDIF + ENDDO +! +! ENTRAINING CLOUD +! + do k = 2, km1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + if(CNVFLG(I).and.k.gt.JMIN(I).and.k.le.KTCON(I)) THEN + SUMZ(I,k) = SUMZ(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) + SUMH(I,k) = SUMH(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1)) & + & * HEO(I,k) + ENDIF + endif + enddo + enddo +!! + DO I = 1, IM + IF(CNVFLG(I)) THEN +! call random_number(XKT2) +! call srand(fhour) +! XKT2(I) = rand() + KT2(I) = nint(XKT2(I)*float(KTCON(I)-JMIN(I))-.5)+JMIN(I)+1 +! KT2(I) = nint(sqrt(XKT2(I))*float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 +! KT2(I) = nint(ranf() *float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1 + tem1 = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) + tem2 = (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) + if (abs(tem2) .gt. 0.000001) THEN + XLAMB(I) = tem1 / tem2 + else + CNVFLG(I) = .false. + ENDIF +! XLAMB(I) = (HCKO(I,JMIN(I)) - HESO(I,KT2(I))) +! & / (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I))) + XLAMB(I) = max(XLAMB(I),RZERO) + XLAMB(I) = min(XLAMB(I),2.3/SUMZ(I,KT2(I))) + ENDIF + ENDDO +!! + DO I = 1, IM + DWNFLG(I) = CNVFLG(I) + DWNFLG2(I) = CNVFLG(I) + IF(CNVFLG(I)) THEN + if(KT2(I).ge.KTCON(I)) DWNFLG(I) = .false. + if(XLAMB(I).le.1.e-30.or.HCKO(I,JMIN(I))-HESO(I,KT2(I)).le.1.e-30)& + & DWNFLG(I) = .false. + do k = JMIN(I), KT2(I) + if(DWNFLG(I).and.HEO(I,k).gt.HESO(I,KT2(I))) DWNFLG(I)=.false. + enddo +! IF(CNVFLG(I).AND.(PFLD(KBCON(I))-PFLD(KTCON(I))).GT.PDETRN) +! & DWNFLG(I)=.FALSE. + IF(CNVFLG(I).AND.(PFLD(I,KBCON(I))-PFLD(I,KTCON(I))).LT.PDPDWN) & + & DWNFLG2(I)=.FALSE. + ENDIF + ENDDO +!! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) +! ETA(I,k) = ETA(I,k-1) * EXP( XLAMB(I) * DZ) +! to simplify matter, we will take the linear approach here +! + ETA(I,k) = ETA(I,k-1) * (1. + XLAMB(I) * dz) + ETAU(I,k) = ETAU(I,k-1) * (1. + (XLAMB(I)+xlambu) * dz) + ENDIF + endif + ENDDO + ENDDO +!! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then +! IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN + IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KTCON(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + ETAU(I,k) = ETAU(I,k-1) * (1. + xlambu * dz) + ENDIF + endif + ENDDO + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +! PRINT *, ' LMIN(I), KT2(I)=', LMIN(I), KT2(I) +! PRINT *, ' KBOT, KTOP, JMIN(I) =', KBCON(I), KTCON(I), JMIN(I) +! ENDIF +! IF(LAT.EQ.LATD.AND.lon.eq.lond) THEN +! print *, ' xlamb =', xlamb +! print *, ' eta =', (eta(k),k=1,KT2(I)) +! print *, ' ETAU =', (ETAU(I,k),k=1,KT2(I)) +! print *, ' HCKO =', (HCKO(I,k),k=1,KT2(I)) +! print *, ' SUMZ =', (SUMZ(I,k),k=1,KT2(I)) +! print *, ' SUMH =', (SUMH(I,k),k=1,KT2(I)) +! ENDIF + DO I = 1, IM + if(DWNFLG(I)) THEN + KTCON(I) = KT2(I) + ENDIF + ENDDO +! +! CLOUD PROPERTY ABOVE CLOUD Base IS MODIFIED BY THE DETRAINMENT PROCESS +! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then +!jfe + IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN +!jfe IF(K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN + FACTOR = ETA(I,k-1) / ETA(I,k) + ONEMF = 1. - FACTOR + fuv = ETAU(I,k-1) / ETAU(I,k) + onemfu = 1. - fuv + HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & + & .5 * (HEO(I,k) + HEO(I,k+1)) + UCKO(I,k) = fuv * UCKO(I,k-1) + ONEMFu * & + & .5 * (UO(I,k) + UO(I,k+1)) + VCKO(I,k) = fuv * VCKO(I,k-1) + ONEMFu * & + & .5 * (VO(I,k) + VO(I,k+1)) + DBYO(I,k) = HCKO(I,k) - HESO(I,k) + ENDIF + endif + ENDDO + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +! PRINT *, ' UCKO=', (UCKO(I,k),k=KBCON(I)+1,KTCON(I)) +! PRINT *, ' uenv=', (.5*(UO(I,k)+UO(I,k-1)),k=KBCON(I)+1,KTCON(I)) +! ENDIF + DO I = 1, IM + if(CNVFLG(I).and.DWNFLG2(I).and.JMIN(I).le.KBCON(I)) & + & THEN + CNVFLG(I) = .false. + DWNFLG(I) = .false. + DWNFLG2(I) = .false. + ENDIF + ENDDO +!! + TOTFLG = .TRUE. + DO I = 1, IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +!! +! +! COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION +! + DO I = 1, IM + AA1(I) = 0. + RHBAR(I) = 0. + ENDDO + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + DZ1 = (ZO(I,k) - ZO(I,k-1)) + GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) + QRCH = QESO(I,k) & + & + GAMMA * DBYO(I,k) / (HVAP * (1. + GAMMA)) + FACTOR = ETA(I,k-1) / ETA(I,k) + ONEMF = 1. - FACTOR + QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * & + & .5 * (QO(I,k) + QO(I,k+1)) + DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * QRCH + RHBAR(I) = RHBAR(I) + QO(I,k) / QESO(I,k) +! +! BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT +! + IF(DQ.GT.0.) THEN + ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) + QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) + AA1(I) = AA1(I) - DZ1 * G * QLK + QC = QLK + QRCH + PWO(I,k) = ETAH * C0 * DZ * QLK + QCKO(I,k) = QC + PWAVO(I) = PWAVO(I) + PWO(I,k) + ENDIF + ENDIF + endif + ENDDO + ENDDO + DO I = 1, IM + RHBAR(I) = RHBAR(I) / float(KTCON(I) - KB(I) - 1) + ENDDO +! +! this section is ready for cloud water +! + if(ncloud.gt.0) THEN +! +! compute liquid and vapor separation at cloud top +! + DO I = 1, IM + k = KTCON(I) + IF(CNVFLG(I)) THEN + GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2) + QRCH = QESO(I,K) & + & + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA)) + DQ = QCKO(I,K-1) - QRCH +! +! CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT +! + IF(DQ.GT.0.) THEN + QLKO_KTCON(I) = dq + QCKO(I,K-1) = QRCH + ENDIF + ENDIF + ENDDO + ENDIF +! +! CALCULATE CLOUD WORK FUNCTION AT T+DT +! + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN + DZ1 = ZO(I,k) - ZO(I,k-1) + GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) + RFACT = 1. + DELTA * CP * GAMMA & + & * TO(I,k-1) / HVAP + AA1(I) = AA1(I) + & + & DZ1 * (G / (CP * TO(I,k-1))) & + & * DBYO(I,k-1) / (1. + GAMMA) & + & * RFACT + val = 0. + AA1(I)=AA1(I)+ & + & DZ1 * G * DELTA * & +!cmr & MAX( 0.,(QESO(I,k-1) - QO(I,k-1))) & + & MAX(val,(QESO(I,k-1) - QO(I,k-1))) + ENDIF + endif + ENDDO + ENDDO + DO I = 1, IM + IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I) = .FALSE. + IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE. + IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I) = .FALSE. + ENDDO +!! + TOTFLG = .TRUE. + DO I = 1, IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +!! +!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +!cccc PRINT *, ' AA1(I) BEFORE DWNDRFT =', AA1(I) +!cccc ENDIF +! +!------- DOWNDRAFT CALCULATIONS +! +! +!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR +! + DO I = 1, IM + IF(CNVFLG(I)) THEN + VSHEAR(I) = 0. + ENDIF + ENDDO + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN + shear=rcs(I) * sqrt((UO(I,k+1)-UO(I,k)) ** 2 & + & + (VO(I,k+1)-VO(I,k)) ** 2) + VSHEAR(I) = VSHEAR(I) + SHEAR + ENDIF + endif + ENDDO + ENDDO + DO I = 1, IM + EDT(I) = 0. + IF(CNVFLG(I)) THEN + KNUMB = KTCON(I) - KB(I) + 1 + KNUMB = MAX(KNUMB,1) + VSHEAR(I) = 1.E3 * VSHEAR(I) / (ZO(I,KTCON(I))-ZO(I,KB(I))) + E1=1.591-.639*VSHEAR(I) & + & +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3) + EDT(I)=1.-E1 +!cmr EDT(I) = MIN(EDT(I),.9) + val = .9 + EDT(I) = MIN(EDT(I),val) +!cmr EDT(I) = MAX(EDT(I),.0) + val = .0 + EDT(I) = MAX(EDT(I),val) + EDTO(I)=EDT(I) + EDTX(I)=EDT(I) + ENDIF + ENDDO +! DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR + DO I = 1, IM + KBDTR(I) = KBCON(I) + beta = betas + if(SLIMSK(I).eq.1.) beta = betal + IF(CNVFLG(I)) THEN + KBDTR(I) = KBCON(I) + KBDTR(I) = MAX(KBDTR(I),1) + XLAMD(I) = 0. + IF(KBDTR(I).GT.1) THEN + DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1) & + & - ZO(I,1) + XLAMD(I) = LOG(BETA) / DZ + ENDIF + ENDIF + ENDDO +! DETERMINE DOWNDRAFT MASS FLUX + DO K = 1, KM + DO I = 1, IM + IF(k .le. kmax(i)) then + IF(CNVFLG(I)) THEN + ETAD(I,k) = 1. + ENDIF + QRCDO(I,k) = 0. + endif + ENDDO + ENDDO + DO K = KM1, 2, -1 + DO I = 1, IM + if (k .le. kbmax(i)) then + IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) + ENDIF + endif + ENDDO + ENDDO + K = 1 + DO I = 1, IM + IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN + DZ = .5 * (ZO(I,2) - ZO(I,1)) + ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ) + ENDIF + ENDDO +! +!--- DOWNDRAFT MOISTURE PROPERTIES +! + DO I = 1, IM + PWEVO(I) = 0. + FLG(I) = CNVFLG(I) + ENDDO + DO I = 1, IM + IF(CNVFLG(I)) THEN + JMN = JMIN(I) + HCDO(I) = HEO(I,JMN) + QCDO(I) = QO(I,JMN) + QRCDO(I,JMN) = QESO(I,JMN) + UCDO(I) = UO(I,JMN) + VCDO(I) = VO(I,JMN) + ENDIF + ENDDO + DO K = KM1, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN + DQ = QESO(I,k) + DT = TO(I,k) + GAMMA = EL2ORC * DQ / DT**2 + DH = HCDO(I) - HESO(I,k) + QRCDO(I,k) = DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH + DETAD = ETAD(I,k+1) - ETAD(I,k) + PWDO(I,k) = ETAD(I,k+1) * QCDO(I) - & + & ETAD(I,k) * QRCDO(I,k) + PWDO(I,k) = PWDO(I,k) - DETAD * & + & .5 * (QRCDO(I,k) + QRCDO(I,k+1)) + QCDO(I) = QRCDO(I,k) + PWEVO(I) = PWEVO(I) + PWDO(I,k) + ENDIF + endif + ENDDO + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG(I)) THEN +! PRINT *, ' PWAVO(I), PWEVO(I) =', PWAVO(I), PWEVO(I) +! ENDIF +! +!--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP +!--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND +!--- EVAPORATE (PWEV) +! + DO I = 1, IM + edtmax = edtmaxl + if(SLIMSK(I).eq.0.) edtmax = edtmaxs + IF(DWNFLG2(I)) THEN + IF(PWEVO(I).LT.0.) THEN + EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I) + EDTO(I) = MIN(EDTO(I),EDTMAX) + ELSE + EDTO(I) = 0. + ENDIF + ELSE + EDTO(I) = 0. + ENDIF + ENDDO +! +! +!--- DOWNDRAFT CLOUDWORK FUNCTIONS +! +! + DO K = KM1, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN + GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 + DHH=HCDO(I) + DT=TO(I,k+1) + DG=GAMMA + DH=HESO(I,k+1) + DZ=-1.*(ZO(I,k+1)-ZO(I,k)) + AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & + & *(1.+DELTA*CP*DG*DT/HVAP) + val=0. + AA1(I)=AA1(I)+EDTO(I)* & +!cmr & DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1))) & + & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) + ENDIF + endif + ENDDO + ENDDO +!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN +!cccc PRINT *, ' AA1(I) AFTER DWNDRFT =', AA1(I) +!cccc ENDIF + DO I = 1, IM + IF(AA1(I).LE.0.) CNVFLG(I) = .FALSE. + IF(AA1(I).LE.0.) DWNFLG(I) = .FALSE. + IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE. + ENDDO +!! + TOTFLG = .TRUE. + DO I = 1, IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +!! +! +! +!--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS +!--- WILL DO TO THE ENVIRONMENT? +! + DO K = 1, KM + DO I = 1, IM + IF(k .le. kmax(i) .and. CNVFLG(I)) THEN + DELLAH(I,k) = 0. + DELLAQ(I,k) = 0. + DELLAU(I,k) = 0. + DELLAV(I,k) = 0. + ENDIF + ENDDO + ENDDO + DO I = 1, IM + IF(CNVFLG(I)) THEN + DP = 1000. * DEL(I,1) + DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I) & + & - HEO(I,1)) * G / DP + DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I) & + & - QO(I,1)) * G / DP + DELLAU(I,1) = EDTO(I) * ETAD(I,1) * (UCDO(I) & + & - UO(I,1)) * G / DP + DELLAV(I,1) = EDTO(I) * ETAD(I,1) * (VCDO(I) & + & - VO(I,1)) * G / DP + ENDIF + ENDDO +! +!--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT +! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN + AUP = 1. + IF(K.LE.KB(I)) AUP = 0. + ADW = 1. + IF(K.GT.JMIN(I)) ADW = 0. + DV1= HEO(I,k) + DV2 = .5 * (HEO(I,k) + HEO(I,k+1)) + DV3= HEO(I,k-1) + DV1Q= QO(I,k) + DV2Q = .5 * (QO(I,k) + QO(I,k+1)) + DV3Q= QO(I,k-1) + DV1U= UO(I,k) + DV2U = .5 * (UO(I,k) + UO(I,k+1)) + DV3U= UO(I,k-1) + DV1V= VO(I,k) + DV2V = .5 * (VO(I,k) + VO(I,k+1)) + DV3V= VO(I,k-1) + DP = 1000. * DEL(I,K) + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + DETA = ETA(I,k) - ETA(I,k-1) + DETAD = ETAD(I,k) - ETAD(I,k-1) + DELLAH(I,k) = DELLAH(I,k) + & + & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1 & + & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3 & + & - AUP * DETA * DV2 & + & + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP + DELLAQ(I,k) = DELLAQ(I,k) + & + & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1Q & + & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3Q & + & - AUP * DETA * DV2Q & + & +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,k)+QRCDO(I,k-1))) * G / DP + DELLAU(I,k) = DELLAU(I,k) + & + & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1U & + & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3U & + & - AUP * DETA * DV2U & + & + ADW * EDTO(I) * DETAD * UCDO(I) & + & ) * G / DP + DELLAV(I,k) = DELLAV(I,k) + & + & ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1V & + & - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3V & + & - AUP * DETA * DV2V & + & + ADW * EDTO(I) * DETAD * VCDO(I) & + & ) * G / DP + ENDIF + endif + ENDDO + ENDDO +! +!------- CLOUD TOP +! + DO I = 1, IM + IF(CNVFLG(I)) THEN + INDX = KTCON(I) + DP = 1000. * DEL(I,INDX) + DV1 = HEO(I,INDX-1) + DELLAH(I,INDX) = ETA(I,INDX-1) * & + & (HCKO(I,INDX-1) - DV1) * G / DP + DVQ1 = QO(I,INDX-1) + DELLAQ(I,INDX) = ETA(I,INDX-1) * & + & (QCKO(I,INDX-1) - DVQ1) * G / DP + DV1U = UO(I,INDX-1) + DELLAU(I,INDX) = ETA(I,INDX-1) * & + & (UCKO(I,INDX-1) - DV1U) * G / DP + DV1V = VO(I,INDX-1) + DELLAV(I,INDX) = ETA(I,INDX-1) * & + & (VCKO(I,INDX-1) - DV1V) * G / DP +! +! cloud water +! + DELLAL(I) = ETA(I,INDX-1) * QLKO_KTCON(I) * g / dp + ENDIF + ENDDO +! +!------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX +! + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).and.k.gt.KTCON(I)) THEN + QO(I,k) = Q1(I,k) + TO(I,k) = T1(I,k) + UO(I,k) = U1(I,k) + VO(I,k) = V1(I,k) + ENDIF + IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN + QO(I,k) = DELLAQ(I,k) * MBDT + Q1(I,k) + DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP + TO(I,k) = DELLAT * MBDT + T1(I,k) +!cmr QO(I,k) = max(QO(I,k),1.e-10) + val = 1.e-10 + QO(I,k) = max(QO(I,k), val ) + ENDIF + endif + ENDDO + ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE +!--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX) +!--- WOULD HAVE ON THE STABILITY, +!--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX, +!--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE +!--- DESTABILIZATION. +! +!--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS +! + DO K = 1, KM + DO I = 1, IM + IF(k .le. kmax(i) .and. CNVFLG(I)) THEN +!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) +! + QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa +! + QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k)+EPSM1*QESO(I,k)) +!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val ) + TVO(I,k) = TO(I,k) + DELTA * TO(I,k) * QO(I,k) + ENDIF + ENDDO + ENDDO + DO I = 1, IM + IF(CNVFLG(I)) THEN + XAA0(I) = 0. + XPWAV(I) = 0. + ENDIF + ENDDO +! +! HYDROSTATIC HEIGHT ASSUME ZERO TERR +! +! DO I = 1, IM +! IF(CNVFLG(I)) THEN +! DLNSIG = LOG(PRSL(I,1)/PS(I)) +! ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1) +! ENDIF +! ENDDO +! DO K = 2, KM +! DO I = 1, IM +! IF(k .le. kmax(i) .and. CNVFLG(I)) THEN +! DLNSIG = LOG(PRSL(I,K) / PRSL(I,K-1)) +! ZO(I,k) = ZO(I,k-1) - DLNSIG * RD / G +! & * .5 * (TVO(I,k) + TVO(I,k-1)) +! ENDIF +! ENDDO +! ENDDO +! +!--- MOIST STATIC ENERGY +! + DO K = 1, KM1 + DO I = 1, IM + IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k)) + DP = .5 * (PFLD(I,k+1) - PFLD(I,k)) +!jfe ES = 10. * FPVS(TO(I,k+1)) +! + ES = 0.01 * fpvs(TO(I,K+1)) ! fpvs is in Pa +! + PPRIME = PFLD(I,k+1) + EPSM1 * ES + QS = EPS * ES / PPRIME + DQSDP = - QS / PPRIME + DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2)) + DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME) + GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2) + DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA)) + DQ = DQSDT * DT + DQSDP * DP + TO(I,k) = TO(I,k+1) + DT + QO(I,k) = QO(I,k+1) + DQ + PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1)) + ENDIF + ENDDO + ENDDO + DO K = 1, KM1 + DO I = 1, IM + IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN +!jfe QESO(I,k) = 10. * FPVS(TO(I,k)) +! + QESO(I,k) = 0.01 * fpvs(TO(I,K)) ! fpvs is in Pa +! + QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1 * QESO(I,k)) +!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val1 = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val1) +!cmr QO(I,k) = max(QO(I,k),1.e-10) + val2 = 1.e-10 + QO(I,k) = max(QO(I,k), val2 ) +! QO(I,k) = MIN(QO(I,k),QESO(I,k)) + HEO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & + & CP * TO(I,k) + HVAP * QO(I,k) + HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) + & + & CP * TO(I,k) + HVAP * QESO(I,k) + ENDIF + ENDDO + ENDDO + DO I = 1, IM + k = kmax(i) + IF(CNVFLG(I)) THEN + HEO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QO(I,k) + HESO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QESO(I,k) +! HEO(I,k) = MIN(HEO(I,k),HESO(I,k)) + ENDIF + ENDDO + DO I = 1, IM + IF(CNVFLG(I)) THEN + INDX = KB(I) + XHKB(I) = HEO(I,INDX) + XQKB(I) = QO(I,INDX) + HCKO(I,INDX) = XHKB(I) + QCKO(I,INDX) = XQKB(I) + ENDIF + ENDDO +! +! +!**************************** STATIC CONTROL +! +! +!------- MOISTURE AND CLOUD WORK FUNCTIONS +! + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then +! IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN + IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN + FACTOR = ETA(I,k-1) / ETA(I,k) + ONEMF = 1. - FACTOR + HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF * & + & .5 * (HEO(I,k) + HEO(I,k+1)) + ENDIF +! IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN +! HEO(I,k) = HEO(I,k-1) +! ENDIF + endif + ENDDO + ENDDO + DO K = 2, KM1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN + DZ = .5 * (ZO(I,k+1) - ZO(I,k-1)) + GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2) + XDBY = HCKO(I,k) - HESO(I,k) +!cmr XDBY = MAX(XDBY,0.) + val = 0. + XDBY = MAX(XDBY,val) + XQRCH = QESO(I,k) & + & + GAMMA * XDBY / (HVAP * (1. + GAMMA)) + FACTOR = ETA(I,k-1) / ETA(I,k) + ONEMF = 1. - FACTOR + QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF * & + & .5 * (QO(I,k) + QO(I,k+1)) + DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * XQRCH + IF(DQ.GT.0.) THEN + ETAH = .5 * (ETA(I,k) + ETA(I,k-1)) + QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ) + XAA0(I) = XAA0(I) - (ZO(I,k) - ZO(I,k-1)) * G * QLK + XQC = QLK + XQRCH + XPW = ETAH * C0 * DZ * QLK + QCKO(I,k) = XQC + XPWAV(I) = XPWAV(I) + XPW + ENDIF + ENDIF +! IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN + IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN + DZ1 = ZO(I,k) - ZO(I,k-1) + GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2) + RFACT = 1. + DELTA * CP * GAMMA & + & * TO(I,k-1) / HVAP + XDBY = HCKO(I,k-1) - HESO(I,k-1) + XAA0(I) = XAA0(I) & + & + DZ1 * (G / (CP * TO(I,k-1))) & + & * XDBY / (1. + GAMMA) & + & * RFACT + val=0. + XAA0(I)=XAA0(I)+ & + & DZ1 * G * DELTA * & +!cmr & MAX( 0.,(QESO(I,k-1) - QO(I,k-1))) & + & MAX(val,(QESO(I,k-1) - QO(I,k-1))) + ENDIF + endif + ENDDO + ENDDO +!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +!cccc PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I) +!cccc ENDIF +! +!------- DOWNDRAFT CALCULATIONS +! +! +!--- DOWNDRAFT MOISTURE PROPERTIES +! + DO I = 1, IM + XPWEV(I) = 0. + ENDDO + DO I = 1, IM + IF(DWNFLG2(I)) THEN + JMN = JMIN(I) + XHCD(I) = HEO(I,JMN) + XQCD(I) = QO(I,JMN) + QRCD(I,JMN) = QESO(I,JMN) + ENDIF + ENDDO + DO K = KM1, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN + DQ = QESO(I,k) + DT = TO(I,k) + GAMMA = EL2ORC * DQ / DT**2 + DH = XHCD(I) - HESO(I,k) + QRCD(I,k)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH + DETAD = ETAD(I,k+1) - ETAD(I,k) + XPWD = ETAD(I,k+1) * QRCD(I,k+1) - & + & ETAD(I,k) * QRCD(I,k) + XPWD = XPWD - DETAD * & + & .5 * (QRCD(I,k) + QRCD(I,k+1)) + XPWEV(I) = XPWEV(I) + XPWD + ENDIF + endif + ENDDO + ENDDO +! + DO I = 1, IM + edtmax = edtmaxl + if(SLIMSK(I).eq.0.) edtmax = edtmaxs + IF(DWNFLG2(I)) THEN + IF(XPWEV(I).GE.0.) THEN + EDTX(I) = 0. + ELSE + EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I) + EDTX(I) = MIN(EDTX(I),EDTMAX) + ENDIF + ELSE + EDTX(I) = 0. + ENDIF + ENDDO +! +! +! +!--- DOWNDRAFT CLOUDWORK FUNCTIONS +! +! + DO K = KM1, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)-1) then + IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN + GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2 + DHH=XHCD(I) + DT= TO(I,k+1) + DG= GAMMA + DH= HESO(I,k+1) + DZ=-1.*(ZO(I,k+1)-ZO(I,k)) + XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) & + & *(1.+DELTA*CP*DG*DT/HVAP) + val=0. + XAA0(I)=XAA0(I)+EDTX(I)* & +!cmr & DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1))) & + & DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1))) + ENDIF + endif + ENDDO + ENDDO +!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN +!cccc PRINT *, ' XAA AFTER DWNDRFT =', XAA0(I) +!cccc ENDIF +! +! CALCULATE CRITICAL CLOUD WORK FUNCTION +! + DO I = 1, IM + ACRT(I) = 0. + IF(CNVFLG(I)) THEN +! IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN + IF(PFLD(I,KTCON(I)).LT.PCRIT(15))THEN + ACRT(I)=ACRIT(15)*(975.-PFLD(I,KTCON(I))) & + & /(975.-PCRIT(15)) + ELSE IF(PFLD(I,KTCON(I)).GT.PCRIT(1))THEN + ACRT(I)=ACRIT(1) + ELSE +!cmr K = IFIX((850. - PFLD(I,KTCON(I)))/50.) + 2 + K = int((850. - PFLD(I,KTCON(I)))/50.) + 2 + K = MIN(K,15) + K = MAX(K,2) + ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))* & + & (PFLD(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K)) + ENDIF +! ELSE +! ACRT(I) = .5 * (PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))) + ENDIF + ENDDO + DO I = 1, IM + ACRTFCT(I) = 1. + IF(CNVFLG(I)) THEN + if(SLIMSK(I).eq.1.) THEN + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + ENDIF +!C IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN +! ACRTFCT(I) = PDOT(I) / W3 +! +! modify critical cloud workfunction by cloud base vertical velocity +! + IF(PDOT(I).LE.W4) THEN + ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4) + ELSEIF(PDOT(I).GE.-W4) THEN + ACRTFCT(I) = - (PDOT(I) + W4) / (W4 - W3) + ELSE + ACRTFCT(I) = 0. + ENDIF +!cmr ACRTFCT(I) = MAX(ACRTFCT(I),-1.) + val1 = -1. + ACRTFCT(I) = MAX(ACRTFCT(I),val1) +!cmr ACRTFCT(I) = MIN(ACRTFCT(I),1.) + val2 = 1. + ACRTFCT(I) = MIN(ACRTFCT(I),val2) + ACRTFCT(I) = 1. - ACRTFCT(I) +! +! modify ACRTFCT(I) by colume mean rh if RHBAR(I) is greater than 80 percent +! +! if(RHBAR(I).ge..8) THEN +! ACRTFCT(I) = ACRTFCT(I) * (.9 - min(RHBAR(I),.9)) * 10. +! ENDIF +! +! modify adjustment time scale by cloud base vertical velocity +! + DTCONV(I) = DT2 + max((1800. - DT2),RZERO) * & + & (PDOT(I) - W2) / (W1 - W2) +! DTCONV(I) = MAX(DTCONV(I), DT2) +! DTCONV(I) = 1800. * (PDOT(I) - w2) / (w1 - w2) + DTCONV(I) = max(DTCONV(I),dtmin) + DTCONV(I) = min(DTCONV(I),dtmax) + + ENDIF + ENDDO +! +!--- LARGE SCALE FORCING +! + DO I= 1, IM + FLG(I) = CNVFLG(I) + IF(CNVFLG(I)) THEN +! F = AA1(I) / DTCONV(I) + FLD(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I) + IF(FLD(I).LE.0.) FLG(I) = .FALSE. + ENDIF + CNVFLG(I) = FLG(I) + IF(CNVFLG(I)) THEN +! XAA0(I) = MAX(XAA0(I),0.) + XK(I) = (XAA0(I) - AA1(I)) / MBDT + IF(XK(I).GE.0.) FLG(I) = .FALSE. + ENDIF +! +!--- KERNEL, CLOUD BASE MASS FLUX +! + CNVFLG(I) = FLG(I) + IF(CNVFLG(I)) THEN + XMB(I) = -FLD(I) / XK(I) + XMB(I) = MIN(XMB(I),XMBMAX(I)) + ENDIF + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN +! print *, ' RHBAR(I), ACRTFCT(I) =', RHBAR(I), ACRTFCT(I) +! PRINT *, ' A1, XA =', AA1(I), XAA0(I) +! PRINT *, ' XMB(I), ACRT =', XMB(I), ACRT +! ENDIF + TOTFLG = .TRUE. + DO I = 1, IM + TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I)) + ENDDO + IF(TOTFLG) RETURN +! +! restore t0 and QO to t1 and q1 in case convection stops +! + do k = 1, km + DO I = 1, IM + if (k .le. kmax(i)) then + TO(I,k) = T1(I,k) + QO(I,k) = Q1(I,k) +!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) +! + QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa +! + QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k)) +!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val ) + endif + enddo + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX +!--- MULTIPLIED BY THE MASS FLUX NECESSARY TO KEEP THE +!--- EQUILIBRIUM WITH THE LARGER-SCALE. +! + DO I = 1, IM + DELHBAR(I) = 0. + DELQBAR(I) = 0. + DELTBAR(I) = 0. + QCOND(I) = 0. + ENDDO + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN + AUP = 1. + IF(K.Le.KB(I)) AUP = 0. + ADW = 1. + IF(K.GT.JMIN(I)) ADW = 0. + DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP + T1(I,k) = T1(I,k) + DELLAT * XMB(I) * DT2 + Q1(I,k) = Q1(I,k) + DELLAQ(I,k) * XMB(I) * DT2 + U1(I,k) = U1(I,k) + DELLAU(I,k) * XMB(I) * DT2 + V1(I,k) = V1(I,k) + DELLAV(I,k) * XMB(I) * DT2 + DP = 1000. * DEL(I,K) + DELHBAR(I) = DELHBAR(I) + DELLAH(I,k)*XMB(I)*DP/G + DELQBAR(I) = DELQBAR(I) + DELLAQ(I,k)*XMB(I)*DP/G + DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G + ENDIF + endif + ENDDO + ENDDO + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN +!jfe QESO(I,k) = 10. * FPVS(T1(I,k)) +! + QESO(I,k) = 0.01 * fpvs(T1(I,K)) ! fpvs is in Pa +! + QESO(I,k) = EPS * QESO(I,k)/(PFLD(I,k) + EPSM1*QESO(I,k)) +!cmr QESO(I,k) = MAX(QESO(I,k),1.E-8) + val = 1.E-8 + QESO(I,k) = MAX(QESO(I,k), val ) +! +! cloud water +! + if(ncloud.gt.0.and.CNVFLG(I).and.k.eq.KTCON(I)) THEN + tem = DELLAL(I) * XMB(I) * dt2 + tem1 = MAX(RZERO, MIN(RONE, (TCR-t1(I,K))*TCRF)) + if (QL(I,k,2) .gt. -999.0) then + QL(I,k,1) = QL(I,k,1) + tem * tem1 ! Ice + QL(I,k,2) = QL(I,k,2) + tem *(1.0-tem1) ! Water + else + tem2 = QL(I,k,1) + tem + QL(I,k,1) = tem2 * tem1 ! Ice + QL(I,k,2) = tem2 - QL(I,k,1) ! Water + endif +! QL(I,k) = QL(I,k) + DELLAL(I) * XMB(I) * dt2 + dp = 1000. * del(i,k) + DELLAL(I) = DELLAL(I) * XMB(I) * dp / g + ENDIF + ENDIF + endif + ENDDO + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN +! PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' +! PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR +! PRINT *, ' DELLBAR =' +! PRINT 6003, HVAP*DELLbar +! PRINT *, ' DELLAQ =' +! PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) +! PRINT *, ' DELLAT =' +! PRINT 6003, (DELLAH(i,k)*XMB(I)-HVAP*DELLAQ(I,k)*XMB(I), & +! & K=1,KMAX) +! ENDIF + DO I = 1, IM + RNTOT(I) = 0. + DELQEV(I) = 0. + DELQ2(I) = 0. + FLG(I) = CNVFLG(I) + ENDDO + DO K = KM, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN + AUP = 1. + IF(K.Le.KB(I)) AUP = 0. + ADW = 1. + IF(K.GT.JMIN(I)) ADW = 0. + rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) + RNTOT(I) = RNTOT(I) + rain * XMB(I) * .001 * dt2 + ENDIF + endif + ENDDO + ENDDO + DO K = KM, 1, -1 + DO I = 1, IM + if (k .le. kmax(i)) then + DELTV(I) = 0. + DELQ(I) = 0. + QEVAP(I) = 0. + IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN + AUP = 1. + IF(K.Le.KB(I)) AUP = 0. + ADW = 1. + IF(K.GT.JMIN(I)) ADW = 0. + rain = AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k) + RN(I) = RN(I) + rain * XMB(I) * .001 * dt2 + ENDIF + IF(FLG(I).AND.K.LE.KTCON(I)) THEN + evef = EDT(I) * evfact + if(SLIMSK(I).eq.1.) evef=EDT(I) * evfactl +! if(SLIMSK(I).eq.1.) evef=.07 +! if(SLIMSK(I).ne.1.) evef = 0. + QCOND(I) = EVEF * (Q1(I,k) - QESO(I,k)) & + & / (1. + EL2ORC * QESO(I,k) / T1(I,k)**2) + DP = 1000. * DEL(I,K) + IF(RN(I).GT.0..AND.QCOND(I).LT.0.) THEN + QEVAP(I) = -QCOND(I) * (1.-EXP(-.32*SQRT(DT2*RN(I)))) + QEVAP(I) = MIN(QEVAP(I), RN(I)*1000.*G/DP) + DELQ2(I) = DELQEV(I) + .001 * QEVAP(I) * dp / g + ENDIF + if(RN(I).gt.0..and.QCOND(I).LT.0..and. & + & DELQ2(I).gt.RNTOT(I)) THEN + QEVAP(I) = 1000.* g * (RNTOT(I) - DELQEV(I)) / dp + FLG(I) = .false. + ENDIF + IF(RN(I).GT.0..AND.QEVAP(I).gt.0.) THEN + Q1(I,k) = Q1(I,k) + QEVAP(I) + T1(I,k) = T1(I,k) - ELOCP * QEVAP(I) + RN(I) = RN(I) - .001 * QEVAP(I) * DP / G + DELTV(I) = - ELOCP*QEVAP(I)/DT2 + DELQ(I) = + QEVAP(I)/DT2 + DELQEV(I) = DELQEV(I) + .001*dp*QEVAP(I)/g + ENDIF + DELLAQ(I,k) = DELLAQ(I,k) + DELQ(I) / XMB(I) + DELQBAR(I) = DELQBAR(I) + DELQ(I)*DP/G + DELTBAR(I) = DELTBAR(I) + DELTV(I)*DP/G + ENDIF + endif + ENDDO + ENDDO +! IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN +! PRINT *, ' DELLAH =' +! PRINT 6003, (DELLAH(k)*XMB(I),K=1,KMAX) +! PRINT *, ' DELLAQ =' +! PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX) +! PRINT *, ' DELHBAR, DELQBAR, DELTBAR =' +! PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR +! PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2 +!CCCC PRINT *, ' DELLBAR =' +!CCCC PRINT *, HVAP*DELLbar +! ENDIF +! +! PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP +! IN UNIT OF M INSTEAD OF KG +! + DO I = 1, IM + IF(CNVFLG(I)) THEN +! +! IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF +! MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH +! HEATING AND THE MOISTENING +! + if(RN(I).lt.0..and..not.FLG(I)) RN(I) = 0. + IF(RN(I).LE.0.) THEN + RN(I) = 0. + ELSE + KTOP(I) = KTCON(I) + KBOT(I) = KBCON(I) + KUO(I) = 1 + CLDWRK(I) = AA1(I) + ENDIF + ENDIF + ENDDO + DO K = 1, KM + DO I = 1, IM + if (k .le. kmax(i)) then + IF(CNVFLG(I).AND.RN(I).LE.0.) THEN + T1(I,k) = TO(I,k) + Q1(I,k) = QO(I,k) + ENDIF + endif + ENDDO + ENDDO +!! + RETURN + END SUBROUTINE SASCNV + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & + &, RD => con_RD + + implicit none +! +! include 'constant.h' +! + integer IM, IX, KM, KUO(IM) + real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), & + & PRSLK(IX,KM), & + & Q(IX,KM), T(IX,KM), DT, DPSHC +! +! Locals +! + real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, & + & dsig, dtodsl, dtodsu, eldq, g, & + & gocp, rtdls +! + integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii + integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk & + &, KTOPM(IM) +!! +! PHYSICAL PARAMETERS + PARAMETER(G=GRAV, GOCP=G/CP) +! BOUNDS OF PARCEL ORIGIN + PARAMETER(KLIFTL=2,KLIFTU=2) + LOGICAL LSHC(IM) + real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), & + & PRSL2(IM*KM), PRSLK2(IM*KM), & + & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) +!----------------------------------------------------------------------- +! COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION +! AND MOIST STATIC INSTABILITY. + DO I=1,IM + LSHC(I)=.FALSE. + ENDDO + DO K=1,KM-1 + DO I=1,IM + IF(KUO(I).EQ.0) THEN + ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) + CPDT = CP*(T(I,K)-T(I,K+1)) + RTDLS = (PRSL(I,K)-PRSL(I,K+1)) / & + & PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1)) + DMSE = ELDQ+CPDT-RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + ENDIF + ENDDO + ENDDO + N2 = 0 + DO I=1,IM + IF(LSHC(I)) THEN + N2 = N2 + 1 + INDEX2(N2) = I + ENDIF + ENDDO + IF(N2.EQ.0) RETURN + DO K=1,KM + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + ii = index2(i) + Q2(IK) = Q(II,K) + T2(IK) = T(II,K) + PRSL2(IK) = PRSL(II,K) + PRSLK2(IK) = PRSLK(II,K) + ENDDO + ENDDO + do i=1,N2 + ktopm(i) = KM + enddo + do k=2,KM + do i=1,N2 + ii = index2(i) + if (prsi(ii,1)-prsi(ii,k) .le. dpshc) ktopm(i) = k + enddo + enddo + +!----------------------------------------------------------------------- +! COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. +! CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. + CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, & + & KLCL,KBOT,KTOP,AL,AU) + DO I=1,N2 + KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) + KTOP(I) = min(KTOP(I)+1, ktopm(i)) + LSHC(I) = .FALSE. + ENDDO + DO K=1,KM-1 + KK = (K-1)*N2 + DO I=1,N2 + IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN + IK = KK + I + IKU = IK + N2 + ELDQ = HVAP * (Q2(IK)-Q2(IKU)) + CPDT = CP * (T2(IK)-T2(IKU)) + RTDLS = (PRSL2(IK)-PRSL2(IKU)) / & + & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) + DMSE = ELDQ + CPDT - RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + AU(IK) = G/RTDLS + ENDIF + ENDDO + ENDDO + K1=KM+1 + K2=0 + DO I=1,N2 + IF(.NOT.LSHC(I)) THEN + KBOT(I) = KM+1 + KTOP(I) = 0 + ENDIF + K1 = MIN(K1,KBOT(I)) + K2 = MAX(K2,KTOP(I)) + ENDDO + KT = K2-K1+1 + IF(KT.LT.2) RETURN +!----------------------------------------------------------------------- +! SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. +! COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. +! EXPAND FINAL FIELDS. + KK = (K1-1) * N2 + DO I=1,N2 + IK = KK + I + AD(IK) = 1. + ENDDO +! +! DTODSU=DT/DEL(K1) + DO K=K1,K2-1 +! DTODSL=DTODSU +! DTODSU= DT/DEL(K+1) +! DSIG=SL(K)-SL(K+1) + KK = (K-1) * N2 + DO I=1,N2 + ii = index2(i) + DTODSL = DT/DEL(II,K) + DTODSU = DT/DEL(II,K+1) + DSIG = PRSL(II,K) - PRSL(II,K+1) + IK = KK + I + IKU = IK + N2 + IF(K.EQ.KBOT(I)) THEN + CK=1.5 + ELSEIF(K.EQ.KTOP(I)-1) THEN + CK=1. + ELSEIF(K.EQ.KTOP(I)-2) THEN + CK=3. + ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN + CK=5. + ELSE + CK=0. + ENDIF + DSDZ1 = CK*DSIG*AU(IK)*GOCP + DSDZ2 = CK*DSIG*AU(IK)*AU(IK) + AU(IK) = -DTODSL*DSDZ2 + AL(IK) = -DTODSU*DSDZ2 + AD(IK) = AD(IK)-AU(IK) + AD(IKU) = 1.-AL(IK) + T2(IK) = T2(IK)+DTODSL*DSDZ1 + T2(IKU) = T2(IKU)-DTODSU*DSDZ1 + ENDDO + ENDDO + IK1=(K1-1)*N2+1 + CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), & + & AU(IK1),Q2(IK1),T2(IK1)) + DO K=K1,K2 + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + Q(INDEX2(I),K) = Q2(IK) + T(INDEX2(I),K) = T2(IK) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE SHALCV +!----------------------------------------------------------------------- + SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2) +!yt INCLUDE DBTRIDI2; +!! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer k,n,l,i + real(kind=kind_phys) fk +!! + real(kind=kind_phys) & + & CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), & + & AU(L,N-1),A1(L,N),A2(L,N) +!----------------------------------------------------------------------- + DO I=1,L + FK=1./CM(I,1) + AU(I,1)=FK*CU(I,1) + A1(I,1)=FK*R1(I,1) + A2(I,1)=FK*R2(I,1) + ENDDO + DO K=2,N-1 + DO I=1,L + FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K)=FK*CU(I,K) + A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) + A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) + ENDDO + ENDDO + DO I=1,L + FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) + A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) + ENDDO + DO K=N-1,1,-1 + DO I=1,L + A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1) + A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE TRIDI2T3 +!----------------------------------------------------------------------- + + SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV, & + & KLCL,KBOT,KTOP,TCLD,QCLD) +!yt INCLUDE DBMSTADB; +!! + USE MODULE_GFS_MACHINE, ONLY : kind_phys + USE MODULE_GFS_FUNCPHYS, ONLY : FTDP, FTHE, FTLCL, STMA + USE MODULE_GFS_PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt + + implicit none +!! +! include 'constant.h' +!! + integer k,k1,k2,km,i,im + real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl + real(kind=kind_phys) tma,tvcld,tvenv +!! + real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), & + & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) + INTEGER KLCL(IM), KBOT(IM), KTOP(IM) +! LOCAL ARRAYS + real(kind=kind_phys) SLKMA(IM), THEMA(IM) +!----------------------------------------------------------------------- +! DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. +! COMPUTE ITS LIFTING CONDENSATION LEVEL. +! + DO I=1,IM + SLKMA(I) = 0. + THEMA(I) = 0. + ENDDO + DO K=K1,K2 + DO I=1,IM + PV = 1000.0 * PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) + TDPD = TENV(I,K)-FTDP(PV) + IF(TDPD.GT.0.) THEN + TLCL = FTLCL(TENV(I,K),TDPD) + SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) + ELSE + TLCL = TENV(I,K) + SLKLCL = PRSLK(I,K) + ENDIF + THELCL=FTHE(TLCL,SLKLCL) + IF(THELCL.GT.THEMA(I)) THEN + SLKMA(I) = SLKLCL + THEMA(I) = THELCL + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- +! SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP +! THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. + DO I=1,IM + KLCL(I)=KM+1 + KBOT(I)=KM+1 + KTOP(I)=0 + ENDDO + DO K=1,KM + DO I=1,IM + TCLD(I,K)=0. + QCLD(I,K)=0. + ENDDO + ENDDO + DO K=K1,KM + DO I=1,IM + IF(PRSLK(I,K).LE.SLKMA(I)) THEN + KLCL(I)=MIN(KLCL(I),K) + CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) +! TMA=FTMA(THEMA(I),PRSLK(I,K),QMA) + TVCLD=TMA*(1.+FV*QMA) + TVENV=TENV(I,K)*(1.+FV*QENV(I,K)) + IF(TVCLD.GT.TVENV) THEN + KBOT(I)=MIN(KBOT(I),K) + KTOP(I)=MAX(KTOP(I),K) + TCLD(I,K)=TMA-TENV(I,K) + QCLD(I,K)=QMA-QENV(I,K) + ENDIF + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END SUBROUTINE MSTADBT3 + + END MODULE module_cu_sas diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F new file mode 100644 index 00000000..7dc7c2ff --- /dev/null +++ b/wrfv2_fire/phys/module_cumulus_driver.F @@ -0,0 +1,465 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_cumulus_driver +CONTAINS + SUBROUTINE cumulus_driver( & + ! Order dependent args for domain, mem, and tile dims + ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,i_start,i_end,j_start,j_end,kts,kte,num_tiles & + ! Order independent args (use VAR= in call) + ! --Prognostic + ,u,v,th,t,w & + ,p,pi,rho & + ! --Other arguments + ,itimestep,dt,dx & + ,rainc,raincv,nca & + ,dz8w,p8w,forcet,forceq & + ,w0avg,stepcu,gsw & + ,cldefi,lowlyr,xland,cu_act_flag,warm_rain & + ,htop,hbot,kpbl,ht & + ,ensdim,maxiens,maxens,maxens2,maxens3 & + ! Package selection variable + ,cu_physics & + ! Optional moisture tracers + ,qv_curr, qc_curr, qr_curr & + ,qi_curr, qs_curr, qg_curr & + ,qv_prev, qc_prev, qr_prev & + ,qi_prev, qs_prev, qg_prev & + ! Optional arguments for GD scheme + ,apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & + ,apr_capme,apr_capmi & + ,mass_flux,xf_ens,pr_ens & + ,gd_cloud,gd_cloud2 & + ! Optional moisture and other tendencies + ,rqvcuten,rqccuten,rqrcuten & + ,rqicuten,rqscuten,rqgcuten & + ,rqvblten,rqvften & + ,rthcuten,rthraten,rthblten,rthften & + ! Optional moisture tracer flags + ,f_qv,f_qc,f_qr & + ,f_qi,f_qs,f_qg & + ) +!---------------------------------------------------------------------- + USE module_model_constants + USE module_state_description, ONLY: KFSCHEME,BMJSCHEME & + ,KFETASCHEME,GDSCHEME & + ,SASSCHEME + +! *** add new modules of schemes here + + USE module_cu_kf + USE module_cu_bmj + USE module_cu_kfeta + USE module_cu_gd + USE module_cu_sas + + ! This driver calls subroutines for the cumulus parameterizations. + ! + ! 1. Kain & Fritsch (1993) + ! 2. Betts-Miller-Janjic (Janjic, 1994) + ! +!---------------------------------------------------------------------- + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +! Rho_d dry density (kg/m^3) +! Theta_m moist potential temperature (K) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +!----------------------------------------------------------------- +!-- DT time step (second) +!-- itimestep number of time step (integer) +!-- DX horizontal space interval (m) +!-- rr dry air density (kg/m^3) +! +!-- RTHCUTEN Theta tendency due to +! cumulus scheme precipitation (K/s) +!-- RQVCUTEN Qv tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- RQRCUTEN Qr tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- RQCCUTEN Qc tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- RQSCUTEN Qs tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- RQICUTEN Qi tendency due to +! cumulus scheme precipitation (kg/kg/s) +! +!-- RAINC accumulated total cumulus scheme precipitation (mm) +!-- RAINCV cumulus scheme precipitation (mm) +!-- NCA counter of the cloud relaxation +! time in KF cumulus scheme (integer) +!-- u_phy u-velocity interpolated to theta points (m/s) +!-- v_phy v-velocity interpolated to theta points (m/s) +!-- th_phy potential temperature (K) +!-- t_phy temperature (K) +!-- w vertical velocity (m/s) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- dz8w dz between full levels (m) +!-- p8w pressure at full levels (Pa) +!-- p_phy pressure (Pa) +!-- pi_phy exner function (dimensionless) +! points (dimensionless) +!-- RTHRATEN radiative temp forcing for Grell-Devenyi scheme +!-- RTHBLTEN PBL temp forcing for Grell-Devenyi scheme +!-- RQVBLTEN PBL moisture forcing for Grell-Devenyi scheme +!-- RTHFTEN +!-- RQVFTEN +!-- MASS_FLUX +!-- XF_ENS +!-- PR_ENS +!-- warm_rain +!-- CU_ACT_FLAG +!-- W0AVG average vertical velocity, (for KF scheme) (m/s) +!-- rho density (kg/m^3) +!-- CLDEFI precipitation efficiency (for BMJ scheme) (dimensionless) +!-- STEPCU # of fundamental timesteps between convection calls +!-- XLAND land-sea mask (1.0 for land; 2.0 for water) +!-- LOWLYR index of lowest model layer above the ground +!-- XLV0 latent heat of vaporization constant +! used in temperature dependent formula (J/kg) +!-- XLV1 latent heat of vaporization constant +! used in temperature dependent formula (J/kg/K) +!-- XLS0 latent heat of sublimation constant +! used in temperature dependent formula (J/kg) +!-- XLS1 latent heat of sublimation constant +! used in temperature dependent formula (J/kg/K) +!-- R_d gas constant for dry air ( 287. J/kg/K) +!-- R_v gas constant for water vapor (461 J/k/kg) +!-- Cp specific heat at constant pressure (1004 J/k/kg) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- G acceleration due to gravity (m/s^2) +!-- EP_1 constant for virtual temperature +! (R_v/R_d - 1) (dimensionless) +!-- pi_phy the exner function, (p/p0)**(R/Cp) (none unit) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- i_start start indices for i in tile +!-- i_end end indices for i in tile +!-- j_start start indices for j in tile +!-- j_end end indices for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- num_tiles number of tiles +!-- HBOT index of lowest model layer with convection +!-- HTOP index of highest model layer with convection +!-- LBOT index of lowest model layer with convection +!-- LTOP index of highest model layer with convection +!-- KPBL layer index of the PBL +! +!====================================================================== + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + kts,kte, & + itimestep, num_tiles + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, INTENT(IN ) :: & + ensdim,maxiens,maxens,maxens2,maxens3 + + INTEGER, INTENT(IN ) :: cu_physics + INTEGER, INTENT(IN ) :: STEPCU + LOGICAL, INTENT(IN ) :: warm_rain + + INTEGER,DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: LOWLYR + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: & + dz8w & + , p8w & + , p & + , pi & + , u & + , v & + , th & + , t & + , rho & + , w + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: & + W0AVG + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: & + GSW,HT,XLAND + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINC & + , RAINCV & + , NCA & + , HTOP & + , HBOT & + , CLDEFI + + + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN) :: KPBL + + + LOGICAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: CU_ACT_FLAG + + REAL, INTENT(IN ) :: DT, DX + +! +! optional arguments +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + ! optional moisture tracers + ! 2 time levels; if only one then use CURR + qv_curr, qc_curr, qr_curr & + ,qi_curr, qs_curr, qg_curr & + ,qv_prev, qc_prev, qr_prev & + ,qi_prev, qs_prev, qg_prev & + ! optional moisture and other tendencies + ,rqvcuten,rqccuten,rqrcuten & + ,rqicuten,rqscuten,rqgcuten & + ,rqvblten,rqvften & + ,rthraten,rthblten & + , forcet & + , forceq & + ,rthften,rthcuten + + REAL, DIMENSION( ims:ime , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & + ,apr_capme,apr_capmi & + , MASS_FLUX + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + GD_CLOUD,GD_CLOUD2 + REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ), & + OPTIONAL, & + INTENT(INOUT) :: XF_ENS, PR_ENS + +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, INTENT(IN), OPTIONAL :: & + f_qv & + ,f_qc & + ,f_qr & + ,f_qi & + ,f_qs & + ,f_qg + + +! LOCAL VAR + + INTEGER :: i,j,k,its,ite,jts,jte,ij + +!----------------------------------------------------------------- + + IF (cu_physics .eq. 0) return + +! DON'T JUDGE TIME STEP HERE, SINCE KF NEEDS ACCUMULATED W FIELD. +! DO IT INSIDE THE INDIVIDUAL CUMULUS SCHEME + +! SET START AND END POINTS FOR TILES + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ,its,ite,jts,jte, i,j,k) + + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + + + cps_select: SELECT CASE(cu_physics) + + CASE (KFSCHEME) + CALL wrf_debug(100,'in kfcps') + + CALL KFCPS( & + ! order independent arguments + DT=dt ,KTAU=itimestep ,DX=dx ,RHO=rho & + ,U=u ,V=v ,TH=th ,T=t ,W=w & + ,PCPS=p ,PI=pi & + ,XLV0=xlv0 ,XLV1=xlv1 ,XLS0=xls0 ,XLS1=xls1 & + ,RAINCV=raincv ,NCA=nca & + ,DZ8W=dz8w & + ,W0AVG=w0avg & + ,CP=cp ,R=r_d ,G=g ,EP1=ep_1 ,EP2=ep_2 & + ,SVP1=svp1 ,SVP2=svp2 ,SVP3=svp3 ,SVPT0=svpt0 & + ,STEPCU=stepcu & + ,CU_ACT_FLAG=cu_act_flag & + ,WARM_RAIN=warm_rain & + ,QV=qv_curr & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals + ,RTHCUTEN=rthcuten ,RQVCUTEN=rqvcuten & + ,RQCCUTEN=rqccuten ,RQRCUTEN=rqrcuten & + ,RQICUTEN=rqicuten ,RQSCUTEN=rqscuten & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + + CASE (BMJSCHEME) + CALL wrf_debug(100,'in bmj_cps') + CALL BMJDRV( & + TH=th,T=T ,RAINCV=raincv, RHO=rho & + ,DT=dt ,ITIMESTEP=itimestep ,STEPCU=stepcu & + ,CUTOP=htop, CUBOT=hbot, KPBL=kpbl & + ,DZ8W=dz8w ,PINT=p8w, PMID=p, PI=pi & + ,CP=cp ,R=r_d ,ELWV=xlv ,ELIV=xls ,G=g & + ,TFRZ=svpt0 ,D608=ep_1 ,CLDEFI=cldefi & + ,LOWLYR=lowlyr ,XLAND=xland & + ,CU_ACT_FLAG=cu_act_flag & + ,QV=qv_curr & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals + ,RTHCUTEN=rthcuten ,RQVCUTEN=rqvcuten & + ) + + CASE (KFETASCHEME) + CALL wrf_debug(100,'in kf_eta_cps') + CALL KF_ETA_CPS( & + U=u ,V=v ,TH=th ,T=t ,W=w ,RHO=rho & + ,RAINCV=raincv, NCA=nca ,DZ8W=dz8w & + ,PCPS=p, PI=pi ,W0AVG=W0AVG & + ,CUTOP=HTOP,CUBOT=HBOT & + ,XLV0=XLV0 ,XLV1=XLV1 ,XLS0=XLS0 ,XLS1=XLS1 & + ,CP=CP ,R=R_d ,G=G ,EP1=EP_1 ,EP2=EP_2 & + ,SVP1=SVP1 ,SVP2=SVP2 ,SVP3=SVP3 ,SVPT0=SVPT0 & + ,DT=dt ,KTAU=itimestep ,DX=dx & + ,STEPCU=stepcu & + ,CU_ACT_FLAG=cu_act_flag ,warm_rain=warm_rain & + ,QV=qv_curr & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals + ,RTHCUTEN=rthcuten & + ,RQVCUTEN=rqvcuten ,RQCCUTEN=rqccuten & + ,RQRCUTEN=rqrcuten ,RQICUTEN=rqicuten & + ,RQSCUTEN=rqscuten & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + + CASE (GDSCHEME) + CALL wrf_debug(100,'in grelldrv') + CALL GRELLDRV( & + DT=dt, ITIMESTEP=itimestep, DX=dx & + ,U=u,V=v,T=t,W=w ,RHO=rho & + ,P=p,PI=pi ,Q=qv_curr ,RAINCV=raincv & + ,DZ8W=dz8w,P8W=p8w,XLV=xlv,CP=cp,G=g,R_V=r_v & + ,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc & + ,APR_ST=apr_st,APR_AS=apr_as & + ,APR_CAPMA=apr_capma,APR_CAPME=apr_capme & + ,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux & + ,XF_ENS=xf_ens,PR_ENS=pr_ens,HT=ht & + ,xland=xland,gsw=gsw & + ,GDC=gd_cloud,GDC2=gd_cloud2 & + ,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens & + ,MAXENS2=maxens2,MAXENS3=maxens3 & + ,STEPCU=STEPCU,htop=htop,hbot=hbot & + ,CU_ACT_FLAG=CU_ACT_FLAG,warm_rain=warm_rain & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals +#if (NMM_CORE == 1 ) + ,RTHCUTEN=RTHCUTEN ,RTHFTEN=forcet & + ,RQICUTEN=RQICUTEN ,RQVFTEN=forceq & +#else + ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN & + ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN & +#endif + ,RTHRATEN=RTHRATEN,RTHBLTEN=RTHBLTEN & + ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN & + ,RQVBLTEN=RQVBLTEN & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + CASE (SASSCHEME) + + CALL wrf_debug(100,'in cu_sas') + CALL CU_SAS( & + DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU & + ,RAINCV=RAINCV,HTOP=HTOP,HBOT=HBOT & + ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & + ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR & + ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND & + ,CU_ACT_FLAG=CU_ACT_FLAG & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals + ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN & + ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + + CASE DEFAULT + + WRITE( wrf_err_message , * ) 'The cumulus option does not exist: cu_physics = ', cu_physics + CALL wrf_error_fatal ( wrf_err_message ) + + END SELECT cps_select + + ENDDO + !$OMP END PARALLEL DO + + END SUBROUTINE cumulus_driver + +END MODULE module_cumulus_driver diff --git a/wrfv2_fire/phys/module_diagnostics.F b/wrfv2_fire/phys/module_diagnostics.F new file mode 100644 index 00000000..6b6af920 --- /dev/null +++ b/wrfv2_fire/phys/module_diagnostics.F @@ -0,0 +1,256 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_diagnostics +CONTAINS + SUBROUTINE diagnostic_output_calc( & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + i_start,i_end,j_start,j_end,kts,kte,num_tiles & + ,dpsdt,dmudt & + ,p_phy,pk1m,mu_2,mu_2m & + ,u,v & + ,raincv,rainncv,rainc,rainnc & + ,hfx,sfcevp,lh & + ,dt,xtime,sbw & + ,diag_print & + ) +!---------------------------------------------------------------------- + + USE module_dm + + IMPLICIT NONE +!====================================================================== +! Definitions +!----------- +!-- DIAG_PRINT print control: 0 - no diagnostics; 1 - dmudt only; 2 - all +!-- DT time step (second) +!-- XTIME forecast time +!-- SBW specified boundary width - used later +! +!-- P_PHY 3D pressure array +!-- MU dry column hydrostatic pressure +!-- RAINC cumulus scheme precipitation since hour 0 +!-- RAINCV cumulus scheme precipitation in one time step (mm) +!-- RAINNC explicit scheme precipitation since hour 0 +!-- RAINNCV explicit scheme precipitation in one time step (mm) +!-- HFX surface sensible heat flux +!-- LH surface latent heat flux +!-- SFCEVP total surface evaporation +!-- U u component of wind - to be used later to compute k.e. +!-- V v component of wind - to be used later to compute k.e. +! +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- ips start index for i in patch +!-- ipe end index for i in patch +!-- jps start index for j in patch +!-- jpe end index for j in patch +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- i_start start indices for i in tile +!-- i_end end indices for i in tile +!-- j_start start indices for j in tile +!-- j_end end indices for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- num_tiles number of tiles +! +!====================================================================== + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + kts,kte, & + num_tiles + + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, INTENT(IN ) :: diag_print + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: u & + , v & + , p_phy + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: & + MU_2 & + , RAINC & + , RAINNC & + , RAINCV & + , RAINNCV & + , HFX & + , SFCEVP & + , LH + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: DPSDT & + , DMUDT & + , MU_2M & + , PK1M + + REAL, INTENT(IN ) :: DT, XTIME + INTEGER, INTENT(IN ) :: SBW + +! LOCAL VAR + + INTEGER :: i,j,k,its,ite,jts,jte,ij + + REAL :: no_points + REAL :: dpsdt_sum, dmudt_sum, dardt_sum, drcdt_sum, drndt_sum + REAL :: hfx_sum, lh_sum, sfcevp_sum, rainc_sum, rainnc_sum, raint_sum + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*256 :: outstring + CHARACTER*6 :: grid_str + +!----------------------------------------------------------------- + + if (diag_print .eq. 0 ) return + + IF ( xtime .gt. 0. ) THEN + +! COMPUTE THE NUMBER OF MASS GRID POINTS + no_points = float((ide-ids)*(jde-jds)) + +! SET START AND END POINTS FOR TILES +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + + DO ij = 1 , num_tiles + +! print *, i_start(ij),i_end(ij),j_start(ij),j_end(ij) + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + dpsdt(i,j)=(p_phy(i,kms,j)-pk1m(i,j))/dt + dmudt(i,j)=(mu_2(i,j)-mu_2m(i,j))/dt + ENDDO + ENDDO + + ENDDO +! !$OMP END PARALLEL DO + +! print *, 'p_phy(30,1,30),pk1m(30,30) : ', p_phy(30,1,30),pk1m(30,30) +! print *, 'mu_2(30,30),mu_2m(30,30) : ', mu_2(30,30),mu_2m(30,30) + dpsdt_sum = 0. + dmudt_sum = 0. + + DO j = jps, min(jpe,jde-1) + DO i = ips, min(ipe,ide-1) + dpsdt_sum = dpsdt_sum + abs(dpsdt(i,j)) + dmudt_sum = dmudt_sum + abs(dmudt(i,j)) + ENDDO + ENDDO + +! compute global sum + dpsdt_sum = wrf_dm_sum_real ( dpsdt_sum ) + dmudt_sum = wrf_dm_sum_real ( dmudt_sum ) + +! print *, 'dpsdt, dmudt : ', dpsdt_sum, dmudt_sum + + IF ( diag_print .eq. 2 ) THEN + dardt_sum = 0. + drcdt_sum = 0. + drndt_sum = 0. + sfcevp_sum = 0. + hfx_sum = 0. + lh_sum = 0. + + DO j = jps, min(jpe,jde-1) + DO i = ips, min(ipe,ide-1) + drcdt_sum = drcdt_sum + abs(raincv(i,j)) + drndt_sum = drndt_sum + abs(rainncv(i,j)) + dardt_sum = dardt_sum + abs(raincv(i,j)) + abs(rainncv(i,j)) + rainc_sum = rainc_sum + abs(rainc(i,j)) + rainnc_sum = rainnc_sum + abs(rainnc(i,j)) + raint_sum = raint_sum + abs(rainc(i,j)) + abs(rainnc(i,j)) + sfcevp_sum = sfcevp_sum + abs(sfcevp(i,j)) + hfx_sum = hfx_sum + abs(hfx(i,j)) + lh_sum = lh_sum + abs(lh(i,j)) + ENDDO + ENDDO + +! compute global sum + drcdt_sum = wrf_dm_sum_real ( drcdt_sum ) + drndt_sum = wrf_dm_sum_real ( drndt_sum ) + dardt_sum = wrf_dm_sum_real ( dardt_sum ) + rainc_sum = wrf_dm_sum_real ( rainc_sum ) + rainnc_sum = wrf_dm_sum_real ( rainnc_sum ) + raint_sum = wrf_dm_sum_real ( raint_sum ) + sfcevp_sum = wrf_dm_sum_real ( sfcevp_sum ) + hfx_sum = wrf_dm_sum_real ( hfx_sum ) + lh_sum = wrf_dm_sum_real ( lh_sum ) + + ENDIF + +! print out the average values + + CALL get_current_grid_name( grid_str ) + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN +#endif + WRITE(outstring,*) grid_str,'Domain average of dpsdt, dmudt (Pa/sec): ', xtime, & + dpsdt_sum/no_points, & + dmudt_sum/no_points + CALL wrf_message ( TRIM(outstring) ) + IF ( diag_print .eq. 2) THEN + WRITE(outstring,*) grid_str,'Domain average of dardt, drcdt, drndt (mm/sec): ', xtime, & + dardt_sum/dt/no_points, & + drcdt_sum/dt/no_points, & + drndt_sum/dt/no_points + CALL wrf_message ( TRIM(outstring) ) + WRITE(outstring,*) grid_str,'Domain average of rt_sum, rc_sum, rnc_sum (mm/sec): ', xtime, & + raint_sum/no_points, & + rainc_sum/no_points, & + rainnc_sum/no_points + CALL wrf_message ( TRIM(outstring) ) + WRITE(outstring,*) grid_str,'Domain average of sfcevp, hfx, lh: ', xtime, & + sfcevp_sum/no_points, & + hfx_sum/no_points, & + lh_sum/no_points + CALL wrf_message ( TRIM(outstring) ) + ENDIF +#ifdef DM_PARALLEL + ENDIF +#endif + + ENDIF + +! save values at this time step + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij,i,j ) + DO ij = 1 , num_tiles + + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + pk1m(i,j)=p_phy(i,kms,j) + mu_2m(i,j)=mu_2(i,j) + ENDDO + ENDDO + + IF ( xtime .lt. 0.0001 ) THEN + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + dpsdt(i,j)=0. + dmudt(i,j)=0. + ENDDO + ENDDO + ENDIF + + ENDDO + !$OMP END PARALLEL DO + + END SUBROUTINE diagnostic_output_calc + +END MODULE module_diagnostics diff --git a/wrfv2_fire/phys/module_fdda_psufddagd.F b/wrfv2_fire/phys/module_fdda_psufddagd.F new file mode 100644 index 00000000..47780518 --- /dev/null +++ b/wrfv2_fire/phys/module_fdda_psufddagd.F @@ -0,0 +1,602 @@ +!wrf:model_layer:physics +! +! +! +MODULE module_fdda_psufddagd + + USE module_dm + +CONTAINS +! +!------------------------------------------------------------------- +! + SUBROUTINE fddagd(itimestep,dt,xtime,id,analysis_interval, end_fdda_hour, & + if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_q, & + if_zfac_uv, k_zfac_uv, if_zfac_t, k_zfac_t, if_zfac_q, k_zfac_q, & + guv, gt, gq, if_ramping, dtramp_min, & + u3d,v3d,th3d,t3d, & + qv3d, & + p3d,pi3d, & + u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,mu_ndg_old, & + u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,mu_ndg_new, & + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,& + pblh, ht, z, z_at_w, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- +!-- u3d 3d u-velocity staggered on u points +!-- v3d 3d v-velocity staggered on v points +!-- th3d 3d potential temperature (k) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- p3d 3d pressure (pa) +!-- pi3d 3d exner function (dimensionless) +!-- rundgdten staggered u tendency due to +! fdda grid nudging (m/s/s) +!-- rvndgdten staggered v tendency due to +! fdda grid nudging (m/s/s) +!-- rthndgdten theta tendency due to +! fdda grid nudging (K/s) +!-- rqvndgdten qv tendency due to +! fdda grid nudging (kg/kg/s) +!-- rmundgdten mu tendency due to +! fdda grid nudging (Pa/s) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- +! + INTEGER, INTENT(IN) :: itimestep, analysis_interval, end_fdda_hour + + INTEGER, INTENT(IN) :: if_no_pbl_nudging_uv, if_no_pbl_nudging_t, & + if_no_pbl_nudging_q + INTEGER, INTENT(IN) :: if_zfac_uv, if_zfac_t, if_zfac_q + INTEGER, INTENT(IN) :: k_zfac_uv, k_zfac_t, k_zfac_q + INTEGER, INTENT(IN) :: if_ramping + + INTEGER , INTENT(IN) :: id + REAL, INTENT(IN) :: DT, xtime, dtramp_min + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: qv3d, & + p3d, & + pi3d, & + th3d, & + t3d, & + z, & + z_at_w + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: rundgdten, & + rvndgdten, & + rthndgdten, & + rqvndgdten + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: rmundgdten + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: u_ndg_old, & + v_ndg_old, & + t_ndg_old, & + q_ndg_old, & + u_ndg_new, & + v_ndg_new, & + t_ndg_new, & + q_ndg_new + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: mu_ndg_old, & + mu_ndg_new + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: u3d, & + v3d + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: pblh, & + ht + + REAL, INTENT(IN) :: guv, gt, gq + + INTEGER :: i, j, k, itsu, jtsv, itf, jtf, ktf, i0, k0, j0 + REAL :: xtime_old, xtime_new, coef, val_analysis + INTEGER :: kpbl, dbg_level + + REAL :: zpbl, zagl, zagl_bot, zagl_top, tfac, actual_end_fdda_min + REAL, DIMENSION( its:ite, kts:kte, jts:jte, 4 ) :: wpbl ! 1: u, 2: v, 3: t, 4: q + REAL, DIMENSION( kts:kte, 4 ) :: wzfac ! 1: u, 2: v, 3: t, 4: q + + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER (LEN=256) :: message + + xtime_old = FLOOR(xtime/analysis_interval) * analysis_interval * 1.0 + xtime_new = xtime_old + analysis_interval + coef = (xtime-xtime_old)/(xtime_new-xtime_old) + + + IF ( wrf_dm_on_monitor()) THEN + + CALL get_wrf_debug_level( dbg_level ) + + IF( xtime-xtime_old < 0.5*dt/60.0 ) THEN + + IF( xtime < end_fdda_hour*60.0 ) THEN + WRITE(message,'(a,i1,a,f10.3,a)') & + 'D0',id,' Analysis nudging read in new data at time = ', xtime, ' min.' + CALL wrf_message( TRIM(message) ) + WRITE(message,'(a,i1,a,2f8.2,a)') & + 'D0',id,' Analysis nudging bracketing times = ', xtime_old, xtime_new, ' min.' + CALL wrf_message( TRIM(message) ) + ENDIF + + actual_end_fdda_min = end_fdda_hour*60.0 + IF( if_ramping == 1 .AND. dtramp_min > 0.0 ) & + actual_end_fdda_min = end_fdda_hour*60.0 + ABS(dtramp_min) + + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN +! Find the mid point of the tile and print out the sample values + i0 = (ite-its)/2+its + j0 = (jte-jts)/2+jts + + IF( guv > 0.0 ) THEN + DO k = kts, kte + WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') & + ' D0',id,' sample analysis values at i,k,j=', i0, k, j0, & + ' u_ndg_old=', u_ndg_old(i0,k,j0), ' u_ndg_new=', u_ndg_new(i0,k,j0) + CALL wrf_message( TRIM(message) ) + ENDDO + DO k = kts, kte + WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') & + ' D0',id,' sample analysis values at i,k,j=', i0, k, j0, & + ' v_ndg_old=', v_ndg_old(i0,k,j0), ' v_ndg_new=', v_ndg_new(i0,k,j0) + CALL wrf_message( TRIM(message) ) + ENDDO + ENDIF + + IF( gt > 0.0 ) THEN + DO k = kts, kte + WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') & + ' D0',id,' sample analysis values at i,k,j=', i0, k, j0, & + ' t_ndg_old=', t_ndg_old(i0,k,j0), ' t_ndg_new=', t_ndg_new(i0,k,j0) + CALL wrf_message( TRIM(message) ) + ENDDO + ENDIF + + IF( gq > 0.0 ) THEN + DO k = kts, kte + WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') & + ' D0',id,' sample analysis values at i,k,j=', i0, k, j0, & + ' q_ndg_old=', q_ndg_old(i0,k,j0), ' q_ndg_new=', q_ndg_new(i0,k,j0) + CALL wrf_message( TRIM(message) ) + ENDDO + ENDIF + + ENDIF + ENDIF + ENDIF + + jtsv=MAX0(jts,jds+1) + itsu=MAX0(its,ids+1) + + jtf=MIN0(jte,jde-1) + ktf=MIN0(kte,kde-1) + itf=MIN0(ite,ide-1) +! +! If the user-defined namelist switches (if_no_pbl_nudging_uv, if_no_pbl_nudging_t, +! if_no_pbl_nudging_q swithes) are set to 1, compute the weighting function, wpbl(:,k,:,:), +! based on the PBL depth. wpbl = 1 above the PBL and wpbl = 0 in the PBL. If all +! the switche are set to zero, wpbl = 1 (default value). +! + wpbl(:,:,:,:) = 1.0 + + IF( if_no_pbl_nudging_uv == 1 ) THEN + + DO j=jts,jtf + DO i=itsu,itf + + kpbl = 1 + zpbl = 0.5 * ( pblh(i-1,j) + pblh(i,j) ) + + loop_ku: DO k=kts,ktf + zagl = 0.5 * ( z(i-1,k,j)-ht(i-1,j) + z(i,k,j)-ht(i,j) ) + zagl_bot = 0.5 * ( z_at_w(i-1,k, j)-ht(i-1,j) + z_at_w(i,k, j)-ht(i,j) ) + zagl_top = 0.5 * ( z_at_w(i-1,k+1,j)-ht(i-1,j) + z_at_w(i,k+1,j)-ht(i,j) ) + IF( zpbl >= zagl_bot .AND. zpbl < zagl_top ) THEN + kpbl = k + EXIT loop_ku + ENDIF + ENDDO loop_ku + + DO k=kts,ktf + IF( k <= kpbl ) wpbl(i, k, j, 1) = 0.0 + IF( k == kpbl+1 ) wpbl(i, k, j, 1) = 0.1 + IF( k > kpbl+1 ) wpbl(i, k, j, 1) = 1.0 + ENDDO + + ENDDO + ENDDO + + DO i=its,itf + DO j=jtsv,jtf + + kpbl = 1 + zpbl = 0.5 * ( pblh(i,j-1) + pblh(i,j) ) + + loop_kv: DO k=kts,ktf + zagl = 0.5 * ( z(i,k,j-1)-ht(i,j-1) + z(i,k,j)-ht(i,j) ) + zagl_bot = 0.5 * ( z_at_w(i,k, j-1)-ht(i,j-1) + z_at_w(i,k, j)-ht(i,j) ) + zagl_top = 0.5 * ( z_at_w(i,k+1,j-1)-ht(i,j-1) + z_at_w(i,k+1,j)-ht(i,j) ) + IF( zpbl >= zagl_bot .AND. zpbl < zagl_top ) THEN + kpbl = k + EXIT loop_kv + ENDIF + ENDDO loop_kv + + DO k=kts,ktf + IF( k <= kpbl ) wpbl(i, k, j, 2) = 0.0 + IF( k == kpbl+1 ) wpbl(i, k, j, 2) = 0.1 + IF( k > kpbl+1 ) wpbl(i, k, j, 2) = 1.0 + ENDDO + + ENDDO + ENDDO + + ENDIF + + IF( if_no_pbl_nudging_t == 1 ) THEN + + DO j=jts,jtf + DO i=its,itf + + kpbl = 1 + zpbl = pblh(i,j) + + loop_kt: DO k=kts,ktf + zagl = z(i,k,j)-ht(i,j) + zagl_bot = z_at_w(i,k, j)-ht(i,j) + zagl_top = z_at_w(i,k+1,j)-ht(i,j) + IF( zpbl >= zagl_bot .AND. zpbl < zagl_top ) THEN + kpbl = k + EXIT loop_kt + ENDIF + ENDDO loop_kt + + DO k=kts,ktf + IF( k <= kpbl ) wpbl(i, k, j, 3) = 0.0 + IF( k == kpbl+1 ) wpbl(i, k, j, 3) = 0.1 + IF( k > kpbl+1 ) wpbl(i, k, j, 3) = 1.0 + ENDDO + + ENDDO + ENDDO + + ENDIF + + IF( if_no_pbl_nudging_q == 1 ) THEN + + DO j=jts,jtf + DO i=its,itf + + kpbl = 1 + zpbl = pblh(i,j) + + loop_kq: DO k=kts,ktf + zagl = z(i,k,j)-ht(i,j) + zagl_bot = z_at_w(i,k, j)-ht(i,j) + zagl_top = z_at_w(i,k+1,j)-ht(i,j) + IF( zpbl >= zagl_bot .AND. zpbl < zagl_top ) THEN + kpbl = k + EXIT loop_kq + ENDIF + ENDDO loop_kq + + DO k=kts,ktf + IF( k <= kpbl ) wpbl(i, k, j, 4) = 0.0 + IF( k == kpbl+1 ) wpbl(i, k, j, 4) = 0.1 + IF( k > kpbl+1 ) wpbl(i, k, j, 4) = 1.0 + ENDDO + + ENDDO + ENDDO + + ENDIF +! +! If the user-defined namelist switches (if_zfac_uv, if_zfac_t, +! if_zfac_q swithes) are set to 1, compute the weighting function, wzfac(k,:), +! based on the namelist specified k values (k_zfac_uv, k_zfac_t and k_zfac_q) below which analysis +! nudging is turned off (wzfac = 1 above k_zfac_x and = 0 in below k_zfac_x). If all +! the switche are set to zero, wzfac = 1 (default value). +! + wzfac(:,:) = 1.0 + + IF( if_zfac_uv == 1 ) THEN + + DO j=jts,jtf + DO i=itsu,itf + DO k=kts,ktf + IF( k <= k_zfac_uv ) wzfac(k, 1:2) = 0.0 + IF( k == k_zfac_uv+1 ) wzfac(k, 1:2) = 0.1 + IF( k > k_zfac_uv+1 ) wzfac(k, 1:2) = 1.0 + ENDDO + ENDDO + ENDDO + + ENDIF + + IF( if_zfac_t == 1 ) THEN + + DO j=jts,jtf + DO i=itsu,itf + DO k=kts,ktf + IF( k <= k_zfac_t ) wzfac(k, 3) = 0.0 + IF( k == k_zfac_t+1 ) wzfac(k, 3) = 0.1 + IF( k > k_zfac_t+1 ) wzfac(k, 3) = 1.0 + ENDDO + ENDDO + ENDDO + + ENDIF + + IF( if_zfac_q == 1 ) THEN + + DO j=jts,jtf + DO i=itsu,itf + DO k=kts,ktf + IF( k <= k_zfac_q ) wzfac(k, 4) = 0.0 + IF( k == k_zfac_q+1 ) wzfac(k, 4) = 0.1 + IF( k > k_zfac_q+1 ) wzfac(k, 4) = 1.0 + ENDDO + ENDDO + ENDDO + + ENDIF +! +! If if_ramping and dtramp_min are defined by user, comput a time weighting function, tfac, +! for analysis nudging so that at the end of the nudging period (which has to be at a +! analysis time) we ramp down the nudging coefficient, based on the use-defined sign of dtramp_min. +! +! When dtramp_min is negative, ramping ends at end_fdda_hour and starts at +! end_fdda_hour-ABS(dtramp_min). +! +! When dtramp_min is positive, ramping starts at end_fdda_hour and ends at +! end_fdda_hour+ABS(dtramp_min). In this case, the obs values are extrapolated using +! the obs tendency saved from the previous FDDA wondow. More specifically for extrapolation, +! coef (see codes below) is recalculated to reflect extrapolation during the ramping period. +! + tfac = 1.0 + + IF( if_ramping == 1 .AND. ABS(dtramp_min) > 0.0 ) THEN + + IF( dtramp_min <= 0.0 ) THEN + actual_end_fdda_min = end_fdda_hour*60.0 + ELSE + actual_end_fdda_min = end_fdda_hour*60.0 + dtramp_min + ENDIF + + IF( xtime < actual_end_fdda_min-ABS(dtramp_min) )THEN + tfac = 1.0 + ELSEIF( xtime >= actual_end_fdda_min-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min )THEN + tfac = ( actual_end_fdda_min - xtime ) / ABS(dtramp_min) + IF( dtramp_min > 0.0 ) coef = (xtime-xtime_old+analysis_interval*60.0)/(analysis_interval*60.0) + ELSE + tfac = 0.0 + ENDIF + + ENDIF +! +! Compute 3-D nudging tendencies for u, v, t and q +! + DO j=jts,jtf + DO k=kts,ktf + DO i=itsu,itf + val_analysis = u_ndg_old(i,k,j) *( 1.0 - coef ) + u_ndg_new(i,k,j) * coef + RUNDGDTEN(i,k,j) = guv * wpbl(i,k,j,1) * wzfac(k,1) * tfac * & + ( val_analysis - u3d(i,k,j) ) + ENDDO + ENDDO + ENDDO + + DO j=jtsv,jtf + DO k=kts,ktf + DO i=its,itf + val_analysis = v_ndg_old(i,k,j) *( 1.0 - coef ) + v_ndg_new(i,k,j) * coef + RVNDGDTEN(i,k,j) = guv * wpbl(i,k,j,2) * wzfac(k,2) * tfac * & + ( val_analysis - v3d(i,k,j) ) + ENDDO + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + val_analysis = t_ndg_old(i,k,j) *( 1.0 - coef ) + t_ndg_new(i,k,j) * coef + RTHNDGDTEN(i,k,j) = gt * wpbl(i,k,j,3) * wzfac(k,3) * tfac * & + ( val_analysis - th3d(i,k,j) + 300.0 ) + + val_analysis = q_ndg_old(i,k,j) *( 1.0 - coef ) + q_ndg_new(i,k,j) * coef + RQVNDGDTEN(i,k,j) = gq * wpbl(i,k,j,4) * wzfac(k,4) * tfac * & + ( val_analysis - qv3d(i,k,j) ) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE fddagd + + + SUBROUTINE fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& + run_hours, & + if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_q, & + if_zfac_uv, k_zfac_uv, if_zfac_t, k_zfac_t, if_zfac_q, k_zfac_q, & + guv, gt, gq, if_ramping, dtramp_min, end_fdda_hour, & + restart, allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! + INTEGER , INTENT(IN) :: id + LOGICAL, INTENT(IN) :: restart, allowed_to_read + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT) :: & + rundgdten, & + rvndgdten, & + rthndgdten, & + rqvndgdten + INTEGER, INTENT(IN) :: run_hours + INTEGER, INTENT(IN) :: if_no_pbl_nudging_uv, if_no_pbl_nudging_t, & + if_no_pbl_nudging_q, end_fdda_hour + INTEGER, INTENT(IN) :: if_zfac_uv, if_zfac_t, if_zfac_q + INTEGER, INTENT(IN) :: k_zfac_uv, k_zfac_t, k_zfac_q + INTEGER, INTENT(IN) :: if_ramping + REAL, INTENT(IN) :: dtramp_min + REAL, INTENT(IN) :: guv, gt, gq + REAL :: actual_end_fdda_min + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: rmundgdten + INTEGER :: i, j, k + + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER (LEN=256) :: message + + IF ( wrf_dm_on_monitor() ) THEN + + IF( guv > 0.0 ) THEN + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for wind is turned on and Guv= ', guv + CALL wrf_message(TRIM(message)) + ELSE IF( guv < 0.0 ) THEN + CALL wrf_error_fatal('In grid FDDA, Guv must be positive.') + ELSE + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for wind is turned off and Guv= ', guv + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gt > 0.0 ) THEN + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for temperature is turned on and Gt= ', gt + CALL wrf_message(TRIM(message)) + ELSE IF( gt < 0.0 ) THEN + CALL wrf_error_fatal('In grid FDDA, Gt must be positive.') + ELSE + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for temperature is turned off and Gt= ', gt + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gq > 0.0 ) THEN + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for water vapor mixing ratio is turned on and Gq= ', gq + CALL wrf_message(TRIM(message)) + ELSE IF( gq < 0.0 ) THEN + CALL wrf_error_fatal('In grid FDDA, Gq must be positive.') + ELSE + WRITE(message,'(a,i1,a,e12.4)') & + 'D0',id,' Analysis nudging for water vapor mixing ratio is turned off and Gq= ', gq + CALL wrf_message(TRIM(message)) + ENDIF + + IF( guv > 0.0 .AND. if_no_pbl_nudging_uv == 1 ) THEN + WRITE(message,'(a,i1,a)') & + 'D0',id,' Analysis nudging for wind is turned off within the PBL.' + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gt > 0.0 .AND. if_no_pbl_nudging_t == 1 ) THEN + WRITE(message,'(a,i1,a)') & + 'D0',id,' Analysis nudging for temperature is turned off within the PBL.' + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gq > 0.0 .AND. if_no_pbl_nudging_q == 1 ) THEN + WRITE(message,'(a,i1,a)') & + 'D0',id,' Analysis nudging for water vapor mixing ratio is turned off within the PBL.' + CALL wrf_message(TRIM(message)) + ENDIF + + IF( guv > 0.0 .AND. if_zfac_uv == 1 ) THEN + WRITE(message,'(a,i1,a,i3)') & + 'D0',id,' Analysis nudging for wind is turned off below layer', k_zfac_uv + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gt > 0.0 .AND. if_zfac_t == 1 ) THEN + WRITE(message,'(a,i1,a,i3)') & + 'D0',id,' Analysis nudging for temperature is turned off below layer', k_zfac_t + CALL wrf_message(TRIM(message)) + ENDIF + + IF( gq > 0.0 .AND. if_zfac_q == 1 ) THEN + WRITE(message,'(a,i1,a,i3)') & + 'D0',id,' Analysis nudging for water vapor mixing ratio is turned off below layer', & + k_zfac_q + CALL wrf_message(TRIM(message)) + ENDIF + + IF( if_ramping == 1 .AND. ABS(dtramp_min) > 0.0 ) THEN + IF( dtramp_min <= 0.0 ) THEN + actual_end_fdda_min = end_fdda_hour*60.0 + ELSE + actual_end_fdda_min = end_fdda_hour*60.0 + ABS(dtramp_min) + ENDIF + + IF( actual_end_fdda_min <= run_hours*60. ) THEN + WRITE(message,'(a,i1,a)') & + 'D0',id,' Analysis nudging is ramped down near the end of the nudging period,' + CALL wrf_message(TRIM(message)) + + WRITE(message,'(a,f6.2,a,f6.2,a)') & + ' starting at ', (actual_end_fdda_min - ABS(dtramp_min))/60.0, & + 'h, ending at ', actual_end_fdda_min/60.0,'h.' + CALL wrf_message(TRIM(message)) + ENDIF + ENDIF + + ENDIF + + IF(.not.restart) THEN + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + rundgdten(i,k,j) = 0. + rvndgdten(i,k,j) = 0. + rthndgdten(i,k,j) = 0. + rqvndgdten(i,k,j) = 0. + if(k.eq.kts) rmundgdten(i,j) = 0. + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE fddagdinit +!------------------------------------------------------------------- +END MODULE module_fdda_psufddagd diff --git a/wrfv2_fire/phys/module_fddagd_driver.F b/wrfv2_fire/phys/module_fddagd_driver.F new file mode 100644 index 00000000..d67e4ec9 --- /dev/null +++ b/wrfv2_fire/phys/module_fddagd_driver.F @@ -0,0 +1,277 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_fddagd_driver +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE fddagd_driver(itimestep,dt,xtime, & + id, & + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & + RQVNDGDTEN,RMUNDGDTEN, & + u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,mu_ndg_old, & + u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,mu_ndg_new, & + u3d,v3d,th_phy,rho,moist, & + p_phy,pi_phy,p8w,t_phy,dz8w,z,z_at_w, & + config_flags,DX,n_moist, & + STEPFG, & + pblh,ht, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start,i_end, j_start,j_end, kts,kte, num_tiles) +!------------------------------------------------------------------ + USE module_configure + USE module_state_description + USE module_model_constants + +! *** add new modules of schemes here + + USE module_fdda_psufddagd +!------------------------------------------------------------------ + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +!-- RUNDGDTEN U tendency due to +! FDDA analysis nudging (m/s^2) +!-- RVNDGDTEN V tendency due to +! FDDA analysis nudging (m/s^2) +!-- RTHNDGDTEN Theta tendency due to +! FDDA analysis nudging (K/s) +!-- RQVNDGDTEN Qv tendency due to +! FDDA analysis nudging (kg/kg/s) +!-- RMUNDGDTEN mu tendency due to +! FDDA analysis nudging (Pa/s) +!-- itimestep number of time steps +!-- u3d u-velocity staggered on u points (m/s) +!-- v3d v-velocity staggered on v points (m/s) +!-- th_phy potential temperature (K) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- p_phy pressure (Pa) +!-- pi_phy exner function (dimensionless) +!-- p8w pressure at full levels (Pa) +!-- t_phy temperature (K) +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- config_flags +!-- DX horizontal space interval (m) +!-- DT time step (second) +!-- n_moist number of moisture species +!-- STEPFG number of timesteps per FDDA re-calculation +!-- KPBL k-index of PBL top +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!****************************************************************** +!------------------------------------------------------------------ + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags +! + + INTEGER , INTENT(IN) :: id + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + kts,kte, num_tiles, & + n_moist + + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, INTENT(IN ) :: itimestep,STEPFG +! + REAL, INTENT(IN ) :: DT,DX,XTIME + + +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: p_phy, & + pi_phy, & + p8w, & + rho, & + t_phy, & + u3d, & + v3d, & + dz8w, & + z, & + z_at_w, & + th_phy +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), & + INTENT(IN ) :: moist +! +! +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RUNDGDTEN, & + RVNDGDTEN, & + RTHNDGDTEN, & + RQVNDGDTEN + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: RMUNDGDTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: u_ndg_old, & + v_ndg_old, & + t_ndg_old, & + q_ndg_old, & + u_ndg_new, & + v_ndg_new, & + t_ndg_new, & + q_ndg_new + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: mu_ndg_old, & + mu_ndg_new + +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: pblh, & + ht + +! LOCAL VAR + +! + INTEGER :: i,J,K,NK,jj,ij + +!------------------------------------------------------------------ +! +#if ! ( NMM_CORE == 1 ) + if (config_flags%grid_fdda .eq. 0) return + + IF (itimestep == 1) THEN + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij,i,j,k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + + DO k=kts,min(kte+1,kde) + u_ndg_old(i,k,j) = u3d(i,k,j) + v_ndg_old(i,k,j) = v3d(i,k,j) + t_ndg_old(i,k,j) = th_phy(i,k,j) - 300.0 + q_ndg_old(i,k,j) = moist(i,k,j,P_QV) + ENDDO + mu_ndg_old(i,j) = 0.0 + + ENDDO + ENDDO + + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + IF (itimestep .eq. 1 .or. mod(itimestep,STEPFG) .eq. 0) THEN + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij,i,j,k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + + DO k=kts,min(kte+1,kde) + RTHNDGDTEN(I,K,J)=0. + RUNDGDTEN(I,K,J)=0. + RVNDGDTEN(I,K,J)=0. + RQVNDGDTEN(I,K,J)=0. + ENDDO + + RMUNDGDTEN(I,J)=0. + + ENDDO + ENDDO + + ENDDO + !$OMP END PARALLEL DO +! + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i,j,k ) + DO ij = 1 , num_tiles + fdda_select: SELECT CASE(config_flags%grid_fdda) + + CASE (PSUFDDAGD) + CALL wrf_debug(100,'in PSU FDDA scheme') + CALL FDDAGD(itimestep,dt,xtime, & + id, & + config_flags%gfdda_interval_m, & + config_flags%gfdda_end_h, & + config_flags%if_no_pbl_nudging_uv, & + config_flags%if_no_pbl_nudging_t, & + config_flags%if_no_pbl_nudging_q, & + config_flags%if_zfac_uv, & + config_flags%k_zfac_uv, & + config_flags%if_zfac_t, & + config_flags%k_zfac_t, & + config_flags%if_zfac_q, & + config_flags%k_zfac_q, & + config_flags%guv, & + config_flags%gt, config_flags%gq, & + config_flags%if_ramping, config_flags%dtramp_min, & + u3d,v3d,th_phy,t_phy, & + moist(ims,kms,jms,P_QV), & + p_phy,pi_phy, & + u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,mu_ndg_old, & + u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,mu_ndg_new, & + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,& + pblh, ht, z, z_at_w, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte ) + + + CASE DEFAULT + + WRITE( wrf_err_message , * ) 'The fdda option does not exist: grid_fdda = ', config_flags%grid_fdda + CALL wrf_error_fatal ( wrf_err_message ) + + END SELECT fdda_select + + ENDDO + !$OMP END PARALLEL DO + + ENDIF + +#endif +! + END SUBROUTINE fddagd_driver +END MODULE module_fddagd_driver diff --git a/wrfv2_fire/phys/module_fddaobs_driver.F b/wrfv2_fire/phys/module_fddaobs_driver.F new file mode 100644 index 00000000..6be3085f --- /dev/null +++ b/wrfv2_fire/phys/module_fddaobs_driver.F @@ -0,0 +1,384 @@ +!WRF:MODEL_LAYER:PHYSICS +MODULE module_fddaobs_driver + +! This obs-nudging FDDA module (RTFDDA) is developed by the +! NCAR/RAL/NSAP (National Security Application Programs), under the +! sponsorship of ATEC (Army Test and Evaluation Commands). ATEC is +! acknowledged for releasing this capability for WRF community +! research applications. +! +! The NCAR/RAL RTFDDA module was adapted, and significantly modified +! from the obs-nudging module in the standard MM5V3.1 which was originally +! developed by PSU (Stauffer and Seaman, 1994). +! +! Yubao Liu (NCAR/RAL): lead developer of the RTFDDA module +! Al Bourgeois (NCAR/RAL): lead engineer implementing RTFDDA into WRF-ARW +! Nov. 2006 +! +! References: +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and J. Hacker, 2005: An +! implementation of obs-nudging-based FDDA into WRF for supporting +! ATEC test operations. 2005 WRF user workshop. Paper 10.7. +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and W. Yu, 2006: An update +! on "obs-nudging"-based FDDA for WRF-ARW: Verification using OSSE +! and performance of real-time forecasts. 2006 WRF user workshop. Paper 4.7. + +! +! Stauffer, D.R., and N.L. Seaman, 1994: Multi-scale four-dimensional data +! assimilation. J. Appl. Meteor., 33, 416-434. +! +! http://www.rap.ucar.edu/projects/armyrange/references.html +! + +CONTAINS + +!----------------------------------------------------------------------- +SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & + nudge_opt, iprt_errob, iprt_nudob, & + fdasta, fdaend, & + nudge_wind, nudge_temp, nudge_mois, & + nudge_pstr, & + coef_wind, coef_temp, coef_mois, & + coef_pstr, rinxy, rinsig, twindo, & + npfi, ionf, idynin, dtramp, & + xlatc_cg, xlonc_cg, true_lat1, true_lat2, & + map_proj, i_parent_start, j_parent_start, & + parent_grid_ratio, maxdom, itimestep, & + dt, gmt, julday, & +#if ( EM_CORE == 1 ) + fdob, & +#endif + max_obs, nobs_ndg_vars, & + nobs_err_flds, nstat, varobs, errf, dx, & + KPBL, HT, mut, muu, muv, & + msft, msfu, msfv, p_phy, t_tendf, t0, & + ub, vb, tb, qvb, pbase, ptop, pp, & + uratx, vratx, tratx, ru_tendf, rv_tendf, & + moist_tend, savwt, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims + +!----------------------------------------------------------------------- + USE module_domain + USE module_bc + USE module_model_constants, ONLY : rovg, rcp + USE module_fddaobs_rtfdda + +! This driver calls subroutines for fdda obs-nudging and +! returns computed tendencies + +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! taken from MM5 code - 03 Feb 2004. +!----------------------------------------------------------------------- + +!======================================================================= +! Definitions +!----------- +!-- KPBL vertical layer index for PBL top +!-- HT terrain height (m) +!-- p_phy pressure (Pa) +!-- t_tendf temperature tendency + + INTEGER, intent(in) :: ids,ide, jds,jde, kds,kde ! domain dims. + INTEGER, intent(in) :: ims,ime, jms,jme, kms,kme ! memory dims. + INTEGER, intent(in) :: its,ite, jts,jte, kts,kte ! tile dims. + + INTEGER, intent(in) :: inest + INTEGER, intent(in) :: maxdom + INTEGER, intent(in) :: domid(maxdom) ! Domain IDs + INTEGER, intent(in) :: parid(maxdom) ! Parent domain IDs + LOGICAL, intent(in) :: restart + INTEGER, intent(in) :: itimestep + INTEGER, intent(in) :: nudge_opt + LOGICAL, intent(in) :: iprt_errob + LOGICAL, intent(in) :: iprt_nudob + REAL, intent(in) :: fdasta + REAL, intent(in) :: fdaend + INTEGER, intent(in) :: nudge_wind + INTEGER, intent(in) :: nudge_temp + INTEGER, intent(in) :: nudge_mois + INTEGER, intent(in) :: nudge_pstr + REAL, intent(in) :: coef_wind + REAL, intent(in) :: coef_temp + REAL, intent(in) :: coef_mois + REAL, intent(in) :: coef_pstr + REAL, intent(inout) :: rinxy + REAL, intent(inout) :: rinsig + REAL, intent(inout) :: twindo + INTEGER, intent(in) :: npfi + INTEGER, intent(in) :: ionf + INTEGER, intent(in) :: idynin + REAL, intent(inout) :: dtramp + REAL, intent(in) :: xlatc_cg ! center latitude of coarse grid + REAL, intent(in) :: xlonc_cg ! center longitude of coarse grid + REAL, intent(in) :: true_lat1 + REAL, intent(in) :: true_lat2 + INTEGER, intent(in) :: map_proj + INTEGER, intent(in) :: i_parent_start(maxdom) + INTEGER, intent(in) :: j_parent_start(maxdom) + INTEGER, intent(in) :: parent_grid_ratio + REAL, intent(in) :: dt + REAL, intent(in) :: gmt + INTEGER, intent(in) :: julday + INTEGER, intent(in) :: max_obs ! max number of observations + INTEGER, intent(in) :: nobs_ndg_vars + INTEGER, intent(in) :: nobs_err_flds + INTEGER, intent(in) :: nstat + REAL, intent(inout) :: varobs(nobs_ndg_vars, max_obs) + REAL, intent(inout) :: errf(nobs_err_flds, max_obs) + REAL, intent(in) :: dx ! this-domain grid cell-size (m) + INTEGER, INTENT(IN) :: kpbl( ims:ime, jms:jme ) + REAL, INTENT(IN) :: ht( ims:ime, jms:jme ) + REAL, INTENT(IN) :: mut( ims:ime , jms:jme ) ! Air mass on t-grid + REAL, INTENT(IN) :: muu( ims:ime , jms:jme ) ! Air mass on u-grid + REAL, INTENT(IN) :: muv( ims:ime , jms:jme ) ! Air mass on v-grid + REAL, INTENT(IN) :: msft( ims:ime , jms:jme ) ! Map scale on t-grid + REAL, INTENT(IN) :: msfu( ims:ime , jms:jme ) ! Map scale on u-grid + REAL, INTENT(IN) :: msfv( ims:ime , jms:jme ) ! Map scale on v-grid + + REAL, INTENT(IN) :: p_phy( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(INOUT) :: t_tendf( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: t0 + REAL, INTENT(INOUT) :: savwt( nobs_ndg_vars, ims:ime, kms:kme, jms:jme ) + +#if ( EM_CORE == 1 ) + TYPE(fdob_type), intent(inout) :: fdob +#endif + + REAL, INTENT(IN) :: ub( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: vb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: tb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: qvb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: pbase( ims:ime, kms:kme, jms:jme ) ! Base press. (Pa) + REAL, INTENT(IN) :: ptop + REAL, INTENT(IN) :: pp( ims:ime, kms:kme, jms:jme ) ! Press. pert. (Pa) + REAL, INTENT(IN) :: uratx( ims:ime, jms:jme ) ! On mass points + REAL, INTENT(IN) :: vratx( ims:ime, jms:jme ) ! " + REAL, INTENT(IN) :: tratx( ims:ime, jms:jme ) ! " + REAL, INTENT(INOUT) :: ru_tendf( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(INOUT) :: rv_tendf( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(INOUT) :: moist_tend( ims:ime, kms:kme, jms:jme ) + +! Local variables + logical :: nudge_flag ! Flag for doing nudging + integer :: KTAU ! Forecast timestep + real :: xtime ! Forecast time in minutes + real :: dtmin ! dt in minutes + integer :: i, j, k ! Loop counters. + integer :: idom ! Loop counter. + integer :: nsta ! Number of observation stations + integer :: infr ! Frequency for obs input and error calc + integer :: idarst ! Flag for calling sub errob on restart + real :: dtr ! Abs value of dtramp (for dynamic init) + real :: tconst ! Reciprocal of dtr + integer :: KPBLJ(its:ite) ! 1D temp array. +#ifdef RAL + real :: HTIJ(ids:ide, jds:jde) = 0. ! Terrain ht on global grid. +#endif + +#if ( EM_CORE == 1 ) + nudge_flag = (nudge_opt .eq. 1) + + if (.not. nudge_flag) return + +!---------------------------------------------------------------------- +! *************** BEGIN FDDA SETUP SECTION *************** + +! Calculate forecast time. + dtmin = dt/60. + xtime = dtmin*(itimestep-1) + + ktau = itimestep - 1 !ktau corresponds to xtime + +! DEFINE NSTA WHEN NOT NUDGING TO IND. OBS. +! print *,'in fddaobs_driver, xtime=',xtime + IF(ktau.EQ.fdob%ktaur) THEN + IF (iprt_nudob) PRINT *,3333,fdob%domain_tot +! print *,'ktau,ktaur,inest=',ktau,fdob%ktaur,inest +3333 FORMAT(1X,'IN fddaobs_driver: I4DITOT = ',I2) + nsta=0. + ELSE + nsta=fdob%nstat + ENDIF + + infr = ionf*(parent_grid_ratio**fdob%levidn(inest)) + nsta=fdob%nstat + idarst = 0 + IF(restart .AND. ktau.EQ.fdob%ktaur) idarst=1 + +! COMPUTE ERROR BETWEEN OBSERVATIONS and MODEL + IF( nsta.GT.0 ) THEN + IF( MOD(ktau,infr).EQ.0 .OR. idarst.EQ.1) THEN + + CALL ERROB(inest, ub, vb, tb, t0, qvb, pbase, pp, rcp, & + uratx, vratx, tratx, & + nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & + fdob%levidn, parid, fdob%nstat, & + nudge_wind, nudge_temp, nudge_mois, nudge_pstr, & + fdob%rio, fdob%rjo, fdob%rko, varobs, errf, & + i_parent_start, j_parent_start, ktau, & + parent_grid_ratio, npfi, iprt_errob, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + ENDIF + ENDIF + + fdob%tfaci=1.0 + IF(idynin.EQ.1.AND.nudge_opt.EQ.1) THEN + dtr=ABS(dtramp) + tconst=1./dtr +! FDAEND(IN) IS THE TIME IN MINUTES TO END THE DYNAMIC INITIALIZATION CY + IF(xtime.LT.fdaend-dtr)THEN + fdob%tfaci=1. + ELSEIF(xtime.GE.fdaend-dtr.AND.xtime.LE.fdaend) THEN + fdob%tfaci=(fdaend-xtime)*tconst + ELSE + fdob%tfaci=0.0 + ENDIF + IF(ktau.EQ.fdob%ktaur.OR.MOD(ktau,10).EQ.0) THEN + IF (iprt_nudob) & + PRINT*,' DYNINOBS: IN,KTAU,XTIME,FDAEND,DTRAMP,DTR,TCONST', & + ',TFACI: ',INEST,KTAU,XTIME,FDAEND,DTRAMP,DTR,TCONST, & + fdob%TFACI + ENDIF + ENDIF + +#ifdef RAL +! MEIXU: collect terrain array HT into a global array HTIJ + CALL loc2glob(HT, HTIJ, "2D", "REAL", & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme ) +! MEIXU end +#endif +! +! *************** END FDDA SETUP SECTION *************** +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- +! *************** BEGIN NUDGING SECTION *************** + + DO J = jts, jte +! +! IF NUDGING SURFACE WINDS IN THE BOUNDARY LAYER, IF IWINDS(INEST+2)=1 +! USE A SIMILARITY CORRECTION BASED ON ROUGHNESS TO APPLY 10M +! WIND TO THE SURFACE LAYER (K=KL) AT 40M. TO DO THIS WE MUST +! STORE ROUGHNESS AND REGIME FOR EACH J SLICE AFTER THE CALL TO +! HIRPBL FOR LATER USE IN BLNUDGD. +! + DO I=its,ite + KPBLJ(I)=KPBL(I,J) + ENDDO +! +!--- OBS NUDGING FOR TEMP AND MOISTURE +! + NSTA=NSTAT + IF(J .GT. 2 .and. J .LT.fdob%sn_end) THEN + IF(nudge_temp.EQ.1 .AND. NSTA.GT.0) & + THEN +! write(6,*) 'calling nudob: IVAR=3, J = ',j + CALL NUDOB(J, 3, t_tendf(ims,kms,j), & + inest, restart, ktau, fdob%ktaur, xtime, & + mut(ims,j), msft(ims,j), & + nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & + npfi, ionf, rinxy, twindo, & + fdob%levidn, & + parid, nstat, i_parent_start, j_parent_start, & + fdob, fdob%lev_in_ob, fdob%plfo, fdob%nlevs_ob, & + parent_grid_ratio, dx, dtmin, fdob%rio, fdob%rjo, & + fdob%rko, fdob%timeob, varobs, errf, & + pbase(ims,kms,j), ptop, pp(ims,kms,j), & + nudge_wind, nudge_temp, nudge_mois, & + coef_wind, coef_temp, coef_mois, & + savwt(1,ims,kms,j), kpblj, 0, & + iprt_nudob, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims +! write(6,*) 'return from nudob: IVAR=3, J = ',j + ENDIF + + IF(nudge_mois.EQ.1 .AND. NSTA.GT.0) & + THEN +! write(6,*) 'calling nudob: IVAR=4, J = ',j + CALL NUDOB(J, 4, moist_tend(ims,kms,j), & + inest, restart, ktau, fdob%ktaur, xtime, & + mut(ims,j), msft(ims,j), & + nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & + npfi, ionf, rinxy, twindo, & + fdob%levidn, & + parid, nstat, i_parent_start, j_parent_start, & + fdob, fdob%lev_in_ob, fdob%plfo, fdob%nlevs_ob, & + parent_grid_ratio, dx, dtmin, fdob%rio, fdob%rjo, & + fdob%rko, fdob%timeob, varobs, errf, & + pbase(ims,kms,j), ptop, pp(ims,kms,j), & + nudge_wind, nudge_temp, nudge_mois, & + coef_wind, coef_temp, coef_mois, & + savwt(1,ims,kms,j), kpblj, 0, & + iprt_nudob, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims +! write(6,*) 'return from nudob: IVAR=4, J = ',j + ENDIF + ENDIF + + IF(nudge_wind.EQ.1 .AND. NSTA.GT.0) & + THEN +! write(6,*) 'calling nudob: IVAR=1, J = ',j + CALL NUDOB(J, 1, ru_tendf(ims,kms,j), & + inest, restart, ktau, fdob%ktaur, xtime, & + muu(ims,j), msfu(ims,j), & + nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & + npfi, ionf, rinxy, twindo, & + fdob%levidn, & + parid, nstat, i_parent_start, j_parent_start, & + fdob, fdob%lev_in_ob, fdob%plfo, fdob%nlevs_ob, & + parent_grid_ratio, dx, dtmin, fdob%rio, fdob%rjo, & + fdob%rko, fdob%timeob, varobs, errf, & + pbase(ims,kms,j), ptop, pp(ims,kms,j), & + nudge_wind, nudge_temp, nudge_mois, & + coef_wind, coef_temp, coef_mois, & + savwt(1,ims,kms,j), kpblj, 0, & + iprt_nudob, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims +! write(6,*) 'return from nudob: IVAR=1, J = ',j + +! write(6,*) 'calling nudob: IVAR=2, J = ',j + CALL NUDOB(J, 2, rv_tendf(ims,kms,j), & + inest, restart, ktau, fdob%ktaur, xtime, & + muv(ims,j), msfv(ims,j), & + nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & + npfi, ionf, rinxy, twindo, & + fdob%levidn, & + parid, nstat, i_parent_start, j_parent_start, & + fdob, fdob%lev_in_ob, fdob%plfo, fdob%nlevs_ob, & + parent_grid_ratio, dx, dtmin, fdob%rio, fdob%rjo, & + fdob%rko, fdob%timeob, varobs, errf, & + pbase(ims,kms,j), ptop, pp(ims,kms,j), & + nudge_wind, nudge_temp, nudge_mois, & + coef_wind, coef_temp, coef_mois, & + savwt(1,ims,kms,j), kpblj, 0, & + iprt_nudob, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims +! write(6,*) 'return from nudob: IVAR=2, J = ',j + ENDIF + ENDDO +! +! --- END OF 4DDA +! + RETURN +#endif + END SUBROUTINE fddaobs_driver + +END MODULE module_fddaobs_driver diff --git a/wrfv2_fire/phys/module_fddaobs_rtfdda.F b/wrfv2_fire/phys/module_fddaobs_rtfdda.F new file mode 100644 index 00000000..c0ce91ff --- /dev/null +++ b/wrfv2_fire/phys/module_fddaobs_rtfdda.F @@ -0,0 +1,2383 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_fddaobs_rtfdda + +! This obs-nudging FDDA module (RTFDDA) is developed by the +! NCAR/RAL/NSAP (National Security Application Programs), under the +! sponsorship of ATEC (Army Test and Evaluation Commands). ATEC is +! acknowledged for releasing this capability for WRF community +! research applications. +! +! The NCAR/RAL RTFDDA module was adapted, and significantly modified +! from the obs-nudging module in the standard MM5V3.1 which was originally +! developed by PSU (Stauffer and Seaman, 1994). +! +! Yubao Liu (NCAR/RAL): lead developer of the RTFDDA module +! Al Bourgeois (NCAR/RAL): lead engineer implementing RTFDDA into WRF-ARW +! Nov. 2006 +! +! References: +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and J. Hacker, 2005: An +! implementation of obs-nudging-based FDDA into WRF for supporting +! ATEC test operations. 2005 WRF user workshop. Paper 10.7. +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and W. Yu, 2006: An update +! on "obs-nudging"-based FDDA for WRF-ARW: Verification using OSSE +! and performance of real-time forecasts. 2006 WRF user workshop. Paper 4.7. + +! +! Stauffer, D.R., and N.L. Seaman, 1994: Multi-scale four-dimensional data +! assimilation. J. Appl. Meteor., 33, 416-434. +! +! http://www.rap.ucar.edu/projects/armyrange/references.html +! + +CONTAINS + +!------------------------------------------------------------------------------ + SUBROUTINE fddaobs_init(obs_nudge_opt, maxdom, inest, parid, & + dx_coarse, restart, obs_twindo, itimestep, & + e_sn, s_sn_cg, e_sn_cg, s_we_cg, e_we_cg, & +#if ( EM_CORE == 1 ) + fdob, & +#endif + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +!----------------------------------------------------------------------- +! This routine does initialization for real time fdda obs-nudging. +! +!----------------------------------------------------------------------- + USE module_domain +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + +!======================================================================= +! Definitions +!----------- + INTEGER, intent(in) :: maxdom + INTEGER, intent(in) :: obs_nudge_opt(maxdom) + INTEGER, intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, intent(in) :: inest + INTEGER, intent(in) :: parid(maxdom) + REAL ,intent(in) :: dx_coarse ! coarse-domain grid cell-size (km) + LOGICAL, intent(in) :: restart + REAL, intent(inout) :: obs_twindo + INTEGER, intent(in) :: itimestep + INTEGER, intent(in) :: e_sn ! ending south-north grid index + INTEGER, intent(in) :: s_sn_cg ! starting south-north coarse-grid index + INTEGER, intent(in) :: e_sn_cg ! ending south-north coarse-grid index + INTEGER, intent(in) :: s_we_cg ! starting west-east coarse-grid index + INTEGER, intent(in) :: e_we_cg ! ending west-east coarse-grid index +#if ( EM_CORE == 1 ) + TYPE(fdob_type), intent(inout) :: fdob +#endif + +! Local variables + logical :: nudge_flag ! nudging flag for this nest + integer :: ktau ! current timestep + integer :: nest ! loop counter + integer :: idom ! domain id + integer :: parent ! parent domain + +#if ( EM_CORE == 1 ) +! This routine should only be called once. This is a check to make +! certain that initialization only happens once. + if (fdob%domain_init .ne. 1) then +! Obs-nudging will be initialized on this call + fdob%domain_init = 1 + else +! Obs-nudging has already been initialized, so return + return + endif + +! Set flag for nudging on pressure (not sigma) surfaces + fdob%iwtsig = 0 + +! Set ending nudging date (used with dynamic ramp-down) to zero. + fdob%datend = 0. + +! Convert twindo from minutes to hours. + obs_twindo = obs_twindo / 60. + +! Initialize flags. + + fdob%domain_tot=0 + do nest=1,maxdom + fdob%domain_tot = fdob%domain_tot + obs_nudge_opt(nest) + end do + +! Set parameters. + + fdob%pfree = 50.0 + fdob%rinfmn = 1.0 + fdob%rinfmx = 2.0 + fdob%dpsmx = 7.5 + fdob%dcon = 1.0/fdob%dpsmx + fdob%xn = 0.7155668 ! cone factor + + fdob%ds_cg = dx_coarse / 1000. ! coarse gridsize (km) + fdob%sn_maxcg = e_sn_cg - s_sn_cg + 1 ! coarse domain grid dimension in N-S + fdob%we_maxcg = e_we_cg - s_we_cg + 1 ! coarse domain grid dimension in W-E + fdob%sn_end = e_sn - 1 ! ending S-N grid coordinate + +! Calculate the nest levels, levidn. Note that each nest +! must know the nest levels levidn(maxdom) of each domain. + do nest=1,maxdom + +! Initialize nest level for each domain. + if (nest .eq. 1) then + fdob%levidn(nest) = 0 ! Mother domain has nest level 0 + else + fdob%levidn(nest) = 1 ! All other domains start with 1 + endif + idom = nest +100 parent = parid(idom) ! Go up the parent tree + if (parent .gt. 1) then ! If not up to mother domain + fdob%levidn(nest) = fdob%levidn(nest) + 1 + idom = parid(parent) + goto 100 + endif + enddo + +! Check to see if the nudging flag has been set. If not, +! simply RETURN. + nudge_flag = (obs_nudge_opt(inest) .eq. 1) + if (.not. nudge_flag) return + + ktau = itimestep + if(restart) then + fdob%ktaur = ktau + else + fdob%ktaur = 0 + endif + + RETURN +#endif + END SUBROUTINE fddaobs_init + +#if ( EM_CORE == 1 ) +!----------------------------------------------------------------------- +SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & + uratx, vratx, tratx, nndgv, & + nerrf, niobf, maxdom, levidn, parid, nstat, & + iswind, & + istemp, ismois, ispstr, rio, rjo, rko, varobs, & + errf, i_parent_start, j_parent_start, & + ktau, iratio, npfi, iprt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!----------------------------------------------------------------------- +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + USE module_dm, ONLY : get_full_obs_vector +#endif + +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! +! PURPOSE: THIS SUBROUTINE CALCULATES THE DIFFERENCE BETWEEN THE +! OBSERVED VALUES AND THE FORECAST VALUES AT THE OBSERVATION +! POINTS. THE OBSERVED VALUES CLOSEST TO THE CURRENT +! FORECAST TIME (XTIME) WERE DETERMINED IN SUBROUTINE +! IN4DOB AND STORED IN ARRAY VAROBS. THE DIFFERENCES +! CALCULATED BY SUBROUTINE ERROB WILL BE STORED IN ARRAY +! ERRF FOR THE NSTA OBSERVATION LOCATIONS. MISSING +! OBSERVATIONS ARE DENOTED BY THE DUMMY VALUE 99999. +! +! HISTORY: Original author: MM5 version??? +! 02/04/2004 - Creation of WRF version. Al Bourgeois +! 08/28/2006 - Conversion from F77 to F90 Al Bourgeois +!------------------------------------------------------------------------------ + +! THE STORAGE ORDER IN VAROBS AND ERRF IS AS FOLLOWS: +! IVAR VARIABLE TYPE(TAU-1) +! ---- -------------------- +! 1 U error +! 2 V error +! 3 T error +! 4 Q error +! 5 Surface press error at T points (not used) +! 6 Model surface press at T-points +! 7 Model surface press at U-points +! 8 Model surface press at V-points +! 9 RKO at U-points + +!----------------------------------------------------------------------- +! +! Description of input arguments. +! +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: inest ! Domain index. + INTEGER, INTENT(IN) :: nndgv ! Number of nudge variables. + INTEGER, INTENT(IN) :: nerrf ! Number of error fields. + INTEGER, INTENT(IN) :: niobf ! Number of observations. + INTEGER, INTENT(IN) :: maxdom ! Maximum number of domains. + INTEGER, INTENT(IN) :: levidn(maxdom) ! Level of nest. + INTEGER, INTENT(IN) :: parid(maxdom) ! Id of parent grid. + INTEGER, INTENT(IN) :: i_parent_start(maxdom) ! Start i index in parent domain. + INTEGER, INTENT(IN) :: j_parent_start(maxdom) ! Start j index in parent domain. + INTEGER, INTENT(IN) :: ktau + INTEGER, INTENT(IN) :: iratio ! Nest to parent gridsize ratio. + INTEGER, INTENT(IN) :: npfi ! Coarse-grid diagnostics freq. + LOGICAL, INTENT(IN) :: iprt ! Print flag + INTEGER, INTENT(IN) :: nstat + INTEGER, intent(in) :: iswind + INTEGER, intent(in) :: istemp + INTEGER, intent(in) :: ismois + INTEGER, intent(in) :: ispstr + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde ! domain dims. + INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims. + INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte ! tile dims. + + REAL, INTENT(IN) :: ub( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: vb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: tb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: t0 + REAL, INTENT(IN) :: qvb( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: pbase( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: pp( ims:ime, kms:kme, jms:jme ) ! Press. perturbation (Pa) + REAL, INTENT(IN) :: rovcp + REAL, INTENT(IN) :: uratx( ims:ime, jms:jme ) ! U to U10 ratio on mass points. + REAL, INTENT(IN) :: vratx( ims:ime, jms:jme ) ! V to V10 ratio on mass points. + REAL, INTENT(IN) :: tratx( ims:ime, jms:jme ) ! T to TH2 ratio on mass points. + REAL, INTENT(IN) :: rio(niobf) ! West-east coordinate. + REAL, INTENT(IN) :: rjo(niobf) ! South-north coordinate. + REAL, INTENT(INOUT) :: rko(niobf) + REAL, INTENT(INOUT) :: varobs(nndgv, niobf) + REAL, INTENT(INOUT) :: errf(nerrf, niobf) + +! Local variables + INTEGER :: iobmg(niobf) ! Obs i-coord on mass grid + INTEGER :: jobmg(niobf) ! Obs j-coord on mass grid + INTEGER :: ia(niobf) + INTEGER :: ib(niobf) + INTEGER :: ic(niobf) + REAL :: pbbo(kds:kde) ! column base pressure (cb) at obs loc. + REAL :: ppbo(kds:kde) ! column pressure perturbation (cb) at obs loc. + + REAL :: ra(niobf) + REAL :: rb(niobf) + REAL :: rc(niobf) + REAL :: dxobmg(niobf) ! Interp. fraction (x dir) referenced to mass-grid + REAL :: dyobmg(niobf) ! Interp. fraction (y dir) referenced to mass-grid + INTEGER MM(MAXDOM) + INTEGER NNL + real :: uratio( ims:ime, jms:jme ) ! U to U10 ratio on momentum points. + real :: vratio( ims:ime, jms:jme ) ! V to V10 ratio on momentum points. + real :: pug1,pug2,pvg1,pvg2 + +! Define staggers for U, V, and T grids, referenced from non-staggered grid. + real, parameter :: gridx_t = 0.5 ! Mass-point x stagger + real, parameter :: gridy_t = 0.5 ! Mass-point y stagger + real, parameter :: gridx_u = 0.0 ! U-point x stagger + real, parameter :: gridy_u = 0.5 ! U-point y stagger + real, parameter :: gridx_v = 0.5 ! V-point x stagger + real, parameter :: gridy_v = 0.0 ! V-point y stagger + + real :: dummy = 99999. + + real :: pbhi, pphi + real :: press,ttemp !ajb scratch variables +! real model_temp,pot_temp !ajb scratch variables + +!*** DECLARATIONS FOR IMPLICIT NONE + integer nsta,ivar,n,ityp + integer iob,job,kob,iob_ms,job_ms + integer k,kbot,nml,nlb,nle + integer iobm,jobm,iobp,jobp,kobp,inpf,i,j + integer i_start,i_end,j_start,j_end ! loop ranges for uratio,vratio calc. + integer k_start,k_end + + real gridx,gridy,dxob,dyob,dzob,dxob_ms,dyob_ms + real pob + real grfacx,grfacy,uratiob,vratiob,tratiob,tratxob,fnpf + real stagx ! For x correction to mass-point stagger + real stagy ! For y correction to mass-point stagger + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + LOGICAL MP_LOCAL_DUMMASK(NIOBF) ! Mask for work to be done on this processor + LOGICAL MP_LOCAL_UOBMASK(NIOBF) ! Dot-point mask + LOGICAL MP_LOCAL_VOBMASK(NIOBF) ! Dot-point mask + LOGICAL MP_LOCAL_COBMASK(NIOBF) ! Cross-point mask +#endif +! LOGICAL, EXTERNAL :: TILE_MASK + + NSTA=NSTAT + +! FIRST, DETERMINE THE GRID TYPE CORRECTION FOR U-momentum, V-momentum, +! AND MASS POINTS, AND WHEN INEST=2, CONVERT THE STORED COARSE MESH INDICES +! TO THE FINE MESH INDEX EQUIVALENTS + +! ITYP=1 FOR U-POINTS, ITYP=2 for V-POINTS, and ITYP=3 FOR MASS POINTS + + if (iprt) then + write(6,'(a,i5,a,i2,a,i5,a)') '++++++CALL ERROB AT KTAU = ', & + KTAU,' AND INEST = ',INEST,': NSTA = ',NSTA,' ++++++' + endif + + ERRF = 0.0 ! Zero out errf array + +! Set up loop bounds for this grid's boundary conditions + i_start = max( its-1,ids ) + i_end = min( ite+1,ide-1 ) + j_start = max( jts-1,jds ) + j_end = min( jte+1,jde-1 ) + k_start = kts + k_end = min( kte, kde-1 ) + + DO ITYP=1,3 ! Big loop: ityp=1 for U, ityp=2 for V, ityp=3 for T,Q,SP + +! Set grid stagger + IF(ITYP.EQ.1) THEN ! U-POINT CASE + GRIDX = gridx_u + GRIDY = gridy_u + ELSE IF(ITYP.EQ.2) THEN ! V-POINT CASE + GRIDX = gridx_v + GRIDY = gridy_v + ELSE ! MASS-POINT CASE + GRIDX = gridx_t + GRIDY = gridy_t + ENDIF + +! Compute URATIO and VRATIO fields on momentum (u,v) points. + IF(ityp.eq.1)THEN + call upoint(i_start,i_end, j_start,j_end, ids,ide, ims,ime, jms,jme, uratx, uratio) + ELSE IF (ityp.eq.2) THEN + call vpoint(i_start,i_end, j_start,j_end, jds,jde, ims,ime, jms,jme, vratx, vratio) + ENDIF + + IF(INEST.EQ.1) THEN ! COARSE MESH CASE... + DO N=1,NSTA + RA(N)=RIO(N)-GRIDX + RB(N)=RJO(N)-GRIDY + IA(N)=RA(N) + IB(N)=RB(N) + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) + DXOB=RA(N)-FLOAT(IA(N)) + DYOB=RB(N)-FLOAT(IB(N)) + +! Save mass-point arrays for computing rko for all var types + if(ityp.eq.1) then + iobmg(n) = MIN0(MAX0(1,int(RIO(n)-gridx_t)),ide-1) + jobmg(n) = MIN0(MAX0(1,int(RJO(n)-gridy_t)),jde-1) + dxobmg(n) = RIO(N)-gridx_t-FLOAT(int(RIO(N)-gridx_t)) + dyobmg(n) = RJO(N)-gridy_t-FLOAT(int(RJO(N)-gridy_t)) + endif + iob_ms = iobmg(n) + job_ms = jobmg(n) + dxob_ms = dxobmg(n) + dyob_ms = dyobmg(n) + + +!if(n.eq.1 .and. iprt) then +! write(6,*) 'ERROB - COARSE MESH:' +! write(6,'(a,i1,a,i1,4(a,f5.2),2(a,i3),2(a,f6.3))') 'OBS= ',n, & +! ' ityp= ',ityp, & +! ' ra= ',ra(n),' rb= ',rb(n), & +! ' rio= ',rio(n),' rjo= ',rjo(n), & +! ' iob= ',iob,' job= ',job, & +! ' dxob= ',dxob,' dyob= ',dyob +! write(6,'(a,i3,a,i3,a,f5.2,a,f5.2)') & +! ' iob_ms= ',iob_ms,' job_ms= ',job_ms, & +! ' dxob_ms= ',dxob_ms,' dyob_ms= ',dyob_ms +!endif + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Set mask for obs to be handled by this processor + MP_LOCAL_DUMMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte) + + IF ( MP_LOCAL_DUMMASK(N) ) THEN +#endif + +! Interpolate pressure to obs location column and convert from Pa to cb. + + do k = kds, kde + pbbo(k) = .001*( & + (1.-DYOB_MS)*( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS) + & + DXOB_MS *pbase(IOB_MS+1,K,JOB_MS) ) + & + DYOB_MS* ( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS+1) + & + DXOB_MS *pbase(IOB_MS+1,K,JOB_MS+1) ) ) + ppbo(k) = .001*( & + (1.-DYOB_MS)*( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS) + & + DXOB_MS *pp(IOB_MS+1,K,JOB_MS) ) + & + DYOB_MS* ( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS+1) + & + DXOB_MS *pp(IOB_MS+1,K,JOB_MS+1) ) ) + +! write(6,'(a,i2,2(a,f9.3)') ' k= ',k,' pbbo= ',pbbo(k),' ppbo= ',ppbo(k) + enddo + +!ajb 20040119: Note based on bugfix for dot/cross points split across processors, +!ajb which was actually a serial code fix: The ityp=2 (v-points) and +!ajb itype=3 (mass-points) cases should not use the ityp=1 (u-points) +!ajb case rko! This is necessary for bit-for-bit reproducability +!ajb with the parallel run. (coarse mesh) + + + if(abs(rko(n)+99).lt.1.)then + pob = varobs(5,n) + + if(pob .gt.-800000.)then + do k=k_end-1,1,-1 + kbot = k + if(pob .le. pbbo(k)+ppbo(k)) then + goto 199 + endif + enddo + 199 continue + + pphi = ppbo(kbot+1) + pbhi = pbbo(kbot+1) + + rko(n) = real(kbot+1)- & + ( (pob-pbhi-pphi) / (pbbo(kbot)+ppbo(kbot)-pbhi-pphi) ) + + rko(n)=max(rko(n),1.0) + endif + endif + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF !end IF( MP_LOCAL_DUMMASK(N) ) !ajb +#endif + + RC(N)=RKO(N) + + ENDDO ! END COARSE MESH LOOP OVER NSTA + + ELSE ! FINE MESH CASE + +! CONVERT (I,J,K) OF OBSERVATIONS TO THE EQUIVALENT FINE MESH VALUES. + DO N=1,NSTA + +! COMPUTE THE OBS LOCATION WITH RESPECT TO THIS MESH (INEST)... + NML=INEST + MM(LEVIDN(INEST)+1)=INEST +! WORKING TOWARD COARSER MESHES, DETERMINE THE HIERARCHY OF MOTHER +! MESHES WITH RESPECT TO EACH MOTHER MESH STARTING AT MESH "IN"... +! THAT IS, DETERMINE ITS MOTHER, GRANDMOTHER, GREAT-GRANDMOTHER, ETC. +! OUT TO THE COARSE GRID MESH (INEST=1). +! LEVIDN HOLDS THE NEST LEVEL AND PARID HOLDS THE MOTHER MESH FOR EACH +! GRID (E.G., FOR 3 MESHES AND 2 NEST LEVELS, IN=1 IS THE COARSE GRID +! MESH, IN=2 HAS LEVIDN(2)=1 AND PARID(2)=1, AND IN=3 HAS LEVIDN(3)=2 +! AND PARID(3)=2...) + DO NNL=LEVIDN(INEST),1,-1 + MM(NNL)=PARID(NML) + NML=MM(NNL) + ENDDO + +! NOTE: MM(1) MUST BE THE COARSE GRID MESH (INEST=0) + IF(MM(1).NE.1) then + if(iprt) write(6,*) 'stopping in errob: inest = ',inest + STOP 21 + ENDIF + + RA(N)=RIO(N) + RB(N)=RJO(N) + DO NNL=1,LEVIDN(INEST) + GRFACX=0. + GRFACY=0. +! COMPUTE THE OBS LOCATION WITH RESPECT TO THE INNER GRID IN NON- +! STAGGERED SPACE (GRID=0.). WHEN WE REACH MESH INEST, THEN +! APPLY THE APPRPRIATE STAGGER, DEPENDING ON THE VARIABLE... + IF(NNL.EQ.LEVIDN(INEST)) THEN + GRFACX=GRIDX + GRFACY=GRIDY + ENDIF + + RA(N)=(RA(N)-FLOAT(i_parent_start(MM(NNL+1))))* & + FLOAT(IRATIO)+1.-GRFACX + RB(N)=(RB(N)-FLOAT(j_parent_start(MM(NNL+1))))* & + FLOAT(IRATIO)+1.-GRFACY + + IA(N)=RA(N) + IB(N)=RB(N) + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) + DXOB=RA(N)-FLOAT(IA(N)) + DYOB=RB(N)-FLOAT(IB(N)) + +! Save mass-point arrays for computing rko for all var types + if(ityp.eq.1) then + stagx = grfacx - gridx_t !Correct x stagger to mass-point + stagy = grfacy - gridy_t !Correct y stagger to mass-point + iobmg(n) = MIN0(MAX0(1,int(RA(n)+stagx)),ide-1) + jobmg(n) = MIN0(MAX0(1,int(RB(n)+stagy)),jde-1) + dxobmg(n) = RA(N)+stagx-FLOAT(int(RA(N)+stagx)) + dyobmg(n) = RB(N)+stagy-FLOAT(int(RB(N)+stagy)) + endif + iob_ms = iobmg(n) + job_ms = jobmg(n) + dxob_ms = dxobmg(n) + dyob_ms = dyobmg(n) + +!if(n.eq.1) then +! write(6,*) 'ERROB - FINE MESH:' +! write(6,*) 'RA = ',ra(n),' RB = ',rb(n) +! write(6,'(a,i1,a,i1,4(a,f5.2),2(a,i3),2(a,f6.3))') 'OBS= ',n, & +! ' ityp= ',ityp, & +! ' ra= ',ra(n),' rb= ',rb(n), & +! ' rio= ',rio(n),' rjo= ',rjo(n), & +! ' iob= ',iob,' job= ',job, & +! ' dxob= ',dxob,' dyob= ',dyob +! write(6,'(a,i3,a,i3,a,f5.2,a,f5.2)') & +! ' iob_ms= ',iob_ms,' job_ms= ',job_ms, & +! ' dxob_ms= ',dxob_ms,' dyob_ms= ',dyob_ms +!endif + + ENDDO ! end do nnl=1,levidn(inest) + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Set mask for obs to be handled by this processor + MP_LOCAL_DUMMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte) + + IF ( MP_LOCAL_DUMMASK(N) ) THEN +#endif + +! Interpolate pressure to obs location column and convert from Pa to cb. + + do k = kds, kde + pbbo(k) = .001*( & + (1.-DYOB_MS)*( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS) + & + DXOB_MS *pbase(IOB_MS+1,K,JOB_MS) ) + & + DYOB_MS* ( (1.-DXOB_MS)*pbase(IOB_MS,K,JOB_MS+1) + & + DXOB_MS *pbase(IOB_MS+1,K,JOB_MS+1) ) ) + ppbo(k) = .001*( & + (1.-DYOB_MS)*( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS) + & + DXOB_MS *pp(IOB_MS+1,K,JOB_MS) ) + & + DYOB_MS* ( (1.-DXOB_MS)*pp(IOB_MS,K,JOB_MS+1) + & + DXOB_MS *pp(IOB_MS+1,K,JOB_MS+1) ) ) + +! write(6,'(a,i2,2(a,f9.3)') ' k= ',k,' pbbo= ',pbbo(k),' ppbo= ',ppbo(k) + enddo + +!ajb 20040119: Note based on bugfix for dot/cross points split across processors, +!ajb which was actually a serial code fix: The ityp=2 (v-points) and +!ajb itype=3 (mass-points) cases should not use the ityp=1 (u-points) +!ajb case) rko! This is necessary for bit-for-bit reproducability +!ajb with parallel run. (fine mesh) + + if(abs(rko(n)+99).lt.1.)then + pob = varobs(5,n) + + if(pob .gt.-800000.)then + do k=k_end-1,1,-1 + kbot = k + if(pob .le. pbbo(k)+ppbo(k)) then + goto 198 + endif + enddo + 198 continue + + pphi = ppbo(kbot+1) + pbhi = pbbo(kbot+1) + + rko(n) = real(kbot+1)- & + ( (pob-pbhi-pphi) / (pbbo(kbot)+ppbo(kbot)-pbhi-pphi) ) + rko(n)=max(rko(n),1.0) + endif + endif + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF !end IF( MP_LOCAL_DUMMASK(N) ) !ajb +#endif + + RC(N)=RKO(N) + + ENDDO ! END FINE MESH LOOP OVER NSTA + + ENDIF ! end if(inest.eq.1) + +! INITIALIZE THE ARRAY OF DIFFERENCES BETWEEN THE OBSERVATIONS +! AND THE LOCAL FORECAST VALUES TO ZERO. FOR THE FINE MESH +! ONLY, SET THE DIFFERENCE TO A LARGE DUMMY VALUE IF THE +! OBSERVATION IS OUTSIDE THE FINE MESH DOMAIN. + +! SET DIFFERENCE VALUE TO A DUMMY VALUE FOR OBS POINTS OUTSIDE +! CURRENT DOMAIN + IF(ITYP.EQ.1) THEN + NLB=1 + NLE=1 + ELSE IF(ITYP.EQ.2) THEN + NLB=2 + NLE=2 + ELSE + NLB=3 + NLE=5 + ENDIF + DO IVAR=NLB,NLE + DO N=1,NSTA + IF((RA(N)-1.).LT.0)THEN + ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY + ENDIF + IF((RB(N)-1.).LT.0)THEN + ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY + ENDIF + IF((FLOAT(ide)-2.0*GRIDX-RA(N)-1.E-10).LT.0)THEN + ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY + ENDIF + IF((FLOAT(jde)-2.0*GRIDY-RB(N)-1.E-10).LT.0)THEN + ERRF(IVAR,N)=ERRF(IVAR,N)+DUMMY + ENDIF + if(rc(n).lt.1.)errf(ivar,n)=errf(ivar,n)+dummy + ENDDO + ENDDO + +! NOW FIND THE EXACT OFFSET OF EACH OBSERVATION FROM THE +! GRID POINT TOWARD THE LOWER LEFT + DO N=1,NSTA + IA(N)=RA(N) + IB(N)=RB(N) + IC(N)=RC(N) + ENDDO + DO N=1,NSTA + RA(N)=RA(N)-FLOAT(IA(N)) + RB(N)=RB(N)-FLOAT(IB(N)) + RC(N)=RC(N)-FLOAT(IC(N)) + ENDDO +! PERFORM A TRILINEAR EIGHT-POINT (3-D) INTERPOLATION +! TO FIND THE FORECAST VALUE AT THE EXACT OBSERVATION +! POINTS FOR U, V, T, AND Q. + +! Compute local masks for dot and cross points. + if(ityp.eq.1) then + DO N=1,NSTA + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Set mask for U-momemtum points to be handled by this processor + MP_LOCAL_UOBMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte) +#endif + ENDDO + endif + if(ityp.eq.2) then + DO N=1,NSTA + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Set mask for V-momentum points to be handled by this processor + MP_LOCAL_VOBMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte) +#endif + ENDDO + endif + if(ityp.eq.3) then + DO N=1,NSTA + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Set mask for cross (mass) points to be handled by this processor + MP_LOCAL_COBMASK(N) = TILE_MASK(IOB, JOB, its, ite, jts, jte) +#endif + ENDDO + endif + +!********************************************************** +! PROCESS U VARIABLE (IVAR=1) +!********************************************************** + IF(ITYP.EQ.1) THEN +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + DO N=1,NSTA + IF(MP_LOCAL_UOBMASK(N)) THEN + ERRF(9,N)=rko(n) !RKO is needed by neighboring processors !ajb + ENDIF + ENDDO +#endif + IF(ISWIND.EQ.1) THEN + DO N=1,NSTA + IOB=MAX0(2,IA(N)) + IOB=MIN0(IOB,ide-1) + IOBM=MAX0(1,IOB-1) + IOBP=MIN0(ide-1,IOB+1) + JOB=MAX0(2,IB(N)) + JOB=MIN0(JOB,jde-1) + JOBM=MAX0(1,JOB-1) + JOBP=MIN0(jde-1,JOB+1) + KOB=MIN0(K_END,IC(N)) + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + IF(MP_LOCAL_UOBMASK(N))THEN ! Do if obs on this processor +#endif + KOBP=MIN0(KOB+1,k_end) + DXOB=RA(N) + DYOB=RB(N) + DZOB=RC(N) + +! Compute surface pressure values at surrounding U and V points + PUG1 = .5*( pbase(IOBM,1,JOB) + pbase(IOB,1,JOB) ) + PUG2 = .5*( pbase(IOB,1,JOB) + pbase(IOBP,1,JOB) ) + +! This is to correct obs to model sigma level using reverse similarity theory + if(rko(n).eq.1.0)then + uratiob=((1.-DXOB)*((1.-DYOB)*uratio(IOB,JOB)+ & + DYOB*uratio(IOBP,JOB) & + )+DXOB*((1.-DYOB)*uratio(IOB,JOBP)+ & + DYOB*uratio(IOBP,JOBP))) + else + uratiob=1. + endif +!YLIU Some PBL scheme do not define the vratio/uratio + if(abs(uratiob).lt.1.0e-3) then + uratiob=1. + endif + +! INITIAL ERRF(IVAR,N) IS ZERO FOR OBSERVATIONS POINTS +! WITHIN THE DOMAIN, AND A LARGE DUMMY VALUE FOR POINTS +! OUTSIDE THE CURRENT DOMAIN + +! U COMPONENT WIND ERROR + ERRF(1,N)=ERRF(1,N)+uratiob*VAROBS(1,N)-((1.-DZOB)* & + ((1.-DyOB)*((1.- & + DxOB)*UB(IOB,KOB,JOB)+DxOB*UB(IOB+1,KOB,JOB) & + )+DyOB*((1.-DxOB)*UB(IOB,KOB,JOB+1)+DxOB* & + UB(IOB+1,KOB,JOB+1)))+DZOB*((1.-DyOB)*((1.-DxOB) & + *UB(IOB,KOBP,JOB)+DxOB*UB(IOB+1,KOBP,JOB))+ & + DyOB*((1.-DxOB)*UB(IOB,KOBP,JOB+1)+DxOB* & + UB(IOB+1,KOBP,JOB+1)))) + +! if(n.le.10) then +! write(6,*) +! write(6,'(a,i3,i3,i3,a,i3,a,i2)') 'ERRF1 at ',iob,job,kob, & +! ' N = ',n,' inest = ',inest +! write(6,*) 'VAROBS(1,N) = ',varobs(1,n) +! write(6,*) 'VAROBS(5,N) = ',varobs(5,n) +! write(6,*) 'UB(IOB,KOB,JOB) = ',UB(IOB,KOB,JOB) +! write(6,*) 'UB(IOB+1,KOB,JOB) = ',UB(IOB+1,KOB,JOB) +! write(6,*) 'UB(IOB,KOB,JOB+1) = ',UB(IOB,KOB,JOB+1) +! write(6,*) 'UB(IOB+1,KOB,JOB+1) = ',UB(IOB+1,KOB,JOB+1) +! write(6,*) 'UB(IOB,KOBP,JOB) = ',UB(IOB,KOBP,JOB) +! write(6,*) 'UB(IOB+1,KOBP,JOB) = ',UB(IOB+1,KOBP,JOB) +! write(6,*) 'UB(IOB,KOBP,JOB+1) = ',UB(IOB,KOBP,JOB+1) +! write(6,*) 'UB(IOB+1,KOBP,JOB+1) = ',UB(IOB+1,KOBP,JOB+1) +! write(6,*) 'uratiob = ',uratiob +! write(6,*) 'DXOB,DYOB,DZOB = ',DXOB,DYOB,DZOB +! write(6,*) 'ERRF(1,N) = ',errf(1,n) +! write(6,*) +! endif + + +! Store model surface pressure (not the error!) at U point. + ERRF(7,N)=.001*( (1.-DXOB)*PUG1 + DXOB*PUG2 ) + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF ! end IF( MP_LOCAL_UOBMASK(N) ) +#endif + ENDDO ! END U-POINT LOOP OVER OBS + + ENDIF ! end if(iswind.eq.1) + + ENDIF ! ITYP=1: PROCESS U + +!********************************************************** +! PROCESS V VARIABLE (IVAR=2) +!********************************************************** + IF(ITYP.EQ.2) THEN + + IF(ISWIND.EQ.1) THEN + DO N=1,NSTA + IOB=MAX0(2,IA(N)) + IOB=MIN0(IOB,ide-1) + IOBM=MAX0(1,IOB-1) + IOBP=MIN0(ide-1,IOB+1) + JOB=MAX0(2,IB(N)) + JOB=MIN0(JOB,jde-1) + JOBM=MAX0(1,JOB-1) + JOBP=MIN0(jde-1,JOB+1) + KOB=MIN0(K_END,IC(N)) + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + IF(MP_LOCAL_VOBMASK(N))THEN ! Do if obs on this processor +#endif + KOBP=MIN0(KOB+1,k_end) + DXOB=RA(N) + DYOB=RB(N) + DZOB=RC(N) + +! Compute surface pressure values at surrounding U and V points + PVG1 = .5*( pbase(IOB,1,JOBM) + pbase(IOB,1,JOB) ) + PVG2 = .5*( pbase(IOB,1,JOB) + pbase(IOB,1,JOBP) ) + +! This is to correct obs to model sigma level using reverse similarity theory + if(rko(n).eq.1.0)then + vratiob=((1.-DXOB)*((1.-DYOB)*vratio(IOB,JOB)+ & + DYOB*vratio(IOBP,JOB) & + )+DXOB*((1.-DYOB)*vratio(IOB,JOBP)+ & + DYOB*vratio(IOBP,JOBP))) + else + vratiob=1. + endif +!YLIU Some PBL scheme do not define the vratio/uratio + if(abs(vratiob).lt.1.0e-3) then + vratiob=1. + endif + +! INITIAL ERRF(IVAR,N) IS ZERO FOR OBSERVATIONS POINTS +! WITHIN THE DOMAIN, AND A LARGE DUMMY VALUE FOR POINTS +! OUTSIDE THE CURRENT DOMAIN + +! V COMPONENT WIND ERROR + ERRF(2,N)=ERRF(2,N)+vratiob*VAROBS(2,N)-((1.-DZOB)* & + ((1.-DyOB)*((1.- & + DxOB)*VB(IOB,KOB,JOB)+DxOB*VB(IOB+1,KOB,JOB) & + )+DyOB*((1.-DxOB)*VB(IOB,KOB,JOB+1)+DxOB* & + VB(IOB+1,KOB,JOB+1)))+DZOB*((1.-DyOB)*((1.-DxOB) & + *VB(IOB,KOBP,JOB)+DxOB*VB(IOB+1,KOBP,JOB))+ & + DyOB*((1.-DxOB)*VB(IOB,KOBP,JOB+1)+DxOB* & + VB(IOB+1,KOBP,JOB+1)))) + +! Store model surface pressure (not the error!) at V point. + ERRF(8,N)=.001*( (1.-DYOB)*PVG1 + DYOB*PVG2 ) + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF ! end IF( MP_LOCAL_VOBMASK(N) ) +#endif + ENDDO ! END V-POINT LOOP OVER OBS + + ENDIF ! end if(iswind.eq.1) + + ENDIF ! ITYP=1: PROCESS V + +!********************************************************** +! PROCESS MASS-POINT VARIABLES IVAR=3 (T) AND IVAR=4 (QV) +!********************************************************** + IF(ITYP.EQ.3) THEN + + IF(ISTEMP.EQ.1 .OR. ISMOIS.EQ.1) THEN + DO N=1,NSTA + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + IF(MP_LOCAL_COBMASK(N)) THEN ! Do if obs on this processor +#endif + KOB=MIN0(k_end,IC(N)) + KOBP=MIN0(KOB+1,K_END) + DXOB=RA(N) + DYOB=RB(N) + DZOB=RC(N) + +! This is to correct obs to model sigma level using reverse similarity theory + if(rko(n).eq.1.0)then + tratxob=((1.-DXOB)*((1.-DYOB)*tratx(IOB,JOB)+ & + DYOB*tratx(IOB+1,JOB) & + )+DXOB*((1.-DYOB)*tratx(IOB,JOB+1)+ & + DYOB*tratx(IOB+1,JOB+1))) + else + tratxob=1. + endif + +!yliu + if(abs(tratxob) .lt. 1.0E-3) tratxob=1. + +!ajb testing only + if(iprt .and. n.eq.81) then + write(6,*) 'POTENTIAL TEMP FOR N=81:' + write(6,*) + write(6,*) ' K THETA TEMPERATURE', & + ' PBASE' + write(6,*) + do k=k_end,1,-1 + press = pbase(iob,k,job)+pp(iob,k,job) + ttemp = exp ( alog(300.+TB(IOB,k,JOB)) - & + .2857143*alog(100000./press) ) + write(6,*) k,300.+TB(IOB,k,JOB),ttemp,pbase(iob,k,job) + enddo + endif +!ajb end testing only + +! TEMPERATURE ERROR +! if(n.le.10) then +! write(6,*) 'before: errf(3,n) = ',errf(3,n) +! endif + ERRF(3,N)=ERRF(3,N)+tratxob*VAROBS(3,N)-((1.-DZOB)* & + ((1.-DyOB)*((1.- & + DxOB)*(TB(IOB,KOB,JOB))+DxOB* & + (TB(IOB+1,KOB,JOB)))+DyOB*((1.-DxOB)* & + (TB(IOB,KOB,JOB+1))+DxOB* & + (TB(IOB+1,KOB,JOB+1))))+DZOB*((1.- & + DyOB)*((1.-DxOB)*(TB(IOB,KOBP,JOB))+DxOB* & + (TB(IOB+1,KOBP,JOB)))+DyOB*((1.-DxOB)* & + (TB(IOB,KOBP,JOB+1))+DxOB* & + (TB(IOB+1,KOBP,JOB+1))))) + +! if(n.le.10) then +! write(6,*) +! write(6,'(a,i3,i3,i3,a,i3,a,i2)') 'ERRF3 at ',iob,job,kob, & +! ' N = ',n,' inest = ',inest +! write(6,*) 'VAROBS(3,N) = ',varobs(3,n) +! write(6,*) 'VAROBS(5,N) = ',varobs(5,n) +! write(6,*) 'TB(IOB,KOB,JOB) = ',TB(IOB,KOB,JOB) +! write(6,*) 'TB(IOB+1,KOB,JOB) = ',TB(IOB+1,KOB,JOB) +! write(6,*) 'TB(IOB,KOB,JOB+1) = ',TB(IOB,KOB,JOB+1) +! write(6,*) 'TB(IOB+1,KOB,JOB+1) = ',TB(IOB+1,KOB,JOB+1) +! write(6,*) 'TB(IOB,KOBP,JOB) = ',TB(IOB,KOBP,JOB) +! write(6,*) 'TB(IOB+1,KOBP,JOB) = ',TB(IOB+1,KOBP,JOB) +! write(6,*) 'TB(IOB,KOBP,JOB+1) = ',TB(IOB,KOBP,JOB+1) +! write(6,*) 'TB(IOB+1,KOBP,JOB+1) = ',TB(IOB+1,KOBP,JOB+1) +! write(6,*) 'tratxob = ',tratxob +! write(6,*) 'DXOB,DYOB,DZOB = ',DXOB,DYOB,DZOB +! write(6,*) 'ERRF(3,N) = ',errf(3,n) +! write(6,*) +! endif + + +! MOISTURE ERROR + ERRF(4,N)=ERRF(4,N)+VAROBS(4,N)-((1.-DZOB)*((1.-DyOB)*((1.- & + DxOB)*QVB(IOB,KOB,JOB)+DxOB* & + QVB(IOB+1,KOB,JOB))+DyOB*((1.-DxOB)* & + QVB(IOB,KOB,JOB+1)+DxOB* & + QVB(IOB+1,KOB,JOB+1)))+DZOB*((1.- & + DyOB)*((1.-DxOB)*QVB(IOB,KOBP,JOB)+DxOB & + *QVB(IOB+1,KOBP,JOB))+DyOB*((1.-DxOB & + )*QVB(IOB,KOBP,JOB+1)+DxOB* & + QVB(IOB+1,KOBP,JOB+1)))) + +! Store model surface pressure (not the error!) at T-point + ERRF(6,N)= .001* & + ((1.-DyOB)*((1.-DxOB)*pbase(IOB,1,JOB)+DxOB* & + pbase(IOB+1,1,JOB))+DyOB*((1.-DxOB)* & + pbase(IOB,1,JOB+1)+DxOB*pbase(IOB+1,1,JOB+1) )) + + if(iprt .and. n.eq.81) then + write(6,*) 'ERRF(6,81) calculation:' + write(6,*) 'iob,job = ',iob,job + write(6,*) 'pbase(iob,1,job) = ',pbase(iob,1,job) + write(6,*) 'pbase(iob+1,1,job) = ',pbase(iob+1,1,job) + write(6,*) 'pbase(iob,1,job+1) = ',pbase(iob,1,job+1) + write(6,*) 'pbase(iob+1,1,job+1) = ',pbase(iob+1,1,job+1) + write(6,*) 'ERRF(6,81) = ',errf(6,n) +! call flush(6) + endif + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF ! end IF( MP_LOCAL_COBMASK(N) ) +#endif + ENDDO ! END T and QV LOOP OVER OBS + + ENDIF !end if(istemp.eq.1 .or. ismois.eq.1) + +!********************************************************** +! PROCESS SURFACE PRESSURE CROSS-POINT FIELD, IVAR=5, +! USING BILINEAR FOUR-POINT 2-D INTERPOLATION +!********************************************************** + IF(ISPSTR.EQ.1) THEN + DO N=1,NSTA + IOB=MAX0(1,IA(N)) + IOB=MIN0(IOB,ide-1) + JOB=MAX0(1,IB(N)) + JOB=MIN0(JOB,jde-1) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + IF(MP_LOCAL_COBMASK(N)) THEN ! Do if obs on this processor +#endif + DXOB=RA(N) + DYOB=RB(N) +!ajb fix this (put in correct pressure calc for IOB,JOB here) + ERRF(5,N)=ERRF(5,N)+VAROBS(5,N)-((1.-DyOB)*((1.-DxOB)* & + pbase(IOB,1,JOB)+DxOB*pbase(IOB+1,1,JOB))+DyOB* & + ((1.-DxOB)*pbase(IOB,1,JOB+1)+DxOB* & + pbase(IOB+1,1,JOB+1))) + + if(n.eq.81) then + write(6,*) 'ERRF(5,81) calculation:' + write(6,*) 'iob,job = ',iob,job + write(6,*) 'pbase(iob,1,job) = ',pbase(iob,1,job) + write(6,*) 'pbase(iob+1,1,job) = ',pbase(iob+1,1,job) + write(6,*) 'pbase(iob,1,job+1) = ',pbase(iob,1,job+1) + write(6,*) 'pbase(iob+1,1,job+1) = ',pbase(iob+1,1,job+1) + write(6,*) 'errf(5,81) = ',errf(5,n) +! call flush(6) + endif + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ENDIF ! end IF( MP_LOCAL_COBMASK(N) ) +#endif + + ENDDO + + ENDIF ! end if(ispstr.eq.1) + + ENDIF ! end if(ityp.eq.3) + + ENDDO ! END BIG LOOP + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! Gather the errf values calculated by the processors with the obs. + CALL get_full_obs_vector(nsta, nerrf, niobf, mp_local_uobmask, & + mp_local_vobmask, mp_local_cobmask, errf) +#endif + +! DIFFERENCE BETWEEN OBS AND FCST IS COMPLETED + IF(INEST.EQ.1)THEN + INPF=NPFI + ELSE + FNPF=IRATIO**LEVIDN(INEST) + INPF=FNPF*NPFI + ENDIF +! Gross error check for temperature. Set all vars bad. + do n=1,nsta + if((abs(errf(3,n)).gt.20.).and. & + (errf(3,n).gt.-800000.))then + + errf(1,n)=-888888. + errf(2,n)=-888888. + errf(3,n)=-888888. + errf(4,n)=-888888. + varobs(1,n)=-888888. + varobs(2,n)=-888888. + varobs(3,n)=-888888. + varobs(4,n)=-888888. + endif + enddo + +! For printout +! IF(MOD(KTAU,INPF).NE.0) THEN +! RETURN +! ENDIF + + RETURN + END SUBROUTINE errob + + SUBROUTINE upoint(i_start,i_end, j_start,j_end, ids,ide, ims,ime, jms,jme, & + arrin, arrout) +!------------------------------------------------------------------------------ +! PURPOSE: This subroutine interpolates a real 2D array defined over mass +! coordinate points, to U (momentum) points. +! +!------------------------------------------------------------------------------ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: i_start ! Starting i index for this model tile + INTEGER, INTENT(IN) :: i_end ! Ending i index for this model tile + INTEGER, INTENT(IN) :: j_start ! Starting j index for this model tile + INTEGER, INTENT(IN) :: j_end ! Ending j index for this model tile + INTEGER, INTENT(IN) :: ids ! Starting i index for entire model domain + INTEGER, INTENT(IN) :: ide ! Ending i index for entire model domain + INTEGER, INTENT(IN) :: ims ! Starting i index for model patch + INTEGER, INTENT(IN) :: ime ! Ending i index for model patch + INTEGER, INTENT(IN) :: jms ! Starting j index for model patch + INTEGER, INTENT(IN) :: jme ! Ending j index for model patch + REAL, INTENT(IN) :: arrin ( ims:ime, jms:jme ) ! input array on mass points + REAL, INTENT(OUT) :: arrout( ims:ime, jms:jme ) ! output array on U points + +! Local variables + integer :: i, j + +! Do domain interior first + do j = j_start, j_end + do i = max(2,i_start), i_end + arrout(i,j) = 0.5*(arrin(i,j)+arrin(i-1,j)) + enddo + enddo + +! Do west-east boundaries + if(i_start .eq. ids) then + do j = j_start, j_end + arrout(i_start,j) = arrin(i_start,j) + enddo + endif + if(i_end .eq. ide-1) then + do j = j_start, j_end + arrout(i_end+1,j) = arrin(i_end,j) + enddo + endif + + RETURN + END SUBROUTINE upoint + + SUBROUTINE vpoint(i_start,i_end, j_start,j_end, jds,jde, ims,ime, jms,jme, & + arrin, arrout) +!------------------------------------------------------------------------------ +! PURPOSE: This subroutine interpolates a real 2D array defined over mass +! coordinate points, to V (momentum) points. +! +!------------------------------------------------------------------------------ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: i_start ! Starting i index for this model tile + INTEGER, INTENT(IN) :: i_end ! Ending i index for this model tile + INTEGER, INTENT(IN) :: j_start ! Starting j index for this model tile + INTEGER, INTENT(IN) :: j_end ! Ending j index for this model tile + INTEGER, INTENT(IN) :: jds ! Starting j index for entire model domain + INTEGER, INTENT(IN) :: jde ! Ending j index for entire model domain + INTEGER, INTENT(IN) :: ims ! Starting i index for model patch + INTEGER, INTENT(IN) :: ime ! Ending i index for model patch + INTEGER, INTENT(IN) :: jms ! Starting j index for model patch + INTEGER, INTENT(IN) :: jme ! Ending j index for model patch + REAL, INTENT(IN) :: arrin ( ims:ime, jms:jme ) ! input array on mass points + REAL, INTENT(OUT) :: arrout( ims:ime, jms:jme ) ! output array on V points + +! Local variables + integer :: i, j + +! Do domain interior first + do j = max(2,j_start), j_end + do i = i_start, i_end + arrout(i,j) = 0.5*(arrin(i,j)+arrin(i,j-1)) + enddo + enddo + +! Do south-north boundaries + if(j_start .eq. jds) then + do i = i_start, i_end + arrout(i,j_start) = arrin(i,j_start) + enddo + endif + if(j_end .eq. jde-1) then + do i = i_start, i_end + arrout(i,j_end+1) = arrin(i,j_end) + enddo + endif + + RETURN + END SUBROUTINE vpoint + + LOGICAL FUNCTION TILE_MASK(iloc, jloc, its, ite, jts, jte) +!------------------------------------------------------------------------------ +! PURPOSE: Check to see if an i, j grid coordinate is in the tile index range. +! +! Returns: TRUE if the grid coordinate (ILOC,JLOC) is in the tile defined by +! tile-range indices (its,jts) and (ite,jte) +! FALSE otherwise. +! +!------------------------------------------------------------------------------ + IMPLICIT NONE + + INTEGER, INTENT(IN) :: iloc + INTEGER, INTENT(IN) :: jloc + INTEGER, INTENT(IN) :: its + INTEGER, INTENT(IN) :: ite + INTEGER, INTENT(IN) :: jts + INTEGER, INTENT(IN) :: jte + +! Local variables + LOGICAL :: retval + + TILE_MASK = (iloc .LE. ite .AND. iloc .GE. its .AND. & + jloc .LE. jte .AND. jloc .GE. jts ) + + RETURN + END FUNCTION TILE_MASK + +!----------------------------------------------------------------------- + SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur, & + xtime, mu, msf, nndgv, nerrf, niobf, maxdom, & + npfi, ionf, rinxy, twindo, levidn, & + parid, nstat, i_parent_start, j_parent_start, & + fdob, lev_in_ob, plfo, nlevs_ob, & + iratio, dx, dtmin, rio, rjo, rko, & + timeob, varobs, errf, pbase, ptop, pp, & + iswind, istemp, ismois, giv, git, giq, & + savwt, kpblt, nscan, & + iprt, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte ) ! tile dims + +!----------------------------------------------------------------------- + USE module_model_constants + USE module_domain +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! +! PURPOSE: THIS SUBROUTINE GENERATES NUDGING TENDENCIES FOR THE J-TH +! VERTICAL SLICE (I-K PLANE) FOR FOUR-DIMENSIONAL DATA +! ASSIMILATION FROM INDIVIDUAL OBSERVATIONS. THE NUDGING +! TENDENCIES ARE FOUND FROM A ONE-PASS CALCULATION OF +! WEIGHTING FACTORS SIMILAR TO THE BENJAMIN-SEAMAN OBJECTIVE +! ANALYSIS. THIS SUBROUTINE IS DESIGNED FOR RAPID EXECUTION +! AND MINIMAL STORAGE REQUIREMENTS. ALGORITHMS SHOULD BE +! VECTORIZED WHEREVER POSSIBLE. +! +! HISTORY: Original author: MM5 version??? +! 02/04/2004 - Creation of WRF version. Al Bourgeois +! 08/28/2006 - Conversion from F77 to F90 Al Bourgeois +!------------------------------------------------------------------------------ +! +! NOTE: This routine was originally designed for MM5, which uses +! a nonstandard (I,J) coordinate system. For WRF, I is the +! east-west running coordinate, and J is the south-north +! running coordinate. So a "J-slab" here is west-east in +! extent, not south-north as for MM5. -ajb 06/10/2004 +! +! NET WEIGHTING (WT) OF THE DIFFERENCE BETWEEN THE OBSERVATIONS +! AND LOCAL FORECAST VALUES IS BASED ON THE MULTIPLE OF THREE +! +! NET WEIGHTING (WT) OF THE DIFFERENCE BETWEEN THE OBSERVATIONS +! AND LOCAL FORECAST VALUES IS BASED ON THE MULTIPLE OF THREE +! TYPES OF FACTORS: +! 1) TIME WEIGHTING - ONLY OBSERVATIONS WITHIN A SELECTED +! TIME WINDOW (TWINDO) CENTERED AT THE CURRENT FORECAST +! TIME (XTIME) ARE USED. OBSERVATIONS CLOSEST TO +! XTIME ARE TIME-WEIGHTED MOST HEAVILY (TIMEWT) +! 2) VERTICAL WEIGHTING - NON-ZERO WEIGHTS (WTSIG) ARE +! CALCULATED WITHIN A VERTICAL REGION OF INFLUENCE +! (RINSIG). +! 3) HORIZONTAL WEIGHTING - NON-ZERO WEIGHTS (WTIJ) ARE +! CALCULATED WITHIN A RADIUS OF INFLUENCE (RINXY). THE +! VALUE OF RIN IS DEFINED IN KILOMETERS, AND CONVERTED +! TO GRID LENGTHS FOR THE APPROPRIATE MESH SIZE. +! +! THE FIVE FORECAST VARIABLES ARE PROCESSED BY CHANGING THE +! VALUE OF IVAR AS FOLLOWS: +! IVAR VARIABLE(TAU-1) +! ---- --------------- +! 1 U +! 2 V +! 3 T +! 4 QV +! 5 PSB(CROSS) REMOVED IN V3 +! (6) PSB(DOT) +! +!----------------------------------------------------------------------- +! +! Description of input arguments. +! +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde ! domain dims. + INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims. + INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte ! tile dims. + INTEGER, INTENT(IN) :: j ! south-north running coordinate. + INTEGER, INTENT(IN) :: ivar + INTEGER, INTENT(IN) :: inest ! domain index + LOGICAL, INTENT(IN) :: ifrest + INTEGER, INTENT(IN) :: ktau + INTEGER, INTENT(IN) :: ktaur + REAL, INTENT(IN) :: xtime ! forecast time in minutes + INTEGER, INTENT(IN) :: nndgv ! number of nudge variables + INTEGER, INTENT(IN) :: nerrf ! number of error fields + INTEGER, INTENT(IN) :: niobf ! number of observations + INTEGER, INTENT(IN) :: maxdom ! maximum number of domains + INTEGER, INTENT(IN) :: npfi + INTEGER, INTENT(IN) :: ionf + REAL, INTENT(IN) :: rinxy + REAL, INTENT(IN) :: twindo + INTEGER, INTENT(IN) :: levidn(maxdom) ! level of nest + INTEGER, INTENT(IN) :: parid(maxdom) ! parent domain id + INTEGER, INTENT(IN) :: nstat ! number of obs stations + INTEGER, INTENT(IN) :: i_parent_start(maxdom) ! Start i index in parent domain. + INTEGER, INTENT(IN) :: j_parent_start(maxdom) ! Start j index in parent domain. + TYPE(fdob_type), intent(inout) :: fdob + REAL, INTENT(IN) :: lev_in_ob(niobf) ! Level in sounding-type obs. + REAL, intent(IN) :: plfo(niobf) + REAL, INTENT(IN) :: nlevs_ob(niobf) ! Number of levels in sounding. + INTEGER, INTENT(IN) :: iratio ! Nest to parent gridsize ratio. + REAL, INTENT(IN) :: dx ! This domain grid cell-size (m) + REAL, INTENT(IN) :: dtmin + REAL, INTENT(IN) :: rio(niobf) + REAL, INTENT(IN) :: rjo(niobf) + REAL, INTENT(INOUT) :: rko(niobf) + REAL, INTENT(IN) :: timeob(niobf) + REAL, INTENT(IN) :: varobs(nndgv,niobf) + REAL, INTENT(IN) :: errf(nerrf, niobf) + REAL, INTENT(IN) :: pbase( ims:ime, kms:kme ) ! Base pressure. + REAL, INTENT(IN) :: ptop + REAL, INTENT(IN) :: pp( ims:ime, kms:kme ) ! Pressure perturbation (Pa) + REAL, INTENT(IN) :: mu(ims:ime) ! Air mass on u, v, or mass-grid + REAL, INTENT(IN) :: msf(ims:ime) ! Map scale (only used for vars u & v) + INTEGER, intent(in) :: iswind ! Nudge flag for wind + INTEGER, intent(in) :: istemp ! Nudge flag for temperature + INTEGER, intent(in) :: ismois ! Nudge flag for moisture + REAL, intent(in) :: giv ! Coefficient for wind + REAL, intent(in) :: git ! Coefficient for temperature + REAL, intent(in) :: giq ! Coefficient for moisture + REAL, INTENT(INOUT) :: aten( ims:ime, kms:kme) + REAL, INTENT(INOUT) :: savwt( nndgv, ims:ime, kms:kme ) + INTEGER, INTENT(IN) :: kpblt(its:ite) + INTEGER, INTENT(IN) :: nscan ! number of scans + LOGICAL, INTENT(IN) :: iprt ! print flag + +! Local variables + integer :: mm(maxdom) + real :: ra(niobf) + real :: rb(niobf) + real :: psurf(niobf) + real :: wtsig(kms:kme),wt(ims:ime,kms:kme),wt2err(ims:ime,kms:kme) + real :: rscale(ims:ime) ! For converting to rho-coupled units. +! real :: tscale(ims:ime,kms:kme) ! For converting to potential temp. units. + real :: reserf(100) + character*40 name + character*3 chr_hr + +!*** DECLARATIONS FOR IMPLICIT NONE + integer :: i,k,iplo,icut,ipl,inpf,infr,jjjn + integer :: igrid,n,nml,nnl,nsthis,nsmetar,nsspeci,nsship + integer :: nssynop,nstemp,nspilot,nssatwnds,nssams,nsprofs + integer :: maxi,mini,maxj,minj,nnn,nsndlev,njcsnd,kob + integer :: komin,komax,nn,nhi,nlo,nnjc + integer :: i_s,i_e + integer :: istq + real :: gfactor,rfactor,gridx,gridy,rindx,schnes,ris + real :: grfacx,grfacy + real :: fdtim,tw1,tw2,tconst,timewt,timewt2,ttim,dift,pob + real :: ri,rj,rx,ry,rsq,wtij,pdfac,erfivr,dk,slope,rinfac + real :: rinprs,pijk,pobhi,poblo,pdiffj,w2eowt,gitq + + real :: scratch + +! print *,'start nudob, nstat,j,ivar=',nstat,j,ivar +! if(ivar.ne.4)return +!yliu start -- for multi-scans: NSCAN=0: original +! NSCAN=1: added a scan with a larger Ri and smaller G +! if(NSCAN.ne.0 .and. NSCAN.ne.1) stop +! ajb note: Will need to increase memory for SAVWT if NSCAN=1: + if(NSCAN.ne.0) then + IF (iprt) write(6,*) 'SAVWT must be resized for NSCAN=1' + stop + endif + IPLO=0 + NSCAN*4 + GFACTOR=1. + NSCAN*(-1. + 0.33333) + RFACTOR=1. + NSCAN*(-1. + 3.0) +!yliu end +! jc + +! return if too close to j boundary + if(inest.eq.1.and.ivar.lt.3.and.(j.le.2.or.j.ge.jde-1)) then +! write(6,*) '1 RETURN: IVAR = ',ivar,' J = ',j, +! $ ' too close to boundary.' + return + endif + if(inest.eq.1.and.ivar.ge.3.and.(j.le.2.or.j.ge.jde-2)) then +! write(6,*) '2 RETURN: IVAR = ',ivar,' J = ',j, +! $ ' too close to boundary.' + return + endif + +! COMPUTE IPL WHICH REPRESENTS IVAR FOR EACH MESH IN SAVWT MODS + ICUT=0 + IF(INEST.GT.1)ICUT=1 + i_s = max0(2+icut,its) + i_e = min0(ide-1-icut,ite) + + IPL=IVAR + IPLO !yliu +IPLO + +! DEFINE GRID-TYPE OFFSET FACTORS, IGRID AND GRID + + IF(INEST.EQ.1)THEN + INPF=NPFI + INFR=IONF + ELSE + IF(IRATIO.NE.3) THEN + IF (iprt) THEN + write(6,*) 'iratio = ',iratio + write(6,*) 'stop 1 in nudob: iratio = ',iratio + ENDIF + STOP 1 + ENDIF + INPF=(3**LEVIDN(INEST))*NPFI + INFR=(3**LEVIDN(INEST))*IONF + ENDIF + GRIDX=0.0 + GRIDY=0.0 + IGRID=0 + IF(IVAR.GE.3)THEN + GRIDX=0.5 + GRIDY=0.5 + IGRID=1 + ELSEIF(IVAR.eq.1) THEN + GRIDY=0.5 + IGRID=1 + ELSEIF(IVAR.eq.2) THEN + GRIDX=0.5 + IGRID=1 + ENDIF + +! TRANSFORM THE HORIZONTAL RADIUS OF INFLUENCE, RINXY, FROM +! KILOMETERS TO GRID LENGTHS, RINDX + + RINDX=RINXY*1000./DX * RFACTOR !yliu *RFACTOR + +! jc +! make horizontal radius vary per nest +! rindx=rindx/float(inest) +! yliu test1 -- En 3, 4 +! rindx=rindx/float(3**(in-1)) !YLIU +! jc +! make horizontal radius vary per nest +! schnes=1/float(inest) !JC +! yliu test1 -- En 3, 4 !YLIU + schnes=1/float(3**(inest-1)) !JC +! reduce the Rinf in the nested grid proportionally + rindx=rindx*schnes +! rinfmn =1., rinfmx=2., pfree=50 in param.F +! yliu test: for upper-air data, use larger influence radii +! Essentially increase the slope -- the same radii +! at 500mb and above as the coarse mesh and the +! same small radii at sfc as that for sfc obs + fdob%rinfmx=2. *1.0 /schnes !YLIU +! rinfmx=1.2*1.0 /schnes !YLIU +! jc + RIS=RINDX*RINDX + IF(IFREST.AND.KTAU.EQ.KTAUR)GOTO 5 + IF(MOD(KTAU,INFR).NE.0)GOTO 126 +5 CONTINUE + IF (iprt) THEN + IF(J.EQ.10) write(6,6) INEST,J,KTAU,XTIME,IVAR,IPL,rindx + ENDIF +6 FORMAT(1X,'OBS NUDGING FOR IN,J,KTAU,XTIME,', & + 'IVAR,IPL: ',I2,1X,I2,1X,I5,1X,F8.2,1X,I2,1X,I2, & + ' rindx=',f4.1) + +! SET RA AND RB + IF(INEST.EQ.1) THEN + +! SET RA AND RB FOR THE COARSE MESH... + DO N=1,NSTAT + RA(N)=RIO(N)-GRIDX + RB(N)=RJO(N)-GRIDY + ENDDO + + ELSE + +! SET RA AND RB FOR THE FINE MESH CASE... + DO N=1,NSTAT + +! COMPUTE THE OBS LOCATION WITH RESPECT TO THIS MESH (INEST)... + NML=INEST + MM(LEVIDN(INEST)+1)=INEST +! WORKING TOWARD COARSER MESHES, DETERMINE THE HIERARCHY OF MOTHER +! MESHES WITH RESPECT TO EACH MOTHER MESH STARTING AT MESH "INEST"... +! THAT IS, DETERMINE ITS MOTHER, GRANDMOTHER, GREAT-GRANDMOTHER, ETC. +! OUT TO THE COARSE GRID MESH (INEST=1). +! LEVIDN HOLDS THE NEST LEVEL AND PARID HOLDS THE MOTHER MESH FOR EACH +! GRID (E.G., FOR 3 MESHES AND 2 NEST LEVELS, INEST=1 IS THE COARSE GRID +! MESH, INEST=2 HAS LEVIDN(2)=1 AND PARID(2)=1, AND INEST=3 HAS LEVIDN(3)=2 +! AND PARID(3)=2...) + DO NNL=LEVIDN(INEST),1,-1 + MM(NNL)=PARID(NML) + NML=MM(NNL) + ENDDO + +! MM(1) MUST BE THE COARSE GRID MESH (INEST=0) + + IF(MM(1).NE.1) then + IF (iprt) write(6,*) 'stop 21 in nudob: inest = ',inest + STOP 21 + ENDIF + RA(N)=RIO(N) + RB(N)=RJO(N) + DO NNL=1,LEVIDN(INEST) + GRFACX=0. + GRFACY=0. +! COMPUTE THE OBS LOCATION WITH RESPECT TO THE INNER GRID IN DOT-POINT +! SPACE (GRID=0.). WHEN WE REACH MESH IN, THEN USE "GRID" TO GO TO +! CROSS OR DOT DEPENDING ON THE VARIABLE... + IF(NNL.EQ.LEVIDN(INEST)) THEN + GRFACX=GRIDX + GRFACY=GRIDY + ENDIF + + RA(N)=(RA(N)-FLOAT(i_parent_start(MM(NNL+1))))* & + FLOAT(IRATIO)+1.-GRFACX + RB(N)=(RB(N)-FLOAT(j_parent_start(MM(NNL+1))))* & + FLOAT(IRATIO)+1.-GRFACY + + ENDDO + + ENDDO ! END LOOP OVER OBS STATIONS FOR FINE MESH CASE + + ENDIF ! END SECTION FOR SETTING RA AND RB + + +! OUTPUT OBS PER GRID EVERY HOUR + if ( mod(xtime,60.).gt.56. .and. ivar.eq.3 .and. j.eq.10) then + IF (iprt) print *,'outputting obs number on grid ', & + inest,' at time=',xtime + write(chr_hr(1:3),'(i3)')nint(xtime/60.) + if(chr_hr(1:1).eq.' ')chr_hr(1:1)='0' + if(chr_hr(2:2).eq.' ')chr_hr(2:2)='0' + IF (iprt) print *,'chr_hr=',chr_hr(1:3),nint(xtime/60.) + open(91,file= & + 'obs_g'//char(inest+ichar('0'))//'_'//chr_hr(1:3), & + form='FORMATted',status='unknown') + write(91,911)nstat + write(6,911)nstat +911 FORMAT('total obs=',i8) + nsthis=0 + nsmetar=0 + nsspeci=0 + nsship=0 + nssynop=0 + nstemp=0 + nspilot=0 + nssatwnds=0 + nssams=0 + nsprofs=0 +! print *,'ide,jde=',ide,jde + do jjjn=1,nstat +! DETERMINE THE TIME-WEIGHT FACTOR FOR N + FDTIM=XTIME-DTMIN +! CONVERT TWINDO AND TIMEOB FROM HOURS TO MINUTES: + TW1=TWINDO/2.*60. + TW2=TWINDO*60. + TCONST=1./TW1 + TIMEWT2=0.0 + TTIM=TIMEOB(jjjn)*60. +!***********TTIM=TARGET TIME IN MINUTES + DIFT=ABS(FDTIM-TTIM) + IF(DIFT.LE.TW1)TIMEWT2=1.0 + + IF(DIFT.GT.TW1.AND.DIFT.LE.TW2) THEN + IF(FDTIM.LT.TTIM)TIMEWT2=(FDTIM-(TTIM-TW2))*TCONST + IF(FDTIM.GT.TTIM)TIMEWT2=((TTIM+TW2)-FDTIM)*TCONST + ENDIF + +! print *,'timewt2=',timewt2,ttim,fdtim + if (ra(jjjn).ge.1. .and. rb(jjjn).ge.1. & + .and.ra(jjjn).le.real(ide) .and. rb(jjjn).le.real(jde) & + .and.timewt2.gt.0.) then + if(lev_in_ob(jjjn).eq.1.)nsthis=nsthis+1 + if(plfo(jjjn).eq.1.)nsmetar=nsmetar+1 + if(plfo(jjjn).eq.2.)nsspeci=nsspeci+1 + if(plfo(jjjn).eq.3.)nsship=nsship+1 + if(plfo(jjjn).eq.4.)nssynop=nssynop+1 + if(plfo(jjjn).eq.5..and.lev_in_ob(jjjn).eq.1.) nstemp=nstemp+1 + if(plfo(jjjn).eq.6..and.lev_in_ob(jjjn).eq.1.) nspilot=nspilot+1 + if(plfo(jjjn).eq.7.)nssatwnds=nssatwnds+1 + if(plfo(jjjn).eq.8.)nssams=nssams+1 + if(plfo(jjjn).eq.9..and.lev_in_ob(jjjn).eq.1.) nsprofs=nsprofs+1 + endif + enddo + write(91,912)nsthis + write(6,912)nsthis +912 FORMAT('total obs on this grid=',i8) + write(91,921)nsmetar + write(6,921)nsmetar +921 FORMAT('total metar obs on this grid=',i8) + write(91,922)nsspeci + write(6,922)nsspeci +922 FORMAT('total special obs on this grid=',i8) + write(91,923)nsship + write(6,923)nsship +923 FORMAT('total ship obs on this grid=',i8) + write(91,924)nssynop + write(6,924)nssynop +924 FORMAT('total synop obs on this grid=',i8) + write(91,925)nstemp + write(6,925)nstemp +925 FORMAT('total temp obs on this grid=',i8) + write(91,926)nspilot + write(6,926)nspilot +926 FORMAT('total pilot obs on this grid=',i8) + write(91,927)nssatwnds + write(6,927)nssatwnds +927 FORMAT('total sat-wind obs on this grid=',i8) + write(91,928)nssams + write(6,928)nssams +928 FORMAT('total sams obs on this grid=',i8) + write(91,929)nsprofs + write(6,929)nsprofs +929 FORMAT('total profiler obs on this grid=',i8) + close(91) + endif ! END OUTPUT OBS PER GRID EVERY HOUR + + +! INITIALIZE WEIGHTING ARRAYS TO ZERO + DO I=its,ite + DO K=1,kte + WT(I,K)=0.0 + WT2ERR(I,K)=0.0 + ENDDO + ENDDO + +! DO P* COMPUTATIONS ON DOT POINTS FOR IVAR.LT.3 (U AND V) +! AND CROSS POINTS FOR IVAR.GE.3 (T,Q,P*). +! +! COMPUTE P* AT OBS LOCATION (RA,RB). DO THIS AS SEPARATE VECTOR LOOP H +! SO IT IS ALREADY AVAILABLE IN NSTAT LOOP 120 BELOW + +! PSURF IS NOT AVAILABLE GLOBALLY, THEREFORE, THE BILINEAR INTERPOLATION +! AROUND THE OBS POINT IS DONE IN ERROB() AND STORED IN ERRF([678],N) FOR +! THE POINT (6=PRESS, 7=U-MOM, 8=V-MOM). + DO N=1,NSTAT + IF(IVAR.GE.3)THEN + PSURF(N)=ERRF(6,N) + ELSE + IF(IVAR.EQ.1)THEN + PSURF(N)=ERRF(7,N) ! U-points + ELSE + PSURF(N)=ERRF(8,N) ! V-points + ENDIF + ENDIF + ENDDO + +! DETERMINE THE LIMITS OF THE SEARCH REGION FOR THE CURRENT +! J-STRIP + + MAXJ=J+IFIX(RINDX*fdob%RINFMX+0.99) !ajb + MINJ=J-IFIX(RINDX*fdob%RINFMX+0.99) !ajb + +! jc comment out this? want to use obs beyond the domain? +! MAXJ=MIN0(JL-IGRID,MAXJ) !yliu +! MINJ=MAX0(1,MINJ) !yliu + + n=1 + +!*********************************************************************** + DO nnn=1,NSTAT ! BEGIN OUTER LOOP FOR THE NSTAT OBSERVATIONS +!*********************************************************************** +! Soundings are consecutive obs, but they need to be treated as a single +! entity. Thus change the looping to nnn, with n defined separately. + + +!yliu +! note for sfc data: nsndlev=1 and njcsnd=1 + nsndlev=int(nlevs_ob(n)-lev_in_ob(n))+1 + +! yliu start -- set together with the other parts +! test: do the sounding levels as individual obs +! nsndlev=1 +! yliu end + njcsnd=nsndlev +! set pob here, to be used later + pob=varobs(5,n) +! print *, "s-- n=,nsndlev",n,njcsnd,J, ipl +! print *, "s--",ivar,(errf(ivar,i),i=n,n+njcsnd) +! CHECK TO SEE OF STATION N HAS DATA FOR VARIABLE IVAR +! AND IF IT IS SUFFICIENTLY CLOSE TO THE J STRIP. THIS +! SHOULD ELIMINATE MOST STATIONS FROM FURTHER CONSIDER- +! ATION. + +!yliu: Skip bad obs if it is sfc or single level sounding. +!yliu: Before this (020918), a snd will be skipped if its first +!yliu level has bad data- often true due to elevation + + IF( ABS(ERRF(IVAR,N)).GT.9.E4 .and. njcsnd.eq.1 ) THEN +! print *, " bad obs skipped" + + ELSEIF( RB(N).LT.FLOAT(MINJ) .OR. RB(N).GT.FLOAT(MAXJ) ) THEN +! print *, " skipped obs far away from this J-slice" + +!---------------------------------------------------------------------- + ELSE ! BEGIN SECTION FOR PROCESSING THE OBSERVATION +!---------------------------------------------------------------------- + +! DETERMINE THE TIME-WEIGHT FACTOR FOR N + FDTIM=XTIME-DTMIN +! TWINDO IS IN MINUTES: + TW1=TWINDO/2.*60. + TW2=TWINDO*60. + TCONST=1./TW1 + TIMEWT=0.0 + TTIM=TIMEOB(N)*60. +!***********TTIM=TARGET TIME IN MINUTES + DIFT=ABS(FDTIM-TTIM) + IF(DIFT.LE.TW1)TIMEWT=1.0 + IF(DIFT.GT.TW1.AND.DIFT.LE.TW2) THEN + IF(FDTIM.LT.TTIM)TIMEWT=(FDTIM-(TTIM-TW2))*TCONST + IF(FDTIM.GT.TTIM)TIMEWT=((TTIM+TW2)-FDTIM)*TCONST + ENDIF + +! DETERMINE THE LIMITS OF APPLICATION OF THE OBS IN THE VERTICAL +! FOR THE VERTICAL WEIGHTING, WTSIG + +! ASSIMILATE OBSERVATIONS ON PRESSURE LEVELS, EXCEPT FOR SURFACE +!ajb 20021210: (Bugfix) RKO is not available globally. It is computed in +!ajb ERROB() by the processor handling the obs point, and stored in ERRF(9,N). + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + rko(n) = errf(9,n) !ajb 20021210 +#endif + KOB=nint(RKO(N)) + KOB=MIN0(kte,KOB) + KOB=MAX0(1,KOB) + +! ASSIMILATE SURFACE LAYER DATA ON SIGMA + IF(KOB.EQ.1.AND.IVAR.LE.4.and.nlevs_ob(n).lt.1.5) THEN + DO K=1,kte + WTSIG(K)=0.0 + ENDDO +! DEFINE WTSIG: (FOR SRP: SPREAD SURFACE DATA THROUGH LOWEST 200 M) +! WTSIG(1)=1.0 +! WTSIG(2)=0.67 +! WTSIG(3)=0.33 +! KOMIN=3 +! KOMAX=1 +! DEFINE THE MAX AND MIN I VALUES FOR POSSIBLE NONZERO +! WEIGHTS, BASED ON THE RADIUS OF INFLUENCE, RINDX (IN GRID LENGTHS). +! fix this because kpblt at 1 and il is 0 + MAXI=IFIX(RA(N)+0.99+RINDX) + MAXI=MIN0(ide-1,MAXI) + MINI=IFIX(RA(N)-RINDX-0.99) + MINI=MAX0(2,MINI) +!yliu start +! use also obs outside of this domain -- surface obs +! if(RA(N).LT.0.-RINDX .or. RA(N).GT.float(IL+RINDX) .or. +! & RB(N).LT.0.-RINDX .or. RB(N).GT.float(JL+RINDX)) then +! print *, " skipped obs far away from this domain" +! currently can use obs within this domain or ones very close to (1/3 +! influence of radius in the coarse domain) this +! domain. In later case, use BC column value to approximate the model value +! at obs point -- ERRF need model field in errob.F !! + if ( RA(N).GE.(0.-RINDX/3) & + .and. RA(N).LE.float(ide)+RINDX/3 & + .and. RB(N).GE.(0.-RINDX/3) & + .and. RB(N).LE.float(jde)+RINDX/3) then + +! or use obs within this domain only +! if(RA(N).LT.1 .or. RA(N).GT.float(IL) .or. +! & RB(N).LT.1 .or. RB(N).GT.float(JL)) then +! print *, " skipped obs far outside of this domain" +! if(j.eq.3 .and. ivar.eq.3) then +! write(6,*) 'N = ',n,' exit 120 3' +! endif +!yliu end +! +! LOOP THROUGH THE NECESSARY GRID POINTS SURROUNDING +! OBSERVATION N. COMPUTE THE HORIZONTAL DISTANCE TO +! THE OBS AND FIND THE WEIGHTING SUM OVER ALL OBS + RJ=FLOAT(J) + RX=RJ-RB(N) +! WEIGHTS FOR THE 3-D VARIABLES + ERFIVR=ERRF(IVAR,N) +! +!JM I will be local, because it indexes into PDOC, WT, and others + +! if((ivar.eq.1 .or. ivar.eq.3) .and. n.le.200) then +! write(6,'(a,i3,a,i3)')'SURF OBS NEAR: N = ',n,' nest = ',inest +! write(6,'(a,f10.3,a,f10.3,a,i3,a,i3,a,i3,a,i2)') +! $ ' RA =',RA(N),' RB =',RB(N),' J =',j, +! $ ' MINI =',MINI,' MAXI =',MAXI,' NEST =',inest +! endif + + DO I=max0(its,MINI),min0(ite,MAXI) + + RI=FLOAT(I) + RY=RI-RA(N) + RIS=RINDX*RINDX + RSQ=RX*RX+RY*RY +! DPRIM=SQRT(RSQ) +! THIS FUNCTION DECREASES WTIJ AS PSFC CHANGES WITHIN SEARCH RADIUS +! D=DPRIM+RINDX*DCON*ABS(PSBO(N)-PDOC(I,J)) +! DSQ=D*D +! WTIJ=(RIS-DSQ)/(RIS+DSQ) + wtij=(ris-rsq)/(ris+rsq) + scratch = (abs(psurf(n)-.001*pbase(i,1))*fdob%DCON) + pdfac=1.-AMIN1(1.0,scratch) + wtij=wtij*pdfac + WTIJ=AMAX1(0.0,WTIJ) + +! try making sfc obs weighting go thru pbl +! jc kpbl is at dot or cross only - need to interpolate? +! wtsig(1)=1. + komax=max0(3,kpblt(i)) + +! jc arbitrary check here + IF (iprt) THEN + if (kpblt(i).gt.25 .and. ktau.ne.0) & + write(6,552)inest,i,j,kpblt(i) +552 FORMAT('kpblt is gt 25, inest,i,j,kpblt=',4i4) + ENDIF + + if(kpblt(i).gt.25) komax=3 + komin=1 + dk=float(komax) + + do k=komin,komax + + wtsig(k)=float(komax-k+1)/dk + WT(I,K)=WT(I,K)+TIMEWT*WTSIG(K)*WTIJ + + WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ*WTIJ*WTSIG(K) & + *WTSIG(K)*ERFIVR + +! if(ivar.eq.1 .and. i.eq.38 .and. j.eq.78) then +! +! write(6,'(a,i2,a,f8.3,a,f8.3,a,f8.3,a,f8.3,a,f8.3)') +! 'Surface obs, after: k = ',k, & +! ' WT2ERR = ',wt2err(i,k), & +! ' TIMEWT = ',timewt, & +! ' WTIJ = ',wtij, & +! ' WSIG = ',wtsig(k), & +! ' ERFIVR = ',erfivr +! endif + + enddo + + ENDDO + +! print *, " Surface " + + endif ! end check for obs in domain +! END SURFACE-LAYER U OR V OBS NUDGING + + ELSE +! BEGIN CALCULATIONS TO SPREAD OBS INFLUENCE ALONG PRESSURE LEVELS +! +! print *,'in upper air section' +! DEFINE THE MAX AND MIN I VALUES FOR POSSIBLE NONZERO +! WEIGHTS, BASED ON THE RADIUS OF INFLUENCE, RINDX, AND RINFAC. +! RINFAC VARIES AS A LINEAR FUNCTION FROM FROM RINFMN AT P*+PTOP +! TO RINFMX AT PFREE AND "ABOVE" (LOWER PRESSURE). +!ajb SLOPE=(RINFMN-RINFMX)/(PSBO(N)+PTOP-PFREE) + + slope = (fdob%RINFMN-fdob%RINFMX)/(psurf(n)-fdob%PFREE) + + RINFAC=SLOPE*POB+fdob%RINFMX-SLOPE*fdob%pfree + RINFAC=AMAX1(RINFAC,fdob%RINFMN) + RINFAC=AMIN1(RINFAC,fdob%RINFMX) +!yliu: for multilevel upper-air data, take the maximum +! for the I loop. + if(nsndlev.gt.1) RINFAC = fdob%RINFMX +!yliu end + + MAXI=IFIX(RA(N)+0.99+RINDX*RINFAC) + MAXI=MIN0(ide-IGRID,MAXI) + MINI=IFIX(RA(N)-RINDX*RINFAC-0.99) + MINI=MAX0(1,MINI) + +! yliu start +! use also obs outside of but close to this domain -- upr data +! if( RA(N).LT.(0.-RINFAC*RINDX) +! & .or. RA(N).GT.float(IL)+RINFAC*RINDX +! & .or. RB(N).LT.(0.-RINFAC*RINDX) +! & .or. RB(N).GT.float(JL)+RINFAC*RINDX)then +! print *, " skipped obs far away from this I-range" +! currently can use obs within this domain or ones very close to (1/3 +! influence of radius in the coarse domain) this +! domain. In later case, use BC column value to approximate the model value +! at obs point -- ERRF need model field in errob.F !! + +!cc if (i.eq.39 .and. j.eq.34) then +!cc write(6,*) 'RA(N) = ',ra(n) +!cc write(6,*) 'rinfac = ',rinfac,' rindx = ',rindx +!cc endif + if( RA(N).GE.(0.-RINFAC*RINDX/3) & + .and. RA(N).LE.float(ide)+RINFAC*RINDX/3 & + .and. RB(N).GE.(0.-RINFAC*RINDX/3) & + .and. RB(N).LE.float(jde)+RINFAC*RINDX/3) then +! or use obs within this domain only +! if(RA(N).LT.1 .or. RA(N).GT.float(IL) .or. +! & RB(N).LT.1 .or. RB(N).GT.float(JL)) then +! print *, " skipped obs far outside of this domain" + +! yliu end +! is this 2 needed here - kpbl not used? +! MINI=MAX0(2,MINI) + +! LOOP THROUGH THE NECESSARY GRID POINTS SURROUNDING +! OBSERVATION N. COMPUTE THE HORIZONTAL DISTANCE TO +! THE OBS AND FIND THE WEIGHTING SUM OVER ALL OBS + RJ=FLOAT(J) + RX=RJ-RB(N) +! WEIGHTS FOR THE 3-D VARIABLES +! + ERFIVR=ERRF(IVAR,N) +! jc + nsndlev=int(nlevs_ob(n)-lev_in_ob(n))+1 +! yliu start +! test: do the sounding levels as individual obs +! nsndlev=1 +! yliu end + njcsnd=nsndlev +! + DO I=max0(its,MINI),min0(ite,MAXI) +! jc + RI=FLOAT(I) + RY=RI-RA(N) + RIS=RINDX*RINFAC*RINDX*RINFAC + RSQ=RX*RX+RY*RY +! yliu test: for upper-air data, keep D1 influence radii +! RIS=RIS /schnes /schnes + WTIJ=(RIS-RSQ)/(RIS+RSQ) + WTIJ=AMAX1(0.0,WTIJ) +! weight ob in vertical with +- 50 mb +! yliu: 75 hba for single upper-air, 30hba for multi-level soundings + if(nsndlev.eq.1) then + rinprs=7.5 + else + rinprs=3.0 + endif +! yliu end +! +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +! --- HANDLE 1-LEVEL and MULTI-LEVEL OBSERVATIONS SEPARATELY --- +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + + if(nsndlev.eq.1)then +!---------------------------------------------------------------------- +! --- HANDLE 1-LEVEL OBSERVATIONS --- +!---------------------------------------------------------------------- + +! if(I.eq.MINI) print *, " Single snd " +! ERFIVR is the residual (difference) between the ob and the model +! at that point. We can analyze that residual up and down. +! First find komin for ob. +!yliu start -- in the old code, komax and komin were reversed! + do k=kte,1,-1 + pijk = .001*(pbase(i,k)+pp(i,k)) +! print *,'k,pijk,pob,rinprs=',k,pijk,pob,rinprs + if(pijk.ge.(pob+rinprs)) then + komin=k + go to 325 + endif + enddo + komin=1 + 325 continue +! now find komax for ob + do k=3,kte + pijk = .001*(pbase(i,k)+pp(i,k)) + if(pijk.le.(pob-rinprs)) then + komax=k + go to 326 + endif + enddo + komax=kte ! yliu 20050706 + 326 continue + +! yliu: single-level upper-air data will act either above or below the PBL top +! komax=min0(kpblt(i), komax) + if(komax.gt.kpblt(i)) komin=max0(kpblt(i), komin) + if(komin.lt.kpblt(i)) komax=min0(kpblt(i), komax) +! yliu end +! +! print *,'1 level, komin,komax=',komin,komax +! if(i.eq.MINI) then +! print *, "yyyyyyyyyyS IPL erfivr=", IPL, ERFIVR,J,pob +! ERFIVR=0 +! endif + do k=1,kte + reserf(k)=0.0 + wtsig(k)=0.0 + enddo +!yliu end + +!cc if (i.eq.39 .and. j.eq.34) then +!cc write(6,*) ' komin = ', komin,' komax = ',komax +!cc endif + + do k=komin,komax + pijk = .001*(pbase(i,k)+pp(i,k)) + reserf(k)=erfivr + wtsig(k)=1.-abs(pijk-pob)/rinprs + wtsig(k)=amax1(wtsig(k),0.0) +! print *,'k,pijk,pob,rinprs,wtsig=',k,pijk,pob,rinprs,wtsig(k) +! Now calculate WT and WT2ERR for each i,j,k point cajb + WT(I,K)=WT(I,K)+TIMEWT*WTIJ*wtsig(k) + + WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ*WTIJ* & + reserf(k)*wtsig(k)*wtsig(k) + enddo + + else +!---------------------------------------------------------------------- +! --- HANDLE MULTI-LEVEL OBSERVATIONS --- +!---------------------------------------------------------------------- +!yliu start +! if(I.eq.MINI) print *, " Multi-level snd " +! print *, " n=,nsndlev",n,nsndlev,nlevs_ob(n),lev_in_ob(n) & +! ,nlevs_ob(n+nsndlev-1),lev_in_ob(n+nsndlev-1) + if(nlevs_ob(n+nsndlev-1).ne.lev_in_ob(n+nsndlev-1)) then + IF (iprt) THEN + print *, "n = ",n,"nsndlev = ",nsndlev + print *, "nlevs_ob,lev_in_ob", & + nlevs_ob(n+nsndlev-1),lev_in_ob(n+nsndlev-1) + print *, "in nudobs.F: sounding level messed up, stopping" + ENDIF + stop + endif +!yliu end +! This is for a multi-level observation +! The trick here is that the sounding is "one ob". You don't +! want multiple levels to each be treated like separate +! and independent observations. +! At each i,j want to interpolate sounding to the model levels at that +! particular point. + komin=1 + komax=kte-2 +! this loop goes to 1501 +! do from kte-2 to 1 so don't adjust top of model. Arbitrary. +!yliu start + do k=1,kte + reserf(k)=0.0 + wtsig(k)=0.0 + enddo +!yliu end + + do k=komax,komin,-1 + + pijk = .001*(pbase(i,k)+pp(i,k)) + +! if sigma level pressure is .gt. than the lowest ob level, don't interpolate + if(pijk.gt.varobs(5,n)) then + go to 1501 + endif + +! if sigma level pressure is .lt. than the highest ob level, don't interpolate + if(pijk.le.varobs(5,n+nsndlev-1)) then + go to 1501 + endif + +! now interpolate sounding to this k +! yliu start-- recalculate WTij for each k-level +!ajb SLOPE = (fdob%RINFMN-fdob%RINFMX)/(pdoc(i,j)+PTOP-fdob%PFREE) + slope = (fdob%RINFMN-fdob%RINFMX)/ (.001*pbase(i,1)-fdob%PFREE) + RINFAC=SLOPE*pijk+fdob%RINFMX-SLOPE*fdob%PFREE + RINFAC=AMAX1(RINFAC,fdob%RINFMN) + RINFAC=AMIN1(RINFAC,fdob%RINFMX) + RIS=RINDX*RINFAC*RINDX*RINFAC + RSQ=RX*RX+RY*RY + +! for upper-air data, keep D1 influence radii +! RIS=RIS /schnes /schnes + WTIJ=(RIS-RSQ)/(RIS+RSQ) + WTIJ=AMAX1(0.0,WTIJ) +! yliu end + +! this loop goes to 1503 + do nn=2,nsndlev +! only set pobhi if varobs(ivar) is ok + pobhi=-888888. + + if(varobs(ivar,n+nn-1).gt.-800000. & + .and. varobs(5,n+nn-1).gt.-800000.) then + pobhi=varobs(5,n+nn-1) + nhi=n+nn-1 + if(pobhi.lt.pijk .and. abs(pobhi-pijk).lt.20.) then + go to 1502 ! within 200mb of obs height + endif + endif + + enddo + +! did not find any ob above within 100 mb, so jump out + go to 1501 + 1502 continue + + nlo=nhi-1 + do nnjc=nhi-1,n,-1 + if(varobs(ivar,nnjc).gt.-800000. & + .and. varobs(5,nnjc).gt.-800000.) then + poblo=varobs(5,nnjc) + nlo=nnjc + if(poblo.gt.pijk .and. abs(poblo-pijk).lt.20.) then + go to 1505 ! within 200mb of obs height + endif + endif + enddo +!yliu end -- + +! did not find any ob below within 200 mb, so jump out + go to 1501 + 1505 continue + +! interpolate to model level + pdiffj=alog(pijk/poblo)/alog(pobhi/poblo) + reserf(k)=errf(ivar,nlo)+ & + (errf(ivar,nhi)-errf(ivar,nlo))*pdiffj + wtsig(k)=1. + + 1501 continue + +! now calculate WT and WT2ERR for each i,j,k point cajb + WT(I,K)=WT(I,K)+TIMEWT*WTIJ*wtsig(k) + + WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ*WTIJ* & + reserf(k)*wtsig(k)*wtsig(k) + +! if(ivar.eq.1 .and. i.eq.38 .and. j.eq.78) then +! +! if(wt(i,k) .ne. 0.0) then +! scratch = WT2ERR(I,K)/WT(I,K) +! else +! scratch = 999. +! endif +! +! write(6,'(a,i2,a,f8.3,a,f4.2,a,f7.4,a,f4.2,a,f5.3,a,f7.4)') +! $ 'Multi-level obs: k = ',k, +! $ ' WT2ERR = ',wt2err(i,k), +! $ ' WTIJ = ',wtij, +! $ ' RSF = ',reserf(k), +! $ ' WSIG = ',wtsig(k), +! $ ' WT = ',wt(i,k), +! $ ' W2EOWT = ',scratch +! endif + + +! end do k + enddo ! enddo k levels +! end multi-levels + endif ! end if(nsndlev.eq.1) +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +! END 1-LEVEL AND MULTI-LEVEL OBSERVATIONS +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +! + ENDDO ! END DO MINI,MAXI LOOP + + endif ! check for obs in domain + +! END OF NUDGING TO OBS ON PRESSURE LEVELS + + ENDIF !end IF(KOB.EQ.1.AND.IVAR.LE.4.and.nlevs_ob(n).lt.1.5) + +!---------------------------------------------------------------------- + ENDIF ! END SECTION FOR PROCESSING OF OBSERVATION +!---------------------------------------------------------------------- + +! n=n+1 + n=n+njcsnd + +!yliu 1202 continue + if(n.gt.nstat)then +! print *,'n,nstat=',n,nstat,ivar,j + go to 1203 + endif +! print *, "e-- n=,nsndlev",n,njcsnd,nlevs_ob(n),lev_in_ob(n) + +!*********************************************************************** + ENDDO ! END OUTER LOOP FOR THE NSTAT OBSERVATIONS +!*********************************************************************** + + 1203 continue + +! WEIGHTS AND WEIGHTED DIFFERENCES HAVE BEEN SUMMED. NOW +! APPLY THE NUDGING FACTOR AND THE RESULTANT TENDENCY TO +! THE ATEN ARRAY +! ASSURE THAT WT(I,K) AND WTP(I,K) ARE NONZERO SINCE +! THEY ARE USED BELOW IN THE DENOMINATOR. + DO K=kts,kte + DO I=its,ite + IF(WT(I,K).EQ.0)THEN + WT2ERR(I,K)=0.0 + ENDIF + IF(WT(I,K).EQ.0)THEN + WT(I,K)=1.0 + ENDIF + ENDDO + ENDDO + +126 CONTINUE + + IF(IVAR.GE.3)GOTO 170 +! this is for u,v +! 3-D DOT POINT TENDENCIES + +! Calculate scales for converting nudge factor from u (v) +! to rho_u (or rho_v) units. + + call calc_rcouple_scales(mu,msf,rscale,ims,ime,its,ite) + + DO K=1,kte + + DO I=i_s,i_e + + IF(MOD(KTAU,INFR).EQ.0.OR.(IFREST.AND.KTAU.EQ.KTAUR))THEN + W2EOWT=WT2ERR(I,K)/WT(I,K) + ELSE + W2EOWT=SAVWT(IPL,I,K) + ENDIF + +! if(ivar .eq. 1 .and. i.eq.38 .and. j.eq.78 .and. k.eq.1) then +! scratch = GIV*RSCALE(I)*W2EOWT*fdob%TFACI*ISWIND*GFACTOR +! write(6,*) 'ATEN calc: k = ',k +! write(6,*) 'U before: aten = ',aten(i,k),' scr = ',scratch +! write(6,*) 'GIV = ',giv,' rscale = ',rscale(i), +! $ ' W2EOWT = ',w2eowt +! write(6,*) 'TFACI = ',fdob%tfaci,' ISWIND = ',iswind, +! $ ' GFACTOR = ',gfactor +! endif +! +! if(ivar .eq. 2 .and. i.eq.39 .and. j.eq.29) then +! scratch = GIV*RSCALE(I)*W2EOWT*fdob%TFACI*ISWIND*GFACTOR +! write(6,*) 'ATEN calc: k = ',k +! write(6,*) 'V before: aten = ',aten(i,k),' scr = ',scratch +! write(6,*) 'GIV = ',giv,' rscale = ',rscale(i), +! $ ' W2EOWT = ',w2eowt +! write(6,*) 'TFACI = ',fdob%tfaci,' ISWIND = ',iswind, +! $ ' GFACTOR = ',gfactor +! endif + + ATEN(i,k)=ATEN(i,k)+GIV*RSCALE(I) & + *W2EOWT*fdob%TFACI & + *ISWIND *GFACTOR !yliu *GFACTOR + +! if(ivar .eq. 1 .and. i.eq.38 .and. j.eq.78 .and. k.eq.1) then +! write(6,*) 'U after: aten = ',aten(i,k),' scr = ',scratch +! endif +! if(ivar .eq. 2 .and. i.eq.39 .and. j.eq.29) then +! write(6,*) 'V after: aten = ',aten(i,k),' scr = ',scratch +! endif + + ENDDO + ENDDO + + IF(MOD(KTAU,INFR).EQ.0.OR.(IFREST.AND.KTAU.EQ.KTAUR))THEN + DO K=1,kte + DO I=its,ite + SAVWT(IPL,I,K)=WT2ERR(I,K)/WT(I,K) + ENDDO + ENDDO + ENDIF + + RETURN + +170 CONTINUE + +! 3-D CROSS-POINT TENDENCIES +! this is for t (ivar=3) and q (ivsr=4) + IF(3-IVAR.LT.0)THEN + GITQ=GIQ + ELSE + GITQ=GIT + ENDIF + IF(3-IVAR.LT.0)THEN + ISTQ=ISMOIS + ELSE + ISTQ=ISTEMP + ENDIF + + DO K=1,kte + DO I=i_s,i_e + IF(MOD(KTAU,INFR).EQ.0.OR.(IFREST.AND.KTAU.EQ.KTAUR))THEN + W2EOWT=WT2ERR(I,K)/WT(I,K) + ELSE + W2EOWT=SAVWT(IPL,I,K) + ENDIF + +! if(ivar .eq. 3 .and. i.eq.39 .and. j.eq.29) then +! scratch = GITQ*MU(I)*W2EOWT*fdob%TFACI*ISTQ*GFACTOR +! write(6,*) 'ATEN calc: k = ',k +! write(6,*) 'T before: aten = ',aten(i,k),' scr = ',scratch +! write(6,*) 'GITQ = ',gitq,' MU = ',mu(i), +! $ ' W2EOWT = ',w2eowt +! write(6,*) ' TFACI = ',fdob%tfaci,' ISTQ = ',istq, +! $ ' GFACTOR = ',gfactor +! endif +! +! if(ivar .eq. 4 .and. i.eq.39 .and. j.eq.29) then +! scratch = GITQ*MU(I)*W2EOWT*fdob%TFACI*ISTQ*GFACTOR +! write(6,*) 'ATEN calc: k = ',k +! write(6,*) 'Q before: aten = ',aten(i,k),' scr = ',scratch +! write(6,*) 'GITQ = ',gitq,' MU = ',mu(i), +! $ ' W2EOWT = ',w2eowt +! write(6,*) ' TFACI = ',fdob%tfaci,' ISTQ = ',istq, +! $ ' GFACTOR = ',gfactor +! endif + + ATEN(i,k)=ATEN(i,k)+GITQ*MU(I) & + *W2EOWT*fdob%TFACI*ISTQ *GFACTOR !yliu *GFACTOR + +! if(ivar .eq. 3 .and. i.eq.39 .and. j.eq.29) then +! write(6,*) 'T after: aten = ',aten(i,k),' scr = ',scratch +! endif +! if(ivar .eq. 4 .and. i.eq.39 .and. j.eq.29) then +! write(6,*) 'Q after: aten = ',aten(i,k),' scr = ',scratch +! endif + + ENDDO + ENDDO + + IF(MOD(KTAU,INFR).EQ.0.OR.(IFREST.AND.KTAU.EQ.KTAUR)) THEN + DO K=1,kte + DO I=its,ite + SAVWT(IPL,I,K)=WT2ERR(I,K)/WT(I,K) + ENDDO + ENDDO + ENDIF + + RETURN + END SUBROUTINE nudob + + SUBROUTINE calc_rcouple_scales(a, msf, rscale, ims,ime, its,ite) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ims,ime ! Memory dimensions + INTEGER, INTENT(IN) :: its,ite ! Tile dimensions + REAL, INTENT(IN) :: a( ims:ime ) ! Air mass array + REAL, INTENT(IN) :: msf( ims:ime ) ! Map scale factor array + REAL, INTENT(OUT) :: rscale( ims:ime ) ! Scales for rho-coupling + +! Local variables + integer :: i + +! Calculate scales to be used for producing rho-coupled nudging factors. + do i = its,ite + rscale(i) = a(i)/msf(i) + enddo + + RETURN + END SUBROUTINE calc_rcouple_scales + +!ajb: Not used + SUBROUTINE set_real_array(rscale, value, ims,ime, its,ite) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ims,ime ! Memory dimensions + INTEGER, INTENT(IN) :: its,ite ! Tile dimensions + REAL, INTENT(IN) :: value ! Constant array value + REAL, INTENT(OUT) :: rscale( ims:ime ) ! Output array + +! Local variables + integer :: i + +! Set array to constant value + do i = its,ite + rscale(i) = value + enddo + + RETURN + END SUBROUTINE set_real_array + +!ajb: Not used + SUBROUTINE calc_pottemp_scales(ivar, rcp, pb, p, tscale, & + ims,ime, its,ite, & + kms,kme, kts,kte) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ims,ime, kms,kme ! Memory dimensions + INTEGER, INTENT(IN) :: its,ite, kts,kte ! Tile dimensions + INTEGER, INTENT(IN) :: ivar ! Variable identifier + REAL, INTENT(IN) :: rcp ! Constant (2./7.) + REAL, INTENT(IN) :: pb(ims:ime, kms:kme) ! Base pressure (Pa) array + REAL, INTENT(IN) :: p(ims:ime, kms:kme) ! Pressure pert. (Pa) array + REAL, INTENT(OUT) :: tscale(ims:ime, kms:kme) ! Scales for pot. temp. +! Local variables + integer :: i,k + + if(ivar.eq.3) then + +! Calculate scales to be used for producing potential temperature nudging factors. + do k = kts,kte + do i = its,ite + tscale(i,k) = ( 1000000. / ( pb(i,k)+p(i,k)) )**rcp + enddo + enddo + else +! Set to 1. for moisture scaling. + do k = kts,kte + do i = its,ite + tscale(i,k) = 1.0 + enddo + enddo + endif + + RETURN + END SUBROUTINE calc_pottemp_scales +#endif + +END MODULE module_fddaobs_rtfdda + diff --git a/wrfv2_fire/phys/module_fire_driver.F b/wrfv2_fire/phys/module_fire_driver.F new file mode 100644 index 00000000..61490ac2 --- /dev/null +++ b/wrfv2_fire/phys/module_fire_driver.F @@ -0,0 +1,266 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_fire_driver +CONTAINS + +!------------------------------------------------------------------ + + SUBROUTINE fire_driver(ifire & + ,u,v,u_frame,v_frame,mu,rho & ! send + ,itimestep,dt,dx,dy,z,z_at_w,dz8w,ht & + ,ids, ide, kds, kde, jds, jde & + ,ims, ime, kms, kme, jms, jme & + ,ifds, ifde, kfds, kfde, jfds, jfde & + ,ifms, ifme, kfms, kfme, jfms, jfme & + ,ifps, ifpe, kfps, kfpe, jfps, jfpe & + ,kts,kte,num_tiles,i_start,i_end,j_start,j_end & + ,grid_id,cen_lat,cen_lon,lat_ll,lon_ll & + ,moad_cen_lat,moad_cen_lon & + ,moad_lat_ll,moad_lon_ll,moad_dx,moad_dy & + ,moad_s_we,moad_e_we,moad_s_sn,moad_e_sn & + ,sr_x,sr_y & + ,fire_lat_init,fire_lon_init,fire_ign_time & + ,fire_shape,fire_crwn_hgt & + ,fire_ext_grnd,fire_ext_crwn,fire_sprd_mdl & + ,fire_fuel_read,fire_fuel_cat & + ,nfuel_cat,nfl,nfl_t,nfl_c,ncod,in1,in2,ixb,iyb & ! send&recv + ,icn,fg,fc,r_0,bbb,betafl,phiwc,area,area2 & + ,zf,zsf,tign_g,tign_c,tign_crt,xfg,yfg,xcd & + ,ycd,xcn,ycn,sprdx,sprdy & + ,rthfrten,rqvfrten & + ,grnhfx,grnqfx,canhfx,canqfx) ! recv + +!------------------------------------------------------------------ + + USE module_state_description, ONLY : & + FIRE_CAWFE + + USE module_model_constants + +! --- add new modules of schemes here + + USE module_fr_cawfe + + ! This driver calls subroutines for the fire parameterizations. + ! + ! fire scheme: + ! 1. CAWFE scheme (Clark, Coen, Latham 2004) + ! + +!------------------------------------------------------------------ + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +!-- rthfrten Theta tendency due to fire parameterization (K/s) +!-- rqvfrten Qv tendency due to fire parameterization (kg/kg/s) +!-- itimestep number of time steps +!-- z height above sea level (m) +!-- dx horizontal space interval (m) +!-- dt time step (second) +!-- zs +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!****************************************************************** +!------------------------------------------------------------------ +! + INTEGER, INTENT(in) :: ifire + + INTEGER, INTENT(in) :: ifds,ifde, jfds,jfde, kfds,kfde ! strt/end index domain + INTEGER, INTENT(in) :: ifms,ifme, jfms,jfme, kfms,kfme ! strt/end index memory + INTEGER, INTENT(in) :: ifps,ifpe, jfps,jfpe, kfps,kfpe ! strt/end index patch + + INTEGER, INTENT(in) :: ids,ide, jds,jde, kds,kde ! atmosphere domain dimensions + INTEGER, INTENT(in) :: ims,ime, jms,jme, kms,kme ! atmosphere memory dimensions + INTEGER, INTENT(in) :: kts,kte, num_tiles ! atmosphere tile dimensions + + INTEGER, DIMENSION(num_tiles), INTENT(in) :: & + i_start,i_end,j_start,j_end + + INTEGER, INTENT(in) :: itimestep ! current time step (cumultiv) + REAL, INTENT(in) :: dt ! time step + REAL, INTENT(in) :: dx,dy ! dx,dy on innermost atm mesh + INTEGER, INTENT(in) :: grid_id ! grid id of innermost atm mesh + REAL, INTENT(in) :: cen_lat,cen_lon ! center lat,lon of " " " + REAL, INTENT(in) :: lat_ll,lon_ll ! lat,lon of sw corner of " " " + REAL, INTENT(in) :: moad_cen_lat,moad_cen_lon ! lat,lon of center of moad + REAL, INTENT(in) :: moad_lat_ll,moad_lon_ll ! lat,lon of sw corner of moad + REAL, INTENT(in) :: moad_dx,moad_dy ! dx,dy of moad + INTEGER, INTENT(in) :: moad_s_we,moad_e_we ! strt/stop grd pts in x moad + INTEGER, INTENT(in) :: moad_s_sn,moad_e_sn ! strt/stop grd pts in y moad + + INTEGER, INTENT(in) :: sr_x,sr_y + REAL, INTENT(in) :: fire_lat_init,fire_lon_init + REAL, INTENT(in) :: fire_ign_time + INTEGER, INTENT(in) :: fire_fuel_read + INTEGER, INTENT(in) :: fire_shape + REAL, INTENT(in) :: fire_crwn_hgt + REAL, INTENT(in) :: fire_ext_crwn + REAL, INTENT(in) :: fire_ext_grnd + INTEGER, INTENT(in) :: fire_sprd_mdl + INTEGER, INTENT(in) :: fire_fuel_cat + REAL, INTENT(in) :: u_frame, v_frame + + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: u,v + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: z,z_at_w + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: rho + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: dz8w + REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: ht + REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: mu + +! ----- inout variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t,nfl_c + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: fg,fc + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: r_0,bbb,betafl,phiwc + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2 + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_c,tign_crt + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + + REAL, INTENT(inout), DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + rthfrten, & + rqvfrten + + REAL, INTENT(inout), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx + REAL, INTENT(inout), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx + +! ---- local variables + + INTEGER :: i,j,k,nk,jj,ij,its,ite,jts,jte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: v_tmp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: u_tmp + CHARACTER(LEN=128) :: msg + +!------------------------------------------------------------------ +! + CALL wrf_debug(100,'entering fire_driver') + +! -- get u and v, zero tendencies + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij,i,j,k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kts,kte + DO i=i_start(ij),i_end(ij) + v_tmp(i,k,j) = v(i,k,j) + v_frame + u_tmp(i,k,j) = u(i,k,j) + u_frame + ENDDO + ENDDO + DO k=kts,min(kte+1,kde) + DO i=i_start(ij),i_end(ij) + rthfrten(i,k,j)=0. + rqvfrten(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO +! + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i,j,k, its, ite, jts, jte ) + DO ij = 1 , num_tiles + + its = i_start(ij) ! start atmospheric tile in i + ite = i_end(ij) ! end atmospheric tile in i + jts = j_start(ij) ! start atmospheric tile in j + jte = j_end(ij) ! end atmospheric tile in j + + fire_select: SELECT CASE(ifire) + + CASE (FIRE_CAWFE) + + CALL wrf_debug(100,'entering CAWFE fire scheme') + + CALL cawfe( & + ids,ide, kds,kde, jds,jde & ! send + ,ims,ime, kms,kme, jms,jme & + ,its,ite, kts,kte, jts,jte & + ,ifds,ifde, kfds,kfde, jfds,jfde & + ,ifms,ifme, kfms,kfme, jfms,jfme & + ,itimestep,dt,dx,dy & + ,grid_id,cen_lat,cen_lon,lat_ll,lon_ll & + ,moad_cen_lat,moad_cen_lon & + ,moad_lat_ll,moad_lon_ll,moad_dx,moad_dy & + ,moad_s_we,moad_e_we,moad_s_sn,moad_e_sn & + ,sr_x,sr_y & + ,fire_lat_init,fire_lon_init,fire_ign_time/60. & + ,fire_shape,fire_sprd_mdl,fire_crwn_hgt & + ,fire_ext_grnd,fire_ext_crwn & + ,fire_fuel_read,fire_fuel_cat & + ,z,z_at_w,dz8w,ht,u_tmp,v_tmp,mu,rho & + ,nfuel_cat,nfl,nfl_t,nfl_c,ncod,in1,in2,ixb,iyb & ! send&recv + ,icn,fg,fc,r_0,bbb,betafl,phiwc,area,area2 & + ,zf,zsf,tign_g,tign_c,tign_crt,xfg,yfg,xcd & + ,ycd,xcn,ycn,sprdx,sprdy & + ,rthfrten,rqvfrten & + ,grnhfx,grnqfx,canhfx,canqfx) ! recv + + CALL wrf_debug(100,'exiting CAWFE fire scheme') + + CASE DEFAULT + + WRITE( msg , * ) 'This fire option does not exist: ifire = ', ifire + CALL wrf_error_fatal ( msg ) + + END SELECT fire_select + + ENDDO + !$OMP END PARALLEL DO + + END SUBROUTINE fire_driver + +END MODULE module_fire_driver diff --git a/wrfv2_fire/phys/module_fr_cawfe.F b/wrfv2_fire/phys/module_fr_cawfe.F new file mode 100644 index 00000000..1b55e65d --- /dev/null +++ b/wrfv2_fire/phys/module_fr_cawfe.F @@ -0,0 +1,6117 @@ +! ============================================================================= +! +! This set of modules contains the fire code ported from the CAWFE model. +! +! http://www.mmm.ucar.edu/research/wildfire/afm/afm.html +! +! This version is no longer compatible with the Clark-Hall model. It is +! now WRF specific. +! +! Created by: Edward (Ned) G. Patton +! National Center for Atmospheric Research +! Mesoscale and Microscale Meteorology Division +! Boulder, Colorado 80307-3000 +! patton@ucar.edu +! +! Under guidance by: Janice L. Coen +! National Center for Atmospheric Research +! Mesoscale and Microscale Meteorology Division +! Boulder, Colorado 80307-3000 +! coen@ucar.edu +! +! Based on: Clark, T. L., J. L. Coen and D. Latham: 2004, +! "Description of a coupled atmosphere-fire model", +! International Journal of Wildland Fire, 13, 49-63. +! +! See below for a description of the variables. +! +! There are two modules: 1) module_fr_cawfe_fuel (sets fuel params) +! 2) module_fr_cawfe (the fire code) +! +! ============================================================================= + +MODULE module_fr_cawfe_fuel + + INTEGER, PARAMETER :: nfuelcats = 14 + + INTEGER, DIMENSION( nfuelcats ) :: ichap + REAL , DIMENSION( nfuelcats ) :: weight,fgi,fci,fci_d,fct,fcbr, & + fueldepthm,fueldens,fuelmce, & + savr,st,se + +! ============================================================================= +! ----- Specification of fuel properties for the standard 13 fire +! behavior fuel models (for surface fires), along with some +! estimated canopy properties (for crown fire). +! ============================================================================= +! FUEL MODEL 1: Short grass (1 ft) +! FUEL MODEL 2: Timber (grass and understory) +! FUEL MODEL 3: Tall grass (2.5 ft) +! FUEL MODEL 4: Chaparral (6 ft) +! FUEL MODEL 5: Brush (2 ft) +! FUEL MODEL 6: Dormant brush, hardwood slash +! FUEL MODEL 7: Southern rough +! FUEL MODEL 8: Closed timber litter +! FUEL MODEL 9: Hardwood litter +! FUEL MODEL 10: Timber (litter + understory) +! FUEL MODEL 11: Light logging slash +! FUEL MODEL 12: Medium logging slash +! FUEL MODEL 13: Heavy logging slash +! + DATA fgi / 0.166, 0.897, 0.675, 2.468, 0.785, 1.345, 1.092, & + 1.121, 0.780, 2.694, 2.582, 7.749, 13.024, 1.e-7 / + DATA fueldepthm /0.305, 0.305, 0.762, 1.829, 0.61, 0.762,0.762, & + 0.0610, 0.0610, 0.305, 0.305, 0.701, 0.914, 0.305 / + DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562., & + 1889., 2484., 1764., 1182., 1145., 1159., 3500. / + DATA fuelmce / 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, & + 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12 / + DATA fueldens / nfuelcats * 32. / ! 32 if solid, 19 if rotten. + DATA st / nfuelcats* 0.0555 / + DATA se / nfuelcats* 0.010 / + +! ----- Notes on weight: (4) - best fit of Latham data; +! (5)-(7) could be 60-120; (8)-(10) could be 300-1600; +! (11)-(13) could be 300-1600 + DATA weight / 7., 7., 7., 180., 100., 100., 100., & + 900., 900., 900., 900., 900., 900., 7. / + +! ----- 1.12083 is 5 tons/acre. 5-50 tons/acre orig., 100-300 after blowdown + DATA fci_d / 0., 0., 0., 1.123, 0., 0., 0., & + 1.121, 1.121, 1.121, 1.121, 1.121, 1.121, 0./ + DATA fct / 60., 60., 60., 60., 60., 60., 60., & + 60., 120., 180., 180., 180., 180. , 60. / + DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / + +! ========================================================================= + +CONTAINS + + SUBROUTINE init_module_fire_fuel + END SUBROUTINE init_module_fire_fuel + +END MODULE module_fr_cawfe_fuel + + +! ========================================================================= +! +! The following module contains the fire code ported from the Clark-Hall model. +! +! ========================================================================= + + +MODULE module_fr_cawfe + + USE module_model_constants + + INTEGER, SAVE :: igwiz + + REAL, PARAMETER :: cmbcnst = 17.433e+06 ! J/kg dry fuel + REAL, PARAMETER :: hfgl = 17.e4 ! W/m^2 + REAL, PARAMETER :: fuelheat = cmbcnst * 4.30e-04 ! convert J/kg to BTU/lb + REAL, PARAMETER :: fuelmc_g = 0.08 ! set = 0 for dry ground fuel + REAL, PARAMETER :: fuelmc_c = 1.00 ! set = 0 for dry canopy + REAL, PARAMETER :: bmst = fuelmc_g/(1+fuelmc_g) +! REAL, PARAMETER :: ep = epsilon ! epsilon a very small number +! REAL, PARAMETER :: ep_sq = epsilon**2 + REAL, PARAMETER :: ep = 1.e-7 ! epsilon a very small number + REAL, PARAMETER :: ep_sq = ep**2 + + REAL :: tignm + REAL :: dxf,dyf + REAL :: betaop,c,e + REAL :: grndhx,grndqx,canhx,canqx + + REAL, DIMENSION( 4 ) :: xlm,ylm + + DATA igwiz /0/ ! igwiz=0 1st time through firecode at startup,restart + +CONTAINS + +! ========================================================================= + +SUBROUTINE cawfe(ids,ide, kds,kde, jds,jde, & ! incoming + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + itimestep,dt,dx,dy, & + grid_id,cen_lat,cen_lon,lat_ll,lon_ll, & + moad_cen_lat,moad_cen_lon, & + moad_lat_ll,moad_lon_ll,moad_dx,moad_dy, & + moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, & + nfrx,nfry, & + tlat_stf,tlon_stf,t_ignite,ishape,ibeh, & + z1can,alfg,alfc,ifuelread,nfuel_cat0, & + z,z_at_w,dz8w,zs,u,v,mu,rho, & + nfuel_cat,nfl,nfl_t,nfl_c,ncod, & ! in and out + in1,in2,ixb,iyb,icn, & + fg,fc,r_0,bbb,betafl,phiwc,area,area2, & + zf,zsf,tign_g,tign_c,tign_crt, & + xfg,yfg,xcd,ycd,xcn,ycn,sprdx,sprdy, & + rthfrten,rqvfrten,grnhfx,grnqfx,canhfx,canqfx) ! outgoing + +! ------------------------------------------------------------------------- +! +! ---- key indicies +! +! ids,ide start,end domain indicies for atmos. variables in x +! kds,kde start,end domain indicies for atmos. variables in z +! jds,jde start,end domain indicies for atmos. variables in y +! ims,ime start,end memory dimensions for atmos. variables in x +! kms,kme start,end memory dimensions for atmos. variables in z +! jms,jme start,end memory dimensions for atmos. variables in y +! its,ite start,end tile indicies for atmos. variables in x +! kts,kte start,end tile indicies for atmos. variables in z +! jts,jte start,end tile indicies for atmos. variables in y +! +! ifds,ifde start,end domain dimensions for fire variables indicies in x +! jfds,jfde start,end domain dimensions for fire variables indicies in y +! ifms,ifme start,end memory dimensions for fire variables indicies in x +! jfms,jfme start,end memory dimensions for fire variables indicies in y +! +! if_st,if_en start,end tile indicies for fire variables indicies in x +! jf_st,jf_en start,end tile indicies for fire variables indicies in y +! +! ---- incoming WRF variables +! +! itimestep integer time step +! dt time increment of atmos. grid that contains the fire grid +! dx,dy delta x,y of innermost atmos. grid that contains the fire grid +! grid_id integer grid id pointing to the WRF domain which are we on +! cen_lat latitude of the center of the fire domain +! cen_lon longitude of the center of the fire domain +! lat_ll latitude of the south-west corner of the fire domain +! lon_ll longitude of the south-west corner of the fire domain +! moad_cen_lat latitude of the center of the mother of all domains (moad) +! moad_cen_lon longitude of the center of the moad +! moad_lat_ll latitude of the south-west corner of the moad +! moad_lon_ll longitude of the south-west corner of the moad +! moad_dx delta x of moad grid +! moad_dy delta y of moad grid +! moad_s_we starting west-east index of moad grid +! moad_e_we ending west-east index of moad grid +! moad_s_sn starting south-north index of moad grid +! moad_e_sn ending south-north index of moad grid +! +! nfrx,nfry specified innermost atmos. grid refinement for fire grid in x,y +! tlat_stf latitude of inital fire location (degrees lat) +! tlon_stf longitude of inital fire location (degrees lon) +! t_ignite time of fire initiation (s) +! ishape what initial fire shape? +! ibeh which fire spread model? = 0 McArthur, =1 BEHAVE +! z1can lowest height crown fire heat is released (m) +! alfc extinction depth of crown fire heat (m) +! alfg extinction depth of ground fire heat (m) +! ifuelread read fuel parameters from file? or specify them? +! nfuel_cat0 if fuel parameters are specified, what category? +! +! z height above sea level of mass points (m) +! z_at_w height above sea level of w points (m) +! dz8w delta z between w points (m) +! zs height of surface above sea level (m) +! u,v incoming atmos. winds (m/s at arakawa-c grid locations) +! mu +! rho incoming atmos. density (kg/m^3 at arakawa-c grid mass points) +! +! ---- in and out fire variables +! +! nfuel_cat(i,j) integer NFFL fuel category at each fire grid cell +! nfl(i,j) = 0 means no fire line points in that cell +! nfl(i,j) = 1 means there are some fire line points in that cell +! ncod(i,j,it) is number of fire line coordinates in fire grid (i,j) +! in1(i,j,1) is i1 index for (i,j) grid +! in1(i,j,2) is j1 index for (i,j) grid +! in2(i,j,1) is i2 index for (i,j) grid +! in2(i,j,2) is j2 index for (i,j) grid +! ixb(i,j,it) = 0 means the x coord of the it tracer is within ep of boundary +! ixb(i,j,it) = 1 means the x coord of the it tracer is an interior point +! iyb(i,j,it) = 0 means the y coord of the it tracer is within ep of boundary +! iyb(i,j,it) = 1 means the y coord of the it tracer is an interior point +! icn(i,j,it) = 0 means the it coord is not a corner point +! icn(i,j,it) = 1 means the it coord is a corner point +! fg(i,j) mass of surface fuel (kg/m^2) +! fc(i,j) total mass of canopy fuel (kg/m^2) +! r_0(i,j) is the spread rate for a fire on flat ground with no wind +! bbb(i,j) is a constant in the wind correction for fire spread +! betafl(i,j) is a constant in the wind correction for fire spread +! phiwc(i,j) is a constant in the wind correction for fire spread +! area(i,j) +! area2(i,j) the sum over this is the fire area (m^2) +! zf(i,j) hgt of kds+1 mass point above sea level interp. to fire grid (m) +! zsf(i,j) hgt of surface above sea level interpolated to fire grid (m) +! tign_g(i,j) time this cell ignited ground fire (s); < 0 -> no ignition +! tign_c(i,j) time this cell ignited crown fire (s); < 0 -> no ignition +! tign_crt(i,j) time this cell ignited completely (s); < 0 -> not entirely aflame +! xfg(i,j,4) x coord of the 4 surface fuel tracers specific to grid (i,j) +! yfg(i,j,4) y coord of the 4 surface fuel tracers specific to grid (i,j) +! xcd(i,j,it) x coord of the it fire line coordinate in grid (i,j) +! ycd(i,j,it) y coord of the it fire line coordinate in grid (i,j) +! xcn(i,j,it) x coord of the normal vector at point (i,j) +! ycn(i,j,it) y coord of the normal vector at point (i,j) +! sprdx(i,j,it) spread rate in x normalized units (mostly for debug) +! sprdy(i,j,it) spread rate in y normalized units (mostly for debug) +! +! ---- key output variables from fire +! +! rthfrten theta tendency due to fire induced heat flux divergence +! rqvfrten Qv tendency due to fire induced moisture flux divergence +! +! grnhfx heat flux from ground fire (W/m^2) +! grnqfx moisture flux from ground fire (W/m^2) +! canhfx heat flux from crown fire (W/m^2) +! canqfx moisture flux from crown fire (W/m^2) +! +! ---- local fire variables +! +! fgi initial total mass of surface fuel (kg/m^2) +! fci initial total mass of crown fuel +! fci_d initial dry mass of crown fuel +! fuelmc_c initial moisture/dry mass ratio for crown fuel +! fct burn out time for crown fuel, after dry (s) +! fcbr crown fuel burn rate (kg/m^2/s) +! cmbcnst joules per kg of dry fuel +! fuelmc_g fuel particle (surface) moisture content +! fuel moisture fuelmc_g = (h2o)/(dry) +! bmst ratio of latent to sensible heat from sfc burn: +! % of total fuel mass that is water (not quite +! = % fuel moisture). bmst= (h2o)/(h2o+dry) +! so bmst = fuelmc_g / (1 + fuelmc_g) where +! fuelmc_g = ground fuel moisture +! hfgl surface fire heat flux threshold to ignite canopy (W/m^2) +! fuelloadm ovendry fuel loading, kg/m^2 (converted to lb/ft^2) +! fueldepthm fuel depth, in m (converted to ft) +! savr fuel particle surface-area-to-volume ratio (1/ft) +! grass: 3500., 10 hr fuel: 109., 100 hr fuel: 30. +! fuelheat fuel particle low heat content (btu/lb) +! fueldens ovendry particle density (lb/ft^3) +! st fuel particle total mineral content +! se fuel particle effective mineral content +! fuelmce moisture content of extinction; +! 0.30 for many dead fuels; 0.15 for grass +! weight weighting parameter determining the slope of the mass loss curve +! ranges from ~5 (fast burnup) to 1000 ( ~40% decr over 10 min). +! sfcu(i,j,6) surface wind in x-direction interpolated to grid corners (m/s) +! sfcv(i,j,6) surface wind in y-direction interpolated to grid corners (m/s) +! +! when deriving fireline coordinates we always keep the fire to our left +! +! ------------------------------------------------------------------------- +! +! .... Three components to this subroutine: +! +! Initialization +! IGWIZ loop: Initialization of variables for all +! runs including restart. Executed once each time the +! model is started on 1st pass through fire_sfc . +! Pass through tracer scheme. +! This defines fire boundary and (ground) fire line +! progression in this time step. +! Calculation of fluxes to be fed into atmosphere. +! Calculates macroscale properties of this +! fire line progression back on atmosphere in terms of +! mass burned -> heat and vapor fluxes to be fed into atmos. +! 3 parts to this: +! 1) ground fire heat+vapor release. +! 2) some ground fire heat used to dry overlying canopy. +! 3) canopy fire ignition, heat+vapor release. +! +! ------------------------------------------------------------------------- +! +! - should sometime integrate fuel depth (veg type) with ZNOT? +! +! Conversions: +! Fuel loads: 1 ton/acre = 0.224166 kg/m^2 +! ------------------------------------------------------------------------- + + USE module_fr_cawfe_fuel + USE module_wrf_error +! USE module_tecplot + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde ! atmosphere domain indices + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme ! atmosphere memory indices + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte ! atmosphere tile indices + + INTEGER, INTENT(in) :: ifds,ifde, jfds,jfde, kfds,kfde ! fire domain indices + INTEGER, INTENT(in) :: ifms,ifme, jfms,jfme, kfms,kfme ! fire memory indices + + INTEGER, INTENT(in) :: itimestep ! current time step (cumulative) + REAL, INTENT(in) :: dt ! time step + REAL, INTENT(in) :: dx,dy ! dx,dy on innermost atm mesh + INTEGER, INTENT(in) :: grid_id ! grid id of innermost atm mesh + REAL, INTENT(in) :: cen_lat,cen_lon ! center lat,lon of " " " + REAL, INTENT(in) :: lat_ll,lon_ll ! lat,lon of sw corner of " " " + REAL, INTENT(in) :: moad_cen_lat,moad_cen_lon ! lat,lon of center of moad + REAL, INTENT(in) :: moad_lat_ll,moad_lon_ll ! lat,lon of sw corner of moad + REAL, INTENT(in) :: moad_dx,moad_dy ! dx,dy of moad + INTEGER, INTENT(in) :: moad_s_we,moad_e_we ! strt/stop grd pts in x moad + INTEGER, INTENT(in) :: moad_s_sn,moad_e_sn ! strt/stop grd pts in y moad + + INTEGER, INTENT(in) :: nfrx,nfry + REAL, INTENT(in) :: tlat_stf + REAL, INTENT(in) :: tlon_stf + REAL, INTENT(in) :: t_ignite + INTEGER, INTENT(in) :: ifuelread + INTEGER, INTENT(in) :: ishape + REAL, INTENT(in) :: z1can + REAL, INTENT(in) :: alfg + REAL, INTENT(in) :: alfc + INTEGER, INTENT(in) :: ibeh + INTEGER, INTENT(in) :: nfuel_cat0 + + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: u,v + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: z,z_at_w + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: rho + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: dz8w + REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: mu + REAL, INTENT(in), DIMENSION( ims:ime, jms:jme ) :: zs + +! ----- inout variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t,nfl_c + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: fg,fc + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: r_0,bbb,betafl,phiwc + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2 + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_c,tign_crt + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + + REAL, INTENT(inout), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rthfrten + REAL, INTENT(inout), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rqvfrten + +! ----- out variables + + REAL, INTENT(out), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx + REAL, INTENT(out), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx + +! ----- local variables + + INTEGER :: if_st,if_en, jf_st,jf_en + INTEGER :: nf + INTEGER :: it + INTEGER :: i,j + INTEGER :: ib,jb + INTEGER :: idts + INTEGER :: iyes + INTEGER :: ig,jg + INTEGER :: ic,jc + + REAL :: time + REAL :: delplot + REAL :: rad + REAL :: sumarea + REAL :: a_fl + REAL :: burn_frac + REAL :: delm + REAL :: bratio + REAL :: dmass + REAL :: fcav + REAL :: delh + REAL :: grnhsum,canhsum + REAL :: ratg,ratc + REAL :: teps + REAL :: ratio + + REAL, DIMENSION( ims:ime,jms:jme,6 ) :: sfcu,sfcv + + REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: grnhft,grnqft + REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: canhft,canqft + + CHARACTER (LEN=80) :: msg + +! --- take incoming horizontal atmos. winds on arakawa-c grid and +! interpolate them to the cube corners. resulting winds (sfcu,sfcv) +! are at the south west corner of the atmos. cell and shifted up +! one-half grid point to the w-level. sfcu,sfcv will be further +! interpolated to the needed locations behind the fire line in +! sr. fire_tr. + + CALL fire_winds(u,v, & ! send + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + sfcu,sfcv) ! receive + +! ----- get the time from model start (assumes non-variable dt) + + time = FLOAT(itimestep) * dt + +! ----- set indicies over which fire grid exists +! +! these indicies are needed so that we are properly handling +! fire calculations within tiles that butt up against domain +! boundaries where the halo information is not available. +! therefore the fire exists on one less atmospheric grid point +! than the innermost domain is dimensioned. + + if_st = MAX( (its-1)*nfrx+1, ids*nfrx+1 ) + if_en = MIN( (ite)*nfrx , (ide-1)*nfrx ) + jf_st = MAX( (jts-1)*nfry+1, jds*nfry+1 ) + jf_en = MIN( (jte)*nfry , (jde-1)*nfry ) + +! ----- begin initialization for all runs, including restart + + IF (igwiz == 0) THEN ! igwiz loop + + igwiz = 1 + + dxf = dx / FLOAT(nfrx) + dyf = dy / FLOAT(nfry) + + WRITE(msg,*)'fire: dx,dy, dxf,dyf=', dx,dy, dxf,dyf + CALL wrf_message ( msg ) + +! ----- fuel moisture parameters + + DO nf = 1,nfuelcats + fci(nf) = (1.+fuelmc_c)*fci_d(nf) + fcbr(nf) = fci_d(nf)/fct(nf) + END DO + +! ----- initialize fire-related constants, and fuel category data + + CALL fire_startup( grid_id,z,zs, & ! send + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ifuelread, nfuel_cat0, & + zf,zsf,nfuel_cat,betafl,bbb,r_0,phiwc ) ! recv + +! -- EGP converted data statements from blockdata.f (check this for restarts...) + + DO j = jf_st,jf_en + DO i = if_st,if_en + tign_g(i,j) = -100. + tign_c(i,j) = -100. + tign_crt(i,j) = -100. + DO it = 1,4 + xfg(i,j,it) = 0. + yfg(i,j,it) = 0. + END DO + nfl(i,j) = 0 + END DO + END DO + +! ----- check if fire has been ignited (i.e. TIGNM > 0.) + + tignm = -100. + DO j = jf_st,jf_en + DO i = if_st,if_en + tignm = MAX(tign_g(i,j),tign_c(i,j),tignm) + END DO + END DO + +!!!! EGP for MPI we need to communicate tignm to all processors + +! ----- if no fire has been ignited, initialize some fireline variables, +! including fuel loads. + + IF (tignm < -10.) THEN + +! ----- iof=1 + + CALL fire_init(1,dt, & ! send + cen_lat,cen_lon,lat_ll,lon_ll, & + moad_cen_lat,moad_cen_lon,moad_dx,moad_dy,& + moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, & + nfl_t,time,dx,dy,nfuel_cat, & + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ishape,tlat_stf,tlon_stf,t_ignite,icn, & + fg,fc,tign_g,nfl,xfg,yfg, & ! send&recv + ixb,iyb) ! recv + + END IF + + END IF ! igwiz loop + +! ----- end initialization + +! ----- t_ignite is time we want the fire ignited (in model time). +! +! This call: +! - ignites a fire if t_ignite-time/60. < dt/60. +! (i.e. if we are within 1 time step of designated ignition) +! - sets tignm=now (a time > 0.). + + WRITE(msg,*)'tignm = ',tignm + CALL wrf_message ( msg ) + + WRITE(msg,*)'t_ignite = ',t_ignite + CALL wrf_message ( msg ) + + WRITE(msg,*)'time = ',time + CALL wrf_message ( msg ) + + WRITE(msg,*)'diff = ',t_ignite-time,dt + CALL wrf_message ( msg ) + + CALL fire_init(2,dt, & ! send + cen_lat,cen_lon,lat_ll,lon_ll, & + moad_cen_lat,moad_cen_lon,moad_dx,moad_dy, & + moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, & + nfl_t,time,dx,dy,nfuel_cat, & + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ishape,tlat_stf,tlon_stf,t_ignite,icn, & + fg,fc,tign_g,nfl,xfg,yfg, & ! send&recv + ixb,iyb) ! recv + + + IF (tignm < -10.) RETURN ! if nothing has ignited yet, return. + +! ----- begin pass through tracer scheme + + DO jb = jts,MIN(jte,jde-1) + DO ib = its,MIN(ite,ide-1) + grnhfx(ib,jb) = 0.0 + grnqfx(ib,jb) = 0.0 + canhfx(ib,jb) = 0.0 + canqfx(ib,jb) = 0.0 + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + grnhft(i,j) = 0.0 + grnqft(i,j) = 0.0 + canqft(i,j) = 0.0 + canhft(i,j) = 0.0 + END DO + END DO + + CALL fire_stat(1,dt,time, & ! send + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,nfl_t,tign_g,tign_crt, & ! send&recv + area,area2,xfg,yfg, & + ixb,iyb,icn) ! recv + +! EGP --- temporarily dump fire line for tecplot + +! CALL fire_write_fire_ln(itimestep, & +! nfl,icn,xfg,yfg,dxf,dyf, & +! ifms,ifme, kfms,kfme, jfms,jfme, & +! if_st,if_en, jf_st,jf_en) + +! EGP --- + +! ----- create points outlining fire + + CALL fire_ln(dt,time,zs,sprdx,sprdy, & ! send + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ncod,in1,in2,ixb,iyb,icn, & ! send&recv + tign_g,tign_crt,area,area2,xfg,yfg, & + nfl,nfl_t,rad,xcd,ycd,xcn,ycn) ! recv + +! ----- advect fire line points using spread rate + + CALL fire_tr(dt,ibeh,nfuel_cat,ncod,nfl,zf,zsf,zs, & ! send + sfcu,sfcv,xcd,ycd,bbb,phiwc,betafl,r_0, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + xcn,ycn, & ! send&recv + sprdx,sprdy) ! recv + +! ----- reset coordinates for fire line grids + + CALL fire_ds(ixb,iyb,icn,nfl,ncod,in1,in2, & ! send + time,xcn,ycn,xcd,ycd, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + xfg,yfg,tign_g) ! send&recv + +! ----- identify and treat newly ignited cells + + CALL fire_igs(ixb,iyb,icn,in1,in2,ncod,time, & ! send + xcn,ycn,zs,xcd,ycd,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,tign_g,xfg,yfg) ! send&recv + +! ----- + + CALL fire_stat(2,dt,time, & ! send + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,nfl_t,tign_g,tign_crt, & ! send&recv + area,area2,xfg,yfg, & + ixb,iyb,icn) ! recv + +! ----- end pass through tracer scheme +! ----- now begin calculation of flux feedback to atmosphere + + sumarea = 0. + + DO 95 j = jf_st+1,jf_en-1 + + jb = INT(FLOAT((j-2)/nfry+2)+ep) + + DO 96 i = if_st+1,if_en-1 !start of I,J fuel grid physics + + ib = INT(FLOAT((i-2)/nfrx+2)+ep) + +! ----- ground fuel + + IF (fg(i,j) < ep) GO TO 97 !grid point is burned out + IF (tign_g(i,j) < ep) GO TO 97 !grid point has not ignited !error + +! ----- calc. change in burning area + + a_fl = area2(i,j) + sumarea = sumarea + area2(i,j) + +! ----- calc. mass burned based on time since ignition from mass loss curve + + CALL fire_burn_fcn(i,j, & ! send + nfuel_cat,nfl,ncod,in1,in2, & + ixb,iyb,icn,time,area2, & + tign_g,tign_crt, & + xcd,ycd,xcn,ycn,xfg,yfg, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + burn_frac) ! recv + + delm = MAX(fg(i,j) - (1.-burn_frac)*fgi(nfuel_cat(i,j)),0.0) + +! ----- all ground fuel burns off at the same rate +! add random component to burn rate for excitation + + bratio = 1.0 + dmass = delm + fg(i,j) = MAX(fg(i,j)-dmass,0.0) + + grnhft(i,j) = dmass/dt*(1.-bmst)*cmbcnst ! J/m^2/sec + grnqft(i,j) = (bmst+(1.-bmst)*.56)*dmass/dt*xlv + +! ----- drying out canopy + + fcav = fc(i,j)-(1.-a_fl)*fci(nfuel_cat(i,j)) & + -a_fl*fci_d(nfuel_cat(i,j)) ! canopy moist. to be dried + + IF (fcav > 0.0) THEN + delh = MIN(grnhft(i,j)*dt,fcav*xlv) ! J/m^2 + grnhft(i,j) = grnhft(i,j) - delh/dt ! J/m^2/sec + fc(i,j) = fc(i,j) - delh/xlv + fcav = fcav - delh/xlv + canqft(i,j) = canqft(i,j) + delh/dt + END IF + +! ----- ignition of canopy follows +! if surface fire heat flux over threshold, has not yet ignited, + + IF (grnhft(i,j) > hfgl .AND. tign_c(i,j) < -10. & + .AND. fcav < ep) tign_c(i,j) = time + +97 CONTINUE !end of ground fire physics + +! ----- canopy + + IF (tign_c(i,j) < -10.) GO TO 98 !grid point has not yet been ignited + + a_fl = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) & + +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3))) + + IF (fc(i,j) < ep) GO TO 98 !canopy grid point is burned out + +! ----- define mass available to burn + + delm = MAX(fc(i,j)-(1.-a_fl)*fci_d(nfuel_cat(i,j)),0.0) + dmass = MIN(a_fl*fcbr(nfuel_cat(i,j))*dt,bratio*delm) + + fc(i,j) = fc(i,j) - dmass + + canhft(i,j) = dmass / dt * cmbcnst + canqft(i,j) = .56 * dmass / dt * xlv + +98 CONTINUE !end of canopy fire physics + +! ----- ib,jb are atm grid pt counters; i,j grid pt counters +! grnhft, grnhfx are in J/m^2/s (W/m^2) + + canhfx(ib,jb) = canhfx(ib,jb) + canhft(i,j)/FLOAT(nfrx*nfry) + canqfx(ib,jb) = canqfx(ib,jb) + canqft(i,j)/FLOAT(nfrx*nfry) + grnhfx(ib,jb) = grnhfx(ib,jb) + grnhft(i,j)/FLOAT(nfrx*nfry) + grnqfx(ib,jb) = grnqfx(ib,jb) + grnqft(i,j)/FLOAT(nfrx*nfry) + +96 END DO +95 END DO ! end of i,j fuel grid physics + +!--- EGP need to handle MPI issues with sumarea + + sumarea = sumarea * dxf * dyf + + WRITE(msg,23)'time (min)=',time/60.,' AREA (acre)=',sumarea/4047. +23 FORMAT (1x,a11,f10.4,3x,a13,f15.5) + CALL wrf_message ( msg ) + +! ----- end calculation of flux feedback to atmosphere + +! ----- generate some statistics for printout and future plotting + + grndhx = 0.0 + canhx = 0.0 + grnhsum = 0.0 + canhsum = 0.0 + grndqx = 0.0 + canhx = 0.0 + canqx = 0.0 + +! DO j = jts,jte +! DO i = its,ite + + DO j = MAX(jts,jds+1),MIN(jte,jde-1) + DO i = MAX(its,ids+1),MIN(ite,ide-1) + grndhx = MAX(grndhx,grnhfx(i,j)) + canhx = MAX(canhx,canhfx(i,j)) + grnhsum = grnhsum + grnhfx(i,j)*dx*dy + canhsum = canhsum + canhfx(i,j)*dx*dy + grndqx = MAX(grndqx,grnqfx(i,j)) + canqx = MAX(canqx,canqfx(i,j)) + END DO + END DO + + WRITE(msg,93)grndhx,grndqx,canhx,canqx +93 FORMAT(1x,'GRNDHX=',e11.4,' GRNDQX=',e11.4,' CANHX=',e11.4,' CANQX=',e11.4/2x) + CALL wrf_message( msg ) + + WRITE(msg,68)grnhsum,canhsum +68 FORMAT(1x,'TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = ',2e11.4,' WATTS') + CALL wrf_message( msg ) + +! ----- end of statistics print out + + ig = 0 + jg = 0 + ratg = 0.0 + ic = 0 + jc = 0 + ratc = 0.0 + teps = 1. + + DO j = MAX(jts,jds+1),MIN(jte,jde-1) + DO i = MAX(its,ids+1),MIN(ite,ide-1) + ratio = grnqfx(i,j)/(teps+grnhfx(i,j)) + IF (ratio > ratg) THEN + ig = i + jg = j + ratg = ratio + END IF + ratio = canqfx(i,j)/(teps+canhfx(i,j)) + IF (ratio > ratc) THEN + ic = i + jc = j + ratc = ratio + END IF + END DO + END DO + + IF (ratg > 1. .OR. ratc > 1.) THEN + WRITE(msg,441)ratg,ig,jg,ratc,ic,jc, & + grnhfx(ig,jg),grnqfx(ig,jg),canhfx(ic,jc),canqfx(ic,jc) +441 FORMAT(1x,'RATG(I,J)=',e11.4,2i3,' RATC(I,J)=',e11.4,2i3/1x, & + 'GRNH/QFX=',2e11.4,' CANH/CANQFX=',2e11.4) + CALL wrf_message( msg ) + END IF + + ! --- add heat and moisture fluxes to tendency variables + + CALL fire_tendency(grnhfx,grnqfx,canhfx,canqfx, & ! send + alfg,alfc,z1can, & + zs,z_at_w,dz8w,mu,rho, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + rthfrten,rqvfrten) ! recv + + RETURN + +END SUBROUTINE cawfe + +! ========================================================================= + +SUBROUTINE fire_startup( grid_id,z,zs, & ! incoming + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ifuelread,nfuel_cat0, & + zf,zsf,nfuel_cat,betafl,bbb,r_0,phiwc ) ! outgoing + +! ... Initialize things that need to be set every time the +! model starts up, +! including restart, including constants, pre-multipliers, +! and fuel map. + + USE module_fr_cawfe_fuel + USE module_wrf_error + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en,jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in) :: ifuelread + INTEGER, INTENT(in) :: nfuel_cat0 + + INTEGER, INTENT(in) :: grid_id + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ):: zs + REAL, INTENT(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: z + +! ----- outgoing variables + + INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + + REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf + REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: betafl,bbb,r_0,phiwc + +! ----- local variables + + INTEGER :: i,j,ii,jj + INTEGER :: nvl + INTEGER :: iu1 + + REAL :: t1 + REAL :: fuelloadm,fuelload,fueldepth,qig,epsilon,rhob + REAL :: rtemp2,gammax,a,ratio,gamma,wn,rtemp1,etam,etas,ir,irm,xifr + REAL :: tii,tjj,epx,epy + + INTEGER :: nfxy,nf,ni,nj,ci,cj,ip,jp + REAL, DIMENSION( ims:ime,jms:jme,nfrx*nfry) :: ztmp,zstmp + LOGICAL, DIMENSION(ims:ime, jms:jme ) :: icmask + + CHARACTER (LEN=80) :: lfile2 + CHARACTER (LEN=128) :: msg + + +! ----- begin subroutine + + xlm(1) = -.5 + xlm(3) = -.5 + xlm(2) = +.5 + xlm(4) = +.5 + ylm(1) = -.5 + ylm(2) = -.5 + ylm(3) = +.5 + ylm(4) = +.5 + +! ----- constants +! +! interpolates topography on atm grid to fire/fuel grid (zs -> zsf) +! and also interpolates height above sea level of first grid +! point to fire grid (z -> zf). Note that these are valid at +! the center of the cell. + + DO j = jf_st,jf_en + tjj = 1.5 + (FLOAT(j) - 1.5) / FLOAT(nfry) + jj = INT(tjj) + epy = tjj - FLOAT(jj) + DO i = if_st,if_en + tii = 1.5 + (FLOAT(i)-1.5)/FLOAT(nfrx) + ii = INT(tii) + epx = tii - FLOAT(ii) + zsf(i,j) = (1.-epy)*((1.-epx)*zs(ii,jj)+epx*zs(ii+1,jj)) & + + epy*((1.-epx)*zs(ii,jj+1)+epx*zs(ii+1,jj+1)) + zf(i,j) = (1.-epy)*((1.-epx)*z(ii,kds+1,jj)+epx*z(ii+1,kds+1,jj)) & + + epy*((1.-epx)*z(ii,kds+1,jj+1)+epx*z(ii+1,kds+1,jj+1)) + enddo + enddo + +! ----- load fuel categories (or constant) here +! +! ... How will fuel categories be set? IFUELREAD= 0 - uniform; +! 1 - user-prescribed algorithm; 2 - read files + + WRITE(msg,*)'fire_startup: ifuelread=', ifuelread + CALL wrf_message ( msg ) + + IF (ifuelread == 0) THEN + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfuel_cat(i,j) = nfuel_cat0 + END DO + END DO + + ELSE IF (ifuelread == 1) THEN + +! Make dependent on altitude (CO mountains/forest vs. plains) +! 2000 m : 6562 ft ; 1600 m: 5249 ft + +! ... User defines fuel category spatial variability ! param! + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfuel_cat(i,j) = 2 ! Grass with understory + t1 = zsf(i,j) + IF (t1 <= 1524.) THEN ! up to 5000 ft + nfuel_cat(i,j) = 3 ! Tall grass + ELSE IF (t1 >= 1524. .AND. t1 <= 2073.) THEN ! 5.0-6.8 kft. + nfuel_cat(i,j) = 2 ! Grass with understory + ELSE IF (t1 >= 2073. .AND. t1 <= 2438.) THEN ! 6.8-8.0 kft. + nfuel_cat(i,j) = 8 ! Timber litter - 10 (ponderosa) + ELSE IF (t1 > 2438. .AND. t1 <= 3354.) THEN ! 8.0-11.0 kft. +! ... could also be mixed conifer. + nfuel_cat(i,j) = 10 ! Timber litter - 8 (lodgepole) + ELSE IF (t1 > 3354. .AND. t1 <= 3658.) THEN ! 11.0-12.0 kft + nfuel_cat(i,j) = 1 ! Alpine meadow - 1 + ELSE IF (t1 > 3658. ) THEN ! > 12.0 kft + nfuel_cat(i,j) = 14 ! No fuel. + END IF + END DO + END DO + + ELSE IF (ifuelread == 2) THEN + +! -- EGP need to fix this so that when reading fuel data from +! a file that each if_st:if_en and jf_st:jf_en reads the +! correct chunk of the file.... +! +! NOTE: changed nvl=nvlm to nvl=model + +! ----- written assuming NVERT=0, no parallelization +! ... Read fuel files + +! nvl = nvlm ! Load fuel for innermost domain. + nvl = grid_id ! Load fuel for innermost domain. + IF (nvl <= 9) THEN + WRITE(lfile2,80) nvl +80 FORMAT('fuel_layer_',I1,'.dat') + ELSE + WRITE (msg,*) 'STOP, fire_startup: Generalize filename format for NVL > 9' + CALL wrf_error_fatal ( msg ) + END IF + + iu1 = 10 + OPEN(iu1,FILE=lfile2,STATUS='unknown',FORM='formatted') + + DO j = jf_st,jf_en + DO i = if_st,if_en + READ(iu1,'(I2)') nfuel_cat(i,j) +! ... If no fuel category specified (i.e. '99'), set to '14', +! which (in the current 13 category NFFL category system) +! is 'no fuel' + IF (nfuel_cat(i,j) < 1) nfuel_cat(i,j) = 14 ! not generalized + IF (nfuel_cat(i,j) > nfuelcats) nfuel_cat(i,j) = 14 ! not generalized + END DO + END DO + + CLOSE (iu1) + + ELSE + + WRITE (msg,*) & + 'STOP, in fire_startup: error reading fuel categories from file: iu1' + CALL wrf_error_fatal ( msg ) + + END IF + +! ----- end LOAD FUEL CATEGORIES (OR CONSTANT) HERE. + +! ----- Settings of fire spread parameters from BEHAVE follows. These +! don't need to be recalculated later. +! + DO j = jf_st,jf_en + DO i = if_st,if_en + fuelloadm = (1.-bmst) * fgi(nfuel_cat(i,j)) ! fuelload without moisture + fuelload = fuelloadm * (.3048)**2 * 2.205 ! to lb/ft^2 + fueldepth = fueldepthm(nfuel_cat(i,j))/0.3048 ! to ft + betafl(i,j) = fuelload/(fueldepth * fueldens(nfuel_cat(i,j))) !packing ratio + betaop = 3.348 * savr(nfuel_cat(i,j))**(-0.8189) ! optimum packing ratio + qig = 250. + 1116.*fuelmc_g ! heat of preigntn., btu/lb + epsilon = EXP(-138./savr(nfuel_cat(i,j)) ) ! eff. heating number + rhob = fuelload/fueldepth ! ovendry bulk density, lb/ft^3 + + c = 7.47 * EXP( -0.133 * savr(nfuel_cat(i,j))**0.55) ! const in wind coef + bbb(i,j) = 0.02526 * savr(nfuel_cat(i,j))**0.54 ! const in wind coef + e = 0.715 * EXP( -3.59E-4 * savr(nfuel_cat(i,j))) ! const in wind coef + phiwc(i,j) = c * (betafl(i,j)/betaop)**(-e) + + rtemp2 = savr(nfuel_cat(i,j))**1.5 + gammax = rtemp2/(495. + 0.0594*rtemp2) ! maximum rxn vel, 1/min + a = 1./(4.774 * savr(nfuel_cat(i,j))**0.1 - 7.27) ! coef for optimum rxn vel + ratio = betafl(i,j)/betaop + gamma = gammax *(ratio**a) *EXP(a*(1.-ratio)) ! optimum rxn vel, 1/min + + wn = fuelload/(1 + st(nfuel_cat(i,j))) ! net fuel loading, lb/ft^2 + rtemp1 = fuelmc_g/fuelmce(nfuel_cat(i,j)) + etam = 1.-2.59*rtemp1 +5.11*rtemp1**2 -3.52*rtemp1**3 !moist damp coef + etas = 0.174* se(nfuel_cat(i,j))**(-0.19) !mineral damping coef + ir = gamma * wn * fuelheat * etam * etas ! rxn intensity, btu/ft^2 min + irm = ir * 1055./( 0.3048**2 * 60.) * 1.e-6 !for MW/m^2 + +! ----- propagating flux ratio + xifr = EXP( (0.792 + 0.681*savr(nfuel_cat(i,j))**0.5) & + * (betafl(i,j)+0.1)) /(192. + 0.2595*savr(nfuel_cat(i,j))) + +! ----- r_0 is the spread rate for a fire on flat ground with no wind. + r_0(i,j) = ir*xifr/(rhob * epsilon *qig) ! default spread rate in ft/min + IF (nfuel_cat(i,j) == 14) r_0(i,j) = 0. ! no fuel, no spread. +! WRITE (msg,*) 'irm,r0 (m/s)=',i,j,irm, (r_0(i,j)/196.85) +! CALL wrf_message ( msg ) + + + END DO + END DO + + RETURN + +END SUBROUTINE fire_startup + +! ========================================================================= + +SUBROUTINE fire_init(iof,dt, & ! incoming + cen_lat,cen_lon,lat_ll,lon_ll, & + moad_cen_lat,moad_cen_lon,moad_dx,moad_dy, & + moad_s_we,moad_e_we,moad_s_sn,moad_e_sn, & + nfl_t,time,dx,dy,nfuel_cat, & + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ishape,tlat_stf,tlon_stf,t_ignite,icn, & + fg,fc,tign_g,nfl,xfg,yfg, & ! in-out + ixb,iyb) ! outgoing + +! ------------------------------------------------------------------- +! If iof = 1: this routine sets some variables to zero and initializes +! some parameters +! +! If iof = 2: this routine ignites a fire with shape: ishape +! ------------------------------------------------------------------- + + USE module_fr_cawfe_fuel + + IMPLICIT NONE + +! ------ incoming variables + + INTEGER, INTENT(in) :: iof + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifds,ifde, kfds,kfde, jfds,jfde + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + REAL, INTENT(in) :: cen_lat,cen_lon ! lat,lon center of finest mesh + REAL, INTENT(in) :: lat_ll,lon_ll ! lat,lon lower left of " " + REAL, INTENT(in) :: moad_cen_lat,moad_cen_lon ! lat,lon center of moad + REAL, INTENT(in) :: moad_dx,moad_dy ! dx,dy of moad + INTEGER, INTENT(in) :: moad_s_we,moad_e_we ! strt & end indices in x on moad + INTEGER, INTENT(in) :: moad_s_sn,moad_e_sn ! strt & end indices in y on moad + + INTEGER, INTENT(in) :: ishape + REAL, INTENT(in) :: tlat_stf + REAL, INTENT(in) :: tlon_stf + REAL, INTENT(in) :: t_ignite + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl_t,nfuel_cat + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ):: icn + + REAL, INTENT(in) :: time,dt + REAL, INTENT(in) :: dx,dy + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + +! ------ outgoing variables + + INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb + +! ------ in and out going variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: fg,fc + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ------ local variables + + INTEGER :: i,j + INTEGER :: it + INTEGER :: istf,jstf + INTEGER :: ii,jj + INTEGER :: ixm,iym + INTEGER :: i1,i2,j1,j2 + INTEGER :: nfl_max + INTEGER :: ism,isp,jsm,jsp + INTEGER :: nxmm,nymm + INTEGER :: moad_num_pnts_x,moad_num_pnts_y + + REAL :: xwidfire,ywidfire,tdiff,dxst,dyst,xcntr,ycntr,stx,sty + REAL :: xf1,yf1,xx1,yy1,fii,fjj + REAL :: rad,x0,y0,x1,y1,x2,y2 + REAL :: rmin + REAL :: r1,r2,r3,r4 + REAL :: r12,r13,r14,r23,r24,r34 + REAL :: a_fl + REAL :: xwd,ywd + REAL :: xmax,ymax,rmax,alpha + REAL :: x,y,spd,ss,dxp,dyp + + CHARACTER(LEN=120) :: msg + +! ------ begin routine + + IF (tignm > -10.) RETURN ! If there is alrady a fire, return. +! Generalize this when want to add multiple fires. + + IF (iof == 1) THEN ! iof=1 +! ... This is 1st time through sr. fire (either cold start or restart) and +! NO FIRE YET. Initialize some fire & fuel variables that will change +! once fire starts. +! +! Define the initial tracer positions of the ground fuel (XFG,YFG) +! where the coordinates are relative to the grid center such that +! XFG and YFG vary between -0.5 to +0.5 where (XFG,YFG)=(0.,0.) is +! the grid center. |XFG|.le. 0.5 and |YFG|.le. 0.5 . +! + DO j = jf_st,jf_en + DO i = if_st,if_en + fg(i,j) = fgi(nfuel_cat(i,j)) !sfc fuel horiz. homogeneous conditions + fc(i,j) = fci(nfuel_cat(i,j)) !canopy fuel horiz. homogeneous conditions + nfl(i,j) = 0 + tign_g(i,j) = -100. ! no fire set yet + DO it = 1,4 ! loop over the 4 tracers per fuel cell + ixb(i,j,it) = 1 + iyb(i,j,it) = 1 + xfg(i,j,it) = 0.0 + yfg(i,j,it) = 0.0 + END DO + END DO + END DO + END IF ! iof=1 + + tdiff = ABS(t_ignite-time/60.) ! T_IGNITE is in minutes + + IF (iof == 2 .AND. tdiff < dt/60.) THEN ! iof=2 + +! It's time to ignite a fire! (Generalize so that other fires could +! be burning elsewhere.) +! T_IGNITE is the designated ignition time in minutes (model time) + + +! set tlat_stf,tlon_stf: latitude and longitude of the center of ignition location + + WRITE (msg,*) 'FIRE IGNITION AT: TLAT_STF, TLON_STF=',tlat_stf,tlon_stf + CALL wrf_message ( msg ) + + + +! moad_cen_lat = latitude of the center of outermost domain (mother of all domains) +! moad_cen_lon = longitude of the center of outermost domain +! get dxst,dyst: fire dist. from domain 1 center in m + + dxst = (tlon_stf-moad_cen_lon) * 111.1949 * 1.e3 + dyst = (tlat_stf-moad_cen_lat) * 111.1949 * 1.e3 + +! EGP + dxst = 0. + dyst = 0. + + WRITE (msg,*) 'fire dist dom1 center (m): dxst,dyst=',dxst,dyst + CALL wrf_message ( msg ) + +! get xcntr,ycntr: distance from SW corner domain 1 to center of domain 1 (m) + + moad_num_pnts_x = moad_e_we - moad_s_we + 1 + moad_num_pnts_y = moad_e_sn - moad_s_sn + 1 + + xcntr = (FLOAT(moad_num_pnts_x) * moad_dx) / 2. + ycntr = (FLOAT(moad_num_pnts_y) * moad_dy) / 2. + + WRITE (msg,*) 'dist SW corner dom1 to center dom1 (m): ', & + 'xcntr,ycntr=',xcntr,ycntr + CALL wrf_message ( msg ) + + +! get stx,sty: coords (in m) of fire start wrt the sw corner of model 1 in m + +! WRITE (msg,*) 'ycntr, dyst, sum=',ycntr,dyst, ycntr+dyst +! CALL wrf_message ( msg ) + + stx = xcntr + dxst ! in m + sty = ycntr + dyst + + WRITE (msg,*) & + 'coords fire rel to SW corner mod 1 (m): stx,sty:',stx,sty + CALL wrf_message ( msg ) + + +! EGP --- FIX this for WRF... currently writing over +! get xf1,yf1: position of SW corner of fire domain (in m) +! +! IF (ifs == 1) THEN +! xf1 = (cen_lon - lon_ll) * 111.1949 * 1.e3 +! yf1 = (cen_lat - lat_ll) * 111.1949 * 1.e3 +! ELSE +! xf1 = 999999. +! yf1 = 999999. +! END IF +! xf1 = wrf_dm_min_real ( xf1 ) +! yf1 = wrf_dm_min_real ( yf1 ) + + xf1 = 0. + yf1 = 0. + + WRITE (msg,*) 'pos of sw corner of fire domain (m): xfx1,xfy1:',xf1,yf1 + CALL wrf_message ( msg ) + + +! get xx1,yy1: position of fire relative to fire domain (in m) + + xx1 = stx - xf1 ! in m + yy1 = sty - yf1 + + WRITE (msg,*) 'Fire position relative to fire domain (m):',xx1,yy1 + CALL wrf_message ( msg ) + + +! get istf,jstf: position of fire in fire domain in atm grid cells + + istf = INT( xx1 / dx ) + 1 + jstf = INT( yy1 / dy ) + 1 + + WRITE (msg,*) 'Fire position in domain atm grid pts:', istf,jstf + CALL wrf_message ( msg ) + +! get fii,fjj: dist in m from this model level's SE corner + + fii= ( xx1 / dxf ) + 1. + fjj= ( yy1 / dyf ) + 1. + +! WRITE (msg,*) 'calc fii,fjj=',fii,fjj +! CALL wrf_message ( msg ) + + ii = AINT(fii) + jj = AINT(fjj) + + WRITE (msg,*) 'Fire position in domain in fuel cells:',ii,jj + CALL wrf_message ( msg ) + +! .... Or set fire location this way. +! ... ISTF LSTF are the model dynamic grid positions of ignition point +! +! istf = 31 ! param ! for 4 dom +! jstf = 24 ! param ! for 4 dom +! istf = 30 ! param ! for 3 dom +! jstf = 38 ! param ! for 3 dom +! istf = 104 ! param ! for 5 dom ! could/should be 106 +! jstf = 49 ! param ! for 5 dom ! could/should be 50 +! istf = 190 ! param ! for 6 dom +! jstf = 68 ! param ! for 6 dom + + istf = moad_num_pnts_x / 2 ! param ! + jstf = moad_num_pnts_y / 2 ! param ! +! +! --- EGP need to fix initialization for MPI... currently the ishape +! query happens on every CPU, therefore an equivalent fire will +! be initiated on every CPU +! +! ------------------------------------------------------------------------ + IF (ishape == 0) THEN ! spot fire +! ...The circular ignition that follows assumes physically small fuel +! cells. Typical values of about 5 meters or less would be reasonable +! otherwise use line ignition + + rad = 10.01 * SQRT(dxf**2 + dyf**2) ! rad= 1.01 * hypot of fuel cell ! param! + +! set x0,y0: dist in m from this model level's SE corner + + x0 = FLOAT(ii-1) * dxf + .5*dxf + y0 = FLOAT(jj-1) * dyf + .5*dyf + + WRITE (msg,*) 'Spot fire initialized with rad=',rad,' at ', & + ii,jj,' fuel cell location' + CALL wrf_message ( msg ) + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 +! ... calc distance of each corner of fuel cell from ig pt. + r1 = SQRT( (FLOAT(i-2)*dxf-x0)**2 + (FLOAT(j-2)*dyf-y0)**2 ) + r2 = SQRT( (FLOAT(i-1)*dxf-x0)**2 + (FLOAT(j-2)*dyf-y0)**2 ) + r3 = SQRT( (FLOAT(i-2)*dxf-x0)**2 + (FLOAT(j-1)*dyf-y0)**2 ) + r4 = SQRT( (FLOAT(i-1)*dxf-x0)**2 + (FLOAT(j-1)*dyf-y0)**2 ) + rmin = MIN(r1,r2,r3,r4) + +! ... if any less than spot fire radius, ignite + IF (rmin < rad) THEN !rmin lt rad + tign_g(i,j) = time + nfl(i,j) = 1 + IF (rad-r1 > ep) THEN + xfg(i,j,1) = xlm(1) + yfg(i,j,1) = ylm(1) + END IF + IF (rad-r2 > ep) THEN + xfg(i,j,2) = xlm(2) + yfg(i,j,2) = ylm(2) + END IF + IF (rad-r3 > ep) THEN + xfg(i,j,3) = xlm(3) + yfg(i,j,3) = ylm(3) + END IF + IF (rad-r4 > ep) THEN + xfg(i,j,4) = xlm(4) + yfg(i,j,4) = ylm(4) + END IF + + IF (r1 < rad .AND. r2 < rad .AND. r3 > rad .AND. r4 > rad) THEN + xfg(i,j,3) = xlm(3) + yfg(i,j,3) = ylm(1) + (rad-r1)/(r3-r1) + xfg(i,j,4) = xlm(4) + yfg(i,j,4) = ylm(2) + (rad-r2)/(r4-r2) + END IF + IF (r1 > rad .AND. r2 > rad .AND. r3 < rad .AND. r4 < rad) THEN + xfg(i,j,1) = xlm(1) + yfg(i,j,1) = ylm(3) - (rad-r3)/(r1-r3) + xfg(i,j,2) = xlm(2) + yfg(i,j,2) = ylm(4) - (rad-r4)/(r2-r4) + END IF + IF (r1 < rad .AND. r3 < rad .AND. r2 > rad .AND. r4 > rad) THEN + xfg(i,j,2) = xlm(1) + (rad-r1)/(r2-r1) + yfg(i,j,2) = ylm(2) + xfg(i,j,4) = xlm(3) + (rad-r3)/(r4-r3) + yfg(i,j,4) = ylm(4) + END IF + IF (r1 > rad .AND. r3 > rad .AND. r2 < rad .AND. r4 < rad) THEN + xfg(i,j,1) = xlm(2) - (rad-r2)/(r1-r2) + yfg(i,j,1) = ylm(1) + xfg(i,j,3) = xlm(4) - (rad-r4)/(r3-r4) + yfg(i,j,3) = ylm(3) + END IF + + IF (r1 < rad .AND. r2 > rad .AND. r3 > rad .AND. r4 > rad) THEN + xfg(i,j,2) = xlm(1) + (rad-r1)/(r2-r1) + yfg(i,j,2) = ylm(2) + xfg(i,j,3) = xlm(3) + yfg(i,j,3) = ylm(1) + (rad-r1)/(r3-r1) + xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + IF (r2 < rad .AND. r1 > rad .AND. r3 > rad .AND. r4 > rad) THEN + xfg(i,j,1) = xlm(2) - (rad-r2)/(r1-r2) + yfg(i,j,1) = ylm(1) + xfg(i,j,4) = xlm(4) + yfg(i,j,4) = ylm(2) + (rad-r2)/(r4-r2) + xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (r3 < rad .AND. r1 > rad .AND. r2 > rad .AND. r4 > rad) THEN + xfg(i,j,4) = xlm(3) + (rad-r3)/(r4-r3) + yfg(i,j,4) = ylm(4) + xfg(i,j,1) = xlm(1) + yfg(i,j,1) = ylm(3) - (rad-r3)/(r1-r3) + xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (r4 < rad .AND. r1 > rad .AND. r2 > rad .AND. r3 > rad) THEN + xfg(i,j,3) = xlm(4) - (rad-r4)/(r3-r4) + yfg(i,j,3) = ylm(3) + xfg(i,j,2) = xlm(2) + yfg(i,j,2) = ylm(4) - (rad-r4)/(r2-r4) + xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + + IF (r1 > rad .AND. r2 < rad .AND. r3 < rad .AND. r4 < rad) THEN + x1 = xlm(1) + x2 = xlm(2) - (rad-r2)/(r1-r2) + xfg(i,j,1) = .5*(x1+x2) + y1 = ylm(1) + y2 = ylm(3) - (rad-r3)/(r1-r3) + yfg(i,j,1) = .5*(y1+y2) + END IF + IF (r2 > rad .AND. r1 < rad .AND. r3 < rad .AND. r4 < rad) THEN + x1 = xlm(4) + x2 = xlm(1) + (rad-r1)/(r2-r1) + xfg(i,j,2) = .5*(x1+x2) + y1 = ylm(1) + y2 = ylm(4) - (rad-r4)/(r2-r4) + yfg(i,j,2) = .5*(y1+y2) + END IF + IF (r3 > rad .AND. r1 < rad .AND. r2 < rad .AND. r4 < rad) THEN + x1 = xlm(1) + x2 = xlm(4) - (rad-r4)/(r3-r4) + xfg(i,j,3) = .5*(x1+x2) + y1 = ylm(4) + y2 = ylm(1) + (rad-r1)/(r3-r1) + yfg(i,j,3) = .5*(y1+y2) + END IF + IF (r4 > rad .AND. r1 < rad .AND. r2 < rad .AND. r3 < rad) THEN + x1 = xlm(2) + x2 = xlm(3) + (rad-r3)/(r4-r3) + xfg(i,j,4) = .5*(x1+x2) + y1 = ylm(3) + y2 = ylm(2) + (rad-r2)/(r4-r2) + yfg(i,j,4) = .5*(y1+y2) + END IF + + r12 = (xfg(i,j,1)-xfg(i,j,2))**2 + (yfg(i,j,1)-yfg(i,j,2))**2 + r13 = (xfg(i,j,1)-xfg(i,j,3))**2 + (yfg(i,j,1)-yfg(i,j,3))**2 + r14 = (xfg(i,j,1)-xfg(i,j,4))**2 + (yfg(i,j,1)-yfg(i,j,4))**2 + r23 = (xfg(i,j,2)-xfg(i,j,3))**2 + (yfg(i,j,2)-yfg(i,j,3))**2 + r24 = (xfg(i,j,2)-xfg(i,j,4))**2 + (yfg(i,j,2)-yfg(i,j,4))**2 + r34 = (xfg(i,j,3)-xfg(i,j,4))**2 + (yfg(i,j,3)-yfg(i,j,4))**2 + rmin = MIN(r12,r13,r14,r23,r24,r34) + + a_fl = .5*( & + (xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) & + +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3))) + + IF (rmin < ep_sq .AND. a_fl < .5) THEN + IF (r12 < ep_sq) THEN + IF (ABS(xfg(i,j,3)-xlm(3)) < ep .AND. & + ABS(yfg(i,j,3)-ylm(3)) < ep) THEN + xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (ABS(xfg(i,j,4)-xlm(4)) < ep .AND. & + ABS(yfg(i,j,4)-ylm(4)) < ep) THEN + xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + END IF + + IF (r13 < ep_sq) THEN + IF (ABS(xfg(i,j,2)-xlm(2)) < ep .AND. & + ABS(yfg(i,j,2)-ylm(2)) < ep) THEN + xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (ABS(xfg(i,j,4)-xlm(4)) < ep .AND. & + ABS(yfg(i,j,4)-ylm(4)) < ep) THEN + xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + END IF + + IF (r24 < ep_sq) THEN + IF (ABS(xfg(i,j,3)-xlm(3)) < ep .AND. & + ABS(yfg(i,j,3)-ylm(3)) < ep) THEN + xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (ABS(xfg(i,j,1)-xlm(1)) < ep .AND. & + ABS(yfg(i,j,1)-ylm(1)) < ep) THEN + xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + END IF + + IF (r34 < ep_sq) THEN + IF (ABS(xfg(i,j,2)-xlm(2)) < ep .AND. & + ABS(yfg(i,j,2)-ylm(2)) < ep) THEN + xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + IF (ABS(xfg(i,j,1)-xlm(1)) < ep .AND. & + ABS(yfg(i,j,1)-ylm(1)) < ep) THEN + xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + END IF + END IF + END IF !rmin lt rad + END DO ! i loop + END DO ! l loop + + END IF ! spot fire +! +! ------------------------------------------------------------------------ + if (ishape == 1) THEN ! line fire +! +! ----- length and width settings.... +! +! ywidfire = 1. + 1.*dyf ! N-S length in m ! param! +! ywidfire = 409. ! N-S length in m ! param! + ywidfire = 20. ! N-S length in m ! param! + xwidfire = 10. ! 4 ! W-E width in m ! param! +! xwidfire = dxf * .01 ! narrow line, 1 cm ! param! + +! ----- following is check on width - must be within 2*DXF as coded + IF (xwidfire >= 2.*dxf) xwidfire = 2.*dxf + +! ----- width of fire line in non-dim lenth + xwd = xwidfire/dxf * .5 + +! ----- N-S length fire line in fuel cells + iym = INT(ywidfire/dyf) + +! ----- length of end pieces + ywd = (ywidfire - FLOAT(iym)*dyf)/dyf/2. + ywd = MAX(ywd,2.*ep) + +! ----- Location..... + j1 = jj - (iym/2) + j2 = j1 + iym + i1 = ii + i2 = i1 + 1 + +! ----- fire length in m = (j2-j1)*dyf or (i2-i1)*dxf + + IF (iym > 0) THEN !fire line longer than one fuel cell + DO j = j1,j2 + tign_g(i1,j) = time + tign_g(i2,j) = time + nfl(i1,j) = 1 + nfl(i2,j) = 1 + xfg(i1,j,1) = +.5 - xwd ! left half of fire line + xfg(i1,j,2) = +.5 + xfg(i1,j,3) = +.5 - xwd + xfg(i1,j,4) = +.5 + yfg(i1,j,1) = -.5 + yfg(i1,j,2) = -.5 + yfg(i1,j,3) = +.5 + yfg(i1,j,4) = +.5 + xfg(i2,j,1) = -.5 ! right half of fire line + xfg(i2,j,2) = -.5 + xwd + xfg(i2,j,3) = -.5 + xfg(i2,j,4) = -.5 + xwd + yfg(i2,j,1) = -.5 + yfg(i2,j,2) = -.5 + yfg(i2,j,3) = +.5 + yfg(i2,j,4) = +.5 + END DO + nfl_max = nfl_max + 1 + END IF !fire line longer than one fuel cell + + IF (iym == 0) j2 = j1 - 1 + + tign_g(i1,j2+1) = time + tign_g(i2,j2+1) = time + tign_g(i1,j1-1) = time + tign_g(i2,j1-1) = time + nfl(i1,j2+1) = 1 + nfl(i2,j2+1) = 1 + nfl(i1,j1-1) = 1 + nfl(i2,j1-1) = 1 + nfl_max = nfl_max + 4 + + xfg(i1,j2+1,1) = +.5 - xwd + xfg(i1,j2+1,2) = +.5 + xfg(i1,j2+1,3) = +.5 - xwd*.5 + xfg(i1,j2+1,4) = +.5 + yfg(i1,j2+1,1) = -.5 + yfg(i1,j2+1,2) = -.5 + yfg(i1,j2+1,3) = -.5 + ywd*.5 + yfg(i1,j2+1,4) = -.5 + ywd + + xfg(i2,j2+1,1) = -.5 + xfg(i2,j2+1,2) = -.5 + xwd + xfg(i2,j2+1,3) = -.5 + xfg(i2,j2+1,4) = -.5 + xwd*.5 + yfg(i2,j2+1,1) = -.5 + yfg(i2,j2+1,2) = -.5 + yfg(i2,j2+1,3) = -.5 + ywd + yfg(i2,j2+1,4) = -.5 + ywd*.5 + + xfg(i1,j1-1,1) = +.5 - xwd*.5 + xfg(i1,j1-1,2) = +.5 + xfg(i1,j1-1,3) = +.5 - xwd + xfg(i1,j1-1,4) = +.5 + yfg(i1,j1-1,1) = +.5 - ywd*.5 + yfg(i1,j1-1,2) = +.5 - ywd + yfg(i1,j1-1,3) = +.5 + yfg(i1,j1-1,4) = +.5 + + xfg(i2,j1-1,1) = -.5 + xfg(i2,j1-1,2) = -.5 + xwd*.5 + xfg(i2,j1-1,3) = -.5 + xfg(i2,j1-1,4) = -.5 + xwd + yfg(i2,j1-1,1) = +.5 - ywd + yfg(i2,j1-1,2) = +.5 - ywd*.5 + yfg(i2,j1-1,3) = +.5 + yfg(i2,j1-1,4) = +.5 + + END IF !line fire + +! ------------------------------------------------------------------------ + + IF (ishape == 2) THEN !windmill fire + + nxmm = (ide-ids+1)-2 + nymm = (jde-jds+1)-2 + + iym = 14 + j1 = 2 + nfry*(nymm/2-iym-1) + j2 = 1 + nfry*(1+nymm/2+iym) + ixm = 14 + i1 = 2 + nfrx*(nxmm/2-ixm-1) + i2 = 1 + nfrx*(1+nxmm/2+ixm) + +! ----- Straight line fire +! iym = 10 +! j1 = 2 + nfry*(nymm/2-iym-1) +! j2 = 1 + nfry*(1+nymm/2+iym) +! ixm = 1 +! i1 = 2 + nfrx*(nxmm/2-ixm-1) +! i2 = 1 + nfrx*(1+nxmm/2+ixm) + i = 1 + nfrx*nxmm/2 +! + xmax = FLOAT(nxmm/2)*dx + ymax = FLOAT(nymm/2)*dy + rmax = SQRT(xmax**2+ymax**2) + alpha = +4.*FLOAT(nxmm)/60. + + jsm = (nymm/2)*nfry + jsp = (nymm/2)*nfry+3 + jsm = jsm - 2 + jsp = jsp + 2 +! + DO j = j1,j2 +! IF (j == (nymm/2)*nfry+1 .OR. j == (nymm/2)*nfry+2) GO TO 801 + IF (j >= jsm+1 .AND. j <= jsp-1) GO TO 801 + tign_g(i,j) = time + tign_g(i+1,j) = time + xfg(i,j,1) = +.25 + xfg(i,j,2) = +.50 + xfg(i,j,3) = +.25 + xfg(i,j,4) = +.50 + yfg(i,j,1) = -.5 + yfg(i,j,2) = -.5 + yfg(i,j,3) = +.5 + yfg(i,j,4) = +.5 + xfg(i+1,j,1) = -.50 + xfg(i+1,j,2) = -.25 + xfg(i+1,j,3) = -.50 + xfg(i+1,j,4) = -.25 + yfg(i+1,j,1) = -.5 + yfg(i+1,j,2) = -.5 + yfg(i+1,j,3) = +.5 + yfg(i+1,j,4) = +.5 + END DO +! + 801 CONTINUE + + yfg(i+1,jsp,1) = -.25 + yfg(i+1,jsp,2) = -.25 + yfg(i ,jsp,1) = -.25 + yfg(i ,jsp,2) = -.25 + yfg(i+1,jsm,3) = +.25 + yfg(i+1,jsm,4) = +.25 + yfg(i ,jsm,3) = +.25 + yfg(i ,jsm,4) = +.25 +! + y = (j2-((jfde-jfds+1)-2)/2-1.5)*dyf !grid center + spd = alpha*ABS(y)/rmax + ss = 0.018*EXP(.8424*spd) ! why Macarthur in here? + dyp = (0.018*dxf)/(ss*dyf) + dyp = SIGN(1.,alpha)*dyp + + yfg(i+1,j2,3) = +.25 + yfg(i+1,j2,4) = +.25 - .5*dyp + yfg(i ,j2,3) = +.25 + .5*dyp + yfg(i ,j2,4) = +.25 +! + yfg(i+1,j1,1) = -.25 + yfg(i+1,j1,2) = -.25 - .5*dyp + yfg(i ,j1,1) = -.25 + .5*dyp + yfg(i ,j1,2) = -.25 + +! ----- FIRE WIDTH = .01*dyf + j = 1 + nfry*nymm/2 + ism = (nxmm/2)*nfrx + isp = (nxmm/2)*nfrx+3 + ism = ism - 2 + isp = isp + 2 + + DO i = i1,i2 +! IF (i == (nxmm/2)*nfrx+1 .OR. i == (nxmm/2)*nfrx+2) GO TO 799 + IF (i >= ism+1 .AND. i <= isp-1) GO TO 799 + tign_g(i,j) = time + tign_g(i,j+1) = time + xfg(i,j,1) = -.5 + xfg(i,j,2) = +.5 + xfg(i,j,3) = -.5 + xfg(i,j,4) = +.5 + yfg(i,j,1) = +.25 + yfg(i,j,2) = +.25 + yfg(i,j,3) = +.50 + yfg(i,j,4) = +.50 + + xfg(i,j+1,1) = -.5 + xfg(i,j+1,2) = +.5 + xfg(i,j+1,3) = -.5 + xfg(i,j+1,4) = +.5 + yfg(i,j+1,1) = -.50 + yfg(i,j+1,2) = -.50 + yfg(i,j+1,3) = -.25 + yfg(i,j+1,4) = -.25 + END DO + + 799 CONTINUE + +! ---- EGP need to make sure only the grid that contains +! the fire center gets set +! + x = (i2-(nfrx*(ifde-ifds+1)-2)/2-1.5)*dxf !grid center + spd = alpha*ABS(x)/rmax + ss = 0.018*EXP(.8424*spd) ! why Macarthur in here? + dxp = (0.018*dyf)/(ss*dxf) + dxp = SIGN(1.,alpha)*dxp + + xfg(i1,j+1,3) = -.25 + .5*dxp + xfg(i1,j+1,1) = -.25 + xfg(i1,j ,3) = -.25 + xfg(i1,j ,1) = -.25 - .5*dxp + +! ism = (nxmm/2)*nfrx +! isp = (nxmm/2)*nfrx + 3 + xfg(ism,j+1,4) = +.25 + xfg(ism,j+1,2) = +.25 + xfg(ism,j ,4) = +.25 + xfg(ism,j ,2) = +.25 + xfg(isp,j+1,3) = -.25 + xfg(isp,j+1,1) = -.25 + xfg(isp,j ,3) = -.25 + xfg(isp,j ,1) = -.25 + + xfg(i2,j+1,4) = +.25 + .5*dxp + xfg(i2,j+1,2) = +.25 + xfg(i2,j ,4) = +.25 + xfg(i2,j ,2) = +.25 - .5*dxp + END IF ! END ishape=2, windmill fire + + tignm = time + + END IF ! iof=2 + + RETURN + +END SUBROUTINE fire_init + +! ========================================================================= + +SUBROUTINE fire_stat(iffg,dt,time, & ! incoming + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,nfl_t,tign_g,tign_crt, & ! inout + area,area2,xfg,yfg, & + ixb,iyb,icn) ! out + +! --- if iffg > 0, this routine resets all the variables +! defining the fire line, updates the locations of +! the fire line, and ignites any cells fully surrounded +! fire + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in) :: iffg + + REAL, INTENT(in) :: dt,time + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + +! ----- inout variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2 + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ----- outgoing variables + + INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + +! ----- local variables + + INTEGER :: i,j,it + INTEGER :: i1,j1 + INTEGER :: nct,icls + INTEGER :: ic1,ic2,ic3,ic4 + INTEGER :: inxt,inyt + INTEGER :: is,js,iss,jss + INTEGER :: iod + INTEGER :: isum,jsum + INTEGER :: itest + INTEGER :: itot + INTEGER :: ita,itb,itc + + INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl,islsum + + REAL :: x1,y1 + REAL :: x2,y2 + REAL :: x3,y3 + REAL :: x4,y4 + REAL :: an + REAL :: t1 + REAL :: xavg,yavg + REAL :: xfg_a,yfg_a + + REAL, DIMENSION( ifms:ifme,jfms:jfme ) :: tmp + +! ----- when deriving fireline coordinates we always keep the fire to our left + + DO j = jf_st,jf_en + DO i = if_st,if_en + DO it = 1,4 + ixb(i,j,it) = INT(ABS(xfg(i,j,it)-xlm(it)) / & + (ABS(xfg(i,j,it)-xlm(it)) + ep) + .5 - ep) + iyb(i,j,it) = INT(ABS(yfg(i,j,it)-ylm(it)) / & + (ABS(yfg(i,j,it)-ylm(it)) + ep) + .5 - ep) + icn(i,j,it) = 1 + ixb(i,j,it)*iyb(i,j,it) - ixb(i,j,it) - iyb(i,j,it) + END DO + END DO + END DO + + IF (iffg > 0) THEN ! iffg > 0 + + DO j = jf_st,jf_en + DO i = if_st,if_en + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) & + + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + tmp(i,j) = .5 * ((xfg(i,j,4)-xfg(i,j,1)) * (yfg(i,j,3)-yfg(i,j,2)) & + + (yfg(i,j,4)-yfg(i,j,1)) * (xfg(i,j,2)-xfg(i,j,3))) + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 LOOP + + nct = nc(i,j) + icls = icl(i,j) + + IF (nct == 3 .AND. icls == 1) THEN !3/1 TREATMENT + +! ----- natural triangle is (x1,x2) (x2,y2), (x3,y3) + + ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4) + x1 = xlm(ic1) + y1 = ylm(ic1) + x2 = xfg(i,j,ic1) + y2 = yfg(i,j,ic1) + + ic3 = (1 - icn(i,j,1))*(2 + ixb(i,j,1)) & + + (1 - icn(i,j,2))*(1 + 3*ixb(i,j,2)) & + + (1 - icn(i,j,3))*(4 - 3*ixb(i,j,3)) & + + (1 - icn(i,j,4))*(3 - ixb(i,j,4)) + x3 = xlm(ic3) + y3 = ylm(ic3) + + inxt = (1 - ixb(i,j,ic1))*( & ! 0=no virt, 1=virt x-coord + (1-icn(i,j,1)) * (1-iyb(i,j-1,3)) + & + (1-icn(i,j,2)) * (1-iyb(i,j-1,4)) + & + (1-icn(i,j,3)) * (1-iyb(i,j+1,1)) + & + (1-icn(i,j,4)) * (1-iyb(i,j+1,2)) ) + + x3 = FLOAT(1-inxt)*x3 + FLOAT(inxt)*( & + FLOAT(1-icn(i,j,1)) * xfg(i,j-1,3)+ & + FLOAT(1-icn(i,j,2)) * xfg(i,j-1,4)+ & + FLOAT(1-icn(i,j,3)) * xfg(i,j+1,1)+ & + FLOAT(1-icn(i,j,4)) * xfg(i,j+1,2)) + + inyt = ixb(i,j,ic1)*( & ! 0=no virt, 1=virt y-coord + (1-icn(i,j,1)) * (1-ixb(i-1,j,2)) + & + (1-icn(i,j,2)) * (1-ixb(i+1,j,1)) + & + (1-icn(i,j,3)) * (1-ixb(i-1,j,4)) + & + (1-icn(i,j,4)) * (1-ixb(i+1,j,3)) ) + + y3 = FLOAT(1-inyt)*y3 + FLOAT(inyt) * ( & + FLOAT(1-icn(i,j,1))*yfg(i-1,j,2) + & + FLOAT(1-icn(i,j,2))*yfg(i+1,j,1) + & + FLOAT(1-icn(i,j,3))*yfg(i-1,j,4) + & + FLOAT(1-icn(i,j,4))*yfg(i+1,j,3) ) + + tmp(i,j) = 1. - .5*ABS((x2-x1)*(y3-y1)) - .5*ABS((y2-y1)*(x3-x1)) + + IF (tmp(i,j) > 1.-ep) THEN + IF (iffg == 1) tmp(i,j) = 1. - 2.*ep !test + + xfg(i,j-1,3) = FLOAT(icn(i,j,1))*xfg(i,j-1,3)+ & + FLOAT(1-icn(i,j,1))*xlm(3) + xfg(i,j-1,4) = FLOAT(icn(i,j,2))*xfg(i,j-1,4)+ & + FLOAT(1-icn(i,j,2))*xlm(4) + xfg(i,j+1,1) = FLOAT(icn(i,j,3))*xfg(i,j+1,1)+ & + FLOAT(1-icn(i,j,3))*xlm(1) + xfg(i,j+1,2) = FLOAT(icn(i,j,4))*xfg(i,j+1,2)+ & + FLOAT(1-icn(i,j,4))*xlm(2) + + yfg(i-1,j,2) = FLOAT(icn(i,j,1))*yfg(i-1,j,2)+ & + FLOAT(1-icn(i,j,1))*ylm(2) + yfg(i+1,j,1) = FLOAT(icn(i,j,2))*yfg(i+1,j,1)+ & + FLOAT(1-icn(i,j,2))*ylm(1) + yfg(i-1,j,4) = FLOAT(icn(i,j,3))*yfg(i-1,j,4)+ & + FLOAT(1-icn(i,j,3))*ylm(4) + yfg(i+1,j,3) = FLOAT(icn(i,j,4))*yfg(i+1,j,3)+ & + FLOAT(1-icn(i,j,4))*ylm(3) + + END IF + END IF !3/1 TREATMENT + + IF (nct == 2 .AND. icls == 3) THEN !2/3 TREATMENT + +! ----- We convert 2/3's to 2/2's because code has no treatment +! for 2/3's, i.e. it is an unecessary class. +! IC1 and IC2 are indices of the two corners +! IC3 is index of point to be moved to near IC1 corner. + + ic1 = 1*icn(i,j,1)*(ixb(i,j,3)+iyb(i,j,2)) + & + 2*icn(i,j,2)*(ixb(i,j,4)+iyb(i,j,1)) + & + 3*icn(i,j,3)*(ixb(i,j,1)+iyb(i,j,4)) + & + 4*icn(i,j,4)*(ixb(i,j,2)+iyb(i,j,3)) + + ic2 = 1*icn(i,j,1)*ixb(i,j,4)*iyb(i,j,4) + & + 2*icn(i,j,2)*ixb(i,j,3)*iyb(i,j,3) + & + 3*icn(i,j,3)*ixb(i,j,2)*iyb(i,j,2) + & + 4*icn(i,j,4)*ixb(i,j,1)*iyb(i,j,1) + + ic3 = ixb(i,j,1)*iyb(i,j,1) + & + 2*ixb(i,j,2)*iyb(i,j,2) + & + 3*ixb(i,j,3)*iyb(i,j,3) + & + 4*ixb(i,j,4)*iyb(i,j,4) + + ic4 = 10 - ic1 - ic2 - ic3 + + is = i + (1-ixb(i,j,ic4))*INT((1.+ep)*(xfg(i,j,ic1)-xfg(i,j,ic4))) + js = j + ixb(i,j,ic4) *INT((1.+ep)*(yfg(i,j,ic1)-yfg(i,j,ic4))) + + xfg(i,j,ic3) = FLOAT(iyb(i,j,ic4))*xlm(ic3) & + + FLOAT(1-iyb(i,j,ic4))* & + (FLOAT(1-nfl(i,js)*ixb(i,js,ic4))* & + (xlm(ic1)+SIGN(2.*ep,xfg(i,j,ic3)-xfg(i,j,ic1))) & +! + nfl(i,js)*ixb(i,js,ic4)*xfg(i,js,ic4)) & !old version + + nfl(i,js)*ixb(i,js,ic4)*((1-iyb(i,js,ic4))*xfg(i,js,ic4) &!test + + iyb(i,js,ic4)*(-xlm(ic3)+SIGN(2.*ep,xlm(ic3))))) + +! ixb(i,j,ic3) = 1 - iyb(i,j,ic4) !old version + ixb(i,j,ic3) = INT(ABS(xfg(i,j,ic3)-xlm(ic3))/ & + (ABS(xfg(i,j,ic3)-xlm(ic3))+ep)+.5-ep) !test + + yfg(i,j,ic3) = FLOAT(ixb(i,j,ic4))*ylm(ic3) & + + FLOAT(1-ixb(i,j,ic4))*(FLOAT(1-nfl(is,j)*iyb(is,j,ic4))* & + (ylm(ic1)+SIGN(2.*ep,yfg(i,j,ic3)-yfg(i,j,ic1))) & +! + nfl(is,j)*iyb(is,j,ic4)*yfg(is,j,ic4)) & !old version + + nfl(is,j)*iyb(is,j,ic4)*((1-ixb(is,j,ic4))*yfg(is,j,ic4) & !test + + ixb(is,j,ic4)*(-ylm(ic3)+SIGN(2.*ep,ylm(ic3))))) + +! iyb(i,j,ic3) = 1 - ixb(i,j,ic4) !old version + iyb(i,j,ic3) = INT(ABS(yfg(i,j,ic3)-ylm(ic3))/ & + (ABS(yfg(i,j,ic3)-ylm(ic3))+ep)+.5-ep) !test + + tmp(i,j) = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) & + +(yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3))) + + IF (nfl(is,js) == 0) THEN + xfg(is,js,ic2) = xlm(ic2) + yfg(is,js,ic2) = ylm(ic2) + xfg(is,js,ic4) = FLOAT(1-iyb(i,j,ic3))*xfg(i,j,ic3) & + + FLOAT( iyb(i,j,ic3))*xlm(ic4) + yfg(is,js,ic4) = FLOAT( iyb(i,j,ic3))*yfg(i,j,ic3) & + + FLOAT(1-iyb(i,j,ic3))*ylm(ic4) + + iss = is + INT(SIGN(1.,xfg(i,j,ic2)-xfg(i,j,ic4))) & + * (1-iyb(i,j,ic3)) + jss = js + INT(SIGN(1.,yfg(i,j,ic2)-yfg(i,j,ic4))) & + * iyb(i,j,ic3) + +! PRINT *,'debug STAT 23 CONVERSION I J=',i,j +! PRINT *,'debug IS JS ISS JSS=',is,js,iss,jss + + xfg(is,js,ic1) = FLOAT(1-iyb(i,j,ic3))*xlm(ic1) & + + FLOAT(iyb(i,j,ic3))*( & + FLOAT(nfl(iss,jss)*(1-iyb(iss,jss,ic3))) & + * xfg(iss,jss,ic3) & + + FLOAT(1-nfl(iss,jss)*(1-iyb(iss,jss,ic3)))* & + (xlm(ic2)+2.*ep*SIGN(1.,xfg(i,j,ic1)-xfg(i,j,ic2)))) + + yfg(is,js,ic1) = FLOAT(iyb(i,j,ic3))*ylm(ic1) & + + FLOAT(1-iyb(i,j,ic3))*( & + FLOAT(nfl(iss,jss)*(1-ixb(iss,jss,ic3))) & + * yfg(iss,jss,ic3) & + + FLOAT(1-nfl(iss,jss)*(1-ixb(iss,jss,ic3)))* & + (ylm(ic2)+2.*ep*SIGN(1.,yfg(i,j,ic1)-yfg(i,j,ic2)))) + + xfg(is,js,ic3) = .5*(xfg(is,js,ic1)+xfg(is,js,ic4)) + yfg(is,js,ic3) = .5*(yfg(is,js,ic1)+yfg(is,js,ic4)) + + nfl(is,js) = 1 + tign_g(is,js) = time + +! PRINT *,'debug XFG(IS,JS=',(XFG(IS,JS,IT),IT=1,4) +! PRINT *,'debug YFG(IS,JS=',(YFG(IS,JS,IT),IT=1,4) +! PRINT *,'debug IC1 IC2 IC3 IC4=',IC1,IC2,IC3,IC4 +! + END IF + END IF !2/3 TREATMENT + + IF (nct == 3 .AND. icls == 2) THEN !3/2 TREATMENT + + ic1 = 1*(ixb(i,j,1)*iyb(i,j,1)) + & + 2*(ixb(i,j,2)*iyb(i,j,2)) + & + 3*(ixb(i,j,3)*iyb(i,j,3)) + & + 4*(ixb(i,j,4)*iyb(i,j,4)) + ic2 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4) + + x1 = xfg(i,j,ic1) + y1 = yfg(i,j,ic1) + x2 = xlm(ic2) + y2 = ylm(ic2) + + iod = ic1 - 2*(ic1/2) + ic3 = ic1 - 1 + 2*iod + ic4 = 6 - ic1 - 2*iod + is = i + 1 - 2*iod + js = j - 1 + 2*(ic1/3) + + x3 = FLOAT(1-nfl(i,js)*ixb(i,js,ic4))*xlm(ic3) + & + FLOAT( nfl(i,js)*ixb(i,js,ic4))*xfg(i,js,ic4) + y3 = ylm(ic3) + x4 = xlm(ic4) + y4 = FLOAT(1-nfl(is,j)*iyb(is,j,ic3))*ylm(ic4) + & + FLOAT( nfl(is,j)*iyb(is,j,ic3))*yfg(is,j,ic3) + + tmp(i,j) = 1. - .5*(ABS((x2-x1)*(y3-y4)) + ABS((y2-y1)*(x4-x3))) + + END IF !3/2 TREATMENT + + END IF !NFL=1 LOOP + + END DO + END DO + + IF (iffg == 1) THEN ! iffg == 1 + + DO j = jf_st,jf_en + DO i = if_st,if_en + area(i,j) = tmp(i,j) + END DO + END DO + + END IF ! iffg == 1 + + IF(IFFG == 2) THEN !IFFG == 2 + +! --- locate and ignite any totally boundary enclosed regions, i.e. where +! nfl=1 everywhere within a closed burning contour. We only consider +! regions with area less than 1.-ep + + DO j = jf_st,jf_en + DO i = if_st,if_en + an = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) & + + (yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3))) + nfl_t(i,j) = INT((ep+tign_g(i,j)+ABS(ep+tign_g(i,j)))/ & + (2.*ABS(tign_g(i,j))+2.*ep)+.5) + nfl(i,j) = nfl_t(i,j) * (1 - INT(an+ep)) + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + DO it = 1,4 + ixb(i,j,it) = INT(ABS(xfg(i,j,it)-xlm(it))/ & + (ABS(xfg(i,j,it)-xlm(it)) + ep) + .5 - ep) + iyb(i,j,it) = INT(ABS(yfg(i,j,it)-ylm(it))/ & + (ABS(yfg(i,j,it)-ylm(it)) + ep) + .5 - ep) + icn(i,j,it) = 1 + ixb(i,j,it)*iyb(i,j,it) & + - ixb(i,j,it) - iyb(i,j,it) + END DO + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 + islsum(i,j) = & + INT((tign_g(i+1,j) + ABS(tign_g(i+1,j)) + 2.*ep)/ & + (2.*ABS(tign_g(i+1,j)) + 1.5*ep)) + & + INT((tign_g(i-1,j) + ABS(tign_g(i-1,j)) + 2.*ep)/ & + (2.*ABS(tign_g(i-1,j)) + 1.5*ep)) + & + INT((tign_g(i,j+1) + ABS(tign_g(i,j+1)) + 2.*ep)/ & + (2.*ABS(tign_g(i,j+1)) + 1.5*ep)) + & + INT((tign_g(i,j-1) + ABS(tign_g(i,j-1)) + 2.*ep)/ & + (2.*ABS(tign_g(i,j-1)) + 1.5*ep)) + & + INT((tign_g(i+1,j+1)+ABS(tign_g(i+1,j+1)) + 2.*ep)/ & + (2.*ABS(tign_g(i+1,j+1)) + 1.5*ep)) + & + INT((tign_g(i-1,j+1)+ABS(tign_g(i-1,j+1)) + 2.*ep)/ & + (2.*ABS(tign_g(i-1,j+1)) + 1.5*ep)) + & + INT((tign_g(i+1,j-1)+ABS(tign_g(i+1,j-1)) + 2.*ep)/ & + (2.*ABS(tign_g(i+1,j-1)) + 1.5*ep)) + & + INT((tign_g(i-1,j-1)+ABS(tign_g(i-1,j-1)) + 2.*ep)/ & + (2.*ABS(tign_g(i-1,j-1)) + 1.5*ep)) + END IF ! nfl=1 + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 + + isum = islsum(i,j) + + IF (isum == 8) THEN !ISUM=8 + + itest = 1 + + IF (nc(i,j) == 1 .AND. icl(i,j) == 4) THEN !1/4 treatment +! ----- test for threat of second ignition (itest=0 is necessary to continue) + itest=(1-icn(i,j,1))*(icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) & + +(1-icn(i,j,2))*(icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4)) & + +(1-icn(i,j,3))*(icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1)) & + +(1-icn(i,j,4))*(icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2)) + END IF !1/4 treatment + + IF (itest > 0) THEN +!! nfl(i,j) = 0 + area2(i,j) = 1. + DO it = 1,4 + ixb(i,j,it) = 0 + iyb(i,j,it) = 0 + icn(i,j,it) = 1 + xfg(i,j,it) = xlm(it) + yfg(i,j,it) = ylm(it) + END DO + END IF ! itest > 0 + END IF ! isum = 8 + END IF ! nfl = 1 + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + IF (nfl(i,j) == 1) THEN ! nfl=1 + isum = islsum(i,j) + IF (isum == 8) THEN ! isum = 8 + itest = 1 + + IF (nc(i,j) == 2 .AND. icl(i,j) == 2) THEN ! 2/2 treatment + IF (icn(i,j,1)+icn(i,j,2) == 2) itest= & + (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1)) & + + (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2)) + IF (icn(i,j,3)+icn(i,j,4) == 2) itest= & + (icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) & + + (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4)) + IF (icn(i,j,1)+icn(i,j,3) == 2) itest= & + (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4)) & + + (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2)) + IF (icn(i,j,2)+icn(i,j,4) == 2) itest= & + (icn(i-1,j,2)+icn(i-1,j-1,4)+icn(i,j-1,3)) & + + (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1)) + END IF ! 2/2 treatment + + IF (itest > 0) THEN +! itot = itot + 1 +!! nfl(i,j) = 0 + area2(i,j) = 1. + DO it = 1,4 + ixb(i,j,it) = 0 + iyb(i,j,it) = 0 + icn(i,j,it) = 1 + xfg(i,j,it) = xlm(it) + yfg(i,j,it) = ylm(it) + END DO + END IF ! itest > 0 + END IF ! isum = 8 + END IF ! nfl = 1 + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 + + isum = islsum(i,j) + + IF (isum == 8) THEN !ISUM=8 + + itest = 1 + + IF (nc(i,j) == 3 .AND. icl(i,j) == 1) THEN !3/1 treatment + + ic1 = 10-icn(i,j,1)-2*icn(i,j,2)-3*icn(i,j,3)-4*icn(i,j,4) + + IF (ic1 == 1) THEN + itest = (1-icn(i,j,ic1)) * & + (icn(i-1,j,2)+icn(i-1,j-1,4) + icn(i,j-1,3) & + + icn(i,j-1,1)*iyb(i,j-1,3) + & + icn(i-1,j,1)*ixb(i,j-1,2) & + + icn(i,j-1,2)*icn(i-1,j-1,2)*iyb(i,j,1) & + + icn(i-1,j,3)*icn(i-1,j-1,3)*ixb(i,j,1)) + END IF + + IF (ic1 == 2) THEN + itest = (1-icn(i,j,ic1)) * & + (icn(i+1,j,1)+icn(i+1,j-1,3)+icn(i,j-1,4) & + + icn(i,j-1,2)*iyb(i,j-1,4)+ & + icn(i+1,j,2)*ixb(i,j-1,1) & + + icn(i,j-1,1)*icn(i+1,j-1,1)*iyb(i,j,2) & + + icn(i+1,j,4)*icn(i+1,j-1,4)*ixb(i,j,2)) + END IF + + IF (ic1 == 3) THEN + itest = (1-icn(i,j,ic1)) * & + (icn(i-1,j,4)+icn(i-1,j+1,2)+icn(i,j+1,1) & + + icn(i,j+1,3)*iyb(i,j+1,1) + & + icn(i-1,j,3) * ixb(i-1,j,4) & + + icn(i,j+1,4)*icn(i-1,j+1,4)*iyb(i,j,3) & + + icn(i-1,j,1)*icn(i-1,j+1,1)*ixb(i,j,3)) + END IF + + IF (ic1 == 4) THEN + itest = (1-icn(i,j,ic1)) * & + (icn(i+1,j,3)+icn(i+1,j+1,1)+icn(i,j+1,2) & + + icn(i,j+1,4)*iyb(i,j+1,2)+ & + icn(i+1,j,4)*ixb(i+1,j,3) & + + icn(i,j+1,3)*icn(i+1,j+1,3)*iyb(i,j,4) & + + icn(i+1,j,2)*icn(i+1,j+1,2)*ixb(i,j,4)) + END IF + + END IF !3/1 treatment + + IF (itest > 0) THEN + area2(i,j) = 1. + DO it = 1,4 + ixb(i,j,it) = 0 + iyb(i,j,it) = 0 + icn(i,j,it) = 1 + xfg(i,j,it) = xlm(it) + yfg(i,j,it) = ylm(it) + END DO + END IF ! itest > 0 + END IF ! ISUM = 8 + END IF ! NFL = 1 + END DO + END DO + + ! --- here we are figuring out which cells define the fire line + ! + ! if tign_g() > 0 then nfl() is set to 1 (this only tells us + ! if the cell is on fire. then we go find out whether our + ! neighbors are on fire and whether their tracers are in the + ! adjacent corner. if all four neighboring cells are on fire + ! and the tracers are in the corners nearest my current point, + ! then we must be in an interior point, nfl()=0. if all four + ! neighboring cells don't have tracers pushed to the corner near + ! me, then we must be at the edge of the fire, nfl() = 1. + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfl(i,j) = INT( (ep + tign_g(i,j) + ABS(ep + tign_g(i,j))) / & + (2.*ABS(tign_g(i,j))+2.*ep)+.5 ) + nfl_t(i,j) = (1 - INT(area(i,j) + ep)) !test + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + nfl_t(i,j) = (1 - int(area(i,j) + ep - 2.*ep* & + (1. - FLOAT(( & + ((icn(i+1,j,1) + icn(i+1,j,3))/2)*nfl(i+1,j) + & + ((icn(i-1,j,2) + icn(i-1,j,4))/2)*nfl(i-1,j) + & + ((icn(i,j+1,1) + icn(i,j+1,2))/2)*nfl(i,j+1) + & + ((icn(i,j-1,3) + icn(i,j-1,4))/2)*nfl(i,j-1) & + )/4)))) !test + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfl(i,j) = nfl(i,j)*nfl_t(i,j) + END DO + END DO + + ! --- check on validity of 1/4's and 2/2's + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + IF (nfl(i,j) == 1) THEN !NFL=1 + nct = icn(i,j,1)+icn(i,j,2)+icn(i,j,3)+icn(i,j,4) + icls = ixb(i,j,1)+ixb(i,j,2)+ixb(i,j,3)+ixb(i,j,4) + & + iyb(i,j,1)+iyb(i,j,2)+iyb(i,j,3)+iyb(i,j,4) + + ! --- check that 1/4 is logical + + IF (nct == 1 .AND. icls == 4) THEN ! nct=1 icls=4 validity test + + CALL fire_valid14(i,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, & + icl,xfg,yfg,ixb,iyb,icn, & + ifms,ifme, kfms,kfme, jfms,jfme) + + IF (ita == 0 .AND. itb == 0 .AND. itc > 0) THEN + xfg(i,j,ic3) = xlm(ic3) + yfg(i,j,ic3) = ylm(ic3) + icn(i,j,ic3) = 1 + ixb(i,j,ic3) = 0 + iyb(i,j,ic3) = 0 + xfg(i,j,ic4) = xlm(ic4) + yfg(i,j,ic4) = ylm(ic4) + icn(i,j,ic4) = 1 + ixb(i,j,ic4) = 0 + iyb(i,j,ic4) = 0 + + ! ----- following call takes care of indexing order effects + + IF (nc(i-1,j) == 1 .AND. icl(i-1,j) == 4 .AND. i > 2) & + CALL fire_valid14(i-1,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, & + icl,xfg,yfg,ixb,iyb,icn, & + ifms,ifme, kfms,kfme, jfms,jfme) + IF (nc(i,j-1) == 1 .AND. icl(i,j-1) == 4 .AND. j > 2) & + CALL fire_valid14(i,j-1,ic1,ic2,ic3,ic4,ita,itb,itc,nc, & + icl,xfg,yfg,ixb,iyb,icn, & + ifms,ifme, kfms,kfme, jfms,jfme) + END IF + END IF ! NCT=1 ICLS=4 validity test + END IF ! NFL=1 + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + IF (nfl(i,j) == 1) THEN !NFL=1 + nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icls = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + + ! -- check on validity of 2/2's + + IF (nct == 2 .AND. icls == 2) THEN !2/2 TESTING FOLLOWS + isum = nfl(i+1,j) + nfl(i-1,j) + + IF (iyb(i,j,1)+iyb(i,j,2) == 2 .AND. isum < 2) THEN + IF (nfl(i+1,j) == 0 .AND. area2(i+1,j) > 1.-ep) THEN + yfg(i,j,2) = ylm(2) + END IF + IF (nfl(i-1,j) == 0 .AND. area2(i-1,j) > 1.-ep) THEN + yfg(i,j,1) = ylm(1) + END IF + END IF + + IF (iyb(i,j,3)+iyb(i,j,4) == 2 .AND. isum < 2) THEN + IF (nfl(i+1,j) == 0 .AND. area2(i+1,j) > 1.-ep) THEN + yfg(i,j,4) = ylm(4) + END IF + IF (nfl(i-1,j) == 0 .AND. area2(i-1,j) > 1.-ep) THEN + yfg(i,j,3) = ylm(3) + END IF + END IF + + jsum = nfl(i,j+1) + nfl(i,j-1) + IF (ixb(i,j,1)+ixb(i,j,3) == 2 .AND. jsum < 2) THEN + IF (nfl(i,j+1) == 0 .AND. area2(i,j+1) > 1.-ep) THEN + xfg(i,j,3) = xlm(3) + END IF + IF (nfl(i,j-1) == 0 .AND. area2(i,j-1) > 1.-ep) THEN + xfg(i,j,1) = xlm(1) + END IF + END IF + + IF (ixb(i,j,2)+ixb(i,j,4) == 2 .AND. jsum < 2) THEN + IF (nfl(i,j+1) == 0 .AND. area2(i,j+1) > 1.-ep) THEN + xfg(i,j,4) = xlm(4) + END IF + IF (nfl(i,j-1) == 0 .AND. area2(i,j-1) > 1.-ep) THEN + xfg(i,j,2) = xlm(2) + END IF + END IF + END IF !2/2 TESTING ABOVE + + ! --- this portion of code was not active in the dand1 testing + ! debug new code follows + IF (nct == 3 .AND. (icls == 1 .OR. icls == 2)) THEN ! 3/1 TESTING + ic2 = (1-icn(i,j,1)) + 2*(1-icn(i,j,2)) & + + 3*(1-icn(i,j,3)) + 4*(1-icn(i,j,4)) + ic1 = 5 - ic2 + ic3 = 2 - (ic1*ic2)/6 + ic4 = 10 - ic1 - ic2 - ic3 + t1 = ABS(ABS(xfg(i,j,ic2))-.5) + ABS(ABS(yfg(i,j,ic2))-.5) + IF (t1 < 10.*ep) THEN + PRINT *,'debug 3/1 to 3/2 conversion hit' + xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4)) + yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4)) + ixb(i,j,ic2) = 1 + iyb(i,j,ic2) = 1 + END IF + END IF !3/1 TESTING FOLLOWS + ! debug new code above + ! --- the above portion of code was not active in the dand1 testing + + END IF !NFL=1 + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + nc(i,j) = icn(i,j,1)+icn(i,j,2)+icn(i,j,3)+icn(i,j,4) + icl(i,j) = ixb(i,j,1)+ixb(i,j,2)+ixb(i,j,3)+ixb(i,j,4) + & + iyb(i,j,1)+iyb(i,j,2)+iyb(i,j,3)+iyb(i,j,4) + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 + + nct = nc(i,j) + icls = icl(i,j) + + ! --- align neighbors with 2/2s + + IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2 + + IF (icn(i,j,1)+icn(i,j,3) == 2) THEN + IF (nfl(i,j+1)*ixb(i,j+1,2) == 1 & + .AND. iyb(i,j+1,2) == 0) THEN + xavg = .5*(xfg(i,j+1,2)+xfg(i,j,4)) +! xavg = amax1(xfg(i,j+1,2),xfg(i,j,4)) + xfg(i,j+1,2) = xavg + xfg(i,j,4) = xavg + END IF + IF (nc(i,j+1) == 4) xfg(i,j,4) = xlm(4) + IF (nfl(i,j-1)*ixb(i,j-1,4) == 1 & + .AND. iyb(i,j-1,4) == 0) THEN + xavg = .5*(xfg(i,j-1,4)+xfg(i,j,2)) +! xavg = amax1(xfg(i,j-1,4),xfg(i,j,2)) + xfg(i,j-1,4) = xavg + xfg(i,j,2) = xavg + END IF + IF (nc(i,j-1) == 4) xfg(i,j,2) = xlm(2) + END IF + + IF (icn(i,j,2)+icn(i,j,4) == 2) THEN + IF (nfl(i,j+1)*ixb(i,j+1,1) == 1 & + .AND. iyb(i,j+1,1) == 0) THEN + xavg = .5*(xfg(i,j+1,1)+xfg(i,j,3)) +! xavg = MIN(xfg(i,j+1,1),xfg(i,j,3)) + xfg(i,j+1,1) = xavg + xfg(i,j,3) = xavg + END IF + IF (nc(i,j+1) == 4) xfg(i,j,3) = xlm(3) + IF (nfl(i,j-1)*ixb(i,j-1,3) == 1 & + .AND. iyb(i,j-1,3) == 0) THEN + xavg = .5*(xfg(i,j-1,3)+xfg(i,j,1)) +! xavg = MIN(xfg(i,j-1,3),xfg(i,j,1)) + xfg(i,j-1,3) = xavg + xfg(i,j,1) = xavg + END IF + IF (nc(i,j-1) == 4) xfg(i,j,1) = xlm(1) + END IF + + IF (icn(i,j,1)+icn(i,j,2) == 2) THEN + IF (nfl(i+1,j)*iyb(i+1,j,3) == 1 & + .AND. ixb(i+1,j,3) == 0) THEN + yavg = .5*(yfg(i+1,j,3)+yfg(i,j,4)) +! yavg = MAX(yfg(i+1,j,3),yfg(i,j,4)) + yfg(i+1,j,3) = yavg + yfg(i,j,4) = yavg + END IF + IF (nc(i+1,j) == 4) yfg(i,j,4) = ylm(4) + IF (nfl(i-1,j)*iyb(i-1,j,4) == 1 & + .AND. ixb(i-1,j,4) == 0) THEN + yavg = .5*(yfg(i-1,j,4)+yfg(i,j,3)) +! yavg = MAX(yfg(i-1,j,4),yfg(i,j,3)) + yfg(i-1,j,4) = yavg + yfg(i,j,3) = yavg + END IF + IF (nc(i-1,j) == 4) yfg(i,j,3) = ylm(3) + END IF + + IF (icn(i,j,3)+icn(i,j,4) == 2) THEN + IF (nfl(i+1,j)*iyb(i+1,j,1) == 1 & + .AND. ixb(i+1,j,1) == 0) THEN + yavg = .5*(yfg(i+1,j,1)+yfg(i,j,2)) +! yavg = MIN(yfg(i+1,j,1),yfg(i,j,2)) + yfg(i+1,j,1) = yavg + yfg(i,j,2) = yavg + END IF + IF (nc(i+1,j) == 4) yfg(i,j,2) = ylm(2) + IF (nfl(i-1,j)*iyb(i-1,j,2) == 1 & + .AND. ixb(i-1,j,2) == 0) THEN + yavg = .5*(yfg(i-1,j,2)+yfg(i,j,1)) +! yavg = MIN(yfg(i-1,j,2),yfg(i,j,1)) + yfg(i-1,j,2) = yavg + yfg(i,j,1) = yavg + END IF + IF (nc(i-1,j) == 4) yfg(i,j,1) = ylm(1) + END IF + + END IF !NCT=2 ICLS=2 + + ! --- align 1/4 neighbors with 3/1 moving coordinate + + IF (nct == 3 .AND. icls == 1) THEN !NCT=3 ICLS=1 + + IF (icn(i,j,1) == 0) THEN + IF(iyb(i,j,1) == 1 & + .AND. nc(i-1,j) == 1 & + .AND. icl(i-1,j) == 4) THEN + yfg(i-1,j,2) = yfg(i,j,1) + END IF + IF (ixb(i,j,1) == 1 & + .AND. nc(i,j-1) == 1 & + .AND. icl(i,j-1) == 4) THEN + xfg(i,j-1,3) = xfg(i,j,1) + END IF + END IF + + IF (icn(i,j,2) == 0) THEN + IF (iyb(i,j,2) == 1 & + .AND. nc(i+1,j) == 1 & + .AND. icl(i+1,j) == 4) THEN + yfg(i+1,j,1) = yfg(i,j,2) + END IF + IF (ixb(i,j,2) == 1 & + .AND. nc(i,j-1) == 1 & + .AND. icl(i,j-1) == 4) THEN + xfg(i,j-1,4) = xfg(i,j,2) + END IF + END IF + + IF (icn(i,j,3) == 0) THEN + IF (iyb(i,j,3) == 1 & + .AND. nc(i-1,j) == 1 & + .AND. icl(i-1,j) == 4) THEN + yfg(i-1,j,4) = yfg(i,j,3) + END IF + IF (ixb(i,j,3) == 1 & + .AND. nc(i,j+1) == 1 & + .AND. icl(i,j+1) == 4) THEN + xfg(i,j+1,1) = xfg(i,j,3) + END IF + END IF + + IF (icn(i,j,4) == 0) THEN + IF (iyb(i,j,4) == 1 & + .AND. nc(i+1,j) == 1 & + .AND. icl(i+1,j) == 4) THEN + yfg(i+1,j,3) = yfg(i,j,4) + END IF + IF (ixb(i,j,4) == 1 & + .AND. nc(i,j+1) == 1 & + .AND. icl(i,j+1) == 4) THEN + xfg(i,j+1,2) = xfg(i,j,4) + END IF + END IF + + END IF !NCT=3 ICLS=1 + + ! --- align abutting 1/4's + + itest=1 + if (itest.eq.1) then + IF (nct.eq.1 .AND. icls == 4) THEN !NCT=1 ICLS=4 + ic1 =icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ixb(i,j,1)*(1-iyb(i,j,1))+2*ixb(i,j,2)*(1-iyb(i,j,2)) + & + 3*ixb(i,j,3)*(1-iyb(i,j,3))+4*ixb(i,j,4)*(1-iyb(i,j,4)) + ic4 = 10 - ic1 - ic2 - ic3 + iod = ic1 - 2*(ic1/2) + is = 1 - 2*iod + js = -1 + 2*(ic1/3) + + IF (ic1 >= 1) THEN + IF (nc(i,j+js) == 1 .AND. & + icl(i,j+js) == 4 .AND. & + icn(i,j+js,ic4) == 1) THEN + xfg_a = .5*(xfg(i,j,ic3)+xfg(i,j+js,ic2)) + xfg(i,j,ic3) = xfg_a + xfg(i,j+js,ic2) = xfg_a + ! ----- align central coordinate + xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4)) +! yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4)) + END IF + IF (nc(i+is,j).eq.1 .AND. & + icl(i+is,j).eq.4 .AND. & + icn(i+is,j,ic3) == 1) THEN + yfg_a = .5*(yfg(i,j,ic4)+yfg(i+is,j,ic2)) + yfg(i,j,ic4) = yfg_a + yfg(i+is,j,ic2) = yfg_a + ! ----- align central coordinate +! xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4)) + yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4)) + END IF + END IF + + END IF !NCT=1 ICLS=4 + END IF + END IF !NFL=1 + END DO + END DO + + DO j = jf_st,jf_en + DO i = if_st,if_en + tmp(i,j) = .5*((xfg(i,j,4)-xfg(i,j,1))*(yfg(i,j,3)-yfg(i,j,2)) & + + (yfg(i,j,4)-yfg(i,j,1))*(xfg(i,j,2)-xfg(i,j,3))) + area2(i,j) = tmp(i,j) + If (nfl(i,j) < 0 .AND. ABS(time-tign_g(i,j)) < dt) THEN + tmp(i,j) = 0.0 + nfl(i,j) = 0 + tign_g(i,j) = -100. + DO it = 1,4 + xfg(i,j,it) = 0.0 + yfg(i,j,it) = 0.0 + END DO + END IF + END DO + END DO + + ! --- identify cells that are completely on fire for fire_burn_fcn + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + IF (area2(i,j) > (1.-ep) .AND. tign_crt(i,j) < 0.) THEN + tign_crt(i,j) = time + END IF + END DO + END DO + + END IF ! iffg == 2 + END IF ! iffg > 0 + + RETURN + +END SUBROUTINE fire_stat + +! ========================================================================= + +SUBROUTINE fire_ln(dt,time,zs,sprdx,sprdy, & ! incoming + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + ncod,in1,in2,ixb,iyb,icn, & ! inout + tign_g,tign_crt,area,area2,xfg,yfg, & + nfl,nfl_t,radhld,xcd,ycd,xcn,ycn) ! outgoing + +! ----- this routine creates points outlining the fire + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + REAL, INTENT(in) :: dt,time + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + +! ----- inout variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: area,area2 + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ----- outgoing variables + + INTEGER, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,nfl_t + + REAL, INTENT(out) :: radhld + + REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + +! ----- local variables + + INTEGER :: i,j,it + INTEGER :: istat + INTEGER :: nct,icls + INTEGER :: ic1,ic2,ic3,ic4 + INTEGER :: i1,i2,i3 + INTEGER :: j1,j2,j3 + INTEGER :: iflt + INTEGER :: inxt,inyt + INTEGER :: iod + INTEGER :: is,js + INTEGER :: isen + INTEGER :: it1,it2,it3,it4 + INTEGER :: nh0,nh1,nh2,nh3,nht + INTEGER :: itt + INTEGER :: ihit + INTEGER :: i1tst,j1tst + INTEGER :: i2tst,j2tst + INTEGER :: nh11,nh01,nh10,nhtmp + INTEGER :: ilm1,ilm2,ilm3,ilm4 + INTEGER :: itest + INTEGER :: iloc + INTEGER :: ihld,jhld + + INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl + + REAL :: t1 + REAL :: tlx,tly + REAL :: t1tst + REAL :: x02,y02,r02 + REAL :: x20,y20,r20 + REAL :: x22,y22,r22 + REAL :: x01,y01,r01 + REAL :: x10,y10,r10 + REAL :: x11,y11,r11 + REAL :: r1sq,r2sq + REAL :: radmax,radmin,radavg,radsum,radtst + REAL :: x1,y1 + REAL :: x2,y2 + REAL :: x3,y3 + REAL :: det,aa,bb,x_0,y_0,rad,vtsgn + + CHARACTER(LEN=80) :: msg + +! ----- when deriving fireline coordinates we always keep the fire to our left + + write(*,*)'in fire_ln: 1' + +! ----- calculate nfl(i,j) + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfl(i,j) = INT( (ep+tign_g(i,j) + ABS(ep+tign_g(i,j))) & + / (2.*ABS(tign_g(i,j))+2.*ep) + .5 ) + nfl_t(i,j) = (1 - INT(area(i,j) + ep)) !test + END DO + END DO + + write(*,*)'in fire_ln: 2' + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + nfl_t(i,j) = (1-INT(area(i,j)+ep-2.*ep* & + (1.-FLOAT(( & + ((icn(i+1,j,1)+icn(i+1,j,3))/2)*nfl(i+1,j) + & + ((icn(i-1,j,2)+icn(i-1,j,4))/2)*nfl(i-1,j) + & + ((icn(i,j+1,1)+icn(i,j+1,2))/2)*nfl(i,j+1) + & + ((icn(i,j-1,3)+icn(i,j-1,4))/2)*nfl(i,j-1) & + )/4)))) !test + END DO + END DO + write(*,*)'in fire_ln: 3' + + DO j = jf_st,jf_en + DO i = if_st,if_en + nfl(i,j) = nfl(i,j) * nfl_t(i,j) + DO it = 1,4 + xcd(i,j,it) = 0.0 + ycd(i,j,it) = 0.0 + xcn(i,j,it) = 0.0 + ycn(i,j,it) = 0.0 + END DO + END DO + END DO + + write(*,*)'in fire_ln: 4' + CALL fire_stat(0,dt,time, & ! send + zs,xcd,ycd,xcn,ycn,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,nfl_t,tign_g,tign_crt, & ! send&recv + area,area2,xfg,yfg, & + ixb,iyb,icn) ! recv + + write(*,*)'in fire_ln: 5' + DO j = jf_st,jf_en + DO i = if_st,if_en + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + END DO + END DO + write(*,*)'in fire_ln: 6' + +! ----- get xcd,ycd + +y_cd: DO j = jf_st+1,jf_en-1 +x_cd: DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL outer loop + + istat = 0 + nct = nc(i,j) + + IF (nct == 0) THEN !NCT=0 + iflt = 1 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF !NCT=0 + + ncod(i,j) = 0 + icls = icl(i,j) + + IF (nct == 4) THEN !NCT=4 ICLS=0 + ncod(i,j) = 2 + IF (tign_g(i+1,j) < 0.0 .OR. & + nfl(i+1,j)*(icn(i+1,j,1)+icn(i+1,j,3)) < 2) THEN + ycd(i,j,1) = (1-icn(i+1,j,1))*yfg(i,j,2) + icn(i+1,j,1)* & + yfg(i+1,j,3) + ycd(i,j,2) = (1-icn(i+1,j,3))*yfg(i,j,4) + icn(i+1,j,3)* & + yfg(i+1,j,1) + xcd(i,j,1) = xlm(2) + xcd(i,j,2) = xlm(4) + istat = istat + 1 + END IF + + IF (tign_g(i-1,j) < 0.0 .OR. & + nfl(i-1,j)*(icn(i-1,j,2)+icn(i-1,j,4)) < 2) THEN + ycd(i,j,1) = (1-icn(i-1,j,4))*yfg(i,j,3) + icn(i-1,j,4)* & + yfg(i-1,j,2) + ycd(i,j,2) = (1-icn(i-1,j,2))*yfg(i,j,1) + icn(i-1,j,2)* & + yfg(i-1,j,4) + xcd(i,j,1) = xlm(3) + xcd(i,j,2) = xlm(1) + istat = istat + 1 + END IF + + IF (tign_g(i,j+1) < 0.0 .OR. & + nfl(i,j+1)*(icn(i,j+1,1)+icn(i,j+1,2)) < 2) THEN + xcd(i,j,1) = (1-icn(i,j+1,2))*xfg(i,j,4) + icn(i,j+1,2)* & + xfg(i,j+1,1) + xcd(i,j,2) = (1-icn(i,j+1,1))*xfg(i,j,3) + icn(i,j+1,1)* & + xfg(i,j+1,2) + ycd(i,j,1) = ylm(4) + ycd(i,j,2) = ylm(3) + istat = istat + 1 + END IF + + IF (tign_g(i,j-1) < 0.0 .OR. & + nfl(i,j-1)*(icn(i,j-1,3)+icn(i,j-1,4)) < 2) THEN + xcd(i,j,1) = (1-icn(i,j-1,3))*xfg(i,j,1)+icn(i,j-1,3)* & + xfg(i,j+1,4) + xcd(i,j,2) = (1-icn(i,j-1,4))*xfg(i,j,2)+icn(i,j-1,4)* & + xfg(i,j+1,3) + ycd(i,j,1) = ylm(1) + ycd(i,j,2) = ylm(2) + istat = istat + 1 + END IF + END IF !NCT=4 ICLS=0 + + IF (nct == 3 .AND. icls == 1) THEN !NCT=3 AND ICLS=1 + ncod(i,j) = 2 + istat = istat + 1 + ic1 = (1-icn(i,j,1)) + 2*(1-icn(i,j,2)) + & + 3*(1-icn(i,j,3)) + 4*(1-icn(i,j,4)) + ic3 = (1-icn(i,j,1))*(2+ixb(i,j,1)) & + + (1-icn(i,j,2))*(1+3*ixb(i,j,2)) & + + (1-icn(i,j,3))*(4-3*ixb(i,j,3)) & + + (1-icn(i,j,4))*(3-ixb(i,j,4)) + i1 = ((ic1-2)*(ic1-3)*(1+ixb(i,j,ic1)) & + + (ic1-1)*(4-ic1)*(2-ixb(i,j,ic1)))/2 + i2 = 3 - i1 +! ------------------------------- inxt =0 means no virtual 1=virtual x-coordinate + inxt = (1-ixb(i,j,ic1))*( & + (1-icn(i,j,1))*(1-iyb(i,j-1,3)) + & + (1-icn(i,j,2))*(1-iyb(i,j-1,4)) + & + (1-icn(i,j,3))*(1-iyb(i,j+1,1)) + & + (1-icn(i,j,4))*(1-iyb(i,j+1,2))) +! ------------------------------- inyt =0 means no virtual 1=virtual y-coordinate + inyt = ixb(i,j,ic1)*( & + (1-icn(i,j,1))*(1-ixb(i-1,j,2)) + & + (1-icn(i,j,2))*(1-ixb(i+1,j,1)) + & + (1-icn(i,j,3))*(1-ixb(i-1,j,4)) + & + (1-icn(i,j,4))*(1-ixb(i+1,j,3))) + xcd(i,j,i1) = xfg(i,j,ic1) + ycd(i,j,i1) = yfg(i,j,ic1) + xcd(i,j,i2) = FLOAT(1-inxt)*xlm(ic3) + FLOAT(inxt)*( & + FLOAT(1-icn(i,j,1))*xfg(i,j-1,3)+ & + FLOAT(1-icn(i,j,2))*xfg(i,j-1,4)+ & + FLOAT(1-icn(i,j,3))*xfg(i,j+1,1)+ & + FLOAT(1-icn(i,j,4))*xfg(i,j+1,2)) + ycd(i,j,i2) = FLOAT(1-inyt)*ylm(ic3) + FLOAT(inyt)*( & + FLOAT(1-icn(i,j,1))*yfg(i-1,j,2)+ & + FLOAT(1-icn(i,j,2))*yfg(i+1,j,1)+ & + FLOAT(1-icn(i,j,3))*yfg(i-1,j,4)+ & + FLOAT(1-icn(i,j,4))*yfg(i+1,j,3)) + END IF !NCT=3 AND ICLS=1 + + IF (nct == 3 .AND. icls == 2) THEN !NCT=3 AND ICLS=2 + + ncod(i,j) = 3 + + IF (icn(i,j,1) == 0) THEN + xcd(i,j,1) = xfg(i,j,3) + xcd(i,j,2) = xfg(i,j,1) + xcd(i,j,3) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j,2) & + + FLOAT(nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j-1,3) + ycd(i,j,1) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,2))*yfg(i,j,3) & + + FLOAT(nfl(i-1,j)*iyb(i-1,j,2))*yfg(i-1,j,2) + ycd(i,j,2) = yfg(i,j,1) + ycd(i,j,3) = yfg(i,j,2) + istat = istat + 1 + END IF + + IF (icn(i,j,2) == 0) THEN + xcd(i,j,1) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j,1) & + + FLOAT( nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j-1,4) + xcd(i,j,2) = xfg(i,j,2) + xcd(i,j,3) = xfg(i,j,4) + ycd(i,j,1) = yfg(i,j,1) + ycd(i,j,2) = yfg(i,j,2) + ycd(i,j,3) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,1))*yfg(i,j,4) & + + FLOAT( nfl(i+1,j)*iyb(i+1,j,1))*yfg(i+1,j,1) + istat = istat + 1 + END IF + + IF (icn(i,j,3) == 0) THEN + xcd(i,j,1) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j,4) & + + FLOAT( nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j+1,1) + xcd(i,j,2) = xfg(i,j,3) + xcd(i,j,3) = xfg(i,j,1) + ycd(i,j,1) = yfg(i,j,4) + ycd(i,j,2) = yfg(i,j,3) + ycd(i,j,3) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,4))*yfg(i,j,1) & + + FLOAT( nfl(i-1,j)*iyb(i-1,j,4))*yfg(i-1,j,4) + istat = istat + 1 + END IF + + IF (icn(i,j,4) == 0) THEN + xcd(i,j,1) = xfg(i,j,2) + xcd(i,j,2) = xfg(i,j,4) + xcd(i,j,3) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j,3) & + + FLOAT( nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j+1,2) + ycd(i,j,1) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,3))*yfg(i,j,2) & + + FLOAT( nfl(i+1,j)*iyb(i+1,j,3))*yfg(i+1,j,3) + ycd(i,j,2) = yfg(i,j,4) + ycd(i,j,3) = yfg(i,j,3) + istat = istat + 1 + END IF + + END IF !NCT=3 AND ICLS=2 + + IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2 + ncod(i,j) = 2 + IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 AND 2 + xcd(i,j,1) = xfg(i,j,4) + xcd(i,j,2) = xfg(i,j,3) + ycd(i,j,1) = yfg(i,j,4) + ycd(i,j,2) = yfg(i,j,3) + istat = istat + 1 + END IF !IT=1 AND 2 + IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 AND 4 + xcd(i,j,1) = xfg(i,j,3) + xcd(i,j,2) = xfg(i,j,1) + ycd(i,j,1) = yfg(i,j,3) + ycd(i,j,2) = yfg(i,j,1) + istat = istat + 1 + END IF !IT=2 AND 4 + IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 AND 4 + xcd(i,j,1) = xfg(i,j,1) + xcd(i,j,2) = xfg(i,j,2) + ycd(i,j,1) = yfg(i,j,1) + ycd(i,j,2) = yfg(i,j,2) + istat = istat + 1 + END IF !IT=3 AND 4 + IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 AND 3 + xcd(i,j,1) = xfg(i,j,2) + xcd(i,j,2) = xfg(i,j,4) + ycd(i,j,1) = yfg(i,j,2) + ycd(i,j,2) = yfg(i,j,4) + istat = istat + 1 + END IF !IT=1 AND 3 + END IF !NCT=2 ICLS=2 + + IF (nct == 2 .AND. icls == 3) THEN !NCT=2 ICLS=3 + ncod(i,j) = 3 + IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 AND 2 + IF (ixb(i,j,3) == 1) THEN + xcd(i,j,1) = xfg(i,j,4) + xcd(i,j,2) = xfg(i,j,3) + xcd(i,j,3) = xfg(i,j,1) + ycd(i,j,1) = yfg(i,j,4) + ycd(i,j,2) = yfg(i,j,3) + ycd(i,j,3) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,4))*yfg(i,j,1) & + + FLOAT( nfl(i-1,j)*iyb(i-1,j,4))*yfg(i-1,j,4) + istat = istat+1 + END IF + IF (ixb(i,j,3) == 0) THEN + xcd(i,j,1) = xfg(i,j,2) + xcd(i,j,2) = xfg(i,j,4) + xcd(i,j,3) = xfg(i,j,3) + ycd(i,j,1) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,3))*yfg(i,j,2) & + + FLOAT( nfl(i+1,j)*iyb(i+1,j,3))*yfg(i+1,j,3) + ycd(i,j,2) = yfg(i,j,4) + ycd(i,j,3) = yfg(i,j,3) + istat = istat + 1 + END IF + END IF !IT=1 AND 2 + IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 AND 4 + IF (iyb(i,j,1) == 1) THEN + xcd(i,j,1) = xfg(i,j,3) + xcd(i,j,2) = xfg(i,j,1) + xcd(i,j,3) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j,2) & + + FLOAT( nfl(i,j-1)*ixb(i,j-1,3))*xfg(i,j-1,3) + ycd(i,j,1) = yfg(i,j,3) + ycd(i,j,2) = yfg(i,j,1) + ycd(i,j,3) = yfg(i,j,2) + istat = istat + 1 + END IF + IF (iyb(i,j,1) == 0) THEN + xcd(i,j,1) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j,4) & + + FLOAT( nfl(i,j+1)*ixb(i,j+1,1))*xfg(i,j+1,1) + xcd(i,j,2) = xfg(i,j,3) + xcd(i,j,3) = xfg(i,j,1) + ycd(i,j,1) = yfg(i,j,4) + ycd(i,j,2) = yfg(i,j,3) + ycd(i,j,3) = yfg(i,j,1) + istat = istat + 1 + END IF + END IF !IT=2 AND 4 + IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 AND 4 + IF (ixb(i,j,2) == 0) THEN + xcd(i,j,1) = xfg(i,j,3) + xcd(i,j,2) = xfg(i,j,1) + xcd(i,j,3) = xfg(i,j,2) + ycd(i,j,1) = FLOAT(1-nfl(i-1,j)*iyb(i-1,j,2))*yfg(i,j,3) & + + FLOAT( nfl(i-1,j)*iyb(i-1,j,2))*yfg(i-1,j,2) + ycd(i,j,2) = yfg(i,j,1) + ycd(i,j,3) = yfg(i,j,2) + istat = istat + 1 + END IF + IF (ixb(i,j,2) == 1) THEN + xcd(i,j,1) = xfg(i,j,1) + xcd(i,j,2) = xfg(i,j,2) + xcd(i,j,3) = xfg(i,j,4) + ycd(i,j,1) = yfg(i,j,1) + ycd(i,j,2) = yfg(i,j,2) + ycd(i,j,3) = FLOAT(1-nfl(i+1,j)*iyb(i+1,j,1))*yfg(i,j,4) & + + FLOAT( nfl(i+1,j)*iyb(i+1,j,1))*yfg(i+1,j,1) + istat = istat + 1 + END IF + END IF !IT=3 AND 4 + IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 AND 3 + IF (iyb(i,j,2) == 0) THEN + xcd(i,j,1) = xfg(i,j,2) + xcd(i,j,2) = xfg(i,j,4) + xcd(i,j,3) = FLOAT(1-nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j,3) & + + FLOAT( nfl(i,j+1)*ixb(i,j+1,2))*xfg(i,j+1,2) + ycd(i,j,1) = yfg(i,j,2) + ycd(i,j,2) = yfg(i,j,4) + ycd(i,j,3) = yfg(i,j,3) + istat = istat + 1 + END IF + IF (iyb(i,j,2) == 1) THEN + xcd(i,j,1) = FLOAT(1-nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j,1) & + + FLOAT( nfl(i,j-1)*ixb(i,j-1,4))*xfg(i,j-1,4) + xcd(i,j,2) = xfg(i,j,2) + xcd(i,j,3) = xfg(i,j,4) + ycd(i,j,1) = yfg(i,j,1) + ycd(i,j,2) = yfg(i,j,2) + ycd(i,j,3) = yfg(i,j,4) + istat = istat + 1 + END IF + END IF !IT=1 AND 3 + END IF !NCT=2 ICLS=3 + + IF (nct == 1 .AND. icls == 4) THEN !NCT=1 ICLS=4 + ncod(i,j) = 3 + ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + & + 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4)) + ic4 = 10 - ic1 - ic2 - ic3 + iod = ic1 - 2*(ic1/2) + is = 1 - 2*iod + js = -1 + 2*(ic1/3) + isen = is*js + +! -------------------- straight lines for stability + xfg(i,j,ic2) = .5*(xfg(i,j,ic3)+xfg(i,j,ic4)) + yfg(i,j,ic2) = .5*(yfg(i,j,ic3)+yfg(i,j,ic4)) + + it1 = ((1+isen)*ic3+(1-isen)*ic4)/2 + it3 = ((1+isen)*ic4+(1-isen)*ic3)/2 + + xcd(i,j,1) = xfg(i,j,it1) + ycd(i,j,1) = yfg(i,j,it1) + xcd(i,j,2) = xfg(i,j,ic2) + ycd(i,j,2) = yfg(i,j,ic2) + xcd(i,j,3) = xfg(i,j,it3) + ycd(i,j,3) = yfg(i,j,it3) + istat = istat + 1 + END IF !NCT=1 ICLS=4 + + IF (istat /= 1) THEN + IF (area(i,j) > (1.-ep) .AND. istat > 1) THEN + nfl(i,j) = 0 + ELSE + iflt = 2 + PRINT *,'ISTAT=',istat + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + END IF + + END IF !NFL outer loop + + END DO x_cd + END DO y_cd + + write(*,*)'in fire_ln: 7' + +! ----- test prints for missed grids + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + IF (nfl(i,j) == 1 .AND. ncod(i,j) == 0) THEN + iflt = 3 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + END DO + END DO + write(*,*)'in fire_ln: 8' + +! ...CALCULATING INDEX LOCATIONS OF NEIGHBORS +! +! ...This is the most critical loop of the code. If this fails +! the remaining logic will do weird things. This is probably +! the first place to check when problems occur. + +y_in: DO j = jf_st+1,jf_en-1 +x_in: DO i = if_st+1,if_en-1 + + + IF (nfl(i,j) == 1) THEN !NFL=1 loop + + write(*,*)'in fire_ln: 8.1 : ',i,j + nh0 = ncod(i,j) + nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icls = icl(i,j) + + itt = nh0 + t1 = ABS(xcd(i,j,2)) + ABS(ycd(i,j,2)) + IF (nct == 3 .AND. icls == 2 .AND. t1 > .9) itt = 2 + tlx = SIGN(1.,xcd(i,j,itt)) + tly = SIGN(1.,ycd(i,j,itt)) + i2 = i + INT(tlx*1.5) + j2 = j + INT(tly*1.5) + write(*,*)'in fire_ln: 8.1.1 : nh0 = ',nh0 + write(*,*)'in fire_ln: 8.1.2 : nct = ',nct + write(*,*)'in fire_ln: 8.1.3 : icls = ',icls + write(*,*)'in fire_ln: 8.1.4 : itt = ',itt + write(*,*)'in fire_ln: 8.1.5 : i,j = ',i,j + write(*,*)'in fire_ln: 8.1.6 : tlx = ',tlx,tly + write(*,*)'in fire_ln: 8.1.7 : int = ',INT(tlx*1.5),INT(tly*1.5) + write(*,*)'in fire_ln: 8.1.8 : i2,j2 =',i2,j2 + + ihit = 0 + j2tst = j2 + i2tst = i2 + + write(*,*)'in fire_ln: 8.2 : ',i,j + IF (nct == 3 .AND. icls == 1) THEN !test code follows + write(*,*)'in fire_ln: 8.2.1 : ',i,j +! ----- ... looking for anomolous 3/1 situations + ic1 = 1 - icn(i,j,1) + 2*(1-icn(i,j,2)) + 3*(1-icn(i,j,3)) & + + 4*(1-icn(i,j,4)) + t1tst = ABS(xcd(i,j,1) + xcd(i,j,2))*FLOAT(iyb(i,j,ic1)) & + + ABS(ycd(i,j,1) + ycd(i,j,2))*FLOAT(ixb(i,j,ic1)) + IF (t1tst > 1.-ep) THEN + j2tst = j2 + i2tst = i2 + ihit = 1 + IF (nfl(i,j2) == 0 .AND. iyb(i,j,ic1) == 0) THEN + tlx = SIGN(1.,xcd(i,j,2)-xcd(i,j,1)) + i2 = i + INT(tlx*1.5) + END IF + IF (nfl(i2,j) == 0 .AND. ixb(i,j,ic1) == 0) THEN + tly = SIGN(1.,ycd(i,j,2)-ycd(i,j,1)) + j2 = j + INT(tly*1.5) + END IF + END IF + END IF !test code above +! + write(*,*)'in fire_ln: 8.3 : ',i,j + x02 = xcd(i,j2,1) + SIGN(ep,xcd(i,j2,2)-xcd(i,j2,1)) + y02 = ycd(i,j2,1) + SIGN(ep,ycd(i,j2,2)-ycd(i,j2,1)) + x20 = xcd(i2,j,1) + SIGN(ep,xcd(i2,j,2)-xcd(i2,j,1)) + y20 = ycd(i2,j,1) + SIGN(ep,ycd(i2,j,2)-ycd(i2,j,1)) + x22 = xcd(i2,j2,1) + SIGN(ep,xcd(i2,j2,2)-xcd(i2,j2,1)) + y22 = ycd(i2,j2,1) + SIGN(ep,ycd(i2,j2,2)-ycd(i2,j2,1)) + r02 = (xcd(i,j,itt)-x02)**2 + (ycd(i,j,itt)-tly-y02)**2 & + + FLOAT(1-nfl(i,j2)) + r20 = (xcd(i,j,itt)-tlx-x20)**2 + (ycd(i,j,itt)-y20)**2 & + + FLOAT(1-nfl(i2,j)) + r22 = (xcd(i,j,itt)-tlx-x22)**2 + (ycd(i,j,itt)-tly-y22)**2 & + + FLOAT(1-nfl(i2,j2)) + write(*,*)'in fire_ln: 8.3.1 : ',i2,j2 + is = i2 + js = j2 + IF (r02 < r22 .AND. r02 < r20) is = i + IF (r20 < r22 .AND. r20 < r02) js = j + i2 = is + j2 = js + write(*,*)'in fire_ln: 8.3.2 : ',i2,j2 + + itt = 1 + t1 = ABS(xcd(i,j,2)) + ABS(ycd(i,j,2)) + IF (nct == 3 .AND. icls == 2 .AND. t1 > .9) itt = 2 + tlx = SIGN(1.,xcd(i,j,itt)) + tly = SIGN(1.,ycd(i,j,itt)) + i1 = i + INT(tlx*1.5) + j1 = j + INT(tly*1.5) + + j1tst = j1 + i1tst = i1 + write(*,*)'in fire_ln: 8.4 : ',i,j + + IF (nct == 3 .AND. icls == 1) THEN !test code follows + write(*,*)'in fire_ln: 8.4.1 : ',i,j +! ----- ... looking for anomolous 3/1 situations + ic1 = 1 - icn(i,j,1) + 2*(1-icn(i,j,2)) + 3*(1-icn(i,j,3)) & + + 4*(1-icn(i,j,4)) + t1tst = ABS(xcd(i,j,1) + xcd(i,j,2))*FLOAT(iyb(i,j,ic1)) & + + ABS(ycd(i,j,1) + ycd(i,j,2))*FLOAT(ixb(i,j,ic1)) + IF (t1tst > 1.-ep) THEN + j1tst = j1 + i1tst = i1 + ihit = ihit + 2 + if (nfl(i,j1) == 0 .AND. iyb(i,j,ic1) == 0) THEN + tlx = SIGN(1.,xcd(i,j,1)-xcd(i,j,2)) + i1 = i + INT(tlx*1.5) + END IF + IF (nfl(i1,j) == 0 .AND. ixb(i,j,ic1) == 0) THEN + tly = SIGN(1.,ycd(i,j,1)-ycd(i,j,2)) + j1 = j + INT(tly*1.5) + END IF + END IF + END IF !test code above +! + write(*,*)'in fire_ln: 8.5 : ',i,j + write(*,*)'in fire_ln: 8.5.1 : ',i,j + nh11 = nfl(i1,j1)*ncod(i1,j1) + 1 - nfl(i1,j1) + nh01 = nfl(i ,j1)*ncod(i ,j1) + 1 - nfl(i ,j1) + nh10 = nfl(i1, j)*ncod(i1, j) + 1 - nfl(i1, j) + nhtmp = nh01 - nfl(i,j1) + x01 = xcd(i,j1,nh01) + SIGN(ep,xcd(i,j1,nhtmp)-xcd(i,j1,nh01)) + y01 = ycd(i,j1,nh01) + SIGN(ep,ycd(i,j1,nhtmp)-ycd(i,j1,nh01)) + write(*,*)'in fire_ln: 8.5.2 : ',i,j + nhtmp = nh10 - nfl(i1,j) + x10 = xcd(i1,j,nh10) + SIGN(ep,xcd(i1,j,nhtmp)-xcd(i1,j,nh10)) + y10 = ycd(i1,j,nh10) + SIGN(ep,ycd(i1,j,nhtmp)-ycd(i1,j,nh10)) + nhtmp = nh11 - nfl(i1,j1) + x11 = xcd(i1,j1,nh11) + SIGN(ep,xcd(i1,j1,nhtmp)-xcd(i1,j1,nh11)) + y11 = ycd(i1,j1,nh11) + SIGN(ep,ycd(i1,j1,nhtmp)-ycd(i1,j1,nh11)) + r01 = (xcd(i,j,itt)-x01)**2 + (ycd(i,j,itt)-tly-y01)**2 & + + (1.-FLOAT(nfl(i,j1))) + r10 = (xcd(i,j,itt)-tlx-x10)**2 + (ycd(i,j,itt)-y10)**2 & + + (1.-FLOAT(nfl(i1,j))) + r11 = (xcd(i,j,itt)-tlx-x11)**2 + (ycd(i,j,itt)-tly-y11)**2 & + + (1.-FLOAT(nfl(i1,j1))) + write(*,*)'in fire_ln: 8.5.3 : ',i,j + is = i1 + js = j1 + IF (r01 < r11 .AND. r01 < r10) is = i + IF (r10 < r11 .AND. r10 < r01) js = j + i1 = is + j1 = js + write(*,*)'in fire_ln: 8.5.4 : ',i,j +! ----- ... end of evaluation + in1(i,j,1) = i1 + in1(i,j,2) = j1 + in2(i,j,1) = i2 + in2(i,j,2) = j2 + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + nht = nh0 + nh1 + nh2 + + write(*,*)'in fire_ln: 8.5.5 : ',i,j + write(*,*)'in fire_ln: 8.5.5 : ncod(',i1,j1,') = ',ncod(i1,j1),nfl(i1,j1) + write(*,*)'in fire_ln: 8.5.5 : ncod(',i2,j2,') = ',ncod(i2,j2),nfl(i2,j2) + write(*,*)'in fire_ln: 8.5.5 : xcd(',i,j,1,') = ',xcd(i,j,1) + write(*,*)'in fire_ln: 8.5.5 : xcd(',i2,j2,nh2,') = ',xcd(i2,j2,nh2) + write(*,*)'in fire_ln: 8.5.5 : i2-i = ',i2-i + write(*,*)'in fire_ln: 8.5.5 : ycd(',i,j,1,') = ',ycd(i,j,1) + write(*,*)'in fire_ln: 8.5.5 : ycd(',i2,j2,nh2,') = ',ycd(i2,j2,nh2) + write(*,*)'in fire_ln: 8.5.5 : j2-j = ',j2-j + + write(*,*)'in fire_ln: 8.5.5 : xcd(',i,j,nh0,') = ',xcd(i,j,nh0) + write(*,*)'in fire_ln: 8.5.5 : xcd(',i1,j1,1,') = ',xcd(i1,j1,1) + write(*,*)'in fire_ln: 8.5.5 : i1-i = ',i1-i + write(*,*)'in fire_ln: 8.5.5 : ycd(',i,j,nh0,') = ',ycd(i,j,nh0) + write(*,*)'in fire_ln: 8.5.5 : ycd(',i1,j1,1,') = ',ycd(i1,j1,1) + write(*,*)'in fire_ln: 8.5.5 : j1-j = ',j1-j + r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + & + (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2 + r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + & + (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2 + +! IF (nh0 == 0) then +! r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + & +! (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2 +! IF (r2sq < ep_sq) THEN +! iflt = 184 +! CALL fire_error_debug(i,j,iflt, & +! time,in1,in2,tign_g, & +! nfl,ncod,xcd,ycd,xcn,ycn,icn, & +! ixb,iyb,xfg,yfg, & +! ifms,ifme, kfms,kfme, jfms,jfme, & +! if_st,if_en,jf_st,jf_en) +! END IF +! ELSE IF (nh2 == 0) THEN +! r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + & +! (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2 +! IF (r1sq < ep_sq) THEN +! iflt = 185 +! CALL fire_error_debug(i,j,iflt, & +! time,in1,in2,tign_g, & +! nfl,ncod,xcd,ycd,xcn,ycn,icn, & +! ixb,iyb,xfg,yfg, & +! ifms,ifme, kfms,kfme, jfms,jfme, & +! if_st,if_en,jf_st,jf_en) +! END IF +! ELSE +! r2sq = (xcd(i,j,1)-xcd(i2,j2,nh2)-FLOAT(i2-i))**2 + & +! (ycd(i,j,1)-ycd(i2,j2,nh2)-FLOAT(j2-j))**2 +! r1sq = (xcd(i,j,nh0)-xcd(i1,j1,1)-FLOAT(i1-i))**2 + & +! (ycd(i,j,nh0)-ycd(i1,j1,1)-FLOAT(j1-j))**2 +! IF (r1sq < ep_sq .OR. r2sq < ep_sq) THEN +! PRINT *,'DEBUG R1SQ R2SQ=',r1sq,r2sq +! iflt = 84 +! CALL fire_error_debug(i,j,iflt, & +! time,in1,in2,tign_g, & +! nfl,ncod,xcd,ycd,xcn,ycn,icn, & +! ixb,iyb,xfg,yfg, & +! ifms,ifme, kfms,kfme, jfms,jfme, & +! if_st,if_en,jf_st,jf_en) +! +! END IF +! END IF + + write(*,*)'in fire_ln: 8.5.6 : ',i,j + +! IF (r1sq < ep_sq .OR. r2sq < ep_sq) THEN +! PRINT *,'DEBUG R1SQ R2SQ=',r1sq,r2sq +! iflt = 84 +! CALL fire_error_debug(i,j,iflt, & +! time,in1,in2,tign_g, & +! nfl,ncod,xcd,ycd,xcn,ycn,icn, & +! ixb,iyb,xfg,yfg, & +! ifms,ifme, kfms,kfme, jfms,jfme, & +! if_st,if_en,jf_st,jf_en) + +! END IF + + write(*,*)'in fire_ln: 8.6 : ',i,j + IF (i1 < if_st .OR. i1 > if_en .OR. j1 < jf_st .OR. j1 > jf_en) THEN + iflt = 85 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + IF (i2 < if_st .OR. i2 > if_en .OR. j2 < jf_st .OR. j2 > jf_en) THEN + iflt = 87 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + write(*,*)'in fire_ln: 8.7 : ',i,j + ilm1 = IABS(in1(i,j,1)-i) + ilm2 = IABS(in2(i,j,1)-i) + ilm3 = IABS(in1(i,j,2)-j) + ilm4 = IABS(in2(i,j,2)-j) + + write(*,*)'in fire_ln: 8.8 : ',i,j + IF (ilm1 > 1 .OR. ilm2 > 1 .OR. ilm3 > 1 .OR. ilm4 > 1) THEN + iflt = 83 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + IF (i1 == i .AND. j1 == j) THEN + iflt = 4 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + IF (i2 == i .AND. j2 == j) THEN + iflt = 5 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + IF (i2 == i1 .AND. j2 == j1) THEN +! ----- ... fireline brushes corner of 3/1. Odd normal vector pts inwards. + iflt = 6 + PRINT *,'IC1 T1TST=',ic1,t1tst + PRINT *,'IHIT=',ihit + PRINT *,'I1TST J1TST=',i1tst,j1tst + PRINT *,'I2TST J2TST=',i2tst,j2tst + WRITE (msg,*) 'i,i2,i1=',i,i2,i1,' j,j2,j1=',j,j2,j1 + CALL wrf_message( msg ) + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + write(*,*)'in fire_ln: 8.9 : ',i,j + itest = 0 + IF (itest == 0) THEN + + IF (i1 /= in1(i,j,1) .OR. j1 /= in1(i,j,2) .OR. i2 /= in2(i,j,1) & + .OR. j2 /= in2(i,j,2)) THEN + iflt = 80 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + IF (ABS(xcd(i,j,1)) > .5 .OR. ABS(ycd(i,j,1)) > .5) THEN + iflt = 81 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + IF (ABS(xcd(i,j,nh0)) > .5 .OR. ABS(ycd(i,j,nh0)) > .5) THEN + iflt = 82 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + + END IF + write(*,*)'in fire_ln: 8.10 : ',i,j + END IF !NFL=1 LOOP +! + END DO x_in + END DO y_in + + write(*,*)'in fire_ln: 9' +! + radmax = -1.e5 + radmin = 1.e5 + radavg = 0.0 + radsum = 0.0 + radtst = 10000. + +! ...This is the second most critical loop of the code. If this +! fails the remaining logic may fail. This is probably the second +! place to check when problems occur. + +y_cn: DO j = jf_st+1,jf_en-1 +x_cn: DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL=1 LOOP + + nh0 = ncod(i,j) + i1 = in1(i,j,1) + j1 = in1(i,j,2) + i2 = in2(i,j,1) + j2 = in2(i,j,2) + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + +! ----- ...calculate xcn and ycn for points 1,nh0 at grid i,j + + x1 = xcd(i1,j1, 1) + FLOAT(i1-i) + y1 = ycd(i1,j1, 1) + FLOAT(j1-j) + x2 = xcd(i ,j , 1) + y2 = ycd(i ,j , 1) + x3 = xcd(i ,j ,nh0) + y3 = ycd(i ,j ,nh0) + iloc = 0 + + IF (icl(i,j) == 4 .AND. nc(i,j) == 1) THEN + IF (icl(i1,j1) == 4 .AND. nc(i1,j1) == 1) THEN + i3 = in1(i1,j1,1) + j3 = in1(i1,j1,2) +! IF (nfl(i3,j3) == 1) THEN + IF (nfl(i3,j3) == 1 .AND. icl(i3,j3) /= 4) THEN + iloc = 1 + x1 = xcd(i3,j3,1) + FLOAT(i3-i) + y1 = ycd(i3,j3,1) + FLOAT(j3-j) + x2 = xcd(i ,j , 1) + y2 = ycd(i ,j , 1) + x3 = xcd(i2,j2,nh2) + FLOAT(i2-i) + y3 = ycd(i2,j2,nh2) + FLOAT(j2-j) + END IF + END IF + END IF + +! ... test code follows + IF (icl(i,j) == 4 .AND. nc(i,j) == 1 .AND. iloc == 0) THEN + x1 = xcd(i1,j1, 1) + FLOAT(i1-i) + y1 = ycd(i1,j1, 1) + FLOAT(j1-j) + x2 = xcd(i1,j1,nh1) + FLOAT(i1-i) + y2 = ycd(i1,j1,nh1) + FLOAT(j1-j) + x3 = xcd(i2,j2, 1) + FLOAT(i2-i) + y3 = ycd(i2,j2, 1) + FLOAT(j2-j) + END IF +! ... test code above + + xcn(i,j,1) = xcd(i,j,1) + ycn(i,j,1) = ycd(i,j,1) + det = (x1-x2)*(y1-y3) - (x1-x3)*(y1-y2) + aa = .5*(x1*x1 - x2*x2 + y1*y1 - y2*y2) + bb = .5*(x1*x1 - x3*x3 + y1*y1 - y3*y3) + x_0 = (aa*(y1-y3)-bb*(y1-y2)) / (det+SIGN(ep,det)) + y_0 = (bb*(x1-x2)-aa*(x1-x3)) / (det+SIGN(ep,det)) + rad = SQRT((x2-x_0)**2 + (y2-y_0)**2) + IF (rad > 1. .AND. rad < 1000.) THEN !test + vtsgn = (y3-y1)*(x2-x_0) - (x3-x1)*(y2-y_0) + it1 = INT((vtsgn+ABS(vtsgn)) / (ABS(vtsgn)+ep_sq)+.5) - 1 + t1 = FLOAT(it1) + xcn(i,j,1) = xcd(i,j,1) + t1*(x2-x_0)/(rad+ep) + ycn(i,j,1) = ycd(i,j,1) + t1*(y2-y_0)/(rad+ep) + ELSE + rad = SQRT((y3-y1)**2 + (x3-x1)**2) + IF (ABS(rad) < ep) THEN + WRITE (6,*) 'HEY1 START' + WRITE (6,*) 'HEY1 RAD,ILOC',rad,iloc + WRITE (6,*) 'HEY1 I,J,NH0',i,j,nh0 + WRITE (6,*) 'HEY1 I1,J1',i1,j1,nh1 + WRITE (6,*) 'HEY1 R01,R10,R11',r01,r10,r11 + WRITE (6,*) 'HEY1 X1,X2,X3',x1,x2,x3 + WRITE (6,*) 'HEY1 Y1,Y2,Y3',y1,y2,y3 + WRITE (6,*) 'HEY1 XCD(I)=',(xcd(i,j,it),it=1,nh0) + WRITE (6,*) 'HEY1 YCD(I)=',(ycd(i,j,it),it=1,nh0) + WRITE (6,*) 'HEY1 XCD(I1)=',(xcd(i1,j1,it),it=1,nh1) + WRITE (6,*) 'HEY1 YCD(I1)=',(ycd(i1,j1,it),it=1,nh1) + iflt = 111 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + xcn(i,j,1) = xcd(i,j,1) + (y3-y1)/(rad+ep) + ycn(i,j,1) = ycd(i,j,1) - (x3-x1)/(rad+ep) + END IF + + IF (rad < .1 .AND. rad < radtst) THEN + radhld = rad + radtst = rad + ihld = i + jhld = j + END IF + + radmax = MAX(radmax,rad) + radmin = MIN(radmin,rad) + radavg = radavg + rad + radsum = radsum + 1. + + x1 = xcd(i ,j , 1) + y1 = ycd(i ,j , 1) + x2 = xcd(i ,j ,nh0) + y2 = ycd(i ,j ,nh0) + x3 = xcd(i2,j2,nh2) + FLOAT(i2-i) + y3 = ycd(i2,j2,nh2) + FLOAT(j2-j) + iloc = 0 + + IF (icl(i,j) == 4 .AND. nc(i,j) == 1) THEN + IF (icl(i2,j2) == 4 .AND. nc(i2,j2) == 1) THEN + i3 = in2(i2,j2,1) + j3 = in2(i2,j2,2) + nh3 = ncod(i3,j3) +! IF (nfl(i3,j3) == 1) THEN + IF (nfl(i3,j3) == 1 .AND. icl(i3,j3) /= 4) THEN + iloc = 1 + x1 = xcd(i1,j1,1) + FLOAT(i1-i) + y1 = ycd(i1,j1,1) + FLOAT(j1-j) + x2 = xcd(i ,j ,nh0) + y2 = ycd(i ,j ,nh0) + x3 = xcd(i3,j3,nh3) + FLOAT(i3-i) + y3 = ycd(i3,j3,nh3) + FLOAT(j3-j) + END IF + END IF + END IF + +! ... test code follows + IF (icl(i,j) == 4 .AND. nc(i,j) == 1 .AND. iloc == 0) THEN + x1 = xcd(i1,j1,nh1) + FLOAT(i1-i) + y1 = ycd(i1,j1,nh1) + FLOAT(j1-j) + x2 = xcd(i2,j2, 1) + FLOAT(i2-i) + y2 = ycd(i2,j2, 1) + FLOAT(j2-j) + x3 = xcd(i2,j2,nh2) + FLOAT(i2-i) + y3 = ycd(i2,j2,nh2) + FLOAT(j2-j) + END IF +! ... test code above + + xcn(i,j,nh0) = xcd(i,j,nh0) + ycn(i,j,nh0) = ycd(i,j,nh0) + det = (x1-x2)*(y1-y3) - (x1-x3)*(y1-y2) + aa = .5*(x1*x1 - x2*x2 + y1*y1 - y2*y2) + bb = .5*(x1*x1 - x3*x3 + y1*y1 - y3*y3) + x_0 = (aa*(y1-y3) - bb*(y1-y2)) / (det + SIGN(ep,det)) + y_0 = (bb*(x1-x2) - aa*(x1-x3)) / (det + SIGN(ep,det)) + rad = SQRT((x2-x_0)**2 + (y2-y_0)**2) + + IF (rad > 1. .AND. rad < 1000.) THEN !test + vtsgn = (y3-y1)*(x2-x_0) - (x3-x1)*(y2-y_0) + it1 = INT((vtsgn+ABS(vtsgn)) / (ABS(vtsgn)+ep_sq)+.5) - 1 + t1 = FLOAT(it1) + xcn(i,j,nh0) = xcd(i,j,nh0) + t1*(x2-x_0)/(rad+ep) + ycn(i,j,nh0) = ycd(i,j,nh0) + t1*(y2-y_0)/(rad+ep) + ELSE + rad = SQRT((y3-y1)**2 + (x3-x1)**2) + IF (abs(rad) < ep) THEN + WRITE (6,*) 'HEY2 START' + WRITE (6,*) 'HEY2 RAD,ILOC',rad,iloc + WRITE (6,*) 'HEY2 I,J,NH0',i,j,nh0 + WRITE (6,*) 'HEY2 I2,J2,NH2',i2,j2,nh2 + WRITE (6,*) 'HEY2 R02,R20,R22',r02,r20,r22 + WRITE (6,*) 'HEY2 X1,X2,X3',x1,x2,x3 + WRITE (6,*) 'HEY2 Y1,Y2,Y3',y1,y2,y3 + WRITE (6,*) 'HEY2 XCD(I)=',(xcd(i,j,it),it=1,nh0) + WRITE (6,*) 'HEY2 YCD(I)=',(ycd(i,j,it),it=1,nh0) + WRITE (6,*) 'HEY2 XCD(I2)=',(xcd(i2,j2,it),it=1,nh2) + WRITE (6,*) 'HEY2 YCD(I2)=',(ycd(i2,j2,it),it=1,nh2) + iflt = 112 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + xcn(i,j,nh0) = xcd(i,j,nh0) + (y3-y1)/(rad+ep) + ycn(i,j,nh0) = ycd(i,j,nh0) - (x3-x1)/(rad+ep) + END IF + IF (rad < .1 .AND. rad < radtst) THEN + radhld = rad + radtst = rad + ihld = i + jhld = j + END IF + + IF (nh0 == 3) THEN + x1 = xcd(i,j,1) + y1 = ycd(i,j,1) + x3 = xcd(i,j,3) + y3 = ycd(i,j,3) + rad = SQRT((y3-y1)**2 + (x3-x1)**2) + IF (ABS(rad) < ep) THEN + WRITE (6,*) 'HEY3 I,J,RAD,Y1,Y2,Y3,X1,X2,X3', & + i,j,rad,y1,y2,y3,x1,x2,x3 + iflt = 113 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + xcn(i,j,2) = xcd(i,j,2) + (y3-y1)/(rad+ep) + ycn(i,j,2) = ycd(i,j,2) - (x3-x1)/(rad+ep) + END IF + END IF !NFL=1 LOOP + + END DO x_cn + END DO y_cn + + write(*,*)'in fire_ln: 10' + IF (ABS(radsum) > ep_sq) THEN + radavg = radavg/radsum + PRINT *,'RADMAX MIN AVG SUM',radmax,radmin,radavg,radsum + ELSE + PRINT *,'RADMAX MIN SUM, CANT CALC RADAVG',radmax,radmin,radsum + END IF + write(*,*)'in fire_ln: 11' + + RETURN + +END SUBROUTINE fire_ln + +! ========================================================================= + +SUBROUTINE fire_tr(dt,ibeh,nfuel_cat,ncod,nfl,zf,zsf,zs, & ! incoming + sfcu,sfcv,xcd,ycd,bbb,phiwc,betafl,r_0, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + xcn,ycn, & ! inout + sprdx,sprdy) ! outgoing + +! -------------------------------------------------------------------- +! this routine advects fire line coordinates after fire_ln call +! all xcd ycd xcn and ycn points are calculated and used to +! calculate local velocities and spread rates +! -------------------------------------------------------------------- + + USE module_fr_cawfe_fuel + + IMPLICIT NONE + +! ------ incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in) :: ibeh + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod,nfl + + REAL, INTENT(in) :: dt + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme,6 ) :: sfcu,sfcv + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: zf,zsf + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: bbb,phiwc,betafl,r_0 + +! ------ inout variables + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + +! ------ outgoing variables + + REAL, INTENT(out), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + +! ------ local variables + + INTEGER :: i,j + INTEGER :: it,itm + INTEGER :: ks,ksp + INTEGER :: ib,jb + + REAL :: tirx,tiry + REAL :: tspmax,tspmin + REAL :: epx,epy,epz + REAL :: t1 + REAL :: dlx,dly,dl + REAL :: x,y + REAL :: tib,tjb + REAL :: uu,vv + REAL :: zs1,zs2 + REAL :: tanphi,speed + REAL :: ss + REAL :: fuel_hgt + + REAL, PARAMETER :: dist = 2. ! distance behind fire line in the + ! direction of the normal vector that + ! winds are taken to advect fire. + ! terrain slope taken to be the + ! difference between the elevation at + ! the fire line and the elevation twice + ! this distance from the fire line in + ! the direction of the normal vector. + + CHARACTER(LEN=80) :: msg + +! when deriving fireline coordinates we always keep the fire to our left + + tirx = 1. / FLOAT(nfrx) + tiry = 1. / FLOAT(nfry) + +! ... SFCU and SFCV are positioned such that vertical index=1 means +! they are at the surface (2) means one grid point above the surface. + + tspmax = 0.0 + tspmin = 1000.0 + + DO j = jf_st,jf_en + DO i = if_st,if_en + +! --- get integer height of fuel + + fuel_hgt = 1. + fueldepthm(nfuel_cat(i,j)) / (zf(i,j)-zsf(i,j)) + + ks = INT( fuel_hgt ) + ksp = ks+1 ! test! + epz = fuel_hgt - FLOAT(ks) ! test! + +! --- zero out some debug + + DO it = 1,4 + sprdx(i,j,it) = 0.0 + sprdy(i,j,it) = 0.0 + END DO + + itm = ncod(i,j) + + IF (nfl(i,j).eq.1) THEN !NFL bypass + + DO it = 1,itm + + ! -- the Don Latham change follows - jury is still out + + dlx = (xcn(i,j,it)-xcd(i,j,it)) * dxf + dly = (ycn(i,j,it)-ycd(i,j,it)) * dyf + + ! --- find winds at the specified distance behind the fire line. + ! note that ib, jb are atmospheric grid coords. (where + ! zs is defined), not fuel cell grid coords. + + t1 = dist / SQRT( dlx**2 + dly**2 ) + x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1 + y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1 + tib = 1. + (FLOAT(i)-1.5+x)*tirx + tjb = 1. + (FLOAT(j)-1.5+y)*tiry + ib = INT(tib) + jb = INT(tjb) + epx = tib - FLOAT(ib) + epy = tjb - FLOAT(jb) + + uu = (1.-epz)*( & + (1.-epy)*((1.-epx)*sfcu(ib ,jb ,ks) & + + epx *sfcu(ib+1,jb ,ks)) & + + epy*((1.-epx)*sfcu(ib ,jb+1,ks) & + + epx *sfcu(ib+1,jb+1,ks))) & + + epz *( & + (1.-epy)*((1.-epx)*sfcu(ib ,jb ,ksp) & + + epx *sfcu(ib+1,jb ,ksp)) & + + epy*((1.-epx)*sfcu(ib ,jb+1,ksp) & + + epx *sfcu(ib+1,jb+1,ksp))) + + vv = (1.-epz)*( & + (1.-epy)*((1.-epx)*sfcv(ib ,jb ,ks) & + + epx *sfcv(ib+1,jb ,ks)) & + + epy*((1.-epx)*sfcv(ib ,jb+1,ks) & + + epx *sfcv(ib+1,jb+1,ks))) & + + epz *( & + (1.-epy)*((1.-epx)*sfcv(ib ,jb ,ksp) & + + epx *sfcv(ib+1,jb ,ksp)) & + + epy*((1.-epx)*sfcv(ib ,jb+1,ksp) & + + epx *sfcv(ib+1,jb+1,ksp))) + + ! --- find elevation at the fire line for this particle. + + t1 = 0.0 + x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1 + y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1 + tib = 1.5 + (FLOAT(i)-1.5+x)*tirx + tjb = 1.5 + (FLOAT(j)-1.5+y)*tiry + ib = INT(tib) + jb = INT(tjb) + epx = tib - FLOAT(ib) + epy = tjb - FLOAT(jb) + + zs1 = (1.-epy)*((1.-epx)*zs(ib,jb ) + epx*zs(ib+1,jb)) & + + epy*((1.-epx)*zs(ib,jb+1) + epx*zs(ib+1,jb+1)) + + ! --- find elevation at twice the specified distance behind + ! the fire line in the direction of the normal vector + + t1 = (2.*dist) / SQRT(dlx**2 + dly**2) + x = xcd(i,j,it) - (xcn(i,j,it)-xcd(i,j,it))*t1 + y = ycd(i,j,it) - (ycn(i,j,it)-ycd(i,j,it))*t1 + + tib = 1.5 + (FLOAT(i)-1.5+x)*tirx + tjb = 1.5 + (FLOAT(j)-1.5+y)*tiry + ib = INT(tib) + jb = INT(tjb) + epx = tib - FLOAT(ib) + epy = tjb - FLOAT(jb) + + zs2 = (1.-epy)*((1.-epx)*zs(ib,jb ) + epx*zs(ib+1,jb)) & + + epy*((1.-epx)*zs(ib,jb+1) + epx*zs(ib+1,jb+1)) + + ! --- calculate tangent of terrain slope in direction of spread. + + tanphi = (zs1-zs2) / (2.*dist) + PRINT *,'debug ZS1 ZS2 TANPHI=',zs1,zs2,tanphi + + ! --- calculate wind speed in direction of spread. + + dlx = (xcn(i,j,it)-xcd(i,j,it)) + dly = (ycn(i,j,it)-ycd(i,j,it)) + dlx = dlx + SIGN(ep,dlx) + dly = dly + SIGN(ep,dly) + dl = SQRT(dlx**2 + dly**2) + t1 = 1./dl + + speed = t1*(uu*dlx + vv*dly) + +! fuelloadm = (1.-bmst) * fgi(nfuel_cat(i,j)) ! fueload w/out moisture + + ! --- calculate fire's rate of spread + + CALL fire_ros( i,j, & ! send + ifms,ifme, kfms,kfme, jfms,jfme, & + speed,tanphi,ibeh,nfuel_cat, & + bbb,phiwc,betafl,r_0, & + ss) ! recv + + ! --- get new non-dimensional distance according to spread rate + + dlx = t1 * dlx * ss * dt / dxf + dly = t1 * dly * ss * dt / dyf + + ! --- some debug + + tspmax = MAX(ss,tspmax) + tspmin = MIN(ss,tspmin) + sprdx(i,j,it) = dxf * dlx / dt + sprdy(i,j,it) = dyf * dly / dt + + ! --- update normal vector's locations + + xcn(i,j,it) = xcd(i,j,it) + dlx + ycn(i,j,it) = ycd(i,j,it) + dly + + END DO + END IF !NFL bypass + END DO + END DO + + WRITE(msg,21) tspmax, tspmin +21 FORMAT(1x,'MAX/MIN SPREAD RATE (m/s)=',2(1x,f10.5)) + CALL wrf_message( msg ) + + RETURN + +END SUBROUTINE fire_tr + +! ========================================================================= + +SUBROUTINE fire_ds(ixb,iyb,icn,nfl,ncod,in1,in2, & ! incoming + time,xcn,ycn,xcd,ycd, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + xfg,yfg,tign_g) ! inout + +! --------------------------------------------------------------------- +! This routine assigns quadrilateral grid positions using the +! new XCN and YCN positions. New cell ignitions are also treated. +! +! First we calculate XFG,YFG using linear extrapolation. This +! can result in different values at the same equivalent point +! for neighboring grids. (Curvature effect). This will be corrected +! in last loop of this routine. +! --------------------------------------------------------------------- + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + + REAL, INTENT(in) :: time + + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + +! ----- inout variables + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g + +! ----- local variables + + INTEGER :: i,j + INTEGER :: nct,icls + INTEGER :: i1,i2 + INTEGER :: j1,j2 + INTEGER :: nh0,nh1,nh2,nht + INTEGER :: ic1,ic2,ic3,ic4 + INTEGER :: iod + INTEGER :: is,js + INTEGER :: isen + INTEGER :: iia3,iib3,iic3,iid3,iit + INTEGER :: jja4,jjb4,jjc4,jjd4,jjt + INTEGER :: iflt + + INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl + + REAL :: dlx,dly + REAL :: dxx,dyy + REAL :: x1,x2,x3,x4,x5,x6,x7 + REAL :: y1,y2,y3,y4,y5,y6,y7 + REAL :: xfg_a3,xfg_b3,xfg_c3,xfg_d3 + REAL :: yfg_a4,yfg_b4,yfg_c4,yfg_d4 + REAL :: xfg_ic3,yfg_ic4 + REAL :: tia3,tib3,tic3,tid3 + REAL :: tja4,tjb4,tjc4,tjd4 + +! when deriving fireline coordinates we always keep the fire to our left + + DO j = jf_st,jf_en + DO i = if_st,if_en + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + END DO + END DO +! +yl: DO j = jf_st+1,jf_en-1 +xl: DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !NFL outer loop + + nct = nc(i,j) + icls = icl(i,j) + nh0 = ncod(i,j) + i1 = in1(i,j,1) + j1 = in1(i,j,2) + i2 = in2(i,j,1) + j2 = in2(i,j,2) + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + nht = nh0 + nh1 + nh2 + + dly = (xcn(i,j,2)-xcn(i,j,1))/ & + (ycn(i,j,2)-ycn(i,j,1)+SIGN(ep,ycn(i,j,2)-ycn(i,j,1))) + dlx = (ycn(i,j,2)-ycn(i,j,1))/ & + (xcn(i,j,2)-xcn(i,j,1)+SIGN(ep,xcn(i,j,2)-xcn(i,j,1))) + + IF (nct == 3 .AND. icls == 1) THEN !NCT=3 and ICLS=1 NCOD=2 + + ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4) + + IF (ic1 == 1) THEN + IF (ixb(i,j,ic1) == 1) THEN + dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1) + dxx = MIN(0.0,dxx) + xfg(i,j,ic1) = xfg(i,j,ic1) + dxx + END IF + IF (ixb(i,j,ic1) == 0) THEN + dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1) + dyy = MIN(0.0,dyy) + yfg(i,j,ic1) = yfg(i,j,ic1) + dyy + END IF + END IF + + IF (ic1 == 2) THEN + IF (ixb(i,j,ic1) == 1) THEN + dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1) + dxx = MAX(0.0,dxx) + xfg(i,j,ic1) = xfg(i,j,ic1) + dxx + END IF + IF (ixb(i,j,ic1) == 0) THEN + dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1) + dyy = MIN(0.0,dyy) + yfg(i,j,ic1) = yfg(i,j,ic1) + dyy + END IF + END IF + + IF (ic1 == 3) THEN + IF (ixb(i,j,ic1) == 1) THEN + dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1) + dxx = MIN(0.0,dxx) + xfg(i,j,ic1) = xfg(i,j,ic1) + dxx + END IF + IF (ixb(i,j,ic1) == 0) THEN + dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1) + dyy = MAX(0.0,dyy) + yfg(i,j,ic1) = yfg(i,j,ic1) + dyy + END IF + END IF + + IF (ic1 == 4) THEN + IF (ixb(i,j,ic1) == 1) THEN + dxx = xcn(i,j,1) + (ylm(ic1)-ycn(i,j,1))*dly - xfg(i,j,ic1) + dxx = MAX(0.0,dxx) + xfg(i,j,ic1) = xfg(i,j,ic1) + dxx + END IF + IF (ixb(i,j,ic1) == 0) THEN + dyy = ycn(i,j,1) + (xlm(ic1)-xcn(i,j,1))*dlx - yfg(i,j,ic1) + dyy = MAX(0.0,dyy) + yfg(i,j,ic1) = yfg(i,j,ic1) + dyy + END IF + END IF + + IF (ABS(xfg(i,j,ic1)+xlm(ic1)) > 1.) xfg(i,j,ic1) = xlm(ic1) + IF (ABS(yfg(i,j,ic1)+ylm(ic1)) > 1.) yfg(i,j,ic1) = ylm(ic1) + + END IF !NCT=3 and ICLS=1 + + IF (nct == 3 .AND. icls == 2) THEN !NCT=3 and ICLS=2 NCOD=3 + ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4) + yfg(i,j,ic1) = ycn(i,j,2) + xfg(i,j,ic1) = xcn(i,j,2) + IF (ABS(xfg(i,j,ic1)+xlm(ic1)) > 1.) xfg(i,j,ic1) = xlm(ic1) + IF (ABS(yfg(i,j,ic1)+ylm(ic1)) > 1.) yfg(i,j,ic1) = ylm(ic1) + END IF !NCT=3 and ICLS=2 + + IF (nct == 2 .AND. icls == 2) THEN !NCT=2 ICLS=2 NCOD=2 + + IF (icn(i,j,1)+icn(i,j,2) == 2) THEN !IT=1 and 2 + xfg(i,j,3) = xlm(3) + xfg(i,j,4) = xlm(4) + yfg(i,j,3) = (ycn(i,j,1)+(xlm(3)-xcn(i,j,1))*dlx) + yfg(i,j,4) = (ycn(i,j,1)+(xlm(4)-xcn(i,j,1))*dlx) + IF (ABS(yfg(i,j,3)+ylm(3)) > 1.) yfg(i,j,3) = ylm(3) + IF (ABS(yfg(i,j,4)+ylm(4)) > 1.) yfg(i,j,4) = ylm(4) + END IF !IT=1 and 2 + + IF (icn(i,j,3)+icn(i,j,4) == 2) THEN !IT=3 and 4 + xfg(i,j,1) = xlm(1) + xfg(i,j,2) = xlm(2) + yfg(i,j,1) = (ycn(i,j,1)+(xlm(1)-xcn(i,j,1))*dlx) + yfg(i,j,2) = (ycn(i,j,1)+(xlm(2)-xcn(i,j,1))*dlx) + IF (ABS(yfg(i,j,1)+ylm(1)) > 1.) yfg(i,j,1) = ylm(1) + IF (ABS(yfg(i,j,2)+ylm(2)) > 1.) yfg(i,j,2) = ylm(2) + END IF !IT=3 and 4 + + IF (icn(i,j,2)+icn(i,j,4) == 2) THEN !IT=2 and 4 + yfg(i,j,1) = ylm(1) + yfg(i,j,3) = ylm(3) + xfg(i,j,1) = (xcn(i,j,1)+(ylm(1)-ycn(i,j,1))*dly) + xfg(i,j,3) = (xcn(i,j,1)+(ylm(3)-ycn(i,j,1))*dly) + IF (ABS(xfg(i,j,1)+xlm(1)) > 1.) xfg(i,j,1) = xlm(1) + IF (ABS(xfg(i,j,3)+xlm(3)) > 1.) xfg(i,j,3) = xlm(3) + END IF !IT=2 and 4 + + IF (icn(i,j,1)+icn(i,j,3) == 2) THEN !IT=1 and 3 + yfg(i,j,2) = ylm(2) + yfg(i,j,4) = ylm(4) + xfg(i,j,2) = (xcn(i,j,1)+(ylm(2)-ycn(i,j,1))*dly) + xfg(i,j,4) = (xcn(i,j,1)+(ylm(4)-ycn(i,j,1))*dly) + IF (ABS(xfg(i,j,2)+xlm(2)) > 1.) xfg(i,j,2) = xlm(2) + IF (ABS(xfg(i,j,4)+xlm(4)) > 1.) xfg(i,j,4) = xlm(4) + END IF !IT=1 and 3 + + END IF !NCT=2 ICLS=2 + + IF (nct == 1 .AND. icls == 4) THEN !NCT=1 ICLS=4 NCOD=3 +! debug section + ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + & + 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4)) + ic4 = 10 - ic1 - ic2 - ic3 +! WRITE (6,*) 'ic1,ic2,ic3,ic4=',ic1,ic2,ic3,ic4 + iod = ic1 - 2*(ic1/2) + is = 1 - 2*iod + js = -1 + 2*(ic1/3) + isen = is*js +! WRITE (6,*) 'iod,is,js,isen=',iod,is,js,isen + + x1 = xcn(i2,j2,2) + float(i2-i) + y1 = ycn(i2,j2,2) + float(j2-j) + x2 = xcn(i2,j2,1) + float(i2-i) + y2 = ycn(i2,j2,1) + float(j2-j) + x3 = xcn(i,j,2+isen) + y3 = ycn(i,j,2+isen) + x4 = xcn(i,j,2) + y4 = ycn(i,j,2) + x5 = xcn(i,j,2-isen) + y5 = ycn(i,j,2-isen) + x6 = xcn(i1,j1,nh1) + FLOAT(i1-i) + y6 = ycn(i1,j1,nh1) + FLOAT(j1-j) + x7 = xcn(i1,j1,nh1-1) + FLOAT(i1-i) + y7 = ycn(i1,j1,nh1-1) + FLOAT(j1-j) + IF (isen == -1) THEN + x1 = xcn(i1,j1,nh1-1) + FLOAT(i1-i) + y1 = ycn(i1,j1,nh1-1) + FLOAT(j1-j) + x2 = xcn(i1,j1,nh1) + FLOAT(i1-i) + y2 = ycn(i1,j1,nh1) + FLOAT(j1-j) + x6 = xcn(i2,j2,1) + FLOAT(i2-i) + y6 = ycn(i2,j2,1) + FLOAT(j2-j) + x7 = xcn(i2,j2,2) + FLOAT(i2-i) + y7 = ycn(i2,j2,2) + FLOAT(j2-j) +! WRITE (6,*) 'ad: x1,x2,x3,x4,x5,x6,x7=',x1,x2,x3,x4,x5,x6,x7 +! WRITE (6,*) 'ad: y1,y2,y3,y4,y5,y6,y7=',y1,y2,y3,y4,y5,y6,y7 + END IF + +! ----- first choice + xfg_a3 = x7 + (ylm(ic3)-y7)*(x4-x7)/(y4-y7+SIGN(ep,y4-y7)) + yfg_a4 = y1 + (xlm(ic4)-x1)*(y4-y1)/(x4-x1+SIGN(ep,x4-x1)) + +! ----- second choice + xfg_b3 = x7 + (ylm(ic3)-y7)*(x6-x7)/(y6-y7+SIGN(ep,y6-y7)) + yfg_b4 = y1 + (xlm(ic4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + +! ----- third choice + xfg_c3 = x5 + (ylm(ic3)-y5)*(x4-x5)/(y4-y5+SIGN(ep,y4-y5)) + yfg_c4 = y3 + (xlm(ic4)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3)) + +! ----- fourth choice + xfg_d3 = x5 + yfg_d4 = y3 + +! WRITE (6,*) '1st choice xfg_a3, yfg_a4=',xfg_a3, yfg_a4 +! WRITE (6,*) '2nd choice xfg_b3, yfg_b4=',xfg_b3, yfg_b4 +! WRITE (6,*) '3nd choice xfg_c3, yfg_c4=',xfg_c3, yfg_c4 +! WRITE (6,*) '4th choice xfg_d3, yfg_d4=',xfg_d3, yfg_d4 + +! ----- test constraints +! tia3 = ((xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) & +! + ABS((xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive +! tib3 = ((xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) & +! + ABS((xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive +! tic3 = ((xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) & +! + ABS((xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive +! tid3 = ((xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) & +! + ABS((xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)))) !must be positive +! +! iia3 = INT((tia3+ABS(tia3))/(2.*ABS(tia3)+ep)+.5) +! iib3 = INT((tib3+ABS(tib3))/(2.*ABS(tib3)+ep)+.5) +! iic3 = INT((tic3+ABS(tic3))/(2.*ABS(tic3)+ep)+.5) +! iid3 = INT((tid3+ABS(tid3))/(2.*ABS(tid3)+ep)+.5) + + iia3 = 0 + iib3 = 0 + iic3 = 0 + iid3 = 0 + + IF ( (xfg_a3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iia3 = 1 + IF ( (xfg_b3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iib3 = 1 + IF ( (xfg_c3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iic3 = 1 + IF ( (xfg_d3-xfg(i,j,ic3))*(xlm(ic3)-xlm(ic1)) >= -ep) iid3 = 1 + + iib3 = (1-iia3)*iib3 + iic3 = (1-iia3)*(1-iib3)*iic3 + iid3 = (1-iia3)*(1-iib3)*(1-iic3)*iid3 + iit = iia3 + iib3 + iic3 + iid3 + +! tja4 = ((yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) & +! + ABS((yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive +! tjb4 = ((yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) & +! + ABS((yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive +! tjc4 = ((yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) & +! + ABS((yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive +! tjd4 = ((yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) & +! + ABS((yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)))) !must be positive +! jja4 = INT((tja4+ABS(tja4))/(2.*ABS(tja4)+ep)+.5) +! jjb4 = INT((tjb4+ABS(tjb4))/(2.*ABS(tjb4)+ep)+.5) +! jjc4 = INT((tjc4+ABS(tjc4))/(2.*ABS(tjc4)+ep)+.5) +! jjd4 = INT((tjd4+ABS(tjd4))/(2.*ABS(tjd4)+ep)+.5) + + jja4 = 0 + jjb4 = 0 + jjc4 = 0 + jjd4 = 0 + + IF ( (yfg_a4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jja4 = 1 + IF ( (yfg_b4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjb4 = 1 + IF ( (yfg_c4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjc4 = 1 + IF ( (yfg_d4-yfg(i,j,ic4))*(ylm(ic4)-ylm(ic1)) >= -ep) jjd4 = 1 + + jjb4 = (1-jja4)*jjb4 + jjc4 = (1-jja4)*(1-jjb4)*jjc4 + jjd4 = (1-jja4)*(1-jjb4)*(1-jjc4)*jjd4 + jjt = jja4 + jjb4 + jjc4 + jjd4 + + IF (iit*jjt == 0) THEN + iflt = 884 + PRINT *,'IC1 2 3 4=',ic1,ic2,ic3,ic4 + PRINT *,'XFG_A YFG_A=',xfg_a3,yfg_a4 + PRINT *,'XFG_B YFG_B=',xfg_b3,yfg_b4 + PRINT *,'XFG_C YFG_C=',xfg_c3,yfg_c4 + PRINT *,'XFG_D YFG_D=',xfg_d3,yfg_d4 + PRINT *,'TIA3 TJA4=',tia3,tja4 + PRINT *,'TIB3 TJB4=',tib3,tjb4 + PRINT *,'TIC3 TJC4=',tic3,tjc4 + PRINT *,'TID3 TJD4=',tid3,tjd4 + PRINT *,'IIA3 JJA4=',iia3,jja4 + PRINT *,'IIB3 JJB4=',iib3,jjb4 + PRINT *,'IIC3 JJC4=',iic3,jjc4 + PRINT *,'IID3 JJD4=',iid3,jjd4 + + WRITE (6,*) 'debug: iit,jjt=',iit,jjt + WRITE (6,*) 'debug:IIT=IIA3+IIB3+IIC3+IID3',iit,iia3,iib3,iic3,iid3 + WRITE (6,*) 'debug:JJT=JJA4+JJB4+JJC4+JJD4',jjt,jja4,jjb4,jjc4,jjd4 + + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + + END IF + + xfg_ic3 = (FLOAT(iia3)*xfg_a3 + FLOAT(iib3)*xfg_b3 + & + FLOAT(iic3)*xfg_c3 + FLOAT(iid3)*xfg_d3) & + /(FLOAT(iia3+iib3+iic3+iid3)+ep) + yfg_ic4 = (FLOAT(jja4)*yfg_a4 + FLOAT(jjb4)*yfg_b4 + & + FLOAT(jjc4)*yfg_c4 + FLOAT(jjd4)*yfg_d4) & + /(FLOAT(jja4+jjb4+jjc4+jjd4)+ep) + + xfg(i,j,ic3) = xfg_ic3 + yfg(i,j,ic3) = ylm(ic3) + xfg(i,j,ic4) = xlm(ic4) + yfg(i,j,ic4) = yfg_ic4 + xfg(i,j,ic2) = xcn(i,j,2) + yfg(i,j,ic2) = ycn(i,j,2) + + IF (ABS(xfg(i,j,ic3)+xlm(ic3)) > 1.) xfg(i,j,ic3) = xlm(ic3) + IF (ABS(yfg(i,j,ic4)+ylm(ic4)) > 1.) yfg(i,j,ic4) = ylm(ic4) + IF (ABS(xfg(i,j,ic2)+xlm(ic2)) > 1.) xfg(i,j,ic2) = xlm(ic2) + IF (ABS(yfg(i,j,ic2)+ylm(ic2)) > 1.) yfg(i,j,ic2) = ylm(ic2) + + IF (ABS(xfg(i,j,ic3)) > .5+ep .OR. ABS(yfg(i,j,ic4)) > .5+ep) THEN + iflt = 885 + PRINT *,'IC1 2 3 4=',ic1,ic2,ic3,ic4 + PRINT *,'XFG_A YFG_A=',xfg_a3,yfg_a4 + PRINT *,'XFG_B YFG_B=',xfg_b3,yfg_b4 + PRINT *,'XFG_C YFG_C=',xfg_c3,yfg_c4 + PRINT *,'XFG_D YFG_D=',xfg_d3,yfg_d4 + PRINT *,'TIA3 TJA4=',tia3,tja4 + PRINT *,'TIB3 TJB4=',tib3,tjb4 + PRINT *,'TIC3 TJC4=',tic3,tjc4 + PRINT *,'TID3 TJD4=',tid3,tjd4 + PRINT *,'IIA3 JJA4=',iia3,jja4 + PRINT *,'IIB3 JJB4=',iib3,jjb4 + PRINT *,'IIC3 JJC4=',iic3,jjc4 + PRINT *,'IID3 JJD4=',iid3,jjd4 + + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + + END IF + + END IF !NCT=1 ICLS=4 + + END IF !NFL outer loop + END DO xl + END DO yl + + RETURN + +END SUBROUTINE fire_ds + +! ========================================================================= + +SUBROUTINE fire_igs(ixb,iyb,icn,in1,in2,ncod,time, & ! incoming + xcn,ycn,zs,xcd,ycd,sprdx,sprdy, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + nfl,tign_g,xfg,yfg) ! inout + +! ------------------------------------------------------------------------- +! This routine treats new ignitions and the initialization of new grids +! using the XCN and YCN positions. It preserves symmetry and stability by +! first interogating all ignitors for all cells to be ignited. +! +! IX is I index of new ignition grid +! LY is L index of new ignition grid +! ------------------------------------------------------------------------- + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: ncod + + REAL, INTENT(in) :: time + + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: sprdx,sprdy + +! ----- inout variables + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ----- local variables + + INTEGER :: i,j + INTEGER :: is,js + INTEGER :: ip,jp + INTEGER :: i1,i2 + INTEGER :: j1,j2 + INTEGER :: nh0,nh1,nh2 + INTEGER :: ix1,ix2,ix3 + INTEGER :: iy1,iy2,iy3 + INTEGER :: jy1,jy2,jy3 + INTEGER :: ixsum,jysum,isum,isumc + INTEGER :: nct,icls + INTEGER :: is12,is34,is13,is24 + INTEGER :: ic1,ic2,ic3,ic4 + INTEGER :: iod,isen + INTEGER :: ihita,ihitb + INTEGER :: ia4,ja4 + INTEGER :: ia6,ja6 + INTEGER :: ib1,jb1 + INTEGER :: ib3,jb3 + + INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl + INTEGER, DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ist + + REAL :: dlx,dly + REAL :: xfg_1,yfg_1 + REAL :: xfg_2,yfg_2 + REAL :: xfg_3,yfg_3 + REAL :: xfg_4,yfg_4 + REAL :: x1,x2,x3,x4,x5,x6,x7 + REAL :: y1,y2,y3,y4,y5,y6,y7 + REAL :: xfga,yfga + REAL :: xfgb,yfgb + REAL :: tx,ty + REAL :: txa,tya + REAL :: txb,tyb + REAL :: xfg_ic1,yfg_ic1 + REAL :: xfg_a,yfg_a + REAL :: xfg_b,yfg_b + REAL :: xfg_a4,yfg_a4 + REAL :: xfg_a6,yfg_a6 + REAL :: xfg_b1,yfg_b1 + REAL :: xfg_b3,yfg_b3 + REAL :: ti1,ti2,ti3,tia4,tia6,tib1,tib3 + REAL :: tj1,tj2,tj3,tja4,tja6,tjb1,tjb3 + + CHARACTER (LEN=256) :: msg + +! ----- when deriving fireline coordinates we always keep the fire to our left + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + END DO + END DO + +! ----- preprocessing for loop 2 + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN + + i1 = in1(i,j,1) + j1 = in1(i,j,2) + i2 = in2(i,j,1) + j2 = in2(i,j,2) + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + nh0 = ncod(i,j) + ix1 = i + INT(2.*xcn(i,j,1)) + ix2 = i + INT(2.*xcn(i,j,2)) + ix3 = i + INT(2.*xcn(i,j,nh0)) + jy1 = j + INT(2.*ycn(i,j,1)) + jy2 = j + INT(2.*ycn(i,j,2)) + jy3 = j + INT(2.*ycn(i,j,nh0)) + ixsum = ix1 + ix2 + ix3 - 3*i + jysum = jy1 + jy2 + jy3 - 3*j + isum = IABS(ixsum) + IABS(jysum) + nct = nc(i,j) + icls = icl(i,j) + + is12 = 0 + is34 = 0 + is13 = 0 + is24 = 0 + IF (isum > 0) THEN + IF((nct == 2 .AND. icls == 2) .OR. (nct == 4 .AND. icls == 0)) THEN + IF (icn(i,j,1)+icn(i,j,2) == 2 .AND. jysum > 0 & + .AND. nfl(i,j+1) /= 1 .AND. tign_g(i,j+1) < -10.) is12 = 1 + IF (icn(i,j,3)+icn(i,j,4) == 2 .AND. jysum < 0 & + .AND. nfl(i,j-1) /= 1 .AND. tign_g(i,j-1) < -10.) is34 = 1 + IF (icn(i,j,1)+icn(i,j,3) == 2 .AND. ixsum > 0 & + .AND. nfl(i+1,j) /= 1 .AND. tign_g(i+1,j) < -10.) is13 = 1 + IF (icn(i,j,2)+icn(i,j,4) == 2 .AND. ixsum < 0 & + .AND. nfl(i-1,j) /= 1 .AND. tign_g(i-1,j) < -10.) is24 = 1 + END IF + IF (nct == 3 .AND. icls == 1) THEN + IF (icn(i,j,1)+icn(i,j,2) == 2 .AND. & + ixb(i,j,3)+ixb(i,j,4) == 0 .AND. & + jysum > 0 .AND. nfl(i,j+1) /= 1 .AND. & + tign_g(i,j+1) < -10.) is12 = 1 + IF (icn(i,j,3)+icn(i,j,4) == 2 .AND. & + ixb(i,j,1)+ixb(i,j,2) == 0 .AND. & + jysum < 0 .AND. nfl(i,j-1) /= 1 .AND. & + tign_g(i,j-1) < -10.) is34 = 1 + IF (icn(i,j,1)+icn(i,j,3) == 2 .AND. & + iyb(i,j,2)+iyb(i,j,4) == 0 .AND. & + ixsum > 0 .AND. nfl(i+1,j) /= 1 .AND. & + tign_g(i+1,j) < -10.) is13 = 1 + IF (icn(i,j,2)+icn(i,j,4) == 2 .AND. & + iyb(i,j,1)+iyb(i,j,3) == 0 .AND. & + ixsum < 0 .AND. nfl(i-1,j) /= 1 .AND. & + tign_g(i-1,j) < -10.) is24 = 1 + END IF + END IF + + ist(i,j,1) = is12 + ist(i,j,2) = is34 + ist(i,j,3) = is13 + ist(i,j,4) = is24 + + END IF !NFL=1 loop + END DO + END DO + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + IF (nfl(i,j) == 1) THEN !check cell i,j + + is12 = ist(i,j,1) + is34 = ist(i,j,2) + is13 = ist(i,j,3) + is24 = ist(i,j,4) + +! ----- the preprocessing of is12 etc allows overwriting or double ignition +! -----the checks on nfl give 2/2 ignition dominance. + + IF (is12+is34+is13+is24 > 0) THEN !2/2 4/0 and 3/1 ignition + dly = (xcn(i,j,2)-xcn(i,j,1))/ & + (ycn(i,j,2)-ycn(i,j,1) + SIGN(ep,ycn(i,j,2)-ycn(i,j,1))) + dlx = (ycn(i,j,2)-ycn(i,j,1))/ & + (xcn(i,j,2)-xcn(i,j,1) + SIGN(ep,xcn(i,j,2)-ycn(i,j,1))) + + IF (is12 == 1) THEN + xfg_4 = xcn(i,j,1) + (ylm(4)-ycn(i,j,1))*dly + yfg_4 = ycn(i,j,1) + (xlm(4)-xcn(i,j,1))*dlx + xfg_3 = xcn(i,j,1) + (ylm(3)-ycn(i,j,1))*dly + yfg_3 = ycn(i,j,1) + (xlm(3)-xcn(i,j,1))*dlx + +! ----- igniting a 1/4 + IF (yfg_4 > .5 .AND. yfg_3 < .5 .AND. nfl(i,j+1) /= 1) THEN + nfl(i,j+1) = 1 + tign_g(i,j+1) = time + xfg(i,j+1,1) = xfg_4 - 5.*ep + yfg(i,j+1,1) = ylm(1) + xfg(i,j+1,2) = xlm(2) + yfg(i,j+1,2) = ylm(2) + xfg(i,j+1,4) = xlm(4) + yfg(i,j+1,4) = yfg_4 - 1. + 5.*ep + xfg(i,j+1,3) = .5*(xfg(i,j+1,1)+xfg(i,j+1,4)) + yfg(i,j+1,3) = .5*(yfg(i,j+1,1)+yfg(i,j+1,4)) + END IF + +! ----- igniting a 1/4 + IF (yfg_3 > .5 .AND. yfg_4 < .5 .AND. nfl(i,j+1) /= 1) THEN + nfl(i,j+1) = 1 + tign_g(i,j+1) = time + xfg(i,j+1,1) = xlm(1) + yfg(i,j+1,1) = ylm(1) + xfg(i,j+1,2) = xfg_3 + 5.*ep + yfg(i,j+1,2) = ylm(2) + xfg(i,j+1,3) = xlm(3) + yfg(i,j+1,3) = yfg_3 - 1. + 5.*ep + xfg(i,j+1,4) = .5*(xfg(i,j+1,2)+xfg(i,j+1,3)) + yfg(i,j+1,4) = .5*(yfg(i,j+1,2)+yfg(i,j+1,3)) + END IF + + IF (yfg_3 > .5 .AND. yfg_4 > .5) THEN ! igniting a 2/2 + nfl(i,j+1) = 1 + tign_g(i,j+1) = time + xfg(i,j+1,1) = xlm(1) + yfg(i,j+1,1) = ylm(1) + xfg(i,j+1,2) = xlm(2) + yfg(i,j+1,2) = ylm(2) + xfg(i,j+1,3) = xlm(3) + yfg(i,j+1,3) = yfg_3 - 1. + 5.*ep + xfg(i,j+1,4) = xlm(4) + yfg(i,j+1,4) = yfg_4 - 1. + 5.*ep + END IF + END IF + + IF (is34 == 1) THEN + xfg_1 = xcn(i,j,1) + (ylm(1)-ycn(i,j,1))*dly + yfg_1 = ycn(i,j,1) + (xlm(1)-xcn(i,j,1))*dlx + xfg_2 = xcn(i,j,1) + (ylm(2)-ycn(i,j,1))*dly + yfg_2 = ycn(i,j,1) + (xlm(2)-xcn(i,j,1))*dlx + +! ----- igniting a 1/4 + IF (yfg_1 < -.5 .AND. yfg_2 > -.5 .AND. nfl(i,j-1) /= 1) THEN + nfl(i,j-1) = 1 + tign_g(i,j-1) = time + xfg(i,j-1,1) = xlm(1) + yfg(i,j-1,1) = yfg_1 + 1. - 5.*ep + xfg(i,j-1,3) = xlm(3) + yfg(i,j-1,3) = ylm(3) + xfg(i,j-1,4) = xfg_1 + 5.*ep + yfg(i,j-1,4) = ylm(4) + xfg(i,j-1,2) = .5*(xfg(i,j-1,1)+xfg(i,j-1,4)) + yfg(i,j-1,2) = .5*(yfg(i,j-1,1)+yfg(i,j-1,4)) + END IF + +! ----- igniting a 1/4 + IF (yfg_2 < -.5 .AND. yfg_1 > -.5 .AND. nfl(i,j-1) /= 1) THEN + nfl(i,j-1) = 1 + tign_g(i,j-1) = time + xfg(i,j-1,2) = xlm(2) + yfg(i,j-1,2) = yfg_2 + 1. - 5.*ep + xfg(i,j-1,3) = xfg_2 - 5.*ep + yfg(i,j-1,3) = ylm(3) + xfg(i,j-1,4) = xlm(4) + yfg(i,j-1,4) = ylm(4) + xfg(i,j-1,1) = .5*(xfg(i,j-1,2)+xfg(i,j-1,3)) + yfg(i,j-1,1) = .5*(yfg(i,j-1,2)+yfg(i,j-1,3)) + END IF + + IF (yfg_2 < -.5 .AND. yfg_1 < -.5) THEN !igniting a 2/2 + nfl(i,j-1) = 1 + tign_g(i,j-1) = time + xfg(i,j-1,1) = xlm(1) + yfg(i,j-1,1) = yfg_1 + 1. - 5.*ep + xfg(i,j-1,2) = xlm(2) + yfg(i,j-1,2) = yfg_2 + 1. - 5.*ep + xfg(i,j-1,3) = xlm(3) + yfg(i,j-1,3) = ylm(3) + xfg(i,j-1,4) = xlm(4) + yfg(i,j-1,4) = xlm(4) + END IF + END IF + + IF (is24 == 1) THEN + + xfg_1 = xcn(i,j,1) + (ylm(1)-ycn(i,j,1))*dly + yfg_1 = ycn(i,j,1) + (xlm(1)-xcn(i,j,1))*dlx + xfg_3 = xcn(i,j,1) + (ylm(3)-ycn(i,j,1))*dly + yfg_3 = ycn(i,j,1) + (xlm(3)-xcn(i,j,1))*dlx + +! ----- igniting a 1/4 + IF (xfg_1 < -.5 .AND. xfg_3 > -.5 .AND. nfl(i-1,j) /= 1) THEN + nfl(i-1,j) = 1 + tign_g(i-1,j) = time + xfg(i-1,j,1) = xfg_1 + 1. - 5.*ep + yfg(i-1,j,1) = ylm(1) + xfg(i-1,j,2) = xlm(2) + yfg(i-1,j,2) = ylm(2) + xfg(i-1,j,4) = xlm(4) + yfg(i-1,j,4) = yfg_1 + 5.*ep + xfg(i-1,j,3) = .5*(xfg(i-1,j,1)+xfg(i-1,j,4)) + yfg(i-1,j,3) = .5*(yfg(i-1,j,1)+yfg(i-1,j,4)) + END IF + +! ----- igniting a 1/4 + IF (xfg_1 > -.5 .AND. xfg_3 < -.5 .AND. nfl(i-1,j) /= 1) THEN + nfl(i-1,j) = 1 + tign_g(i-1,j) = time + xfg(i-1,j,3) = xfg_3 + 1. - 5.*ep + yfg(i-1,j,3) = ylm(3) + xfg(i-1,j,4) = xlm(4) + yfg(i-1,j,4) = ylm(4) + xfg(i-1,j,2) = xlm(2) + yfg(i-1,j,2) = yfg_3 - 5.*ep + xfg(i-1,j,1) = .5*(xfg(i-1,j,2)+xfg(i-1,j,3)) + yfg(i-1,j,1) = .5*(yfg(i-1,j,2)+yfg(i-1,j,3)) + END IF + + IF (xfg_1 < -.5 .AND. xfg_3 < -.5) THEN !igniting a 2/2 + nfl(i-1,j) = 1 + tign_g(i-1,j) = time + xfg(i-1,j,3) = xfg_3+1.-5.*ep + yfg(i-1,j,3) = ylm(3) + xfg(i-1,j,4) = xlm(4) + yfg(i-1,j,4) = ylm(4) + xfg(i-1,j,2) = xlm(2) + yfg(i-1,j,2) = ylm(2) + xfg(i-1,j,1) = xfg_1+1.-5.*ep + yfg(i-1,j,1) = ylm(1) + END IF + END IF + + IF (is13 == 1) THEN + + xfg_2 = xcn(i,j,1) + (ylm(2)-ycn(i,j,1))*dly + yfg_2 = ycn(i,j,1) + (xlm(2)-xcn(i,j,1))*dlx + xfg_4 = xcn(i,j,1) + (ylm(4)-ycn(i,j,1))*dly + yfg_4 = ycn(i,j,1) + (xlm(4)-xcn(i,j,1))*dlx + +! ----- igniting a 1/4 + IF (xfg_2 > .5 .AND. xfg_4 < .5 .AND. nfl(i+1,j) /= 1) THEN + nfl(i+1,j) = 1 + tign_g(i+1,j) = time + xfg(i+1,j,1) = xlm(1) + yfg(i+1,j,1) = ylm(1) + xfg(i+1,j,2) = xfg_2 - 1. + 5.*ep + yfg(i+1,j,2) = ylm(2) + xfg(i+1,j,3) = xlm(3) + yfg(i+1,j,3) = yfg_2 + 5.*ep + xfg(i+1,j,4) = .5*(xfg(i+1,j,2)+xfg(i+1,j,3)) + yfg(i+1,j,4) = .5*(yfg(i+1,j,2)+yfg(i+1,j,3)) + END IF + +! ----- igniting a 1/4 + IF (xfg_2 < .5 .AND. xfg_4 > .5 .AND. nfl(i+1,j) /= 1) THEN + nfl(i+1,j) = 1 + tign_g(i+1,j) = time + xfg(i+1,j,4) = xfg_4 - 1. + 5.*ep + yfg(i+1,j,4) = ylm(4) + xfg(i+1,j,3) = xlm(3) + yfg(i+1,j,3) = ylm(3) + xfg(i+1,j,1) = xlm(1) + yfg(i+1,j,1) = yfg_4 - 5.*ep + xfg(i+1,j,2) = .5*(xfg(i+1,j,1)+xfg(i+1,j,4)) + yfg(i+1,j,2) = .5*(yfg(i+1,j,1)+yfg(i+1,j,4)) + END IF + + IF (xfg_2 > .5 .AND. xfg_4 > .5) THEN !igniting a 2/2 + nfl(i+1,j) = 1 + tign_g(i+1,j) = time + xfg(i+1,j,1) = xlm(1) + yfg(i+1,j,1) = ylm(1) + xfg(i+1,j,2) = xfg_2 - 1. + 5.*ep + yfg(i+1,j,2) = ylm(2) + xfg(i+1,j,3) = xlm(3) + yfg(i+1,j,3) = ylm(3) + xfg(i+1,j,4) = xfg_4 - 1. + 5.*ep + yfg(i+1,j,4) = ylm(4) + END IF + + END IF + + END IF !NCT=2 ICLS=2 + + END IF !2/2 4/0 and 3/1 ignition + END DO + END DO + +!new version of 3/1 and 3/2 diagonal ignitions + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + nct = nc(i,j) + icls = icl(i,j) + + IF (nfl(i,j) == 1 .AND. nct == 3 .AND. time-tign_g(i,j) > ep) THEN + + i1 = in1(i,j,1) + j1 = in1(i,j,2) + i2 = in2(i,j,1) + j2 = in2(i,j,2) + + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + nh0 = ncod(i,j) + + ic1 = 10 - icn(i,j,1) - 2*icn(i,j,2) - 3*icn(i,j,3) - 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ic1 - 1 + 2*(ic1-(ic1/2)*2) + ic4 = 10 - ic1 - ic2 - ic3 + + x1 = FLOAT(icls-1)*(xcn(i1,j1,nh1-1)+FLOAT(i1-i)) & + + FLOAT(2-icls)*(xcn(i1,j1,nh1-1)+FLOAT(i1-i)) + y1 = FLOAT(icls-1)*(ycn(i1,j1,nh1-1)+FLOAT(j1-j)) & + + FLOAT(2-icls)*(ycn(i1,j1,nh1-1)+FLOAT(j1-j)) + x2 = FLOAT(icls-1)*xcn(i,j,2) + FLOAT(2-icls)*xcn(i,j,2) + y2 = FLOAT(icls-1)*ycn(i,j,2) + FLOAT(2-icls)*ycn(i,j,2) + x3 = FLOAT(icls-1)*xcn(i,j,2) + FLOAT(2-icls)*xcn(i,j,1) + y3 = FLOAT(icls-1)*ycn(i,j,2) + FLOAT(2-icls)*ycn(i,j,1) + x4 = FLOAT(icls-1)*(xcn(i2,j2,2)+FLOAT(i2-i)) & + + FLOAT(2-icls)*(xcn(i2,j2,2)+FLOAT(i2-i)) + y4 = FLOAT(icls-1)*(ycn(i2,j2,2)+FLOAT(j2-j)) & + + FLOAT(2-icls)*(ycn(i2,j2,2)+FLOAT(j2-j)) + + xfga = x1 + (ylm(ic1)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + xfgb = x3 + (ylm(ic1)-y3)*(x4-x3)/(y4-y3+SIGN(ep,y4-y3)) + yfga = y1 + (xlm(ic1)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + yfgb = y3 + (xlm(ic1)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3)) + + xfga = xfga + SIGN(ep,xlm(ic1)) + xfgb = xfgb + SIGN(ep,xlm(ic1)) + yfga = yfga + SIGN(ep,ylm(ic1)) + yfgb = yfgb + SIGN(ep,ylm(ic1)) + +! ----- txa=0 means no ignition possible by the A line +! ----- txa=1 means ignition is possible by the A line + + txa = (xlm(ic1)-xfga)*(xlm(ic3)-xlm(ic1)) !debug + txb = (xlm(ic1)-xfgb)*(xlm(ic3)-xlm(ic1)) + tya = (ylm(ic1)-yfga)*(ylm(ic4)-ylm(ic1)) + tyb = (ylm(ic1)-yfgb)*(ylm(ic4)-ylm(ic1)) + + txa = INT((txa+ABS(txa))/(2.*ABS(txa)+ep)+.5) + txb = INT((txb+ABS(txb))/(2.*ABS(txb)+ep)+.5) + tya = INT((tya+ABS(tya))/(2.*ABS(tya)+ep)+.5) + tyb = INT((tyb+ABS(tyb))/(2.*ABS(tyb)+ep)+.5) + +! ----- we threshold the limit to .5 cell distance + + txa = .5 * txa * (1.-SIGN(1.,ABS(xfga-xlm(ic1))-.5)) !debug + txb = .5 * txb * (1.-SIGN(1.,ABS(xfgb-xlm(ic1))-.5)) + tya = .5 * tya * (1.-SIGN(1.,ABS(yfga-ylm(ic1))-.5)) + tyb = .5 * tyb * (1.-SIGN(1.,ABS(yfgb-ylm(ic1))-.5)) + + is = 1 - 2 * (ic1-(ic1/2)*2) + js = - 1 + 2 * ((ic1-1)/2) + + IF (txa+txb > 1.-ep .AND. tya+tyb > 1.-ep .AND. & + tign_g(i+is,j+js) < -10.) THEN !IGNITION + + xfg_ic1 = (txa*xfga+txb*xfgb)/(txa+txb+ep) + yfg_ic1 = (tya*yfga+tyb*yfgb)/(tya+tyb+ep) + nfl(i+is,j+js) = 1 + tign_g(i+is,j+js) = time + xfg(i+is,j+js,ic2) = xlm(ic2) + yfg(i+is,j+js,ic2) = ylm(ic2) + xfg(i+is,j+js,ic3) = xlm(ic3) + yfg(i+is,j+js,ic4) = ylm(ic4) + yfg(i+is,j+js,ic3) = yfg_ic1 - FLOAT(js)*(1.-5.*ep) !debug + xfg(i+is,j+js,ic4) = xfg_ic1 - FLOAT(js)*(1.-5.*ep) !debug + xfg(i+is,j+js,ic1) = .5*(xfg(i+is,j+js,ic3)+xfg(i+is,j+js,ic4)) + yfg(i+is,j+js,ic1) = .5*(yfg(i+is,j+js,ic3)+yfg(i+is,j+js,ic4)) + + END IF ! WE HAVE IGNITION + + END IF !NFL=1 NCT=3 + END DO + END DO +!end new version of 3/1 and 3/2 diagonal ignitions + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + nct = nc(i,j) + icls = icl(i,j) + + IF (nfl(i,j) == 1 .AND. nct == 1 .AND. icls == 4 .AND. & + tign_g(i,j) > ep) THEN !NCT=1 ICLS=4 +! debug section + tx = MAX(ABS(xcn(i,j,1)),ABS(xcn(i,j,3))) + ty = MAX(ABS(ycn(i,j,1)),ABS(ycn(i,j,3))) + + IF (tx > .5 .OR. ty > .5) THEN !1/4 likely + i1 = in1(i,j,1) + j1 = in1(i,j,2) + i2 = in2(i,j,1) + j2 = in2(i,j,2) + nh1 = ncod(i1,j1) + nh2 = ncod(i2,j2) + nh0 = ncod(i,j) + ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + & + 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4)) + ic4 = 10 - ic1 - ic2 - ic3 + iod = ic1 - 2*(ic1/2) + is = 1 - 2*iod + js = - 1 + 2*(ic1/3) + isen = is*js + x1 = xcn(i2,j2,2) + FLOAT(i2-i) + y1 = ycn(i2,j2,2) + FLOAT(j2-j) + x2 = xcn(i2,j2,1) + FLOAT(i2-i) + y2 = ycn(i2,j2,1) + FLOAT(j2-j) + x3 = xcn(i,j,2+isen) + y3 = ycn(i,j,2+isen) + x4 = xcn(i,j,2) + y4 = ycn(i,j,2) + x5 = xcn(i,j,2-isen) + y5 = ycn(i,j,2-isen) + x6 = xcn(i1,j1,nh1) + FLOAT(i1-i) + y6 = ycn(i1,j1,nh1) + FLOAT(j1-j) + x7 = xcn(i1,j1,nh1-1) + FLOAT(i1-i) + y7 = ycn(i1,j1,nh1-1) + FLOAT(j1-j) + IF (isen == -1) THEN + x1 = xcn(i1,j1,nh1-1) + FLOAT(i1-i) + y1 = ycn(i1,j1,nh1-1) + FLOAT(j1-j) + x2 = xcn(i1,j1,nh1) + FLOAT(i1-i) + y2 = ycn(i1,j1,nh1) + FLOAT(j1-j) + x6 = xcn(i2,j2,1) + FLOAT(i2-i) + y6 = ycn(i2,j2,1) + FLOAT(j2-j) + x7 = xcn(i2,j2,2) + FLOAT(i2-i) + y7 = ycn(i2,j2,2) + FLOAT(j2-j) + END IF + ihita = 0 + ihitb = 0 + IF (nfl(i-is,j) /= 1) THEN !NFL(I-IS,J) NE 1 + yfg_a4 = y4 + (xlm(ic3)-x4)*(y5-y4)/(x5-x4+SIGN(ep,x5-x4)) + tj1 = (yfg_a4-ylm(ic3))*(ylm(ic2)-ylm(ic3)) + tj2 = (xlm(ic3)-x5)*(xlm(ic1)-xlm(ic3)) + tj3 = .75 - ABS(yfg_a4-ylm(ic3)) + tja4 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3))) + ja4 = INT((tja4+ABS(tja4))/(2.*ABS(tja4)+ep)+.5) + + xfg_a4 = x4 + (ylm(ic3)-y4)*(x5-x4)/(y5-y4+SIGN(ep,y5-y4)) + ti1 = (xlm(ic3)-xfg_a4)*(xlm(ic1)-xlm(ic3)) + ti2 = (xlm(ic3)-x5)*(xlm(ic1)-xlm(ic3)) + ti3 = .75 - ABS(xfg_a4-xlm(ic3)) + tia4 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3))) + ia4 = INT((tia4+ABS(tia4))/(2.*ABS(tia4)+ep)+.5) + + xfg_a6 = x6 + (ylm(ic3)-y6)*(x7-x6)/(y7-y6+SIGN(ep,y7-y6)) + ti1 = (xfg_a6-xlm(ic3))*(xlm(ic3)-xlm(ic1)) + ti2 = (x6-xlm(ic3))*(xlm(ic3)-xlm(ic1)) + ti3 = .75 - ABS(xfg_a6-xlm(ic3)) + tia6 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3))) + ia6 = INT((tia6+ABS(tia6))/(2.*ABS(tia6)+ep)+.5) + + yfg_a6 = y6 + (xlm(ic3)-x6)*(y7-y6)/(x7-x6+SIGN(ep,x7-x6)) + tj1 = (yfg_a6-ylm(ic3))*(ylm(ic2)-ylm(ic3)) + tj2 = (x6-xlm(ic3))*(xlm(ic3)-xlm(ic1)) + tj3 = .75 - ABS(yfg_a6-ylm(ic3)) + tja6 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3))) + ja6 = INT((tja6+ABS(tja6))/(2.*ABS(tja6)+ep)+.5) + +! ----- ia6 takes priority over ia4 +! ----- la4 takes priority over la6 + ia4 = (1-ia6)*ia4 + ja6 = (1-ja4)*ja6 + xfg_a = (FLOAT(ia4)*xfg_a4+FLOAT(ia6)*xfg_a6)/(FLOAT(ia4+ia6)+ep) + yfg_a = (FLOAT(ja4)*yfg_a4+FLOAT(ja6)*yfg_a6)/(FLOAT(ja4+ja6)+ep) + IF (ia4+ia6 > 0 .AND. ja4+ja6 > 0) THEN + nfl(i-is,j) = 1 + ihita = 1 + tign_g(i-is,j) = time + xfg(i-is,j,ic1) = xlm(ic1) + yfg(i-is,j,ic1) = ylm(ic1) + xfg(i-is,j,ic3) = xfg_a + FLOAT(is)*(1.-5.*ep) + yfg(i-is,j,ic3) = ylm(ic3) + xfg(i-is,j,ic4) = xlm(ic4) + yfg(i-is,j,ic4) = yfg_a + SIGN(5.*ep,ylm(ic2)-ylm(ic3)) + xfg(i-is,j,ic2) = .5*(xfg(i-is,j,ic3)+xfg(i-is,j,ic4)) + yfg(i-is,j,ic2) = .5*(yfg(i-is,j,ic3)+yfg(i-is,j,ic4)) + END IF +! IF (ihita == 1) THEN + IF (ihita == 3) THEN + PRINT *,'debug IHITA results follow' + PRINT *,'debug IC1 2 3 4=',ic1,ic2,ic3,ic4 + PRINT *,'debug I J=',i,j + PRINT *,'debug I1 J1=',i1,j1 + PRINT *,'debug I2 J2=',i2,j2 + PRINT *,'debug IOD IS JS=',iod,is,js + PRINT *,'debug XFG_A4 YFG_A4=',xfg_a4,yfg_a4 + PRINT *,'debug IA4 JA4=',ia4,ja4 + PRINT *,'debug XFG_A6 YFG_A6=',xfg_a6,yfg_a6 + PRINT *,'debug IA6 JA6=',ia6,ja6 + PRINT *,'debug X1 X2=',x1,x2 + PRINT *,'debug Y1 Y2=',y1,y2 + PRINT *,'debug X3 X4 X5=',x3,x4,x5 + PRINT *,'debug Y3 Y4 Y5=',y3,y4,y5 + PRINT *,'debug X6 X7=',x6,x7 + PRINT *,'debug Y6 Y7=',y6,y7 + + END IF + END IF !NFL(I-IS,J) NE 1 + + IF (nfl(i,j-js) /= 1) THEN !NFL(I,J-JS) NE 1 + + yfg_b1 = y1 + (xlm(ic4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + tj1 = (yfg_b1-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + tj2 = (y2-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + tj3 = .75 - ABS(yfg_b1-ylm(ic4)) + tjb1 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3))) + jb1 = INT((tjb1+ABS(tjb1))/(2.*ABS(tjb1)+ep)+.5) + + xfg_b1 = x1 + (ylm(ic4)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + ti1 = (xfg_b1-xlm(ic4))*(xlm(ic2)-xlm(ic4)) + ti2 = (y2-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + ti3 = .75 - ABS(xfg_b1-xlm(ic4)) + tib1 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3))) + ib1 = INT((tib1+ABS(tib1))/(2.*ABS(tib1)+ep)+.5) + + xfg_b3 = x3 + (ylm(ic4)-y3)*(x4-x3)/(y4-y3+SIGN(ep,y4-y3)) + ti1 = (xfg_b3-xlm(ic4))*(xlm(ic2)-xlm(ic4)) + ti2 = (y3-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + ti3 = .75 - ABS(xfg_b3-xlm(ic4)) + tib3 = MIN((ti1+ABS(ti1)),(ti2+ABS(ti2)),(ti3+ABS(ti3))) + ib3 = INT((tib3+ABS(tib3))/(2.*ABS(tib3)+ep)+.5) + + yfg_b3 = y3 + (xlm(ic4)-x3)*(y4-y3)/(x4-x3+SIGN(ep,x4-x3)) + tj1 = (yfg_b3-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + tj2 = (y3-ylm(ic4))*(ylm(ic4)-ylm(ic1)) + tj3 = .75 - ABS(yfg_b3-ylm(ic4)) + tjb3 = MIN((tj1+ABS(tj1)),(tj2+ABS(tj2)),(tj3+ABS(tj3))) + jb3 = INT((tjb3+ABS(tjb3))/(2.*ABS(tjb3)+ep)+.5) + +! ----- ib3 takes priority over ib1 +! ----- jb1 takes priority over jb3 + ib1 = (1-ib3)*ib1 + jb3 = (1-jb1)*jb3 + xfg_b = (FLOAT(ib1)*xfg_b1+FLOAT(ib3)*xfg_b3)/(FLOAT(ib1+ib3)+ep) + yfg_b = (FLOAT(jb1)*yfg_b1+FLOAT(jb3)*yfg_b3)/(FLOAT(jb1+jb3)+ep) + IF (ib1+ib3 > 0 .AND. jb1+jb3 > 0) THEN + nfl(i,j-js) = 1 + ihitb = 1 + tign_g(i,j-js) = time + xfg(i,j-js,ic1) = xlm(ic1) + yfg(i,j-js,ic1) = ylm(ic1) + xfg(i,j-js,ic3) = xfg_b + SIGN(5.*ep,xlm(ic2)-xlm(ic4)) + yfg(i,j-js,ic3) = ylm(ic3) + xfg(i,j-js,ic4) = xlm(ic4) + yfg(i,j-js,ic4) = yfg_b + FLOAT(js)*(1.-5.*ep) + xfg(i,j-js,ic2) = .5*(xfg(i,j-js,ic3)+xfg(i,j-js,ic4)) + yfg(i,j-js,ic2) = .5*(yfg(i,j-js,ic3)+yfg(i,j-js,ic4)) + END IF +! IF (ihitb == 1) THEN + IF (ihitb == 3) THEN + PRINT *,'debug IHITB results follow' + PRINT *,'debug IC1 2 3 4=',ic1,ic2,ic3,ic4 + PRINT *,'debug I J=',i,j + PRINT *,'debug I1 J1=',i1,j1 + PRINT *,'debug I2 J2=',i2,j2 + PRINT *,'debug IOD IS JS=',iod,is,js + PRINT *,'debug XFG_B1 YFG_B1=',xfg_b1,yfg_b1 + PRINT *,'debug XFG_B3 YFG_B3=',xfg_b3,yfg_b3 + PRINT *,'debug X1 X2=',x1,x2 + PRINT *,'debug Y1 Y2=',y1,y2 + PRINT *,'debug X3 X4 X5=',x3,x4,x5 + PRINT *,'debug Y3 Y4 Y5=',y3,y4,y5 + PRINT *,'debug X6 X7=',x6,x7 + PRINT *,'debug Y6 Y7=',y6,y7 + END IF + END IF !NFL(I,J-JS) NE 1 + END IF !1/4 likely + END IF !NCT=1 ICLS=4 +! debug section + END DO + END DO + +! ----- redundant check for unignited cells - likely missed by diagonal 1/3 or 2/3 + + DO j = jf_st+1,jf_en-1 + DO i = if_st+1,if_en-1 + + isum = nfl(i+1,j) + nfl(i-1,j) + nfl(i,j+1) + nfl(i,j-1) + + IF (tign_g(i,j) < -10. .AND. isum == 2) THEN !unignited cell + +! ----- corner = 1 + + isumc = icn(i-1,j,2) + icn(i,j-1,3) + isum = iyb(i-1,j,4) + ixb(i,j-1,4) + IF (isumc == 2 .AND. isum >= 1) THEN + PRINT *,'debug CN=1 redund igs hit at I J=',i,j + tign_g(i,j) = time + nfl(i,j) = 1 + x1 = xfg(i,j-1,4) + y1 = yfg(i,j-1,4)-1. + x2 = xfg(i-1,j,4)-1. + y2 = yfg(i-1,j,4) + xfg_2 = x1 + (ylm(2)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + yfg_3 = y1 + (xlm(3)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + xfg(i,j,1) = xlm(1) + yfg(i,j,1) = ylm(1) + xfg(i,j,2) = xfg_2 + yfg(i,j,2) = ylm(2) + xfg(i,j,3) = xlm(3) + yfg(i,j,3) = yfg_3 + xfg(i,j,4) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,4) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + +! ----- corner = 2 + + isumc = icn(i+1,j,1) + icn(i,j-1,4) + isum = iyb(i+1,j,3) + ixb(i,j-1,3) + IF (isumc == 2 .AND. isum >= 1) THEN + PRINT *,'debug CN=2 redund igs hit at I J=',i,j + tign_g(i,j) = time + nfl(i,j) = 1 + x1 = xfg(i+1,j,3) + 1. + y1 = yfg(i+1,j,3) + x2 = xfg(i,j-1,3) + y2 = yfg(i,j-1,3) - 1. + xfg_1 = x1 + (ylm(1)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + yfg_4 = y1 + (xlm(4)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + xfg(i,j,2) = xlm(2) + yfg(i,j,2) = ylm(2) + xfg(i,j,1) = xfg_1 + yfg(i,j,1) = ylm(1) + xfg(i,j,4) = xlm(4) + yfg(i,j,4) = yfg_4 + xfg(i,j,3) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,3) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + +! ----- corner = 3 + + isumc = icn(i-1,j,4) + icn(i,j+1,1) + isum = iyb(i-1,j,2) + ixb(i,j+1,2) + IF (isumc == 2 .AND. isum >= 1) THEN + PRINT *,'debug CN=3 redund igs hit at I J=',i,j + tign_g(i,j) = time + nfl(i,j) = 1 + x1 = xfg(i-1,j,2) - 1. + y1 = yfg(i-1,j,2) + x2 = xfg(i,j+1,2) + y2 = yfg(i,j+1,2) + 1. + xfg_4 = x1 + (ylm(4)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + yfg_1 = y1 + (xlm(1)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + xfg(i,j,3) = xlm(3) + yfg(i,j,3) = ylm(3) + xfg(i,j,4) = xfg_4 + yfg(i,j,4) = ylm(4) + xfg(i,j,1) = xlm(1) + yfg(i,j,1) = yfg_1 + xfg(i,j,2) = .5*(xfg(i,j,1)+xfg(i,j,4)) + yfg(i,j,2) = .5*(yfg(i,j,1)+yfg(i,j,4)) + END IF + +! ----- corner = 4 + isumc = icn(i+1,j,3) + icn(i,j+1,2) + isum = iyb(i+1,j,1) + ixb(i,j+1,1) + IF (isumc == 2 .AND. isum >= 1) THEN + PRINT *,'debug CN=4 redund igs hit at I J=',i,j + tign_g(i,j) = time + nfl(i,j) = 1 + x1 = xfg(i,j+1,1) + y1 = yfg(i,j+1,1)+1. + x2 = xfg(i+1,j,1)+1. + y2 = yfg(i+1,j,1) + xfg_3 = x1 + (ylm(3)-y1)*(x2-x1)/(y2-y1+SIGN(ep,y2-y1)) + yfg_2 = y1 + (xlm(2)-x1)*(y2-y1)/(x2-x1+SIGN(ep,x2-x1)) + xfg(i,j,4) = xlm(4) + yfg(i,j,4) = ylm(4) + xfg(i,j,3) = xfg_3 + yfg(i,j,3) = ylm(3) + xfg(i,j,2) = xlm(2) + yfg(i,j,2) = yfg_2 + xfg(i,j,1) = .5*(xfg(i,j,2)+xfg(i,j,3)) + yfg(i,j,1) = .5*(yfg(i,j,2)+yfg(i,j,3)) + END IF + + END IF !unignited cell + END DO + END DO + + RETURN + +END SUBROUTINE fire_igs + +! ========================================================================= + +SUBROUTINE fire_burn_fcn(i,j, & ! incoming + nfuel_cat,nfl,ncod,in1,in2, & + ixb,iyb,icn,time,area2, & + tign_g,tign_crt, & + xcd,ycd,xcn,ycn,xfg,yfg, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en, & + nfrx,nfry, & + burn_frac) ! outgoing + +! ----------------------------------------------------------------------- +! This subroutine gives a fit to the mass loss curve. +! It calculates the fraction of mass left in the cell's ignited +! area at the time given. +! The function approximates a decreasing exponential with +! weighting value WEIGHT ranging from 20 (fast burnup) to 1000 +! ( ~40% decrease in mass over 10 min). +! BURN_FRAC= fraction of fuel mass in cell that has been burned in +! last timestep. +! TIGN_CRT(I,L): if fuel cell is not fully ignited, it is negative. +! If fuel cell fully ignited, it is dimensionless (universal) time +! TCELL : time since cell ignition (s) +! TMCRIT : first time since cell ignition that whole cell is burning (s) +! ----------------------------------------------------------------------- + + USE module_fr_cawfe_fuel + + IMPLICIT NONE + +! ------ incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: its,ite, kts,kte, jts,jte + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + INTEGER, INTENT(in) :: nfrx,nfry + + INTEGER, INTENT(in) :: i,j + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,2 ) :: in1,in2 + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + + REAL, INTENT(in) :: time + + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: area2 + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g,tign_crt + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ------ outgoing variables + + REAL, INTENT(out) :: burn_frac + +! ------ local variables + + INTEGER :: iflt + + REAL :: are1 + REAL :: tcell + REAL :: burn_fracc + REAL :: tmcrit + +! -------------------------------------------------------------------------- + + are1 = area2(i,j) + +! ----- CVMGP: returns x1 if x3 >=0, x2 if x3 < 0 + tcell = cvmgp( time-tign_g(i,j), 0., tign_g(i,j) ) + + IF (tign_crt(i,j) < 0.) THEN ! fuel cell not yet fully burning + + IF (tcell > ep) THEN + burn_frac = are1 + are1*weight(nfuel_cat(i,j))/tcell & + * (EXP(-tcell/weight(nfuel_cat(i,j)))-1.) + ELSE + burn_frac = 0. + END IF + + ELSE !fuel cell is fully burning + + tmcrit = tign_crt(i,j) - tign_g(i,j) + + IF (tmcrit > ep) THEN + + burn_fracc = are1 + are1*weight(nfuel_cat(i,j))/tmcrit & + *(EXP(-tmcrit/weight(nfuel_cat(i,j)))-1.) + + burn_frac = burn_fracc + weight(nfuel_cat(i,j))/tmcrit & + *(1.-EXP(-tmcrit/weight(nfuel_cat(i,j)))) & + *(1.-EXP( (tmcrit-tcell)/weight(nfuel_cat(i,j)) )) + + ELSE ! fuel cell is ~instantly fully lit (kin test) + + burn_frac = 1.-EXP(-tmcrit/weight(nfuel_cat(i,j))) ! test: point burning + + IF (tign_crt(i,j) > ep .AND. ABS(time-tign_crt(i,j)) < ep) & + THEN !avoid initialization cases + + PRINT 66,tmcrit,burn_frac,i,j,time + 66 FORMAT(1X,'Warning 215- TMCRIT BURN_FRAC =',2F5.2, & + ', I J =',2I4,', TIME =',F8.2) + END IF + END IF +! + IF (tmcrit > tcell) THEN + WRITE (6,*) 'STOP 213: BURN_FRAC,ARE1,WEIGHT,TCELL,TMCRIT=', & + i,j,burn_frac,are1,weight(nfuel_cat(i,j)),tcell,tmcrit + iflt = 213 + CALL fire_error_debug(i,j,iflt, & + time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn, & + ixb,iyb,xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + END IF + END IF + + RETURN + +END SUBROUTINE fire_burn_fcn + +! ========================================================================= + +SUBROUTINE fire_ros( i,j, & ! incoming + ifms,ifme, kfms,kfme, jfms,jfme, & + speed,tanphi,ibeh,nfuel_cat, & + bbb,phiwc,betafl,r_0, & + ros) ! outgoing + +!----------------------------------------------------------------------- +! ... calculates the rate of fire spread with mcarthur formula or behave +! using fuel type of fuel cell +! +! m/s = (ft/min) *.3048/60. = (ft/min) * .00508 ! conversion rate +! ft/min = m/s * 2.2369 * 88. = m/s * 196.850 ! conversion rate +! +!----------------------------------------------------------------------- + + USE module_fr_cawfe_fuel + + IMPLICIT NONE + +! ------ incoming variables + + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: ibeh + INTEGER, INTENT(in) :: i,j + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfuel_cat + + REAL, INTENT(in) :: speed,tanphi + + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: bbb,phiwc,betafl,r_0 + +! ------ in and out going variables + + +! ------ outgoing variables + + REAL, INTENT(out) :: ros + +! ------ local variables + + REAL :: spd_ms,spd_fm + REAL :: phis,phiw,sp_n + CHARACTER(LEN=96) :: msg + +! ------ begin routine + + IF (ichap(nfuel_cat(i,j)) == 0) THEN ! not chaparral + + IF (ibeh == 1) THEN ! BEHAVE + +! --- if wind is 0 or into fireline, phiw=0, this reduces to backing r.o.s. + + spd_ms = .5*(speed + ABS(speed)) + spd_ms = MIN(spd_ms,10.) ! max input wind spd is 10 m/s !param + + spd_fm = spd_ms * 196.850 ! convert wind spd from m/s to ft/min + +! ----- wind factor : phiw = c * spd_fm**bbb(i,j) * (betafl(i,j)/betaop)**(-e) + + phiw = spd_fm**bbb(i,j) * phiwc(i,j) ! wind coef + +! --- slope factor + + phis = 0. + IF (tanphi > 0.) THEN + phis = 5.275 *(betafl(i,j))**(-0.3) *tanphi**2 ! slope factor + END IF + +! --- spread rate (m/s) + + ros = r_0(i,j) * (1. + phiw + phis) * .00508 + + WRITE (msg,'(x,a,2i4,5(x,e12.3) )') 'i,j,ros,r0,phiw,phis=', & + i,j,ros,r_0(i,j),phiw,phis + CALL wrf_message( msg ) + + IF (ros > 1.) WRITE (6,*) 'speed=',speed,' tanphi=',tanphi + + ELSE IF (ibeh == 0) THEN !MACARTHUR FORMULA + + ros = 0.18 * EXP(0.8424*.5*(speed+ABS(speed))) + + END IF + + ELSE IF (ichap(nfuel_cat(i,j)) == 1) THEN ! chaparral +! .... spread rate has no dependency on fuel character, only windspeed. + spd_ms = .5*(speed+ABS(speed)) + ros = 1.2974 * spd_ms**1.41 ! spread rate, m/s +! -- note: backing r.o.s. is 0 for chaparral without setting nozero value below + sp_n =.03333 ! Chaparral backing fire spread rate 0.033 m/s + ros = MAX(ros, sp_n) ! no less than backing r.o.s. + END IF + +! ----------NOTE! Put an 6 m/s cap on max spread rate ----------- + + ros = MIN(ros, 6.) ! no faster than this cap ! param ! + +! IF (spd_ms > 0) THEN +! WRITE (6,120) i,j,' spd_ms,ros =',spd_ms,ros,' phiw,r0_ms=', & +! phiw, r_0(i,j)*0.00508 +! END IF +!120 FORMAT (1x,2i3,a,2f10.4,a,2f10.4) + + RETURN + +END SUBROUTINE fire_ros + +! ========================================================================= + +SUBROUTINE fire_valid14(i,j,ic1,ic2,ic3,ic4,ita,itb,itc,nc, & + icl,xfg,yfg,ixb,iyb,icn, & + ifms,ifme, kfms,kfme, jfms,jfme) + +! ----- routine checks the validity of fire points + + IMPLICIT NONE + +! ----- incoming variables + + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: i,j + +! ----- inout variables + + INTEGER, INTENT(inout) :: ic1,ic2,ic3,ic4 + INTEGER, INTENT(inout) :: ita,itb,itc + + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: ixb,iyb,icn + INTEGER, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icl + + REAL, INTENT(inout), DIMENSION( ifms:ifme,jfms:jfme,4 ) :: xfg,yfg + +! ----- local variables + + INTEGER :: iod + INTEGER :: is,js + +! ----- begin routine + + ic1 = icn(i,j,1) + 2*icn(i,j,2) + 3*icn(i,j,3) + 4*icn(i,j,4) + ic2 = 5 - ic1 + ic3 = ixb(i,j,1)*(1-iyb(i,j,1)) + 2*ixb(i,j,2)*(1-iyb(i,j,2)) + & + 3*ixb(i,j,3)*(1-iyb(i,j,3)) + 4*ixb(i,j,4)*(1-iyb(i,j,4)) + ic4 = 10 - ic1 - ic2 - ic3 + iod = ic1 - 2*(ic1/2) + is = 1 - 2*iod + js = -1 + 2*(ic1/3) + ita = icn(i-is,j,ic1) + icn(i-is,j+js,ic4) + itb = icn(i+is,j-js,ic3) + icn(i,j-js,ic1) + itc = icn(i-is,j,ic4) + icn(i-is,j-js,ic1) + icn(i,j-js,ic3) + + IF (ita > 0) then + xfg(i,j,ic3) = xlm(ic3) + yfg(i,j,ic3) = ylm(ic3) + icn(i,j,ic3) = 1 + ixb(i,j,ic3) = 0 + iyb(i,j,ic3) = 0 + xfg(i,j,ic2) = xlm(ic2) + yfg(i,j,ic2) = ylm(ic3) + 5.*ep*(ylm(ic2)-ylm(ic3)) + END IF + + IF (itb > 0) THEN + xfg(i,j,ic4) = xlm(ic4) + yfg(i,j,ic4) = ylm(ic4) + icn(i,j,ic4) = 1 + ixb(i,j,ic4) = 0 + iyb(i,j,ic4) = 0 + xfg(i,j,ic2) = xlm(ic4) + 5.*ep*(xlm(ic2)-xlm(ic4)) + yfg(i,j,ic2) = ylm(ic2) + END IF + + IF (itc > 0) THEN + xfg(i,j,ic2) = xlm(ic2) + yfg(i,j,ic2) = ylm(ic2) + icn(i,j,ic2) = 1 + ixb(i,j,ic2) = 0 + iyb(i,j,ic2) = 0 + END IF + +! ?????? + IF (ita > 0 .AND. itb > 0 .AND. itc == 0) THEN +! ----- chose IC2 coordinate positions + END IF + + nc(i,j) = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icl(i,j) = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + + RETURN + +END SUBROUTINE fire_valid14 + +! ========================================================================= + +SUBROUTINE fire_error_debug(i,j,iflt,time,in1,in2,tign_g, & + nfl,ncod,xcd,ycd,xcn,ycn,icn,ixb,iyb, & + xfg,yfg, & + ifms,ifme, kfms,kfme, jfms,jfme, & + if_st,if_en,jf_st,jf_en) + +! ------- this routine writes debug to stdout and to ncar graphics + + USE module_wrf_error + + IMPLICIT NONE + +! ------- incoming variables + + INTEGER, INTENT(in) :: ifms,ifme, kfms,kfme, jfms,jfme + INTEGER, INTENT(in) :: if_st,if_en, jf_st,jf_en + + INTEGER, INTENT(in) :: i,j,iflt + + + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: nfl,ncod + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 2 ) :: in1,in2 + INTEGER, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: ixb,iyb,icn + + REAL, INTENT(in) :: time + + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme ) :: tign_g + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xcd,ycd + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xcn,ycn + REAL, INTENT(in), DIMENSION( ifms:ifme,jfms:jfme, 4 ) :: xfg,yfg + +! ------ local variables + + INTEGER, PARAMETER :: ierrf = 6 + INTEGER, PARAMETER :: lunit = 2 + INTEGER, PARAMETER :: iwkid = 1 + + INTEGER :: ii,jj,it,ic,ierr,nct,icls,ixn,jyn,i1,j1,iszdm + INTEGER :: idl,jdl,i2,j2,iix,jjy,npd + + INTEGER, DIMENSION( ifms:ifme,jfms:jfme ) :: nc,icc + + REAL :: txn,tyn,x1,x2,y1,y2,xx1,yy1,xx2,yy2,xx3,yy3,dl,rwidth + + CHARACTER (LEN=4) :: flitnu + CHARACTER (LEN=80) :: lhead + CHARACTER (LEN=80) :: cdum + CHARACTER (LEN=21) :: fnmi + CHARACTER (LEN=5) :: iflg + CHARACTER (LEN=256) :: msg + +! ---------- end declarations, begin processing + + DO jj = jf_st,jf_en + DO ii = if_st,if_en + nc(ii,jj) = 0 + icc(ii,jj) = 0 + DO it=1,4 + nc(ii,jj) = nc(ii,jj) + icn(ii,jj,it) + icc(ii,jj) = icc(ii,jj) + ixb(ii,jj,it) + iyb(ii,jj,it) + END DO + END DO + END DO + + PRINT 11,time,i,j,iflt +11 FORMAT(1x,'ERROR DEBUG AT TIME=',f9.3,' I J=',2i4,' IFLT=',i4) + + PRINT 80,i,j,ncod(i,j),(in1(i,j,ic),ic=1,2),(in2(i,j,ic),ic=1,2) +80 FORMAT(1x,'I J NCOD=',3i4/4x,'IN1=',2i4/4x,'IN2=',2i4) + + PRINT 84,((time-tign_g(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1) +84 FORMAT(1x,'TIME-TIGN_G=',3f14.4) + + PRINT 85,((nfl(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1) +85 FORMAT(1x,' NFL =',3i10) + PRINT 135,((nc(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1) +135 FORMAT(1X,' NC =',3i10) + PRINT 136,((icc(ii,jj),ii=i-1,i+1),jj=j+1,j-1,-1) +136 FORMAT(1X,' ICLS =',3i10) + + PRINT 63,(xcd(i,j,it),it=1,4),(ycd(i,j,it),it=1,4) +63 FORMAT(1x,'XCD(I J )=',4f10.7/1x,'YCD(I J =',4f10.7) + PRINT 67,(xcd(i+1,j,it),it=1,4),(ycd(i+1,j,it),it=1,4) +67 FORMAT(1x,'XCD(IP J )=',4f10.7/1x,'YCD(IP J =',4f10.7) + PRINT 68,(xcd(i-1,j,it),it=1,4),(ycd(i-1,j,it),it=1,4) +68 FORMAT(1x,'XCD(IM J )=',4f10.7/1x,'YCD(IM J =',4f10.7) + PRINT 69,(xcd(i,j+1,it),it=1,4),(ycd(i,j+1,it),it=1,4) +69 FORMAT(1x,'XCD(I JP)=',4f10.7/1x,'YCD(I JP=',4f10.7) + PRINT 70,(xcd(i,j-1,it),it=1,4),(ycd(i,j-1,it),it=1,4) +70 FORMAT(1x,'XCD(I JM)=',4f10.7/1x,'YCD(I JM=',4f10.7) + PRINT 71,(xcd(i+1,j+1,it),it=1,4),(ycd(i+1,j+1,it),it=1,4) +71 FORMAT(1x,'XCD(IP JP)=',4f10.7/1x,'YCD(IP JP=',4f10.7) + PRINT 72,(xcd(i-1,j-1,it),it=1,4),(ycd(i-1,j-1,it),it=1,4) +72 FORMAT(1x,'XCD(IM JM)=',4f10.7/1x,'YCD(IM JM=',4f10.7) + PRINT 79,(xcd(i+1,j-1,it),it=1,4),(ycd(i+1,j-1,it),it=1,4) +79 FORMAT(1x,'XCD(IP JM)=',4f10.7/1x,'YCD(IP JM=',4f10.7) + PRINT 83,(xcd(i-1,j+1,it),it=1,4),(ycd(i-1,j+1,it),it=1,4) +83 FORMAT(1x,'XCD(IM JP)=',4f10.7/1x,'YCD(IM JP=',4f10.7) + + PRINT 65,(xcn(i,j,it),it=1,4),(ycn(i,j,it),it=1,4) +65 FORMAT(1x,'XCN(I J =',4f10.7/1x,'YCN(I J =',4f10.7) + PRINT 73,(xcn(i+1,j,it),it=1,4),(ycn(i+1,j,it),it=1,4) +73 FORMAT(1x,'XCN(IP J =',4f10.7/1x,'YCN(IP J =',4f10.7) + PRINT 74,(xcn(i-1,j,it),it=1,4),(ycn(i-1,j,it),it=1,4) +74 FORMAT(1x,'XCN(IM J =',4f10.7/1x,'YCN(IM J =',4f10.7) + PRINT 75,(xcn(i,j+1,it),it=1,4),(ycn(i,j+1,it),it=1,4) +75 FORMAT(1x,'XCN(I JP=',4f10.7/1x,'YCN(I JP=',4f10.7) + PRINT 76,(xcn(i,j-1,it),it=1,4),(ycn(i,j-1,it),it=1,4) +76 FORMAT(1x,'XCN(I JM=',4f10.7/1x,'YCN(I JM=',4f10.7) + PRINT 77,(xcn(i+1,j+1,it),it=1,4),(ycn(i+1,j+1,it),it=1,4) +77 FORMAT(1x,'XCN(IP JP=',4f10.7/1x,'YCN(IP JP=',4f10.7) + PRINT 78,(xcn(i-1,j-1,it),it=1,4),(ycn(i-1,j-1,it),it=1,4) +78 FORMAT(1x,'XCN(IM JM=',4f10.7/1x,'YCN(IM JM=',4f10.7) + PRINT 81,(xcn(i+1,j-1,it),it=1,4),(ycn(i+1,j-1,it),it=1,4) +81 FORMAT(1x,'XCN(IP JM=',4f10.7/1x,'YCN(IP JM=',4f10.7) + PRINT 82,(xcn(i-1,j+1,it),it=1,4),(ycn(i-1,j+1,it),it=1,4) +82 FORMAT(1x,'XCN(IM JP=',4f10.7/1x,'YCN(IM JP=',4f10.7) + + nct = icn(i,j,1) + icn(i,j,2) + icn(i,j,3) + icn(i,j,4) + icls = ixb(i,j,1) + ixb(i,j,2) + ixb(i,j,3) + ixb(i,j,4) + & + iyb(i,j,1) + iyb(i,j,2) + iyb(i,j,3) + iyb(i,j,4) + + PRINT 32,nct,icls,(icn(i,j,it),it=1,4),nfl(i,j) +32 FORMAT(1x,'NCT ICLS=',2i4/5x,'ICN=',4i4/5x,'NFL=',i4) + + PRINT 49,i ,j,(xfg(i ,j,it),it=1,4),(yfg(i ,j,it),it=1,4) + PRINT 50,i+1,j,(xfg(i+1,j,it),it=1,4),(yfg(i+1,j,it),it=1,4) + PRINT 51,i-1,j,(xfg(i-1,j,it),it=1,4),(yfg(i-1,j,it),it=1,4) + PRINT 52,i,j+1,(xfg(i,j+1,it),it=1,4),(yfg(i,j+1,it),it=1,4) + PRINT 53,i,j-1,(xfg(i,j-1,it),it=1,4),(yfg(i,j-1,it),it=1,4) +49 FORMAT(1x,'I J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +50 FORMAT(1x,'IP J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +51 FORMAT(1x,'IM J =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +52 FORMAT(1x,'I JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +53 FORMAT(1x,'I JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) + + PRINT 54,i+1,j+1,(xfg(i+1,j+1,it),it=1,4),(yfg(i+1,j+1,it),it=1,4) + PRINT 55,i+1,j-1,(xfg(i+1,j-1,it),it=1,4),(yfg(i+1,j-1,it),it=1,4) + PRINT 56,i-1,j+1,(xfg(i-1,j+1,it),it=1,4),(yfg(i-1,j+1,it),it=1,4) + PRINT 57,i-1,j-1,(xfg(i-1,j-1,it),it=1,4),(yfg(i-1,j-1,it),it=1,4) +54 FORMAT(1x,'IP JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +55 FORMAT(1x,'IP JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +56 FORMAT(1x,'IM JP =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) +57 FORMAT(1x,'IM JM =',2i4,' XFG=',4f10.7/16x,' YFG=',4f10.7) + + PRINT 33,(ixb(i,j,it),it=1,4),(iyb(i,j,it),it=1,4) + PRINT 34,(ixb(i+1,j,it),it=1,4),(iyb(i+1,j,it),it=1,4) + PRINT 35,(ixb(i-1,j,it),it=1,4),(iyb(i-1,j,it),it=1,4) + PRINT 36,(ixb(i,j+1,it),it=1,4),(iyb(i,j+1,it),it=1,4) + PRINT 37,(ixb(i,j-1,it),it=1,4),(iyb(i,j-1,it),it=1,4) +33 FORMAT(1x,'IXB(I J )=',4i4/1x,'IYB(I J )=',4i4) +34 FORMAT(1x,'IXB(IP J )=',4i4/1x,'IYB(IP J )=',4i4) +35 FORMAT(1x,'IXB(IM J )=',4i4/1x,'IYB(IM J )=',4i4) +36 FORMAT(1x,'IXB(I JP)=',4i4/1x,'IYB(I JP)=',4i4) +37 FORMAT(1x,'IXB(I JM)=',4I4/1x,'IYB(I JM)=',4i4) + +! ---- EGP commented out printing the winds... +! ... print winds used to spread fire +! PRINT 180,i ,j,(ug(i ,j,it),it=1,4),(vg(i ,j,it),it=1,4) +! PRINT 181,i+1,j,(ug(i+1,j,it),it=1,4),(vg(i+1,j,it),it=1,4) +! PRINT 182,i-1,j,(ug(i-1,j,it),it=1,4),(vg(i-1,j,it),it=1,4) +! PRINT 183,i,j+1,(ug(i,j+1,it),it=1,4),(vg(i,j+1,it),it=1,4) +! PRINT 184,i,j-1,(ug(i,j-1,it),it=1,4),(vg(i,j-1,it),it=1,4) +180 FORMAT(1x,'I J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3) +181 FORMAT(1x,'IP J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3) +182 FORMAT(1x,'IM J =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3) +183 FORMAT(1x,'I JP =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3) +184 FORMAT(1x,'I JM =',2i4,' UG=',4f9.3/16x,' VG=',4f9.3) + + WRITE (iflg,'(I5.5)') iflt + WRITE (msg,*) 'fire_error_debug: FATAL '//iflg + CALL wrf_error_fatal ( msg ) + + RETURN + +END SUBROUTINE fire_error_debug + +! ========================================================================= + +REAL FUNCTION cvmgp(a,b,c) + +! ----- returns x1 if x3 >=0 +! or x2 if x3 < 0 + + REAL, INTENT(in) :: a,b,c + +! ----- begin + + IF (c >= 0.) THEN + cvmgp = a + ELSE + cvmgp = b + END IF + +END FUNCTION cvmgp + +! ========================================================================= + +SUBROUTINE fire_emissions(grnhfx,canhfx,dt,dz8w,rho,num_scalars, & ! incoming + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + scalar) ! outgoing + +! ------------------------------------------------------------------------- +! this routine handles the emission of carbonaceous particles assuming +! a specified percent of the fuel mass to be emitted as smoke. +! +! this routine will serve as a template for further chemical emissions. +! ------------------------------------------------------------------------- + + IMPLICIT NONE + +! --- incoming variables + + INTEGER, INTENT(in) :: ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte + + INTEGER, INTENT(in) :: num_scalars + + REAL, INTENT(in) :: dt + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: grnhfx,canhfx + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rho + +! --- outgoing variables + + REAL, INTENT(out), DIMENSION( ims:ime,jms:jme,1:num_scalars ) :: scalar + +! --- local variables + + INTEGER :: i,j,k + + REAL :: smoke_fac + REAL :: del_g,del_c + REAL :: density_g,density_c + REAL :: zbox_g,zbox_c + REAL :: tracer_g,tracer_c + +! --------------------------------------------------------------------- + + smoke_fac = 0.02 ! 2% of fuel mass becomes smoke + + DO j = MAX(jts,jds+1),MIN(jte,jde-1) + DO i = MAX(its,ids+1),MIN(ite,ide-1) + + del_g = grnhfx(i,j) * dt / cmbcnst + del_c = canhfx(i,j) * dt / cmbcnst + + density_g = rho(i,1,j) + density_c = rho(i,2,j) + + zbox_g = dz8w(i,1,j) + zbox_c = dz8w(i,2,j) + + ! --- tracer_g/c in kg of tracer per kg of air + + tracer_g = smoke_fac * del_g / (zbox_g * density_g) + tracer_c = smoke_fac * del_c / (zbox_c * density_c) + + scalar(i,1,j) = scalar(i,1,j) + tracer_g + scalar(i,2,j) = scalar(i,2,j) + tracer_c + + END DO + END DO + +END SUBROUTINE fire_emissions + +! ========================================================================= + +SUBROUTINE fire_winds(u,v, & ! incoming + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + u_i,v_i) ! outgoing + +! --- this routine takes u and v from the arakawa c-grid and interpolates +! them horizontally and upward to the w-level (i.e. to the grid cube corners) +! as desired by the fire code. note that the final values are two +! dimensional arrays that are six grid points tall valid at the w-levels +! and that the exterior single grid point on all four edges of the domain +! are not filled. +! +! v(1,2) u(1,2) u(2,2) +! ----*---- v(1,2) *--------* v(2,2) +! | | | | +! u(1,1) * * u(2,1) ===> | | +! | | | | +! ^ y ----*---- u(1,1) *--------* u(2,1) +! | v(1,1) v(1,1) v(2,1) +! | +! *----> x and shifted up to w-level +! + IMPLICIT NONE + + INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte + + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: u,v + + REAL, INTENT(out), DIMENSION( ims:ime,jms:jme,6 ) :: u_i,v_i + + INTEGER :: i,j,k + INTEGER :: i_st,i_en + INTEGER :: j_st,j_en + + ! --- set indicies + + i_st = MAX(its,ids+1) + i_en = MIN(ite,ide-1) + j_st = MAX(jts,jds+1) + j_en = MIN(jte,jde-1) + + ! --- get velocities + + DO k = 1,6 + DO j = j_st,j_en + DO i = i_st,i_en + u_i(i,j,k) = .25*( u(i,k,j) + u(i,k,j+1) + u(i,k+1,j) + u(i,k+1,j+1) ) + v_i(i,j,k) = .25*( v(i-1,k,j) + v(i,k,j) + v(i-1,k+1,j) + v(i,k+1,j) ) + END DO + END DO + END DO + + RETURN + +END SUBROUTINE fire_winds + +! ========================================================================= + +SUBROUTINE fire_tendency(grnhfx,grnqfx,canhfx,canqfx, & ! incoming + alfg,alfc,z1can, & + zs,z_at_w,dz8w,mu,rho, & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + rthfrten,rqvfrten) ! outgoing + +! --- this routine takes fire generated heat and moisture fluxes and +! calculates their influence on the theta and water vapor + +! --- note that these tendencies are valid at the Arakawa-A location + + IMPLICIT NONE + +! --- incoming variables + + INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx ! W/m^2 + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx ! W/m^2 + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: mu ! dry air mass (Pa) + + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w ! dz across w-lvl + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rho ! density + + REAL, INTENT(in) :: alfg ! extinction depth ground fire heat (m) + REAL, INTENT(in) :: alfc ! extinction depth crown fire heat (m) + REAL, INTENT(in) :: z1can ! height of crown fire heat release (m) + +! --- outgoing variables + + REAL, INTENT(out), DIMENSION( ims:ime,kms:kme,jms:jme ) :: & + rthfrten, & ! theta tendency from fire (in mass units) + rqvfrten ! Qv tendency from fire (in mass units) +! --- local variables + + INTEGER :: i,j,k + INTEGER :: i_st,i_en, j_st,j_en, k_st,k_en + + REAL :: cp_i + REAL :: rho_i + REAL :: xlv_i + REAL :: z_w,dz + REAL :: fact_g, fact_c + + REAL, DIMENSION( ims:ime,kms:kme,jms:jme ) :: hfx,qfx + +! --- set some local constants + + cp_i = 1./cp ! inverse of specific heat + xlv_i = 1./xlv ! inverse of latent heat + +! --- set loop indicies : note that + + i_st = MAX(its,ids+1) + i_en = MIN(ite,ide-1) + k_st = kts + k_en = MIN(kte,kde-1) + j_st = MAX(jts,jds+1) + j_en = MIN(jte,jde-1) + +! --- distribute fluxes + + DO j = j_st,j_en + DO k = k_st,k_en + DO i = i_st,i_en + + ! --- set z (in meters above ground) + + z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st + + ! --- heat flux + + fact_g = cp_i * EXP( - alfg * z_w ) + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * EXP( - alfc * (z_w - z1can) ) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) + + ! --- vapor flux + + fact_g = xlv_i * EXP( - alfg * z_w ) + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * EXP( - alfc * (z_w - z1can) ) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + + END DO + END DO + END DO + +! --- add flux divergence to tendencies +! +! multiply by dry air mass (mu) to eliminate the need to +! call sr. calculate_phy_tend (in dyn_em/module_em.F) + + DO j = j_st,j_en + DO k = k_st,k_en-1 + DO i = i_st,i_en + + rho_i = 1./rho(i,k,j) + + rthfrten(i,k,j) = - mu(i,j) * rho_i * (hfx(i,k+1,j)-hfx(i,k,j)) / dz8w(i,k,j) + rqvfrten(i,k,j) = - mu(i,j) * rho_i * (qfx(i,k+1,j)-qfx(i,k,j)) / dz8w(i,k,j) + + END DO + END DO + END DO + + RETURN + +END SUBROUTINE fire_tendency + +! ========================================================================= + +END MODULE module_fr_cawfe diff --git a/wrfv2_fire/phys/module_gfs_funcphys.F b/wrfv2_fire/phys/module_gfs_funcphys.F new file mode 100755 index 00000000..6c9f7b18 --- /dev/null +++ b/wrfv2_fire/phys/module_gfs_funcphys.F @@ -0,0 +1,2935 @@ +!------------------------------------------------------------------------------- +module module_gfs_funcphys +!$$$ Module Documentation Block +! +! Module: funcphys API for basic thermodynamic physics +! Author: Iredell Org: W/NX23 Date: 1999-03-01 +! +! Abstract: This module provides an Application Program Interface +! for computing basic thermodynamic physics functions, in particular +! (1) saturation vapor pressure as a function of temperature, +! (2) dewpoint temperature as a function of vapor pressure, +! (3) equivalent potential temperature as a function of temperature +! and scaled pressure to the kappa power, +! (4) temperature and specific humidity along a moist adiabat +! as functions of equivalent potential temperature and +! scaled pressure to the kappa power, +! (5) scaled pressure to the kappa power as a function of pressure, and +! (6) temperature at the lifting condensation level as a function +! of temperature and dewpoint depression. +! The entry points required to set up lookup tables start with a "g". +! All the other entry points are functions starting with an "f" or +! are subroutines starting with an "s". These other functions and +! subroutines are elemental; that is, they return a scalar if they +! are passed only scalars, but they return an array if they are passed +! an array. These other functions and subroutines can be inlined, too. +! +! Program History Log: +! 1999-03-01 Mark Iredell +! 1999-10-15 Mark Iredell SI unit for pressure (Pascals) +! 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi +! +! Public Variables: +! krealfp Integer parameter kind or length of reals (=kind_phys) +! +! Public Subprograms: +! gpvsl Compute saturation vapor pressure over liquid table +! +! fpvsl Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvslq Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvslx Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gpvsi Compute saturation vapor pressure over ice table +! +! fpvsi Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsiq Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsix Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gpvs Compute saturation vapor pressure table +! +! fpvs Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsq Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsx Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gtdpl Compute dewpoint temperature over liquid table +! +! ftdpl Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplq Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplx Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplxg Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gtdpi Compute dewpoint temperature table over ice +! +! ftdpi Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpiq Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpix Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpixg Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gtdp Compute dewpoint temperature table +! +! ftdp Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpq Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpx Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpxg Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gthe Compute equivalent potential temperature table +! +! fthe Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! ftheq Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! fthex Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! gtma Compute moist adiabat tables +! +! stma Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmaq Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmax Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmaxg Elementally compute moist adiabat temperature and moisture +! tg Real(krealfp) guess parcel temperature in Kelvin +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! gpkap Compute pressure to the kappa table +! +! fpkap Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! fpkapq Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! fpkapo Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) surface pressure in Pascals +! +! fpkapx Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! grkap Compute pressure to the 1/kappa table +! +! frkap Elementally raise pressure to the 1/kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the 1/kappa power +! +! frkapq Elementally raise pressure to the kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! frkapx Elementally raise pressure to the kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! gtlcl Compute LCL temperature table +! +! ftlcl Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclq Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclo Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclx Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! gfuncphys Compute all physics function tables +! +! Attributes: +! Language: Fortran 90 +! +!$$$ + use module_gfs_machine,only:kind_phys + use module_gfs_physcons + implicit none + private +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Public Variables +! integer,public,parameter:: krealfp=selected_real_kind(15,45) + integer,public,parameter:: krealfp=kind_phys +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Private Variables + real(krealfp),parameter:: psatb=con_psat*1.e-5 + integer,parameter:: nxpvsl=7501 + real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) + integer,parameter:: nxpvsi=7501 + real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi) + integer,parameter:: nxpvs=7501 + real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs) + integer,parameter:: nxtdpl=5001 + real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl) + integer,parameter:: nxtdpi=5001 + real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi) + integer,parameter:: nxtdp=5001 + real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp) + integer,parameter:: nxthe=241,nythe=151 + real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe) + integer,parameter:: nxma=151,nyma=121 + real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma) +! integer,parameter:: nxpkap=5501 + integer,parameter:: nxpkap=11001 + real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap) + integer,parameter:: nxrkap=5501 + real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) + integer,parameter:: nxtlcl=151,nytlcl=61 + real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Public Subprograms + public gpvsl,fpvsl,fpvslq,fpvslx + public gpvsi,fpvsi,fpvsiq,fpvsix + public gpvs,fpvs,fpvsq,fpvsx + public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg + public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg + public gtdp,ftdp,ftdpq,ftdpx,ftdpxg + public gthe,fthe,ftheq,fthex + public gtma,stma,stmaq,stmax,stmaxg + public gpkap,fpkap,fpkapq,fpkapo,fpkapx + public grkap,frkap,frkapq,frkapx + public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx + public gfuncphys +contains +!------------------------------------------------------------------------------- + subroutine gpvsl +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvsl Compute saturation vapor pressure table over liquid +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvsl. +! Exact saturation vapor pressures are calculated in subprogram fpvslx. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gpvsl +! +! Subprograms called: +! (fpvslx) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvsl-1) +! c1xpvsl=1.-xmin/xinc + c2xpvsl=1./xinc + c1xpvsl=1.-xmin*c2xpvsl + do jx=1,nxpvsl + x=xmin+(jx-1)*xinc + t=x + tbpvsl(jx)=fpvslx(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function fpvsl(t) + function fpvsl(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsl Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsl is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvsl(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsl Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsl + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) + jx=min(xj,nxpvsl-1._krealfp) + fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvslq(t) + function fpvslq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvslq Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvslq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvslq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvslq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvslq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) + jx=min(max(nint(xj),2),nxpvsl-1) + dxj=xj-jx + fj1=tbpvsl(jx-1) + fj2=tbpvsl(jx) + fj3=tbpvsl(jx+1) + fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvslx(t) + function fpvslx(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvslx Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvslx(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvslx Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvslx + real(krealfp),intent(in):: t + real(krealfp),parameter:: dldt=con_cvap-con_cliq + real(krealfp),parameter:: heat=con_hvap + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) tr +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gpvsi +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvsi Compute saturation vapor pressure table over ice +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvsi. +! Exact saturation vapor pressures are calculated in subprogram fpvsix. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gpvsi +! +! Subprograms called: +! (fpvsix) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvsi-1) +! c1xpvsi=1.-xmin/xinc + c2xpvsi=1./xinc + c1xpvsi=1.-xmin*c2xpvsi + do jx=1,nxpvsi + x=xmin+(jx-1)*xinc + t=x + tbpvsi(jx)=fpvsix(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function fpvsi(t) + function fpvsi(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsi Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsi is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsi(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsi Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsi + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) + jx=min(xj,nxpvsi-1._krealfp) + fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvsiq(t) + function fpvsiq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsiq Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvsiq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsiq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsiq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsiq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) + jx=min(max(nint(xj),2),nxpvsi-1) + dxj=xj-jx + fj1=tbpvsi(jx-1) + fj2=tbpvsi(jx) + fj3=tbpvsi(jx+1) + fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvsix(t) + function fpvsix(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsix Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The water model assumes a perfect gas, constant specific heats +! for gas and ice, and neglects the volume of the ice. +! The model does account for the variation of the latent heat +! of condensation with temperature. The liquid option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsix(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsix Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsix + real(krealfp),intent(in):: t + real(krealfp),parameter:: dldt=con_cvap-con_csol + real(krealfp),parameter:: heat=con_hvap+con_hfus + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) tr +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gpvs +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvs Compute saturation vapor pressure table +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvs. +! Exact saturation vapor pressures are calculated in subprogram fpvsx. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gpvs +! +! Subprograms called: +! (fpvsx) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvs-1) +! c1xpvs=1.-xmin/xinc + c2xpvs=1./xinc + c1xpvs=1.-xmin*c2xpvs + do jx=1,nxpvs + x=xmin+(jx-1)*xinc + t=x + tbpvs(jx)=fpvsx(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function fpvs(t) + function fpvs(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvs Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvs. See documentation for fpvsx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvs is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvs(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvs Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvs + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) + jx=min(xj,nxpvs-1._krealfp) + fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvsq(t) + function fpvsq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsq Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvs. See documentation for fpvsx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvsq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvsq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) + jx=min(max(nint(xj),2),nxpvs-1) + dxj=xj-jx + fj1=tbpvs(jx-1) + fj2=tbpvs(jx) + fj3=tbpvs(jx+1) + fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpvsx(t) + function fpvsx(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsx Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The saturation vapor pressure over either liquid and ice is computed +! over liquid for temperatures above the triple point, +! over ice for temperatures 20 degress below the triple point, +! and a linear combination of the two for temperatures in between. +! The water model assumes a perfect gas, constant specific heats +! for gas, liquid and ice, and neglects the volume of the condensate. +! The model does account for the variation of the latent heat +! of condensation and sublimation with temperature. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The reference for this computation is Emanuel(1994), pages 116-117. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvsx(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsx Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsx + real(krealfp),intent(in):: t + real(krealfp),parameter:: tliq=con_ttp + real(krealfp),parameter:: tice=con_ttp-20.0 + real(krealfp),parameter:: dldtl=con_cvap-con_cliq + real(krealfp),parameter:: heatl=con_hvap + real(krealfp),parameter:: xponal=-dldtl/con_rv + real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + real(krealfp),parameter:: dldti=con_cvap-con_csol + real(krealfp),parameter:: heati=con_hvap+con_hfus + real(krealfp),parameter:: xponai=-dldti/con_rv + real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp) tr,w,pvl,pvi +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + if(t.ge.tliq) then + fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + elseif(t.lt.tice) then + fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + else + w=(t-tice)/(tliq-tice) + pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + fpvsx=w*pvl+(1.-w)*pvi + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdpl +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdpl Compute dewpoint temperature over liquid table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdpl. +! Exact dewpoint temperatures are calculated in subprogram ftdplxg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 1 to 10001 Pascals +! giving a dewpoint temperature range of 208 to 319 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gtdpl +! +! Subprograms called: +! (ftdplxg) inlinable function to compute dewpoint temperature over liquid +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=1 + xmax=10001 + xinc=(xmax-xmin)/(nxtdpl-1) + c1xtdpl=1.-xmin/xinc + c2xtdpl=1./xinc + t=208.0 + do jx=1,nxtdpl + x=xmin+(jx-1)*xinc + pv=x + t=ftdplxg(t,pv) + tbtdpl(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function ftdpl(pv) + function ftdpl(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpl Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdpl. See documentation for ftdplxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpl is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdpl(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpl Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpl + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) + jx=min(xj,nxtdpl-1._krealfp) + ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdplq(pv) + function ftdplq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplq Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdpl. see documentation for ftdplxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdplq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) + jx=min(max(nint(xj),2),nxtdpl-1) + dxj=xj-jx + fj1=tbtdpl(jx-1) + fj2=tbtdpl(jx) + fj3=tbtdpl(jx+1) + ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdplx(pv) + function ftdplx(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplx Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdplxg +! is obtained using ftdpl so gtdpl must be already called. +! See documentation for ftdplxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplx(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplx Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdpl) inlinable function to compute dewpoint temperature over liquid +! (ftdplxg) inlinable function to compute dewpoint temperature over liquid +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplx + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdpl(pv) + ftdplx=ftdplxg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdplxg(tg,pv) + function ftdplxg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplxg Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplxg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplxg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplxg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: dldt=con_cvap-con_cliq + real(krealfp),parameter:: heat=con_hvap + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) t,tr,pvt,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) + el=heat+dldt*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdplxg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdpi +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdpi Compute dewpoint temperature over ice table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdpi. +! Exact dewpoint temperatures are calculated in subprogram ftdpixg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals +! giving a dewpoint temperature range of 197 to 279 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gtdpi +! +! Subprograms called: +! (ftdpixg) inlinable function to compute dewpoint temperature over ice +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0.1 + xmax=1000.1 + xinc=(xmax-xmin)/(nxtdpi-1) + c1xtdpi=1.-xmin/xinc + c2xtdpi=1./xinc + t=197.0 + do jx=1,nxtdpi + x=xmin+(jx-1)*xinc + pv=x + t=ftdpixg(t,pv) + tbtdpi(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function ftdpi(pv) + function ftdpi(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpi Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdpi. See documentation for ftdpixg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpi is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpi(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpi Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpi + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) + jx=min(xj,nxtdpi-1._krealfp) + ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpiq(pv) + function ftdpiq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpiq Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdpi. see documentation for ftdpixg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpiq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpiq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpiq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpiq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) + jx=min(max(nint(xj),2),nxtdpi-1) + dxj=xj-jx + fj1=tbtdpi(jx-1) + fj2=tbtdpi(jx) + fj3=tbtdpi(jx+1) + ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpix(pv) + function ftdpix(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpix Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdpixg +! is obtained using ftdpi so gtdpi must be already called. +! See documentation for ftdpixg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpix(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpix Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdpi) inlinable function to compute dewpoint temperature over ice +! (ftdpixg) inlinable function to compute dewpoint temperature over ice +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpix + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdpi(pv) + ftdpix=ftdpixg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpixg(tg,pv) + function ftdpixg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpixg Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The water model assumes a perfect gas, constant specific heats +! for gas and ice, and neglects the volume of the ice. +! The model does account for the variation of the latent heat +! of sublimation with temperature. The liquid option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpixg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpixg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpixg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: dldt=con_cvap-con_csol + real(krealfp),parameter:: heat=con_hvap+con_hfus + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) t,tr,pvt,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) + el=heat+dldt*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdpixg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdp +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdp Compute dewpoint temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdp. +! Exact dewpoint temperatures are calculated in subprogram ftdpxg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 0.5 to 1000.5 Pascals +! giving a dewpoint temperature range of 208 to 319 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gtdp +! +! Subprograms called: +! (ftdpxg) inlinable function to compute dewpoint temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0.5 + xmax=10000.5 + xinc=(xmax-xmin)/(nxtdp-1) + c1xtdp=1.-xmin/xinc + c2xtdp=1./xinc + t=208.0 + do jx=1,nxtdp + x=xmin+(jx-1)*xinc + pv=x + t=ftdpxg(t,pv) + tbtdp(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function ftdp(pv) + function ftdp(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdp Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdp. See documentation for ftdpxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdp is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdp(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdp Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdp + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) + jx=min(xj,nxtdp-1._krealfp) + ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpq(pv) + function ftdpq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpq Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdp. see documentation for ftdpxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) + jx=min(max(nint(xj),2),nxtdp-1) + dxj=xj-jx + fj1=tbtdp(jx-1) + fj2=tbtdp(jx) + fj3=tbtdp(jx+1) + ftdpq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpx(pv) + function ftdpx(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpx Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdpxg +! is obtained using ftdp so gtdp must be already called. +! See documentation for ftdpxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpx(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpx Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdp) inlinable function to compute dewpoint temperature +! (ftdpxg) inlinable function to compute dewpoint temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpx + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdp(pv) + ftdpx=ftdpxg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftdpxg(tg,pv) + function ftdpxg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpxg Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The saturation vapor pressure over either liquid and ice is computed +! over liquid for temperatures above the triple point, +! over ice for temperatures 20 degress below the triple point, +! and a linear combination of the two for temperatures in between. +! The water model assumes a perfect gas, constant specific heats +! for gas, liquid and ice, and neglects the volume of the condensate. +! The model does account for the variation of the latent heat +! of condensation and sublimation with temperature. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The reference for this decision is Emanuel(1994), pages 116-117. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpxg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpxg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpxg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: tliq=con_ttp + real(krealfp),parameter:: tice=con_ttp-20.0 + real(krealfp),parameter:: dldtl=con_cvap-con_cliq + real(krealfp),parameter:: heatl=con_hvap + real(krealfp),parameter:: xponal=-dldtl/con_rv + real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + real(krealfp),parameter:: dldti=con_cvap-con_csol + real(krealfp),parameter:: heati=con_hvap+con_hfus + real(krealfp),parameter:: xponai=-dldti/con_rv + real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + if(t.ge.tliq) then + pvt=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + el=heatl+dldtl*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + elseif(t.lt.tice) then + pvt=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + el=heati+dldti*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + else + w=(t-tice)/(tliq-tice) + pvtl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + pvti=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + pvt=w*pvtl+(1.-w)*pvti + ell=heatl+dldtl*(t-con_ttp) + eli=heati+dldti*(t-con_ttp) + dpvt=(w*ell*pvtl+(1.-w)*eli*pvti)/(con_rv*t**2) + endif + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdpxg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gthe +!$$$ Subprogram Documentation Block +! +! Subprogram: gthe Compute equivalent potential temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature table +! as a function of LCL temperature and pressure over 1e5 Pa +! to the kappa power for function fthe. +! Equivalent potential temperatures are calculated in subprogram fthex +! the current implementation computes a table with a first dimension +! of 241 for temperatures ranging from 183.16 to 303.16 Kelvin +! and a second dimension of 151 for pressure over 1e5 Pa +! to the kappa power ranging from 0.04**rocp to 1.10**rocp. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gthe +! +! Subprograms called: +! (fthex) inlinable function to compute equiv. pot. temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=con_ttp-90._krealfp + xmax=con_ttp+30._krealfp + ymin=0.04_krealfp**con_rocp + ymax=1.10_krealfp**con_rocp + xinc=(xmax-xmin)/(nxthe-1) + c1xthe=1.-xmin/xinc + c2xthe=1./xinc + yinc=(ymax-ymin)/(nythe-1) + c1ythe=1.-ymin/yinc + c2ythe=1./yinc + do jy=1,nythe + y=ymin+(jy-1)*yinc + pk=y + do jx=1,nxthe + x=xmin+(jx-1)*xinc + t=x + tbthe(jx,jy)=fthex(t,pk) + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function fthe(t,pk) + function fthe(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: fthe Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! A bilinear interpolation is done between values in a lookup table +! computed in gthe. see documentation for fthex for details. +! Input values outside table range are reset to table extrema, +! except zero is returned for too cold or high LCLs. +! The interpolation accuracy is better than 0.01 Kelvin. +! On the Cray, fthe is almost 6 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: the=fthe(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! fthe Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fthe + real(krealfp),intent(in):: t,pk + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) + yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) + if(xj.ge.1..and.yj.ge.1.) then + jx=min(xj,nxthe-1._krealfp) + jy=min(yj,nythe-1._krealfp) + ftx1=tbthe(jx,jy)+(xj-jx)*(tbthe(jx+1,jy)-tbthe(jx,jy)) + ftx2=tbthe(jx,jy+1)+(xj-jx)*(tbthe(jx+1,jy+1)-tbthe(jx,jy+1)) + fthe=ftx1+(yj-jy)*(ftx2-ftx1) + else + fthe=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftheq(t,pk) + function ftheq(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftheq Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! A biquadratic interpolation is done between values in a lookup table +! computed in gthe. see documentation for fthex for details. +! Input values outside table range are reset to table extrema, +! except zero is returned for too cold or high LCLs. +! The interpolation accuracy is better than 0.0002 Kelvin. +! On the Cray, ftheq is almost 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: the=ftheq(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! ftheq Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftheq + real(krealfp),intent(in):: t,pk + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) + yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) + if(xj.ge.1..and.yj.ge.1.) then + jx=min(max(nint(xj),2),nxthe-1) + jy=min(max(nint(yj),2),nythe-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbthe(jx-1,jy-1) + ft12=tbthe(jx-1,jy) + ft13=tbthe(jx-1,jy+1) + ft21=tbthe(jx,jy-1) + ft22=tbthe(jx,jy) + ft23=tbthe(jx,jy+1) + ft31=tbthe(jx+1,jy-1) + ft32=tbthe(jx+1,jy) + ft33=tbthe(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + ftheq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 + else + ftheq=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fthex(t,pk) + function fthex(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: fthex Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! Equivalent potential temperature is constant for a saturated parcel +! rising adiabatically up a moist adiabat when the heat and mass +! of the condensed water are neglected. Ice is also neglected. +! The formula for equivalent potential temperature (Holton) is +! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) +! where t is the temperature, pv is the saturated vapor pressure, +! pd is the dry pressure p-pv, el is the temperature dependent +! latent heat of condensation hvap+dldt*(t-ttp), and other values +! are physical constants defined in parameter statements in the code. +! Zero is returned if the input values make saturation impossible. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: the=fthex(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! fthex Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fthex + real(krealfp),intent(in):: t,pk + real(krealfp) p,tr,pv,pd,el,expo,expmax +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + p=pk**con_cpor + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + if(pd.gt.pv) then + el=con_hvap+con_dldt*(t-con_ttp) + expo=el*con_eps*pv/(con_cp*t*pd) + fthex=t*pd**(-con_rocp)*exp(expo) + else + fthex=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtma +!$$$ Subprogram Documentation Block +! +! Subprogram: gtma Compute moist adiabat tables +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity tables +! as a function of equivalent potential temperature and +! pressure over 1e5 Pa to the kappa power for subprogram stma. +! Exact parcel temperatures are calculated in subprogram stmaxg. +! The current implementation computes a table with a first dimension +! of 151 for equivalent potential temperatures ranging from 200 to 500 +! Kelvin and a second dimension of 121 for pressure over 1e5 Pa +! to the kappa power ranging from 0.01**rocp to 1.10**rocp. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gtma +! +! Subprograms called: +! (stmaxg) inlinable subprogram to compute parcel temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=200._krealfp + xmax=500._krealfp + ymin=0.01_krealfp**con_rocp + ymax=1.10_krealfp**con_rocp + xinc=(xmax-xmin)/(nxma-1) + c1xma=1.-xmin/xinc + c2xma=1./xinc + yinc=(ymax-ymin)/(nyma-1) + c1yma=1.-ymin/yinc + c2yma=1./yinc + do jy=1,nyma + y=ymin+(jy-1)*yinc + pk=y + tg=xmin*y + do jx=1,nxma + x=xmin+(jx-1)*xinc + the=x + call stmaxg(tg,the,pk,t,q) + tbtma(jx,jy)=t + tbqma(jx,jy)=q + tg=t + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental subroutine stma(the,pk,tma,qma) + subroutine stma(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stma Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! Bilinear interpolations are done between values in a lookup table +! computed in gtma. See documentation for stmaxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.01 Kelvin +! and 5.e-6 kg/kg for temperature and humidity, respectively. +! On the Cray, stma is about 35 times faster than exact calculation. +! This subprogram should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call stma(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) + yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) + jx=min(xj,nxma-1._krealfp) + jy=min(yj,nyma-1._krealfp) + ftx1=tbtma(jx,jy)+(xj-jx)*(tbtma(jx+1,jy)-tbtma(jx,jy)) + ftx2=tbtma(jx,jy+1)+(xj-jx)*(tbtma(jx+1,jy+1)-tbtma(jx,jy+1)) + tma=ftx1+(yj-jy)*(ftx2-ftx1) + qx1=tbqma(jx,jy)+(xj-jx)*(tbqma(jx+1,jy)-tbqma(jx,jy)) + qx2=tbqma(jx,jy+1)+(xj-jx)*(tbqma(jx+1,jy+1)-tbqma(jx,jy+1)) + qma=qx1+(yj-jy)*(qx2-qx1) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental subroutine stmaq(the,pk,tma,qma) + subroutine stmaq(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmaq Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! Biquadratic interpolations are done between values in a lookup table +! computed in gtma. See documentation for stmaxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.0005 Kelvin +! and 1.e-7 kg/kg for temperature and humidity, respectively. +! On the Cray, stmaq is about 25 times faster than exact calculation. +! This subprogram should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmaq(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tmaq Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 + real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) + yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) + jx=min(max(nint(xj),2),nxma-1) + jy=min(max(nint(yj),2),nyma-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbtma(jx-1,jy-1) + ft12=tbtma(jx-1,jy) + ft13=tbtma(jx-1,jy+1) + ft21=tbtma(jx,jy-1) + ft22=tbtma(jx,jy) + ft23=tbtma(jx,jy+1) + ft31=tbtma(jx+1,jy-1) + ft32=tbtma(jx+1,jy) + ft33=tbtma(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + tma=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 + q11=tbqma(jx-1,jy-1) + q12=tbqma(jx-1,jy) + q13=tbqma(jx-1,jy+1) + q21=tbqma(jx,jy-1) + q22=tbqma(jx,jy) + q23=tbqma(jx,jy+1) + q31=tbqma(jx+1,jy-1) + q32=tbqma(jx+1,jy) + q33=tbqma(jx+1,jy+1) + qx1=(((q31+q11)/2-q21)*dxj+(q31-q11)/2)*dxj+q21 + qx2=(((q32+q12)/2-q22)*dxj+(q32-q12)/2)*dxj+q22 + qx3=(((q33+q13)/2-q23)*dxj+(q33-q13)/2)*dxj+q23 + qma=(((qx3+qx1)/2-qx2)*dyj+(qx3-qx1)/2)*dyj+qx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental subroutine stmax(the,pk,tma,qma) + subroutine stmax(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmax Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute temperature and humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! An approximate parcel temperature for subprogram stmaxg +! is obtained using stma so gtma must be already called. +! See documentation for stmaxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmax(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Subprograms called: +! (stma) inlinable subprogram to compute parcel temperature +! (stmaxg) inlinable subprogram to compute parcel temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + real(krealfp) tg,qg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call stma(the,pk,tg,qg) + call stmaxg(tg,the,pk,tma,qma) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental subroutine stmaxg(tg,the,pk,tma,qma) + subroutine stmaxg(tg,the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmaxg Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute temperature and humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! A guess parcel temperature must be provided. +! Equivalent potential temperature is constant for a saturated parcel +! rising adiabatically up a moist adiabat when the heat and mass +! of the condensed water are neglected. Ice is also neglected. +! The formula for equivalent potential temperature (Holton) is +! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) +! where t is the temperature, pv is the saturated vapor pressure, +! pd is the dry pressure p-pv, el is the temperature dependent +! latent heat of condensation hvap+dldt*(t-ttp), and other values +! are physical constants defined in parameter statements in the code. +! The formula is inverted by iterating Newtonian approximations +! for each the and p until t is found to within 1.e-4 Kelvin. +! The specific humidity is then computed from pv and pd. +! This subprogram can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmaxg(tg,the,pk,tma,qma) +! +! Input argument list: +! tg Real(krealfp) guess parcel temperature in Kelvin +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: tg,the,pk + real(krealfp),intent(out):: tma,qma + real(krealfp),parameter:: terrm=1.e-4 + real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + p=pk**con_cpor + do i=1,100 + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + el=con_hvap+con_dldt*(t-con_ttp) + expo=el*con_eps*pv/(con_cp*t*pd) + thet=t*pd**(-con_rocp)*exp(expo) + dthet=thet/t*(1.+expo*(con_dldt*t/el+el*p/(con_rv*t*pd))) + terr=(thet-the)/dthet + t=t-terr + if(abs(terr).le.terrm) exit + enddo + tma=t + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + qma=con_eps*pv/(pd+con_eps*pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + subroutine gpkap +!$$$ Subprogram documentation block +! +! Subprogram: gpkap Compute coefficients for p**kappa +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Computes pressure to the kappa table as a function of pressure +! for the table lookup function fpkap. +! Exact pressure to the kappa values are calculated in subprogram fpkapx. +! The current implementation computes a table with a length +! of 5501 for pressures ranging up to 110000 Pascals. +! +! Program History Log: +! 94-12-30 Iredell +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: call gpkap +! +! Subprograms called: +! fpkapx function to compute exact pressure to the kappa +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0._krealfp + xmax=110000._krealfp + xinc=(xmax-xmin)/(nxpkap-1) + c1xpkap=1.-xmin/xinc + c2xpkap=1./xinc + do jx=1,nxpkap + x=xmin+(jx-1)*xinc + p=x + tbpkap(jx)=fpkapx(p) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function fpkap(p) + function fpkap(p) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpkap raise pressure to the kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the kappa power. +! A linear interpolation is done between values in a lookup table +! computed in gpkap. See documentation for fpkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy ranges from 9 decimal places +! at 100000 Pascals to 5 decimal places at 1000 Pascals. +! On the Cray, fpkap is over 5 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: pkap=fpkap(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkap + real(krealfp),intent(in):: p + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) + jx=min(xj,nxpkap-1._krealfp) + fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpkapq(p) + function fpkapq(p) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpkapq raise pressure to the kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the kappa power. +! A quadratic interpolation is done between values in a lookup table +! computed in gpkap. see documentation for fpkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy ranges from 12 decimal places +! at 100000 Pascals to 7 decimal places at 1000 Pascals. +! On the Cray, fpkap is over 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: pkap=fpkapq(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkapq Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapq + real(krealfp),intent(in):: p + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) + jx=min(max(nint(xj),2),nxpkap-1) + dxj=xj-jx + fj1=tbpkap(jx-1) + fj2=tbpkap(jx) + fj3=tbpkap(jx+1) + fpkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + function fpkapo(p) +!$$$ Subprogram documentation block +! +! Subprogram: fpkapo raise surface pressure to the kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Raise surface pressure over 1e5 Pa to the kappa power +! using a rational weighted chebyshev approximation. +! The numerator is of order 2 and the denominator is of order 4. +! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx. +! The accuracy of this approximation is almost 8 decimal places. +! On the Cray, fpkap is over 10 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! +! Usage: pkap=fpkapo(p) +! +! Input argument list: +! p Real(krealfp) surface pressure in Pascals +! p should be in the range 40000 to 110000 +! +! Output argument list: +! fpkapo Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapo + real(krealfp),intent(in):: p + integer,parameter:: nnpk=2,ndpk=4 + real(krealfp):: cnpk(0:nnpk)=(/3.13198449e-1,5.78544829e-2,& + 8.35491871e-4/) + real(krealfp):: cdpk(0:ndpk)=(/1.,8.15968401e-2,5.72839518e-4,& + -4.86959812e-7,5.24459889e-10/) + integer n + real(krealfp) pkpa,fnpk,fdpk +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + pkpa=p*1.e-3_krealfp + fnpk=cnpk(nnpk) + do n=nnpk-1,0,-1 + fnpk=pkpa*fnpk+cnpk(n) + enddo + fdpk=cdpk(ndpk) + do n=ndpk-1,0,-1 + fdpk=pkpa*fdpk+cdpk(n) + enddo + fpkapo=fnpk/fdpk +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fpkapx(p) + function fpkapx(p) +!$$$ Subprogram documentation block +! +! Subprogram: fpkapx raise pressure to the kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: raise pressure over 1e5 Pa to the kappa power. +! Kappa is equal to rd/cp where rd and cp are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 94-12-30 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: pkap=fpkapx(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkapx Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapx + real(krealfp),intent(in):: p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + fpkapx=(p/1.e5_krealfp)**con_rocp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine grkap +!$$$ Subprogram documentation block +! +! Subprogram: grkap Compute coefficients for p**(1/kappa) +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Computes pressure to the 1/kappa table as a function of pressure +! for the table lookup function frkap. +! Exact pressure to the 1/kappa values are calculated in subprogram frkapx. +! The current implementation computes a table with a length +! of 5501 for pressures ranging up to 110000 Pascals. +! +! Program History Log: +! 94-12-30 Iredell +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: call grkap +! +! Subprograms called: +! frkapx function to compute exact pressure to the 1/kappa +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0._krealfp + xmax=fpkapx(110000._krealfp) + xinc=(xmax-xmin)/(nxrkap-1) + c1xrkap=1.-xmin/xinc + c2xrkap=1./xinc + do jx=1,nxrkap + x=xmin+(jx-1)*xinc + p=x + tbrkap(jx)=frkapx(p) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function frkap(pkap) + function frkap(pkap) +!$$$ Subprogram Documentation Block +! +! Subprogram: frkap raise pressure to the 1/kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. +! A linear interpolation is done between values in a lookup table +! computed in grkap. See documentation for frkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 7 decimal places. +! On the IBM, fpkap is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: p=frkap(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkap Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkap + real(krealfp),intent(in):: pkap + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) + jx=min(xj,nxrkap-1._krealfp) + frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function frkapq(pkap) + function frkapq(pkap) +!$$$ Subprogram Documentation Block +! +! Subprogram: frkapq raise pressure to the 1/kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. +! A quadratic interpolation is done between values in a lookup table +! computed in grkap. see documentation for frkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 11 decimal places. +! On the IBM, fpkap is almost 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: p=frkapq(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkapq Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkapq + real(krealfp),intent(in):: pkap + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) + jx=min(max(nint(xj),2),nxrkap-1) + dxj=xj-jx + fj1=tbrkap(jx-1) + fj2=tbrkap(jx) + fj3=tbrkap(jx+1) + frkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function frkapx(pkap) + function frkapx(pkap) +!$$$ Subprogram documentation block +! +! Subprogram: frkapx raise pressure to the 1/kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: raise pressure over 1e5 Pa to the 1/kappa power. +! Kappa is equal to rd/cp where rd and cp are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 94-12-30 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: p=frkapx(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkapx Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkapx + real(krealfp),intent(in):: pkap +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + frkapx=pkap**(1/con_rocp)*1.e5_krealfp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtlcl +!$$$ Subprogram Documentation Block +! +! Subprogram: gtlcl Compute equivalent potential temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute lifting condensation level temperature table +! as a function of temperature and dewpoint depression for function ftlcl. +! Lifting condensation level temperature is calculated in subprogram ftlclx +! The current implementation computes a table with a first dimension +! of 151 for temperatures ranging from 180.0 to 330.0 Kelvin +! and a second dimension of 61 for dewpoint depression ranging from +! 0 to 60 Kelvin. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: call gtlcl +! +! Subprograms called: +! (ftlclx) inlinable function to compute LCL temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,tdpd,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180._krealfp + xmax=330._krealfp + ymin=0._krealfp + ymax=60._krealfp + xinc=(xmax-xmin)/(nxtlcl-1) + c1xtlcl=1.-xmin/xinc + c2xtlcl=1./xinc + yinc=(ymax-ymin)/(nytlcl-1) + c1ytlcl=1.-ymin/yinc + c2ytlcl=1./yinc + do jy=1,nytlcl + y=ymin+(jy-1)*yinc + tdpd=y + do jx=1,nxtlcl + x=xmin+(jx-1)*xinc + t=x + tbtlcl(jx,jy)=ftlclx(t,tdpd) + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +! elemental function ftlcl(t,tdpd) + function ftlcl(t,tdpd) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftlcl Compute LCL temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. +! A bilinear interpolation is done between values in a lookup table +! computed in gtlcl. See documentation for ftlclx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin. +! On the Cray, ftlcl is ? times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlcl(t,tdpd) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlcl Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlcl + real(krealfp),intent(in):: t,tdpd + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) + yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) + jx=min(xj,nxtlcl-1._krealfp) + jy=min(yj,nytlcl-1._krealfp) + ftx1=tbtlcl(jx,jy)+(xj-jx)*(tbtlcl(jx+1,jy)-tbtlcl(jx,jy)) + ftx2=tbtlcl(jx,jy+1)+(xj-jx)*(tbtlcl(jx+1,jy+1)-tbtlcl(jx,jy+1)) + ftlcl=ftx1+(yj-jy)*(ftx2-ftx1) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftlclq(t,tdpd) + function ftlclq(t,tdpd) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftlclq Compute LCL temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. +! A biquadratic interpolation is done between values in a lookup table +! computed in gtlcl. see documentation for ftlclx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.000003 Kelvin. +! On the Cray, ftlclq is ? times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlclq(t,tdpd) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlcl Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclq + real(krealfp),intent(in):: t,tdpd + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) + yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) + jx=min(max(nint(xj),2),nxtlcl-1) + jy=min(max(nint(yj),2),nytlcl-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbtlcl(jx-1,jy-1) + ft12=tbtlcl(jx-1,jy) + ft13=tbtlcl(jx-1,jy+1) + ft21=tbtlcl(jx,jy-1) + ft22=tbtlcl(jx,jy) + ft23=tbtlcl(jx,jy+1) + ft31=tbtlcl(jx+1,jy-1) + ft32=tbtlcl(jx+1,jy) + ft33=tbtlcl(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + ftlclq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + function ftlclo(t,tdpd) +!$$$ Subprogram documentation block +! +! Subprogram: ftlclo Compute LCL temperature. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. the formula used is +! a polynomial taken from Phillips mstadb routine which empirically +! approximates the original exact implicit relationship. +! (This kind of approximation is customary (inman, 1969), but +! the original source for this particular one is not yet known. -MI) +! Its accuracy is about 0.03 Kelvin for a dewpoint depression of 30. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlclo(t,tdpd) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlclo Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclo + real(krealfp),intent(in):: t,tdpd + real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& + clcl3=-0.710321e-3,clcl4=-0.270742e-5 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function ftlclx(t,tdpd) + function ftlclx(t,tdpd) +!$$$ Subprogram documentation block +! +! Subprogram: ftlclx Compute LCL temperature. +! Author: Iredell org: w/NMC2X2 Date: 25 March 1999 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. A parcel lifted +! adiabatically becomes saturated at the lifting condensation level. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formulas +! pvlcl=con_psat*(trlcl**xa)*exp(xb*(1.-trlcl)) +! pvdew=con_psat*(trdew**xa)*exp(xb*(1.-trdew)) +! where pvlcl is the saturated parcel vapor pressure at the LCL, +! pvdew is the unsaturated parcel vapor pressure initially, +! trlcl is ttp/tlcl and trdew is ttp/tdew. The adiabatic lifting +! of the parcel is represented by the following formula +! pvdew=pvlcl*(t/tlcl)**(1/kappa) +! This formula is inverted by iterating Newtonian approximations +! until tlcl is found to within 1.e-6 Kelvin. Note that the minimum +! returned temperature is 180 Kelvin. +! +! Program History Log: +! 1999-03-25 Iredell +! +! Usage: tlcl=ftlclx(t,tdpd) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlclx Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclx + real(krealfp),intent(in):: t,tdpd + real(krealfp),parameter:: terrm=1.e-4,tlmin=180.,tlminx=tlmin-5. + real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr,terrp + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/(t-tdpd) + pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + tlcl=t-tdpd + do i=1,100 + tr=con_ttp/tlcl + ta=t/tlcl + pvlcl=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr))*ta**(1/con_rocp) + el=con_hvap+con_dldt*(tlcl-con_ttp) + dpvlcl=(el/(con_rv*t**2)+1/(con_rocp*tlcl))*pvlcl + terr=(pvlcl-pvdew)/dpvlcl + tlcl=tlcl-terr + if(abs(terr).le.terrm.or.tlcl.lt.tlminx) exit + enddo + ftlclx=max(tlcl,tlmin) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gfuncphys +!$$$ Subprogram Documentation Block +! +! Subprogram: gfuncphys Compute all physics function tables +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute all physics function tables. Lookup tables are +! set up for computing saturation vapor pressure, dewpoint temperature, +! equivalent potential temperature, moist adiabatic temperature and humidity, +! pressure to the kappa, and lifting condensation level temperature. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: call gfuncphys +! +! Subprograms called: +! gpvsl compute saturation vapor pressure over liquid table +! gpvsi compute saturation vapor pressure over ice table +! gpvs compute saturation vapor pressure table +! gtdpl compute dewpoint temperature over liquid table +! gtdpi compute dewpoint temperature over ice table +! gtdp compute dewpoint temperature table +! gthe compute equivalent potential temperature table +! gtma compute moist adiabat tables +! gpkap compute pressure to the kappa table +! grkap compute pressure to the 1/kappa table +! gtlcl compute LCL temperature table +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call gpvsl + call gpvsi + call gpvs + call gtdpl + call gtdpi + call gtdp + call gthe + call gtma + call gpkap + call grkap + call gtlcl +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +end module module_gfs_funcphys diff --git a/wrfv2_fire/phys/module_gfs_machine.F b/wrfv2_fire/phys/module_gfs_machine.F new file mode 100755 index 00000000..a6a85b79 --- /dev/null +++ b/wrfv2_fire/phys/module_gfs_machine.F @@ -0,0 +1,16 @@ + MODULE MODULE_GFS_MACHINE + + IMPLICIT NONE + SAVE +! Machine dependant constants + integer kind_io4,kind_io8,kind_phys,kind_rad,kind_evod + parameter (kind_rad = selected_real_kind(13,60)) ! the '60' maps to 64-bit real + parameter (kind_phys = selected_real_kind(13,60)) ! the '60' maps to 64-bit real + parameter (kind_io4 = 4) + parameter (kind_io8 = 8) + parameter (kind_evod = 8) + + real(kind=kind_evod) mprec ! machine precision to restrict dep + parameter(mprec = 1.e-12 ) + + END MODULE MODULE_GFS_MACHINE diff --git a/wrfv2_fire/phys/module_gfs_physcons.F b/wrfv2_fire/phys/module_gfs_physcons.F new file mode 100755 index 00000000..1f67d0a3 --- /dev/null +++ b/wrfv2_fire/phys/module_gfs_physcons.F @@ -0,0 +1,40 @@ +module module_gfs_physcons + use module_gfs_machine,only:kind_phys +! Physical constants as set in NMC handbook from Smithsonian tables. +! Physical constants are given to 5 places. +! 1990/04/30: g and rd are made consistent with NWS usage. +! 2001/10/22: g made consistent with SI usage. +! Math constants + real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 ! pi + real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 ! square root of 2 + real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0 ! square root of 3 +! Primary constants + real(kind=kind_phys),parameter:: con_rerth =6.3712e+6 ! radius of earth (m) + real(kind=kind_phys),parameter:: con_g =9.80665e+0! gravity (m/s2) + real(kind=kind_phys),parameter:: con_omega =7.2921e-5 ! ang vel of earth (1/s) + real(kind=kind_phys),parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K) + real(kind=kind_phys),parameter:: con_rv =4.6150e+2 ! gas constant H2O (J/kg/K) + real(kind=kind_phys),parameter:: con_cp =1.0046e+3 ! spec heat air @p (J/kg/K) + real(kind=kind_phys),parameter:: con_cv =7.1760e+2 ! spec heat air @v (J/kg/K) + real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K) + real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq (J/kg/K) + real(kind=kind_phys),parameter:: con_csol =2.1060e+3 ! spec heat H2O ice (J/kg/K) + real(kind=kind_phys),parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond (J/kg) + real(kind=kind_phys),parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion (J/kg) + real(kind=kind_phys),parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt (Pa) + real(kind=kind_phys),parameter:: con_sbc =5.6730e-8 ! stefan-boltzmann (W/m2/K4) + real(kind=kind_phys),parameter:: con_solr =1.3533e+3 ! solar constant (W/m2) + real(kind=kind_phys),parameter:: con_t0c =2.7315e+2 ! temp at 0C (K) + real(kind=kind_phys),parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt (K) + real(kind=kind_phys),parameter:: con_jcal =4.1855E+0 ! JOULES PER CALORIE () +! Secondary constants + real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp + real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd + real(kind=kind_phys),parameter:: con_rog =con_rd/con_g + real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. + real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv + real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. + real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq + real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv + real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) +end module module_gfs_physcons diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F new file mode 100644 index 00000000..512ac171 --- /dev/null +++ b/wrfv2_fire/phys/module_microphysics_driver.F @@ -0,0 +1,622 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! *** add new modules of schemes here +! +MODULE module_microphysics_driver +CONTAINS + +SUBROUTINE microphysics_driver( & + th, rho, pi_phy, p & + ,ht, dz8w, p8w, dt,dx,dy & + ,mp_physics, spec_zone & + ,specified, channel_switch & + ,warm_rain & + ,t8w & + ,cldfra, cldfra_old, exch_h, nsource & + ,qlsink, precr, preci, precs, precg & + ,xland,itimestep & + ,f_ice_phy,f_rain_phy,f_rimef_phy & + ,lowlyr,sr, id & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,i_start,i_end,j_start,j_end,kts,kte & + ,num_tiles, naer & + ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & + ,qndrop_curr,qni_curr & + ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni & + ,qt_curr,f_qt & + ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew + ,w ,z & + ,rainnc, rainncv & + ,snownc, snowncv & + ,graupelnc, graupelncv & + ) +! Framework + USE module_state_description, ONLY : & + KESSLERSCHEME, LINSCHEME, WSM3SCHEME, WSM5SCHEME & + ,WSM6SCHEME, ETAMPNEW, NCEPCLOUD3, NCEPCLOUD5, THOMPSON + + +! Model Layer + USE module_model_constants + USE module_wrf_error + +! *** add new modules of schemes here + + USE module_mp_kessler + USE module_mp_lin + USE module_mp_ncloud3 + USE module_mp_ncloud5 + USE module_mp_wsm3 + USE module_mp_wsm5 + USE module_mp_wsm6 + USE module_mp_etanew + USE module_mp_thompson + USE module_mixactivate, only: prescribe_aerosol_mixactivate + +!---------------------------------------------------------------------- + ! This driver calls subroutines for the microphys. + ! + ! Schemes + ! + ! Kessler scheme + ! Lin et al. (1983), Rutledge and Hobbs (1984) + ! WRF Single-Moment 3-class, Hong, Dudhia and Chen (2004) + ! WRF Single-Moment 5-class, Hong, Dudhia and Chen (2004) + ! WRF Single-Moment 6-class, Lim and Hong (2003 WRF workshop) + ! Eta Grid-scale Cloud and Precipitation scheme (EGCP01, Ferrier) + ! NCEP cloud3, Hong et al. (1998) with some mod, Dudhia (1989) + ! NCEP cloud5, Hong et al. (1998) with some mod, Rutledge and Hobbs (1984) + ! +!---------------------------------------------------------------------- + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +! Rho_d dry density (kg/m^3) +! Theta_m moist potential temperature (K) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +! Qndrop droplet number mixing ratio (#/kg) +! Qni cloud ice number concentration (#/kg) +! +!---------------------------------------------------------------------- +!-- th potential temperature (K) +!-- moist_new updated moisture array (kg/kg) +!-- moist_old Old moisture array (kg/kg) +!-- rho density of air (kg/m^3) +!-- pi_phy exner function (dimensionless) +!-- p pressure (Pa) +!-- RAINNC grid scale precipitation (mm) +!-- RAINNCV one time step grid scale precipitation (mm/step) +!-- SNOWNC grid scale snow and ice (mm) +!-- SNOWNCV one time step grid scale snow and ice (mm/step) +!-- GRAUPELNC grid scale graupel (mm) +!-- GRAUPELNCV one time step grid scale graupel (mm/step) +!-- SR one time step mass ratio of snow to total precip +!-- z Height above sea level (m) +!-- dt Time step (s) +!-- G acceleration due to gravity (m/s^2) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- R_d gas constant for dry air (J/kg/K) +!-- R_v gas constant for water vapor (J/kg/K) +!-- XLS latent heat of sublimation (J/kg) +!-- XLV latent heat of vaporization (J/kg) +!-- XLF latent heat of melting (J/kg) +!-- rhowater water density (kg/m^3) +!-- rhosnow snow density (kg/m^3) +!-- F_ICE_PHY Fraction of ice. +!-- F_RAIN_PHY Fraction of rain. +!-- F_RIMEF_PHY Mass ratio of rimed ice (rime factor) +!-- t8w temperature at layer interfaces +!-- cldfra, cldfra_old, current, previous cloud fraction +!-- exch_h vertical diffusivity (m2/s) +!-- qlsink Fractional cloud water sink (/s) +!-- precr rain precipitation rate at all levels (kg/m2/s) +!-- preci ice precipitation rate at all levels (kg/m2/s) +!-- precs snow precipitation rate at all levels (kg/m2/s) +!-- precg graupel precipitation rate at all levels (kg/m2/s) & +!-- P_QV species index for water vapor +!-- P_QC species index for cloud water +!-- P_QR species index for rain water +!-- P_QI species index for cloud ice +!-- P_QS species index for snow +!-- P_QG species index for graupel +!-- P_QNDROP species index for cloud drop mixing ratio +!-- P_QNI species index for cloud ice number concentration +!-- id grid id number +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- i_start start indices for i in tile +!-- i_end end indices for i in tile +!-- j_start start indices for j in tile +!-- j_end end indices for j in tile +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- num_tiles number of tiles +! +!====================================================================== + + INTEGER, INTENT(IN ) :: mp_physics + LOGICAL, INTENT(IN ) :: specified +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: kts,kte + INTEGER, INTENT(IN ) :: itimestep,num_tiles,spec_zone + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + LOGICAL, INTENT(IN ) :: warm_rain +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: th +! + +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + rho, & + dz8w, & + p8w, & + pi_phy, & + p + + + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY +!!$#ifdef WRF_CHEM +! REAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & +!!$#else +!!$ REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: & +!!$#endif + qlsink, & ! cloud water sink (/s) + precr, & ! rain precipitation rate at all levels (kg/m2/s) + preci, & ! ice precipitation rate at all levels (kg/m2/s) + precs, & ! snow precipitation rate at all levels (kg/m2/s) + precg ! graupel precipitation rate at all levels (kg/m2/s) + +! + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAND + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: SR + + REAL, INTENT(IN ) :: dt,dx,dy + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: LOWLYR + +! +! Optional +! + LOGICAL, OPTIONAL, INTENT(IN ) :: channel_switch + REAL, OPTIONAL, INTENT(INOUT ) :: naer ! aerosol number concentration (/kg) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(INOUT ) :: & + w, z, t8w & + ,cldfra, cldfra_old, exch_h & + ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & + ,qt_curr,qndrop_curr,qni_curr + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(OUT ) :: & + nsource + +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT), & + OPTIONAL :: & + RAINNC & + ,RAINNCV & + ,SNOWNC & + ,SNOWNCV & + ,GRAUPELNC & + ,GRAUPELNCV + INTEGER,OPTIONAL,INTENT(IN ) :: id + + REAL , DIMENSION( ims:ime , jms:jme ) , OPTIONAL , & + INTENT(IN) :: ht + + REAL, DIMENSION (:), OPTIONAL, INTENT(INOUT) :: mp_restart_state & + ,tbpvs_state,tbpvs0_state +! + + LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni,f_qt + + +! LOCAL VAR + + INTEGER :: i,j,k,its,ite,jts,jte,ij,sz,n + LOGICAL :: channel + +!--------------------------------------------------------------------- +! check for microphysics type. We need a clean way to +! specify these things! +!--------------------------------------------------------------------- + + channel = .FALSE. + IF ( PRESENT ( channel_switch ) ) channel = channel_switch + + if (mp_physics .eq. 0) return + IF( specified ) THEN + sz = spec_zone + ELSE + sz = 0 + ENDIF + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, its, ite, jts, jte, i,j,k,n ) + + DO ij = 1 , num_tiles + + IF (channel) THEN + its = max(i_start(ij),ids) + ite = min(i_end(ij),ide-1) + ELSE + its = max(i_start(ij),ids+sz) + ite = min(i_end(ij),ide-1-sz) + ENDIF + jts = max(j_start(ij),jds+sz) + jte = min(j_end(ij),jde-1-sz) + + IF( PRESENT(qlsink) ) qlsink(its:ite,kts:kte,jts:jte) = 0. + +!----------- +#ifndef WRF_CHEM + IF( PRESENT( QNDROP_CURR ) ) THEN + IF( F_QNDROP .AND. mp_physics==LINSCHEME ) THEN + CALL wrf_debug ( 100 , 'microphysics_driver: calling prescribe_aerosol_mixactivate' ) +! 06-nov-2005 rce - id & itimestep added to arg list + call prescribe_aerosol_mixactivate ( & + id, itimestep, dt, naer, & + rho, th, pi_phy, w, cldfra, cldfra_old, & + z, dz8w, p8w, t8w, exch_h, & + qv_curr, qc_curr, qi_curr, qndrop_curr, & + nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + F_QC=f_qc, F_QI=f_qi ) + ELSE IF( F_QNDROP ) THEN + call wrf_error_fatal("SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME.") + END IF + END IF +#endif + + micro_select: SELECT CASE(mp_physics) + + CASE (KESSLERSCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling kessler' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( Z )) THEN + CALL kessler( & + T=th & + ,QV=qv_curr & + ,QC=qc_curr & + ,QR=qr_curr & + ,RHO=rho, PII=pi_phy,DT_IN=dt, Z=z, XLV=xlv, CP=cp & + ,EP2=ep_2,SVP1=svp1,SVP2=svp2 & + ,SVP3=svp3,SVPT0=svpt0,RHOWATER=rhowater & + ,DZ8W=dz8w & + ,RAINNC=rainnc,RAINNCV=rainncv & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling kessler' ) + ENDIF + +! + CASE (THOMPSON) + CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson et al' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & + PRESENT ( QNI_CURR ).AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN + CALL mp_gt_driver( & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QG=qg_curr, & + NI=qni_curr, & + TH=th, & + PII=pi_phy, & + P=p, & + DZ=dz8w, & + DT_IN=dt, & + ITIMESTEP=itimestep, & + RAINNC=RAINNC, & + RAINNCV=RAINNCV, & + SR=SR & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' ) + ENDIF +! + CASE (LINSCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling lin_et_al' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( Z ) ) THEN + CALL lin_et_al( & + TH=th & + ,QV=qv_curr & + ,QL=qc_curr & + ,QR=qr_curr & + ,QI=qi_curr & + ,QS=qs_curr & + ,QLSINK=qlsink & + ,RHO=rho, PII=pi_phy, P=p, DT_IN=dt, Z=z & + ,HT=ht, DZ8W=dz8w, GRAV=G, CP=cp & + ,RAIR=r_d, RVAPOR=R_v & + ,XLS=xls, XLV=xlv, XLF=xlf & + ,RHOWATER=rhowater, RHOSNOW=rhosnow & + ,EP2=ep_2,SVP1=svp1,SVP2=svp2 & + ,SVP3=svp3,SVPT0=svpt0 & + ,RAINNC=rainnc, RAINNCV=rainncv & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ,PRECR=precr,PRECI=preci,PRECS=precs,PRECG=precg & + ,F_QG=f_qg, F_QNDROP=f_qndrop & + ,QG=qg_curr & + ,QNDROP=qndrop_curr & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling lin_et_al' ) + ENDIF + + CASE (WSM3SCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm3' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( W ) ) THEN + CALL wsm3( & + TH=th & + ,Q=qv_curr & + ,QCI=qc_curr & + ,QRS=qr_curr & + ,W=w,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv & + ,RD=r_d,RV=r_v,T0C=svpt0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,RAIN=rainnc ,RAINNCV=rainncv & + ,SNOW=snownc ,SNOWNCV=snowncv & + ,SR=sr & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling wsm3' ) + ENDIF + + CASE (WSM5SCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm5' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN + CALL wsm5( & + TH=th & + ,Q=qv_curr & + ,QC=qc_curr & + ,QR=qr_curr & + ,QI=qi_curr & + ,QS=qs_curr & + ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv & + ,RD=r_d,RV=r_v,T0C=svpt0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,RAIN=rainnc ,RAINNCV=rainncv & + ,SNOW=snownc ,SNOWNCV=snowncv & + ,SR=sr & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling wsm5' ) + ENDIF + + CASE (WSM6SCHEME) + CALL wrf_debug ( 100 , 'microphysics_driver: calling wsm6' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN + CALL wsm6( & + TH=th & + ,Q=qv_curr & + ,QC=qc_curr & + ,QR=qr_curr & + ,QI=qi_curr & + ,QS=qs_curr & + ,QG=qg_curr & + ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv & + ,RD=r_d,RV=r_v,T0C=svpt0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,RAIN=rainnc ,RAINNCV=rainncv & + ,SNOW=snownc ,SNOWNCV=snowncv & + ,SR=sr & + ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling wsm6' ) + ENDIF + + CASE (ETAMPNEW) + CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') + + IF ( PRESENT( qv_curr ) .AND. PRESENT( qt_curr ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( mp_restart_state ) .AND. & + PRESENT( tbpvs_state ) .AND. & + PRESENT( tbpvs0_state ) ) THEN + CALL ETAMP_NEW( & + ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy & + ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & + ,QV=qv_curr & + ,QC=qc_curr & + ,QS=qs_curr & + ,QR=qr_curr & + ,QT=qt_curr & + ,LOWLYR=LOWLYR,SR=SR & + ,F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY & + ,F_RIMEF_PHY=F_RIMEF_PHY & + ,RAINNC=rainnc,RAINNCV=rainncv & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ,MP_RESTART_STATE=mp_restart_state & + ,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling etampnew' ) + ENDIF + + CASE (NCEPCLOUD3) + CALL wrf_debug ( 100 , 'microphysics_driver: calling ncloud3' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( W ) ) THEN + CALL ncloud3( & + TH=th & + ,Q=qv_curr & + ,QCI=qc_curr & + ,QRS=qr_curr & + ,W=w, DEN=rho, PII=pi_phy, P=p, DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv & + ,RD=r_d,RV=r_v,T0C=SVPT0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,RAIN=RAINNC,RAINNCV=RAINNCV & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling ncepcloud3' ) + ENDIF + + CASE (NCEPCLOUD5) + CALL wrf_debug ( 100 , 'microphysics_driver: calling ncloud5' ) + IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & + PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & + PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( W ) ) THEN + CALL ncloud5( & + TH=th & + ,Q=qv_curr & + ,QC=qc_curr & + ,QR=qr_curr & + ,QI=qi_curr & + ,QS=qs_curr & + ,W=w, DEN=rho, PII=pi_phy, P=p, DELZ=dz8w & + ,DELT=dt,G=g,CPD=cp,CPV=cpv & + ,RD=r_d,RV=r_v,T0C=SVPT0 & + ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & + ,XLS=xls, XLV0=xlv, XLF0=xlf & + ,DEN0=rhoair0, DENR=rhowater & + ,CLIQ=cliq,CICE=cice,PSAT=psat & + ,RAIN=RAINNC,RAINNCV=RAINNCV & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling ncepcloud5' ) + ENDIF + + + CASE DEFAULT + + WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', mp_physics + CALL wrf_error_fatal ( wrf_err_message ) + + END SELECT micro_select + + ENDDO + !$OMP END PARALLEL DO + + CALL wrf_debug ( 200 , 'microphysics_driver: returning from' ) + + RETURN + + END SUBROUTINE microphysics_driver + +END MODULE module_microphysics_driver + diff --git a/wrfv2_fire/phys/module_microphysics_zero_out.F b/wrfv2_fire/phys/module_microphysics_zero_out.F new file mode 100644 index 00000000..020b7a05 --- /dev/null +++ b/wrfv2_fire/phys/module_microphysics_zero_out.F @@ -0,0 +1,128 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! +MODULE module_microphysics_zero_out +CONTAINS + +SUBROUTINE microphysics_zero_out ( & + moist_new , n_moist & + ,config_flags & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte ) + + + USE module_state_description + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: n_moist + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ) :: moist_new + +! Local + + INTEGER i,j,k,n + + + ! Zero out small condensate values FSL-BLS-12-JUL-2004 + + IF ( config_flags%mp_zero_out .EQ. 0 ) THEN + ! do nothing + ELSE IF ( config_flags%mp_zero_out .EQ. 1 ) THEN + ! All of the "moist" fields, except for vapor, that are below a critical + ! threshold are set to zero. + CALL wrf_debug ( 100 , 'zero out small condensates, vapor not included') + DO n = PARAM_FIRST_SCALAR,n_moist + IF ( n .NE. P_QV ) THEN + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + IF ( moist_new(i,k,j,n) .LT. config_flags%mp_zero_out_thresh ) moist_new(i,k,j,n) =0. + ENDDO + ENDDO + ENDDO + END IF + ENDDO + ELSE IF ( config_flags%mp_zero_out .EQ. 2 ) then + ! All of the non-Qv "moist" fields that are below a critical threshold are set to + ! zero. The vapor is constrained to be non-negative. + CALL wrf_debug ( 100 , 'zero out small condensates, zero out negative vapor') + DO n = PARAM_FIRST_SCALAR,n_moist + IF ( n .NE. P_QV ) THEN + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + IF ( moist_new(i,k,j,n) .LT. config_flags%mp_zero_out_thresh ) moist_new(i,k,j,n) =0. + ENDDO + ENDDO + ENDDO + ELSE IF ( n .EQ. P_QV ) THEN + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + moist_new(i,k,j,n) = MAX ( moist_new(i,k,j,n) , 0. ) + ENDDO + ENDDO + ENDDO + END IF + ENDDO + END IF + + ! Make sure that the boundary is .GE. 0 if the config_flags%mp_zero_out option is selected (1 or 2) + ! Just do the outer row/col, no interior points. + + IF ( config_flags%mp_zero_out .NE. 0 ) THEN + DO n = PARAM_FIRST_SCALAR,n_moist + ! bottom row + j = jds + IF ( ( j .GE. jts ) .AND. ( j .LE. MIN( jte , jde-1) ) ) THEN + DO k = kts, kte + DO i = its , MIN ( ite , ide-1 ) + moist_new(i,k,j,n) = MAX ( moist_new(i,k,j,n) , 0. ) + ENDDO + ENDDO + END IF + ! top row + j = jde-1 + IF ( ( j .GE. jts ) .AND. ( j .LE. MIN( jte , jde-1) ) ) THEN + DO k = kts, kte + DO i = its , MIN ( ite , ide-1 ) + moist_new(i,k,j,n) = MAX ( moist_new(i,k,j,n) , 0. ) + ENDDO + ENDDO + END IF + ! left column + i = ids + IF ( ( i .GE. its ) .AND. ( i .LE. MIN( ite , ide-1) ) ) THEN + DO j = jts , MIN ( jte , jde-1 ) + DO k = kts, kte + moist_new(i,k,j,n) = MAX ( moist_new(i,k,j,n) , 0. ) + ENDDO + ENDDO + END IF + ! right column + i = ide-1 + IF ( ( i .GE. its ) .AND. ( i .LE. MIN( ite , ide-1) ) ) THEN + DO j = jts , MIN ( jte , jde-1 ) + DO k = kts, kte + moist_new(i,k,j,n) = MAX ( moist_new(i,k,j,n) , 0. ) + ENDDO + ENDDO + END IF + ENDDO + END IF + + RETURN + + END SUBROUTINE microphysics_zero_out + +END MODULE module_microphysics_zero_out + + + diff --git a/wrfv2_fire/phys/module_mixactivate.F b/wrfv2_fire/phys/module_mixactivate.F new file mode 100644 index 00000000..9ecc0064 --- /dev/null +++ b/wrfv2_fire/phys/module_mixactivate.F @@ -0,0 +1,2478 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for information and terms of use +!********************************************************************************** + +MODULE module_mixactivate + +CONTAINS + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! 06-nov-2005 rce - grid_id & ktau added to arg list +! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3) + subroutine prescribe_aerosol_mixactivate ( & + grid_id, ktau, dtstep, naer, & + rho_phy, th_phy, pi_phy, w, cldfra, cldfra_old, & + z, dz8w, p_at_w, t_at_w, exch_h, & + qv, qc, qi, qndrop3d, & + nsource, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + f_qc, f_qi ) + +! USE module_configure + +! wrapper to call mixactivate for mosaic description of aerosol + + implicit none + +! subr arguments + integer, intent(in) :: & + grid_id, ktau, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + real, intent(in) :: dtstep + real, intent(inout) :: naer ! aerosol number (/kg) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + rho_phy, th_phy, pi_phy, w, & + z, dz8w, p_at_w, t_at_w, exch_h + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d + + real, intent(out), & + dimension( ims:ime, kms:kme, jms:jme) :: nsource + + LOGICAL, OPTIONAL :: f_qc, f_qi + +! local vars + integer maxd_aphase, maxd_atype, maxd_asize, maxd_acomp, max_chem + parameter (maxd_aphase=2,maxd_atype=1,maxd_asize=1,maxd_acomp=1, max_chem=10) + real ddvel(its:ite, jts:jte, max_chem) ! dry deposition velosity + real qsrflx(ims:ime, jms:jme, max_chem) ! dry deposition flux of aerosol + real chem(ims:ime, kms:kme, jms:jme, max_chem) ! chem array + integer i,j,k,l,m,n,p + real hygro( its:ite, kts:kte, jts:jte, maxd_asize, maxd_atype ) ! bulk + integer ntype_aer, nsize_aer(maxd_atype),ncomp_aer(maxd_atype), nphase_aer + integer massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + waterptr_aer( maxd_asize, maxd_atype ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + ai_phase, cw_phase + real dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) + dhi_sect( maxd_asize, maxd_atype ), & ! maximum size of section (cm) + sigmag_aer(maxd_asize, maxd_atype), & ! geometric standard deviation of aerosol size dist + dgnum_aer(maxd_asize, maxd_atype), & ! mean diameter (cm) of mode + dens_aer( maxd_acomp, maxd_atype), & ! density (g/cm3) of material + mw_aer( maxd_acomp, maxd_atype) ! molecular weight (g/mole) + real, dimension(ims:ime,kms:kme,jms:jme) :: & + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + integer idrydep_onoff + real, dimension(ims:ime,kms:kme,jms:jme) :: t_phy + integer msectional + + + integer ptr + real maer + + if(naer.lt.1.)then + naer=1000.e6 ! #/kg default value + endif + ai_phase=1 + cw_phase=2 + idrydep_onoff = 0 + msectional = 0 + + t_phy(:,:,:)=th_phy(:,:,:)*pi_phy(:,:,:) + + ntype_aer=maxd_atype + do n=1,ntype_aer + nsize_aer(n)=maxd_asize + ncomp_aer(n)=maxd_acomp + end do + nphase_aer=maxd_aphase + +! set properties for each type and size + do n=1,ntype_aer + do m=1,nsize_aer(n) + dlo_sect( m,n )=0.01e-4 ! minimum size of section (cm) + dhi_sect( m,n )=0.5e-4 ! maximum size of section (cm) + sigmag_aer(m,n)=2. ! geometric standard deviation of aerosol size dist + dgnum_aer(m,n)=0.1e-4 ! mean diameter (cm) of mode + end do + do l=1,ncomp_aer(n) + dens_aer( l, n)=1.0 ! density (g/cm3) of material + mw_aer( l, n)=132. ! molecular weight (g/mole) + end do + end do + ptr=0 + do p=1,nphase_aer + do n=1,ntype_aer + do m=1,nsize_aer(n) + ptr=ptr+1 + numptr_aer( m, n, p )=ptr + if(p.eq.ai_phase)then + chem(:,:,:,ptr)=naer + else + chem(:,:,:,ptr)=0 + endif + end do ! size + end do ! type + end do ! phase + do p=1,maxd_aphase + do n=1,ntype_aer + do m=1,nsize_aer(n) + do l=1,ncomp_aer(n) + ptr=ptr+1 + if(ptr.gt.max_chem)then + write(6,*)'ptr,max_chem=',ptr,max_chem,' in prescribe_aerosol_mixactivate' + call exit(1) + endif + massptr_aer(l, m, n, p)=ptr +! maer is ug/kg-air; naer is #/kg-air; dgnum is cm; dens_aer is g/cm3 +! 1.e6 factor converts g to ug + maer= 1.0e6 * naer * dens_aer(l,n) * ( (3.1416/6.) * & + (dgnum_aer(m,n)**3) * exp( 4.5*((log(sigmag_aer(m,n)))**2) ) ) + if(p.eq.ai_phase)then + chem(:,:,:,ptr)=maer + else + chem(:,:,:,ptr)=0 + endif + end do + end do ! size + end do ! type + end do ! phase + do n=1,ntype_aer + do m=1,nsize_aer(n) + ptr=ptr+1 + if(ptr.gt.max_chem)then + write(6,*)'ptr,max_chem=',ptr,max_chem,' in prescribe_aerosol_mixactivate' + call exit(1) + endif +!wig waterptr_aer(m, n)=ptr + waterptr_aer(m, n)=-1 + end do ! size + end do ! type + ddvel(:,:,:)=0. + hygro( :,:,:,:,:) = 0.5 + +! 06-nov-2005 rce - grid_id & ktau added to arg list + call mixactivate( msectional, & + chem,max_chem,qv,qc,qi,qndrop3d, & + t_phy, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dgnum_aer, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ims,ime, jms,jme, & + kms,kme, & + its,ite, jts,jte, kts,kte, & + rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + grid_id, ktau, dtstep, & + F_QC=f_qc, F_QI=f_qi ) + + + end subroutine prescribe_aerosol_mixactivate + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! nov-04 sg ! replaced amode with aer and expanded aerosol dimension to include type and phase + +! 06-nov-2005 rce - grid_id & ktau added to arg list +! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3) +subroutine mixactivate( msectional, & + chem, num_chem, qv, qc, qi, qndrop3d, & + temp, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dgnum_aer, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + rho, zm, dz8w, p_at_w, t_at_w, kvh, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + grid_id, ktau, dtstep, & + f_qc, f_qi ) + + +! vertical diffusion and nucleation of cloud droplets +! assume cloud presence controlled by cloud fraction +! doesn't distinguish between warm, cold clouds + + USE module_model_constants, only: g, rhowater, xlv, cp, rvovrd, r_d, r_v, mwdry, ep_2 + USE module_radiation_driver, only: cal_cldfra + + implicit none + +! input + + INTEGER, intent(in) :: grid_id, ktau + INTEGER, intent(in) :: num_chem + integer, intent(in) :: ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + integer maxd_aphase, nphase_aer, maxd_atype, ntype_aer + integer maxd_asize, maxd_acomp, nsize_aer(maxd_atype) + integer, intent(in) :: & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + waterptr_aer( maxd_asize, maxd_atype ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase), & + ai_phase, cw_phase + integer, intent(in) :: msectional ! 1 for sectional, 0 for modal + integer, intent(in) :: idrydep_onoff + real, intent(in) :: & + dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) + dhi_sect( maxd_asize, maxd_atype ), & ! maximum size of section (cm) + sigmag_aer(maxd_asize, maxd_atype), & ! geometric standard deviation of aerosol size dist + dgnum_aer(maxd_asize, maxd_atype), & ! mean diameter (cm) of mode + dens_aer( maxd_acomp, maxd_atype), & ! density (g/cm3) of material + mw_aer( maxd_acomp, maxd_atype) ! molecular weight (g/mole) + + + REAL, intent(inout), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) :: & + chem ! aerosol molar mixing ratio (ug/kg or #/kg) + + REAL, intent(in), DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi ! water species (vapor, cloud drops, cloud ice) mixing ratio (g/g) + + LOGICAL, OPTIONAL :: f_qc, f_qi + + REAL, intent(inout), DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d ! water species mixing ratio (g/g) + + real, intent(in) :: dtstep ! time step for microphysics (s) + real, intent(in) :: temp(ims:ime, kms:kme, jms:jme) ! temperature (K) + real, intent(in) :: w(ims:ime, kms:kme, jms:jme) ! vertical velocity (m/s) + real, intent(in) :: rho(ims:ime, kms:kme, jms:jme) ! density at mid-level (kg/m3) + REAL, intent(in) :: ddvel( its:ite, jts:jte, num_chem ) ! deposition velocity (m/s) + real, intent(in) :: zm(ims:ime, kms:kme, jms:jme) ! geopotential height of level (m) + real, intent(in) :: dz8w(ims:ime, kms:kme, jms:jme) ! layer thickness (m) + real, intent(in) :: p_at_w(ims:ime, kms:kme, jms:jme) ! pressure at layer interface (Pa) + real, intent(in) :: t_at_w(ims:ime, kms:kme, jms:jme) ! temperature at layer interface (K) + real, intent(in) :: kvh(ims:ime, kms:kme, jms:jme) ! vertical diffusivity (m2/s) + real, intent(inout) :: cldfra_old(ims:ime, kms:kme, jms:jme)! cloud fraction on previous time step + real, intent(inout) :: cldfra(ims:ime, kms:kme, jms:jme) ! cloud fraction + real, intent(in) :: hygro( its:ite, kts:kte, jts:jte, maxd_asize, maxd_atype ) ! bulk hygroscopicity & + + REAL, intent(out), DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! dry deposition rate for aerosol + real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & ! droplet number source (#/kg/s) + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + +!--------------------Local storage------------------------------------- +! + real :: qndrop(kms:kme) ! cloud droplet number mixing ratio (#/kg) + real :: lcldfra(kms:kme) ! liquid cloud fraction + real :: lcldfra_old(kms:kme) ! liquid cloud fraction for previous timestep + real :: wtke(kms:kme) ! turbulent vertical velocity at base of layer k (m2/s) + real zn(kms:kme) ! g/pdel (m2/g) for layer + real zs(kms:kme) ! inverse of distance between levels (m) + real zkmin,zkmax + data zkmin/0.01/,zkmax/100./ + save zkmin,zkmax + real cs(kms:kme) ! air density (kg/m3) + real dz(kms:kme) ! geometric thickness of layers (m) + + real wdiab ! diabatic vertical velocity +! real, parameter :: wmixmin = 0.1 ! minimum turbulence vertical velocity (m/s) + real, parameter :: wmixmin = 0.2 ! minimum turbulence vertical velocity (m/s) +! real, parameter :: wmixmin = 1.0 ! minimum turbulence vertical velocity (m/s) + real :: qndrop_new(kms:kme) ! droplet number nucleated on cloud boundaries + real :: ekd(kms:kme) ! diffusivity for droplets (m2/s) + real :: ekk(kms:kme) ! density*diffusivity for droplets (kg/m3 m2/s) + real :: srcn(kms:kme) ! droplet source rate (/s) + real sq2pi + data sq2pi/2.5066282746/ + save sq2pi + real dtinv + + logical top ! true if cloud top, false if cloud base or new cloud + logical first + save first + data first/.true./ + integer km1,kp1 + real wbar,wmix,wmin,wmax + real cmincld + data cmincld/1.e-12/ + save cmincld + real dum,dumc + real dact + real fluxntot ! (#/cm2/s) + real fac_srflx + real depvel_drop + real :: surfrate(num_chem) ! surface exchange rate (/s) + real surfratemax ! max surfrate for all species treated here + real surfrate_drop ! surfade exchange rate for droplelts + real dtmin,tinv,dtt + integer nsubmix,nsubmix_bnd + integer i,j,k,m,n,nsub + real dtmix + real alogarg + real qcld + real pi + integer nnew,nsav,ntemp + real :: overlapp(kms:kme),overlapm(kms:kme) ! cloud overlap + real :: ekkp(kms:kme),ekkm(kms:kme) ! zn*zs*density*diffusivity + integer count_submix(100) + save count_submix + + integer lnum,lnumcw,l,lmass,lmasscw,lsfc,lsfccw,ltype,lsig,lwater + integer :: ntype(maxd_asize) + + real :: naerosol(maxd_asize, maxd_atype) ! interstitial aerosol number conc (/m3) + real :: naerosolcw(maxd_asize, maxd_atype) ! activated number conc (/m3) + real :: maerosol(maxd_acomp,maxd_asize, maxd_atype) ! interstit mass conc (kg/m3) + real :: maerosolcw(maxd_acomp,maxd_asize, maxd_atype) ! activated mass conc (kg/m3) + real :: maerosol_tot(maxd_asize, maxd_atype) ! species-total interstit mass conc (kg/m3) + real :: maerosol_totcw(maxd_asize, maxd_atype) ! species-total activated mass conc (kg/m3) + real :: vaerosol(maxd_asize, maxd_atype) ! interstit+activated aerosol volume conc (m3/m3) + real :: vaerosolcw(maxd_asize, maxd_atype) ! activated aerosol volume conc (m3/m3) + real :: raercol(kms:kme,num_chem,2) ! aerosol mass, number mixing ratios + real :: source(kms:kme) ! + + real :: fn(maxd_asize, maxd_atype) ! activation fraction for aerosol number + real :: fs(maxd_asize, maxd_atype) ! activation fraction for aerosol sfcarea + real :: fm(maxd_asize, maxd_atype) ! activation fraction for aerosol mass + integer :: ncomp(maxd_atype) + + real :: fluxn(maxd_asize, maxd_atype) ! number activation fraction flux (m/s) + real :: fluxs(maxd_asize, maxd_atype) ! sfcarea activation fraction flux (m/s) + real :: fluxm(maxd_asize, maxd_atype) ! mass activation fraction flux (m/s) +! note: activation fraction fluxes are defined as +! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] +! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] + + real :: nact(kms:kme,maxd_asize, maxd_atype) ! fractional aero. number activation rate (/s) + real :: mact(kms:kme,maxd_asize, maxd_atype) ! fractional aero. mass activation rate (/s) + real :: npv(maxd_asize, maxd_atype) ! number per volume concentration (/m3) + real scale + + real :: hygro_aer(maxd_asize, maxd_atype) ! hygroscopicity of aerosol mode + real :: exp45logsig ! exp(4.5*alogsig**2) + real :: alogsig(maxd_asize, maxd_atype) ! natl log of geometric standard dev of aerosol + integer psat + parameter (psat=6) ! number of supersaturations to calc ccn concentration + real ccn(kts:kte,psat) ! number conc of aerosols activated at supersat + real, parameter :: supersat(psat)= &! supersaturation (%) to determine ccn concentration + (/0.02,0.05,0.1,0.2,0.5,1.0/) + real super(psat) ! supersaturation + real surften ! surface tension of water w/respect to air (N/m) + data surften/0.076/ + save surften + real :: ccnfact(psat,maxd_asize, maxd_atype) + real :: amcube(maxd_asize, maxd_atype) ! cube of dry mode radius (m) + real :: argfactor(maxd_asize, maxd_atype) + real aten ! surface tension parameter + real t0 ! reference temperature + real sm ! critical supersaturation + real arg + +!!$#if (defined AIX) +!!$#define ERF erf +!!$#define ERFC erfc +!!$#else +!!$#define ERF erf +!!$ real erf +!!$#define ERFC erfc +!!$ real erfc +!!$#endif + + character*8, parameter :: ccn_name(psat)=(/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) + integer ids,ide, jds,jde, kds,kde + + arg = 1.0 + if (abs(0.8427-ERF_ALT(arg))/0.8427>0.001) then + write (6,*) 'erf_alt(1.0) = ',ERF_ALT(arg) + write (6,*) 'dropmixnuc: Error function error' + call exit + endif + arg = 0.0 + if (ERF_ALT(arg) /= 0.0) then + write (6,*) 'erf_alt(0.0) = ',ERF_ALT(arg) + write (6,*) 'dropmixnuc: Error function error' + call exit + endif + + pi = 4.*atan(1.0) + dtinv=1./dtstep + + depvel_drop = 0.1 ! prescribed here rather than getting it from dry_dep_driver + if (idrydep_onoff .le. 0) depvel_drop = 0.0 + + do n=1,ntype_aer + do m=1,nsize_aer(n) + ncomp(n)=ncomp_aer(n) +! print *,'sigmag_aer,dgnum_aer=',sigmag_aer(m,n),dgnum_aer(m,n) + alogsig(m,n)=alog(sigmag_aer(m,n)) + ! used only if number is diagnosed from volume + npv(m,n)=6./(pi*(0.01*dgnum_aer(m,n))**3*exp(4.5*alogsig(m,n)*alogsig(m,n))) + end do + end do + + t0=273. + aten=2.*surften/(r_v*t0*rhowater) + super(:)=0.01*supersat(:) + do n=1,ntype_aer + do m=1,nsize_aer(n) + exp45logsig=exp(4.5*alogsig(m,n)*alogsig(m,n)) + argfactor(m,n)=2./(3.*sqrt(2.)*alogsig(m,n)) + amcube(m,n)=3./(4.*pi*exp45logsig*npv(m,n)) + enddo + enddo + + IF( PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + CALL cal_cldfra(CLDFRA,qc,qi,f_qc,f_qi, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + END IF + + qsrflx(:,:,:) = 0. + +! start loop over columns + + do 120 j=jts,jte + do 100 i=its,ite + + raercol(:,:,:) = 0. !~ wig: added, but should not be necessary + fluxn(:,:) = 0. !~ + fluxs(:,:) = 0. !~ + fluxm(:,:) = 0. !~ + fn(:,:) = 0. !~ + fs(:,:) = 0. !~ + fm(:,:) = 0. !~ + +! load number nucleated into qndrop on cloud boundaries + +! initialization for current i ......................................... + + do k=kts+1,kte-1 + zs(k)=1./(zm(i,k,j)-zm(i,k-1,j)) + enddo + zs(kts)=zs(kts+1) + zs(kte)=0. + + do k=kts,kte-1 +!!$ if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then +!!$! call exit(1) +!!$ endif + if(f_qi)then + qcld=qc(i,k,j)+qi(i,k,j) + else + qcld=qc(i,k,j) + endif + if(qcld.lt.-1..or.qcld.gt.1.)then + write(6,'(a,g12.2,a,3i5)')'qcld=',qcld,' for i,k,j=',i,k,j + call exit(1) + endif + if(qcld.gt.1.e-20)then + lcldfra(k)=cldfra(i,k,j)*qc(i,k,j)/qcld + lcldfra_old(k)=cldfra_old(i,k,j)*qc(i,k,j)/qcld + else + lcldfra(k)=0. + lcldfra_old(k)=0. + endif + qndrop(k)=qndrop3d(i,k,j) +! qndrop(k)=1.e5 + cs(k)=rho(i,k,j) ! air density (kg/m3) + dz(k)=dz8w(i,k,j) + do n=1,ntype_aer + do m=1,nsize_aer(n) + nact(k,m,n)=0. + mact(k,m,n)=0. + enddo + enddo + zn(k)=1./(cs(k)*dz(k)) + if(k>kts)then + ekd(k)=kvh(i,k,j) + ekd(k)=max(ekd(k),zkmin) + ekd(k)=min(ekd(k),zkmax) + else + ekd(k)=0 + endif +! diagnose subgrid vertical velocity from diffusivity + if(k.eq.kts)then + wtke(k)=sq2pi*depvel_drop +! wtke(k)=sq2pi*kvh(i,k,j) +! wtke(k)=max(wtke(k),wmixmin) + else + wtke(k)=sq2pi*ekd(k)/dz(k) + endif + wtke(k)=max(wtke(k),wmixmin) + nsource(i,k,j)=0. + enddo + + ! calculate surface rate and mass mixing ratio for aerosol + + surfratemax = 0.0 + nsav=1 + nnew=2 + surfrate_drop=depvel_drop/dz(kts) + surfratemax = max( surfratemax, surfrate_drop ) + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum>0)then + surfrate(lnum)=ddvel(i,j,lnum)/dz(kts) + surfrate(lnumcw)=surfrate_drop + surfratemax = max( surfratemax, surfrate(lnum) ) +! scale = 1000./mwdry ! moles/kg + scale = 1. + raercol(kts:kte-1,lnumcw,nsav)=chem(i,kts:kte-1,j,lnumcw)*scale ! #/kg + raercol(kts:kte-1,lnum,nsav)=chem(i,kts:kte-1,j,lnum)*scale + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) +! scale = mw_aer(l,n)/mwdry + scale = 1.e-9 ! kg/ug + surfrate(lmass)=ddvel(i,j,lmass)/dz(kts) + surfrate(lmasscw)=surfrate_drop + surfratemax = max( surfratemax, surfrate(lmass) ) + raercol(kts:kte-1,lmasscw,nsav)=chem(i,kts:kte-1,j,lmasscw)*scale ! kg/kg + raercol(kts:kte-1,lmass,nsav)=chem(i,kts:kte-1,j,lmass)*scale ! kg/kg + enddo + lwater=waterptr_aer(m,n) + if(lwater>0)then + surfrate(lwater)=ddvel(i,j,lwater)/dz(kts) + surfratemax = max( surfratemax, surfrate(lwater) ) + raercol(kts:kte-1,lwater,nsav)=chem(i,kts:kte-1,j,lwater) ! don't bother to convert units, + ! because it doesn't contribute to aerosol mass + endif + enddo ! size + enddo ! type + + +! droplet nucleation/aerosol activation + +! k-loop for growing/shrinking cloud calcs ............................. + + do k=kts,kte-1 + km1=max0(k-1,1) + kp1=min0(k+1,kte-1) + + if(lcldfra(k)-lcldfra_old(k).gt.0.01)then +! go to 10 + +! growing cloud + +! wmix=wtke(k) + wbar=w(i,k,j)+wtke(k) + wmix=0. + wmin=0. +! 06-nov-2005 rce - increase wmax from 10 to 50 (deep convective clouds) + wmax=50. + wdiab=0 + +! load aerosol properties, assuming external mixtures + + do n=1,ntype_aer + do m=1,nsize_aer(n) + call loadaer(raercol(1,1,nsav),k,kms,kme,num_chem, & + cs(k), npv(m,n), dlo_sect(m,n),dhi_sect(m,n), & + maxd_acomp, ncomp(n), & + grid_id, ktau, i, j, m, n, & + numptr_aer(m,n,ai_phase),numptr_aer(m,n,cw_phase), & + dens_aer(1,n), & + massptr_aer(1,m,n,ai_phase), massptr_aer(1,m,n,cw_phase), & + maerosol(1,m,n), maerosolcw(1,m,n), & + maerosol_tot(m,n), maerosol_totcw(m,n), & + naerosol(m,n), naerosolcw(m,n), & + vaerosol(m,n), vaerosolcw(m,n) ) + + hygro_aer(m,n)=hygro(i,k,j,m,n) + enddo + enddo + +! 06-nov-2005 rce - grid_id & ktau added to arg list + call activate(wbar,wmix,wdiab,wmin,wmax,temp(i,k,j),cs(k), & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + naerosol, vaerosol, & + dlo_sect,dhi_sect,sigmag_aer,hygro_aer, & + fn,fs,fm,fluxn,fluxs,fluxm, grid_id, ktau, i, j, k ) + + dumc=(lcldfra(k)-lcldfra_old(k)) + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + dact=dumc*fn(m,n)*(raercol(k,lnum,nsav)) ! interstitial only +! print *,'fn=',fn(m,n),' for m,n=',m,n +! print *,'growing cloud dumc=',dumc,' fn=',fn(m,n) + qndrop(k)=qndrop(k)+dact + nsource(i,k,j)=nsource(i,k,j)+dact*dtinv + if(lnum.gt.0)then + raercol(k,lnumcw,nsav) = raercol(k,lnumcw,nsav)+dact + raercol(k,lnum,nsav) = raercol(k,lnum,nsav)-dact + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) +! rce 07-jul-2005 - changed dact for mass to mimic that used for number +! dact=dum*(raercol(k,lmass,nsav)) ! interstitial only + dact=dumc*fm(m,n)*(raercol(k,lmass,nsav)) ! interstitial only + raercol(k,lmasscw,nsav) = raercol(k,lmasscw,nsav)+dact + raercol(k,lmass,nsav) = raercol(k,lmass,nsav)-dact + enddo + enddo + enddo +! 10 continue + endif + + if(lcldfra(k) < lcldfra_old(k) .and. lcldfra_old(k) > 1.e-20)then +! go to 20 + +! shrinking cloud ...................................................... + +! droplet loss in decaying cloud + nsource(i,k,j)=nsource(i,k,j)+qndrop(k)*(lcldfra(k)-lcldfra_old(k))*dtinv + qndrop(k)=qndrop(k)*(1.+lcldfra(k)-lcldfra_old(k)) +! convert activated aerosol to interstitial in decaying cloud + + dumc=(lcldfra(k)-lcldfra_old(k))/lcldfra_old(k) +! print *,'shrinking cloud dumc=',dumc + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum.gt.0)then + dact=raercol(k,lnumcw,nsav)*dumc + raercol(k,lnumcw,nsav)=raercol(k,lnumcw,nsav)+dact + raercol(k,lnum,nsav)=raercol(k,lnum,nsav)-dact + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) + dact=raercol(k,lmasscw,nsav)*dumc + raercol(k,lmasscw,nsav)=raercol(k,lmasscw,nsav)+dact + raercol(k,lmass,nsav)=raercol(k,lmass,nsav)-dact + enddo + enddo + enddo +! 20 continue + endif + + enddo !k loop + +! end of k-loop for growing/shrinking cloud calcs ...................... + + +! ...................................................................... +! start of k-loop for calc of old cloud activation tendencies .......... + + do k=kts,kte-1 + km1=max0(k-1,kts) + kp1=min0(k+1,kte-1) + if(lcldfra(k).gt.0.01)then + if(lcldfra_old(k).gt.0.01)then +! go to 30 + +! old cloud + + if(lcldfra_old(k)-lcldfra_old(km1).gt.0.01.or.k.eq.kts)then + +! interior cloud + +! cloud base + + wdiab=0 + wmix=wtke(k) ! spectrum of updrafts + wbar=w(i,k,j) ! spectrum of updrafts +! wmix=0. ! single updraft +! wbar=wtke(k) ! single updraft +! 06-nov-2005 rce - increase wmax from 10 to 50 (deep convective clouds) + wmax=50. + top=.false. + ekd(k)=wtke(k)*dz(k)/sq2pi + alogarg=max(1.e-20,1/lcldfra_old(k)-1.) + wmin=wbar+wmix*0.25*sq2pi*alog(alogarg) + + do n=1,ntype_aer + do m=1,nsize_aer(n) + call loadaer(raercol(1,1,nsav),km1,kms,kme,num_chem, & + cs(k), npv(m,n),dlo_sect(m,n),dhi_sect(m,n), & + maxd_acomp, ncomp(n), & + grid_id, ktau, i, j, m, n, & + numptr_aer(m,n,ai_phase),numptr_aer(m,n,cw_phase), & + dens_aer(1,n), & + massptr_aer(1,m,n,ai_phase), massptr_aer(1,m,n,cw_phase), & + maerosol(1,m,n), maerosolcw(1,m,n), & + maerosol_tot(m,n), maerosol_totcw(m,n), & + naerosol(m,n), naerosolcw(m,n), & + vaerosol(m,n), vaerosolcw(m,n) ) + + hygro_aer(m,n)=hygro(i,k,j,m,n) + + enddo + enddo +! print *,'old cloud wbar,wmix=',wbar,wmix + + call activate(wbar,wmix,wdiab,wmin,wmax,temp(i,k,j),cs(k), & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + naerosol, vaerosol, & + dlo_sect,dhi_sect, sigmag_aer,hygro_aer, & + fn,fs,fm,fluxn,fluxs,fluxm, grid_id, ktau, i, j, k ) + + if(k.gt.kts)then + dumc = lcldfra_old(k)-lcldfra_old(km1) + else + dumc=lcldfra_old(k) + endif + dum=1./(dz(k)) + fluxntot=0. + do n=1,ntype_aer + do m=1,nsize_aer(n) + fluxn(m,n)=fluxn(m,n)*dumc +! fluxs(m,n)=fluxs(m,n)*dumc + fluxm(m,n)=fluxm(m,n)*dumc + lnum=numptr_aer(m,n,ai_phase) + fluxntot=fluxntot+fluxn(m,n)*raercol(km1,lnum,nsav) +! print *,'fn=',fn(m,n),' for m,n=',m,n +! print *,'old cloud dumc=',dumc,' fn=',fn(m,n),' for m,n=',m,n + nact(k,m,n)=nact(k,m,n)+fluxn(m,n)*dum + mact(k,m,n)=mact(k,m,n)+fluxm(m,n)*dum + enddo + enddo + nsource(i,k,j)=nsource(i,k,j)+fluxntot*zs(k) + fluxntot=fluxntot*cs(k) + endif +! 30 continue + endif + else +! go to 40 +! no cloud + if(qndrop(k).gt.10000.e6)then + print *,'i,k,j,lcldfra,qndrop=',i,k,j,lcldfra(k),qndrop(k) + print *,'cldfra,ql,qi',cldfra(i,k,j),qc(i,k,j),qi(i,k,j) + endif + nsource(i,k,j)=nsource(i,k,j)-qndrop(k)*dtinv + qndrop(k)=0. +! convert activated aerosol to interstitial in decaying cloud + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum.gt.0)then + raercol(k,lnum,nsav)=raercol(k,lnum,nsav)+raercol(k,lnumcw,nsav) + raercol(k,lnumcw,nsav)=0. + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) + raercol(k,lmass,nsav)=raercol(k,lmass,nsav)+raercol(k,lmasscw,nsav) + raercol(k,lmasscw,nsav)=0. + enddo + enddo + enddo +! 40 continue + endif + enddo +! 50 continue + +! go to 100 + +! switch nsav, nnew so that nnew is the updated aerosol + + ntemp=nsav + nsav=nnew + nnew=ntemp + +! load new droplets in layers above, below clouds + + dtmin=dtstep + ekk(kts)=0.0 + do k=kts+1,kte-1 + ekk(k)=ekd(k)*p_at_w(i,k,j)/(r_d*t_at_w(i,k,j)) + enddo + ekk(kte)=0.0 + do k=kts,kte-1 + ekkp(k)=zn(k)*ekk(k+1)*zs(k+1) + ekkm(k)=zn(k)*ekk(k)*zs(k) + tinv=ekkp(k)+ekkm(k) + if(k.eq.kts)tinv=tinv+surfratemax + if(tinv.gt.1.e-6)then + dtt=1./tinv + dtmin=min(dtmin,dtt) + endif + enddo + dtmix=0.9*dtmin + nsubmix=dtstep/dtmix+1 + if(nsubmix>100)then + nsubmix_bnd=100 + else + nsubmix_bnd=nsubmix + endif + count_submix(nsubmix_bnd)=count_submix(nsubmix_bnd)+1 + dtmix=dtstep/nsubmix + fac_srflx = -1.0/(zn(1)*nsubmix) + + do k=kts,kte-1 + kp1=min(k+1,kte-1) + km1=max(k-1,1) + if(lcldfra(kp1).gt.0)then + overlapp(k)=min(lcldfra(k)/lcldfra(kp1),1.) + else + overlapp(k)=1. + endif + if(lcldfra(km1).gt.0)then + overlapm(k)=min(lcldfra(k)/lcldfra(km1),1.) + else + overlapm(k)=1. + endif + enddo + + do nsub=1,nsubmix + qndrop_new(kts:kte-1)=qndrop(kts:kte-1) +! switch nsav, nnew so that nsav is the updated aerosol + ntemp=nsav + nsav=nnew + nnew=ntemp + srcn(:)=0.0 + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) +! update droplet source + srcn(kts:kte-1)=srcn(kts:kte-1)+nact(kts:kte-1,m,n)*(raercol(kts:kte-1,lnum,nsav)) + enddo + enddo + + call explmix(qndrop,srcn,ekkp,ekkm,overlapp,overlapm, & + qndrop_new,surfrate_drop,kts,kte-1,dtmix,.false.) + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum>0)then + source(kts:kte-1)= nact(kts:kte-1,m,n)*(raercol(kts:kte-1,lnum,nsav)) + call explmix(raercol(1,lnumcw,nnew),source,ekkp,ekkm,overlapp,overlapm, & + raercol(1,lnumcw,nsav),surfrate(lnumcw),kts,kte-1,dtmix,& + .false.) + call explmix(raercol(1,lnum,nnew),source,ekkp,ekkm,overlapp,overlapm, & + raercol(1,lnum,nsav),surfrate(lnum),kts,kte-1,dtmix, & + .true.,raercol(1,lnumcw,nsav)) + qsrflx(i,j,lnum) = qsrflx(i,j,lnum) + fac_srflx* & + raercol(kts,lnum,nsav)*surfrate(lnum) + qsrflx(i,j,lnumcw) = qsrflx(i,j,lnumcw) + fac_srflx* & + raercol(kts,lnumcw,nsav)*surfrate(lnumcw) + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) + source(kts:kte-1)= mact(kts:kte-1,m,n)*(raercol(kts:kte-1,lmass,nsav)) + call explmix(raercol(1,lmasscw,nnew),source,ekkp,ekkm,overlapp,overlapm, & + raercol(1,lmasscw,nsav),surfrate(lmasscw),kts,kte-1,dtmix, & + .false.) + call explmix(raercol(1,lmass,nnew),source,ekkp,ekkm,overlapp,overlapm, & + raercol(1,lmass,nsav),surfrate(lmass),kts,kte-1,dtmix, & + .true.,raercol(1,lmasscw,nsav)) + qsrflx(i,j,lmass) = qsrflx(i,j,lmass) + fac_srflx* & + raercol(kts,lmass,nsav)*surfrate(lmass) + qsrflx(i,j,lmasscw) = qsrflx(i,j,lmasscw) + fac_srflx* & + raercol(kts,lmasscw,nsav)*surfrate(lmasscw) + enddo + lwater=waterptr_aer(m,n) ! aerosol water + if(lwater>0)then + source(:)=0. + call explmix( raercol(1,lwater,nnew),source,ekkp,ekkm,overlapp,overlapm, & + raercol(1,lwater,nsav),surfrate(lwater),kts,kte-1,dtmix, & + .true.,source) + endif + enddo ! size + enddo ! type + + enddo !nsub + +! go to 100 + +! evaporate particles again if no cloud + + do k=kts,kte-1 + if(lcldfra(k).eq.0.)then + +! no cloud + + qndrop(k)=0. +! convert activated aerosol to interstitial in decaying cloud + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum.gt.0)then + raercol(k,lnum,nnew)=raercol(k,lnum,nnew)+raercol(k,lnumcw,nnew) + raercol(k,lnumcw,nnew)=0. + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) + raercol(k,lmass,nnew)=raercol(k,lmass,nnew)+raercol(k,lmasscw,nnew) + raercol(k,lmasscw,nnew)=0. + enddo + enddo + enddo + endif + enddo + +! go to 100 +! droplet number + + do k=kts,kte-1 +! if(lcldfra(k).gt.0.1)then +! write(6,'(a,3i5,f12.1)')'i,j,k,qndrop=',i,j,k,qndrop(k) +! endif + if(qndrop(k).lt.-10.e6.or.qndrop(k).gt.1.e12)then + write(6,'(a,g12.2,a,3i5)')'after qndrop=',qndrop(k),' for i,k,j=',i,k,j +! call exit(1) + endif + + qndrop3d(i,k,j) = max(qndrop(k),1.e-6) + + if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then + write(6,'(a,g12.2,a,3i5)')'after qndrop=',qndrop3d(i,k,j),' for i,k,j=',i,k,j +! call exit(1) + endif + if(qc(i,k,j).lt.-1..or.qc(i,k,j).gt.1.)then + write(6,'(a,g12.2,a,3i5)')'qc=',qc(i,k,j),' for i,k,j=',i,k,j + call exit(1) + endif + if(qi(i,k,j).lt.-1..or.qi(i,k,j).gt.1.)then + write(6,'(a,g12.2,a,3i5)')'qi=',qi(i,k,j),' for i,k,j=',i,k,j + call exit(1) + endif + if(qv(i,k,j).lt.-1..or.qv(i,k,j).gt.1.)then + write(6,'(a,g12.2,a,3i5)')'qv=',qv(i,k,j),' for i,k,j=',i,k,j + call exit(1) + endif + cldfra_old(i,k,j) = cldfra(i,k,j) +! if(k.gt.6.and.k.lt.11)cldfra_old(i,k,j)=1. + enddo + + + +! go to 100 +! update chem and convert back to mole/mole + + ccn(:,:) = 0. + do n=1,ntype_aer + do m=1,nsize_aer(n) + lnum=numptr_aer(m,n,ai_phase) + lnumcw=numptr_aer(m,n,cw_phase) + if(lnum.gt.0)then + ! scale=mwdry*0.001 + scale = 1. + chem(i,kts:kte-1,j,lnumcw)= raercol(kts:kte-1,lnumcw,nnew)*scale + chem(i,kts:kte-1,j,lnum)= raercol(kts:kte-1,lnum,nnew)*scale + endif + do l=1,ncomp(n) + lmass=massptr_aer(l,m,n,ai_phase) + lmasscw=massptr_aer(l,m,n,cw_phase) +! scale = mwdry/mw_aer(l,n) + scale = 1.e9 + chem(i,kts:kte-1,j,lmasscw)=raercol(kts:kte-1,lmasscw,nnew)*scale ! ug/kg + chem(i,kts:kte-1,j,lmass)=raercol(kts:kte-1,lmass,nnew)*scale ! ug/kg + enddo + lwater=waterptr_aer(m,n) + if(lwater>0)chem(i,kts:kte-1,j,lwater)=raercol(kts:kte-1,lwater,nnew) ! don't convert units + do k=kts,kte-1 + sm=2.*aten*sqrt(aten/(27.*hygro(i,k,j,m,n)*amcube(m,n))) + do l=1,psat + arg=argfactor(m,n)*log(sm/super(l)) + if(arg<2)then + if(arg<-2)then + ccnfact(l,m,n)=1.e-6 ! convert from #/m3 to #/cm3 + else + ccnfact(l,m,n)=1.e-6*0.5*ERFC_NUM_RECIPES(arg) + endif + else + ccnfact(l,m,n) = 0. + endif +! ccn concentration as diagnostic +! assume same hygroscopicity and ccnfact for cloud-phase and aerosol phase particles + ccn(k,l)=ccn(k,l)+(raercol(k,lnum,nnew)+raercol(k,lnumcw,nnew))*cs(k)*ccnfact(l,m,n) + enddo + enddo + enddo + enddo + do l=1,psat + !wig, 22-Nov-2006: added vertical bounds to prevent out-of-bounds at top + if(l.eq.1)ccn1(i,kts:kte,j)=ccn(:,l) + if(l.eq.2)ccn2(i,kts:kte,j)=ccn(:,l) + if(l.eq.3)ccn3(i,kts:kte,j)=ccn(:,l) + if(l.eq.4)ccn4(i,kts:kte,j)=ccn(:,l) + if(l.eq.5)ccn5(i,kts:kte,j)=ccn(:,l) + if(l.eq.6)ccn6(i,kts:kte,j)=ccn(:,l) + end do + +100 continue ! end of main loop over i +120 continue ! end of main loop over j + + + return + end subroutine mixactivate + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & + qold, surfrate, kts, kte, dt, is_unact, & + qactold ) + +! explicit integration of droplet/aerosol mixing +! with source due to activation/nucleation + + + implicit none + integer, intent(in) :: kts,kte ! number of levels + real, intent(inout) :: q(kts:kte) ! mixing ratio to be updated + real, intent(in) :: qold(kts:kte) ! mixing ratio from previous time step + real, intent(in) :: src(kts:kte) ! source due to activation/nucleation (/s) + real, intent(in) :: ekkp(kts:kte) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! below layer k (k,k+1 interface) + real, intent(in) :: ekkm(kts:kte) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! above layer k (k,k+1 interface) + real, intent(in) :: overlapp(kts:kte) ! cloud overlap below + real, intent(in) :: overlapm(kts:kte) ! cloud overlap above + real, intent(in) :: surfrate ! surface exchange rate (/s) + real, intent(in) :: dt ! time step (s) + logical, intent(in) :: is_unact ! true if this is an unactivated species + real, intent(in),optional :: qactold(kts:kte) + ! mixing ratio of ACTIVATED species from previous step + ! *** this should only be present + ! if the current species is unactivated number/sfc/mass + + integer k,kp1,km1 + + if ( is_unact ) then +! the qactold*(1-overlap) terms are resuspension of activated material + do k=kts,kte + kp1=min(k+1,kte) + km1=max(k-1,kts) + q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & + qactold(kp1)*(1.0-overlapp(k))) & + + ekkm(k)*(qold(km1) - qold(k) + & + qactold(km1)*(1.0-overlapm(k))) ) +! if(q(k)<-1.e-30)then ! force to non-negative +! print *,'q=',q(k),' in explmix' + q(k)=max(q(k),0.) +! endif + end do + else + do k=kts,kte + kp1=min(k+1,kte) + km1=max(k-1,kts) + q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & + ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) +! if(q(k)<-1.e-30)then ! force to non-negative +! print *,'q=',q(k),' in explmix' + q(k)=max(q(k),0.) +! endif + end do + end if +! diffusion loss at base of lowest layer + q(kts)=q(kts)-surfrate*qold(kts)*dt + +! if(q(kts)<-1.e-30)then ! force to non-negative +! print *,'q=',q(kts),' in explmix' + q(kts)=max(q(kts),0.) +! endif + + return + end subroutine explmix + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! 06-nov-2005 rce - grid_id & ktau added to arg list + subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + na, volc, dlo_sect,dhi_sect,sigman, hygro, & + fn, fs, fm, fluxn, fluxs, fluxm, & + grid_id, ktau, ii, jj, kk ) + +! calculates number, surface, and mass fraction of aerosols activated as CCN +! calculates flux of cloud droplets, surface area, and aerosol mass into cloud +! assumes an internal mixture within each of up to pmaxd_atype X pmaxd_asize +! multiple aerosol modes. +! A sectional treatment within each type is assumed if ntype_aer >7. +! A gaussiam spectrum of updrafts can be treated. + +! mks units + +! Abdul-Razzak and Ghan, A parameterization of aerosol activation. +! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + USE module_model_constants, only: g,rhowater, xlv, cp, rvovrd, r_d, r_v, & + mwdry,svp1,svp2,svp3,ep_2 + + implicit none + + +! input + + integer,intent(in) :: maxd_atype ! dimension of types + integer,intent(in) :: maxd_asize ! dimension of sizes + integer,intent(in) :: ntype_aer ! number of types + integer,intent(in) :: nsize_aer(maxd_atype) ! number of sizes for type + integer,intent(in) :: msectional ! 1 for sectional, 0 for modal + integer,intent(in) :: grid_id ! WRF grid%id + integer,intent(in) :: ktau ! WRF time step count + integer,intent(in) :: ii, jj, kk ! i,j,k of current grid cell + real,intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real,intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real,intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real,intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real,intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real,intent(in) :: tair ! air temperature (K) + real,intent(in) :: rhoair ! air density (kg/m3) + real,intent(in) :: na(maxd_asize,maxd_atype) ! aerosol number concentration (/m3) + real,intent(in) :: sigman(maxd_asize,maxd_atype) ! geometric standard deviation of aerosol size distribution + real,intent(in) :: hygro(maxd_asize,maxd_atype) ! bulk hygroscopicity of aerosol mode + real,intent(in) :: volc(maxd_asize,maxd_atype) ! total aerosol volume concentration (m3/m3) + real,intent(in) :: dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) + dhi_sect( maxd_asize, maxd_atype ) ! maximum size of section (cm) + +! output + + real,intent(inout) :: fn(maxd_asize,maxd_atype) ! number fraction of aerosols activated + real,intent(inout) :: fs(maxd_asize,maxd_atype) ! surface fraction of aerosols activated + real,intent(inout) :: fm(maxd_asize,maxd_atype) ! mass fraction of aerosols activated + real,intent(inout) :: fluxn(maxd_asize,maxd_atype) ! flux of activated aerosol number fraction into cloud (m/s) + real,intent(inout) :: fluxs(maxd_asize,maxd_atype) ! flux of activated aerosol surface fraction (m/s) + real,intent(inout) :: fluxm(maxd_asize,maxd_atype) ! flux of activated aerosol mass fraction into cloud (m/s) + +! local + +!!$ external erf,erfc +!!$ real erf,erfc +! external qsat_water + integer, parameter:: nx=200 + integer iquasisect_option, isectional + real integ,integf + real surften ! surface tension of water w/respect to air (N/m) + data surften/0.076/ + save surften + real p0 ! reference pressure (Pa) + real t0 ! reference temperature (K) + data p0/1013.25e2/,t0/273.15/ + save p0,t0 + real ylo(maxd_asize,maxd_atype),yhi(maxd_asize,maxd_atype) ! 1-particle volume at section interfaces + real ymean(maxd_asize,maxd_atype) ! 1-particle volume at r=rmean + real ycut, lnycut, betayy, betayy2, gammayy, phiyy + real surfc(maxd_asize,maxd_atype) ! surface concentration (m2/m3) + real sign(maxd_asize,maxd_atype) ! geometric standard deviation of size distribution + real alnsign(maxd_asize,maxd_atype) ! natl log of geometric standard dev of aerosol + real am(maxd_asize,maxd_atype) ! number mode radius of dry aerosol (m) + real lnhygro(maxd_asize,maxd_atype) ! ln(b) + real pres ! pressure (Pa) + real path ! mean free path (m) + real diff ! diffusivity (m2/s) + real conduct ! thermal conductivity (Joule/m/sec/deg) + real diff0,conduct0 + real es ! saturation vapor pressure + real qs ! water vapor saturation mixing ratio + real dqsdt ! change in qs with temperature + real dqsdp ! change in qs with pressure + real gg ! thermodynamic function (m2/s) + real sqrtg ! sqrt(gg) + real sm(maxd_asize,maxd_atype) ! critical supersaturation for number mode radius + real lnsm(maxd_asize,maxd_atype) ! ln( sm ) + real zeta, eta(maxd_asize,maxd_atype) + real lnsmax ! ln(smax) + real alpha + real gamma + real beta + real gaus + logical top ! true if cloud top, false if cloud base or new cloud + data top/.false./ + save top + real asub(maxd_asize,maxd_atype),bsub(maxd_asize,maxd_atype) ! coefficients of submode size distribution N=a+bx + real totn(maxd_atype) ! total aerosol number concentration + real aten ! surface tension parameter + real gmrad(maxd_atype) ! geometric mean radius + real gmradsq(maxd_atype) ! geometric mean of radius squared + real gmlnsig(maxd_atype) ! geometric standard deviation + real gmsm(maxd_atype) ! critical supersaturation at radius gmrad + real sumflxn(maxd_asize,maxd_atype) + real sumflxs(maxd_asize,maxd_atype) + real sumflxm(maxd_asize,maxd_atype) + real sumfn(maxd_asize,maxd_atype) + real sumfs(maxd_asize,maxd_atype) + real sumfm(maxd_asize,maxd_atype) + real sumns(maxd_atype) + real fnold(maxd_asize,maxd_atype) ! number fraction activated + real fsold(maxd_asize,maxd_atype) ! surface fraction activated + real fmold(maxd_asize,maxd_atype) ! mass fraction activated + real wold,gold + real alogten,alog2,alog3,alogaten + real alogam + real rlo(maxd_asize,maxd_atype), rhi(maxd_asize,maxd_atype) + real rmean(maxd_asize,maxd_atype) + ! mean radius (m) for the section (not used with modal) + ! calculated from current volume & number + real ccc + real dumaa,dumbb + real wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb + real dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar + real alw,sqrtalw + real smax + real x,arg + real xmincoeff,xcut + real z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf + real etafactor1,etafactor2(maxd_asize,maxd_atype),etafactor2max + integer m,n,nw,nwmax + +! numerical integration parameters + real eps,fmax,sds + data eps/0.3/,fmax/0.99/,sds/3./ + +! mathematical constants + real third, twothird, sixth, zero, one, two, three +! 04-nov-2005 rce - make this more precise +! data third/0.333333/, twothird/0.66666667/, sixth/0.166666667/,zero/0./,one/1./,two/2./,three/3./ +! data third/0.33333333333/, twothird/0.66666666667/, sixth/0.16666666667/ +! data zero/0./,one/1./,two/2./,three/3./ +! save third, sixth,twothird,zero,one,two,three + + real sq2, sqpi, pi +! 04-nov-2005 rce - make this more precise +! data sq2/1.4142136/, sqpi/1.7724539/,pi/3.14159/ + data sq2/1.4142135624/, sqpi/1.7724538509/,pi/3.1415926536/ + save sq2,sqpi,pi + + integer ndist(nx) ! accumulates frequency distribution of integration bins required + data ndist/nx*0/ + save eps,fmax,sds,ndist + +! for nsize_aer>7, a sectional approach is used and isectional = iquasisect_option +! activation fractions (fn,fs,fm) are computed as follows +! iquasisect_option = 1,3 - each section treated as a narrow lognormal +! iquasisect_option = 2,4 - within-section dn/dx = a + b*x, x = ln(r) +! smax is computed as follows (when explicit activation is OFF) +! iquasisect_option = 1,2 - razzak-ghan modal parameterization with +! single mode having same ntot, dgnum, sigmag as the combined sections +! iquasisect_option = 3,4 - razzak-ghan sectional parameterization +! for nsize_aer=<9, a modal approach is used and isectional = 0 + +! rce 08-jul-2005 +! if either (na(n,m) < nsmall) or (volc(n,m) < vsmall) +! then treat bin/mode (n,m) as being empty, and set its fn/fs/fm=0.0 +! (for single precision, gradual underflow starts around 1.0e-38, +! and strange things can happen when in that region) + real, parameter :: nsmall = 1.0e-20 ! aer number conc in #/m3 + real, parameter :: vsmall = 1.0e-37 ! aer volume conc in m3/m3 + logical bin_is_empty(maxd_asize,maxd_atype), all_bins_empty + logical bin_is_narrow(maxd_asize,maxd_atype) + + integer idiagaa, ipass_nwloop + integer idiag_dndy_neg, idiag_fnsm_prob + +!....................................................................... +! +! start calc. of modal or sectional activation properties (start of section 1) +! +!....................................................................... + idiag_dndy_neg = 1 ! set this to 0 to turn off + ! warnings about dn/dy < 0 + idiag_fnsm_prob = 1 ! set this to 0 to turn off + ! warnings about fn/fs/fm misbehavior + + iquasisect_option = 2 + if(msectional.gt.0)then + isectional = iquasisect_option + else + isectional = 0 + endif + + do n=1,ntype_aer +! print *,'ntype_aer,n,nsize_aer(n)=',ntype_aer,n,nsize_aer(n) + + if(ntype_aer.eq.1.and.nsize_aer(n).eq.1.and.na(1,1).lt.1.e-20)then + fn(1,1)=0. + fs(1,1)=0. + fm(1,1)=0. + fluxn(1,1)=0. + fluxs(1,1)=0. + fluxm(1,1)=0. + return + endif + enddo + + zero = 0.0 + one = 1.0 + two = 2.0 + three = 3.0 + third = 1.0/3.0 + twothird = 2.0/6.0 + sixth = 1.0/6.0 + + pres=r_d*rhoair*tair + diff0=0.211e-4*(p0/pres)*(tair/t0)**1.94 + conduct0=(5.69+0.017*(tair-t0))*4.186e2*1.e-5 ! convert to J/m/s/deg + es=1000.*svp1*exp( svp2*(tair-t0)/(tair-svp3) ) + qs=ep_2*es/(pres-es) + dqsdt=xlv/(r_v*tair*tair)*qs + alpha=g*(xlv/(cp*r_v*tair*tair)-1./(r_d*tair)) + gamma=(1+xlv/cp*dqsdt)/(rhoair*qs) + gg=1./(rhowater/(diff0*rhoair*qs)+xlv*rhowater/(conduct0*tair)*(xlv/(r_v*tair)-1.)) + sqrtg=sqrt(gg) + beta=4.*pi*rhowater*gg*gamma + aten=2.*surften/(r_v*tair*rhowater) + alogaten=log(aten) + alog2=log(two) + alog3=log(three) + ccc=4.*pi*third + etafactor2max=1.e10/(alpha*wmaxf)**1.5 ! this should make eta big if na is very small. + + all_bins_empty = .true. + do n=1,ntype_aer + totn(n)=0. + gmrad(n)=0. + gmradsq(n)=0. + sumns(n)=0. + do m=1,nsize_aer(n) + alnsign(m,n)=log(sigman(m,n)) +! internal mixture of aerosols + + bin_is_empty(m,n) = .true. + if (volc(m,n).gt.vsmall .and. na(m,n).gt.nsmall) then + bin_is_empty(m,n) = .false. + all_bins_empty = .false. + lnhygro(m,n)=log(hygro(m,n)) +! number mode radius (m,n) +! write(6,*)'alnsign,volc,na=',alnsign(m,n),volc(m,n),na(m,n) + am(m,n)=exp(-1.5*alnsign(m,n)*alnsign(m,n))* & + (3.*volc(m,n)/(4.*pi*na(m,n)))**third + + if (isectional .gt. 0) then +! sectional model. +! need to use bulk properties because parameterization doesn't +! work well for narrow bins. + totn(n)=totn(n)+na(m,n) + alogam=log(am(m,n)) + gmrad(n)=gmrad(n)+na(m,n)*alogam + gmradsq(n)=gmradsq(n)+na(m,n)*alogam*alogam + endif + etafactor2(m,n)=1./(na(m,n)*beta*sqrtg) + + if(hygro(m,n).gt.1.e-10)then + sm(m,n)=2.*aten/(3.*am(m,n))*sqrt(aten/(3.*hygro(m,n)*am(m,n))) + else + sm(m,n)=100. + endif +! write(6,*)'sm,hygro,am=',sm(m,n),hygro(m,n),am(m,n) + else + sm(m,n)=1. + etafactor2(m,n)=etafactor2max ! this should make eta big if na is very small. + + endif + lnsm(m,n)=log(sm(m,n)) + if ((isectional .eq. 3) .or. (isectional .eq. 4)) then + sumns(n)=sumns(n)+na(m,n)/sm(m,n)**twothird + endif +! write(6,'(a,i4,6g12.2)')'m,na,am,hygro,lnhygro,sm,lnsm=',m,na(m,n),am(m,n),hygro(m,n),lnhygro(m,n),sm(m,n),lnsm(m,n) + end do ! size + end do ! type + +! if all bins are empty, set all activation fractions to zero and exit + if ( all_bins_empty ) then + do n=1,ntype_aer + do m=1,nsize_aer(n) + fluxn(m,n)=0. + fn(m,n)=0. + fluxs(m,n)=0. + fs(m,n)=0. + fluxm(m,n)=0. + fm(m,n)=0. + end do + end do + return + endif + + + + if (isectional .le. 0) goto 30000 + + do n=1,ntype_aer + !wig 19-Oct-2006: Add zero trap based May 2006 e-mail from + !Ghan. Transport can clear out a cell leading to + !inconsistencies with the mass. + gmrad(n)=gmrad(n)/max(totn(n),1e-20) + gmlnsig=gmradsq(n)/totn(n)-gmrad(n)*gmrad(n) ! [ln(sigmag)]**2 + gmlnsig(n)=sqrt( max( 1.e-4, gmlnsig(n) ) ) + gmrad(n)=exp(gmrad(n)) + if ((isectional .eq. 3) .or. (isectional .eq. 4)) then + gmsm(n)=totn(n)/sumns(n) + gmsm(n)=gmsm(n)*gmsm(n)*gmsm(n) + gmsm(n)=sqrt(gmsm(n)) + else +! gmsm(n)=2.*aten/(3.*gmrad(n))*sqrt(aten/(3.*hygro(1,n)*gmrad(n))) + gmsm(n)=2.*aten/(3.*gmrad(n))*sqrt(aten/(3.*hygro(nsize_aer(n),n)*gmrad(n))) + endif + enddo + +!....................................................................... +! calculate sectional "sub-bin" size distribution +! +! dn/dy = nt*( a + b*y ) for ylo < y < yhi +! +! nt = na(m,n) = number mixing ratio of the bin +! y = v/vhi +! v = (4pi/3)*r**3 = particle volume +! vhi = v at r=rhi (upper bin boundary) +! ylo = y at lower bin boundary = vlo/vhi = (rlo/rhi)**3 +! yhi = y at upper bin boundary = 1.0 +! +! dv/dy = v * dn/dy = nt*vhi*( a*y + b*y*y ) +! +!....................................................................... +! 02-may-2006 - this dn/dy replaces the previous +! dn/dx = a + b*x where l = ln(r) +! the old dn/dx was overly complicated for cases of rmean near rlo or rhi +! the new dn/dy is consistent with that used in the movesect routine, +! which does continuous growth by condensation and aqueous chemistry +!....................................................................... + do 25002 n = 1,ntype_aer + do 25000 m = 1,nsize_aer(n) + +! convert from diameter in cm to radius in m + rlo(m,n) = 0.5*0.01*dlo_sect(m,n) + rhi(m,n) = 0.5*0.01*dhi_sect(m,n) + ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 + yhi(m,n) = 1.0 + +! 04-nov-2005 - extremely narrow bins will be treated using 0/1 activation +! this is to avoid potential numberical problems + bin_is_narrow(m,n) = .false. + if ((rhi(m,n)/rlo(m,n)) .le. 1.01) bin_is_narrow(m,n) = .true. + +! rmean is mass mean radius for the bin; xmean = log(rmean) +! just use section midpoint if bin is empty + if ( bin_is_empty(m,n) ) then + rmean(m,n) = sqrt(rlo(m,n)*rhi(m,n)) + ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 + goto 25000 + end if + + rmean(m,n) = (volc(m,n)/(ccc*na(m,n)))**third + rmean(m,n) = max( rlo(m,n), min( rhi(m,n), rmean(m,n) ) ) + ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 + if ( bin_is_narrow(m,n) ) goto 25000 + +! if rmean is extremely close to either rlo or rhi, +! treat the bin as extremely narrow + if ((rhi(m,n)/rmean(m,n)) .le. 1.01) then + bin_is_narrow(m,n) = .true. + rlo(m,n) = min( rmean(m,n), (rhi(m,n)/1.01) ) + ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 + goto 25000 + else if ((rmean(m,n)/rlo(m,n)) .le. 1.01) then + bin_is_narrow(m,n) = .true. + rhi(m,n) = max( rmean(m,n), (rlo(m,n)*1.01) ) + ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 + ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 + goto 25000 + endif + +! if rmean is somewhat close to either rlo or rhi, then dn/dy will be +! negative near the upper or lower bin boundary +! in these cases, assume that all the particles are in a subset of the full bin, +! and adjust rlo or rhi so that rmean will be near the center of this subset +! note that the bin is made narrower LOCALLY/TEMPORARILY, +! just for the purposes of the activation calculation + gammayy = (ymean(m,n)-ylo(m,n)) / (yhi(m,n)-ylo(m,n)) + if (gammayy .lt. 0.34) then + dumaa = ylo(m,n) + (yhi(m,n)-ylo(m,n))*(gammayy/0.34) + rhi(m,n) = rhi(m,n)*(dumaa**third) + ylo(m,n) = (rlo(m,n)/rhi(m,n))**3 + ymean(m,n) = (rmean(m,n)/rhi(m,n))**3 + else if (gammayy .ge. 0.66) then + dumaa = ylo(m,n) + (yhi(m,n)-ylo(m,n))*((gammayy-0.66)/0.34) + ylo(m,n) = dumaa + rlo(m,n) = rhi(m,n)*(dumaa**third) + end if + if ((rhi(m,n)/rlo(m,n)) .le. 1.01) then + bin_is_narrow(m,n) = .true. + goto 25000 + end if + + betayy = ylo(m,n)/yhi(m,n) + betayy2 = betayy*betayy + bsub(m,n) = (12.0*ymean(m,n) - 6.0*(1.0+betayy)) / & + (4.0*(1.0-betayy2*betayy) - 3.0*(1.0-betayy2)*(1.0+betayy)) + asub(m,n) = (1.0 - bsub(m,n)*(1.0-betayy2)*0.5) / (1.0-betayy) + + if ( asub(m,n)+bsub(m,n)*ylo(m,n) .lt. 0. ) then + if (idiag_dndy_neg .gt. 0) then + print *,'dndy<0 at lower boundary' + print *,'n,m=',n,m + print *,'na=',na(m,n),' volc=',volc(m,n) + print *,'volc/(na*pi*4/3)=', (volc(m,n)/(na(m,n)*ccc)) + print *,'rlo(m,n),rhi(m,n)=',rlo(m,n),rhi(m,n) + print *,'dlo_sect/2,dhi_sect/2=', & + (0.005*dlo_sect(m,n)),(0.005*dhi_sect(m,n)) + print *,'asub,bsub,ylo,yhi=',asub(m,n),bsub(m,n),ylo(m,n),yhi(m,n) + print *,'asub+bsub*ylo=', & + (asub(m,n)+bsub(m,n)*ylo(m,n)) + print *,'subr activate error 11 - i,j,k =', ii, jj, kk +! 07-nov-2005 rce - don't stop for this, it's not fatal +! stop + endif + endif + if ( asub(m,n)+bsub(m,n)*yhi(m,n) .lt. 0. ) then + if (idiag_dndy_neg .gt. 0) then + print *,'dndy<0 at upper boundary' + print *,'n,m=',n,m + print *,'na=',na(m,n),' volc=',volc(m,n) + print *,'volc/(na*pi*4/3)=', (volc(m,n)/(na(m,n)*ccc)) + print *,'rlo(m,n),rhi(m,n)=',rlo(m,n),rhi(m,n) + print *,'dlo_sect/2,dhi_sect/2=', & + (0.005*dlo_sect(m,n)),(0.005*dhi_sect(m,n)) + print *,'asub,bsub,ylo,yhi=',asub(m,n),bsub(m,n),ylo(m,n),yhi(m,n) + print *,'asub+bsub*yhi=', & + (asub(m,n)+bsub(m,n)*yhi(m,n)) + print *,'subr activate error 12 - i,j,k =', ii, jj, kk +! stop + endif + endif + +25000 continue ! m=1,nsize_aer(n) +25002 continue ! n=1,ntype_aer + + +30000 continue +!....................................................................... +! +! end calc. of modal or sectional activation properties (end of section 1) +! +!....................................................................... + + + +! sjg 7-16-98 upward +! print *,'wbar,sigw=',wbar,sigw + + if(sigw.le.1.e-5) goto 50000 + +!....................................................................... +! +! start calc. of activation fractions/fluxes +! for spectrum of updrafts (start of section 2) +! +!....................................................................... + ipass_nwloop = 1 + idiagaa = 0 +! 06-nov-2005 rce - set idiagaa=1 for testing/debugging +! if ((grid_id.eq.1) .and. (ktau.eq.167) .and. & +! (ii.eq.24) .and. (jj.eq. 1) .and. (kk.eq.14)) idiagaa = 1 + +40000 continue + if(top)then + wmax=0. + wmin=min(zero,-wdiab) + else + wmax=min(wmaxf,wbar+sds*sigw) + wmin=max(wminf,-wdiab) + endif + wmin=max(wmin,wbar-sds*sigw) + w=wmin + dwmax=eps*sigw + dw=dwmax + dfmax=0.2 + dfmin=0.1 + if(wmax.le.w)then + do n=1,ntype_aer + do m=1,nsize_aer(n) + fluxn(m,n)=0. + fn(m,n)=0. + fluxs(m,n)=0. + fs(m,n)=0. + fluxm(m,n)=0. + fm(m,n)=0. + end do + end do + return + endif + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumflxn(m,n)=0. + sumfn(m,n)=0. + fnold(m,n)=0. + sumflxs(m,n)=0. + sumfs(m,n)=0. + fsold(m,n)=0. + sumflxm(m,n)=0. + sumfm(m,n)=0. + fmold(m,n)=0. + enddo + enddo + + fold=0 + gold=0 +! 06-nov-2005 rce - set wold=w here +! wold=0 + wold=w + + +! 06-nov-2005 rce - define nwmax; calc dwmin from nwmax + nwmax = 200 +! dwmin = min( dwmax, 0.01 ) + dwmin = (wmax - wmin)/(nwmax-1) + dwmin = min( dwmax, dwmin ) + dwmin = max( 0.01, dwmin ) + +! +! loop over updrafts, incrementing sums as you go +! the "200" is (arbitrary) upper limit for number of updrafts +! if integration finishes before this, OK; otherwise, ERROR +! + if (idiagaa.gt.0) then + write(*,94700) ktau, grid_id, ii, jj, kk, nwmax + write(*,94710) 'wbar,sigw,wdiab=', wbar, sigw, wdiab + write(*,94710) 'wmin,wmax,dwmin,dwmax=', wmin, wmax, dwmin, dwmax + write(*,94720) -1, w, wold, dw + end if +94700 format( / 'activate 47000 - ktau,id,ii,jj,kk,nwmax=', 6i5 ) +94710 format( 'activate 47000 - ', a, 6(1x,f11.5) ) +94720 format( 'activate 47000 - nw,w,wold,dw=', i5, 3(1x,f11.5) ) + + do 47000 nw = 1, nwmax +41000 wnuc=w+wdiab + + if (idiagaa.gt.0) write(*,94720) nw, w, wold, dw + +! write(6,*)'wnuc=',wnuc + alw=alpha*wnuc + sqrtalw=sqrt(alw) + zeta=2.*sqrtalw*aten/(3.*sqrtg) + etafactor1=2.*alw*sqrtalw + if (isectional .gt. 0) then +! sectional model. +! use bulk properties + + do n=1,ntype_aer + if(totn(n).gt.1.e-10)then + eta(1,n)=etafactor1/(totn(n)*beta*sqrtg) + else + eta(1,n)=1.e10 + endif + enddo + call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,(/1/),gmsm,gmlnsig,smax) +! call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,nsize_aer,gmsm,gmlnsig,smax) + lnsmax=log(smax) + x=2*(log(gmsm(1))-lnsmax)/(3*sq2*gmlnsig(1)) + fnew=0.5*(1.-ERF_ALT(x)) + + else + + do n=1,ntype_aer + do m=1,nsize_aer(n) + eta(m,n)=etafactor1*etafactor2(m,n) + enddo + enddo + + call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,nsize_aer,sm,alnsign,smax) +! write(6,*)'w,smax=',w,smax + + lnsmax=log(smax) + + x=2*(lnsm(nsize_aer(1),1)-lnsmax)/(3*sq2*alnsign(nsize_aer(1),1)) + fnew=0.5*(1.-ERF_ALT(x)) + + endif + + dwnew = dw +! 06-nov-2005 rce - "n" here should be "nw" (?) +! if(fnew-fold.gt.dfmax.and.n.gt.1)then + if(fnew-fold.gt.dfmax.and.nw.gt.1)then +! reduce updraft increment for greater accuracy in integration + if (dw .gt. 1.01*dwmin) then + dw=0.7*dw + dw=max(dw,dwmin) + w=wold+dw + go to 41000 + else + dwnew = dwmin + endif + endif + + if(fnew-fold.lt.dfmin)then +! increase updraft increment to accelerate integration + dwnew=min(1.5*dw,dwmax) + endif + fold=fnew + + z=(w-wbar)/(sigw*sq2) + gaus=exp(-z*z) + fnmin=1. + xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3 +! write(6,*)'xmincoeff=',xmincoeff + + + do 44002 n=1,ntype_aer + do 44000 m=1,nsize_aer(n) + if ( bin_is_empty(m,n) ) then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. + else if ((isectional .eq. 2) .or. (isectional .eq. 4)) then +! sectional +! within-section dn/dx = a + b*x + xcut=xmincoeff-third*lnhygro(m,n) +! ycut=(exp(xcut)/rhi(m,n))**3 +! 07-jul-2006 rce - the above line gave a (rare) overflow when smax=1.0e-20 +! if (ycut > yhi), then actual value of ycut is unimportant, +! so do the following to avoid overflow + lnycut = 3.0 * ( xcut - log(rhi(m,n)) ) + lnycut = min( lnycut, log(yhi(m,n)*1.0e5) ) + ycut=exp(lnycut) +! write(6,*)'m,n,rcut,rlo,rhi=',m,n,exp(xcut),rlo(m,n),rhi(m,n) +! if(lnsmax.lt.lnsmn(m,n))then + if(ycut.gt.yhi(m,n))then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. + elseif(ycut.lt.ylo(m,n))then + fn(m,n)=1. + fs(m,n)=1. + fm(m,n)=1. + elseif ( bin_is_narrow(m,n) ) then +! 04-nov-2005 rce - for extremely narrow bins, +! do zero activation if xcut>xmean, 100% activation otherwise + if (ycut.gt.ymean(m,n)) then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. + else + fn(m,n)=1. + fs(m,n)=1. + fm(m,n)=1. + endif + else + phiyy=ycut/yhi(m,n) + fn(m,n) = asub(m,n)*(1.0-phiyy) + 0.5*bsub(m,n)*(1.0-phiyy*phiyy) + if (fn(m,n).lt.zero .or. fn(m,n).gt.one) then + if (idiag_fnsm_prob .gt. 0) then + print *,'fn(',m,n,')=',fn(m,n),' outside 0,1 - activate err21' + print *,'na,volc =', na(m,n), volc(m,n) + print *,'asub,bsub =', asub(m,n), bsub(m,n) + print *,'yhi,ycut =', yhi(m,n), ycut + endif + endif + + if (fn(m,n) .le. zero) then +! 10-nov-2005 rce - if fn=0, then fs & fm must be 0 + fn(m,n)=zero + fs(m,n)=zero + fm(m,n)=zero + else if (fn(m,n) .ge. one) then +! 10-nov-2005 rce - if fn=1, then fs & fm must be 1 + fn(m,n)=one + fs(m,n)=one + fm(m,n)=one + else +! 10-nov-2005 rce - otherwise, calc fm and check it + fm(m,n) = (yhi(m,n)/ymean(m,n)) * (0.5*asub(m,n)*(1.0-phiyy*phiyy) + & + third*bsub(m,n)*(1.0-phiyy*phiyy*phiyy)) + if (fm(m,n).lt.fn(m,n) .or. fm(m,n).gt.one) then + if (idiag_fnsm_prob .gt. 0) then + print *,'fm(',m,n,')=',fm(m,n),' outside fn,1 - activate err22' + print *,'na,volc,fn =', na(m,n), volc(m,n), fn(m,n) + print *,'asub,bsub =', asub(m,n), bsub(m,n) + print *,'yhi,ycut =', yhi(m,n), ycut + endif + endif + if (fm(m,n) .le. fn(m,n)) then +! 10-nov-2005 rce - if fm=fn, then fs must =fn + fm(m,n)=fn(m,n) + fs(m,n)=fn(m,n) + else if (fm(m,n) .ge. one) then +! 10-nov-2005 rce - if fm=1, then fs & fn must be 1 + fm(m,n)=one + fs(m,n)=one + fn(m,n)=one + else +! 10-nov-2005 rce - these two checks assure that the mean size +! of the activated & interstitial particles will be between rlo & rhi + dumaa = fn(m,n)*(yhi(m,n)/ymean(m,n)) + fm(m,n) = min( fm(m,n), dumaa ) + dumaa = 1.0 + (fn(m,n)-1.0)*(ylo(m,n)/ymean(m,n)) + fm(m,n) = min( fm(m,n), dumaa ) +! 10-nov-2005 rce - now calculate fs and bound it by fn, fm + betayy = ylo(m,n)/yhi(m,n) + dumaa = phiyy**twothird + dumbb = betayy**twothird + fs(m,n) = & + (asub(m,n)*(1.0-phiyy*dumaa) + & + 0.625*bsub(m,n)*(1.0-phiyy*phiyy*dumaa)) / & + (asub(m,n)*(1.0-betayy*dumbb) + & + 0.625*bsub(m,n)*(1.0-betayy*betayy*dumbb)) + fs(m,n)=max(fs(m,n),fn(m,n)) + fs(m,n)=min(fs(m,n),fm(m,n)) + endif + endif + endif + + else +! modal + x=2*(lnsm(m,n)-lnsmax)/(3*sq2*alnsign(m,n)) + fn(m,n)=0.5*(1.-ERF_ALT(x)) + arg=x-sq2*alnsign(m,n) + fs(m,n)=0.5*(1.-ERF_ALT(arg)) + arg=x-1.5*sq2*alnsign(m,n) + fm(m,n)=0.5*(1.-ERF_ALT(arg)) +! print *,'w,x,fn,fs,fm=',w,x,fn(m,n),fs(m,n),fm(m,n) + endif + +! fn(m,n)=1. !test +! fs(m,n)=1. +! fm(m,n)=1. + fnmin=min(fn(m,n),fnmin) +! integration is second order accurate +! assumes linear variation of f*gaus with w + wb=(w+wold) + fnbar=(fn(m,n)*gaus+fnold(m,n)*gold) + fsbar=(fs(m,n)*gaus+fsold(m,n)*gold) + fmbar=(fm(m,n)*gaus+fmold(m,n)*gold) + if((top.and.w.lt.0.).or.(.not.top.and.w.gt.0.))then + sumflxn(m,n)=sumflxn(m,n)+sixth*(wb*fnbar & + +(fn(m,n)*gaus*w+fnold(m,n)*gold*wold))*dw + sumflxs(m,n)=sumflxs(m,n)+sixth*(wb*fsbar & + +(fs(m,n)*gaus*w+fsold(m,n)*gold*wold))*dw + sumflxm(m,n)=sumflxm(m,n)+sixth*(wb*fmbar & + +(fm(m,n)*gaus*w+fmold(m,n)*gold*wold))*dw + endif + sumfn(m,n)=sumfn(m,n)+0.5*fnbar*dw +! write(6,'(a,9g10.2)')'lnsmax,lnsm(m,n),x,fn(m,n),fnold(m,n),g,gold,fnbar,dw=', & +! lnsmax,lnsm(m,n),x,fn(m,n),fnold(m,n),g,gold,fnbar,dw + fnold(m,n)=fn(m,n) + sumfs(m,n)=sumfs(m,n)+0.5*fsbar*dw + fsold(m,n)=fs(m,n) + sumfm(m,n)=sumfm(m,n)+0.5*fmbar*dw + fmold(m,n)=fm(m,n) + +44000 continue ! m=1,nsize_aer(n) +44002 continue ! n=1,ntype_aer + +! sumg=sumg+0.5*(gaus+gold)*dw + gold=gaus + wold=w + dw=dwnew + + if(nw.gt.1.and.(w.gt.wmax.or.fnmin.gt.fmax))go to 48000 + w=w+dw + +47000 continue ! nw = 1, nwmax + + + print *,'do loop is too short in activate' + print *,'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw + print *,'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab + print *,'wnuc=',wnuc + do n=1,ntype_aer + print *,'ntype=',n + print *,'na=',(na(m,n),m=1,nsize_aer(n)) + print *,'fn=',(fn(m,n),m=1,nsize_aer(n)) + end do +! dump all subr parameters to allow testing with standalone code +! (build a driver that will read input and call activate) + print *,'top,wbar,sigw,wdiab,tair,rhoair,ntype_aer=' + print *, top,wbar,sigw,wdiab,tair,rhoair,ntype_aer + print *,'na=' + print *, na + print *,'volc=' + print *, volc + print *,'sigman=' + print *, sigman + print *,'hygro=' + print *, hygro + + print *,'subr activate error 31 - i,j,k =', ii, jj, kk +! 06-nov-2005 rce - if integration fails, repeat it once with additional diagnostics + if (ipass_nwloop .eq. 1) then + ipass_nwloop = 2 + idiagaa = 2 + goto 40000 + end if + stop + +48000 continue + + + ndist(n)=ndist(n)+1 + if(.not.top.and.w.lt.wmaxf)then + +! contribution from all updrafts stronger than wmax +! assuming constant f (close to fmax) + wnuc=w+wdiab + + z1=(w-wbar)/(sigw*sq2) + z2=(wmaxf-wbar)/(sigw*sq2) + integ=sigw*0.5*sq2*sqpi*(ERFC_NUM_RECIPES(z1)-ERFC_NUM_RECIPES(z2)) +! consider only upward flow into cloud base when estimating flux + wf1=max(w,zero) + zf1=(wf1-wbar)/(sigw*sq2) + gf1=exp(-zf1*zf1) + wf2=max(wmaxf,zero) + zf2=(wf2-wbar)/(sigw*sq2) + gf2=exp(-zf2*zf2) + gf=(gf1-gf2) + integf=wbar*sigw*0.5*sq2*sqpi*(ERFC_NUM_RECIPES(zf1)-ERFC_NUM_RECIPES(zf2))+sigw*sigw*gf + + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumflxn(m,n)=sumflxn(m,n)+integf*fn(m,n) + sumfn(m,n)=sumfn(m,n)+fn(m,n)*integ + sumflxs(m,n)=sumflxs(m,n)+integf*fs(m,n) + sumfs(m,n)=sumfs(m,n)+fs(m,n)*integ + sumflxm(m,n)=sumflxm(m,n)+integf*fm(m,n) + sumfm(m,n)=sumfm(m,n)+fm(m,n)*integ + end do + end do +! sumg=sumg+integ + endif + + + do n=1,ntype_aer + do m=1,nsize_aer(n) + +! fn(m,n)=sumfn(m,n)/(sumg) + fn(m,n)=sumfn(m,n)/(sq2*sqpi*sigw) + fluxn(m,n)=sumflxn(m,n)/(sq2*sqpi*sigw) + if(fn(m,n).gt.1.01)then + if (idiag_fnsm_prob .gt. 0) then + print *,'fn=',fn(m,n),' > 1 - activate err41' + print *,'w,m,n,na,am=',w,m,n,na(m,n),am(m,n) + print *,'integ,sumfn,sigw=',integ,sumfn(m,n),sigw + print *,'subr activate error - i,j,k =', ii, jj, kk +! call exit + endif + fluxn(m,n) = fluxn(m,n)/fn(m,n) + endif + + fs(m,n)=sumfs(m,n)/(sq2*sqpi*sigw) + fluxs(m,n)=sumflxs(m,n)/(sq2*sqpi*sigw) + if(fs(m,n).gt.1.01)then + if (idiag_fnsm_prob .gt. 0) then + print *,'fs=',fs(m,n),' > 1 - activate err42' + print *,'m,n,isectional=',m,n,isectional + print *,'alnsign(m,n)=',alnsign(m,n) + print *,'rcut,rlo(m,n),rhi(m,n)',exp(xcut),rlo(m,n),rhi(m,n) + print *,'w,m,na,am=',w,m,na(m,n),am(m,n) + print *,'integ,sumfs,sigw=',integ,sumfs(m,n),sigw + endif + fluxs(m,n) = fluxs(m,n)/fs(m,n) + endif + +! fm(m,n)=sumfm(m,n)/(sumg) + fm(m,n)=sumfm(m,n)/(sq2*sqpi*sigw) + fluxm(m,n)=sumflxm(m,n)/(sq2*sqpi*sigw) + if(fm(m,n).gt.1.01)then + if (idiag_fnsm_prob .gt. 0) then + print *,'fm(',m,n,')=',fm(m,n),' > 1 - activate err43' + endif + fluxm(m,n) = fluxm(m,n)/fm(m,n) + endif + + end do + end do + + goto 60000 +!....................................................................... +! +! end calc. of activation fractions/fluxes +! for spectrum of updrafts (end of section 2) +! +!....................................................................... + + +!....................................................................... +! +! start calc. of activation fractions/fluxes +! for (single) uniform updraft (start of section 3) +! +!....................................................................... +50000 continue + wnuc=wbar+wdiab +! write(6,*)'uniform updraft =',wnuc + +! 04-nov-2005 rce - moved the code for "wnuc.le.0" code to here + if(wnuc.le.0.)then + do n=1,ntype_aer + do m=1,nsize_aer(n) + fn(m,n)=0 + fluxn(m,n)=0 + fs(m,n)=0 + fluxs(m,n)=0 + fm(m,n)=0 + fluxm(m,n)=0 + end do + end do + return + endif + + w=wbar + alw=alpha*wnuc + sqrtalw=sqrt(alw) + zeta=2.*sqrtalw*aten/(3.*sqrtg) + + if (isectional .gt. 0) then +! sectional model. +! use bulk properties + do n=1,ntype_aer + if(totn(n).gt.1.e-10)then + eta(1,n)=2*alw*sqrtalw/(totn(n)*beta*sqrtg) + else + eta(1,n)=1.e10 + endif + end do + call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,(/1/),gmsm,gmlnsig,smax) +! call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,nsize_aer,gmsm,gmlnsig,smax) + + else + + do n=1,ntype_aer + do m=1,nsize_aer(n) + if(na(m,n).gt.1.e-10)then + eta(m,n)=2*alw*sqrtalw/(na(m,n)*beta*sqrtg) + else + eta(m,n)=1.e10 + endif + end do + end do + + call maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,nsize_aer,sm,alnsign,smax) + + endif + + lnsmax=log(smax) + xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3 + +! print *,'smax=',smax + + + do 55002 n=1,ntype_aer + do 55000 m=1,nsize_aer(n) + +! 04-nov-2005 rce - check for bin_is_empty here too, just like earlier + if ( bin_is_empty(m,n) ) then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. + + else if ((isectional .eq. 2) .or. (isectional .eq. 4)) then +! sectional +! within-section dn/dx = a + b*x + xcut=xmincoeff-third*lnhygro(m,n) +! ycut=(exp(xcut)/rhi(m,n))**3 +! 07-jul-2006 rce - the above line gave a (rare) overflow when smax=1.0e-20 +! if (ycut > yhi), then actual value of ycut is unimportant, +! so do the following to avoid overflow + lnycut = 3.0 * ( xcut - log(rhi(m,n)) ) + lnycut = min( lnycut, log(yhi(m,n)*1.0e5) ) + ycut=exp(lnycut) +! write(6,*)'m,n,rcut,rlo,rhi=',m,n,exp(xcut),rlo(m,n),rhi(m,n) +! if(lnsmax.lt.lnsmn(m,n))then + if(ycut.gt.yhi(m,n))then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. +! elseif(lnsmax.gt.lnsmx(m,n))then + elseif(ycut.lt.ylo(m,n))then + fn(m,n)=1. + fs(m,n)=1. + fm(m,n)=1. + elseif ( bin_is_narrow(m,n) ) then +! 04-nov-2005 rce - for extremely narrow bins, +! do zero activation if xcut>xmean, 100% activation otherwise + if (ycut.gt.ymean(m,n)) then + fn(m,n)=0. + fs(m,n)=0. + fm(m,n)=0. + else + fn(m,n)=1. + fs(m,n)=1. + fm(m,n)=1. + endif + else + phiyy=ycut/yhi(m,n) + fn(m,n) = asub(m,n)*(1.0-phiyy) + 0.5*bsub(m,n)*(1.0-phiyy*phiyy) + if (fn(m,n).lt.zero .or. fn(m,n).gt.one) then + if (idiag_fnsm_prob .gt. 0) then + print *,'fn(',m,n,')=',fn(m,n),' outside 0,1 - activate err21' + print *,'na,volc =', na(m,n), volc(m,n) + print *,'asub,bsub =', asub(m,n), bsub(m,n) + print *,'yhi,ycut =', yhi(m,n), ycut + endif + endif + + if (fn(m,n) .le. zero) then +! 10-nov-2005 rce - if fn=0, then fs & fm must be 0 + fn(m,n)=zero + fs(m,n)=zero + fm(m,n)=zero + else if (fn(m,n) .ge. one) then +! 10-nov-2005 rce - if fn=1, then fs & fm must be 1 + fn(m,n)=one + fs(m,n)=one + fm(m,n)=one + else +! 10-nov-2005 rce - otherwise, calc fm and check it + fm(m,n) = (yhi(m,n)/ymean(m,n)) * (0.5*asub(m,n)*(1.0-phiyy*phiyy) + & + third*bsub(m,n)*(1.0-phiyy*phiyy*phiyy)) + if (fm(m,n).lt.fn(m,n) .or. fm(m,n).gt.one) then + if (idiag_fnsm_prob .gt. 0) then + print *,'fm(',m,n,')=',fm(m,n),' outside fn,1 - activate err22' + print *,'na,volc,fn =', na(m,n), volc(m,n), fn(m,n) + print *,'asub,bsub =', asub(m,n), bsub(m,n) + print *,'yhi,ycut =', yhi(m,n), ycut + endif + endif + if (fm(m,n) .le. fn(m,n)) then +! 10-nov-2005 rce - if fm=fn, then fs must =fn + fm(m,n)=fn(m,n) + fs(m,n)=fn(m,n) + else if (fm(m,n) .ge. one) then +! 10-nov-2005 rce - if fm=1, then fs & fn must be 1 + fm(m,n)=one + fs(m,n)=one + fn(m,n)=one + else +! 10-nov-2005 rce - these two checks assure that the mean size +! of the activated & interstitial particles will be between rlo & rhi + dumaa = fn(m,n)*(yhi(m,n)/ymean(m,n)) + fm(m,n) = min( fm(m,n), dumaa ) + dumaa = 1.0 + (fn(m,n)-1.0)*(ylo(m,n)/ymean(m,n)) + fm(m,n) = min( fm(m,n), dumaa ) +! 10-nov-2005 rce - now calculate fs and bound it by fn, fm + betayy = ylo(m,n)/yhi(m,n) + dumaa = phiyy**twothird + dumbb = betayy**twothird + fs(m,n) = & + (asub(m,n)*(1.0-phiyy*dumaa) + & + 0.625*bsub(m,n)*(1.0-phiyy*phiyy*dumaa)) / & + (asub(m,n)*(1.0-betayy*dumbb) + & + 0.625*bsub(m,n)*(1.0-betayy*betayy*dumbb)) + fs(m,n)=max(fs(m,n),fn(m,n)) + fs(m,n)=min(fs(m,n),fm(m,n)) + endif + endif + + endif + + else +! modal + x=2*(lnsm(m,n)-lnsmax)/(3*sq2*alnsign(m,n)) + fn(m,n)=0.5*(1.-ERF_ALT(x)) + arg=x-sq2*alnsign(m,n) + fs(m,n)=0.5*(1.-ERF_ALT(arg)) + arg=x-1.5*sq2*alnsign(m,n) + fm(m,n)=0.5*(1.-ERF_ALT(arg)) + endif + +! fn(m,n)=1. ! test +! fs(m,n)=1. +! fm(m,n)=1. + if((top.and.wbar.lt.0.).or.(.not.top.and.wbar.gt.0.))then + fluxn(m,n)=fn(m,n)*w + fluxs(m,n)=fs(m,n)*w + fluxm(m,n)=fm(m,n)*w + else + fluxn(m,n)=0 + fluxs(m,n)=0 + fluxm(m,n)=0 + endif + +55000 continue ! m=1,nsize_aer(n) +55002 continue ! n=1,ntype_aer + +! 04-nov-2005 rce - moved the code for "wnuc.le.0" from here +! to near the start the uniform undraft section + +!....................................................................... +! +! end calc. of activation fractions/fluxes +! for (single) uniform updraft (end of section 3) +! +!....................................................................... + + + +60000 continue + + +! do n=1,ntype_aer +! do m=1,nsize_aer(n) +! write(6,'(a,2i3,5e10.1)')'n,m,na,wbar,sigw,fn,fm=',n,m,na(m,n),wbar,sigw,fn(m,n),fm(m,n) +! end do +! end do + + + return + end subroutine activate + + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + subroutine maxsat(zeta,eta,maxd_atype,ntype_aer,maxd_asize,nsize_aer, & + sm,alnsign,smax) + +! calculates maximum supersaturation for multiple +! competing aerosol modes. + +! Abdul-Razzak and Ghan, A parameterization of aerosol activation. +! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + integer maxd_atype + integer ntype_aer + integer maxd_asize + integer nsize_aer(maxd_atype) ! number of size bins + real sm(maxd_asize,maxd_atype) ! critical supersaturation for number mode radius + real zeta, eta(maxd_asize,maxd_atype) + real alnsign(maxd_asize,maxd_atype) ! ln(sigma) + integer pmax + parameter (pmax=100) + real f1(pmax,pmax) + real smax ! maximum supersaturation + save f1 + logical first + data first/.true./ + save first + real twothird,sum +! 04-nov-2005 rce - make this more precise +! data twothird/0.666666666/ + data twothird/0.66666666667/ + save twothird + integer m ! size index + integer n ! type index + + if(first)then +! calculate and save f1(sigma). assumes sigma is invariant. + do n=1,ntype_aer + do m=1,nsize_aer(n) + if(ntype_aer>pmax)then + print *,'pmax < ',ntype_aer,' in maxsat' + call exit + endif + if(nsize_aer(n)>pmax)then + print *,'pmax < ',nsize_aer(n),' in maxsat' + call exit + endif + f1(m,n)=0.5*exp(2.5*alnsign(m,n)*alnsign(m,n)) + end do + end do + first=.false. + endif + + do n=1,ntype_aer + do m=1,nsize_aer(n) + if(zeta.gt.1.e5*eta(m,n).or.sm(m,n)*sm(m,n).gt.1.e5*eta(m,n))then +! weak forcing. essentially none activated + smax=1.e-20 + else +! significant activation of this mode. calc activation all modes. + go to 1 + endif + end do + end do + + return + + 1 continue + + sum=0 + do n=1,ntype_aer + do m=1,nsize_aer(n) + if(eta(m,n).gt.1.e-20)then + g1=sqrt(zeta/eta(m,n)) + g1=g1*g1*g1 + g2=sm(m,n)/sqrt(eta(m,n)+3*zeta) + g2=sqrt(g2) + g2=g2*g2*g2 + sum=sum+(f1(m,n)*g1+(1.+0.25*alnsign(m,n))*g2)/(sm(m,n)*sm(m,n)) + else + sum=1.e20 + endif + end do + end do + + smax=1./sqrt(sum) + + return + end subroutine maxsat + + + + +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3); +! grid_id, ktau, i, j, isize, itype added to arg list to assist debugging + subroutine loadaer(chem,k,kmn,kmx,num_chem,cs,npv, & + dlo_sect,dhi_sect,maxd_acomp, ncomp, & + grid_id, ktau, i, j, isize, itype, & + numptr_aer, numptrcw_aer, dens_aer, & + massptr_aer, massptrcw_aer, & + maerosol, maerosolcw, & + maerosol_tot, maerosol_totcw, & + naerosol, naerosolcw, & + vaerosol, vaerosolcw) + + implicit none + +! load aerosol number, surface, mass concentrations + +! input + + integer num_chem ! maximum number of consituents + integer k,kmn,kmx + real chem(kmn:kmx,num_chem) ! aerosol mass, number mixing ratios + real cs ! air density (kg/m3) + real npv ! number per volume concentration (/m3) + integer maxd_acomp,ncomp + integer numptr_aer,numptrcw_aer + integer massptr_aer(maxd_acomp), massptrcw_aer(maxd_acomp) + real dens_aer(maxd_acomp) ! aerosol material density (g/cm3) + real dlo_sect,dhi_sect ! minimum, maximum diameter of section (cm) + integer grid_id, ktau, i, j, isize, itype + +! output + + real naerosol ! interstitial number conc (/m3) + real naerosolcw ! activated number conc (/m3) + real maerosol(maxd_acomp) ! interstitial mass conc (kg/m3) + real maerosolcw(maxd_acomp) ! activated mass conc (kg/m3) + real maerosol_tot ! total-over-species interstitial mass conc (kg/m3) + real maerosol_totcw ! total-over-species activated mass conc (kg/m3) + real vaerosol ! interstitial volume conc (m3/m3) + real vaerosolcw ! activated volume conc (m3/m3) + +! internal + + integer lnum,lnumcw,l,ltype,lmass,lmasscw,lsfc,lsfccw + real num_at_dhi, num_at_dlo + real npv_at_dhi, npv_at_dlo + real pi + real specvol ! inverse aerosol material density (m3/kg) +! 04-nov-2005 rce - make this more precise +! data pi/3.14159/ + data pi/3.1415926526/ + save pi + + + lnum=numptr_aer + lnumcw=numptrcw_aer + maerosol_tot=0. + maerosol_totcw=0. + vaerosol=0. + vaerosolcw=0. + do l=1,ncomp + lmass=massptr_aer(l) + lmasscw=massptrcw_aer(l) + maerosol(l)=chem(k,lmass)*cs + maerosol(l)=max(maerosol(l),0.) + maerosolcw(l)=chem(k,lmasscw)*cs + maerosolcw(l)=max(maerosolcw(l),0.) + maerosol_tot=maerosol_tot+maerosol(l) + maerosol_totcw=maerosol_totcw+maerosolcw(l) +! [ 1.e-3 factor because dens_aer is (g/cm3), specvol is (m3/kg) ] + specvol=1.0e-3/dens_aer(l) + vaerosol=vaerosol+maerosol(l)*specvol + vaerosolcw=vaerosolcw+maerosolcw(l)*specvol +! write(6,'(a,3e12.2)')'maerosol,dens_aer,vaerosol=',maerosol(l),dens_aer(l),vaerosol + enddo + + if(lnum.gt.0)then +! aerosol number predicted +! [ 1.0e6 factor because because dhi_ & dlo_sect are (cm), vaerosol is (m3) ] + npv_at_dhi = 6.0e6/(pi*dhi_sect*dhi_sect*dhi_sect) + npv_at_dlo = 6.0e6/(pi*dlo_sect*dlo_sect*dlo_sect) + + naerosol=chem(k,lnum)*cs + naerosolcw=chem(k,lnumcw)*cs + num_at_dhi = vaerosol*npv_at_dhi + num_at_dlo = vaerosol*npv_at_dlo + naerosol = max( num_at_dhi, min( num_at_dlo, naerosol ) ) +! write(6,'(a,5e10.1)')'naerosol,num_at_dhi,num_at_dlo,dhi_sect,dlo_sect', & +! naerosol,num_at_dhi,num_at_dlo,dhi_sect,dlo_sect + num_at_dhi = vaerosolcw*npv_at_dhi + num_at_dlo = vaerosolcw*npv_at_dlo + naerosolcw = max( num_at_dhi, min( num_at_dlo, naerosolcw ) ) + else +! aerosol number diagnosed from mass and prescribed size + naerosol=vaerosol*npv + naerosol=max(naerosol,0.) + naerosolcw=vaerosolcw*npv + naerosolcw=max(naerosolcw,0.) + endif + + + return + end subroutine loadaer + + + +!----------------------------------------------------------------------- + real function erfc_num_recipes( x ) +! +! from press et al, numerical recipes, 1990, page 164 +! + implicit none + real x + double precision erfc_dbl, dum, t, zz + + zz = abs(x) + t = 1.0/(1.0 + 0.5*zz) + +! erfc_num_recipes = +! & t*exp( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + +! & t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + +! & t*(-1.13520398 + +! & t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) + + dum = ( -zz*zz - 1.26551223 + t*(1.00002368 + t*(0.37409196 + & + t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + & + t*(-1.13520398 + & + t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) + + erfc_dbl = t * exp(dum) + if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl + + erfc_num_recipes = erfc_dbl + + return + end function erfc_num_recipes + +!----------------------------------------------------------------------- + real function erf_alt( x ) + + implicit none + + real,intent(in) :: x + + erf_alt = 1. - erfc_num_recipes(x) + + end function erf_alt + +END MODULE module_mixactivate diff --git a/wrfv2_fire/phys/module_mp_etanew.F b/wrfv2_fire/phys/module_mp_etanew.F new file mode 100644 index 00000000..7f7529af --- /dev/null +++ b/wrfv2_fire/phys/module_mp_etanew.F @@ -0,0 +1,2589 @@ +!WRF:MODEL_MP:PHYSICS +! +MODULE module_mp_etanew +! +!----------------------------------------------------------------------- + REAL,PRIVATE,SAVE :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & + & CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, & + & RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & + & RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax +! + INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 + REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH +! + REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & + & DelDMI=1.e-6,XMImin=1.e6*DMImin + INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536, & + & MDImin=XMImin, MDImax=XMImax + REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & + & ACCRI,SDENS,VSNOWI,VENTI1,VENTI2 +! + REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, & + & DelDMR=1.e-6,XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax + INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax + REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & + & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 +! + INTEGER, PRIVATE,PARAMETER :: Nrime=40 + REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF +! + INTEGER,PARAMETER :: NX=7501 + REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 + REAL, DIMENSION(NX),PRIVATE,SAVE :: TBPVS,TBPVS0 + REAL, PRIVATE,SAVE :: C1XPVS0,C2XPVS0,C1XPVS,C2XPVS +! + REAL, PRIVATE,PARAMETER :: & +!--- Physical constants follow: + & CP=1004.6, EPSQ=1.E-12, GRAV=9.806, RHOL=1000., RD=287.04 & + & ,RV=461.5, T0C=273.15, XLS=2.834E6 & +!--- Derived physical constants follow: + & ,EPS=RD/RV, EPS1=RV/RD-1., EPSQ1=1.001*EPSQ & + & ,RCP=1./CP, RCPRV=RCP/RV, RGRAV=1./GRAV, RRHOL=1./RHOL & + & ,XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, XLS3=XLS*XLS/RV & +!--- Constants specific to the parameterization follow: +!--- CLIMIT/CLIMIT1 are lower limits for treating accumulated precipitation + & ,CLIMIT=10.*EPSQ, CLIMIT1=-CLIMIT & + & ,C1=1./3. & + & ,DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3 & + & ,XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 + INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 +! +! ====================================================================== +!--- Important tunable parameters that are exported to other modules +! * RHgrd - threshold relative humidity for onset of condensation +! * T_ICE - temperature (C) threshold at which all remaining liquid water +! is glaciated to ice +! * T_ICE_init - maximum temperature (C) at which ice nucleation occurs +! * NLImax - maximum number concentrations (m**-3) of large ice (snow/graupel/sleet) +! * NLImin - minimum number concentrations (m**-3) of large ice (snow/graupel/sleet) +! * N0r0 - assumed intercept (m**-4) of rain drops if drop diameters are between 0.2 and 0.45 mm +! * N0rmin - minimum intercept (m**-4) for rain drops +! * NCW - number concentrations of cloud droplets (m**-3) +! * FLARGE1, FLARGE2 - number fraction of large ice to total (large+snow) ice +! at T>0C and in presence of sublimation (FLARGE1), otherwise in +! presence of ice saturated/supersaturated conditions +! ====================================================================== + REAL, PUBLIC,PARAMETER :: & + & RHgrd=1. & + & ,T_ICE=-30. & + & ,T_ICEK=T0C+T_ICE & + & ,T_ICE_init=-5. & + & ,NLImax=5.E3 & + & ,NLImin=1.E3 & + & ,N0r0=8.E6 & + & ,N0rmin=1.E4 & + & ,NCW=100.E6 & + & ,FLARGE1=1. & + & ,FLARGE2=.2 +!--- Other public variables passed to other routines: + REAL,PUBLIC,SAVE :: QAUT0 + REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI +! +! + CONTAINS + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + SUBROUTINE ETAMP_NEW (itimestep,DT,DX,DY, & + & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt, & + & LOWLYR,SR, & + & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & + & QC,QR,QS, & + & mp_restart_state,tbpvs_state,tbpvs0_state, & + & RAINNC,RAINNCV, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE & + & ,ITIMESTEP + + REAL, INTENT(IN) :: DT,DX,DY + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & dz8w,p_phy,pi_phy,rho_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & th_phy,qv,qt + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + & qc,qr,qs + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY + REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & + & RAINNC,RAINNCV + REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR +! + REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE +! + REAL,DIMENSION(nx),INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE +! + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + +!----------------------------------------------------------------------- +! LOCAL VARS +!----------------------------------------------------------------------- + +! NSTATS,QMAX,QTOT are diagnostic vars + + INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS + REAL, DIMENSION(ITLO:ITHI,5) :: QMAX + REAL, DIMENSION(ITLO:ITHI,22):: QTOT + +! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). +! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE +! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE + +! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related +! the microphysics scheme. Instead, they will be used by Eta precip +! assimilation. + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + & TLATGS_PHY,TRAIN_PHY + REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC + REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy + + INTEGER :: I,J,K,KFLIP + REAL :: WC +! +!----------------------------------------------------------------------- +!********************************************************************** +!----------------------------------------------------------------------- +! + MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2) +! + C1XPVS0=MP_RESTART_STATE(MY_T2+1) + C2XPVS0=MP_RESTART_STATE(MY_T2+2) + C1XPVS =MP_RESTART_STATE(MY_T2+3) + C2XPVS =MP_RESTART_STATE(MY_T2+4) + CIACW =MP_RESTART_STATE(MY_T2+5) + CIACR =MP_RESTART_STATE(MY_T2+6) + CRACW =MP_RESTART_STATE(MY_T2+7) + CRAUT =MP_RESTART_STATE(MY_T2+8) +! + TBPVS(1:NX) =TBPVS_STATE(1:NX) + TBPVS0(1:NX)=TBPVS0_STATE(1:NX) +! + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) !Convert to specific humidity + ENDDO + ENDDO + ENDDO + +! initial diagnostic variables and data assimilation vars +! (will need to delete this part in the future) + + DO k = 1,4 + DO i = ITLO,ITHI + NSTATS(i,k)=0. + ENDDO + ENDDO + + DO k = 1,5 + DO i = ITLO,ITHI + QMAX(i,k)=0. + ENDDO + ENDDO + + DO k = 1,22 + DO i = ITLO,ITHI + QTOT(i,k)=0. + ENDDO + ENDDO + +! initial data assimilation vars (will need to delete this part in the future) + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + TLATGS_PHY (i,k,j)=0. + TRAIN_PHY (i,k,j)=0. + ENDDO + ENDDO + ENDDO + + DO j = jts,jte + DO i = its,ite + ACPREC(i,j)=0. + APREC (i,j)=0. + PREC (i,j)=0. + SR (i,j)=0. + ENDDO + ENDDO + +!----------------------------------------------------------------------- + + CALL EGCP01DRV(DT,LOWLYR, & + & APREC,PREC,ACPREC,SR,NSTATS,QMAX,QTOT, & + & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & + & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) !Convert to mixing ratio + WC=qt(I,K,J) + QS(I,K,J)=0. + QR(I,K,J)=0. + QC(I,K,J)=0. + IF(F_ICE_PHY(I,K,J)>=1.)THEN + QS(I,K,J)=WC + ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN + QC(I,K,J)=WC + ELSE + QS(I,K,J)=F_ICE_PHY(I,K,J)*WC + QC(I,K,J)=WC-QS(I,K,J) + ENDIF +! + IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN + IF(F_RAIN_PHY(I,K,J).GE.1.)THEN + QR(I,K,J)=QC(I,K,J) + QC(I,K,J)=0. + ELSE + QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) + QC(I,K,J)=QC(I,K,J)-QR(I,K,J) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +! +! update rain (from m to mm) + + DO j=jts,jte + DO i=its,ite + RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) + RAINNCV(i,j)=APREC(i,j)*1000. + ENDDO + ENDDO +! + MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2) + MP_RESTART_STATE(MY_T2+1)=C1XPVS0 + MP_RESTART_STATE(MY_T2+2)=C2XPVS0 + MP_RESTART_STATE(MY_T2+3)=C1XPVS + MP_RESTART_STATE(MY_T2+4)=C2XPVS + MP_RESTART_STATE(MY_T2+5)=CIACW + MP_RESTART_STATE(MY_T2+6)=CIACR + MP_RESTART_STATE(MY_T2+7)=CRACW + MP_RESTART_STATE(MY_T2+8)=CRAUT +! + TBPVS_STATE(1:NX) =TBPVS(1:NX) + TBPVS0_STATE(1:NX)=TBPVS0(1:NX) + +!----------------------------------------------------------------------- + + END SUBROUTINE ETAMP_NEW + +!----------------------------------------------------------------------- + + SUBROUTINE EGCP01DRV( & + & DTPH,LOWLYR,APREC,PREC,ACPREC,SR, & + & NSTATS,QMAX,QTOT, & + & dz8w,RHO_PHY,CWM_PHY,T_PHY,Q_PHY,F_ICE_PHY,P_PHY, & + & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) +!----------------------------------------------------------------------- +! DTPH Physics time step (s) +! CWM_PHY (qt) Mixing ratio of the total condensate. kg/kg +! Q_PHY Mixing ratio of water vapor. kg/kg +! F_RAIN_PHY Fraction of rain. +! F_ICE_PHY Fraction of ice. +! F_RIMEF_PHY Mass ratio of rimed ice (rime factor). +! +!TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related the +!micrphysics sechme. Instead, they will be used by Eta precip assimilation. +! +!NSTATS,QMAX,QTOT are used for diagnosis purposes. +! +!----------------------------------------------------------------------- +!--- Variables APREC,PREC,ACPREC,SR are calculated for precip assimilation +! and/or ZHAO's scheme in Eta and are not required by this microphysics +! scheme itself. +!--- NSTATS,QMAX,QTOT are used for diagnosis purposes only. They will be +! printed out when PRINT_diag is true. +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + LOGICAL, PARAMETER :: PRINT_diag=.FALSE. +! VARIABLES PASSED IN/OUT + INTEGER,INTENT(IN ) :: ids,ide, jds,jde, kds,kde & + & ,ims,ime, jms,jme, kms,kme & + & ,its,ite, jts,jte, kts,kte + REAL,INTENT(IN) :: DTPH + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + INTEGER,DIMENSION(ITLO:ITHI,4),INTENT(INOUT) :: NSTATS + REAL,DIMENSION(ITLO:ITHI,5),INTENT(INOUT) :: QMAX + REAL,DIMENSION(ITLO:ITHI,22),INTENT(INOUT) :: QTOT + REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & + & APREC,PREC,ACPREC,SR + REAL,DIMENSION( its:ite, kts:kte, jts:jte ),INTENT(INOUT) :: t_phy + REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: & + & dz8w,P_PHY,RHO_PHY + REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT) :: & + & CWM_PHY, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY & + & ,Q_PHY,TRAIN_PHY +! +!----------------------------------------------------------------------- +!LOCAL VARIABLES +!----------------------------------------------------------------------- +! +#define CACHE_FRIENDLY_MP_ETANEW +#ifdef CACHE_FRIENDLY_MP_ETANEW +# define TEMP_DIMS kts:kte,its:ite,jts:jte +# define TEMP_DEX L,I,J +#else +# define TEMP_DIMS its:ite,jts:jte,kts:kte +# define TEMP_DEX I,J,L +#endif +! + INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP + REAL,DIMENSION(TEMP_DIMS) :: CWM,T,Q,TRAIN,TLATGS,P + REAL,DIMENSION(kts:kte,its:ite,jts:jte) :: F_ice,F_rain,F_RimeF + INTEGER,DIMENSION(its:ite,jts:jte) :: LMH + REAL :: TC,WC,QI,QR,QW,Fice,Frain,DUM,ASNOW,ARAIN + REAL,DIMENSION(kts:kte) :: P_col,Q_col,T_col,QV_col,WC_col, & + RimeF_col,QI_col,QR_col,QW_col, THICK_col,DPCOL + REAL,DIMENSION(2) :: PRECtot,PRECmax +!----------------------------------------------------------------------- +! + DO J=JTS,JTE + DO I=ITS,ITE + LMH(I,J) = KTE-LOWLYR(I,J)+1 + ENDDO + ENDDO + + DO 98 J=JTS,JTE + DO 98 I=ITS,ITE + DO L=KTS,KTE + KFLIP=KTE+1-L + CWM(TEMP_DEX)=CWM_PHY(I,KFLIP,J) + T(TEMP_DEX)=T_PHY(I,KFLIP,J) + Q(TEMP_DEX)=Q_PHY(I,KFLIP,J) + P(TEMP_DEX)=P_PHY(I,KFLIP,J) + TLATGS(TEMP_DEX)=TLATGS_PHY(I,KFLIP,J) + TRAIN(TEMP_DEX)=TRAIN_PHY(I,KFLIP,J) + F_ice(L,I,J)=F_ice_PHY(I,KFLIP,J) + F_rain(L,I,J)=F_rain_PHY(I,KFLIP,J) + F_RimeF(L,I,J)=F_RimeF_PHY(I,KFLIP,J) + ENDDO +98 CONTINUE + + DO 100 J=JTS,JTE + DO 100 I=ITS,ITE + LSFC=LMH(I,J) ! "L" of surface +! + DO K=KTS,KTE + KFLIP=KTE+1-K + DPCOL(K)=RHO_PHY(I,KFLIP,J)*GRAV*dz8w(I,KFLIP,J) + ENDDO +! + ! + !--- Initialize column data (1D arrays) + ! + L=1 + IF (CWM(TEMP_DEX) .LE. EPSQ) CWM(TEMP_DEX)=EPSQ + F_ice(1,I,J)=1. + F_rain(1,I,J)=0. + F_RimeF(1,I,J)=1. + DO L=1,LSFC + ! + !--- Pressure (Pa) = (Psfc-Ptop)*(ETA/ETA_sfc)+Ptop + ! + P_col(L)=P(TEMP_DEX) + ! + !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) + ! + THICK_col(L)=DPCOL(L)*RGRAV + T_col(L)=T(TEMP_DEX) + TC=T_col(L)-T0C + QV_col(L)=max(EPSQ, Q(TEMP_DEX)) + IF (CWM(TEMP_DEX) .LE. EPSQ1) THEN + WC_col(L)=0. + IF (TC .LT. T_ICE) THEN + F_ice(L,I,J)=1. + ELSE + F_ice(L,I,J)=0. + ENDIF + F_rain(L,I,J)=0. + F_RimeF(L,I,J)=1. + ELSE + WC_col(L)=CWM(TEMP_DEX) + ENDIF + ! + !--- Determine composition of condensate in terms of + ! cloud water, ice, & rain + ! + WC=WC_col(L) + QI=0. + QR=0. + QW=0. + Fice=F_ice(L,I,J) + Frain=F_rain(L,I,J) + IF (Fice .GE. 1.) THEN + QI=WC + ELSE IF (Fice .LE. 0.) THEN + QW=WC + ELSE + QI=Fice*WC + QW=WC-QI + ENDIF + IF (QW.GT.0. .AND. Frain.GT.0.) THEN + IF (Frain .GE. 1.) THEN + QR=QW + QW=0. + ELSE + QR=Frain*QW + QW=QW-QR + ENDIF + ENDIF + RimeF_col(L)=F_RimeF(L,I,J) ! (real) + QI_col(L)=QI + QR_col(L)=QR + QW_col(L)=QW + ENDDO +! +!####################################################################### + ! + !--- Perform the microphysical calculations in this column + ! + I_index=I + J_index=J + CALL EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, LSFC, & + & P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & + & THICK_col, WC_col,KTS,KTE,NSTATS,QMAX,QTOT ) + + + ! +!####################################################################### +! + ! + !--- Update storage arrays + ! + DO L=1,LSFC + TRAIN(TEMP_DEX)=(T_col(L)-T(TEMP_DEX))/DTPH + TLATGS(TEMP_DEX)=T_col(L)-T(TEMP_DEX) + T(TEMP_DEX)=T_col(L) + Q(TEMP_DEX)=QV_col(L) + CWM(TEMP_DEX)=WC_col(L) + ! + !--- REAL*4 array storage + ! + F_RimeF(L,I,J)=MAX(1., RimeF_col(L)) + IF (QI_col(L) .LE. EPSQ) THEN + F_ice(L,I,J)=0. + IF (T_col(L) .LT. T_ICEK) F_ice(L,I,J)=1. + ELSE + F_ice(L,I,J)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) + ENDIF + IF (QR_col(L) .LE. EPSQ) THEN + DUM=0 + ELSE + DUM=QR_col(L)/(QR_col(L)+QW_col(L)) + ENDIF + F_rain(L,I,J)=DUM + ! + ENDDO + ! + !--- Update accumulated precipitation statistics + ! + !--- Surface precipitation statistics; SR is fraction of surface + ! precipitation (if >0) associated with snow + ! + APREC(I,J)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying + PREC(I,J)=PREC(I,J)+APREC(I,J) + ACPREC(I,J)=ACPREC(I,J)+APREC(I,J) + IF(APREC(I,J) .LT. 1.E-8) THEN + SR(I,J)=0. + ELSE + SR(I,J)=RRHOL*ASNOW/APREC(I,J) + ENDIF + ! + !--- Debug statistics + ! + IF (PRINT_diag) THEN + PRECtot(1)=PRECtot(1)+ARAIN + PRECtot(2)=PRECtot(2)+ASNOW + PRECmax(1)=MAX(PRECmax(1), ARAIN) + PRECmax(2)=MAX(PRECmax(2), ASNOW) + ENDIF + + +!####################################################################### +!####################################################################### +! +100 CONTINUE ! End "I" & "J" loops + DO 101 J=JTS,JTE + DO 101 I=ITS,ITE + DO L=KTS,KTE + KFLIP=KTE+1-L + CWM_PHY(I,KFLIP,J)=CWM(TEMP_DEX) + T_PHY(I,KFLIP,J)=T(TEMP_DEX) + Q_PHY(I,KFLIP,J)=Q(TEMP_DEX) + TLATGS_PHY(I,KFLIP,J)=TLATGS(TEMP_DEX) + TRAIN_PHY(I,KFLIP,J)=TRAIN(TEMP_DEX) + F_ice_PHY(I,KFLIP,J)=F_ice(L,I,J) + F_rain_PHY(I,KFLIP,J)=F_rain(L,I,J) + F_RimeF_PHY(I,KFLIP,J)=F_RimeF(L,I,J) + ENDDO +101 CONTINUE + END SUBROUTINE EGCP01DRV +! +! +!############################################################################### +! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL +! (1) Represents sedimentation by preserving a portion of the precipitation +! through top-down integration from cloud-top. Modified procedure to +! Zhao and Carr (1997). +! (2) Microphysical equations are modified to be less sensitive to time +! steps by use of Clausius-Clapeyron equation to account for changes in +! saturation mixing ratios in response to latent heating/cooling. +! (3) Prevent spurious temperature oscillations across 0C due to +! microphysics. +! (4) Uses lookup tables for: calculating two different ventilation +! coefficients in condensation and deposition processes; accretion of +! cloud water by precipitation; precipitation mass; precipitation rate +! (and mass-weighted precipitation fall speeds). +! (5) Assumes temperature-dependent variation in mean diameter of large ice +! (Houze et al., 1979; Ryan et al., 1996). +! -> 8/22/01: This relationship has been extended to colder temperatures +! to parameterize smaller large-ice particles down to mean sizes of MDImin, +! which is 50 microns reached at -55.9C. +! (6) Attempts to differentiate growth of large and small ice, mainly for +! improved transition from thin cirrus to thick, precipitating ice +! anvils. +! -> 8/22/01: This feature has been diminished by effectively adjusting to +! ice saturation during depositional growth at temperatures colder than +! -10C. Ice sublimation is calculated more explicitly. The logic is +! that sources of are either poorly understood (e.g., nucleation for NWP) +! or are not represented in the Eta model (e.g., detrainment of ice from +! convection). Otherwise the model is too wet compared to the radiosonde +! observations based on 1 Feb - 18 March 2001 retrospective runs. +! (7) Top-down integration also attempts to treat mixed-phase processes, +! allowing a mixture of ice and water. Based on numerous observational +! studies, ice growth is based on nucleation at cloud top & +! subsequent growth by vapor deposition and riming as the ice particles +! fall through the cloud. Effective nucleation rates are a function +! of ice supersaturation following Meyers et al. (JAM, 1992). +! -> 8/22/01: The simulated relative humidities were far too moist compared +! to the rawinsonde observations. This feature has been substantially +! diminished, limited to a much narrower temperature range of 0 to -10C. +! (8) Depositional growth of newly nucleated ice is calculated for large time +! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals +! using their ice crystal masses calculated after 600 s of growth in water +! saturated conditions. The growth rates are normalized by time step +! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). +! -> 8/22/01: This feature has been effectively limited to 0 to -10C. +! (9) Ice precipitation rates can increase due to increase in response to +! cloud water riming due to (a) increased density & mass of the rimed +! ice, and (b) increased fall speeds of rimed ice. +! -> 8/22/01: This feature has been effectively limited to 0 to -10C. +!############################################################################### +!############################################################################### +! + SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & + & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & + & THICK_col, WC_col ,KTS,KTE,NSTATS,QMAX,QTOT) +! +!############################################################################### +!############################################################################### +! +!------------------------------------------------------------------------------- +!----- NOTE: Code is currently set up w/o threading! +!------------------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation +! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 +! PRGRMMR: Jin (Modification for WRF structure) +!------------------------------------------------------------------------------- +! ABSTRACT: +! * Merges original GSCOND & PRECPD subroutines. +! * Code has been substantially streamlined and restructured. +! * Exchange between water vapor & small cloud condensate is calculated using +! the original Asai (1965, J. Japan) algorithm. See also references to +! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. +! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) +! parameterization. +!------------------------------------------------------------------------------- +! +! USAGE: +! * CALL EGCP01COLUMN FROM SUBROUTINE EGCP01DRV +! +! INPUT ARGUMENT LIST: +! DTPH - physics time step (s) +! I_index - I index +! J_index - J index +! LSFC - Eta level of level above surface, ground +! P_col - vertical column of model pressure (Pa) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! THICK_col - vertical column of model mass thickness (density*height increment) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! +! +! OUTPUT ARGUMENT LIST: +! ARAIN - accumulated rainfall at the surface (kg) +! ASNOW - accumulated snowfall at the surface (kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! +! OUTPUT FILES: +! NONE +! +! Subprograms & Functions called: +! * Real Function CONDENSE - cloud water condensation +! * Real Function DEPOSIT - ice deposition (not sublimation) +! +! UNIQUE: NONE +! +! LIBRARY: NONE +! +! COMMON BLOCKS: +! CMICRO_CONS - key constants initialized in GSMCONST +! CMICRO_STATS - accumulated and maximum statistics +! CMY_GROWTH - lookup table for growth of ice crystals in +! water saturated conditions (Miller & Young, 1979) +! IVENT_TABLES - lookup tables for ventilation effects of ice +! IACCR_TABLES - lookup tables for accretion rates of ice +! IMASS_TABLES - lookup tables for mass content of ice +! IRATE_TABLES - lookup tables for precipitation rates of ice +! IRIME_TABLES - lookup tables for increase in fall speed of rimed ice +! RVENT_TABLES - lookup tables for ventilation effects of rain +! RACCR_TABLES - lookup tables for accretion rates of rain +! RMASS_TABLES - lookup tables for mass content of rain +! RVELR_TABLES - lookup tables for fall speeds of rain +! RRATE_TABLES - lookup tables for precipitation rates of rain +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +! +! +!------------------------------------------------------------------------- +!--------------- Arrays & constants in argument list --------------------- +!------------------------------------------------------------------------- +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: KTS,KTE,I_index, J_index, LSFC + REAL,INTENT(INOUT) :: ARAIN, ASNOW + REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: P_col, QI_col,QR_col & + & ,QV_col ,QW_col, RimeF_col, T_col, THICK_col,WC_col +! +!------------------------------------------------------------------------- +!-------------- Common blocks for microphysical statistics --------------- +!------------------------------------------------------------------------- +! +!------------------------------------------------------------------------- +!--------- Common blocks for constants initialized in GSMCONST ---------- +! + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + INTEGER,INTENT(INOUT) :: NSTATS(ITLO:ITHI,4) + REAL,INTENT(INOUT) :: QMAX(ITLO:ITHI,5),QTOT(ITLO:ITHI,22) +! +!------------------------------------------------------------------------- +!--------------- Common blocks for various lookup tables ----------------- +! +!--- Discretized growth rates of small ice crystals after their nucleation +! at 1 C intervals from -1 C to -35 C, based on calculations by Miller +! and Young (1979, JAS) after 600 s of growth. Resultant growth rates +! are multiplied by physics time step in GSMCONST. +! +!------------------------------------------------------------------------- +! +!--- Mean ice-particle diameters varying from 50 microns to 1000 microns +! (1 mm), assuming an exponential size distribution. +! +!---- Meaning of the following arrays: +! - mdiam - mean diameter (m) +! - VENTI1 - integrated quantity associated w/ ventilation effects +! (capacitance only) for calculating vapor deposition onto ice +! - VENTI2 - integrated quantity associated w/ ventilation effects +! (with fall speed) for calculating vapor deposition onto ice +! - ACCRI - integrated quantity associated w/ cloud water collection by ice +! - MASSI - integrated quantity associated w/ ice mass +! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate +! precipitation rates +! +! +!------------------------------------------------------------------------- +! +!--- VEL_RF - velocity increase of rimed particles as functions of crude +! particle size categories (at 0.1 mm intervals of mean ice particle +! sizes) and rime factor (different values of Rime Factor of 1.1**N, +! where N=0 to Nrime). +! +!------------------------------------------------------------------------- +! +!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns +! (0.45 mm), assuming an exponential size distribution. +! +!------------------------------------------------------------------------- +!------- Key parameters, local variables, & important comments --------- +!----------------------------------------------------------------------- +! +!--- TOLER => Tolerance or precision for accumulated precipitation +! + REAL, PARAMETER :: TOLER=5.E-7, C2=1./6., RHO0=1.194, Xratio=.025 +! +!--- If BLEND=1: +! precipitation (large) ice amounts are estimated at each level as a +! blend of ice falling from the grid point above and the precip ice +! present at the start of the time step (see TOT_ICE below). +!--- If BLEND=0: +! precipitation (large) ice amounts are estimated to be the precip +! ice present at the start of the time step. +! +!--- Extended to include sedimentation of rain on 2/5/01 +! + REAL, PARAMETER :: BLEND=1. +! +!--- This variable is for debugging purposes (if .true.) +! + LOGICAL, PARAMETER :: PRINT_diag=.FALSE. +! +!----------------------------------------------------------------------- +!--- Local variables +!----------------------------------------------------------------------- +! + REAL EMAIRI, N0r, NLICE, NSmICE + LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical + INTEGER :: IDR,INDEX_MY,INDEXR,INDEXR1,INDEXS,IPASS,ITDX,IXRF, & + & IXS,LBEF,L +! + REAL :: ABI,ABW,AIEVP,ARAINnew,ASNOWnew,BLDTRH,BUDGET, & + & CREVP,DELI,DELR,DELT,DELV,DELW,DENOMF, & + & DENOMI,DENOMW,DENOMWI,DIDEP, & + & DIEVP,DIFFUS,DLI,DTPH,DTRHO,DUM,DUM1, & + & DUM2,DWV0,DWVI,DWVR,DYNVIS,ESI,ESW,FIR,FLARGE,FLIMASS, & + & FSMALL,FWR,FWS,GAMMAR,GAMMAS, & + & PCOND,PIACR,PIACW,PIACWI,PIACWR,PICND,PIDEP,PIDEP_max, & + & PIEVP,PILOSS,PIMLT,PP,PRACW,PRAUT,PREVP,PRLOSS, & + & QI,QInew,QLICE,QR,QRnew,QSI,QSIgrd,QSInew,QSW,QSW0, & + & QSWgrd,QSWnew,QT,QTICE,QTnew,QTRAIN,QV,QW,QW0,QWnew, & + & RFACTOR,RHO,RIMEF,RIMEF1,RQR,RR,RRHO,SFACTOR, & + & TC,TCC,TFACTOR,THERM_COND,THICK,TK,TK2,TNEW, & + & TOT_ICE,TOT_ICEnew,TOT_RAIN,TOT_RAINnew, & + & VEL_INC,VENTR,VENTIL,VENTIS,VRAIN1,VRAIN2,VRIMEF,VSNOW, & + & WC,WCnew,WSgrd,WS,WSnew,WV,WVnew,WVQW, & + & XLF,XLF1,XLI,XLV,XLV1,XLV2,XLIMASS,XRF,XSIMASS +! +!####################################################################### +!########################## Begin Execution ############################ +!####################################################################### +! +! + ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) + ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) +! +!----------------------------------------------------------------------- +!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ +!----------------------------------------------------------------------- +! + + DO 10 L=1,LSFC + +!--- Skip this level and go to the next lower level if no condensate +! and very low specific humidities +! + IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 +! +!----------------------------------------------------------------------- +!------------ Proceed with cloud microphysics calculations ------------- +!----------------------------------------------------------------------- +! + TK=T_col(L) ! Temperature (deg K) + TC=TK-T0C ! Temperature (deg C) + PP=P_col(L) ! Pressure (Pa) + QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) + WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) + WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) +! +!----------------------------------------------------------------------- +!--- Moisture variables below are mixing ratios & not specifc humidities +!----------------------------------------------------------------------- +! + CLEAR=.TRUE. +! +!--- This check is to determine grid-scale saturation when no condensate is present +! + ESW=1000.*FPVS0(TK) ! Saturation vapor pressure w/r/t water + QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water + WS=QSW ! General saturation mixing ratio (water/ice) + IF (TC .LT. 0.) THEN + ESI=1000.*FPVS(TK) ! Saturation vapor pressure w/r/t ice + QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water + WS=QSI ! General saturation mixing ratio (water/ice) + ENDIF +! +!--- Effective grid-scale Saturation mixing ratios +! + QSWgrd=RHgrd*QSW + QSIgrd=RHgrd*QSI + WSgrd=RHgrd*WS +! +!--- Check if air is subsaturated and w/o condensate +! + IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. +! +!--- Check if any rain is falling into layer from above +! + IF (ARAIN .GT. CLIMIT) THEN + CLEAR=.FALSE. + ELSE + ARAIN=0. + ENDIF +! +!--- Check if any ice is falling into layer from above +! +!--- NOTE that "SNOW" in variable names is synonomous with +! large, precipitation ice particles +! + IF (ASNOW .GT. CLIMIT) THEN + CLEAR=.FALSE. + ELSE + ASNOW=0. + ENDIF +! +!----------------------------------------------------------------------- +!-- Loop to the end if in clear, subsaturated air free of condensate --- +!----------------------------------------------------------------------- +! + IF (CLEAR) GO TO 10 +! +!----------------------------------------------------------------------- +!--------- Initialize RHO, THICK & microphysical processes ------------- +!----------------------------------------------------------------------- +! +! +!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; +! (see pp. 63-65 in Fleagle & Businger, 1963) +! + RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) + RRHO=1./RHO ! Reciprocal of air density + DTRHO=DTPH*RHO ! Time step * air density + BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density + THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) +! + ARAINnew=0. ! Updated accumulated rainfall + ASNOWnew=0. ! Updated accumulated snowfall + QI=QI_col(L) ! Ice mixing ratio + QInew=0. ! Updated ice mixing ratio + QR=QR_col(L) ! Rain mixing ratio + QRnew=0. ! Updated rain ratio + QW=QW_col(L) ! Cloud water mixing ratio + QWnew=0. ! Updated cloud water ratio +! + PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) + PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) + PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; >0) + PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) + PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) + PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; >0) + PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) + PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) + PIMLT=0. ! Melting ice (kg/kg; >0) + PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) + PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) + PREVP=0. ! Rain evaporation (kg/kg; <0) +! +!--- Double check input hydrometeor mixing ratios +! +! DUM=WC-(QI+QW+QR) +! DUM1=ABS(DUM) +! DUM2=TOLER*MIN(WC, QI+QW+QR) +! IF (DUM1 .GT. DUM2) THEN +! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, +! & ' L=',L +! WRITE(6,"(4(a12,g11.4,1x))") +! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, +! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR +! ENDIF +! +!*********************************************************************** +!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** +!*********************************************************************** +! +!--- Calculate a few variables, which are used more than once below +! +!--- Latent heat of vaporization as a function of temperature from +! Bolton (1980, JAS) +! + XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) + XLF=XLS-XLV ! Latent heat of fusion (Lf) + XLV1=XLV*RCP ! Lv/Cp + XLF1=XLF*RCP ! Lf/Cp + TK2=1./(TK*TK) ! 1./TK**2 + XLV2=XLV*XLV*QSW*TK2/RV ! Lv**2*Qsw/(Rv*TK**2) + DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction +! +!--- Basic thermodynamic quantities +! * DYNVIS - dynamic viscosity [ kg/(m*s) ] +! * THERM_COND - thermal conductivity [ J/(m*s*K) ] +! * DIFFUS - diffusivity of water vapor [ m**2/s ] +! + TFACTOR=TK**1.5/(TK+120.) + DYNVIS=1.496E-6*TFACTOR + THERM_COND=2.116E-3*TFACTOR + DIFFUS=8.794E-5*TK**1.81/PP +! +!--- Air resistance term for the fall speed of ice following the +! basic research by Heymsfield, Kajikawa, others +! + GAMMAS=(1.E5/PP)**C1 +! +!--- Air resistance for rain fall speed (Beard, 1985, JAS, p.470) +! + GAMMAR=(RHO0/RHO)**.4 +! +!---------------------------------------------------------------------- +!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- +!---------------------------------------------------------------------- +! +!--- Determine if conditions supporting ice are present +! + IF (TC.LT.0. .OR. QI.GT. EPSQ .OR. ASNOW.GT.CLIMIT) THEN + ICE_logical=.TRUE. + ELSE + ICE_logical=.FALSE. + QLICE=0. + QTICE=0. + ENDIF +! +!--- Determine if rain is present +! + RAIN_logical=.FALSE. + IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. +! + IF (ICE_logical) THEN +! +!--- IMPORTANT: Estimate time-averaged properties. +! +!--- +! * FLARGE - ratio of number of large ice to total (large & small) ice +! * FSMALL - ratio of number of small ice crystals to large ice particles +! -> Small ice particles are assumed to have a mean diameter of 50 microns. +! * XSIMASS - used for calculating small ice mixing ratio +!--- +! * TOT_ICE - total mass (small & large) ice before microphysics, +! which is the sum of the total mass of large ice in the +! current layer and the input flux of ice from above +! * PILOSS - greatest loss (<0) of total (small & large) ice by +! sublimation, removing all of the ice falling from above +! and the ice within the layer +! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) +! ice mass to the unrimed ice mass (>=1) +! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) +! * VSNOW - Fall speed of rimed snow w/ air resistance correction +! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer +! * XLIMASS - used for calculating large ice mixing ratio +! * FLIMASS - mass fraction of large ice +! * QTICE - time-averaged mixing ratio of total ice +! * QLICE - time-averaged mixing ratio of large ice +! * NLICE - time-averaged number concentration of large ice +! * NSmICE - number concentration of small ice crystals at current level +!--- +!--- Assumed number fraction of large ice particles to total (large & small) +! ice particles, which is based on a general impression of the literature. +! + WVQW=WV+QW ! Water vapor & cloud water +! + + + IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) THEN + ! + !--- Eliminate small ice particle contributions for melting & sublimation + ! + FLARGE=FLARGE1 + ELSE + ! + !--- Enhanced number of small ice particles during depositional growth + ! (effective only when 0C > T >= T_ice [-10C] ) + ! + FLARGE=FLARGE2 + ! + !--- Larger number of small ice particles due to rime splintering + ! + IF (TC.GE.-8. .AND. TC.LE.-3.) FLARGE=.5*FLARGE +! + ENDIF ! End IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) + FSMALL=(1.-FLARGE)/FLARGE + XSIMASS=RRHO*MASSI(MDImin)*FSMALL + IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) THEN + INDEXS=MDImin + TOT_ICE=0. + PILOSS=0. + RimeF1=1. + VrimeF=1. + VEL_INC=GAMMAS + VSNOW=0. + EMAIRI=THICK + XLIMASS=RRHO*RimeF1*MASSI(INDEXS) + FLIMASS=XLIMASS/(XLIMASS+XSIMASS) + QLICE=0. + QTICE=0. + NLICE=0. + NSmICE=0. + ELSE + ! + !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), + ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships + ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). + ! + DUM=XMImax*EXP(.0536*TC) + INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) + TOT_ICE=THICK*QI+BLEND*ASNOW + PILOSS=-TOT_ICE/THICK + LBEF=MAX(1,L-1) + DUM1=RimeF_col(LBEF) + DUM2=RimeF_col(L) + RimeF1=(DUM2*THICK*QI+DUM1*BLEND*ASNOW)/TOT_ICE + RimeF1=MIN(RimeF1, RFmax) + DO IPASS=0,1 + IF (RimeF1 .LE. 1.) THEN + RimeF1=1. + VrimeF=1. + ELSE + IXS=MAX(2, MIN(INDEXS/100, 9)) + XRF=10.492*ALOG(RimeF1) + IXRF=MAX(0, MIN(INT(XRF), Nrime)) + IF (IXRF .GE. Nrime) THEN + VrimeF=VEL_RF(IXS,Nrime) + ELSE + VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & + & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) + ENDIF + ENDIF ! End IF (RimeF1 .LE. 1.) + VEL_INC=GAMMAS*VrimeF + VSNOW=VEL_INC*VSNOWI(INDEXS) + EMAIRI=THICK+BLDTRH*VSNOW + XLIMASS=RRHO*RimeF1*MASSI(INDEXS) + FLIMASS=XLIMASS/(XLIMASS+XSIMASS) + QTICE=TOT_ICE/EMAIRI + QLICE=FLIMASS*QTICE + NLICE=QLICE/XLIMASS + NSmICE=Fsmall*NLICE + ! + IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) & + & .OR. IPASS.EQ.1) THEN + EXIT + ELSE + ! + !--- Reduce excessive accumulation of ice at upper levels + ! associated with strong grid-resolved ascent + ! + !--- Force NLICE to be between NLImin and NLImax + ! + DUM=MAX(NLImin, MIN(NLImax, NLICE) ) + XLI=RHO*(QTICE/DUM-XSIMASS)/RimeF1 + IF (XLI .LE. MASSI(MDImin) ) THEN + INDEXS=MDImin + ELSE IF (XLI .LE. MASSI(450) ) THEN + DLI=9.5885E5*XLI**.42066 ! DLI in microns + INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) + ELSE IF (XLI .LE. MASSI(MDImax) ) THEN + DLI=3.9751E6*XLI**.49870 ! DLI in microns + INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) + ELSE + INDEXS=MDImax + ! + !--- 8/22/01: Increase density of large ice if maximum limits + ! are reached for number concentration (NLImax) and mean size + ! (MDImax). Done to increase fall out of ice. + ! + IF (DUM .GE. NLImax) & + & RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) + ENDIF ! End IF (XLI .LE. MASSI(MDImin) ) +! WRITE(6,"(4(a12,g11.4,1x))") +! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, +! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, +! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 + ENDIF ! End IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) ... + ENDDO ! End DO IPASS=0,1 + ENDIF ! End IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) + ENDIF ! End IF (ICE_logical) +! +!---------------------------------------------------------------------- +!--------------- Calculate individual processes ----------------------- +!---------------------------------------------------------------------- +! +!--- Cloud water autoconversion to rain and collection by rain +! + IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN + ! + !--- QW0 could be modified based on land/sea properties, + ! presence of convection, etc. This is why QAUT0 and CRAUT + ! are passed into the subroutine as externally determined + ! parameters. Can be changed in the future if desired. + ! + QW0=QAUT0*RRHO + PRAUT=MAX(0., QW-QW0)*CRAUT + IF (QLICE .GT. EPSQ) THEN + ! + !--- Collection of cloud water by large ice particles ("snow") + ! PIACWI=PIACW for riming, PIACWI=0 for shedding + ! + FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) + PIACW=FWS*QW + IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming + ENDIF ! End IF (QLICE .GT. EPSQ) + ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) +! +!---------------------------------------------------------------------- +!--- Loop around some of the ice-phase processes if no ice should be present +!---------------------------------------------------------------------- +! + IF (ICE_logical .EQV. .FALSE.) GO TO 20 +! +!--- Now the pretzel logic of calculating ice deposition +! + IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ)) THEN + ! + !--- Adjust to ice saturation at T0) and evaporation + ! + DUM=PIEVP-PIMLT + IF (DUM .LT. PILOSS) THEN + DUM1=PILOSS/DUM + PIMLT=PIMLT*DUM1 + PIEVP=PIEVP*DUM1 + ENDIF ! End IF (DUM .GT. QTICE) + ENDIF ! End IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) +! +!--- IMPORTANT: Estimate time-averaged properties. +! +! * TOT_RAIN - total mass of rain before microphysics, which is the sum of +! the total mass of rain in the current layer and the input +! flux of rain from above +! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) +! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) +! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from +! above and the rain within the layer +! * RQR - rain content (kg/m**3) +! * INDEXR - mean size of rain drops to the nearest 1 micron in size +! * N0r - intercept of rain size distribution (typically 10**6 m**-4) +! + TOT_RAIN=0. + VRAIN1=0. + QTRAIN=0. + PRLOSS=0. + RQR=0. + N0r=0. + INDEXR1=0 + INDEXR=MDRmin + IF (RAIN_logical) THEN + IF (ARAIN .LE. 0.) THEN + INDEXR=MDRmin + VRAIN1=0. + ELSE + ! + !--- INDEXR (related to mean diameter) & N0r could be modified + ! by land/sea properties, presence of convection, etc. + ! + !--- Rain rate normalized to a density of 1.194 kg/m**3 + ! + RR=ARAIN/(DTPH*GAMMAR) + ! + IF (RR .LE. RR_DRmin) THEN + ! + !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, + ! instead vary N0r with rain rate + ! + INDEXR=MDRmin + ELSE IF (RR .LE. RR_DR1) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.05 and 0.10 mm: + ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 + ! + INDEXR=INT( 1.123E3*RR**.1947 + .5 ) + INDEXR=MAX( MDRmin, MIN(INDEXR, MDR1) ) + ELSE IF (RR .LE. RR_DR2) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.10 and 0.20 mm: + ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 + ! + INDEXR=INT( 1.225E3*RR**.2017 + .5 ) + INDEXR=MAX( MDR1, MIN(INDEXR, MDR2) ) + ELSE IF (RR .LE. RR_DR3) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.20 and 0.32 mm: + ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 + ! + INDEXR=INT( 1.3006E3*RR**.2083 + .5 ) + INDEXR=MAX( MDR2, MIN(INDEXR, MDR3) ) + ELSE IF (RR .LE. RR_DRmax) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.32 and 0.45 mm: + ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 + ! + INDEXR=INT( 1.355E3*RR**.2144 + .5 ) + INDEXR=MAX( MDR3, MIN(INDEXR, MDRmax) ) + ELSE + ! + !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, + ! instead vary N0r with rain rate + ! + INDEXR=MDRmax + ENDIF ! End IF (RR .LE. RR_DRmin) etc. + VRAIN1=GAMMAR*VRAIN(INDEXR) + ENDIF ! End IF (ARAIN .LE. 0.) + INDEXR1=INDEXR ! For debugging only + TOT_RAIN=THICK*QR+BLEND*ARAIN + QTRAIN=TOT_RAIN/(THICK+BLDTRH*VRAIN1) + PRLOSS=-TOT_RAIN/THICK + RQR=RHO*QTRAIN + ! + !--- RQR - time-averaged rain content (kg/m**3) + ! + IF (RQR .LE. RQR_DRmin) THEN + N0r=MAX(N0rmin, CN0r_DMRmin*RQR) + INDEXR=MDRmin + ELSE IF (RQR .GE. RQR_DRmax) THEN + N0r=CN0r_DMRmax*RQR + INDEXR=MDRmax + ELSE + N0r=N0r0 + INDEXR=MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) + ENDIF + ! + IF (TC .LT. T_ICE) THEN + PIACR=-PRLOSS + ELSE + DWVr=WV-PCOND-QSW + DUM=QW+PCOND + IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) THEN + ! + !--- Rain evaporation + ! + ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], + ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) + ! + ! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; + ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; + ! CREVP - unitless + ! + RFACTOR=GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 + ABW=1./(RHO*XLV2/THERM_COND+1./DIFFUS) + ! + !--- Note that VENTR1, VENTR2 lookup tables do not include the + ! 1/Davg multiplier as in the ice tables + ! + VENTR=N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) + CREVP=ABW*VENTR*DTPH + IF (CREVP .LT. Xratio) THEN + DUM=DWVr*CREVP + ELSE + DUM=DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW + ENDIF + PREVP=MAX(DUM, PRLOSS) + ELSE IF (QW .GT. EPSQ) THEN + FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) + PRACW=MIN(1.,FWR)*QW + ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) + ! + IF (TC.LT.0. .AND. TCC.LT.0.) THEN + ! + !--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) + ! - Rescaled mean drop diameter from microns (INDEXR) to mm (DUM) to prevent underflow + ! + DUM=.001*FLOAT(INDEXR) + DUM=(EXP(ABFR*TC)-1.)*DUM*DUM*DUM*DUM*DUM*DUM*DUM + PIACR=MIN(CBFR*N0r*RRHO*DUM, QTRAIN) + IF (QLICE .GT. EPSQ) THEN + ! + !--- Freezing of rain by collisions w/ large ice + ! + DUM=GAMMAR*VRAIN(INDEXR) + DUM1=DUM-VSNOW + ! + !--- DUM2 - Difference in spectral fall speeds of rain and + ! large ice, parameterized following eq. (48) on p. 112 of + ! Murakami (J. Meteor. Soc. Japan, 1990) + ! + DUM2=(DUM1*DUM1+.04*DUM*VSNOW)**.5 + DUM1=5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS & + & +.5E-12*INDEXS*INDEXS + FIR=MIN(1., CIACR*NLICE*DUM1*DUM2) + ! + !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? + ! + PIACR=MIN(PIACR+FIR*QTRAIN, QTRAIN) + ENDIF ! End IF (QLICE .GT. EPSQ) + DUM=PREVP-PIACR + If (DUM .LT. PRLOSS) THEN + DUM1=PRLOSS/DUM + PREVP=DUM1*PREVP + PIACR=DUM1*PIACR + ENDIF ! End If (DUM .LT. PRLOSS) + ENDIF ! End IF (TC.LT.0. .AND. TCC.LT.0.) + ENDIF ! End IF (TC .LT. T_ICE) + ENDIF ! End IF (RAIN_logical) +! +!---------------------------------------------------------------------- +!---------------------- Main Budget Equations ------------------------- +!---------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------- +!--- Update fields, determine characteristics for next lower layer ---- +!----------------------------------------------------------------------- +! +!--- Carefully limit sinks of cloud water +! + DUM1=PIACW+PRAUT+PRACW-MIN(0.,PCOND) + IF (DUM1 .GT. QW) THEN + DUM=QW/DUM1 + PIACW=DUM*PIACW + PIACWI=DUM*PIACWI + PRAUT=DUM*PRAUT + PRACW=DUM*PRACW + IF (PCOND .LT. 0.) PCOND=DUM*PCOND + ENDIF + PIACWR=PIACW-PIACWI ! TC >= 0C +! +!--- QWnew - updated cloud water mixing ratio +! + DELW=PCOND-PIACW-PRAUT-PRACW + QWnew=QW+DELW + IF (QWnew .LE. EPSQ) QWnew=0. + IF (QW.GT.0. .AND. QWnew.NE.0.) THEN + DUM=QWnew/QW + IF (DUM .LT. TOLER) QWnew=0. + ENDIF +! +!--- Update temperature and water vapor mixing ratios +! + DELT= XLV1*(PCOND+PIEVP+PICND+PREVP) & + & +XLS1*PIDEP+XLF1*(PIACWI+PIACR-PIMLT) + Tnew=TK+DELT +! + DELV=-PCOND-PIDEP-PIEVP-PICND-PREVP + WVnew=WV+DELV +! +!--- Update ice mixing ratios +! +!--- +! * TOT_ICEnew - total mass (small & large) ice after microphysics, +! which is the sum of the total mass of large ice in the +! current layer and the flux of ice out of the grid box below +! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & +! rimed) ice mass to the unrimed ice mass (>=1) +! * QInew - updated mixing ratio of total (large & small) ice in layer +! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW +! -> But QLICEnew=QInew*FLIMASS, so +! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) +! * ASNOWnew - updated accumulation of snow at bottom of grid cell +!--- +! + DELI=0. + RimeF=1. + IF (ICE_logical) THEN + DELI=PIDEP+PIEVP+PIACWI+PIACR-PIMLT + TOT_ICEnew=TOT_ICE+THICK*DELI + IF (TOT_ICE.GT.0. .AND. TOT_ICEnew.NE.0.) THEN + DUM=TOT_ICEnew/TOT_ICE + IF (DUM .LT. TOLER) TOT_ICEnew=0. + ENDIF + IF (TOT_ICEnew .LE. CLIMIT) THEN + TOT_ICEnew=0. + RimeF=1. + QInew=0. + ASNOWnew=0. + ELSE + ! + !--- Update rime factor if appropriate + ! + DUM=PIACWI+PIACR + IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) THEN + RimeF=RimeF1 + ELSE + ! + !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) + ! DUM1 - Total ice mass, rimed & unrimed + ! DUM2 - Estimated mass of *unrimed* ice + ! + DUM1=TOT_ICE+THICK*(PIDEP+DUM) + DUM2=TOT_ICE/RimeF1+THICK*PIDEP + IF (DUM2 .LE. 0.) THEN + RimeF=RFmax + ELSE + RimeF=MIN(RFmax, MAX(1., DUM1/DUM2) ) + ENDIF + ENDIF ! End IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) + QInew=TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) + IF (QInew .LE. EPSQ) QInew=0. + IF (QI.GT.0. .AND. QInew.NE.0.) THEN + DUM=QInew/QI + IF (DUM .LT. TOLER) QInew=0. + ENDIF + ASNOWnew=BLDTRH*FLIMASS*VSNOW*QInew + IF (ASNOW.GT.0. .AND. ASNOWnew.NE.0.) THEN + DUM=ASNOWnew/ASNOW + IF (DUM .LT. TOLER) ASNOWnew=0. + ENDIF + ENDIF ! End IF (TOT_ICEnew .LE. CLIMIT) + ENDIF ! End IF (ICE_logical) + + +! +!--- Update rain mixing ratios +! +!--- +! * TOT_RAINnew - total mass of rain after microphysics +! current layer and the input flux of ice from above +! * VRAIN2 - time-averaged fall speed of rain in grid and below +! (with air resistance correction) +! * QRnew - updated rain mixing ratio in layer +! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) +! * ARAINnew - updated accumulation of rain at bottom of grid cell +!--- +! + DELR=PRAUT+PRACW+PIACWR-PIACR+PIMLT+PREVP+PICND + TOT_RAINnew=TOT_RAIN+THICK*DELR + IF (TOT_RAIN.GT.0. .AND. TOT_RAINnew.NE.0.) THEN + DUM=TOT_RAINnew/TOT_RAIN + IF (DUM .LT. TOLER) TOT_RAINnew=0. + ENDIF + IF (TOT_RAINnew .LE. CLIMIT) THEN + TOT_RAINnew=0. + VRAIN2=0. + QRnew=0. + ARAINnew=0. + ELSE + ! + !--- 1st guess time-averaged rain rate at bottom of grid box + ! + RR=TOT_RAINnew/(DTPH*GAMMAR) + ! + !--- Use same algorithm as above for calculating mean drop diameter + ! (IDR, in microns), which is used to estimate the time-averaged + ! fall speed of rain drops at the bottom of the grid layer. This + ! isn't perfect, but the alternative is solving a transcendental + ! equation that is numerically inefficient and nasty to program + ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). + ! + IF (RR .LE. RR_DRmin) THEN + IDR=MDRmin + ELSE IF (RR .LE. RR_DR1) THEN + IDR=INT( 1.123E3*RR**.1947 + .5 ) + IDR=MAX( MDRmin, MIN(IDR, MDR1) ) + ELSE IF (RR .LE. RR_DR2) THEN + IDR=INT( 1.225E3*RR**.2017 + .5 ) + IDR=MAX( MDR1, MIN(IDR, MDR2) ) + ELSE IF (RR .LE. RR_DR3) THEN + IDR=INT( 1.3006E3*RR**.2083 + .5 ) + IDR=MAX( MDR2, MIN(IDR, MDR3) ) + ELSE IF (RR .LE. RR_DRmax) THEN + IDR=INT( 1.355E3*RR**.2144 + .5 ) + IDR=MAX( MDR3, MIN(IDR, MDRmax) ) + ELSE + IDR=MDRmax + ENDIF ! End IF (RR .LE. RR_DRmin) + VRAIN2=GAMMAR*VRAIN(IDR) + QRnew=TOT_RAINnew/(THICK+BLDTRH*VRAIN2) + IF (QRnew .LE. EPSQ) QRnew=0. + IF (QR.GT.0. .AND. QRnew.NE.0.) THEN + DUM=QRnew/QR + IF (DUM .LT. TOLER) QRnew=0. + ENDIF + ARAINnew=BLDTRH*VRAIN2*QRnew + IF (ARAIN.GT.0. .AND. ARAINnew.NE.0.) THEN + DUM=ARAINnew/ARAIN + IF (DUM .LT. TOLER) ARAINnew=0. + ENDIF + ENDIF +! + WCnew=QWnew+QRnew+QInew +! +!---------------------------------------------------------------------- +!-------------- Begin debugging & verification ------------------------ +!---------------------------------------------------------------------- +! +!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. +! + + + QT=THICK*(WV+WC)+ARAIN+ASNOW + QTnew=THICK*(WVnew+WCnew)+ARAINnew+ASNOWnew + BUDGET=QT-QTnew +! +!--- Additional check on budget preservation, accounting for truncation effects +! + DBG_logical=.FALSE. +! DUM=ABS(BUDGET) +! IF (DUM .GT. TOLER) THEN +! DUM=DUM/MIN(QT, QTnew) +! IF (DUM .GT. TOLER) DBG_logical=.TRUE. +! ENDIF +!! +! DUM=(RHgrd+.001)*QSInew +! IF ( (QWnew.GT.EPSQ) .OR. QRnew.GT.EPSQ .OR. WVnew.GT.DUM) +! & .AND. TC.LT.T_ICE ) DBG_logical=.TRUE. +! +! IF (TC.GT.5. .AND. QInew.GT.EPSQ) DBG_logical=.TRUE. +! + IF ((WVnew.LT.EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN + ! + WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=',J_index,& + & ' L=',L,' LSFC=',LSFC + ! + ESW=1000.*FPVS0(Tnew) + QSWnew=EPS*ESW/(PP-ESW) + IF (TC.LT.0. .OR. Tnew .LT. 0.) THEN + ESI=1000.*FPVS(Tnew) + QSInew=EPS*ESI/(PP-ESI) + ELSE + QSI=QSW + QSInew=QSWnew + ENDIF + WSnew=QSInew + WRITE(6,"(4(a12,g11.4,1x))") & + & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, & + & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, & + & 'RHgrd=',RHgrd, & + & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, & + & 'RHInew=',WVnew/QSInew, & + & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew, & + & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, & + & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, & + & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, & + & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, & + & 'ASNOWnew=',ASNOWnew, & + & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, & + & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, & + & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew + ! + WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, & + & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, & + & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, & + & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', & + & PIMLT, & + & '{} PIACR=',PIACR + ! + IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, & + & 'VSNOW=',VSNOW, & + & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, & + & 'FLIMASS=',FLIMASS, & + & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, & + & 'QTICE=',QTICE, & + & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, & + & 'EMAIRI=',EMAIRI, & + & '{} RimeF=',RimeF + ! + IF (TOT_RAIN.GT.0. .OR. TOT_RAINnew.GT.0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), & + & 'GAMMAR=',GAMMAR,'N0r=',N0r, & + & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR, & + & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, & + & 'VOLR2=',THICK+BLDTRH*VRAIN2 + ! + IF (PRAUT .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 + ! + IF (PRACW .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR + ! + IF (PIACR .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR + ! + DUM=PIMLT+PICND-PREVP-PIEVP + IF (DUM.GT.0. .or. DWVi.NE.0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, & + & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS + ! + IF (PREVP .LT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, & + & '{} DWVr=',DWVr,'DENOMW=',DENOMW + ! + IF (PIDEP.NE.0. .AND. DWVi.NE.0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, & + & 'SFACTOR=',SFACTOR, & + & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & + & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & + & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP + ! + IF (PIDEP.GT.0. .AND. PCOND.NE.0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, & + & 'DUM2=',PCOND-PIACW + ! + IF (FWS .GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} FWS=',FWS + ! + DUM=PIMLT+PICND-PIEVP + IF (DUM.GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & + & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & + & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 + ! + ENDIF + + +! +!----------------------------------------------------------------------- +!--------------- Water budget statistics & maximum values -------------- +!----------------------------------------------------------------------- +! + IF (PRINT_diag) THEN + ITdx=MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) + IF (QInew .GT. EPSQ) NSTATS(ITdx,1)=NSTATS(ITdx,1)+1 + IF (QInew.GT.EPSQ .AND. QRnew+QWnew.GT.EPSQ) & + & NSTATS(ITdx,2)=NSTATS(ITdx,2)+1 + IF (QWnew .GT. EPSQ) NSTATS(ITdx,3)=NSTATS(ITdx,3)+1 + IF (QRnew .GT. EPSQ) NSTATS(ITdx,4)=NSTATS(ITdx,4)+1 + ! + QMAX(ITdx,1)=MAX(QMAX(ITdx,1), QInew) + QMAX(ITdx,2)=MAX(QMAX(ITdx,2), QWnew) + QMAX(ITdx,3)=MAX(QMAX(ITdx,3), QRnew) + QMAX(ITdx,4)=MAX(QMAX(ITdx,4), ASNOWnew) + QMAX(ITdx,5)=MAX(QMAX(ITdx,5), ARAINnew) + QTOT(ITdx,1)=QTOT(ITdx,1)+QInew*THICK + QTOT(ITdx,2)=QTOT(ITdx,2)+QWnew*THICK + QTOT(ITdx,3)=QTOT(ITdx,3)+QRnew*THICK + ! + QTOT(ITdx,4)=QTOT(ITdx,4)+PCOND*THICK + QTOT(ITdx,5)=QTOT(ITdx,5)+PICND*THICK + QTOT(ITdx,6)=QTOT(ITdx,6)+PIEVP*THICK + QTOT(ITdx,7)=QTOT(ITdx,7)+PIDEP*THICK + QTOT(ITdx,8)=QTOT(ITdx,8)+PREVP*THICK + QTOT(ITdx,9)=QTOT(ITdx,9)+PRAUT*THICK + QTOT(ITdx,10)=QTOT(ITdx,10)+PRACW*THICK + QTOT(ITdx,11)=QTOT(ITdx,11)+PIMLT*THICK + QTOT(ITdx,12)=QTOT(ITdx,12)+PIACW*THICK + QTOT(ITdx,13)=QTOT(ITdx,13)+PIACWI*THICK + QTOT(ITdx,14)=QTOT(ITdx,14)+PIACWR*THICK + QTOT(ITdx,15)=QTOT(ITdx,15)+PIACR*THICK + ! + QTOT(ITdx,16)=QTOT(ITdx,16)+(WVnew-WV)*THICK + QTOT(ITdx,17)=QTOT(ITdx,17)+(QWnew-QW)*THICK + QTOT(ITdx,18)=QTOT(ITdx,18)+(QInew-QI)*THICK + QTOT(ITdx,19)=QTOT(ITdx,19)+(QRnew-QR)*THICK + QTOT(ITdx,20)=QTOT(ITdx,20)+(ARAINnew-ARAIN) + QTOT(ITdx,21)=QTOT(ITdx,21)+(ASNOWnew-ASNOW) + IF (QInew .GT. 0.) & + & QTOT(ITdx,22)=QTOT(ITdx,22)+QInew*THICK/RimeF + ! + ENDIF +! +!---------------------------------------------------------------------- +!------------------------- Update arrays ------------------------------ +!---------------------------------------------------------------------- +! + + + T_col(L)=Tnew ! Updated temperature +! + QV_col(L)=max(EPSQ, WVnew/(1.+WVnew)) ! Updated specific humidity + WC_col(L)=max(EPSQ, WCnew) ! Updated total condensate mixing ratio + QI_col(L)=max(EPSQ, QInew) ! Updated ice mixing ratio + QR_col(L)=max(EPSQ, QRnew) ! Updated rain mixing ratio + QW_col(L)=max(EPSQ, QWnew) ! Updated cloud water mixing ratio + RimeF_col(L)=RimeF ! Updated rime factor + ASNOW=ASNOWnew ! Updated accumulated snow + ARAIN=ARAINnew ! Updated accumulated rain +! +!####################################################################### +! +10 CONTINUE ! ##### End "L" loop through model levels ##### + + +! +!####################################################################### +! +!----------------------------------------------------------------------- +!--------------------------- Return to GSMDRIVE ----------------------- +!----------------------------------------------------------------------- +! + CONTAINS +!####################################################################### +!--------- Produces accurate calculation of cloud condensation --------- +!####################################################################### +! + REAL FUNCTION CONDENSE (PP, QW, TK, WV) +! +!--------------------------------------------------------------------------------- +!------ The Asai (1965) algorithm takes into consideration the release of ------ +!------ latent heat in increasing the temperature & in increasing the ------ +!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ +!--------------------------------------------------------------------------------- +! + IMPLICIT NONE +! + INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) + REAL (KIND=HIGH_PRES), PARAMETER :: & + & RHLIMIT=.001, RHLIMIT1=-RHLIMIT + REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum +! + REAL,INTENT(IN) :: QW,PP,WV,TK + REAL WVdum,Tdum,XLV2,DWV,WS,ESW,XLV1,XLV +integer nsteps +! +!----------------------------------------------------------------------- +! +!--- LV (T) is from Bolton (JAS, 1980) +! + XLV=3.148E6-2370.*TK + XLV1=XLV*RCP + XLV2=XLV*XLV*RCPRV + Tdum=TK + WVdum=WV + WCdum=QW + ESW=1000.*FPVS0(Tdum) ! Saturation vapor press w/r/t water + WS=RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water + DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio + SSAT=DWV/WS ! Supersaturation ratio + CONDENSE=0. +nsteps = 0 + DO WHILE ((SSAT.LT.RHLIMIT1 .AND. WCdum.GT.EPSQ) & + & .OR. SSAT.GT.RHLIMIT) + nsteps = nsteps + 1 + COND=DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) + COND=MAX(COND, -WCdum) ! Limit cloud water evaporation + Tdum=Tdum+XLV1*COND ! Updated temperature + WVdum=WVdum-COND ! Updated water vapor mixing ratio + WCdum=WCdum+COND ! Updated cloud water mixing ratio + CONDENSE=CONDENSE+COND ! Total cloud water condensation + ESW=1000.*FPVS0(Tdum) ! Updated saturation vapor press w/r/t water + WS=RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water + DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio + SSAT=DWV/WS ! Grid-scale supersaturation ratio + ENDDO +! + END FUNCTION CONDENSE +! +!####################################################################### +!---------------- Calculate ice deposition at T 0 ) + + time_sediment = time_sediment - dtfall + DO k = 1, kte-1 + factor(k) = dtfall*rdzk(k)/rhok(k) + ENDDO + factor(kte) = dtfall*rdzk(kte) + + ppt=0. + + k = 1 + ppt=rhok(k)*prodk(k)*vt(k)*dtfall/rhowater + RAINNCV(i,j)=ppt*1000. + RAINNC(i,j)=RAINNC(i,j)+ppt*1000. ! unit = mm + +!------------------------------------------------------------------------------ +! Time split loop, Fallout done with flux upstream +!------------------------------------------------------------------------------ + + DO k = kts, kte-1 + prodk(k) = prodk(k) - factor(k) & + * (rhok(k)*prodk(k)*vt(k) & + -rhok(k+1)*prodk(k+1)*vt(k+1)) + ENDDO + + k = kte + prodk(k) = prodk(k) - factor(k)*prodk(k)*vt(k) + +!------------------------------------------------------------------------------ +! compute new sedimentation velocity, and check/recompute new +! sedimentation timestep if this isn't the last split step. +!------------------------------------------------------------------------------ + + IF( nfall > 1 ) THEN ! this wasn't the last split sedimentation timestep + + nfall = nfall - 1 + crmax = 0. + DO k = kts, kte + qrr = amax1(0.,prodk(k)*0.001*rhok(k)) + vt(k) = 36.34*(qrr**0.1364) * vtden(k) +! vtmax = amax1(vt(k), vtmax) + crmax = amax1(vt(k)*time_sediment*rdzw(k),crmax) + ENDDO + + nfall_new = max(1,nint(0.5+crmax/max_cr_sedimentation)) + if (nfall_new /= nfall ) then + nfall = nfall_new + dtfall = time_sediment/nfall + end if + + ELSE ! this was the last timestep + + DO k=kts,kte + prod(i,k,j) = prodk(k) + ENDDO + nfall = 0 ! exit condition for sedimentation loop + + END IF + + ENDDO column_sedimentation + + ENDDO sedimentation_outer_i_loop + +!------------------------------------------------------------------------------ +! Production of rain and deletion of qc +! Production of qc from supersaturation +! Evaporation of QR +!------------------------------------------------------------------------------ + + DO k = kts, kte + DO i = its, ite + factorn = 1.0 / (1.+c3*dt*amax1(0.,qr(i,k,j))**c4) + qrprod = qc(i,k,j) * (1.0 - factorn) & + + factorn*c1*dt*amax1(qc(i,k,j)-c2,0.) + rcgs = 0.001*rho(i,k,j) + + qc(i,k,j) = amax1(qc(i,k,j) - qrprod,0.) + qr(i,k,j) = (qr(i,k,j) + prod(i,k,j)-qr(i,k,j)) + qr(i,k,j) = amax1(qr(i,k,j) + qrprod,0.) + + temp = pii(i,k,j)*t(i,k,j) + pressure = 1.000e+05 * (pii(i,k,j)**(1004./287.)) + gam = 2.5e+06/(1004.*pii(i,k,j)) +! qvs = 380.*exp(17.27*(temp-273.)/(temp- 36.))/pressure + es = 1000.*svp1*exp(svp2*(temp-svpt0)/(temp-svp3)) + qvs = ep2*es/(pressure-es) +! prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+qvs*f5/(temp-36.)**2) + prod(i,k,j) = (qv(i,k,j)-qvs) / (1.+pressure/(pressure-es)*qvs*f5/(temp-svp3)**2) + ern = amin1(dt*(((1.6+124.9*(rcgs*qr(i,k,j))**.2046) & + *(rcgs*qr(i,k,j))**.525)/(2.55e8/(pressure*qvs) & + +5.4e5))*(dim(qvs,qv(i,k,j))/(rcgs*qvs)), & + amax1(-prod(i,k,j)-qc(i,k,j),0.),qr(i,k,j)) + +! Update all variables + + product = amax1(prod(i,k,j),-qc(i,k,j)) + t (i,k,j) = t(i,k,j) + gam*(product - ern) + qv(i,k,j) = amax1(qv(i,k,j) - product + ern,0.) + qc(i,k,j) = qc(i,k,j) + product + qr(i,k,j) = qr(i,k,j) - ern + + ENDDO + ENDDO + + ENDDO microphysics_outer_j_loop + + RETURN + + END SUBROUTINE kessler + +END MODULE module_mp_kessler diff --git a/wrfv2_fire/phys/module_mp_lin.F b/wrfv2_fire/phys/module_mp_lin.F new file mode 100644 index 00000000..8e80ef2a --- /dev/null +++ b/wrfv2_fire/phys/module_mp_lin.F @@ -0,0 +1,2621 @@ +!WRF:MODEL_LAYER:PHYSICS +! + +MODULE module_mp_lin + + USE module_wrf_error +! + REAL , PARAMETER, PRIVATE :: RH = 1.0 +! REAL , PARAMETER, PRIVATE :: episp0 = 0.622*611.21 + REAL , PARAMETER, PRIVATE :: xnor = 8.0e6 + REAL , PARAMETER, PRIVATE :: xnos = 3.0e6 + +! Lin +! REAL , PARAMETER, PRIVATE :: xnog = 4.0e4 +! REAL , PARAMETER, PRIVATE :: rhograul = 917. + +! Hobbs + REAL , PARAMETER, PRIVATE :: xnog = 4.0e6 + REAL , PARAMETER, PRIVATE :: rhograul = 400. + +! + REAL , PARAMETER, PRIVATE :: & + qi0 = 1.0e-3, ql0 = 7.0e-4, qs0 = 6.0E-4, & + xmi50 = 4.8e-10, xmi40 = 2.46e-10, & + constb = 0.8, constd = 0.25, & + o6 = 1./6., cdrag = 0.6, & + avisc = 1.49628e-6, adiffwv = 8.7602e-5, & + axka = 1.4132e3, di50 = 1.0e-4, xmi = 4.19e-13, & + cw = 4.187e3, vf1s = 0.78, vf2s = 0.31, & + xni0 = 1.0e-2, xmnin = 1.05e-18, bni = 0.5, & + ci = 2.093e3 +CONTAINS + +!------------------------------------------------------------------- +! Lin et al., 1983, JAM, 1065-1092, and +! Rutledge and Hobbs, 1984, JAS, 2949-2972 +!------------------------------------------------------------------- + SUBROUTINE lin_et_al(th & + ,qv, ql, qr & + ,qi, qs & + ,rho, pii, p & + ,dt_in & + ,z,ht, dz8w & + ,grav, cp, Rair, rvapor & + ,XLS, XLV, XLF, rhowater, rhosnow & + ,EP2,SVP1,SVP2,SVP3,SVPT0 & + , RAINNC, RAINNCV & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ! Optional + ,qlsink, precr, preci, precs, precg & + , F_QG,F_QNDROP & + , qg, qndrop & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! Shuhua 12/17/99 +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + qv, & + ql, & + qr + +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + rho, & + pii, & + p, & + dz8w + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: z + + + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht + + REAL, INTENT(IN ) :: dt_in, & + grav, & + Rair, & + rvapor, & + cp, & + XLS, & + XLV, & + XLF, & + rhowater, & + rhosnow + + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINNC, & + RAINNCV + +! Optional + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + qi, & + qs, & + qg, & + qndrop + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, INTENT(OUT ) :: & + qlsink, & ! cloud water conversion to rain (/s) + precr, & ! rain precipitation rate at all levels (kg/m2/s) + preci, & ! ice precipitation rate at all levels (kg/m2/s) + precs, & ! snow precipitation rate at all levels (kg/m2/s) + precg ! graupel precipitation rate at all levels (kg/m2/s) + + LOGICAL, INTENT(IN), OPTIONAL :: F_QG, F_QNDROP + +! LOCAL VAR + + INTEGER :: min_q, max_q + + REAL, DIMENSION( its:ite , jts:jte ) & + :: rain, snow, graupel,ice + + REAL, DIMENSION( kts:kte ) :: qvz, qlz, qrz, & + qiz, qsz, qgz, & + thz, & + tothz, rhoz, & + orhoz, sqrhoz, & + prez, zz, & + precrz, preciz, precsz, precgz, & + qndropz, & + dzw, preclw + + LOGICAL :: flag_qg, flag_qndrop +! + REAL :: dt, pptrain, pptsnow, pptgraul, rhoe_s, & + gindex, pptice + real :: qndropconst + + INTEGER :: i,j,k +! + flag_qg = .false. + flag_qndrop = .false. + IF ( PRESENT ( f_qg ) ) flag_qg = f_qg + IF ( PRESENT ( f_qndrop ) ) flag_qndrop = f_qndrop +! + dt=dt_in + rhoe_s=1.29 + qndropconst=100.e6 !sg + gindex=1.0 + + IF (.not.flag_qg) gindex=0. + + j_loop: DO j = jts, jte + i_loop: DO i = its, ite +! +!- write data from 3-D to 1-D +! + DO k = kts, kte + qvz(k)=qv(i,k,j) + qlz(k)=ql(i,k,j) + qrz(k)=qr(i,k,j) + thz(k)=th(i,k,j) +! + rhoz(k)=rho(i,k,j) + orhoz(k)=1./rhoz(k) + prez(k)=p(i,k,j) + sqrhoz(k)=sqrt(rhoe_s*orhoz(k)) + tothz(k)=pii(i,k,j) + zz(k)=z(i,k,j) + dzw(k)=dz8w(i,k,j) + END DO + + IF (flag_qndrop .AND. PRESENT( qndrop )) THEN + DO k = kts, kte + qndropz(k)=qndrop(i,k,j) + ENDDO + ELSE + DO k = kts, kte + qndropz(k)=qndropconst + ENDDO + ENDIF + + DO k = kts, kte + qiz(k)=qi(i,k,j) + qsz(k)=qs(i,k,j) + ENDDO + + IF ( flag_qg .AND. PRESENT( qg ) ) THEN + DO k = kts, kte + qgz(k)=qg(i,k,j) + ENDDO + ELSE + DO k = kts, kte + qgz(k)=0. + ENDDO + ENDIF +! + pptrain=0. + pptsnow=0. + pptgraul=0. + pptice=0. + CALL clphy1d( dt, qvz, qlz, qrz, qiz, qsz, qgz, & + qndropz,flag_qndrop, & + thz, tothz, rhoz, orhoz, sqrhoz, & + prez, zz, dzw, ht(I,J), preclw, & + precrz, preciz, precsz, precgz, & + pptrain, pptsnow, pptgraul, pptice, & + grav, cp, Rair, rvapor, gindex, & + XLS, XLV, XLF, rhowater, rhosnow, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + kts, kte, i, j ) + +! +! Precipitation from cloud microphysics -- only for one time step +! +! unit is transferred from m to mm + +! + rain(i,j)=pptrain + snow(i,j)=pptsnow + graupel(i,j)=pptgraul + ice(i,j)=pptice +! + RAINNCV(i,j)= pptrain + pptsnow + pptgraul + pptice + RAINNC(i,j)=RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice + +! +!- update data from 1-D back to 3-D +! +! + IF ( present(qlsink) .and. present(precr) ) THEN !sg beg + DO k = kts, kte + if(ql(i,k,j)>1.e-20) then + qlsink(i,k,j)=-preclw(k)/ql(i,k,j) + else + qlsink(i,k,j)=0. + endif + precr(i,k,j)=precrz(k) + END DO + END IF !sg end + + DO k = kts, kte + qv(i,k,j)=qvz(k) + ql(i,k,j)=qlz(k) + qr(i,k,j)=qrz(k) + th(i,k,j)=thz(k) + END DO +! + IF ( flag_qndrop .AND. PRESENT( qndrop ) ) THEN !sg beg + DO k = kts, kte + qndrop(i,k,j)=qndropz(k) + ENDDO + END IF !sg end + + DO k = kts, kte + qi(i,k,j)=qiz(k) + qs(i,k,j)=qsz(k) + ENDDO + + IF ( present(preci) ) THEN !sg beg + DO k = kts, kte + preci(i,k,j)=preciz(k) + ENDDO + END IF + + IF ( present(precs) ) THEN + DO k = kts, kte + precs(i,k,j)=precsz(k) + ENDDO + END IF !sg end + + IF ( flag_qg .AND. PRESENT( qg ) ) THEN + DO k = kts, kte + qg(i,k,j)=qgz(k) + ENDDO + + IF ( present(precg) ) THEN !sg beg + DO k = kts, kte + precg(i,k,j)=precgz(k) + ENDDO !sg end + END IF + ELSE !sg beg + IF ( present(precg) ) precg(i,:,j)=0. !sg end + ENDIF +! + ENDDO i_loop + ENDDO j_loop + + END SUBROUTINE lin_et_al + + +!----------------------------------------------------------------------- + SUBROUTINE clphy1d(dt, qvz, qlz, qrz, qiz, qsz, qgz, & + qndropz,flag_qndrop, & + thz, tothz, rho, orho, sqrho, & + prez, zz, dzw, zsfc, preclw, & + precrz, preciz, precsz, precgz, & + pptrain, pptsnow, pptgraul, & + pptice, grav, cp, Rair, rvapor, gindex, & + XLS, XLV, XLF, rhowater, rhosnow, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + kts, kte, i, j ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! This program handles the vertical 1-D cloud micphysics +!----------------------------------------------------------------------- +! avisc: constant in empirical formular for dynamic viscosity of air +! =1.49628e-6 [kg/m/s] = 1.49628e-5 [g/cm/s] +! adiffwv: constant in empirical formular for diffusivity of water +! vapor in air +! = 8.7602e-5 [kgm/s3] = 8.7602 [gcm/s3] +! axka: constant in empirical formular for thermal conductivity of air +! = 1.4132e3 [m2/s2/K] = 1.4132e7 [cm2/s2/K] +! qi0: mixing ratio threshold for cloud ice aggregation [kg/kg] +! xmi50: mass of a 50 micron ice crystal +! = 4.8e-10 [kg] =4.8e-7 [g] +! xmi40: mass of a 40 micron ice crystal +! = 2.46e-10 [kg] = 2.46e-7 [g] +! di50: diameter of a 50 micro (radius) ice crystal +! =1.0e-4 [m] +! xmi: mass of one cloud ice crystal +! =4.19e-13 [kg] = 4.19e-10 [g] +! oxmi=1.0/xmi +! +! xni0=1.0e-2 [m-3] The value given in Lin et al. is wrong.(see +! Hsie et al.(1980) and Rutledge and Hobbs(1983) ) +! bni=0.5 [K-1] +! xmnin: mass of a natural ice nucleus +! = 1.05e-18 [kg] = 1.05e-15 [g] This values is suggested by +! Hsie et al. (1980) +! = 1.0e-12 [kg] suggested by Rutlegde and Hobbs (1983) +! rhowater: density of water=1.0 g/cm3=1000.0 kg/m3 +! consta: constant in empirical formular for terminal +! velocity of raindrop +! =2115.0 [cm**(1-b)/s] = 2115.0*0.01**(1-b) [m**(1-b)/s] +! constb: constant in empirical formular for terminal +! velocity of raindrop +! =0.8 +! xnor: intercept parameter of the raindrop size distribution +! = 0.08 cm-4 = 8.0e6 m-4 +! araut: time sacle for autoconversion of cloud water to raindrops +! =1.0e-3 [s-1] +! ql0: mixing ratio threshold for cloud watercoalescence [kg/kg] +! vf1r: ventilation factors for rain =0.78 +! vf2r: ventilation factors for rain =0.31 +! rhosnow: density of snow=0.1 g/cm3=100.0 kg/m3 +! constc: constant in empirical formular for terminal +! velocity of snow +! =152.93 [cm**(1-d)/s] = 152.93*0.01**(1-d) [m**(1-d)/s] +! constd: constant in empirical formular for terminal +! velocity of snow +! =0.25 +! xnos: intercept parameter of the snowflake size distribution +! vf1s: ventilation factors for snow =0.78 +! vf2s: ventilation factors for snow =0.31 +! +!---------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: kts, kte, i, j + + REAL, DIMENSION( kts:kte ), & + INTENT(INOUT) :: qvz, qlz, qrz, qiz, qsz, & + qndropz, & + qgz, thz + + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: tothz, rho, orho, sqrho, & + prez, zz, dzw + + REAL, INTENT(IN ) :: dt, grav, cp, Rair, rvapor, & + XLS, XLV, XLF, rhowater, & + rhosnow,EP2,SVP1,SVP2,SVP3,SVPT0 + + REAL, DIMENSION( kts:kte ), INTENT(OUT) :: preclw, & + precrz, preciz, precsz, precgz + + REAL, INTENT(INOUT) :: pptrain, pptsnow, pptgraul, pptice + + REAL, INTENT(IN ) :: zsfc + logical, intent(in) :: flag_qndrop !sg + +! local vars + + REAL :: obp4, bp3, bp5, bp6, odp4, & + dp3, dp5, dp5o2 + + +! temperary vars + + REAL :: tmp, tmp0, tmp1, tmp2,tmp3, & + tmp4,delta2,delta3, delta4, & + tmpa,tmpb,tmpc,tmpd,alpha1, & + qic, abi,abr, abg, odtberg, & + vti50,eiw,eri,esi,esr, esw, & + erw,delrs,term0,term1,araut, & + constg2, vf1r, vf2r,alpha2, & + Ap, Bp, egw, egi, egs, egr, & + constg, gdelta4, g1sdelt4, & + factor, tmp_r, tmp_s,tmp_g, & + qlpqi, rsat, a1, a2, xnin + + INTEGER :: k +! + REAL, DIMENSION( kts:kte ) :: oprez, tem, temcc, theiz, qswz, & + qsiz, qvoqswz, qvoqsiz, qvzodt, & + qlzodt, qizodt, qszodt, qrzodt, & + qgzodt + + REAL, DIMENSION( kts:kte ) :: psnow, psaut, psfw, psfi, praci, & + piacr, psaci, psacw, psdep, pssub, & + pracs, psacr, psmlt, psmltevp, & + prain, praut, pracw, prevp, pvapor, & + pclw, pladj, pcli, pimlt, pihom, & + pidw, piadj, pgraupel, pgaut, & + pgfr, pgacw, pgaci, pgacr, pgacs, & + pgacip,pgacrp,pgacsp,pgwet, pdry, & + pgsub, pgdep, pgmlt, pgmltevp, & + qschg, qgchg +! + + REAL, DIMENSION( kts:kte ) :: qvsbar, rs0, viscmu, visc, diffwv, & + schmidt, xka + + REAL, DIMENSION( kts:kte ) :: vtr, vts, vtg, & + vtrold, vtsold, vtgold, vtiold, & + xlambdar, xlambdas, xlambdag, & + olambdar, olambdas, olambdag + + REAL :: episp0k, dtb, odtb, pi, pio4, & + pio6, oxLf, xLvocp, xLfocp, consta, & + constc, ocdrag, gambp4, gamdp4, & + gam4pt5, Cpor, oxmi, gambp3, gamdp3,& + gambp6, gam3pt5, gam2pt75, gambp5o2,& + gamdp5o2, cwoxlf, ocp, xni50, es +! + REAL :: qvmin=1.e-20 + REAL :: gindex + REAL :: temc1,save1,save2,xni50mx + +! for terminal velocity flux + + INTEGER :: min_q, max_q + REAL :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz + LOGICAL :: notlast +! + +!sg: begin +! liqconc = liquid water content in gcm^-3 +! capn = droplet number concentration cm^-3 +! dis = relative dispersion (dimensionless) between 0.2 and 1. +! Written by Yangang Liu based on Liu et al., GRL 32, 2005. +! Autoconversion rate P = P0*T +! p0 = rate function +! kappa = constant in Long kernel +! beta = Condensation rate constant +! xc = Normalized critical mass +! *********************************************************** + real liqconc, dis, beta, kappa, p0, xc, capn,rhocgs + if(flag_qndrop)then + dis = 0.5 ! droplet dispersion, set to 0.5 per SG 8-Nov-2006 +! Give empirical constants + kappa=1.1d10 +! Calculate Condensation rate constant + beta = (1.0d0+3.0d0*dis**2)*(1.0d0+4.0d0*dis**2)* & + (1.0d0+5.0d0*dis**2)/((1.0d0+dis**2)*(1.0d0+2.0d0*dis**2)) + endif +!sg: end + + dtb=dt + odtb=1./dtb + pi=acos(-1.) + pio4=acos(-1.)/4. + pio6=acos(-1.)/6. + ocp=1./cp + oxLf=1./xLf + xLvocp=xLv/cp + xLfocp=xLf/cp + consta=2115.0*0.01**(1-constb) + constc=152.93*0.01**(1-constd) + ocdrag=1./Cdrag +! episp0k=RH*episp0 + episp0k=RH*ep2*1000.*svp1 +! + gambp4=ggamma(constb+4.) + gamdp4=ggamma(constd+4.) + gam4pt5=ggamma(4.5) + Cpor=cp/Rair + oxmi=1.0/xmi + gambp3=ggamma(constb+3.) + gamdp3=ggamma(constd+3.) + gambp6=ggamma(constb+6) + gam3pt5=ggamma(3.5) + gam2pt75=ggamma(2.75) + gambp5o2=ggamma((constb+5.)/2.) + gamdp5o2=ggamma((constd+5.)/2.) + cwoxlf=cw/xlf + delta2=0. + delta3=0. + delta4=0. +! +!----------------------------------------------------------------------- +! oprez 1./prez ( prez : pressure) +! qsw saturated mixing ratio on water surface +! qsi saturated mixing ratio on ice surface +! episp0k RH*e*saturated pressure at 273.15 K +! qvoqsw qv/qsw +! qvoqsi qv/qsi +! qvzodt qv/dt +! qlzodt ql/dt +! qizodt qi/dt +! qszodt qs/dt +! qrzodt qr/dt +! qgzodt qg/dt +! +! temcc temperature in dregee C +! + + obp4=1.0/(constb+4.0) + bp3=constb+3.0 + bp5=constb+5.0 + bp6=constb+6.0 + odp4=1.0/(constd+4.0) + dp3=constd+3.0 + dp5=constd+5.0 + dp5o2=0.5*(constd+5.0) +! + do k=kts,kte + oprez(k)=1./prez(k) + enddo + + do k=kts,kte + qlz(k)=amax1( 0.0,qlz(k) ) + qiz(k)=amax1( 0.0,qiz(k) ) + qvz(k)=amax1( qvmin,qvz(k) ) + qsz(k)=amax1( 0.0,qsz(k) ) + qrz(k)=amax1( 0.0,qrz(k) ) + qgz(k)=amax1( 0.0,qgz(k) ) + qndropz(k)=amax1( 0.0,qndropz(k) ) !sg +! + tem(k)=thz(k)*tothz(k) + temcc(k)=tem(k)-273.15 +! +! qswz(k)=episp0k*oprez(k)* & +! exp( svp2*temcc(k)/(tem(k)-svp3) ) + es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) + qswz(k)=ep2*es/(prez(k)-es) + if (tem(k) .lt. 273.15 ) then +! qsiz(k)=episp0k*oprez(k)* & +! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + qsiz(k)=ep2*es/(prez(k)-es) + if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) + else + qsiz(k)=qswz(k) + endif +! + qvoqswz(k)=qvz(k)/qswz(k) + qvoqsiz(k)=qvz(k)/qsiz(k) + qvzodt(k)=amax1( 0.0,odtb*qvz(k) ) + qlzodt(k)=amax1( 0.0,odtb*qlz(k) ) + qizodt(k)=amax1( 0.0,odtb*qiz(k) ) + qszodt(k)=amax1( 0.0,odtb*qsz(k) ) + qrzodt(k)=amax1( 0.0,odtb*qrz(k) ) + qgzodt(k)=amax1( 0.0,odtb*qgz(k) ) + + theiz(k)=thz(k)+(xlvocp*qvz(k)-xlfocp*qiz(k))/tothz(k) + enddo + + +! +! +!----------------------------------------------------------------------- +! In this simple stable cloud parameterization scheme, only five +! forms of water substance (water vapor, cloud water, cloud ice, +! rain and snow are considered. The prognostic variables are total +! water (qp),cloud water (ql), and cloud ice (qi). Rain and snow are +! diagnosed following Nagata and Ogura, 1991, MWR, 1309-1337. Eq (A7). +! the micro physics are based on (1) Hsie et al.,1980, JAM, 950-977 ; +! (2) Lin et al., 1983, JAM, 1065-1092 ; (3) Rutledge and Hobbs, 1983, +! JAS, 1185-1206 ; (4) Rutledge and Hobbs, 1984, JAS, 2949-2972. +!----------------------------------------------------------------------- +! +! rhowater: density of water=1.0 g/cm3=1000.0 kg/m3 +! rhosnow: density of snow=0.1 g/cm3=100.0 kg/m3 +! xnor: intercept parameter of the raindrop size distribution +! = 0.08 cm-4 = 8.0e6 m-4 +! xnos: intercept parameter of the snowflake size distribution +! = 0.03 cm-4 = 3.0e6 m-4 +! xnog: intercept parameter of the graupel size distribution +! = 4.0e-4 cm-4 = 4.0e4 m-4 +! consta: constant in empirical formular for terminal +! velocity of raindrop +! =2115.0 [cm**(1-b)/s] = 2115.0*0.01**(1-b) [m**(1-b)/s] +! constb: constant in empirical formular for terminal +! velocity of raindrop +! =0.8 +! constc: constant in empirical formular for terminal +! velocity of snow +! =152.93 [cm**(1-d)/s] = 152.93*0.01**(1-d) [m**(1-d)/s] +! constd: constant in empirical formular for terminal +! velocity of snow +! =0.25 +! avisc: constant in empirical formular for dynamic viscosity of air +! =1.49628e-6 [kg/m/s] = 1.49628e-5 [g/cm/s] +! adiffwv: constant in empirical formular for diffusivity of water +! vapor in air +! = 8.7602e-5 [kgm/s3] = 8.7602 [gcm/s3] +! axka: constant in empirical formular for thermal conductivity of air +! = 1.4132e3 [m2/s2/K] = 1.4132e7 [cm2/s2/K] +! qi0: mixing ratio threshold for cloud ice aggregation [kg/kg] +! = 1.0e-3 g/g = 1.0e-3 kg/gk +! ql0: mixing ratio threshold for cloud watercoalescence [kg/kg] +! = 2.0e-3 g/g = 2.0e-3 kg/gk +! qs0: mixing ratio threshold for snow aggregation +! = 6.0e-4 g/g = 6.0e-4 kg/gk +! xmi50: mass of a 50 micron ice crystal +! = 4.8e-10 [kg] =4.8e-7 [g] +! xmi40: mass of a 40 micron ice crystal +! = 2.46e-10 [kg] = 2.46e-7 [g] +! di50: diameter of a 50 micro (radius) ice crystal +! =1.0e-4 [m] +! xmi: mass of one cloud ice crystal +! =4.19e-13 [kg] = 4.19e-10 [g] +! oxmi=1.0/xmi +! + + +! if gindex=1.0 include graupel +! if gindex=0. no graupel +! +! + do k=kts,kte + psnow(k)=0.0 + psaut(k)=0.0 + psfw(k)=0.0 + psfi(k)=0.0 + praci(k)=0.0 + piacr(k)=0.0 + psaci(k)=0.0 + psacw(k)=0.0 + psdep(k)=0.0 + pssub(k)=0.0 + pracs(k)=0.0 + psacr(k)=0.0 + psmlt(k)=0.0 + psmltevp(k)=0.0 +! + prain(k)=0.0 + praut(k)=0.0 + pracw(k)=0.0 + prevp(k)=0.0 +! + pvapor(k)=0.0 +! + pclw(k)=0.0 + preclw(k)=0.0 !sg + pladj(k)=0.0 +! + pcli(k)=0.0 + pimlt(k)=0.0 + pihom(k)=0.0 + pidw(k)=0.0 + piadj(k)=0.0 + enddo + +! +!!! graupel +! + do k=kts,kte + pgraupel(k)=0.0 + pgaut(k)=0.0 + pgfr(k)=0.0 + pgacw(k)=0.0 + pgaci(k)=0.0 + pgacr(k)=0.0 + pgacs(k)=0.0 + pgacip(k)=0.0 + pgacrP(k)=0.0 + pgacsp(k)=0.0 + pgwet(k)=0.0 + pdry(k)=0.0 + pgsub(k)=0.0 + pgdep(k)=0.0 + pgmlt(k)=0.0 + pgmltevp(k)=0.0 + qschg(k)=0. + qgchg(k)=0. + enddo +! +! +! Set rs0=episp0*oprez(k) +! episp0=e*saturated pressure at 273.15 K +! e = 0.622 +! + DO k=kts,kte + rs0(k)=ep2*1000.*svp1/(prez(k)-1000.*svp1) + END DO +! +!*********************************************************************** +! Calculate precipitation fluxes due to terminal velocities. +!*********************************************************************** +! +!- Calculate termianl velocity (vt?) of precipitation q?z +!- Find maximum vt? to determine the small delta t +! +!-- rain +! + t_del_tv=0. + del_tv=dtb + notlast=.true. + DO while (notlast) +! + min_q=kte + max_q=kts-1 +! + do k=kts,kte-1 + if (qrz(k) .gt. 1.0e-8) then + min_q=min0(min_q,k) + max_q=max0(max_q,k) + tmp1=sqrt(pi*rhowater*xnor/rho(k)/qrz(k)) + tmp1=sqrt(tmp1) + vtrold(k)=o6*consta*gambp4*sqrho(k)/tmp1**constb + if (k .eq. 1) then + del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtrold(k)) + else + del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtrold(k)) + endif + else + vtrold(k)=0. + endif + enddo + + if (max_q .ge. min_q) then +! +!- Check if the summation of the small delta t >= big delta t +! (t_del_tv) (del_tv) (dtb) + + t_del_tv=t_del_tv+del_tv +! + if ( t_del_tv .ge. dtb ) then + notlast=.false. + del_tv=dtb+del_tv-t_del_tv + endif +! + fluxin=0. + do k=max_q,min_q,-1 + fluxout=rho(k)*vtrold(k)*qrz(k) + flux=(fluxin-fluxout)/rho(k)/dzw(k) + tmpqrz=qrz(k) + qrz(k)=qrz(k)+del_tv*flux + fluxin=fluxout + enddo + if (min_q .eq. 1) then + pptrain=pptrain+fluxin*del_tv + else + qrz(min_q-1)=qrz(min_q-1)+del_tv* & + fluxin/rho(min_q-1)/dzw(min_q-1) + endif +! + else + notlast=.false. + endif + ENDDO + +! +!-- snow +! + t_del_tv=0. + del_tv=dtb + notlast=.true. + + DO while (notlast) +! + min_q=kte + max_q=kts-1 +! + do k=kts,kte-1 + if (qsz(k) .gt. 1.0e-8) then + min_q=min0(min_q,k) + max_q=max0(max_q,k) + tmp1=sqrt(pi*rhosnow*xnos/rho(k)/qsz(k)) + tmp1=sqrt(tmp1) + vtsold(k)=o6*constc*gamdp4*sqrho(k)/tmp1**constd + if (k .eq. 1) then + del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtsold(k)) + else + del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtsold(k)) + endif + else + vtsold(k)=0. + endif + enddo + + if (max_q .ge. min_q) then +! +! +!- Check if the summation of the small delta t >= big delta t +! (t_del_tv) (del_tv) (dtb) + + t_del_tv=t_del_tv+del_tv + + if ( t_del_tv .ge. dtb ) then + notlast=.false. + del_tv=dtb+del_tv-t_del_tv + endif +! + fluxin=0. + do k=max_q,min_q,-1 + fluxout=rho(k)*vtsold(k)*qsz(k) + flux=(fluxin-fluxout)/rho(k)/dzw(k) + qsz(k)=qsz(k)+del_tv*flux + qsz(k)=amax1(0.,qsz(k)) + fluxin=fluxout + enddo + if (min_q .eq. 1) then + pptsnow=pptsnow+fluxin*del_tv + else + qsz(min_q-1)=qsz(min_q-1)+del_tv* & + fluxin/rho(min_q-1)/dzw(min_q-1) + endif +! + else + notlast=.false. + endif + + ENDDO +! +!-- grauupel +! + t_del_tv=0. + del_tv=dtb + notlast=.true. +! + DO while (notlast) +! + min_q=kte + max_q=kts-1 +! + do k=kts,kte-1 + if (qgz(k) .gt. 1.0e-8) then + min_q=min0(min_q,k) + max_q=max0(max_q,k) + tmp1=sqrt(pi*rhograul*xnog/rho(k)/qgz(k)) + tmp1=sqrt(tmp1) + term0=sqrt(4.*grav*rhograul*0.33334/rho(k)/cdrag) + vtgold(k)=o6*gam4pt5*term0*sqrt(1./tmp1) + if (k .eq. 1) then + del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtgold(k)) + else + del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtgold(k)) + endif + else + vtgold(k)=0. + endif + enddo + + if (max_q .ge. min_q) then +! +! +!- Check if the summation of the small delta t >= big delta t +! (t_del_tv) (del_tv) (dtb) + + t_del_tv=t_del_tv+del_tv + + if ( t_del_tv .ge. dtb ) then + notlast=.false. + del_tv=dtb+del_tv-t_del_tv + endif + +! + fluxin=0. + do k=max_q,min_q,-1 + fluxout=rho(k)*vtgold(k)*qgz(k) + flux=(fluxin-fluxout)/rho(k)/dzw(k) + qgz(k)=qgz(k)+del_tv*flux + qgz(k)=amax1(0.,qgz(k)) + fluxin=fluxout + enddo + if (min_q .eq. 1) then + pptgraul=pptgraul+fluxin*del_tv + else + qgz(min_q-1)=qgz(min_q-1)+del_tv* & + fluxin/rho(min_q-1)/dzw(min_q-1) + endif +! + else + notlast=.false. + endif +! + ENDDO + +! +!-- cloud ice (03/21/02) follow Vaughan T.J. Phillips at GFDL +! + t_del_tv=0. + del_tv=dtb + notlast=.true. +! + DO while (notlast) +! + min_q=kte + max_q=kts-1 +! + do k=kts,kte-1 + if (qiz(k) .gt. 1.0e-8) then + min_q=min0(min_q,k) + max_q=max0(max_q,k) + vtiold(k)= 3.29 * (rho(k)* qiz(k))** 0.16 ! Heymsfield and Donner + if (k .eq. 1) then + del_tv=amin1(del_tv,0.9*(zz(k)-zsfc)/vtiold(k)) + else + del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtiold(k)) + endif + else + vtiold(k)=0. + endif + enddo + + if (max_q .ge. min_q) then +! +! +!- Check if the summation of the small delta t >= big delta t +! (t_del_tv) (del_tv) (dtb) + + t_del_tv=t_del_tv+del_tv + + if ( t_del_tv .ge. dtb ) then + notlast=.false. + del_tv=dtb+del_tv-t_del_tv + endif + + fluxin=0. + do k=max_q,min_q,-1 + fluxout=rho(k)*vtiold(k)*qiz(k) + flux=(fluxin-fluxout)/rho(k)/dzw(k) + qiz(k)=qiz(k)+del_tv*flux + qiz(k)=amax1(0.,qiz(k)) + fluxin=fluxout + enddo + if (min_q .eq. 1) then + pptice=pptice+fluxin*del_tv + else + qiz(min_q-1)=qiz(min_q-1)+del_tv* & + fluxin/rho(min_q-1)/dzw(min_q-1) + endif +! + else + notlast=.false. + endif +! + ENDDO + do k=kts,kte-1 !sg beg + precrz(k)=rho(k)*vtrold(k)*qrz(k) + preciz(k)=rho(k)*vtiold(k)*qiz(k) + precsz(k)=rho(k)*vtsold(k)*qsz(k) + precgz(k)=rho(k)*vtgold(k)*qgz(k) + enddo !sg end + precrz(kte)=0. !wig - top level never set for vtXold vars + preciz(kte)=0. !wig + precsz(kte)=0. !wig + precgz(kte)=0. !wig + + +! Microphpysics processes +! + DO 2000 k=kts,kte +! +!*********************************************************************** +!***** diagnose mixing ratios (qrz,qsz), terminal ***** +!***** velocities (vtr,vts), and slope parameters in size ***** +!***** distribution(xlambdar,xlambdas) of rain and snow ***** +!***** follows Nagata and Ogura, 1991, MWR, 1309-1337. Eq (A7) ***** +!*********************************************************************** +! +!**** assuming no cloud water can exist in the top two levels due to +!**** radiation consideration +! +!! if +!! unsaturated, +!! no cloud water, rain, ice, snow and graupel +!! then +!! skip these processes and jump to line 2000 +! +! + tmp=qiz(k)+qlz(k)+qsz(k)+qrz(k)+qgz(k)*gindex + if( qvz(k)+qlz(k)+qiz(k) .lt. qsiz(k) & + .and. tmp .eq. 0.0 ) go to 2000 + +!! calculate terminal velocity of rain +! + if (qrz(k) .gt. 1.0e-8) then + tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k)) + xlambdar(k)=sqrt(tmp1) + olambdar(k)=1.0/xlambdar(k) + vtrold(k)=o6*consta*gambp4*sqrho(k)*olambdar(k)**constb + else + vtrold(k)=0. + olambdar(k)=0. + endif +! +! if (qrz(k) .gt. 1.0e-12) then + if (qrz(k) .gt. 1.0e-8) then + tmp1=sqrt(pi*rhowater*xnor*orho(k)/qrz(k)) + xlambdar(k)=sqrt(tmp1) + olambdar(k)=1.0/xlambdar(k) + vtr(k)=o6*consta*gambp4*sqrho(k)*olambdar(k)**constb + else + vtr(k)=0. + olambdar(k)=0. + endif +! +!! calculate terminal velocity of snow +! + if (qsz(k) .gt. 1.0e-8) then + tmp1=sqrt(pi*rhosnow*xnos*orho(k)/qsz(k)) + xlambdas(k)=sqrt(tmp1) + olambdas(k)=1.0/xlambdas(k) + vtsold(k)=o6*constc*gamdp4*sqrho(k)*olambdas(k)**constd + else + vtsold(k)=0. + olambdas(k)=0. + endif +! +! if (qsz(k) .gt. 1.0e-12) then + if (qsz(k) .gt. 1.0e-8) then + tmp1=sqrt(pi*rhosnow*xnos*orho(k)/qsz(k)) + xlambdas(k)=sqrt(tmp1) + olambdas(k)=1.0/xlambdas(k) + vts(k)=o6*constc*gamdp4*sqrho(k)*olambdas(k)**constd + else + vts(k)=0. + olambdas(k)=0. + endif +! +!! calculate terminal velocity of graupel +! + if (qgz(k) .gt. 1.0e-8) then + tmp1=sqrt( pi*rhograul*xnog*orho(k)/qgz(k)) + xlambdag(k)=sqrt(tmp1) + olambdag(k)=1.0/xlambdag(k) + term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) + vtgold(k)=o6*gam4pt5*term0*sqrt(olambdag(k)) + else + vtgold(k)=0. + olambdag(k)=0. + endif +! +! if (qgz(k) .gt. 1.0e-12) then + if (qgz(k) .gt. 1.0e-8) then + tmp1=sqrt( pi*rhograul*xnog*orho(k)/qgz(k)) + xlambdag(k)=sqrt(tmp1) + olambdag(k)=1.0/xlambdag(k) + term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) + vtg(k)=o6*gam4pt5*term0*sqrt(olambdag(k)) + else + vtg(k)=0. + olambdag(k)=0. + endif +! +!*********************************************************************** +!***** compute viscosity,difusivity,thermal conductivity, and ****** +!***** Schmidt number ****** +!*********************************************************************** +!c------------------------------------------------------------------ +!c viscmu: dynamic viscosity of air kg/m/s +!c visc: kinematic viscosity of air = viscmu/rho (m2/s) +!c avisc=1.49628e-6 kg/m/s=1.49628e-5 g/cm/s +!c viscmu=1.718e-5 kg/m/s in RH +!c diffwv: Diffusivity of water vapor in air +!c adiffwv = 8.7602e-5 (8.794e-5 in MM5) kgm/s3 +!c = 8.7602 (8.794 in MM5) gcm/s3 +!c diffwv(k)=2.26e-5 m2/s +!c schmidt: Schmidt number=visc/diffwv +!c xka: thermal conductivity of air J/m/s/K (Kgm/s3/K) +!c xka(k)=2.43e-2 J/m/s/K in RH +!c axka=1.4132e3 (1.414e3 in MM5) m2/s2/k = 1.4132e7 cm2/s2/k +!c------------------------------------------------------------------ + + viscmu(k)=avisc*tem(k)**1.5/(tem(k)+120.0) + visc(k)=viscmu(k)*orho(k) + diffwv(k)=adiffwv*tem(k)**1.81*oprez(k) + schmidt(k)=visc(k)/diffwv(k) + xka(k)=axka*viscmu(k) + + if (tem(k) .lt. 273.15) then + +! +!*********************************************************************** +!********* snow production processes for T < 0 C ********** +!*********************************************************************** +!c +!c (1) ICE CRYSTAL AGGREGATION TO SNOW (Psaut): Lin (21) +!c! psaut=alpha1*(qi-qi0) +!c! alpha1=1.0e-3*exp(0.025*(T-T0)) +!c +! alpha1=1.0e-3*exp( 0.025*temcc(k) ) + + alpha1=1.0e-3*exp( 0.025*temcc(k) ) +! + if(temcc(k) .lt. -20.0) then + tmp1=-7.6+4.0*exp( -0.2443e-3*(abs(temcc(k))-20)**2.455 ) + qic=1.0e-3*exp(tmp1)*orho(k) + else + qic=qi0 + end if +!testing +! tmp1=amax1( 0.0,alpha1*(qiz(k)-qic) ) +! psaut(k)=amin1( tmp1,qizodt(k) ) + + tmp1=odtb*(qiz(k)-qic)*(1.0-exp(-alpha1*dtb)) + psaut(k)=amax1( 0.0,tmp1 ) + +!c +!c (2) BERGERON PROCESS TRANSFER OF CLOUD WATER TO SNOW (Psfw) +!c this process only considered when -31 C < T < 0 C +!c Lin (33) and Hsie (17) +!c +!c! +!c! parama1 and parama2 functions must be user supplied +!c! + +! testing + if( qlz(k) .gt. 1.0e-10 ) then + temc1=amax1(-30.99,temcc(k)) +! print*,'temc1',temc1,qlz(k) + a1=parama1( temc1 ) + a2=parama2( temc1 ) + tmp1=1.0-a2 +!! change unit from cgs to mks + a1=a1*0.001**tmp1 +!c! dtberg is the time needed for a crystal to grow from 40 to 50 um +!c ! odtberg=1.0/dtberg + odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1) +! +!c! compute terminal velocity of a 50 micron ice cystal +! + vti50=constc*di50**constd*sqrho(k) +! + eiw=1.0 + save1=a1*xmi50**a2 + save2=0.25*pi*eiw*rho(k)*di50*di50*vti50 +! + tmp2=( save1 + save2*qlz(k) ) +! +!! maximum number of 50 micron crystals limited by the amount +!! of supercool water +! + xni50mx=qlzodt(k)/tmp2 +! +!! number of 50 micron crystals produced +! +! + xni50=qiz(k)*( 1.0-exp(-dtb*odtberg) )/xmi50 + xni50=amin1(xni50,xni50mx) +! + tmp3=odtb*tmp2/save2*( 1.0-exp(-save2*xni50*dtb) ) + psfw(k)=amin1( tmp3,qlzodt(k) ) +!testing +! psfw(k)=0. + +!0915 if( temcc(k).gt.-30.99 ) then +!0915 a1=parama1( temcc(k) ) +!0915 a2=parama2( temcc(k) ) +!0915 tmp1=1.0-a2 +!! change unit from cgs to mks +!0915 a1=a1*0.001**tmp1 + +!c! dtberg is the time needed for a crystal to grow from 40 to 50 um +!c! odtberg=1.0/dtberg +!0915 odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1) + +!c! number of 50 micron crystals produced +!0915 xni50=qiz(k)*dtb*odtberg/xmi50 + +!c! need to calculate the terminal velocity of a 50 micron +!c! ice cystal +!0915 vti50=constc*di50**constd*sqrho(k) +!0915 eiw=1.0 +!0915 tmp2=xni50*( a1*xmi50**a2 + & +!0915 0.25*qlz(k)*pi*eiw*rho(k)*di50*di50*vti50 ) +!0915 psfw(k)=amin1( tmp2,qlzodt(k) ) +!0915 psfw(k)=0. +!c +!c (3) REDUCTION OF CLOUD ICE BY BERGERON PROCESS (Psfi): Lin (34) +!c this process only considered when -31 C < T < 0 C +!c + tmp1=xni50*xmi50-psfw(k) + psfi(k)=amin1(tmp1,qizodt(k)) +! testing +! psfi(k)=0. + end if +! + +!0915 tmp1=qiz(k)*odtberg +!0915 psfi(k)=amin1(tmp1,qizodt(k)) +! testing +!0915 psfi(k)=0. +!0915 end if +! + if(qrz(k) .le. 0.0) go to 1000 +! +! Processes (4) and (5) only need when qrz > 0.0 +! +!c +!c (4) CLOUD ICE ACCRETION BY RAIN (Praci): Lin (25) +!c may produce snow or graupel +!c + eri=1.0 +!0915 tmp1=qiz(k)*pio4*eri*xnor*consta*sqrho(k) +!0915 tmp2=tmp1*gambp3*olambdar(k)**bp3 +!0915 praci(k)=amin1( tmp2,qizodt(k) ) + + save1=pio4*eri*xnor*consta*sqrho(k) + tmp1=save1*gambp3*olambdar(k)**bp3 + praci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) ) + +!c +!c (5) RAIN ACCRETION BY CLOUD ICE (Piacr): Lin (26) +!c +!0915 tmp2=tmp1*rho(k)*pio6*rhowater*gambp6*oxmi* & +!0915 olambdar(k)**bp6 +!0915 piacr(k)=amin1( tmp2,qrzodt(k) ) + + tmp2=qiz(k)*save1*rho(k)*pio6*rhowater*gambp6*oxmi* & + olambdar(k)**bp6 + piacr(k)=amin1( tmp2,qrzodt(k) ) + +! +1000 continue +! + if(qsz(k) .le. 0.0) go to 1200 +! +! Compute the following processes only when qsz > 0.0 +! +!c +!c (6) ICE CRYSTAL ACCRETION BY SNOW (Psaci): Lin (22) +!c + esi=exp( 0.025*temcc(k) ) + save1=pio4*xnos*constc*gamdp3*sqrho(k)* & + olambdas(k)**dp3 + tmp1=esi*save1 + psaci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) ) + +!0915 tmp1=pio4*xnos*constc*gamdp3*sqrho(k)* & +!0915 olambdas(k)**dp3 +!0915 tmp2=qiz(k)*esi*tmp1 +!0915 psaci(k)=amin1( tmp2,qizodt(k) ) +!c +!c (7) CLOUD WATER ACCRETION BY SNOW (Psacw): Lin (24) +!c + esw=1.0 + tmp1=esw*save1 + psacw(k)=qlzodt(K)*( 1.0-exp(-tmp1*dtb) ) + +!0915 tmp2=qlz(k)*esw*tmp1 +!0915 psacw(k)=amin1( tmp2,qlzodt(k) ) +!c +!c (8) DEPOSITION/SUBLIMATION OF SNOW (Psdep/Pssub): Lin (31) +!c includes consideration of ventilation effect +!c +!c abi=2*pi*(Si-1)/rho/(A"+B") +!c + tmpa=rvapor*xka(k)*tem(k)*tem(k) + tmpb=xls*xls*rho(k)*qsiz(k)*diffwv(k) + tmpc=tmpa*qsiz(k)*diffwv(k) + abi=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) +! +!c vf1s,vf2s=ventilation factors for snow +!c vf1s=0.78,vf2s=0.31 in LIN +! + tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) + tmp2=abi*xnos*( vf1s*olambdas(k)*olambdas(k)+ & + vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) + tmp3=odtb*( qvz(k)-qsiz(k) ) +! + if( tmp2 .le. 0.0) then + tmp2=amax1( tmp2,tmp3) + pssub(k)=amax1( tmp2,-qszodt(k) ) + psdep(k)=0.0 + else + psdep(k)=amin1( tmp2,tmp3 ) + pssub(k)=0.0 + end if + +!0915 psdep(k)=amax1(0.0,tmp2) +!0915 pssub(k)=amin1(0.0,tmp2) +!0915 pssub(k)=amax1( pssub(k),-qszodt(k) ) +! + if(qrz(k) .le. 0.0) go to 1200 +! +! Compute processes (9) and (10) only when qsz > 0.0 and qrz > 0.0 +! +!c +!c (9) ACCRETION OF SNOW BY RAIN (Pracs): Lin (27) +!c + esr=1.0 + tmpa=olambdar(k)*olambdar(k) + tmpb=olambdas(k)*olambdas(k) + tmpc=olambdar(k)*olambdas(k) + tmp1=pi*pi*esr*xnor*xnos*abs( vtr(k)-vts(k) )*orho(k) + tmp2=tmpb*tmpb*olambdar(k)*(5.0*tmpb+2.0*tmpc+0.5*tmpa) + tmp3=tmp1*rhosnow*tmp2 + pracs(k)=amin1( tmp3,qszodt(k) ) +!c +!c (10) ACCRETION OF RAIN BY SNOW (Psacr): Lin (28) +!c + tmp3=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp4=tmp1*rhowater*tmp3 + psacr(k)=amin1( tmp4,qrzodt(k) ) +! +1200 continue +! + else +! +!*********************************************************************** +!********* snow production processes for T > 0 C ********** +!*********************************************************************** +! + if (qsz(k) .le. 0.0) go to 1400 +!c +!c (1) CLOUD WATER ACCRETION BY SNOW (Psacw): Lin (24) +!c + esw=1.0 + + tmp1=esw*pio4*xnos*constc*gamdp3*sqrho(k)* & + olambdas(k)**dp3 + psacw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) ) + +!0915 tmp1=pio4*xnos*constc*gamdp3*sqrho(k)* & +!0915 olambdas(k)**dp3 +!0915 tmp2=qlz(k)*esw*tmp1 +!0915 psacw(k)=amin1( tmp2,qlzodt(k) ) +!c +!c (2) ACCRETION OF RAIN BY SNOW (Psacr): Lin (28) +!c + esr=1.0 + tmpa=olambdar(k)*olambdar(k) + tmpb=olambdas(k)*olambdas(k) + tmpc=olambdar(k)*olambdas(k) + tmp1=pi*pi*esr*xnor*xnos*abs( vtr(k)-vts(k) )*orho(k) + tmp2=tmpa*tmpa*olambdas(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp3=tmp1*rhowater*tmp2 + psacr(k)=amin1( tmp3,qrzodt(k) ) +!c +!c (3) MELTING OF SNOW (Psmlt): Lin (32) +!c Psmlt is negative value +! + delrs=rs0(k)-qvz(k) + term1=2.0*pi*orho(k)*( xlv*diffwv(k)*rho(k)*delrs- & + xka(k)*temcc(k) ) + tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) + tmp2=xnos*( vf1s*olambdas(k)*olambdas(k)+ & + vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) + tmp3=term1*oxlf*tmp2-cwoxlf*temcc(k)*( psacw(k)+psacr(k) ) + tmp4=amin1(0.0,tmp3) + psmlt(k)=amax1( tmp4,-qszodt(k) ) +!c +!c (4) EVAPORATION OF MELTING SNOW (Psmltevp): HR (A27) +!c but use Lin et al. coefficience +!c Psmltevp is a negative value +!c + tmpa=rvapor*xka(k)*tem(k)*tem(k) + tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) + tmpc=tmpa*qswz(k)*diffwv(k) + tmpd=amin1( 0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb ) + +! abr=2.0*pi*(qvoqswz(k)-1.0)*tmpc/(tmpa+tmpb) + + abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) +! +!**** allow evaporation to occur when RH less than 90% +!**** here not using 100% because the evaporation cooling +!**** of temperature is not taking into account yet; hence, +!**** the qsw value is a little bit larger. This will avoid +!**** evaporation can generate cloud. +! +!c vf1s,vf2s=ventilation factors for snow +!c vf1s=0.78,vf2s=0.31 in LIN +! + tmp1=constc*sqrho(k)*olambdas(k)**dp5/visc(k) + tmp2=abr*xnos*( vf1s*olambdas(k)*olambdas(k)+ & + vf2s*schmidt(k)**0.33334*gamdp5o2*sqrt(tmp1) ) + tmp3=amin1(0.0,tmp2) + tmp3=amax1( tmp3,tmpd ) + psmltevp(k)=amax1( tmp3,-qszodt(k) ) +1400 continue +! + end if + +!*********************************************************************** +!********* rain production processes ********** +!*********************************************************************** +! +!c +!c (1) AUTOCONVERSION OF RAIN (Praut): RH +!sg: begin + if(flag_qndrop)then + if( qndropz(k) >= 1. ) then +! Liu et al. autoconversion scheme + rhocgs=rho(k)*1.e-3 + liqconc=rhocgs*qlz(k) + capn=rhocgs*qndropz(k) +! rate function + if(liqconc.gt.1.e-10)then + p0=kappa*beta/capn*(liqconc*liqconc*liqconc) + xc=9.7d-17*capn*sqrt(capn)/(liqconc*liqconc) +! Calculate autoconversion rate (g/g/s) + if(xc.lt.10.)then + praut(k)=p0/rhocgs*0.5d0*(xc*xc+2*xc+2.0d0)* & + (1.0d0+xc)*dexp(-2.0d0*xc) + endif + endif + endif + else +!sg: end +!c araut=afa*rho +!c afa=0.001 Rate coefficient for autoconvergence +!c +!c araut=1.0e-3 +!c + araut=0.001 +!testing +! tmp1=amax1( 0.0,araut*(qlz(k)-ql0) ) +! praut(k)=amin1( tmp1,qlzodt(k) ) + tmp1=odtb*(qlz(k)-ql0)*( 1.0-exp(-araut*dtb) ) + praut(k)=amax1( 0.0,tmp1 ) + endif !sg + +!c +!c (2) ACCRETION OF CLOUD WATER BY RAIN (Pracw): Lin (51) +!c + erw=1.0 +! tmp1=qlz(k)*pio4*erw*xnor*consta*sqrho(k) +! tmp2=tmp1*gambp3*olambdar(k)**bp3 +! pracw(k)=amin1( tmp2,qlzodt(k) ) + + tmp1=pio4*erw*xnor*consta*sqrho(k)* & + gambp3*olambdar(k)**bp3 + pracw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) ) + +!c +!c (3) EVAPORATION OF RAIN (Prevp): Lin (52) +!c Prevp is negative value +!c +!c Sw=qvoqsw : saturation ratio +!c + tmpa=rvapor*xka(k)*tem(k)*tem(k) + tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) + tmpc=tmpa*qswz(k)*diffwv(k) + tmpd=amin1(0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb) +! +! abr=2.0*pi*(qvoqswz(k)-1.0)*tmpc/(tmpa+tmpb) + + abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) +! +!c vf1r,vf2r=ventilation factors for rain +!c vf1r=0.78,vf2r=0.31 in RH, LIN and MM5 +! + vf1r=0.78 + vf2r=0.31 + tmp1=consta*sqrho(k)*olambdar(k)**bp5/visc(k) + tmp2=abr*xnor*( vf1r*olambdar(k)*olambdar(k)+ & + vf2r*schmidt(k)**0.33334*gambp5o2*sqrt(tmp1) ) + tmp3=amin1( 0.0,tmp2 ) + tmp3=amax1( tmp3,tmpd ) + prevp(k)=amax1( tmp3,-qrzodt(k) ) + +! +! if(iout .gt. 0) write(20,*)'tmp1,tmp2,tmp3=',tmp1,tmp2,tmp3 +! if(iout .gt. 0) write(20,*)'qlz,qiz,qrz=',qlz(k),qiz(k),qrz(k) +! if(iout .gt. 0) write(20,*)'tem,qsz,qvz=',tem(k),qsz(k),qvz(k) + + + +! if (gindex .eq. 0.) goto 900 +! + if (tem(k) .lt. 273.15) then +! +! +!-- graupel +!*********************************************************************** +!********* graupel production processes for T < 0 C ********** +!*********************************************************************** +!c +!c (1) AUTOCONVERSION OF SNOW TO FORM GRAUPEL (Pgaut): Lin (37) +!c pgaut=alpha2*(qsz-qs0) +!c qs0=6.0E-4 +!c alpha2=1.0e-3*exp(0.09*temcc(k)) Lin (38) +! + alpha2=1.0e-3*exp(0.09*temcc(k)) +! + +! testing +! tmp1=alpha2*(qsz(k)-qs0) +! tmp1=amax1(0.0,tmp1) +! pgaut(k)=amin1( tmp1,qszodt(k) ) + + tmp1=odtb*(qsz(k)-qs0)*(1.0-exp(-alpha2*dtb)) + pgaut(k)=amax1( 0.0,tmp1 ) + +!c +!c (2) FREEZING OF RAIN TO FORM GRAUPEL (Pgfr): Lin (45) +!c positive value +!c Constant in Bigg freezing Aplume=Ap=0.66 /k +!c Constant in raindrop freezing equ. Bplume=Bp=100./m/m/m/s +! + + if (qrz(k) .gt. 1.e-8 ) then + Bp=100. + Ap=0.66 + tmp1=olambdar(k)*olambdar(k)*olambdar(k) + tmp2=20.*pi*pi*Bp*xnor*rhowater*orho(k)* & + (exp(-Ap*temcc(k))-1.0)*tmp1*tmp1*olambdar(k) + Pgfr(k)=amin1( tmp2,qrzodt(k) ) + else + Pgfr(k)=0 + endif + +!c +!c if (qgz(k) = 0.0) skip the other step below about graupel +!c + if (qgz(k) .eq. 0.0) goto 4000 + +!c +!c Comparing Pgwet(wet process) and Pdry(dry process), +!c we will pick up the small one. +!c + +!c --------------- +!c | dry processes | +!c --------------- +!c +!c (3) ACCRETION OF CLOUD WATER BY GRAUPEL (Pgacw): Lin (40) +!c egw=1.0 +!c Cdrag=0.6 drag coefficients for hairstone +!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) +!c + egw=1.0 + constg=sqrt(4.*grav*rhograul*0.33334*orho(k)*oCdrag) + tmp1=pio4*xnog*gam3pt5*constg*olambdag(k)**3.5 + tmp2=qlz(k)*egw*tmp1 + Pgacw(k)=amin1( tmp2,qlzodt(k) ) +!c +!c (4) ACCRETION OF ICE CRYSTAL BY GRAUPEL (Pgaci): Lin (41) +!c egi=1. for wet growth +!c egi=0.1 for dry growth +!c + egi=0.1 + tmp2=qiz(k)*egi*tmp1 + pgaci(k)=amin1( tmp2,qizodt(k) ) + + +!c +!c (5) ACCRETION OF SNOW BY GRAUPEL (Pgacs) : Lin (29) +!c Compute processes (6) only when qsz > 0.0 and qgz > 0.0 +!c + egs=exp(0.09*temcc(k)) + tmpa=olambdas(k)*olambdas(k) + tmpb=olambdag(k)*olambdag(k) + tmpc=olambdas(k)*olambdag(k) + tmp1=pi*pi*xnos*xnog*abs( vts(k)-vtg(k) )*orho(k) + tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp3=tmp1*egs*rhosnow*tmp2 + Pgacs(k)=amin1( tmp3,qszodt(k) ) + + +!c +!c (6) ACCRETION OF RAIN BY GRAUPEL (Pgacr): Lin (42) +!c Compute processes (6) only when qrz > 0.0 and qgz > 0.0 +!c egr=1. +!c + egr=1. + tmpa=olambdar(k)*olambdar(k) + tmpb=olambdag(k)*olambdag(k) + tmpc=olambdar(k)*olambdag(k) + tmp1=pi*pi*xnor*xnog*abs( vtr(k)-vtg(k) )*orho(k) + tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp3=tmp1*egr*rhowater*tmp2 + pgacr(k)=amin1( tmp3,qrzodt(k) ) + +!c +!c (7) Calculate total dry process effect Pdry(k) +!c + Pdry(k)=Pgacw(k)+pgaci(k)+Pgacs(k)+pgacr(k) + +!c --------------- +!c | wet processes | +!c --------------- +!c +!c (3) ACCRETION OF ICE CRYSTAL BY GRAUPEL (Pgacip): Lin (41) +!c egi=1. for wet growth +!c egi=0.1 for dry growth +!c + tmp2=10.*pgaci(k) + pgacip(k)=amin1( tmp2,qizodt(k) ) + +!c +!c (4) ACCRETION OF SNOW BY GRAUPEL ((Pgacsp) : Lin (29) +!c Compute processes (6) only when qsz > 0.0 and qgz > 0.0 +!c egs=exp(0.09*(tem(k)-273.15)) when T < 273.15 k +!c + tmp3=Pgacs(k)*1.0/egs + Pgacsp(k)=amin1( tmp3,qszodt(k) ) + +!c +!c (5) WET GROWTH OF GRAUPEL (Pgwet) : Lin (43) +!c may involve Pgacs or Pgaci and +!c must include PPgacw or Pgacr, or both. +!c ( The amount of Pgacw which is not able +!c to freeze is shed to rain. ) + IF(temcc(k).gt.-40.)THEN + + term0=constg*olambdag(k)**5.5/visc(k) + +!c +!c vf1s,vf2s=ventilation factors for graupel +!c vf1s=0.78,vf2s=0.31 in LIN +!c Cdrag=0.6 drag coefficient for hairstone +!c constg2=vf1s*olambdag(k)*olambdag(k)+ +!c vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) + + delrs=rs0(k)-qvz(k) + tmp0=1./(xlf+cw*temcc(k)) + tmp1=2.*pi*xnog*(rho(k)*xlv*diffwv(k)*delrs-xka(k)* & + temcc(k))*orho(k)*tmp0 + constg2=vf1s*olambdag(k)*olambdag(k)+ & + vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) + tmp3=tmp1*constg2+(Pgacip(k)+Pgacsp(k))* & + (1-Ci*temcc(k)*tmp0) + tmp3=amax1(0.0,tmp3) + Pgwet(k)=amax1(tmp3,qlzodt(k)+qszodt(k)+qizodt(k) ) + +!c +!c Comparing Pgwet(wet process) and Pdry(dry process), +!c we will apply the small one. +!c if dry processes then delta4=1.0 +!c if wet processes then delta4=0.0 +! + if ( Pdry(k) .lt. Pgwet(k) ) then + delta4=1.0 + else + delta4=0.0 + endif + ELSE + delta4=1.0 + ENDIF + +!c +!c +!c (6) Pgacrp(k)=Pgwet(k)-Pgacw(k)-Pgacip(k)-Pgacsp(k) +!c if Pgacrp(k) > 0. then some of the rain is frozen to hail +!c if Pgacrp(k) < 0. then some of the cloud water collected +!c by the hail is unable to freeze and is +!c shed as rain. +!c + Pgacrp(k)=Pgwet(k)-Pgacw(k)-Pgacip(k)-Pgacsp(k) + +!c +!c (8) DEPOSITION/SUBLIMATION OF GRAUPEL (Pgdep/Pgsub): Lin (46) +!c includes ventilation effect +!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) +!c constg2=vf1s*olambdag(k)*olambdag(k)+ +!c vf2s*schmidt(k)**0.33334*gam2pt75*constg +!c +!c abg=2*pi*(Si-1)/rho/(A"+B") +!c + tmpa=rvapor*xka(k)*tem(k)*tem(k) + tmpb=xls*xls*rho(k)*qsiz(k)*diffwv(k) + tmpc=tmpa*qsiz(k)*diffwv(k) + abg=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) +!c +!c vf1s,vf2s=ventilation factors for graupel +!c vf1s=0.78,vf2s=0.31 in LIN +!c Cdrag=0.6 drag coefficient for hairstone +!c + tmp2=abg*xnog*constg2 + pgdep(k)=amax1(0.0,tmp2) + pgsub(k)=amin1(0.0,tmp2) + pgsub(k)=amax1( pgsub(k),-qgzodt(k) ) + + 4000 continue + else +! +!*********************************************************************** +!********* graupel production processes for T > 0 C ********** +!*********************************************************************** +! +!c +!c (1) ACCRETION OF CLOUD WATER BY GRAUPEL (Pgacw): Lin (40) +!c egw=1.0 +!c Cdrag=0.6 drag coefficients for hairstone +!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) + + egw=1.0 + constg=sqrt(4.*grav*rhograul*0.33334*orho(k)*oCdrag) + tmp1=pio4*xnog*gam3pt5*constg*olambdag(k)**3.5 + tmp2=qlz(k)*egw*tmp1 + Pgacw(k)=amin1( tmp2,qlzodt(k) ) + +!c +!c (2) ACCRETION OF RAIN BY GRAUPEL (Pgacr): Lin (42) +!c Compute processes (5) only when qrz > 0.0 and qgz > 0.0 +!c egr=1. +!c + egr=1. + tmpa=olambdar(k)*olambdar(k) + tmpb=olambdag(k)*olambdag(k) + tmpc=olambdar(k)*olambdag(k) + tmp1=pi*pi*xnor*xnog*abs( vtr(k)-vtg(k) )*orho(k) + tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp3=tmp1*egr*rhowater*tmp2 + pgacr(k)=amin1( tmp3,qrzodt(k) ) + + +!c +!c (3) GRAUPEL MELTING TO FORM RAIN (Pgmlt): Lin (47) +!c Pgmlt is negative value +!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) +!c constg2=vf1s*olambdag(k)*olambdag(k)+ +!c vf2s*schmidt(k)**0.33334*gam2pt75*constg +!c Cdrag=0.6 drag coefficients for hairstone +! + delrs=rs0(k)-qvz(k) + term1=2.0*pi*orho(k)*( xlv*diffwv(k)*rho(k)*delrs- & + xka(k)*temcc(k) ) + term0=sqrt(4.*grav*rhograul*0.33334*orho(k)*ocdrag) & + *olambdag(k)**5.5/visc(k) + + constg2=vf1s*olambdag(k)*olambdag(k)+ & + vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0) + tmp2=xnog*constg2 + tmp3=term1*oxlf*tmp2-cwoxlf*temcc(k)*( pgacw(k)+pgacr(k) ) + tmp4=amin1(0.0,tmp3) + pgmlt(k)=amax1( tmp4,-qgzodt(k) ) + + +!c +!c (4) EVAPORATION OF MELTING GRAUPEL (Pgmltevp) : HR (A19) +!c but use Lin et al. coefficience +!c Pgmltevp is a negative value +!c abg=2.0*pi*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb) +!c + tmpa=rvapor*xka(k)*tem(k)*tem(k) + tmpb=xlv*xlv*rho(k)*qswz(k)*diffwv(k) + tmpc=tmpa*qswz(k)*diffwv(k) + tmpd=amin1( 0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb ) + +!c +!c abg=2*pi*(Si-1)/rho/(A"+B") +!c + abg=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb) +! +!**** allow evaporation to occur when RH less than 90% +!**** here not using 100% because the evaporation cooling +!**** of temperature is not taking into account yet; hence, +!**** the qgw value is a little bit larger. This will avoid +!**** evaporation can generate cloud. +! +!c vf1s,vf2s=ventilation factors for snow +!c vf1s=0.78,vf2s=0.31 in LIN +!c constg=sqrt(4.*grav*rhograul*0.33334*orho(k)/Cdrag) +!c constg2=vf1s*olambdag(k)*olambdag(k)+ +!c vf2s*schmidt(k)**0.33334*gam2pt75*constg +! + tmp2=abg*xnog*constg2 + tmp3=amin1(0.0,tmp2) + tmp3=amax1( tmp3,tmpd ) + pgmltevp(k)=amax1( tmp3,-qgzodt(k) ) + +!c +!c (5) ACCRETION OF SNOW BY GRAUPEL (Pgacs) : Lin (29) +!c Compute processes (3) only when qsz > 0.0 and qgz > 0.0 +!c egs=1.0 +!c + egs=1. + tmpa=olambdas(k)*olambdas(k) + tmpb=olambdag(k)*olambdag(k) + tmpc=olambdas(k)*olambdag(k) + tmp1=pi*pi*xnos*xnog*abs( vts(k)-vtg(k) )*orho(k) + tmp2=tmpa*tmpa*olambdag(k)*(5.0*tmpa+2.0*tmpc+0.5*tmpb) + tmp3=tmp1*egs*rhosnow*tmp2 + Pgacs(k)=amin1( tmp3,qszodt(k) ) + + endif + + +! + 900 continue + +!cc +!c +!c********************************************************************** +!c***** combine all processes together and avoid negative ***** +!c***** water substances +!*********************************************************************** +!c + if ( temcc(k) .lt. 0.0) then +!,delta4,1.-delta4 +!c +!c gdelta4=gindex*delta4 +!c g1sdelt4=gindex*(1.-delta4) +!c + gdelta4=gindex*delta4 + g1sdelt4=gindex*(1.-delta4) +!c +!c combined water vapor depletions +!c +!cc graupel + tmp=psdep(k)+pgdep(k)*gindex + if ( tmp .gt. qvzodt(k) ) then + factor=qvzodt(k)/tmp + psdep(k)=psdep(k)*factor + pgdep(k)=pgdep(k)*factor*gindex + end if +!c +!c combined cloud water depletions +!c + tmp=praut(k)+psacw(k)+psfw(k)+pracw(k)+gindex*Pgacw(k) + if ( tmp .gt. qlzodt(k) ) then + factor=qlzodt(k)/tmp + praut(k)=praut(k)*factor + psacw(k)=psacw(k)*factor + psfw(k)=psfw(k)*factor + pracw(k)=pracw(k)*factor +!cc graupel + Pgacw(k)=Pgacw(k)*factor*gindex + end if +!c +!c combined cloud ice depletions +!c + tmp=psaut(k)+psaci(k)+praci(k)+psfi(k)+Pgaci(k)*gdelta4 & + +Pgacip(k)*g1sdelt4 + if (tmp .gt. qizodt(k) ) then + factor=qizodt(k)/tmp + psaut(k)=psaut(k)*factor + psaci(k)=psaci(k)*factor + praci(k)=praci(k)*factor + psfi(k)=psfi(k)*factor +!cc graupel + Pgaci(k)=Pgaci(k)*factor*gdelta4 + Pgacip(k)=Pgacip(k)*factor*g1sdelt4 + endif +!c +!c combined all rain processes +!c + tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k) & + +Pgfr(k)*gindex+Pgacr(k)*gdelta4 & + +Pgacrp(k)*g1sdelt4 + if (tmp_r .gt. qrzodt(k) ) then + factor=qrzodt(k)/tmp_r + piacr(k)=piacr(k)*factor + psacr(k)=psacr(k)*factor + prevp(k)=prevp(k)*factor +!cc graupel + Pgfr(k)=Pgfr(k)*factor*gindex + Pgacr(k)=Pgacr(k)*factor*gdelta4 + Pgacrp(k)=Pgacrp(k)*factor*g1sdelt4 + endif + +!c +!c if qrz < 1.0E-4 and qsz < 1.0E-4 then delta2=1. +!c (all Pracs and Psacr become to snow) +!c if qrz >= 1.0E-4 or qsz >= 1.0E-4 then delta2=0. +!c (all Pracs and Psacr become to graupel) +!c + if (qrz(k) .lt. 1.0E-4 .and. qsz(k) .lt. 1.0E-4) then + delta2=1.0 + else + delta2=0.0 + endif +! +!cc graupel + +!c +!c if qrz(k) < 1.0e-4 then delta3=1. means praci(k) --> qs +!c piacr(k) --> qs +!c if qrz(k) > 1.0e-4 then delta3=0. means praci(k) --> qg +!c piacr(k) --> qg : Lin (20) + + if (qrz(k) .lt. 1.0e-4) then + delta3=1.0 + else + delta3=0.0 + endif +! +!c +!c if gindex = 0.(no graupel) then delta2=1.0 +!c delta3=1.0 +!c + if (gindex .eq. 0.) then + delta2=1.0 + delta3=1.0 + endif +! +!c +!c combined all snow processes +!c + tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+ & + psfi(k)+praci(k)*delta3+piacr(k)*delta3+ & + psdep(k))+Pgaut(k)*gindex+Pgacs(k)*gdelta4+ & + Pgacsp(k)*g1sdelt4+Pracs(k)*(1.-delta2)- & + Psacr(k)*delta2 + if ( tmp_s .gt. qszodt(k) ) then + factor=qszodt(k)/tmp_s + pssub(k)=pssub(k)*factor + Pracs(k)=Pracs(k)*factor +!cc graupel + Pgaut(k)=Pgaut(k)*factor*gindex + Pgacs(k)=Pgacs(k)*factor*gdelta4 + Pgacsp(k)=Pgacsp(k)*factor*g1sdelt4 + endif + +!cc graupel +! + +! if (gindex .eq. 0.) goto 998 +!c +!c combined all graupel processes +!c + tmp_g=-pgaut(k)-pgfr(k)-Pgacw(k)*delta4-Pgaci(k)*delta4 & + -Pgacr(k)*delta4-Pgacs(k)*delta4 & + -pgwet(k)*(1.-delta4)-pgsub(k)-pgdep(k) & + -psacr(k)*(1-delta2)-Pracs(k)*(1-delta2) & + -praci(k)*(1-delta3)-piacr(k)*(1-delta3) + if (tmp_g .gt. qgzodt(k)) then + factor=qgzodt(k)/tmp_g + pgsub(k)=pgsub(k)*factor + endif + + 998 continue +!c +!c calculate new water substances, thetae, tem, and qvsbar +!c + +!cc graupel + pvapor(k)=-pssub(k)-psdep(k)-prevp(k)-pgsub(k)*gindex & + -pgdep(k)*gindex + qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k) ) + pclw(k)=-praut(k)-pracw(k)-psacw(k)-psfw(k)-pgacw(k)*gindex + if(flag_qndrop)then + if( qlz(k) > 1e-20 ) & + qndropz(k)=amax1( 0.0,qndropz(k)+dtb*pclw(k)*qndropz(k)/qlz(k) ) !sg + endif + qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) ) + pcli(k)=-psaut(k)-psfi(k)-psaci(k)-praci(k)-pgaci(k)*gdelta4 & + -Pgacip(k)*g1sdelt4 + qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) ) + tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k) & + +Pgfr(k)*gindex+Pgacr(k)*gdelta4 & + +Pgacrp(k)*g1sdelt4 + 232 format(i2,1x,6(f9.3,1x)) + prain(k)=-tmp_r + qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) ) + tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+ & + psfi(k)+praci(k)*delta3+piacr(k)*delta3+ & + psdep(k))+Pgaut(k)*gindex+Pgacs(k)*gdelta4+ & + Pgacsp(k)*g1sdelt4+Pracs(k)*(1.-delta2)- & + Psacr(k)*delta2 + psnow(k)=-tmp_s + qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) ) + qschg(k)=qschg(k)+psnow(k) + qschg(k)=psnow(k) +!cc graupel + tmp_g=-pgaut(k)-pgfr(k)-Pgacw(k)*delta4-Pgaci(k)*delta4 & + -Pgacr(k)*delta4-Pgacs(k)*delta4 & + -pgwet(k)*(1.-delta4)-pgsub(k)-pgdep(k) & + -psacr(k)*(1-delta2)-Pracs(k)*(1-delta2) & + -praci(k)*(1-delta3)-piacr(k)*(1-delta3) + 252 format(i2,1x,6(f12.9,1x)) + 262 format(i2,1x,7(f12.9,1x)) + pgraupel(k)=-tmp_g + pgraupel(k)=pgraupel(k)*gindex + qgz(k)=amax1( 0.0,qgz(k)+dtb*pgraupel(k)) +! qgchg(k)=qgchg(k)+pgraupel(k) + qgchg(k)=pgraupel(k) + qgz(k)=qgz(k)*gindex + + tmp=ocp/tothz(k)*xLf*(qschg(k)+qgchg(k)) + theiz(k)=theiz(k)+dtb*tmp + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + tem(k)=thz(k)*tothz(k) + + temcc(k)=tem(k)-273.15 + + if( temcc(k) .lt. -40.0 ) qswz(k)=qsiz(k) + qlpqi=qlz(k)+qiz(k) + if ( qlpqi .eq. 0.0 ) then + qvsbar(k)=qsiz(k) + else + qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi + endif + +! + else +!c +!c combined cloud water depletions +!c + tmp=praut(k)+psacw(k)+pracw(k)+pgacw(k)*gindex + if ( tmp .gt. qlzodt(k) ) then + factor=qlzodt(k)/tmp + praut(k)=praut(k)*factor + psacw(k)=psacw(k)*factor + pracw(k)=pracw(k)*factor +!cc graupel + pgacw(k)=pgacw(k)*factor*gindex + end if +!c +!c combined all snow processes +!c + tmp_s=-(psmlt(k)+psmltevp(k))+Pgacs(k)*gindex + if (tmp_s .gt. qszodt(k) ) then + factor=qszodt(k)/tmp_s + psmlt(k)=psmlt(k)*factor + psmltevp(k)=psmltevp(k)*factor +!cc graupel + Pgacs(k)=Pgacs(k)*factor*gindex + endif + +!c +!c +!cc graupel +!c +! if (gindex .eq. 0.) goto 997 + +!c +!c combined all graupel processes +!c + tmp_g=-pgmlt(k)-pgacs(k)-pgmltevp(k) + if (tmp_g .gt. qgzodt(k)) then + factor=qgzodt(k)/tmp_g + pgmltevp(k)=pgmltevp(k)*factor + pgmlt(k)=pgmlt(k)*factor + endif +!c + 997 continue + +!c +!c combined all rain processes +!c + tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k)) & + +pgmlt(k)*gindex-pgacw(k)*gindex + if (tmp_r .gt. qrzodt(k) ) then + factor=qrzodt(k)/tmp_r + prevp(k)=prevp(k)*factor + endif +!c +!c +!c calculate new water substances and thetae +!c + + + pvapor(k)=-psmltevp(k)-prevp(k)-pgmltevp(k) + qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k)) + pclw(k)=-praut(k)-pracw(k)-psacw(k)-pgacw(k)*gindex + if(flag_qndrop)then + if( qlz(k) > 1e-20 ) & + qndropz(k)=amax1( 0.0,qndropz(k)+dtb*pclw(k)*qndropz(k)/qlz(k) ) !sg + endif + qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) ) + pcli(k)=0.0 + qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) ) + tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k)) & + +pgmlt(k)*gindex-pgacw(k)*gindex + 242 format(i2,1x,7(f9.6,1x)) + prain(k)=-tmp_r + tmpqrz=qrz(k) + qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) ) + tmp_s=-(psmlt(k)+psmltevp(k))+Pgacs(k)*gindex + psnow(k)=-tmp_s + qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) ) +! qschg(k)=qschg(k)+psnow(k) + qschg(k)=psnow(k) +!cc graupel + + tmp_g=-pgmlt(k)-pgacs(k)-pgmltevp(k) +! write(*,272)k,pgmlt(k),pgacs(k),pgmltevp(k), + 272 format(i2,1x,3(f12.9,1x)) + pgraupel(k)=-tmp_g*gindex + qgz(k)=amax1( 0.0,qgz(k)+dtb*pgraupel(k)) +! qgchg(k)=qgchg(k)+pgraupel(k) + qgchg(k)=pgraupel(k) + qgz(k)=qgz(k)*gindex +! + tmp=ocp/tothz(k)*xLf*(qschg(k)+qgchg(k)) + theiz(k)=theiz(k)+dtb*tmp + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + + tem(k)=thz(k)*tothz(k) + temcc(k)=tem(k)-273.15 +! qswz(k)=episp0k*oprez(k)* & +! exp( svp2*temcc(k)/(tem(k)-svp3) ) + es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) + qswz(k)=ep2*es/(prez(k)-es) + qsiz(k)=qswz(k) + qvsbar(k)=qswz(k) +! + end if + preclw(k)=pclw(k) !sg + +! +!*********************************************************************** +!********** saturation adjustment ********** +!*********************************************************************** +! +! allow supersaturation exits linearly from 0% at 500 mb to 50% +! above 300 mb +! 5.0e-5=1.0/(500mb-300mb) +! + rsat=1.0+0.5*(50000.0-prez(k))*5.0e-5 + rsat=amax1(1.0,rsat) + rsat=amin1(1.5,rsat) + rsat=1.0 + if( qvz(k)+qlz(k)+qiz(k) .lt. rsat*qvsbar(k) ) then + +!c +!c unsaturated +!c + qvz(k)=qvz(k)+qlz(k)+qiz(k) + qlz(k)=0.0 + qiz(k)=0.0 + + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + tem(k)=thz(k)*tothz(k) + temcc(k)=tem(k)-273.15 + + go to 1800 +! + else +!c +!c saturated +!c +! + pladj(k)=qlz(k) + piadj(k)=qiz(k) +! + + CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, & + k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0 ) + +! + pladj(k)=odtb*(qlz(k)-pladj(k)) + piadj(k)=odtb*(qiz(k)-piadj(k)) +! + pclw(k)=pclw(k)+pladj(k) + pcli(k)=pcli(k)+piadj(k) + pvapor(k)=pvapor(k)-( pladj(k)+piadj(k) ) +! + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + tem(k)=thz(k)*tothz(k) + + temcc(k)=tem(k)-273.15 + +! qswz(k)=episp0k*oprez(k)* & +! exp( svp2*temcc(k)/(tem(k)-svp3) ) + es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) + qswz(k)=ep2*es/(prez(k)-es) + if (tem(k) .lt. 273.15 ) then +! qsiz(k)=episp0k*oprez(k)* & +! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + qsiz(k)=ep2*es/(prez(k)-es) + if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) + else + qsiz(k)=qswz(k) + endif + qlpqi=qlz(k)+qiz(k) + if ( qlpqi .eq. 0.0 ) then + qvsbar(k)=qsiz(k) + else + qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi + endif + + end if + +! +!*********************************************************************** +!***** melting and freezing of cloud ice and cloud water ***** +!*********************************************************************** + qlpqi=qlz(k)+qiz(k) + if(qlpqi .le. 0.0) go to 1800 +! +!c +!c (1) HOMOGENEOUS NUCLEATION WHEN T< -40 C (Pihom) +!c + if(temcc(k) .lt. -40.0) pihom(k)=qlz(k)*odtb +!c +!c (2) MELTING OF ICE CRYSTAL WHEN T> 0 C (Pimlt) +!c + if(temcc(k) .gt. 0.0) pimlt(k)=qiz(k)*odtb +!c +!c (3) PRODUCTION OF CLOUD ICE BY BERGERON PROCESS (Pidw): Hsie (p957) +!c this process only considered when -31 C < T < 0 C +!c + if(temcc(k) .lt. 0.0 .and. temcc(k) .gt. -31.0) then +!c! +!c! parama1 and parama2 functions must be user supplied +!c! + a1=parama1( temcc(k) ) + a2=parama2( temcc(k) ) +!! change unit from cgs to mks + a1=a1*0.001**(1.0-a2) + xnin=xni0*exp(-bni*temcc(k)) + pidw(k)=xnin*orho(k)*(a1*xmnin**a2) + end if +! + pcli(k)=pcli(k)+pihom(k)-pimlt(k)+pidw(k) + pclw(k)=pclw(k)-pihom(k)+pimlt(k)-pidw(k) + qlz(k)=amax1( 0.0,qlz(k)+dtb*(-pihom(k)+pimlt(k)-pidw(k)) ) + qiz(k)=amax1( 0.0,qiz(k)+dtb*(pihom(k)-pimlt(k)+pidw(k)) ) + +! + CALL satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, kts, kte, & + k, xLvocp, xLfocp, episp0k ,EP2,SVP1,SVP2,SVP3,SVPT0) + + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + tem(k)=thz(k)*tothz(k) + + temcc(k)=tem(k)-273.15 + +! qswz(k)=episp0k*oprez(k)* & +! exp( svp2*temcc(k)/(tem(k)-svp3) ) + es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) ) + qswz(k)=ep2*es/(prez(k)-es) + + if (tem(k) .lt. 273.15 ) then +! qsiz(k)=episp0k*oprez(k)* & +! exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + es=1000.*svp1*exp( 21.8745584*(tem(k)-273.16)/(tem(k)-7.66) ) + qsiz(k)=ep2*es/(prez(k)-es) + if (temcc(k) .lt. -40.0) qswz(k)=qsiz(k) + else + qsiz(k)=qswz(k) + endif + qlpqi=qlz(k)+qiz(k) + if ( qlpqi .eq. 0.0 ) then + qvsbar(k)=qsiz(k) + else + qvsbar(k)=( qiz(k)*qsiz(k)+qlz(k)*qswz(k) )/qlpqi + endif + +1800 continue +! +!*********************************************************************** +!********** integrate the productions of rain and snow ********** +!*********************************************************************** +!c + +2000 continue + + +!--------------------------------------------------------------------- + +! +!*********************************************************************** +!****** Write terms in cloud physics to time series dataset ***** +!*********************************************************************** +! +! open(unit=24,form='formatted',status='new', +! & file='cloud.dat') + +!9030 format(10e12.6) + +! write(24,*)'tmp' +! write(24,9030) (tem(k),k=kts+1,kte) +! write(24,*)'qiz' +! write(24,9030) (qiz(k),k=kts+1,kte) +! write(24,*)'qsz' +! write(24,9030) (qsz(k),k=kts+1,kte) +! write(24,*)'qrz' +! write(24,9030) (qrz(k),k=kts+1,kte) +! write(24,*)'qgz' +! write(24,9030) (qgz(k),k=kts+1,kte) +! write(24,*)'qvoqsw' +! write(24,9030) (qvoqswz(k),k=kts+1,kte) +! write(24,*)'qvoqsi' +! write(24,9030) (qvoqsiz(k),k=kts+1,kte) +! write(24,*)'vtr' +! write(24,9030) (vtr(k),k=kts+1,kte) +! write(24,*)'vts' +! write(24,9030) (vts(k),k=kts+1,kte) +! write(24,*)'vtg' +! write(24,9030) (vtg(k),k=kts+1,kte) +! write(24,*)'pclw' +! write(24,9030) (pclw(k),k=kts+1,kte) +! write(24,*)'pvapor' +! write(24,9030) (pvapor(k),k=kts+1,kte) +! write(24,*)'pcli' +! write(24,9030) (pcli(k),k=kts+1,kte) +! write(24,*)'pimlt' +! write(24,9030) (pimlt(k),k=kts+1,kte) +! write(24,*)'pihom' +! write(24,9030) (pihom(k),k=kts+1,kte) +! write(24,*)'pidw' +! write(24,9030) (pidw(k),k=kts+1,kte) +! write(24,*)'prain' +! write(24,9030) (prain(k),k=kts+1,kte) +! write(24,*)'praut' +! write(24,9030) (praut(k),k=kts+1,kte) +! write(24,*)'pracw' +! write(24,9030) (pracw(k),k=kts+1,kte) +! write(24,*)'prevp' +! write(24,9030) (prevp(k),k=kts+1,kte) +! write(24,*)'psnow' +! write(24,9030) (psnow(k),k=kts+1,kte) +! write(24,*)'psaut' +! write(24,9030) (psaut(k),k=kts+1,kte) +! write(24,*)'psfw' +! write(24,9030) (psfw(k),k=kts+1,kte) +! write(24,*)'psfi' +! write(24,9030) (psfi(k),k=kts+1,kte) +! write(24,*)'praci' +! write(24,9030) (praci(k),k=kts+1,kte) +! write(24,*)'piacr' +! write(24,9030) (piacr(k),k=kts+1,kte) +! write(24,*)'psaci' +! write(24,9030) (psaci(k),k=kts+1,kte) +! write(24,*)'psacw' +! write(24,9030) (psacw(k),k=kts+1,kte) +! write(24,*)'psdep' +! write(24,9030) (psdep(k),k=kts+1,kte) +! write(24,*)'pssub' +! write(24,9030) (pssub(k),k=kts+1,kte) +! write(24,*)'pracs' +! write(24,9030) (pracs(k),k=kts+1,kte) +! write(24,*)'psacr' +! write(24,9030) (psacr(k),k=kts+1,kte) +! write(24,*)'psmlt' +! write(24,9030) (psmlt(k),k=kts+1,kte) +! write(24,*)'psmltevp' +! write(24,9030) (psmltevp(k),k=kts+1,kte) +! write(24,*)'pladj' +! write(24,9030) (pladj(k),k=kts+1,kte) +! write(24,*)'piadj' +! write(24,9030) (piadj(k),k=kts+1,kte) +! write(24,*)'pgraupel' +! write(24,9030) (pgraupel(k),k=kts+1,kte) +! write(24,*)'pgaut' +! write(24,9030) (pgaut(k),k=kts+1,kte) +! write(24,*)'pgfr' +! write(24,9030) (pgfr(k),k=kts+1,kte) +! write(24,*)'pgacw' +! write(24,9030) (pgacw(k),k=kts+1,kte) +! write(24,*)'pgaci' +! write(24,9030) (pgaci(k),k=kts+1,kte) +! write(24,*)'pgacr' +! write(24,9030) (pgacr(k),k=kts+1,kte) +! write(24,*)'pgacs' +! write(24,9030) (pgacs(k),k=kts+1,kte) +! write(24,*)'pgacip' +! write(24,9030) (pgacip(k),k=kts+1,kte) +! write(24,*)'pgacrP' +! write(24,9030) (pgacrP(k),k=kts+1,kte) +! write(24,*)'pgacsp' +! write(24,9030) (pgacsp(k),k=kts+1,kte) +! write(24,*)'pgwet' +! write(24,9030) (pgwet(k),k=kts+1,kte) +! write(24,*)'pdry' +! write(24,9030) (pdry(k),k=kts+1,kte) +! write(24,*)'pgsub' +! write(24,9030) (pgsub(k),k=kts+1,kte) +! write(24,*)'pgdep' +! write(24,9030) (pgdep(k),k=kts+1,kte) +! write(24,*)'pgmlt' +! write(24,9030) (pgmlt(k),k=kts+1,kte) +! write(24,*)'pgmltevp' +! write(24,9030) (pgmltevp(k),k=kts+1,kte) + + + +!**** below if qv < qvmin then qv=qvmin, ql=0.0, and qi=0.0 +! + do k=kts+1,kte + if ( qvz(k) .lt. qvmin ) then + qlz(k)=0.0 + qiz(k)=0.0 + qvz(k)=amax1( qvmin,qvz(k)+qlz(k)+qiz(k) ) + end if + enddo +! + END SUBROUTINE clphy1d + + +!--------------------------------------------------------------------- +! SATURATED ADJUSTMENT +!--------------------------------------------------------------------- + SUBROUTINE satadj(qvz, qlz, qiz, prez, theiz, thz, tothz, & + kts, kte, k, xLvocp, xLfocp, episp0k, EP2,SVP1,SVP2,SVP3,SVPT0) +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- +! This program use Newton's method for finding saturated temperature +! and saturation mixing ratio. +! +! In this saturation adjustment scheme we assume +! (1) the saturation mixing ratio is the mass weighted average of +! saturation values over liquid water (qsw), and ice (qsi) +! following Lord et al., 1984 and Tao, 1989 +! +! (2) the percentage of cloud liquid and cloud ice will +! be fixed during the saturation calculation +!--------------------------------------------------------------------- +! + + INTEGER, INTENT(IN ) :: kts, kte, k + + REAL, DIMENSION( kts:kte ), & + INTENT(INOUT) :: qvz, qlz, qiz +! + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: prez, theiz, tothz + + REAL, INTENT(IN ) :: xLvocp, xLfocp, episp0k + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + +! LOCAL VARS + + INTEGER :: n + + REAL, DIMENSION( kts:kte ) :: thz, tem, temcc, qsiz, & + qswz, qvsbar + + REAL :: qsat, qlpqi, ratql, t0, t1, tmp1, ratqi, tsat, absft, & + denom1, denom2, dqvsbar, ftsat, dftsat, qpz, & + gindex, es +! +!--------------------------------------------------------------------- + + thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k) + + tem(k)=tothz(k)*thz(k) + if (tem(k) .gt. 273.15) then +! qsat=episp0k/prez(k)* & +! exp( svp2*(tem(k)-273.15)/(tem(k)-svp3) ) + es=1000.*svp1*exp( svp2*(tem(k)-svpt0)/(tem(k)-svp3) ) + qsat=ep2*es/(prez(k)-es) + else + qsat=episp0k/prez(k)* & + exp( 21.8745584*(tem(k)-273.15)/(tem(k)-7.66) ) + end if + qpz=qvz(k)+qlz(k)+qiz(k) + if (qpz .lt. qsat) then + qvz(k)=qpz + qiz(k)=0.0 + qlz(k)=0.0 + go to 400 + end if + qlpqi=qlz(k)+qiz(k) + if( qlpqi .ge. 1.0e-5) then + ratql=qlz(k)/qlpqi + ratqi=qiz(k)/qlpqi + else + t0=273.15 +! t1=233.15 + t1=248.15 + tmp1=( t0-tem(k) )/(t0-t1) + tmp1=amin1(1.0,tmp1) + tmp1=amax1(0.0,tmp1) + ratqi=tmp1 + ratql=1.0-tmp1 + end if +! +! +!-- saturation mixing ratios over water and ice +!-- at the outset we will follow Bolton 1980 MWR for +!-- the water and Murray JAS 1967 for the ice +! +!-- dqvsbar=d(qvsbar)/dT +!-- ftsat=F(Tsat) +!-- dftsat=d(F(T))/dT +! +! First guess of tsat + + tsat=tem(k) + absft=1.0 +! + do 200 n=1,20 + denom1=1.0/(tsat-svp3) + denom2=1.0/(tsat-7.66) +! qswz(k)=episp0k/prez(k)* & +! exp( svp2*denom1*(tsat-273.15) ) + es=1000.*svp1*exp( svp2*denom1*(tsat-svpt0) ) + qswz(k)=ep2*es/(prez(k)-es) + if (tem(k) .lt. 273.15) then +! qsiz(k)=episp0k/prez(k)* & +! exp( 21.8745584*denom2*(tsat-273.15) ) + es=1000.*svp1*exp( 21.8745584*denom2*(tsat-273.15) ) + qsiz(k)=ep2*es/(prez(k)-es) + if (tem(k) .lt. 233.15) qswz(k)=qsiz(k) + else + qsiz(k)=qswz(k) + endif + qvsbar(k)=ratql*qswz(k)+ratqi*qsiz(k) +! +! if( absft .lt. 0.01 .and. n .gt. 3 ) go to 300 + if( absft .lt. 0.01 ) go to 300 +! + dqvsbar=ratql*qswz(k)*svp2*243.5*denom1*denom1+ & + ratqi*qsiz(k)*21.8745584*265.5*denom2*denom2 + ftsat=tsat+(xlvocp+ratqi*xlfocp)*qvsbar(k)- & + tothz(k)*theiz(k)-xlfocp*ratqi*(qvz(k)+qlz(k)+qiz(k)) + dftsat=1.0+(xlvocp+ratqi*xlfocp)*dqvsbar + tsat=tsat-ftsat/dftsat + absft=abs(ftsat) + +200 continue +9020 format(1x,'point can not converge, absft,n=',e12.5,i5) +! +300 continue + if( qpz .gt. qvsbar(k) ) then + qvz(k)=qvsbar(k) + qiz(k)=ratqi*( qpz-qvz(k) ) + qlz(k)=ratql*( qpz-qvz(k) ) + else + qvz(k)=qpz + qiz(k)=0.0 + qlz(k)=0.0 + end if + 400 continue + + END SUBROUTINE satadj + + +!---------------------------------------------------------------- + REAL FUNCTION parama1(temp) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +! This program calculate the parameter for crystal growth rate +! in Bergeron process +!---------------------------------------------------------------- + + REAL, INTENT (IN ) :: temp + REAL, DIMENSION(32) :: a1 + INTEGER :: i1, i1p1 + REAL :: ratio + + data a1/0.100e-10,0.7939e-7,0.7841e-6,0.3369e-5,0.4336e-5, & + 0.5285e-5,0.3728e-5,0.1852e-5,0.2991e-6,0.4248e-6, & + 0.7434e-6,0.1812e-5,0.4394e-5,0.9145e-5,0.1725e-4, & + 0.3348e-4,0.1725e-4,0.9175e-5,0.4412e-5,0.2252e-5, & + 0.9115e-6,0.4876e-6,0.3473e-6,0.4758e-6,0.6306e-6, & + 0.8573e-6,0.7868e-6,0.7192e-6,0.6513e-6,0.5956e-6, & + 0.5333e-6,0.4834e-6/ + + i1=int(-temp)+1 + i1p1=i1+1 + ratio=-(temp)-float(i1-1) + parama1=a1(i1)+ratio*( a1(i1p1)-a1(i1) ) + + END FUNCTION parama1 + +!---------------------------------------------------------------- + REAL FUNCTION parama2(temp) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +! This program calculate the parameter for crystal growth rate +! in Bergeron process +!---------------------------------------------------------------- + + REAL, INTENT (IN ) :: temp + REAL, DIMENSION(32) :: a2 + INTEGER :: i1, i1p1 + REAL :: ratio + + data a2/0.0100,0.4006,0.4831,0.5320,0.5307,0.5319,0.5249, & + 0.4888,0.3849,0.4047,0.4318,0.4771,0.5183,0.5463, & + 0.5651,0.5813,0.5655,0.5478,0.5203,0.4906,0.4447, & + 0.4126,0.3960,0.4149,0.4320,0.4506,0.4483,0.4460, & + 0.4433,0.4413,0.4382,0.4361/ + i1=int(-temp)+1 + i1p1=i1+1 + ratio=-(temp)-float(i1-1) + parama2=a2(i1)+ratio*( a2(i1p1)-a2(i1) ) + + END FUNCTION parama2 + +!---------------------------------------------------------------- + REAL FUNCTION ggamma(X) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- + REAL, INTENT(IN ) :: x + REAL, DIMENSION(8) :: B + INTEGER ::j, K1 + REAL ::PF, G1TO2 ,TEMP + + DATA B/-.577191652,.988205891,-.897056937,.918206857, & + -.756704078,.482199394,-.193527818,.035868343/ + + PF=1. + TEMP=X + DO 10 J=1,200 + IF (TEMP .LE. 2) GO TO 20 + TEMP=TEMP-1. + 10 PF=PF*TEMP + 100 FORMAT(//,5X,'module_mp_lin: INPUT TO GAMMA FUNCTION TOO LARGE, X=',E12.5) + WRITE(wrf_err_message,100)X + CALL wrf_error_fatal(wrf_err_message) + 20 G1TO2=1. + TEMP=TEMP - 1. + DO 30 K1=1,8 + 30 G1TO2=G1TO2 + B(K1)*TEMP**K1 + ggamma=PF*G1TO2 + + END FUNCTION ggamma + +!---------------------------------------------------------------- + +END MODULE module_mp_lin + diff --git a/wrfv2_fire/phys/module_mp_ncloud3.F b/wrfv2_fire/phys/module_mp_ncloud3.F new file mode 100755 index 00000000..8ec0f032 --- /dev/null +++ b/wrfv2_fire/phys/module_mp_ncloud3.F @@ -0,0 +1,830 @@ +MODULE module_mp_ncloud3 + + REAL, PARAMETER, PRIVATE :: dtcldcr = 240. + INTEGER, PARAMETER, PRIVATE :: mstepmax = 100 + + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 + REAL, PARAMETER, PRIVATE :: avtr = 841.9 + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + + REAL, PARAMETER, PRIVATE :: avts = 16.2 + REAL, PARAMETER, PRIVATE :: bvts = .527 + REAL, PARAMETER, PRIVATE :: xncmax = 1.e8 + REAL, PARAMETER, PRIVATE :: n0smax = 1.e9 + REAL, PARAMETER, PRIVATE :: betai = .6 + REAL, PARAMETER, PRIVATE :: xn0 = 1.e-2 + REAL, PARAMETER, PRIVATE :: dicon = 16.3 + REAL, PARAMETER, PRIVATE :: di0 = 12.9e-6*.8 + REAL, PARAMETER, PRIVATE :: dimax = 400.e-6 + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent n0s + REAL, PARAMETER, PRIVATE :: alpha = 1./8.18 ! .122 exponen factor for n0s +! REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e15 + REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e5 + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-6 + + REAL, SAVE :: & + qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr,& + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + precr1,precr2,xm0,xmmax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r,& + pidn0s,xlv1 + +CONTAINS + +!=================================================================== +! + SUBROUTINE ncloud3(th, q, qci, qrs & + , w, den, pii, p, delz & + , delt,g, cpd, cpv, rd, rv, t0c & + , ep1, ep2, qmin & + , XLS, XLV0, XLF0, den0, denr & + , cliq,cice,psat & + , rain, rainncv & + , ids,ide, jds,jde, kds,kde & + , ims,ime, jms,jme, kms,kme & + , its,ite, jts,jte, kts,kte & + ) + +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +!Coded by Song-You Hong (NCEP) and implemented by Shuhua Chen (NCAR) +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qci, & + qrs + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: w, & + den, & + pii, & + p, & + delz + + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + T0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv + +! LOCAL VAR + + REAL, DIMENSION( its:ite , kts:kte ) :: t + INTEGER :: i,j,k + +!------------------------------------------------------------------- + DO J=jts,jte + + DO K=kts,kte + DO I=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + ENDDO + ENDDO + + CALL ncloud32D(t, q(ims,kms,j), qci(ims,kms,j) & + ,qrs(ims,kms,j),w(ims,kms,j), den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + , delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,J & + ,rain(ims,j), rainncv(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) + + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + ENDDO + ENDDO + + ENDDO + + END SUBROUTINE ncloud3 + +!=================================================================== +! + SUBROUTINE ncloud32D(t, q, qci, qrs,w, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain, rainncv & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte, & + lat + + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q, & + qci, & + qrs + + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: w, & + den, & + p, & + delz + + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + T0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv + +! LOCAL VAR + + INTEGER, PARAMETER :: iun = 84 + + REAL, DIMENSION( its:ite , kts:kte ) :: & + rh, qs, denfac, slope, slope2, slopeb, & + pgen, paut, pacr, pisd, pres, pcon, fall, falk, & + xl, cpm, work1, work2, q1, t1, & + pgens, pauts, pacrss, pisds, press, pcons + + REAL, DIMENSION( its:ite , kts:kte ) :: & + falkc, work1c, work2c, fallc + + INTEGER, DIMENSION( its:ite ) :: mstep + LOGICAL, DIMENSION( its:ite ) :: flgcld + + REAL :: n0sfac, pi, & + cpmcal, xlcal, tvcal, lamdar, lamdas, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, pvt, qik, delq, facq, qrsci, frzmlt, & + snomlt, hold, holdrs, facqci, supcol, coeres, & + supsat, dtcld, xmi, qciik, delqci, eacrs, satdt, xnc + + INTEGER :: i,j,k, & + iprt, latd, lond, loop, loops, ifsat, kk, n, numdt + +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) + tvcal(x,y) = x+x*ep1*max(y,qmin) +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-30 kg/kg. +! otherwise use uniform distribution value (1.e15) +! + lamdar(x,y)=(pidn0r/(x*y))**.25 + lamdas(x,y,z)=(pidn0s*z/(x*y))**.25 +! +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! + diffus(x,y) = 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & + /viscos(b,c)**(.5)*(den0/c)**0.25 + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! + pi = 4. * atan(1.) +! +!================================================================= +! set iprt = 0 for no unit fort.84 output +! +! iprt = 0 +! if(iprt.eq.1) then +! qdt = delt * 1000. +! latd = jts +! lond = its +! else +! latd = 0 +! lond = 0 +! endif +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k) = max(qci(i,k),0.0) + qrs(i,k) = max(qrs(i,k),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! + do k = kts, kte + do i = its, ite + work1(i,k) = tvcal(t(i,k),q(i,k)) + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + qs(i,k) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + rh(i,k) = max(q(i,k) / qs(i,k),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! if(lat.eq.latd) then +! i = lond +! print*,'lat',latd,lat,i + +! do k = kts, kte +! press(i,k) = 0. +! pauts(i,k) = 0. +! pacrss(i,k)= 0. +! pgens(i,k) = 0. +! pisds(i,k) = 0. +! pcons(i,k) = 0. +! t1(i,k) = t(i,k) +! q1(i,k) = q(i,k) +! enddo +! endif +! + do k = kts, kte + do i = its, ite + pres(i,k) = 0. + paut(i,k) = 0. + pacr(i,k) = 0. + pgen(i,k) = 0. + pisd(i,k) = 0. + pcon(i,k) = 0. + fall(i,k) = 0. + falk(i,k) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + enddo + enddo +! +!---------------------------------------------------------------- +! sloper: the slope parameter of the rain(m-1) +! xka: thermal conductivity of air(jm-1s-1k-1) +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + slope(i,k) = lamdarmax + slopeb(i,k) = slope(i,k)**bvtr + else + if(t(i,k).ge.t0c) then + slope(i,k) = lamdar(qrs(i,k),den(i,k)) + slopeb(i,k) = slope(i,k)**bvtr + else + supcol = t0c-t(i,k) + n0sfac = min(exp(alpha*supcol),n0smax) + slope(i,k) = lamdas(qrs(i,k),den(i,k),n0sfac) + slopeb(i,k) = slope(i,k)**bvts + endif + endif + slope2(i,k) = slope(i,k)*slope(i,k) + enddo + enddo +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k)) + else + work1(i,k) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k)) + endif + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k) + satdt = supsat/dtcld + if(t(i,k).ge.t0c) then +! +!---------------------------------------------------------------- +! warm rain process +! paut: auto conversion rate from cloud to rain (kgkg-1s-1)(kessler) +! pacr: accretion rate of rain by cloud(lin83) +! pres: evaporation/condensation rate of rain(rh83) +! + if(qci(i,k).gt.qc0) then + paut(i,k) = qck1*qci(i,k)**(7./3.) + paut(i,k) = min(paut(i,k),qci(i,k)/dtcld) + endif +! + if(qrs(i,k).gt.qcrmin) then + if(qci(i,k).gt.qcrmin) & + pacr(i,k) = min(pacrr/slope2(i,k)/slope(i,k)/slopeb(i,k) & + *qci(i,k)*denfac(i,k),qci(i,k)/dtcld) + coeres = slope2(i,k)*sqrt(slope(i,k)*slopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*(precr1/slope2(i,k) & + +precr2*work2(i,k)/coeres)/work1(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(pres(i,k),satdt/2) + else + pres(i,k) = min(pres(i,k),qrs(i,k)/dtcld) + pres(i,k) = min(pres(i,k),satdt/2) + endif + endif + else +! +!---------------------------------------------------------------- +! cold rain process +! paut: conversion(aggregation) of ice to snow(kgkg-1s-1)(rh83) +! pgen: generation(nucleation) of ice from vapor(kgkg-1s-1)(rh83) +! pacr: accretion rate of snow by ice(lin83) +! pisd: deposition/sublimation rate of ice(rh83) +! pres: deposition/sublimation rate of snow(lin83) +! + supcol = t0c-t(i,k) + ifsat = 0 + n0sfac = min(exp(alpha*supcol),n0smax) + xnc = min(xn0 * exp(betai*supcol)/den(i,k),xncmax) +! + if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qcrmin) then + eacrs = exp(0.025*(-supcol)) + pacr(i,k) = pacrs*n0sfac*eacrs/slope2(i,k)/slope(i,k) & + /slopeb(i,k)*qci(i,k)*denfac(i,k) + endif +! + if(qci(i,k).gt.qcrmin) then + xmi = qci(i,k)*xnc + pisd(i,k) = 4.*dicon*sqrt(xmi)*den(i,k)*(rh(i,k)-1.) & + /work1(i,k) + if(pisd(i,k).lt.0.) then + pisd(i,k) = max(pisd(i,k),satdt/2) + pisd(i,k) = max(pisd(i,k),-qci(i,k)/dtcld) + else + pisd(i,k) = min(pisd(i,k),satdt/2) + endif + if(abs(pisd(i,k)).ge.abs(satdt)) ifsat = 1 + endif +! + if(qrs(i,k).gt.qcrmin.and.ifsat.ne.1) then + coeres = slope2(i,k)*sqrt(slope(i,k)*slopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*n0sfac*(precs1/slope2(i,k) & + +precs2*work2(i,k)/coeres)/work1(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(pres(i,k),satdt/2) + else + pres(i,k) = min(pres(i,k),satdt/2) + pres(i,k) = min(pres(i,k),qrs(i,k)/dtcld) + endif + if(abs(pisd(i,k)+pres(i,k)).ge.abs(satdt)) ifsat = 1 + endif +! + if(supsat.gt.0.and.ifsat.ne.1) then + pgen(i,k) = max(0.,(xm0*xnc-max(qci(i,k),0.))/dtcld) + pgen(i,k) = min(pgen(i,k),satdt) + endif +! + if(qci(i,k).gt.qcrmin) paut(i,k) & + = max(0.,(qci(i,k)-xmmax*xnc)/dtcld) + endif + enddo + enddo +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite + qciik = max(qcrmin,qci(i,k)) + delqci = (paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k))*dtcld + if(delqci.ge.qciik) then + facqci = qciik/delqci + paut(i,k) = paut(i,k)*facqci + pacr(i,k) = pacr(i,k)*facqci + pgen(i,k) = pgen(i,k)*facqci + pisd(i,k) = pisd(i,k)*facqci + endif + qik = max(qcrmin,q(i,k)) + delq = (pres(i,k)+pgen(i,k)+pisd(i,k))*dtcld + if(delq.ge.qik) then + facq = qik/delq + pres(i,k) = pres(i,k)*facq + pgen(i,k) = pgen(i,k)*facq + pisd(i,k) = pisd(i,k)*facq + endif + work2(i,k) = -pres(i,k)-pgen(i,k)-pisd(i,k) + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k) = max(qci(i,k)-(paut(i,k)+pacr(i,k)-pgen(i,k) & + -pisd(i,k))*dtcld,0.) + qrs(i,k) = max(qrs(i,k)+(paut(i,k)+pacr(i,k) & + +pres(i,k))*dtcld,0.) + if(t(i,k).lt.t0c) then + t(i,k) = t(i,k)-xls*work2(i,k)/cpm(i,k)*dtcld + else + t(i,k) = t(i,k)-xl(i,k)*work2(i,k)/cpm(i,k)*dtcld + endif + enddo + enddo +! + do k = kts, kte + do i = its, ite + qs(i,k) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! condensational/evaporational rate of cloud water if there exists +! additional water vapor condensated/if evaporation of cloud water +! is not enough to remove subsaturation. +! use fall bariable for this process(pcon) +! +! if(lat.eq.latd) write(iun,603) + do k = kts, kte + do i = its, ite + work1(i,k) = conden(t(i,k),q(i,k),qs(i,k),xl(i,k),cpm(i,k)) + work2(i,k) = qci(i,k)+work1(i,k) + pcon(i,k) = min(max(work1(i,k),0.),max(q(i,k),0.))/dtcld + if(qci(i,k).gt.qcrmin.and.work1(i,k).lt.0.and.t(i,k).gt.t0c) & + pcon(i,k) = max(work1(i,k),-qci(i,k))/dtcld + q(i,k) = q(i,k)-pcon(i,k)*dtcld + qci(i,k) = max(qci(i,k)+pcon(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld + +! +! if(lat.eq.latd.and.i.eq.lond) then +! pgens(i,k) = pgens(i,k)+pgen(i,k) +! pcons(i,k) = pcons(i,k)+pcon(i,k) +! pisds(i,k) = pisds(i,k)+pisd(i,k) +! pacrss(i,k) = pacrss(i,k)+pacr(i,k) +! press(i,k) = press(i,k)+pres(i,k) +! pauts(i,k) = pauts(i,k)+paut(i,k) +! write(iun,604) k,p(i,k)/100., & +! t(i,k)-t0c,t(i,k)-t1(i,k),q(i,k)*1000., & +! (q(i,k)-q1(i,k))*1000.,rh(i,k)*100.,pgens(i,k)*qdt, & +! pcons(i,k)*qdt,pisds(i,k)*qdt,pauts(i,k)*qdt,pacrss(i,k)*qdt, & +! press(i,k)*qdt,qci(i,k)*1000.,qrs(i,k)*1000. +! endif + + enddo + enddo +603 format(1x,' k',' p', & + ' t',' delt',' q',' delq',' rh', & + ' pgen',' pcon',' pisd',' paut',' pacr',' pres', & + ' qci',' qrs') +604 format(1x,i3,f6.0,4f5.1,f5.0,8f5.2) +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +! + do k = kts, kte + do i = its, ite + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + slope(i,k) = lamdarmax + slopeb(i,k) = slope(i,k)**bvtr + else + if(t(i,k).ge.t0c) then + slope(i,k) = lamdar(qrs(i,k),den(i,k)) + slopeb(i,k) = slope(i,k)**bvtr + else + supcol = t0c-t(i,k) + n0sfac = min(exp(alpha*supcol),n0smax) + slope(i,k) = lamdas(qrs(i,k),den(i,k),n0sfac) + slopeb(i,k) = slope(i,k)**bvts + endif + endif + slope2(i,k) = slope(i,k)*slope(i,k) + enddo + enddo +! + do i = its, ite + do k = kte, kts, -1 + if(t(i,k).lt.t0c) then + pvt = pvts + else + pvt = pvtr + endif + work1(i,k) = pvt/slopeb(i,k)*denfac(i,k) + work2(i,k) = work1(i,k)/delz(i,k) + if(qrs(i,k).le.qcrmin) work2(i,k) = 0. + numdt = max(nint(work2(i,k)*dtcld+.5),1) + if(t(i,k).lt.t0c.and.qci(i,k).gt.qmin) then + work1c(i,k) = 3.29*(den(i,k)*qci(i,k))**0.16 + else + work1c(i,k) = 0. + endif + if(qci(i,k).le.qmin) then + work2c(i,k) = 0. + else + work2c(i,k) = work1c(i,k)/delz(i,k) + endif + numdt = max(nint(work2c(i,k)*dtcld+.5),numdt) + if(numdt.ge.mstep(i)) mstep(i) = numdt + enddo + mstep(i) = min(mstep(i),mstepmax) + enddo +! +! if(lat.eq.latd) write(iun,605) + do n = 1,mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) + hold = falk(i,k) + fall(i,k) = fall(i,k)+falk(i,k) + holdrs = qrs(i,k) + qrs(i,k) = max(qrs(i,k)-falk(i,k)*dtcld/den(i,k),0.) + falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) + fallc(i,k) = fallc(i,k)+falkc(i,k) + qci(i,k) = max(qci(i,k)-falkc(i,k)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) + hold = falk(i,k) + fall(i,k) = fall(i,k)+falk(i,k) + holdrs = qrs(i,k) + qrs(i,k) = max(qrs(i,k)-(falk(i,k) & + -falk(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) + fallc(i,k) = fallc(i,k)+falkc(i,k) + qci(i,k) = max(qci(i,k)-(falkc(i,k) & + -falkc(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + enddo +605 format(1x,' k',' p',' t',' q',' rh',' w', & + ' vt',' falk',' falt',' qrsi',' qrsf',' mstep') +606 format(1x,i3,f6.0,2f5.1,f5.0,f6.2,5f6.2,i5) +! +!---------------------------------------------------------------- +! compute the freezing/melting term. +! freezing occurs one layer above the melting level +! + do i = its, ite + mstep(i) = 0 + enddo + do k = kts, kte +! + do i = its, ite + if(t(i,k).ge.t0c) then + mstep(i) = k + endif + enddo + enddo +! + do i = its, ite + if(mstep(i).ne.0.and.w(i,mstep(i)).gt.0.) then + work1(i,1) = float(mstep(i) + 1) + work1(i,2) = float(mstep(i)) + else + work1(i,1) = float(mstep(i)) + work1(i,2) = float(mstep(i)) + endif + enddo +! + do i = its, ite + k = nint(work1(i,1)) + kk = nint(work1(i,2)) + if(k*kk.ge.1) then + qrsci = qrs(i,k) + qci(i,k) + if(qrsci.gt.qcrmin.or.fall(i,kk).gt.0.) then + frzmlt = min(max(-w(i,k)*qrsci/delz(i,k),-qrsci/dtcld), & + qrsci/dtcld) + snomlt = min(max(fall(i,kk)/den(i,kk),-qrs(i,k)/dtcld),qrs(i,k)/dtcld) + if(k.eq.kk) then + t(i,k) = t(i,k) - xlf0/cpm(i,k)*(frzmlt+snomlt)*dtcld + else + t(i,k) = t(i,k) - xlf0/cpm(i,k)*frzmlt*dtcld + t(i,kk) = t(i,kk) - xlf0/cpm(i,kk)*snomlt*dtcld + endif + +! if(lat.eq.latd.and.i.eq.lond) write(iun,608) k,t(i,k)-t0c, & +! w(i,k),frzmlt*qdt,snomlt*qdt + + endif + endif + enddo + 608 format(1x,'k = ',i3,' t = ',f5.1,' w = ',f6.2,' frz/mlt = ',f5.1, & + ' snomlt = ',f5.1) +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + if(fall(i,1).gt.0.) then + rainncv(i) = fall(i,1)*delz(i,1)/denr*dtcld*1000. + rain(i) = fall(i,1)*delz(i,1)/denr*dtcld*1000. & + + rain(i) + endif + enddo +! +! if(lat.eq.latd) write(iun,601) latd,lond,loop,rain(lond) + 601 format(1x,' ncloud3 lat lon loop : rain(mm) ',3i6,f20.2) +! + enddo ! big loops + + END SUBROUTINE ncloud32D +! ................................................................... + real function rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + parameter (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + END FUNCTION rgmma +! +!-------------------------------------------------------------------------- + real function fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + real t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs + +!------------------------------------------------------------------- + SUBROUTINE ncloud3init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + + REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + LOGICAL,INTENT(IN) :: allowed_to_read + REAL :: pi + + pi = 4.*atan(1.) + xlv1 = cl-cpv + + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu ! 7.03 + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xm0 = (di0/dicon)**2 + xmmax = (dimax/dicon)**2 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + END SUBROUTINE ncloud3init + +END MODULE module_mp_ncloud3 + diff --git a/wrfv2_fire/phys/module_mp_ncloud5.F b/wrfv2_fire/phys/module_mp_ncloud5.F new file mode 100755 index 00000000..0f7716dc --- /dev/null +++ b/wrfv2_fire/phys/module_mp_ncloud5.F @@ -0,0 +1,945 @@ +MODULE module_mp_ncloud5 + + REAL, PARAMETER, PRIVATE :: dtcldcr = 240. + INTEGER, PARAMETER, PRIVATE :: mstepmax = 100 + + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 + REAL, PARAMETER, PRIVATE :: avtr = 841.9 + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + + REAL, PARAMETER, PRIVATE :: avts = 16.2 + REAL, PARAMETER, PRIVATE :: bvts = .527 + REAL, PARAMETER, PRIVATE :: xncmax = 1.e8 + REAL, PARAMETER, PRIVATE :: n0smax = 1.e9 + REAL, PARAMETER, PRIVATE :: betai = .6 + REAL, PARAMETER, PRIVATE :: xn0 = 1.e-2 + REAL, PARAMETER, PRIVATE :: dicon = 16.3 + REAL, PARAMETER, PRIVATE :: di0 = 12.9e-6*.8 + REAL, PARAMETER, PRIVATE :: dimax = 400.e-6 + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent n0s + REAL, PARAMETER, PRIVATE :: alpha = 1./8.18 ! .122 exponen factor for n0s + REAL, PARAMETER, PRIVATE :: pfrz1 = 100. + REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 +! REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e15 + REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e5 + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-6 + + REAL, PARAMETER, PRIVATE :: t40c = 233.16 + REAL, PARAMETER, PRIVATE :: eacrc = 1.0 + + REAL, SAVE :: & + qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr,& + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + precr1,precr2,xm0,xmmax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r,& + pidn0s,xlv1,pacrc + +CONTAINS + +!=================================================================== +! + SUBROUTINE ncloud5(th, q, qc, qr, qi, qs & + ,w, den, pii, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,rain, rainncv & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +!Coded by Song-You Hong (NCEP) and implemented by Shuhua Chen (NCAR) +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qc, & + qi, & + qr, & + qs + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: w, & + den, & + pii, & + p, & + delz + + + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + t0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + xls, & + xlv0, & + xlf0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv + +! LOCAL VAR + + REAL, DIMENSION( its:ite , kts:kte ) :: t + REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs + INTEGER :: i,j,k + +!------------------------------------------------------------------- + DO J=jts,jte + + DO k=kts,kte + DO i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + qci(i,k,1) = qc(i,k,j) + qci(i,k,2) = qi(i,k,j) + qrs(i,k,1) = qr(i,k,j) + qrs(i,k,2) = qs(i,k,j) + ENDDO + ENDDO + + CALL ncloud52D(t, q(ims,kms,j), qci, qrs & + ,w(ims,kms,j), den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,j & + ,rain(ims,j),rainncv(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) + + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + qc(i,k,j) = qci(i,k,1) + qi(i,k,j) = qci(i,k,2) + qr(i,k,j) = qrs(i,k,1) + qs(i,k,j) = qrs(i,k,2) + ENDDO + ENDDO + + ENDDO + + END SUBROUTINE ncloud5 + +!=================================================================== +! + SUBROUTINE ncloud52D(t, q, qci, qrs,w, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain,rainncv & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte, & + lat + + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( its:ite , kts:kte, 2 ), & + INTENT(INOUT) :: & + qci, qrs + + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q + + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: p, & + w, & + den, & + delz + + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + xls, & + xlv0, & + xlf0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv + +! LOCAL VAR + + INTEGER, PARAMETER :: iun = 84 + + REAL, DIMENSION( its:ite , kts:kte , 2) :: & + rh, qs, slope, slope2, slopeb, & + paut, pres, falk, fall, work1 + REAL, DIMENSION( its:ite , kts:kte ) :: & + falkc, work1c, work2c, fallc + REAL, DIMENSION( its:ite , kts:kte, 3 ) :: & + pacr + REAL, DIMENSION( its:ite , kts:kte ) :: & + pgen, pisd, pcon, xl, cpm, work2, q1, t1, denfac, & + pgens, pauts, pacrss, pisds, press, pcons, psml, psev + + INTEGER, DIMENSION( its:ite ) :: mstep + LOGICAL, DIMENSION( its:ite ) :: flgcld + + REAL :: n0sfac, pi, & + cpmcal, xlcal, lamdar, lamdas, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, holdrr, holdrs, supcol, & + coeres, supsat, dtcld, xmi, eacrs, satdt, xnc, & + fallsum, xlwork2, factor, source, value, & + xlf,pfrzdtc,pfrzdtr + + INTEGER :: i,j,k, & + iprt, latd, lond, loop, loops, ifsat, n, numdt + +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +! tvcal(x,y) = x+x*ep1*max(y,qmin) +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-30 kg/kg. +! otherwise use uniform distribution value (1.e15) +! + lamdar(x,y)=(pidn0r/(x*y))**.25 + lamdas(x,y,z)=(pidn0s*z/(x*y))**.25 +! +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! + diffus(x,y) = 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & + /viscos(b,c)**(.5)*(den0/c)**0.25 + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! + pi = 4. * atan(1.) +! +!================================================================= +! set iprt = 0 for no unit fort.84 output +! + iprt = 1 + if(iprt.eq.1) then + qdt = delt * 1000. + latd = (jte+jts)/2 + 1 + lond = (ite+its)/2 + 1 + else + latd = jts + lond = its + endif +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k,1) = max(qci(i,k,1),0.0) + qrs(i,k,1) = max(qrs(i,k,1),0.0) + qci(i,k,2) = max(qci(i,k,2),0.0) + qrs(i,k,2) = max(qrs(i,k,2),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo + if(lat.eq.latd) then + i = lond + do k = kts, kte + press(i,k) = 0. + pauts(i,k) = 0. + pacrss(i,k)= 0. + pgens(i,k) = 0. + pisds(i,k) = 0. + pcons(i,k) = 0. + t1(i,k) = t(i,k) + q1(i,k) = q(i,k) + enddo + endif +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! + do k = kts, kte + do i = its, ite + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) + qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) +! if(lat.eq.latd.and.i.eq.lond) write(iun,700) qci(i,k,1)*1000., & +! qrs(i,k,1)*1000.,qci(i,k,2)*1000.,qrs(i,k,2)*1000. +!700 format(1x,'before computation', 4f10.4) + enddo + enddo +! +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + pres(i,k,1) = 0. + pres(i,k,2) = 0. + paut(i,k,1) = 0. + paut(i,k,2) = 0. + pacr(i,k,1) = 0. + pacr(i,k,2) = 0. + pacr(i,k,3) = 0. + pgen(i,k) = 0. + pisd(i,k) = 0. + pcon(i,k) = 0. + psml(i,k) = 0. + psev(i,k) = 0. + falk(i,k,1) = 0. + falk(i,k,2) = 0. + fall(i,k,1) = 0. + fall(i,k,2) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + enddo + enddo +! +!---------------------------------------------------------------- +! sloper: the slope parameter of the rain(m-1) +! xka: thermal conductivity of air(jm-1s-1k-1) +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k,1).le.qcrmin)then + slope(i,k,1) = lamdarmax + slopeb(i,k,1) = slope(i,k,1)**bvtr + else + slope(i,k,1) = lamdar(qrs(i,k,1),den(i,k)) + slopeb(i,k,1) = slope(i,k,1)**bvtr + endif + if(qrs(i,k,2).le.qcrmin)then + slope(i,k,2) = lamdarmax + slopeb(i,k,2) = slope(i,k,2)**bvts + else + supcol = t0c-t(i,k) + n0sfac = min(exp(alpha*supcol),n0smax) + slope(i,k,2) = lamdas(qrs(i,k,2),den(i,k),n0sfac) + slopeb(i,k,2) = slope(i,k,2)**bvts + endif + slope2(i,k,1) = slope(i,k,1)*slope(i,k,1) + slope2(i,k,2) = slope(i,k,2)*slope(i,k,2) + enddo + enddo +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) + work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! +! instantaneous melting of cloud ice +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + xlf = xls-xl(i,k) + if(supcol.lt.0..and.qci(i,k,2).gt.qcrmin) then + qci(i,k,1) = qci(i,k,1) + qci(i,k,2) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) + qci(i,k,2) = 0. +! if(lat.eq.latd.and.i.eq.lond) write(iun,607) k,-supcol, & +! qci(i,k,2)*1000.,xlf/cpm(i,k)*qci(i,k,2) + endif +!607 format(1x,'k = ',i3,' t = ',f5.1,' qi melting = ',f10.6, & +! ' del t = ',f10.6) +! +! homogeneous freezing of cloud water below -40c +! + if(supcol.gt.40..and.qci(i,k,1).gt.qcrmin) then + qci(i,k,2) = qci(i,k,2) + qci(i,k,1) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) + qci(i,k,1) = 0. +! if(lat.eq.latd.and.i.eq.lond) write(iun,608) k,-supcol, & +! qci(i,k,1)*1000.,xlf/cpm(i,k)*qci(i,k,1) + endif +!608 format(1x,'k = ',i3,' t = ',f5.1,' qc home freezing = ',f10.6, & +! ' del t = ',f10.6) +! +! heterogeneous freezing of cloud water +! + if(supcol.gt.0..and.qci(i,k,1).gt.qcrmin) then + pfrzdtc = min(pfrz1*exp(pfrz2*supcol-1.) & + *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) + qci(i,k,2) = qci(i,k,2) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qci(i,k,1) = qci(i,k,1)-pfrzdtc +! if(lat.eq.latd.and.i.eq.lond) write(iun,609) k,-supcol, & +! pfrzdtc*1000.,xlf/cpm(i,k)*pfrzdtc + endif +!609 format(1x,'k = ',i3,' t = ',f5.1,' qc hete freezing = ',f10.6, & +! ' del t = ',f10.6) +! +! freezing of rain water +! + if(supcol.gt.0..and.qrs(i,k,1).gt.qcrmin) then + pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & + *exp(pfrz2*supcol-1.)*slope(i,k,1)**(-7)*dtcld, & + qrs(i,k,1)) + qrs(i,k,2) = qrs(i,k,2) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qrs(i,k,1) = qrs(i,k,1)-pfrzdtr +! if(lat.eq.latd.and.i.eq.lond) write(iun,610) k,-supcol, & +! pfrzdtr*1000.,xlf/cpm(i,k)*pfrzdtr +!610 format(1x,'k = ',i3,' t = ',f5.1,' qr freezing = ',f10.6, & +! ' del t = ',f10.6) + endif + enddo + enddo +! +! warm rain process +! paut: auto conversion rate from cloud to rain (kgkg-1s-1) +! pacr: accretion rate of rain by cloud(lin83) +! pres: evaporation/condensation rate of rain(rh83) +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k,1) + satdt = supsat/dtcld + if(qci(i,k,1).gt.qc0) then + paut(i,k,1) = qck1*qci(i,k,1)**(7./3.) + paut(i,k,1) = min(paut(i,k,1),qci(i,k,1)/dtcld) + endif + if(qrs(i,k,1).gt.qcrmin) then + if(qci(i,k,1).gt.qcrmin) pacr(i,k,1) & + = min(pacrr/slope2(i,k,1)/slope(i,k,1)/slopeb(i,k,1) & + *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) + coeres = slope2(i,k,1)*sqrt(slope(i,k,1)*slopeb(i,k,1)) + pres(i,k,1) = (rh(i,k,1)-1.)*(precr1/slope2(i,k,1) & + +precr2*work2(i,k)/coeres)/work1(i,k,1) + if(pres(i,k,1).lt.0.) then + pres(i,k,1) = max(pres(i,k,1),-qrs(i,k,1)/dtcld) + pres(i,k,1) = max(pres(i,k,1),satdt/2) + else + pres(i,k,1) = min(pres(i,k,1),satdt/2) + pres(i,k,1) = min(pres(i,k,1),qrs(i,k,1)/dtcld) + endif + endif + enddo + enddo +! +!---------------------------------------------------------------- +! cold rain process +! paut: conversion(aggregation) of ice to snow(kgkg-1s-1)(rh83) +! pgen: generation(nucleation) of ice from vapor(kgkg-1s-1)(rh83) +! pacr: accretion rate of snow by ice(lin83) +! pisd: deposition/sublimation rate of ice(rh83) +! pres: deposition/sublimation rate of snow(lin83) +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + supsat = max(q(i,k),qmin)-qs(i,k,2) + satdt = supsat/dtcld + ifsat = 0 + n0sfac = min(exp(alpha*supcol),n0smax) + xnc = min(xn0 * exp(betai*supcol)/den(i,k),xncmax) +! + if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,2).gt.qcrmin) then + eacrs = exp(0.025*(-supcol)) + pacr(i,k,2) = min(pacrs*n0sfac*eacrs/slope2(i,k,2)/slope(i,k,2) & + /slopeb(i,k,2)*qci(i,k,2)*denfac(i,k),qci(i,k,2)/dtcld) + endif + if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qcrmin) then + pacr(i,k,3) = min(pacrc/slope2(i,k,2)/slope(i,k,2) & + /slopeb(i,k,2)*qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) + endif +! + if(qci(i,k,2).gt.qcrmin) then + xmi = qci(i,k,2)*xnc + if(ifsat.ne.1) pisd(i,k) = 4.*dicon*sqrt(xmi)*den(i,k) & + *(rh(i,k,2)-1.)/work1(i,k,2) + if(pisd(i,k).lt.0.) then + pisd(i,k) = max(pisd(i,k),satdt) + pisd(i,k) = max(pisd(i,k),-qci(i,k,2)/dtcld) + else + pisd(i,k) = min(pisd(i,k),satdt) + endif + if(abs(pisd(i,k)).gt.abs(satdt)) ifsat = 1 + endif +! + if(qrs(i,k,2).gt.qcrmin.and.ifsat.ne.1) then + coeres = slope2(i,k,2)*sqrt(slope(i,k,2)*slopeb(i,k,2)) + if(ifsat.ne.1) pres(i,k,2) = (rh(i,k,2)-1.)*(precs1 & + /slope2(i,k,2)+precs2*work2(i,k) & + /coeres)/work1(i,k,2) + if(pres(i,k,2).lt.0.) then + pres(i,k,2) = max(pres(i,k,2),-qrs(i,k,2)/dtcld) + pres(i,k,2) = max(pres(i,k,2),satdt/2) + else + pres(i,k,2) = min(pres(i,k,2),satdt/2) + pres(i,k,2) = min(pres(i,k,2),qrs(i,k,2)/dtcld) + endif + if(abs(pisd(i,k)+pres(i,k,2)).ge.abs(satdt)) ifsat = 1 + endif +! + if(supsat.gt.0.and.ifsat.ne.1) then + pgen(i,k) = max(0.,(xm0*xnc-max(qci(i,k,2),0.))/dtcld) + pgen(i,k) = min(pgen(i,k),satdt) + endif +! + if(qci(i,k,2).gt.qcrmin) paut(i,k,2) & + = max(0.,(qci(i,k,2)-xmmax*xnc)/dtcld) +! + if(t(i,k).gt.t0c) then + xlf = xls - xl(i,k) + if(qrs(i,k,2).gt.qcrmin) then + psml(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *(precs1/slope2(i,k,2)+precs2*work2(i,k)/coeres) + psml(i,k) = min(max(psml(i,k),-qrs(i,k,2)/dtcld),0.) + endif + if(qrs(i,k,2).gt.qcrmin.and.rh(i,k,1).lt.1.) & + psev(i,k) = pres(i,k,2)*work1(i,k,2)/work1(i,k,1) + psev(i,k) = min(max(psev(i,k),-qrs(i,k,2)/dtcld),0.) + endif + enddo + enddo +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qcrmin,qci(i,k,1)) + source = (paut(i,k,1)+pacr(i,k,1)+pacr(i,k,3))*dtcld + if (source.gt.value) then + factor = value/source + paut(i,k,1) = paut(i,k,1)*factor + pacr(i,k,1) = pacr(i,k,1)*factor + pacr(i,k,3) = pacr(i,k,3)*factor + endif +! +! cloud ice +! + value = max(qcrmin,qci(i,k,2)) + source = (paut(i,k,2)+pacr(i,k,2)-pgen(i,k)-pisd(i,k))*dtcld + if (source.gt.value) then + factor = value/source + paut(i,k,2) = paut(i,k,2)*factor + pacr(i,k,2) = pacr(i,k,2)*factor + pgen(i,k) = pgen(i,k)*factor + pisd(i,k) = pisd(i,k)*factor + endif + work2(i,k)=-(pres(i,k,1)+pres(i,k,2)+pgen(i,k)+pisd(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(paut(i,k,1)+pacr(i,k,1) & + +pacr(i,k,3))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(paut(i,k,1)+pacr(i,k,1) & + +pres(i,k,1))*dtcld,0.) + qci(i,k,2) = max(qci(i,k,2)-(paut(i,k,2)+pacr(i,k,2) & + -pgen(i,k)-pisd(i,k))*dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+(pres(i,k,2)+paut(i,k,2) & + +pacr(i,k,2)+pacr(i,k,3))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xls*(pres(i,k,2)+pisd(i,k)+pgen(i,k)) & + -xl(i,k)*pres(i,k,1) & + -xlf*pacr(i,k,3) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + else +! +! cloud water +! + value = max(qcrmin,qci(i,k,1)) + source=(paut(i,k,1)+pacr(i,k,1)+pacr(i,k,3))*dtcld + if (source.gt.value) then + factor = value/source + paut(i,k,1) = paut(i,k,1)*factor + pacr(i,k,1) = pacr(i,k,1)*factor + pacr(i,k,3) = pacr(i,k,3)*factor + endif +! +! snow +! + value = max(qcrmin,qrs(i,k,2)) + source=(-psev(i,k)-psml(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psev(i,k) = psev(i,k)*factor + psml(i,k) = psml(i,k)*factor + endif + work2(i,k)=-(pres(i,k,1)+psev(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(paut(i,k,1)+pacr(i,k,1) & + +pacr(i,k,3))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(paut(i,k,1)+pacr(i,k,1) & + +pres(i,k,1) -psml(i,k)+pacr(i,k,3))*dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+(psml(i,k)+psev(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xlf*(psml(i,k))-xl(i,k)*(pres(i,k,1)+psev(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + endif + enddo + enddo +! + do k = kts, kte + do i = its, ite + qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! condensational/evaporational rate of cloud water if there exists +! additional water vapor condensated/if evaporation of cloud water +! is not enough to remove subsaturation. +! use fall bariable for this process(pcon) +! +! if(lat.eq.latd) write(iun,603) + do k = kts, kte + do i = its, ite + work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) + work2(i,k) = qci(i,k,1)+work1(i,k,1) + pcon(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qci(i,k,1).gt.qcrmin.and.work1(i,k,1).lt.0.and.t(i,k).gt.t0c) & + pcon(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld + q(i,k) = q(i,k)-pcon(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)+pcon(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld +! + if(lat.eq.latd.and.i.eq.lond) then + pgens(i,k) = pgens(i,k)+pgen(i,k) + pcons(i,k) = pcons(i,k)+pcon(i,k) + pisds(i,k) = pisds(i,k)+pisd(i,k) + pacrss(i,k) = pacrss(i,k)+pacr(i,k,1)+pacr(i,k,2)+pacr(i,k,3) + press(i,k) = press(i,k)+pres(i,k,1)+pres(i,k,2) + pauts(i,k) = pauts(i,k)+paut(i,k,1)+paut(i,k,2) +! write(iun,604) k,p(i,k)/100., & +! t(i,k)-t0c,t(i,k)-t1(i,k),q(i,k)*1000., & +! (q(i,k)-q1(i,k))*1000.,rh(i,k,2)*100.,pgens(i,k)*qdt, & +! pcons(i,k)*qdt,pisds(i,k)*qdt,pauts(i,k)*qdt,pacrss(i,k)*qdt, & +! press(i,k)*qdt,qci(i,k,1)*1000.,qrs(i,k,1)*1000., & +! qci(i,k,2)*1000.,qrs(i,k,2)*1000. + endif + enddo + enddo +!603 format(1x,' k',' p', & +! ' t',' delt',' q',' delq',' rh', & +! ' pgen',' pcon',' pisd',' paut',' pacr',' pres', & +! ' qc',' qr',' qi',' qs') +!604 format(1x,i3,f6.0,4f5.1,f5.0,10f5.2) +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +! + do k = kts, kte + do i = its, ite + if(qrs(i,k,1).le.qcrmin)then + slope(i,k,1) = lamdarmax + slopeb(i,k,1) = slope(i,k,1)**bvtr + else + slope(i,k,1) = lamdar(qrs(i,k,1),den(i,k)) + slopeb(i,k,1) = slope(i,k,1)**bvtr + endif + if(qrs(i,k,2).le.qcrmin)then + slope(i,k,2) = lamdarmax + slopeb(i,k,2) = slope(i,k,2)**bvts + else + supcol = t0c-t(i,k) + n0sfac = min(exp(alpha*supcol),n0smax) + slope(i,k,2) = lamdas(qrs(i,k,2),den(i,k),n0sfac) + slopeb(i,k,2) = slope(i,k,2)**bvts + endif + slope2(i,k,1) = slope(i,k,1)*slope(i,k,1) + slope2(i,k,2) = slope(i,k,2)*slope(i,k,2) + enddo + enddo +! + do i = its, ite + do k = kte, kts, -1 + work1(i,k,1) = pvtr/slopeb(i,k,1)*denfac(i,k)/delz(i,k) + work1(i,k,2) = pvts/slopeb(i,k,2)*denfac(i,k)/delz(i,k) + if(qrs(i,k,1).le.qcrmin) work1(i,k,1) = 0. + if(qrs(i,k,2).le.qcrmin) work1(i,k,2) = 0. + numdt = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) + if(qci(i,k,2).le.qmin) then + work2c(i,k) = 0. + else + work1c(i,k) = 3.29*(den(i,k)*qci(i,k,2))**0.16 + work2c(i,k) = work1c(i,k)/delz(i,k) + endif + numdt = max(nint(work2c(i,k)*dtcld+.5),numdt) + if(numdt.ge.mstep(i)) mstep(i) = numdt + enddo + mstep(i) = min(mstep(i),mstepmax) + enddo +! +! if(lat.eq.latd) write(iun,605) + do n = 1,mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) + holdrr = qrs(i,k,1) + holdrs = qrs(i,k,2) + qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) + qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + fallc(i,k) = fallc(i,k)+falkc(i,k) + qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) +! +! if(lat.eq.latd.and.i.eq.lond) & +! write(iun,606) k,p(i,k)/100., & +! t(i,k)-t0c,q(i,k)*1000.,rh(i,k,2)*100.,w(i,k),work1(i,k,1) & +! *delz(i,k), work1(i,k,2)*delz(i,k),holdrr*1000.,holdrs*1000., & +! qrs(i,k,1)*1000.,qrs(i,k,2)*1000.,n + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) + holdrr = qrs(i,k,1) + holdrs = qrs(i,k,2) + qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1) & + -falk(i,k+1,1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2) & + -falk(i,k+1,2)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + fallc(i,k) = fallc(i,k)+falkc(i,k) + qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k) & + -falkc(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) +! +! if(lat.eq.latd.and.i.eq.lond) & +! write(iun,606) k,p(i,k)/100., & +! t(i,k)-t0c,q(i,k)*1000.,rh(i,k,2)*100.,w(i,k),work1(i,k,1) & +! *delz(i,k), work1(i,k,2)*delz(i,k),holdrr*1000.,holdrs*1000., & +! qrs(i,k,1)*1000.,qrs(i,k,2)*1000.,n + endif + enddo + enddo + enddo +!605 format(1x,' k',' p',' t',' q',' rh',' w', & +! ' vtr',' vts',' qri',' qsi',' qrf',' qsf',' mstep') +!606 format(1x,i3,f6.0,2f5.1,f5.0,f6.2,6f6.2,i5) +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,1,1)+fall(i,1,2) + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. & + + rain(i) + endif + enddo +! +! if(lat.eq.latd) write(iun,601) latd,lond,loop,rain(lond) +! 601 format(1x,' ncloud5 lat lon loop : rain(mm) ',3i6,f20.2) +! + enddo ! big loops + + END SUBROUTINE ncloud52d +! ................................................................... + REAL FUNCTION rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + PARAMETER (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + end function rgmma +! +!-------------------------------------------------------------------------- + REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs + +!------------------------------------------------------------------- + SUBROUTINE ncloud5init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + + real, intent(in) :: den0,denr,dens,cl,cpv + logical, intent(in) :: allowed_to_read + real :: pi + + pi = 4.*atan(1.) + xlv1 = cl-cpv + + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu ! 7.03 + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xm0 = (di0/dicon)**2 + xmmax = (dimax/dicon)**2 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + pacrc = pi*n0s*avts*g3pbs*.25*eacrc +! + END SUBROUTINE ncloud5init + +END MODULE module_mp_ncloud5 + diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F new file mode 100644 index 00000000..aa42ec90 --- /dev/null +++ b/wrfv2_fire/phys/module_mp_thompson.F @@ -0,0 +1,3069 @@ +!+---+-----------------------------------------------------------------+ +!.. This subroutine computes the moisture tendencies of water vapor, +!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. +!.. Previously this code was based on Reisner et al (1998), but few of +!.. those pieces remain. A complete description is now found in +!.. Thompson et al. (2004, 2006). +!.. Most importantly, users may wish to modify the prescribed number of +!.. cloud droplets (Nt_c; see guidelines mentioned below). Otherwise, +!.. users may alter the rain and graupel size distribution parameters +!.. to use exponential (Marshal-Palmer) or generalized gamma shape. +!.. The snow field assumes a combination of two gamma functions (from +!.. Field et al. 2005) and would require significant modifications +!.. throughout the entire code to alter its shape as well as accretion +!.. rates. Users may also alter the constants used for density of rain, +!.. graupel, ice, and snow, but the latter is not constant when using +!.. Paul Field's snow distribution and moments methods. Other values +!.. users can modify include the constants for mass and/or velocity +!.. power law relations and assumed capacitances used in deposition/ +!.. sublimation/evaporation/melting. +!.. Remaining values should probably be left alone. +!.. +!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 +!..Last modified: 14 Feb 2007 +!+---+-----------------------------------------------------------------+ +!wrft:model_layer:physics +!+---+-----------------------------------------------------------------+ +! + MODULE module_mp_thompson + USE module_wrf_error + + IMPLICIT NONE + + LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. + INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 + REAL, PARAMETER, PRIVATE:: T_0 = 273.15 + REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 + +!..Densities of rain, snow, graupel, and cloud ice. + REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 + REAL, PARAMETER, PRIVATE:: rho_s = 100.0 + REAL, PARAMETER, PRIVATE:: rho_g = 400.0 + REAL, PARAMETER, PRIVATE:: rho_i = 890.0 + +!..Prescribed number of cloud droplets. Set according to known data or +!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and +!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter, +!.. mu_c, calculated based on Nt_c is important in autoconversion +!.. scheme. + REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 + +!..Generalized gamma distributions for rain, graupel and cloud ice. +!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. + REAL, PARAMETER, PRIVATE:: mu_r = 0.0 + REAL, PARAMETER, PRIVATE:: mu_g = 0.0 + REAL, PARAMETER, PRIVATE:: mu_i = 0.0 + REAL, PRIVATE:: mu_c + +!..Sum of two gamma distrib for snow (Field et al. 2005). +!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) +!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] +!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively +!.. calculated as function of ice water content and temperature. + REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 + REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 + REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 + REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 + REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 + +!..Y-intercept parameters for rain & graupel. However, these are not +!.. constant and vary depending on mixing ratio. Furthermore, when +!.. mu is non-zero, these become equiv y-intercept for an exponential +!.. distrib and proper values computed based on assumed mu value. + REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4 + REAL, PARAMETER, PRIVATE:: gonv_max = 1.E6 + REAL, PARAMETER, PRIVATE:: ronv_min = 2.E6 + REAL, PARAMETER, PRIVATE:: ronv_max = 2.E9 + REAL, PARAMETER, PRIVATE:: ronv_sl = 1./4. + REAL, PARAMETER, PRIVATE:: ronv_r0 = 0.10E-3 + REAL, PARAMETER, PRIVATE:: ronv_c0 = ronv_sl/ronv_r0 + REAL, PARAMETER, PRIVATE:: ronv_c1 = (ronv_max-ronv_min)*0.5 + REAL, PARAMETER, PRIVATE:: ronv_c2 = (ronv_max+ronv_min)*0.5 + +!..Mass power law relations: mass = am*D**bm +!.. Snow from Field et al. (2005), others assume spherical form. + REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 + REAL, PARAMETER, PRIVATE:: bm_r = 3.0 + REAL, PARAMETER, PRIVATE:: am_s = 0.069 + REAL, PARAMETER, PRIVATE:: bm_s = 2.0 + REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0 + REAL, PARAMETER, PRIVATE:: bm_g = 3.0 + REAL, PARAMETER, PRIVATE:: am_i = 0.069 + REAL, PARAMETER, PRIVATE:: bm_i = 2.0 + +!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) +!.. Rain from Ferrier (1994), ice, snow, and graupel from +!.. Thompson et al (2006). Coefficient fv is zero for graupel/ice. + REAL, PARAMETER, PRIVATE:: av_r = 4854.0 + REAL, PARAMETER, PRIVATE:: bv_r = 1.0 + REAL, PARAMETER, PRIVATE:: fv_r = 195.0 + REAL, PARAMETER, PRIVATE:: av_s = 40.0 + REAL, PARAMETER, PRIVATE:: bv_s = 0.55 + REAL, PARAMETER, PRIVATE:: fv_s = 125.0 + REAL, PARAMETER, PRIVATE:: av_g = 442.0 + REAL, PARAMETER, PRIVATE:: bv_g = 0.89 + REAL, PARAMETER, PRIVATE:: av_i = 2247.0 + REAL, PARAMETER, PRIVATE:: bv_i = 1.0 + +!..Capacitance of sphere and plates/aggregates: D**3, D**2 + REAL, PARAMETER, PRIVATE:: C_cube = 0.5 + REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3 + +!..Collection efficiencies. Rain/snow/graupel collection of cloud +!.. droplets use variables (Ef_rw, Ef_ri, Ef_sw, Ef_gw respectively) and +!.. get computed elsewhere because they are dependent on stokes +!.. number. + REAL, PARAMETER, PRIVATE:: Ef_si = 0.1 + REAL, PARAMETER, PRIVATE:: Ef_rs = 0.99 + REAL, PARAMETER, PRIVATE:: Ef_rg = 0.99 + +!..Minimum microphys values +!.. R1 value, 1.E-12, cannot be set lower because of numerical +!.. problems with Paul Field's moments and should not be set larger +!.. because of truncation problems in snow/ice growth. + REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 + REAL, PARAMETER, PRIVATE:: R2 = 1.E-8 + REAL, PARAMETER, PRIVATE:: eps = 1.E-29 + +!..Constants in Cooper curve relation for cloud ice number. + REAL, PARAMETER, PRIVATE:: TNO = 5.0 + REAL, PARAMETER, PRIVATE:: ATO = 0.304 + +!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. + REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) + +!..Schmidt number + REAL, PARAMETER, PRIVATE:: Sc = 0.632 + REAL, PRIVATE:: Sc3 + +!..Homogeneous freezing temperature + REAL, PARAMETER, PRIVATE:: HGFR = 235.16 + +!..Water vapor and air gas constants at constant pressure + REAL, PARAMETER, PRIVATE:: Rv = 461.5 + REAL, PARAMETER, PRIVATE:: oRv = 1./Rv + REAL, PARAMETER, PRIVATE:: R = 287.04 + REAL, PARAMETER, PRIVATE:: Cp = 1004.0 + +!..Enthalpy of sublimation, vaporization, and fusion at 0C. + REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 + REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 + REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 + REAL, PARAMETER, PRIVATE:: olfus = 1./lfus + +!..Ice initiates with this mass (kg), corresponding diameter calc. +!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). + REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 + REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 + REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 + REAL, PARAMETER, PRIVATE:: D0s = 125.E-6 + REAL, PARAMETER, PRIVATE:: D0g = 150.E-6 + REAL, PRIVATE:: D0i, xm0s, xm0g + +!..Lookup table dimensions + INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 + INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 + INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 + INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 + INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 + INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 + INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2 + +!..Lookup tables for cloud water content (kg/m**3). + REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & + r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for cloud ice content (kg/m**3). + REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & + r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & + 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & + 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & + 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & + 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & + 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3/) + +!..Lookup tables for rain content (kg/m**3). + REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & + r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for graupel content (kg/m**3). + REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & + r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for snow content (kg/m**3). + REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & + r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) + +!..Lookup tables for rain y-intercept parameter (/m**4). + REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & + N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & + 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & + 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & + 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & + 1.e10/) + +!..Lookup tables for ice number concentration (/m**3). + REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & + Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & + 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & + 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) + +!..For snow moments conversions (from Field et al. 2005) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) + REAL, DIMENSION(10), PARAMETER, PRIVATE:: & + sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) + +!..Lookup table for A1 and A2 in Bergeron process (Koenig 1971) + REAL, DIMENSION(31), PARAMETER, PRIVATE:: & + ABER1 = (/.7939E-07,.7841E-06,.3369E-05,.4336E-05, & + .5285E-05,.3728E-05,.1852E-05,.2991E-06,.4248E-06, & + .7434E-06,.1812E-05,.4394E-05,.9145E-05,.1725E-04, & + .3348E-04,.1725E-04,.9175E-05,.4412E-05,.2252E-05, & + .9115E-06,.4876E-06,.3473E-06,.4758E-06,.6306E-06, & + .8573E-06,.7868E-06,.7192E-06,.6513E-06,.5956E-06, & + .5333E-06,.4834E-06/) + REAL, DIMENSION(31), PARAMETER, PRIVATE:: & + ABER2 = (/.4006,.4831,.5320,.5307,.5319,.5249, & + .4888,.3894,.4047,.4318,.4771,.5183,.5463,.5651, & + .5813,.5655,.5478,.5203,.4906,.4447,.4126,.3960, & + .4149,.4320,.4506,.4483,.4460,.4433,.4413,.4382, & + .4361/) + REAL, DIMENSION(31), PRIVATE:: CBG + +!..Temperatures (5 C interval 0 to -40) used in lookup tables. + REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & + Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) + +!..Lookup tables for various accretion/collection terms. +!.. ntb_x refers to the number of elements for rain, snow, graupel, +!.. and temperature array indices. Variables beginning with tp/tc/tm +!.. represent lookup tables. + DOUBLE PRECISION, DIMENSION(ntb_g,ntb_r1,ntb_r):: & + tcg_racg, tmr_racg, tcr_gacr, tmg_gacr + DOUBLE PRECISION, DIMENSION(ntb_s,ntb_t,ntb_r1,ntb_r):: & + tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & + tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2 + DOUBLE PRECISION, DIMENSION(ntb_c,45):: & + tpi_qcfz, tni_qcfz + DOUBLE PRECISION, DIMENSION(ntb_r,ntb_r1,45):: & + tpi_qrfz, tpg_qrfz, tni_qrfz + DOUBLE PRECISION, DIMENSION(ntb_i,ntb_i1):: & + tps_iaus, tni_iaus, tpi_ide + +!..Variables holding a bunch of exponents and gamma values (cloud water, +!.. cloud ice, rain, snow, then graupel). + REAL, DIMENSION(3), PRIVATE:: cce, ccg + REAL, PRIVATE:: ocg1, ocg2 + REAL, DIMENSION(6), PRIVATE:: cie, cig + REAL, PRIVATE:: oig1, oig2, obmi + REAL, DIMENSION(12), PRIVATE:: cre, crg + REAL, PRIVATE:: ore1, org1, org2, org3, obmr + REAL, DIMENSION(18), PRIVATE:: cse, csg + REAL, PRIVATE:: oams, obms + REAL, DIMENSION(12), PRIVATE:: cge, cgg + REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, obmg + +!..Declaration of precomputed constants in various rate eqns. + REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi + REAL:: t1_qr_ev, t2_qr_ev + REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd + REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me + +!+---+ +!+---+-----------------------------------------------------------------+ +!..END DECLARATIONS +!+---+-----------------------------------------------------------------+ +!+---+ +! + + CONTAINS + + SUBROUTINE thompson_init + + IMPLICIT NONE + + INTEGER:: i, j, k, m, n + +!..From Martin et al. (1994), assign gamma shape parameter mu for cloud +!.. drops according to general dispersion characteristics (disp=~0.25 +!.. for Maritime and 0.45 for Continental). +!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime +!.. to 2 for really dirty air. + mu_c = MIN(15., (1000.E6/Nt_c + 2.)) + +!..Schmidt number to one-third used numerous times. + Sc3 = Sc**(1./3.) + +!..Compute min ice diam from mass, min snow/graupel mass from diam. + D0i = (xm0i/am_i)**(1./bm_i) + xm0s = am_s * D0s**bm_s + xm0g = am_g * D0g**bm_g + +!..These constants various exponents and gamma() assoc with cloud, +!.. rain, snow, and graupel. + cce(1) = mu_c + 1. + cce(2) = bm_r + mu_c + 1. + cce(3) = bm_r + mu_c + 4. + ccg(1) = WGAMMA(cce(1)) + ccg(2) = WGAMMA(cce(2)) + ccg(3) = WGAMMA(cce(3)) + ocg1 = 1./ccg(1) + ocg2 = 1./ccg(2) + + cie(1) = mu_i + 1. + cie(2) = bm_i + mu_i + 1. + cie(3) = bm_i + mu_i + bv_i + 1. + cie(4) = mu_i + bv_i + 1. + cie(5) = mu_i + 2. + cie(6) = bm_i + bv_i + cig(1) = WGAMMA(cie(1)) + cig(2) = WGAMMA(cie(2)) + cig(3) = WGAMMA(cie(3)) + cig(4) = WGAMMA(cie(4)) + cig(5) = WGAMMA(cie(5)) + cig(6) = WGAMMA(cie(6)) + oig1 = 1./cig(1) + oig2 = 1./cig(2) + obmi = 1./bm_i + + do n = 1, 31 + CBG(n) = WGAMMA(mu_i + 1 + ABER2(n)*bm_i) + enddo + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r + mu_r + 2. + cre(5) = bm_r + mu_r + 3. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r + mu_r + bv_r + 2. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r + mu_r + 4. + do n = 1, 12 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s + 3. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s + bv_s + 2. + cse(6) = bm_s + bv_s + 3. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s + mu_s + bv_s + 2. + cse(12) = bm_s + mu_s + bv_s + 3. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = bm_s - 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = bv_s + 3. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s +! sg_lam = csg(2) / csg(1) +! sg_nos = csg(2)**cse(1) / csg(1)**cse(2) + + cge(1) = bm_g + 1. + cge(2) = mu_g + 1. + cge(3) = bm_g + mu_g + 1. + cge(4) = bm_g + mu_g + 2. + cge(5) = bm_g + mu_g + 3. + cge(6) = bm_g + mu_g + bv_g + 1. + cge(7) = bm_g + mu_g + bv_g + 2. + cge(8) = bm_g + mu_g + bv_g + 3. + cge(9) = mu_g + bv_g + 3. + cge(10) = mu_g + 2. + cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) + cge(12) = 0.5*(bv_g + 5.) + mu_g + do n = 1, 12 + cgg(n) = WGAMMA(cge(n)) + enddo + obmg = 1./bm_g + oge1 = 1./cge(1) + ogg1 = 1./cgg(1) + ogg2 = 1./cgg(2) + ogg3 = 1./cgg(3) + +!+---+-----------------------------------------------------------------+ +!..Simplify various rate eqns the best we can now. +!+---+-----------------------------------------------------------------+ + +!..Rain collecting cloud water and cloud ice + t1_qr_qc = PI*.25*av_r * crg(9) + t1_qr_qi = PI*.25*av_r * crg(9) + t2_qr_qi = PI*.25*am_r*av_r * crg(8) + +!..Graupel collecting cloud water + t1_qg_qc = PI*.25*av_g * cgg(9) + +!..Snow collecting cloud water + t1_qs_qc = PI*.25*av_s + +!..Snow collecting cloud ice + t1_qs_qi = PI*.25*av_s + +!..Evaporation of rain; ignore depositional growth of rain. + t1_qr_ev = 0.78 * crg(10) + t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) + +!..Sublimation/depositional growth of snow + t1_qs_sd = 0.86 + t2_qs_sd = 0.28*Sc3*SQRT(av_s) + +!..Melting of snow + t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 + t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) + +!..Sublimation/depositional growth of graupel + t1_qg_sd = 0.86 * cgg(10) + t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) + +!..Melting of graupel + t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) + t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) + +!..Constants for helping find lookup table indexes. + nic2 = NINT(ALOG10(r_c(1))) + nii2 = NINT(ALOG10(r_i(1))) + nii3 = NINT(ALOG10(Nt_i(1))) + nir2 = NINT(ALOG10(r_r(1))) + nir3 = NINT(ALOG10(N0r_exp(1))) + nis2 = NINT(ALOG10(r_s(1))) + nig2 = NINT(ALOG10(r_g(1))) + +!+---+-----------------------------------------------------------------+ +!..Create lookup tables for most costly calculations. +!+---+-----------------------------------------------------------------+ + + do k = 1, ntb_r + do j = 1, ntb_r1 + do i = 1, ntb_g + tcg_racg(i,j,k) = 0.0d0 + tmr_racg(i,j,k) = 0.0d0 + tcr_gacr(i,j,k) = 0.0d0 + tmg_gacr(i,j,k) = 0.0d0 + enddo + enddo + enddo + + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_t + do i = 1, ntb_s + tcs_racs1(i,j,k,m) = 0.0d0 + tmr_racs1(i,j,k,m) = 0.0d0 + tcs_racs2(i,j,k,m) = 0.0d0 + tmr_racs2(i,j,k,m) = 0.0d0 + tcr_sacr1(i,j,k,m) = 0.0d0 + tms_sacr1(i,j,k,m) = 0.0d0 + tcr_sacr2(i,j,k,m) = 0.0d0 + tms_sacr2(i,j,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + + do k = 1, 45 + do j = 1, ntb_r1 + do i = 1, ntb_r + tpi_qrfz(i,j,k) = 0.0d0 + tni_qrfz(i,j,k) = 0.0d0 + tpg_qrfz(i,j,k) = 0.0d0 + enddo + enddo + do i = 1, ntb_c + tpi_qcfz(i,k) = 0.0d0 + tni_qcfz(i,k) = 0.0d0 + enddo + enddo + + do j = 1, ntb_i1 + do i = 1, ntb_i + tps_iaus(i,j) = 0.0d0 + tni_iaus(i,j) = 0.0d0 + tpi_ide(i,j) = 0.0d0 + enddo + enddo + + if (.not. iiwarm) then + CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') + WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & + ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g + CALL wrf_debug(150, wrf_err_message) + +!..Rain collecting graupel & graupel collecting rain. + CALL wrf_debug(200, ' creating rain collecting graupel table') + call qr_acr_qg + +!..Rain collecting snow & snow collecting rain. + CALL wrf_debug(200, ' creating rain collecting snow table') + call qr_acr_qs + +!..Cloud water and rain freezing (Bigg, 1953). + CALL wrf_debug(200, ' creating freezing of water drops table') + call freezeH2O + +!..Conversion of some ice mass into snow category. + CALL wrf_debug(200, ' creating ice converting to snow table') + call qi_aut_qs + + CALL wrf_debug(150, ' ... DONE microphysical lookup tables') + endif + + END SUBROUTINE thompson_init +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!..This is a wrapper routine designed to transfer values from 3D to 1D. +!+---+-----------------------------------------------------------------+ + SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, & + th, pii, p, dz, dt_in, itimestep, & + RAINNC, RAINNCV, SR, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte) ! tile dims + + implicit none + +!..Subroutine arguments + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + qv, qc, qr, qi, qs, qg, ni, th + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & + pii, p, dz + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & + RAINNC, RAINNCV, SR + REAL, INTENT(IN):: dt_in + INTEGER, INTENT(IN):: itimestep + +!..Local variables + REAL, DIMENSION(kts:kte):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + t1d, p1d, dz1d + REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic + REAL:: dt, pptrain, pptsnow, pptgraul, pptice + REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max + INTEGER:: i, j, k + INTEGER:: imax_qc, imax_qr, imax_qi, imax_qs, imax_qg, imax_ni + INTEGER:: jmax_qc, jmax_qr, jmax_qi, jmax_qs, jmax_qg, jmax_ni + INTEGER:: kmax_qc, kmax_qr, kmax_qi, kmax_qs, kmax_qg, kmax_ni + CHARACTER*256:: mp_debug + +!+---+ + + dt = dt_in + + qc_max = 0. + qr_max = 0. + qs_max = 0. + qi_max = 0. + qg_max = 0 + ni_max = 0. + imax_qc = 0 + imax_qr = 0 + imax_qi = 0 + imax_qs = 0 + imax_qg = 0 + imax_ni = 0 + jmax_qc = 0 + jmax_qr = 0 + jmax_qi = 0 + jmax_qs = 0 + jmax_qg = 0 + jmax_ni = 0 + kmax_qc = 0 + kmax_qr = 0 + kmax_qi = 0 + kmax_qs = 0 + kmax_qg = 0 + kmax_ni = 0 + do i = 1, 256 + mp_debug(i:i) = char(0) + enddo + + j_loop: do j = jts, jte + i_loop: do i = its, ite + + pptrain = 0. + pptsnow = 0. + pptgraul = 0. + pptice = 0. + RAINNCV(i,j) = 0. + SR(i,j) = 0. + + do k = kts, kte + t1d(k) = th(i,k,j)*pii(i,k,j) + p1d(k) = p(i,k,j) + dz1d(k) = dz(i,k,j) + qv1d(k) = qv(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qr1d(k) = qr(i,k,j) + qs1d(k) = qs(i,k,j) + qg1d(k) = qg(i,k,j) + ni1d(k) = ni(i,k,j) + enddo + + call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + t1d, p1d, dz1d, & + pptrain, pptsnow, pptgraul, pptice, & + kts, kte, dt, i, j) + + pcp_ra(i,j) = pptrain + pcp_sn(i,j) = pptsnow + pcp_gr(i,j) = pptgraul + pcp_ic(i,j) = pptice + RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice + RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice + SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) + + do k = kts, kte + qv(i,k,j) = qv1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + qr(i,k,j) = qr1d(k) + qs(i,k,j) = qs1d(k) + qg(i,k,j) = qg1d(k) + ni(i,k,j) = ni1d(k) + th(i,k,j) = t1d(k)/pii(i,k,j) + if (qc1d(k) .gt. qc_max) then + imax_qc = i + jmax_qc = j + kmax_qc = k + qc_max = qc1d(k) + elseif (qc1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qr1d(k) .gt. qr_max) then + imax_qr = i + jmax_qr = j + kmax_qr = k + qr_max = qr1d(k) + elseif (qr1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qs1d(k) .gt. qs_max) then + imax_qs = i + jmax_qs = j + kmax_qs = k + qs_max = qs1d(k) + elseif (qs1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qi1d(k) .gt. qi_max) then + imax_qi = i + jmax_qi = j + kmax_qi = k + qi_max = qi1d(k) + elseif (qi1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (qg1d(k) .gt. qg_max) then + imax_qg = i + jmax_qg = j + kmax_qg = k + qg_max = qg1d(k) + elseif (qg1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + if (ni1d(k) .gt. ni_max) then + imax_ni = i + jmax_ni = j + kmax_ni = k + ni_max = ni1d(k) + elseif (ni1d(k) .lt. 0.0) then + write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & + ' at i,j,k=', i,j,k + CALL wrf_debug(150, mp_debug) + endif + enddo + + enddo i_loop + enddo j_loop + +! DEBUG - GT + write(mp_debug,'(a,6(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & + 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & + 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & + 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & + 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & + 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & + 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')' + CALL wrf_debug(150, mp_debug) +! END DEBUG - GT + + END SUBROUTINE mp_gt_driver + +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!+---+-----------------------------------------------------------------+ +!.. This subroutine computes the moisture tendencies of water vapor, +!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel. +!.. Previously this code was based on Reisner et al (1998), but few of +!.. those pieces remain. A complete description is now found in +!.. Thompson et al. (2004, 2006). +!+---+-----------------------------------------------------------------+ +! + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + t1d, p1d, dzq, & + pptrain, pptsnow, pptgraul, pptice, & + kts, kte, dt, ii, jj) + + implicit none + +!..Sub arguments + INTEGER, INTENT(IN):: kts, kte, ii, jj + REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + t1d, p1d + REAL, DIMENSION(kts:kte), INTENT(IN):: dzq + REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice + REAL, INTENT(IN):: dt + +!..Local variables + REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & + qrten, qsten, qgten, niten + + DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd + + DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, & + prr_rcg, prr_sml, prr_gml, & + prr_rci, prv_rev + + DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & + pni_ihm, pri_wfz, pni_wfz, & + pri_rfz, pni_rfz, pri_ide, & + pni_ide, pri_rci, pni_rci, & + pni_sci, pni_iau + + DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & + prs_scw, prs_sde, prs_ihm, & + prs_ide + + DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & + prg_gcw, prg_rci, prg_rcs, & + prg_rcg, prg_ihm + + REAL, DIMENSION(kts:kte):: temp, pres, qv + REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni + REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 + REAL, DIMENSION(kts:kte):: qvs, qvsi + REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati + REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & + tcond, lvap, ocp, lvt2 + + DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g + REAL, DIMENSION(kts:kte):: mvd_r, mvd_c + REAL, DIMENSION(kts:kte):: smob, smo2, smo1, & + smoc, smod, smoe, smof + + REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n + + REAL:: rgvm, delta_tp, orho, onstep, lfus2 + DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg + DOUBLE PRECISION:: lami, ilami + REAL:: Dc, Dc_b, Dc_g, Di, Dr, Ds, Dg, Ds_m, Dg_m + REAL:: zeta1, zeta, taud, tau + REAL:: stoke_r, stoke_s, stoke_g, stoke_i + REAL:: vti, vtr, vts, vtg + REAL, DIMENSION(kts:kte+1):: vtik, vtnk, vtrk, vtsk, vtgk + REAL, DIMENSION(kts:kte):: vts_boost + REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow + REAL:: a_, b_, loga_, A1, A2, tf + REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat + REAL:: xnc, xri, xni, xmi, oxmi, xrc + REAL:: xsat, rate_max, sump, ratio + REAL:: clap, fcd, dfcd + REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl + REAL:: r_frac, g_frac + REAL:: Ef_rw, Ef_ri, Ef_sw, Ef_gw + REAL:: dts, odts, odt, odzq + INTEGER:: i, k, k2, ksed1, ku, n, nn, nstep, k_0, kbot, IT, iexfrq + INTEGER:: nir, nis, nig, nii, nic + INTEGER:: idx_tc,idx_t,idx_s,idx_g,idx_r1,idx_r,idx_i1,idx_i,idx_c + LOGICAL:: melti, no_micro + LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg + +!+---+ + + no_micro = .true. + dts = dt + odt = 1./dt + odts = 1./dts + iexfrq = 1 + +!+---+-----------------------------------------------------------------+ +!.. Source/sink terms. First 2 chars: "pr" represents source/sink of +!.. mass while "pn" represents source/sink of number. Next char is one +!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for +!.. cloud water, "s" for snow, and "g" for graupel. Next chars +!.. represent processes: "de" for sublimation/deposition, "ev" for +!.. evaporation, "fz" for freezing, "ml" for melting, "au" for +!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop +!.. secondary ice production, and "c" for collection followed by the +!.. character for the species being collected. ALL of these terms are +!.. positive (except for deposition/sublimation terms which can switch +!.. signs based on super/subsaturation) and are treated as negatives +!.. where necessary in the tendency equations. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + tten(k) = 0. + qvten(k) = 0. + qcten(k) = 0. + qiten(k) = 0. + qrten(k) = 0. + qsten(k) = 0. + qgten(k) = 0. + niten(k) = 0. + + prw_vcd(k) = 0. + + prv_rev(k) = 0. + prr_wau(k) = 0. + prr_rcw(k) = 0. + prr_rcs(k) = 0. + prr_rcg(k) = 0. + prr_sml(k) = 0. + prr_gml(k) = 0. + prr_rci(k) = 0. + + pri_inu(k) = 0. + pni_inu(k) = 0. + pri_ihm(k) = 0. + pni_ihm(k) = 0. + pri_wfz(k) = 0. + pni_wfz(k) = 0. + pri_rfz(k) = 0. + pni_rfz(k) = 0. + pri_ide(k) = 0. + pni_ide(k) = 0. + pri_rci(k) = 0. + pni_rci(k) = 0. + pni_sci(k) = 0. + pni_iau(k) = 0. + + prs_iau(k) = 0. + prs_sci(k) = 0. + prs_rcs(k) = 0. + prs_scw(k) = 0. + prs_sde(k) = 0. + prs_ihm(k) = 0. + prs_ide(k) = 0. + + prg_scw(k) = 0. + prg_rfz(k) = 0. + prg_gde(k) = 0. + prg_gcw(k) = 0. + prg_rci(k) = 0. + prg_rcs(k) = 0. + prg_rcg(k) = 0. + prg_ihm(k) = 0. + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + qv(k) = MAX(1.E-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + if (qc1d(k) .gt. R1) then + no_micro = .false. + rc(k) = qc1d(k)*rho(k) + L_qc(k) = .true. + else + qc1d(k) = 0.0 + rc(k) = R1 + L_qc(k) = .false. + endif + if (qi1d(k) .gt. R1) then + no_micro = .false. + ri(k) = qi1d(k)*rho(k) + ni(k) = MAX(1., ni1d(k)*rho(k)) + L_qi(k) = .true. + else + qi1d(k) = 0.0 + ni1d(k) = 0.0 + ri(k) = R1 + ni(k) = 0.01 + L_qi(k) = .false. + endif + if (qr1d(k) .gt. R1) then + no_micro = .false. + rr(k) = qr1d(k)*rho(k) + L_qr(k) = .true. + else + qr1d(k) = 0.0 + rr(k) = R1 + L_qr(k) = .false. + endif + if (qs1d(k) .gt. R1) then + no_micro = .false. + rs(k) = qs1d(k)*rho(k) + L_qs(k) = .true. + else + qs1d(k) = 0.0 + rs(k) = R1 + L_qs(k) = .false. + endif + if (qg1d(k) .gt. R1) then + no_micro = .false. + rg(k) = qg1d(k)*rho(k) + L_qg(k) = .true. + else + qg1d(k) = 0.0 + rg(k) = R1 + L_qg(k) = .false. + endif + enddo + + +!+---+-----------------------------------------------------------------+ +!..Derive various thermodynamic variables frequently used. +!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from +!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from +!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + tempc = temp(k) - 273.15 + rhof(k) = SQRT(RHO_NOT/rho(k)) + rhof2(k) = SQRT(rhof(k)) + qvs(k) = rslf(pres(k), temp(k)) + if (tempc .le. 0.0) then + qvsi(k) = rsif(pres(k), temp(k)) + else + qvsi(k) = qvs(k) + endif + satw(k) = qv(k)/qvs(k) + sati(k) = qv(k)/qvsi(k) + ssatw(k) = satw(k) - 1. + ssati(k) = sati(k) - 1. + if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0 + if (abs(ssati(k)).lt. eps) ssati(k) = 0.0 + if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false. + diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) + if (tempc .ge. 0.0) then + visco(k) = (1.718+0.0049*tempc)*1.0E-5 + else + visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 + endif + ocp(k) = 1./(Cp*(1.+0.887*qv(k))) + vsc2(k) = SQRT(rho(k)/visco(k)) + lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc + tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 + enddo + +!+---+-----------------------------------------------------------------+ +!..If no existing hydrometeor species and no chance to initiate ice or +!.. condense cloud water, just exit quickly! +!+---+-----------------------------------------------------------------+ + + if (no_micro) return + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope, and useful moments for snow. +!+---+-----------------------------------------------------------------+ + if (.not. iiwarm) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams + +!..All other moments based on reference, 2nd moment. If bm_s.ne.2, +!.. then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif + +!..Calculate 1st moment. Useful for depositional growth and melting. + loga_ = sa(1) + sa(2)*tc0 + sa(3) & + + sa(4)*tc0 + sa(5)*tc0*tc0 & + + sa(6) + sa(7)*tc0*tc0 & + + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & + + sa(10) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & + + sb(5)*tc0*tc0 + sb(6) & + + sb(7)*tc0*tc0 + sb(8)*tc0 & + + sb(9)*tc0*tc0*tc0 + sb(10) + smo1(k) = a_ * smo2(k)**b_ + +!..Calculate bm_s+1 (th) moment. Useful for diameter calcs. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ + +!..Calculate bv_s+2 (th) moment. Useful for riming. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & + + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & + + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & + + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(13)*cse(13)*cse(13) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & + + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & + + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) + smoe(k) = a_ * smo2(k)**b_ + +!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & + + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & + + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & + + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(16)*cse(16)*cse(16) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & + + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & + + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) + smof(k) = a_ * smo2(k)**b_ + + enddo + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept, slope values for graupel. +!+---+-----------------------------------------------------------------+ + N0_min = gonv_max + do k = kte, kts, -1 + if (.not. L_qg(k)) CYCLE + N0_exp = 100.0*rho(k)/rg(k) + N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo + + endif + +!+---+-----------------------------------------------------------------+ +!..Calculate y-intercept & slope values for rain. +!.. New treatment for variable y-intercept of rain. When rain comes +!.. from melted snow/graupel, compute mass-weighted mean size, melt +!.. into water, compute its mvd and recompute slope/intercept. +!.. If rain not from melted snow, use old relation but hold N0_r +!.. constant at its lowest value. While doing all this, ensure rain +!.. mvd does not exceed reasonable size like 3 mm. +!+---+-----------------------------------------------------------------+ + N0_min = ronv_max + do k = kte, kts, -1 +! if (.not. L_qr(k)) CYCLE + N0_exp = ronv_c1*tanh(ronv_c0*(ronv_r0-rr(k))) + ronv_c2 + N0_min = MIN(N0_exp, N0_min) + N0_exp = N0_min + lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + mvd_r(k) = (3.0+mu_r+0.672) / lamr + if (mvd_r(k) .gt. 3.e-3) then + mvd_r(k) = 3.e-3 + lamr = (3.0+mu_r+0.672) / 3.e-3 + lam_exp = lamr * (crg(3)*org2*org1)**bm_r + N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) + endif + N0_r(k) = N0_exp/(crg(2)*lam_exp) * lamr**cre(2) + ilamr(k) = 1./lamr + enddo + + if (.not. iiwarm) then + k_0 = kts + melti = .false. + do k = kte-1, kts, -1 + if ( (temp(k).gt. T_0) .and. (rr(k).gt. 0.001e-3) & + .and. ((rs(k+1)+rg(k+1)).gt. 0.01e-3) ) then + k_0 = MAX(k+1, k_0) + melti=.true. + goto 135 + endif + enddo + 135 continue + + if (melti) then +!.. Locate bottom of melting layer (if any). + kbot = kts + do k = k_0-1, kts, -1 + if ( (rs(k)+rg(k)).lt. 0.01e-3) goto 136 + enddo + 136 continue + kbot = MAX(k, kts) + +!.. Compute melted snow/graupel equiv water diameter one K-level above +!.. melting. Set starting rain mvd to either 50 microns or max from +!.. higher up in column. + if (L_qs(k_0)) then + Ds = smoc(k_0) / smob(k_0) + Ds_m = (am_s*Ds**bm_s / am_r)**obmr + else + Ds_m = 1.0e-6 + endif + if (L_qg(k_0)) then + Dg = (bm_g + mu_g + 1.) * ilamg(k_0) + Dg_m = (am_g*Dg**bm_g / am_r)**obmr + else + Dg_m = 1.0e-6 + endif + r_mvd1 = mvd_r(k_0) + r_mvd2 = MIN(MAX(Ds_m, Dg_m, r_mvd1+1.e-6, mvd_r(kbot)), & + 3.e-3) + +!.. Within melting layer, apply linear increase of rain mvd from r_mvd1 +!.. to equiv melted snow/graupel value (r_mvd2). So, by the bottom of +!.. the melting layer, the rain will have an mvd that matches that from +!.. melted snow and/or graupel. + if (kbot.gt. 2) then + do k = k_0-1, kbot, -1 + if (.not. L_qr(k)) CYCLE + xkrat = REAL(k_0-k)/REAL(k_0-kbot) + mvd_r(k) = MAX(mvd_r(k), xkrat*(r_mvd2-r_mvd1)+r_mvd1) + lamr = (4.0+mu_r) / mvd_r(k) + lam_exp = lamr * (crg(3)*org2*org1)**bm_r + N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) + N0_exp = MAX(DBLE(ronv_min), MIN(N0_exp, DBLE(ronv_max))) + lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + mvd_r(k) = (3.0+mu_r+0.672) / lamr + N0_r(k) = rr(k)*lamr**cre(3) / (am_r*crg(3)) + ilamr(k) = 1./lamr + enddo + +!.. Below melting layer, hold N0_r constant unless changes to mixing +!.. ratio increase mvd beyond 3 mm threshold, then adjust slope and +!.. intercept to cap mvd at 3 mm. In future, we could lower N0_r to +!.. account for self-collection or other sinks. + do k = kbot-1, kts, -1 + if (.not. L_qr(k)) CYCLE + N0_r(k) = MIN(N0_r(k), N0_r(kbot)) + lamr = (N0_r(k)*am_r*crg(3)/rr(k))**(1./cre(3)) + lam_exp = lamr * (crg(3)*org2*org1)**bm_r + N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) + N0_exp = MAX(DBLE(ronv_min), MIN(N0_exp, DBLE(ronv_max))) + lam_exp = (N0_exp*am_r*crg(1)/rr(k))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + mvd_r(k) = (3.0+mu_r+0.672) / lamr + if (mvd_r(k) .gt. 3.e-3) then + mvd_r(k) = 3.e-3 + lamr = (3.0+mu_r+0.672) / mvd_r(k) + endif + N0_r(k) = rr(k)*lamr**cre(3) / (am_r*crg(3)) + ilamr(k) = 1./lamr + enddo + endif + + endif + endif + +!+---+-----------------------------------------------------------------+ +!..Compute warm-rain process terms (except evap done later). +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + if (.not. L_qc(k)) CYCLE + Dc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6) + lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr + mvd_c(k) = (3.0+mu_c+0.672) / lamc + +!..Autoconversion follows Berry & Reinhardt (1974) with characteristic +!.. diameters correctly computed from gamma distrib of cloud droplets. + if (rc(k).gt. 0.01e-3) then + Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6 + Dc_b = (Dc*Dc*Dc*Dc_g*Dc_g*Dc_g - Dc*Dc*Dc*Dc*Dc*Dc)**(1./6.) + zeta1 = 0.5*((6.25E-6*Dc*Dc_b*Dc_b*Dc_b - 0.4) & + + abs(6.25E-6*Dc*Dc_b*Dc_b*Dc_b - 0.4)) + zeta = 0.027*rc(k)*zeta1 + taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 + tau = 3.72/(rc(k)*taud) + prr_wau(k) = zeta/tau + prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) + endif + +!..Rain collecting cloud water. In CE, assume Dc<1). Either way, only bother to do sedimentation below +!.. 1st level that contains any sedimenting particles (k=ksed1 on down). +!+---+-----------------------------------------------------------------+ + nstep = 0 + ksed1 = 0 + do k = kte+1, kts, -1 + vtrk(k) = 0. + vtik(k) = 0. + vtnk(k) = 0. + vtsk(k) = 0. + vtgk(k) = 0. + enddo + do k = kte, kts, -1 + vtr = 0. + vti = 0. + vts = 0. + vtg = 0. + rhof(k) = SQRT(RHO_NOT/rho(k)) + + if (rr(k).gt. R2) then + lamr = 1./ilamr(k) + vtr = rhof(k)*av_r*crg(6)*org3 * (lamr/(lamr+fv_r))**cre(3) & + *((lamr+fv_r)**(-bv_r)) + vtrk(k) = vtr + endif + + if (.not. iiwarm) then + if (ri(k).gt. R2) then + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + ilami = 1./lami + vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i + vtik(k) = vti + vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i + vtnk(k) = vti + endif + + if (rs(k).gt. R2) then + Ds = smoc(k) / smob(k) + Mrat = 1./Ds + ils1 = 1./(Mrat*Lam0 + fv_s) + ils2 = 1./(Mrat*Lam1 + fv_s) + t1_vts = Kap0*csg(4)*ils1**cse(4) + t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) + t3_vts = Kap0*csg(1)*ils1**cse(1) + t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) + vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) + if (temp(k).gt. T_0) then + vtsk(k) = MAX(vts*vts_boost(k), vtrk(k)) + else + vtsk(k) = vts*vts_boost(k) + endif + endif + + if (rg(k).gt. R2) then + vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g + if (temp(k).gt. T_0) then + vtgk(k) = MAX(vtg, vtrk(k)) + else + vtgk(k) = vtg + endif + endif + endif + + rgvm = MAX(vtik(k), vtrk(k), vtsk(k), vtgk(k)) + if (rgvm .gt. 1.E-3) then + ksed1 = MAX(ksed1, k) + delta_tp = dzq(k)/rgvm + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1 .eq. kte) ksed1 = kte-1 + if (nstep .gt. 0) onstep = 1./REAL(nstep) + +!+---+-----------------------------------------------------------------+ +!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, +!.. whereas neglect m(D) term for number concentration. Therefore, +!.. cloud ice has proper differential sedimentation. +!+---+-----------------------------------------------------------------+ + do n = 1, nstep + do k = kte, kts, -1 + sed_r(k) = vtrk(k)*rr(k) + sed_i(k) = vtik(k)*ri(k) + sed_n(k) = vtnk(k)*ni(k) + sed_g(k) = vtgk(k)*rg(k) + sed_s(k) = vtsk(k)*rs(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) - sed_r(k)*odzq*onstep*orho + qiten(k) = qiten(k) - sed_i(k)*odzq*onstep*orho + niten(k) = niten(k) - sed_n(k)*odzq*onstep*orho + qgten(k) = qgten(k) - sed_g(k)*odzq*onstep*orho + qsten(k) = qsten(k) - sed_s(k)*odzq*onstep*orho + rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep) + ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep) + ni(k) = MAX(1., ni(k) - sed_n(k)*odzq*DT*onstep) + rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep) + rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep) + do k = ksed1, kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*onstep*orho + qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*onstep*orho + niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep*orho + qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*onstep*orho + qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*onstep*orho + rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*DT*onstep) + ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*DT*onstep) + ni(k) = MAX(1., ni(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep) + rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*DT*onstep) + rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*DT*onstep) + enddo + +!+---+-----------------------------------------------------------------+ +!..Precipitation reaching the ground. +!+---+-----------------------------------------------------------------+ + pptrain = pptrain + sed_r(kts)*DT*onstep + pptsnow = pptsnow + sed_s(kts)*DT*onstep + pptgraul = pptgraul + sed_g(kts)*DT*onstep + pptice = pptice + sed_i(kts)*DT*onstep + + enddo + +!+---+-----------------------------------------------------------------+ +!.. Instantly melt any cloud ice into cloud water if above 0C and +!.. instantly freeze any cloud water found below HGFR. +!+---+-----------------------------------------------------------------+ + if (.not. iiwarm) then + do k = kts, kte + xri = MAX(0.0, qi1d(k) + qiten(k)*DT) + if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then + qcten(k) = qcten(k) + xri*odt + qiten(k) = -qi1d(k)*odt + niten(k) = -ni1d(k)*odt + tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) + endif + + xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) + if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then + lfus2 = lsub - lvap(k) + qiten(k) = qiten(k) + xrc*odt + niten(k) = niten(k) + xrc/(2.*xm0i)*odt + qcten(k) = -xrc*odt + tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) + endif + enddo + endif + +!+---+-----------------------------------------------------------------+ +!.. All tendencies computed, apply and pass back final values to parent. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + t1d(k) = t1d(k) + tten(k)*DT + qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) + qc1d(k) = qc1d(k) + qcten(k)*DT + if (qc1d(k) .le. R1) qc1d(k) = 0.0 + qi1d(k) = qi1d(k) + qiten(k)*DT + ni1d(k) = ni1d(k) + niten(k)*DT + if (qi1d(k) .le. R1) then + qi1d(k) = 0.0 + ni1d(k) = 0.0 + else + if (ni1d(k) .gt. 1.0) then + lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi + ilami = 1./lami + Di = (bm_i + mu_i + 1.) * ilami + if (Di.lt. 0.30*D0s) then + lami = cie(2)/(0.30*D0s) + ni1d(k) = MIN(5.D5, cig(1)*oig2*qi1d(k)/am_i*lami**bm_i) + elseif (Di.gt. 5.0*D0s) then + lami = cie(2)/(5.0*D0s) + ni1d(k) = cig(1)*oig2*qi1d(k)/am_i*lami**bm_i + endif + else + lami = cie(2)/(0.30*D0s) + ni1d(k) = MIN(5.D5, cig(1)*oig2*qi1d(k)/am_i*lami**bm_i) + endif + endif + qr1d(k) = qr1d(k) + qrten(k)*DT + if (qr1d(k) .le. R1) qr1d(k) = 0.0 + qs1d(k) = qs1d(k) + qsten(k)*DT + if (qs1d(k) .le. R1) qs1d(k) = 0.0 + qg1d(k) = qg1d(k) + qgten(k)*DT + if (qg1d(k) .le. R1) qg1d(k) = 0.0 + enddo + + end subroutine mp_thompson +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!..Creation of the lookup tables and support functions found below here. +!+---+-----------------------------------------------------------------+ +!..Rain collecting graupel (and inverse). Explicit CE integration. +!+---+-----------------------------------------------------------------+ + + subroutine qr_acr_qg + + implicit none + +!..Local variables + INTEGER:: i, j, k, n, n2 + INTEGER, PARAMETER:: nbr = 100 + INTEGER, PARAMETER:: nbg = 100 + DOUBLE PRECISION, DIMENSION(nbg):: Dg, vg, N_g, dtg + DOUBLE PRECISION, DIMENSION(nbr):: Dr, vr, N_r, dtr + DOUBLE PRECISION, DIMENSION(nbg+1):: Dx + DOUBLE PRECISION, DIMENSION(nbr+1):: Dy + DOUBLE PRECISION:: N0_exp, N0_r, N0_g, lam_exp, lamg, lamr, N0_s + DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2 + +!+---+ + +!..Create bins of rain (from min diameter up to 5 mm). + Dy(1) = D0r*1.0d0 + Dy(nbr+1) = 0.005d0 + do n2 = 2, nbr + Dy(n2) = DEXP(DFLOAT(n2-1)/DFLOAT(nbr) & + *DLOG(Dy(nbr+1)/Dy(1)) +DLOG(Dy(1))) + enddo + do n2 = 1, nbr + Dr(n2) = DSQRT(Dy(n2)*Dy(n2+1)) + vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) + dtr(n2) = Dy(n2+1) - Dy(n2) + enddo + +!..Create bins of graupel (from min diameter up to 5 cm). + Dx(1) = D0g*1.0d0 + Dx(nbg+1) = 0.05d0 + do n = 2, nbg + Dx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + *DLOG(Dx(nbg+1)/Dx(1)) +DLOG(Dx(1))) + enddo + do n = 1, nbg + Dg(n) = DSQRT(Dx(n)*Dx(n+1)) + vg(n) = av_g*Dg(n)**bv_g + dtg(n) = Dx(n+1) - Dx(n) + enddo + + do k = 1, ntb_r + do j = 1, ntb_r1 + + lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) + do n2 = 1, nbr + N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) + enddo + + do i = 1, ntb_g + N0_exp = 100.0d0/r_g(i) + N0_exp = DMAX1(gonv_min*1.d0,DMIN1(N0_exp,gonv_max*1.d0)) + lam_exp = (N0_exp*am_g*cgg(1)/r_g(i))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + N0_g = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + do n = 1, nbg + N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) + enddo + + t1 = 0.0d0 + t2 = 0.0d0 + z1 = 0.0d0 + z2 = 0.0d0 + do n2 = 1, nbr + massr = am_r * Dr(n2)**bm_r + do n = 1, nbg + massg = am_g * Dg(n)**bm_g + + dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) + dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) + + t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvg*massg * N_g(n)* N_r(n2) + z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvg*massr * N_g(n)* N_r(n2) + + t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvr*massr * N_g(n)* N_r(n2) + z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvr*massg * N_g(n)* N_r(n2) + enddo + 97 continue + enddo + tcg_racg(i,j,k) = t1 + tmr_racg(i,j,k) = DMIN1(z1, r_r(k)*1.0d0) + tcr_gacr(i,j,k) = t2 + tmg_gacr(i,j,k) = z2 + enddo + enddo + enddo + + end subroutine qr_acr_qg +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!..Rain collecting snow (and inverse). Explicit CE integration. +!+---+-----------------------------------------------------------------+ + + subroutine qr_acr_qs + + implicit none + +!..Local variables + INTEGER:: i, j, k, m, n, n2 + INTEGER, PARAMETER:: nbr = 100 + INTEGER, PARAMETER:: nbs = 100 + DOUBLE PRECISION, DIMENSION(nbr):: Dr, vr, D1, N_r, dtr + DOUBLE PRECISION, DIMENSION(nbs):: Ds, vs, N_s, dts + DOUBLE PRECISION, DIMENSION(nbr+1):: Dy + DOUBLE PRECISION, DIMENSION(nbs+1):: Dx + DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 + DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2 + DOUBLE PRECISION:: dvs, dvr, masss, massr + DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 + +!+---+ + +!..Create bins of rain (from min diameter up to 5 mm). + Dy(1) = D0r*1.0d0 + Dy(nbr+1) = 0.005d0 + do n2 = 2, nbr + Dy(n2) = DEXP(DFLOAT(n2-1)/DFLOAT(nbr) & + *DLOG(Dy(nbr+1)/Dy(1)) +DLOG(Dy(1))) + enddo + do n2 = 1, nbr + Dr(n2) = DSQRT(Dy(n2)*Dy(n2+1)) + vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) + D1(n2) = (vr(n2)/av_s)**(1./bv_s) + dtr(n2) = Dy(n2+1) - Dy(n2) + enddo + +!..Create bins of snow (from min diameter up to 2 cm). + Dx(1) = D0s*1.0d0 + Dx(nbs+1) = 0.02d0 + do n = 2, nbs + Dx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + *DLOG(Dx(nbs+1)/Dx(1)) +DLOG(Dx(1))) + enddo + do n = 1, nbs + Ds(n) = DSQRT(Dx(n)*Dx(n+1)) + vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) + dts(n) = Dx(n+1) - Dx(n) + enddo + + do m = 1, ntb_r + do k = 1, ntb_r1 + lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) + do n2 = 1, nbr + N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2) + enddo + + do j = 1, ntb_t + do i = 1, ntb_s + +!..From the bm_s moment, compute plus one moment. If we are not +!.. using bm_s=2, then we must transform to the pure 2nd moment +!.. (variable called "second") and then to the bm_s+1 moment. + + M2 = r_s(i)*oams *1.0d0 + if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then + loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s & + + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) & + + sa(6)*bm_s*bm_s + sa(7)*Tc(j)*Tc(j)*bm_s & + + sa(8)*Tc(j)*bm_s*bm_s + sa(9)*Tc(j)*Tc(j)*Tc(j) & + + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*Tc(j) + sb(3)*bm_s & + + sb(4)*Tc(j)*bm_s + sb(5)*Tc(j)*Tc(j) & + + sb(6)*bm_s*bm_s + sb(7)*Tc(j)*Tc(j)*bm_s & + + sb(8)*Tc(j)*bm_s*bm_s + sb(9)*Tc(j)*Tc(j)*Tc(j) & + + sb(10)*bm_s*bm_s*bm_s + second = (M2/a_)**(1./b_) + else + second = M2 + endif + + loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*cse(1) & + + sa(4)*Tc(j)*cse(1) + sa(5)*Tc(j)*Tc(j) & + + sa(6)*cse(1)*cse(1) + sa(7)*Tc(j)*Tc(j)*cse(1) & + + sa(8)*Tc(j)*cse(1)*cse(1) + sa(9)*Tc(j)*Tc(j)*Tc(j) & + + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+sb(2)*Tc(j)+sb(3)*cse(1) + sb(4)*Tc(j)*cse(1) & + + sb(5)*Tc(j)*Tc(j) + sb(6)*cse(1)*cse(1) & + + sb(7)*Tc(j)*Tc(j)*cse(1) + sb(8)*Tc(j)*cse(1)*cse(1) & + + sb(9)*Tc(j)*Tc(j)*Tc(j)+sb(10)*cse(1)*cse(1)*cse(1) + M3 = a_ * second**b_ + + oM3 = 1./M3 + Mrat = M2*(M2*oM3)*(M2*oM3)*(M2*oM3) + M0 = (M2*oM3)**mu_s + slam1 = M2 * oM3 * Lam0 + slam2 = M2 * oM3 * Lam1 + + do n = 1, nbs + N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) & + + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n) + enddo + + t1 = 0.0d0 + t2 = 0.0d0 + t3 = 0.0d0 + t4 = 0.0d0 + z1 = 0.0d0 + z2 = 0.0d0 + z3 = 0.0d0 + z4 = 0.0d0 + do n2 = 1, nbr + massr = am_r * Dr(n2)**bm_r + do n = 1, nbs + masss = am_s * Ds(n)**bm_s + + dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n))) + dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2))) + + if (massr .gt. masss) then + t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvs*masss * N_s(n)* N_r(n2) + z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvs*massr * N_s(n)* N_r(n2) + else + t3 = t3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvs*masss * N_s(n)* N_r(n2) + z3 = z3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvs*massr * N_s(n)* N_r(n2) + endif + + if (massr .gt. masss) then + t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvr*massr * N_s(n)* N_r(n2) + z2 = z2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvr*masss * N_s(n)* N_r(n2) + else + t4 = t4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvr*massr * N_s(n)* N_r(n2) + z4 = z4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & + *dvr*masss * N_s(n)* N_r(n2) + endif + + enddo + enddo + tcs_racs1(i,j,k,m) = t1 + tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) + tcs_racs2(i,j,k,m) = t3 + tmr_racs2(i,j,k,m) = z3 + tcr_sacr1(i,j,k,m) = t2 + tms_sacr1(i,j,k,m) = z2 + tcr_sacr2(i,j,k,m) = t4 + tms_sacr2(i,j,k,m) = z4 + enddo + enddo + enddo + enddo + + end subroutine qr_acr_qs +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!..This is a literal adaptation of Bigg (1954) probability of drops of +!..a particular volume freezing. Given this probability, simply freeze +!..the proportion of drops summing their masses. +!+---+-----------------------------------------------------------------+ + + subroutine freezeH2O + + implicit none + +!..Local variables + INTEGER:: i, j, k, n, n2 + INTEGER, PARAMETER:: nbr = 100 + INTEGER, PARAMETER:: nbc = 50 + DOUBLE PRECISION, DIMENSION(nbr):: Dr, N_r, dtr, massr + DOUBLE PRECISION, DIMENSION(nbr+1):: Dy + DOUBLE PRECISION, DIMENSION(nbc):: Dc, N_c, dtc, massc + DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & + prob, vol, Texp, orho_w, & + lam_exp, lamr, N0_r, lamc, N0_c, y + +!+---+ + + orho_w = 1./rho_w + +!..Create bins of rain (from min diameter up to 5 mm). + Dy(1) = D0r*1.0d0 + Dy(nbr+1) = 0.005d0 + do n2 = 2, nbr + Dy(n2) = DEXP(DFLOAT(n2-1)/DFLOAT(nbr) & + *DLOG(Dy(nbr+1)/Dy(1)) +DLOG(Dy(1))) + enddo + do n2 = 1, nbr + Dr(n2) = DSQRT(Dy(n2)*Dy(n2+1)) + massr(n2) = am_r*Dr(n2)**bm_r + dtr(n2) = Dy(n2+1) - Dy(n2) + enddo + +!..Create bins of cloud water (from min diameter up to 50 microns). + Dc(1) = D0c*1.0d0 + massc(1) = am_r*Dc(1)**bm_r + dtc(1) = D0c*1.0D6 + do n = 2, nbc + Dc(n) = Dc(n-1) + 1.0D-6 + massc(n) = am_r*Dc(n)**bm_r + dtc(n) = (Dc(n) - Dc(n-1)) * 1.0D6 + enddo + +!..Freeze water (smallest drops become cloud ice, otherwise graupel). + do k = 1, 45 +! print*, ' Freezing water for temp = ', -k + Texp = DEXP( DFLOAT(k) ) - 1.0D0 + do j = 1, ntb_r1 + do i = 1, ntb_r + lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) + sum1 = 0.0d0 + sum2 = 0.0d0 + sumn1 = 0.0d0 + do n2 = 1, nbr + N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) + vol = massr(n2)*orho_w + prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) + if (massr(n2) .lt. xm0g) then + sumn1 = sumn1 + prob*N_r(n2) + sum1 = sum1 + prob*N_r(n2)*massr(n2) + else + sum2 = sum2 + prob*N_r(n2)*massr(n2) + endif + enddo + tpi_qrfz(i,j,k) = sum1 + tni_qrfz(i,j,k) = sumn1 + tpg_qrfz(i,j,k) = sum2 + enddo + enddo + do i = 1, ntb_c + lamc = 1.0D-6 * (Nt_c*am_r* ccg(2) * ocg1 / r_c(i))**obmr + N0_c = 1.0D-18 * Nt_c*ocg1 * lamc**cce(1) + sum1 = 0.0d0 + sumn2 = 0.0d0 + do n = 1, nbc + y = Dc(n)*1.0D6 + vol = massc(n)*orho_w + prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) + N_c(n) = N0_c* y**mu_c * EXP(-lamc*y)*dtc(n) + N_c(n) = 1.0D18 * N_c(n) + sumn2 = sumn2 + prob*N_c(n) + sum1 = sum1 + prob*N_c(n)*massc(n) + enddo + tpi_qcfz(i,k) = sum1 + tni_qcfz(i,k) = sumn2 + enddo + enddo + + end subroutine freezeH2O +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ +!..Cloud ice converting to snow since portion greater than min snow +!.. size. Given cloud ice content (kg/m**3), number concentration +!.. (#/m**3) and gamma shape parameter, mu_i, break the distrib into +!.. bins and figure out the mass/number of ice with sizes larger than +!.. D0s. Also, compute incomplete gamma function for the integration +!.. of ice depositional growth from diameter=0 to D0s. Amount of +!.. ice depositional growth is this portion of distrib while larger +!.. diameters contribute to snow growth (as in Harrington et al. 1995). +!+---+-----------------------------------------------------------------+ + + subroutine qi_aut_qs + + implicit none + +!..Local variables + INTEGER:: i, j, n2 + INTEGER, PARAMETER:: nbi = 100 + DOUBLE PRECISION, DIMENSION(nbi):: Di, N_i, dti + DOUBLE PRECISION, DIMENSION(nbi+1):: Dy + DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2 + +!+---+ + +!..Create bins of cloud ice (from min diameter up to 10x min snow size). + Dy(1) = D0i*1.0d0 + Dy(nbi+1) = 10.0d0*D0s + do n2 = 2, nbi + Dy(n2) = DEXP(DFLOAT(n2-1)/DFLOAT(nbi) & + *DLOG(Dy(nbi+1)/Dy(1)) +DLOG(Dy(1))) + enddo + do n2 = 1, nbi + Di(n2) = DSQRT(Dy(n2)*Dy(n2+1)) + dti(n2) = Dy(n2+1) - Dy(n2) + enddo + + do j = 1, ntb_i1 + do i = 1, ntb_i + lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi + Di_mean = (bm_i + mu_i + 1.) / lami + N0_i = Nt_i(j)*oig1 * lami**cie(1) + t1 = 0.0d0 + t2 = 0.0d0 + if (SNGL(Di_mean) .gt. 5.*D0s) then + t1 = r_i(i) + t2 = Nt_i(j) + tpi_ide(i,j) = 0.0D0 + elseif (SNGL(Di_mean) .lt. D0i) then + t1 = 0.0D0 + t2 = 0.0D0 + tpi_ide(i,j) = 1.0D0 + else + tpi_ide(i,j) = GAMMP(mu_i+2.0, SNGL(lami)*D0s) * 1.0D0 + do n2 = 1, nbi + N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) + if (Di(n2).ge.D0s) then + t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i + t2 = t2 + N_i(n2) + endif + enddo + endif + tps_iaus(i,j) = t1 + tni_iaus(i,j) = t2 + enddo + enddo + + end subroutine qi_aut_qs +!+---+-----------------------------------------------------------------+ +!+---+-----------------------------------------------------------------+ + SUBROUTINE GCF(GAMMCF,A,X,GLN) +! --- RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS +! --- CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS +! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY +! --- A MODIFIED LENTZ METHOD. +! --- USES GAMMLN + IMPLICIT NONE + INTEGER, PARAMETER:: ITMAX=100 + REAL, PARAMETER:: gEPS=3.E-7 + REAL, PARAMETER:: FPMIN=1.E-30 + REAL, INTENT(IN):: A, X + REAL:: GAMMCF,GLN + INTEGER:: I + REAL:: AN,B,C,D,DEL,H + GLN=GAMMLN(A) + B=X+1.-A + C=1./FPMIN + D=1./B + H=D + DO 11 I=1,ITMAX + AN=-I*(I-A) + B=B+2. + D=AN*D+B + IF(ABS(D).LT.FPMIN)D=FPMIN + C=B+AN/C + IF(ABS(C).LT.FPMIN)C=FPMIN + D=1./D + DEL=D*C + H=H*DEL + IF(ABS(DEL-1.).LT.gEPS)GOTO 1 + 11 CONTINUE + PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF' + 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H + END SUBROUTINE GCF +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + SUBROUTINE GSER(GAMSER,A,X,GLN) +! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS +! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) +! --- AS GLN. +! --- USES GAMMLN + IMPLICIT NONE + INTEGER, PARAMETER:: ITMAX=100 + REAL, PARAMETER:: gEPS=3.E-7 + REAL, INTENT(IN):: A, X + REAL:: GAMSER,GLN + INTEGER:: N + REAL:: AP,DEL,SUM + GLN=GAMMLN(A) + IF(X.LE.0.)THEN + IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' + GAMSER=0. + RETURN + ENDIF + AP=A + SUM=1./A + DEL=SUM + DO 11 N=1,ITMAX + AP=AP+1. + DEL=DEL*X/AP + SUM=SUM+DEL + IF(ABS(DEL).LT.ABS(SUM)*gEPS)GOTO 1 + 11 CONTINUE + PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER' + 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) + END SUBROUTINE GSER +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION GAMMLN(XX) +! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. + IMPLICIT NONE + REAL, INTENT(IN):: XX + DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 + DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + COF = (/76.18009172947146D0, -86.50532032941677D0, & + 24.01409824083091D0, -1.231739572450155D0, & + .1208650973866179D-2, -.5395239384953D-5/) + DOUBLE PRECISION:: SER,TMP,X,Y + INTEGER:: J + + X=XX + Y=X + TMP=X+5.5D0 + TMP=(X+0.5D0)*LOG(TMP)-TMP + SER=1.000000000190015D0 + DO 11 J=1,6 + Y=Y+1.D0 + SER=SER+COF(J)/Y +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER/X) + END FUNCTION GAMMLN +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION GAMMP(A,X) +! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) +! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 +! --- USES GCF,GSER + IMPLICIT NONE + REAL, INTENT(IN):: A,X + REAL:: GAMMCF,GAMSER,GLN + GAMMP = 0. + IF((X.LT.0.) .OR. (A.LE.0.)) THEN + PRINT *, 'BAD ARGUMENTS IN GAMMP' + RETURN + ELSEIF(X.LT.A+1.)THEN + CALL GSER(GAMSER,A,X,GLN) + GAMMP=GAMSER + ELSE + CALL GCF(GAMMCF,A,X,GLN) + GAMMP=1.-GAMMCF + ENDIF + END FUNCTION GAMMP +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION WGAMMA(y) + + IMPLICIT NONE + REAL, INTENT(IN):: y + + WGAMMA = EXP(GAMMLN(y)) + + END FUNCTION WGAMMA +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS +! A FUNCTION OF TEMPERATURE AND PRESSURE +! + REAL FUNCTION RSLF(P,T) + + IMPLICIT NONE + REAL, INTENT(IN):: P, T + REAL:: ESL,X + REAL, PARAMETER:: C0= .611583699E03 + REAL, PARAMETER:: C1= .444606896E02 + REAL, PARAMETER:: C2= .143177157E01 + REAL, PARAMETER:: C3= .264224321E-1 + REAL, PARAMETER:: C4= .299291081E-3 + REAL, PARAMETER:: C5= .203154182E-5 + REAL, PARAMETER:: C6= .702620698E-8 + REAL, PARAMETER:: C7= .379534310E-11 + REAL, PARAMETER:: C8=-.321582393E-13 + + X=MAX(-80.,T-273.16) + +! ESL=612.2*EXP(17.67*X/(T-29.65)) + ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + RSLF=.622*ESL/(P-ESL) + + END FUNCTION RSLF +! +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A +! FUNCTION OF TEMPERATURE AND PRESSURE +! + REAL FUNCTION RSIF(P,T) + + IMPLICIT NONE + REAL, INTENT(IN):: P, T + REAL:: ESI,X + REAL, PARAMETER:: C0= .609868993E03 + REAL, PARAMETER:: C1= .499320233E02 + REAL, PARAMETER:: C2= .184672631E01 + REAL, PARAMETER:: C3= .402737184E-1 + REAL, PARAMETER:: C4= .565392987E-3 + REAL, PARAMETER:: C5= .521693933E-5 + REAL, PARAMETER:: C6= .307839583E-7 + REAL, PARAMETER:: C7= .105785160E-9 + REAL, PARAMETER:: C8= .161444444E-12 + + X=MAX(-80.,T-273.16) + ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + RSIF=.622*ESI/(P-ESI) + + END FUNCTION RSIF +!+---+-----------------------------------------------------------------+ +END MODULE module_mp_thompson +!+---+-----------------------------------------------------------------+ +! +! MODIFICATIONS TO MAKE IN OTHER MODULES +! +! Use this new code by changing the "THOMPSON" section of code found +! in "module_microphysics_driver.F" with this section. [Of course +! remove the leading comment character that you see here.] +! +! CASE (THOMPSON) +! CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson et al' ) +! IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND. & +! PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND. & +! PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND. & +! PRESENT ( QNI_CURR ).AND. & +! PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN +! CALL mp_gt_driver( & +! QV=qv_curr, & +! QC=qc_curr, & +! QR=qr_curr, & +! QI=qi_curr, & +! QS=qs_curr, & +! QG=qg_curr, & +! NI=qni_curr, & +! TH=th, & +! PII=pi_phy, & +! P=p, & +! DZ=dz8w, & +! DT_IN=dt, & +! ITIMESTEP=itimestep, & +! RAINNC=RAINNC, & +! RAINNCV=RAINNCV, & +! SR=SR & +! ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & +! ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & +! ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) +! ELSE +! CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' ) +! ENDIF +! +! Then rename the call from "thomp_init" to "thompson_init" in the file +! "module_physics_init.F" (seen below): +! +! CASE (THOMPSON) +! CALL thompson_init diff --git a/wrfv2_fire/phys/module_mp_wsm3.F b/wrfv2_fire/phys/module_mp_wsm3.F new file mode 100644 index 00000000..d60990e2 --- /dev/null +++ b/wrfv2_fire/phys/module_mp_wsm3.F @@ -0,0 +1,987 @@ +#if ( RWORDSIZE == 4 ) +# define VREC vsrec +# define VSQRT vssqrt +#else +# define VREC vrec +# define VSQRT vsqrt +#endif + +MODULE module_mp_wsm3 +! +! + REAL, PARAMETER, PRIVATE :: dtcldcr = 120. + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 + REAL, PARAMETER, PRIVATE :: avtr = 841.9 + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + REAL, PARAMETER, PRIVATE :: avts = 11.72 + REAL, PARAMETER, PRIVATE :: bvts = .41 + REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! t=-90C unlimited + REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 + REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 + REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 + REAL, PARAMETER, PRIVATE :: betai = .6 + REAL, PARAMETER, PRIVATE :: xn0 = 1.e-2 + REAL, PARAMETER, PRIVATE :: dicon = 11.9 + REAL, PARAMETER, PRIVATE :: di0 = 12.9e-6 + REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent n0s + REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 + REAL, SAVE :: & + qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr,& + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + precr1,precr2,xm0,xmmax,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r,& + pidn0s,xlv1, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max +! +! Specifies code-inlining of fpvs function in WSM32D below. JM 20040507 +! +CONTAINS +!=================================================================== +! + SUBROUTINE wsm3(th, q, qci, qrs & + , w, den, pii, p, delz & + , delt,g, cpd, cpv, rd, rv, t0c & + , ep1, ep2, qmin & + , XLS, XLV0, XLF0, den0, denr & + , cliq,cice,psat & + , rain, rainncv & + ,snow, snowncv & + ,sr & + , ids,ide, jds,jde, kds,kde & + , ims,ime, jms,jme, kms,kme & + , its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! +! This code is a 3-class simple ice microphyiscs scheme (WSM3) of the WRF +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! Production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM3 cloud scheme +! +! Coded by Song-You Hong (Yonsei Univ.) +! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) +! Summer 2002 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2003 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Dudhia (D89, 1989) J. Atmos. Sci. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qci, & + qrs + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: w, & + den, & + pii, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + t0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv + +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: t + INTEGER :: i,j,k +!------------------------------------------------------------------- + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + ENDDO + ENDDO + CALL wsm32D(t, q(ims,kms,j), qci(ims,kms,j) & + ,qrs(ims,kms,j),w(ims,kms,j), den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,j & + ,rain(ims,j), rainncv(ims,j) & + ,sr(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow(ims,j),snowncv(ims,j) & + ) + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + ENDDO + ENDDO + ENDDO + END SUBROUTINE wsm3 +!=================================================================== +! + SUBROUTINE wsm32D(t, q, qci, qrs,w, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain, rainncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow,snowncv & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte, & + lat + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q, & + qci, & + qrs + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: w, & + den, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: & + rh, qs, denfac, rslope, rslope2, rslope3, rslopeb, & + pgen, paut, pacr, pisd, pres, pcon, fall, falk, & + xl, cpm, work1, work2, xni, qs0, n0sfac + REAL, DIMENSION( its:ite , kts:kte ) :: & + falkc, work1c, work2c, fallc +! variables for optimization + REAL, DIMENSION( its:ite ) :: tvec1 + INTEGER, DIMENSION( its:ite ) :: mstep, numdt + LOGICAL, DIMENSION( its:ite ) :: flgcld + REAL :: pi, & + cpmcal, xlcal, lamdar, lamdas, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + fallsum, fallsum_qsi, vt2i,vt2s,acrfac, & + qdt, pvt, qik, delq, facq, qrsci, frzmlt, & + snomlt, hold, holdrs, facqci, supcol, coeres, & + supsat, dtcld, xmi, qciik, delqci, eacrs, satdt, & + qimax, diameter, xni0, roqi0, supice + REAL :: holdc, holdci + INTEGER :: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, kk, n +! Temporaries used for inlining fpvs function + REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! +! Optimizatin : A**B => exp(log(A)*(B)) + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! + diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) +! venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & +! /viscos(b,c)**(.5)*(den0/c)**0.25 + venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & + /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! + pi = 4. * atan(1.) +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k) = max(qci(i,k),0.0) + qrs(i,k) = max(qrs(i,k),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! +! do k = kts, kte +! do i = its, ite +! denfac(i,k) = sqrt(den0/den(i,k)) +! enddo +! enddo + do k = kts, kte + CALL VREC( tvec1(its), den(its,k), ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) + enddo +! +! Inline expansion for fpvs +! qs(i,k) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs0(i,k) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + cvap = cpv + hvap=xlv0 + hsub=xls + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite +! tr=ttp/t(i,k) +! if(t(i,k).lt.ttp) then +! qs(i,k) =psat*(tr**xai)*exp(xbi*(1.-tr)) +! else +! qs(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) +! endif +! qs0(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k) =psat*(exp(log(tr)*(xai)))*exp(xbi*(1.-tr)) + else + qs(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + endif + qs0(i,k) =psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + qs0(i,k) = (qs0(i,k)-qs(i,k))/qs(i,k) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + rh(i,k) = max(q(i,k) / qs(i,k),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + pres(i,k) = 0. + paut(i,k) = 0. + pacr(i,k) = 0. + pgen(i,k) = 0. + pisd(i,k) = 0. + pcon(i,k) = 0. + fall(i,k) = 0. + falk(i,k) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).ge.t0c) then + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) +! rslopeb(i,k) = rslope(i,k)**bvtr + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + else + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) +! rslopeb(i,k) = rslope(i,k)**bvts + rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + endif +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k),qmin))**0.75,1.e3),1.e6) + xni(i,k) = min(max(5.38e7*exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + enddo + enddo +! + mstepmax = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + if(t(i,k).lt.t0c) then + pvt = pvts + else + pvt = pvtr + endif + work1(i,k) = pvt*rslopeb(i,k)*denfac(i,k) + work2(i,k) = work1(i,k)/delz(i,k) + numdt(i) = max(nint(work2(i,k)*dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) + hold = falk(i,k) + fall(i,k) = fall(i,k)+falk(i,k) + holdrs = qrs(i,k) + qrs(i,k) = max(qrs(i,k)-falk(i,k)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) + hold = falk(i,k) + fall(i,k) = fall(i,k)+falk(i,k) + holdrs = qrs(i,k) + qrs(i,k) = max(qrs(i,k)-(falk(i,k) & + -falk(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + mstepmax = 1 + mstep = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + if(t(i,k).lt.t0c.and.qci(i,k).gt.0.) then + xmi = den(i,k)*qci(i,k)/xni(i,k) +! diameter = dicon * sqrt(xmi) +! work1c(i,k) = 1.49e4*diameter**1.31 + diameter = max(dicon * sqrt(xmi), 1.e-25) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) + else + work1c(i,k) = 0. + endif + if(qci(i,k).le.0.) then + work2c(i,k) = 0. + else + work2c(i,k) = work1c(i,k)/delz(i,k) + endif + numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if (n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k) + qci(i,k) = max(qci(i,k)-falkc(i,k)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if (n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k) + qci(i,k) = max(qci(i,k)-(falkc(i,k) & + -falkc(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + enddo +! +!---------------------------------------------------------------- +! compute the freezing/melting term. [D89 B16-B17] +! freezing occurs one layer above the melting level +! + do i = its, ite + mstep(i) = 0 + enddo + do k = kts, kte +! + do i = its, ite + if(t(i,k).ge.t0c) then + mstep(i) = k + endif + enddo + enddo +! + do i = its, ite + if(mstep(i).ne.0.and.w(i,mstep(i)).gt.0.) then + work1(i,1) = float(mstep(i) + 1) + work1(i,2) = float(mstep(i)) + else + work1(i,1) = float(mstep(i)) + work1(i,2) = float(mstep(i)) + endif + enddo +! + do i = its, ite + k = nint(work1(i,1)) + kk = nint(work1(i,2)) + if(k*kk.ge.1) then + qrsci = qrs(i,k) + qci(i,k) + if(qrsci.gt.0..or.fall(i,kk).gt.0.) then + frzmlt = min(max(-w(i,k)*qrsci/delz(i,k),-qrsci/dtcld), & + qrsci/dtcld) + snomlt = min(max(fall(i,kk)/den(i,kk),-qrs(i,k)/dtcld), & + qrs(i,k)/dtcld) + if(k.eq.kk) then + t(i,k) = t(i,k) - xlf0/cpm(i,k)*(frzmlt+snomlt)*dtcld + else + t(i,k) = t(i,k) - xlf0/cpm(i,k)*frzmlt*dtcld + t(i,kk) = t(i,kk) - xlf0/cpm(i,kk)*snomlt*dtcld + endif + endif + endif + enddo +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,1) + fallsum_qsi = 0. + if((t0c-t(i,1)).gt.0) then + fallsum = fallsum+fallc(i,1) + fallsum_qsi = fall(i,1)+fallc(i,1) + endif + rainncv(i) = 0. + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. & + + rain(i) + endif + IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN + snowncv(i) = 0. + if(fallsum_qsi.gt.0.) then + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + endif + ENDIF + sr(i) = 0. + if(fallsum.gt.0.)sr(i)=fallsum_qsi*delz(i,kts)/denr*dtcld*1000./(rainncv(i)+1.e-12) + enddo +! +!---------------------------------------------------------------- +! rsloper: reverse of the slope parameter of the rain(m) +! xka: thermal conductivity of air(jm-1s-1k-1) +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + else + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + endif + enddo + enddo +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + work1(i,k) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k)) + else + work1(i,k) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k)) + endif + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k) + satdt = supsat/dtcld + if(t(i,k).ge.t0c) then +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qci(i,k).gt.qc0) then +! paut(i,k) = qck1*qci(i,k)**(7./3.) + paut(i,k) = qck1*exp(log(qci(i,k))*((7./3.))) + paut(i,k) = min(paut(i,k),qci(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [D89 B15] +! (C->R) +!--------------------------------------------------------------- + if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then + pacr(i,k) = min(pacrr*rslope3(i,k)*rslopeb(i,k) & + *qci(i,k)*denfac(i,k),qci(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qrs(i,k).gt.0.) then + coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*(precr1*rslope2(i,k) & + +precr2*work2(i,k)*coeres)/work1(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(pres(i,k),satdt/2) + else + pres(i,k) = min(pres(i,k),satdt/2) + endif + endif + else +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + supcol = t0c-t(i,k) + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k),qmin))**0.75,1.e3),1.e6) + xni(i,k) = min(max(5.38e7*exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) +! + if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then + xmi = den(i,k)*qci(i,k)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2s = pvts*rslopeb(i,k)*denfac(i,k) +!------------------------------------------------------------- +! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] +! (TR) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k)+2.*diameter*rslope2(i,k) & + +diameter**2*rslope(i,k) + pacr(i,k) = min(pi*qci(i,k)*eacrs*n0s*n0sfac(i,k) & + *abs(vt2s-vt2i)*acrfac/4.,qci(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pidep: Deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qci(i,k).gt.0.) then + xmi = den(i,k)*qci(i,k)/xni(i,k) + diameter = dicon * sqrt(xmi) + pisd(i,k) = 4.*diameter*xni(i,k)*(rh(i,k)-1.)/work1(i,k) + if(pisd(i,k).lt.0.) then + pisd(i,k) = max(pisd(i,k),satdt/2) + pisd(i,k) = max(pisd(i,k),-qci(i,k)/dtcld) + else + pisd(i,k) = min(pisd(i,k),satdt/2) + endif + if(abs(pisd(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (V->S or S->V) +!------------------------------------------------------------- + if(qrs(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k)*sqrt(rslope(i,k)*rslopeb(i,k)) + pres(i,k) = (rh(i,k)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k) & + +precs2*work2(i,k)*coeres)/work1(i,k) + supice = satdt-pisd(i,k) + if(pres(i,k).lt.0.) then + pres(i,k) = max(pres(i,k),-qrs(i,k)/dtcld) + pres(i,k) = max(max(pres(i,k),satdt/2),supice) + else + pres(i,k) = min(min(pres(i,k),satdt/2),supice) + endif + if(abs(pisd(i,k)+pres(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-pisd(i,k)-pres(i,k) + xni0 = 1.e3*exp(0.1*supcol) +! roqi0 = 4.92e-11*xni0**1.33 + roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) + pgen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k),0.))/dtcld) + pgen(i,k) = min(min(pgen(i,k),satdt),supice) + endif +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qci(i,k).gt.0.) then + qimax = roqimax/den(i,k) + paut(i,k) = max(0.,(qci(i,k)-qimax)/dtcld) + endif + endif + enddo + enddo +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite + qciik = max(qmin,qci(i,k)) + delqci = (paut(i,k)+pacr(i,k)-pgen(i,k)-pisd(i,k))*dtcld + if(delqci.ge.qciik) then + facqci = qciik/delqci + paut(i,k) = paut(i,k)*facqci + pacr(i,k) = pacr(i,k)*facqci + pgen(i,k) = pgen(i,k)*facqci + pisd(i,k) = pisd(i,k)*facqci + endif + qik = max(qmin,q(i,k)) + delq = (pres(i,k)+pgen(i,k)+pisd(i,k))*dtcld + if(delq.ge.qik) then + facq = qik/delq + pres(i,k) = pres(i,k)*facq + pgen(i,k) = pgen(i,k)*facq + pisd(i,k) = pisd(i,k)*facq + endif + work2(i,k) = -pres(i,k)-pgen(i,k)-pisd(i,k) + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k) = max(qci(i,k)-(paut(i,k)+pacr(i,k)-pgen(i,k) & + -pisd(i,k))*dtcld,0.) + qrs(i,k) = max(qrs(i,k)+(paut(i,k)+pacr(i,k) & + +pres(i,k))*dtcld,0.) + if(t(i,k).lt.t0c) then + t(i,k) = t(i,k)-xls*work2(i,k)/cpm(i,k)*dtcld + else + t(i,k) = t(i,k)-xl(i,k)*work2(i,k)/cpm(i,k)*dtcld + endif + enddo + enddo +! + cvap = cpv + hvap = xlv0 + hsub = xls + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) +! qs(i,k)=psat*(tr**xa)*exp(xb*(1.-tr)) + qs(i,k)=psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) + qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) + qs(i,k) = max(qs(i,k),qmin) + denfac(i,k) = sqrt(den0/den(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite + work1(i,k) = conden(t(i,k),q(i,k),qs(i,k),xl(i,k),cpm(i,k)) + work2(i,k) = qci(i,k)+work1(i,k) + pcon(i,k) = min(max(work1(i,k),0.),max(q(i,k),0.))/dtcld + if(qci(i,k).gt.0..and.work1(i,k).lt.0.and.t(i,k).gt.t0c) & + pcon(i,k) = max(work1(i,k),-qci(i,k))/dtcld + q(i,k) = q(i,k)-pcon(i,k)*dtcld + qci(i,k) = max(qci(i,k)+pcon(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qci(i,k).le.qmin) qci(i,k) = 0.0 + enddo + enddo +! + enddo ! big loops + END SUBROUTINE wsm32D +! ................................................................... + REAL FUNCTION rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + PARAMETER (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + END FUNCTION rgmma +! +!-------------------------------------------------------------------------- + REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs +!------------------------------------------------------------------- + SUBROUTINE wsm3init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + LOGICAL, INTENT(IN) :: allowed_to_read + REAL :: pi +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xm0 = (di0/dicon)**2 + xmmax = (dimax/dicon)**2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax +! + END SUBROUTINE wsm3init +END MODULE module_mp_wsm3 diff --git a/wrfv2_fire/phys/module_mp_wsm5.F b/wrfv2_fire/phys/module_mp_wsm5.F new file mode 100644 index 00000000..c6570a1e --- /dev/null +++ b/wrfv2_fire/phys/module_mp_wsm5.F @@ -0,0 +1,1195 @@ +#if ( RWORDSIZE == 4 ) +# define VREC vsrec +# define VSQRT vssqrt +#else +# define VREC vrec +# define VSQRT vsqrt +#endif + +!Including inline expansion statistical function +MODULE module_mp_wsm5 +! +! + REAL, PARAMETER, PRIVATE :: dtcldcr = 120. + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 + REAL, PARAMETER, PRIVATE :: avtr = 841.9 + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + REAL, PARAMETER, PRIVATE :: avts = 11.72 + REAL, PARAMETER, PRIVATE :: bvts = .41 + REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! t=-90C unlimited + REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 + REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 + REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 + REAL, PARAMETER, PRIVATE :: betai = .6 + REAL, PARAMETER, PRIVATE :: xn0 = 1.e-2 + REAL, PARAMETER, PRIVATE :: dicon = 11.9 + REAL, PARAMETER, PRIVATE :: di0 = 12.9e-6 + REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent n0s + REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s + REAL, PARAMETER, PRIVATE :: pfrz1 = 100. + REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 + REAL, PARAMETER, PRIVATE :: t40c = 233.16 + REAL, PARAMETER, PRIVATE :: eacrc = 1.0 + REAL, SAVE :: & + qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr,& + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + precr1,precr2,xm0,xmmax,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r,& + pidn0s,xlv1,pacrc, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max +! +! Specifies code-inlining of fpvs function in WSM52D below. JM 20040507 +! +CONTAINS +!=================================================================== +! + SUBROUTINE wsm5(th, q, qc, qr, qi, qs & + ,den, pii, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,rain, rainncv & + ,snow, snowncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! This code is a 5-class mixed ice microphyiscs scheme (WSM5) of the WRF +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! Production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM5 cloud scheme +! +! Coded by Song-You Hong (Yonsei Univ.) +! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) +! Summer 2002 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2003 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qc, & + qi, & + qr, & + qs + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + den, & + pii, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + t0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv + +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: t + REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs + INTEGER :: i,j,k +!------------------------------------------------------------------- + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + qci(i,k,1) = qc(i,k,j) + qci(i,k,2) = qi(i,k,j) + qrs(i,k,1) = qr(i,k,j) + qrs(i,k,2) = qs(i,k,j) + ENDDO + ENDDO + CALL wsm52D(t, q(ims,kms,j), qci, qrs & + ,den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,j & + ,rain(ims,j),rainncv(ims,j) & + ,sr(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow(ims,j),snowncv(ims,j) & + ) + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + qc(i,k,j) = qci(i,k,1) + qi(i,k,j) = qci(i,k,2) + qr(i,k,j) = qrs(i,k,1) + qs(i,k,j) = qrs(i,k,2) + ENDDO + ENDDO + ENDDO + END SUBROUTINE wsm5 +!=================================================================== +! + SUBROUTINE wsm52D(t, q, qci, qrs, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain,rainncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow,snowncv & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte, & + lat + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( its:ite , kts:kte, 2 ), & + INTENT(INOUT) :: & + qci, & + qrs + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: & + den, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv + +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte , 2) :: & + rh, qs, rslope, rslope2, rslope3, rslopeb, & + falk, fall, work1 + REAL, DIMENSION( its:ite , kts:kte ) :: & + falkc, work1c, work2c, fallc + REAL, DIMENSION( its:ite , kts:kte ) :: & + praut, psaut, prevp, psdep, pracw, psaci, psacw, & + pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp, denfac, xni,& + n0sfac +! variables for optimization + REAL, DIMENSION( its:ite ) :: tvec1 + INTEGER, DIMENSION( its:ite ) :: mstep, numdt + REAL, DIMENSION(its:ite) :: rmstep + REAL dtcldden, rdelz, rdtcld + LOGICAL, DIMENSION( its:ite ) :: flgcld + REAL :: pi, & + cpmcal, xlcal, lamdar, lamdas, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, holdrr, holdrs, supcol, pvt, & + coeres, supsat, dtcld, xmi, eacrs, satdt, & + vt2i,vt2s,acrfac, & + qimax, diameter, xni0, roqi0, & + fallsum, fallsum_qsi, xlwork2, factor, source, & + value, xlf, pfrzdtc, pfrzdtr, supice + REAL :: temp + REAL :: holdc, holdci + INTEGER :: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, n +! Temporaries used for inlining fpvs function + REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! +! Optimizatin : A**B => exp(log(A)*(B)) + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y +! viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y +! xka(x,y) = 1.414e3*viscos(x,y)*y +! diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) +! venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & +! /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) +! conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! +! + pi = 4. * atan(1.) +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k,1) = max(qci(i,k,1),0.0) + qrs(i,k,1) = max(qrs(i,k,1),0.0) + qci(i,k,2) = max(qci(i,k,2),0.0) + qrs(i,k,2) = max(qrs(i,k,2),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! +! do k = kts, kte +! do i = its, ite +! denfac(i,k) = sqrt(den0/den(i,k)) +! enddo +! enddo + do k = kts, kte + CALL VREC( tvec1(its), den(its,k), ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) + enddo +! +! Inline expansion for fpvs +! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + prevp(i,k) = 0. + psdep(i,k) = 0. + praut(i,k) = 0. + psaut(i,k) = 0. + pracw(i,k) = 0. + psaci(i,k) = 0. + psacw(i,k) = 0. + pigen(i,k) = 0. + pidep(i,k) = 0. + pcond(i,k) = 0. + psmlt(i,k) = 0. + psevp(i,k) = 0. + falk(i,k,1) = 0. + falk(i,k,2) = 0. + fall(i,k,1) = 0. + fall(i,k,2) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qci(i,k,2),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + enddo + enddo +! + mstepmax = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) + work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) + numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + rmstep(i) = 1./mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then +! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) +! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) +! qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) +! qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) + dtcldden = dtcld/den(i,k) + qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcldden,0.) + qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcldden,0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then +! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) +! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) +! qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & +! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) +! qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & +! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + dtcldden = dtcld/den(i,k) + rdelz = 1./delz(i,k) + qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & + *delz(i,k+1)*rdelz)*dtcldden,0.) + qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & + *delz(i,k+1)*rdelz)*dtcldden,0.) + endif + enddo + enddo + do k = kte, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then +!---------------------------------------------------------------- +! psmlt: melting of snow [HL A33] [RH83 A25] +! (T>T0: S->R) +!---------------------------------------------------------------- + xlf = xlf0 +! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) + work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & + /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & + *exp(log(t(i,k))*(1.81))/p(i,k)))) & + *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & + *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & + *sqrt(sqrt(den0/(den(i,k))))) + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) +! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & +! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & +! *work2(i,k)*coeres) + psmlt(i,k) = & +(1.414e3*(1.496e-6 * ((t(i,k))*sqrt(t(i,k))) /((t(i,k))+120.)/(den(i,k)) )*(den(i,k)))& + /xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & + *work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,2)/mstep(i)),0.) + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif + endif + enddo + enddo + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + mstepmax = 1 + mstep = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + if(qci(i,k,2).le.0.) then + work2c(i,k) = 0. + else + xmi = den(i,k)*qci(i,k,2)/xni(i,k) +! diameter = min(dicon * sqrt(xmi),dimax) + diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) + work2c(i,k) = work1c(i,k)/delz(i,k) + endif + numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k,2) + qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k,2) + qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + enddo +! +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,1,1)+fall(i,1,2)+fallc(i,1) + fallsum_qsi = fall(i,1,2)+fallc(i,1) + rainncv(i) = 0. + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i) + endif + IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN + snowncv(i) = 0. + if(fallsum_qsi.gt.0.) then + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + endif + ENDIF + sr(i) = 0. + if(fallsum.gt.0.)sr(i)=fallsum_qsi*delz(i,kts)/denr*dtcld*1000./(rainncv(i)+1.e-12) + enddo +! +!--------------------------------------------------------------- +! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] +! (T>T0: I->C) +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + xlf = xls-xl(i,k) + if(supcol.lt.0.) xlf = xlf0 + if(supcol.lt.0.and.qci(i,k,2).gt.0.) then + qci(i,k,1) = qci(i,k,1) + qci(i,k,2) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) + qci(i,k,2) = 0. + endif +!--------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [HL A45] +! (T<-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.40..and.qci(i,k,1).gt.0.) then + qci(i,k,2) = qci(i,k,2) + qci(i,k,1) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) + qci(i,k,1) = 0. + endif +!--------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [HL A44] +! (T0>T>-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qci(i,k,1).gt.0.) then +! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & +! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) + pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & + *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) + qci(i,k,2) = qci(i,k,2) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qci(i,k,1) = qci(i,k,1)-pfrzdtc + endif +!--------------------------------------------------------------- +! psfrz: freezing of rain water [HL A20] [LFO 45] +! (TS) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then +! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & +! *(exp(pfrz2*supcol)-1.)*rslope(i,k,1)**7*dtcld, & +! qrs(i,k,1)) + temp = rslope(i,k,1) + temp = temp*temp*temp*temp*temp*temp*temp + pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & + *(exp(pfrz2*supcol)-1.)*temp*dtcld, & + qrs(i,k,1)) + qrs(i,k,2) = qrs(i,k,2) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qrs(i,k,1) = qrs(i,k,1)-pfrzdtr + endif + enddo + enddo +! +!---------------------------------------------------------------- +! rsloper: reverse of the slope parameter of the rain(m) +! xka: thermal conductivity of air(jm-1s-1k-1) +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else +! rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslope(i,k,1) = 1./(sqrt(sqrt(pidn0r/((qrs(i,k,1))*(den(i,k)))))) + rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else +! rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2))*(den(i,k)))))) + rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + enddo + enddo +! + do k = kts, kte + do i = its, ite +! work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) + work1(i,k,1) = & + ((((den(i,k))*(xl(i,k))*(xl(i,k))) * ((t(i,k))+120.) * (den(i,k))) & + / & + ( 1.414e3 * (1.496e-6 * ((t(i,k))*sqrt(t(i,k)))) * (den(i,k)) * & + (rv*(t(i,k))*(t(i,k))))) & + + & + p(i,k) / ( (qs(i,k,1)) * ( 8.794e-5 * exp(log(t(i,k))*(1.81)) ) ) +! work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) + work1(i,k,2) = & + ( & + (((den(i,k))*(xls)*(xls))*((t(i,k))+120.)*(den(i,k))) & + / & + ( & + 1.414e3 * (1.496e-6 * ((t(i,k))*sqrt(t(i,k)))) * (den(i,k)) * & + (rv*(t(i,k))*(t(i,k))) & + ) & + + & + p(i,k) & + / & + ( qs(i,k,2) * (8.794e-5 * exp(log(t(i,k))*(1.81)))) & + ) +! work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + work2(i,k) = & + ( & + exp(.3333333*log( & + ((1.496e-6 * ((t(i,k))*sqrt(t(i,k))))*p(i,k)) & + / & + (((t(i,k))+120.)*den(i,k)*(8.794e-5 * exp(log(t(i,k))*(1.81)))) & + )) & + * & + sqrt(sqrt(den0/(den(i,k)))) & + ) & + / & + sqrt( & + (1.496e-6 * ((t(i,k))*sqrt(t(i,k)))) & + / & + ( & + ((t(i,k))+120.) * den(i,k) & + ) & + ) + ENDDO + ENDDO +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k,1) + satdt = supsat/dtcld +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qci(i,k,1).gt.qc0) then + praut(i,k) = qck1*exp(log(qci(i,k,1))*((7./3.))) + praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [LFO 51] +! (C->R) +!--------------------------------------------------------------- + if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then + pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & + *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qrs(i,k,1).gt.0.) then + coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) + prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & + +precr2*work2(i,k)*coeres)/work1(i,k,1) + if(prevp(i,k).lt.0.) then + prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) + prevp(i,k) = max(prevp(i,k),satdt/2) + else + prevp(i,k) = min(prevp(i,k),satdt/2) + endif + endif + enddo + enddo +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and RH84 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + rdtcld = 1./dtcld + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + supsat = max(q(i,k),qmin)-qs(i,k,2) + satdt = supsat/dtcld + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qci(i,k,2),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) +! + if(supcol.gt.0) then + if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,2).gt.qmin) then + xmi = den(i,k)*qci(i,k,2)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2s = pvts*rslopeb(i,k,2)*denfac(i,k) +!------------------------------------------------------------- +! psaci: Accretion of cloud ice by rain [HDC 10] +! (TS) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & + +diameter**2*rslope(i,k,2) + psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & + *abs(vt2s-vt2i)*acrfac/4. + endif +!------------------------------------------------------------- +! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] +! (TS, and T>=T0: C->R) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then + psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2) & + *rslopeb(i,k,2)*qci(i,k,1)*denfac(i,k) & +! ,qci(i,k,1)/dtcld) + ,qci(i,k,1)*rdtcld) + endif +!------------------------------------------------------------- +! pidep: Deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qci(i,k,2).gt.0.and.ifsat.ne.1) then + xmi = den(i,k)*qci(i,k,2)/xni(i,k) + diameter = dicon * sqrt(xmi) + pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) + supice = satdt-prevp(i,k) + if(pidep(i,k).lt.0.) then +! pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) +! pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) + pidep(i,k) = max(max(pidep(i,k),satdt*.5),supice) + pidep(i,k) = max(pidep(i,k),-qci(i,k,2)*rdtcld) + else +! pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) + pidep(i,k) = min(min(pidep(i,k),satdt*.5),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 + endif + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (V->S or S->V) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k) & + *(precs1*rslope2(i,k,2)+precs2 & + *work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k) + if(psdep(i,k).lt.0.) then +! psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) +! psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) + psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)*rdtcld) + psdep(i,k) = max(max(psdep(i,k),satdt*.5),supice) + else +! psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) + psdep(i,k) = min(min(psdep(i,k),satdt*.5),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & + ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HL A50] [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supcol.gt.0) then + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) + xni0 = 1.e3*exp(0.1*supcol) + roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) + pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.)) & +! /dtcld) + *rdtcld) + pigen(i,k) = min(min(pigen(i,k),satdt),supice) + endif +! +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qci(i,k,2).gt.0.) then + qimax = roqimax/den(i,k) +! psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) + psaut(i,k) = max(0.,(qci(i,k,2)-qimax)*rdtcld) + endif + endif +!------------------------------------------------------------- +! psevp: Evaporation of melting snow [HL A35] [RH83 A27] +! (T>T0: S->V) +!------------------------------------------------------------- + if(supcol.lt.0.) then + if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) & + psevp(i,k) = psdep(i,k)*work1(i,k,2)/work1(i,k,1) +! psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) + psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)*rdtcld),0.) + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qmin,qci(i,k,1)) + source = (praut(i,k)+pracw(i,k)+psacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + endif +! +! cloud ice +! + value = max(qmin,qci(i,k,2)) + source = (psaut(i,k)+psaci(i,k)-pigen(i,k)-pidep(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psaut(i,k) = psaut(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pigen(i,k) = pigen(i,k)*factor + pidep(i,k) = pidep(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psdep(i,k)+pigen(i,k)+pidep(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & + +psacw(i,k))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & + +prevp(i,k))*dtcld,0.) + qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+psaci(i,k) & + -pigen(i,k)-pidep(i,k))*dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k) & + +psaci(i,k)+psacw(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xls*(psdep(i,k)+pidep(i,k)+pigen(i,k)) & + -xl(i,k)*prevp(i,k)-xlf*psacw(i,k) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + else +! +! cloud water +! + value = max(qmin,qci(i,k,1)) + source=(praut(i,k)+pracw(i,k)+psacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + endif +! +! snow +! + value = max(qcrmin,qrs(i,k,2)) + source=(-psevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psevp(i,k) = psevp(i,k)*factor + endif + work2(i,k)=-(prevp(i,k)+psevp(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & + +psacw(i,k))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & + +prevp(i,k) +psacw(i,k))*dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+psevp(i,k)*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + endif + enddo + enddo +! +! Inline expansion for fpvs +! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite +! work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) + work1(i,k,1) = ((max(q(i,k),qmin)-(qs(i,k,1)))/ & + (1.+(xl(i,k))*(xl(i,k))/(rv*(cpm(i,k)))*(qs(i,k,1))/((t(i,k))*(t(i,k))))) + work2(i,k) = qci(i,k,1)+work1(i,k,1) + pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & + pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld + q(i,k) = q(i,k)-pcond(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 + if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 + enddo + enddo + enddo ! big loops + END SUBROUTINE wsm52d +! ................................................................... + REAL FUNCTION rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + PARAMETER (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + END FUNCTION rgmma +! +!-------------------------------------------------------------------------- + REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + fpvs=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs +!------------------------------------------------------------------- + SUBROUTINE wsm5init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + LOGICAL, INTENT(IN) :: allowed_to_read + REAL :: pi +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xm0 = (di0/dicon)**2 + xmmax = (dimax/dicon)**2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s + pacrc = pi*n0s*avts*g3pbs*.25*eacrc +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax +! + END SUBROUTINE wsm5init +END MODULE module_mp_wsm5 diff --git a/wrfv2_fire/phys/module_mp_wsm6.F b/wrfv2_fire/phys/module_mp_wsm6.F new file mode 100644 index 00000000..4590e3a3 --- /dev/null +++ b/wrfv2_fire/phys/module_mp_wsm6.F @@ -0,0 +1,1501 @@ +#if ( RWORDSIZE == 4 ) +# define VREC vsrec +# define VSQRT vssqrt +#else +# define VREC vrec +# define VSQRT vsqrt +#endif + +MODULE module_mp_wsm6 +! +! + REAL, PARAMETER, PRIVATE :: dtcldcr = 120. + REAL, PARAMETER, PRIVATE :: n0r = 8.e6 + REAL, PARAMETER, PRIVATE :: n0g = 4.e6 + REAL, PARAMETER, PRIVATE :: avtr = 841.9 + REAL, PARAMETER, PRIVATE :: bvtr = 0.8 + REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency + REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + REAL, PARAMETER, PRIVATE :: avts = 11.72 + REAL, PARAMETER, PRIVATE :: bvts = .41 + REAL, PARAMETER, PRIVATE :: avtg = 330. + REAL, PARAMETER, PRIVATE :: bvtg = 0.8 + REAL, PARAMETER, PRIVATE :: deng = 500. + REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! t=-90C unlimited + REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 + REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 + REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 + REAL, PARAMETER, PRIVATE :: betai = .6 + REAL, PARAMETER, PRIVATE :: xn0 = 1.e-2 + REAL, PARAMETER, PRIVATE :: dicon = 11.9 + REAL, PARAMETER, PRIVATE :: di0 = 12.9e-6 + REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 + REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent n0s + REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s + REAL, PARAMETER, PRIVATE :: pfrz1 = 100. + REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 + REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 + REAL, PARAMETER, PRIVATE :: t40c = 233.16 + REAL, PARAMETER, PRIVATE :: eacrc = 1.0 + REAL, PARAMETER, PRIVATE :: dens = 100.0 + REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! pgaut + REAL, SAVE :: & + qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr,& + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + bvtr6,g6pbr, & + precr1,precr2,xm0,xmmax,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r,& + pidn0s,xlv1,pacrc, & + bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & + g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & + precg1,precg2,pidn0g, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max +CONTAINS +!=================================================================== +! + SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & + ,den, pii, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,rain, rainncv & + ,snow, snowncv & + ,graupel, graupelncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the WRF +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! All production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM6 cloud scheme +! +! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) +! Summer 2003 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2004 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + den, & + pii, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + rd, & + rv, & + t0c, & + den0, & + cpd, & + cpv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv + + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: graupel, & + graupelncv +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte ) :: t + REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci + REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs + INTEGER :: i,j,k +!------------------------------------------------------------------- + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + t(i,k)=th(i,k,j)*pii(i,k,j) + qci(i,k,1) = qc(i,k,j) + qci(i,k,2) = qi(i,k,j) + qrs(i,k,1) = qr(i,k,j) + qrs(i,k,2) = qs(i,k,j) + qrs(i,k,3) = qg(i,k,j) + ENDDO + ENDDO + CALL wsm62D(t, q(ims,kms,j), qci, qrs & + ,den(ims,kms,j) & + ,p(ims,kms,j), delz(ims,kms,j) & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,j & + ,rain(ims,j),rainncv(ims,j) & + ,sr(ims,j) & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow(ims,j),snowncv(ims,j) & + ,graupel(ims,j),graupelncv(ims,j) & + ) + DO K=kts,kte + DO I=its,ite + th(i,k,j)=t(i,k)/pii(i,k,j) + qc(i,k,j) = qci(i,k,1) + qi(i,k,j) = qci(i,k,2) + qr(i,k,j) = qrs(i,k,1) + qs(i,k,j) = qrs(i,k,2) + qg(i,k,j) = qrs(i,k,3) + ENDDO + ENDDO + ENDDO + END SUBROUTINE wsm6 +!=================================================================== +! + SUBROUTINE wsm62D(t, q, qci, qrs, den, p, delz & + ,delt,g, cpd, cpv, rd, rv, t0c & + ,ep1, ep2, qmin & + ,XLS, XLV0, XLF0, den0, denr & + ,cliq,cice,psat & + ,lat & + ,rain,rainncv & + ,sr & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,snow,snowncv & + ,graupel,graupelncv & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte, & + lat + REAL, DIMENSION( its:ite , kts:kte ), & + INTENT(INOUT) :: & + t + REAL, DIMENSION( its:ite , kts:kte, 2 ), & + INTENT(INOUT) :: & + qci + REAL, DIMENSION( its:ite , kts:kte, 3 ), & + INTENT(INOUT) :: & + qrs + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(INOUT) :: & + q + REAL, DIMENSION( ims:ime , kms:kme ), & + INTENT(IN ) :: & + den, & + p, & + delz + REAL, INTENT(IN ) :: delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + XLS, & + XLV0, & + XLF0, & + cliq, & + cice, & + psat, & + denr + REAL, DIMENSION( ims:ime ), & + INTENT(INOUT) :: rain, & + rainncv, & + sr + + REAL, DIMENSION( ims:ime ), OPTIONAL, & + INTENT(INOUT) :: snow, & + snowncv + + REAL, DIMENSION( ims:ime ), OPTIONAL, & + INTENT(INOUT) :: graupel, & + graupelncv +! LOCAL VAR + REAL, DIMENSION( its:ite , kts:kte , 3) :: & + rh, qs, rslope, rslope2, rslope3, rslopeb, & + falk, fall, work1 + REAL, DIMENSION( its:ite , kts:kte ) :: & + falkc, work1c, work2c, fallc + REAL, DIMENSION( its:ite , kts:kte) :: & + prevp, psdep, pgdep, praut, psaut, pgaut, & + pracw, psacw, pgacw, pgacr, pgacs, psaci, pgmlt, praci, & + piacr, pracs, psacr, pgaci, pseml, pgeml + REAL, DIMENSION( its:ite , kts:kte ) :: & + pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp, denfac, & + xni, pgevp,n0sfac +! variables for optimization + REAL, DIMENSION( its:ite ) :: tvec1 + REAL :: temp + INTEGER, DIMENSION( its:ite ) :: mstep, numdt + LOGICAL, DIMENSION( its:ite ) :: flgcld + REAL :: pi, & + cpmcal, xlcal, lamdar, lamdas, lamdag, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, holdrr, holdrs, holdrg, supcol, pvt, & + coeres, supsat, dtcld, xmi, eacrs, satdt, & + qimax, diameter, xni0, roqi0, & + fallsum, fallsum_qsi, fallsum_qg, & + vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & + xlwork2, factor, source, value, & + xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 + REAL :: holdc, holdci + INTEGER :: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, n +! Temporaries used for inlining fpvs function + REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp +! +!================================================================= +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! +! Optimizatin : A**B => exp(log(A)*(B)) + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 +! +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! + diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & + /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! + pi = 4. * atan(1.) +! +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qci(i,k,1) = max(qci(i,k,1),0.0) + qrs(i,k,1) = max(qrs(i,k,1),0.0) + qci(i,k,2) = max(qci(i,k,2),0.0) + qrs(i,k,2) = max(qrs(i,k,2),0.0) + qrs(i,k,3) = max(qrs(i,k,3),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation +! emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! +! do k = kts, kte +! do i = its, ite +! denfac(i,k) = sqrt(den0/den(i,k)) +! enddo +! enddo + do k = kts, kte + CALL VREC( tvec1(its), den(its,k), ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) + enddo +! +! Inline expansion for fpvs +! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + prevp(i,k) = 0. + psdep(i,k) = 0. + pgdep(i,k) = 0. + praut(i,k) = 0. + psaut(i,k) = 0. + pgaut(i,k) = 0. + pracw(i,k) = 0. + praci(i,k) = 0. + piacr(i,k) = 0. + psaci(i,k) = 0. + psacw(i,k) = 0. + pracs(i,k) = 0. + psacr(i,k) = 0. + pgacw(i,k) = 0. + pgaci(i,k) = 0. + pgacr(i,k) = 0. + pgacs(i,k) = 0. + pigen(i,k) = 0. + pidep(i,k) = 0. + pcond(i,k) = 0. + psmlt(i,k) = 0. + pgmlt(i,k) = 0. + pseml(i,k) = 0. + pgeml(i,k) = 0. + psevp(i,k) = 0. + pgevp(i,k) = 0. + falk(i,k,1) = 0. + falk(i,k,2) = 0. + falk(i,k,3) = 0. + fall(i,k,1) = 0. + fall(i,k,2) = 0. + fall(i,k,3) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin)then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qci(i,k,2),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + enddo + enddo +! + mstepmax = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) + work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) + work1(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)/delz(i,k) + numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2),work1(i,k,3)) & + *dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + falk(i,k,3) = den(i,k)*qrs(i,k,3)*work1(i,k,3)/mstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) + fall(i,k,3) = fall(i,k,3)+falk(i,k,3) + qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) + qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) + qrs(i,k,3) = max(qrs(i,k,3)-falk(i,k,3)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) + falk(i,k,3) = den(i,k)*qrs(i,k,3)*work1(i,k,3)/mstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + fall(i,k,2) = fall(i,k,2)+falk(i,k,2) + fall(i,k,3) = fall(i,k,3)+falk(i,k,3) + qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + qrs(i,k,3) = max(qrs(i,k,3)-(falk(i,k,3)-falk(i,k+1,3) & + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + do k = kte, kts, -1 + do i = its, ite + if(n.le.mstep(i).and.t(i,k).gt.t0c) then +!--------------------------------------------------------------- +! psmlt: melting of snow [HL A33] [RH83 A25] +! (T>T0: S->R) +!--------------------------------------------------------------- + xlf = xlf0 + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + if(qrs(i,k,2).gt.0.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2) & + +precs2*work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,2)/mstep(i)),0.) + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif +!--------------------------------------------------------------- +! pgmlt: melting of graupel [HL A23] [LFO 47] +! (T>T0: G->R) +!--------------------------------------------------------------- + if(qrs(i,k,3).gt.0.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & + *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,3)/mstep(i)),0.) + qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) + endif + endif + enddo + enddo + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + mstepmax = 1 + mstep = 1 + numdt = 1 + do k = kte, kts, -1 + do i = its, ite + if(qci(i,k,2).le.0.) then + work2c(i,k) = 0. + else + xmi = den(i,k)*qci(i,k,2)/xni(i,k) +! diameter = min(dicon * sqrt(xmi),dimax) + diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) + work1c(i,k) = 1.49e4*diameter**1.31 + work2c(i,k) = work1c(i,k)/delz(i,k) + endif + numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) + if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + enddo + enddo + do i = its, ite + if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + enddo +! + do n = 1, mstepmax + k = kte + do i = its, ite + if(n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k,2) + qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) + endif + enddo + do k = kte-1, kts, -1 + do i = its, ite + if(n.le.mstep(i)) then + falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) + holdc = falkc(i,k) + fallc(i,k) = fallc(i,k)+falkc(i,k) + holdci = qci(i,k,2) + qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + endif + enddo + enddo + enddo +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) + fallsum_qsi = fall(i,kts,2)+fallc(i,kts) + fallsum_qg = fall(i,kts,3) + rainncv(i) = 0. + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) + endif + IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN + snowncv(i) = 0. + if(fallsum_qsi.gt.0.) then + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + endif + ENDIF + IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN + graupelncv(i) = 0. + if(fallsum_qg.gt.0.) then + graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) + endif + ENDIF + sr(i) = 0. + if(fallsum.gt.0.)sr(i)=(fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + & + fallsum_qg*delz(i,kts)/denr*dtcld*1000.)/(rainncv(i)+1.e-12) + enddo +! +!--------------------------------------------------------------- +! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] +! (T>T0: I->C) +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + xlf = xls-xl(i,k) + if(supcol.lt.0.) xlf = xlf0 + if(supcol.lt.0.and.qci(i,k,2).gt.0.) then + qci(i,k,1) = qci(i,k,1) + qci(i,k,2) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) + qci(i,k,2) = 0. + endif +!--------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [HL A45] +! (T<-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.40..and.qci(i,k,1).gt.0.) then + qci(i,k,2) = qci(i,k,2) + qci(i,k,1) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) + qci(i,k,1) = 0. + endif +!--------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [HL A44] +! (T0>T>-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then +! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & +! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) + pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & + *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) + qci(i,k,2) = qci(i,k,2) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qci(i,k,1) = qci(i,k,1)-pfrzdtc + endif +!--------------------------------------------------------------- +! pgfrz: freezing of rain water [HL A20] [LFO 45] +! (TG) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then +! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & +! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & +! *rslope(i,k,1)*dtcld,qrs(i,k,1)) + temp = rslope3(i,k,1) + temp = temp*temp*rslope(i,k,1) + pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & + *(exp(pfrz2*supcol)-1.)*temp*dtcld, & + qrs(i,k,1)) + qrs(i,k,3) = qrs(i,k,3) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qrs(i,k,1) = qrs(i,k,1)-pfrzdtr + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! rsloper: reverse of the slope parameter of the rain(m) +! xka: thermal conductivity of air(jm-1s-1k-1) +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin)then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif + enddo + enddo +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) + work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qs(i,k,1) + satdt = supsat/dtcld +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qci(i,k,1).gt.qc0) then + praut(i,k) = qck1*qci(i,k,1)**(7./3.) + praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [LFO 51] +! (C->R) +!--------------------------------------------------------------- + if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then + pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & + *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qrs(i,k,1).gt.0.) then + coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) + prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & + +precr2*work2(i,k)*coeres)/work1(i,k,1) + if(prevp(i,k).lt.0.) then + prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) + prevp(i,k) = max(prevp(i,k),satdt/2) + else + prevp(i,k) = min(prevp(i,k),satdt/2) + endif + endif + enddo + enddo +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and RH84 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + supsat = max(q(i,k),qmin)-qs(i,k,2) + satdt = supsat/dtcld + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qci(i,k,2),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) +! + xmi = den(i,k)*qci(i,k,2)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) + vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) + vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) + if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then + if(qrs(i,k,1).gt.qcrmin) then +!------------------------------------------------------------- +! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] +! (TR) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & + +diameter**2*rslope(i,k,1) + praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. + praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) +!------------------------------------------------------------- +! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] +! (TS or R->G) +!------------------------------------------------------------- + piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & + *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & + *rslopeb(i,k,1)/24./den(i,k) + piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) + endif +!------------------------------------------------------------- +! psaci: Accretion of cloud ice by snow [HDC 10] +! (TS) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.qcrmin) then + acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & + +diameter**2*rslope(i,k,2) + psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & + *abs(vt2s-vt2i)*acrfac/4. + psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) + endif +!------------------------------------------------------------- +! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] +! (TG) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.qcrmin) then + egi = exp(0.07*(-supcol)) + acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & + +diameter**2*rslope(i,k,3) + pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2g-vt2i)*acrfac/4. + pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) + endif + endif +!------------------------------------------------------------- +! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] +! (TG, and T>=T0: C->R) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then + psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2) & + *rslopeb(i,k,2)*qci(i,k,1)*denfac(i,k) & + ,qci(i,k,1)/dtcld) + endif +!------------------------------------------------------------- +! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] +! (TG, and T>=T0: C->R) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then + pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & + *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) + endif +!------------------------------------------------------------- +! pracs: Accretion of snow by rain [HL A11] [LFO 27] +! (TG) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then + if(supcol.gt.0) then + acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & + +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & + +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) + pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2s) & + *(dens/den(i,k))*acrfac + pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) + endif +!------------------------------------------------------------- +! psacr: Accretion of rain by snow [HL A10] [LFO 28] +! (TS or R->G) (T>=T0: enhance melting of snow) +!------------------------------------------------------------- + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & + +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & + +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) + psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2s-vt2r) & + *(denr/den(i,k))*acrfac + psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) + endif +!------------------------------------------------------------- +! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] +! (TG) (T>=T0: enhance melting of graupel) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & + +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & + +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) + pgacr(i,k) = pi**2*n0r*n0g*abs(vt2g-vt2r)*(denr/den(i,k)) & + *acrfac + pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) + endif +! +!------------------------------------------------------------- +! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] +! (S->G) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then + acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,3) & + +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,3) & + +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,3) + if(supcol.gt.0) then + egs = exp(-0.09*supcol) + else + egs = 1. + endif + pgacs(i,k) = pi**2*egs*n0s*n0sfac(i,k)*n0g*abs(vt2g-vt2s) & + *(dens/den(i,k))*acrfac + pgacs(i,k) = min(pgacs(i,k),qrs(i,k,2)/dtcld) + endif + if(supcol.le.0) then + xlf = xlf0 +!------------------------------------------------------------- +! pseml: Enhanced melting of snow by accretion of water [HL A34] +! (T>=T0: S->R) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.0.) & + pseml(i,k) = min(max(cliq*supcol*(psacw(i,k)+psacr(i,k)) & + /xlf,-qrs(i,k,2)/dtcld),0.) +!------------------------------------------------------------- +! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] +! (T>=T0: G->R) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.0.) & + pgeml(i,k) = min(max(cliq*supcol*(pgacw(i,k)+pgacr(i,k)) & + /xlf,-qrs(i,k,3)/dtcld),0.) + endif + if(supcol.gt.0) then +!------------------------------------------------------------- +! pidep: Deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qci(i,k,2).gt.0.and.ifsat.ne.1) then + pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) + supice = satdt-prevp(i,k) + if(pidep(i,k).lt.0.) then + pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) + pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) + else + pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (TS or S->V) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1 & + *rslope2(i,k,2)+precs2*work2(i,k) & + *coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k) + if(psdep(i,k).lt.0.) then + psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) + psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) + else + psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & + ifsat = 1 + endif +!------------------------------------------------------------- +! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] +! (TG or G->V) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) + if(pgdep(i,k).lt.0.) then + pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) + pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) + else + pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & + abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) + xni0 = 1.e3*exp(0.1*supcol) + roqi0 = 4.92e-11*xni0**1.33 + pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.)) & + /dtcld) + pigen(i,k) = min(min(pigen(i,k),satdt),supice) + endif +! +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qci(i,k,2).gt.0.) then + qimax = roqimax/den(i,k) + psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) + endif +! +!------------------------------------------------------------- +! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] +! (TG) +!------------------------------------------------------------- + if(qrs(i,k,2).gt.0.) then + alpha2 = 1.e-3*exp(0.09*(-supcol)) + pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)) & + ,qrs(i,k,2)/dtcld) + endif + endif +! +!------------------------------------------------------------- +! psevp: Evaporation of melting snow [HL A35] [RH83 A27] +! (T>=T0: S->V) +!------------------------------------------------------------- + if(supcol.lt.0.) then + if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & + *rslope2(i,k,2)+precs2*work2(i,k) & + *coeres)/work1(i,k,1) + psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) + endif +!------------------------------------------------------------- +! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] +! (T>=T0: G->V) +!------------------------------------------------------------- + if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres)/work1(i,k,1) + pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) + endif + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite +! + delta2=0. + delta3=0. + if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. + if(qrs(i,k,1).lt.1.e-4) delta3=1. + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qmin,qci(i,k,1)) + source = (praut(i,k)+pracw(i,k)+psacw(i,k)+pgacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + pgacw(i,k) = pgacw(i,k)*factor + endif +! +! cloud ice +! + value = max(qmin,qci(i,k,2)) + source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k) & + +psaci(i,k)+pgaci(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psaut(i,k) = psaut(i,k)*factor + pigen(i,k) = pigen(i,k)*factor + pidep(i,k) = pidep(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + endif +! +! rain +! + value = max(qmin,qrs(i,k,1)) + source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k) & + +psacr(i,k)+pgacr(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + endif +! +! snow +! + value = max(qmin,qrs(i,k,2)) + source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+psacw(i,k) & + +piacr(i,k)*delta3+praci(i,k)*delta3 & + -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2 & + +psaci(i,k)-pgacs(i,k) )*dtcld + if (source.gt.value) then + factor = value/source + psdep(i,k) = psdep(i,k)*factor + psaut(i,k) = psaut(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! +! graupel +! + value = max(qmin,qrs(i,k,3)) + source = -(pgdep(i,k)+pgaut(i,k) & + +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & + +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & + +pgaci(i,k)+pgacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgdep(i,k) = pgdep(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + pgacw(i,k) = pgacw(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k) & + +pidep(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & + +psacw(i,k)+pgacw(i,k))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & + +prevp(i,k)-piacr(i,k)-pgacr(i,k) & + -psacr(i,k))*dtcld,0.) + qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & + +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & + *dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+psacw(i,k) & + -pgaut(i,k)+piacr(i,k)*delta3 & + +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & + -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & + *dtcld,0.) + qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & + +piacr(i,k)*(1.-delta3) & + +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2)& + +pracs(i,k)*(1.-delta2)+pgaci(i,k)+pgacw(i,k) & + +pgacr(i,k)+pgacs(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & + -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+psacw(i,k) & + +pgacw(i,k)+pgacr(i,k)+psacr(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + else +! +! cloud water +! + value = max(qmin,qci(i,k,1)) + source=(praut(i,k)+pracw(i,k)+psacw(i,k)+pgacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + pgacw(i,k) = pgacw(i,k)*factor + endif +! +! rain +! + value = max(qmin,qrs(i,k,1)) + source = (-psacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k) & + -pracw(i,k)-pgacw(i,k)-prevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pgacw(i,k) = pgacw(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + psacw(i,k) = psacw(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif +! +! snow +! + value = max(qcrmin,qrs(i,k,2)) + source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + psevp(i,k) = psevp(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + endif +! +! graupel +! + value = max(qcrmin,qrs(i,k,3)) + source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + pgevp(i,k) = pgevp(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif + work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & + +psacw(i,k)+pgacw(i,k))*dtcld,0.) + qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & + +prevp(i,k)+psacw(i,k)+pgacw(i,k)-pseml(i,k) & + -pgeml(i,k))*dtcld,0.) + qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & + +pseml(i,k))*dtcld,0.) + qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & + +pgeml(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & + -xlf*(pseml(i,k)+pgeml(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + endif + enddo + enddo +! +! Inline expansion for fpvs +! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) + qs(i,k,1) = max(qs(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) + qs(i,k,2) = max(qs(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) + work2(i,k) = qci(i,k,1)+work1(i,k,1) + pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & + pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld + q(i,k) = q(i,k)-pcond(i,k)*dtcld + qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 + if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 + enddo + enddo + enddo ! big loops + END SUBROUTINE wsm62d +! ................................................................... + REAL FUNCTION rgmma(x) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! rgmma function: use infinite product form + REAL :: euler + PARAMETER (euler=0.577215664901532) + REAL :: x, y + INTEGER :: i + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i=1,10000 + y=float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + END FUNCTION rgmma +! +!-------------------------------------------------------------------------- + REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!-------------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------------- + REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & + xai,xbi,ttp,tr + INTEGER ice +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END FUNCTION fpvs +!------------------------------------------------------------------- + SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,allowed_to_read) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!.... constants which may not be tunable + REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + LOGICAL, INTENT(IN) :: allowed_to_read + REAL :: pi +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + bvtr6 = 6.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g6pbr = rgmma(bvtr6) + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + xm0 = (di0/dicon)**2 + xmmax = (dimax/dicon)**2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + pacrc = pi*n0s*avts*g3pbs*.25*eacrc +! + bvtg1 = 1.+bvtg + bvtg2 = 2.5+.5*bvtg + bvtg3 = 3.+bvtg + bvtg4 = 4.+bvtg + g1pbg = rgmma(bvtg1) + g3pbg = rgmma(bvtg3) + g4pbg = rgmma(bvtg4) + pacrg = pi*n0g*avtg*g3pbg*.25 + g5pbgo2 = rgmma(bvtg2) + pvtg = avtg*g4pbg/6. + precg1 = 2.*pi*n0g*.78 + precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 + pidn0g = pi*deng*n0g +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rslopegmax = 1./lamdagmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rslopegbmax = rslopegmax ** bvtg + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rslopeg2max = rslopegmax * rslopegmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax + rslopeg3max = rslopeg2max * rslopegmax +! + END SUBROUTINE wsm6init +END MODULE module_mp_wsm6 diff --git a/wrfv2_fire/phys/module_pbl_driver.F b/wrfv2_fire/phys/module_pbl_driver.F new file mode 100644 index 00000000..f7aba2c3 --- /dev/null +++ b/wrfv2_fire/phys/module_pbl_driver.F @@ -0,0 +1,537 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_pbl_driver +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE pbl_driver( & + itimestep,dt,u_frame,v_frame & + ,rublten,rvblten,rthblten & + ,tsk,xland,znt,ht & + ,ust,pblh,hfx,qfx,grdflx & + ,u_phy,v_phy,th_phy,rho & + ,p_phy,pi_phy,p8w,t_phy,dz8w,z & + ,tke_myj,el_myj,exch_h,akhs,akms & + ,thz0,qz0,uz0,vz0,qsfc & + ,lowlyr & + ,psim,psih,gz1oz0, wspd,br,chklowq & + ,bl_pbl_physics, ra_lw_physics, dx & + ,stepbl,warm_rain & + ,kpbl,ct,lh,snow,xice & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,i_start,i_end, j_start,j_end, kts,kte, num_tiles & + ! Optional + ,hol, mol, regime & + ! Optional moisture tracers + ,qv_curr, qc_curr, qr_curr & + ,qi_curr, qs_curr, qg_curr & + ,rqvblten,rqcblten,rqiblten & + ,rqrblten,rqsblten,rqgblten & + ! Optional moisture tracer flags + ,f_qv,f_qc,f_qr & + ,f_qi,f_qs,f_qg & + ) +!------------------------------------------------------------------ + USE module_state_description, ONLY : & + YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME + + USE module_model_constants + +! *** add new modules of schemes here + + USE module_bl_myjpbl + USE module_bl_ysu + USE module_bl_mrf + USE module_bl_gfs + + ! This driver calls subroutines for the PBL parameterizations. + ! + ! pbl scheme: + ! 1. ysupbl + ! 2. myjpbl + ! 99. mrfpbl + ! +!------------------------------------------------------------------ + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +! Rho_d dry density (kg/m^3) +! Theta_m moist potential temperature (K) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +!----------------------------------------------------------------- +!-- RUBLTEN U tendency due to +! PBL parameterization (m/s^2) +!-- RVBLTEN V tendency due to +! PBL parameterization (m/s^2) +!-- RTHBLTEN Theta tendency due to +! PBL parameterization (K/s) +!-- RQVBLTEN Qv tendency due to +! PBL parameterization (kg/kg/s) +!-- RQCBLTEN Qc tendency due to +! PBL parameterization (kg/kg/s) +!-- RQIBLTEN Qi tendency due to +! PBL parameterization (kg/kg/s) +!-- itimestep number of time steps +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- EMISS surface emissivity (between 0 and 1) +!-- TSK surface temperature (K) +!-- TMN soil temperature at lower boundary (K) +!-- XLAND land mask (1 for land, 2 for water) +!-- ZNT roughness length (m) +!-- MAVAIL surface moisture availability (between 0 and 1) +!-- UST u* in similarity theory (m/s) +!-- MOL T* (similarity theory) (K) +!-- HOL PBL height over Monin-Obukhov length +!-- PBLH PBL height (m) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- THC thermal inertia (Cal/cm/K/s^0.5) +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- REGIME flag indicating PBL regime (stable, unstable, etc.) +!-- tke_myj turbulence kinetic energy from Mellor-Yamada-Janjic (MYJ) (m^2/s^2) +!-- el_myj mixing length from Mellor-Yamada-Janjic (MYJ) (m) +!-- akhs sfc exchange coefficient of heat/moisture from MYJ +!-- akms sfc exchange coefficient of momentum from MYJ +!-- thz0 potential temperature at roughness length (K) +!-- uz0 u wind component at roughness length (m/s) +!-- vz0 v wind component at roughness length (m/s) +!-- qsfc specific humidity at lower boundary (kg/kg) +!-- th2 diagnostic 2-m theta from surface layer and lsm +!-- t2 diagnostic 2-m temperature from surface layer and lsm +!-- q2 diagnostic 2-m mixing ratio from surface layer and lsm +!-- lowlyr index of lowest model layer above ground +!-- rr dry air density (kg/m^3) +!-- u_phy u-velocity interpolated to theta points (m/s) +!-- v_phy v-velocity interpolated to theta points (m/s) +!-- th_phy potential temperature (K) +!-- p_phy pressure (Pa) +!-- pi_phy exner function (dimensionless) +!-- p8w pressure at full levels (Pa) +!-- t_phy temperature (K) +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- DX horizontal space interval (m) +!-- DT time step (second) +!-- n_moist number of moisture species +!-- PSFC pressure at the surface (Pa) +!-- TSLB +!-- ZS +!-- DZS +!-- num_soil_layers number of soil layer +!-- IFSNOW ifsnow=1 for snow-cover effects +! +!-- P_QV species index for water vapor +!-- P_QC species index for cloud water +!-- P_QR species index for rain water +!-- P_QI species index for cloud ice +!-- P_QS species index for snow +!-- P_QG species index for graupel +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!****************************************************************** +!------------------------------------------------------------------ +! + + + INTEGER, INTENT(IN ) :: bl_pbl_physics, ra_lw_physics + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + kts,kte, num_tiles + + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, INTENT(IN ) :: itimestep,STEPBL + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: LOWLYR +! + LOGICAL, INTENT(IN ) :: warm_rain +! + REAL, INTENT(IN ) :: DT,DX + + +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: p_phy, & + pi_phy, & + p8w, & + rho, & + t_phy, & + u_phy, & + v_phy, & + dz8w, & + z, & + th_phy +! +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: XLAND, & + HT, & + PSIM, & + PSIH, & + GZ1OZ0, & + BR, & + CHKLOWQ +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: TSK, & + UST, & + PBLH, & + HFX, & + QFX, & + ZNT, & + QSFC, & + AKHS, & + AKMS, & + QZ0, & + THZ0, & + UZ0, & + VZ0, & + CT, & + GRDFLX , & + WSPD + +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + EXCH_H,TKE_MYJ +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: EL_MYJ + + REAL , INTENT(IN ) :: u_frame, & + v_frame +! + + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: KPBL + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN) :: XICE, SNOW, LH + +! +! Optional +! +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, INTENT(IN), OPTIONAL :: & + f_qv & + ,f_qc & + ,f_qr & + ,f_qi & + ,f_qs & + ,f_qg + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + ! optional moisture tracers + ! 2 time levels; if only one then use CURR + qv_curr, qc_curr, qr_curr & + ,qi_curr, qs_curr, qg_curr & + ,rqvblten,rqcblten,rqrblten & + ,rqiblten,rqsblten,rqgblten + + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(INOUT) :: HOL, & + MOL, & + REGIME + +! LOCAL VAR + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::v_phytmp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::u_phytmp + + REAL, DIMENSION( ims:ime, jms:jme ) :: TSKOLD, & + USTOLD, & + ZNTOLD, & + ZOL, & + PSFC + +! + + REAL :: DTMIN,DTBL +! + INTEGER :: i,J,K,NK,jj,ij,its,ite,jts,jte + LOGICAL :: radiation + LOGICAL :: flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg + CHARACTER*256 :: message + +!------------------------------------------------------------------ +! + + flag_qv = .FALSE. ; IF ( PRESENT( F_QV ) ) flag_qv = F_QV + flag_qc = .FALSE. ; IF ( PRESENT( F_QC ) ) flag_qc = F_QC + flag_qr = .FALSE. ; IF ( PRESENT( F_QR ) ) flag_qr = F_QR + flag_qi = .FALSE. ; IF ( PRESENT( F_QI ) ) flag_qi = F_QI + flag_qs = .FALSE. ; IF ( PRESENT( F_QS ) ) flag_qs = F_QS + flag_qg = .FALSE. ; IF ( PRESENT( F_QG ) ) flag_qg = F_QG + +!print *,flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg,' flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg' +!print *,f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,' f_qv, f_qc, f_qr, f_qi, f_qs, f_qg' + + if (bl_pbl_physics .eq. 0) return +! RAINBL in mm (Accumulation between PBL calls) + + + IF (itimestep .eq. 1 .or. mod(itimestep,STEPBL) .eq. 0) THEN + + radiation = .false. + IF (ra_lw_physics .gt. 0) radiation = .true. + +!---- +! CALCULATE CONSTANT + + DTMIN=DT/60. +! PBL schemes need PBL time step for updates + DTBL=DT*STEPBL + +! SAVE OLD VALUES + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij,i,j,k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + TSKOLD(i,j)=TSK(i,j) + USTOLD(i,j)=UST(i,j) + ZNTOLD(i,j)=ZNT(i,j) + +! REVERSE ORDER IN THE VERTICAL DIRECTION + +! testing change later + + DO k=kts,kte + v_phytmp(i,k,j)=v_phy(i,k,j)+v_frame + u_phytmp(i,k,j)=u_phy(i,k,j)+u_frame + ENDDO + +! PSFC : in Pa + + PSFC(I,J)=p8w(I,kms,J) + + DO k=kts,min(kte+1,kde) + RTHBLTEN(I,K,J)=0. + RUBLTEN(I,K,J)=0. + RVBLTEN(I,K,J)=0. + IF ( PRESENT( RQCBLTEN )) RQCBLTEN(I,K,J)=0. + IF ( PRESENT( RQVBLTEN )) RQVBLTEN(I,K,J)=0. + ENDDO + + IF (flag_QI .AND. PRESENT(RQIBLTEN) ) THEN + DO k=kts,min(kte+1,kde) + RQIBLTEN(I,K,J)=0. + ENDDO + ENDIF + ENDDO + ENDDO + + ENDDO + !$OMP END PARALLEL DO +! + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i,j,k, its, ite, jts, jte ) + DO ij = 1 , num_tiles + + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + + pbl_select: SELECT CASE(bl_pbl_physics) + + CASE (YSUSCHEME) + CALL wrf_debug(100,'in YSU PBL') + IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & + PRESENT( qi_curr ) .AND. & + PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & + PRESENT( rqiblten ) .AND. & + PRESENT( hol ) ) THEN + CALL ysu( & + U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy & + ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr & + ,P3D=p_phy,PI3D=pi_phy & + ,RUBLTEN=rublten,RVBLTEN=rvblten & + ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten & + ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & + ,FLAG_QI=flag_qi & + ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg & + ,DZ8W=dz8w,Z=z,XLV=XLV,RV=r_v,PSFC=PSFC & + ,ZNT=znt,UST=ust,ZOL=zol,HOL=hol,HPBL=pblh & + ,PSIM=psim,PSIH=psih,XLAND=xland & + ,HFX=hfx,QFX=qfx,TSK=tskold,GZ1OZ0=gz1oz0 & + ,WSPD=wspd,BR=br,DT=dtbl,DTMIN=dtmin,KPBL2D=kpbl & + ,SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0 & + ,EP1=ep_1,EP2=ep_2,KARMAN=karman,EOMEG=eomeg & + ,STBOLT=stbolt,EXCH_H=exch_h,REGIME=regime & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Lack arguments to call YSU pbl') + ENDIF + + CASE (MRFSCHEME) + IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & + PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & + PRESENT( hol ) .AND. & + .TRUE. ) THEN + + CALL wrf_debug(100,'in MRF') + CALL mrf( & + U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy & + ,QV3D=qv_curr & + ,QC3D=qc_curr & + ,QI3D=qi_curr & + ,P3D=p_phy,PI3D=pi_phy & + ,RUBLTEN=rublten,RVBLTEN=rvblten & + ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten & + ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & + ,CP=cp,G=g,ROVCP=rcp,R=r_d,ROVG=rovg & + ,DZ8W=dz8w,Z=z,XLV=xlv,RV=r_v,PSFC=psfc & + ,ZNT=znt,UST=ust,ZOL=zol,HOL=hol & + ,PBL=pblh,PSIM=psim,PSIH=psih & + ,XLAND=xland,HFX=hfx,QFX=qfx,TSK=tskold & + ,GZ1OZ0=gz1oz0,WSPD=wspd,BR=br & + ,DT=dtbl,DTMIN=dtmin,KPBL2D=kpbl & + ,SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0 & + ,EP1=ep_1,EP2=ep_2,KARMAN=karman,EOMEG=eomeg & + ,STBOLT=stbolt,REGIME=regime & + ,FLAG_QI=flag_qi & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Lack arguments to call MRF pbl') + ENDIF + + CASE (GFSSCHEME) + IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & + PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & + .TRUE. ) THEN + CALL wrf_debug(100,'in GFS') + CALL bl_gfs( & + U3D=u_phytmp,V3D=v_phytmp & + ,TH3D=th_phy,T3D=t_phy & + ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr & + ,P3D=p_phy,PI3D=pi_phy & + ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten & + ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten & + ,RQIBLTEN=rqiblten & + ,CP=cp,G=g,ROVCP=rcp,R=r_d,ROVG=rovg,FLAG_QI=flag_qi & + ,DZ8W=dz8w,z=z,PSFC=psfc & + ,UST=ust,PBL=pblh,PSIM=psim,PSIH=psih & + ,HFX=hfx,QFX=qfx,TSK=tskold,GZ1OZ0=gz1oz0 & + ,WSPD=wspd,BR=br & + ,DT=dtbl,KPBL2D=kpbl,EP1=ep_1,KARMAN=karman & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Lack arguments to call GFS pbl') + ENDIF + + CASE (MYJPBLSCHEME) + IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & + PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & + .TRUE. ) THEN + + CALL wrf_debug(100,'in MYJPBL') + CALL myjpbl( & + DT=dt,STEPBL=stepbl,HT=ht,DZ=dz8w & + ,PMID=p_phy,PINT=p8w,TH=th_phy,T=t_phy,EXNER=pi_phy & + ,QV=qv_curr, CWM=qc_curr & + ,U=u_phy,V=v_phy,RHO=rho & + ,TSK=tsk,QSFC=qsfc,CHKLOWQ=chklowq,THZ0=thz0 & + ,QZ0=qz0,UZ0=uz0,VZ0=vz0 & + ,LOWLYR=lowlyr & + ,XLAND=xland,SICE=xice,SNOW=snow & + ,TKE_MYJ=tke_myj,EXCH_H=exch_h,USTAR=ust,ZNT=znt & + ,EL_MYJ=el_myj,PBLH=pblh,KPBL=kpbl,CT=ct & + ,AKHS=akhs,AKMS=akms,ELFLX=lh & + ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten & + ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Lack arguments to call MYJ pbl') + ENDIF + + CASE DEFAULT + + WRITE( message , * ) 'The pbl option does not exist: bl_pbl_physics = ', bl_pbl_physics + CALL wrf_error_fatal ( message ) + + END SELECT pbl_select + + ENDDO + !$OMP END PARALLEL DO + + ENDIF +! + END SUBROUTINE pbl_driver +END MODULE module_pbl_driver diff --git a/wrfv2_fire/phys/module_physics_addtendc.F b/wrfv2_fire/phys/module_physics_addtendc.F new file mode 100644 index 00000000..52050378 --- /dev/null +++ b/wrfv2_fire/phys/module_physics_addtendc.F @@ -0,0 +1,1199 @@ +!WRF:MODEL_LAYER: PHYSICS +! +! note: this module really belongs in the dyn_em directory since it is +! specific only to the EM core. Leaving here for now, with an +! #if ( EM_CORE == 1 ) directive. JM 20031201 +! + +! This MODULE holds the routines which are used to perform updates of the +! model C-grid tendencies with physics A-grid tendencies +! The module consolidates code that was (up to v1.2) duplicated in +! module_em and module_rk and in +! module_big_step_utilities.F and module_big_step_utilities_em.F + +! This MODULE CONTAINS the following routines: +! update_phy_ten, phy_ra_ten, phy_bl_ten, phy_cu_ten, advance_ppt, +! add_a2a, add_a2c_u, and add_a2c_v + + +MODULE module_physics_addtendc + +#if ( EM_CORE == 1 ) + + USE module_state_description + USE module_configure + +CONTAINS + +SUBROUTINE update_phy_ten(rt_tendf,ru_tendf,rv_tendf,moist_tendf, & + scalar_tendf,mu_tendf, & + RTHRATEN,RTHBLTEN,RTHCUTEN,RUBLTEN,RVBLTEN, & + RQVBLTEN,RQCBLTEN,RQIBLTEN, & + RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN,& + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN, & + RMUNDGDTEN, & + rthfrten,rqvfrten, & ! fire + ! these need to be 'opitonal' EGP + n_moist,n_scalar,config_flags,rk_step,adv_moist_cond, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist,n_scalar,rk_step + + LOGICAL , INTENT(IN) :: adv_moist_cond + + REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) :: & + ru_tendf, & + rv_tendf, & + rt_tendf + + REAL , DIMENSION(ims:ime , jms:jme),INTENT(INOUT) :: mu_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar), & + INTENT(INOUT) :: scalar_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RTHRATEN, & + RTHBLTEN, & + RTHCUTEN, & + RUBLTEN, & + RVBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN, & + RTHNDGDTEN, & + RQVNDGDTEN, & + RUNDGDTEN, & + RVNDGDTEN + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: RMUNDGDTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & ! fire + rthfrten, & + rqvfrten +!------------------------------------------------------------------ + +! set up loop bounds for this grid's boundary conditions + + if (config_flags%ra_lw_physics .gt. 0 .or. & + config_flags%ra_sw_physics .gt. 0) & + CALL phy_ra_ten(config_flags,rt_tendf,RTHRATEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (config_flags%bl_pbl_physics .gt. 0) & + CALL phy_bl_ten(config_flags,rk_step,n_moist,n_scalar, & + rt_tendf,ru_tendf,rv_tendf,moist_tendf, & + scalar_tendf,adv_moist_cond, & + RTHBLTEN,RUBLTEN,RVBLTEN, & + RQVBLTEN,RQCBLTEN,RQIBLTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (config_flags%cu_physics .gt. 0) & + CALL phy_cu_ten(config_flags,rk_step,n_moist,rt_tendf, & + RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,moist_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (config_flags%grid_fdda .gt. 0) & + CALL phy_fg_ten(config_flags,rk_step,n_moist, & + rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & + RQVNDGDTEN,RMUNDGDTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (config_flags%ifire .gt. 0) & ! fire + CALL phy_fr_ten(config_flags,rk_step,n_moist, & + rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + rthfrten,rqvfrten, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +END SUBROUTINE update_phy_ten + +!================================================================= +SUBROUTINE phy_ra_ten(config_flags,rt_tendf,RTHRATEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RTHRATEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & + rt_tendf + +! LOCAL VARS + + INTEGER :: i,j,k + + CALL add_a2a(rt_tendf,RTHRATEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +END SUBROUTINE phy_ra_ten + +!================================================================= +SUBROUTINE phy_bl_ten(config_flags,rk_step,n_moist,n_scalar, & + rt_tendf,ru_tendf,rv_tendf,moist_tendf, & + scalar_tendf,adv_moist_cond, & + RTHBLTEN,RUBLTEN,RVBLTEN, & + RQVBLTEN,RQCBLTEN,RQIBLTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist, n_scalar, rk_step + + LOGICAL , INTENT(IN) :: adv_moist_cond + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar), & + INTENT(INOUT) :: scalar_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RTHBLTEN, & + RUBLTEN, & + RVBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + rt_tendf, & + ru_tendf, & + rv_tendf +! LOCAL VARS + + INTEGER :: i,j,k,IBGN,IEND,JBGN,JEND + +!----------------------------------------------------------------- + + SELECT CASE(config_flags%bl_pbl_physics) + + CASE (YSUSCHEME) + + CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_u(ru_tendf,RUBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_v(rv_tendf,RVBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(.not. adv_moist_cond)THEN + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + CASE (MRFSCHEME) + + CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_u(ru_tendf,RUBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_v(rv_tendf,RVBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(.not. adv_moist_cond)THEN + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + CASE (MYJPBLSCHEME) + + CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_u(ru_tendf,RUBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_v(rv_tendf,RVBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(.not. adv_moist_cond)THEN + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDIF + + CASE (GFSSCHEME) + + CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_u(ru_tendf,RUBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_v(rv_tendf,RVBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(.not. adv_moist_cond)THEN + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + CASE DEFAULT + + print*,'phy_bl_ten: The pbl scheme does not exist' + + END SELECT + +END SUBROUTINE phy_bl_ten + +!================================================================= +SUBROUTINE phy_cu_ten(config_flags,rk_step,n_moist,rt_tendf, & + RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,moist_tendf, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type ) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist, rk_step + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & + rt_tendf + +! LOCAL VARS + + INTEGER :: i,j,k + + SELECT CASE (config_flags%cu_physics) + + CASE (KFSCHEME) + CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QR .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QR),RQRCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQICUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QS .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QS),RQSCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (BMJSCHEME) + CALL add_a2a(rt_tendf,RTHCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (KFETASCHEME) + CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QR .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QR),RQRCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQICUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QS .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QS),RQSCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (GDSCHEME) + CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQICUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (SASSCHEME) + CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCCUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQICUTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE DEFAULT + + END SELECT + +END SUBROUTINE phy_cu_ten + +!================================================================= +SUBROUTINE phy_fg_ten(config_flags,rk_step,n_moist, & + rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & + RQVNDGDTEN,RMUNDGDTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist, rk_step + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + RTHNDGDTEN, & + RUNDGDTEN, & + RVNDGDTEN, & + RQVNDGDTEN + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN ) :: RMUNDGDTEN + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + rt_tendf, & + ru_tendf, & + rv_tendf + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: mu_tendf + +! LOCAL VARS + + INTEGER :: i,j,k,IBGN,IEND,JBGN,JEND + +!----------------------------------------------------------------- + + SELECT CASE(config_flags%grid_fdda) + + CASE (PSUFDDAGD) + + CALL add_a2a(rt_tendf,RTHNDGDTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! note fdda u and v tendencies are staggered + CALL add_c2c_u(ru_tendf,RUNDGDTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_c2c_v(rv_tendf,RVNDGDTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2a(mu_tendf,RMUNDGDTEN,config_flags, & + ids,ide, jds, jde, kds, kds, & + ims, ime, jms, jme, kms, kms, & + its, ite, jts, jte, kts, kts ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVNDGDTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + CASE DEFAULT + + END SELECT + +END SUBROUTINE phy_fg_ten + +!================================================================= +SUBROUTINE phy_fr_ten(config_flags,rk_step,n_moist, & + rt_tendf,ru_tendf,rv_tendf, & + mu_tendf, moist_tendf, & + rthfrten,rqvfrten, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!----------------------------------------------------------------- + USE module_state_description, ONLY : & + FIRE_CAWFE +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + n_moist, rk_step + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), & + INTENT(INOUT) :: moist_tendf + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & + rthfrten, & + rqvfrten + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + rt_tendf, & + ru_tendf, & + rv_tendf + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: mu_tendf + +! LOCAL VARS + + INTEGER :: i,j,k,IBGN,IEND,JBGN,JEND + +!----------------------------------------------------------------- + + SELECT CASE(config_flags%ifire) + + CASE (FIRE_CAWFE) + + CALL add_a2a(rt_tendf,rthfrten, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),rqvfrten, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE DEFAULT + + END SELECT + +END SUBROUTINE phy_fr_ten + +!---------------------------------------------------------------------- +SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,RAINC,RAINCV,NCA, & + HTOP,HBOT,CUTOP,CUBOT, & + CUPPT, config_flags, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + USE module_state_description + USE module_cu_kf + USE module_cu_kfeta +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINC, & + RAINCV, & + NCA, & + HTOP, & + HBOT, & + CUTOP, & + CUBOT, & + CUPPT + +! LOCAL VAR + + INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end + INTEGER :: NCUTOP, NCUBOT + +!----------------------------------------------------------------- + + IF (config_flags%cu_physics .eq. 0) return + +! SET START AND END POINTS FOR TILES + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) +! +! IF( config_flags%nested .or. config_flags%specified ) THEN +! i_start = max( its,ids+1 ) +! i_end = min( ite,ide-2 ) +! j_start = max( jts,jds+1 ) +! j_end = min( jte,jde-2 ) +! ENDIF +! + k_start = kts + k_end = min( kte, kde-1 ) + +! Update total cumulus scheme precipitation + +! in mm + + DO J = j_start,j_end + DO i = i_start,i_end + RAINC(I,J)=RAINC(I,J)+RAINCV(I,J) + CUPPT(I,J)=CUPPT(I,J)+RAINCV(I,J)/1000. + ENDDO + ENDDO + + SELECT CASE (config_flags%cu_physics) + + CASE (KFSCHEME) + + DO J = j_start,j_end + DO i = i_start,i_end + + IF ( NINT(NCA(I,J)).GT. 0 ) THEN + + IF ( NINT(NCA(I,J)) .eq. 1 ) THEN + + ! set tendency to zero + RAINCV(I,J)=0. + DO k = k_start,k_end + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + if (P_QI .ge. PARAM_FIRST_SCALAR) RQICUTEN(i,k,j)=0. + if (P_QS .ge. PARAM_FIRST_SCALAR) RQSCUTEN(i,k,j)=0. + ENDDO + ENDIF + + NCA(I,J)=NCA(I,J)-1. ! Decrease NCA + + ENDIF +! + ENDDO + ENDDO + + CASE (BMJSCHEME) + + DO J = j_start,j_end + DO i = i_start,i_end + +! HTOP, HBOT FOR GFDL RADIATION + NCUTOP=NINT(CUTOP(I,J)) + NCUBOT=NINT(CUBOT(I,J)) + IF(NCUTOP>1.AND.NCUTOP0.AND.NCUBOT1.AND.NCUTOP0.AND.NCUBOT ',6*(max_cats*max_seas)+1*max_cats + ENDIF + curs = 1 + DO cats = 1, max_cats + SCFX(cats) = lu_state(curs) ; curs = curs + 1 + DO seas = 1, max_seas + ALBD(cats,seas) = lu_state(curs) ; curs = curs + 1 + SLMO(cats,seas) = lu_state(curs) ; curs = curs + 1 + SFEM(cats,seas) = lu_state(curs) ; curs = curs + 1 + SFZ0(cats,seas) = lu_state(curs) ; curs = curs + 1 + SFHC(cats,seas) = lu_state(curs) ; curs = curs + 1 + THERIN(cats,seas) = lu_state(curs) ; curs = curs + 1 + ENDDO + ENDDO + +! Determine season (summer=1, winter=2) + ISN=1 + IF(JULDAY.LT.105.OR.JULDAY.GT.288)ISN=2 + IF(CEN_LAT.LT.0.0)ISN=3-ISN + + FOUND_LU = .TRUE. + IF ( allowed_to_read ) THEN + landuse_unit = 29 + IF ( wrf_dm_on_monitor() ) THEN + OPEN(landuse_unit, FILE='LANDUSE.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF ( ierr .NE. OPEN_OK ) THEN + WRITE(message,FMT='(A)') & + 'module_physics_init.F: LANDUSE_INIT: open failure for LANDUSE.TBL' + CALL wrf_error_fatal ( message ) + END IF + ENDIF + +! Read info from file LANDUSE.TBL + IF(MMINLU.EQ.'OLD ')THEN +! ISWATER=7 + ISICE=11 + ELSE IF(MMINLU.EQ.'USGS')THEN +! ISWATER=16 + ISICE=24 + ELSE IF(MMINLU.EQ.'SiB ')THEN +! ISWATER=15 + ISICE=16 + ELSE IF(MMINLU.EQ.'LW12')THEN +! ISWATER=15 + ISICE=3 + ENDIF + PRINT *, 'INPUT LANDUSE = ',MMINLU + FOUND_LU = .FALSE. + end_of_file = .FALSE. +!!! BEGINNING OF 1999 LOOP + 1999 CONTINUE + IF ( wrf_dm_on_monitor() ) THEN + READ (landuse_unit,2000,END=2002)LUTYPE + GOTO 2003 + 2002 CONTINUE + CALL wrf_message( 'INPUT FILE FOR LANDUSE REACHED END OF FILE' ) + end_of_file = .TRUE. + 2003 CONTINUE + IF ( .NOT. end_of_file ) READ (landuse_unit,*)LUCATS,LUSEAS + FOUND_LU = LUTYPE.EQ.MMINLU + ENDIF + CALL wrf_dm_bcast_bytes (end_of_file, LWORDSIZE ) + IF ( .NOT. end_of_file ) THEN + CALL wrf_dm_bcast_string(lutype, 4) + CALL wrf_dm_bcast_bytes (lucats, IWORDSIZE ) + CALL wrf_dm_bcast_bytes (luseas, IWORDSIZE ) + CALL wrf_dm_bcast_bytes (found_lu, LWORDSIZE ) + 2000 FORMAT (A4) + IF(FOUND_LU)THEN + LUN=LUCATS + NSN=LUSEAS + PRINT *, 'LANDUSE TYPE = ',LUTYPE,' FOUND', & + LUCATS,' CATEGORIES',LUSEAS,' SEASONS', & + ' WATER CATEGORY = ',ISWATER, & + ' SNOW CATEGORY = ',ISICE + ENDIF + DO ls=1,luseas + if ( wrf_dm_on_monitor() ) then + READ (landuse_unit,*) + endif + DO LC=1,LUCATS + IF(found_lu)THEN + IF ( wrf_dm_on_monitor() ) THEN + READ (landuse_unit,*)LI,ALBD(LC,LS),SLMO(LC,LS),SFEM(LC,LS), & + SFZ0(LC,LS),THERIN(LC,LS),SCFX(LC),SFHC(LC,LS) + ENDIF + CALL wrf_dm_bcast_bytes (LI, IWORDSIZE ) + IF(LC.NE.LI)CALL wrf_error_fatal ( 'module_start: MISSING LANDUSE UNIT ' ) + ELSE + IF ( wrf_dm_on_monitor() ) THEN + READ (landuse_unit,*) + ENDIF + ENDIF + ENDDO + ENDDO + IF(NSN.EQ.1.AND.FOUND_LU) THEN + ISN = 1 + END IF + CALL wrf_dm_bcast_bytes (albd, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (slmo, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (sfem, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (sfz0, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (therin, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (sfhc, max_cats * max_seas * RWORDSIZE ) + CALL wrf_dm_bcast_bytes (scfx, max_cats * RWORDSIZE ) + ENDIF + + IF(.NOT. found_lu .AND. .NOT. end_of_file ) GOTO 1999 +!!! END OF 1999 LOOP + + IF(.NOT. found_lu .OR. end_of_file )THEN + CALL wrf_message ( 'LANDUSE IN INPUT FILE DOES NOT MATCH LUTABLE: TABLE NOT USED' ) + ENDIF + ENDIF ! allowed_to_read + + IF(FOUND_LU)THEN +! Set arrays according to lu_index + itf = min0(ite, ide-1) + jtf = min0(jte, jde-1) + IF(usebgalb)CALL wrf_message ( 'Climatological albedo is used instead of table values' ) + DO j = jts, jtf + DO i = its, itf + IS=nint(lu_index(i,j)) + ! only do this check on read-in data + IF(IS.LT.0.OR.IS.GT.LUN.AND.allowed_to_read)THEN + WRITE ( wrf_err_message , * ) 'ERROR: LANDUSE OUTSIDE RANGE =',IS,' AT ',I,J,' LUN= ',LUN + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ENDIF +! SET NO-DATA POINTS (IS=0) TO WATER + IF(IS.EQ.0)THEN + IS=ISWATER + ENDIF + IF(.NOT.usebgalb)ALBBCK(I,J)=ALBD(IS,ISN)/100. + ALBEDO(I,J)=ALBBCK(I,J) + IF(SNOWC(I,J) .GT. 0.5)ALBEDO(I,J)=ALBBCK(I,J)*(1.+SCFX(IS)) + THC(I,J)=THERIN(IS,ISN)/100. + Z0(I,J)=SFZ0(IS,ISN)/100. + ZNT(I,J)=Z0(I,J) + EMISS(I,J)=SFEM(IS,ISN) + MAVAIL(I,J)=SLMO(IS,ISN) + IF(IS.NE.ISWATER)THEN + XLAND(I,J)=1.0 + ELSE + XLAND(I,J)=2.0 + ENDIF +! SET SEA-ICE POINTS TO LAND WITH ICE/SNOW SURFACE PROPERTIES + IF(XICE(I,J).GT.0.5)THEN + XLAND(I,J)=1.0 + ALBBCK(I,J)=ALBD(ISICE,ISN)/100. + ALBEDO(I,J)=ALBBCK(I,J) + THC(I,J)=THERIN(ISICE,ISN)/100. + Z0(I,J)=SFZ0(ISICE,ISN)/100. + ZNT(I,J)=Z0(I,J) + EMISS(I,J)=SFEM(ISICE,ISN) + MAVAIL(I,J)=SLMO(ISICE,ISN) + ENDIF + ENDDO + ENDDO + ENDIF + if ( wrf_dm_on_monitor() .and. allowed_to_read ) then + CLOSE (landuse_unit) + endif + CALL wrf_debug( 100 , 'returning from of landuse_init' ) + +! restore LU variables from state + curs = 1 + DO cats = 1, max_cats + lu_state(curs) = SCFX(cats) ; curs = curs + 1 + DO seas = 1, max_seas + lu_state(curs) = ALBD(cats,seas) ; curs = curs + 1 + lu_state(curs) = SLMO(cats,seas) ; curs = curs + 1 + lu_state(curs) = SFEM(cats,seas) ; curs = curs + 1 + lu_state(curs) = SFZ0(cats,seas) ; curs = curs + 1 + lu_state(curs) = SFHC(cats,seas) ; curs = curs + 1 + lu_state(curs) = THERIN(cats,seas) ; curs = curs + 1 + ENDDO + ENDDO + + RETURN + + END SUBROUTINE landuse_init + +!===================================================================== + SUBROUTINE ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & + RTHRATENSW,CLDFRA,EMISS,cen_lat,JULYR,JULDAY,GMT, & + levsiz,XLAT,n_ozmixm, & + cldfra_old, & ! Optional + ozmixm,pin, & ! Optional + m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2, & ! Optional + paerlev,n_aerosolc, & + sfull,shalf,pptop,swrad_scat, & + config_flags,restart, & + allowed_to_read, start_of_simulation, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!--------------------------------------------------------------------- + USE module_ra_rrtm + USE module_ra_cam + USE module_ra_sw + USE module_ra_gsfcsw + USE module_ra_gfdleta + USE module_domain +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + INTEGER, INTENT(IN) :: id + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: restart + LOGICAL, INTENT(IN) :: allowed_to_read + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , INTENT(IN) :: JULDAY,JULYR + REAL , INTENT(IN) :: DT, RADT, cen_lat, GMT, pptop, & + swrad_scat + LOGICAL, INTENT(IN) :: start_of_simulation + + INTEGER, INTENT(IN ) :: levsiz, n_ozmixm + INTEGER, INTENT(IN ) :: paerlev, n_aerosolc + + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAT + + REAL, DIMENSION( ims:ime, levsiz, jms:jme, n_ozmixm ), OPTIONAL, & + INTENT(INOUT) :: OZMIXM + + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: m_ps_1,m_ps_2 + REAL, DIMENSION(paerlev), OPTIONAL, INTENT(INOUT) :: m_hybi + REAL, DIMENSION( ims:ime, paerlev, jms:jme, n_aerosolc ), OPTIONAL, & + INTENT(INOUT) :: aerosolc_1, aerosolc_2 + + REAL, DIMENSION(levsiz), OPTIONAL, INTENT(INOUT) :: PIN + + INTEGER , INTENT(INOUT) :: STEPRA + INTEGER :: isn + + REAL , DIMENSION( kms:kme ) , INTENT(IN) :: sfull, shalf + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHRATEN, & + RTHRATENLW, & + RTHRATENSW, & + CLDFRA + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(OUT) :: & + CLDFRA_OLD + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: EMISS + LOGICAL :: etalw = .false. + LOGICAL :: camlw = .false. + LOGICAL :: etamp = .false. + integer :: month,iday + INTEGER :: i, j, k, itf, jtf, ktf +!--------------------------------------------------------------------- + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + +!--------------------------------------------------------------------- + +!-- calculate radiation time step + + STEPRA = nint(RADT*60./DT) + STEPRA = max(STEPRA,1) + +!-- initialization + + IF(start_of_simulation)THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHRATEN(i,k,j)=0. + RTHRATENLW(i,k,j)=0. + RTHRATENSW(i,k,j)=0. + CLDFRA(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + if( present(cldfra_old) ) then + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + cldfra_old(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + end if + ENDIF + +!-- find out which microphysics option is used first + + mp_select: SELECT CASE(config_flags%mp_physics) + + CASE (ETAMPNEW) + etamp = .true. + + END SELECT mp_select + +!-- chose long wave radiation scheme + + lwrad_select: SELECT CASE(config_flags%ra_lw_physics) + + CASE (RRTMSCHEME) + CALL rrtminit( & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (CAMLWSCHEME) +#ifdef MAC_KLUDGE + CALL wrf_error_fatal ( 'CAM radiation scheme not supported under the chosen build configuration' ) +#endif + IF ( PRESENT( OZMIXM ) .AND. PRESENT( PIN ) .AND. & + PRESENT(M_PS_1) .AND. PRESENT(M_PS_2) .AND. & + PRESENT(M_HYBI) .AND. PRESENT(AEROSOLC_1) & + .AND. PRESENT(AEROSOLC_2)) THEN + CALL camradinit( & + R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, & + ozmixm,pin,levsiz,XLAT,n_ozmixm, & + m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2,& + paerlev, n_aerosolc, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' ) + ENDIF + + camlw = .true. + + CASE (GFDLLWSCHEME) + CALL nl_get_start_month(id,month) + CALL nl_get_start_day(id,iday) + CALL gfdletainit(emiss,sfull,shalf,pptop, & + julyr,month,iday,gmt, & + config_flags,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + etalw = .true. + CASE DEFAULT + + END SELECT lwrad_select +!-- initialize short wave radiation scheme + + swrad_select: SELECT CASE(config_flags%ra_sw_physics) + + CASE (SWRADSCHEME) + CALL swinit( & + swrad_scat, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (CAMSWSCHEME) +#ifdef MAC_KLUDGE + CALL wrf_error_fatal ( 'CAM radiation scheme not supported under the chosen build configuration' ) +#endif + IF(.not.camlw)THEN + CALL camradinit( & + R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, & + ozmixm,pin,levsiz,XLAT,n_ozmixm, & + m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2,& + paerlev, n_aerosolc, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + CASE (GSFCSWSCHEME) + CALL gsfc_swinit(cen_lat, allowed_to_read ) + + CASE (GFDLSWSCHEME) + IF(.not.etalw)THEN + CALL nl_get_start_month(id,month) + CALL nl_get_start_day(id,iday) + CALL gfdletainit(emiss,sfull,shalf,pptop, & + julyr,month,iday,gmt, & + config_flags,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + CASE DEFAULT + + END SELECT swrad_select + + END SUBROUTINE ra_init + + SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & + RQVBLTEN,RQCBLTEN,RQIBLTEN,TSK,TMN, & + config_flags,restart,UST,LOWLYR,TSLB,ZS,DZS, & + num_soil_layers,TKE_MYJ,EXCH_H,VEGFRA, & + SNOW,SNOWC, CANWAT,SMSTAV, & + SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW,ACSNOM, & + IVGTYP,ISLTYP,SMOIS,SMFR3D,mavail, & + SNOWH,SH2O,FNDSOILW, FNDSNOWH, & +#if ( NMM_CORE == 1 ) + Z0,XLAND,XICE, & +#else + ZNT,XLAND,XICE, & +#endif + SFCEVP,GRDFLX, & + allowed_to_read, & +! num_roof_layers,num_wall_layers,num_road_layers,& !Optional urban + DZR, DZB, DZG, & !Optional urban + TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !Optional urban + XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !Optional urban + TRL_URB3D, TBL_URB3D, TGL_URB3D, & !Optional urban + SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & !Optional urban + TS_URB2D, FRC_URB2D, UTYPE_URB2D,UCMCALL, & !Optional urban + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + USE module_sf_sfclay + USE module_sf_slab + USE module_bl_ysu + USE module_bl_mrf + USE module_bl_gfs + USE module_sf_myjsfc + USE module_sf_noahlsm + USE module_sf_urban + USE module_sf_ruclsm + USE module_bl_myjpbl +#if (NMM_CORE == 1) + USE module_sf_lsm_nmm +#endif +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: restart + LOGICAL, INTENT(IN) :: FNDSOILW, FNDSNOWH + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: num_soil_layers + INTEGER , INTENT(IN) :: UCMCALL + + REAL , INTENT(IN) :: DT, BLDT + INTEGER , INTENT(INOUT) :: STEPBL + + REAL, DIMENSION( ims:ime , 1:num_soil_layers , jms:jme ), & + INTENT(OUT) :: SMFR3D + + REAL, DIMENSION( ims:ime , 1:num_soil_layers , jms:jme ),& + INTENT(INOUT) :: SMOIS,SH2O,TSLB + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SNOW, & + SNOWH, & + SNOWC, & + CANWAT, & + MAVAIL, & + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + ACSNOW, & + VEGFRA, & + ACSNOM, & + SFCEVP, & + GRDFLX, & + UST, & +#if ( NMM_CORE == 1 ) + Z0, & +#else + ZNT, & +#endif + XLAND, & + XICE + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: IVGTYP, & + ISLTYP, & + LOWLYR + + + REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: ZS,DZS + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RUBLTEN, & + RVBLTEN, & + EXCH_H, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN, & + TKE_MYJ + + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: TSK + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: TMN + LOGICAL, INTENT(IN) :: allowed_to_read + INTEGER :: isn, isfc + +!URBAN +! REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: DZR !Optional urban +! REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: DZB !Optional urban +! REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: DZG !Optional urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZR !Optional urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB !Optional urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D !Optional urban + INTEGER, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UTYPE_URB2D !Optional urban +! REAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D !Optional urban +! REAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D !Optional urban +! REAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D !Optional urban + + +!-- calculate pbl time step + + STEPBL = nint(BLDT*60./DT) + STEPBL = max(STEPBL,1) + + +!-- initialize surface layer scheme + + sfclay_select: SELECT CASE(config_flags%sf_sfclay_physics) + + CASE (SFCLAYSCHEME) + CALL sfclayinit( allowed_to_read ) + isfc = 1 + CASE (MYJSFCSCHEME) + CALL myjsfcinit(LOWLYR,UST, & +#if ( NMM_CORE == 1 ) + Z0, & +#else + ZNT, & +#endif + XLAND,XICE, & + IVGTYP,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + isfc = 2 + + CASE (GFSSFCSCHEME) + CALL myjsfcinit(LOWLYR,UST, & +#if ( NMM_CORE == 1 ) + Z0, & +#else + ZNT, & +#endif + XLAND,XICE, & + IVGTYP,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + isfc = 1 + + CASE DEFAULT + + END SELECT sfclay_select + + +!-- initialize surface scheme + + sfc_select: SELECT CASE(config_flags%sf_surface_physics) + + CASE (SLABSCHEME) + CALL slabinit(TSK,TMN, & + TSLB,ZS,DZS,num_soil_layers, & + restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +#if (NMM_CORE == 1) + CASE (NMMLSMSCHEME) + CALL nmmlsminit(isn,XICE,VEGFRA,SNOW,SNOWC, CANWAT,SMSTAV, & + SMSTOT, SFCRUNOFF,UDRUNOFF,GRDFLX,ACSNOW, & + ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,DZS,SFCEVP, & + TMN, & + num_soil_layers, & + allowed_to_read , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +#endif + CASE (LSMSCHEME) + CALL LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & + SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, & + ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, & + FNDSOILW, FNDSNOWH, & + num_soil_layers, restart, & + allowed_to_read , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!URBAN + IF(UCMCALL.eq.1) THEN + + IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN + + CALL urban_param_init(DZR,DZB,DZG,num_soil_layers & !urban + ) +! num_roof_layers,num_wall_layers,road_soil_layers) !urban + CALL urban_var_init(TSK,TSLB,TMN,IVGTYP, & !urban + ims,ime,jms,jme,num_soil_layers, & !urban +! num_roof_layers,num_wall_layers,num_road_layers, & !urban + XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !urban + TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !urban + TRL_URB3D,TBL_URB3D,TGL_URB3D, & !urban + SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, TS_URB2D, & ! urban + FRC_URB2D, UTYPE_URB2D) !urban + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling urban model' ) + ENDIF + ENDIF + + + CASE (RUCLSMSCHEME) +! if(isfc .ne. 2)CALL wrf_error_fatal & +! ( 'module_physics_init: use myjsfc and myjpbl scheme for this lsm option' ) + CALL lsmrucinit( SMFR3D,TSLB,SMOIS,ISLTYP,mavail, & + num_soil_layers, restart, & + allowed_to_read , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CASE DEFAULT + + END SELECT sfc_select + + +!-- initialize pbl scheme + + pbl_select: SELECT CASE(config_flags%bl_pbl_physics) + + CASE (YSUSCHEME) + if(isfc .ne. 1)CALL wrf_error_fatal & + ( 'module_physics_init: use sfclay scheme for this pbl option' ) + CALL ysuinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + RQCBLTEN,RQIBLTEN,P_QI, & + PARAM_FIRST_SCALAR, & + restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (MRFSCHEME) + if(isfc .ne. 1)CALL wrf_error_fatal & + ( 'module_physics_init: use sfclay scheme for this pbl option' ) + CALL mrfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + RQCBLTEN,RQIBLTEN,P_QI, & + PARAM_FIRST_SCALAR, & + restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (GFSSCHEME) + if(isfc .ne. 1)CALL wrf_error_fatal & + ( 'module_physics_init: use sfclay scheme for this pbl option' ) + CALL gfsinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + RQCBLTEN,RQIBLTEN,P_QI, & + PARAM_FIRST_SCALAR, & + restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (MYJPBLSCHEME) + if(isfc .ne. 2)CALL wrf_error_fatal & + ( 'module_physics_init: use myjsfc scheme for this pbl option' ) + CALL myjpblinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + TKE_MYJ,EXCH_H,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE DEFAULT + + END SELECT pbl_select + + END SUBROUTINE bl_init + +!================================================================== + SUBROUTINE cu_init(STEPCU,CUDT,DT,RTHCUTEN,RQVCUTEN,RQRCUTEN, & + RQCCUTEN,RQSCUTEN,RQICUTEN,NCA,RAINC, & + RAINCV,W0AVG,config_flags,restart, & + CLDEFI,LOWLYR,MASS_FLUX, & + RTHFTEN, RQVFTEN, & + APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & + APR_CAPMA,APR_CAPME,APR_CAPMI, & + allowed_to_read, start_of_simulation, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------ + USE module_cu_kf + USE module_cu_kfeta + USE MODULE_CU_BMJ + USE module_cu_gd + USE module_cu_sas +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: restart + + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN) :: DT, CUDT + LOGICAL , INTENT(IN) :: start_of_simulation + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(INOUT) :: STEPCU + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & + RTHCUTEN, RQVCUTEN, RQCCUTEN, RQRCUTEN, RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHFTEN, RQVFTEN + + REAL , DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: RAINC, RAINCV + + REAL , DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: CLDEFI + + REAL , DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA + + REAL , DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: MASS_FLUX, & + APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & + APR_CAPMA,APR_CAPME,APR_CAPMI + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: LOWLYR + +! LOCAL VAR + + INTEGER :: i,j,itf,jtf + +!-------------------------------------------------------------------- + +!-- calculate cumulus parameterization time step + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) +! + STEPCU = nint(CUDT*60./DT) + STEPCU = max(STEPCU,1) + +!-- initialization + + IF(start_of_simulation)THEN + DO j=jts,jtf + DO i=its,itf + RAINC(i,j)=0. + RAINCV(i,j)=0. + ENDDO + ENDDO + ENDIF + + cps_select: SELECT CASE(config_flags%cu_physics) + + CASE (KFSCHEME) + CALL kfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + PARAM_FIRST_SCALAR,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (BMJSCHEME) + CALL bmjinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + CLDEFI,LOWLYR,cp,r_d,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE (KFETASCHEME) + CALL kf_eta_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + PARAM_FIRST_SCALAR,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (GDSCHEME) + CALL gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & + MASS_FLUX,cp,restart, & + P_QC,P_QI,PARAM_FIRST_SCALAR, & + RTHFTEN, RQVFTEN, & + APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & + APR_CAPMA,APR_CAPME,APR_CAPMI, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (SASSCHEME) + CALL sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & + restart,P_QC,P_QI,PARAM_FIRST_SCALAR, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CASE DEFAULT + + END SELECT cps_select + + END SUBROUTINE cu_init + +!================================================================== + SUBROUTINE mp_init(RAINNC,config_flags,restart,warm_rain, & + adv_moist_cond, & + MPDT, DT, DX, DY, LOWLYR, & ! for eta mp + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & ! for eta mp + mp_restart_state,tbpvs_state,tbpvs0_state, & ! eta mp + allowed_to_read, start_of_simulation, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------ + USE module_mp_ncloud3 + USE module_mp_ncloud5 + USE module_mp_wsm3 + USE module_mp_wsm5 + USE module_mp_wsm6 + USE module_mp_etanew + USE module_mp_thompson +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ +! Arguments + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: restart + LOGICAL , INTENT(OUT) :: warm_rain,adv_moist_cond + REAL , INTENT(IN) :: MPDT, DT, DX, DY + LOGICAL , INTENT(IN) :: start_of_simulation + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER , DIMENSION( ims:ime , jms:jme ) ,INTENT(INOUT) :: LOWLYR + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: RAINNC + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: & + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY + REAL , DIMENSION(:) ,INTENT(INOUT) :: mp_restart_state,tbpvs_state,tbpvs0_state + LOGICAL , INTENT(IN) :: allowed_to_read + +! Local + INTEGER :: i, j, itf, jtf + + warm_rain = .false. + adv_moist_cond = .true. + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + IF(start_of_simulation)THEN + DO j=jts,jtf + DO i=its,itf + RAINNC(i,j) = 0. + ENDDO + ENDDO + ENDIF + + mp_select: SELECT CASE(config_flags%mp_physics) + + CASE (KESSLERSCHEME) + warm_rain = .true. + CASE (WSM3SCHEME) + CALL wsm3init(rhoair0,rhowater,rhosnow,cliq,cv, allowed_to_read ) + CASE (WSM5SCHEME) + CALL wsm5init(rhoair0,rhowater,rhosnow,cliq,cv, allowed_to_read ) + CASE (WSM6SCHEME) + CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cv, allowed_to_read ) + CASE (ETAMPNEW) + adv_moist_cond = .false. + CALL etanewinit (MPDT,DT,DX,DY,LOWLYR,restart, & + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & + mp_restart_state,tbpvs_state,tbpvs0_state,& + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE (THOMPSON) + CALL thompson_init + CASE (NCEPCLOUD3) + CALL ncloud3init(rhoair0,rhowater,rhosnow,cliq,cv, allowed_to_read ) + CASE (NCEPCLOUD5) + CALL ncloud5init(rhoair0,rhowater,rhosnow,cliq,cv, allowed_to_read ) + + CASE DEFAULT + + END SELECT mp_select + + END SUBROUTINE mp_init + +#if ( EM_CORE == 1 ) +!========================================================== + SUBROUTINE fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN, & + RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & + config_flags,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + +!-------------------------------------------------------------------- + USE module_fdda_psufddagd +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: restart + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN) :: DT, FGDT + INTEGER , INTENT(IN) :: id + INTEGER , INTENT(INOUT) :: STEPFG + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RUNDGDTEN, & + RVNDGDTEN, & + RTHNDGDTEN, & + RQVNDGDTEN + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: RMUNDGDTEN + + LOGICAL, INTENT(IN) :: allowed_to_read +!-------------------------------------------------------------------- + +!-- calculate pbl time step + + STEPFG = nint(FGDT*60./DT) + STEPFG = max(STEPFG,1) + + +!-- initialize fdda scheme + + fdda_select: SELECT CASE(config_flags%grid_fdda) + + CASE (PSUFDDAGD) + CALL fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& + config_flags%run_hours, & + config_flags%if_no_pbl_nudging_uv, & + config_flags%if_no_pbl_nudging_t, & + config_flags%if_no_pbl_nudging_q, & + config_flags%if_zfac_uv, & + config_flags%k_zfac_uv, & + config_flags%if_zfac_t, & + config_flags%k_zfac_t, & + config_flags%if_zfac_q, & + config_flags%k_zfac_q, & + config_flags%guv, & + config_flags%gt, config_flags%gq, & + config_flags%if_ramping, config_flags%dtramp_min, & + config_flags%gfdda_end_h, & + restart, allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE DEFAULT + + END SELECT fdda_select + + END SUBROUTINE fg_init + +!------------------------------------------------------------------- + SUBROUTINE fdob_init(obs_nudge_opt, maxdom, inest, parid, & + dx_coarse, restart, obs_twindo, itimestep, & + s_sn_cg, e_sn_cg, s_we_cg, e_we_cg, & + fdob, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + +!-------------------------------------------------------------------- + USE module_domain + USE module_fddaobs_rtfdda +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + INTEGER , INTENT(IN) :: maxdom + INTEGER , INTENT(IN) :: obs_nudge_opt(maxdom) + INTEGER , INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER , INTENT(IN) :: inest + INTEGER , INTENT(IN) :: parid(maxdom) + REAL , INTENT(IN) :: dx_coarse + LOGICAL , INTENT(IN) :: restart + REAL , INTENT(INOUT) :: obs_twindo + INTEGER , INTENT(IN) :: itimestep + INTEGER, intent(in) :: s_sn_cg ! starting north-south coarse-grid index + INTEGER, intent(in) :: e_sn_cg ! ending north-south coarse-grid index + INTEGER, intent(in) :: s_we_cg ! starting west-east coarse-grid index + INTEGER, intent(in) :: e_we_cg ! ending west-east coarse-grid index + + TYPE(fdob_type), INTENT(INOUT) :: fdob + + INTEGER :: e_sn ! ending north-south grid index +!-------------------------------------------------------------------- +!-- initialize fdda obs-nudging scheme + + e_sn = jde + CALL fddaobs_init(obs_nudge_opt, maxdom, inest, parid, & + dx_coarse, restart, obs_twindo, itimestep, & + e_sn, s_sn_cg, e_sn_cg, s_we_cg, e_we_cg, & + fdob, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + END SUBROUTINE fdob_init +#endif + +!-------------------------------------------------------------------- + SUBROUTINE z2sigma(zf,zh,sf,sh,p_top,pptop,config_flags, & + allowed_to_read , & + kds,kde,kms,kme,kts,kte) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN) :: kds,kde,kms,kme,kts,kte + REAL , DIMENSION( kms:kme ), INTENT(IN) :: zf,zh + REAL , DIMENSION( kms:kme ), INTENT(OUT):: sf,sh + REAL , INTENT(IN) :: p_top + REAL , INTENT(OUT) :: pptop + TYPE (grid_config_rec_type) :: config_flags + LOGICAL , INTENT(IN) :: allowed_to_read +! Local + REAL R, G, TS, GAMMA, PS, ZTROP, TSTRAT, PTROP, Z, T, P, ZTOP, PTOP + INTEGER K + + IF(zf(kde/2) .GT. 1.0)THEN +! Height levels assumed (zeta coordinate) +! Convert to sigma using standard atmosphere for pressure-height relation +! constants for standard atmosphere definition + r=287.05 + g=9.80665 + ts=288.15 + gamma=-6.5/1000. + ps=1013.25 + ztrop=11000. + tstrat=ts+gamma*ztrop + ptrop=ps*(tstrat/ts)**(-g/(gamma*r)) + + do k=kde,kds,-1 +! full levels + z=zf(k) + if(z.le.ztrop)then + t=ts+gamma*z + p=ps*(t/ts)**(-g/(gamma*r)) + else + t=tstrat + p=ptrop*exp(-g*(z-ztrop)/(r*tstrat)) + endif + if(k.eq.kde)then + ztop=zf(k) + ptop=p + endif + sf(k)=(p-ptop)/(ps-ptop) +! half levels + if(k.ne.kds)then + z=0.5*(zf(k)+zf(k-1)) + if(z.le.ztrop)then + t=ts+gamma*z + p=ps*(t/ts)**(-g/(gamma*r)) + else + t=tstrat + p=ptrop*exp(-g*(z-ztrop)/(r*tstrat)) + endif + sh(k-1)=(p-ptop)/(ps-ptop) + endif + enddo + pptop=ptop/10. + ELSE +! Levels are already sigma/eta + do k=kde,kds,-1 +! sf(k)=zf(kde-k+kds) +! if(k .ne. kde)sh(k)=zh(kde-1-k+kds) + sf(k)=zf(k) + if(k .ne. kde)sh(k)=zh(k) + enddo + pptop=p_top/1000. + + ENDIF + + END SUBROUTINE z2sigma + +END MODULE module_physics_init diff --git a/wrfv2_fire/phys/module_progtm.F b/wrfv2_fire/phys/module_progtm.F new file mode 100755 index 00000000..86ac47eb --- /dev/null +++ b/wrfv2_fire/phys/module_progtm.F @@ -0,0 +1,93 @@ + module module_progtm + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + SAVE +! + integer,parameter:: NTYPE=9 + integer,parameter:: NGRID=22 + real(kind=kind_phys) B(NTYPE), SATPSI(NTYPE), SATKT(NTYPE), & + & TSAT(NTYPE), & + & DFK(NGRID,NTYPE), & + & KTK(NGRID,NTYPE), & + & DFKT(NGRID,NTYPE) +! +! the nine soil types are: +! 1 ... loamy sand (coarse) +! 2 ... silty clay loam (medium) +! 3 ... light clay (fine) +! 4 ... sandy loam (coarse-medium) +! 5 ... sandy clay (coarse-fine) +! 6 ... clay loam (medium-fine) +! 7 ... sandy clay loam (coarse-med-fine) +! 8 ... loam (organic) +! 9 ... ice (use loamy sand property) +! +! DATA B/4.05,4.38,4.9,5.3,5.39,7.12,7.75,8.52, +! & 10.4,10.4,11.4/ +! DATA SATPSI/.121,.09,.218,.786,.478,.299,.356,.63, +! & .153,.49,.405/ +! DATA SATKT/1.76E-4,1.5633E-4,3.467E-5,7.2E-6,6.95E-6, +! & 6.3E-6,1.7E-6,2.45E-6,2.167E-6,1.033E-6, +! & 1.283E-6/ +! DATA TSAT/.395,.41,.435,.485,.451,.42,.477,.476, +! & .426,.492,.482/ + data b/4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/ + data satpsi/.04,.62,.47,.14,.10,.26,.14,.36,.04/ + data satkt/1.41e-5,.20e-5,.10e-5,.52e-5,.72e-5, & + & .25e-5,.45e-5,.34e-5,1.41e-5/ + data tsat/.421,.464,.468,.434,.406,.465,.404,.439,.421/ +! + contains + subroutine GRDDF + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer i, k + real(kind=kind_phys) dynw, f1, f2, theta +! +! GRDDF SETS UP MOISTURE DIFFUSIVITY AND HYDROLIC CONDUCTIVITY +! FOR ALL SOIL TYPES +! GRDDFS SETS UP THERMAL DIFFUSIVITY FOR ALL SOIL TYPES +! + DO K = 1, NTYPE + DYNW = TSAT(K) * .05 + F1 = B(K) * SATKT(K) * SATPSI(K) / TSAT(K) ** (B(K) + 3.) + F2 = SATKT(K) / TSAT(K) ** (B(K) * 2. + 3.) +! +! CONVERT FROM M/S TO KG M-2 S-1 UNIT +! + F1 = F1 * 1000. + F2 = F2 * 1000. + DO I = 1, NGRID + THETA = FLOAT(I-1) * DYNW + THETA = MIN(TSAT(K),THETA) + DFK(I,K) = F1 * THETA ** (B(K) + 2.) + KTK(I,K) = F2 * THETA ** (B(K) * 2. + 3.) + ENDDO + ENDDO + END SUBROUTINE + subroutine GRDKT + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer i, k + real(kind=kind_phys) dynw, f1, theta, pf + DO K = 1, NTYPE + DYNW = TSAT(K) * .05 + F1 = LOG10(SATPSI(K)) + B(K) * LOG10(TSAT(K)) + 2. + DO I = 1, NGRID + THETA = FLOAT(I-1) * DYNW + THETA = MIN(TSAT(K),THETA) + IF(THETA.GT.0.) THEN + PF = F1 - B(K) * LOG10(THETA) + ELSE + PF = 5.2 + ENDIF + IF(PF.LE.5.1) THEN + DFKT(I,K) = EXP(-(2.7+PF)) * 420. + ELSE + DFKT(I,K) = .1744 + ENDIF + ENDDO + ENDDO + END SUBROUTINE +! + end module module_progtm diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F new file mode 100644 index 00000000..fea78131 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_cam.F @@ -0,0 +1,11544 @@ +MODULE module_ra_cam + integer, parameter :: r8 = 8 + real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90 + integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer + + integer :: ixcldliq + integer :: ixcldice +! integer :: levsiz ! size of level dimension on dataset + integer, parameter :: nbands = 2 ! Number of spectral bands + integer, parameter :: naer_all = 12 + 1 + integer, parameter :: naer = 10 + 1 + integer, parameter :: bnd_nbr_LW=7 + integer, parameter :: ndstsz = 4 ! number of dust size bins + integer :: idxSUL + integer :: idxSSLT + integer :: idxDUSTfirst + integer :: idxCARBONfirst + integer :: idxOCPHO + integer :: idxBCPHO + integer :: idxOCPHI + integer :: idxBCPHI + integer :: idxBG + integer :: idxVOLC + + integer :: mxaerl ! Maximum level of background aerosol + +! indices to sections of array that represent +! groups of aerosols + + integer, parameter :: & + numDUST = 4, & + numCARBON = 4 + +! portion of each species group to use in computation +! of relative radiative forcing. + + real(r8) :: sulscl_rf = 0._r8 ! + real(r8) :: carscl_rf = 0._r8 + real(r8) :: ssltscl_rf = 0._r8 + real(r8) :: dustscl_rf = 0._r8 + real(r8) :: bgscl_rf = 0._r8 + real(r8) :: volcscl_rf = 0._r8 + +! "background" aerosol species mmr. + real(r8) :: tauback = 0._r8 + +! portion of each species group to use in computation +! of aerosol forcing in driving the climate + real(r8) :: sulscl = 1._r8 + real(r8) :: carscl = 1._r8 + real(r8) :: ssltscl = 1._r8 + real(r8) :: dustscl = 1._r8 + real(r8) :: volcscl = 1._r8 + +!From volcrad.F90 module + integer, parameter :: idx_LW_0500_0650=3 + integer, parameter :: idx_LW_0650_0800=4 + integer, parameter :: idx_LW_0800_1000=5 + integer, parameter :: idx_LW_1000_1200=6 + integer, parameter :: idx_LW_1200_2000=7 + +! First two values represent the overlap of volcanics with the non-window +! (0-800, 1200-2200 cm^-1) and window (800-1200 cm^-1) regions.| Coefficients +! were derived using crm_volc_minimize.pro with spectral flux optimization +! on first iteration, total heating rate on subsequent iterations (2-9). +! Five profiles for HLS, HLW, MLS, MLW, and TRO conditions were given equal +! weight. RMS heating rate errors for a visible stratospheric optical +! depth of 1.0 are 0.02948 K/day. +! + real(r8) :: abs_cff_mss_aer(bnd_nbr_LW) = & + (/ 70.257384, 285.282943, & + 1.0273851e+02, 6.3073303e+01, 1.2039569e+02, & + 3.6343643e+02, 2.7138528e+02 /) + +!From radae.F90 module + real(r8), parameter:: min_tp_h2o = 160.0 ! min T_p for pre-calculated abs/emis + real(r8), parameter:: max_tp_h2o = 349.999999 ! max T_p for pre-calculated abs/emis + real(r8), parameter:: dtp_h2o = 21.111111111111 ! difference in adjacent elements of tp_h2o + real(r8), parameter:: min_te_h2o = -120.0 ! min T_e-T_p for pre-calculated abs/emis + real(r8), parameter:: max_te_h2o = 79.999999 ! max T_e-T_p for pre-calculated abs/emis + real(r8), parameter:: dte_h2o = 10.0 ! difference in adjacent elements of te_h2o + real(r8), parameter:: min_rh_h2o = 0.0 ! min RH for pre-calculated abs/emis + real(r8), parameter:: max_rh_h2o = 1.19999999 ! max RH for pre-calculated abs/emis + real(r8), parameter:: drh_h2o = 0.2 ! difference in adjacent elements of RH + real(r8), parameter:: min_lu_h2o = -8.0 ! min log_10(U) for pre-calculated abs/emis + real(r8), parameter:: min_u_h2o = 1.0e-8 ! min pressure-weighted path-length + real(r8), parameter:: max_lu_h2o = 3.9999999 ! max log_10(U) for pre-calculated abs/emis + real(r8), parameter:: dlu_h2o = 0.5 ! difference in adjacent elements of lu_h2o + real(r8), parameter:: min_lp_h2o = -3.0 ! min log_10(P) for pre-calculated abs/emis + real(r8), parameter:: min_p_h2o = 1.0e-3 ! min log_10(P) for pre-calculated abs/emis + real(r8), parameter:: max_lp_h2o = -0.0000001 ! max log_10(P) for pre-calculated abs/emis + real(r8), parameter:: dlp_h2o = 0.3333333333333 ! difference in adjacent elements of lp_h2o + integer, parameter :: n_u = 25 ! Number of U in abs/emis tables + integer, parameter :: n_p = 10 ! Number of P in abs/emis tables + integer, parameter :: n_tp = 10 ! Number of T_p in abs/emis tables + integer, parameter :: n_te = 21 ! Number of T_e in abs/emis tables + integer, parameter :: n_rh = 7 ! Number of RH in abs/emis tables + real(r8):: c16,c17,c26,c27,c28,c29,c30,c31 + real(r8):: fwcoef ! Farwing correction constant + real(r8):: fwc1,fwc2 ! Farwing correction constants + real(r8):: fc1 ! Farwing correction constant + real(r8):: amco2 ! Molecular weight of co2 (g/mol) + real(r8):: amd ! Molecular weight of dry air (g/mol) + real(r8):: p0 ! Standard pressure (dynes/cm**2) + + real(r8):: ah2onw(n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (non-window) + real(r8):: eh2onw(n_p, n_tp, n_u, n_te, n_rh) ! emissivity (non-window) + real(r8):: ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (window, for adjacent layers) + real(r8):: cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for absorptivity (window) + real(r8):: cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for emissivity (window) + real(r8):: ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for absorptivity (window) + real(r8):: ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for emissivity (window) + +! +! Constant coefficients for water vapor overlap with trace gases. +! Reference: Ramanathan, V. and P.Downey, 1986: A Nonisothermal +! Emissivity and Absorptivity Formulation for Water Vapor +! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666 +! +#ifndef G95 + real(r8):: coefh(2,4) = reshape( & + (/ (/5.46557e+01,-7.30387e-02/), & + (/1.09311e+02,-1.46077e-01/), & + (/5.11479e+01,-6.82615e-02/), & + (/1.02296e+02,-1.36523e-01/) /), (/2,4/) ) +! + real(r8):: coefj(3,2) = reshape( & + (/ (/2.82096e-02,2.47836e-04,1.16904e-06/), & + (/9.27379e-02,8.04454e-04,6.88844e-06/) /), (/3,2/) ) +! + real(r8):: coefk(3,2) = reshape( & + (/ (/2.48852e-01,2.09667e-03,2.60377e-06/) , & + (/1.03594e+00,6.58620e-03,4.04456e-06/) /), (/3,2/) ) +#else +! this use of reshape does not work in g95, as of 20061212 jm + real(r8):: coefh(2,4) + real(r8):: coefj(3,2) + real(r8):: coefk(3,2) +#endif + + integer, parameter :: ntemp = 192 ! Number of temperatures in H2O sat. table for Tp + real(r8) :: estblh2o(0:ntemp) ! saturation vapor pressure for H2O for Tp rang + integer, parameter :: o_fa = 6 ! Degree+1 of poly of T_e for absorptivity as U->inf. + integer, parameter :: o_fe = 6 ! Degree+1 of poly of T_e for emissivity as U->inf. + +!----------------------------------------------------------------------------- +! Data for f in C/H/E fit -- value of A and E as U->infinity +! New C/LT/E fit (Hitran 2K, CKD 2.4) -- no change +! These values are determined by integrals of Planck functions or +! derivatives of Planck functions only. +!----------------------------------------------------------------------------- +! +! fa/fe coefficients for 2 bands (0-800 & 1200-2200, 800-1200 cm^-1) +! +! Coefficients of polynomial for f_a in T_e +! +#ifndef G95 + real(r8), parameter:: fat(o_fa,nbands) = reshape( (/ & + (/-1.06665373E-01, 2.90617375E-02, -2.70642049E-04, & ! 0-800&1200-2200 cm^-1 + 1.07595511E-06, -1.97419681E-09, 1.37763374E-12/), & ! 0-800&1200-2200 cm^-1 + (/ 1.10666537E+00, -2.90617375E-02, 2.70642049E-04, & ! 800-1200 cm^-1 + -1.07595511E-06, 1.97419681E-09, -1.37763374E-12/) /) & ! 800-1200 cm^-1 + , (/o_fa,nbands/) ) +! +! Coefficients of polynomial for f_e in T_e +! + real(r8), parameter:: fet(o_fe,nbands) = reshape( (/ & + (/3.46148163E-01, 1.51240299E-02, -1.21846479E-04, & ! 0-800&1200-2200 cm^-1 + 4.04970123E-07, -6.15368936E-10, 3.52415071E-13/), & ! 0-800&1200-2200 cm^-1 + (/6.53851837E-01, -1.51240299E-02, 1.21846479E-04, & ! 800-1200 cm^-1 + -4.04970123E-07, 6.15368936E-10, -3.52415071E-13/) /) & ! 800-1200 cm^-1 + , (/o_fa,nbands/) ) +#else +! this use of reshape does not work in g95, as of 20061212 jm + real(r8):: fat(o_fa,nbands) + real(r8):: fet(o_fe,nbands) +#endif + + + real(r8) :: gravit ! Acceleration of gravity (cgs) + real(r8) :: rga ! 1./gravit + real(r8) :: gravmks ! Acceleration of gravity (mks) + real(r8) :: cpair ! Specific heat of dry air + real(r8) :: epsilo ! Ratio of mol. wght of H2O to dry air + real(r8) :: epsqs ! Ratio of mol. wght of H2O to dry air + real(r8) :: sslp ! Standard sea-level pressure + real(r8) :: stebol ! Stefan-Boltzmann's constant + real(r8) :: rgsslp ! 0.5/(gravit*sslp) + real(r8) :: dpfo3 ! Voigt correction factor for O3 + real(r8) :: dpfco2 ! Voigt correction factor for CO2 + real(r8) :: dayspy ! Number of days per 1 year + real(r8) :: pie ! 3.14..... + real(r8) :: mwdry ! molecular weight dry air ~ kg/kmole (shr_const_mwdair) + real(r8) :: scon ! solar constant (not used in WRF) + real(r8) :: co2mmr +real(r8) :: mwco2 ! molecular weight of carbon dioxide +real(r8) :: mwh2o ! molecular weight water vapor (shr_const_mwwv) +real(r8) :: mwch4 ! molecular weight ch4 +real(r8) :: mwn2o ! molecular weight n2o +real(r8) :: mwf11 ! molecular weight cfc11 +real(r8) :: mwf12 ! molecular weight cfc12 +real(r8) :: cappa ! R/Cp +real(r8) :: rair ! Gas constant for dry air (J/K/kg) +real(r8) :: tmelt ! freezing T of fresh water ~ K +real(r8) :: r_universal ! Universal gas constant ~ J/K/kmole +real(r8) :: latvap ! latent heat of evaporation ~ J/kg +real(r8) :: latice ! latent heat of fusion ~ J/kg +real(r8) :: zvir ! R_V/R_D - 1. + integer plenest ! length of saturation vapor pressure table + parameter (plenest=250) +! +! Table of saturation vapor pressure values es from tmin degrees +! to tmax+1 degrees k in one degree increments. ttrice defines the +! transition region where es is a combination of ice & water values +! +real(r8) estbl(plenest) ! table values of saturation vapor pressure +real(r8) tmin ! min temperature (K) for table +real(r8) tmax ! max temperature (K) for table +real(r8) pcf(6) ! polynomial coeffs -> es transition water to ice +!real(r8), allocatable :: pin(:) ! ozone pressure level (levsiz) +!real(r8), allocatable :: ozmix(:,:,:) ! mixing ratio +!real(r8), allocatable, target :: abstot_3d(:,:,:,:) ! Non-adjacent layer absorptivites +!real(r8), allocatable, target :: absnxt_3d(:,:,:,:) ! Nearest layer absorptivities +!real(r8), allocatable, target :: emstot_3d(:,:,:) ! Total emissivity + +!From aer_optics.F90 module +integer, parameter :: idxVIS = 8 ! index to visible band +integer, parameter :: nrh = 1000 ! number of relative humidity values for look-up-table +integer, parameter :: nspint = 19 ! number of spectral intervals +real(r8) :: ksul(nrh, nspint) ! sulfate specific extinction ( m^2 g-1 ) +real(r8) :: wsul(nrh, nspint) ! sulfate single scattering albedo +real(r8) :: gsul(nrh, nspint) ! sulfate asymmetry parameter +real(r8) :: kbg(nspint) ! background specific extinction ( m^2 g-1 ) +real(r8) :: wbg(nspint) ! background single scattering albedo +real(r8) :: gbg(nspint) ! background asymmetry parameter +real(r8) :: ksslt(nrh, nspint) ! sea-salt specific extinction ( m^2 g-1 ) +real(r8) :: wsslt(nrh, nspint) ! sea-salt single scattering albedo +real(r8) :: gsslt(nrh, nspint) ! sea-salt asymmetry parameter +real(r8) :: kcphil(nrh, nspint) ! hydrophilic carbon specific extinction ( m^2 g-1 ) +real(r8) :: wcphil(nrh, nspint) ! hydrophilic carbon single scattering albedo +real(r8) :: gcphil(nrh, nspint) ! hydrophilic carbon asymmetry parameter +real(r8) :: kcphob(nspint) ! hydrophobic carbon specific extinction ( m^2 g-1 ) +real(r8) :: wcphob(nspint) ! hydrophobic carbon single scattering albedo +real(r8) :: gcphob(nspint) ! hydrophobic carbon asymmetry parameter +real(r8) :: kcb(nspint) ! black carbon specific extinction ( m^2 g-1 ) +real(r8) :: wcb(nspint) ! black carbon single scattering albedo +real(r8) :: gcb(nspint) ! black carbon asymmetry parameter +real(r8) :: kvolc(nspint) ! volcanic specific extinction ( m^2 g-1) +real(r8) :: wvolc(nspint) ! volcanic single scattering albedo +real(r8) :: gvolc(nspint) ! volcanic asymmetry parameter +real(r8) :: kdst(ndstsz, nspint) ! dust specific extinction ( m^2 g-1 ) +real(r8) :: wdst(ndstsz, nspint) ! dust single scattering albedo +real(r8) :: gdst(ndstsz, nspint) ! dust asymmetry parameter +! +!From comozp.F90 module + real(r8) cplos ! constant for ozone path length integral + real(r8) cplol ! constant for ozone path length integral + +!From ghg_surfvals.F90 module + real(r8) :: co2vmr = 3.550e-4 ! co2 volume mixing ratio + real(r8) :: n2ovmr = 0.311e-6 ! n2o volume mixing ratio + real(r8) :: ch4vmr = 1.714e-6 ! ch4 volume mixing ratio + real(r8) :: f11vmr = 0.280e-9 ! cfc11 volume mixing ratio + real(r8) :: f12vmr = 0.503e-9 ! cfc12 volume mixing ratio + + + integer :: ntoplw ! top level to solve for longwave cooling (WRF sets this to 1 for model top below 10 mb) + + logical :: masterproc = .true. + logical :: ozncyc ! true => cycle ozone dataset + logical :: dosw ! True => shortwave calculation this timestep + logical :: dolw ! True => longwave calculation this timestep + logical :: indirect ! True => include indirect radiative effects of sulfate aerosols +! logical :: doabsems ! True => abs/emiss calculation this timestep + logical :: radforce = .false. ! True => calculate aerosol shortwave forcing + logical :: trace_gas=.false. ! set true for chemistry + logical :: strat_volcanic = .false. ! True => volcanic aerosol mass available + + +CONTAINS + +subroutine camrad(RTHRATENLW,RTHRATENSW, & + SWUPT,SWUPTC,SWDNT,SWDNTC, & + LWUPT,LWUPTC,LWDNT,LWDNTC, & + SWUPB,SWUPBC,SWDNB,SWDNBC, & + LWUPB,LWUPBC,LWDNB,LWDNBC, & + swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr, & + GSW,GLW,XLAT,XLONG, & + ALBEDO,t_phy,TSK,EMISS, & + QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & + f_ice_phy,f_rain_phy, & + p_phy,p8w,z,pi_phy,rho_phy,dz8w, & + CLDFRA,XLAND,XICE,SNOW, & + ozmixm,pin0,levsiz,num_months, & + m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0, & + cam_abs_dim1, cam_abs_dim2, & + paerlev,naer_c, & + GMT,JULDAY,JULIAN,DT,XTIME,DECLIN,SOLCON, & + RADT,DEGRAD,n_cldadv, & + abstot_3d, absnxt_3d, emstot_3d, & + doabsems, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_wrf_error + +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + LOGICAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG + LOGICAL, INTENT(INout) :: doabsems + + INTEGER, INTENT(IN ) :: n_cldadv + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: JULIAN + REAL, INTENT(IN ) :: DT + INTEGER, INTENT(IN ) :: levsiz, num_months + INTEGER, INTENT(IN ) :: paerlev, naer_c + INTEGER, INTENT(IN ) :: cam_abs_dim1, cam_abs_dim2 + + + REAL, INTENT(IN ) :: RADT,DEGRAD, & + XTIME,DECLIN,SOLCON,GMT +! +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: P_PHY, & + P8W, & + Z, & + pi_PHY, & + rho_PHY, & + dz8w, & + T_PHY, & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + CLDFRA + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATENLW, & + RTHRATENSW +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAT, & + XLONG, & + XLAND, & + XICE, & + SNOW, & + EMISS, & + TSK, & + ALBEDO + + REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), & + INTENT(IN ) :: OZMIXM + + REAL, DIMENSION(levsiz), INTENT(IN ) :: PIN0 + + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN ) :: m_psp,m_psn + REAL, DIMENSION(paerlev), intent(in) :: m_hybi0 + REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), & + INTENT(IN ) :: aerosolcp, aerosolcn + +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: GSW, GLW + +! saving arrays for doabsems reduction of radiation calcs + + REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ), & + INTENT(INOUT) :: abstot_3d + REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1 , jms:jme ), & + INTENT(INOUT) :: absnxt_3d + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: emstot_3d + + +! Added outputs of total and clearsky fluxes etc +! Note that k=1 refers to the half level below the model lowest level (Sfc) +! k=kme refers to the half level above the model highest level (TOA) +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & +! INTENT(INOUT) :: swup, & +! swupclear, & +! swdn, & +! swdnclear, & +! lwup, & +! lwupclear, & +! lwdn, & +! lwdnclear + + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::& + SWUPT,SWUPTC,SWDNT,SWDNTC, & + LWUPT,LWUPTC,LWDNT,LWDNTC, & + SWUPB,SWUPBC,SWDNB,SWDNBC, & + LWUPB,LWUPBC,LWDNB,LWDNBC + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: swcf, & + lwcf, & + olr, & + coszr + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(OUT ) :: cemiss, & ! cloud emissivity for isccp + taucldc, & ! cloud water optical depth for isccp + taucldi ! cloud ice optical depth for isccp +! +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + +! LOCAL VARIABLES + + INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp + INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n + integer :: begchunk, endchunk + + REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24 + + real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups + real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps + real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t + real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) :: pint, lnpint + real(r8), DIMENSION( its:ite , kts:kte+1 ) :: phyd + real(r8), DIMENSION( its:ite , kts:kte ) :: phydmid + real(r8), DIMENSION( its:ite ) :: fp + real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q +! real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm ! reference pressures at midpoints +! real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi ! reference pressures at interfaces + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cicewp ! in-cloud cloud ice water path + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cliqwp ! in-cloud cloud liquid water path + real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxcl ! cloud water optical depth + real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxci ! cloud ice optical depth + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: emis ! cloud emissivity + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rel ! effective drop radius (microns) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rei ! ice effective drop size (microns) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn ! Maximum values of pressure for each + integer , dimension( 1:ite-its+1 ) :: nmxrgn ! Number of maximally overlapped regions + + real(r8), dimension( 1:ite-its+1 ) :: fsns ! Surface absorbed solar flux + real(r8), dimension( 1:ite-its+1 ) :: fsnt ! Net column abs solar flux at model top + real(r8), dimension( 1:ite-its+1 ) :: flns ! Srf longwave cooling (up-down) flux + real(r8), dimension( 1:ite-its+1 ) :: flnt ! Net outgoing lw flux at model top +! Added outputs of total and clearsky fluxes etc + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsup ! Upward total sky solar + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsupc ! Upward clear sky solar + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdn ! Downward total sky solar + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdnc ! Downward clear sky solar + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flup ! Upward total sky longwave + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flupc ! Upward clear sky longwave + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldn ! Downward total sky longwave + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldnc ! Downward clear sky longwave + real(r8), dimension( 1:ite-its+1 ) :: swcftoa ! Top of the atmosphere solar cloud forcing + real(r8), dimension( 1:ite-its+1 ) :: lwcftoa ! Top of the atmosphere longwave cloud forcing + real(r8), dimension( 1:ite-its+1 ) :: olrtoa ! Top of the atmosphere outgoing longwave +! + real(r8), dimension( 1:ite-its+1 ) :: sols ! Downward solar rad onto surface (sw direct) + real(r8), dimension( 1:ite-its+1 ) :: soll ! Downward solar rad onto surface (lw direct) + real(r8), dimension( 1:ite-its+1 ) :: solsd ! Downward solar rad onto surface (sw diffuse) + real(r8), dimension( 1:ite-its+1 ) :: solld ! Downward solar rad onto surface (lw diffuse) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrs ! Solar heating rate + real(r8), dimension( 1:ite-its+1 ) :: fsds ! Flux Shortwave Downwelling Surface + real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrl ! Longwave cooling rate + real(r8), dimension( 1:ite-its+1 ) :: flwds ! Surface down longwave flux + real(r8), dimension( 1:ite-its+1, levsiz, num_months ) :: ozmixmj ! monthly ozone mixing ratio + real(r8), dimension( 1:ite-its+1, levsiz ) :: ozmix ! ozone mixing ratio (time interpolated) + real(r8), dimension(levsiz) :: pin ! ozone pressure level + real(r8), dimension(1:ite-its+1) :: m_psjp,m_psjn ! MATCH surface pressure + real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljp ! monthly aerosol concentrations + real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljn ! monthly aerosol concentrations + real(r8), dimension(paerlev) :: m_hybi + real(r8), dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns + real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity + real(r8), dimension(its:ite,kts:kte,4) :: absnxt ! Total nearest layer absorptivity + real(r8), dimension(its:ite,kts:kte+1) :: emstot ! Total emissivity + CHARACTER(LEN=256) :: msgstr + +#if !defined(MAC_KLUDGE) && !defined(G95) + lchnk = 1 + begchunk = ims + endchunk = ime + ncol = ite - its + 1 + pcols= ite - its + 1 + pver = kte - kts + 1 + pverp= pver + 1 + pverr = kte - kts + 1 + pverrp= pverr + 1 +! number of advected constituents and non-advected constituents (including water vapor) + ppcnst = n_cldadv +! number of non-advected constituents + pnats = 0 + pcnst = ppcnst-pnats + +! check the # species defined for the input climatology and naer + +! if(naer_c.ne.naer) then +! WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer + if(naer_c.ne.naer_all) then + WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all + CALL wrf_error_fatal ( wrf_err_message ) + endif +! +!=================================================== +! Radiation computations +!=================================================== + + do k=1,levsiz + pin(k)=pin0(k) + enddo + + do k=1,paerlev + m_hybi(k)=m_hybi0(k) + enddo + +! check for uninitialized arrays + if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems)then + CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart') + doabsems = .true. + endif + + do j =jts,jte + +! +! Cosine solar zenith angle for current time step +! + +! call zenith (calday, clat, clon, coszrs, ncol) + + do i = its,ite + ii = i - its + 1 + ! XT24 is the fractional part of simulation days plus half of RADT expressed in + ! units of minutes + ! JULIAN is in days + ! RADT is in minutes + XT24=MOD(XTIME+RADT*0.5,1440.) + TLOCTM=GMT+XT24/60.+XLONG(I,J)/15. + HRANG=15.*(TLOCTM-12.)*DEGRAD + XXLAT=XLAT(I,J)*DEGRAD + clat(ii)=xxlat + coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) + enddo + +! moist variables + + do k = kts,kte + kk = kte - k + kts + do i = its,ite + ii = i - its + 1 + q(ii,kk,1) = max(1.e-10,qv3d(i,k,j)) + IF ( F_QI .and. F_QC .and. F_QS ) THEN + q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)) + q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)+qs3d(i,k,j)) + ELSE IF ( F_QC .and. F_QR ) THEN +! Warm rain or simple ice + q(ii,kk,ixcldliq) = 0. + q(ii,kk,ixcldice) = 0. + if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)) + if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)) + ELSE IF ( F_QC ) THEN +! For Ferrier + q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)*f_ice_phy(i,k,j)) + q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j))) + ELSE + q(ii,kk,ixcldliq) = 0. + q(ii,kk,ixcldice) = 0. + ENDIF + cld(ii,kk) = CLDFRA(I,K,J) + enddo + enddo + + do i = its,ite + ii = i - its + 1 + landfrac(ii) = 2.-XLAND(I,J) + landm(ii) = landfrac(ii) + snowh(ii) = 0.001*SNOW(I,J) + icefrac(ii) = XICE(I,J) + enddo + + do m=1,num_months + do k=1,levsiz + do i = its,ite + ii = i - its + 1 + ozmixmj(ii,k,m) = ozmixm(i,k,j,m) + enddo + enddo + enddo + + do i = its,ite + ii = i - its + 1 + m_psjp(ii) = m_psp(i,j) + m_psjn(ii) = m_psn(i,j) + enddo + + do n=1,naer_c + do k=1,paerlev + do i = its,ite + ii = i - its + 1 + aerosoljp(ii,k,n) = aerosolcp(i,k,j,n) + aerosoljn(ii,k,n) = aerosolcn(i,k,j,n) + enddo + enddo + enddo + +! +! Complete radiation calculations +! + do i = its,ite + ii = i - its + 1 + lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4 + enddo + +! first guess + do k = kts,kte+1 + do i = its,ite + if(k.eq.kts)then + phyd(i,k)=p8w(i,kts,j) + else + phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j) + endif + enddo + enddo + +! correction factor FP to match p8w(I,kts,J)-p8w(I,kte+1,J) + do i = its,ite + fp(i)=(p8w(I,kts,J)-p8w(I,kte+1,J))/(PHYD(i,KTS)-PHYD(i,KTE+1)) + enddo + +! final pass + do k = kts+1,kte+1 + do i = its,ite + phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)*fp(i) + phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k)) + enddo + enddo + + do k = kts,kte+1 + kk = kte - k + kts + 1 + do i = its,ite + ii = i - its + 1 + pint(ii,kk) = phyd(i,k) + if(k.eq.kts)ps(ii)=pint(ii,kk) + lnpint(ii,kk) = log(pint(ii,kk)) + enddo + enddo + + if(.not.doabsems)then +! do kk = kts,kte+1 + do kk = 1,cam_abs_dim2 + do kk1 = kts,kte+1 + do i = its,ite + abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j) + enddo + enddo + enddo +! do kk = 1,4 + do kk = 1,cam_abs_dim1 + do kk1 = kts,kte + do i = its,ite + absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j) + enddo + enddo + enddo + do kk = kts,kte+1 + do i = its,ite + emstot(i,kk) = emstot_3d(i,kk,j) + enddo + enddo + endif + + do k = kts,kte + kk = kte - k + kts + do i = its,ite + ii = i - its + 1 + pmid(ii,kk) = phydmid(i,k) + lnpmid(ii,kk) = log(pmid(ii,kk)) + lnpint(ii,kk) = log(pint(ii,kk)) + pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk) + t(ii,kk) = t_phy(i,k,j) + zm(ii,kk) = z(i,k,j) + enddo + enddo + + +! Compute cloud water/ice paths and optical properties for input to radiation + + call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, & + pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh) + + do i = its,ite + ii = i - its + 1 +! use same albedo for direct and diffuse +! change this when separate values are provided + asdir(ii) = albedo(i,j) + asdif(ii) = albedo(i,j) + aldir(ii) = albedo(i,j) + aldif(ii) = albedo(i,j) + enddo + +! WRF allocate space here (not needed if oznini is called) +! allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90 + + call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid, & + pint, lnpmid, lnpint, pdel, t, q, & + cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif, & + aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME, & + pin, ozmixmj, ozmix, levsiz, num_months, & + m_psjp,m_psjn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, & + doabsems, abstot, absnxt, emstot, & + fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, & + fsns, fsnt ,flns ,flnt , & + qrs, qrl, flwds, rel, rei, & + sols, soll, solsd, solld, & + landfrac, zm, fsds) + + do k = kts,kte + kk = kte - k + kts + do i = its,ite + ii = i - its + 1 + RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j)) + RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j)) + cemiss(i,k,j) = emis(ii,kk) + taucldc(i,k,j) = tauxcl(ii,kk) + taucldi(i,k,j) = tauxci(ii,kk) + enddo + enddo + + if(doabsems)then +! do kk = kts,kte+1 + do kk = 1,cam_abs_dim2 + do kk1 = kts,kte+1 + do i = its,ite + abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk) + enddo + enddo + enddo +! do kk = 1,4 + do kk = 1,cam_abs_dim1 + do kk1 = kts,kte + do i = its,ite + absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk) + enddo + enddo + enddo + do kk = kts,kte+1 + do i = its,ite + emstot_3d(i,kk,j) = emstot(i,kk) + enddo + enddo + endif + + IF(PRESENT(SWUPT))THEN +! Added shortwave and longwave upward/downward total and clear sky fluxes + do k = kts,kte+1 + kk = kte +1 - k + kts + do i = its,ite + ii = i - its + 1 +! swup(i,k,j) = fsup(ii,kk) +! swupclear(i,k,j) = fsupc(ii,kk) +! swdn(i,k,j) = fsdn(ii,kk) +! swdnclear(i,k,j) = fsdnc(ii,kk) +! lwup(i,k,j) = flup(ii,kk) +! lwupclear(i,k,j) = flupc(ii,kk) +! lwdn(i,k,j) = fldn(ii,kk) +! lwdnclear(i,k,j) = fldnc(ii,kk) + if(k.eq.kte+1)then + swupt(i,j) = fsup(ii,kk) + swuptc(i,j) = fsupc(ii,kk) + swdnt(i,j) = fsdn(ii,kk) + swdntc(i,j) = fsdnc(ii,kk) + lwupt(i,j) = fsup(ii,kk) + lwuptc(i,j) = fsupc(ii,kk) + lwdnt(i,j) = fsdn(ii,kk) + lwdntc(i,j) = fsdnc(ii,kk) + endif + if(k.eq.kts)then + swupb(i,j) = fsup(ii,kk) + swupbc(i,j) = fsupc(ii,kk) + swdnb(i,j) = fsdn(ii,kk) + swdnbc(i,j) = fsdnc(ii,kk) + lwupb(i,j) = fsup(ii,kk) + lwupbc(i,j) = fsupc(ii,kk) + lwdnb(i,j) = fsdn(ii,kk) + lwdnbc(i,j) = fsdnc(ii,kk) + endif +! if(i.eq.30.and.j.eq.30) then +! print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk) +! print 1234, 'long ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk) +! 1234 format (a6,4i4,4f10.3) +! endif + enddo + enddo + ENDIF + + do i = its,ite + ii = i - its + 1 + GLW(I,J) = flwds(ii) + GSW(I,J) = fsns(ii) +! Added shortwave and longwave cloud forcing at TOA + swcf(i,j) = swcftoa(ii) + lwcf(i,j) = lwcftoa(ii) + olr(i,j) = olrtoa(ii) + coszr(i,j) = coszrs(ii) + enddo + + enddo ! j-loop + +#endif + +end subroutine camrad +!==================================================================== + SUBROUTINE camradinit( & + R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, & + ozmixm,pin,levsiz,XLAT,num_months, & + m_psp,m_psn,m_hybi,aerosolcp,aerosolcn, & + paerlev,naer_c, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_wrf_error + USE module_configure + +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL, intent(in) :: pptop + REAL, INTENT(IN) :: R_D,R_V,CP,G,STBOLT,EP_2 + + REAL, DIMENSION( kms:kme ) :: shalf + + INTEGER, INTENT(IN ) :: levsiz, num_months + INTEGER, INTENT(IN ) :: paerlev, naer_c + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT + + REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), & + INTENT(INOUT ) :: OZMIXM + + REAL, DIMENSION(levsiz), INTENT(INOUT ) :: PIN + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT ) :: m_psp,m_psn + REAL, DIMENSION(paerlev), INTENT(INOUT ) :: m_hybi + REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), & + INTENT(INOUT) :: aerosolcp,aerosolcn + + REAL(r8) :: pstd + REAL(r8) :: rh2o, cpair + +#if !defined(MAC_KLUDGE) && !defined(G95) + ozncyc = .true. + dosw = .true. + dolw = .true. + indirect = .true. + ixcldliq = 2 + ixcldice = 3 +#if (NMM_CORE != 1) +! aerosol array is not in the NMM Registry +! since CAM radiation not available to NMM (yet) +! so this is blocked out to enable CAM compilation with NMM + idxSUL = P_SUL + idxSSLT = P_SSLT + idxDUSTfirst = P_DUST1 + idxOCPHO = P_OCPHO + idxCARBONfirst = P_OCPHO + idxBCPHO = P_BCPHO + idxOCPHI = P_OCPHI + idxBCPHI = P_BCPHI + idxBG = P_BG + idxVOLC = P_VOLC +#endif + + pstd = 101325.0 +! from physconst module + mwdry = 28.966 ! molecular weight dry air ~ kg/kmole (shr_const_mwdair) + mwco2 = 44. ! molecular weight co2 + mwh2o = 18.016 ! molecular weight water vapor (shr_const_mwwv) + mwch4 = 16. ! molecular weight ch4 + mwn2o = 44. ! molecular weight n2o + mwf11 = 136. ! molecular weight cfc11 + mwf12 = 120. ! molecular weight cfc12 + cappa = R_D/CP + rair = R_D + tmelt = 273.16 ! freezing T of fresh water ~ K + r_universal = 6.02214e26 * STBOLT ! Universal gas constant ~ J/K/kmole + latvap = 2.501e6 ! latent heat of evaporation ~ J/kg + latice = 3.336e5 ! latent heat of fusion ~ J/kg + zvir = R_V/R_D - 1. + rh2o = R_V + cpair = CP +! + epsqs = EP_2 + + CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 ) + CALL esinti(epsqs ,latvap ,latice ,rh2o ,cpair ,tmelt ) + CALL oznini(ozmixm,pin,levsiz,num_months,XLAT, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + +#endif + + END SUBROUTINE camradinit + +#if !defined(MAC_KLUDGE) && !defined(G95) +subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +! +! This subroutine assumes uniform distribution of ozone concentration. +! It should be replaced by monthly climatology that varies latitudinally and vertically +! + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: levsiz, num_months + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT + + REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), & + INTENT(OUT ) :: OZMIXM + + REAL, DIMENSION(levsiz), INTENT(OUT ) :: PIN + +! Local + INTEGER, PARAMETER :: latsiz = 64 + INTEGER, PARAMETER :: lonsiz = 1 + INTEGER :: i, j, k, itf, jtf, ktf, m, pin_unit, lat_unit, oz_unit + REAL :: interp_pt + CHARACTER*256 :: message + + REAL, DIMENSION( lonsiz, levsiz, latsiz, num_months ) :: & + OZMIXIN + + REAL, DIMENSION(latsiz) :: lat_ozone + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + +!-- read in ozone pressure data + + WRITE(message,*)'num_months = ',num_months + CALL wrf_debug(50,message) + + pin_unit = 27 + OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD') + do k = 1,levsiz + READ (pin_unit,*)pin(k) + end do + close(27) + + do k=1,levsiz + pin(k) = pin(k)*100. + end do + +!-- read in ozone lat data + + lat_unit = 28 + OPEN(lat_unit, FILE='ozone_lat.formatted',FORM='FORMATTED',STATUS='OLD') + do j = 1,latsiz + READ (lat_unit,*)lat_ozone(j) + end do + close(28) + + +!-- read in ozone data + + oz_unit = 29 + OPEN(oz_unit, FILE='ozone.formatted',FORM='FORMATTED',STATUS='OLD') + + do m=2,num_months + do j=1,latsiz ! latsiz=64 + do k=1,levsiz ! levsiz=59 + do i=1,lonsiz ! lonsiz=1 + READ (oz_unit,*)ozmixin(i,k,j,m) + enddo + enddo + enddo + enddo + close(29) + + +!-- latitudinally interpolate ozone data (and extend longitudinally) +!-- using function lin_interpol2(x, f, y) result(g) +! Purpose: +! interpolates f(x) to point y +! assuming f(x) = f(x0) + a * (x - x0) +! where a = ( f(x1) - f(x0) ) / (x1 - x0) +! x0 <= x <= x1 +! assumes x is monotonically increasing +! real, intent(in), dimension(:) :: x ! grid points +! real, intent(in), dimension(:) :: f ! grid function values +! real, intent(in) :: y ! interpolation point +! real :: g ! interpolated function value +!--------------------------------------------------------------------------- + + do m=2,num_months + do j=jts,jtf + do k=1,levsiz + do i=its,itf + interp_pt=XLAT(i,j) + ozmixm(i,k,j,m)=lin_interpol2(lat_ozone(:),ozmixin(1,k,:,m),interp_pt) + enddo + enddo + enddo + enddo + +! Old code for fixed ozone + +! pin(1)=70. +! DO k=2,levsiz +! pin(k)=pin(k-1)+16. +! ENDDO + +! DO k=1,levsiz +! pin(k) = pin(k)*100. +! end do + +! DO m=1,num_months +! DO j=jts,jtf +! DO i=its,itf +! DO k=1,2 +! ozmixm(i,k,j,m)=1.e-6 +! ENDDO +! DO k=3,levsiz +! ozmixm(i,k,j,m)=1.e-7 +! ENDDO +! ENDDO +! ENDDO +! ENDDO + +END SUBROUTINE oznini + +subroutine aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +! +! This subroutine assumes a uniform aerosol distribution in both time and space. +! It should be modified if aerosol data are available from WRF-CHEM or other sources +! + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: paerlev,naer_c + + REAL, intent(in) :: pptop + REAL, DIMENSION( kms:kme ), intent(in) :: shalf + + REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), & + INTENT(INOUT ) :: aerosolcn , aerosolcp + + REAL, DIMENSION(paerlev), INTENT(OUT ) :: m_hybi + REAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT ) :: m_psp,m_psn + + REAL :: psurf + real, dimension(29) :: hybi + integer k ! index through vertical levels + + INTEGER :: i, j, itf, jtf, ktf,m + + data hybi/0, 0.0065700002014637, 0.0138600002974272, 0.023089999333024, & + 0.0346900001168251, 0.0491999983787537, 0.0672300010919571, & + 0.0894500017166138, 0.116539999842644, 0.149159997701645, & + 0.187830001115799, 0.232859998941422, 0.284209996461868, & + 0.341369986534119, 0.403340011835098, 0.468600004911423, & + 0.535290002822876, 0.601350009441376, 0.66482001543045, & + 0.724009990692139, 0.777729988098145, 0.825269997119904, & + 0.866419970989227, 0.901350021362305, 0.930540025234222, & + 0.954590022563934, 0.974179983139038, 0.990000009536743, 1/ + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + do k=1,paerlev + m_hybi(k)=hybi(k) + enddo + +! +! mxaerl = max number of levels (from bottom) for background aerosol +! Limit background aerosol height to regions below 900 mb +! + + psurf = 1.e05 + mxaerl = 0 +! do k=pver,1,-1 + do k=kms,kme-1 +! if (hypm(k) >= 9.e4) mxaerl = mxaerl + 1 + if (shalf(k)*psurf+pptop >= 9.e4) mxaerl = mxaerl + 1 + end do + mxaerl = max(mxaerl,1) +! if (masterproc) then + write(6,*)'AEROSOLS: Background aerosol will be limited to ', & + 'bottom ',mxaerl,' model interfaces.' +! 'bottom ',mxaerl,' model interfaces. Top interface is ', & +! hypi(pverp-mxaerl),' pascals' +! end if + + DO j=jts,jtf + DO i=its,itf + m_psp(i,j)=psurf + m_psn(i,j)=psurf + ENDDO + ENDDO + + DO j=jts,jtf + DO i=its,itf + DO k=1,paerlev + aerosolcp(i,k,j,idxSUL)=1.e-7 + aerosolcn(i,k,j,idxSUL)=1.e-7 + aerosolcp(i,k,j,idxSSLT)=1.e-22 + aerosolcn(i,k,j,idxSSLT)=1.e-22 + aerosolcp(i,k,j,idxDUSTfirst)=1.e-7 + aerosolcn(i,k,j,idxDUSTfirst)=1.e-7 + aerosolcp(i,k,j,idxDUSTfirst+1)=1.e-7 + aerosolcn(i,k,j,idxDUSTfirst+1)=1.e-7 + aerosolcp(i,k,j,idxDUSTfirst+2)=1.e-7 + aerosolcn(i,k,j,idxDUSTfirst+2)=1.e-7 + aerosolcp(i,k,j,idxDUSTfirst+3)=1.e-7 + aerosolcn(i,k,j,idxDUSTfirst+3)=1.e-7 + aerosolcp(i,k,j,idxOCPHO)=1.e-7 + aerosolcn(i,k,j,idxOCPHO)=1.e-7 + aerosolcp(i,k,j,idxBCPHO)=1.e-9 + aerosolcn(i,k,j,idxBCPHO)=1.e-9 + aerosolcp(i,k,j,idxOCPHI)=1.e-7 + aerosolcn(i,k,j,idxOCPHI)=1.e-7 + aerosolcp(i,k,j,idxBCPHI)=1.e-8 + aerosolcn(i,k,j,idxBCPHI)=1.e-8 + ENDDO + ENDDO + ENDDO + + call aer_optics_initialize + + +END subroutine aerosol_init + + subroutine aer_optics_initialize + +USE module_wrf_error +USE module_dm + +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use pmgrid ! masterproc is here +! use ioFileMod, only: getfil + +!#if ( defined SPMD ) +! use mpishorthand +!#endif + implicit none + +! include 'netcdf.inc' + + + integer :: nrh_opac ! number of relative humidity values for OPAC data + integer :: nbnd ! number of spectral bands, should be identical to nspint + real(r8), parameter :: wgt_sscm = 6.0 / 7.0 + integer :: krh_opac ! rh index for OPAC rh grid + integer :: krh ! another rh index + integer :: ksz ! dust size bin index + integer :: kbnd ! band index + + real(r8) :: rh ! local relative humidity variable + + integer, parameter :: irh=8 + real(r8) :: rh_opac(irh) ! OPAC relative humidity grid + real(r8) :: ksul_opac(irh,nspint) ! sulfate extinction + real(r8) :: wsul_opac(irh,nspint) ! single scattering albedo + real(r8) :: gsul_opac(irh,nspint) ! asymmetry parameter + real(r8) :: ksslt_opac(irh,nspint) ! sea-salt + real(r8) :: wsslt_opac(irh,nspint) + real(r8) :: gsslt_opac(irh,nspint) + real(r8) :: kssam_opac(irh,nspint) ! sea-salt accumulation mode + real(r8) :: wssam_opac(irh,nspint) + real(r8) :: gssam_opac(irh,nspint) + real(r8) :: ksscm_opac(irh,nspint) ! sea-salt coarse mode + real(r8) :: wsscm_opac(irh,nspint) + real(r8) :: gsscm_opac(irh,nspint) + real(r8) :: kcphil_opac(irh,nspint) ! hydrophilic organic carbon + real(r8) :: wcphil_opac(irh,nspint) + real(r8) :: gcphil_opac(irh,nspint) + real(r8) :: dummy(nspint) + + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER cam_aer_unit + integer :: i + +! read aerosol optics data + + IF ( wrf_dm_on_monitor() ) THEN + DO i = 10,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + cam_aer_unit = i + GOTO 2010 + ENDIF + ENDDO + cam_aer_unit = -1 + 2010 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( cam_aer_unit , IWORDSIZE ) + IF ( cam_aer_unit < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_cam: aer_optics_initialize: Can not find unused fortran unit to read in lookup table.' ) + ENDIF + + IF ( wrf_dm_on_monitor() ) THEN + OPEN(cam_aer_unit,FILE='CAM_AEROPT_DATA', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9010) + call wrf_debug(50,'reading CAM_AEROPT_DATA') + ENDIF + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 ) + + IF ( wrf_dm_on_monitor() ) then + READ (cam_aer_unit,ERR=9010) dummy + READ (cam_aer_unit,ERR=9010) rh_opac + READ (cam_aer_unit,ERR=9010) ksul_opac + READ (cam_aer_unit,ERR=9010) wsul_opac + READ (cam_aer_unit,ERR=9010) gsul_opac + READ (cam_aer_unit,ERR=9010) kssam_opac + READ (cam_aer_unit,ERR=9010) wssam_opac + READ (cam_aer_unit,ERR=9010) gssam_opac + READ (cam_aer_unit,ERR=9010) ksscm_opac + READ (cam_aer_unit,ERR=9010) wsscm_opac + READ (cam_aer_unit,ERR=9010) gsscm_opac + READ (cam_aer_unit,ERR=9010) kcphil_opac + READ (cam_aer_unit,ERR=9010) wcphil_opac + READ (cam_aer_unit,ERR=9010) gcphil_opac + READ (cam_aer_unit,ERR=9010) kcb + READ (cam_aer_unit,ERR=9010) wcb + READ (cam_aer_unit,ERR=9010) gcb + READ (cam_aer_unit,ERR=9010) kdst + READ (cam_aer_unit,ERR=9010) wdst + READ (cam_aer_unit,ERR=9010) gdst + READ (cam_aer_unit,ERR=9010) kbg + READ (cam_aer_unit,ERR=9010) wbg + READ (cam_aer_unit,ERR=9010) gbg + READ (cam_aer_unit,ERR=9010) kvolc + READ (cam_aer_unit,ERR=9010) wvolc + READ (cam_aer_unit,ERR=9010) gvolc + endif + + DM_BCAST_MACRO(rh_opac) + DM_BCAST_MACRO(ksul_opac) + DM_BCAST_MACRO(wsul_opac) + DM_BCAST_MACRO(gsul_opac) + DM_BCAST_MACRO(kssam_opac) + DM_BCAST_MACRO(wssam_opac) + DM_BCAST_MACRO(gssam_opac) + DM_BCAST_MACRO(ksscm_opac) + DM_BCAST_MACRO(wsscm_opac) + DM_BCAST_MACRO(gsscm_opac) + DM_BCAST_MACRO(kcphil_opac) + DM_BCAST_MACRO(wcphil_opac) + DM_BCAST_MACRO(gcphil_opac) + DM_BCAST_MACRO(kcb) + DM_BCAST_MACRO(wcb) + DM_BCAST_MACRO(gcb) + DM_BCAST_MACRO(kvolc) + DM_BCAST_MACRO(wvolc) + DM_BCAST_MACRO(kdst) + DM_BCAST_MACRO(wdst) + DM_BCAST_MACRO(gdst) + DM_BCAST_MACRO(kbg) + DM_BCAST_MACRO(wbg) + DM_BCAST_MACRO(gbg) + + IF ( wrf_dm_on_monitor() ) CLOSE (cam_aer_unit) + + ! map OPAC aerosol species onto CAM aerosol species + ! CAM name OPAC name + ! sul or SO4 = suso sulfate soluble + ! sslt or SSLT = 1/7 ssam + 6/7 sscm sea-salt accumulation/coagulation mode + ! cphil or CPHI = waso water soluble (carbon) + ! cphob or CPHO = waso @ rh = 0 + ! cb or BCPHI/BCPHO = soot + + ksslt_opac(:,:) = (1.0 - wgt_sscm) * kssam_opac(:,:) + wgt_sscm * ksscm_opac(:,:) + + wsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) & + + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) ) & + / ksslt_opac(:,:) + + gsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) * gssam_opac(:,:) & + + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) * gsscm_opac(:,:) ) & + / ( ksslt_opac(:,:) * wsslt_opac(:,:) ) + + do i=1,nspint + kcphob(i) = kcphil_opac(1,i) + wcphob(i) = wcphil_opac(1,i) + gcphob(i) = gcphil_opac(1,i) + end do + + ! interpolate optical properties of hygrospopic aerosol species + ! onto a uniform relative humidity grid + + nbnd = nspint + + do krh = 1, nrh + rh = 1.0_r8 / nrh * (krh - 1) + do kbnd = 1, nbnd + ksul(krh, kbnd) = exp_interpol( rh_opac, & + ksul_opac(:, kbnd) / ksul_opac(1, kbnd), rh ) * ksul_opac(1, kbnd) + wsul(krh, kbnd) = lin_interpol( rh_opac, & + wsul_opac(:, kbnd) / wsul_opac(1, kbnd), rh ) * wsul_opac(1, kbnd) + gsul(krh, kbnd) = lin_interpol( rh_opac, & + gsul_opac(:, kbnd) / gsul_opac(1, kbnd), rh ) * gsul_opac(1, kbnd) + ksslt(krh, kbnd) = exp_interpol( rh_opac, & + ksslt_opac(:, kbnd) / ksslt_opac(1, kbnd), rh ) * ksslt_opac(1, kbnd) + wsslt(krh, kbnd) = lin_interpol( rh_opac, & + wsslt_opac(:, kbnd) / wsslt_opac(1, kbnd), rh ) * wsslt_opac(1, kbnd) + gsslt(krh, kbnd) = lin_interpol( rh_opac, & + gsslt_opac(:, kbnd) / gsslt_opac(1, kbnd), rh ) * gsslt_opac(1, kbnd) + kcphil(krh, kbnd) = exp_interpol( rh_opac, & + kcphil_opac(:, kbnd) / kcphil_opac(1, kbnd), rh ) * kcphil_opac(1, kbnd) + wcphil(krh, kbnd) = lin_interpol( rh_opac, & + wcphil_opac(:, kbnd) / wcphil_opac(1, kbnd), rh ) * wcphil_opac(1, kbnd) + gcphil(krh, kbnd) = lin_interpol( rh_opac, & + gcphil_opac(:, kbnd) / gcphil_opac(1, kbnd), rh ) * gcphil_opac(1, kbnd) + end do + end do + + RETURN +9010 CONTINUE + WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_aer_unit + CALL wrf_error_fatal(errmess) + +END subroutine aer_optics_initialize + + function exp_interpol(x, f, y) result(g) + + ! Purpose: + ! interpolates f(x) to point y + ! assuming f(x) = f(x0) exp a(x - x0) + ! where a = ( ln f(x1) - ln f(x0) ) / (x1 - x0) + ! x0 <= x <= x1 + ! assumes x is monotonically increasing + + ! Author: D. Fillmore + +! use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + real(r8), intent(in), dimension(:) :: x ! grid points + real(r8), intent(in), dimension(:) :: f ! grid function values + real(r8), intent(in) :: y ! interpolation point + real(r8) :: g ! interpolated function value + + integer :: k ! interpolation point index + integer :: n ! length of x + real(r8) :: a + + n = size(x) + + ! find k such that x(k) < y =< x(k+1) + ! set k = 1 if y <= x(1) and k = n-1 if y > x(n) + + if (y <= x(1)) then + k = 1 + else if (y >= x(n)) then + k = n - 1 + else + k = 1 + do while (y > x(k+1) .and. k < n) + k = k + 1 + end do + end if + + ! interpolate + a = ( log( f(k+1) / f(k) ) ) / ( x(k+1) - x(k) ) + g = f(k) * exp( a * (y - x(k)) ) + + end function exp_interpol + + function lin_interpol(x, f, y) result(g) + + ! Purpose: + ! interpolates f(x) to point y + ! assuming f(x) = f(x0) + a * (x - x0) + ! where a = ( f(x1) - f(x0) ) / (x1 - x0) + ! x0 <= x <= x1 + ! assumes x is monotonically increasing + + ! Author: D. Fillmore + +! use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + real(r8), intent(in), dimension(:) :: x ! grid points + real(r8), intent(in), dimension(:) :: f ! grid function values + real(r8), intent(in) :: y ! interpolation point + real(r8) :: g ! interpolated function value + + integer :: k ! interpolation point index + integer :: n ! length of x + real(r8) :: a + + n = size(x) + + ! find k such that x(k) < y =< x(k+1) + ! set k = 1 if y <= x(1) and k = n-1 if y > x(n) + + if (y <= x(1)) then + k = 1 + else if (y >= x(n)) then + k = n - 1 + else + k = 1 + do while (y > x(k+1) .and. k < n) + k = k + 1 + end do + end if + + ! interpolate + a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) ) + g = f(k) + a * (y - x(k)) + + end function lin_interpol + + function lin_interpol2(x, f, y) result(g) + + ! Purpose: + ! interpolates f(x) to point y + ! assuming f(x) = f(x0) + a * (x - x0) + ! where a = ( f(x1) - f(x0) ) / (x1 - x0) + ! x0 <= x <= x1 + ! assumes x is monotonically increasing + + ! Author: D. Fillmore :: J. Done changed from r8 to r4 + + implicit none + + real, intent(in), dimension(:) :: x ! grid points + real, intent(in), dimension(:) :: f ! grid function values + real, intent(in) :: y ! interpolation point + real :: g ! interpolated function value + + integer :: k ! interpolation point index + integer :: n ! length of x + real :: a + + n = size(x) + + ! find k such that x(k) < y =< x(k+1) + ! set k = 1 if y <= x(1) and k = n-1 if y > x(n) + + if (y <= x(1)) then + k = 1 + else if (y >= x(n)) then + k = n - 1 + else + k = 1 + do while (y > x(k+1) .and. k < n) + k = k + 1 + end do + end if + + ! interpolate + a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) ) + g = f(k) + a * (y - x(k)) + + end function lin_interpol2 + +subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: levsiz, num_months,pcols + + REAL(r8), DIMENSION( pcols, levsiz, num_months ), & + INTENT(IN ) :: ozmixmj + + REAL, INTENT(IN ) :: XTIME,GMT + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: JULIAN + REAL, INTENT(IN ) :: DT + + REAL(r8), DIMENSION( pcols, levsiz ), & + INTENT(OUT ) :: ozmix + !Local + REAL(r8) :: intJULIAN + integer :: np1,np,nm,m,k,i + integer :: IJUL + integer, dimension(12) :: date_oz + data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/ + real(r8) :: cdayozp, cdayozm + real(r8) :: fact1, fact2 + logical :: finddate + CHARACTER(LEN=256) :: msgstr + + ! JULIAN starts from 0.0 at 0Z on 1 Jan. + intJULIAN = JULIAN + 1.0_r8 ! offset by one day +! jan 1st 00z is julian=1.0 here + IJUL=INT(intJULIAN) +! Note that following will drift. +! Need to use actual month/day info to compute julian. + intJULIAN=intJULIAN-FLOAT(IJUL) + IJUL=MOD(IJUL,365) + IF(IJUL.EQ.0)IJUL=365 + intJULIAN=intJULIAN+IJUL + np1=1 + finddate=.false. + do m=1,num_months + if(date_oz(m).gt.intjulian.and..not.finddate) then + np1=m + finddate=.true. + endif + enddo + cdayozp=date_oz(np1) + if(np1.gt.1) then + cdayozm=date_oz(np1-1) + np=np1 + nm=np-1 + else + cdayozm=date_oz(12) + np=np1 + nm=12 + endif + call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, & + fact1, fact2) + +! +! Time interpolation. +! + do k=1,levsiz + do i=1,pcols + ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2 + end do + end do + +END subroutine oznint + +subroutine getfactors (cycflag, np1, cdayminus, cdayplus, cday, & + fact1, fact2) +!--------------------------------------------------------------------------- +! +! Purpose: Determine time interpolation factors (normally for a boundary dataset) +! for linear interpolation. +! +! Method: Assume 365 days per year. Output variable fact1 will be the weight to +! apply to data at calendar time "cdayminus", and fact2 the weight to apply +! to data at time "cdayplus". Combining these values will produce a result +! valid at time "cday". Output arguments fact1 and fact2 will be between +! 0 and 1, and fact1 + fact2 = 1 to roundoff. +! +! Author: Jim Rosinski +! +!--------------------------------------------------------------------------- + implicit none +! +! Arguments +! + logical, intent(in) :: cycflag ! flag indicates whether dataset is being cycled yearly + + integer, intent(in) :: np1 ! index points to forward time slice matching cdayplus + + real(r8), intent(in) :: cdayminus ! calendar day of rearward time slice + real(r8), intent(in) :: cdayplus ! calendar day of forward time slice + real(r8), intent(in) :: cday ! calenar day to be interpolated to + real(r8), intent(out) :: fact1 ! time interpolation factor to apply to rearward time slice + real(r8), intent(out) :: fact2 ! time interpolation factor to apply to forward time slice + +! character(len=*), intent(in) :: str ! string to be added to print in case of error (normally the callers name) +! +! Local workspace +! + real(r8) :: deltat ! time difference (days) between cdayminus and cdayplus + real(r8), parameter :: daysperyear = 365. ! number of days in a year +! +! Initial sanity checks +! +! if (np1 == 1 .and. .not. cycflag) then +! call endrun ('GETFACTORS:'//str//' cycflag false and forward month index = Jan. not allowed') +! end if + +! if (np1 < 1) then +! call endrun ('GETFACTORS:'//str//' input arg np1 must be > 0') +! end if + + if (cycflag) then + if ((cday < 1.) .or. (cday > (daysperyear+1.))) then + write(6,*) 'GETFACTORS:', ' bad cday=',cday +! call endrun () + end if + else + if (cday < 1.) then + write(6,*) 'GETFACTORS:', ' bad cday=',cday +! call endrun () + end if + end if +! +! Determine time interpolation factors. Account for December-January +! interpolation if dataset is being cycled yearly. +! + if (cycflag .and. np1 == 1) then ! Dec-Jan interpolation + deltat = cdayplus + daysperyear - cdayminus + if (cday > cdayplus) then ! We are in December + fact1 = (cdayplus + daysperyear - cday)/deltat + fact2 = (cday - cdayminus)/deltat + else ! We are in January + fact1 = (cdayplus - cday)/deltat + fact2 = (cday + daysperyear - cdayminus)/deltat + end if + else + deltat = cdayplus - cdayminus + fact1 = (cdayplus - cday)/deltat + fact2 = (cday - cdayminus)/deltat + end if + + if (.not. validfactors (fact1, fact2)) then + write(6,*) 'GETFACTORS: ', ' bad fact1 and/or fact2=', fact1, fact2 +! call endrun () + end if + + return +end subroutine getfactors + +logical function validfactors (fact1, fact2) +!--------------------------------------------------------------------------- +! +! Purpose: check sanity of time interpolation factors to within 32-bit roundoff +! +!--------------------------------------------------------------------------- + implicit none + + real(r8), intent(in) :: fact1, fact2 ! time interpolation factors + + validfactors = .true. + if (abs(fact1+fact2-1.) > 1.e-6 .or. & + fact1 > 1.000001 .or. fact1 < -1.e-6 .or. & + fact2 > 1.000001 .or. fact2 < -1.e-6) then + + validfactors = .false. + end if + + return +end function validfactors + +subroutine get_rf_scales(scales) + + real(r8), intent(out)::scales(naer_all) ! scale aerosols by this amount + + integer i ! loop index + + scales(idxBG) = bgscl_rf + scales(idxSUL) = sulscl_rf + scales(idxSSLT) = ssltscl_rf + + do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1 + scales(i) = carscl_rf + enddo + + do i = idxDUSTfirst, idxDUSTfirst+numDUST-1 + scales(i) = dustscl_rf + enddo + + scales(idxVOLC) = volcscl_rf + +end subroutine get_rf_scales + +subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, & + aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale) +!------------------------------------------------------------------ +! +! Input: +! time at which aerosol mmrs are needed (get_curr_calday()) +! chunk index +! CAM's vertical grid (pint) +! +! Output: +! values for Aerosol Mass Mixing Ratios at specified time +! on vertical grid specified by CAM (AEROSOLt) +! +! Method: +! first determine which indexs of aerosols are the bounding data sets +! interpolate both onto vertical grid aerm(),aerp(). +! from those two, interpolate in time. +! +!------------------------------------------------------------------ + +! use volcanicmass, only: get_volcanic_mass +! use timeinterp, only: getfactors +! +! aerosol fields interpolated to current time step +! on pressure levels of this time step. +! these should be made read-only for other modules +! Is allocation done correctly here? +! + integer, intent(in) :: c ! Chunk Id. + integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp + real(r8), intent(in) :: pint(pcols,pverp) ! midpoint pres. + real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount + REAL, INTENT(IN ) :: XTIME,GMT + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: JULIAN + REAL, INTENT(IN ) :: DT + real(r8), intent(in ) :: m_psp(pcols),m_psn(pcols) ! Match surface pressure + real(r8), intent(in ) :: aerosoljp(pcols,paerlev,naer_c) + real(r8), intent(in ) :: aerosoljn(pcols,paerlev,naer_c) + real(r8), intent(in ) :: m_hybi(paerlev) + + real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols +! +! Local workspace +! + real(r8) caldayloc ! calendar day of current timestep + real(r8) fact1, fact2 ! time interpolation factors + + integer :: nm = 1 ! index to prv month in array. init to 1 and toggle between 1 and 2 + integer :: np = 2 ! index to nxt month in array. init to 2 and toggle between 1 and 2 + integer :: mo_nxt = bigint ! index to nxt month in file + integer :: mo_prv ! index to previous month + + real(r8) :: cdaym = inf ! calendar day of prv month + real(r8) :: cdayp = inf ! calendar day of next month + real(r8) :: Mid(12) ! Days into year for mid month date + data Mid/16.5, 46.0, 75.5, 106.0, 136.5, 167.0, 197.5, 228.5, 259.0, 289.5, 320.0, 350.5 / + + integer i, k, j ! spatial indices + integer m ! constituent index + integer lats(pcols),lons(pcols) ! latitude and longitudes of column + integer ncol ! number of columns + INTEGER IJUL + REAL(r8) intJULIAN + + real(r8) speciesmin(naer) ! minimal value for each species +! +! values before current time step "the minus month" +! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr +! aerosolp(pcols,pver) is value of next month's aerosol mmr +! (think minus and plus or values to left and right of point to be interpolated) +! + real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month +! +! values beyond (or at) current time step "the plus month" +! + real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month + CHARACTER(LEN=256) :: msgstr + + ! JULIAN starts from 0.0 at 0Z on 1 Jan. + intJULIAN = JULIAN + 1.0_r8 ! offset by one day +! jan 1st 00z is julian=1.0 here + IJUL=INT(intJULIAN) +! Note that following will drift. +! Need to use actual month/day info to compute julian. + intJULIAN=intJULIAN-FLOAT(IJUL) + IJUL=MOD(IJUL,365) + IF(IJUL.EQ.0)IJUL=365 + caldayloc=intJULIAN+IJUL + + if (caldayloc < Mid(1)) then + mo_prv = 12 + mo_nxt = 1 + else if (caldayloc >= Mid(12)) then + mo_prv = 12 + mo_nxt = 1 + else + do i = 2 , 12 + if (caldayloc < Mid(i)) then + mo_prv = i-1 + mo_nxt = i + exit + end if + end do + end if +! +! Set initial calendar day values +! + cdaym = Mid(mo_prv) + cdayp = Mid(mo_nxt) + +! +! Determine time interpolation factors. 1st arg says we are cycling 1 year of data +! + call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, & + fact1, fact2) +! +! interpolate (prv and nxt month) bounding datasets onto cam vertical grid. +! compute mass mixing ratios on CAMS's pressure coordinate +! for both the "minus" and "plus" months +! +! ncol = get_ncols_p(c) + ncol = pcols + +! call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c) +! call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c) + + call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c) + call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c) + +! +! Time interpolate. +! + do m=1,naer + do k=1,pver + do i=1,ncol + AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2 + end do + end do + end do + +! do i=1,ncol +! Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2 +! end do +! +! get background aerosol (tuning) field +! + call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG)) + +! +! find volcanic aerosol masses +! +! if (strat_volcanic) then +! call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC)) +! else + AEROSOLt(:,:,idxVOLC) = 0._r8 +! endif + +! +! exit if mmr is negative (we have previously set +! cumulative mass to be a decreasing function.) +! + speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species + + do m=1,naer + do k=1,pver + do i=1,ncol + if (AEROSOLt(i, k, m) < speciesmin(m)) then + write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting' + write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m) +! call endrun () + end if + end do + end do + end do +! +! scale any AEROSOLS as required +! + call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale) + + return +end subroutine get_aerosol + +subroutine vert_interpolate (Match_ps, aerosolc, m_hybi, paerlev, naer_c, pint, n, AEROSOL_mmr, pcols, pver, pverp, ncol, c) +!-------------------------------------------------------------------- +! Input: match surface pressure, cam interface pressure, +! month index, number of columns, chunk index +! +! Output: Aerosol mass mixing ratio (AEROSOL_mmr) +! +! Method: +! interpolate column mass (cumulative) from match onto +! cam's vertical grid (pressure coordinate) +! convert back to mass mixing ratio +! +!-------------------------------------------------------------------- + +! use physconst, only: gravit + + integer, intent(in) :: paerlev,naer_c,pcols,pver,pverp + real(r8), intent(out) :: AEROSOL_mmr(pcols,pver,naer) ! aerosol mmr from MATCH + real(r8), intent(in) :: Match_ps(pcols) ! surface pressure at a particular month + real(r8), intent(in) :: pint(pcols,pverp) ! interface pressure from CAM + real(r8), intent(in) :: aerosolc(pcols,paerlev,naer_c) + real(r8), intent(in) :: m_hybi(paerlev) + + integer, intent(in) :: ncol,c ! chunk index and number of columns + integer, intent(in) :: n ! prv or nxt month index +! +! Local workspace +! + integer m ! index to aerosol species + integer kupper(pcols) ! last upper bound for interpolation + integer i, k, kk, kkstart, kount ! loop vars for interpolation + integer isv, ksv, msv ! loop indices to save + + logical bad ! indicates a bad point found + logical lev_interp_comp ! interpolation completed for a level + + real(r8) AEROSOL(pcols,pverp,naer) ! cumulative mass of aerosol in column beneath upper + ! interface of level in column at particular month + real(r8) dpl, dpu ! lower and upper intepolation factors + real(r8) v_coord ! vertical coordinate + real(r8) m_to_mmr ! mass to mass mixing ratio conversion factor + real(r8) AER_diff ! temp var for difference between aerosol masses + +! call t_startf ('vert_interpolate') +! +! Initialize index array +! + do i=1,ncol + kupper(i) = 1 + end do +! +! assign total mass to topmost level +! + + do i=1,ncol + do m=1,naer + AEROSOL(i,1,m) = AEROSOLc(i,1,m) + enddo + enddo +! +! At every pressure level, interpolate onto that pressure level +! + do k=2,pver +! +! Top level we need to start looking is the top level for the previous k +! for all longitude points +! + kkstart = paerlev + do i=1,ncol + kkstart = min0(kkstart,kupper(i)) + end do + kount = 0 +! +! Store level indices for interpolation +! +! for the pressure interpolation should be comparing +! pint(column,lev) with M_hybi(lev)*M_ps_cam_col(month,column,chunk) +! + lev_interp_comp = .false. + do kk=kkstart,paerlev-1 + if(.not.lev_interp_comp) then + do i=1,ncol + v_coord = pint(i,k) + if (M_hybi(kk)*Match_ps(i) .lt. v_coord .and. v_coord .le. M_hybi(kk+1)*Match_ps(i)) then + kupper(i) = kk + kount = kount + 1 + end if + end do +! +! If all indices for this level have been found, do the interpolation and +! go to the next level +! +! Interpolate in pressure. +! + if (kount.eq.ncol) then + do i=1,ncol + do m=1,naer + dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i) + dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k) + AEROSOL(i,k,m) = & + (AEROSOLc(i,kupper(i) ,m)*dpl + & + AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu) + enddo + enddo !i + lev_interp_comp = .true. + end if + end if + end do +! +! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and + +! must extrapolate from the bottom or top pressure level for at least some +! of the longitude points. +! + + if(.not.lev_interp_comp) then + do i=1,ncol + do m=1,naer + if (pint(i,k) .lt. M_hybi(1)*Match_ps(i)) then + AEROSOL(i,k,m) = AEROSOLc(i,1,m) + else if (pint(i,k) .gt. M_hybi(paerlev)*Match_ps(i)) then + AEROSOL(i,k,m) = 0.0 + else + dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i) + dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k) + AEROSOL(i,k,m) = & + (AEROSOLc(i,kupper(i) ,m)*dpl + & + AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu) + end if + enddo + end do + + if (kount.gt.ncol) then +! call endrun ('VERT_INTERPOLATE: Bad data: non-monotonicity suspected in dependent variable') + end if + end if + end do + +! call t_startf ('vi_checks') +! +! aerosol mass beneath lowest interface (pverp) must be 0 +! + AEROSOL(1:ncol,pverp,:) = 0. +! +! Set mass in layer to zero whenever it is less than +! 1.e-40 kg/m^2 in the layer +! + do m = 1, naer + do k = 1, pver + do i = 1, ncol + if (AEROSOL(i,k,m) < 1.e-40_r8) AEROSOL(i,k,m) = 0. + end do + end do + end do +! +! Set mass in layer to zero whenever it is less than +! 10^-15 relative to column total mass +! convert back to mass mixing ratios. +! exit if mmr is negative +! + do m = 1, naer + do k = 1, pver + do i = 1, ncol + AER_diff = AEROSOL(i,k,m) - AEROSOL(i,k+1,m) + if( abs(AER_diff) < 1e-15*AEROSOL(i,1,m)) then + AER_diff = 0. + end if + m_to_mmr = gravmks / (pint(i,k+1)-pint(i,k)) + AEROSOL_mmr(i,k,m)= AER_diff * m_to_mmr + if (AEROSOL_mmr(i,k,m) < 0) then + write(6,*)'vert_interpolate: mmr < 0, m, col, lev, mmr',m, i, k, AEROSOL_mmr(i,k,m) + write(6,*)'vert_interpolate: aerosol(k),(k+1)',AEROSOL(i,k,m),AEROSOL(i,k+1,m) + write(6,*)'vert_interpolate: pint(k+1),(k)',pint(i,k+1),pint(i,k) + write(6,*)'n,c',n,c +! call endrun() + end if + end do + end do + end do + +! call t_stopf ('vi_checks') +! call t_stopf ('vert_interpolate') + + return +end subroutine vert_interpolate + +subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel) +!-------------------------------------------------------------- +! Compute effect of sulfate on effective liquid water radius +! Method of Martin et. al. +!-------------------------------------------------------------- + +! use constituents, only: ppcnst, cnst_get_ind +! use history, only: outfld + +!#include + + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols,pver,ppcnst + + real(r8), intent(in) :: landfrac(pcols) ! land fraction + real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures + real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures + real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers + real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover + real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface) + real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns) +! +! local variables +! + real(r8) locrhoair(pcols,pver) ! dry air density [kg/m^3 ] + real(r8) lwcwat(pcols,pver) ! in-cloud liquid water path [kg/m^3 ] + real(r8) sulfmix(pcols,pver) ! sulfate mass mixing ratio [kg/kg ] + real(r8) so4mass(pcols,pver) ! sulfate mass concentration [g/cm^3 ] + real(r8) Aso4(pcols,pver) ! sulfate # concentration [#/cm^3 ] + real(r8) Ntot(pcols,pver) ! ccn # concentration [#/cm^3 ] + real(r8) relmod(pcols,pver) ! effective radius [microns] + + real(r8) wrel(pcols,pver) ! weighted effective radius [microns] + real(r8) wlwc(pcols,pver) ! weighted liq. water content [kg/m^3 ] + real(r8) cldfrq(pcols,pver) ! frequency of occurance of... +! ! clouds (cld => 0.01) [fraction] + real(r8) locPi ! my piece of the pi + real(r8) Rdryair ! gas constant of dry air [J/deg/kg] + real(r8) rhowat ! density of water [kg/m^3 ] + real(r8) Acoef ! m->A conversion factor; assumes +! ! Dbar=0.10, sigma=2.0 [g^-1 ] + real(r8) rekappa ! kappa in evaluation of re(lmod) + real(r8) recoef ! temp. coeficient for calc of re(lmod) + real(r8) reexp ! 1.0/3.0 + real(r8) Ntotb ! temp var to hold below cloud ccn +! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)... + real(r8) Cmarn ! Coef for CDNC_marine [cm^-3] + real(r8) Cland ! Coef for CDNC_land [cm^-3] + real(r8) Hmarn ! Scale height for CDNC_marine [m] + real(r8) Hland ! Scale height for CDNC_land [m] + parameter ( Cmarn = 50.0, Cland = 100.0 ) + parameter ( Hmarn = 1000.0, Hland = 2000.0 ) + real(r8) bgaer ! temp var to hold background CDNC + + integer i,k ! loop indices +! +! Statement functions +! + logical land ! is this a column over land? + land(i) = nint(landfrac(i)).gt.0.5_r8 + + if (indirect) then + +! call endrun ('AEROSOL_INDIRECT: indirect effect is obsolete') + +! ramping is not yet resolved so sulfmix is 0. + sulfmix(1:ncol,1:pver) = 0._r8 + + locPi = 3.141592654 + Rdryair = 287.04 + rhowat = 1000.0 + Acoef = 1.2930E14 + recoef = 3.0/(4.0*locPi*rhowat) + reexp = 1.0/3.0 + +! call cnst_get_ind('CLDLIQ', ixcldliq) + do k=pver,1,-1 + do i = 1,ncol + locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) ) + lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* & + locrhoair(i,k) +! NOTE: 0.001 converts kg/m3 -> g/cm3 + so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001 + Aso4(i,k) = so4mass(i,k)*Acoef + + if (Aso4(i,k) <= 280.0) then + Aso4(i,k) = max(36.0_r8,Aso4(i,k)) + Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30 + rekappa = 0.80 + else + Aso4(i,k) = min(1500.0_r8,Aso4(i,k)) + Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9 + rekappa = 0.67 + end if + if (land(i)) then ! Account for local background aerosol; + bgaer = Cland*exp(-(zm(i,k)/Hland)) + Ntot(i,k) = max(bgaer,Ntot(i,k)) + else + bgaer = Cmarn*exp(-(zm(i,k)/Hmarn)) + Ntot(i,k) = max(bgaer,Ntot(i,k)) + end if + + if (k == pver) then + Ntotb = Ntot(i,k) + else + Ntotb = Ntot(i,k+1) + end if + + relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0 + relmod(i,k) = max(4.0_r8,relmod(i,k)) + relmod(i,k) = min(20.0_r8,relmod(i,k)) + if (cld(i,k) >= 0.01) then + cldfrq(i,k) = 1.0 + else + cldfrq(i,k) = 0.0 + end if + wrel(i,k) = relmod(i,k)*cldfrq(i,k) + wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k) + end do + end do +! call outfld('MSO4 ',so4mass,pcols,lchnk) +! call outfld('LWC ',lwcwat ,pcols,lchnk) +! call outfld('CLDFRQ ',cldfrq ,pcols,lchnk) +! call outfld('WREL ',wrel ,pcols,lchnk) +! call outfld('WLWC ',wlwc ,pcols,lchnk) +! write(6,*)'WARNING: indirect calculation has no effects' + else + do k = 1, pver + do i = 1, ncol + relmod(i,k) = rel(i,k) + end do + end do + endif + +! call outfld('REL ',relmod ,pcols,lchnk) + + return +end subroutine aerosol_indirect + + +subroutine background(lchnk, ncol, pint, pcols, pverr, pverrp, mmr) +!----------------------------------------------------------------------- +! +! Purpose: +! Set global mean tropospheric aerosol background (or tuning) field +! +! Method: +! Specify aerosol mixing ratio. +! Aerosol mass mixing ratio +! is specified so that the column visible aerosol optical depth is a +! specified global number (tauback). This means that the actual mixing +! ratio depends on pressure thickness of the lowest three atmospheric +! layers near the surface. +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use aer_optics, only: kbg,idxVIS +! use physconst, only: gravit +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +!#include +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols,pverr,pverrp + + real(r8), intent(in) :: pint(pcols,pverrp) ! Interface pressure (mks) +! +! Output arguments +! + real(r8), intent(out) :: mmr(pcols,pverr) ! "background" aerosol mass mixing ratio +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer k ! Level index +! + real(r8) mass2mmr ! Factor to convert mass to mass mixing ratio + real(r8) mass ! Mass of "background" aerosol as specified by tauback +! +!----------------------------------------------------------------------- +! + do i=1,ncol + mass2mmr = gravmks / (pint(i,pverrp)-pint(i,pverrp-mxaerl)) + do k=1,pverr +! +! Compute aerosol mass mixing ratio for specified levels (1.e3 factor is +! for units conversion of the extinction coefficiant from m2/g to m2/kg) +! + if ( k >= pverrp-mxaerl ) then +! kaervs is not consistent with the values in aer_optics +! this ?should? be changed. +! rhfac is also implemented differently + mass = tauback / (1.e3 * kbg(idxVIS)) + mmr(i,k) = mass2mmr*mass + else + mmr(i,k) = 0._r8 + endif +! + enddo + enddo +! + return +end subroutine background + +subroutine scale_aerosols(AEROSOLt, pcols, pver, ncol, lchnk, scale) +!----------------------------------------------------------------- +! scale each species as determined by scale factors +!----------------------------------------------------------------- + integer, intent(in) :: ncol, lchnk ! number of columns and chunk index + integer, intent(in) :: pcols, pver + real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount + real(r8), intent(inout) :: AEROSOLt(pcols, pver, naer_all) ! aerosols + integer m + + do m = 1, naer_all + AEROSOLt(:ncol, :, m) = scale(m)*AEROSOLt(:ncol, :, m) + end do + + return +end subroutine scale_aerosols + +subroutine get_int_scales(scales) + real(r8), intent(out)::scales(naer_all) ! scale each aerosol by this amount + integer i ! index through species + +!initialize + scales = 1. + + scales(idxBG) = 1._r8 + scales(idxSUL) = sulscl + scales(idxSSLT) = ssltscl + + do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1 + scales(i) = carscl + enddo + + do i = idxDUSTfirst, idxDUSTfirst+numDUST-1 + scales(i) = dustscl + enddo + + scales(idxVOLC) = volcscl + + return +end subroutine get_int_scales + + subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp ) +! +! Purpose: Compute strat. aerosol transmissions needed in absorptivity/ +! emissivity calculations +! aer_trn() is called by radclw() when doabsems is .true. +! +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use pmgrid +! use ppgrid +! use prescribed_aerosols, only: strat_volcanic + implicit none + +! Input arguments +! +! [kg m-2] Volcanics path above kth interface level +! + integer, intent(in) :: pcols, plev, plevp + real(r8), intent(in) :: aer_mpp(pcols,plevp) + +! Output arguments +! +! [fraction] Total volcanic transmission between interfaces k1 and k2 +! + real(r8), intent(out) :: aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW) + +!------------------------------------------------------------------------- +! Local variables + + integer bnd_idx ! LW band index + integer i ! lon index + integer k1 ! lev index + integer k2 ! lev index + real(r8) aer_pth_dlt ! [kg m-2] Volcanics path between interface + ! levels k1 and k2 + real(r8) odap_aer_ttl ! [fraction] Total path absorption optical + ! depth + +!------------------------------------------------------------------------- + + if (strat_volcanic) then + do bnd_idx=1,bnd_nbr_LW + do i=1,pcols + aer_trn_ttl(i,1,1,bnd_idx)=1.0 + end do + do k1=2,plevp + do i=1,pcols + aer_trn_ttl(i,k1,k1,bnd_idx)=1.0 + + aer_pth_dlt = abs(aer_mpp(i,k1) - aer_mpp(i,1)) + odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt + + aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl) + end do + end do + + do k1=2,plev + do k2=k1+1,plevp + do i=1,pcols + aer_trn_ttl(i,k1,k2,bnd_idx) = & + aer_trn_ttl(i,1,k2,bnd_idx) / & + aer_trn_ttl(i,1,k1,bnd_idx) + end do + end do + end do + + do k1=2,plevp + do k2=1,k1-1 + do i=1,pcols + aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx) + end do + end do + end do + end do + else + aer_trn_ttl = 1.0 + endif + + return + end subroutine aer_trn + + subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp) +!------------------------------------------------------ +! Purpose: convert mass per layer to cumulative mass from Top +!------------------------------------------------------ +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use pmgrid + implicit none +!#include + +! Parameters +! Input + integer, intent(in) :: pcols, plev, plevp + real(r8), intent(in):: aer_mass(pcols,plev) ! Rad level aerosol mass mixing ratio + integer, intent(in):: ncol +! +! Output + real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface +! +! Local + integer i ! Column index + integer k ! Level index +!------------------------------------------------------ +!------------------------------------------------------ + + aer_mpp(1:ncol,1) = 0._r8 + do k=2,plevp + aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1) + enddo +! + return + end subroutine aer_pth + +subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, & + lwups ,emis , & + pmid ,pint ,pmln ,piln ,pdel ,t , & +! qm1 ,cld ,cicewp ,cliqwp ,coszrs, clat, & + qm1 ,cld ,cicewp ,cliqwp ,tauxcl, tauxci, coszrs, clat, & + asdir ,asdif ,aldir ,aldif ,solcon, GMT,JULDAY,JULIAN,DT,XTIME, & + pin, ozmixmj, ozmix, levsiz, num_months, & + m_psp, m_psn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn , & + nmxrgn , & + doabsems, abstot, absnxt, emstot, & + fsup ,fsupc ,fsdn ,fsdnc , & + flup ,flupc ,fldn ,fldnc , & + swcf ,lwcf ,flut , & + fsns ,fsnt ,flns ,flnt , & + qrs ,qrl ,flwds ,rel ,rei , & + sols ,soll ,solsd ,solld , & + landfrac,zm ,fsds ) +!----------------------------------------------------------------------- +! +! Purpose: +! Driver for radiation computation. +! +! Method: +! Radiation uses cgs units, so conversions must be done from +! model fields to radiation fields. +! +! Author: CCM1, CMS Contact: J. Truesdale +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use pspect +! use commap +! use history, only: outfld +! use constituents, only: ppcnst, cnst_get_ind +! use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, & +! aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC +! use physics_types, only: physics_state +! use wv_saturation, only: aqsat +! use chemistry, only: trace_gas +! use physconst, only: cpair, epsilo +! use aer_optics, only: idxVIS +! use aerosol_intr, only: set_aerosol_from_prognostics + + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk,j ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: levsiz ! number of ozone data levels + integer, intent(in) :: num_months ! 12 months + integer, intent(in) :: paerlev,naer_c ! aerosol vertical level and # species + integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst + logical, intent(in) :: doabsems + + + integer nspint ! Num of spctrl intervals across solar spectrum + integer naer_groups ! Num of aerosol groups for optical diagnostics + parameter ( nspint = 19 ) + parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols + + + real(r8), intent(in) :: lwups(pcols) ! Longwave up flux at surface + real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity + real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures + real(r8), intent(in) :: pmln(pcols,pver) ! Natural log of pmid + real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns) + real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns) + real(r8), intent(in) :: piln(pcols,pverp) ! Natural log of pint + real(r8), intent(in) :: pdel(pcols,pverp) ! Pressure difference across layer + real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures + real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers + real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover + real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path + real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path + real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth + real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth + real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle + real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns + real(r8), intent(in) :: asdir(pcols) ! albedo shortwave direct + real(r8), intent(in) :: asdif(pcols) ! albedo shortwave diffuse + real(r8), intent(in) :: aldir(pcols) ! albedo longwave direct + real(r8), intent(in) :: aldif(pcols) ! albedo longwave diffuse + real(r8), intent(in) :: landfrac(pcols) ! land fraction + real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface) + real(r8), intent(in) :: pin(levsiz) ! Pressure levels of ozone data + real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months) ! monthly ozone mixing ratio + real(r8), intent(inout) :: ozmix(pcols,levsiz) ! Ozone data + real, intent(in) :: solcon ! solar constant with eccentricity factor + REAL, INTENT(IN ) :: XTIME,GMT + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: JULIAN + REAL, INTENT(IN ) :: DT + real(r8), intent(in) :: m_psp(pcols),m_psn(pcols) ! MATCH surface pressure + real(r8), intent(in) :: aerosoljp(pcols,paerlev,naer_c) ! aerosol concentrations + real(r8), intent(in) :: aerosoljn(pcols,paerlev,naer_c) ! aerosol concentrations + real(r8), intent(in) :: m_hybi(paerlev) +! type(physics_state), intent(in) :: state + real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each +! maximally overlapped region. +! 0->pmxrgn(i,1) is range of pmid for +! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for +! 2nd region, etc + integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions + + real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn + integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn + +! +! Output solar arguments +! + real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux + real(r8), intent(out) :: fsnt(pcols) ! Net column abs solar flux at model top + real(r8), intent(out) :: flns(pcols) ! Srf longwave cooling (up-down) flux + real(r8), intent(out) :: flnt(pcols) ! Net outgoing lw flux at model top + real(r8), intent(out) :: sols(pcols) ! Downward solar rad onto surface (sw direct) + real(r8), intent(out) :: soll(pcols) ! Downward solar rad onto surface (lw direct) + real(r8), intent(out) :: solsd(pcols) ! Downward solar rad onto surface (sw diffuse) + real(r8), intent(out) :: solld(pcols) ! Downward solar rad onto surface (lw diffuse) + real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate + real(r8), intent(out) :: fsds(pcols) ! Flux Shortwave Downwelling Surface +! Added outputs of total and clearsky fluxes etc + real(r8), intent(out) :: fsup(pcols,pverp) ! Upward total sky solar + real(r8), intent(out) :: fsupc(pcols,pverp) ! Upward clear sky solar + real(r8), intent(out) :: fsdn(pcols,pverp) ! Downward total sky solar + real(r8), intent(out) :: fsdnc(pcols,pverp) ! Downward clear sky solar + real(r8), intent(out) :: flup(pcols,pverp) ! Upward total sky longwave + real(r8), intent(out) :: flupc(pcols,pverp) ! Upward clear sky longwave + real(r8), intent(out) :: fldn(pcols,pverp) ! Downward total sky longwave + real(r8), intent(out) :: fldnc(pcols,pverp) ! Downward clear sky longwave + real(r8), intent(out) :: swcf(pcols) ! Top of the atmosphere solar cloud forcing + real(r8), intent(out) :: lwcf(pcols) ! Top of the atmosphere longwave cloud forcing + real(r8), intent(out) :: flut(pcols) ! Top of the atmosphere outgoing longwave +! +! Output longwave arguments +! + real(r8), intent(out) :: qrl(pcols,pver) ! Longwave cooling rate + real(r8), intent(out) :: flwds(pcols) ! Surface down longwave flux + + real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity + real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity + real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity + + +! +!---------------------------Local variables----------------------------- +! + integer i, k ! index + + integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array + + real(r8) solin(pcols) ! Solar incident flux +! real(r8) fsds(pcols) ! Flux Shortwave Downwelling Surface + real(r8) fsntoa(pcols) ! Net solar flux at TOA + real(r8) fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + real(r8) fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) fsdsc(pcols) ! Clear sky surface downwelling solar flux +! real(r8) flut(pcols) ! Upward flux at top of model +! real(r8) lwcf(pcols) ! longwave cloud forcing +! real(r8) swcf(pcols) ! shortwave cloud forcing + real(r8) flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) flntc(pcols) ! Clear sky lw flux at model top + real(r8) flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) ftem(pcols,pver) ! temporary array for outfld + + real(r8) pbr(pcols,pverr) ! Model mid-level pressures (dynes/cm2) + real(r8) pnm(pcols,pverrp) ! Model interface pressures (dynes/cm2) + real(r8) o3vmr(pcols,pverr) ! Ozone volume mixing ratio + real(r8) o3mmr(pcols,pverr) ! Ozone mass mixing ratio + real(r8) eccf ! Earth/sun distance factor + real(r8) n2o(pcols,pver) ! nitrous oxide mass mixing ratio + real(r8) ch4(pcols,pver) ! methane mass mixing ratio + real(r8) cfc11(pcols,pver) ! cfc11 mass mixing ratio + real(r8) cfc12(pcols,pver) ! cfc12 mass mixing ratio + real(r8) rh(pcols,pverr) ! level relative humidity (fraction) + real(r8) lwupcgs(pcols) ! Upward longwave flux in cgs units + + real(r8) esat(pcols,pverr) ! saturation vapor pressure + real(r8) qsat(pcols,pverr) ! saturation specific humidity + + real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums + real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth + real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo + real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter + real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering + + real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios + real(r8) scales(naer_all) ! scaling factors for aerosols + + +! +! Interpolate ozone volume mixing ratio to model levels +! +! WRF: added pin, levsiz, ozmix here + call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols) + + call radozn(lchnk ,ncol & + ,pcols, pver & + ,pmid ,pin, levsiz, ozmix, o3vmr ) + +! call outfld('O3VMR ',o3vmr ,pcols, lchnk) + +! +! Set chunk dependent radiation input +! + call radinp(lchnk ,ncol ,pcols, pver, pverp, & + pmid ,pint ,o3vmr , pbr ,& + pnm ,eccf ,o3mmr ) + +! +! Solar radiation computation +! + if (dosw) then + +! +! calculate heating with aerosols +! + call aqsat(t, pmid, esat, qsat, pcols, & + ncol, pver, 1, pver) + + ! calculate relative humidity +! rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * & +! ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / & +! ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo) + rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * & + ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / & + ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo) + + if (radforce) then + + pmxrgnrf = pmxrgn + nmxrgnrf = nmxrgn + + call get_rf_scales(scales) + + call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, & + aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales) + + ! overwrite with prognostics aerosols + +! no feedback from prognostic aerosols +! call set_aerosol_from_prognostics (ncol, q, aerosol) + + call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel) + +! call t_startf('radcswmx_rf') + call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, & + pnm ,pbr ,qm1 ,rh ,o3mmr , & + aerosol ,cld ,cicewp ,cliqwp ,rel , & +! rei ,eccf ,coszrs ,scon ,solin ,solcon , & + rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , & + asdir ,asdif ,aldir ,aldif ,nmxrgnrf, & + pmxrgnrf,qrs ,fsnt ,fsntc ,fsntoa , & + fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , & + fsnsc ,fsdsc ,fsds ,sols ,soll , & + solsd ,solld ,frc_day , & + fsup ,fsupc ,fsdn ,fsdnc , & + aertau ,aerssa ,aerasm ,aerfwd ) +! call t_stopf('radcswmx_rf') + +! +! Convert units of shortwave fields needed by rest of model from CGS to MKS +! + + do i = 1, ncol + solin(i) = solin(i)*1.e-3 + fsnt(i) = fsnt(i) *1.e-3 + fsns(i) = fsns(i) *1.e-3 + fsntc(i) = fsntc(i)*1.e-3 + fsnsc(i) = fsnsc(i)*1.e-3 + end do + ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair +! +! Dump shortwave radiation information to history tape buffer (diagnostics) +! +! call outfld('QRS_RF ',ftem ,pcols,lchnk) +! call outfld('FSNT_RF ',fsnt ,pcols,lchnk) +! call outfld('FSNS_RF ',fsns ,pcols,lchnk) +! call outfld('FSNTC_RF',fsntc ,pcols,lchnk) +! call outfld('FSNSC_RF',fsnsc ,pcols,lchnk) + + endif ! if (radforce) + + call get_int_scales(scales) + + call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, & + m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales) + + ! overwrite with prognostics aerosols +! call set_aerosol_from_prognostics (ncol, q, aerosol) + + call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel) +! call t_startf('radcswmx') + + call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, & + pnm ,pbr ,qm1 ,rh ,o3mmr , & + aerosol ,cld ,cicewp ,cliqwp ,rel , & +! rei ,eccf ,coszrs ,scon ,solin ,solcon , & + rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , & + asdir ,asdif ,aldir ,aldif ,nmxrgn , & + pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , & + fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , & + fsnsc ,fsdsc ,fsds ,sols ,soll , & + solsd ,solld ,frc_day , & + fsup ,fsupc ,fsdn ,fsdnc , & + aertau ,aerssa ,aerasm ,aerfwd ) +! call t_stopf('radcswmx') + +! -- tls ---------------------------------------------------------------2 +! +! Convert units of shortwave fields needed by rest of model from CGS to MKS +! + do i=1,ncol + solin(i) = solin(i)*1.e-3 + fsds(i) = fsds(i)*1.e-3 + fsnirt(i)= fsnirt(i)*1.e-3 + fsnrtc(i)= fsnrtc(i)*1.e-3 + fsnirtsq(i)= fsnirtsq(i)*1.e-3 + fsnt(i) = fsnt(i) *1.e-3 + fsns(i) = fsns(i) *1.e-3 + fsntc(i) = fsntc(i)*1.e-3 + fsnsc(i) = fsnsc(i)*1.e-3 + fsdsc(i) = fsdsc(i)*1.e-3 + fsntoa(i)=fsntoa(i)*1.e-3 + fsntoac(i)=fsntoac(i)*1.e-3 + end do + ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair + +! Added upward/downward total and clear sky fluxes + do k = 1, pverp + do i = 1, ncol + fsup(i,k) = fsup(i,k)*1.e-3 + fsupc(i,k) = fsupc(i,k)*1.e-3 + fsdn(i,k) = fsdn(i,k)*1.e-3 + fsdnc(i,k) = fsdnc(i,k)*1.e-3 + end do + end do + +! +! Dump shortwave radiation information to history tape buffer (diagnostics) +! + +! call outfld('frc_day ', frc_day, pcols, lchnk) +! call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk) +! call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk) +! call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk) +! call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk) +! call outfld('BGOD_v ', aertau(:,idxVIS,5) ,pcols,lchnk) +! call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk) +! call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk) +! call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk) +! call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk) +! call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk) +! call aerosol_diagnostics (lchnk, ncol, pdel, aerosol) + +! call outfld('QRS ',ftem ,pcols,lchnk) +! call outfld('SOLIN ',solin ,pcols,lchnk) +! call outfld('FSDS ',fsds ,pcols,lchnk) +! call outfld('FSNIRTOA',fsnirt,pcols,lchnk) +! call outfld('FSNRTOAC',fsnrtc,pcols,lchnk) +! call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk) +! call outfld('FSNT ',fsnt ,pcols,lchnk) +! call outfld('FSNS ',fsns ,pcols,lchnk) +! call outfld('FSNTC ',fsntc ,pcols,lchnk) +! call outfld('FSNSC ',fsnsc ,pcols,lchnk) +! call outfld('FSDSC ',fsdsc ,pcols,lchnk) +! call outfld('FSNTOA ',fsntoa,pcols,lchnk) +! call outfld('FSNTOAC ',fsntoac,pcols,lchnk) +! call outfld('SOLS ',sols ,pcols,lchnk) +! call outfld('SOLL ',soll ,pcols,lchnk) +! call outfld('SOLSD ',solsd ,pcols,lchnk) +! call outfld('SOLLD ',solld ,pcols,lchnk) + + end if +! +! Longwave radiation computation +! + if (dolw) then +! +! Convert upward longwave flux units to CGS +! + do i=1,ncol +! lwupcgs(i) = lwup(i)*1000. + lwupcgs(i) = lwups(i) + end do +! +! Do longwave computation. If not implementing greenhouse gas code then +! first specify trace gas mixing ratios. If greenhouse gas code then: +! o ixtrcg => indx of advected n2o tracer +! o ixtrcg+1 => indx of advected ch4 tracer +! o ixtrcg+2 => indx of advected cfc11 tracer +! o ixtrcg+3 => indx of advected cfc12 tracer +! + if (trace_gas) then +! call cnst_get_ind('N2O' , in2o) +! call cnst_get_ind('CH4' , ich4) +! call cnst_get_ind('CFC11', if11) +! call cnst_get_ind('CFC12', if12) +! call t_startf("radclwmx") + call radclwmx(lchnk ,ncol ,pcols, pver, pverp , & + lwupcgs ,t ,qm1(1,1,1) ,o3vmr , & + pbr ,pnm ,pmln ,piln , & + qm1(1,1,in2o) ,qm1(1,1,ich4) , & + qm1(1,1,if11) ,qm1(1,1,if12) , & + cld ,emis ,pmxrgn ,nmxrgn ,qrl , & + doabsems, abstot, absnxt, emstot, & + flns ,flnt ,flnsc ,flntc ,flwds , & + flut ,flutc , & + flup ,flupc ,fldn ,fldnc , & + aerosol(:,:,idxVOLC)) +! call t_stopf("radclwmx") + else + call trcmix(lchnk ,ncol ,pcols, pver, & + pmid ,clat, n2o ,ch4 , & + cfc11 ,cfc12 ) + +! call t_startf("radclwmx") + call radclwmx(lchnk ,ncol ,pcols, pver, pverp , & + lwupcgs ,t ,qm1(1,1,1) ,o3vmr , & + pbr ,pnm ,pmln ,piln , & + n2o ,ch4 ,cfc11 ,cfc12 , & + cld ,emis ,pmxrgn ,nmxrgn ,qrl , & + doabsems, abstot, absnxt, emstot, & + flns ,flnt ,flnsc ,flntc ,flwds , & + flut ,flutc , & + flup ,flupc ,fldn ,fldnc , & + aerosol(:,:,idxVOLC)) +! call t_stopf("radclwmx") + endif +! +! Convert units of longwave fields needed by rest of model from CGS to MKS +! + do i=1,ncol + flnt(i) = flnt(i)*1.e-3 + flut(i) = flut(i)*1.e-3 + flutc(i) = flutc(i)*1.e-3 + flns(i) = flns(i)*1.e-3 + flntc(i) = flntc(i)*1.e-3 + flnsc(i) = flnsc(i)*1.e-3 + flwds(i) = flwds(i)*1.e-3 + lwcf(i) = flutc(i) - flut(i) + swcf(i) = fsntoa(i) - fsntoac(i) + end do + +! Added upward/downward total and clear sky fluxes + do k = 1, pverp + do i = 1, ncol + flup(i,k) = flup(i,k)*1.e-3 + flupc(i,k) = flupc(i,k)*1.e-3 + fldn(i,k) = fldn(i,k)*1.e-3 + fldnc(i,k) = fldnc(i,k)*1.e-3 + end do + end do +! +! Dump longwave radiation information to history tape buffer (diagnostics) +! +! call outfld('QRL ',qrl(:ncol,:)/cpair,ncol,lchnk) +! call outfld('FLNT ',flnt ,pcols,lchnk) +! call outfld('FLUT ',flut ,pcols,lchnk) +! call outfld('FLUTC ',flutc ,pcols,lchnk) +! call outfld('FLNTC ',flntc ,pcols,lchnk) +! call outfld('FLNS ',flns ,pcols,lchnk) +! call outfld('FLNSC ',flnsc ,pcols,lchnk) +! call outfld('LWCF ',lwcf ,pcols,lchnk) +! call outfld('SWCF ',swcf ,pcols,lchnk) +! + end if +! + return +end subroutine radctl + subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, & + q, cldn, landfrac, landm,icefrac, & + pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh ) +! +! Compute (liquid+ice) water path and cloud water/ice diagnostics +! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios +! +! **** mixes interface and physics code temporarily +!----------------------------------------------------------------------- +! use physics_types, only: physics_state +! use history, only: outfld +! use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw + + implicit none + +! Arguments + integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst + real(r8), intent(in) :: q(pcols,pver,ppcnst) ! moisture arrays + real(r8), intent(in) :: cldn(pcols,pver) ! new cloud fraction + real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness + real(r8), intent(in) :: t(pcols,pver) ! temperature + real(r8), intent(in) :: pmid(pcols,pver) ! pressure + real(r8), intent(in) :: pint(pcols,pverp) ! pressure + real(r8), intent(in) :: ps(pcols) ! surface pressure + real(r8), intent(in) :: landfrac(pcols) ! Land fraction + real(r8), intent(in) :: icefrac(pcols) ! Ice fraction + real(r8), intent(in) :: landm(pcols) ! Land fraction ramped + real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) + +!!$ real(r8), intent(out) :: cwp (pcols,pver) ! in-cloud cloud (total) water path + real(r8), intent(out) :: cicewp(pcols,pver) ! in-cloud cloud ice water path + real(r8), intent(out) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path + real(r8), intent(out) :: emis (pcols,pver) ! cloud emissivity + real(r8), intent(out) :: rel (pcols,pver) ! effective drop radius (microns) + real(r8), intent(out) :: rei (pcols,pver) ! ice effective drop size (microns) + real(r8), intent(out) :: pmxrgn(pcols,pver+1) ! Maximum values of pressure for each + integer , intent(out) :: nmxrgn(pcols) ! Number of maximally overlapped regions + +! Local variables + real(r8) :: cwp (pcols,pver) ! in-cloud cloud (total) water path +!!$ real(r8) :: cicewp(pcols,pver) ! in-cloud cloud ice water path +!!$ real(r8) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path + real(r8) :: effcld(pcols,pver) ! effective cloud=cld*emis + real(r8) :: gicewp(pcols,pver) ! grid-box cloud ice water path + real(r8) :: gliqwp(pcols,pver) ! grid-box cloud liquid water path + real(r8) :: gwp (pcols,pver) ! grid-box cloud (total) water path + real(r8) :: hl (pcols) ! Liquid water scale height + real(r8) :: tgicewp(pcols) ! Vertically integrated ice water path + real(r8) :: tgliqwp(pcols) ! Vertically integrated liquid water path + real(r8) :: tgwp (pcols) ! Vertically integrated (total) cloud water path + real(r8) :: tpw (pcols) ! total precipitable water + real(r8) :: clwpold(pcols,pver) ! Presribed cloud liq. h2o path + real(r8) :: ficemr (pcols,pver) ! Ice fraction from ice and liquid mixing ratios + + real(r8) :: rgrav ! inverse gravitational acceleration + + integer :: i,k ! loop indexes + integer :: lchnk + +!----------------------------------------------------------------------- + +! Compute liquid and ice water paths + tgicewp(:ncol) = 0. + tgliqwp(:ncol) = 0. + do k=1,pver + do i = 1,ncol + gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0 ! Grid box ice water path. + gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0 ! Grid box liquid water path. +!!$ gwp (i,k) = gicewp(i,k) + gliqwp(i,k) + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. +!!$ cwp (i,k) = gwp (i,k) / max(0.01_r8,cldn(i,k)) + ficemr(i,k) = q(i,k,ixcldice) / & + max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq))) + + tgicewp(i) = tgicewp(i) + gicewp(i,k) + tgliqwp(i) = tgliqwp(i) + gliqwp(i,k) + end do + end do + tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol) + gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver) + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + +! Compute total preciptable water in column (in mm) + tpw(:ncol) = 0.0 + rgrav = 1.0/gravmks + do k=1,pver + do i=1,ncol + tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav + end do + end do + +! Diagnostic liquid water path (old specified form) +! call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl) + +! Cloud water and ice particle sizes + call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh) + +! Cloud emissivity. + call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis) + +! Effective cloud cover + do k=1,pver + do i=1,ncol + effcld(i,k) = cldn(i,k)*emis(i,k) + end do + end do + +! Determine parameters for maximum/random overlap + call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn) + +! call outfld('GCLDLWP' ,gwp , pcols,lchnk) +! call outfld('TGCLDCWP',tgwp , pcols,lchnk) +! call outfld('TGCLDLWP',tgliqwp, pcols,lchnk) +! call outfld('TGCLDIWP',tgicewp, pcols,lchnk) +! call outfld('ICLDLWP' ,cwp , pcols,lchnk) +! call outfld('SETLWP' ,clwpold, pcols,lchnk) +! call outfld('EFFCLD' ,effcld , pcols,lchnk) +! call outfld('LWSH' ,hl , pcols,lchnk) + + end subroutine param_cldoptics_calc + +subroutine radabs(lchnk ,ncol ,pcols, pver, pverp, & + pbr ,pnm ,co2em ,co2eml ,tplnka , & + s2c ,tcg ,w ,h2otr ,plco2 , & + plh2o ,co2t ,tint ,tlayr ,plol , & + plos ,pmln ,piln ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , & + uco213 ,uco221 ,uco222 ,uco223 ,uptype , & + bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , & + abstot ,absnxt ,plh2ob ,wb , & + aer_mpp ,aer_trn_ttl) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12 +! +! Method: +! h2o .... Uses nonisothermal emissivity method for water vapor from +! Ramanathan, V. and P.Downey, 1986: A Nonisothermal +! Emissivity and Absorptivity Formulation for Water Vapor +! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666 +! +! Implementation updated by Collins, Hackney, and Edwards (2001) +! using line-by-line calculations based upon Hitran 1996 and +! CKD 2.1 for absorptivity and emissivity +! +! Implementation updated by Collins, Lee-Taylor, and Edwards (2003) +! using line-by-line calculations based upon Hitran 2000 and +! CKD 2.4 for absorptivity and emissivity +! +! co2 .... Uses absorptance parameterization of the 15 micro-meter +! (500 - 800 cm-1) band system of Carbon Dioxide, from +! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization +! of the Absorptance Due to the 15 micro-meter Band System +! of Carbon Dioxide Jouranl of Geophysical Research, +! vol. 96., D5, pp 9013-9019. +! Parameterizations for the 9.4 and 10.4 mircon bands of CO2 +! are also included. +! +! o3 .... Uses absorptance parameterization of the 9.6 micro-meter +! band system of ozone, from Ramanathan, V. and R.Dickinson, +! 1979: The Role of stratospheric ozone in the zonal and +! seasonal radiative energy balance of the earth-troposphere +! system. Journal of the Atmospheric Sciences, Vol. 36, +! pp 1084-1104 +! +! ch4 .... Uses a broad band model for the 7.7 micron band of methane. +! +! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron +! bands of nitrous oxide +! +! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5 +! micron bands of CFC11 +! +! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2 +! micron bands of CFC12 +! +! +! Computes individual absorptivities for non-adjacent layers, accounting +! for band overlap, and sums to obtain the total; then, computes the +! nearest layer contribution. +! +! Author: W. Collins (H2O absorptivity) and J. Kiehl +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: pbr(pcols,pver) ! Prssr at mid-levels (dynes/cm2) + real(r8), intent(in) :: pnm(pcols,pverp) ! Prssr at interfaces (dynes/cm2) + real(r8), intent(in) :: co2em(pcols,pverp) ! Co2 emissivity function + real(r8), intent(in) :: co2eml(pcols,pver) ! Co2 emissivity function + real(r8), intent(in) :: tplnka(pcols,pverp) ! Planck fnctn level temperature + real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length + real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.) + real(r8), intent(in) :: w(pcols,pverp) ! H2o prs wghted path + real(r8), intent(in) :: h2otr(pcols,pverp) ! H2o trnsmssn fnct for o3 overlap + real(r8), intent(in) :: plco2(pcols,pverp) ! Co2 prs wghted path length + real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wfhted path length + real(r8), intent(in) :: co2t(pcols,pverp) ! Tmp and prs wghted path length + real(r8), intent(in) :: tint(pcols,pverp) ! Interface temperatures + real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 level temperatures + real(r8), intent(in) :: plol(pcols,pverp) ! Ozone prs wghted path length + real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path length + real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1) + real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1) + real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + + real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level + real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn. + + +! +! Trace gas variables +! + real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length + real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length + real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length + real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4 + real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! non-nearest layer Planck factor + real(r8), intent(in) :: abplnk2(14,pcols,pverp) ! nearest layer factor +! +! Output arguments +! + real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity + real(r8), intent(out) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer k ! Level index + integer k1 ! Level index + integer k2 ! Level index + integer kn ! Nearest level index + integer wvl ! Wavelength index + + real(r8) abstrc(pcols) ! total trace gas absorptivity + real(r8) bplnk(14,pcols,4) ! Planck functions for sub-divided layers + real(r8) pnew(pcols) ! Effective pressure for H2O vapor linewidth + real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/ + ! Hulst-Curtis-Godson correction for + ! each band + real(r8) u(pcols) ! Pressure weighted H2O path length + real(r8) ub(nbands) ! Pressure weighted H2O path length with + ! Hulst-Curtis-Godson correction for + ! each band + real(r8) tbar(pcols,4) ! Mean layer temperature + real(r8) emm(pcols,4) ! Mean co2 emissivity + real(r8) o3emm(pcols,4) ! Mean o3 emissivity + real(r8) o3bndi ! Ozone band parameter + real(r8) temh2o(pcols,4) ! Mean layer temperature equivalent to tbar + real(r8) k21 ! Exponential coefficient used to calculate +! ! rotation band transmissvty in the 650-800 +! ! cm-1 region (tr1) + real(r8) k22 ! Exponential coefficient used to calculate +! ! rotation band transmissvty in the 500-650 +! ! cm-1 region (tr2) + real(r8) uc1(pcols) ! H2o continuum pathlength in 500-800 cm-1 + real(r8) to3h2o(pcols) ! H2o trnsmsn for overlap with o3 + real(r8) pi ! For co2 absorptivity computation + real(r8) sqti(pcols) ! Used to store sqrt of mean temperature + real(r8) et ! Co2 hot band factor + real(r8) et2 ! Co2 hot band factor squared + real(r8) et4 ! Co2 hot band factor to fourth power + real(r8) omet ! Co2 stimulated emission term + real(r8) f1co2 ! Co2 central band factor + real(r8) f2co2(pcols) ! Co2 weak band factor + real(r8) f3co2(pcols) ! Co2 weak band factor + real(r8) t1co2(pcols) ! Overlap factr weak bands on strong band + real(r8) sqwp ! Sqrt of co2 pathlength + real(r8) f1sqwp(pcols) ! Main co2 band factor + real(r8) oneme ! Co2 stimulated emission term + real(r8) alphat ! Part of the co2 stimulated emission term + real(r8) wco2 ! Constants used to define co2 pathlength + real(r8) posqt ! Effective pressure for co2 line width + real(r8) u7(pcols) ! Co2 hot band path length + real(r8) u8 ! Co2 hot band path length + real(r8) u9 ! Co2 hot band path length + real(r8) u13 ! Co2 hot band path length + real(r8) rbeta7(pcols) ! Inverse of co2 hot band line width par + real(r8) rbeta8 ! Inverse of co2 hot band line width par + real(r8) rbeta9 ! Inverse of co2 hot band line width par + real(r8) rbeta13 ! Inverse of co2 hot band line width par + real(r8) tpatha ! For absorptivity computation + real(r8) abso(pcols,4) ! Absorptivity for various gases/bands + real(r8) dtx(pcols) ! Planck temperature minus 250 K + real(r8) dty(pcols) ! Path temperature minus 250 K + real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D + real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8) + real(r8) tr1 ! Eqn(6) in table A2 of R&D for 650-800 + real(r8) tr10(pcols) ! Eqn (6) times eq(4) in table A2 +! ! of R&D for 500-650 cm-1 region + real(r8) tr2 ! Eqn(6) in table A2 of R&D for 500-650 + real(r8) tr5 ! Eqn(4) in table A2 of R&D for 650-800 + real(r8) tr6 ! Eqn(4) in table A2 of R&D for 500-650 + real(r8) tr9(pcols) ! Equation (6) times eq(4) in table A2 +! ! of R&D for 650-800 cm-1 region + real(r8) sqrtu(pcols) ! Sqrt of pressure weighted h20 pathlength + real(r8) fwk(pcols) ! Equation(33) in R&D far wing correction + real(r8) fwku(pcols) ! GU term in eqs(1) and (6) in table A2 + real(r8) to3co2(pcols) ! P weighted temp in ozone band model + real(r8) dpnm(pcols) ! Pressure difference between two levels + real(r8) pnmsq(pcols,pverp) ! Pressure squared + real(r8) dw(pcols) ! Amount of h2o between two levels + real(r8) uinpl(pcols,4) ! Nearest layer subdivision factor + real(r8) winpl(pcols,4) ! Nearest layer subdivision factor + real(r8) zinpl(pcols,4) ! Nearest layer subdivision factor + real(r8) pinpl(pcols,4) ! Nearest layer subdivision factor + real(r8) dplh2o(pcols) ! Difference in press weighted h2o amount + real(r8) r293 ! 1/293 + real(r8) r250 ! 1/250 + real(r8) r3205 ! Line width factor for o3 (see R&Di) + real(r8) r300 ! 1/300 + real(r8) rsslp ! Reciprocal of sea level pressure + real(r8) r2sslp ! 1/2 of rsslp + real(r8) ds2c ! Y in eq(7) in table A2 of R&D + real(r8) dplos ! Ozone pathlength eq(A2) in R&Di + real(r8) dplol ! Presure weighted ozone pathlength + real(r8) tlocal ! Local interface temperature + real(r8) beta ! Ozone mean line parameter eq(A3) in R&Di +! (includes Voigt line correction factor) + real(r8) rphat ! Effective pressure for ozone beta + real(r8) tcrfac ! Ozone temperature factor table 1 R&Di + real(r8) tmp1 ! Ozone band factor see eq(A1) in R&Di + real(r8) u1 ! Effective ozone pathlength eq(A2) in R&Di + real(r8) realnu ! 1/beta factor in ozone band model eq(A1) + real(r8) tmp2 ! Ozone band factor see eq(A1) in R&Di + real(r8) u2 ! Effective ozone pathlength eq(A2) in R&Di + real(r8) rsqti ! Reciprocal of sqrt of path temperature + real(r8) tpath ! Path temperature used in co2 band model + real(r8) tmp3 ! Weak band factor see K&B + real(r8) rdpnmsq ! Reciprocal of difference in press^2 + real(r8) rdpnm ! Reciprocal of difference in press + real(r8) p1 ! Mean pressure factor + real(r8) p2 ! Mean pressure factor + real(r8) dtym10 ! T - 260 used in eq(9) and (10) table A3a + real(r8) dplco2 ! Co2 path length + real(r8) te ! A_0 T factor in ozone model table 1 of R&Di + real(r8) denom ! Denominator in eq(r8) of table A3a of R&D + real(r8) th2o(pcols) ! transmission due to H2O + real(r8) tco2(pcols) ! transmission due to CO2 + real(r8) to3(pcols) ! transmission due to O3 +! +! Transmission terms for various spectral intervals: +! + real(r8) trab2(pcols) ! H2o 500 - 800 cm-1 + real(r8) absbnd ! Proportional to co2 band absorptance + real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3 + real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3 +! +! Variables for Collins/Hackney/Edwards (C/H/E) & +! Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization + +! +! Notation: +! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986 +! P = atmospheric pressure +! P_0 = reference atmospheric pressure +! W = precipitable water path +! T_e = emission temperature +! T_p = path temperature +! RH = path relative humidity +! + real(r8) fa ! asymptotic value of abs. as U->infinity + real(r8) a_star ! normalized absorptivity for non-window + real(r8) l_star ! interpolated line transmission + real(r8) c_star ! interpolated continuum transmission + + real(r8) te1 ! emission temperature + real(r8) te2 ! te^2 + real(r8) te3 ! te^3 + real(r8) te4 ! te^4 + real(r8) te5 ! te^5 + + real(r8) log_u ! log base 10 of U + real(r8) log_uc ! log base 10 of H2O continuum path + real(r8) log_p ! log base 10 of P + real(r8) t_p ! T_p + real(r8) t_e ! T_e (offset by T_p) + + integer iu ! index for log10(U) + integer iu1 ! iu + 1 + integer iuc ! index for log10(H2O continuum path) + integer iuc1 ! iuc + 1 + integer ip ! index for log10(P) + integer ip1 ! ip + 1 + integer itp ! index for T_p + integer itp1 ! itp + 1 + integer ite ! index for T_e + integer ite1 ! ite + 1 + integer irh ! index for RH + integer irh1 ! irh + 1 + + real(r8) dvar ! normalized variation in T_p/T_e/P/U + real(r8) uvar ! U * diffusivity factor + real(r8) uscl ! factor for lineary scaling as U->0 + + real(r8) wu ! weight for U + real(r8) wu1 ! 1 - wu + real(r8) wuc ! weight for H2O continuum path + real(r8) wuc1 ! 1 - wuc + real(r8) wp ! weight for P + real(r8) wp1 ! 1 - wp + real(r8) wtp ! weight for T_p + real(r8) wtp1 ! 1 - wtp + real(r8) wte ! weight for T_e + real(r8) wte1 ! 1 - wte + real(r8) wrh ! weight for RH + real(r8) wrh1 ! 1 - wrh + + real(r8) w_0_0_ ! weight for Tp/Te combination + real(r8) w_0_1_ ! weight for Tp/Te combination + real(r8) w_1_0_ ! weight for Tp/Te combination + real(r8) w_1_1_ ! weight for Tp/Te combination + + real(r8) w_0_00 ! weight for Tp/Te/RH combination + real(r8) w_0_01 ! weight for Tp/Te/RH combination + real(r8) w_0_10 ! weight for Tp/Te/RH combination + real(r8) w_0_11 ! weight for Tp/Te/RH combination + real(r8) w_1_00 ! weight for Tp/Te/RH combination + real(r8) w_1_01 ! weight for Tp/Te/RH combination + real(r8) w_1_10 ! weight for Tp/Te/RH combination + real(r8) w_1_11 ! weight for Tp/Te/RH combination + + real(r8) w00_00 ! weight for P/Tp/Te/RH combination + real(r8) w00_01 ! weight for P/Tp/Te/RH combination + real(r8) w00_10 ! weight for P/Tp/Te/RH combination + real(r8) w00_11 ! weight for P/Tp/Te/RH combination + real(r8) w01_00 ! weight for P/Tp/Te/RH combination + real(r8) w01_01 ! weight for P/Tp/Te/RH combination + real(r8) w01_10 ! weight for P/Tp/Te/RH combination + real(r8) w01_11 ! weight for P/Tp/Te/RH combination + real(r8) w10_00 ! weight for P/Tp/Te/RH combination + real(r8) w10_01 ! weight for P/Tp/Te/RH combination + real(r8) w10_10 ! weight for P/Tp/Te/RH combination + real(r8) w10_11 ! weight for P/Tp/Te/RH combination + real(r8) w11_00 ! weight for P/Tp/Te/RH combination + real(r8) w11_01 ! weight for P/Tp/Te/RH combination + real(r8) w11_10 ! weight for P/Tp/Te/RH combination + real(r8) w11_11 ! weight for P/Tp/Te/RH combination + + integer ib ! spectral interval: + ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1 + ! 2 = 800-1200 cm^-1 + + + real(r8) pch2o ! H2O continuum path + real(r8) fch2o ! temp. factor for continuum + real(r8) uch2o ! U corresponding to H2O cont. path (window) + + real(r8) fdif ! secant(zenith angle) for diffusivity approx. + + real(r8) sslp_mks ! Sea-level pressure in MKS units + real(r8) esx ! saturation vapor pressure returned by vqsatd + real(r8) qsx ! saturation mixing ratio returned by vqsatd + real(r8) pnew_mks ! pnew in MKS units + real(r8) q_path ! effective specific humidity along path + real(r8) rh_path ! effective relative humidity along path + real(r8) omeps ! 1 - epsilo + + integer iest ! index in estblh2o + + integer bnd_idx ! LW band index + real(r8) aer_pth_dlt ! [kg m-2] STRAER path between interface levels k1 and k2 + real(r8) aer_pth_ngh(pcols) + ! [kg m-2] STRAER path between neighboring layers + real(r8) odap_aer_ttl ! [fraction] Total path absorption optical depth + real(r8) aer_trn_ngh(pcols,bnd_nbr_LW) + ! [fraction] Total transmission between + ! nearest neighbor sub-levels +! +!--------------------------Statement function--------------------------- +! + real(r8) dbvt,t ! Planck fnctn tmp derivative for o3 +! + dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ & + (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t) +! +! +!----------------------------------------------------------------------- +! +! Initialize +! + do k2=1,ntoplw-1 + do k1=1,ntoplw-1 + abstot(:,k1,k2) = inf ! set unused portions for lf95 restart write + end do + end do + do k2=1,4 + do k1=1,ntoplw-1 + absnxt(:,k1,k2) = inf ! set unused portions for lf95 restart write + end do + end do + + do k=ntoplw,pverp + abstot(:,k,k) = inf ! set unused portions for lf95 restart write + end do + + do k=ntoplw,pver + do i=1,ncol + dbvtly(i,k) = dbvt(tlayr(i,k+1)) + dbvtit(i,k) = dbvt(tint(i,k)) + end do + end do + do i=1,ncol + dbvtit(i,pverp) = dbvt(tint(i,pverp)) + end do +! + r293 = 1./293. + r250 = 1./250. + r3205 = 1./.3205 + r300 = 1./300. + rsslp = 1./sslp + r2sslp = 1./(2.*sslp) +! +!Constants for computing U corresponding to H2O cont. path +! + fdif = 1.66 + sslp_mks = sslp / 10.0 + omeps = 1.0 - epsilo +! +! Non-adjacent layer absorptivity: +! +! abso(i,1) 0 - 800 cm-1 h2o rotation band +! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! abso(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O absorptivity +! +! 500-800 cm^-1 H2o continuum/line overlap already included +! in abso(i,1). This used to be in abso(i,4) +! +! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands) +! abso(i,4) co2 15 micrometer band system +! + do k=ntoplw,pverp + do i=1,ncol + pnmsq(i,k) = pnm(i,k)**2 + dtx(i) = tplnka(i,k) - 250. + end do + end do +! +! Non-nearest layer level loops +! + do k1=pverp,ntoplw,-1 + do k2=pverp,ntoplw,-1 + if (k1 == k2) cycle + do i=1,ncol + dplh2o(i) = plh2o(i,k1) - plh2o(i,k2) + u(i) = abs(dplh2o(i)) + sqrtu(i) = sqrt(u(i)) + ds2c = abs(s2c(i,k1) - s2c(i,k2)) + dw(i) = abs(w(i,k1) - w(i,k2)) + uc1(i) = (ds2c + 1.7e-3*u(i))*(1. + 2.*ds2c)/(1. + 15.*ds2c) + pch2o = ds2c + pnew(i) = u(i)/dw(i) + pnew_mks = pnew(i) * sslp_mks +! +! Changed effective path temperature to std. Curtis-Godson form +! + tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i) + t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o) + iest = floor(t_p) - min_tp_h2o + esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * & + (t_p - min_tp_h2o - iest) + qsx = epsilo * esx / (pnew_mks - omeps * esx) +! +! Compute effective RH along path +! + q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga +! +! Calculate effective u, pnew for each band using +! Hulst-Curtis-Godson approximation: +! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, +! 2nd edition, Oxford University Press, 1989. +! Effective H2O path (w) +! eq. 6.24, p. 228 +! Effective H2O path pressure (pnew = u/w): +! eq. 6.29, p. 228 +! + ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1) + ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2) + + pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1) + pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2) + + dtx(i) = tplnka(i,k2) - 250. + dty(i) = tpatha - 250. + + fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i)) + fwku(i) = fwk(i)*u(i) +! +! Define variables for C/H/E (now C/LT/E) fit +! +! abso(i,1) 0 - 800 cm-1 h2o rotation band +! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! abso(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O absorptivity +! +! Notation: +! U = integral (P/P_0 dW) +! P = atmospheric pressure +! P_0 = reference atmospheric pressure +! W = precipitable water path +! T_e = emission temperature +! T_p = path temperature +! RH = path relative humidity +! +! +! Terms for asymptotic value of emissivity +! + te1 = tplnka(i,k2) + te2 = te1 * te1 + te3 = te2 * te1 + te4 = te3 * te1 + te5 = te4 * te1 + +! +! Band-independent indices for lines and continuum tables +! + dvar = (t_p - min_tp_h2o) / dtp_h2o + itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1) + itp1 = itp + 1 + wtp = dvar - floor(dvar) + wtp1 = 1.0 - wtp + + t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o) + dvar = (t_e - min_te_h2o) / dte_h2o + ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1) + ite1 = ite + 1 + wte = dvar - floor(dvar) + wte1 = 1.0 - wte + + rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o) + dvar = (rh_path - min_rh_h2o) / drh_h2o + irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1) + irh1 = irh + 1 + wrh = dvar - floor(dvar) + wrh1 = 1.0 - wrh + + w_0_0_ = wtp * wte + w_0_1_ = wtp * wte1 + w_1_0_ = wtp1 * wte + w_1_1_ = wtp1 * wte1 + + w_0_00 = w_0_0_ * wrh + w_0_01 = w_0_0_ * wrh1 + w_0_10 = w_0_1_ * wrh + w_0_11 = w_0_1_ * wrh1 + w_1_00 = w_1_0_ * wrh + w_1_01 = w_1_0_ * wrh1 + w_1_10 = w_1_1_ * wrh + w_1_11 = w_1_1_ * wrh1 + +! +! H2O Continuum path for 0-800 and 1200-2200 cm^-1 +! +! Assume foreign continuum dominates total H2O continuum in these bands +! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776 +! Then the effective H2O path is just +! U_c = integral[ f(P) dW ] +! where +! W = water-vapor mass and +! f(P) = dependence of foreign continuum on pressure +! = P / sslp +! Then +! U_c = U (the same effective H2O path as for lines) +! +! +! Continuum terms for 800-1200 cm^-1 +! +! Assume self continuum dominates total H2O continuum for this band +! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776 +! Then the effective H2O self-continuum path is +! U_c = integral[ h(e,T) dW ] (*eq. 1*) +! where +! W = water-vapor mass and +! e = partial pressure of H2O along path +! T = temperature along path +! h(e,T) = dependence of foreign continuum on e,T +! = e / sslp * f(T) +! +! Replacing +! e =~ q * P / epsilo +! q = mixing ratio of H2O +! epsilo = 0.622 +! +! and using the definition +! U = integral [ (P / sslp) dW ] +! = (P / sslp) W (homogeneous path) +! +! the effective path length for the self continuum is +! U_c = (q / epsilo) f(T) U (*eq. 2*) +! +! Once values of T, U, and q have been calculated for the inhomogeneous +! path, this sets U_c for the corresponding +! homogeneous atmosphere. However, this need not equal the +! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere +! under consideration. +! +! Solution: hold T and q constant, solve for U' that gives U_c' by +! inverting eq. (2): +! +! U' = (U_c * epsilo) / (q * f(T)) +! + fch2o = fh2oself(t_p) + uch2o = (pch2o * epsilo) / (q_path * fch2o) + +! +! Band-dependent indices for non-window +! + ib = 1 + + uvar = ub(ib) * fdif + log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o) + dvar = (log_u - min_lu_h2o) / dlu_h2o + iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iu1 = iu + 1 + wu = dvar - floor(dvar) + wu1 = 1.0 - wu + + log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o) + dvar = (log_p - min_lp_h2o) / dlp_h2o + ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1) + ip1 = ip + 1 + wp = dvar - floor(dvar) + wp1 = 1.0 - wp + + w00_00 = wp * w_0_00 + w00_01 = wp * w_0_01 + w00_10 = wp * w_0_10 + w00_11 = wp * w_0_11 + w01_00 = wp * w_1_00 + w01_01 = wp * w_1_01 + w01_10 = wp * w_1_10 + w01_11 = wp * w_1_11 + w10_00 = wp1 * w_0_00 + w10_01 = wp1 * w_0_01 + w10_10 = wp1 * w_0_10 + w10_11 = wp1 * w_0_11 + w11_00 = wp1 * w_1_00 + w11_01 = wp1 * w_1_01 + w11_10 = wp1 * w_1_10 + w11_11 = wp1 * w_1_11 +! +! Asymptotic value of absorptivity as U->infinity +! + fa = fat(1,ib) + & + fat(2,ib) * te1 + & + fat(3,ib) * te2 + & + fat(4,ib) * te3 + & + fat(5,ib) * te4 + & + fat(6,ib) * te5 + + a_star = & + ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * & + aer_trn_ttl(i,k1,k2,ib)), & + 0.0_r8), 1.0_r8) +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + abso(i,ib) = abso(i,ib) * uscl + endif + +! +! Band-dependent indices for window +! + ib = 2 + + uvar = ub(ib) * fdif + log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o) + dvar = (log_u - min_lu_h2o) / dlu_h2o + iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iu1 = iu + 1 + wu = dvar - floor(dvar) + wu1 = 1.0 - wu + + log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o) + dvar = (log_p - min_lp_h2o) / dlp_h2o + ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1) + ip1 = ip + 1 + wp = dvar - floor(dvar) + wp1 = 1.0 - wp + + w00_00 = wp * w_0_00 + w00_01 = wp * w_0_01 + w00_10 = wp * w_0_10 + w00_11 = wp * w_0_11 + w01_00 = wp * w_1_00 + w01_01 = wp * w_1_01 + w01_10 = wp * w_1_10 + w01_11 = wp * w_1_11 + w10_00 = wp1 * w_0_00 + w10_01 = wp1 * w_0_01 + w10_10 = wp1 * w_0_10 + w10_11 = wp1 * w_0_11 + w11_00 = wp1 * w_1_00 + w11_01 = wp1 * w_1_01 + w11_10 = wp1 * w_1_10 + w11_11 = wp1 * w_1_11 + + log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o) + dvar = (log_uc - min_lu_h2o) / dlu_h2o + iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iuc1 = iuc + 1 + wuc = dvar - floor(dvar) + wuc1 = 1.0 - wuc +! +! Asymptotic value of absorptivity as U->infinity +! + fa = fat(1,ib) + & + fat(2,ib) * te1 + & + fat(3,ib) * te2 + & + fat(4,ib) * te3 + & + fat(5,ib) * te4 + & + fat(6,ib) * te5 + + l_star = & + ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + + c_star = & + cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + & + cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + & + cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + & + cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + & + cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + & + cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + & + cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + & + cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + & + cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + & + cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + & + cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + & + cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + & + cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + & + cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + & + cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + & + cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + & + cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + & + cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + & + cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + & + cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + & + cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + & + cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + & + cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + & + cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + & + cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + & + cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + & + cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + & + cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + & + cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + & + cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + & + cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + & + cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc + abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * & + aer_trn_ttl(i,k1,k2,ib)), & + 0.0_r8), 1.0_r8) +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + abso(i,ib) = abso(i,ib) * uscl + endif + + end do +! +! Line transmission in 800-1000 and 1000-1200 cm-1 intervals +! + do i=1,ncol + term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i)) + term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i)) + term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i)) + term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i)) + end do +! +! 500 - 800 cm-1 h2o rotation band overlap with co2 +! + do i=1,ncol + k21 = term7(i,1) + term8(i,1)/ & + (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i)) + k22 = term7(i,2) + term8(i,2)/ & + (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i)) + tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i)))) + tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i)))) + tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800) +! ! H2O line+STRAER trn 650--800 cm-1 + tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650) +! ! H2O line+STRAER trn 500--650 cm-1 + tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i))) + tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i))) + tr9(i) = tr1*tr5 + tr10(i) = tr2*tr6 + th2o(i) = tr10(i) + trab2(i) = 0.65*tr9(i) + 0.35*tr10(i) + end do + if (k2 < k1) then + do i=1,ncol + to3h2o(i) = h2otr(i,k1)/h2otr(i,k2) + end do + else + do i=1,ncol + to3h2o(i) = h2otr(i,k2)/h2otr(i,k1) + end do + end if +! +! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands) +! + do i=1,ncol + dpnm(i) = pnm(i,k1) - pnm(i,k2) + to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i) + te = (to3co2(i)*r293)**.7 + dplos = plos(i,k1) - plos(i,k2) + dplol = plol(i,k1) - plol(i,k2) + u1 = 18.29*abs(dplos)/te + u2 = .5649*abs(dplos)/te + rphat = dplol/dplos + tlocal = tint(i,k2) + tcrfac = sqrt(tlocal*r250)*te + beta = r3205*(rphat + dpfo3*tcrfac) + realnu = te/beta + tmp1 = u1/sqrt(4. + u1*(1. + realnu)) + tmp2 = u2/sqrt(4. + u2*(1. + realnu)) + o3bndi = 74.*te*log(1. + tmp1 + tmp2) + abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2) + to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2) + end do +! +! abso(i,4) co2 15 micrometer band system +! + do i=1,ncol + sqwp = sqrt(abs(plco2(i,k1) - plco2(i,k2))) + et = exp(-480./to3co2(i)) + sqti(i) = sqrt(to3co2(i)) + rsqti = 1./sqti(i) + et2 = et*et + et4 = et2*et2 + omet = 1. - 1.5*et2 + f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti + f1sqwp(i) = f1co2*sqwp + t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti)) + oneme = 1. - et2 + alphat = oneme**3*rsqti + pi = abs(dpnm(i)) + wco2 = 2.5221*co2vmr*pi*rga + u7(i) = 4.9411e4*alphat*et2*wco2 + u8 = 3.9744e4*alphat*et4*wco2 + u9 = 1.0447e5*alphat*et4*et2*wco2 + u13 = 2.8388e3*alphat*et4*wco2 + tpath = to3co2(i) + tlocal = tint(i,k2) + tcrfac = sqrt(tlocal*r250*tpath*r300) + posqt = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti + rbeta7(i) = 1./(5.3228*posqt) + rbeta8 = 1./(10.6576*posqt) + rbeta9 = rbeta7(i) + rbeta13 = rbeta9 + f2co2(i) = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + & + (u8 /sqrt(4. + u8*(1. + rbeta8))) + & + (u9 /sqrt(4. + u9*(1. + rbeta9))) + f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13)) + end do + if (k2 >= k1) then + do i=1,ncol + sqti(i) = sqrt(tlayr(i,k2)) + end do + end if +! + do i=1,ncol + tmp1 = log(1. + f1sqwp(i)) + tmp2 = log(1. + f2co2(i)) + tmp3 = log(1. + f3co2(i)) + absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i) + abso(i,4) = trab2(i)*co2em(i,k2)*absbnd + tco2(i) = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))) + end do +! +! Calculate absorptivity due to trace gases, abstrc +! + call trcab( lchnk ,ncol ,pcols, pverp, & + k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , & + bch4 ,to3co2 ,pnm ,dw ,pnew , & + s2c ,uptype ,u ,abplnk1 ,tco2 , & + th2o ,to3 ,abstrc , & + aer_trn_ttl) +! +! Sum total absorptivity +! + do i=1,ncol + abstot(i,k1,k2) = abso(i,1) + abso(i,2) + & + abso(i,3) + abso(i,4) + abstrc(i) + end do + end do ! do k2 = + end do ! do k1 = +! +! Adjacent layer absorptivity: +! +! abso(i,1) 0 - 800 cm-1 h2o rotation band +! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! abso(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O absorptivity +! +! 500-800 cm^-1 H2o continuum/line overlap already included +! in abso(i,1). This used to be in abso(i,4) +! +! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands) +! abso(i,4) co2 15 micrometer band system +! +! Nearest layer level loop +! + do k2=pver,ntoplw,-1 + do i=1,ncol + tbar(i,1) = 0.5*(tint(i,k2+1) + tlayr(i,k2+1)) + emm(i,1) = 0.5*(co2em(i,k2+1) + co2eml(i,k2)) + tbar(i,2) = 0.5*(tlayr(i,k2+1) + tint(i,k2)) + emm(i,2) = 0.5*(co2em(i,k2) + co2eml(i,k2)) + tbar(i,3) = 0.5*(tbar(i,2) + tbar(i,1)) + emm(i,3) = emm(i,1) + tbar(i,4) = tbar(i,3) + emm(i,4) = emm(i,2) + o3emm(i,1) = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2)) + o3emm(i,2) = 0.5*(dbvtit(i,k2) + dbvtly(i,k2)) + o3emm(i,3) = o3emm(i,1) + o3emm(i,4) = o3emm(i,2) + temh2o(i,1) = tbar(i,1) + temh2o(i,2) = tbar(i,2) + temh2o(i,3) = tbar(i,1) + temh2o(i,4) = tbar(i,2) + dpnm(i) = pnm(i,k2+1) - pnm(i,k2) + end do +! +! Weighted Planck functions for trace gases +! + do wvl = 1,14 + do i = 1,ncol + bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2)) + bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2)) + bplnk(wvl,i,3) = bplnk(wvl,i,1) + bplnk(wvl,i,4) = bplnk(wvl,i,2) + end do + end do + + do i=1,ncol + rdpnmsq = 1./(pnmsq(i,k2+1) - pnmsq(i,k2)) + rdpnm = 1./dpnm(i) + p1 = .5*(pbr(i,k2) + pnm(i,k2+1)) + p2 = .5*(pbr(i,k2) + pnm(i,k2 )) + uinpl(i,1) = (pnmsq(i,k2+1) - p1**2)*rdpnmsq + uinpl(i,2) = -(pnmsq(i,k2 ) - p2**2)*rdpnmsq + uinpl(i,3) = -(pnmsq(i,k2 ) - p1**2)*rdpnmsq + uinpl(i,4) = (pnmsq(i,k2+1) - p2**2)*rdpnmsq + winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm + winpl(i,2) = (.5*(-pnm(i,k2 ) + pbr(i,k2)))*rdpnm + winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2 ))*rdpnm + winpl(i,4) = (.5*(-pnm(i,k2 ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm + tmp1 = 1./(piln(i,k2+1) - piln(i,k2)) + tmp2 = piln(i,k2+1) - pmln(i,k2) + tmp3 = piln(i,k2 ) - pmln(i,k2) + zinpl(i,1) = (.5*tmp2 )*tmp1 + zinpl(i,2) = ( - .5*tmp3)*tmp1 + zinpl(i,3) = (.5*tmp2 - tmp3)*tmp1 + zinpl(i,4) = ( tmp2 - .5*tmp3)*tmp1 + pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1)) + pinpl(i,2) = 0.5*(p2 + pnm(i,k2 )) + pinpl(i,3) = 0.5*(p1 + pnm(i,k2 )) + pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1)) + if(strat_volcanic) then + aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1)) + endif + end do + do kn=1,4 + do i=1,ncol + u(i) = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1)) + sqrtu(i) = sqrt(u(i)) + dw(i) = abs(w(i,k2) - w(i,k2+1)) + pnew(i) = u(i)/(winpl(i,kn)*dw(i)) + pnew_mks = pnew(i) * sslp_mks + t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o) + iest = floor(t_p) - min_tp_h2o + esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * & + (t_p - min_tp_h2o - iest) + qsx = epsilo * esx / (pnew_mks - omeps * esx) + q_path = dw(i) / ABS(dpnm(i)) / rga + + ds2c = abs(s2c(i,k2) - s2c(i,k2+1)) + uc1(i) = uinpl(i,kn)*ds2c + pch2o = uc1(i) + uc1(i) = (uc1(i) + 1.7e-3*u(i))*(1. + 2.*uc1(i))/(1. + 15.*uc1(i)) + dtx(i) = temh2o(i,kn) - 250. + dty(i) = tbar(i,kn) - 250. + + fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i)) + fwku(i) = fwk(i)*u(i) + + if(strat_volcanic) then + aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i) + + do bnd_idx=1,bnd_nbr_LW + odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt + aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl) + end do + else + aer_trn_ngh(i,:) = 1.0 + endif + +! +! Define variables for C/H/E (now C/LT/E) fit +! +! abso(i,1) 0 - 800 cm-1 h2o rotation band +! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! abso(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O absorptivity +! +! Notation: +! U = integral (P/P_0 dW) +! P = atmospheric pressure +! P_0 = reference atmospheric pressure +! W = precipitable water path +! T_e = emission temperature +! T_p = path temperature +! RH = path relative humidity +! +! +! Terms for asymptotic value of emissivity +! + te1 = temh2o(i,kn) + te2 = te1 * te1 + te3 = te2 * te1 + te4 = te3 * te1 + te5 = te4 * te1 + +! +! Indices for lines and continuum tables +! Note: because we are dealing with the nearest layer, +! the Hulst-Curtis-Godson corrections +! for inhomogeneous paths are not applied. +! + uvar = u(i)*fdif + log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o) + dvar = (log_u - min_lu_h2o) / dlu_h2o + iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iu1 = iu + 1 + wu = dvar - floor(dvar) + wu1 = 1.0 - wu + + log_p = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o) + dvar = (log_p - min_lp_h2o) / dlp_h2o + ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1) + ip1 = ip + 1 + wp = dvar - floor(dvar) + wp1 = 1.0 - wp + + dvar = (t_p - min_tp_h2o) / dtp_h2o + itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1) + itp1 = itp + 1 + wtp = dvar - floor(dvar) + wtp1 = 1.0 - wtp + + t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o) + dvar = (t_e - min_te_h2o) / dte_h2o + ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1) + ite1 = ite + 1 + wte = dvar - floor(dvar) + wte1 = 1.0 - wte + + rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o) + dvar = (rh_path - min_rh_h2o) / drh_h2o + irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1) + irh1 = irh + 1 + wrh = dvar - floor(dvar) + wrh1 = 1.0 - wrh + + w_0_0_ = wtp * wte + w_0_1_ = wtp * wte1 + w_1_0_ = wtp1 * wte + w_1_1_ = wtp1 * wte1 + + w_0_00 = w_0_0_ * wrh + w_0_01 = w_0_0_ * wrh1 + w_0_10 = w_0_1_ * wrh + w_0_11 = w_0_1_ * wrh1 + w_1_00 = w_1_0_ * wrh + w_1_01 = w_1_0_ * wrh1 + w_1_10 = w_1_1_ * wrh + w_1_11 = w_1_1_ * wrh1 + + w00_00 = wp * w_0_00 + w00_01 = wp * w_0_01 + w00_10 = wp * w_0_10 + w00_11 = wp * w_0_11 + w01_00 = wp * w_1_00 + w01_01 = wp * w_1_01 + w01_10 = wp * w_1_10 + w01_11 = wp * w_1_11 + w10_00 = wp1 * w_0_00 + w10_01 = wp1 * w_0_01 + w10_10 = wp1 * w_0_10 + w10_11 = wp1 * w_0_11 + w11_00 = wp1 * w_1_00 + w11_01 = wp1 * w_1_01 + w11_10 = wp1 * w_1_10 + w11_11 = wp1 * w_1_11 + +! +! Non-window absorptivity +! + ib = 1 + + fa = fat(1,ib) + & + fat(2,ib) * te1 + & + fat(3,ib) * te2 + & + fat(4,ib) * te3 + & + fat(5,ib) * te4 + & + fat(6,ib) * te5 + + a_star = & + ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + + abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * & + aer_trn_ngh(i,ib)), & + 0.0_r8), 1.0_r8) + +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + abso(i,ib) = abso(i,ib) * uscl + endif + +! +! Window absorptivity +! + ib = 2 + + fa = fat(1,ib) + & + fat(2,ib) * te1 + & + fat(3,ib) * te2 + & + fat(4,ib) * te3 + & + fat(5,ib) * te4 + & + fat(6,ib) * te5 + + a_star = & + ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + + abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * & + aer_trn_ngh(i,ib)), & + 0.0_r8), 1.0_r8) + +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + abso(i,ib) = abso(i,ib) * uscl + endif + + end do +! +! Line transmission in 800-1000 and 1000-1200 cm-1 intervals +! + do i=1,ncol + term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i)) + term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i)) + term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i)) + term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i)) + end do +! +! 500 - 800 cm-1 h2o rotation band overlap with co2 +! + do i=1,ncol + dtym10 = dty(i) - 10. + denom = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i) + k21 = term7(i,1) + term8(i,1)/denom + denom = 1. + (c28 + c29*dtym10 )*sqrtu(i) + k22 = term7(i,2) + term8(i,2)/denom + tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i)))) + tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i)))) + tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800) +! ! H2O line+STRAER trn 650--800 cm-1 + tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650) +! ! H2O line+STRAER trn 500--650 cm-1 + tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i))) + tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i))) + tr9(i) = tr1*tr5 + tr10(i) = tr2*tr6 + trab2(i)= 0.65*tr9(i) + 0.35*tr10(i) + th2o(i) = tr10(i) + end do +! +! abso(i,3) o3 9.6 micrometer (nu3 and nu1 bands) +! + do i=1,ncol + te = (tbar(i,kn)*r293)**.7 + dplos = abs(plos(i,k2+1) - plos(i,k2)) + u1 = zinpl(i,kn)*18.29*dplos/te + u2 = zinpl(i,kn)*.5649*dplos/te + tlocal = tbar(i,kn) + tcrfac = sqrt(tlocal*r250)*te + beta = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac) + realnu = te/beta + tmp1 = u1/sqrt(4. + u1*(1. + realnu)) + tmp2 = u2/sqrt(4. + u2*(1. + realnu)) + o3bndi = 74.*te*log(1. + tmp1 + tmp2) + abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2)) + to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2) + end do +! +! abso(i,4) co2 15 micrometer band system +! + do i=1,ncol + dplco2 = plco2(i,k2+1) - plco2(i,k2) + sqwp = sqrt(uinpl(i,kn)*dplco2) + et = exp(-480./tbar(i,kn)) + sqti(i) = sqrt(tbar(i,kn)) + rsqti = 1./sqti(i) + et2 = et*et + et4 = et2*et2 + omet = (1. - 1.5*et2) + f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti + f1sqwp(i)= f1co2*sqwp + t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti)) + oneme = 1. - et2 + alphat = oneme**3*rsqti + pi = abs(dpnm(i))*winpl(i,kn) + wco2 = 2.5221*co2vmr*pi*rga + u7(i) = 4.9411e4*alphat*et2*wco2 + u8 = 3.9744e4*alphat*et4*wco2 + u9 = 1.0447e5*alphat*et4*et2*wco2 + u13 = 2.8388e3*alphat*et4*wco2 + tpath = tbar(i,kn) + tlocal = tbar(i,kn) + tcrfac = sqrt((tlocal*r250)*(tpath*r300)) + posqt = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti + rbeta7(i)= 1./(5.3228*posqt) + rbeta8 = 1./(10.6576*posqt) + rbeta9 = rbeta7(i) + rbeta13 = rbeta9 + f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + & + u8 /sqrt(4. + u8*(1. + rbeta8)) + & + u9 /sqrt(4. + u9*(1. + rbeta9)) + f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13)) + tmp1 = log(1. + f1sqwp(i)) + tmp2 = log(1. + f2co2(i)) + tmp3 = log(1. + f3co2(i)) + absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i) + abso(i,4)= trab2(i)*emm(i,kn)*absbnd + tco2(i) = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + end do ! do i = +! +! Calculate trace gas absorptivity for nearest layer, abstrc +! + call trcabn(lchnk ,ncol ,pcols, pverp, & + k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,tbar ,bplnk , & + winpl ,pinpl ,tco2 ,th2o ,to3 , & + uptype ,dw ,s2c ,u ,pnew , & + abstrc ,uinpl , & + aer_trn_ngh) +! +! Total next layer absorptivity: +! + do i=1,ncol + absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + & + abso(i,3) + abso(i,4) + abstrc(i) + end do + end do ! do kn = + end do ! do k2 = + + return +end subroutine radabs + +function psi(tpx,iband) +! +! History: First version for Hitran 1996 (C/H/E) +! Current version for Hitran 2000 (C/LT/E) +! Short function for Hulst-Curtis-Godson temperature factors for +! computing effective H2O path +! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing +! lines between 500 and 2820 cm^-1. +! See cfa-www.harvard.edu/HITRAN +! Isotopes of H2O: all +! Line widths: air-broadened only (self set to 0) +! Code for line strengths and widths: GENLN3 +! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric +! Transmittance and Radiance Model, Version 3.0 Description +! and Users Guide, NCAR/TN-367+STR, 147 pp. +! +! Note: functions have been normalized by dividing by their values at +! a path temperature of 160K +! +! spectral intervals: +! 1 = 0-800 cm^-1 and 1200-2200 cm^-1 +! 2 = 800-1200 cm^-1 +! +! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, +! 2nd edition, Oxford University Press, 1989. +! Psi: function for pressure along path +! eq. 6.30, p. 228 +! + real(r8),intent(in):: tpx ! path temperature + integer, intent(in):: iband ! band to process + real(r8) psi ! psi for given band + real(r8),parameter :: psi_r0(nbands) = (/ 5.65308452E-01, -7.30087891E+01/) + real(r8),parameter :: psi_r1(nbands) = (/ 4.07519005E-03, 1.22199547E+00/) + real(r8),parameter :: psi_r2(nbands) = (/-1.04347237E-05, -7.12256227E-03/) + real(r8),parameter :: psi_r3(nbands) = (/ 1.23765354E-08, 1.47852825E-05/) + + psi = (((psi_r3(iband) * tpx) + psi_r2(iband)) * tpx + psi_r1(iband)) * tpx + psi_r0(iband) +end function psi + +function phi(tpx,iband) +! +! History: First version for Hitran 1996 (C/H/E) +! Current version for Hitran 2000 (C/LT/E) +! Short function for Hulst-Curtis-Godson temperature factors for +! computing effective H2O path +! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing +! lines between 500 and 2820 cm^-1. +! See cfa-www.harvard.edu/HITRAN +! Isotopes of H2O: all +! Line widths: air-broadened only (self set to 0) +! Code for line strengths and widths: GENLN3 +! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric +! Transmittance and Radiance Model, Version 3.0 Description +! and Users Guide, NCAR/TN-367+STR, 147 pp. +! +! Note: functions have been normalized by dividing by their values at +! a path temperature of 160K +! +! spectral intervals: +! 1 = 0-800 cm^-1 and 1200-2200 cm^-1 +! 2 = 800-1200 cm^-1 +! +! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, +! 2nd edition, Oxford University Press, 1989. +! Phi: function for H2O path +! eq. 6.25, p. 228 +! + real(r8),intent(in):: tpx ! path temperature + integer, intent(in):: iband ! band to process + real(r8) phi ! phi for given band + real(r8),parameter :: phi_r0(nbands) = (/ 9.60917711E-01, -2.21031342E+01/) + real(r8),parameter :: phi_r1(nbands) = (/ 4.86076751E-04, 4.24062610E-01/) + real(r8),parameter :: phi_r2(nbands) = (/-1.84806265E-06, -2.95543415E-03/) + real(r8),parameter :: phi_r3(nbands) = (/ 2.11239959E-09, 7.52470896E-06/) + + phi = (((phi_r3(iband) * tpx) + phi_r2(iband)) * tpx + phi_r1(iband)) & + * tpx + phi_r0(iband) +end function phi + +function fh2oself( temp ) +! +! Short function for H2O self-continuum temperature factor in +! calculation of effective H2O self-continuum path length +! +! H2O Continuum: CKD 2.4 +! Code for continuum: GENLN3 +! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric +! Transmittance and Radiance Model, Version 3.0 Description +! and Users Guide, NCAR/TN-367+STR, 147 pp. +! +! In GENLN, the temperature scaling of the self-continuum is handled +! by exponential interpolation/extrapolation from observations at +! 260K and 296K by: +! +! TFAC = (T(IPATH) - 296.0)/(260.0 - 296.0) +! CSFFT = CSFF296*(CSFF260/CSFF296)**TFAC +! +! For 800-1200 cm^-1, (CSFF260/CSFF296) ranges from ~2.1 to ~1.9 +! with increasing wavenumber. The ratio /, +! where <> indicates average over wavenumber, is ~2.07 +! +! fh2oself is (/)**TFAC +! + real(r8),intent(in) :: temp ! path temperature + real(r8) fh2oself ! mean ratio of self-continuum at temp and 296K + + fh2oself = 2.0727484**((296.0 - temp) / 36.0) +end function fh2oself + +! from wv_saturation.F90 + + real(r8) function estblf( td ) +! +! Saturation vapor pressure table lookup +! + real(r8), intent(in) :: td ! Temperature for saturation lookup +! + real(r8) :: e ! intermediate variable for es look-up + real(r8) :: ai + integer :: i +! + e = max(min(td,tmax),tmin) ! partial pressure + i = int(e-tmin)+1 + ai = aint(e-tmin) + estblf = (tmin+ai-e+1.)* & + estbl(i)-(tmin+ai-e)* & + estbl(i+1) + end function estblf + + +subroutine esinti(epslon ,latvap ,latice ,rh2o ,cpair ,tmelt ) +!----------------------------------------------------------------------- +! +! Purpose: +! Initialize es lookup tables +! +! Method: +! +! +! +! Author: J. Hack +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use wv_saturation, only: gestbl + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: epslon ! Ratio of h2o to dry air molecular weights + real(r8), intent(in) :: latvap ! Latent heat of vaporization + real(r8), intent(in) :: latice ! Latent heat of fusion + real(r8), intent(in) :: rh2o ! Gas constant for water vapor + real(r8), intent(in) :: cpair ! Specific heat of dry air + real(r8), intent(in) :: tmelt ! Melting point of water (K) +! +!---------------------------Local workspace----------------------------- +! + real(r8) tmn ! Minimum temperature entry in table + real(r8) tmx ! Maximum temperature entry in table + real(r8) trice ! Trans range from es over h2o to es over ice + logical ip ! Ice phase (true or false) +! +!----------------------------------------------------------------------- +! +! Specify control parameters first +! + tmn = 173.16 + tmx = 375.16 + trice = 20.00 + ip = .true. +! +! Call gestbl to build saturation vapor pressure table. +! + call gestbl(tmn ,tmx ,trice ,ip ,epslon , & + latvap ,latice ,rh2o ,cpair ,tmelt ) +! + return +end subroutine esinti + +subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , & + latvap ,latice ,rh2o ,cpair ,tmeltx ) +!----------------------------------------------------------------------- +! +! Purpose: +! Builds saturation vapor pressure table for later lookup procedure. +! +! Method: +! Uses Goff & Gratch (1946) relationships to generate the table +! according to a set of free parameters defined below. Auxiliary +! routines are also included for making rapid estimates (well with 1%) +! of both es and d(es)/dt for the particular table configuration. +! +! Author: J. Hack +! +!----------------------------------------------------------------------- +! use pmgrid, only: masterproc + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: tmn ! Minimum temperature entry in es lookup table + real(r8), intent(in) :: tmx ! Maximum temperature entry in es lookup table + real(r8), intent(in) :: epsil ! Ratio of h2o to dry air molecular weights + real(r8), intent(in) :: trice ! Transition range from es over range to es over ice + real(r8), intent(in) :: latvap ! Latent heat of vaporization + real(r8), intent(in) :: latice ! Latent heat of fusion + real(r8), intent(in) :: rh2o ! Gas constant for water vapor + real(r8), intent(in) :: cpair ! Specific heat of dry air + real(r8), intent(in) :: tmeltx ! Melting point of water (K) +! +!---------------------------Local variables----------------------------- +! + real(r8) t ! Temperature + real(r8) rgasv + real(r8) cp + real(r8) hlatf + real(r8) ttrice + real(r8) hlatv + integer n ! Increment counter + integer lentbl ! Calculated length of lookup table + integer itype ! Ice phase: 0 -> no ice phase +! 1 -> ice phase, no transition +! -x -> ice phase, x degree transition + logical ip ! Ice phase logical flag + logical icephs +! +!----------------------------------------------------------------------- +! +! Set es table parameters +! + tmin = tmn ! Minimum temperature entry in table + tmax = tmx ! Maximum temperature entry in table + ttrice = trice ! Trans. range from es over h2o to es over ice + icephs = ip ! Ice phase (true or false) +! +! Set physical constants required for es calculation +! + epsqs = epsil + hlatv = latvap + hlatf = latice + rgasv = rh2o + cp = cpair + tmelt = tmeltx +! + lentbl = INT(tmax-tmin+2.000001) + if (lentbl .gt. plenest) then + write(6,9000) tmax, tmin, plenest +! call endrun ('GESTBL') ! Abnormal termination + end if +! +! Begin building es table. +! Check whether ice phase requested. +! If so, set appropriate transition range for temperature +! + if (icephs) then + if (ttrice /= 0.0) then + itype = -ttrice + else + itype = 1 + end if + else + itype = 0 + end if +! + t = tmin - 1.0 + do n=1,lentbl + t = t + 1.0 + call gffgch(t,estbl(n),itype) + end do +! + do n=lentbl+1,plenest + estbl(n) = -99999.0 + end do +! +! Table complete -- Set coefficients for polynomial approximation of +! difference between saturation vapor press over water and saturation +! pressure over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial +! is valid in the range -40 < t < 0 (degrees C). +! +! --- Degree 5 approximation --- +! + pcf(1) = 5.04469588506e-01 + pcf(2) = -5.47288442819e+00 + pcf(3) = -3.67471858735e-01 + pcf(4) = -8.95963532403e-03 + pcf(5) = -7.78053686625e-05 +! +! --- Degree 6 approximation --- +! +!-----pcf(1) = 7.63285250063e-02 +!-----pcf(2) = -5.86048427932e+00 +!-----pcf(3) = -4.38660831780e-01 +!-----pcf(4) = -1.37898276415e-02 +!-----pcf(5) = -2.14444472424e-04 +!-----pcf(6) = -1.36639103771e-06 +! + if (masterproc) then + write(6,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***' + end if + + return +! +9000 format('GESTBL: FATAL ERROR *********************************',/, & + ' TMAX AND TMIN REQUIRE A LARGER DIMENSION ON THE LENGTH', & + ' OF THE SATURATION VAPOR PRESSURE TABLE ESTBL(PLENEST)',/, & + ' TMAX, TMIN, AND PLENEST => ', 2f7.2, i3) +! +end subroutine gestbl + +subroutine gffgch(t ,es ,itype ) +!----------------------------------------------------------------------- +! +! Purpose: +! Computes saturation vapor pressure over water and/or over ice using +! Goff & Gratch (1946) relationships. +! +! +! Method: +! T (temperature), and itype are input parameters, while es (saturation +! vapor pressure) is an output parameter. The input parameter itype +! serves two purposes: a value of zero indicates that saturation vapor +! pressures over water are to be returned (regardless of temperature), +! while a value of one indicates that saturation vapor pressures over +! ice should be returned when t is less than freezing degrees. If itype +! is negative, its absolute value is interpreted to define a temperature +! transition region below freezing in which the returned +! saturation vapor pressure is a weighted average of the respective ice +! and water value. That is, in the temperature range 0 => -itype +! degrees c, the saturation vapor pressures are assumed to be a weighted +! average of the vapor pressure over supercooled water and ice (all +! water at 0 c; all ice at -itype c). Maximum transition range => 40 c +! +! Author: J. Hack +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use physconst, only: tmelt +! use abortutils, only: endrun + + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: t ! Temperature +! +! Output arguments +! + integer, intent(inout) :: itype ! Flag for ice phase and associated transition + + real(r8), intent(out) :: es ! Saturation vapor pressure +! +!---------------------------Local variables----------------------------- +! + real(r8) e1 ! Intermediate scratch variable for es over water + real(r8) e2 ! Intermediate scratch variable for es over water + real(r8) eswtr ! Saturation vapor pressure over water + real(r8) f ! Intermediate scratch variable for es over water + real(r8) f1 ! Intermediate scratch variable for es over water + real(r8) f2 ! Intermediate scratch variable for es over water + real(r8) f3 ! Intermediate scratch variable for es over water + real(r8) f4 ! Intermediate scratch variable for es over water + real(r8) f5 ! Intermediate scratch variable for es over water + real(r8) ps ! Reference pressure (mb) + real(r8) t0 ! Reference temperature (freezing point of water) + real(r8) term1 ! Intermediate scratch variable for es over ice + real(r8) term2 ! Intermediate scratch variable for es over ice + real(r8) term3 ! Intermediate scratch variable for es over ice + real(r8) tr ! Transition range for es over water to es over ice + real(r8) ts ! Reference temperature (boiling point of water) + real(r8) weight ! Intermediate scratch variable for es transition + integer itypo ! Intermediate scratch variable for holding itype +! +!----------------------------------------------------------------------- +! +! Check on whether there is to be a transition region for es +! + if (itype < 0) then + tr = abs(float(itype)) + itypo = itype + itype = 1 + else + tr = 0.0 + itypo = itype + end if + if (tr > 40.0) then + write(6,900) tr +! call endrun ('GFFGCH') ! Abnormal termination + end if +! + if(t < (tmelt - tr) .and. itype == 1) go to 10 +! +! Water +! + ps = 1013.246 + ts = 373.16 + e1 = 11.344*(1.0 - t/ts) + e2 = -3.49149*(ts/t - 1.0) + f1 = -7.90298*(ts/t - 1.0) + f2 = 5.02808*log10(ts/t) + f3 = -1.3816*(10.0**e1 - 1.0)/10000000.0 + f4 = 8.1328*(10.0**e2 - 1.0)/1000.0 + f5 = log10(ps) + f = f1 + f2 + f3 + f4 + f5 + es = (10.0**f)*100.0 + eswtr = es +! + if(t >= tmelt .or. itype == 0) go to 20 +! +! Ice +! +10 continue + t0 = tmelt + term1 = 2.01889049/(t0/t) + term2 = 3.56654*log(t0/t) + term3 = 20.947031*(t0/t) + es = 575.185606e10*exp(-(term1 + term2 + term3)) +! + if (t < (tmelt - tr)) go to 20 +! +! Weighted transition between water and ice +! + weight = min((tmelt - t)/tr,1.0_r8) + es = weight*es + (1.0 - weight)*eswtr +! +20 continue + itype = itypo + return +! +900 format('GFFGCH: FATAL ERROR ******************************',/, & + 'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', & + ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', & + ' 40.0 DEGREES C',/, ' TR = ',f7.2) +! +end subroutine gffgch + +subroutine radems(lchnk ,ncol ,pcols, pver, pverp, & + s2c ,tcg ,w ,tplnke ,plh2o , & + pnm ,plco2 ,tint ,tint4 ,tlayr , & + tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , & + uco213 ,uco221 ,uco222 ,uco223 ,uptype , & + bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , & + co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , & + plh2ob ,wb , & + aer_trn_ttl) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12 +! +! Method: +! H2O .... Uses nonisothermal emissivity method for water vapor from +! Ramanathan, V. and P.Downey, 1986: A Nonisothermal +! Emissivity and Absorptivity Formulation for Water Vapor +! Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666 +! +! Implementation updated by Collins,Hackney, and Edwards 2001 +! using line-by-line calculations based upon Hitran 1996 and +! CKD 2.1 for absorptivity and emissivity +! +! Implementation updated by Collins, Lee-Taylor, and Edwards (2003) +! using line-by-line calculations based upon Hitran 2000 and +! CKD 2.4 for absorptivity and emissivity +! +! CO2 .... Uses absorptance parameterization of the 15 micro-meter +! (500 - 800 cm-1) band system of Carbon Dioxide, from +! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization +! of the Absorptance Due to the 15 micro-meter Band System +! of Carbon Dioxide Jouranl of Geophysical Research, +! vol. 96., D5, pp 9013-9019. Also includes the effects +! of the 9.4 and 10.4 micron bands of CO2. +! +! O3 .... Uses absorptance parameterization of the 9.6 micro-meter +! band system of ozone, from Ramanathan, V. and R. Dickinson, +! 1979: The Role of stratospheric ozone in the zonal and +! seasonal radiative energy balance of the earth-troposphere +! system. Journal of the Atmospheric Sciences, Vol. 36, +! pp 1084-1104 +! +! ch4 .... Uses a broad band model for the 7.7 micron band of methane. +! +! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron +! bands of nitrous oxide +! +! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5 +! micron bands of CFC11 +! +! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2 +! micron bands of CFC12 +! +! +! Computes individual emissivities, accounting for band overlap, and +! sums to obtain the total. +! +! Author: W. Collins (H2O emissivity) and J. Kiehl +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length + real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.) + real(r8), intent(in) :: w(pcols,pverp) ! H2o path length + real(r8), intent(in) :: tplnke(pcols) ! Layer planck temperature + real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wghted path length + real(r8), intent(in) :: pnm(pcols,pverp) ! Model interface pressure + real(r8), intent(in) :: plco2(pcols,pverp) ! Prs wghted path of co2 + real(r8), intent(in) :: tint(pcols,pverp) ! Model interface temperatures + real(r8), intent(in) :: tint4(pcols,pverp) ! Tint to the 4th power + real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 model layer temperature + real(r8), intent(in) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power + real(r8), intent(in) :: plol(pcols,pverp) ! Pressure wghtd ozone path + real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path + real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + + real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) +! ! [fraction] Total strat. aerosol +! ! transmission between interfaces k1 and k2 + +! +! Trace gas variables +! + real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length + real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length + real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4 + real(r8), intent(in) :: uptype(pcols,pverp) ! p-type continuum path length +! +! Output arguments +! + real(r8), intent(out) :: emstot(pcols,pverp) ! Total emissivity + real(r8), intent(out) :: co2em(pcols,pverp) ! Layer co2 normalzd plnck funct drvtv + real(r8), intent(out) :: co2eml(pcols,pver) ! Intrfc co2 normalzd plnck func drvtv + real(r8), intent(out) :: co2t(pcols,pverp) ! Tmp and prs weighted path length + real(r8), intent(out) :: h2otr(pcols,pverp) ! H2o transmission over o3 band + real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor + real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor + +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer k ! Level index] + integer k1 ! Level index +! +! Local variables for H2O: +! + real(r8) h2oems(pcols,pverp) ! H2o emissivity + real(r8) tpathe ! Used to compute h2o emissivity + real(r8) dtx(pcols) ! Planck temperature minus 250 K + real(r8) dty(pcols) ! Path temperature minus 250 K +! +! The 500-800 cm^-1 emission in emis(i,4) has been combined +! into the 0-800 cm^-1 emission in emis(i,1) +! + real(r8) emis(pcols,2) ! H2O emissivity +! +! +! + real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D + real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8) + real(r8) tr1(pcols) ! Equation(6) in table A2 for 650-800 + real(r8) tr2(pcols) ! Equation(6) in table A2 for 500-650 + real(r8) tr3(pcols) ! Equation(4) in table A2 for 650-800 + real(r8) tr4(pcols) ! Equation(4),table A2 of R&D for 500-650 + real(r8) tr7(pcols) ! Equation (6) times eq(4) in table A2 +! of R&D for 650-800 cm-1 region + real(r8) tr8(pcols) ! Equation (6) times eq(4) in table A2 +! of R&D for 500-650 cm-1 region + real(r8) k21(pcols) ! Exponential coefficient used to calc +! rot band transmissivity in the 650-800 +! cm-1 region (tr1) + real(r8) k22(pcols) ! Exponential coefficient used to calc +! rot band transmissivity in the 500-650 +! cm-1 region (tr2) + real(r8) u(pcols) ! Pressure weighted H2O path length + real(r8) ub(nbands) ! Pressure weighted H2O path length with + ! Hulst-Curtis-Godson correction for + ! each band + real(r8) pnew ! Effective pressure for h2o linewidth + real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/ + ! Hulst-Curtis-Godson correction for + ! each band + real(r8) uc1(pcols) ! H2o continuum pathlength 500-800 cm-1 + real(r8) fwk ! Equation(33) in R&D far wing correction + real(r8) troco2(pcols,pverp) ! H2o overlap factor for co2 absorption + real(r8) emplnk(14,pcols) ! emissivity Planck factor + real(r8) emstrc(pcols,pverp) ! total trace gas emissivity +! +! Local variables for CO2: +! + real(r8) co2ems(pcols,pverp) ! Co2 emissivity + real(r8) co2plk(pcols) ! Used to compute co2 emissivity + real(r8) sum(pcols) ! Used to calculate path temperature + real(r8) t1i ! Co2 hot band temperature factor + real(r8) sqti ! Sqrt of temperature + real(r8) pi ! Pressure used in co2 mean line width + real(r8) et ! Co2 hot band factor + real(r8) et2 ! Co2 hot band factor + real(r8) et4 ! Co2 hot band factor + real(r8) omet ! Co2 stimulated emission term + real(r8) ex ! Part of co2 planck function + real(r8) f1co2 ! Co2 weak band factor + real(r8) f2co2 ! Co2 weak band factor + real(r8) f3co2 ! Co2 weak band factor + real(r8) t1co2 ! Overlap factor weak bands strong band + real(r8) sqwp ! Sqrt of co2 pathlength + real(r8) f1sqwp ! Main co2 band factor + real(r8) oneme ! Co2 stimulated emission term + real(r8) alphat ! Part of the co2 stimulated emiss term + real(r8) wco2 ! Consts used to define co2 pathlength + real(r8) posqt ! Effective pressure for co2 line width + real(r8) rbeta7 ! Inverse of co2 hot band line width par + real(r8) rbeta8 ! Inverse of co2 hot band line width par + real(r8) rbeta9 ! Inverse of co2 hot band line width par + real(r8) rbeta13 ! Inverse of co2 hot band line width par + real(r8) tpath ! Path temp used in co2 band model + real(r8) tmp1 ! Co2 band factor + real(r8) tmp2 ! Co2 band factor + real(r8) tmp3 ! Co2 band factor + real(r8) tlayr5 ! Temperature factor in co2 Planck func + real(r8) rsqti ! Reciprocal of sqrt of temperature + real(r8) exm1sq ! Part of co2 Planck function + real(r8) u7 ! Absorber amt for various co2 band systems + real(r8) u8 ! Absorber amt for various co2 band systems + real(r8) u9 ! Absorber amt for various co2 band systems + real(r8) u13 ! Absorber amt for various co2 band systems + real(r8) r250 ! Inverse 250K + real(r8) r300 ! Inverse 300K + real(r8) rsslp ! Inverse standard sea-level pressure +! +! Local variables for O3: +! + real(r8) o3ems(pcols,pverp) ! Ozone emissivity + real(r8) dbvtt(pcols) ! Tmp drvtv of planck fctn for tplnke + real(r8) dbvt,fo3,t,ux,vx + real(r8) te ! Temperature factor + real(r8) u1 ! Path length factor + real(r8) u2 ! Path length factor + real(r8) phat ! Effecitive path length pressure + real(r8) tlocal ! Local planck function temperature + real(r8) tcrfac ! Scaled temperature factor + real(r8) beta ! Absorption funct factor voigt effect + real(r8) realnu ! Absorption function factor + real(r8) o3bndi ! Band absorption factor +! +! Transmission terms for various spectral intervals: +! + real(r8) absbnd ! Proportional to co2 band absorptance + real(r8) tco2(pcols) ! co2 overlap factor + real(r8) th2o(pcols) ! h2o overlap factor + real(r8) to3(pcols) ! o3 overlap factor +! +! Variables for new H2O parameterization +! +! Notation: +! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986 +! P = atmospheric pressure +! P_0 = reference atmospheric pressure +! W = precipitable water path +! T_e = emission temperature +! T_p = path temperature +! RH = path relative humidity +! + real(r8) fe ! asymptotic value of emis. as U->infinity + real(r8) e_star ! normalized non-window emissivity + real(r8) l_star ! interpolated line transmission + real(r8) c_star ! interpolated continuum transmission + + real(r8) te1 ! emission temperature + real(r8) te2 ! te^2 + real(r8) te3 ! te^3 + real(r8) te4 ! te^4 + real(r8) te5 ! te^5 + + real(r8) log_u ! log base 10 of U + real(r8) log_uc ! log base 10 of H2O continuum path + real(r8) log_p ! log base 10 of P + real(r8) t_p ! T_p + real(r8) t_e ! T_e (offset by T_p) + + integer iu ! index for log10(U) + integer iu1 ! iu + 1 + integer iuc ! index for log10(H2O continuum path) + integer iuc1 ! iuc + 1 + integer ip ! index for log10(P) + integer ip1 ! ip + 1 + integer itp ! index for T_p + integer itp1 ! itp + 1 + integer ite ! index for T_e + integer ite1 ! ite + 1 + integer irh ! index for RH + integer irh1 ! irh + 1 + + real(r8) dvar ! normalized variation in T_p/T_e/P/U + real(r8) uvar ! U * diffusivity factor + real(r8) uscl ! factor for lineary scaling as U->0 + + real(r8) wu ! weight for U + real(r8) wu1 ! 1 - wu + real(r8) wuc ! weight for H2O continuum path + real(r8) wuc1 ! 1 - wuc + real(r8) wp ! weight for P + real(r8) wp1 ! 1 - wp + real(r8) wtp ! weight for T_p + real(r8) wtp1 ! 1 - wtp + real(r8) wte ! weight for T_e + real(r8) wte1 ! 1 - wte + real(r8) wrh ! weight for RH + real(r8) wrh1 ! 1 - wrh + + real(r8) w_0_0_ ! weight for Tp/Te combination + real(r8) w_0_1_ ! weight for Tp/Te combination + real(r8) w_1_0_ ! weight for Tp/Te combination + real(r8) w_1_1_ ! weight for Tp/Te combination + + real(r8) w_0_00 ! weight for Tp/Te/RH combination + real(r8) w_0_01 ! weight for Tp/Te/RH combination + real(r8) w_0_10 ! weight for Tp/Te/RH combination + real(r8) w_0_11 ! weight for Tp/Te/RH combination + real(r8) w_1_00 ! weight for Tp/Te/RH combination + real(r8) w_1_01 ! weight for Tp/Te/RH combination + real(r8) w_1_10 ! weight for Tp/Te/RH combination + real(r8) w_1_11 ! weight for Tp/Te/RH combination + + real(r8) w00_00 ! weight for P/Tp/Te/RH combination + real(r8) w00_01 ! weight for P/Tp/Te/RH combination + real(r8) w00_10 ! weight for P/Tp/Te/RH combination + real(r8) w00_11 ! weight for P/Tp/Te/RH combination + real(r8) w01_00 ! weight for P/Tp/Te/RH combination + real(r8) w01_01 ! weight for P/Tp/Te/RH combination + real(r8) w01_10 ! weight for P/Tp/Te/RH combination + real(r8) w01_11 ! weight for P/Tp/Te/RH combination + real(r8) w10_00 ! weight for P/Tp/Te/RH combination + real(r8) w10_01 ! weight for P/Tp/Te/RH combination + real(r8) w10_10 ! weight for P/Tp/Te/RH combination + real(r8) w10_11 ! weight for P/Tp/Te/RH combination + real(r8) w11_00 ! weight for P/Tp/Te/RH combination + real(r8) w11_01 ! weight for P/Tp/Te/RH combination + real(r8) w11_10 ! weight for P/Tp/Te/RH combination + real(r8) w11_11 ! weight for P/Tp/Te/RH combination + + integer ib ! spectral interval: + ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1 + ! 2 = 800-1200 cm^-1 + + real(r8) pch2o ! H2O continuum path + real(r8) fch2o ! temp. factor for continuum + real(r8) uch2o ! U corresponding to H2O cont. path (window) + + real(r8) fdif ! secant(zenith angle) for diffusivity approx. + + real(r8) sslp_mks ! Sea-level pressure in MKS units + real(r8) esx ! saturation vapor pressure returned by vqsatd + real(r8) qsx ! saturation mixing ratio returned by vqsatd + real(r8) pnew_mks ! pnew in MKS units + real(r8) q_path ! effective specific humidity along path + real(r8) rh_path ! effective relative humidity along path + real(r8) omeps ! 1 - epsilo + + integer iest ! index in estblh2o + +! +!---------------------------Statement functions------------------------- +! +! Derivative of planck function at 9.6 micro-meter wavelength, and +! an absorption function factor: +! +! + dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ & + (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t) +! + fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx)) +! +! +! +!----------------------------------------------------------------------- +! +! Initialize +! + r250 = 1./250. + r300 = 1./300. + rsslp = 1./sslp +! +! Constants for computing U corresponding to H2O cont. path +! + fdif = 1.66 + sslp_mks = sslp / 10.0 + omeps = 1.0 - epsilo +! +! Planck function for co2 +! + do i=1,ncol + ex = exp(960./tplnke(i)) + co2plk(i) = 5.e8/((tplnke(i)**4)*(ex - 1.)) + co2t(i,ntoplw) = tplnke(i) + sum(i) = co2t(i,ntoplw)*pnm(i,ntoplw) + end do + k = ntoplw + do k1=pverp,ntoplw+1,-1 + k = k + 1 + do i=1,ncol + sum(i) = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1)) + ex = exp(960./tlayr(i,k1)) + tlayr5 = tlayr(i,k1)*tlayr4(i,k1) + co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2) + co2t(i,k) = sum(i)/pnm(i,k) + end do + end do +! +! Initialize planck function derivative for O3 +! + do i=1,ncol + dbvtt(i) = dbvt(tplnke(i)) + end do +! +! Calculate trace gas Planck functions +! + call trcplk(lchnk ,ncol ,pcols, pver, pverp, & + tint ,tlayr ,tplnke ,emplnk ,abplnk1 , & + abplnk2 ) +! +! Interface loop +! + do k1=ntoplw,pverp +! +! H2O emissivity +! +! emis(i,1) 0 - 800 cm-1 h2o rotation band +! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! emis(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O emissivity +! +! emis(i,3) = 0.0 +! +! For the p type continuum +! + do i=1,ncol + u(i) = plh2o(i,k1) + pnew = u(i)/w(i,k1) + pnew_mks = pnew * sslp_mks +! +! Apply scaling factor for 500-800 continuum +! + uc1(i) = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ & + (1. + 15.*s2c(i,k1)) + pch2o = s2c(i,k1) +! +! Changed effective path temperature to std. Curtis-Godson form +! + tpathe = tcg(i,k1)/w(i,k1) + t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o) + iest = floor(t_p) - min_tp_h2o + esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * & + (t_p - min_tp_h2o - iest) + qsx = epsilo * esx / (pnew_mks - omeps * esx) +! +! Compute effective RH along path +! + q_path = w(i,k1) / pnm(i,k1) / rga +! +! Calculate effective u, pnew for each band using +! Hulst-Curtis-Godson approximation: +! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, +! 2nd edition, Oxford University Press, 1989. +! Effective H2O path (w) +! eq. 6.24, p. 228 +! Effective H2O path pressure (pnew = u/w): +! eq. 6.29, p. 228 +! + ub(1) = plh2ob(1,i,k1) / psi(t_p,1) + ub(2) = plh2ob(2,i,k1) / psi(t_p,2) + + pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1) + pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2) +! +! +! + dtx(i) = tplnke(i) - 250. + dty(i) = tpathe - 250. +! +! Define variables for C/H/E (now C/LT/E) fit +! +! emis(i,1) 0 - 800 cm-1 h2o rotation band +! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band +! emis(i,2) 800 - 1200 cm-1 h2o window +! +! Separation between rotation and vibration-rotation dropped, so +! only 2 slots needed for H2O emissivity +! +! emis(i,3) = 0.0 +! +! Notation: +! U = integral (P/P_0 dW) +! P = atmospheric pressure +! P_0 = reference atmospheric pressure +! W = precipitable water path +! T_e = emission temperature +! T_p = path temperature +! RH = path relative humidity +! +! Terms for asymptotic value of emissivity +! + te1 = tplnke(i) + te2 = te1 * te1 + te3 = te2 * te1 + te4 = te3 * te1 + te5 = te4 * te1 +! +! Band-independent indices for lines and continuum tables +! + dvar = (t_p - min_tp_h2o) / dtp_h2o + itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1) + itp1 = itp + 1 + wtp = dvar - floor(dvar) + wtp1 = 1.0 - wtp + + t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o) + dvar = (t_e - min_te_h2o) / dte_h2o + ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1) + ite1 = ite + 1 + wte = dvar - floor(dvar) + wte1 = 1.0 - wte + + rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o) + dvar = (rh_path - min_rh_h2o) / drh_h2o + irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1) + irh1 = irh + 1 + wrh = dvar - floor(dvar) + wrh1 = 1.0 - wrh + + w_0_0_ = wtp * wte + w_0_1_ = wtp * wte1 + w_1_0_ = wtp1 * wte + w_1_1_ = wtp1 * wte1 + + w_0_00 = w_0_0_ * wrh + w_0_01 = w_0_0_ * wrh1 + w_0_10 = w_0_1_ * wrh + w_0_11 = w_0_1_ * wrh1 + w_1_00 = w_1_0_ * wrh + w_1_01 = w_1_0_ * wrh1 + w_1_10 = w_1_1_ * wrh + w_1_11 = w_1_1_ * wrh1 +! +! H2O Continuum path for 0-800 and 1200-2200 cm^-1 +! +! Assume foreign continuum dominates total H2O continuum in these bands +! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776 +! Then the effective H2O path is just +! U_c = integral[ f(P) dW ] +! where +! W = water-vapor mass and +! f(P) = dependence of foreign continuum on pressure +! = P / sslp +! Then +! U_c = U (the same effective H2O path as for lines) +! +! +! Continuum terms for 800-1200 cm^-1 +! +! Assume self continuum dominates total H2O continuum for this band +! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776 +! Then the effective H2O self-continuum path is +! U_c = integral[ h(e,T) dW ] (*eq. 1*) +! where +! W = water-vapor mass and +! e = partial pressure of H2O along path +! T = temperature along path +! h(e,T) = dependence of foreign continuum on e,T +! = e / sslp * f(T) +! +! Replacing +! e =~ q * P / epsilo +! q = mixing ratio of H2O +! epsilo = 0.622 +! +! and using the definition +! U = integral [ (P / sslp) dW ] +! = (P / sslp) W (homogeneous path) +! +! the effective path length for the self continuum is +! U_c = (q / epsilo) f(T) U (*eq. 2*) +! +! Once values of T, U, and q have been calculated for the inhomogeneous +! path, this sets U_c for the corresponding +! homogeneous atmosphere. However, this need not equal the +! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere +! under consideration. +! +! Solution: hold T and q constant, solve for U' that gives U_c' by +! inverting eq. (2): +! +! U' = (U_c * epsilo) / (q * f(T)) +! + fch2o = fh2oself(t_p) + uch2o = (pch2o * epsilo) / (q_path * fch2o) + +! +! Band-dependent indices for non-window +! + ib = 1 + + uvar = ub(ib) * fdif + log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o) + dvar = (log_u - min_lu_h2o) / dlu_h2o + iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iu1 = iu + 1 + wu = dvar - floor(dvar) + wu1 = 1.0 - wu + + log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o) + dvar = (log_p - min_lp_h2o) / dlp_h2o + ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1) + ip1 = ip + 1 + wp = dvar - floor(dvar) + wp1 = 1.0 - wp + + w00_00 = wp * w_0_00 + w00_01 = wp * w_0_01 + w00_10 = wp * w_0_10 + w00_11 = wp * w_0_11 + w01_00 = wp * w_1_00 + w01_01 = wp * w_1_01 + w01_10 = wp * w_1_10 + w01_11 = wp * w_1_11 + w10_00 = wp1 * w_0_00 + w10_01 = wp1 * w_0_01 + w10_10 = wp1 * w_0_10 + w10_11 = wp1 * w_0_11 + w11_00 = wp1 * w_1_00 + w11_01 = wp1 * w_1_01 + w11_10 = wp1 * w_1_10 + w11_11 = wp1 * w_1_11 + +! +! Asymptotic value of emissivity as U->infinity +! + fe = fet(1,ib) + & + fet(2,ib) * te1 + & + fet(3,ib) * te2 + & + fet(4,ib) * te3 + & + fet(5,ib) * te4 + & + fet(6,ib) * te5 + + e_star = & + eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * & + aer_trn_ttl(i,k1,1,ib)), & + 0.0_r8), 1.0_r8) +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + emis(i,ib) = emis(i,ib) * uscl + endif + + + +! +! Band-dependent indices for window +! + ib = 2 + + uvar = ub(ib) * fdif + log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o) + dvar = (log_u - min_lu_h2o) / dlu_h2o + iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iu1 = iu + 1 + wu = dvar - floor(dvar) + wu1 = 1.0 - wu + + log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o) + dvar = (log_p - min_lp_h2o) / dlp_h2o + ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1) + ip1 = ip + 1 + wp = dvar - floor(dvar) + wp1 = 1.0 - wp + + w00_00 = wp * w_0_00 + w00_01 = wp * w_0_01 + w00_10 = wp * w_0_10 + w00_11 = wp * w_0_11 + w01_00 = wp * w_1_00 + w01_01 = wp * w_1_01 + w01_10 = wp * w_1_10 + w01_11 = wp * w_1_11 + w10_00 = wp1 * w_0_00 + w10_01 = wp1 * w_0_01 + w10_10 = wp1 * w_0_10 + w10_11 = wp1 * w_0_11 + w11_00 = wp1 * w_1_00 + w11_01 = wp1 * w_1_01 + w11_10 = wp1 * w_1_10 + w11_11 = wp1 * w_1_11 + + log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o) + dvar = (log_uc - min_lu_h2o) / dlu_h2o + iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1) + iuc1 = iuc + 1 + wuc = dvar - floor(dvar) + wuc1 = 1.0 - wuc +! +! Asymptotic value of emissivity as U->infinity +! + fe = fet(1,ib) + & + fet(2,ib) * te1 + & + fet(3,ib) * te2 + & + fet(4,ib) * te3 + & + fet(5,ib) * te4 + & + fet(6,ib) * te5 + + l_star = & + ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + & + ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + & + ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + & + ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + & + ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + & + ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + & + ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + & + ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + & + ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + & + ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + & + ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + & + ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + & + ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + & + ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + & + ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + & + ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + & + ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + & + ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + & + ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + & + ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + & + ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + & + ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + & + ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + & + ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + & + ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + & + ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + & + ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + & + ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + & + ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + & + ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + & + ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + & + ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu + + c_star = & + cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + & + cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + & + cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + & + cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + & + cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + & + cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + & + cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + & + cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + & + cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + & + cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + & + cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + & + cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + & + cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + & + cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + & + cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + & + cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + & + cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + & + cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + & + cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + & + cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + & + cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + & + cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + & + cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + & + cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + & + cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + & + cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + & + cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + & + cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + & + cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + & + cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + & + cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + & + cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc + emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * & + aer_trn_ttl(i,k1,1,ib)), & + 0.0_r8), 1.0_r8) +! +! Invoke linear limit for scaling wrt u below min_u_h2o +! + if (uvar < min_u_h2o) then + uscl = uvar / min_u_h2o + emis(i,ib) = emis(i,ib) * uscl + endif + + +! +! Compute total emissivity for H2O +! + h2oems(i,k1) = emis(i,1)+emis(i,2) + + end do +! +! +! + + do i=1,ncol + term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i)) + term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i)) + term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i)) + term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i)) + end do + do i=1,ncol +! +! 500 - 800 cm-1 rotation band overlap with co2 +! + k21(i) = term7(i,1) + term8(i,1)/ & + (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i))) + k22(i) = term7(i,2) + term8(i,2)/ & + (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i))) + fwk = fwcoef + fwc1/(1.+fwc2*u(i)) + tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i)))) + tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i)))) + tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800) +! ! H2O line+aer trn 650--800 cm-1 + tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650) +! ! H2O line+aer trn 500--650 cm-1 + tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i))) + tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i))) + tr7(i) = tr1(i)*tr3(i) + tr8(i) = tr2(i)*tr4(i) + troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i) + th2o(i) = tr8(i) + end do +! +! CO2 emissivity for 15 micron band system +! + do i=1,ncol + t1i = exp(-480./co2t(i,k1)) + sqti = sqrt(co2t(i,k1)) + rsqti = 1./sqti + et = t1i + et2 = et*et + et4 = et2*et2 + omet = 1. - 1.5*et2 + f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti + sqwp = sqrt(plco2(i,k1)) + f1sqwp = f1co2*sqwp + t1co2 = 1./(1. + 245.18*omet*sqwp*rsqti) + oneme = 1. - et2 + alphat = oneme**3*rsqti + wco2 = 2.5221*co2vmr*pnm(i,k1)*rga + u7 = 4.9411e4*alphat*et2*wco2 + u8 = 3.9744e4*alphat*et4*wco2 + u9 = 1.0447e5*alphat*et4*et2*wco2 + u13 = 2.8388e3*alphat*et4*wco2 +! + tpath = co2t(i,k1) + tlocal = tplnke(i) + tcrfac = sqrt((tlocal*r250)*(tpath*r300)) + pi = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac + posqt = pi/(2.*sqti) + rbeta7 = 1./( 5.3288*posqt) + rbeta8 = 1./ (10.6576*posqt) + rbeta9 = rbeta7 + rbeta13= rbeta9 + f2co2 = (u7/sqrt(4. + u7*(1. + rbeta7))) + & + (u8/sqrt(4. + u8*(1. + rbeta8))) + & + (u9/sqrt(4. + u9*(1. + rbeta9))) + f3co2 = u13/sqrt(4. + u13*(1. + rbeta13)) + tmp1 = log(1. + f1sqwp) + tmp2 = log(1. + f2co2) + tmp3 = log(1. + f3co2) + absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti + tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7)))) + co2ems(i,k1) = troco2(i,k1)*absbnd*co2plk(i) + ex = exp(960./tint(i,k1)) + exm1sq = (ex - 1.)**2 + co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq) + end do +! +! O3 emissivity +! + do i=1,ncol + h2otr(i,k1) = exp(-12.*s2c(i,k1)) + h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200) + te = (co2t(i,k1)/293.)**.7 + u1 = 18.29*plos(i,k1)/te + u2 = .5649*plos(i,k1)/te + phat = plos(i,k1)/plol(i,k1) + tlocal = tplnke(i) + tcrfac = sqrt(tlocal*r250)*te + beta = (1./.3205)*((1./phat) + (dpfo3*tcrfac)) + realnu = (1./beta)*te + o3bndi = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu)) + o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi + to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu)) + end do +! +! Calculate trace gas emissivities +! + call trcems(lchnk ,ncol ,pcols, pverp, & + k1 ,co2t ,pnm ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , & + bch4 ,uco211 ,uco212 ,uco213 ,uco221 , & + uco222 ,uco223 ,uptype ,w ,s2c , & + u ,emplnk ,th2o ,tco2 ,to3 , & + emstrc , & + aer_trn_ttl) +! +! Total emissivity: +! + do i=1,ncol + emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1) & + + emstrc(i,k1) + end do + end do ! End of interface loop + + return +end subroutine radems + +subroutine radtpl(lchnk ,ncol ,pcols, pver, pverp, & + tnm ,lwupcgs ,qnm ,pnm ,plco2 ,plh2o , & + tplnka ,s2c ,tcg ,w ,tplnke , & + tint ,tint4 ,tlayr ,tlayr4 ,pmln , & + piln ,plh2ob ,wb ) +!-------------------------------------------------------------------- +! +! Purpose: +! Compute temperatures and path lengths for longwave radiation +! +! Method: +! +! +! +! Author: CCM1 +! +!-------------------------------------------------------------------- + +!------------------------------Arguments----------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures + real(r8), intent(in) :: lwupcgs(pcols) ! Surface longwave up flux + real(r8), intent(in) :: qnm(pcols,pver) ! Model level specific humidity + real(r8), intent(in) :: pnm(pcols,pverp) ! Pressure at model interfaces (dynes/cm2) + real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1) + real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1) +! +! Output arguments +! + real(r8), intent(out) :: plco2(pcols,pverp) ! Pressure weighted co2 path + real(r8), intent(out) :: plh2o(pcols,pverp) ! Pressure weighted h2o path + real(r8), intent(out) :: tplnka(pcols,pverp) ! Level temperature from interface temperatures + real(r8), intent(out) :: s2c(pcols,pverp) ! H2o continuum path length + real(r8), intent(out) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.) + real(r8), intent(out) :: w(pcols,pverp) ! H2o path length + real(r8), intent(out) :: tplnke(pcols) ! Equal to tplnka + real(r8), intent(out) :: tint(pcols,pverp) ! Layer interface temperature + real(r8), intent(out) :: tint4(pcols,pverp) ! Tint to the 4th power + real(r8), intent(out) :: tlayr(pcols,pverp) ! K-1 level temperature + real(r8), intent(out) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power + real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + real(r8), intent(out) :: wb(nbands,pcols,pverp) ! H2o path length with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + +! +!---------------------------Local variables-------------------------- +! + integer i ! Longitude index + integer k ! Level index + integer kp1 ! Level index + 1 + + real(r8) repsil ! Inver ratio mol weight h2o to dry air + real(r8) dy ! Thickness of layer for tmp interp + real(r8) dpnm ! Pressure thickness of layer + real(r8) dpnmsq ! Prs squared difference across layer + real(r8) dw ! Increment in H2O path length + real(r8) dplh2o ! Increment in plh2o + real(r8) cpwpl ! Const in co2 mix ratio to path length conversn + +!-------------------------------------------------------------------- +! + repsil = 1./epsilo +! +! Compute co2 and h2o paths +! + cpwpl = amco2/amd * 0.5/(gravit*p0) + do i=1,ncol + plh2o(i,ntoplw) = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw) + plco2(i,ntoplw) = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw) + end do + do k=ntoplw,pver + do i=1,ncol + plh2o(i,k+1) = plh2o(i,k) + rgsslp* & + (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k) + plco2(i,k+1) = co2vmr*cpwpl*pnm(i,k+1)**2 + end do + end do +! +! Set the top and bottom intermediate level temperatures, +! top level planck temperature and top layer temp**4. +! +! Tint is lower interface temperature +! (not available for bottom layer, so use ground temperature) +! + do i=1,ncol + tint4(i,pverp) = lwupcgs(i)/stebol + tint(i,pverp) = sqrt(sqrt(tint4(i,pverp))) + tplnka(i,ntoplw) = tnm(i,ntoplw) + tint(i,ntoplw) = tplnka(i,ntoplw) + tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4 + tint4(i,ntoplw) = tlayr4(i,ntoplw) + end do +! +! Intermediate level temperatures are computed using temperature +! at the full level below less dy*delta t,between the full level +! + do k=ntoplw+1,pver + do i=1,ncol + dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k)) + tint(i,k) = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1)) + tint4(i,k) = tint(i,k)**4 + end do + end do +! +! Now set the layer temp=full level temperatures and establish a +! planck temperature for absorption (tplnka) which is the average +! the intermediate level temperatures. Note that tplnka is not +! equal to the full level temperatures. +! + do k=ntoplw+1,pverp + do i=1,ncol + tlayr(i,k) = tnm(i,k-1) + tlayr4(i,k) = tlayr(i,k)**4 + tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1)) + end do + end do +! +! Calculate tplank for emissivity calculation. +! Assume isothermal tplnke i.e. all levels=ttop. +! + do i=1,ncol + tplnke(i) = tplnka(i,ntoplw) + tlayr(i,ntoplw) = tint(i,ntoplw) + end do +! +! Now compute h2o path fields: +! + do i=1,ncol +! +! Changed effective path temperature to std. Curtis-Godson form +! + tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw) + w(i,ntoplw) = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw) +! +! Hulst-Curtis-Godson scaling for H2O path +! + wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1) + wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2) +! +! Hulst-Curtis-Godson scaling for effective pressure along H2O path +! + plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1) + plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2) + + s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil + end do + + do k=ntoplw,pver + do i=1,ncol + dpnm = pnm(i,k+1) - pnm(i,k) + dpnmsq = pnm(i,k+1)**2 - pnm(i,k)**2 + dw = rga*qnm(i,k)*dpnm + kp1 = k+1 + w(i,kp1) = w(i,k) + dw +! +! Hulst-Curtis-Godson scaling for H2O path +! + wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1) + wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2) +! +! Hulst-Curtis-Godson scaling for effective pressure along H2O path +! + dplh2o = plh2o(i,kp1) - plh2o(i,k) + + plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1) + plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2) +! +! Changed effective path temperature to std. Curtis-Godson form +! + tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k) + s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* & + fh2oself(tnm(i,k))*qnm(i,k)*repsil + end do + end do +! + return +end subroutine radtpl + +subroutine radaeini( pstdx, mwdryx, mwco2x ) + +USE module_wrf_error +USE module_dm + +! +! Initialize radae module data +! +! +! Input variables +! + real(r8), intent(in) :: pstdx ! Standard pressure (dynes/cm^2) + real(r8), intent(in) :: mwdryx ! Molecular weight of dry air + real(r8), intent(in) :: mwco2x ! Molecular weight of carbon dioxide +! +! Variables for loading absorptivity/emissivity +! + integer ncid_ae ! NetCDF file id for abs/ems file + + integer pdimid ! pressure dimension id + integer psize ! pressure dimension size + + integer tpdimid ! path temperature dimension id + integer tpsize ! path temperature size + + integer tedimid ! emission temperature dimension id + integer tesize ! emission temperature size + + integer udimid ! u (H2O path) dimension id + integer usize ! u (H2O path) dimension size + + integer rhdimid ! relative humidity dimension id + integer rhsize ! relative humidity dimension size + + integer ah2onwid ! var. id for non-wndw abs. + integer eh2onwid ! var. id for non-wndw ems. + integer ah2owid ! var. id for wndw abs. (adjacent layers) + integer cn_ah2owid ! var. id for continuum trans. for wndw abs. + integer cn_eh2owid ! var. id for continuum trans. for wndw ems. + integer ln_ah2owid ! var. id for line trans. for wndw abs. + integer ln_eh2owid ! var. id for line trans. for wndw ems. + +! character*(NF_MAX_NAME) tmpname! dummy variable for var/dim names + character(len=256) locfn ! local filename + integer tmptype ! dummy variable for variable type + integer ndims ! number of dimensions +! integer dims(NF_MAX_VAR_DIMS) ! vector of dimension ids + integer natt ! number of attributes +! +! Variables for setting up H2O table +! + integer t ! path temperature + integer tmin ! mininum path temperature + integer tmax ! maximum path temperature + integer itype ! type of sat. pressure (=0 -> H2O only) + integer i + real(r8) tdbl + + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER cam_abs_unit + +! +! Constants to set +! + p0 = pstdx + amd = mwdryx + amco2 = mwco2x +! +! Coefficients for h2o emissivity and absorptivity for overlap of H2O +! and trace gases. +! + c16 = coefj(3,1)/coefj(2,1) + c17 = coefk(3,1)/coefk(2,1) + c26 = coefj(3,2)/coefj(2,2) + c27 = coefk(3,2)/coefk(2,2) + c28 = .5 + c29 = .002053 + c30 = .1 + c31 = 3.0e-5 +! +! Initialize further longwave constants referring to far wing +! correction for overlap of H2O and trace gases; R&D refers to: +! +! Ramanathan, V. and P.Downey, 1986: A Nonisothermal +! Emissivity and Absorptivity Formulation for Water Vapor +! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666 +! + fwcoef = .1 ! See eq(33) R&D + fwc1 = .30 ! See eq(33) R&D + fwc2 = 4.5 ! See eq(33) and eq(34) in R&D + fc1 = 2.6 ! See eq(34) R&D + + IF ( wrf_dm_on_monitor() ) THEN + DO i = 10,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + cam_abs_unit = i + GOTO 2010 + ENDIF + ENDDO + cam_abs_unit = -1 + 2010 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( cam_abs_unit , IWORDSIZE ) + IF ( cam_abs_unit < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_cam: radaeinit: Can not find unused fortran unit to read in lookup table.' ) + ENDIF + + IF ( wrf_dm_on_monitor() ) THEN + OPEN(cam_abs_unit,FILE='CAM_ABS_DATA', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9010) + call wrf_debug(50,'reading CAM_ABS_DATA') + ENDIF + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 ) + + IF ( wrf_dm_on_monitor() ) then + READ (cam_abs_unit,ERR=9010) ah2onw + READ (cam_abs_unit,ERR=9010) eh2onw + READ (cam_abs_unit,ERR=9010) ah2ow + READ (cam_abs_unit,ERR=9010) cn_ah2ow + READ (cam_abs_unit,ERR=9010) cn_eh2ow + READ (cam_abs_unit,ERR=9010) ln_ah2ow + READ (cam_abs_unit,ERR=9010) ln_eh2ow + + endif + + DM_BCAST_MACRO(ah2onw) + DM_BCAST_MACRO(eh2onw) + DM_BCAST_MACRO(ah2ow) + DM_BCAST_MACRO(cn_ah2ow) + DM_BCAST_MACRO(cn_eh2ow) + DM_BCAST_MACRO(ln_ah2ow) + DM_BCAST_MACRO(ln_eh2ow) + + IF ( wrf_dm_on_monitor() ) CLOSE (cam_abs_unit) + +! Set up table of H2O saturation vapor pressures for use in calculation +! effective path RH. Need separate table from table in wv_saturation +! because: +! (1. Path temperatures can fall below minimum of that table; and +! (2. Abs/Emissivity tables are derived with RH for water only. +! + tmin = nint(min_tp_h2o) + tmax = nint(max_tp_h2o)+1 + itype = 0 + do t = tmin, tmax +! call gffgch(dble(t),estblh2o(t-tmin),itype) + tdbl = t + call gffgch(tdbl,estblh2o(t-tmin),itype) + end do + + RETURN +9010 CONTINUE + WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_abs_unit + CALL wrf_error_fatal(errmess) +end subroutine radaeini + +subroutine radclwmx(lchnk ,ncol ,pcols, pver, pverp, & + lwupcgs ,tnm ,qnm ,o3vmr , & + pmid ,pint ,pmln ,piln , & + n2o ,ch4 ,cfc11 ,cfc12 , & + cld ,emis ,pmxrgn ,nmxrgn ,qrl , & + doabsems, abstot, absnxt, emstot, & + flns ,flnt ,flnsc ,flntc ,flwds , & + flut ,flutc , & + flup ,flupc ,fldn ,fldnc , & + aer_mass) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute longwave radiation heating rates and boundary fluxes +! +! Method: +! Uses broad band absorptivity/emissivity method to compute clear sky; +! assumes randomly overlapped clouds with variable cloud emissivity to +! include effects of clouds. +! +! Computes clear sky absorptivity/emissivity at lower frequency (in +! general) than the model radiation frequency; uses previously computed +! and stored values for efficiency +! +! Note: This subroutine contains vertical indexing which proceeds +! from bottom to top rather than the top to bottom indexing +! used in the rest of the model. +! +! Author: B. Collins +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d +! use volcrad + + implicit none + + integer pverp2,pverp3,pverp4 +! parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4) + + real(r8) cldmin + parameter (cldmin = 1.0d-80) +!------------------------------Commons---------------------------------- +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols, pver, pverp + integer, intent(in) :: ncol ! number of atmospheric columns +! maximally overlapped region. +! 0->pmxrgn(i,1) is range of pmid for +! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for +! 2nd region, etc + integer, intent(in) :: nmxrgn(pcols) ! Number of maximally overlapped regions + logical, intent(in) :: doabsems + + real(r8), intent(in) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each + real(r8), intent(in) :: lwupcgs(pcols) ! Longwave up flux in CGS units +! +! Input arguments which are only passed to other routines +! + real(r8), intent(in) :: tnm(pcols,pver) ! Level temperature + real(r8), intent(in) :: qnm(pcols,pver) ! Level moisture field + real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio + real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressure + real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmid) + real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pint) + real(r8), intent(in) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio + real(r8), intent(in) :: ch4(pcols,pver) ! methane mass mixing ratio + real(r8), intent(in) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio + real(r8), intent(in) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio + real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover + real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity + real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer + +! +! Output arguments +! + real(r8), intent(out) :: qrl(pcols,pver) ! Longwave heating rate + real(r8), intent(out) :: flns(pcols) ! Surface cooling flux + real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux + real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model + real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing + real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux + real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model + real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface +! Added downward/upward total and clear sky fluxes + real(r8), intent(out) :: flup(pcols,pverp) ! Total sky upward longwave flux + real(r8), intent(out) :: flupc(pcols,pverp) ! Clear sky upward longwave flux + real(r8), intent(out) :: fldn(pcols,pverp) ! Total sky downward longwave flux + real(r8), intent(out) :: fldnc(pcols,pverp) ! Clear sky downward longwave flux +! + real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity + real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity + real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity + +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer ilon ! Longitude index + integer ii ! Longitude index + integer iimx ! Longitude index (max overlap) + integer k ! Level index + integer k1 ! Level index + integer k2 ! Level index + integer k3 ! Level index + integer km ! Level index + integer km1 ! Level index + integer km3 ! Level index + integer km4 ! Level index + integer irgn ! Index for max-overlap regions + integer l ! Index for clouds to overlap + integer l1 ! Index for clouds to overlap + integer n ! Counter + +! + real(r8) :: plco2(pcols,pverp) ! Path length co2 + real(r8) :: plh2o(pcols,pverp) ! Path length h2o + real(r8) tmp(pcols) ! Temporary workspace + real(r8) tmp2(pcols) ! Temporary workspace + real(r8) absbt(pcols) ! Downward emission at model top + real(r8) plol(pcols,pverp) ! O3 pressure wghted path length + real(r8) plos(pcols,pverp) ! O3 path length + real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level + real(r8) co2em(pcols,pverp) ! Layer co2 normalized planck funct. derivative + real(r8) co2eml(pcols,pver) ! Interface co2 normalized planck funct. deriv. + real(r8) delt(pcols) ! Diff t**4 mid layer to top interface + real(r8) delt1(pcols) ! Diff t**4 lower intrfc to mid layer + real(r8) bk1(pcols) ! Absrptvty for vertical quadrature + real(r8) bk2(pcols) ! Absrptvty for vertical quadrature + real(r8) cldp(pcols,pverp) ! Cloud cover with extra layer + real(r8) ful(pcols,pverp) ! Total upwards longwave flux + real(r8) fsul(pcols,pverp) ! Clear sky upwards longwave flux + real(r8) fdl(pcols,pverp) ! Total downwards longwave flux + real(r8) fsdl(pcols,pverp) ! Clear sky downwards longwv flux + real(r8) fclb4(pcols,-1:pver) ! Sig t**4 for cld bottom interfc + real(r8) fclt4(pcols,0:pver) ! Sig t**4 for cloud top interfc + real(r8) s(pcols,pverp,pverp) ! Flx integral sum + real(r8) tplnka(pcols,pverp) ! Planck fnctn temperature + real(r8) s2c(pcols,pverp) ! H2o cont amount + real(r8) tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.) + real(r8) w(pcols,pverp) ! H2o path + real(r8) tplnke(pcols) ! Planck fnctn temperature + real(r8) h2otr(pcols,pverp) ! H2o trnmsn for o3 overlap + real(r8) co2t(pcols,pverp) ! Prs wghted temperature path + real(r8) tint(pcols,pverp) ! Interface temperature + real(r8) tint4(pcols,pverp) ! Interface temperature**4 + real(r8) tlayr(pcols,pverp) ! Level temperature + real(r8) tlayr4(pcols,pverp) ! Level temperature**4 + real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + real(r8) wb(nbands,pcols,pverp) ! H2o path length with + ! Hulst-Curtis-Godson temp. factor + ! for H2O bands + + real(r8) cld0 ! previous cloud amt (for max overlap) + real(r8) cld1 ! next cloud amt (for max overlap) + real(r8) emx(0:pverp) ! Emissivity factors (max overlap) + real(r8) emx0 ! Emissivity factors for BCs (max overlap) + real(r8) trans ! 1 - emis + real(r8) asort(pver) ! 1 - cloud amounts to be sorted for max ovrlp. + real(r8) atmp ! Temporary storage for sort when nxs = 2 + real(r8) maxcld(pcols) ! Maximum cloud at any layer + + integer indx(pcols) ! index vector of gathered array values +!!$ integer indxmx(pcols+1,pverp)! index vector of gathered array values + integer indxmx(pcols,pverp)! index vector of gathered array values +! (max overlap) + integer nrgn(pcols) ! Number of max overlap regions at longitude + integer npts ! number of values satisfying some criterion + integer ncolmx(pverp) ! number of columns with clds in region + integer kx1(pcols,pverp) ! Level index for top of max-overlap region + integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region + integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld() +! in descending order + integer nxs(pcols,pverp) ! Number of cloudy layers between kx1 and kx2 + integer nxsk ! Number of cloudy layers between (kx1/kx2)&k + integer ksort(0:pverp) ! Level indices of cloud amounts to be sorted +! for max ovrlp. calculation + integer ktmp ! Temporary storage for sort when nxs = 2 + +! real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total + real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total +! ! transmission between interfaces k1 and k2 +! +! Pointer variables to 3d structures +! +! real(r8), pointer :: abstot(:,:,:) +! real(r8), pointer :: absnxt(:,:,:) +! real(r8), pointer :: emstot(:,:) + +! +! Trace gas variables +! + real(r8) ucfc11(pcols,pverp) ! CFC11 path length + real(r8) ucfc12(pcols,pverp) ! CFC12 path length + real(r8) un2o0(pcols,pverp) ! N2O path length + real(r8) un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8) uch4(pcols,pverp) ! CH4 path length + real(r8) uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8) uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8) uco213(pcols,pverp) ! CO2 9.4 micron band path length + real(r8) uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8) uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8) uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8) bn2o0(pcols,pverp) ! pressure factor for n2o + real(r8) bn2o1(pcols,pverp) ! pressure factor for n2o + real(r8) bch4(pcols,pverp) ! pressure factor for ch4 + real(r8) uptype(pcols,pverp) ! p-type continuum path length + real(r8) abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor + real(r8) abplnk2(14,pcols,pverp) ! nearest layer factor +! +! +!----------------------------------------------------------------------- +! +! + pverp2=pver+2 + pverp3=pver+3 + pverp4=pver+4 +! +! Set pointer variables +! +! abstot => abstot_3d(:,:,:,lchnk) +! absnxt => absnxt_3d(:,:,:,lchnk) +! emstot => emstot_3d(:,:,lchnk) +! +! accumulate mass path from top of atmosphere +! + call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp) + +! +! Calculate some temperatures needed to derive absorptivity and +! emissivity, as well as some h2o path lengths +! + call radtpl(lchnk ,ncol ,pcols, pver, pverp, & + tnm ,lwupcgs ,qnm ,pint ,plco2 ,plh2o , & + tplnka ,s2c ,tcg ,w ,tplnke , & + tint ,tint4 ,tlayr ,tlayr4 ,pmln , & + piln ,plh2ob ,wb ) + if (doabsems) then +! +! Compute ozone path lengths at frequency of a/e calculation. +! + call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw ) +! +! Compute trace gas path lengths +! + call trcpth(lchnk ,ncol ,pcols, pver, pverp, & + tnm ,pint ,cfc11 ,cfc12 ,n2o , & + ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , & + bch4 ,uptype ) + +! Compute transmission through STRAER absorption continuum + call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp) + +! +! +! Compute total emissivity: +! + call radems(lchnk ,ncol ,pcols, pver, pverp, & + s2c ,tcg ,w ,tplnke ,plh2o , & + pint ,plco2 ,tint ,tint4 ,tlayr , & + tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , & + uco213 ,uco221 ,uco222 ,uco223 ,uptype , & + bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , & + co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , & + plh2ob ,wb , & + aer_trn_ttl) +! +! Compute total absorptivity: +! + call radabs(lchnk ,ncol ,pcols, pver, pverp, & + pmid ,pint ,co2em ,co2eml ,tplnka , & + s2c ,tcg ,w ,h2otr ,plco2 , & + plh2o ,co2t ,tint ,tlayr ,plol , & + plos ,pmln ,piln ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , & + uco213 ,uco221 ,uco222 ,uco223 ,uptype , & + bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , & + abstot ,absnxt ,plh2ob ,wb , & + aer_mpp ,aer_trn_ttl) + end if +! +! Compute sums used in integrals (all longitude points) +! +! Definition of bk1 & bk2 depends on finite differencing. for +! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent +! layers only. +! +! delt=t**4 in layer above current sigma level km. +! delt1=t**4 in layer below current sigma level km. +! + do i=1,ncol + delt(i) = tint4(i,pver) - tlayr4(i,pverp) + delt1(i) = tlayr4(i,pverp) - tint4(i,pverp) + s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4)) + s(i,pver,pverp) = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3)) + end do + do k=ntoplw,pver-1 + do i=1,ncol + bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5 + bk1(i) = bk2(i) + s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i)) + end do + end do +! +! All k, km>1 +! + do km=pver,ntoplw+1,-1 + do i=1,ncol + delt(i) = tint4(i,km-1) - tlayr4(i,km) + delt1(i) = tlayr4(i,km) - tint4(i,km) + end do + do k=pverp,ntoplw,-1 + if (k == km) then + do i=1,ncol + bk2(i) = absnxt(i,km-1,4) + bk1(i) = absnxt(i,km-1,1) + end do + else if (k == km-1) then + do i=1,ncol + bk2(i) = absnxt(i,km-1,2) + bk1(i) = absnxt(i,km-1,3) + end do + else + do i=1,ncol + bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5 + bk1(i) = bk2(i) + end do + end if + do i=1,ncol + s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i)) + end do + end do + end do +! +! Computation of clear sky fluxes always set first level of fsul +! + do i=1,ncol + fsul(i,pverp) = lwupcgs(i) + end do +! +! Downward clear sky fluxes store intermediate quantities in down flux +! Initialize fluxes to clear sky values. +! + do i=1,ncol + tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp) + fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1) + fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw) + end do +! +! fsdl(i,pverp) assumes isothermal layer +! + do k=ntoplw+1,pver + do i=1,ncol + fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1) + fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1)) + end do + end do +! +! Store the downward emission from level 1 = total gas emission * sigma +! t**4. fsdl does not yet include all terms +! + do i=1,ncol + absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp) + fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1) + end do +! +!---------------------------------------------------------------------- +! Modifications for clouds -- max/random overlap assumption +! +! The column is divided into sets of adjacent layers, called regions, +! in which the clouds are maximally overlapped. The clouds are +! randomly overlapped between different regions. The number of +! regions in a column is set by nmxrgn, and the range of pressures +! included in each region is set by pmxrgn. The max/random overlap +! can be written in terms of the solutions of random overlap with +! cloud amounts = 1. The random overlap assumption is equivalent to +! setting the flux boundary conditions (BCs) at the edges of each region +! equal to the mean all-sky flux at those boundaries. Since the +! emissivity array for propogating BCs is only computed for the +! TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated +! in terms of solutions to the random overlap equations. This is done +! by writing the flux BCs as the sum of a clear-sky flux and emission +! from a cloud outside the region weighted by an emissivity. This +! emissivity is determined from the location of the cloud and the +! flux BC. +! +! Copy cloud amounts to buffer with extra layer (needed for overlap logic) +! + cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver) + cldp(:ncol,pverp) = 0.0 +! +! +! Select only those locations where there are no clouds +! (maximum cloud fraction <= 1.e-3 treated as clear) +! Set all-sky fluxes to clear-sky values. +! + maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2) + + npts = 0 + do i=1,ncol + if (maxcld(i) < cldmin) then + npts = npts + 1 + indx(npts) = i + end if + end do + + do ii = 1, npts + i = indx(ii) + do k = ntoplw, pverp + fdl(i,k) = fsdl(i,k) + ful(i,k) = fsul(i,k) + end do + end do +! +! Select only those locations where there are clouds +! + npts = 0 + do i=1,ncol + if (maxcld(i) >= cldmin) then + npts = npts + 1 + indx(npts) = i + end if + end do + +! +! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions +! + do ii = 1, npts + i = indx(ii) + fdl(i,ntoplw) = fsdl(i,ntoplw) + fdl(i,pverp) = 0.0 + ful(i,ntoplw) = 0.0 + ful(i,pverp) = fsul(i,pverp) + do k = ntoplw+1, pver + fdl(i,k) = 0.0 + ful(i,k) = 0.0 + end do +! +! Initialize Planck emission from layer boundaries +! + do k = ntoplw, pver + fclt4(i,k-1) = stebol*tint4(i,k) + fclb4(i,k-1) = stebol*tint4(i,k+1) + enddo + fclb4(i,ntoplw-2) = stebol*tint4(i,ntoplw) + fclt4(i,pver) = stebol*tint4(i,pverp) +! +! Initialize indices for layers to be max-overlapped +! + do irgn = 0, nmxrgn(i) + kx2(i,irgn) = ntoplw-1 + end do + nrgn(i) = 0 + end do + +!---------------------------------------------------------------------- +! INDEX CALCULATIONS FOR MAX OVERLAP + + do ii = 1, npts + ilon = indx(ii) + +! +! Outermost loop over regions (sets of adjacent layers) to be max overlapped +! + do irgn = 1, nmxrgn(ilon) +! +! Calculate min/max layer indices inside region. +! + n = 0 + if (kx2(ilon,irgn-1) < pver) then + nrgn(ilon) = irgn + k1 = kx2(ilon,irgn-1)+1 + kx1(ilon,irgn) = k1 + kx2(ilon,irgn) = 0 + do k2 = pver, k1, -1 + if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then + kx2(ilon,irgn) = k2 + exit + end if + end do +! +! Identify columns with clouds in the given region. +! + do k = k1, k2 + if (cldp(ilon,k) >= cldmin) then + n = n+1 + indxmx(n,irgn) = ilon + exit + endif + end do + endif + ncolmx(irgn) = n +! +! Dummy value for handling clear-sky regions +! +!!$ indxmx(ncolmx(irgn)+1,irgn) = ncol+1 +! +! Outer loop over columns with clouds in the max-overlap region +! + do iimx = 1, ncolmx(irgn) + i = indxmx(iimx,irgn) +! +! Sort cloud areas and corresponding level indices. +! + n = 0 + do k = kx1(i,irgn),kx2(i,irgn) + if (cldp(i,k) >= cldmin) then + n = n+1 + ksort(n) = k +! +! We need indices for clouds in order of largest to smallest, so +! sort 1-cld in ascending order +! + asort(n) = 1.0-cldp(i,k) + end if + end do + nxs(i,irgn) = n +! +! If nxs(i,irgn) eq 1, no need to sort. +! If nxs(i,irgn) eq 2, sort by swapping if necessary +! If nxs(i,irgn) ge 3, sort using local sort routine +! + if (nxs(i,irgn) == 2) then + if (asort(2) < asort(1)) then + ktmp = ksort(1) + ksort(1) = ksort(2) + ksort(2) = ktmp + + atmp = asort(1) + asort(1) = asort(2) + asort(2) = atmp + endif + else if (nxs(i,irgn) >= 3) then + call sortarray(nxs(i,irgn),asort,ksort(1:)) + endif + + do l = 1, nxs(i,irgn) + kxs(l,i,irgn) = ksort(l) + end do +! +! End loop over longitude i for fluxes +! + end do +! +! End loop over regions irgn for max-overlap +! + end do +! +!---------------------------------------------------------------------- +! DOWNWARD FLUXES: +! Outermost loop over regions (sets of adjacent layers) to be max overlapped +! + do irgn = 1, nmxrgn(ilon) +! +! Compute clear-sky fluxes for regions without clouds +! + iimx = 1 + if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then +! +! Calculate emissivity so that downward flux at upper boundary of region +! can be cast in form of solution for downward flux from cloud above +! that boundary. Then solutions for fluxes at other levels take form of +! random overlap expressions. Try to locate "cloud" as close as possible +! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1. +! + k1 = kx1(ilon,irgn) + do km1 = ntoplw-2, k1-2 + km4 = km1+3 + k2 = k1 + k3 = k2+1 + tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3) + emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ & + ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1)) + if (emx0 >= 0.0 .and. emx0 <= 1.0) exit + end do + km1 = min(km1,k1-2) + do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1 + k3 = k2+1 + tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3) + fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + & + emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon)) + end do + else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then + iimx = iimx+1 + end if +! +! Outer loop over columns with clouds in the max-overlap region +! + do iimx = 1, ncolmx(irgn) + i = indxmx(iimx,irgn) + +! +! Calculate emissivity so that downward flux at upper boundary of region +! can be cast in form of solution for downward flux from cloud above that +! boundary. Then solutions for fluxes at other levels take form of +! random overlap expressions. Try to locate "cloud" as close as possible +! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1. +! + k1 = kx1(i,irgn) + do km1 = ntoplw-2,k1-2 + km4 = km1+3 + k2 = k1 + k3 = k2 + 1 + tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3) + tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4) + emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1)) + if (emx0 >= 0.0 .and. emx0 <= 1.0) exit + end do + km1 = min(km1,k1-2) + ksort(0) = km1 + 1 +! +! Loop to calculate fluxes at level k +! + nxsk = 0 + do k = kx1(i,irgn), kx2(i,irgn) +! +! Identify clouds (largest to smallest area) between kx1 and k +! Since nxsk will increase with increasing k up to nxs(i,irgn), once +! nxsk == nxs(i,irgn) then use the list constructed for previous k +! + if (nxsk < nxs(i,irgn)) then + nxsk = 0 + do l = 1, nxs(i,irgn) + k1 = kxs(l,i,irgn) + if (k >= k1) then + nxsk = nxsk + 1 + ksort(nxsk) = k1 + endif + end do + endif +! +! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1 +! + ksort(nxsk+1) = pverp +! +! Initialize iterated emissivity factors +! + do l = 1, nxsk + emx(l) = emis(i,ksort(l)) + end do +! +! Initialize iterated emissivity factor for bnd. condition at upper interface +! + emx(0) = emx0 +! +! Initialize previous cloud amounts +! + cld0 = 1.0 +! +! Indices for flux calculations +! + k2 = k+1 + k3 = k2+1 + tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3) +! +! Loop over number of cloud levels inside region (biggest to smallest cld area) +! + do l = 1, nxsk+1 +! +! Calculate downward fluxes +! + cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l) + if (cld0 /= cld1) then + fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2) + do l1 = 0, l - 1 + km1 = ksort(l1)-1 + km4 = km1+3 + tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4) + fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- & + fsdl(i,k2)) + end do + endif + cld0 = cld1 +! +! Multiply emissivity factors by current cloud transmissivity +! + if (l <= nxsk) then + k1 = ksort(l) + trans = 1.0-emis(i,k1) +! +! Ideally the upper bound on l1 would be l-1, but the sort routine +! scrambles the order of layers with identical cloud amounts +! + do l1 = 0, nxsk + if (ksort(l1) < k1) then + emx(l1) = emx(l1)*trans + endif + end do + end if +! +! End loop over number l of cloud levels +! + end do +! +! End loop over level k for fluxes +! + end do +! +! End loop over longitude i for fluxes +! + end do +! +! End loop over regions irgn for max-overlap +! + end do + +! +!---------------------------------------------------------------------- +! UPWARD FLUXES: +! Outermost loop over regions (sets of adjacent layers) to be max overlapped +! + do irgn = nmxrgn(ilon), 1, -1 +! +! Compute clear-sky fluxes for regions without clouds +! + iimx = 1 + if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then +! +! Calculate emissivity so that upward flux at lower boundary of region +! can be cast in form of solution for upward flux from cloud below that +! boundary. Then solutions for fluxes at other levels take form of +! random overlap expressions. Try to locate "cloud" as close as possible +! to surface such that the "cloud" pseudo-emissivity is between 0 and 1. +! Include allowance for surface emissivity (both numerator and denominator +! equal 1) +! + k1 = kx2(ilon,irgn)+1 + if (k1 < pverp) then + do km1 = pver-1,kx2(ilon,irgn),-1 + km3 = km1+2 + k2 = k1 + k3 = k2+1 + tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3) + emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ & + ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1)) + if (emx0 >= 0.0 .and. emx0 <= 1.0) exit + end do + km1 = max(km1,kx2(ilon,irgn)) + else + km1 = k1-1 + km3 = km1+2 + emx0 = 1.0 + endif + + do k2 = kx1(ilon,irgn), kx2(ilon,irgn) + k3 = k2+1 +! +! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s) +! + tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3) + ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* & + (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon)) + end do + else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then + iimx = iimx+1 + end if +! +! Outer loop over columns with clouds in the max-overlap region +! + do iimx = 1, ncolmx(irgn) + i = indxmx(iimx,irgn) + +! +! Calculate emissivity so that upward flux at lower boundary of region +! can be cast in form of solution for upward flux from cloud at that +! boundary. Then solutions for fluxes at other levels take form of +! random overlap expressions. Try to locate "cloud" as close as possible +! to surface such that the "cloud" pseudo-emissivity is between 0 and 1. +! Include allowance for surface emissivity (both numerator and denominator +! equal 1) +! + k1 = kx2(i,irgn)+1 + if (k1 < pverp) then + do km1 = pver-1,kx2(i,irgn),-1 + km3 = km1+2 + k2 = k1 + k3 = k2+1 + tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3) + emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1)) + if (emx0 >= 0.0 .and. emx0 <= 1.0) exit + end do + km1 = max(km1,kx2(i,irgn)) + else + emx0 = 1.0 + km1 = k1-1 + endif + ksort(0) = km1 + 1 + +! +! Loop to calculate fluxes at level k +! + nxsk = 0 + do k = kx2(i,irgn), kx1(i,irgn), -1 +! +! Identify clouds (largest to smallest area) between k and kx2 +! Since nxsk will increase with decreasing k up to nxs(i,irgn), once +! nxsk == nxs(i,irgn) then use the list constructed for previous k +! + if (nxsk < nxs(i,irgn)) then + nxsk = 0 + do l = 1, nxs(i,irgn) + k1 = kxs(l,i,irgn) + if (k <= k1) then + nxsk = nxsk + 1 + ksort(nxsk) = k1 + endif + end do + endif +! +! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1 +! + ksort(nxsk+1) = pverp +! +! Initialize iterated emissivity factors +! + do l = 1, nxsk + emx(l) = emis(i,ksort(l)) + end do +! +! Initialize iterated emissivity factor for bnd. condition at lower interface +! + emx(0) = emx0 +! +! Initialize previous cloud amounts +! + cld0 = 1.0 +! +! Indices for flux calculations +! + k2 = k + k3 = k2+1 +! +! Loop over number of cloud levels inside region (biggest to smallest cld area) +! + do l = 1, nxsk+1 +! +! Calculate upward fluxes +! + cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l) + if (cld0 /= cld1) then + ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2) + do l1 = 0, l - 1 + km1 = ksort(l1)-1 + km3 = km1+2 +! +! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s) +! + tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3) + ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* & + (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2)) + end do + endif + cld0 = cld1 +! +! Multiply emissivity factors by current cloud transmissivity +! + if (l <= nxsk) then + k1 = ksort(l) + trans = 1.0-emis(i,k1) +! +! Ideally the upper bound on l1 would be l-1, but the sort routine +! scrambles the order of layers with identical cloud amounts +! + do l1 = 0, nxsk + if (ksort(l1) > k1) then + emx(l1) = emx(l1)*trans + endif + end do + end if +! +! End loop over number l of cloud levels +! + end do +! +! End loop over level k for fluxes +! + end do +! +! End loop over longitude i for fluxes +! + end do +! +! End loop over regions irgn for max-overlap +! + end do +! +! End outermost longitude loop +! + end do +! +! End cloud modification loops +! +!---------------------------------------------------------------------- +! All longitudes: store history tape quantities +! + do i=1,ncol + flwds(i) = fdl (i,pverp ) + flns(i) = ful (i,pverp ) - fdl (i,pverp ) + flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp ) + flnt(i) = ful (i,ntoplw) - fdl (i,ntoplw) + flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw) + flut(i) = ful (i,ntoplw) + flutc(i) = fsul(i,ntoplw) + end do +! +! Computation of longwave heating (J/kg/s) +! + do k=ntoplw,pver + do i=1,ncol + qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* & + 1.E-4*gravit/((pint(i,k) - pint(i,k+1))) + end do + end do +! Return 0 above solution domain + if ( ntoplw > 1 )then + qrl(:ncol,:ntoplw-1) = 0. + end if + +! Added downward/upward total and clear sky fluxes +! + do k=ntoplw,pverp + do i=1,ncol + flup(i,k) = ful(i,k) + flupc(i,k) = fsul(i,k) + fldn(i,k) = fdl(i,k) + fldnc(i,k) = fsdl(i,k) + end do + end do +! Return 0 above solution domain + if ( ntoplw > 1 )then + flup(:ncol,:ntoplw-1) = 0. + flupc(:ncol,:ntoplw-1) = 0. + fldn(:ncol,:ntoplw-1) = 0. + fldnc(:ncol,:ntoplw-1) = 0. + end if +! + return +end subroutine radclwmx + +subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & + pint ,pmid ,h2ommr ,rh ,o3mmr , & + aermmr ,cld ,cicewp ,cliqwp ,rel , & +! rei ,eccf ,coszrs ,scon ,solin ,solcon, & + rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon, & + asdir ,asdif ,aldir ,aldif ,nmxrgn , & + pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , & + fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns , & + fsnsc ,fsdsc ,fsds ,sols ,soll , & + solsd ,solld ,frc_day , & + fsup ,fsupc ,fsdn ,fsdnc , & + aertau ,aerssa ,aerasm ,aerfwd ) +!----------------------------------------------------------------------- +! +! Purpose: +! Solar radiation code +! +! Method: +! Basic method is Delta-Eddington as described in: +! +! Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! Five changes to the basic method described above are: +! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993) +! (2) the distinction between liquid and ice particle clouds +! (Kiehl et al, 1996); +! (3) provision for calculating TOA fluxes with spectral response to +! match Nimbus-7 visible/near-IR radiometers (Collins, 1998); +! (4) max-random overlap (Collins, 2001) +! (5) The near-IR absorption by H2O was updated in 2003 by Collins, +! Lee-Taylor, and Edwards for consistency with the new line data in +! Hitran 2000 and the H2O continuum version CKD 2.4. Modifications +! were optimized by reducing RMS errors in heating rates relative +! to a series of benchmark calculations for the 5 standard AFGL +! atmospheres. The benchmarks were performed using DISORT2 combined +! with GENLN3. The near-IR scattering optical depths for Rayleigh +! scattering were also adjusted, as well as the correction for +! stratospheric heating by H2O. +! +! The treatment of maximum-random overlap is described in the +! comment block "INDEX CALCULATIONS FOR MAX OVERLAP". +! +! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters. +! solar flux fractions specified for each interval. allows for +! seasonally and diurnally varying solar input. Includes molecular, +! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud, +! and surface absorption. Computes delta-eddington reflections and +! transmissions assuming homogeneously mixed layers. Adds the layers +! assuming scattering between layers to be isotropic, and distinguishes +! direct solar beam from scattered radiation. +! +! Longitude loops are broken into 1 or 2 sections, so that only daylight +! (i.e. coszrs > 0) computations are done. +! +! Note that an extra layer above the model top layer is added. +! +! cgs units are used. +! +! Special diagnostic calculation of the clear sky surface and total column +! absorbed flux is also done for cloud forcing diagnostics. +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use ghg_surfvals, only: co2mmr +! use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, & +! idxDUSTfirst, numDUST, idxVOLC, naer_all +! use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, & +! ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, & +! kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc +! use abortutils, only: endrun + + implicit none + + integer nspint ! Num of spctrl intervals across solar spectrum + integer naer_groups ! Num of aerosol groups for optical diagnostics + + parameter ( nspint = 19 ) + parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, and all aerosols +!-----------------------Constants for new band (640-700 nm)------------- + real(r8) v_raytau_35 + real(r8) v_raytau_64 + real(r8) v_abo3_35 + real(r8) v_abo3_64 + parameter( & + v_raytau_35 = 0.155208, & + v_raytau_64 = 0.0392, & + v_abo3_35 = 2.4058030e+01, & + v_abo3_64 = 2.210e+01 & + ) + + +!-------------Parameters for accelerating max-random solution------------- +! +! The solution time scales like prod(j:1->N) (1 + n_j) where +! N = number of max-overlap regions (nmxrgn) +! n_j = number of unique cloud amounts in region j +! +! Therefore the solution cost can be reduced by decreasing n_j. +! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky. +! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps) +! decimal places as identical +! +! areamin reduces the cost by dropping configurations that occupy +! a surface area < areamin of the model grid box. The surface area +! for a configuration C(j,k_j), where j is the region number and k_j is the +! index for a unique cloud amount (in descending order from biggest to +! smallest clouds) in region j, is +! +! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)] +! +! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0. +! +! nconfgmax reduces the cost and improves load balancing by setting an upper +! bound on the number of cloud configurations in the solution. If the number +! of configurations exceeds nconfgmax, the nconfgmax configurations with the +! largest area are retained, and the fluxes are normalized by the total area +! of these nconfgmax configurations. For the current max/random overlap +! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount +! parameterization, the mean and RMS number of configurations are +! both roughly 5. nconfgmax has been set to the mean+2*RMS number, or 15. +! +! Minimum cloud amount (as a fraction of the grid-box area) to +! distinguish from clear sky +! + real(r8) cldmin + parameter (cldmin = 1.0e-80_r8) +! +! Minimimum horizontal area (as a fraction of the grid-box area) to retain +! for a unique cloud configuration in the max-random solution +! + real(r8) areamin + parameter (areamin = 0.01_r8) +! +! Decimal precision of cloud amount (0 -> preserve full resolution; +! 10^-n -> preserve n digits of cloud amount) +! + real(r8) cldeps + parameter (cldeps = 0.0_r8) +! +! Maximum number of configurations to include in solution +! + integer nconfgmax + parameter (nconfgmax = 15) +!------------------------------Commons---------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk,jj ! chunk identifier + integer, intent(in) :: pcols, pver, pverp + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure + real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure + real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio) + real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio + real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio + real(r8), intent(in) :: rh(pcols,pver) ! Relative humidity (fraction) +! + real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover + real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path + real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path + real(r8), intent(in) :: rel(pcols,pver) ! Liquid effective drop size (microns) + real(r8), intent(in) :: rei(pcols,pver) ! Ice effective drop size (microns) +! + real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2) + real, intent(in) :: solcon ! solar constant with eccentricity factor + real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle + real(r8), intent(in) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad + real(r8), intent(in) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad + real(r8), intent(in) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad + real(r8), intent(in) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad + + real(r8), intent(in) :: scon ! solar constant +! +! IN/OUT arguments +! + real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each +! ! maximally overlapped region. +! ! 0->pmxrgn(i,1) is range of pressure for +! ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for +! ! 2nd region, etc + integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions +! +! Output arguments +! + + real(r8), intent(out) :: solin(pcols) ! Incident solar flux + real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate + real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux + real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux + real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface +! + real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux + real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx + real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA + real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7) + real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7) + real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7) + real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7) + real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa + real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns + real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth + real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth + +! Added downward/upward total and clear sky fluxes + real(r8), intent(out) :: fsup(pcols,pverp) ! Total sky upward solar flux (spectrally summed) + real(r8), intent(out) :: fsupc(pcols,pverp) ! Clear sky upward solar flux (spectrally summed) + real(r8), intent(out) :: fsdn(pcols,pverp) ! Total sky downward solar flux (spectrally summed) + real(r8), intent(out) :: fsdnc(pcols,pverp) ! Clear sky downward solar flux (spectrally summed) +! + real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns + real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth + real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo + real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter + real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering +! real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth +! real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo +! real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter +! real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering +! +!---------------------------Local variables----------------------------- +! +! Max/random overlap variables +! + real(r8) asort(pverp) ! 1 - cloud amounts to be sorted for max ovrlp. + real(r8) atmp ! Temporary storage for sort when nxs = 2 + real(r8) cld0 ! 1 - (cld amt) used to make wstr, cstr, nstr + real(r8) totwgt ! Total of xwgts = total fractional area of +! grid-box covered by cloud configurations +! included in solution to fluxes + + real(r8) wgtv(nconfgmax) ! Weights for fluxes +! 1st index is configuration number + real(r8) wstr(pverp,pverp) ! area weighting factors for streams +! 1st index is for stream #, +! 2nd index is for region # + + real(r8) xexpt ! solar direct beam trans. for layer above + real(r8) xrdnd ! diffuse reflectivity for layer above + real(r8) xrupd ! diffuse reflectivity for layer below + real(r8) xrups ! direct-beam reflectivity for layer below + real(r8) xtdnt ! total trans for layers above + + real(r8) xwgt ! product of cloud amounts + + real(r8) yexpt ! solar direct beam trans. for layer above + real(r8) yrdnd ! diffuse reflectivity for layer above + real(r8) yrupd ! diffuse reflectivity for layer below + real(r8) ytdnd ! dif-beam transmission for layers above + real(r8) ytupd ! dif-beam transmission for layers below + + real(r8) zexpt ! solar direct beam trans. for layer above + real(r8) zrdnd ! diffuse reflectivity for layer above + real(r8) zrupd ! diffuse reflectivity for layer below + real(r8) zrups ! direct-beam reflectivity for layer below + real(r8) ztdnt ! total trans for layers above + + logical new_term ! Flag for configurations to include in fluxes + logical region_found ! flag for identifying regions + + integer ccon(0:pverp,nconfgmax) +! flags for presence of clouds +! 1st index is for level # (including +! layer above top of model and at surface) +! 2nd index is for configuration # + integer cstr(0:pverp,pverp) +! flags for presence of clouds +! 1st index is for level # (including +! layer above top of model and at surface) +! 2nd index is for stream # + integer icond(0:pverp,nconfgmax) +! Indices for copying rad. properties from +! one identical downward cld config. +! to another in adding method (step 2) +! 1st index is for interface # (including +! layer above top of model and at surface) +! 2nd index is for configuration # range + integer iconu(0:pverp,nconfgmax) +! Indices for copying rad. properties from +! one identical upward configuration +! to another in adding method (step 2) +! 1st index is for interface # (including +! layer above top of model and at surface) +! 2nd index is for configuration # range + integer iconfig ! Counter for random-ovrlap configurations + integer irgn ! Index for max-overlap regions + integer is0 ! Lower end of stream index range + integer is1 ! Upper end of stream index range + integer isn ! Stream index + integer istr(pverp+1) ! index for stream #s during flux calculation + integer istrtd(0:pverp,0:nconfgmax+1) +! indices into icond +! 1st index is for interface # (including +! layer above top of model and at surface) +! 2nd index is for configuration # range + integer istrtu(0:pverp,0:nconfgmax+1) +! indices into iconu +! 1st index is for interface # (including +! layer above top of model and at surface) +! 2nd index is for configuration # range + integer j ! Configuration index + integer k1 ! Level index + integer k2 ! Level index + integer ksort(pverp) ! Level indices of cloud amounts to be sorted + integer ktmp ! Temporary storage for sort when nxs = 2 + integer kx1(0:pverp) ! Level index for top of max-overlap region + integer kx2(0:pverp) ! Level index for bottom of max-overlap region + integer l ! Index + integer l0 ! Index + integer mrgn ! Counter for nrgn + integer mstr ! Counter for nstr + integer n0 ! Number of configurations with ccon(k,:)==0 + integer n1 ! Number of configurations with ccon(k,:)==1 + integer nconfig ! Number of random-ovrlap configurations + integer nconfigm ! Value of config before testing for areamin, +! nconfgmax + integer npasses ! number of passes over the indexing loop + integer nrgn ! Number of max overlap regions at current +! longitude + integer nstr(pverp) ! Number of unique cloud configurations +! ("streams") in a max-overlapped region +! 1st index is for region # + integer nuniq ! # of unique cloud configurations + integer nuniqd(0:pverp) ! # of unique cloud configurations: TOA +! to level k + integer nuniqu(0:pverp) ! # of unique cloud configurations: surface +! to level k + integer nxs ! Number of cloudy layers between k1 and k2 + integer ptr0(nconfgmax) ! Indices of configurations with ccon(k,:)==0 + integer ptr1(nconfgmax) ! Indices of configurations with ccon(k,:)==1 + integer ptrc(nconfgmax) ! Pointer for configurations sorted by wgtv +! integer findvalue ! Function for finding kth smallest element +! in a vector +! external findvalue + +! +! Other +! + integer ns ! Spectral loop index + integer i ! Longitude loop index + integer k ! Level loop index + integer km1 ! k - 1 + integer kp1 ! k + 1 + integer n ! Loop index for daylight + integer ndayc ! Number of daylight columns + integer idayc(pcols) ! Daytime column indices + integer indxsl ! Index for cloud particle properties + integer ksz ! dust size bin index + integer krh ! relative humidity bin index + integer kaer ! aerosol group index + real(r8) wrh ! weight for linear interpolation between lut points + real(r8) :: rhtrunc ! rh, truncated for the purposes of extrapolating + ! aerosol optical properties +! +! A. Slingo's data for cloud particle radiative properties (from 'A GCM +! Parameterization for the Shortwave Properties of Water Clouds' JAS +! vol. 46 may 1989 pp 1419-1427) +! + real(r8) abarl(4) ! A coefficient for extinction optical depth + real(r8) bbarl(4) ! B coefficient for extinction optical depth + real(r8) cbarl(4) ! C coefficient for single scat albedo + real(r8) dbarl(4) ! D coefficient for single scat albedo + real(r8) ebarl(4) ! E coefficient for asymmetry parameter + real(r8) fbarl(4) ! F coefficient for asymmetry parameter + + save abarl, bbarl, cbarl, dbarl, ebarl, fbarl + + data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/ + data bbarl/ 1.305 , 1.346 ,1.454 ,1.641 / + data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201 / + data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 / + data ebarl/ 0.829 , 0.794 ,0.754 ,0.826 / + data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/ + + real(r8) abarli ! A coefficient for current spectral band + real(r8) bbarli ! B coefficient for current spectral band + real(r8) cbarli ! C coefficient for current spectral band + real(r8) dbarli ! D coefficient for current spectral band + real(r8) ebarli ! E coefficient for current spectral band + real(r8) fbarli ! F coefficient for current spectral band +! +! Caution... A. Slingo recommends no less than 4.0 micro-meters nor +! greater than 20 micro-meters +! +! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) +! + real(r8) abari(4) ! a coefficient for extinction optical depth + real(r8) bbari(4) ! b coefficient for extinction optical depth + real(r8) cbari(4) ! c coefficient for single scat albedo + real(r8) dbari(4) ! d coefficient for single scat albedo + real(r8) ebari(4) ! e coefficient for asymmetry parameter + real(r8) fbari(4) ! f coefficient for asymmetry parameter + + save abari, bbari, cbari, dbari, ebari, fbari + + data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/ + data bbari/ 2.431 , 2.431 ,2.431 ,2.431 / + data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658 / + data dbari/ 0.0 , 1.405e-05,8.328e-04,2.05e-05 / + data ebari/ 0.7661 , 0.7730 ,0.794 ,0.9595 / + data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/ + + real(r8) abarii ! A coefficient for current spectral band + real(r8) bbarii ! B coefficient for current spectral band + real(r8) cbarii ! C coefficient for current spectral band + real(r8) dbarii ! D coefficient for current spectral band + real(r8) ebarii ! E coefficient for current spectral band + real(r8) fbarii ! F coefficient for current spectral band +! + real(r8) delta ! Pressure (in atm) for stratos. h2o limit + real(r8) o2mmr ! O2 mass mixing ratio: + + save delta, o2mmr + +! +! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4 +! + data delta / 0.0014257179260883 / +! +! END UPDATE +! + data o2mmr / .23143 / + + real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad + real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad +! +! Next series depends on spectral interval +! + real(r8) frcsol(nspint) ! Fraction of solar flux in spectral interval + real(r8) wavmin(nspint) ! Min wavelength (micro-meters) of interval + real(r8) wavmax(nspint) ! Max wavelength (micro-meters) of interval + real(r8) raytau(nspint) ! Rayleigh scattering optical depth + real(r8) abh2o(nspint) ! Absorption coefficiant for h2o (cm2/g) + real(r8) abo3 (nspint) ! Absorption coefficiant for o3 (cm2/g) + real(r8) abco2(nspint) ! Absorption coefficiant for co2 (cm2/g) + real(r8) abo2 (nspint) ! Absorption coefficiant for o2 (cm2/g) + real(r8) ph2o(nspint) ! Weight of h2o in spectral interval + real(r8) pco2(nspint) ! Weight of co2 in spectral interval + real(r8) po2 (nspint) ! Weight of o2 in spectral interval + real(r8) nirwgt(nspint) ! Spectral Weights to simulate Nimbus-7 filter + real(r8) wgtint ! Weight for specific spectral interval + + save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , & + abco2 ,abo2 ,ph2o ,pco2 ,po2 ,nirwgt + + data frcsol / .001488, .001389, .001290, .001686, .002877, & + .003869, .026336, .360739, .065392, .526861, & + .526861, .526861, .526861, .526861, .526861, & + .526861, .006239, .001834, .001834/ +! +! weight for 0.64 - 0.7 microns appropriate to clear skies over oceans +! + data nirwgt / 0.0, 0.0, 0.0, 0.0, 0.0, & + 0.0, 0.0, 0.0, 0.320518, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0 / + + data wavmin / .200, .245, .265, .275, .285, & + .295, .305, .350, .640, .700, .701, & + .701, .701, .701, .702, .702, & + 2.630, 4.160, 4.160/ + + data wavmax / .245, .265, .275, .285, .295, & + .305, .350, .640, .700, 5.000, 5.000, & + 5.000, 5.000, 5.000, 5.000, 5.000, & + 2.860, 4.550, 4.550/ + +! +! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4 +! + data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, & + 1.085, 0.730, v_raytau_35, v_raytau_64, & + 0.02899756, 0.01356763, 0.00537341, & + 0.00228515, 0.00105028, 0.00046631, & + 0.00025734, & + .0001, .0001, .0001/ +! +! END UPDATE +! + +! +! Absorption coefficients +! +! +! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4 +! + data abh2o / .000, .000, .000, .000, .000, & + .000, .000, .000, .000, & + 0.00256608, 0.06310504, 0.42287445, 2.45397941, & + 11.20070807, 47.66091389, 240.19010243, & + .000, .000, .000/ +! +! END UPDATE +! + + data abo3 /5.370e+04, 13.080e+04, 9.292e+04, 4.530e+04, 1.616e+04, & + 4.441e+03, 1.775e+02, v_abo3_35, v_abo3_64, .000, & + .000, .000 , .000 , .000 , .000, & + .000, .000 , .000 , .000 / + + data abco2 / .000, .000, .000, .000, .000, & + .000, .000, .000, .000, .000, & + .000, .000, .000, .000, .000, & + .000, .094, .196, 1.963/ + + data abo2 / .000, .000, .000, .000, .000, & + .000, .000, .000,1.11e-05,6.69e-05, & + .000, .000, .000, .000, .000, & + .000, .000, .000, .000/ +! +! Spectral interval weights +! + data ph2o / .000, .000, .000, .000, .000, & + .000, .000, .000, .000, .505, & + .210, .120, .070, .048, .029, & + .018, .000, .000, .000/ + + data pco2 / .000, .000, .000, .000, .000, & + .000, .000, .000, .000, .000, & + .000, .000, .000, .000, .000, & + .000, 1.000, .640, .360/ + + data po2 / .000, .000, .000, .000, .000, & + .000, .000, .000, 1.000, 1.000, & + .000, .000, .000, .000, .000, & + .000, .000, .000, .000/ +! +! Diagnostic and accumulation arrays; note that sfltot, fswup, and +! fswdn are not used in the computation,but are retained for future use. +! + real(r8) solflx ! Solar flux in current interval + real(r8) sfltot ! Spectrally summed total solar flux + real(r8) totfld(0:pver) ! Spectrally summed flux divergence + real(r8) fswup(0:pverp) ! Spectrally summed up flux + real(r8) fswdn(0:pverp) ! Spectrally summed down flux + real(r8) fswupc(0:pverp) ! Spectrally summed up clear sky flux + real(r8) fswdnc(0:pverp) ! Spectrally summed down clear sky flux +! +! Cloud radiative property arrays +! +! real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth +! real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth + real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo + real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter + real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction + real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo + real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter + real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction +! +! Aerosol mass paths by species +! + real(r8) usul(pcols,pver) ! sulfate (SO4) + real(r8) ubg(pcols,pver) ! background aerosol + real(r8) usslt(pcols,pver) ! sea-salt (SSLT) + real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI) + real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO) + real(r8) ucb(pcols,pver) ! black carbon (BCPHI + BCPHO) + real(r8) uvolc(pcols,pver) ! volcanic mass + real(r8) udst(ndstsz,pcols,pver) ! dust + +! +! local variables used for the external mixing of aerosol species +! + real(r8) tau_sul ! optical depth, sulfate + real(r8) tau_bg ! optical depth, background aerosol + real(r8) tau_sslt ! optical depth, sea-salt + real(r8) tau_cphil ! optical depth, hydrophilic carbon + real(r8) tau_cphob ! optical depth, hydrophobic carbon + real(r8) tau_cb ! optical depth, black carbon + real(r8) tau_volc ! optical depth, volcanic + real(r8) tau_dst(ndstsz) ! optical depth, dust, by size category + real(r8) tau_dst_tot ! optical depth, total dust + real(r8) tau_tot ! optical depth, total aerosol + + real(r8) tau_w_sul ! optical depth * single scattering albedo, sulfate + real(r8) tau_w_bg ! optical depth * single scattering albedo, background aerosol + real(r8) tau_w_sslt ! optical depth * single scattering albedo, sea-salt + real(r8) tau_w_cphil ! optical depth * single scattering albedo, hydrophilic carbon + real(r8) tau_w_cphob ! optical depth * single scattering albedo, hydrophobic carbon + real(r8) tau_w_cb ! optical depth * single scattering albedo, black carbon + real(r8) tau_w_volc ! optical depth * single scattering albedo, volcanic + real(r8) tau_w_dst(ndstsz) ! optical depth * single scattering albedo, dust, by size + real(r8) tau_w_dst_tot ! optical depth * single scattering albedo, total dust + real(r8) tau_w_tot ! optical depth * single scattering albedo, total aerosol + + real(r8) tau_w_g_sul ! optical depth * single scattering albedo * asymmetry parameter, sulfate + real(r8) tau_w_g_bg ! optical depth * single scattering albedo * asymmetry parameter, background aerosol + real(r8) tau_w_g_sslt ! optical depth * single scattering albedo * asymmetry parameter, sea-salt + real(r8) tau_w_g_cphil ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon + real(r8) tau_w_g_cphob ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon + real(r8) tau_w_g_cb ! optical depth * single scattering albedo * asymmetry parameter, black carbon + real(r8) tau_w_g_volc ! optical depth * single scattering albedo * asymmetry parameter, volcanic + real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size + real(r8) tau_w_g_dst_tot ! optical depth * single scattering albedo * asymmetry parameter, total dust + real(r8) tau_w_g_tot ! optical depth * single scattering albedo * asymmetry parameter, total aerosol + + real(r8) f_sul ! forward scattering fraction, sulfate + real(r8) f_bg ! forward scattering fraction, background aerosol + real(r8) f_sslt ! forward scattering fraction, sea-salt + real(r8) f_cphil ! forward scattering fraction, hydrophilic carbon + real(r8) f_cphob ! forward scattering fraction, hydrophobic carbon + real(r8) f_cb ! forward scattering fraction, black carbon + real(r8) f_volc ! forward scattering fraction, volcanic + real(r8) f_dst(ndstsz) ! forward scattering fraction, dust, by size + real(r8) f_dst_tot ! forward scattering fraction, total dust + real(r8) f_tot ! forward scattering fraction, total aerosol + + real(r8) tau_w_f_sul ! optical depth * forward scattering fraction * single scattering albedo, sulfate + real(r8) tau_w_f_bg ! optical depth * forward scattering fraction * single scattering albedo, background + real(r8) tau_w_f_sslt ! optical depth * forward scattering fraction * single scattering albedo, sea-salt + real(r8) tau_w_f_cphil ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C + real(r8) tau_w_f_cphob ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C + real(r8) tau_w_f_cb ! optical depth * forward scattering fraction * single scattering albedo, black C + real(r8) tau_w_f_volc ! optical depth * forward scattering fraction * single scattering albedo, volcanic + real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size + real(r8) tau_w_f_dst_tot ! optical depth * forward scattering fraction * single scattering albedo, total dust + real(r8) tau_w_f_tot ! optical depth * forward scattering fraction * single scattering albedo, total aerosol + real(r8) w_dst_tot ! single scattering albedo, total dust + real(r8) w_tot ! single scattering albedo, total aerosol + real(r8) g_dst_tot ! asymmetry parameter, total dust + real(r8) g_tot ! asymmetry parameter, total aerosol + real(r8) ksuli ! specific extinction interpolated between rh look-up-table points, sulfate + real(r8) ksslti ! specific extinction interpolated between rh look-up-table points, sea-salt + real(r8) kcphili ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon + real(r8) wsuli ! single scattering albedo interpolated between rh look-up-table points, sulfate + real(r8) wsslti ! single scattering albedo interpolated between rh look-up-table points, sea-salt + real(r8) wcphili ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon + real(r8) gsuli ! asymmetry parameter interpolated between rh look-up-table points, sulfate + real(r8) gsslti ! asymmetry parameter interpolated between rh look-up-table points, sea-salt + real(r8) gcphili ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon +! +! Aerosol radiative property arrays +! + real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth + real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo + real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter + real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction + +! +! Various arrays and other constants: +! + real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer + real(r8) zenfac(pcols) ! Square root of cos solar zenith angle + real(r8) sqrco2 ! Square root of the co2 mass mixg ratio + real(r8) tmp1 ! Temporary constant array + real(r8) tmp2 ! Temporary constant array + real(r8) pdel ! Pressure difference across layer + real(r8) path ! Mass path of layer + real(r8) ptop ! Lower interface pressure of extra layer + real(r8) ptho2 ! Used to compute mass path of o2 + real(r8) ptho3 ! Used to compute mass path of o3 + real(r8) pthco2 ! Used to compute mass path of co2 + real(r8) pthh2o ! Used to compute mass path of h2o + real(r8) h2ostr ! Inverse sq. root h2o mass mixing ratio + real(r8) wavmid(nspint) ! Spectral interval middle wavelength + real(r8) trayoslp ! Rayleigh optical depth/standard pressure + real(r8) tmp1l ! Temporary constant array + real(r8) tmp2l ! Temporary constant array + real(r8) tmp3l ! Temporary constant array + real(r8) tmp1i ! Temporary constant array + real(r8) tmp2i ! Temporary constant array + real(r8) tmp3i ! Temporary constant array + real(r8) rdenom ! Multiple scattering term + real(r8) rdirexp ! layer direct ref times exp transmission + real(r8) tdnmexp ! total transmission - exp transmission + real(r8) psf(nspint) ! Frac of solar flux in spect interval +! +! Layer absorber amounts; note that 0 refers to the extra layer added +! above the top model layer +! + real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o + real(r8) uo3(pcols,0:pver) ! Layer absorber amount of o3 + real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2 + real(r8) uo2(pcols,0:pver) ! Layer absorber amount of o2 + real(r8) uaer(pcols,0:pver) ! Layer aerosol amount +! +! Total column absorber amounts: +! + real(r8) uth2o(pcols) ! Total column absorber amount of h2o + real(r8) uto3(pcols) ! Total column absorber amount of o3 + real(r8) utco2(pcols) ! Total column absorber amount of co2 + real(r8) uto2(pcols) ! Total column absorber amount of o2 +! +! These arrays are defined for pver model layers; 0 refers to the extra +! layer on top: +! + real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad + real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad + real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad + real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad + real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer + + real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad + real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad + real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad + real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad + real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer + + real(r8) flxdiv ! Flux divergence for layer +! +! +! Radiative Properties: +! +! There are 1 classes of properties: +! (1. All-sky bulk properties +! (2. Clear-sky properties +! +! The first set of properties are generated during step 2 of the solution. +! +! These arrays are defined at model interfaces; in 1st index (for level #), +! 0 is the top of the extra layer above the model top, and +! pverp is the earth surface. 2nd index is for cloud configuration +! defined over a whole column. +! + real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above + real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above + real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below + real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below + real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above +! +! Bulk properties used during the clear-sky calculation. +! + real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above + real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above + real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below + real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below + real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above + + real(r8) fluxup(0:pverp) ! Up flux at model interface + real(r8) fluxdn(0:pverp) ! Down flux at model interface + real(r8) wexptdn ! Direct solar beam trans. to surface + +! +!----------------------------------------------------------------------- +! START OF CALCULATION +!----------------------------------------------------------------------- +! +! write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk + + do i=1, ncol +! +! Initialize output fields: +! + fsds(i) = 0.0_r8 + + fsnirtoa(i) = 0.0_r8 + fsnrtoac(i) = 0.0_r8 + fsnrtoaq(i) = 0.0_r8 + + fsns(i) = 0.0_r8 + fsnsc(i) = 0.0_r8 + fsdsc(i) = 0.0_r8 + + fsnt(i) = 0.0_r8 + fsntc(i) = 0.0_r8 + fsntoa(i) = 0.0_r8 + fsntoac(i) = 0.0_r8 + + solin(i) = 0.0_r8 + + sols(i) = 0.0_r8 + soll(i) = 0.0_r8 + solsd(i) = 0.0_r8 + solld(i) = 0.0_r8 + +! initialize added downward/upward total and clear sky fluxes + + do k=1,pverp + fsup(i,k) = 0.0_r8 + fsupc(i,k) = 0.0_r8 + fsdn(i,k) = 0.0_r8 + fsdnc(i,k) = 0.0_r8 + tauxcl(i,k-1) = 0.0_r8 + tauxci(i,k-1) = 0.0_r8 + end do + + do k=1, pver + qrs(i,k) = 0.0_r8 + end do + + ! initialize aerosol diagnostic fields to 0.0 + ! Average can be obtained by dividing / + do kaer = 1, naer_groups + do ns = 1, nspint + frc_day(i) = 0.0_r8 + aertau(i,ns,kaer) = 0.0_r8 + aerssa(i,ns,kaer) = 0.0_r8 + aerasm(i,ns,kaer) = 0.0_r8 + aerfwd(i,ns,kaer) = 0.0_r8 + end do + end do + + end do +! +! Compute starting, ending daytime loop indices: +! *** Note this logic assumes day and night points are contiguous so +! *** will not work in general with chunked data structure. +! + ndayc = 0 + do i=1,ncol + if (coszrs(i) > 0.0_r8) then + ndayc = ndayc + 1 + idayc(ndayc) = i + end if + end do +! +! If night everywhere, return: +! + if (ndayc == 0) return +! +! Perform other initializations +! + tmp1 = 0.5_r8/(gravit*sslp) + tmp2 = delta/gravit + sqrco2 = sqrt(co2mmr) + + do n=1,ndayc + i=idayc(n) +! +! Define solar incident radiation and interface pressures: +! +! solin(i) = scon*eccf*coszrs(i) +!WRF use SOLCON (MKS) calculated outside + solin(i) = solcon*coszrs(i)*1000. + pflx(i,0) = 0._r8 + do k=1,pverp + pflx(i,k) = pint(i,k) + end do +! +! Compute optical paths: +! + ptop = pflx(i,1) + ptho2 = o2mmr * ptop / gravit + ptho3 = o3mmr(i,1) * ptop / gravit + pthco2 = sqrco2 * (ptop / gravit) + h2ostr = sqrt( 1._r8 / h2ommr(i,1) ) + zenfac(i) = sqrt(coszrs(i)) + pthh2o = ptop**2*tmp1 + (ptop*rga)* & + (h2ostr*zenfac(i)*delta) + uh2o(i,0) = h2ommr(i,1)*pthh2o + uco2(i,0) = zenfac(i)*pthco2 + uo2 (i,0) = zenfac(i)*ptho2 + uo3 (i,0) = ptho3 + uaer(i,0) = 0.0_r8 + do k=1,pver + pdel = pflx(i,k+1) - pflx(i,k) + path = pdel / gravit + ptho2 = o2mmr * path + ptho3 = o3mmr(i,k) * path + pthco2 = sqrco2 * path + h2ostr = sqrt(1.0_r8/h2ommr(i,k)) + pthh2o = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2 + uh2o(i,k) = h2ommr(i,k)*pthh2o + uco2(i,k) = zenfac(i)*pthco2 + uo2 (i,k) = zenfac(i)*ptho2 + uo3 (i,k) = ptho3 + usul(i,k) = aermmr(i,k,idxSUL) * path + ubg(i,k) = aermmr(i,k,idxBG) * path + usslt(i,k) = aermmr(i,k,idxSSLT) * path + if (usslt(i,k) .lt. 0.0) then ! usslt is sometimes small and negative, will be fixed + usslt(i,k) = 0.0 + end if + ucphil(i,k) = aermmr(i,k,idxOCPHI) * path + ucphob(i,k) = aermmr(i,k,idxOCPHO) * path + ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path + uvolc(i,k) = aermmr(i,k,idxVOLC) + do ksz = 1, ndstsz + udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path + end do + end do +! +! Compute column absorber amounts for the clear sky computation: +! + uth2o(i) = 0.0_r8 + uto3(i) = 0.0_r8 + utco2(i) = 0.0_r8 + uto2(i) = 0.0_r8 + + do k=1,pver + uth2o(i) = uth2o(i) + uh2o(i,k) + uto3(i) = uto3(i) + uo3(i,k) + utco2(i) = utco2(i) + uco2(i,k) + uto2(i) = uto2(i) + uo2(i,k) + end do +! +! Set cloud properties for top (0) layer; so long as tauxcl is zero, +! there is no cloud above top of model; the other cloud properties +! are arbitrary: +! + tauxcl(i,0) = 0._r8 + wcl(i,0) = 0.999999_r8 + gcl(i,0) = 0.85_r8 + fcl(i,0) = 0.725_r8 + tauxci(i,0) = 0._r8 + wci(i,0) = 0.999999_r8 + gci(i,0) = 0.85_r8 + fci(i,0) = 0.725_r8 +! +! Aerosol +! + tauxar(i,0) = 0._r8 + wa(i,0) = 0.925_r8 + ga(i,0) = 0.850_r8 + fa(i,0) = 0.7225_r8 +! +! End do n=1,ndayc +! + end do +! +! Begin spectral loop +! + do ns=1,nspint +! +! Set index for cloud particle properties based on the wavelength, +! according to A. Slingo (1989) equations 1-3: +! Use index 1 (0.25 to 0.69 micrometers) for visible +! Use index 2 (0.69 - 1.19 micrometers) for near-infrared +! Use index 3 (1.19 to 2.38 micrometers) for near-infrared +! Use index 4 (2.38 to 4.00 micrometers) for near-infrared +! +! Note that the minimum wavelength is encoded (with .001, .002, .003) +! in order to specify the index appropriate for the near-infrared +! cloud absorption properties +! + if(wavmax(ns) <= 0.7_r8) then + indxsl = 1 + else if(wavmin(ns) == 0.700_r8) then + indxsl = 2 + else if(wavmin(ns) == 0.701_r8) then + indxsl = 3 + else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then + indxsl = 4 + end if +! +! Set cloud extinction optical depth, single scatter albedo, +! asymmetry parameter, and forward scattered fraction: +! + abarli = abarl(indxsl) + bbarli = bbarl(indxsl) + cbarli = cbarl(indxsl) + dbarli = dbarl(indxsl) + ebarli = ebarl(indxsl) + fbarli = fbarl(indxsl) +! + abarii = abari(indxsl) + bbarii = bbari(indxsl) + cbarii = cbari(indxsl) + dbarii = dbari(indxsl) + ebarii = ebari(indxsl) + fbarii = fbari(indxsl) +! +! adjustfraction within spectral interval to allow for the possibility of +! sub-divisions within a particular interval: +! + psf(ns) = 1.0_r8 + if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns) + if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns) + if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns) + + do n=1,ndayc + i=idayc(n) + + frc_day(i) = 1.0_r8 + do kaer = 1, naer_groups + aertau(i,ns,kaer) = 0.0 + aerssa(i,ns,kaer) = 0.0 + aerasm(i,ns,kaer) = 0.0 + aerfwd(i,ns,kaer) = 0.0 + end do + + do k=1,pver +! +! liquid +! + tmp1l = abarli + bbarli/rel(i,k) + tmp2l = 1._r8 - cbarli - dbarli*rel(i,k) + tmp3l = fbarli*rel(i,k) +! +! ice +! + tmp1i = abarii + bbarii/rei(i,k) + tmp2i = 1._r8 - cbarii - dbarii*rei(i,k) + tmp3i = fbarii*rei(i,k) + + if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then + tauxcl(i,k) = cliqwp(i,k)*tmp1l + tauxci(i,k) = cicewp(i,k)*tmp1i + else + tauxcl(i,k) = 0.0 + tauxci(i,k) = 0.0 + endif +! +! Do not let single scatter albedo be 1. Delta-eddington solution +! for non-conservative case has different analytic form from solution +! for conservative case, and raddedmx is written for non-conservative case. +! + wcl(i,k) = min(tmp2l,.999999_r8) + gcl(i,k) = ebarli + tmp3l + fcl(i,k) = gcl(i,k)*gcl(i,k) +! + wci(i,k) = min(tmp2i,.999999_r8) + gci(i,k) = ebarii + tmp3i + fci(i,k) = gci(i,k)*gci(i,k) +! +! Set aerosol properties +! Conversion factor to adjust aerosol extinction (m2/g) +! + rhtrunc = rh(i,k) + rhtrunc = min(rh(i,k),1._r8) +! if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX') + krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1) + wrh = rhtrunc * nrh - krh + + ! linear interpolation of optical properties between rh table points + ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh + ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh + kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh + wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh + wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh + wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh + gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh + gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh + gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh + + tau_sul = 1.e4 * ksuli * usul(i,k) + tau_sslt = 1.e4 * ksslti * usslt(i,k) + tau_cphil = 1.e4 * kcphili * ucphil(i,k) + tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k) + tau_cb = 1.e4 * kcb(ns) * ucb(i,k) + tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k) + tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k) + tau_bg = 1.e4 * kbg(ns) * ubg(i,k) + + tau_w_sul = tau_sul * wsuli + tau_w_sslt = tau_sslt * wsslti + tau_w_cphil = tau_cphil * wcphili + tau_w_cphob = tau_cphob * wcphob(ns) + tau_w_cb = tau_cb * wcb(ns) + tau_w_volc = tau_volc * wvolc(ns) + tau_w_dst(:) = tau_dst(:) * wdst(:,ns) + tau_w_bg = tau_bg * wbg(ns) + + tau_w_g_sul = tau_w_sul * gsuli + tau_w_g_sslt = tau_w_sslt * gsslti + tau_w_g_cphil = tau_w_cphil * gcphili + tau_w_g_cphob = tau_w_cphob * gcphob(ns) + tau_w_g_cb = tau_w_cb * gcb(ns) + tau_w_g_volc = tau_w_volc * gvolc(ns) + tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns) + tau_w_g_bg = tau_w_bg * gbg(ns) + + f_sul = gsuli * gsuli + f_sslt = gsslti * gsslti + f_cphil = gcphili * gcphili + f_cphob = gcphob(ns) * gcphob(ns) + f_cb = gcb(ns) * gcb(ns) + f_volc = gvolc(ns) * gvolc(ns) + f_dst(:) = gdst(:,ns) * gdst(:,ns) + f_bg = gbg(ns) * gbg(ns) + + tau_w_f_sul = tau_w_sul * f_sul + tau_w_f_bg = tau_w_bg * f_bg + tau_w_f_sslt = tau_w_sslt * f_sslt + tau_w_f_cphil = tau_w_cphil * f_cphil + tau_w_f_cphob = tau_w_cphob * f_cphob + tau_w_f_cb = tau_w_cb * f_cb + tau_w_f_volc = tau_w_volc * f_volc + tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:) +! +! mix dust aerosol size bins +! w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere +! but calculate them anyway for future use +! + tau_dst_tot = sum(tau_dst) + tau_w_dst_tot = sum(tau_w_dst) + tau_w_g_dst_tot = sum(tau_w_g_dst) + tau_w_f_dst_tot = sum(tau_w_f_dst) + + if (tau_dst_tot .gt. 0.0) then + w_dst_tot = tau_w_dst_tot / tau_dst_tot + else + w_dst_tot = 0.0 + endif + + if (tau_w_dst_tot .gt. 0.0) then + g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot + f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot + else + g_dst_tot = 0.0 + f_dst_tot = 0.0 + endif +! +! mix aerosols +! + tau_tot = tau_sul + tau_sslt & + + tau_cphil + tau_cphob + tau_cb + tau_dst_tot + tau_tot = tau_tot + tau_bg + tau_volc + + tau_w_tot = tau_w_sul + tau_w_sslt & + + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot + tau_w_tot = tau_w_tot + tau_w_bg + tau_w_volc + + tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt & + + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot + tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc + + tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt & + + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot + tau_w_f_tot = tau_w_f_tot + tau_w_f_bg + tau_w_f_volc + + if (tau_tot .gt. 0.0) then + w_tot = tau_w_tot / tau_tot + else + w_tot = 0.0 + endif + + if (tau_w_tot .gt. 0.0) then + g_tot = tau_w_g_tot / tau_w_tot + f_tot = tau_w_f_tot / tau_w_tot + else + g_tot = 0.0 + f_tot = 0.0 + endif + + tauxar(i,k) = tau_tot + wa(i,k) = min(w_tot, 0.999999_r8) + if (g_tot.gt.1._r8) write(6,*) "g_tot > 1" + if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1" +! if (g_tot.gt.1._r8) call endrun ('RADCSWMX') +! if (g_tot.lt.-1._r8) call endrun ('RADCSWMX') + ga(i,k) = g_tot + if (f_tot.gt.1._r8) write(6,*)"f_tot > 1" + if (f_tot.lt.0._r8) write(6,*)"f_tot < 0" +! if (f_tot.gt.1._r8) call endrun ('RADCSWMX') +! if (f_tot.lt.0._r8) call endrun ('RADCSWMX') + fa(i,k) = f_tot + + aertau(i,ns,1) = aertau(i,ns,1) + tau_sul + aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt + aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb + aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot + aertau(i,ns,5) = aertau(i,ns,5) + tau_bg + aertau(i,ns,6) = aertau(i,ns,6) + tau_volc + aertau(i,ns,7) = aertau(i,ns,7) + tau_tot + + aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul + aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt + aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb + aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot + aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg + aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc + aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot + + aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul + aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt + aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot + aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg + aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc + aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot + + aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul + aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt + aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot + aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg + aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc + aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot + +! +! End do k=1,pver +! + end do + + ! normalize aerosol optical diagnostic fields + do kaer = 1, naer_groups + + if (aerssa(i,ns,kaer) .gt. 0.0) then ! aerssa currently holds product of tau and ssa + aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer) + aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer) + else + aerasm(i,ns,kaer) = 0.0_r8 + aerfwd(i,ns,kaer) = 0.0_r8 + end if + + if (aertau(i,ns,kaer) .gt. 0.0) then + aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer) + else + aerssa(i,ns,kaer) = 0.0_r8 + end if + + end do + + +! +! End do n=1,ndayc +! + end do + +! +! Set reflectivities for surface based on mid-point wavelength +! + wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns)) +! +! Wavelength less than 0.7 micro-meter +! + if (wavmid(ns) < 0.7_r8 ) then + do n=1,ndayc + i=idayc(n) + albdir(i,ns) = asdir(i) + albdif(i,ns) = asdif(i) + end do +! +! Wavelength greater than 0.7 micro-meter +! + else + do n=1,ndayc + i=idayc(n) + albdir(i,ns) = aldir(i) + albdif(i,ns) = aldif(i) + end do + end if + trayoslp = raytau(ns)/sslp +! +! Layer input properties now completely specified; compute the +! delta-Eddington solution reflectivities and transmissivities +! for each layer +! + call raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc , & + abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , & + uh2o ,uo3 ,uco2 ,uo2 , & + trayoslp ,pflx ,ns , & + tauxcl ,wcl ,gcl ,fcl , & + tauxci ,wci ,gci ,fci , & + tauxar ,wa ,ga ,fa , & + rdir ,rdif ,tdir ,tdif ,explay , & + rdirc ,rdifc ,tdirc ,tdifc ,explayc ) +! +! End spectral loop +! + end do +! +!---------------------------------------------------------------------- +! +! Solution for max/random cloud overlap. +! +! Steps: +! (1. delta-Eddington solution for each layer (called above) +! +! (2. The adding method is used to +! compute the reflectivity and transmissivity to direct and diffuse +! radiation from the top and bottom of the atmosphere for each +! cloud configuration. This calculation is based upon the +! max-random overlap assumption. +! +! (3. to solve for the fluxes, combine the +! bulk properties of the atmosphere above/below the region. +! +! Index calculations for steps 2-3 are performed outside spectral +! loop to avoid redundant calculations. Index calculations (with +! application of areamin & nconfgmax conditions) are performed +! first to identify the minimum subset of terms for the configurations +! satisfying the areamin & nconfgmax conditions. This minimum set is +! used to identify the corresponding minimum subset of terms in +! steps 2 and 3. +! + + do n=1,ndayc + i=idayc(n) + +!---------------------------------------------------------------------- +! INDEX CALCULATIONS FOR MAX OVERLAP +! +! The column is divided into sets of adjacent layers, called regions, +! in which the clouds are maximally overlapped. The clouds are +! randomly overlapped between different regions. The number of +! regions in a column is set by nmxrgn, and the range of pressures +! included in each region is set by pmxrgn. +! +! The following calculations determine the number of unique cloud +! configurations (assuming maximum overlap), called "streams", +! within each region. Each stream consists of a vector of binary +! clouds (either 0 or 100% cloud cover). Over the depth of the region, +! each stream requires a separate calculation of radiative properties. These +! properties are generated using the adding method from +! the radiative properties for each layer calculated by raddedmx. +! +! The upward and downward-propagating streams are treated +! separately. +! +! We will refer to a particular configuration of binary clouds +! within a single max-overlapped region as a "stream". We will +! refer to a particular arrangement of binary clouds over the entire column +! as a "configuration". +! +! This section of the code generates the following information: +! (1. nrgn : the true number of max-overlap regions (need not = nmxrgn) +! (2. nstr : the number of streams in a region (>=1) +! (3. cstr : flags for presence of clouds at each layer in each stream +! (4. wstr : the fractional horizontal area of a grid box covered +! by each stream +! (5. kx1,2 : level indices for top/bottom of each region +! +! The max-overlap calculation proceeds in 3 stages: +! (1. compute layer radiative properties in raddedmx. +! (2. combine these properties between layers +! (3. combine properties to compute fluxes at each interface. +! +! Most of the indexing information calculated here is used in steps 2-3 +! after the call to raddedmx. +! +! Initialize indices for layers to be max-overlapped +! +! Loop to handle fix in totwgt=0. For original overlap config +! from npasses = 0. +! + npasses = 0 + do + do irgn = 0, nmxrgn(i) + kx2(irgn) = 0 + end do + mrgn = 0 +! +! Outermost loop over regions (sets of adjacent layers) to be max overlapped +! + do irgn = 1, nmxrgn(i) +! +! Calculate min/max layer indices inside region. +! + region_found = .false. + if (kx2(irgn-1) < pver) then + k1 = kx2(irgn-1)+1 + kx1(irgn) = k1 + kx2(irgn) = k1-1 + do k2 = pver, k1, -1 + if (pmid(i,k2) <= pmxrgn(i,irgn)) then + kx2(irgn) = k2 + mrgn = mrgn+1 + region_found = .true. + exit + end if + end do + else + exit + endif + + if (region_found) then +! +! Sort cloud areas and corresponding level indices. +! + nxs = 0 + if (cldeps > 0) then + do k = k1,k2 + if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then + nxs = nxs+1 + ksort(nxs) = k +! +! We need indices for clouds in order of largest to smallest, so +! sort 1-cld in ascending order +! + asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps) + end if + end do + else + do k = k1,k2 + if (cld(i,k) >= cldmin) then + nxs = nxs+1 + ksort(nxs) = k +! +! We need indices for clouds in order of largest to smallest, so +! sort 1-cld in ascending order +! + asort(nxs) = 1.0_r8-cld(i,k) + end if + end do + endif +! +! If nxs eq 1, no need to sort. +! If nxs eq 2, sort by swapping if necessary +! If nxs ge 3, sort using local sort routine +! + if (nxs == 2) then + if (asort(2) < asort(1)) then + ktmp = ksort(1) + ksort(1) = ksort(2) + ksort(2) = ktmp + + atmp = asort(1) + asort(1) = asort(2) + asort(2) = atmp + endif + else if (nxs >= 3) then + call sortarray(nxs,asort,ksort) + endif +! +! Construct wstr, cstr, nstr for this region +! + cstr(k1:k2,1:nxs+1) = 0 + mstr = 1 + cld0 = 0.0_r8 + do l = 1, nxs + if (asort(l) /= cld0) then + wstr(mstr,mrgn) = asort(l) - cld0 + cld0 = asort(l) + mstr = mstr + 1 + endif + cstr(ksort(l),mstr:nxs+1) = 1 + end do + nstr(mrgn) = mstr + wstr(mstr,mrgn) = 1.0_r8 - cld0 +! +! End test of region_found = true +! + endif +! +! End loop over regions irgn for max-overlap +! + end do + nrgn = mrgn +! +! Finish construction of cstr for additional top layer +! + cstr(0,1:nstr(1)) = 0 +! +! INDEX COMPUTATIONS FOR STEP 2-3 +! This section of the code generates the following information: +! (1. totwgt step 3 total frac. area of configurations satisfying +! areamin & nconfgmax criteria +! (2. wgtv step 3 frac. area of configurations +! (3. ccon step 2 binary flag for clouds in each configuration +! (4. nconfig steps 2-3 number of configurations +! (5. nuniqu/d step 2 Number of unique cloud configurations for +! up/downwelling rad. between surface/TOA +! and level k +! (6. istrtu/d step 2 Indices into iconu/d +! (7. iconu/d step 2 Cloud configurations which are identical +! for up/downwelling rad. between surface/TOA +! and level k +! +! Number of configurations (all permutations of streams in each region) +! + nconfigm = product(nstr(1: nrgn)) +! +! Construction of totwgt, wgtv, ccon, nconfig +! + istr(1: nrgn) = 1 + nconfig = 0 + totwgt = 0.0_r8 + new_term = .true. + do iconfig = 1, nconfigm + xwgt = 1.0_r8 + do mrgn = 1, nrgn + xwgt = xwgt * wstr(istr(mrgn),mrgn) + end do + if (xwgt >= areamin) then + nconfig = nconfig + 1 + if (nconfig <= nconfgmax) then + j = nconfig + ptrc(nconfig) = nconfig + else + nconfig = nconfgmax + if (new_term) then + j = findvalue(1,nconfig,wgtv,ptrc) + endif + if (wgtv(j) < xwgt) then + totwgt = totwgt - wgtv(j) + new_term = .true. + else + new_term = .false. + endif + endif + if (new_term) then + wgtv(j) = xwgt + totwgt = totwgt + xwgt + do mrgn = 1, nrgn + ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn)) + end do + endif + endif + + mrgn = nrgn + istr(mrgn) = istr(mrgn) + 1 + do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1) + istr(mrgn) = 1 + mrgn = mrgn - 1 + istr(mrgn) = istr(mrgn) + 1 + end do +! +! End do iconfig = 1, nconfigm +! + end do +! +! If totwgt = 0 implement maximum overlap and make another pass +! if totwgt = 0 on this second pass then terminate. +! + if (totwgt > 0.) then + exit + else + npasses = npasses + 1 + if (npasses >= 2 ) then + write(6,*)'RADCSWMX: Maximum overlap of column ','failed' +! call endrun + endif + nmxrgn(i)=1 + pmxrgn(i,1)=1.0e30 + end if +! +! End npasses = 0, do +! + end do +! +! +! Finish construction of ccon +! + ccon(0,:) = 0 + ccon(pverp,:) = 0 +! +! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree +! + nuniqd(0) = 1 + nuniqu(pverp) = 1 + + istrtd(0,1) = 1 + istrtu(pverp,1) = 1 + + do j = 1, nconfig + icond(0,j)=j + iconu(pverp,j)=j + end do + + istrtd(0,2) = nconfig+1 + istrtu(pverp,2) = nconfig+1 + + do k = 1, pverp + km1 = k-1 + nuniq = 0 + istrtd(k,1) = 1 + do l0 = 1, nuniqd(km1) + is0 = istrtd(km1,l0) + is1 = istrtd(km1,l0+1)-1 + n0 = 0 + n1 = 0 + do isn = is0, is1 + j = icond(km1,isn) + if (ccon(k,j) == 0) then + n0 = n0 + 1 + ptr0(n0) = j + endif + if (ccon(k,j) == 1) then + n1 = n1 + 1 + ptr1(n1) = j + endif + end do + if (n0 > 0) then + nuniq = nuniq + 1 + istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0 + icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr0(1:n0) + endif + if (n1 > 0) then + nuniq = nuniq + 1 + istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1 + icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr1(1:n1) + endif + end do + nuniqd(k) = nuniq + end do + + do k = pver, 0, -1 + kp1 = k+1 + nuniq = 0 + istrtu(k,1) = 1 + do l0 = 1, nuniqu(kp1) + is0 = istrtu(kp1,l0) + is1 = istrtu(kp1,l0+1)-1 + n0 = 0 + n1 = 0 + do isn = is0, is1 + j = iconu(kp1,isn) + if (ccon(k,j) == 0) then + n0 = n0 + 1 + ptr0(n0) = j + endif + if (ccon(k,j) == 1) then + n1 = n1 + 1 + ptr1(n1) = j + endif + end do + if (n0 > 0) then + nuniq = nuniq + 1 + istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0 + iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr0(1:n0) + endif + if (n1 > 0) then + nuniq = nuniq + 1 + istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1 + iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1) + endif + end do + nuniqu(k) = nuniq + end do +! +!---------------------------------------------------------------------- +! End of index calculations +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- +! Start of flux calculations +!---------------------------------------------------------------------- +! +! Initialize spectrally integrated totals: +! + do k=0,pver + totfld(k) = 0.0_r8 + fswup (k) = 0.0_r8 + fswdn (k) = 0.0_r8 + fswupc (k) = 0.0_r8 + fswdnc (k) = 0.0_r8 + end do + + sfltot = 0.0_r8 + fswup (pverp) = 0.0_r8 + fswdn (pverp) = 0.0_r8 + fswupc (pverp) = 0.0_r8 + fswdnc (pverp) = 0.0_r8 +! +! Start spectral interval +! + do ns = 1,nspint + wgtint = nirwgt(ns) +!---------------------------------------------------------------------- +! STEP 2 +! +! +! Apply adding method to solve for radiative properties +! +! First initialize the bulk properties at TOA +! + rdndif(0,1:nconfig) = 0.0_r8 + exptdn(0,1:nconfig) = 1.0_r8 + tdntot(0,1:nconfig) = 1.0_r8 +! +! Solve for properties involving downward propagation of radiation. +! The bulk properties are: +! +! (1. exptdn Sol. beam dwn. trans from layers above +! (2. rdndif Ref to dif rad for layers above +! (3. tdntot Total trans for layers above +! + do k = 1, pverp + km1 = k - 1 + do l0 = 1, nuniqd(km1) + is0 = istrtd(km1,l0) + is1 = istrtd(km1,l0+1)-1 + + j = icond(km1,is0) + + xexpt = exptdn(km1,j) + xrdnd = rdndif(km1,j) + tdnmexp = tdntot(km1,j) - xexpt + + if (ccon(km1,j) == 1) then +! +! If cloud in layer, use cloudy layer radiative properties +! + ytdnd = tdif(ns,i,km1) + yrdnd = rdif(ns,i,km1) + + rdenom = 1._r8/(1._r8-yrdnd*xrdnd) + rdirexp = rdir(ns,i,km1)*xexpt + + zexpt = xexpt * explay(ns,i,km1) + zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom + ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom + else +! +! If clear layer, use clear-sky layer radiative properties +! + ytdnd = tdifc(ns,i,km1) + yrdnd = rdifc(ns,i,km1) + + rdenom = 1._r8/(1._r8-yrdnd*xrdnd) + rdirexp = rdirc(ns,i,km1)*xexpt + + zexpt = xexpt * explayc(ns,i,km1) + zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom + ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* & + (tdnmexp + xrdnd*rdirexp)*rdenom + endif + +! +! If 2 or more configurations share identical properties at a given level k, +! the properties (at level k) are computed once and copied to +! all the configurations for efficiency. +! + do isn = is0, is1 + j = icond(km1,isn) + exptdn(k,j) = zexpt + rdndif(k,j) = zrdnd + tdntot(k,j) = ztdnt + end do +! +! end do l0 = 1, nuniqd(k) +! + end do +! +! end do k = 1, pverp +! + end do +! +! Solve for properties involving upward propagation of radiation. +! The bulk properties are: +! +! (1. rupdif Ref to dif rad for layers below +! (2. rupdir Ref to dir rad for layers below +! +! Specify surface boundary conditions (surface albedos) +! + rupdir(pverp,1:nconfig) = albdir(i,ns) + rupdif(pverp,1:nconfig) = albdif(i,ns) + + do k = pver, 0, -1 + do l0 = 1, nuniqu(k) + is0 = istrtu(k,l0) + is1 = istrtu(k,l0+1)-1 + + j = iconu(k,is0) + + xrupd = rupdif(k+1,j) + xrups = rupdir(k+1,j) + + if (ccon(k,j) == 1) then +! +! If cloud in layer, use cloudy layer radiative properties +! + yexpt = explay(ns,i,k) + yrupd = rdif(ns,i,k) + ytupd = tdif(ns,i,k) + + rdenom = 1._r8/( 1._r8 - yrupd*xrupd) + tdnmexp = (tdir(ns,i,k)-yexpt) + rdirexp = xrups*yexpt + + zrupd = yrupd + xrupd*(ytupd**2)*rdenom + zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom + else +! +! If clear layer, use clear-sky layer radiative properties +! + yexpt = explayc(ns,i,k) + yrupd = rdifc(ns,i,k) + ytupd = tdifc(ns,i,k) + + rdenom = 1._r8/( 1._r8 - yrupd*xrupd) + tdnmexp = (tdirc(ns,i,k)-yexpt) + rdirexp = xrups*yexpt + + zrupd = yrupd + xrupd*(ytupd**2)*rdenom + zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom + endif + +! +! If 2 or more configurations share identical properties at a given level k, +! the properties (at level k) are computed once and copied to +! all the configurations for efficiency. +! + do isn = is0, is1 + j = iconu(k,isn) + rupdif(k,j) = zrupd + rupdir(k,j) = zrups + end do +! +! end do l0 = 1, nuniqu(k) +! + end do +! +! end do k = pver,0,-1 +! + end do +! +!---------------------------------------------------------------------- +! +! STEP 3 +! +! Compute up and down fluxes for each interface k. This requires +! adding up the contributions from all possible permutations +! of streams in all max-overlap regions, weighted by the +! product of the fractional areas of the streams in each region +! (the random overlap assumption). The adding principle has been +! used in step 2 to combine the bulk radiative properties +! above and below the interface. +! + do k = 0,pverp +! +! Initialize the fluxes +! + fluxup(k)=0.0_r8 + fluxdn(k)=0.0_r8 + + do iconfig = 1, nconfig + xwgt = wgtv(iconfig) + xexpt = exptdn(k,iconfig) + xtdnt = tdntot(k,iconfig) + xrdnd = rdndif(k,iconfig) + xrupd = rupdif(k,iconfig) + xrups = rupdir(k,iconfig) +! +! Flux computation +! + rdenom = 1._r8/(1._r8 - xrdnd * xrupd) + + fluxup(k) = fluxup(k) + xwgt * & + ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom) + fluxdn(k) = fluxdn(k) + xwgt * & + (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom) +! +! End do iconfig = 1, nconfig +! + end do +! +! Normalize by total area covered by cloud configurations included +! in solution +! + fluxup(k)=fluxup(k) / totwgt + fluxdn(k)=fluxdn(k) / totwgt +! +! End do k = 0,pverp +! + end do +! +! Initialize the direct-beam flux at surface +! + wexptdn = 0.0_r8 + + do iconfig = 1, nconfig + wexptdn = wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig) + end do + + wexptdn = wexptdn / totwgt +! +! Monochromatic computation completed; accumulate in totals +! + solflx = solin(i)*frcsol(ns)*psf(ns) + fsnt(i) = fsnt(i) + solflx*(fluxdn(1) - fluxup(1)) + fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0)) + fsns(i) = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp)) + sfltot = sfltot + solflx + fswup(0) = fswup(0) + solflx*fluxup(0) + fswdn(0) = fswdn(0) + solflx*fluxdn(0) +! +! Down spectral fluxes need to be in mks; thus the .001 conversion factors +! + if (wavmid(ns) < 0.7_r8) then + sols(i) = sols(i) + wexptdn*solflx*0.001_r8 + solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8 + else + soll(i) = soll(i) + wexptdn*solflx*0.001_r8 + solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8 + fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0)) + end if + fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0)) + + do k=0,pver +! +! Compute flux divergence in each layer using the interface up and down +! fluxes: +! + kp1 = k+1 + flxdiv = (fluxdn(k ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k )) + totfld(k) = totfld(k) + solflx*flxdiv + fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1) + fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1) + end do +! +! Perform clear-sky calculation +! + exptdnc(0) = 1.0_r8 + rdndifc(0) = 0.0_r8 + tdntotc(0) = 1.0_r8 + rupdirc(pverp) = albdir(i,ns) + rupdifc(pverp) = albdif(i,ns) + + do k = 1, pverp + km1 = k - 1 + xexpt = exptdnc(km1) + xrdnd = rdndifc(km1) + yrdnd = rdifc(ns,i,km1) + ytdnd = tdifc(ns,i,km1) + + exptdnc(k) = xexpt*explayc(ns,i,km1) + + rdenom = 1._r8/(1._r8 - yrdnd*xrdnd) + rdirexp = rdirc(ns,i,km1)*xexpt + tdnmexp = tdntotc(km1) - xexpt + + tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* & + rdenom + rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom + end do + + do k=pver,0,-1 + xrupd = rupdifc(k+1) + yexpt = explayc(ns,i,k) + yrupd = rdifc(ns,i,k) + ytupd = tdifc(ns,i,k) + + rdenom = 1._r8/( 1._r8 - yrupd*xrupd) + + rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + & + xrupd*(tdirc(ns,i,k)-yexpt))*rdenom + rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom + end do + + do k=0,1 + rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k)) + fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* & + rdenom + fluxdn(k) = exptdnc(k) + & + (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* & + rdenom + fswupc(k) = fswupc(k) + solflx*fluxup(k) + fswdnc(k) = fswdnc(k) + solflx*fluxdn(k) + end do +! k = pverp + do k=2,pverp + rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k)) + fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* & + rdenom + fluxdn(k) = exptdnc(k) + (tdntotc(k) - exptdnc(k) + & + exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom + fswupc(k) = fswupc(k) + solflx*fluxup(k) + fswdnc(k) = fswdnc(k) + solflx*fluxdn(k) + end do + + fsntc(i) = fsntc(i)+solflx*(fluxdn(1)-fluxup(1)) + fsntoac(i) = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0)) + fsnsc(i) = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp)) + fsdsc(i) = fsdsc(i)+solflx*(fluxdn(pverp)) + fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0)) +! +! End of clear sky calculation +! + +! +! End of spectral interval loop +! + end do +! +! Compute solar heating rate (J/kg/s) +! + do k=1,pver + qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1)) + end do + +! Added downward/upward total and clear sky fluxes + + do k=1,pverp + fsup(i,k) = fswup(k) + fsupc(i,k) = fswupc(k) + fsdn(i,k) = fswdn(k) + fsdnc(i,k) = fswdnc(k) + end do +! +! Set the downwelling flux at the surface +! + fsds(i) = fswdn(pverp) +! +! End do n=1,ndayc +! + end do + +! write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk + + return +end subroutine radcswmx + +subroutine raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc ,abh2o , & + abo3 ,abco2 ,abo2 ,uh2o ,uo3 , & + uco2 ,uo2 ,trayoslp,pflx ,ns , & + tauxcl ,wcl ,gcl ,fcl ,tauxci , & + wci ,gci ,fci ,tauxar ,wa , & + ga ,fa ,rdir ,rdif ,tdir , & + tdif ,explay ,rdirc ,rdifc ,tdirc , & + tdifc ,explayc ) +!----------------------------------------------------------------------- +! +! Purpose: +! Computes layer reflectivities and transmissivities, from the top down +! to the surface using the delta-Eddington solutions for each layer +! +! Method: +! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington +! Approximation for Solar Radiation in the NCAR Community Climate Model, +! Journal of Geophysical Research, Vol 97, D7, pp7603-7612). +! +! Modified for maximum/random cloud overlap by Bill Collins and John +! Truesdale +! +! Author: Bill Collins +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid + + implicit none + + integer nspint ! Num of spctrl intervals across solar spectrum + + parameter ( nspint = 19 ) +! +! Minimum total transmission below which no layer computation are done: +! + real(r8) trmin ! Minimum total transmission allowed + real(r8) wray ! Rayleigh single scatter albedo + real(r8) gray ! Rayleigh asymetry parameter + real(r8) fray ! Rayleigh forward scattered fraction + + parameter (trmin = 1.e-3) + parameter (wray = 0.999999) + parameter (gray = 0.0) + parameter (fray = 0.1) +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: pver, pverp, pcols + real(r8), intent(in) :: coszrs(pcols) ! Cosine zenith angle + real(r8), intent(in) :: trayoslp ! Tray/sslp + real(r8), intent(in) :: pflx(pcols,0:pverp) ! Interface pressure + real(r8), intent(in) :: abh2o ! Absorption coefficiant for h2o + real(r8), intent(in) :: abo3 ! Absorption coefficiant for o3 + real(r8), intent(in) :: abco2 ! Absorption coefficiant for co2 + real(r8), intent(in) :: abo2 ! Absorption coefficiant for o2 + real(r8), intent(in) :: uh2o(pcols,0:pver) ! Layer absorber amount of h2o + real(r8), intent(in) :: uo3(pcols,0:pver) ! Layer absorber amount of o3 + real(r8), intent(in) :: uco2(pcols,0:pver) ! Layer absorber amount of co2 + real(r8), intent(in) :: uo2(pcols,0:pver) ! Layer absorber amount of o2 + real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid) + real(r8), intent(in) :: wcl(pcols,0:pver) ! Cloud single scattering albedo (liquid) + real(r8), intent(in) :: gcl(pcols,0:pver) ! Cloud asymmetry parameter (liquid) + real(r8), intent(in) :: fcl(pcols,0:pver) ! Cloud forward scattered fraction (liquid) + real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice) + real(r8), intent(in) :: wci(pcols,0:pver) ! Cloud single scattering albedo (ice) + real(r8), intent(in) :: gci(pcols,0:pver) ! Cloud asymmetry parameter (ice) + real(r8), intent(in) :: fci(pcols,0:pver) ! Cloud forward scattered fraction (ice) + real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth + real(r8), intent(in) :: wa(pcols,0:pver) ! Aerosol single scattering albedo + real(r8), intent(in) :: ga(pcols,0:pver) ! Aerosol asymmetry parameter + real(r8), intent(in) :: fa(pcols,0:pver) ! Aerosol forward scattered fraction + + integer, intent(in) :: ndayc ! Number of daylight columns + integer, intent(in) :: idayc(pcols) ! Daylight column indices + integer, intent(in) :: ns ! Index of spectral interval +! +! Input/Output arguments +! +! Following variables are defined for each layer; 0 refers to extra +! layer above top of model: +! + real(r8), intent(inout) :: rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad + real(r8), intent(inout) :: rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad + real(r8), intent(inout) :: tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad + real(r8), intent(inout) :: tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad + real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer +! +! Corresponding quantities for clear-skies +! + real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver) ! Clear layer reflec. to direct rad + real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver) ! Clear layer reflec. to diffuse rad + real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver) ! Clear layer trans. to direct rad + real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver) ! Clear layer trans. to diffuse rad + real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer +! +!---------------------------Local variables----------------------------- +! + integer i ! Column indices + integer k ! Level index + integer nn ! Index of column loops (max=ndayc) + + real(r8) taugab(pcols) ! Layer total gas absorption optical depth + real(r8) tauray(pcols) ! Layer rayleigh optical depth + real(r8) taucsc ! Layer cloud scattering optical depth + real(r8) tautot ! Total layer optical depth + real(r8) wtot ! Total layer single scatter albedo + real(r8) gtot ! Total layer asymmetry parameter + real(r8) ftot ! Total layer forward scatter fraction + real(r8) wtau ! rayleigh layer scattering optical depth + real(r8) wt ! layer total single scattering albedo + real(r8) ts ! layer scaled extinction optical depth + real(r8) ws ! layer scaled single scattering albedo + real(r8) gs ! layer scaled asymmetry parameter +! +!---------------------------Statement functions------------------------- +! +! Statement functions and other local variables +! + real(r8) alpha ! Term in direct reflect and transmissivity + real(r8) gamma ! Term in direct reflect and transmissivity + real(r8) el ! Term in alpha,gamma,n,u + real(r8) taus ! Scaled extinction optical depth + real(r8) omgs ! Scaled single particle scattering albedo + real(r8) asys ! Scaled asymmetry parameter + real(r8) u ! Term in diffuse reflect and +! transmissivity + real(r8) n ! Term in diffuse reflect and +! transmissivity + real(r8) lm ! Temporary for el + real(r8) ne ! Temporary for n + real(r8) w ! Dummy argument for statement function + real(r8) uu ! Dummy argument for statement function + real(r8) g ! Dummy argument for statement function + real(r8) e ! Dummy argument for statement function + real(r8) f ! Dummy argument for statement function + real(r8) t ! Dummy argument for statement function + real(r8) et ! Dummy argument for statement function +! +! Intermediate terms for delta-eddington solution +! + real(r8) alp ! Temporary for alpha + real(r8) gam ! Temporary for gamma + real(r8) ue ! Temporary for u + real(r8) arg ! Exponential argument + real(r8) extins ! Extinction + real(r8) amg ! Alp - gam + real(r8) apg ! Alp + gam +! + alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu)) + gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu)) + el(w,g) = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g)) + taus(w,f,t) = (1._r8 - w*f)*t + omgs(w,f) = (1._r8 - f)*w/(1._r8 - w*f) + asys(g,f) = (g - f)/(1._r8 - f) + u(w,g,e) = 1.5_r8*(1._r8 - w*g)/e + n(uu,et) = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et) +! +!----------------------------------------------------------------------- +! +! Compute layer radiative properties +! +! Compute radiative properties (reflectivity and transmissivity for +! direct and diffuse radiation incident from above, under clear +! and cloudy conditions) and transmission of direct radiation +! (under clear and cloudy conditions) for each layer. +! + do k=0,pver + do nn=1,ndayc + i=idayc(nn) + tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k)) + taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k) + tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k) + taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k) + wtau = wray*tauray(i) + wt = wtau + taucsc + wtot = wt/tautot + gtot = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) & + + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt + ftot = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) & + + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt + ts = taus(wtot,ftot,tautot) + ws = omgs(wtot,ftot) + gs = asys(gtot,ftot) + lm = el(ws,gs) + alp = alpha(ws,coszrs(i),gs,lm) + gam = gamma(ws,coszrs(i),gs,lm) + ue = u(ws,gs,lm) +! +! Limit argument of exponential to 25, in case lm very large: +! + arg = min(lm*ts,25._r8) + extins = exp(-arg) + ne = n(ue,extins) + rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne + tdif(ns,i,k) = 4._r8*ue/ne +! +! Limit argument of exponential to 25, in case coszrs is very small: +! + arg = min(ts/coszrs(i),25._r8) + explay(ns,i,k) = exp(-arg) + apg = alp + gam + amg = alp - gam + rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k) + tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k) +! +! Under rare conditions, reflectivies and transmissivities can be +! negative; zero out any negative values +! + rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8) + tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8) + rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8) + tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8) +! +! Clear-sky calculation +! + if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then + + rdirc(ns,i,k) = rdir(ns,i,k) + tdirc(ns,i,k) = tdir(ns,i,k) + rdifc(ns,i,k) = rdif(ns,i,k) + tdifc(ns,i,k) = tdif(ns,i,k) + explayc(ns,i,k) = explay(ns,i,k) + else + tautot = tauray(i) + taugab(i) + tauxar(i,k) + taucsc = tauxar(i,k)*wa(i,k) +! +! wtau already computed for all-sky +! + wt = wtau + taucsc + wtot = wt/tautot + gtot = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt + ftot = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt + ts = taus(wtot,ftot,tautot) + ws = omgs(wtot,ftot) + gs = asys(gtot,ftot) + lm = el(ws,gs) + alp = alpha(ws,coszrs(i),gs,lm) + gam = gamma(ws,coszrs(i),gs,lm) + ue = u(ws,gs,lm) +! +! Limit argument of exponential to 25, in case lm very large: +! + arg = min(lm*ts,25._r8) + extins = exp(-arg) + ne = n(ue,extins) + rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne + tdifc(ns,i,k) = 4._r8*ue/ne +! +! Limit argument of exponential to 25, in case coszrs is very small: +! + arg = min(ts/coszrs(i),25._r8) + explayc(ns,i,k) = exp(-arg) + apg = alp + gam + amg = alp - gam + rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ & + apg*rdifc(ns,i,k) + tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* & + explayc(ns,i,k) +! +! Under rare conditions, reflectivies and transmissivities can be +! negative; zero out any negative values +! + rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8) + tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8) + rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8) + tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8) + end if + end do + end do + + return +end subroutine raddedmx +subroutine radini(gravx ,cpairx ,epsilox ,stebolx, pstdx ) +!----------------------------------------------------------------------- +! +! Purpose: +! Initialize various constants for radiation scheme; note that +! the radiation scheme uses cgs units. +! +! Method: +! +! +! +! Author: W. Collins (H2O parameterization) and J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid, only: pver, pverp +! use comozp, only: cplos, cplol +! use pmgrid, only: masterproc, plev, plevp +! use radae, only: radaeini +! use physconst, only: mwdry, mwco2 +#if ( defined SPMD ) +! use mpishorthand +#endif + implicit none + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real, intent(in) :: gravx ! Acceleration of gravity (MKS) + real, intent(in) :: cpairx ! Specific heat of dry air (MKS) + real, intent(in) :: epsilox ! Ratio of mol. wght of H2O to dry air + real, intent(in) :: stebolx ! Stefan-Boltzmann's constant (MKS) + real(r8), intent(in) :: pstdx ! Standard pressure (Pascals) +! +!---------------------------Local variables----------------------------- +! + integer k ! Loop variable + + real(r8) v0 ! Volume of a gas at stp (m**3/kmol) + real(r8) p0 ! Standard pressure (pascals) + real(r8) amd ! Effective molecular weight of dry air (kg/kmol) + real(r8) goz ! Acceleration of gravity (m/s**2) +! +!----------------------------------------------------------------------- +! +! Set general radiation consts; convert to cgs units where appropriate: +! + gravit = 100.*gravx + rga = 1./gravit + gravmks = gravx + cpair = 1.e4*cpairx + epsilo = epsilox + sslp = 1.013250e6 + stebol = 1.e3*stebolx + rgsslp = 0.5/(gravit*sslp) + dpfo3 = 2.5e-3 + dpfco2 = 5.0e-3 + dayspy = 365. + pie = 4.*atan(1.) +! +! Initialize ozone data. +! + v0 = 22.4136 ! Volume of a gas at stp (m**3/kmol) + p0 = 0.1*sslp ! Standard pressure (pascals) + amd = 28.9644 ! Molecular weight of dry air (kg/kmol) + goz = gravx ! Acceleration of gravity (m/s**2) +! +! Constants for ozone path integrals (multiplication by 100 for unit +! conversion to cgs from mks): +! + cplos = v0/(amd*goz) *100.0 + cplol = v0/(amd*goz*p0)*0.5*100.0 +! +! Derived constants +! If the top model level is above ~90 km (0.1 Pa), set the top level to compute +! longwave cooling to about 80 km (1 Pa) +! WRF: assume top level > 0.1 mb +! if (hypm(1) .lt. 0.1) then +! do k = 1, pver +! if (hypm(k) .lt. 1.) ntoplw = k +! end do +! else + ntoplw = 1 +! end if +! if (masterproc) then +! write (6,*) 'RADINI: ntoplw =',ntoplw, ' pressure:',hypm(ntoplw) +! endif + + call radaeini( pstdx, mwdry, mwco2 ) + return +end subroutine radini +subroutine radinp(lchnk ,ncol , pcols, pver, pverp, & + pmid ,pint ,o3vmr , pmidrd ,& + pintrd ,eccf ,o3mmr ) +!----------------------------------------------------------------------- +! +! Purpose: +! Set latitude and time dependent arrays for input to solar +! and longwave radiation. +! Convert model pressures to cgs, and compute ozone mixing ratio, needed for +! the solar radiation. +! +! Method: +! +! +! +! Author: CCM1, CMS Contact J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use time_manager, only: get_curr_calday + + implicit none + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols, pver, pverp + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: pmid(pcols,pver) ! Pressure at model mid-levels (pascals) + real(r8), intent(in) :: pint(pcols,pverp) ! Pressure at model interfaces (pascals) + real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio +! +! Output arguments +! + real(r8), intent(out) :: pmidrd(pcols,pver) ! Pressure at mid-levels (dynes/cm*2) + real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2) + real(r8), intent(out) :: eccf ! Earth-sun distance factor + real(r8), intent(out) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio + +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude loop index + integer k ! Vertical loop index + + real(r8) :: calday ! current calendar day + real(r8) amd ! Effective molecular weight of dry air (g/mol) + real(r8) amo ! Molecular weight of ozone (g/mol) + real(r8) vmmr ! Ozone volume mixing ratio + real(r8) delta ! Solar declination angle + + save amd ,amo + + data amd / 28.9644 / + data amo / 48.0000 / +! +!----------------------------------------------------------------------- +! +! calday = get_curr_calday() + eccf = 1. ! declared intent(out) so fill a value (not used in WRF) +! call shr_orb_decl (calday ,eccen ,mvelpp ,lambm0 ,obliqr , & +! delta ,eccf) + +! +! Convert pressure from pascals to dynes/cm2 +! + do k=1,pver + do i=1,ncol + pmidrd(i,k) = pmid(i,k)*10.0 + pintrd(i,k) = pint(i,k)*10.0 + end do + end do + do i=1,ncol + pintrd(i,pverp) = pint(i,pverp)*10.0 + end do +! +! Convert ozone volume mixing ratio to mass mixing ratio: +! + vmmr = amo/amd + do k=1,pver + do i=1,ncol + o3mmr(i,k) = vmmr*o3vmr(i,k) + end do + end do +! + return +end subroutine radinp +subroutine radoz2(lchnk ,ncol ,pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw ) +!----------------------------------------------------------------------- +! +! Purpose: +! Computes the path length integrals to the model interfaces given the +! ozone volume mixing ratio +! +! Method: +! +! +! +! Author: CCM1, CMS Contact J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use comozp + + implicit none +!------------------------------Input arguments-------------------------- +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures + + integer, intent(in) :: ntoplw ! topmost level/layer longwave is solved for + +! +!----------------------------Output arguments--------------------------- +! + real(r8), intent(out) :: plol(pcols,pverp) ! Ozone prs weighted path length (cm) + real(r8), intent(out) :: plos(pcols,pverp) ! Ozone path length (cm) + +! +!---------------------------Local workspace----------------------------- +! + integer i ! longitude index + integer k ! level index +! +!----------------------------------------------------------------------- +! +! Evaluate the ozone path length integrals to interfaces; +! factors of .1 and .01 to convert pressures from cgs to mks: +! + do i=1,ncol + plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw) + plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw) + end do + do k=ntoplw+1,pverp + do i=1,ncol + plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1)) + plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* & + (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1)) + end do + end do +! + return +end subroutine radoz2 + + +subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr) +!----------------------------------------------------------------------- +! +! Purpose: Interpolate ozone from current time-interpolated values to model levels +! +! Method: Use pressure values to determine interpolation levels +! +! Author: Bruce Briegleb +! +!-------------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use phys_grid, only: get_lat_all_p, get_lon_all_p +! use comozp +! use abortutils, only: endrun +!-------------------------------------------------------------------------- + implicit none +!-------------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: pcols, pver + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: levsiz ! number of ozone layers + + real(r8), intent(in) :: pmid(pcols,pver) ! level pressures (mks) + real(r8), intent(in) :: pin(levsiz) ! ozone data level pressures (mks) + real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio + + real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio +! +! local storage +! + integer i ! longitude index + integer k, kk, kkstart ! level indices + integer kupper(pcols) ! Level indices for interpolation + integer kount ! Counter + integer lats(pcols) ! latitude indices + integer lons(pcols) ! latitude indices + + real(r8) dpu ! upper level pressure difference + real(r8) dpl ! lower level pressure difference +! +! Initialize latitude indices +! +! call get_lat_all_p(lchnk, ncol, lats) +! call get_lon_all_p(lchnk, ncol, lons) +! +! Initialize index array +! + do i=1,ncol + kupper(i) = 1 + end do + + do k=1,pver +! +! Top level we need to start looking is the top level for the previous k +! for all longitude points +! + kkstart = levsiz + do i=1,ncol + kkstart = min0(kkstart,kupper(i)) + end do + kount = 0 +! +! Store level indices for interpolation +! + do kk=kkstart,levsiz-1 + do i=1,ncol + if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then + kupper(i) = kk + kount = kount + 1 + end if + end do +! +! If all indices for this level have been found, do the interpolation and +! go to the next level +! + if (kount.eq.ncol) then + do i=1,ncol + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end do + goto 35 + end if + end do +! +! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and +! must extrapolate from the bottom or top ozone data level for at least some +! of the longitude points. +! + do i=1,ncol + if (pmid(i,k) .lt. pin(1)) then + o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1) + else if (pmid(i,k) .gt. pin(levsiz)) then + o3vmr(i,k) = ozmix(i,levsiz) + else + dpu = pmid(i,k) - pin(kupper(i)) + dpl = pin(kupper(i)+1) - pmid(i,k) + o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + & + ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu) + end if + end do + + if (kount.gt.ncol) then +! call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected') + end if +35 continue + end do + + return +end subroutine radozn + + +subroutine sortarray(n, ain, indxa) +!----------------------------------------------- +! +! Purpose: +! Sort an array +! Alogrithm: +! Based on Shell's sorting method. +! +! Author: T. Craig +!----------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +! Arguments +! + integer , intent(in) :: n ! total number of elements + integer , intent(inout) :: indxa(n) ! array of integers + real(r8), intent(inout) :: ain(n) ! array to sort +! +! local variables +! + integer :: i, j ! Loop indices + integer :: ni ! Starting increment + integer :: itmp ! Temporary index + real(r8):: atmp ! Temporary value to swap + + ni = 1 + do while(.TRUE.) + ni = 3*ni + 1 + if (ni <= n) cycle + exit + end do + + do while(.TRUE.) + ni = ni/3 + do i = ni + 1, n + atmp = ain(i) + itmp = indxa(i) + j = i + do while(.TRUE.) + if (ain(j-ni) <= atmp) exit + ain(j) = ain(j-ni) + indxa(j) = indxa(j-ni) + j = j - ni + if (j > ni) cycle + exit + end do + ain(j) = atmp + indxa(j) = itmp + end do + if (ni > 1) cycle + exit + end do + return + +end subroutine sortarray +subroutine trcab(lchnk ,ncol ,pcols, pverp, & + k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , & + bch4 ,to3co2 ,pnm ,dw ,pnew , & + s2c ,uptype ,dplh2o ,abplnk1 ,tco2 , & + th2o ,to3 ,abstrc , & + aer_trn_ttl) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate absorptivity for non nearest layers for CH4, N2O, CFC11 and +! CFC12. +! +! Method: +! See CCM3 description for equations. +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use volcrad + + implicit none + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pverp + integer, intent(in) :: k1,k2 ! level indices +! + real(r8), intent(in) :: to3co2(pcols) ! pressure weighted temperature + real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressures + real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length +! + real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length + real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length +! + real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o +! + real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4 + real(r8), intent(in) :: dw(pcols) ! h2o path length + real(r8), intent(in) :: pnew(pcols) ! pressure + real(r8), intent(in) :: s2c(pcols,pverp) ! continuum path length + real(r8), intent(in) :: uptype(pcols,pverp) ! p-type h2o path length +! + real(r8), intent(in) :: dplh2o(pcols) ! p squared h2o path length + real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! Planck factor + real(r8), intent(in) :: tco2(pcols) ! co2 transmission factor + real(r8), intent(in) :: th2o(pcols) ! h2o transmission factor + real(r8), intent(in) :: to3(pcols) ! o3 transmission factor + + real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn. + +! +! Output Arguments +! + real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity +! +!--------------------------Local Variables------------------------------ +! + integer i,l ! loop counters + + real(r8) sqti(pcols) ! square root of mean temp + real(r8) du1 ! cfc11 path length + real(r8) du2 ! cfc12 path length + real(r8) acfc1 ! cfc11 absorptivity 798 cm-1 + real(r8) acfc2 ! cfc11 absorptivity 846 cm-1 +! + real(r8) acfc3 ! cfc11 absorptivity 933 cm-1 + real(r8) acfc4 ! cfc11 absorptivity 1085 cm-1 + real(r8) acfc5 ! cfc12 absorptivity 889 cm-1 + real(r8) acfc6 ! cfc12 absorptivity 923 cm-1 + real(r8) acfc7 ! cfc12 absorptivity 1102 cm-1 +! + real(r8) acfc8 ! cfc12 absorptivity 1161 cm-1 + real(r8) du01 ! n2o path length + real(r8) dbeta01 ! n2o pressure factor + real(r8) dbeta11 ! " + real(r8) an2o1 ! absorptivity of 1285 cm-1 n2o band +! + real(r8) du02 ! n2o path length + real(r8) dbeta02 ! n2o pressure factor + real(r8) an2o2 ! absorptivity of 589 cm-1 n2o band + real(r8) du03 ! n2o path length + real(r8) dbeta03 ! n2o pressure factor +! + real(r8) an2o3 ! absorptivity of 1168 cm-1 n2o band + real(r8) duch4 ! ch4 path length + real(r8) dbetac ! ch4 pressure factor + real(r8) ach4 ! absorptivity of 1306 cm-1 ch4 band + real(r8) du11 ! co2 path length +! + real(r8) du12 ! " + real(r8) du13 ! " + real(r8) dbetc1 ! co2 pressure factor + real(r8) dbetc2 ! co2 pressure factor + real(r8) aco21 ! absorptivity of 1064 cm-1 band +! + real(r8) du21 ! co2 path length + real(r8) du22 ! " + real(r8) du23 ! " + real(r8) aco22 ! absorptivity of 961 cm-1 band + real(r8) tt(pcols) ! temp. factor for h2o overlap factor +! + real(r8) psi1 ! " + real(r8) phi1 ! " + real(r8) p1 ! h2o overlap factor + real(r8) w1 ! " + real(r8) ds2c(pcols) ! continuum path length +! + real(r8) duptyp(pcols) ! p-type path length + real(r8) tw(pcols,6) ! h2o transmission factor + real(r8) g1(6) ! " + real(r8) g2(6) ! " + real(r8) g3(6) ! " +! + real(r8) g4(6) ! " + real(r8) ab(6) ! h2o temp. factor + real(r8) bb(6) ! " + real(r8) abp(6) ! " + real(r8) bbp(6) ! " +! + real(r8) tcfc3 ! transmission for cfc11 band + real(r8) tcfc4 ! transmission for cfc11 band + real(r8) tcfc6 ! transmission for cfc12 band + real(r8) tcfc7 ! transmission for cfc12 band + real(r8) tcfc8 ! transmission for cfc12 band +! + real(r8) tlw ! h2o transmission + real(r8) tch4 ! ch4 transmission +! +!--------------------------Data Statements------------------------------ +! + data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/ + data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/ + data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/ + data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/ + data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/ + data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/ + data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/ + data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/ +! +!--------------------------Statement Functions-------------------------- +! + real(r8) func, u, b + func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b)) +! +!------------------------------------------------------------------------ +! + do i = 1,ncol + sqti(i) = sqrt(to3co2(i)) +! +! h2o transmission +! + tt(i) = abs(to3co2(i) - 250.0) + ds2c(i) = abs(s2c(i,k1) - s2c(i,k2)) + duptyp(i) = abs(uptype(i,k1) - uptype(i,k2)) + end do +! + do l = 1,6 + do i = 1,ncol + psi1 = exp(abp(l)*tt(i) + bbp(l)*tt(i)*tt(i)) + phi1 = exp(ab(l)*tt(i) + bb(l)*tt(i)*tt(i)) + p1 = pnew(i)*(psi1/phi1)/sslp + w1 = dw(i)*phi1 + tw(i,l) = exp(-g1(l)*p1*(sqrt(1.0 + g2(l)*(w1/p1)) - 1.0) - & + g3(l)*ds2c(i)-g4(l)*duptyp(i)) + end do + end do +! + do i=1,ncol + tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1 + 0.3*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000)) + tw(i,2)=tw(i,2)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1 + tw(i,3)=tw(i,3)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1 + tw(i,4)=tw(i,4)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1 + tw(i,5)=tw(i,5)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1 + tw(i,6)=tw(i,6)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1 + end do ! end loop over lon + do i = 1,ncol + du1 = abs(ucfc11(i,k1) - ucfc11(i,k2)) + du2 = abs(ucfc12(i,k1) - ucfc12(i,k2)) +! +! cfc transmissions +! + tcfc3 = exp(-175.005*du1) + tcfc4 = exp(-1202.18*du1) + tcfc6 = exp(-5786.73*du2) + tcfc7 = exp(-2873.51*du2) + tcfc8 = exp(-2085.59*du2) +! +! Absorptivity for CFC11 bands +! + acfc1 = 50.0*(1.0 - exp(-54.09*du1))*tw(i,1)*abplnk1(7,i,k2) + acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*abplnk1(8,i,k2) + acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*abplnk1(9,i,k2) + acfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*abplnk1(10,i,k2) +! +! Absorptivity for CFC12 bands +! + acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*abplnk1(11,i,k2) + acfc6 = 50.0*(1.0 - tcfc6)* tw(i,4) * abplnk1(12,i,k2) + acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5) * tcfc4*abplnk1(13,i,k2) + acfc8 = 70.0*(1.0 - tcfc8)* tw(i,6) * abplnk1(14,i,k2) +! +! Emissivity for CH4 band 1306 cm-1 +! + tlw = exp(-1.0*sqrt(dplh2o(i))) + tlw=tlw*aer_trn_ttl(i,k1,k2,idx_LW_1200_2000) + duch4 = abs(uch4(i,k1) - uch4(i,k2)) + dbetac = abs(bch4(i,k1) - bch4(i,k2))/duch4 + ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac))*tlw*abplnk1(3,i,k2) + tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac)) +! +! Absorptivity for N2O bands +! + du01 = abs(un2o0(i,k1) - un2o0(i,k2)) + du11 = abs(un2o1(i,k1) - un2o1(i,k2)) + dbeta01 = abs(bn2o0(i,k1) - bn2o0(i,k2))/du01 + dbeta11 = abs(bn2o1(i,k1) - bn2o1(i,k2))/du11 +! +! 1285 cm-1 band +! + an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) & + + func(du11,dbeta11))*tlw*tch4*abplnk1(4,i,k2) + du02 = 0.100090*du01 + du12 = 0.0992746*du11 + dbeta02 = 0.964282*dbeta01 +! +! 589 cm-1 band +! + an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) + & + func(du12,dbeta02))*th2o(i)*tco2(i)*abplnk1(5,i,k2) + du03 = 0.0333767*du01 + dbeta03 = 0.982143*dbeta01 +! +! 1168 cm-1 band +! + an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03))* & + tw(i,6)*tcfc8*abplnk1(6,i,k2) +! +! Emissivity for 1064 cm-1 band of CO2 +! + du11 = abs(uco211(i,k1) - uco211(i,k2)) + du12 = abs(uco212(i,k1) - uco212(i,k2)) + du13 = abs(uco213(i,k1) - uco213(i,k2)) + dbetc1 = 2.97558*abs(pnm(i,k1) + pnm(i,k2))/(2.0*sslp*sqti(i)) + dbetc2 = 2.0*dbetc1 + aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) & + + func(du12,dbetc2) + func(du13,dbetc2)) & + *to3(i)*tw(i,5)*tcfc4*tcfc7*abplnk1(2,i,k2) +! +! Emissivity for 961 cm-1 band +! + du21 = abs(uco221(i,k1) - uco221(i,k2)) + du22 = abs(uco222(i,k1) - uco222(i,k2)) + du23 = abs(uco223(i,k1) - uco223(i,k2)) + aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) & + + func(du22,dbetc1) + func(du23,dbetc2)) & + *tw(i,4)*tcfc3*tcfc6*abplnk1(1,i,k2) +! +! total trace gas absorptivity +! + abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + & + acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + & + aco21 + aco22 + end do +! + return +! +end subroutine trcab + + + +subroutine trcabn(lchnk ,ncol ,pcols, pverp, & + k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,tbar ,bplnk , & + winpl ,pinpl ,tco2 ,th2o ,to3 , & + uptype ,dw ,s2c ,up2 ,pnew , & + abstrc ,uinpl , & + aer_trn_ngh) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate nearest layer absorptivity due to CH4, N2O, CFC11 and CFC12 +! +! Method: +! Equations in CCM3 description +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use volcrad + + implicit none + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pverp + integer, intent(in) :: k2 ! level index + integer, intent(in) :: kn ! level index +! + real(r8), intent(in) :: tbar(pcols,4) ! pressure weighted temperature + real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length + real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band) +! + real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length + real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length +! + real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: bplnk(14,pcols,4) ! weighted Planck fnc. for absorptivity + real(r8), intent(in) :: winpl(pcols,4) ! fractional path length + real(r8), intent(in) :: pinpl(pcols,4) ! pressure factor for subdivided layer +! + real(r8), intent(in) :: tco2(pcols) ! co2 transmission + real(r8), intent(in) :: th2o(pcols) ! h2o transmission + real(r8), intent(in) :: to3(pcols) ! o3 transmission + real(r8), intent(in) :: dw(pcols) ! h2o path length + real(r8), intent(in) :: pnew(pcols) ! pressure factor +! + real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum factor + real(r8), intent(in) :: uptype(pcols,pverp) ! p-type path length + real(r8), intent(in) :: up2(pcols) ! p squared path length + real(r8), intent(in) :: uinpl(pcols,4) ! Nearest layer subdivision factor + real(r8), intent(in) :: aer_trn_ngh(pcols,bnd_nbr_LW) + ! [fraction] Total transmission between + ! nearest neighbor sub-levels +! +! Output Arguments +! + real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity + +! +!--------------------------Local Variables------------------------------ +! + integer i,l ! loop counters +! + real(r8) sqti(pcols) ! square root of mean temp + real(r8) rsqti(pcols) ! reciprocal of sqti + real(r8) du1 ! cfc11 path length + real(r8) du2 ! cfc12 path length + real(r8) acfc1 ! absorptivity of cfc11 798 cm-1 band +! + real(r8) acfc2 ! absorptivity of cfc11 846 cm-1 band + real(r8) acfc3 ! absorptivity of cfc11 933 cm-1 band + real(r8) acfc4 ! absorptivity of cfc11 1085 cm-1 band + real(r8) acfc5 ! absorptivity of cfc11 889 cm-1 band + real(r8) acfc6 ! absorptivity of cfc11 923 cm-1 band +! + real(r8) acfc7 ! absorptivity of cfc11 1102 cm-1 band + real(r8) acfc8 ! absorptivity of cfc11 1161 cm-1 band + real(r8) du01 ! n2o path length + real(r8) dbeta01 ! n2o pressure factors + real(r8) dbeta11 ! " +! + real(r8) an2o1 ! absorptivity of the 1285 cm-1 n2o band + real(r8) du02 ! n2o path length + real(r8) dbeta02 ! n2o pressure factor + real(r8) an2o2 ! absorptivity of the 589 cm-1 n2o band + real(r8) du03 ! n2o path length +! + real(r8) dbeta03 ! n2o pressure factor + real(r8) an2o3 ! absorptivity of the 1168 cm-1 n2o band + real(r8) duch4 ! ch4 path length + real(r8) dbetac ! ch4 pressure factor + real(r8) ach4 ! absorptivity of the 1306 cm-1 ch4 band +! + real(r8) du11 ! co2 path length + real(r8) du12 ! " + real(r8) du13 ! " + real(r8) dbetc1 ! co2 pressure factor + real(r8) dbetc2 ! co2 pressure factor +! + real(r8) aco21 ! absorptivity of the 1064 cm-1 co2 band + real(r8) du21 ! co2 path length + real(r8) du22 ! " + real(r8) du23 ! " + real(r8) aco22 ! absorptivity of the 961 cm-1 co2 band +! + real(r8) tt(pcols) ! temp. factor for h2o overlap + real(r8) psi1 ! " + real(r8) phi1 ! " + real(r8) p1 ! factor for h2o overlap + real(r8) w1 ! " +! + real(r8) ds2c(pcols) ! continuum path length + real(r8) duptyp(pcols) ! p-type path length + real(r8) tw(pcols,6) ! h2o transmission overlap + real(r8) g1(6) ! h2o overlap factor + real(r8) g2(6) ! " +! + real(r8) g3(6) ! " + real(r8) g4(6) ! " + real(r8) ab(6) ! h2o temp. factor + real(r8) bb(6) ! " + real(r8) abp(6) ! " +! + real(r8) bbp(6) ! " + real(r8) tcfc3 ! transmission of cfc11 band + real(r8) tcfc4 ! transmission of cfc11 band + real(r8) tcfc6 ! transmission of cfc12 band + real(r8) tcfc7 ! " +! + real(r8) tcfc8 ! " + real(r8) tlw ! h2o transmission + real(r8) tch4 ! ch4 transmission +! +!--------------------------Data Statements------------------------------ +! + data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/ + data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/ + data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/ + data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/ + data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/ + data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/ + data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/ + data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/ +! +!--------------------------Statement Functions-------------------------- +! + real(r8) func, u, b + func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b)) +! +!------------------------------------------------------------------ +! + do i = 1,ncol + sqti(i) = sqrt(tbar(i,kn)) + rsqti(i) = 1. / sqti(i) +! +! h2o transmission +! + tt(i) = abs(tbar(i,kn) - 250.0) + ds2c(i) = abs(s2c(i,k2+1) - s2c(i,k2))*uinpl(i,kn) + duptyp(i) = abs(uptype(i,k2+1) - uptype(i,k2))*uinpl(i,kn) + end do +! + do l = 1,6 + do i = 1,ncol + psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i)) + phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i)) + p1 = pnew(i) * (psi1/phi1) / sslp + w1 = dw(i) * winpl(i,kn) * phi1 + tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) & + - g3(l)*ds2c(i)-g4(l)*duptyp(i)) + end do + end do +! + do i=1,ncol + tw(i,1)=tw(i,1)*(0.7*aer_trn_ngh(i,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1 + 0.3*aer_trn_ngh(i,idx_LW_0800_1000)) + tw(i,2)=tw(i,2)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1 + tw(i,3)=tw(i,3)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1 + tw(i,4)=tw(i,4)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1 + tw(i,5)=tw(i,5)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1 + tw(i,6)=tw(i,6)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1 + end do ! end loop over lon + + do i = 1,ncol +! + du1 = abs(ucfc11(i,k2+1) - ucfc11(i,k2)) * winpl(i,kn) + du2 = abs(ucfc12(i,k2+1) - ucfc12(i,k2)) * winpl(i,kn) +! +! cfc transmissions +! + tcfc3 = exp(-175.005*du1) + tcfc4 = exp(-1202.18*du1) + tcfc6 = exp(-5786.73*du2) + tcfc7 = exp(-2873.51*du2) + tcfc8 = exp(-2085.59*du2) +! +! Absorptivity for CFC11 bands +! + acfc1 = 50.0*(1.0 - exp(-54.09*du1)) * tw(i,1)*bplnk(7,i,kn) + acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*bplnk(8,i,kn) + acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6 * bplnk(9,i,kn) + acfc4 = 100.0*(1.0 - tcfc4)* tw(i,5) * bplnk(10,i,kn) +! +! Absorptivity for CFC12 bands +! + acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*bplnk(11,i,kn) + acfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*bplnk(12,i,kn) + acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5)*tcfc4 *bplnk(13,i,kn) + acfc8 = 70.0*(1.0 - tcfc8)*tw(i,6)*bplnk(14,i,kn) +! +! Absorptivity for CH4 band 1306 cm-1 +! + tlw = exp(-1.0*sqrt(up2(i))) + tlw=tlw*aer_trn_ngh(i,idx_LW_1200_2000) + duch4 = abs(uch4(i,k2+1) - uch4(i,k2)) * winpl(i,kn) + dbetac = 2.94449 * pinpl(i,kn) * rsqti(i) / sslp + ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac)) * tlw * bplnk(3,i,kn) + tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac)) +! +! Absorptivity for N2O bands +! + du01 = abs(un2o0(i,k2+1) - un2o0(i,k2)) * winpl(i,kn) + du11 = abs(un2o1(i,k2+1) - un2o1(i,k2)) * winpl(i,kn) + dbeta01 = 19.399 * pinpl(i,kn) * rsqti(i) / sslp + dbeta11 = dbeta01 +! +! 1285 cm-1 band +! + an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) & + + func(du11,dbeta11)) * tlw * tch4 * bplnk(4,i,kn) + du02 = 0.100090*du01 + du12 = 0.0992746*du11 + dbeta02 = 0.964282*dbeta01 +! +! 589 cm-1 band +! + an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) & + + func(du12,dbeta02)) * tco2(i) * th2o(i) * bplnk(5,i,kn) + du03 = 0.0333767*du01 + dbeta03 = 0.982143*dbeta01 +! +! 1168 cm-1 band +! + an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03)) * & + tw(i,6) * tcfc8 * bplnk(6,i,kn) +! +! Absorptivity for 1064 cm-1 band of CO2 +! + du11 = abs(uco211(i,k2+1) - uco211(i,k2)) * winpl(i,kn) + du12 = abs(uco212(i,k2+1) - uco212(i,k2)) * winpl(i,kn) + du13 = abs(uco213(i,k2+1) - uco213(i,k2)) * winpl(i,kn) + dbetc1 = 2.97558 * pinpl(i,kn) * rsqti(i) / sslp + dbetc2 = 2.0 * dbetc1 + aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) & + + func(du12,dbetc2) + func(du13,dbetc2)) & + * to3(i) * tw(i,5) * tcfc4 * tcfc7 * bplnk(2,i,kn) +! +! Absorptivity for 961 cm-1 band of co2 +! + du21 = abs(uco221(i,k2+1) - uco221(i,k2)) * winpl(i,kn) + du22 = abs(uco222(i,k2+1) - uco222(i,k2)) * winpl(i,kn) + du23 = abs(uco223(i,k2+1) - uco223(i,k2)) * winpl(i,kn) + aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) & + + func(du22,dbetc1) + func(du23,dbetc2)) & + * tw(i,4) * tcfc3 * tcfc6 * bplnk(1,i,kn) +! +! total trace gas absorptivity +! + abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + & + acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + & + aco21 + aco22 + end do +! + return +! +end subroutine trcabn + + + + + +subroutine trcems(lchnk ,ncol ,pcols, pverp, & + k ,co2t ,pnm ,ucfc11 ,ucfc12 , & + un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , & + bch4 ,uco211 ,uco212 ,uco213 ,uco221 , & + uco222 ,uco223 ,uptype ,w ,s2c , & + up2 ,emplnk ,th2o ,tco2 ,to3 , & + emstrc , & + aer_trn_ttl) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate emissivity for CH4, N2O, CFC11 and CFC12 bands. +! +! Method: +! See CCM3 Description for equations. +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use volcrad + + implicit none + +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pverp + + real(r8), intent(in) :: co2t(pcols,pverp) ! pressure weighted temperature + real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressure + real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length +! + real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length + real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length +! + real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length + real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o +! + real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o + real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4 + real(r8), intent(in) :: emplnk(14,pcols) ! emissivity Planck factor + real(r8), intent(in) :: th2o(pcols) ! water vapor overlap factor + real(r8), intent(in) :: tco2(pcols) ! co2 overlap factor +! + real(r8), intent(in) :: to3(pcols) ! o3 overlap factor + real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum path length + real(r8), intent(in) :: w(pcols,pverp) ! h2o path length + real(r8), intent(in) :: up2(pcols) ! pressure squared h2o path length +! + integer, intent(in) :: k ! level index + + real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn. + +! +! Output Arguments +! + real(r8), intent(out) :: emstrc(pcols,pverp) ! total trace gas emissivity + +! +!--------------------------Local Variables------------------------------ +! + integer i,l ! loop counters +! + real(r8) sqti(pcols) ! square root of mean temp + real(r8) ecfc1 ! emissivity of cfc11 798 cm-1 band + real(r8) ecfc2 ! " " " 846 cm-1 band + real(r8) ecfc3 ! " " " 933 cm-1 band + real(r8) ecfc4 ! " " " 1085 cm-1 band +! + real(r8) ecfc5 ! " " cfc12 889 cm-1 band + real(r8) ecfc6 ! " " " 923 cm-1 band + real(r8) ecfc7 ! " " " 1102 cm-1 band + real(r8) ecfc8 ! " " " 1161 cm-1 band + real(r8) u01 ! n2o path length +! + real(r8) u11 ! n2o path length + real(r8) beta01 ! n2o pressure factor + real(r8) beta11 ! n2o pressure factor + real(r8) en2o1 ! emissivity of the 1285 cm-1 N2O band + real(r8) u02 ! n2o path length +! + real(r8) u12 ! n2o path length + real(r8) beta02 ! n2o pressure factor + real(r8) en2o2 ! emissivity of the 589 cm-1 N2O band + real(r8) u03 ! n2o path length + real(r8) beta03 ! n2o pressure factor +! + real(r8) en2o3 ! emissivity of the 1168 cm-1 N2O band + real(r8) betac ! ch4 pressure factor + real(r8) ech4 ! emissivity of 1306 cm-1 CH4 band + real(r8) betac1 ! co2 pressure factor + real(r8) betac2 ! co2 pressure factor +! + real(r8) eco21 ! emissivity of 1064 cm-1 CO2 band + real(r8) eco22 ! emissivity of 961 cm-1 CO2 band + real(r8) tt(pcols) ! temp. factor for h2o overlap factor + real(r8) psi1 ! narrow band h2o temp. factor + real(r8) phi1 ! " +! + real(r8) p1 ! h2o line overlap factor + real(r8) w1 ! " + real(r8) tw(pcols,6) ! h2o transmission overlap + real(r8) g1(6) ! h2o overlap factor + real(r8) g2(6) ! " +! + real(r8) g3(6) ! " + real(r8) g4(6) ! " + real(r8) ab(6) ! " + real(r8) bb(6) ! " + real(r8) abp(6) ! " +! + real(r8) bbp(6) ! " + real(r8) tcfc3 ! transmission for cfc11 band + real(r8) tcfc4 ! " + real(r8) tcfc6 ! transmission for cfc12 band + real(r8) tcfc7 ! " +! + real(r8) tcfc8 ! " + real(r8) tlw ! h2o overlap factor + real(r8) tch4 ! ch4 overlap factor +! +!--------------------------Data Statements------------------------------ +! + data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/ + data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/ + data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/ + data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/ + data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/ + data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/ + data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/ + data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/ +! +!--------------------------Statement Functions-------------------------- +! + real(r8) func, u, b + func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b)) +! +!----------------------------------------------------------------------- +! + do i = 1,ncol + sqti(i) = sqrt(co2t(i,k)) +! +! Transmission for h2o +! + tt(i) = abs(co2t(i,k) - 250.0) + end do +! + do l = 1,6 + do i = 1,ncol + psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i)) + phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i)) + p1 = pnm(i,k) * (psi1/phi1) / sslp + w1 = w(i,k) * phi1 + tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) & + - g3(l)*s2c(i,k)-g4(l)*uptype(i,k)) + end do + end do + +! Overlap H2O tranmission with STRAER continuum in 6 trace gas +! subbands + + do i=1,ncol + tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k,1,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1 + 0.3*aer_trn_ttl(i,k,1,idx_LW_0800_1000)) + tw(i,2)=tw(i,2)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1 + tw(i,3)=tw(i,3)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1 + tw(i,4)=tw(i,4)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1 + tw(i,5)=tw(i,5)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1 + tw(i,6)=tw(i,6)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1 + end do ! end loop over lon +! + do i = 1,ncol +! +! transmission due to cfc bands +! + tcfc3 = exp(-175.005*ucfc11(i,k)) + tcfc4 = exp(-1202.18*ucfc11(i,k)) + tcfc6 = exp(-5786.73*ucfc12(i,k)) + tcfc7 = exp(-2873.51*ucfc12(i,k)) + tcfc8 = exp(-2085.59*ucfc12(i,k)) +! +! Emissivity for CFC11 bands +! + ecfc1 = 50.0*(1.0 - exp(-54.09*ucfc11(i,k))) * tw(i,1) * emplnk(7,i) + ecfc2 = 60.0*(1.0 - exp(-5130.03*ucfc11(i,k)))* tw(i,2) * emplnk(8,i) + ecfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*emplnk(9,i) + ecfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*emplnk(10,i) +! +! Emissivity for CFC12 bands +! + ecfc5 = 45.0*(1.0 - exp(-1272.35*ucfc12(i,k)))*tw(i,3)*emplnk(11,i) + ecfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*emplnk(12,i) + ecfc7 = 80.0*(1.0 - tcfc7)*tw(i,5)* tcfc4 * emplnk(13,i) + ecfc8 = 70.0*(1.0 - tcfc8)*tw(i,6) * emplnk(14,i) +! +! Emissivity for CH4 band 1306 cm-1 +! + tlw = exp(-1.0*sqrt(up2(i))) + +! Overlap H2O vibration rotation band with STRAER continuum +! for CH4 1306 cm-1 and N2O 1285 cm-1 bands + + tlw=tlw*aer_trn_ttl(i,k,1,idx_LW_1200_2000) + betac = bch4(i,k)/uch4(i,k) + ech4 = 6.00444*sqti(i)*log(1.0 + func(uch4(i,k),betac)) *tlw * emplnk(3,i) + tch4 = 1.0/(1.0 + 0.02*func(uch4(i,k),betac)) +! +! Emissivity for N2O bands +! + u01 = un2o0(i,k) + u11 = un2o1(i,k) + beta01 = bn2o0(i,k)/un2o0(i,k) + beta11 = bn2o1(i,k)/un2o1(i,k) +! +! 1285 cm-1 band +! + en2o1 = 2.35558*sqti(i)*log(1.0 + func(u01,beta01) + & + func(u11,beta11))*tlw*tch4*emplnk(4,i) + u02 = 0.100090*u01 + u12 = 0.0992746*u11 + beta02 = 0.964282*beta01 +! +! 589 cm-1 band +! + en2o2 = 2.65581*sqti(i)*log(1.0 + func(u02,beta02) + & + func(u12,beta02)) * tco2(i) * th2o(i) * emplnk(5,i) + u03 = 0.0333767*u01 + beta03 = 0.982143*beta01 +! +! 1168 cm-1 band +! + en2o3 = 2.54034*sqti(i)*log(1.0 + func(u03,beta03)) * & + tw(i,6) * tcfc8 * emplnk(6,i) +! +! Emissivity for 1064 cm-1 band of CO2 +! + betac1 = 2.97558*pnm(i,k) / (sslp*sqti(i)) + betac2 = 2.0 * betac1 + eco21 = 3.7571*sqti(i)*log(1.0 + func(uco211(i,k),betac1) & + + func(uco212(i,k),betac2) + func(uco213(i,k),betac2)) & + * to3(i) * tw(i,5) * tcfc4 * tcfc7 * emplnk(2,i) +! +! Emissivity for 961 cm-1 band +! + eco22 = 3.8443*sqti(i)*log(1.0 + func(uco221(i,k),betac1) & + + func(uco222(i,k),betac1) + func(uco223(i,k),betac2)) & + * tw(i,4) * tcfc3 * tcfc6 * emplnk(1,i) +! +! total trace gas emissivity +! + emstrc(i,k) = ecfc1 + ecfc2 + ecfc3 + ecfc4 + ecfc5 +ecfc6 + & + ecfc7 + ecfc8 + en2o1 + en2o2 + en2o3 + ech4 + & + eco21 + eco22 + end do +! + return +! +end subroutine trcems + +subroutine trcmix(lchnk ,ncol ,pcols, pver, & + pmid ,clat, n2o ,ch4 , & + cfc11 , cfc12 ) +!----------------------------------------------------------------------- +! +! Purpose: +! Specify zonal mean mass mixing ratios of CH4, N2O, CFC11 and +! CFC12 +! +! Method: +! Distributions assume constant mixing ratio in the troposphere +! and a decrease of mixing ratio in the stratosphere. Tropopause +! defined by ptrop. The scale height of the particular trace gas +! depends on latitude. This assumption produces a more realistic +! stratospheric distribution of the various trace gases. +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use phys_grid, only: get_rlat_all_p +! use physconst, only: mwdry, mwch4, mwn2o, mwf11, mwf12 +! use ghg_surfvals, only: ch4vmr, n2ovmr, f11vmr, f12vmr + + implicit none + +!-----------------------------Arguments--------------------------------- +! +! Input +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver + + real(r8), intent(in) :: pmid(pcols,pver) ! model pressures + real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns +! +! Output +! + real(r8), intent(out) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio + real(r8), intent(out) :: ch4(pcols,pver) ! methane mass mixing ratio + real(r8), intent(out) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio + real(r8), intent(out) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio + +! +!--------------------------Local Variables------------------------------ + + real(r8) :: rmwn2o ! ratio of molecular weight n2o to dry air + real(r8) :: rmwch4 ! ratio of molecular weight ch4 to dry air + real(r8) :: rmwf11 ! ratio of molecular weight cfc11 to dry air + real(r8) :: rmwf12 ! ratio of molecular weight cfc12 to dry air +! + integer i ! longitude loop index + integer k ! level index +! +! real(r8) clat(pcols) ! latitude in radians for columns + real(r8) coslat(pcols) ! cosine of latitude + real(r8) dlat ! latitude in degrees + real(r8) ptrop ! pressure level of tropopause + real(r8) pratio ! pressure divided by ptrop +! + real(r8) xn2o ! pressure scale height for n2o + real(r8) xch4 ! pressure scale height for ch4 + real(r8) xcfc11 ! pressure scale height for cfc11 + real(r8) xcfc12 ! pressure scale height for cfc12 +! + real(r8) ch40 ! tropospheric mass mixing ratio for ch4 + real(r8) n2o0 ! tropospheric mass mixing ratio for n2o + real(r8) cfc110 ! tropospheric mass mixing ratio for cfc11 + real(r8) cfc120 ! tropospheric mass mixing ratio for cfc12 +! +!----------------------------------------------------------------------- + rmwn2o = mwn2o/mwdry ! ratio of molecular weight n2o to dry air + rmwch4 = mwch4/mwdry ! ratio of molecular weight ch4 to dry air + rmwf11 = mwf11/mwdry ! ratio of molecular weight cfc11 to dry air + rmwf12 = mwf12/mwdry ! ratio of molecular weight cfc12 to dry air +! +! get latitudes +! +! call get_rlat_all_p(lchnk, ncol, clat) + do i = 1, ncol + coslat(i) = cos(clat(i)) + end do +! +! set tropospheric mass mixing ratios +! + ch40 = rmwch4 * ch4vmr + n2o0 = rmwn2o * n2ovmr + cfc110 = rmwf11 * f11vmr + cfc120 = rmwf12 * f12vmr + + do i = 1, ncol + coslat(i) = cos(clat(i)) + end do +! + do k = 1,pver + do i = 1,ncol +! +! set stratospheric scale height factor for gases + dlat = abs(57.2958 * clat(i)) + if(dlat.le.45.0) then + xn2o = 0.3478 + 0.00116 * dlat + xch4 = 0.2353 + xcfc11 = 0.7273 + 0.00606 * dlat + xcfc12 = 0.4000 + 0.00222 * dlat + else + xn2o = 0.4000 + 0.013333 * (dlat - 45) + xch4 = 0.2353 + 0.0225489 * (dlat - 45) + xcfc11 = 1.00 + 0.013333 * (dlat - 45) + xcfc12 = 0.50 + 0.024444 * (dlat - 45) + end if +! +! pressure of tropopause + ptrop = 250.0e2 - 150.0e2*coslat(i)**2.0 +! +! determine output mass mixing ratios + if (pmid(i,k) >= ptrop) then + ch4(i,k) = ch40 + n2o(i,k) = n2o0 + cfc11(i,k) = cfc110 + cfc12(i,k) = cfc120 + else + pratio = pmid(i,k)/ptrop + ch4(i,k) = ch40 * (pratio)**xch4 + n2o(i,k) = n2o0 * (pratio)**xn2o + cfc11(i,k) = cfc110 * (pratio)**xcfc11 + cfc12(i,k) = cfc120 * (pratio)**xcfc12 + end if + end do + end do +! + return +! +end subroutine trcmix + +subroutine trcplk(lchnk ,ncol ,pcols, pver, pverp, & + tint ,tlayr ,tplnke ,emplnk ,abplnk1 , & + abplnk2 ) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate Planck factors for absorptivity and emissivity of +! CH4, N2O, CFC11 and CFC12 +! +! Method: +! Planck function and derivative evaluated at the band center. +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid + + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: tint(pcols,pverp) ! interface temperatures + real(r8), intent(in) :: tlayr(pcols,pverp) ! k-1 level temperatures + real(r8), intent(in) :: tplnke(pcols) ! Top Layer temperature +! +! output arguments +! + real(r8), intent(out) :: emplnk(14,pcols) ! emissivity Planck factor + real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor + real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor + +! +!--------------------------Local Variables------------------------------ +! + integer wvl ! wavelength index + integer i,k ! loop counters +! + real(r8) f1(14) ! Planck function factor + real(r8) f2(14) ! " + real(r8) f3(14) ! " +! +!--------------------------Data Statements------------------------------ +! + data f1 /5.85713e8,7.94950e8,1.47009e9,1.40031e9,1.34853e8, & + 1.05158e9,3.35370e8,3.99601e8,5.35994e8,8.42955e8, & + 4.63682e8,5.18944e8,8.83202e8,1.03279e9/ + data f2 /2.02493e11,3.04286e11,6.90698e11,6.47333e11, & + 2.85744e10,4.41862e11,9.62780e10,1.21618e11, & + 1.79905e11,3.29029e11,1.48294e11,1.72315e11, & + 3.50140e11,4.31364e11/ + data f3 /1383.0,1531.0,1879.0,1849.0,848.0,1681.0, & + 1148.0,1217.0,1343.0,1561.0,1279.0,1328.0, & + 1586.0,1671.0/ +! +!----------------------------------------------------------------------- +! +! Calculate emissivity Planck factor +! + do wvl = 1,14 + do i = 1,ncol + emplnk(wvl,i) = f1(wvl)/(tplnke(i)**4.0*(exp(f3(wvl)/tplnke(i))-1.0)) + end do + end do +! +! Calculate absorptivity Planck factor for tint and tlayr temperatures +! + do wvl = 1,14 + do k = ntoplw, pverp + do i = 1, ncol +! +! non-nearlest layer function +! + abplnk1(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tint(i,k))) & + /(tint(i,k)**5.0*(exp(f3(wvl)/tint(i,k))-1.0)**2.0) +! +! nearest layer function +! + abplnk2(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tlayr(i,k))) & + /(tlayr(i,k)**5.0*(exp(f3(wvl)/tlayr(i,k))-1.0)**2.0) + end do + end do + end do +! + return +end subroutine trcplk + +subroutine trcpth(lchnk ,ncol ,pcols, pver, pverp, & + tnm ,pnm ,cfc11 ,cfc12 ,n2o , & + ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , & + un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , & + uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , & + bch4 ,uptype ) +!----------------------------------------------------------------------- +! +! Purpose: +! Calculate path lengths and pressure factors for CH4, N2O, CFC11 +! and CFC12. +! +! Method: +! See CCM3 description for details +! +! Author: J. Kiehl +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid +! use ghg_surfvals, only: co2mmr + + implicit none + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures + real(r8), intent(in) :: pnm(pcols,pverp) ! Pres. at model interfaces (dynes/cm2) + real(r8), intent(in) :: qnm(pcols,pver) ! h2o specific humidity + real(r8), intent(in) :: cfc11(pcols,pver) ! CFC11 mass mixing ratio +! + real(r8), intent(in) :: cfc12(pcols,pver) ! CFC12 mass mixing ratio + real(r8), intent(in) :: n2o(pcols,pver) ! N2O mass mixing ratio + real(r8), intent(in) :: ch4(pcols,pver) ! CH4 mass mixing ratio + +! +! Output arguments +! + real(r8), intent(out) :: ucfc11(pcols,pverp) ! CFC11 path length + real(r8), intent(out) :: ucfc12(pcols,pverp) ! CFC12 path length + real(r8), intent(out) :: un2o0(pcols,pverp) ! N2O path length + real(r8), intent(out) :: un2o1(pcols,pverp) ! N2O path length (hot band) + real(r8), intent(out) :: uch4(pcols,pverp) ! CH4 path length +! + real(r8), intent(out) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(out) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(out) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length + real(r8), intent(out) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(out) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length +! + real(r8), intent(out) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length + real(r8), intent(out) :: bn2o0(pcols,pverp) ! pressure factor for n2o + real(r8), intent(out) :: bn2o1(pcols,pverp) ! pressure factor for n2o + real(r8), intent(out) :: bch4(pcols,pverp) ! pressure factor for ch4 + real(r8), intent(out) :: uptype(pcols,pverp) ! p-type continuum path length + +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer k ! Level index +! + real(r8) co2fac(pcols,1) ! co2 factor + real(r8) alpha1(pcols) ! stimulated emission term + real(r8) alpha2(pcols) ! stimulated emission term + real(r8) rt(pcols) ! reciprocal of local temperature + real(r8) rsqrt(pcols) ! reciprocal of sqrt of temp +! + real(r8) pbar(pcols) ! mean pressure + real(r8) dpnm(pcols) ! difference in pressure + real(r8) diff ! diffusivity factor +! +!--------------------------Data Statements------------------------------ +! + data diff /1.66/ +! +!----------------------------------------------------------------------- +! +! Calculate path lengths for the trace gases at model top +! + do i = 1,ncol + ucfc11(i,ntoplw) = 1.8 * cfc11(i,ntoplw) * pnm(i,ntoplw) * rga + ucfc12(i,ntoplw) = 1.8 * cfc12(i,ntoplw) * pnm(i,ntoplw) * rga + un2o0(i,ntoplw) = diff * 1.02346e5 * n2o(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw)) + un2o1(i,ntoplw) = diff * 2.01909 * un2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw)) + uch4(i,ntoplw) = diff * 8.60957e4 * ch4(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw)) + co2fac(i,1) = diff * co2mmr * pnm(i,ntoplw) * rga + alpha1(i) = (1.0 - exp(-1540.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw)) + alpha2(i) = (1.0 - exp(-1360.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw)) + uco211(i,ntoplw) = 3.42217e3 * co2fac(i,1) * alpha1(i) * exp(-1849.7/tnm(i,ntoplw)) + uco212(i,ntoplw) = 6.02454e3 * co2fac(i,1) * alpha1(i) * exp(-2782.1/tnm(i,ntoplw)) + uco213(i,ntoplw) = 5.53143e3 * co2fac(i,1) * alpha1(i) * exp(-3723.2/tnm(i,ntoplw)) + uco221(i,ntoplw) = 3.88984e3 * co2fac(i,1) * alpha2(i) * exp(-1997.6/tnm(i,ntoplw)) + uco222(i,ntoplw) = 3.67108e3 * co2fac(i,1) * alpha2(i) * exp(-3843.8/tnm(i,ntoplw)) + uco223(i,ntoplw) = 6.50642e3 * co2fac(i,1) * alpha2(i) * exp(-2989.7/tnm(i,ntoplw)) + bn2o0(i,ntoplw) = diff * 19.399 * pnm(i,ntoplw)**2.0 * n2o(i,ntoplw) * & + 1.02346e5 * rga / (sslp*tnm(i,ntoplw)) + bn2o1(i,ntoplw) = bn2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw)) * 2.06646e5 + bch4(i,ntoplw) = diff * 2.94449 * ch4(i,ntoplw) * pnm(i,ntoplw)**2.0 * rga * & + 8.60957e4 / (sslp*tnm(i,ntoplw)) + uptype(i,ntoplw) = diff * qnm(i,ntoplw) * pnm(i,ntoplw)**2.0 * & + exp(1800.0*(1.0/tnm(i,ntoplw) - 1.0/296.0)) * rga / sslp + end do +! +! Calculate trace gas path lengths through model atmosphere +! + do k = ntoplw,pver + do i = 1,ncol + rt(i) = 1./tnm(i,k) + rsqrt(i) = sqrt(rt(i)) + pbar(i) = 0.5 * (pnm(i,k+1) + pnm(i,k)) / sslp + dpnm(i) = (pnm(i,k+1) - pnm(i,k)) * rga + alpha1(i) = diff * rsqrt(i) * (1.0 - exp(-1540.0/tnm(i,k)))**3.0 + alpha2(i) = diff * rsqrt(i) * (1.0 - exp(-1360.0/tnm(i,k)))**3.0 + ucfc11(i,k+1) = ucfc11(i,k) + 1.8 * cfc11(i,k) * dpnm(i) + ucfc12(i,k+1) = ucfc12(i,k) + 1.8 * cfc12(i,k) * dpnm(i) + un2o0(i,k+1) = un2o0(i,k) + diff * 1.02346e5 * n2o(i,k) * rsqrt(i) * dpnm(i) + un2o1(i,k+1) = un2o1(i,k) + diff * 2.06646e5 * n2o(i,k) * & + rsqrt(i) * exp(-847.36/tnm(i,k)) * dpnm(i) + uch4(i,k+1) = uch4(i,k) + diff * 8.60957e4 * ch4(i,k) * rsqrt(i) * dpnm(i) + uco211(i,k+1) = uco211(i,k) + 1.15*3.42217e3 * alpha1(i) * & + co2mmr * exp(-1849.7/tnm(i,k)) * dpnm(i) + uco212(i,k+1) = uco212(i,k) + 1.15*6.02454e3 * alpha1(i) * & + co2mmr * exp(-2782.1/tnm(i,k)) * dpnm(i) + uco213(i,k+1) = uco213(i,k) + 1.15*5.53143e3 * alpha1(i) * & + co2mmr * exp(-3723.2/tnm(i,k)) * dpnm(i) + uco221(i,k+1) = uco221(i,k) + 1.15*3.88984e3 * alpha2(i) * & + co2mmr * exp(-1997.6/tnm(i,k)) * dpnm(i) + uco222(i,k+1) = uco222(i,k) + 1.15*3.67108e3 * alpha2(i) * & + co2mmr * exp(-3843.8/tnm(i,k)) * dpnm(i) + uco223(i,k+1) = uco223(i,k) + 1.15*6.50642e3 * alpha2(i) * & + co2mmr * exp(-2989.7/tnm(i,k)) * dpnm(i) + bn2o0(i,k+1) = bn2o0(i,k) + diff * 19.399 * pbar(i) * rt(i) & + * 1.02346e5 * n2o(i,k) * dpnm(i) + bn2o1(i,k+1) = bn2o1(i,k) + diff * 19.399 * pbar(i) * rt(i) & + * 2.06646e5 * exp(-847.36/tnm(i,k)) * n2o(i,k)*dpnm(i) + bch4(i,k+1) = bch4(i,k) + diff * 2.94449 * rt(i) * pbar(i) & + * 8.60957e4 * ch4(i,k) * dpnm(i) + uptype(i,k+1) = uptype(i,k) + diff *qnm(i,k) * & + exp(1800.0*(1.0/tnm(i,k) - 1.0/296.0)) * pbar(i) * dpnm(i) + end do + end do +! + return +end subroutine trcpth +subroutine aqsat(t ,p ,es ,qs ,ii , & + ilen ,kk ,kstart ,kend ) +!----------------------------------------------------------------------- +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk) +! This routine is useful for evaluating only a selected region in the +! vertical. +! +! Method: +! +! +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ii ! I dimension of arrays t, p, es, qs + integer, intent(in) :: kk ! K dimension of arrays t, p, es, qs + integer, intent(in) :: ilen ! Length of vectors in I direction which + integer, intent(in) :: kstart ! Starting location in K direction + integer, intent(in) :: kend ! Ending location in K direction + real(r8), intent(in) :: t(ii,kk) ! Temperature + real(r8), intent(in) :: p(ii,kk) ! Pressure +! +! Output arguments +! + real(r8), intent(out) :: es(ii,kk) ! Saturation vapor pressure + real(r8), intent(out) :: qs(ii,kk) ! Saturation specific humidity +! +!---------------------------Local workspace----------------------------- +! + real(r8) omeps ! 1 - 0.622 + integer i, k ! Indices +! +!----------------------------------------------------------------------- +! + omeps = 1.0 - epsqs + do k=kstart,kend + do i=1,ilen + es(i,k) = estblf(t(i,k)) +! +! Saturation specific humidity +! + qs(i,k) = epsqs*es(i,k)/(p(i,k) - omeps*es(i,k)) +! +! The following check is to avoid the generation of negative values +! that can occur in the upper stratosphere and mesosphere +! + qs(i,k) = min(1.0_r8,qs(i,k)) +! + if (qs(i,k) < 0.0) then + qs(i,k) = 1.0 + es(i,k) = p(i,k) + end if + end do + end do +! + return +end subroutine aqsat +!=============================================================================== + subroutine cldefr(lchnk ,ncol ,pcols, pver, pverp, & + landfrac,t ,rel ,rei ,ps ,pmid , landm, icefrac, snowh) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute cloud water and ice particle size +! +! Method: +! use empirical formulas to construct effective radii +! +! Author: J.T. Kiehl, B. A. Boville, P. Rasch +! +!----------------------------------------------------------------------- + + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: landfrac(pcols) ! Land fraction + real(r8), intent(in) :: icefrac(pcols) ! Ice fraction + real(r8), intent(in) :: t(pcols,pver) ! Temperature + real(r8), intent(in) :: ps(pcols) ! Surface pressure + real(r8), intent(in) :: pmid(pcols,pver) ! Midpoint pressures + real(r8), intent(in) :: landm(pcols) + real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) +! +! Output arguments +! + real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns) + real(r8), intent(out) :: rei(pcols,pver) ! Ice effective drop size (microns) +! + +!++pjr +! following Kiehl + call reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh) + +! following Kristjansson and Mitchell + call reitab(ncol, pcols, pver, t, rei) +!--pjr +! +! + return + end subroutine cldefr + +!=============================================================================== + subroutine cldems(lchnk ,ncol ,pcols, pver, pverp, clwp ,fice ,rei ,emis ) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute cloud emissivity using cloud liquid water path (g/m**2) +! +! Method: +! +! +! +! Author: J.T. Kiehl +! +!----------------------------------------------------------------------- + + implicit none +!------------------------------Parameters------------------------------- +! + real(r8) kabsl ! longwave liquid absorption coeff (m**2/g) + parameter (kabsl = 0.090361) +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: clwp(pcols,pver) ! cloud liquid water path (g/m**2) + real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns) + real(r8), intent(in) :: fice(pcols,pver) ! fractional ice content within cloud +! +! Output arguments +! + real(r8), intent(out) :: emis(pcols,pver) ! cloud emissivity (fraction) +! +!---------------------------Local workspace----------------------------- +! + integer i,k ! longitude, level indices + real(r8) kabs ! longwave absorption coeff (m**2/g) + real(r8) kabsi ! ice absorption coefficient +! +!----------------------------------------------------------------------- +! + do k=1,pver + do i=1,ncol + kabsi = 0.005 + 1./rei(i,k) + kabs = kabsl*(1.-fice(i,k)) + kabsi*fice(i,k) + emis(i,k) = 1. - exp(-1.66*kabs*clwp(i,k)) + end do + end do +! + return + end subroutine cldems + +!=============================================================================== + subroutine cldovrlap(lchnk ,ncol ,pcols, pver, pverp, pint ,cld ,nmxrgn ,pmxrgn ) +!----------------------------------------------------------------------- +! +! Purpose: +! Partitions each column into regions with clouds in neighboring layers. +! This information is used to implement maximum overlap in these regions +! with random overlap between them. +! On output, +! nmxrgn contains the number of regions in each column +! pmxrgn contains the interface pressures for the lower boundaries of +! each region! +! Method: + +! +! Author: W. Collins +! +!----------------------------------------------------------------------- + + implicit none +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure + real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover +! +! Output arguments +! + real(r8), intent(out) :: pmxrgn(pcols,pverp)! Maximum values of pressure for each +! maximally overlapped region. +! 0->pmxrgn(i,1) is range of pressure for +! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for +! 2nd region, etc + integer nmxrgn(pcols) ! Number of maximally overlapped regions +! +!---------------------------Local variables----------------------------- +! + integer i ! Longitude index + integer k ! Level index + integer n ! Max-overlap region counter + + real(r8) pnm(pcols,pverp) ! Interface pressure + + logical cld_found ! Flag for detection of cloud + logical cld_layer(pver) ! Flag for cloud in layer +! +!------------------------------------------------------------------------ +! + + do i = 1, ncol + cld_found = .false. + cld_layer(:) = cld(i,:) > 0.0_r8 + pmxrgn(i,:) = 0.0 + pnm(i,:)=pint(i,:)*10. + n = 1 + do k = 1, pver + if (cld_layer(k) .and. .not. cld_found) then + cld_found = .true. + else if ( .not. cld_layer(k) .and. cld_found) then + cld_found = .false. + if (count(cld_layer(k:pver)) == 0) then + exit + endif + pmxrgn(i,n) = pnm(i,k) + n = n + 1 + endif + end do + pmxrgn(i,n) = pnm(i,pverp) + nmxrgn(i) = n + end do + + return + end subroutine cldovrlap + +!=============================================================================== + subroutine cldclw(lchnk ,ncol ,pcols, pver, pverp, zi ,clwp ,tpw ,hl ) +!----------------------------------------------------------------------- +! +! Purpose: +! Evaluate cloud liquid water path clwp (g/m**2) +! +! Method: +! +! +! +! Author: J.T. Kiehl +! +!----------------------------------------------------------------------- + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: pcols, pver, pverp + + real(r8), intent(in) :: zi(pcols,pverp) ! height at layer interfaces(m) + real(r8), intent(in) :: tpw(pcols) ! total precipitable water (mm) +! +! Output arguments +! + real(r8) clwp(pcols,pver) ! cloud liquid water path (g/m**2) + real(r8) hl(pcols) ! liquid water scale height + real(r8) rhl(pcols) ! 1/hl + +! +!---------------------------Local workspace----------------------------- +! + integer i,k ! longitude, level indices + real(r8) clwc0 ! reference liquid water concentration (g/m**3) + real(r8) emziohl(pcols,pverp) ! exp(-zi/hl) +! +!----------------------------------------------------------------------- +! +! Set reference liquid water concentration +! + clwc0 = 0.21 +! +! Diagnose liquid water scale height from precipitable water +! + do i=1,ncol + hl(i) = 700.0*log(max(tpw(i)+1.0_r8,1.0_r8)) + rhl(i) = 1.0/hl(i) + end do +! +! Evaluate cloud liquid water path (vertical integral of exponential fn) +! + do k=1,pverp + do i=1,ncol + emziohl(i,k) = exp(-zi(i,k)*rhl(i)) + end do + end do + do k=1,pver + do i=1,ncol + clwp(i,k) = clwc0*hl(i)*(emziohl(i,k+1) - emziohl(i,k)) + end do + end do +! + return + end subroutine cldclw + + +!=============================================================================== + subroutine reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute cloud water size +! +! Method: +! analytic formula following the formulation originally developed by J. T. Kiehl +! +! Author: Phil Rasch +! +!----------------------------------------------------------------------- +! use physconst, only: tmelt + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ncol + integer, intent(in) :: pcols, pver + real(r8), intent(in) :: landfrac(pcols) ! Land fraction + real(r8), intent(in) :: icefrac(pcols) ! Ice fraction + real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) + real(r8), intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean + real(r8), intent(in) :: t(pcols,pver) ! Temperature + +! +! Output arguments +! + real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns) +! +!---------------------------Local workspace----------------------------- +! + integer i,k ! Lon, lev indices + real(r8) rliqland ! liquid drop size if over land + real(r8) rliqocean ! liquid drop size if over ocean + real(r8) rliqice ! liquid drop size if over sea ice +! +!----------------------------------------------------------------------- +! + rliqocean = 14.0_r8 + rliqice = 14.0_r8 + rliqland = 8.0_r8 + do k=1,pver + do i=1,ncol +! jrm Reworked effective radius algorithm + ! Start with temperature-dependent value appropriate for continental air + ! Note: findmcnew has a pressure dependence here + rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0_r8,max(0.0_r8,(tmelt-t(i,k))*0.05)) + ! Modify for snow depth over land + rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,snowh(i)*10.)) + ! Ramp between polluted value over land to clean value over ocean. + rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,1.0-landm(i))) + ! Ramp between the resultant value and a sea ice value in the presence of ice. + rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0_r8,max(0.0_r8,icefrac(i))) +! end jrm + end do + end do + end subroutine reltab + +!=============================================================================== + subroutine reitab(ncol, pcols, pver, t, re) + ! + + integer, intent(in) :: ncol, pcols, pver + real(r8), intent(out) :: re(pcols,pver) + real(r8), intent(in) :: t(pcols,pver) + real(r8) retab(95) + real(r8) corr + integer i + integer k + integer index + ! + ! Tabulated values of re(T) in the temperature interval + ! 180 K -- 274 K; hexagonal columns assumed: + ! + data retab / & + 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ + ! + save retab + ! + do k=1,pver + do i=1,ncol + index = int(t(i,k)-179.) + index = min(max(index,1),94) + corr = t(i,k) - int(t(i,k)) + re(i,k) = retab(index)*(1.-corr) & + +retab(index+1)*corr + ! re(i,k) = amax1(amin1(re(i,k),30.),10.) + end do + end do + ! + return + end subroutine reitab + + +function findvalue(ix,n,ain,indxa) +!----------------------------------------------------------------------- +! +! Purpose: +! Subroutine for finding ix-th smallest value in the array +! The elements are rearranged so that the ix-th smallest +! element is in the ix place and all smaller elements are +! moved to the elements up to ix (with random order). +! +! Algorithm: Based on the quicksort algorithm. +! +! Author: T. Craig +! +!----------------------------------------------------------------------- +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +! arguments +! + integer, intent(in) :: ix ! element to search for + integer, intent(in) :: n ! total number of elements + integer, intent(inout):: indxa(n) ! array of integers + real(r8), intent(in) :: ain(n) ! array to search +! + integer findvalue ! return value +! +! local variables +! + integer i,j + integer il,im,ir + + integer ia + integer itmp +! +!---------------------------Routine----------------------------- +! + il=1 + ir=n + do + if (ir-il <= 1) then + if (ir-il == 1) then + if (ain(indxa(ir)) < ain(indxa(il))) then + itmp=indxa(il) + indxa(il)=indxa(ir) + indxa(ir)=itmp + endif + endif + findvalue=indxa(ix) + return + else + im=(il+ir)/2 + itmp=indxa(im) + indxa(im)=indxa(il+1) + indxa(il+1)=itmp + if (ain(indxa(il+1)) > ain(indxa(ir))) then + itmp=indxa(il+1) + indxa(il+1)=indxa(ir) + indxa(ir)=itmp + endif + if (ain(indxa(il)) > ain(indxa(ir))) then + itmp=indxa(il) + indxa(il)=indxa(ir) + indxa(ir)=itmp + endif + if (ain(indxa(il+1)) > ain(indxa(il))) then + itmp=indxa(il+1) + indxa(il+1)=indxa(il) + indxa(il)=itmp + endif + i=il+1 + j=ir + ia=indxa(il) + do + do + i=i+1 + if (ain(indxa(i)) >= ain(ia)) exit + end do + do + j=j-1 + if (ain(indxa(j)) <= ain(ia)) exit + end do + if (j < i) exit + itmp=indxa(i) + indxa(i)=indxa(j) + indxa(j)=itmp + end do + indxa(il)=indxa(j) + indxa(j)=ia + if (j >= ix)ir=j-1 + if (j <= ix)il=i + endif + end do +end function findvalue + +#endif + + + +END MODULE module_ra_cam diff --git a/wrfv2_fire/phys/module_ra_gfdleta.F b/wrfv2_fire/phys/module_ra_gfdleta.F new file mode 100755 index 00000000..99aec5fe --- /dev/null +++ b/wrfv2_fire/phys/module_ra_gfdleta.F @@ -0,0 +1,10245 @@ +!WRF:MODEL_RA:RADIATION +! +#define FERRIER_GFDL +MODULE MODULE_RA_GFDLETA + USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE + USE MODULE_MODEL_CONSTANTS +#ifdef FERRIER_GFDL + USE MODULE_MP_ETANEW, ONLY : & + & RHgrd,T_ICE,FPVS,QAUT0,XMImax,XMIexp,MDImin,MDImax,MASSI, & + & FLARGE1,FLARGE2,NLImin,NLImax +#endif + INTEGER,PARAMETER :: NL=81 + INTEGER,PARAMETER :: NBLY=15 + REAL,PARAMETER :: RTHRESH=1.E-15,DTR=1./DEGRAD + + INTEGER, SAVE, DIMENSION(3) :: LTOP + REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 + REAL , SAVE, DIMENSION(NL) :: PRGFDL + REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R + + REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), & + TABLE2(28,180),TABLE3(28,180),EM3(28,180), & + SOURCE(28,NBLY), DSRCE(28,NBLY) + + REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V + REAL ,SAVE :: R1,RSIN1,RCOS1,RCOS2 +! Created by CO2 initialization + REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,& + C2D58,CO258 + REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, & + C2D31,C2D38,CDT31,CDT38, & + CO271,CO278,C2D71,C2D78, & + CDT71,CDT78 + REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, & + C2DM51,C2DM58 + CHARACTER(256) :: ERRMESS + +! Used by CO2 initialization +! COMMON/PRESS/PA(109) +! COMMON/TRAN/ TRANSA(109,109) +! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP + REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV + REAL ,SAVE, DIMENSION(109,109) :: TRANSA + REAL ,SAVE :: CORE,UEXP,SEXP + + EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) + EQUIVALENCE (EM3V(1),EM3(1,1)) + EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & + (T4(1),TABLE3(1,1)) + REAL,SAVE,DIMENSION(4) :: PTOPC +! +!--- Used for Gaussian look up tables +! + REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01 + INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD + REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD + REAL, PRIVATE :: RSQR + LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE. + + +#ifndef FERRIER_GFDL + REAL, PRIVATE, PARAMETER :: RHgrd=1.0 + REAL, PRIVATE, PARAMETER :: T_ice=-30.0 +#endif + +! +!--- Important parameters for cloud properties - see extensive comments in +! DO 580 loop within subroutine RADTN +! + REAL, PARAMETER :: & + & TRAD_ice=0.5*T_ice & !--- Very tunable parameter + &, ABSCOEF_W=800. & !--- Very tunable parameter + &, ABSCOEF_I=500. & !--- Very tunable parameter + &, SECANG=-1.66 & !--- Very tunable parameter + &, CLDCOEF_LW=1.5 & !--- Enhance LW cloud depths + &, ABSCOEF_LW=SECANG*CLDCOEF_LW & !--- Final factor for cloud emissivities + &, Qconv=0.1e-3 & !--- Very tunable parameter + &, CTauCW=ABSCOEF_W*Qconv & + &, CTauCI=ABSCOEF_I*Qconv +! + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP, & + & JULYR,MONTH,IDAY,GMT, & + & CONFIG_FLAGS,ALLOWED_TO_READ, & + & IDS, IDE, JDS, JDE, KDS, KDE, & + & IMS, IME, JMS, JME, KMS, KME, & + & ITS, ITE, JTS, JTE, KTS, KTE ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE + INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY + REAL,INTENT(IN) :: GMT,PPTOP + REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS + LOGICAL,INTENT(IN) :: ALLOWED_TO_READ +! + INTEGER :: I,IHRST,J,N + REAL :: PCLD,XSD,PI,SQR2PI + REAL :: SSLP=1013.25 + REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642., & + & PLBTM=105000. +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- +! +!*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS. +! + LTOP(1)=0 + LTOP(2)=0 + LTOP(3)=0 +! + DO N=1,KTE + PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10. + IF(PCLD>=PTOP_LO)LTOP(1)=N + IF(PCLD>=PTOP_MID)LTOP(2)=N + IF(PCLD>=PTOP_HI)LTOP(3)=N +! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP + ENDDO +!*** +!*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES +!*** + PTOPC(1)=PLBTM + PTOPC(2)=PTOP_LO*100. + PTOPC(3)=PTOP_MID*100. + PTOPC(4)=PTOP_HI*100. +! +!*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS +!*** OTHERWISE CALL CO2O3. +! + IF(ALLOWED_TO_READ)THEN + IF(CONFIG_FLAGS%CO2TF==1)THEN + CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2) + ELSE + CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE) + ENDIF +! + CALL O3CLIM + CALL TABLE + IHRST=NINT(GMT) +! WRITE(0,*)'into solard ',gmt,ihrst + CALL SOLARD(IHRST,IDAY,MONTH,JULYR) + ENDIF +! +!*** FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0 +! + DO J=JTS,JTE + DO I=ITS,ITE + EMISS(I,J) = 1.0 + ENDDO + ENDDO +! +!--- Calculate the area under the Gaussian curve at the start of the +!--- model run and build the look up table AXSD +! + PI=ACOS(-1.) + SQR2PI=SQRT(2.*PI) + RSQR=1./SQR2PI + DO I=1,NXSD + XSD=REAL(I)*DXSD + AXSD(I)=GAUSIN(XSD) + if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I) + ENDDO +!! !*** +!! !*** MESO STANDARD DEVIATION OF EK AND MAHRT'S CLOUD COVER ALOGRITHM +!! !*** +!! SDM=-0.03-0.00015*DX+0.02*LOG(DX) ! meso SD +!! if (SDprint) print *,'DX, SDM=',DX,SDM +! if (SDprint) print *, & +! & 'RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax=',& +! & RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax +! +!----------------------------------------------------------------------- + END SUBROUTINE GFDLETAINIT +!----------------------------------------------------------------------- +! +!------------------------------------------------------------------ +! urban related variable are added to arguments of etara +!--------------------------------------------------------------------- +! +!----------------------------------------------------------------------- + SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D & + & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T & + & ,QV,QW,QI,QS & + & ,TSK2D,GLW,RSWIN,GSW,RSWINC & + & ,RSWTOA,RLWTOA,CZMEAN & + & ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT & + & ,VEGFRA,SNOW,G,GMT & +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + & ,NSTEPRA,NPHS,ITIMESTEP & + & ,XTIME,JULIAN & + & ,COSZ_URB2D,OMG_URB2D & ! urban + & ,JULYR,JULDAY,GFDL_LW,GFDL_SW & + & ,CFRACL,CFRACM,CFRACH & + & ,ACFRST,NCFRST,ACFRCV,NCFRCV & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP & + & ,NPHS,NSTEPRA + + INTEGER,INTENT(IN) :: julyr,julday + INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added + ,NCFRCV !Added + REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN + + REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: & + THRATEN,THRATENLW,THRATENSW,CLDFRA !Added CLDFRA + REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, & + & rho_phy, & + & p_phy, & + & PI3D + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, & + & TSK2D,VEGFRA, & + & XLAND + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON + REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT + REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added + & RLWTOA, & !Added + & ACFRST, & !Added + & ACFRCV + REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW + REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN & + & ,RSWIN,RSWINC & + & ,CFRACL,CFRACM,CFRACH + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV, & + & QW,T + LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw + REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI + + REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, & + & QWFLIP,TFLIP + REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD + REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL + REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT + INTEGER :: IDAT(3),Jmonth,Jday + INTEGER :: I,J,K,KFLIP,IHRST + +!------------------------------------------------- +! urban related variables are added to declaration +!------------------------------------------------- + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban +! begin debugging radiation + integer :: imd,jmd + real :: FSWrat +! end debugging radiation +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- + IF(GFDL_LW.AND.GFDL_SW )GO TO 100 +! + DO J=JMS,JME + DO K=KMS,KME + DO I=IMS,IME + CLDFRA(I,K,J)=0. + ENDDO + ENDDO + ENDDO +! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) + DO J=JTS,JTE + DO I=ITS,ITE + PHYD(I,KTS,J)=P8W(I,KTS,J) + ENDDO + ENDDO +! + DO J=JTS,JTE + DO K=KTS,KTE + DO I=ITS,ITE + PHYD(I,K+1,J)=PHYD(I,K,J)-G*RHO_PHY(I,K,J)*DZ8W(I,K,J) + ENDDO + ENDDO + ENDDO +! + DO K=KMS,KME + KFLIP=KME+1-K + DO J=JTS,JTE + DO I=ITS,ITE + P8WFLIP(I,K,J)=PHYD(I,KFLIP,J) + ENDDO + ENDDO + ENDDO +! +!- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25) +! + DO K=KTS,KTE + KFLIP=KTE+1-K + DO J=JTS,JTE + DO I=ITS,ITE + TFLIP (I,K,J)=T(I,KFLIP,J) + QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J))) + QWFLIP(I,K,J)=QW(I,KFLIP,J) !Modified +! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS +! Eta MP now outputs QS instead of QI (JD 2006-05-12) + QIFLIP(I,K,J)=QS(I,KFLIP,J) !Added QS + IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI +! PFLIP (I,K,J)=P_PHY(I,KFLIP,J) +! +!*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL +! + PFLIP(I,K,J)=0.5*(P8WFLIP(I,K,J)+P8WFLIP(I,K+1,J)) + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + CUBOT(I,J)=KTE+1-HBOT(I,J) + CUTOP(I,J)=KTE+1-HTOP(I,J) + ENDDO + ENDDO +! + CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY) +! + IDAT(1)=JMONTH + IDAT(2)=JDAY + IDAT(3)=JULYR + IHRST =NINT(GMT) + +!----------------------------------------------------------------------- + CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, & + & PFLIP,P8WFLIP,XLAND,TSK2D, & + & GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT, & + & ACFRCV,NCFRCV,ACFRST,NCFRST, & + & VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC, & +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + & IDAT,IHRST,XTIME,JULIAN, & + & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, & + & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & + & CFRACL,CFRACM,CFRACH, & +! & COSZ2D,OMG2D, & !urban + & COSZ_URB2D,OMG_URB2D, & !urban + & IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE ) +!----------------------------------------------------------------------- +! begin debugging radiation +! imd=(ims+ime)/2 +! jmd=(jms+jme)/2 +! FSWrat=0. +! if (RSWIN(imd,jmd) .gt. 0.) & +! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd) +! write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") & +! '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' & +! ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = ' & +! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) & +! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) & +! ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat +! end debugging radiation +! +!--- Need to save LW & SW tendencies since radiation calculates both and this block +! is skipped when GFDL SW is called, both only if GFDL LW is also called +! + IF(GFDL_LW)THEN + DO J=JTS,JTE + DO K = KTS,KTE + KFLIP=KTE+1-K + DO I=ITS,ITE + THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J) + THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J) + THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF +! +!*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER. +! Only gets executed if a different LW scheme (not GFDL) is called +! + IF(GFDL_SW)THEN + DO J=JTS,JTE + DO K=KTS,KTE + KFLIP=KTE+1-K + DO I=ITS,ITE + THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF +! +!*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP +!*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS +! + DO J=JTS,JTE + DO I=ITS,ITE +! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT + HBOTR(I,J)=HBOT(I,J) + HTOPR(I,J)=HTOP(I,J) + HBOT(I,J)=REAL(KTE+1) + HTOP(I,J)=0. + CUPPT(I,J)=0. + ENDDO + ENDDO +! + 100 IF(GFDL_SW)THEN + DO J=JTS,JTE + DO K=KTS,KTE + KFLIP=KTE+1-K + DO I=ITS,ITE + THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J) + ENDDO + ENDDO + ENDDO + ENDIF +! + END SUBROUTINE ETARA +! +!----------------------------------------------------------------------- + SUBROUTINE RADTN(DT,T,Q,QCW,QICE, & + & PFLIP,P8WFLIP,XLAND,TSK2D, & + & GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT, & + & ACFRCV,NCFRCV,ACFRST,NCFRST, & + & VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC, & +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + & IDAT,IHRST,XTIME,JULIAN, & + & NRADS,NRADL,NPHS,NTSD, & + & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & + & CFRACL,CFRACM,CFRACH, & + & COSZ_URB2D,OMG_URB2D, & !urban + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + +! GLAT : geodetic latitude in radians of the mass points on the computational grid. + +! CZEN : instantaneous cosine of the solar zenith angle. + +! CUTOP : (REAL) model layer number that is highest in the atmosphere +! in which convective cloud occurred since the previous call to the +! radiation driver. + +! CUBOT : (REAL) model layer number that is lowest in the atmosphere +! in which convective cloud occurred since the previous call to the +! radiation driver. + +! ALB : is no longer used in the operational radiation. Prior to 24 July 2001 +! ALB was the climatological albedo that was modified within RADTN to +! account for vegetation fraction and snow. +! +! ALB : reintroduced as the dynamic albedo from LSM + +! CUPPT: accumulated convective precipitation (meters) since the +! last call to the radiation. + +! TSK2D : skin temperature + +! IHE and IHW are relative location indices needed to locate neighboring +! points on the Eta's Arakawa E grid since arrays are indexed locally on +! each MPI task rather than globally. IHE refers to the adjacent grid +! point (a V point) to the east of the mass point being considered. IHW +! is the adjacent grid point to the west of the given mass point. + +! IRAD is a relic from older code that is no longer needed. + +! ACFRCV : sum of the convective cloud fractions that were computed +! during each call to the radiation between calls to the subroutines that +! do the forecast output. + +! NCFRCV : the total number of times in which the convective cloud +! fraction was computed to be greater than zero in the radiation between +! calls to the output routines. In the post-processor, ACFRCV is divided +! by NCFRCV to yield an average convective cloud fraction. + +! ACFRST and NCFRST are the analogs for stratiform cloud cover. + +! VEGFRC is the fraction of the gridbox with vegetation. + +! LVL holds the number of model layers that lie below the ground surface +! at each point. Clearly for sigma coordinates LVL is zero everywhere. + +! CTHK : an assumed maximum thickness of stratiform clouds currently set +! to 20000 Pascals. I think this is relevant for computing "low", +! "middle", and "high" cloud fractions which are post-processed but which +! do not feed back into the integration. + +! IDAT : a 3-element integer array holding the month, day, and year, +! respectively, of the date for the start time of the free forecast. + +! ABCFF : holds coefficients for various absorption bands. You can see +! where they are set in GFDLRD.F. + +! LTOP : a 3-element integer array holding the model layer that is at or +! immediately below the specified pressure levels for the tops +! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa) +! stratiform clouds. These are for the diagnostic cloud layers +! needed in the output but not in the integration. + +! NRADS : integer number of fundamental timesteps (our smallest +! timestep, i.e., the one for inertial gravity wave adjustment) +! between updates of the shortwave tendencies. + +! NRADL : integer number of fundamental timesteps between updates of +! the longwave tendencies. + +! NTSD : integer counter of the fundamental timesteps that have +! elapsed since the start of the forecast. + +! GLW : incoming longwave radiation at the surface +! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface +! RSWIN : total (clear + cloudy sky) incoming (downward) solar radiation at the surface +! RSWINC : clear sky incoming (downward) solar radiation at the surface + +! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency + +! CLDFRA : 3D cloud fraction + +! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere + +! CZMEAN : time-average cosine of the zenith angle + +! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions + +! XTIME : time since simulation start (minutes) + +! JULIAN: Day of year (0.0 at 00Z Jan 1st) + +!********************************************************************** +!****************************** NOTE ********************************** +!********************************************************************** +!*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD +!*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY +!*** THAN LONGWAVE. +!********************************************************************** +!****************************** NOTE ********************************** +!********************************************************************** +!----------------------------------------------------------------------- +! INTEGER, PARAMETER :: NL=81 + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + & ims,ime, jms,jme, kms,kme , & + & its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS +! LOGICAL, INTENT(IN) :: RESTRT + REAL , INTENT(IN) :: DT,XTIME,JULIAN +! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 + INTEGER, INTENT(IN), DIMENSION(3) :: IDAT +!----------------------------------------------------------------------- + INTEGER :: LM1,LP1,LM + INTEGER, INTENT(IN) :: IHRST +! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL +! + REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0. & + &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1 & +!------------------------ For Clouds ---------------------------------- + &, CLFRmin=0.01, TAUCmax=4.161 & +!--- Parameters used for new cloud cover scheme + &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04 & + &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25 +! + INTEGER, PARAMETER :: NB=12,KSMUD=0 + INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15) + REAL (KIND=K15) :: DDX,EEX,PROD +! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D +!----------------------------------------------------------------------- + LOGICAL :: SHORT,LONG + LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1 + LOGICAL, SAVE :: CNCLD=.TRUE. + LOGICAL :: NEW_CLOUD +!----------------------------------------------------------------------- + REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D + REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, & + & QICE,T, & + & PFLIP, & + & P8WFLIP + +! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE + REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN & + & ,RSWIN,RSWINC & !Added + & ,CFRACL,CFRACM & + & ,CFRACH + REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA !added + +! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD +! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA +!----------------------------------------------------------------------- + REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT + REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON +!----------------------------------------------------------------------- + REAL, DIMENSION(ims:ime,jms:jme) :: CZEN + INTEGER, DIMENSION(its:ite, jts:jte):: LMH +!----------------------------------------------------------------------- +! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW +!----------------------------------------------------------------------- + REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST & + ,RSWTOA,RLWTOA + INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST +!----------------------------------------------------------------------- + REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC + REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,& + & TENDS +!----------------------------------------------------------------------- + REAL :: CTHK(3) + DATA CTHK/20000.0,20000.0,20000.0/ + + REAL,DIMENSION(10),SAVE :: CC,PPT +!----------------------------------------------------------------------- + REAL,SAVE :: ABCFF(NB) + INTEGER,DIMENSION(its:ite,jts:jte) :: LVL + REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL + REAL, DIMENSION( 0:kte) :: CLDAMT + REAL, DIMENSION(its:ite,3):: CLDCFR + INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP + REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, & + & SLMSK,FLWUP, & + & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, & + & FLWUPS,FSWDNSC + + REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID + REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN + REAL, DIMENSION(its:ite,jts:jte) :: TOT + + REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT + INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP + INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD + REAL, DIMENSION(its:ite) :: TAUDAR + REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL + + REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID +!! & ,QOVRCST ! Added + REAL,SAVE :: P400=40000. + INTEGER,SAVE :: NFILE=14 + +!----------------------------------------------------------------------- + REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG + REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2 + REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX + REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF + REAL :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM + REAL :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD + REAL :: RHtot,RRHO,FLARGE,FSMALL,DSNOW,SDM,QPCLDY,DIFCLD + REAL :: TauC,CTauL,CTauS, CFSmax,CFCmax + INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, & + & JD,II + INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL + INTEGER :: LCNVB,LCNVT + INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP + INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1 + +!------------------------------------------------- +! urban related variables are added to declaration +!------------------------------------------------- + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban + + INTEGER :: INDEXS,IXSD + DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/ + DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ + DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., & + & 2706.,39011./ +! begin debugging radiation + integer :: imd,jmd, Jndx + real :: FSWrat + imd=(ims+ime)/2 + jmd=(jms+jme)/2 +! end debugging radiation +! +!======================================================================= +! + MYJS=jts + MYJE=jte + MYIS=its + MYIE=ite + MYJS1=jts !???? + MYJE1=jte + MYJS2=jts + MYJE2=jte + LM=kte + LM1=LM-1 + LP1=LM+1 +! + DO J=JTS,JTE + DO I=ITS,ITE + LMH(I,J)=KME-1 + LVL(I,J)=0 + ENDDO + ENDDO +!********************************************************************** +!*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED. +!********************************************************************** +!----------------------CONVECTION-------------------------------------- +! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP +! FOR RADIATION +! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS +! THEY ARE INTEGER MULTIPLES OF EACH OTHER +! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD +! + NTSPH=NINT(3600./DT) + NRADPP=MIN(NRADS,NRADL) + CLSTP=1.0*NRADPP/NTSPH + CONVPRATE=CUPRATE/CLSTP +!----------------------CONVECTION-------------------------------------- +!*** +!*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE. +!*** + SHORT=.TRUE. + LONG=.TRUE. + ITIMSW=0 + ITIMLW=0 + IF(SHORT)ITIMSW=1 + IF(LONG) ITIMLW=1 +!*** +!*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE +!*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS +!*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON. +!*** +! TIME=NTSD*DT + TIME=XTIME*60. +!----------------------------------------------------------------------- + CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & + & MYIS,MYIE,MYJS,MYJE, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte, & + & OMG_URB2d=OMG_URB2D ) !Optional urban +!----------------------------------------------------------------------- +! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS) + ADDL=0. + IF(MOD(IDAT(3),4).EQ.0)ADDL=1. + RANG=PI2*(DAYI-RLAG)/(365.+ADDL) + RSIN1=SIN(RANG) + RCOS1=COS(RANG) + RCOS2=COS(2.*RANG) +! +!----------------------------------------------------------------------- + IF(SHORT)THEN + DO J=MYJS,MYJE + DO I=MYIS,MYIE + CZMEAN(I,J)=0. + TOT(I,J)=0. + ENDDO + ENDDO +! + DO II=0,NRADS,NPHS + TIMES=XTIME*60.+II*DT + CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & + & MYIS,MYIE,MYJS,MYJE, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte, & + & OMG_URB2D) !Optional urban +! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),& +! & II,NRADS,NPHS,NTSD,DT + DO J=MYJS,MYJE + DO I=MYIS,MYIE + IF(CZEN(I,J).GT.0.)THEN + CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J) + TOT(I,J)=TOT(I,J)+1. + ENDIF + ENDDO + ENDDO + ENDDO + DO J=MYJS,MYJE + DO I=MYIS,MYIE + IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J) + ENDDO + ENDDO + ENDIF + +!-------------------------------------------- +! COSZ2D is calculated for urban +!-------------------------------------------- + DO J=MYJS,MYJE !urban + DO I=MYIS,MYIE !urban + if(present(COSZ_URB2D)) COSZ_URB2D(I,J)=CZEN(I,J) !urban + ENDDO !urban + ENDDO !urban +! +! +!*** Do not modify pressure for ozone concentrations below the top layer +!*** + DO L=2,LM + DO I=MYIS,MYIE + POZN(I,L)=H1 + ENDDO + ENDDO +!----------------------------------------------------------------------- +! +!*********************************************************************** +!*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN +!*********************************************************************** +! ********************* + DO 700 J = MYJS, MYJE +! ********************* +! + DO 125 L=1,LM + DO I=MYIS,MYIE + TMID(I,L)=T(I,1,J) + QMID(I,L)=EPSQ + QWMID(I,L)=0. + QIMID(I,L)=0. + CSMID(I,L)=0. + CCMID(I,L)=0. + OZN(I,L)=EPSO3 + TENDS(I,L,J)=0. + TENDL(I,L,J)=0. + ENDDO + 125 CONTINUE +! + DO 140 N=1,3 + DO I=MYIS,MYIE + CLDCFR(I,N)=0. + MTOP(I,N)=0 + MBOT(I,N)=0 + ENDDO + 140 CONTINUE +!*** +!*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT +!*** ARE ACTUALLY AT ETA LEVEL L=LMH. +!*** + DO 200 I=MYIS,MYIE +! IR=IRAD(I) + LML=LMH(I,J) + LVLIJ=LVL(I,J) +! + DO L=1,LML + PMID(I,L+LVLIJ)=PFLIP(I,L,J) + PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J) + EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP + TMID(I,L+LVLIJ)=T(I,L,J) + THMID(I,L+LVLIJ)=T(I,L,J)*EXNER + QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J)) +!--- Note that rain is ignored, only effects from cloud water and +! ice (cloud ice + snow) are considered + QWMID(I,L+LVLIJ)=QCW(I,L,J) + QIMID(I,L+LVLIJ)=QICE(I,L,J) + ENDDO +!*** +!*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN. +!*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA. +!*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1. +!*** + IF(LVLIJ.GT.0)THEN + KNTLYR=0 +! + DO L=LVLIJ,1,-1 + KNTLYR=KNTLYR+1 + PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC + PINT(I,L+1)=PMID(I,L)+HPINC + EXNER=(1.E5/PMID(I,L))**RCP + THMID(I,L)=TMID(I,L)*EXNER + ENDDO + ENDIF +! + IF(LVLIJ.EQ.0) THEN + PINT(I,1)=P8WFLIP(I,1,J) + ELSE + PINT(I,1)=PMID(I,1)-HPINC + ENDIF + 200 CONTINUE +!*** +!*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE, +!*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS +!*** NEGATIVE OVER WATER. +!*** + DO 250 I=MYIS,MYIE + PSFC(I)=P8WFLIP(I,KME,J) + APES=(PSFC(I)*1.E-5)**RCP +! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J)) + IF((XLAND(I,J)-1.5).GT.0.)THEN + TSKN(I)=-TSK2D(I,J) + ELSE + TSKN(I)=TSK2D(I,J) + ENDIF + +! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.)) +! SLMSK(I)=SM(I,J) + SLMSK(I)=XLAND(I,J)-1. +! +! SNO(I,J)=AMAX1(SNO(I,J),0.) +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + SNOMM=AMAX1(SNO(I,J),0.) + SNOFAC=AMIN1(SNOMM/0.02, 1.0) +!!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J)) + ALBEDO(I)=ALB(I,J) +! + XLAT(I)=GLAT(I,J)/DTR + COSZ(I)=CZMEAN(I,J) + 250 CONTINUE +!----------------------------------------------------------------------- +!--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION (Ferrier, Nov '04) +! +!--- Assumes Gaussian-distributed probability density functions (PDFs) for +! total relative humidity (RHtot) within the grid for convective and +! grid-scale cloud processes. The standard deviation of RHtot is assumed +! to be larger for convective clouds than grid-scale (stratiform) clouds. +!----------------------------------------------------------------------- +! + DO I=MYIS,MYIE + LML=LMH(I,J) + LVLIJ=LVL(I,J) + DO 255 L=1,LML + LL=L+LVLIJ + WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio + QCLD=QWMID(I,LL)+QIMID(I,LL) !--- Total cloud water + ice mixing ratio + IF (QCLD .LE. EPSQ) GO TO 255 !--- Skip if no condensate is present + CLFR=H0 + WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio + + ! + !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C ) + ! +#ifdef FERRIER_GFDL + ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa) +#else + ESAT=FPVS_new(TMID(I,LL)) !--- Saturation vapor pressure (Pa) +#endif + QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio + RHUM=WV/QSAT !--- Relative humidity + ! + !--- Revised cloud cover parameterization (temporarily ignore rain) + ! + RHtot=(WV+QCLD)/QSAT !--- Total relative humidity +!! ! +!! !--- QOVRCST is the amount of cloud condensate associated with full +!! ! overcast, PCLDY is an arbitrary factor for partial cloudiness +!! ! +!! TCLD=TMID(I,LL)-T0C !--- Air temp in deg C +!! RRHO=(R_D*TMID(I,LL)*(1.+EP_1*QMID(I,LL)))/PMID(I,LL) +!! IF (TCLD .GE. 0.) THEN +!! QOVRCST(I,LL)=QAUT0*RRHO +!! ELSE +!! IF (TCLD.GE.-8. .AND. TCLD.LE.-3.) THEN +!! FLARGE=FLARGE1 +!! ELSE +!! FLARGE=FLARGE2 +!! ENDIF +!! FSMALL=(1.-FLARGE)/FLARGE +!! DSNOW=XMImax*EXP(XMIexp*TCLD) +!! INDEXS=MAX(MDImin, MIN(MDImax, INT(DSNOW))) +!! QOVRCST(I,LL)=NLImax*( FSMALL*MASSI(MDImin) & +!! & +MASSI(INDEXS) )*RRHO +!! ENDIF !--- End IF (TCLD .GE. 0.) +!! QOVRCST(I,LL)=PCLDY*QOVRCST(I,LL) + LCNVT=NINT(CUTOP(I,J))+LVLIJ + LCNVT=MIN(LM,LCNVT) + LCNVB=NINT(CUBOT(I,J))+LVLIJ + LCNVB=MIN(LM,LCNVB) + IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN + SDM=CVSDM + ELSE + SDM=STSDM + ENDIF + ARG=(RHtot-RHgrd)/SDM + IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN + CLFR=HALF + ELSE IF (ARG .GT. DXSD2) THEN + IF (ARG .GE. XSDmax) THEN + CLFR=H1 + ELSE + IXSD=INT(ARG/DXSD+HALF) + IXSD=MIN(NXSD, MAX(IXSD,1)) + CLFR=HALF+AXSD(IXSD) + if (SDprint) & + & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") & + & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot & + & ,1000.*QSAT,TCLD,.01*PMID(I,LL) + ENDIF !--- End IF (ARG .GE. XSDmax) + ELSE + IF (ARG .LE. XSDmin) THEN + CLFR=H0 + ELSE + IXSD=INT(ARG/DXSD1+HALF) + IXSD=MIN(NXSD, MAX(IXSD,1)) + CLFR=HALF-AXSD(IXSD) + if (SDprint) & + & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") & + & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot & + & ,1000.*QSAT,TCLD,.01*PMID(I,LL) + IF (CLFR .LT. CLFRmin) CLFR=H0 + ENDIF !--- End IF (ARG .LE. XSDmin) + ENDIF !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) + CSMID(I,LL)=CLFR +!! ! +!! !--- Here the condensate is adjusted to be only over the cloudy area +!! ! +!! IF (CLFR.GT.0. .AND. QCLD.LE.0.) THEN +!! ! +!! !--- Put in modest amounts of cloud water & cloud ice for partially cloudy grids +!! ! +!! QPCLDY=MIN(.01*QSAT, QOVRCST(I,LL)) +!! IF (TCLD .GE. H0) THEN +!! QWMID(I,LL)=QPCLDY +!! ELSE +!! QIMID(I,LL)=QPCLDY +!! ENDIF +!! ENDIF !--- End IF (CLFR.GT.0. .AND. QCLD.LE.0.) +255 CONTINUE !--- End DO L=1,LML + ENDDO !--- End DO I=MYIS,MYIE +! +!*********************************************************************** +!****************** END OF GRID-SCALE CLOUD FRACTIONS **************** +! +!--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION +! +!--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is +! used for convective cloud fraction as a function of precipitation +! rate. Cloud fractions have been increased by 20% for each rainrate +! interval so that shallow, nonprecipitating convection is ascribed a +! constant cloud fraction of 0.1 (Ferrier, Feb '02). +!*********************************************************************** +! + IF (CNCLD) THEN + DO I=MYIS,MYIE +! +!*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC +! Convective clouds need to be at least 2 model layers thick +! + IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN + !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02) + CLFR=CC(1) + PMOD=CUPPT(I,J)*CONVPRATE + IF (PMOD .GT. PPT(1)) THEN + DO NC=1,10 + IF(PMOD.GT.PPT(NC)) NMOD=NC + ENDDO + IF (NMOD .GE. 10) THEN + CLFR=CC(10) + ELSE + CC1=CC(NMOD) + CC2=CC(NMOD+1) + P1=PPT(NMOD) + P2=PPT(NMOD+1) + CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1) + ENDIF !--- End IF (NMOD .GE. 10) ... + CLFR=MIN(H1, CLFR) + ENDIF !--- End IF (PMOD .GT. PPT(1)) ... + ! + !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS + ! + LVLIJ=LVL(I,J) + LCNVT=NINT(CUTOP(I,J))+LVLIJ + LCNVT=MIN(LM,LCNVT) + LCNVB=NINT(CUBOT(I,J))+LVLIJ + LCNVB=MIN(LM,LCNVB) +!! ! +!! !---- For debugging +!! ! +!! WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)") +!! & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT +!! &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J) +!! &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR +!! ! + ! + !--- Build in small amounts of subgrid-scale convective condensate + ! (simple assumptions), but only if the convective cloud fraction + ! exceeds that of the grid-scale cloud fraction + ! + DO LL=LCNVT,LCNVB + ARG=MAX(H0, H1-CSMID(I,LL)) + CCMID(I,LL)=MIN(ARG,CLFR) + ENDDO !--- End DO LL=LCNVT,LCNVB + ENDIF !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ... + ENDDO !--- End DO I loop + ENDIF !--- End IF (CNCLD) ... +! +!********************************************************************* +!*************** END OF CONVECTIVE CLOUD FRACTIONS ***************** +!********************************************************************* +!*** +!*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID +!*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL +!*** +!*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!! +!*** +!*** + DO 500 I=MYIS,MYIE +!! + DO L=0,LM + CLDAMT(L)=0. + ENDDO +!! +!!*** NOW GOES LOW, MIDDLE, HIGH +!! + DO 480 NLVL=1,3 + CLDMAX=0. + MALVL=LM + LLTOP=LM+1-LTOP(NLVL)+LVL(I,J) +!!*** +!!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN +!!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND. +!!*** + IF(LLTOP.GE.LM)GO TO 480 +!! + IF(NLVL.GT.1)THEN + LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J) + LLBOT=MIN(LLBOT,LM1) + ELSE + LLBOT=LM1 + ENDIF +!! + DO 435 L=LLTOP,LLBOT + CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L)) + IF(CLDAMT(L).GT.CLDMAX)THEN + MALVL=L + CLDMAX=CLDAMT(L) + ENDIF + 435 CONTINUE +!!********************************************************************* +!! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN +!! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992). +!! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE +!! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED. +!! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST +!! CONTINUING CLOUD LAYERS IN THE DOMAIN. +!!********************************************************************* + CL1=0.0 + CL2=0.0 + KBT1=LLBOT + KBT2=LLBOT + KTH1=0 + KTH2=0 +!! + DO 450 LL=LLTOP,LLBOT + L=LLBOT-LL+LLTOP + BIT1=.FALSE. + CR1=CLDAMT(L) + BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. & + & (PINT(I,L).LT.PTOPC(NLVL)).AND. & + & (CLDAMT(L).GT.0.0) + BIT1=BIT1.OR.BITX + IF(.NOT.BIT1)GO TO 450 +!!*** +!!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER +!!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE +!!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR +!!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY +!!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE +!!*** NEEDED IN THE FUTURE. +!!*** + BITY=BITX.AND.(KTH2.LE.0) + BITZ=BITX.AND.(KTH2.GT.0) +!! + IF(BITY)THEN + KBT2=L + KTH2=1 + ENDIF +!! + IF(BITZ)THEN + KTOP1=KBT2-KTH2+1 + DPCL=PMID(I,KBT2)-PMID(I,KTOP1) + IF(DPCL.LT.CTHK(NLVL))THEN + KTH2=KTH2+1 + ELSE + KBT2=KBT2-1 + ENDIF + ENDIF + IF(BITX)CL2=AMAX1(CL2,CR1) +!!*** +!!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP. +!!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD +!!*** LAYER IN THAT DOMAIN. +!!*** + BIT2=.FALSE. + BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. & + PINT(I,L-1).LT.PTOPC(NLVL+1)) + BITZ=BITY.AND.CL1.GT.0.0 + BITW=BITY.AND.CL1.LE.0.0 + BIT2=BIT2.OR.BITY + IF(.NOT.BIT2)GO TO 450 +!! + IF(BITZ)THEN + KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2)) + KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1 + CL1=CL1+CL2-CL1*CL2 + ENDIF +!! + IF(BITW)THEN + KBT1=KBT2 + KTH1=KTH2 + CL1=CL2 + ENDIF +!! + IF(BITY)THEN + KBT2=LLBOT + KTH2=0 + CL2=0.0 + ENDIF + 450 CONTINUE +! + CLDCFR(I,NLVL)=AMIN1(1.0,CL1) + MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1) + MBOT(I,NLVL)=KBT1 + 480 CONTINUE + 500 CONTINUE + +!*** +!*** SET THE UN-NEEDED TAUDAR TO ONE +!*** + DO I=MYIS,MYIE + TAUDAR(I)=1.0 + ENDDO +!---------------------------------------------------------------------- +! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982), +! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993). +! +! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO +! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL +! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED +! IN THIS CALCULATIONS. +! +! QINGYUN ZHAO 95-3-22 +! +!---------------------------------------------------------------------- +! +!*** +!*** INITIALIZE ARRAYS FOR USES LATER +!*** + + DO 600 I=MYIS,MYIE + LML=LMH(I,J) + LVLIJ=LVL(I,J) +! +!*** +!*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD +!*** LAYER ABOVE THE SURFACE AND SO ON. +!*** + EMIS(I,1)=1.0 + KTOP(I,1)=LP1 + KBTM(I,1)=LP1 + CAMT(I,1)=1.0 + KCLD(I)=2 +! + DO NBAND=1,NB + RRCL(I,NBAND,1)=0.0 + TTCL(I,NBAND,1)=1.0 + ENDDO +! + DO 510 L=2,LP1 + CAMT(I,L)=0.0 + KTOP(I,L)=1 + KBTM(I,L)=1 + EMIS(I,L)=0.0 +! + DO NBAND=1,NB + RRCL(I,NBAND,L)=0.0 + TTCL(I,NBAND,L)=1.0 + ENDDO + 510 CONTINUE + +!### End changes so far +!*** +!*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER +!*** CLOUD TYPE=1: STRATIFORM CLOUD +!*** TYPE=2: CONVECTIVE CLOUD +!*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT, +!*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION. +!*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS. +!*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN. +!*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS +!*** OF MODEL LEVEL. +!*** + NEW_CLOUD=.TRUE. +! + DO L=2,LML + LL=LML-L+1+LVLIJ !-- Model layer + CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer + CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer +!------------------- + IF (CLFR .GE. CLFRMIN) THEN +!--- Cloud present at level + IF (NEW_CLOUD) THEN +!--- New cloud layer + IF(L==2.AND.CLFR1>=CLFRmin)THEN + KBTM(I,KCLD(I))=LL+1 + CAMT(I,KCLD(I))=CLFR1 + ELSE + KBTM(I,KCLD(I))=LL + CAMT(I,KCLD(I))=CLFR + ENDIF + NEW_CLOUD=.FALSE. + ELSE +!--- Existing cloud layer + CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR) + ENDIF ! End IF (NEW_CLOUD .EQ. 0) ... + ELSE IF (CLFR1 .GE. CLFRMIN) THEN +!--- Cloud is not present at level but did exist at lower level, then ... + IF (L .EQ. 2) THEN +!--- For the case of ground fog + KBTM(I,KCLD(I))=LL+1 + CAMT(I,KCLD(I))=CLFR1 + ENDIF + KTOP(I,KCLD(I))=LL+1 + NEW_CLOUD=.TRUE. + KCLD(I)=KCLD(I)+1 + CAMT(I,KCLD(I))=0.0 + ENDIF +!------------------- + ENDDO !--- End DO L loop +!*** +!*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND; +!*** THE LAST IS THE SKY): +!*** + NCLDS(I)=KCLD(I)-2 + NCLD=NCLDS(I) +!*** +!*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES +!*** + IF(NCLD.GE.1)THEN +!*** +!*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!! +!*** + DO 580 NC=2,NCLD+1 +! + TauC=0. !--- Total optical depth for each cloud layer (solar & longwave) + QSUM=0.0 + NKTP=LP1 + NBTM=0 + BITX=CAMT(I,NC).GE.CLFRMIN + NKTP=MIN(NKTP,KTOP(I,NC)) + NBTM=MAX(NBTM,KBTM(I,NC)) +! + DO LL=NKTP,NBTM + IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN + PRS1=PINT(I,LL)*0.01 + PRS2=PINT(I,LL+1)*0.01 + DELP=PRS2-PRS1 + TCLD=TMID(I,LL)-T0C + QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) & + & /(120.1612*SQRT(TMID(I,LL))) +! +!*********************************************************************** +!**** IMPORTANT NOTES concerning input cloud optical properties ****** +!*********************************************************************** +! +!--- The simple optical depth parameterization from eq. (1) of Harshvardhan +! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship) +! is used for convective cloud properties with some simple changes. +! +!--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are +! described below. +! 1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where +! Q0 is assumed to be the threshold mixing ratio for "thick anvils", +! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al. +! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/ +! cloud observations, and it is intended only to be a crude scaling +! factor for "order of magnitude" effects. The functional dependence +! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7). +! Result: CTau=800.*Qc => note that the "800." factor is referred to +! as an absorption coefficient +! 2) For an assumed value of Q0=1 g/kg for "thick anvils", then +! CTau=80.*Qc, or an absorption coefficient that is an order of +! magnitude less. +! => ABSCOEF_W can vary from 100. to 1000. !! +! 3) From p. 3105 of Dudhia (1989), values of +! 0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa +! => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb +! 4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000. after units conversion +! 5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption +! coefficients are roughly half those of cloud water, it was decided +! to keep this simple and assume half that of water. +! => ABSCOEF_I=0.5*ABSCOEF_W +! +!--- For convection, the following is assumed: +! 1) A characteristic water/ice mixing ratio (Qconv) +! 2) A temperature threshold for water or ice (TRAD_ice) +! +!----------------------------------------------------------------------- +! + CTau=0. +!-- For crude estimation of convective cloud optical depths + IF (CCMID(I,LL) .GE. CLFRmin) THEN + IF (TCLD .GE. TRAD_ice) THEN + CTau=CTauCW !--- Convective cloud water + ELSE + CTau=CTauCI !--- Convective ice + ENDIF +! CTau=CTau*CCMID(I,LL) !--- Reduce by convective cloud fraction + ENDIF +! +!-- For crude estimation of grid-scale cloud optical depths +! +!-- => The following 2 lines were intended to reduce cloud optical depths further +! than what's parameterized in the NAM and what's theoretically justified +! CTau=CTau+CSMID(I,LL)* & +! & ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) ) + CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) + TauC=TauC+DELP*CTau + ENDIF !--- End IF(LL.GE.KTOP(I,NC) .... + ENDDO !--- End DO LL +! +!!! IF(BITX)EMIS(I,NC)=1.0-EXP(-0.75*TauC) + IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC) + IF(QSUM.GE.EPSQ1)THEN +! + DO 570 NBAND=1,NB + IF(BITX)THEN + PROD=ABCFF(NBAND)*QSUM + DDX=TauC/(TauC+PROD) + EEX=1.0-DDX + IF(ABS(EEX).GE.1.E-8)THEN + DD=DDX + EE=EEX + FF=1.0-DD*0.85 + AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC) + AA=EXP(-AA) + BB=FF/EE + GG=SQRT(BB) + DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA + RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD) + TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD) + ENDIF + ENDIF + 570 CONTINUE + ENDIF + 580 CONTINUE +! + ENDIF +! + 600 CONTINUE +!********************************************************************* +!****************** COMPUTE OZONE AT MIDLAYERS ********************* +!********************************************************************* +! +!*** MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL +!*** OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB) +! + DO I=MYIS,MYIE + FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1)) + POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1)) + ENDDO +! + CALL OZON2D(LM,POZN,XLAT,OZN, & + MYIS,MYIE, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +!*** +!*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED. +!*** +!---------------------------------------------------------------------- +!*** +!*** CALL THE GFDL RADIATION DRIVER +!*** +!*** + Jndx=J + CALL RADFS & + & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT & +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL & + &, COSZ,TAUDAR,1 & + &, 1,0 & + &, ITIMSW,ITIMLW & + &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) & + &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC & + &, ids,ide, jds,jde, kds,kde & + &, ims,ime, jms,jme, kms,kme & +! begin debugging radiation + &, its,ite, jts,jte, kts,kte & + &, imd,jmd, Jndx ) +! end debugging radiation +!---------------------------------------------------------------------- + IF(LONG)THEN +! +!-- All fluxes in W/m**2 +!--- GLW => downward longwave at the surface (formerly RLWIN) +!--- RLWTOA => outgoing longwave at the top of the atmosphere +!-- Note: RLWOUT & SIGT4 have been removed because they are no longer being used! +! + DO I=MYIS,MYIE + GLW(I,J)=FLWDNS(I) + RLWTOA(I,J)=FLWUP(I) + ENDDO + ENDIF +! + IF(SHORT)THEN +! +!-- All fluxes in W/m**2 +!--- GSW => NET shortwave at the surface +!--- RSWIN => incoming shortwave at the surface (all sky) +!--- RSWINC => clear-sky incoming shortwave at the surface +!--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere +! + DO I=MYIS,MYIE + GSW(I,J)=FSWDNS(I)-FSWUPS(I) + RSWIN(I,J) =FSWDNS(I) + RSWINC(I,J)=FSWDNSC(I) + RSWTOA(I,J)=FSWUP(I) + ENDDO + ENDIF +! +!*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND +!*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY. +!*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL. +! +!*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS. +! +!*** UPDATE NEW 3D CLOUD FRACTION (CLDFRA) +! + DO I=MYIS,MYIE + CFRACL(I,J)=CLDCFR(I,1) + CFRACM(I,J)=CLDCFR(I,2) + CFRACH(I,J)=CLDCFR(I,3) + IF(CNCLD)THEN + CFSmax=0. !-- Maximum cloud fraction (stratiform component) + CFCmax=0. !-- Maximum cloud fraction (convective component) + DO L=1,LMH(I,J) + LL=L+LVL(I,J) + CFSmax=MAX(CFSmax, CSMID(I,LL) ) + CFCmax=MAX(CFCmax, CCMID(I,LL) ) + ENDDO + ACFRST(I,J)=ACFRST(I,J)+CFSmax + NCFRST(I,J)=NCFRST(I,J)+1 + ACFRCV(I,J)=ACFRCV(I,J)+CFCmax + NCFRCV(I,J)=NCFRCV(I,J)+1 + ELSE + !--- Count only locations with grid-scale cloudiness, ignore convective clouds + ! (option not used, but if so set to the total cloud fraction) + CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J)) + ACFRST(I,J)=ACFRST(I,J)+CFRAVG + NCFRST(I,J)=NCFRST(I,J)+1 + ENDIF +!--- Flip 3D cloud fractions in the vertical and save time + LML=LMH(I,J) + DO L=1,LML + LL=LML-L+1+LVL(I,J) + CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL)) + ENDDO + ENDDO !-- I index +!*** +!*** THIS ROW IS FINISHED. GO TO NEXT +!*** +! ********************* + 700 CONTINUE +! ********************* +!---------------------------------------------------------------------- +!*** +!*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE. +!*** +!---------------------------------------------------------------------- +! begin debugging radiation +! FSWrat=0. +! if (RSWIN(imd,jmd) .gt. 0.) & +! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd) +! write(6,"(2a,2i5,7f9.2)") & +! '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' & +! ,'ALBEDO,RSWOUT/RSWIN = '& +! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) & +! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) & +! ,ALB(imd,jmd),FSWrat +! end debugging radiation +!---------------------------------------------------------------------- +! +!--- Need to save LW & SW tendencies since radiation calculates both and this block + + END SUBROUTINE RADTN + +!---------------------------------------------------------------------- + + REAL FUNCTION GAUSIN(xsd) + REAL, PARAMETER :: crit=1.e-3 + REAL A1,A2,RN,B1,B2,B3,SUM +! +! This function calculate area under the Gaussian curve between mean +! and xsd # of standard deviation (03/22/2004 Hsin-mu Lin) +! + a1=xsd*RSQR + a2=exp(-0.5*xsd**2) + rn=1. + b1=1. + b2=1. + b3=1. + sum=1. + do while (b2 .gt. crit) + rn=rn+1. + b2=xsd**2/(2.*rn-1.) + b3=b1*b2 + sum=sum+b3 + b1=b3 + enddo + GAUSIN=a1*a2*sum + RETURN + END FUNCTION GAUSIN + +!---------------------------------------------------------------------- + + SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & + MYIS,MYIE,MYJS,MYJE, & + IDS,IDE, JDS,JDE, KDS,KDE, & + IMS,IME, JMS,JME, KMS,KME, & + ITS,ITE, JTS,JTE, KTS,KTE, & + OMG_URB2D) !Optional urban +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , & + IMS,IME, JMS,JME, KMS,KME , & + ITS,ITE, JTS,JTE, KTS,KTE + INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE + + REAL, INTENT(IN) :: TIMES + REAL, INTENT(OUT) :: HOUR,DAYI + INTEGER, INTENT(IN) :: IHRST + + INTEGER, INTENT(IN), DIMENSION(3) :: IDAT + REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON + REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN + REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !Optional urban + + REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, & + GSTC3=9.3104E-2,GSTC4=-6.2E-6, & + PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, & +!#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, & + DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, & + ZEROJD=2451545.0 + + REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, & + ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG + REAL :: HRLCL,SINALT + INTEGER :: KMNTH,KNT,IDIFYR,J,I + LOGICAL :: LEAP +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + INTEGER :: MONTH (12) +!----------------------------------------------------------------------- + DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/ +!*********************************************************************** +! SAVE MONTH + DAY=0. + LEAP=.FALSE. + IF(MOD(IDAT(3),4).EQ.0)THEN + MONTH(2)=29 + LEAP=.TRUE. + ENDIF + IF(IDAT(1).GT.1)THEN + KMNTH=IDAT(1)-1 + DO 10 KNT=1,KMNTH + DAY=DAY+REAL(MONTH(KNT)) + 10 CONTINUE + ENDIF +!*** +!*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO +!*** FORECAST TIME OF INTEREST +!*** + DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24. + DAYI=REAL(INT(DAY)+1) + HOUR=(DAY-DAYI+1.)*24. + YFCTR=2000.-IDAT(3) +!----------------------------------------------------------------------- +!*** +!*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND +!*** RIGHT ASCENSION. +!*** +!----------------------------------------------------------------------- + IDIFYR=IDAT(3)-2000 +!*** +!*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR +!*** ADDING IN LEAP DAYS AS NEEDED +!*** + IF(IDIFYR.LT.0)THEN + ADDDAY=REAL(IDIFYR/4) + ELSE + ADDDAY=REAL((IDIFYR+3)/4) + ENDIF + STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5 +!*** +!*** THE JULIAN DATE OF THE TIME IN QUESTION +!*** + DATJUL=STARTYR+DAY +! +!*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE +!*** AT 00H 1 January 2000 +! + DIFJD=DATJUL-ZEROJD +! +!*** MEAN GEOMETRIC LONGITUDE OF THE SUN +! + SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2 +! +!*** THE MEAN ANOMOLY +! + ANOM=(357.528+0.9856003*DIFJD)*DEG2RD +! +!*** APPARENT GEOMETRIC LONGITUDE OF THE SUN +! + SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD + IF(SLON.GT.PI2)SLON=SLON-PI2 +! +!*** DECLINATION AND RIGHT ASCENSION +! + DEC=ASIN(SIN(SLON)*SIN(OBLIQ)) + RA=ACOS(COS(SLON)/COS(DEC)) + IF(SLON.GT.PI)RA=PI2-RA +!*** +!*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR +!*** HOUR ANGLE. +!*** + DATJ0=STARTYR+DAYI-1. + TU=(DATJ0-2451545.)/36525. + STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU) + SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR + SIDTIM=SIDTIM*15.*DEG2RD + IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2 + IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2 + HRANG=SIDTIM-RA +! + DO 100 J=MYJS,MYJE + DO 100 I=MYIS,MYIE +! HRLCL=HRANG-GLON(I,J) + HRLCL=HRANG+GLON(I,J)+PI2 +!*** +!*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE +!*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE. +!*** + SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* & + COS(GLAT(I,J)) + IF(SINALT.LT.0.)SINALT=0. + CZEN(I,J)=SINALT + if(present(OMG_URB2D))OMG_URB2D(I,J)=HRLCL !urban + 100 CONTINUE +!*** +!*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME, +!*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE +!*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED). +!*** + IF(DAYI.GT.365.)THEN + IF(.NOT.LEAP)THEN + DAYI=DAYI-365. + ELSEIF(LEAP.AND.DAYI.GT.366.)THEN + DAYI=DAYI-366. + ENDIF + ENDIF +! + END SUBROUTINE ZENITH +!----------------------------------------------------------------------- + + SUBROUTINE OZON2D (LK,POZN,XLAT,QO3, & + MYIS,MYIE, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: LK,MYIS,MYIE + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN + REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT + REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3 +!---------------------------------------------------------------------- + INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL + +! REAL, INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3 +! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + INTEGER,DIMENSION(its:ite) :: JJROW + REAL, DIMENSION(its:ite) :: TTHAN + REAL, DIMENSION(its:ite,NL) :: QO3O3 + + INTEGER :: I,K,NUMITR,ILOG,IT,NHALF + REAL :: TH2,DO3V,DO3VP,APHI,APLO +!---------------------------------------------------------------------- + DO I=MYIS,MYIE + TH2=0.2*XLAT(I) + JJROW(I)=19.001-TH2 + TTHAN(I)=(19-JJROW(I))-TH2 + ENDDO +! +!*** SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. +! + DO K=1,NL + DO I=MYIS,MYIE + DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K) & + +RCOS1*XDO3N3(JJROW(I),K) & + +RCOS2*XDO3N4(JJROW(I),K) + DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) & + +RCOS1*XDO3N3(JJROW(I)+1,K) & + +RCOS2*XDO3N4(JJROW(I)+1,K) +! +!*** NOW LATITUDINAL INTERPOLATION +!*** AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4) +! + QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V)) + ENDDO + ENDDO +!*** +!*** VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P) +!*** + NUMITR=0 + ILOG=NL + 20 CONTINUE + ILOG=(ILOG+1)/2 + IF(ILOG.EQ.1)GO TO 25 + NUMITR=NUMITR+1 + GO TO 20 + 25 CONTINUE +! + DO 60 K=1,LK +! + NHALF=(NL+1)/2 + DO I=MYIS,MYIE + JJROW(I)=NHALF + ENDDO +! + DO 40 IT=1,NUMITR + NHALF=(NHALF+1)/2 + DO I=MYIS,MYIE + IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN + JJROW(I)=JJROW(I)-NHALF + ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN + JJROW(I)=JJROW(I)+NHALF + ENDIF + JJROW(I)=MIN(JJROW(I),NL) + JJROW(I)=MAX(JJROW(I),2) + ENDDO + 40 CONTINUE +! + DO 50 I=MYIS,MYIE + IF(POZN(I,K).LT.PRGFDL(1))THEN + QO3(I,K)=QO3O3(I,1) + ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN + QO3(I,K)=QO3O3(I,NL) + ELSE + APLO=ALOG(PRGFDL(JJROW(I)-1)) + APHI=ALOG(PRGFDL(JJROW(I))) + QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ & + (APLO-APHI)* & + (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I))) + ENDIF + 50 CONTINUE +! + 60 CONTINUE + + END SUBROUTINE OZON2D +!----------------------------------------------------------------------- + +! SUBROUTINE ZERO2(ARRAY, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- +!IMPLICIT NONE +!---------------------------------------------------------------------- +! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & +! ims,ime, jms,jme, kms,kme , & +! its,ite, jts,jte, kts,kte +! REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY +! INTEGER :: I,J +!---------------------------------------------------------------------- +! DO J=jts,jte +! DO I=its,ite +! ARRAY(I,J)=0. +! ENDDO +! ENDDO + +! END SUBROUTINE ZERO2 + +!---------------------------------------------------------------- + + SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR ETA LYRS +! PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 +! MICHAEL BALDWIN ORG: W/NMC22 DATE: 92-06-08 +! +! ABSTRACT: THIS CODE WRITTEN AT GFDL... +! CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE, +! FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4 +! CODE IS CALLED ONLY ONCE. +! +! PROGRAM HISTORY LOG: +! 84-01-01 FELS AND SCHWARZKOPF,GFDL. +! 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE. +! 92-06-08 M. BALDWIN - UPDATE TO RUN IN ETA MODEL +! +! USAGE: CALL O3INT(O3,SIGL) OLD +! INPUT ARGUMENT LIST: +! PHALF - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE) +! OUTPUT ARGUMENT LIST: +! DDUO3N - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4) +! DDO3N2 DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN +! DDO3N3 N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR) +! DDO3N4 AND SEASON-WIN,SPR,SUM,FALL. +! IN COMMON +! +! OUTPUT FILES: +! OUTPUT - PRINT FILE. +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 200. +! +!$$$ +!.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3 +!.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE) +!----------------------------------------------------------------------- +! INCLUDE "parmeta" +!----------------------------------------------------------------------- +! ********************************************************* + + INTEGER :: N,NP,NP2,NM1 + +! PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1) +! ********************************************************* +!----------------------------------------------------------------------- +!*** +!*** SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN +!*** CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE). +!*** DEFINED AS 5 DEG LAT MEANS N.P.->S.P. +!*** + REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4 + +! C O M M O N /SAVMEM/ +! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... +! 1 DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM) +! ..... K.CAMPANA OCTOBER 1988 +!CCC DIMENSION T41(NP2,2),O3O3(37,N,4) +! DIMENSION SIGL(N) +! ********************************************************* + REAL :: QI(82) + REAL :: DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41) + REAL :: TEMPN(19) + REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), & + O3LO4(10,16) + REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33) + REAL :: O35DEG(37,kts:kte) + REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), & + PHALF(kts:kte+1),P(81),PH(82) + + INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN + REAL :: O3RD,O3TOT,O3DU + + EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) + EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46)) + EQUIVALENCE (P1(1),P(1)),(P2(1),P(49)) + DATA PH1/ 0., & + 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, & + 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, & + 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, & + 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, & + 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, & + 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, & + 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, & + 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, & + 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, & + 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, & + 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ + DATA PH2/ & + 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, & + 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, & + 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, & + 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, & + 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, & + 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, & + 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, & + 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, & + 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, & + 0.1000000E+01/ + DATA P1/ & + 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, & + 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, & + 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, & + 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, & + 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, & + 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, & + 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, & + 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, & + 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, & + 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, & + 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, & + 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ + DATA P2/ & + 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, & + 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, & + 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, & + 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, & + 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, & + 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, & + 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, & + 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, & + 0.1000000E+01/ + DATA O3HI1/ & + .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, & + .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, & + .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, & + .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, & + .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, & + .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, & + .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, & + .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, & + 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, & + 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, & + 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, & + 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, & + 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, & + 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, & + 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, & + 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ + DATA O3HI2/ & + 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, & + 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, & + 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, & + 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, & + 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, & + 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, & + 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, & + 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, & + 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ + DATA O3LO1/ & + 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, & + 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, & + 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, & + 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, & + 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, & + 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, & + 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, & + .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, & + .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, & + .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, & + .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, & + .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, & + .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, & + .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, & + .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, & + .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ + DATA O3LO2/ & + 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, & + 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, & + 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, & + 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, & + 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, & + 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, & + .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, & + .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, & + .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, & + .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, & + .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, & + .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, & + .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, & + .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, & + .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, & + .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ + DATA O3LO3/ & + 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, & + 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, & + 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, & + 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, & + 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, & + 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, & + .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, & + .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, & + .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, & + .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, & + .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, & + .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, & + .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, & + .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, & + .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, & + .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ + DATA O3LO4/ & + 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, & + 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, & + 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, & + 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, & + 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, & + 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, & + 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, & + .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, & + .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, & + .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, & + .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, & + .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, & + .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, & + .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, & + .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, & + .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ + +!!!!! +! PSS=101325. +! PDIF=PSS-PT +! +! DO L=1,LM1 +! PHALF(L+1)=AETA(L)*PDIF+PT +! ENDDO +! +! PHALF(1)=0. +! PHALF(LP1)=PSS +!!!! + N=kte;NP=N+1;NP2=N+2;NM1=N-1 + + NKK=41 + NK=81 + NKP=NK+1 + DO 24 K=1,NP +! 24 PHALF(K)=PHALF(K)*1.0E 03 + 24 PHALF(K)=PHALF(K)*0.01*1.0E+03 +! 24 PSTD(K)=PSTD(K+1)*1.0E 03 + DO 25 K=1,NK + PH(K)=PH(K)*1013250. + 25 P(K)=P(K)*1013250. + PH(NKP)=PH(NKP)*1013250. +!KAC WRITE (6,3) PH +!KAC WRITE (6,3) P +! WRITE (6,3) (PHALF(K),K=1,NP) +! WRITE (6,3) (PSTD(K),K=1,NP) +!***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM. + DO 1010 K=1,25 + DO 1010 L=1,10 + RO31(L,K)=O3HI(L,K) + RO32(L,K)=O3HI(L,K) +1010 CONTINUE +! + DO 3000 NCASE=1,4 + ITAPE=NCASE+50 + IPLACE=2 + IF (NCASE.EQ.2) IPLACE=4 + IF (NCASE.EQ.3) IPLACE=1 + IF (NCASE.EQ.4) IPLACE=3 +!***NCASE=1: SPRING (IN N.H.) +!***NCASE=2: FALL (IN N.H.) +!***NCASE=3: WINTER (IN N.H.) +!***NCASE=4: SUMMER (IN N.H.) + IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN + DO 1011 K=26,41 + DO 1011 L=1,10 + RO31(L,K)=O3LO1(L,K-25) + RO32(L,K)=O3LO2(L,K-25) +1011 CONTINUE + ENDIF + IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN + DO 1031 K=26,41 + DO 1031 L=1,10 + RO31(L,K)=O3LO3(L,K-25) + RO32(L,K)=O3LO4(L,K-25) +1031 CONTINUE + ENDIF + DO 30 KK=1,NKK + DO 31 L=1,10 + DUO3N(L,KK)=RO31(11-L,KK) + 31 DUO3N(L+9,KK)=RO32(L,KK) + DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK)) + 30 CONTINUE +!***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON + IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN + DO 1024 KK=1,NKK + DO 1025 L=1,19 + TEMPN(L)=DUO3N(20-L,KK) +1025 CONTINUE + DO 1026 L=1,19 + DUO3N(L,KK)=TEMPN(L) +1026 CONTINUE +1024 CONTINUE + ENDIF +!***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE +! LEVELS +!KAC WRITE (6,800) DUO3N +!***BEGIN LATITUDE (10 DEG) LOOP + DO 33 L=1,19 + DO 22 KK=1,NKK + 22 RSTD(KK)=DUO3N(L,KK) + NKM=NK-1 + NKMM=NK-3 +! BESSELS HALF-POINT INTERPOLATION FORMULA + DO 60 K=4,NKMM,2 + KI=K/2 + 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ & + RSTD(KI-1))/16. + RDATA(2)=.5*(RSTD(2)+RSTD(1)) + RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1)) +! PUT UNCHANGED DATA INTO NEW ARRAY + DO 61 K=1,NK,2 + KQ=(K+1)/2 + 61 RDATA(K)=RSTD(KQ) +!---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT +! WRITE (6,798) RDATA +! CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL + DO 99 KK=1,N + RBAR(KK)=0. +! LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN + DO 98 K=1,NK + IF(PH(K+1).LT.PHALF(KK)) GO TO 98 + IF(PH(K).GT.PHALF(KK+1)) GO TO 98 + IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK & + )+RDATA(K)*(PH(K+1)-PHALF(KK)) + IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK & + )+RDATA(K)*(PH(K+1)-PH(K)) + IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK & + )+RDATA(K)*(PHALF(KK+1)-PH(K)) + 98 CONTINUE + RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK)) + IF(RBAR(KK).GT..0000) GO TO 99 +! CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE +! OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND +! PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM +! RDATA + DO 29 K=1,NK + IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K) + 29 CONTINUE + 99 CONTINUE +! CALCULATE TOTAL OZONE + O3RD=0. + DO 89 KK=1,80 + 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK)) + O3RD=O3RD+RDATA(81)*(P(81)-PH(81)) + O3RD=O3RD/980. + O3TOT=0. + DO 88 KK=1,N + 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK)) + O3TOT=O3TOT/980. +! UNITS ARE MICROGRAMS/CM**2 + O3DU=O3TOT/2.144 +! O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM) +!--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT +! WRITE (6,796) O3RD,O3TOT,O3DU + DO 23 KK=1,N + 23 DDUO3(L,KK)=RBAR(KK)*.01 + 33 CONTINUE +!***END OF LATITUDE LOOP +! +!***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF +! 10 DEG VALUES + DO 1060 KK=1,N + DO 1061 L=1,19 + O35DEG(2*L-1,KK)=DDUO3(L,KK) +1061 CONTINUE + DO 1062 L=1,18 + O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK)) +1062 CONTINUE +1060 CONTINUE +!***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE +!O222 *************************************************** +!C WRITE (66) O35DEG + IF (IPLACE.EQ.1) THEN + DO 302 JJ=1,37 + DO 302 KEN=1,N + DDUO3N(JJ,KEN) = O35DEG(JJ,KEN) + 302 CONTINUE + ELSE IF (IPLACE.EQ.2) THEN + DO 312 JJ=1,37 + DO 312 KEN=1,N + DDO3N2(JJ,KEN) = O35DEG(JJ,KEN) + 312 CONTINUE + ELSE IF (IPLACE.EQ.3) THEN + DO 322 JJ=1,37 + DO 322 KEN=1,N + DDO3N3(JJ,KEN) = O35DEG(JJ,KEN) + 322 CONTINUE + ELSE IF (IPLACE.EQ.4) THEN + DO 332 JJ=1,37 + DO 332 KEN=1,N + DDO3N4(JJ,KEN) = O35DEG(JJ,KEN) + 332 CONTINUE + END IF +!O222 *************************************************** +3000 CONTINUE +!***END OF LOOP OVER CASES + RETURN + 1 FORMAT(10F4.2) + 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X) + 3 FORMAT(10E12.5) + 797 FORMAT(10F7.2) + 799 FORMAT(19F6.4) + 800 FORMAT(19F6.2) + 102 FORMAT(' O3 IPLACE=',I4) + 1033 FORMAT(19F6.5) + 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, & + 1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,) + + END SUBROUTINE O3INT +!---------------------------------------------------------------- + + SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP & + , ids,ide, jds,jde, kds,kde & + , ims,ime, jms,jme, kms,kme & + , its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte +!---------------------------------------------------------------------- + +! ************************************************************ +! * * +! * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL * +! * * +! * Q. ZHAO 95-3-22 * +! * * +! ************************************************************ + + REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT + INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP + INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS + + REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT + REAL, DIMENSION(kts:kte+1) :: CLDROW + INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC + REAL :: XCLD + + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE + + ! DIMENSION CLDIPT(LP1,LP1, 64 ) + ! DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), & + ! KBTM(IDIM1:IDIM2,LP1) + ! DIMENSION CLDROW(LP1) + ! DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1) + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3 + LM1=L-1; LM2=L-2; LM3=L-3 + MYIS=its; MYIE=ite + +! + DO 1 IQ=MYIS,MYIE,64 + ITOP=IQ+63 + IF(ITOP.GT.MYIE) ITOP=MYIE + JTOP=ITOP-IQ+1 + DO 11 IP=1,JTOP + IR=IQ+IP-1 + IF (NCLDS(IR).EQ.0) THEN + DO 25 J=1,LP1 + DO 25 I=1,LP1 + CLDIPT(I,J,IP)=1. +25 CONTINUE + ENDIF + IF (NCLDS(IR).GE.1) THEN + XCLD=1.-CAMT(IR,2) + K1=KTOP(IR,2)+1 + K2=KBTM(IR,2) + DO 27 J=1,LP1 + CLDROW(J)=1. +27 CONTINUE + DO 29 J=1,K2 + CLDROW(J)=XCLD +29 CONTINUE + KB=MAX(K1,K2+1) + DO 33 K=KB,LP1 + DO 33 KP=1,LP1 + CLDIPT(KP,K,IP)=CLDROW(KP) +33 CONTINUE + DO 37 J=1,LP1 + CLDROW(J)=1. +37 CONTINUE + DO 39 J=K1,LP1 + CLDROW(J)=XCLD +39 CONTINUE + KT=MIN(K1-1,K2) + DO 43 K=1,KT + DO 43 KP=1,LP1 + CLDIPT(KP,K,IP)=CLDROW(KP) +43 CONTINUE + IF(K2+1.LE.K1-1) THEN + DO 31 J=K2+1,K1-1 + DO 31 I=1,LP1 + CLDIPT(I,J,IP)=1. +31 CONTINUE + ELSE IF(K1.LE.K2) THEN + DO 32 J=K1,K2 + DO 32 I=1,LP1 + CLDIPT(I,J,IP)=XCLD +32 CONTINUE + ENDIF + ENDIF + + IF (NCLDS(IR).GE.2) THEN + DO 21 NC=2,NCLDS(IR) + XCLD=1.-CAMT(IR,NC+1) + K1=KTOP(IR,NC+1)+1 + K2=KBTM(IR,NC+1) + DO 47 J=1,LP1 + CLDROW(J)=1. +47 CONTINUE + DO 49 J=1,K2 + CLDROW(J)=XCLD +49 CONTINUE + KB=MAX(K1,K2+1) + DO 53 K=KB,LP1 + DO 53 KP=1,LP1 + CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) +53 CONTINUE + DO 57 J=1,LP1 + CLDROW(J)=1. +57 CONTINUE + DO 59 J=K1,LP1 + CLDROW(J)=XCLD +59 CONTINUE + KT=MIN(K1-1,K2) + DO 63 K=1,KT + DO 63 KP=1,LP1 + CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) +63 CONTINUE + IF(K1.LE.K2) THEN + DO 52 J=K1,K2 + DO 52 I=1,LP1 + CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD +52 CONTINUE + ENDIF +21 CONTINUE + ENDIF +11 CONTINUE + DO 71 J=1,LP1 + DO 71 I=1,LP1 + DO 71 IP=1,JTOP + IR=IQ+IP-1 + CLDFAC(IR,I,J)=CLDIPT(I,J,IP) +71 CONTINUE +1 CONTINUE + + END SUBROUTINE CLO89 +!---------------------------------------------------------------- +! SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, & +! PRESS,TEMP,RH2O,QO3,CLDFAC, & +! CAMT,NCLDS,KTOP,KBTM, & +!! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & +! BO3RND,AO3RND, & +! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & +! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & +! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & +! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & +! TEN,HP1,FOUR,HM1EZ,SKO3R, & +! AB15WD,SKC1R,RADCON,QUARTR,TWO, & +! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & +! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + + SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, & + PRESS,TEMP,RH2O,QO3,CLDFAC, & + CAMT,NCLDS,KTOP,KBTM, & +! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & + BO3RND,AO3RND, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & + GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & + P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & + TEN,HP1,FOUR,HM1EZ, & + RADCON,QUARTR,TWO, & + HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & + RADCON1,H16E1, H28E1,H44194M2,H1P41819, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- +! INTEGER, PARAMETER :: NBLY=15 + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, INTENT(IN) :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR + REAL, INTENT(IN) :: GINV,H3M4,BETINW,RATH2OMW,GP0INV + REAL, INTENT(IN) :: P0XZP8,P0XZP2,H3M3,P0,H1M3 + REAL, INTENT(IN) :: H1M2,H25E2,B0,B1,B2,B3,HAF +! REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ,SKO3R + REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ +! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO + REAL, INTENT(IN) :: RADCON,QUARTR,TWO + REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2 +! REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D + REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819 +!---------------------------------------------------------------------- + REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND +! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW +! REAL, INTENT(IN), DIMENSION(5040) :: EM3V + REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & + BCOMB,BETACM + + REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT + INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP + INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS + + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: RH2O,QO3 + REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA + REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX + +! REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT + +! Include co2 data from a file, which needs to have exactly vertical +! dimension of the model. + + +!!! ??? co2 table +! REAL, DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,& +! C2D58,CO258 +! REAL, DIMENSION(kts:kte+1) :: STEMP,GTEMP,CO231,CO238, & +! C2D31,C2D38,CDT31,CDT38, & +! CO271,CO278,C2D71,C2D78, & +! CDT71,CDT78 +! REAL, DIMENSION(kts:kte) :: CO2M51,CO2M58,CDTM51,CDTM58, & +! C2DM51,C2DM58 +!!! end co2 table + +! REAL, DIMENSION(kts:kte+1) :: CLDROW + + REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,& + TPHIO3,TOTVO2,TSTDAV,TDAV, & + VSUM3,CO2R1,D2CD21,DCO2D1, & + CO2R2,D2CD22,DCO2D2,CO2SP1,& + CO2SP2,CO2R,DCO2DT,D2CDT2, & + TLSQU,DIFT + REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,& + QH2O,VV,VAR1,VAR2,VAR3,VAR4 + REAL, DIMENSION(its:ite,kts:kte+1) :: P,T + REAL, DIMENSION(its:ite,kts:kte) :: CO2MR,CO2MD,CO2M2D + REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL + + REAL, DIMENSION(its:ite) :: EMX1,EMX2,VSUM1,VSUM2,A1,A2 + REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21 + + ! COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1), + ! DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L) + ! DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1) + ! 1 CO2M2D(IDIM1:IDIM2,L) + ! DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L), + ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L), + ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L), + ! COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1), + ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1) + ! DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1) + ! DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1) + ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3 + ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2), + ! 2 VSUM2(IDIM1:IDIM2) + ! DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1), + ! LLP1=LL+1, LL = 2L + ! EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1) + ! DIMENSION TPHIO3(IDIM1:IDIM2,LP1), + ! DIMENSION TEXPSL(IDIM1:IDIM2,LP1) + ! DIMENSION QH2O(IDIM1:IDIM2,L) + ! DIMENSION DELP2(IDIM1:IDIM2,L) + ! DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L), + ! 1 VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L) + ! 1 VV(IDIM1:IDIM2,L) + ! DIMENSION CNTVAL(IDIM1:IDIM2,LP1) + ! DIMENSION TOTO3(IDIM1:IDIM2,LP1) + ! DIMENSION EMX1(IDIM1:IDIM2), + + ! DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), & + ! RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L) + ! DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2), & + ! TOPFLX(IDIM1:IDIM2) + +! +! +!****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP) +!****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE +! CORRECTIONS (TEXPSL) + + INTEGER :: K, I,KP + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + MYIS=its; MYIE=ite + + + DO 103 K=2,L + DO 103 I=MYIS,MYIE + P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K)) + T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K)) +103 CONTINUE + DO 105 I=MYIS,MYIE + P(I,1)=ZERO + P(I,LP1)=PRESS(I,LP1) + T(I,1)=TEMP(I,1) + T(I,LP1)=TEMP(I,LP1) +105 CONTINUE + DO 107 K=1,L + DO 107 I=MYIS,MYIE + DELP2(I,K)=P(I,K+1)-P(I,K) + DELP(I,K)=ONE/DELP2(I,K) +107 CONTINUE +!****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF. +! (THIS IS 1800.(1./TEMP-1./296.)) + DO 125 K=1,LP1 + DO 125 I=MYIS,MYIE + TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108 +!...THEN TAKE EXPONENTIAL + TEXPSL(I,K)=EXP(TEXPSL(I,K)) +125 CONTINUE +!***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY +! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE +! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4). +! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND +! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND +! O3,RESPECTIVELY. +! + DO 131 K=1,L + DO 131 I=MYIS,MYIE + QH2O(I,K)=RH2O(I,K)*DIFFCTR +!---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS +! THE LEVEL PRESSURE (PRESS) + VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV + VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV + VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV + VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4) + VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3) +! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS. +! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR +! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE +! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT +! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF +! AN ANGULAR INTEGRATION IS SEVERE. +! + CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ & + (RH2O(I,K)+RATH2OMW) +131 CONTINUE +! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM + DO 201 I=MYIS,MYIE + TOTPHI(I,1)=ZERO + TOTO3(I,1)=ZERO + TPHIO3(I,1)=ZERO + TOTVO2(I,1)=ZERO +201 CONTINUE + DO 203 K=2,LP1 + DO 203 I=MYIS,MYIE + TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1) + TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1) + TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1) + TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1) +203 CONTINUE +!---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO +! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS. +!---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO +! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1. +! + DO 801 I=MYIS,MYIE + EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV + EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV +801 CONTINUE +!---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1) +! OR TO PRESS(K+1) (INDEX LP2-LL) + DO 811 K=1,L + DO 811 I=MYIS,MYIE + EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV +811 CONTINUE + DO 812 K=1,LM1 + DO 812 I=MYIS,MYIE + EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) & + *GP0INV +812 CONTINUE + DO 821 I=MYIS,MYIE + EMPL(I,1)=VAR2(I,L) + EMPL(I,LLP1)=EMPL(I,LL) +821 CONTINUE +!***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS +! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD. +! TEMP. SOUNDING (DIFT) + DO 161 I=MYIS,MYIE + TSTDAV(I,1)=ZERO + TDAV(I,1)=ZERO +161 CONTINUE + DO 162 K=1,LP1 + DO 162 I=MYIS,MYIE + VSUM3(I,K)=TEMP(I,K)-STEMP(K) +162 CONTINUE + DO 163 K=1,L + DO 165 I=MYIS,MYIE + VSUM2(I)=GTEMP(K)*DELP2(I,K) + VSUM1(I)=VSUM2(I)*VSUM3(I,K) + TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I) + TDAV(I,K+1)=TDAV(I,K)+VSUM1(I) +165 CONTINUE +163 CONTINUE +! +!****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) + DO 171 I=MYIS,MYIE + A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2 + A2(I)=(P0-PRESS(I,LP1))/P0XZP2 +171 CONTINUE +!***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION +! FUNCTIONS AND TEMP. DERIVATIVES +!---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE +! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME) + DO 184 K=1,LP1 + DO 184 I=MYIS,MYIE + CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K) + D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K)) + DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K)) + CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K) + D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K)) + DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K)) +184 CONTINUE + DO 190 K=1,L + DO 190 I=MYIS,MYIE + CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K) + CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K)) + CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K)) +190 CONTINUE +!***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT +! +! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING +! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS +! CALCULATION IS FOR (I,KP,1) + DO 211 KP=2,LP1 + DO 211 I=MYIS,MYIE + DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP) +211 CONTINUE + DO 212 I=MYIS,MYIE + CO21(I,1,1)=1.0 + CO2SP1(I,1)=1.0 + CO2SP2(I,1)=1.0 +212 CONTINUE + DO 215 KP=2,LP1 + DO 215 I=MYIS,MYIE +!---CALCULATIONS FOR KP>1 FOR K=1 + CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1) + DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1)) + D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1)) + CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & + HAF*DIFT(I,KP)*D2CDT2(I,KP)) +!---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE +! SAME VALUE OF DIFT DUE TO SYMMETRY + CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP) + DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP)) + D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP)) + CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & + HAF*DIFT(I,KP)*D2CDT2(I,KP)) +215 CONTINUE +! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW. +!---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS +! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1)) + DO 250 K=2,LP1 + DO 250 I=MYIS,MYIE + CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* & + D2CD21(I,K)) + CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* & + D2CD22(I,K)) +250 CONTINUE +! +! NEXT THE CASE WHEN K=2...L + DO 220 K=2,L + DO 222 KP=K+1,LP1 + DO 222 I=MYIS,MYIE + DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ & + (TSTDAV(I,KP)-TSTDAV(I,K)) + CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K) + DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)) + D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)) + CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & + HAF*DIFT(I,KP)*D2CDT2(I,KP)) + CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP) + DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP)) + D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP)) + CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & + HAF*DIFT(I,KP)*D2CDT2(I,KP)) +222 CONTINUE +220 CONTINUE +! FINALLY THE CASE WHEN K=KP,K=2..LP1 + DO 206 K=2,LP1 + DO 206 I=MYIS,MYIE + DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1)) + CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K) + DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K)) + D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K)) + CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ & + HAF*DIFT(I,K)*D2CDT2(I,K)) +206 CONTINUE +!--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS . + DO 260 K=1,L + DO 260 I=MYIS,MYIE + CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* & + VSUM3(I,K)*CO2M2D(I,K)) +260 CONTINUE +!***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2) + DO 264 K=1,LP1 + DO 264 I=MYIS,MYIE + IF (T(I,K).LE.H25E2) THEN + TLSQU(I,K)=B0+(T(I,K)-H25E2)* & + (B1+(T(I,K)-H25E2)* & + (B2+B3*(T(I,K)-H25E2))) + ELSE + TLSQU(I,K)=B0 + ENDIF +264 CONTINUE +!***APPLY TO ALL CO2 TFS + DO 280 K=1,LP1 + DO 282 KP=1,LP1 + DO 282 I=MYIS,MYIE + CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP) +282 CONTINUE +280 CONTINUE + DO 284 K=1,LP1 + DO 286 I=MYIS,MYIE + CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) + CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) +286 CONTINUE +284 CONTINUE + DO 288 K=1,L + DO 290 I=MYIS,MYIE + CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K) +290 CONTINUE +288 CONTINUE +! CALL FST88(HEATRA,GRNFLX,TOPFLX, & +! QH2O,PRESS,P,DELP,DELP2,TEMP,T, & +! CLDFAC,NCLDS,KTOP,KBTM,CAMT, & +! CO21,CO2NBL,CO2SP1,CO2SP2, & +! VAR1,VAR2,VAR3,VAR4,CNTVAL, & +! TOTO3,TPHIO3,TOTPHI,TOTVO2, & +! EMX1,EMX2,EMPL, & +! +! BO3RND,AO3RND, & +!! T1,T2,T4 , EM1V,EM1VW, EM3V, & +! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & +! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, & +! AB15WD,SKC1R,RADCON,QUARTR,TWO, & +! HM6666M2,HMP66667,HMP5, & +! HP166666,H41666M2,RADCON1, & +! H16E1, H28E1, H25E2, H44194M2,H1P41819, & +! SKO2D, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + + CALL FST88(HEATRA,GRNFLX,TOPFLX, & + QH2O,PRESS,P,DELP,DELP2,TEMP,T, & + CLDFAC,NCLDS,KTOP,KBTM,CAMT, & + CO21,CO2NBL,CO2SP1,CO2SP2, & + VAR1,VAR2,VAR3,VAR4,CNTVAL, & + TOTO3,TPHIO3,TOTPHI,TOTVO2, & + EMX1,EMX2,EMPL, & +! + BO3RND,AO3RND, & +! T1,T2,T4 , EM1V,EM1VW, EM3V, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + TEN,HP1,HAF,ONE,FOUR,HM1EZ, & + RADCON,QUARTR,TWO, & + HM6666M2,HMP66667,HMP5, & + HP166666,H41666M2,RADCON1, & + H16E1, H28E1, H25E2, H44194M2,H1P41819, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + END SUBROUTINE LWR88 +!--------------------------------------------------------------------- +! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, & +! QH2O,PRESS,P,DELP,DELP2,TEMP,T, & +! CLDFAC,NCLDS,KTOP,KBTM,CAMT, & +! CO21,CO2NBL,CO2SP1,CO2SP2, & +! VAR1,VAR2,VAR3,VAR4,CNTVAL, & +! TOTO3,TPHIO3,TOTPHI,TOTVO2, & +! EMX1,EMX2,EMPL, & +! BO3RND,AO3RND, & +!! T1,T2,T4 , EM1V,EM1VW, EM3V, & +! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & +! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, & +! AB15WD,SKC1R,RADCON,QUARTR,TWO, & +! HM6666M2,HMP66667,HMP5, & +! HP166666,H41666M2,RADCON1, & +! H16E1, H28E1, H25E2, H44194M2,H1P41819, & +! SKO2D, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + + SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, & + QH2O,PRESS,P,DELP,DELP2,TEMP,T, & + CLDFAC,NCLDS,KTOP,KBTM,CAMT, & + CO21,CO2NBL,CO2SP1,CO2SP2, & + VAR1,VAR2,VAR3,VAR4,CNTVAL, & + TOTO3,TPHIO3,TOTPHI,TOTVO2, & + EMX1,EMX2,EMPL, & + BO3RND,AO3RND, & +! T1,T2,T4 , EM1V,EM1VW, EM3V, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + TEN,HP1,HAF,ONE,FOUR,HM1EZ, & + RADCON,QUARTR,TWO, & + HM6666M2,HMP66667,HMP5, & + HP166666,H41666M2,RADCON1, & + H16E1, H28E1, H25E2, H44194M2,H1P41819, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- +! INTEGER, PARAMETER :: NBLY=15 + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + +! REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R + REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ +! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO + REAL, INTENT(IN) :: RADCON,QUARTR,TWO + REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5 + REAL, INTENT(IN) :: HP166666,H41666M2,RADCON1,H16E1, H28E1 +! REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819,SKO2D + REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819 + + REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & + BCOMB,BETACM + +! REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW +! REAL, INTENT(IN), DIMENSION(5040) :: EM3V + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,& + CO2SP1,CO2SP2 + + REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2 + INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP + INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: QH2O + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP + REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA + REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T + REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21 + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, & + DELP,& + VAR1,VAR2,VAR3,VAR4 + REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND + REAL, INTENT(IN), DIMENSION(its:ite) :: EMX1,EMX2 + + REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2 + REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2 + INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO + REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, & + SS1,CSOUR,TC,OSS,CSS,DTC,SS2,& + AVEPHI,E1CTS1,E1FLX, & + E1CTW1,DSORC,EMISS,FAC1,& + TO3SP,OVER1D,CNTTAU,TOTEVV,& + CO2SP,FLX,AVMO3, & + AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,& + DELPR1 + REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,& + VSUM1,FLXNET,Z1 + + REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC + REAL, DIMENSION(its:ite,kts:kte) :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,& + CTSO3,CTS + REAL, DIMENSION(its:ite) :: GXCTS,FLX1E1 + REAL, DIMENSION(its:ite) :: PTOP,PBOT,FTOP,FBOT,DELPTC + REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC +! REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE + INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + LLM2 = LL-2; LLM1=LL-1 + MYIS=its; MYIE=ite + +! + DO 101 K=1,LP1 + DO 101 I=MYIS,MYIE +!---TEMP. INDICES FOR E1,SOURCE + VTMP3(I,K)=AINT(TEMP(I,K)*HP1) + FXO(I,K)=VTMP3(I,K)-9. + DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K) +!---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY) + IXO(I,K)=FXO(I,K) +101 CONTINUE + DO 103 k=1,L + DO 103 I=MYIS,MYIE +!---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS) + VTMP3(I,K)=AINT(T(I,K+1)*HP1) + FXOE2(I,K)=VTMP3(I,K)-9. + DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K) +103 CONTINUE +!---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS. + DO 105 I=MYIS,MYIE + FXOE2(I,LP1)=FXO(I,L) + DTE2(I,LP1)=DT(I,L) + FXOSP(I,1)=FXOE2(I,LM1) + FXOSP(I,2)=FXO(I,LM1) + DTSP(I,1)=DTE2(I,LM1) + DTSP(I,2)=DT(I,LM1) +105 CONTINUE +! +!---SOURCE FUNCTION FOR COMBINED BAND 1 + DO 4114 I=MYIS,MYIE + DO 4114 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),1) + DSORC(I,K)=DSRCE(IXO(I,K),1) +4114 CONTINUE + DO 4112 K=1,LP1 + DO 4112 I=MYIS,MYIE + SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4112 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 2 + DO 4214 I=MYIS,MYIE + DO 4214 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),2) + DSORC(I,K)=DSRCE(IXO(I,K),2) +4214 CONTINUE + DO 4212 K=1,LP1 + DO 4212 I=MYIS,MYIE + SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4212 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 3 + DO 4314 I=MYIS,MYIE + DO 4314 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),3) + DSORC(I,K)=DSRCE(IXO(I,K),3) +4314 CONTINUE + DO 4312 K=1,LP1 + DO 4312 I=MYIS,MYIE + SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4312 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 4 + DO 4414 I=MYIS,MYIE + DO 4414 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),4) + DSORC(I,K)=DSRCE(IXO(I,K),4) +4414 CONTINUE + DO 4412 K=1,LP1 + DO 4412 I=MYIS,MYIE + SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4412 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 5 + DO 4514 I=MYIS,MYIE + DO 4514 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),5) + DSORC(I,K)=DSRCE(IXO(I,K),5) +4514 CONTINUE + DO 4512 K=1,LP1 + DO 4512 I=MYIS,MYIE + SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4512 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 6 + DO 4614 I=MYIS,MYIE + DO 4614 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),6) + DSORC(I,K)=DSRCE(IXO(I,K),6) +4614 CONTINUE + DO 4612 K=1,LP1 + DO 4612 I=MYIS,MYIE + SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4612 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 7 + DO 4714 I=MYIS,MYIE + DO 4714 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),7) + DSORC(I,K)=DSRCE(IXO(I,K),7) +4714 CONTINUE + DO 4712 K=1,LP1 + DO 4712 I=MYIS,MYIE + SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4712 CONTINUE +!---SOURCE FUNCTION FOR COMBINED BAND 8 + DO 4814 I=MYIS,MYIE + DO 4814 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),8) + DSORC(I,K)=DSRCE(IXO(I,K),8) +4814 CONTINUE + DO 4812 K=1,LP1 + DO 4812 I=MYIS,MYIE + SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4812 CONTINUE +!---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1) + DO 4914 I=MYIS,MYIE + DO 4914 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),9) + DSORC(I,K)=DSRCE(IXO(I,K),9) +4914 CONTINUE + DO 4912 K=1,LP1 + DO 4912 I=MYIS,MYIE + SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +4912 CONTINUE +!---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1) + DO 5014 I=MYIS,MYIE + DO 5014 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),10) + DSORC(I,K)=DSRCE(IXO(I,K),10) +5014 CONTINUE + DO 5012 K=1,LP1 + DO 5012 I=MYIS,MYIE + SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +5012 CONTINUE +!---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1) + DO 5114 I=MYIS,MYIE + DO 5114 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),11) + DSORC(I,K)=DSRCE(IXO(I,K),11) +5114 CONTINUE + DO 5112 K=1,LP1 + DO 5112 I=MYIS,MYIE + SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +5112 CONTINUE +!---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1) + DO 5214 I=MYIS,MYIE + DO 5214 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),12) + DSORC(I,K)=DSRCE(IXO(I,K),12) +5214 CONTINUE + DO 5212 K=1,LP1 + DO 5212 I=MYIS,MYIE + SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +5212 CONTINUE +!---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1) + DO 5314 I=MYIS,MYIE + DO 5314 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),13) + DSORC(I,K)=DSRCE(IXO(I,K),13) +5314 CONTINUE + DO 5312 K=1,LP1 + DO 5312 I=MYIS,MYIE + SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +5312 CONTINUE +!---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1) + DO 5414 I=MYIS,MYIE + DO 5414 K=1,LP1 + VTMP3(I,K)=SOURCE(IXO(I,K),14) + DSORC(I,K)=DSRCE(IXO(I,K),14) +5414 CONTINUE + DO 5412 K=1,LP1 + DO 5412 I=MYIS,MYIE + SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) +5412 CONTINUE +! +! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2 +! +! +! CALL NLTE +! +! +!---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR) +! AND THE WINDOW REGION (SS1) + DO 131 K=1,LP1 + DO 131 I=MYIS,MYIE + SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14) +131 CONTINUE + DO 143 K=1,LP1 + DO 143 I=MYIS,MYIE + CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10) +143 CONTINUE +! +!---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES +! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA- +! TIONS. +! + DO 901 K=1,LP1 + DO 901 I=MYIS,MYIE + TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K) +901 CONTINUE + DO 903 K=1,L + DO 903 I=MYIS,MYIE + OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13) + CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K) + DTC(I,K+1)=TC(I,K+1)-TC(I,K) + SS2(I,K+1)=SS1(I,K+1)-SS1(I,K) +903 CONTINUE +! +! +!---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO +! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS +! ON THE FOLLOWING PRINCIPLES: +! +! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL +! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) +! OVER ALL KP'S, FROM 1 TO LP1. +! +! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS: +! +! FOR ALL K'S K=1 TO LP1: +! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1) +! OVER ALL KP'S, FROM K+1 TO LP1 +! AND +! FOR KP FROM K+1 TO LP1: +! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2) +! +! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS) +! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM +! K+1 TO LP1, EACH TIME K IS INCREMENTED. +! EQUATIONS (1) AND (2) THEN BECOME: +! +! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K) +! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3) +! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4) +! +! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR +! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND +! WITH CARE. +! +! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR +! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO, +! THE +! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI +!---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY +! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY +! MAY BE EXTRACTED HERE. + DO 3021 K=1,L + DO 3021 I=MYIS,MYIE + AVEPHI(I,K)=TOTPHI(I,K+1) +3021 CONTINUE +!---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1) +! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES +! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE +! (OTHERWISE VACANT) LP1'TH POSITION +! + DO 803 I=MYIS,MYIE + AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) +803 CONTINUE +! COMPUTE FLUXES FOR K=1 + CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, & + FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T, & +! T1,T2,T4 ,EM1V,EM1VW, & + H16E1,TEN,HP1,H28E1,HAF, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + DO 302 K=1,L + DO 302 I=MYIS,MYIE + FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1) + TO3SPC(I,K)=HAF*(FAC1(I,K)* & + (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE)) +! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS +! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY. + TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1))) + OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ & + SKC1R*TOTVO2(I,K+1))) +!---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE +! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH +! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU + CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1)) + TOTEVV(I,K)=1./CNTTAU(I,K) +302 CONTINUE + DO 3022 K=1,L + DO 3022 I=MYIS,MYIE + CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1) +3022 CONTINUE + DO 3023 K=1,L + DO 3023 I=MYIS,MYIE + CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K) +3023 CONTINUE +!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION + DO 1808 I=MYIS,MYIE + RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1) +1808 CONTINUE +!---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH +! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN +! THE OTHER CALCULATIONS + DO 305 K=2,LP1 + DO 305 I=MYIS,MYIE + FLX(I,K)= (TC(I,1)*E1FLX(I,K) & + +SS1(I,1)*CNTTAU(I,K-1) & + +SORC(I,1,13)*TO3SP(I,K-1) & + +CSOUR(I,1)*CO2SP(I,K)) & + *CLDFAC(I,1,K) +305 CONTINUE + DO 307 I=MYIS,MYIE + FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) & + +CSOUR(I,1) +307 CONTINUE +!---THE KP TERMS FOR K=1... + DO 303 KP=2,LP1 + DO 303 I=MYIS,MYIE + FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) & + +SS2(I,KP)*CNTTAU(I,KP-1) & + +CSS(I,KP)*CO21(I,KP,1) & + +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1) +303 CONTINUE +! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER +! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS. +! + CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, & + CLDFAC,TEMP,PRESS,VAR1,VAR2, & + P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, & + CO2SP1,CO2SP2,CO2SP, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & +! SKO2D,RADCON, & + RADCON, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! +! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2 +! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800- +! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE +! CONTAINED IN CTSO3, COMPUTED IN SPA88. +! + DO 998 I=MYIS,MYIE + VTMP3(I,1)=1. +998 CONTINUE + DO 999 K=1,L + DO 999 I=MYIS,MYIE + VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1) +999 CONTINUE + DO 1001 K=1,L + DO 1001 I=MYIS,MYIE + CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* & + (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + & + SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K))) +1001 CONTINUE +! + DO 1011 K=1,L + DO 1011 I=MYIS,MYIE + VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - & + CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K))) +1011 CONTINUE + DO 1012 I=MYIS,MYIE + FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* & + (E1CTS1(I,LP1)-E1CTW1(I,LP1)) +1012 CONTINUE + DO 1014 K=1,L + DO 1013 I=MYIS,MYIE + FLX1E1(I)=FLX1E1(I)+VTMP3(I,K) +1013 CONTINUE +1014 CONTINUE +! +!---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES. +! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL +! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS. +! + DO 321 K=2,LM1 + KLEN=K +! + DO 3218 KK=1,LP1-K + DO 3218 I=MYIS,MYIE + AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K) +3218 CONTINUE + DO 1803 I=MYIS,MYIE + AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) +1803 CONTINUE +!---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT +! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL +! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS +! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE +! THEIR FLUXES SEPARASTELY. +! + CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, & +! T1,T2,T4, & + H16E1,HP1,H28E1,HAF,TEN, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + DO 322 KK=1,LP1-K + DO 322 I=MYIS,MYIE + AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K) + AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K) + AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K) + CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1) +322 CONTINUE +! + DO 3221 KK=1,LP1-K + DO 3221 I=MYIS,MYIE + FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1) + VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* & + (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ & + FAC1(I,K+KK-1))-ONE)) + TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) & + +SKO3R*AVVO2(I,K+KK-1))) + OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ & + SKC1R*AVVO2(I,K+KK-1))) + CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K) +3221 CONTINUE + DO 3223 KP=K+1,LP1 + DO 3223 I=MYIS,MYIE + CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP) +3223 CONTINUE +!---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION + DO 1804 I=MYIS,MYIE + RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K) +1804 CONTINUE +!---THE KP TERMS FOR ARBIRRARY K.. + DO 3423 KP=K+1,LP1 + DO 3423 I=MYIS,MYIE + FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) & + +SS2(I,KP)*CONT1D(I,KP-1) & + +CSS(I,KP)*CO21(I,KP,K) & + +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K) +3423 CONTINUE + DO 3425 KP=K+1,LP1 + DO 3425 I=MYIS,MYIE + FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) & + +SS2(I,K)*CONT1D(I,KP-1) & + +CSS(I,K)*CO21(I,K,KP) & + +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP) +3425 CONTINUE +321 CONTINUE +! + DO 821 I=MYIS,MYIE + TPL(I,1)=TEMP(I,L) + TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L)) + TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L)) +821 CONTINUE + DO 823 K=2,L + DO 823 I=MYIS,MYIE + TPL(I,K)=T(I,K) + TPL(I,K+L)=T(I,K) +823 CONTINUE +! +!---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES, +! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1) + DO 833 I=MYIS,MYIE + AVEPHI(I,1)=VAR2(I,L) + AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L) +833 CONTINUE + CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, & +! T1,T2,T4, & + H16E1,TEN,H28E1,HP1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! +! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES +! CALL E3V88(EMD,TPL,EMPL,EM3V, & + CALL E3V88(EMD,TPL,EMPL, & + TEN,HP1,H28E1,H16E1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS +! USING METHODS FOR H2O GIVEN IN REF. (4) + DO 851 K=2,L + DO 851 I=MYIS,MYIE + EMISDG(I,K)=EMD(I,K+L)+EMD(I,K) +851 CONTINUE +! +! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN +! LWR88 + DO 861 I=MYIS,MYIE + EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ & + EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2)) + EMISDG(I,LP1)=TWO*EMD(I,LP1) + EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ & + EMX2(I) +861 CONTINUE + DO 331 I=MYIS,MYIE + FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L) + VTMP3(I,L)=HAF*(FAC1(I,L)* & + (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE)) + TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L))) + OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ & + SKC1R*CNTVAL(I,L))) + CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1) + RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L) +331 CONTINUE + DO 618 K=1,L + DO 618 I=MYIS,MYIE + RLOG(I,K)=LOG(RLOG(I,K)) +618 CONTINUE + DO 601 K=1,LM1 + DO 601 I=MYIS,MYIE + DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) + ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1) +601 CONTINUE + DO 603 K=1,L + DO 603 I=MYIS,MYIE + DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K)) + ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K) +603 CONTINUE + DO 625 I=MYIS,MYIE + ALP(I,LL)=-RLOG(I,L) + ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1))) +625 CONTINUE +! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE +! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION. +! +! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND +!***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY +! EVALUATED. + DO 631 K=1,LLP1 + DO 631 I=MYIS,MYIE + C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2)) +631 CONTINUE + DO 641 I=MYIS,MYIE + CO21(I,LP1,LP1)=ONE+C(I,L) + CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* & + C(I,LLM1))/(P(I,LP1)-PRESS(I,L)) + CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- & + (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1)) +641 CONTINUE + DO 643 K=2,L + DO 643 I=MYIS,MYIE + CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1)) +643 CONTINUE +! +! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE +! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS +! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4). + DO 651 K=1,LM1 + DO 651 I=MYIS,MYIE + CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1) + CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1) +651 CONTINUE +!---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED + DO 655 K=1,LLM2 + DO 655 I=MYIS,MYIE + CSUB2(I,K+1)=SKO3R*CSUB(I,K+1) + C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* & + (HP166666-CSUB(I,K+1)*H41666M2)) + C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* & + (HP166666-CSUB2(I,K+1)*H41666M2)) +655 CONTINUE + DO 661 I=MYIS,MYIE + CONTDG(I,LP1)=1.+C(I,LLM1) + TO3DG(I,LP1)=1.+C2(I,LLM1) +661 CONTINUE + DO 663 K=2,L + DO 663 I=MYIS,MYIE + CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K)) + TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K)) +663 CONTINUE +!---NOW OBTAIN FLUXES +! +! FOR THE DIAGONAL TERMS... + DO 871 K=2,LP1 + DO 871 I=MYIS,MYIE + FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) & + +SS2(I,K)*CONTDG(I,K) & + +OSS(I,K)*TO3DG(I,K) & + +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K) +871 CONTINUE +! FOR THE TWO OFF-DIAGONAL TERMS... + DO 873 I=MYIS,MYIE + FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) & + +DTC(I,LP1)*EMSPEC(I,2) & + +OSS(I,LP1)*TO31D(I,L) & + +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L) + FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) & + +OSS(I,L)*TO31D(I,L) & + +SS2(I,L)*CONT1D(I,L) & + +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1) +873 CONTINUE +! +! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, +! TOTAL HEATING RATES AND THE FLUX AT THE GROUND +! +! .....CALCULATE THE EMISSIVITY HEATING RATES + DO 1101 K=1,L + DO 1101 I=MYIS,MYIE + HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K) +1101 CONTINUE +! .....CALCULATE THE TOTAL HEATING RATES + DO 1103 K=1,L + DO 1103 I=MYIS,MYIE + HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K) +1103 CONTINUE +! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE +! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) + DO 1111 K=1,L + DO 1111 I=MYIS,MYIE + VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1 +1111 CONTINUE + DO 1115 I=MYIS,MYIE + TOPFLX(I)=FLX1E1(I)+GXCTS(I) + FLXNET(I,1)=TOPFLX(I) +1115 CONTINUE +!---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS +! THE THICK CLOUD SECTION IS INVOKED. + DO 1123 K=2,LP1 + DO 1123 I=MYIS,MYIE + FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1) +1123 CONTINUE + DO 1125 I=MYIS,MYIE + GRNFLX(I)=FLXNET(I,LP1) +1125 CONTINUE +! +! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD +! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT, +! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED. +!***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE +! ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS. + ICNT=0 + DO 1301 I=MYIS,MYIE + ICNT=ICNT+NCLDS(I) +1301 CONTINUE + IF (ICNT.EQ.0) GO TO 6999 +!---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW + KCLDS=NCLDS(MYIS) + DO 2106 I=MYIS,MYIE + KCLDS=MAX(NCLDS(I),KCLDS) +2106 CONTINUE +! +! +!***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF +! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE +! BEEN DEFINED!). + DO 1361 KK=1,KCLDS + KMIN=LP1 + KMAX=0 + DO 1362 I=MYIS,MYIE + J1=KTOP(I,KK+1) +! IF (J1.EQ.1) GO TO 1362 + J3=KBTM(I,KK+1) + IF (J3.GT.J1) THEN + PTOP(I)=P(I,J1) + PBOT(I)=P(I,J3+1) + FTOP(I)=FLXNET(I,J1) + FBOT(I)=FLXNET(I,J3+1) +!***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) + DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I)) + KMIN=MIN(KMIN,J1) + KMAX=MAX(KMAX,J3) + ENDIF +1362 CONTINUE + KMIN=KMIN+1 +!***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR +! ALL LEVELS. + DO 1365 K=KMIN,KMAX + DO 1363 I=MYIS,MYIE +! IF (KTOP(I,KK+1).EQ.1) GO TO 1363 + IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN + Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I) +!ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) + +!ORIGINAL1 Z1(I,K)*CAMT(I,KK+1) + FLXNET(I,K)=Z1(I,K) + ENDIF +1363 CONTINUE +1365 CONTINUE +1361 CONTINUE +!***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN +! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY +! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED. +! DO 6051 K=1,LP1 +! DO 6051 I=MYIS,MYIE +! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) + +! 1 Z1(I,K)*CAMT(I,NC) +!051 CONTINUE +!***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. +! DO 1401 K=1,LP1 +! DO 1401 I=MYIS,MYIE +! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I) +! 1 .AND. (NC-1).LE.NCLDS(I)) THEN +! FLXNET(I,K)=FLXTHK(I,K) +! ENDIF +!401 CONTINUE +! +!******END OF CLOUD LOOP***** +6001 CONTINUE +6999 CONTINUE +!***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE +! REVISED FLUXES: + DO 6101 K=1,L + DO 6101 I=MYIS,MYIE + HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K) +6101 CONTINUE +! THE THICK CLOUD SECTION ENDS HERE. + + END SUBROUTINE FST88 + +!---------------------------------------------------------------------- + + SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, & + AVEPHI,TEMP,T, & +! T1,T2,T4,EM1V,EM1VW, & + H16E1,TEN,HP1,H28E1,HAF, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF + + REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2 + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T + REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: G2,G5 +! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW + + REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2 + INTEGER,DIMENSION(its:ite,kts:kte*3+2) :: IT1 + INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL + +! REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, & +! TABLE3 +! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) +! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & +! (T4(1),TABLE3(1,1)) + + INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + LLM2 = LL-2; LLM1=LL-1 + MYIS=its; MYIE=ite + +!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE +! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE +! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN +! OBTAINED IN FST88, FOR CONVENIENCE. +! +!---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY-- +! +!---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS +! THE SPECIAL CASE FOR THE LP1TH LAYER. + + DO 1322 K=1,LP1 + DO 1322 I=MYIS,MYIE + TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1 + FYO(I,K)=AINT(TMP3(I,K)*TEN) + DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) + FYO(I,K)=H28E1*FYO(I,K) + IVAL(I,K)=FYO(I,K)+FXOE2(I,K) + EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & + +DTE2(I,K)*T4(IVAL(I,K)) +1322 CONTINUE +! +!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW +! BY AVERAGING THE VALUES FOR L AND LP1: + DO 1344 I=MYIS,MYIE + EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) +1344 CONTINUE +! +! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS +! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE +! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING +! TO THE FLUXES AT OTHER LEVELS. +! +!***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY +! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE +! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE +! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED +! IN THE E2 CALCS.,WITH K=1). +! +! +! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE +! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT +! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE +! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED. + DO 208 I=MYIS,MYIE + IT1(I,1)=FXOE1(I,1) + WW1(I,1)=TEN-DTE1(I,1) + WW2(I,1)=HP1 +208 CONTINUE + DO 209 K=1,L + DO 209 I=MYIS,MYIE + IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1) + IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K) + WW1(I,K+1)=TEN-DTE1(I,K+1) + WW2(I,K+1)=HP1-DU(I,K) +209 CONTINUE + DO 211 KP=1,L + DO 211 I=MYIS,MYIE + IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1) +211 CONTINUE +! +! +! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG) + DO 230 I=MYIS,MYIE + G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ & + WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1) + G3(I,1)=G1(I,1) +230 CONTINUE + DO 240 K=1,L + DO 240 I=MYIS,MYIE + G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ & + WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ & + WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ & + DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29) + G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ & + WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ & + WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ & + DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29) +240 CONTINUE + DO 241 KP=2,LP1 + DO 241 I=MYIS,MYIE + G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ & + WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ & + WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ & + DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29) +241 CONTINUE +! + DO 244 I=MYIS,MYIE + G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ & + WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1) +244 CONTINUE + DO 242 K=1,L + DO 242 I=MYIS,MYIE + G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ & + WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ & + WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ & + DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29) + G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ & + WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ & + WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ & + DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29) +242 CONTINUE +! + END SUBROUTINE E1E290 + +!---------------------------------------------------------------------- + + SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, & + CLDFAC,TEMP,PRESS,VAR1,VAR2, & + P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, & + CO2SP1,CO2SP2,CO2SP, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & +! SKO2D,RADCON, & + RADCON, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- +! INTEGER, PARAMETER :: NBLY=15 + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + + REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & + RADCON +! SKO2D,RADCON + + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR + REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3 + REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: EXCTS + REAL,INTENT(OUT),DIMENSION(its:ite) :: GXCTS + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC + REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP + + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2 + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: DELP,DELP2,TO3SPC + REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,& + CO2SP2,CO2SP + REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & + BCOMB,BETACM + + REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3 + REAL,DIMENSION(its:ite,kts:kte) ::X,Y,FAC1,FAC2,F,FF,AG,AGG, & + PHITMP,PSITMP,TOPM,TOPPHI,TT + + INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + LLM2 = LL-2; LLM1=LL-1 + MYIS=its; MYIE=ite + +!--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM + + DO 101 K=1,L + DO 101 I=MYIS,MYIE + X(I,K)=TEMP(I,K)-H25E2 + Y(I,K)=X(I,K)*X(I,K) +101 CONTINUE +!---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE +! TRANSMISSION FCTNS AT THE TOP. + DO 345 I=MYIS,MYIE + CTMP(I,1)=ONE + CTMP2(I,1)=1. + CTMP3(I,1)=1. +345 CONTINUE +!***BEGIN LOOP ON FREQUENCY BANDS (1)*** +! +!---CALCULATION FOR BAND 1 (COMBINED BAND 1) +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 301 K=1,L + DO 301 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +301 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 315 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +315 CONTINUE + DO 319 K=2,L + DO 317 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +317 CONTINUE +319 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 321 K=1,L + DO 321 I=MYIS,MYIE + FAC1(I,K)=ACOMB(1)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +321 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 353 K=1,L + DO 353 I=MYIS,MYIE + EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K)) +353 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 361 I=MYIS,MYIE + GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,1)-SORC(I,L,1))) +361 CONTINUE +! +! +!-----CALCULATION FOR BAND 2 (COMBINED BAND 2) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 401 K=1,L + DO 401 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +401 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 415 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +415 CONTINUE + DO 419 K=2,L + DO 417 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +417 CONTINUE +419 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 421 K=1,L + DO 421 I=MYIS,MYIE + FAC1(I,K)=ACOMB(2)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +421 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 453 K=1,L + DO 453 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* & + (CTMP(I,K+1)-CTMP(I,K)) +453 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 461 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,2)-SORC(I,L,2))) +461 CONTINUE +! +!-----CALCULATION FOR BAND 3 (COMBINED BAND 3) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 501 K=1,L + DO 501 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +501 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 515 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +515 CONTINUE + DO 519 K=2,L + DO 517 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +517 CONTINUE +519 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 521 K=1,L + DO 521 I=MYIS,MYIE + FAC1(I,K)=ACOMB(3)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +521 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 553 K=1,L + DO 553 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* & + (CTMP(I,K+1)-CTMP(I,K)) +553 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 561 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,3)-SORC(I,L,3))) +561 CONTINUE +! +!-----CALCULATION FOR BAND 4 (COMBINED BAND 4) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 601 K=1,L + DO 601 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +601 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 615 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +615 CONTINUE + DO 619 K=2,L + DO 617 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +617 CONTINUE +619 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 621 K=1,L + DO 621 I=MYIS,MYIE + FAC1(I,K)=ACOMB(4)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +621 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 653 K=1,L + DO 653 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* & + (CTMP(I,K+1)-CTMP(I,K)) +653 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 661 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,4)-SORC(I,L,4))) +661 CONTINUE +! +!-----CALCULATION FOR BAND 5 (COMBINED BAND 5) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 701 K=1,L + DO 701 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +701 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 715 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +715 CONTINUE + DO 719 K=2,L + DO 717 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +717 CONTINUE +719 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 721 K=1,L + DO 721 I=MYIS,MYIE + FAC1(I,K)=ACOMB(5)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(5)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +721 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 753 K=1,L + DO 753 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* & + (CTMP(I,K+1)-CTMP(I,K)) +753 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 761 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,5)-SORC(I,L,5))) +761 CONTINUE +! +!-----CALCULATION FOR BAND 6 (COMBINED BAND 6) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 801 K=1,L + DO 801 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +801 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 815 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +815 CONTINUE + DO 819 K=2,L + DO 817 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +817 CONTINUE +819 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 821 K=1,L + DO 821 I=MYIS,MYIE + FAC1(I,K)=ACOMB(6)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(6)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +821 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 853 K=1,L + DO 853 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* & + (CTMP(I,K+1)-CTMP(I,K)) +853 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 861 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,6)-SORC(I,L,6))) +861 CONTINUE +! +!-----CALCULATION FOR BAND 7 (COMBINED BAND 7) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 901 K=1,L + DO 901 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +901 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 915 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +915 CONTINUE + DO 919 K=2,L + DO 917 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +917 CONTINUE +919 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 921 K=1,L + DO 921 I=MYIS,MYIE + FAC1(I,K)=ACOMB(7)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(7)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +921 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 953 K=1,L + DO 953 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* & + (CTMP(I,K+1)-CTMP(I,K)) +953 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 961 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,7)-SORC(I,L,7))) +961 CONTINUE +! +!-----CALCULATION FOR BAND 8 (COMBINED BAND 8) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1001 K=1,L + DO 1001 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1001 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1015 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1015 CONTINUE + DO 1019 K=2,L + DO 1017 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1017 CONTINUE +1019 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1021 K=1,L + DO 1021 I=MYIS,MYIE + FAC1(I,K)=ACOMB(8)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(8)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1021 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1053 K=1,L + DO 1053 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* & + (CTMP(I,K+1)-CTMP(I,K)) +1053 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1061 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,8)-SORC(I,L,8))) +1061 CONTINUE +! +!-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1101 K=1,L + DO 1101 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1101 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1115 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1115 CONTINUE + DO 1119 K=2,L + DO 1117 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1117 CONTINUE +1119 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1121 K=1,L + DO 1121 I=MYIS,MYIE + FAC1(I,K)=ACOMB(9)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1121 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1153 K=1,L + DO 1153 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* & + (CTMP(I,K+1)-CTMP(I,K)) +1153 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1161 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,9)-SORC(I,L,9))) +1161 CONTINUE +! +!-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1201 K=1,L + DO 1201 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1201 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1215 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1215 CONTINUE + DO 1219 K=2,L + DO 1217 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1217 CONTINUE +1219 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1221 K=1,L + DO 1221 I=MYIS,MYIE + FAC1(I,K)=ACOMB(10)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1221 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1253 K=1,L + DO 1253 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* & + (CTMP(I,K+1)-CTMP(I,K)) +1253 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1261 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,10)-SORC(I,L,10))) +1261 CONTINUE +! +!-----CALCULATION FOR BAND 11 (800-900 CM-1) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1301 K=1,L + DO 1301 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1301 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1315 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1315 CONTINUE + DO 1319 K=2,L + DO 1317 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1317 CONTINUE +1319 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1321 K=1,L + DO 1321 I=MYIS,MYIE + FAC1(I,K)=ACOMB(11)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(11)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1321 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1353 K=1,L + DO 1353 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* & + (CTMP(I,K+1)-CTMP(I,K)) +1353 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1361 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,11)-SORC(I,L,11))) +1361 CONTINUE +! +!-----CALCULATION FOR BAND 12 (900-990 CM-1) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1401 K=1,L + DO 1401 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1401 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1415 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1415 CONTINUE + DO 1419 K=2,L + DO 1417 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1417 CONTINUE +1419 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1421 K=1,L + DO 1421 I=MYIS,MYIE + FAC1(I,K)=ACOMB(12)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(12)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1421 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1453 K=1,L + DO 1453 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* & + (CTMP(I,K+1)-CTMP(I,K)) +1453 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1461 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,12)-SORC(I,L,12))) +1461 CONTINUE +! +!-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3)) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1501 K=1,L + DO 1501 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1501 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1515 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1515 CONTINUE + DO 1519 K=2,L + DO 1517 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1517 CONTINUE +1519 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1521 K=1,L + DO 1521 I=MYIS,MYIE + FAC1(I,K)=ACOMB(13)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K))) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1521 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1553 K=1,L + DO 1553 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* & + (CTMP(I,K+1)-CTMP(I,K)) +1553 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1561 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,13)-SORC(I,L,13))) +1561 CONTINUE +! +!-----CALCULATION FOR BAND 14 (1070-1200 CM-1) +! +! +!---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY +! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED +! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) + DO 1601 K=1,L + DO 1601 I=MYIS,MYIE + F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K)) + FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K)) + AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE + AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE + PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) + PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) +1601 CONTINUE +!---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE +! P(K) (TOPM,TOPPHI) + DO 1615 I=MYIS,MYIE + TOPM(I,1)=PHITMP(I,1) + TOPPHI(I,1)=PSITMP(I,1) +1615 CONTINUE + DO 1619 K=2,L + DO 1617 I=MYIS,MYIE + TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) + TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) +1617 CONTINUE +1619 CONTINUE +!---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION + DO 1621 K=1,L + DO 1621 I=MYIS,MYIE + FAC1(I,K)=ACOMB(14)*TOPM(I,K) + FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K)) + TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & + BETACM(14)*TOTVO2(I,K+1)*SKO2D)) + CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) +1621 CONTINUE +!---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS + DO 1653 K=1,L + DO 1653 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* & + (CTMP(I,K+1)-CTMP(I,K)) +1653 CONTINUE +!---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS + DO 1661 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ & + (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & + TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & + (SORC(I,LP1,14)-SORC(I,L,14))) +1661 CONTINUE +! +! +! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND +! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE +! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT +! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS +! REDUCING COMPUTATIONS! + DO 1731 K=1,L + DO 1731 I=MYIS,MYIE + GXCTS(I)=GXCTS(I)-EXCTS(I,K) +1731 CONTINUE +! +! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE +! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON) + DO 1741 K=1,L + DO 1741 I=MYIS,MYIE + EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K) +1741 CONTINUE +!---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT +! EXCTS HAS ITS APPROPRIATE VALUE. +! +!*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS +! (CTSO3) + DO 1711 K=1,L + DO 1711 I=MYIS,MYIE + CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1) + CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1) +1711 CONTINUE + DO 1701 K=1,L + DO 1701 I=MYIS,MYIE + CTSO3(I,K)=RADCON*DELP(I,K)* & + (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + & + SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K))) +1701 CONTINUE + + END SUBROUTINE SPA88 +!---------------------------------------------------------------------- + + SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, & +! T1,T2,T4, & + H16E1,HP1,H28E1,HAF,TEN, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: KLEN + REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN + REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB + REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2 + +! REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4 + + REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS + + REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU + INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL + +! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3 +! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & +! (T4(1),TABLE3(1,1)) +! EQUIVALENCE (TMP3,DT) + + INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + LLM2 = LL-2; LLM1=LL-1 + MYIS=its; MYIE=ite + + +!---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE +! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE +! THUS GENERATES THE E2 FUNCTION. +! +!---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL +! CASE: RESULTS ARE IN EMISS + + + + DO 132 K=1,LP2-KLEN + DO 132 I=MYIS,MYIE + TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1 + FYO(I,K)=AINT(TMP3(I,K)*TEN) + DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) + FYO(I,K)=H28E1*FYO(I,K) + IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1) + EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & + +DTE2(I,KLEN+K-1)*T4(IVAL(I,K)) +132 CONTINUE +!---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW +! BY AVERAGING THE VALUES FOR L AND LP1: + DO 1344 I=MYIS,MYIE + EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) +1344 CONTINUE +!---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT. +! +!---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB. +! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING +! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH +! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT +! INVOLVED HERE. +! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN +! EMISSB(I,(KLEN) TO L) + DO 142 K=1,LP1-KLEN + DO 142 I=MYIS,MYIE + DT(I,K)=DTE2(I,KLEN-1) + IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1) +142 CONTINUE +! + DO 234 K=1,LP1-KLEN + DO 234 I=MYIS,MYIE + EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & + +DT(I,K)*T4(IVAL(I,K)) +234 CONTINUE + + END SUBROUTINE E290 + +!--------------------------------------------------------------------- + + SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, & +! T1,T2,T4, & + H16E1,TEN,H28E1,HP1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1 + REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS + REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI + REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP + +! REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4 + +! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3 +! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & +! (T4(1),TABLE3(1,1)) + + INTEGER :: K,I,MYIS,MYIE + + REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU + INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL + + MYIS=its + MYIE=ite + + DO 132 K=1,2 + DO 132 I=MYIS,MYIE + TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1 + FYO(I,K)=AINT(TMP3(I,K)*TEN) + DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) + IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K) + EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ & + DTSP(I,K)*T4(IVAL(I,K)) +132 CONTINUE + + END SUBROUTINE E2SPEC + +!--------------------------------------------------------------------- + +! SUBROUTINE E3V88(EMV,TV,AV,EM3V, & + SUBROUTINE E3V88(EMV,TV,AV, & + TEN,HP1,H28E1,H16E1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, INTENT(IN) :: TEN,HP1,H28E1,H16E1 +!----------------------------------------------------------------------- + REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: TV,AV +! REAL, INTENT(IN), DIMENSION(5040) :: EM3V + + REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,& + FYO +! REAL, DIMENSION(5040) :: EM3V + +! EQUIVALENCE (EM3V(1),EM3(1,1)) + + INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT + + INTEGER :: LLP1,I,K,MYIS,MYIE ,L + L = kte + LLP1 = 2*L + 1 + MYIS=its; MYIE=ite + +!---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND +! K (1-LLP1) + + DO 203 K=1,LLP1 + DO 203 I=MYIS,MYIE + FXO(I,K)=AINT(TV(I,K)*HP1) + TMP3(I,K)=LOG10(AV(I,K))+H16E1 + DT(I,K)=TV(I,K)-TEN*FXO(I,K) + FYO(I,K)=AINT(TMP3(I,K)*TEN) + DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) +!---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE +! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K. + IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1 + WW1(I,K)=TEN-DT(I,K) + WW2(I,K)=HP1-DU(I,K) + EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ & + WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ & + WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ & + DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20) +203 CONTINUE + + END SUBROUTINE E3V88 +!----------------------------------------------------------------------- + + SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, & + DFSWL, & + PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, & + NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT, & + ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, & +! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, & + ABCFF,PWTS, & + H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, & + HP816,RRAYAV,GINV,CFCO2,CFO3, & + TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, & + H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, & + H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL,INTENT(IN) :: RRCO2,SSOLAR + REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,& + GINV,CFCO2,CFO3 + REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2 + REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ + REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON +!---------------------------------------------------------------------- + INTEGER, PARAMETER :: NB=12 + REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT + REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3 + REAL, INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND + INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS + INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW + REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT + + REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: & + FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL + REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND + REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS + +! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3 +! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2 + + REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3 + REAL, DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2 + + REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3 + REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD + REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU + REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN + REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT + REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1 + REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN, & + UFNTRN,TCLU,TCLD,ALFA,ALFAU, & + UFNCLU,DFNCLU + + REAL, DIMENSION(its:ite,NB) :: DFNTOP + REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX + +! EQUIVALENCE & +! (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) & +! , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) & +! , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) & +! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) & +! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) & +! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) & +! , (PR2 , TDCL2) + +! EQUIVALENCE & +! (UDO3,DFNCLU), (URO3,UFNCLU) & +! , (UDCO2,TCLD ), (URCO2,TCLU) & +! , (TDO3 ,DFNTRN),(TUO3,UFNTRN) & +!! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) & +! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) & +! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) & +! , (PR2 , TDCL2) + + INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL + REAL :: DENOM,HTEMP,TEMPF,TEMPG + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + MYIS=its; MYIE=ite + MYIS1=MYIS+1 ! ?? + + DO 100 I=MYIS,MYIE + SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE) + PP(I,1) = ZERO + PP(I,LP1) = PRESS(I,LP1) + TMP1(I) = ONE/PRESS(I,LP1) +100 CONTINUE + DO 110 K=1,LM1 + DO 110 I=MYIS,MYIE + PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K)) +110 CONTINUE + DO 120 K=1,L + DO 120 I=MYIS,MYIE + DP (I,K) = PP(I,K+1)-PP(I,K) + PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1)) +120 CONTINUE + DO 130 K=1,L + DO 130 I=MYIS,MYIE + PR2(I,K) = PR2(I,K)*TMP1(I) +130 CONTINUE +! CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS) + DO 140 N=1,NB + DO 140 IP=MYIS,MYIE + DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N) +140 CONTINUE +! EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION +! FOR THE VISIBLE BAND + DO 150 I=MYIS,MYIE + RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) + REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ & + (ONE-ALVD(I)*RRAYAV) +150 CONTINUE + DO 155 I=MYIS,MYIE + RRAY(I) = 0.104/(ONE+4.8*COSZRO(I)) + REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ & + (ONE-ALVD(I)*0.093) +155 CONTINUE +! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER +! IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2. +! DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3. + DO 160 K=1,L + DO 160 I=MYIS,MYIE + DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K) + DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K) + DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K) +160 CONTINUE +! +! CALCULATE CLEAR SKY SW FLUX +! +! OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE +! FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD +! PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING +! QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3. + DO 200 IP=MYIS,MYIE + UD (IP,1) = ZERO + UDCO2(IP,1) = ZERO + UDO3 (IP,1) = ZERO +! SH + UO3 (IP,1) = UDO3 (IP,1) + UCO2 (IP,1) = UDCO2(IP,1) + +200 CONTINUE + DO 210 K=2,LP1 + DO 210 I=MYIS,MYIE + UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I) + UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I) + UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I) +! SH + UO3 (I,K) = UDO3 (I,K) + UCO2 (I,K) = UDCO2(I,K) + +210 CONTINUE + DO 220 IP=MYIS,MYIE + UR (IP,LP1) = UD (IP,LP1) + URCO2(IP,LP1) = UDCO2(IP,LP1) + URO3 (IP,LP1) = UDO3 (IP,LP1) +! SH + UO3 (IP,LP1+LP1) = URO3 (IP,LP1) + UCO2 (IP,LP1+LP1) = URCO2(IP,LP1) + +220 CONTINUE + DO 230 K=L,1,-1 + DO 230 IP=MYIS,MYIE + UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR + URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR + URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR +! SH + UO3 (IP,LP1+K) = URO3 (IP,K) + UCO2(IP,LP1+K) = URCO2(IP,K) + +230 CONTINUE +! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED +! BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED +! BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX, +! AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT +! OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2. +! SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE +! VALUES ACTUALLY STORED IN TCO2. + DO 240 K=1,LL + DO 240 I=MYIS,MYIE + TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) & + -H75826M4) +240 CONTINUE + +! SH + DO 241 K=1,L + DO 241 I=MYIS,MYIE + TDCO2(I,K+1)=TCO2(I,K+1) +241 CONTINUE + DO 242 K=1,L + DO 242 I=MYIS,MYIE + TUCO2(I,K)=TCO2(I,LP1+K) +242 CONTINUE + +! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN +! THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS +! 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED +! BY 2. THE TRANSMISSIONS ARE STORED IN TO3. + HTEMP = H1036E2*H1036E2*H1036E2 + DO 250 K=1,LL + DO 250 I=MYIS,MYIE + TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* & + (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ & + H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ & + H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1)))) +250 CONTINUE + +! SH + DO 251 K=1,L + DO 251 I=MYIS,MYIE + TDO3(I,K+1)=TO3(I,K+1) +251 CONTINUE + DO 252 K=1,L + DO 252 I=MYIS,MYIE + TUO3(I,K)=TO3(I,LP1+K) +252 CONTINUE + + +! START FREQUENCY LOOP (ON N) HERE +! +!--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION + DO 260 K=1,L + DO 260 I=MYIS,MYIE + TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) + TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) + DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1) + UFN(I,K) = TTU(I,K)*TUO3(I,K) +260 CONTINUE + DO 270 I=MYIS,MYIE + DFN(I,1) = ONE + UFN(I,LP1) = DFN(I,LP1) +270 CONTINUE +! SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE +! ATMOSPHERE (DFNTOP(I,1)) +! DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS + DO 280 K=1,LP1 + DO 280 I=MYIS,MYIE + DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1) + UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1) +280 CONTINUE + DO 285 I=MYIS,MYIE + GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I)) + GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - & + (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I)) + GDFNB(I) = ZERO + GDFND(I) = ZERO +285 CONTINUE +!---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME +! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND +! TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS +! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. + DO 350 N=2,NB + IF (N.EQ.2) THEN +! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO +! THAT OF BAND 1 (SAVED AS TTD,TTU) +!--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION + DO 290 K=1,L + DO 290 I=MYIS,MYIE + DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1) + UFN(I,K) = TTU(I,K)*TUCO2(I,K) +290 CONTINUE + ELSE +! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED +! BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH +! IS THE SAME FOR ALL INFRARED BANDS. + DO 300 K=1,L + DO 300 I=MYIS,MYIE + DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) & + *TDCO2(I,K+1) + UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) & + *TUCO2(I,K) +300 CONTINUE + ENDIF +!---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR +! ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS. + DO 310 I=MYIS,MYIE + DFN(I,1) = ONE + UFN(I,LP1) = DFN(I,LP1) +310 CONTINUE +! SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP +! AND SUM OVER BANDS + DO 320 K=1,LP1 + DO 320 I=MYIS,MYIE + DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N) + UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N) +320 CONTINUE + DO 330 I=MYIS,MYIE + GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N) +330 CONTINUE +350 CONTINUE + DO 360 K=1,LP1 + DO 360 I=MYIS,MYIE + FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K) +360 CONTINUE + DO 370 K=1,L + DO 370 I=MYIS,MYIE + HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K) +370 CONTINUE +! +!---END OF FREQUENCY LOOP (OVER N) +! +! CALCULATE CLOUDY SKY SW FLUX +! + KCLDS=NCLDS(MYIS) + DO 400 I=MYIS1,MYIE + KCLDS=MAX(NCLDS(I),KCLDS) +400 CONTINUE + DO 410 K=1,LP1 + DO 410 I=MYIS,MYIE + DFSWC(I,K) = DFSWL(I,K) + UFSWC(I,K) = UFSWL(I,K) + FSWC (I,K) = FSWL (I,K) +410 CONTINUE + DO 420 K=1,L + DO 420 I=MYIS,MYIE + HSWC(I,K) = HSWL(I,K) +420 CONTINUE +!******************************************************************* + IF (KCLDS .EQ. 0) RETURN +!******************************************************************* + DO 430 K=1,LP1 + DO 430 I=MYIS,MYIE + XAMT(I,K) = CAMT(I,K) +430 CONTINUE + DO 470 I=MYIS,MYIE + NNCLDS = NCLDS(I) + CCMAX(I) = ZERO + IF (NNCLDS .LE. 0) GO TO 470 + CCMAX(I) = ONE + DO 450 K=1,NNCLDS + CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1)) +450 CONTINUE + CCMAX(I) = ONE - CCMAX(I) + IF (CCMAX(I) .GT. ZERO) THEN + DO 460 K=1,NNCLDS + XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I) +460 CONTINUE + END IF +470 CONTINUE + DO 480 K=1,LP1 + DO 480 I=MYIS,MYIE + FF (I,K) = DIFFCTR + FFCO2(I,K) = DIFFCTR + FFO3 (I,K) = O3DIFCTR +480 CONTINUE + DO 490 IP=MYIS,MYIE + JTOP = KTOPSW(IP,NCLDS(IP)+1) + DO 490 K=1,JTOP + FF (IP,K) = SECZ(IP) + FFCO2(IP,K) = SECZ(IP) + FFO3 (IP,K) = SECZ(IP) +490 CONTINUE + DO 500 I=MYIS,MYIE + RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) + REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ & + (ONE-ALVD(I)*RRAYAV) +500 CONTINUE + DO 510 IP=MYIS,MYIE + UD (IP,1) = ZERO + UDCO2(IP,1) = ZERO + UDO3 (IP,1) = ZERO +! SH + UO3 (IP,1) = UDO3 (IP,1) + UCO2 (IP,1) = UDCO2(IP,1) + +510 CONTINUE + DO 520 K=2,LP1 + DO 520 I=MYIS,MYIE + UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K) + UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K) + UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K) +! SH + UO3 (I,K) = UDO3 (I,K) + UCO2(I,K) = UDCO2(I,K) + +520 CONTINUE + DO 530 IP=MYIS,MYIE + UR (IP,LP1) = UD (IP,LP1) + URCO2(IP,LP1) = UDCO2(IP,LP1) + URO3 (IP,LP1) = UDO3 (IP,LP1) +! SH + UO3 (IP,LP1+LP1) = URO3 (IP,LP1) + UCO2 (IP,LP1+LP1) = URCO2(IP,LP1) + +530 CONTINUE + DO 540 K=L,1,-1 + DO 540 IP=MYIS,MYIE + UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR + URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR + URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR +! SH + UO3 (IP,LP1+K) = URO3 (IP,K) + UCO2(IP,LP1+K) = URCO2(IP,K) + +540 CONTINUE + DO 550 K=1,LL + DO 550 I=MYIS,MYIE + TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) & + -H75826M4) +550 CONTINUE +! SH + DO 551 K=1,L + DO 551 I=MYIS,MYIE + TDCO2(I,K+1)=TCO2(I,K+1) +551 CONTINUE + DO 552 K=1,L + DO 552 I=MYIS,MYIE + TUCO2(I,K)=TCO2(I,LP1+K) +552 CONTINUE + + DO 560 K=1,LL + DO 560 I=MYIS,MYIE + TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* & + (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ & + H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ & + H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1)))) +560 CONTINUE +! SH + DO 561 K=1,L + DO 561 I=MYIS,MYIE + TDO3(I,K+1)=TO3(I,K+1) +561 CONTINUE + DO 562 K=1,L + DO 562 I=MYIS,MYIE + TUO3(I,K)=TO3(I,LP1+K) +562 CONTINUE + +!******************************************************************** +!---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN +! BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!). +!******************************************************************** + DO 570 I=MYIS,MYIE + CR(I,1) = REFL(I) +570 CONTINUE +!***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR +! REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND +!---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES +! EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE). + DO 581 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 581 + DO 580 KK=2,KCLDS+1 + CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK) + CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK) +580 CONTINUE +581 CONTINUE +!---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF +! "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED +! LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL +! FREQUENCY BANDS. + DO 591 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 591 + DO 590 KK=1,KCLDS + IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN + PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1)) + DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1))) + ENDIF +590 CONTINUE +591 CONTINUE + DO 600 K=1,L + DO 600 I=MYIS,MYIE + TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) + TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) + TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1) + TTU (I,K) = TTUB1(I,K)*TUO3(I,K) +600 CONTINUE + DO 610 I=MYIS,MYIE + TTD(I,1) = ONE + TTU(I,LP1) = TTD(I,LP1) +610 CONTINUE +!***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT +! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR +! EACH BAND N. THE REQUIRED QUANTITIES ARE: +! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: +! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: +! TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: +! AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE +! STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY, +! AS THEY HAVE MULTIPLE USE IN THE PGM. +!---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: + DO 620 I=MYIS,MYIE + TDCL1 (I,1) = TTD(I,LP1) + TUCL1 (I,1) = TTU(I,LP1) + TDCL2 (I,1) = TDCL1(I,1) + DFNTRN(I,1) = ONE/TDCL1(I,1) + UFNTRN(I,1) = DFNTRN(I,1) +620 CONTINUE + DO 631 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 631 + DO 630 KK=2,KCLDS+1 + TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) + TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) + TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) +630 CONTINUE +631 CONTINUE +!---COMPUTE INVERSES + DO 641 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 641 +! SH + DO 640 KK=2,KCLDS+1 + DFNTRN(I,KK) = ONE/TDCL1(I,KK) + UFNTRN(I,KK) = ONE/TUCL1(I,KK) +640 CONTINUE +641 CONTINUE +!---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE +! TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS +! QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY +! FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH +! ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K). + DO 651 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 651 + DO 650 KK=1,KCLDS + TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1) + TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1) +650 CONTINUE +651 CONTINUE +!***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION +! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE +! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW +! THE CLOUD IN QUESTION. +!---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION + DO 660 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 660 + ALFA (I,1)=CR(I,1) + ALFAU(I,1)=ZERO +660 CONTINUE +!---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! + DO 671 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 671 + DO 670 KK=2,KCLDS+1 + ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ & + (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) + ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK) +670 CONTINUE +671 CONTINUE +! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS +!---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP +! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX +! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST +! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE +! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU +! EQUALS ALFA. THIS IS ALSO CORRECT. + DO 680 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 680 + UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1) + DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1) +680 CONTINUE +!---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED +! ABOVE + DO 691 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 691 + DO 690 KK=KCLDS,1,-1 + UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* & + TCLU(I,KK)) + DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK) +690 CONTINUE +691 CONTINUE + DO 701 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 701 + DO 700 KK=1,KCLDS+1 + UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK) + DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK) +700 CONTINUE +701 CONTINUE +!---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD) + DO 720 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 720 + J2=KBTMSW(I,2) + DO 710 K=J2,LP1 + UFN(I,K) = UFNTRN(I,1)*TTU(I,K) + DFN(I,K) = DFNTRN(I,1)*TTD(I,K) +710 CONTINUE +720 CONTINUE +!---REMAINING LEVELS (IF ANY!) + DO 760 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 760 + DO 755 KK=2,KCLDS+1 + J1=KTOPSW(I,KK) + J2=KBTMSW(I,KK+1) + IF (J1.EQ.1) GO TO 755 + DO 730 K=J2,J1 + UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) + DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) +730 CONTINUE +!---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD +! LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY +! TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX). + J3=KBTMSW(I,KK) + IF ((J3-J1).GT.1) THEN + TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) + TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) + DO 740 K=J1+1,J3-1 + UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) + DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) +740 CONTINUE + ENDIF +755 CONTINUE +760 CONTINUE + DO 770 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 770 + DO 771 K=1,LP1 + DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1) + UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1) +771 CONTINUE +770 CONTINUE + DO 780 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 780 + TMP1(I) = ONE - CCMAX(I) + GDFVB(I) = TMP1(I)*GDFVB(I) + GDFNB(I) = TMP1(I)*GDFNB(I) + GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1) +780 CONTINUE +!---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME +! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND +! TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS +! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. +! + DO 1000 N=2,NB +!YH93 + DO 791 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 791 + DO 790 K=1,KCLDS+1 + CR(I,K) = CRR(I,N,K)*XAMT(I,K) + CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K) +790 CONTINUE +791 CONTINUE +!YH93 + IF (N.EQ.2) THEN +! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO +! THAT OF BAND 1 (SAVED AS TTDB1,TTUB1) + DO 800 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 800 + DO 801 KK=2,LP1 + TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK) +801 CONTINUE + DO 802 KK=1,L + TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK) +802 CONTINUE +800 CONTINUE + ELSE + DO 810 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 810 + DO 811 KK=2,LP1 + TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) & + * TDCO2(I,KK) +811 CONTINUE + DO 812 KK=1,L + TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) & + * TUCO2(I,KK) +812 CONTINUE +810 CONTINUE + ENDIF +!---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR +! ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS. + DO 820 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 820 + TTU(I,LP1) = TTD(I,LP1) + TTD(I,1) = ONE +820 CONTINUE +!***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT +! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR +! EACH BAND N. THE REQUIRED QUANTITIES ARE: +! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: +! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1: +! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: +! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED +! IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS +! THEY HAVE MULTIPLE USE IN THE PGM. +!---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: + DO 830 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 830 + TDCL1 (I,1) = TTD(I,LP1) + TUCL1 (I,1) = TTU(I,LP1) + TDCL2 (I,1) = TDCL1(I,1) + DFNTRN(I,1) = ONE/TDCL1(I,1) + UFNTRN(I,1) = DFNTRN(I,1) +830 CONTINUE + DO 841 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 841 + DO 840 KK=2,KCLDS+1 + TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) + TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) + TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) +840 CONTINUE +841 CONTINUE + DO 851 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 851 + DO 850 KK=2,KCLDS+1 + DFNTRN(I,KK) = ONE/TDCL1(I,KK) + UFNTRN(I,KK) = ONE/TUCL1(I,KK) +850 CONTINUE +851 CONTINUE + DO 861 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 861 + DO 860 KK=1,KCLDS + TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1) + TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1) +860 CONTINUE +861 CONTINUE +!***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION +! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE +! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW +! THE CLOUD IN QUESTION. + DO 870 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 870 + ALFA (I,1) = CR(I,1) + ALFAU(I,1) = ZERO +870 CONTINUE +!---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! + DO 881 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 881 + DO 880 KK=2,KCLDS+1 + ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - & + TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) + ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK) +880 CONTINUE +881 CONTINUE +! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS +!---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP +! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX +! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST +! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE +! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU +! EQUALS ALFA. THIS IS ALSO CORRECT. + DO 890 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 890 + UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1) + DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1) +890 CONTINUE + DO 901 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 901 + DO 900 KK=KCLDS,1,-1 +! +!*** ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT +! + DENOM=ALFA(I,KK+1)*TCLU(I,KK) + IF(DENOM.GT.RTHRESH)THEN + UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM + ELSE + UFNCLU(I,KK)=0. + ENDIF + IF(ALFA(I,KK).GT.RTHRESH)THEN + DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK) + ELSE + DFNCLU(I,KK)=0. + ENDIF +900 CONTINUE +901 CONTINUE +! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS + DO 911 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 911 + DO 910 KK=1,KCLDS+1 + UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK) + DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK) +910 CONTINUE +911 CONTINUE + DO 930 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 930 + J2=KBTMSW(I,2) + DO 920 K=J2,LP1 + UFN(I,K) = UFNTRN(I,1)*TTU(I,K) + DFN(I,K) = DFNTRN(I,1)*TTD(I,K) +920 CONTINUE +930 CONTINUE + DO 970 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 970 + DO 965 KK=2,KCLDS+1 + J1 = KTOPSW(I,KK) + J2 = KBTMSW(I,KK+1) + IF (J1.EQ.1) GO TO 965 + DO 940 K=J2,J1 + UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) + DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) +940 CONTINUE + J3 = KBTMSW(I,KK) + IF ((J3-J1).GT.1) THEN + TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) + TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) + DO 950 K=J1+1,J3-1 + UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) + DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) +950 CONTINUE + ENDIF +965 CONTINUE +970 CONTINUE + DO 980 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 980 + DO 981 K=1,LP1 + DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N) + UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N) +981 CONTINUE +980 CONTINUE + DO 990 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 990 + GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N) +990 CONTINUE +1000 CONTINUE + DO 1100 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 1100 + DO 1101 K=1,LP1 + DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K) + UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K) +1101 CONTINUE +1100 CONTINUE + DO 1200 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 1200 + DO 1201 KK=1,LP1 + FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK) +1201 CONTINUE +1200 CONTINUE + DO 1250 I=MYIS,MYIE + KCLDS=NCLDS(I) + IF(KCLDS.EQ.0) GO TO 1250 + DO 1251 KK=1, L + HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK) +1251 CONTINUE +1250 CONTINUE + + END SUBROUTINE SWR93 +!----------------------------------------------------------------------- + + SUBROUTINE RADFS & + +! ***************************************************************** +! * * +! * THE INTERNAL DRIVE FOR GFDL RADIATION * +! * THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993) * +! * AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL * +! * NOV. 18, 1993 * +! * * +! * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION * +! * ON EACH MODEL LAYER. * +! * QINGYUN ZHAO 95-3-22 * +! ***************************************************************** +!*** +!*** REQUIRED INPUT: +!*** + (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT & +!BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] + , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL & + , COSZRO,TAUDAR,IBEG & + , KO3,KALB & + , ITIMSW,ITIMLW & +!*************************************************************************** +!* IX IS THE LENGTH OF A ROW IN THE DOMAIN +! +!* QS(IX): THE SURFACE PRESSURE (PA) +!* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.) +!* PPI(IX,LP1) THE INTERFACE PRESSURES (PA) +!* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG) +!* TT(IX,L): THE MIDLAYER TEMPERATURE (K) +!* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO +!* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER +!* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1) +!* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION) +!* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES +!* (N.H.> 0) +!* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER +!* LAYER=1:SURFACE +!* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON +!* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER +!* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE) +!* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL) +!* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER +!* NCLDS(IX): NUMBER OF CLOUD LAYERS +!* EMCLD(IX,LP1): CLOUD EMISSIVITY +!* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS +!* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS +!* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER +!* +!* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE +!* TAUDAR: =1.0 +!* IBEG: =1 +!* KO3: =1 ( READ IN THE QZONE DATA) +!* KALB: =0 +!* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED) +!* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED) +!************************************************************************ +!*** +!*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL +!*** + , SWH,HLW & + , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC & + , ids,ide, jds,jde, kds,kde & + , ims,ime, jms,jme, kms,kme & +! begin debugging radiation + , its,ite, jts,jte, kts,kte & + , imd,jmd, Jndx ) +! end debugging radiation +!************************************************************************ +!* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S. +!* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM). +!* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S. +!* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM). +!* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. +!* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL). +!* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. +!* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL). +!* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. +!* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL). +!* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. +!* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL). +!* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. +!* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL). +!* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2. +!* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL). +!* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2. +!* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL). +!* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. +!* FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL). +!************************************************************************ +!*** +!*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL +!*** +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- +!INTEGER, PARAMETER :: NBLY=15 + INTEGER, PARAMETER :: NB=12 + INTEGER, PARAMETER :: NBLX=47 + INTEGER , PARAMETER:: NBLW = 163 + + REAL,PARAMETER :: AMOLWT=28.9644 + REAL,PARAMETER :: CSUBP=1.00484E7 + REAL,PARAMETER :: DIFFCTR=1.66 + REAL,PARAMETER :: G=980.665 + REAL,PARAMETER :: GINV=1./G + REAL,PARAMETER :: GRAVDR=980.0 + REAL,PARAMETER :: O3DIFCTR=1.90 + REAL,PARAMETER :: P0=1013250. + REAL,PARAMETER :: P0INV=1./P0 + REAL,PARAMETER :: GP0INV=GINV*P0INV + REAL,PARAMETER :: P0XZP2=202649.902 + REAL,PARAMETER :: P0XZP8=810600.098 + REAL,PARAMETER :: P0X2=2.*1013250. + REAL,PARAMETER :: RADCON=8.427 + REAL,PARAMETER :: RADCON1=1./8.427 + REAL,PARAMETER :: RATCO2MW=1.519449738 + REAL,PARAMETER :: RATH2OMW=.622 + REAL,PARAMETER :: RGAS=8.3142E7 + REAL,PARAMETER :: RGASSP=8.31432E7 + REAL,PARAMETER :: SECPDA=8.64E4 +! +!******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* +! ARRANGED IN DECREASING ORDER + REAL,PARAMETER :: HUNDRED=100. + REAL,PARAMETER :: HNINETY=90. + REAL,PARAMETER :: HNINE=9.0 + REAL,PARAMETER :: SIXTY=60. + REAL,PARAMETER :: FIFTY=50. + REAL,PARAMETER :: TEN=10. + REAL,PARAMETER :: EIGHT=8. + REAL,PARAMETER :: FIVE=5. + REAL,PARAMETER :: FOUR=4. + REAL,PARAMETER :: THREE=3. + REAL,PARAMETER :: TWO=2. + REAL,PARAMETER :: ONE=1. + REAL,PARAMETER :: HAF=0.5 + REAL,PARAMETER :: QUARTR=0.25 + REAL,PARAMETER :: ZERO=0. +! +!******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) +! ARRANGED IN DECREASING ORDER + REAL,PARAMETER :: H83E26=8.3E26 + REAL,PARAMETER :: H71E26=7.1E26 + REAL,PARAMETER :: H1E15=1.E15 + REAL,PARAMETER :: H1E13=1.E13 + REAL,PARAMETER :: H1E11=1.E11 + REAL,PARAMETER :: H1E8=1.E8 + REAL,PARAMETER :: H2E6=2.0E6 + REAL,PARAMETER :: H1E6=1.0E6 + REAL,PARAMETER :: H69766E5=6.97667E5 + REAL,PARAMETER :: H4E5=4.E5 + REAL,PARAMETER :: H165E5=1.65E5 + REAL,PARAMETER :: H5725E4=57250. + REAL,PARAMETER :: H488E4=48800. + REAL,PARAMETER :: H1E4=1.E4 + REAL,PARAMETER :: H24E3=2400. + REAL,PARAMETER :: H20788E3=2078.8 + REAL,PARAMETER :: H2075E3=2075. + REAL,PARAMETER :: H18E3=1800. + REAL,PARAMETER :: H1224E3=1224. + REAL,PARAMETER :: H67390E2=673.9057 + REAL,PARAMETER :: H5E2=500. + REAL,PARAMETER :: H3082E2=308.2 + REAL,PARAMETER :: H3E2=300. + REAL,PARAMETER :: H2945E2=294.5 + REAL,PARAMETER :: H29316E2=293.16 + REAL,PARAMETER :: H26E2=260.0 + REAL,PARAMETER :: H25E2=250. + REAL,PARAMETER :: H23E2=230. + REAL,PARAMETER :: H2E2=200.0 + REAL,PARAMETER :: H15E2=150. + REAL,PARAMETER :: H1386E2=138.6 + REAL,PARAMETER :: H1036E2=103.6 + REAL,PARAMETER :: H8121E1=81.21 + REAL,PARAMETER :: H35E1=35. + REAL,PARAMETER :: H3116E1=31.16 + REAL,PARAMETER :: H28E1=28. + REAL,PARAMETER :: H181E1=18.1 + REAL,PARAMETER :: H18E1=18. + REAL,PARAMETER :: H161E1=16.1 + REAL,PARAMETER :: H16E1=16. + REAL,PARAMETER :: H1226E1=12.26 + REAL,PARAMETER :: H9P94=9.94 + REAL,PARAMETER :: H6P08108=6.081081081 + REAL,PARAMETER :: H3P6=3.6 + REAL,PARAMETER :: H3P5=3.5 + REAL,PARAMETER :: H2P9=2.9 + REAL,PARAMETER :: H2P8=2.8 + REAL,PARAMETER :: H2P5=2.5 + REAL,PARAMETER :: H1P8=1.8 + REAL,PARAMETER :: H1P4387=1.4387 + REAL,PARAMETER :: H1P41819=1.418191 + REAL,PARAMETER :: H1P4=1.4 + REAL,PARAMETER :: H1P25892=1.258925411 + REAL,PARAMETER :: H1P082=1.082 + REAL,PARAMETER :: HP816=0.816 + REAL,PARAMETER :: HP805=0.805 + REAL,PARAMETER :: HP8=0.8 + REAL,PARAMETER :: HP60241=0.60241 + REAL,PARAMETER :: HP602409=0.60240964 + REAL,PARAMETER :: HP6=0.6 + REAL,PARAMETER :: HP526315=0.52631579 + REAL,PARAMETER :: HP518=0.518 + REAL,PARAMETER :: HP5048=0.5048 + REAL,PARAMETER :: HP3795=0.3795 + REAL,PARAMETER :: HP369=0.369 + REAL,PARAMETER :: HP26=0.26 + REAL,PARAMETER :: HP228=0.228 + REAL,PARAMETER :: HP219=0.219 + REAL,PARAMETER :: HP166666=.166666 + REAL,PARAMETER :: HP144=0.144 + REAL,PARAMETER :: HP118666=0.118666192 + REAL,PARAMETER :: HP1=0.1 +! (NEGATIVE EXPONENTIALS BEGIN HERE) + REAL,PARAMETER :: H658M2=0.0658 + REAL,PARAMETER :: H625M2=0.0625 + REAL,PARAMETER :: H44871M2=4.4871E-2 + REAL,PARAMETER :: H44194M2=.044194 + REAL,PARAMETER :: H42M2=0.042 + REAL,PARAMETER :: H41666M2=0.0416666 + REAL,PARAMETER :: H28571M2=.02857142857 + REAL,PARAMETER :: H2118M2=0.02118 + REAL,PARAMETER :: H129M2=0.0129 + REAL,PARAMETER :: H1M2=.01 + REAL,PARAMETER :: H559M3=5.59E-3 + REAL,PARAMETER :: H3M3=0.003 + REAL,PARAMETER :: H235M3=2.35E-3 + REAL,PARAMETER :: H1M3=1.0E-3 + REAL,PARAMETER :: H987M4=9.87E-4 + REAL,PARAMETER :: H323M4=0.000323 + REAL,PARAMETER :: H3M4=0.0003 + REAL,PARAMETER :: H285M4=2.85E-4 + REAL,PARAMETER :: H1M4=0.0001 + REAL,PARAMETER :: H75826M4=7.58265E-4 + REAL,PARAMETER :: H6938M5=6.938E-5 + REAL,PARAMETER :: H394M5=3.94E-5 + REAL,PARAMETER :: H37412M5=3.7412E-5 + REAL,PARAMETER :: H15M5=1.5E-5 + REAL,PARAMETER :: H1439M5=1.439E-5 + REAL,PARAMETER :: H128M5=1.28E-5 + REAL,PARAMETER :: H102M5=1.02E-5 + REAL,PARAMETER :: H1M5=1.0E-5 + REAL,PARAMETER :: H7M6=7.E-6 + REAL,PARAMETER :: H4999M6=4.999E-6 + REAL,PARAMETER :: H451M6=4.51E-6 + REAL,PARAMETER :: H25452M6=2.5452E-6 + REAL,PARAMETER :: H1M6=1.E-6 + REAL,PARAMETER :: H391M7=3.91E-7 + REAL,PARAMETER :: H1174M7=1.174E-7 + REAL,PARAMETER :: H8725M8=8.725E-8 + REAL,PARAMETER :: H327M8=3.27E-8 + REAL,PARAMETER :: H257M8=2.57E-8 + REAL,PARAMETER :: H1M8=1.0E-8 + REAL,PARAMETER :: H23M10=2.3E-10 + REAL,PARAMETER :: H14M10=1.4E-10 + REAL,PARAMETER :: H11M10=1.1E-10 + REAL,PARAMETER :: H1M10=1.E-10 + REAL,PARAMETER :: H83M11=8.3E-11 + REAL,PARAMETER :: H82M11=8.2E-11 + REAL,PARAMETER :: H8M11=8.E-11 + REAL,PARAMETER :: H77M11=7.7E-11 + REAL,PARAMETER :: H72M11=7.2E-11 + REAL,PARAMETER :: H53M11=5.3E-11 + REAL,PARAMETER :: H48M11=4.8E-11 + REAL,PARAMETER :: H44M11=4.4E-11 + REAL,PARAMETER :: H42M11=4.2E-11 + REAL,PARAMETER :: H37M11=3.7E-11 + REAL,PARAMETER :: H35M11=3.5E-11 + REAL,PARAMETER :: H32M11=3.2E-11 + REAL,PARAMETER :: H3M11=3.0E-11 + REAL,PARAMETER :: H28M11=2.8E-11 + REAL,PARAMETER :: H24M11=2.4E-11 + REAL,PARAMETER :: H23M11=2.3E-11 + REAL,PARAMETER :: H2M11=2.E-11 + REAL,PARAMETER :: H18M11=1.8E-11 + REAL,PARAMETER :: H15M11=1.5E-11 + REAL,PARAMETER :: H14M11=1.4E-11 + REAL,PARAMETER :: H114M11=1.14E-11 + REAL,PARAMETER :: H11M11=1.1E-11 + REAL,PARAMETER :: H1M11=1.E-11 + REAL,PARAMETER :: H96M12=9.6E-12 + REAL,PARAMETER :: H93M12=9.3E-12 + REAL,PARAMETER :: H77M12=7.7E-12 + REAL,PARAMETER :: H74M12=7.4E-12 + REAL,PARAMETER :: H65M12=6.5E-12 + REAL,PARAMETER :: H62M12=6.2E-12 + REAL,PARAMETER :: H6M12=6.E-12 + REAL,PARAMETER :: H45M12=4.5E-12 + REAL,PARAMETER :: H44M12=4.4E-12 + REAL,PARAMETER :: H4M12=4.E-12 + REAL,PARAMETER :: H38M12=3.8E-12 + REAL,PARAMETER :: H37M12=3.7E-12 + REAL,PARAMETER :: H3M12=3.E-12 + REAL,PARAMETER :: H29M12=2.9E-12 + REAL,PARAMETER :: H28M12=2.8E-12 + REAL,PARAMETER :: H24M12=2.4E-12 + REAL,PARAMETER :: H21M12=2.1E-12 + REAL,PARAMETER :: H16M12=1.6E-12 + REAL,PARAMETER :: H14M12=1.4E-12 + REAL,PARAMETER :: H12M12=1.2E-12 + REAL,PARAMETER :: H8M13=8.E-13 + REAL,PARAMETER :: H46M13=4.6E-13 + REAL,PARAMETER :: H36M13=3.6E-13 + REAL,PARAMETER :: H135M13=1.35E-13 + REAL,PARAMETER :: H12M13=1.2E-13 + REAL,PARAMETER :: H1M13=1.E-13 + REAL,PARAMETER :: H3M14=3.E-14 + REAL,PARAMETER :: H15M14=1.5E-14 + REAL,PARAMETER :: H14M14=1.4E-14 +! +!******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) +! ARRANGED IN DESCENDING ORDER + REAL,PARAMETER :: HM2M2=-.02 + REAL,PARAMETER :: HM6666M2=-.066667 + REAL,PARAMETER :: HMP5=-0.5 + REAL,PARAMETER :: HMP575=-0.575 + REAL,PARAMETER :: HMP66667=-.66667 + REAL,PARAMETER :: HMP805=-0.805 + REAL,PARAMETER :: HM1EZ=-1. + REAL,PARAMETER :: HM13EZ=-1.3 + REAL,PARAMETER :: HM19EZ=-1.9 + REAL,PARAMETER :: HM1E1=-10. + REAL,PARAMETER :: HM1597E1=-15.97469413 + REAL,PARAMETER :: HM161E1=-16.1 + REAL,PARAMETER :: HM1797E1=-17.97469413 + REAL,PARAMETER :: HM181E1=-18.1 + REAL,PARAMETER :: HM8E1=-80. + REAL,PARAMETER :: HM1E2=-100. +! + REAL,PARAMETER :: H1M16=1.0E-16 + REAL,PARAMETER :: H1M20=1.E-20 + REAL,PARAMETER :: Q19001=19.001 + REAL,PARAMETER :: DAYSEC=1.1574E-5 + REAL,PARAMETER :: HSIGMA=5.673E-8 + REAL,PARAMETER :: TWENTY=20.0 + REAL,PARAMETER :: HP537=0.537 + REAL,PARAMETER :: HP2=0.2 + REAL,PARAMETER :: RCO2=3.3E-4 + REAL,PARAMETER :: H3M6=3.0E-6 + REAL,PARAMETER :: PI=3.1415927 + REAL,PARAMETER :: DEGRAD=180.0/PI + REAL,PARAMETER :: H74E1=74.0 + REAL,PARAMETER :: H15E1=15.0 + + REAL, PARAMETER:: B0 = -.51926410E-4 + REAL, PARAMETER:: B1 = -.18113332E-3 + REAL, PARAMETER:: B2 = -.10680132E-5 + REAL, PARAMETER:: B3 = -.67303519E-7 + REAL, PARAMETER:: AWIDE = 0.309801E+01 + REAL, PARAMETER:: BWIDE = 0.495357E-01 + REAL, PARAMETER:: BETAWD = 0.347839E+02 + REAL, PARAMETER:: BETINW = 0.766811E+01 + + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW +!---------------------------------------------------------------------- +! **************************************************************** +! * GENERALIZED FOR PLUG-COMPATIBILITY - * +! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..* +!......* EXAMPLE FOR MRF: * +! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) * +! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)* +! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... * +! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA * +! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... * +! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 * +! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE * +! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) * +! * SLMSK = 0. * +! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH * +! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR * +! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 * +! * ALBEDO GE .5 * +! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR * +! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 * +! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... * +! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 * +! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) * +! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) * +! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME * +! * =1 USE TEMP DEP. CLD EMIS SCHEME * +! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE * +! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' * +! * ......YH FEB 93 * +! **************************************************************** +!-------------------------------- +! INTEGER, PARAMETER:: LNGTH=37*kte +!-------------------------------- + +! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D + + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O + REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD + REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT + REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR + REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS + INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS + INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM + REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL + REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3 +! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW +! REAL, INTENT(IN), DIMENSION(5040) :: EM3V + +! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR + +! TABLE ??? + + REAL, DIMENSION(3) :: BO3RND,AO3RND + REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & + BCOMB,BETACM + + DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/ + DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/ + + DATA ACOMB / & + 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, & + 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, & + 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, & + 0.178110E-01, 0.170166E+00, 0.537083E-02/ + DATA BCOMB / & + 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, & + 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, & + 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, & + 0.875182E-01, 0.857907E-01, 0.214005E+00/ + DATA APCM / & + -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, & + 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, & + 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, & + 0.279259E-01, 0.197002E-01, 0.349782E-01/ + DATA BPCM / & + -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, & + -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, & + -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, & + -0.982953E-04, -0.772497E-04, -0.748263E-04/ + DATA ATPCM / & + -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, & + 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, & + 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, & + 0.281662E-01, 0.199525E-01, 0.370962E-01/ + DATA BTPCM / & + -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, & + -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, & + -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, & + -0.933645E-04, -0.664045E-04, -0.115290E-03/ + DATA BETACM / & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, & + 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, & + 0.589554E+01, 0.495227E+01, 0.000000E+00/ + + +! ********************************************* +!====> * OUTPUT TO CALLING PROGRAM * +! ********************************************* + + REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW + REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, & + FSWDNS,FLWUP,FLWDNS,FSWDNSC + +! ********************************************* +!====> * POSSIBLE OUTPUT TO CALLING PROGRAM * +! ********************************************* + + REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR + +! ************************************************************ +!====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) * +! ************************************************************ + + REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL + +! ****************************************************** +!====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB * +! ****************************************************** + + REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC + REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF + REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA + REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX + REAL, DIMENSION(kts:kte+1)::PHALF +!..... ADD PRESSURE INTERFACE + + REAL, DIMENSION(NB) :: ABCFF,PWTS + + DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., & + 989.,2706.,39011./ + DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, & + .001467,.002342,.001075/ + + REAL :: CFCO2,CFO3,REFLO3,RRAYAV + + DATA CFCO2,CFO3/508.96,466.64/ + DATA REFLO3/1.9/ + DATA RRAYAV/0.144/ + +! ********************************************* +!====> * VECTOR TEMPORARIES FOR CLOUD CALC. * +! ********************************************* + + REAL, DIMENSION(its:ite):: TTHAN + REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP + INTEGER, DIMENSION(its:ite):: JJROW + +!====> ************************************************************** +!-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN +! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE). +! DEFINED AS 5 DEG LAT MEANS N.P.->S.P. +! COMMON /SAVMEM/ & +!- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... +! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L) + + REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4 + +!====> ************************************************************** +! + REAL, DIMENSION(21,20) :: ALBD + REAL, DIMENSION(20) :: ZA + REAL, DIMENSION(21) :: TRN + REAL, DIMENSION(19) :: DZA + + REAL :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2 + INTEGER :: IR,IQ,JX + DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, & + .70,.75,.80,.85,.90,.95,1.00/ + + REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6) + + EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), & + (ALB33(1,1),ALBD(1,15)) + DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, & + .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, & + .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, & + .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, & + .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, & + .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, & + .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, & + .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, & + .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, & + .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, & + .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, & + .246,.235,.222,.211,.205,.200/ + DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, & + .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, & + .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, & + .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, & + .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, & + .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, & + .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, & + .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, & + .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, & + .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, & + .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, & + .058,.055,.054,.053,.052,.052/ + DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, & + .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, & + .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, & + .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, & + .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, & + .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, & + .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, & + .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, & + .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, & + .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/ + DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., & + 50.,40.,30.,20.,10.,0.0/ + DATA DZA/8*2.0,6*4.0,5*10.0/ + +! *********************************************************** +! + + REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, & + GDFVB, & + GDFNB,GDFVD,GDFND, & + SFCALB + + REAL :: RRVCO2,RRCO2,TDUM + REAL :: ALBD0,ALVD1,ALND1 + INTEGER :: N +! +!*** The following two lines are for debugging. + integer :: imd,jmd, Jndx + real :: FSWrat,FSWrat1,FSWDNS1 +!*** + +!====> BEGIN HERE ....................... +! +!--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE; +! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN. + REAL,PARAMETER :: H196=1.96 + + INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 + INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN + + L=kte + LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 + LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L + LLM2 = LL-2; LLM1=LL-1 + MYIS=its; MYIE=ite + +!******ZHAO +! NOTE: XLAT IS IN DEGREE HERE +!*****ZHAO +!-- Formerly => SOLC=2./(R1*R1), SSOLAR=0.98*SOLC + SSOLAR=H196/(R1*R1) +!********************************************************* +! Special note: The solar constant is reduced extra 3 percent to account +! for the lack of aerosols in the shortwave radiation +! parameterization. Q. Zhao 96-7-23 +! ### May also be due not accounting for reduction in solar constant due to +! absorption by ozone above the top of the model domain (Ferrier, Apr-2005) +!********************************************************* + SSOLAR=SSOLAR*0.97 +! + DO 40 I=MYIS,MYIE + IR = I + IBEG - 1 + TH2=HP2*XLAT(IR) + JJROW(I)=Q19001-TH2 + TTHAN(I)=(19-JJROW(I))-TH2 +!..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN +! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS + SFCALB(I) = ALBEDO(IR) +!..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK... +!***ZHAO +! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA +! THE UNIT FOR PRESS IS MICRO BAR +! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL +!***ZHAO + PRESS(I,LP1)=QS(IR)*10.0 + TEMP(I,LP1)=ABS(TSFC(IR)) + COSZEN(I) = COSZRO(IR) + TAUDA(I) = TAUDAR(IR) + 40 CONTINUE +!***ZHAO +!..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC +! ETA MODEL HAS THE SAME STRUCTURE +!***ZHAO + DO 50 K=1,L + DO 50 I=MYIS,MYIE + IR = I + IBEG - 1 +!..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK.......... + TEMP(I,K) = TT(IR,K) + PRESS(I,K) = 10.0 * PP(IR,K) +!.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK + RH2O(I,K)=QQH2O(IR,K) + IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6 + 50 CONTINUE +!... ************************* + IF (KO3.EQ.0) GO TO 65 +!... ************************* + DO 60 K=1,L + DO 60 I=MYIS,MYIE + QO3(I,K) = O3QO3(I+IBEG-1,K) + 60 CONTINUE + 65 CONTINUE +!... ************************************ + IF (KALB.GT.0) GO TO 110 +!... ************************************ +!..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF +! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0 + IQ=INT(TWENTY*HP537+ONE) + DO 105 I=MYIS,MYIE + IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN + ZEN=DEGRAD*ACOS(MAX(COSZEN(I),0.0)) + IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE) + IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) & + JX=INT(QUARTR*(H74E1-ZEN)+HNINE) + IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1) + DZEN=-(ZEN-ZA(JX))/DZA(JX) + ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX)) + ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX)) + SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ)) + ENDIF + 105 CONTINUE + 110 CONTINUE +! ********************************** + IF (KO3.GT.0) GO TO 135 +! ********************************** +!.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE, +!.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. + DO 125 I=MYIS,MYIE + + PHALF(1)=0. + PHALF(LP1)=PPI(I,kme) + DO K=1,LM1 + PHALF(K+1)=PP(I,K) ! AETA(K)*PDIF+PT ! BSF index was erroneously L + ENDDO + + CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + DO 130 K=1,L + DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) & + +RCOS1*DDO3N3(JJROW(I),K) & + +RCOS2*DDO3N4(JJROW(I),K) + DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) & + +RCOS1*DDO3N3(JJROW(I)+1,K) & + +RCOS2*DDO3N4(JJROW(I)+1,K) +!... NOW LATITUDINAL INTERPOLATION, AND +! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4) + QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K))) + 130 CONTINUE + 125 CONTINUE + 135 CONTINUE +!............. + DO 195 I=MYIS,MYIE +!..... VISIBLE AND NEAR IR DIFFUSE ALBEDO + ALVD(I) = SFCALB(I) + ALND(I) = SFCALB(I) +!..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO + ALVB(I) = SFCALB(I) + ALNB(I) = SFCALB(I) +! +!--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05) +!--- Turn back on to mimic NAM 8/17/05 +! +!..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW +! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE.. + IF (SLMSK(I+IBEG-1).LT.0.5) THEN + IF (SFCALB(I).LE.0.5) THEN + ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI) + ALBD0 = EXP (ALBD0) + ALVD1 = (ALVD(I) - 0.054313) / 0.945687 + ALND1 = (ALND(I) - 0.054313) / 0.945687 + ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0 + ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0 + !-- Put in an upper limit on beam albedos + ALVB(I) = MIN(0.5,ALVB(I)) + ALNB(I) = MIN(0.5,ALNB(I)) + END IF + END IF + 195 CONTINUE +!.....SURFACE VALUES OF RRCL AND TTCL + DO 200 N=1,2 + DO 200 I=MYIS,MYIE + RRCL(I,N,1)=ALVD(I) + TTCL(I,N,1)=ZERO + 200 CONTINUE + DO 220 N=3,NB + DO 220 I=MYIS,MYIE + RRCL(I,N,1)=ALND(I) + TTCL(I,N,1)=ZERO + 220 CONTINUE +!... ************************** +!... * END OF CLOUD SECTION * +!... ************************** +!... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2 +! INTO RRCO2,THE MASS MIXING RATIO. + RRVCO2=RCO2 + RRCO2=RRVCO2*RATCO2MW + 250 IF(ITIMLW .EQ. 0) GO TO 300 +! +! *********************** +!====> * LONG WAVE RADIATION * +! *********************** +! +!.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS + DO 240 K=1,LP1 + DO 240 I=MYIS,MYIE + EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K) + 240 CONTINUE +!.... GET CLD FACTOR FOR LW CALCULATIONS +!.... + +! shuhua + + CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! shuhua +!===> LONG WAVE RADIATION +! CALL LWR88(HEATRA,GRNFLX,TOPFLX, & +! PRESS,TEMP,RH2O,QO3,CLDFAC, & +! EQCMT,NCLDS,KTOP,KBTM, & +! +!! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & +! BO3RND,AO3RND, & +! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & +! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & +! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & +! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & +! TEN,HP1,FOUR,HM1EZ,SKO3R, & +! AB15WD,SKC1R,RADCON,QUARTR,TWO, & +! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & +! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + + CALL LWR88(HEATRA,GRNFLX,TOPFLX, & + PRESS,TEMP,RH2O,QO3,CLDFAC, & + EQCMT,NCLDS,KTOP,KBTM, & +! +! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & + BO3RND,AO3RND, & + APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & + ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & + GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & + P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & + TEN,HP1,FOUR,HM1EZ, & + RADCON,QUARTR,TWO, & + HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & + RADCON1,H16E1, H28E1,H44194M2,H1P41819, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!.... +!================================================================================ +!--- IMPORTANT!! Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use +! the following algorithm, because the GFDL code calculates NET longwave flux +! (GRNFLX, Up - Down) as its fundamental quantity. +! +! 1. Calculate upward LW at surface (FLWUPS) +! 2. Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX +! +!--- Note: The following fluxes must be multipled by .001 to convert to mks +! => GRNFLX, or GRound Net FLuX +! => TOPFLX, or top of the atmosphere fluxes (FLWUP) +! +!--- IMPORTANT!! If the surface emissivity (SFCEMS) differs from 1.0, then +! uncomment the line below starting with "!BSF" +!================================================================================ + DO 280 I=MYIS,MYIE + IR = I + IBEG - 1 + FLWUP(IR) = .001*TOPFLX(I) +! TDUM=TEMP(I,LP1) +!--- Use an average of the skin & lowest model level temperature + TDUM=.5*(TEMP(I,LP1)+TEMP(I,L)) + FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM +!BSF FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM + FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I) + 280 CONTINUE +!.... Average LW heating/cooling rates over the lowest 2 atmospheric layers, +! which may be necessary for when dealing with thin layers near the surface + DO I=MYIS,MYIE + TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1)) + HEATRA(I,L)=TDUM + HEATRA(I,LM1)=TDUM + ENDDO +!.... CONVERT HEATING RATES TO DEG/SEC + DO 290 K=1,L + DO 290 I=MYIS,MYIE + HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC + 290 CONTINUE + 300 CONTINUE + IF(ITIMSW .EQ. 0) GO TO 350 +!SW + CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, & + PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, & + NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, & + ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, & +! +! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, & + ABCFF,PWTS, & + H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, & + HP816,RRAYAV,GINV,CFCO2,CFO3, & + TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, & + H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, & + H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!SW +! +!..... GET SW FLUXES IN WATTS/M**2 + DO 320 I=MYIS,MYIE + IR = I + IBEG - 1 + FSWUP(IR) = UF(I,1) * 1.E-3 + FSWDN(IR) = DF(I,1) * 1.E-3 + FSWUPS(IR) = UF(I,LP1) * 1.E-3 +!-- FSWDNS is more accurate using array DF than summing the GDFxx arrays +!C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3 +!! FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3 + FSWDNS(IR) = DF(I,LP1) * 1.E-3 + FSWDNSC(IR) = DFL(I,LP1) * 1.E-3 +!... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION +!..... VISIBLE AND NEAR IR DIFFUSE + GDFVDR(IR) = GDFVD(I) * 1.E-3 + GDFNDR(IR) = GDFND(I) * 1.E-3 +!..... VISIBLE AND NEAR IR DIRECT BEAM + GDFVBR(IR) = GDFVB(I) * 1.E-3 + GDFNBR(IR) = GDFNB(I) * 1.E-3 + 320 CONTINUE +!.... CONVERT HEATING RATES TO DEG/SEC + DO 330 K=1,L + DO 330 I=MYIS,MYIE + SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC + 330 CONTINUE + 350 CONTINUE +! begin debugging radiation + +! if (Jndx .eq. jmd) then +! FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001 +! write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,' & +! ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' & +! ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' & +! ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1 & +! ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd) +! FSWrat=0. +! if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd) +! FSWrat1=0. +! if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1 +! write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' & +! ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' & +! ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd) & +! ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1 +! endif +! end debugging radiation + RETURN + 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', & + 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2) + + END SUBROUTINE RADFS + +!----------------------------------------------------------------------- + SUBROUTINE O3CLIM +! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- +! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & +! ims,ime, jms,jme, kms,kme , & +! its,ite, jts,jte, kts,kte + +! ****************************************************************** +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION +! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-?? +! +! ABSTRACT: +! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING +! 81-LAYER DATA FROM GFDL. +! +! PROGRAM HISTORY LOG: +! ??-??-?? GFDL/KC - ORIGINATOR +! 96-07-26 BLACK - MODIFIED FOR ETA MODEL +! +! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN +! INPUT ARGUMENT LIST: +! NONE +! +! OUTPUT ARGUMENT LIST: +! NONE +! +! OUTPUT FILES: +! NONE +! +! SUBPROGRAMS CALLED: +! +! UNIQUE: +! NONE +! +! LIBRARY: +! NONE +! +! COMMON BLOCKS: SEASO3 +! O3DATA +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +!$$$ +!---------------------------------------------------------------------- +! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP + INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1 +!---------------------------------------------------------------------- +! INCLUDE "SEASO3.comm" +!--------------------------------------------------------------------- +! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 +! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL + +! COMMON /SEASO3/ +! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... +! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL) +! +! &,PRGFDL(NL) +!--------------------------------------------------------------------- + REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) & + ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16) +!---------------------------------------------------------------------- + REAL :: AVG,A1,B1,B2 + INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex +!---------------------------------------------------------------------- + REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) & + ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) & + ,DDUO3N(19,NL),DUO3N(19,41) & + ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) & + ,O3HI(10,25) & + ,RSTD(81),RBAR(NL),RDATA(81) & + ,PHALF(NL),P(81),PH(82) + REAL :: PXX(81),PYY(82) ! fix for nesting +!---------------------------------------------------------------------- +!nesting EQUIVALENCE & +!nesting (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) & +!nesting ,(PH1(1),PH(1)),(PH2(1),PH(46)) & +!nesting ,(P1(1),P(1)),(P2(1),P(49)) + EQUIVALENCE & + (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) & + ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting + ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting +!---------------------------------------------------------------------- +! EQUIVALENCE & +! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) & +! ,(XRAD2(1),XDO3N2(1,1)) & +! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),) + EQUIVALENCE & + (XRAD1(1),O3O3(1,1,1)) & + ,(XRAD2(1),O3O3(1,1,2)) & + ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4)) +!---------------------------------------------------------------------- +!--------------------------------------------------------------------- + DATA PH1/ 0., & + 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, & + 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, & + 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, & + 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, & + 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, & + 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, & + 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, & + 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, & + 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, & + 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, & + 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ + DATA PH2/ & + 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, & + 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, & + 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, & + 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, & + 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, & + 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, & + 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, & + 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, & + 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, & + 0.1000000E+01/ + DATA P1/ & + 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, & + 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, & + 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, & + 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, & + 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, & + 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, & + 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, & + 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, & + 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, & + 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, & + 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, & + 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ + DATA P2/ & + 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, & + 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, & + 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, & + 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, & + 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, & + 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, & + 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, & + 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, & + 0.1000000E+01/ + DATA O3HI1/ & + .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, & + .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, & + .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, & + .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, & + .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, & + .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, & + .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, & + .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, & + 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, & + 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, & + 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, & + 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, & + 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, & + 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, & + 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, & + 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ + DATA O3HI2/ & + 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, & + 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, & + 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, & + 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, & + 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, & + 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, & + 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, & + 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, & + 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ + DATA O3LO1/ & + 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, & + 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, & + 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, & + 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, & + 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, & + 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, & + 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, & + .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, & + .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, & + .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, & + .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, & + .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, & + .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, & + .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, & + .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, & + .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ + DATA O3LO2/ & + 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, & + 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, & + 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, & + 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, & + 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, & + 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, & + .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, & + .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, & + .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, & + .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, & + .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, & + .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, & + .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, & + .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, & + .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, & + .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ + DATA O3LO3/ & + 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, & + 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, & + 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, & + 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, & + 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, & + 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, & + .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, & + .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, & + .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, & + .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, & + .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, & + .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, & + .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, & + .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, & + .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, & + .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ + DATA O3LO4/ & + 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, & + 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, & + 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, & + 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, & + 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, & + 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, & + 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, & + .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, & + .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, & + .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, & + .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, & + .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, & + .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, & + .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, & + .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, & + .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ +!---------------------------------------------------------------------- +!*** +!*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES +!*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3 +!*** AND PSFC=1013.25 MB ......K.A.C. DEC94 +!*** + DO K=1,NK +! PH(K)=PH(K)*1013250. +! P(K)=P(K)*1013250. + PH(K)=PYY(K)*1013250. ! fix for nesting + P(K)=PXX(K)*1013250. ! fix for nesting + ENDDO +! +! PH(NKP)=PH(NKP)*1013250. + PH(NKP)=PYY(NKP)*1013250. ! fix for nesting +! + DO K=1,NL + PSTD(K)=P(K) + ENDDO +! + DO K=1,25 + DO N=1,10 + RO31(N,K)=O3HI(N,K) + RO32(N,K)=O3HI(N,K) + ENDDO + ENDDO +!---------------------------------------------------------------------- + DO 100 NCASE=1,4 +! +!*** NCASE=1: SPRING (IN N.H.) +!*** NCASE=2: FALL (IN N.H.) +!*** NCASE=3: WINTER (IN N.H.) +!*** NCASE=4: SUMMER (IN N.H.) +! + IPLACE=2 + IF(NCASE.EQ.2)IPLACE=4 + IF(NCASE.EQ.3)IPLACE=1 + IF(NCASE.EQ.4)IPLACE=3 +! + IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN + DO K=26,41 + DO N=1,10 + RO31(N,K)=O3LO1(N,K-25) + RO32(N,K)=O3LO2(N,K-25) + ENDDO + ENDDO + ENDIF +! + IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN + DO K=26,41 + DO N=1,10 + RO31(N,K)=O3LO3(N,K-25) + RO32(N,K)=O3LO4(N,K-25) + ENDDO + ENDDO + ENDIF +! + DO 25 KK=1,NKK + DO N=1,10 + DUO3N(N,KK)=RO31(11-N,KK) + DUO3N(N+9,KK)=RO32(N,KK) + ENDDO + DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK)) + 25 CONTINUE +! +!***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON +! + IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN + DO 50 KK=1,NKK + DO N=1,19 + TEMPN(N)=DUO3N(20-N,KK) + ENDDO + DO N=1,19 + DUO3N(N,KK)=TEMPN(N) + ENDDO + 50 CONTINUE + ENDIF +! +!*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE +!*** LEVELS +! +!*** BEGIN LATITUDE (10 DEG) LOOP +! + DO 75 N=1,19 +! + DO KK=1,NKK + RSTD(KK)=DUO3N(N,KK) + ENDDO +! + NKM=NK-1 + NKMM=NK-3 +!*** +!*** BESSELS HALF-POINT INTERPOLATION FORMULA +!*** + DO K=4,NKMM,2 + KI=K/2 + RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) & + -RSTD(KI)+RSTD(KI-1))/16. + ENDDO +! + RDATA(2)=0.5*(RSTD(2)+RSTD(1)) + RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1)) +! +!*** PUT UNCHANGED DATA INTO NEW ARRAY +! + DO K=1,NK,2 + KQ=(K+1)/2 + RDATA(K)=RSTD(KQ) + ENDDO +! + DO KK=1,NL + DDUO3N(N,KK)=RDATA(KK)*.01 + ENDDO +! + 75 CONTINUE +! +!*** END OF LATITUDE LOOP +! +!---------------------------------------------------------------------- +!*** +!*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF +!*** 10 DEG VALUES +!*** + DO 90 KK=1,NL +! + DO N=1,19 + O35DEG(2*N-1,KK)=DDUO3N(N,KK) + ENDDO +! + DO N=1,18 + O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK)) + ENDDO +! + 90 CONTINUE +! + DO JJ=1,37 + DO KEN=1,NL + O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN) + ENDDO + ENDDO +! + 100 CONTINUE +!---------------------------------------------------------------------- +!*** END OF LOOP OVER CASES +!---------------------------------------------------------------------- +!*** +!*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT +!*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D) +!*** + DO I=1,NLGTH + AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I)) + A1=0.5*(XRAD2(I)-XRAD4(I)) + B1=0.5*(XRAD1(I)-XRAD3(I)) + B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I))) + +! XRAD1(I)=AVG +! XRAD2(I)=A1 +! XRAD3(I)=B1 +! XRAD4(I)=B2 + + iindex = 1+mod((I-1),37) + jindex = 1+(I-1)/37 + XDUO3N(iindex,jindex)=AVG + XDO3N2(iindex,jindex)=A1 + XDO3N3(iindex,jindex)=B1 + XDO3N4(iindex,jindex)=B2 + ENDDO +!*** +!*** CONVERT GFDL PRESSURE (MICROBARS) TO PA +!*** + DO N=1,NL + PRGFDL(N)=PSTD(N)*1.E-1 + ENDDO +! + END SUBROUTINE O3CLIM + +!--------------------------------------------------------------------- + SUBROUTINE TABLE +! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, & +! SOURCE,DSRCE ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + +!INTEGER, PARAMETER :: NBLY=15 + INTEGER, PARAMETER :: NB=12 + INTEGER, PARAMETER :: NBLX=47 + INTEGER , PARAMETER:: NBLW = 163 + + REAL,PARAMETER :: AMOLWT=28.9644 + REAL,PARAMETER :: CSUBP=1.00484E7 + REAL,PARAMETER :: DIFFCTR=1.66 + REAL,PARAMETER :: G=980.665 + REAL,PARAMETER :: GINV=1./G + REAL,PARAMETER :: GRAVDR=980.0 + REAL,PARAMETER :: O3DIFCTR=1.90 + REAL,PARAMETER :: P0=1013250. + REAL,PARAMETER :: P0INV=1./P0 + REAL,PARAMETER :: GP0INV=GINV*P0INV + REAL,PARAMETER :: P0XZP2=202649.902 + REAL,PARAMETER :: P0XZP8=810600.098 + REAL,PARAMETER :: P0X2=2.*1013250. + REAL,PARAMETER :: RADCON=8.427 + REAL,PARAMETER :: RADCON1=1./8.427 + REAL,PARAMETER :: RATCO2MW=1.519449738 + REAL,PARAMETER :: RATH2OMW=.622 + REAL,PARAMETER :: RGAS=8.3142E7 + REAL,PARAMETER :: RGASSP=8.31432E7 + REAL,PARAMETER :: SECPDA=8.64E4 +! +!******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* +! ARRANGED IN DECREASING ORDER + REAL,PARAMETER :: HUNDRED=100. + REAL,PARAMETER :: HNINETY=90. + REAL,PARAMETER :: HNINE=9.0 + REAL,PARAMETER :: SIXTY=60. + REAL,PARAMETER :: FIFTY=50. + REAL,PARAMETER :: TEN=10. + REAL,PARAMETER :: EIGHT=8. + REAL,PARAMETER :: FIVE=5. + REAL,PARAMETER :: FOUR=4. + REAL,PARAMETER :: THREE=3. + REAL,PARAMETER :: TWO=2. + REAL,PARAMETER :: ONE=1. + REAL,PARAMETER :: HAF=0.5 + REAL,PARAMETER :: QUARTR=0.25 + REAL,PARAMETER :: ZERO=0. +! +!******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) +! ARRANGED IN DECREASING ORDER + REAL,PARAMETER :: H83E26=8.3E26 + REAL,PARAMETER :: H71E26=7.1E26 + REAL,PARAMETER :: H1E15=1.E15 + REAL,PARAMETER :: H1E13=1.E13 + REAL,PARAMETER :: H1E11=1.E11 + REAL,PARAMETER :: H1E8=1.E8 + REAL,PARAMETER :: H2E6=2.0E6 + REAL,PARAMETER :: H1E6=1.0E6 + REAL,PARAMETER :: H69766E5=6.97667E5 + REAL,PARAMETER :: H4E5=4.E5 + REAL,PARAMETER :: H165E5=1.65E5 + REAL,PARAMETER :: H5725E4=57250. + REAL,PARAMETER :: H488E4=48800. + REAL,PARAMETER :: H1E4=1.E4 + REAL,PARAMETER :: H24E3=2400. + REAL,PARAMETER :: H20788E3=2078.8 + REAL,PARAMETER :: H2075E3=2075. + REAL,PARAMETER :: H18E3=1800. + REAL,PARAMETER :: H1224E3=1224. + REAL,PARAMETER :: H67390E2=673.9057 + REAL,PARAMETER :: H5E2=500. + REAL,PARAMETER :: H3082E2=308.2 + REAL,PARAMETER :: H3E2=300. + REAL,PARAMETER :: H2945E2=294.5 + REAL,PARAMETER :: H29316E2=293.16 + REAL,PARAMETER :: H26E2=260.0 + REAL,PARAMETER :: H25E2=250. + REAL,PARAMETER :: H23E2=230. + REAL,PARAMETER :: H2E2=200.0 + REAL,PARAMETER :: H15E2=150. + REAL,PARAMETER :: H1386E2=138.6 + REAL,PARAMETER :: H1036E2=103.6 + REAL,PARAMETER :: H8121E1=81.21 + REAL,PARAMETER :: H35E1=35. + REAL,PARAMETER :: H3116E1=31.16 + REAL,PARAMETER :: H28E1=28. + REAL,PARAMETER :: H181E1=18.1 + REAL,PARAMETER :: H18E1=18. + REAL,PARAMETER :: H161E1=16.1 + REAL,PARAMETER :: H16E1=16. + REAL,PARAMETER :: H1226E1=12.26 + REAL,PARAMETER :: H9P94=9.94 + REAL,PARAMETER :: H6P08108=6.081081081 + REAL,PARAMETER :: H3P6=3.6 + REAL,PARAMETER :: H3P5=3.5 + REAL,PARAMETER :: H2P9=2.9 + REAL,PARAMETER :: H2P8=2.8 + REAL,PARAMETER :: H2P5=2.5 + REAL,PARAMETER :: H1P8=1.8 + REAL,PARAMETER :: H1P4387=1.4387 + REAL,PARAMETER :: H1P41819=1.418191 + REAL,PARAMETER :: H1P4=1.4 + REAL,PARAMETER :: H1P25892=1.258925411 + REAL,PARAMETER :: H1P082=1.082 + REAL,PARAMETER :: HP816=0.816 + REAL,PARAMETER :: HP805=0.805 + REAL,PARAMETER :: HP8=0.8 + REAL,PARAMETER :: HP60241=0.60241 + REAL,PARAMETER :: HP602409=0.60240964 + REAL,PARAMETER :: HP6=0.6 + REAL,PARAMETER :: HP526315=0.52631579 + REAL,PARAMETER :: HP518=0.518 + REAL,PARAMETER :: HP5048=0.5048 + REAL,PARAMETER :: HP3795=0.3795 + REAL,PARAMETER :: HP369=0.369 + REAL,PARAMETER :: HP26=0.26 + REAL,PARAMETER :: HP228=0.228 + REAL,PARAMETER :: HP219=0.219 + REAL,PARAMETER :: HP166666=.166666 + REAL,PARAMETER :: HP144=0.144 + REAL,PARAMETER :: HP118666=0.118666192 + REAL,PARAMETER :: HP1=0.1 +! (NEGATIVE EXPONENTIALS BEGIN HERE) + REAL,PARAMETER :: H658M2=0.0658 + REAL,PARAMETER :: H625M2=0.0625 + REAL,PARAMETER :: H44871M2=4.4871E-2 + REAL,PARAMETER :: H44194M2=.044194 + REAL,PARAMETER :: H42M2=0.042 + REAL,PARAMETER :: H41666M2=0.0416666 + REAL,PARAMETER :: H28571M2=.02857142857 + REAL,PARAMETER :: H2118M2=0.02118 + REAL,PARAMETER :: H129M2=0.0129 + REAL,PARAMETER :: H1M2=.01 + REAL,PARAMETER :: H559M3=5.59E-3 + REAL,PARAMETER :: H3M3=0.003 + REAL,PARAMETER :: H235M3=2.35E-3 + REAL,PARAMETER :: H1M3=1.0E-3 + REAL,PARAMETER :: H987M4=9.87E-4 + REAL,PARAMETER :: H323M4=0.000323 + REAL,PARAMETER :: H3M4=0.0003 + REAL,PARAMETER :: H285M4=2.85E-4 + REAL,PARAMETER :: H1M4=0.0001 + REAL,PARAMETER :: H75826M4=7.58265E-4 + REAL,PARAMETER :: H6938M5=6.938E-5 + REAL,PARAMETER :: H394M5=3.94E-5 + REAL,PARAMETER :: H37412M5=3.7412E-5 + REAL,PARAMETER :: H15M5=1.5E-5 + REAL,PARAMETER :: H1439M5=1.439E-5 + REAL,PARAMETER :: H128M5=1.28E-5 + REAL,PARAMETER :: H102M5=1.02E-5 + REAL,PARAMETER :: H1M5=1.0E-5 + REAL,PARAMETER :: H7M6=7.E-6 + REAL,PARAMETER :: H4999M6=4.999E-6 + REAL,PARAMETER :: H451M6=4.51E-6 + REAL,PARAMETER :: H25452M6=2.5452E-6 + REAL,PARAMETER :: H1M6=1.E-6 + REAL,PARAMETER :: H391M7=3.91E-7 + REAL,PARAMETER :: H1174M7=1.174E-7 + REAL,PARAMETER :: H8725M8=8.725E-8 + REAL,PARAMETER :: H327M8=3.27E-8 + REAL,PARAMETER :: H257M8=2.57E-8 + REAL,PARAMETER :: H1M8=1.0E-8 + REAL,PARAMETER :: H23M10=2.3E-10 + REAL,PARAMETER :: H14M10=1.4E-10 + REAL,PARAMETER :: H11M10=1.1E-10 + REAL,PARAMETER :: H1M10=1.E-10 + REAL,PARAMETER :: H83M11=8.3E-11 + REAL,PARAMETER :: H82M11=8.2E-11 + REAL,PARAMETER :: H8M11=8.E-11 + REAL,PARAMETER :: H77M11=7.7E-11 + REAL,PARAMETER :: H72M11=7.2E-11 + REAL,PARAMETER :: H53M11=5.3E-11 + REAL,PARAMETER :: H48M11=4.8E-11 + REAL,PARAMETER :: H44M11=4.4E-11 + REAL,PARAMETER :: H42M11=4.2E-11 + REAL,PARAMETER :: H37M11=3.7E-11 + REAL,PARAMETER :: H35M11=3.5E-11 + REAL,PARAMETER :: H32M11=3.2E-11 + REAL,PARAMETER :: H3M11=3.0E-11 + REAL,PARAMETER :: H28M11=2.8E-11 + REAL,PARAMETER :: H24M11=2.4E-11 + REAL,PARAMETER :: H23M11=2.3E-11 + REAL,PARAMETER :: H2M11=2.E-11 + REAL,PARAMETER :: H18M11=1.8E-11 + REAL,PARAMETER :: H15M11=1.5E-11 + REAL,PARAMETER :: H14M11=1.4E-11 + REAL,PARAMETER :: H114M11=1.14E-11 + REAL,PARAMETER :: H11M11=1.1E-11 + REAL,PARAMETER :: H1M11=1.E-11 + REAL,PARAMETER :: H96M12=9.6E-12 + REAL,PARAMETER :: H93M12=9.3E-12 + REAL,PARAMETER :: H77M12=7.7E-12 + REAL,PARAMETER :: H74M12=7.4E-12 + REAL,PARAMETER :: H65M12=6.5E-12 + REAL,PARAMETER :: H62M12=6.2E-12 + REAL,PARAMETER :: H6M12=6.E-12 + REAL,PARAMETER :: H45M12=4.5E-12 + REAL,PARAMETER :: H44M12=4.4E-12 + REAL,PARAMETER :: H4M12=4.E-12 + REAL,PARAMETER :: H38M12=3.8E-12 + REAL,PARAMETER :: H37M12=3.7E-12 + REAL,PARAMETER :: H3M12=3.E-12 + REAL,PARAMETER :: H29M12=2.9E-12 + REAL,PARAMETER :: H28M12=2.8E-12 + REAL,PARAMETER :: H24M12=2.4E-12 + REAL,PARAMETER :: H21M12=2.1E-12 + REAL,PARAMETER :: H16M12=1.6E-12 + REAL,PARAMETER :: H14M12=1.4E-12 + REAL,PARAMETER :: H12M12=1.2E-12 + REAL,PARAMETER :: H8M13=8.E-13 + REAL,PARAMETER :: H46M13=4.6E-13 + REAL,PARAMETER :: H36M13=3.6E-13 + REAL,PARAMETER :: H135M13=1.35E-13 + REAL,PARAMETER :: H12M13=1.2E-13 + REAL,PARAMETER :: H1M13=1.E-13 + REAL,PARAMETER :: H3M14=3.E-14 + REAL,PARAMETER :: H15M14=1.5E-14 + REAL,PARAMETER :: H14M14=1.4E-14 +! +!******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) +! ARRANGED IN DESCENDING ORDER + REAL,PARAMETER :: HM2M2=-.02 + REAL,PARAMETER :: HM6666M2=-.066667 + REAL,PARAMETER :: HMP5=-0.5 + REAL,PARAMETER :: HMP575=-0.575 + REAL,PARAMETER :: HMP66667=-.66667 + REAL,PARAMETER :: HMP805=-0.805 + REAL,PARAMETER :: HM1EZ=-1. + REAL,PARAMETER :: HM13EZ=-1.3 + REAL,PARAMETER :: HM19EZ=-1.9 + REAL,PARAMETER :: HM1E1=-10. + REAL,PARAMETER :: HM1597E1=-15.97469413 + REAL,PARAMETER :: HM161E1=-16.1 + REAL,PARAMETER :: HM1797E1=-17.97469413 + REAL,PARAMETER :: HM181E1=-18.1 + REAL,PARAMETER :: HM8E1=-80. + REAL,PARAMETER :: HM1E2=-100. +! + REAL,PARAMETER :: H1M16=1.0E-16 + REAL,PARAMETER :: H1M20=1.E-20 + REAL,PARAMETER :: HP98=0.98 + REAL,PARAMETER :: Q19001=19.001 + REAL,PARAMETER :: DAYSEC=1.1574E-5 + REAL,PARAMETER :: HSIGMA=5.673E-5 + REAL,PARAMETER :: TWENTY=20.0 + REAL,PARAMETER :: HP537=0.537 + REAL,PARAMETER :: HP2=0.2 + REAL,PARAMETER :: RCO2=3.3E-4 + REAL,PARAMETER :: H3M6=3.0E-6 + REAL,PARAMETER :: PI=3.1415927 + REAL,PARAMETER :: DEGRAD=180.0/PI + REAL,PARAMETER :: H74E1=74.0 + REAL,PARAMETER :: H15E1=15.0 + + REAL, PARAMETER:: B0 = -.51926410E-4 + REAL, PARAMETER:: B1 = -.18113332E-3 + REAL, PARAMETER:: B2 = -.10680132E-5 + REAL, PARAMETER:: B3 = -.67303519E-7 + REAL, PARAMETER:: AWIDE = 0.309801E+01 + REAL, PARAMETER:: BWIDE = 0.495357E-01 + REAL, PARAMETER:: BETAWD = 0.347839E+02 + REAL, PARAMETER:: BETINW = 0.766811E+01 + + +! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), & +! TABLE2(28,180),TABLE3(28,180),EM3(28,180), & +! SOURCE(28,NBLY), DSRCE(28,NBLY) + +! + REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW) + REAL :: BANDLO(NBLW),BANDHI(NBLW) + + INTEGER :: IBAND(40) + + REAL :: BANDL1(64),BANDL2(64),BANDL3(35) + REAL :: BANDH1(64),BANDH2(64),BANDH3(35) +! REAL :: AB15WD,SKO2D,SKC1R,SKO3R + +! REAL :: AWIDE,BWIDE,BETAWD,BETINW + +! DATA AWIDE / 0.309801E+01/ +! DATA BWIDE / 0.495357E-01/ +! DATA BETAWD / 0.347839E+02/ +! DATA BETINW / 0.766811E+01/ + +! +!% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ; +!% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ; + +! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW) + + REAL :: & + SUM(28,180),PERTSM(28,180),SUM3(28,180), & + SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), & + DBDTNB(28,NBLW) + REAL :: & + ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), & + TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), & + SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), & + R1T(28),R2(28),S2(28),T3(28),R1WD(28) + REAL :: EXPO(180),FAC(180) + REAL :: CNUSB(30),DNUSB(30) + REAL :: ALFANB(NBLW),AROTNB(NBLW) + REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), & + BETANB(NBLW) + + REAL :: AB15(2) + + REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35) + REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35) + REAL :: BETAD1(64),BETAD2(64),BETAD3(35) + + EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), & + (ARNDM3(1),ARNDM(129)) + EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), & + (BRNDM3(1),BRNDM(129)) + EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), & + (BETAD3(1),BETAD(129)) + +!--------------------------------------------------------------- + REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp + INTEGER :: N,I,ICNT,I1,I2E,I2 + INTEGER :: J,JP,NSUBDS,NSB,IA + +!--------------------------------------------------------------- + + DATA IBAND / & + 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, & + 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, & + 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, & + 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/ + + DATA BANDL1 / & + 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, & + 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, & + 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, & + 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, & + 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, & + 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, & + 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, & + 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, & + 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, & + 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, & + 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, & + 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, & + 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, & + 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, & + 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, & + 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/ + DATA BANDL2 / & + 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, & + 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, & + 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, & + 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, & + 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, & + 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, & + 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, & + 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, & + 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, & + 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, & + 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, & + 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, & + 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, & + 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, & + 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, & + 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/ + DATA BANDL3 / & + 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, & + 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, & + 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, & + 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, & + 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, & + 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, & + 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, & + 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, & + 0.218000E+04, 0.219000E+04, 0.227000E+04/ + + DATA BANDH1 / & + 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, & + 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, & + 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, & + 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, & + 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, & + 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, & + 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, & + 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, & + 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, & + 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, & + 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, & + 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, & + 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, & + 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, & + 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, & + 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/ + DATA BANDH2 / & + 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, & + 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, & + 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, & + 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, & + 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, & + 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, & + 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, & + 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, & + 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, & + 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, & + 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, & + 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, & + 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, & + 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, & + 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, & + 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/ + DATA BANDH3 / & + 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, & + 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, & + 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, & + 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, & + 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, & + 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, & + 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, & + 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, & + 0.219000E+04, 0.220000E+04, 0.238000E+04/ + +! +!***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING +! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS + DATA ARNDM1 / & + 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, & + 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, & + 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, & + 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, & + 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, & + 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, & + 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, & + 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, & + 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, & + 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, & + 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, & + 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, & + 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, & + 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, & + 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, & + 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/ + DATA ARNDM2 / & + 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, & + 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, & + 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, & + 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, & + 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, & + 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, & + 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, & + 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, & + 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, & + 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, & + 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, & + 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, & + 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, & + 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, & + 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, & + 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/ + DATA ARNDM3 / & + 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, & + 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, & + 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, & + 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, & + 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, & + 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, & + 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, & + 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, & + 0.919409E-01, 0.155521E-01, 0.537083E-02/ + DATA BRNDM1 / & + 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, & + 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, & + 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, & + 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, & + 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, & + 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, & + 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, & + 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, & + 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, & + 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, & + 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, & + 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, & + 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, & + 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, & + 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, & + 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/ + DATA BRNDM2 / & + 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, & + 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, & + 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, & + 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, & + 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, & + 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, & + 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, & + 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, & + 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, & + 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, & + 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, & + 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, & + 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, & + 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, & + 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, & + 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/ + DATA BRNDM3 / & + 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, & + 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, & + 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, & + 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, & + 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, & + 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, & + 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, & + 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, & + 0.227233E+00, 0.190562E+00, 0.214005E+00/ + DATA BETAD1 / & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, & + 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, & + 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, & + 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, & + 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, & + 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/ + DATA BETAD2 / & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/ + DATA BETAD3 / & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & + 0.000000E+00, 0.000000E+00, 0.000000E+00/ +!--------------------------------------------------------------- +! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), & +! (BANDL3(1),BANDLO(129)) + +! L = kme-1 +! LP1 = L+1 +! LP1V = LP1*(1+2*L/2) +! IMAX = ite +! LP2 = L + 2 + + DO I = 1,64 + BANDLO(I)=BANDL1(I) + ENDDO + + DO I = 65,128 + BANDLO(I)=BANDL2(I-64) + ENDDO + + DO I = 129,163 + BANDLO(I)=BANDL3(I-128) + ENDDO + + DO I = 1,64 + BANDHI(I)=BANDH1(I) + ENDDO + + DO I = 65,128 + BANDHI(I)=BANDH2(I-64) + ENDDO + + DO I = 129,163 + BANDHI(I)=BANDH3(I-128) + ENDDO + +!**************************************** +!***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 +!....FOR NARROW-BANDS... + DO 101 N=1,NBLW + ANB(N)=ARNDM(N) + BNB(N)=BRNDM(N) + CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N)) + DELNB(N)=BANDHI(N)-BANDLO(N) + BETANB(N)=BETAD(N) +101 CONTINUE + AB15(1)=ANB(57)*BNB(57) + AB15(2)=ANB(58)*BNB(58) +!....FOR WIDE BANDS... + AB15WD=AWIDE*BWIDE +! +!***COMPUTE INDICES: IND,INDX2,KMAXV +!SH ICNT=0 +!SH DO 113 I1=1,L +!SH I2E=LP1-I1 +!SH DO 115 I2=1,I2E +!SH ICNT=ICNT+1 +!SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1 +!SH115 CONTINUE +!SH113 CONTINUE +!SH KMAXV(1)=1 +!SH DO 117 I=2,L +!SH KMAXV(I)=KMAXV(I-1)+(LP2-I) +117 CONTINUE +!SH KMAXVM=KMAXV(L) +!***COMPUTE RATIOS OF CONT. COEFFS + SKC1R=BETAWD/BETINW + SKO3R=BETAD(61)/BETINW + SKO2D=ONE/BETINW +! +!****BEGIN TABLE COMPUTATIONS HERE*** +!***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES +!---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS +! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM +! 100K TO 370K. +!---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF +! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS +! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. + ZMASS(1)=H1M16 + DO 201 J=1,180 + JP=J+1 + ZROOT(J)=SQRT(ZMASS(J)) + ZMASS(JP)=ZMASS(J)*H1P25892 +201 CONTINUE + DO 203 I=1,28 + XTEMV(I)=HNINETY+TEN*I + TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I) + FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I) +203 CONTINUE +!******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY +! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE +! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD) +! THEN COMBINED (USING IBAND) INTO SOURCE. + DO 205 N=1,NBLY + DO 205 I=1,28 + SOURCE(I,N)=ZERO +205 CONTINUE + DO 207 N=1,NBLX + DO 207 I=1,28 + SRCWD(I,N)=ZERO +207 CONTINUE +!---BEGIN FREQ. LOOP (ON N) + DO 211 N=1,NBLX + IF (N.LE.46) THEN +!***THE 160-1200 BAND CASES + CENT=CENTNB(N+16) + DEL=DELNB(N+16) + BDLO=BANDLO(N+16) + BDHI=BANDHI(N+16) + ENDIF + IF (N.EQ.NBLX) THEN +!***THE 2270-2380 BAND CASE + CENT=CENTNB(NBLW) + DEL=DELNB(NBLW) + BDLO=BANDLO(NBLW) + BDHI=BANDHI(NBLW) + ENDIF +!***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE +! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. + NSUBDS=(DEL-H1M3)/10+1 + DO 213 NSB=1,NSUBDS + IF (NSB.NE.NSUBDS) THEN + CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE + DNUSB(NSB)=TEN + ELSE + CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI) + DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO) + ENDIF + C1=(H37412M5)*CNUSB(NSB)**3 +!---BEGIN TEMP. LOOP (ON I) + DO 215 I=1,28 + X(I)=H1P4387*CNUSB(NSB)/XTEMV(I) + X1(I)=EXP(X(I)) + SRCS(I)=C1/(X1(I)-ONE) + SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB) +215 CONTINUE +213 CONTINUE +211 CONTINUE +!***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE +! AND DSRCE + DO 221 N=1,40 + DO 221 I=1,28 + SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N) +221 CONTINUE + DO 223 N=9,NBLY + DO 223 I=1,28 + SOURCE(I,N)=SRCWD(I,N+32) +223 CONTINUE + DO 225 N=1,NBLY + DO 225 I=1,27 + DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1 +225 CONTINUE + DO 231 N=1,NBLW + ALFANB(N)=BNB(N)*ANB(N) + AROTNB(N)=SQRT(ALFANB(N)) +231 CONTINUE +!***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR +! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE +! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ. +! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. +! + DO 301 N=1,NBLW + CENT=CENTNB(N) + DEL=DELNB(N) +!---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT +! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR +! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY. +#if 0 + DO 303 IA=1,3 +#else +!jm -- getting floating point exceptions for IA=1, since 2 is only +! used anyway, I disabled the looping. + DO 303 IA=2,2 +#endif + ANU=CENT+HAF*(IA-2)*DEL + C1=(H37412M5)*ANU*ANU*ANU+H1M20 +!---TEMPERATURE LOOP--- + DO 305 I=1,28 + X(I)=H1P4387*ANU/XTEMV(I) + X1(I)=EXP(X(I)) +!#$ tmp=max((X1(I)-ONE),H1M20) +!#$ SC(I)=C1/tmp + SC(I)=C1/((X1(I)-ONE)+H1M20) +!#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1) + DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1) +305 CONTINUE + IF (IA.EQ.2) THEN + DO 307 I=1,28 + SRC1NB(I,N)=DEL*SC(I) + DBDTNB(I,N)=DEL*DSC(I) +307 CONTINUE + ENDIF +303 CONTINUE +301 CONTINUE +!***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION +! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A +! DIFFERENT DEPENDENCE ON (ZMASS). +!---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE + DO 311 I=1,28 + SUM4(I)=ZERO + SUM6(I)=ZERO + SUM7(I)=ZERO + SUM8(I)=ZERO + SUM4WD(I)=ZERO +311 CONTINUE + DO 313 N=1,NBLW + CENT=CENTNB(N) +!***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4 +! SUM6,SUM7,SUM8 + IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN + DO 315 I=1,28 + SUM4(I)=SUM4(I)+SRC1NB(I,N) + SUM6(I)=SUM6(I)+DBDTNB(I,N) + SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N) + SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N) +315 CONTINUE + ENDIF +!***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD + IF (CENT.GT.160. .AND. CENT.LT.560.) THEN + DO 316 I=1,28 + SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N) +316 CONTINUE + ENDIF +313 CONTINUE + DO 317 I=1,28 + R1T(I)=SUM4(I)/TFOUR(I) + R2(I)=SUM6(I)/FORTCU(I) + S2(I)=SUM7(I)/FORTCU(I) + T3(I)=SUM8(I)/FORTCU(I) + R1WD(I)=SUM4WD(I)/TFOUR(I) +317 CONTINUE + DO 401 J=1,180 + DO 401 I=1,28 + SUM(I,J)=ZERO + PERTSM(I,J)=ZERO + SUM3(I,J)=ZERO + SUMWDE(I,J)=ZERO +401 CONTINUE +!---FREQUENCY LOOP BEGINS--- + DO 411 N=1,NBLW + CENT=CENTNB(N) +!***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 + IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN + DO 413 J=1,180 + X2(J)=AROTNB(N)*ZROOT(J) + EXPO(J)=EXP(-X2(J)) +413 CONTINUE + DO 415 J=1,180 + IF (X2(J).GE.HUNDRED) THEN + EXPO(J)=ZERO + ENDIF +415 CONTINUE + DO 417 J=121,180 + FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) +417 CONTINUE + DO 419 J=1,180 + DO 419 I=1,28 + SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J) + PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J) +419 CONTINUE + DO 421 J=121,180 + DO 421 I=1,28 + SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J) +421 CONTINUE + ENDIF +!---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) + IF (CENT.GT.160. .AND. CENT.LT.560.) THEN + DO 420 J=1,180 + DO 420 I=1,28 + SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J) +420 CONTINUE + ENDIF +411 CONTINUE + DO 431 J=1,180 + DO 431 I=1,28 + EM1(I,J)=SUM(I,J)/TFOUR(I) + TABLE1(I,J)=PERTSM(I,J)/FORTCU(I) +431 CONTINUE + DO 433 J=121,180 + DO 433 I=1,28 + EM3(I,J)=SUM3(I,J)/FORTCU(I) +433 CONTINUE + DO 441 J=1,179 + DO 441 I=1,28 + TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN +441 CONTINUE + DO 443 J=1,180 + DO 443 I=1,27 + TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1 +443 CONTINUE + DO 445 I=1,28 + TABLE2(I,180)=ZERO +445 CONTINUE + DO 447 J=1,180 + TABLE3(28,J)=ZERO +447 CONTINUE + DO 449 J=1,2 + DO 449 I=1,28 + EM1(I,J)=R1T(I) +449 CONTINUE + DO 451 J=1,120 + DO 451 I=1,28 + EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT +451 CONTINUE + DO 453 J=121,180 + DO 453 I=1,28 + EM3(I,J)=EM3(I,J)/ZMASS(J) +453 CONTINUE +!***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. +! WE USE R1WD AND SUMWDE OBTAINED ABOVE. + DO 501 J=1,180 + DO 501 I=1,28 + EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I) +501 CONTINUE + DO 503 J=1,2 + DO 503 I=1,28 + EM1WDE(I,J)=R1WD(I) +503 CONTINUE + + END SUBROUTINE TABLE + +!--------------------------------------------------------------------- + SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR) +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE +! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23 +! +! ABSTRACT: +! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY +! FOR USE IN SHORT-WAVE RADIATION. +! +! PROGRAM HISTORY LOG: +! 96-07-23 Q.ZHAO - ORIGINATOR +! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO +! CALCULATE JD. +! 04-11-18 Y.-T. HOU - FIXED ERROR IN JULIAN DAY CALCULATION +! +! USAGE: CALL SOLARD FROM SUBROUTINE INIT +! +! INPUT ARGUMENT LIST: +! NONE +! +! OUTPUT ARGUMENT LIST: +! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH +! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER). +! +! INPUT FILES: +! NONE +! +! OUTPUT FILES: +! NONE +! +! SUBPROGRAMS CALLED: +! +! UNIQUE: NONE +! +! LIBRARY: IW3JDN +! +! COMMON BLOCKS: CTLBLK +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +!*********************************************************************** + REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI +!----------------------------------------------------------------------- +! INTEGER, INTENT(IN ) :: IHRST,IDAT(3) + INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR +! REAL , INTENT(OUT) :: R1 +!----------------------------------------------------------------------- + INTEGER :: NDM(12),JYR19,JMN + REAL :: CCR + + DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/ + DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/ + +!.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900 +!.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT +!.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT +! + REAL :: TPP + DATA TPP/1.55/ + + INTEGER :: JDOR2,JDOR1 + DATA JDOR2/2415020/, JDOR1/2415019/ + + REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1 + INTEGER :: JHR,JD,ITER +! +! LIBRARY: IW3JDN +! +! -------------------------------------------------------------------- +! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT +! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100 +! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN +! CALENDAR DURING THIS PERIOD +! -------------------------------------------------------------------- + + JHR=IHRST +! + JD=IDAY-32075 & + +1461*(JULYR+4800+(MONTH-14)/12)/4 & + +367*(MONTH-2-(MONTH-14)/12*12)/12 & + -3*((JULYR+4900+(MONTH-14)/12)/100)/4 + IF(JHR.LT.12)THEN + JD=JD-1 + FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN) + ELSE + 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN) + END IF + DAYINC=JHR/24.0 + FJD1=JD+FJD+DAYINC + JD=FJD1 + FJD=FJD1-JD +!*** +!*** CALCULATE THE SOLAR-EARTH DISTANCE +!*** + DAT=REAL(JD-JDOR2)-TPP+FJD +!*** +! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH +!*** + T=FLOAT(JD-JDOR2)/36525.E0 +!*** +! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS) +!*** + YEAR=.25964134E0+.304E-5*T +!*** +! COMPUTES ORBIT ECCENTRICITY FROM T +!*** + EC=.01675104E0-(.418E-4+.126E-6*T)*T + YEAR=YEAR+365.E0 +!*** +! DATE=DAYS SINCE LAST PERIHELION PASSAGE +!*** + DATE = MOD(DAT,YEAR) +!*** +! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD +!*** + EM=PI2*DATE/YEAR + E=1.E0 + ITER = 0 + 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E)) + CR=ABS(E-EP) + E=EP + ITER = ITER + 1 + IF(ITER.GT.10) GOTO 1031 + IF(CR.GT.CCR) GO TO 31 + 1031 CONTINUE + R1=1.E0-EC*COS(E) +! + WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1 + 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ & + 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' & + , I3,' R1=',F9.4) +!*** +! RETURN TO RADTN +!*** + END SUBROUTINE SOLARD +!--------------------------------------------------------------------- + SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday) +!--------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER, INTENT(IN) :: JULDAY,julyr + INTEGER, INTENT(OUT) :: Jmonth,Jday + LOGICAL :: LEAP,NOT_FIND_DATE + INTEGER :: MONTH (12),itmpday,itmpmon,i +!----------------------------------------------------------------------- + DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/ +!*********************************************************************** + NOT_FIND_DATE = .true. + + itmpday = JULDAY + itmpmon = 1 + LEAP=.FALSE. + IF(MOD(julyr,4).EQ.0)THEN + MONTH(2)=29 + LEAP=.TRUE. + ENDIF + + i = 1 + DO WHILE (NOT_FIND_DATE) + IF(itmpday.GT.MONTH(i))THEN + itmpday=itmpday-MONTH(i) + ELSE + Jday=itmpday + Jmonth=i + NOT_FIND_DATE = .false. + ENDIF + i = i+1 + END DO + + END SUBROUTINE CAL_MON_DAY +!!================================================================================ +! CO2 initialization code + + FUNCTION ANTEMP(L,Z) + REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7) +! ************** TROPICAL SOUNDING ************************** + DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, & + 51.0, 70.0, 100., 200., 300./ + DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, & + 1.0, -2.8, -.27, 0.0, 0.0, 0.0/ + DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0/ +! ************** SUB-TROPICAL SUMMER ************************ + DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, & + 36.0, 48.0, 50.0, 70.0, 100./ + DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, & + 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/ + DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, & + 1.0, 2.5, .5, 1.0, 1.0/ +! ************** SUB-TROPICAL WINTER ************************ + DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, & + 44.5, 50.0, 71.0, 98.0, 200.0/ + DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, & + 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/ + DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0/ +! ************* SUB-ARCTIC SUMMER ************************* + DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, & + 50.2, 69.2, 100.0, 102.0, 103.0/ + DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, & + 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/ + DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, & + 1.0, 1.5, 1.0, 1.0, 1.0/ +! ************ SUB-ARCTIC WINTER ***************************** + DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, & + 30.0, 35.0, 50.0, 70.0, 100.0/ + DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, & + 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/ + DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0/ +! ************ US STANDARD 1976 ****************************** + DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, & + 71.0, 84.8520, 90.0, 91.0, 92.0/ + DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, & + -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/ + DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0/ +! +! ************ ENLARGED US STANDARD 1976 ********************** + DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, & + 71.0, 84.8520, 90.0, 91.0, 92.0/ + DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, & + -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/ + DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 1.0/ +! + DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/ +! + NLAST=10 + TEMP=TSTAR(L)+C(1,L)*Z + DO 20 N=1,NLAST + EXPO=(Z-ZB(N,L))/DELTA(N,L) + EXPP=ZB(N,L)/DELTA(N,L) +!JD single-precision change +! FAC=EXP(EXPP)+EXP(-EXPP) +!mp write(6,*) '.........................................' +!mp what in the hell does the next line do? +!mp +!mp apparently if statement <0 or =0 then 23, else 24 +!mp IF(ABS(EXPO)-100.0) 23,23,24 +! +! changed to a more reasonable value for the workstation +! + IF(ABS(EXPO)-50.0) 23,23,24 + 23 X=EXP(EXPO) + Y=X+1.0/X + ZLOG=ALOG(Y) + GO TO 25 + 24 ZLOG=ABS(EXPO) +!mp 25 IF(EXPP-100.0) 27,27,28 + 25 IF(EXPP-50.0) 27,27,28 +!JD single-precision change + 27 FAC=EXP(EXPP)+EXP(-EXPP) + FACLOG=ALOG(FAC) + GO TO 29 + 28 FACLOG=EXPP +! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* +! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC)) + 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* & + (ZLOG-FACLOG)) +!mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L), +!mp + ZLOG,FACLOG + 20 CONTINUE + ANTEMP=TEMP + + END FUNCTION ANTEMP + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc + + SUBROUTINE COEINT(RAT,IR) +! ********************************************************************** +! +! +! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO +! THE FUNCTIONAL FORM +! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)), +! WHERE +! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/ +! (ETA*(P1+P2+CORE)+(P1-P2)) +! +! +! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER +! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH +! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL +! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER. +! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT +! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU +! ITERATION VALUE OF ETA. +! DEFINE: +! PATHA=PATH(P(I),P(I-2),CORE,ETA) +! PATHB=PATH(P(I),P(I-1),CORE,ETA); +! THEN +! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1))) +! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)), +! SO THAT +! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB). +! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T +! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE +! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I). +! NEWTON S METHOD FOR SOLVING THE EQUATION +! F(X)=0 +! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD). +! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE. +! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS +! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T +! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T +! USED FOR INTERPOLATION. +! THERE ARE SEVERAL POSSIBLE PITFALLS: +! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH +! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP +! AND AN ERROR MESSAGE IS PRINTED OUT. +! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT +! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C +! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF +! A WARNING IS PRINTED OUT. +! +! ********************************************************************* +!.... +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! COMMON/PRESS/PA(109) + REAL RAT,SINV +! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV + REAL PA2 +! COMMON/TRAN/ TRANSA(109,109) +! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP + DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109) + DIMENSION SINV(4) + INTEGER :: IERR + DATA SINV/2.74992,2.12731,4.38111,0.0832926/ +!NOV89 DIMENSION SINV(3) +!NOV89 DATA SINV/2.74992,2.12731,4.38111/ +!O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988 +!O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS + CORE=5.000 + UEXP=0.90 +! P0=0.7 + DO 902 I=1,109 + PA2=PA(I)*PA(I) + SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25) +902 CONTINUE + DO 900 I=1,109 + ETA(I)=3.2E-4*EXP(-PA(I)/500.) + ETAP(I)=ETA(I) +900 CONTINUE + DO 1200 NP=1,10 + DO 1000 I=3,109 + SEXP=SEXPV(I) + R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1)) + REXP=R**(UEXP/SEXP) + arg1=path(pa(i),pa(i-2),core,eta(i)) + arg2=path(pa(i),pa(i-1),core,eta(i)) + PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP + PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP + XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA) + DO 1010 LL=1,20 + F1=DLOG(1.0D0+XX*PATHA) + F2=DLOG(1.0D0+XX*PATHB) + F=F1/F2-REXP + FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ & + (F2*F2) + XX=XX-F/FPRIME + CHECK=1.0D0+XX*PATHA +!!!! IF (CHECK) 1020,1020,1025 + IF(CHECK.LE.0.)THEN + WRITE(errmess,360)I,LL,CHECK + WRITE(errmess,*)' xx=',xx,' patha=',patha + 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10) + CALL wrf_error_fatal ( errmess ) + ENDIF + 1010 CONTINUE + CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ & + (DLOG(1.0D0+XX*PATHA)+1.0D-20) + XA(I)=XX +1000 CONTINUE + XA(2)=XA(3) + XA(1)=XA(3) + CA(2)=CA(3) + CA(1)=CA(3) + DO 1100 I=3,109 + PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP + PATH0(I)=1.0D0+XA(I)*PATH0(I) +!+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I) +1100 CONTINUE + DO 1035 I=1,109 + SEXP=SEXPV(I) + ETAP(I)=ETA(I) + ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* & + (CA(I)*XA(I))**(1./UEXP) +1035 CONTINUE +! +! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985). +! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S) +! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND +! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND +! ALSO,THE DENOMINATOR IS MULTIPLIED BY +! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE. +! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN +! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL +! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS. +! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992. +! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS) +! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731 +! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111 +! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926 +! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2 +! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV, +! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION. +! +! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109) +!366 FORMAT (2I4,4E20.12) +1200 CONTINUE + 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ & + 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6) + RETURN + END SUBROUTINE COEINT + +!-------------- + + +!CCC PROGRAM CO2INS + SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag) +! ********************************************************* +! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ****** +! ..... K.CAMPANA MARCH 1988,OCTOBER 1988... +! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER +! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION +! ********************************************************* + DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6) + DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), & + CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), & + CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1) +!CC ITIN=22 +!CC ITIN1=23 +!O222 LATEST CODE HAD IQ=1 +!CC IQ=4 +1011 FORMAT (4F20.14) +!CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1) + DO 300 J=1,LP1 + DO 300 I=1,LP1 + CO2PO(I,J) = T22(I,J,1) +!NOV89 + IF (IQ.EQ.5) GO TO 300 +!NOV89 + CO2PO1(I,J) = T22(I,J,2) + CO2PO2(I,J) = T22(I,J,3) + 300 CONTINUE + DO 301 J=1,LP1 + DO 301 I=1,LP1 + CO2800(I,J) = T23(I,J,1) +!NOV89 + IF (IQ.EQ.5) GO TO 301 +!NOV89 + CO2801(I,J) = T23(I,J,2) + CO2802(I,J) = T23(I,J,3) + 301 CONTINUE +!***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS +! ARE: +! IQ=1 560-800 (CONSOL.=490-850) +! IQ=2 560-670 (CONSOL.=490-670) +! IQ=3 670-800 (CONSOL.=670-850) +! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850) +!NOV89 +! IQ=5 2270-2380 (CONSOL.=2270-2380) +!NOV89 +! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS +! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT +! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S. +!NOV89 +! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE +! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY +! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES +! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE +! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS +! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP. +! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED. +!NOV89 + IF (IQ.EQ.1) THEN + C1=1.5 + C2x=0.5 + ENDIF + IF (IQ.EQ.2) THEN + C1=18./11. + C2x=7./11. + ENDIF + IF (IQ.EQ.3) THEN + C1=18./13. + C2x=5./13. + ENDIF + IF (IQ.EQ.4) THEN + C1=1.8 + C2x=0.8 + ENDIF +!NOV89 + IF (IQ.EQ.5) THEN + C1=1.0 + C2x=0.0 + ENDIF +!NOV89 + DO 1021 I=1,LP1 + DO 1021 J=1,LP1 + CO2PO(J,I)=C1*CO2PO(J,I)-C2x + CO2800(J,I)=C1*CO2800(J,I)-C2x +!NOV89 + IF (IQ.EQ.5) GO TO 1021 +!NOV89 + CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x + CO2801(J,I)=C1*CO2801(J,I)-C2x + CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x + CO2802(J,I)=C1*CO2802(J,I)-C2x +1021 CONTINUE +!NOV89 + IF (IQ.GE.1.AND.IQ.LE.4) THEN +!NOV89 + DO 1 J=1,LP1 + DO 1 I=1,LP1 + DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100. + DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100. + D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000. + D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000. +1 CONTINUE +!NOV89 + ENDIF +!NOV89 +!O222 ********************************************************* +!CC REWIND 66 +! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE +!CC WRITE (66) DCDT10 +!CC WRITE (66) CO2PO +!CC WRITE (66) D2CT10 +!CC WRITE (66) DCDT8 +!CC WRITE (66) CO2800 +!CC WRITE (66) D2CT8 +!CC REWIND 66 +!NOV89 + IF (IQ.EQ.1.OR.IQ.EQ.4) THEN +!NOV89 + DO 400 J=1,LP1 + DO 400 I=1,LP1 + T66(I,J,1) = DCDT10(I,J) + T66(I,J,2) = CO2PO(I,J) + T66(I,J,3) = D2CT10(I,J) + T66(I,J,4) = DCDT8(I,J) + T66(I,J,5) = CO2800(I,J) + T66(I,J,6) = D2CT8(I,J) + 400 CONTINUE +!NOV89 + ELSE + DO 409 I=1,LP1 + T66(I,1,2) = CO2PO(1,I) + T66(I,1,5) = CO2800(1,I) + IF (IQ.EQ.5) GO TO 409 + T66(I,1,1) = DCDT10(1,I) + T66(I,1,3) = D2CT10(1,I) + T66(I,1,4) = DCDT8(1,I) + T66(I,1,6) = D2CT8(1,I) + 409 CONTINUE + ENDIF +!NOV89 +!O222 ********************************************************* + RETURN + END SUBROUTINE CO2INS +!O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT) +!NOV89 + SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2) +!NOV89 +! ********************************************************* +! CHANGES TO DATA READ AND FORMAT SEE CO222 *** +! ..... K.CAMPANA MARCH 1988,OCTOBER 1988 +! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89 +! ********************************************************* +! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS +! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS +! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE +! USER. +! +! METHOD: +! +! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS- +! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND +! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY +! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE +! THE DIAGRAM AND DISCUSSION BELOW. +! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME. +! +! LET P BE AN ARRAY OF USER-DEFINED PRESSURES +! AND PD BE USER-DEFINED PRESSURE LAYERS. +! +! - - - - - - - - - PD(I-1) --- +! ^ +! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I)) +! ^ +! - - - - - - - - - PD(I) --- +! ^ +! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1)) +! ^ +! - - - - - - - - - PD(I+1)--- +! ... (THE NOTATION USED IS +! ... CONSISTENT WITH THE CODE) +! ... +! - - - - - - - - - PD(J-1) +! +! ----------------- P(J) +! +! - - - - - - - - - PD(J) +! +! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES +! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM. +! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD +! (PD,PLM ARE NOT INPUTTED). +! +! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER- +! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY +! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL +! +! PD(I) +! ---- +! 1 ^ +! ------------- * ^ TAU ( P',PLM(J) ) DP' +! PD(I)-PD(I-1) ^ +! ---- +! PD(I-1) +! +! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER. +! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE +! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)). +! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS +! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN +! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION +! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT +! INPUTTED). +! +! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS +! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC +! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED +! FOR LAYER-MEAN TRANSMISSIVITIES. +! +! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE +! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID +! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED. +! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US +! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE +! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A +! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS) +! BY 25 DEGREES. +! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS +! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS- +! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S. +! A LOGARITHMIC INTERPOLATION SCHEME IS USED. +! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES +! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES +! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID. +! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO- +! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD +! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE +! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES. +! +! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES: +! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD, +! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES +! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE +! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO +! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J) +! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR +! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)). +! NOTE: +! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT +! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING) +! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER +! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J). +! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN +! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG +! PRESSURE OF PLM(2). +! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER +! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE; +! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1. +! +! +! REFERENCE: +! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE +! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL +! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981. +! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS; +! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R. +! IS PLANNED TO DOCUMENT THESE CHANGES. +! +! AUTHOR: M.DANIEL SCHWARZKOPF +! +! DATE: 14 JULY 1983 +! +! ADDRESS: +! +! G.F.D.L. +! P.O.BOX 308 +! PRINCETON,N.J.08540 +! U.S.A. +! TELEPHONE: (609) 452-6521 +! +! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE +! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS- +! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2 +! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND +! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS: +! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN. +! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN. +! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN. +! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN. +! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN. +! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN. +! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING +! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE +! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES +! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED +! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER +! CALCULATIONS. +! +! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER +! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A +! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR +! ADAPTATIONS TO OTHER MACHINES. +! +! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS: +! +! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE +! 5 P (PURPOSE 1) (5E16.9) 201 CARDS +! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS +! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS +! 5 NMETHD (I3) 202 CARDS +! 20 TRANSA (4F20.14) 102 TAPE +!NOV89 +! ITAPE TRANSA (4F20.14) 102 TAPE +!NOV89 +! +! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS: +! +! UNIT NO VARIABLES FORMAT STATEMENT NO. +! 6 TRNFCT (1X,8F15.8) 301 PRINT +! 22 TRNFCT (4F20.14) 102 TAPE +! +! PARAMETER INPUTS: +! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING +! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1 +! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO +! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT +! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2. +! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO +! PRESSURE LAYERS=2,SO NLEVLS=2 +! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD +! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE. +! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1; +! NLP2=NLEVLS+2. +! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER +! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE. +! +! INPUTS: +! +! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS +! TRANSA IS A DOUBLE PRECISION REAL ARRAY. +! +! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3 +! RECORDS,AS FOLLOWS: +! 1) TRANSA, STANDARD TEMPERATURE PROFILE +! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG +! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG +! +! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS +! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR +! PURPOSE 2). +! +! C) P,PD,PLM : +! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE +! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR +! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE +! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE +! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE +! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS. +! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE +! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE +! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS +! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON +! LIMITATIONS. +! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN +! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS +! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON +! LIMITATIONS.PD IS READ IN BEFORE PLM. +! +! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR +! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH. +! +! +! +! +! LIMITATIONS: +! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL +! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO. +! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO +! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS +! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J), +! ONE MUST INCLUDE SUCH A LEVEL. +! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB. +! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE. +! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER, +! SIMPLY DELETE THE LINE. +! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING: +! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT +! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD: +! READ (5,202) NLEVLS +! NLP1=NLEVLS+1 +! NLP2=NLEVLS+2 +! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING +! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT. +! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED +! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA, +! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2) +! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS. +! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER +! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE +! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS +! PARAMETER NLEVLS=40 +! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO +! REQUIREMENTS OF CDC FORTAN. +! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF +! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO +! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT. +! +! OUTPUT: +! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION +! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22. +! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE +! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14). +! +! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN +! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY +! MODIFY OR ELIMINATE THIS AT WILL. +! +! ************ FUNCTION INTERPOLATER ROUTINE ***************** +! +! +! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF ******* +! ****** DATA LEVELS IN THE MODEL ******* +! **************************************************************** +! **************************************************************** + COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N +! COMMON/PRESS/PA(109) +! COMMON/TRAN/ TRANSA(109,109) +! COMMON / OUTPUT / TRNS(NLP1,NLP1) +! COMMON/INPUTP/P(NLP1),PD(NLP2) + DIMENSION TRNS(NLP1,NLP1) + DIMENSION P(NLP1),PD(NLP2) + DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1) + DIMENSION NRTAB(3) + DIMENSION T15A(NLP2,2),T15B(NLP1) + DIMENSION T22(NLP1,NLP1,3) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + DATA NRTAB/1,2,4/ +!*********************************** +! THE FOLLOWING ARE THE INPUT FORMATS +100 FORMAT (4F20.14) +743 FORMAT (F20.14) +201 FORMAT (5E16.9) +202 FORMAT (I3) +!O222 203 FORMAT (F12.6,I2) +203 FORMAT (F12.6) +! THE FOLLOWING ARE THE OUTPUT FORMATS +102 FORMAT (4F20.14) +301 FORMAT (1X,8F15.8) +! +!CC REWIND 15 +!CC REWIND 20 +!NOV89 + REWIND ITAPE +!NOV89 +!CC REWIND 22 +! +! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES +! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^ + PA(1)=0. + FACT15=10.**(1./15.) + FACT30=10.**(1./30.) + PA(2)=1.0E-3 + DO 231 I=2,76 + PA(I+1)=PA(I)*FACT15 +231 CONTINUE + DO 232 I=77,108 + PA(I+1)=PA(I)*FACT30 +232 CONTINUE +! + N=25 + NLV=NLEVLS + NLP1V=NLP1 + NLP2V=NLP2 +! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX +! GIVING THE FREQUENCY RANGE OF THE LBL DATA +!O222 READ (5,203) RATIO,IR +!CC IR = 1 +!CC READ (5,203) RATIO +!O222 *********************************** +!***VALUES FOR IR***** +! IR=1 CONSOL. LBL TRANS. =490-850 +! IR=2 CONSOL. LBL TRANS. =490-670 +! IR=3 CONSOL. LBL TRANS. =670-850 +! IR=4 CONSOL. LBL TRANS. =2270-2380 +!*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK +! ALSO READ IN THE METHOD NO.(1 OR 2) +!CC READ (5,202) NMETHD + IF (RATIO.EQ.1.0) GO TO 621 + CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' ) +!NOV89 621 ITAP1=20 +621 ITAP1=ITAPE +!NOV89 + NTAP=1 + IF (NMETHD.EQ.2) GO TO 502 +! *****CARDS FOR PURPOSE 1(NMETHD=1) +!CC READ (15,201) (P(I),I=1,NLP1) + DO 300 I=1,NLP1 + P(I)=T15B(I) + 300 CONTINUE + DO 801 I=1,NLP1 + PS(I)=P(I) +801 CONTINUE + GO TO 503 +502 CONTINUE +! *****CARDS FOR PURPOSE 2(NMETHD=2) +!CC READ (15,201) (PD(I),I=1,NLP2) +!CC READ (15,201) (PLM(I),I=1,NLP1) + DO 303 I=1,NLP2 + PD(I)=T15A(I,1) + 303 CONTINUE + DO 302 I=1,NLP1 + PLM(I)=T15A(I,2) + 302 CONTINUE + DO 802 I=1,NLP1 + PDS(I)=PD(I+1) + PS(I)=PLM(I) +802 CONTINUE +! +503 CONTINUE +! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES +!NOV89 +!NOV89 DO 400 KKK=1,3 + ICLOOP = 3 + IF (IR.EQ.4) ICLOOP = 1 + DO 400 KKK=1,ICLOOP +!NOV89 +! ********************** + IF (NMETHD.EQ.2) GO TO 505 +! *****CARDS FOR PURPOSE 1(NMETHD=1) + DO 803 I=1,NLP1 + P(I)=PS(I) +803 CONTINUE + GO TO 506 +505 CONTINUE +! *****CARDS FOR PURPOSE 2(NMETHD=2) + DO 804 I=1,NLP1 + PD(I)=PDS(I) + P(I)=PS(I) +804 CONTINUE +! +506 CONTINUE + IA=108 + IAP=IA+1 +!NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109) +!mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109) + IF (NTAP.EQ.1) THEN + IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109) + CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE ) + ENDIF +!mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881 +!mp + do J=109,1,-6 +!mp write(6,697)(TRANSA(I,J),I=5,105,10) + enddo +! 697 format(11(f5.3,1x)) +!mp +!NOV89 + DO 4 I=1,IAP + TRANSA(I,I)=1.0 + 4 CONTINUE + CALL COEINT(RATIO,IR) + DO 805 I=1,NLP1 + DO 805 J=1,NLP1 + TRNS(J,I)=1.00 +805 CONTINUE + DO 10 I=1,NLP1 + DO 20 J=1,I + IF (I.EQ.J) GO TO 20 + P1=P(J) + P2=P(I) + CALL SINTR2 + TRNS(J,I)=TRNSLO +20 CONTINUE +10 CONTINUE + DO 47 I=1,NLP1 + DO 47 J=I,NLP1 + TRNS(J,I)=TRNS(I,J) +47 CONTINUE +! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS + IF (NMETHD.EQ.1) GO TO 2872 +! + DO 51 J=1,NLP1 + DO 52 I=2,NLP1 + IA=I + JA=J + N=25 + IF (I.NE.J) N=3 + CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS) +52 CONTINUE +51 CONTINUE +! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS +2872 CONTINUE +! +!+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1) +!CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1) + DO 304 J=1,NLP1 + DO 304 I=1,NLP1 + T22(I,J,KKK) = TRNS(I,J) + 304 CONTINUE +400 CONTINUE + RETURN + END SUBROUTINE CO2INT +!CCC PROGRAM CO2IN1 + SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1) +! CO2IN1=CO2INS FOR METHOD 1 +! ********************************************************* +! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 *** +! ..... K.CAMPANA MARCH 1988,OCTOBER 1988 +! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER +! ********************************************************* + DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6) + DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), & + CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), & + CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1) + ITIN=20 + ITIN1=21 +!O222 LATEST CODE HAS IQ=1 +!CC IQ=4 +1011 FORMAT (4F20.14) +!CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1) +!CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1) + DO 300 J=1,LP1 + DO 300 I=1,LP1 + CO2PO(I,J) = T20(I,J,1) +!NOV89 + IF (IQ.EQ.5) GO TO 300 +!NOV89 + CO2PO1(I,J) = T20(I,J,2) + CO2PO2(I,J) = T20(I,J,3) + 300 CONTINUE + DO 301 J=1,LP1 + DO 301 I=1,LP1 + CO2800(I,J) = T21(I,J,1) +!NOV89 + IF (IQ.EQ.5) GO TO 301 +!NOV89 + CO2801(I,J) = T21(I,J,2) + CO2802(I,J) = T21(I,J,3) + 301 CONTINUE +!***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS +! ARE: +! IQ=1 560-800 (CONSOL.=490-850) +! IQ=2 560-670 (CONSOL.=490-670) +! IQ=3 670-800 (CONSOL.=670-850) +! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850) +!NOV89 +! IQ=5 2270-2380 (CONSOL.=2270-2380) +!NOV89 +! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS +! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT +! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S. + IF (IQ.EQ.1) THEN + C1=1.5 + C2x=0.5 + ENDIF + IF (IQ.EQ.2) THEN + C1=18./11. + C2x=7./11. + ENDIF + IF (IQ.EQ.3) THEN + C1=18./13. + C2x=5./13. + ENDIF + IF (IQ.EQ.4) THEN + C1=1.8 + C2x=0.8 + ENDIF +!NOV89 + IF (IQ.EQ.5) THEN + C1=1.0 + C2x=0.0 + ENDIF +!NOV89 + DO 1021 I=1,LP1 + DO 1021 J=1,LP1 + CO2PO(J,I)=C1*CO2PO(J,I)-C2x + CO2800(J,I)=C1*CO2800(J,I)-C2x +!NOV89 + IF (IQ.EQ.5) GO TO 1021 +!NOV89 + CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x + CO2801(J,I)=C1*CO2801(J,I)-C2x + CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x + CO2802(J,I)=C1*CO2802(J,I)-C2x +1021 CONTINUE +!NOV89 + IF (IQ.GE.1.AND.IQ.LE.4) THEN +!NOV89 + DO 1 J=1,LP1 + DO 1 I=1,LP1 + DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100. + DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100. + D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000. + D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000. +1 CONTINUE +!NOV89 + ENDIF +!NOV89 +!O222 ********************************************************* +!CC REWIND 66 +! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE +!CC WRITE (66) (DCDT10(I,I+1),I=1,L) +!CC WRITE (66) (CO2PO(I,I+1),I=1,L) +!CC WRITE (66) (D2CT10(I,I+1),I=1,L) +!CC WRITE (66) (DCDT8(I,I+1),I=1,L) +!CC WRITE (66) (CO2800(I,I+1),I=1,L) +!CC WRITE (66) (D2CT8(I,I+1),I=1,L) +!CC REWIND 66 +!O222 ********************************************************* + DO 400 I=1,L + T66(I,2) = CO2PO(I,I+1) + T66(I,5) = CO2800(I,I+1) +!NOV89 + IF (IQ.EQ.5) GO TO 400 +!NOV89 + T66(I,1) = DCDT10(I,I+1) + T66(I,3) = D2CT10(I,I+1) + T66(I,4) = DCDT8(I,I+1) + T66(I,6) = D2CT8(I,I+1) + 400 CONTINUE + RETURN + END SUBROUTINE CO2IN1 +!CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987.... + SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & + SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2) +! +! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS +! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL +! ** FUNCTION WHICH APPROXIMATES +! ** THE US STANDARD (1976). THIS IS +! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE +! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS +! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN. +! ****************************************************************** +! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 ** +! ....K. CAMPANA MARCH 88,OCTOBER 88 + DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), & + T43(NLP2,2),T44(NLP) + DIMENSION SGLVNU(NLP),SIGLNU(NL) + DIMENSION SFULL(NLP),SHALF(NL) +! ****************************************************************** +! +!*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS +! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA- +! TIONAL RADIATION CODES +! + CHARACTER*20 PROFIL + DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP) + DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2) + DIMENSION PD(NLP2),GTEMP(NLP) + DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4) + DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2) +! +! + DATA PROFIL/ & + 'US STANDARD 1976'/ + DATA PSMAX/1013.250/ +! +! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING +! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS +! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0 +! + NTYPE=0 +!O222 READ (*,*) NTYPE + 5 NLEV=NL + DELZAP=0.5 + R=8.31432 + G0=9.80665 + ZMASS=28.9644 + AA=6356.766 + ALT(1)=0.0 + TEMP(1)=ANTEMP(6,0.0) +!*******DETERMINE THE PRESSURES (PRESS) + PSTAR=PSMAX +! +!*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION +! + LTOP(1)=0 + LTOP(2)=0 + LTOP(3)=0 + DO 30 N=1,NL + PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10. + IF(PCLD.GE.642.)LTOP(1)=N + IF(PCLD.GE.350.)LTOP(2)=N + IF(PCLD.GE.150.)LTOP(3)=N +! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP + 30 CONTINUE +! +!O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP) +!O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP) +!O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP) +!CC---- CALL SIGP(PSTAR,PD,GTEMP) + NLM=NL-1 + CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & + SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2) + PD(NLP2)=PSTAR + DO 40 N=1,NLP + PRSINT(N)=PD(NLP2+1-N) + 40 CONTINUE +! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE + DO 504 NQ=1,4 + DO 505 N=2,NLP + 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N)) + PRESS(1)=PRSINT(1) +!********************* + DO 100 N=1,NLEV +! +! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT +! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM. +! + DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1)) + NINT=DLOGP/DELZAP + NINT=NINT+1 + ZNINT=NINT +! G=G0 + DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT) + HT=ALT(N) +! +! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF +! ** RUNGE-KUTTA INTEGRATION. +! + DO 200 M=1,NINT + RK1=ANTEMP(6,HT)*DZ + RK2=ANTEMP(6,HT+0.5*RK1)*DZ + RK3=ANTEMP(6,HT+0.5*RK2)*DZ + RK4=ANTEMP(6,HT+RK3)*DZ +!mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ + HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4) + 200 CONTINUE + ALT(N+1)=HT + TEMP(N+1)=ANTEMP(6,HT) + 100 CONTINUE + DO 506 N=1,NLP + TMPINT(N,NQ)=TEMP(N) + A(N,NQ)=ALT(N) +506 CONTINUE +504 CONTINUE +!O222 ***************************************************** +!***OUTPUT TEMPERATURES +!O222 ***************************************************** + DO 901 N=1,NLP + SGTEMP(N,1) = TMPINT(NLP2-N,1) + 901 CONTINUE +!O222 ***************************************************** +!***OUTPUT GTEMP +!O222 ***************************************************** + DO 902 N=1,NLP + SGTEMP(N,2) = GTEMP(N) + 902 CONTINUE +!O222 ***************************************************** + RETURN + END SUBROUTINE CO2PTZ + FUNCTION PATH(A,B,C,E) +!.... +! DOUBLE PRECISION XA,CA +! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP + PEXP=1./SEXP + PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.)) + RETURN + END FUNCTION PATH +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F) +!.... +! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL + D1=(FP-F0)/(XP-X0) + D2=(FM-F0)/(XM-X0) + B=(D1-D2)/(XP-XM) + A=D1-B*(XP-X0) + DEL=(X-X0) + F=F0+DEL*(A+DEL*B) + RETURN + END SUBROUTINE QINTRP + SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS) + COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N + DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V) + DIMENSION WT(101) + N2=2*N + N2P=2*N+1 +! *****WEIGHTS ARE CALCULATED + WT(1)=1. + DO 21 I=1,N + WT(2*I)=4. + WT(2*I+1)=1. +21 CONTINUE + IF (N.EQ.1) GO TO 25 + DO 22 I=2,N + WT(2*I-1)=2. +22 CONTINUE +25 CONTINUE + TRNSNB=0. + DP=(PD(IA)-PD(IA-1))/N2 + PFIX=P(JA) + DO 1 KK=1,N2P + PVARY=PD(IA-1)+(KK-1)*DP + IF (PVARY.GE.PFIX) P2=PVARY + IF (PVARY.GE.PFIX) P1=PFIX + IF (PVARY.LT.PFIX) P1=PVARY + IF (PVARY.LT.PFIX) P2=PFIX + CALL SINTR2 + TRNSNB=TRNSNB+TRNSLO*WT(KK) +1 CONTINUE + TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1))) + RETURN + END SUBROUTINE QUADSR +!--------------------------------------------------------------------- + SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & + SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2) + DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2) + DIMENSION SIGLY(KD),SIGLV(KP) + DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM) + DIMENSION IDATE(4) + DIMENSION T41(KP2,2),T42(KP), & + T43(KP2,2),T44(KP) +! integer :: retval +! character(50) :: prsmid='prsmid' +!CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL +!CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, & +!CC .594,.688,.777,.856,.920,.960,.981,.995/ +! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1), +! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.) +! +!..... GET NMC SIGMA STRUCTURE +!CC IF (LREAD.GT.0) GO TO 914 +!--- PPTOP IS MODEL TOP PRESSURE IN CB.... +! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A..... +!cccc PPTOP=5.0 +! READ(11,PPTOP,END=12321) +12321 CONTINUE +! WRITE(6,88221)PPTOP,KD,KP +!88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2) +! open(unit=23,file='fort.23',form='unformatted' & +! , access='sequential') +! REWIND 23 +! READ(23)SIGLY +! DO KKK=1,KD +! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD +! END DO +! WRITE(6,88222) +!88222 FORMAT(' READ AETA') +! DO 37821 LLL=1,KD +! WRITE(6,37820)LLL,SIGLY(LLL) +!37820 FORMAT(' L=',I2,' AETA=',E12.5) +!37821 CONTINUE +! READ(23)SIGLV +! DO KKK=1,KP +! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD +! END DO +! WRITE(6,88223) +!88223 FORMAT(' READ ETA') +! PRINT 704,(SIGLY(K),K=1,KD) +! PRINT 704,(SIGLV(K),K=1,KP) +! DO 37823 LLL=1,KP +! WRITE(6,37822)LLL,SIGLV(LLL) +!37822 FORMAT(' L=',I2,' ETA=',E12.5) +!37823 CONTINUE + 701 FORMAT(F6.2) + 702 FORMAT(7F10.6) + IF (PPTOP.LE.0.) GO TO 708 + PSFC=100. +!--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM +! VERTICAL LOCATION + DO 706 K=1,KD + SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC + 706 CONTINUE + DO 707 K=1,KP + SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC + 707 CONTINUE + 708 CONTINUE +! PRINT 703,PPTOP +! PRINT 704,(SIGLY(K),K=1,KD) +! PRINT 704,(SIGLV(K),K=1,KP) + 703 FORMAT(1H ,'PTOP =',F6.2) + 704 FORMAT(1H ,7F10.6) + DO 913 K=1,KP + SGLVNU(K) = SIGLV(K) + IF (K.LE.KD) SIGLNU(K) = SIGLY(K) + 913 CONTINUE + DO 77 K=1,KD + Q(K) = SIGLNU(KD+1-K) + 77 CONTINUE + PSS= 1013250. + QMH(1)=0. + QMH(KP)=1. + DO 1 K=2,KD + QMH(K)=0.5*(Q(K-1)+Q(K)) +1 CONTINUE + PD(1)=0. + PD(KP2)=PSS + DO 2 K=2,KP + PD(K)=Q(K-1)*PSS +2 CONTINUE +! call int_get_fresh_handle(retval) +! close(retval) +! write(0,*)' before open in CO2O3' +! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier) +! write(0,*)' after open1' +! do k=1,62 +! write(retval)pd(k) +! enddo +! close(retval) + PLM(1)=0. + DO 3 K=1,KM + PLM(K+1)=0.5*(PD(K+1)+PD(K+2)) +3 CONTINUE + PLM(KP)=PSS + DO 4 K=1,KD + GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250. +4 CONTINUE + GTEMP(KP)=0. +!+++ WRITE (6,100) (GTEMP(K),K=1,KD) +!+++ WRITE (6,100) (PD(K),K=1,KP2) +!+++ WRITE (6,100) (PLM(K),K=1,KP) +!***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB) +! THE FOLLOWING PUTS P-DATA INTO MB + DO 11 I=1,KP + PD(I)=PD(I)*1.0E-3 + PLM(I)=PLM(I)*1.0E-3 +11 CONTINUE + PD(KP2)=PD(KP2)*1.0E-3 +!CC WRITE (41,101) (PD(K),K=1,KP2) +!CC WRITE (41,101) (PLM(K),K=1,KP) +!CC WRITE (42,101) (PLM(K),K=1,KP) + DO 300 K=1,KP2 + T41(K,1) = PD(K) + 300 CONTINUE + DO 301 K=1,KP + T41(K,2) = PLM(K) + T42(K) = PLM(K) + 301 CONTINUE +!***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ + DO 12 I=1,KP2 + PDT(I)=PD(I) +12 CONTINUE +!***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED + PSS=0.8*1013250. + QMH(1)=0. + QMH(KP)=1. + DO 201 K=2,KD + QMH(K)=0.5*(Q(K-1)+Q(K)) +201 CONTINUE + PD(1)=0. + PD(KP2)=PSS + DO 202 K=2,KP + PD(K)=Q(K-1)*PSS +202 CONTINUE + PLM(1)=0. + DO 203 K=1,KM + PLM(K+1)=0.5*(PD(K+1)+PD(K+2)) +203 CONTINUE + PLM(KP)=PSS +!+++ WRITE (6,100) (PD(K),K=1,KP2) +!+++ WRITE (6,100) (PLM(K),K=1,KP) +!***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB) +! THE FOLLOWING PUTS P-DATA INTO MB + DO 211 I=1,KP + PD(I)=PD(I)*1.0E-3 + PLM(I)=PLM(I)*1.0E-3 +211 CONTINUE + PD(KP2)=PD(KP2)*1.0E-3 +!CC WRITE (43,101) (PD(K),K=1,KP2) +!CC WRITE (43,101) (PLM(K),K=1,KP) +!CC WRITE (44,101) (PLM(K),K=1,KP) + DO 302 K=1,KP2 + T43(K,1) = PD(K) + 302 CONTINUE + DO 303 K=1,KP + T43(K,2) = PLM(K) + T44(K) = PLM(K) + 303 CONTINUE +!***RESTORE PD + DO 212 I=1,KP2 + PD(I)=PDT(I) +212 CONTINUE +100 FORMAT (1X,5E20.13) +101 FORMAT (5E16.9) + RETURN + END SUBROUTINE SIGP +!--------------------------------------------------------------------- + SUBROUTINE SINTR2 +!.... +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) +! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV + COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N +! COMMON/PRESS/ PA(109) +! COMMON/TRAN/ TRANSA(109,109) +! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP + DO 70 L=1,109 + IP1=L + IF (P2-PA(L)) 65,65,70 + 70 CONTINUE + 65 I=IP1-1 + IF (IP1.EQ.1) IP1=2 + IF (I.EQ.0) I=1 + DO 80 L=1,109 + JP1=L + IF (P1-PA(L)) 75,75,80 + 80 CONTINUE + 75 J=JP1-1 + IF (JP1.EQ.1) JP1=2 + IF (J.EQ.0) J=1 + JJJ=J + III=I + J=JJJ + JP1=J+1 + I=III + IP1=I+1 +! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION +! FOR PETA(=0.5*(P1+P2)) + PETA=P2 + DO 90 L=1,109 + IETAP1=L + IF (PETA-PA(L)) 85,85,90 +90 CONTINUE +85 IETA=IETAP1-1 + IF (IETAP1.EQ.1) IETAP1=2 + IF (IETA.EQ.0) IETA=1 + ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ & + (PA(IETAP1)-PA(IETA)) + SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- & + SEXPV(IETA))/ (PA(IETAP1)-PA(IETA)) + PIPMPI=PA(IP1)-PA(I) + UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP + IF (I-J) 126,126,127 + 126 CONTINUE + TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP) + TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP) + TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI + GO TO 128 + 127 TIJ=TRANSA(I,J) + TIPJ=TRANSA(I+1,J) + TIJP=TRANSA(I,J+1) + TIPJP=TRANSA(I+1,J+1) + UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP + UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP + UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP + UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP + PRODI=CA(I)*XA(I) + PRODIP=CA(I+1)*XA(I+1) + PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI + XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI + CINT=PROD/XINT + AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP) + AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP) + AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP) + AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP) + EIJ=TIJ+AIJ + EIPJ=TIPJ+AIPJ + EIJP=TIJP+AIJP + EIPJP=TIPJP+AIPJP + DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J)) + DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J)) + EPIP1=EIJ+DTDJ*(P1-PA(J)) + EPIPP1=EIPJ+DTDPJ*(P1-PA(J)) + EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI + TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP) + IF (I.GE.108.OR.J.GE.108) GO TO 350 + IF (I-J-2) 350,350,355 +355 CONTINUE + TIP2J=TRANSA(I+2,J) + TIP2JP=TRANSA(I+2,J+1) + TI2J2=TRANSA(I+2,J+2) + TIJP2=TRANSA(I,J+2) + TIPJP2=TRANSA(I+1,J+2) + UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP + UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP + UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP + UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP + UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP + AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP) + AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP) + AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP) + AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP) + AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP) + EIP2J=TIP2J+AIP2J + EIP2JP=TIP2JP+AIP2JP + EIJP2=TIJP2+AIJP2 + EIPJP2=TIPJP2+AIPJP2 + EI2J2=TI2J2+AI2J2 + CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI) + CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP) + CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2) + CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL) + TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP) + 350 CONTINUE + 128 CONTINUE + 205 CONTINUE + RETURN + END SUBROUTINE SINTR2 + SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2) +!CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL +! CODES TO PRODUCE A FILE OF CO2 HGT DATA +! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE +! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89. +!NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C. + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 errmess +! integer :: retval,kk,ka,kb +! character(50) :: co2='co2' + INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR + DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6) +!NOV89 + DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6) +!NOV89 + DIMENSION T41(LP2,2),T42(LP1), & + T43(LP2,2),T44(LP1) + DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3) + DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3) + DIMENSION SGLVNU(LP1),SIGLNU(L) + DIMENSION SFULL(LP1),SHALF(L) +! DIMENSION STEMP(LP1),GTEMP(LP1) +! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L) +! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L) +! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1) +! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1) +!NOV89 +! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1) +! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1) +! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1) +! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1) +! DIMENSION CO211(LP1),CO218(LP1) +! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2)) +! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4)) +! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6)) +! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2)) +! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4)) +! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6)) +! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5)) +!NOV89 +! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2)) +! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2)) +! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4)) +! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6)) +! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2)) +! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4)) +! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6)) + +! +! Deallocate before reading. This is required for nested domain init. +! + IF(ALLOCATED (CO251))DEALLOCATE(CO251) + IF(ALLOCATED (CDT51))DEALLOCATE(CDT51) + IF(ALLOCATED (C2D51))DEALLOCATE(C2D51) + IF(ALLOCATED (CO258))DEALLOCATE(CO258) + IF(ALLOCATED (CDT58))DEALLOCATE(CDT58) + IF(ALLOCATED (C2D58))DEALLOCATE(C2D58) + IF(ALLOCATED (STEMP))DEALLOCATE(STEMP) + IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP) + IF(ALLOCATED (CO231))DEALLOCATE(CO231) + IF(ALLOCATED (CDT31))DEALLOCATE(CDT31) + IF(ALLOCATED (C2D31))DEALLOCATE(C2D31) + IF(ALLOCATED (CO238))DEALLOCATE(CO238) + IF(ALLOCATED (CDT38))DEALLOCATE(CDT38) + IF(ALLOCATED (C2D38))DEALLOCATE(C2D38) + IF(ALLOCATED (CO271))DEALLOCATE(CO271) + IF(ALLOCATED (CDT71))DEALLOCATE(CDT71) + IF(ALLOCATED (C2D71))DEALLOCATE(C2D71) + IF(ALLOCATED (CO278))DEALLOCATE(CO278) + IF(ALLOCATED (CDT78))DEALLOCATE(CDT78) + IF(ALLOCATED (C2D78))DEALLOCATE(C2D78) + IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51) + IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51) + IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51) + IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58) + IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58) + IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58) +! + ALLOCATE(CO251(LP1,LP1)) + ALLOCATE(CDT51(LP1,LP1)) + ALLOCATE(C2D51(LP1,LP1)) + ALLOCATE(CO258(LP1,LP1)) + ALLOCATE(CDT58(LP1,LP1)) + ALLOCATE(C2D58(LP1,LP1)) + ALLOCATE(STEMP(LP1)) + ALLOCATE(GTEMP(LP1)) + ALLOCATE(CO231(LP1)) + ALLOCATE(CDT31(LP1)) + ALLOCATE(C2D31(LP1)) + ALLOCATE(CO238(LP1)) + ALLOCATE(CDT38(LP1)) + ALLOCATE(C2D38(LP1)) + ALLOCATE(CO271(LP1)) + ALLOCATE(CDT71(LP1)) + ALLOCATE(C2D71(LP1)) + ALLOCATE(CO278(LP1)) + ALLOCATE(CDT78(LP1)) + ALLOCATE(C2D78(LP1)) + ALLOCATE(CO2M51(L)) + ALLOCATE(CDTM51(L)) + ALLOCATE(C2DM51(L)) + ALLOCATE(CO2M58(L)) + ALLOCATE(CDTM58(L)) + ALLOCATE(C2DM58(L)) + IF ( wrf_dm_on_monitor() ) THEN + DO i = 61,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + etarad_unit61 = i + GOTO 2061 + ENDIF + ENDDO + etarad_unit61 = -1 + 2061 CONTINUE + DO i = 62,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + etarad_unit62 = i + GOTO 2062 + ENDIF + ENDDO + etarad_unit62 = -1 + 2062 CONTINUE + DO i = 63,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + etarad_unit63 = i + GOTO 2063 + ENDIF + ENDDO + etarad_unit63 = -1 + 2063 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE ) + IF ( etarad_unit61 < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) + ENDIF + CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE ) + IF ( etarad_unit62 < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) + ENDIF + CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE ) + IF ( etarad_unit63 < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) + ENDIF + IF ( wrf_dm_on_monitor() ) THEN + OPEN(etarad_unit61,FILE='tr49t85', & + FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR) + ENDIF + IF ( wrf_dm_on_monitor() ) THEN + OPEN(etarad_unit62,FILE='tr49t67', & + FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR) + ENDIF + IF ( wrf_dm_on_monitor() ) THEN + OPEN(etarad_unit63,FILE='tr67t85', & + FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR) + ENDIF + +!===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44.... + LREAD = 0 +! DO KKK=1,L +!JD READ(23)SIGLNU(KKK) +! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1 +! END DO + CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & + SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2) +! call int_get_fresh_handle(retval) +! close(retval) +! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier) +! do kk=1,2 +! write(retval)(sgtemp(k,kk),k=1,61) +! enddo + DO K=1,LP1 + STEMP(K)=SGTEMP(K,1) + GTEMP(K)=SGTEMP(K,2) + ENDDO +!===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. +! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE... +! FOR THE CONSOLIDATED 490-850 CM-1 BAND... +!NOV89 +! ICO2TP=61 + ICO2TP=etarad_unit61 +!NOV89 + IR = 1 + RATIO = 1.0 + NMETHD = 2 + CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) + IR = 1 + RATIO = 1.0 + NMETHD = 1 + CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2) + IR = 1 + RATIO = 1.0 + NMETHD = 2 + CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) + IR = 1 + RATIO = 1.0 + NMETHD = 1 + CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2) +!===> FILL UP THE CO2D1D ARRAY +! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND +! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS, +! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE +! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE +! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O.. +! + IQ = 1 + CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1) +! do kk=1,6 +! write(retval)(co2d1d(k,kk),k=1,60) +! enddo + DO K=1,L + CDTM51(K)=CO2D1D(K,1) + CO2M51(K)=CO2D1D(K,2) + C2DM51(K)=CO2D1D(K,3) + CDTM58(K)=CO2D1D(K,4) + CO2M58(K)=CO2D1D(K,5) + C2DM58(K)=CO2D1D(K,6) + ENDDO +! +!===> FILL UP THE CO2D2D ARRAY +! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES +! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 +! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED +! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A +! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN +! SCHWARZKOPF AND FELS (J.G.R.,1985). +! + CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1) +! do kk=1,6 +! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61) +! enddo + DO K1=1,LP1 + DO K2=1,LP1 + CDT51(K1,K2)=CO2D2D(K1,K2,1) + CO251(K1,K2)=CO2D2D(K1,K2,2) + C2D51(K1,K2)=CO2D2D(K1,K2,3) + CDT58(K1,K2)=CO2D2D(K1,K2,4) + CO258(K1,K2)=CO2D2D(K1,K2,5) + C2D58(K1,K2)=CO2D2D(K1,K2,6) + ENDDO + ENDDO +! +!NOV89 +!===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. +! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE... +! FOR THE CONSOLIDATED 490-670 CM-1 BAND... +! ICO2TP=62 + ICO2TP=etarad_unit62 + IR = 2 + RATIO = 1.0 + NMETHD = 2 + CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) + CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) + IQ = 2 + CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2) +! do kk=1,6 +! write(retval)(co2iq2(k,1,kk),k=1,61) +! enddo + DO K=1,LP1 + CDT31(K)=CO2IQ2(K,1,1) + CO231(K)=CO2IQ2(K,1,2) + C2D31(K)=CO2IQ2(K,1,3) + CDT38(K)=CO2IQ2(K,1,4) + CO238(K)=CO2IQ2(K,1,5) + C2D38(K)=CO2IQ2(K,1,6) + ENDDO +!===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. +! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE... +! FOR THE CONSOLIDATED 670-850 CM-1 BAND... +! ICO2TP=63 + ICO2TP=etarad_unit63 + IR = 3 + RATIO = 1.0 + NMETHD = 2 + CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) + CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) + IQ = 3 + CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3) +! do kk=1,6 +! write(retval)(co2iq3(k,1,kk),k=1,61) +! enddo +! close(retval) + DO K=1,LP1 + CDT71(K)=CO2IQ3(K,1,1) + CO271(K)=CO2IQ3(K,1,2) + C2D71(K)=CO2IQ3(K,1,3) + CDT78(K)=CO2IQ3(K,1,4) + CO278(K)=CO2IQ3(K,1,5) + C2D78(K)=CO2IQ3(K,1,6) + ENDDO +!--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET +!===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. +! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE... +! FOR THE 4.3 MICRON BAND... +! NOT USED YET ICO2TP=65 +! NOT USED YET IR = 4 +! NOT USED YET RATIO = 1.0 +! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET)..... +! NOT USED YET NMETHD = 2 +! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD) +! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD) +! NOT USED YET IQ = 5 +! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ) +!NOV89 +!... WRITE DATA TO DISK.. +! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA +! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP.. + +! NOT USED YET WRITE(66) CO211 +! NOT USED YET WRITE(66) CO218 +!NOV89 + IF ( wrf_dm_on_monitor() ) THEN + CLOSE (etarad_unit61) + CLOSE (etarad_unit62) + CLOSE (etarad_unit63) + ENDIF + + RETURN +9061 CONTINUE + WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61 + write(0,*)' IERROR=',IERROR + CALL wrf_error_fatal(errmess) +9062 CONTINUE + WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62 + write(0,*)' IERROR=',IERROR + CALL wrf_error_fatal(errmess) +9063 CONTINUE + WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63 + write(0,*)' IERROR=',IERROR + CALL wrf_error_fatal(errmess) + END SUBROUTINE CO2O3 + + +!!================================================================================ +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- + SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE) +!---------------------------------------------------------------------- +! ******************************************************************* +! * C O N R A D * +! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL * +! * COORDINATE TESTS ... * +! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 * +! ******************************************************************* +! +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE +!---------------------------------------------------------------------- +! + INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE + INTEGER,DIMENSION(3) :: RSZE +! + REAL,DIMENSION(KMS:KME-1,6) :: CO21D + REAL,DIMENSION(KMS:KME,2) :: SGTMP + REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7 + REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D + REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2 + LOGICAL :: OPENED + LOGICAL,EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 errmess +! +!---------------------------------------------------------------------- +! +! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE +! +! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION +! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND +! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), +!----- THE 2-DIMENSIONAL ARRAYS ARE +! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES +! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 +! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED +! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A +! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN +! SCHWARZKOPF AND FELS (J.G.R.,1985). +!----- THE 1-DIM ARRAYS ARE +! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES +! FOR TAU(I,I+1),I=1,L, +! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE +! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. +! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O. +!----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/ +! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR +! PSTAR=1013250. +!----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS +! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM) +! +!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE +! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED +! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE +! DATA ARE IN BLOCK DATA BD3: +! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) +! WITH P(SFC)=1013.25 MB +! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) +! WITH P(SFC)= 810 MB +! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251 +! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258 +! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251 +! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251 +! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE +! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR +! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB +! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB +! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51 +! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58 +! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51 +! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58 +! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL +! STRUCTURE WITH P(SFC)=1013.25 MB +! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL +! STRUCTURE WITH P(SFC)=1013.25 MB. +!----- THE FOLLOWING ARE STILL IN BLOCK DATA +! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. +! CORRECTION FOR T(K). (SEE REF. 4 AND BD3) +! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0 +! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0 +! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0 +! +!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE +! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM +! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2. +! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE +! THESE ARE USED FOR CTS COMPUTATIONS. +! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) +! WITH P(SFC)=1013.25 MB +! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) +! WITH P(SFC)= 810 MB +! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231 +! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238 +! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231 +! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231 +! +!***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE +! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM +! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4. +! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) +! WITH P(SFC)=1013.25 MB +! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) +! WITH P(SFC)= 810 MB +! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271 +! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278 +! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271 +! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271 +! +! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION ******* +! +! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270- +! 2380 PART OF THE 4.3 UM CO2 BAND. +! THESE DATA ARE IN BLOCK DATA BD5. +! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) +! WITH P(SFC)=1013.25 MB +! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) +! WITH P(SFC)= 810 MB +! +! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION *********** +!---------------------------------------------------------------------- +! + L=KME-KMS + LP1=KME-KMS+1 +! +!---------------------------------------------------------------------- + IF ( wrf_dm_on_monitor() ) THEN + DO i = 14,99 + write(0,*)' in CONRAD i=',i,' opened=',opened + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + nunit_co2 = i + GOTO 2014 + ENDIF + ENDDO + nunit_co2 = -1 + 2014 CONTINUE + ENDIF + IF ( wrf_dm_on_monitor() ) THEN + OPEN(nunit_co2,FILE='co2_trans', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR) + ENDIF + + REWIND NUNIT_CO2 +!---------------------------------------------------------------------- +! +!*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA. +! + RSZE(1) = LP1 + RSZE(2) = L + RSZE(3) = LP1*LP1 +!---------------------------------------------------------------------- +! + RSIZE = RSZE(1) +! + DO KK=1,2 + IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE) + CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE ) + ENDDO +! +!---------------------------------------------------------------------- +! + RSIZE = RSZE(2) +! + DO KK=1,6 + IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE) + CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE ) + ENDDO +! +!---------------------------------------------------------------------- +! + RSIZE = RSZE(3) +! + DO KK=1,6 + IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE) + CALL wrf_dm_bcast_real( DATA2(1), RSIZE ) + N=0 +! + DO I1=1,LP1 + DO I2=1,LP1 + N=N+1 + CO22D(I1,I2,KK)=DATA2(N) + ENDDO + ENDDO +! + ENDDO + +! +! Deallocate before reading. This is required for nested domain init. +! + IF(ALLOCATED (CO251))DEALLOCATE(CO251) + IF(ALLOCATED (CDT51))DEALLOCATE(CDT51) + IF(ALLOCATED (C2D51))DEALLOCATE(C2D51) + IF(ALLOCATED (CO258))DEALLOCATE(CO258) + IF(ALLOCATED (CDT58))DEALLOCATE(CDT58) + IF(ALLOCATED (C2D58))DEALLOCATE(C2D58) + IF(ALLOCATED (STEMP))DEALLOCATE(STEMP) + IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP) + IF(ALLOCATED (CO231))DEALLOCATE(CO231) + IF(ALLOCATED (CDT31))DEALLOCATE(CDT31) + IF(ALLOCATED (C2D31))DEALLOCATE(C2D31) + IF(ALLOCATED (CO238))DEALLOCATE(CO238) + IF(ALLOCATED (CDT38))DEALLOCATE(CDT38) + IF(ALLOCATED (C2D38))DEALLOCATE(C2D38) + IF(ALLOCATED (CO271))DEALLOCATE(CO271) + IF(ALLOCATED (CDT71))DEALLOCATE(CDT71) + IF(ALLOCATED (C2D71))DEALLOCATE(C2D71) + IF(ALLOCATED (CO278))DEALLOCATE(CO278) + IF(ALLOCATED (CDT78))DEALLOCATE(CDT78) + IF(ALLOCATED (C2D78))DEALLOCATE(C2D78) + IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51) + IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51) + IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51) + IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58) + IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58) + IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58) +! +!---------------------------------------------------------------------- +! + RSIZE = RSZE(1) +! + DO KK=1,6 + IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE) + CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE ) + ENDDO +! +!---------------------------------------------------------------------- +! + DO KK=1,6 + IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE) + CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE ) + ENDDO +! +!---------------------------------------------------------------------- + ALLOCATE(CO251(LP1,LP1)) + ALLOCATE(CDT51(LP1,LP1)) + ALLOCATE(C2D51(LP1,LP1)) + ALLOCATE(CO258(LP1,LP1)) + ALLOCATE(CDT58(LP1,LP1)) + ALLOCATE(C2D58(LP1,LP1)) + ALLOCATE(STEMP(LP1)) + ALLOCATE(GTEMP(LP1)) + ALLOCATE(CO231(LP1)) + ALLOCATE(CDT31(LP1)) + ALLOCATE(C2D31(LP1)) + ALLOCATE(CO238(LP1)) + ALLOCATE(CDT38(LP1)) + ALLOCATE(C2D38(LP1)) + ALLOCATE(CO271(LP1)) + ALLOCATE(CDT71(LP1)) + ALLOCATE(C2D71(LP1)) + ALLOCATE(CO278(LP1)) + ALLOCATE(CDT78(LP1)) + ALLOCATE(C2D78(LP1)) + ALLOCATE(CO2M51(L)) + ALLOCATE(CDTM51(L)) + ALLOCATE(C2DM51(L)) + ALLOCATE(CO2M58(L)) + ALLOCATE(CDTM58(L)) + ALLOCATE(C2DM58(L)) +!---------------------------------------------------------------------- +! + DO K=1,LP1 + STEMP(K) = SGTMP(K,1) + GTEMP(K) = SGTMP(K,2) + ENDDO +! + DO K=1,L + CDTM51(K) = CO21D(K,1) + CO2M51(K) = CO21D(K,2) + C2DM51(K) = CO21D(K,3) + CDTM58(K) = CO21D(K,4) + CO2M58(K) = CO21D(K,5) + C2DM58(K) = CO21D(K,6) + ENDDO +! + DO J=1,LP1 + DO I=1,LP1 + CDT51(I,J) = CO22D(I,J,1) + CO251(I,J) = CO22D(I,J,2) + C2D51(I,J) = CO22D(I,J,3) + CDT58(I,J) = CO22D(I,J,4) + CO258(I,J) = CO22D(I,J,5) + C2D58(I,J) = CO22D(I,J,6) + ENDDO + ENDDO +! + DO K=1,LP1 + CDT31(K) = CO21D3(K,1) + CO231(K) = CO21D3(K,2) + C2D31(K) = CO21D3(K,3) + CDT38(K) = CO21D3(K,4) + CO238(K) = CO21D3(K,5) + C2D38(K) = CO21D3(K,6) + ENDDO +! + DO K=1,LP1 + CDT71(K) = CO21D7(K,1) + CO271(K) = CO21D7(K,2) + C2D71(K) = CO21D7(K,3) + CDT78(K) = CO21D7(K,4) + CO278(K) = CO21D7(K,5) + C2D78(K) = CO21D7(K,6) + ENDDO +! +!---------------------------------------------------------------------- + IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2 + 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2) +!---------------------------------------------------------------------- + IF( wrf_dm_on_monitor() )THEN + CLOSE(nunit_co2) + ENDIF + RETURN +! +9014 CONTINUE + WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2 + CALL wrf_error_fatal(errmess) +!---------------------------------------------------------------------- + END SUBROUTINE CONRAD +!+---+-----------------------------------------------------------------+ +! Replacement routine to compute saturation vapor pressure over +! water/ice. This is needed here in case we run microphysics other +! than ETAMPNEW (Ferrier) because it initializes a lookup table to +! facilitate calculations of FVPS. For speed, we use the polynomial +! expansion of Flatau & Walko, 1989. +!+---+-----------------------------------------------------------------+ + REAL FUNCTION FPVS_new(T) + + IMPLICIT NONE + REAL, INTENT(IN):: T + + if (T .ge. 273.16) then + FPVS_new = e_sub_l(T) + else + FPVS_new = e_sub_i(T) + endif + + END FUNCTION FPVS_new +! +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS +! A FUNCTION OF TEMPERATURE. +! + REAL FUNCTION e_sub_l(T) + + IMPLICIT NONE + REAL, INTENT(IN):: T + REAL:: ESL,X + REAL, PARAMETER:: C0= .611583699E03 + REAL, PARAMETER:: C1= .444606896E02 + REAL, PARAMETER:: C2= .143177157E01 + REAL, PARAMETER:: C3= .264224321E-1 + REAL, PARAMETER:: C4= .299291081E-3 + REAL, PARAMETER:: C5= .203154182E-5 + REAL, PARAMETER:: C6= .702620698E-8 + REAL, PARAMETER:: C7= .379534310E-11 + REAL, PARAMETER:: C8=-.321582393E-13 + + X=AMAX1(-80.,T-273.16) + + ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + + e_sub_l = ESL + + END FUNCTION e_sub_l +! +!+---+-----------------------------------------------------------------+ +! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A +! FUNCTION OF TEMPERATURE. +! + REAL FUNCTION e_sub_i(T) + + IMPLICIT NONE + REAL, INTENT(IN):: T + REAL:: ESI,X + REAL, PARAMETER:: C0= .609868993E03 + REAL, PARAMETER:: C1= .499320233E02 + REAL, PARAMETER:: C2= .184672631E01 + REAL, PARAMETER:: C3= .402737184E-1 + REAL, PARAMETER:: C4= .565392987E-3 + REAL, PARAMETER:: C5= .521693933E-5 + REAL, PARAMETER:: C6= .307839583E-7 + REAL, PARAMETER:: C7= .105785160E-9 + REAL, PARAMETER:: C8= .161444444E-12 + + X=AMAX1(-80.,T-273.16) + ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + + e_sub_i = ESI + + END FUNCTION e_sub_i + +! + +!---------------------------------------------------------------------- +! + END MODULE module_RA_GFDLETA +! +!---------------------------------------------------------------------- + diff --git a/wrfv2_fire/phys/module_ra_gsfcsw.F b/wrfv2_fire/phys/module_ra_gsfcsw.F new file mode 100644 index 00000000..c7186ff9 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_gsfcsw.F @@ -0,0 +1,3160 @@ +!Comment the following out to turn off aerosol-radiation +!feedback between MOSAIC and GSFCSW. wig, 21-Feb-2005 + +MODULE module_ra_gsfcsw + + REAL, PARAMETER, PRIVATE :: thresh=1.e-9 + REAL, SAVE :: center_lat + +! Assign co2 and trace gases amount (units are parts/part by volumn) + + REAL, PARAMETER, PRIVATE :: co2 = 300.e-6 + +CONTAINS + +!------------------------------------------------------------------ +! urban related variable are added to arguments of gsfcswrad +!------------------------------------------------------------------ + SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & + ,dz8w,rho_phy & + ,alb,t3d,qv3d,qc3d,qr3d & + ,qi3d,qs3d,qg3d,qndrop3d & + ,p3d,p8w3d,pi3d,cldfra3d,rswtoa & + ,gmt,cp,g,julday,xtime,declin,solcon & + ,radfrq,degrad,taucldi,taucldc,warm_rain & + ,tauaer300,tauaer400,tauaer600,tauaer999 & ! jcb + ,gaer300,gaer400,gaer600,gaer999 & ! jcb + ,waer300,waer400,waer600,waer999 & ! jcb + ,aer_ra_feedback & + ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,cosz_urb2d,omg_urb2d ) !Optional urban +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + INTEGER, PARAMETER :: np = 75 + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + LOGICAL, INTENT(IN ) :: warm_rain + + INTEGER, INTENT(IN ) :: JULDAY + + + REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & + XTIME,DECLIN,SOLCON +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: P3D, & + P8W3D, & + pi3D, & + T3D, & + dz8w, & + rho_phy, & + CLDFRA3D + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATEN + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: taucldi, & + taucldc +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAT, & + XLONG, & + ALB +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: GSW, & + RSWTOA +! + REAL, INTENT(IN ) :: GMT,CP,G +! + +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb + gaer300,gaer400,gaer600,gaer999, & ! jcb + waer300,waer400,waer600,waer999 ! jcb + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(IN ) :: & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + QNDROP3D + + LOGICAL, OPTIONAL, INTENT(IN ) :: & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & + F_QNDROP + +! LOCAL VARS + + REAL, DIMENSION( its:ite ) :: & + ts, & + cosz, & + rsuvbm, & + rsuvdf, & + rsirbm, & + rsirdf, & + p400, & + p700 + + INTEGER, DIMENSION( its:ite ) :: & + ict, & + icb + + REAL, DIMENSION( its:ite, kts-1:kte, 2 ) :: taucld + + REAL, DIMENSION( its:ite, kts-1:kte+1 ) :: flx, & + flxd +! + REAL, DIMENSION( its:ite, kts-1:kte ) :: O3 +! + REAL, DIMENSION( its:ite, kts-1:kte, 11 ) :: & + taual, & + ssaal, & + asyal + + REAL, DIMENSION( its:ite, kts-1:kte, 2 ) :: & + reff, & + cwc + REAL, DIMENSION( its: ite, kts-1:kte+1 ) :: & + P8W2D + REAL, DIMENSION( its: ite, kts-1:kte ) :: & + TTEN2D, & + qndrop2d, & + SH2D, & + P2D, & + T2D, & + fcld2D + real, DIMENSION( its:ite , kts:kte+1 ) :: phyd + real, DIMENSION( its:ite , kts:kte ) :: phydmid + + REAL, DIMENSION( np, 5 ) :: pres, & + ozone + REAL, DIMENSION( np ) :: p + + LOGICAL :: cldwater,overcast, predicate +! + INTEGER :: i,j,K,NK,ib,kk,mix,mkx + +! iprof = 1 : mid-latitude summer profile +! = 2 : mid-latitude winter profile +! = 3 : sub-arctic summer profile +! = 4 : sub-arctic winter profile +! = 5 : tropical profile +! + + INTEGER :: iprof, & + is_summer, & + ie_summer, & + lattmp + + +! + REAL :: XLAT0,XLONG0 + REAL :: fac,latrmp + REAL :: xt24,tloctm,hrang,xxlat + +!URBAN + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: COSZ_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: OMG_URB2D !urban + + real, dimension(11) :: midbands ! jcb + data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ ! jcb + real :: ang,slope ! jcb + character(len=200) :: msg !wig + real pi, third, relconst, lwpmin, rhoh2o +! +!-------------------------------------------------------------------------------- +! data set 1 +! mid-latitude summer (75 levels) : p(mb) o3(g/g) +! surface temp = 294.0 +! + data (pres(i,1),i=1,np)/ & + 0.0006244, 0.0008759, 0.0012286, 0.0017234, 0.0024174, & + 0.0033909, 0.0047565, 0.0066720, 0.0093589, 0.0131278, & + 0.0184145, 0.0258302, 0.0362323, 0.0508234, 0.0712906, & + 0.1000000, 0.1402710, 0.1967600, 0.2759970, 0.3871430, & + 0.5430, 0.7617, 1.0685, 1.4988, 2.1024, 2.9490, & + 4.1366, 5.8025, 8.1392, 11.4170, 16.0147, 22.4640, & + 31.5105, 44.2001, 62.0000, 85.7750, 109.5500, 133.3250, & + 157.1000, 180.8750, 204.6500, 228.4250, 252.2000, 275.9750, & + 299.7500, 323.5250, 347.3000, 371.0750, 394.8500, 418.6250, & + 442.4000, 466.1750, 489.9500, 513.7250, 537.5000, 561.2750, & + 585.0500, 608.8250, 632.6000, 656.3750, 680.1500, 703.9250, & + 727.7000, 751.4750, 775.2500, 799.0250, 822.8000, 846.5750, & + 870.3500, 894.1250, 917.9000, 941.6750, 965.4500, 989.2250, & + 1013.0000/ +! + data (ozone(i,1),i=1,np)/ & + 0.1793E-06, 0.2228E-06, 0.2665E-06, 0.3104E-06, 0.3545E-06, & + 0.3989E-06, 0.4435E-06, 0.4883E-06, 0.5333E-06, 0.5786E-06, & + 0.6241E-06, 0.6698E-06, 0.7157E-06, 0.7622E-06, 0.8557E-06, & + 0.1150E-05, 0.1462E-05, 0.1793E-05, 0.2143E-05, 0.2512E-05, & + 0.2902E-05, 0.3313E-05, 0.4016E-05, 0.5193E-05, 0.6698E-05, & + 0.8483E-05, 0.9378E-05, 0.9792E-05, 0.1002E-04, 0.1014E-04, & + 0.9312E-05, 0.7834E-05, 0.6448E-05, 0.5159E-05, 0.3390E-05, & + 0.1937E-05, 0.1205E-05, 0.8778E-06, 0.6935E-06, 0.5112E-06, & + 0.3877E-06, 0.3262E-06, 0.2770E-06, 0.2266E-06, 0.2020E-06, & + 0.1845E-06, 0.1679E-06, 0.1519E-06, 0.1415E-06, 0.1317E-06, & + 0.1225E-06, 0.1137E-06, 0.1055E-06, 0.1001E-06, 0.9487E-07, & + 0.9016E-07, 0.8641E-07, 0.8276E-07, 0.7930E-07, 0.7635E-07, & + 0.7347E-07, 0.7065E-07, 0.6821E-07, 0.6593E-07, 0.6368E-07, & + 0.6148E-07, 0.5998E-07, 0.5859E-07, 0.5720E-07, 0.5582E-07, & + 0.5457E-07, 0.5339E-07, 0.5224E-07, 0.5110E-07, 0.4999E-07/ + +!-------------------------------------------------------------------------------- +! data set 2 +! mid-latitude winter (75 levels) : p(mb) o3(g/g) +! surface temp = 272.2 +! + data (pres(i,2),i=1,np)/ & + 0.0006244, 0.0008759, 0.0012286, 0.0017234, 0.0024174, & + 0.0033909, 0.0047565, 0.0066720, 0.0093589, 0.0131278, & + 0.0184145, 0.0258302, 0.0362323, 0.0508234, 0.0712906, & + 0.1000000, 0.1402710, 0.1967600, 0.2759970, 0.3871430, & + 0.5430, 0.7617, 1.0685, 1.4988, 2.1024, 2.9490, & + 4.1366, 5.8025, 8.1392, 11.4170, 16.0147, 22.4640, & + 31.5105, 44.2001, 62.0000, 85.9000, 109.8000, 133.7000, & + 157.6000, 181.5000, 205.4000, 229.3000, 253.2000, 277.1000, & + 301.0000, 324.9000, 348.8000, 372.7000, 396.6000, 420.5000, & + 444.4000, 468.3000, 492.2000, 516.1000, 540.0000, 563.9000, & + 587.8000, 611.7000, 635.6000, 659.5000, 683.4000, 707.3000, & + 731.2000, 755.1000, 779.0000, 802.9000, 826.8000, 850.7000, & + 874.6000, 898.5000, 922.4000, 946.3000, 970.2000, 994.1000, & + 1018.0000/ +! + data (ozone(i,2),i=1,np)/ & + 0.2353E-06, 0.3054E-06, 0.3771E-06, 0.4498E-06, 0.5236E-06, & + 0.5984E-06, 0.6742E-06, 0.7511E-06, 0.8290E-06, 0.9080E-06, & + 0.9881E-06, 0.1069E-05, 0.1152E-05, 0.1319E-05, 0.1725E-05, & + 0.2145E-05, 0.2581E-05, 0.3031E-05, 0.3497E-05, 0.3980E-05, & + 0.4478E-05, 0.5300E-05, 0.6725E-05, 0.8415E-05, 0.1035E-04, & + 0.1141E-04, 0.1155E-04, 0.1143E-04, 0.1093E-04, 0.1060E-04, & + 0.9720E-05, 0.8849E-05, 0.7424E-05, 0.6023E-05, 0.4310E-05, & + 0.2820E-05, 0.1990E-05, 0.1518E-05, 0.1206E-05, 0.9370E-06, & + 0.7177E-06, 0.5450E-06, 0.4131E-06, 0.3277E-06, 0.2563E-06, & + 0.2120E-06, 0.1711E-06, 0.1524E-06, 0.1344E-06, 0.1199E-06, & + 0.1066E-06, 0.9516E-07, 0.8858E-07, 0.8219E-07, 0.7598E-07, & + 0.6992E-07, 0.6403E-07, 0.5887E-07, 0.5712E-07, 0.5540E-07, & + 0.5370E-07, 0.5214E-07, 0.5069E-07, 0.4926E-07, 0.4785E-07, & + 0.4713E-07, 0.4694E-07, 0.4676E-07, 0.4658E-07, 0.4641E-07, & + 0.4634E-07, 0.4627E-07, 0.4619E-07, 0.4612E-07, 0.4605E-07/ + + +!-------------------------------------------------------------------------------- +! data set 3 +! sub-arctic summer (75 levels) : p(mb) o3(g/g) +! surface temp = 287.0 +! + data (pres(i,3),i=1,np)/ & + 0.0006244, 0.0008759, 0.0012286, 0.0017234, 0.0024174, & + 0.0033909, 0.0047565, 0.0066720, 0.0093589, 0.0131278, & + 0.0184145, 0.0258302, 0.0362323, 0.0508234, 0.0712906, & + 0.1000000, 0.1402710, 0.1967600, 0.2759970, 0.3871430, & + 0.5430, 0.7617, 1.0685, 1.4988, 2.1024, 2.9490, & + 4.1366, 5.8025, 8.1392, 11.4170, 16.0147, 22.4640, & + 31.5105, 44.2001, 62.0000, 85.7000, 109.4000, 133.1000, & + 156.8000, 180.5000, 204.2000, 227.9000, 251.6000, 275.3000, & + 299.0000, 322.7000, 346.4000, 370.1000, 393.8000, 417.5000, & + 441.2000, 464.9000, 488.6000, 512.3000, 536.0000, 559.7000, & + 583.4000, 607.1000, 630.8000, 654.5000, 678.2000, 701.9000, & + 725.6000, 749.3000, 773.0000, 796.7000, 820.4000, 844.1000, & + 867.8000, 891.5000, 915.2000, 938.9000, 962.6000, 986.3000, & + 1010.0000/ +! + data (ozone(i,3),i=1,np)/ & + 0.1728E-06, 0.2131E-06, 0.2537E-06, 0.2944E-06, 0.3353E-06, & + 0.3764E-06, 0.4176E-06, 0.4590E-06, 0.5006E-06, 0.5423E-06, & + 0.5842E-06, 0.6263E-06, 0.6685E-06, 0.7112E-06, 0.7631E-06, & + 0.1040E-05, 0.1340E-05, 0.1660E-05, 0.2001E-05, 0.2362E-05, & + 0.2746E-05, 0.3153E-05, 0.3762E-05, 0.4988E-05, 0.6518E-05, & + 0.8352E-05, 0.9328E-05, 0.9731E-05, 0.8985E-05, 0.7632E-05, & + 0.6814E-05, 0.6384E-05, 0.5718E-05, 0.4728E-05, 0.4136E-05, & + 0.3033E-05, 0.2000E-05, 0.1486E-05, 0.1121E-05, 0.8680E-06, & + 0.6474E-06, 0.5164E-06, 0.3921E-06, 0.2996E-06, 0.2562E-06, & + 0.2139E-06, 0.1723E-06, 0.1460E-06, 0.1360E-06, 0.1267E-06, & + 0.1189E-06, 0.1114E-06, 0.1040E-06, 0.9678E-07, 0.8969E-07, & + 0.8468E-07, 0.8025E-07, 0.7590E-07, 0.7250E-07, 0.6969E-07, & + 0.6694E-07, 0.6429E-07, 0.6208E-07, 0.5991E-07, 0.5778E-07, & + 0.5575E-07, 0.5403E-07, 0.5233E-07, 0.5067E-07, 0.4904E-07, & + 0.4721E-07, 0.4535E-07, 0.4353E-07, 0.4173E-07, 0.3997E-07/ + + +!-------------------------------------------------------------------------------- +! data set 3 +! sub-arctic winter (75 levels) : p(mb) o3(g/g) +! surface temp = 257.1 +! + data (pres(i,4),i=1,np)/ & + 0.0006244, 0.0008759, 0.0012286, 0.0017234, 0.0024174, & + 0.0033909, 0.0047565, 0.0066720, 0.0093589, 0.0131278, & + 0.0184145, 0.0258302, 0.0362323, 0.0508234, 0.0712906, & + 0.1000000, 0.1402710, 0.1967600, 0.2759970, 0.3871430, & + 0.5430, 0.7617, 1.0685, 1.4988, 2.1024, 2.9490, & + 4.1366, 5.8025, 8.1392, 11.4170, 16.0147, 22.4640, & + 31.5105, 44.2001, 62.0000, 85.7750, 109.5500, 133.3250, & + 157.1000, 180.8750, 204.6500, 228.4250, 252.2000, 275.9750, & + 299.7500, 323.5250, 347.3000, 371.0750, 394.8500, 418.6250, & + 442.4000, 466.1750, 489.9500, 513.7250, 537.5000, 561.2750, & + 585.0500, 608.8250, 632.6000, 656.3750, 680.1500, 703.9250, & + 727.7000, 751.4750, 775.2500, 799.0250, 822.8000, 846.5750, & + 870.3500, 894.1250, 917.9000, 941.6750, 965.4500, 989.2250, & + 1013.0000/ +! + data (ozone(i,4),i=1,np)/ & + 0.2683E-06, 0.3562E-06, 0.4464E-06, 0.5387E-06, 0.6333E-06, & + 0.7301E-06, 0.8291E-06, 0.9306E-06, 0.1034E-05, 0.1140E-05, & + 0.1249E-05, 0.1360E-05, 0.1474E-05, 0.1855E-05, 0.2357E-05, & + 0.2866E-05, 0.3383E-05, 0.3906E-05, 0.4437E-05, 0.4975E-05, & + 0.5513E-05, 0.6815E-05, 0.8157E-05, 0.1008E-04, 0.1200E-04, & + 0.1242E-04, 0.1250E-04, 0.1157E-04, 0.1010E-04, 0.9063E-05, & + 0.8836E-05, 0.8632E-05, 0.8391E-05, 0.7224E-05, 0.6054E-05, & + 0.4503E-05, 0.3204E-05, 0.2278E-05, 0.1833E-05, 0.1433E-05, & + 0.9996E-06, 0.7440E-06, 0.5471E-06, 0.3944E-06, 0.2852E-06, & + 0.1977E-06, 0.1559E-06, 0.1333E-06, 0.1126E-06, 0.9441E-07, & + 0.7678E-07, 0.7054E-07, 0.6684E-07, 0.6323E-07, 0.6028E-07, & + 0.5746E-07, 0.5468E-07, 0.5227E-07, 0.5006E-07, 0.4789E-07, & + 0.4576E-07, 0.4402E-07, 0.4230E-07, 0.4062E-07, 0.3897E-07, & + 0.3793E-07, 0.3697E-07, 0.3602E-07, 0.3506E-07, 0.3413E-07, & + 0.3326E-07, 0.3239E-07, 0.3153E-07, 0.3069E-07, 0.2987E-07/ + +!-------------------------------------------------------------------------------- +! data set 4 +! tropical (75 levels) : p(mb) o3(g/g) +! surface temp = 300.0 +! + data (pres(i,5),i=1,np)/ & + 0.0006244, 0.0008759, 0.0012286, 0.0017234, 0.0024174, & + 0.0033909, 0.0047565, 0.0066720, 0.0093589, 0.0131278, & + 0.0184145, 0.0258302, 0.0362323, 0.0508234, 0.0712906, & + 0.1000000, 0.1402710, 0.1967600, 0.2759970, 0.3871430, & + 0.5430, 0.7617, 1.0685, 1.4988, 2.1024, 2.9490, & + 4.1366, 5.8025, 8.1392, 11.4170, 16.0147, 22.4640, & + 31.5105, 44.2001, 62.0000, 85.7750, 109.5500, 133.3250, & + 157.1000, 180.8750, 204.6500, 228.4250, 252.2000, 275.9750, & + 299.7500, 323.5250, 347.3000, 371.0750, 394.8500, 418.6250, & + 442.4000, 466.1750, 489.9500, 513.7250, 537.5000, 561.2750, & + 585.0500, 608.8250, 632.6000, 656.3750, 680.1500, 703.9250, & + 727.7000, 751.4750, 775.2500, 799.0250, 822.8000, 846.5750, & + 870.3500, 894.1250, 917.9000, 941.6750, 965.4500, 989.2250, & + 1013.0000/ +! + data (ozone(i,5),i=1,np)/ & + 0.1993E-06, 0.2521E-06, 0.3051E-06, 0.3585E-06, 0.4121E-06, & + 0.4661E-06, 0.5203E-06, 0.5748E-06, 0.6296E-06, 0.6847E-06, & + 0.7402E-06, 0.7959E-06, 0.8519E-06, 0.9096E-06, 0.1125E-05, & + 0.1450E-05, 0.1794E-05, 0.2156E-05, 0.2538E-05, 0.2939E-05, & + 0.3362E-05, 0.3785E-05, 0.4753E-05, 0.6005E-05, 0.7804E-05, & + 0.9635E-05, 0.1023E-04, 0.1067E-04, 0.1177E-04, 0.1290E-04, & + 0.1134E-04, 0.9223E-05, 0.6667E-05, 0.3644E-05, 0.1545E-05, & + 0.5355E-06, 0.2523E-06, 0.2062E-06, 0.1734E-06, 0.1548E-06, & + 0.1360E-06, 0.1204E-06, 0.1074E-06, 0.9707E-07, 0.8960E-07, & + 0.8419E-07, 0.7962E-07, 0.7542E-07, 0.7290E-07, 0.7109E-07, & + 0.6940E-07, 0.6786E-07, 0.6635E-07, 0.6500E-07, 0.6370E-07, & + 0.6244E-07, 0.6132E-07, 0.6022E-07, 0.5914E-07, 0.5884E-07, & + 0.5855E-07, 0.5823E-07, 0.5772E-07, 0.5703E-07, 0.5635E-07, & + 0.5570E-07, 0.5492E-07, 0.5412E-07, 0.5335E-07, 0.5260E-07, & + 0.5167E-07, 0.5063E-07, 0.4961E-07, 0.4860E-07, 0.4761E-07/ + +!-------------------------------------------------------------------------------- + +#ifdef WRF_CHEM + IF ( aer_ra_feedback == 1) then + IF ( .NOT. & + ( PRESENT(tauaer300) .AND. & + PRESENT(tauaer400) .AND. & + PRESENT(tauaer600) .AND. & + PRESENT(tauaer999) .AND. & + PRESENT(gaer300) .AND. & + PRESENT(gaer400) .AND. & + PRESENT(gaer600) .AND. & + PRESENT(gaer999) .AND. & + PRESENT(waer300) .AND. & + PRESENT(waer400) .AND. & + PRESENT(waer600) .AND. & + PRESENT(waer999) ) ) THEN + CALL wrf_error_fatal ( 'Warning: missing fields required for aerosol radiation' ) + ENDIF + ENDIF +#endif + cldwater = .true. + overcast = .false. + + mix=ite-its+1 + mkx=kte-kts+1 + + is_summer=80 + ie_summer=265 + +! testing, need to change iprof, which is function of lat and julian day +! iprof = 1 : mid-latitude summer profile +! = 2 : mid-latitude winter profile +! = 3 : sub-arctic summer profile +! = 4 : sub-arctic winter profile +! = 5 : tropical profile + + IF (abs(center_lat) .le. 30. ) THEN ! tropic + iprof = 5 + ELSE + IF (center_lat .gt. 0.) THEN + IF (center_lat .gt. 60. ) THEN ! arctic + IF (JULDAY .gt. is_summer .and. JULDAY .lt. ie_summer ) THEN + ! arctic summer + iprof = 3 + ELSE + ! arctic winter + iprof = 4 + ENDIF + ELSE ! midlatitude + IF (JULDAY .gt. is_summer .and. JULDAY .lt. ie_summer ) THEN + ! north midlatitude summer + iprof = 1 + ELSE + ! north midlatitude winter + iprof = 2 + ENDIF + ENDIF + + ELSE + IF (center_lat .lt. -60. ) THEN ! antarctic + IF (JULDAY .lt. is_summer .or. JULDAY .gt. ie_summer ) THEN + ! antarctic summer + iprof = 3 + ELSE + ! antarctic winter + iprof = 4 + ENDIF + ELSE ! midlatitude + IF (JULDAY .lt. is_summer .or. JULDAY .gt. ie_summer ) THEN + ! south midlatitude summer + iprof = 1 + ELSE + ! south midlatitude winter + iprof = 2 + ENDIF + ENDIF + + ENDIF + ENDIF + + + j_loop: DO J=jts,jte + + DO K=kts,kte + DO I=its,ite + cwc(i,k,1) = 0. + cwc(i,k,2) = 0. + ENDDO + ENDDO + + DO K=1,np + p(k)=pres(k,iprof) + ENDDO + + do k = kts,kte+1 + do i = its,ite + if(k.eq.kts)then + phyd(i,k)=p8w3d(i,kts,j) + else + phyd(i,k)=phyd(i,k-1) - g*rho_phy(i,k-1,j)*dz8w(i,k-1,j) + phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k)) + endif + enddo + enddo + +! reverse vars +! + DO K=kts,kte+1 + DO I=its,ite + NK=kme-K+kms + P8W2D(I,K)=phyd(I,NK)*0.01 ! P8w2D is in mb + ENDDO + ENDDO + + DO I=its,ite + P8W2D(I,0)=.0 + ENDDO +! + DO K=kts,kte + DO I=its,ite + NK=kme-1-K+kms + TTEN2D(I,K)=0. + T2D(I,K)=T3D(I,NK,J) + +! SH2D specific humidity + SH2D(I,K)=QV3D(I,NK,J)/(1.+QV3D(I,NK,J)) + SH2D(I,K)=max(0.,SH2D(I,K)) + cwc(I,K,2)=QC3D(I,NK,J) + cwc(I,K,2)=max(0.,cwc(I,K,2)) + + P2D(I,K)=phydmid(I,NK)*0.01 ! P2D is in mb + fcld2D(I,K)=CLDFRA3D(I,NK,J) + ENDDO + ENDDO + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + + IF (.NOT. warm_rain .AND. .NOT. predicate ) THEN + DO K=kts,kte + DO I=its,ite + IF (T2D(I,K) .lt. 273.15) THEN + cwc(I,K,1)=cwc(I,K,2) + cwc(I,K,2)=0. + ENDIF + ENDDO + ENDDO + ENDIF + + IF ( PRESENT( F_QNDROP ) ) THEN + IF ( F_QNDROP ) THEN + DO K=kts,kte + DO I=its,ite + NK=kme-1-K+kms + qndrop2d(I,K)=qndrop3d(I,NK,j) + ENDDO + ENDDO + qndrop2d(:,kts-1)=0. + END IF + END IF + + DO I=its,ite + TTEN2D(I,0)=0. + T2D(I,0)=T2D(I,1) +! SH2D specific humidity + SH2D(I,0)=0.5*SH2D(i,1) + cwc(I,0,2)=0. + cwc(I,0,1)=0. + P2D(I,0)=0.5*(P8W2D(I,0)+P8W2D(I,1)) + fcld2D(I,0)=0. + ENDDO +! + IF ( PRESENT( F_QI ) .AND. PRESENT( qi3d) ) THEN + IF ( (F_QI) ) THEN + DO K=kts,kte + DO I=its,ite + NK=kme-1-K+kms + cwc(I,K,1)=QI3D(I,NK,J) + cwc(I,K,1)=max(0.,cwc(I,K,1)) + ENDDO + ENDDO + ENDIF + ENDIF +! +! ... Vertical profiles for ozone +! + call o3prof (np, p, ozone(1,iprof), its, ite, kts-1, kte, P2D, O3) + +! ... Vertical profiles for effective particle size +! + pi = 4.*atan(1.0) + third=1./3. + rhoh2o=1.e3 + relconst=3/(4.*pi*rhoh2o) +! minimun liquid water path to calculate rel +! corresponds to optical depth of 1.e-3 for radius 4 microns. + lwpmin=3.e-5 + do k = kts-1, kte + do i = its, ite + reff(i,k,2) = 10. + if( PRESENT( F_QNDROP ) ) then + if( F_QNDROP ) then + if ( cwc(i,k,2)*(P8W2D(I,K+1)-P8W2D(I,K)).gt.lwpmin.and. & + qndrop2d(i,k).gt.1000. ) then + reff(i,k,2)=(relconst*cwc(i,k,2)/qndrop2d(i,k))**third ! effective radius in m +! apply scaling from Martin et al., JAS 51, 1830. + reff(i,k,2)=1.1*reff(i,k,2) + reff(i,k,2)=reff(i,k,2)*1.e6 ! convert from m to microns + reff(i,k,2)=max(reff(i,k,2),4.) + reff(i,k,2)=min(reff(i,k,2),20.) + end if + end if + end if + reff(i,k,1) = 80. + end do + end do +! +! ... Level indices separating high, middle and low clouds +! + do i = its, ite + p400(i) = 1.e5 + p700(i) = 1.e5 + enddo + + do k = kts-1,kte+1 + do i = its, ite + if (abs(P8W2D(i,k) - 400.) .lt. p400(i)) then + p400(i) = abs(P8W2D(i,k) - 400.) + ict(i) = k + endif + if (abs(P8W2D(i,k) - 700.) .lt. p700(i)) then + p700(i) = abs(P8W2D(i,k) - 700.) + icb(i) = k + endif + end do + end do + +!wig beg +! ... Aerosol effects. Added aerosol feedbacks with MOSAIC, Dec. 2005. +! + do ib = 1, 11 + do k = kts-1,kte + do i = its,ite + taual(i,k,ib) = 0. + ssaal(i,k,ib) = 0. + asyal(i,k,ib) = 0. + end do + end do + end do + +#ifdef WRF_CHEM + IF ( AER_RA_FEEDBACK == 1) then +!wig end + do ib = 1, 11 + do k = kts-1,kte-1 !wig + do i = its,ite + +! taual(i,kte-k,ib) = 0. +! ssaal(i,kte-k,ib) = 0. +! asyal(i,kte-k,ib) = 0. + +!jcb beg +! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths +! these are: 200,235,270,287.5,302.5,305,362.5,550,1920,1745,6135; why the emphasis on the UV? +! taual - use angstrom exponent + if(tauaer300(i,k+1,j).gt.thresh .and. tauaer999(i,k+1,j).gt.thresh) then + ang=log(tauaer300(i,k+1,j)/tauaer999(i,k+1,j))/log(999./300.) +! write(6,*)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j) + taual(i,kte-k,ib)=tauaer400(i,k+1,j)*(0.4/midbands(ib))**ang ! notice reserved variable +! write(6,10001)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j),midbands(ib),taual(i,k,ib) +!10001 format(i3,i3,5f12.6) + +! ssa - linear interpolation; extrapolation + slope=(waer600(i,k+1,j)-waer400(i,k+1,j))/.2 + ssaal(i,kte-k,ib) = slope*(midbands(ib)-.6)+waer600(i,k+1,j) ! notice reversed variables + if(ssaal(i,kte-k,ib).lt.0.4) ssaal(i,kte-k,ib)=0.4 + if(ssaal(i,kte-k,ib).ge.1.0) ssaal(i,kte-k,ib)=1.0 + +! g - linear interpolation;extrapolation + slope=(gaer600(i,k+1,j)-gaer400(i,k+1,j))/.2 + asyal(i,kte-k,ib) = slope*(midbands(ib)-.6)+gaer600(i,k+1,j) ! notice reversed varaibles + if(asyal(i,kte-k,ib).lt.0.5) asyal(i,kte-k,ib)=0.5 + if(asyal(i,kte-k,ib).ge.1.0) asyal(i,kte-k,ib)=1.0 + endif +!jcb end + end do + end do + end do + +!wig beg + do ib = 1, 11 + do i = its,ite + slope = 0. !use slope as a sum holder + do k = kts-1,kte + slope = slope + taual(i,k,ib) + end do + if( slope < 0. ) then + write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,ib=",3i5)') slope,i,j,ib + call wrf_error_fatal(msg) + else if( slope > 5. ) then + call wrf_message("-------------------------") + write(msg,'("WARNING: Large total optical depth of ",f8.2," at point i,j,ib=",3i5)') slope,i,j,ib + call wrf_message(msg) + + call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999") + do k=kts,kte + write(msg,'(i4,4f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), & + tauaer600(i,k,j), tauaer999(i,k,j) + call wrf_message(msg) + end do + + call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999") + do k=kts,kte + write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), & + gaer600(i,k,j), gaer999(i,k,j) + call wrf_message(msg) + end do + + call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999") + do k=kts,kte + write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), & + waer600(i,k,j), waer999(i,k,j) + call wrf_message(msg) + end do + + call wrf_message("Diagnostics 4: k, ssaal, asyal, taual") + do k=kts-1,kte + write(msg,'(i4,3f8.2)') k, ssaal(i,k,ib), asyal(i,k,ib), taual(i,k,ib) + call wrf_message(msg) + end do + call wrf_message("-------------------------") + end if + end do + end do +!wig end + endif +#endif +! +! ... Initialize output arrays +! + do ib = 1, 2 + do k = kts-1, kte + do i = its, ite + taucld(i,k,ib) = 0. + end do + end do + end do +! + do k = kts-1,kte+1 + do i = its,ite + flx(i,k) = 0. + flxd(i,k) = 0. + end do + end do +! +! ... Solar zenith angle +! + do i = its,ite + xt24 = mod(xtime + radfrq * 0.5, 1440.) + tloctm = GMT + xt24 / 60. + XLONG(i,j) / 15. + hrang = 15. * (tloctm - 12.) * degrad + xxlat = XLAT(i,j) * degrad + cosz(i) = sin(xxlat) * sin(declin) + & + cos(xxlat) * cos(declin) * cos(hrang) +!urban + if(present(COSZ_URB2D)) COSZ_URB2D(i,j)=cosz(i) !urban + if(present(OMG_URB2D)) OMG_URB2D(i,j)=hrang !urban + rsuvbm(i) = ALB(i,j) + rsuvdf(i) = ALB(i,j) + rsirbm(i) = ALB(i,j) + rsirdf(i) = ALB(i,j) + end do + + call sorad (mix,1,1,mkx+1,p8w2D,t2D,sh2D,o3, & + overcast,cldwater,cwc,taucld,reff,fcld2D,ict,icb,& + taual,ssaal,asyal, & + cosz,rsuvbm,rsuvdf,rsirbm,rsirdf, & + flx,flxd) +! +! ... Convert the units of flx and flc from fraction to w/m^2 +! + do k = kts, kte + do i = its, ite + nk=kme-1-k+kms + if(present(taucldc)) taucldc(i,nk,j)=taucld(i,k,2) + if(present(taucldi)) taucldi(i,nk,j)=taucld(i,k,1) + enddo + enddo + + do k = kts, kte+1 + do i = its, ite + if (cosz(i) .lt. thresh) then + flx(i,k) = 0. + else + flx(i,k) = flx(i,k) * SOLCON * cosz(i) + endif + end do + end do +! +! ... Calculate heating rate (deg/sec) +! + fac = .01 * g / Cp + do k = kts, kte + do i = its, ite + if (cosz(i) .gt. thresh) then + TTEN2D(i,k) = - fac * (flx(i,k) - flx(i,k+1))/ & + (p8w2d(i,k)-p8w2d(i,k+1)) + endif + end do + end do + +! upward top of atmosphere + do i = its, ite + if (cosz(i) .le. thresh) then + RSWTOA(i,j) = 0. + else + RSWTOA(i,j) = flx(i,kts) - flxd(i,kts) * SOLCON * cosz(i) +! print *,'cosz,rswtoa=',cosz(i),rswtoa(i,j) + endif + end do +! +! ... Absorbed part in surface energy budget +! + do i = its, ite + if (cosz(i) .le. thresh) then + GSW(i,j) = 0. + else + GSW(i,j) = (1. - rsuvbm(i)) * flxd(i,kte+1) * SOLCON * cosz(i) + endif + end do + + DO K=kts,kte + NK=kme-1-K+kms + DO I=its,ite + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN2D(I,NK)/pi3D(I,K,J) + ENDDO + ENDDO +! + ENDDO j_loop + + END SUBROUTINE GSFCSWRAD + +!********************* Version Solar-6 (May 8, 1997) ***************** + + subroutine sorad (m,n,ndim,np,pl,ta,wa,oa, & + overcast,cldwater,cwc,taucld,reff,fcld,ict,icb, & + taual,ssaal,asyal, & + cosz,rsuvbm,rsuvdf,rsirbm,rsirdf, & + flx,flxd) + +!************************************************************************ +! +! Version Solar-6 (May 8, 1997) +! +! New feature of this version is: +! (1) An option is added for scaling the cloud optical thickness. If +! the fractional cloud cover, fcld, in an atmospheric model is alway +! either 1 or 0 (i.e. partly cloudy sky is not allowed), it does +! not require the scaling of cloud optical thickness, and the +! option "overcast" can be set to .true. Computation is faster +! with this option than with overcast=.false. +! +!********************************************************************** +! +! Version Solar-5 (April 1997) +! +! New features of this version are: +! (1) Cloud optical properties can be computed from cloud water/ice +! amount and the effective particle size. +! (2) Aerosol optical properties are functions of height and band. +! (3) A maximum-random cloud overlapping approximation is applied. +! +!********************************************************************* +! +! This routine computes solar fluxes due to the absoption by water +! vapor, ozone, co2, o2, clouds, and aerosols and due to the +! scattering by clouds, aerosols, and gases. +! +! The solar spectrum is divided into one UV+visible band and three IR +! bands separated by the wavelength 0.7 micron. The UV+visible band +! is further divided into eight sub-bands. +! +! This is a vectorized code. It computes fluxes simultaneously for +! (m x n) soundings, which is a subset of (m x ndim) soundings. +! In a global climate model, m and ndim correspond to the numbers of +! grid boxes in the zonal and meridional directions, respectively. +! +! Ice and liquid cloud particles are allowed to co-exist in a layer. +! +! There is an option of providing either cloud ice/water mixing ratio +! (cwc) or thickness (taucld). If the former is provided, set +! cldwater=.true., and taucld will be computed from cwc and reff as a +! function of spectra band. Otherwise, set cldwater=.false., and +! specify taucld, independent of spectral band. +! +! If no information is available for reff, a default value of +! 10 micron for liquid water and 75 micron for ice can be used. +! For a clear layer, reff can be set to any values except zero. +! +! The maximum-random assumption is applied for treating cloud +! overlapping. + +! Clouds are grouped into high, middle, and low clouds separated by +! the level indices ict and icb. For detail, see subroutine cldscale. +! +! In a high spatial-resolution atmospheric model, fractional cloud cover +! might be computed to be either 0 or 1. In such a case, scaling of the +! cloud optical thickness is not necessary, and the computation can be +! made faster by setting overcast=.true. The option overcast=.false. +! can be applied to any values of the fractional cloud cover, but the +! computation is slower. +! +! Aerosol optical thickness, single-scattering albaedo, and asymmtry +! factor can be specified as functions of height and spectral band. +! +!----- Input parameters: +! units size +! number of soundings in zonal direction (m) n/d 1 +! number of soundings in meridional direction (n) n/d 1 +! maximum number of soundings in n/d 1 +! meridional direction (ndim>=n) +! number of atmospheric layers (np) n/d 1 +! level pressure (pl) mb m*ndim*(np+1) +! layer temperature (ta) k m*ndim*np +! layer specific humidity (wa) gm/gm m*ndim*np +! layer ozone concentration (oa) gm/gm m*ndim*np +! co2 mixing ratio by volumn (co2) pppv 1 +! option for scaling cloud optical thickness n/d 1 +! overcast="true" if scaling is NOT required +! overcast="fasle" if scaling is required +! option for cloud optical thickness n/d 1 +! cldwater="true" if cwc is provided +! cldwater="false" if taucld is provided +! cloud water mixing ratio (cwc) gm/gm m*ndim*np*2 +! index 1 for ice particles +! index 2 for liquid drops +! cloud optical thickness (taucld) n/d m*ndim*np*2 +! index 1 for ice particles +! index 2 for liquid drops +! effective cloud-particle size (reff) micrometer m*ndim*np*2 +! index 1 for ice particles +! index 2 for liquid drops +! cloud amount (fcld) fraction m*ndim*np +! level index separating high and middle n/d 1 +! clouds (ict) +! level index separating middle and low n/d 1 +! clouds (icb) +! aerosol optical thickness (taual) n/d m*ndim*np*11 +! aerosol single-scattering albedo (ssaal) n/d m*ndim*np*11 +! aerosol asymmetry factor (asyal) n/d m*ndim*np*11 +! in the uv region : +! index 1 for the 0.175-0.225 micron band +! index 2 for the 0.225-0.245; 0.260-0.280 micron band +! index 3 for the 0.245-0.260 micron band +! index 4 for the 0.280-0.295 micron band +! index 5 for the 0.295-0.310 micron band +! index 6 for the 0.310-0.320 micron band +! index 7 for the 0.325-0.400 micron band +! in the par region : +! index 8 for the 0.400-0.700 micron band +! in the infrared region : +! index 9 for the 0.700-1.220 micron band +! index 10 for the 1.220-2.270 micron band +! index 11 for the 2.270-10.00 micron band +! cosine of solar zenith angle (cosz) n/d m*ndim +! uv+visible sfc albedo for beam radiation +! for wavelengths<0.7 micron (rsuvbm) fraction m*ndim +! uv+visible sfc albedo for diffuse radiation +! for wavelengths<0.7 micron (rsuvdf) fraction m*ndim +! ir sfc albedo for beam radiation +! for wavelengths>0.7 micron (rsirbm) fraction m*ndim +! ir sfc albedo for diffuse radiation (rsirdf) fraction m*ndim +! +!----- Output parameters +! +! all-sky flux (downward minus upward) (flx) fraction m*ndim*(np+1) +! clear-sky flux (downward minus upward) (flc) fraction m*ndim*(np+1) +! all-sky direct downward uv (0.175-0.4 micron) +! flux at the surface (fdiruv) fraction m*ndim +! all-sky diffuse downward uv flux at +! the surface (fdifuv) fraction m*ndim +! all-sky direct downward par (0.4-0.7 micron) +! flux at the surface (fdirpar) fraction m*ndim +! all-sky diffuse downward par flux at +! the surface (fdifpar) fraction m*ndim +! all-sky direct downward ir (0.7-10 micron) +! flux at the surface (fdirir) fraction m*ndim +! all-sky diffuse downward ir flux at +! the surface (fdifir) fraction m*ndim +! +!----- Notes: +! +! (1) The unit of "flux" is fraction of the incoming solar radiation +! at the top of the atmosphere. Therefore, fluxes should +! be equal to "flux" multiplied by the extra-terrestrial solar +! flux and the cosine of solar zenith angle. +! (2) pl(i,j,1) is the pressure at the top of the model, and +! pl(i,j,np+1) is the surface pressure. +! (3) the pressure levels ict and icb correspond approximately +! to 400 and 700 mb. +! (4) if overcast='true', the clear-sky flux, flc, is not computed. +! +!************************************************************************** + implicit none +!************************************************************************** + +!-----input parameters + + integer m,n,ndim,np + integer ict(m,ndim),icb(m,ndim) + real pl(m,ndim,np+1),ta(m,ndim,np),wa(m,ndim,np),oa(m,ndim,np) + real cwc(m,ndim,np,2),taucld(m,ndim,np,2),reff(m,ndim,np,2), & + fcld(m,ndim,np) + real taual(m,ndim,np,11),ssaal(m,ndim,np,11),asyal(m,ndim,np,11) + real cosz(m,ndim),rsuvbm(m,ndim),rsuvdf(m,ndim), & + rsirbm(m,ndim),rsirdf(m,ndim) + logical overcast,cldwater + +!-----output parameters + + real flx(m,ndim,np+1),flc(m,ndim,np+1) + real flxu(m,ndim,np+1),flxd(m,ndim,np+1) + real fdiruv (m,ndim),fdifuv (m,ndim) + real fdirpar(m,ndim),fdifpar(m,ndim) + real fdirir (m,ndim),fdifir (m,ndim) + +!-----temporary array + + integer i,j,k + real cwp(m,n,np,2) + real dp(m,n,np),wh(m,n,np),oh(m,n,np),scal(m,n,np) + real swh(m,n,np+1),so2(m,n,np+1),df(m,n,np+1) + real sdf(m,n),sclr(m,n),csm(m,n),x + + do j= 1, n + do i= 1, m + if (pl(i,j,1) .eq. 0.0) then + pl(i,j,1)=1.0e-4 + endif + enddo + enddo + + do j= 1, n + do i= 1, m + + swh(i,j,1)=0. + so2(i,j,1)=0. + +!-----csm is the effective secant of the solar zenith angle +! see equation (12) of Lacis and Hansen (1974, JAS) + + csm(i,j)=35./sqrt(1224.*cosz(i,j)*cosz(i,j)+1.) + + enddo + enddo + + do k= 1, np + do j= 1, n + do i= 1, m + +!-----compute layer thickness and pressure-scaling function. +! indices for the surface level and surface layer +! are np+1 and np, respectively. + + dp(i,j,k)=pl(i,j,k+1)-pl(i,j,k) + scal(i,j,k)=dp(i,j,k)*(.5*(pl(i,j,k)+pl(i,j,k+1))/300.)**.8 + +!-----compute scaled water vapor amount, unit is g/cm**2 +! note: the sign prior to the constant 0.00135 was incorrectly +! set to negative in the previous version + + wh(i,j,k)=1.02*wa(i,j,k)*scal(i,j,k)* & + (1.+0.00135*(ta(i,j,k)-240.)) +1.e-11 + swh(i,j,k+1)=swh(i,j,k)+wh(i,j,k) + +!-----compute ozone amount, unit is (cm-atm)stp +! the number 466.7 is a conversion factor from g/cm**2 to (cm-atm)stp + + oh(i,j,k)=1.02*oa(i,j,k)*dp(i,j,k)*466.7 +1.e-11 + +!-----compute layer cloud water amount (gm/m**2) +! the index is 1 for ice crystals and 2 for liquid drops + + cwp(i,j,k,1)=1.02*10000.*cwc(i,j,k,1)*dp(i,j,k) + cwp(i,j,k,2)=1.02*10000.*cwc(i,j,k,2)*dp(i,j,k) + + enddo + enddo + enddo + +!-----initialize fluxes for all-sky (flx), clear-sky (flc), and +! flux reduction (df) + + do k=1, np+1 + do j=1, n + do i=1, m + flx(i,j,k)=0. + flc(i,j,k)=0. + flxu(i,j,k)=0. + flxd(i,j,k)=0. + df(i,j,k)=0. + enddo + enddo + enddo + +!-----compute solar uv and par fluxes + + call soluv (m,n,ndim,np,oh,dp,overcast,cldwater, & + cwp,taucld,reff,ict,icb,fcld,cosz, & + taual,ssaal,asyal,csm,rsuvbm,rsuvdf, & + flx,flc,flxu,flxd,fdiruv,fdifuv,fdirpar,fdifpar) + +!-----compute and update solar ir fluxes + + call solir (m,n,ndim,np,wh,overcast,cldwater, & + cwp,taucld,reff,ict,icb,fcld,cosz, & + taual,ssaal,asyal,csm,rsirbm,rsirdf, & + flx,flc,flxu,flxd,fdirir,fdifir) + +!-----compute scaled o2 amount, unit is (cm-atm)stp. + + do k= 1, np + do j= 1, n + do i= 1, m + so2(i,j,k+1)=so2(i,j,k)+165.22*scal(i,j,k) + enddo + enddo + enddo + +!-----compute flux reduction due to oxygen following +! chou (J. climate, 1990). The fraction 0.0287 is the +! extraterrestrial solar flux in the o2 bands. + + do k= 2, np+1 + do j= 1, n + do i= 1, m + x=so2(i,j,k)*csm(i,j) + df(i,j,k)=df(i,j,k)+0.0287*(1.-exp(-0.00027*sqrt(x))) + enddo + enddo + enddo + +!-----compute scaled co2 amounts. unit is (cm-atm)stp. + + do k= 1, np + do j= 1, n + do i= 1, m + so2(i,j,k+1)=so2(i,j,k)+co2*789.*scal(i,j,k)+1.e-11 + enddo + enddo + enddo + +!-----compute and update flux reduction due to co2 following +! chou (J. Climate, 1990) + + call flxco2(m,n,np,so2,swh,csm,df) + +!-----adjust for the effect of o2 cnd co2 on clear-sky fluxes. + + do k= 2, np+1 + do j= 1, n + do i= 1, m + flc(i,j,k)=flc(i,j,k)-df(i,j,k) + enddo + enddo + enddo + +!-----adjust for the all-sky fluxes due to o2 and co2. It is +! assumed that o2 and co2 have no effects on solar radiation +! below clouds. + + do j=1,n + do i=1,m + sdf(i,j)=0.0 + sclr(i,j)=1.0 + enddo + enddo + + do k=1,np + do j=1,n + do i=1,m + +!-----sclr is the fraction of clear sky. +! sdf is the flux reduction below clouds. + + if(fcld(i,j,k).gt.0.01) then + sdf(i,j)=sdf(i,j)+df(i,j,k)*sclr(i,j)*fcld(i,j,k) + sclr(i,j)=sclr(i,j)*(1.-fcld(i,j,k)) + endif + flx(i,j,k+1)=flx(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j) + flxu(i,j,k+1)=flxu(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j) + flxd(i,j,k+1)=flxd(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j) ! SG: same as flux???? + + enddo + enddo + enddo + +!-----adjustment for the direct downward ir flux. + + do j= 1, n + do i= 1, m + flc(i,j,np+1)=flc(i,j,np+1)+df(i,j,np+1)*rsirbm(i,j) + flx(i,j,np+1)=flx(i,j,np+1)+(sdf(i,j)+ & + df(i,j,np+1)*sclr(i,j))*rsirbm(i,j) + flxu(i,j,np+1)=flxu(i,j,np+1)+(sdf(i,j)+ & + df(i,j,np+1)*sclr(i,j))*rsirbm(i,j) + flxd(i,j,np+1)=flxd(i,j,np+1)+(sdf(i,j)+ & + df(i,j,np+1)*sclr(i,j))*rsirbm(i,j) + fdirir(i,j)=fdirir(i,j)-(sdf(i,j)+df(i,j,np+1)*sclr(i,j)) + enddo + enddo + + end subroutine sorad + +!************************************************************************ + + subroutine soluv (m,n,ndim,np,oh,dp,overcast,cldwater, & + cwp,taucld,reff,ict,icb,fcld,cosz, & + taual,ssaal,asyal,csm,rsuvbm,rsuvdf, & + flx,flc,flxu,flxd,fdiruv,fdifuv,fdirpar,fdifpar) + +!************************************************************************ +! compute solar fluxes in the uv+par region. the spectrum is +! grouped into 8 bands: +! +! Band Micrometer +! +! UV-C 1. .175 - .225 +! 2. .225 - .245 +! .260 - .280 +! 3. .245 - .260 +! +! UV-B 4. .280 - .295 +! 5. .295 - .310 +! 6. .310 - .320 +! +! UV-A 7. .320 - .400 +! +! PAR 8. .400 - .700 +! +!----- Input parameters: units size +! +! number of soundings in zonal direction (m) n/d 1 +! number of soundings in meridional direction (n) n/d 1 +! maximum number of soundings in n/d 1 +! meridional direction (ndim) +! number of atmospheric layers (np) n/d 1 +! layer ozone content (oh) (cm-atm)stp m*n*np +! layer pressure thickness (dp) mb m*n*np +! option for scaling cloud optical thickness n/d 1 +! overcast="true" if scaling is NOT required +! overcast="fasle" if scaling is required +! input option for cloud optical thickness n/d 1 +! cldwater="true" if taucld is provided +! cldwater="false" if cwp is provided +! cloud water amount (cwp) gm/m**2 m*n*np*2 +! index 1 for ice particles +! index 2 for liquid drops +! cloud optical thickness (taucld) n/d m*ndim*np*2 +! index 1 for ice paticles +! index 2 for liquid particles +! effective cloud-particle size (reff) micrometer m*ndim*np*2 +! index 1 for ice paticles +! index 2 for liquid particles +! level indiex separating high and n/d m*n +! middle clouds (ict) +! level indiex separating middle and n/d m*n +! low clouds (icb) +! cloud amount (fcld) fraction m*ndim*np +! cosine of solar zenith angle (cosz) n/d m*ndim +! aerosol optical thickness (taual) n/d m*ndim*np*11 +! aerosol single-scattering albedo (ssaal) n/d m*ndim*np*11 +! aerosol asymmetry factor (asyal) n/d m*ndim*np*11 +! cosecant of the solar zenith angle (csm) n/d m*n +! uv+par surface albedo for beam fraction m*ndim +! radiation (rsuvbm) +! uv+par surface albedo for diffuse fraction m*ndim +! radiation (rsuvdf) +! +!---- temporary array +! +! scaled cloud optical thickness n/d m*n*np +! for beam radiation (tauclb) +! scaled cloud optical thickness n/d m*n*np +! for diffuse radiation (tauclf) +! +!----- output (updated) parameters: +! +! all-sky net downward flux (flx) fraction m*ndim*(np+1) +! clear-sky net downward flux (flc) fraction m*ndim*(np+1) +! all-sky direct downward uv flux at +! the surface (fdiruv) fraction m*ndim +! all-sky diffuse downward uv flux at +! the surface (fdifuv) fraction m*ndim +! all-sky direct downward par flux at +! the surface (fdirpar) fraction m*ndim +! all-sky diffuse downward par flux at +! the surface (fdifpar) fraction m*ndim +! +!*********************************************************************** + implicit none +!*********************************************************************** + +!-----input parameters + + integer m,n,ndim,np + integer ict(m,ndim),icb(m,ndim) + real taucld(m,ndim,np,2),reff(m,ndim,np,2),fcld(m,ndim,np) + real cc(m,n,3),cosz(m,ndim) + real cwp(m,n,np,2),oh(m,n,np),dp(m,n,np) + real taual(m,ndim,np,11),ssaal(m,ndim,np,11),asyal(m,ndim,np,11) + real rsuvbm(m,ndim),rsuvdf(m,ndim),csm(m,n) + logical overcast,cldwater + +!-----output (updated) parameter + + real flx(m,ndim,np+1),flc(m,ndim,np+1) + real flxu(m,ndim,np+1),flxd(m,ndim,np+1) + real fdiruv (m,ndim),fdifuv (m,ndim) + real fdirpar(m,ndim),fdifpar(m,ndim) + +!-----static parameters + + integer nband + parameter (nband=8) + real hk(nband),xk(nband),ry(nband) + real aig(3),awg(3) + +!-----temporary array + + integer i,j,k,ib + real tauclb(m,n,np),tauclf(m,n,np),asycl(m,n,np) + real taurs,tauoz,tausto,ssatau,asysto,tauto,ssato,asyto + real taux,reff1,reff2,g1,g2 + real td(m,n,np+1,2),rr(m,n,np+1,2),tt(m,n,np+1,2), & + rs(m,n,np+1,2),ts(m,n,np+1,2) + real fall(m,n,np+1),fclr(m,n,np+1),fsdir(m,n),fsdif(m,n) + real fallu(m,n,np+1),falld(m,n,np+1) + real asyclt(m,n) + real rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n) + real rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n) + +!-----hk is the fractional extra-terrestrial solar flux in each +! of the 8 bands. the sum of hk is 0.47074. + + data hk/.00057, .00367, .00083, .00417, & + .00600, .00556, .05913, .39081/ + +!-----xk is the ozone absorption coefficient. unit: /(cm-atm)stp + + data xk /30.47, 187.2, 301.9, 42.83, & + 7.09, 1.25, 0.0345, 0.0539/ + +!-----ry is the extinction coefficient for Rayleigh scattering. +! unit: /mb. + + data ry /.00604, .00170, .00222, .00132, & + .00107, .00091, .00055, .00012/ + +!-----coefficients for computing the asymmetry factor of ice clouds +! from asycl=aig(*,1)+aig(*,2)*reff+aig(*,3)*reff**2, independent +! of spectral band. + + data aig/.74625000,.00105410,-.00000264/ + +!-----coefficients for computing the asymmetry factor of liquid +! clouds from asycl=awg(*,1)+awg(*,2)*reff+awg(*,3)*reff**2, +! independent of spectral band. + + data awg/.82562000,.00529000,-.00014866/ + +!-----initialize fdiruv, fdifuv, surface reflectances and transmittances. +! cc is the maximum cloud cover in each of the three cloud groups. + + do j= 1, n + do i= 1, m + fdiruv(i,j)=0.0 + fdifuv(i,j)=0.0 + rr(i,j,np+1,1)=rsuvbm(i,j) + rr(i,j,np+1,2)=rsuvbm(i,j) + rs(i,j,np+1,1)=rsuvdf(i,j) + rs(i,j,np+1,2)=rsuvdf(i,j) + td(i,j,np+1,1)=0.0 + td(i,j,np+1,2)=0.0 + tt(i,j,np+1,1)=0.0 + tt(i,j,np+1,2)=0.0 + ts(i,j,np+1,1)=0.0 + ts(i,j,np+1,2)=0.0 + cc(i,j,1)=0.0 + cc(i,j,2)=0.0 + cc(i,j,3)=0.0 + enddo + enddo + + +!-----compute cloud optical thickness + + if (cldwater) then + + do k= 1, np + do j= 1, n + do i= 1, m + taucld(i,j,k,1)=cwp(i,j,k,1)*( 3.33e-4+2.52/reff(i,j,k,1)) + taucld(i,j,k,2)=cwp(i,j,k,2)*(-6.59e-3+1.65/reff(i,j,k,2)) + enddo + enddo + enddo + + endif + +!-----options for scaling cloud optical thickness + + if (overcast) then + + do k= 1, np + do j= 1, n + do i= 1, m + tauclb(i,j,k)=taucld(i,j,k,1)+taucld(i,j,k,2) + tauclf(i,j,k)=tauclb(i,j,k) + enddo + enddo + enddo + + do k= 1, 3 + do j= 1, n + do i= 1, m + cc(i,j,k)=1.0 + enddo + enddo + enddo + + else + +!-----scale cloud optical thickness in each layer from taucld (with +! cloud amount fcld) to tauclb and tauclf (with cloud amount cc). +! tauclb is the scaled optical thickness for beam radiation and +! tauclf is for diffuse radiation. + + call cldscale(m,n,ndim,np,cosz,fcld,taucld,ict,icb, & + cc,tauclb,tauclf) + + endif + +!-----compute cloud asymmetry factor for a mixture of +! liquid and ice particles. unit of reff is micrometers. + + do k= 1, np + + do j= 1, n + do i= 1, m + + asyclt(i,j)=1.0 + + taux=taucld(i,j,k,1)+taucld(i,j,k,2) + if (taux.gt.0.05 .and. fcld(i,j,k).gt.0.01) then + + reff1=min(reff(i,j,k,1),130.) + reff2=min(reff(i,j,k,2),20.0) + + g1=(aig(1)+(aig(2)+aig(3)*reff1)*reff1)*taucld(i,j,k,1) + g2=(awg(1)+(awg(2)+awg(3)*reff2)*reff2)*taucld(i,j,k,2) + asyclt(i,j)=(g1+g2)/taux + + endif + + enddo + enddo + + do j=1,n + do i=1,m + asycl(i,j,k)=asyclt(i,j) + enddo + enddo + + enddo + +!-----integration over spectral bands + + do 100 ib=1,nband + + do 300 k= 1, np + + do j= 1, n + do i= 1, m + +!-----compute ozone and rayleigh optical thicknesses + + taurs=ry(ib)*dp(i,j,k) + tauoz=xk(ib)*oh(i,j,k) + +!-----compute clear-sky optical thickness, single scattering albedo, +! and asymmetry factor + + tausto=taurs+tauoz+taual(i,j,k,ib)+1.0e-8 + ssatau=ssaal(i,j,k,ib)*taual(i,j,k,ib)+taurs + asysto=asyal(i,j,k,ib)*ssaal(i,j,k,ib)*taual(i,j,k,ib) + + tauto=tausto + ssato=ssatau/tauto+1.0e-8 + ssato=min(ssato,0.999999) + asyto=asysto/(ssato*tauto) + +!-----compute reflectance and transmittance for cloudless layers + +!- for direct incident radiation + + call deledd (tauto,ssato,asyto,csm(i,j), & + rr1t(i,j),tt1t(i,j),td1t(i,j)) + +!- for diffuse incident radiation + + call sagpol (tauto,ssato,asyto,rs1t(i,j),ts1t(i,j)) + +!-----compute reflectance and transmittance for cloud layers + + if (tauclb(i,j,k).lt.0.01 .or. fcld(i,j,k).lt.0.01) then + + rr2t(i,j)=rr1t(i,j) + tt2t(i,j)=tt1t(i,j) + td2t(i,j)=td1t(i,j) + rs2t(i,j)=rs1t(i,j) + ts2t(i,j)=ts1t(i,j) + + else + +!-- for direct incident radiation + + tauto=tausto+tauclb(i,j,k) + ssato=(ssatau+tauclb(i,j,k))/tauto+1.0e-8 + ssato=min(ssato,0.999999) + asyto=(asysto+asycl(i,j,k)*tauclb(i,j,k))/(ssato*tauto) + + call deledd (tauto,ssato,asyto,csm(i,j), & + rr2t(i,j),tt2t(i,j),td2t(i,j)) + +!-- for diffuse incident radiation + + tauto=tausto+tauclf(i,j,k) + ssato=(ssatau+tauclf(i,j,k))/tauto+1.0e-8 + ssato=min(ssato,0.999999) + asyto=(asysto+asycl(i,j,k)*tauclf(i,j,k))/(ssato*tauto) + + call sagpol (tauto,ssato,asyto,rs2t(i,j),ts2t(i,j)) + + endif + + enddo + enddo + + do j=1,n + do i=1,m + rr(i,j,k,1)=rr1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + tt(i,j,k,1)=tt1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + td(i,j,k,1)=td1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + rs(i,j,k,1)=rs1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + ts(i,j,k,1)=ts1t(i,j) + enddo + enddo + + do j=1,n + do i=1,m + rr(i,j,k,2)=rr2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + tt(i,j,k,2)=tt2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + td(i,j,k,2)=td2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + rs(i,j,k,2)=rs2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + ts(i,j,k,2)=ts2t(i,j) + enddo + enddo + + 300 continue + +!-----flux calculations + + call cldflx (m,n,np,ict,icb,overcast,cc,rr,tt,td,rs,ts, & + fclr,fall,fallu,falld,fsdir,fsdif) + + do k= 1, np+1 + do j= 1, n + do i= 1, m + flx(i,j,k)=flx(i,j,k)+fall(i,j,k)*hk(ib) + flxu(i,j,k)=flxu(i,j,k)+fallu(i,j,k)*hk(ib) + flxd(i,j,k)=flxd(i,j,k)+falld(i,j,k)*hk(ib) + enddo + enddo + do j= 1, n + do i= 1, m + flc(i,j,k)=flc(i,j,k)+fclr(i,j,k)*hk(ib) + enddo + enddo + enddo + +!-----compute downward surface fluxes in the UV and par regions + + if(ib.lt.8) then + do j=1,n + do i=1,m + fdiruv(i,j)=fdiruv(i,j)+fsdir(i,j)*hk(ib) + fdifuv(i,j)=fdifuv(i,j)+fsdif(i,j)*hk(ib) + enddo + enddo + else + do j=1,n + do i=1,m + fdirpar(i,j)=fsdir(i,j)*hk(ib) + fdifpar(i,j)=fsdif(i,j)*hk(ib) + enddo + enddo + endif + + 100 continue + + end subroutine soluv + +!************************************************************************ + + subroutine solir (m,n,ndim,np,wh,overcast,cldwater, & + cwp,taucld,reff,ict,icb,fcld,cosz, & + taual,ssaal,asyal,csm,rsirbm,rsirdf, & + flx,flc,flxu,flxd,fdirir,fdifir) + +!************************************************************************ +! compute solar flux in the infrared region. The spectrum is divided +! into three bands: +! +! band wavenumber(/cm) wavelength (micron) +! 1( 9) 14300-8200 0.70-1.22 +! 2(10) 8200-4400 1.22-2.27 +! 3(11) 4400-1000 2.27-10.0 +! +!----- Input parameters: units size +! +! number of soundings in zonal direction (m) n/d 1 +! number of soundings in meridional direction (n) n/d 1 +! maximum number of soundings in n/d 1 +! meridional direction (ndim) +! number of atmospheric layers (np) n/d 1 +! layer scaled-water vapor content (wh) gm/cm^2 m*n*np +! option for scaling cloud optical thickness n/d 1 +! overcast="true" if scaling is NOT required +! overcast="fasle" if scaling is required +! input option for cloud optical thickness n/d 1 +! cldwater="true" if taucld is provided +! cldwater="false" if cwp is provided +! cloud water concentration (cwp) gm/m**2 m*n*np*2 +! index 1 for ice particles +! index 2 for liquid drops +! cloud optical thickness (taucld) n/d m*ndim*np*2 +! index 1 for ice paticles +! effective cloud-particle size (reff) micrometer m*ndim*np*2 +! index 1 for ice paticles +! index 2 for liquid particles +! level index separating high and n/d m*n +! middle clouds (ict) +! level index separating middle and n/d m*n +! low clouds (icb) +! cloud amount (fcld) fraction m*ndim*np +! aerosol optical thickness (taual) n/d m*ndim*np*11 +! aerosol single-scattering albedo (ssaal) n/d m*ndim*np*11 +! aerosol asymmetry factor (asyal) n/d m*ndim*np*11 +! cosecant of the solar zenith angle (csm) n/d m*n +! near ir surface albedo for beam fraction m*ndim +! radiation (rsirbm) +! near ir surface albedo for diffuse fraction m*ndim +! radiation (rsirdf) +! +!---- temporary array +! +! scaled cloud optical thickness n/d m*n*np +! for beam radiation (tauclb) +! scaled cloud optical thickness n/d m*n*np +! for diffuse radiation (tauclf) +! +!----- output (updated) parameters: +! +! all-sky flux (downward-upward) (flx) fraction m*ndim*(np+1) +! clear-sky flux (downward-upward) (flc) fraction m*ndim*(np+1) +! all-sky direct downward ir flux at +! the surface (fdirir) fraction m*ndim +! all-sky diffuse downward ir flux at +! the surface (fdifir) fraction m*ndim +! +!********************************************************************** + implicit none +!********************************************************************** + +!-----input parameters + + integer m,n,ndim,np + integer ict(m,ndim),icb(m,ndim) + real cwp(m,n,np,2),taucld(m,ndim,np,2),reff(m,ndim,np,2) + real fcld(m,ndim,np),cc(m,n,3),cosz(m,ndim) + real rsirbm(m,ndim),rsirdf(m,ndim) + real taual(m,ndim,np,11),ssaal(m,ndim,np,11),asyal(m,ndim,np,11) + real wh(m,n,np),csm(m,n) + logical overcast,cldwater + +!-----output (updated) parameters + + real flx(m,ndim,np+1),flc(m,ndim,np+1) + real flxu(m,ndim,np+1),flxd(m,ndim,np+1) + real fdirir(m,ndim),fdifir(m,ndim) + +!-----static parameters + + integer nk,nband + parameter (nk=10,nband=3) + real xk(nk),hk(nband,nk),aib(nband,2),awb(nband,2) + real aia(nband,3),awa(nband,3),aig(nband,3),awg(nband,3) + +!-----temporary array + + integer ib,iv,ik,i,j,k + real tauclb(m,n,np),tauclf(m,n,np) + real ssacl(m,n,np),asycl(m,n,np) + real rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2), & + rs(m,n,np+1,2),ts(m,n,np+1,2) + real fall(m,n,np+1),fclr(m,n,np+1) + real fallu(m,n,np+1),falld(m,n,np+1) + real fsdir(m,n),fsdif(m,n) + + real tauwv,tausto,ssatau,asysto,tauto,ssato,asyto + real taux,reff1,reff2,w1,w2,g1,g2 + real ssaclt(m,n),asyclt(m,n) + real rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n) + real rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n) + +!-----water vapor absorption coefficient for 10 k-intervals. +! unit: cm^2/gm + + data xk/ & + 0.0010, 0.0133, 0.0422, 0.1334, 0.4217, & + 1.334, 5.623, 31.62, 177.8, 1000.0/ + +!-----water vapor k-distribution function, +! the sum of hk is 0.52926. unit: fraction + + data hk/ & + .20673,.08236,.01074, .03497,.01157,.00360, & + .03011,.01133,.00411, .02260,.01143,.00421, & + .01336,.01240,.00389, .00696,.01258,.00326, & + .00441,.01381,.00499, .00115,.00650,.00465, & + .00026,.00244,.00245, .00000,.00094,.00145/ + +!-----coefficients for computing the extinction coefficient of +! ice clouds from b=aib(*,1)+aib(*,2)/reff + + data aib/ & + .000333, .000333, .000333, & + 2.52, 2.52, 2.52/ + +!-----coefficients for computing the extinction coefficient of +! water clouds from b=awb(*,1)+awb(*,2)/reff + + data awb/ & + -0.0101, -0.0166, -0.0339, & + 1.72, 1.85, 2.16/ + + +!-----coefficients for computing the single scattering albedo of +! ice clouds from ssa=1-(aia(*,1)+aia(*,2)*reff+aia(*,3)*reff**2) + + data aia/ & + -.00000260, .00215346, .08938331, & + .00000746, .00073709, .00299387, & + .00000000,-.00000134,-.00001038/ + +!-----coefficients for computing the single scattering albedo of +! liquid clouds from ssa=1-(awa(*,1)+awa(*,2)*reff+awa(*,3)*reff**2) + + data awa/ & + .00000007,-.00019934, .01209318, & + .00000845, .00088757, .01784739, & + -.00000004,-.00000650,-.00036910/ + +!-----coefficients for computing the asymmetry factor of ice clouds +! from asycl=aig(*,1)+aig(*,2)*reff+aig(*,3)*reff**2 + + data aig/ & + .74935228, .76098937, .84090400, & + .00119715, .00141864, .00126222, & + -.00000367,-.00000396,-.00000385/ + +!-----coefficients for computing the asymmetry factor of liquid clouds +! from asycl=awg(*,1)+awg(*,2)*reff+awg(*,3)*reff**2 + + data awg/ & + .79375035, .74513197, .83530748, & + .00832441, .01370071, .00257181, & + -.00023263,-.00038203, .00005519/ + +!-----initialize surface fluxes, reflectances, and transmittances. +! cc is the maximum cloud cover in each of the three cloud groups. + + do j= 1, n + do i= 1, m + fdirir(i,j)=0.0 + fdifir(i,j)=0.0 + rr(i,j,np+1,1)=rsirbm(i,j) + rr(i,j,np+1,2)=rsirbm(i,j) + rs(i,j,np+1,1)=rsirdf(i,j) + rs(i,j,np+1,2)=rsirdf(i,j) + td(i,j,np+1,1)=0.0 + td(i,j,np+1,2)=0.0 + tt(i,j,np+1,1)=0.0 + tt(i,j,np+1,2)=0.0 + ts(i,j,np+1,1)=0.0 + ts(i,j,np+1,2)=0.0 + cc(i,j,1)=0.0 + cc(i,j,2)=0.0 + cc(i,j,3)=0.0 + enddo + enddo + +!-----integration over spectral bands + + do 100 ib=1,nband + + iv=ib+8 + +!-----compute cloud optical thickness + + if (cldwater) then + + do k= 1, np + do j= 1, n + do i= 1, m + taucld(i,j,k,1)=cwp(i,j,k,1)*(aib(ib,1) & + +aib(ib,2)/reff(i,j,k,1)) + taucld(i,j,k,2)=cwp(i,j,k,2)*(awb(ib,1) & + +awb(ib,2)/reff(i,j,k,2)) + enddo + enddo + enddo + + endif + +!-----options for scaling cloud optical thickness + + if (overcast) then + + do k= 1, np + do j= 1, n + do i= 1, m + tauclb(i,j,k)=taucld(i,j,k,1)+taucld(i,j,k,2) + tauclf(i,j,k)=tauclb(i,j,k) + enddo + enddo + enddo + + do k= 1, 3 + do j= 1, n + do i= 1, m + cc(i,j,k)=1.0 + enddo + enddo + enddo + + else + +!-----scale cloud optical thickness in each layer from taucld (with +! cloud amount fcld) to tauclb and tauclf (with cloud amount cc). +! tauclb is the scaled optical thickness for beam radiation and +! tauclf is for diffuse radiation. + + call cldscale(m,n,ndim,np,cosz,fcld,taucld,ict,icb, & + cc,tauclb,tauclf) + + endif + +!-----compute cloud single scattering albedo and asymmetry factor +! for a mixture of ice and liquid particles. + + do k= 1, np + + do j= 1, n + do i= 1, m + + ssaclt(i,j)=1.0 + asyclt(i,j)=1.0 + + taux=taucld(i,j,k,1)+taucld(i,j,k,2) + if (taux.gt.0.05 .and. fcld(i,j,k).gt.0.01) then + + reff1=min(reff(i,j,k,1),130.) + reff2=min(reff(i,j,k,2),20.0) + + w1=(1.-(aia(ib,1)+(aia(ib,2)+ & + aia(ib,3)*reff1)*reff1))*taucld(i,j,k,1) + w2=(1.-(awa(ib,1)+(awa(ib,2)+ & + awa(ib,3)*reff2)*reff2))*taucld(i,j,k,2) + ssaclt(i,j)=(w1+w2)/taux + + g1=(aig(ib,1)+(aig(ib,2)+aig(ib,3)*reff1)*reff1)*w1 + g2=(awg(ib,1)+(awg(ib,2)+awg(ib,3)*reff2)*reff2)*w2 + asyclt(i,j)=(g1+g2)/(w1+w2) + + endif + + enddo + enddo + + do j=1,n + do i=1,m + ssacl(i,j,k)=ssaclt(i,j) + enddo + enddo + do j=1,n + do i=1,m + asycl(i,j,k)=asyclt(i,j) + enddo + enddo + + enddo + +!-----integration over the k-distribution function + + do 200 ik=1,nk + + do 300 k= 1, np + + do j= 1, n + do i= 1, m + + tauwv=xk(ik)*wh(i,j,k) + +!-----compute clear-sky optical thickness, single scattering albedo, +! and asymmetry factor. + + tausto=tauwv+taual(i,j,k,iv)+1.0e-8 + ssatau=ssaal(i,j,k,iv)*taual(i,j,k,iv) + asysto=asyal(i,j,k,iv)*ssaal(i,j,k,iv)*taual(i,j,k,iv) + +!-----compute reflectance and transmittance for cloudless layers + + tauto=tausto + ssato=ssatau/tauto+1.0e-8 + + if (ssato .gt. 0.001) then + + ssato=min(ssato,0.999999) + asyto=asysto/(ssato*tauto) + +!- for direct incident radiation + + call deledd (tauto,ssato,asyto,csm(i,j), & + rr1t(i,j),tt1t(i,j),td1t(i,j)) + +!- for diffuse incident radiation + + call sagpol (tauto,ssato,asyto,rs1t(i,j),ts1t(i,j)) + + else + + td1t(i,j)=exp(-tauto*csm(i,j)) + ts1t(i,j)=exp(-1.66*tauto) + tt1t(i,j)=0.0 + rr1t(i,j)=0.0 + rs1t(i,j)=0.0 + + endif + +!-----compute reflectance and transmittance for cloud layers + + if (tauclb(i,j,k).lt.0.01 .or. fcld(i,j,k).lt.0.01) then + + rr2t(i,j)=rr1t(i,j) + tt2t(i,j)=tt1t(i,j) + td2t(i,j)=td1t(i,j) + rs2t(i,j)=rs1t(i,j) + ts2t(i,j)=ts1t(i,j) + + else + +!- for direct incident radiation + + tauto=tausto+tauclb(i,j,k) + ssato=(ssatau+ssacl(i,j,k)*tauclb(i,j,k))/tauto+1.0e-8 + ssato=min(ssato,0.999999) + asyto=(asysto+asycl(i,j,k)*ssacl(i,j,k)*tauclb(i,j,k))/ & + (ssato*tauto) + + call deledd (tauto,ssato,asyto,csm(i,j), & + rr2t(i,j),tt2t(i,j),td2t(i,j)) + +!- for diffuse incident radiation + + tauto=tausto+tauclf(i,j,k) + ssato=(ssatau+ssacl(i,j,k)*tauclf(i,j,k))/tauto+1.0e-8 + ssato=min(ssato,0.999999) + asyto=(asysto+asycl(i,j,k)*ssacl(i,j,k)*tauclf(i,j,k))/ & + (ssato*tauto) + + call sagpol (tauto,ssato,asyto,rs2t(i,j),ts2t(i,j)) + + endif + + enddo + enddo + + do j=1,n + do i=1,m + rr(i,j,k,1)=rr1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + tt(i,j,k,1)=tt1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + td(i,j,k,1)=td1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + rs(i,j,k,1)=rs1t(i,j) + enddo + enddo + do j=1,n + do i=1,m + ts(i,j,k,1)=ts1t(i,j) + enddo + enddo + + do j=1,n + do i=1,m + rr(i,j,k,2)=rr2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + tt(i,j,k,2)=tt2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + td(i,j,k,2)=td2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + rs(i,j,k,2)=rs2t(i,j) + enddo + enddo + do j=1,n + do i=1,m + ts(i,j,k,2)=ts2t(i,j) + enddo + enddo + + 300 continue + +!-----flux calculations + + call cldflx (m,n,np,ict,icb,overcast,cc,rr,tt,td,rs,ts, & + fclr,fall,fallu,falld,fsdir,fsdif) + + do k= 1, np+1 + do j= 1, n + do i= 1, m + flx(i,j,k) = flx(i,j,k)+fall(i,j,k)*hk(ib,ik) + flxu(i,j,k) = flxu(i,j,k)+fallu(i,j,k)*hk(ib,ik) + flxd(i,j,k) = flxd(i,j,k)+falld(i,j,k)*hk(ib,ik) + enddo + enddo + do j= 1, n + do i= 1, m + flc(i,j,k) = flc(i,j,k)+fclr(i,j,k)*hk(ib,ik) + enddo + enddo + enddo + +!-----compute downward surface fluxes in the ir region + + do j= 1, n + do i= 1, m + fdirir(i,j) = fdirir(i,j)+fsdir(i,j)*hk(ib,ik) + fdifir(i,j) = fdifir(i,j)+fsdif(i,j)*hk(ib,ik) + enddo + enddo + + 200 continue + 100 continue + + end subroutine solir + +!******************************************************************** + + subroutine cldscale (m,n,ndim,np,cosz,fcld,taucld,ict,icb, & + cc,tauclb,tauclf) + +!******************************************************************** +! +! This subroutine computes the high, middle, and +! low cloud amounts and scales the cloud optical thickness. +! +! To simplify calculations in a cloudy atmosphere, clouds are +! grouped into high, middle and low clouds separated by the levels +! ict and icb (level 1 is the top of the model atmosphere). +! +! Within each of the three groups, clouds are assumed maximally +! overlapped, and the cloud cover (cc) of a group is the maximum +! cloud cover of all the layers in the group. The optical thickness +! (taucld) of a given layer is then scaled to new values (tauclb and +! tauclf) so that the layer reflectance corresponding to the cloud +! cover cc is the same as the original reflectance with optical +! thickness taucld and cloud cover fcld. +! +!---input parameters +! +! number of grid intervals in zonal direction (m) +! number of grid intervals in meridional direction (n) +! maximum number of grid intervals in meridional direction (ndim) +! number of atmospheric layers (np) +! cosine of the solar zenith angle (cosz) +! fractional cloud cover (fcld) +! cloud optical thickness (taucld) +! index separating high and middle clouds (ict) +! index separating middle and low clouds (icb) +! +!---output parameters +! +! fractional cover of high, middle, and low clouds (cc) +! scaled cloud optical thickness for beam radiation (tauclb) +! scaled cloud optical thickness for diffuse radiation (tauclf) +! +!******************************************************************** + implicit none +!******************************************************************** + +!-----input parameters + + integer m,n,ndim,np + integer ict(m,ndim),icb(m,ndim) + real cosz(m,ndim),fcld(m,ndim,np),taucld(m,ndim,np,2) + +!-----output parameters + + real cc(m,n,3),tauclb(m,n,np),tauclf(m,n,np) + +!-----temporary variables + + integer i,j,k,im,it,ia,kk + real fm,ft,fa,xai,taux + +!-----pre-computed table + + integer nm,nt,na + parameter (nm=11,nt=9,na=11) + real dm,dt,da,t1,caib(nm,nt,na),caif(nt,na) + parameter (dm=0.1,dt=0.30103,da=0.1,t1=-0.9031) + +!-----include the pre-computed table of mcai for scaling the cloud optical +! thickness under the assumption that clouds are maximally overlapped +! +! caib is for scaling the cloud optical thickness for direct radiation +! caif is for scaling the cloud optical thickness for diffuse radiation + + + data ((caib(1,i,j),j=1,11),i=1,9)/ & + .000,0.068,0.140,0.216,0.298,0.385,0.481,0.586,0.705,0.840,1.000, & + .000,0.052,0.106,0.166,0.230,0.302,0.383,0.478,0.595,0.752,1.000, & + .000,0.038,0.078,0.120,0.166,0.218,0.276,0.346,0.438,0.582,1.000, & + .000,0.030,0.060,0.092,0.126,0.164,0.206,0.255,0.322,0.442,1.000, & + .000,0.025,0.051,0.078,0.106,0.136,0.170,0.209,0.266,0.462,1.000, & + .000,0.023,0.046,0.070,0.095,0.122,0.150,0.187,0.278,0.577,1.000, & + .000,0.022,0.043,0.066,0.089,0.114,0.141,0.187,0.354,0.603,1.000, & + .000,0.021,0.042,0.063,0.086,0.108,0.135,0.214,0.349,0.565,1.000, & + .000,0.021,0.041,0.062,0.083,0.105,0.134,0.202,0.302,0.479,1.000/ + data ((caib(2,i,j),j=1,11),i=1,9)/ & + .000,0.088,0.179,0.272,0.367,0.465,0.566,0.669,0.776,0.886,1.000, & + .000,0.079,0.161,0.247,0.337,0.431,0.531,0.637,0.749,0.870,1.000, & + .000,0.065,0.134,0.207,0.286,0.372,0.466,0.572,0.692,0.831,1.000, & + .000,0.049,0.102,0.158,0.221,0.290,0.370,0.465,0.583,0.745,1.000, & + .000,0.037,0.076,0.118,0.165,0.217,0.278,0.354,0.459,0.638,1.000, & + .000,0.030,0.061,0.094,0.130,0.171,0.221,0.286,0.398,0.631,1.000, & + .000,0.026,0.052,0.081,0.111,0.146,0.189,0.259,0.407,0.643,1.000, & + .000,0.023,0.047,0.072,0.098,0.129,0.170,0.250,0.387,0.598,1.000, & + .000,0.022,0.044,0.066,0.090,0.118,0.156,0.224,0.328,0.508,1.000/ + data ((caib(3,i,j),j=1,11),i=1,9)/ & + .000,0.094,0.189,0.285,0.383,0.482,0.582,0.685,0.788,0.894,1.000, & + .000,0.088,0.178,0.271,0.366,0.465,0.565,0.669,0.776,0.886,1.000, & + .000,0.079,0.161,0.247,0.337,0.431,0.531,0.637,0.750,0.870,1.000, & + .000,0.066,0.134,0.209,0.289,0.375,0.470,0.577,0.697,0.835,1.000, & + .000,0.050,0.104,0.163,0.227,0.300,0.383,0.483,0.606,0.770,1.000, & + .000,0.038,0.080,0.125,0.175,0.233,0.302,0.391,0.518,0.710,1.000, & + .000,0.031,0.064,0.100,0.141,0.188,0.249,0.336,0.476,0.689,1.000, & + .000,0.026,0.054,0.084,0.118,0.158,0.213,0.298,0.433,0.638,1.000, & + .000,0.023,0.048,0.074,0.102,0.136,0.182,0.254,0.360,0.542,1.000/ + data ((caib(4,i,j),j=1,11),i=1,9)/ & + .000,0.096,0.193,0.290,0.389,0.488,0.589,0.690,0.792,0.896,1.000, & + .000,0.092,0.186,0.281,0.378,0.477,0.578,0.680,0.785,0.891,1.000, & + .000,0.086,0.174,0.264,0.358,0.455,0.556,0.660,0.769,0.882,1.000, & + .000,0.074,0.153,0.235,0.323,0.416,0.514,0.622,0.737,0.862,1.000, & + .000,0.061,0.126,0.195,0.271,0.355,0.449,0.555,0.678,0.823,1.000, & + .000,0.047,0.098,0.153,0.215,0.286,0.370,0.471,0.600,0.770,1.000, & + .000,0.037,0.077,0.120,0.170,0.230,0.303,0.401,0.537,0.729,1.000, & + .000,0.030,0.062,0.098,0.138,0.187,0.252,0.343,0.476,0.673,1.000, & + .000,0.026,0.053,0.082,0.114,0.154,0.207,0.282,0.391,0.574,1.000/ + data ((caib(5,i,j),j=1,11),i=1,9)/ & + .000,0.097,0.194,0.293,0.392,0.492,0.592,0.693,0.794,0.897,1.000, & + .000,0.094,0.190,0.286,0.384,0.483,0.584,0.686,0.789,0.894,1.000, & + .000,0.090,0.181,0.274,0.370,0.468,0.569,0.672,0.778,0.887,1.000, & + .000,0.081,0.165,0.252,0.343,0.439,0.539,0.645,0.757,0.874,1.000, & + .000,0.069,0.142,0.218,0.302,0.392,0.490,0.598,0.717,0.850,1.000, & + .000,0.054,0.114,0.178,0.250,0.330,0.422,0.529,0.656,0.810,1.000, & + .000,0.042,0.090,0.141,0.200,0.269,0.351,0.455,0.589,0.764,1.000, & + .000,0.034,0.070,0.112,0.159,0.217,0.289,0.384,0.515,0.703,1.000, & + .000,0.028,0.058,0.090,0.128,0.174,0.231,0.309,0.420,0.602,1.000/ + data ((caib(6,i,j),j=1,11),i=1,9)/ & + .000,0.098,0.196,0.295,0.394,0.494,0.594,0.695,0.796,0.898,1.000, & + .000,0.096,0.193,0.290,0.389,0.488,0.588,0.690,0.792,0.895,1.000, & + .000,0.092,0.186,0.281,0.378,0.477,0.577,0.680,0.784,0.891,1.000, & + .000,0.086,0.174,0.264,0.358,0.455,0.556,0.661,0.769,0.882,1.000, & + .000,0.075,0.154,0.237,0.325,0.419,0.518,0.626,0.741,0.865,1.000, & + .000,0.062,0.129,0.201,0.279,0.366,0.462,0.571,0.694,0.836,1.000, & + .000,0.049,0.102,0.162,0.229,0.305,0.394,0.501,0.631,0.793,1.000, & + .000,0.038,0.080,0.127,0.182,0.245,0.323,0.422,0.550,0.730,1.000, & + .000,0.030,0.064,0.100,0.142,0.192,0.254,0.334,0.448,0.627,1.000/ + data ((caib(7,i,j),j=1,11),i=1,9)/ & + .000,0.098,0.198,0.296,0.396,0.496,0.596,0.696,0.797,0.898,1.000, & + .000,0.097,0.194,0.293,0.392,0.491,0.591,0.693,0.794,0.897,1.000, & + .000,0.094,0.190,0.286,0.384,0.483,0.583,0.686,0.789,0.894,1.000, & + .000,0.089,0.180,0.274,0.369,0.467,0.568,0.672,0.778,0.887,1.000, & + .000,0.081,0.165,0.252,0.344,0.440,0.541,0.646,0.758,0.875,1.000, & + .000,0.069,0.142,0.221,0.306,0.397,0.496,0.604,0.722,0.854,1.000, & + .000,0.056,0.116,0.182,0.256,0.338,0.432,0.540,0.666,0.816,1.000, & + .000,0.043,0.090,0.143,0.203,0.273,0.355,0.455,0.583,0.754,1.000, & + .000,0.034,0.070,0.111,0.157,0.210,0.276,0.359,0.474,0.650,1.000/ + data ((caib(8,i,j),j=1,11),i=1,9)/ & + .000,0.099,0.198,0.298,0.398,0.497,0.598,0.698,0.798,0.899,1.000, & + .000,0.098,0.196,0.295,0.394,0.494,0.594,0.695,0.796,0.898,1.000, & + .000,0.096,0.193,0.290,0.390,0.489,0.589,0.690,0.793,0.896,1.000, & + .000,0.093,0.186,0.282,0.379,0.478,0.578,0.681,0.786,0.892,1.000, & + .000,0.086,0.175,0.266,0.361,0.458,0.558,0.663,0.771,0.883,1.000, & + .000,0.076,0.156,0.240,0.330,0.423,0.523,0.630,0.744,0.867,1.000, & + .000,0.063,0.130,0.203,0.282,0.369,0.465,0.572,0.694,0.834,1.000, & + .000,0.049,0.102,0.161,0.226,0.299,0.385,0.486,0.611,0.774,1.000, & + .000,0.038,0.078,0.122,0.172,0.229,0.297,0.382,0.498,0.672,1.000/ + data ((caib(9,i,j),j=1,11),i=1,9)/ & + .000,0.099,0.199,0.298,0.398,0.498,0.598,0.699,0.799,0.899,1.000, & + .000,0.099,0.198,0.298,0.398,0.497,0.598,0.698,0.798,0.899,1.000, & + .000,0.098,0.196,0.295,0.394,0.494,0.594,0.695,0.796,0.898,1.000, & + .000,0.096,0.193,0.290,0.389,0.488,0.588,0.690,0.792,0.895,1.000, & + .000,0.092,0.185,0.280,0.376,0.474,0.575,0.678,0.782,0.890,1.000, & + .000,0.084,0.170,0.259,0.351,0.447,0.547,0.652,0.762,0.878,1.000, & + .000,0.071,0.146,0.224,0.308,0.398,0.494,0.601,0.718,0.850,1.000, & + .000,0.056,0.114,0.178,0.248,0.325,0.412,0.514,0.638,0.793,1.000, & + .000,0.042,0.086,0.134,0.186,0.246,0.318,0.405,0.521,0.691,1.000/ + data ((caib(10,i,j),j=1,11),i=1,9)/ & + .000,0.100,0.200,0.300,0.400,0.500,0.600,0.700,0.800,0.900,1.000, & + .000,0.100,0.200,0.300,0.400,0.500,0.600,0.700,0.800,0.900,1.000, & + .000,0.100,0.200,0.300,0.400,0.500,0.600,0.700,0.800,0.900,1.000, & + .000,0.100,0.199,0.298,0.398,0.498,0.598,0.698,0.798,0.899,1.000, & + .000,0.098,0.196,0.294,0.392,0.491,0.590,0.691,0.793,0.896,1.000, & + .000,0.092,0.185,0.278,0.374,0.470,0.570,0.671,0.777,0.886,1.000, & + .000,0.081,0.162,0.246,0.333,0.424,0.521,0.625,0.738,0.862,1.000, & + .000,0.063,0.128,0.196,0.270,0.349,0.438,0.540,0.661,0.809,1.000, & + .000,0.046,0.094,0.146,0.202,0.264,0.337,0.426,0.542,0.710,1.000/ + data ((caib(11,i,j),j=1,11),i=1,9)/ & + .000,0.101,0.202,0.302,0.402,0.502,0.602,0.702,0.802,0.901,1.000, & + .000,0.102,0.202,0.303,0.404,0.504,0.604,0.703,0.802,0.902,1.000, & + .000,0.102,0.205,0.306,0.406,0.506,0.606,0.706,0.804,0.902,1.000, & + .000,0.104,0.207,0.309,0.410,0.510,0.609,0.707,0.805,0.902,1.000, & + .000,0.106,0.208,0.309,0.409,0.508,0.606,0.705,0.803,0.902,1.000, & + .000,0.102,0.202,0.298,0.395,0.493,0.590,0.690,0.790,0.894,1.000, & + .000,0.091,0.179,0.267,0.357,0.449,0.545,0.647,0.755,0.872,1.000, & + .000,0.073,0.142,0.214,0.290,0.372,0.462,0.563,0.681,0.822,1.000, & + .000,0.053,0.104,0.158,0.217,0.281,0.356,0.446,0.562,0.726,1.000/ + data ((caif(i,j),j=1,11),i=1,9)/ & + .000,0.099,0.198,0.297,0.397,0.496,0.597,0.697,0.798,0.899,1.000, & + .000,0.098,0.196,0.294,0.394,0.494,0.594,0.694,0.796,0.898,1.000, & + .000,0.096,0.192,0.290,0.388,0.487,0.587,0.689,0.792,0.895,1.000, & + .000,0.092,0.185,0.280,0.376,0.476,0.576,0.678,0.783,0.890,1.000, & + .000,0.085,0.173,0.263,0.357,0.454,0.555,0.659,0.768,0.881,1.000, & + .000,0.076,0.154,0.237,0.324,0.418,0.517,0.624,0.738,0.864,1.000, & + .000,0.063,0.131,0.203,0.281,0.366,0.461,0.567,0.688,0.830,1.000, & + .000,0.052,0.107,0.166,0.232,0.305,0.389,0.488,0.610,0.770,1.000, & + .000,0.043,0.088,0.136,0.189,0.248,0.317,0.400,0.510,0.675,1.000/ + +!-----clouds within each of the high, middle, and low clouds are assumed +! to be maximally overlapped, and the cloud cover (cc) for a group +! (high, middle, or low) is the maximum cloud cover of all the layers +! within a group + + do j=1,n + do i=1,m + cc(i,j,1)=0.0 + cc(i,j,2)=0.0 + cc(i,j,3)=0.0 + enddo + enddo + do j=1,n + do i=1,m + do k=1,ict(i,j)-1 + cc(i,j,1)=max(cc(i,j,1),fcld(i,j,k)) + enddo + enddo + enddo + + do j=1,n + do i=1,m + do k=ict(i,j),icb(i,j)-1 + cc(i,j,2)=max(cc(i,j,2),fcld(i,j,k)) + enddo + enddo + enddo + + do j=1,n + do i=1,m + do k=icb(i,j),np + cc(i,j,3)=max(cc(i,j,3),fcld(i,j,k)) + enddo + enddo + enddo + +!-----scale the cloud optical thickness. +! taucld(i,j,k,1) is the optical thickness for ice particles, and +! taucld(i,j,k,2) is the optical thickness for liquid particles. + + do j=1,n + do i=1,m + + do k=1,np + + if(k.lt.ict(i,j)) then + kk=1 + elseif(k.ge.ict(i,j) .and. k.lt.icb(i,j)) then + kk=2 + else + kk=3 + endif + + tauclb(i,j,k) = 0.0 + tauclf(i,j,k) = 0.0 + + taux=taucld(i,j,k,1)+taucld(i,j,k,2) + if (taux.gt.0.05 .and. fcld(i,j,k).gt.0.01) then + +!-----normalize cloud cover + + fa=fcld(i,j,k)/cc(i,j,kk) + +!-----table look-up + + taux=min(taux,32.) + + fm=cosz(i,j)/dm + ft=(log10(taux)-t1)/dt + fa=fa/da + + im=int(fm+1.5) + it=int(ft+1.5) + ia=int(fa+1.5) + + im=max(im,2) + it=max(it,2) + ia=max(ia,2) + + im=min(im,nm-1) + it=min(it,nt-1) + ia=min(ia,na-1) + + fm=fm-float(im-1) + ft=ft-float(it-1) + fa=fa-float(ia-1) + +!-----scale cloud optical thickness for beam radiation. +! the scaling factor, xai, is a function of the solar zenith +! angle, optical thickness, and cloud cover. + + xai= (-caib(im-1,it,ia)*(1.-fm)+ & + caib(im+1,it,ia)*(1.+fm))*fm*.5+caib(im,it,ia)*(1.-fm*fm) + + xai=xai+(-caib(im,it-1,ia)*(1.-ft)+ & + caib(im,it+1,ia)*(1.+ft))*ft*.5+caib(im,it,ia)*(1.-ft*ft) + + xai=xai+(-caib(im,it,ia-1)*(1.-fa)+ & + caib(im,it,ia+1)*(1.+fa))*fa*.5+caib(im,it,ia)*(1.-fa*fa) + + xai= xai-2.*caib(im,it,ia) + xai=max(xai,0.0) + + tauclb(i,j,k) = taux*xai + +!-----scale cloud optical thickness for diffuse radiation. +! the scaling factor, xai, is a function of the cloud optical +! thickness and cover but not the solar zenith angle. + + xai= (-caif(it-1,ia)*(1.-ft)+ & + caif(it+1,ia)*(1.+ft))*ft*.5+caif(it,ia)*(1.-ft*ft) + + xai=xai+(-caif(it,ia-1)*(1.-fa)+ & + caif(it,ia+1)*(1.+fa))*fa*.5+caif(it,ia)*(1.-fa*fa) + + xai= xai-caif(it,ia) + xai=max(xai,0.0) + + tauclf(i,j,k) = taux*xai + + endif + + enddo + enddo + enddo + + end subroutine cldscale + +!********************************************************************* + + subroutine deledd(tau,ssc,g0,csm,rr,tt,td) + +!********************************************************************* +! +!-----uses the delta-eddington approximation to compute the +! bulk scattering properties of a single layer +! coded following King and Harshvardhan (JAS, 1986) +! +! inputs: +! +! tau: the effective optical thickness +! ssc: the effective single scattering albedo +! g0: the effective asymmetry factor +! csm: the effective secant of the zenith angle +! +! outputs: +! +! rr: the layer reflection of the direct beam +! tt: the layer diffuse transmission of the direct beam +! td: the layer direct transmission of the direct beam +! +!********************************************************************* + implicit none +!********************************************************************* + + real zero,one,two,three,four,fourth,seven,thresh + parameter (one =1., three=3.) + parameter (two =2., seven=7.) + parameter (four=4., fourth=.25) + parameter (zero=0., thresh=1.e-8) + +!-----input parameters + real tau,ssc,g0,csm + +!-----output parameters + real rr,tt,td + +!-----temporary parameters + + real zth,ff,xx,taup,sscp,gp,gm1,gm2,gm3,akk,alf1,alf2, & + all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4 + +!--------------------------------------------------------------------- + + zth = one / csm + +! delta-eddington scaling of single scattering albedo, +! optical thickness, and asymmetry factor, +! K & H eqs(27-29) + + ff = g0*g0 + xx = one-ff*ssc + taup= tau*xx + sscp= ssc*(one-ff)/xx + gp = g0/(one+g0) + +! gamma1, gamma2, and gamma3. see table 2 and eq(26) K & H +! ssc and gp are the d-s single scattering +! albedo and asymmetry factor. + + xx = three*gp + gm1 = (seven - sscp*(four+xx))*fourth + gm2 = -(one - sscp*(four-xx))*fourth + +! akk is k as defined in eq(25) of K & H + + akk = sqrt((gm1+gm2)*(gm1-gm2)) + + xx = akk * zth + st7 = one - xx + st8 = one + xx + st3 = st7 * st8 + + if (abs(st3) .lt. thresh) then + zth = zth + 0.001 + xx = akk * zth + st7 = one - xx + st8 = one + xx + st3 = st7 * st8 + endif + +! extinction of the direct beam transmission + + td = exp(-taup/zth) + +! alf1 and alf2 are alpha1 and alpha2 from eqs (23) & (24) of K & H + + gm3 = (two - zth*three*gp)*fourth + xx = gm1 - gm2 + alf1 = gm1 - gm3 * xx + alf2 = gm2 + gm3 * xx + +! all is last term in eq(21) of K & H +! bll is last term in eq(22) of K & H + + xx = akk * two + all = (gm3 - alf2 * zth )*xx*td + bll = (one - gm3 + alf1*zth)*xx + + xx = akk * gm3 + cll = (alf2 + xx) * st7 + dll = (alf2 - xx) * st8 + + xx = akk * (one-gm3) + fll = (alf1 + xx) * st8 + ell = (alf1 - xx) * st7 + + st2 = exp(-akk*taup) + st4 = st2 * st2 + + st1 = sscp / ((akk+gm1 + (akk-gm1)*st4) * st3) + +! rr is r-hat of eq(21) of K & H +! tt is diffuse part of t-hat of eq(22) of K & H + + rr = ( cll-dll*st4 -all*st2)*st1 + tt = - ((fll-ell*st4)*td-bll*st2)*st1 + + rr = max(rr,zero) + tt = max(tt,zero) + + end subroutine deledd + +!********************************************************************* + + subroutine sagpol(tau,ssc,g0,rll,tll) + +!********************************************************************* +!-----transmittance (tll) and reflectance (rll) of diffuse radiation +! follows Sagan and Pollock (JGR, 1967). +! also, eq.(31) of Lacis and Hansen (JAS, 1974). +! +!-----input parameters: +! +! tau: the effective optical thickness +! ssc: the effective single scattering albedo +! g0: the effective asymmetry factor +! +!-----output parameters: +! +! rll: the layer reflection of diffuse radiation +! tll: the layer transmission of diffuse radiation +! +!********************************************************************* + implicit none +!********************************************************************* + + real one,three,four + parameter (one=1., three=3., four=4.) + +!-----output parameters: + + real tau,ssc,g0 + +!-----output parameters: + + real rll,tll + +!-----temporary arrays + + real xx,uuu,ttt,emt,up1,um1,st1 + + xx = one-ssc*g0 + uuu = sqrt( xx/(one-ssc)) + ttt = sqrt( xx*(one-ssc)*three )*tau + emt = exp(-ttt) + up1 = uuu + one + um1 = uuu - one + xx = um1*emt + st1 = one / ((up1+xx) * (up1-xx)) + rll = up1*um1*(one-emt*emt)*st1 + tll = uuu*four*emt *st1 + + end subroutine sagpol + +!******************************************************************* + + subroutine cldflx (m,n,np,ict,icb,overcast,cc,rr,tt,td,rs,ts,& + fclr,fall,fallu,falld,fsdir,fsdif) + +!******************************************************************* +! compute upward and downward fluxes using a two-stream adding method +! following equations (3)-(5) of Chou (1992, JAS). +! +! clouds are grouped into high, middle, and low clouds which are +! assumed randomly overlapped. It involves eight sets of calculations. +! In each set of calculations, each atmospheric layer is homogeneous, +! either totally filled with clouds or without clouds. + +! input parameters: +! +! m: number of soundings in zonal direction +! n: number of soundings in meridional direction +! np: number of atmospheric layers +! ict: the level separating high and middle clouds +! icb: the level separating middle and low clouds +! cc: effective cloud covers for high, middle and low clouds +! tt: diffuse transmission of a layer illuminated by beam radiation +! td: direct beam tranmssion +! ts: transmission of a layer illuminated by diffuse radiation +! rr: reflection of a layer illuminated by beam radiation +! rs: reflection of a layer illuminated by diffuse radiation +! +! output parameters: +! +! fclr: clear-sky flux (downward minus upward) +! fall: all-sky flux (downward minus upward) +! fsdir: surface direct downward flux +! fsdif: surface diffuse downward flux +! +!*********************************************************************c + implicit none +!*********************************************************************c + +!-----input parameters + + integer m,n,np + integer ict(m,n),icb(m,n) + + real rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2) + real rs(m,n,np+1,2),ts(m,n,np+1,2) + real cc(m,n,3) + logical overcast + +!-----temporary array + + integer i,j,k,ih,im,is,itm + real rra(m,n,np+1,2,2),tta(m,n,np+1,2,2),tda(m,n,np+1,2,2) + real rsa(m,n,np+1,2,2),rxa(m,n,np+1,2,2) + real ch(m,n),cm(m,n),ct(m,n),flxdn(m,n,np+1) + real flxdnu(m,n,np+1),flxdnd(m,n,np+1) + real fdndir(m,n),fdndif(m,n),fupdif + real denm,xx + +!-----output parameters + + real fclr(m,n,np+1),fall(m,n,np+1) + real fallu(m,n,np+1),falld(m,n,np+1) + real fsdir(m,n),fsdif(m,n) + +!-----initialize all-sky flux (fall) and surface downward fluxes + + do k=1,np+1 + do j=1,n + do i=1,m + fclr(i,j,k)=0.0 + fall(i,j,k)=0.0 + fallu(i,j,k)=0.0 + falld(i,j,k)=0.0 + enddo + enddo + enddo + + do j=1,n + do i=1,m + fsdir(i,j)=0.0 + fsdif(i,j)=0.0 + enddo + enddo + +!-----compute transmittances and reflectances for a composite of +! layers. layers are added one at a time, going down from the top. +! tda is the composite transmittance illuminated by beam radiation +! tta is the composite diffuse transmittance illuminated by +! beam radiation +! rsa is the composite reflectance illuminated from below +! by diffuse radiation +! tta and rsa are computed from eqs. (4b) and (3b) of Chou + + itm=1 + +!-----if overcas.=.true., set itm=2, and only one set of fluxes is computed + + if (overcast) itm=2 + +!-----for high clouds. indices 1 and 2 denote clear and cloudy +! situations, respectively. + + do 10 ih=itm,2 + + do j= 1, n + do i= 1, m + tda(i,j,1,ih,1)=td(i,j,1,ih) + tta(i,j,1,ih,1)=tt(i,j,1,ih) + rsa(i,j,1,ih,1)=rs(i,j,1,ih) + tda(i,j,1,ih,2)=td(i,j,1,ih) + tta(i,j,1,ih,2)=tt(i,j,1,ih) + rsa(i,j,1,ih,2)=rs(i,j,1,ih) + enddo + enddo + + do j= 1, n + do i= 1, m + do k= 2, ict(i,j)-1 + denm = ts(i,j,k,ih)/( 1.-rsa(i,j,k-1,ih,1)*rs(i,j,k,ih)) + tda(i,j,k,ih,1)= tda(i,j,k-1,ih,1)*td(i,j,k,ih) + tta(i,j,k,ih,1)= tda(i,j,k-1,ih,1)*tt(i,j,k,ih) & + +(tda(i,j,k-1,ih,1)*rr(i,j,k,ih) & + *rsa(i,j,k-1,ih,1)+tta(i,j,k-1,ih,1))*denm + rsa(i,j,k,ih,1)= rs(i,j,k,ih)+ts(i,j,k,ih) & + *rsa(i,j,k-1,ih,1)*denm + tda(i,j,k,ih,2)= tda(i,j,k,ih,1) + tta(i,j,k,ih,2)= tta(i,j,k,ih,1) + rsa(i,j,k,ih,2)= rsa(i,j,k,ih,1) + enddo + enddo + enddo + +!-----for middle clouds + + do 10 im=itm,2 + + do j= 1, n + do i= 1, m + do k= ict(i,j), icb(i,j)-1 + denm = ts(i,j,k,im)/( 1.-rsa(i,j,k-1,ih,im)*rs(i,j,k,im)) + tda(i,j,k,ih,im)= tda(i,j,k-1,ih,im)*td(i,j,k,im) + tta(i,j,k,ih,im)= tda(i,j,k-1,ih,im)*tt(i,j,k,im) & + +(tda(i,j,k-1,ih,im)*rr(i,j,k,im) & + *rsa(i,j,k-1,ih,im)+tta(i,j,k-1,ih,im))*denm + rsa(i,j,k,ih,im)= rs(i,j,k,im)+ts(i,j,k,im) & + *rsa(i,j,k-1,ih,im)*denm + enddo + enddo + enddo + + 10 continue + +!-----layers are added one at a time, going up from the surface. +! rra is the composite reflectance illuminated by beam radiation +! rxa is the composite reflectance illuminated from above +! by diffuse radiation +! rra and rxa are computed from eqs. (4a) and (3a) of Chou + +!-----for the low clouds + + do 20 is=itm,2 + + do j= 1, n + do i= 1, m + rra(i,j,np+1,1,is)=rr(i,j,np+1,is) + rxa(i,j,np+1,1,is)=rs(i,j,np+1,is) + rra(i,j,np+1,2,is)=rr(i,j,np+1,is) + rxa(i,j,np+1,2,is)=rs(i,j,np+1,is) + enddo + enddo + + do j= 1, n + do i= 1, m + do k=np,icb(i,j),-1 + denm=ts(i,j,k,is)/( 1.-rs(i,j,k,is)*rxa(i,j,k+1,1,is) ) + rra(i,j,k,1,is)=rr(i,j,k,is)+(td(i,j,k,is) & + *rra(i,j,k+1,1,is)+tt(i,j,k,is)*rxa(i,j,k+1,1,is))*denm + rxa(i,j,k,1,is)= rs(i,j,k,is)+ts(i,j,k,is) & + *rxa(i,j,k+1,1,is)*denm + rra(i,j,k,2,is)=rra(i,j,k,1,is) + rxa(i,j,k,2,is)=rxa(i,j,k,1,is) + enddo + enddo + enddo + +!-----for middle clouds + + do 20 im=itm,2 + + do j= 1, n + do i= 1, m + do k= icb(i,j)-1,ict(i,j),-1 + denm=ts(i,j,k,im)/( 1.-rs(i,j,k,im)*rxa(i,j,k+1,im,is) ) + rra(i,j,k,im,is)= rr(i,j,k,im)+(td(i,j,k,im) & + *rra(i,j,k+1,im,is)+tt(i,j,k,im)*rxa(i,j,k+1,im,is))*denm + rxa(i,j,k,im,is)= rs(i,j,k,im)+ts(i,j,k,im) & + *rxa(i,j,k+1,im,is)*denm + enddo + enddo + enddo + + 20 continue + +!-----integration over eight sky situations. +! ih, im, is denotes high, middle and low cloud groups. + + do 100 ih=itm,2 + +!-----clear portion + + if(ih.eq.1) then + do j=1,n + do i=1,m + ch(i,j)=1.0-cc(i,j,1) + enddo + enddo + + else + +!-----cloudy portion + + do j=1,n + do i=1,m + ch(i,j)=cc(i,j,1) + enddo + enddo + + endif + + do 100 im=itm,2 + +!-----clear portion + + if(im.eq.1) then + + do j=1,n + do i=1,m + cm(i,j)=ch(i,j)*(1.0-cc(i,j,2)) + enddo + enddo + + else + +!-----cloudy portion + + do j=1,n + do i=1,m + cm(i,j)=ch(i,j)*cc(i,j,2) + enddo + enddo + + endif + + do 100 is=itm,2 + +!-----clear portion + + if(is.eq.1) then + + do j=1,n + do i=1,m + ct(i,j)=cm(i,j)*(1.0-cc(i,j,3)) + enddo + enddo + + else + +!-----cloudy portion + + do j=1,n + do i=1,m + ct(i,j)=cm(i,j)*cc(i,j,3) + enddo + enddo + + endif + +!-----add one layer at a time, going down. + + do j= 1, n + do i= 1, m + do k= icb(i,j), np + denm = ts(i,j,k,is)/( 1.-rsa(i,j,k-1,ih,im)*rs(i,j,k,is) ) + tda(i,j,k,ih,im)= tda(i,j,k-1,ih,im)*td(i,j,k,is) + tta(i,j,k,ih,im)= tda(i,j,k-1,ih,im)*tt(i,j,k,is) & + +(tda(i,j,k-1,ih,im)*rr(i,j,k,is) & + *rsa(i,j,k-1,ih,im)+tta(i,j,k-1,ih,im))*denm + rsa(i,j,k,ih,im)= rs(i,j,k,is)+ts(i,j,k,is) & + *rsa(i,j,k-1,ih,im)*denm + enddo + enddo + enddo + +!-----add one layer at a time, going up. + + do j= 1, n + do i= 1, m + do k= ict(i,j)-1,1,-1 + denm =ts(i,j,k,ih)/(1.-rs(i,j,k,ih)*rxa(i,j,k+1,im,is)) + rra(i,j,k,im,is)= rr(i,j,k,ih)+(td(i,j,k,ih) & + *rra(i,j,k+1,im,is)+tt(i,j,k,ih)*rxa(i,j,k+1,im,is))*denm + rxa(i,j,k,im,is)= rs(i,j,k,ih)+ts(i,j,k,ih) & + *rxa(i,j,k+1,im,is)*denm + enddo + enddo + enddo + +!-----compute fluxes following eq (5) of Chou (1992) + +! fdndir is the direct downward flux +! fdndif is the diffuse downward flux +! fupdif is the diffuse upward flux + + do k=2,np+1 + do j=1, n + do i=1, m + denm= 1./(1.- rxa(i,j,k,im,is)*rsa(i,j,k-1,ih,im)) + fdndir(i,j)= tda(i,j,k-1,ih,im) + xx = tda(i,j,k-1,ih,im)*rra(i,j,k,im,is) + fdndif(i,j)= (xx*rsa(i,j,k-1,ih,im)+tta(i,j,k-1,ih,im))*denm + fupdif= (xx+tta(i,j,k-1,ih,im)*rxa(i,j,k,im,is))*denm + flxdn(i,j,k)=fdndir(i,j)+fdndif(i,j)-fupdif + flxdnu(i,j,k)=-fupdif + flxdnd(i,j,k)=fdndir(i,j)+fdndif(i,j) + enddo + enddo + enddo + + do j=1, n + do i=1, m + flxdn(i,j,1)=1.0-rra(i,j,1,im,is) + flxdnu(i,j,1)=-rra(i,j,1,im,is) + flxdnd(i,j,1)=1.0 + enddo + enddo + +!-----summation of fluxes over all (eight) sky situations. + + do k=1,np+1 + do j=1,n + do i=1,m + if(ih.eq.1 .and. im.eq.1 .and. is.eq.1) then + fclr(i,j,k)=flxdn(i,j,k) + endif + fall(i,j,k)=fall(i,j,k)+flxdn(i,j,k)*ct(i,j) + fallu(i,j,k)=fallu(i,j,k)+flxdnu(i,j,k)*ct(i,j) + falld(i,j,k)=falld(i,j,k)+flxdnd(i,j,k)*ct(i,j) + enddo + enddo + enddo + + do j=1,n + do i=1,m + fsdir(i,j)=fsdir(i,j)+fdndir(i,j)*ct(i,j) + fsdif(i,j)=fsdif(i,j)+fdndif(i,j)*ct(i,j) + enddo + enddo + + 100 continue + + end subroutine cldflx + +!***************************************************************** + + subroutine flxco2(m,n,np,swc,swh,csm,df) + +!***************************************************************** + +!-----compute the reduction of clear-sky downward solar flux +! due to co2 absorption. + + implicit none + +!-----input parameters + + integer m,n,np + real csm(m,n),swc(m,n,np+1),swh(m,n,np+1),cah(22,19) + +!-----output (undated) parameter + + real df(m,n,np+1) + +!-----temporary array + + integer i,j,k,ic,iw + real xx,clog,wlog,dc,dw,x1,x2,y2 + +!******************************************************************** +!-----include co2 look-up table + + data ((cah(i,j),i=1,22),j= 1, 5)/ & + 0.9923, 0.9922, 0.9921, 0.9920, 0.9916, 0.9910, 0.9899, 0.9882, & + 0.9856, 0.9818, 0.9761, 0.9678, 0.9558, 0.9395, 0.9188, 0.8945, & + 0.8675, 0.8376, 0.8029, 0.7621, 0.7154, 0.6647, 0.9876, 0.9876, & + 0.9875, 0.9873, 0.9870, 0.9864, 0.9854, 0.9837, 0.9811, 0.9773, & + 0.9718, 0.9636, 0.9518, 0.9358, 0.9153, 0.8913, 0.8647, 0.8350, & + 0.8005, 0.7599, 0.7133, 0.6627, 0.9808, 0.9807, 0.9806, 0.9805, & + 0.9802, 0.9796, 0.9786, 0.9769, 0.9744, 0.9707, 0.9653, 0.9573, & + 0.9459, 0.9302, 0.9102, 0.8866, 0.8604, 0.8311, 0.7969, 0.7565, & + 0.7101, 0.6596, 0.9708, 0.9708, 0.9707, 0.9705, 0.9702, 0.9697, & + 0.9687, 0.9671, 0.9647, 0.9612, 0.9560, 0.9483, 0.9372, 0.9221, & + 0.9027, 0.8798, 0.8542, 0.8253, 0.7916, 0.7515, 0.7054, 0.6551, & + 0.9568, 0.9568, 0.9567, 0.9565, 0.9562, 0.9557, 0.9548, 0.9533, & + 0.9510, 0.9477, 0.9428, 0.9355, 0.9250, 0.9106, 0.8921, 0.8700, & + 0.8452, 0.8171, 0.7839, 0.7443, 0.6986, 0.6486/ + + data ((cah(i,j),i=1,22),j= 6,10)/ & + 0.9377, 0.9377, 0.9376, 0.9375, 0.9372, 0.9367, 0.9359, 0.9345, & + 0.9324, 0.9294, 0.9248, 0.9181, 0.9083, 0.8948, 0.8774, 0.8565, & + 0.8328, 0.8055, 0.7731, 0.7342, 0.6890, 0.6395, 0.9126, 0.9126, & + 0.9125, 0.9124, 0.9121, 0.9117, 0.9110, 0.9098, 0.9079, 0.9052, & + 0.9012, 0.8951, 0.8862, 0.8739, 0.8579, 0.8385, 0.8161, 0.7900, & + 0.7585, 0.7205, 0.6760, 0.6270, 0.8809, 0.8809, 0.8808, 0.8807, & + 0.8805, 0.8802, 0.8796, 0.8786, 0.8770, 0.8747, 0.8712, 0.8659, & + 0.8582, 0.8473, 0.8329, 0.8153, 0.7945, 0.7697, 0.7394, 0.7024, & + 0.6588, 0.6105, 0.8427, 0.8427, 0.8427, 0.8426, 0.8424, 0.8422, & + 0.8417, 0.8409, 0.8397, 0.8378, 0.8350, 0.8306, 0.8241, 0.8148, & + 0.8023, 0.7866, 0.7676, 0.7444, 0.7154, 0.6796, 0.6370, 0.5897, & + 0.7990, 0.7990, 0.7990, 0.7989, 0.7988, 0.7987, 0.7983, 0.7978, & + 0.7969, 0.7955, 0.7933, 0.7899, 0.7846, 0.7769, 0.7664, 0.7528, & + 0.7357, 0.7141, 0.6866, 0.6520, 0.6108, 0.5646/ + + data ((cah(i,j),i=1,22),j=11,15)/ & + 0.7515, 0.7515, 0.7515, 0.7515, 0.7514, 0.7513, 0.7511, 0.7507, & + 0.7501, 0.7491, 0.7476, 0.7450, 0.7409, 0.7347, 0.7261, 0.7144, & + 0.6992, 0.6793, 0.6533, 0.6203, 0.5805, 0.5357, 0.7020, 0.7020, & + 0.7020, 0.7019, 0.7019, 0.7018, 0.7017, 0.7015, 0.7011, 0.7005, & + 0.6993, 0.6974, 0.6943, 0.6894, 0.6823, 0.6723, 0.6588, 0.6406, & + 0.6161, 0.5847, 0.5466, 0.5034, 0.6518, 0.6518, 0.6518, 0.6518, & + 0.6518, 0.6517, 0.6517, 0.6515, 0.6513, 0.6508, 0.6500, 0.6485, & + 0.6459, 0.6419, 0.6359, 0.6273, 0.6151, 0.5983, 0.5755, 0.5458, & + 0.5095, 0.4681, 0.6017, 0.6017, 0.6017, 0.6017, 0.6016, 0.6016, & + 0.6016, 0.6015, 0.6013, 0.6009, 0.6002, 0.5989, 0.5967, 0.5932, & + 0.5879, 0.5801, 0.5691, 0.5535, 0.5322, 0.5043, 0.4700, 0.4308, & + 0.5518, 0.5518, 0.5518, 0.5518, 0.5518, 0.5518, 0.5517, 0.5516, & + 0.5514, 0.5511, 0.5505, 0.5493, 0.5473, 0.5441, 0.5393, 0.5322, & + 0.5220, 0.5076, 0.4878, 0.4617, 0.4297, 0.3929/ + + data ((cah(i,j),i=1,22),j=16,19)/ & + 0.5031, 0.5031, 0.5031, 0.5031, 0.5031, 0.5030, 0.5030, 0.5029, & + 0.5028, 0.5025, 0.5019, 0.5008, 0.4990, 0.4960, 0.4916, 0.4850, & + 0.4757, 0.4624, 0.4441, 0.4201, 0.3904, 0.3564, 0.4565, 0.4565, & + 0.4565, 0.4564, 0.4564, 0.4564, 0.4564, 0.4563, 0.4562, 0.4559, & + 0.4553, 0.4544, 0.4527, 0.4500, 0.4460, 0.4400, 0.4315, 0.4194, & + 0.4028, 0.3809, 0.3538, 0.3227, 0.4122, 0.4122, 0.4122, 0.4122, & + 0.4122, 0.4122, 0.4122, 0.4121, 0.4120, 0.4117, 0.4112, 0.4104, & + 0.4089, 0.4065, 0.4029, 0.3976, 0.3900, 0.3792, 0.3643, 0.3447, & + 0.3203, 0.2923, 0.3696, 0.3696, 0.3696, 0.3696, 0.3696, 0.3696, & + 0.3695, 0.3695, 0.3694, 0.3691, 0.3687, 0.3680, 0.3667, 0.3647, & + 0.3615, 0.3570, 0.3504, 0.3409, 0.3279, 0.3106, 0.2892, 0.2642/ + +!******************************************************************** +!-----table look-up for the reduction of clear-sky solar +! radiation due to co2. The fraction 0.0343 is the +! extraterrestrial solar flux in the co2 bands. + + do k= 2, np+1 + do j= 1, n + do i= 1, m + xx=1./.3 + clog=log10(swc(i,j,k)*csm(i,j)) + wlog=log10(swh(i,j,k)*csm(i,j)) + ic=int( (clog+3.15)*xx+1.) + iw=int( (wlog+4.15)*xx+1.) + if(ic.lt.2)ic=2 + if(iw.lt.2)iw=2 + if(ic.gt.22)ic=22 + if(iw.gt.19)iw=19 + dc=clog-float(ic-2)*.3+3. + dw=wlog-float(iw-2)*.3+4. + x1=cah(1,iw-1)+(cah(1,iw)-cah(1,iw-1))*xx*dw + x2=cah(ic-1,iw-1)+(cah(ic-1,iw)-cah(ic-1,iw-1))*xx*dw + y2=x2+(cah(ic,iw-1)-cah(ic-1,iw-1))*xx*dc + if (x1.lt.y2) x1=y2 + df(i,j,k)=df(i,j,k)+0.0343*(x1-y2) + enddo + enddo + enddo + + end subroutine flxco2 + +!***************************************************************** + + subroutine o3prof (np, pres, ozone, its, ite, kts, kte, p, o3) + +!***************************************************************** + implicit none +!***************************************************************** +! + integer iprof,m,np,its,ite,kts,kte + integer i,k,ko,kk + real pres(np),ozone(np) + real p(its:ite,kts:kte),o3(its:ite,kts:kte) + +! Statement function + + real Linear, x1, y1, x2, y2, x + Linear(x1, y1, x2, y2, x) = & + (y1 * (x2 - x) + y2 * (x - x1)) / (x2 - x1) +! + do k = 1,np + pres(k) = alog(pres(k)) + enddo + do k = kts,kte + do i = its, ite + p(i,k) = alog(p(i,k)) + end do + end do + +! assume the pressure at model top is greater than pres(1) +! if it is not, this part needs to change + + do i = its, ite + ko = 1 + do k = kts+1, kte + do while (ko .lt. np .and. p(i,k) .gt. pres(ko)) + ko = ko + 1 + end do + o3(i,k) = Linear (pres(ko), ozone(ko), & + pres(ko-1), ozone(ko-1), & + p(i,k)) + ko = ko - 1 + end do + end do + +! calculate top lay O3 + + do i = its, ite + ko = 1 + k = kts + do while (ko .le. np .and. p(i,k) .gt. pres(ko)) + ko = ko + 1 + end do + IF (ko-1 .le. 1) then + O3(i,k)=ozone(k) + ELSE + O3(i,k)=0. + do kk=ko-2,1,-1 + O3(i,k)=O3(i,k)+ozone(kk)*(pres(kk+1)-pres(kk)) + enddo + O3(i,k)=O3(i,k)/(pres(ko-1)-pres(1)) + ENDIF +! print*,'O3=',i,k,ko,O3(i,k),p(i,k),ko,pres(ko),pres(ko-1) + end do + + end subroutine o3prof + +!----------------------------------------- + SUBROUTINE gsfc_swinit(cen_lat, allowed_to_read) + + REAL, INTENT(IN ) :: cen_lat + LOGICAL, INTENT(IN ) :: allowed_to_read + + center_lat=cen_lat + + END SUBROUTINE gsfc_swinit + + +END MODULE module_ra_gsfcsw diff --git a/wrfv2_fire/phys/module_ra_rrtm.F b/wrfv2_fire/phys/module_ra_rrtm.F new file mode 100644 index 00000000..4abfdcf4 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_rrtm.F @@ -0,0 +1,7408 @@ + +MODULE module_ra_rrtm + +! Parameters + + INTEGER, PRIVATE :: IDATA + INTEGER, PARAMETER :: MG=16 + INTEGER, PARAMETER :: NBANDS=16 + INTEGER, PARAMETER :: NGPT=140 + INTEGER, PARAMETER :: NG1=8 + INTEGER, PARAMETER :: NG2=14 + INTEGER, PARAMETER :: NG3=16 + INTEGER, PARAMETER :: NG4=14 + INTEGER, PARAMETER :: NG5=16 + INTEGER, PARAMETER :: NG6=8 + INTEGER, PARAMETER :: NG7=12 + INTEGER, PARAMETER :: NG8=8 + INTEGER, PARAMETER :: NG9=12 + INTEGER, PARAMETER :: NG10=6 + INTEGER, PARAMETER :: NG11=8 + INTEGER, PARAMETER :: NG12=8 + INTEGER, PARAMETER :: NG13=4 + INTEGER, PARAMETER :: NG14=2 + INTEGER, PARAMETER :: NG15=2 + INTEGER, PARAMETER :: NG16=2 + INTEGER, PARAMETER :: MAXINPX=35 + INTEGER, PARAMETER :: MAXXSEC=4 + + INTEGER, PARAMETER :: NMOL = 6 + REAL, PARAMETER :: ONEMINUS = 1. - 1.E-6 + +! var + + REAL , SAVE :: FLUXFAC + INTEGER , SAVE :: NLAYERS +! +! data 1 +! + REAL,SAVE :: abscoefL1(5,13,MG), abscoefH1(5,13:59,MG), & + SELFREF1(10,MG) + REAL,SAVE :: abscoefL2(5,13,MG), abscoefH2(5,13:59,MG), & + SELFREF2(10,MG) + REAL,SAVE :: abscoefL3(10,5,13,MG), abscoefH3(5,5,13:59,MG), & + SELFREF3(10,MG) + REAL,SAVE :: abscoefL4(9,5,13,MG), abscoefH4(6,5,13:59,MG), & + SELFREF4(10,MG) + REAL,SAVE :: abscoefL5(9,5,13,MG), abscoefH5(5,5,13:59,MG), & + SELFREF5(10,MG) + REAL,SAVE :: abscoefL6(5,13,MG), SELFREF6(10,MG) + REAL,SAVE :: abscoefL7(9,5,13,MG), abscoefH7(5,13:59,MG), & + SELFREF7(10,MG) + REAL,SAVE :: abscoefL8(5,7,MG), abscoefH8(5,7:59,MG), & + SELFREF8(10,MG) + REAL,SAVE :: abscoefL9(11,5,13,MG), abscoefH9(5,13:59,MG), & + SELFREF9(10,MG) + REAL,SAVE :: abscoefL10(5,13,MG), abscoefH10(5,13:59,MG) + REAL,SAVE :: abscoefL11(5,13,MG), abscoefH11(5,13:59,MG), & + SELFREF11(10,MG) + REAL,SAVE :: abscoefL12(9,5,13,MG), SELFREF12(10,MG) + REAL,SAVE :: abscoefL13(9,5,13,MG), SELFREF13(10,MG) + REAL,SAVE :: abscoefL14(5,13,MG), abscoefH14(5,13:59,MG), & + SELFREF14(10,MG) + REAL,SAVE :: abscoefL15(9,5,13,MG), SELFREF15(10,MG) + REAL,SAVE :: abscoefL16(9,5,13,MG), SELFREF16(10,MG) + +! +! data 2 +! + INTEGER,SAVE :: NGM(MG*NBANDS), NGC(NBANDS), NGS(NBANDS), & + NGN(NGPT), NGB(NGPT) + REAL,SAVE :: WT(MG) +! +! data 3 +! + REAL,SAVE :: FRACREFA1(MG), FRACREFB1(MG), FORREF1(MG) + REAL,SAVE :: FRACREFA2(MG,13), FRACREFB2(MG), FORREF2(MG) + REAL,SAVE :: FRACREFA3(MG,10), FRACREFB3(MG,5) + REAL,SAVE :: FORREF3(MG), ABSN2OA3(MG), ABSN2OB3(MG) + REAL,SAVE :: FRACREFA4(MG,9), FRACREFB4(MG,6) + REAL,SAVE :: FRACREFA5(MG,9), FRACREFB5(MG,5), CCL45(MG) + REAL,SAVE :: FRACREFA6(MG), ABSCO26(MG), CFC11ADJ6(MG), CFC126(MG) + REAL,SAVE :: FRACREFA7(MG,9), FRACREFB7(MG), ABSCO27(MG) + REAL,SAVE :: FRACREFA8(MG), FRACREFB8(MG), ABSCO2A8(MG), ABSCO2B8(MG) + REAL,SAVE :: ABSN2OA8(MG), ABSN2OB8(MG), CFC128(MG), CFC22ADJ8(MG) + REAL,SAVE :: FRACREFA9(MG,9), FRACREFB9(MG), ABSN2O9(3*MG) + REAL,SAVE :: FRACREFA10(MG), FRACREFB10(MG) + REAL,SAVE :: FRACREFA11(MG), FRACREFB11(MG) + REAL,SAVE :: FRACREFA12(MG,9) + REAL,SAVE :: FRACREFA13(MG,9) + REAL,SAVE :: FRACREFA14(MG), FRACREFB14(MG) + REAL,SAVE :: FRACREFA15(MG,9) + REAL,SAVE :: FRACREFA16(MG,9) +! +! data 4 +! + INTEGER,SAVE :: NXMOL, IXINDX(MAXINPX) + +! data 5 + + REAL,SAVE :: WAVENUM1(NBANDS),WAVENUM2(NBANDS),DELWAVE(NBANDS) + +! data 6 + + INTEGER,SAVE :: NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) + REAL, SAVE :: HEATFAC + REAL, SAVE :: PREF(59),PREFLOG(59),TREF(59) + +! data 7 + + REAL, SAVE :: TOTPLNK(181,NBANDS), TOTPLK16(181) + +! data + + REAL, SAVE :: TAU(0:5000),TF(0:5000),TRANS(0:5000) +! + REAL, SAVE :: ABSA1(5*13,NG1), ABSB1(5*(59-13+1),NG1), & + SELFREFC1(10,NG1), FORREFC1(NG1) + REAL, SAVE :: ABSA2(5*13,NG2), ABSB2(5*(59-13+1),NG2), & + SELFREFC2(10,NG2), FORREFC2(NG2) + REAL, SAVE :: ABSA3(10*5*13,NG3), ABSB3(5*5*(59-13+1),NG3), & + SELFREFC3(10,NG3), FORREFC3(NG3), & + ABSN2OAC3(NG3), ABSN2OBC3(NG3) + REAL, SAVE :: ABSA4(9*5*13,NG4), ABSB4(6*5*(59-13+1),NG4), & + SELFREFC4(10,NG4) + REAL, SAVE :: ABSA5(9*5*13,NG5), ABSB5(5*5*(59-13+1),NG5), & + SELFREFC5(10,NG5), CCL4C5(NG5) + REAL, SAVE :: ABSA6(5*13,NG6), SELFREFC6(10,NG6), & + ABSCO2C6(NG6), CFC11ADJC6(NG6), CFC12C6(NG6) + REAL, SAVE :: ABSA7(9*5*13,NG7), ABSB7(5*(59-13+1),NG7), & + SELFREFC7(10,NG7), ABSCO2C7(NG7) + REAL, SAVE :: ABSA8(5*7,NG8), ABSB8(5*(59-7+1),NG8), & + SELFREFC8(10,NG8), & + ABSCO2AC8(NG8), ABSCO2BC8(NG8), & + ABSN2OAC8(NG8), ABSN2OBC8(NG8), & + CFC12C8(NG8), CFC22ADJC8(NG8) + REAL, SAVE :: ABSA9(11*5*13,NG9), ABSB9(5*(59-13+1),NG9), & + SELFREFC9(10,NG9), ABSN2OC9(3*NG9) + REAL, SAVE :: ABSA10(5*13,NG10), ABSB10(5*(59-13+1),NG10) + REAL, SAVE :: ABSA11(5*13,NG11), ABSB11(5*(59-13+1),NG11), & + SELFREFC11(10,NG11) + REAL, SAVE :: ABSA12(9*5*13,NG12), SELFREFC12(10,NG12) + REAL, SAVE :: ABSA13(9*5*13,NG13), SELFREFC13(10,NG13) + REAL, SAVE :: ABSA14(5*13,NG14), ABSB14(5*(59-13+1),NG14), & + SELFREFC14(10,NG14) + REAL, SAVE :: ABSA15(9*5*13,NG15), SELFREFC15(10,NG15) + REAL, SAVE :: ABSA16(9*5*13,NG16), SELFREFC16(10,NG16) + + REAL, SAVE :: FRACREFAC1(NG1), FRACREFBC1(NG1) + REAL, SAVE :: FRACREFAC2(NG2,13), FRACREFBC2(NG2) + REAL, SAVE :: FRACREFAC3(NG3,10), FRACREFBC3(NG3,5) + REAL, SAVE :: FRACREFAC4(NG4,9), FRACREFBC4(NG4,6) + REAL, SAVE :: FRACREFAC5(NG5,9), FRACREFBC5(NG5,5) + REAL, SAVE :: FRACREFAC6(NG6) + REAL, SAVE :: FRACREFAC7(NG7,9), FRACREFBC7(NG7) + REAL, SAVE :: FRACREFAC8(NG8), FRACREFBC8(NG8) + REAL, SAVE :: FRACREFAC9(NG9,9), FRACREFBC9(NG9) + REAL, SAVE :: FRACREFAC10(NG10), FRACREFBC10(NG10) + REAL, SAVE :: FRACREFAC11(NG11), FRACREFBC11(NG11) + REAL, SAVE :: FRACREFAC12(NG12,9) + REAL, SAVE :: FRACREFAC13(NG13,9) + REAL, SAVE :: FRACREFAC14(NG14), FRACREFBC14(NG14) + REAL, SAVE :: FRACREFAC15(NG15,9) + REAL, SAVE :: FRACREFAC16(NG16,9) + + REAL, SAVE :: CORR1(0:200),CORR2(0:200) + REAL, SAVE :: BPADE + REAL, SAVE :: RWGT(MG*NBANDS) + +!---------------------------------------------------------------------------- +! +! start data 2 + +! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands: +! This mapping from 256 to 140 points has been carefully selected to +! minimize the effect on the resulting fluxes and cooling rates, and +! caution should be used if the mapping is modified. +! +! NGPT The total number of new g-points +! NGC The number of new g-points in each band +! NGM The index of each new g-point relative to the original +! 16 g-points for each band. +! NGN The number of original g-points that are combined to make +! each new g-point in each band. +! NGB The band index for each new g-point. +! WT RRTM weights for 16 g-points. + +! Data Statements + DATA NGC /8,14,16,14,16,8,12,8,12,6,8,8,4,2,2,2/ + DATA NGS /8,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/ + DATA NGM /1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! Band 1 + 1,2,3,4,5,6,7,8,9,10,11,12,13,13,14,14, & ! Band 2 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! Band 3 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! Band 4 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! Band 5 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! Band 6 + 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! Band 7 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! Band 8 + 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! Band 9 + 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! Band 10 + 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! Band 11 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! Band 12 + 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! Band 13 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! Band 14 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! Band 15 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2/ ! Band 16 + DATA NGN /2,2,2,2,2,2,2,2, & ! Band 1 + 1,1,1,1,1,1,1,1,1,1,1,1,2,2, & ! Band 2 + 16*1, & ! Band 3 + 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! Band 4 + 16*1, & ! Band 5 + 2,2,2,2,2,2,2,2, & ! Band 6 + 2,2,1,1,1,1,1,1,1,1,2,2, & ! Band 7 + 2,2,2,2,2,2,2,2, & ! Band 8 + 1,1,1,1,1,1,1,1,2,2,2,2, & ! Band 9 + 2,2,2,2,4,4, & ! Band 10 + 1,1,2,2,2,2,3,3, & ! Band 11 + 1,1,1,1,2,2,4,4, & ! Band 12 + 3,3,4,6, & ! Band 13 + 8,8, & ! Band 14 + 8,8, & ! Band 15 + 8,8/ ! Band 16 + DATA NGB /8*1, & ! Band 1 + 14*2, & ! Band 2 + 16*3, & ! Band 3 + 14*4, & ! Band 4 + 16*5, & ! Band 5 + 8*6, & ! Band 6 + 12*7, & ! Band 7 + 8*8, & ! Band 8 + 12*9, & ! Band 9 + 6*10, & ! Band 10 + 8*11, & ! Band 11 + 8*12, & ! Band 12 + 4*13, & ! Band 13 + 2*14, & ! Band 14 + 2*15, & ! Band 15 + 2*16/ ! Band 16 + DATA WT/ & + 0.1527534276,0.1491729617,0.1420961469,0.1316886544, & + 0.1181945205,0.1019300893,0.0832767040,0.0626720116, & + 0.0424925,0.0046269894,0.0038279891,0.0030260086, & + 0.0022199750,0.0014140010,0.000533,0.000075/ + +! +! end of data 2 +! +!----------------------------------------------------------------------- + +! start data 3 + + +! Data + + DATA FRACREFA1/ & + 0.08452097,0.17952873,0.16214369,0.13602182, & + 0.12760490,0.10302561,0.08392423,0.06337652, & + 0.04206551,0.00487497,0.00410743,0.00344421, & + 0.00285731,0.00157327,0.00080648,0.00012406/ + DATA FRACREFB1/ & + 0.15492001,0.17384727,0.15165100,0.12675308, & + 0.10986247,0.09006091,0.07584465,0.05990077, & + 0.04113461,0.00438638,0.00374754,0.00313924, & + 0.00234381,0.00167167,0.00062744,0.00010889/ + + DATA FORREF1/ & + -4.50470E-02,-1.18908E-01,-7.21730E-02,-2.83862E-02, & + -3.01961E-02,-1.56877E-02,-1.53684E-02,-1.29135E-02, & + -1.27963E-02,-1.81742E-03, 4.40008E-05, 1.05260E-02, & + 2.17290E-02, 1.65571E-02, 7.60751E-02, 1.47405E-01/ + + +! Data + +! The ith set of reference fractions are from the ith reference +! pressure level. + + DATA FRACREFA2/ & + 0.18068060,0.16803175,0.15140158,0.12221480, 0.10240850,0.09330297,0.07518960,0.05611294, & + 0.03781487,0.00387192,0.00321285,0.00244440, 0.00179546,0.00107704,0.00038798,0.00005060, & + 0.17927621,0.16731168,0.15129538,0.12328085, 0.10243484,0.09354796,0.07538418,0.05633071, & + 0.03810832,0.00398347,0.00320262,0.00250029, 0.00178666,0.00111127,0.00039438,0.00005169, & + 0.17762886,0.16638555,0.15115446,0.12470623, 0.10253213,0.09383459,0.07560240,0.05646568, & + 0.03844077,0.00409142,0.00322521,0.00254918, 0.00179296,0.00113652,0.00040169,0.00005259, & + 0.17566043,0.16539773,0.15092199,0.12571971, 0.10340609,0.09426189,0.07559051,0.05678188, & + 0.03881499,0.00414102,0.00328551,0.00258795, 0.00181648,0.00115145,0.00040969,0.00005357, & + 0.17335825,0.16442548,0.15070701,0.12667464, 0.10452303,0.09450833,0.07599410,0.05706393, & + 0.03910370,0.00417880,0.00335256,0.00261708, 0.00185491,0.00116627,0.00041759,0.00005464, & + 0.17082544,0.16321516,0.15044247,0.12797612, 0.10574646,0.09470057,0.07647423,0.05738756, & + 0.03935621,0.00423789,0.00342651,0.00264549, 0.00190188,0.00118281,0.00042592,0.00005583, & + 0.16809277,0.16193336,0.15013184,0.12937409, 0.10720784,0.09485368,0.07692636,0.05771774, & + 0.03966988,0.00427754,0.00349696,0.00268946, 0.00193536,0.00120222,0.00043462,0.00005712, & + 0.16517997,0.16059248,0.14984852,0.13079269, 0.10865030,0.09492947,0.07759736,0.05812201, & + 0.03997169,0.00432356,0.00355308,0.00274031, 0.00197243,0.00122401,0.00044359,0.00005849, & + 0.16209179,0.15912023,0.14938223,0.13198245, 0.11077233,0.09487948,0.07831636,0.05863440, & + 0.04028239,0.00436804,0.00360407,0.00279885, 0.00200364,0.00124861,0.00045521,0.00005996, & + 0.15962425,0.15789343,0.14898103,0.13275230, 0.11253940,0.09503502,0.07884382,0.05908009, & + 0.04053524,0.00439971,0.00364269,0.00284965, 0.00202758,0.00127076,0.00046408,0.00006114, & + 0.15926200,0.15770932,0.14891729,0.13283882, 0.11276010,0.09507311,0.07892222,0.05919230, & + 0.04054824,0.00440833,0.00365575,0.00286459, 0.00203786,0.00128405,0.00046504,0.00006146, & + 0.15926351,0.15770483,0.14891177,0.13279966, 0.11268171,0.09515216,0.07890341,0.05924807, & + 0.04052851,0.00440870,0.00365425,0.00286878, 0.00205747,0.00128916,0.00046589,0.00006221, & + 0.15937765,0.15775780,0.14892603,0.13273248, 0.11252731,0.09521657,0.07885858,0.05927679, & + 0.04050184,0.00440285,0.00365748,0.00286791, 0.00207507,0.00129193,0.00046679,0.00006308/ +! From P = 0.432 mb. + DATA FRACREFB2/ & + 0.17444289,0.16467269,0.15021490,0.12460902, & + 0.10400643,0.09481928,0.07590704,0.05752856, & + 0.03931715,0.00428572,0.00349352,0.00278938, & + 0.00203448,0.00130037,0.00051560,0.00006255/ + + DATA FORREF2/ & + -2.34550E-03,-8.42698E-03,-2.01816E-02,-5.66701E-02, & + -8.93189E-02,-6.37487E-02,-4.56455E-02,-4.41417E-02, & + -4.48605E-02,-4.74696E-02,-5.16648E-02,-5.63099E-02, & + -4.74781E-02,-3.84704E-02,-2.49905E-02, 2.02114E-03/ + +! Data + + DATA FRACREFA3/ & +! From P = 1053.6 mb. + 0.15116400,0.14875700,0.14232300,0.13234501, 0.11881600,0.10224100,0.08345580,0.06267490, & + 0.04250650,0.00462650,0.00382259,0.00302600, 0.00222004,0.00141397,0.00053379,0.00007421, & + 0.15266000,0.14888400,0.14195900,0.13179500, 0.11842700,0.10209000,0.08336130,0.06264370, & + 0.04247660,0.00461946,0.00381536,0.00302601, 0.00222004,0.00141397,0.00053302,0.00007498, & + 0.15282799,0.14903000,0.14192399,0.13174300, 0.11835300,0.10202700,0.08329830,0.06264830, & + 0.04246910,0.00460242,0.00381904,0.00301573, 0.00222004,0.00141397,0.00053379,0.00007421, & + 0.15298399,0.14902800,0.14193401,0.13173500, 0.11833300,0.10195800,0.08324730,0.06264770, & + 0.04246490,0.00460489,0.00381123,0.00301893, 0.00221093,0.00141397,0.00053379,0.00007421, & + 0.15307599,0.14907201,0.14198899,0.13169800, 0.11827300,0.10192300,0.08321600,0.06263490, & + 0.04245600,0.00460846,0.00380836,0.00301663, 0.00221402,0.00141167,0.00052807,0.00007376, & + 0.15311401,0.14915401,0.14207301,0.13167299, 0.11819300,0.10188900,0.08318760,0.06261960, & + 0.04243890,0.00461584,0.00380929,0.00300815, 0.00221736,0.00140588,0.00052776,0.00007376, & + 0.15316001,0.14925499,0.14213000,0.13170999, 0.11807700,0.10181400,0.08317400,0.06260300, & + 0.04242720,0.00461520,0.00381381,0.00301285, 0.00220275,0.00140371,0.00052776,0.00007376, & + 0.15321200,0.14940999,0.14222500,0.13164200, 0.11798200,0.10174500,0.08317500,0.06253640, & + 0.04243130,0.00461724,0.00381534,0.00300320, 0.00220091,0.00140364,0.00052852,0.00007300, & + 0.15312800,0.14973100,0.14234400,0.13168900, 0.11795200,0.10156100,0.08302990,0.06252240, & + 0.04240980,0.00461035,0.00381381,0.00300176, 0.00220160,0.00140284,0.00052774,0.00007376, & + 0.15292500,0.14978001,0.14242400,0.13172600, 0.11798800,0.10156400,0.08303050,0.06251670, & + 0.04240970,0.00461302,0.00381452,0.00300250, 0.00220126,0.00140324,0.00052850,0.00007300/ + DATA FRACREFB3/ & +! From P = 64.1 mb. + 0.16340201,0.15607700,0.14601400,0.13182700, & + 0.11524700,0.09666570,0.07825360,0.05849780, & + 0.03949650,0.00427980,0.00353719,0.00279303, & + 0.00204788,0.00130139,0.00049055,0.00006904, & + 0.15762900,0.15494700,0.14659800,0.13267800, & + 0.11562700,0.09838360,0.07930420,0.05962700, & + 0.04036360,0.00438053,0.00361463,0.00285723, & + 0.00208345,0.00132135,0.00050528,0.00008003, & + 0.15641500,0.15394500,0.14633600,0.13180400, & + 0.11617100,0.09924170,0.08000510,0.06021420, & + 0.04082730,0.00441694,0.00365364,0.00287723, & + 0.00210914,0.00135784,0.00054651,0.00008003, & + 0.15482700,0.15286300,0.14392500,0.13244100, & + 0.11712000,0.09994920,0.08119200,0.06104360, & + 0.04135600,0.00446685,0.00368377,0.00290767, & + 0.00215445,0.00142865,0.00056142,0.00008003, & + 0.15975100,0.15653500,0.14214399,0.12892200, & + 0.11508400,0.09906020,0.08087940,0.06078190, & + 0.04140530,0.00452724,0.00374558,0.00295328, & + 0.00218509,0.00138644,0.00056018,0.00008003/ + + DATA ABSN2OA3/ & + 1.50387E-01,2.91407E-01,6.28803E-01,9.65619E-01, & + 1.15054E-00,2.23424E-00,1.83392E-00,1.39033E-00, & + 4.28457E-01,2.73502E-01,1.84307E-01,1.61325E-01, & + 7.66314E-02,1.33862E-01,6.71196E-07,1.59293E-06/ + DATA ABSN2OB3/ & + 9.37044E-05,1.23318E-03,7.91720E-03,5.33005E-02, & + 1.72343E-01,4.29571E-01,1.01288E+00,3.83863E+00, & + 1.15312E+01,1.08383E+00,2.24847E+00,1.51268E+00, & + 3.33177E-01,7.82102E-01,3.44631E-01,1.61039E-03/ + DATA FORREF3/ & + 1.76842E-04, 1.77913E-04, 1.25186E-04, 1.07912E-04, & + 1.05217E-04, 7.48726E-05, 1.11701E-04, 7.68921E-05, & + 9.87242E-05, 9.85711E-05, 6.16557E-05,-1.61291E-05, & + -1.26794E-04,-1.19011E-04,-2.67814E-04, 6.95005E-05/ + +! Data + + DATA FRACREFA4/ & +! From P = + 0.15579100,0.14918099,0.14113800,0.13127001, & + 0.11796300,0.10174300,0.08282370,0.06238150, & + 0.04213440,0.00458968,0.00377949,0.00298736, & + 0.00220743,0.00140644,0.00053024,0.00007459, & + 0.15292799,0.15004000,0.14211500,0.13176700, & + 0.11821100,0.10186300,0.08288040,0.06241390, & + 0.04220720,0.00459006,0.00377919,0.00298743, & + 0.00220743,0.00140644,0.00053024,0.00007459, & + 0.14386199,0.15125300,0.14650001,0.13377000, & + 0.11895900,0.10229400,0.08312110,0.06239520, & + 0.04225560,0.00459428,0.00378865,0.00298860, & + 0.00220743,0.00140644,0.00053024,0.00007459, & + 0.14359100,0.14561599,0.14479300,0.13740200, & + 0.12150100,0.10315400,0.08355480,0.06247240, & + 0.04230980,0.00459916,0.00378373,0.00300063, & + 0.00221111,0.00140644,0.00053024,0.00007459, & + 0.14337599,0.14451601,0.14238000,0.13520500, & + 0.12354200,0.10581200,0.08451810,0.06262440, & + 0.04239590,0.00460297,0.00378701,0.00300466, & + 0.00221899,0.00141020,0.00053024,0.00007459, & + 0.14322001,0.14397401,0.14117201,0.13401900, & + 0.12255500,0.10774100,0.08617650,0.06296420, & + 0.04249590,0.00463406,0.00378241,0.00302037, & + 0.00221583,0.00141103,0.00053814,0.00007991, & + 0.14309500,0.14364301,0.14043900,0.13348100, & + 0.12211600,0.10684700,0.08820590,0.06374610, & + 0.04264730,0.00464231,0.00384022,0.00303427, & + 0.00221825,0.00140943,0.00055564,0.00007991, & + 0.15579100,0.14918099,0.14113800,0.13127001, & + 0.11796300,0.10174300,0.08282370,0.06238150, & + 0.04213440,0.00458968,0.00377949,0.00298736, & + 0.00220743,0.00140644,0.00053024,0.00007459, & + 0.15937001,0.15159500,0.14242800,0.13078900, & + 0.11671300,0.10035700,0.08143450,0.06093850, & + 0.04105320,0.00446233,0.00369844,0.00293784, & + 0.00216425,0.00143403,0.00054571,0.00007991/ + DATA FRACREFB4/ & +! From P = 1.17 mb. + 0.15558299,0.14930600,0.14104301,0.13124099, & + 0.11792900,0.10159200,0.08314130,0.06240450, & + 0.04217020,0.00459313,0.00379798,0.00299835, & + 0.00218950,0.00140615,0.00053010,0.00007457, & + 0.15592700,0.14918999,0.14095700,0.13115700, & + 0.11788900,0.10158000,0.08313780,0.06240240, & + 0.04217000,0.00459313,0.00379798,0.00299835, & + 0.00218950,0.00140615,0.00053010,0.00007457, & + 0.15949000,0.15014900,0.14162201,0.13080800, & + 0.11713500,0.10057100,0.08170080,0.06128110, & + 0.04165600,0.00459202,0.00379835,0.00299717, & + 0.00218958,0.00140616,0.00053010,0.00007457, & + 0.15967900,0.15038200,0.14196999,0.13074800, & + 0.11701700,0.10053000,0.08160790,0.06122690, & + 0.04128310,0.00456598,0.00379486,0.00299457, & + 0.00219016,0.00140619,0.00053011,0.00007456, & + 0.15989800,0.15057300,0.14207700,0.13068600, & + 0.11682900,0.10053900,0.08163610,0.06121870, & + 0.04121690,0.00449061,0.00371235,0.00294207, & + 0.00217778,0.00139877,0.00053011,0.00007455, & + 0.15950100,0.15112500,0.14199100,0.13071300, & + 0.11680800,0.10054600,0.08179050,0.06120910, & + 0.04126050,0.00444324,0.00366843,0.00289369, & + 0.00211550,0.00134746,0.00050874,0.00007863/ + +! Data + + DATA FRACREFA5/ & +! From P = 387.6 mb. + 0.13966499,0.14138900,0.13763399,0.13076700, & + 0.12299100,0.10747700,0.08942000,0.06769200, & + 0.04587610,0.00501173,0.00415809,0.00328398, & + 0.00240015,0.00156222,0.00059104,0.00008323, & + 0.13958199,0.14332899,0.13785399,0.13205400, & + 0.12199700,0.10679600,0.08861080,0.06712320, & + 0.04556030,0.00500863,0.00416315,0.00328629, & + 0.00240023,0.00156220,0.00059104,0.00008323, & + 0.13907100,0.14250501,0.13889600,0.13297300, & + 0.12218700,0.10683800,0.08839260,0.06677310, & + 0.04538570,0.00495402,0.00409863,0.00328219, & + 0.00240805,0.00156266,0.00059104,0.00008323, & + 0.13867700,0.14190100,0.13932300,0.13327099, & + 0.12280800,0.10692500,0.08844510,0.06658510, & + 0.04519340,0.00492276,0.00408832,0.00323856, & + 0.00239289,0.00155698,0.00059104,0.00008323, & + 0.13845000,0.14158800,0.13929300,0.13295600, & + 0.12348300,0.10736700,0.08859480,0.06650610, & + 0.04498230,0.00491335,0.00406968,0.00322901, & + 0.00234666,0.00155235,0.00058813,0.00008323, & + 0.13837101,0.14113200,0.13930500,0.13283101, & + 0.12349200,0.10796400,0.08890490,0.06646480, & + 0.04485990,0.00489554,0.00405264,0.00320313, & + 0.00234742,0.00151159,0.00058438,0.00008253, & + 0.13834500,0.14093500,0.13896500,0.13262001, & + 0.12326900,0.10828900,0.08950050,0.06674610, & + 0.04476560,0.00489624,0.00400962,0.00317423, & + 0.00233479,0.00148249,0.00058590,0.00008253, & + 0.13831300,0.14069000,0.13871400,0.13247600, & + 0.12251400,0.10831300,0.08977090,0.06776920, & + 0.04498390,0.00484111,0.00398948,0.00316069, & + 0.00229741,0.00150104,0.00058608,0.00008253, & + 0.14027201,0.14420401,0.14215700,0.13446601, & + 0.12303700,0.10596100,0.08650370,0.06409570, & + 0.04312310,0.00471110,0.00393954,0.00310850, & + 0.00229588,0.00146366,0.00058194,0.00008253/ + DATA FRACREFB5/ & +! From P = 1.17 mb. + 0.14339100,0.14358699,0.13935301,0.13306700, & + 0.12135700,0.10590600,0.08688240,0.06553220, & + 0.04446740,0.00483580,0.00399413,0.00316225, & + 0.00233007,0.00149135,0.00056246,0.00008059, & + 0.14330500,0.14430299,0.14053699,0.13355300, & + 0.12151200,0.10529100,0.08627630,0.06505230, & + 0.04385850,0.00476555,0.00395010,0.00313878, & + 0.00232273,0.00149354,0.00056246,0.00008059, & + 0.14328399,0.14442700,0.14078601,0.13390100, & + 0.12132600,0.10510600,0.08613660,0.06494630, & + 0.04381310,0.00475378,0.00394166,0.00313076, & + 0.00231235,0.00149159,0.00056301,0.00008059, & + 0.14326900,0.14453100,0.14114200,0.13397101, & + 0.12127200,0.10493400,0.08601380,0.06483360, & + 0.04378900,0.00474655,0.00393549,0.00312583, & + 0.00230686,0.00148433,0.00056502,0.00008059, & + 0.14328900,0.14532700,0.14179000,0.13384600, & + 0.12093700,0.10461500,0.08573010,0.06461340, & + 0.04366570,0.00473087,0.00392539,0.00311238, & + 0.00229865,0.00147572,0.00056517,0.00007939/ + + DATA CCL45/ & + 26.1407, 53.9776, 63.8085, 36.1701, & + 15.4099, 10.23116, 4.82948, 5.03836, & + 1.75558,0.,0.,0., & + 0.,0.,0.,0./ + +! Data + + DATA FRACREFA6/ & +! From P = 706 mb. + 0.13739009,0.14259538,0.14033118,0.13547136, & + 0.12569460,0.11028396,0.08626066,0.06245148, & + 0.04309394,0.00473551,0.00403920,0.00321695, & + 0.00232470,0.00147662,0.00056095,0.00007373/ + + DATA CFC11ADJ6/ & + 0., 0., 36.7627, 150.757, & + 81.4109, 74.9112, 56.9325, 49.3226, & + 57.1074, 66.1202, 109.557, 89.0562, & + 149.865, 196.140, 258.393, 80.9923/ + DATA CFC126/ & + 62.8368, 43.2626, 26.7549, 22.2487, & + 23.5029, 34.8323, 26.2335, 23.2306, & + 18.4062, 13.9534, 22.6268, 24.2604, & + 30.0088, 26.3634, 15.8237, 57.5050/ + DATA ABSCO26/ & + 7.44852E-05, 6.29208E-05, 7.34031E-05, 6.65218E-05, & + 7.87511E-05, 1.22489E-04, 3.39785E-04, 9.33040E-04, & + 1.54323E-03, 4.07220E-04, 4.34332E-04, 8.76418E-05, & + 9.80381E-05, 3.51680E-05, 5.31766E-05, 1.01542E-05/ + +! Data + + DATA FRACREFA7/ & + 0.16461779, 0.14889984, 0.14233345, 0.13156526, & + 0.11679733, 0.09988949, 0.08078653, 0.06006384, & + 0.04028391, 0.00435899, 0.00359173, 0.00281707, & + 0.00206767, 0.00135012, 0.00050720, 0.00007146, & + 0.16442357, 0.14944240, 0.14245804, 0.13111183, & + 0.11688625, 0.09983791, 0.08085148, 0.05993948, & + 0.04028057, 0.00435939, 0.00358708, 0.00284036, & + 0.00208869, 0.00133256, 0.00049260, 0.00006931, & + 0.16368519, 0.15018989, 0.14262174, 0.13084342, & + 0.11682195, 0.09996257, 0.08074036, 0.05985692, & + 0.04045362, 0.00436208, 0.00358257, 0.00287122, & + 0.00211004, 0.00133804, 0.00049260, 0.00006931, & + 0.16274056, 0.15133780, 0.14228874, 0.13081114, & + 0.11688486, 0.09979610, 0.08073687, 0.05996741, & + 0.04040616, 0.00439869, 0.00368910, 0.00293041, & + 0.00211604, 0.00133536, 0.00049260, 0.00006931, & + 0.16176532, 0.15207882, 0.14226955, 0.13079646, & + 0.11688191, 0.09966998, 0.08066384, 0.06020275, & + 0.04047901, 0.00446696, 0.00377456, 0.00294410, & + 0.00211082, 0.00133536, 0.00049260, 0.00006931, & + 0.15993737, 0.15305527, 0.14259829, 0.13078023, & + 0.11686983, 0.09980131, 0.08058286, 0.06031430, & + 0.04082833, 0.00450509, 0.00377574, 0.00294823, & + 0.00210977, 0.00133302, 0.00049260, 0.00006931, & + 0.15371189, 0.15592396, 0.14430280, 0.13076764, & + 0.11720382, 0.10023471, 0.08066396, 0.06073554, & + 0.04121581, 0.00451202, 0.00377832, 0.00294609, & + 0.00210943, 0.00133336, 0.00049260, 0.00006931, & + 0.14262275, 0.14572631, 0.14560597, 0.13736825, & + 0.12271351, 0.10419556, 0.08294533, 0.06199794, & + 0.04157615, 0.00452842, 0.00377704, 0.00293852, & + 0.00211034, 0.00133278, 0.00049259, 0.00006931, & + 0.14500433, 0.14590444, 0.14430299, 0.13770708, & + 0.12288283, 0.10350952, 0.08269450, 0.06130579, & + 0.04144571, 0.00452096, 0.00377382, 0.00294532, & + 0.00210943, 0.00133228, 0.00049260, 0.00006931/ + DATA FRACREFB7/ & + 0.15355594,0.15310939,0.14274909,0.13129812, & + 0.11736792,0.10118213,0.08215259,0.06165591, & + 0.04164486,0.00451141,0.00372837,0.00294095, & + 0.00215259,0.00136792,0.00051233,0.00007075/ + + DATA ABSCO27/ & + 9.30038E-05, 1.74061E-04, 2.09293E-04, 2.52360E-04, & + 3.13404E-04, 4.16619E-04, 6.27394E-04, 1.29386E-03, & + 4.05192E-03, 3.97050E-03, 7.00634E-04, 6.06617E-04, & + 7.66978E-04, 6.70661E-04, 7.89971E-04, 7.55709E-04/ + +! Data + + DATA FRACREFA8/ & +! From P = 1053.6 mb. + 0.15309700,0.15450300,0.14458799,0.13098200, & + 0.11817900,0.09953490,0.08132080,0.06139960, & + 0.04132010,0.00446788,0.00372533,0.00294053, & + 0.00211371,0.00128122,0.00048050,0.00006759/ + DATA FRACREFB8/ & +! From P = 28.9 mb. + 0.14105400,0.14728899,0.14264800,0.13331699, & + 0.12034100,0.10467000,0.08574980,0.06469390, & + 0.04394640,0.00481284,0.00397375,0.00315006, & + 0.00228636,0.00144606,0.00054604,0.00007697/ + + DATA CFC128/ & + 85.4027, 89.4696, 74.0959, 67.7480, & + 61.2444, 59.9073, 60.8296, 63.0998, & + 59.6110, 64.0735, 57.2622, 58.9721, & + 43.5505, 26.1192, 32.7023, 32.8667/ + DATA CFC22ADJ8/ & +! Original CFC22 is multiplied by 1.485 to account for the 780-850 cm-1 +! and 1290-1335 cm-1 bands. + 135.335, 89.6642, 76.2375, 65.9748, & + 63.1164, 60.2935, 64.0299, 75.4264, & + 51.3018, 7.07911, 5.86928, 0.398693, & + 2.82885, 9.12751, 6.28271, 0./ + DATA ABSCO2A8/ & + 1.11233E-05, 3.92400E-05, 6.62059E-05, 8.51687E-05, & + 7.79035E-05, 1.34058E-04, 2.82553E-04, 5.41741E-04, & + 1.47029E-05, 2.34982E-05, 6.91094E-08, 8.48917E-08, & + 6.58783E-08, 4.64849E-08, 3.62742E-08, 3.62742E-08/ + DATA ABSCO2B8/ & + 4.10977E-09, 5.65200E-08, 1.70800E-07, 4.16840E-07, & + 9.53684E-07, 2.36468E-06, 7.29502E-06, 4.93883E-05, & + 5.10440E-04, 9.75248E-04, 1.36495E-03, 2.40451E-03, & + 4.50277E-03, 2.24486E-02, 4.06756E-02, 2.17447E-10/ + DATA ABSN2OA8/ & + 1.28527E-02,5.28651E-02,1.01668E-01,1.57224E-01, & + 2.76947E-01,4.93048E-01,6.71387E-01,3.48809E-01, & + 4.19840E-01,3.13558E-01,2.44432E-01,2.05108E-01, & + 1.21423E-01,1.22158E-01,1.49702E-01,1.47799E-01/ + DATA ABSN2OB8/ & + 3.15864E-03,4.87347E-03,8.63235E-03,2.16053E-02, & + 3.63699E-02,7.89149E-02,3.53807E-01,1.27140E-00, & + 2.31464E-00,7.75834E-02,5.15063E-02,4.07059E-02, & + 5.91947E-02,5.83546E-02,3.12716E-01,1.47456E-01/ + +! Data + + DATA FRACREFA9/ & +! From P = 1053.6 mb. + 0.16898900,0.15898301,0.13575301,0.12600900, & + 0.11545800,0.09879170,0.08106830,0.06063440, & + 0.03988780,0.00421760,0.00346635,0.00278779, & + 0.00206225,0.00132324,0.00050033,0.00007038, & + 0.18209399,0.15315101,0.13571000,0.12504999, & + 0.11379100,0.09680810,0.08008570,0.05970280, & + 0.03942860,0.00413383,0.00343186,0.00275558, & + 0.00204657,0.00130219,0.00045454,0.00005664, & + 0.18459500,0.15512000,0.13395500,0.12576801, & + 0.11276800,0.09645190,0.07956650,0.05903340, & + 0.03887050,0.00412226,0.00339453,0.00273518, & + 0.00196922,0.00119411,0.00040263,0.00005664, & + 0.18458800,0.15859900,0.13278100,0.12589300, & + 0.11272700,0.09599660,0.07903030,0.05843600, & + 0.03843400,0.00405181,0.00337980,0.00263818, & + 0.00186869,0.00111807,0.00040263,0.00005664, & + 0.18459301,0.16176100,0.13235000,0.12528200, & + 0.11237100,0.09618840,0.07833760,0.05800770, & + 0.03787610,0.00408253,0.00330363,0.00250445, & + 0.00176725,0.00111753,0.00040263,0.00005664, & + 0.18454400,0.16505300,0.13221300,0.12476600, & + 0.11158300,0.09618120,0.07797340,0.05740380, & + 0.03742820,0.00392691,0.00312208,0.00246306, & + 0.00176735,0.00111721,0.00040263,0.00005664, & + 0.18452001,0.16697501,0.13445500,0.12391300, & + 0.11059100,0.09596890,0.07761050,0.05643200, & + 0.03686520,0.00377086,0.00309351,0.00246297, & + 0.00176765,0.00111700,0.00040263,0.00005664, & + 0.18460999,0.16854499,0.13922299,0.12266400, & + 0.10962200,0.09452030,0.07653800,0.05551340, & + 0.03609660,0.00377043,0.00309367,0.00246304, & + 0.00176749,0.00111689,0.00040263,0.00005664, & + 0.18312500,0.16787501,0.14720701,0.12766500, & + 0.10890900,0.08935530,0.07310870,0.05443140, & + 0.03566380,0.00376446,0.00309521,0.00246510, & + 0.00176139,0.00111543,0.00040263,0.00005664/ + DATA FRACREFB9/ & +! From P = 0.071 mb. + 0.20148601,0.15252700,0.13376500,0.12184600, & + 0.10767800,0.09307410,0.07674570,0.05876940, & + 0.04001480,0.00424612,0.00346896,0.00269954, & + 0.00196864,0.00122562,0.00043628,0.00004892/ + + DATA ABSN2O9/ & +! From P = 952 mb. + 3.26267E-01,2.42869E-00,1.15455E+01,7.39478E-00, & + 5.16550E-00,2.54474E-00,3.53082E-00,3.82278E-00, & + 1.81297E-00,6.65313E-01,1.23652E-01,1.83895E-03, & + 1.70592E-03,2.68434E-09,0.,0., & +! From P = 620 mb. + 2.08632E-01,1.11865E+00,4.95975E+00,8.10907E+00, & + 1.10408E+01,5.45460E+00,4.18611E+00,3.53422E+00, & + 2.54164E+00,3.65093E-01,5.84480E-01,2.26918E-01, & + 1.36230E-03,5.54400E-10,6.83703E-10,0., & +! From P = 313 mb. + 6.20022E-02,2.69521E-01,9.81928E-01,1.65004E-00, & + 3.08089E-00,5.38696E-00,1.14600E+01,2.41211E+01, & + 1.69655E+01,1.37556E-00,5.43254E-01,3.52079E-01, & + 4.31888E-01,4.82523E-06,5.74747E-11,0./ + +! Data + + DATA FRACREFA10/ & +! From P = 473 mb. + 0.16271301,0.15141940,0.14065412,0.12899506, & + 0.11607002,0.10142808,0.08116794,0.06104711, & + 0.04146209,0.00447386,0.00372902,0.00287258, & + 0.00206028,0.00134634,0.00049232,0.00006927/ + DATA FRACREFB10/ & +! From P = 1.17 mb. + 0.16571465,0.15262246,0.14036226,0.12620729, & + 0.11477834,0.09967982,0.08155201,0.06159503, & + 0.04196607,0.00453940,0.00376881,0.00300437, & + 0.00223034,0.00139432,0.00051516,0.00007095/ + +! Data + + DATA FRACREFA11/ & +! From P = 473 mb. + 0.14152819,0.13811260,0.14312185,0.13705885, & + 0.11944738,0.10570189,0.08866373,0.06565409, & + 0.04428961,0.00481540,0.00387058,0.00329187, & + 0.00238294,0.00150971,0.00049287,0.00005980/ + DATA FRACREFB11/ & +! From P = 1.17 mb. + 0.10874039,0.15164889,0.15149839,0.14515044, & + 0.12486220,0.10725017,0.08715712,0.06463144, & + 0.04332319,0.00441193,0.00393819,0.00305960, & + 0.00224221,0.00145100,0.00055586,0.00007934/ + +! Data + + DATA FRACREFA12/ & +! From P = 706.3 mb. + 0.21245100,0.15164700,0.14486700,0.13075501, & + 0.11629600,0.09266050,0.06579930,0.04524000, & + 0.03072870,0.00284297,0.00234660,0.00185208, & + 0.00133978,0.00082214,0.00031016,0.00004363, & + 0.14703900,0.16937999,0.15605700,0.14159000, & + 0.12088500,0.10058500,0.06809110,0.05131470, & + 0.03487040,0.00327281,0.00250183,0.00190024, & + 0.00133978,0.00082214,0.00031016,0.00004363, & + 0.13689300,0.16610400,0.15723500,0.14299500, & + 0.12399400,0.09907820,0.07169690,0.05367370, & + 0.03671630,0.00378148,0.00290510,0.00221076, & + 0.00142810,0.00093527,0.00031016,0.00004363, & + 0.13054299,0.16273800,0.15874299,0.14279599, & + 0.12674300,0.09664900,0.07462200,0.05620080, & + 0.03789090,0.00411690,0.00322920,0.00245036, & + 0.00178303,0.00098595,0.00040802,0.00010150, & + 0.12828299,0.15824600,0.15688400,0.14449100, & + 0.12787800,0.09517830,0.07679350,0.05890820, & + 0.03883570,0.00442304,0.00346796,0.00255333, & + 0.00212519,0.00116168,0.00067065,0.00010150, & + 0.12649800,0.15195100,0.15646499,0.14569700, & + 0.12669300,0.09653520,0.07887920,0.06106920, & + 0.04043910,0.00430390,0.00364453,0.00314360, & + 0.00203206,0.00187787,0.00067075,0.00010150, & + 0.12500300,0.14460599,0.15672199,0.14724600, & + 0.11978900,0.10190200,0.08196710,0.06315770, & + 0.04240100,0.00433645,0.00404097,0.00329466, & + 0.00288491,0.00187803,0.00067093,0.00010150, & + 0.12317200,0.14118700,0.15242000,0.13794300, & + 0.12119200,0.10655400,0.08808350,0.06521370, & + 0.04505680,0.00485949,0.00477105,0.00401468, & + 0.00288491,0.00187786,0.00067110,0.00010150, & + 0.10193600,0.11693000,0.13236099,0.14053200, & + 0.13749801,0.12193100,0.10221000,0.07448910, & + 0.05205320,0.00572312,0.00476882,0.00403380, & + 0.00288871,0.00187396,0.00067218,0.00010150/ + +! Data + + DATA FRACREFA13/ & +! From P = 706.3 mb. + 0.17683899,0.17319500,0.15712699,0.13604601, & + 0.10776200,0.08750010,0.06808820,0.04905150, & + 0.03280360,0.00350836,0.00281864,0.00219862, & + 0.00160943,0.00101885,0.00038147,0.00005348, & + 0.17535400,0.16999300,0.15610200,0.13589200, & + 0.10842100,0.08988550,0.06943920,0.04974900, & + 0.03323400,0.00352752,0.00289402,0.00231003, & + 0.00174659,0.00101884,0.00038147,0.00005348, & + 0.17409500,0.16846400,0.15641899,0.13503000, & + 0.10838600,0.08985800,0.07092720,0.05075710, & + 0.03364180,0.00354241,0.00303507,0.00243391, & + 0.00177502,0.00114638,0.00043585,0.00005348, & + 0.17248300,0.16778600,0.15543500,0.13496999, & + 0.10826300,0.09028740,0.07156720,0.05187120, & + 0.03424890,0.00363933,0.00324715,0.00255030, & + 0.00187380,0.00116978,0.00051229,0.00009768, & + 0.17061099,0.16715799,0.15405200,0.13471501, & + 0.10896400,0.09069460,0.07229760,0.05218280, & + 0.03555340,0.00379576,0.00330240,0.00274693, & + 0.00201587,0.00119598,0.00061885,0.00009768, & + 0.16789700,0.16629100,0.15270300,0.13360199, & + 0.11047200,0.09151080,0.07325000,0.05261450, & + 0.03657990,0.00450092,0.00349537,0.00283321, & + 0.00208396,0.00140354,0.00066587,0.00009768, & + 0.16412200,0.16387400,0.15211500,0.13062200, & + 0.11325100,0.09348130,0.07381380,0.05434740, & + 0.03803160,0.00481346,0.00393592,0.00296633, & + 0.00222532,0.00163762,0.00066648,0.00009768, & + 0.15513401,0.15768200,0.14850400,0.13330200, & + 0.11446500,0.09868230,0.07642050,0.05624170, & + 0.04197810,0.00502288,0.00429452,0.00315347, & + 0.00263559,0.00171772,0.00066860,0.00009768, & + 0.15732600,0.15223300,0.14271900,0.13563600, & + 0.11859600,0.10274200,0.07934560,0.05763410, & + 0.03921740,0.00437741,0.00337921,0.00280212, & + 0.00200156,0.00124812,0.00064664,0.00009768/ + +! Data + + DATA FRACREFA14/ & +! From P = 1053.6 mb. + 0.18446200,0.16795200,0.14949700,0.12036000, & + 0.10440100,0.09024280,0.07435880,0.05629380, & + 0.03825420,0.00417276,0.00345278,0.00272949, & + 0.00200378,0.00127404,0.00050721,0.00004141/ + DATA FRACREFB14/ & +! From P = 0.64 mb. + 0.19128500,0.16495700,0.14146100,0.11904500, & + 0.10350200,0.09151190,0.07604270,0.05806020, & + 0.03979950,0.00423959,0.00357439,0.00287559, & + 0.00198860,0.00116529,0.00043616,0.00005987/ + +! Data + + DATA FRACREFA15/ & +! From P = 1053.6 mb. + 0.11287100,0.12070200,0.12729000,0.12858100, & + 0.12743001,0.11961800,0.10290400,0.07888980, & + 0.05900120,0.00667979,0.00552926,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.13918801,0.16353001,0.16155800,0.14090499, & + 0.11322300,0.08757720,0.07225720,0.05173390, & + 0.04731360,0.00667979,0.00552926,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.14687300,0.17853101,0.15664500,0.13351700, & + 0.10791200,0.08684320,0.07158090,0.05198410, & + 0.04340110,0.00667979,0.00552926,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.15760700,0.17759100,0.15158001,0.13193300, & + 0.10742800,0.08693760,0.07159490,0.05196250, & + 0.04065270,0.00667979,0.00552926,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.16646700,0.17299300,0.15018500,0.13138700, & + 0.10735900,0.08713110,0.07130330,0.05279420, & + 0.03766730,0.00667979,0.00552926,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.17546000,0.16666500,0.14969499,0.13105400, & + 0.10782500,0.08718610,0.07156770,0.05308320, & + 0.03753960,0.00432465,0.00509623,0.00436993, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.18378501,0.16064601,0.14940400,0.13146400, & + 0.10810300,0.08775740,0.07115360,0.05400040, & + 0.03689970,0.00388333,0.00323610,0.00353414, & + 0.00320611,0.00204765,0.00077371,0.00010894, & + 0.18966800,0.15744300,0.14993000,0.13152599, & + 0.10899200,0.08858690,0.07142920,0.05399600, & + 0.03433460,0.00374886,0.00302066,0.00240653, & + 0.00199205,0.00204765,0.00077371,0.00010894, & + 0.11887100,0.12479600,0.12569501,0.12839900, & + 0.12473500,0.12012800,0.11086700,0.08493590, & + 0.05063770,0.00328723,0.00266849,0.00210232, & + 0.00152114,0.00095635,0.00035374,0.00004980/ + +! Data + + DATA FRACREFA16/ & +! From P = 862.6 mb. + 0.17356300,0.18880001,0.17704099,0.13661300, & + 0.10691600,0.08222480,0.05939860,0.04230810, & + 0.02526330,0.00244532,0.00193541,0.00150415, & + 0.00103528,0.00067068,0.00024951,0.00003348, & + 0.17779499,0.19837400,0.16557600,0.13470000, & + 0.11013600,0.08342720,0.05987030,0.03938700, & + 0.02293650,0.00238849,0.00192400,0.00149921, & + 0.00103539,0.00067150,0.00024822,0.00003348, & + 0.18535601,0.19407199,0.16053200,0.13300700, & + 0.10779000,0.08408500,0.06480450,0.04070160, & + 0.02203590,0.00227779,0.00189074,0.00146888, & + 0.00103147,0.00066770,0.00024751,0.00003348, & + 0.19139200,0.18917400,0.15748601,0.13240699, & + 0.10557300,0.08383260,0.06724060,0.04364450, & + 0.02175820,0.00225436,0.00184421,0.00143153, & + 0.00103027,0.00066066,0.00024222,0.00003148, & + 0.19547801,0.18539500,0.15442000,0.13114899, & + 0.10515600,0.08350350,0.06909780,0.04671630, & + 0.02168820,0.00224400,0.00182009,0.00139098, & + 0.00102582,0.00065367,0.00023202,0.00003148, & + 0.19757500,0.18266800,0.15208900,0.12897800, & + 0.10637200,0.08391220,0.06989830,0.04964120, & + 0.02155800,0.00224310,0.00177358,0.00138184, & + 0.00101538,0.00063370,0.00023227,0.00003148, & + 0.20145500,0.17692900,0.14940600,0.12690400, & + 0.10828800,0.08553720,0.07004940,0.05153430, & + 0.02268740,0.00216943,0.00178603,0.00137754, & + 0.00098344,0.00063165,0.00023218,0.00003148, & + 0.20383500,0.17047501,0.14570600,0.12679300, & + 0.11043100,0.08719150,0.07045440,0.05345420, & + 0.02448340,0.00215839,0.00175893,0.00138296, & + 0.00098318,0.00063188,0.00023199,0.00003148, & + 0.18680701,0.15961801,0.15092900,0.13049100, & + 0.11418400,0.09380540,0.07093450,0.05664280, & + 0.02938410,0.00217751,0.00176766,0.00138275, & + 0.00098377,0.00063181,0.00023193,0.00003148/ + + +! +! end of data 3 +! + +!----------------------------------------------------------------------- + +! start data 4 + + DATA NXMOL /2/ + DATA IXINDX /0,2,3,0,31*0/ + +! +! end of data 4 +! +!----------------------------------------------------------------------- + +! start data 5 + +! +! Longwave spectral band data + + DATA WAVENUM1(1) /10./, WAVENUM2(1) /250./, DELWAVE(1) /240./ + DATA WAVENUM1(2) /250./, WAVENUM2(2) /500./, DELWAVE(2) /250./ + DATA WAVENUM1(3) /500./, WAVENUM2(3) /630./, DELWAVE(3) /130./ + DATA WAVENUM1(4) /630./, WAVENUM2(4) /700./, DELWAVE(4) /70./ + DATA WAVENUM1(5) /700./, WAVENUM2(5) /820./, DELWAVE(5) /120./ + DATA WAVENUM1(6) /820./, WAVENUM2(6) /980./, DELWAVE(6) /160./ + DATA WAVENUM1(7) /980./, WAVENUM2(7) /1080./, DELWAVE(7) /100./ + DATA WAVENUM1(8) /1080./, WAVENUM2(8) /1180./, DELWAVE(8) /100./ + DATA WAVENUM1(9) /1180./, WAVENUM2(9) /1390./, DELWAVE(9) /210./ + DATA WAVENUM1(10) /1390./,WAVENUM2(10) /1480./,DELWAVE(10) /90./ + DATA WAVENUM1(11) /1480./,WAVENUM2(11) /1800./,DELWAVE(11) /320./ + DATA WAVENUM1(12) /1800./,WAVENUM2(12) /2080./,DELWAVE(12) /280./ + DATA WAVENUM1(13) /2080./,WAVENUM2(13) /2250./,DELWAVE(13) /170./ + DATA WAVENUM1(14) /2250./,WAVENUM2(14) /2380./,DELWAVE(14) /130./ + DATA WAVENUM1(15) /2380./,WAVENUM2(15) /2600./,DELWAVE(15) /220./ + DATA WAVENUM1(16) /2600./,WAVENUM2(16) /3000./,DELWAVE(16) /400./ + +! +! end of data 5 +! +!----------------------------------------------------------------------- + +! start data 6 + + + DATA NG /16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/ + DATA NSPA /1, 1,10, 9, 9, 1, 9, 1,11, 1, 1, 9, 9, 1, 9, 9/ + DATA NSPB /1, 1, 5, 6, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0/ + +! HEATFAC is the factor by which one must multiply delta-flux/ +! delta-pressure, with flux in w/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! = (9.8066)(3600)(1e-5)/(1.004) + + DATA HEATFAC /8.4391/ + +! These pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + + DATA PREF / & + 1.05363E+03,8.62642E+02,7.06272E+02,5.78246E+02,4.73428E+02, & + 3.87610E+02,3.17348E+02,2.59823E+02,2.12725E+02,1.74164E+02, & + 1.42594E+02,1.16746E+02,9.55835E+01,7.82571E+01,6.40715E+01, & + 5.24573E+01,4.29484E+01,3.51632E+01,2.87892E+01,2.35706E+01, & + 1.92980E+01,1.57998E+01,1.29358E+01,1.05910E+01,8.67114E+00, & + 7.09933E+00,5.81244E+00,4.75882E+00,3.89619E+00,3.18993E+00, & + 2.61170E+00,2.13828E+00,1.75067E+00,1.43333E+00,1.17351E+00, & + 9.60789E-01,7.86628E-01,6.44036E-01,5.27292E-01,4.31710E-01, & + 3.53455E-01,2.89384E-01,2.36928E-01,1.93980E-01,1.58817E-01, & + 1.30029E-01,1.06458E-01,8.71608E-02,7.13612E-02,5.84256E-02, & + 4.78349E-02,3.91639E-02,3.20647E-02,2.62523E-02,2.14936E-02, & + 1.75975E-02,1.44076E-02,1.17959E-02,9.65769E-03/ + DATA PREFLOG / & + 6.9600E+00, 6.7600E+00, 6.5600E+00, 6.3600E+00, 6.1600E+00, & + 5.9600E+00, 5.7600E+00, 5.5600E+00, 5.3600E+00, 5.1600E+00, & + 4.9600E+00, 4.7600E+00, 4.5600E+00, 4.3600E+00, 4.1600E+00, & + 3.9600E+00, 3.7600E+00, 3.5600E+00, 3.3600E+00, 3.1600E+00, & + 2.9600E+00, 2.7600E+00, 2.5600E+00, 2.3600E+00, 2.1600E+00, & + 1.9600E+00, 1.7600E+00, 1.5600E+00, 1.3600E+00, 1.1600E+00, & + 9.6000E-01, 7.6000E-01, 5.6000E-01, 3.6000E-01, 1.6000E-01, & + -4.0000E-02,-2.4000E-01,-4.4000E-01,-6.4000E-01,-8.4000E-01, & + -1.0400E+00,-1.2400E+00,-1.4400E+00,-1.6400E+00,-1.8400E+00, & + -2.0400E+00,-2.2400E+00,-2.4400E+00,-2.6400E+00,-2.8400E+00, & + -3.0400E+00,-3.2400E+00,-3.4400E+00,-3.6400E+00,-3.8400E+00, & + -4.0400E+00,-4.2400E+00,-4.4400E+00,-4.6400E+00/ +! These are the temperatures associated with the respective +! pressures for the MLS standard atmosphere. + DATA TREF / & + 2.9420E+02, 2.8799E+02, 2.7894E+02, 2.6925E+02, 2.5983E+02, & + 2.5017E+02, 2.4077E+02, 2.3179E+02, 2.2306E+02, 2.1578E+02, & + 2.1570E+02, 2.1570E+02, 2.1570E+02, 2.1706E+02, 2.1858E+02, & + 2.2018E+02, 2.2174E+02, 2.2328E+02, 2.2479E+02, 2.2655E+02, & + 2.2834E+02, 2.3113E+02, 2.3401E+02, 2.3703E+02, 2.4022E+02, & + 2.4371E+02, 2.4726E+02, 2.5085E+02, 2.5457E+02, 2.5832E+02, & + 2.6216E+02, 2.6606E+02, 2.6999E+02, 2.7340E+02, 2.7536E+02, & + 2.7568E+02, 2.7372E+02, 2.7163E+02, 2.6955E+02, 2.6593E+02, & + 2.6211E+02, 2.5828E+02, 2.5360E+02, 2.4854E+02, 2.4348E+02, & + 2.3809E+02, 2.3206E+02, 2.2603E+02, 2.2000E+02, 2.1435E+02, & + 2.0887E+02, 2.0340E+02, 1.9792E+02, 1.9290E+02, 1.8809E+02, & + 1.8329E+02, 1.7849E+02, 1.7394E+02, 1.7212E+02/ + +! +! end of data 6 +! +!----------------------------------------------------------------------- + +! start data 7 + + DATA (TOTPLNK(IDATA, 1),IDATA=1,50)/ & + 1.13735E-06,1.15150E-06,1.16569E-06,1.17992E-06,1.19419E-06, & + 1.20850E-06,1.22285E-06,1.23723E-06,1.25164E-06,1.26610E-06, & + 1.28059E-06,1.29511E-06,1.30967E-06,1.32426E-06,1.33889E-06, & + 1.35355E-06,1.36824E-06,1.38296E-06,1.39772E-06,1.41250E-06, & + 1.42732E-06,1.44217E-06,1.45704E-06,1.47195E-06,1.48689E-06, & + 1.50185E-06,1.51684E-06,1.53186E-06,1.54691E-06,1.56198E-06, & + 1.57709E-06,1.59222E-06,1.60737E-06,1.62255E-06,1.63776E-06, & + 1.65299E-06,1.66825E-06,1.68352E-06,1.69883E-06,1.71416E-06, & + 1.72951E-06,1.74488E-06,1.76028E-06,1.77570E-06,1.79114E-06, & + 1.80661E-06,1.82210E-06,1.83760E-06,1.85313E-06,1.86868E-06/ + DATA (TOTPLNK(IDATA, 1),IDATA=51,100)/ & + 1.88425E-06,1.89985E-06,1.91546E-06,1.93109E-06,1.94674E-06, & + 1.96241E-06,1.97811E-06,1.99381E-06,2.00954E-06,2.02529E-06, & + 2.04105E-06,2.05684E-06,2.07264E-06,2.08846E-06,2.10429E-06, & + 2.12015E-06,2.13602E-06,2.15190E-06,2.16781E-06,2.18373E-06, & + 2.19966E-06,2.21562E-06,2.23159E-06,2.24758E-06,2.26358E-06, & + 2.27959E-06,2.29562E-06,2.31167E-06,2.32773E-06,2.34381E-06, & + 2.35990E-06,2.37601E-06,2.39212E-06,2.40825E-06,2.42440E-06, & + 2.44056E-06,2.45673E-06,2.47292E-06,2.48912E-06,2.50533E-06, & + 2.52157E-06,2.53781E-06,2.55406E-06,2.57032E-06,2.58660E-06, & + 2.60289E-06,2.61919E-06,2.63550E-06,2.65183E-06,2.66817E-06/ + DATA (TOTPLNK(IDATA, 1),IDATA=101,150)/ & + 2.68452E-06,2.70088E-06,2.71726E-06,2.73364E-06,2.75003E-06, & + 2.76644E-06,2.78286E-06,2.79929E-06,2.81572E-06,2.83218E-06, & + 2.84864E-06,2.86510E-06,2.88159E-06,2.89807E-06,2.91458E-06, & + 2.93109E-06,2.94762E-06,2.96415E-06,2.98068E-06,2.99724E-06, & + 3.01379E-06,3.03036E-06,3.04693E-06,3.06353E-06,3.08013E-06, & + 3.09674E-06,3.11335E-06,3.12998E-06,3.14661E-06,3.16324E-06, & + 3.17989E-06,3.19656E-06,3.21323E-06,3.22991E-06,3.24658E-06, & + 3.26328E-06,3.27998E-06,3.29669E-06,3.31341E-06,3.33013E-06, & + 3.34686E-06,3.36360E-06,3.38034E-06,3.39709E-06,3.41387E-06, & + 3.43063E-06,3.44742E-06,3.46420E-06,3.48099E-06,3.49779E-06/ + DATA (TOTPLNK(IDATA, 1),IDATA=151,181)/ & + 3.51461E-06,3.53141E-06,3.54824E-06,3.56506E-06,3.58191E-06, & + 3.59875E-06,3.61559E-06,3.63244E-06,3.64931E-06,3.66617E-06, & + 3.68305E-06,3.69992E-06,3.71682E-06,3.73372E-06,3.75061E-06, & + 3.76753E-06,3.78443E-06,3.80136E-06,3.81829E-06,3.83522E-06, & + 3.85215E-06,3.86910E-06,3.88605E-06,3.90301E-06,3.91997E-06, & + 3.93694E-06,3.95390E-06,3.97087E-06,3.98788E-06,4.00485E-06, & + 4.02187E-06/ + DATA (TOTPLNK(IDATA, 2),IDATA=1,50)/ & + 2.13441E-06,2.18076E-06,2.22758E-06,2.27489E-06,2.32268E-06, & + 2.37093E-06,2.41966E-06,2.46886E-06,2.51852E-06,2.56864E-06, & + 2.61922E-06,2.67026E-06,2.72175E-06,2.77370E-06,2.82609E-06, & + 2.87893E-06,2.93221E-06,2.98593E-06,3.04008E-06,3.09468E-06, & + 3.14970E-06,3.20515E-06,3.26103E-06,3.31732E-06,3.37404E-06, & + 3.43118E-06,3.48873E-06,3.54669E-06,3.60506E-06,3.66383E-06, & + 3.72301E-06,3.78259E-06,3.84256E-06,3.90293E-06,3.96368E-06, & + 4.02483E-06,4.08636E-06,4.14828E-06,4.21057E-06,4.27324E-06, & + 4.33629E-06,4.39971E-06,4.46350E-06,4.52765E-06,4.59217E-06, & + 4.65705E-06,4.72228E-06,4.78787E-06,4.85382E-06,4.92011E-06/ + DATA (TOTPLNK(IDATA, 2),IDATA=51,100)/ & + 4.98675E-06,5.05374E-06,5.12106E-06,5.18873E-06,5.25674E-06, & + 5.32507E-06,5.39374E-06,5.46274E-06,5.53207E-06,5.60172E-06, & + 5.67169E-06,5.74198E-06,5.81259E-06,5.88352E-06,5.95475E-06, & + 6.02629E-06,6.09815E-06,6.17030E-06,6.24276E-06,6.31552E-06, & + 6.38858E-06,6.46192E-06,6.53557E-06,6.60950E-06,6.68373E-06, & + 6.75824E-06,6.83303E-06,6.90810E-06,6.98346E-06,7.05909E-06, & + 7.13500E-06,7.21117E-06,7.28763E-06,7.36435E-06,7.44134E-06, & + 7.51859E-06,7.59611E-06,7.67388E-06,7.75192E-06,7.83021E-06, & + 7.90875E-06,7.98755E-06,8.06660E-06,8.14589E-06,8.22544E-06, & + 8.30522E-06,8.38526E-06,8.46553E-06,8.54604E-06,8.62679E-06/ + DATA (TOTPLNK(IDATA, 2),IDATA=101,150)/ & + 8.70777E-06,8.78899E-06,8.87043E-06,8.95211E-06,9.03402E-06, & + 9.11616E-06,9.19852E-06,9.28109E-06,9.36390E-06,9.44692E-06, & + 9.53015E-06,9.61361E-06,9.69729E-06,9.78117E-06,9.86526E-06, & + 9.94957E-06,1.00341E-05,1.01188E-05,1.02037E-05,1.02888E-05, & + 1.03742E-05,1.04597E-05,1.05454E-05,1.06313E-05,1.07175E-05, & + 1.08038E-05,1.08903E-05,1.09770E-05,1.10639E-05,1.11509E-05, & + 1.12382E-05,1.13257E-05,1.14133E-05,1.15011E-05,1.15891E-05, & + 1.16773E-05,1.17656E-05,1.18542E-05,1.19429E-05,1.20317E-05, & + 1.21208E-05,1.22100E-05,1.22994E-05,1.23890E-05,1.24787E-05, & + 1.25686E-05,1.26587E-05,1.27489E-05,1.28393E-05,1.29299E-05/ + DATA (TOTPLNK(IDATA, 2),IDATA=151,181)/ & + 1.30206E-05,1.31115E-05,1.32025E-05,1.32937E-05,1.33850E-05, & + 1.34765E-05,1.35682E-05,1.36600E-05,1.37520E-05,1.38441E-05, & + 1.39364E-05,1.40288E-05,1.41213E-05,1.42140E-05,1.43069E-05, & + 1.43999E-05,1.44930E-05,1.45863E-05,1.46797E-05,1.47733E-05, & + 1.48670E-05,1.49608E-05,1.50548E-05,1.51489E-05,1.52431E-05, & + 1.53375E-05,1.54320E-05,1.55267E-05,1.56214E-05,1.57164E-05, & + 1.58114E-05/ + DATA (TOTPLNK(IDATA, 3),IDATA=1,50)/ & + 1.34822E-06,1.39134E-06,1.43530E-06,1.48010E-06,1.52574E-06, & + 1.57222E-06,1.61956E-06,1.66774E-06,1.71678E-06,1.76666E-06, & + 1.81741E-06,1.86901E-06,1.92147E-06,1.97479E-06,2.02898E-06, & + 2.08402E-06,2.13993E-06,2.19671E-06,2.25435E-06,2.31285E-06, & + 2.37222E-06,2.43246E-06,2.49356E-06,2.55553E-06,2.61837E-06, & + 2.68207E-06,2.74664E-06,2.81207E-06,2.87837E-06,2.94554E-06, & + 3.01356E-06,3.08245E-06,3.15221E-06,3.22282E-06,3.29429E-06, & + 3.36662E-06,3.43982E-06,3.51386E-06,3.58876E-06,3.66451E-06, & + 3.74112E-06,3.81857E-06,3.89688E-06,3.97602E-06,4.05601E-06, & + 4.13685E-06,4.21852E-06,4.30104E-06,4.38438E-06,4.46857E-06/ + DATA (TOTPLNK(IDATA, 3),IDATA=51,100)/ & + 4.55358E-06,4.63943E-06,4.72610E-06,4.81359E-06,4.90191E-06, & + 4.99105E-06,5.08100E-06,5.17176E-06,5.26335E-06,5.35573E-06, & + 5.44892E-06,5.54292E-06,5.63772E-06,5.73331E-06,5.82970E-06, & + 5.92688E-06,6.02485E-06,6.12360E-06,6.22314E-06,6.32346E-06, & + 6.42455E-06,6.52641E-06,6.62906E-06,6.73247E-06,6.83664E-06, & + 6.94156E-06,7.04725E-06,7.15370E-06,7.26089E-06,7.36883E-06, & + 7.47752E-06,7.58695E-06,7.69712E-06,7.80801E-06,7.91965E-06, & + 8.03201E-06,8.14510E-06,8.25891E-06,8.37343E-06,8.48867E-06, & + 8.60463E-06,8.72128E-06,8.83865E-06,8.95672E-06,9.07548E-06, & + 9.19495E-06,9.31510E-06,9.43594E-06,9.55745E-06,9.67966E-06/ + DATA (TOTPLNK(IDATA, 3),IDATA=101,150)/ & + 9.80254E-06,9.92609E-06,1.00503E-05,1.01752E-05,1.03008E-05, & + 1.04270E-05,1.05539E-05,1.06814E-05,1.08096E-05,1.09384E-05, & + 1.10679E-05,1.11980E-05,1.13288E-05,1.14601E-05,1.15922E-05, & + 1.17248E-05,1.18581E-05,1.19920E-05,1.21265E-05,1.22616E-05, & + 1.23973E-05,1.25337E-05,1.26706E-05,1.28081E-05,1.29463E-05, & + 1.30850E-05,1.32243E-05,1.33642E-05,1.35047E-05,1.36458E-05, & + 1.37875E-05,1.39297E-05,1.40725E-05,1.42159E-05,1.43598E-05, & + 1.45044E-05,1.46494E-05,1.47950E-05,1.49412E-05,1.50879E-05, & + 1.52352E-05,1.53830E-05,1.55314E-05,1.56803E-05,1.58297E-05, & + 1.59797E-05,1.61302E-05,1.62812E-05,1.64327E-05,1.65848E-05/ + DATA (TOTPLNK(IDATA, 3),IDATA=151,181)/ & + 1.67374E-05,1.68904E-05,1.70441E-05,1.71982E-05,1.73528E-05, & + 1.75079E-05,1.76635E-05,1.78197E-05,1.79763E-05,1.81334E-05, & + 1.82910E-05,1.84491E-05,1.86076E-05,1.87667E-05,1.89262E-05, & + 1.90862E-05,1.92467E-05,1.94076E-05,1.95690E-05,1.97309E-05, & + 1.98932E-05,2.00560E-05,2.02193E-05,2.03830E-05,2.05472E-05, & + 2.07118E-05,2.08768E-05,2.10423E-05,2.12083E-05,2.13747E-05, & + 2.15414E-05/ + DATA (TOTPLNK(IDATA, 4),IDATA=1,50)/ & + 8.90528E-07,9.24222E-07,9.58757E-07,9.94141E-07,1.03038E-06, & + 1.06748E-06,1.10545E-06,1.14430E-06,1.18403E-06,1.22465E-06, & + 1.26618E-06,1.30860E-06,1.35193E-06,1.39619E-06,1.44136E-06, & + 1.48746E-06,1.53449E-06,1.58246E-06,1.63138E-06,1.68124E-06, & + 1.73206E-06,1.78383E-06,1.83657E-06,1.89028E-06,1.94495E-06, & + 2.00060E-06,2.05724E-06,2.11485E-06,2.17344E-06,2.23303E-06, & + 2.29361E-06,2.35519E-06,2.41777E-06,2.48134E-06,2.54592E-06, & + 2.61151E-06,2.67810E-06,2.74571E-06,2.81433E-06,2.88396E-06, & + 2.95461E-06,3.02628E-06,3.09896E-06,3.17267E-06,3.24741E-06, & + 3.32316E-06,3.39994E-06,3.47774E-06,3.55657E-06,3.63642E-06/ + DATA (TOTPLNK(IDATA, 4),IDATA=51,100)/ & + 3.71731E-06,3.79922E-06,3.88216E-06,3.96612E-06,4.05112E-06, & + 4.13714E-06,4.22419E-06,4.31227E-06,4.40137E-06,4.49151E-06, & + 4.58266E-06,4.67485E-06,4.76806E-06,4.86229E-06,4.95754E-06, & + 5.05383E-06,5.15113E-06,5.24946E-06,5.34879E-06,5.44916E-06, & + 5.55053E-06,5.65292E-06,5.75632E-06,5.86073E-06,5.96616E-06, & + 6.07260E-06,6.18003E-06,6.28848E-06,6.39794E-06,6.50838E-06, & + 6.61983E-06,6.73229E-06,6.84573E-06,6.96016E-06,7.07559E-06, & + 7.19200E-06,7.30940E-06,7.42779E-06,7.54715E-06,7.66749E-06, & + 7.78882E-06,7.91110E-06,8.03436E-06,8.15859E-06,8.28379E-06, & + 8.40994E-06,8.53706E-06,8.66515E-06,8.79418E-06,8.92416E-06/ + DATA (TOTPLNK(IDATA, 4),IDATA=101,150)/ & + 9.05510E-06,9.18697E-06,9.31979E-06,9.45356E-06,9.58826E-06, & + 9.72389E-06,9.86046E-06,9.99793E-06,1.01364E-05,1.02757E-05, & + 1.04159E-05,1.05571E-05,1.06992E-05,1.08422E-05,1.09861E-05, & + 1.11309E-05,1.12766E-05,1.14232E-05,1.15707E-05,1.17190E-05, & + 1.18683E-05,1.20184E-05,1.21695E-05,1.23214E-05,1.24741E-05, & + 1.26277E-05,1.27822E-05,1.29376E-05,1.30939E-05,1.32509E-05, & + 1.34088E-05,1.35676E-05,1.37273E-05,1.38877E-05,1.40490E-05, & + 1.42112E-05,1.43742E-05,1.45380E-05,1.47026E-05,1.48680E-05, & + 1.50343E-05,1.52014E-05,1.53692E-05,1.55379E-05,1.57074E-05, & + 1.58778E-05,1.60488E-05,1.62207E-05,1.63934E-05,1.65669E-05/ + DATA (TOTPLNK(IDATA, 4),IDATA=151,181)/ & + 1.67411E-05,1.69162E-05,1.70920E-05,1.72685E-05,1.74459E-05, & + 1.76240E-05,1.78029E-05,1.79825E-05,1.81629E-05,1.83440E-05, & + 1.85259E-05,1.87086E-05,1.88919E-05,1.90760E-05,1.92609E-05, & + 1.94465E-05,1.96327E-05,1.98199E-05,2.00076E-05,2.01961E-05, & + 2.03853E-05,2.05752E-05,2.07658E-05,2.09571E-05,2.11491E-05, & + 2.13418E-05,2.15352E-05,2.17294E-05,2.19241E-05,2.21196E-05, & + 2.23158E-05/ + DATA (TOTPLNK(IDATA, 5),IDATA=1,50)/ & + 5.70230E-07,5.94788E-07,6.20085E-07,6.46130E-07,6.72936E-07, & + 7.00512E-07,7.28869E-07,7.58019E-07,7.87971E-07,8.18734E-07, & + 8.50320E-07,8.82738E-07,9.15999E-07,9.50110E-07,9.85084E-07, & + 1.02093E-06,1.05765E-06,1.09527E-06,1.13378E-06,1.17320E-06, & + 1.21353E-06,1.25479E-06,1.29698E-06,1.34011E-06,1.38419E-06, & + 1.42923E-06,1.47523E-06,1.52221E-06,1.57016E-06,1.61910E-06, & + 1.66904E-06,1.71997E-06,1.77192E-06,1.82488E-06,1.87886E-06, & + 1.93387E-06,1.98991E-06,2.04699E-06,2.10512E-06,2.16430E-06, & + 2.22454E-06,2.28584E-06,2.34821E-06,2.41166E-06,2.47618E-06, & + 2.54178E-06,2.60847E-06,2.67626E-06,2.74514E-06,2.81512E-06/ + DATA (TOTPLNK(IDATA, 5),IDATA=51,100)/ & + 2.88621E-06,2.95841E-06,3.03172E-06,3.10615E-06,3.18170E-06, & + 3.25838E-06,3.33618E-06,3.41511E-06,3.49518E-06,3.57639E-06, & + 3.65873E-06,3.74221E-06,3.82684E-06,3.91262E-06,3.99955E-06, & + 4.08763E-06,4.17686E-06,4.26725E-06,4.35880E-06,4.45150E-06, & + 4.54537E-06,4.64039E-06,4.73659E-06,4.83394E-06,4.93246E-06, & + 5.03215E-06,5.13301E-06,5.23504E-06,5.33823E-06,5.44260E-06, & + 5.54814E-06,5.65484E-06,5.76272E-06,5.87177E-06,5.98199E-06, & + 6.09339E-06,6.20596E-06,6.31969E-06,6.43460E-06,6.55068E-06, & + 6.66793E-06,6.78636E-06,6.90595E-06,7.02670E-06,7.14863E-06, & + 7.27173E-06,7.39599E-06,7.52142E-06,7.64802E-06,7.77577E-06/ + DATA (TOTPLNK(IDATA, 5),IDATA=101,150)/ & + 7.90469E-06,8.03477E-06,8.16601E-06,8.29841E-06,8.43198E-06, & + 8.56669E-06,8.70256E-06,8.83957E-06,8.97775E-06,9.11706E-06, & + 9.25753E-06,9.39915E-06,9.54190E-06,9.68580E-06,9.83085E-06, & + 9.97704E-06,1.01243E-05,1.02728E-05,1.04224E-05,1.05731E-05, & + 1.07249E-05,1.08779E-05,1.10320E-05,1.11872E-05,1.13435E-05, & + 1.15009E-05,1.16595E-05,1.18191E-05,1.19799E-05,1.21418E-05, & + 1.23048E-05,1.24688E-05,1.26340E-05,1.28003E-05,1.29676E-05, & + 1.31361E-05,1.33056E-05,1.34762E-05,1.36479E-05,1.38207E-05, & + 1.39945E-05,1.41694E-05,1.43454E-05,1.45225E-05,1.47006E-05, & + 1.48797E-05,1.50600E-05,1.52413E-05,1.54236E-05,1.56070E-05/ + DATA (TOTPLNK(IDATA, 5),IDATA=151,181)/ & + 1.57914E-05,1.59768E-05,1.61633E-05,1.63509E-05,1.65394E-05, & + 1.67290E-05,1.69197E-05,1.71113E-05,1.73040E-05,1.74976E-05, & + 1.76923E-05,1.78880E-05,1.80847E-05,1.82824E-05,1.84811E-05, & + 1.86808E-05,1.88814E-05,1.90831E-05,1.92857E-05,1.94894E-05, & + 1.96940E-05,1.98996E-05,2.01061E-05,2.03136E-05,2.05221E-05, & + 2.07316E-05,2.09420E-05,2.11533E-05,2.13657E-05,2.15789E-05, & + 2.17931E-05/ + DATA (TOTPLNK(IDATA, 6),IDATA=1,50)/ & + 2.73493E-07,2.87408E-07,3.01848E-07,3.16825E-07,3.32352E-07, & + 3.48439E-07,3.65100E-07,3.82346E-07,4.00189E-07,4.18641E-07, & + 4.37715E-07,4.57422E-07,4.77774E-07,4.98784E-07,5.20464E-07, & + 5.42824E-07,5.65879E-07,5.89638E-07,6.14115E-07,6.39320E-07, & + 6.65266E-07,6.91965E-07,7.19427E-07,7.47666E-07,7.76691E-07, & + 8.06516E-07,8.37151E-07,8.68607E-07,9.00896E-07,9.34029E-07, & + 9.68018E-07,1.00287E-06,1.03860E-06,1.07522E-06,1.11274E-06, & + 1.15117E-06,1.19052E-06,1.23079E-06,1.27201E-06,1.31418E-06, & + 1.35731E-06,1.40141E-06,1.44650E-06,1.49257E-06,1.53965E-06, & + 1.58773E-06,1.63684E-06,1.68697E-06,1.73815E-06,1.79037E-06/ + DATA (TOTPLNK(IDATA, 6),IDATA=51,100)/ & + 1.84365E-06,1.89799E-06,1.95341E-06,2.00991E-06,2.06750E-06, & + 2.12619E-06,2.18599E-06,2.24691E-06,2.30895E-06,2.37212E-06, & + 2.43643E-06,2.50189E-06,2.56851E-06,2.63628E-06,2.70523E-06, & + 2.77536E-06,2.84666E-06,2.91916E-06,2.99286E-06,3.06776E-06, & + 3.14387E-06,3.22120E-06,3.29975E-06,3.37953E-06,3.46054E-06, & + 3.54280E-06,3.62630E-06,3.71105E-06,3.79707E-06,3.88434E-06, & + 3.97288E-06,4.06270E-06,4.15380E-06,4.24617E-06,4.33984E-06, & + 4.43479E-06,4.53104E-06,4.62860E-06,4.72746E-06,4.82763E-06, & + 4.92911E-06,5.03191E-06,5.13603E-06,5.24147E-06,5.34824E-06, & + 5.45634E-06,5.56578E-06,5.67656E-06,5.78867E-06,5.90213E-06/ + DATA (TOTPLNK(IDATA, 6),IDATA=101,150)/ & + 6.01694E-06,6.13309E-06,6.25060E-06,6.36947E-06,6.48968E-06, & + 6.61126E-06,6.73420E-06,6.85850E-06,6.98417E-06,7.11120E-06, & + 7.23961E-06,7.36938E-06,7.50053E-06,7.63305E-06,7.76694E-06, & + 7.90221E-06,8.03887E-06,8.17690E-06,8.31632E-06,8.45710E-06, & + 8.59928E-06,8.74282E-06,8.88776E-06,9.03409E-06,9.18179E-06, & + 9.33088E-06,9.48136E-06,9.63323E-06,9.78648E-06,9.94111E-06, & + 1.00971E-05,1.02545E-05,1.04133E-05,1.05735E-05,1.07351E-05, & + 1.08980E-05,1.10624E-05,1.12281E-05,1.13952E-05,1.15637E-05, & + 1.17335E-05,1.19048E-05,1.20774E-05,1.22514E-05,1.24268E-05, & + 1.26036E-05,1.27817E-05,1.29612E-05,1.31421E-05,1.33244E-05/ + DATA (TOTPLNK(IDATA, 6),IDATA=151,181)/ & + 1.35080E-05,1.36930E-05,1.38794E-05,1.40672E-05,1.42563E-05, & + 1.44468E-05,1.46386E-05,1.48318E-05,1.50264E-05,1.52223E-05, & + 1.54196E-05,1.56182E-05,1.58182E-05,1.60196E-05,1.62223E-05, & + 1.64263E-05,1.66317E-05,1.68384E-05,1.70465E-05,1.72559E-05, & + 1.74666E-05,1.76787E-05,1.78921E-05,1.81069E-05,1.83230E-05, & + 1.85404E-05,1.87591E-05,1.89791E-05,1.92005E-05,1.94232E-05, & + 1.96471E-05/ + DATA (TOTPLNK(IDATA, 7),IDATA=1,50)/ & + 1.25349E-07,1.32735E-07,1.40458E-07,1.48527E-07,1.56954E-07, & + 1.65748E-07,1.74920E-07,1.84481E-07,1.94443E-07,2.04814E-07, & + 2.15608E-07,2.26835E-07,2.38507E-07,2.50634E-07,2.63229E-07, & + 2.76301E-07,2.89864E-07,3.03930E-07,3.18508E-07,3.33612E-07, & + 3.49253E-07,3.65443E-07,3.82195E-07,3.99519E-07,4.17428E-07, & + 4.35934E-07,4.55050E-07,4.74785E-07,4.95155E-07,5.16170E-07, & + 5.37844E-07,5.60186E-07,5.83211E-07,6.06929E-07,6.31355E-07, & + 6.56498E-07,6.82373E-07,7.08990E-07,7.36362E-07,7.64501E-07, & + 7.93420E-07,8.23130E-07,8.53643E-07,8.84971E-07,9.17128E-07, & + 9.50123E-07,9.83969E-07,1.01868E-06,1.05426E-06,1.09073E-06/ + DATA (TOTPLNK(IDATA, 7),IDATA=51,100)/ & + 1.12810E-06,1.16638E-06,1.20558E-06,1.24572E-06,1.28680E-06, & + 1.32883E-06,1.37183E-06,1.41581E-06,1.46078E-06,1.50675E-06, & + 1.55374E-06,1.60174E-06,1.65078E-06,1.70087E-06,1.75200E-06, & + 1.80421E-06,1.85749E-06,1.91186E-06,1.96732E-06,2.02389E-06, & + 2.08159E-06,2.14040E-06,2.20035E-06,2.26146E-06,2.32372E-06, & + 2.38714E-06,2.45174E-06,2.51753E-06,2.58451E-06,2.65270E-06, & + 2.72210E-06,2.79272E-06,2.86457E-06,2.93767E-06,3.01201E-06, & + 3.08761E-06,3.16448E-06,3.24261E-06,3.32204E-06,3.40275E-06, & + 3.48476E-06,3.56808E-06,3.65271E-06,3.73866E-06,3.82595E-06, & + 3.91456E-06,4.00453E-06,4.09584E-06,4.18851E-06,4.28254E-06/ + DATA (TOTPLNK(IDATA, 7),IDATA=101,150)/ & + 4.37796E-06,4.47475E-06,4.57293E-06,4.67249E-06,4.77346E-06, & + 4.87583E-06,4.97961E-06,5.08481E-06,5.19143E-06,5.29948E-06, & + 5.40896E-06,5.51989E-06,5.63226E-06,5.74608E-06,5.86136E-06, & + 5.97810E-06,6.09631E-06,6.21597E-06,6.33713E-06,6.45976E-06, & + 6.58388E-06,6.70950E-06,6.83661E-06,6.96521E-06,7.09531E-06, & + 7.22692E-06,7.36005E-06,7.49468E-06,7.63084E-06,7.76851E-06, & + 7.90773E-06,8.04846E-06,8.19072E-06,8.33452E-06,8.47985E-06, & + 8.62674E-06,8.77517E-06,8.92514E-06,9.07666E-06,9.22975E-06, & + 9.38437E-06,9.54057E-06,9.69832E-06,9.85762E-06,1.00185E-05, & + 1.01810E-05,1.03450E-05,1.05106E-05,1.06777E-05,1.08465E-05/ + DATA (TOTPLNK(IDATA, 7),IDATA=151,181)/ & + 1.10168E-05,1.11887E-05,1.13621E-05,1.15372E-05,1.17138E-05, & + 1.18920E-05,1.20718E-05,1.22532E-05,1.24362E-05,1.26207E-05, & + 1.28069E-05,1.29946E-05,1.31839E-05,1.33749E-05,1.35674E-05, & + 1.37615E-05,1.39572E-05,1.41544E-05,1.43533E-05,1.45538E-05, & + 1.47558E-05,1.49595E-05,1.51647E-05,1.53716E-05,1.55800E-05, & + 1.57900E-05,1.60017E-05,1.62149E-05,1.64296E-05,1.66460E-05, & + 1.68640E-05/ + DATA (TOTPLNK(IDATA, 8),IDATA=1,50)/ & + 6.74445E-08,7.18176E-08,7.64153E-08,8.12456E-08,8.63170E-08, & + 9.16378E-08,9.72168E-08,1.03063E-07,1.09184E-07,1.15591E-07, & + 1.22292E-07,1.29296E-07,1.36613E-07,1.44253E-07,1.52226E-07, & + 1.60540E-07,1.69207E-07,1.78236E-07,1.87637E-07,1.97421E-07, & + 2.07599E-07,2.18181E-07,2.29177E-07,2.40598E-07,2.52456E-07, & + 2.64761E-07,2.77523E-07,2.90755E-07,3.04468E-07,3.18673E-07, & + 3.33381E-07,3.48603E-07,3.64352E-07,3.80638E-07,3.97474E-07, & + 4.14871E-07,4.32841E-07,4.51395E-07,4.70547E-07,4.90306E-07, & + 5.10687E-07,5.31699E-07,5.53357E-07,5.75670E-07,5.98652E-07, & + 6.22315E-07,6.46672E-07,6.71731E-07,6.97511E-07,7.24018E-07/ + DATA (TOTPLNK(IDATA, 8),IDATA=51,100)/ & + 7.51266E-07,7.79269E-07,8.08038E-07,8.37584E-07,8.67922E-07, & + 8.99061E-07,9.31016E-07,9.63797E-07,9.97417E-07,1.03189E-06, & + 1.06722E-06,1.10343E-06,1.14053E-06,1.17853E-06,1.21743E-06, & + 1.25726E-06,1.29803E-06,1.33974E-06,1.38241E-06,1.42606E-06, & + 1.47068E-06,1.51630E-06,1.56293E-06,1.61056E-06,1.65924E-06, & + 1.70894E-06,1.75971E-06,1.81153E-06,1.86443E-06,1.91841E-06, & + 1.97350E-06,2.02968E-06,2.08699E-06,2.14543E-06,2.20500E-06, & + 2.26573E-06,2.32762E-06,2.39068E-06,2.45492E-06,2.52036E-06, & + 2.58700E-06,2.65485E-06,2.72393E-06,2.79424E-06,2.86580E-06, & + 2.93861E-06,3.01269E-06,3.08803E-06,3.16467E-06,3.24259E-06/ + DATA (TOTPLNK(IDATA, 8),IDATA=101,150)/ & + 3.32181E-06,3.40235E-06,3.48420E-06,3.56739E-06,3.65192E-06, & + 3.73779E-06,3.82502E-06,3.91362E-06,4.00359E-06,4.09494E-06, & + 4.18768E-06,4.28182E-06,4.37737E-06,4.47434E-06,4.57273E-06, & + 4.67254E-06,4.77380E-06,4.87651E-06,4.98067E-06,5.08630E-06, & + 5.19339E-06,5.30196E-06,5.41201E-06,5.52356E-06,5.63660E-06, & + 5.75116E-06,5.86722E-06,5.98479E-06,6.10390E-06,6.22453E-06, & + 6.34669E-06,6.47042E-06,6.59569E-06,6.72252E-06,6.85090E-06, & + 6.98085E-06,7.11238E-06,7.24549E-06,7.38019E-06,7.51646E-06, & + 7.65434E-06,7.79382E-06,7.93490E-06,8.07760E-06,8.22192E-06, & + 8.36784E-06,8.51540E-06,8.66459E-06,8.81542E-06,8.96786E-06/ + DATA (TOTPLNK(IDATA, 8),IDATA=151,181)/ & + 9.12197E-06,9.27772E-06,9.43513E-06,9.59419E-06,9.75490E-06, & + 9.91728E-06,1.00813E-05,1.02471E-05,1.04144E-05,1.05835E-05, & + 1.07543E-05,1.09267E-05,1.11008E-05,1.12766E-05,1.14541E-05, & + 1.16333E-05,1.18142E-05,1.19969E-05,1.21812E-05,1.23672E-05, & + 1.25549E-05,1.27443E-05,1.29355E-05,1.31284E-05,1.33229E-05, & + 1.35193E-05,1.37173E-05,1.39170E-05,1.41185E-05,1.43217E-05, & + 1.45267E-05/ + DATA (TOTPLNK(IDATA, 9),IDATA=1,50)/ & + 2.61522E-08,2.80613E-08,3.00838E-08,3.22250E-08,3.44899E-08, & + 3.68841E-08,3.94129E-08,4.20820E-08,4.48973E-08,4.78646E-08, & + 5.09901E-08,5.42799E-08,5.77405E-08,6.13784E-08,6.52001E-08, & + 6.92126E-08,7.34227E-08,7.78375E-08,8.24643E-08,8.73103E-08, & + 9.23832E-08,9.76905E-08,1.03240E-07,1.09039E-07,1.15097E-07, & + 1.21421E-07,1.28020E-07,1.34902E-07,1.42075E-07,1.49548E-07, & + 1.57331E-07,1.65432E-07,1.73860E-07,1.82624E-07,1.91734E-07, & + 2.01198E-07,2.11028E-07,2.21231E-07,2.31818E-07,2.42799E-07, & + 2.54184E-07,2.65983E-07,2.78205E-07,2.90862E-07,3.03963E-07, & + 3.17519E-07,3.31541E-07,3.46039E-07,3.61024E-07,3.76507E-07/ + DATA (TOTPLNK(IDATA, 9),IDATA=51,100)/ & + 3.92498E-07,4.09008E-07,4.26050E-07,4.43633E-07,4.61769E-07, & + 4.80469E-07,4.99744E-07,5.19606E-07,5.40067E-07,5.61136E-07, & + 5.82828E-07,6.05152E-07,6.28120E-07,6.51745E-07,6.76038E-07, & + 7.01010E-07,7.26674E-07,7.53041E-07,7.80124E-07,8.07933E-07, & + 8.36482E-07,8.65781E-07,8.95845E-07,9.26683E-07,9.58308E-07, & + 9.90732E-07,1.02397E-06,1.05803E-06,1.09292E-06,1.12866E-06, & + 1.16526E-06,1.20274E-06,1.24109E-06,1.28034E-06,1.32050E-06, & + 1.36158E-06,1.40359E-06,1.44655E-06,1.49046E-06,1.53534E-06, & + 1.58120E-06,1.62805E-06,1.67591E-06,1.72478E-06,1.77468E-06, & + 1.82561E-06,1.87760E-06,1.93066E-06,1.98479E-06,2.04000E-06/ + DATA (TOTPLNK(IDATA, 9),IDATA=101,150)/ & + 2.09631E-06,2.15373E-06,2.21228E-06,2.27196E-06,2.33278E-06, & + 2.39475E-06,2.45790E-06,2.52222E-06,2.58773E-06,2.65445E-06, & + 2.72238E-06,2.79152E-06,2.86191E-06,2.93354E-06,3.00643E-06, & + 3.08058E-06,3.15601E-06,3.23273E-06,3.31075E-06,3.39009E-06, & + 3.47074E-06,3.55272E-06,3.63605E-06,3.72072E-06,3.80676E-06, & + 3.89417E-06,3.98297E-06,4.07315E-06,4.16474E-06,4.25774E-06, & + 4.35217E-06,4.44802E-06,4.54532E-06,4.64406E-06,4.74428E-06, & + 4.84595E-06,4.94911E-06,5.05376E-06,5.15990E-06,5.26755E-06, & + 5.37671E-06,5.48741E-06,5.59963E-06,5.71340E-06,5.82871E-06, & + 5.94559E-06,6.06403E-06,6.18404E-06,6.30565E-06,6.42885E-06/ + DATA (TOTPLNK(IDATA, 9),IDATA=151,181)/ & + 6.55364E-06,6.68004E-06,6.80806E-06,6.93771E-06,7.06898E-06, & + 7.20190E-06,7.33646E-06,7.47267E-06,7.61056E-06,7.75010E-06, & + 7.89133E-06,8.03423E-06,8.17884E-06,8.32514E-06,8.47314E-06, & + 8.62284E-06,8.77427E-06,8.92743E-06,9.08231E-06,9.23893E-06, & + 9.39729E-06,9.55741E-06,9.71927E-06,9.88291E-06,1.00483E-05, & + 1.02155E-05,1.03844E-05,1.05552E-05,1.07277E-05,1.09020E-05, & + 1.10781E-05/ + DATA (TOTPLNK(IDATA,10),IDATA=1,50)/ & + 8.89300E-09,9.63263E-09,1.04235E-08,1.12685E-08,1.21703E-08, & + 1.31321E-08,1.41570E-08,1.52482E-08,1.64090E-08,1.76428E-08, & + 1.89533E-08,2.03441E-08,2.18190E-08,2.33820E-08,2.50370E-08, & + 2.67884E-08,2.86402E-08,3.05969E-08,3.26632E-08,3.48436E-08, & + 3.71429E-08,3.95660E-08,4.21179E-08,4.48040E-08,4.76294E-08, & + 5.05996E-08,5.37201E-08,5.69966E-08,6.04349E-08,6.40411E-08, & + 6.78211E-08,7.17812E-08,7.59276E-08,8.02670E-08,8.48059E-08, & + 8.95508E-08,9.45090E-08,9.96873E-08,1.05093E-07,1.10733E-07, & + 1.16614E-07,1.22745E-07,1.29133E-07,1.35786E-07,1.42711E-07, & + 1.49916E-07,1.57410E-07,1.65202E-07,1.73298E-07,1.81709E-07/ + DATA (TOTPLNK(IDATA,10),IDATA=51,100)/ & + 1.90441E-07,1.99505E-07,2.08908E-07,2.18660E-07,2.28770E-07, & + 2.39247E-07,2.50101E-07,2.61340E-07,2.72974E-07,2.85013E-07, & + 2.97467E-07,3.10345E-07,3.23657E-07,3.37413E-07,3.51623E-07, & + 3.66298E-07,3.81448E-07,3.97082E-07,4.13212E-07,4.29848E-07, & + 4.47000E-07,4.64680E-07,4.82898E-07,5.01664E-07,5.20991E-07, & + 5.40888E-07,5.61369E-07,5.82440E-07,6.04118E-07,6.26410E-07, & + 6.49329E-07,6.72887E-07,6.97095E-07,7.21964E-07,7.47506E-07, & + 7.73732E-07,8.00655E-07,8.28287E-07,8.56635E-07,8.85717E-07, & + 9.15542E-07,9.46122E-07,9.77469E-07,1.00960E-06,1.04251E-06, & + 1.07623E-06,1.11077E-06,1.14613E-06,1.18233E-06,1.21939E-06/ + DATA (TOTPLNK(IDATA,10),IDATA=101,150)/ & + 1.25730E-06,1.29610E-06,1.33578E-06,1.37636E-06,1.41785E-06, & + 1.46027E-06,1.50362E-06,1.54792E-06,1.59319E-06,1.63942E-06, & + 1.68665E-06,1.73487E-06,1.78410E-06,1.83435E-06,1.88564E-06, & + 1.93797E-06,1.99136E-06,2.04582E-06,2.10137E-06,2.15801E-06, & + 2.21576E-06,2.27463E-06,2.33462E-06,2.39577E-06,2.45806E-06, & + 2.52153E-06,2.58617E-06,2.65201E-06,2.71905E-06,2.78730E-06, & + 2.85678E-06,2.92749E-06,2.99946E-06,3.07269E-06,3.14720E-06, & + 3.22299E-06,3.30007E-06,3.37847E-06,3.45818E-06,3.53923E-06, & + 3.62161E-06,3.70535E-06,3.79046E-06,3.87695E-06,3.96481E-06, & + 4.05409E-06,4.14477E-06,4.23687E-06,4.33040E-06,4.42538E-06/ + DATA (TOTPLNK(IDATA,10),IDATA=151,181)/ & + 4.52180E-06,4.61969E-06,4.71905E-06,4.81991E-06,4.92226E-06, & + 5.02611E-06,5.13148E-06,5.23839E-06,5.34681E-06,5.45681E-06, & + 5.56835E-06,5.68146E-06,5.79614E-06,5.91242E-06,6.03030E-06, & + 6.14978E-06,6.27088E-06,6.39360E-06,6.51798E-06,6.64398E-06, & + 6.77165E-06,6.90099E-06,7.03198E-06,7.16468E-06,7.29906E-06, & + 7.43514E-06,7.57294E-06,7.71244E-06,7.85369E-06,7.99666E-06, & + 8.14138E-06/ + DATA (TOTPLNK(IDATA,11),IDATA=1,50)/ & + 2.53767E-09,2.77242E-09,3.02564E-09,3.29851E-09,3.59228E-09, & + 3.90825E-09,4.24777E-09,4.61227E-09,5.00322E-09,5.42219E-09, & + 5.87080E-09,6.35072E-09,6.86370E-09,7.41159E-09,7.99628E-09, & + 8.61974E-09,9.28404E-09,9.99130E-09,1.07437E-08,1.15436E-08, & + 1.23933E-08,1.32953E-08,1.42522E-08,1.52665E-08,1.63410E-08, & + 1.74786E-08,1.86820E-08,1.99542E-08,2.12985E-08,2.27179E-08, & + 2.42158E-08,2.57954E-08,2.74604E-08,2.92141E-08,3.10604E-08, & + 3.30029E-08,3.50457E-08,3.71925E-08,3.94476E-08,4.18149E-08, & + 4.42991E-08,4.69043E-08,4.96352E-08,5.24961E-08,5.54921E-08, & + 5.86277E-08,6.19081E-08,6.53381E-08,6.89231E-08,7.26681E-08/ + DATA (TOTPLNK(IDATA,11),IDATA=51,100)/ & + 7.65788E-08,8.06604E-08,8.49187E-08,8.93591E-08,9.39879E-08, & + 9.88106E-08,1.03834E-07,1.09063E-07,1.14504E-07,1.20165E-07, & + 1.26051E-07,1.32169E-07,1.38525E-07,1.45128E-07,1.51982E-07, & + 1.59096E-07,1.66477E-07,1.74132E-07,1.82068E-07,1.90292E-07, & + 1.98813E-07,2.07638E-07,2.16775E-07,2.26231E-07,2.36015E-07, & + 2.46135E-07,2.56599E-07,2.67415E-07,2.78592E-07,2.90137E-07, & + 3.02061E-07,3.14371E-07,3.27077E-07,3.40186E-07,3.53710E-07, & + 3.67655E-07,3.82031E-07,3.96848E-07,4.12116E-07,4.27842E-07, & + 4.44039E-07,4.60713E-07,4.77876E-07,4.95537E-07,5.13706E-07, & + 5.32392E-07,5.51608E-07,5.71360E-07,5.91662E-07,6.12521E-07/ + DATA (TOTPLNK(IDATA,11),IDATA=101,150)/ & + 6.33950E-07,6.55958E-07,6.78556E-07,7.01753E-07,7.25562E-07, & + 7.49992E-07,7.75055E-07,8.00760E-07,8.27120E-07,8.54145E-07, & + 8.81845E-07,9.10233E-07,9.39318E-07,9.69113E-07,9.99627E-07, & + 1.03087E-06,1.06286E-06,1.09561E-06,1.12912E-06,1.16340E-06, & + 1.19848E-06,1.23435E-06,1.27104E-06,1.30855E-06,1.34690E-06, & + 1.38609E-06,1.42614E-06,1.46706E-06,1.50886E-06,1.55155E-06, & + 1.59515E-06,1.63967E-06,1.68512E-06,1.73150E-06,1.77884E-06, & + 1.82715E-06,1.87643E-06,1.92670E-06,1.97797E-06,2.03026E-06, & + 2.08356E-06,2.13791E-06,2.19330E-06,2.24975E-06,2.30728E-06, & + 2.36589E-06,2.42560E-06,2.48641E-06,2.54835E-06,2.61142E-06/ + DATA (TOTPLNK(IDATA,11),IDATA=151,181)/ & + 2.67563E-06,2.74100E-06,2.80754E-06,2.87526E-06,2.94417E-06, & + 3.01429E-06,3.08562E-06,3.15819E-06,3.23199E-06,3.30704E-06, & + 3.38336E-06,3.46096E-06,3.53984E-06,3.62002E-06,3.70151E-06, & + 3.78433E-06,3.86848E-06,3.95399E-06,4.04084E-06,4.12907E-06, & + 4.21868E-06,4.30968E-06,4.40209E-06,4.49592E-06,4.59117E-06, & + 4.68786E-06,4.78600E-06,4.88561E-06,4.98669E-06,5.08926E-06, & + 5.19332E-06/ + DATA (TOTPLNK(IDATA,12),IDATA=1,50)/ & + 2.73921E-10,3.04500E-10,3.38056E-10,3.74835E-10,4.15099E-10, & + 4.59126E-10,5.07214E-10,5.59679E-10,6.16857E-10,6.79103E-10, & + 7.46796E-10,8.20335E-10,9.00144E-10,9.86671E-10,1.08039E-09, & + 1.18180E-09,1.29142E-09,1.40982E-09,1.53757E-09,1.67529E-09, & + 1.82363E-09,1.98327E-09,2.15492E-09,2.33932E-09,2.53726E-09, & + 2.74957E-09,2.97710E-09,3.22075E-09,3.48145E-09,3.76020E-09, & + 4.05801E-09,4.37595E-09,4.71513E-09,5.07672E-09,5.46193E-09, & + 5.87201E-09,6.30827E-09,6.77205E-09,7.26480E-09,7.78794E-09, & + 8.34304E-09,8.93163E-09,9.55537E-09,1.02159E-08,1.09151E-08, & + 1.16547E-08,1.24365E-08,1.32625E-08,1.41348E-08,1.50554E-08/ + DATA (TOTPLNK(IDATA,12),IDATA=51,100)/ & + 1.60264E-08,1.70500E-08,1.81285E-08,1.92642E-08,2.04596E-08, & + 2.17171E-08,2.30394E-08,2.44289E-08,2.58885E-08,2.74209E-08, & + 2.90290E-08,3.07157E-08,3.24841E-08,3.43371E-08,3.62782E-08, & + 3.83103E-08,4.04371E-08,4.26617E-08,4.49878E-08,4.74190E-08, & + 4.99589E-08,5.26113E-08,5.53801E-08,5.82692E-08,6.12826E-08, & + 6.44245E-08,6.76991E-08,7.11105E-08,7.46634E-08,7.83621E-08, & + 8.22112E-08,8.62154E-08,9.03795E-08,9.47081E-08,9.92066E-08, & + 1.03879E-07,1.08732E-07,1.13770E-07,1.18998E-07,1.24422E-07, & + 1.30048E-07,1.35880E-07,1.41924E-07,1.48187E-07,1.54675E-07, & + 1.61392E-07,1.68346E-07,1.75543E-07,1.82988E-07,1.90688E-07/ + DATA (TOTPLNK(IDATA,12),IDATA=101,150)/ & + 1.98650E-07,2.06880E-07,2.15385E-07,2.24172E-07,2.33247E-07, & + 2.42617E-07,2.52289E-07,2.62272E-07,2.72571E-07,2.83193E-07, & + 2.94147E-07,3.05440E-07,3.17080E-07,3.29074E-07,3.41430E-07, & + 3.54155E-07,3.67259E-07,3.80747E-07,3.94631E-07,4.08916E-07, & + 4.23611E-07,4.38725E-07,4.54267E-07,4.70245E-07,4.86666E-07, & + 5.03541E-07,5.20879E-07,5.38687E-07,5.56975E-07,5.75751E-07, & + 5.95026E-07,6.14808E-07,6.35107E-07,6.55932E-07,6.77293E-07, & + 6.99197E-07,7.21656E-07,7.44681E-07,7.68278E-07,7.92460E-07, & + 8.17235E-07,8.42614E-07,8.68606E-07,8.95223E-07,9.22473E-07, & + 9.50366E-07,9.78915E-07,1.00813E-06,1.03802E-06,1.06859E-06/ + DATA (TOTPLNK(IDATA,12),IDATA=151,181)/ & + 1.09986E-06,1.13184E-06,1.16453E-06,1.19796E-06,1.23212E-06, & + 1.26703E-06,1.30270E-06,1.33915E-06,1.37637E-06,1.41440E-06, & + 1.45322E-06,1.49286E-06,1.53333E-06,1.57464E-06,1.61679E-06, & + 1.65981E-06,1.70370E-06,1.74847E-06,1.79414E-06,1.84071E-06, & + 1.88821E-06,1.93663E-06,1.98599E-06,2.03631E-06,2.08759E-06, & + 2.13985E-06,2.19310E-06,2.24734E-06,2.30260E-06,2.35888E-06, & + 2.41619E-06/ + DATA (TOTPLNK(IDATA,13),IDATA=1,50)/ & + 4.53634E-11,5.11435E-11,5.75754E-11,6.47222E-11,7.26531E-11, & + 8.14420E-11,9.11690E-11,1.01921E-10,1.13790E-10,1.26877E-10, & + 1.41288E-10,1.57140E-10,1.74555E-10,1.93665E-10,2.14613E-10, & + 2.37548E-10,2.62633E-10,2.90039E-10,3.19948E-10,3.52558E-10, & + 3.88073E-10,4.26716E-10,4.68719E-10,5.14331E-10,5.63815E-10, & + 6.17448E-10,6.75526E-10,7.38358E-10,8.06277E-10,8.79625E-10, & + 9.58770E-10,1.04410E-09,1.13602E-09,1.23495E-09,1.34135E-09, & + 1.45568E-09,1.57845E-09,1.71017E-09,1.85139E-09,2.00268E-09, & + 2.16464E-09,2.33789E-09,2.52309E-09,2.72093E-09,2.93212E-09, & + 3.15740E-09,3.39757E-09,3.65341E-09,3.92579E-09,4.21559E-09/ + DATA (TOTPLNK(IDATA,13),IDATA=51,100)/ & + 4.52372E-09,4.85115E-09,5.19886E-09,5.56788E-09,5.95928E-09, & + 6.37419E-09,6.81375E-09,7.27917E-09,7.77168E-09,8.29256E-09, & + 8.84317E-09,9.42487E-09,1.00391E-08,1.06873E-08,1.13710E-08, & + 1.20919E-08,1.28515E-08,1.36514E-08,1.44935E-08,1.53796E-08, & + 1.63114E-08,1.72909E-08,1.83201E-08,1.94008E-08,2.05354E-08, & + 2.17258E-08,2.29742E-08,2.42830E-08,2.56545E-08,2.70910E-08, & + 2.85950E-08,3.01689E-08,3.18155E-08,3.35373E-08,3.53372E-08, & + 3.72177E-08,3.91818E-08,4.12325E-08,4.33727E-08,4.56056E-08, & + 4.79342E-08,5.03617E-08,5.28915E-08,5.55270E-08,5.82715E-08, & + 6.11286E-08,6.41019E-08,6.71951E-08,7.04119E-08,7.37560E-08/ + DATA (TOTPLNK(IDATA,13),IDATA=101,150)/ & + 7.72315E-08,8.08424E-08,8.45927E-08,8.84866E-08,9.25281E-08, & + 9.67218E-08,1.01072E-07,1.05583E-07,1.10260E-07,1.15107E-07, & + 1.20128E-07,1.25330E-07,1.30716E-07,1.36291E-07,1.42061E-07, & + 1.48031E-07,1.54206E-07,1.60592E-07,1.67192E-07,1.74015E-07, & + 1.81064E-07,1.88345E-07,1.95865E-07,2.03628E-07,2.11643E-07, & + 2.19912E-07,2.28443E-07,2.37244E-07,2.46318E-07,2.55673E-07, & + 2.65316E-07,2.75252E-07,2.85489E-07,2.96033E-07,3.06891E-07, & + 3.18070E-07,3.29576E-07,3.41417E-07,3.53600E-07,3.66133E-07, & + 3.79021E-07,3.92274E-07,4.05897E-07,4.19899E-07,4.34288E-07, & + 4.49071E-07,4.64255E-07,4.79850E-07,4.95863E-07,5.12300E-07/ + DATA (TOTPLNK(IDATA,13),IDATA=151,181)/ & + 5.29172E-07,5.46486E-07,5.64250E-07,5.82473E-07,6.01164E-07, & + 6.20329E-07,6.39979E-07,6.60122E-07,6.80767E-07,7.01922E-07, & + 7.23596E-07,7.45800E-07,7.68539E-07,7.91826E-07,8.15669E-07, & + 8.40076E-07,8.65058E-07,8.90623E-07,9.16783E-07,9.43544E-07, & + 9.70917E-07,9.98912E-07,1.02754E-06,1.05681E-06,1.08673E-06, & + 1.11731E-06,1.14856E-06,1.18050E-06,1.21312E-06,1.24645E-06, & + 1.28049E-06/ + DATA (TOTPLNK(IDATA,14),IDATA=1,50)/ & + 1.40113E-11,1.59358E-11,1.80960E-11,2.05171E-11,2.32266E-11, & + 2.62546E-11,2.96335E-11,3.33990E-11,3.75896E-11,4.22469E-11, & + 4.74164E-11,5.31466E-11,5.94905E-11,6.65054E-11,7.42522E-11, & + 8.27975E-11,9.22122E-11,1.02573E-10,1.13961E-10,1.26466E-10, & + 1.40181E-10,1.55206E-10,1.71651E-10,1.89630E-10,2.09265E-10, & + 2.30689E-10,2.54040E-10,2.79467E-10,3.07128E-10,3.37190E-10, & + 3.69833E-10,4.05243E-10,4.43623E-10,4.85183E-10,5.30149E-10, & + 5.78755E-10,6.31255E-10,6.87910E-10,7.49002E-10,8.14824E-10, & + 8.85687E-10,9.61914E-10,1.04385E-09,1.13186E-09,1.22631E-09, & + 1.32761E-09,1.43617E-09,1.55243E-09,1.67686E-09,1.80992E-09/ + DATA (TOTPLNK(IDATA,14),IDATA=51,100)/ & + 1.95212E-09,2.10399E-09,2.26607E-09,2.43895E-09,2.62321E-09, & + 2.81949E-09,3.02844E-09,3.25073E-09,3.48707E-09,3.73820E-09, & + 4.00490E-09,4.28794E-09,4.58819E-09,4.90647E-09,5.24371E-09, & + 5.60081E-09,5.97875E-09,6.37854E-09,6.80120E-09,7.24782E-09, & + 7.71950E-09,8.21740E-09,8.74271E-09,9.29666E-09,9.88054E-09, & + 1.04956E-08,1.11434E-08,1.18251E-08,1.25422E-08,1.32964E-08, & + 1.40890E-08,1.49217E-08,1.57961E-08,1.67140E-08,1.76771E-08, & + 1.86870E-08,1.97458E-08,2.08553E-08,2.20175E-08,2.32342E-08, & + 2.45077E-08,2.58401E-08,2.72334E-08,2.86900E-08,3.02122E-08, & + 3.18021E-08,3.34624E-08,3.51954E-08,3.70037E-08,3.88899E-08/ + DATA (TOTPLNK(IDATA,14),IDATA=101,150)/ & + 4.08568E-08,4.29068E-08,4.50429E-08,4.72678E-08,4.95847E-08, & + 5.19963E-08,5.45058E-08,5.71161E-08,5.98309E-08,6.26529E-08, & + 6.55857E-08,6.86327E-08,7.17971E-08,7.50829E-08,7.84933E-08, & + 8.20323E-08,8.57035E-08,8.95105E-08,9.34579E-08,9.75488E-08, & + 1.01788E-07,1.06179E-07,1.10727E-07,1.15434E-07,1.20307E-07, & + 1.25350E-07,1.30566E-07,1.35961E-07,1.41539E-07,1.47304E-07, & + 1.53263E-07,1.59419E-07,1.65778E-07,1.72345E-07,1.79124E-07, & + 1.86122E-07,1.93343E-07,2.00792E-07,2.08476E-07,2.16400E-07, & + 2.24568E-07,2.32988E-07,2.41666E-07,2.50605E-07,2.59813E-07, & + 2.69297E-07,2.79060E-07,2.89111E-07,2.99455E-07,3.10099E-07/ + DATA (TOTPLNK(IDATA,14),IDATA=151,181)/ & + 3.21049E-07,3.32311E-07,3.43893E-07,3.55801E-07,3.68041E-07, & + 3.80621E-07,3.93547E-07,4.06826E-07,4.20465E-07,4.34473E-07, & + 4.48856E-07,4.63620E-07,4.78774E-07,4.94325E-07,5.10280E-07, & + 5.26648E-07,5.43436E-07,5.60652E-07,5.78302E-07,5.96397E-07, & + 6.14943E-07,6.33949E-07,6.53421E-07,6.73370E-07,6.93803E-07, & + 7.14731E-07,7.36157E-07,7.58095E-07,7.80549E-07,8.03533E-07, & + 8.27050E-07/ + DATA (TOTPLNK(IDATA,15),IDATA=1,50)/ & + 3.90483E-12,4.47999E-12,5.13122E-12,5.86739E-12,6.69829E-12, & + 7.63467E-12,8.68833E-12,9.87221E-12,1.12005E-11,1.26885E-11, & + 1.43534E-11,1.62134E-11,1.82888E-11,2.06012E-11,2.31745E-11, & + 2.60343E-11,2.92087E-11,3.27277E-11,3.66242E-11,4.09334E-11, & + 4.56935E-11,5.09455E-11,5.67338E-11,6.31057E-11,7.01127E-11, & + 7.78096E-11,8.62554E-11,9.55130E-11,1.05651E-10,1.16740E-10, & + 1.28858E-10,1.42089E-10,1.56519E-10,1.72243E-10,1.89361E-10, & + 2.07978E-10,2.28209E-10,2.50173E-10,2.73999E-10,2.99820E-10, & + 3.27782E-10,3.58034E-10,3.90739E-10,4.26067E-10,4.64196E-10, & + 5.05317E-10,5.49631E-10,5.97347E-10,6.48689E-10,7.03891E-10/ + DATA (TOTPLNK(IDATA,15),IDATA=51,100)/ & + 7.63201E-10,8.26876E-10,8.95192E-10,9.68430E-10,1.04690E-09, & + 1.13091E-09,1.22079E-09,1.31689E-09,1.41957E-09,1.52922E-09, & + 1.64623E-09,1.77101E-09,1.90401E-09,2.04567E-09,2.19647E-09, & + 2.35690E-09,2.52749E-09,2.70875E-09,2.90127E-09,3.10560E-09, & + 3.32238E-09,3.55222E-09,3.79578E-09,4.05375E-09,4.32682E-09, & + 4.61574E-09,4.92128E-09,5.24420E-09,5.58536E-09,5.94558E-09, & + 6.32575E-09,6.72678E-09,7.14964E-09,7.59526E-09,8.06470E-09, & + 8.55897E-09,9.07916E-09,9.62638E-09,1.02018E-08,1.08066E-08, & + 1.14420E-08,1.21092E-08,1.28097E-08,1.35446E-08,1.43155E-08, & + 1.51237E-08,1.59708E-08,1.68581E-08,1.77873E-08,1.87599E-08/ + DATA (TOTPLNK(IDATA,15),IDATA=101,150)/ & + 1.97777E-08,2.08423E-08,2.19555E-08,2.31190E-08,2.43348E-08, & + 2.56045E-08,2.69302E-08,2.83140E-08,2.97578E-08,3.12636E-08, & + 3.28337E-08,3.44702E-08,3.61755E-08,3.79516E-08,3.98012E-08, & + 4.17265E-08,4.37300E-08,4.58143E-08,4.79819E-08,5.02355E-08, & + 5.25777E-08,5.50114E-08,5.75393E-08,6.01644E-08,6.28896E-08, & + 6.57177E-08,6.86521E-08,7.16959E-08,7.48520E-08,7.81239E-08, & + 8.15148E-08,8.50282E-08,8.86675E-08,9.24362E-08,9.63380E-08, & + 1.00376E-07,1.04555E-07,1.08878E-07,1.13349E-07,1.17972E-07, & + 1.22751E-07,1.27690E-07,1.32793E-07,1.38064E-07,1.43508E-07, & + 1.49129E-07,1.54931E-07,1.60920E-07,1.67099E-07,1.73473E-07/ + DATA (TOTPLNK(IDATA,15),IDATA=151,181)/ & + 1.80046E-07,1.86825E-07,1.93812E-07,2.01014E-07,2.08436E-07, & + 2.16082E-07,2.23957E-07,2.32067E-07,2.40418E-07,2.49013E-07, & + 2.57860E-07,2.66963E-07,2.76328E-07,2.85961E-07,2.95868E-07, & + 3.06053E-07,3.16524E-07,3.27286E-07,3.38345E-07,3.49707E-07, & + 3.61379E-07,3.73367E-07,3.85676E-07,3.98315E-07,4.11287E-07, & + 4.24602E-07,4.38265E-07,4.52283E-07,4.66662E-07,4.81410E-07, & + 4.96535E-07/ + DATA (TOTPLNK(IDATA,16),IDATA=1,50)/ & + 4.65378E-13,5.41927E-13,6.29913E-13,7.30869E-13,8.46510E-13, & + 9.78750E-13,1.12972E-12,1.30181E-12,1.49764E-12,1.72016E-12, & + 1.97260E-12,2.25858E-12,2.58206E-12,2.94744E-12,3.35955E-12, & + 3.82372E-12,4.34581E-12,4.93225E-12,5.59010E-12,6.32711E-12, & + 7.15171E-12,8.07317E-12,9.10159E-12,1.02480E-11,1.15244E-11, & + 1.29438E-11,1.45204E-11,1.62697E-11,1.82084E-11,2.03545E-11, & + 2.27278E-11,2.53494E-11,2.82424E-11,3.14313E-11,3.49431E-11, & + 3.88064E-11,4.30522E-11,4.77139E-11,5.28273E-11,5.84308E-11, & + 6.45658E-11,7.12764E-11,7.86103E-11,8.66176E-11,9.53534E-11, & + 1.04875E-10,1.15245E-10,1.26528E-10,1.38796E-10,1.52123E-10/ + DATA (TOTPLNK(IDATA,16),IDATA=51,100)/ & + 1.66590E-10,1.82281E-10,1.99287E-10,2.17704E-10,2.37632E-10, & + 2.59182E-10,2.82468E-10,3.07610E-10,3.34738E-10,3.63988E-10, & + 3.95504E-10,4.29438E-10,4.65951E-10,5.05212E-10,5.47402E-10, & + 5.92707E-10,6.41329E-10,6.93477E-10,7.49371E-10,8.09242E-10, & + 8.73338E-10,9.41911E-10,1.01524E-09,1.09359E-09,1.17728E-09, & + 1.26660E-09,1.36190E-09,1.46350E-09,1.57177E-09,1.68709E-09, & + 1.80984E-09,1.94044E-09,2.07932E-09,2.22693E-09,2.38373E-09, & + 2.55021E-09,2.72689E-09,2.91429E-09,3.11298E-09,3.32353E-09, & + 3.54655E-09,3.78265E-09,4.03251E-09,4.29679E-09,4.57620E-09, & + 4.87148E-09,5.18341E-09,5.51276E-09,5.86037E-09,6.22708E-09/ + DATA (TOTPLNK(IDATA,16),IDATA=101,150)/ & + 6.61381E-09,7.02145E-09,7.45097E-09,7.90336E-09,8.37967E-09, & + 8.88092E-09,9.40827E-09,9.96280E-09,1.05457E-08,1.11583E-08, & + 1.18017E-08,1.24773E-08,1.31865E-08,1.39306E-08,1.47111E-08, & + 1.55295E-08,1.63872E-08,1.72860E-08,1.82274E-08,1.92132E-08, & + 2.02450E-08,2.13247E-08,2.24541E-08,2.36352E-08,2.48699E-08, & + 2.61602E-08,2.75082E-08,2.89161E-08,3.03860E-08,3.19203E-08, & + 3.35213E-08,3.51913E-08,3.69330E-08,3.87486E-08,4.06411E-08, & + 4.26129E-08,4.46668E-08,4.68058E-08,4.90325E-08,5.13502E-08, & + 5.37617E-08,5.62703E-08,5.88791E-08,6.15915E-08,6.44107E-08, & + 6.73404E-08,7.03841E-08,7.35453E-08,7.68278E-08,8.02355E-08/ + DATA (TOTPLNK(IDATA,16),IDATA=151,181)/ & + 8.37721E-08,8.74419E-08,9.12486E-08,9.51968E-08,9.92905E-08, & + 1.03534E-07,1.07932E-07,1.12490E-07,1.17211E-07,1.22100E-07, & + 1.27163E-07,1.32404E-07,1.37829E-07,1.43443E-07,1.49250E-07, & + 1.55257E-07,1.61470E-07,1.67893E-07,1.74532E-07,1.81394E-07, & + 1.88485E-07,1.95810E-07,2.03375E-07,2.11189E-07,2.19256E-07, & + 2.27583E-07,2.36177E-07,2.45046E-07,2.54196E-07,2.63634E-07, & + 2.73367E-07/ + + DATA (TOTPLK16(IDATA),IDATA=1,50)/ & + 4.46128E-13,5.19008E-13,6.02681E-13,6.98580E-13,8.08302E-13, & + 9.33629E-13,1.07654E-12,1.23925E-12,1.42419E-12,1.63407E-12, & + 1.87190E-12,2.14099E-12,2.44498E-12,2.78793E-12,3.17424E-12, & + 3.60881E-12,4.09698E-12,4.64461E-12,5.25813E-12,5.94456E-12, & + 6.71156E-12,7.56752E-12,8.52154E-12,9.58357E-12,1.07644E-11, & + 1.20758E-11,1.35304E-11,1.51420E-11,1.69256E-11,1.88973E-11, & + 2.10746E-11,2.34762E-11,2.61227E-11,2.90356E-11,3.22388E-11, & + 3.57574E-11,3.96187E-11,4.38519E-11,4.84883E-11,5.35616E-11, & + 5.91075E-11,6.51647E-11,7.17743E-11,7.89797E-11,8.68284E-11, & + 9.53697E-11,1.04658E-10,1.14748E-10,1.25701E-10,1.37582E-10/ + DATA (TOTPLK16(IDATA),IDATA=51,100)/ & + 1.50457E-10,1.64400E-10,1.79487E-10,1.95799E-10,2.13422E-10, & + 2.32446E-10,2.52970E-10,2.75094E-10,2.98925E-10,3.24578E-10, & + 3.52172E-10,3.81833E-10,4.13695E-10,4.47897E-10,4.84588E-10, & + 5.23922E-10,5.66063E-10,6.11182E-10,6.59459E-10,7.11081E-10, & + 7.66251E-10,8.25172E-10,8.88065E-10,9.55155E-10,1.02668E-09, & + 1.10290E-09,1.18406E-09,1.27044E-09,1.36233E-09,1.46002E-09, & + 1.56382E-09,1.67406E-09,1.79108E-09,1.91522E-09,2.04686E-09, & + 2.18637E-09,2.33416E-09,2.49063E-09,2.65622E-09,2.83136E-09, & + 3.01653E-09,3.21221E-09,3.41890E-09,3.63712E-09,3.86740E-09, & + 4.11030E-09,4.36641E-09,4.63631E-09,4.92064E-09,5.22003E-09/ + DATA (TOTPLK16(IDATA),IDATA=101,150)/ & + 5.53516E-09,5.86670E-09,6.21538E-09,6.58191E-09,6.96708E-09, & + 7.37165E-09,7.79645E-09,8.24229E-09,8.71007E-09,9.20066E-09, & + 9.71498E-09,1.02540E-08,1.08186E-08,1.14100E-08,1.20290E-08, & + 1.26767E-08,1.33544E-08,1.40630E-08,1.48038E-08,1.55780E-08, & + 1.63867E-08,1.72313E-08,1.81130E-08,1.90332E-08,1.99932E-08, & + 2.09945E-08,2.20385E-08,2.31267E-08,2.42605E-08,2.54416E-08, & + 2.66716E-08,2.79520E-08,2.92846E-08,3.06711E-08,3.21133E-08, & + 3.36128E-08,3.51717E-08,3.67918E-08,3.84749E-08,4.02232E-08, & + 4.20386E-08,4.39231E-08,4.58790E-08,4.79083E-08,5.00132E-08, & + 5.21961E-08,5.44592E-08,5.68049E-08,5.92356E-08,6.17537E-08/ + DATA (TOTPLK16(IDATA),IDATA=151,181)/ & + 6.43617E-08,6.70622E-08,6.98578E-08,7.27511E-08,7.57449E-08, & + 7.88419E-08,8.20449E-08,8.53568E-08,8.87805E-08,9.23190E-08, & + 9.59753E-08,9.97526E-08,1.03654E-07,1.07682E-07,1.11841E-07, & + 1.16134E-07,1.20564E-07,1.25135E-07,1.29850E-07,1.34712E-07, & + 1.39726E-07,1.44894E-07,1.50221E-07,1.55711E-07,1.61367E-07, & + 1.67193E-07,1.73193E-07,1.79371E-07,1.85732E-07,1.92279E-07, & + 1.99016E-07/ + + + + +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE RRTMLWRAD(rthraten,glw,olr,emiss & + ,p8w,p3d,pi3d & + ,dz8w,t3d,t8w,rho3d,r,g & + ,icloud, warm_rain & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,qv3d,qc3d,qr3d & + ,qi3d,qs3d,qg3d,cldfra3d & + ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg & + ) +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + LOGICAL, INTENT(IN ) :: warm_rain +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ICLOUD +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + T3D, & + t8w, & + p8w, & + P3D, & + pi3D, & + rho3D +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHRATEN +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: EMISS +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GLW, & + OLR +! + REAL, INTENT(IN ) :: R,G +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + CLDFRA3D, & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D + + LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG + +! LOCAL VARS + + REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & + Tw1D, & + PHYD + + REAL, DIMENSION( kts:kte ) :: TTEN1D, & + CLDFRA1D, & + DZ1D, & + P1D, & + PHYDMID, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + QS1D, & + QG1D +! + REAL :: TSFC,GLW0,OLR0,EMISS0,FP +! + INTEGER:: i,j,K,NK + LOGICAL :: predicate + +!------------------------------------------------------------------ + +!-----CALCULATE LONG WAVE RADIATION +! + j_loop: DO J=jts,jte + i_loop: DO I=its,ite + +! reverse vars +! p1D pw1D are in mb + +! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) +! PHYD REPLACES P8W, PHYDMID REPLACES P3D + PHYD(kts) = p8w(I,kts,J) +! first guess + DO K = KTS,KTE + PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J) + ENDDO +! correction factor FP to match p8w(I,kts,J)-p8w(I,kte,J) + FP = (p8w(I,kts,J)-p8w(I,kte,J))/(PHYD(KTS)-PHYD(KTE)) +! final pass + DO K = KTS,KTE + PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J)*FP + PHYDMID(K)= 0.5*(PHYD(K)+PHYD(K+1)) + ENDDO + + do k=kts,kte+1 + NK=kme-k+kms +! Pw1D(K) = p8w(I,NK,J)/100. + Pw1D(K) = PHYD(NK)/100. + Tw1D(K) = t8w(I,NK,J) + enddo + + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + CLDFRA1D(k)=0. + ENDDO + + DO K=kts,kte + NK=kme-1-K+kms + QV1D(K)=QV3D(I,NK,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + + DO K=kts,kte + NK=kme-1-K+kms + TTEN1D(K)=0. + T1D(K)=T3D(I,NK,J) +! P1D(K)=P3D(I,NK,J)/100. + P1D(K)=PHYDMID(NK)/100. + DZ1D(K)=dz8w(I,NK,J) + ENDDO + + IF (ICLOUD .ne. 0) THEN + IF ( PRESENT( CLDFRA3D ) ) THEN + DO K=kts,kte + NK=kme-1-K+kms + CLDFRA1D(k)=CLDFRA3D(I,NK,J) + ENDDO + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF ( F_QC) THEN + DO K=kts,kte + NK=kme-1-K+kms + QC1D(K)=QC3D(I,NK,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF ( F_QR) THEN + DO K=kts,kte + NK=kme-1-K+kms + QR1D(K)=QR3D(I,NK,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + + IF (.NOT. predicate .and. .not. warm_rain) THEN + DO K=kts,kte + IF (T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QS1D(K)=QR1D(K) + QC1D(K)=0. + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + + IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN + DO K=kts,kte + NK=kme-1-K+kms + QI1D(K)=QI3D(I,NK,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + NK=kme-1-K+kms + QS1D(K)=QS3D(I,NK,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + NK=kme-1-K+kms + QG1D(K)=QG3D(I,NK,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + + ENDIF + + EMISS0=EMISS(I,J) + GLW0=0. + OLR0=0. + TSFC=Tw1D(kme) + + CALL RRTM(tten1d,glw0,olr0,tsfc,cldfra1d,t1d,tw1d,qv1d,qc1d, & + qr1d,qi1d,qs1d,qg1d,p1d,pW1d,dz1d, & + emiss0,r,g, & + kts,kte ) + + GLW(I,J)=GLW0 + OLR(I,J)=OLR0 + + DO K=kts,kte + nk=kme-1-k+kms + rthraten(i,k,j)=rthraten(i,k,j)+tten1d(nk)/pi3d(i,k,j) + ENDDO + + END DO i_loop + END DO j_loop + +!------------------------------------------------------------------- + + END SUBROUTINE RRTMLWRAD + + +!**************************************************************************** +!* * +!* RRTM * +!* * +!* * +!* * +!* RAPID RADIATIVE TRANSFER MODEL * +!* * +!* * +!* ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +!* 840 MEMORIAL DRIVE * +!* CAMBRIDGE, MA 02139 * +!* * +!* * +!* ELI J. MLAWER * +!* STEVEN J. TAUBMAN~ * +!* SHEPARD A. CLOUGH * +!* * +!* * +!* ~currently at GFDL * +!* * +!* * +!* * +!* email: mlawer@aer.com * +!* * +!* The authors wish to acknowledge the contributions of the * +!* following people: Patrick D. Brown, Michael J. Iacono, * +!* Ronald E. Farren, Luke Chen, Robert Bergstrom. * +!* * +!**************************************************************************** + +! *** This version of RRTM has been altered to interface with the +! *** NCAR MM5 mesoscale model for the calculation of longwave radiative +! *** transfer (based on a code for interface with CCM model by M. J. Iacono) +! *** J. Dudhia ; March, 1999 +!--------------------------------------------------------------------- + SUBROUTINE RRTM(TTEN,GLW,OLR,TSFC,CLDFRA,T,Tw,QV,QC, & + QR,QI,QS,QG,P,Pw,DZ, & + EMISS,R,G, & + kts,kte ) +!--------------------------------------------------------------------- +! *** This program is the driver for RRTM, the AER LW radiation model. +! This routine: +! Calls MM5ATM to provide atmosphere in column and boundary values +! a) calls GASABS to calculate gaseous optical depths +! b) calls SETCOEF to calculate various quantities needed for +! the radiative transfer algorithm +! c) calls RTRN (for both clear and cloudy columns) to do the +! radiative transfer calculation +! d) passes the necessary flux and cooling rate back to MM5 +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: kts, kte +! + REAL, DIMENSION( kts:kte+1 ), INTENT(IN ) :: Pw, & + Tw + + REAL, DIMENSION( kts:kte ), INTENT(IN ) :: CLDFRA, & + T, & + P, & + DZ +! + REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & + QV + REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & + QC, & + QR, & + QI, & + QS, & + QG +! + REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN +! + REAL, INTENT(IN ) :: R, G, EMISS +! + REAL, INTENT(INOUT) :: TSFC,GLW,OLR + +! LOCAL VAR + + INTEGER, DIMENSION( NGPT,kts:kte+1 ) :: ITR + + REAL, DIMENSION( NGPT,kts:kte+1 ) :: PFRAC, & + TAUG + + REAL, DIMENSION( 35,kts:kte+1 ) :: WKL + + REAL, DIMENSION( MAXXSEC,kts:kte+1 ) :: WX + + REAL, DIMENSION( kts:kte ) :: O3PROF + + REAL, DIMENSION( kts:kte+1 ) :: PAVEL, & + TAVEL, & + CLDFRAC, & + TAUCLOUD, & + COLDRY, & + COLH2O, & + COLCO2, & + COLO3, & + COLN2O, & + COLCH4, & + COLO2, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + +! + INTEGER, DIMENSION( kts:kte+1 ) :: ICLDLYR, & + JP, & + JT, & + JT1, & + INDSELF + + REAL, DIMENSION( 0:kte+1 ) :: PZ, & + TZ, & + TOTDFLUX, & + TOTUFLUX, & + HTR +! + INTEGER :: I,K,ktep1 + INTEGER :: LAYTROP,LAYSWTCH,LAYLOW + REAL :: TBOUND + REAL, DIMENSION(NBANDS) :: SEMISS + + +!--------------------------------------------------------------------------- +! RRTM Definitions +! NGPT ! Total number of g-point subintervals +! MXLAY ! Maximum number of model layers +! NBANDS ! Number of longwave spectral bands +! PI ! Geometric constant +! FLUXFAC ! Radiance to flux conversion factor +! HEATFAC ! Heating rate conversion factor +! NG(NBANDS) ! Number of g-points per band for input +! absorption coefficient data +! NSPA(NBANDS),NSPB(NBANDS) ! Number of reference atmospheres per band +! WAVENUM1(NBANDS) ! Longwave band lower limit (wavenumbers) +! WAVENUM2(NBANDS) ! Longwave band upper limit (wavenumbers) +! DELWAVE ! Longwave band width (wavenumbers) +! NLAYERS ! Number of model layers (mkx+1) +! PAVEL(MXLAY) ! Layer pressures (mb) +! PZ(0:MXLAY) ! Level (interface) pressures (mb) +! TAVEL(MXLAY) ! Layer temperatures (K) +! TZ(0:MXLAY) ! Level (interface) temperatures(mb) +! TBOUND ! Surface temperature (K) +! CLDFRAC(MXLAY) ! Layer cloud fraction +! TAUCLOUD(MXLAY) ! Layer cloud optical depth +! ITR(NGPT,MXLAY) ! Integer look-up table index +! PFRAC(NGPT,MXLAY) ! Planck fractions +! ICLDLYR(MXLAY) ! Flag for cloudy layers +! TOTUFLUX(0:MXLAY) ! Upward longwave flux (W/m2) +! TOTDFLUX(0:MXLAY) ! Downward longwave flux (W/m2) +! FNET(0:MXLAY) ! Net longwave flux (W/m2) +! HTR(0:MXLAY) ! Longwave heating rate (K/day) +! CLRNTTOA ! Clear-sky TOA outgoing flux (W/m2) +! CLRNTSRF ! Clear-sky net surface flux (W/m2) +! TOTUCLFL(0:MXLAY) ! Clear-sky upward longwave flux (W/m2) +! TOTDCLFL(0:MXLAY) ! Clear-sky downward longwave flux (W/m2) +! FNETC(0:MXLAY) ! Clear-sky net longwave flux (W/m2) +! HTRC(0:MXLAY) ! Clear-sky longwave heating rate (K/day) +! +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. +!--------------------------------------------------------------------------- + + ktep1=kte+1 +! +! CLOUD EMISSIVITIES (M^2/G) +! THESE ARE CONSISTENT WITH LWRAD (ABCW=0.5*(ABUP+ABDOWN)) +! +! ONEMINUS = 1. - 1.E-6 +! PI = 2.*ASIN(1.) +! FLUXFAC = PI * 2.D4 +! + CALL INIRAD (O3PROF,Pw,kts,kte) + +! Prepare atmospheric profile from CCM for use in RRTM, and define +! other RRTM input parameters. Arrays are passed back through the +! existing RRTM commons and arrays. + + CALL MM5ATM(CLDFRA,O3PROF,T,Tw,TSFC,QV,QC,QR,QI,QS,QG, & + P,Pw,DZ,EMISS,R,G, & + PAVEL,TAVEL,PZ,TZ,CLDFRAC,TAUCLOUD,COLDRY, & + WKL,WX,TBOUND,SEMISS, & + kts,kte ) + +! Calculate information needed by the radiative transfer routine +! that is specific to this atmosphere, especially some of the +! coefficients and indices needed to compute the optical depths +! by interpolating data from stored reference atmospheres. + + CALL SETCOEF(kts,ktep1, & + PAVEL,TAVEL,COLDRY,COLH2O,COLCO2,COLO3, & + COLN2O,COLCH4,COLO2,CO2MULT, & + FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC, & + JP,JT,JT1,INDSELF,WKL,LAYTROP,LAYSWTCH,LAYLOW) + + CALL GASABS(kts,ktep1, & + COLDRY,COLH2O,COLCO2,COLO3,COLN2O,COLCH4, & + COLO2,CO2MULT, & + FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC, & + JP,JT,JT1,INDSELF,ITR,WX,PFRAC,TAUG, & + LAYTROP,LAYSWTCH,LAYLOW ) + +! Check for cloud in column. Use original CCM LW threshold: if total +! clear sky fraction < 0.999, then column is cloudy, otherwise consider +! it clear. Also, set up flag array, icldlyr, for use in radiative +! transfer. Set icldlyr to one for each layer with cloud. If tclrsf +! is not available, icldlyr can be set from cldfrac alone. + + do 1500 k = 1, nlayers + if (cldfrac(k).gt.0.) then + icldlyr(k) = 1 + else + icldlyr(k) = 0 + endif + 1500 continue + +! Call the radiative transfer routine. + + CALL RTRN(kts,ktep1, & + TAVEL, PZ, TZ, CLDFRAC, TAUCLOUD, TOTDFLUX, & + TOTUFLUX, HTR, ICLDLYR, ITR, PFRAC, TBOUND,SEMISS ) + +! Pass total sky up and down flux profiles to CCM output arrays and +! convert from mks to cgs units for CCM. Pass clear sky TOA and surface +! net fluxes to CCM fields for diagnostics. Pass total sky heating rate +! profile to CCM output arrays and convert units to K/sec. The vertical +! array index (bottom to top in RRTM) is reversed for CCM fields. + +! flntc(iiplon) = CLRNTTOA*1.e3 +! flnsc(iiplon) = CLRNTSRF*1.e3 +! do 2400 k = 0, NLAYERS-1 +! fulc(k+1) = TOTUCLFL(NLAYERS-1-k)*1.e3 +! fdlc(k+1) = TOTDCLFL(NLAYERS-1-k)*1.e3 +! ful(k+1) = TOTUFLUX(NLAYERS-1-k)*1.e3 +! fdl(k+1) = TOTDFLUX(NLAYERS-1-k)*1.e3 +! 2400 continue + do 2450 k = 1, NLAYERS-1 +! qrlc(k) = HTRC(NLAYERS-1-k)/86400. +! qrl(k) = HTR(NLAYERS-1-k)/86400. + TTEN(K)=HTR(NLAYERS-1-k)/86400. + 2450 continue + GLW = TOTDFLUX(0) + OLR = TOTUFLUX(NLAYERS) + + END SUBROUTINE RRTM + + +!*************************************************************************** + SUBROUTINE CMBGB1(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, FORREF, & + SELFREFC, FORREFC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! Original version: Michael J. Iacono; July, 1998 +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! The subroutines CMBGB1->CMBGB16 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 16 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMINIT. Plank fraction data +! in arrays FRACREFA and FRACREFB are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTM. +! +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG),abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG), FRACREFB(MG), FORREF(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG1), FORREFC(NG1) + REAL FRACREFAC(NG1), FRACREFBC(NG1) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(1) + SUMK = 0. + DO 2600 IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM) + 2600 CONTINUE + ABSA1(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(1) + SUMK = 0. + DO 3600 IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM) + 3600 CONTINUE + ABSB1(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(1) + SUMK = 0. + DO 4600 IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + IPRSM = 0 + DO 5400 IGC = 1,NGC(1) + SUMK = 0. + SUMF1 = 0. + SUMF2 = 0. + DO 5600 IPR = 1, NGN(IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + FORREF(IPRSM)*RWGT(IPRSM) + SUMF1= SUMF1+ FRACREFA(IPRSM) + SUMF2= SUMF2+ FRACREFB(IPRSM) + 5600 CONTINUE + FORREFC(IGC) = SUMK + FRACREFAC(IGC) = SUMF1 + FRACREFBC(IGC) = SUMF2 + 5400 CONTINUE + + END SUBROUTINE CMBGB1 + +!*************************************************************************** + SUBROUTINE CMBGB2(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, FORREF, & + SELFREFC, FORREFC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG),abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,13), FRACREFB(MG), FORREF(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG2), FORREFC(NG2) + REAL FRACREFAC(NG2,13), FRACREFBC(NG2) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(2) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+16) + 2600 CONTINUE + ABSA2(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(2) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+16) + 3600 CONTINUE + ABSB2(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(2) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+16) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JPJP = 1,13 + IPRSM = 0 + DO 5400 IGC = 1,NGC(2) + SUMF = 0. + DO 5600 IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 5600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 5400 CONTINUE + 5000 CONTINUE + + IPRSM = 0 + DO 6400 IGC = 1,NGC(2) + SUMK = 0. + SUMF = 0. + DO 6600 IPR = 1, NGN(NGS(1)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + FORREF(IPRSM)*RWGT(IPRSM+16) + SUMF = SUMF + FRACREFB(IPRSM) + 6600 CONTINUE + FORREFC(IGC) = SUMK + FRACREFBC(IGC) = SUMF + 6400 CONTINUE + + END SUBROUTINE CMBGB2 + +!*************************************************************************** + SUBROUTINE CMBGB3(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, FORREF, ABSN2OA, ABSN2OB, & + SELFREFC, FORREFC, & + ABSN2OAC, ABSN2OBC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) +!*************************************************************************** + +! Input + REAL abscoefL(10,5,13,MG),abscoefH(5,5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,10), FRACREFB(MG,5) + REAL FORREF(MG), ABSN2OA(MG), ABSN2OB(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG3), FORREFC(NG3), & + ABSN2OAC(NG3), ABSN2OBC(NG3) + REAL FRACREFAC(NG3,10), FRACREFBC(NG3,5) + + DO 2000 JN = 1,10 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(3) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)* RWGT(IPRSM+32) + 2600 CONTINUE + ABSA3(JN+(JTJT-1)*10+(JPJP-1)*50,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JN = 1,5 + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(3) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JN,JTJT,JPJP,IPRSM)* RWGT(IPRSM+32) + 3600 CONTINUE + ABSB3(JN+(JTJT-1)*5+(JPJP-13)*25,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(3) + SUMK = 0. + SUMF = 0. + DO 4600 IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)* RWGT(IPRSM+32) + SUMF = SUMF + FRACREFA(IPRSM,JTJT) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + FRACREFAC(IGC,JTJT) = SUMF + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JPJP = 1,5 + IPRSM = 0 + DO 5400 IGC = 1,NGC(3) + SUMF = 0. + DO 5600 IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFB(IPRSM,JPJP) + 5600 CONTINUE + FRACREFBC(IGC,JPJP) = SUMF + 5400 CONTINUE + 5000 CONTINUE + + IPRSM = 0 + DO 6400 IGC = 1,NGC(3) + SUMK1= 0. + SUMK2= 0. + SUMK3= 0. + DO 6600 IPR = 1, NGN(NGS(2)+IGC) + IPRSM = IPRSM + 1 + SUMK1= SUMK1+ FORREF(IPRSM)*RWGT(IPRSM+32) + SUMK2= SUMK2+ ABSN2OA(IPRSM)*RWGT(IPRSM+32) + SUMK3= SUMK3+ ABSN2OB(IPRSM)*RWGT(IPRSM+32) + 6600 CONTINUE + FORREFC(IGC) = SUMK1 + ABSN2OAC(IGC) = SUMK2 + ABSN2OBC(IGC) = SUMK3 + 6400 CONTINUE + + END SUBROUTINE CMBGB3 + +!*************************************************************************** + SUBROUTINE CMBGB4(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, & + SELFREFC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG),abscoefH(6,5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9), FRACREFB(MG,6) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG4) + REAL FRACREFAC(NG4,9), FRACREFBC(NG4,6) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(4) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+48) + 2600 CONTINUE + ABSA4(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JN = 1,6 + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(4) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+48) + 3600 CONTINUE + ABSB4(JN+(JTJT-1)*6+(JPJP-13)*30,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(4) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+48) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JPJP = 1,9 + IPRSM = 0 + DO 5400 IGC = 1,NGC(4) + SUMF = 0. + DO 5600 IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 5600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 5400 CONTINUE + 5000 CONTINUE + + DO 6000 JPJP = 1,6 + IPRSM = 0 + DO 6400 IGC = 1,NGC(4) + SUMF = 0. + DO 6600 IPR = 1, NGN(NGS(3)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFB(IPRSM,JPJP) + 6600 CONTINUE + FRACREFBC(IGC,JPJP) = SUMF + 6400 CONTINUE + 6000 CONTINUE + + END SUBROUTINE CMBGB4 + +!*************************************************************************** + SUBROUTINE CMBGB5(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, CCL4, & + SELFREFC, CCL4C, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG),abscoefH(5,5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9), FRACREFB(MG,5), CCL4(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG5), CCL4C(NG5) + REAL FRACREFAC(NG5,9), FRACREFBC(NG5,5) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(5) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+64) + 2600 CONTINUE + ABSA5(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JN = 1,5 + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(5) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+64) + 3600 CONTINUE + ABSB5(JN+(JTJT-1)*5+(JPJP-13)*25,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(5) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+64) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JPJP = 1,9 + IPRSM = 0 + DO 5400 IGC = 1,NGC(5) + SUMF = 0. + DO 5600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 5600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 5400 CONTINUE + 5000 CONTINUE + + DO 6000 JPJP = 1,5 + IPRSM = 0 + DO 6400 IGC = 1,NGC(5) + SUMF = 0. + DO 6600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFB(IPRSM,JPJP) + 6600 CONTINUE + FRACREFBC(IGC,JPJP) = SUMF + 6400 CONTINUE + 6000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(5) + SUMK = 0. + DO 7600 IPR = 1, NGN(NGS(4)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + CCL4(IPRSM)*RWGT(IPRSM+64) + 7600 CONTINUE + CCL4C(IGC) = SUMK + 7400 CONTINUE + + END SUBROUTINE CMBGB5 + +!*************************************************************************** + SUBROUTINE CMBGB6(abscoefL, SELFREF, & + FRACREFA, ABSCO2, CFC11ADJ, CFC12, & + SELFREFC, ABSCO2C, CFC11ADJC, CFC12C, & + FRACREFAC ) +!*************************************************************************** +! +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG), ABSCO2(MG), CFC11ADJ(MG), CFC12(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG6), & + ABSCO2C(NG6), CFC11ADJC(NG6), CFC12C(NG6) + REAL FRACREFAC(NG6) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(6) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+80) + 2600 CONTINUE + ABSA6(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(6) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+80) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(6) + SUMF = 0. + SUMK1= 0. + SUMK2= 0. + SUMK3= 0. + DO 7600 IPR = 1, NGN(NGS(5)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM) + SUMK1= SUMK1+ ABSCO2(IPRSM)*RWGT(IPRSM+80) + SUMK2= SUMK2+ CFC11ADJ(IPRSM)*RWGT(IPRSM+80) + SUMK3= SUMK3+ CFC12(IPRSM)*RWGT(IPRSM+80) + 7600 CONTINUE + FRACREFAC(IGC) = SUMF + ABSCO2C(IGC) = SUMK1 + CFC11ADJC(IGC) = SUMK2 + CFC12C(IGC) = SUMK3 + 7400 CONTINUE + + END SUBROUTINE CMBGB6 + +!*************************************************************************** + SUBROUTINE CMBGB7(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, ABSCO2, & + SELFREFC, ABSCO2C, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG),abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9), FRACREFB(MG), ABSCO2(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG7), ABSCO2C(NG7) + REAL FRACREFAC(NG7,9), FRACREFBC(NG7) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(7) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+96) + 2600 CONTINUE + ABSA7(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(7) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+96) + 3600 CONTINUE + ABSB7(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(7) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+96) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JPJP = 1,9 + IPRSM = 0 + DO 5400 IGC = 1,NGC(7) + SUMF = 0. + DO 5600 IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 5600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 5400 CONTINUE + 5000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(7) + SUMF = 0. + SUMK = 0. + DO 7600 IPR = 1, NGN(NGS(6)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFB(IPRSM) + SUMK = SUMK + ABSCO2(IPRSM)*RWGT(IPRSM+96) + 7600 CONTINUE + FRACREFBC(IGC) = SUMF + ABSCO2C(IGC) = SUMK + 7400 CONTINUE + + END SUBROUTINE CMBGB7 + +!*************************************************************************** + SUBROUTINE CMBGB8(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, ABSCO2A, ABSCO2B, & + ABSN2OA, ABSN2OB, CFC12, CFC22ADJ, & + SELFREFC, ABSCO2AC, ABSCO2BC, & + ABSN2OAC, ABSN2OBC, CFC12C, CFC22ADJC, & + FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) +!*************************************************************************** + +! Input + REAL abscoefL(5,7,MG),abscoefH(5,7:59,MG), SELFREF(10,MG) + REAL FRACREFA(MG), FRACREFB(MG), ABSCO2A(MG), ABSCO2B(MG) + REAL ABSN2OA(MG), ABSN2OB(MG), CFC12(MG), CFC22ADJ(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG8), & + ABSCO2AC(NG8), ABSCO2BC(NG8), & + ABSN2OAC(NG8), ABSN2OBC(NG8), & + CFC12C(NG8), CFC22ADJC(NG8) + REAL FRACREFAC(NG8), FRACREFBC(NG8) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,7 + IPRSM = 0 + DO 2400 IGC = 1,NGC(8) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+112) + 2600 CONTINUE + ABSA8(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 7,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(8) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+112) + 3600 CONTINUE + ABSB8(JTJT+(JPJP-7)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(8) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+112) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(8) + SUMF1= 0. + SUMF2= 0. + SUMK1= 0. + SUMK2= 0. + SUMK3= 0. + SUMK4= 0. + SUMK5= 0. + SUMK6= 0. + DO 7600 IPR = 1, NGN(NGS(7)+IGC) + IPRSM = IPRSM + 1 + SUMF1= SUMF1+ FRACREFA(IPRSM) + SUMF2= SUMF2+ FRACREFB(IPRSM) + SUMK1= SUMK1+ ABSCO2A(IPRSM)*RWGT(IPRSM+112) + SUMK2= SUMK2+ ABSCO2B(IPRSM)*RWGT(IPRSM+112) + SUMK3= SUMK3+ ABSN2OA(IPRSM)*RWGT(IPRSM+112) + SUMK4= SUMK4+ ABSN2OB(IPRSM)*RWGT(IPRSM+112) + SUMK5= SUMK5+ CFC12(IPRSM)*RWGT(IPRSM+112) + SUMK6= SUMK6+ CFC22ADJ(IPRSM)*RWGT(IPRSM+112) + 7600 CONTINUE + FRACREFAC(IGC) = SUMF1 + FRACREFBC(IGC) = SUMF2 + ABSCO2AC(IGC) = SUMK1 + ABSCO2BC(IGC) = SUMK2 + ABSN2OAC(IGC) = SUMK3 + ABSN2OBC(IGC) = SUMK4 + CFC12C(IGC) = SUMK5 + CFC22ADJC(IGC) = SUMK6 + 7400 CONTINUE + + END SUBROUTINE CMBGB8 + +!*************************************************************************** + SUBROUTINE CMBGB9(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, ABSN2O, & + SELFREFC, ABSN2OC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) +!*************************************************************************** + +! Input + REAL abscoefL(11,5,13,MG), abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9), FRACREFB(MG), ABSN2O(3*MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG9), ABSN2OC(3*NG9) + REAL FRACREFAC(NG9,9), FRACREFBC(NG9) + + DO 2000 JN = 1,11 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(9) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+128) + 2600 CONTINUE + ABSA9(JN+(JTJT-1)*11+(JPJP-1)*55,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(9) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+128) + 3600 CONTINUE + ABSB9(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(9) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+128) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 5000 JN = 1,3 + IPRSM = 0 + DO 5400 IGC = 1,NGC(9) + SUMK = 0. + DO 5600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + JND = (JN-1)*16 + SUMK = SUMK + ABSN2O(JND+IPRSM)*RWGT(IPRSM+128) + 5600 CONTINUE + JNDC = (JN-1)*NGC(9) + ABSN2OC(JNDC+IGC) = SUMK + 5400 CONTINUE + 5000 CONTINUE + + DO 6000 JPJP = 1,9 + IPRSM = 0 + DO 6400 IGC = 1,NGC(9) + SUMF = 0. + DO 6600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 6600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 6400 CONTINUE + 6000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(9) + SUMF = 0. + DO 7600 IPR = 1, NGN(NGS(8)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFB(IPRSM) + 7600 CONTINUE + FRACREFBC(IGC) = SUMF + 7400 CONTINUE + + END SUBROUTINE CMBGB9 + +!*************************************************************************** + SUBROUTINE CMBGB10(abscoefL, abscoefH, & + FRACREFA, FRACREFB, & + FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG),abscoefH(5,13:59,MG) + REAL FRACREFA(MG), FRACREFB(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL FRACREFAC(NG10), FRACREFBC(NG10) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(10) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+144) + 2600 CONTINUE + ABSA10(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(10) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+144) + 3600 CONTINUE + ABSB10(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(10) + SUMF1= 0. + SUMF2= 0. + DO 7600 IPR = 1, NGN(NGS(9)+IGC) + IPRSM = IPRSM + 1 + SUMF1= SUMF1+ FRACREFA(IPRSM) + SUMF2= SUMF2+ FRACREFB(IPRSM) + 7600 CONTINUE + FRACREFAC(IGC) = SUMF1 + FRACREFBC(IGC) = SUMF2 + 7400 CONTINUE + + END SUBROUTINE CMBGB10 + +!*************************************************************************** + SUBROUTINE CMBGB11(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, & + SELFREFC, & + FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG),abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG), FRACREFB(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG11) + REAL FRACREFAC(NG11), FRACREFBC(NG11) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(11) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+160) + 2600 CONTINUE + ABSA11(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(11) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+160) + 3600 CONTINUE + ABSB11(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(11) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+160) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(11) + SUMF1= 0. + SUMF2= 0. + DO 7600 IPR = 1, NGN(NGS(10)+IGC) + IPRSM = IPRSM + 1 + SUMF1= SUMF1+ FRACREFA(IPRSM) + SUMF2= SUMF2+ FRACREFB(IPRSM) + 7600 CONTINUE + FRACREFAC(IGC) = SUMF1 + FRACREFBC(IGC) = SUMF2 + 7400 CONTINUE + + END SUBROUTINE CMBGB11 + + +!*************************************************************************** + SUBROUTINE CMBGB12(abscoefL, SELFREF, & + FRACREFA, & + SELFREFC, FRACREFAC ) +!*************************************************************************** +! +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG12) + REAL FRACREFAC(NG12,9) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(12) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+176) + 2600 CONTINUE + ABSA12(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(12) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+176) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 7000 JPJP = 1,9 + IPRSM = 0 + DO 7400 IGC = 1,NGC(12) + SUMF = 0. + DO 7600 IPR = 1, NGN(NGS(11)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 7600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 7400 CONTINUE + 7000 CONTINUE + + END SUBROUTINE CMBGB12 + +!*************************************************************************** + SUBROUTINE CMBGB13(abscoefL, SELFREF, FRACREFA, & + SELFREFC, FRACREFAC ) +!*************************************************************************** +! +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG13) + REAL FRACREFAC(NG13,9) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(13) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+192) + 2600 CONTINUE + ABSA13(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(13) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+192) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 7000 JPJP = 1,9 + IPRSM = 0 + DO 7400 IGC = 1,NGC(13) + SUMF = 0. + DO 7600 IPR = 1, NGN(NGS(12)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 7600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 7400 CONTINUE + 7000 CONTINUE + + END SUBROUTINE CMBGB13 + +!*************************************************************************** + SUBROUTINE CMBGB14(abscoefL, abscoefH, SELFREF, & + FRACREFA, FRACREFB, & + SELFREFC, FRACREFAC, FRACREFBC ) +!*************************************************************************** +! +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) +!*************************************************************************** + +! Input + REAL abscoefL(5,13,MG),abscoefH(5,13:59,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG), FRACREFB(MG) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG14) + REAL FRACREFAC(NG14), FRACREFBC(NG14) + + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(14) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JTJT,JPJP,IPRSM)*RWGT(IPRSM+208) + 2600 CONTINUE + ABSA14(JTJT+(JPJP-1)*5,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 3000 JTJT = 1,5 + DO 3200 JPJP = 13,59 + IPRSM = 0 + DO 3400 IGC = 1,NGC(14) + SUMK = 0. + DO 3600 IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefH(JTJT,JPJP,IPRSM)*RWGT(IPRSM+208) + 3600 CONTINUE + ABSB14(JTJT+(JPJP-13)*5,IGC) = SUMK + 3400 CONTINUE + 3200 CONTINUE + 3000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(14) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+208) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + IPRSM = 0 + DO 7400 IGC = 1,NGC(14) + SUMF1= 0. + SUMF2= 0. + DO 7600 IPR = 1, NGN(NGS(13)+IGC) + IPRSM = IPRSM + 1 + SUMF1= SUMF1+ FRACREFA(IPRSM) + SUMF2= SUMF2+ FRACREFB(IPRSM) + 7600 CONTINUE + FRACREFAC(IGC) = SUMF1 + FRACREFBC(IGC) = SUMF2 + 7400 CONTINUE + + + END SUBROUTINE CMBGB14 + +!*************************************************************************** + SUBROUTINE CMBGB15(abscoefL, SELFREF, FRACREFA, & + SELFREFC, FRACREFAC ) +!*************************************************************************** +! +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG15) + REAL FRACREFAC(NG15,9) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(15) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+224) + 2600 CONTINUE + ABSA15(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(15) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+224) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 7000 JPJP = 1,9 + IPRSM = 0 + DO 7400 IGC = 1,NGC(15) + SUMF = 0. + DO 7600 IPR = 1, NGN(NGS(14)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 7600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 7400 CONTINUE + 7000 CONTINUE + + END SUBROUTINE CMBGB15 + +!*************************************************************************** + SUBROUTINE CMBGB16(abscoefL, SELFREF, FRACREFA, & + SELFREFC, FRACREFAC ) +!*************************************************************************** +! +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) +!*************************************************************************** + +! Input + REAL abscoefL(9,5,13,MG) + REAL SELFREF(10,MG) + REAL FRACREFA(MG,9) +! REAL RWGT(MG*NBANDS) +! Output + REAL SELFREFC(10,NG16) + REAL FRACREFAC(NG16,9) + + DO 2000 JN = 1,9 + DO 2000 JTJT = 1,5 + DO 2200 JPJP = 1,13 + IPRSM = 0 + DO 2400 IGC = 1,NGC(16) + SUMK = 0. + DO 2600 IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + abscoefL(JN,JTJT,JPJP,IPRSM)*RWGT(IPRSM+240) + 2600 CONTINUE + ABSA16(JN+(JTJT-1)*9+(JPJP-1)*45,IGC) = SUMK + 2400 CONTINUE + 2200 CONTINUE + 2000 CONTINUE + + DO 4000 JTJT = 1,10 + IPRSM = 0 + DO 4400 IGC = 1,NGC(16) + SUMK = 0. + DO 4600 IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + SUMK = SUMK + SELFREF(JTJT,IPRSM)*RWGT(IPRSM+240) + 4600 CONTINUE + SELFREFC(JTJT,IGC) = SUMK + 4400 CONTINUE + 4000 CONTINUE + + DO 7000 JPJP = 1,9 + IPRSM = 0 + DO 7400 IGC = 1,NGC(16) + SUMF = 0. + DO 7600 IPR = 1, NGN(NGS(15)+IGC) + IPRSM = IPRSM + 1 + SUMF = SUMF + FRACREFA(IPRSM,JPJP) + 7600 CONTINUE + FRACREFAC(IGC,JPJP) = SUMF + 7400 CONTINUE + 7000 CONTINUE + + END SUBROUTINE CMBGB16 + +!------------------------------------------------------------------------- + SUBROUTINE INIRAD (O3PROF,Pw, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: kts,kte + + REAL, DIMENSION( kts:kte ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+1 ),INTENT(IN ) :: Pw + +! LOCAL VAR + + REAL, DIMENSION( kts:kte+1 ) :: PAVEL, TAVEL + REAL, DIMENSION( 0:kte+1 ) :: PZ, TZ + + INTEGER :: k + + +! +! COMPUTE OZONE MIXING RATIO DISTRIBUTION +! + DO K=kts,kte + O3PROF(K)=0. + ENDDO + + CALL O3DATA(O3PROF, Pw, kts, kte) +! + END SUBROUTINE INIRAD + +!------------------------------------------------------------------------- + SUBROUTINE O3DATA (O3PROF, Pw, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- +! + INTEGER, INTENT(IN ) :: kts, kte +! + REAL, DIMENSION( kts:kte ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+1 ),INTENT(IN ) :: Pw + +! LOCAL VAR + INTEGER :: K, JJ, NK + + REAL :: PRLEVH(kts:kte+1),PPWRKH(32), & + O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), & + O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31) + + REAL :: PB1, PB2, PT1, PT2 + + DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, & + 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, & + 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, & + 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, & + 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, & + 9.856E-6,5.960E-6,5.960E-6/ + + DATA PPSUM /955.890,850.532,754.599,667.742,589.841, & + 519.421,455.480,398.085,347.171,301.735,261.310,225.360, & + 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, & + 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, & + 9.277, 4.660, 2.421, 1.294, 0.647/ +! + DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, & + 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, & + 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, & + 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, & + 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, & + 9.389E-6,6.135E-6,6.135E-6/ + + DATA PPWIN /955.747,841.783,740.199,649.538,568.404, & + 495.815,431.069,373.464,322.354,277.190,237.635,203.433, & + 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, & + 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, & + 7.583, 3.620, 1.807, 0.938, 0.469/ +! + + DO K=1,31 + PPANN(K)=PPSUM(K) + ENDDO +! + O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1)) +! + DO K=2,31 + O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* & + (PPSUM(K)-PPWIN(K-1)) + ENDDO +! + DO K=2,31 + O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K)) + ENDDO +! + DO K=1,31 + O3WRK(K)=O3ANN(K) + PPWRK(K)=PPANN(K) + ENDDO +! +! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS +! + +! Pw is total P at w level +! Pw is in mb + + DO K=kts,kte+1 + NK=kte+1-K+1 + PRLEVH(K)=Pw(NK) + ENDDO +! + PPWRKH(1)=1100. + DO K=2,31 + PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2. + ENDDO + PPWRKH(32)=0. + DO K=kts,kte + DO 25 JJ=1,31 + IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN + PB1=0. + ELSE + PB1=PRLEVH(K)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN + PB2=0. + ELSE + PB2=PRLEVH(K)-PPWRKH(JJ+1) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN + PT1=0. + ELSE + PT1=PRLEVH(K+1)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN + PT2=0. + ELSE + PT2=PRLEVH(K+1)-PPWRKH(JJ+1) + ENDIF + O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ) + 25 CONTINUE + O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1)) + + ENDDO +! + END SUBROUTINE O3DATA + +!--------------------------------------------------------------------------- + SUBROUTINE MM5ATM(CLDFRA,O3PROF,T,Tw,TSFC,QV,QC,QR,QI,QS,QG, & + P,Pw,DELZ,EMISS,R,G, & + PAVEL,TAVEL,PZ,TZ,CLDFRAC,TAUCLOUD,COLDRY, & + WKL,WX,TBOUND,SEMISS, & + kts,kte ) +!--------------------------------------------------------------------------- +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Revision for NCAR MM5: J. Dudhia (converted from CCM code) +! +! Input atmospheric profile from NCAR MM5, and prepare it for use in RRTM. +! Set other RRTM input parameters. Values are passed back through existing +! RRTM arrays and commons. +!--------------------------------------------------------------------------- +! RRTM Definitions +! MXLAY = kte+1 ! Maximum number of model layers +! MAXXSEC ! Maximum number of cross sections +! NLAYERS ! Number of model layers (kte+1) +! PAVEL(MXLAY) ! Layer pressures (mb) +! PZ(0:MXLAY) ! Level (interface) pressures (mb) +! TAVEL(MXLAY) ! Layer temperatures (K) +! TZ(0:MXLAY) ! Level (interface) temperatures(mb) +! TBOUND ! Surface temperature (K) +! COLDRY(MXLAY) ! Dry air column (molecules/cm2) +! WKL(35,MXLAY) ! Molecular amounts (molecules/cm2) +! WBRODL(MXLAY) ! Inactive in this version +! WX(MAXXSEC) ! Cross-section amounts (molecules/cm2) +! CLDFRAC(MXLAY) ! Layer cloud fraction +! TAUCLOUD(MXLAY) ! Layer cloud optical depth +! AMD ! Atomic weight of dry air +! AMW ! Atomic weight of water +! AMO ! Atomic weight of ozone +! AMCH4 ! Atomic weight of methane +! AMN2O ! Atomic weight of nitrous oxide +! AMC11 ! Atomic weight of CFC-11 +! AMC12 ! Atomic weight of CFC-12 +! NXMOL ! Number of cross-section molecules +! IXINDX ! Cross-section molecule index (see below) +! IXSECT ! On/off flag for cross-sections (inactive) +! IXMAX ! Maximum number of cross-sections (inactive) +! +!----------------------------------------------------------------------------- +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. +!---------------------------------------------------------------------------- +! Activate cross section molecules: +! NXMOL - number of cross-sections input by user +! IXINDX(I) - index of cross-section molecule corresponding to Ith +! cross-section specified by user +! = 0 -- not allowed in RRTM +! = 1 -- CCL4 +! = 2 -- CFC11 +! = 3 -- CFC12 +! = 4 -- CFC22 +! DATA NXMOL /2/ +! DATA IXINDX /0,2,3,0,31*0/ +! +! CLOUD EMISSIVITIES (M^2/G) +! THESE ARE CONSISTENT WITH LWRAD (ABCW=0.5*(ABUP+ABDOWN)) +!---------------------------------------------------------------------------- + + + INTEGER, INTENT(IN ) :: kts, kte +! + REAL, DIMENSION( 35,kts:kte+1 ), & + INTENT(INOUT) :: WKL + + REAL, DIMENSION( MAXXSEC,kts:kte+1 ), & + INTENT(INOUT) :: WX + + REAL, INTENT(INOUT) :: TBOUND + REAL, DIMENSION(NBANDS), INTENT(INOUT) :: SEMISS + + REAL, DIMENSION( kts:kte+1 ), INTENT(IN ) :: & + Tw, & + Pw + REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & + CLDFRA, & + O3PROF, & + DELZ, & + T, & + P + + REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & + QV + + REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & + QC, & + QR, & + QI, & + QS, & + QG + + REAL, DIMENSION( kts:kte+1 ), INTENT(INOUT) :: & + PAVEL, & + TAVEL, & + CLDFRAC, & + TAUCLOUD, & + COLDRY + + REAL, DIMENSION( 0:kte+1 ), INTENT(INOUT) :: & + PZ, & + TZ + + REAL, INTENT(IN ) :: R,G,EMISS,TSFC + + REAL :: GRAVIT + +! +! LOCAL + + REAL, DIMENSION( kts:kte ) :: CLDFRC, & + PINT, & + TINT, & + O3, & + N2O, & + CH4, & + CLWP, & + CIWP, & + PLWP, & + PIWP + + real :: amd ! Effective molecular weight of dry air (g/mol) + real :: amw ! Molecular weight of water vapor (g/mol) + real :: amo ! Molecular weight of ozone (g/mol) + real :: amch4 ! Molecular weight of methane (g/mol) + real :: amn2o ! Molecular weight of nitrous oxide (g/mol) + real :: amc11 ! Molecular weight of CFC11 (g/mol) - CFCL3 + real :: amc12 ! Molecular weight of CFC12 (g/mol) - CF2CL2 + real :: avgdro ! Avogadro's number (molecules/mole) + +! Atomic weights for conversion from mass to volume mixing ratios + + data amd / 28.9644 / + data amw / 18.0154 / + data amo / 47.9998 / + data amch4 / 16.0430 / + data amn2o / 44.0128 / + data amc11 / 137.3684 / + data amc12 / 120.9138 / + data avgdro/ 6.022E23 / + +! Set molecular weight ratios + + real :: amdw, & ! Molecular weight of dry air / water vapor + amdc, & ! Molecular weight of dry air / methane + amdn, & ! Molecular weight of dry air / nitrous oxide + amdc1, & ! Molecular weight of dry air / CFC11 + amdc2 ! Molecular weight of dry air / CFC12 + + data amdw / 1.607758 / + data amdc / 1.805423 / + data amdn / 0.658090 / + data amdc1/ 0.210852 / + data amdc2/ 0.239546 / + +! Put in CO2 volume mixing ratio here (330 ppmv) + + real :: co2vmr + data co2vmr / 330.e-6 / + + REAL :: ABCW,ABICE,ABRN,ABSN + + DATA ABCW /0.144/ + DATA ABICE /0.0735/ + DATA ABRN /0.330E-3/ + DATA ABSN /2.34E-3/ + + GRAVIT = G*100. + +! +! MID-LAYER VALUES + DO K=kts,kte + RO=P(K)/(R*T(K))*100. + DZ=DELZ(K) + QV(K)=AMAX1(QV(K),1.E-12) + + CLDFRC(K)=CLDFRA(K) + +! PATHS IN G/M^2 + +! QI=0 if no ice phase +! QS=0 if no ice phase + + CLWP(K)=RO*QC(K)*DZ*1000. + CIWP(K)=RO*QI(K)*DZ*1000. + PLWP(K)=(RO*QR(K))**0.75*DZ*1000. + PIWP(K)=(RO*QS(K))**0.75*DZ*1000. + + O3(K)=O3PROF(K) + N2O(K)=0. + CH4(K)=0. + + ENDDO + +! Initialize all molecular amounts to zero here, then pass MM5 amounts +! into RRTM arrays WKL and WX below. + + DO 1000 ILAY = kts,kte+1 + DO 1100 ISP = 1,35 + 1100 WKL(ISP,ILAY) = 0.0 + DO 1200 ISP = 1,MAXXSEC + 1200 WX(ISP,ILAY) = 0.0 + 1000 CONTINUE + +! Set parameters needed for RRTM execution: + + IXSECT = 1 + IXMAX = 4 + +! Set surface temperature. The longwave upward surface flux is +! computed in the Land Surface Model based on the surface +! temperature and the emissivity of the surface type for each +! grid point. The bottom interface temperature, tint(kte+1), is +! ground temperature consistent with this LW upward flux, and +! TBOUND is set to this temperature here. + +! TBOUND = TINT(kte+1) + TBOUND = Tw(kte+1) +! TBOUND = TSFC + +! Install MM5 profiles into RRTM arrays for pressure, temperature, +! and molecular amounts. Pressures are converted from cb +! (CCM) to mb (RRTM). H2O and trace gas amounts are converted from +! mass mixing ratio to volume mixing ratio. CO2 vmr is constant at all +! levels. The dry air column COLDRY (in molec/cm2) is calculated +! from the level pressures PZ (in mb) based on the hydrostatic equation +! and includes a correction to account for H2O in the layer. The +! molecular weight of moist air (amm) is calculated for each layer. + +! RRTM is executed for an additional layer (L=kte+1), which extends +! from the model top (ptop) to 0 mb, to calculate the downward +! flux at the model top interface. H2O, CO2, and O3 vmrs for this +! extra layer are set to the values in the model's top layer, though +! the O3 value is reduced by a fraction (0.6) based on the US Std Atm. +! For GCMs with a model top near 0 mb, this extra layer is not needed, and +! NLAYERS should be set to the number of model layers (kte in this case). +! Note: RRTM levels count from bottom to top, while MM5 levels count +! from the top down and must be reversed here. + +! NMOL = 6 +! PZ(0) = pint(kte+1) +! TZ(0) = tint(kte+1) + + PZ(0) = Pw(kte+1) + TZ(0) = Tw(kte+1) + DO 2000 L = 1, NLAYERS-1 + PAVEL(L) = p(kte+1-L) + TAVEL(L) = t(kte+1-L) +! PZ(L) = pint(kte+1-L) +! TZ(L) = tint(kte+1-L) + PZ(L) = Pw(kte+1-L) + TZ(L) = Tw(kte+1-L) + WKL(1,L) = qv(kte+1-L)*amdw + WKL(2,L) = co2vmr + WKL(3,L) = o3(kte+1-L) + WKL(4,L) = n2o(kte+1-L)*amdn + WKL(6,L) = ch4(kte+1-L)*amdc + amm = (1-WKL(1,L))*amd + WKL(1,L)*amw + COLDRY(L) = (PZ(L-1)-PZ(L))*1.E3*avgdro/ & + (gravit*amm*(1+WKL(1,L))) + 2000 CONTINUE + +! Set cross section molecule amounts from CCM; convert to vmr + DO 2100 L=1, NLAYERS-1 +! WX(2,L) = c11mmr(kte+1-L)*amdc1 +! WX(3,L) = c12mmr(kte+1-L)*amdc2 + WX(2,L) = 0. + WX(3,L) = 0. + 2100 CONTINUE + +! ***** +! Set up values for extra layer at top of the atmosphere. +! The top layer temperature for all gridpoints is set to the top layer-1 +! temperature plus a constant (0 K) that represents an isothermal layer +! above ptop. Top layer interface temperatures are +! linearly interpolated from the layer temperatures. +! Note: The top layer temperature and ozone amount are based on a 0-3mb +! top layer and must be modified if the layering is changed. +! This section should be commented if the extra layer is not needed. + + PAVEL(NLAYERS) = 0.5*PZ(NLAYERS-1) + TAVEL(NLAYERS) = TAVEL(NLAYERS-1) + 0.0 + PZ(NLAYERS) = 0.00 + TZ(NLAYERS-1) = 0.5*(TAVEL(NLAYERS)+TAVEL(NLAYERS-1)) + TZ(NLAYERS) = TZ(NLAYERS-1)+0.0 + WKL(1,NLAYERS) = WKL(1,NLAYERS-1) + WKL(2,NLAYERS) = co2vmr + WKL(3,NLAYERS) = 0.6*WKL(3,NLAYERS-1) + WKL(4,NLAYERS) = WKL(4,NLAYERS-1) + WKL(6,NLAYERS) = WKL(6,NLAYERS-1) + amm = (1-WKL(1,NLAYERS-1))*amd + WKL(1,NLAYERS-1)*amw +! COLDRY(NLAYERS) = (PZ(NLAYERS-1))*1.E3*avgdro/ & + COLDRY(NLAYERS) = ((PZ(NLAYERS-1)-PZ(NLAYERS)))*1.E3*avgdro/ & + (gravit*amm*(1+WKL(1,NLAYERS-1))) + WX(2,NLAYERS) = WX(2,NLAYERS-1) + WX(3,NLAYERS) = WX(3,NLAYERS-1) +! ***** + +! Here, all molecules in WKL and WX are in volume mixing ratio; convert to +! molec/cm2 based on COLDRY for use in RRTM + + DO 5000 L = 1, NLAYERS + DO 4200 IMOL = 1, NMOL + WKL(IMOL,L) = COLDRY(L) * WKL(IMOL,L) + 4200 CONTINUE + DO 4400 IX = 1,MAXXSEC + IF (IXINDX(IX) .NE. 0) THEN + WX(IXINDX(IX),L) = COLDRY(L) * WX(IX,L) * 1.E-20 + ENDIF + 4400 CONTINUE + 5000 CONTINUE + +! Set spectral surface emissivity for each longwave band. The default value +! is set here to emiss(i,j) based on land-use (taken to be constant across band +! Comment: if land-surface uses skin temperature, emissivity must match that +! used in its calculation (e.g. 1.0) + DO 5500 N=1,NBANDS + SEMISS(N) = EMISS + 5500 CONTINUE + +! Transfer cloud fraction to RRTM array; compute cloud optical depth, TAUCLOUD, +! as the product of clwp and cloud mass absorption coefficient in MM5, which is +! a combination of liquid and ice absorption coefficients. +! Note: RRTM levels count from bottom to top, while CCM levels count from the +! top down and must be reversed here. Values for the extra RRTM level (above +! the model top) are set to zero. + + DO 7000 L = 1, NLAYERS-1 + TAUCLOUD(L) = ABCW*CLWP(kte+1-L)+ABICE*CIWP(kte+1-L) & + +ABRN*PLWP(kte+1-L)+ABSN*PIWP(kte+1-L) + IF(TAUCLOUD(L).GT.0.01)CLDFRC(kte+1-L)=1. + CLDFRAC(L) = cldfrc(kte+1-L) + 7000 CONTINUE + CLDFRAC(NLAYERS) = 0.0 + TAUCLOUD(NLAYERS) = 0.0 + + END SUBROUTINE MM5ATM + +!--------------------------------------------------------------------------- + SUBROUTINE SETCOEF(kts,ktep1, & + PAVEL,TAVEL,COLDRY,COLH2O,COLCO2,COLO3, & + COLN2O,COLCH4,COLO2,CO2MULT, & + FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC, & + JP,JT,JT1,INDSELF,WKL,LAYTROP,LAYSWTCH,LAYLOW ) +!--------------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------------- +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! For a given atmosphere, calculate the indices and fractions related to the +! pressure and temperature interpolations. Also calculate the values of the +! integrated Planck functions for each band at the level and layer +! temperatures. +!--------------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: kts, ktep1 + + REAL, DIMENSION( 35,kts:ktep1), & + INTENT(IN ) :: WKL + + INTEGER, INTENT(INOUT) :: LAYTROP,LAYSWTCH,LAYLOW + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + PAVEL, & + TAVEL, & + COLDRY + + REAL, DIMENSION( kts:ktep1 ), INTENT(INOUT) :: & + COLH2O, & + COLCO2, & + COLO3, & + COLN2O, & + COLCH4, & + COLO2, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(INOUT) :: & + JP, & + JT, & + JT1, & + INDSELF +! LOCAL + + INTEGER :: LAY, JP1 + REAL :: STPFAC, PLOG, FP, FT, FT1, WATERS, WATER, & + CALEFAC, FACTOR, CO2REG, COMPFP, SCALEFAC + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STPFAC = 296./1013. + + LAYTROP = 0 + LAYSWTCH = 0 + LAYLOW = 0 + DO 7000 LAY = 1, NLAYERS +! Find the two reference pressures on either side of the +! layer pressure. Store them in JP and JP1. Store in FP the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + PLOG = LOG(PAVEL(LAY)) + JP(LAY) = INT(36. - 5*(PLOG+0.04)) + IF (JP(LAY) .LT. 1) THEN + JP(LAY) = 1 + ELSEIF (JP(LAY) .GT. 58) THEN + JP(LAY) = 58 + ENDIF + JP1 = JP(LAY) + 1 + FP = 5. * (PREFLOG(JP(LAY)) - PLOG) + +! Determine, for each reference pressure (JP and JP1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. Store these indices in JT and JT1, resp. +! Store in FT (resp. FT1) the fraction of the way between JT +! (JT1) and the next highest reference temperature that the +! layer temperature falls. + JT(LAY) = INT(3. + (TAVEL(LAY)-TREF(JP(LAY)))/15.) + IF (JT(LAY) .LT. 1) THEN + JT(LAY) = 1 + ELSEIF (JT(LAY) .GT. 4) THEN + JT(LAY) = 4 + ENDIF + FT = ((TAVEL(LAY)-TREF(JP(LAY)))/15.) - FLOAT(JT(LAY)-3) + JT1(LAY) = INT(3. + (TAVEL(LAY)-TREF(JP1))/15.) + IF (JT1(LAY) .LT. 1) THEN + JT1(LAY) = 1 + ELSEIF (JT1(LAY) .GT. 4) THEN + JT1(LAY) = 4 + ENDIF + FT1 = ((TAVEL(LAY)-TREF(JP1))/15.) - FLOAT(JT1(LAY)-3) + + WATER = WKL(1,LAY)/COLDRY(LAY) + SCALEFAC = PAVEL(LAY) * STPFAC / TAVEL(LAY) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. + IF (PLOG .LE. 4.56) GO TO 5300 + LAYTROP = LAYTROP + 1 +! For one band, the "switch" occurs at ~300 mb. +! JD: changed from (PLOG .GE. 5.76) to avoid out-of-range + IF (PLOG .Gt. 5.76) LAYSWTCH = LAYSWTCH + 1 + IF (PLOG .GE. 6.62) LAYLOW = LAYLOW + 1 +! + FORFAC(LAY) = SCALEFAC / (1.+WATER) +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + SELFFAC(LAY) = WATER * FORFAC(LAY) + FACTOR = (TAVEL(LAY)-188.0)/7.2 + INDSELF(LAY) = MIN(9, MAX(1, INT(FACTOR)-7)) + SELFFRAC(LAY) = FACTOR - FLOAT(INDSELF(LAY) + 7) + +! Calculate needed column amounts. + COLH2O(LAY) = 1.E-20 * WKL(1,LAY) + COLCO2(LAY) = 1.E-20 * WKL(2,LAY) + COLO3(LAY) = 1.E-20 * WKL(3,LAY) + COLN2O(LAY) = 1.E-20 * WKL(4,LAY) + COLCH4(LAY) = 1.E-20 * WKL(6,LAY) + COLO2(LAY) = 1.E-20 * WKL(7,LAY) + IF (COLCO2(LAY) .EQ. 0.) COLCO2(LAY) = 1.E-32 * COLDRY(LAY) + IF (COLN2O(LAY) .EQ. 0.) COLN2O(LAY) = 1.E-32 * COLDRY(LAY) + IF (COLCH4(LAY) .EQ. 0.) COLCH4(LAY) = 1.E-32 * COLDRY(LAY) +! Using E = 1334.2 cm-1. + CO2REG = 3.55E-24 * COLDRY(LAY) + CO2MULT(LAY)= (COLCO2(LAY) - CO2REG) * & + 272.63*EXP(-1919.4/TAVEL(LAY))/(8.7604E-4*TAVEL(LAY)) + GO TO 5400 + +! Above LAYTROP. + 5300 CONTINUE + + FORFAC(LAY) = SCALEFAC / (1.+WATER) +! Calculate needed column amounts. + COLH2O(LAY) = 1.E-20 * WKL(1,LAY) + COLCO2(LAY) = 1.E-20 * WKL(2,LAY) + COLO3(LAY) = 1.E-20 * WKL(3,LAY) + COLN2O(LAY) = 1.E-20 * WKL(4,LAY) + COLCH4(LAY) = 1.E-20 * WKL(6,LAY) + COLO2(LAY) = 1.E-20 * WKL(7,LAY) + IF (COLCO2(LAY) .EQ. 0.) COLCO2(LAY) = 1.E-32 * COLDRY(LAY) + IF (COLN2O(LAY) .EQ. 0.) COLN2O(LAY) = 1.E-32 * COLDRY(LAY) + IF (COLCH4(LAY) .EQ. 0.) COLCH4(LAY) = 1.E-32 * COLDRY(LAY) + CO2REG = 3.55E-24 * COLDRY(LAY) + CO2MULT(LAY)= (COLCO2(LAY) - CO2REG) * & + 272.63*EXP(-1919.4/TAVEL(LAY))/(8.7604E-4*TAVEL(LAY)) + 5400 CONTINUE + +! We have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). We multiply the pressure +! fraction FP with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines TAUGBn for band n). + + COMPFP = 1. - FP + FAC10(LAY) = COMPFP * FT + FAC00(LAY) = COMPFP * (1. - FT) + FAC11(LAY) = FP * FT1 + FAC01(LAY) = FP * (1. - FT1) + + 7000 CONTINUE + +! Set LAYLOW for profiles with surface pressure less than 750mb. + IF (LAYLOW.EQ.0) LAYLOW=1 +! Sometimes round-off gives wrong LAYSWTCH therefore check here (JD) + IF (JP(LAYSWTCH+1).LE.6) THEN + LAYSWTCH=LAYSWTCH+1 + ENDIF + + END SUBROUTINE SETCOEF + +!------------------------------------------------------------------------------- +!* * +!* Optical depths developed for the * +!* * +!* RAPID RADIATIVE TRANSFER MODEL (RRTM) * +!* * +!* * +!* ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +!* 840 MEMORIAL DRIVE * +!* CAMBRIDGE, MA 02139 * +!* * +!* * +!* ELI J. MLAWER * +!* STEVEN J. TAUBMAN * +!* SHEPARD A. CLOUGH * +!* * +!* * +!* * +!* * +!* email: mlawer@aer.com * +!* * +!* The authors wish to acknowledge the contributions of the * +!* following people: Patrick D. Brown, Michael J. Iacono, * +!* Ronald E. Farren, Luke Chen, Robert Bergstrom. * +!* * +!------------------------------------------------------------------------------- +!* * +!* Revision for NCAR CCM: Michael J. Iacono; September, 1998 * +!* * +!* TAUMOL * +!* * +!* This file contains the subroutines TAUGBn (where n goes from * +!* 1 to 16). TAUGBn calculates the optical depths and Planck fractions * +!* per g-value and layer for band n. * +!* * +!* Output: optical depths (unitless) * +!* fractions needed to compute Planck functions at every layer * +!* and g-value * +!* * +!* COMMON /TAUGCOM/ TAUG(MXLAY,MG) * +!* COMMON /PLANKG/ FRACS(MXLAY,MG) * +!* * +!* Input * +!* * +!* COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * +!* COMMON /PRECISE/ ONEMINUS * +!* COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * +!* & PZ(0:MXLAY),TZ(0:MXLAY) * +!* COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * +!* & COLH2O(MXLAY),COLCO2(MXLAY), * +!* & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * +!* & COLO2(MXLAY),CO2MULT(MXLAY) * +!* COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * +!* & FAC10(MXLAY),FAC11(MXLAY) * +!* COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * +!* COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * +!* * +!* Description: * +!* NG(IBAND) - number of g-values in band IBAND * +!* NSPA(IBAND) - for the lower atmosphere, the number of reference * +!* atmospheres that are stored for band IBAND per * +!* pressure level and temperature. Each of these * +!* atmospheres has different relative amounts of the * +!* key species for the band (i.e. different binary * +!* species parameters). * +!* NSPB(IBAND) - same for upper atmosphere * +!* ONEMINUS - since problems are caused in some cases by interpolation * +!* parameters equal to or greater than 1, for these cases * +!* these parameters are set to this value, slightly < 1. * +!* PAVEL - layer pressures (mb) * +!* TAVEL - layer temperatures (degrees K) * +!* PZ - level pressures (mb) * +!* TZ - level temperatures (degrees K) * +!* LAYTROP - layer at which switch is made from one combination of * +!* key species to another * +!* COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * +!* vapor,carbon dioxide, ozone, nitrous ozide, methane, * +!* respectively (molecules/cm**2) * +!* CO2MULT - for bands in which carbon dioxide is implemented as a * +!* trace species, this is the factor used to multiply the * +!* band's average CO2 absorption coefficient to get the added * +!* contribution to the optical depth relative to 355 ppm. * +!* FACij(LAY) - for layer LAY, these are factors that are needed to * +!* compute the interpolation factors that multiply the * +!* appropriate reference k-values. A value of 0 (1) for * +!* i,j indicates that the corresponding factor multiplies * +!* reference k-value for the lower (higher) of the two * +!* appropriate temperatures, and altitudes, respectively. * +!* JP - the index of the lower (in altitude) of the two appropriate * +!* reference pressure levels needed for interpolation * +!* JT, JT1 - the indices of the lower of the two appropriate reference * +!* temperatures needed for interpolation (for pressure * +!* levels JP and JP+1, respectively) * +!* SELFFAC - scale factor needed to water vapor self-continuum, equals * +!* (water vapor density)/(atmospheric density at 296K and * +!* 1013 mb) * +!* SELFFRAC - factor needed for temperature interpolation of reference * +!* water vapor self-continuum data * +!* INDSELF - index of the lower of the two appropriate reference * +!* temperatures needed for the self-continuum interpolation * +!* * +!* Data input * +!* COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * +!* (note: n is the band number) * +!* * +!* Description: * +!* KA - k-values for low reference atmospheres (no water vapor * +!* self-continuum) (units: cm**2/molecule) * +!* KB - k-values for high reference atmospheres (all sources) * +!* (units: cm**2/molecule) * +!* SELFREF - k-values for water vapor self-continuum for reference * +!* atmospheres (used below LAYTROP) * +!* (units: cm**2/molecule) * +!* * +!* DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * +!* EQUIVALENCE (KA,ABSA),(KB,ABSB) * +!* * +!******************************************************************************* + +!--------------------------------------------------------------------------- + SUBROUTINE TAUGB1(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!--------------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. +! Revised by Michael J. Iacono, Atmospheric & Environmental Research. + +! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below LAYTROP, the water vapor self-continuum +! is interpolated (in temperature) separately. +!cdir novector + DO 2500 LAY = 1, LAYTROP + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(1) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(1) + 1 + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG1 + TAUG(IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSA1(IND0,IG) + & + FAC10(LAY) * ABSA1(IND0+1,IG) + & + FAC01(LAY) * ABSA1(IND1,IG) + & + FAC11(LAY) * ABSA1(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC1(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC1(INDS+1,IG) - SELFREFC1(INDS,IG))) + & + FORFAC(LAY) * FORREFC1(IG)) + PFRAC(IG,LAY) = FRACREFAC1(IG) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(1) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(1) + 1 + DO 3000 IG = 1, NG1 + TAUG(IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSB1(IND0,IG) + & + FAC10(LAY) * ABSB1(IND0+1,IG) + & + FAC01(LAY) * ABSB1(IND1,IG) + & + FAC11(LAY) * ABSB1(IND1+1,IG) + & + FORFAC(LAY) * FORREFC1(IG)) + PFRAC(IG,LAY) = FRACREFBC1(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB1 + +!---------------------------------------------------------------------------- + SUBROUTINE TAUGB2(kts,ktep1,COLDRY,COLH2O,FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!---------------------------------------------------------------------------- + +! BAND 2: 250-500 cm-1 (low - H2O; high - H2O) + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, PARAMETER :: NGS1=8 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLDRY, & + COLH2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + DIMENSION FC00(kts:ktep1),FC01(kts:ktep1),FC10(kts:ktep1),FC11(kts:ktep1) + DIMENSION REFPARAM(13) + +! These are the mixing ratios for H2O for a MLS atmosphere at the +! 13 RRTM reference pressure levels: 1.8759999E-02, 1.2223309E-02, +! 5.8908667E-03, 2.7675382E-03, 1.4065107E-03, 7.5969833E-04, +! 3.8875898E-04, 1.6542293E-04, 3.7189537E-05, 7.4764857E-06, +! 4.3081886E-06, 3.3319423E-06, 3.2039343E-06/ + +! The following are parameters related to the reference water vapor +! mixing ratios by REFPARAM(I) = REFH2O(I) / (.002+REFH2O(I)). +! These parameters are used for the Planck function interpolation. + DATA REFPARAM/ & + 0.903661, 0.859386, 0.746542, 0.580496, 0.412889, 0.275283, & + 0.162745, 7.63929E-02, 1.82553E-02, 3.72432E-03, & + 2.14946E-03, 1.66320E-03, 1.59940E-03/ + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below LAYTROP, the water vapor self-continuum is +! interpolated (in temperature) separately. +!cdir novector + DO 2500 LAY = 1, LAYTROP + WATER = 1.E20 * COLH2O(LAY) / COLDRY(LAY) + H2OPARAM = WATER/(WATER +.002) + DO 1800 IFRAC = 2, 12 + IF (H2OPARAM .GE. REFPARAM(IFRAC)) GO TO 1900 + 1800 CONTINUE + 1900 CONTINUE + FRACINT = (H2OPARAM-REFPARAM(IFRAC))/ & + (REFPARAM(IFRAC-1)-REFPARAM(IFRAC)) + + FP = FAC11(LAY) + FAC01(LAY) + IFP = 2.E2*FP+0.5 + IF (IFP.LE.0) IFP = 0 + FC00(LAY) = FAC00(LAY) * CORR2(IFP) + FC10(LAY) = FAC10(LAY) * CORR2(IFP) + FC01(LAY) = FAC01(LAY) * CORR1(IFP) + FC11(LAY) = FAC11(LAY) * CORR1(IFP) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(2) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(2) + 1 + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG2 + TAUG(NGS1+IG,LAY) = COLH2O(LAY) * & + (FC00(LAY) * ABSA2(IND0,IG) + & + FC10(LAY) * ABSA2(IND0+1,IG) + & + FC01(LAY) * ABSA2(IND1,IG) + & + FC11(LAY) * ABSA2(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC2(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC2(INDS+1,IG) - SELFREFC2(INDS,IG))) + & + FORFAC(LAY) * FORREFC2(IG)) + PFRAC(NGS1+IG,LAY) = FRACREFAC2(IG,IFRAC) + FRACINT * & + (FRACREFAC2(IG,IFRAC-1)-FRACREFAC2(IG,IFRAC)) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + FP = FAC11(LAY) + FAC01(LAY) + IFP = 2.E2*FP+0.5 + IF (IFP.LE.0) IFP = 0 + FC00(LAY) = FAC00(LAY) * CORR2(IFP) + FC10(LAY) = FAC10(LAY) * CORR2(IFP) + FC01(LAY) = FAC01(LAY) * CORR1(IFP) + FC11(LAY) = FAC11(LAY) * CORR1(IFP) + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(2) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(2) + 1 + DO 3000 IG = 1, NG2 + TAUG(NGS1+IG,LAY) = COLH2O(LAY) * & + (FC00(LAY) * ABSB2(IND0,IG) + & + FC10(LAY) * ABSB2(IND0+1,IG) + & + FC01(LAY) * ABSB2(IND1,IG) + & + FC11(LAY) * ABSB2(IND1+1,IG) + & + FORFAC(LAY) * FORREFC2(IG)) + PFRAC(NGS1+IG,LAY) = FRACREFBC2(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB2 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB3(kts,ktep1,COLH2O,COLCO2,COLN2O,FAC00,FAC01,FAC10, & + FAC11,FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 3: 500-630 cm-1 (low - H2O,CO2; high - H2O,CO2) + + INTEGER, PARAMETER :: NGS2=22 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCO2, & + COLN2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + DIMENSION H2OREF(59),CO2REF(59), ETAREF(10) + REAL N2OMULT,N2OREF(59) + + DATA ETAREF/ & + 0.,0.125,0.25,0.375,0.5,0.625,0.75,0.875,0.9875,1.0/ + DATA H2OREF/ & + 1.87599E-02,1.22233E-02,5.89086E-03,2.76753E-03,1.40651E-03, & + 7.59698E-04,3.88758E-04,1.65422E-04,3.71895E-05,7.47648E-06, & + 4.30818E-06,3.33194E-06,3.20393E-06,3.16186E-06,3.25235E-06, & + 3.42258E-06,3.62884E-06,3.91482E-06,4.14875E-06,4.30810E-06, & + 4.44204E-06,4.57783E-06,4.70865E-06,4.79432E-06,4.86971E-06, & + 4.92603E-06,4.96688E-06,4.99628E-06,5.05266E-06,5.12658E-06, & + 5.25028E-06,5.35708E-06,5.45085E-06,5.48304E-06,5.50000E-06, & + 5.50000E-06,5.45359E-06,5.40468E-06,5.35576E-06,5.25327E-06, & + 5.14362E-06,5.03396E-06,4.87662E-06,4.69787E-06,4.51911E-06, & + 4.33600E-06,4.14416E-06,3.95232E-06,3.76048E-06,3.57217E-06, & + 3.38549E-06,3.19881E-06,3.01212E-06,2.82621E-06,2.64068E-06, & + 2.45515E-06,2.26962E-06,2.08659E-06,1.93029E-06/ + DATA N2OREF/ & + 3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07, & + 3.19652E-07,3.15324E-07,3.03830E-07,2.94221E-07,2.84953E-07, & + 2.76714E-07,2.64709E-07,2.42847E-07,2.09547E-07,1.71945E-07, & + 1.37491E-07,1.13319E-07,1.00354E-07,9.12812E-08,8.54633E-08, & + 8.03631E-08,7.33718E-08,6.59754E-08,5.60386E-08,4.70901E-08, & + 3.99774E-08,3.29786E-08,2.60642E-08,2.10663E-08,1.65918E-08, & + 1.30167E-08,1.00900E-08,7.62490E-09,6.11592E-09,4.66725E-09, & + 3.28574E-09,2.84838E-09,2.46198E-09,2.07557E-09,1.85507E-09, & + 1.65675E-09,1.45843E-09,1.31948E-09,1.20716E-09,1.09485E-09, & + 9.97803E-10,9.31260E-10,8.64721E-10,7.98181E-10,7.51380E-10, & + 7.13670E-10,6.75960E-10,6.38250E-10,6.09811E-10,5.85998E-10, & + 5.62185E-10,5.38371E-10,5.15183E-10,4.98660E-10/ + DATA CO2REF/ & + 53*3.55E-04, 3.5470873E-04, 3.5427220E-04, 3.5383567E-04, & + 3.5339911E-04, 3.5282588E-04, 3.5079606E-04/ + + STRRAT = 1.19268 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT*COLCO2(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + IF (JS .EQ. 8) THEN + IF (FS .GE. 0.9) THEN + JS = 9 + FS = 10. * (FS - 0.9) + ELSE + FS = FS/0.9 + ENDIF + ENDIF + NS = JS + INT(FS + 0.5) + FP = FAC01(LAY) + FAC11(LAY) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(3) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(3) + JS + INDS = INDSELF(LAY) + COLREF1 = N2OREF(JP(LAY)) + COLREF2 = N2OREF(JP(LAY)+1) + IF (NS .EQ. 10) THEN + WCOMB1 = H2OREF(JP(LAY)) + WCOMB2 = H2OREF(JP(LAY)+1) + ELSE + WCOMB1 = STRRAT * CO2REF(JP(LAY))/(1.-ETAREF(NS)) + WCOMB2 = STRRAT * CO2REF(JP(LAY)+1)/(1.-ETAREF(NS)) + ENDIF + RATIO = (COLREF1/WCOMB1)+FP*((COLREF2/WCOMB2)-(COLREF1/WCOMB1)) + CURRN2O = SPECCOMB * RATIO + N2OMULT = COLN2O(LAY) - CURRN2O +!!DIR$ VECTOR + DO 2000 IG = 1, NG3 + TAUG(NGS2+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA3(IND0,IG) + & + FAC100 * ABSA3(IND0+1,IG) + & + FAC010 * ABSA3(IND0+10,IG) + & + FAC110 * ABSA3(IND0+11,IG) + & + FAC001 * ABSA3(IND1,IG) + & + FAC101 * ABSA3(IND1+1,IG) + & + FAC011 * ABSA3(IND1+10,IG) + & + FAC111 * ABSA3(IND1+11,IG)) + & + COLH2O(LAY) * & + (SELFFAC(LAY) * (SELFREFC3(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC3(INDS+1,IG) - SELFREFC3(INDS,IG))) + & + FORFAC(LAY) * FORREFC3(IG)) & + + N2OMULT * ABSN2OAC3(IG) + PFRAC(NGS2+IG,LAY) = FRACREFAC3(IG,JS) + FS * & + (FRACREFAC3(IG,JS+1) - FRACREFAC3(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + +!!DIR$ NOVECTOR +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + SPECCOMB = COLH2O(LAY) + STRRAT*COLCO2(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 4.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + NS = JS + INT(FS + 0.5) + FP = FAC01(LAY) + FAC11(LAY) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(3) + JS + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(3) + JS + COLREF1 = N2OREF(JP(LAY)) + COLREF2 = N2OREF(JP(LAY)+1) + IF (NS .EQ. 5) THEN + WCOMB1 = H2OREF(JP(LAY)) + WCOMB2 = H2OREF(JP(LAY)+1) + ELSE + WCOMB1 = STRRAT * CO2REF(JP(LAY))/(1.-ETAREF(NS)) + WCOMB2 = STRRAT * CO2REF(JP(LAY)+1)/(1.-ETAREF(NS)) + ENDIF + RATIO = (COLREF1/WCOMB1)+FP*((COLREF2/WCOMB2)-(COLREF1/WCOMB1)) + CURRN2O = SPECCOMB * RATIO + N2OMULT = COLN2O(LAY) - CURRN2O +!!DIR$ VECTOR + DO 3000 IG = 1, NG3 + TAUG(NGS2+IG,LAY) = SPECCOMB * & + (FAC000 * ABSB3(IND0,IG) + & + FAC100 * ABSB3(IND0+1,IG) + & + FAC010 * ABSB3(IND0+5,IG) + & + FAC110 * ABSB3(IND0+6,IG) + & + FAC001 * ABSB3(IND1,IG) + & + FAC101 * ABSB3(IND1+1,IG) + & + FAC011 * ABSB3(IND1+5,IG) + & + FAC111 * ABSB3(IND1+6,IG)) + & + COLH2O(LAY) * FORFAC(LAY) * FORREFC3(IG) & + + N2OMULT * ABSN2OBC3(IG) + PFRAC(NGS2+IG,LAY) = FRACREFBC3(IG,JS) + FS * & + (FRACREFBC3(IG,JS+1) - FRACREFBC3(IG,JS)) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB3 + +!---------------------------------------------------------------------------- + SUBROUTINE TAUGB4(kts,ktep1,COLH2O,COLCO2,COLO3,FAC00,FAC01,FAC10, & + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!---------------------------------------------------------------------------- + +! BAND 4: 630-700 cm-1 (low - H2O,CO2; high - O3,CO2) + + INTEGER, PARAMETER :: NGS3=38 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCO2, & + COLO3, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 850.577 + STRRAT2 = 35.7416 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. +!!DIR$ NOVECTOR +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLCO2(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(4) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(4) + JS + INDS = INDSELF(LAY) +!!DIR$ VECTOR + DO 2000 IG = 1, NG4 + TAUG(NGS3+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA4(IND0,IG) + & + FAC100 * ABSA4(IND0+1,IG) + & + FAC010 * ABSA4(IND0+9,IG) + & + FAC110 * ABSA4(IND0+10,IG) + & + FAC001 * ABSA4(IND1,IG) + & + FAC101 * ABSA4(IND1+1,IG) + & + FAC011 * ABSA4(IND1+9,IG) + & + FAC111 * ABSA4(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC4(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC4(INDS+1,IG) - SELFREFC4(INDS,IG))) + PFRAC(NGS3+IG,LAY) = FRACREFAC4(IG,JS) + FS * & + (FRACREFAC4(IG,JS+1) - FRACREFAC4(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + +!!DIR$ NOVECTOR +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + SPECCOMB = COLO3(LAY) + STRRAT2*COLCO2(LAY) + SPECPARM = COLO3(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 4.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + IF (JS .GT. 1) THEN + JS = JS + 1 + ELSEIF (FS .GE. 0.0024) THEN + JS = 2 + FS = (FS - 0.0024)/0.9976 + ELSE + JS = 1 + FS = FS/0.0024 + ENDIF + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(4) + JS + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(4) + JS +!!DIR$ VECTOR + DO 3000 IG = 1, NG4 + TAUG(NGS3+IG,LAY) = SPECCOMB * & + (FAC000 * ABSB4(IND0,IG) + & + FAC100 * ABSB4(IND0+1,IG) + & + FAC010 * ABSB4(IND0+6,IG) + & + FAC110 * ABSB4(IND0+7,IG) + & + FAC001 * ABSB4(IND1,IG) + & + FAC101 * ABSB4(IND1+1,IG) + & + FAC011 * ABSB4(IND1+6,IG) + & + FAC111 * ABSB4(IND1+7,IG)) + PFRAC(NGS3+IG,LAY) = FRACREFBC4(IG,JS) + FS * & + (FRACREFBC4(IG,JS+1) - FRACREFBC4(IG,JS)) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB4 + +!---------------------------------------------------------------------------- + SUBROUTINE TAUGB5(kts,ktep1,COLH2O,COLCO2,COLO3,FAC00,FAC01,FAC10, & + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,WX, & + PFRAC,TAUG,LAYTROP ) +!---------------------------------------------------------------------------- + +! BAND 5: 700-820 cm-1 (low - H2O,CO2; high - O3,CO2) + + INTEGER, PARAMETER :: NGS4=52 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( MAXXSEC,kts:ktep1 ), & + INTENT(IN ) :: WX + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCO2, & + COLO3, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 90.4894 + STRRAT2 = 0.900502 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. +!!DIR$ NOVECTOR +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLCO2(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(5) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(5) + JS + INDS = INDSELF(LAY) +!!DIR$ VECTOR + DO 2000 IG = 1, NG5 + TAUG(NGS4+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA5(IND0,IG) + & + FAC100 * ABSA5(IND0+1,IG) + & + FAC010 * ABSA5(IND0+9,IG) + & + FAC110 * ABSA5(IND0+10,IG) + & + FAC001 * ABSA5(IND1,IG) + & + FAC101 * ABSA5(IND1+1,IG) + & + FAC011 * ABSA5(IND1+9,IG) + & + FAC111 * ABSA5(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC5(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC5(INDS+1,IG) - SELFREFC5(INDS,IG))) & + + WX(1,LAY) * CCL4C5(IG) + PFRAC(NGS4+IG,LAY) = FRACREFAC5(IG,JS) + FS * & + (FRACREFAC5(IG,JS+1) - FRACREFAC5(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + +!!DIR$ NOVECTOR +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + SPECCOMB = COLO3(LAY) + STRRAT2*COLCO2(LAY) + SPECPARM = COLO3(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 4.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(5) + JS + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(5) + JS +!!DIR$ VECTOR + DO 3000 IG = 1, NG5 + TAUG(NGS4+IG,LAY) = SPECCOMB * & + (FAC000 * ABSB5(IND0,IG) + & + FAC100 * ABSB5(IND0+1,IG) + & + FAC010 * ABSB5(IND0+5,IG) + & + FAC110 * ABSB5(IND0+6,IG) + & + FAC001 * ABSB5(IND1,IG) + & + FAC101 * ABSB5(IND1+1,IG) + & + FAC011 * ABSB5(IND1+5,IG) + & + FAC111 * ABSB5(IND1+6,IG)) & + + WX(1,LAY) * CCL4C5(IG) + PFRAC(NGS4+IG,LAY) = FRACREFBC5(IG,JS) + FS * & + (FRACREFBC5(IG,JS+1) - FRACREFBC5(IG,JS)) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB5 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB6(kts,ktep1,COLH2O,CO2MULT,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,WX,PFRAC,TAUG, & + LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 6: 820-980 cm-1 (low - H2O; high - nothing) + + INTEGER, PARAMETER :: NGS5=68 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( MAXXSEC,kts:ktep1 ), & + INTENT(IN ) :: WX + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. The water vapor self-continuum is interpolated +! (in temperature) separately. +!cdir novector + DO 2500 LAY = 1, LAYTROP + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(6) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(6) + 1 + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG6 + TAUG(NGS5+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSA6(IND0,IG) + & + FAC10(LAY) * ABSA6(IND0+1,IG) + & + FAC01(LAY) * ABSA6(IND1,IG) + & + FAC11(LAY) * ABSA6(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC6(INDS,IG) + & + SELFFRAC(LAY)* & + (SELFREFC6(INDS+1,IG)-SELFREFC6(INDS,IG)))) & + + WX(2,LAY) * CFC11ADJC6(IG) & + + WX(3,LAY) * CFC12C6(IG) & + + CO2MULT(LAY) * ABSCO2C6(IG) + PFRAC(NGS5+IG,LAY) = FRACREFAC6(IG) + 2000 CONTINUE + 2500 CONTINUE + +! Nothing important goes on above LAYTROP in this band. +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + DO 3000 IG = 1, NG6 + TAUG(NGS5+IG,LAY) = 0.0 & + + WX(2,LAY) * CFC11ADJC6(IG) & + + WX(3,LAY) * CFC12C6(IG) + PFRAC(NGS5+IG,LAY) = FRACREFAC6(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB6 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB7(kts,ktep1,COLH2O,COLO3,CO2MULT,FAC00,FAC01,FAC10, & + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 7: 980-1080 cm-1 (low - H2O,O3; high - O3) + + INTEGER, PARAMETER :: NGS6=76 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLO3, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 8.21104E4 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. +!!DIR$ NOVECTOR +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLO3(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*SPECPARM + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(7) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(7) + JS + INDS = INDSELF(LAY) +!!DIR$ VECTOR + DO 2000 IG = 1, NG7 + TAUG(NGS6+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA7(IND0,IG) + & + FAC100 * ABSA7(IND0+1,IG) + & + FAC010 * ABSA7(IND0+9,IG) + & + FAC110 * ABSA7(IND0+10,IG) + & + FAC001 * ABSA7(IND1,IG) + & + FAC101 * ABSA7(IND1+1,IG) + & + FAC011 * ABSA7(IND1+9,IG) + & + FAC111 * ABSA7(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC7(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC7(INDS+1,IG) - SELFREFC7(INDS,IG)))& + + CO2MULT(LAY) * ABSCO2C7(IG) + PFRAC(NGS6+IG,LAY) = FRACREFAC7(IG,JS) + FS * & + (FRACREFAC7(IG,JS+1) - FRACREFAC7(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(7) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(7) + 1 + DO 3000 IG = 1, NG7 + TAUG(NGS6+IG,LAY) = COLO3(LAY) * & + (FAC00(LAY) * ABSB7(IND0,IG) + & + FAC10(LAY) * ABSB7(IND0+1,IG) + & + FAC01(LAY) * ABSB7(IND1,IG) + & + FAC11(LAY) * ABSB7(IND1+1,IG)) & + + CO2MULT(LAY) * ABSCO2C7(IG) + PFRAC(NGS6+IG,LAY) = FRACREFBC7(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB7 + +!---------------------------------------------------------------------------- + SUBROUTINE TAUGB8(kts,ktep1,COLH2O,COLO3,COLN2O,CO2MULT, & + FAC00,FAC01,FAC10,FAC11,SELFFAC,SELFFRAC, & + JP,JT,JT1,INDSELF,WX,PFRAC,TAUG,LAYSWTCH ) +!---------------------------------------------------------------------------- + +! BAND 8: 1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3) + + INTEGER, PARAMETER :: NGS7=88 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYSWTCH + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( MAXXSEC,kts:ktep1 ), & + INTENT(IN ) :: WX + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLO3, & + COLN2O, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + DIMENSION H2OREF(59),O3REF(59) + REAL N2OMULT,N2OREF(59) + + DATA H2OREF/ & + 1.87599E-02,1.22233E-02,5.89086E-03,2.76753E-03,1.40651E-03, & + 7.59698E-04,3.88758E-04,1.65422E-04,3.71895E-05,7.47648E-06, & + 4.30818E-06,3.33194E-06,3.20393E-06,3.16186E-06,3.25235E-06, & + 3.42258E-06,3.62884E-06,3.91482E-06,4.14875E-06,4.30810E-06, & + 4.44204E-06,4.57783E-06,4.70865E-06,4.79432E-06,4.86971E-06, & + 4.92603E-06,4.96688E-06,4.99628E-06,5.05266E-06,5.12658E-06, & + 5.25028E-06,5.35708E-06,5.45085E-06,5.48304E-06,5.50000E-06, & + 5.50000E-06,5.45359E-06,5.40468E-06,5.35576E-06,5.25327E-06, & + 5.14362E-06,5.03396E-06,4.87662E-06,4.69787E-06,4.51911E-06, & + 4.33600E-06,4.14416E-06,3.95232E-06,3.76048E-06,3.57217E-06, & + 3.38549E-06,3.19881E-06,3.01212E-06,2.82621E-06,2.64068E-06, & + 2.45515E-06,2.26962E-06,2.08659E-06,1.93029E-06/ + DATA N2OREF/ & + 3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07, & + 3.19652E-07,3.15324E-07,3.03830E-07,2.94221E-07,2.84953E-07, & + 2.76714E-07,2.64709E-07,2.42847E-07,2.09547E-07,1.71945E-07, & + 1.37491E-07,1.13319E-07,1.00354E-07,9.12812E-08,8.54633E-08, & + 8.03631E-08,7.33718E-08,6.59754E-08,5.60386E-08,4.70901E-08, & + 3.99774E-08,3.29786E-08,2.60642E-08,2.10663E-08,1.65918E-08, & + 1.30167E-08,1.00900E-08,7.62490E-09,6.11592E-09,4.66725E-09, & + 3.28574E-09,2.84838E-09,2.46198E-09,2.07557E-09,1.85507E-09, & + 1.65675E-09,1.45843E-09,1.31948E-09,1.20716E-09,1.09485E-09, & + 9.97803E-10,9.31260E-10,8.64721E-10,7.98181E-10,7.51380E-10, & + 7.13670E-10,6.75960E-10,6.38250E-10,6.09811E-10,5.85998E-10, & + 5.62185E-10,5.38371E-10,5.15183E-10,4.98660E-10/ + DATA O3REF/ & + 3.01700E-08,3.47254E-08,4.24769E-08,5.27592E-08,6.69439E-08, & + 8.71295E-08,1.13911E-07,1.56771E-07,2.17878E-07,3.24430E-07, & + 4.65942E-07,5.68057E-07,6.96065E-07,1.11863E-06,1.76175E-06, & + 2.32689E-06,2.95769E-06,3.65930E-06,4.59503E-06,5.31891E-06, & + 5.96179E-06,6.51133E-06,7.06350E-06,7.69169E-06,8.25771E-06, & + 8.70824E-06,8.83245E-06,8.71486E-06,8.09434E-06,7.33071E-06, & + 6.31014E-06,5.36717E-06,4.48289E-06,3.83913E-06,3.28270E-06, & + 2.82351E-06,2.49061E-06,2.16453E-06,1.83845E-06,1.66182E-06, & + 1.50517E-06,1.34852E-06,1.19718E-06,1.04822E-06,8.99264E-07, & + 7.63432E-07,6.53806E-07,5.44186E-07,4.34564E-07,3.64210E-07, & + 3.11938E-07,2.59667E-07,2.07395E-07,1.91456E-07,1.93639E-07, & + 1.95821E-07,1.98004E-07,2.06442E-07,2.81546E-07/ + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. +!cdir novector + DO 2500 LAY = 1, LAYSWTCH + FP = FAC01(LAY) + FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(8) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(8) + 1 + INDS = INDSELF(LAY) + COLREF1 = N2OREF(JP(LAY)) + COLREF2 = N2OREF(JP(LAY)+1) + WCOMB1 = H2OREF(JP(LAY)) + WCOMB2 = H2OREF(JP(LAY)+1) + RATIO = (COLREF1/WCOMB1)+FP*((COLREF2/WCOMB2)-(COLREF1/WCOMB1)) + CURRN2O = COLH2O(LAY) * RATIO + N2OMULT = COLN2O(LAY) - CURRN2O + DO 2000 IG = 1, NG8 + TAUG(NGS7+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSA8(IND0,IG) + & + FAC10(LAY) * ABSA8(IND0+1,IG) + & + FAC01(LAY) * ABSA8(IND1,IG) + & + FAC11(LAY) * ABSA8(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC8(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC8(INDS+1,IG) - SELFREFC8(INDS,IG))))& + + WX(3,LAY) * CFC12C8(IG) & + + WX(4,LAY) * CFC22ADJC8(IG) & + + CO2MULT(LAY) * ABSCO2AC8(IG) & + + N2OMULT * ABSN2OAC8(IG) + PFRAC(NGS7+IG,LAY) = FRACREFAC8(IG) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYSWTCH+1, NLAYERS + FP = FAC01(LAY) + FAC11(LAY) + IND0 = ((JP(LAY)-7)*5+(JT(LAY)-1))*NSPB(8) + 1 + IND1 = ((JP(LAY)-6)*5+(JT1(LAY)-1))*NSPB(8) + 1 + COLREF1 = N2OREF(JP(LAY)) + COLREF2 = N2OREF(JP(LAY)+1) + WCOMB1 = O3REF(JP(LAY)) + WCOMB2 = O3REF(JP(LAY)+1) + RATIO = (COLREF1/WCOMB1)+FP*((COLREF2/WCOMB2)-(COLREF1/WCOMB1)) + CURRN2O = COLO3(LAY) * RATIO + N2OMULT = COLN2O(LAY) - CURRN2O + DO 3000 IG = 1, NG8 + TAUG(NGS7+IG,LAY) = COLO3(LAY) * & + (FAC00(LAY) * ABSB8(IND0,IG) + & + FAC10(LAY) * ABSB8(IND0+1,IG) + & + FAC01(LAY) * ABSB8(IND1,IG) + & + FAC11(LAY) * ABSB8(IND1+1,IG)) & + + WX(3,LAY) * CFC12C8(IG) & + + WX(4,LAY) * CFC22ADJC8(IG) & + + CO2MULT(LAY) * ABSCO2BC8(IG) & + + N2OMULT * ABSN2OBC8(IG) + PFRAC(NGS7+IG,LAY) = FRACREFBC8(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB8 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB9(kts,ktep1,COLH2O,COLN2O,COLCH4,FAC00,FAC01,FAC10, & + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP,LAYSWTCH,LAYLOW ) +!----------------------------------------------------------------------------- + +! BAND 9: 1180-1390 cm-1 (low - H2O,CH4; high - CH4) + + INTEGER, PARAMETER :: NGS8=96 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP,LAYSWTCH,LAYLOW + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLN2O, & + COLCH4, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + DIMENSION H2OREF(13),CH4REF(13),ETAREF(11) + REAL N2OMULT,N2OREF(13) + + DATA N2OREF/ & + 3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07,3.20000E-07, & + 3.19652E-07,3.15324E-07,3.03830E-07,2.94221E-07,2.84953E-07, & + 2.76714E-07,2.64709E-07,2.42847E-07/ + DATA H2OREF/ & + 1.8759999E-02, 1.2223309E-02, 5.8908667E-03, 2.7675382E-03, & + 1.4065107E-03, 7.5969833E-04, 3.8875898E-04, 1.6542293E-04, & + 3.7189537E-05, 7.4764857E-06, 4.3081886E-06, 3.3319423E-06, & + 3.2039343E-06/ + DATA CH4REF/ & + 1.7000001E-06, 1.7000001E-06, 1.6998713E-06, 1.6904165E-06, & + 1.6671424E-06, 1.6350652E-06, 1.6097551E-06, 1.5590465E-06, & + 1.5119849E-06, 1.4741138E-06, 1.4384609E-06, 1.4002215E-06, & + 1.3573376E-06/ + DATA ETAREF/ & + 0.,0.125,0.25,0.375,0.5,0.625,0.75,0.875,0.96,0.99,1.0/ + + STRRAT = 21.6282 + IOFF = 0 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT*COLCH4(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + JFRAC = JS + FS = MOD(SPECMULT,1.0) + FFRAC = FS + IF (JS .EQ. 8) THEN + IF (FS .LE. 0.68) THEN + FS = FS/0.68 + ELSEIF (FS .LE. 0.92) THEN + JS = JS + 1 + FS = (FS-0.68)/0.24 + ELSE + JS = JS + 2 + FS = (FS-0.92)/0.08 + ENDIF + ELSEIF (JS .EQ.9) THEN + JS = 10 + FS = 1. + JFRAC = 8 + FFRAC = 1. + ENDIF + FP = FAC01(LAY) + FAC11(LAY) + NS = JS + INT(FS + 0.5) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(9) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(9) + JS + INDS = INDSELF(LAY) + IF (LAY .EQ. LAYLOW) IOFF = NG9 + IF (LAY .EQ. LAYSWTCH) IOFF = 2*NG9 + COLREF1 = N2OREF(JP(LAY)) + COLREF2 = N2OREF(JP(LAY)+1) + IF (NS .EQ. 11) THEN + WCOMB1 = H2OREF(JP(LAY)) + WCOMB2 = H2OREF(JP(LAY)+1) + ELSE + WCOMB1 = STRRAT * CH4REF(JP(LAY))/(1.-ETAREF(NS)) + WCOMB2 = STRRAT * CH4REF(JP(LAY)+1)/(1.-ETAREF(NS)) + ENDIF + RATIO = (COLREF1/WCOMB1)+FP*((COLREF2/WCOMB2)-(COLREF1/WCOMB1)) + CURRN2O = SPECCOMB * RATIO + N2OMULT = COLN2O(LAY) - CURRN2O + DO 2000 IG = 1, NG9 + TAUG(NGS8+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA9(IND0,IG) + & + FAC100 * ABSA9(IND0+1,IG) + & + FAC010 * ABSA9(IND0+11,IG) + & + FAC110 * ABSA9(IND0+12,IG) + & + FAC001 * ABSA9(IND1,IG) + & + FAC101 * ABSA9(IND1+1,IG) + & + FAC011 * ABSA9(IND1+11,IG) + & + FAC111 * ABSA9(IND1+12,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC9(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC9(INDS+1,IG) - SELFREFC9(INDS,IG))) & + + N2OMULT * ABSN2OC9(IG+IOFF) + PFRAC(NGS8+IG,LAY) = FRACREFAC9(IG,JFRAC) + FFRAC * & + (FRACREFAC9(IG,JFRAC+1) - FRACREFAC9(IG,JFRAC)) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(9) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(9) + 1 + DO 3000 IG = 1, NG9 + TAUG(NGS8+IG,LAY) = COLCH4(LAY) * & + (FAC00(LAY) * ABSB9(IND0,IG) + & + FAC10(LAY) * ABSB9(IND0+1,IG) + & + FAC01(LAY) * ABSB9(IND1,IG) + & + FAC11(LAY) * ABSB9(IND1+1,IG)) + PFRAC(NGS8+IG,LAY) = FRACREFBC9(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB9 + +!-------------------------------------------------------------------------------- + SUBROUTINE TAUGB10(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11,JP,JT,JT1, & + PFRAC,TAUG,LAYTROP ) +!-------------------------------------------------------------------------------- + +! BAND 10: 1390-1480 cm-1 (low - H2O; high - H2O) + + INTEGER, PARAMETER :: NGS9=108 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11 + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1 + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. +!cdir novector + DO 2500 LAY = 1, LAYTROP + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(10) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(10) + 1 + DO 2000 IG = 1, NG10 + TAUG(NGS9+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSA10(IND0,IG) + & + FAC10(LAY) * ABSA10(IND0+1,IG) + & + FAC01(LAY) * ABSA10(IND1,IG) + & + FAC11(LAY) * ABSA10(IND1+1,IG)) + PFRAC(NGS9+IG,LAY) = FRACREFAC10(IG) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(10) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(10) + 1 + DO 3000 IG = 1, NG10 + TAUG(NGS9+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSB10(IND0,IG) + & + FAC10(LAY) * ABSB10(IND0+1,IG) + & + FAC01(LAY) * ABSB10(IND1,IG) + & + FAC11(LAY) * ABSB10(IND1+1,IG)) + PFRAC(NGS9+IG,LAY) = FRACREFBC10(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB10 + +!-------------------------------------------------------------------------- + SUBROUTINE TAUGB11(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP ) +!-------------------------------------------------------------------------- + +! BAND 11: 1480-1800 cm-1 (low - H2O; high - H2O) + + INTEGER, PARAMETER :: NGS10=114 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below LAYTROP, the water vapor self-continuum +! is interpolated (in temperature) separately. +!cdir novector + DO 2500 LAY = 1, LAYTROP + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(11) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(11) + 1 + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG11 + TAUG(NGS10+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSA11(IND0,IG) + & + FAC10(LAY) * ABSA11(IND0+1,IG) + & + FAC01(LAY) * ABSA11(IND1,IG) + & + FAC11(LAY) * ABSA11(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC11(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC11(INDS+1,IG) - SELFREFC11(INDS,IG)))) + PFRAC(NGS10+IG,LAY) = FRACREFAC11(IG) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(11) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(11) + 1 + DO 3000 IG = 1, NG11 + TAUG(NGS10+IG,LAY) = COLH2O(LAY) * & + (FAC00(LAY) * ABSB11(IND0,IG) + & + FAC10(LAY) * ABSB11(IND0+1,IG) + & + FAC01(LAY) * ABSB11(IND1,IG) + & + FAC11(LAY) * ABSB11(IND1+1,IG)) + PFRAC(NGS10+IG,LAY) = FRACREFBC11(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB11 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB12(kts,ktep1,COLH2O,COLCO2,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 12: 1800-2080 cm-1 (low - H2O,CO2; high - nothing) + + INTEGER, PARAMETER :: NGS11=122 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCO2, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 0.009736757 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. +!!DIR$ NOVECTOR +!cdir novector + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLCO2(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(12) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(12) + JS + INDS = INDSELF(LAY) +!!DIR$ VECTOR + DO 2000 IG = 1, NG12 + TAUG(NGS11+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA12(IND0,IG) + & + FAC100 * ABSA12(IND0+1,IG) + & + FAC010 * ABSA12(IND0+9,IG) + & + FAC110 * ABSA12(IND0+10,IG) + & + FAC001 * ABSA12(IND1,IG) + & + FAC101 * ABSA12(IND1+1,IG) + & + FAC011 * ABSA12(IND1+9,IG) + & + FAC111 * ABSA12(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC12(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC12(INDS+1,IG) - SELFREFC12(INDS,IG))) + PFRAC(NGS11+IG,LAY) = FRACREFAC12(IG,JS) + FS * & + (FRACREFAC12(IG,JS+1) - FRACREFAC12(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + +!cdir novector + DO 3500 LAY = LAYTROP+1, NLAYERS + DO 3000 IG = 1, NG12 + TAUG(NGS11+IG,LAY) = 0.0 + PFRAC(NGS11+IG,LAY) = 0.0 + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB12 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB13(kts,ktep1,COLH2O,COLN2O,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 13: 2080-2250 cm-1 (low - H2O,N2O; high - nothing) + + INTEGER, PARAMETER :: NGS12=130 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLN2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 16658.87 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLN2O(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(13) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(13) + JS + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG13 + TAUG(NGS12+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA13(IND0,IG) + & + FAC100 * ABSA13(IND0+1,IG) + & + FAC010 * ABSA13(IND0+9,IG) + & + FAC110 * ABSA13(IND0+10,IG) + & + FAC001 * ABSA13(IND1,IG) + & + FAC101 * ABSA13(IND1+1,IG) + & + FAC011 * ABSA13(IND1+9,IG) + & + FAC111 * ABSA13(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC13(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC13(INDS+1,IG) - SELFREFC13(INDS,IG))) + PFRAC(NGS12+IG,LAY) = FRACREFAC13(IG,JS) + FS * & + (FRACREFAC13(IG,JS+1) - FRACREFAC13(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + + DO 3500 LAY = LAYTROP+1, NLAYERS + DO 3000 IG = 1, NG13 + TAUG(NGS12+IG,LAY) = 0.0 + PFRAC(NGS12+IG,LAY) = 0.0 + 3000 CONTINUE + 3500 CONTINUE + + + END SUBROUTINE TAUGB13 + +!---------------------------------------------------------------------------- + SUBROUTINE TAUGB14(kts,ktep1,COLCO2,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP ) +!---------------------------------------------------------------------------- + +! BAND 14: 2250-2380 cm-1 (low - CO2; high - CO2) + + INTEGER, PARAMETER :: NGS13=134 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLCO2, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below LAYTROP, the water vapor self-continuum +! is interpolated (in temperature) separately. + DO 2500 LAY = 1, LAYTROP + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(14) + 1 + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(14) + 1 + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG14 + TAUG(NGS13+IG,LAY) = COLCO2(LAY) * & + (FAC00(LAY) * ABSA14(IND0,IG) + & + FAC10(LAY) * ABSA14(IND0+1,IG) + & + FAC01(LAY) * ABSA14(IND1,IG) + & + FAC11(LAY) * ABSA14(IND1+1,IG) + & + SELFFAC(LAY) * (SELFREFC14(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC14(INDS+1,IG) - SELFREFC14(INDS,IG)))) + PFRAC(NGS13+IG,LAY) = FRACREFAC14(IG) + 2000 CONTINUE + 2500 CONTINUE + + DO 3500 LAY = LAYTROP+1, NLAYERS + IND0 = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(14) + 1 + IND1 = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(14) + 1 + DO 3000 IG = 1, NG14 + TAUG(NGS13+IG,LAY) = COLCO2(LAY) * & + (FAC00(LAY) * ABSB14(IND0,IG) + & + FAC10(LAY) * ABSB14(IND0+1,IG) + & + FAC01(LAY) * ABSB14(IND1,IG) + & + FAC11(LAY) * ABSB14(IND1+1,IG)) + PFRAC(NGS13+IG,LAY) = FRACREFBC14(IG) + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB14 + +!------------------------------------------------------------------------------ + SUBROUTINE TAUGB15(kts,ktep1,COLH2O,COLCO2,COLN2O,FAC00,FAC01,FAC10, & + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF, & + PFRAC,TAUG,LAYTROP ) +!------------------------------------------------------------------------------ + +! BAND 15: 2380-2600 cm-1 (low - N2O,CO2; high - nothing) + + INTEGER, PARAMETER :: NGS14=136 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCO2, & + COLN2O, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 0.2883201 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLN2O(LAY) + STRRAT1*COLCO2(LAY) + SPECPARM = COLN2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(15) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(15) + JS + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG15 + TAUG(NGS14+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA15(IND0,IG) + & + FAC100 * ABSA15(IND0+1,IG) + & + FAC010 * ABSA15(IND0+9,IG) + & + FAC110 * ABSA15(IND0+10,IG) + & + FAC001 * ABSA15(IND1,IG) + & + FAC101 * ABSA15(IND1+1,IG) + & + FAC011 * ABSA15(IND1+9,IG) + & + FAC111 * ABSA15(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC15(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC15(INDS+1,IG) - SELFREFC15(INDS,IG))) + PFRAC(NGS14+IG,LAY) = FRACREFAC15(IG,JS) + FS * & + (FRACREFAC15(IG,JS+1) - FRACREFAC15(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + + DO 3500 LAY = LAYTROP+1, NLAYERS + DO 3000 IG = 1, NG15 + TAUG(NGS14+IG,LAY) = 0.0 + PFRAC(NGS14+IG,LAY) = 0.0 + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB15 + +!----------------------------------------------------------------------------- + SUBROUTINE TAUGB16(kts,ktep1,COLH2O,COLCH4,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP ) +!----------------------------------------------------------------------------- + +! BAND 16: 2600-3000 cm-1 (low - H2O,CH4; high - nothing) + + INTEGER, PARAMETER :: NGS15=138 + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, INTENT(IN ) :: LAYTROP + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC, & + TAUG + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLH2O, & + COLCH4, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + JP, & + JT, & + JT1, & + INDSELF + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + STRRAT1 = 830.411 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + DO 2500 LAY = 1, LAYTROP + SPECCOMB = COLH2O(LAY) + STRRAT1*COLCH4(LAY) + SPECPARM = COLH2O(LAY)/SPECCOMB + IF (SPECPARM .GE. ONEMINUS) SPECPARM = ONEMINUS + SPECMULT = 8.*(SPECPARM) + JS = 1 + INT(SPECMULT) + FS = MOD(SPECMULT,1.0) + FAC000 = (1. - FS) * FAC00(LAY) + FAC010 = (1. - FS) * FAC10(LAY) + FAC100 = FS * FAC00(LAY) + FAC110 = FS * FAC10(LAY) + FAC001 = (1. - FS) * FAC01(LAY) + FAC011 = (1. - FS) * FAC11(LAY) + FAC101 = FS * FAC01(LAY) + FAC111 = FS * FAC11(LAY) + IND0 = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(16) + JS + IND1 = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(16) + JS + INDS = INDSELF(LAY) + DO 2000 IG = 1, NG16 + TAUG(NGS15+IG,LAY) = SPECCOMB * & + (FAC000 * ABSA16(IND0,IG) + & + FAC100 * ABSA16(IND0+1,IG) + & + FAC010 * ABSA16(IND0+9,IG) + & + FAC110 * ABSA16(IND0+10,IG) + & + FAC001 * ABSA16(IND1,IG) + & + FAC101 * ABSA16(IND1+1,IG) + & + FAC011 * ABSA16(IND1+9,IG) + & + FAC111 * ABSA16(IND1+10,IG)) + & + COLH2O(LAY) * & + SELFFAC(LAY) * (SELFREFC16(INDS,IG) + & + SELFFRAC(LAY) * & + (SELFREFC16(INDS+1,IG) - SELFREFC16(INDS,IG))) + PFRAC(NGS15+IG,LAY) = FRACREFAC16(IG,JS) + FS * & + (FRACREFAC16(IG,JS+1) - FRACREFAC16(IG,JS)) + 2000 CONTINUE + 2500 CONTINUE + + DO 3500 LAY = LAYTROP+1, NLAYERS + DO 3000 IG = 1, NG16 + TAUG(NGS15+IG,LAY) = 0.0 + PFRAC(NGS15+IG,LAY) = 0.0 + 3000 CONTINUE + 3500 CONTINUE + + END SUBROUTINE TAUGB16 + + +!------------------------------------------------------------------------- + SUBROUTINE RTRN(kts,ktep1, & + TAVEL, PZ, TZ, CLDFRAC, TAUCLOUD, TOTDFLUX, & + TOTUFLUX, HTR, ICLDLYR, ITR, PFRAC, TBOUND,SEMISS ) +!------------------------------------------------------------------------- +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! This program calculates the upward fluxes, downward fluxes, and +! heating rates for an arbitrary clear or cloudy atmosphere. The input +! to this program is the atmospheric profile, all Planck function +! information, and the cloud fraction by layer. The diffusivity angle +! (SECANG=1.66) is used for the angle integration for consistency with +! the NCAR CCM; the Gaussian weight appropriate to this angle (WTNUM=0.5) +! is applied here. Note that use of the emissivity angle for the flux +! integration can cause errors of 1 to 4 W/m2 within cloudy layers. +!------------------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: kts,ktep1 + + INTEGER, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(IN ) :: ITR + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(IN ) :: PFRAC + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + TAVEL + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + CLDFRAC, & + TAUCLOUD + + REAL, DIMENSION( 0:ktep1 ),INTENT(INOUT):: & + TOTDFLUX, & + TOTUFLUX + + REAL, DIMENSION( 0:ktep1 ), INTENT(INOUT) :: & + HTR + + REAL, DIMENSION( 0:ktep1 ), INTENT(IN ) :: & + PZ, & + TZ + INTEGER, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + ICLDLYR + + REAL, INTENT(IN ) :: TBOUND + REAL, DIMENSION(NBANDS), INTENT(IN ) :: SEMISS + +! LOCAL VAR + + REAL, DIMENSION( 0:ktep1 ) :: & + TOTUCLFL, & + TOTDCLFL + + REAL, DIMENSION( 0:ktep1 ) :: & + FNET, & + FNETC, & + HTRC + + INTEGER :: kk + + REAL :: CLRNTTOA,CLRNTSRF + +! Parameters + +! INTEGER, PARAMETER :: MXLAY=101 + REAL, PARAMETER :: SECANG=1.66 + REAL, PARAMETER :: WTNUM=0.5 + +! RRTM Definitions +! Input +! MXLAY ! Maximum number of model layers +! NGPT ! Total number of g-point subintervals +! NBANDS ! Number of longwave spectral bands +! SECANG ! Diffusivity angle +! WTNUM ! Weight for radiance to flux conversion +! NLAYERS ! Number of model layers (plev+1) +! PAVEL(MXLAY) ! Layer pressures (mb) +! PZ(0:MXLAY) ! Level (interface) pressures (mb) +! TAVEL(MXLAY) ! Layer temperatures (K) +! TZ(0:MXLAY) ! Level (interface) temperatures(mb) +! TBOUND ! Surface temperature (K) +! CLDFRAC(MXLAY) ! Layer cloud fraction +! TAUCLOUD(MXLAY) ! Layer cloud optical depth +! ITR(NGPT,MXLAY) ! Integer look-up table index +! PFRAC(NGPT,MXLAY) ! Planck fractions +! ICLDLYR(MXLAY) ! Flag for cloudy layers +! ICLD ! Flag for cloudy in column +! SEMISS(NBANDS) ! Surface emissivities for each band +! BPADE ! Pade constant +! TAU ! Clear sky optical depth look-up table +! TF ! Tau transition function look-up table +! TRANS ! Clear sky transmittance look-up table +! Local +! ABSS(NGPT*MXLAY) ! Gaseous absorptivity +! ABSCLD(MXLAY) ! Cloud absorptivity +! ATOT(NGPT*MXLAY) ! Combined gaseous and cloud absorptivity +! ODCLR(NGPT,MXLAY) ! Clear sky (gaseous) optical depth +! ODCLD(MXLAY) ! Cloud optical depth +! EFCLFRAC(MXLAY) ! Effective cloud fraction +! RADLU(NGPT) ! Upward radiance +! URAD ! Spectrally summed upward radiance +! RADCLRU(NGPT) ! Clear sky upward radiance +! CLRURAD ! Spectrally summed clear sky upward radiance +! RADLD(NGPT) ! Downward radiance +! DRAD ! Spectrally summed downward radiance +! RADCLRD(NGPT) ! Clear sky downward radiance +! CLRDRAD ! Spectrally summed clear sky downward radianc +! Output +! TOTUFLUX(0:MXLAY) ! Upward longwave flux (W/m2) +! TOTDFLUX(0:MXLAY) ! Downward longwave flux (W/m2) +! FNET(0:MXLAY) ! Net longwave flux (W/m2) +! HTR(0:MXLAY) ! Longwave heating rate (K/day) +! CLRNTTOA ! Clear sky TOA outgoing flux (W/m2) +! CLRNTSFC ! Clear sky net surface flux (W/m2) +! TOTUCLFL(0:MXLAY) ! Clear sky upward longwave flux (W/m2) +! TOTDCLFL(0:MXLAY) ! Clear sky downward longwave flux (W/m2) +! FNETC(0:MXLAY) ! Clear sky net longwave flux (W/m2) +! HTRC(0:MXLAY) ! Clear sky longwave heating rate (K/day) +! + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + + DIMENSION BBU(NGPT*(ktep1-kts+1)),BBUTOT(NGPT*(ktep1-kts)),BGLEV(NGPT) + DIMENSION PLANKBND(NBANDS),PLNKEMIT(NBANDS) + DIMENSION PLVL(NBANDS,0:ktep1),PLAY(NBANDS,kts:ktep1) + DIMENSION INDLAY(kts:ktep1),INDLEV(0:ktep1) + DIMENSION TLAYFRAC(kts:ktep1),TLEVFRAC(0:ktep1) + DIMENSION ABSS(NGPT*(ktep1-kts+1)),ABSCLD(kts:ktep1-1),ATOT(NGPT*(ktep1-kts)) + DIMENSION ODCLR(NGPT,kts:ktep1-1),ODCLD(kts:ktep1-1),EFCLFRAC(kts:ktep1-1) + DIMENSION RADLU(NGPT),RADLD(NGPT) + DIMENSION RADCLRU(NGPT),RADCLRD(NGPT) + DIMENSION SEMIS(NGPT),RADUEMIT(NGPT) + + INDBOUND = TBOUND - 159. + TBNDFRAC = TBOUND - INT(TBOUND) + + DO 200 LAY = 0, NLAYERS + TOTUFLUX(LAY) = 0.0 + TOTDFLUX(LAY) = 0.0 + TOTUCLFL(LAY) = 0.0 + TOTDCLFL(LAY) = 0.0 + INDLEV(LAY) = TZ(LAY) - 159. + TLEVFRAC(LAY) = TZ(LAY) - INT(TZ(LAY)) + 200 CONTINUE + + DO 220 LEV = 1, NLAYERS + + IF (ICLDLYR(LEV).EQ.1) THEN + INDLAY(LEV) = TAVEL(LEV) - 159. + TLAYFRAC(LEV) = TAVEL(LEV) - INT(TAVEL(LEV)) +! Cloudy sky optical depth and absorptivity. + ODCLD(LEV) = SECANG * TAUCLOUD(LEV) + TRANSCLD = EXP(-ODCLD(LEV)) + ABSCLD(LEV) = 1. - TRANSCLD + EFCLFRAC(LEV) = ABSCLD(LEV) * CLDFRAC(LEV) +! Get clear sky optical depth from TAU lookup table + DO 250 IPR = 1, NGPT + IND = ITR(IPR,LEV) + ODCLR(IPR,LEV) = TAU(IND) + 250 CONTINUE + ELSE + INDLAY(LEV) = TAVEL(LEV) - 159. + TLAYFRAC(LEV) = TAVEL(LEV) - INT(TAVEL(LEV)) + ENDIF + + 220 CONTINUE + +! SUMPL = 0.0 +! SUMPLEM = 0.0 +! *** Loop over frequency bands. + DO 600 IBAND = 1, NBANDS + DBDTLEV = TOTPLNK(INDBOUND+1,IBAND)-TOTPLNK(INDBOUND,IBAND) + PLANKBND(IBAND) = DELWAVE(IBAND) * (TOTPLNK(INDBOUND,IBAND) + & + TBNDFRAC * DBDTLEV) + DBDTLEV = TOTPLNK(INDLEV(0)+1,IBAND) - & + TOTPLNK(INDLEV(0),IBAND) + PLVL(IBAND,0) = DELWAVE(IBAND) * (TOTPLNK(INDLEV(0),IBAND) + & + TLEVFRAC(0)*DBDTLEV) + + PLNKEMIT(IBAND) = SEMISS(IBAND) * PLANKBND(IBAND) +! SUMPLEM = SUMPLEM + PLNKEMIT(IBAND) +! SUMPL = SUMPL + PLANKBND(IBAND) + + DO 300 LEV = 1, NLAYERS +! Calculate the integrated Planck functions at the level and +! layer temperatures. + DBDTLEV = TOTPLNK(INDLEV(LEV)+1,IBAND) - & + TOTPLNK(INDLEV(LEV),IBAND) + DBDTLAY = TOTPLNK(INDLAY(LEV)+1,IBAND) - & + TOTPLNK(INDLAY(LEV),IBAND) + PLAY(IBAND,LEV) = DELWAVE(IBAND) * & + (TOTPLNK(INDLAY(LEV),IBAND) + TLAYFRAC(LEV) * DBDTLAY) + PLVL(IBAND,LEV) = DELWAVE(IBAND) * & + (TOTPLNK(INDLEV(LEV),IBAND) + TLEVFRAC(LEV) * DBDTLEV) + 300 CONTINUE + 600 CONTINUE + +! SEMISLW = SUMPLEM / SUMPL + +! *** Initialize for radiative transfer. + DO 500 IPR = 1, NGPT + RADCLRD(IPR) = 0. + RADLD(IPR) = 0. + SEMIS(IPR) = SEMISS(NGB(IPR)) + RADUEMIT(IPR) = PFRAC(IPR,1) * PLNKEMIT(NGB(IPR)) + BGLEV(IPR) = PFRAC(IPR,NLAYERS) * PLVL(NGB(IPR),NLAYERS) + 500 CONTINUE + + +! *** DOWNWARD RADIATIVE TRANSFER +! *** DRAD holds summed radiance for total sky stream +! *** CLRDRAD holds summed radiance for clear sky stream + + ICLDDN = 0 + DO 3000 LEV = NLAYERS, 1, -1 + DRAD = 0.0 + CLRDRAD = 0.0 + + IF (ICLDLYR(LEV).EQ.1) THEN + +! *** Cloudy layer + ICLDDN = 1 + IENT = NGPT * (LEV-1) + DO 2000 IPR = 1, NGPT + INDEX = IENT + IPR +! Get lookup table index + IND = ITR(IPR,LEV) +! Add clear sky and cloud optical depths + ODSM = ODCLR(IPR,LEV) + ODCLD(LEV) + FACTOT = ODSM / (BPADE + ODSM) + BGLAY = PFRAC(IPR,LEV) * PLAY(NGB(IPR),LEV) + DELBGUP = BGLEV(IPR) - BGLAY +! Get TF from lookup table + TAUF = TF(IND) + BBU(INDEX) = BGLAY + TAUF * DELBGUP + BBUTOT(INDEX) = BGLAY + FACTOT * DELBGUP + BGLEV(IPR) = PFRAC(IPR,LEV) * PLVL(NGB(IPR),LEV-1) + DELBGDN = BGLEV(IPR) - BGLAY + BBD = BGLAY + TAUF * DELBGDN + BBDLEVD = BGLAY + FACTOT * DELBGDN +! Get clear sky transmittance from lookup table + ABSS(INDEX) = 1. - TRANS(IND) + ATOT(INDEX) = ABSS(INDEX) + ABSCLD(LEV) - & + ABSS(INDEX) * ABSCLD(LEV) + GASSRC = BBD * ABSS(INDEX) +! Total sky radiance + RADLD(IPR) = RADLD(IPR) - RADLD(IPR) * (ABSS(INDEX) + & + EFCLFRAC(LEV) * (1.-ABSS(INDEX))) + GASSRC + & + CLDFRAC(LEV) * (BBDLEVD * ATOT(INDEX) - GASSRC) + DRAD = DRAD + RADLD(IPR) +! Clear sky radiance + RADCLRD(IPR) = RADCLRD(IPR) + (BBD - RADCLRD(IPR)) & + * ABSS(INDEX) + CLRDRAD = CLRDRAD + RADCLRD(IPR) + 2000 CONTINUE + + ELSE + +! *** Clear layer + IENT = NGPT * (LEV-1) + DO 2100 IPR = 1, NGPT + INDEX = IENT + IPR + IND = ITR(IPR,LEV) + BGLAY = PFRAC(IPR,LEV) * PLAY(NGB(IPR),LEV) + DELBGUP = BGLEV(IPR) - BGLAY +! Get TF from lookup table + TAUF = TF(IND) + BBU(INDEX) = BGLAY + TAUF * DELBGUP + BGLEV(IPR) = PFRAC(IPR,LEV) * PLVL(NGB(IPR),LEV-1) + DELBGDN = BGLEV(IPR) - BGLAY + BBD = BGLAY + TAUF * DELBGDN +! Get clear sky transmittance from lookup table + ABSS(INDEX) = 1. - TRANS(IND) +! Total sky radiance + RADLD(IPR) = RADLD(IPR) + (BBD - RADLD(IPR)) * & + ABSS(INDEX) + DRAD = DRAD + RADLD(IPR) + 2100 CONTINUE +! Set clear sky stream to total sky stream as long as layers +! remain clear. Streams diverge when a cloud is reached. + IF (ICLDDN.EQ.1) THEN + DO 2200 IPR = 1, NGPT + RADCLRD(IPR) = RADCLRD(IPR) + (BBD - RADCLRD(IPR)) * & + ABSS(INDEX) + CLRDRAD = CLRDRAD + RADCLRD(IPR) + 2200 CONTINUE + ELSE + DO 2300 IPR = 1, NGPT + RADCLRD(IPR) = RADLD(IPR) + CLRDRAD = DRAD + 2300 CONTINUE + ENDIF + +! 2100 CONTINUE + + ENDIF + + TOTDFLUX(LEV-1) = DRAD * WTNUM + TOTDCLFL(LEV-1) = CLRDRAD * WTNUM + + 3000 CONTINUE + + +! SPECTRAL EMISSIVITY & REFLECTANCE +! Include the contribution of spectrally varying longwave emissivity and +! reflection from the surface to the upward radiative transfer. +! Note: Spectral and Lambertian reflection are identical for the one angle +! flux integration used here. + + URAD = 0.0 + CLRURAD = 0.0 + DO 3500 IPR = 1, NGPT +! Total sky radiance + RADLU(IPR) = RADUEMIT(IPR) + (1. - SEMIS(IPR)) * RADLD(IPR) + URAD = URAD + RADLU(IPR) +! Clear sky radiance + RADCLRU(IPR) = RADUEMIT(IPR) + (1. - SEMIS(IPR)) & + * RADCLRD(IPR) + CLRURAD = CLRURAD + RADCLRU(IPR) + 3500 CONTINUE + TOTUFLUX(0) = URAD * WTNUM + TOTUCLFL(0) = CLRURAD * WTNUM + + +! *** UPWARD RADIATIVE TRANSFER +! *** URAD holds the summed radiance for total sky stream +! *** CLRURAD holds the summed radiance for clear sky stream + + DO 5000 LEV = 1, NLAYERS + URAD = 0.0 + CLRURAD = 0.0 + +! Check flag for cloud in current layer + + IF (ICLDLYR(LEV).EQ.1) THEN + +! *** Cloudy layers + IENT = NGPT * (LEV-1) + DO 4000 IPR = 1, NGPT + INDEX = IENT + IPR + GASSRC = BBU(INDEX) * ABSS(INDEX) +! Total sky radiance + RADLU(IPR) = RADLU(IPR) - RADLU(IPR) * (ABSS(INDEX) + & + EFCLFRAC(LEV) * (1.-ABSS(INDEX))) + GASSRC + & + CLDFRAC(LEV) * (BBUTOT(INDEX) * ATOT(INDEX) - GASSRC) + URAD = URAD + RADLU(IPR) +! Clear sky radiance + RADCLRU(IPR) = RADCLRU(IPR) + (BBU(INDEX) - RADCLRU(IPR)) * & + ABSS(INDEX) + CLRURAD = CLRURAD + RADCLRU(IPR) + 4000 CONTINUE + + ELSE + +! *** Clear layer + IENT = NGPT * (LEV-1) + DO 4100 IPR = 1, NGPT + INDEX = IENT + IPR +! Total sky radiance + RADLU(IPR) = RADLU(IPR) + (BBU(INDEX)-RADLU(IPR)) * & + ABSS(INDEX) + URAD = URAD + RADLU(IPR) +! Clear sky radiance +! Upward clear and total sky streams must remain separate because surface +! reflectance is different for each. + RADCLRU(IPR) = RADCLRU(IPR) + (BBU(INDEX) - RADCLRU(IPR)) & + * ABSS(INDEX) + CLRURAD = CLRURAD + RADCLRU(IPR) + 4100 CONTINUE + + ENDIF + + TOTUFLUX(LEV) = URAD * WTNUM + TOTUCLFL(LEV) = CLRURAD * WTNUM + + 5000 CONTINUE + + +! *** Convert radiances to fluxes and heating rates for total sky. Calculates +! clear sky surface and TOA values. To compute clear sky profiles, uncommen +! relevant lines below. + TOTUFLUX(0) = TOTUFLUX(0) * FLUXFAC + TOTDFLUX(0) = TOTDFLUX(0) * FLUXFAC + FNET(0) = TOTUFLUX(0) - TOTDFLUX(0) + TOTUCLFL(0) = TOTUCLFL(0) * FLUXFAC + TOTDCLFL(0) = TOTDCLFL(0) * FLUXFAC + FNETC(0) = TOTUCLFL(0) - TOTDCLFL(0) + CLRNTTOA = TOTUCLFL(NLAYERS) + CLRNTSRF = TOTUFLUX(0) - TOTDCLFL(0) + + DO 7000 LEV = 1, NLAYERS + TOTUFLUX(LEV) = TOTUFLUX(LEV) * FLUXFAC + TOTDFLUX(LEV) = TOTDFLUX(LEV) * FLUXFAC + FNET(LEV) = TOTUFLUX(LEV) - TOTDFLUX(LEV) + TOTUCLFL(LEV) = TOTUCLFL(LEV) * FLUXFAC + TOTDCLFL(LEV) = TOTDCLFL(LEV) * FLUXFAC + FNETC(LEV) = TOTUCLFL(LEV) - TOTDCLFL(LEV) + L = LEV - 1 +! Calculate Heating Rates. + HTR(L) = HEATFAC * (FNET(L) - FNET(LEV)) / (PZ(L) - PZ(LEV)) + HTRC(L) = HEATFAC * (FNETC(L) - FNETC(LEV)) / (PZ(L) - PZ(LEV)) + 7000 CONTINUE + HTR(NLAYERS) = 0.0 + HTRC(NLAYERS) = 0.0 + + + END SUBROUTINE RTRN + +!--------------------------------------------------------------------------- + SUBROUTINE GASABS(kts,ktep1, & + COLDRY,COLH2O,COLCO2,COLO3,COLN2O,COLCH4, & + COLO2,CO2MULT, & + FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC, & + JP,JT,JT1,INDSELF,ITR,WX,PFRAC,TAUG, & + LAYTROP,LAYSWTCH,LAYLOW ) +!--------------------------------------------------------------------------- +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! This routine calculates the gaseous optical depths for all 16 longwave +! spectral bands. The optical depths are used to define the Pade +! approximation to the function of tau transition from tranparancy to +! opacity. This function, which varies from 0 to 1, is converted to an +! integer that will serve as an index for the lookup tables of tau +! transition function and transmittance used in the radiative transfer. +! These lookup tables are created on initialization in routine RRTMINIT. +!--------------------------------------------------------------------------- +! +! Definitions +! NGPT ! Total number of g-point subintervals +! MXLAY ! Maximum number of model layers +! SECANG ! Diffusivity angle for flux computation +! TAU(NGPT,MXLAY) ! Gaseous optical depths +! NLAYERS ! Number of model layers used in RRTM +! PAVEL(MXLAY) ! Model layer pressures (mb) +! PZ(0:MXLAY) ! Model level (interface) pressures (mb) +! TAVEL(MXLAY) ! Model layer temperatures (K) +! TZ(0:MXLAY) ! Model level (interface) temperatures (K) +! TBOUND ! Surface temperature (K) +! BPADE ! Pade approximation constant (=1./0.278) +! ITR(NGPT,MXLAY) ! Integer lookup table index +! +! Parameters + + IMPLICIT NONE + + REAL, PARAMETER :: SECANG=1.66 + + INTEGER, INTENT(IN ) :: kts,ktep1 + INTEGER, INTENT(IN ) :: LAYTROP,LAYSWTCH,LAYLOW + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: PFRAC + + REAL, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: TAUG + + REAL, DIMENSION( MAXXSEC,kts:ktep1 ), & + INTENT(IN ) :: WX + + INTEGER, DIMENSION( NGPT,kts:ktep1 ), & + INTENT(INOUT) :: ITR + + REAL, DIMENSION( kts:ktep1 ), INTENT(IN ) :: & + COLDRY, & + COLH2O, & + COLCO2, & + COLO3, & + COLN2O, & + COLCH4, & + COLO2, & + CO2MULT, & + FAC00, & + FAC01, & + FAC10, & + FAC11, & + FORFAC, & + SELFFAC, & + SELFFRAC + + INTEGER, DIMENSION( kts:ktep1 ), INTENT(INOUT) :: & + JP, & + JT, & + JT1, & + INDSELF + + INTEGER :: lay,ipr + REAL :: odepth,tff + +! This compiler directive was added to insure private common block storage +! in multi-tasked mode on a CRAY or SGI for all commons except those that +! carry constants. + +! ************************************************************************** + +! Calculate optical depth for each band + + CALL TAUGB1(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB2(kts,ktep1,COLDRY,COLH2O,FAC00,FAC01,FAC10,FAC11, & + FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB3(kts,ktep1,COLH2O,COLCO2,COLN2O,FAC00,FAC01,FAC10,FAC11,& + FORFAC,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB4(kts,ktep1,COLH2O,COLCO2,COLO3,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB5(kts,ktep1,COLH2O,COLCO2,COLO3,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,WX,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB6(kts,ktep1,COLH2O,CO2MULT,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,WX,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB7(kts,ktep1,COLH2O,COLO3,CO2MULT,FAC00,FAC01,FAC10,FAC11,& + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB8(kts,ktep1,COLH2O,COLO3,COLN2O,CO2MULT,FAC00,FAC01,FAC10,& + FAC11,SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,WX,PFRAC,TAUG,& + LAYSWTCH) + CALL TAUGB9(kts,ktep1,COLH2O,COLN2O,COLCH4,FAC00,FAC01,FAC10,FAC11,& + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP,LAYSWTCH,LAYLOW) + CALL TAUGB10(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11,JP,JT,JT1,& + PFRAC,TAUG,LAYTROP) + CALL TAUGB11(kts,ktep1,COLH2O,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB12(kts,ktep1,COLH2O,COLCO2,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB13(kts,ktep1,COLH2O,COLN2O,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB14(kts,ktep1,COLCO2,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB15(kts,ktep1,COLH2O,COLCO2,COLN2O,FAC00,FAC01,FAC10,FAC11,& + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + CALL TAUGB16(kts,ktep1,COLH2O,COLCH4,FAC00,FAC01,FAC10,FAC11, & + SELFFAC,SELFFRAC,JP,JT,JT1,INDSELF,PFRAC,TAUG, & + LAYTROP) + +! Compute the lookup table index from the Pade approximation of the +! tau transition function, which is derived from the optical depth. + + DO 6000 LAY = 1, NLAYERS + DO 5000 IPR = 1, NGPT + ODEPTH = SECANG * TAUG(IPR,LAY) + TFF = ODEPTH/(BPADE+ODEPTH) + IF (ODEPTH.LE.0.) TFF=0. + ITR(IPR,LAY) = INT(5.E3*TFF+0.5) + 5000 CONTINUE + 6000 CONTINUE + + END SUBROUTINE GASABS + +!==================================================================== + SUBROUTINE rrtminit( & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL :: pi + + PI = 2.*ASIN(1.) + FLUXFAC = PI * 2.D4 + NLAYERS = kme + + IF ( allowed_to_read ) THEN + CALL rrtm_lookuptable + ENDIF + + END SUBROUTINE rrtminit + + +! ************************************************************************** + SUBROUTINE rrtm_lookuptable +! ************************************************************************** + +USE module_wrf_error +USE module_dm +IMPLICIT NONE + +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: Michael J. Iacono; July, 1998 +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! This subroutine performs calculations necessary for the initialization +! of the LW model, RRTM. Lookup tables are computed for use in the LW +! radiative transfer, and input absorption coefficient data for each +! spectral band are reduced from 256 g-points to 140 for use in RRTM. +! ************************************************************************** + +! Definitions +! Arrays for 5000-point look-up tables: +! TAU Clear-sky optical depth (used in cloudy radiative transfer) +! TF Tau transition function; i.e. the transition of the Planck +! function from that for the mean layer temperature to that for +! the layer boundary temperature as a function of optical depth. +! The "linear in tau" method is used to make the table. +! TRANS Transmittance +! BPADE Inverse of the Pade approximation constant (= 1./0.278) + +! Local + INTEGER :: i,itre,igcsm,ibnd,igc,ind,ig,ipr,iprsm + REAL :: tfn,fp,rtfp,wtsum + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + REAL :: WTSM(MG) + CHARACTER*80 errmess + INTEGER rrtm_unit + + IF ( wrf_dm_on_monitor() ) THEN + DO i = 10,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + rrtm_unit = i + GOTO 2010 + ENDIF + ENDDO + rrtm_unit = -1 + 2010 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( rrtm_unit , IWORDSIZE ) + IF ( rrtm_unit < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_rrtm: rrtm_lookuptable: Can not '// & + 'find unused fortran unit to read in lookup table.' ) + ENDIF + +! start data 1 + +! ************************************************************************** +! RRTM Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for NCAR CCM: Michael J. Iacono; September, 1998 +! +! This routine contains 16 READ statements that include the +! absorption coefficients and other data for each of the 16 longwave +! spectral bands used in RRTM. Here, the data are defined for 16 +! g-points, or sub-intervals, per band. These data are combined and +! weighted using a mapping procedure in routine RRTMINIT to reduce +! the total number of g-points from 256 to 140 for use in the CCM. +! ************************************************************************** +#ifdef G95 +! JRB hardwire unit to 98 to ensure it is read big endian by g95 + rrtm_unit=98 +#endif + IF ( wrf_dm_on_monitor() ) THEN + OPEN(rrtm_unit,FILE='RRTM_DATA', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9009) + ENDIF + +! The array abscoefL1 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + + +! The array abscoefH1 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF1 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL1, abscoefH1, SELFREF1 + DM_BCAST_MACRO(abscoefL1) + DM_BCAST_MACRO(abscoefH1) + DM_BCAST_MACRO(SELFREF1) + +! ************************************************************************** +! The array abscoefL2 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array abscoefH2 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF2 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL2, abscoefH2, SELFREF2 + DM_BCAST_MACRO(abscoefL2) + DM_BCAST_MACRO(abscoefH2) + DM_BCAST_MACRO(SELFREF2) + +! ************************************************************************** + +! The array abscoefL3 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different water vapor to CO2 ratios, & +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, & +! JS=1 refers to dry air (eta = 0), JS = 10 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array abscoefH3 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs from 1 to 5, & +! and corresponds to different H2O to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = H2O/(H2O+RAT*CO2), & +! where RAT is the ratio of the integrated line strength in the band +! of CO2 to that of H2O. For instance, JS=1 refers to no H2O, & +! JS = 2 corresponds to eta = 0.25, etc. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF3 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL3, abscoefH3, SELFREF3 + DM_BCAST_MACRO(abscoefL3) + DM_BCAST_MACRO(abscoefH3) + DM_BCAST_MACRO(SELFREF3) + +! ************************************************************************** + +! The array abscoefL4 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 9 and corresponds to different water vapor to CO2 ratios, & +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, & +! JS=1 refers to dry air (eta = 0), JS = 9 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, & +! JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array abscoefH4 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of O3 to CO2. The first index in the array, JS, runs from 1 to 6, & +! and corresponds to different O3 to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = O3/(O3+RAT*H2O), & +! where RAT is the ratio of the integrated line strength in the band +! of CO2 to that of O3. For instance, JS=1 refers to no O3 (eta = 0) +! and JS = 5 corresponds to eta = 1.0. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF4 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL4, abscoefH4, SELFREF4 + DM_BCAST_MACRO(abscoefL4) + DM_BCAST_MACRO(abscoefH4) + DM_BCAST_MACRO(SELFREF4) + +! ************************************************************************** + +! The array abscoefL5 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 9 and corresponds to different water vapor to CO2 ratios, & +! as expressed through the binary species parameter eta, defined as +! eta = h2o/(h20 + (rat) * co2), where rat is the ratio of the integrated +! line strength in the band of co2 to that of h2o. For instance, & +! JS=1 refers to dry air (eta = 0), JS = 9 corresponds to eta = 1.0. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, & +! JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array abscoefH5 contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of O3 to CO2. The first index in the array, JS, runs from 1 to 5, & +! and corresponds to different O3 to CO2 ratios, as expressed through +! the binary species parameter eta, defined as eta = O3/(O3+RAT*CO2), & +! where RAT is the ratio of the integrated line strength in the band +! of co2 to that of O3. For instance, JS=1 refers to no O3 (eta = 0) +! and JS = 5 corresponds to eta = 1.0. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF5 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL5, abscoefH5, SELFREF5 + DM_BCAST_MACRO(abscoefL5) + DM_BCAST_MACRO(abscoefH5) + DM_BCAST_MACRO(SELFREF5) + +! ************************************************************************** + +! The array abscoefL6 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array SELFREF6 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL6, SELFREF6 + DM_BCAST_MACRO(abscoefL6) + DM_BCAST_MACRO(SELFREF6) + +! ************************************************************************** + +! The array abscoefL7 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array abscoefH7 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF7 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL7, abscoefH7, SELFREF7 + DM_BCAST_MACRO(abscoefL7) + DM_BCAST_MACRO(abscoefH7) + DM_BCAST_MACRO(SELFREF7) + +! ************************************************************************** + +! The array abscoefL8 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. +! The array abscoefL8 contains absorption coef5s at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the cooresponding TREF for this pressure level, & +! JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The second index, JP, runs from 1 to 13 and refers +! to the corresponding pressure level in PREF (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The third index, IG, goes from 1 to 16, & +! and tells us which "g-channel" the absorption coefficients are for. + + +! The array abscoefH8 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + +! +! SELFREF8 is the array for the self-continuum. +! + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL8, abscoefH8, SELFREF8 + DM_BCAST_MACRO(abscoefL8) + DM_BCAST_MACRO(abscoefH8) + DM_BCAST_MACRO(SELFREF8) + +! ************************************************************************** + +! The array abscoefL9 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 11, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array abscoefH9 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF9 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL9, abscoefH9, SELFREF9 + DM_BCAST_MACRO(abscoefL9) + DM_BCAST_MACRO(abscoefH9) + DM_BCAST_MACRO(SELFREF9) + +! ************************************************************************** + +! The array abscoefL10 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array abscoefH10 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL10, abscoefH10 + DM_BCAST_MACRO(abscoefL10) + DM_BCAST_MACRO(abscoefH10) + +! ************************************************************************** + +! The array abscoefL11 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array abscoefH11 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF11 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL11, abscoefH11, SELFREF11 + DM_BCAST_MACRO(abscoefL11) + DM_BCAST_MACRO(abscoefH11) + DM_BCAST_MACRO(SELFREF11) + +! ************************************************************************** + +! The array abscoefL12 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array SELFREF12 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL12, SELFREF12 + DM_BCAST_MACRO(abscoefL12) + DM_BCAST_MACRO(SELFREF12) + +! ************************************************************************** + +! The array abscoefL13 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array SELFREF13 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL13, SELFREF13 + DM_BCAST_MACRO(abscoefL13) + DM_BCAST_MACRO(SELFREF13) + +! ************************************************************************** + +! The array abscoefL14 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, & +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, & +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + + +! The array abscoefH14 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, & +! and tells us which g-interval the absorption coefficients are for. + + +! The array SELFREF14 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL14, abscoefH14, SELFREF14 + DM_BCAST_MACRO(abscoefL14) + DM_BCAST_MACRO(abscoefH14) + DM_BCAST_MACRO(SELFREF14) + +! ************************************************************************** + +! The array abscoefL15 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array SELFREF15 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL15, SELFREF15 + DM_BCAST_MACRO(abscoefL15) + DM_BCAST_MACRO(SELFREF15) + +! ************************************************************************** + +! The array abscoefL16 contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, & +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, & +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + + +! The array SELFREF16 contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, & +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, & +! etc. The second index runs over the g-channel (1 to 16). + + IF ( wrf_dm_on_monitor() ) READ (rrtm_unit,ERR=9010) abscoefL16, SELFREF16 + DM_BCAST_MACRO(abscoefL16) + DM_BCAST_MACRO(SELFREF16) + + IF ( wrf_dm_on_monitor() ) CLOSE (rrtm_unit) + +!----------------------------------------------------------------------- + + + +! Compute lookup tables for transmittance, tau transition function, +! and clear sky tau (for the cloudy sky radiative transfer). Tau is +! computed as a function of the tau transition function, transmittance +! is calculated as a function of tau, and the tau transition function +! is calculated using the linear in tau formulation at values of tau +! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables +! are computed at intervals of 0.001. The inverse of the constant used +! in the Pade approximation to the tau transition function is set to b. + + TAU(0) = 0.0 + TAU(5000) = 1.E10 + TRANS(0) = 1.0 + TRANS(5000) = 0.0 + TF(0) = 0.0 + TF(5000) = 1.0 + BPADE=1./0.278 + DO 1000 ITRE = 1,4999 + TFN = ITRE/5.E3 + TAU(ITRE) = BPADE*TFN/(1.-TFN) + TRANS(ITRE) = EXP(-TAU(ITRE)) + IF (TAU(ITRE).LT.0.1) THEN + TF(ITRE) = TAU(ITRE)/6. + ELSE + TF(ITRE) = 1.-2.*((1./TAU(ITRE))-(TRANS(ITRE)/(1.-TRANS(ITRE)))) + ENDIF + 1000 CONTINUE +! Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2) + CORR1(0) = 1. + CORR1(200) = 1. + CORR2(0) = 1. + CORR2(200) = 1. + DO 1200 I = 1,199 + FP = 0.005*FLOAT(I) + RTFP = SQRT(FP) + CORR1(I) = RTFP/FP + CORR2(I) = (1.-RTFP)/(1.-FP) + 1200 CONTINUE + +! Perform g-point reduction from 16 per band (256 total points) to +! a band dependant number (140 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + + IGCSM = 0 + DO 500 IBND = 1,NBANDS + IPRSM = 0 + IF (NGC(IBND).LT.16) THEN + DO 450 IGC = 1,NGC(IBND) + IGCSM = IGCSM + 1 + WTSUM = 0. + DO 420 IPR = 1, NGN(IGCSM) + IPRSM = IPRSM + 1 + WTSUM = WTSUM + WT(IPRSM) + 420 CONTINUE + WTSM(IGC) = WTSUM + 450 CONTINUE + DO 400 IG = 1,NG(IBND) + IND = (IBND-1)*16 + IG + RWGT(IND) = WT(IG)/WTSM(NGM(IND)) + 400 CONTINUE + ELSE + DO 300 IG = 1,NG(IBND) + IGCSM = IGCSM + 1 + IND = (IBND-1)*16 + IG + RWGT(IND) = 1.0 + 300 CONTINUE + ENDIF + 500 CONTINUE + +! Reduce g-points for relevant data in each LW spectral band. + + CALL CMBGB1 (abscoefL1, abscoefH1, SELFREF1, & + FRACREFA1, FRACREFB1, FORREF1, & + SELFREFC1, FORREFC1, FRACREFAC1, & + FRACREFBC1 & + ) + CALL CMBGB2 (abscoefL2, abscoefH2, SELFREF2, & + FRACREFA2, FRACREFB2, FORREF2, & + SELFREFC2, FORREFC2, FRACREFAC2, & + FRACREFBC2 & + ) + CALL CMBGB3 (abscoefL3, abscoefH3, SELFREF3, & + FRACREFA3, FRACREFB3, & + FORREF3, ABSN2OA3, ABSN2OB3, & + SELFREFC3, FORREFC3, & + ABSN2OAC3, ABSN2OBC3, FRACREFAC3, FRACREFBC3 & + ) + CALL CMBGB4 (abscoefL4, abscoefH4, SELFREF4, & + FRACREFA4, FRACREFB4, & + SELFREFC4, FRACREFAC4, FRACREFBC4 & + ) + CALL CMBGB5 (abscoefL5, abscoefH5, SELFREF5, & + FRACREFA5, FRACREFB5, CCL45, & + SELFREFC5, CCL4C5, FRACREFAC5, & + FRACREFBC5 & + ) + CALL CMBGB6 (abscoefL6, SELFREF6, & + FRACREFA6, ABSCO26, CFC11ADJ6, CFC126, & + SELFREFC6, ABSCO2C6, CFC11ADJC6, CFC12C6, & + FRACREFAC6 & + ) + CALL CMBGB7 (abscoefL7, abscoefH7, SELFREF7, & + FRACREFA7, FRACREFB7, ABSCO27, & + SELFREFC7, ABSCO2C7, FRACREFAC7, & + FRACREFBC7 & + ) + CALL CMBGB8 (abscoefL8, abscoefH8, SELFREF8, & + FRACREFA8, FRACREFB8, ABSCO2A8, ABSCO2B8, & + ABSN2OA8, ABSN2OB8, CFC128, CFC22ADJ8, & + SELFREFC8, ABSCO2AC8, ABSCO2BC8, & + ABSN2OAC8, ABSN2OBC8, CFC12C8, CFC22ADJC8, & + FRACREFAC8, FRACREFBC8 & + ) + CALL CMBGB9 (abscoefL9, abscoefH9, SELFREF9, & + FRACREFA9, FRACREFB9, ABSN2O9, & + SELFREFC9, ABSN2OC9, FRACREFAC9, & + FRACREFBC9 & + ) + CALL CMBGB10(abscoefL10, abscoefH10, & + FRACREFA10, FRACREFB10, & + FRACREFAC10, FRACREFBC10 & + ) + CALL CMBGB11(abscoefL11, abscoefH11, SELFREF11, & + FRACREFA11, FRACREFB11, & + SELFREFC11, FRACREFAC11, & + FRACREFBC11 & + ) + CALL CMBGB12(abscoefL12, SELFREF12, & + FRACREFA12, & + SELFREFC12, FRACREFAC12 & + ) + CALL CMBGB13(abscoefL13, SELFREF13, & + FRACREFA13, & + SELFREFC13, FRACREFAC13 & + ) + CALL CMBGB14(abscoefL14, abscoefH14, SELFREF14, & + FRACREFA14, FRACREFB14, & + SELFREFC14, FRACREFAC14, & + FRACREFBC14 & + ) + CALL CMBGB15(abscoefL15, SELFREF15, & + FRACREFA15, & + SELFREFC15, FRACREFAC15 & + ) + CALL CMBGB16(abscoefL16, SELFREF16, & + FRACREFA16, & + SELFREFC16, FRACREFAC16 & + ) + RETURN +9009 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtm: error opening RRTM_DATA on unit ',rrtm_unit + CALL wrf_error_fatal(errmess) + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtm: error reading RRTM_DATA on unit ',rrtm_unit + CALL wrf_error_fatal(errmess) + END SUBROUTINE rrtm_lookuptable + +!------------------------------------------------------------------ + +END MODULE module_ra_rrtm diff --git a/wrfv2_fire/phys/module_ra_sw.F b/wrfv2_fire/phys/module_ra_sw.F new file mode 100644 index 00000000..a5360043 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_sw.F @@ -0,0 +1,488 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_ra_sw + + REAL,PRIVATE,SAVE :: CSSCA + +CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO, & + rho_phy,T3D,QV3D,QC3D,QR3D, & + QI3D,QS3D,QG3D,P3D,pi3D,dz8w,GMT, & + R,CP,G,JULDAY, & + XTIME,DECLIN,SOLCON, & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + RADFRQ,ICLOUD,DEGRAD,warm_rain, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + cosz_urb2d,omg_urb2d & !Optional urban + ) +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + LOGICAL, INTENT(IN ) :: warm_rain + INTEGER, INTENT(IN ) :: icloud + + REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & + XTIME,DECLIN,SOLCON +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: P3D, & + pi3D, & + rho_phy, & + dz8w, & + T3D + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: pm2_5_dry, & + pm2_5_water, & + pm2_5_dry_ec + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATEN +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAT, & + XLONG, & + ALBEDO +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: GSW +! + REAL, INTENT(IN ) :: GMT,R,CP,G,dt +! + INTEGER, INTENT(IN ) :: JULDAY +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(IN ) :: & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D + + LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG + +! LOCAL VARS + + REAL, DIMENSION( kts:kte ) :: & + TTEN1D, & + RHO01D, & + P1D, & + DZ, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + QS1D, & + QG1D +! + REAL:: XLAT0,XLONG0,ALB0,GSW0 + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban + REAL :: COSZ, OMG !urban +! + INTEGER :: i,j,K,NK + LOGICAL :: predicate + real :: aer_dry1(kts:kte),aer_water1(kts:kte) + +!------------------------------------------------------------------ + j_loop: DO J=jts,jte + i_loop: DO I=its,ite + +! reverse vars + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + QG1D(K)=0. + ENDDO + + DO K=kts,kte + NK=kme-1-K+kms + TTEN1D(K)=0. + + T1D(K)=T3D(I,NK,J) + P1D(K)=P3D(I,NK,J) + RHO01D(K)=rho_phy(I,NK,J) + DZ(K)=dz8w(I,NK,J) + ENDDO + + IF( PRESENT(pm2_5_dry) .AND. PRESENT(pm2_5_water) )THEN + DO K=kts,kte + NK=kme-1-K+kms + aer_dry1(k) = pm2_5_dry(i,nk,j) + aer_water1(k) = pm2_5_water(i,nk,j) + ENDDO + ELSE + DO K=kts,kte + aer_dry1(k) = 0. + aer_water1(k) = 0. + ENDDO + ENDIF + + IF (PRESENT(F_QV) .AND. PRESENT(QV3D)) THEN + IF (F_QV) THEN + DO K=kts,kte + NK=kme-1-K+kms + QV1D(K)=QV3D(I,NK,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF (F_QC) THEN + DO K=kts,kte + NK=kme-1-K+kms + QC1D(K)=QC3D(I,NK,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF (F_QR) THEN + DO K=kts,kte + NK=kme-1-K+kms + QR1D(K)=QR3D(I,NK,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + +! + IF ( PRESENT( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + + IF ( predicate .AND. PRESENT( QI3D ) ) THEN + DO K=kts,kte + NK=kme-1-K+kms + QI1D(K)=QI3D(I,NK,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ELSE + IF (.not. warm_rain) THEN + DO K=kts,kte + IF(T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QC1D(K)=0. + QS1D(K)=QR1D(K) + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + NK=kme-1-K+kms + QS1D(K)=QS3D(I,NK,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + NK=kme-1-K+kms + QG1D(K)=QG3D(I,NK,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + + XLAT0=XLAT(I,J) + XLONG0=XLONG(I,J) + ALB0=ALBEDO(I,J) + + CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & + T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & + XTIME,GMT,RHO01D,DZ, & + R,CP,G,DECLIN,SOLCON, & + COSZ, OMG, & !urban + RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & + kts,kte ) + + IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN + COSZ_URB2D(I,J)=COSZ !urban + OMG_URB2D(I,J)=OMG !urban + ENDIF + + GSW(I,J)=GSW0 + DO K=kts,kte + NK=kme-1-K+kms + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN1D(NK)/pi3D(I,K,J) + ENDDO +! + ENDDO i_loop + ENDDO j_loop + + END SUBROUTINE SWRAD + +!------------------------------------------------------------------ + SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO, & + T,QV,QC,QR,QI,QS,QG,P, & + XTIME, GMT, RHO0, DZ, & + R,CP,G,DECLIN,SOLCON, & + COSZ, OMG, & !urban + RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & + kts,kte ) +!------------------------------------------------------------------ +! TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR +! AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS, +! 1984) +! CHANGES: +! REDUCE EFFECTS OF ICE CLOUDS AND PRECIP ON LIQUID WATER PATH +! ADD EFFECT OF GRAUPEL +!------------------------------------------------------------------ + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: kts,kte +! + REAL, DIMENSION( kts:kte ), INTENT(IN ) :: & + RHO0, & + T, & + P, & + DZ, & + QV, & + QC, & + QR, & + QI, & + QS, & + QG + + REAL, DIMENSION( kts:kte ), INTENT(INOUT):: TTEN +! + REAL, INTENT(IN ) :: XTIME,GMT,R,CP,G,DECLIN, & + SOLCON,XLAT,XLONG,ALBEDO, & + RADFRQ, DEGRAD +! + INTEGER, INTENT(IN) :: icloud + REAL, INTENT(INOUT) :: GSW +! +! LOCAL VARS +! + REAL, DIMENSION( kts:kte+1 ) :: SDOWN + + REAL, DIMENSION( kts:kte ) :: XLWP, & + XATP, & + XWVP, & + aer_dry1,aer_water1, & + RO +! + REAL, DIMENSION( 4, 5 ) :: ALBTAB, & + ABSTAB + + REAL, DIMENSION( 4 ) :: XMUVAL + + REAL, INTENT(OUT) :: COSZ !urban + REAL, INTENT(OUT) :: OMG !urban + + REAL :: beta + +!------------------------------------------------------------------ + + DATA ALBTAB/0.,0.,0.,0., & + 69.,58.,40.,15., & + 90.,80.,70.,60., & + 94.,90.,82.,78., & + 96.,92.,85.,80./ + + DATA ABSTAB/0.,0.,0.,0., & + 0.,2.5,4.,5., & + 0.,2.6,7.,10., & + 0.,3.3,10.,14., & + 0.,3.7,10.,15./ + + DATA XMUVAL/0.,0.2,0.5,1.0/ + + REAL :: bext340, absc, alba, alw, csza,dabsa,dsca,dabs + REAL :: bexth2o, dscld, hrang,ff,oldalb,oldabs,oldabc + REAL :: soltop, totabs, tloctm, ugcm, uv,xabs,xabsa,wv + REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj + REAL :: xxlat,ww + INTEGER :: iil,ii,jjl,ju,k,iu + + GSW=0.0 + bext340=5.E-6 + bexth2o=5.E-6 + SOLTOP=SOLCON + XT24=MOD(XTIME+RADFRQ*0.5,1440.) + TLOCTM=GMT+XT24/60.+XLONG/15. + HRANG=15.*(TLOCTM-12.)*DEGRAD + XXLAT=XLAT*DEGRAD + CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) + + COSZ = CSZA !urban + OMG = HRANG !urban + +! RETURN IF NIGHT + IF(CSZA.LE.1.E-9)GOTO 7 +! + DO K=kts, kte + +! P in the unit of 10mb + RO(K)=P(K)/(R*T(K)) + XWVP(K)=RO(K)*QV(K)*DZ(K)*1000. +! KG/M**2 + XATP(K)=RO(K)*DZ(K) + ENDDO +! +! G/M**2 +! REDUCE WEIGHT OF LIQUID AND ICE IN SHORT-WAVE SCHEME +! ADD GRAUPEL EFFECT (ASSUMED SAME AS RAIN) +! + IF (ICLOUD.EQ.0)THEN + DO K=kts, kte + XLWP(K)=0. + ENDDO + ELSE + DO K=kts, kte + XLWP(K)=RO(K)*1000.*DZ(K)*(QC(K)+0.1*QI(K)+0.05* & + QR(K)+0.02*QS(K)+0.05*QG(K)) + ENDDO + ENDIF +! + XMU=CSZA + SDOWN(1)=SOLTOP*XMU +! SET WW (G/M**2) LIQUID WATER PATH INTEGRATED DOWN +! SET UV (G/M**2) WATER VAPOR PATH INTEGRATED DOWN + WW=0. + UV=0. + OLDALB=0. + OLDABC=0. + TOTABS=0. +! CONTRIBUTIONS DUE TO CLEAR AIR AND CLOUD + DSCA=0. + DABS=0. + DSCLD=0. +! +! CONTRIBUTION DUE TO AEROSOLS (FOR CHEMISTRY) + DABSA=0. +! + DO 200 K=kts,kte + WW=WW+XLWP(K) + UV=UV+XWVP(K) +! WGM IS WW/COS(THETA) (G/M**2) +! UGCM IS UV/COS(THETA) (G/CM**2) + WGM=WW/XMU + UGCM=UV*0.0001/XMU +! + OLDABS=TOTABS +! WATER VAPOR ABSORPTION AS IN LACIS AND HANSEN (1974) + TOTABS=2.9*UGCM/((1.+141.5*UGCM)**0.635+5.925*UGCM) +! APPROXIMATE RAYLEIGH + AEROSOL SCATTERING +! XSCA=1.E-5*XATP(K)/XMU +! XSCA=(1.E-5*XATP(K)+aer_dry1(K)*bext340+aer_water1(K)*bexth2o)/XMU + beta=0.4*(1.0-XMU)+0.1 +! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT + XSCA=(cssca*XATP(K)+beta*aer_dry1(K)*bext340*DZ(K) & + +beta*aer_water1(K)*bexth2o*DZ(K))/XMU + +! LAYER VAPOR ABSORPTION DONE FIRST + XABS=(TOTABS-OLDABS)*(SDOWN(1)-DSCLD-DSCA-DABSA)/SDOWN(K) +!rs AEROSOL ABSORB (would be elemental carbon). So far XABSA = 0. + XABSA=0. + IF(XABS.LT.0.)XABS=0. +! + ALW=ALOG10(WGM+1.) + IF(ALW.GT.3.999)ALW=3.999 +! + DO II=1,3 + IF(XMU.GT.XMUVAL(II))THEN + IIL=II + IU=II+1 + XI=(XMU-XMUVAL(II))/(XMUVAL(II+1)-XMUVAL(II))+FLOAT(IIL) + ENDIF + ENDDO +! + JJL=IFIX(ALW)+1 + JU=JJL+1 + YJ=ALW+1. +! CLOUD ALBEDO + ALBA=(ALBTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & + +ALBTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & + +ALBTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & + +ALBTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & + /((IU-IIL)*(JU-JJL)) +! CLOUD ABSORPTION + ABSC=(ABSTAB(IU,JU)*(XI-IIL)*(YJ-JJL) & + +ABSTAB(IIL,JU)*(IU-XI)*(YJ-JJL) & + +ABSTAB(IU,JJL)*(XI-IIL)*(JU-YJ) & + +ABSTAB(IIL,JJL)*(IU-XI)*(JU-YJ)) & + /((IU-IIL)*(JU-JJL)) +! LAYER ALBEDO AND ABSORPTION + XALB=(ALBA-OLDALB)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) + XABSC=(ABSC-OLDABC)*(SDOWN(1)-DSCA-DABS)/SDOWN(K) + IF(XALB.LT.0.)XALB=0. + IF(XABSC.LT.0.)XABSC=0. + DSCLD=DSCLD+(XALB+XABSC)*SDOWN(K)*0.01 + DSCA=DSCA+XSCA*SDOWN(K) + DABS=DABS+XABS*SDOWN(K) + DABSA=DABSA+XABSA*SDOWN(K) + OLDALB=ALBA + OLDABC=ABSC +! LAYER TRANSMISSIVITY + TRANS0=100.-XALB-XABSC-XABS*100.-XSCA*100. + IF(TRANS0.LT.1.)THEN + FF=99./(XALB+XABSC+XABS*100.+XSCA*100.) + XALB=XALB*FF + XABSC=XABSC*FF + XABS=XABS*FF + XSCA=XSCA*FF + TRANS0=1. + ENDIF + SDOWN(K+1)=AMAX1(1.E-9,SDOWN(K)*TRANS0*0.01) + TTEN(K)=SDOWN(K)*(XABSC+XABS*100.+XABSA*100.)*0.01/( & + RO(K)*CP*DZ(K)) + 200 CONTINUE +! + GSW=(1.-ALBEDO)*SDOWN(kte+1) + + 7 CONTINUE +! + END SUBROUTINE SWPARA + +!==================================================================== + SUBROUTINE swinit(swrad_scat, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , INTENT(IN) :: swrad_scat + +! CSSCA - CLEAR-SKY SCATTERING SET FROM NAMELIST SWRAD_SCAT + cssca = swrad_scat * 1.e-5 + + END SUBROUTINE swinit + +END MODULE module_ra_sw diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F new file mode 100644 index 00000000..165d0d88 --- /dev/null +++ b/wrfv2_fire/phys/module_radiation_driver.F @@ -0,0 +1,1279 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! +MODULE module_radiation_driver +CONTAINS +!BOP +! !IROUTINE: radiation_driver - interface to radiation physics options + +! !INTERFACE: + SUBROUTINE radiation_driver ( & + itimestep,dt ,lw_physics,sw_physics ,NPHS & + ,RTHRATENLW ,RTHRATENSW ,RTHRATEN & + ,ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC & ! Optional + ,ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC & ! Optional + ,ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC & ! Optional + ,ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC & ! Optional + , SWUPT, SWUPTC, SWDNT, SWDNTC & ! Optional + , SWUPB, SWUPBC, SWDNB, SWDNBC & ! Optional + , LWUPT, LWUPTC, LWDNT, LWDNTC & ! Optional + , LWUPB, LWUPBC, LWDNB, LWDNBC & ! Optional + ,LWCF,SWCF,OLR & ! Optional + ,GLW, GSW, SWDOWN, XLAT, XLONG, ALBEDO & + ,EMISS, rho, p8w, p , pi , dz8w ,t, t8w, GMT & + ,XLAND, XICE, TSK, HTOP,HBOT,HTOPR,HBOTR, CUPPT, VEGFRA, SNOW & + ,julyr, JULDAY, julian, xtime, RADT, STEPRA, ICLOUD, warm_rain & + ,declin_urb,COSZ_URB2D, omg_urb2d & !Optional urban + ,ra_call_offset,RSWTOA,RLWTOA, CZMEAN & + ,CFRACL, CFRACM, CFRACH & + ,ACFRST,NCFRST,ACFRCV,NCFRCV,SWDOWNC & + ,z & + ,levsiz, n_ozmixm, n_aerosolc, paerlev & + ,cam_abs_dim1, cam_abs_dim2, cam_abs_freq_s & + ,ozmixm,pin & ! Optional + ,m_ps_1,m_ps_2,aerosolc_1,aerosolc_2,m_hybi0 & ! Optional + ,abstot, absnxt, emstot & ! Optional + ,taucldi, taucldc & ! Optional + ,ids, ide, jds, jde, kds, kde & + ,ims, ime, jms, jme, kms, kme & + ,i_start, i_end & + ,j_start, j_end & + ,kts, kte & + ,num_tiles & + ,qv,qc,qr,qi,qs,qg,qndrop & + ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop & + ,CLDFRA ,Pb & + ,f_ice_phy,f_rain_phy & + ,pm2_5_dry, pm2_5_water, pm2_5_dry_ec & + ,tauaer300, tauaer400, tauaer600, tauaer999 & ! jcb + ,gaer300, gaer400, gaer600, gaer999 & ! jcb + ,waer300, waer400, waer600, waer999 & ! jcb + ,qc_adjust ,qi_adjust & ! jm + ,cu_rad_feedback, aer_ra_feedback & ! jm + + ) + +!------------------------------------------------------------------------- + +! !USES: + USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME & + ,SWRADSCHEME, GSFCSWSCHEME & + ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME + USE module_model_constants + USE module_wrf_error + +! *** add new modules of schemes here + + USE module_ra_sw + USE module_ra_gsfcsw + USE module_ra_rrtm + USE module_ra_cam + USE module_ra_gfdleta + + ! This driver calls subroutines for the radiation parameterizations. + ! + ! short wave radiation choices: + ! 1. swrad (19??) + ! + ! long wave radiation choices: + ! 1. rrtmlwrad + ! +!---------------------------------------------------------------------- + IMPLICIT NONE +! +! +! Radiation_driver is the WRF mediation layer routine that provides the interface to +! to radiation physics packages in the WRF model layer. The radiation +! physics packages to call are chosen by setting the namelist variable +! (Rconfig entry in Registry) to the integer value assigned to the +! particular package (package entry in Registry). For example, if the +! namelist variable ra_lw_physics is set to 1, this corresponds to the +! Registry Package entry for swradscheme. Note that the Package +! names in the Registry are defined constants (frame/module_state_description.F) +! in the CASE statements in this routine. +! +! Among the arguments is moist, a four-dimensional scalar array storing +! a variable number of moisture tracers, depending on the physics +! configuration for the WRF run, as determined in the namelist. The +! highest numbered index of active moisture tracers the integer argument +! n_moist (note: the number of tracers at run time is the quantity +! n_moist - PARAM_FIRST_SCALAR + 1 , not n_moist. Individual tracers +! may be indexed from moist by the Registry name of the tracer prepended +! with P_; for example P_QC is the index of cloud water. An index +! represents a valid, active field only if the index is greater than +! or equal to PARAM_FIRST_SCALAR. PARAM_FIRST_SCALAR and the individual +! indices for each tracer is defined in module_state_description and +! set in set_scalar_indices_from_config defined in frame/module_configure.F. +! +! Physics drivers in WRF 2.0 and higher, originally model-layer +! routines, have been promoted to mediation layer routines and they +! contain OpenMP threaded loops over tiles. Thus, physics drivers +! are called from single-threaded regions in the solver. The physics +! routines that are called from the physics drivers are model-layer +! routines and fully tile-callable and thread-safe. +! +! +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! . +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Grid structure in physics part of WRF +! +!------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!================================================================== +! Definitions +!----------- +! Theta potential temperature (K) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +!----------------------------------------------------------------- +!-- PM2_5_DRY Dry PM2.5 aerosol mass for all species (ug m^-3) +!-- PM2_5_WATER PM2.5 water mass (ug m^-3) +!-- PM2_5_DRY_EC Dry PM2.5 elemental carbon aersol mass (ug m^-3) +!-- RTHRATEN Theta tendency +! due to radiation (K/s) +!-- RTHRATENLW Theta tendency +! due to long wave radiation (K/s) +!-- RTHRATENSW Theta temperature tendency +! due to short wave radiation (K/s) +!-- dt time step (s) +!-- itimestep number of time steps +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- GSW net short wave flux at ground surface (W/m^2) +!-- SWDOWN downward short wave flux at ground surface (W/m^2) +!-- SWDOWNC clear-sky downward short wave flux at ground surface (W/m^2; optional; for AQ) +!-- RLWTOA upward long wave at top of atmosphere (w/m2) +!-- RSWTOA upward short wave at top of atmosphere (w/m2) +!-- XLAT latitude, south is negative (degree) +!-- XLONG longitude, west is negative (degree) +!-- ALBEDO albedo (between 0 and 1) +!-- CLDFRA cloud fraction (between 0 and 1) +!-- EMISS surface emissivity (between 0 and 1) +!-- rho_phy density (kg/m^3) +!-- rr dry air density (kg/m^3) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- n_moist number of moisture species +!-- qndrop Cloud droplet number (#/kg) +!-- p8w pressure at full levels (Pa) +!-- p_phy pressure (Pa) +!-- Pb base-state pressure (Pa) +!-- pi_phy exner function (dimensionless) +!-- dz8w dz between full levels (m) +!-- t_phy temperature (K) +!-- t8w temperature at full levels (K) +!-- GMT Greenwich Mean Time Hour of model start (hour) +!-- JULDAY the initial day (Julian day) +!-- RADT time for calling radiation (min) +!-- ra_call_offset -1 (old) means usually just before output, 0 after +!-- DEGRAD conversion factor for +! degrees to radians (pi/180.) (rad/deg) +!-- DPD degrees per day for earth's +! orbital position (deg/day) +!-- R_d gas constant for dry air (J/kg/K) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- G acceleration due to gravity (m/s^2) +!-- rvovrd R_v divided by R_d (dimensionless) +!-- XTIME time since simulation start (min) +!-- DECLIN solar declination angle (rad) +!-- SOLCON solar constant (W/m^2) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- i_start start indices for i in tile +!-- i_end end indices for i in tile +!-- j_start start indices for j in tile +!-- j_end end indices for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!-- num_tiles number of tiles +! +!================================================================== +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + kts,kte, & + num_tiles + + INTEGER, INTENT(IN) :: lw_physics, sw_physics + + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, INTENT(IN ) :: STEPRA,ICLOUD,ra_call_offset + INTEGER, INTENT(IN ) :: levsiz, n_ozmixm + INTEGER, INTENT(IN ) :: paerlev, n_aerosolc, cam_abs_dim1, cam_abs_dim2 + REAL, INTENT(IN ) :: cam_abs_freq_s + + LOGICAL, INTENT(IN ) :: warm_rain + + REAL, INTENT(IN ) :: RADT + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAND, & + XICE, & + TSK, & + VEGFRA, & + SNOW + REAL, DIMENSION( ims:ime, levsiz, jms:jme, n_ozmixm ), OPTIONAL, & + INTENT(IN ) :: OZMIXM + + REAL, DIMENSION(levsiz), OPTIONAL, INTENT(IN ) :: PIN + + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(IN ) :: m_ps_1,m_ps_2 + REAL, DIMENSION( ims:ime, paerlev, jms:jme, n_aerosolc ), OPTIONAL, & + INTENT(IN ) :: aerosolc_1, aerosolc_2 + REAL, DIMENSION(paerlev), OPTIONAL, & + INTENT(IN ) :: m_hybi0 + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: HTOP, & + HBOT, & + HTOPR, & + HBOTR, & + CUPPT + + INTEGER, INTENT(IN ) :: julyr +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: dz8w, & + z, & + p8w, & + p, & + pi, & + t, & + t8w, & + rho +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb + gaer300,gaer400,gaer600,gaer999, & ! jcb + waer300,waer400,waer600,waer999, & ! jcb + qc_adjust, qi_adjust + + LOGICAL, OPTIONAL :: cu_rad_feedback + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback + +! +! variables for aerosols (only if running with chemistry) +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: pm2_5_dry, & + pm2_5_water, & + pm2_5_dry_ec +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATEN, & + RTHRATENLW, & + RTHRATENSW + +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & +! INTENT(INOUT) :: SWUP, & +! SWDN, & +! SWUPCLEAR, & +! SWDNCLEAR, & +! LWUP, & +! LWDN, & +! LWUPCLEAR, & +! LWDNCLEAR + + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::& + ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC, & + ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC, & + ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC, & + ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::& + SWUPT, SWUPTC, SWDNT, SWDNTC, & + SWUPB, SWUPBC, SWDNB, SWDNBC, & + LWUPT, LWUPTC, LWDNT, LWDNTC, & + LWUPB, LWUPBC, LWDNB, LWDNBC + + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL , & + INTENT(INOUT) :: SWCF, & + LWCF, & + OLR + + +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAT, & + XLONG, & + ALBEDO, & + EMISS +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: GSW, & + GLW + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: SWDOWN +! + REAL, INTENT(IN ) :: GMT,dt, & + julian, xtime +! + INTEGER, INTENT(IN ) :: JULDAY, itimestep + + INTEGER,INTENT(IN) :: NPHS + REAL, DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: & + CFRACH, & !Added + CFRACL, & !Added + CFRACM, & !Added + CZMEAN !Added + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: & + RLWTOA, & !Added + RSWTOA, & !Added + ACFRST, & !Added + ACFRCV !Added + + INTEGER,DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: & + NCFRST, & !Added + NCFRCV !Added +! Optional (only used by CAM lw scheme) + + REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2, jms:jme ), OPTIONAL ,& + INTENT(INOUT) :: abstot + REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1, jms:jme ), OPTIONAL ,& + INTENT(INOUT) :: absnxt + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,& + INTENT(INOUT) :: emstot + +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: CLDFRA + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, & + INTENT(OUT) :: SWDOWNC +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(INOUT ) :: & + pb & + ,qv,qc,qr,qi,qs,qg,qndrop + + LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: taucldi,taucldc + +! LOCAL VAR + + REAL, DIMENSION( ims:ime, jms:jme ) :: GLAT,GLON + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: CEMISS + REAL, DIMENSION( ims:ime, jms:jme ) :: coszr + + REAL :: DECLIN,SOLCON + INTEGER :: i,j,k,its,ite,jts,jte,ij + INTEGER :: STEPABS + LOGICAL :: gfdl_lw,gfdl_sw + LOGICAL :: doabsems + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + REAL :: OBECL,SINOB,SXLONG,ARG,DECDEG, & + DJUL,RJUL,ECCFAC + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_temp,qc_temp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_save,qc_save + +!------------------------------------------------------------------ +! urban related variables are added to declaration +!------------------------------------------------- + REAL, OPTIONAL, INTENT(OUT) :: DECLIN_URB !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: omg_urb2d !urban +!------------------------------------------------------------------ + + if (lw_physics .eq. 0 .and. sw_physics .eq. 0) return + +! ra_call_offset = -1 gives old method where radiation may be called just before output +! ra_call_offset = 0 gives new method where radiation may be called just after output +! and is also consistent with removal of offset in new XTIME + Radiation_step: IF (itimestep .eq. 1 .or. mod(itimestep,STEPRA) .eq. 1 + ra_call_offset) THEN + +! CAM-specific additional radiation frequency - cam_abs_freq_s (=21600s by default) + STEPABS = nint(cam_abs_freq_s/(dt*STEPRA))*STEPRA + IF (itimestep .eq. 1 .or. mod(itimestep,STEPABS) .eq. 1 + ra_call_offset) THEN + doabsems = .true. + ELSE + doabsems = .false. + ENDIF + + gfdl_lw = .false. + gfdl_sw = .false. + +!--------------- + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) + + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + +! initialize data + + DO j=jts,jte + DO i=its,ite + GSW(I,J)=0. + GLW(I,J)=0. + SWDOWN(I,J)=0. + GLAT(I,J)=XLAT(I,J)*DEGRAD + GLON(I,J)=XLONG(I,J)*DEGRAD + ENDDO + ENDDO + + DO j=jts,jte + DO k=kts,kte+1 + DO i=its,ite + RTHRATEN(I,K,J)=0. +! SWUP(I,K,J) = 0.0 +! SWDN(I,K,J) = 0.0 +! SWUPCLEAR(I,K,J) = 0.0 +! SWDNCLEAR(I,K,J) = 0.0 +! LWUP(I,K,J) = 0.0 +! LWDN(I,K,J) = 0.0 +! LWUPCLEAR(I,K,J) = 0.0 +! LWDNCLEAR(I,K,J) = 0.0 + CEMISS(I,K,J)=0.0 + ENDDO + ENDDO + ENDDO + +! temporarily modify hydrometeors (currently only done for GD scheme and WRF-Chem) +! + IF ( PRESENT( cu_rad_feedback ) ) THEN + IF ( PRESENT( qc ) .AND. PRESENT( qc_adjust ) .AND. cu_rad_feedback ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc_save(i,k,j) = qc(i,k,j) + qc(i,k,j) = qc(i,k,j) + qc_adjust(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF ( PRESENT( qi ) .AND. PRESENT( qi_adjust ) .AND. cu_rad_feedback ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qi_save(i,k,j) = qi(i,k,j) + qi(i,k,j) = qi(i,k,j) + qi_adjust(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + +! Fill temporary water variable depending on micro package (tgs 25 Apr 2006) + if(PRESENT(qc) .and. PRESENT(F_QC)) then + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc_temp(I,K,J)=qc(I,K,J) + ENDDO + ENDDO + ENDDO + else + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc_temp(I,K,J)=0. + ENDDO + ENDDO + ENDDO + endif + if(PRESENT(qr) .and. PRESENT(F_QR)) then + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc_temp(I,K,J) = qc_temp(I,K,J) + qr(I,K,J) + ENDDO + ENDDO + ENDDO + endif + +!--------------- +! Calculate constant for short wave radiation + + CALL radconst(XTIME,DECLIN,SOLCON,JULIAN, & + DEGRAD,DPD ) + + if(present(DECLIN_URB))DECLIN_URB=DECLIN ! urban + + lwrad_cldfra_select: SELECT CASE(lw_physics) + + CASE (GFDLLWSCHEME) + +!-- Do nothing, since cloud fractions (with partial cloudiness effects) +!-- are defined in GFDL LW/SW schemes and do not need to be initialized. + + CASE (CAMLWSCHEME) + + IF ( PRESENT ( CLDFRA ) .AND. & + PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN +! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998) + + CALL cal_cldfra2(CLDFRA,qv,qc,qi,qs, & + F_QV,F_QC,F_QI,F_QS,t,p, & + F_ICE_PHY,F_RAIN_PHY, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + + CASE DEFAULT + + IF ( PRESENT ( CLDFRA ) .AND. & + PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + CALL cal_cldfra(CLDFRA,qc,qi,F_QC,F_QI, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + + END SELECT lwrad_cldfra_select + +!pjj/cray Cray X1 cannot print from threaded region +#ifndef crayx1 + WRITE(wrf_err_message,*)'SOLCON=',SOLCON,DECLIN,XTIME + CALL wrf_debug(50,wrf_err_message) +#endif + + lwrad_select: SELECT CASE(lw_physics) + + CASE (RRTMSCHEME) + CALL wrf_debug (100, 'CALL rrtm') + + CALL RRTMLWRAD( & + RTHRATEN=RTHRATEN,GLW=GLW,OLR=RLWTOA,EMISS=EMISS & + ,QV3D=QV & + ,QC3D=QC & + ,QR3D=QR & + ,QI3D=QI & + ,QS3D=QS & + ,QG3D=QG & + ,P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,T3D=t & + ,T8W=t8w,RHO3D=rho, CLDFRA3D=CLDFRA,R=R_d,G=G & + ,F_QV=F_QV,F_QC=F_QC,F_QR=F_QR & + ,F_QI=F_QI,F_QS=F_QS,F_QG=F_QG & + ,ICLOUD=icloud,WARM_RAIN=warm_rain & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + CASE (GFDLLWSCHEME) + + CALL wrf_debug (100, 'CALL gfdllw') + + IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND. & + PRESENT(F_QS) .AND. PRESENT(qs) .AND. & + PRESENT(qv) .AND. PRESENT(qc) ) THEN + IF ( F_QV .AND. F_QC .AND. F_QS) THEN + gfdl_lw = .true. + CALL ETARA( & + DT=dt,XLAND=xland & + ,P8W=p8w,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,T=t & + ,QV=qv,QW=qc_temp,QI=qi,QS=qs & + ,TSK2D=tsk,GLW=GLW,RSWIN=SWDOWN,GSW=GSW & + ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=pi & + ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot & + ,HBOTR=hbotr, HTOPR=htopr & + ,ALBEDO=albedo,CUPPT=cuppt & + ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt & + ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep & + ,XTIME=xtime,JULIAN=julian & + ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & + ,JULYR=julyr,JULDAY=julday & + ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & + ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & + ,ACFRST=acfrst,NCFRST=ncfrst & + ,ACFRCV=acfrcv,NCFRCV=ncfrcv & + ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean & + ,THRATEN=rthraten,THRATENLW=rthratenlw & + ,THRATENSW=rthratensw & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Can not call ETARA (1a). Missing moisture fields.') + ENDIF + ELSE + CALL wrf_error_fatal('Can not call ETARA (1b). Missing moisture fields.') + ENDIF + CASE (CAMLWSCHEME) + CALL wrf_debug(100, 'CALL camrad lw') + IF(cam_abs_dim1 .ne. 4 .or. cam_abs_dim2 .ne. kde .or. & + paerlev .ne. 29 .or. levsiz .ne. 59 )THEN + WRITE( wrf_err_message , * ) & +'set paerlev=29, levsiz=59, cam_abs_dim1=4, and cam_abs_dim2=number of levels (e_vert) in physics namelist for CAM radiation' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF ( PRESENT( OZMIXM ) .AND. PRESENT( PIN ) .AND. & + PRESENT(M_PS_1) .AND. PRESENT(M_PS_2) .AND. & + PRESENT(M_HYBI0) .AND. PRESENT(AEROSOLC_1) & + .AND. PRESENT(AEROSOLC_2) ) THEN + CALL CAMRAD(RTHRATENLW=RTHRATEN,RTHRATENSW=RTHRATENSW, & + SWUPT=SWUPT,SWUPTC=SWUPTC, & + SWDNT=SWDNT,SWDNTC=SWDNTC, & + LWUPT=LWUPT,LWUPTC=LWUPTC, & + LWDNT=LWDNT,LWDNTC=LWDNTC, & + SWUPB=SWUPB,SWUPBC=SWUPBC, & + SWDNB=SWDNB,SWDNBC=SWDNBC, & + LWUPB=LWUPB,LWUPBC=LWUPBC, & + LWDNB=LWDNB,LWDNBC=LWDNBC, & + SWCF=SWCF,LWCF=LWCF,OLR=RLWTOA,CEMISS=CEMISS, & + TAUCLDC=TAUCLDC,TAUCLDI=TAUCLDI,COSZR=COSZR, & + GSW=GSW,GLW=GLW,XLAT=XLAT,XLONG=XLONG, & + ALBEDO=ALBEDO,t_phy=t,TSK=TSK,EMISS=EMISS & + ,QV3D=qv & + ,QC3D=qc & + ,QR3D=qr & + ,QI3D=qi & + ,QS3D=qs & + ,QG3D=qg & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & + ,f_ice_phy=f_ice_phy,f_rain_phy=f_rain_phy & + ,p_phy=p,p8w=p8w,z=z,pi_phy=pi,rho_phy=rho, & + dz8w=dz8w, & + CLDFRA=CLDFRA,XLAND=XLAND,XICE=XICE,SNOW=SNOW, & + ozmixm=ozmixm,pin0=pin,levsiz=levsiz, & + num_months=n_ozmixm, & + m_psp=m_ps_1,m_psn=m_ps_2,aerosolcp=aerosolc_1, & + aerosolcn=aerosolc_2,m_hybi0=m_hybi0, & + paerlev=paerlev, naer_c=n_aerosolc, & + cam_abs_dim1=cam_abs_dim1, cam_abs_dim2=cam_abs_dim2, & + GMT=GMT,JULDAY=JULDAY,JULIAN=JULIAN,DT=DT,XTIME=XTIME,DECLIN=DECLIN, & + SOLCON=SOLCON,RADT=RADT,DEGRAD=DEGRAD,n_cldadv=3 & + ,abstot_3d=abstot,absnxt_3d=absnxt,emstot_3d=emstot & + ,doabsems=doabsems & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' ) + ENDIF + CASE DEFAULT + + WRITE( wrf_err_message , * ) 'The longwave option does not exist: lw_physics = ', lw_physics + CALL wrf_error_fatal ( wrf_err_message ) + + END SELECT lwrad_select + + IF (lw_physics .gt. 0 .and. .not.gfdl_lw) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + RTHRATENLW(I,K,J)=RTHRATEN(I,K,J) +! OLR ALSO WILL CONTAIN OUTGOING LONGWAVE FOR RRTM (NMM HAS NO OLR ARRAY) + IF(PRESENT(OLR) .AND. K .EQ. 1)OLR(I,J)=RLWTOA(I,J) + ENDDO + ENDDO + ENDDO + ENDIF +! + + swrad_select: SELECT CASE(sw_physics) + + CASE (SWRADSCHEME) + CALL wrf_debug(100, 'CALL swrad') + CALL SWRAD( & + DT=dt,RTHRATEN=rthraten,GSW=gsw & + ,XLAT=xlat,XLONG=xlong,ALBEDO=albedo & +#ifdef WRF_CHEM + ,PM2_5_DRY=pm2_5_dry,PM2_5_WATER=pm2_5_water & + ,PM2_5_DRY_EC=pm2_5_dry_ec & +#endif + ,RHO_PHY=rho,T3D=t & + ,P3D=p,PI3D=pi,DZ8W=dz8w,GMT=gmt & + ,R=r_d,CP=cp,G=g,JULDAY=julday & + ,XTIME=xtime,DECLIN=declin,SOLCON=solcon & +! ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban + ,RADFRQ=radt,ICLOUD=icloud,DEGRAD=degrad & + ,warm_rain=warm_rain & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban + ,QV3D=qv & + ,QC3D=qc & + ,QR3D=qr & + ,QI3D=qi & + ,QS3D=qs & + ,QG3D=qg & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & + ) + + CASE (GSFCSWSCHEME) + CALL wrf_debug(100, 'CALL gsfcswrad') + CALL GSFCSWRAD( & + RTHRATEN=rthraten,GSW=gsw,XLAT=xlat,XLONG=xlong & + ,ALB=albedo,T3D=t,P3D=p,P8W3D=p8w,pi3D=pi & + ,DZ8W=dz8w,RHO_PHY=rho & + ,CLDFRA3D=cldfra,RSWTOA=rswtoa & + ,GMT=gmt,CP=cp,G=g & +! ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban + ,JULDAY=julday,XTIME=xtime & + ,DECLIN=declin,SOLCON=solcon & + ,RADFRQ=radt,DEGRAD=degrad & + ,TAUCLDI=taucldi,TAUCLDC=taucldc & + ,WARM_RAIN=warm_rain & +#ifdef WRF_CHEM + ,TAUAER300=tauaer300,TAUAER400=tauaer400 & ! jcb + ,TAUAER600=tauaer600,TAUAER999=tauaer999 & ! jcb + ,GAER300=gaer300,GAER400=gaer400 & ! jcb + ,GAER600=gaer600,GAER999=gaer999 & ! jcb + ,WAER300=waer300,WAER400=waer400 & ! jcb + ,WAER600=waer600,WAER999=waer999 & ! jcb + ,aer_ra_feedback=aer_ra_feedback & +#endif + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban + ,QV3D=qv & + ,QC3D=qc & + ,QR3D=qr & + ,QI3D=qi & + ,QS3D=qs & + ,QG3D=qg & + ,QNDROP3D=qndrop & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & + ,F_QNDROP=f_qndrop & + ) + CASE (CAMSWSCHEME) +! Temporarily lw switch already calculates sw CAM tendency, so inactive here + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J) + ENDDO + ENDDO + ENDDO + + CASE (GFDLSWSCHEME) + + CALL wrf_debug (100, 'CALL gfdlsw') + + IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND. & + PRESENT(F_QS) .AND. PRESENT(qs) .AND. & + PRESENT(qv) .AND. PRESENT(qc) ) THEN + IF ( F_QV .AND. F_QC .AND. F_QS ) THEN + gfdl_sw = .true. + CALL ETARA( & + DT=dt,XLAND=xland & + ,P8W=p8w,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,T=t & + ,QV=qv,QW=qc_temp,QI=qi,QS=qs & + ,TSK2D=tsk,GLW=GLW,RSWIN=SWDOWN,GSW=GSW & + ,RSWINC=SWDOWNC,CLDFRA=CLDFRA,PI3D=pi & + ,GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot & + ,HBOTR=hbotr, HTOPR=htopr & + ,ALBEDO=albedo,CUPPT=cuppt & + ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt & + ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep & + ,XTIME=xtime,JULIAN=julian & + ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & + ,JULYR=julyr,JULDAY=julday & + ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & + ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & + ,ACFRST=acfrst,NCFRST=ncfrst & + ,ACFRCV=acfrcv,NCFRCV=ncfrcv & + ,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean & + ,THRATEN=rthraten,THRATENLW=rthratenlw & + ,THRATENSW=rthratensw & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal('Can not call ETARA (2a). Missing moisture fields.') + ENDIF + ELSE + CALL wrf_error_fatal('Can not call ETARA (2b). Missing moisture fields.') + ENDIF + + CASE DEFAULT + + WRITE( wrf_err_message , * ) 'The shortwave option does not exist: sw_physics = ', sw_physics + CALL wrf_error_fatal ( wrf_err_message ) + + END SELECT swrad_select + + IF (sw_physics .gt. 0 .and. .not.gfdl_sw) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + RTHRATENSW(I,K,J)=RTHRATEN(I,K,J)-RTHRATENLW(I,K,J) + ENDDO + ENDDO + ENDDO + + DO j=jts,jte + DO i=its,ite + SWDOWN(I,J)=GSW(I,J)/(1.-ALBEDO(I,J)) + ENDDO + ENDDO + + ENDIF + + IF ( PRESENT( cu_rad_feedback ) ) THEN + IF ( PRESENT( qc ) .AND. PRESENT( qc_adjust ) .AND. cu_rad_feedback ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc(i,k,j) = qc_save(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF ( PRESENT( qi ) .AND. PRESENT( qi_adjust ) .AND. cu_rad_feedback ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qi(i,k,j) = qi_save(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + ENDDO + !$OMP END PARALLEL DO + + ENDIF Radiation_step + + accumulate_lw_select: SELECT CASE(lw_physics) + + CASE (CAMLWSCHEME) + IF(PRESENT(LWUPTC))THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) + + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + + DO j=jts,jte + DO i=its,ite + ACLWUPT(I,J) = ACLWUPT(I,J) + LWUPT(I,J)*DT + ACLWUPTC(I,J) = ACLWUPTC(I,J) + LWUPTC(I,J)*DT + ACLWDNT(I,J) = ACLWDNT(I,J) + LWDNT(I,J)*DT + ACLWDNTC(I,J) = ACLWDNTC(I,J) + LWDNTC(I,J)*DT + ACLWUPB(I,J) = ACLWUPB(I,J) + LWUPB(I,J)*DT + ACLWUPBC(I,J) = ACLWUPBC(I,J) + LWUPBC(I,J)*DT + ACLWDNB(I,J) = ACLWDNB(I,J) + LWDNB(I,J)*DT + ACLWDNBC(I,J) = ACLWDNBC(I,J) + LWDNBC(I,J)*DT + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ENDIF + CASE DEFAULT + END SELECT accumulate_lw_select + + accumulate_sw_select: SELECT CASE(sw_physics) + + CASE (CAMSWSCHEME) + IF(PRESENT(SWUPTC))THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) + + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + + DO j=jts,jte + DO i=its,ite + ACSWUPT(I,J) = ACSWUPT(I,J) + SWUPT(I,J)*DT + ACSWUPTC(I,J) = ACSWUPTC(I,J) + SWUPTC(I,J)*DT + ACSWDNT(I,J) = ACSWDNT(I,J) + SWDNT(I,J)*DT + ACSWDNTC(I,J) = ACSWDNTC(I,J) + SWDNTC(I,J)*DT + ACSWUPB(I,J) = ACSWUPB(I,J) + SWUPB(I,J)*DT + ACSWUPBC(I,J) = ACSWUPBC(I,J) + SWUPBC(I,J)*DT + ACSWDNB(I,J) = ACSWDNB(I,J) + SWDNB(I,J)*DT + ACSWDNBC(I,J) = ACSWDNBC(I,J) + SWDNBC(I,J)*DT + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ENDIF + + CASE DEFAULT + END SELECT accumulate_sw_select + + END SUBROUTINE radiation_driver + +!--------------------------------------------------------------------- +!BOP +! !IROUTINE: radconst - compute radiation terms +! !INTERFAC: + SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & + DEGRAD,DPD ) +!--------------------------------------------------------------------- + USE module_wrf_error + IMPLICIT NONE +!--------------------------------------------------------------------- + +! !ARGUMENTS: + REAL, INTENT(IN ) :: DEGRAD,DPD,XTIME,JULIAN + REAL, INTENT(OUT ) :: DECLIN,SOLCON + REAL :: OBECL,SINOB,SXLONG,ARG, & + DECDEG,DJUL,RJUL,ECCFAC +! +! !DESCRIPTION: +! Compute terms used in radiation physics +!EOP + +! for short wave radiation + + DECLIN=0. + SOLCON=0. + +!-----OBECL : OBLIQUITY = 23.5 DEGREE. + + OBECL=23.5*DEGRAD + SINOB=SIN(OBECL) + +!-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX: + + IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.) + IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.) + SXLONG=SXLONG*DEGRAD + ARG=SINOB*SIN(SXLONG) + DECLIN=ASIN(ARG) + DECDEG=DECLIN/DEGRAD +!----SOLAR CONSTANT ECCENTRICITY FACTOR (PALTRIDGE AND PLATT 1976) + DJUL=JULIAN*360./365. + RJUL=DJUL*DEGRAD + ECCFAC=1.000110+0.034221*COS(RJUL)+0.001280*SIN(RJUL)+0.000719* & + COS(2*RJUL)+0.000077*SIN(2*RJUL) + SOLCON=1370.*ECCFAC + +!pjj/cray Cray X1 cannot print from threaded region +#ifndef crayx1 + write(wrf_err_message,10)DECDEG,SOLCON +10 FORMAT(1X,'*** SOLAR DECLINATION ANGLE = ',F6.2,' DEGREES.', & + ' SOLAR CONSTANT = ',F8.2,' W/M**2 ***') + CALL wrf_debug (50, wrf_err_message) +#endif + + END SUBROUTINE radconst + +!--------------------------------------------------------------------- +!BOP +! !IROUTINE: cal_cldfra - Compute cloud fraction +! !INTERFACE: + SUBROUTINE cal_cldfra(CLDFRA,QC,QI,F_QC,F_QI, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: & + CLDFRA + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: & + QI, & + QC + + LOGICAL,INTENT(IN) :: F_QC,F_QI + + REAL thresh + INTEGER:: i,j,k +! !DESCRIPTION: +! Compute cloud fraction from input ice and cloud water fields +! if provided. +! +! Whether QI or QC is active or not is determined from the indices of +! the fields into the 4D scalar arrays in WRF. These indices are +! P_QI and P_QC, respectively, and they are passed in to the routine +! to enable testing to see if QI and QC represent active fields in +! the moisture 4D scalar array carried by WRF. +! +! If a field is active its index will have a value greater than or +! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! this routine. +!EOP +!--------------------------------------------------------------------- + thresh=1.0e-6 + + IF ( f_qi .AND. f_qc ) THEN + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + IF ( QC(i,k,j)+QI(I,k,j) .gt. thresh) THEN + CLDFRA(i,k,j)=1. + ELSE + CLDFRA(i,k,j)=0. + ENDIF + ENDDO + ENDDO + ENDDO + ELSE IF ( f_qc ) THEN + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + IF ( QC(i,k,j) .gt. thresh) THEN + CLDFRA(i,k,j)=1. + ELSE + CLDFRA(i,k,j)=0. + ENDIF + ENDDO + ENDDO + ENDDO + ELSE + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + CLDFRA(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE cal_cldfra + +!BOP +! !IROUTINE: cal_cldfra2 - Compute cloud fraction +! !INTERFACE: +! cal_cldfra_xr - Compute cloud fraction. +! Code adapted from that in module_ra_gfdleta.F in WRF_v2.0.3 by James Done +!! +!!--- Cloud fraction parameterization follows Randall, 1994 +!! (see Hong et al., 1998) +!! (modified by Ferrier, Feb '02) +! + SUBROUTINE cal_cldfra2(CLDFRA, QV, QC, QI, QS, & + F_QV, F_QC, F_QI, F_QS, t_phy, p_phy, & + F_ICE_PHY,F_RAIN_PHY, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: & + CLDFRA + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: & + QV, & + QI, & + QC, & + QS, & + t_phy, & + p_phy, & + F_ICE_PHY, & + F_RAIN_PHY + + LOGICAL,INTENT(IN) :: F_QC,F_QI,F_QV,F_QS + +! REAL thresh + INTEGER:: i,j,k + REAL :: RHUM, tc, esw, esi, weight, qvsw, qvsi, qvs_weight, QIMID, QWMID, QCLD, DENOM, ARG, SUBSAT + + REAL ,PARAMETER :: ALPHA0=100., GAMMA=0.49, QCLDMIN=1.E-12, & + PEXP=0.25, RHGRID=1.0 + REAL , PARAMETER :: SVP1=0.61078 + REAL , PARAMETER :: SVP2=17.2693882 + REAL , PARAMETER :: SVPI2=21.8745584 + REAL , PARAMETER :: SVP3=35.86 + REAL , PARAMETER :: SVPI3=7.66 + REAL , PARAMETER :: SVPT0=273.15 + REAL , PARAMETER :: r_d = 287. + REAL , PARAMETER :: r_v = 461.6 + REAL , PARAMETER :: ep_2=r_d/r_v +! !DESCRIPTION: +! Compute cloud fraction from input ice and cloud water fields +! if provided. +! +! Whether QI or QC is active or not is determined from the indices of +! the fields into the 4D scalar arrays in WRF. These indices are +! P_QI and P_QC, respectively, and they are passed in to the routine +! to enable testing to see if QI and QC represent active fields in +! the moisture 4D scalar array carried by WRF. +! +! If a field is active its index will have a value greater than or +! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! this routine. +!EOP + + +!----------------------------------------------------------------------- +!--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION +! (modified by Ferrier, Feb '02) +! +!--- Cloud fraction parameterization follows Randall, 1994 +! (see Hong et al., 1998) +!----------------------------------------------------------------------- +! Note: ep_2=287./461.6 Rd/Rv +! Note: R_D=287. + +! Alternative calculation for critical RH for grid saturation +! RHGRID=0.90+.08*((100.-DX)/95.)**.5 + +! Calculate saturation mixing ratio weighted according to the fractions of +! water and ice. +! Following: +! Murray, F.W. 1966. ``On the computation of Saturation Vapor Pressure'' J. Appl. Meteor. 6 p.204 +! es (in mb) = 6.1078 . exp[ a . (T-273.16)/ (T-b) ] +! +! over ice over water +! a = 21.8745584 17.2693882 +! b = 7.66 35.86 + +!--------------------------------------------------------------------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + tc = t_phy(i,k,j) - SVPT0 + esw = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t_phy(i,k,j) - SVP3 ) ) + esi = 1000.0 * SVP1 * EXP( SVPI2 * tc / ( t_phy(i,k,j) - SVPI3 ) ) + QVSW = EP_2 * esw / ( p_phy(i,k,j) - esw ) + QVSI = EP_2 * esi / ( p_phy(i,k,j) - esi ) + + IF ( F_QI .and. F_QC .and. F_QS) THEN + QCLD=QI(i,k,j)+QC(i,k,j)+QS(I,k,j) + IF (QCLD .LT. QCLDMIN) THEN + weight = 0. + ELSE + weight = (QI(i,k,j)+QS(I,k,j)) / QCLD + ENDIF + ELSE IF ( F_QC ) THEN + +! Mixing ratios of cloud water & total ice (cloud ice + snow). +! Mixing ratios of rain are not considered in this scheme. +! F_ICE is fraction of ice +! F_RAIN is fraction of rain + + QIMID=QC(i,k,j)*F_ICE_PHY(i,k,j) + QWMID=(QC(i,k,j)-QIMID)*(1.-F_RAIN_PHY(i,k,j)) + + +! +!--- Total "cloud" mixing ratio, QCLD. Rain is not part of cloud, +! only cloud water + cloud ice + snow +! + QCLD=QWMID+QIMID + IF (QCLD .LT. QCLDMIN) THEN + weight = 0. + ELSE + weight = F_ICE_PHY(i,k,j) + ENDIF + + ELSE + CLDFRA(i,k,j)=0. + ENDIF ! IF ( F_QI .and. F_QC ) + + + QVS_WEIGHT = (1-weight)*QVSW + weight*QVSI + RHUM=QV(i,k,j)/QVS_WEIGHT !--- Relative humidity +! +!--- Determine cloud fraction (modified from original algorithm) +! + IF (QCLD .LT. QCLDMIN) THEN +! +!--- Assume zero cloud fraction if there is no cloud mixing ratio +! + CLDFRA(i,k,j)=0. + ELSEIF(RHUM.GE.RHGRID)THEN +! +!--- Assume cloud fraction of unity if near saturation and the cloud +! mixing ratio is at or above the minimum threshold +! + CLDFRA(i,k,j)=1. + ELSE +! +!--- Adaptation of original algorithm (Randall, 1994; Zhao, 1995) +! modified based on assumed grid-scale saturation at RH=RHgrid. +! + SUBSAT=MAX(1.E-10,RHGRID*QVS_WEIGHT-QV(i,k,j)) + DENOM=(SUBSAT)**GAMMA + ARG=MAX(-6.9, -ALPHA0*QCLD/DENOM) ! <-- EXP(-6.9)=.001 +! prevent negative values (new) + RHUM=MAX(1.E-10, RHUM) + CLDFRA(i,k,j)=(RHUM/RHGRID)**PEXP*(1.-EXP(ARG)) +!! ARG=-1000*QCLD/(RHUM-RHGRID) +!! ARG=MAX(ARG, ARGMIN) +!! CLDFRA(i,k,j)=(RHUM/RHGRID)*(1.-EXP(ARG)) + IF (CLDFRA(i,k,j) .LT. .01) CLDFRA(i,k,j)=0. + ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... + ENDDO !--- End DO i + ENDDO !--- End DO k + ENDDO !--- End DO j + + END SUBROUTINE cal_cldfra2 + +END MODULE module_radiation_driver diff --git a/wrfv2_fire/phys/module_sf_gfs.F b/wrfv2_fire/phys/module_sf_gfs.F new file mode 100755 index 00000000..1f96c6b1 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_gfs.F @@ -0,0 +1,1767 @@ +!!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_sf_gfs + + +CONTAINS + +!------------------------------------------------------------------- + SUBROUTINE SF_GFS(U3D,V3D,T3D,QV3D,P3D, & + CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM, & + ZNT,UST,PSIM,PSIH, & + XLAND,HFX,QFX,LH,TSK,FLHC,FLQC, & + QGH,QSFC,U10,V10, & + GZ1OZ0,WSPD,BR,ISFFLX, & + EP1,EP2,KARMAN,itimestep, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!------------------------------------------------------------------- + USE MODULE_GFS_MACHINE, ONLY : kind_phys + USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys,fpvs +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- ROVCP R/CP +!-- R gas constant for dry air (J/kg/K) +!-- XLV latent heat of vaporization for water (J/kg) +!-- PSFC surface pressure (Pa) +!-- ZNT roughness length (m) +!-- UST u* in similarity theory (m/s) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity stability function for heat +!-- XLAND land mask (1 for land, 2 for water) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH net upward latent heat flux at surface (W/m^2) +!-- TSK surface temperature (K) +!-- FLHC exchange coefficient for heat (m/s) +!-- FLQC exchange coefficient for moisture (m/s) +!-- QGH lowest-level saturated mixing ratio +!-- U10 diagnostic 10m u wind +!-- V10 diagnostic 10m v wind +!-- GZ1OZ0 log(z/z0) where z0 is roughness length +!-- WSPD wind speed at lowest model level (m/s) +!-- BR bulk Richardson number in surface layer +!-- ISFFLX isfflx=1 for surface heat and moisture fluxes +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- KARMAN Von Karman constant +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ISFFLX,itimestep + + REAL, INTENT(IN) :: & + CP, & + EP1, & + EP2, & + KARMAN, & + R, & + ROVCP, & + XLV + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & + P3D, & + QV3D, & + T3D, & + U3D, & + V3D + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & + TSK, & + PSFC, & + XLAND + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: & + BR, & + CHS, & + CHS2, & + CPM, & + CQS2, & + FLHC, & + FLQC, & + GZ1OZ0, & + HFX, & + LH, & + PSIM, & + PSIH, & + QFX, & + QGH, & + QSFC, & + UST, & + ZNT, & + WSPD + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & + U10, & + V10 + + +!--------------------------- LOCAL VARS ------------------------------ + + REAL :: ESAT + + REAL (kind=kind_phys) :: & + RHOX + + REAL (kind=kind_phys), DIMENSION(its:ite) :: & + CH, & + CM, & + DDVEL, & + DRAIN, & + EP, & + EVAP, & + FH, & + FH2, & + FM, & + HFLX, & + PH, & + PM, & + PRSL1, & + PRSLKI, & + PS, & + Q1, & + Q2M, & + QSS, & + QSURF, & + RB, & + RCL, & + RHO1, & + SLIMSK, & + STRESS, & + T1, & + T2M, & + THGB, & + THX, & + TSKIN, & + SHELEG, & + U1, & + U10M, & + USTAR, & + V1, & + V10M, & + WIND, & + Z0RL, & + Z1 + + + INTEGER :: & + I, & + IM, & + J, & + K, & + KM + + + if(itimestep.eq.0) then + CALL GFUNCPHYS + endif + + IM=ITE-ITS+1 + KM=KTE-KTS+1 + + DO J=jts,jte + + DO i=its,ite + DDVEL(I)=0. + RCL(i)=1. + PRSL1(i)=P3D(i,kts,j)*.001 + PS(i)=PSFC(i,j)*.001 + Q1(I) = QV3D(i,kts,j) +! QSURF(I)=QSFC(I,J) + QSURF(I)=0. + SHELEG(I)=0. + SLIMSK(i)=ABS(XLAND(i,j)-2.) + TSKIN(i)=TSK(i,j) + T1(I) = T3D(i,kts,j) + U1(I) = U3D(i,kts,j) + USTAR(I) = UST(i,j) + V1(I) = V3D(i,kts,j) + Z0RL(I) = ZNT(i,j)*100. + ENDDO + + DO i=its,ite + PRSLKI(i)=(PS(I)/PRSL1(I))**ROVCP + THGB(I)=TSKIN(i)*(100./PS(I))**ROVCP + THX(I)=T1(i)*(100./PRSL1(I))**ROVCP + RHO1(I)=PRSL1(I)*1000./(R*T1(I)*(1.+EP1*Q1(I))) + Q1(I)=Q1(I)/(1.+Q1(I)) + ENDDO + + + CALL PROGTM(IM,KM,PS,U1,V1,T1,Q1, & + SHELEG,TSKIN,QSURF, & +!WRF SMC,STC,DM,SOILTYP,SIGMAF,VEGTYPE,CANOPY,DLWFLX, & +!WRF SLRAD,SNOWMT,DELT, & + Z0RL, & +!WRF TG3,GFLUX,F10M, & + U10M,V10M,T2M,Q2M, & +!WRF ZSOIL, & + CM,CH,RB, & +!WRF RHSCNPY,RHSMC,AIM,BIM,CIM, & + RCL,PRSL1,PRSLKI,SLIMSK, & + DRAIN,EVAP,HFLX,STRESS,EP, & + FM,FH,USTAR,WIND,DDVEL, & + PM,PH,FH2,QSS,Z1 ) + + + DO i=its,ite + U10(i,j)=U10M(i) + V10(i,j)=V10M(i) + BR(i,j)=RB(i) + CHS(I,J)=CH(I)*WIND(I) + CHS2(I,J)=USTAR(I)*KARMAN/FH2(I) + CPM(I,J)=CP*(1.+0.8*QV3D(i,kts,j)) + esat = fpvs(t1(i)) + QGH(I,J)=ep2*esat/(1000.*ps(i)-esat) + QSFC(I,J)=qss(i) + PSIH(i,j)=PH(i) + PSIM(i,j)=PM(i) + UST(i,j)=ustar(i) + WSPD(i,j)=WIND(i) + ZNT(i,j)=Z0RL(i)*.01 + ENDDO + + DO i=its,ite + FLHC(i,j)=CPM(I,J)*RHO1(I)*CHS(I,J) + FLQC(i,j)=RHO1(I)*CHS(I,J) + GZ1OZ0(i,j)=LOG(Z1(I)/(Z0RL(I)*.01)) + CQS2(i,j)=CHS2(I,J) + ENDDO + + IF (ISFFLX.EQ.0) THEN + DO i=its,ite + HFX(i,j)=0. + LH(i,j)=0. + QFX(i,j)=0. + ENDDO + ELSE + DO i=its,ite + IF(XLAND(I,J)-1.5.GT.0.)THEN + HFX(I,J)=FLHC(I,J)*(THGB(I)-THX(I)) + ELSEIF(XLAND(I,J)-1.5.LT.0.)THEN + HFX(I,J)=FLHC(I,J)*(THGB(I)-THX(I)) + HFX(I,J)=AMAX1(HFX(I,J),-250.) + ENDIF + QFX(I,J)=FLQC(I,J)*(QSFC(I,J)-Q1(I)) + QFX(I,J)=AMAX1(QFX(I,J),0.) + LH(I,J)=XLV*QFX(I,J) + ENDDO + ENDIF + + + ENDDO + + + END SUBROUTINE SF_GFS + + +!------------------------------------------------------------------- + + SUBROUTINE PROGTM(IM,KM,PS,U1,V1,T1,Q1, & + & SHELEG,TSKIN,QSURF, & +!WRF & SMC,STC,DM,SOILTYP,SIGMAF,VEGTYPE,CANOPY, & +!WRF & DLWFLX,SLRAD,SNOWMT,DELT, & + & Z0RL, & +!WRF & TG3,GFLUX,F10M, & + & U10M,V10M,T2M,Q2M, & +!WRF & ZSOIL, & + & CM, CH, RB, & +!WRF & RHSCNPY,RHSMC,AIM,BIM,CIM, & + & RCL,PRSL1,PRSLKI,SLIMSK, & + & DRAIN,EVAP,HFLX,STRESS,EP, & + & FM,FH,USTAR,WIND,DDVEL, & + & PM,PH,FH2,QSS,Z1 ) +! + + USE MODULE_GFS_MACHINE, ONLY : kind_phys + USE MODULE_GFS_FUNCPHYS, ONLY : fpvs + USE MODULE_GFS_PHYSCONS, grav => con_g, SBC => con_sbc, HVAP => con_HVAP & + &, CP => con_CP, HFUS => con_HFUS, JCAL => con_JCAL & + &, EPS => con_eps, EPSM1 => con_epsm1, t0c => con_t0c & + &, RVRDM1 => con_FVirt, RD => con_RD + implicit none +! +! include 'constant.h' +! + integer IM, km +! + real(kind=kind_phys), parameter :: cpinv=1.0/cp, HVAPI=1.0/HVAP + real(kind=kind_phys) DELT + INTEGER SOILTYP(IM), VEGTYPE(IM) + real(kind=kind_phys) PS(IM), U1(IM), V1(IM), & + & T1(IM), Q1(IM), SHELEG(IM), & + & TSKIN(IM), QSURF(IM), SMC(IM,KM), & + & STC(IM,KM), DM(IM), SIGMAF(IM), & + & CANOPY(IM), DLWFLX(IM), SLRAD(IM), & + & SNOWMT(IM), Z0RL(IM), TG3(IM), & + & GFLUX(IM), F10M(IM), U10M(IM), & + & V10M(IM), T2M(IM), Q2M(IM), & + & ZSOIL(IM,KM), CM(IM), CH(IM), & + & RB(IM), RHSCNPY(IM), RHSMC(IM,KM), & + & AIM(IM,KM), BIM(IM,KM), CIM(IM,KM), & + & RCL(IM), PRSL1(IM), PRSLKI(IM), & + & SLIMSK(IM), DRAIN(IM), EVAP(IM), & + & HFLX(IM), RNET(IM), EP(IM), & + & FM(IM), FH(IM), USTAR(IM), & + & WIND(IM), DDVEL(IM), STRESS(IM) +! +! Locals +! + integer k,i +! + real(kind=kind_phys) CANFAC(IM), & + & DDZ(IM), DDZ2(IM), DELTA(IM), & + & DEW(IM), DF1(IM), DFT0(IM), & + & DFT2(IM), DFT1(IM), & + & DMDZ(IM), DMDZ2(IM), DTDZ1(IM), & + & DTDZ2(IM), DTV(IM), EC(IM), & + & EDIR(IM), ETPFAC(IM), & + & FACTSNW(IM), FH2(IM), FM10(IM), & + & FX(IM), GX(IM), & + & HCPCT(IM), HL1(IM), HL12(IM), & + & HLINF(IM), PARTLND(IM), PH(IM), & + & PH2(IM), PM(IM), PM10(IM), & + & PSURF(IM), Q0(IM), QS1(IM), & + & QSS(IM), RAT(IM), RCAP(IM), & + & RCH(IM), RHO(IM), RS(IM), & + & RSMALL(IM), SLWD(IM), SMCZ(IM), & + & SNET(IM), SNOEVP(IM), SNOWD(IM), & + & T1O(IM), T2MO(IM), TERM1(IM), & + & TERM2(IM), THETA1(IM), THV1(IM), & + & TREF(IM), TSURF(IM), TV1(IM), & + & TVS(IM), TSURFO(IM), TWILT(IM), & + & XX(IM), XRCL(IM), YY(IM), & + & Z0(IM), Z0MAX(IM), Z1(IM), & + & ZTMAX(IM), ZZ(IM), PS1(IM) +! + real(kind=kind_phys) a0, a0p, a1, a1p, aa, aa0, & + & aa1, adtv, alpha, arnu, b1, b1p, & + & b2, b2p, bb, bb0, bb1, bb2, & + & bfact, ca, cc, cc1, cc2, cfactr, & + & ch2o, charnock, cice, convrad, cq, csoil, & + & ctfil1,ctfil2, delt2, df2, dfsnow, & + & elocp, eth, ff, FMS, & +!WRF & fhs, funcdf, funckt,g, hl0, hl0inf, & + & fhs, g, hl0, hl0inf, & + & hl110, hlt, hltinf,OLINF, rcq, rcs, & + & rct, restar, rhoh2o,rnu, RSI, & + & rss, scanop, sig2k, sigma, smcdry, & + & t12, t14, tflx, tgice, topt, & + & val, vis, zbot, snomin, tem +! +! + + PARAMETER (CHARNOCK=.014,CA=.4)!C CA IS THE VON KARMAN CONSTANT + PARAMETER (G=grav,sigma=sbc) + + PARAMETER (ALPHA=5.,A0=-3.975,A1=12.32,B1=-7.755,B2=6.041) + PARAMETER (A0P=-7.941,A1P=24.75,B1P=-8.705,B2P=7.899,VIS=1.4E-5) + PARAMETER (AA1=-1.076,BB1=.7045,CC1=-.05808) + PARAMETER (BB2=-.1954,CC2=.009999) + PARAMETER (ELOCP=HVAP/CP,DFSNOW=.31,CH2O=4.2E6,CSOIL=1.26E6) + PARAMETER (SCANOP=.5,CFACTR=.5,ZBOT=-3.,TGICE=271.2) + PARAMETER (CICE=1880.*917.,topt=298.) + PARAMETER (RHOH2O=1000.,CONVRAD=JCAL*1.E4/60.) + PARAMETER (CTFIL1=.5,CTFIL2=1.-CTFIL1) + PARAMETER (RNU=1.51E-5,ARNU=.135*RNU) + parameter (snomin=1.0e-9) +! + LOGICAL FLAG(IM), FLAGSNW(IM) +!WRF real(kind=kind_phys) KT1(IM), KT2(IM), KTSOIL, & + real(kind=kind_phys) KT1(IM), KT2(IM), & + & ET(IM,KM), & + & STSOIL(IM,KM), AI(IM,KM), BI(IM,KM), & + & CI(IM,KM), RHSTC(IM,KM) + real(kind=kind_phys) rsmax(13), rgl(13), rsmin(13), hs(13), & + & smmax(9), smdry(9), smref(9), smwlt(9) + +! +! the 13 vegetation types are: +! +! 1 ... broadleave-evergreen trees (tropical forest) +! 2 ... broadleave-deciduous trees +! 3 ... broadleave and needle leave trees (mixed forest) +! 4 ... needleleave-evergreen trees +! 5 ... needleleave-deciduous trees (larch) +! 6 ... broadleave trees with groundcover (savanna) +! 7 ... groundcover only (perenial) +! 8 ... broadleave shrubs with perenial groundcover +! 9 ... broadleave shrubs with bare soil +! 10 ... dwarf trees and shrubs with ground cover (trunda) +! 11 ... bare soil +! 12 ... cultivations (use parameters from type 7) +! 13 ... glacial +! + data rsmax/13*5000./ + data rsmin/150.,100.,125.,150.,100.,70.,40., & + & 300.,400.,150.,999.,40.,999./ + data rgl/5*30.,65.,4*100.,999.,100.,999./ + data hs/41.69,54.53,51.93,47.35,47.35,54.53,36.35, & + & 3*42.00,999.,36.35,999./ + data smmax/.421,.464,.468,.434,.406,.465,.404,.439,.421/ + data smdry/.07,.14,.22,.08,.18,.16,.12,.10,.07/ + data smref/.283,.387,.412,.312,.338,.382,.315,.329,.283/ + data smwlt/.029,.119,.139,.047,.010,.103,.069,.066,.029/ +! +!!! save rsmax, rsmin, rgl, hs, smmax, smdry, smref, smwlt +! + +!WRF DELT2 = DELT * 2. +! +! ESTIMATE SIGMA ** K AT 2 M +! + SIG2K = 1. - 4. * G * 2. / (CP * 280.) +! +! INITIALIZE VARIABLES. ALL UNITS ARE SUPPOSEDLY M.K.S. UNLESS SPECIFIE +! PSURF IS IN PASCALS +! WIND IS WIND SPEED, THETA1 IS ADIABATIC SURFACE TEMP FROM LEVEL 1 +! RHO IS DENSITY, QS1 IS SAT. HUM. AT LEVEL1 AND QSS IS SAT. HUM. AT +! SURFACE +! CONVERT SLRAD TO THE CIVILIZED UNIT FROM LANGLEY MINUTE-1 K-4 +! SURFACE ROUGHNESS LENGTH IS CONVERTED TO M FROM CM +! +!! +! qs1 = fpvs(t1) +! qss = fpvs(tskin) + DO I=1,IM + XRCL(I) = SQRT(RCL(I)) + PSURF(I) = 1000. * PS(I) + PS1(I) = 1000. * PRSL1(I) +! SLWD(I) = SLRAD(I) * CONVRAD +!WRF SLWD(I) = SLRAD(I) +! +! DLWFLX has been given a negative sign for downward longwave +! snet is the net shortwave flux +! +!WRF SNET(I) = -SLWD(I) - DLWFLX(I) + WIND(I) = XRCL(I) * SQRT(U1(I) * U1(I) + V1(I) * V1(I)) & + & + MAX(0.0_kind_phys, MIN(DDVEL(I), 30.0_kind_phys)) + WIND(I) = MAX(WIND(I),1._kind_phys) + Q0(I) = MAX(Q1(I),1.E-8_kind_phys) + TSURF(I) = TSKIN(I) + THETA1(I) = T1(I) * PRSLKI(I) + TV1(I) = T1(I) * (1. + RVRDM1 * Q0(I)) + THV1(I) = THETA1(I) * (1. + RVRDM1 * Q0(I)) + TVS(I) = TSURF(I) * (1. + RVRDM1 * Q0(I)) + RHO(I) = PS1(I) / (RD * TV1(I)) +!jfe QS1(I) = 1000. * FPVS(T1(I)) + qs1(i) = fpvs(t1(i)) + QS1(I) = EPS * QS1(I) / (PS1(I) + EPSM1 * QS1(I)) + QS1(I) = MAX(QS1(I), 1.E-8_kind_phys) + Q0(I) = min(QS1(I),Q0(I)) +!jfe QSS(I) = 1000. * FPVS(TSURF(I)) + qss(i) = fpvs(tskin(i)) + QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) +! RS = PLANTR + RS(I) = 0. +!WRF if(VEGTYPE(I).gt.0.) RS(I) = rsmin(VEGTYPE(I)) + Z0(I) = .01 * Z0RL(i) +!WRF CANOPY(I)= MAX(CANOPY(I),0._kind_phys) + DM(I) = 1. +!WRF + GOTO 1111 +!WRF + FACTSNW(I) = 10. + IF(SLIMSK(I).EQ.2.) FACTSNW(I) = 3. +! +! SNOW DEPTH IN WATER EQUIVALENT IS CONVERTED FROM MM TO M UNIT +! + SNOWD(I) = SHELEG(I) / 1000. + FLAGSNW(I) = .FALSE. +! +! WHEN SNOW DEPTH IS LESS THAN 1 MM, A PATCHY SNOW IS ASSUMED AND +! SOIL IS ALLOWED TO INTERACT WITH THE ATMOSPHERE. +! WE SHOULD EVENTUALLY MOVE TO A LINEAR COMBINATION OF SOIL AND +! SNOW UNDER THE CONDITION OF PATCHY SNOW. +! + IF(SNOWD(I).GT..001.OR.SLIMSK(I).EQ.2.) RS(I) = 0. + IF(SNOWD(I).GT..001) FLAGSNW(I) = .TRUE. +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' WIND,TV1,TVS,Q1,QS1,SNOW,SLIMSK=', +!##DG& WIND,TV1,TVS,Q1,QS1,SNOWD,SLIMSK +!##DG PRINT *, ' SNET, SLWD =', SNET, SLWD(I) +!##DG ENDIF + IF(SLIMSK(I).EQ.0.) THEN + ZSOIL(I,1) = 0. + ELSEIF(SLIMSK(I).EQ.1.) THEN + ZSOIL(I,1) = -.10 + ELSE + ZSOIL(I,1) = -3. / KM + ENDIF +!WRF +1111 CONTINUE +!WRF + ENDDO + +!! +!WRF + GOTO 2222 +!WRF + DO K = 2, KM + DO I=1,IM + IF(SLIMSK(I).EQ.0.) THEN + ZSOIL(I,K) = 0. + ELSEIF(SLIMSK(I).EQ.1.) THEN + ZSOIL(I,K) = ZSOIL(I,K-1) & + & + (-2. - ZSOIL(I,1)) / (KM - 1) + ELSE + ZSOIL(I,K) = - 3. * FLOAT(K) / FLOAT(KM) + ENDIF + ENDDO + ENDDO +!WRF +2222 CONTINUE +!WRF +!! + DO I=1,IM + Z1(I) = -RD * TV1(I) * LOG(PS1(I)/PSURF(I)) / G + DRAIN(I) = 0. + ENDDO + +!! + DO K = 1, KM + DO I=1,IM + ET(I,K) = 0. + RHSMC(I,K) = 0. + AIM(I,K) = 0. + BIM(I,K) = 1. + CIM(I,K) = 0. + STSOIL(I,K) = STC(I,K) + ENDDO + ENDDO + + DO I=1,IM + EDIR(I) = 0. + EC(I) = 0. + EVAP(I) = 0. + EP(I) = 0. + SNOWMT(I) = 0. + GFLUX(I) = 0. + RHSCNPY(I) = 0. + FX(I) = 0. + ETPFAC(I) = 0. + CANFAC(I) = 0. + ENDDO +! +! COMPUTE STABILITY DEPENDENT EXCHANGE COEFFICIENTS +! +! THIS PORTION OF THE CODE IS PRESENTLY SUPPRESSED +! + DO I=1,IM + IF(SLIMSK(I).EQ.0.) THEN + USTAR(I) = SQRT(G * Z0(I) / CHARNOCK) + ENDIF +! +! COMPUTE STABILITY INDICES (RB AND HLINF) +! + + Z0MAX(I) = MIN(Z0(I),0.1 * Z1(I)) + ZTMAX(I) = Z0MAX(I) + IF(SLIMSK(I).EQ.0.) THEN + RESTAR = USTAR(I) * Z0MAX(I) / VIS + RESTAR = MAX(RESTAR,.000001_kind_phys) +! RESTAR = ALOG(RESTAR) +! RESTAR = MIN(RESTAR,5.) +! RESTAR = MAX(RESTAR,-5.) +! RAT(I) = AA1 + BB1 * RESTAR + CC1 * RESTAR ** 2 +! RAT(I) = RAT(I) / (1. + BB2 * RESTAR +! & + CC2 * RESTAR ** 2) +! Rat taken from Zeng, Zhao and Dickinson 1997 + RAT(I) = 2.67 * restar ** .25 - 2.57 + RAT(I) = min(RAT(I),7._kind_phys) + ZTMAX(I) = Z0MAX(I) * EXP(-RAT(I)) + ENDIF + ENDDO + +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' z0max, ztmax, restar, RAT(I) =', +!##DG & z0max, ztmax, restar, RAT(I) +!##DG ENDIF + DO I = 1, IM + DTV(I) = THV1(I) - TVS(I) + ADTV = ABS(DTV(I)) + ADTV = MAX(ADTV,.001_kind_phys) + DTV(I) = SIGN(1._kind_phys,DTV(I)) * ADTV + RB(I) = G * DTV(I) * Z1(I) / (.5 * (THV1(I) + TVS(I)) & + & * WIND(I) * WIND(I)) + RB(I) = MAX(RB(I),-5000._kind_phys) +! FM(I) = LOG((Z0MAX(I)+Z1(I)) / Z0MAX(I)) +! FH(I) = LOG((ZTMAX(I)+Z1(I)) / ZTMAX(I)) + FM(I) = LOG((Z1(I)) / Z0MAX(I)) + FH(I) = LOG((Z1(I)) / ZTMAX(I)) + HLINF(I) = RB(I) * FM(I) * FM(I) / FH(I) + FM10(I) = LOG((Z0MAX(I)+10.) / Z0MAX(I)) + FH2(I) = LOG((ZTMAX(I)+2.) / ZTMAX(I)) + ENDDO +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' DTV, RB(I), FM(I), FH(I), HLINF =', +!##DG & dtv, rb, FM(I), FH(I), hlinf +!##DG ENDIF +! +! STABLE CASE +! + DO I = 1, IM + IF(DTV(I).GE.0.) THEN + HL1(I) = HLINF(I) + ENDIF + IF(DTV(I).GE.0..AND.HLINF(I).GT..25) THEN + HL0INF = Z0MAX(I) * HLINF(I) / Z1(I) + HLTINF = ZTMAX(I) * HLINF(I) / Z1(I) + AA = SQRT(1. + 4. * ALPHA * HLINF(I)) + AA0 = SQRT(1. + 4. * ALPHA * HL0INF) + BB = AA + BB0 = SQRT(1. + 4. * ALPHA * HLTINF) + PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) + PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) + FMS = FM(I) - PM(I) + FHS = FH(I) - PH(I) + HL1(I) = FMS * FMS * RB(I) / FHS + ENDIF + ENDDO +! +! SECOND ITERATION +! + DO I = 1, IM + IF(DTV(I).GE.0.) THEN + HL0 = Z0MAX(I) * HL1(I) / Z1(I) + HLT = ZTMAX(I) * HL1(I) / Z1(I) + AA = SQRT(1. + 4. * ALPHA * HL1(I)) + AA0 = SQRT(1. + 4. * ALPHA * HL0) + BB = AA + BB0 = SQRT(1. + 4. * ALPHA * HLT) + PM(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) + PH(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) + HL110 = HL1(I) * 10. / Z1(I) + AA = SQRT(1. + 4. * ALPHA * HL110) + PM10(I) = AA0 - AA + LOG((AA + 1.) / (AA0 + 1.)) + HL12(I) = HL1(I) * 2. / Z1(I) +! AA = SQRT(1. + 4. * ALPHA * HL12(I)) + BB = SQRT(1. + 4. * ALPHA * HL12(I)) + PH2(I) = BB0 - BB + LOG((BB + 1.) / (BB0 + 1.)) + ENDIF + ENDDO +!! +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' HL1(I), PM, PH =', +!##DG & HL1(I), pm, ph +!##DG ENDIF +! +! UNSTABLE CASE +! +! +! CHECK FOR UNPHYSICAL OBUKHOV LENGTH +! + DO I=1,IM + IF(DTV(I).LT.0.) THEN + OLINF = Z1(I) / HLINF(I) + IF(ABS(OLINF).LE.50. * Z0MAX(I)) THEN + HLINF(I) = -Z1(I) / (50. * Z0MAX(I)) + ENDIF + ENDIF + ENDDO +! +! GET PM AND PH +! + DO I = 1, IM + IF(DTV(I).LT.0..AND.HLINF(I).GE.-.5) THEN + HL1(I) = HLINF(I) + PM(I) = (A0 + A1 * HL1(I)) * HL1(I) & + & / (1. + B1 * HL1(I) + B2 * HL1(I) * HL1(I)) + PH(I) = (A0P + A1P * HL1(I)) * HL1(I) & + & / (1. + B1P * HL1(I) + B2P * HL1(I) * HL1(I)) + HL110 = HL1(I) * 10. / Z1(I) + PM10(I) = (A0 + A1 * HL110) * HL110 & + & / (1. + B1 * HL110 + B2 * HL110 * HL110) + HL12(I) = HL1(I) * 2. / Z1(I) + PH2(I) = (A0P + A1P * HL12(I)) * HL12(I) & + & / (1. + B1P * HL12(I) + B2P * HL12(I) * HL12(I)) + ENDIF + IF(DTV(I).LT.0.AND.HLINF(I).LT.-.5) THEN + HL1(I) = -HLINF(I) + PM(I) = LOG(HL1(I)) + 2. * HL1(I) ** (-.25) - .8776 + PH(I) = LOG(HL1(I)) + .5 * HL1(I) ** (-.5) + 1.386 + HL110 = HL1(I) * 10. / Z1(I) + PM10(I) = LOG(HL110) + 2. * HL110 ** (-.25) - .8776 + HL12(I) = HL1(I) * 2. / Z1(I) + PH2(I) = LOG(HL12(I)) + .5 * HL12(I) ** (-.5) + 1.386 + ENDIF + ENDDO +! +! FINISH THE EXCHANGE COEFFICIENT COMPUTATION TO PROVIDE FM AND FH +! + DO I = 1, IM + + FM(I) = FM(I) - PM(I) + FH(I) = FH(I) - PH(I) + FM10(I) = FM10(I) - PM10(I) + FH2(I) = FH2(I) - PH2(I) + CM(I) = CA * CA / (FM(I) * FM(I)) + CH(I) = CA * CA / (FM(I) * FH(I)) + CQ = CH(I) + STRESS(I) = CM(I) * WIND(I) * WIND(I) + USTAR(I) = SQRT(STRESS(I)) +! USTAR(I) = SQRT(CM(I) * WIND(I) * WIND(I)) + ENDDO +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' FM, FH, CM, CH(I), USTAR =', +!##DG & FM, FH, CM, ch, USTAR +!##DG ENDIF +! +! UPDATE Z0 OVER OCEAN +! + DO I = 1, IM + IF(SLIMSK(I).EQ.0.) THEN + Z0(I) = (CHARNOCK / G) * USTAR(I) ** 2 +! NEW IMPLEMENTATION OF Z0 +! CC = USTAR(I) * Z0 / RNU +! PP = CC / (1. + CC) +! FF = G * ARNU / (CHARNOCK * USTAR(I) ** 3) +! Z0 = ARNU / (USTAR(I) * FF ** PP) + Z0(I) = MIN(Z0(I),.1_kind_phys) + Z0(I) = MAX(Z0(I),1.E-7_kind_phys) + Z0RL(I) = 100. * Z0(I) + ENDIF + ENDDO + + GOTO 5555 +! +! RCP = RHO CP CH V +! + DO I = 1, IM + RCH(I) = RHO(I) * CP * CH(I) * WIND(I) + ENDDO + + +! +! SENSIBLE AND LATENT HEAT FLUX OVER OPEN WATER +! + DO I = 1, IM + IF(SLIMSK(I).EQ.0.) THEN + EVAP(I) = ELOCP * RCH(I) * (QSS(I) - Q1(I)) + DM(I) = 1. + QSURF(I) = QSS(I) + ENDIF + ENDDO + + ! + ! COMPUTE SOIL/SNOW/ICE HEAT FLUX IN PREPARATION FOR SURFACE ENERGY + ! BALANCE CALCULATION + ! + DO I = 1, IM + GFLUX(I) = 0. + IF(SLIMSK(I).EQ.1.) THEN + SMCZ(I) = .5 * (SMC(I,1) + .20) + DFT0(I) = KTSOIL(SMCZ(I),SOILTYP(I)) + ELSEIF(SLIMSK(I).EQ.2.) THEN + ! DF FOR ICE IS TAKEN FROM MAYKUT AND UNTERSTEINER + ! DF IS IN SI UNIT OF W K-1 M-1 + DFT0(I) = 2.2 + ENDIF + ENDDO + !! + DO I=1,IM + IF(SLIMSK(I).NE.0.) THEN + ! IF(SNOWD(I).GT..001) THEN + IF(FLAGSNW(I)) THEN + ! + ! WHEN SNOW COVERED, GROUND HEAT FLUX COMES FROM SNOW + ! + TFLX = MIN(T1(I), TSURF(I)) + GFLUX(I) = -DFSNOW * (TFLX - STSOIL(I,1)) & + & / (FACTSNW(I) * MAX(SNOWD(I),.001_kind_phys)) + ELSE + GFLUX(I) = DFT0(I) * (STSOIL(I,1) - TSURF(I)) & + & / (-.5 * ZSOIL(I,1)) + ENDIF + GFLUX(I) = MAX(GFLUX(I),-200._kind_phys) + GFLUX(I) = MIN(GFLUX(I),+200._kind_phys) + ENDIF + ENDDO + DO I = 1, IM + FLAG(I) = SLIMSK(I).NE.0. + PARTLND(I) = 1. + IF(SNOWD(I).GT.0..AND.SNOWD(I).LE..001) THEN + PARTLND(I) = 1. - SNOWD(I) / .001 + ENDIF + ENDDO + DO I = 1, IM + SNOEVP(I) = 0. + if(SNOWD(I).gt..001) PARTLND(I) = 0. + ENDDO + ! + ! COMPUTE POTENTIAL EVAPORATION FOR LAND AND SEA ICE + ! + DO I = 1, IM + IF(FLAG(I)) THEN + T12 = T1(I) * T1(I) + T14 = T12 * T12 + ! + ! RCAP = FNET - SIGMA T**4 + GFLX - RHO CP CH V (T1-THETA1) + ! + RCAP(I) = -SLWD(I) - SIGMA * T14 + GFLUX(I) & + & - RCH(I) * (T1(I) - THETA1(I)) + ! + ! RSMALL = 4 SIGMA T**3 / RCH(I) + 1 + ! + RSMALL(I) = 4. * SIGMA * T1(I) * T12 / RCH(I) + 1. + ! + ! DELTA = L / CP * DQS/DT + ! + DELTA(I) = ELOCP * EPS * HVAP * QS1(I) / (RD * T12) + ! + ! POTENTIAL EVAPOTRANSPIRATION ( WATTS / M**2 ) AND + ! POTENTIAL EVAPORATION + ! + TERM1(I) = ELOCP * RSMALL(I) * RCH(I)*(QS1(I)-Q0(I)) + TERM2(I) = RCAP(I) * DELTA(I) + EP(I) = (ELOCP * RSMALL(I) * RCH(I) * (QS1(I) - Q0(I)) & + & + RCAP(I) * DELTA(I)) + EP(I) = EP(I) / (RSMALL(I) + DELTA(I)) + ENDIF + ENDDO + ! + ! ACTUAL EVAPORATION OVER LAND IN THREE PARTS : EDIR, ET, AND EC + ! + ! DIRECT EVAPORATION FROM SOIL, THE UNIT GOES FROM M S-1 TO KG M-2 S-1 + ! + DO I = 1, IM + FLAG(I) = SLIMSK(I).EQ.1..AND.EP(I).GT.0. + ENDDO + DO I = 1, IM + IF(FLAG(I)) THEN + DF1(I) = FUNCDF(SMC(I,1),SOILTYP(I)) + KT1(I) = FUNCKT(SMC(I,1),SOILTYP(I)) + endif + if(FLAG(I).and.STC(I,1).lt.t0c) then + DF1(I) = 0. + KT1(I) = 0. + endif + IF(FLAG(I)) THEN + ! TREF = .75 * THSAT(SOILTYP(I)) + TREF(I) = smref(SOILTYP(I)) + ! TWILT = TWLT(SOILTYP(I)) + TWILT(I) = smwlt(SOILTYP(I)) + smcdry = smdry(SOILTYP(I)) + ! FX(I) = -2. * DF1(I) * (SMC(I,1) - .23) / ZSOIL(I,1) + ! & - KT1(I) + FX(I) = -2. * DF1(I) * (SMC(I,1) - smcdry) / ZSOIL(I,1) & + & - KT1(I) + FX(I) = MIN(FX(I), EP(I)/HVAP) + FX(I) = MAX(FX(I),0._kind_phys) + ! + ! SIGMAF IS THE FRACTION OF AREA COVERED BY VEGETATION + ! + EDIR(I) = FX(I) * (1. - SIGMAF(I)) * PARTLND(I) + ENDIF + ENDDO + ! + ! calculate stomatal resistance + ! + DO I = 1, IM + if(FLAG(I)) then + ! + ! resistance due to PAR. We use net solar flux as proxy at the present time + ! + ff = .55 * 2. * SNET(I) / rgl(VEGTYPE(I)) + rcs = (ff + RS(I)/rsmax(VEGTYPE(I))) / (1. + ff) + rcs = max(rcs,.0001_kind_phys) + rct = 1. + rcq = 1. + ! + ! resistance due to thermal effect + ! + ! rct = 1. - .0016 * (topt - theta1) ** 2 + ! rct = max(rct,.0001) + ! + ! resistance due to humidity + ! + ! rcq = 1. / (1. + hs(VEGTYPE(I)) * (QS1(I) - Q0(I))) + ! rcq = max(rcq,.0001) + ! + ! compute resistance without the effect of soil moisture + ! + RS(I) = RS(I) / (rcs * rct * rcq) + endif + ENDDO + ! + ! TRANSPIRATION FROM ALL LEVELS OF THE SOIL + ! + DO I = 1, IM + IF(FLAG(I)) THEN + CANFAC(I) = (CANOPY(I) / SCANOP) ** CFACTR + endif + IF(FLAG(I)) THEN + ETPFAC(I) = SIGMAF(I) & + & * (1. - CANFAC(I)) / HVAP + GX(I) = (SMC(I,1) - TWILT(I)) / (TREF(I) - TWILT(I)) + GX(I) = MAX(GX(I),0._kind_phys) + GX(I) = MIN(GX(I),1._kind_phys) + ! + ! resistance due to soil moisture deficit + ! + rss = GX(I) * (ZSOIL(I,1) / ZSOIL(I,km)) + rss = max(rss,.0001_kind_phys) + RSI = RS(I) / rss + ! + ! transpiration a la Monteith + ! + eth = (TERM1(I) + TERM2(I)) / & + & (DELTA(I) + RSMALL(I) * (1. + RSI * CH(I) * WIND(I))) + ET(I,1) = ETPFAC(I) * eth & + & * PARTLND(I) + ENDIF + ENDDO + !! + DO K = 2, KM + DO I=1,IM + IF(FLAG(I)) THEN + GX(I) = (SMC(I,K) - TWILT(I)) / (TREF(I) - TWILT(I)) + GX(I) = MAX(GX(I),0._kind_phys) + GX(I) = MIN(GX(I),1._kind_phys) + ! + ! resistance due to soil moisture deficit + ! + rss = GX(I) * ((ZSOIL(I,k) - ZSOIL(I,k-1))/ZSOIL(I,km)) + rss = max(rss,1.e-6_kind_phys) + RSI = RS(I) / rss + ! + ! transpiration a la Monteith + ! + eth = (TERM1(I) + TERM2(I)) / & + & (DELTA(I) + RSMALL(I) * (1. + RSI * CH(I) * WIND(I))) + ET(I,K) = eth & + & * ETPFAC(I) * PARTLND(I) + ENDIF + ENDDO + ENDDO + !! + 400 CONTINUE + ! + ! CANOPY RE-EVAPORATION + ! + DO I=1,IM + IF(FLAG(I)) THEN + EC(I) = SIGMAF(I) * CANFAC(I) * EP(I) / HVAP + EC(I) = EC(I) * PARTLND(I) + EC(I) = min(EC(I),CANOPY(I)/delt) + ENDIF + ENDDO + ! + ! SUM UP TOTAL EVAPORATION + ! + DO I = 1, IM + IF(FLAG(I)) THEN + EVAP(I) = EDIR(I) + EC(I) + ENDIF + ENDDO + !! + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + EVAP(I) = EVAP(I) + ET(I,K) + ENDIF + ENDDO + ENDDO + !! + ! + ! RETURN EVAP UNIT FROM KG M-2 S-1 TO WATTS M-2 + ! + DO I=1,IM + IF(FLAG(I)) THEN + EVAP(I) = MIN(EVAP(I)*HVAP,EP(I)) + ENDIF + ENDDO + !##DG IF(LAT.EQ.LATD) THEN + !##DG PRINT *, 'FX(I), SIGMAF, EDIR(I), ETPFAC=', FX(I)*HVAP,SIGMAF, + !##DG& EDIR(I)*HVAP,ETPFAC*HVAP + !##DG PRINT *, ' ET =', (ET(K)*HVAP,K=1,KM) + !##DG PRINT *, ' CANFAC(I), EC(I), EVAP', CANFAC(I),EC(I)*HVAP,EVAP + !##DG ENDIF + ! + ! EVAPORATION OVER BARE SEA ICE + ! + DO I = 1, IM + ! IF(SLIMSK(I).EQ.2.AND.SNOWD(I).LE..001) THEN + IF(SLIMSK(I).EQ.2.) THEN + EVAP(I) = PARTLND(I) * EP(I) + ENDIF + ENDDO + ! + ! TREAT DOWNWARD MOISTURE FLUX SITUATION + ! (EVAP WAS PRESET TO ZERO SO NO UPDATE NEEDED) + ! DEW IS CONVERTED FROM KG M-2 TO M TO CONFORM TO PRECIP UNIT + ! + DO I = 1, IM + FLAG(I) = SLIMSK(I).NE.0..AND.EP(I).LE.0. + DEW(I) = 0. + ENDDO + DO I = 1, IM + IF(FLAG(I)) THEN + DEW(I) = -EP(I) * DELT / (HVAP * RHOH2O) + EVAP(I) = EP(I) + DEW(I) = DEW(I) * PARTLND(I) + EVAP(I) = EVAP(I) * PARTLND(I) + DM(I) = 1. + ENDIF + ENDDO + ! + ! SNOW COVERED LAND AND SEA ICE + ! + DO I = 1, IM + FLAG(I) = SLIMSK(I).NE.0..AND.SNOWD(I).GT.0. + ENDDO + ! + ! CHANGE OF SNOW DEPTH DUE TO EVAPORATION OR SUBLIMATION + ! + ! CONVERT EVAP FROM KG M-2 S-1 TO M S-1 TO DETERMINE THE REDUCTION OF S + ! + DO I = 1, IM + IF(FLAG(I)) THEN + BFACT = SNOWD(I) / (DELT * EP(I) / (HVAP * RHOH2O)) + BFACT = MIN(BFACT,1._kind_phys) + ! + ! THE EVAPORATION OF SNOW + ! + IF(EP(I).LE.0.) BFACT = 1. + IF(SNOWD(I).LE..001) THEN + ! EVAP = (SNOWD(I)/.001)*BFACT*EP(I) + EVAP + ! SNOEVP(I) = bfact * EP(I) * (1. - PARTLND(I)) + ! EVAP = EVAP + SNOEVP(I) + SNOEVP(I) = bfact * EP(I) + ! EVAP = EVAP + SNOEVP(I) * (1. - PARTLND(I)) + EVAP(I)=EVAP(I)+SNOEVP(I)*(1.-PARTLND(I)) + ELSE + ! EVAP(I) = BFACT * EP(I) + SNOEVP(I) = bfact * EP(I) + EVAP(I) = SNOEVP(I) + ENDIF + TSURF(I) = T1(I) + & + & (RCAP(I) - GFLUX(I) - DFSNOW * (T1(I) - STSOIL(I,1)) & + & /(FACTSNW(I) * MAX(SNOWD(I),.001_kind_phys)) & + ! & + THETA1 - T1 & + ! & - BFACT * EP(I)) / (RSMALL(I) * RCH(I) & + & - SNOEVP(I)) / (RSMALL(I) * RCH(I) & + & + DFSNOW / (FACTSNW(I)* MAX(SNOWD(I),.001_kind_phys))) + ! SNOWD(I) = SNOWD(I) - BFACT * EP(I) * DELT / (RHOH2O * HVAP) + SNOWD(I) = SNOWD(I) - SNOEVP(I) * delt / (rhoh2o * hvap) + SNOWD(I) = MAX(SNOWD(I),0._kind_phys) + ENDIF + ENDDO + ! + ! SNOW MELT (M) + ! + 500 CONTINUE + DO I = 1, IM + FLAG(I) = SLIMSK(I).NE.0. & + & .AND.SNOWD(I).GT..0 + ENDDO + DO I = 1, IM + IF(FLAG(I).AND.TSURF(I).GT.T0C) THEN + SNOWMT(I) = RCH(I) * RSMALL(I) * DELT & + & * (TSURF(I) - T0C) / (RHOH2O * HFUS) + SNOWMT(I) = min(SNOWMT(I),SNOWD(I)) + SNOWD(I) = SNOWD(I) - SNOWMT(I) + SNOWD(I) = MAX(SNOWD(I),0._kind_phys) + TSURF(I) = MAX(T0C,TSURF(I) & + & -HFUS*SNOWMT(I)*RHOH2O/(RCH(I)*RSMALL(I)*DELT)) + ENDIF + ENDDO + ! + ! We need to re-evaluate evaporation because of snow melt + ! the skin temperature is now bounded to 0 deg C + ! + ! qss = fpvs(tsurf) + DO I = 1, IM + ! IF (SNOWD(I) .GT. 0.0) THEN + IF (SNOWD(I) .GT. snomin) THEN + !jfe QSS(I) = 1000. * FPVS(TSURF(I)) + qss(i) = fpvs(tsurf(i)) + QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) + EVAP(I) = elocp * RCH(I) * (QSS(I) - Q0(I)) + ENDIF + ENDDO + ! + ! PREPARE TENDENCY TERMS FOR THE SOIL MOISTURE FIELD WITHOUT PRECIPITAT + ! THE UNIT OF MOISTURE FLUX NEEDS TO BECOME M S-1 FOR SOIL MOISTURE + ! HENCE THE FACTOR OF RHOH2O + ! + DO I = 1, IM + FLAG(I) = SLIMSK(I).EQ.1. + if(FLAG(I)) then + DF1(I) = FUNCDF(SMCZ(I),SOILTYP(I)) + KT1(I) = FUNCKT(SMCZ(I),SOILTYP(I)) + endif + if(FLAG(I).and.STC(I,1).lt.t0c) then + DF1(I) = 0. + KT1(I) = 0. + endif + IF(FLAG(I)) THEN + RHSCNPY(I) = -EC(I) + SIGMAF(I) * RHOH2O * DEW(I) / DELT + SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) + DMDZ(I) = (SMC(I,1) - SMC(I,2)) / (-.5 * ZSOIL(I,2)) + RHSMC(I,1) = (DF1(I) * DMDZ(I) + KT1(I) & + & + (EDIR(I) + ET(I,1))) / (ZSOIL(I,1) * RHOH2O) + RHSMC(I,1) = RHSMC(I,1) - (1. - SIGMAF(I)) * DEW(I) / & + & ( ZSOIL(I,1) * delt) + DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) + ! + ! AIM, BIM, AND CIM ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE + ! IMPLICIT UPDATE OF THE SOIL MOISTURE + ! + AIM(I,1) = 0. + BIM(I,1) = DF1(I) * DDZ(I) / (-ZSOIL(I,1) * RHOH2O) + CIM(I,1) = -BIM(I,1) + ENDIF + ENDDO + !! + DO K = 2, KM + IF(K.LT.KM) THEN + DO I=1,IM + IF(FLAG(I)) THEN + DF2 = FUNCDF(SMCZ(I),SOILTYP(I)) + KT2(I) = FUNCKT(SMCZ(I),SOILTYP(I)) + ENDIF + IF(FLAG(I).and.STC(I,k).lt.t0c) THEN + df2 = 0. + KT2(I) = 0. + ENDIF + IF(FLAG(I)) THEN + DMDZ2(I) = (SMC(I,K) - SMC(I,K+1)) & + & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) + SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) + RHSMC(I,K) = (DF2 * DMDZ2(I) + KT2(I) & + & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) & + & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) + DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) + CIM(I,K) = -DF2 * DDZ2(I) & + & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) + ENDIF + ENDDO + ELSE + DO I = 1, IM + IF(FLAG(I)) THEN + KT2(I) = FUNCKT(SMC(I,K),SOILTYP(I)) + ENDIF + if(FLAG(I).and.STC(I,k).lt.t0c) KT2(I) = 0. + IF(FLAG(I)) THEN + RHSMC(I,K) = (KT2(I) & + & - DF1(I) * DMDZ(I) - KT1(I) + ET(I,K)) & + & / (RHOH2O*(ZSOIL(I,K) - ZSOIL(I,K-1))) + DRAIN(I) = KT2(I) + CIM(I,K) = 0. + ENDIF + ENDDO + ENDIF + DO I = 1, IM + IF(FLAG(I)) THEN + AIM(I,K) = -DF1(I) * DDZ(I) & + & / ((ZSOIL(I,K-1) - ZSOIL(I,K))*RHOH2O) + BIM(I,K) = -(AIM(I,K) + CIM(I,K)) + DF1(I) = DF2 + KT1(I) = KT2(I) + DMDZ(I) = DMDZ2(I) + DDZ(I) = DDZ2(I) + ENDIF + ENDDO + ENDDO + !! + 600 CONTINUE + ! + ! UPDATE SOIL TEMPERATURE AND SEA ICE TEMPERATURE + ! + DO I=1,IM + FLAG(I) = SLIMSK(I).NE.0. + ENDDO + ! + ! SURFACE TEMPERATURE IS PART OF THE UPDATE WHEN SNOW IS ABSENT + ! + DO I=1,IM + ! IF(FLAG(I).AND.SNOWD(I).LE..001) THEN + IF(FLAG(I).AND..NOT.FLAGSNW(I)) THEN + YY(I) = T1(I) + & + ! & (RCAP(I)-GFLUX(I) + THETA1 - T1(I) & + & (RCAP(I)-GFLUX(I) & + & - EVAP(I)) / (RSMALL(I) * RCH(I)) + ZZ(I) = 1. + DFT0(I) / (-.5 * ZSOIL(I,1) * RCH(I) * RSMALL(I)) + XX(I) = DFT0(I) * (STSOIL(I,1) - YY(I)) / & + & (.5 * ZSOIL(I,1) * ZZ(I)) + ENDIF + ! IF(FLAG(I).AND.SNOWD(I).GT..001) THEN + IF(FLAG(I).AND.FLAGSNW(I)) THEN + YY(I) = STSOIL(I,1) + ! + ! HEAT FLUX FROM SNOW IS EXPLICIT IN TIME + ! + ZZ(I) = 1. + XX(I) = DFSNOW * (STSOIL(I,1) - TSURF(I)) & + & / (-FACTSNW(I) * MAX(SNOWD(I),.001_kind_phys)) + ENDIF + ENDDO + ! + ! COMPUTE THE FORCING AND THE IMPLICIT MATRIX ELEMENTS FOR UPDATE + ! + ! CH2O IS THE HEAT CAPACITY OF WATER AND CSOIL IS THE HEAT CAPACITY OF + ! + DO I = 1, IM + IF(FLAG(I)) THEN + SMCZ(I) = MAX(SMC(I,1), SMC(I,2)) + DTDZ1(I) = (STSOIL(I,1) - STSOIL(I,2)) / (-.5 * ZSOIL(I,2)) + IF(SLIMSK(I).EQ.1.) THEN + DFT1(I) = KTSOIL(SMCZ(I),SOILTYP(I)) + HCPCT(I) = SMC(I,1) * CH2O + (1. - SMC(I,1)) * CSOIL + ELSE + DFT1(I) = DFT0(I) + HCPCT(I) = CICE + ENDIF + DFT2(I) = DFT1(I) + DDZ(I) = 1. / (-.5 * ZSOIL(I,2)) + ! + ! AI, BI, AND CI ARE THE ELEMENTS OF THE TRIDIAGONAL MATRIX FOR THE + ! IMPLICIT UPDATE OF THE SOIL TEMPERATURE + ! + AI(I,1) = 0. + BI(I,1) = DFT1(I) * DDZ(I) / (-ZSOIL(I,1) * HCPCT(I)) + CI(I,1) = -BI(I,1) + BI(I,1) = BI(I,1) & + & + DFT0(I) / (.5 * ZSOIL(I,1) **2 * HCPCT(I) * ZZ(I)) + ! SS = DFT0(I) * (STSOIL(I,1) - YY(I)) & + ! & / (.5 * ZSOIL(I,1) * ZZ(I)) + ! RHSTC(1) = (DFT1(I) * DTDZ1(I) - SS) + RHSTC(I,1) = (DFT1(I) * DTDZ1(I) - XX(I)) & + & / (ZSOIL(I,1) * HCPCT(I)) + ENDIF + ENDDO + !! + DO K = 2, KM + DO I=1,IM + IF(SLIMSK(I).EQ.1.) THEN + HCPCT(I) = SMC(I,K) * CH2O + (1. - SMC(I,K)) * CSOIL + ELSEIF(SLIMSK(I).EQ.2.) THEN + HCPCT(I) = CICE + ENDIF + ENDDO + IF(K.LT.KM) THEN + DO I = 1, IM + IF(FLAG(I)) THEN + DTDZ2(I) = (STSOIL(I,K) - STSOIL(I,K+1)) & + & / (.5 * (ZSOIL(I,K-1) - ZSOIL(I,K+1))) + SMCZ(I) = MAX(SMC(I,K), SMC(I,K+1)) + IF(SLIMSK(I).EQ.1.) THEN + DFT2(I) = KTSOIL(SMCZ(I),SOILTYP(I)) + ENDIF + DDZ2(I) = 2. / (ZSOIL(I,K-1) - ZSOIL(I,K+1)) + CI(I,K) = -DFT2(I) * DDZ2(I) & + & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) + ENDIF + ENDDO + ELSE + ! + ! AT THE BOTTOM, CLIMATOLOGY IS ASSUMED AT 2M DEPTH FOR LAND AND + ! FREEZING TEMPERATURE IS ASSUMED FOR SEA ICE AT Z(KM) + DO I = 1, IM + IF(SLIMSK(I).EQ.1.) THEN + DTDZ2(I) = (STSOIL(I,K) - TG3(I)) & + & / (.5 * (ZSOIL(I,K-1) + ZSOIL(I,K)) - ZBOT) + DFT2(I) = KTSOIL(SMC(I,K),SOILTYP(I)) + CI(I,K) = 0. + ENDIF + IF(SLIMSK(I).EQ.2.) THEN + DTDZ2(I) = (STSOIL(I,K) - TGICE) & + & / (.5 * ZSOIL(I,K-1) - .5 * ZSOIL(I,K)) + DFT2(I) = DFT1(I) + CI(I,K) = 0. + ENDIF + ENDDO + ENDIF + DO I = 1, IM + IF(FLAG(I)) THEN + RHSTC(I,K) = (DFT2(I) * DTDZ2(I) - DFT1(I) * DTDZ1(I)) & + & / ((ZSOIL(I,K) - ZSOIL(I,K-1)) * HCPCT(I)) + AI(I,K) = -DFT1(I) * DDZ(I) & + & / ((ZSOIL(I,K-1) - ZSOIL(I,K)) * HCPCT(I)) + BI(I,K) = -(AI(I,K) + CI(I,K)) + DFT1(I) = DFT2(I) + DTDZ1(I) = DTDZ2(I) + DDZ(I) = DDZ2(I) + ENDIF + ENDDO + ENDDO + !! + 700 CONTINUE + ! + ! SOLVE THE TRI-DIAGONAL MATRIX + ! + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + RHSTC(I,K) = RHSTC(I,K) * DELT2 + AI(I,K) = AI(I,K) * DELT2 + BI(I,K) = 1. + BI(I,K) * DELT2 + CI(I,K) = CI(I,K) * DELT2 + ENDIF + ENDDO + ENDDO + ! FORWARD ELIMINATION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,1) = -CI(I,1) / BI(I,1) + RHSTC(I,1) = RHSTC(I,1) / BI(I,1) + ENDIF + ENDDO + !! + DO K = 2, KM + DO I=1,IM + IF(FLAG(I)) THEN + CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) + CI(I,K) = -CI(I,K) * CC + RHSTC(I,K) = (RHSTC(I,K) - AI(I,K) * RHSTC(I,K-1)) * CC + ENDIF + ENDDO + ENDDO + !! + ! BACKWARD SUBSTITUTTION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,KM) = RHSTC(I,KM) + ENDIF + ENDDO + !! + DO K = KM-1, 1 + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,K) = CI(I,K) * CI(I,K+1) + RHSTC(I,K) + ENDIF + ENDDO + ENDDO + ! + ! UPDATE SOIL AND ICE TEMPERATURE + ! + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + STSOIL(I,K) = STSOIL(I,K) + CI(I,K) + ENDIF + ENDDO + ENDDO + ! + ! UPDATE SURFACE TEMPERATURE FOR SNOW FREE SURFACES + ! + DO I=1,IM + ! IF(SLIMSK(I).NE.0..AND.SNOWD(I).LE..001) THEN + IF(SLIMSK(I).NE.0..AND..NOT.FLAGSNW(I)) THEN + TSURF(I) = (YY(I) + (ZZ(I) - 1.) * STSOIL(I,1)) / ZZ(I) + ENDIF + ! IF(SLIMSK(I).EQ.2..AND.SNOWD(I).LE..001) THEN + IF(SLIMSK(I).EQ.2..AND..NOT.FLAGSNW(I)) THEN + TSURF(I) = MIN(TSURF(I),T0C) + ENDIF + ENDDO + !! + DO K = 1, KM + DO I=1,IM + IF(SLIMSK(I).EQ.2) THEN + STSOIL(I,K) = MIN(STSOIL(I,K),T0C) + ENDIF + ENDDO + ENDDO + ! + ! TIME FILTER FOR SOIL AND SKIN TEMPERATURE + ! + DO I=1,IM + IF(SLIMSK(I).NE.0.) THEN + TSKIN(I) = CTFIL1 * TSURF(I) + CTFIL2 * TSKIN(I) + ENDIF + ENDDO + DO K = 1, KM + DO I=1,IM + IF(SLIMSK(I).NE.0.) THEN + STC(I,K) = CTFIL1 * STSOIL(I,K) + CTFIL2 * STC(I,K) + ENDIF + ENDDO + ENDDO + ! + ! GFLUX CALCULATION + ! + DO I=1,IM + FLAG(I) = SLIMSK(I).NE.0. & + ! & .AND.SNOWD(I).GT..001 & + & .AND.FLAGSNW(I) + ENDDO + DO I = 1, IM + IF(FLAG(I)) THEN + GFLUX(I) = -DFSNOW * (TSKIN(I) - STC(I,1)) & + & / (FACTSNW(I) * MAX(SNOWD(I),.001_kind_phys)) + ENDIF + ENDDO + DO I = 1, IM + ! IF(SLIMSK(I).NE.0..AND.SNOWD(I).LE..001) THEN + IF( SLIMSK(I).NE.0..AND..NOT.FLAGSNW(I)) THEN + GFLUX(I) = DFT0(I) * (STC(I,1) - TSKIN(I)) & + & / (-.5 * ZSOIL(I,1)) + ENDIF + ENDDO + + +5555 CONTINUE + + ! + ! CALCULATE SENSIBLE HEAT FLUX + ! +!WRF DO I = 1, IM +!WRF HFLX(I) = RCH(I) * (TSKIN(I) - THETA1(I)) +!WRF ENDDO + ! + ! THE REST OF THE OUTPUT + ! +!WRF DO I = 1, IM +!WRF QSURF(I) = Q1(I) + EVAP(I) / (ELOCP * RCH(I)) +!WRF DM(I) = 1. + ! + ! CONVERT SNOW DEPTH BACK TO MM OF WATER EQUIVALENT + ! +!WRF SHELEG(I) = SNOWD(I) * 1000. +!WRF ENDDO + ! + + DO I = 1, IM + F10M(I) = FM10(I) / FM(I) + F10M(I) = min(F10M(I),1._kind_phys) + U10M(I) = F10M(I) * XRCL(I) * U1(I) + V10M(I) = F10M(I) * XRCL(I) * V1(I) +!WRF T2M(I) = TSKIN(I) * (1. - FH2(I) / FH(I)) & +!WRF & + THETA1(I) * FH2(I) / FH(I) +!WRF T2M(I) = T2M(I) * SIG2K +! Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) & +! & + Q1(I) * FH2(I) / FH(I) +! T2M(I) = T1 +! Q2M(I) = Q1 +!WRF IF(EVAP(I).GE.0.) THEN +! +! IN CASE OF EVAPORATION, USE THE INFERRED QSURF TO DEDUCE Q2M +! +!WRF Q2M(I) = QSURF(I) * (1. - FH2(I) / FH(I)) & +!WRF & + Q1(I) * FH2(I) / FH(I) +!WRF ELSE +! +! FOR DEW FORMATION SITUATION, USE SATURATED Q AT TSKIN +! +!jfe QSS(I) = 1000. * FPVS(TSKIN(I)) +!WRF qss(I) = fpvs(tskin(I)) +!WRF QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) +!WRF Q2M(I) = QSS(I) * (1. - FH2(I) / FH(I)) & +!WRF & + Q1(I) * FH2(I) / FH(I) +!WRF ENDIF +!jfe QSS(I) = 1000. * FPVS(T2M(I)) +!WRF QSS(I) = fpvs(t2m(I)) +! QSS(I) = 1000. * T2MO(I) +!WRF QSS(I) = EPS * QSS(I) / (PSURF(I) + EPSM1 * QSS(I)) +!WRF Q2M(I) = MIN(Q2M(I),QSS(I)) + ENDDO +!! +! DO I = 1, IM +! RNET(I) = -SLWD(I) - SIGMA * TSKIN(I) **4 +! ENDDO +!! +! +!WRF do i=1,im +!WRF tem = 1.0 / rho(i) +!WRF hflx(i) = hflx(i) * tem * cpinv +!WRF evap(i) = evap(i) * tem * hvapi +!WRF enddo + + +! +!##DG IF(LAT.EQ.LATD) THEN +!C RBAL = -SLWD-SIGMA*TSKIN**4+GFLUX +!C & -EVAP - HFLX +!##DG PRINT 6000,HFLX,EVAP,GFLUX, +!##DG& STC(1), STC(2),TSKIN,RNET,SLWD +!##DG PRINT *, ' T1 =', T1 + 6000 FORMAT(8(F8.2,',')) +!C PRINT *, ' EP, ETP,T2M(I) =', EP, ETP,T2M(I) +!C PRINT *, ' FH, FH2 =', FH, FH2 +!C PRINT *, ' PH, PH2 =', PH, PH2 +!C PRINT *, ' CH, RCH =', CH, RCH +!C PRINT *, ' TERM1, TERM2 =', TERM1, TERM2 +!C PRINT *, ' RS(I), PLANTR =', RS(I), PLANTR +!##DG ENDIF + + RETURN + END SUBROUTINE PROGTM +! +! PROGT2 IS THE SECOND PART OF THE SOIL MODEL THAT IS EXECUTED +! AFTER PRECIPITATION FOR THE TIME STEP HAS BEEN CALCULATED +! +!FPP$ NOCONCUR R +!FPP$ EXPAND(FUNCDF,FUNCKT,THSAT) + SUBROUTINE PROGT2(IM,KM,RHSCNPY, & + & RHSMC,AI,BI,CI,SMC,SLIMSK, & + & CANOPY,PRECIP,RUNOFF,SNOWMT, & + & ZSOIL,SOILTYP,SIGMAF,DELT,me) +!c + USE MODULE_GFS_MACHINE , ONLY : kind_phys + implicit none + integer km, IM, me + real(kind=kind_phys) delt + real(kind=kind_phys) RHSCNPY(IM), RHSMC(IM,KM), AI(IM,KM), & + & BI(IM,KM), CI(IM,KM), SMC(IM,KM), & + & SLIMSK(IM), CANOPY(IM), PRECIP(IM), & + & RUNOFF(IM), SNOWMT(IM), ZSOIL(IM,KM), & + & SIGMAF(IM) + INTEGER SOILTYP(IM) +! + integer k, lond, i + real(kind=kind_phys) CNPY(IM), PRCP(IM), TSAT(IM), & + & INF(IM), INFMAX(IM), SMSOIL(IM,KM) +! + real(kind=kind_phys) cc, ctfil1, ctfil2, delt2, & + & drip, rffact, rhoh2o, & +!WRF & rzero, scanop, tdif, thsat, KSAT + & rzero, scanop, tdif, KSAT +! + LOGICAL FLAG(IM) +!c + PARAMETER (SCANOP=.5, RHOH2O=1000.) + PARAMETER (CTFIL1=.5, CTFIL2=1.-CTFIL1) +! PARAMETER (CTFIL1=1., CTFIL2=1.-CTFIL1) + PARAMETER (RFFACT=.15) +! +!##DG LATD = 44 + LOND = 353 + DELT2 = DELT * 2. +! +! PRECIPITATION RATE IS NEEDED IN UNIT OF KG M-2 S-1 +! + DO I=1,IM + PRCP(I) = RHOH2O * (PRECIP(I)+SNOWMT(I)) / DELT + RUNOFF(I) = 0. + CNPY(I) = CANOPY(I) + ENDDO +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' BEFORE RUNOFF CAL, RHSMC =', RHSMC(1) +!##DG ENDIF +! +! UPDATE CANOPY WATER CONTENT +! + DO I=1,IM + IF(SLIMSK(I).EQ.1.) THEN + RHSCNPY(I) = RHSCNPY(I) + SIGMAF(I) * PRCP(I) + CANOPY(I) = CANOPY(I) + DELT * RHSCNPY(I) + CANOPY(I) = MAX(CANOPY(I),0._kind_phys) + PRCP(I) = PRCP(I) * (1. - SIGMAF(I)) + IF(CANOPY(I).GT.SCANOP) THEN + DRIP = CANOPY(I) - SCANOP + CANOPY(I) = SCANOP + PRCP(I) = PRCP(I) + DRIP / DELT + ENDIF +! +! CALCULATE INFILTRATION RATE +! + INF(I) = PRCP(I) + TSAT(I) = THSAT(SOILTYP(I)) +! DSAT = FUNCDF(TSAT(I),SOILTYP(I)) +! KSAT = FUNCKT(TSAT(I),SOILTYP(I)) +! INFMAX(I) = -DSAT * (TSAT(I) - SMC(I,1)) +! & / (.5 * ZSOIL(I,1)) & +! & + KSAT + INFMAX(I) = (-ZSOIL(I,1)) * & + & ((TSAT(I) - SMC(I,1)) / DELT - RHSMC(I,1)) & + & * RHOH2O + INFMAX(I) = MAX(RFFACT*INFMAX(I),0._kind_phys) +! IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = KSAT +! IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = ZSOIL(I,1) * RHSMC(I,1) + IF(INF(I).GT.INFMAX(I)) THEN + RUNOFF(I) = INF(I) - INFMAX(I) + INF(I) = INFMAX(I) + ENDIF + INF(I) = INF(I) / RHOH2O + RHSMC(I,1) = RHSMC(I,1) - INF(I) / ZSOIL(I,1) + ENDIF + ENDDO +!! +!##DG IF(LAT.EQ.LATD) THEN +!##DG PRINT *, ' PRCP(I), INFMAX(I), RUNOFF =', PRCP(I),INFMAX(I),RUNOFF +!##DG PRINT *, ' SMSOIL =', SMC(1), SMC(2) +!##DG PRINT *, ' RHSMC =', RHSMC(1) +!##DG ENDIF +! +! WE CURRENTLY IGNORE THE EFFECT OF RAIN ON SEA ICE +! + DO I=1,IM + FLAG(I) = SLIMSK(I).EQ.1. + ENDDO +!! +! +! SOLVE THE TRI-DIAGONAL MATRIX +! + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + RHSMC(I,K) = RHSMC(I,K) * DELT2 + AI(I,K) = AI(I,K) * DELT2 + BI(I,K) = 1. + BI(I,K) * DELT2 + CI(I,K) = CI(I,K) * DELT2 + ENDIF + ENDDO + ENDDO +! FORWARD ELIMINATION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,1) = -CI(I,1) / BI(I,1) + RHSMC(I,1) = RHSMC(I,1) / BI(I,1) + ENDIF + ENDDO + DO K = 2, KM + DO I=1,IM + IF(FLAG(I)) THEN + CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) + CI(I,K) = -CI(I,K) * CC + RHSMC(I,K)=(RHSMC(I,K)-AI(I,K)*RHSMC(I,K-1))*CC + ENDIF + ENDDO + ENDDO +! BACKWARD SUBSTITUTTION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,KM) = RHSMC(I,KM) + ENDIF + ENDDO +!! + DO K = KM-1, 1 + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,K) = CI(I,K) * CI(I,K+1) + RHSMC(I,K) + ENDIF + ENDDO + ENDDO + 100 CONTINUE +! +! UPDATE SOIL MOISTURE +! + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + SMSOIL(I,K) = SMC(I,K) + CI(I,K) + SMSOIL(I,K) = MAX(SMSOIL(I,K),0._kind_phys) + TDIF = MAX(SMSOIL(I,K) - TSAT(I),0._kind_phys) + RUNOFF(I) = RUNOFF(I) - & + & RHOH2O * TDIF * ZSOIL(I,K) / DELT + SMSOIL(I,K) = SMSOIL(I,K) - TDIF + ENDIF + ENDDO + ENDDO + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + SMC(I,K) = CTFIL1 * SMSOIL(I,K) + CTFIL2 * SMC(I,K) + ENDIF + ENDDO + ENDDO +! IF(FLAG(I)) THEN +! CANOPY(I) = CTFIL1 * CANOPY(I) + CTFIL2 * CNPY(I) +! ENDIF +! I = 1 +! PRINT *, ' SMC' +! PRINT 6000, SMC(1), SMC(2) +!6000 FORMAT(2(F8.5,',')) + RETURN + END SUBROUTINE PROGT2 + FUNCTION KTSOIL(THETA,KTYPE) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, DFKT + implicit none + integer ktype,kw + real(kind=kind_phys) ktsoil, theta, w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + KTSOIL = DFKT(KW,KTYPE) & + & + (W - KW) * (DFKT(KW+1,KTYPE) - DFKT(KW,KTYPE)) + RETURN + END FUNCTION KTSOIL + FUNCTION FUNCDF(THETA,KTYPE) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, DFK + implicit none + integer ktype,kw + real(kind=kind_phys) funcdf,theta,w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + FUNCDF = DFK(KW,KTYPE) & + & + (W - KW) * (DFK(KW+1,KTYPE) - DFK(KW,KTYPE)) + RETURN + END FUNCTION FUNCDF + FUNCTION FUNCKT(THETA,KTYPE) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, KTK + implicit none + integer ktype,kw + real(kind=kind_phys) funckt,theta,w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + FUNCKT = KTK(KW,KTYPE) & + & + (W - KW) * (KTK(KW+1,KTYPE) - KTK(KW,KTYPE)) + RETURN + END FUNCTION FUNCKT + FUNCTION THSAT(KTYPE) +! + USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT + implicit none + integer ktype + real(kind=kind_phys) thsat +! + THSAT = TSAT(KTYPE) + RETURN + END FUNCTION THSAT + FUNCTION TWLT(KTYPE) + + USE MODULE_GFS_MACHINE , ONLY : kind_phys +! USE module_progtm + implicit none + integer ktype + real(kind=kind_phys) twlt +! + TWLT = .1 + RETURN + END FUNCTION TWLT + + END MODULE module_sf_gfs diff --git a/wrfv2_fire/phys/module_sf_lsm_nmm.F b/wrfv2_fire/phys/module_sf_lsm_nmm.F new file mode 100644 index 00000000..1b273059 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_lsm_nmm.F @@ -0,0 +1,5615 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE MODULE_SF_LSM_NMM + +USE MODULE_MPP +USE MODULE_MODEL_CONSTANTS + + REAL, SAVE :: SCFX(30) + + INTEGER, SAVE :: ISEASON + CHARACTER*256 :: errmess + +CONTAINS + +!----------------------------------------------------------------------- + SUBROUTINE NMMLSM(DZ8W,QV3D,P8W3D,RHO3D, & + & T3D,TH3D,TSK,CHS, & + & HFX,QFX,QGH,GSW,GLW,ELFLX,RMOL, & ! added for WRF CHEM + & SMSTAV,SMSTOT,SFCRUNOFF, & + & UDRUNOFF,IVGTYP,ISLTYP,VEGFRA,SFCEVP,POTEVP, & + & GRDFLX,SFCEXC,ACSNOW,ACSNOM,SNOPCX, & + & ALBSF,TMN,XLAND,XICE,QZ0, & + & TH2,Q2,SNOWC,CHS2,QSFC,TBOT,CHKLOWQ,RAINBL, & + & NUM_SOIL_LAYERS,DT,DZS,ITIMESTEP, & + & SMOIS,TSLB,SNOW,CANWAT,CPM,ROVCP,SR, & + & ALB,SNOALB,SMLIQ,SNOWH, & + & IDS,IDE, JDS,JDE, KDS,KDE, & + & IMS,IME, JMS,JME, KMS,KME, & + & ITS,ITE, JTS,JTE, KTS,KTE ) +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!-- DZ8W thickness of layers (m) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P8W3D 3D pressure on layer interfaces (Pa) +!-- FLHC exchange coefficient for heat (m/s) +!-- FLQC exchange coefficient for moisture (m/s) +!-- PSFC surface pressure (Pa) +!-- XLAND land mask (1 for land, 2 for water) +!-- TMN soil temperature at lower boundary (K) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- TSK surface temperature (K) +!-- GSW NET downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- ELFLX actual latent heat flux (w m-2: positive, if up from surface) +!-- SFCEVP accumulated surface evaporation (W/m^2) +!-- POTEVP accumulated potential evaporation (W/m^2) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- THC thermal inertia (Cal/cm/K/s^0.5) +!-- TBOT bottom soil temperature (local yearly-mean sfc air temperature) +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- EMISS surface emissivity (between 0 and 1) +!-- DELTSM time step (second) +!-- ROVCP R/CP +!-- SR fraction of frozen precip (0.0 to 1.0) +!-- XLV latent heat of melting (J/kg) +!-- DTMIN time step (minute) +!-- IFSNOW ifsnow=1 for snow-cover effects +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) +!-- SVPT0 constant for saturation vapor pressure (K) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- EP2 constant for specific humidity calculation +! (R_d/R_v) (dimensionless) +!-- KARMAN Von Karman constant +!-- EOMEG angular velocity of earth's rotation (rad/s) +!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) +!-- STEM soil temperature in 5-layer model +!-- ZS depths of centers of soil layers +!-- DZS thicknesses of soil layers +!-- num_soil_layers the number of soil layers +!-- ACSNOW accumulated snowfall (water equivalent) (mm) +!-- ACSNOM accumulated snowmelt (water equivalent) (mm) +!-- SNOPCX snow phase change heat flux (W/m^2) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!----------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: NUM_SOIL_LAYERS,ITIMESTEP +! + REAL,INTENT(IN) :: DT,ROVCP +! + REAL,DIMENSION(IMS:IME,1:NUM_SOIL_LAYERS,JMS:JME), & + & INTENT(INOUT) :: SMOIS, & ! new + SMLIQ, & ! new + TSLB ! + + REAL,DIMENSION(1:NUM_SOIL_LAYERS),INTENT(IN) :: DZS +! + REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & + & TSK, & !was TGB (temperature) + & HFX, & + & QFX, & + & QSFC,& + & SNOW, & !new + & SNOWH, & !new + & ALB, & + & SNOALB, & + & ALBSF, & + & SNOWC, & + & CANWAT, & ! new + & SMSTAV, & + & SMSTOT, & + & SFCRUNOFF, & + & UDRUNOFF, & + & SFCEVP, & + & POTEVP, & + & GRDFLX, & + & ACSNOW, & + & ACSNOM, & + & SNOPCX, & + & Q2, & + & TH2, & + & SFCEXC + + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IVGTYP, & + ISLTYP + + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: TMN, & + XLAND, & + XICE, & + VEGFRA, & + GSW, & + GLW, & + QZ0, & + SR + + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: QV3D, & + P8W3D, & + RHO3D, & + TH3D, & + T3D, & + DZ8W + +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RAINBL +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CHS2, & + CHS, & + QGH, & + CPM +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: TBOT +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CHKLOWQ, & + ELFLX +! added for WRF-CHEM, 20041205, JM -- not used in this routine as yet + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: RMOL + +! LOCAL VARS + + REAL,DIMENSION(ITS:ITE) :: QV1D, & + & T1D, & + & TH1D, & + & ZA1D, & + & P8W1D, & + & PSFC1D, & + & RHO1D, & + & PREC1D + + INTEGER :: I,J + REAL :: RATIOMX +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + DO J=JTS,JTE + + DO I=ITS,ITE + T1D(I) = T3D(I,1,J) + TH1D(I) = TH3D(I,1,J) +!!! QV1D(I) = QV3D(I,1,J) + RATIOMX = QV3D(I,1,J) + QV1D(I) = RATIOMX/(1.+RATIOMX) + P8W1D(I) = (P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5 + PSFC1D(I) = P8W3D(I,1,J) + ZA1D(I) = 0.5*DZ8W(I,1,J) + RHO1D(I) = RHO3D(I,1,J) + PREC1D(I) = RAINBL(I,J)/DT + ENDDO + +!FLHC = SFCEXC + +!----------------------------------------------------------------------- + CALL SURFCE(J,ZA1D,QV1D,P8W1D,PSFC1D,RHO1D,T1D,TH1D,TSK, & + CHS(IMS,J),PREC1D,HFX,QFX,QGH(IMS,J),GSW,GLW, & + SMSTAV,SMSTOT,SFCRUNOFF, & + UDRUNOFF,IVGTYP,ISLTYP,VEGFRA,SFCEVP,POTEVP,GRDFLX, & + ELFLX,SFCEXC,ACSNOW,ACSNOM,SNOPCX, & + ALBSF,TMN,XLAND,XICE,QZ0, & + TH2,Q2,SNOWC,CHS2(IMS,J),QSFC,TBOT,CHKLOWQ, & + NUM_SOIL_LAYERS,DT,DZS,ITIMESTEP, & + SMOIS,TSLB,SNOW,CANWAT,CPM(IMS,J),ROVCP,SR, & + ALB,SNOALB,SMLIQ,SNOWH, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) +! + ENDDO + + END SUBROUTINE NMMLSM + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + SUBROUTINE SURFCE(J,ZA,QV,P8W,PSFC,RHO,T,TH,TSK,CHS,PREC,HFX,QFX, & + QGH,GSW,GLW,SMSTAV,SMSTOT,SFCRUNOFF,UDRUNOFF, & + IVGTYP,ISLTYP,VEGFRA,SFCEVP,POTEVP,GRDFLX, & + ELFLX,SFCEXC,ACSNOW,ACSNOM,SNOPCX, & + ALBSF,TMN,XLAND,XICE,QZ0, & + TH2,Q2,SNOWC,CHS2,QSFC,TBOT,CHKLOWQ, & + NUM_SOIL_LAYERS,DT,DZS,ITIMESTEP, & + SMOIS,TSLB,SNOW,CANWAT,CPM,ROVCP,SR, & + ALB,SNOALB,SMLIQ,SNOWH, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) +!------------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------------ +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: SURFCE CALCULATE SURFACE CONDITIONS +! PRGRMMR: F. CHEN DATE: 97-12-06 +! +! ABSTRACT: +! THIS ROUTINE IS THE DRIVER FOR COMPUTATION OF GROUND CONDITIONS +! BY USING A LAND SURFACE MODEL (LSM). +! +! PROGRAM HISTORY LOG: +! 97-12-06 CHEN - ORIGINATOR +! +! REFERENCES: +! PAN AND MAHRT (1987) BOUN. LAYER METEOR. +! CHEN ET AL. (1996) J. GEOPHYS. RES. +! CHEN ET AL. (1997) BOUN. LAYER METEOR. +! CHEN and Dudhia (2000) Mon. Wea. Rev. +! +! SUBPROGRAMS CALLED: +! SFLX +! +! SET LOCAL PARAMETERS. +!---------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: IMS,IME, JMS,JME, KMS,KME, & + ITS,ITE, JTS,JTE, KTS,KTE, & + J,ITIMESTEP + + INTEGER , INTENT(IN) :: NUM_SOIL_LAYERS + + REAL, INTENT(IN ) :: DT,ROVCP + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS + + + REAL, PARAMETER :: PQ0=379.90516 + REAL, PARAMETER :: TRESH=.95E0,A2=17.2693882,A3=273.16,A4=35.86, & + T0=273.16E0,T1=274.16E0,ROW=1.E3, & + ELWV=2.50E6,ELIV=XLS,ELIW=XLF, & + A23M4=A2*(A3-A4), RLIVWV=ELIV/ELWV, & + ROWLIW=ROW*ELIW,ROWLIV=ROW*ELIV,CAPA=R_D/CP + + INTEGER, PARAMETER :: NROOT=3 +! + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(INOUT) :: SMOIS, & ! new + SMLIQ, & ! new + TSLB ! new !STEMP + + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: TSK, & !was TGB (temperature) + HFX, & !new + QFX, & !new + QSFC,& !new + SNOW, & !new + SNOWH, & !new + ALB, & + SNOALB, & + ALBSF, & + SNOWC, & + CANWAT, & ! new + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + SFCEVP, & + POTEVP, & + GRDFLX, & + ACSNOW, & + ACSNOM, & + SNOPCX + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: IVGTYP, & + ISLTYP + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: TMN, & + XLAND, & + XICE, & + VEGFRA, & + GSW, & + GLW, & + QZ0, & + SR + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: Q2, & + TH2, & + SFCEXC + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: TBOT + + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: CHKLOWQ, & + ELFLX + + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: QGH, & + CHS, & + CPM, & + CHS2 + +! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE LSM + REAL, DIMENSION( its:ite ) , & + INTENT(IN ) :: ZA, & + TH, & + QV, & + T, & + p8w, & + PSFC, & + rho, & + PREC ! one time step in mm + + REAL, DIMENSION( its:ite ) :: TGDSA + +! LOCAL VARS + + REAL, DIMENSION(1:num_soil_layers) :: SMLIQ1D,SMOIS1D,STEMP1D + +!---------------------------------------------------------------------- +!*** DECLARATIONS FOR IMPLICIT NONE + + REAL :: APELM,APES,FDTLIW,FDTW,Q2SAT,Z,FK,SOLDN,SFCTMP,SFCTH2, & + SFCPRS,PRCP,Q2K,DQSDTK,SATFLG,TBOTK,CHK,VGFRCK,T1K,LWDN, & + CMCK,Q2M,SNODPK,PLFLX,HFLX,GFLX,RNOF1K, & + RNOF2K,Q1K,SMELTK,SOILQW,SOILQM,T2K,PRESK,CHFF,STIMESTEP, & + ALB1D,SNOALB1D,SNOWH1D,ALBSF1D,SOLNET,FFROZP, & + DUM1,DUM2,DUM3,DUM4,DUM5,DUM6,DUM7 + + INTEGER :: I,K,NS,ICE,IVGTPK,ISLTPK,ISPTPK,NOOUT,NSOIL,LZ + +!---------------------------------------------------------------------- +!*********************************************************************** +! START SURFCE HERE +!*** +!*** SET CONSTANTS CALCULATED HERE FOR CLARITY. +!*** + FDTLIW=DT/ROWLIW +! FDTLIV=DT/ROWLIV + FDTW=DT/(XLV*RHOWATER) +!*** +!*** SET LSM CONSTANTS AND TIME INDEPENDENT VARIABLES +!*** INITIALIZE LSM HISTORICAL VARIABLES +!*** +!----------------------------------------------------------------------- + + NSOIL=num_soil_layers + + IF(ITIMESTEP.EQ.1)THEN + DO 50 I=its,ite +!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS + IF((XLAND(I,J)-1.5).GE.0.)THEN +! check sea-ice point + IF(XICE(I,J).EQ.1.)PRINT*,' sea-ice at water point, I=',I, & + 'J=',J +!*** Open Water Case + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + TSLB(I,NS,J)=273.16 !STEMP + ENDDO + ELSE + IF(XICE(I,J).EQ.1.)THEN +!*** SEA-ICE CASE + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + ENDDO + ENDIF + ENDIF +! + 50 CONTINUE + ENDIF +!----------------------------------------------------------------------- + DO 100 I=its,ite +! SFCPRS=(A(KL)*PSB(I,J)+PTOP+PP3D(I,J,KL)*0.001)*1.E3 + SFCPRS=p8w(I) !Pressure in middle of lowest layer + Q2SAT=QGH(I) +! CHKLOWQ(I,J)=1. + CHFF=CHS(I)*RHO(I)*CPM(I) +!CHK*RHO*CP +! TGDSA: potential T + TGDSA(I)=TSK(I,J)*(1.E5/SFCPRS)**ROVCP +! +!*** CHECK FOR SATURATION AT THE LOWEST MODEL LEVEL +! + Q2K=QV(I) + APES=(1.E5/PSFC(I))**CAPA +! + IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN + SATFLG=0. + CHKLOWQ(I,J)=0. + ELSE + SATFLG=1.0 + CHKLOWQ(I,J)=1. + ENDIF +! + TBOT(I,J)=273.16 +!*** +!*** LOADING AND UNLOADING MM5/LSM LAND SOIL VARIABLES +!*** + IF((XLAND(I,J)-1.5).GE.0.)THEN +!*** Water + HFX(I,J)=HFX(I,J)/APES + QFX(I,J)=QFX(I,J)*SATFLG + SFCEVP(I,J)=SFCEVP(I,J)+QFX(I,J)*DT + ELSE +!*** LAND OR SEA-ICE +!ATEC ICE=INT(XICE(I,J)+0.3) + IF (XICE(I,J) .GT. 0.5) THEN + ICE=1 + ELSE + ICE=0 + ENDIF +! + Q2K=MIN(QV(I),Q2SAT) + Z=ZA(I) +! FK=GSW(I,J)+GLW(I,J) + LWDN=GLW(I,J) +! +!*** GSW is net downward shortwave +! +! SOLNET=GSW(I,J) +! +!*** GSW is total downward shortwave +! + SOLDN=GSW(I,J) +! +!*** Simple use of albedo to determine total incoming solar shortwave SOLDN +!*** (no solar zenith angle correction) +! +! SOLDN=SOLNET/(1.-ALB(I,J)) + SOLNET=SOLDN*(1.-ALB(I,J)) +! + ALBSF1D=ALBSF(I,J) + SNOALB1D=SNOALB(I,J) + SFCTMP=T(I) +!!! SFCTH2=SFCTMP+(0.0097545*Z) + APELM=(1.E5/SFCPRS)**CAPA + SFCTH2=SFCTMP*APELM + SFCTH2=SFCTH2/APES + PRCP=PREC(I) +!!! Q2K=QV(I) +!!! Q2SAT=PQ0/SFCPRS*EXP(A2*(SFCTMP-A3)/(SFCTMP-A4)) + DQSDTK=Q2SAT*A23M4/(SFCTMP-A4)**2 + IF(ICE.EQ.0)THEN + TBOTK=TMN(I,J) + ELSE + TBOTK=271.16 + ENDIF + CHK=CHS(I) + IVGTPK=IVGTYP(I,J) + IF(IVGTPK.EQ.0)IVGTPK=13 + ISLTPK=ISLTYP(I,J) + IF(ISLTPK.EQ.0)ISLTPK=9 +! hardwire slope type (ISPTPK)=1 + ISPTPK=1 + VGFRCK=VEGFRA(I,J)/100. + IF(IVGTPK.EQ.25) VGFRCK=0.0001 + IF(ISLTPK.EQ.14.AND.XICE(I,J).EQ.0.)THEN + PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + PRINT*,i,j,'RESET SOIL in surfce.F' +! ISLTYP(I,J)=7 + ISLTPK=7 + ENDIF + T1K=TSK(I,J) + CMCK=CANWAT(I,J) +!*** convert snow depth from mm to meter + SNODPK=SNOW(I,J)*0.001 + SNOWH1D=SNOWH(I,J)*0.001 +! +!*** fraction of frozen precip +! + FFROZP=SR(I,J) +! + DO 70 NS=1,NSOIL + SMOIS1D(NS)=SMOIS(I,NS,J) + SMLIQ1D(NS)=SMLIQ(I,NS,J) + STEMP1D(NS)=TSLB(I,NS,J) !STEMP + 70 CONTINUE + +! +! print*,'BF SFLX','ISLTPK',ISLTPK,'IVGTPK=',IVGTPK,'SMOIS1D',& +! SMOIS1D,'STEMP1',STEMP1D,'VGFRCK',VGFRCK +!----------------------------------------------------------------------- +! old WRF call to SFLX +! CALL SFLX(ICE,SATFLG,DT,Z,NSOIL,NROOT,DZS,FK,SOLDN,SFCPRS, & +! PRCP,SFCTMP,SFCTH2,Q2K,Q2SAT,DQSDTK,TBOTK,CHK,CHFF, & +! IVGTPK,ISLTPK,VGFRCK,PLFLX,ELFLX,HFLX,GFLX,RNOF1K,RNOF2K,& +! Q1K,SMELTK,T1K,CMCK,SMOIS1D,STEMP1D,SNODPK,SOILQW,SOILQM) +!----------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! Ek 12 June 2002 - NEW CALL SFLX +! ops Eta call to SFLX ...'tailor' this to WRF +! CALL SFLX +! I (ICE,DTK,Z,NSOIL,SLDPTH, +! I LWDN,SOLDN,SFCPRS,PRCP,SFCTMP,SFCTH2,Q2K,SFCSPD,Q2SAT,DQSDTK, +! I IVGTPK,ISLTPK,ISPTPK, +! I VGFRCK,PTU,TBOT,ALB,SNOALB, +! 2 CMCK,T1K,STCK,SMCK,SH2OK,SNOWH,SNODPK,ALB2D,CHK,CMK, +! O PLFLX,ELFLX,HFLX,GFLX,RNOF1K,RNOF2K,Q1K,SMELTK, +! O SOILQW,SOILQM,DUM1,DUM2,DUM3,DUM4) +!----------------------------------------------------------------------- + CALL SFLX & + (FFROZP,ICE,DT,Z,NSOIL,DZS, & + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,SFCTH2,Q2K,DUM5,Q2SAT, & + DQSDTK,IVGTPK,ISLTPK,ISPTPK, & + VGFRCK,DUM6,TBOTK,ALBSF1D,SNOALB1D, & + CMCK,T1K,STEMP1D,SMOIS1D,SMLIQ1D,SNOWH1D,SNODPK,ALB1D,CHK,DUM7, & + PLFLX,ELFLX(I,J),HFLX,GFLX,RNOF1K,RNOF2K,Q1K,SMELTK, & + SOILQW,SOILQM,DUM1,DUM2,DUM3,DUM4,I,J) +!----------------------------------------------------------------------- +!*** DIAGNOSTICS +! Convert the water unit into mm + SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RNOF1K*DT*1000.0 + UDRUNOFF(I,J)=UDRUNOFF(I,J)+RNOF2K*DT*1000.0 + SMSTAV(I,J)=SOILQW + +!mp + if (abs(SMSTAV(I,J)) .lt. 3.5) then + else + write(errmess,*) 'bad SMSTAV: ', I,J,SMSTAV(I,J) + CALL wrf_message( errmess ) + endif +!mp + + SMSTOT(I,J)=SOILQM*1000. + SFCEXC(I,J)=CHK +! IF(SNOB(I,J).GT.0..OR.SICE(I,J).GT.0.)THEN +! QFC1(I,J)=QFC1(I,J)*RLIVWV +! ENDIF + IF(FFROZP.GT.0.5)THEN + ACSNOW(I,J)=ACSNOW(I,J)+PREC(I)*DT + ENDIF + IF(SNOW(I,J).GT.0.)THEN + ACSNOM(I,J)=ACSNOM(I,J)+SMELTK*1000. + SNOPCX(I,J)=SNOPCX(I,J)-SMELTK/FDTLIW + ENDIF + POTEVP(I,J)=POTEVP(I,J)+PLFLX*FDTW +! POTFLX(I,J)=POTFLX(I,J)-PLFLX +!*** WRF LOWER BOUNDARY CONDITIONS + GRDFLX(I,J)=GFLX + HFX(I,J)=HFLX + QFX(I,J)=ELFLX(I,J)/ELWV + SFCEVP(I,J)=SFCEVP(I,J)+QFX(I,J)*DT + TSK(I,J)=T1K + T2K=T1K-HFX(I,J)/(RHO(I)*CPM(I)*CHS2(I)) + TH2(I,J)=T2K*(1.E5/SFCPRS)**ROVCP + Q2M=Q1K-QFX(I,J)/(RHO(I)*CHS2(I)) +!!!!!! Q2(I,J)=Q2M +!!!!!! Q2(I,J)=Q2K +! t2k=th2k/(1.E5/SFCPRS)**ROVCP +! QS(I,J)=Q1K +!!! QSFC(I,J)=Q1K +!*** UPDATE STATE VARIABLES + SNOW(I,J)=SNODPK*1000.0 + SNOWH(I,J)=SNOWH1D*1000.0 + CANWAT(I,J)=CMCK + IF(SNOW(I,J).GT.1.0)THEN +! ALB(I,J)=0.01*ALBD(IVGTPK,ISEASON)*(1.+SCFX(IVGTPK)) + SNOWC(I,J)=1.0 + ELSE +! ALB(I,J)=0.01*ALBD(IVGTPK,ISEASON) + SNOWC(I,J)=0.0 + ENDIF +! update albedo + ALB(I,J)=ALB1D +! update bottom soil temperature + TBOT(I,J)=TBOTK + + DO 80 NS=1,NSOIL + SMOIS(I,NS,J)=SMOIS1D(NS) + SMLIQ(I,NS,J)=SMLIQ1D(NS) + TSLB(I,NS,J)=STEMP1D(NS) ! STEMP + 80 CONTINUE + ENDIF +#if 0 + NOOUT=0 + + IF((ITIMESTEP.EQ.1.OR.MOD(ITIMESTEP,1).EQ.0) & + .AND. I .EQ.29.AND.J.EQ.23) THEN +! print*, 'GLW',GLW(I,J),'GSW',GSW(I,J) + print*, 'T2K',T2K,'T1K',T1K,'HFX',HFX(I,J),'RHO',RHO(I),'CPM',CPM(I), & + 'CHS2',CHS2(I),'soil T',STEMP1D,'soil m', SMOIS1D +! print*,'Q2M',Q2M,'Q1K',Q1K,'QFX',QFX(I,J),'RHO',RHO(I),'CHS2',CHS2(I),'latent',ELFLX + ENDIF + + IF(NOOUT.EQ.1)GOTO 100 +! write output to 29 + IF(ITIMESTEP.EQ.1.AND.I.EQ.1.AND.J.EQ.1) & + WRITE (29,*)& + 'itimestep ',' FK ',' SOLDN ',' SFCPR ', & + ' SFCTMP ',' Q2K ',' TBOTK ', & + ' CHK ',' ELFLX ',' HFLX ',' GFLX ', & + ' RNOF1K ',' RNOF2K ',' T1K ',' CMCK ', & + ' SMCK1 ',' SMCK2 ',' SMCK3 ',' SMCK4 ', & + ' STCK1 ',' STCK2 ',' STCK3 ',' STCK4 ', & + ' SNODPK ',' T2 ', & + ' Q2 ',' SMSTOT ',' SFCEVP ', ' RAIN' + IF((ITIMESTEP.EQ.1.OR.MOD(ITIMESTEP,1).EQ.0) & + .AND. I .EQ.29.AND.J.EQ.23) THEN + print *,'outputting at itimestep =', itimestep + STIMESTEP=FLOAT(itimestep) + WRITE (29,1029)STIMESTEP,FK,SOLDN,SFCPRS/100.,SFCTMP,1000.* & + Q2K,TBOTK,1000.*CHK,ELFLX(i,j),HFLX,GFLX,SFCRUNOFF(I,J)& + ,UDRUNOFF(I,J),T1K,CMCK,SMOIS1D,STEMP1D,SNODPK, & +! ,UDRUNOFF(I,J),T1K,CMCK,SMOIS1D(3),SMOIS1D(7),SMOIS1D(11),& +! SMOIS1D(14),STEMP1D(3), STEMP1D(7),STEMP1D(11), & +! STEMP1D(14), SNODPK, & + T2K,1000.*Q2M,SMSTOT(I,J),SFCEVP(I,J),PRCP + 1029 FORMAT (29F10.4) +! IF(ITIMESTEP.EQ.0)WRITE (39,*)' P ',' T ', & +! ' TH ',' Q ',' U ',' V ', & +! ' QC ' +! WRITE (39,1039)itimestep +! DO K=kts,kte +! WRITE (39,1039)PRESK,TX(I,K),THX(I,K),1000.*QX(I,K),UX(I,K),& +! VX(I,K),1000.*QCX(I,K) + 1039 FORMAT (7F10.5) +! ENDDO + ENDIF +! +#endif + 100 CONTINUE +! +!----------------------------------------------------------------------- + END SUBROUTINE SURFCE +!----------------------------------------------------------------------- + + SUBROUTINE SFLX ( & + FFROZP,ICE,DT,ZLVL,NSOIL,SLDPTH, & + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,TH2,Q2,SFCSPD,Q2SAT, & + DQSDT2,VEGTYP,SOILTYP,SLOPETYP, & + SHDFAC,PTU,TBOT,ALB,SNOALB, & + CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, & + ETP,ETA,SHEAT,SSOIL,RUNOFF1,RUNOFF2,Q1,SNOMLT, & + SOILW,SOILM,SMCWLT,SMCDRY,SMCREF,SMCMAX,I,J) +! ---------------------------------------------------------------------- +! & ETA,SHEAT, & +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- +! & EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & +! & BETA,ETP,SSOIL, & +! & FLX1,FLX2,FLX3, & +! & SNOMLT,SNCOVR, & +! & RUNOFF1,RUNOFF2,RUNOFF3, & +! & RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & +! & SOILW,SOILM, & +! & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT,I,J) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SFLX - VERSION 2.7 - June 2nd 2003 +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "NOAH/OSU LSM" FAMILY OF PHYSICS SUBROUTINES FOR A +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE SOIL MOISTURE, SOIL +! ICE, SOIL TEMPERATURE, SKIN TEMPERATURE, SNOWPACK WATER CONTENT, +! SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY BALANCE AND SURFACE +! WATER BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD +! RADIATION AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! ICE SEA-ICE FLAG (=1: SEA-ICE, =0: LAND) +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) +! ---------------------------------------------------------------------- +! 2. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLDN SOLAR DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SOLAR) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! ---------------------------------------------------------------------- +! 3. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND +! Q2SAT SAT MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 4. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! VEGTYP VEGETATION TYPE (INTEGER INDEX) +! SOILTYP SOIL TYPE (INTEGER INDEX) +! SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX) +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) <= SHDFAC +! PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS) +! (NOT YET USED, BUT PASSED TO REDPRM FOR FUTURE USE IN +! VEG PARMS) +! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN +! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF +! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT +! INCLUDE DIURNAL SUN ANGLE EFFECT) +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! ---------------------------------------------------------------------- +! 5. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! CMC CANOPY MOISTURE CONTENT (M) +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! NOTE: FROZEN SOIL MOISTURE = SMC - SH2O +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) +! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR +! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) WHEN SNEQV>0 +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1); NOTE: +! CM IS TECHNICALLY A CONDUCTANCE SINCE IT HAS BEEN +! MULTIPLIED BY WIND SPEED. CM IS NOT NEEDED IN SFLX +! ---------------------------------------------------------------------- +! 6. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION +! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W M-2: NEGATIVE, IF UP FROM +! SURFACE) +! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SURFACE) +! ---------------------------------------------------------------------- +! EC CANOPY WATER EVAPORATION (W M-2) +! EDIR DIRECT SOIL EVAPORATION (W M-2) +! ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT (SOIL) LAYER +! (W M-2) +! ETT TOTAL PLANT TRANSPIRATION (W M-2) +! ESNOW SUBLIMATION FROM SNOWPACK (W M-2) +! DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY +! WATER-HOLDING CAPACITY (M) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) +! ETP POTENTIAL EVAPORATION (W M-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM OF LAST +! SOIL LAYER +! RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX) +! FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP +! ---------------------------------------------------------------------- +! RC CANOPY RESISTANCE (S M-1) +! PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP +! = ACTUAL TRANSPIRATION +! XLAI LEAF AREA INDEX (DIMENSIONLESS) +! RSMIN MINIMUM CANOPY RESISTANCE (S M-1) +! RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS) +! RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS) +! RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS) +! RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS) +! ---------------------------------------------------------------------- +! 7. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION +! BETWEEN SMCWLT AND SMCMAX) +! SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) +! ---------------------------------------------------------------------- +! 8. PARAMETERS (P): +! ---------------------------------------------------------------------- +! SMCWLT WILTING POINT (VOLUMETRIC) +! SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP +! LAYER ENDS (VOLUMETRIC) +! SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO +! STRESS (VOLUMETRIC) +! SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE +! (VOLUMETRIC) +! NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED +! IN SUBROUTINE REDPRM. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + +! ---------------------------------------------------------------------- +! DECLARATIONS - LOGICAL +! ---------------------------------------------------------------------- + LOGICAL FRZGRA + LOGICAL SATURATED + LOGICAL SNOWNG + +! ---------------------------------------------------------------------- +! DECLARATIONS - INTEGER +! ---------------------------------------------------------------------- + INTEGER ICE + INTEGER K + INTEGER KZ + INTEGER NSOIL + INTEGER NROOT + INTEGER SLOPETYP + INTEGER SOILTYP + INTEGER VEGTYP + INTEGER I + INTEGER J + +! ---------------------------------------------------------------------- +! DECLARATIONS - REAL +! ---------------------------------------------------------------------- + REAL ALBEDO + REAL ALB + REAL BEXP + REAL BETA + REAL CFACTR + REAL CH + REAL CM + REAL CMC + REAL CMCMAX + REAL CP +! REAL CSNOW + REAL CSOIL + REAL CZIL + REAL DEW + REAL DF1 + REAL DF1H + REAL DF1A + REAL DKSAT + REAL DT + REAL DWSAT + REAL DQSDT2 + REAL DSOIL + REAL DTOT + REAL DRIP + REAL EC + REAL EDIR + REAL ESNOW + REAL ET(NSOIL) + REAL ETT + REAL FRCSNO + REAL FRCSOI + REAL EPSCA + REAL ETA + REAL ETP + REAL FDOWN + REAL F1 + REAL FLX1 + REAL FLX2 + REAL FLX3 + REAL FXEXP + REAL FRZX + REAL SHEAT + REAL HS + REAL KDT + REAL LWDN + REAL LVH2O + REAL PC + REAL PRCP + REAL PTU + REAL PRCP1 + REAL PSISAT + REAL Q2 + REAL Q2SAT + REAL QUARTZ + REAL R + REAL RCH + REAL REFKDT + REAL RR + REAL RTDIS(NSOLD) + REAL RUNOFF1 + REAL RUNOFF2 + REAL RGL + REAL RUNOFF3 + REAL RSMAX + REAL RC + REAL RSMIN + REAL RCQ + REAL RCS + REAL RCSOIL + REAL RCT + REAL RSNOW + REAL SNDENS + REAL SNCOND + REAL SSOIL + REAL SBETA + REAL SFCPRS + REAL SFCSPD + REAL SFCTMP + REAL SHDFAC + REAL SHDMIN + REAL SH2O(NSOIL) + REAL SLDPTH(NSOIL) + REAL SMCDRY + REAL SMCMAX + REAL SMCREF + REAL SMCWLT + REAL SMC(NSOIL) + REAL SNEQV + REAL SNCOVR + REAL SNOWH + REAL SN_NEW + REAL SLOPE + REAL SNUP + REAL SALP + REAL SNOALB + REAL STC(NSOIL) + REAL SNOMLT + REAL SOLDN + REAL SOILM + REAL SOILW + REAL SOILWM + REAL SOILWW + REAL T1 + REAL T1V + REAL T24 + REAL T2V + REAL TBOT + REAL TH2 + REAL TH2V + REAL TOPT + REAL TFREEZ + REAL TSNOW + REAL XLAI + REAL ZLVL + REAL ZBOT + REAL Z0 + REAL ZSOIL(NSOLD) + + REAL FFROZP + REAL SOLNET + REAL LSUBS + + REAL Q1 + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + PARAMETER(TFREEZ = 273.15) + PARAMETER(LVH2O = 2.501E+6) + PARAMETER(LSUBS = 2.83E+6) + PARAMETER(R = 287.04) + PARAMETER(CP = 1004.5) + +! ---------------------------------------------------------------------- +! INITIALIZATION +! ---------------------------------------------------------------------- + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + SNOMLT = 0.0 + +! ---------------------------------------------------------------------- +! THE VARIABLE "ICE" IS A FLAG DENOTING SEA-ICE CASE +! ---------------------------------------------------------------------- + IF (ICE .EQ. 1) THEN + +! ---------------------------------------------------------------------- +! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO 3 METERS +! ---------------------------------------------------------------------- + DO KZ = 1,NSOIL + ZSOIL(KZ) = -3.*FLOAT(KZ)/FLOAT(NSOIL) + END DO + + ELSE + +! ---------------------------------------------------------------------- +! CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF +! EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW +! GROUND) +! ---------------------------------------------------------------------- + ZSOIL(1) = -SLDPTH(1) + DO KZ = 2,NSOIL + ZSOIL(KZ) = -SLDPTH(KZ)+ZSOIL(KZ-1) + END DO + + ENDIF + +! ---------------------------------------------------------------------- +! NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING +! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. +! ---------------------------------------------------------------------- + CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP, & + & CFACTR,CMCMAX,RSMAX,TOPT,REFKDT,KDT,SBETA, & + & SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX,PSISAT,SLOPE, & + & SNUP,SALP,BEXP,DKSAT,DWSAT,SMCMAX,SMCWLT,SMCREF, & + & SMCDRY,F1,QUARTZ,FXEXP,RTDIS,SLDPTH,ZSOIL, & + & NROOT,NSOIL,Z0,CZIL,XLAI,CSOIL,PTU) + +! ---------------------------------------------------------------------- +! INITIALIZE PRECIPITATION LOGICALS. +! ---------------------------------------------------------------------- + SNOWNG = .FALSE. + FRZGRA = .FALSE. + +! ---------------------------------------------------------------------- +! IF SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP +! ---------------------------------------------------------------------- + IF (ICE .EQ. 1) THEN + SNEQV = 0.01 + SNOWH = 0.05 + SNDENS = SNEQV/SNOWH + ENDIF + +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION +! SUBROUTINE) +! ---------------------------------------------------------------------- + IF (SNEQV .EQ. 0.0) THEN + SNDENS = 0.0 + SNOWH = 0.0 + SNCOND = 1.0 + ELSE + SNDENS = SNEQV/SNOWH + SNCOND = CSNOW(SNDENS) + ENDIF + +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + IF (PRCP .GT. 0.0) THEN +! IF (SFCTMP .LE. TFREEZ) THEN + IF (FFROZP .GT. 0.5) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 .LE. TFREEZ) FRZGRA = .TRUE. + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES +! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. +! ---------------------------------------------------------------------- + IF ( (SNOWNG) .OR. (FRZGRA) ) THEN + SN_NEW = PRCP * DT * 0.001 + SNEQV = SNEQV + SN_NEW + PRCP1 = 0.0 + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) + SNCOND = CSNOW (SNDENS) + ELSE + +! ---------------------------------------------------------------------- +! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT +! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL (ALONG WITH +! ANY CANOPY "DRIP" ADDED TO THIS LATER) +! ---------------------------------------------------------------------- + PRCP1 = PRCP + + ENDIF + +! ---------------------------------------------------------------------- +! DETERMINE SNOWCOVER AND ALBEDO OVER LAND. +! ---------------------------------------------------------------------- + IF (ICE .EQ. 0) THEN + +! ---------------------------------------------------------------------- +! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO. +! ---------------------------------------------------------------------- + IF (SNEQV .EQ. 0.0) THEN + SNCOVR = 0.0 + ALBEDO = ALB + + ELSE +! ---------------------------------------------------------------------- +! DETERMINE SNOW FRACTIONAL COVERAGE. +! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. +! ---------------------------------------------------------------------- + CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) +! MEK JAN 2006, LIMIT SNOW COVER TO A MAXIMUM FRACTION OF 0.98 + SNCOVR = MIN(SNCOVR,0.98) + CALL ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) + ENDIF + + ELSE +! ---------------------------------------------------------------------- +! SNOW COVER, ALBEDO OVER SEA-ICE +! ---------------------------------------------------------------------- + SNCOVR = 1.0 +! changed in version 2.6 on June 2nd 2003 +! ALBEDO = 0.60 + ALBEDO = 0.65 + ENDIF + +! ---------------------------------------------------------------------- +! THERMAL CONDUCTIVITY FOR SEA-ICE CASE +! ---------------------------------------------------------------------- + IF (ICE .EQ. 1) THEN + DF1 = 2.2 + + ELSE + +! ---------------------------------------------------------------------- +! NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES +! CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE +! LATTER FOLLOWS THAT ON PAGES 148-149 FROM "HEAT TRANSFER IN +! COLD CLIMATES", BY V. J. LUNARDINI (PUBLISHED IN 1981 +! BY VAN NOSTRAND REINHOLD CO.) I.E. TREATMENT OF TWO CONTIGUOUS +! "PLANE PARALLEL" MEDIUMS (NAMELY HERE THE FIRST SOIL LAYER +! AND THE SNOWPACK LAYER, IF ANY). THIS DIFFUSIVITY TREATMENT +! BEHAVES WELL FOR BOTH ZERO AND NONZERO SNOWPACK, INCLUDING THE +! LIMIT OF VERY THIN SNOWPACK. THIS TREATMENT ALSO ELIMINATES +! THE NEED TO IMPOSE AN ARBITRARY UPPER BOUND ON SUBSURFACE +! HEAT FLUX WHEN THE SNOWPACK BECOMES EXTREMELY THIN. +! ---------------------------------------------------------------------- +! FIRST CALCULATE THERMAL DIFFUSIVITY OF TOP SOIL LAYER, USING +! BOTH THE FROZEN AND LIQUID SOIL MOISTURE, FOLLOWING THE +! SOIL THERMAL DIFFUSIVITY FUNCTION OF PETERS-LIDARD ET AL. +! (1998,JAS, VOL 55, 1209-1224), WHICH REQUIRES THE SPECIFYING +! THE QUARTZ CONTENT OF THE GIVEN SOIL CLASS (SEE ROUTINE REDPRM) +! ---------------------------------------------------------------------- + CALL TDFCND (DF1,SMC(1),QUARTZ,SMCMAX,SH2O(1)) + +! ---------------------------------------------------------------------- +! NEXT ADD SUBSURFACE HEAT FLUX REDUCTION EFFECT FROM THE +! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF +! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) +! ---------------------------------------------------------------------- + DF1 = DF1 * EXP(SBETA*SHDFAC) + ENDIF + +! ---------------------------------------------------------------------- +! FINALLY "PLANE PARALLEL" SNOWPACK EFFECT FOLLOWING +! V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS +! COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER +! ---------------------------------------------------------------------- + DSOIL = -(0.5 * ZSOIL(1)) + + IF (SNEQV .EQ. 0.) THEN + SSOIL = DF1 * (T1 - STC(1) ) / DSOIL + ELSE + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH/DTOT + FRCSOI = DSOIL/DTOT +! +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + DF1H = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) +! 2. ARITHMETIC MEAN (PARALLEL FLOW) +! DF1 = FRCSNO*SNCOND + FRCSOI*DF1 + DF1A = FRCSNO*SNCOND + FRCSOI*DF1 +! +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) +! TEST - MBEK, 10 Jan 2002 +! weigh DF by snow fraction +! DF1 = DF1H*SNCOVR + DF1A*(1.0-SNCOVR) +! DF1 = DF1H*SNCOVR + DF1*(1.0-SNCOVR) + DF1 = DF1A*SNCOVR + DF1*(1.0-SNCOVR) + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + SSOIL = DF1 * (T1 - STC(1) ) / DTOT + ENDIF + +! MEK -- DEBUG -- AUG 2005 +! WRITE(*,*) 'T1,STC(1),DSOIL=',T1,STC(1),DSOIL +! WRITE(*,*) 'DF1,SBETA,SHDFAC=',DF1,SBETA,SHDFAC +! WRITE(*,*) 'SSOIL=',SSOIL + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + IF (SNCOVR .GT. 0.) THEN + CALL SNOWZ0 (SNCOVR,Z0) + ENDIF + +! ---------------------------------------------------------------------- +! NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR +! HEAT AND MOISTURE. +! +! NOTE !!! +! COMMENT OUT CALL SFCDIF, IF SFCDIF ALREADY CALLED IN CALLING PROGRAM +! (SUCH AS IN COUPLED ATMOSPHERIC MODEL). +! +! NOTE !!! +! DO NOT CALL SFCDIF UNTIL AFTER ABOVE CALL TO REDPRM, IN CASE +! ALTERNATIVE VALUES OF ROUGHNESS LENGTH (Z0) AND ZILINTINKEVICH COEF +! (CZIL) ARE SET THERE VIA NAMELIST I/O. +! +! NOTE !!! +! ROUTINE SFCDIF RETURNS A CH THAT REPRESENTS THE WIND SPD TIMES THE +! "ORIGINAL" NONDIMENSIONAL "Ch" TYPICAL IN LITERATURE. HENCE THE CH +! RETURNED FROM SFCDIF HAS UNITS OF M/S. THE IMPORTANT COMPANION +! COEFFICIENT OF CH, CARRIED HERE AS "RCH", IS THE CH FROM SFCDIF TIMES +! AIR DENSITY AND PARAMETER "CP". "RCH" IS COMPUTED IN "CALL PENMAN". +! RCH RATHER THAN CH IS THE COEFF USUALLY INVOKED LATER IN EQNS. +! +! NOTE !!! +! SFCDIF ALSO RETURNS THE SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM, CM, +! ALSO KNOWN AS THE SURFACE DRAGE COEFFICIENT, BUT CM IS NOT USED HERE. +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! SFCDIF AND PENMAN. +! ---------------------------------------------------------------------- + T2V = SFCTMP * (1.0 + 0.61 * Q2 ) +! ---------------------------------------------------------------------- +! COMMENT OUT BELOW 2 LINES IF CALL SFCDIF IS COMMENTED OUT, I.E. IN THE +! COUPLED MODEL. +! ---------------------------------------------------------------------- +! T1V = T1 * (1.0 + 0.61 * Q2) +! TH2V = TH2 * (1.0 + 0.61 * Q2) +! +! CALL SFCDIF (ZLVL,Z0,T1V,TH2V,SFCSPD,CZIL,CM,CH) + +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- +! FDOWN = SOLDN*(1.0-ALBEDO) + LWDN + FDOWN = SOLNET + LWDN + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER +! CALCULATIONS. +! ---------------------------------------------------------------------- + CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2) + +! ---------------------------------------------------------------------- +! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC +! IF NONZERO GREENNESS FRACTION +! ---------------------------------------------------------------------- + IF (SHDFAC .GT. 0.) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED +! BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW +! ---------------------------------------------------------------------- + CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, & + & SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + & TOPT,RSMAX,RGL,HS,XLAI, & + & RCS,RCT,RCQ,RCSOIL) + + ENDIF + +! ---------------------------------------------------------------------- +! NOW DECIDE MAJOR PATHWAY BRANCH TO TAKE DEPENDING ON WHETHER SNOWPACK +! EXISTS OR NOT: +! ---------------------------------------------------------------------- + ESNOW = 0.0 + IF (SNEQV .EQ. 0.0) THEN + CALL NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, & + & SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL, & + & STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + & SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, & + & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + & RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + & QUARTZ,FXEXP,CSOIL, & + & BETA,DRIP,DEW,FLX1,FLX2,FLX3) + ELSE + CALL SNOPAC (ETP,ETA,PRCP,PRCP1,SNOWNG,SMC,SMCMAX,SMCWLT, & + & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + & SBETA,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, & + & SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,SNEQV,SNDENS, & + & SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT,SNUP, & + & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + & ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW) +! ESNOW = ETA + ENDIF + +! ---------------------------------------------------------------------- +! PREPARE SENSIBLE HEAT (H) FOR RETURN TO PARENT MODEL +! ---------------------------------------------------------------------- + SHEAT = -(CH * CP * SFCPRS)/(R * T2V) * ( TH2 - T1 ) + +! ---------------------------------------------------------------------- +! CONVERT UNITS AND/OR SIGN OF TOTAL EVAP (ETA), POTENTIAL EVAP (ETP), +! SUBSURFACE HEAT FLUX (S), AND RUNOFFS FOR WHAT PARENT MODEL EXPECTS +! CONVERT ETA FROM KG M-2 S-1 TO W M-2 +! ---------------------------------------------------------------------- +! ETA = ETA*LVH2O +! ETP = ETP*LVH2O + +! ---------------------------------------------------------------------- + EDIR = EDIR * LVH2O + EC = EC * LVH2O + DO K=1,4 + ET(K) = ET(K) * LVH2O + ENDDO + ETT = ETT * LVH2O + ESNOW = ESNOW * LSUBS + ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) + IF (ETP .GT. 0.) THEN + ETA = EDIR + EC + ETT + ESNOW + ELSE + ETA = ETP + ENDIF + BETA = ETA/ETP +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- + SSOIL = -1.0*SSOIL + +! ---------------------------------------------------------------------- +! CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1 +! AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW +! ---------------------------------------------------------------------- + RUNOFF3 = RUNOFF3/DT + RUNOFF2 = RUNOFF2+RUNOFF3 + +! ---------------------------------------------------------------------- +! TOTAL COLUMN SOIL MOISTURE IN METERS (SOILM) AND ROOT-ZONE +! SOIL MOISTURE AVAILABILITY (FRACTION) RELATIVE TO POROSITY/SATURATION +! ---------------------------------------------------------------------- + SOILM = -1.0*SMC(1)*ZSOIL(1) + DO K = 2,NSOIL + SOILM = SOILM+SMC(K)*(ZSOIL(K-1)-ZSOIL(K)) + END DO + SOILWM = -1.0*(SMCMAX-SMCWLT)*ZSOIL(1) + SOILWW = -1.0*(SMC(1)-SMCWLT)*ZSOIL(1) + DO K = 2,NROOT + SOILWM = SOILWM+(SMCMAX-SMCWLT)*(ZSOIL(K-1)-ZSOIL(K)) + SOILWW = SOILWW+(SMC(K)-SMCWLT)*(ZSOIL(K-1)-ZSOIL(K)) + END DO + SOILW = SOILWW/SOILWM + +! ---------------------------------------------------------------------- +! END SUBROUTINE SFLX +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX + + SUBROUTINE ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) +! ALB SNOWFREE ALBEDO +! SNOALB MAXIMUM (DEEP) SNOW ALBEDO +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SNCOVR FRACTIONAL SNOW COVER +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT +! TSNOW SNOW SURFACE TEMPERATURE (K) +! ---------------------------------------------------------------------- + REAL ALB, SNOALB, SHDFAC, SHDMIN, SNCOVR, ALBEDO, TSNOW + +! ---------------------------------------------------------------------- +! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, +! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM +! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA +! (1985, JCAM, VOL 24, 402-411) +! ---------------------------------------------------------------------- +! changed in version 2.6 on June 2nd 2003 +! ALBEDO = ALB + (1.0-(SHDFAC-SHDMIN))*SNCOVR*(SNOALB-ALB) + ALBEDO = ALB + SNCOVR*(SNOALB-ALB) + IF (ALBEDO .GT. SNOALB) ALBEDO=SNOALB + +! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) +! IF (TSNOW.LE.263.16) THEN +! ALBEDO=SNOALB +! ELSE +! IF (TSNOW.LT.273.16) THEN +! TM=0.1*(TSNOW-263.16) +! ALBEDO=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) +! ELSE +! ALBEDO=0.67 +! ENDIF +! ENDIF + +! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) +! IF (TSNOW.LT.273.16) THEN +! ALBEDO=SNOALB-0.008*DT/86400 +! ELSE +! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 +! ENDIF + +! ---------------------------------------------------------------------- +! END SUBROUTINE ALCALC +! ---------------------------------------------------------------------- + END SUBROUTINE ALCALC + + SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, & + & SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + & TOPT,RSMAX,RGL,HS,XLAI, & + & RCS,RCT,RCQ,RCSOIL) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE CANRES +! ---------------------------------------------------------------------- +! CALCULATE CANOPY RESISTANCE WHICH DEPENDS ON INCOMING SOLAR RADIATION, +! AIR TEMPERATURE, ATMOSPHERIC WATER VAPOR PRESSURE DEFICIT AT THE +! LOWEST MODEL LEVEL, AND SOIL MOISTURE (PREFERABLY UNFROZEN SOIL +! MOISTURE RATHER THAN TOTAL) +! ---------------------------------------------------------------------- +! SOURCE: JARVIS (1976), NOILHAN AND PLANTON (1989, MWR), JACQUEMIN AND +! NOILHAN (1990, BLM) +! SEE ALSO: CHEN ET AL (1996, JGR, VOL 101(D3), 7251-7268), EQNS 12-14 +! AND TABLE 2 OF SEC. 3.1.2 +! ---------------------------------------------------------------------- +! INPUT: +! SOLAR INCOMING SOLAR RADIATION +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! SFCTMP AIR TEMPERATURE AT 1ST LEVEL ABOVE GROUND +! Q2 AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! Q2SAT SATURATION AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! DQSDT2 SLOPE OF SATURATION HUMIDITY FUNCTION WRT TEMP +! SFCPRS SURFACE PRESSURE +! SMC VOLUMETRIC SOIL MOISTURE +! ZSOIL SOIL DEPTH (NEGATIVE SIGN, AS IT IS BELOW GROUND) +! NSOIL NO. OF SOIL LAYERS +! NROOT NO. OF SOIL LAYERS IN ROOT ZONE (1.LE.NROOT.LE.NSOIL) +! XLAI LEAF AREA INDEX +! SMCWLT WILTING POINT +! SMCREF REFERENCE SOIL MOISTURE (WHERE SOIL WATER DEFICIT STRESS +! SETS IN) +! RSMIN, RSMAX, TOPT, RGL, HS ARE CANOPY STRESS PARAMETERS SET IN +! SURBOUTINE REDPRM +! OUTPUT: +! PC PLANT COEFFICIENT +! RC CANOPY RESISTANCE +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER K + INTEGER NROOT + INTEGER NSOIL + + REAL CH + REAL CP + REAL DELTA + REAL DQSDT2 + REAL FF + REAL GX + REAL HS + REAL P + REAL PART(NSOLD) + REAL PC + REAL Q2 + REAL Q2SAT + REAL RC + REAL RSMIN + REAL RCQ + REAL RCS + REAL RCSOIL + REAL RCT + REAL RD + REAL RGL + REAL RR + REAL RSMAX + REAL SFCPRS + REAL SFCTMP + REAL SIGMA + REAL SLV + REAL SMC(NSOIL) + REAL SMCREF + REAL SMCWLT + REAL SOLAR + REAL TOPT + REAL SLVCP + REAL ST1 + REAL TAIR4 + REAL XLAI + REAL ZSOIL(NSOIL) + + PARAMETER(CP = 1004.5) + PARAMETER(RD = 287.04) + PARAMETER(SIGMA = 5.67E-8) + PARAMETER(SLV = 2.501000E6) + +! ---------------------------------------------------------------------- +! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. +! ---------------------------------------------------------------------- + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + RCSOIL = 0.0 + RC = 0.0 + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION +! ---------------------------------------------------------------------- + FF = 0.55*2.0*SOLAR/(RGL*XLAI) + RCS = (FF + RSMIN/RSMAX) / (1.0 + FF) + RCS = MAX(RCS,0.0001) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND +! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). +! ---------------------------------------------------------------------- + RCT = 1.0 - 0.0016*((TOPT-SFCTMP)**2.0) + RCT = MAX(RCT,0.0001) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. +! RCQ EXPRESSION FROM SSIB +! ---------------------------------------------------------------------- + RCQ = 1.0/(1.0+HS*(Q2SAT-Q2)) + RCQ = MAX(RCQ,0.01) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. +! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. +! ---------------------------------------------------------------------- + GX = (SMC(1) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX .GT. 1.) GX = 1. + IF (GX .LT. 0.) GX = 0. + +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- + PART(1) = (ZSOIL(1)/ZSOIL(NROOT)) * GX +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(1) = RTDIS(1) * GX +! ---------------------------------------------------------------------- + IF (NROOT .GT. 1) THEN + DO K = 2,NROOT + GX = (SMC(K) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX .GT. 1.) GX = 1. + IF (GX .LT. 0.) GX = 0. +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- + PART(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT)) * GX +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(K) = RTDIS(K) * GX +! ---------------------------------------------------------------------- + END DO + ENDIF + + DO K = 1,NROOT + RCSOIL = RCSOIL+PART(K) + END DO + RCSOIL = MAX(RCSOIL,0.0001) + +! ---------------------------------------------------------------------- +! DETERMINE CANOPY RESISTANCE DUE TO ALL FACTORS. CONVERT CANOPY +! RESISTANCE (RC) TO PLANT COEFFICIENT (PC) TO BE USED WITH POTENTIAL +! EVAP IN DETERMINING ACTUAL EVAP. PC IS DETERMINED BY: +! PC * LINERIZED PENMAN POTENTIAL EVAP = +! PENMAN-MONTEITH ACTUAL EVAPORATION (CONTAINING RC TERM). +! ---------------------------------------------------------------------- + RC = RSMIN/(XLAI*RCS*RCT*RCQ*RCSOIL) + +! TAIR4 = SFCTMP**4. +! ST1 = (4.*SIGMA*RD)/CP +! SLVCP = SLV/CP +! RR = ST1*TAIR4/(SFCPRS*CH) + 1.0 + RR = (4.*SIGMA*RD/CP)*(SFCTMP**4.)/(SFCPRS*CH) + 1.0 + DELTA = (SLV/CP)*DQSDT2 + + PC = (RR+DELTA)/(RR*(1.+RC*CH)+DELTA) + +! ---------------------------------------------------------------------- +! END SUBROUTINE CANRES +! ---------------------------------------------------------------------- + END SUBROUTINE CANRES + + SUBROUTINE DEVAP (EDIR1,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & + & DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE DEVAP +! ---------------------------------------------------------------------- +! CALCULATE DIRECT SOIL EVAPORATION +! ---------------------------------------------------------------------- + REAL BEXP +! REAL DEVAP + REAL EDIR1 + REAL DKSAT + REAL DWSAT + REAL ETP1 + REAL FX + REAL FXEXP + REAL SHDFAC + REAL SMC + REAL SMCDRY + REAL SMCMAX + REAL ZSOIL + REAL SMCREF + REAL SMCWLT + REAL SRATIO + +! ---------------------------------------------------------------------- +! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR +! WHEN FXEXP=1. +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO .GT. 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + +! ---------------------------------------------------------------------- +! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE +! ---------------------------------------------------------------------- +! DEVAP = FX * ( 1.0 - SHDFAC ) * ETP1 + EDIR1 = FX * ( 1.0 - SHDFAC ) * ETP1 + +! ---------------------------------------------------------------------- +! END SUBROUTINE DEVAP +! ---------------------------------------------------------------------- + END SUBROUTINE DEVAP + + SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + & SH2O, & + & SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + & SMCREF,SHDFAC,CMCMAX, & + & SMCDRY,CFACTR, & + & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE EVAPO +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER I + INTEGER K + INTEGER NSOIL + INTEGER NROOT + + REAL BEXP + REAL CFACTR + REAL CMC + REAL CMC2MS + REAL CMCMAX +! REAL DEVAP + REAL DKSAT + REAL DT + REAL DWSAT + REAL EC1 + REAL EDIR1 + REAL ET1(NSOIL) + REAL ETA1 + REAL ETP1 + REAL ETT1 + REAL FXEXP + REAL PC + REAL Q2 + REAL RTDIS(NSOIL) + REAL SFCTMP + REAL SHDFAC + REAL SMC(NSOIL) + REAL SH2O(NSOIL) + REAL SMCDRY + REAL SMCMAX + REAL SMCREF + REAL SMCWLT + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS +! GREATER THAN ZERO. +! ---------------------------------------------------------------------- + EDIR1 = 0. + EC1 = 0. + DO K = 1,NSOIL + ET1(K) = 0. + END DO + ETT1 = 0. + + IF (ETP1 .GT. 0.0) THEN + +! ---------------------------------------------------------------------- +! RETRIEVE DIRECT EVAPORATION FROM SOIL SURFACE. CALL THIS FUNCTION +! ONLY IF VEG COVER NOT COMPLETE. +! FROZEN GROUND VERSION: SH2O STATES REPLACE SMC STATES. +! ---------------------------------------------------------------------- + IF (SHDFAC .LT. 1.) THEN + CALL DEVAP (EDIR1,ETP1,SH2O(1),ZSOIL(1),SHDFAC,SMCMAX, & +! EDIR = DEVAP(ETP1,SH2O(1),ZSOIL(1),SHDFAC,SMCMAX, & + & BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) + ENDIF + +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION, +! AND ACCUMULATE IT FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + IF (SHDFAC.GT.0.0) THEN + + CALL TRANSP (ET1,NSOIL,ETP1,SH2O,CMC,ZSOIL,SHDFAC,SMCWLT, & + & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) + + DO K = 1,NSOIL + ETT1 = ETT1 + ET1(K) + END DO + +! ---------------------------------------------------------------------- +! CALCULATE CANOPY EVAPORATION. +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR CMC=0.0. +! ---------------------------------------------------------------------- + IF (CMC .GT. 0.0) THEN + EC1 = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 + ELSE + EC1 = 0.0 + ENDIF + +! ---------------------------------------------------------------------- +! EC SHOULD BE LIMITED BY THE TOTAL AMOUNT OF AVAILABLE WATER ON THE +! CANOPY. -F.CHEN, 18-OCT-1994 +! ---------------------------------------------------------------------- + CMC2MS = CMC / DT + EC1 = MIN ( CMC2MS, EC1 ) + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! TOTAL UP EVAP AND TRANSP TYPES TO OBTAIN ACTUAL EVAPOTRANSP +! ---------------------------------------------------------------------- + ETA1 = EDIR1 + ETT1 + EC1 + +! ---------------------------------------------------------------------- +! END SUBROUTINE EVAPO +! ---------------------------------------------------------------------- + END SUBROUTINE EVAPO + + SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & + & TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, & + & F1,DF1,QUARTZ,CSOIL,AI,BI,CI) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE HRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + LOGICAL ITAVG + + INTEGER I + INTEGER K + INTEGER NSOIL + +! ---------------------------------------------------------------------- +! DECLARE WORK ARRAYS NEEDED IN TRI-DIAGONAL IMPLICIT SOLVER +! ---------------------------------------------------------------------- + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + +! ---------------------------------------------------------------------- +! DECLARATIONS +! ---------------------------------------------------------------------- + REAL BEXP + REAL CAIR + REAL CH2O + REAL CICE + REAL CSOIL + REAL DDZ + REAL DDZ2 + REAL DENOM + REAL DF1 + REAL DF1N + REAL DF1K + REAL DT + REAL DTSDZ + REAL DTSDZ2 + REAL F1 + REAL HCPCT + REAL PSISAT + REAL QUARTZ + REAL QTOT + REAL RHSTS(NSOIL) + REAL SSOIL + REAL SICE + REAL SMC(NSOIL) + REAL SH2O(NSOIL) + REAL SMCMAX +! REAL SNKSRC + REAL STC(NSOIL) + REAL T0 + REAL TAVG + REAL TBK + REAL TBK1 + REAL TBOT + REAL ZBOT + REAL TSNSR + REAL TSURF + REAL YY + REAL ZSOIL(NSOIL) + REAL ZZ1 + + PARAMETER(T0 = 273.15) + +! ---------------------------------------------------------------------- +! SET SPECIFIC HEAT CAPACITIES OF AIR, WATER, ICE, SOIL MINERAL +! ---------------------------------------------------------------------- + PARAMETER(CAIR = 1004.0) + PARAMETER(CH2O = 4.2E6) + PARAMETER(CICE = 2.106E6) +! NOTE: CSOIL NOW SET IN ROUTINE REDPRM AND PASSED IN +! PARAMETER(CSOIL = 1.26E6) + +! ---------------------------------------------------------------------- +! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. +! ---------------------------------------------------------------------- + ITAVG = .TRUE. +! ITAVG = .FALSE. + +! ---------------------------------------------------------------------- +! BEGIN SECTION FOR TOP SOIL LAYER +! ---------------------------------------------------------------------- +! CALC THE HEAT CAPACITY OF THE TOP SOIL LAYER +! ---------------------------------------------------------------------- + HCPCT = SH2O(1)*CH2O + (1.0-SMCMAX)*CSOIL + (SMCMAX-SMC(1))*CAIR & + & + ( SMC(1) - SH2O(1) )*CICE + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL(2) ) + AI(1) = 0.0 + CI(1) = (DF1 * DDZ) / (ZSOIL(1) * HCPCT) + BI(1) = -CI(1) + DF1 / (0.5 * ZSOIL(1) * ZSOIL(1)*HCPCT*ZZ1) + +! ---------------------------------------------------------------------- +! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL +! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. USE THE TEMP +! GRADIENT AND SUBSFC HEAT FLUX TO CALC "RIGHT-HAND SIDE TENDENCY +! TERMS", OR "RHSTS", FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- + DTSDZ = (STC(1) - STC(2)) / (-0.5 * ZSOIL(2)) + SSOIL = DF1 * (STC(1) - YY) / (0.5 * ZSOIL(1) * ZZ1) + RHSTS(1) = (DF1 * DTSDZ - SSOIL) / (ZSOIL(1) * HCPCT) + +! ---------------------------------------------------------------------- +! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND +! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT APPLIED TO +! POTENTIAL SOIL FREEZING/THAWING IN ROUTINE SNKSRC. +! ---------------------------------------------------------------------- + QTOT = SSOIL - DF1*DTSDZ + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): +! SET TEMP "TSURF" AT TOP OF SOIL COLUMN (FOR USE IN FREEZING SOIL +! PHYSICS LATER IN FUNCTION SUBROUTINE SNKSRC). IF SNOWPACK CONTENT IS +! ZERO, THEN TSURF EXPRESSION BELOW GIVES TSURF = SKIN TEMP. IF +! SNOWPACK IS NONZERO (HENCE ARGUMENT ZZ1=1), THEN TSURF EXPRESSION +! BELOW YIELDS SOIL COLUMN TOP TEMPERATURE UNDER SNOWPACK. THEN +! CALCULATE TEMPERATURE AT BOTTOM INTERFACE OF 1ST SOIL LAYER FOR USE +! LATER IN FUNCTION SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- + IF (ITAVG) THEN + TSURF = (YY + (ZZ1-1) * STC(1)) / ZZ1 + CALL TBND (STC(1),STC(2),ZSOIL,ZBOT,1,NSOIL,TBK) + ENDIF + +! ---------------------------------------------------------------------- +! CALCULATE FROZEN WATER CONTENT IN 1ST SOIL LAYER. +! ---------------------------------------------------------------------- + SICE = SMC(1) - SH2O(1) + +! ---------------------------------------------------------------------- +! IF FROZEN WATER PRESENT OR ANY OF LAYER-1 MID-POINT OR BOUNDING +! INTERFACE TEMPERATURES BELOW FREEZING, THEN CALL SNKSRC TO +! COMPUTE HEAT SOURCE/SINK (AND CHANGE IN FROZEN WATER CONTENT) +! DUE TO POSSIBLE SOIL WATER PHASE CHANGE +! ---------------------------------------------------------------------- + IF ( (SICE .GT. 0.) .OR. (TSURF .LT. T0) .OR. & + & (STC(1) .LT. T0) .OR. (TBK .LT. T0) ) THEN + + IF (ITAVG) THEN + CALL TMPAVG(TAVG,TSURF,STC(1),TBK,ZSOIL,NSOIL,1) + ELSE + TAVG = STC(1) + ENDIF + TSNSR = SNKSRC (TAVG,SMC(1),SH2O(1), & + & ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) + + RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) + ENDIF + +! ---------------------------------------------------------------------- +! THIS ENDS SECTION FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) +! ---------------------------------------------------------------------- + DF1K = DF1 + DO K = 2,NSOIL + +! ---------------------------------------------------------------------- +! CALCULATE HEAT CAPACITY FOR THIS SOIL LAYER. +! ---------------------------------------------------------------------- + HCPCT = SH2O(K)*CH2O +(1.0-SMCMAX)*CSOIL +(SMCMAX-SMC(K))*CAIR & + & + ( SMC(K) - SH2O(K) )*CICE + + IF (K .NE. NSOIL) THEN +! ---------------------------------------------------------------------- +! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY FOR THIS LAYER. +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC(K),QUARTZ,SMCMAX,SH2O(K)) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER +! ---------------------------------------------------------------------- + DENOM = 0.5 * ( ZSOIL(K-1) - ZSOIL(K+1) ) + DTSDZ2 = ( STC(K) - STC(K+1) ) / DENOM + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DDZ2 = 2. / (ZSOIL(K-1) - ZSOIL(K+1)) + CI(K) = -DF1N * DDZ2 / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAYER. +! ---------------------------------------------------------------------- + IF (ITAVG) THEN + CALL TBND (STC(K),STC(K+1),ZSOIL,ZBOT,K,NSOIL,TBK1) + ENDIF + ELSE + +! ---------------------------------------------------------------------- +! SPECIAL CASE OF BOTTOM SOIL LAYER: CALCULATE THERMAL DIFFUSIVITY FOR +! BOTTOM LAYER. +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC(K),QUARTZ,SMCMAX,SH2O(K)) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. +! ---------------------------------------------------------------------- + DENOM = .5 * (ZSOIL(K-1) + ZSOIL(K)) - ZBOT + DTSDZ2 = (STC(K)-TBOT) / DENOM + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO IF BOTTOM LAYER. +! ---------------------------------------------------------------------- + CI(K) = 0. + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + IF (ITAVG) THEN + CALL TBND (STC(K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + ENDIF + + ENDIF +! ---------------------------------------------------------------------- +! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. +! ---------------------------------------------------------------------- +! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL(K) - ZSOIL(K-1) ) * HCPCT + RHSTS(K) = ( DF1N * DTSDZ2 - DF1K * DTSDZ ) / DENOM + QTOT = -1.0*DENOM*RHSTS(K) + SICE = SMC(K) - SH2O(K) + + IF ( (SICE .GT. 0.) .OR. (TBK .LT. T0) .OR. & + & (STC(K) .LT. T0) .OR. (TBK1 .LT. T0) ) THEN + + IF (ITAVG) THEN + CALL TMPAVG(TAVG,TBK,STC(K),TBK1,ZSOIL,NSOIL,K) + ELSE + TAVG = STC(K) + ENDIF + TSNSR = SNKSRC(TAVG,SMC(K),SH2O(K),ZSOIL,NSOIL, & + & SMCMAX,PSISAT,BEXP,DT,K,QTOT) + RHSTS(K) = RHSTS(K) - TSNSR / DENOM + ENDIF + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI(K) = - DF1 * DDZ / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) + BI(K) = -(AI(K) + CI(K)) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. +! ---------------------------------------------------------------------- + TBK = TBK1 + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO + +! ---------------------------------------------------------------------- +! END SUBROUTINE HRT +! ---------------------------------------------------------------------- + END SUBROUTINE HRT + + SUBROUTINE HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE HRTICE +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE PACK. ALSO TO +! COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX +! OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER K + INTEGER NSOIL + + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + + REAL DDZ + REAL DDZ2 + REAL DENOM + REAL DF1 + REAL DTSDZ + REAL DTSDZ2 + REAL HCPCT + REAL RHSTS(NSOIL) + REAL SSOIL + REAL STC(NSOIL) + REAL TBOT + REAL YY + REAL ZBOT + REAL ZSOIL(NSOIL) + REAL ZZ1 + + DATA TBOT /271.16/ + +! ---------------------------------------------------------------------- +! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY, +! HCPCT = 1880.0*917.0. +! ---------------------------------------------------------------------- + PARAMETER(HCPCT = 1.72396E+6) + +! ---------------------------------------------------------------------- +! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE +! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. +! ---------------------------------------------------------------------- +! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE +! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE +! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK +! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. +! ---------------------------------------------------------------------- + ZBOT = ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL(2) ) + AI(1) = 0.0 + CI(1) = (DF1 * DDZ) / (ZSOIL(1) * HCPCT) + BI(1) = -CI(1) + DF1/(0.5 * ZSOIL(1) * ZSOIL(1) * HCPCT * ZZ1) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. +! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC +! RHSTS FOR THE TOP SOIL LAYER. +! ---------------------------------------------------------------------- + DTSDZ = ( STC(1) - STC(2) ) / ( -0.5 * ZSOIL(2) ) + SSOIL = DF1 * ( STC(1) - YY ) / ( 0.5 * ZSOIL(1) * ZZ1 ) + RHSTS(1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL(1) * HCPCT ) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + IF (K .NE. NSOIL) THEN + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. +! ---------------------------------------------------------------------- + DENOM = 0.5 * ( ZSOIL(K-1) - ZSOIL(K+1) ) + DTSDZ2 = ( STC(K) - STC(K+1) ) / DENOM + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DDZ2 = 2. / (ZSOIL(K-1) - ZSOIL(K+1)) + CI(K) = -DF1 * DDZ2 / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) + ELSE + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC(K)-TBOT)/(.5 * (ZSOIL(K-1) + ZSOIL(K))-ZBOT) + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO. +! ---------------------------------------------------------------------- + CI(K) = 0. + ENDIF + +! ---------------------------------------------------------------------- +! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL(K) - ZSOIL(K-1) ) * HCPCT + RHSTS(K) = ( DF1 * DTSDZ2 - DF1 * DTSDZ ) / DENOM + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI(K) = - DF1 * DDZ / ((ZSOIL(K-1) - ZSOIL(K)) * HCPCT) + BI(K) = -(AI(K) + CI(K)) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. +! ---------------------------------------------------------------------- + DTSDZ = DTSDZ2 + DDZ = DDZ2 + + END DO +! ---------------------------------------------------------------------- +! END SUBROUTINE HRTICE +! ---------------------------------------------------------------------- + END SUBROUTINE HRTICE + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER K + INTEGER NSOIL + + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + REAL CIin(NSOLD) + REAL DT + REAL RHSTS(NSOIL) + REAL RHSTSin(NSOIL) + REAL STCIN(NSOIL) + REAL STCOUT(NSOIL) + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS(K) = RHSTS(K) * DT + AI(K) = AI(K) * DT + BI(K) = 1. + BI(K) * DT + CI(K) = CI(K) * DT + END DO + +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin(K) = RHSTS(K) + END DO + DO K = 1,NSOIL + CIin(K) = CI(K) + END DO + +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12(CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) + +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT(K) = STCIN(K) + CI(K) + END DO + +! ---------------------------------------------------------------------- +! END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP + + SUBROUTINE NOPAC(ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, & + & SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL, & + & STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + & SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, & + & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + & RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + & QUARTZ,FXEXP,CSOIL, & + & BETA,DRIP,DEW,FLX1,FLX2,FLX3) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE NOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES AND UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN NO SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + INTEGER ICE + INTEGER NROOT + INTEGER NSOIL + + REAL BEXP + REAL BETA + REAL CFACTR + REAL CMC + REAL CMCMAX + REAL CP + REAL CSOIL + REAL DEW + REAL DF1 + REAL DKSAT + REAL DRIP + REAL DT + REAL DWSAT + REAL EC + REAL EDIR + REAL EPSCA + REAL ETA + REAL ETA1 + REAL ETP + REAL ETP1 + REAL ET(NSOIL) + REAL ETT + REAL FDOWN + REAL F1 + REAL FXEXP + REAL FLX1 + REAL FLX2 + REAL FLX3 + REAL FRZFACT + REAL KDT + REAL PC + REAL PRCP + REAL PRCP1 + REAL PSISAT + REAL Q2 + REAL QUARTZ + REAL RCH + REAL RR + REAL RTDIS(NSOIL) + REAL RUNOFF1 + REAL RUNOFF2 + REAL RUNOFF3 + REAL SSOIL + REAL SBETA + REAL SFCTMP + REAL SHDFAC + REAL SH2O(NSOIL) + REAL SIGMA + REAL SLOPE + REAL SMC(NSOIL) + REAL SMCDRY + REAL SMCMAX + REAL SMCREF + REAL SMCWLT + REAL STC(NSOIL) + REAL T1 + REAL T24 + REAL TBOT + REAL TH2 + REAL YY + REAL YYNUM + REAL ZBOT + REAL ZSOIL(NSOIL) + REAL ZZ1 + + REAL EC1 + REAL EDIR1 + REAL ET1(NSOIL) + REAL ETT1 + + INTEGER K + + PARAMETER(CP = 1004.5) + PARAMETER(SIGMA = 5.67E-8) + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! CONVERT ETP FROM KG M-2 S-1 TO MS-1 AND INITIALIZE DEW. +! ---------------------------------------------------------------------- + PRCP1 = PRCP * 0.001 + ETP1 = ETP * 0.001 + DEW = 0.0 + + EDIR = 0. + EDIR1 = 0. + EC = 0. + EC1 = 0. + DO K = 1,NSOIL + ET(K) = 0. + ET1(K) = 0. + END DO + ETT = 0. + ETT1 = 0. + + IF (ETP .GT. 0.0) THEN + +! ---------------------------------------------------------------------- +! CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1'. +! ---------------------------------------------------------------------- + CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + & SMCREF,SHDFAC,CMCMAX, & + & SMCDRY,CFACTR, & + & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR1,EC1,ET1, & + & DRIP) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FM M S-1 TO KG M-2 S-1 +! ---------------------------------------------------------------------- +! ETA = ETA1 * 1000.0 + +! ---------------------------------------------------------------------- +! EDIR = EDIR1 * 1000.0 +! EC = EC1 * 1000.0 +! ETT = ETT1 * 1000.0 +! ET(1) = ET1(1) * 1000.0 +! ET(2) = ET1(2) * 1000.0 +! ET(3) = ET1(3) * 1000.0 +! ET(4) = ET1(4) * 1000.0 +! ---------------------------------------------------------------------- + + ELSE + +! ---------------------------------------------------------------------- +! IF ETP < 0, ASSUME DEW FORMS (TRANSFORM ETP1 INTO DEW AND REINITIALIZE +! ETP1 TO ZERO). +! ---------------------------------------------------------------------- + DEW = -ETP1 +! ETP1 = 0.0 + +! ---------------------------------------------------------------------- +! CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1' AND ADD DEW AMOUNT. +! ---------------------------------------------------------------------- + PRCP1 = PRCP1 + DEW +! +! CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, +! & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, +! & SMCREF,SHDFAC,CMCMAX, +! & SMCDRY,CFACTR, +! & EDIR1,EC1,ET1,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR1,EC1,ET1, & + & DRIP) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. +! ---------------------------------------------------------------------- +! ETA = ETA1 * 1000.0 + +! ---------------------------------------------------------------------- +! EDIR = EDIR1 * 1000.0 +! EC = EC1 * 1000.0 +! ETT = ETT1 * 1000.0 +! ET(1) = ET1(1) * 1000.0 +! ET(2) = ET1(2) * 1000.0 +! ET(3) = ET1(3) * 1000.0 +! ET(4) = ET1(4) * 1000.0 +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FM M S-1 TO KG M-2 S-1 +! ---------------------------------------------------------------------- + ETA = ETA1 * 1000.0 + +! ---------------------------------------------------------------------- + EDIR = EDIR1 * 1000.0 + EC = EC1 * 1000.0 + DO K = 1,NSOIL + ET(K) = ET1(K) * 1000.0 +! ET(1) = ET1(1) * 1000.0 +! ET(2) = ET1(2) * 1000.0 +! ET(3) = ET1(3) * 1000.0 +! ET(4) = ET1(4) * 1000.0 + ENDDO + ETT = ETT1 * 1000.0 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! BASED ON ETP AND E VALUES, DETERMINE BETA +! ---------------------------------------------------------------------- + IF ( ETP .LE. 0.0 ) THEN + BETA = 0.0 + IF ( ETP .LT. 0.0 ) THEN + BETA = 1.0 +! ETA = ETP + ENDIF + ELSE + BETA = ETA / ETP + ENDIF + +! ---------------------------------------------------------------------- +! GET SOIL THERMAL DIFFUXIVITY/CONDUCTIVITY FOR TOP SOIL LYR, +! CALC. ADJUSTED TOP LYR SOIL TEMP AND ADJUSTED SOIL FLUX, THEN +! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. +! ---------------------------------------------------------------------- + CALL TDFCND (DF1,SMC(1),QUARTZ,SMCMAX,SH2O(1)) + +! ---------------------------------------------------------------------- +! VEGETATION GREENNESS FRACTION REDUCTION IN SUBSURFACE HEAT FLUX +! VIA REDUCTION FACTOR, WHICH IS CONVENIENT TO APPLY HERE TO THERMAL +! DIFFUSIVITY THAT IS LATER USED IN HRT TO COMPUTE SUB SFC HEAT FLUX +! (SEE ADDITIONAL COMMENTS ON VEG EFFECT SUB-SFC HEAT FLX IN +! ROUTINE SFLX) +! ---------------------------------------------------------------------- + DF1 = DF1 * EXP(SBETA*SHDFAC) + +! ---------------------------------------------------------------------- +! COMPUTE INTERMEDIATE TERMS PASSED TO ROUTINE HRT (VIA ROUTINE +! SHFLX BELOW) FOR USE IN COMPUTING SUBSURFACE HEAT FLUX IN HRT +! ---------------------------------------------------------------------- + YYNUM = FDOWN - SIGMA * T24 + YY = SFCTMP + (YYNUM/RCH+TH2-SFCTMP-BETA*EPSCA) / RR + ZZ1 = DF1 / ( -0.5 * ZSOIL(1) * RCH * RR ) + 1.0 + + CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + & QUARTZ,CSOIL) + +! ---------------------------------------------------------------------- +! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE +! THEY ARE NOT USED HERE IN SNOPAC. FLX2 (FREEZING RAIN HEAT FLUX) WAS +! SIMILARLY INITIALIZED IN THE PENMAN ROUTINE. +! ---------------------------------------------------------------------- + FLX1 = 0.0 + FLX3 = 0.0 + +! ---------------------------------------------------------------------- +! END SUBROUTINE NOPAC +! ---------------------------------------------------------------------- + END SUBROUTINE NOPAC + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE PENMAN +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + LOGICAL SNOWNG + LOGICAL FRZGRA + + REAL A + REAL BETA + REAL CH + REAL CP + REAL CPH2O + REAL CPICE + REAL DELTA + REAL DQSDT2 + REAL ELCP + REAL EPSCA + REAL ETP + REAL FDOWN + REAL FLX2 + REAL FNET + REAL LSUBC + REAL LSUBF + REAL PRCP + REAL Q2 + REAL Q2SAT + REAL R + REAL RAD + REAL RCH + REAL RHO + REAL RR + REAL SSOIL + REAL SFCPRS + REAL SFCTMP + REAL SIGMA + REAL T24 + REAL T2V + REAL TH2 + + PARAMETER(CP = 1004.6) + PARAMETER(CPH2O = 4.218E+3) + PARAMETER(CPICE = 2.106E+3) + PARAMETER(R = 287.04) + PARAMETER(ELCP = 2.4888E+3) + PARAMETER(LSUBF = 3.335E+5) + PARAMETER(LSUBC = 2.501000E+6) + PARAMETER(SIGMA = 5.67E-8) + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! ---------------------------------------------------------------------- + FLX2 = 0.0 + +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + DELTA = ELCP * DQSDT2 + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP + RR = T24 * 6.48E-8 /(SFCPRS * CH) + 1.0 + RHO = SFCPRS / (R * T2V) + RCH = RHO * CP * CH + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + IF (.NOT. SNOWNG) THEN + IF (PRCP .GT. 0.0) RR = RR + CPH2O*PRCP/RCH + ELSE + RR = RR + CPICE*PRCP/RCH + ENDIF + + FNET = FDOWN - SIGMA*T24 - SSOIL + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- + IF (FRZGRA) THEN + FLX2 = -LSUBF * PRCP + FNET = FNET - FLX2 + ENDIF + +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + RAD = FNET/RCH + TH2 - SFCTMP + A = ELCP * (Q2SAT - Q2) + EPSCA = (A*RR + RAD*DELTA) / (DELTA + RR) + ETP = EPSCA * RCH / LSUBC + +! ---------------------------------------------------------------------- +! END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN + + SUBROUTINE REDPRM ( & + & VEGTYP,SOILTYP,SLOPETYP, & + & CFACTR,CMCMAX,RSMAX,TOPT,REFKDT,KDT,SBETA, & + & SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX,PSISAT,SLOPE, & + & SNUP,SALP,BEXP,DKSAT,DWSAT, & + & SMCMAX,SMCWLT,SMCREF, & + & SMCDRY,F1,QUARTZ,FXEXP,RTDIS,SLDPTH,ZSOIL, & + & NROOT,NSOIL,Z0,CZIL,LAI,CSOIL,PTU) + + IMPLICIT NONE +! ---------------------------------------------------------------------- +! SUBROUTINE REDPRM +! ---------------------------------------------------------------------- +! INTERNALLY SET (DEFAULT VALUESS), OR OPTIONALLY READ-IN VIA NAMELIST +! I/O, ALL SOIL AND VEGETATION PARAMETERS REQUIRED FOR THE EXECUSION OF +! THE NOAH LSM. +! +! OPTIONAL NON-DEFAULT PARAMETERS CAN BE READ IN, ACCOMMODATING UP TO 30 +! SOIL, VEG, OR SLOPE CLASSES, IF THE DEFAULT MAX NUMBER OF SOIL, VEG, +! AND/OR SLOPE TYPES IS RESET. +! +! FUTURE UPGRADES OF ROUTINE REDPRM MUST EXPAND TO INCORPORATE SOME OF +! THE EMPIRICAL PARAMETERS OF THE FROZEN SOIL AND SNOWPACK PHYSICS (SUCH +! AS IN ROUTINES FRH2O, SNOWPACK, AND SNOW_NEW) NOT YET SET IN THIS +! REDPRM ROUTINE, BUT RATHER SET IN LOWER LEVEL SUBROUTINES. +! +! SET MAXIMUM NUMBER OF SOIL-, VEG-, AND SLOPETYP IN DATA STATEMENT. +! ---------------------------------------------------------------------- + INTEGER MAX_SLOPETYP + INTEGER MAX_SOILTYP + INTEGER MAX_VEGTYP + + PARAMETER(MAX_SLOPETYP = 30) + PARAMETER(MAX_SOILTYP = 30) + PARAMETER(MAX_VEGTYP = 30) + +! ---------------------------------------------------------------------- +! NUMBER OF DEFINED SOIL-, VEG-, AND SLOPETYPS USED. +! ---------------------------------------------------------------------- + INTEGER DEFINED_VEG + INTEGER DEFINED_SOIL + INTEGER DEFINED_SLOPE + + DATA DEFINED_VEG/27/ + DATA DEFINED_SOIL/19/ + DATA DEFINED_SLOPE/9/ + +! ---------------------------------------------------------------------- +! SET-UP SOIL PARAMETERS FOR GIVEN SOIL TYPE +! INPUT: SOLTYP: SOIL TYPE (INTEGER INDEX) +! OUTPUT: SOIL PARAMETERS: +! MAXSMC: MAX SOIL MOISTURE CONTENT (POROSITY) +! REFSMC: REFERENCE SOIL MOISTURE (ONSET OF SOIL MOISTURE +! STRESS IN TRANSPIRATION) +! WLTSMC: WILTING PT SOIL MOISTURE CONTENTS +! DRYSMC: AIR DRY SOIL MOIST CONTENT LIMITS +! SATPSI: SATURATED SOIL POTENTIAL +! SATDK: SATURATED SOIL HYDRAULIC CONDUCTIVITY +! BB: THE 'B' PARAMETER +! SATDW: SATURATED SOIL DIFFUSIVITY +! F11: USED TO COMPUTE SOIL DIFFUSIVITY/CONDUCTIVITY +! QUARTZ: SOIL QUARTZ CONTENT +! ---------------------------------------------------------------------- +! SOIL STATSGO +! TYPE CLASS +! ---- ------- +! 1 SAND +! 2 LOAMY SAND +! 3 SANDY LOAM +! 4 SILT LOAM +! 5 SILT +! 6 LOAM +! 7 SANDY CLAY LOAM +! 8 SILTY CLAY LOAM +! 9 CLAY LOAM +! 10 SANDY CLAY +! 11 SILTY CLAY +! 12 CLAY +! 13 ORGANIC MATERIAL +! 14 WATER +! 15 BEDROCK +! 16 OTHER(land-ice) +! 17 PLAYA +! 18 LAVA +! 19 WHITE SAND +! ---------------------------------------------------------------------- + + REAL BB(MAX_SOILTYP) + REAL DRYSMC(MAX_SOILTYP) + REAL F11(MAX_SOILTYP) + REAL MAXSMC(MAX_SOILTYP) + REAL REFSMC(MAX_SOILTYP) + REAL SATPSI(MAX_SOILTYP) + REAL SATDK(MAX_SOILTYP) + REAL SATDW(MAX_SOILTYP) + REAL WLTSMC(MAX_SOILTYP) + REAL QTZ(MAX_SOILTYP) + + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL F1 + REAL PTU + REAL QUARTZ + REAL REFSMC1 + REAL SMCDRY + REAL SMCMAX + REAL SMCREF + REAL SMCWLT + REAL WLTSMC1 + +! ---------------------------------------------------------------------- +! SOIL TEXTURE-RELATED ARRAYS. +! ---------------------------------------------------------------------- + DATA MAXSMC/0.395, 0.421, 0.434, 0.476, 0.476, 0.439, & + & 0.404, 0.464, 0.465, 0.406, 0.468, 0.457, & + & 0.464, 0.464, 0.200, 0.421, 0.457, 0.200, & + & 0.395, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ +! ---------------------------------------------------------------------- + DATA SATPSI/0.0350, 0.0363, 0.1413, 0.7586, 0.7586, 0.3548, & + & 0.1349, 0.6166, 0.2630, 0.0977, 0.3236, 0.4677, & + & 0.3548, 0.3548, 0.0350, 0.0363, 0.4677, 0.0350, & + & 0.0350, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & + & 0.000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000/ +! ---------------------------------------------------------------------- + DATA SATDK /1.7600E-4, 1.4078E-5, 5.2304E-6, 2.8089E-6, 2.8089E-6,& + & 3.3770E-6, 4.4518E-6, 2.0348E-6, 2.4464E-6, 7.2199E-6,& + & 1.3444E-6, 9.7394E-7, 3.3770E-6, 3.3770E-6, 1.4078E-5,& + & 1.4078E-5, 9.7394E-7, 1.4078E-5, 1.7600E-4, 0.0,& + & 0.0, 0.0, 0.0, 0.0, 0.0,& + & 0.0, 0.0, 0.0, 0.0, 0.0/ +! ---------------------------------------------------------------------- + DATA BB /4.05, 4.26, 4.74, 5.33, 5.33, 5.25, & + & 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, & + & 5.25, 5.25, 4.05, 4.26, 11.55, 4.05, & + & 4.05, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ +! ---------------------------------------------------------------------- + DATA QTZ /0.92, 0.82, 0.60, 0.25, 0.10, 0.40, & + & 0.60, 0.10, 0.35, 0.52, 0.10, 0.25, & + & 0.05, 0.05, 0.07, 0.25, 0.60, 0.52, & + & 0.92, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/ + +! ---------------------------------------------------------------------- +! THE FOLLOWING 5 PARAMETERS ARE DERIVED LATER IN REDPRM.F FROM THE SOIL +! DATA, AND ARE JUST GIVEN HERE FOR REFERENCE AND TO FORCE STATIC +! STORAGE ALLOCATION. -DAG LOHMANN, FEB. 2001 +! ---------------------------------------------------------------------- +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + DATA REFSMC/0.196, 0.248, 0.282, 0.332, 0.332, 0.301, & + & 0.293, 0.368, 0.361, 0.320, 0.388, 0.389, & + & 0.319, 0.000, 0.116, 0.248, 0.389, 0.116, & + & 0.196, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + DATA WLTSMC/0.023, 0.028, 0.047, 0.084, 0.084, 0.066, & + & 0.069, 0.120, 0.103, 0.100, 0.126, 0.135, & + & 0.069, 0.000, 0.012, 0.028, 0.135, 0.012, & + & 0.023, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + DATA DRYSMC/0.023, 0.028, 0.047, 0.084, 0.084, 0.066, & + & 0.069, 0.120, 0.103, 0.100, 0.126, 0.135, & + & 0.069, 0.000, 0.012, 0.028, 0.135, 0.012, & + & 0.023, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ + +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + DATA SATDW /0.632E-4, 0.517E-5, 0.807E-5, 0.239E-4, 0.239E-4, & + & 0.143E-4, 0.101E-4, 0.236E-4, 0.113E-4, 0.186E-4, & + & 0.966E-5, 0.115E-4, 0.136E-4, 0.0, 0.998E-5, & + & 0.517E-5, 0.115E-4, 0.998E-5, 0.632E-4, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0/ +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + DATA F11 /-1.090, -1.041, -0.568, 0.162, 0.162, -0.327, & + & -1.535, -1.118, -1.297, -3.211, -1.916, -2.258, & + & -0.201, 0.000, -2.287, -1.041, -2.258, -2.287, & + & -1.090, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/ + +! ---------------------------------------------------------------------- +! SET-UP VEGETATION PARAMETERS FOR A GIVEN VEGETAION TYPE: +! INPUT: VEGTYP = VEGETATION TYPE (INTEGER INDEX) +! OUPUT: VEGETATION PARAMETERS +! SHDFAC: VEGETATION GREENNESS FRACTION +! RSMIN: MIMIMUM STOMATAL RESISTANCE +! RGL: PARAMETER USED IN SOLAR RAD TERM OF +! CANOPY RESISTANCE FUNCTION +! HS: PARAMETER USED IN VAPOR PRESSURE DEFICIT TERM OF +! CANOPY RESISTANCE FUNCTION +! SNUP: THRESHOLD SNOW DEPTH (IN WATER EQUIVALENT M) THAT +! IMPLIES 100% SNOW COVER +! ---------------------------------------------------------------------- +! CLASS USGS-WRF VEGETATION/SURFACE TYPE +! 1 Urban and Built-Up Land +! 2 Dryland Cropland and Pasture +! 3 Irrigated Cropland and Pasture +! 4 Mixed Dryland/Irrigated Cropland and Pasture +! 5 Cropland/Grassland Mosaic +! 6 Cropland/Woodland Mosaic +! 7 Grassland +! 8 Shrubland +! 9 Mixed Shrubland/Grassland +! 10 Savanna +! 11 Deciduous Broadleaf Forest +! 12 Deciduous Needleleaf Forest +! 13 Evergreen Broadleaf Forest +! 14 Evergreen Needleleaf Forest +! 15 Mixed Forest +! 16 Water Bodies +! 17 Herbaceous Wetland +! 18 Wooded Wetland +! 19 Barren or Sparsely Vegetated +! 20 Herbaceous Tundra +! 21 Wooded Tundra +! 22 Mixed Tundra +! 23 Bare Ground Tundra +! 24 Snow or Ice +! 25 Playa +! 26 Lava +! 27 White Sand +! ---------------------------------------------------------------------- + + INTEGER NROOT + INTEGER NROOT_DATA(MAX_VEGTYP) + + REAL FRZFACT + REAL HS + REAL HSTBL(MAX_VEGTYP) + REAL LAI + REAL LAI_DATA(MAX_VEGTYP) + REAL PSISAT + REAL RSMIN + REAL RGL + REAL RGLTBL(MAX_VEGTYP) + REAL RSMTBL(MAX_VEGTYP) + REAL SHDFAC + REAL SNUP + REAL SNUPX(MAX_VEGTYP) + REAL Z0 + REAL Z0_DATA(MAX_VEGTYP) + +! ---------------------------------------------------------------------- +! VEGETATION CLASS-RELATED ARRAYS +! ---------------------------------------------------------------------- +! DATA NROOT_DATA /2,3,3,3,3,3,3,3,3,3, +! & 4,4,4,4,4,2,2,2,2,3, +! & 3,3,2,2,2,2,2,0,0,0/ + DATA NROOT_DATA /1,3,3,3,3,3,3,3,3,3, & + & 4,4,4,4,4,0,2,2,1,3, & + & 3,3,2,1,1,1,1,0,0,0/ + DATA RSMTBL /200.0, 70.0, 70.0, 70.0, 70.0, 70.0, & + & 70.0, 300.0, 170.0, 70.0, 100.0, 150.0, & + & 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, & + & 300.0, 150.0, 150.0, 150.0, 200.0, 200.0, & + & 40.0, 100.0, 300.0, 0.0, 0.0, 0.0/ + DATA RGLTBL /100.0, 100.0, 100.0, 100.0, 100.0, 65.0, & + & 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, & + & 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, & + & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, & + & 100.0, 100.0, 100.0, 0.0, 0.0, 0.0/ + DATA HSTBL /42.00, 36.25, 36.25, 36.25, 36.25, 44.14, & + & 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, & + & 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, & + & 42.00, 42.00, 42.00, 42.00, 42.00, 42.00, & + & 36.25, 42.00, 42.00, 0.00, 0.00, 0.00/ + DATA SNUPX /0.020, 0.020, 0.020, 0.020, 0.020, 0.020, & + & 0.020, 0.020, 0.020, 0.040, 0.040, 0.040, & + & 0.040, 0.040, 0.040, 0.010, 0.013, 0.020, & + & 0.013, 0.020, 0.020, 0.020, 0.020, 0.013, & + & 0.013, 0.013, 0.013, 0.000, 0.000, 0.000/ + DATA Z0_DATA / 1.00, 0.07, 0.07, 0.07, 0.07, 0.15, & + & 0.08, 0.03, 0.05, 0.86, 0.80, 0.85, & + & 2.65, 1.09, 0.80, 0.001, 0.04, 0.05, & + & 0.01, 0.04, 0.06, 0.05, 0.03, 0.001, & + & 0.01, 0.15, 0.01, 0.00, 0.00, 0.00/ + DATA LAI_DATA /4.0, 4.0, 4.0, 4.0, 4.0, 4.0, & + & 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, & + & 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, & + & 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, & + & 4.0, 4.0, 4.0, 0.0, 0.0, 0.0/ + +! ---------------------------------------------------------------------- +! CLASS PARAMETER 'SLOPETYP' WAS INCLUDED TO ESTIMATE LINEAR RESERVOIR +! COEFFICIENT 'SLOPE' TO THE BASEFLOW RUNOFF OUT OF THE BOTTOM LAYER. +! LOWEST CLASS (SLOPETYP=0) MEANS HIGHEST SLOPE PARAMETER = 1. +! DEFINITION OF SLOPETYP FROM 'ZOBLER' SLOPE TYPE: +! SLOPE CLASS PERCENT SLOPE +! 1 0-8 +! 2 8-30 +! 3 > 30 +! 4 0-30 +! 5 0-8 & > 30 +! 6 8-30 & > 30 +! 7 0-8, 8-30, > 30 +! 9 GLACIAL ICE +! BLANK OCEAN/SEA +! ---------------------------------------------------------------------- +! NOTE: +! CLASS 9 FROM 'ZOBLER' FILE SHOULD BE REPLACED BY 8 AND 'BLANK' 9 +! ---------------------------------------------------------------------- + REAL SLOPE + REAL SLOPE_DATA(MAX_SLOPETYP) + + DATA SLOPE_DATA /0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & + & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/ + +! ---------------------------------------------------------------------- +! SET NAMELIST FILE NAME +! ---------------------------------------------------------------------- + CHARACTER*50 NAMELIST_NAME + +! ---------------------------------------------------------------------- +! SET UNIVERSAL PARAMETERS (NOT DEPENDENT ON SOIL, VEG, SLOPE TYPE) +! ---------------------------------------------------------------------- + INTEGER I + INTEGER NSOIL + INTEGER SLOPETYP + INTEGER SOILTYP + INTEGER VEGTYP + + INTEGER BARE +! DATA BARE /11/ + DATA BARE /19/ + + LOGICAL LPARAM + DATA LPARAM /.TRUE./ + + LOGICAL LFIRST + DATA LFIRST /.TRUE./ + +! ---------------------------------------------------------------------- +! PARAMETER USED TO CALCULATE ROUGHNESS LENGTH OF HEAT. +! ---------------------------------------------------------------------- + REAL CZIL + REAL CZIL_DATA +! changed in version 2.6 June 2nd 2003 +! DATA CZIL_DATA /0.2/ + DATA CZIL_DATA /0.1/ + +! ---------------------------------------------------------------------- +! PARAMETER USED TO CALUCULATE VEGETATION EFFECT ON SOIL HEAT FLUX. +! ---------------------------------------------------------------------- + REAL SBETA + REAL SBETA_DATA + DATA SBETA_DATA /-2.0/ + +! ---------------------------------------------------------------------- +! BARE SOIL EVAPORATION EXPONENT USED IN DEVAP. +! ---------------------------------------------------------------------- + REAL FXEXP + REAL FXEXP_DATA + DATA FXEXP_DATA /2.0/ + +! ---------------------------------------------------------------------- +! SOIL HEAT CAPACITY [J M-3 K-1] +! ---------------------------------------------------------------------- + REAL CSOIL + REAL CSOIL_DATA +! DATA CSOIL_DATA /1.26E+6/ + DATA CSOIL_DATA /2.00E+6/ + +! ---------------------------------------------------------------------- +! SPECIFY SNOW DISTRIBUTION SHAPE PARAMETER SALP - SHAPE PARAMETER OF +! DISTRIBUTION FUNCTION OF SNOW COVER. FROM ANDERSON'S DATA (HYDRO-17) +! BEST FIT IS WHEN SALP = 2.6 +! ---------------------------------------------------------------------- + REAL SALP + REAL SALP_DATA +! changed for version 2.6 June 2nd 2003 +! DATA SALP_DATA /2.6/ + DATA SALP_DATA /4.0/ + +! ---------------------------------------------------------------------- +! KDT IS DEFINED BY REFERENCE REFKDT AND DKSAT; REFDK=2.E-6 IS THE SAT. +! DK. VALUE FOR THE SOIL TYPE 2 +! ---------------------------------------------------------------------- + REAL REFDK + REAL REFDK_DATA + DATA REFDK_DATA /2.0E-6/ + + REAL REFKDT + REAL REFKDT_DATA + DATA REFKDT_DATA /3.0/ + + REAL FRZX + REAL KDT + +! ---------------------------------------------------------------------- +! FROZEN GROUND PARAMETER, FRZK, DEFINITION: ICE CONTENT THRESHOLD ABOVE +! WHICH FROZEN SOIL IS IMPERMEABLE REFERENCE VALUE OF THIS PARAMETER FOR +! THE LIGHT CLAY SOIL (TYPE=3) FRZK = 0.15 M. +! ---------------------------------------------------------------------- + REAL FRZK + REAL FRZK_DATA + DATA FRZK_DATA /0.15/ + + REAL RTDIS(NSOIL) + REAL SLDPTH(NSOIL) + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! SET TWO CANOPY WATER PARAMETERS. +! ---------------------------------------------------------------------- + REAL CFACTR + REAL CFACTR_DATA + DATA CFACTR_DATA /0.5/ + + REAL CMCMAX + REAL CMCMAX_DATA + DATA CMCMAX_DATA /0.5E-3/ + +! ---------------------------------------------------------------------- +! SET MAX. STOMATAL RESISTANCE. +! ---------------------------------------------------------------------- + REAL RSMAX + REAL RSMAX_DATA + DATA RSMAX_DATA /5000.0/ + +! ---------------------------------------------------------------------- +! SET OPTIMUM TRANSPIRATION AIR TEMPERATURE. +! ---------------------------------------------------------------------- + REAL TOPT + REAL TOPT_DATA + DATA TOPT_DATA /298.0/ + +! ---------------------------------------------------------------------- +! SPECIFY DEPTH[M] OF LOWER BOUNDARY SOIL TEMPERATURE. +! ---------------------------------------------------------------------- + REAL ZBOT + REAL ZBOT_DATA +! changed for version 2.5.2 +! DATA ZBOT_DATA /-3.0/ + DATA ZBOT_DATA /-8.0/ + +! ---------------------------------------------------------------------- +! SET TWO SOIL MOISTURE WILT, SOIL MOISTURE REFERENCE PARAMETERS +! ---------------------------------------------------------------------- + REAL SMLOW + REAL SMLOW_DATA + DATA SMLOW_DATA /0.5/ + + REAL SMHIGH + REAL SMHIGH_DATA +! changed in 2.6 from 3 to 6 on June 2nd 2003 + DATA SMHIGH_DATA /3.0/ +! DATA SMHIGH_DATA /6.0/ + +! ---------------------------------------------------------------------- +! NAMELIST DEFINITION: +! ---------------------------------------------------------------------- + NAMELIST /SOIL_VEG/ SLOPE_DATA, RSMTBL, RGLTBL, HSTBL, SNUPX, & + & BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & + & WLTSMC, QTZ, LPARAM, ZBOT_DATA, SALP_DATA, CFACTR_DATA, & + & CMCMAX_DATA, SBETA_DATA, RSMAX_DATA, TOPT_DATA, & + & REFDK_DATA, FRZK_DATA, BARE, DEFINED_VEG, DEFINED_SOIL, & + & DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA, & + & CZIL_DATA, LAI_DATA, CSOIL_DATA + +! ---------------------------------------------------------------------- +! READ NAMELIST FILE TO OVERRIDE DEFAULT PARAMETERS ONLY ONCE. +! NAMELIST_NAME must be 50 characters or less. +! ---------------------------------------------------------------------- + IF (LFIRST) THEN +! WRITE(*,*) 'READ NAMELIST' +! OPEN(58, FILE = 'namelist_filename.txt') +! READ(58,'(A)') NAMELIST_NAME +! CLOSE(58) +! WRITE(*,*) 'Namelist Filename is ', NAMELIST_NAME +! OPEN(59, FILE = NAMELIST_NAME) +! 50 CONTINUE +! READ(59, SOIL_VEG, END=100) +! IF (LPARAM) GOTO 50 +! 100 CONTINUE +! CLOSE(59) +! WRITE(*,NML=SOIL_VEG) + LFIRST = .FALSE. + IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN + WRITE(*,*) 'Warning: DEFINED_SOIL too large in namelist' + STOP 222 + ENDIF + IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN + WRITE(*,*) 'Warning: DEFINED_VEG too large in namelist' + STOP 222 + ENDIF + IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN + WRITE(*,*) 'Warning: DEFINED_SLOPE too large in namelist' + STOP 222 + ENDIF + + SMLOW = SMLOW_DATA + SMHIGH = SMHIGH_DATA + + DO I = 1,DEFINED_SOIL + SATDW(I) = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I)) + F11(I) = ALOG10(SATPSI(I)) + BB(I)*ALOG10(MAXSMC(I)) + 2.0 + REFSMC1 = MAXSMC(I)*(5.79E-9/SATDK(I)) & + & **(1.0/(2.0*BB(I)+3.0)) + REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH + WLTSMC1 = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I)) + WLTSMC(I) = WLTSMC1 - SMLOW * WLTSMC1 + +! ---------------------------------------------------------------------- +! CURRENT VERSION DRYSMC VALUES THAT EQUATE TO WLTSMC. +! FUTURE VERSION COULD LET DRYSMC BE INDEPENDENTLY SET VIA NAMELIST. +! ---------------------------------------------------------------------- + DRYSMC(I) = WLTSMC(I) + END DO + +! ---------------------------------------------------------------------- +! END LFIRST BLOCK +! ---------------------------------------------------------------------- + ENDIF + + IF (SOILTYP .GT. DEFINED_SOIL) THEN + WRITE(*,*) 'Warning: too many soil types' + STOP 333 + ENDIF + IF (VEGTYP .GT. DEFINED_VEG) THEN + WRITE(*,*) 'Warning: too many veg types' + STOP 333 + ENDIF + IF (SLOPETYP .GT. DEFINED_SLOPE) THEN + WRITE(*,*) 'Warning: too many slope types' + STOP 333 + ENDIF + +! ---------------------------------------------------------------------- +! SET-UP UNIVERSAL PARAMETERS (NOT DEPENDENT ON SOILTYP, VEGTYP OR +! SLOPETYP) +! ---------------------------------------------------------------------- + ZBOT = ZBOT_DATA + SALP = SALP_DATA + CFACTR = CFACTR_DATA + CMCMAX = CMCMAX_DATA + SBETA = SBETA_DATA + RSMAX = RSMAX_DATA + TOPT = TOPT_DATA + REFDK = REFDK_DATA + FRZK = FRZK_DATA + FXEXP = FXEXP_DATA + REFKDT = REFKDT_DATA + CZIL = CZIL_DATA + CSOIL = CSOIL_DATA + +! ---------------------------------------------------------------------- +! SET-UP SOIL PARAMETERS +! ---------------------------------------------------------------------- + BEXP = BB(SOILTYP) + DKSAT = SATDK(SOILTYP) + DWSAT = SATDW(SOILTYP) + F1 = F11(SOILTYP) + KDT = REFKDT * DKSAT/REFDK + PSISAT = SATPSI(SOILTYP) + QUARTZ = QTZ(SOILTYP) + SMCDRY = DRYSMC(SOILTYP) + SMCMAX = MAXSMC(SOILTYP) + SMCREF = REFSMC(SOILTYP) + SMCWLT = WLTSMC(SOILTYP) + FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) + +! ---------------------------------------------------------------------- +! TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT +! ---------------------------------------------------------------------- + FRZX = FRZK * FRZFACT + +! ---------------------------------------------------------------------- +! SET-UP VEGETATION PARAMETERS +! ---------------------------------------------------------------------- + NROOT = NROOT_DATA(VEGTYP) + SNUP = SNUPX(VEGTYP) + RSMIN = RSMTBL(VEGTYP) + RGL = RGLTBL(VEGTYP) + HS = HSTBL(VEGTYP) + Z0 = Z0_DATA(VEGTYP) + LAI = LAI_DATA(VEGTYP) + IF (VEGTYP .EQ. BARE) SHDFAC = 0.0 + + IF (NROOT .GT. NSOIL) THEN + WRITE(*,*) 'Warning: too many root layers' + STOP 333 + ENDIF + +! ---------------------------------------------------------------------- +! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM +! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. +! ---------------------------------------------------------------------- + DO I = 1,NROOT + RTDIS(I) = -SLDPTH(I)/ZSOIL(NROOT) + END DO + +! ---------------------------------------------------------------------- +! SET-UP SLOPE PARAMETER +! ---------------------------------------------------------------------- + SLOPE = SLOPE_DATA(SLOPETYP) + +! ---------------------------------------------------------------------- +! END SUBROUTINE REDPRM +! ---------------------------------------------------------------------- + END SUBROUTINE REDPRM + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + INTEGER K + INTEGER KK + INTEGER NSOIL + + REAL A(NSOIL) + REAL B(NSOIL) + REAL C(NSOIL) + REAL D(NSOIL) + REAL DELTA(NSOIL) + REAL P(NSOIL) + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C(NSOIL) = 0.0 + +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + P(1) = -C(1) / B(1) + DELTA(1) = D(1) / B(1) + +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + P(K) = -C(K) * ( 1.0 / (B(K) + A (K) * P(K-1)) ) + DELTA(K) = (D(K)-A(K)*DELTA(K-1))*(1.0/(B(K)+A(K)*P(K-1))) + END DO + +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P(NSOIL) = DELTA(NSOIL) + +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + KK = NSOIL - K + 1 + P(KK) = P(KK) * P(KK+1) + DELTA(KK) + END DO + +! ---------------------------------------------------------------------- +! END SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 + + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + & QUARTZ,CSOIL) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER I + INTEGER ICE + INTEGER IFRZ + INTEGER NSOIL + + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + + REAL BEXP + REAL CSOIL + REAL DF1 + REAL DT + REAL F1 + REAL PSISAT + REAL QUARTZ + REAL RHSTS(NSOLD) + REAL SSOIL + REAL SH2O(NSOIL) + REAL SMC(NSOIL) + REAL SMCMAX + REAL SMCWLT + REAL STC(NSOIL) + REAL STCF(NSOLD) + REAL T0 + REAL T1 + REAL TBOT + REAL YY + REAL ZBOT + REAL ZSOIL(NSOIL) + REAL ZZ1 + + PARAMETER(T0 = 273.15) + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + IF (ICE.EQ.1) THEN + +! ---------------------------------------------------------------------- +! SEA-ICE CASE +! ---------------------------------------------------------------------- + CALL HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + ELSE + +! ---------------------------------------------------------------------- +! LAND-MASS CASE +! ---------------------------------------------------------------------- + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + & ZBOT,PSISAT,SH2O,DT, & + & BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + ENDIF + + DO I = 1,NSOIL + STC(I) = STCF(I) + END DO + +! ---------------------------------------------------------------------- +! IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND +! (SKIN) TEMPERATURE HERE IN RESPONSE TO THE UPDATED SOIL TEMPERATURE +! PROFILE ABOVE. (NOTE: INSPECTION OF ROUTINE SNOPAC SHOWS THAT T1 +! BELOW IS A DUMMY VARIABLE ONLY, AS SKIN TEMPERATURE IS UPDATED +! DIFFERENTLY IN ROUTINE SNOPAC) +! ---------------------------------------------------------------------- + T1 = (YY + (ZZ1 - 1.0) * STC(1)) / ZZ1 + +! ---------------------------------------------------------------------- +! CALCULATE SURFACE SOIL HEAT FLUX +! ---------------------------------------------------------------------- + SSOIL = DF1 * (STC(1) - T1) / (0.5 * ZSOIL(1)) + +! ---------------------------------------------------------------------- +! END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX + + SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR1,EC1,ET1, & + & DRIP) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SMFLX +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER I + INTEGER K + INTEGER NSOIL + + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + + REAL BEXP + REAL CMC + REAL CMCMAX + REAL DKSAT + REAL DRIP + REAL DT + REAL DUMMY + REAL DWSAT + REAL EC1 + REAL EDIR1 + REAL ET1(NSOIL) + REAL EXCESS + REAL FRZFACT + REAL KDT + REAL PCPDRP + REAL PRCP1 + REAL RHSCT + REAL RHSTT(NSOLD) + REAL RUNOFF1 + REAL RUNOFF2 + REAL RUNOFF3 + REAL SHDFAC + REAL SMC(NSOIL) + REAL SH2O(NSOIL) + REAL SICE(NSOLD) + REAL SH2OA(NSOLD) + REAL SH2OFG(NSOLD) + REAL SLOPE + REAL SMCMAX + REAL SMCWLT + REAL TRHSCT + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE. +! ---------------------------------------------------------------------- + DUMMY = 0. + +! ---------------------------------------------------------------------- +! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) +! ---------------------------------------------------------------------- + RHSCT = SHDFAC * PRCP1 - EC1 + +! ---------------------------------------------------------------------- +! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING +! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL +! FALL TO THE GRND. +! ---------------------------------------------------------------------- + DRIP = 0. + TRHSCT = DT * RHSCT + EXCESS = CMC + TRHSCT + IF (EXCESS .GT. CMCMAX) DRIP = EXCESS - CMCMAX + +! ---------------------------------------------------------------------- +! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMC) THAT GOES INTO THE +! SOIL +! ---------------------------------------------------------------------- + PCPDRP = (1. - SHDFAC) * PRCP1 + DRIP / DT + +! ---------------------------------------------------------------------- +! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT & SSTEP +! ---------------------------------------------------------------------- + DO I = 1,NSOIL + SICE(I) = SMC(I) - SH2O(I) + END DO + +! ---------------------------------------------------------------------- +! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE +! TENDENCY EQUATIONS. +! +! IF THE INFILTRATING PRECIP RATE IS NONTRIVIAL, +! (WE CONSIDER NONTRIVIAL TO BE A PRECIP TOTAL OVER THE TIME STEP +! EXCEEDING ONE ONE-THOUSANDTH OF THE WATER HOLDING CAPACITY OF +! THE FIRST SOIL LAYER) +! THEN CALL THE SRT/SSTEP SUBROUTINE PAIR TWICE IN THE MANNER OF +! TIME SCHEME "F" (IMPLICIT STATE, AVERAGED COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU (1988, MWR, VOL 116, +! PAGES 1945-1958)TO MINIMIZE 2-DELTA-T OSCILLATIONS IN THE +! SOIL MOISTURE VALUE OF THE TOP SOIL LAYER THAT CAN ARISE BECAUSE +! OF THE EXTREME NONLINEAR DEPENDENCE OF THE SOIL HYDRAULIC +! DIFFUSIVITY COEFFICIENT AND THE HYDRAULIC CONDUCTIVITY ON THE +! SOIL MOISTURE STATE +! OTHERWISE CALL THE SRT/SSTEP SUBROUTINE PAIR ONCE IN THE MANNER OF +! TIME SCHEME "D" (IMPLICIT STATE, EXPLICIT COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU +! PCPDRP IS UNITS OF KG/M**2/S OR MM/S, ZSOIL IS NEGATIVE DEPTH IN M +! ---------------------------------------------------------------------- +! IF ( PCPDRP .GT. 0.0 ) THEN + IF ( (PCPDRP*DT) .GT. (0.001*1000.0*(-ZSOIL(1))*SMCMAX) ) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! SMC STATES REPLACED BY SH2O STATES IN SRT SUBR. SH2O & SICE STATES +! INCLUDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT +! ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER +! ---------------------------------------------------------------------- + CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + + CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + + DO K = 1,NSOIL + SH2OA(K) = (SH2O(K) + SH2OFG(K)) * 0.5 + END DO + + CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & + & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + + ELSE + + CALL SRT (RHSTT,EDIR1,ET1,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + + ENDIF + +! RUNOF = RUNOFF + +! ---------------------------------------------------------------------- +! END SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + END SUBROUTINE SMFLX + + SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- +! CALCULATE SNOW FRACTION (0 -> 1) +! SNEQV SNOW WATER EQUIVALENT (M) +! SNUP THRESHOLD SNEQV DEPTH ABOVE WHICH SNCOVR=1 +! SALP TUNING PARAMETER +! SNCOVR FRACTIONAL SNOW COVER +! ---------------------------------------------------------------------- + REAL SNEQV, SNUP, SALP, SNCOVR, RSNOW, Z0N, SNOWH + +! ---------------------------------------------------------------------- +! SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE +! REDPRM) ABOVE WHICH SNOCVR=1. +! ---------------------------------------------------------------------- + IF (SNEQV .LT. SNUP) THEN + RSNOW = SNEQV/SNUP + SNCOVR = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP)) + ELSE + SNCOVR = 1.0 + ENDIF + + Z0N=0.035 +! FORMULATION OF DICKINSON ET AL. 1986 + +! SNCOVR=SNOWH/(SNOWH + 5*Z0N) + +! FORMULATION OF MARSHALL ET AL. 1994 +! SNCOVR=SNEQV/(SNEQV + 2*Z0N) + +! ---------------------------------------------------------------------- +! END SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- + END SUBROUTINE SNFRAC + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCP1,SNOWNG,SMC,SMCMAX,SMCWLT, & + & SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + & SBETA,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, & + & SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,ESD,SNDENS,& + & SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT,SNUP, & + & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + & ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + INTEGER ICE + INTEGER NROOT + INTEGER NSOIL + + LOGICAL SNOWNG + + REAL BEXP + REAL BETA + REAL CFACTR + REAL CMC + REAL CMCMAX + REAL CP + REAL CPH2O + REAL CPICE + REAL CSOIL + REAL DENOM + REAL DEW + REAL DF1 + REAL DKSAT + REAL DRIP + REAL DSOIL + REAL DTOT + REAL DT + REAL DWSAT + REAL EC + REAL EDIR + REAL EPSCA + REAL ESD + REAL ESDMIN + REAL EXPSNO + REAL EXPSOI + REAL ETA + REAL ETA1 + REAL ETP + REAL ETP1 + REAL ETP2 + REAL ET(NSOIL) + REAL ETT + REAL EX + REAL EXPFAC + REAL FDOWN + REAL FXEXP + REAL FLX1 + REAL FLX2 + REAL FLX3 + REAL F1 + REAL KDT + REAL LSUBF + REAL LSUBC + REAL LSUBS + REAL PC + REAL PRCP + REAL PRCP1 + REAL Q2 + REAL RCH + REAL RR + REAL RTDIS(NSOIL) + REAL SSOIL + REAL SBETA + REAL SSOIL1 + REAL SFCTMP + REAL SHDFAC + REAL SIGMA + REAL SMC(NSOIL) + REAL SH2O(NSOIL) + REAL SMCDRY + REAL SMCMAX + REAL SMCREF + REAL SMCWLT + REAL SNOMLT + REAL SNOWH + REAL STC(NSOIL) + REAL T1 + REAL T11 + REAL T12 + REAL T12A + REAL T12B + REAL T24 + REAL TBOT + REAL ZBOT + REAL TH2 + REAL YY + REAL ZSOIL(NSOIL) + REAL ZZ1 + REAL TFREEZ + REAL SALP + REAL SFCPRS + REAL SLOPE + REAL FRZFACT + REAL PSISAT + REAL SNUP + REAL RUNOFF1 + REAL RUNOFF2 + REAL RUNOFF3 + REAL QUARTZ + REAL SNDENS + REAL SNCOND + REAL RSNOW + REAL SNCOVR + REAL QSAT + REAL ETP3 + REAL SEH + REAL T14 +! REAL CSNOW + + REAL EC1 + REAL EDIR1 + REAL ET1(NSOIL) + REAL ETT1 + + REAL ETNS + REAL ETNS1 + REAL ESNOW + REAL ESNOW1 + REAL ESNOW2 + REAL ETANRG + + INTEGER K + + REAL SNOEXP + + PARAMETER(CP = 1004.5) + PARAMETER(CPH2O = 4.218E+3) + PARAMETER(CPICE = 2.106E+3) + PARAMETER(ESDMIN = 1.E-6) + PARAMETER(LSUBF = 3.335E+5) + PARAMETER(LSUBC = 2.501000E+6) + PARAMETER(LSUBS = 2.83E+6) + PARAMETER(SIGMA = 5.67E-8) + PARAMETER(TFREEZ = 273.15) + +! DATA SNOEXP /1.0/ + DATA SNOEXP /2.0/ + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO M S-1 AND THEN TO AN +! AMOUNT (M) GIVEN TIMESTEP (DT) AND CALL IT AN EFFECTIVE SNOWPACK +! REDUCTION AMOUNT, ETP2 (M). THIS IS THE AMOUNT THE SNOWPACK WOULD BE +! REDUCED DUE TO EVAPORATION FROM THE SNOW SFC DURING THE TIMESTEP. +! EVAPORATION WILL PROCEED AT THE POTENTIAL RATE UNLESS THE SNOW DEPTH +! IS LESS THAN THE EXPECTED SNOWPACK REDUCTION. +! IF SEAICE (ICE=1), BETA REMAINS=1. +! ---------------------------------------------------------------------- + PRCP1 = PRCP1*0.001 + +! ETP2 = ETP * 0.001 * DT + BETA = 1.0 + IF (ICE .NE. 1) THEN + IF (ESD .LT. ETP2) THEN +! BETA = ESD / ETP2 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- + EDIR = 0.0 + EDIR1 = 0.0 + EC = 0.0 + EC1 = 0.0 + DO K = 1,NSOIL + ET(K) = 0.0 + ET1(K) = 0.0 + ENDDO + ETT = 0.0 + ETT1 = 0.0 + ETNS = 0.0 + ETNS1 = 0.0 + ESNOW = 0.0 + ESNOW1 = 0.0 + ESNOW2 = 0.0 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + DEW = 0.0 + ETP1 = ETP*0.001 + IF (ETP .LT. 0.0) THEN +! DEW = -ETP * 0.001 + DEW = -ETP1 +! ESNOW2 = ETP * 0.001 * DT + ESNOW2 = ETP1 * DT + ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS) +! ENDIF + ELSE +! ---------------------------------------------------------------------- +! ETP1 = 0.0 +! ETP1 = ETP*0.001 + IF (ICE .NE. 1) THEN + IF (SNCOVR .LT. 1.) THEN +! CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, + CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + & SMCREF,SHDFAC,CMCMAX, & + & SMCDRY,CFACTR, & + & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) +! ENDIF +! ---------------------------------------------------------------------- + EDIR1 = EDIR1*(1.-SNCOVR) + EC1 = EC1*(1.-SNCOVR) + DO K = 1,NSOIL + ET1(K) = ET1(K)*(1.-SNCOVR) + END DO + ETT1 = ETT1*(1.-SNCOVR) + ETNS1 = ETNS1*(1.-SNCOVR) +! ---------------------------------------------------------------------- + EDIR = EDIR1 * 1000.0 + EC = EC1 * 1000.0 + DO K = 1,NSOIL + ET(K) = ET1(K) * 1000.0 + END DO + ETT = ETT1 * 1000.0 + ETNS = ETNS1 * 1000.0 +! ---------------------------------------------------------------------- + ENDIF + ESNOW = ETP*SNCOVR +! ESNOW1 = ETP*0.001 + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + ETNS*LSUBC + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GOUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1 - SFCTMP) + ELSE + IF (PRCP .GT. 0.0) FLX1 = CPH2O * PRCP * (T1 - SFCTMP) + ENDIF + +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + DSOIL = -(0.5 * ZSOIL(1)) + DTOT = SNOWH + DSOIL + DENOM = 1.0 + DF1 / (DTOT * RR * RCH) +! T12A = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH +! & + TH2 - SFCTMP - BETA*EPSCA ) / RR +! T12A = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH +! M.Ek, 24Nov04, add snow emissivity + T12A = ((FDOWN-FLX1-FLX2 & + & -(0.95*SNCOVR+(1.0-SNCOVR))*SIGMA*T24)/RCH & + & + TH2 - SFCTMP - ETANRG/RCH ) / RR + T12B = DF1 * STC(1) / (DTOT * RR * RCH) + T12 = (SFCTMP + T12A + T12B) / DENOM + +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- + IF (T12 .LE. TFREEZ) THEN + T1 = T12 + SSOIL = DF1 * (T1 - STC(1)) / DTOT +! ESD = MAX(0.0, ESD-ETP2) + ESD = MAX(0.0, ESD-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + SNOMLT = 0.0 + + ELSE +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- +! T1 = TFREEZ * SNCOVR + T12 * (1.0 - SNCOVR) +! mek Feb2004 +! non-linear weighting of snow vs non-snow covered portions of gridbox +! so with SNOEXP = 2.0 (>1), surface skin temperature is higher than for +! the linear case (SNOEXP = 1). + T1 = TFREEZ * SNCOVR**SNOEXP + T12 * (1.0 - SNCOVR**SNOEXP) +! QSAT = (0.622*6.11E2)/(SFCPRS-0.378*6.11E2) +! ETP = RCH*(QSAT-Q2)/CP +! ETP2 = ETP*0.001*DT + BETA = 1.0 + SSOIL = DF1 * (T1 - STC(1)) / DTOT + +! ---------------------------------------------------------------------- +! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. +! BETA<1 +! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. +! ---------------------------------------------------------------------- +! IF (ESD .LE. ETP2) THEN +! IF (ESD .LE. ESNOW2) THEN + IF (ESD-ESNOW2 .LE. ESDMIN) THEN +! BETA = ESD / ETP2 + ESD = 0.0 + EX = 0.0 + SNOMLT = 0.0 + + ELSE +! ---------------------------------------------------------------------- +! POTENTIAL EVAP (SUBLIMATION) LESS THAN DEPTH OF SNOWPACK, RETAIN +! BETA=1. +! SNOWPACK (ESD) REDUCED BY POTENTIAL EVAP RATE +! ETP3 (CONVERT TO FLUX) +! ---------------------------------------------------------------------- +! ESD = ESD-ETP2 + ESD = ESD-ESNOW2 +! ETP3 = ETP*LSUBC + SEH = RCH*(T1-TH2) + T14 = T1*T1 + T14 = T14*T14 +! FLX3 = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETP3 +! FLX3 = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETANRG +! M.Ek, 24Nov04, add snow emissivity + FLX3 = FDOWN - FLX1 - FLX2 - & + & (0.95*SNCOVR+(1.0-SNCOVR))*SIGMA*T14 - SSOIL - SEH - ETANRG + IF (FLX3 .LE. 0.0) FLX3 = 0.0 + EX = FLX3*0.001/LSUBF + +! ---------------------------------------------------------------------- +! SNOWMELT REDUCTION DEPENDING ON SNOW COVER +! IF SNOW COVER LESS THAN 5% NO SNOWMELT REDUCTION +! ***NOTE: DOES 'IF' BELOW FAIL TO MATCH THE MELT WATER WITH THE MELT +! ENERGY? +! ---------------------------------------------------------------------- +! IF (SNCOVR .GT. 0.05) EX = EX * SNCOVR + SNOMLT = EX * DT + +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + IF (ESD-SNOMLT .GE. ESDMIN) THEN + ESD = ESD - SNOMLT + + ELSE +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + EX = ESD/DT + FLX3 = EX*1000.0*LSUBF + SNOMLT = ESD + ESD = 0.0 + + ENDIF +! ---------------------------------------------------------------------- +! END OF 'ESD .LE. ETP2' IF-BLOCK +! ---------------------------------------------------------------------- + ENDIF + + PRCP1 = PRCP1 + EX + +! ---------------------------------------------------------------------- +! END OF 'T12 .LE. TFREEZ' IF-BLOCK +! ---------------------------------------------------------------------- + ENDIF + +! ---------------------------------------------------------------------- +! FINAL BETA NOW IN HAND, SO COMPUTE EVAPORATION. EVAP EQUALS ETP +! UNLESS BETA<1. +! ---------------------------------------------------------------------- +! ETA = BETA*ETP + +! ---------------------------------------------------------------------- +! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW +! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR, EC, OR ETT IN SMFLX +! (BELOW). +! IF SEAICE (ICE=1) SKIP CALL TO SMFLX. +! SMFLX RETURNS UPDATED SOIL MOISTURE VALUES. IN THIS, THE SNOW PACK +! CASE, ETA1 IS NOT USED IN CALCULATION OF EVAP. +! ---------------------------------------------------------------------- +! ETP1 = 0.0 + IF (ICE .NE. 1) THEN +! CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, +! & SH2O,SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, +! & SMCREF,SHDFAC,CMCMAX, +! & SMCDRY,CFACTR, +! & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR1,EC1,ET1, & + & DRIP) + + ENDIF + +! ---------------------------------------------------------------------- +! EDIR = EDIR1 * 1000.0 +! EC = EC1 * 1000.0 +! ETT = ETT1 * 1000.0 +! ET(1) = ET1(1) * 1000.0 +! ET(2) = ET1(2) * 1000.0 +! ET(3) = ET1(3) * 1000.0 +! ET(4) = ET1(4) * 1000.0 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTER FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE +! SKIN TEMP VALUE AS REVISED BY SHFLX. +! ---------------------------------------------------------------------- + ZZ1 = 1.0 + YY = STC(1)-0.5*SSOIL*ZSOIL(1)*ZZ1/DF1 + T11 = T1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. NOTE: THE SUB-SFC HEAT FLUX +! (SSOIL1) AND THE SKIN TEMP (T11) OUTPUT FROM THIS SHFLX CALL ARE NOT +! USED IN ANY SUBSEQUENT CALCULATIONS. RATHER, THEY ARE DUMMY VARIABLES +! HERE IN THE SNOPAC CASE, SINCE THE SKIN TEMP AND SUB-SFC HEAT FLUX ARE +! UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC. +! ---------------------------------------------------------------------- + CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & + & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + & QUARTZ,CSOIL) + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + IF (ESD .GT. 0.) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) + ELSE + ESD = 0. + SNOWH = 0. + SNDENS = 0. + SNCOND = 1. + SNCOVR = 0. + ENDIF + +! ---------------------------------------------------------------------- +! END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC + + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! ESD WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) +! +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + INTEGER IPOL, J + + REAL BFAC,C1,C2,SNDENS,DSX,DTHR,DTSEC,DW,SNOWHC,SNOWH,PEXP,TAVGC, & + & TSNOW,TSNOWC,TSOIL,TSOILC,ESD,ESDC,ESDCX,G,KN + + PARAMETER(C1 = 0.01, C2=21.0, G=9.81, KN=4000.0) + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH*100. + ESDC = ESD*100. + DTHR = DTSEC/3600. + TSNOWC = TSNOW-273.15 + TSOILC = TSOIL-273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- + TAVGC = 0.5*(TSNOWC+TSOILC) + +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + IF (ESDC .GT. 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + ENDIF + BFAC = DTHR*C1*EXP(0.08*TAVGC-C2*SNDENS) + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. +! +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + IPOL = 4 + PEXP = 0. + DO J = IPOL,1,-1 +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + PEXP = (1. + PEXP)*BFAC*ESDCX/REAL(J+1) + END DO + PEXP = PEXP + 1. + + DSX = SNDENS*(PEXP) +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*ESD/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + IF (DSX .GT. 0.40) DSX = 0.40 + IF (DSX .LT. 0.05) DSX = 0.05 + SNDENS = DSX +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + IF (TSNOWC .GE. 0.) THEN + DW = 0.13*DTHR/24. + SNDENS = SNDENS*(1.-DW)+DW + IF (SNDENS .GT. 0.40) SNDENS = 0.40 + ENDIF + +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + SNOWHC = ESDC/SNDENS + SNOWH = SNOWHC*0.01 + +! ---------------------------------------------------------------------- +! END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK + + SUBROUTINE SNOWZ0 (SNCOVR,Z0) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! SNCOVR FRACTIONAL SNOW COVER +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + REAL SNCOVR, Z0, Z0S +! PARAMETER (Z0S=0.001) + +! CURRENT NOAH LSM CONDITION - MBEK, 09-OCT-2001 + Z0S = Z0 +! + Z0 = (1-SNCOVR)*Z0 + SNCOVR*Z0S +! ---------------------------------------------------------------------- +! END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITITY TO ACCOUNT FOR THE NEW SNOWFALL. +! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. +! +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + REAL SNDENS + REAL DSNEW + REAL SNOWHC + REAL HNEWC + REAL SNOWH + REAL NEWSN + REAL NEWSNC + REAL TEMP + REAL TEMPC + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH*100. + NEWSNC = NEWSN*100. + TEMPC = TEMP-273.15 + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + IF (TEMPC .LE. -15.) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05+0.0017*(TEMPC+15.)**1.5 + ENDIF + +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC/DSNEW + SNDENS = (SNOWHC*SNDENS+HNEWC*DSNEW)/(SNOWHC+HNEWC) + SNOWHC = SNOWHC+HNEWC + SNOWH = SNOWHC*0.01 + +! ---------------------------------------------------------------------- +! END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW + + SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + & ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER CVFRZ + INTEGER IALP1 + INTEGER IOHINF + INTEGER J + INTEGER JJ + INTEGER K + INTEGER KS + INTEGER NSOIL + + REAL ACRT + REAL AI(NSOLD) + REAL BEXP + REAL BI(NSOLD) + REAL CI(NSOLD) + REAL DD + REAL DDT + REAL DDZ + REAL DDZ2 + REAL DENOM + REAL DENOM2 + REAL DICE + REAL DKSAT + REAL DMAX(NSOLD) + REAL DSMDZ + REAL DSMDZ2 + REAL DT + REAL DT1 + REAL DWSAT + REAL EDIR + REAL ET(NSOIL) + REAL FCR + REAL FRZX + REAL INFMAX + REAL KDT + REAL MXSMC + REAL MXSMC2 + REAL NUMER + REAL PCPDRP + REAL PDDUM + REAL PX + REAL RHSTT(NSOIL) + REAL RUNOFF1 + REAL RUNOFF2 + REAL SH2O(NSOIL) + REAL SH2OA(NSOIL) + REAL SICE(NSOIL) + REAL SICEMAX + REAL SLOPE + REAL SLOPX + REAL SMCAV + REAL SMCMAX + REAL SMCWLT + REAL SSTT + REAL SUM + REAL VAL + REAL WCND + REAL WCND2 + REAL WDF + REAL WDF2 + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + PARAMETER(CVFRZ = 3) + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- + IOHINF=1 + +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + SICEMAX = 0.0 + DO KS=1,NSOIL + IF (SICE(KS) .GT. SICEMAX) SICEMAX = SICE(KS) + END DO + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + PDDUM = PCPDRP + RUNOFF1 = 0.0 + IF (PCPDRP .NE. 0.0) THEN + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF .EQ. 1) THEN + + DT1 = DT/86400. + SMCAV = SMCMAX - SMCWLT + DMAX(1)=-ZSOIL(1)*SMCAV + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DICE = -ZSOIL(1) * SICE(1) + + DMAX(1)=DMAX(1)*(1.0 - (SH2OA(1)+SICE(1)-SMCWLT)/SMCAV) + DD=DMAX(1) + + DO KS=2,NSOIL + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DICE = DICE + ( ZSOIL(KS-1) - ZSOIL(KS) ) * SICE(KS) + + DMAX(KS) = (ZSOIL(KS-1)-ZSOIL(KS))*SMCAV + DMAX(KS) = DMAX(KS)*(1.0 - (SH2OA(KS)+SICE(KS)-SMCWLT)/SMCAV) + DD = DD+DMAX(KS) + END DO + +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + VAL = (1.-EXP(-KDT*DT1)) + DDT = DD*VAL + PX = PCPDRP*DT + IF (PX .LT. 0.0) PX = 0.0 + INFMAX = (PX*(DDT/(PX+DDT)))/DT + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + FCR = 1. + IF (DICE .GT. 1.E-2) THEN + ACRT = CVFRZ * FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J+1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ-J)) / FLOAT (K) + END DO + FCR = 1. - EXP(-ACRT) * SUM + ENDIF + INFMAX = INFMAX * FCR + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + MXSMC = SH2OA(1) + + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + + INFMAX = MAX(INFMAX,WCND) + INFMAX = MIN(INFMAX,PX) + + IF (PCPDRP .GT. INFMAX) THEN + RUNOFF1 = PCPDRP - INFMAX + PDDUM = INFMAX + ENDIF + + ENDIF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + MXSMC = SH2OA(1) + + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( -.5 * ZSOIL(2) ) + AI(1) = 0.0 + BI(1) = WDF * DDZ / ( -ZSOIL(1) ) + CI(1) = -BI(1) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + DSMDZ = ( SH2O(1) - SH2O(2) ) / ( -.5 * ZSOIL(2) ) + RHSTT(1) = (WDF * DSMDZ + WCND - PDDUM + EDIR + ET(1))/ZSOIL(1) + SSTT = WDF * DSMDZ + WCND + EDIR + ET(1) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + DENOM2 = (ZSOIL(K-1) - ZSOIL(K)) + IF (K .NE. NSOIL) THEN + SLOPX = 1. + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + MXSMC2 = SH2OA(K) + + CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + +! ---------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL(K-1) - ZSOIL(K+1)) + DSMDZ2 = (SH2O(K) - SH2O(K+1)) / (DENOM * 0.5) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DDZ2 = 2.0 / DENOM + CI(K) = -WDF2 * DDZ2 / DENOM2 + ELSE + +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + SLOPX = SLOPE + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + CALL WDFCND (WDF2,WCND2,SH2OA(NSOIL),SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + CI(K) = 0.0 + ENDIF + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2 - (WDF * DSMDZ) & + & - WCND + ET(K) + RHSTT(K) = NUMER / (-DENOM2) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + AI(K) = -WDF * DDZ / DENOM2 + BI(K) = -( AI(K) + CI(K) ) + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + IF (K .EQ. NSOIL) THEN + RUNOFF2 = SLOPX * WCND2 + ENDIF + + IF (K .NE. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + ENDIF + END DO + +! ---------------------------------------------------------------------- +! END SUBROUTINE SRT +! ---------------------------------------------------------------------- + END SUBROUTINE SRT + + SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + & NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + & AI,BI,CI) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + INTEGER NSOLD + PARAMETER(NSOLD = 20) + + INTEGER I + INTEGER K + INTEGER KK11 + INTEGER NSOIL + + REAL AI(NSOLD) + REAL BI(NSOLD) + REAL CI(NSOLD) + REAL CIin(NSOLD) + REAL CMC + REAL CMCMAX + REAL DDZ + REAL DT + REAL RHSCT + REAL RHSTT(NSOIL) + REAL RHSTTin(NSOIL) + REAL RUNOFF3 + REAL SH2OIN(NSOIL) + REAL SH2OOUT(NSOIL) + REAL SICE(NSOIL) + REAL SMC(NSOIL) + REAL SMCMAX + REAL STOT + REAL WPLUS + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT(K) = RHSTT(K) * DT + AI(K) = AI(K) * DT + BI(K) = 1. + BI(K) * DT + CI(K) = CI(K) * DT + END DO + +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTin(K) = RHSTT(K) + END DO + DO K = 1,NSOIL + CIin(K) = CI(K) + END DO + +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) + +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + DDZ = -ZSOIL(1) + + DO K = 1,NSOIL + IF (K .NE. 1) DDZ = ZSOIL(K - 1) - ZSOIL(K) + SH2OOUT(K) = SH2OIN(K) + CI(K) + WPLUS / DDZ + + STOT = SH2OOUT(K) + SICE(K) + IF (STOT .GT. SMCMAX) THEN + IF (K .EQ. 1) THEN + DDZ = -ZSOIL(1) + ELSE + KK11 = K - 1 + DDZ = -ZSOIL(K) + ZSOIL(KK11) + ENDIF + WPLUS = (STOT-SMCMAX) * DDZ + ELSE + WPLUS = 0. + ENDIF + SMC(K) = MAX ( MIN(STOT,SMCMAX),0.02 ) + SH2OOUT(K) = MAX((SMC(K)-SICE(K)),0.0) + END DO + + RUNOFF3 = WPLUS + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + CMC = CMC + DT * RHSCT + IF (CMC .LT. 1.E-20) CMC=0.0 + CMC = MIN(CMC,CMCMAX) + +! ---------------------------------------------------------------------- +! END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP + + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE TBND +! ---------------------------------------------------------------------- +! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF +! THE MIDDLE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + INTEGER NSOIL + INTEGER K + + REAL TBND1 + REAL T0 + REAL TU + REAL TB + REAL ZB + REAL ZBOT + REAL ZUP + REAL ZSOIL (NSOIL) + + PARAMETER(T0 = 273.15) + +! ---------------------------------------------------------------------- +! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER +! ---------------------------------------------------------------------- + IF (K .EQ. 1) THEN + ZUP = 0. + ELSE + ZUP = ZSOIL(K-1) + ENDIF + +! ---------------------------------------------------------------------- +! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE +! TEMPERATURE INTO THE LAST LAYER BOUNDARY +! ---------------------------------------------------------------------- + IF (K .EQ. NSOIL) THEN + ZB = 2.*ZBOT-ZSOIL(K) + ELSE + ZB = ZSOIL(K+1) + ENDIF + +! ---------------------------------------------------------------------- +! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + TBND1 = TU+(TB-TU)*(ZUP-ZSOIL(K))/(ZUP-ZB) + +! ---------------------------------------------------------------------- +! END SUBROUTINE TBND +! ---------------------------------------------------------------------- + END SUBROUTINE TBND + + SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE TDFCND +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY AND CONDUCTIVITY OF THE SOIL FOR A GIVEN +! POINT AND TIME. +! ---------------------------------------------------------------------- +! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) +! June 2001 CHANGES: FROZEN SOIL CONDITION. +! ---------------------------------------------------------------------- + REAL DF + REAL GAMMD + REAL THKDRY + REAL AKE + REAL THKICE + REAL THKO + REAL THKQTZ + REAL THKSAT + REAL THKS + REAL THKW + REAL QZ + REAL SATRATIO + REAL SH2O + REAL SMC + REAL SMCMAX + REAL XU + REAL XUNFROZ + +! ---------------------------------------------------------------------- +! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): +! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! ---------------------------------------------------------------------- +! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT +! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS +! ---------------------------------------------------------------------- +! THKW ......WATER THERMAL CONDUCTIVITY +! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ +! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS +! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) +! THKICE ....ICE THERMAL CONDUCTIVITY +! SMCMAX ....POROSITY (= SMCMAX) +! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! ---------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). +! +! PABLO GRUNMANN, 08/17/98 +! REFS.: +! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK +! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. +! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, +! UNIVERSITY OF TRONDHEIM, +! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL +! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES +! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, +! VOL. 55, PP. 1209-1224. +! ---------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: + SATRATIO = SMC/SMCMAX + +! PARAMETERS W/(M.K) + THKICE = 2.2 + THKW = 0.57 + THKO = 2.0 +! IF (QZ .LE. 0.2) THKO = 3.0 + THKQTZ = 7.7 +! SOLIDS' CONDUCTIVITY + THKS = (THKQTZ**QZ)*(THKO**(1.- QZ)) + +! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + XUNFROZ = (SH2O + 1.E-9) / (SMC + 1.E-9) + +! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) + XU=XUNFROZ*SMCMAX +! SATURATED THERMAL CONDUCTIVITY + THKSAT = THKS**(1.-SMCMAX)*THKICE**(SMCMAX-XU)*THKW**(XU) + +! DRY DENSITY IN KG/M3 + GAMMD = (1. - SMCMAX)*2700. + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + THKDRY = (0.135*GAMMD + 64.7)/(2700. - 0.947*GAMMD) + + IF ( (SH2O + 0.0005) .LT. SMC ) THEN +! FROZEN + AKE = SATRATIO + ELSE +! UNFROZEN +! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) + IF ( SATRATIO .GT. 0.1 ) THEN + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + AKE = LOG10(SATRATIO) + 1.0 + + ELSE + +! USE K = KDRY + AKE = 0.0 + + ENDIF + ENDIF + +! THERMAL CONDUCTIVITY + + DF = AKE*(THKSAT - THKDRY) + THKDRY + +! ---------------------------------------------------------------------- +! END SUBROUTINE TDFCND +! ---------------------------------------------------------------------- + END SUBROUTINE TDFCND + + SUBROUTINE TMPAVG (TAVG,TUP,TM,TDN,ZSOIL,NSOIL,K) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- +! CALCULATE SOIL LAYER AVERAGE TEMPERATURE (TAVG) IN FREEZING/THAWING +! LAYER USING UP, DOWN, AND MIDDLE LAYER TEMPERATURES (TUP, TDN, TM), +! WHERE TUP IS AT TOP BOUNDARY OF LAYER, TDN IS AT BOTTOM BOUNDARY OF +! LAYER. TM IS LAYER PROGNOSTIC STATE TEMPERATURE. +! ---------------------------------------------------------------------- + INTEGER K + INTEGER NSOIL + + REAL DZ + REAL DZH + REAL T0 + REAL TAVG + REAL TDN + REAL TM + REAL TUP + REAL X0 + REAL XDN + REAL XUP + REAL ZSOIL (NSOIL) + + PARAMETER(T0 = 2.7315E2) + +! ---------------------------------------------------------------------- + IF (K .EQ. 1) THEN + DZ = -ZSOIL(1) + ELSE + DZ = ZSOIL(K-1)-ZSOIL(K) + ENDIF + + DZH=DZ*0.5 + + IF (TUP .LT. T0) THEN + IF (TM .LT. T0) THEN + IF (TDN .LT. T0) THEN +! ---------------------------------------------------------------------- +! TUP, TM, TDN < T0 +! ---------------------------------------------------------------------- + TAVG = (TUP + 2.0*TM + TDN)/ 4.0 + ELSE +! ---------------------------------------------------------------------- +! TUP & TM < T0, TDN >= T0 +! ---------------------------------------------------------------------- + X0 = (T0 - TM) * DZH / (TDN - TM) + TAVG = 0.5 * (TUP*DZH+TM*(DZH+X0)+T0*(2.*DZH-X0)) / DZ + ENDIF + ELSE + IF (TDN .LT. T0) THEN +! ---------------------------------------------------------------------- +! TUP < T0, TM >= T0, TDN < T0 +! ---------------------------------------------------------------------- + XUP = (T0-TUP) * DZH / (TM-TUP) + XDN = DZH - (T0-TM) * DZH / (TDN-TM) + TAVG = 0.5 * (TUP*XUP+T0*(2.*DZ-XUP-XDN)+TDN*XDN) / DZ + ELSE +! ---------------------------------------------------------------------- +! TUP < T0, TM >= T0, TDN >= T0 +! ---------------------------------------------------------------------- + XUP = (T0-TUP) * DZH / (TM-TUP) + TAVG = 0.5 * (TUP*XUP+T0*(2.*DZ-XUP)) / DZ + ENDIF + ENDIF + ELSE + IF (TM .LT. T0) THEN + IF (TDN .LT. T0) THEN +! ---------------------------------------------------------------------- +! TUP >= T0, TM < T0, TDN < T0 +! ---------------------------------------------------------------------- + XUP = DZH - (T0-TUP) * DZH / (TM-TUP) + TAVG = 0.5 * (T0*(DZ-XUP)+TM*(DZH+XUP)+TDN*DZH) / DZ + ELSE +! ---------------------------------------------------------------------- +! TUP >= T0, TM < T0, TDN >= T0 +! ---------------------------------------------------------------------- + XUP = DZH - (T0-TUP) * DZH / (TM-TUP) + XDN = (T0-TM) * DZH / (TDN-TM) + TAVG = 0.5 * (T0*(2.*DZ-XUP-XDN)+TM*(XUP+XDN)) / DZ + ENDIF + ELSE + IF (TDN .LT. T0) THEN +! ---------------------------------------------------------------------- +! TUP >= T0, TM >= T0, TDN < T0 +! ---------------------------------------------------------------------- + XDN = DZH - (T0-TM) * DZH / (TDN-TM) + TAVG = (T0*(DZ-XDN)+0.5*(T0+TDN)*XDN) / DZ + ELSE +! ---------------------------------------------------------------------- +! TUP >= T0, TM >= T0, TDN >= T0 +! ---------------------------------------------------------------------- + TAVG = (TUP + 2.0*TM + TDN) / 4.0 + ENDIF + ENDIF + ENDIF +! ---------------------------------------------------------------------- +! END SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- + END SUBROUTINE TMPAVG + + SUBROUTINE TRANSP (ET1,NSOIL,ETP1,SMC,CMC,ZSOIL,SHDFAC,SMCWLT, & + & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE TRANSP +! ---------------------------------------------------------------------- +! CALCULATE TRANSPIRATION FOR THE VEG CLASS. +! ---------------------------------------------------------------------- + INTEGER I + INTEGER K + INTEGER NSOIL + INTEGER NROOT + + REAL CFACTR + REAL CMC + REAL CMCMAX + REAL DENOM + REAL ET1(NSOIL) + REAL ETP1 + REAL ETP1A + REAL GX (7) +!.....REAL PART(NSOIL) + REAL PC + REAL Q2 + REAL RTDIS(NSOIL) + REAL RTX + REAL SFCTMP + REAL SGX + REAL SHDFAC + REAL SMC(NSOIL) + REAL SMCREF + REAL SMCWLT + REAL ZSOIL(NSOIL) + +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TRANSP TO ZERO FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + ET1(K) = 0. + END DO + +! ---------------------------------------------------------------------- +! CALCULATE AN 'ADJUSTED' POTENTIAL TRANSPIRATION +! IF STATEMENT BELOW TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +! NOTE: GX AND OTHER TERMS BELOW REDISTRIBUTE TRANSPIRATION BY LAYER, +! ET(K), AS A FUNCTION OF SOIL MOISTURE AVAILABILITY, WHILE PRESERVING +! TOTAL ETP1A. +! ---------------------------------------------------------------------- + IF (CMC .NE. 0.0) THEN + ETP1A = SHDFAC * PC * ETP1 * (1.0 - (CMC /CMCMAX) ** CFACTR) + ELSE + ETP1A = SHDFAC * PC * ETP1 + ENDIF + + SGX = 0.0 + DO I = 1,NROOT + GX(I) = ( SMC(I) - SMCWLT ) / ( SMCREF - SMCWLT ) + GX(I) = MAX ( MIN ( GX(I), 1. ), 0. ) + SGX = SGX + GX (I) + END DO + SGX = SGX / NROOT + + DENOM = 0. + DO I = 1,NROOT + RTX = RTDIS(I) + GX(I) - SGX + GX(I) = GX(I) * MAX ( RTX, 0. ) + DENOM = DENOM + GX(I) + END DO + IF (DENOM .LE. 0.0) DENOM = 1. + + DO I = 1,NROOT + ET1(I) = ETP1A * GX(I) / DENOM + END DO + +! ---------------------------------------------------------------------- +! ABOVE CODE ASSUMES A VERTICALLY UNIFORM ROOT DISTRIBUTION +! CODE BELOW TESTS A VARIABLE ROOT DISTRIBUTION +! ---------------------------------------------------------------------- +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * GX * ETP1A +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(1) = RTDIS(1) * ETP1A +! ET(1) = ETP1A * PART(1) +! ---------------------------------------------------------------------- +! LOOP DOWN THRU THE SOIL LAYERS REPEATING THE OPERATION ABOVE, +! BUT USING THE THICKNESS OF THE SOIL LAYER (RATHER THAN THE +! ABSOLUTE DEPTH OF EACH LAYER) IN THE FINAL CALCULATION. +! ---------------------------------------------------------------------- +! DO K = 2,NROOT +! GX = ( SMC(K) - SMCWLT ) / ( SMCREF - SMCWLT ) +! GX = MAX ( MIN ( GX, 1. ), 0. ) +! TEST CANOPY RESISTANCE +! GX = 1.0 +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*GX*ETP1A +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(K) = RTDIS(K) * ETP1A +! ET(K) = ETP1A*PART(K) +! END DO +! ---------------------------------------------------------------------- +! END SUBROUTINE TRANSP +! ---------------------------------------------------------------------- + END SUBROUTINE TRANSP + + SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. +! ---------------------------------------------------------------------- + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL EXPON + REAL FACTR1 + REAL FACTR2 + REAL SICEMAX + REAL SMC + REAL SMCMAX + REAL VKwgt + REAL WCND + REAL WDF + +! ---------------------------------------------------------------------- +! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT +! ---------------------------------------------------------------------- + SMC = SMC + SMCMAX = SMCMAX + FACTR1 = 0.2 / SMCMAX + FACTR2 = SMC / SMCMAX + +! ---------------------------------------------------------------------- +! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY +! ---------------------------------------------------------------------- + EXPON = BEXP + 2.0 + WDF = DWSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- +! FROZEN SOIL HYDRAULIC DIFFUSIVITY. VERY SENSITIVE TO THE VERTICAL +! GRADIENT OF UNFROZEN WATER. THE LATTER GRADIENT CAN BECOME VERY +! EXTREME IN FREEZING/THAWING SITUATIONS, AND GIVEN THE RELATIVELY +! FEW AND THICK SOIL LAYERS, THIS GRADIENT SUFFERES SERIOUS +! TRUNCTION ERRORS YIELDING ERRONEOUSLY HIGH VERTICAL TRANSPORTS OF +! UNFROZEN WATER IN BOTH DIRECTIONS FROM HUGE HYDRAULIC DIFFUSIVITY. +! THEREFORE, WE FOUND WE HAD TO ARBITRARILY CONSTRAIN WDF +! -- +! VERSION D_10CM: ........ FACTR1 = 0.2/SMCMAX +! WEIGHTED APPROACH...................... PABLO GRUNMANN, 28_SEP_1999. +! ---------------------------------------------------------------------- + IF (SICEMAX .GT. 0.0) THEN + VKWGT = 1./(1.+(500.*SICEMAX)**3.) + WDF = VKWGT*WDF + (1.- VKWGT)*DWSAT*FACTR1**EXPON + ENDIF + +! ---------------------------------------------------------------------- +! RESET THE EXPNTL COEF AND CALC THE HYDRAULIC CONDUCTIVITY +! ---------------------------------------------------------------------- + EXPON = (2.0 * BEXP) + 3.0 + WCND = DKSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- +! END SUBROUTINE WDFCND +! ---------------------------------------------------------------------- + END SUBROUTINE WDFCND + + SUBROUTINE nmmlsminit(isn,XICE,VEGFRA,SNOW,SNOWC,CANWAT,SMSTAV, & + SMSTOT, SFCRUNOFF,UDRUNOFF,GRDFLX,ACSNOW, & + ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,DZS,SFCEVP, & ! STEMP + TMN, & + num_soil_layers, & + allowed_to_read, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + +! Arguments + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION( num_soil_layers), INTENT(IN) :: DZS + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: SMOIS, & + TSLB !STEMP + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SNOW, & + SNOWC, & + CANWAT, & + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + SFCEVP, & + GRDFLX, & + ACSNOW, & + XICE, & + VEGFRA, & + TMN, & + ACSNOM + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: IVGTYP, & + ISLTYP + +! + + INTEGER, INTENT(IN) :: isn + LOGICAL, INTENT(IN) :: allowed_to_read +! Local + INTEGER :: iseason + INTEGER :: icm,jcm,itf,jtf + INTEGER :: I,J,L + + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + icm = ide/2 + jcm = jde/2 + + iseason=isn + + DO J=jts,jtf + DO I=its,itf +! SNOW(i,j)=0. + SNOWC(i,j)=0. +! SMSTAV(i,j)= +! SMSTOT(i,j)= +! SFCRUNOFF(i,j)= +! UDRUNOFF(i,j)= +! GRDFLX(i,j)= +! ACSNOW(i,j)= +! ACSNOM(i,j)= + ENDDO + ENDDO + + END SUBROUTINE nmmlsminit + + FUNCTION CSNOW (DSNOW) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! FUNCTION CSNOW +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + REAL C + REAL DSNOW + REAL CSNOW + REAL UNIT + + PARAMETER(UNIT = 0.11631) + +! ---------------------------------------------------------------------- +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C=0.328*10**(2.25*DSNOW) +! CSNOW=UNIT*C +! MEK JAN 2006, DOUBLE SNOW THERMAL CONDUCTIVITY + CSNOW=2.0*UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! CSNOW=0.021+2.51*DSNOW**2 + +! ---------------------------------------------------------------------- +! END FUNCTION CSNOW +! ---------------------------------------------------------------------- + END FUNCTION CSNOW + + FUNCTION FRH2O (TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! FUNCTION FRH2O +! ---------------------------------------------------------------------- +! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF +! TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO +! SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL +! (1999, JGR, VOL 104(D16), 19569-19585). +! ---------------------------------------------------------------------- +! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON +! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN +! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT +! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH +! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, +! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE +! LIMIT OF FREEZING POINT TEMPERATURE T0. +! ---------------------------------------------------------------------- +! INPUT: +! +! TKELV.........TEMPERATURE (Kelvin) +! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) +! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) +! SMCMAX........SATURATION SOIL MOISTURE CONTENT (FROM REDPRM) +! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) +! PSIS..........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) +! +! OUTPUT: +! FRH2O.........SUPERCOOLED LIQUID WATER CONTENT +! ---------------------------------------------------------------------- + REAL BEXP + REAL BLIM + REAL BX + REAL CK + REAL DENOM + REAL DF + REAL DH2O + REAL DICE + REAL DSWL + REAL ERROR + REAL FK + REAL FRH2O + REAL GS + REAL HLICE + REAL PSIS + REAL SH2O + REAL SMC + REAL SMCMAX + REAL SWL + REAL SWLK + REAL TKELV + REAL T0 + + INTEGER NLOG + INTEGER KCOUNT + + PARAMETER(CK = 8.0) +! PARAMETER(CK = 0.0) + PARAMETER(BLIM = 5.5) + PARAMETER(ERROR = 0.005) + + PARAMETER(HLICE = 3.335E5) + PARAMETER(GS = 9.81) + PARAMETER(DICE = 920.0) + PARAMETER(DH2O = 1000.0) + PARAMETER(T0 = 273.15) + +! ---------------------------------------------------------------------- +! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) +! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS +! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. +! ---------------------------------------------------------------------- + BX = BEXP + IF (BEXP .GT. BLIM) BX = BLIM + +! ---------------------------------------------------------------------- +! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. +! ---------------------------------------------------------------------- + NLOG=0 + KCOUNT=0 + +! ---------------------------------------------------------------------- +! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC +! ---------------------------------------------------------------------- + IF (TKELV .GT. (T0 - 1.E-3)) THEN + FRH2O = SMC + ELSE + IF (CK .NE. 0.0) THEN + +! ---------------------------------------------------------------------- +! OPTION 1: ITERATED SOLUTION FOR NONZERO CK +! IN KOREN ET AL, JGR, 1999, EQN 17 +! ---------------------------------------------------------------------- +! INITIAL GUESS FOR SWL (frozen content) +! ---------------------------------------------------------------------- + SWL = SMC-SH2O + +! ---------------------------------------------------------------------- +! KEEP WITHIN BOUNDS. +! ---------------------------------------------------------------------- + IF (SWL .GT. (SMC-0.02)) SWL = SMC-0.02 + IF (SWL .LT. 0.) SWL = 0. + +! ---------------------------------------------------------------------- +! START OF ITERATIONS +! ---------------------------------------------------------------------- + DO WHILE ( (NLOG .LT. 10) .AND. (KCOUNT .EQ. 0) ) + NLOG = NLOG+1 + DF = ALOG(( PSIS*GS/HLICE ) * ( ( 1.+CK*SWL )**2. ) * & + & ( SMCMAX/(SMC-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV) + DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( SMC - SWL ) + SWLK = SWL - DF/DENOM +! ---------------------------------------------------------------------- +! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. +! ---------------------------------------------------------------------- + IF (SWLK .GT. (SMC-0.02)) SWLK = SMC - 0.02 + IF (SWLK .LT. 0.) SWLK = 0. + +! ---------------------------------------------------------------------- +! MATHEMATICAL SOLUTION BOUNDS APPLIED. +! ---------------------------------------------------------------------- + DSWL = ABS(SWLK-SWL) + SWL = SWLK + +! ---------------------------------------------------------------------- +! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) +! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. +! ---------------------------------------------------------------------- + IF ( DSWL .LE. ERROR ) THEN + KCOUNT = KCOUNT+1 + ENDIF + END DO + +! ---------------------------------------------------------------------- +! END OF ITERATIONS +! ---------------------------------------------------------------------- +! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. +! ---------------------------------------------------------------------- + FRH2O = SMC - SWL + +! ---------------------------------------------------------------------- +! END OPTION 1 +! ---------------------------------------------------------------------- + ENDIF + +! ---------------------------------------------------------------------- +! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 +! IN KOREN ET AL., JGR, 1999, EQN 17 +! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION +! ---------------------------------------------------------------------- + IF (KCOUNT .EQ. 0) THEN + Print*,'Flerchinger used in NEW version. Iterations=',NLOG + FK = (((HLICE/(GS*(-PSIS)))* & + & ((TKELV-T0)/TKELV))**(-1/BX))*SMCMAX + IF (FK .LT. 0.02) FK = 0.02 + FRH2O = MIN (FK, SMC) +! ---------------------------------------------------------------------- +! END OPTION 2 +! ---------------------------------------------------------------------- + ENDIF + + ENDIF + +! ---------------------------------------------------------------------- +! END FUNCTION FRH2O +! ---------------------------------------------------------------------- + END FUNCTION FRH2O + + FUNCTION SNKSRC (TAVG,SMC,SH2O,ZSOIL,NSOIL, & + & SMCMAX,PSISAT,BEXP,DT,K,QTOT) + + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! FUNCTION SNKSRC +! ---------------------------------------------------------------------- +! CALCULATE SINK/SOURCE TERM OF THE TERMAL DIFFUSION EQUATION. (SH2O) IS +! AVAILABLE LIQUED WATER. +! ---------------------------------------------------------------------- + INTEGER K + INTEGER NSOIL + + REAL BEXP + REAL DF + REAL DH2O + REAL DT + REAL DZ + REAL DZH + REAL FREE +! REAL FRH2O + REAL HLICE + REAL PSISAT + REAL QTOT + REAL SH2O + REAL SMC + REAL SMCMAX + REAL SNKSRC + REAL T0 + REAL TAVG + REAL TDN + REAL TM + REAL TUP + REAL TZ + REAL X0 + REAL XDN + REAL XH2O + REAL XUP + REAL ZSOIL (NSOIL) + + PARAMETER(DH2O = 1.0000E3) + PARAMETER(HLICE = 3.3350E5) + PARAMETER(T0 = 2.7315E2) + + IF (K .EQ. 1) THEN + DZ = -ZSOIL(1) + ELSE + DZ = ZSOIL(K-1)-ZSOIL(K) + ENDIF + +! ---------------------------------------------------------------------- +! VIA FUNCTION FRH2O, COMPUTE POTENTIAL OR 'EQUILIBRIUM' UNFROZEN +! SUPERCOOLED FREE WATER FOR GIVEN SOIL TYPE AND SOIL LAYER TEMPERATURE. +! FUNCTION FRH20 INVOKES EQN (17) FROM V. KOREN ET AL (1999, JGR, VOL. +! 104, PG 19573). (ASIDE: LATTER EQN IN JOURNAL IN CENTIGRADE UNITS. +! ROUTINE FRH2O USE FORM OF EQN IN KELVIN UNITS.) +! ---------------------------------------------------------------------- + FREE = FRH2O(TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) + +! ---------------------------------------------------------------------- +! IN NEXT BLOCK OF CODE, INVOKE EQN 18 OF V. KOREN ET AL (1999, JGR, +! VOL. 104, PG 19573.) THAT IS, FIRST ESTIMATE THE NEW AMOUNTOF LIQUID +! WATER, 'XH2O', IMPLIED BY THE SUM OF (1) THE LIQUID WATER AT THE BEGIN +! OF CURRENT TIME STEP, AND (2) THE FREEZE OF THAW CHANGE IN LIQUID +! WATER IMPLIED BY THE HEAT FLUX 'QTOT' PASSED IN FROM ROUTINE HRT. +! SECOND, DETERMINE IF XH2O NEEDS TO BE BOUNDED BY 'FREE' (EQUIL AMT) OR +! IF 'FREE' NEEDS TO BE BOUNDED BY XH2O. +! ---------------------------------------------------------------------- + XH2O = SH2O + QTOT*DT/(DH2O*HLICE*DZ) + +! ---------------------------------------------------------------------- +! FIRST, IF FREEZING AND REMAINING LIQUID LESS THAN LOWER BOUND, THEN +! REDUCE EXTENT OF FREEZING, THEREBY LETTING SOME OR ALL OF HEAT FLUX +! QTOT COOL THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + IF ( XH2O .LT. SH2O .AND. XH2O .LT. FREE) THEN + IF ( FREE .GT. SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! SECOND, IF THAWING AND THE INCREASE IN LIQUID WATER GREATER THAN UPPER +! BOUND, THEN REDUCE EXTENT OF THAW, THEREBY LETTING SOME OR ALL OF HEAT +! FLUX QTOT WARM THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + IF ( XH2O .GT. SH2O .AND. XH2O .GT. FREE ) THEN + IF ( FREE .LT. SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + ENDIF + ENDIF + + IF (XH2O .LT. 0.) XH2O = 0. + IF (XH2O .GT. SMC) XH2O = SMC + +! ---------------------------------------------------------------------- +! CALCULATE PHASE-CHANGE HEAT SOURCE/SINK TERM FOR USE IN ROUTINE HRT +! AND UPDATE LIQUID WATER TO REFLCET FINAL FREEZE/THAW INCREMENT. +! ---------------------------------------------------------------------- + SNKSRC = -DH2O*HLICE*DZ*(XH2O-SH2O)/DT + SH2O = XH2O + +! ---------------------------------------------------------------------- +! END FUNCTION SNKSRC +! ---------------------------------------------------------------------- + END FUNCTION SNKSRC + +END MODULE module_sf_lsm_nmm + diff --git a/wrfv2_fire/phys/module_sf_myjsfc.F b/wrfv2_fire/phys/module_sf_myjsfc.F new file mode 100755 index 00000000..fda337c9 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_myjsfc.F @@ -0,0 +1,1231 @@ +!---------------------------------------------------------------------- +! + MODULE MODULE_SF_MYJSFC +! +!---------------------------------------------------------------------- +! + USE MODULE_MODEL_CONSTANTS + USE MODULE_DM, ONLY : WRF_DM_MAXVAL +! +!---------------------------------------------------------------------- +! +! REFERENCES: Janjic (2002), NCEP Office Note 437 +! +! ABSTRACT: +! MYJSFC GENERATES THE SURFACE EXCHANGE COEFFICIENTS FOR VERTICAL +! TURBULENT EXCHANGE BASED UPON MONIN_OBUKHOV THEORY WITH +! VARIOUS REFINEMENTS. +! +!---------------------------------------------------------------------- +! + INTEGER :: ITRMX=5 ! Iteration count for sfc layer computations +! + REAL,PARAMETER :: VKARMAN=0.4 + REAL,PARAMETER :: CAPA=R_D/CP,ELOCP=2.72E6/CP,RCAP=1./CAPA + REAL,PARAMETER :: GOCP02=G/CP*2.,GOCP10=G/CP*10. +! REAL,PARAMETER :: EPSU2=1.E-4,EPSUST=0.07,EPSZT=1.E-5 +! ECMWF sets lower limit on ln(Z0h)=-20 --> EPSZT=2.e-9 + REAL,PARAMETER :: EPSU2=1.E-6,EPSUST=1.e-9,EPSZT=1.E-28 + REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 + REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC + REAL,PARAMETER :: BETA=1./273.,CZIL=0.1,EXCML=0.0001,EXCMS=0.0001 & +!old REAL,PARAMETER :: BETA=1./273.,CZIL=0.1,EXCML=0.001,EXCMS=0.001 & + & ,GLKBR=10.,GLKBS=30.,PI=3.1415926 & + & ,QVISC=2.1E-5,RIC=0.505,SMALL=0.35 & + & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & + & ,USTC=0.7,USTR=0.225,VISC=1.5E-5,FH=1.01 & + & ,WWST=1.2,ZTFC=1.,TOPOFAC=9.0e-6 +! + REAL,PARAMETER :: BTG=BETA*G,CZIV=SMALL*GLKBS & + & ,GRRS=GLKBR/GLKBS & + & ,RTVISC=1./TVISC,RVISC=1./VISC & + & ,ZQRZT=SQSC/SQPR & + & ,FZQ1=RTVISC*QVISC*ZQRZT & + & ,FZQ2=RTVISC*QVISC*ZQRZT & + & ,FZT1=RVISC *TVISC*SQPR & + & ,FZT2=CZIV*GRRS*TVISC*SQPR & + & ,FZU1=CZIV*VISC & + & ,PIHF=0.5*PI & + & ,RQVISC=1./QVISC & + & ,USTFC=0.018/G & + & ,WWST2=WWST*WWST & + & ,ZILFC=-CZIL*VKARMAN*SQVISC +! +!---------------------------------------------------------------------- + INTEGER, PARAMETER :: KZTM=10001,KZTM2=KZTM-2 +! + REAL :: DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2 +! + REAL,DIMENSION(KZTM) :: PSIH1,PSIH2,PSIM1,PSIM2 +! +!---------------------------------------------------------------------- +! +CONTAINS +! +!---------------------------------------------------------------------- + SUBROUTINE MYJSFC(ITIMESTEP,HT,DZ & + & ,PMID,PINT,TH,T,QV,QC,U,V,Q2 & + & ,TSK,QSFC,THZ0,QZ0,UZ0,VZ0 & + & ,LOWLYR,XLAND & + & ,USTAR,ZNT,Z0BASE,PBLH,MAVAIL,RMOL & + & ,AKHS,AKMS & + & ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC & + & ,QGH,CPM,CT & + & ,U10,V10,T02,TH02,TSHLTR,TH10,Q02,QSHLTR,Q10,PSHLTR & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: ITIMESTEP +! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LOWLYR +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HT,MAVAIL,TSK & + & ,XLAND,Z0BASE +! + REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ & + & ,PMID,PINT & + & ,Q2,QC,QV & + & ,T,TH & + & ,U,V +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: FLX_LH,HFX,PSHLTR & + & ,QFX,Q10,QSHLTR & + & ,TH10,TSHLTR,T02 & + & ,U10,V10,TH02,Q02 +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS & + & ,PBLH,QSFC +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: QZ0,RMOL,THZ0 & + & ,USTAR,UZ0,VZ0 & + & ,ZNT +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CHS,CHS2,CQS2 & + & ,CPM,CT,FLHC,FLQC & + & ,QGH +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: I,J,K,KFLIP,LMH,LPBL,NTSD +! + REAL :: A,APESFC,B,BTGX,CWMLOW & + & ,DQDT,DTDIF,DTDT,DUDT,DVDT & + & ,FIS & + & ,P02P,P10P,PLOW,PSFC,PTOP,QLOW,QS02,QS10 & + & ,RAPA,RAPA02,RAPA10,RATIOMX,RDZ,SEAMASK,SM & + & ,T02P,T10P,TEM,TH02P,TH10P,THLOW,THELOW,THM & + & ,TLOW,TZ0,ULOW,VLOW,ZSL +! + REAL,DIMENSION(KTS:KTE) :: CWMK,PK,Q2K,QK,THEK,THK,TK,UK,VK +! + REAL,DIMENSION(KTS:KTE-1) :: EL,ELM +! + REAL,DIMENSION(KTS:KTE+1) :: ZHK +! + REAL,DIMENSION(ITS:ITE,JTS:JTE) :: THSK +! + REAL,DIMENSION(ITS:ITE,KTS:KTE+1,JTS:JTE) :: ZINT +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + DO J=JTS,JTE + DO K=KTS,KTE+1 + DO I=ITS,ITE + ZINT(I,K,J)=0. + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,KTE+1,J)=HT(I,J) ! Z at bottom of lowest sigma layer + PBLH(I,J)=-1. +! +!!!!!!!!! +!!!!!! UNCOMMENT THESE LINES IF USING ETA COORDINATES +!!!!!!!!! +!!!!!! ZINT(I,KTE+1,J)=1.E-4 ! Z of bottom of lowest eta layer +!!!!!! ZHK(KTE+1)=1.E-4 ! Z of bottom of lowest eta layer +! + ENDDO + ENDDO +! + DO J=JTS,JTE + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + DO I=ITS,ITE + ZINT(I,K,J)=ZINT(I,K+1,J)+DZ(I,KFLIP,J) + ENDDO + ENDDO + ENDDO +! + NTSD=ITIMESTEP +! +#if ( NMM_CORE == 1 ) + if(NTSD+1.eq.1) then +#else + IF(NTSD==1)THEN +#endif +!tgs IF(NTSD==1)THEN + DO J=JTS,JTE + DO I=ITS,ITE + USTAR(I,J)=0.1 + FIS=HT(I,J)*G + SM=XLAND(I,J)-1. +!!! Z0(I,J)=SM*Z0SEA+(1.-SM)*(Z0(I,J)*Z0MAX+FIS*FCM+Z0LAND) +!!! ZNT(I,J)=SM*Z0SEA+(1.-SM)*(ZNT(I,J)*Z0MAX+FIS*FCM+Z0LAND) + ENDDO + ENDDO + ENDIF +! +!!!! IF(NTSD==1)THEN + DO J=JTS,JTE + DO I=ITS,ITE + CT(I,J)=0. + ENDDO + ENDDO +!!!! ENDIF +! +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE +! +!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED +! + LMH=KTE-LOWLYR(I,J)+1 +! + PTOP=PINT(I,KTE+1,J) ! KTE+1=KME + PSFC=PINT(I,LOWLYR(I,J),J) +! Define THSK here (for first timestep mostly) + THSK(I,J)=TSK(I,J)/(PSFC*1.E-5)**CAPA +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +!*** AND FLIP DIRECTION SINCE MYJ SCHEME +!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP +! + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + THK(K)=TH(I,KFLIP,J) + TK(K)=T(I,KFLIP,J) + RATIOMX=QV(I,KFLIP,J) + QK(K)=RATIOMX/(1.+RATIOMX) + PK(K)=PMID(I,KFLIP,J) + CWMK(K)=QC(I,KFLIP,J) + THEK(K)=(CWMK(K)*(-ELOCP/TK(K))+1.)*THK(K) + Q2K(K)=2.*Q2(I,KFLIP,J) +! +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,K,J) +! + ENDDO + ZHK(KTE+1)=HT(I,J) ! Z at bottom of lowest sigma layer +! + DO K=KTE,KTS,-1 + KFLIP=KTE+1-K + UK(K)=U(I,KFLIP,J) + VK(K)=V(I,KFLIP,J) + ENDDO +! +!*** FIND THE HEIGHT OF THE PBL +! + LPBL=LMH + DO K=LMH-1,1,-1 + IF(Q2K(K)<=EPSQ2*FH) THEN + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!----------------------------------------------------------------------- +!--------------THE HEIGHT OF THE PBL------------------------------------ +!----------------------------------------------------------------------- +! + 110 PBLH(I,J)=ZHK(LPBL)-ZHK(LMH+1) +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE SURFACE EXCHANGE COEFFICIENTS +!*** +!---------------------------------------------------------------------- + PLOW=PK(LMH) + TLOW=TK(LMH) + THLOW=THK(LMH) + THELOW=THEK(LMH) + QLOW=QK(LMH) + CWMLOW=CWMK(LMH) + ULOW=UK(LMH) + VLOW=VK(LMH) + ZSL=(ZHK(LMH)-ZHK(LMH+1))*0.5 + APESFC=(PSFC*1.E-5)**CAPA +!tgs - in ARW THZ0 is not initialized when MYJSFC is called first time +#if ( NMM_CORE == 1 ) + if(NTSD+1.eq.1) then +#else + IF(NTSD==1)THEN +#endif +! if(itimestep.le.1) then + TZ0=TSK(I,J) + else + TZ0=THZ0(I,J)*APESFC + endif +! + CALL SFCDIF(NTSD,SEAMASK,THSK(I,J),QSFC(I,J),PSFC & + & ,UZ0(I,J),VZ0(I,J),TZ0,THZ0(I,J),QZ0(I,J) & + & ,USTAR(I,J),ZNT(I,J),Z0BASE(I,J),CT(I,J),RMOL(I,J) & + & ,AKMS(I,J),AKHS(I,J),PBLH(I,J),MAVAIL(I,J) & + & ,CHS(I,J),CHS2(I,J),CQS2(I,J) & + & ,HFX(I,J),QFX(I,J),FLX_LH(I,J) & + & ,FLHC(I,J),FLQC(I,J),QGH(I,J),CPM(I,J) & + & ,ULOW,VLOW,TLOW,THLOW,THELOW,QLOW,CWMLOW & + & ,ZSL,PLOW & + & ,U10(I,J),V10(I,J),TSHLTR(I,J),TH10(I,J) & + & ,QSHLTR(I,J),Q10(I,J),PSHLTR(I,J) & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,i,j,ZHK(LMH+1)) +! +!*** REMOVE SUPERATURATION AT 2M AND 10M +! + RAPA=APESFC + TH02P=TSHLTR(I,J) + TH10P=TH10(I,J) + TH02(I,J)=TSHLTR(I,J) +! + RAPA02=RAPA-GOCP02/TH02P + RAPA10=RAPA-GOCP10/TH10P +! + T02P=TH02P*RAPA02 + T10P=TH10P*RAPA10 +! 1 may 06 tgs T02(I,J) = T02P + T02(I,J) = TH02(I,J)*APESFC +! + P02P=(RAPA02**RCAP)*1.E5 + P10P=(RAPA10**RCAP)*1.E5 +! + QS02=PQ0/P02P*EXP(A2*(T02P-A3)/(T02P-A4)) + QS10=PQ0/P10P*EXP(A2*(T10P-A3)/(T10P-A4)) +! + IF(QSHLTR(I,J)>QS02)QSHLTR(I,J)=QS02 + IF(Q10 (I,J)>QS10)Q10 (I,J)=QS10 + Q02(I,J)=QSHLTR(I,J)/(1.-QSHLTR(I,J)) +!---------------------------------------------------------------------- +! + ENDDO +! +!---------------------------------------------------------------------- + ENDDO setup_integration +!---------------------------------------------------------------------- + + END SUBROUTINE MYJSFC +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & + & ,UZ0,VZ0,TZ0,THZ0,QZ0 & + & ,USTAR,Z0,Z0BASE,CT,RLMO,AKMS,AKHS,PBLH,WETM & + & ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC,QGH,CPM & + & ,ULOW,VLOW,TLOW,THLOW,THELOW,QLOW,CWMLOW & + & ,ZSL,PLOW & + & ,U10,V10,TH02,TH10,Q02,Q10,PSHLTR & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,i,j,ZSFC) +! **************************************************************** +! * * +! * SURFACE LAYER * +! * * +! **************************************************************** +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE,i,j +! + INTEGER,INTENT(IN) :: NTSD +! + REAL,INTENT(IN) :: CWMLOW,PBLH,PLOW,QLOW,PSFC,SEAMASK,ZSFC & + & ,THELOW,THLOW,THS,TLOW,TZ0,ULOW,VLOW,WETM,ZSL & + & ,Z0BASE +! + REAL,INTENT(OUT) :: CHS,CHS2,CPM,CQS2,CT,FLHC,FLQC,FLX_LH,HFX & + & ,PSHLTR,Q02,Q10,QFX,QGH,RLMO,TH02,TH10,U10,V10 +! + REAL,INTENT(INOUT) :: AKHS,AKMS,QZ0,THZ0,USTAR,UZ0,VZ0,Z0,QS +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: ITR,K +! + REAL :: A,B,BTGH,BTGX,CXCHL,CXCHS,DTHV,DU2,ELFC,FCT & + & ,HLFLX,HSFLX,HV,PSH02,PSH10,PSHZ,PSHZL,PSM10,PSMZ,PSMZL & + & ,RDZ,RDZT,RIB,RLMA,RLMN,RLMP & + & ,RLOGT,RLOGU,RWGH,RZ,RZST,RZSU,SIMH,SIMM,TEM,THM & + & ,UMFLX,USTARK,VMFLX,WGHT,WGHTT,WGHTQ,WSTAR2 & + & ,X,XLT,XLT4,XLU,XLU4,XT,XT4,XU,XU4,ZETALT,ZETALU & + & ,ZETAT,ZETAU,ZQ,ZSLT,ZSLU,ZT,ZU,TOPOTERM,ZZIL +! +!*** DIAGNOSTICS +! + REAL :: AKHS02,AKHS10,AKMS02,AKMS10,EKMS10,QSAT10,QSAT2 & + & ,RLNT02,RLNT10,RLNU10,SIMH02,SIMH10,SIMM10,T02,T10 & + & ,TERM1,RLOW,U10E,V10E,WSTAR,XLT02,XLT024,XLT10 & + & ,XLT104,XLU10,XLU104,XU10,XU104,ZT02,ZT10,ZTAT02,ZTAT10 & + & ,ZTAU,ZTAU10,ZU10,ZUUZ +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- + RDZ=1./ZSL + CXCHL=EXCML*RDZ + CXCHS=EXCMS*RDZ +! + BTGX=G/THLOW + ELFC=VKARMAN*BTGX +! + IF(PBLH>1000.)THEN + BTGH=BTGX*PBLH + ELSE + BTGH=BTGX*1000. + ENDIF +! +!---------------------------------------------------------------------- +! +!*** SEA POINTS +! +!---------------------------------------------------------------------- +! + IF(SEAMASK>0.5)THEN +! +!---------------------------------------------------------------------- + DO ITR=1,ITRMX +!---------------------------------------------------------------------- + Z0=MAX(USTFC*USTAR*USTAR,1.59E-5) +! +!*** VISCOUS SUBLAYER, JANJIC MWR 1994 +! +!---------------------------------------------------------------------- + IF(USTAR1) then +#else + IF(NTSD>1)THEN +#endif +!tgs IF(NTSD>1)THEN + THZ0=((WGHTT*THLOW+THS)/(WGHTT+1.)+THZ0)*0.5 + QZ0=((WGHTQ*QLOW+QS)/(WGHTQ+1.)+QZ0)*0.5 + ELSE + THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.) + QZ0=(WGHTQ*QLOW+QS)/(WGHTQ+1.) + ENDIF +! + ENDIF +! + IF(USTAR>=USTR.AND.USTAR1) then +#else + IF(NTSD>1)THEN +#endif + +!tgs IF(NTSD>1)THEN + THZ0=((WGHTT*THLOW+THS)/(WGHTT+1.)+THZ0)*0.5 + QZ0=((WGHTQ*QLOW+QS)/(WGHTQ+1.)+QZ0)*0.5 + ELSE + THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.) + QZ0=(WGHTQ*QLOW+QS)/(WGHTQ+1.) + ENDIF +! + ENDIF +!---------------------------------------------------------------------- + ELSE +!---------------------------------------------------------------------- + ZU=Z0 + UZ0=0. + VZ0=0. +! + ZT=Z0 + THZ0=THS +! + ZQ=Z0 + QZ0=QS +!---------------------------------------------------------------------- + ENDIF +!---------------------------------------------------------------------- + TEM=(TLOW+TZ0)*0.5 + THM=(THELOW+THZ0)*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + DTHV=((THELOW-THZ0)*((QLOW+QZ0+CWMLOW)*(0.5*P608)+1.) & + & +(QLOW-QZ0+CWMLOW)*A+CWMLOW*B) +! + DU2=MAX((ULOW-UZ0)**2+(VLOW-VZ0)**2,EPSU2) + RIB=BTGX*DTHV*ZSL/DU2 +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +!---------------------------------------------------------------------- +! AKMS=MAX( VISC*RDZ,CXCHS) +! AKHS=MAX(TVISC*RDZ,CXCHS) +!---------------------------------------------------------------------- +! ELSE ! turbulent branch +!---------------------------------------------------------------------- + ZSLU=ZSL+ZU + ZSLT=ZSL+ZT +! + RZSU=ZSLU/ZU + RZST=ZSLT/ZT +! + RLOGU=LOG(RZSU) + RLOGT=LOG(RZST) +! +!---------------------------------------------------------------------- +!*** 1./MONIN-OBUKHOV LENGTH +!---------------------------------------------------------------------- +! + RLMO=ELFC*AKHS*DTHV/USTAR**3 +! + ZETALU=ZSLU*RLMO + ZETALT=ZSLT*RLMO + ZETAU=ZU*RLMO + ZETAT=ZT*RLMO +! + ZETALU=MIN(MAX(ZETALU,ZTMIN1),ZTMAX1) + ZETALT=MIN(MAX(ZETALT,ZTMIN1),ZTMAX1) + ZETAU=MIN(MAX(ZETAU,ZTMIN1/RZSU),ZTMAX1/RZSU) + ZETAT=MIN(MAX(ZETAT,ZTMIN1/RZST),ZTMAX1/RZST) +! +!---------------------------------------------------------------------- +!*** WATER FUNCTIONS +!---------------------------------------------------------------------- +! + RZ=(ZETAU-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZ=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + RZ=(ZETALU-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZL=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + SIMM=PSMZL-PSMZ+RLOGU +! + RZ=(ZETAT-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZ=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + RZ=(ZETALT-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZL=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH=(PSHZL-PSHZ+RLOGT)*FH01 +!---------------------------------------------------------------------- + USTARK=USTAR*VKARMAN + AKMS=MAX(USTARK/SIMM,CXCHS) + AKHS=MAX(USTARK/SIMH,CXCHS) +! +!---------------------------------------------------------------------- +!*** BELJAARS CORRECTION FOR USTAR +!---------------------------------------------------------------------- +! + IF(DTHV<=0.)THEN !zj + WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.) !zj + ELSE !zj + WSTAR2=0. !zj + ENDIF !zj + USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST) +! +!---------------------------------------------------------------------- +! ENDIF ! End of turbulent branch +!---------------------------------------------------------------------- +! + ENDDO ! End of the iteration loop over sea points +! +!---------------------------------------------------------------------- +! +!*** LAND POINTS +! +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- + IF(NTSD==1)THEN + QS=QLOW + ENDIF +! + ZU=Z0 + UZ0=0. + VZ0=0. +! + ZT=ZU*ZTFC + THZ0=THS +! + ZQ=ZT + QZ0=QS +!---------------------------------------------------------------------- + TEM=(TLOW+TZ0)*0.5 + THM=(THELOW+THZ0)*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + DTHV=((THELOW-THZ0)*((QLOW+QZ0+CWMLOW)*(0.5*P608)+1.) & + & +(QLOW-QZ0+CWMLOW)*A+CWMLOW*B) +! + DU2=MAX((ULOW-UZ0)**2+(VLOW-VZ0)**2,EPSU2) + RIB=BTGX*DTHV*ZSL/DU2 +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +! AKMS=MAX( VISC*RDZ,CXCHL) +! AKHS=MAX(TVISC*RDZ,CXCHL) +!---------------------------------------------------------------------- +! ELSE ! Turbulent branch +!---------------------------------------------------------------------- + ZSLU=ZSL+ZU +! + RZSU=ZSLU/ZU +! + RLOGU=LOG(RZSU) + + ZSLT=ZSL+ZU ! u,v and t are at the same level +!---------------------------------------------------------------------- +! +!mp Topo modification of ZILFC term +! + TOPOTERM=TOPOFAC*ZSFC**2. + TOPOTERM=MAX(TOPOTERM,3.0) +! + IF(DTHV>0.)THEN + ZZIL=ZILFC*TOPOTERM + ELSE + ZZIL=ZILFC + ENDIF +! +!---------------------------------------------------------------------- +! + land_point_iteration: DO ITR=1,ITRMX +! +!---------------------------------------------------------------------- +!*** ZILITINKEVITCH FIX FOR ZT +!---------------------------------------------------------------------- +! +! oldform ZT=MAX(EXP(ZZIL*SQRT(USTAR*ZU))*ZU,EPSZT) + ZT=MAX(EXP(ZZIL*SQRT(USTAR*Z0BASE))*Z0BASE,EPSZT) +! + RZST=ZSLT/ZT + RLOGT=LOG(RZST) +! +!---------------------------------------------------------------------- +!*** 1./MONIN-OBUKHOV LENGTH-SCALE +!---------------------------------------------------------------------- +! + RLMO=ELFC*AKHS*DTHV/USTAR**3 + ZETALU=ZSLU*RLMO + ZETALT=ZSLT*RLMO + ZETAU=ZU*RLMO + ZETAT=ZT*RLMO +! + ZETALU=MIN(MAX(ZETALU,ZTMIN2),ZTMAX2) + ZETALT=MIN(MAX(ZETALT,ZTMIN2),ZTMAX2) + ZETAU=MIN(MAX(ZETAU,ZTMIN2/RZSU),ZTMAX2/RZSU) + ZETAT=MIN(MAX(ZETAT,ZTMIN2/RZST),ZTMAX2/RZST) +! +!---------------------------------------------------------------------- +!*** LAND FUNCTIONS +!---------------------------------------------------------------------- +! + RZ=(ZETAU-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZ=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) +! + RZ=(ZETALU-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZL=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) +! + SIMM=PSMZL-PSMZ+RLOGU +! + RZ=(ZETAT-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZ=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + RZ=(ZETALT-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZL=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + SIMH=(PSHZL-PSHZ+RLOGT)*FH02 +!---------------------------------------------------------------------- + USTARK=USTAR*VKARMAN + AKMS=MAX(USTARK/SIMM,CXCHL) + AKHS=MAX(USTARK/SIMH,CXCHL) +! +!---------------------------------------------------------------------- +!*** BELJAARS CORRECTION FOR USTAR +!---------------------------------------------------------------------- +! + IF(DTHV<=0.)THEN !zj + WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.) !zj + ELSE !zj + WSTAR2=0. !zj + ENDIF !zj +! + USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST) +! +!---------------------------------------------------------------------- + ENDDO land_point_iteration +!---------------------------------------------------------------------- +! +! ENDIF ! End of turbulant branch over land +! +!---------------------------------------------------------------------- +! + ENDIF ! End of land/sea branch +! +!---------------------------------------------------------------------- +!*** COUNTERGRADIENT FIX +!---------------------------------------------------------------------- +! +! HV=-AKHS*DTHV +! IF(HV>0.)THEN +! FCT=-10.*(BTGX)**(-1./3.) +! CT=FCT*(HV/(PBLH*PBLH))**(2./3.) +! ELSE + CT=0. +! ENDIF +! +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** THE FOLLOWING DIAGNOSTIC BLOCK PRODUCES 2-m and 10-m VALUES +!*** FOR TEMPERATURE, MOISTURE, AND WINDS. IT IS DONE HERE SINCE +!*** THE VARIOUS QUANTITIES NEEDED FOR THE COMPUTATION ARE LOST +!*** UPON EXIT FROM THE ROTUINE. +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! + WSTAR=SQRT(WSTAR2)/WWST +! + UMFLX=AKMS*(ULOW -UZ0 ) + VMFLX=AKMS*(VLOW -VZ0 ) + HSFLX=AKHS*(THLOW-THZ0) + HLFLX=AKHS*(QLOW -QZ0 ) +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +!---------------------------------------------------------------------- +! IF(SEAMASK>0.5)THEN +! AKMS10=MAX( VISC/10.,CXCHS) +! AKHS02=MAX(TVISC/02.,CXCHS) +! AKHS10=MAX(TVISC/10.,CXCHS) +! ELSE +! AKMS10=MAX( VISC/10.,CXCHL) +! AKHS02=MAX(TVISC/02.,CXCHL) +! AKHS10=MAX(TVISC/10.,CXCHL) +! ENDIF +!---------------------------------------------------------------------- +! ELSE +!---------------------------------------------------------------------- + ZU10=ZU+10. + ZT02=ZT+02. + ZT10=ZT+10. +! + RLNU10=LOG(ZU10/ZU) + RLNT02=LOG(ZT02/ZT) + RLNT10=LOG(ZT10/ZT) +! + ZTAU10=ZU10*RLMO + ZTAT02=ZT02*RLMO + ZTAT10=ZT10*RLMO +! +!---------------------------------------------------------------------- +!*** SEA +!---------------------------------------------------------------------- +! + IF(SEAMASK>0.5)THEN +! +!---------------------------------------------------------------------- + ZTAU10=MIN(MAX(ZTAU10,ZTMIN1),ZTMAX1) + ZTAT02=MIN(MAX(ZTAT02,ZTMIN1),ZTMAX1) + ZTAT10=MIN(MAX(ZTAT10,ZTMIN1),ZTMAX1) +!---------------------------------------------------------------------- + RZ=(ZTAU10-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + SIMM10=PSM10-PSMZ+RLNU10 +! + RZ=(ZTAT02-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH02=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH02=(PSH02-PSHZ+RLNT02)*FH01 +! + RZ=(ZTAT10-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH10=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH10=(PSH10-PSHZ+RLNT10)*FH01 +! + AKMS10=MAX(USTARK/SIMM10,CXCHS) + AKHS02=MAX(USTARK/SIMH02,CXCHS) + AKHS10=MAX(USTARK/SIMH10,CXCHS) +! +!---------------------------------------------------------------------- +!*** LAND +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- + ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2) + ZTAT02=MIN(MAX(ZTAT02,ZTMIN2),ZTMAX2) + ZTAT10=MIN(MAX(ZTAT10,ZTMIN2),ZTMAX2) +!---------------------------------------------------------------------- + RZ=(ZTAU10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) +! + SIMM10=PSM10-PSMZ+RLNU10 +! + RZ=(ZTAT02-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH02=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + SIMH02=(PSH02-PSHZ+RLNT02)*FH02 +! + RZ=(ZTAT10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH10=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + SIMH10=(PSH10-PSHZ+RLNT10)*FH02 +! + AKMS10=MAX(USTARK/SIMM10,CXCHL) + AKHS02=MAX(USTARK/SIMH02,CXCHL) + AKHS10=MAX(USTARK/SIMH10,CXCHL) +!---------------------------------------------------------------------- + ENDIF +!---------------------------------------------------------------------- +! ENDIF +!---------------------------------------------------------------------- + U10 =UMFLX/AKMS10+UZ0 + V10 =VMFLX/AKMS10+VZ0 + TH02=HSFLX/AKHS02+THZ0 + TH10=HSFLX/AKHS10+THZ0 + Q02 =HLFLX/AKHS02+QZ0 + Q10 =HLFLX/AKHS10+QZ0 + TERM1=-0.068283/TLOW + PSHLTR=PSFC*EXP(TERM1) +! +!---------------------------------------------------------------------- +!*** COMPUTE "EQUIVALENT" Z0 TO APPROXIMATE LOCAL SHELTER READINGS. +!---------------------------------------------------------------------- +! + U10E=U10 + V10E=V10 +! + IF(SEAMASK<0.5)THEN + +!1st ZUUZ=MIN(0.5*ZU,0.1) +!1st ZU=MAX(0.1*ZU,ZUUZ) +!tst ZUUZ=amin1(ZU*0.50,0.3) +!tst ZU=amax1(ZU*0.3,ZUUZ) + + ZUUZ=AMIN1(ZU*0.50,0.18) + ZU=AMAX1(ZU*0.35,ZUUZ) +! + ZU10=ZU+10. + RZSU=ZU10/ZU + RLNU10=LOG(RZSU) + + ZETAU=ZU*RLMO + ZTAU10=ZU10*RLMO + + ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2) + ZETAU=MIN(MAX(ZETAU,ZTMIN2/RZSU),ZTMAX2/RZSU) + + RZ=(ZTAU10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) + SIMM10=PSM10-PSMZ+RLNU10 + EKMS10=MAX(USTARK/SIMM10,CXCHL) + + U10E=UMFLX/EKMS10+UZ0 + V10E=VMFLX/EKMS10+VZ0 + + ENDIF +! + U10=U10E + V10=V10E +! +!---------------------------------------------------------------------- +!*** SET OTHER WRF DRIVER ARRAYS +!---------------------------------------------------------------------- +! + RLOW=PLOW/(R_D*TLOW) + CHS=AKHS + CHS2=AKHS02 + CQS2=AKHS02 + HFX=-RLOW*CP*HSFLX + QFX=-RLOW*HLFLX*WETM + FLX_LH=XLV*QFX + FLHC=RLOW*CP*AKHS + FLQC=RLOW*AKHS*WETM +!!! QGH=PQ0/PSHLTR*EXP(A2S*(TSK-A3S)/(TSK-A4S)) + QGH=((1.-SEAMASK)*PQ0+SEAMASK*PQ0SEA) & + & /PLOW*EXP(A2S*(TLOW-A3S)/(TLOW-A4S)) + QGH=QGH/(1.-QGH) !Convert to mixing ratio + CPM=CP*(1.+0.8*QLOW) +! +!*** DO NOT COMPUTE QS OVER LAND POINTS HERE SINCE IT IS +!*** A PROGNOSTIC VARIABLE THERE. IT IS OKAY TO USE IT +!*** AS A DIAGNOSTIC OVER WATER SINCE IT WILL CAUSE NO +!*** INTERFERENCE BEFORE BEING RECOMPUTED IN MYJPBL. +! + IF(SEAMASK>0.5)THEN + QS=QLOW+QFX/(RLOW*AKHS) + QS=QS/(1.-QS) + ENDIF +!---------------------------------------------------------------------- +! + END SUBROUTINE SFCDIF +! +!---------------------------------------------------------------------- + SUBROUTINE MYJSFCINIT(LOWLYR,USTAR,Z0 & + & ,SEAMASK,XICE,IVGTYP,RESTART & + & ,ALLOWED_TO_READ & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + LOGICAL,INTENT(IN) :: RESTART,ALLOWED_TO_READ +! + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IVGTYP +! + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: LOWLYR +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: SEAMASK,XICE +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: USTAR,Z0 +! + REAL,DIMENSION(0:30) :: VZ0TBL + REAL,DIMENSION(0:30) :: VZ0TBL_24 +! + INTEGER :: I,IDUM,IRECV,J,JDUM,K,ITF,JTF,KTF,MAXGBL_IVGTYP & + &, MAXLOC_IVGTYP,MPI_COMM_COMP +! +! INTEGER :: MPI_INTEGER,MPI_MAX +! + REAL :: SM,X,ZETA1,ZETA2,ZRNG1,ZRNG2 +! + REAL :: PIHF=3.1415926/2.,EPS=1.E-6 +!---------------------------------------------------------------------- + VZ0TBL= & + & (/0., & + & 2.653,0.826,0.563,1.089,0.854,0.856,0.035,0.238,0.065,0.076 & + & ,0.011,0.035,0.011,0.000,0.000,0.000,0.000,0.000,0.000,0.000 & + & ,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/) + + VZ0TBL_24= (/0., & + & 1.00, 0.07, 0.07, 0.07, 0.07, 0.15, & + & 0.08, 0.03, 0.05, 0.86, 0.80, 0.85, & + & 2.65, 1.09, 0.80, 0.001, 0.04, 0.05, & + & 0.01, 0.04, 0.06, 0.05, 0.03, 0.001, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 /) + +!---------------------------------------------------------------------- +! + JTF=MIN0(JTE,JDE-1) + KTF=MIN0(KTE,KDE-1) + ITF=MIN0(ITE,IDE-1) +! +! +!*** FOR NOW, ASSUME SIGMA MODE FOR LOWEST MODEL LAYER +! + DO J=JTS,JTF + DO I=ITS,ITF + LOWLYR(I,J)=1 +! USTAR(I,J)=EPSUST + ENDDO + ENDDO +!---------------------------------------------------------------------- +#if (NMM_CORE == 1) +! + IF(.NOT.RESTART)THEN +! CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP) +! MAXLOC_IVGTYP=MAXVAL(IVGTYP) +! CALL MPI_ALLREDUCE(MAXLOC_IVGTYP,MAXGBL_IVGTYP,1,MPI_INTEGER & +! &, MPI_MAX,MPI_COMM_COMP,IRECV) + MAXGBL_IVGTYP=MAXVAL(IVGTYP) + CALL WRF_DM_MAXVAL(MAXGBL_IVGTYP,IDUM,JDUM) +! + IF (MAXGBL_IVGTYP<13) THEN + DO J=JTS,JTE + DO I=ITS,ITE + SM=SEAMASK(I,J)-1. + IF(SM+XICE(I,J)<0.5)THEN + Z0(I,J)=VZ0TBL(IVGTYP(I,J)) + ENDIF + ENDDO + ENDDO +! + ELSE +! + DO J=JTS,JTE + DO I=ITS,ITE + SM=SEAMASK(I,J)-1. + IF(SM+XICE(I,J)<0.5)THEN + Z0(I,J)=VZ0TBL_24(IVGTYP(I,J)) + ENDIF + ENDDO + ENDDO +! + ENDIF ! Vegtype check +! + ENDIF ! Restart check + +#endif +!---------------------------------------------------------------------- + IF(.NOT.RESTART)THEN + DO J=JTS,JTE + DO I=ITS,ITF + USTAR(I,J)=0.1 + ENDDO + ENDDO + ENDIF +!---------------------------------------------------------------------- +! +!*** COMPUTE SURFACE LAYER INTEGRAL FUNCTIONS +! +!---------------------------------------------------------------------- + FH01=1. + FH02=1. +! +! ZTMIN1=-10.0 +! ZTMAX1=2.0 +! ZTMIN2=-10.0 +! ZTMAX2=2.0 + ZTMIN1=-5.0 + ZTMAX1=1.0 + ZTMIN2=-5.0 + ZTMAX2=1.0 +! + ZRNG1=ZTMAX1-ZTMIN1 + ZRNG2=ZTMAX2-ZTMIN2 +! + DZETA1=ZRNG1/(KZTM-1) + DZETA2=ZRNG2/(KZTM-1) +! +!---------------------------------------------------------------------- +!*** FUNCTION DEFINITION LOOP +!---------------------------------------------------------------------- +! + ZETA1=ZTMIN1 + ZETA2=ZTMIN2 +! + DO K=1,KZTM +! +!---------------------------------------------------------------------- +!*** UNSTABLE RANGE +!---------------------------------------------------------------------- +! + IF(ZETA1<0.)THEN +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- + X=SQRT(SQRT(1.-16.*ZETA1)) +! + PSIM1(K)=-2.*LOG((X+1.)/2.)-LOG((X*X+1.)/2.)+2.*ATAN(X)-PIHF + PSIH1(K)=-2.*LOG((X*X+1.)/2.) +! +!---------------------------------------------------------------------- +!*** STABLE RANGE +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! +! PSIM1(K)=5.*ZETA1 +! PSIH1(K)=5.*ZETA1 +!---------------------------------------------------------------------- +!*** HOLTSLAG AND DE BRUIN 1988 +!---------------------------------------------------------------------- +! + PSIM1(K)=0.7*ZETA1+0.75*ZETA1*(6.-0.35*ZETA1)*EXP(-0.35*ZETA1) + PSIH1(K)=0.7*ZETA1+0.75*ZETA1*(6.-0.35*ZETA1)*EXP(-0.35*ZETA1) +!---------------------------------------------------------------------- +! + ENDIF +! +!---------------------------------------------------------------------- +!*** UNSTABLE RANGE +!---------------------------------------------------------------------- +! + IF(ZETA2<0.)THEN +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! + X=SQRT(SQRT(1.-16.*ZETA2)) +! + PSIM2(K)=-2.*LOG((X+1.)/2.)-LOG((X*X+1.)/2.)+2.*ATAN(X)-PIHF + PSIH2(K)=-2.*LOG((X*X+1.)/2.) +!---------------------------------------------------------------------- +!*** STABLE RANGE +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! +! PSIM2(K)=5.*ZETA2 +! PSIH2(K)=5.*ZETA2 +! +!---------------------------------------------------------------------- +!*** HOLTSLAG AND DE BRUIN 1988 +!---------------------------------------------------------------------- +! + PSIM2(K)=0.7*ZETA2+0.75*ZETA2*(6.-0.35*ZETA2)*EXP(-0.35*ZETA2) + PSIH2(K)=0.7*ZETA2+0.75*ZETA2*(6.-0.35*ZETA2)*EXP(-0.35*ZETA2) +!---------------------------------------------------------------------- +! + ENDIF +! +!---------------------------------------------------------------------- + IF(K==KZTM)THEN + ZTMAX1=ZETA1 + ZTMAX2=ZETA2 + ENDIF +! + ZETA1=ZETA1+DZETA1 + ZETA2=ZETA2+DZETA2 +!---------------------------------------------------------------------- + ENDDO +!---------------------------------------------------------------------- + ZTMAX1=ZTMAX1-EPS + ZTMAX2=ZTMAX2-EPS +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJSFCINIT +! +!---------------------------------------------------------------------- +! + END MODULE MODULE_SF_MYJSFC +! +!---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F new file mode 100644 index 00000000..1bf2aeec --- /dev/null +++ b/wrfv2_fire/phys/module_sf_noahlsm.F @@ -0,0 +1,5366 @@ +MODULE module_sf_noahlsm + + USE module_model_constants + +!------------------------------- + USE module_sf_urban +!------------------------------- + +! REAL, PARAMETER :: CP = 1004.5 + REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & + CPH2O = 4.218E+3,CPICE = 2.106E+3, & + LSUBF = 3.335E+5 + +! VEGETATION PARAMETERS + INTEGER :: LUCATS , BARE + integer, PARAMETER :: NLUS=50 + CHARACTER*4 LUTYPE + INTEGER, DIMENSION(1:NLUS) :: NROTBL + real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, LAITBL, & + ALBTBL, Z0TBL, SHDTBL, MAXALB + REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA + +! SOIL PARAMETERS + INTEGER :: SLCATS + INTEGER, PARAMETER :: NSLTYPE=30 + CHARACTER*4 SLTYPE + REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ + +! LSM GENERAL PARAMETERS + INTEGER :: SLPCATS + INTEGER, PARAMETER :: NSLOPE=30 + REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA + REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & + CZIL_DATA + + CHARACTER*256 :: err_message + +! +CONTAINS +! +!---------------------------------------------------------------- +! Urban related variable are added to arguments - urban +!---------------------------------------------------------------- + SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & + HFX,QFX,LH,GRDFLX, QGH,GSW,GLW,SMSTAV,SMSTOT, & + SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,VEGFRA, & + ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE, EMISS, & + SNOWC,QSFC,RAINBL, & + num_soil_layers,DT,DZS,ITIMESTEP, & + SMOIS,TSLB,SNOW,CANWAT, & + CHS,CHS2,CQS2,CPM,ROVCP, & !H + SH2O,SNOWH, & !H + U_PHY,V_PHY, & !I + SNOALB,SHDMIN,SHDMAX, & !I + ACSNOM,ACSNOW, & !O + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + ucmcall, & +!Optional Urban + TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban + UC_URB2D, & !H urban + XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban + TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban + SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban + PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban + GZ1OZ0_URB2D, AKMS_URB2D, & !O urban + TH2_URB2D,Q2_URB2D, UST_URB2D, & !O urban + DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban + XLAT_URB2D, & !I urban + num_roof_layers, num_wall_layers, & !I urban + num_road_layers, DZR, DZB, DZG, & !I urban + FRC_URB2D,UTYPE_URB2D) !O +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +!---------------------------------------------------------------- +! --- atmospheric (WRF generic) variables +!-- DT time step (seconds) +!-- DZ8W thickness of layers (m) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- FLHC exchange coefficient for heat (m/s) +!-- FLQC exchange coefficient for moisture (m/s) +!-- PSFC surface pressure (Pa) +!-- XLAND land mask (1 for land, 2 for water) +!-- QGH saturated mixing ratio at 2 meter +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- History variables +!-- CANWAT canopy moisture content (mm) +!-- TSK surface temperature (K) +!-- TSLB soil temp (k) +!-- SMOIS total soil moisture content (volumetric fraction) +!-- SH2O unfrozen soil moisture content (volumetric fraction) +! note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O +!-- SNOWH actual snow depth (m) +!-- SNOW liquid water-equivalent snow depth (m) +!-- ALBEDO time-varying surface albedo including snow effect (unitless fraction) +!-- ALBBCK background surface albedo (unitless fraction) +!-- CHS surface exchange coefficient for heat and moisture (m s-1); +!-- CHS2 2m surface exchange coefficient for heat (m s-1); +!-- CQS2 2m surface exchange coefficient for moisture (m s-1); +! --- soil variables +!-- num_soil_layers the number of soil layers +!-- ZS depths of centers of soil layers (m) +!-- DZS thicknesses of soil layers (m) +!-- SLDPTH thickness of each soil layer (m, same as DZS) +!-- TMN soil temperature at lower boundary (K) +!-- SMCWLT wilting point (volumetric) +!-- SMCDRY dry soil moisture threshold where direct evap from +! top soil layer ends (volumetric) +!-- SMCREF soil moisture threshold below which transpiration begins to +! stress (volumetric) +!-- SMCMAX porosity, i.e. saturated value of soil moisture (volumetric) +!-- NROOT number of root layers, a function of veg type, determined +! in subroutine redprm. +!-- SMSTAV Soil moisture availability for evapotranspiration ( +! fraction between SMCWLT and SMCMXA) +!-- SMSTOT Total soil moisture content frozen+unfrozen) in the soil column (mm) +! --- snow variables +!-- SNOWC fraction snow coverage (0-1.0) +! --- vegetation variables +!-- SNOALB upper bound on maximum albedo over deep snow +!-- SHDMIN minimum areal fractional coverage of annual green vegetation +!-- SHDMAX maximum areal fractional coverage of annual green vegetation +!-- XLAI leaf area index (dimensionless) +!-- Z0BRD Background fixed roughness length (M) +!-- Z0 Background vroughness length (M) as function +!-- ZNT Time varying roughness length (M) as function +!-- ALBD(IVGTPK,ISN) background albedo reading from a table +! --- LSM output +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH upward moisture flux at the surface (W m-2) +!-- GRDFLX(I,J) ground heat flux (W m-2) +!-- FDOWN radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +!---------------------------------------------------------------------------- +!-- EC canopy water evaporation ((W m-2) +!-- EDIR direct soil evaporation (W m-2) +!-- ET plant transpiration from a particular root layer (W m-2) +!-- ETT total plant transpiration (W m-2) +!-- ESNOW sublimation from (or deposition to if <0) snowpack (W m-2) +!-- DRIP through-fall of precip and/or dew in excess of canopy +! water-holding capacity (m) +!-- DEW dewfall (or frostfall for t<273.15) (M) +! ---------------------------------------------------------------------- +!-- BETA ratio of actual/potential evap (dimensionless) +!-- ETP potential evaporation (W m-2) +! ---------------------------------------------------------------------- +!-- FLX1 precip-snow sfc (W m-2) +!-- FLX2 freezing rain latent heat flux (W m-2) +!-- FLX3 phase-change heat flux from snowmelt (W m-2) +! ---------------------------------------------------------------------- +!-- ACSNOM snow melt (mm) (water equivalent) +!-- ACSNOW accumulated snow fall (mm) (water equivalent) +! ---------------------------------------------------------------------- +!-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface +!-- RUNOFF2 subsurface runoff (m s-1), drainage out bottom of last +! soil layer (baseflow) +! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3 +!-- RUNOFF3 numerical trunctation in excess of porosity (smcmax) +! for a given soil layer at the end of a time step (m s-1). +! ---------------------------------------------------------------------- +!-- RC canopy resistance (s m-1) +!-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp +!-- RSMIN minimum canopy resistance (s m-1) +!-- RCS incoming solar rc factor (dimensionless) +!-- RCT air temperature rc factor (dimensionless) +!-- RCQ atmos vapor pressure deficit rc factor (dimensionless) +!-- RCSOIL soil moisture rc factor (dimensionless) + +!-- EMISS surface emissivity (between 0 and 1) + +!-- ROVCP R/CP +! (R_d/R_v) (dimensionless) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!---------------------------------------------------------------- + +! IN only + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ucmcall !urban + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: TMN, & + XLAND, & + XICE, & + VEGFRA, & + SHDMIN, & + SHDMAX, & + SNOALB, & + GSW, & + GLW, & + Z0, & + ALBBCK, & + RAINBL, & + EMISS + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + p8w3D, & + DZ8W, & + T3D + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: QGH, & + CHS, & + CPM + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: IVGTYP, & + ISLTYP + + INTEGER, INTENT(IN) :: num_soil_layers,ITIMESTEP + + REAL, INTENT(IN ) :: DT,ROVCP + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS + +! IN and OUT + + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(INOUT) :: SMOIS, & ! total soil moisture + SH2O, & ! new soil liquid + TSLB ! TSLB STEMP + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: TSK, & !was TGB (temperature) + HFX, & + QFX, & + LH, & + GRDFLX, & + QSFC,& + CQS2,& + CHS2,& + SNOW, & + SNOWC, & + SNOWH, & !new + CANWAT, & + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + ACSNOM, & + ACSNOW, & + ALBEDO, & + ZNT + + +! Local variables (moved here from driver to make routine thread safe, 20031007 jm) + + REAL, DIMENSION(1:num_soil_layers) :: ET + + REAL :: BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT, & + FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI, & + RCS,RCT,RCQ,RCSOIL + + +! DECLARATIONS - LOGICAL +! ---------------------------------------------------------------------- + LOGICAL, PARAMETER :: LOCAL=.false. + LOGICAL :: FRZGRA, SNOWNG + + LOGICAL :: IPRINT + +! ---------------------------------------------------------------------- +! DECLARATIONS - INTEGER +! ---------------------------------------------------------------------- + INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP + INTEGER :: NROOT + INTEGER :: KZ ,K + INTEGER :: NS +! ---------------------------------------------------------------------- +! DECLARATIONS - REAL +! ---------------------------------------------------------------------- + + REAL :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN, & + Q2SAT,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1, & + SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, & + Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT + + REAL :: EMISSI + + REAL :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2 + + REAL :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1 + + REAL :: DUMMY,Z0BRD +! + REAL :: COSZ, SOLARDIRECT +! + REAL, DIMENSION(1:num_soil_layers):: SLDPTH, STC,SMC,SWC +! + REAL, DIMENSION(1:num_soil_layers) :: ZSOIL, RTDIS + REAL, PARAMETER :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65, & + T0=273.16E0, ELWV=2.50E6, A23M4=A2*(A3-A4) + +! ---------------------------------------------------------------------- +! DECLARATIONS START - urban +! ---------------------------------------------------------------------- + +! input variables surface_driver --> lsm + INTEGER, INTENT(IN) :: num_roof_layers + INTEGER, INTENT(IN) :: num_wall_layers + INTEGER, INTENT(IN) :: num_road_layers + REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR + REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB + REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG + REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY + +! input variables lsm --> urban + INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3] + REAL :: TA_URB ! potential temp at 1st atmospheric level [K] + REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg] + REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s] + REAL :: U1_URB ! u at 1st atmospheric level [m/s] + REAL :: V1_URB ! v at 1st atmospheric level [m/s] + REAL :: SSG_URB ! downward total short wave radiation [W/m/m] + REAL :: LLG_URB ! downward long wave radiation [W/m/m] + REAL :: RAIN_URB ! precipitation [mm/h] + REAL :: RHOO_URB ! air density [kg/m^3] + REAL :: ZA_URB ! first atmospheric level [m] + REAL :: DELT_URB ! time step [s] + REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m] + REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m] + REAL :: XLAT_URB ! latitude [deg] + REAL :: COSZ_URB ! cosz + REAL :: OMG_URB ! hour angle + REAL :: ZNT_URB ! roughness length [m] + REAL :: TR_URB + REAL :: TB_URB + REAL :: TG_URB + REAL :: TC_URB + REAL :: QC_URB + REAL :: UC_URB + REAL :: XXXR_URB + REAL :: XXXB_URB + REAL :: XXXG_URB + REAL :: XXXC_URB + REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K] + REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] + REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] + LOGICAL :: LSOLAR_URB +! state variable surface_driver <--> lsm <--> urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D +! + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D + + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D + +! output variable lsm --> surface_driver + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D +! + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D +! + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D + + +! output variables urban --> lsm + REAL :: TS_URB ! surface radiative temperature [K] + REAL :: QS_URB ! surface humidity [-] + REAL :: SH_URB ! sensible heat flux [W/m/m] + REAL :: LH_URB ! latent heat flux [W/m/m] + REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s] + REAL :: SW_URB ! upward short wave radiation flux [W/m/m] + REAL :: ALB_URB ! time-varying albedo [fraction] + REAL :: LW_URB ! upward long wave radiation flux [W/m/m] + REAL :: G_URB ! heat flux into the ground [W/m/m] + REAL :: RN_URB ! net radiation [W/m/m] + REAL :: PSIM_URB ! shear f for momentum [-] + REAL :: PSIH_URB ! shear f for heat [-] + REAL :: GZ1OZ0_URB ! shear f for heat [-] + REAL :: U10_URB ! wind u component at 10 m [m/s] + REAL :: V10_URB ! wind v component at 10 m [m/s] + REAL :: TH2_URB ! potential temperature at 2 m [K] + REAL :: Q2_URB ! humidity at 2 m [-] + REAL :: CHS_URB + REAL :: CHS2_URB + REAL :: UST_URB + +! ---------------------------------------------------------------------- +! DECLARATIONS END - urban +! ---------------------------------------------------------------------- + +! debug printout + IPRINT=.false. + + SLOPETYP=2 +! SHDMIN=0.00 + + + NSOIL=num_soil_layers + + DO NS=1,NSOIL + SLDPTH(NS)=DZS(NS) + ENDDO + + DO J=jts,jte + + IF(ITIMESTEP.EQ.1)THEN + DO 50 I=its,ite +!*** initialize soil conditions for IHOP 31 May case +! IF((XLAND(I,J)-1.5) < 0.)THEN +! if (I==108.and.j==85) then +! DO NS=1,NSOIL +! SMOIS(I,NS,J)=0.10 +! SH2O(I,NS,J)=0.10 +! enddo +! endif +! ENDIF + +!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS + IF((XLAND(I,J)-1.5).GE.0.)THEN +! check sea-ice point + IF(XICE(I,J).EQ.1..and.IPRINT)PRINT*,' sea-ice at water point, I=',I, & + 'J=',J +!*** Open Water Case + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + TSLB(I,NS,J)=273.16 !STEMP + ENDDO + ELSE + IF(XICE(I,J).EQ.1.)THEN +!*** SEA-ICE CASE + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + ENDDO + ENDIF + ENDIF +! + 50 CONTINUE + ENDIF ! end of initialization over ocean + +!----------------------------------------------------------------------- + DO 100 I=its,ite + SFCPRS=P8w3D(i,1,j) + Q2K=QV3D(i,1,j) + Q2SAT=QGH(I,j) + SFCTMP=T3D(i,1,j) + ZLVL=0.5*DZ8W(i,1,j) + TH2=SFCTMP+(0.0097545*ZLVL) + EMISSI = EMISS(I,J) + LWDN=GLW(I,J)*EMISSI + SOLDN=GSW(I,J)/(1.0-albedo(i,j)) + PRCP=RAINBL(i,j)/DT + VEGTYP=IVGTYP(I,J) + SOILTYP=ISLTYP(I,J) + SHDFAC=VEGFRA(I,J)/100. + T1=TSK(I,J) + CHK=CHS(I,J) + SHMIN=SHDMIN(I,J)/100. !NEW + SHMAX=SHDMAX(I,J)/100. !NEW + SNOALB1=SNOALB(I,J) !NEW +! convert snow depth from mm to meter + SNEQV=SNOW(I,J)*0.001 +! SNOWHK=SNOWH(I,J)*0.001 ! check the unit of snowh which is assumed to be mm for now + SNOWHK=SNOWH(I,J) ! check the unit of snowh which is assumed to be m for now + + +!*** + IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block +! Open water points +!CC Q2SAT=PQ0/SFCPRS*EXP(A2*(TGDSA(I)-A3)/(TGDSA(I)-A4)) +! HFX(I,J)=CHFF*(TGDSA(I)-TH(I)) +! QFX(I,J)=RHO(I)*CHS(I)*(Q2SAT-QV(I)) +! SFCEVP(I,J)=SFCEVP(I,J)+QFX(I,J)*DT + + ELSE +! Land or sea-ice case + + IF (XICE(I,J) .GT. 0.5) THEN + ICE=1 + ELSE + ICE=0 + ENDIF + DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2 + + IF(ICE.EQ.0)THEN + TBOT=TMN(I,J) + ELSE + TBOT=271.16 + ENDIF + IF(VEGTYP.EQ.25) SHDFAC=0.0000 + IF(VEGTYP.EQ.26) SHDFAC=0.0000 + IF(VEGTYP.EQ.27) SHDFAC=0.0000 + IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN + IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F' + SOILTYP=7 + ENDIF + CMC=CANWAT(I,J) + +!------------------------------------------- +!*** convert snow depth from mm to meter +! +! IF(RDMAXALB) THEN +! SNOALB=ALBMAX(I,J)*0.01 +! ELSE +! SNOALB=MAXALB(IVGTPK)*0.01 +! ENDIF +! IF(RDBRDALB) THEN +! ALBBRD=ALBEDO(I,J)*0.01 +! ELSE +! ALBBRD=ALBD(IVGTPK,ISN)*0.01 +! ENDIF + +! SNOALB1=0.80 +! SHMIN=0.00 + ALBBRD=ALBBCK(I,J) + Z0BRD=Z0(I,J) +!FEI: temporaray arrays above need to be changed later by using SI + + DO 70 NS=1,NSOIL + SMC(NS)=SMOIS(I,NS,J) + STC(NS)=TSLB(I,NS,J) !STEMP + SWC(NS)=SH2O(I,NS,J) + 70 CONTINUE +! + if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN + SNOWHK= 5.*SNEQV + endif +! + +!Fei: urban. for urban surface, if calling UCM, redefine urban as 5: Cropland/Grassland Mosaic + + IF(UCMCALL == 1 ) THEN + IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + VEGTYP = 5 + SHDFAC = 0.8 + ALBEDOK =0.2 + ALBBRD =0.2 + IF ( FRC_URB2D(I,J) < 0.99 ) THEN + T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) + ELSE + T1 = TSK(I,J) + ENDIF + ENDIF + ELSE + IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + VEGTYP = 1 + ENDIF + ENDIF + + IF(IPRINT) THEN +! + print*, 'BEFORE SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDO',ALBEDO,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif + + + CALL SFLX (ICE,DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,DUMMY, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, & !S + CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1, & !D + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) + + + IF(IPRINT) THEN + + print*, 'AFTER SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDO',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif + +!*** UPDATE STATE VARIABLES + CANWAT(I,J)=CMC + SNOW(I,J)=SNEQV*1000. +! SNOWH(I,J)=SNOWHK*1000. + SNOWH(I,J)=SNOWHK ! SNOWHK is assumed in meters + ALBEDO(I,J)=ALBEDOK + ZNT(I,J)=Z0K + TSK(I,J)=T1 + HFX(I,J)=SHEAT + QFX(I,J)=ETA_KINEMATIC + LH(I,J)=ETA + GRDFLX(I,J)=SSOIL + SNOWC(I,J)=SNCOVR + CHS2(I,J)=CQS2(I,J) +! prevent diagnostic ground q (q1) from being greater than qsat(tsk) +! as happens over snow cover where the cqs2 value also becomes irrelevant +! by setting cqs2=chs in this situation the 2m q should become just qv(k=1) + IF (Q1 .GT. QSFC(I,J)) THEN + CQS2(I,J) = CHS(I,J) + ENDIF + QSFC(I,J)=Q1 +! + DO 80 NS=1,NSOIL + SMOIS(I,NS,J)=SMC(NS) + TSLB(I,NS,J)=STC(NS) ! STEMP + SH2O(I,NS,J)=SWC(NS) + 80 CONTINUE +! ENDIF + + IF (UCMCALL == 1 ) THEN ! Beginning of UCM CALL if block +!-------------------------------------- +! URBAN CANOPY MODEL START - urban +!-------------------------------------- +! Input variables lsm --> urban + + + IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN + +! Call urban + +! + UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) + + TA_URB = SFCTMP ! [K] + QA_URB = Q2K ! [kg/kg] + UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.) + U1_URB = U_PHY(I,1,J) + V1_URB = V_PHY(I,1,J) + IF(UA_URB < 1.) UA_URB=1. ! [m/s] + SSG_URB = SOLDN ! [W/m/m] + SSGD_URB = 0.8*SOLDN ! [W/m/m] + SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] + LLG_URB = LWDN ! [W/m/m] + RAIN_URB = RAINBL(I,J) ! [mm] + RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] + ZA_URB = ZLVL ! [m] + DELT_URB = DT ! [sec] + XLAT_URB = XLAT_URB2D(I,J) ! [deg] + COSZ_URB = COSZ_URB2D(I,J) ! + OMG_URB = OMG_URB2D(I,J) ! + ZNT_URB = ZNT(I,J) + + LSOLAR_URB = .FALSE. + + TR_URB = TR_URB2D(I,J) + TB_URB = TB_URB2D(I,J) + TG_URB = TG_URB2D(I,J) + TC_URB = TC_URB2D(I,J) + QC_URB = QC_URB2D(I,J) + UC_URB = UC_URB2D(I,J) + + DO K = 1,num_roof_layers + TRL_URB(K) = TRL_URB3D(I,K,J) + END DO + DO K = 1,num_wall_layers + TBL_URB(K) = TBL_URB3D(I,K,J) + END DO + DO K = 1,num_road_layers + TGL_URB(K) = TGL_URB3D(I,K,J) + END DO + + XXXR_URB = XXXR_URB2D(I,J) + XXXB_URB = XXXB_URB2D(I,J) + XXXG_URB = XXXG_URB2D(I,J) + XXXC_URB = XXXC_URB2D(I,J) +! + CHS_URB = CHS(I,J) + CHS2_URB = CHS2(I,J) +! + +! Call urban + + + CALL urban(LSOLAR_URB, & ! I + num_roof_layers,num_wall_layers,num_road_layers, & ! C + DZR,DZB,DZG, & ! C + UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I + SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I + ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I + XLAT_URB,DELT_URB,ZNT_URB, & ! I + CHS_URB, CHS2_URB, & ! I + TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H + TRL_URB,TBL_URB,TGL_URB, & ! H + XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H + TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O + SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O + GZ1OZ0_URB, & !O + U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O + UST_URB) !O + + + IF(IPRINT) THEN + + print*, 'AFTER CALL URBAN' + print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', & + num_wall_layers, & + 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', & + TA_URB, & + 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', & + V1_URB, & + 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, & + 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, & + 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,& + 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, & + 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',& + TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, & + 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, & + 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,& + 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', & + LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,& + 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', & + RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, & + 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, & + 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB + endif + + TS_URB2D(I,J) = TS_URB + + ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-] + HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m] + QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB & + + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s] + LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m] + GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m] + TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K] + QSFC(I,J)= FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-] + + IF(IPRINT)THEN + + print*, ' FRC_URB2D', FRC_URB2D, & + 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, & + 'ALBEDO(I,J)', ALBEDO(I,J), & + 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), & + 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', & + ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), & + 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), & + 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),& + 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), & + 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J) + endif + + + + +! Renew Urban State Varialbes + + TR_URB2D(I,J) = TR_URB + TB_URB2D(I,J) = TB_URB + TG_URB2D(I,J) = TG_URB + TC_URB2D(I,J) = TC_URB + QC_URB2D(I,J) = QC_URB + UC_URB2D(I,J) = UC_URB + + DO K = 1,num_roof_layers + TRL_URB3D(I,K,J) = TRL_URB(K) + END DO + DO K = 1,num_wall_layers + TBL_URB3D(I,K,J) = TBL_URB(K) + END DO + DO K = 1,num_road_layers + TGL_URB3D(I,K,J) = TGL_URB(K) + END DO + XXXR_URB2D(I,J) = XXXR_URB + XXXB_URB2D(I,J) = XXXB_URB + XXXG_URB2D(I,J) = XXXG_URB + XXXC_URB2D(I,J) = XXXC_URB + + SH_URB2D(I,J) = SH_URB + LH_URB2D(I,J) = LH_URB + G_URB2D(I,J) = G_URB + RN_URB2D(I,J) = RN_URB + PSIM_URB2D(I,J) = PSIM_URB + PSIH_URB2D(I,J) = PSIH_URB + GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB + U10_URB2D(I,J) = U10_URB + V10_URB2D(I,J) = V10_URB + TH2_URB2D(I,J) = TH2_URB + Q2_URB2D(I,J) = Q2_URB + UST_URB2D(I,J) = UST_URB + AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) + + END IF + + ENDIF ! end of UCM CALL if block +!-------------------------------------- +! Urban Part End - urban +!-------------------------------------- + +!*** DIAGNOSTICS + SMSTAV(I,J)=SOILW + SMSTOT(I,J)=SOILM*1000. +! Convert the water unit into mm + SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0 + UDRUNOFF(I,J)=UDRUNOFF(I,J)+(RUNOFF2+RUNOFF3)*DT*1000.0 + IF(SFCTMP<=T0)THEN +! ACSNOW(I,J)=ACSNOW(I,J)+PREC(I)*DT + ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT + ENDIF + IF(SNOW(I,J).GT.0.)THEN + ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000. + ENDIF + + ENDIF ! endif of land-sea test + + 100 CONTINUE ! of I loop + + ENDDO ! of J loop +!------------------------------------------------------ + END SUBROUTINE lsm +!------------------------------------------------------ + + SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & + SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, & + ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, & + FNDSOILW, FNDSNOWH, & + num_soil_layers, restart, & + allowed_to_read , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: num_soil_layers + + LOGICAL , INTENT(IN) :: restart , allowed_to_read + + REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: SMOIS, & !Total soil moisture + SH2O, & !liquid soil moisture + TSLB !STEMP + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SNOW, & + SNOWH, & + SNOWC, & + CANWAT, & + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + ACSNOW, & + VEGFRA, & + ACSNOM + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN) :: IVGTYP, & + ISLTYP + + LOGICAL, INTENT(IN) :: FNDSOILW , & + FNDSNOWH + + INTEGER :: L + REAL :: BX, SMCMAX, PSISAT, FREE + REAL, PARAMETER :: BLIM = 5.5, HLICE = 3.335E5, & + GRAV = 9.81, T0 = 273.15 + INTEGER :: errflag + +! + + +! initialize three Noah LSM related tables + IF ( allowed_to_read ) THEN + CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' ) + CALL LSM_PARM_INIT + ENDIF + + IF(.not.restart)THEN + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + errflag = 0 + DO j = jts,jtf + DO i = its,itf + IF ( ISLTYP( i,j ) .LT. 1 ) THEN + errflag = 1 + WRITE(err_message,*)"module_sf_noahlsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) + CALL wrf_message(err_message) + ENDIF + ENDDO + ENDDO + IF ( errflag .EQ. 1 ) THEN + CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// & + "of ISLTYP. Is this field in the input?" ) + ENDIF + +! initialize soil liquid water content SH2O + +! IF(.NOT.FNDSOILW) THEN + +! If no SWC, do the following +! PRINT *,'SOIL WATER NOT FOUND - VALUE SET IN LSMINIT' + DO J = jts,jtf + DO I = its,itf + BX = BB(ISLTYP(I,J)) + SMCMAX = MAXSMC(ISLTYP(I,J)) + PSISAT = SATPSI(ISLTYP(I,J)) + if ((bx > 0.0).and.(smcmax > 0.0).and.(psisat > 0.0)) then + DO NS=1, num_soil_layers +! ---------------------------------------------------------------------- +!SH2O <= SMOIS for T < 273.149K (-0.001C) + IF (TSLB(I,NS,J) < 273.149) THEN +! ---------------------------------------------------------------------- +! first guess following explicit solution for Flerchinger Eqn from Koren +! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O). +! ISLTPK is soil type + BX = BB(ISLTYP(I,J)) + SMCMAX = MAXSMC(ISLTYP(I,J)) + PSISAT = SATPSI(ISLTYP(I,J)) + IF ( BX > BLIM ) BX = BLIM + FK=(( (HLICE/(GRAV*(-PSISAT))) * & + ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BX) )*SMCMAX + IF (FK < 0.02) FK = 0.02 + SH2O(I,NS,J) = MIN( FK, SMOIS(I,NS,J) ) +! ---------------------------------------------------------------------- +! now use iterative solution for liquid soil water content using +! FUNCTION FRH2O with the initial guess for SH2O from above explicit +! first guess. + CALL FRH2O (FREE,TSLB(I,NS,J),SMOIS(I,NS,J),SH2O(I,NS,J), & + SMCMAX,BX,PSISAT) + SH2O(I,NS,J) = FREE + ELSE ! of IF (TSLB(I,NS,J) +! ---------------------------------------------------------------------- +! SH2O = SMOIS ( for T => 273.149K (-0.001C) + SH2O(I,NS,J)=SMOIS(I,NS,J) +! ---------------------------------------------------------------------- + ENDIF ! of IF (TSLB(I,NS,J) + END DO ! of DO NS=1, num_soil_layers + else ! of if ((bx > 0.0) + DO NS=1, num_soil_layers + SH2O(I,NS,J)=SMOIS(I,NS,J) + END DO + endif ! of if ((bx > 0.0) + ENDDO ! DO I = its,itf + ENDDO ! DO J = jts,jtf +! ENDIF ! of IF(.NOT.FNDSOILW)THEN + +! initialize physical snow height SNOWH + + IF(.NOT.FNDSNOWH)THEN +! If no SNOWH do the following + CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' ) + DO J = jts,jtf + DO I = its,itf + SNOWH(I,J)=SNOW(I,J)*0.005 ! SNOW in mm and SNOWH in m + ENDDO + ENDDO + ENDIF + +! initialize canopy water to ZERO + +! GO TO 110 +! print*,'Note that canopy water content (CANWAT) is set to ZERO in LSMINIT' + DO J = jts,jtf + DO I = its,itf + CANWAT(I,J)=0.0 + ENDDO + ENDDO + 110 CONTINUE + + ENDIF +!------------------------------------------------------------------------------ + END SUBROUTINE lsminit +!------------------------------------------------------------------------------ + + + +! +!----------------------------------------------------------------- + SUBROUTINE LSM_PARM_INIT +!----------------------------------------------------------------- + + character*4 :: MMINLU, MMINSL + + MMINLU='USGS' + MMINSL='STAS' + call SOIL_VEG_GEN_PARM( MMINLU, MMINSL) + +!----------------------------------------------------------------- + END SUBROUTINE LSM_PARM_INIT +!----------------------------------------------------------------- + +!----------------------------------------------------------------- + SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) +!----------------------------------------------------------------- + + IMPLICIT NONE + + integer :: LUMATCH, IINDEX, LC, NUM_SLOPE + integer :: ierr + INTEGER , PARAMETER :: OPEN_OK = 0 + + character*4 :: MMINLU, MMINSL + character*128 :: mess , message + logical, external :: wrf_dm_on_monitor + + +!-----SPECIFY VEGETATION RELATED CHARACTERISTICS : +! ALBBCK: SFC albedo (in percentage) +! Z0: Roughness length (m) +! SHDFAC: Green vegetation fraction (in percentage) +! Note: The ALBEDO, Z0, and SHDFAC values read from the following table +! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is +! the monthly green vegetation data +! CMXTBL: MAX CNPY Capacity (m) +! NROTBL: Rooting depth (layer) +! RSMIN: Mimimum stomatal resistance (s m-1) +! RSMAX: Max. stomatal resistance (s m-1) +! RGL: Parameters used in radiation stress function +! HS: Parameter used in vapor pressure deficit functio +! TOPT: Optimum transpiration air temperature. (K) +! CMCMAX: Maximum canopy water capacity +! CFACTR: Parameter used in the canopy inteception calculati +! SNUP: Threshold snow depth (in water equivalent m) that +! implies 100% snow cover +! LAI: Leaf area index (dimensionless) +! MAXALB: Upper bound on maximum albedo over deep snow +! +!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL +! + + IF ( wrf_dm_on_monitor() ) THEN + + OPEN(19, FILE='VEGPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. OPEN_OK ) THEN + WRITE(message,FMT='(A)') & + 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF + + WRITE ( mess, * ) 'INPUT LANDUSE = ',MMINLU + CALL wrf_message( mess ) + + LUMATCH=0 + + READ (19,*) + READ (19,2000,END=2002)LUTYPE + READ (19,*)LUCATS,IINDEX + 2000 FORMAT (A4) + + IF(LUTYPE.EQ.MMINLU)THEN + WRITE( mess , * ) 'LANDUSE TYPE = ',LUTYPE,' FOUND', & + LUCATS,' CATEGORIES' + CALL wrf_message( mess ) + LUMATCH=1 + ENDIF + + IF(LUTYPE.EQ.MMINLU)THEN + DO LC=1,LUCATS + READ (19,*)IINDEX,ALBTBL(LC),Z0TBL(LC),SHDTBL(LC), & + NROTBL(LC),RSTBL(LC),RGLTBL(LC),HSTBL(LC), & + SNUPTBL(LC),LAITBL(LC),MAXALB(LC) + ENDDO +! + READ (19,*) + READ (19,*)TOPT_DATA + READ (19,*) + READ (19,*)CMCMAX_DATA + READ (19,*) + READ (19,*)CFACTR_DATA + READ (19,*) + READ (19,*)RSMAX_DATA + READ (19,*) + READ (19,*)BARE + ENDIF +! + 2002 CONTINUE + + CLOSE (19) + ENDIF + + CALL wrf_dm_bcast_string ( LUTYPE , 4 ) + CALL wrf_dm_bcast_integer ( LUCATS , 1 ) + CALL wrf_dm_bcast_integer ( IINDEX , 1 ) + CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) + CALL wrf_dm_bcast_real ( ALBTBL , NLUS ) + CALL wrf_dm_bcast_real ( Z0TBL , NLUS ) + CALL wrf_dm_bcast_real ( SHDTBL , NLUS ) + CALL wrf_dm_bcast_real ( NROTBL , NLUS ) + CALL wrf_dm_bcast_real ( RSTBL , NLUS ) + CALL wrf_dm_bcast_real ( RGLTBL , NLUS ) + CALL wrf_dm_bcast_real ( HSTBL , NLUS ) + CALL wrf_dm_bcast_real ( SNUPTBL , NLUS ) + CALL wrf_dm_bcast_real ( LAITBL , NLUS ) + CALL wrf_dm_bcast_real ( MAXALB , NLUS ) + CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) + CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) + CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) + CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) + CALL wrf_dm_bcast_integer ( BARE , 1 ) + +! +!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL +! + IF ( wrf_dm_on_monitor() ) THEN + OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. OPEN_OK ) THEN + WRITE(message,FMT='(A)') & + 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF + + MMINSL='STAS' !oct2 + WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICAION = ',MMINSL + CALL wrf_message( mess ) + + LUMATCH=0 + + READ (19,*) + READ (19,2000,END=2003)SLTYPE + READ (19,*)SLCATS,IINDEX + IF(SLTYPE.EQ.MMINSL)THEN + WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ',SLTYPE,' FOUND', & + SLCATS,' CATEGORIES' + CALL wrf_message ( mess ) + LUMATCH=1 + ENDIF + IF(SLTYPE.EQ.MMINSL)THEN + DO LC=1,SLCATS + READ (19,*) IINDEX,BB(LC),DRYSMC(LC),F11(LC),MAXSMC(LC),& + REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC), & + WLTSMC(LC), QTZ(LC) + ENDDO + ENDIF + + 2003 CONTINUE + + CLOSE (19) + ENDIF + + CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) + CALL wrf_dm_bcast_string ( SLTYPE , 4 ) + CALL wrf_dm_bcast_string ( MMINSL , 4 ) ! since this is reset above, see oct2 ^ + CALL wrf_dm_bcast_integer ( SLCATS , 1 ) + CALL wrf_dm_bcast_integer ( IINDEX , 1 ) + CALL wrf_dm_bcast_real ( BB , NSLTYPE ) + CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) + CALL wrf_dm_bcast_real ( F11 , NSLTYPE ) + CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) + CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) + CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE ) + CALL wrf_dm_bcast_real ( SATDK , NSLTYPE ) + CALL wrf_dm_bcast_real ( SATDW , NSLTYPE ) + CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE ) + CALL wrf_dm_bcast_real ( QTZ , NSLTYPE ) + + IF(LUMATCH.EQ.0)THEN + CALL wrf_message( 'SOIl TEXTURE IN INPUT FILE DOES NOT ' ) + CALL wrf_message( 'MATCH SOILPARM TABLE' ) + CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' ) + ENDIF + +! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! + IF ( wrf_dm_on_monitor() ) THEN + OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. OPEN_OK ) THEN + WRITE(message,FMT='(A)') & + 'module_sf_noahlsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF + + READ (19,*) + READ (19,*) + READ (19,*) NUM_SLOPE + + SLPCATS=NUM_SLOPE + + DO LC=1,SLPCATS + READ (19,*)SLOPE_DATA(LC) + ENDDO + + READ (19,*) + READ (19,*)SBETA_DATA + READ (19,*) + READ (19,*)FXEXP_DATA + READ (19,*) + READ (19,*)CSOIL_DATA + READ (19,*) + READ (19,*)SALP_DATA + READ (19,*) + READ (19,*)REFDK_DATA + READ (19,*) + READ (19,*)REFKDT_DATA + READ (19,*) + READ (19,*)FRZK_DATA + READ (19,*) + READ (19,*)ZBOT_DATA + READ (19,*) + READ (19,*)CZIL_DATA + READ (19,*) + READ (19,*)SMLOW_DATA + READ (19,*) + READ (19,*)SMHIGH_DATA + CLOSE (19) + ENDIF + + CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 ) + CALL wrf_dm_bcast_integer ( SLPCATS , 1 ) + CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE ) + CALL wrf_dm_bcast_real ( SBETA_DATA , 1 ) + CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 ) + CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 ) + CALL wrf_dm_bcast_real ( SALP_DATA , 1 ) + CALL wrf_dm_bcast_real ( REFDK_DATA , 1 ) + CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 ) + CALL wrf_dm_bcast_real ( FRZK_DATA , 1 ) + CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 ) + CALL wrf_dm_bcast_real ( CZIL_DATA , 1 ) + CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 ) + CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 ) + + +!----------------------------------------------------------------- + END SUBROUTINE SOIL_VEG_GEN_PARM +!----------------------------------------------------------------- + + SUBROUTINE SFLX (ICE,DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LLANDUSE, LSOIL, & !CL + LWDN,SOLDN,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, & !F + COSZ,PRCPRAIN, SOLARDIRECT, & !F + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHDMIN,SHDMAX, & !I + ALB, SNOALB,TBOT, Z0BRD, Z0, EMISSI, & !S + CMC,T1,STC,SMC,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM, & !H +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1, & !D + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) !P +! ---------------------------------------------------------------------- +! SUBROUTINE SFLX - VERSION 3.X - October 2002 +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE SOIL MOISTURE, SOIL +! ICE, SOIL TEMPERATURE, SKIN TEMPERATURE, SNOWPACK WATER CONTENT, +! SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY BALANCE AND SURFACE +! WATER BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD +! RADIATION AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! L LOGICAL +! CL 4-string character bearing logical meaning +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! P Parameters +! Msic Miscellaneous terms passed from gridded driver +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! ICE SEA-ICE FLAG (=1: SEA-ICE, =0: LAND) +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) +! ---------------------------------------------------------------------- +! 2. LOGICAL: +! ---------------------------------------------------------------------- +! LCH Exchange coefficient (Ch) calculation flag (false: using +! ch-routine SFCDIF; true: Ch is brought in) +! LOCAL Flag for local-site simulation (where there is no +! maps for albedo, veg fraction, and roughness +! true: all LSM parameters (inluding albedo, veg fraction and +! roughness length) will be defined by three tables +! LLANDUSE (=USGS, using USGS landuse classification) +! LSOIL (=STAS, using FAO/STATSGO soil texture classification) +! ---------------------------------------------------------------------- +! 3. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLDN SOLAR DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET SOLAR) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR TEMPERATURE (K) AT HEIGHT 2M ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! COSZ Solar zenith angle (not used for now) +! PRCPRAIN Liquid-precipitation rate (KG M-2 S-1) (not used) +! SOLARDIRECT Direct component of downward solar radiation (W M-2) (not used) +! ---------------------------------------------------------------------- +! 4. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! SFCSPD WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND +! Q2SAT SAT MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 5. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! VEGTYP VEGETATION TYPE (INTEGER INDEX) +! SOILTYP SOIL TYPE (INTEGER INDEX) +! SLOPETYP CLASS OF SFC SLOPE (INTEGER INDEX) +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! (FRACTION= 0.0-1.0) <= SHDFAC +! PTU PHOTO THERMAL UNIT (PLANT PHENOLOGY FOR ANNUALS/CROPS) +! (NOT YET USED, BUT PASSED TO REDPRM FOR FUTURE USE IN +! VEG PARMS) +! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN +! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF +! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT +! INCLUDE DIURNAL SUN ANGLE EFFECT) +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! Z0BRD Background fixed roughness length (M) +! Z0 Time varying roughness length (M) as function of snow depth +! ---------------------------------------------------------------------- +! 6. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! CMC CANOPY MOISTURE CONTENT (M) +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SMC(NSOIL) TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! SH2O(NSOIL) UNFROZEN SOIL MOISTURE CONTENT (VOLUMETRIC FRACTION) +! NOTE: FROZEN SOIL MOISTURE = SMC - SH2O +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) +! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR +! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) WHEN SNEQV>0 +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! CM SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM (M S-1); NOTE: +! CM IS TECHNICALLY A CONDUCTANCE SINCE IT HAS BEEN +! MULTIPLIED BY WIND SPEED. +! ---------------------------------------------------------------------- +! 7. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION +! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM +! SURFACE) +! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1 +! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SURFACE) +! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +! ---------------------------------------------------------------------- +! EC CANOPY WATER EVAPORATION (W m-2) +! EDIR DIRECT SOIL EVAPORATION (W m-2) +! ET(NSOIL) PLANT TRANSPIRATION FROM A PARTICULAR ROOT (SOIL) LAYER +! (W m-2) +! ETT TOTAL PLANT TRANSPIRATION (W m-2) +! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK +! (W m-2) +! DRIP THROUGH-FALL OF PRECIP AND/OR DEW IN EXCESS OF CANOPY +! WATER-HOLDING CAPACITY (M) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! BETA RATIO OF ACTUAL/POTENTIAL EVAP (DIMENSIONLESS) +! ETP POTENTIAL EVAPORATION (W m-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! RUNOFF2 SUBSURFACE RUNOFF (M S-1), DRAINAGE OUT BOTTOM OF LAST +! SOIL LAYER (BASEFLOW) +! RUNOFF3 NUMERICAL TRUNCTATION IN EXCESS OF POROSITY (SMCMAX) +! FOR A GIVEN SOIL LAYER AT THE END OF A TIME STEP (M S-1). +! Note: the above RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3 +! ---------------------------------------------------------------------- +! RC CANOPY RESISTANCE (S M-1) +! PC PLANT COEFFICIENT (UNITLESS FRACTION, 0-1) WHERE PC*ETP +! = ACTUAL TRANSP +! XLAI LEAF AREA INDEX (DIMENSIONLESS) +! RSMIN MINIMUM CANOPY RESISTANCE (S M-1) +! RCS INCOMING SOLAR RC FACTOR (DIMENSIONLESS) +! RCT AIR TEMPERATURE RC FACTOR (DIMENSIONLESS) +! RCQ ATMOS VAPOR PRESSURE DEFICIT RC FACTOR (DIMENSIONLESS) +! RCSOIL SOIL MOISTURE RC FACTOR (DIMENSIONLESS) +! ---------------------------------------------------------------------- +! 8. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! SOILW AVAILABLE SOIL MOISTURE IN ROOT ZONE (UNITLESS FRACTION +! BETWEEN SMCWLT AND SMCMAX) +! SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) +! Q1 Effective mixing ratio at surface (kg kg-1), used for +! diagnosing the mixing ratio at 2 meter for coupled model +! ---------------------------------------------------------------------- +! 9. PARAMETERS (P): +! ---------------------------------------------------------------------- +! SMCWLT WILTING POINT (VOLUMETRIC) +! SMCDRY DRY SOIL MOISTURE THRESHOLD WHERE DIRECT EVAP FRM TOP +! LAYER ENDS (VOLUMETRIC) +! SMCREF SOIL MOISTURE THRESHOLD WHERE TRANSPIRATION BEGINS TO +! STRESS (VOLUMETRIC) +! SMCMAX POROSITY, I.E. SATURATED VALUE OF SOIL MOISTURE +! (VOLUMETRIC) +! NROOT NUMBER OF ROOT LAYERS, A FUNCTION OF VEG TYPE, DETERMINED +! IN SUBROUTINE REDPRM. +! ---------------------------------------------------------------------- + + + IMPLICIT NONE +! ---------------------------------------------------------------------- + +! DECLARATIONS - LOGICAL AND CHARACTERS +! ---------------------------------------------------------------------- + LOGICAL, INTENT(IN):: LOCAL + LOGICAL :: FRZGRA, SNOWNG + CHARACTER (LEN=4), INTENT(IN):: LLANDUSE, LSOIL + +! ---------------------------------------------------------------------- +! DECLARATIONS - INTEGER +! ---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP + INTEGER,INTENT(OUT):: NROOT + INTEGER KZ, K, iout + +! ---------------------------------------------------------------------- +! DECLARATIONS - REAL +! ---------------------------------------------------------------------- + REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, & + Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, & + SOLDN,TBOT,TH2,ZLVL, & + EMISSI + REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,ALBEDO,CH,CM, & + CMC,SNEQV,SNCOVR,SNOWH,T1,XLAI,SHDFAC,Z0BRD,ALB + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: ET + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O, SMC, STC + REAL,DIMENSION(1:NSOIL):: RTDIS, ZSOIL + + REAL,INTENT(OUT) :: ETA_KINEMATIC,BETA,DEW,DRIP,EC,EDIR,ESNOW,ETA, & + ETP,FLX1,FLX2,FLX3,SHEAT,PC,RUNOFF1,RUNOFF2, & + RUNOFF3,RC,RSMIN,RCQ,RCS,RCSOIL,RCT,SSOIL, & + SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT, SOILM, & + SOILW,FDOWN,Q1 + REAL :: BEXP,CFACTR,CMCMAX,CSOIL,CZIL,DF1,DF1H,DF1A,DKSAT,DWSAT, & + DSOIL,DTOT,ETT,FRCSNO,FRCSOI,EPSCA,F1,FXEXP,FRZX,HS, & + KDT,LVH2O,PRCP1,PSISAT,QUARTZ,R,RCH,REFKDT,RR,RGL, & + RSMAX, & + RSNOW,SNDENS,SNCOND,SBETA,SN_NEW,SLOPE,SNUP,SALP,SOILWM, & + SOILWW,T1V,T24,T2V,TH2V,TOPT,TFREEZ,TSNOW,ZBOT,Z0,PRCPF, & + ETNS,PTU,LSUBS + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + PARAMETER (TFREEZ = 273.15) + PARAMETER (LVH2O = 2.501E+6) + PARAMETER (LSUBS = 2.83E+6) + PARAMETER (R = 287.04) +! ---------------------------------------------------------------------- +! INITIALIZATION +! ---------------------------------------------------------------------- + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + SNOMLT = 0.0 + +! ---------------------------------------------------------------------- +! THE VARIABLE "ICE" IS A FLAG DENOTING SEA-ICE CASE +! ---------------------------------------------------------------------- +! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO 3 METERS +! ---------------------------------------------------------------------- + IF (ICE == 1) THEN + DO KZ = 1,NSOIL + ZSOIL (KZ) = -3.* FLOAT (KZ)/ FLOAT (NSOIL) + END DO + +! ---------------------------------------------------------------------- +! CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF +! EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW +! GROUND) +! ---------------------------------------------------------------------- + ELSE + ZSOIL (1) = - SLDPTH (1) + DO KZ = 2,NSOIL + ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) + END DO +! ---------------------------------------------------------------------- +! NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING +! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. +! ---------------------------------------------------------------------- + CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX,TOPT, & + REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, & + PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, & + SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, & + RTDIS,SLDPTH,ZSOIL,NROOT,NSOIL,Z0BRD,CZIL,XLAI, & + CSOIL,ALB,PTU,LLANDUSE,LSOIL,LOCAL) + END IF + +!urban change + IF(VEGTYP==1)THEN + SHDFAC=0.05 + RSMIN=400.0 + SMCMAX = 0.45 + SMCREF = 0.42 + SMCWLT = 0.40 + ENDIF + +! ---------------------------------------------------------------------- +! INITIALIZE PRECIPITATION LOGICALS. +! ---------------------------------------------------------------------- + SNOWNG = .FALSE. + FRZGRA = .FALSE. + +! ---------------------------------------------------------------------- +! IF SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP +! ---------------------------------------------------------------------- + IF (ICE == 1) THEN + SNEQV = 0.01 + SNOWH = 0.05 +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION +! SUBROUTINE) +! ---------------------------------------------------------------------- + END IF + IF (SNEQV == 0.0) THEN + SNDENS = 0.0 + SNOWH = 0.0 + SNCOND = 1.0 + ELSE + SNDENS = SNEQV / SNOWH + IF(SNDENS > 1.0) THEN + CALL wrf_error_fatal ( 'Physical snow depth is less than snow water equiv.' ) + ENDIF + CALL CSNOW (SNCOND,SNDENS) + END IF +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + IF (PRCP > 0.0) THEN + IF (SFCTMP <= TFREEZ) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 <= TFREEZ) FRZGRA = .TRUE. + END IF + END IF +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES +! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. +! ---------------------------------------------------------------------- + IF ( (SNOWNG) .OR. (FRZGRA) ) THEN + SN_NEW = PRCP * DT * 0.001 +! PRCP1 = 0.0 +! change name of PRCP1 to PRCPF + SNEQV = SNEQV + SN_NEW + PRCPF = 0.0 + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) + CALL CSNOW (SNCOND,SNDENS) + +! ---------------------------------------------------------------------- +! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT +! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL (ALONG WITH +! ANY CANOPY "DRIP" ADDED TO THIS LATER) +! ---------------------------------------------------------------------- +! PRCP1 = PRCP + ELSE +! change name of PRCP1 to PRCPF + + PRCPF = PRCP + END IF +! ---------------------------------------------------------------------- +! DETERMINE SNOWCOVER AND ALBEDO OVER LAND. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO. +! ---------------------------------------------------------------------- + IF (ICE == 0) THEN + IF (SNEQV == 0.0) THEN + SNCOVR = 0.0 + ALBEDO = ALB + ELSE +! ---------------------------------------------------------------------- +! DETERMINE SNOW FRACTIONAL COVERAGE. +! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. +! ---------------------------------------------------------------------- + CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) + CALL ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) + END IF +! ---------------------------------------------------------------------- +! SNOW COVER, ALBEDO OVER SEA-ICE +! ---------------------------------------------------------------------- + ELSE + SNCOVR = 1.0 + ALBEDO = 0.60 + END IF +! ---------------------------------------------------------------------- +! THERMAL CONDUCTIVITY FOR SEA-ICE CASE +! ---------------------------------------------------------------------- + IF (ICE == 1) THEN + DF1 = 2.2 + ELSE +! ---------------------------------------------------------------------- +! NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES +! CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE +! LATTER FOLLOWS THAT ON PAGES 148-149 FROM "HEAT TRANSFER IN +! COLD CLIMATES", BY V. J. LUNARDINI (PUBLISHED IN 1981 +! BY VAN NOSTRAND REINHOLD CO.) I.E. TREATMENT OF TWO CONTIGUOUS +! "PLANE PARALLEL" MEDIUMS (NAMELY HERE THE FIRST SOIL LAYER +! AND THE SNOWPACK LAYER, IF ANY). THIS DIFFUSIVITY TREATMENT +! BEHAVES WELL FOR BOTH ZERO AND NONZERO SNOWPACK, INCLUDING THE +! LIMIT OF VERY THIN SNOWPACK. THIS TREATMENT ALSO ELIMINATES +! THE NEED TO IMPOSE AN ARBITRARY UPPER BOUND ON SUBSURFACE +! HEAT FLUX WHEN THE SNOWPACK BECOMES EXTREMELY THIN. +! ---------------------------------------------------------------------- +! FIRST CALCULATE THERMAL DIFFUSIVITY OF TOP SOIL LAYER, USING +! BOTH THE FROZEN AND LIQUID SOIL MOISTURE, FOLLOWING THE +! SOIL THERMAL DIFFUSIVITY FUNCTION OF PETERS-LIDARD ET AL. +! (1998,JAS, VOL 55, 1209-1224), WHICH REQUIRES THE SPECIFYING +! THE QUARTZ CONTENT OF THE GIVEN SOIL CLASS (SEE ROUTINE REDPRM) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! NEXT ADD SUBSURFACE HEAT FLUX REDUCTION EFFECT FROM THE +! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF +! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) +! ---------------------------------------------------------------------- + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + +!urban change + IF (VEGTYP==1) DF1=3.24 + + DF1 = DF1 * EXP (SBETA * SHDFAC) +! ---------------------------------------------------------------------- +! FINALLY "PLANE PARALLEL" SNOWPACK EFFECT FOLLOWING +! V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS +! COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER +! ---------------------------------------------------------------------- + END IF + + DSOIL = - (0.5 * ZSOIL (1)) + IF (SNEQV == 0.) THEN + SSOIL = DF1 * (T1- STC (1) ) / DSOIL + ELSE + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH / DTOT + +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + FRCSOI = DSOIL / DTOT +! 2. ARITHMETIC MEAN (PARALLEL FLOW) +! DF1 = FRCSNO*SNCOND + FRCSOI*DF1 + DF1H = (SNCOND * DF1)/ (FRCSOI * SNCOND+ FRCSNO * DF1) + +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) +! TEST - MBEK, 10 Jan 2002 +! weigh DF by snow fraction +! DF1 = DF1H*SNCOVR + DF1A*(1.0-SNCOVR) +! DF1 = DF1H*SNCOVR + DF1*(1.0-SNCOVR) + DF1A = FRCSNO * SNCOND+ FRCSOI * DF1 + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + DF1 = DF1A * SNCOVR + DF1* (1.0- SNCOVR) + SSOIL = DF1 * (T1- STC (1) ) / DTOT + END IF +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + IF (SNCOVR > 0. ) THEN + CALL SNOWZ0 (SNCOVR,Z0,Z0BRD) + ELSE + Z0=Z0BRD + END IF +! ---------------------------------------------------------------------- +! NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR +! HEAT AND MOISTURE. + +! NOTE !!! +! DO NOT CALL SFCDIF UNTIL AFTER ABOVE CALL TO REDPRM, IN CASE +! ALTERNATIVE VALUES OF ROUGHNESS LENGTH (Z0) AND ZILINTINKEVICH COEF +! (CZIL) ARE SET THERE VIA NAMELIST I/O. + +! NOTE !!! +! ROUTINE SFCDIF RETURNS A CH THAT REPRESENTS THE WIND SPD TIMES THE +! "ORIGINAL" NONDIMENSIONAL "Ch" TYPICAL IN LITERATURE. HENCE THE CH +! RETURNED FROM SFCDIF HAS UNITS OF M/S. THE IMPORTANT COMPANION +! COEFFICIENT OF CH, CARRIED HERE AS "RCH", IS THE CH FROM SFCDIF TIMES +! AIR DENSITY AND PARAMETER "CP". "RCH" IS COMPUTED IN "CALL PENMAN". +! RCH RATHER THAN CH IS THE COEFF USUALLY INVOKED LATER IN EQNS. + +! NOTE !!! +! ---------------------------------------------------------------------- +! SFCDIF ALSO RETURNS THE SURFACE EXCHANGE COEFFICIENT FOR MOMENTUM, CM, +! ALSO KNOWN AS THE SURFACE DRAGE COEFFICIENT. Needed as a state variable +! for iterative/implicit solution of CH in SFCDIF +! ---------------------------------------------------------------------- +! IF(.NOT.LCH) THEN +! T1V = T1 * (1.0+ 0.61 * Q2) +! TH2V = TH2 * (1.0+ 0.61 * Q2) +! CALL SFCDIF_off (ZLVL,Z0,T1V,TH2V,SFCSPD,CZIL,CM,CH) +! ENDIF + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER +! CALCULATIONS. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- + FDOWN = SOLDN * (1.0- ALBEDO) + LWDN +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! PENMAN. + T2V = SFCTMP * (1.0+ 0.61 * Q2 ) + + iout=0 + if(iout.eq.1) then + print*,'before penman' + print*,' SFCTMP',SFCTMP,'SFCPRS',SFCPRS,'CH',CH,'T2V',T2V, & + 'TH2',TH2,'PRCP',PRCP,'FDOWN',FDOWN,'T24',T24,'SSOIL',SSOIL, & + 'Q2',Q2,'Q2SAT',Q2SAT,'ETP',ETP,'RCH',RCH, & + 'EPSCA',EPSCA,'RR',RR ,'SNOWNG',SNOWNG,'FRZGRA',FRZGRA, & + 'DQSDT2',DQSDT2,'FLX2',FLX2,'SNOWH',SNOWH,'SNEQV',SNEQV, & + ' DSOIL',DSOIL,' FRCSNO',FRCSNO,' SNCOVR',SNCOVR,' DTOT',DTOT, & + ' ZSOIL (1)',ZSOIL(1),' DF1',DF1,'T1',T1,' STC1',STC(1), & + 'ALBEDO',ALBEDO,'SMC',SMC,'STC',STC,'SH2O',SH2O + endif + + CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + DQSDT2,FLX2,EMISSI) + +! ---------------------------------------------------------------------- +! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC +! IF NONZERO GREENNESS FRACTION +! ---------------------------------------------------------------------- + +! print*,'after penman ETP',ETP +! ---------------------------------------------------------------------- +! FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED +! BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW +! ---------------------------------------------------------------------- + IF (SHDFAC > 0.) THEN + CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, & + SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + TOPT,RSMAX,RGL,HS,XLAI, & + RCS,RCT,RCQ,RCSOIL,EMISSI) + END IF +! ---------------------------------------------------------------------- +! NOW DECIDE MAJOR PATHWAY BRANCH TO TAKE DEPENDING ON WHETHER SNOWPACK +! EXISTS OR NOT: +! ---------------------------------------------------------------------- + ESNOW = 0.0 + IF (SNEQV == 0.0) THEN + CALL NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SHDFAC, & + SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, & + SSOIL, & + STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, & + DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP) + ETA_KINEMATIC = ETA + ETA = ETA * LVH2O + ETP = ETP*LVH2O +! BETA = ETA/ETP + ELSE + CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SBETA,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA, & + SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,SNEQV,SNDENS,& + SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT, & + ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI, & + VEGTYP) + ETA_KINEMATIC = ESNOW + ETNS + ESNOW = ESNOW * LSUBS +! ETA = ESNOW * LSUBS + ETNS * LVH2O + ETA = ESNOW + ETNS * LVH2O + ETP = ETP*LSUBS +! ETP = ETP* ( (SNCOVR*LSUBS+(1.-SNCOVR)*LVH2O ) +! BETA = ETA/ETP + END IF + +! Calculate effective mixing ratio at grnd level (skin) +! +! Q1=Q2+ETA*CP/RCH + Q1=Q2+ETA_KINEMATIC*CP/RCH +! +! ---------------------------------------------------------------------- +! PREPARE SENSIBLE HEAT (H) FOR RETURN TO PARENT MODEL +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CONVERT UNITS AND/OR SIGN OF TOTAL EVAP (ETA), POTENTIAL EVAP (ETP), +! SUBSURFACE HEAT FLUX (S), AND RUNOFFS FOR WHAT PARENT MODEL EXPECTS +! CONVERT ETA FROM KG M-2 S-1 TO W M-2 +! ---------------------------------------------------------------------- +!ek ETA = ETA*LVH2O + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + +! ---------------------------------------------------------------------- +! CONVERT OTHER EVAP TERMS FROM M S-1 TO KG M-2 S-1, THEN TO W M-2 +! ---------------------------------------------------------------------- +! EDIR = EDIR*1000. +! EC = EC*1000. +! DO K = 1,NSOIL +! ET(K) = ET(K)*1000. +! END DO +! ETT = ETT*1000. + +! ETP = ETP * LVH2O + EC = EC * LVH2O + EDIR = EDIR * LVH2O + DO K = 1,NSOIL + ET (K) = ET (K)* LVH2O + END DO + ETT = ETT * LVH2O + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- +! ESNOW = ESNOW * LVH2O + +! ---------------------------------------------------------------------- +! CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1 +! AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW +! ---------------------------------------------------------------------- + SSOIL = -1.0* SSOIL + RUNOFF3 = RUNOFF3/ DT + +! ---------------------------------------------------------------------- +! TOTAL COLUMN SOIL MOISTURE IN METERS (SOILM) AND ROOT-ZONE +! SOIL MOISTURE AVAILABILITY (FRACTION) RELATIVE TO POROSITY/SATURATION +! ---------------------------------------------------------------------- + RUNOFF2 = RUNOFF2+ RUNOFF3 + IF (ICE == 0) THEN + SOILM = -1.0* SMC (1)* ZSOIL (1) + DO K = 2,NSOIL + SOILM = SOILM + SMC (K)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + SOILWM = -1.0* (SMCMAX - SMCWLT)* ZSOIL (1) + SOILWW = -1.0* (SMC (1) - SMCWLT)* ZSOIL (1) + + IF (NROOT >= 2) THEN + DO K = 2,NROOT + SOILWM = SOILWM + (SMCMAX - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + SOILWW = SOILWW + (SMC(K) - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + END IF + IF (SOILWM .LT. 1.E-6) THEN + SOILWM = 0.0 + SOILW = 0.0 + SOILM = 0.0 + ELSE + SOILW = SOILWW / SOILWM + END IF + ELSE + SOILWM = 0.0 + SOILW = 0.0 + SOILM = 0.0 + END IF + +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX +! ---------------------------------------------------------------------- + + SUBROUTINE ALCALC (ALB,SNOALB,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO) + +! ---------------------------------------------------------------------- +! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) +! ALB SNOWFREE ALBEDO +! SNOALB MAXIMUM (DEEP) SNOW ALBEDO +! SHDFAC AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SHDMIN MINIMUM AREAL FRACTIONAL COVERAGE OF GREEN VEGETATION +! SNCOVR FRACTIONAL SNOW COVER +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT +! TSNOW SNOW SURFACE TEMPERATURE (K) +! ---------------------------------------------------------------------- + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, +! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM +! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA +! (1985, JCAM, VOL 24, 402-411) +! ---------------------------------------------------------------------- + REAL, INTENT(IN) :: ALB, SNOALB, SHDFAC, SHDMIN, SNCOVR, TSNOW + REAL, INTENT(OUT) :: ALBEDO + ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB) + +! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) +! IF (TSNOW.LE.263.16) THEN +! ALBEDO=SNOALB +! ELSE +! IF (TSNOW.LT.273.16) THEN +! TM=0.1*(TSNOW-263.16) +! ALBEDO=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) +! ELSE +! ALBEDO=0.67 +! ENDIF +! ENDIF + +! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) +! IF (TSNOW.LT.273.16) THEN +! ALBEDO=SNOALB-0.008*DT/86400 +! ELSE +! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 +! ENDIF + + IF (ALBEDO > SNOALB) ALBEDO = SNOALB + +! ---------------------------------------------------------------------- + END SUBROUTINE ALCALC +! ---------------------------------------------------------------------- + + SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, & + SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & + TOPT,RSMAX,RGL,HS,XLAI, & + RCS,RCT,RCQ,RCSOIL,EMISSI) + +! ---------------------------------------------------------------------- +! SUBROUTINE CANRES +! ---------------------------------------------------------------------- +! CALCULATE CANOPY RESISTANCE WHICH DEPENDS ON INCOMING SOLAR RADIATION, +! AIR TEMPERATURE, ATMOSPHERIC WATER VAPOR PRESSURE DEFICIT AT THE +! LOWEST MODEL LEVEL, AND SOIL MOISTURE (PREFERABLY UNFROZEN SOIL +! MOISTURE RATHER THAN TOTAL) +! ---------------------------------------------------------------------- +! SOURCE: JARVIS (1976), NOILHAN AND PLANTON (1989, MWR), JACQUEMIN AND +! NOILHAN (1990, BLM) +! SEE ALSO: CHEN ET AL (1996, JGR, VOL 101(D3), 7251-7268), EQNS 12-14 +! AND TABLE 2 OF SEC. 3.1.2 +! ---------------------------------------------------------------------- +! INPUT: +! SOLAR INCOMING SOLAR RADIATION +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! SFCTMP AIR TEMPERATURE AT 1ST LEVEL ABOVE GROUND +! Q2 AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! Q2SAT SATURATION AIR HUMIDITY AT 1ST LEVEL ABOVE GROUND +! DQSDT2 SLOPE OF SATURATION HUMIDITY FUNCTION WRT TEMP +! SFCPRS SURFACE PRESSURE +! SMC VOLUMETRIC SOIL MOISTURE +! ZSOIL SOIL DEPTH (NEGATIVE SIGN, AS IT IS BELOW GROUND) +! NSOIL NO. OF SOIL LAYERS +! NROOT NO. OF SOIL LAYERS IN ROOT ZONE (1.LE.NROOT.LE.NSOIL) +! XLAI LEAF AREA INDEX +! SMCWLT WILTING POINT +! SMCREF REFERENCE SOIL MOISTURE (WHERE SOIL WATER DEFICIT STRESS +! SETS IN) +! RSMIN, RSMAX, TOPT, RGL, HS ARE CANOPY STRESS PARAMETERS SET IN +! SURBOUTINE REDPRM +! OUTPUT: +! PC PLANT COEFFICIENT +! RC CANOPY RESISTANCE +! ---------------------------------------------------------------------- + + IMPLICIT NONE + INTEGER, INTENT(IN) :: NROOT,NSOIL + INTEGER K + REAL, INTENT(IN) :: CH,DQSDT2,HS,Q2,Q2SAT,RSMIN,RGL,RSMAX, & + SFCPRS,SFCTMP,SMCREF,SMCWLT, SOLAR,TOPT,XLAI, & + EMISSI + REAL,DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, INTENT(OUT):: PC,RC,RCQ,RCS,RCSOIL,RCT + REAL :: DELTA,FF,GX,P,RR + REAL, DIMENSION(1:NSOIL) :: PART + REAL, PARAMETER :: SLV = 2.501000E6 + + +! ---------------------------------------------------------------------- +! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. +! ---------------------------------------------------------------------- + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + RCSOIL = 0.0 + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION +! ---------------------------------------------------------------------- + RC = 0.0 + FF = 0.55*2.0* SOLAR / (RGL * XLAI) + RCS = (FF + RSMIN / RSMAX) / (1.0+ FF) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND +! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). +! ---------------------------------------------------------------------- + RCS = MAX (RCS,0.0001) + RCT = 1.0- 0.0016* ( (TOPT - SFCTMP)**2.0) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. +! RCQ EXPRESSION FROM SSIB +! ---------------------------------------------------------------------- + RCT = MAX (RCT,0.0001) + RCQ = 1.0/ (1.0+ HS * (Q2SAT - Q2)) + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. +! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. +! ---------------------------------------------------------------------- + RCQ = MAX (RCQ,0.01) + GX = (SMC (1) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX > 1.) GX = 1. + IF (GX < 0.) GX = 0. + +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(1) = RTDIS(1) * GX +! ---------------------------------------------------------------------- + PART (1) = (ZSOIL (1)/ ZSOIL (NROOT)) * GX + DO K = 2,NROOT + GX = (SMC (K) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX > 1.) GX = 1. + IF (GX < 0.) GX = 0. +! ---------------------------------------------------------------------- +! USE SOIL DEPTH AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! USE ROOT DISTRIBUTION AS WEIGHTING FACTOR +! PART(K) = RTDIS(K) * GX +! ---------------------------------------------------------------------- + PART (K) = ( (ZSOIL (K) - ZSOIL (K -1))/ ZSOIL (NROOT)) * GX + END DO + DO K = 1,NROOT + RCSOIL = RCSOIL + PART (K) + END DO + +! ---------------------------------------------------------------------- +! DETERMINE CANOPY RESISTANCE DUE TO ALL FACTORS. CONVERT CANOPY +! RESISTANCE (RC) TO PLANT COEFFICIENT (PC) TO BE USED WITH POTENTIAL +! EVAP IN DETERMINING ACTUAL EVAP. PC IS DETERMINED BY: +! PC * LINERIZED PENMAN POTENTIAL EVAP = +! PENMAN-MONTEITH ACTUAL EVAPORATION (CONTAINING RC TERM). +! ---------------------------------------------------------------------- + RCSOIL = MAX (RCSOIL,0.0001) + + RC = RSMIN / (XLAI * RCS * RCT * RCQ * RCSOIL) +! RR = (4.* SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) + 1.0 + RR = (4.* EMISSI *SIGMA * RD / CP)* (SFCTMP **4.)/ (SFCPRS * CH) & + + 1.0 + + DELTA = (SLV / CP)* DQSDT2 + + PC = (RR + DELTA)/ (RR * (1. + RC * CH) + DELTA) + +! ---------------------------------------------------------------------- + END SUBROUTINE CANRES +! ---------------------------------------------------------------------- + + SUBROUTINE CSNOW (SNCOND,DSNOW) + +! ---------------------------------------------------------------------- +! SUBROUTINE CSNOW +! FUNCTION CSNOW +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: DSNOW + REAL, INTENT(OUT):: SNCOND + REAL :: C + REAL, PARAMETER :: UNIT = 0.11631 + +! ---------------------------------------------------------------------- +! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C = 0.328*10** (2.25* DSNOW) +! CSNOW=UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! SNCOND=0.0293*(1.+100.*DSNOW**2) +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! SNCOND=0.021+2.51*DSNOW**2 +! CSNOW=0.021+2.51*DSNOW**2 + + SNCOND = UNIT * C + +! ---------------------------------------------------------------------- + END SUBROUTINE CSNOW +! ---------------------------------------------------------------------- + + SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & + DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) + +! ---------------------------------------------------------------------- +! SUBROUTINE DEVAP +! FUNCTION DEVAP +! ---------------------------------------------------------------------- +! CALCULATE DIRECT SOIL EVAPORATION +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, & + SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT + REAL, INTENT(OUT):: EDIR + REAL :: FX, SRATIO + + +! ---------------------------------------------------------------------- +! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR +! WHEN FXEXP=1. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + +! ---------------------------------------------------------------------- +! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE +! ---------------------------------------------------------------------- + EDIR = FX * ( 1.0- SHDFAC ) * ETP1 + +! ---------------------------------------------------------------------- + END SUBROUTINE DEVAP +! ---------------------------------------------------------------------- + + SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR,EC,ET,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + +! ---------------------------------------------------------------------- +! SUBROUTINE EVAPO +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, NROOT + INTEGER :: I,K + REAL, INTENT(IN) :: BEXP, CFACTR,CMC,CMCMAX,DKSAT, & + DT,DWSAT,ETP1,FXEXP,PC,Q2,SFCTMP, & + SHDFAC,SMCDRY,SMCMAX,SMCREF,SMCWLT + REAL, INTENT(OUT) :: EC,EDIR,ETA1,ETT + REAL :: CMC2MS + REAL,DIMENSION(1:NSOIL), INTENT(IN) :: RTDIS, SMC, SH2O, ZSOIL + REAL,DIMENSION(1:NSOIL), INTENT(OUT) :: ET + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS +! GREATER THAN ZERO. +! ---------------------------------------------------------------------- + EDIR = 0. + EC = 0. + ETT = 0. + DO K = 1,NSOIL + ET (K) = 0. + END DO + +! print*,'SHDFAC',SHDFAC,'SMCMAX', SMCMAX,'BEXP',BEXP, +! & 'DKSAT',DKSAT,'DWSAT',DWSAT,'DRY',SMCDRY,'REF',SMCREF, +! & 'WLT',SMCWLT,'FXEX',FXEXP,'SMC',SMC +! ---------------------------------------------------------------------- +! RETRIEVE DIRECT EVAPORATION FROM SOIL SURFACE. CALL THIS FUNCTION +! ONLY IF VEG COVER NOT COMPLETE. +! FROZEN GROUND VERSION: SH2O STATES REPLACE SMC STATES. +! ---------------------------------------------------------------------- + IF (ETP1 > 0.0) THEN + IF (SHDFAC < 1.) THEN +! CALL DEVAP (EDIR,ETP1,SH2O (1),ZSOIL (1),SHDFAC,SMCMAX, + CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & + BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) + END IF +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION, +! AND ACCUMULATE IT FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + + IF (SHDFAC > 0.0) THEN + CALL TRANSP (ET,NSOIL,ETP1,SH2O,CMC,ZSOIL,SHDFAC,SMCWLT, & + CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT,RTDIS) + DO K = 1,NSOIL + ETT = ETT + ET ( K ) + END DO +! ---------------------------------------------------------------------- +! CALCULATE CANOPY EVAPORATION. +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR CMC=0.0. +! ---------------------------------------------------------------------- + IF (CMC > 0.0) THEN + EC = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 + ELSE + EC = 0.0 + END IF +! ---------------------------------------------------------------------- +! EC SHOULD BE LIMITED BY THE TOTAL AMOUNT OF AVAILABLE WATER ON THE +! CANOPY. -F.CHEN, 18-OCT-1994 +! ---------------------------------------------------------------------- + CMC2MS = CMC / DT + EC = MIN ( CMC2MS, EC ) + END IF + END IF +! ---------------------------------------------------------------------- +! TOTAL UP EVAP AND TRANSP TYPES TO OBTAIN ACTUAL EVAPOTRANSP +! ---------------------------------------------------------------------- + ETA1 = EDIR + ETT + EC + +! ---------------------------------------------------------------------- + END SUBROUTINE EVAPO +! ---------------------------------------------------------------------- + + SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) + +! ---------------------------------------------------------------------- +! SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF +! TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO +! SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL +! (1999, JGR, VOL 104(D16), 19569-19585). +! ---------------------------------------------------------------------- +! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON +! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN +! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT +! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH +! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, +! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE +! LIMIT OF FREEZING POINT TEMPERATURE T0. +! ---------------------------------------------------------------------- +! INPUT: + +! TKELV.........TEMPERATURE (Kelvin) +! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) +! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) +! SMCMAX........SATURATION SOIL MOISTURE CONTENT (FROM REDPRM) +! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) +! PSIS..........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) + +! OUTPUT: +! FRH2O.........SUPERCOOLED LIQUID WATER CONTENT +! FREE..........SUPERCOOLED LIQUID WATER CONTENT +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: BEXP,PSIS,SH2O,SMC,SMCMAX,TKELV + REAL, INTENT(OUT) :: FREE + REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK + INTEGER :: NLOG,KCOUNT +! PARAMETER(CK = 0.0) + REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, & + HLICE = 3.335E5, GS = 9.81,DICE = 920.0, & + DH2O = 1000.0, T0 = 273.15 + +! ---------------------------------------------------------------------- +! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) +! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS +! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. +! ---------------------------------------------------------------------- + BX = BEXP + +! ---------------------------------------------------------------------- +! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. +! ---------------------------------------------------------------------- + IF (BEXP > BLIM) BX = BLIM + NLOG = 0 + +! ---------------------------------------------------------------------- +! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC +! ---------------------------------------------------------------------- + KCOUNT = 0 +! FRH2O = SMC + IF (TKELV > (T0- 1.E-3)) THEN + FREE = SMC + ELSE + +! ---------------------------------------------------------------------- +! OPTION 1: ITERATED SOLUTION FOR NONZERO CK +! IN KOREN ET AL, JGR, 1999, EQN 17 +! ---------------------------------------------------------------------- +! INITIAL GUESS FOR SWL (frozen content) +! ---------------------------------------------------------------------- + IF (CK /= 0.0) THEN + SWL = SMC - SH2O +! ---------------------------------------------------------------------- +! KEEP WITHIN BOUNDS. +! ---------------------------------------------------------------------- + IF (SWL > (SMC -0.02)) SWL = SMC -0.02 + +! ---------------------------------------------------------------------- +! START OF ITERATIONS +! ---------------------------------------------------------------------- + IF (SWL < 0.) SWL = 0. + 1001 Continue + IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 + NLOG = NLOG +1 + DF = ALOG ( ( PSIS * GS / HLICE ) * ( ( 1. + CK * SWL )**2.) * & + ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - ( & + TKELV - T0)/ TKELV) + DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) + SWLK = SWL - DF / DENOM +! ---------------------------------------------------------------------- +! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. +! ---------------------------------------------------------------------- + IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02 + IF (SWLK < 0.) SWLK = 0. + +! ---------------------------------------------------------------------- +! MATHEMATICAL SOLUTION BOUNDS APPLIED. +! ---------------------------------------------------------------------- + DSWL = ABS (SWLK - SWL) + +! ---------------------------------------------------------------------- +! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) +! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. +! ---------------------------------------------------------------------- + SWL = SWLK + IF ( DSWL <= ERROR ) THEN + KCOUNT = KCOUNT +1 + END IF +! ---------------------------------------------------------------------- +! END OF ITERATIONS +! ---------------------------------------------------------------------- +! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. +! ---------------------------------------------------------------------- +! FRH2O = SMC - SWL + goto 1001 + 1002 continue + FREE = SMC - SWL + END IF +! ---------------------------------------------------------------------- +! END OPTION 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 +! IN KOREN ET AL., JGR, 1999, EQN 17 +! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION +! ---------------------------------------------------------------------- + IF (KCOUNT == 0) THEN + PRINT *,'Flerchinger USEd in NEW version. Iterations=',NLOG + FK = ( ( (HLICE / (GS * ( - PSIS)))* & + ( (TKELV - T0)/ TKELV))** ( -1/ BX))* SMCMAX +! FRH2O = MIN (FK, SMC) + IF (FK < 0.02) FK = 0.02 + FREE = MIN (FK, SMC) +! ---------------------------------------------------------------------- +! END OPTION 2 +! ---------------------------------------------------------------------- + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE FRH2O +! ---------------------------------------------------------------------- + + SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & + TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP) + +! ---------------------------------------------------------------------- +! SUBROUTINE HRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL :: ITAVG + INTEGER, INTENT(IN) :: NSOIL, VEGTYP + INTEGER :: I, K + + REAL, INTENT(IN) :: BEXP, CSOIL, DF1, DT,F1,PSISAT,QUARTZ, & + SMCMAX ,TBOT,YY,ZZ1, ZBOT + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL :: DDZ, DDZ2, DENOM, DF1N, DF1K, DTSDZ, & + DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, & + TBK1,TSNSR,TSURF,CSOIL_LOC + REAL, PARAMETER :: T0 = 273.15, CAIR = 1004.0, CICE = 2.106E6,& + CH2O = 4.2E6 + + +!urban + IF(VEGTYP==1) then + CSOIL_LOC=3.0E6 + ELSE + CSOIL_LOC=CSOIL + ENDIF + +! ---------------------------------------------------------------------- +! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. +! ---------------------------------------------------------------------- + ITAVG = .TRUE. +! ---------------------------------------------------------------------- +! BEGIN SECTION FOR TOP SOIL LAYER +! ---------------------------------------------------------------------- +! CALC THE HEAT CAPACITY OF THE TOP SOIL LAYER +! ---------------------------------------------------------------------- + HCPCT = SH2O (1)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC (1))& + * CAIR & + + ( SMC (1) - SH2O (1) )* CICE + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL +! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. USE THE TEMP +! GRADIENT AND SUBSFC HEAT FLUX TO CALC "RIGHT-HAND SIDE TENDENCY +! TERMS", OR "RHSTS", FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1 / (0.5 * ZSOIL (1) * ZSOIL (1)* HCPCT * & + ZZ1) + DTSDZ = (STC (1) - STC (2)) / ( -0.5 * ZSOIL (2)) + SSOIL = DF1 * (STC (1) - YY) / (0.5 * ZSOIL (1) * ZZ1) +! RHSTS(1) = (DF1 * DTSDZ - SSOIL) / (ZSOIL(1) * HCPCT) + DENOM = (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND +! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT APPLIED TO +! POTENTIAL SOIL FREEZING/THAWING IN ROUTINE SNKSRC. +! ---------------------------------------------------------------------- +! QTOT = SSOIL - DF1*DTSDZ + RHSTS (1) = (DF1 * DTSDZ - SSOIL) / DENOM + +! ---------------------------------------------------------------------- +! CALCULATE FROZEN WATER CONTENT IN 1ST SOIL LAYER. +! ---------------------------------------------------------------------- + QTOT = -1.0* RHSTS (1)* DENOM + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): +! SET TEMP "TSURF" AT TOP OF SOIL COLUMN (FOR USE IN FREEZING SOIL +! PHYSICS LATER IN FUNCTION SUBROUTINE SNKSRC). IF SNOWPACK CONTENT IS +! ZERO, THEN TSURF EXPRESSION BELOW GIVES TSURF = SKIN TEMP. IF +! SNOWPACK IS NONZERO (HENCE ARGUMENT ZZ1=1), THEN TSURF EXPRESSION +! BELOW YIELDS SOIL COLUMN TOP TEMPERATURE UNDER SNOWPACK. THEN +! CALCULATE TEMPERATURE AT BOTTOM INTERFACE OF 1ST SOIL LAYER FOR USE +! LATER IN FUNCTION SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- + SICE = SMC (1) - SH2O (1) + IF (ITAVG) THEN + TSURF = (YY + (ZZ1-1) * STC (1)) / ZZ1 +! ---------------------------------------------------------------------- +! IF FROZEN WATER PRESENT OR ANY OF LAYER-1 MID-POINT OR BOUNDING +! INTERFACE TEMPERATURES BELOW FREEZING, THEN CALL SNKSRC TO +! COMPUTE HEAT SOURCE/SINK (AND CHANGE IN FROZEN WATER CONTENT) +! DUE TO POSSIBLE SOIL WATER PHASE CHANGE +! ---------------------------------------------------------------------- + CALL TBND (STC (1),STC (2),ZSOIL,ZBOT,1,NSOIL,TBK) + IF ( (SICE > 0.) .OR. (STC (1) < T0) .OR. & + (TSURF < T0) .OR. (TBK < T0) ) THEN +! TSNSR = SNKSRC (TAVG,SMC(1),SH2O(1), + CALL TMPAVG (TAVG,TSURF,STC (1),TBK,ZSOIL,NSOIL,1) + CALL SNKSRC (TSNSR,TAVG,SMC (1),SH2O (1), & + ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) +! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) + RHSTS (1) = RHSTS (1) - TSNSR / DENOM + END IF + ELSE +! TSNSR = SNKSRC (STC(1),SMC(1),SH2O(1), + IF ( (SICE > 0.) .OR. (STC (1) < T0) ) THEN + CALL SNKSRC (TSNSR,STC (1),SMC (1),SH2O (1), & + ZSOIL,NSOIL,SMCMAX,PSISAT,BEXP,DT,1,QTOT) +! RHSTS(1) = RHSTS(1) - TSNSR / ( ZSOIL(1) * HCPCT ) + RHSTS (1) = RHSTS (1) - TSNSR / DENOM + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SECTION FOR TOP SOIL LAYER. +! ---------------------------------------------------------------------- + END IF + +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + + DDZ2 = 0.0 + DF1K = DF1 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) +! ---------------------------------------------------------------------- +! CALCULATE HEAT CAPACITY FOR THIS SOIL LAYER. +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + HCPCT = SH2O (K)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC ( & + K))* CAIR + ( SMC (K) - SH2O (K) )* CICE +! ---------------------------------------------------------------------- +! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY FOR THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + +!urban + IF(VEGTYP==1) DF1N = 3.24 + + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),STC (K +1),ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + + ELSE +! ---------------------------------------------------------------------- +! SPECIAL CASE OF BOTTOM SOIL LAYER: CALCULATE THERMAL DIFFUSIVITY FOR +! BOTTOM LAYER. +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. +! ---------------------------------------------------------------------- + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + + +!urban + IF(VEGTYP==1) DF1N = 3.24 + + DENOM = .5 * (ZSOIL (K -1) + ZSOIL (K)) - ZBOT + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO IF BOTTOM LAYER. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT) / DENOM + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = 0. + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. + END IF +! ---------------------------------------------------------------------- +! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM + QTOT = -1.0* DENOM * RHSTS (K) + + SICE = SMC (K) - SH2O (K) + IF (ITAVG) THEN + CALL TMPAVG (TAVG,TBK,STC (K),TBK1,ZSOIL,NSOIL,K) +! TSNSR = SNKSRC(TAVG,SMC(K),SH2O(K),ZSOIL,NSOIL, + IF ( (SICE > 0.) .OR. (STC (K) < T0) .OR. & + (TBK .lt. T0) .OR. (TBK1 .lt. T0) ) THEN + CALL SNKSRC (TSNSR,TAVG,SMC (K),SH2O (K),ZSOIL,NSOIL, & + SMCMAX,PSISAT,BEXP,DT,K,QTOT) + RHSTS (K) = RHSTS (K) - TSNSR / DENOM + END IF + ELSE +! TSNSR = SNKSRC(STC(K),SMC(K),SH2O(K),ZSOIL,NSOIL, + IF ( (SICE > 0.) .OR. (STC (K) < T0) ) THEN + CALL SNKSRC (TSNSR,STC (K),SMC (K),SH2O (K),ZSOIL,NSOIL, & + SMCMAX,PSISAT,BEXP,DT,K,QTOT) + RHSTS (K) = RHSTS (K) - TSNSR / DENOM + END IF + END IF + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI (K) = - DF1 * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + TBK = TBK1 + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRT +! ---------------------------------------------------------------------- + + SUBROUTINE HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE HRTICE +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE PACK. ALSO TO +! COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX +! OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, INTENT(IN) :: DF1,YY,ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: AI, BI,CI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: RHSTS + REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL, & + ZBOT,TBOT + REAL, PARAMETER :: HCPCT = 1.72396E+6 + +! ---------------------------------------------------------------------- +! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY, +! HCPCT = 1880.0*917.0. +! ---------------------------------------------------------------------- + DATA TBOT /271.16/ + +! ---------------------------------------------------------------------- +! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE +! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. +! ---------------------------------------------------------------------- +! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE +! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE +! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK +! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + ZBOT = ZSOIL (NSOIL) + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. +! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC +! RHSTS FOR THE TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * & + ZZ1) + DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) ) + SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 ) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT ) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + CI (K) = - DF1 * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. +! ---------------------------------------------------------------------- + ELSE + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) & + - ZBOT) + CI (K) = 0. +! ---------------------------------------------------------------------- +! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + END IF + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + RHSTS (K) = ( DF1 * DTSDZ2- DF1 * DTSDZ ) / DENOM + AI (K) = - DF1 * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRTICE +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT,SHDFAC, & + SBETA,Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,EMISSI, & + SSOIL, & + STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & + SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, & + DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP) + +! ---------------------------------------------------------------------- +! SUBROUTINE NOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES AND UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN NO SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ICE, NROOT,NSOIL,VEGTYP + INTEGER :: K + + REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DKSAT,DT,DWSAT, & + EPSCA,ETP,FDOWN,F1,FXEXP,FRZFACT,KDT,PC, & + PRCP,PSISAT,Q2,QUARTZ,RCH,RR,SBETA,SFCTMP,& + SHDFAC,SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, & + T24,TBOT,TH2,ZBOT,EMISSI + REAL, INTENT(INOUT) :: CMC,BETA,T1 + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR,ETA,ETT,FLX1,FLX3, & + RUNOFF1,RUNOFF2,RUNOFF3,SSOIL + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC + REAL, DIMENSION(1:NSOIL) :: ET1 + REAL :: EC1,EDIR1,ETT1,DF1,ETA1,ETP1,PRCP1,YY, & + YYNUM,ZZ1 + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! CONVERT ETP Fnd PRCP FROM KG M-2 S-1 TO M S-1 AND INITIALIZE DEW. +! ---------------------------------------------------------------------- + PRCP1 = PRCP * 0.001 + ETP1 = ETP * 0.001 + DEW = 0.0 +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- + EDIR = 0. + EDIR1 = 0. + EC1 = 0. + EC = 0. + DO K = 1,NSOIL + ET(K) = 0. + ET1(K) = 0. + END DO + ETT = 0. + ETT1 = 0. + + IF (ETP > 0.0) THEN + CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. +! ---------------------------------------------------------------------- + + ETA = ETA1 * 1000.0 + +! ---------------------------------------------------------------------- +! IF ETP < 0, ASSUME DEW FORMS (TRANSFORM ETP1 INTO DEW AND REINITIALIZE +! ETP1 TO ZERO). +! ---------------------------------------------------------------------- + ELSE + DEW = - ETP1 + +! ---------------------------------------------------------------------- +! CONVERT PRCP FROM 'KG M-2 S-1' TO 'M S-1' AND ADD DEW AMOUNT. +! ---------------------------------------------------------------------- + ETP1 = 0.0 + + PRCP1 = PRCP1+ DEW + CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP) + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. +! ---------------------------------------------------------------------- + ETA = ETA1 * 1000.0 + END IF + +! ---------------------------------------------------------------------- +! BASED ON ETP AND E VALUES, DETERMINE BETA +! ---------------------------------------------------------------------- + + IF ( ETP <= 0.0 ) THEN + BETA = 0.0 + IF ( ETP < 0.0 ) THEN + BETA = 1.0 + ETA = ETP + END IF + ELSE + BETA = ETA / ETP + END IF + +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION COMPONENTS 'M S-1' TO 'KG M-2 S-1'. +! ---------------------------------------------------------------------- + EDIR = EDIR1*1000. + EC = EC1*1000. + DO K = 1,NSOIL + ET(K) = ET1(K)*1000. + END DO + ETT = ETT1*1000. + +! ---------------------------------------------------------------------- +! GET SOIL THERMAL DIFFUXIVITY/CONDUCTIVITY FOR TOP SOIL LYR, +! CALC. ADJUSTED TOP LYR SOIL TEMP AND ADJUSTED SOIL FLUX, THEN +! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. +! ---------------------------------------------------------------------- + + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + +!urban + IF (VEGTYP==1) DF1=3.24 +! + +! ---------------------------------------------------------------------- +! VEGETATION GREENNESS FRACTION REDUCTION IN SUBSURFACE HEAT FLUX +! VIA REDUCTION FACTOR, WHICH IS CONVENIENT TO APPLY HERE TO THERMAL +! DIFFUSIVITY THAT IS LATER USED IN HRT TO COMPUTE SUB SFC HEAT FLUX +! (SEE ADDITIONAL COMMENTS ON VEG EFFECT SUB-SFC HEAT FLX IN +! ROUTINE SFLX) +! ---------------------------------------------------------------------- + DF1 = DF1 * EXP (SBETA * SHDFAC) +! ---------------------------------------------------------------------- +! COMPUTE INTERMEDIATE TERMS PASSED TO ROUTINE HRT (VIA ROUTINE +! SHFLX BELOW) FOR USE IN COMPUTING SUBSURFACE HEAT FLUX IN HRT +! ---------------------------------------------------------------------- +! YYNUM = FDOWN - SIGMA * T24 + YYNUM = FDOWN - EMISSI*SIGMA * T24 + YY = SFCTMP + (YYNUM / RCH + TH2- SFCTMP - BETA * EPSCA) / RR + + ZZ1 = DF1 / ( -0.5 * ZSOIL (1) * RCH * RR ) + 1.0 + +!urban + CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + QUARTZ,CSOIL,VEGTYP) + +! ---------------------------------------------------------------------- +! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE +! THEY ARE NOT USED HERE IN SNOPAC. FLX2 (FREEZING RAIN HEAT FLUX) WAS +! SIMILARLY INITIALIZED IN THE PENMAN ROUTINE. +! ---------------------------------------------------------------------- + FLX1 = 0.0 + FLX3 = 0.0 + +! ---------------------------------------------------------------------- + END SUBROUTINE NOPAC +! ---------------------------------------------------------------------- + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI) + +! ---------------------------------------------------------------------- +! SUBROUTINE PENMAN +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA + REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP, & + Q2, Q2SAT,SSOIL, SFCPRS, SFCTMP, & + T2V, TH2,EMISSI + REAL, INTENT(OUT) :: EPSCA,ETP,FLX2,RCH,RR,T24 + REAL :: A, DELTA, FNET,RAD,RHO + + REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6,CP = 1004.6 + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + FLX2 = 0.0 + DELTA = ELCP * DQSDT2 + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP +! RR = T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + RR = EMISSI*T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + RHO = SFCPRS / (RD * T2V) + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + RCH = RHO * CP * CH + IF (.NOT. SNOWNG) THEN + IF (PRCP > 0.0) RR = RR + CPH2O * PRCP / RCH + ELSE + RR = RR + CPICE * PRCP / RCH + END IF + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- +! FNET = FDOWN - SIGMA * T24- SSOIL + FNET = FDOWN - EMISSI*SIGMA * T24- SSOIL + IF (FRZGRA) THEN + FLX2 = - LSUBF * PRCP + FNET = FNET - FLX2 +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + END IF + RAD = FNET / RCH + TH2- SFCTMP + A = ELCP * (Q2SAT - Q2) + EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) + ETP = EPSCA * RCH / LSUBC + +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + + SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & + TOPT, & + REFKDT,KDT,SBETA, SHDFAC,RSMIN,RGL,HS,ZBOT,FRZX, & + PSISAT,SLOPE,SNUP,SALP,BEXP,DKSAT,DWSAT, & + SMCMAX,SMCWLT,SMCREF,SMCDRY,F1,QUARTZ,FXEXP, & + RTDIS,SLDPTH,ZSOIL, NROOT,NSOIL,Z0BRD,CZIL,LAI, & + CSOIL,ALBBRD,PTU,LLANDUSE,LSOIL,LOCAL) + + IMPLICIT NONE +! ---------------------------------------------------------------------- +! Internally set (default valuess) +! all soil and vegetation parameters required for the execusion oF +! the Noah lsm are defined in VEGPARM.TBL, SOILPARM.TB, and GENPARM.TBL. +! ---------------------------------------------------------------------- +! Vegetation parameters: +! ALBBRD: SFC background snow-free albedo +! CMXTBL: MAX CNPY Capacity +! Z0BRD: Background roughness length +! SHDFAC: Green vegetation fraction +! NROOT: Rooting depth +! RSMIN: Mimimum stomatal resistance +! RSMAX: Max. stomatal resistance +! RGL: Parameters used in radiation stress function +! HS: Parameter used in vapor pressure deficit functio +! TOPT: Optimum transpiration air temperature. +! CMCMAX: Maximum canopy water capacity +! CFACTR: Parameter used in the canopy inteception calculation +! SNUP: Threshold snow depth (in water equivalent m) that +! implies 100 percent snow cover +! LAI: Leaf area index +! +! ---------------------------------------------------------------------- +! Soil parameters: +! SMCMAX: MAX soil moisture content (porosity) +! SMCREF: Reference soil moisture (field capacity) +! SMCWLT: Wilting point soil moisture +! SMCWLT: Air dry soil moist content limits +! SSATPSI: SAT (saturation) soil potential +! DKSAT: SAT soil conductivity +! BEXP: B parameter +! SSATDW: SAT soil diffusivity +! F1: Soil thermal diffusivity/conductivity coef. +! QUARTZ: Soil quartz content +! Modified by F. Chen (12/22/97) to use the STATSGO soil map +! Modified By F. Chen (01/22/00) to include PLaya, Lava, and White San +! Modified By F. Chen (08/05/02) to include additional parameters for the Noah +! NOTE: SATDW = BB*SATDK*(SATPSI/MAXSMC) +! F11 = ALOG10(SATPSI) + BB*ALOG10(MAXSMC) + 2.0 +! REFSMC1=MAXSMC*(5.79E-9/SATDK)**(1/(2*BB+3)) 5.79E-9 m/s= 0.5 mm +! REFSMC=REFSMC1+1./3.(MAXSMC-REFSMC1) +! WLTSMC1=MAXSMC*(200./SATPSI)**(-1./BB) (Wetzel and Chang, 198 +! WLTSMC=WLTSMC1-0.5*WLTSMC1 +! Note: the values for playa is set for it to have a thermal conductivit +! as sand and to have a hydrulic conductivity as clay +! +! ---------------------------------------------------------------------- +! Class parameter 'SLOPETYP' was included to estimate linear reservoir +! coefficient 'SLOPE' to the baseflow runoff out of the bottom layer. +! lowest class (slopetyp=0) means highest slope parameter = 1. +! definition of slopetyp from 'zobler' slope type: +! slope class percent slope +! 1 0-8 +! 2 8-30 +! 3 > 30 +! 4 0-30 +! 5 0-8 & > 30 +! 6 8-30 & > 30 +! 7 0-8, 8-30, > 30 +! 9 GLACIAL ICE +! BLANK OCEAN/SEA +! SLOPE_DATA: linear reservoir coefficient +! SBETA_DATA: parameter used to caluculate vegetation effect on soil heat +! FXEXP_DAT: soil evaporation exponent used in DEVAP +! CSOIL_DATA: soil heat capacity [J M-3 K-1] +! SALP_DATA: shape parameter of distribution function of snow cover +! REFDK_DATA and REFKDT_DATA: parameters in the surface runoff parameteriz +! FRZK_DATA: frozen ground parameter +! ZBOT_DATA: depth[M] of lower boundary soil temperature +! CZIL_DATA: calculate roughness length of heat +! SMLOW_DATA and MHIGH_DATA: two soil moisture wilt, soil moisture referen +! parameters +! Set maximum number of soil-, veg-, and slopetyp in data statement. +! ---------------------------------------------------------------------- + INTEGER, PARAMETER :: MAX_SLOPETYP=30,MAX_SOILTYP=30,MAX_VEGTYP=30 + LOGICAL :: LOCAL + CHARACTER (LEN=4), INTENT(IN):: LLANDUSE, LSOIL + +! Veg parameters + INTEGER, INTENT(IN) :: VEGTYP + INTEGER, INTENT(OUT) :: NROOT + REAL, INTENT(OUT) :: HS,LAI,RSMIN,RGL,SHDFAC,SNUP,Z0BRD, & + CMCMAX,RSMAX,TOPT,ALBBRD +! Soil parameters + INTEGER, INTENT(IN) :: SOILTYP + REAL, INTENT(OUT) :: BEXP,DKSAT,DWSAT,F1,QUARTZ,SMCDRY, & + SMCMAX,SMCREF,SMCWLT,PSISAT +! General parameters + INTEGER, INTENT(IN) :: SLOPETYP,NSOIL + INTEGER :: I + + REAL, INTENT(OUT) :: SLOPE,CZIL,SBETA,FXEXP, & + CSOIL,SALP,FRZX,KDT,CFACTR, & + ZBOT,REFKDT,PTU + REAL,DIMENSION(1:NSOIL),INTENT(IN) :: SLDPTH,ZSOIL + REAL,DIMENSION(1:NSOIL),INTENT(OUT):: RTDIS + REAL :: FRZFACT,FRZK,REFDK + +! SAVE +! ---------------------------------------------------------------------- +! + IF (SOILTYP .gt. SLCATS) THEN + CALL wrf_error_fatal ( 'Warning: too many input soil types' ) + END IF + IF (VEGTYP .gt. LUCATS) THEN + CALL wrf_error_fatal ( 'Warning: too many input landuse types' ) + END IF + IF (SLOPETYP .gt. SLPCATS) THEN + CALL wrf_error_fatal ( 'Warning: too many input slope types' ) + END IF + +! ---------------------------------------------------------------------- +! SET-UP SOIL PARAMETERS +! ---------------------------------------------------------------------- + CSOIL = CSOIL_DATA + BEXP = BB (SOILTYP) + DKSAT = SATDK (SOILTYP) + DWSAT = SATDW (SOILTYP) + F1 = F11 (SOILTYP) + PSISAT = SATPSI (SOILTYP) + QUARTZ = QTZ (SOILTYP) + SMCDRY = DRYSMC (SOILTYP) + SMCMAX = MAXSMC (SOILTYP) + SMCREF = REFSMC (SOILTYP) + SMCWLT = WLTSMC (SOILTYP) +! ---------------------------------------------------------------------- +! Set-up universal parameters (not dependent on SOILTYP, VEGTYP or +! SLOPETYP) +! ---------------------------------------------------------------------- + ZBOT = ZBOT_DATA + SALP = SALP_DATA + SBETA = SBETA_DATA + REFDK = REFDK_DATA + FRZK = FRZK_DATA + FXEXP = FXEXP_DATA + REFKDT = REFKDT_DATA + PTU = 0. ! (not used yet) to satisify intent(out) + KDT = REFKDT * DKSAT / REFDK + CZIL = CZIL_DATA + SLOPE = SLOPE_DATA (SLOPETYP) + +! ---------------------------------------------------------------------- +! TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT +! ---------------------------------------------------------------------- + FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) + FRZX = FRZK * FRZFACT + +! ---------------------------------------------------------------------- +! SET-UP VEGETATION PARAMETERS +! ---------------------------------------------------------------------- + TOPT = TOPT_DATA + CMCMAX = CMCMAX_DATA + CFACTR = CFACTR_DATA + RSMAX = RSMAX_DATA + NROOT = NROTBL (VEGTYP) + SNUP = SNUPTBL (VEGTYP) + RSMIN = RSTBL (VEGTYP) + RGL = RGLTBL (VEGTYP) + HS = HSTBL (VEGTYP) + LAI = LAITBL (VEGTYP) + IF(LOCAL) THEN + ALBBRD = ALBTBL(VEGTYP) + Z0BRD = Z0TBL(VEGTYP) + SHDFAC = SHDTBL(VEGTYP) + ENDIF + + IF (VEGTYP .eq. BARE) SHDFAC = 0.0 + IF (NROOT .gt. NSOIL) THEN + WRITE (err_message,*) 'Error: too many root layers ', & + NSOIL,NROOT + CALL wrf_error_fatal ( err_message ) +! ---------------------------------------------------------------------- +! CALCULATE ROOT DISTRIBUTION. PRESENT VERSION ASSUMES UNIFORM +! DISTRIBUTION BASED ON SOIL LAYER DEPTHS. +! ---------------------------------------------------------------------- + END IF + DO I = 1,NROOT + RTDIS (I) = - SLDPTH (I)/ ZSOIL (NROOT) +! ---------------------------------------------------------------------- +! SET-UP SLOPE PARAMETER +! ---------------------------------------------------------------------- + END DO + +! print*,'end of PRMRED' +! print*,'VEGTYP',VEGTYP,'SOILTYP',SOILTYP,'SLOPETYP',SLOPETYP, & +! & 'CFACTR',CFACTR,'CMCMAX',CMCMAX,'RSMAX',RSMAX,'TOPT',TOPT, & +! & 'REFKDT',REFKDT,'KDT',KDT,'SBETA',SBETA, 'SHDFAC',SHDFAC, & +! & 'RSMIN',RSMIN,'RGL',RGL,'HS',HS,'ZBOT',ZBOT,'FRZX',FRZX, & +! & 'PSISAT',PSISAT,'SLOPE',SLOPE,'SNUP',SNUP,'SALP',SALP,'BEXP', & +! & BEXP, & +! & 'DKSAT',DKSAT,'DWSAT',DWSAT, & +! & 'SMCMAX',SMCMAX,'SMCWLT',SMCWLT,'SMCREF',SMCREF,'SMCDRY',SMCDRY, & +! & 'F1',F1,'QUARTZ',QUARTZ,'FXEXP',FXEXP, & +! & 'RTDIS',RTDIS,'SLDPTH',SLDPTH,'ZSOIL',ZSOIL, 'NROOT',NROOT, & +! & 'NSOIL',NSOIL,'Z0',Z0,'CZIL',CZIL,'LAI',LAI, & +! & 'CSOIL',CSOIL,'PTU',PTU, & +! & 'LOCAL', LOCAL + + END SUBROUTINE REDPRM + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) + +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KK + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D + REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (1) = - C (1) / B (1) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DELTA (1) = D (1) / B (1) + DO K = 2,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) + +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + KK = NSOIL - K + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- + + + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + QUARTZ,CSOIL,VEGTYP) + +! ---------------------------------------------------------------------- +! SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ICE, NSOIL, VEGTYP + INTEGER :: I + + REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, & + SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1 + REAL, INTENT(INOUT) :: T1 + REAL, INTENT(OUT) :: SSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SEA-ICE CASE +! ---------------------------------------------------------------------- + IF (ICE == 1) THEN + + CALL HRTICE (RHSTS,STC,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + +! ---------------------------------------------------------------------- +! LAND-MASS CASE +! ---------------------------------------------------------------------- + ELSE + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,PSISAT,SH2O,DT, & + BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + END IF + DO I = 1,NSOIL + STC (I) = STCF (I) + END DO + +! ---------------------------------------------------------------------- +! IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND +! (SKIN) TEMPERATURE HERE IN RESPONSE TO THE UPDATED SOIL TEMPERATURE +! PROFILE ABOVE. (NOTE: INSPECTION OF ROUTINE SNOPAC SHOWS THAT T1 +! BELOW IS A DUMMY VARIABLE ONLY, AS SKIN TEMPERATURE IS UPDATED +! DIFFERENTLY IN ROUTINE SNOPAC) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATE SURFACE SOIL HEAT FLUX +! ---------------------------------------------------------------------- + T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + & SH2O,SLOPE,KDT,FRZFACT, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX, & + & RUNOFF1,RUNOFF2,RUNOFF3, & + & EDIR,EC,ET, & + & DRIP) + +! ---------------------------------------------------------------------- +! SUBROUTINE SMFLX +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT (SMC - A PER +! UNIT VOLUME MEASUREMENT) IS A DEPENDENT VARIABLE THAT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! FROZEN GROUND VERSION: NEW STATES ADDED: SH2O, AND FROZEN GROUND +! CORRECTION FACTOR, FRZFACT AND PARAMETER SLOPE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I,K + + REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, & + KDT, PRCP1, SHDFAC, SLOPE, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMC, SH2O + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & + SICE, SH2OA, SH2OFG + REAL :: DUMMY, EXCESS,FRZFACT,PCPDRP,RHSCT,TRHSCT + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) +! ---------------------------------------------------------------------- + DUMMY = 0. + +! ---------------------------------------------------------------------- +! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING +! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL +! FALL TO THE GRND. +! ---------------------------------------------------------------------- + RHSCT = SHDFAC * PRCP1- EC + DRIP = 0. + TRHSCT = DT * RHSCT + EXCESS = CMC + TRHSCT + +! ---------------------------------------------------------------------- +! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMC) THAT GOES INTO THE +! SOIL +! ---------------------------------------------------------------------- + IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX + PCPDRP = (1. - SHDFAC) * PRCP1+ DRIP / DT + +! ---------------------------------------------------------------------- +! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP +! + DO I = 1,NSOIL + SICE (I) = SMC (I) - SH2O (I) + END DO +! ---------------------------------------------------------------------- +! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE +! TENDENCY EQUATIONS. +! IF THE INFILTRATING PRECIP RATE IS NONTRIVIAL, +! (WE CONSIDER NONTRIVIAL TO BE A PRECIP TOTAL OVER THE TIME STEP +! EXCEEDING ONE ONE-THOUSANDTH OF THE WATER HOLDING CAPACITY OF +! THE FIRST SOIL LAYER) +! THEN CALL THE SRT/SSTEP SUBROUTINE PAIR TWICE IN THE MANNER OF +! TIME SCHEME "F" (IMPLICIT STATE, AVERAGED COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU (1988, MWR, VOL 116, +! PAGES 1945-1958)TO MINIMIZE 2-DELTA-T OSCILLATIONS IN THE +! SOIL MOISTURE VALUE OF THE TOP SOIL LAYER THAT CAN ARISE BECAUSE +! OF THE EXTREME NONLINEAR DEPENDENCE OF THE SOIL HYDRAULIC +! DIFFUSIVITY COEFFICIENT AND THE HYDRAULIC CONDUCTIVITY ON THE +! SOIL MOISTURE STATE +! OTHERWISE CALL THE SRT/SSTEP SUBROUTINE PAIR ONCE IN THE MANNER OF +! TIME SCHEME "D" (IMPLICIT STATE, EXPLICIT COEFFICIENT) +! OF SECTION 2 OF KALNAY AND KANAMITSU +! PCPDRP IS UNITS OF KG/M**2/S OR MM/S, ZSOIL IS NEGATIVE DEPTH IN M +! ---------------------------------------------------------------------- +! IF ( PCPDRP .GT. 0.0 ) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! SMC STATES REPLACED BY SH2O STATES IN SRT SUBR. SH2O & SICE STATES +! INC&UDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT +! ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER +! ---------------------------------------------------------------------- + IF ( (PCPDRP * DT) > (0.001*1000.0* (- ZSOIL (1))* SMCMAX) ) THEN + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + DO K = 1,NSOIL + SH2OA (K) = (SH2O (K) + SH2OFG (K)) * 0.5 + END DO + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + + ELSE + CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) +! RUNOF = RUNOFF + + END IF + +! ---------------------------------------------------------------------- + END SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + + SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- +! CALCULATE SNOW FRACTION (0 -> 1) +! SNEQV SNOW WATER EQUIVALENT (M) +! SNUP THRESHOLD SNEQV DEPTH ABOVE WHICH SNCOVR=1 +! SALP TUNING PARAMETER +! SNCOVR FRACTIONAL SNOW COVER +! ---------------------------------------------------------------------- + IMPLICIT NONE + + REAL, INTENT(IN) :: SNEQV,SNUP,SALP,SNOWH + REAL, INTENT(OUT) :: SNCOVR + REAL :: RSNOW, Z0N + +! ---------------------------------------------------------------------- +! SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE +! REDPRM) ABOVE WHICH SNOCVR=1. +! ---------------------------------------------------------------------- + IF (SNEQV < SNUP) THEN + RSNOW = SNEQV / SNUP + SNCOVR = 1. - ( EXP ( - SALP * RSNOW) - RSNOW * EXP ( - SALP)) + ELSE + SNCOVR = 1.0 + END IF + +! FORMULATION OF DICKINSON ET AL. 1986 +! Z0N = 0.035 + +! SNCOVR=SNOWH/(SNOWH + 5*Z0N) + +! FORMULATION OF MARSHALL ET AL. 1994 +! SNCOVR=SNEQV/(SNEQV + 2*Z0N) + +! ---------------------------------------------------------------------- + END SUBROUTINE SNFRAC +! ---------------------------------------------------------------------- + + SUBROUTINE SNKSRC (TSNSR,TAVG,SMC,SH2O,ZSOIL,NSOIL, & + & SMCMAX,PSISAT,BEXP,DT,K,QTOT) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- +! CALCULATE SINK/SOURCE TERM OF THE TERMAL DIFFUSION EQUATION. (SH2O) IS +! AVAILABLE LIQUED WATER. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: K,NSOIL + + REAL, INTENT(IN) :: BEXP, DT, PSISAT, QTOT, SMC, SMCMAX, & + TAVG + REAL, INTENT(INOUT) :: SH2O + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: ZSOIL + + REAL :: DF, DZ, DZH, FREE, TSNSR, & + TDN, TM, TUP, TZ, X0, XDN, XH2O, XUP + + REAL, PARAMETER :: DH2O = 1.0000E3, HLICE = 3.3350E5, & + T0 = 2.7315E2 + + IF (K == 1) THEN + DZ = - ZSOIL (1) + ELSE + DZ = ZSOIL (K -1) - ZSOIL (K) + END IF +! ---------------------------------------------------------------------- +! VIA FUNCTION FRH2O, COMPUTE POTENTIAL OR 'EQUILIBRIUM' UNFROZEN +! SUPERCOOLED FREE WATER FOR GIVEN SOIL TYPE AND SOIL LAYER TEMPERATURE. +! FUNCTION FRH20 INVOKES EQN (17) FROM V. KOREN ET AL (1999, JGR, VOL. +! 104, PG 19573). (ASIDE: LATTER EQN IN JOURNAL IN CENTIGRADE UNITS. +! ROUTINE FRH2O USE FORM OF EQN IN KELVIN UNITS.) +! ---------------------------------------------------------------------- +! FREE = FRH2O(TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) + +! ---------------------------------------------------------------------- +! IN NEXT BLOCK OF CODE, INVOKE EQN 18 OF V. KOREN ET AL (1999, JGR, +! VOL. 104, PG 19573.) THAT IS, FIRST ESTIMATE THE NEW AMOUNTOF LIQUID +! WATER, 'XH2O', IMPLIED BY THE SUM OF (1) THE LIQUID WATER AT THE BEGIN +! OF CURRENT TIME STEP, AND (2) THE FREEZE OF THAW CHANGE IN LIQUID +! WATER IMPLIED BY THE HEAT FLUX 'QTOT' PASSED IN FROM ROUTINE HRT. +! SECOND, DETERMINE IF XH2O NEEDS TO BE BOUNDED BY 'FREE' (EQUIL AMT) OR +! IF 'FREE' NEEDS TO BE BOUNDED BY XH2O. +! ---------------------------------------------------------------------- + CALL FRH2O (FREE,TAVG,SMC,SH2O,SMCMAX,BEXP,PSISAT) + +! ---------------------------------------------------------------------- +! FIRST, IF FREEZING AND REMAINING LIQUID LESS THAN LOWER BOUND, THEN +! REDUCE EXTENT OF FREEZING, THEREBY LETTING SOME OR ALL OF HEAT FLUX +! QTOT COOL THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + XH2O = SH2O + QTOT * DT / (DH2O * HLICE * DZ) + IF ( XH2O < SH2O .AND. XH2O < FREE) THEN + IF ( FREE > SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + END IF + END IF +! ---------------------------------------------------------------------- +! SECOND, IF THAWING AND THE INCREASE IN LIQUID WATER GREATER THAN UPPER +! BOUND, THEN REDUCE EXTENT OF THAW, THEREBY LETTING SOME OR ALL OF HEAT +! FLUX QTOT WARM THE SOIL TEMP LATER IN ROUTINE HRT. +! ---------------------------------------------------------------------- + IF ( XH2O > SH2O .AND. XH2O > FREE ) THEN + IF ( FREE < SH2O ) THEN + XH2O = SH2O + ELSE + XH2O = FREE + END IF + END IF + +! ---------------------------------------------------------------------- +! CALCULATE PHASE-CHANGE HEAT SOURCE/SINK TERM FOR USE IN ROUTINE HRT +! AND UPDATE LIQUID WATER TO REFLCET FINAL FREEZE/THAW INCREMENT. +! ---------------------------------------------------------------------- +! SNKSRC = -DH2O*HLICE*DZ*(XH2O-SH2O)/DT + IF (XH2O < 0.) XH2O = 0. + IF (XH2O > SMC) XH2O = SMC + TSNSR = - DH2O * HLICE * DZ * (XH2O - SH2O)/ DT + SH2O = XH2O + +! ---------------------------------------------------------------------- + END SUBROUTINE SNKSRC +! ---------------------------------------------------------------------- + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & + SMCREF,SMCDRY,CMC,CMCMAX,NSOIL,DT, & + SBETA,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,F1,SSOIL,STC,EPSCA,& + SFCPRS,BEXP,PC,RCH,RR,CFACTR,SNCOVR,ESD,SNDENS,& + SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT, & + ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & + RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & + ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI,& + VEGTYP) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ICE, NROOT, NSOIL,VEGTYP + INTEGER :: K + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DF1,DKSAT, & + DT,DWSAT, EPSCA,ETP,FDOWN,F1,FXEXP, & + FRZFACT,KDT,PC, PRCP,PSISAT,Q2,QUARTZ, & + RCH,RR,SBETA,SFCPRS, SFCTMP, SHDFAC, & + SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, T24, & + TBOT,TH2,ZBOT,EMISSI + REAL, INTENT(INOUT) :: CMC, BETA, ESD,FLX2,PRCPF,SNOWH,SNCOVR, & + SNDENS, T1 + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR, ETNS, ESNOW,ETT, & + FLX1,FLX3, RUNOFF1,RUNOFF2,RUNOFF3, & + SSOIL,SNOMLT + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC + REAL, DIMENSION(1:NSOIL) :: ET1 + REAL :: DENOM,DSOIL,DTOT,EC1,EDIR1,ESDFLX,ETA, & + ETT1, ESNOW1, ESNOW2, ETA1,ETP1,ETP2, & + ETP3, ETNS1, ETANRG, ETAX, EX, FLX3X, & + FRCSNO,FRCSOI, PRCP1, QSAT,RSNOW, SEH, & + SNCOND,SSOIL1, T11,T12, T12A, T12AX, & + T12B, T14, YY, ZZ1, EMISSI_S + + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + LSUBS = 2.83E+6, TFREEZ = 273.15, & + SNOEXP = 1.0 + +! ---------------------------------------------------------------------- +! EXECUTABLE CODE BEGINS HERE: +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESDFLX [KG M-2 S-1] .le. ESNOW +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + EDIR = 0. + EDIR1 = 0. + EC1 = 0. + EC = 0. + EMISSI_S=0.9 ! For snow + DO K = 1,NSOIL + ET (K) = 0. + ET1 (K) = 0. + END DO + ETT = 0. + ETT1 = 0. + ETNS = 0. + ETNS1 = 0. + ESNOW = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO M S-1 AND THEN TO AN +! AMOUNT (M) GIVEN TIMESTEP (DT) AND CALL IT AN EFFECTIVE SNOWPACK +! REDUCTION AMOUNT, ETP2 (M). THIS IS THE AMOUNT THE SNOWPACK WOULD BE +! REDUCED DUE TO EVAPORATION FROM THE SNOW SFC DURING THE TIMESTEP. +! EVAPORATION WILL PROCEED AT THE POTENTIAL RATE UNLESS THE SNOW DEPTH +! IS LESS THAN THE EXPECTED SNOWPACK REDUCTION. +! IF SEAICE (ICE=1), BETA REMAINS=1. +! ---------------------------------------------------------------------- +! PRCP1 = PRCP1*0.001 +! change name of PRCP1 to PRCPF + DEW = 0. + + PRCP1 = PRCPF *0.001 + ETP1 = ETP * 0.001 + ESNOW = ETP * SNCOVR +! write(*,*) 'ESNOW,ESDFLX=',ESNOW,ESDFLX +! ESDFLX = ESD *1000./ DT +! IF (ESDFLX .lt. ESNOW) THEN +!ek ESD = 0. +! ESNOW = ESDFLX +! ESD = 0. +! ELSE + ESNOW1 = ESNOW * 0.001 +!ek ESD = ESD - ESNOW2 + ESNOW2 = ESNOW1 * DT +! ESD = ESD- ESNOW2 +! END IF +! ETP2 = ETP * 0.001 * DT +! IF (ICE .NE. 1) THEN +! IF (ESD .LT. ETP2) THEN +! BETA = ESD / ETP2 +! ENDIF +! ENDIF + +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + BETA = 1.0 + IF (ETP <= 0.0) THEN + IF(ETP == 0.) BETA = 0.0 + DEW = - ETP * 0.001 +! ETP1 = 0.0 + ELSE + IF (ICE /= 1) THEN +! write(*,*) 'ETP1=',ETP1 + IF (SNCOVR < 1.) THEN + CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, & + FXEXP) + EDIR1 = EDIR1* (1. - SNCOVR) + EC1 = EC1* (1. - SNCOVR) + DO K = 1,NSOIL + ET1 (K) = ET1 (K)* (1. - SNCOVR) + END DO + ETT1 = ETT1*(1.-SNCOVR) + ETNS1 = EDIR1+ EC1+ ETT1 + EDIR = EDIR1*1000. + EC = EC1*1000. + DO K = 1,NSOIL + ET (K) = ET1 (K)*1000. + END DO + ETT = ETT1*1000. + ETNS = ETNS1*1000. +! write(*,*) EDIR*2.5E+9, +! & EC*2.5E+9, +! & ET(1)*2.5E+9, +! & ET(2)*2.5E+9, +! & ET(3)*2.5E+9, +! & ET(4)*2.5E+9, +! & ETT*2.5E+9 +! write(*,*) 'SNCOVR=',SNCOVR + ETNS = ETNS1*1000. +! write(*,*) 'ESNOW[W/M2],ETNS[W/M2]=', +! & ESNOW*LSUBS,ETNS*LSUBC +! write(*,*) 'ETP[W/M2],ETANRG=', +! & ETP*LSUBS,ETANRG +! ---------------------------------------------------------------------- + +! end IF (SNCOVR .lt. 1.) + END IF + +! end IF (ICE .ne. 1) + END IF + +! end IF (ETP .le. 0.0) + END IF +! ---------------------------------------------------------------------- +! COMPUTE TOTAL EVAPORATION, SNOW AND NON-SNOW +! also compute energy units (ETANRG) needed later below +! ---------------------------------------------------------------------- + +! write(*,*)'ESNOW*LSUBS,ETNS*LSUBC,ETANRG=', +! & ESNOW*LSUBS,ETNS*LSUBC,ETANRG + ETANRG = ESNOW * LSUBS + ETNS * LSUBC + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1- SFCTMP) + ELSE + IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP) +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + END IF + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL +!ek T12A = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH +!ek & + TH2 - SFCTMP - BETA*EPSCA ) / RR +!ek T12AX = ( (FDOWN-FLX1-FLX2-SIGMA*T24)/RCH +!ek & + TH2 - SFCTMP - ETANRG/RCH ) / RR + DENOM = 1.0+ DF1 / (DTOT * RR * RCH) +! write(*,*) 'T12A,T12AX=',T12A,T12AX +!Place for emiss, snow emiss=0.90 +! T12A = ( (FDOWN - FLX1- FLX2- SIGMA * T24)/ RCH & + T12A = ( (FDOWN - FLX1- FLX2- EMISSI_S*SIGMA * T24)/ RCH & + & + TH2- SFCTMP - ETANRG / RCH ) / RR + T12B = DF1 * STC (1) / (DTOT * RR * RCH) + +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- + T12 = (SFCTMP + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN + T1 = T12 + SSOIL = DF1 * (T1- STC (1)) / DTOT +! ESD = MAX (0.0, ESD- ETP2) + ESD = MAX(0.0, ESD-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + + SNOMLT = 0.0 +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- +!ek2 T1 = TFREEZ * SNCOVR + T12 * (1.0 - SNCOVR) + ELSE +!ek QSAT = (0.622*6.11E2)/(SFCPRS-0.378*6.11E2) +!ek ETP = RCH*(QSAT-Q2)/CP +!ek ETP2 = ETP*0.001*DT + T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP) + BETA = 1.0 + +! ---------------------------------------------------------------------- +! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. +! BETA<1 +! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. +! ---------------------------------------------------------------------- + SSOIL = DF1 * (T1- STC (1)) / DTOT +! IF (ESD .le. ETP2) THEN +! BETA = ESD / ETP2 + IF (ESD <= ESNOW2) THEN + ESD = 0.0 + EX = 0.0 + SNOMLT = 0.0 +! ---------------------------------------------------------------------- +! POTENTIAL EVAP (SUBLIMATION) LESS THAN DEPTH OF SNOWPACK, RETAIN +! BETA=1. +! SNOWPACK (ESD) REDUCED BY POTENTIAL EVAP RATE +! ETP3 (CONVERT TO FLUX) +! ---------------------------------------------------------------------- + ELSE +! ESD = ESD- ETP2 + ESD = ESD-ESNOW2 + ETP3 = ETP * LSUBC +! WRITE (*,*) 'SNCOVR=',SNCOVR +! WRITE (*,*) 'ETP3,ETANRG=',ETP3,ETANRG,'ETP',ETP,'LSUBC',LSUBC + SEH = RCH * (T1- TH2) + T14 = T1* T1 +!ek FLX3 = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETP3 +!ek FLX3X = FDOWN - FLX1 - FLX2 - SIGMA*T14 - SSOIL - SEH - ETANRG + T14 = T14* T14 +! FLX3 = FDOWN - FLX1- FLX2- SIGMA * T14- SSOIL - SEH - ETANRG + FLX3 = FDOWN - FLX1- FLX2- EMISSI_S*SIGMA * T14- SSOIL- SEH- & + & ETANRG +! WRITE (*,*) 'FLX3,FLX3X=',FLX3,FLX3X + IF (FLX3 <= 0.0) FLX3 = 0.0 +! ---------------------------------------------------------------------- +! SNOWMELT REDUCTION DEPENDING ON SNOW COVER +! IF SNOW COVER LESS THAN 5% NO SNOWMELT REDUCTION +! ***NOTE: DOES 'IF' BELOW FAIL TO MATCH THE MELT WATER WITH THE MELT +! ENERGY? +! ---------------------------------------------------------------------- + EX = FLX3*0.001/ LSUBF +! IF (SNCOVR .gt. 0.05) EX = EX * SNCOVR + +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + SNOMLT = EX * DT + IF (ESD- SNOMLT >= ESDMIN) THEN + ESD = ESD- SNOMLT +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + ELSE + EX = ESD / DT + FLX3 = EX *1000.0* LSUBF + SNOMLT = ESD + + ESD = 0.0 +! ---------------------------------------------------------------------- +! END OF 'ESD .LE. ETP2' IF-BLOCK +! ---------------------------------------------------------------------- + END IF + END IF + +! ---------------------------------------------------------------------- +! END OF 'T12 .LE. TFREEZ' IF-BLOCK +! ---------------------------------------------------------------------- + PRCP1 = PRCP1+ EX +! ---------------------------------------------------------------------- +! FINAL BETA NOW IN HAND, SO COMPUTE EVAPORATION. EVAP EQUALS ETP +! UNLESS BETA<1. +! ---------------------------------------------------------------------- +!ek ETA = BETA*ETP +! write(*,*) 'ETA,ETAX,ETAX/ETA=',ETA,ETAX,ETAX/ETA +! IF (ETAX/ETA .GE. 1.0) THEN +! write(*,*) '*********************' +! write(*,*) '*********************' +! write(*,*) '*********************' +! write(*,*) 'ETAX/ETA .GE. 1.0 !!!' +! write(*,*) '*********************' +! write(*,*) '*********************' +! write(*,*) '*********************' +! ENDIF + +! ---------------------------------------------------------------------- +! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW +! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR, EC, OR ETT IN SMFLX +! (BELOW). +! IF SEAICE (ICE=1) SKIP CALL TO SMFLX. +! SMFLX RETURNS UPDATED SOIL MOISTURE VALUES. IN THIS, THE SNOW PACK +! CASE, ETA1 IS NOT USED IN CALCULATION OF EVAP. +! ---------------------------------------------------------------------- +! ETP1 = 0.0 + END IF + IF (ICE /= 1) THEN + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP) +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTER FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE +! SKIN TEMP VALUE AS REVISED BY SHFLX. +! ---------------------------------------------------------------------- + END IF + ZZ1 = 1.0 + YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. NOTE: THE SUB-SFC HEAT FLUX +! (SSOIL1) AND THE SKIN TEMP (T11) OUTPUT FROM THIS SHFLX CALL ARE NOT +! USED IN ANY SUBSEQUENT CALCULATIONS. RATHER, THEY ARE DUMMY VARIABLES +! HERE IN THE SNOPAC CASE, SINCE THE SKIN TEMP AND SUB-SFC HEAT FLUX ARE +! UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC. +! ---------------------------------------------------------------------- + T11 = T1 + CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & + QUARTZ,CSOIL,VEGTYP) + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + IF (ESD > 0.) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) + ELSE + ESD = 0. + SNOWH = 0. + SNDENS = 0. + SNCOND = 1. + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + + + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! ESD WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) + +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER :: IPOL, J + REAL, INTENT(IN) :: ESD, DTSEC,TSNOW,TSOIL + REAL, INTENT(INOUT) :: SNOWH, SNDENS + REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, & + TAVGC,TSNOWC,TSOILC,ESDC,ESDCX + REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & + KN = 4000.0 +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + ESDC = ESD *100. + DTHR = DTSEC /3600. + TSNOWC = TSNOW -273.15 + TSOILC = TSOIL -273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + TAVGC = 0.5* (TSNOWC + TSOILC) + IF (ESDC > 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + END IF + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. + +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS) + IPOL = 4 + PEXP = 0. +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + DO J = IPOL,1, -1 + PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1) + END DO + + PEXP = PEXP + 1. +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*ESD/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! & CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + DSX = SNDENS * (PEXP) + IF (DSX > 0.40) DSX = 0.40 + IF (DSX < 0.05) DSX = 0.05 +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + SNDENS = DSX + IF (TSNOWC >= 0.) THEN + DW = 0.13* DTHR /24. + SNDENS = SNDENS * (1. - DW) + DW + IF (SNDENS >= 0.40) SNDENS = 0.40 +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + END IF + SNOWHC = ESDC / SNDENS + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! SNCOVR FRACTIONAL SNOW COVER +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: SNCOVR, Z0BRD + REAL, INTENT(OUT) :: Z0 + REAL, PARAMETER :: Z0S=0.001 + +! CURRENT NOAH LSM CONDITION - MBEK, 09-OCT-2001 +! Z0S = Z0BRD + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITITY TO ACCOUNT FOR THE NEW SNOWFALL. +! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. + +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: NEWSN, TEMP + REAL, INTENT(INOUT) :: SNDENS, SNOWH + REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + NEWSNC = NEWSN *100. + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + TEMPC = TEMP -273.15 + IF (TEMPC <= -15.) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05+0.0017* (TEMPC +15.)**1.5 + END IF +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC / DSNEW + IF (SNOWHC + HNEWC .LT. 1.0E-3) THEN + SNDENS = MAX(DSNEW,SNDENS) + ELSE + SNDENS = (SNOWHC * SNDENS + HNEWC * DSNEW)/ (SNOWHC + HNEWC) + ENDIF + SNOWHC = SNOWHC + HNEWC + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + + SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: IALP1, IOHINF, J, JJ, K, KS + REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, FRZX, & + KDT, PCPDRP, SLOPE, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET, SH2O, SH2OA, SICE, & + ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS) > SICEMAX) SICEMAX = SICE (KS) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + PDDUM = PCPDRP + RUNOFF1 = 0.0 + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + + IF (PCPDRP /= 0.0) THEN + DT1 = DT /86400. + SMCAV = SMCMAX - SMCWLT + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1)* SMCAV + + DICE = - ZSOIL (1) * SICE (1) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1) + SICE (1) - SMCWLT)/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1) - ZSOIL (KS) ) * SICE (KS) + DMAX (KS) = (ZSOIL (KS -1) - ZSOIL (KS))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS) + SICE (KS) & + - SMCWLT)/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT * DT1)) + DDT = DD * VAL + PX = PCPDRP * DT + IF (PX < 0.0) PX = 0.0 + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX) + IF (PCPDRP > INFMAX) THEN + RUNOFF1 = PCPDRP - INFMAX + PDDUM = INFMAX + END IF +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2) ) + AI (1) = 0.0 + BI (1) = WDF * DDZ / ( - ZSOIL (1) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1) = - BI (1) + DSMDZ = ( SH2O (1) - SH2O (2) ) / ( - .5 * ZSOIL (2) ) + RHSTT (1) = (WDF * DSMDZ + WCND- PDDUM + EDIR + ET (1))/ ZSOIL (1) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR + ET (1) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1) - ZSOIL (K)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K) + CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K) - SH2O (K +1)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE + CALL WDFCND (WDF2,WCND2,SH2OA (NSOIL),SMCMAX,BEXP,DKSAT,DWSAT, & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K) = NUMER / ( - DENOM2) + AI (K) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K) = - ( AI (K) + CI (K) ) + IF (K .eq. NSOIL) THEN + RUNOFF2 = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SRT +! ---------------------------------------------------------------------- + + SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DDZ, RHSCT, STOT, WPLUS + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTin (K) = RHSTT (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ + STOT = SH2OOUT (K) + SICE (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + END DO + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMC + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) + +! ---------------------------------------------------------------------- +! SUBROUTINE TBND +! ---------------------------------------------------------------------- +! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF +! THE MIDDLE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + REAL, INTENT(IN) :: TB, TU, ZBOT + REAL, INTENT(OUT) :: TBND1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL :: ZB, ZUP + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER +! ---------------------------------------------------------------------- + IF (K == 1) THEN + ZUP = 0. + ELSE + ZUP = ZSOIL (K -1) + END IF +! ---------------------------------------------------------------------- +! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE +! TEMPERATURE INTO THE LAST LAYER BOUNDARY +! ---------------------------------------------------------------------- + IF (K == NSOIL) THEN + ZB = 2.* ZBOT - ZSOIL (K) + ELSE + ZB = ZSOIL (K +1) + END IF +! ---------------------------------------------------------------------- +! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + + TBND1 = TU + (TB - TU)* (ZUP - ZSOIL (K))/ (ZUP - ZB) +! ---------------------------------------------------------------------- + END SUBROUTINE TBND +! ---------------------------------------------------------------------- + + + SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) + +! ---------------------------------------------------------------------- +! SUBROUTINE TDFCND +! ---------------------------------------------------------------------- +! CALCULATE THERMAL DIFFUSIVITY AND CONDUCTIVITY OF THE SOIL FOR A GIVEN +! POINT AND TIME. +! ---------------------------------------------------------------------- +! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) +! June 2001 CHANGES: FROZEN SOIL CONDITION. +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O + REAL, INTENT(OUT) :: DF + REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & + THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & + XUNFROZ + +! ---------------------------------------------------------------------- +! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): +! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! ---------------------------------------------------------------------- +! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT +! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS +! ---------------------------------------------------------------------- +! THKW ......WATER THERMAL CONDUCTIVITY +! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ +! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS +! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) +! THKICE ....ICE THERMAL CONDUCTIVITY +! SMCMAX ....POROSITY (= SMCMAX) +! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! ---------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + +! PABLO GRUNMANN, 08/17/98 +! REFS.: +! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK +! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. +! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, +! UNIVERSITY OF TRONDHEIM, +! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL +! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES +! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, +! VOL. 55, PP. 1209-1224. +! ---------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / SMCMAX + THKICE = 2.2 + THKW = 0.57 +! IF (QZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! SOLIDS' CONDUCTIVITY +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 + +! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + THKS = (THKQTZ ** QZ)* (THKO ** (1. - QZ)) + +! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) + XUNFROZ = SH2O / SMC +! SATURATED THERMAL CONDUCTIVITY + XU = XUNFROZ * SMCMAX + +! DRY DENSITY IN KG/M3 + THKSAT = THKS ** (1. - SMCMAX)* THKICE ** (SMCMAX - XU)* THKW ** & + (XU) + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + GAMMD = (1. - SMCMAX)*2700. + + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) +! FROZEN + IF ( (SH2O + 0.0005) < SMC ) THEN + AKE = SATRATIO +! UNFROZEN +! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) + ELSE + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + IF ( SATRATIO > 0.1 ) THEN + + AKE = LOG10 (SATRATIO) + 1.0 + +! USE K = KDRY + ELSE + + AKE = 0.0 + END IF +! THERMAL CONDUCTIVITY + + END IF + + DF = AKE * (THKSAT - THKDRY) + THKDRY +! ---------------------------------------------------------------------- + END SUBROUTINE TDFCND +! ---------------------------------------------------------------------- + + SUBROUTINE TMPAVG (TAVG,TUP,TM,TDN,ZSOIL,NSOIL,K) + +! ---------------------------------------------------------------------- +! SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- +! CALCULATE SOIL LAYER AVERAGE TEMPERATURE (TAVG) IN FREEZING/THAWING +! LAYER USING UP, DOWN, AND MIDDLE LAYER TEMPERATURES (TUP, TDN, TM), +! WHERE TUP IS AT TOP BOUNDARY OF LAYER, TDN IS AT BOTTOM BOUNDARY OF +! LAYER. TM IS LAYER PROGNOSTIC STATE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER K + + INTEGER NSOIL + REAL DZ + REAL DZH + REAL T0 + REAL TAVG + REAL TDN + REAL TM + REAL TUP + REAL X0 + REAL XDN + REAL XUP + + REAL ZSOIL (NSOIL) + +! ---------------------------------------------------------------------- + PARAMETER (T0 = 2.7315E2) + IF (K .eq. 1) THEN + DZ = - ZSOIL (1) + ELSE + DZ = ZSOIL (K -1) - ZSOIL (K) + END IF + + DZH = DZ *0.5 + IF (TUP .lt. T0) THEN + IF (TM .lt. T0) THEN +! ---------------------------------------------------------------------- +! TUP, TM, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + TAVG = (TUP + 2.0* TM + TDN)/ 4.0 +! ---------------------------------------------------------------------- +! TUP & TM < T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + X0 = (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (TUP * DZH + TM * (DZH + X0) + T0* ( & + & 2.* DZH - X0)) / DZ + END IF + ELSE +! ---------------------------------------------------------------------- +! TUP < T0, TM .ge. T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XUP = (T0- TUP) * DZH / (TM - TUP) + XDN = DZH - (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP - XDN) & + & + TDN * XDN) / DZ +! ---------------------------------------------------------------------- +! TUP < T0, TM .ge. T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + XUP = (T0- TUP) * DZH / (TM - TUP) + TAVG = 0.5 * (TUP * XUP + T0* (2.* DZ - XUP)) / DZ + END IF + END IF + ELSE + IF (TM .lt. T0) THEN +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM < T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XUP = DZH - (T0- TUP) * DZH / (TM - TUP) + TAVG = 0.5 * (T0* (DZ - XUP) + TM * (DZH + XUP) & + & + TDN * DZH) / DZ +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM < T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + XUP = DZH - (T0- TUP) * DZH / (TM - TUP) + XDN = (T0- TM) * DZH / (TDN - TM) + TAVG = 0.5 * (T0* (2.* DZ - XUP - XDN) + TM * & + & (XUP + XDN)) / DZ + END IF + ELSE +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM .ge. T0, TDN < T0 +! ---------------------------------------------------------------------- + IF (TDN .lt. T0) THEN + XDN = DZH - (T0- TM) * DZH / (TDN - TM) + TAVG = (T0* (DZ - XDN) +0.5* (T0+ TDN)* XDN) / DZ +! ---------------------------------------------------------------------- +! TUP .ge. T0, TM .ge. T0, TDN .ge. T0 +! ---------------------------------------------------------------------- + ELSE + TAVG = (TUP + 2.0* TM + TDN) / 4.0 + END IF + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE TMPAVG +! ---------------------------------------------------------------------- + + SUBROUTINE TRANSP (ET,NSOIL,ETP1,SMC,CMC,ZSOIL,SHDFAC,SMCWLT, & + & CMCMAX,PC,CFACTR,SMCREF,SFCTMP,Q2,NROOT, & + & RTDIS) + +! ---------------------------------------------------------------------- +! SUBROUTINE TRANSP +! ---------------------------------------------------------------------- +! CALCULATE TRANSPIRATION FOR THE VEG CLASS. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER I + INTEGER K + INTEGER NSOIL + + INTEGER NROOT + REAL CFACTR + REAL CMC + REAL CMCMAX + REAL DENOM + REAL ET (NSOIL) + REAL ETP1 + REAL ETP1A +!.....REAL PART(NSOIL) + REAL GX (7) + REAL PC + REAL Q2 + REAL RTDIS (NSOIL) + REAL RTX + REAL SFCTMP + REAL SGX + REAL SHDFAC + REAL SMC (NSOIL) + REAL SMCREF + REAL SMCWLT + +! ---------------------------------------------------------------------- +! INITIALIZE PLANT TRANSP TO ZERO FOR ALL SOIL LAYERS. +! ---------------------------------------------------------------------- + REAL ZSOIL (NSOIL) + DO K = 1,NSOIL + ET (K) = 0. +! ---------------------------------------------------------------------- +! CALCULATE AN 'ADJUSTED' POTENTIAL TRANSPIRATION +! IF STATEMENT BELOW TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +! NOTE: GX AND OTHER TERMS BELOW REDISTRIBUTE TRANSPIRATION BY LAYER, +! ET(K), AS A FUNCTION OF SOIL MOISTURE AVAILABILITY, WHILE PRESERVING +! TOTAL ETP1A. +! ---------------------------------------------------------------------- + END DO + IF (CMC .ne. 0.0) THEN + ETP1A = SHDFAC * PC * ETP1 * (1.0- (CMC / CMCMAX) ** CFACTR) + ELSE + ETP1A = SHDFAC * PC * ETP1 + END IF + SGX = 0.0 + DO I = 1,NROOT + GX (I) = ( SMC (I) - SMCWLT ) / ( SMCREF - SMCWLT ) + GX (I) = MAX ( MIN ( GX (I), 1. ), 0. ) + SGX = SGX + GX (I) + END DO + + SGX = SGX / NROOT + DENOM = 0. + DO I = 1,NROOT + RTX = RTDIS (I) + GX (I) - SGX + GX (I) = GX (I) * MAX ( RTX, 0. ) + DENOM = DENOM + GX (I) + END DO + + IF (DENOM .le. 0.0) DENOM = 1. + DO I = 1,NROOT + ET (I) = ETP1A * GX (I) / DENOM +! ---------------------------------------------------------------------- +! ABOVE CODE ASSUMES A VERTICALLY UNIFORM ROOT DISTRIBUTION +! CODE BELOW TESTS A VARIABLE ROOT DISTRIBUTION +! ---------------------------------------------------------------------- +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * GX * ETP1A +! ET(1) = ( ZSOIL(1) / ZSOIL(NROOT) ) * ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(1) = RTDIS(1) * ETP1A +! ET(1) = ETP1A * PART(1) +! ---------------------------------------------------------------------- +! LOOP DOWN THRU THE SOIL LAYERS REPEATING THE OPERATION ABOVE, +! BUT USING THE THICKNESS OF THE SOIL LAYER (RATHER THAN THE +! ABSOLUTE DEPTH OF EACH LAYER) IN THE FINAL CALCULATION. +! ---------------------------------------------------------------------- +! DO K = 2,NROOT +! GX = ( SMC(K) - SMCWLT ) / ( SMCREF - SMCWLT ) +! GX = MAX ( MIN ( GX, 1. ), 0. ) +! TEST CANOPY RESISTANCE +! GX = 1.0 +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*GX*ETP1A +! ET(K) = ((ZSOIL(K)-ZSOIL(K-1))/ZSOIL(NROOT))*ETP1A +! ---------------------------------------------------------------------- +! USING ROOT DISTRIBUTION AS WEIGHTING FACTOR +! ---------------------------------------------------------------------- +! ET(K) = RTDIS(K) * ETP1A +! ET(K) = ETP1A*PART(K) +! END DO + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE TRANSP +! ---------------------------------------------------------------------- + + SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT, & + & SICEMAX) + +! ---------------------------------------------------------------------- +! SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL EXPON + REAL FACTR1 + REAL FACTR2 + REAL SICEMAX + REAL SMC + REAL SMCMAX + REAL VKwgt + REAL WCND + +! ---------------------------------------------------------------------- +! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT +! ---------------------------------------------------------------------- + REAL WDF + FACTR1 = 0.2 / SMCMAX + +! ---------------------------------------------------------------------- +! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY +! ---------------------------------------------------------------------- + FACTR2 = SMC / SMCMAX + EXPON = BEXP + 2.0 + +! ---------------------------------------------------------------------- +! FROZEN SOIL HYDRAULIC DIFFUSIVITY. VERY SENSITIVE TO THE VERTICAL +! GRADIENT OF UNFROZEN WATER. THE LATTER GRADIENT CAN BECOME VERY +! EXTREME IN FREEZING/THAWING SITUATIONS, AND GIVEN THE RELATIVELY +! FEW AND THICK SOIL LAYERS, THIS GRADIENT SUFFERES SERIOUS +! TRUNCTION ERRORS YIELDING ERRONEOUSLY HIGH VERTICAL TRANSPORTS OF +! UNFROZEN WATER IN BOTH DIRECTIONS FROM HUGE HYDRAULIC DIFFUSIVITY. +! THEREFORE, WE FOUND WE HAD TO ARBITRARILY CONSTRAIN WDF +! -- +! VERSION D_10CM: ........ FACTR1 = 0.2/SMCMAX +! WEIGHTED APPROACH...................... PABLO GRUNMANN, 28_SEP_1999. +! ---------------------------------------------------------------------- + WDF = DWSAT * FACTR2 ** EXPON + IF (SICEMAX .gt. 0.0) THEN + VKWGT = 1./ (1. + (500.* SICEMAX)**3.) + WDF = VKWGT * WDF + (1. - VKWGT)* DWSAT * FACTR1** EXPON +! ---------------------------------------------------------------------- +! RESET THE EXPNTL COEF AND CALC THE HYDRAULIC CONDUCTIVITY +! ---------------------------------------------------------------------- + END IF + EXPON = (2.0 * BEXP) + 3.0 + WCND = DKSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- + END SUBROUTINE WDFCND +! ---------------------------------------------------------------------- + + SUBROUTINE SFCDIF_off (ZLM,Z0,THZ0,THLM,SFCSPD,CZIL,AKMS,AKHS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL) +! ---------------------------------------------------------------------- +! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. +! SEE CHEN ET AL (1997, BLM) +! ---------------------------------------------------------------------- + + IMPLICIT NONE + REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW + REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, & + & SQVISC + REAL RIC, RRIC, FHNEU, RFC, RFAC, ZZ, PSLMU, PSLMS, PSLHU, & + & PSLHS + REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM + REAL SFCSPD, CZIL, AKMS, AKHS, ZILFC, ZU, ZT, RDZ, CXCH + REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT + REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 +!CC ......REAL ZTFC + + REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & + & RLMA + + INTEGER ITRMX, ILECH, ITR + PARAMETER & + & (WWST = 1.2,WWST2 = WWST * WWST,G = 9.8,VKRM = 0.40, & + & EXCM = 0.001 & + & ,BETA = 1./270.,BTG = BETA * G,ELFC = VKRM * BTG & + & ,WOLD =.15,WNEW = 1. - WOLD,ITRMX = 05, & + & PIHF = 3.14159265/2.) + PARAMETER & + & (EPSU2 = 1.E-4,EPSUST = 0.07,EPSIT = 1.E-4,EPSA = 1.E-8 & + & ,ZTMIN = -5.,ZTMAX = 1.,HPBL = 1000.0 & + & ,SQVISC = 258.2) + PARAMETER & + & (RIC = 0.183,RRIC = 1.0/ RIC,FHNEU = 0.8,RFC = 0.191 & + & ,RFAC = RIC / (FHNEU * RFC * RFC)) + +! ---------------------------------------------------------------------- +! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS +! ---------------------------------------------------------------------- +! LECH'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) + PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) + +! ---------------------------------------------------------------------- +! PAULSON'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) + PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & + & +2.* ATAN (XX) & + &- PIHF + PSPMS (YY)= 5.* YY + PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) + +! ---------------------------------------------------------------------- +! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND +! OVER SOLID SURFACE (LAND, SEA-ICE). +! ---------------------------------------------------------------------- + PSPHS (YY)= 5.* YY + +! ---------------------------------------------------------------------- +! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 +! C......ZTFC=0.1 +! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT +! ---------------------------------------------------------------------- + ILECH = 0 + +! ---------------------------------------------------------------------- + ZILFC = - CZIL * VKRM * SQVISC +! C.......ZT=Z0*ZTFC + ZU = Z0 + RDZ = 1./ ZLM + CXCH = EXCM * RDZ + DTHV = THLM - THZ0 + +! ---------------------------------------------------------------------- +! BELJARS CORRECTION OF USTAR +! ---------------------------------------------------------------------- + DU2 = MAX (SFCSPD * SFCSPD,EPSU2) +!cc If statements to avoid TANGENT LINEAR problems near zero + BTGH = BTG * HPBL + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF + +! ---------------------------------------------------------------------- +! ZILITINKEVITCH APPROACH FOR ZT +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + +! ---------------------------------------------------------------------- + ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZSLU = ZLM + ZU +! PRINT*,'ZSLT=',ZSLT +! PRINT*,'ZLM=',ZLM +! PRINT*,'ZT=',ZT + + ZSLT = ZLM + ZT + RLOGU = log (ZSLU / ZU) + + RLOGT = log (ZSLT / ZT) +! PRINT*,'RLMO=',RLMO +! PRINT*,'ELFC=',ELFC +! PRINT*,'AKHS=',AKHS +! PRINT*,'DTHV=',DTHV +! PRINT*,'USTAR=',USTAR + + RLMO = ELFC * AKHS * DTHV / USTAR **3 +! ---------------------------------------------------------------------- +! 1./MONIN-OBUKKHOV LENGTH-SCALE +! ---------------------------------------------------------------------- + DO ITR = 1,ITRMX + ZETALT = MAX (ZSLT * RLMO,ZTMIN) + RLMO = ZETALT / ZSLT + ZETALU = ZSLU * RLMO + ZETAU = ZU * RLMO + + ZETAT = ZT * RLMO + IF (ILECH .eq. 0) THEN + IF (RLMO .lt. 0.)THEN + XLU4 = 1. -16.* ZETALU + XLT4 = 1. -16.* ZETALT + XU4 = 1. -16.* ZETAU + + XT4 = 1. -16.* ZETAT + XLU = SQRT (SQRT (XLU4)) + XLT = SQRT (SQRT (XLT4)) + XU = SQRT (SQRT (XU4)) + + XT = SQRT (SQRT (XT4)) +! PRINT*,'-----------1------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSPMU(ZETAU)=',PSPMU(ZETAU) +! PRINT*,'XU=',XU +! PRINT*,'------------------------' + PSMZ = PSPMU (XU) + SIMM = PSPMU (XLU) - PSMZ + RLOGU + PSHZ = PSPHU (XT) + SIMH = PSPHU (XLT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) +! PRINT*,'-----------2------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSPMS(ZETAU)=',PSPMS(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSPMS (ZETAU) + SIMM = PSPMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS (ZETAT) + SIMH = PSPHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! LECH'S FUNCTIONS +! ---------------------------------------------------------------------- + ELSE + IF (RLMO .lt. 0.)THEN +! PRINT*,'-----------3------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSLMU(ZETAU)=',PSLMU(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSLMU (ZETAU) + SIMM = PSLMU (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU (ZETAT) + SIMH = PSLHU (ZETALT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + + ZETALT = MIN (ZETALT,ZTMAX) +! PRINT*,'-----------4------------' +! PRINT*,'PSMZ=',PSMZ +! PRINT*,'PSLMS(ZETAU)=',PSLMS(ZETAU) +! PRINT*,'ZETAU=',ZETAU +! PRINT*,'------------------------' + PSMZ = PSLMS (ZETAU) + SIMM = PSLMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS (ZETAT) + SIMH = PSLHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! BELJAARS CORRECTION FOR USTAR +! ---------------------------------------------------------------------- + END IF + +! ---------------------------------------------------------------------- +! ZILITINKEVITCH FIX FOR ZT +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + + ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZSLT = ZLM + ZT +!----------------------------------------------------------------------- + RLOGT = log (ZSLT / ZT) + USTARK = USTAR * VKRM + AKMS = MAX (USTARK / SIMM,CXCH) +!----------------------------------------------------------------------- +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +!----------------------------------------------------------------------- + AKHS = MAX (USTARK / SIMH,CXCH) + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF +!----------------------------------------------------------------------- + RLMN = ELFC * AKHS * DTHV / USTAR **3 +!----------------------------------------------------------------------- +! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 +!----------------------------------------------------------------------- + RLMA = RLMO * WOLD+ RLMN * WNEW +!----------------------------------------------------------------------- + RLMO = RLMA +! PRINT*,'----------------------------' +! PRINT*,'SFCDIF OUTPUT ! ! ! ! ! ! ! ! ! ! ! !' + +! PRINT*,'ZLM=',ZLM +! PRINT*,'Z0=',Z0 +! PRINT*,'THZ0=',THZ0 +! PRINT*,'THLM=',THLM +! PRINT*,'SFCSPD=',SFCSPD +! PRINT*,'CZIL=',CZIL +! PRINT*,'AKMS=',AKMS +! PRINT*,'AKHS=',AKHS +! PRINT*,'----------------------------' + + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SFCDIF_off +! ---------------------------------------------------------------------- + +END MODULE module_sf_noahlsm diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F new file mode 100644 index 00000000..df66e721 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_ruclsm.F @@ -0,0 +1,4475 @@ +#define LSMRUC_DBG_LVL 3000 +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_sf_ruclsm + USE module_wrf_error + +CONTAINS + +!----------------------------------------------------------------- + SUBROUTINE LSMRUC( & + DT,KTAU,NSL,ZS, & + RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & + Z3D,P8W,T3D,QV3D,QC3D,RHO3D, & !p8W in [PA] + GLW,GSW,EMISS,CHKLOWQ, & + FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & + SNOALB,ALBBCK, & !new + QSFC,QSG,QVG,QCG,SOILT1,TSNAV, & + TBOT,IVGTYP,ISLTYP,XLAND,XICE, & + CP,G0,LV,STBOLT, & + SOILMOIS,SMAVAIL,SMMAX, & + TSO,SOILT,HFX,QFX,LH, & + SFCRUNOFF,UDRUNOFF,SFCEXC, & + SFCEVP,GRDFLX,ACSNOW, & + SMFR3D,KEEPFR3DFLAG, & + myj, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- +! +! The RUC LSM model is described in: +! Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997: +! Performance of different soil model configurations in simulating +! ground surface temperature and surface fluxes. +! Mon. Wea. Rev. 125, 1870-1884. +! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: Parameterization of +! cold-season processes in the MAPS land-surface scheme. +! J. Geophys. Res. 105, 4077-4086. +!----------------------------------------------------------------- +!-- DT time step (second) +! ktau - number of time step +! NSL - number of soil layers +! NZS - number of levels in soil +! ZS - depth of soil levels (m) +!-- RAINBL - accumulated rain in [mm] between the PBL calls +!-- RAINNCV one time step grid scale precipitation (mm/step) +! SNOW - snow water equivalent [mm] +! FRAZFRAC - fraction of frozen precipitation +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- Z3D heights (m) +!-- P8W 3D pressure (Pa) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +! QC3D - 3D cloud water mixing ratio (Kg/Kg) +! RHO3D - 3D air density (kg/m^3) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- GSW absorbed short wave flux at ground surface (W/m^2) +!-- EMISS surface emissivity (between 0 and 1) +! FLQC - surface exchange coefficient for moisture (kg/m^2/s) +! FLHC - surface exchange coefficient for heat [W/m^2/s/degreeK] +! SFCEXC - surface exchange coefficient for heat [m/s] +! CANWAT - CANOPY MOISTURE CONTENT (mm) +! VEGFRA - vegetation fraction (between 0 and 1) +! ALB - surface albedo (between 0 and 1) +! SNOALB - maximum snow albedo (between 0 and 1) +! ALBBCK - snow-free albedo (between 0 and 1) +! ZNT - roughness length [m] +!-- TBOT soil temperature at lower boundary (K) +! IVGTYP - USGS vegetation type (24 classes) +! ISLTYP - STASGO soil type (16 classes) +!-- XLAND land mask (1 for land, 2 for water) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- G0 acceleration due to gravity (m/s^2) +!-- LV latent heat of melting (J/kg) +!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) +! SOILMOIS - soil moisture content (volumetric fraction) +! TSO - soil temp (K) +!-- SOILT surface temperature (K) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH upward latent heat flux (W/m^2) +! SFCRUNOFF - ground surface runoff [mm] +! UDRUNOFF - underground runoff [mm] +! SFCEVP - total evaporation in [kg/m^2] +! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) +! ACSNOW - accumulation of snow water [m] +!-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). +!-- used only in MYJPBL. +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!------------------------------------------------------------------------- +! INTEGER, PARAMETER :: nzss=5 +! INTEGER, PARAMETER :: nddzs=2*(nzss-2) + + INTEGER, PARAMETER :: nvegclas=24 + + REAL, INTENT(IN ) :: DT + LOGICAL, INTENT(IN ) :: myj,frpcpn + INTEGER, INTENT(IN ) :: ktau, nsl, & + ims,ime, jms,jme, kms,kme, & + ids,ide, jds,jde, kds,kde, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + QC3D, & + p8w, & + rho3D, & + T3D, & + z3D + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: RAINBL, & + GLW, & + GSW, & + SNOALB, & + ALBBCK, & + FLHC, & + FLQC, & + EMISS, & +! MAVAIL, & + XICE, & + XLAND, & + VEGFRA, & + TBOT + + REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: & + SNOW, & !new + SNOWH, & + SNOWC, & + CANWAT, & ! new + ALB, & + MAVAIL, & + SFCEXC, & + ZNT + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: & + FRZFRAC + + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: IVGTYP, & + ISLTYP + + REAL, INTENT(IN ) :: CP,G0,LV,STBOLT + + REAL, DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + INTENT(INOUT) :: SOILMOIS,TSO + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SOILT, & + HFX, & + QFX, & + LH, & + SFCEVP, & + SFCRUNOFF, & + UDRUNOFF, & + GRDFLX, & + ACSNOW, & + QVG, & + QCG, & + QSFC, & + QSG, & + CHKLOWQ, & + SOILT1, & + TSNAV + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SMAVAIL, & + SMMAX + + REAL, DIMENSION( its:ite, jts:jte ) :: DEW, & + PC, & + RUNOFF1, & + RUNOFF2, & + EMISSL, & + ZNTL, & + LMAVAIL, & + SMELT, & + SNOH, & + SNFLX, & + SNOM, & + EDIR, & + EC, & + ETT, & + SUBLIM, & + EVAPL, & + PRCPL, & + XICED, & + INFILTR + +!--- soil/snow properties + REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & + :: KEEPFR3DFLAG, & + SMFR3D + + REAL & + :: RHOCS, & + RHOSN, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + WILT, & + CANWATR, & + SNOWFRAC, & + SNHEI, & + SNWE + + REAL :: CN, & + SAT,CW, & + C1SN, & + C2SN, & + KQWRTZ, & + KICE, & + KWT + + + REAL, DIMENSION(1:NSL) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:2*(nsl-2)) :: DTDZS + + REAL, DIMENSION(1:4001) :: TBQ + + + REAL, DIMENSION( 1:nsl ) :: SOILM1D, & + TSO1D, & + SOILICE, & + SOILIQW, & + SMFRKEEP + + REAL, DIMENSION( 1:nsl ) :: KEEPFR + + + REAL :: RSM, & + SNWEPRINT, & + SNHEIPRINT + + REAL :: PRCPMS, & + NEWSNMS, & + PATM, & + TABS, & + QVATM, & + QCATM, & + Q2SAT, & + SATFLG, & + CONFLX, & + RHO, & + QKMS, & + TKMS, & + INFILTRP + REAL :: cq,r61,r273,arp,brp,x,evs,eis + + INTEGER :: NROOT + INTEGER :: ILAND,ISOIL + + INTEGER, DIMENSION ( 1:nvegclas ) :: IFOREST + + INTEGER :: I,J,K,NZS,NZS1,NDDZS + INTEGER :: k1,l,k2,kp,km + + +!----------------------------------------------------------------- + + NZS=NSL + NDDZS=2*(nzs-2) + +!---- table TBQ is for resolution of balance equation in VILKA + CQ=173.15-.05 + R273=1./273.15 + R61=6.1153*0.62198 + ARP=77455.*41.9/461.525 + BRP=64.*41.9/461.525 + + DO K=1,4001 + CQ=CQ+.05 +! TBQ(K)=R61*EXP(ARP*(R273-1./CQ)-BRP*LOG(CQ*R273)) + EVS=EXP(17.67*(CQ-273.15)/(CQ-29.65)) + EIS=EXP(22.514-6.15E3/CQ) + if(CQ.ge.273.15) then +! tbq is in mb + tbq(k) = R61*evs + else + tbq(k) = R61*eis + endif + + END DO + +!--- Initialize soil/vegetation parameters +!--- This is temporary until SI is added to mass coordinate ---!!!!! + +#if ( NMM_CORE == 1 ) + if(ktau+1.eq.1) then +#else + if(ktau.eq.1) then +#endif + DO J=jts,jte + DO i=its,ite + do k=1,nsl +! smfr3d (i,k,j)=soilmois(i,k,j)/900.*1.e3 + keepfr3dflag(i,k,j)=0. + enddo +!--- initializing to zero snow fraction + snowc(i,j) = min(1.,snowh(i,j)/0.1) +!--- initializing of snow temp + soilt1(i,j)=soilt(i,j) + tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273. + qcg (i,j) =0. + patm=P8w(i,kms,j)*1.e-2 + QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATM + qvg (i,j) = QSG(i,j)*mavail(i,j) +! qvg (i,j) =qv3d(i,kms,j) + qsfc(i,j) = qsg(i,j)/(1.+qsg(i,j)) + SMELT(i,j) = 0. + SNOM (i,j) = 0. + SNFLX(i,j) = 0. + DEW (i,j) = 0. + PC (i,j) = 0. + zntl (i,j) = 0. + RUNOFF1(i,j) = 0. + RUNOFF2(i,j) = 0. + emissl (i,j) = 0. +! Temporarily!!! +! canwat(i,j)=0. + +! For RUC LSM CHKLOWQ needed for MYJPBL should +! 1 because is actual specific humidity at the surface, and +! not the saturation value + chklowq(i,j) = 1. + infiltr(i,j) = 0. + snoh (i,j) = 0. + edir (i,j) = 0. + ec (i,j) = 0. + ett (i,j) = 0. + sublim(i,j) = 0. + evapl (i,j) = 0. + prcpl (i,j) = 0. + ENDDO + ENDDO + + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + endif + +!----------------------------------------------------------------- + + PRCPMS = 0. +! NROOT = 4 + + + DO J=jts,jte + + DO i=its,ite + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & + ims,ime,jms,jme,its,ite,jts,jte,nzs + print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) + print *,' MAVAIL ', mavail(i,j) + print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) + print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & + qfx(i,j),hfx(i,j) + print *, ' GSW, GLW =',gsw(i,j),glw(i,j) + print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) + print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) + print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) + print *, ' I,J=, after SFCLAY FLQC,FLHC ',i,j,flqc(i,j),flhc(i,j) + print *, 'LSMRUC, IVGTYP,ISLTYP,ZNT,ALB = ', ivgtyp(i,j),isltyp(i,j),znt(i,j),alb(i,j),i,j + print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) + print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + ENDIF + + + ILAND = IVGTYP(i,j) + ISOIL = ISLTYP(I,J) + TABS = T3D(i,kms,j) + QVATM = QV3D(i,kms,j) + QCATM = QC3D(i,kms,j) + PATM = P8w(i,kms,j)*1.e-5 +!---- what height is the first level?---- check!!!!! +!-- need to de-stagger from w levels to P levels + CONFLX = Z3D(i,kms,j) +! CONFLX = 0.5*Z3D(i,kms,j) +! CONFLX = 5. + RHO = RHO3D(I,kms,J) +!--- 1*e-3 is to convert from mm/s to m/s + IF(FRPCPN) THEN + PRCPMS = (RAINBL(i,j)/DT*1.e-3)*(1-FRZFRAC(I,J)) + NEWSNMS = (RAINBL(i,j)/DT*1.e-3)*FRZFRAC(I,J) + ELSE + if (tabs.le.273.15) then + PRCPMS = 0. + NEWSNMS = RAINBL(i,j)/DT*1.e-3 + else + PRCPMS = RAINBL(i,j)/DT*1.e-3 + NEWSNMS = 0. + endif + ENDIF +!--- rooting depth is 5 levels for forests +! if(iforest(ivgtyp(i,j)).eq.1) nroot=5 +!--- convert exchange coeff to [m/s] + QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) + TKMS=FLHC(I,J)/RHO/CP +!--- convert incoming snow and canwat from mm to m + SNWE=SNOW(I,J)*1.E-3 + SNHEI=SNOWH(I,J) + CANWATR=CANWAT(I,J)*1.E-3 + SNOWFRAC=SNOWC(I,J) + +!----- + zsmain(1)=0. + zshalf(1)=0. + do k=2,nzs + zsmain(k)= zs(k) + zshalf(k)=0.5*(zsmain(k-1) + zsmain(k)) + enddo + +!-- definition of number of soil levels in the rooting zone + IF(iforest(ivgtyp(i,j)).ne.1) THEN +!---- non forests + do k=2,nzs + if(zsmain(k).ge.0.4) then + NROOT=K + goto 111 + endif + enddo + + ELSE +!---- forests + do k=2,nzs + if(zsmain(k).ge.1.1) then + NROOT=K + goto 111 + endif + enddo + ENDIF + 111 continue + +!----- + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' ZS, ZSMAIN, ZSHALF, CONFLX --->', zs,zsmain,zshalf,conflx + print *,'NROOT, iforest, ivgtyp, i,j ', nroot,iforest(ivgtyp(i,j)),ivgtyp(I,J),I,J + ENDIF + +!------------------------------------------------------------ +!----- DDZS and DSDZ1 are for implicit soilution of soil eqns. +!------------------------------------------------------------- + NZS1=NZS-1 +!----- + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + ENDIF + + DO K=2,NZS1 + K1=2*K-3 + K2=K1+1 + X=DT/2./(ZSHALF(K+1)-ZSHALF(K)) + DTDZS(K1)=X/(ZSMAIN(K)-ZSMAIN(K-1)) + DTDZS2(K-1)=X + DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) + END DO + + + CN=0.5 ! exponent + SAT=0.0005 ! canopy water saturated + + CW =4.183E6 + + +!--- Constants used in Johansen soil thermal +!--- conductivity method + + KQWRTZ=7.7 + KICE=2.2 + KWT=0.57 + +!*********************************************************************** +!--- Constants for snow density calculations C1SN and C2SN + + c1sn=0.026 +! c1sn=0.01 + c2sn=21. + +!*********************************************************************** + + NROOT= 4 +! ! rooting depth + + if(SNOWH(i,j).gt.0.) then + RHOSN = SNOW(i,j)/SNOWH(i,j) + else + RHOSN = 300. + endif + +!--- initializing soil and surface properties + CALL SOILVEGIN ( ILAND,ISOIL,MYJ,IFOREST, & + EMISSL(I,J),PC(i,j),ZNT(I,J),QWRTZ, & +! EMISSL(I,J),PC(i,j),ZNTL(I,J),QWRTZ, & + RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT ) + +!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS + + + IF((XLAND(I,J)-1.5).GE.0.)THEN +!-- Water point + SMAVAIL(I,J)=1.0 + SMMAX(I,J)=1.0 +! SNOW(I,J)=0.0 + LMAVAIL(I,J)=1.0 + + ILAND=16 + ISOIL=14 + + patm=P8w(i,kms,j)*1.e-2 + qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATM + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + CHKLOWQ(I,J)=1. + Q2SAT=QSN(TABS,TBQ)/PATM + + DO K=1,NZS + SOILMOIS(I,K,J)=1.0 + TSO(I,K,J)= SOILT(I,J) + ENDDO + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + PRINT*,' water point, I=',I, & + 'J=',J, 'SOILT=', SOILT(i,j) + ENDIF +!--- decide if this water point is ice: +! if(tabs.le.271.) then + if(xice(i,j).gt.0.5) then +! if(soilt(i,j).le.271.or.xice(i,j).eq.1.) then +! if(tabs.le.271.or.xice(i,j).eq.1.) then + XICED(i,j)=1. + else + XICED(i,j)=0. + endif + + IF(XICED(I,J).NE.1.) SNOW(I,J)=0. + IF(XICED(I,J).GT.0.5)THEN +!-- Sea-ice case + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + PRINT*,' sea-ice at water point, I=',I, & + 'J=',J + ENDIF + ILAND = 24 + ISOIL = 16 + + SMAVAIL(I,J)=1.0 + SMMAX(I,J)=1.0 + LMAVAIL(I,J)=1.0 +! SOILT(I,J) = MIN(273.15,SOILT(I,J)) + + DO K=1,NZS + SOILMOIS(I,K,J)=1.0 + TSO(I,K,J)= MIN(273.15,SOILT(I,J)) + ENDDO + ENDIF + +! for MYJ surface and PBL scheme + if (myj) then + IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN +! IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qsg(I,J))THEN + SATFLG=0. + ELSE + SATFLG=1.0 + ENDIF + else + SATFLG=1.0 + endif + QFX(I,J)=QFX(I,J)*SATFLG + + + ELSE + +!-- Land point +! Attention!!!! RUC LSM uses soil moisture content minus residual (minimum +! soil moisture content for a given soil type) as a state variable. +! If the WRF model is initialized from the RUC background model, then the +! soil moisture variable is consistent with the RUC LSM. +! If the WRF model is initialized from another background model (ETA, GFS...) +! then the residual value should be subtracted when the 1-d array of soil +! moisture is initialized before the call to SFCTMP, and after SFCTMP qmin +! should be added back in. +! +! soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin(i,j)),dqm(i,j)) + + + DO k=1,nzs +! soilm1d - soil moisture content minus residual [m**3/m**3] + soilm1d (k) = min(max(0.,soilmois(i,k,j)),dqm) + tso1d (k) = tso(i,k,j) + ENDDO + + do k=1,nzs + smfrkeep(k) = smfr3d(i,k,j) + keepfr (k) = keepfr3dflag(i,k,j) + enddo + +! LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/(REF-QMIN))) + LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/dqm)) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & + i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO + print *,'CONFLX =',CONFLX + print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + ENDIF + +!----------------------------------------------------------------- + CALL SFCTMP (dt,ktau,conflx,i,j, & +!--- input variables + nzs,nddzs,nroot, & + iland,isoil,xland(i,j),ivgtyp(i,j), & + PRCPMS,NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN, & + PATM,TABS,QVATM,QCATM,RHO, & + GLW(I,J),GSW(I,J),EMISSL(I,J), & + QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & + canwatr,vegfra(I,J),alb(I,J),znt(I,J), & + snoalb(i,j),albbck(i,j), & !new + myj, & +!--- soil fixed fields + QWRTZ, & + rhocs,dqm,qmin,ref, & + wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + cp,g0,lv,stbolt,cw,c1sn,c2sn, & + KQWRTZ,KICE,KWT, & +!--- output variables + snweprint,snheiprint,rsm, & + soilm1d,tso1d,smfrkeep,keepfr, & + soilt(I,J),soilt1(i,j),tsnav(i,j),dew(I,J), & + qvg(I,J),qsg(I,J),qcg(I,J),SMELT(I,J), & + SNOH(I,J),SNFLX(I,J),SNOM(I,J),ACSNOW(I,J), & + edir(I,J),ec(I,J),ett(I,J),sfcevp(I,J), & + lh(I,J),hfx(I,J),grdflx(I,J),sublim(I,J), & + evapl(I,J),prcpl(I,J),runoff1(I,J), & + runoff2(I,J),soilice,soiliqw,infiltrp) +!----------------------------------------------------------------- + +!*** DIAGNOSTICS +!--- available and maximum soil moisture content in the soil +!--- domain + smavail(i,j) = 0. + smmax (i,j) = 0. + + do k=1,nzs-1 + smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* & + (zshalf(k+1)-zshalf(k)) + smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + (zshalf(k+1)-zshalf(k)) + enddo + + smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & + (zsmain(nzs)-zshalf(nzs)) + smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + (zsmain(nzs)-zshalf(nzs)) + +!--- Convert the water unit into mm + SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 + UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*1000.0 + SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. + SMMAX (I,J) = SMMAX(I,J) * 1000. + SFCEXC (I,J) = TKMS +! MYJSFC expects QSFC as saturation specific humidity at surface + QSFC(I,J) = QSG(I,J)/(1.+QSG(I,J)) + Q2SAT=QSN(TABS,TBQ)/PATM +! for MYJ surface and PBL scheme + if (myj) then + IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN + CHKLOWQ(I,J)=0. + ELSE + CHKLOWQ(I,J)=1. + ENDIF + else + CHKLOWQ(I,J)=1. + endif + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if(CHKLOWQ(I,J).eq.0.) then + print *,'i,j,CHKLOWQ', & + i,j,CHKLOWQ(I,J) + endif + ENDIF + + MAVAIL (i,j) = LMAVAIL(I,J) +! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m + SNOW (i,j) = SNWE*1000. + SNOWH (I,J) = SNHEI + CANWAT (I,J) = CANWATR*1000. + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + ENDIF + QFX (I,J) = LH(I,J)/LV + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' QFX after change, LH ', i,j, QFX(i,j),LH(I,J) + ENDIF +!--- SNOWC snow cover flag + SNOWC(I,J)=SNOWFRAC + +! IF(SNOWH(I,J).GT.0.02)THEN +! SNOWC(I,J)=1.0 +! ELSE +! SNOWC(I,J)=0.0 +! ENDIF + + INFILTR(I,J) = INFILTRP + +!--- get 3d soil fields + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'LAND, i,j,tso1d,soilm1d - end of time step', & + i,j,tso1d,soilm1d + ENDIF + + do k=1,nzs + + soilmois(i,k,j) = soilm1d(k) +! If not initialized from the RUC model then add qmion back. +! soilmois(i,k,j) = (soilm1d(k)+qmin(i,j)) + tso(i,k,j) = tso1d(k) + enddo + + do k=1,nzs + smfr3d(i,k,j) = smfrkeep(k) + keepfr3dflag(i,k,j) = keepfr (k) + enddo + + ENDIF + + ENDDO + + ENDDO + +!----------------------------------------------------------------- + END SUBROUTINE LSMRUC +!----------------------------------------------------------------- + + + + SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & +!--- input variables + nzs,nddzs,nroot, & + ILAND,ISOIL,XLAND,IVGTYP, & + PRCPMS,NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN, & + PATM,TABS,QVATM,QCATM,rho, & + GLW,GSW,EMISS,QKMS,TKMS,PC, & + MAVAIL,CST,VEGFRA,ALB,ZNT, & + ALB_SNOW,ALB_SNOW_FREE, & + MYJ, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + cp,g0,lv,stbolt,cw,c1sn,c2sn, & + KQWRTZ,KICE,KWT, & +!--- output variables + snweprint,snheiprint,rsm, & + soilm1d,ts1d,smfrkeep,keepfr,soilt,soilt1, & + tsnav,dew,qvg,qsg,qcg, & + SMELT,SNOH,SNFLX,SNOM,ACSNOW, & + edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & + evapl,prcpl,runoff1,runoff2,soilice, & + soiliqw,infiltr) +!----------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------- + +!--- input variables + + INTEGER, INTENT(IN ) :: i,j,nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + + REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: C1SN,C2SN + LOGICAL, INTENT(IN ) :: myj +!--- 3-D Atmospheric variables + REAL , & + INTENT(IN ) :: PATM, & + TABS, & + QVATM, & + QCATM + REAL , & + INTENT(IN ) :: GLW, & + GSW, & + PC, & + ALB_SNOW, & + ALB_SNOW_FREE, & + VEGFRA, & + XLAND, & + RHO, & + QKMS, & + TKMS + + INTEGER, INTENT(IN ) :: IVGTYP +!--- 2-D variables + REAL , & + INTENT(INOUT) :: EMISS, & + MAVAIL, & + SNOWFRAC, & + ALB, & + CST + +!--- soil properties + REAL :: & + RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + SAT, & + WILT + + REAL, INTENT(IN ) :: CN, & + CW, & + CP, & + G0, & + LV, & + STBOLT, & + KQWRTZ, & + KICE, & + KWT + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TS1D, & + SOILM1D, & + SMFRKEEP + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: KEEPFR + + + INTEGER, INTENT(INOUT) :: ILAND,ISOIL + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: DEW, & + EDIR1, & + EC1, & + ETT1, & + EETA, & + EVAPL, & + INFILTR, & + RHOSN, & + SUBLIM, & + PRCPL, & + QVG, & + QSG, & + QCG, & + QFX, & + HFX, & + S, & + RUNOFF1, & + RUNOFF2, & + ACSNOW, & + SNWE, & + SNHEI, & + SMELT, & + SNOM, & + SNOH, & + SNFLX, & + SOILT, & + SOILT1, & + TSNAV, & + ZNT + +!-------- 1-d variables + REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW + + REAL, INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT +!--- Local variables + + INTEGER :: K,ILNB + + REAL :: BSN, XSN, RHONEWSN , & + RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & + T3, UPFLUX, XINET + REAL :: snhei_crit, keep_snow_albedo + + REAL :: RNET,GSWNEW,EMISSN,ALBSN,ZNTSN + REAL :: VEGFRAC + +!----------------------------------------------------------------- + integer, parameter :: ilsnow=99 + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & + SNWE,RHOSN,SNOM,SMELT,TS1D + ENDIF +! print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & +! IVGTYP,ISOIL,ILAND, & +! PRCPMS,SNWE,RHOSN, & +! PATM,TABS,QVATM,QCATM,rho +! GLW,GSW,EMISS,QKMS,TKMS,PC, & +! cst,vegfrac,alb,znt, & +!--- soil fixed fields +! QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & +! sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants +! cp,g0,lv,stbolt,cw,c1sn,c2sn, & +! KQWRTZ,KICE,KWT + + NEWSN=0. + RAINF = 0. + RSM=0. + INFILTR=0. + VEGFRAC=0.01*VEGFRA + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms + print *,'GSW, GLW, SOILT, STBOLT, EMISS', & + GSW, GLW, SOILT, STBOLT, EMISS + ENDIF + + + SNHEI = SNWE * 1000. / RHOSN +!-------------- + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + +!Calculate the amount (m) of fresh snow + + if(snhei.gt.0.0081*1.e3/rhosn) then +!*** Correct snow density for current temperature (Koren et al. 1999) + BSN=delt/3600.*c1sn*exp(0.08*tsnav-c2sn*rhosn*1.e-3) + if(bsn*snwe*100..lt.1.e-4) goto 777 + XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) + rhosn=MIN(MAX(100.,XSN),400.) +! rhosn=MIN(MAX(50.,XSN),400.) + 777 continue + + else + rhosn =200. + rhonewsn =100. + endif + +! IF(TABS.LE.273.15)THEN + + newsn=newsnms*delt +!--- consider for now that all PRCPMS went into snow +! prcpms = 0. +!---- ACSNOW - accumulation of snow water [m] + acsnow=acsnow+newsn + + IF(NEWSN.GE.1.E-8) THEN +!*** Calculate fresh snow density (t > -15C, else MIN value) +!*** Eq. 10 from Koren et al. (1999) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *, 'THERE IS NEW SNOW, newsn', newsn + ENDIF + if(tabs.lt.258.15) then +! rhonewsn=50. + rhonewsn=100. + + else + rhonewsn=1.e3*max((0.10+0.0017*(Tabs-273.15+15.)**1.5) & + , 0.10) +! rhonewsn=1.e3*max((0.05+0.0017*(Tabs-273.15+15.)**1.5) & +! , 0.05) + rhonewsn=MIN(rhonewsn,400.) +! rhonewsn=100. + endif + + +!*** Define average snow density of the snow pack considering +!*** the amount of fresh snow (eq. 9 in Koren et al.(1999) +!*** without snow melt ) + xsn=(rhosn*snwe+rhonewsn*newsn)/ & + (snwe+newsn) + rhosn=MIN(MAX(100.,XSN),400.) +! rhosn=MIN(MAX(50.,XSN),400.) + + snwe=snwe+newsn + snhei=snwe*1.E3/rhosn + NEWSN=NEWSN*1.E3/rhosn + endif + +! ELSE +!--- TABS is above freezing. Needed precip rates from microphysics +!--- to do a better job with mixed phase precip. + +! NEWSN = 0. +! +! ENDIF + + IF(PRCPMS.NE.0.) THEN + +! PRCPMS is liquid precipitation rate +! RAINF is a flag used for calculation of rain water +! heat content contribution into heat budget equation. Rain's temperature +! is set equal to air temperature at the first atmospheric +! level. + + RAINF=1. + ENDIF + +! IF((XLAND-1.5).GE.0.)THEN +! IF(ILAND.EQ.16) THEN +! SNHEI=0. +! SNWE=0. +! ELSE + + IF(SNHEI.GT.0.0) THEN +!--- Set of surface parameters should be changed to snow values for grid +!--- points where the snow cover exceeds snow threshold of 2 cm + EMISS = 0.91 + +! GSWNEW = GSW +! The following lines compute albedo depending on snow +! depth. For now commented out. +! alb_snow_free=0.2 +! alb_snow=0.70 +! SNHEI_CRIT=0.05 + + SNHEI_CRIT=0.01601*1.e3/rhosn + SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) + + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN.GT.0.) KEEP_SNOW_ALBEDO = 1. + +!--- GSW in-coming solar + GSWNEW=GSW/(1.-ALB) + + ALB = MAX(keep_snow_albedo*alb_snow, & + MIN((alb_snow_free + & + (alb_snow - alb_snow_free) * & + (snhei/(2.*SNHEI_CRIT))), alb_snow)) +!--- recompute absorbed solar radiation and net radiation +!--- for new value of albedo + gswnew=gswnew*(1.-alb) + + XINET = EMISS*(GLW-UPFLUX) + RNET = GSWnew + XINET + + CALL SNOWSOIL ( & !--- input variables + i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & + RHOSN,PATM,QVATM,QCATM, & + GLW,GSWnew,EMISS,RNET,IVGTYP, & + QKMS,TKMS,PC,CST, & + RHO,VEGFRAC,ALB,ZNT, & + MYJ, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,G0,cw,stbolt,tabs, & + KQWRTZ,KICE,KWT, & +!--- output variables + ilnb,snweprint,snheiprint,rsm, & + soilm1d,ts1d,smfrkeep,keepfr, & + dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & + SMELT,SNOH,SNFLX,SNOM,edir1,ec1,ett1,eeta, & + qfx,hfx,s,sublim,prcpl,runoff1,runoff2, & + mavail,soilice,soiliqw,infiltr ) + + if(snhei.eq.0.) then + +! if(snhei.le.2.e-2) then +!--- all snow is melted +! gswnew=gswnew/(1.-alb) + alb=alb_snow_free +! gswnew=gswnew*(1.-alb) + endif + + ELSE + + snheiprint=0. + snweprint=0. + + CALL SOIL( & +!--- input variables + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & + EMISS,RNET,QKMS,TKMS,PC,cst,rho,vegfrac, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt, & + psis,bclh,ksat,sat,cn, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,G0,cw,stbolt,tabs, & + KQWRTZ,KICE,KWT, & +!--- output variables + soilm1d,ts1d,smfrkeep,keepfr, & + dew,soilt,qvg,qsg,qcg,edir1,ec1, & + ett1,eeta,qfx,hfx,s,evapl,prcpl,runoff1, & + runoff2,mavail,soilice,soiliqw, & + infiltr) + + ENDIF +! ENDIF + +! + +! RETURN +! END +!--------------------------------------------------------------- + END SUBROUTINE SFCTMP +!--------------------------------------------------------------- + + + FUNCTION QSN(TN,T) +!**************************************************************** + REAL, DIMENSION(1:4001), INTENT(IN ) :: T + REAL, INTENT(IN ) :: TN + + REAL QSN, R,R1,R2 + INTEGER I + + R=(TN-173.15)/.05+1. + I=INT(R) + IF(I.GE.1) goto 10 + I=1 + R=1. + 10 IF(I.LE.4000) GOTO 20 + I=4000 + R=4001. + 20 R1=T(I) + R2=R-I + QSN=(T(I+1)-R1)*R2 + R1 +! print *,' in QSN, I,R,R1,R2,T(I+1),TN, QSN', I,R,r1,r2,t(i+1),tn,QSN +! RETURN +! END +!----------------------------------------------------------------------- + END FUNCTION QSN +!------------------------------------------------------------------------ + + + SUBROUTINE SOIL ( & +!--- input variables + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& + PRCPMS,RAINF,PATM,QVATM,QCATM, & + GLW,GSW,EMISS,RNET, & + QKMS,TKMS,PC,cst,rho,vegfrac, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + xlv,CP,G0_P,cw,stbolt,TABS, & + KQWRTZ,KICE,KWT, & +!--- output variables + soilmois,tso,smfrkeep,keepfr, & + dew,soilt,qvg,qsg,qcg, & + edir1,ec1,ett1,eeta,qfx,hfx,s,evapl, & + prcpl,runoff1,runoff2,mavail,soilice, & + soiliqw,infiltrp) + +!************************************************************* +! Energy and moisture budget for vegetated surfaces +! without snow, heat diffusion amf Richards eqns. in +! soil +! +! DELT - time step (s) +! ktau - numver of time step +! CONFLX - depth of constant flux layer (m) +! J,I - the location of grid point +! IME, JME, KME, NZS - dimensions of the domain +! NROOT - number of levels within the root zone +! PRCPMS - precipitation rate in m/s +! PATM - pressure [bar] +! QVATM,QCATM - cloud and water vapor mixing ratio (kg/kg) +! at the first atm. level +! GLW, GSW - incoming longwave and absorbed shortwave +! radiation at the surface (W/m^2) +! EMISS,RNET - emissivity of the ground surface (0-1) and net +! radiation at the surface (W/m^2) +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TKMS - exchange coefficient for heat in the surface +! layer (m/s) +! PC - plant coefficient (resistance) (0-1) +! RHO - density of atmosphere near sueface (kg/m^3) +! VEGFRAC - greeness fraction +! RHOCS - volumetric heat capacity of dry soil +! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) +! REF, WILT - field capacity soil moisture and the +! wilting point (m^3/m^3) +! PSIS - matrix potential at saturation (m) +! BCLH - exponent for Clapp-Hornberger parameterization +! KSAT - saturated hydraulic conductivity (m/s) +! SAT - maximum value of water intercepted by canopy (m) +! CN - exponent for calculation of canopy water +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil +! TBQ - table to define saturated mixing ration +! of water vapor for given temperature and pressure +! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) +! DEW - dew in kg/m^2s +! SOILT - skin temperature (K) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of +! canopy water, transpiration in kg m-2 s-1 and total +! evaporation in m s-1. +! QFX, HFX - latent and sensible heat fluxes (W/m^2) +! S - soil heat flux in the top layer (W/m^2) +! RUNOFF - surface runoff (m/s) +! RUNOFF2 - underground runoff (m) +! MAVAIL - moisture availability in the top soil layer (0-1) +! INFILTRP - infiltration flux from the top of soil domain (m/s) +! +!***************************************************************** + IMPLICIT NONE +!----------------------------------------------------------------- + +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,iland,isoil + REAL, INTENT(IN ) :: DELT,CONFLX +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL, & + INTENT(IN ) :: GLW, & + GSW, & + EMISS, & + RHO, & + PC, & + VEGFRAC, & + QKMS, & + TKMS + +!--- soil properties + REAL, & + INTENT(IN ) :: RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + WILT + + REAL, INTENT(IN ) :: CN, & + CW, & + KQWRTZ, & + KICE, & + KWT, & + XLV, & + g0_p + + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO, & + SOILMOIS, & + SMFRKEEP + + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: KEEPFR + +!-------- 2-d variables + REAL, & + INTENT(INOUT) :: DEW, & + CST, & + EDIR1, & + EC1, & + ETT1, & + EETA, & + EVAPL, & + PRCPL, & + MAVAIL, & + QVG, & + QSG, & + QCG, & + RNET, & + QFX, & + HFX, & + S, & + SAT, & + RUNOFF1, & + RUNOFF2, & + SOILT + +!-------- 1-d variables + REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW + +!--- Local variables + + REAL :: INFILTRP, transum , & + RAINF, PRCPMS , & + TABS, T3, UPFLUX, XINET + REAL :: CP,G0,LV,STBOLT,xlmelt,dzstop , & + can,epot,fac,fltot,ft,fq,hft , & + q1,ras,rhoice,sph , & + trans,zn,ci,cvw,tln,tavln,pi , & + DD1,CMC2MS,DRYCAN,WETCAN , & + INFMAX,RIW + REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + thdif,tranf,tav,soilmoism , & + soilicem,soiliqwm,detal , & + fwsat,lwsat,told,smold + + REAL :: drip + + INTEGER :: nzs1,nzs2,k + +!----------------------------------------------------------------- + +!-- define constants +! STBOLT=5.670151E-8 + RHOICE=900. + CI=RHOICE*2100. + XLMELT=3.335E+5 + cvw=cw + + SAT=0.0005 + prcpl=prcpms + +!--- Initializing local arrays + DO K=1,NZS + TRANSP (K)=0. + soilmoism(k)=0. + soilice (k)=0. + soiliqw (k)=0. + soilicem (k)=0. + soiliqwm (k)=0. + lwsat (k)=0. + fwsat (k)=0. + tav (k)=0. + cap (k)=0. + thdif (k)=0. + diffu (k)=0. + hydro (k)=0. + tranf (k)=0. + detal (k)=0. + told (k)=0. + smold (k)=0. + ENDDO + + NZS1=NZS-1 + NZS2=NZS-2 + dzstop=1./(zsmain(2)-zsmain(1)) + RAS=RHO*1.E-3 + RIW=rhoice*1.e-3 + +!--- Computation of volumetric content of ice in soil + + DO K=1,NZS +!- main levels + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/RIW + +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + + ENDDO + + DO K=1,NZS1 +!- middle of soil layers + tav(k)=0.5*(tso(k)+tso(k+1)) + soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) + tavln=log(tav(k)/273.15) + + if(tavln.lt.0.) then + soiliqwm(k)=(dqm+qmin)*(XLMELT* & + (tav(k)-273.15)/tav(k)/9.81/psis) & + **(-1./bclh)-qmin + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) + soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilicem(k)=min(soilicem(k), & + 0.5*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + endif + + else + soilicem(k)=0. + soiliqwm(k)=soilmoism(k) + lwsat(k)=dqm+qmin + fwsat(k)=0. + endif + + ENDDO + + do k=1,nzs + if(soilice(k).gt.0.) then + smfrkeep(k)=soilice(k) + else + smfrkeep(k)=soilmois(k)/riw + endif + enddo + +!****************************************************************** +! SOILPROP computes thermal diffusivity, and diffusional and +! hydraulic condeuctivities +!****************************************************************** + CALL SOILPROP( & +!--- input variables + nzs,fwsat,lwsat,tav,keepfr, & + soilmois,soiliqw,soilice, & + soilmoism,soiliqwm,soilicem, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & +!--- constants + riw,xlmelt,CP,G0_P,cvw,ci, & + kqwrtz,kice,kwt, & +!--- output variables + thdif,diffu,hydro,cap) + +!******************************************************************** +!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW + + DRIP=0. + DD1=0. + + FQ=QKMS + + Q1=-QKMS*RAS*(QVATM - QSG) + + DEW=0. + IF(QVATM.GE.QSG)THEN + DEW=FQ*(QVATM-QSG) + ENDIF + IF(DEW.NE.0.)THEN + DD1=CST+DELT*(PRCPMS +DEW*RAS)*vegfrac + ELSE + DD1=CST+ & + DELT*(PRCPMS+RAS*FQ*(QVATM-QSG) & + *(CST/SAT)**CN)*vegfrac + ENDIF + + IF(DD1.LT.0.) DD1=0. + if(vegfrac.eq.0.)then + cst=0. + drip=0. + endif + IF (vegfrac.GT.0.) THEN + CST=DD1 + IF(CST.GT.SAT) THEN + CST=SAT + DRIP=DD1-SAT + ENDIF + ENDIF + +!--- WETCAN is the fraction of vegetated area covered by canopy +!--- water, and DRYCAN is the fraction of vegetated area where +!--- transpiration may take place. + + WETCAN=(CST/SAT)**CN + DRYCAN=1.-WETCAN + +! print *,'CST,DRIP',cst,drip + +!************************************************************** +! TRANSF computes transpiration function +!************************************************************** + CALL TRANSF( & +!--- input variables + nzs,nroot,soiliqw, & +!--- soil fixed fields + dqm,qmin,ref,wilt,zshalf, & +!--- output variables + tranf,transum) + + +!--- Save soil temp and moisture from the beginning of time step + do k=1,nzs + told(k)=tso(k) + smold(k)=soilmois(k) + enddo + +!************************************************************** +! SOILTEMP soilves heat budget and diffusion eqn. in soil +!************************************************************** + + CALL SOILTEMP( & +!--- input variables + i,j,iland,isoil, & + delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF, & + PATM,TABS,QVATM,QCATM,EMISS,RNET, & + QKMS,TKMS,PC,rho,vegfrac, & + thdif,cap,drycan,wetcan, & + transum,dew,mavail, & +!--- soil fixed fields + dqm,qmin,bclh,zsmain,zshalf,DTDZS,tbq, & +!--- constants + xlv,CP,G0_P,cvw,stbolt, & +!--- output variables + tso,soilt,qvg,qsg,qcg) + +!************************************************************************ + +!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW + ETT1=0. + DEW=0. + + IF(QVATM.GE.QSG)THEN + DEW=QKMS*(QVATM-QSG) + DO K=1,NZS + TRANSP(K)=0. + ENDDO + ELSE + DO K=1,NROOT + TRANSP(K)=VEGFRAC*RAS*QKMS* & + (QVATM-QSG)* & + PC*TRANF(K)*DRYCAN/ZSHALF(NROOT+1) + IF(TRANSP(K).GT.0.) TRANSP(K)=0. + ETT1=ETT1-TRANSP(K) + ENDDO + DO k=nroot+1,nzs + transp(k)=0. + enddo + ENDIF + +!-- Recalculating of volumetric content of frozen water in soil + DO K=1,NZS +!- main levels + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + ENDDO + + INFMAX=999. +!--- The threshold when the infiltration stops is: +!--- volumetric content of unfrozen pores < 0.12 + if((dqm+qmin-riw*soilicem(1)).lt.0.12) & + INFMAX=0. + +!************************************************************************* +! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) +! and Richards eqn. +!************************************************************************* + CALL SOILMOIST ( & +!-- input + delt,nzs,nddzs,DTDZS,DTDZS2, & + zsmain,zshalf,diffu,hydro, & + QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & + QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & +!-- soil properties + DQM,QMIN,REF,KSAT,RAS,INFMAX, & +!-- output + SOILMOIS,MAVAIL,RUNOFF1, & + RUNOFF2,INFILTRP) + +!--- KEEPFR is 1 when the temperature and moisture in soil +!--- are both increasing. In this case soil ice should not +!--- be increasing according to the freezing curve. +!--- Some part of ice is melted, but additional water is +!--- getting frozen. Thus, only structure of frozen soil is +!--- changed, and phase changes are not affecting the heat +!--- transfer. This situation may happen when it rains on the +!--- frozen soil. + + do k=1,nzs + if (soilice(k).gt.0.) then + if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then + keepfr(k)=1. + else + keepfr(k)=0. + endif + endif + enddo +!--- THE DIAGNOSTICS OF SURFACE FLUXES + + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + HFT=-TKMS*CP*RHO*(TABS-SOILT) + Q1=-QKMS*RAS*(QVATM - QSG) + EDIR1 =-(1.-vegfrac)*QKMS*RAS* & + (QVATM-QVG) + IF (Q1.LE.0.) THEN +! --- condensation + EC1=0. + EDIR1=0. + ETT1=0. + EETA=0. + QFX=- XLV*RHO*DEW + ELSE +! --- evaporation + EC1 = Q1 * WETCAN + CMC2MS=CST/DELT + if(EC1.gt.CMC2MS) cst=0. + EC1=MIN(CMC2MS,EC1)*vegfrac + EETA = (EDIR1 + EC1 + ETT1)*1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= XLV * EETA + ENDIF + EVAPL=QFX/XLV + S=THDIF(1)*CAP(1)*DZSTOP*(TSO(1)-TSO(2)) + HFX=HFT + FLTOT=RNET-HFT-QFX-S + + 222 CONTINUE + + 1123 FORMAT(I5,8F12.3) + 1133 FORMAT(I7,8E12.4) + 123 format(i6,f6.2,7f8.1) + 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) + + +! RETURN +! END +!------------------------------------------------------------------- + END SUBROUTINE SOIL +!------------------------------------------------------------------- + + + SUBROUTINE SNOWSOIL ( & +!--- input variables + i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & + RHOSN, & + PATM,QVATM,QCATM, & + GLW,GSW,EMISS,RNET,IVGTYP, & + QKMS,TKMS,PC,cst,rho,vegfrac,alb,znt, & + MYJ, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + xlv,CP,G0_P,cw,stbolt,TABS, & + KQWRTZ,KICE,KWT, & +!--- output variables + ilnb,snweprint,snheiprint,rsm, & + soilmois,tso,smfrkeep,keepfr, & + dew,soilt,soilt1,tsnav, & + qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & + edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & + prcpl,runoff1,runoff2,mavail,soilice, & + soiliqw,infiltrp ) + +!*************************************************************** +! Energy and moisture budget for snow, heat diffusion eqns. +! in snow and soil, Richards eqn. for soil covered with snow +! +! DELT - time step (s) +! ktau - numver of time step +! CONFLX - depth of constant flux layer (m) +! J,I - the location of grid point +! IME, JME, NZS - dimensions of the domain +! NROOT - number of levels within the root zone +! PRCPMS - precipitation rate in m/s +! NEWSNOW - pcpn in soilid form (m) +! SNHEI, SNWE - snow height and snow water equivalent (m) +! RHOSN - snow density (kg/m-3) +! PATM - pressure (bar) +! QVATM,QCATM - cloud and water vapor mixing ratio +! at the first atm. level (kg/kg) +! GLW, GSW - incoming longwave and absorbed shortwave +! radiation at the surface (W/m^2) +! EMISS,RNET - emissivity (0-1) of the ground surface and net +! radiation at the surface (W/m^2) +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TKMS - exchange coefficient for heat in the surface +! layer (m/s) +! PC - plant coefficient (resistance) (0-1) +! RHO - density of atmosphere near surface (kg/m^3) +! VEGFRAC - greeness fraction (0-1) +! RHOCS - volumetric heat capacity of dry soil (J/m^3/K) +! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) +! REF, WILT - field capacity soil moisture and the +! wilting point (m^3/m^3) +! PSIS - matrix potential at saturation (m) +! BCLH - exponent for Clapp-Hornberger parameterization +! KSAT - saturated hydraulic conductivity (m/s) +! SAT - maximum value of water intercepted by canopy (m) +! CN - exponent for calculation of canopy water +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil +! TBQ - table to define saturated mixing ration +! of water vapor for given temperature and pressure +! ilnb - number of layers in snow +! rsm - liquid water inside snow pack (m) +! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) +! DEW - dew in (kg/m^2 s) +! SOILT - skin temperature (K) +! SOILT1 - snow temperature at 7.5 cm depth (K) +! TSNAV - average temperature of snow pack (C) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of +! canopy water, transpiration (kg m-2 s-1) and total +! evaporation in (m s-1). +! QFX, HFX - latent and sensible heat fluxes (W/m^2) +! S - soil heat flux in the top layer (W/m^2) +! SUBLIM - snow sublimation (kg/m^2/s) +! RUNOFF1 - surface runoff (m/s) +! RUNOFF2 - underground runoff (m) +! MAVAIL - moisture availability in the top soil layer (0-1) +! SOILICE - content of soil ice in soil layers (m^3/m^3) +! SOILIQW - lliquid water in soil layers (m^3/m^3) +! INFILTRP - infiltration flux from the top of soil domain (m/s) +! XINET - net long-wave radiation (W/m^2) +! +!******************************************************************* + + IMPLICIT NONE +!------------------------------------------------------------------- +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,isoil + + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + RAINF,NEWSNOW + + LOGICAL, INTENT(IN ) :: myj + +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL , & + INTENT(IN ) :: GLW, & + GSW, & + RHO, & + PC, & + VEGFRAC, & + QKMS, & + TKMS + + INTEGER, INTENT(IN ) :: IVGTYP +!--- soil properties + REAL , & + INTENT(IN ) :: RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + SAT, & + WILT + + REAL, INTENT(IN ) :: CN, & + CW, & + XLV, & + G0_P, & + KQWRTZ, & + KICE, & + KWT + + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO, & + SOILMOIS, & + SMFRKEEP + + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: KEEPFR + + + INTEGER, INTENT(INOUT) :: ILAND + + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: DEW, & + CST, & + EDIR1, & + EC1, & + ETT1, & + EETA, & + RHOSN, & + SUBLIM, & + PRCPL, & + ALB, & + EMISS, & + ZNT, & + MAVAIL, & + QVG, & + QSG, & + QCG, & + QFX, & + HFX, & + S, & + RUNOFF1, & + RUNOFF2, & + SNWE, & + SNHEI, & + SMELT, & + SNOM, & + SNOH, & + SNFLX, & + SOILT, & + SOILT1, & + SNOWFRAC, & + TSNAV + + INTEGER, INTENT(INOUT) :: ILNB + +!-------- 1-d variables + REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW + + REAL, INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT +!--- Local variables + + + INTEGER :: nzs1,nzs2,k + + REAL :: INFILTRP, RHONEWSN,TRANSUM , & + SNTH, NEWSN , & + TABS, T3, UPFLUX, XINET , & + BETA, SNWEPR,EPDT,PP + REAL :: CP,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & + can,epot,fac,fltot,ft,fq,hft , & + q1,ras,rhoice,sph , & + trans,zn,ci,cvw,tln,tavln,pi , & + DD1,CMC2MS,DRYCAN,WETCAN , & + INFMAX,RIW,DELTSN,H,UMVEG + + REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + thdif,tranf,tav,soilmoism , & + soilicem,soiliqwm,detal , & + fwsat,lwsat,told,smold + REAL :: drip + + REAL :: RNET + +!----------------------------------------------------------------- + + cvw=cw + XLMELT=3.335E+5 +!-- the next line calculates heat of sublimation of water vapor + XLVm=XLV+XLMELT +! STBOLT=5.670151E-8 + +!--- SNOW flag -- 99 + ILAND=99 + +!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. +!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, +!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is +!--- computed using SNWE=0.03 m and current snow density. +!--- SNTH - the threshold below which the snow layer is combined with +!--- the top soil layer. SNTH is computed using snwe=0.016 m, and +!--- equals 4 cm for snow density 400 kg/m^3. + + DELTSN=0.0301*1.e3/rhosn + snth=0.01601*1.e3/rhosn + + RHOICE=900. + CI=RHOICE*2100. + RAS=RHO*1.E-3 + RIW=rhoice*1.e-3 + MAVAIL=1. + RSM=0. + + DO K=1,NZS + TRANSP (K)=0. + soilmoism (k)=0. + soiliqwm (k)=0. + soilice (k)=0. + soilicem (k)=0. + lwsat (k)=0. + fwsat (k)=0. + tav (k)=0. + cap (k)=0. + diffu (k)=0. + hydro (k)=0. + thdif (k)=0. + tranf (k)=0. + detal (k)=0. + told (k)=0. + smold (k)=0. + ENDDO + + snweprint=0. + snheiprint=0. + prcpl=prcpms + +!*** DELTSN is the depth of the top layer of snow where +!*** there is a temperature gradient, the rest of the snow layer +!*** is considered to have constant temperature + + + NZS1=NZS-1 + NZS2=NZS-2 + DZSTOP=1./(zsmain(2)-zsmain(1)) + +!----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- +!----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- +!tgs - the following loop is added to define the amount of frozen +!tgs - water in soil if there is any + DO K=1,NZS + + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/riw + +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + + ENDDO + + DO K=1,NZS1 + + tav(k)=0.5*(tso(k)+tso(k+1)) + soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) + tavln=log(tav(k)/273.15) + + if(tavln.lt.0.) then + soiliqwm(k)=(dqm+qmin)*(XLMELT* & + (tav(k)-273.15)/tav(k)/9.81/psis) & + **(-1./bclh)-qmin + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) + soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilicem(k)=min(soilicem(k), & + 0.5*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + endif + + else + soilicem(k)=0. + soiliqwm(k)=soilmoism(k) + lwsat(k)=dqm+qmin + fwsat(k)=0. + + endif + ENDDO + + do k=1,nzs + if(soilice(k).gt.0.) then + smfrkeep(k)=soilice(k) + else + smfrkeep(k)=soilmois(k)/riw + endif + enddo + + +! print *,'etaf,etal,etamf,etaml,lwsat,fwsat', +! 1 soilice,soiliqw,soilicem,soiliqwm,lwsat,fwsat + +!****************************************************************** +! SOILPROP computes thermal diffusivity, and diffusional and +! hydraulic condeuctivities +!****************************************************************** + CALL SOILPROP( & +!--- input variables + nzs,fwsat,lwsat,tav,keepfr, & + soilmois,soiliqw,soilice, & + soilmoism,soiliqwm,soilicem, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & +!--- constants + riw,xlmelt,CP,G0_P,cvw,ci, & + kqwrtz,kice,kwt, & +!--- output variables + thdif,diffu,hydro,cap) + +!******************************************************************** +!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW + + DRIP=0. + SMELT=0. + DD1=0. + H=1. + + FQ=QKMS + + +!--- If vegfrac.ne.0. then part of falling snow can be +!--- intercepted by the canopy. + + DEW=0. + UMVEG=1.-vegfrac + EPOT = -FQ*(QVATM-QSG) + + IF(vegfrac.EQ.0.) then + cst=0. + drip=0. + ELSE + IF(EPOT.GE.0.) THEN +! Evaporation + DD1=CST+(NEWSNOW*RHOSN*1.E-3 & +!-- need to think more if we want this change.... + -DELT*(RAS*EPOT & +! -DELT*(-PRCPMS+RAS*EPOT & + *(CST/SAT)**CN)) *vegfrac + ELSE +! Sublimation + DEW = - EPOT + DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*( & +! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*(PRCPMS & + +DEW*RAS)) *vegfrac + ENDIF + + IF(DD1.LT.0.) DD1=0. + IF (vegfrac.GT.0.) THEN + CST=DD1 + IF(CST.GT.SAT) THEN + CST=SAT + DRIP=DD1-SAT + ENDIF + ENDIF + + +!--- In SFCTMP NEWSNOW is added to SNHEI as if there is no vegetation +!--- With vegetation part of NEWSNOW can be intercepted by canopy until +!--- the saturation is reached. After the canopy saturation is reached +!--- DRIP in the solid form will be added to SNOW cover. + + SNWE=(SNHEI-vegfrac*NEWSNOW)*RHOSN*1.E-3 & + + DRIP & +! - 10% of liquid precip could be added to snow water +! - this is based on SnowMIP2. +! - something more intelligent should be done to liquid water + +0.10*prcpms*delt + + + ENDIF + + DRIP=0. + SNHEI=SNWE*1.e3/RHOSN + SNWEPR=SNWE + +! check if all snow can evaporate during DT + BETA=1. + EPDT = EPOT * RAS *DELT*UMVEG + IF(SNWEPR.LE.EPDT) THEN + BETA=SNWEPR/max(1.e-8,EPDT) + SNWE=0. + SNHEI=0. + ENDIF + + WETCAN=(CST/SAT)**CN + DRYCAN=1.-WETCAN + +!************************************************************** +! TRANSF computes transpiration function +!************************************************************** + CALL TRANSF( & +!--- input variables + nzs,nroot,soiliqw, & +!--- soil fixed fields + dqm,qmin,ref,wilt,zshalf, & +!--- output variables + tranf,transum) + +!--- Save soil temp and moisture from the beginning of time step + do k=1,nzs + told(k)=tso(k) + smold(k)=soilmois(k) + enddo + +!************************************************************** +! SOILTEMP soilves heat budget and diffusion eqn. in soil +!************************************************************** + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *, 'TSO before calling SNOWTEMP: ', tso + ENDIF + CALL SNOWTEMP( & +!--- input variables + i,j,iland,isoil, & + delt,ktau,conflx,nzs,nddzs,nroot, & + snwe,snwepr,snhei,newsnow,snowfrac, & + beta,deltsn,snth,rhosn, & + PRCPMS,RAINF, & + PATM,TABS,QVATM,QCATM, & + GLW,GSW,EMISS,RNET, & + QKMS,TKMS,PC,rho,vegfrac, & + thdif,cap,drycan,wetcan,cst, & + tranf,transum,dew,mavail, & +!--- soil fixed fields + dqm,qmin,psis,bclh, & + zsmain,zshalf,DTDZS,tbq, & +!--- constants + xlvm,CP,G0_P,cvw,stbolt, & +!--- output variables + snweprint,snheiprint,rsm, & + tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & + smelt,snoh,snflx,ilnb) + +!************************************************************************ +!--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW + DEW=0. + ETT1=0. + PP=PATM*1.E3 + QSG= QSN(SOILT,TBQ)/PP + EPOT = -FQ*(QVATM-QSG) + IF(EPOT.GE.0.) THEN +! Evaporation + DO K=1,NROOT + TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & + *PC*tranf(K)*DRYCAN/zshalf(NROOT+1) + IF(TRANSP(K).GT.0.) TRANSP(K)=0. + ETT1=ETT1-TRANSP(K) + ENDDO + DO k=nroot+1,nzs + transp(k)=0. + enddo + + ELSE +! Sublimation + DEW=-EPOT + DO K=1,NZS + TRANSP(K)=0. + ENDDO + ETT1=0. + ENDIF + +!-- recalculating of frozen water in soil + DO K=1,NZS + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + ENDDO + + INFMAX=999. +!--- The threshold when the infiltration stops is: +!--- volumetric content of unfrozen pores < 0.12 + soilicem(1)=0.5*(soilice(1)+soilice(2)) + if((dqm+qmin-riw*soilicem(1)).lt.0.12) & + INFMAX=0. + +!************************************************************************* +!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) +! AND TSO,ETA PROFILES +!************************************************************************* + CALL SOILMOIST ( & +!-- input + delt,nzs,nddzs,DTDZS,DTDZS2, & + zsmain,zshalf,diffu,hydro, & + QSG,QVG,QCG,QCATM,QVATM,-0.9*PRCPMS/(1.-vegfrac), & +! QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & + 0.,TRANSP,0., & + 0.,SMELT,soilice,vegfrac, & +!-- soil properties + DQM,QMIN,REF,KSAT,RAS,INFMAX, & +!-- output + soilmois,MAVAIL,RUNOFF1, & + RUNOFF2,infiltrp) + +!-- Restore land-use parameters if snow is less than threshold + IF(SNHEI.EQ.0.) then + tsnav=soilt-273.15 + CALL SNOWFREE(ivgtyp,myj,emiss, & + znt,iland) + smelt=smelt+snwe/delt + rsm=0. +! snwe=0. + ENDIF + + SNOM=SNOM+SMELT*DELT + +!--- KEEPFR is 1 when the temperature and moisture in soil +!--- are both increasing. In this case soil ice should not +!--- be increasing according to the freezing curve. +!--- Some part of ice is melted, but additional water is +!--- getting frozen. Thus, only structure of frozen soil is +!--- changed, and phase changes are not affecting the heat +!--- transfer. This situation may happen when it rains on the +!--- frozen soil. + + do k=1,nzs + if (soilice(k).gt.0.) then + if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then + keepfr(k)=1. + else + keepfr(k)=0. + endif + endif + enddo +!--- THE DIAGNOSTICS OF SURFACE FLUXES + + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + HFT=- TKMS*CP*RHO*(TABS-SOILT) + Q1 = - FQ*RAS* (QVATM - QSG) + EDIR1 = Q1*UMVEG *BETA + + IF (Q1.LT.0.) THEN +! --- condensation + EC1=0. + EDIR1=0. + ETT1=0. + EETA=0. + DEW=FQ*(QVATM-QSG) + QFX= -XLVm*RHO*DEW + sublim=QFX/XLVm + ELSE +! --- evaporation + EC1 = Q1 * WETCAN + CMC2MS=CST/DELT + if(EC1.gt.CMC2MS) cst=0. + EC1=MIN(CMC2MS,EC1)*vegfrac + EETA = (EDIR1 + EC1 + ETT1)*1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= XLVm * EETA + sublim=(EDIR1 + EC1)*1.E3 + ENDIF + s=THDIF(1)*CAP(1)*dzstop*(tso(1)-tso(2)) + HFX=HFT + FLTOT=RNET-HFT-QFX-S + + 222 CONTINUE + + 1123 FORMAT(I5,8F12.3) + 1133 FORMAT(I7,8E12.4) + 123 format(i6,f6.2,7f8.1) + 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) + + +! RETURN +! END +!------------------------------------------------------------------- + END SUBROUTINE SNOWSOIL +!------------------------------------------------------------------- + + + SUBROUTINE SOILTEMP( & +!--- input variables + i,j,iland,isoil, & + delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & + EMISS,RNET, & + QKMS,TKMS,PC,RHO,VEGFRAC, & + THDIF,CAP,DRYCAN,WETCAN, & + TRANSUM,DEW,MAVAIL, & +!--- soil fixed fields + DQM,QMIN,BCLH, & + ZSMAIN,ZSHALF,DTDZS,TBQ, & +!--- constants + XLV,CP,G0_P,CVW,STBOLT, & +!--- output variables + TSO,SOILT,QVG,QSG,QCG) + +!************************************************************* +! Energy budget equation and heat diffusion eqn are +! solved here and +! +! DELT - time step (s) +! ktau - numver of time step +! CONFLX - depth of constant flux layer (m) +! IME, JME, KME, NZS - dimensions of the domain +! NROOT - number of levels within the root zone +! PRCPMS - precipitation rate in m/s +! COTSO, RHTSO - coefficients for implicit solution of +! heat diffusion equation +! THDIF - thermal diffusivity (m^2/s) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! PATM - pressure [baa] +! QC3D,QV3D - cloud and water vapor mixing ratio +! at the first atm. level (kg/kg) +! EMISS,RNET - emissivity (0-1) of the ground surface and net +! radiation at the surface (W/m^2) +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TKMS - exchange coefficient for heat in the surface +! layer (m/s) +! PC - plant coefficient (resistance) +! RHO - density of atmosphere near surface (kg/m^3) +! VEGFRAC - greeness fraction (0-1) +! CAP - volumetric heat capacity (J/m^3/K) +! DRYCAN - dry fraction of vegetated area where +! transpiration may take place (0-1) +! WETCAN - fraction of vegetated area covered by canopy +! water (0-1) +! TRANSUM - transpiration function integrated over the +! rooting zone (m) +! DEW - dew in kg/m^2s +! MAVAIL - fraction of maximum soil moisture in the top +! layer (0-1) +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS - dt/(2.*dzshalf*dzmain) +! TBQ - table to define saturated mixing ration +! of water vapor for given temperature and pressure +! TSO - soil temperature (K) +! SOILT - skin temperature (K) +! +!**************************************************************** + + IMPLICIT NONE +!----------------------------------------------------------------- + +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,iland,isoil + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL , & + INTENT(IN ) :: & + EMISS, & + RHO, & + RNET, & + PC, & + VEGFRAC, & + DEW, & + QKMS, & + TKMS + +!--- soil properties + REAL , & + INTENT(IN ) :: & + BCLH, & + DQM, & + QMIN + + REAL, INTENT(IN ) :: CP, & + CVW, & + XLV, & + STBOLT, & + TABS, & + G0_P + + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + THDIF, & + CAP + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: & + MAVAIL, & + QVG, & + QSG, & + QCG, & + SOILT + + +!--- Local variables + + REAL :: x,x1,x2,x4,dzstop,can,ft,sph , & + tn,trans,umveg,denom + + REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM + + REAL :: C,CC,AA1,RHCS,H1 + + REAL, DIMENSION(1:NZS) :: cotso,rhtso + + INTEGER :: nzs1,nzs2,k,k1,kn,kk + +!----------------------------------------------------------------- + + + NZS1=NZS-1 + NZS2=NZS-2 + dzstop=1./(ZSMAIN(2)-ZSMAIN(1)) + + do k=1,nzs + cotso(k)=0. + rhtso(k)=0. + enddo +!****************************************************************************** +! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO +!****************************************************************************** +! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) +! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did +! cotso(1)=h1/(1.+h1) +! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ +! 1 (1.+h1) + cotso(1)=0. + rhtso(1)=TSO(NZS) + DO 33 K=1,NZS2 + KN=NZS-K + K1=2*KN-3 + X1=DTDZS(K1)*THDIF(KN-1) + X2=DTDZS(K1+1)*THDIF(KN) + FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & + -X2*(TSO(KN)-TSO(KN+1)) + DENOM=1.+X1+X2-X2*cotso(K) + cotso(K+1)=X1/DENOM + rhtso(K+1)=(FT+X2*rhtso(K))/DENOM + 33 CONTINUE + +!************************************************************************ +!--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) + + RHCS=CAP(1) + H=MAVAIL + IF(DEW.NE.0.)THEN + DRYCAN=0. + WETCAN=1. + ENDIf + TRANS=PC*TRANSUM*DRYCAN/ZSHALF(NROOT+1) + CAN=WETCAN+TRANS + UMVEG=1.-VEGFRAC + FKT=TKMS + D1=cotso(NZS1) + D2=rhtso(NZS1) + TN=SOILT + D9=THDIF(1)*RHCS*dzstop + D10=TKMS*CP*RHO + R211=.5*CONFLX/DELT + R21=R211*CP*RHO + R22=.5/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5*TN**4 + R7=R6/TN + D11=RNET+R6 + TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + +RAINF*CVW*PRCPMS + FKQ=QKMS*RHO + R210=R211*RHO + C=VEGFRAC*FKQ*CAN + CC=C*XLV/TDENOM + AA=XLV*(FKQ*UMVEG+R210)/TDENOM + BB=(D10*TABS+R21*TN+XLV*(QVATM* & + (FKQ*UMVEG+C) & + +R210*QVG)+D11+D9*(D2+R22*TN) & + +RAINF*CVW*PRCPMS*max(273.15,TABS) & + )/TDENOM + AA1=AA+CC + PP=PATM*1.E3 + AA1=AA1/PP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + PRINT *,' VILKA-1' + print *,'D10,TABS,R21,TN,QVATM,FKQ,UMVEG,VEGFRAC,CAN', & + D10,TABS,R21,TN,QVATM,FKQ,UMVEG,VEGFRAC,CAN + print *,'RNET, EMISS, STBOLT, SOILT',RNET, EMISS, STBOLT, SOILT + print *,'R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM', & + R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM + print *,'tn,aa1,bb,pp,umveg,fkq,r210,vegfrac', & + tn,aa1,bb,pp,umveg,fkq,r210,vegfrac + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + TQ2=QVATM+QCATM + TX2=TQ2*(1.-H) + Q1=TX2+H*QS1 + IF(Q1.LT.QS1) GOTO 100 +!--- if no saturation - goto 100 +!--- if saturation - goto 90 + 90 QVG=QS1 + QSG=QS1 + TSO(1)=TS1 + QCG=Q1-QS1 + GOTO 200 + 100 BB=BB-AA*TX2 + AA=(AA*H+CC)/PP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + PRINT *,' VILKA-2' + print *,'D10,TABS,R21,TN,QVATM,FKQ,UMVEG,VEGFRAC,CAN', & + D10,TABS,R21,TN,QVATM,FKQ,UMVEG,VEGFRAC,CAN + print *,'R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM', & + R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM + + print *,'tn,aa1,bb,pp,umveg,fkq,r210,vegfrac', & + tn,aa1,bb,pp,umveg,fkq,r210,vegfrac + ENDIF + + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + Q1=TX2+H*QS1 + IF(Q1.GT.QS1) GOTO 90 + QSG=QS1 + QVG=Q1 + TSO(1)=TS1 + QCG=0. + 200 CONTINUE + +!--- SOILT - skin temperature + SOILT=TS1 + +!---- Final solution for soil temperature - TSO + DO K=2,NZS + KK=NZS-K+1 + TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) + END DO + +! return +! end +!-------------------------------------------------------------------- + END SUBROUTINE SOILTEMP +!-------------------------------------------------------------------- + + + SUBROUTINE SNOWTEMP( & +!--- input variables + i,j,iland,isoil, & + delt,ktau,conflx,nzs,nddzs,nroot, & + snwe,snwepr,snhei,newsnow,snowfrac, & + beta,deltsn,snth,rhosn, & + PRCPMS,RAINF, & + PATM,TABS,QVATM,QCATM, & + GLW,GSW,EMISS,RNET, & + QKMS,TKMS,PC,RHO,VEGFRAC, & + THDIF,CAP,DRYCAN,WETCAN,CST, & + TRANF,TRANSUM,DEW,MAVAIL, & +!--- soil fixed fields + DQM,QMIN,PSIS,BCLH, & + ZSMAIN,ZSHALF,DTDZS,TBQ, & +!--- constants + XLVM,CP,G0_P,CVW,STBOLT, & +!--- output variables + SNWEPRINT,SNHEIPRINT,RSM, & + TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, & + SMELT,SNOH,SNFLX,ILNB) + +!******************************************************************** +! Energy budget equation and heat diffusion eqn are +! solved here to obtain snow and soil temperatures +! +! DELT - time step (s) +! ktau - numver of time step +! CONFLX - depth of constant flux layer (m) +! IME, JME, KME, NZS - dimensions of the domain +! NROOT - number of levels within the root zone +! PRCPMS - precipitation rate in m/s +! COTSO, RHTSO - coefficients for implicit solution of +! heat diffusion equation +! THDIF - thermal diffusivity (W/m/K) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! PATM - pressure [bar] +! QCATM,QVATM - cloud and water vapor mixing ratio +! at the first atm. level (kg/kg) +! EMISS,RNET - emissivity (0-1) of the ground surface and net +! radiation at the surface (W/m^2) +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TKMS - exchange coefficient for heat in the surface +! layer (m/s) +! PC - plant coefficient (resistance) +! RHO - density of atmosphere near surface (kg/m^3) +! VEGFRAC - greeness fraction (0-1) +! CAP - volumetric heat capacity (J/m^3/K) +! DRYCAN - dry fraction of vegetated area where +! transpiration may take place (0-1) +! WETCAN - fraction of vegetated area covered by canopy +! water (0-1) +! TRANSUM - transpiration function integrated over the +! rooting zone (m) +! DEW - dew in kg/m^2/s +! MAVAIL - fraction of maximum soil moisture in the top +! layer (0-1) +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS - dt/(2.*dzshalf*dzmain) +! TBQ - table to define saturated mixing ration +! of water vapor for given temperature and pressure +! TSO - soil temperature (K) +! SOILT - skin temperature (K) +! +!********************************************************************* + + IMPLICIT NONE +!--------------------------------------------------------------------- +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + + INTEGER, INTENT(IN ) :: i,j,iland,isoil + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + RAINF,NEWSNOW,DELTSN,SNTH , & + TABS,TRANSUM,SNWEPR + +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL , & + INTENT(IN ) :: GLW, & + GSW, & + RHO, & + PC, & + VEGFRAC, & + QKMS, & + TKMS + +!--- soil properties + REAL , & + INTENT(IN ) :: & + BCLH, & + DQM, & + PSIS, & + QMIN + + REAL, INTENT(IN ) :: CP, & + CVW, & + STBOLT, & + XLVM, & + G0_P + + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + THDIF, & + CAP, & + TRANF + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO + + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: DEW, & + CST, & + RHOSN, & + EMISS, & + MAVAIL, & + QVG, & + QSG, & + QCG, & + SNWE, & + SNHEI, & + SNOWFRAC, & + SMELT, & + SNOH, & + SNFLX, & + SOILT, & + SOILT1, & + TSNAV + + REAL, INTENT(INOUT) :: DRYCAN, WETCAN + + REAL, INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT + INTEGER, INTENT(OUT) :: ilnb +!--- Local variables + + + INTEGER :: nzs1,nzs2,k,k1,kn,kk + + REAL :: x,x1,x2,x4,dzstop,can,ft,sph, & + tn,trans,umveg,denom + + REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + + REAL :: t3,upflux,xinet,ras, & + xlmelt,rhocsn,thdifsn, & + beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn + + REAL :: fso,fsn, & + FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & + TDENOM,C,CC,AA1,RHCS,H1, & + tsob, snprim, sh1, sh2, & + smeltg,snohg,snodif,soh, & + CMC2MS,TNOLD,QGOLD,SNOHGNEW + + REAL, DIMENSION(1:NZS) :: transp,cotso,rhtso + REAL :: edir1, & + ec1, & + ett1, & + eeta, & + s, & + qfx, & + hfx + + REAL :: RNET,rsmfrac,soiltfrac,hsn + +!----------------------------------------------------------------- + + do k=1,nzs + transp (k)=0. + cotso (k)=0. + rhtso (k)=0. + enddo + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt + ENDIF + XLMELT=3.335E+5 + RHOCSN=2090.* RHOSN + THDIFSN = 0.265/RHOCSN + RAS=RHO*1.E-3 + + SOILTFRAC=SOILT + + SMELT=0. + SOH=0. + SMELTG=0. + SNOHG=0. + SNODIF=0. + RSM = 0. + RSMFRAC = 0. + fsn=1. + fso=0. + hsn=snhei + + NZS1=NZS-1 + NZS2=NZS-2 + + QGOLD=QVG + TNOLD=SOILT + DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + +!****************************************************************************** +! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO +!****************************************************************************** +! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) +! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did +! cotso(1)=h1/(1.+h1) +! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ +! 1 (1.+h1) + + cotso(1)=0. + rhtso(1)=TSO(NZS) + DO 33 K=1,NZS2 + KN=NZS-K + K1=2*KN-3 + X1=DTDZS(K1)*THDIF(KN-1) + X2=DTDZS(K1+1)*THDIF(KN) + FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & + -X2*(TSO(KN)-TSO(KN+1)) + DENOM=1.+X1+X2-X2*cotso(K) + cotso(K+1)=X1/DENOM + rhtso(K+1)=(FT+X2*rhtso(K))/DENOM + 33 CONTINUE +!--- THE NZS element in COTSO and RHTSO will be for snow +!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH + IF(SNHEI.GE.SNTH) then +! if(snhei.le.DELTSN+DELTSN) then + if(snhei.le.DELTSN+SNTH) then +!-- 1-layer snow model + ilnb=1 + snprim=snhei + soilt1=tso(1) + tsob=tso(1) + XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + DDZSN = XSN / SNPRIM + X1SN = DDZSN * thdifsn + X2 = DTDZS(1)*THDIF(1) + FT = TSO(1)+X1SN*(SOILT-TSO(1)) & + -X2*(TSO(1)-TSO(2)) + DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + cotso(NZS)=X1SN/DENOM + rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM + cotsn=cotso(NZS) + rhtsn=rhtso(NZS) +!*** Average temperature of snow pack (C) + tsnav=0.5*(soilt+tso(1)) & + -273.15 + + else +!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth + ilnb=2 + snprim=deltsn + tsob=soilt1 + XSN = DELT/2./(0.5*SNHEI) + XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + DDZSN = XSN / DELTSN + DDZSN1 = XSN1 / (SNHEI-DELTSN) + X1SN = DDZSN * thdifsn + X1SN1 = DDZSN1 * thdifsn + X2 = DTDZS(1)*THDIF(1) + FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & + -X2*(TSO(1)-TSO(2)) + DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + cotso(nzs)=x1sn1/denom + rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom + ftsnow = soilt1+x1sn*(soilt-soilt1) & + -x1sn1*(soilt1-tso(1)) + denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + cotsn=x1sn/denomsn + rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn +!*** Average temperature of snow pack (C) + tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15 + endif + ENDIF + + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then +!--- snow is too thin to be treated separately, therefore it +!--- is combined with the first soil layer. + fsn=SNHEI/(SNHEI+zsmain(2)) + fso=1.-fsn + soilt1=tso(1) + tsob=tso(2) + snprim=SNHEI+zsmain(2) + XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + DDZSN = XSN /snprim + X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) + X2=DTDZS(2)*THDIF(2) + FT=TSO(2)+X1SN*(SOILT-TSO(2))- & + X2*(TSO(2)-TSO(3)) + denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + cotso(nzs1) = x1sn/denom + rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom + tsnav=0.5*(soilt+tso(1)) & + -273.15 + ENDIF + +!************************************************************************ +!--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26) + + ETT1=0. + EPOT=-QKMS*(QVATM-QSG) + RHCS=CAP(1) + H=MAVAIL + IF(DEW.NE.0.)THEN + DRYCAN=0. + WETCAN=1. + ENDIF + TRANS=PC*TRANSUM*DRYCAN/ZSHALF(NROOT+1) + CAN=WETCAN+TRANS + UMVEG=1.-VEGFRAC + FKT=TKMS + D1=cotso(NZS1) + D2=rhtso(NZS1) + TN=SOILT + D9=THDIF(1)*RHCS*dzstop + D10=TKMS*CP*RHO + R211=.5*CONFLX/DELT + R21=R211*CP*RHO + R22=.5/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5*TN**4 + R7=R6/TN + D11=RNET+R6 + + IF(SNHEI.GE.SNTH) THEN +! if(snhei.le.DELTSN+DELTSN) then + if(snhei.le.DELTSN+SNTH) then +!--- 1-layer snow + D1SN = cotso(NZS) + D2SN = rhtso(NZS) + else +!--- 2-layer snow + D1SN = cotsn + D2SN = rhtsn + endif + D9SN= THDIFSN*RHOCSN / SNPRIM + R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + ENDIF + + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then +!--- thin snow is combined with soil + D1SN = D1 + D2SN = D2 + D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIF(1)*RHCS)/ & + snprim + R22SN = snprim*snprim*0.5 & + /((fsn*THDIFSN+fso*THDIF(1))*delt) + ENDIF + + IF(SNHEI.eq.0.)then +!--- all snow is sublimated + D9SN = D9 + R22SN = R22 + D1SN = D1 + D2SN = D2 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' SNHEI = 0, D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN + ENDIF + ENDIF + +!---- TDENOM for snow + + TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + +RAINF*CVW*PRCPMS & + +RHOCSN*NEWSNOW/DELT + + FKQ=QKMS*RHO + R210=R211*RHO + C=VEGFRAC*FKQ*CAN + CC=C*XLVM/TDENOM + AA=XLVM*(BETA*FKQ*UMVEG+R210)/TDENOM + BB=(D10*TABS+R21*TN+XLVM*(QVATM* & + (BETA*FKQ*UMVEG+C) & + +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & + +RAINF*CVW*PRCPMS*max(273.15,TABS) & + + RHOCSN*NEWSNOW/DELT*min(273.15,TABS) & + )/TDENOM + AA1=AA+CC + PP=PATM*1.E3 + AA1=AA1/PP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'VILKA-SNOW' + print *,'tn,aa1,bb,pp,umveg,fkq,r210,vegfrac', & + tn,aa1,bb,pp,umveg,fkq,r210,vegfrac + ENDIF + + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + TQ2=QVATM+QCATM + TX2=TQ2*(1.-H) + Q1=TX2+H*QS1 +!--- it is saturation over snow + 90 QVG=QS1 + QSG=QS1 + QCG=Q1-QS1 + +!--- SOILT - skin temperature + SOILT=TS1 + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' AFTER VILKA-SNOW' + print *,' TS1,QS1: ', ts1,qs1 + ENDIF + +! Solution for temperature at 7.5 cm depth and snow-soil interface + IF(SNHEI.GE.SNTH) THEN +! if(snhei.gt.DELTSN+DELTSN) then + if(snhei.gt.DELTSN+SNTH) then +!-- 2-layer snow model + SOILT1=rhtsn+cotsn*SOILT + TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT1 + tsob=soilt1 + else +!-- 1 layer in snow + TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT + SOILT1=TSO(1) + tsob=tso(1) + endif + ELSE +!-- all snow is evaporated + TSO(1)=SOILT + SOILT1=SOILT + tsob=SOILT + ENDIF + +!---- Final solution for TSO + DO K=2,NZS + KK=NZS-K+1 + TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) + END DO +!--- For thin snow layer combined with the top soil layer +!--- TSO is computed by linear inmterpolation between SOILT +!--- and TSO(2) + + if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then + tso(1)=tso(2)+(soilt-tso(2))*fso + SOILT1=TSO(1) + tsob=tso(2) +!!! tsob=tso(1) + endif + +!--- IF SOILT > 273.15 F then melting of snow can happen + IF(SOILT.GE.273.15.AND.SNHEI.GT.0.) THEN +!!! SOILT=273.15 + soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT + soilt=soiltfrac + QSG= QSN(soilt,TBQ)/PP +!!! QSG= QSN(273.15,TBQ)/PP + QVG=QSG + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 * SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + EPOT = -QKMS*(QVATM-QSG) + Q1=EPOT*RAS + + IF (Q1.LE.0.) THEN +! --- condensation + DEW=-EPOT + DO K=1,NZS + TRANSP(K)=0. + ENDDO + + QFX= XLVM*RHO*DEW + ELSE +! --- evaporation + DO K=1,NROOT + TRANSP(K)=-VEGFRAC*q1 & + *PC*TRANF(K)*DRYCAN/zshalf(NROOT+1) + IF(TRANSP(K).GT.0.) TRANSP(K)=0. + ETT1=ETT1-TRANSP(K) + ENDDO + DO k=nroot+1,nzs + transp(k)=0. + enddo + + EDIR1 = Q1*UMVEG * BETA + EC1 = Q1 * WETCAN *VEGFRAC + CMC2MS=CST/DELT + EC1=MIN(CMC2MS,EC1) + EETA = (EDIR1 + EC1 + ETT1)*1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= - XLVM * EETA + ENDIF + + HFX=D10*(TABS-soilt) +!!! HFX=D10*(TABS-273.15) + + IF(SNHEI.GE.SNTH)then + SOH=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM +! SOH=thdifsn*RHOCSN*(273.15-TSOB)/SNPRIM + SNFLX=SOH + ELSE + SOH=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & + (soilt-TSOB)/snprim +!!! (273.15-TSOB)/snprim + SNFLX=SOH + ENDIF + + X= (R21+D9SN*R22SN)*(soilt-TNOLD) + & +!!! X= (R21+D9SN*R22SN)*(273.15-TNOLD) + & + XLVM*R210*(QSG-QGOLD) +!-- SNOH is energy flux of snow phase change + SNOH=RNET+QFX +HFX & + +RHOCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & + -SOH-X+RAINF*CVW*PRCPMS* & + (max(273.15,TABS)-TN) + SNOH=AMAX1(0.,SNOH) +!-- SMELT is speed of melting in M/S + SMELT= SNOH /XLMELT*1.E-3 +! SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) + SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS*UMVEG) + + SNOHGNEW=SMELT*XLMELT*1.E3 + SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + + SNOH=SNOHGNEW +! SNOHSMELT*XLMELT*1.E3 + +!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack +!!! rsm=0.13*smelt*delt + if(snwe.gt.0.) then + rsmfrac=min(0.18,(max(0.08,0.10/snwe*0.13))) + else + rsmfrac=0.13 + endif + + rsm=rsmfrac*smelt*delt + SMELT=SMELT-rsm/delt + +!-- correction of liquid equivalent of snow depth +!-- due to evaporation and snow melt + SNWE = AMAX1(0.,(SNWEPR- & +! 1 (SMELT+BETA*EPOT*RAS)*DELT + (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + ) ) + +!--- If all snow melts, then 13% of snow melt we kept in the +!--- snow pack should be added back to snow melt and infiltrate +!--- into soil. + if(snwe.le.rsm) then + smelt=smelt+rsm/delt + snwe=0. + rsm=0. + SOILT=SNODIF*DELT/RHCS*ZSHALF(2) & + +soiltfrac +!!! +273.15 + SOILT=SOILTFRAC + else +!*** Correct snow density on effect of snow melt, melted +!*** from the top of the snow. 13% of melted water +!*** remains in the pack and changes its density. +!*** Eq. 9 (with my correction) in Koren et al. (1999) + + if(snwe.gt.snth*rhosn*1.e-3) then + xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & + snwe + rhosn=MIN(XSN,400.) + + RHOCSN=2090.* RHOSN + thdifsn = 0.265/RHOCSN + endif + + endif + +!--- If there is no snow melting then just evaporation +!--- or condensation cxhanges SNWE + ELSE + EPOT=-QKMS*(QVATM-QSG) + SNWE = AMAX1(0.,(SNWEPR- & + BETA*EPOT*RAS*UMVEG*DELT)) + + ENDIF +!*** Correct snow density on effect of snow melt, melted +!*** from the top of the snow. 13% of melted water +!*** remains in the pack and changes its density. +!*** Eq. 9 (with my correction) in Koren et al. (1999) + + SNHEI=SNWE *1.E3 / RHOSN + +!-- Snow melt from the top is done. But if ground surface temperature +!-- is above freezing snow can melt from the bottom. The following +!-- piece of code will check if bottom melting is possible. + + IF(TSO(1).GE.273.15.AND.SNHEI.GT.0.) THEN + soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) + + SNOHG=(TSO(1)-soiltfrac)*(RHCS*zshalf(2)+ & + RHOCSN*0.5*SNHEI) / DELT + SNOHG=AMAX1(0.,SNOHG) + SNODIF=0. +! TSO(1)=273.15 + SMELTG=SNOHG/XLMELT*1.E-3 +! SMELTG=AMIN1(SMELTG,SNWE/DELT) + if(SNWE-SMELTG*DELT.ge.rsm) then +! SNWE = SNWE-SMELTG*DELT + SNWE = AMAX1(0.,SNWE-SMELTG*DELT) + else + smeltg=snwe/delt + snwe=0. + rsm=0. + endif + + SNOHGNEW=SMELTG*XLMELT*1.e3 + SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) + TSO(1)=soiltfrac + if(snwe.eq.0.)then + TSO(1)=SNODIF*DELT/RHCS*zshalf(2) + soiltfrac +!!! TSO(1)=SNODIF*DELT/RHCS*zshalf(2) + 273.15 + endif + + SMELT=SMELT+SMELTG + SNOH=SNOH+SNOHGNEW + + ENDIF + + SNHEI=SNWE *1.E3 / RHOSN + + snweprint=snwe & +!--- if VEGFRAC.ne.0. then some snow stays on the canopy +!--- and should be added to SNWE for water conservation + +VEGFRAC*cst + snheiprint=snweprint*1.E3 / RHOSN + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *, 'snweprint : ',snweprint +print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB + ENDIF +!--- Compute flux in the top snow layer + SNFLX=D9SN*(SOILT-TSOB) + + if(snhei.gt.0.) then + if(ilnb.gt.1) then + tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15 + else + tsnav=0.5*(soilt+tso(1)) - 273.15 + endif + else + tsnav=0. + endif !new line +! return +! end +!------------------------------------------------------------------------ + END SUBROUTINE SNOWTEMP +!------------------------------------------------------------------------ + + + SUBROUTINE SOILMOIST ( & +!--input parameters + DELT,NZS,NDDZS,DTDZS,DTDZS2, & + ZSMAIN,ZSHALF,DIFFU,HYDRO, & + QSG,QVG,QCG,QCATM,QVATM,PRCP, & + QKMS,TRANSP,DRIP, & + DEW,SMELT,SOILICE,VEGFRAC, & +!--soil properties + DQM,QMIN,REF,KSAT,RAS,INFMAX, & +!--output + SOILMOIS,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) +!************************************************************************* +! moisture balance equation and Richards eqn. +! are solved here +! +! DELT - time step (s) +! IME,JME,NZS - dimensions of soil domain +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS - dt/(2.*dzshalf*dzmain) +! DTDZS2 - dt/(2.*dzshalf) +! DIFFU - diffusional conductivity (m^2/s) +! HYDRO - hydraulic conductivity (m/s) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! QCATM,QVATM - cloud and water vapor mixing ratio +! at the first atm. level (kg/kg) +! PRCP - precipitation rate in m/s +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TRANSP - transpiration from the soil layers (m/s) +! DRIP - liquid water dripping from the canopy to soil (m) +! DEW - dew in kg/m^2s +! SMELT - melting rate in m/s +! SOILICE - volumetric content of ice in soil (m^3/m^3) +! VEGFRAC - greeness fraction (0-1) +! RAS - ration of air density to soil density +! INFMAX - maximum infiltration rate (kg/m^2/s) +! +! SOILMOIS - volumetric soil moisture, 6 levels (m^3/m^3) +! MAVAIL - fraction of maximum soil moisture in the top +! layer (0-1) +! RUNOFF - surface runoff (m/s) +! RUNOFF2 - underground runoff (m) +! INFILTRP - point infiltration flux into soil (m/s) +! /(snow bottom runoff) (mm/s) +! +! COSMC, RHSMC - coefficients for implicit solution of +! Richards equation +!****************************************************************** + IMPLICIT NONE +!------------------------------------------------------------------ +!--- input variables + REAL, INTENT(IN ) :: DELT + INTEGER, INTENT(IN ) :: NZS,NDDZS + +! input variables + + REAL, DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + ZSHALF, & + DIFFU, & + HYDRO, & + TRANSP, & + SOILICE, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & + QKMS,VEGFRAC,DRIP,PRCP , & + DEW,SMELT , & + DQM,QMIN,REF,KSAT,RAS + +! output + + REAL, DIMENSION( 1:nzs ) , & + + INTENT(INOUT) :: SOILMOIS + + REAL, INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + INFMAX + +! local variables + + REAL, DIMENSION( 1:nzs ) :: COSMC,RHSMC + + REAL :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + REAL :: REFKDT,REFDK,DELT1,F1MAX,F2MAX + REAL :: F1,F2,FD,KDT,VAL,DDT,PX + REAL :: QQ,UMVEG,INFMAX1,TRANS + REAL :: TOTLIQ,FLX,FLXSAT,QTOT + REAL :: DID,X1,X2,X4,DENOM,Q2,Q4 + REAL :: dice,fcr,acrt,frzx,sum,cvfrz + + INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk + +!****************************************************************************** +! COEFFICIENTS FOR THOMAS ALGORITHM FOR SOILMOIS +!****************************************************************************** + NZS1=NZS-1 + NZS2=NZS-2 + + 118 format(6(10Pf23.19)) + + do k=1,nzs + cosmc(k)=0. + rhsmc(k)=0. + enddo + + DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. + X1=ZSMAIN(NZS)-ZSMAIN(NZS1) +! DENOM=DID/DELT+DIFFU(NZS1)/X1 +! COSMC(1)=DIFFU(NZS1)/X1/DENOM +! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT +! 1 +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) +! 1 -HYDRO(NZS1)*SOILMOIS(NZS1))*DID +! 1 /X1) /DENOM + + DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + +HYDRO(NZS1)/2./DID)/DENOM + RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & + DID)/DENOM + + DO 330 K=1,NZS2 + KN=NZS-K + K1=2*KN-3 + X4=2.*DTDZS(K1)*DIFFU(KN-1) + X2=2.*DTDZS(K1+1)*DIFFU(KN) + Q4=X4+HYDRO(KN-1)*DTDZS2(KN-1) + Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) + DENOM=1.+X2+X4-Q2*COSMC(K) + COSMC(K+1)=Q4/DENOM + 330 RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & + +TRANSP(KN) & + /(ZSHALF(KN+1)-ZSHALF(KN)) & + *DELT)/DENOM + +! --- MOISTURE BALANCE BEGINS HERE + + TRANS=TRANSP(1) + UMVEG=1.-VEGFRAC + + RUNOFF=0. + RUNOFF2=0. + DZS=ZSMAIN(2) + R1=COSMC(NZS1) + R2= RHSMC(NZS1) + R3=DIFFU(1)/DZS + R4=R3+HYDRO(1)*.5 + R5=R3-HYDRO(2)*.5 + R6=QKMS*RAS +!-- Total liquid water available on the top of soil domain +!-- Without snow - 3 sources of water: precipitation, +!-- water dripping from the canopy and dew +!-- With snow - only one source of water - snow melt + +! print *,'PRCP,DRIP,DEW,umveg,ras,smelt', +! 1 PRCP,DRIP,DEW,umveg,ras,smelt +! if (drip.ne.0.) then +! print *,'DRIP non-zero' +! write(6,191) drip +! write (6,191)soilmois(1) +! write (6,191)soilmois(2) +! endif + 191 format (f23.19) + + TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + + + FLX=TOTLIQ + INFILTRP=TOTLIQ + +! ----------- FROZEN GROUND VERSION ------------------------- +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. +! BASED ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT +! CLOSE TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. +! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) +! +! Current logic doesn't allow CVFRZ be bigger than 3 + CVFRZ = 3. + +!-- SCHAAKE/KOREN EXPRESSION for calculation of max infiltration + REFKDT=3. + REFDK=3.4341E-6 + DELT1=DELT/86400. + F1MAX=DQM*ZSHALF(2) + F2MAX=DQM*(ZSHALF(3)-ZSHALF(2)) + F1=F1MAX*(1.-SOILMOIS(1)/DQM) + F2=F2MAX*(1.-SOILMOIS(2)/DQM) + FD=F1+F2 + KDT=REFKDT*KSAT/REFDK + VAL=(1.-EXP(-KDT*DELT1)) + DDT = FD*VAL + PX= - TOTLIQ * DELT + IF(PX.LT.0.0) PX = 0.0 + if(ddt.eq.0.) then + infmax1=ksat + else + INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT + INFMAX1 = MIN(INFMAX1, KSAT) + endif +! print *,'INFMAX1=,ksat',infmax1,ksat,f1,f2,kdt,val,ddt,px +! ----------- FROZEN GROUND VERSION -------------------------- +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! +! ------------------------------------------------------------------ + + DICE = soilice(1)*zshalf(2) + DO K=2,NZS1 + DICE = DICE + ( ZSHALF(K+1) - ZSHALF(K) ) * soilice(k) + ENDDO + FRZX= 0.28*((dqm+qmin)/ref) * (0.400 / 0.482) + FCR = 1. + IF ( DICE .GT. 1.E-2) THEN + ACRT = CVFRZ * FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO JK = 1,IALP1 + K = 1 + DO JJ = JK+1, IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ-JK)) / FLOAT (K) + END DO + FCR = 1. - EXP(-ACRT) * SUM + END IF +! print *,'FCR--------',fcr + INFMAX1 = INFMAX1* FCR + INFMAX1 = MIN(INFMAX1, KSAT) +! ------------------------------------------------------------------- + + INFMAX = MIN(INFMAX,INFMAX1) +!---- + IF (-TOTLIQ.GE.INFMAX)THEN + RUNOFF=-TOTLIQ-INFMAX + FLX=-INFMAX + ENDIF +! INFILTRP is total infiltration flux in M/S + INFILTRP=FLX +! print *,'PRCIP',infiltrp,flx,infmax +! Solution of moisture budget + R7=.5*DZS/DELT + R4=R4+R7 + FLX=FLX-SOILMOIS(1)*R7 + R8=UMVEG*R6 + QTOT=QVATM+QCATM + R9=TRANS + R10=QTOT-QSG +!-- evaporation regime + IF(R10.LE.0.) THEN + QQ=(R5*R2-FLX+R9)/(R4-R5*R1-R10*R8/(REF-QMIN)) + FLXSAT=-DQM*(R4-R5*R1-R10*R8/(REF-QMIN)) & + +R5*R2+R9 + ELSE +!-- dew formation regime + QQ=(R2*R5-FLX+R8*(QTOT-QCG-QVG)+R9)/(R4-R1*R5) + FLXSAT=-DQM*(R4-R1*R5)+R2*R5+R8*(QTOT-QVG-QCG)+R9 + END IF + + IF(QQ.LT.0.) THEN + SOILMOIS(1)=0. + + ELSE IF(QQ.GT.DQM) THEN +!-- saturation + SOILMOIS(1)=DQM + RUNOFF2=runoff2+(FLXSAT-FLX)*DELT + RUNOFF=RUNOFF+(FLXSAT-FLX) + ELSE + SOILMOIS(1)=max(1.e-8,QQ) + END IF + +!--- FINAL SOLUTION FOR SOILMOIS +! DO K=2,NZS + DO K=2,NZS-1 + KK=NZS-K+1 + QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) + + IF (QQ.LT.0.) THEN + SOILMOIS(K)=0. + + ELSE IF(QQ.GT.DQM) THEN +!-- saturation + SOILMOIS(K)=DQM + IF(K.EQ.NZS)THEN + RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)) + ELSE + RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K+1)-ZSHALF(K)) + ENDIF + ELSE + SOILMOIS(K)=max(1.e-8,QQ) + END IF + END DO + +! MAVAIL=min(1.,SOILMOIS(1)/(REF-QMIN)) + MAVAIL=min(1.,SOILMOIS(1)/DQM) + if (MAVAIL.EQ.0.) MAVAIL=.00001 + +! RETURN +! END +!------------------------------------------------------------------- + END SUBROUTINE SOILMOIST +!------------------------------------------------------------------- + + + SUBROUTINE SOILPROP( & +!--- input variables + nzs,fwsat,lwsat,tav,keepfr, & + soilmois,soiliqw,soilice, & + soilmoism,soiliqwm,soilicem, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & +!--- constants + riw,xlmelt,CP,G0_P,cvw,ci, & + kqwrtz,kice,kwt, & +!--- output variables + thdif,diffu,hydro,cap) + +!****************************************************************** +! SOILPROP computes thermal diffusivity, and diffusional and +! hydraulic condeuctivities +!****************************************************************** +! NX,NY,NZS - dimensions of soil domain +! FWSAT, LWSAT - volumetric content of frozen and liquid water +! for saturated condition at given temperatures (m^3/m^3) +! TAV - temperature averaged for soil layers (K) +! SOILMOIS - volumetric soil moisture at the main soil levels (m^3/m^3) +! SOILMOISM - volumetric soil moisture averaged for layers (m^3/m^3) +! SOILIQWM - volumetric liquid soil moisture averaged for layers (m^3/m^3) +! SOILICEM - volumetric content of soil ice averaged for layers (m^3/m^3) +! THDIF - thermal diffusivity for soil layers (W/m/K) +! DIFFU - diffusional conductivity (m^2/s) +! HYDRO - hydraulic conductivity (m/s) +! CAP - volumetric heat capacity (J/m^3/K) +! +!****************************************************************** + + IMPLICIT NONE +!----------------------------------------------------------------- + +!--- soil properties + INTEGER, INTENT(IN ) :: NZS + REAL , & + INTENT(IN ) :: RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QWRTZ, & + QMIN + + REAL, DIMENSION( 1:nzs ) , & + INTENT(IN ) :: SOILMOIS, & + keepfr + + + REAL, INTENT(IN ) :: CP, & + CVW, & + RIW, & + kqwrtz, & + kice, & + kwt, & + XLMELT, & + G0_P + + + +!--- output variables + REAL, DIMENSION(1:NZS) , & + INTENT(INOUT) :: cap,diffu,hydro , & + thdif,tav , & + soilmoism , & + soiliqw,soilice , & + soilicem,soiliqwm , & + fwsat,lwsat + +!--- local variables + REAL, DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + + REAL :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + REAL :: tln,tavln,tn,pf,a,am,ame,h + INTEGER :: nzs1,k + +!-- for Johansen thermal conductivity + REAL :: kzero,gamd,kdry,kas,x5,sr,ke + + + nzs1=nzs-1 + +!-- Constants for Johansen (1975) thermal conductivity + kzero =2. ! if qwrtz > 0.2 + + + do k=1,nzs + detal (k)=0. + kasat (k)=0. + kjpl (k)=0. + hk (k)=0. + enddo + + ws=dqm+qmin + x1=xlmelt/(g0_p*psis) + x2=x1/bclh*ws + x4=(bclh+1.)/bclh +!--- Next 3 lines are for Johansen thermal conduct. + gamd=(1.-ws)*2700. + kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) + kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) + + DO K=1,NZS1 + tn=tav(k) - 273.15 + wd=ws - riw*soilicem(k) + psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & + * (ws/wd)**3. +!--- PSIF should be in [CM] to compute PF + pf=log10(abs(psif)) + fact=1.+riw*soilicem(k) +!--- HK is for McCumber thermal conductivity + IF(PF.LE.5.2) THEN + HK(K)=420.*EXP(-(PF+2.7))*fact + ELSE + HK(K)=.1744*fact + END IF + + IF(soilicem(k).NE.0.AND.TN.LT.0.) then +!--- DETAL is taking care of energy spent on freezing or released from +! melting of soil water + + DETAL(K)=273.15*X2/(TAV(K)*TAV(K))* & + (TAV(K)/(X1*TN))**X4 + + if(keepfr(k).eq.1.) then + detal(k)=0. + endif + + ENDIF + +!--- Next 10 lines calculate Johansen thermal conductivity KJPL + kasat(k)=kas**(1.-ws)*kice**fwsat(k) & + *kwt**lwsat(k) + + X5=(soilmoism(k)+qmin)/ws + if(soilicem(k).eq.0.) then + sr=max(0.101,x5) + ke=log10(sr)+1. +!--- next 2 lines - for coarse soils +! sr=max(0.0501,x5) +! ke=0.7*log10(sr)+1. + else + ke=x5 + endif + + kjpl(k)=ke*(kasat(k)-kdry)+kdry + +!--- CAP -volumetric heat capacity + CAP(K)=(1.-WS)*RHOCS & + + (soiliqwm(K)+qmin)*CVW & + + soilicem(K)*CI & + + (dqm-soilmoism(k))*CP*1.2 & + - DETAL(K)*1.e3*xlmelt + + a=RIW*soilicem(K) + + if((ws-a).lt.0.12)then + diffu(K)=0. + else + H=max(0.,(soilmoism(K)-a)/(max(1.e-8,(dqm-a)))) + facd=1. + if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) + ame=max(1.e-8,dqm-riw*soilicem(K)) +!--- DIFFU is diffusional conductivity of soil water + diffu(K)=-BCLH*KSAT*PSIS/ame* & + (dqm/ame)**3. & + *H**(BCLH+2.)*facd + endif + +! diffu(K)=-BCLH*KSAT*PSIS/dqm & +! *H**(BCLH+2.) + + +!--- thdif - thermal diffusivity +! thdif(K)=HK(K)/CAP(K) +!--- Use thermal conductivity from Johansen (1975) + thdif(K)=KJPL(K)/CAP(K) + + END DO + + DO K=1,NZS + + if((ws-riw*soilice(k)).lt.0.12)then + hydro(k)=0. + else + fach=1. + if(soilice(k).ne.0.) & + fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) + am=max(1.e-8,dqm-riw*soilice(k)) +!--- HYDRO is hydraulic conductivity of soil water + hydro(K)=KSAT/am* & + (soiliqw(K)/am) & + **(2.*BCLH+2.) & + * fach + endif + + ENDDO + +! RETURN +! END + +!----------------------------------------------------------------------- + END SUBROUTINE SOILPROP +!----------------------------------------------------------------------- + + + SUBROUTINE TRANSF( & +!--- input variables + nzs,nroot,soiliqw, & +!--- soil fixed fields + dqm,qmin,ref,wilt,zshalf, & +!--- output variables + tranf,transum) + +!------------------------------------------------------------------- +!--- TRANF(K) - THE TRANSPIRATION FUNCTION (Smirnova et al. 1996, EQ. 18,19) +!******************************************************************* +! NX,NY,NZS - dimensions of soil domain +! SOILIQW - volumetric liquid soil moisture at the main levels (m^3/m^3) +! TRANF - the transpiration function at levels (m) +! TRANSUM - transpiration function integrated over the rooting zone (m) +! +!******************************************************************* + IMPLICIT NONE +!------------------------------------------------------------------- + +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,nzs + +!--- soil properties + REAL , & + INTENT(IN ) :: DQM, & + QMIN, & + REF, & + WILT + + REAL, DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + ZSHALF + +!-- output + REAL, DIMENSION(1:NZS), INTENT(OUT) :: TRANF + REAL, INTENT(OUT) :: TRANSUM + +!-- local variables + REAL :: totliq, did + INTEGER :: k + +!-- for non-linear root distribution + REAL :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + REAL, DIMENSION(1:NZS) :: PART +!-------------------------------------------------------------------- + + do k=1,nzs + part(k)=0. + enddo + + transum=0. + totliq=soiliqw(1)+qmin + sm1=totliq + sm2=sm1*sm1 + sm3=sm2*sm1 + sm4=sm3*sm1 + ap0=0.299 + ap1=-8.152 + ap2=61.653 + ap3=-115.876 + ap4=59.656 + gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 + if(totliq.ge.ref) gx=1. + if(totliq.le.0.) gx=0. + if(gx.gt.1.) gx=1. + if(gx.lt.0.) gx=0. + DID=zshalf(2) + part(1)=DID*gx + IF(TOTLIQ.GT.REF) THEN + TRANF(1)=DID + ELSE IF(TOTLIQ.LE.WILT) THEN + TRANF(1)=0. + ELSE + TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID + ENDIF +!-- uncomment next line for non-linear root distribution +!cc TRANF(1)=part(1) + DO K=2,NROOT + totliq=soiliqw(k)+qmin + sm1=totliq + sm2=sm1*sm1 + sm3=sm2*sm1 + sm4=sm3*sm1 + gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 + if(totliq.ge.ref) gx=1. + if(totliq.le.0.) gx=0. + if(gx.gt.1.) gx=1. + if(gx.lt.0.) gx=0. + DID=zshalf(K+1)-zshalf(K) + part(k)=did*gx + IF(totliq.GE.REF) THEN + TRANF(K)=DID + ELSE IF(totliq.LE.WILT) THEN + TRANF(K)=0. + ELSE + TRANF(K)=(totliq-WILT) & + /(REF-WILT)*DID + ENDIF +!-- uncomment next line for non-linear root distribution +!cc TRANF(k)=part(k) + END DO + +!-- TRANSUM - total for the rooting zone + transum=0. + DO K=1,NROOT + transum=transum+tranf(k) + END DO + +! RETURN +! END +!----------------------------------------------------------------- + END SUBROUTINE TRANSF +!----------------------------------------------------------------- + + + SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) +!-------------------------------------------------------------- +!--- VILKA finds the solution of energy budget at the surface +!--- using table T,QS computed from Clausius-Klapeiron +!-------------------------------------------------------------- + REAL, DIMENSION(1:4001), INTENT(IN ) :: TT + REAL, INTENT(IN ) :: TN,D1,D2,PP + INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil + + REAL, INTENT(OUT ) :: QS, TS + + REAL :: F1,T1,T2,RN + INTEGER :: I,I1 + + I=(TN-1.7315E2)/.05+1 + T1=173.1+FLOAT(I)*.05 + F1=T1+D1*TT(I)-D2 + I1=I-F1/(.05+D1*(TT(I+1)-TT(I))) + I=I1 + IF(I.GT.4000.OR.I.LT.1) GOTO 1 + 10 I1=I + T1=173.1+FLOAT(I)*.05 + F1=T1+D1*TT(I)-D2 + RN=F1/(.05+D1*(TT(I+1)-TT(I))) + I=I-INT(RN) + IF(I.GT.4000.OR.I.LT.1) GOTO 1 + IF(I1.NE.I) GOTO 10 + TS=T1-.05*RN + QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP + GOTO 20 + 1 PRINT *,' AVOST IN VILKA ' +! WRITE(12,*)'AVOST',TN,D1,D2,PP,NSTEP + PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil + CALL wrf_error_fatal (' AVOST IN VILKA ' ) + 20 CONTINUE +! RETURN +! END +!----------------------------------------------------------------------- + END SUBROUTINE VILKA +!----------------------------------------------------------------------- + + + SUBROUTINE SOILVEGIN ( IVGTYP,ISLTYP,MYJ, & + IFOREST,EMISS,PC,ZNT,QWRTZ, & + RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT ) + +!************************************************************************ +! Set-up soil and vegetation Parameters in the case when +! snow disappears during the forecast and snow parameters +! shold be replaced by surface parameters according to +! soil and vegetation types in this point. +! +! Output: +! +! +! Soil parameters: +! DQM: MAX soil moisture content - MIN (m^3/m^3) +! REF: Reference soil moisture (m^3/m^3) +! WILT: Wilting PT soil moisture contents (m^3/m^3) +! QMIN: Air dry soil moist content limits (m^3/m^3) +! PSIS: SAT soil potential coefs. (m) +! KSAT: SAT soil diffusivity/conductivity coefs. (m/s) +! BCLH: Soil diffusivity/conductivity exponent. +! +! ************************************************************************ + IMPLICIT NONE +!--------------------------------------------------------------------------- + integer, parameter :: nsoilclas=19 + integer, parameter :: nvegclas=24 + integer, parameter :: iwater=16 + integer, parameter :: ilsnow=99 + + +!--- soiltyp classification according to STATSGO(nclasses=16) +! +! 1 SAND SAND +! 2 LOAMY SAND LOAMY SAND +! 3 SANDY LOAM SANDY LOAM +! 4 SILT LOAM SILTY LOAM +! 5 SILT SILTY LOAM +! 6 LOAM LOAM +! 7 SANDY CLAY LOAM SANDY CLAY LOAM +! 8 SILTY CLAY LOAM SILTY CLAY LOAM +! 9 CLAY LOAM CLAY LOAM +! 10 SANDY CLAY SANDY CLAY +! 11 SILTY CLAY SILTY CLAY +! 12 CLAY LIGHT CLAY +! 13 ORGANIC MATERIALS LOAM +! 14 WATER +! 15 BEDROCK +! Bedrock is reclassified as class 14 +! 16 OTHER (land-ice) +! 17 Playa +! 18 Lava +! 19 White Sand +! +!---------------------------------------------------------------------- + REAL LQMA(nsoilclas),LRHC(nsoilclas), & + LPSI(nsoilclas),LQMI(nsoilclas), & + LBCL(nsoilclas),LKAS(nsoilclas), & + LWIL(nsoilclas),LREF(nsoilclas), & + DATQTZ(nsoilclas) +!-- LQMA Rawls et al.[1982] +! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, +! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/ +!--- +!-- Clapp, R. and G. Hornberger, 1978: Empirical equations for some soil +! hydraulic properties, Water Resour. Res., 14, 601-604. + +!-- Clapp et al. [1978] + DATA LQMA /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & + 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, & + 0.20, 0.435, 0.468, 0.200, 0.339/ + +!-- LREF Rawls et al.[1982] +! DATA LREF /0.091, 0.125, 0.207, 0.330, 0.360, 0.270, 0.255, +! & 0.366, 0.318, 0.339, 0.387, 0.396, 0.329, 1.0, 0.108, 0.283/ + +!-- Clapp et al. [1978] + DATA LREF /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & + 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., & + 0.1, 0.249, 0.454, 0.17, 0.236/ + +!-- LWIL Rawls et al.[1982] +! DATA LWIL/0.033, 0.055, 0.095, 0.133, 0.133, 0.117, 0.148, +! & 0.208, 0.197, 0.239, 0.250, 0.272, 0.066, 0.0, 0.006, 0.029/ + +!-- Clapp et al. [1978] + DATA LWIL/0.068, 0.075, 0.114, 0.179, 0.179, 0.155, 0.175, & + 0.218, 0.250, 0.219, 0.283, 0.286, 0.155, 0.0, & + 0.006, 0.114, 0.030, 0.006, 0.01/ + +! DATA LQMI/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, 0.067, +! & 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.0, 0.006, 0.028/ + +!-- Carsel and Parrish [1988] + DATA LQMI/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & + 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & + 0.004, 0.065, 0.020, 0.004, 0.008/ + +!-- LPSI Cosby et al[1984] +! DATA LPSI/0.060, 0.036, 0.141, 0.759, 0.759, 0.355, 0.135, +! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/ +! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/ + +!-- Clapp et al. [1978] + DATA LPSI/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & + 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, & + 0.121, 0.218, 0.468, 0.069, 0.069/ + +!-- LKAS Rawls et al.[1982] +! DATA LKAS/5.83E-5, 1.70E-5, 7.19E-6, 1.89E-6, 1.89E-6, +! & 3.67E-6, 1.19E-6, 4.17E-7, 6.39E-7, 3.33E-7, 2.50E-7, +! & 1.67E-7, 3.38E-6, 0.0, 1.41E-4, 1.41E-5/ + +!-- Clapp et al. [1978] + DATA LKAS/1.76E-4, 1.56E-4, 3.47E-5, 7.20E-6, 7.20E-6, & + 6.95E-6, 6.30E-6, 1.70E-6, 2.45E-6, 2.17E-6, & + 1.03E-6, 1.28E-6, 6.95E-6, 0.0, 1.41E-4, & + 3.47E-5, 1.28E-6, 1.41E-4, 1.76E-4/ + +!-- LBCL Cosby et al [1984] +! DATA LBCL/2.79, 4.26, 4.74, 5.33, 5.33, 5.25, 6.66, +! & 8.72, 8.17, 10.73, 10.39, 11.55, 5.25, 0.0, 2.79, 4.26/ + +!-- Clapp et al. [1978] + DATA LBCL/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & + 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, & + 4.05, 4.90, 11.55, 2.79, 2.79/ + + DATA LRHC /1.47,1.41,1.34,1.27,1.27,1.21,1.18,1.32,1.23, & + 1.18,1.15,1.09,1.21,4.18,2.03,2.10,1.09,2.03,1.47/ + + DATA DATQTZ/0.92,0.82,0.60,0.25,0.10,0.40,0.60,0.10,0.35, & + 0.52,0.10,0.25,0.00,0.,0.60,0.0,0.25,0.60,0.92/ + +!-------------------------------------------------------------------------- +! +! USGS Vegetation Types +! +! 1: Urban and Built-Up Land +! 2: Dryland Cropland and Pasture +! 3: Irrigated Cropland and Pasture +! 4: Mixed Dryland/Irrigated Cropland and Pasture +! 5: Cropland/Grassland Mosaic +! 6: Cropland/Woodland Mosaic +! 7: Grassland +! 8: Shrubland +! 9: Mixed Shrubland/Grassland +! 10: Savanna +! 11: Deciduous Broadleaf Forest +! 12: Deciduous Needleleaf Forest +! 13: Evergreen Broadleaf Forest +! 14: Evergreen Needleleaf Fores +! 15: Mixed Forest +! 16: Water Bodies +! 17: Herbaceous Wetland +! 18: Wooded Wetland +! 19: Barren or Sparsely Vegetated +! 20: Herbaceous Tundra +! 21: Wooded Tundra +! 22: Mixed Tundra +! 23: Bare Ground Tundra +! 24: Snow or Ice + +!---- Below are the arrays for the vegetation parameters + REAL LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & + LPC(nvegclas), NROTBL(nvegclas) + +!************************************************************************ +!---- vegetation parameters +! +!-- USGS model +! + DATA LALB/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & + .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55/ + DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & + .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95/ +!-- Roughness length is changed for forests and some others +! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & +! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & + .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + + DATA LMOI/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3, & + .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95/ +! +!---- still needs to be corrected +! +! DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ + DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & + 0.5,0.7,0.6,0.7,0.5,0./ + + +!*************************************************************************** + + + INTEGER :: & + IVGTYP, & + ISLTYP + + LOGICAL, INTENT(IN ) :: myj + + REAL , & + INTENT ( OUT) :: pc + + REAL , & + INTENT (INOUT ) :: emiss, & + znt +!--- soil properties + REAL , & + INTENT( OUT) :: RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + WILT + + INTEGER, DIMENSION( 1:nvegclas ) , & + INTENT ( OUT) :: iforest + + + + INTEGER, DIMENSION( 1:nvegclas ) :: if1 + INTEGER :: kstart, kfin, lstart, lfin + INTEGER :: i,j,k + +!*********************************************************************** +! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil +! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil + DATA IF1/12*0,1,1,1,9*0/ + + do k=1,nvegclas + iforest(k)=if1(k) + enddo + + + EMISS = LEMI(IVGTYP) +! When MYJ sfc scheme is used - better use recommended in MYJSFCINIT +! values of roughness length, and not redefine it here. +! The table in this routine is the one we use in RUC with RUC LSM. + + if (.not. myj) then + ZNT = LROU(IVGTYP) + endif + + PC = LPC (IVGTYP) + + RHOCS = LRHC(ISLTYP)*1.E6 + BCLH = LBCL(ISLTYP) + DQM = LQMA(ISLTYP)- & + LQMI(ISLTYP) + KSAT = LKAS(ISLTYP) + PSIS = - LPSI(ISLTYP) + QMIN = LQMI(ISLTYP) + REF = LREF(ISLTYP) + WILT = LWIL(ISLTYP) + QWRTZ = DATQTZ(ISLTYP) + +!-------------------------------------------------------------------------- + END SUBROUTINE SOILVEGIN +!-------------------------------------------------------------------------- + + + SUBROUTINE SNOWFREE (ivgtyp,myj,emiss,znt,iland) +!************************************************************************ +! Set-up soil and vegetation Parameters in the case when +! snow disappears during the forecast and snow parameters +! shold be replaced by surface parameters according to +! soil and vegetation types in this point. +! +!*************************************************************************** + IMPLICIT NONE +!--------------------------------------------------------------------------- + integer, parameter :: nvegclas=24 + + + INTEGER :: IVGTYP + + LOGICAL, INTENT(IN ) :: myj + + REAL, INTENT(INOUT) :: & + emiss, & + znt + INTEGER, INTENT(INOUT) :: ILAND + +!---- Below are the arrays for the vegetation parameters + REAL, DIMENSION( 1:nvegclas ) :: LALB, & + LEMI, & + LROU_MYJ,& + LROU + +!************************************************************************ +!-- USGS model +! + DATA LALB/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & + .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55/ + DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & + .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95/ +!-- Roughness length is changed for forests and some others +! next 2 lines - table from RUC + DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & + 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + +! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & +! .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + +! With MYJSFC better use the table from MYJSFCINIT + DATA LROU_MYJ/1.0,.07,.07,.07,.07,.15,.08,.03,.05,.86,.8,.85, & + 2.65,1.09,.8,.001,.04,.05,.01,.04,.06,.05,.03,.001/ + + + +!-------------------------------------------------------------------------- + + EMISS = LEMI(IVGTYP) + if(myj) then + ZNT = LROU_MYJ(IVGTYP) + else + ZNT = LROU(IVGTYP) + endif + ILAND = IVGTYP +! --- + +! RETURN +! END +!-------------------------------------------------------------------------- + END SUBROUTINE SNOWFREE + + SUBROUTINE LSMRUCINIT( SMFR3D,TSLB,SMOIS,ISLTYP,mavail, & + nzs, restart, & + allowed_to_read , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + nzs + + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(IN) :: TSLB, & + SMOIS + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ISLTYP + + REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + INTENT(INOUT) :: SMFR3D + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: MAVAIL + + REAL, DIMENSION ( 1:nzs ) :: SOILIQW + + LOGICAL , INTENT(IN) :: restart, allowed_to_read + +! + INTEGER :: I,J,L,itf,jtf + REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + + RIW=900.*1.e-3 + XLMELT=3.335E+5 + + DO J=jts,jtf + DO I=its,itf + + CALL SOILIN ( ISLTYP(I,J), DQM, REF, PSIS, QMIN, BCLH ) + + +!--- Computation of volumetric content of ice in soil +!--- and initialize MAVAIL + + IF (.not.restart) THEN + if(isltyp(i,j).ne.14) then + mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/dqm)) +! mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/(ref-qmin))) + else + mavail(i,j) = 1. + endif + DO L=1,NZS + if(isltyp(i,j).ne.14) then +!-- for land points initialize soil ice + tln=log(TSLB(i,l,j)/273.15) + + if(tln.lt.0.) then + soiliqw(l)=(dqm+qmin)*(XLMELT* & + (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(l)=max(0.,soiliqw(l)) + soiliqw(l)=min(soiliqw(l),smois(i,l,j)) + smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW + + else + smfr3d(i,l,j)=0. + endif + else +!-- for water points + smfr3d(i,l,j)=0. + endif + + ENDDO + ENDIF + + ENDDO + ENDDO + + END SUBROUTINE lsmrucinit + + SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) + +!--- soiltyp classification according to STATSGO(nclasses=16) +! +! 1 SAND SAND +! 2 LOAMY SAND LOAMY SAND +! 3 SANDY LOAM SANDY LOAM +! 4 SILT LOAM SILTY LOAM +! 5 SILT SILTY LOAM +! 6 LOAM LOAM +! 7 SANDY CLAY LOAM SANDY CLAY LOAM +! 8 SILTY CLAY LOAM SILTY CLAY LOAM +! 9 CLAY LOAM CLAY LOAM +! 10 SANDY CLAY SANDY CLAY +! 11 SILTY CLAY SILTY CLAY +! 12 CLAY LIGHT CLAY +! 13 ORGANIC MATERIALS LOAM +! 14 WATER +! 15 BEDROCK +! Bedrock is reclassified as class 14 +! 16 OTHER (land-ice) +! extra classes from Fei Chen +! 17 Playa +! 18 Lava +! 19 White Sand +! +!---------------------------------------------------------------------- + integer, parameter :: nsoilclas=19 + + integer, intent ( in) :: isltyp + real, intent ( out) :: dqm,ref,qmin,psis + + REAL LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & + LPSI(nsoilclas),LQMI(nsoilclas) + +!-- LQMA Rawls et al.[1982] +! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, +! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/ +!--- +!-- Clapp, R. and G. Hornberger, Empirical equations for some soil +! hydraulic properties, Water Resour. Res., 14,601-604,1978. +!-- Clapp et al. [1978] + DATA LQMA /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & + 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, & + 0.20, 0.435, 0.468, 0.200, 0.339/ + +!-- Clapp et al. [1978] + DATA LREF /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & + 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., & + 0.1, 0.249, 0.454, 0.17, 0.236/ + +!-- Carsel and Parrish [1988] + DATA LQMI/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & + 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & + 0.004, 0.065, 0.020, 0.004, 0.008/ + +!-- Clapp et al. [1978] + DATA LPSI/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & + 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, & + 0.121, 0.218, 0.468, 0.069, 0.069/ + +!-- Clapp et al. [1978] + DATA LBCL/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & + 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, & + 4.05, 4.90, 11.55, 2.79, 2.79/ + + + DQM = LQMA(ISLTYP)- & + LQMI(ISLTYP) + REF = LREF(ISLTYP) + PSIS = - LPSI(ISLTYP) + QMIN = LQMI(ISLTYP) + BCLH = LBCL(ISLTYP) + + END SUBROUTINE SOILIN + +END MODULE module_sf_ruclsm diff --git a/wrfv2_fire/phys/module_sf_sfcdiags.F b/wrfv2_fire/phys/module_sf_sfcdiags.F new file mode 100644 index 00000000..05af5d49 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_sfcdiags.F @@ -0,0 +1,47 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_sf_sfcdiags + +CONTAINS + + SUBROUTINE SFCDIAGS(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & + PSFC,CP,R_d,ROVCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN) :: HFX, & + QFX, & + TSK, & + QSFC + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: Q2, & + TH2, & + T2 + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN) :: PSFC, & + CHS2, & + CQS2 + REAL, INTENT(IN ) :: CP,R_d,ROVCP +! LOCAL VARS + INTEGER :: I,J + REAL :: RHO + + DO J=jts,jte + DO I=its,ite + RHO = PSFC(I,J)/(R_d * TSK(I,J)) + Q2(I,J) = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J)) + T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) + TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP + ENDDO + ENDDO + + END SUBROUTINE SFCDIAGS + +END MODULE module_sf_sfcdiags diff --git a/wrfv2_fire/phys/module_sf_sfclay.F b/wrfv2_fire/phys/module_sf_sfclay.F new file mode 100644 index 00000000..13d466e8 --- /dev/null +++ b/wrfv2_fire/phys/module_sf_sfclay.F @@ -0,0 +1,785 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_sf_sfclay + + REAL , PARAMETER :: VCONVC=1. + REAL , PARAMETER :: CZO=0.0185 + REAL , PARAMETER :: OZO=1.59E-5 + + REAL, DIMENSION(0:1000 ),SAVE :: PSIMTB,PSIHTB + +CONTAINS + +!------------------------------------------------------------------- + SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & + CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM, & + ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, & + XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & + uratx,vratx,tratx, & + U10,V10,TH2,T2,Q2, & + GZ1OZ0,WSPD,BR,ISFFLX,DX, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & + KARMAN,EOMEG,STBOLT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- dz8w dz between full levels (m) +!-- CP heat capacity at constant pressure for dry air (J/kg/K) +!-- G acceleration due to gravity (m/s^2) +!-- ROVCP R/CP +!-- R gas constant for dry air (J/kg/K) +!-- XLV latent heat of vaporization for water (J/kg) +!-- PSFC surface pressure (Pa) +!-- ZNT roughness length (m) +!-- UST u* in similarity theory (m/s) +!-- PBLH PBL height from previous time (m) +!-- MAVAIL surface moisture availability (between 0 and 1) +!-- ZOL z/L height over Monin-Obukhov length +!-- MOL T* (similarity theory) (K) +!-- REGIME flag indicating PBL regime (stable, unstable, etc.) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity stability function for heat +!-- XLAND land mask (1 for land, 2 for water) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH net upward latent heat flux at surface (W/m^2) +!-- TSK surface temperature (K) +!-- FLHC exchange coefficient for heat (W/m^2/K) +!-- FLQC exchange coefficient for moisture (kg/m^2/s) +!-- CHS heat/moisture exchange coefficient for LSM (m/s) +!-- QGH lowest-level saturated mixing ratio +!-- QSFC ground saturated mixing ratio +!-- uratx ratio of surface U to U10 +!-- vratx ratio of surface V to V10 +!-- tratx ratio of surface T to TH2 +!-- U10 diagnostic 10m u wind +!-- V10 diagnostic 10m v wind +!-- TH2 diagnostic 2m theta (K) +!-- T2 diagnostic 2m temperature (K) +!-- Q2 diagnostic 2m mixing ratio (kg/kg) +!-- GZ1OZ0 log(z/z0) where z0 is roughness length +!-- WSPD wind speed at lowest model level (m/s) +!-- BR bulk Richardson number in surface layer +!-- ISFFLX isfflx=1 for surface heat and moisture fluxes +!-- DX horizontal grid size (m) +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) +!-- SVPT0 constant for saturation vapor pressure (K) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- EP2 constant for specific humidity calculation +! (R_d/R_v) (dimensionless) +!-- KARMAN Von Karman constant +!-- EOMEG angular velocity of earth's rotation (rad/s) +!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte +! + INTEGER, INTENT(IN ) :: ISFFLX + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + P3D, & + T3D + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: MAVAIL, & + PBLH, & + XLAND, & + TSK + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT ) :: U10, & + V10, & + TH2, & + T2, & + Q2, & + QSFC + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: uratx,vratx,tratx +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: REGIME, & + HFX, & + QFX, & + LH, & + MOL,RMOL +!m the following 5 are change to memory size +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & + PSIM,PSIH + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: U3D, & + V3D + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: PSFC + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ZNT, & + ZOL, & + UST, & + CPM, & + CHS2, & + CQS2, & + CHS + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: FLHC,FLQC + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: & + QGH + + + + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + +! LOCAL VARS + + REAL, DIMENSION( its:ite ) :: U1D, & + V1D, & + QV1D, & + P1D, & + T1D + + REAL, DIMENSION( its:ite ) :: dz8w1d + + INTEGER :: I,J + + DO J=jts,jte + DO i=its,ite + dz8w1d(I) = dz8w(i,1,j) + ENDDO + + DO i=its,ite + U1D(i) =U3D(i,1,j) + V1D(i) =V3D(i,1,j) + QV1D(i)=QV3D(i,1,j) + P1D(i) =P3D(i,1,j) + T1D(i) =T3D(i,1,j) + ENDDO + + CALL SFCLAY1D(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & + CP,G,ROVCP,R,XLV,PSFC(ims,j),CHS(ims,j),CHS2(ims,j),& + CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j), & + ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j), & + MOL(ims,j),REGIME(ims,j),PSIM(ims,j),PSIH(ims,j), & + XLAND(ims,j),HFX(ims,j),QFX(ims,j),TSK(ims,j), & + uratx(ims,j),vratx(ims,j),tratx(ims,j), & + U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), & + Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j), & + QSFC(ims,j),LH(ims,j), & + GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDDO + + + END SUBROUTINE SFCLAY + + +!------------------------------------------------------------------- + SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & + CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, & + ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, & + XLAND,HFX,QFX,TSK, & + uratx,vratx,tratx, & + U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH, & + QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & + KARMAN,EOMEG,STBOLT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- + REAL, PARAMETER :: XKA=2.4E-5 + REAL, PARAMETER :: PRT=1. + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + J +! + INTEGER, INTENT(IN ) :: ISFFLX + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT + +! + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: MAVAIL, & + PBLH, & + XLAND, & + TSK +! + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: PSFCPA + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: REGIME, & + HFX, & + QFX, & + MOL,RMOL +!m the following 5 are changed to memory size--- +! + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & + PSIM,PSIH + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: ZNT, & + ZOL, & + UST, & + CPM, & + CHS2, & + CQS2, & + CHS + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: FLHC,FLQC + + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: & + QGH + + REAL, DIMENSION( ims:ime ) , & + INTENT(OUT) :: U10,V10, & + TH2,T2,Q2,QSFC,LH + + REAL, DIMENSION( ims:ime ) , & + INTENT(OUT) :: uratx,vratx,tratx + + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + +! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY + REAL, DIMENSION( its:ite ), INTENT(IN ) :: dz8w1d + + REAL, DIMENSION( its:ite ), INTENT(IN ) :: UX, & + VX, & + QV1D, & + P1D, & + T1D + +! LOCAL VARS + + REAL, DIMENSION( its:ite ) :: ZA, & + THVX,ZQKL, & + ZQKLP1, & + THX,QX, & + PSIH2, & + PSIM2, & + PSIH10, & + PSIM10, & + GZ2OZ0, & + GZ10OZ0 +! + REAL, DIMENSION( its:ite ) :: & + RHOX,GOVRTH, & + TGDSA +! + REAL, DIMENSION( its:ite) :: SCR3,SCR4 + REAL, DIMENSION( its:ite ) :: THGB, PSFC +! + INTEGER :: KL + + INTEGER :: N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10 + + REAL :: PL,THCON,TVCON,E1 + REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 + REAL :: DTG,PSIX,USTM,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2 + REAL :: FLUXC,VSGD +!------------------------------------------------------------------- + KL=kte + + DO i=its,ite +! PSFC cmb + PSFC(I)=PSFCPA(I)/1000. + ENDDO +! +!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: +! + DO 5 I=its,ite + TGDSA(I)=TSK(I) +! PSFC cmb + THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP + 5 CONTINUE +! +!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., +! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. +! +! *** NOTE *** +! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, +! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE +! TENDENCIES. +! + 10 CONTINUE + +! DO 24 I=its,ite +! UX(I)=U1D(I) +! VX(I)=V1D(I) +! 24 CONTINUE + + 26 CONTINUE + +!.....SCR3(I,K) STORE TEMPERATURE, +! SCR4(I,K) STORE VIRTUAL TEMPERATURE. + + DO 30 I=its,ite +! PL cmb + PL=P1D(I)/1000. + SCR3(I)=T1D(I) + THCON=(100./PL)**ROVCP + THX(I)=SCR3(I)*THCON + SCR4(I)=SCR3(I) + THVX(I)=THX(I) + QX(I)=0. + 30 CONTINUE +! + DO I=its,ite + QGH(I)=0. + FLHC(I)=0. + FLQC(I)=0. + CPM(I)=CP + ENDDO +! +! IF(IDRY.EQ.1)GOTO 80 + DO 50 I=its,ite + QX(I)=QV1D(I) + TVCON=(1.+EP1*QX(I)) + THVX(I)=THX(I)*TVCON + SCR4(I)=SCR3(I)*TVCON + 50 CONTINUE +! + DO 60 I=its,ite + E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) + QSFC(I)=EP2*E1/(PSFC(I)-E1) +! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE +! Q2SAT = QGH IN LSM + E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) + QGH(I)=EP2*E1/(PSFC(I)-E1) + CPM(I)=CP*(1.+0.8*QX(I)) + 60 CONTINUE + 80 CONTINUE + +!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND +! LEVEL, AND THE LAYER THICKNESSES. + + DO 90 I=its,ite + ZQKLP1(I)=0. + RHOX(I)=PSFC(I)*1000./(R*SCR4(I)) + 90 CONTINUE +! + DO 110 I=its,ite + ZQKL(I)=dz8w1d(I)+ZQKLP1(I) + 110 CONTINUE +! + DO 120 I=its,ite + ZA(I)=0.5*(ZQKL(I)+ZQKLP1(I)) + 120 CONTINUE +! + DO 160 I=its,ite + GOVRTH(I)=G/THX(I) + 160 CONTINUE + +!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO +! AKB(1976), EQ(12). + + DO 260 I=its,ite + GZ1OZ0(I)=ALOG(ZA(I)/ZNT(I)) + GZ2OZ0(I)=ALOG(2./ZNT(I)) + GZ10OZ0(I)=ALOG(10./ZNT(I)) + IF((XLAND(I)-1.5).GE.0)THEN + ZL=ZNT(I) + ELSE + ZL=0.01 + ENDIF + WSPD(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) + + TSKV=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) + DTHVDZ=(THVX(I)-TSKV) +! Convective velocity scale Vc and subgrid-scale velocity Vsg +! following Beljaars (1995, QJRMS) and Mahrt and Sun (1995, MWR) +! ... HONG Aug. 2001 +! +! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) + fluxc = max(hfx(i)/rhox(i)/cp & + + ep1*tskv*qfx(i)/rhox(i),0.) + VCONV = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 +! IF(-DTHVDZ.GE.0)THEN +! DTHVM=-DTHVDZ +! ELSE +! DTHVM=0. +! ENDIF +! VCONV = max(vconv,VCONVC*SQRT(DTHVM)) +! VCONV comes from Beljaars only + VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 + WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV+vsgd*vsgd) + WSPD(I)=AMAX1(WSPD(I),0.1) + BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) +! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 + IF(MOL(I).LT.0.)BR(I)=AMIN1(BR(I),0.0) +!jdf + RMOL(I)=-GOVRTH(I)*DTHVDZ*ZA(I)*KARMAN +!jdf + + 260 CONTINUE + +! +!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: +! +! +! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) +! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). +! +! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: +! +! 1. BR .GE. 0.2; +! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), +! +! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; +! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS +! (REGIME=2), +! +! 3. BR .EQ. 0.0 +! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), +! +! 4. BR .LT. 0.0 +! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). +! +!CCCCC + + DO 320 I=its,ite +!CCCCC +!CC REMOVE REGIME 3 DEPENDENCE ON PBL HEIGHT +!CC IF(BR(I).LT.0..AND.HOL(I,J).GT.1.5)GOTO 310 + IF(BR(I).LT.0.)GOTO 310 +! +!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: +! + IF(BR(I).LT.0.2)GOTO 270 + REGIME(I)=1. + PSIM(I)=-10.*GZ1OZ0(I) +! LOWER LIMIT ON PSI IN STABLE CONDITIONS + PSIM(I)=AMAX1(PSIM(I),-10.) + PSIH(I)=PSIM(I) + PSIM10(I)=10./ZA(I)*PSIM(I) + PSIM10(I)=AMAX1(PSIM10(I),-10.) + PSIH10(I)=PSIM10(I) + PSIM2(I)=2./ZA(I)*PSIM(I) + PSIM2(I)=AMAX1(PSIM2(I),-10.) + PSIH2(I)=PSIM2(I) + +! 1.0 over Monin-Obukhov length + IF(UST(I).LT.0.01)THEN + RMOL(I)=BR(I)*GZ1OZ0(I) !ZA/L + ELSE + RMOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(UST(I)*UST(I)) !ZA/L + ENDIF + RMOL(I)=AMIN1(RMOL(I),9.999) ! ZA/L + RMOL(I) = RMOL(I)/ZA(I) !1.0/L + + GOTO 320 +! +!-----CLASS 2; DAMPED MECHANICAL TURBULENCE: +! + 270 IF(BR(I).EQ.0.0)GOTO 280 + REGIME(I)=2. + PSIM(I)=-5.0*BR(I)*GZ1OZ0(I)/(1.1-5.0*BR(I)) +! LOWER LIMIT ON PSI IN STABLE CONDITIONS + PSIM(I)=AMAX1(PSIM(I),-10.) +!.....AKB(1976), EQ(16). + PSIH(I)=PSIM(I) + PSIM10(I)=10./ZA(I)*PSIM(I) + PSIM10(I)=AMAX1(PSIM10(I),-10.) + PSIH10(I)=PSIM10(I) + PSIM2(I)=2./ZA(I)*PSIM(I) + PSIM2(I)=AMAX1(PSIM2(I),-10.) + PSIH2(I)=PSIM2(I) + + ! Linear form: PSIM = -0.5*ZA/L; e.g, see eqn 16 of + ! Blackadar, Modeling the nocturnal boundary layer, Preprints, + ! Third Symposium on Atmospheric Turbulence Diffusion and Air Quality, + ! Raleigh, NC, 1976 + ZOL(I) = BR(I)*GZ1OZ0(I)/(1.00001-5.0*BR(I)) + + if ( ZOL(I) .GT. 0.5 ) then ! linear form ok + ! Holtslag and de Bruin, J. App. Meteor 27, 689-704, 1988; + ! see also, Launiainen, Boundary-Layer Meteor 76,165-179, 1995 + ! Eqn (8) of Launiainen, 1995 + ZOL(I) = ( 1.89*GZ1OZ0(I) + 44.2 ) * BR(I)*BR(I) & + + ( 1.18*GZ1OZ0(I) - 1.37 ) * BR(I) + ZOL(I)=AMIN1(ZOL(I),9.999) + end if + + ! 1.0 over Monin-Obukhov length + RMOL(I)= ZOL(I)/ZA(I) + + GOTO 320 +! +!-----CLASS 3; FORCED CONVECTION: +! + 280 REGIME(I)=3. + PSIM(I)=0.0 + PSIH(I)=PSIM(I) + PSIM10(I)=0. + PSIH10(I)=PSIM10(I) + PSIM2(I)=0. + PSIH2(I)=PSIM2(I) + + + IF(UST(I).LT.0.01)THEN + ZOL(I)=BR(I)*GZ1OZ0(I) + ELSE + ZOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(UST(I)*UST(I)) + ENDIF + + RMOL(I) = ZOL(I)/ZA(I) + + GOTO 320 +! +!-----CLASS 4; FREE CONVECTION: +! + 310 CONTINUE + REGIME(I)=4. + IF(UST(I).LT.0.01)THEN + ZOL(I)=BR(I)*GZ1OZ0(I) + ELSE + ZOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(UST(I)*UST(I)) + ENDIF + ZOL10=10./ZA(I)*ZOL(I) + ZOL2=2./ZA(I)*ZOL(I) + ZOL(I)=AMIN1(ZOL(I),0.) + ZOL(I)=AMAX1(ZOL(I),-9.9999) + ZOL10=AMIN1(ZOL10,0.) + ZOL10=AMAX1(ZOL10,-9.9999) + ZOL2=AMIN1(ZOL2,0.) + ZOL2=AMAX1(ZOL2,-9.9999) + NZOL=INT(-ZOL(I)*100.) + RZOL=-ZOL(I)*100.-NZOL + NZOL10=INT(-ZOL10*100.) + RZOL10=-ZOL10*100.-NZOL10 + NZOL2=INT(-ZOL2*100.) + RZOL2=-ZOL2*100.-NZOL2 + PSIM(I)=PSIMTB(NZOL)+RZOL*(PSIMTB(NZOL+1)-PSIMTB(NZOL)) + PSIH(I)=PSIHTB(NZOL)+RZOL*(PSIHTB(NZOL+1)-PSIHTB(NZOL)) + PSIM10(I)=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10)) + PSIH10(I)=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10)) + PSIM2(I)=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2)) + PSIH2(I)=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2)) + +!---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS +!--- THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL +! PSIH(I)=AMIN1(PSIH(I),0.9*GZ1OZ0(I)) +! PSIM(I)=AMIN1(PSIM(I),0.9*GZ1OZ0(I)) + PSIH(I)=AMIN1(PSIH(I),0.9*GZ1OZ0(I)) + PSIM(I)=AMIN1(PSIM(I),0.9*GZ1OZ0(I)) + PSIH2(I)=AMIN1(PSIH2(I),0.9*GZ2OZ0(I)) + PSIM10(I)=AMIN1(PSIM10(I),0.9*GZ10OZ0(I)) + + RMOL(I) = ZOL(I)/ZA(I) + + 320 CONTINUE +! +!-----COMPUTE THE FRICTIONAL VELOCITY: +! ZA(1982) EQS(2.60),(2.61). +! + DO 330 I=its,ite + DTG=THX(I)-THGB(I) + PSIX=GZ1OZ0(I)-PSIM(I) + PSIX10=GZ10OZ0(I)-PSIM10(I) +! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL +! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 + PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) + + IF((XLAND(I)-1.5).GE.0)THEN + ZL=ZNT(I) + ELSE + ZL=0.01 + ENDIF + PSIQ=ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-PSIH(I) + PSIT2=GZ2OZ0(I)-PSIH2(I) + PSIQ2=ALOG(KARMAN*UST(I)*2./XKA+2./ZL)-PSIH2(I) +! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE + UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX + U10(I)=UX(I)*PSIX10/PSIX + V10(I)=VX(I)*PSIX10/PSIX + TH2(I)=THGB(I)+DTG*PSIT2/PSIT + Q2(I)=QSFC(I)+(QX(I)-QSFC(I))*PSIQ2/PSIQ + T2(I) = TH2(I)*(PSFC(I)/100.)**ROVCP +! LATER Q2 WILL BE OVERWRITTEN FOR LAND POINTS IN SURFCE +! QA2(I,J) = Q2(I) +! UA10(I,J) = U10(I) +! VA10(I,J) = V10(I) +! write(*,1002)UST(I),KARMAN*WSPD(I),PSIX,KARMAN*WSPD(I)/PSIX +! + IF(ABS(U10(I)) .GT. 1.E-10) THEN + uratx(I) = UX(I)/U10(I) + ELSE + uratx(I) = 1.2 + END IF + IF(ABS(V10(I)) .GT. 1.E-10) THEN + vratx(I) = VX(I)/V10(I) + ELSE + vratx(I) = 1.2 + END IF + tratx(I) = THX(I)/TH2(I) + + USTM=AMAX1(UST(I),0.1) + IF((XLAND(I)-1.5).GE.0)THEN + UST(I)=UST(I) + ELSE + UST(I)=USTM + ENDIF +! write(*,1002)UST(I),USTM,I,J + 1002 format(f15.12,2x,f15.12,2x,f15.12,2x,f15.12,2x,f15.12) + MOL(I)=KARMAN*DTG/PSIT/PRT + 330 CONTINUE +! + 335 CONTINUE + +!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: + + DO i=its,ite + QFX(i)=0. + HFX(i)=0. + ENDDO + + IF (ISFFLX.EQ.0) GOTO 410 + +!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). + + DO 360 I=its,ite + IF((XLAND(I)-1.5).GE.0)THEN + ZNT(I)=CZO*UST(I)*UST(I)/G+OZO + ENDIF + IF((XLAND(I)-1.5).GE.0)THEN + ZL=ZNT(I) + ELSE + ZL=0.01 + ENDIF + FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/( & + ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-PSIH(I)) + DTTHX=ABS(THX(I)-THGB(I)) + IF(DTTHX.GT.1.E-5)THEN + FLHC(I)=CPM(I)*RHOX(I)*UST(I)*MOL(I)/(THX(I)-THGB(I)) +! write(*,1001)FLHC(I),CPM(I),RHOX(I),UST(I),MOL(I),THX(I),THGB(I),I + 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) + ELSE + FLHC(I)=0. + ENDIF + 360 CONTINUE + +! +!-----COMPUTE SURFACE MOIST FLUX: +! +! IF(IDRY.EQ.1)GOTO 390 +! + DO 370 I=its,ite + QFX(I)=FLQC(I)*(QSFC(I)-QX(I)) + QFX(I)=AMAX1(QFX(I),0.) + LH(I)=XLV*QFX(I) + 370 CONTINUE + +!-----COMPUTE SURFACE HEAT FLUX: +! + 390 CONTINUE + DO 400 I=its,ite + IF(XLAND(I)-1.5.GT.0.)THEN + HFX(I)=FLHC(I)*(THGB(I)-THX(I)) + ELSEIF(XLAND(I)-1.5.LT.0.)THEN + HFX(I)=FLHC(I)*(THGB(I)-THX(I)) + HFX(I)=AMAX1(HFX(I),-250.) + ENDIF + 400 CONTINUE + + DO I=its,ite + IF((XLAND(I)-1.5).GE.0)THEN + ZL=ZNT(I) + ELSE + ZL=0.01 + ENDIF + CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & + /XKA+ZA(I)/ZL)-PSIH(I)) +! GZ2OZ0(I)=ALOG(2./ZNT(I)) +! PSIM2(I)=-10.*GZ2OZ0(I) +! PSIM2(I)=AMAX1(PSIM2(I),-10.) +! PSIH2(I)=PSIM2(I) + CQS2(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*2.0 & + /XKA+2.0/ZL)-PSIH2(I)) + CHS2(I)=UST(I)*KARMAN/(GZ2OZ0(I)-PSIH2(I)) + ENDDO + + 410 CONTINUE +!jdf +! DO I=its,ite +! IF(UST(I).GE.0.1) THEN +! RMOL(I)=RMOL(I)*(-FLHC(I))/(UST(I)*UST(I)*UST(I)) +! ELSE +! RMOL(I)=RMOL(I)*(-FLHC(I))/(0.1*0.1*0.1) +! ENDIF +! ENDDO +!jdf + +! + END SUBROUTINE SFCLAY1D + +!==================================================================== + SUBROUTINE sfclayinit( allowed_to_read ) + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER :: N + REAL :: ZOLN,X,Y + + DO N=0,1000 + ZOLN=-FLOAT(N)*0.01 + X=(1-16.*ZOLN)**0.25 + PSIMTB(N)=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))- & + 2.*ATAN(X)+2.*ATAN(1.) + Y=(1-16*ZOLN)**0.5 + PSIHTB(N)=2*ALOG(0.5*(1+Y)) + ENDDO + + END SUBROUTINE sfclayinit + +!------------------------------------------------------------------- + +END MODULE module_sf_sfclay diff --git a/wrfv2_fire/phys/module_sf_slab.F b/wrfv2_fire/phys/module_sf_slab.F new file mode 100644 index 00000000..f4d75dfc --- /dev/null +++ b/wrfv2_fire/phys/module_sf_slab.F @@ -0,0 +1,540 @@ +!WRF:MODEL_LAYER:PHYSICS +! +MODULE module_sf_slab + + !---SPECIFY CONSTANTS AND LAYERS FOR SOIL MODEL + !---SOIL DIFFUSION CONSTANT SET (M^2/S) + + REAL, PARAMETER :: DIFSL=5.e-7 + + !---FACTOR TO MAKE SOIL STEP MORE CONSERVATIVE + + REAL , PARAMETER :: SOILFAC=1.25 + +CONTAINS + +!---------------------------------------------------------------- + SUBROUTINE SLAB(T3D,QV3D,P3D,FLHC,FLQC, & + PSFC,XLAND,TMN,HFX,QFX,LH,TSK,QSFC,CHKLOWQ, & + GSW,GLW,CAPG,THC,SNOWC,EMISS,MAVAIL, & + DELTSM,ROVCP,XLV,DTMIN,IFSNOW, & + SVP1,SVP2,SVP3,SVPT0,EP2, & + KARMAN,EOMEG,STBOLT, & + TSLB,ZS,DZS,num_soil_layers,radiation, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +! +! SUBROUTINE SLAB CALCULATES THE GROUND TEMPERATURE TENDENCY +! ACCORDING TO THE RESIDUAL OF THE SURFACE ENERGY BUDGET +! (BLACKADAR, 1978B). +! +! CHANGES: +! FOR SOIL SUB-TIMESTEPS UPDATE SURFACE HFX AND QFX AS TG +! CHANGES TO PREVENT POSSIBLE INSTABILITY FOR LONG MODEL +! STEPS (DT > ~200 SEC). +! +! PUT SNOW COVER CHECK ON SOIL SUB-TIMESTEPS +! +! MAKE UPPER LIMIT ON SOIL SUB-STEP LENGTH MORE CONSERVATIVE +! +!---------------------------------------------------------------- +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- FLHC exchange coefficient for heat (m/s) +!-- FLQC exchange coefficient for moisture (m/s) +!-- PSFC surface pressure (Pa) +!-- XLAND land mask (1 for land, 2 for water) +!-- TMN soil temperature at lower boundary (K) +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH latent heat flux at the surface (W/m^2) +!-- TSK surface temperature (K) +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- THC thermal inertia (Cal/cm/K/s^0.5) +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- EMISS surface emissivity (between 0 and 1) +!-- DELTSM time step (second) +!-- ROVCP R/CP +!-- XLV latent heat of melting (J/kg) +!-- DTMIN time step (minute) +!-- IFSNOW ifsnow=1 for snow-cover effects +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) +!-- SVPT0 constant for saturation vapor pressure (K) +!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) +!-- EP2 constant for specific humidity calculation +! (R_d/R_v) (dimensionless) +!-- KARMAN Von Karman constant +!-- EOMEG angular velocity of earth's rotation (rad/s) +!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) +!-- TSLB soil temperature in 5-layer model +!-- ZS depths of centers of soil layers +!-- DZS thicknesses of soil layers +!-- num_soil_layers the number of soil layers +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!---------------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: num_soil_layers + LOGICAL, INTENT(IN) :: radiation + + INTEGER, INTENT(IN ) :: IFSNOW + +! + REAL, INTENT(IN ) :: DTMIN,XLV,ROVCP,DELTSM + + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP2,KARMAN,EOMEG,STBOLT + + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(INOUT) :: TSLB + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::ZS,DZS + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + P3D, & + T3D +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: SNOWC, & + XLAND, & + EMISS, & + MAVAIL, & + TMN, & + GSW, & + GLW, & + THC + +!CHKLOWQ is declared as memory size +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: HFX, & + QFX, & + LH, & + CAPG, & + TSK, & + QSFC, & + CHKLOWQ + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: PSFC +! + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + FLHC, & + FLQC + +! LOCAL VARS + + REAL, DIMENSION( its:ite ) :: QV1D, & + P1D, & + T1D + INTEGER :: I,J + + DO J=jts,jte + + DO i=its,ite + T1D(i) =T3D(i,1,j) + QV1D(i)=QV3D(i,1,j) + P1D(i) =P3D(i,1,j) + ENDDO + +! the indices to the PSFC argument in the following call look +! wrong; however, it is correct to call with its (and not ims) +! because of the way PSFC is defined in SLAB1D. Whether *that* +! is a good idea or not, this commenter cannot comment. JM + + CALL SLAB1D(J,T1D,QV1D,P1D,FLHC(ims,j),FLQC(ims,j), & + PSFC(its,j),XLAND(ims,j),TMN(ims,j),HFX(ims,j), & + QFX(ims,j),TSK(ims,j),QSFC(ims,j),CHKLOWQ(ims,j), & + LH(ims,j),GSW(ims,j),GLW(ims,j), & + CAPG(ims,j),THC(ims,j),SNOWC(ims,j),EMISS(ims,j), & + MAVAIL(ims,j),DELTSM,ROVCP,XLV,DTMIN,IFSNOW, & + SVP1,SVP2,SVP3,SVPT0,EP2,KARMAN,EOMEG,STBOLT, & + TSLB(ims,1,j),ZS,DZS,num_soil_layers,radiation, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + ENDDO + + END SUBROUTINE SLAB + +!---------------------------------------------------------------- + SUBROUTINE SLAB1D(J,T1D,QV1D,P1D,FLHC,FLQC, & + PSFCPA,XLAND,TMN,HFX,QFX,TSK,QSFC,CHKLOWQ, & + LH,GSW,GLW,CAPG,THC,SNOWC,EMISS,MAVAIL, & + DELTSM,ROVCP,XLV,DTMIN,IFSNOW, & + SVP1,SVP2,SVP3,SVPT0,EP2, & + KARMAN,EOMEG,STBOLT, & + TSLB2D,ZS,DZS,num_soil_layers,radiation, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +! +! SUBROUTINE SLAB CALCULATES THE GROUND TEMPERATURE TENDENCY +! ACCORDING TO THE RESIDUAL OF THE SURFACE ENERGY BUDGET +! (BLACKADAR, 1978B). +! +! CHANGES: +! FOR SOIL SUB-TIMESTEPS UPDATE SURFACE HFX AND QFX AS TG +! CHANGES TO PREVENT POSSIBLE INSTABILITY FOR LONG MODEL +! STEPS (DT > ~200 SEC). +! +! PUT SNOW COVER CHECK ON SOIL SUB-TIMESTEPS +! +! MAKE UPPER LIMIT ON SOIL SUB-STEP LENGTH MORE CONSERVATIVE +! +!---------------------------------------------------------------- + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,J + + INTEGER , INTENT(IN) :: num_soil_layers + LOGICAL, INTENT(IN ) :: radiation + + INTEGER, INTENT(IN ) :: IFSNOW +! + REAL, INTENT(IN ) :: DTMIN,XLV,ROVCP,DELTSM + + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN ) :: EP2,KARMAN,EOMEG,STBOLT + + REAL, DIMENSION( ims:ime , 1:num_soil_layers ), & + INTENT(INOUT) :: TSLB2D + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::ZS,DZS + +! + REAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: HFX, & + QFX, & + LH, & + CAPG, & + TSK, & + QSFC, & + CHKLOWQ +! + REAL, DIMENSION( ims:ime ) , & + INTENT(IN ) :: SNOWC, & + XLAND, & + EMISS, & + MAVAIL, & + TMN, & + GSW, & + GLW, & + THC +! + REAL, DIMENSION( its:ite ) , & + INTENT(IN ) :: QV1D, & + P1D, & + T1D +! + REAL, DIMENSION( its:ite ) , & + INTENT(IN ) :: PSFCPA + +! + REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: & + FLHC, & + FLQC +! LOCAL VARS + + REAL, DIMENSION( its:ite ) :: PSFC + + REAL, DIMENSION( its:ite ) :: & + THX, & + QX, & + SCR3 + + REAL, DIMENSION( its:ite ) :: DTHGDT, & + TG0, & + THTMN, & + XLD1, & + TSCVN, & + OLTG, & + UPFLUX, & + HM, & + RNET, & + XINET, & + QS, & + DTSDT +! + REAL, DIMENSION( its:ite, num_soil_layers ) :: FLUX +! + INTEGER :: I,K,NSOIL,ITSOIL,L,NK,RADSWTCH + REAL :: PS,PS1,XLDCOL,TSKX,RNSOIL,RHOG1,RHOG2,RHOG3,LAMDAG + REAL :: THG,ESG,QSG,HFXT,QFXT,CS,CSW,LAMG(4),THCON,PL + +!---------------------------------------------------------------------- +!-----DETERMINE IF ANY POINTS IN COLUMN ARE LAND (RATHER THAN OCEAN) +! POINTS. IF NOT, SKIP DOWN TO THE PRINT STATEMENTS SINCE OCEAN +! SURFACE TEMPERATURES ARE NOT ALLOWED TO CHANGE. +! +! from sfcrad +!---------------------------------------------------------------------- + DATA CSW/4.183E6/ + DATA LAMG/1.407E-8, -1.455E-5, 6.290E-3, 0.16857/ + + DO i=its,ite +! in cmb + PSFC(I)=PSFCPA(I)/1000. + ENDDO + + + DO I=its,ite +! PL cmb + PL=P1D(I)/1000. + SCR3(I)=T1D(I) + THCON=(100./PL)**ROVCP + THX(I)=SCR3(I)*THCON + QX(I)=0. + ENDDO + +! IF(IDRY.EQ.1) GOTO 81 + DO I=its,ite + QX(I)=QV1D(I) + ENDDO + 81 CONTINUE + +! +!-----THE SLAB THERMAL CAPACITY CAPG(I) ARE DEPENDENT ON: +! THC(I) - SOIL THERMAL INERTIAL, ONLY. +! + DO I=its,ite + CAPG(I)=3.298E6*THC(I) + IF(num_soil_layers .gt. 1)THEN + +! CAPG REPRESENTS SOIL HEAT CAPACITY (J/K/M^3) WHEN DIFSL=5.E-7 (M^2/S) +! TO GIVE A CORRECT THERMAL INERTIA (=CAPG*DIFSL^0.5) + + CAPG(I)=5.9114E7*THC(I) + ENDIF + ENDDO +! + XLDCOL=2.0 + DO 10 I=its,ite + XLDCOL=AMIN1(XLDCOL,XLAND(I)) + 10 CONTINUE +! + IF(XLDCOL.GT.1.5)GOTO 90 +! +! +!-----CONVERT SLAB TEMPERATURE TO POTENTIAL TEMPERATURE AND +! SET XLD1(I) = 0. FOR OCEAN POINTS: +! +! + DO 20 I=its,ite + IF((XLAND(I)-1.5).GE.0)THEN + XLD1(I)=0. + ELSE + XLD1(I)=1. + ENDIF + 20 CONTINUE +! +!-----CONVERT 'TSK(THETAG)' TO 'TG' FOR 'IUP' CALCULATION .... +! IF WE ARE USING THE BLACKADAR MULTI-LEVEL (HIGH-RESOLUTION) +! PBL MODEL +! + DO 50 I=its,ite + IF(XLD1(I).LT.0.5)GOTO 50 + +! PS cmb + PS=PSFC(I) + +! TSK is Temperature at gound sfc +! TG0(I)=TSK(I)*(PS*0.01)**ROVCP + TG0(I)=TSK(I) + 50 CONTINUE +! +!-----COMPUTE THE SURFACE ENERGY BUDGET: +! +! IF(ISOIL.EQ.1)NSOIL=1 + IF(num_soil_layers .gt. 1)NSOIL=1 + + + IF (radiation) then + RADSWTCH=1 + ELSE + RADSWTCH=0 + ENDIF + + DO 70 I=its,ite + IF(XLD1(I).LT.0.5)GOTO 70 + OLTG(I)=TSK(I)*(100./PSFC(I))**ROVCP + UPFLUX(I)=RADSWTCH*STBOLT*TG0(I)**4 + XINET(I)=EMISS(I)*(GLW(I)-UPFLUX(I)) + RNET(I)=GSW(I)+XINET(I) + HM(I)=1.18*EOMEG*(TG0(I)-TMN(I)) +! MOISTURE FLUX CALCULATED HERE (OVERWRITES SFC LAYER VALUE FOR LAND) + ESG=SVP1*EXP(SVP2*(TG0(I)-SVPT0)/(TG0(I)-SVP3)) + QSG=EP2*ESG/(PSFC(I)-ESG) + THG=TSK(I)*(100./PSFC(I))**ROVCP + HFX(I)=FLHC(I)*(THG-THX(I)) + QFX(I)=FLQC(I)*(QSG-QX(I)) + LH(I)=QFX(I)*XLV + QS(I)=HFX(I)+QFX(I)*XLV +! IF(ISOIL.EQ.0)THEN + IF(num_soil_layers .EQ. 1)THEN + DTHGDT(I)=(RNET(I)-QS(I))/CAPG(I)-HM(I) + ELSE + DTHGDT(I)=0. + ENDIF + 70 CONTINUE +! IF(ISOIL.EQ.1)THEN + IF(num_soil_layers .gt. 1)THEN + NSOIL=1+IFIX(SOILFAC*4*DIFSL/DZS(1)*DELTSM/DZS(1)) + RNSOIL=1./FLOAT(NSOIL) +! +! SOIL SUB-TIMESTEP +! + DO ITSOIL=1,NSOIL + DO I=its,ite + DO L=1,num_soil_layers-1 + IF(XLD1(I).LT.0.5)GOTO 75 + IF(L.EQ.1.AND.ITSOIL.GT.1)THEN + PS1=(PSFC(I)*0.01)**ROVCP + +! for rk scheme A and B are the same + PS=PSFC(I) + THG=TSLB2D(I,1)/PS1 + ESG=SVP1*EXP(SVP2*(TSLB2D(I,1)-SVPT0)/(TSLB2D(I,1) & + -SVP3)) + QSG=EP2*ESG/(PS-ESG) +! UPDATE FLUXES FOR NEW GROUND TEMPERATURE + HFXT=FLHC(I)*(THG-THX(I)) + QFXT=FLQC(I)*(QSG-QX(I)) + QS(I)=HFXT+QFXT*XLV +! SUM HFX AND QFX OVER SOIL TIMESTEPS + HFX(I)=HFX(I)+HFXT + QFX(I)=QFX(I)+QFXT + ENDIF + FLUX(I,1)=RNET(I)-QS(I) + FLUX(I,L+1)=-DIFSL*CAPG(I)*(TSLB2D(I,L+1)-TSLB2D(I,L))/( & + ZS(L+1)-ZS(L)) + DTSDT(I)=-(FLUX(I,L+1)-FLUX(I,L))/(DZS(L)*CAPG(I)) + TSLB2D(I,L)=TSLB2D(I,L)+DTSDT(I)*DELTSM*RNSOIL + IF(IFSNOW.EQ.1.AND.L.EQ.1)THEN + IF((SNOWC(I).GT.0..AND.TSLB2D(I,1).GT.273.16))THEN + TSLB2D(I,1)=273.16 + ENDIF + ENDIF + IF(L.EQ.1)DTHGDT(I)=DTHGDT(I)+RNSOIL*DTSDT(I) + IF(ITSOIL.EQ.NSOIL.AND.L.EQ.1)THEN +! AVERAGE HFX AND QFX OVER SOIL TIMESTEPS FOR OUTPUT TO PBL + HFX(I)=HFX(I)*RNSOIL + QFX(I)=QFX(I)*RNSOIL + LH(I)=QFX(I)*XLV + ENDIF + 75 CONTINUE + ENDDO + ENDDO + ENDDO + ENDIF +! + DO 80 I=its,ite + IF(XLD1(I).LT.0.5) GOTO 80 + TSKX=TG0(I)+DELTSM*DTHGDT(I) + +! TSK is temperature +! TSK(I)=TSKX*(100./PS1)**ROVCP + TSK(I)=TSKX + 80 CONTINUE + +! +!-----MODIFY THE THE GROUND TEMPERATURE IF THE SNOW COVER EFFECTS ARE +! CONSIDERED: LIMIT THE GROUND TEMPERATURE UNDER 0 C. +! + IF(IFSNOW.EQ.0)GOTO 90 + DO 85 I=its,ite + IF(XLD1(I).LT.0.5)GOTO 85 +! PS1=(PSFC(I)*0.01)**ROVCP +! TSCVN(I)=TSK(I)*PS1 + TSCVN(I)=TSK(I) + IF((SNOWC(I).GT.0..AND.TSCVN(I).GT.273.16))THEN + TSCVN(I)=273.16 + ELSE + TSCVN(I)=TSCVN(I) + ENDIF +! TSK(I)=TSCVN(I)/PS1 + TSK(I)=TSCVN(I) + 85 CONTINUE +! + 90 CONTINUE + DO I=its,ite +! QSFC and CHKLOWQ needed by Eta PBL + QSFC(I)=QX(I)+QFX(I)/FLQC(I) + CHKLOWQ(I)=MAVAIL(I) + ENDDO +! + 140 CONTINUE + + END SUBROUTINE SLAB1D + +!================================================================ + SUBROUTINE slabinit(TSK,TMN, & + TSLB,ZS,DZS,num_soil_layers, & + restart, allowed_to_read, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart, allowed_to_read + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: num_soil_layers +! + REAL, DIMENSION( ims:ime , 1:num_soil_layers , jms:jme ), INTENT(INOUT) :: TSLB + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: ZS,DZS + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN) :: TSK, & + TMN +! LOCAR VAR + + INTEGER :: L,J,I,itf,jtf +!---------------------------------------------------------------- + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + END SUBROUTINE slabinit + +!------------------------------------------------------------------- + +END MODULE module_sf_slab diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F new file mode 100644 index 00000000..13f1929b --- /dev/null +++ b/wrfv2_fire/phys/module_sf_urban.F @@ -0,0 +1,1695 @@ +MODULE module_sf_urban + +!=============================================================================== +! Single-Layer Urban Canopy Model for WRF Noah-LSM +! Original Version: 2002/11/06 by Hiroyuki Kusaka +! Last Update: 2006/08/24 by Fei Chen and Mukul Tewari (NCAR/RAL) +!=============================================================================== + + CHARACTER(LEN=4) :: LU_DATA_TYPE + + INTEGER :: ICATE + + REAL, ALLOCATABLE, DIMENSION(:) :: ZR_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: Z0C_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: Z0HC_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: ZDC_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: SVF_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: R_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: RW_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: HGT_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: CDS_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: AS_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: AH_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BETR_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BETB_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL + + REAL :: CAPR_DATA, CAPB_DATA, CAPG_DATA + REAL :: AKSR_DATA, AKSB_DATA, AKSG_DATA + REAL :: ALBR_DATA, ALBB_DATA, ALBG_DATA + REAL :: EPSR_DATA, EPSB_DATA, EPSG_DATA + REAL :: Z0R_DATA, Z0B_DATA, Z0G_DATA + REAL :: Z0HR_DATA, Z0HB_DATA, Z0HG_DATA + REAL :: TRLEND_DATA, TBLEND_DATA, TGLEND_DATA + + INTEGER :: BOUNDR_DATA,BOUNDB_DATA,BOUNDG_DATA + INTEGER :: CH_SCHEME_DATA, TS_SCHEME_DATA + + INTEGER :: allocate_status + +! INTEGER :: num_roof_layers +! INTEGER :: num_wall_layers +! INTEGER :: num_road_layers + + CONTAINS + +!=============================================================================== +! +! Author: +! Hiroyuki KUSAKA, PhD +! University of Tsukuba, JAPAN +! (CRIEPI, NCAR/MMM visiting scientist, 2002-2004) +! kusaka@ccs.tsukuba.ac.jp +! +! Co-Researchers: +! Fei CHEN, PhD +! NCAR/RAP feichen@ucar.edu +! Mukul TEWARI, PhD +! NCAR/RAP mukul@ucar.edu +! +! Purpose: +! Calculate surface temeprature, fluxes, canopy air temperature, and canopy wind +! +! Subroutines: +! module_sf_urban +! |- urban +! |- read_param +! |- mos or jurges +! |- multi_layer or force_restore +! |- urban_param_init <-- urban_param.tbl +! |- urban_var_init +! +! Input Data from WRF [MKS unit]: +! +! UTYPE [-] : Urban type. 1=urban, 2=suburban, 3=rural +! TA [K] : Potential temperature at 1st wrf level (absolute temp) +! QA [kg/kg] : Mixing ratio at 1st atmospheric level +! UA [m/s] : Wind speed at 1st atmospheric level +! SSG [W/m/m] : Short wave downward radiation at a flat surface +! Note this is the total of direct and diffusive solar +! downward radiation. If without two components, the +! single solar downward can be used instead. +! SSG = SSGD + SSGQ +! LSOLAR [-] : Indicating the input type of solar downward radiation +! True: both direct and diffusive solar radiation +! are available +! False: only total downward ridiation is available. +! SSGD [W/m/m] : Direct solar radiation at a flat surface +! if SSGD is not available, one can assume a ratio SRATIO +! (e.g., 0.7), so that SSGD = SRATIO*SSG +! SSGQ [W/m/m] : Diffuse solar radiation at a flat surface +! If SSGQ is not available, SSGQ = SSG - SSGD +! LLG [W/m/m] : Long wave downward radiation at a flat surface +! RAIN [mm/h] : Precipitation +! RHOO [kg/m/m/m] : Air density +! ZA [m] : First atmospheric level +! as a lowest boundary condition +! DECLIN [rad] : solar declination +! COSZ : = sin(fai)*sin(del)+cos(fai)*cos(del)*cos(omg) +! OMG [rad] : solar hour angle +! XLAT [deg] : latitude +! DELT [sec] : Time step +! ZNT [m] : Roughnes length +! +! Output Data to WRF [MKS unit]: +! +! TS [K] : Surface potential temperature (absolute temp) +! QS [-] : Surface humidity +! +! SH [W/m/m/] : Sensible heat flux, = FLXTH*RHOO*CPP +! LH [W/m/m] : Latent heat flux, = FLXHUM*RHOO*ELL +! LH_INEMATIC [kg/m/m/sec]: Moisture Kinematic flux, = FLXHUM*RHOO +! SW [W/m/m] : Upward shortwave radiation flux, +! = SSG-SNET*697.7*60. (697.7*60.=100.*100.*4.186) +! ALB [-] : Time-varying albedo +! LW [W/m/m] : Upward longwave radiation flux, +! = LNET*697.7*60.-LLG +! G [W/m/m] : Heat Flux into the Ground +! RN [W/m/m] : Net radiation +! +! PSIM [-] : Diagnostic similarity stability function for momentum +! PSIH [-] : Diagnostic similarity stability function for heat +! +! TC [K] : Diagnostic canopy air temperature +! QC [-] : Diagnostic canopy humidity +! +! TH2 [K] : Diagnostic potential temperature at 2 m +! Q2 [-] : Diagnostic humidity at 2 m +! U10 [m/s] : Diagnostic u wind component at 10 m +! V10 [m/s] : Diagnostic v wind component at 10 m +! +! CHS, CHS2 [m/s] : CH*U at ZA, CH*U at 2 m (not used) +! +! Important parameters: +! Following parameter are assigned in run/urban_param.tbl +! +! ZR [m] : roof level (building height) +! Z0C [m] : Roughness length above canyon for momentum (1/10 of ZR) +! Z0HC [m] : Roughness length above canyon for heat (1/10 of Z0C) +! ZDC [m] : Zero plane displacement height (1/5 of ZR) +! SVF [-] : sky view factor. Calculated again in urban_param_init +! R [-] : building coverage ratio +! RW [-] : = 1 - R +! HGT [-] : normalized building height +! CDS [-] : drag coefficient by buildings +! AS [1/m] : buildings volumetric parameter +! AH [cal/cm/cm] : anthropogenic heat +! BETR [-] : minimum moisture availability of roof +! BETB [-] : minimum moisture availability of building wall +! BETG [-] : minimum moisture availability of road +! CAPR[cal/cm/cm/cm/degC]: heat capacity of roof +! CAPB[cal/cm/cm/cm/degC]: heat capacity of building wall +! CAPG[cal/cm/cm/cm/degC]: heat capacity of road +! AKSR [cal/cm/sec/degC] : thermal conductivity of roof +! AKSB [cal/cm/sec/degC] : thermal conductivity of building wall +! AKSG [cal/cm/sec/degC] : thermal conductivity of road +! ALBR [-] : surface albedo of roof +! ALBB [-] : surface albedo of building wall +! ALBG [-] : surface albedo of road +! EPSR [-] : surface emissivity of roof +! EPSB [-] : surface emissivity of building wall +! EPSG [-] : surface emissivity of road +! Z0R [m] : roughness length for momentum of roof +! Z0B [m] : roughness length for momentum of building wall (only for CH_SCHEME = 1) +! Z0G [m] : roughness length for momentum of road (only for CH_SCHEME = 1) +! Z0HR [m] : roughness length for heat of roof +! Z0HB [m] : roughness length for heat of building wall (only for CH_SCHEME = 1) +! Z0HG [m] : roughness length for heat of roof +! num_roof_layers : number of layers within roof +! num_wall_layers : number of layers within building walls +! num_road_layers : number of layers within below road surface +! NOTE: for now, these layers are defined as same as the number of soil layers in namelist.input +! DZR [cm] : thickness of each roof layer +! DZB [cm] : thickness of each building wall layer +! DZG [cm] : thickness of each ground layer +! BOUNDR [integer 1 or 2] : Boundary Condition for Roof Layer Temp [1: Zero-Flux, 2: T = Constant] +! BOUNDB [integer 1 or 2] : Boundary Condition for Building Wall Layer Temp [1: Zero-Flux, 2: T = Constant] +! BOUNDG [integer 1 or 2] : Boundary Condition for Road Layer Temp [1: Zero-Flux, 2: T = Constant] +! TRLEND [K] : lower boundary condition of roof temperature +! TBLEND [K] : lower boundary condition of building temperature +! TGLEND [K] : lower boundary condition of gound temperature +! CH_SCHEME [integer 1 or 2] : Sfc exchange scheme used for building wall and road +! [1: M-O Similarity Theory, 2: Empirical Form (recommend)] +! TS_SCHEME [integer 1 or 2] : Scheme for computing surface temperature (for roof, wall, and road) +! [1: 4-layer model, 2: Force-Restore method] +! +! +! References: +! Kusaka and Kimura (2004) J.Appl.Meteor., vol.43, p1899-1910 +! Kusaka and Kimura (2004) J.Meteor.Soc.Japan, vol.82, p45-65 +! Kusaka et al. (2001) Bound.-Layer Meteor., vol.101, p329-358 +! +! History: +! 2006/06 modified by H. Kusaka (Univ. Tsukuba), M. Tewari +! 2005/10/26, modified by Fei Chen, Mukul Tewari +! 2003/07/21 WRF , modified by H. Kusaka of CRIEPI (NCAR/MMM) +! 2001/08/26 PhD , modified by H. Kusaka of CRIEPI (Univ.Tsukuba) +! 1999/08/25 LCM , developed by H. Kusaka of CRIEPI (Univ.Tsukuba) +! +!=============================================================================== +! +! subroutine urban: +! +!=============================================================================== + + SUBROUTINE urban(LSOLAR, & ! L + num_roof_layers,num_wall_layers,num_road_layers, & ! I + DZR,DZB,DZG, & ! I + UTYPE,TA,QA,UA,U1,V1,SSG,SSGD,SSGQ,LLG,RAIN,RHOO, & ! I + ZA,DECLIN,COSZ,OMG,XLAT,DELT,ZNT, & ! I + CHS, CHS2, & ! I + TR, TB, TG, TC, QC, UC, & ! H + TRL,TBL,TGL, & ! H + XXXR, XXXB, XXXG, XXXC, & ! H + TS,QS,SH,LH,LH_KINEMATIC, & ! O + SW,ALB,LW,G,RN,PSIM,PSIH, & ! O + GZ1OZ0, & ! O + U10,V10,TH2,Q2,UST & ! O + ) + + IMPLICIT NONE + + REAL, PARAMETER :: CP=0.24 ! heat capacity of dry air [cgs unit] + REAL, PARAMETER :: EL=583. ! latent heat of vaporation [cgs unit] + REAL, PARAMETER :: SIG=8.17E-11 ! stefun bolzman constant [cgs unit] + REAL, PARAMETER :: SIG_SI=5.67E-8 ! [MKS unit] + REAL, PARAMETER :: AK=0.4 ! kalman const. [-] + REAL, PARAMETER :: PI=3.14159 ! pi [-] + REAL, PARAMETER :: TETENA=7.5 ! const. of Tetens Equation [-] + REAL, PARAMETER :: TETENB=237.3 ! const. of Tetens Equation [-] + REAL, PARAMETER :: SRATIO=0.75 ! ratio between direct/total solar [-] + + REAL, PARAMETER :: CPP=1004.5 ! heat capacity of dry air [J/K/kg] + REAL, PARAMETER :: ELL=2.442E+06 ! latent heat of vaporization [J/kg] + REAL, PARAMETER :: XKA=2.4E-5 + +!------------------------------------------------------------------------------- +! C: configuration variables +!------------------------------------------------------------------------------- + + LOGICAL, INTENT(IN) :: LSOLAR ! logical [true=both, false=SSG only] + +! The following variables are also model configuration variables, but are +! defined in the URBAN.TBL and in the contains statement in the top of +! the module_urban_init, so we should not declare them here. + + INTEGER, INTENT(IN) :: num_roof_layers + INTEGER, INTENT(IN) :: num_wall_layers + INTEGER, INTENT(IN) :: num_road_layers + + + REAL, INTENT(IN), DIMENSION(1:num_roof_layers) :: DZR ! grid interval of roof layers [cm] + REAL, INTENT(IN), DIMENSION(1:num_wall_layers) :: DZB ! grid interval of wall layers [cm] + REAL, INTENT(IN), DIMENSION(1:num_road_layers) :: DZG ! grid interval of road layers [cm] + +!------------------------------------------------------------------------------- +! I: input variables from LSM to Urban +!------------------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: UTYPE ! urban type [urban=1, suburban=2, rural=3] + + REAL, INTENT(IN) :: TA ! potential temp at 1st atmospheric level [K] + REAL, INTENT(IN) :: QA ! mixing ratio at 1st atmospheric level [kg/kg] + REAL, INTENT(IN) :: UA ! wind speed at 1st atmospheric level [m/s] + REAL, INTENT(IN) :: U1 ! u at 1st atmospheric level [m/s] + REAL, INTENT(IN) :: V1 ! v at 1st atmospheric level [m/s] + REAL, INTENT(IN) :: SSG ! downward total short wave radiation [W/m/m] + REAL, INTENT(IN) :: LLG ! downward long wave radiation [W/m/m] + REAL, INTENT(IN) :: RAIN ! precipitation [mm/h] + REAL, INTENT(IN) :: RHOO ! air density [kg/m^3] + REAL, INTENT(IN) :: ZA ! first atmospheric level [m] + REAL, INTENT(IN) :: DECLIN ! solar declination [rad] + REAL, INTENT(IN) :: COSZ ! sin(fai)*sin(del)+cos(fai)*cos(del)*cos(omg) + REAL, INTENT(IN) :: OMG ! solar hour angle [rad] + + REAL, INTENT(IN) :: XLAT ! latitude [deg] + REAL, INTENT(IN) :: DELT ! time step [s] + REAL, INTENT(IN) :: ZNT ! roughness length [m] + REAL, INTENT(IN) :: CHS,CHS2 ! CH*U at za and 2 m [m/s] + + REAL, INTENT(INOUT) :: SSGD ! downward direct short wave radiation [W/m/m] + REAL, INTENT(INOUT) :: SSGQ ! downward diffuse short wave radiation [W/m/m] + +!------------------------------------------------------------------------------- +! O: output variables from Urban to LSM +!------------------------------------------------------------------------------- + + REAL, INTENT(OUT) :: TS ! surface potential temperature [K] + REAL, INTENT(OUT) :: QS ! surface humidity [K] + REAL, INTENT(OUT) :: SH ! sensible heat flux [W/m/m] + REAL, INTENT(OUT) :: LH ! latent heat flux [W/m/m] + REAL, INTENT(OUT) :: LH_KINEMATIC ! latent heat, kinetic [kg/m/m/s] + REAL, INTENT(OUT) :: SW ! upward short wave radiation flux [W/m/m] + REAL, INTENT(OUT) :: ALB ! time-varying albedo [fraction] + REAL, INTENT(OUT) :: LW ! upward long wave radiation flux [W/m/m] + REAL, INTENT(OUT) :: G ! heat flux into the ground [W/m/m] + REAL, INTENT(OUT) :: RN ! net radition [W/m/m] + REAL, INTENT(OUT) :: PSIM ! similality stability shear function for momentum + REAL, INTENT(OUT) :: PSIH ! similality stability shear function for heat + REAL, INTENT(OUT) :: GZ1OZ0 + REAL, INTENT(OUT) :: U10 ! u at 10m [m/s] + REAL, INTENT(OUT) :: V10 ! u at 10m [m/s] + REAL, INTENT(OUT) :: TH2 ! potential temperature at 2 m [K] + REAL, INTENT(OUT) :: Q2 ! humidity at 2 m [-] +!m REAL, INTENT(OUT) :: CHS,CHS2 ! CH*U at za and 2 m [m/s] + REAL, INTENT(OUT) :: UST ! friction velocity [m/s] + + +!------------------------------------------------------------------------------- +! H: Historical (state) variables of Urban : LSM <--> Urban +!------------------------------------------------------------------------------- + +! TR: roof temperature [K]; TRP: at previous time step [K] +! TB: building wall temperature [K]; TBP: at previous time step [K] +! TG: road temperature [K]; TGP: at previous time step [K] +! TC: urban-canopy air temperature [K]; TCP: at previous time step [K] +! (absolute temperature) +! QC: urban-canopy air mixing ratio [kg/kg]; QCP: at previous time step [kg/kg] +! +! XXXR: Monin-Obkhov length for roof [dimensionless] +! XXXB: Monin-Obkhov length for building wall [dimensionless] +! XXXG: Monin-Obkhov length for road [dimensionless] +! XXXC: Monin-Obkhov length for urban-canopy [dimensionless] +! +! TRL, TBL, TGL: layer temperature [K] (absolute temperature) + + REAL, INTENT(INOUT):: TR, TB, TG, TC, QC, UC + REAL, INTENT(INOUT):: XXXR, XXXB, XXXG, XXXC + + REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: TRL + REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: TBL + REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: TGL + +!------------------------------------------------------------------------------- +! L: Local variables from read_param +!------------------------------------------------------------------------------- + + REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, CDS, AS, AH + REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG + REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HR, Z0HB, Z0HG + REAL :: TRLEND,TBLEND,TGLEND + + REAL :: TH2X !m + + INTEGER :: BOUNDR, BOUNDB, BOUNDG + INTEGER :: CH_SCHEME, TS_SCHEME + + LOGICAL :: SHADOW ! [true=consider svf and shadow effects, false=consider svf effect only] + +!------------------------------------------------------------------------------- +! L: Local variables +!------------------------------------------------------------------------------- + + REAL :: BETR, BETB, BETG + REAL :: SX, SD, SQ, RX + REAL :: UR, ZC, XLB, BB + REAL :: Z, RIBR, RIBB, RIBG, RIBC, BHR, BHB, BHG, BHC + REAL :: TSC, LNET, SNET, FLXUV, THG, FLXTH, FLXHUM, FLXG + REAL :: W, VFGS, VFGW, VFWG, VFWS, VFWW + REAL :: HOUI1, HOUI2, HOUI3, HOUI4, HOUI5, HOUI6, HOUI7, HOUI8 + REAL :: SLX, SLX1, SLX2, SLX3, SLX4, SLX5, SLX6, SLX7, SLX8 + REAL :: FLXTHR, FLXTHB, FLXTHG, FLXHUMR, FLXHUMB, FLXHUMG + REAL :: SR, SB, SG, RR, RB, RG + REAL :: SR1, SR2, SB1, SB2, SG1, SG2, RR1, RR2, RB1, RB2, RG1, RG2 + REAL :: HR, HB, HG, ELER, ELEB, ELEG, G0R, G0B, G0G + REAL :: ALPHAC, ALPHAR, ALPHAB, ALPHAG + REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG + REAL :: C1R, C1B, C1G, TE, TC1, TC2, QC1, QC2, QS0R, QS0B, QS0G,RHO,ES + + REAL :: DESDT + REAL :: F + REAL :: DQS0RDTR + REAL :: DRRDTR, DHRDTR, DELERDTR, DG0RDTR + REAL :: DTR, DFDT + REAL :: FX, FY, GF, GX, GY + REAL :: DTCDTB, DTCDTG + REAL :: DQCDTB, DQCDTG + REAL :: DRBDTB1, DRBDTG1, DRBDTB2, DRBDTG2 + REAL :: DRGDTB1, DRGDTG1, DRGDTB2, DRGDTG2 + REAL :: DRBDTB, DRBDTG, DRGDTB, DRGDTG + REAL :: DHBDTB, DHBDTG, DHGDTB, DHGDTG + REAL :: DELEBDTB, DELEBDTG, DELEGDTG, DELEGDTB + REAL :: DG0BDTB, DG0BDTG, DG0GDTG, DG0GDTB + REAL :: DQS0BDTB, DQS0GDTG + REAL :: DTB, DTG, DTC + + REAL :: THEATAZ ! Solar Zenith Angle [rad] + REAL :: THEATAS ! = PI/2. - THETAZ + REAL :: FAI ! Latitude [rad] + REAL :: CNT,SNT + REAL :: PS ! Surface Pressure [hPa] + REAL :: TAV ! Vertial Temperature [K] + + REAL :: XXX, X, Z0, Z0H, CD, CH + REAL :: XXX2, PSIM2, PSIH2, XXX10, PSIM10, PSIH10 + REAL :: PSIX, PSIT, PSIX2, PSIT2, PSIX10, PSIT10 + + REAL :: TRP, TBP, TGP, TCP, QCP, TST, QST + + INTEGER :: iteration, K + +!------------------------------------------------------------------------------- +! Set parameters +!------------------------------------------------------------------------------- + + CALL read_param(UTYPE,ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,CDS,AS,AH, & + CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & + EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & + BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, & + BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME) + + IF( ZDC+Z0C+2. >= ZA) THEN + PRINT *, 'ZDC + Z0C + 2m is larger than the 1st WRF level' + PRINT *, 'Stop in the subroutine urban - change ZDC and Z0C' + STOP + END IF + + IF(.NOT.LSOLAR) THEN + SSGD = SRATIO*SSG + SSGQ = SSG - SSGD + ENDIF + SSGD = SRATIO*SSG ! No radiation scheme has SSGD and SSGQ. + SSGQ = SSG - SSGD + + W=2.*1.*HGT + VFGS=SVF + VFGW=1.-SVF + VFWG=(1.-SVF)*(1.-R)/W + VFWS=VFWG + VFWW=1.-2.*VFWG + +!------------------------------------------------------------------------------- +! Convert unit from MKS to cgs +! Renew surface and layer temperatures +!------------------------------------------------------------------------------- + + SX=(SSGD+SSGQ)/697.7/60. ! downward short wave radition [ly/min] + SD=SSGD/697.7/60. ! downward direct short wave radiation + SQ=SSGQ/697.7/60. ! downward diffiusion short wave radiation + RX=LLG/697.7/60. ! downward long wave radiation + RHO=RHOO*0.001 ! air density at first atmospheric level + + TRP=TR + TBP=TB + TGP=TG + TCP=TC + QCP=QC + + TAV=TA*(1.+0.61*QA) + PS=RHOO*287.*TAV/100. ![hPa] + +!------------------------------------------------------------------------------- +! Canopy wind +!------------------------------------------------------------------------------- + + IF ( ZR + 2. < ZA ) THEN + UR=UA*LOG((ZR-ZDC)/Z0C)/LOG((ZA-ZDC)/Z0C) + ZC=0.7*ZR +! ZC=0.5*ZR + XLB=0.4*(ZR-ZDC) + BB=ZR*(CDS*AS/(2.*XLB**2.))**(1./3.) + UC=UR*EXP(-BB*(1.-ZC/ZR)) + ELSE + print *,'ZR=',ZR, 'ZA=',ZA + PRINT *, 'Warning ZR + 2m is larger than the 1st WRF level' + ZC=ZA/2. + UC=UA/2. + END IF + +!------------------------------------------------------------------------------- +! Net Short Wave Radiation at roof, wall, and road +!------------------------------------------------------------------------------- + + SHADOW = .false. +! SHADOW = .true. + + IF (SSG > 0.0) THEN + + IF(.NOT.SHADOW) THEN ! no shadow effects model + + SR1=SX*(1.-ALBR) + SG1=SX*VFGS*(1.-ALBG) + SB1=SX*VFWS*(1.-ALBB) + SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG) + SB2=SG1*ALBG/(1.-ALBG)*VFWG*(1.-ALBB) + + ELSE ! shadow effects model + + FAI=XLAT*PI/180. + + THEATAS=ABS(ASIN(COSZ)) + THEATAZ=ABS(ACOS(COSZ)) + + SNT=COS(DECLIN)*SIN(OMG)/COS(THEATAS) + CNT=(COSZ*SIN(FAI)-SIN(DECLIN))/COS(THEATAS)/COS(FAI) + + HOUI1=(SNT*COS(PI/8.) -CNT*SIN(PI/8.)) + HOUI2=(SNT*COS(2.*PI/8.) -CNT*SIN(2.*PI/8.)) + HOUI3=(SNT*COS(3.*PI/8.) -CNT*SIN(3.*PI/8.)) + HOUI4=(SNT*COS(4.*PI/8.) -CNT*SIN(4.*PI/8.)) + HOUI5=(SNT*COS(5.*PI/8.) -CNT*SIN(5.*PI/8.)) + HOUI6=(SNT*COS(6.*PI/8.) -CNT*SIN(6.*PI/8.)) + HOUI7=(SNT*COS(7.*PI/8.) -CNT*SIN(7.*PI/8.)) + HOUI8=(SNT*COS(8.*PI/8.) -CNT*SIN(8.*PI/8.)) + + SLX1=HGT*ABS(TAN(THEATAZ))*ABS(HOUI1) + SLX2=HGT*ABS(TAN(THEATAZ))*ABS(HOUI2) + SLX3=HGT*ABS(TAN(THEATAZ))*ABS(HOUI3) + SLX4=HGT*ABS(TAN(THEATAZ))*ABS(HOUI4) + SLX5=HGT*ABS(TAN(THEATAZ))*ABS(HOUI5) + SLX6=HGT*ABS(TAN(THEATAZ))*ABS(HOUI6) + SLX7=HGT*ABS(TAN(THEATAZ))*ABS(HOUI7) + SLX8=HGT*ABS(TAN(THEATAZ))*ABS(HOUI8) + + IF(SLX1 > RW) SLX1=RW + IF(SLX2 > RW) SLX2=RW + IF(SLX3 > RW) SLX3=RW + IF(SLX4 > RW) SLX4=RW + IF(SLX5 > RW) SLX5=RW + IF(SLX6 > RW) SLX6=RW + IF(SLX7 > RW) SLX7=RW + IF(SLX8 > RW) SLX8=RW + + SLX=(SLX1+SLX2+SLX3+SLX4+SLX5+SLX6+SLX7+SLX8)/8. + + END IF + + SR=SR1 + SG=SG1+SG2 + SB=SB1+SB2 + + SNET=R*SR+W*SB+RW*SG + + ELSE + + SR=0. + SG=0. + SB=0. + SNET=0. + + END IF + +!------------------------------------------------------------------------------- +! Roof +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +! CHR, CDR, BETR +!------------------------------------------------------------------------------- + + Z=ZA-ZDC + BHR=LOG(Z0R/Z0HR)/0.4 + RIBR=(9.8*2./(TA+TRP))*(TA-TRP)*(Z+Z0R)/(UA*UA) + + CALL mos(XXXR,ALPHAR,CDR,BHR,RIBR,Z,Z0R,UA,TA,TRP,RHO) + + CHR=ALPHAR/RHO/CP/UA + + IF(RAIN > 1.) BETR=0.7 + + IF (TS_SCHEME == 1) THEN + +!------------------------------------------------------------------------------- +! TR Solving Non-Linear Equation by Newton-Rapson +! TRL Solving Heat Equation by Tri Diagonal Matrix Algorithm +!------------------------------------------------------------------------------- +! TSC=TRP-273.15 +! ES=EXP(19.482-4303.4/(TSC+243.5)) ! WMO +! ES=6.11*10.**(TETENA*TSC/(TETENB+TSC)) ! Tetens +! DESDT=( 6.1078*(2500.-2.4*TSC)/ & ! Tetens +! (0.46151*(TSC+273.15)**2.) )*10.**(7.5*TSC/(237.3+TSC)) +! ES=6.11*EXP((2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) ) ! Clausius-Clapeyron +! DESDT=(2.5*10.**6./461.51)*ES/(TRP**2.) ! Clausius-Clapeyron +! QS0R=0.622*ES/(PS-0.378*ES) +! DQS0RDTR = DESDT*0.622*PS/((PS-0.378*ES)**2.) +! DQS0RDTR = 17.269*(273.15-35.86)/((TRP-35.86)**2.)*QS0R + +! TRP=350. + + DO ITERATION=1,20 + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) ) + DESDT=(2.5*10.**6./461.51)*ES/(TRP**2.) + QS0R=0.622*ES/(PS-0.378*ES) + DQS0RDTR = DESDT*0.622*PS/((PS-0.378*ES)**2.) + + RR=EPSR*(RX-SIG*(TRP**4.)/60.) + HR=RHO*CP*CHR*UA*(TRP-TA)*100. + ELER=RHO*EL*CHR*UA*BETR*(QS0R-QA)*100. + G0R=AKSR*(TRP-TRL(1))/(DZR(1)/2.) + + F = SR + RR - HR - ELER - G0R + + DRRDTR = (-4.*EPSR*SIG*TRP**3.)/60. + DHRDTR = RHO*CP*CHR*UA*100. + DELERDTR = RHO*EL*CHR*UA*BETR*DQS0RDTR*100. + DG0RDTR = 2.*AKSR/DZR(1) + + DFDT = DRRDTR - DHRDTR - DELERDTR - DG0RDTR + DTR = F/DFDT + + TR = TRP - DTR + TRP = TR + + IF( ABS(F) < 0.000001 .AND. ABS(DTR) < 0.000001 ) EXIT + + END DO + +! multi-layer heat equation model + + CALL multi_layer(num_roof_layers,BOUNDR,G0R,CAPR,AKSR,TRL,DZR,DELT,TRLEND) + + ELSE + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TRP-273.15)/(273.15*TRP) ) + QS0R=0.622*ES/(PS-0.378*ES) + + RR=EPSR*(RX-SIG*(TRP**4.)/60.) + HR=RHO*CP*CHR*UA*(TRP-TA)*100. + ELER=RHO*EL*CHR*UA*BETR*(QS0R-QA)*100. + G0R=SR+RR-HR-ELER + + CALL force_restore(CAPR,AKSR,DELT,SR,RR,HR,ELER,TRLEND,TRP,TR) + + TRP=TR + + END IF + + FLXTHR=HR/RHO/CP/100. + FLXHUMR=ELER/RHO/EL/100. + +!------------------------------------------------------------------------------- +! Wall and Road +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +! CHC, CHB, CDB, BETB, CHG, CDG, BETG +!------------------------------------------------------------------------------- + + Z=ZA-ZDC + BHC=LOG(Z0C/Z0HC)/0.4 + RIBC=(9.8*2./(TA+TCP))*(TA-TCP)*(Z+Z0C)/(UA*UA) + + CALL mos(XXXC,ALPHAC,CDC,BHC,RIBC,Z,Z0C,UA,TA,TCP,RHO) + + IF (CH_SCHEME == 1) THEN + + Z=ZDC + BHB=LOG(Z0B/Z0HB)/0.4 + BHG=LOG(Z0G/Z0HG)/0.4 + RIBB=(9.8*2./(TCP+TBP))*(TCP-TBP)*(Z+Z0B)/(UC*UC) + RIBG=(9.8*2./(TCP+TGP))*(TCP-TGP)*(Z+Z0G)/(UC*UC) + + CALL mos(XXXB,ALPHAB,CDB,BHB,RIBB,Z,Z0B,UC,TCP,TBP,RHO) + CALL mos(XXXG,ALPHAG,CDG,BHG,RIBG,Z,Z0G,UC,TCP,TGP,RHO) + + ELSE + + ALPHAB=RHO*CP*(6.15+4.18*UC)/1200. + IF(UC > 5.) ALPHAB=RHO*CP*(7.51*UC**0.78)/1200. + ALPHAG=RHO*CP*(6.15+4.18*UC)/1200. + IF(UC > 5.) ALPHAG=RHO*CP*(7.51*UC**0.78)/1200. + + END IF + + CHC=ALPHAC/RHO/CP/UA + CHB=ALPHAB/RHO/CP/UC + CHG=ALPHAG/RHO/CP/UC + + BETB=0.0 + IF(RAIN > 1.) BETG=0.7 + + IF (TS_SCHEME == 1) THEN + +!------------------------------------------------------------------------------- +! TB, TG Solving Non-Linear Simultaneous Equation by Newton-Rapson +! TBL,TGL Solving Heat Equation by Tri Diagonal Matrix Algorithm +!------------------------------------------------------------------------------- + +! TBP=350. +! TGP=350. + + DO ITERATION=1,20 + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TBP-273.15)/(273.15*TBP) ) + DESDT=(2.5*10.**6./461.51)*ES/(TBP**2.) + QS0B=0.622*ES/(PS-0.378*ES) + DQS0BDTB=DESDT*0.622*PS/((PS-0.378*ES)**2.) + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TGP-273.15)/(273.15*TGP) ) + DESDT=(2.5*10.**6./461.51)*ES/(TGP**2.) + QS0G=0.622*ES/(PS-0.378*ES) + DQS0GDTG=DESDT*0.22*PS/((PS-0.378*ES)**2.) + + RG1=EPSG*( RX*VFGS & + +EPSB*VFGW*SIG*TBP**4./60. & + -SIG*TGP**4./60. ) + + RB1=EPSB*( RX*VFWS & + +EPSG*VFWG*SIG*TGP**4./60. & + +EPSB*VFWW*SIG*TBP**4./60. & + -SIG*TBP**4./60. ) + + RG2=EPSG*( (1.-EPSB)*(1.-SVF)*VFWS*RX & + +(1.-EPSB)*(1.-SVF)*VFWG*EPSG*SIG*TGP**4./60. & + +EPSB*(1.-EPSB)*(1.-SVF)*(1.-2.*VFWS)*SIG*TBP**4./60. ) + + RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX & + +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. & + +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX & + +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. & + +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. ) + + RG=RG1+RG2 + RB=RB1+RB2 + + DRBDTB1=EPSB*(4.*EPSB*SIG*TB**3.*VFWW-4.*SIG*TB**3.)/60. + DRBDTG1=EPSB*(4.*EPSG*SIG*TG**3.*VFWG)/60. + DRBDTB2=EPSB*(4.*(1.-EPSG)*EPSB*SIG*TB**3.*VFGW*VFWG & + +4.*EPSB*(1.-EPSB)*SIG*TB**3.*VFWW*VFWW)/60. + DRBDTG2=EPSB*(4.*(1.-EPSB)*EPSG*SIG*TG**3.*VFWG*VFWW)/60. + + DRGDTB1=EPSG*(4.*EPSB*SIG*TB**3.*VFGW)/60. + DRGDTG1=EPSG*(-4.*SIG*TG**3.)/60. + DRGDTB2=EPSG*(4.*EPSB*(1.-EPSB)*SIG*TB**3.*VFWW*VFGW)/60. + DRGDTG2=EPSG*(4.*(1.-EPSB)*EPSG*SIG*TG**3.*VFWG*VFGW)/60. + + DRBDTB=DRBDTB1+DRBDTB2 + DRBDTG=DRBDTG1+DRBDTG2 + DRGDTB=DRGDTB1+DRGDTB2 + DRGDTG=DRGDTG1+DRGDTG2 + + HB=RHO*CP*CHB*UC*(TBP-TCP)*100. + HG=RHO*CP*CHG*UC*(TGP-TCP)*100. + + DTCDTB=W*ALPHAB/(RW*ALPHAC+RW*ALPHAG+W*ALPHAB) + DTCDTG=RW*ALPHAG/(RW*ALPHAC+RW*ALPHAG+W*ALPHAB) + + DHBDTB=RHO*CP*CHB*UC*(1.-DTCDTB)*100. + DHBDTG=RHO*CP*CHB*UC*(0.-DTCDTG)*100. + DHGDTG=RHO*CP*CHG*UC*(1.-DTCDTG)*100. + DHGDTB=RHO*CP*CHG*UC*(0.-DTCDTB)*100. + + ELEB=RHO*EL*CHB*UC*BETB*(QS0B-QCP)*100. + ELEG=RHO*EL*CHG*UC*BETG*(QS0G-QCP)*100. + + DQCDTB=W*ALPHAB*BETB*DQS0BDTB/(RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB) + DQCDTG=RW*ALPHAG*BETG*DQS0GDTG/(RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB) + + DELEBDTB=RHO*EL*CHB*UC*BETB*(DQS0BDTB-DQCDTB)*100. + DELEBDTG=RHO*EL*CHB*UC*BETB*(0.-DQCDTG)*100. + DELEGDTG=RHO*EL*CHG*UC*BETG*(DQS0GDTG-DQCDTG)*100. + DELEGDTB=RHO*EL*CHG*UC*BETG*(0.-DQCDTB)*100. + + G0B=AKSB*(TBP-TBL(1))/(DZB(1)/2.) + G0G=AKSG*(TGP-TGL(1))/(DZG(1)/2.) + + DG0BDTB=2.*AKSB/DZB(1) + DG0BDTG=0. + DG0GDTG=2.*AKSG/DZG(1) + DG0GDTB=0. + + F = SB + RB - HB - ELEB - G0B + FX = DRBDTB - DHBDTB - DELEBDTB - DG0BDTB + FY = DRBDTG - DHBDTG - DELEBDTG - DG0BDTG + + GF = SG + RG - HG - ELEG - G0G + GX = DRGDTB - DHGDTB - DELEGDTB - DG0GDTB + GY = DRGDTG - DHGDTG - DELEGDTG - DG0GDTG + + DTB = (GF*FY-F*GY)/(FX*GY-GX*FY) + DTG = -(GF+GX*DTB)/GY + + TB = TBP + DTB + TG = TGP + DTG + + TBP = TB + TGP = TG + + TC1=RW*ALPHAC+RW*ALPHAG+W*ALPHAB + TC2=RW*ALPHAC*TA+RW*ALPHAG*TGP+W*ALPHAB*TBP + TC=TC2/TC1 + + QC1=RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB + QC2=RW*ALPHAC*QA+RW*ALPHAG*BETG*QS0G+W*ALPHAB*BETB*QS0B + QC=QC2/QC1 + + DTC=TCP - TC + TCP=TC + QCP=QC + + IF( ABS(F) < 0.000001 .AND. ABS(DTB) < 0.000001 & + .AND. ABS(GF) < 0.000001 .AND. ABS(DTG) < 0.000001 & + .AND. ABS(DTC) < 0.000001) EXIT + + END DO + + CALL multi_layer(num_wall_layers,BOUNDB,G0B,CAPB,AKSB,TBL,DZB,DELT,TBLEND) + + CALL multi_layer(num_road_layers,BOUNDG,G0G,CAPG,AKSG,TGL,DZG,DELT,TGLEND) + + ELSE + +!------------------------------------------------------------------------------- +! TB, TG by Force-Restore Method +!------------------------------------------------------------------------------- + + ES=6.11*EXP((2.5*10.**6./461.51)*(TBP-273.15)/(273.15*TBP) ) + QS0B=0.622*ES/(PS-0.378*ES) + + ES=6.11*EXP((2.5*10.**6./461.51)*(TGP-273.15)/(273.15*TGP) ) + QS0G=0.622*ES/(PS-0.378*ES) + + RG1=EPSG*( RX*VFGS & + +EPSB*VFGW*SIG*TBP**4./60. & + -SIG*TGP**4./60. ) + + RB1=EPSB*( RX*VFWS & + +EPSG*VFWG*SIG*TGP**4./60. & + +EPSB*VFWW*SIG*TBP**4./60. & + -SIG*TBP**4./60. ) + + RG2=EPSG*( (1.-EPSB)*(1.-SVF)*VFWS*RX & + +(1.-EPSB)*(1.-SVF)*VFWG*EPSG*SIG*TGP**4./60. & + +EPSB*(1.-EPSB)*(1.-SVF)*(1.-2.*VFWS)*SIG*TBP**4./60. ) + + RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX & + +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. & + +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX & + +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. & + +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. ) + + RG=RG1+RG2 + RB=RB1+RB2 + + HB=RHO*CP*CHB*UC*(TBP-TCP)*100. + ELEB=RHO*EL*CHB*UC*BETB*(QS0B-QCP)*100. + G0B=SB+RB-HB-ELEB + + HG=RHO*CP*CHG*UC*(TGP-TCP)*100. + ELEG=RHO*EL*CHG*UC*BETG*(QS0G-QCP)*100. + G0G=SG+RG-HG-ELEG + + CALL force_restore(CAPB,AKSB,DELT,SB,RB,HB,ELEB,TBLEND,TBP,TB) + CALL force_restore(CAPG,AKSG,DELT,SG,RG,HG,ELEG,TGLEND,TGP,TG) + + TBP=TB + TGP=TG + + TC1=RW*ALPHAC+RW*ALPHAG+W*ALPHAB + TC2=RW*ALPHAC*TA+RW*ALPHAG*TGP+W*ALPHAB*TBP + TC=TC2/TC1 + + QC1=RW*ALPHAC+RW*ALPHAG*BETG+W*ALPHAB*BETB + QC2=RW*ALPHAC*QA+RW*ALPHAG*BETG*QS0G+W*ALPHAB*BETB*QS0B + QC=QC2/QC1 + + TCP=TC + QCP=QC + + END IF + + FLXTHB=HB/RHO/CP/100. + FLXHUMB=ELEB/RHO/EL/100. + FLXTHG=HG/RHO/CP/100. + FLXHUMG=ELEG/RHO/EL/100. + +!------------------------------------------------------------------------------- +! Total Fulxes from Urban Canopy +!------------------------------------------------------------------------------- + + FLXUV = ( R*CDR + RW*CDC )*UA*UA + FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) + FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) + FLXG = ( R*G0R + W*G0B + RW*G0G ) + LNET = R*RR + W*RB + RW*RG + +!---------------------------------------------------------------------------- +! Convert Unit: FLUXES and u* T* q* --> WRF +!---------------------------------------------------------------------------- + + SH = FLXTH * RHOO * CPP ! Sensible heat flux [W/m/m] + LH = FLXHUM * RHOO * ELL ! Latent heat flux [W/m/m] + LH_KINEMATIC = FLXHUM * RHOO ! Latent heat, Kinematic [kg/m/m/s] + LW = LLG - (LNET*697.7*60.) ! Upward longwave radiation [W/m/m] + SW = SSG - (SNET*697.7*60.) ! Upward shortwave radiation [W/m/m] + ALB = 0. + IF( ABS(SSG) > 0.0001) ALB = SW/SSG ! Effective albedo [-] + G = -FLXG*697.7*60. ! [W/m/m] + RN = (SNET+LNET)*697.7*60. ! Net radiation [W/m/m] + + UST = SQRT(FLXUV) ! u* [m/s] + TST = -FLXTH/UST ! T* [K] + QST = -FLXHUM/UST ! q* [-] + +!------------------------------------------------------ +! diagnostic GRID AVERAGED PSIM PSIH TS QS --> WRF +!------------------------------------------------------ + + Z0 = Z0C + Z0H = Z0HC + Z = ZA - ZDC + + XXX = 0.4*9.81*Z*TST/TA/UST/UST + + IF ( XXX >= 1. ) XXX = 1. + IF ( XXX <= -5. ) XXX = -5. + + IF ( XXX > 0 ) THEN + PSIM = -5. * XXX + PSIH = -5. * XXX + ELSE + X = (1.-16.*XXX)**0.25 + PSIM = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + PI/2. + PSIH = 2.*ALOG((1.+X*X)/2.) + END IF + + GZ1OZ0 = ALOG(Z/Z0) + CD = 0.4**2./(ALOG(Z/Z0)-PSIM)**2. +! +!m CH = 0.4**2./(ALOG(Z/Z0)-PSIM)/(ALOG(Z/Z0H)-PSIH) +!m CHS = 0.4*UST/(ALOG(Z/Z0H)-PSIH) +!m TS = TA + FLXTH/CH/UA ! surface potential temp (flux temp) +!m QS = QA + FLXHUM/CH/UA ! surface humidity +! + TS = TA + FLXTH/CHS ! surface potential temp (flux temp) + QS = QA + FLXHUM/CHS ! surface humidity + +!------------------------------------------------------- +! diagnostic GRID AVERAGED U10 V10 TH2 Q2 --> WRF +!------------------------------------------------------- + + XXX2 = (2./Z)*XXX + IF ( XXX2 >= 1. ) XXX2 = 1. + IF ( XXX2 <= -5. ) XXX2 = -5. + + IF ( XXX2 > 0 ) THEN + PSIM2 = -5. * XXX2 + PSIH2 = -5. * XXX2 + ELSE + X = (1.-16.*XXX2)**0.25 + PSIM2 = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + 2.*ATAN(1.) + PSIH2 = 2.*ALOG((1.+X*X)/2.) + END IF +! +!m CHS2 = 0.4*UST/(ALOG(2./Z0H)-PSIH2) +! + + XXX10 = (10./Z)*XXX + IF ( XXX10 >= 1. ) XXX10 = 1. + IF ( XXX10 <= -5. ) XXX10 = -5. + + IF ( XXX10 > 0 ) THEN + PSIM10 = -5. * XXX10 + PSIH10 = -5. * XXX10 + ELSE + X = (1.-16.*XXX10)**0.25 + PSIM10 = 2.*ALOG((1.+X)/2.) + ALOG((1.+X*X)/2.) - 2.*ATAN(X) + 2.*ATAN(1.) + PSIH10 = 2.*ALOG((1.+X*X)/2.) + END IF + + PSIX = ALOG(Z/Z0) - PSIM + PSIT = ALOG(Z/Z0H) - PSIH + + PSIX2 = ALOG(2./Z0) - PSIM2 + PSIT2 = ALOG(2./Z0H) - PSIH2 + + PSIX10 = ALOG(10./Z0) - PSIM10 + PSIT10 = ALOG(10./Z0H) - PSIH10 + + U10 = U1 * (PSIX10/PSIX) ! u at 10 m [m/s] + V10 = V1 * (PSIX10/PSIX) ! v at 10 m [m/s] + +! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! potential temp at 2 m [K] +! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! Fei: this seems to be temp (not potential) at 2 m [K] +!Fei: consistant with M-O theory + TH2 = TS + (TA-TS) *(CHS/CHS2) + + Q2 = QS + (QA-QS)*(PSIT2/PSIT) ! humidity at 2 m [-] + +! TS = (LW/SIG_SI/0.88)**0.25 ! Radiative temperature [K] + + RETURN + + END SUBROUTINE urban +!=============================================================================== +! +! mos +! +!=============================================================================== + SUBROUTINE mos(XXX,ALPHA,CD,B1,RIB,Z,Z0,UA,TA,TSF,RHO) + +! XXX: z/L (requires iteration by Newton-Rapson method) +! B1: Stanton number +! PSIM: = PSIX of LSM +! PSIH: = PSIT of LSM + + IMPLICIT NONE + + REAL, PARAMETER :: CP=0.24 + REAL, INTENT(IN) :: B1, Z, Z0, UA, TA, TSF, RHO + REAL, INTENT(OUT) :: ALPHA, CD + REAL, INTENT(INOUT) :: XXX, RIB + REAL :: XXX0, X, X0, FAIH, DPSIM, DPSIH + REAL :: F, DF, XXXP, US, TS, AL, XKB, DD, PSIM, PSIH + INTEGER :: NEWT + INTEGER, PARAMETER :: NEWT_END=10 + + IF(RIB <= -15.) RIB=-15. + + IF(RIB < 0.) THEN + + DO NEWT=1,NEWT_END + + IF(XXX >= 0.) XXX=-1.E-3 + + XXX0=XXX*Z0/(Z+Z0) + + X=(1.-16.*XXX)**0.25 + X0=(1.-16.*XXX0)**0.25 + + PSIM=ALOG((Z+Z0)/Z0) & + -ALOG((X+1.)**2.*(X**2.+1.)) & + +2.*ATAN(X) & + +ALOG((X+1.)**2.*(X0**2.+1.)) & + -2.*ATAN(X0) + FAIH=1./SQRT(1.-16.*XXX) + PSIH=ALOG((Z+Z0)/Z0)+0.4*B1 & + -2.*ALOG(SQRT(1.-16.*XXX)+1.) & + +2.*ALOG(SQRT(1.-16.*XXX0)+1.) + + DPSIM=(1.-16.*XXX)**(-0.25)/XXX & + -(1.-16.*XXX0)**(-0.25)/XXX + DPSIH=1./SQRT(1.-16.*XXX)/XXX & + -1./SQRT(1.-16.*XXX0)/XXX + + F=RIB*PSIM**2./PSIH-XXX + + DF=RIB*(2.*DPSIM*PSIM*PSIH-DPSIH*PSIM**2.) & + /PSIH**2.-1. + + XXXP=XXX + XXX=XXXP-F/DF + IF(XXX <= -10.) XXX=-10. + + END DO + + ELSE IF(RIB >= 0.142857) THEN + + XXX=0.714 + PSIM=ALOG((Z+Z0)/Z0)+7.*XXX + PSIH=PSIM+0.4*B1 + + ELSE + + AL=ALOG((Z+Z0)/Z0) + XKB=0.4*B1 + DD=-4.*RIB*7.*XKB*AL+(AL+XKB)**2. + IF(DD <= 0.) DD=0. + XXX=(AL+XKB-2.*RIB*7.*AL-SQRT(DD))/(2.*(RIB*7.**2-7.)) + PSIM=ALOG((Z+Z0)/Z0)+7.*MIN(XXX,0.714) + PSIH=PSIM+0.4*B1 + + END IF + + US=0.4*UA/PSIM ! u* + IF(US <= 0.01) US=0.01 + TS=0.4*(TA-TSF)/PSIH ! T* + + CD=US*US/UA**2. ! CD + ALPHA=RHO*CP*0.4*US/PSIH ! RHO*CP*CH*U + + RETURN + END SUBROUTINE mos +!=============================================================================== +! +! louis79 +! +!=============================================================================== + SUBROUTINE louis79(ALPHA,CD,RIB,Z,Z0,UA,RHO) + + IMPLICIT NONE + + REAL, PARAMETER :: CP=0.24 + REAL, INTENT(IN) :: Z, Z0, UA, RHO + REAL, INTENT(OUT) :: ALPHA, CD + REAL, INTENT(INOUT) :: RIB + REAL :: A2, XX, CH, CMB, CHB + + A2=(0.4/ALOG(Z/Z0))**2. + + IF(RIB <= -15.) RIB=-15. + + IF(RIB >= 0.0) THEN + IF(RIB >= 0.142857) THEN + XX=0.714 + ELSE + XX=RIB*LOG(Z/Z0)/(1.-7.*RIB) + END IF + CH=0.16/0.74/(LOG(Z/Z0)+7.*MIN(XX,0.714))**2. + CD=0.16/(LOG(Z/Z0)+7.*MIN(XX,0.714))**2. + ELSE + CMB=7.4*A2*9.4*SQRT(Z/Z0) + CHB=5.3*A2*9.4*SQRT(Z/Z0) + CH=A2/0.74*(1.-9.4*RIB/(1.+CHB*SQRT(-RIB))) + CD=A2*(1.-9.4*RIB/(1.+CHB*SQRT(-RIB))) + END IF + + ALPHA=RHO*CP*CH*UA + + RETURN + END SUBROUTINE louis79 +!=============================================================================== +! +! louis82 +! +!=============================================================================== + SUBROUTINE louis82(ALPHA,CD,RIB,Z,Z0,UA,RHO) + + IMPLICIT NONE + + REAL, PARAMETER :: CP=0.24 + REAL, INTENT(IN) :: Z, Z0, UA, RHO + REAL, INTENT(OUT) :: ALPHA, CD + REAL, INTENT(INOUT) :: RIB + REAL :: A2, FM, FH, CH, CHH + + A2=(0.4/ALOG(Z/Z0))**2. + + IF(RIB <= -15.) RIB=-15. + + IF(RIB >= 0.0) THEN + FM=1./((1.+(2.*5.*RIB)/SQRT(1.+5.*RIB))) + FH=1./(1.+(3.*5.*RIB)*SQRT(1.+5.*RIB)) + CH=A2*FH + CD=A2*FM + ELSE + CHH=5.*3.*5.*A2*SQRT(Z/Z0) + FM=1.-(2.*5.*RIB)/(1.+3.*5.*5.*A2*SQRT(Z/Z0+1.)*(-RIB)) + FH=1.-(3.*5.*RIB)/(1.+CHH*SQRT(-RIB)) + CH=A2*FH + CD=A2*FM + END IF + + ALPHA=RHO*CP*CH*UA + + RETURN + END SUBROUTINE louis82 +!=============================================================================== +! +! multi_layer +! +!=============================================================================== + SUBROUTINE multi_layer(KM,BOUND,G0,CAP,AKS,TSL,DZ,DELT,TSLEND) + + IMPLICIT NONE + + REAL, INTENT(IN) :: G0, CAP, AKS, DELT,TSLEND + + INTEGER, INTENT(IN) :: KM, BOUND + + REAL, DIMENSION(KM), INTENT(IN) :: DZ + + REAL, DIMENSION(KM), INTENT(INOUT) :: TSL + + REAL, DIMENSION(KM) :: A, B, C, D, X, P, Q + + REAL :: DZEND + + INTEGER :: K + + DZEND=DZ(KM) + + A(1) = 0.0 + + B(1) = CAP*DZ(1)/DELT & + +2.*AKS/(DZ(1)+DZ(2)) + C(1) = -2.*AKS/(DZ(1)+DZ(2)) + D(1) = CAP*DZ(1)/DELT*TSL(1) + G0 + + DO K=2,KM-1 + A(K) = -2.*AKS/(DZ(K-1)+DZ(K)) + B(K) = CAP*DZ(K)/DELT + 2.*AKS/(DZ(K-1)+DZ(K)) + 2.*AKS/(DZ(K)+DZ(K+1)) + C(K) = -2.*AKS/(DZ(K)+DZ(K+1)) + D(K) = CAP*DZ(K)/DELT*TSL(K) + END DO + + IF(BOUND == 1) THEN ! Flux=0 + A(KM) = -2.*AKS/(DZ(KM-1)+DZ(KM)) + B(KM) = CAP*DZ(KM)/DELT + 2.*AKS/(DZ(KM-1)+DZ(KM)) + C(KM) = 0.0 + D(KM) = CAP*DZ(KM)/DELT*TSL(KM) + ELSE ! T=constant + A(KM) = -2.*AKS/(DZ(KM-1)+DZ(KM)) + B(KM) = CAP*DZ(KM)/DELT + 2.*AKS/(DZ(KM-1)+DZ(KM)) + 2.*AKS/(DZ(KM)+DZEND) + C(KM) = 0.0 + D(KM) = CAP*DZ(KM)/DELT*TSL(KM) + 2.*AKS*TSLEND/(DZ(KM)+DZEND) + END IF + + P(1) = -C(1)/B(1) + Q(1) = D(1)/B(1) + + DO K=2,KM + P(K) = -C(K)/(A(K)*P(K-1)+B(K)) + Q(K) = (-A(K)*Q(K-1)+D(K))/(A(K)*P(K-1)+B(K)) + END DO + + X(KM) = Q(KM) + + DO K=KM-1,1,-1 + X(K) = P(K)*X(K+1)+Q(K) + END DO + + DO K=1,KM + TSL(K) = X(K) + END DO + + RETURN + END SUBROUTINE multi_layer +!=============================================================================== +! +! subroutine read_param +! +!=============================================================================== + SUBROUTINE read_param(UTYPE, & ! in + ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,CDS,AS,AH, & ! out + CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & ! out + EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & ! out + BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, & ! out + BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME) ! out + + INTEGER, INTENT(IN) :: UTYPE + + REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,CDS,AS,AH, & + CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & + EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & + BETR,BETB,BETG,TRLEND,TBLEND,TGLEND + + INTEGER, INTENT(OUT) :: BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME + + ZR = ZR_TBL(UTYPE) + Z0C= Z0C_TBL(UTYPE) + Z0HC= Z0HC_TBL(UTYPE) + ZDC= ZDC_TBL(UTYPE) + SVF= SVF_TBL(UTYPE) + R= R_TBL(UTYPE) + RW= RW_TBL(UTYPE) + HGT= HGT_TBL(UTYPE) + CDS= CDS_TBL(UTYPE) + AS= AS_TBL(UTYPE) + AH= AH_TBL(UTYPE) + BETR= BETR_TBL(UTYPE) + BETB= BETB_TBL(UTYPE) + BETG= BETG_TBL(UTYPE) + +!m FRC_URB= FRC_URB_TBL(UTYPE) + + CAPR= CAPR_DATA + CAPB= CAPB_DATA + CAPG= CAPG_DATA + AKSR= AKSR_DATA + AKSB= AKSB_DATA + AKSG= AKSG_DATA + ALBR= ALBR_DATA + ALBB= ALBB_DATA + ALBG= ALBG_DATA + EPSR= EPSR_DATA + EPSB= EPSB_DATA + EPSG= EPSG_DATA + Z0R= Z0R_DATA + Z0B= Z0B_DATA + Z0G= Z0G_DATA + Z0HR= Z0HR_DATA + Z0HB= Z0HB_DATA + Z0HG= Z0HG_DATA + TRLEND= TRLEND_DATA + TBLEND= TBLEND_DATA + TGLEND= TGLEND_DATA + BOUNDR= BOUNDR_DATA + BOUNDB= BOUNDB_DATA + BOUNDG= BOUNDG_DATA + CH_SCHEME = CH_SCHEME_DATA + TS_SCHEME = TS_SCHEME_DATA + + RETURN + END SUBROUTINE read_param +!=============================================================================== +! +! subroutine urban_param_init: Read parameters from urban_param.tbl +! +!=============================================================================== + SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers & + ) +! num_roof_layers,num_wall_layers,num_road_layers) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + +! REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: DZR +! REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: DZB +! REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: DZG + REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZR + REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB + REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG + + INTEGER :: INDEX, LC, K + INTEGER :: IOSTATUS, ALLOCATE_STATUS + INTEGER :: num_roof_layers + INTEGER :: num_wall_layers + INTEGER :: num_road_layers + INTEGER :: dummy + REAL :: DHGT, HGT, VFWS, VFGS + + OPEN (UNIT=11, & + FILE='urban_param.tbl', & + ACCESS='SEQUENTIAL', & + STATUS='OLD', & + ACTION='READ', & + POSITION='REWIND', & + IOSTAT=IOSTATUS) + + IF (IOSTATUS > 0) STOP 'ERROR OPEN urban_param.tbl' + + READ(11,*) + READ(11,'(A4)') LU_DATA_TYPE + + READ(11,*) ICATE + ALLOCATE( ZR_TBL(ICATE), stat=allocate_status ) + if(allocate_status == 0) THEN + ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate Z0C_TBL in urban_param_init' + IF( .NOT. ALLOCATED( Z0HC_TBL ) ) & + ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate Z0HC_TBL in urban_param_init' + IF( .NOT. ALLOCATED( ZDC_TBL ) ) & + ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate ZDC_TBL in urban_param_init' + IF( .NOT. ALLOCATED( SVF_TBL ) ) & + ALLOCATE( SVF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate SVF_TBL in urban_param_init' + IF( .NOT. ALLOCATED( R_TBL ) ) & + ALLOCATE( R_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate R_TBL in urban_param_init' + IF( .NOT. ALLOCATED( RW_TBL ) ) & + ALLOCATE( RW_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate RW_TBL in urban_param_init' + IF( .NOT. ALLOCATED( HGT_TBL ) ) & + ALLOCATE( HGT_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate HGT_TBL in urban_param_init' + IF( .NOT. ALLOCATED( CDS_TBL ) ) & + ALLOCATE( CDS_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate CDS_TBL in urban_param_init' + IF( .NOT. ALLOCATED( AS_TBL ) ) & + ALLOCATE( AS_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate AS_TBL in urban_param_init' + IF( .NOT. ALLOCATED( AH_TBL ) ) & + ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate AH_TBL in urban_param_init' + IF( .NOT. ALLOCATED( BETR_TBL ) ) & + ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate BETR_TBL in urban_param_init' + IF( .NOT. ALLOCATED( BETB_TBL ) ) & + ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate BETB_TBL in urban_param_init' + IF( .NOT. ALLOCATED( BETG_TBL ) ) & + ALLOCATE( BETG_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate BETG_TBL in urban_param_init' + ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) stop 'error allocate FRC_URB_TBL in urban_param_init' + +ENDIF + + DO LC = 1, ICATE + READ(11,*) INDEX, & + ZR_TBL(LC), & + Z0C_TBL(LC), & + Z0HC_TBL(LC), & + ZDC_TBL(LC), & + SVF_TBL(LC), & + R_TBL(LC), & + RW_TBL(LC), & + HGT_TBL(LC), & + CDS_TBL(LC), & + AS_TBL(LC), & + AH_TBL(LC), & + BETR_TBL(LC), & + BETB_TBL(LC), & + BETG_TBL(LC), & + FRC_URB_TBL(LC) + END DO + + READ(11,*) + READ(11,*) CAPR_DATA + READ(11,*) + READ(11,*) CAPB_DATA + READ(11,*) + READ(11,*) CAPG_DATA + READ(11,*) + READ(11,*) AKSR_DATA + READ(11,*) + READ(11,*) AKSB_DATA + READ(11,*) + READ(11,*) AKSG_DATA + READ(11,*) + READ(11,*) ALBR_DATA + READ(11,*) + READ(11,*) ALBB_DATA + READ(11,*) + READ(11,*) ALBG_DATA + READ(11,*) + READ(11,*) EPSR_DATA + READ(11,*) + READ(11,*) EPSB_DATA + READ(11,*) + READ(11,*) EPSG_DATA + READ(11,*) + READ(11,*) Z0R_DATA + READ(11,*) + READ(11,*) Z0B_DATA + READ(11,*) + READ(11,*) Z0G_DATA + READ(11,*) + READ(11,*) Z0HR_DATA + READ(11,*) + READ(11,*) Z0HB_DATA + READ(11,*) + READ(11,*) Z0HG_DATA + READ(11,*) +! READ(11,*) num_roof_layers + READ(11,*) dummy + READ(11,*) +! READ(11,*) num_wall_layers + READ(11,*) dummy + READ(11,*) +! READ(11,*) num_road_layers + READ(11,*) dummy + + num_roof_layers = num_soil_layers + num_wall_layers = num_soil_layers + num_road_layers = num_soil_layers + + DO K=1,num_roof_layers + READ(11,*) + READ(11,*) DZR(K) + END DO + + DO K=1,num_wall_layers + READ(11,*) + READ(11,*) DZB(K) + END DO + + DO K=1,num_road_layers + READ(11,*) + READ(11,*) DZG(K) + END DO + + READ(11,*) + READ(11,*) BOUNDR_DATA + READ(11,*) + READ(11,*) BOUNDB_DATA + READ(11,*) + READ(11,*) BOUNDG_DATA + READ(11,*) + READ(11,*) TRLEND_DATA + READ(11,*) + READ(11,*) TBLEND_DATA + READ(11,*) + READ(11,*) TGLEND_DATA + READ(11,*) + READ(11,*) CH_SCHEME_DATA + READ(11,*) + READ(11,*) TS_SCHEME_DATA + + CLOSE(11) + +! Calculate Sky View Factor + + DO LC = 1, ICATE + DHGT=HGT_TBL(LC)/100. + HGT=0. + VFWS=0. + HGT=HGT_TBL(LC)-DHGT/2. + do k=1,99 + HGT=HGT-DHGT + VFWS=VFWS+0.25*(1.-HGT/SQRT(HGT**2.+RW_TBL(LC)**2.)) + end do + + VFWS=VFWS/99. + VFWS=VFWS*2. + + VFGS=1.-2.*VFWS*HGT_TBL(LC)/RW_TBL(LC) + SVF_TBL(LC)=VFGS + END DO + + END SUBROUTINE urban_param_init +!=========================================================================== +! +! subroutine urban_var_init: initialization of urban state variables +! +!=========================================================================== + SUBROUTINE urban_var_init(TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, & ! in + ims,ime,jms,jme,num_soil_layers, & ! in +! num_roof_layers,num_wall_layers,num_road_layers, & ! in + XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & ! inout + TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & ! inout + TRL_URB3D,TBL_URB3D,TGL_URB3D, & ! inout + SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & ! inout + TS_URB2D, FRC_URB2D, UTYPE_URB2D) ! inout + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ims,ime,jms,jme,num_soil_layers +! INTEGER, INTENT(IN) :: num_roof_layers, num_wall_layers, num_road_layers + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TSURFACE0_URB + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(IN) :: TLAYER0_URB + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TDEEP0_URB + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IVGTYP + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D + +! REAL, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D +! REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D +! REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D +! + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UTYPE_URB2D + INTEGER :: UTYPE_URB + + INTEGER :: I,J,K + + DO I=ims,ime + DO J=jms,jme + + XXXR_URB2D(I,J)=0. + XXXB_URB2D(I,J)=0. + XXXG_URB2D(I,J)=0. + XXXC_URB2D(I,J)=0. + + SH_URB2D(I,J)=0. + LH_URB2D(I,J)=0. + G_URB2D(I,J)=0. + RN_URB2D(I,J)=0. +!m + FRC_URB2D(I,J)=0. + UTYPE_URB2D(I,J)=0. + + IF( IVGTYP(I,J) == 1) THEN + UTYPE_URB2D(I,J) = 2 ! for default. high-density + UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-density + FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + ENDIF + IF( IVGTYP(I,J) == 31) THEN + UTYPE_URB2D(I,J) = 3 ! low-density residential + UTYPE_URB = UTYPE_URB2D(I,J) ! low-density residential + FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + ENDIF + IF( IVGTYP(I,J) == 32) THEN + UTYPE_URB2D(I,J) = 2 ! high-density + UTYPE_URB = UTYPE_URB2D(I,J) ! high-density + FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + ENDIF + IF( IVGTYP(I,J) == 33) THEN + UTYPE_URB2D(I,J) = 1 ! Commercial/Industrial/Transportation + UTYPE_URB = UTYPE_URB2D(I,J) ! Commercial/Industrial/Transportation + FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + ENDIF + + + QC_URB2D(I,J)=0.01 + + TC_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + TR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + TB_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + TG_URB2D(I,J)=TSURFACE0_URB(I,J)+0. +! + TS_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + +! DO K=1,num_roof_layers +! DO K=1,num_soil_layers +! TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. +! TRL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0. +! TRL_URB3D(I,3,J)=TLAYER0_URB(I,3,J)+0. +! TRL_URB3D(I,4,J)=TLAYER0_URB(I,4,J)+0. + + TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. + TRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) + TRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. + TRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 +! END DO + +! DO K=1,num_wall_layers +! DO K=1,num_soil_layers +!m TBL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. +!m TBL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0. +!m TBL_URB3D(I,3,J)=TLAYER0_URB(I,3,J)+0. +!m TBL_URB3D(I,4,J)=TLAYER0_URB(I,4,J)+0. + + TBL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. + TBL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) + TBL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. + TBL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 +! END DO + +! DO K=1,num_road_layers + DO K=1,num_soil_layers + TGL_URB3D(I,K,J)=TLAYER0_URB(I,K,J)+0. + END DO + + END DO + END DO + + RETURN + END SUBROUTINE urban_var_init +!=========================================================================== +! +! force_restore +! +!=========================================================================== + SUBROUTINE force_restore(CAP,AKS,DELT,S,R,H,LE,TSLEND,TSP,TS) + + REAL, INTENT(IN) :: CAP,AKS,DELT,S,R,H,LE,TSLEND,TSP + REAL, INTENT(OUT) :: TS + REAL :: C1,C2 + + C2=24.*3600./2./3.14159 + C1=SQRT(0.5*C2*CAP*AKS) + + TS = TSP + DELT*( (S+R-H-LE)/C1 -(TSP-TSLEND)/C2 ) + + END SUBROUTINE force_restore +!=========================================================================== +! +! bisection (not used) +! +!============================================================================== + SUBROUTINE bisection(TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ,TS) + + REAL, INTENT(IN) :: TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ + REAL, INTENT(OUT) :: TS + REAL :: ES,QS0,R,H,ELE,G0,F1,F + + TS1 = TSP - 5. + TS2 = TSP + 5. + + DO ITERATION = 1,22 + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TS1-273.15)/(273.15*TS1) ) + QS0=0.622*ES/(PS-0.378*ES) + R=EPS*(RX-SIG*(TS1**4.)/60.) + H=RHO*CP*CH*UA*(TS1-TA)*100. + ELE=RHO*EL*CH*UA*BET*(QS0-QA)*100. + G0=AKS*(TS1-TSL)/(DZ/2.) + F1= S + R - H - ELE - G0 + + TS=0.5*(TS1+TS2) + + ES=6.11*EXP( (2.5*10.**6./461.51)*(TS-273.15)/(273.15*TS) ) + QS0=0.622*ES/(PS-0.378*ES) + R=EPS*(RX-SIG*(TS**4.)/60.) + H=RHO*CP*CH*UA*(TS-TA)*100. + ELE=RHO*EL*CH*UA*BET*(QS0-QA)*100. + G0=AKS*(TS-TSL)/(DZ/2.) + F = S + R - H - ELE - G0 + + IF (F1*F > 0.0) THEN + TS1=TS + ELSE + TS2=TS + END IF + + END DO + + RETURN +END SUBROUTINE bisection +!=========================================================================== +END MODULE module_sf_urban diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F new file mode 100644 index 00000000..bfbac196 --- /dev/null +++ b/wrfv2_fire/phys/module_surface_driver.F @@ -0,0 +1,882 @@ +!WRF:MEDIATION_LAYER:PHYSICS +! +MODULE module_surface_driver +CONTAINS + + SUBROUTINE surface_driver( & + & acsnom,acsnow,akhs,akms,albedo,br,canwat & + & ,chklowq,dt,dx,dz8w,dzs,glw & + & ,grdflx,gsw,swdown,gz1oz0,hfx,ht,ifsnow,isfflx & + & ,isltyp,itimestep,ivgtyp,lowlyr,mavail,rmol & + & ,num_soil_layers,p8w,pblh,pi_phy,pshltr,psih & + & ,psim,p_phy,q10,q2,qfx,qsfc,qshltr,qz0 & + & ,raincv,rho,sfcevp,sfcexc,sfcrunoff & + & ,smois,smstav,smstot,snoalb,snow,snowc,snowh,stepbl & + & ,th10,th2,thz0,th_phy,tmn,tshltr,tsk,tslb & + & ,t_phy,u10,udrunoff,ust,uz0,u_frame,u_phy,v10,vegfra & + & ,vz0,v_frame,v_phy,warm_rain,wspd,xice,xland,z,znt,zs & + & ,ct,tke_myj & + & ,albbck,lh,sh2o,shdmax,shdmin,z0 & + & ,flqc,flhc,psfc,sst,sst_update,t2,emiss & + & ,sf_sfclay_physics,sf_surface_physics,ra_lw_physics & + ! Optional urban + & ,declin_urb,cosz_urb2d,omg_urb2d,xlat_urb2d & !I urban + & ,num_roof_layers, num_wall_layers & !I urban + & ,num_road_layers, dzr, dzb, dzg & !I urban + & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d & !H urban + & ,uc_urb2d & !H urban + & ,xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d & !H urban + & ,trl_urb3d,tbl_urb3d,tgl_urb3d & !H urban + & ,sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d & !H urban + & ,frc_urb2d, utype_urb2d & !H urban + & ,ucmcall & ! urban + & , ids,ide,jds,jde,kds,kde & + & , ims,ime,jms,jme,kms,kme & + & , i_start,i_end,j_start,j_end,kts,kte,num_tiles & + ! Optional moisture tracers + & ,qv_curr, qc_curr, qr_curr & + & ,qi_curr, qs_curr, qg_curr & + ! Optional moisture tracer flags + & ,f_qv,f_qc,f_qr & + & ,f_qi,f_qs,f_qg & + ! Other optionals (more or less em specific) + & ,capg,hol,mol & + & ,rainncv,rainbl,regime,thc & + & ,qsg,qvg,qcg,soilt1,tsnav & + & ,smfr3d,keepfr3dflag & + ! Other optionals (more or less nmm specific) + & ,potevp,snopcx,soiltb,sr & + ! Optional observation nudging + & ,uratx,vratx,tratx & + ) + +#if ( ! NMM_CORE == 1 ) + USE module_state_description, ONLY : SFCLAYSCHEME & + ,MYJSFCSCHEME & + ,GFSSFCSCHEME & + ,SLABSCHEME & + ,LSMSCHEME & + ,RUCLSMSCHEME +#else + USE module_state_description, ONLY : SFCLAYSCHEME & + ,MYJSFCSCHEME & + ,GFSSFCSCHEME & + ,SLABSCHEME & + ,NMMLSMSCHEME & + ,LSMSCHEME & + ,RUCLSMSCHEME +#endif + USE module_model_constants +! *** add new modules of schemes here + + USE module_sf_sfclay + USE module_sf_myjsfc + USE module_sf_gfs + USE module_sf_noahlsm + USE module_sf_ruclsm +#if ( NMM_CORE == 1 ) + USE module_sf_lsm_nmm +#endif + + USE module_sf_slab +! + USE module_sf_sfcdiags +! + + ! This driver calls subroutines for the surface parameterizations. + ! + ! surface layer: (between surface and pbl) + ! 1. sfclay + ! 2. myjsfc + ! surface: ground temp/lsm scheme: + ! 1. slab + ! 2. Noah LSM + ! 99. NMM LSM (NMM core only) +!------------------------------------------------------------------ + IMPLICIT NONE +!====================================================================== +! Grid structure in physics part of WRF +!---------------------------------------------------------------------- +! The horizontal velocities used in the physics are unstaggered +! relative to temperature/moisture variables. All predicted +! variables are carried at half levels except w, which is at full +! levels. Some arrays with names (*8w) are at w (full) levels. +! +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, +! then you have to reverse the order in the k direction. +! +! kme - half level (no data at this level) +! kme ----- full level +! kme-1 - half level +! kme-1 ----- full level +! . +! kms+2 - half level +! kms+2 ----- full level +! kms+1 - half level +! kms+1 ----- full level +! kms - half level +! kms ----- full level +! +!====================================================================== +! Definitions +!----------- +! Theta potential temperature (K) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +!----------------------------------------------------------------- +!-- itimestep number of time steps +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- GSW net short wave flux at ground surface (W/m^2) +!-- SWDOWN downward short wave flux at ground surface (W/m^2) +!-- EMISS surface emissivity (between 0 and 1) +!-- TSK surface temperature (K) +!-- TMN soil temperature at lower boundary (K) +!-- XLAND land mask (1 for land, 2 for water) +!-- ZNT time-varying roughness length (m) +!-- Z0 background roughness length (m) +!-- MAVAIL surface moisture availability (between 0 and 1) +!-- UST u* in similarity theory (m/s) +!-- MOL T* (similarity theory) (K) +!-- HOL PBL height over Monin-Obukhov length +!-- PBLH PBL height (m) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- THC thermal inertia (Cal/cm/K/s^0.5) +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- HFX net upward heat flux at the surface (W/m^2) +!-- QFX net upward moisture flux at the surface (kg/m^2/s) +!-- LH net upward latent heat flux at surface (W/m^2) +!-- REGIME flag indicating PBL regime (stable, unstable, etc.) +!-- tke_myj turbulence kinetic energy from Mellor-Yamada-Janjic (MYJ) (m^2/s^2) +!-- akhs sfc exchange coefficient of heat/moisture from MYJ +!-- akms sfc exchange coefficient of momentum from MYJ +!-- thz0 potential temperature at roughness length (K) +!-- uz0 u wind component at roughness length (m/s) +!-- vz0 v wind component at roughness length (m/s) +!-- qsfc specific humidity at lower boundary (kg/kg) +!-- uratx ratio of u over u10 (Added for obs-nudging) +!-- vratx ratio of v over v10 (Added for obs-nudging) +!-- tratx ratio of t over th2 (Added for obs-nudging) +!-- u10 diagnostic 10-m u component from surface layer +!-- v10 diagnostic 10-m v component from surface layer +!-- th2 diagnostic 2-m theta from surface layer and lsm +!-- t2 diagnostic 2-m temperature from surface layer and lsm +!-- q2 diagnostic 2-m mixing ratio from surface layer and lsm +!-- tshltr diagnostic 2-m theta from MYJ +!-- th10 diagnostic 10-m theta from MYJ +!-- qshltr diagnostic 2-m specific humidity from MYJ +!-- q10 diagnostic 10-m specific humidity from MYJ +!-- lowlyr index of lowest model layer above ground +!-- rr dry air density (kg/m^3) +!-- u_phy u-velocity interpolated to theta points (m/s) +!-- v_phy v-velocity interpolated to theta points (m/s) +!-- th_phy potential temperature (K) +!-- moist moisture array (4D - last index is species) (kg/kg) +!-- p_phy pressure (Pa) +!-- pi_phy exner function (dimensionless) +!-- pshltr diagnostic shelter (2m) pressure from MYJ (Pa) +!-- p8w pressure at full levels (Pa) +!-- t_phy temperature (K) +!-- dz8w dz between full levels (m) +!-- z height above sea level (m) +!-- DX horizontal space interval (m) +!-- DT time step (second) +!-- PSFC pressure at the surface (Pa) +!-- SST sea-surface temperature (K) +!-- TSLB +!-- ZS +!-- DZS +!-- num_soil_layers number of soil layer +!-- IFSNOW ifsnow=1 for snow-cover effects +! +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!****************************************************************** +!------------------------------------------------------------------ + + INTEGER, INTENT(IN) :: & + & ids,ide,jds,jde,kds,kde & + & ,ims,ime,jms,jme,kms,kme & + & ,kts,kte,num_tiles + + INTEGER, INTENT(IN) :: sf_sfclay_physics,sf_surface_physics,ra_lw_physics,sst_update + + INTEGER, INTENT(IN) :: ucmcall !urban + + INTEGER, DIMENSION(num_tiles), INTENT(IN) :: & + & i_start,i_end,j_start,j_end + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: ISLTYP + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: IVGTYP + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: LOWLYR + INTEGER, INTENT(IN ):: IFSNOW + INTEGER, INTENT(IN ):: ISFFLX + INTEGER, INTENT(IN ):: ITIMESTEP + INTEGER, INTENT(IN ):: NUM_SOIL_LAYERS + INTEGER, INTENT(IN ):: STEPBL + LOGICAL, INTENT(IN ):: WARM_RAIN + REAL , INTENT(IN ):: U_FRAME + REAL , INTENT(IN ):: V_FRAME + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: SMOIS + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: TSLB + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: GLW + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: GSW,SWDOWN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: HT + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: RAINCV + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SST + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: TMN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: VEGFRA + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: XICE + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: XLAND + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: MAVAIL + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: SNOALB + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: ACSNOW + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: AKHS + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: AKMS + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: ALBEDO + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: CANWAT + + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: GRDFLX + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: HFX + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: RMOL + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: PBLH + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: Q2 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: QFX + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: QSFC + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: QZ0 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SFCRUNOFF + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SMSTAV + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SMSTOT + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SNOW + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SNOWC + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: SNOWH + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: TH2 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: THZ0 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: TSK + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: UDRUNOFF + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: UST + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: UZ0 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: VZ0 + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: WSPD + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: ZNT + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: BR + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: CHKLOWQ + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: GZ1OZ0 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: PSHLTR + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: PSIH + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: PSIM + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: Q10 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: QSHLTR + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: TH10 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: TSHLTR + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: U10 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: V10 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT):: PSFC + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: ACSNOM + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: SFCEVP + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: SFCEXC + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: FLHC + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: FLQC + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CT + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: DZ8W + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: P8W + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: PI_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: P_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: RHO + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: TH_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: T_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: U_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: V_PHY + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ):: Z + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: TKE_MYJ + REAL, DIMENSION(1:num_soil_layers), INTENT(IN):: DZS + REAL, DIMENSION(1:num_soil_layers), INTENT(IN):: ZS + REAL, INTENT(IN ):: DT + REAL, INTENT(IN ):: DX + +! arguments for NCAR surface physics + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ):: ALBBCK ! INOUT needed for NMM + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ):: LH + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: SH2O + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: Z0 + +! +! Optional +! + +! +! Observation nudging +! + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT):: uratx !Added for obs-nudging + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT):: vratx !Added for obs-nudging + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT):: tratx !Added for obs-nudging +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, INTENT(IN), OPTIONAL :: & + f_qv & + ,f_qc & + ,f_qr & + ,f_qi & + ,f_qs & + ,f_qg + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + ! optional moisture tracers + ! 2 time levels; if only one then use CURR + qv_curr, qc_curr, qr_curr & + ,qi_curr, qs_curr, qg_curr + + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: capg + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: emiss + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: hol + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: mol + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: regime + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN ):: rainncv + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: RAINBL + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: t2 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN ):: thc + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qsg + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qvg + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qcg + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: soilt1 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: tsnav + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: potevp ! NMM LSM + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: snopcx ! NMM LSM + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: soiltb ! NMM LSM + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: sr ! NMM and RUC LSM + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), OPTIONAL, INTENT(INOUT):: smfr3d + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), OPTIONAL, INTENT(INOUT):: keepfr3dflag + +! LOCAL VAR + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::v_phytmp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::u_phytmp + + REAL, DIMENSION( ims:ime, jms:jme ) :: ZOL + + REAL, DIMENSION( ims:ime, jms:jme ) :: & + QGH, & + CHS, & + CPM, & + CHS2, & + CQS2 + + REAL :: DTMIN,DTBL +! + INTEGER :: i,J,K,NK,jj,ij + LOGICAL :: radiation, myj, frpcpn +!------------------------------------------------- +! urban related variables are added to declaration +!------------------------------------------------- + REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB !urban + REAL, OPTIONAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D !urban + INTEGER, OPTIONAL, INTENT(IN) :: num_roof_layers !urban + INTEGER, OPTIONAL, INTENT(IN) :: num_wall_layers !urban + INTEGER, OPTIONAL, INTENT(IN) :: num_road_layers !urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZR !urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZB !urban + REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZG !urban + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: TC_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: QC_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: UC_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXR_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXB_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXG_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXC_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban + INTENT(INOUT) :: TRL_URB3D !urban + REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban + INTENT(INOUT) :: TBL_URB3D !urban + REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban + INTENT(INOUT) :: TGL_URB3D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: LH_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: G_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: RN_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: TS_URB2D !urban +! + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D !urban + INTEGER, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UTYPE_URB2D !urban + + REAL, DIMENSION( ims:ime, jms:jme ) :: PSIM_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: PSIH_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: GZ1OZ0_URB2D !urban local var +!m REAL, DIMENSION( ims:ime, jms:jme ) :: AKHS_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: AKMS_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: U10_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: V10_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: TH2_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: Q2_URB2D !urban local var + REAL, DIMENSION( ims:ime, jms:jme ) :: UST_URB2D !urban local var + +!------------------------------------------------------------------ + CHARACTER*256 :: message +!------------------------------------------------------------------ +! + + if (sf_sfclay_physics .eq. 0) return + + v_phytmp = 0. + u_phytmp = 0. + ZOL = 0. + QGH = 0. + CHS = 0. + CPM = 0. + CHS2 = 0. + DTMIN = 0. + DTBL = 0. + +! RAINBL in mm (Accumulation between PBL calls) + + IF ( PRESENT( rainncv ) .AND. PRESENT( rainbl ) ) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + RAINBL(i,j) = RAINBL(i,j) + RAINCV(i,j) + RAINNCV(i,j) + RAINBL(i,j) = MAX (RAINBL(i,j), 0.0) + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ELSE IF ( PRESENT( rainbl ) ) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + RAINBL(i,j) = RAINBL(i,j) + RAINCV(i,j) + RAINBL(i,j) = MAX (RAINBL(i,j), 0.0) + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ENDIF +! Update SST + IF (sst_update .EQ. 1) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + IF(XLAND(i,j) .GT. 1.5)TSK(i,j)=SST(i,j) + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ENDIF + + IF (itimestep .eq. 1 .or. mod(itimestep,STEPBL) .eq. 0) THEN + + radiation = .false. + myj = .false. + frpcpn = .false. + + IF (ra_lw_physics .gt. 0) radiation = .true. + +!---- +! CALCULATE CONSTANT + + DTMIN=DT/60. +! Surface schemes need PBL time step for updates and accumulations +! Assume these schemes provide no tendencies + DTBL=DT*STEPBL + +! SAVE OLD VALUES + + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) +! PSFC : in Pa + PSFC(I,J)=p8w(I,kts,J) +! REVERSE ORDER IN THE VERTICAL DIRECTION + DO k=kts,kte + v_phytmp(i,k,j)=v_phy(i,k,j)+v_frame + u_phytmp(i,k,j)=u_phy(i,k,j)+u_frame + ENDDO + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + sfclay_select: SELECT CASE(sf_sfclay_physics) + + CASE (SFCLAYSCHEME) +#if (NMM_CORE != 1) +! DX varies spatially in NMM, therefore, SFCLAY cannot be called +! because it takes a scalar DX. NMM passes in a dummy value for this +! scalar. NEEDS FURTHER ATTENTION. JM 20050215 + IF (PRESENT(qv_curr) .AND. & + PRESENT(mol) .AND. PRESENT(regime) .AND. & + .TRUE. ) THEN + CALL wrf_debug( 100, 'in SFCLAY' ) + CALL SFCLAY(u_phytmp,v_phytmp,t_phy,qv_curr,& + p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, & + znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & + xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & + uratx,vratx,tratx, & + u10,v10,th2,t2,q2, & + gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + ELSE + CALL wrf_error_fatal('Lacking arguments for SFCLAY in surface driver') + ENDIF + +#else + CALL wrf_error_fatal('SFCLAY cannot be used with NMM') +#endif + CASE (MYJSFCSCHEME) + IF (PRESENT(qv_curr) .AND. PRESENT(qc_curr) .AND. & + .TRUE. ) THEN + + myj =.true. + + CALL wrf_debug(100,'in MYJSFC') + CALL MYJSFC(itimestep,ht,dz8w, & + p_phy,p8w,th_phy,t_phy, & + qv_curr,qc_curr, & + u_phy,v_phy,tke_myj, & + tsk,qsfc,thz0,qz0,uz0,vz0, & + lowlyr, & + xland, & + ust,znt,z0,pblh,mavail,rmol, & + akhs,akms, & + chs,chs2,cqs2,hfx,qfx,lh,flhc,flqc,qgh,cpm,ct, & + u10,v10,t2,th2,tshltr,th10,q2,qshltr,q10,pshltr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + ELSE + CALL wrf_error_fatal('Lacking arguments for MYJSFC in surface driver') + ENDIF + + CASE (GFSSFCSCHEME) + IF (PRESENT(qv_curr) .AND. .TRUE. ) THEN + CALL wrf_debug( 100, 'in GFSSFC' ) + CALL SF_GFS(u_phytmp,v_phytmp,t_phy,qv_curr, & + p_phy,CP,RCP,R_d,XLV,PSFC,CHS,CHS2,CQS2,CPM, & + ZNT,UST,PSIM,PSIH, & + XLAND,HFX,QFX,LH,TSK,FLHC,FLQC, & + QGH,QSFC,U10,V10, & + GZ1OZ0,WSPD,BR,ISFFLX, & + EP_1,EP_2,KARMAN,itimestep, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + CALL wrf_debug(100,'in SFCDIAGS') + ELSE + CALL wrf_error_fatal('Lacking arguments for SF_GFS in surface driver') + ENDIF + + CASE DEFAULT + + WRITE( message , * ) & + 'The sfclay option does not exist: sf_sfclay_physics = ', sf_sfclay_physics + CALL wrf_error_fatal ( message ) + + END SELECT sfclay_select + ENDDO + !$OMP END PARALLEL DO + + IF (ISFFLX.EQ.0 ) GOTO 430 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + + sfc_select: SELECT CASE(sf_surface_physics) + + CASE (SLABSCHEME) + + IF (PRESENT(qv_curr) .AND. & + PRESENT(capg) .AND. & + .TRUE. ) THEN + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) +! CQS2 ACCOUNTS FOR MAVAIL FOR SFCDIAGS 2M Q + CQS2(I,J)= CQS2(I,J)*MAVAIL(I,J) + ENDDO + ENDDO + + CALL wrf_debug(100,'in SLAB') + CALL SLAB(t_phy,qv_curr,p_phy,flhc,flqc, & + psfc,xland,tmn,hfx,qfx,lh,tsk,qsfc,chklowq, & + gsw,glw,capg,thc,snowc,emiss,mavail, & + dtbl,rcp,xlv,dtmin,ifsnow, & + svp1,svp2,svp3,svpt0,ep_2,karman,eomeg,stbolt, & + tslb,zs,dzs,num_soil_layers,radiation, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + SFCEVP(I,J)= SFCEVP(I,J) + QFX(I,J)*DTBL + ENDDO + ENDDO + + CALL wrf_debug(100,'in SFCDIAGS') + CALL SFCDIAGS(hfx,qfx,tsk,qsfc,chs2,cqs2,t2,th2,q2, & + psfc,cp,r_d,rcp, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + + ELSE + CALL wrf_error_fatal('Lacking arguments for SLAB in surface driver') + ENDIF + +#if ( NMM_CORE == 1 ) + CASE (NMMLSMSCHEME) + IF (PRESENT(qv_curr) .AND. PRESENT(rainbl) .AND. & + PRESENT(potevp) .AND. PRESENT(snopcx) .AND. & + PRESENT(soiltb) .AND. PRESENT(sr) .AND. & + .TRUE. ) THEN + CALL wrf_debug(100,'in NMM LSM') + CALL nmmlsm(dz8w,qv_curr,p8w,rho, & + t_phy,th_phy,tsk,chs, & + hfx,qfx,qgh,swdown,glw,lh,rmol, & + smstav,smstot,sfcrunoff, & + udrunoff,ivgtyp,isltyp,vegfra,sfcevp,potevp, & + grdflx,sfcexc,acsnow,acsnom,snopcx, & + albbck,tmn,xland,xice,qz0, & + th2,q2,snowc,cqs2,qsfc,soiltb,chklowq,rainbl, & + num_soil_layers,dtbl,dzs,itimestep, & + smois,tslb,snow,canwat,cpm,rcp,sr, & !tslb + albedo,snoalb,sh2o,snowh, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + CALL wrf_debug(100,'back from NMM LSM') + ELSE + CALL wrf_error_fatal('Lacking arguments for NMMLSM in surface driver') + ENDIF +#endif + + CASE (LSMSCHEME) + + IF (PRESENT(qv_curr) .AND. PRESENT(rainbl) .AND. & +! PRESENT(emiss) .AND. PRESENT(t2) .AND. & +! PRESENT(declin_urb) .AND. PRESENT(cosz_urb2d) .AND. & +! PRESENT(omg_urb2d) .AND. PRESENT( xlat_urb2d) .AND. & +! PRESENT(dzr) .AND. & +! PRESENT( dzb) .AND. PRESENT(dzg) .AND. & +! PRESENT(tr_urb2d) .AND. PRESENT(tb_urb2d) .AND. & +! PRESENT(tg_urb2d) .AND. PRESENT(tc_urb2d) .AND. & +! PRESENT(qc_urb2d) .AND. PRESENT(uc_urb2d) .AND. & +! PRESENT(xxxr_urb2d) .AND. PRESENT(xxxb_urb2d) .AND. & +! PRESENT(xxxg_urb2d) .AND. & +! PRESENT(xxxc_urb2d) .AND. PRESENT(trl_urb3d) .AND. & +! PRESENT(tbl_urb3d) .AND. PRESENT(tgl_urb3d) .AND. & +! PRESENT(sh_urb2d) .AND. PRESENT(lh_urb2d) .AND. & +! PRESENT(g_urb2d) .AND. PRESENT(rn_urb2d) .AND. & +! PRESENT(ts_urb2d) .AND. & +! PRESENT(frc_urb2d) .AND. PRESENT(utype_urb2d) .AND. & + .TRUE. ) THEN +!------------------------------------------------------------------ + CALL wrf_debug(100,'in NOAH LSM') + CALL lsm(dz8w,qv_curr,p8w,t_phy,tsk, & + hfx,qfx,lh,grdflx,qgh,gsw,glw,smstav,smstot, & + sfcrunoff,udrunoff,ivgtyp,isltyp,vegfra, & + albedo,albbck,znt,z0, tmn,xland,xice, emiss, & + snowc,qsfc,rainbl, & + num_soil_layers,dtbl,dzs,itimestep, & + smois,tslb,snow,canwat, & + chs, chs2, cqs2, cpm,rcp, & + sh2o,snowh, & !h + u_phy,v_phy, & !I + snoalb,shdmin,shdmax, & !i + acsnom,acsnow, & !o + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & + ucmcall & +!Optional urban + ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban + uc_urb2d, & !H urban + xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban + trl_urb3d,tbl_urb3d,tgl_urb3d, & !H urban + sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d, & !H urban + psim_urb2d,psih_urb2d,u10_urb2d,v10_urb2d, & !O urban + GZ1OZ0_urb2d, AKMS_URB2D, & !O urban + th2_urb2d,q2_urb2d,ust_urb2d, & !O urban + declin_urb,cosz_urb2d,omg_urb2d, & !I urban + xlat_urb2d, & !I urban + num_roof_layers, num_wall_layers, & !I urban + num_road_layers, DZR, DZB, DZG, & !I urban + FRC_URB2D, UTYPE_URB2D & ! urban + ) + + + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + CHKLOWQ(I,J)= 1.0 + SFCEVP(I,J)= SFCEVP(I,J) + QFX(I,J)*DTBL + ENDDO + ENDDO + + CALL SFCDIAGS(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & + PSFC,CP,R_d,RCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + +!urban + IF(UCMCALL.eq.1) THEN + DO j=j_start(ij),j_end(ij) !urban + DO i=i_start(ij),i_end(ij) !urban + IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & !urban + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN !urban +! TH2(I,J) = TH2_URB2D(I,J) !urban +! T2(I,J) = TH2_URB2D(I,J)/(1.E5/PSFC(I,J))**RCP !urban +!m T2(I,J) = TH2_URB2D(I,J) !urban + T2(I,J) = FRC_URB2D(i,j)*TH2_URB2D(I,J) + (1-FRC_URB2D(i,j))*T2(I,J) !urban + TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**RCP !urban +!m Q2(I,J) = Q2_URB2D(I,J) !urban + Q2(I,J) = FRC_URB2D(i,j)*Q2_URB2D(I,J) +(1-FRC_URB2D(i,j))* Q2(I,J) !urban + U10(I,J) = U10_URB2D(I,J) !urban + V10(I,J) = V10_URB2D(I,J) !urban + PSIM(I,J) = PSIM_URB2D(I,J) !urban + PSIH(I,J) = PSIH_URB2D(I,J) !urban + GZ1OZ0(I,J) = GZ1OZ0_URB2D(I,J) !urban +!m AKHS(I,J) = AKHS_URB2D(I,J) !urban + AKHS(I,J) = CHS(I,J) !urban + AKMS(I,J) = AKMS_URB2D(I,J) !urban + END IF !urban + ENDDO !urban + ENDDO !urban + ENDIF +!------------------------------------------------------------------ + + ELSE + CALL wrf_error_fatal('Lacking arguments for LSM in surface driver') + ENDIF + + CASE (RUCLSMSCHEME) + IF (PRESENT(qv_curr) .AND. PRESENT(qc_curr) .AND. & +! PRESENT(emiss) .AND. PRESENT(t2) .AND. & + PRESENT(qsg) .AND. PRESENT(qvg) .AND. & + PRESENT(qcg) .AND. PRESENT(soilt1) .AND. & + PRESENT(tsnav) .AND. PRESENT(smfr3d) .AND. & + PRESENT(keepfr3dflag) .AND. PRESENT(rainbl) .AND. & + .TRUE. ) THEN + + IF( PRESENT(sr) ) THEN + frpcpn=.true. + ELSE + SR = 1. + ENDIF + + CALL wrf_debug(100,'in RUC LSM') + CALL LSMRUC(dtbl,itimestep,num_soil_layers, & + zs,rainbl,snow,snowh,snowc,sr,frpcpn, & + dz8w,p8w,t_phy,qv_curr,qc_curr,rho, & !p8w in [pa] + glw,gsw,emiss,chklowq, & + flqc,flhc,mavail,canwat,vegfra,albedo,znt, & + snoalb, albbck, & !new + qsfc,qsg,qvg,qcg,soilt1,tsnav, & + tmn,ivgtyp,isltyp,xland,xice, & + cp,g,xlv,stbolt, & + smois,smstav,smstot,tslb,tsk,hfx,qfx,lh, & + sfcrunoff,udrunoff,sfcexc, & + sfcevp,grdflx,acsnow, & + smfr3d,keepfr3dflag, & + myj, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + + IF(.not. MYJ) then + + CALL SFCDIAGS(HFX,QFX,TSK,QVG,CHS2,CQS2,T2,TH2,Q2, & + PSFC,CP,R_d,RCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + ENDIF + + + ELSE + CALL wrf_error_fatal('Lacking arguments for RUCLSM in surface driver') + ENDIF + + CASE DEFAULT + + WRITE( message , * ) & + 'The surface option does not exist: sf_surface_physics = ', sf_surface_physics + CALL wrf_error_fatal ( message ) + + END SELECT sfc_select + ENDDO + !$OMP END PARALLEL DO + + 430 CONTINUE + + +! Reset RAINBL in mm (Accumulation between PBL calls) + + IF ( PRESENT( rainbl ) ) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + RAINBL(i,j) = 0. + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + ENDIF + + ENDIF + + END SUBROUTINE surface_driver + +END MODULE module_surface_driver + diff --git a/wrfv2_fire/run/CAM_ABS_DATA b/wrfv2_fire/run/CAM_ABS_DATA new file mode 100644 index 00000000..8671f8ed Binary files /dev/null and b/wrfv2_fire/run/CAM_ABS_DATA differ diff --git a/wrfv2_fire/run/CAM_AEROPT_DATA b/wrfv2_fire/run/CAM_AEROPT_DATA new file mode 100644 index 00000000..88370afa Binary files /dev/null and b/wrfv2_fire/run/CAM_AEROPT_DATA differ diff --git a/wrfv2_fire/run/ETAMPNEW_DATA b/wrfv2_fire/run/ETAMPNEW_DATA new file mode 100644 index 00000000..c18d5a71 Binary files /dev/null and b/wrfv2_fire/run/ETAMPNEW_DATA differ diff --git a/wrfv2_fire/run/ETAMPNEW_DATA_DBL b/wrfv2_fire/run/ETAMPNEW_DATA_DBL new file mode 100644 index 00000000..df8d7f9e Binary files /dev/null and b/wrfv2_fire/run/ETAMPNEW_DATA_DBL differ diff --git a/wrfv2_fire/run/GENPARM.TBL b/wrfv2_fire/run/GENPARM.TBL new file mode 100644 index 00000000..037f15e9 --- /dev/null +++ b/wrfv2_fire/run/GENPARM.TBL @@ -0,0 +1,34 @@ +General Parameters +SLOPE_DATA +9 +0.1 +0.6 +1.0 +0.35 +0.55 +0.8 +0.63 +0.0 +0.0 +SBETA_DATA +-2.0 +FXEXP_DATA +2.0 +CSOIL_DATA +2.00E+6 +SALP_DATA +2.6 +REFDK_DATA +2.0E-6 +REFKDT_DATA +3.0 +FRZK_DATA +0.15 +ZBOT_DATA +-8.0 +CZIL_DATA +0.1 +SMLOW_DATA +0.5 +SMHIGH_DATA +3.0 diff --git a/wrfv2_fire/run/LANDUSE.TBL b/wrfv2_fire/run/LANDUSE.TBL new file mode 100644 index 00000000..d16feb1b --- /dev/null +++ b/wrfv2_fire/run/LANDUSE.TBL @@ -0,0 +1,142 @@ +OLD +13,2, 'ALBD SLMO SFEM SFZ0 THERIN SCFX SFHC ' +SUMMER +1, 18., .05, .88, 50., 3., 1.22, 18.9e5,'Urban land' +2, 17., .30, .92, 15., 4., 2.76, 25.0e5,'Agriculture' +3, 19., .15, .92, 12., 3., 2.37, 20.8e5,'Range-grassland' +4, 16., .30, .93, 50., 4., 2.63, 25.0e5,'Deciduous forest' +5, 12., .30, .95, 50., 4., 3.33, 29.2e5,'Coniferous forest' +6, 14., .35, .95, 40., 5., 2.21, 41.8e5,'Mixed forest and wet land' +7, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water' +8, 14., .50, .95, 20., 6., 1.36, 29.2e5,'Marsh or wet land' +9, 25., .02, .85, 10., 2., 1.76, 12.0e5,'Desert' +10, 15., .50, .92, 10., 5., 3.67, 9.0e25,'Tundra' +11, 55., .95, .95, 5., 5., 0., 9.0e25,'Permanent ice' +12, 12., .50, .95, 50., 5., 1.66, 29.2e5,'Tropical or subtropical forest' +13, 20., .15, .92, 15., 3., 2.00, 25.0e5,'Savannah' +WINTER +1, 18., .10, .88, 50., 3., 1.22, 18.9e5,'Urban land' +2, 23., .60, .92, 5., 4., 1.78, 25.0e5,'Agriculture' +3, 23., .30, .92, 10., 4., 1.78, 20.8e5,'Range-grassland' +4, 17., .60, .93, 50., 5., 2.40, 25.0e5,'Deciduous forest' +5, 12., .60, .95, 50., 5., 3.33, 29.2e5,'Coniferous forest' +6, 14., .70, .95, 40., 6., 2.21, 41.8e5,'Mixed forest and wet land' +7, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water' +8, 14., .75, .95, 20., 6., 1.40, 29.2e5,'Marsh or wet land' +9, 25., .05, .85, 10., 2., 1.76, 12.0e5,'Desert' +10, 15., .90, .92, 10., 5., 3.67, 9.0e25,'Tundra' +11, 70., .95, .95, 5., 5., 0., 9.0e25,'Permanent ice' +12, 12., .50, .95, 50., 5., 1.66, 29.2e5,'Tropical or subtropical forest' +13, 20., .15, .92, 15., 3., 2.00, 25.0e5,'Savannah' +USGS +33,2, 'ALBD SLMO SFEM SFZ0 THERIN SCFX SFHC ' +SUMMER +1, 15., .10, .88, 80., 3., 1.67, 18.9e5,'Urban and Built-Up Land' +2, 17., .30, .985, 15., 4., 2.71, 25.0e5,'Dryland Cropland and Pasture' +3, 18., .50, .985, 10., 4., 2.20, 25.0e5,'Irrigated Cropland and Pasture' +4, 18., .25, .985, 15., 4., 2.56, 25.0e5,'Mixed Dryland/Irrigated Cropland and Pasture' +5, 18., .25, .98, 14., 4., 2.56, 25.0e5,'Cropland/Grassland Mosaic' +6, 16., .35, .985, 20., 4., 3.19, 25.0e5,'Cropland/Woodland Mosaic' +7, 19., .15, .96, 12., 3., 2.37, 20.8e5,'Grassland' +8, 22., .10, .93, 5., 3., 1.56, 20.8e5,'Shrubland' +9, 20., .15, .95, 6., 3., 2.14, 20.8e5,'Mixed Shrubland/Grassland' +10, 20., .15, .92, 15., 3., 2.00, 25.0e5,'Savanna' +11, 16., .30, .93, 50., 4., 2.63, 25.0e5,'Deciduous Broadleaf Forest' +12, 14., .30, .94, 50., 4., 2.86, 25.0e5,'Deciduous Needleleaf Forest' +13, 12., .50, .95, 50., 5., 1.67, 29.2e5,'Evergreen Broadleaf Forest' +14, 12., .30, .95, 50., 4., 3.33, 29.2e5,'Evergreen Needleleaf Forest' +15, 13., .30, .97, 50., 4., 2.11, 41.8e5,'Mixed Forest' +16, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water Bodies' +17, 14., .60, .95, 20., 6., 1.50, 29.2e5,'Herbaceous Wetland' +18, 14., .35, .95, 40., 5., 1.14, 41.8e5,'Wooded Wetland' +19, 25., .02, .90, 1., 2., 0.81, 12.0e5,'Barren or Sparsely Vegetated' +20, 15., .50, .92, 10., 5., 2.87, 9.0e25,'Herbaceous Tundra' +21, 15., .50, .93, 30., 5., 2.67, 9.0e25,'Wooded Tundra' +22, 15., .50, .92, 15., 5., 2.67, 9.0e25,'Mixed Tundra' +23, 25., .02, .90, 10., 2., 1.60, 12.0e5,'Bare Ground Tundra' +24, 55., .95, .95, 5., 5., 0., 9.0e25,'Snow or Ice' +25, 30., .40, .90, 1., 5., .62, 12.0E5,'Playa' +26, 18., .50, .95, 15., 6., .62, 12.0E5,'Lava' +27, 70., .40, .90, 1., 5., 0., 12.0E5,'White Sand' +28, 15., .02, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +29, 15., .02, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +30, 15., .10, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +31, 10., .10, .97, 80., 3., 1.67, 18.9e5,'Low Intensity Residential ' +32, 10., .10, .97, 80., 3., 1.67, 18.9e5,'High Intensity Residential' +33, 10., .10, .97, 80., 3., 1.67, 18.9e5,'Industrial or Commercial' +WINTER +1, 15., .10, .88, 80., 3., 1.67, 18.9e5,'Urban and Built-Up Land' +2, 20., .60, .92, 5., 4., 2.00, 25.0e5,'Dryland Cropland and Pasture' +3, 20., .50, .93, 2., 4., 1.76, 25.0e5,'Irrigated Cropland and Pasture' +4, 20., .50, .92, 5., 4., 2.00, 25.0e5,'Mixed Dryland/Irrigated Cropland and Pasture' +5, 20., .40, .92, 5., 4., 2.00, 25.0e5,'Cropland/Grassland Mosaic' +6, 20., .60, .93, 20., 4., 2.00, 25.0e5,'Cropland/Woodland Mosaic' +7, 23., .30, .92, 10., 4., 2.00, 20.8e5,'Grassland' +8, 22., .20, .93, 1., 4., 1.30, 20.8e5,'Shrubland' +9, 22., .25, .93, 1., 4., 1.24, 20.8e5,'Mixed Shrubland/Grassland' +10, 20., .15, .92, 15., 3., 2.00, 25.0e5,'Savanna' +11, 17., .60, .93, 50., 5., 2.40, 25.0e5,'Deciduous Broadleaf Forest' +12, 15., .60, .93, 50., 5., 2.60, 25.0e5,'Deciduous Needleleaf Forest' +13, 12., .50, .95, 50., 5., 1.67, 29.2e5,'Evergreen Broadleaf Forest' +14, 12., .60, .95, 50., 5., 3.00, 29.2e5,'Evergreen Needleleaf Forest' +15, 14., .60, .93, 20., 6., 1.12, 41.8e5,'Mixed Forest' +16, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water Bodies' +17, 14., .75, .95, 20., 6., 1.50, 29.2e5,'Herbaceous Wetland' +18, 14., .70, .95, 40., 6., 1.14, 41.8e5,'Wooded Wetland' +19, 23., .05, .90, 1., 2., 0.81, 12.0e5,'Barren or Sparsely Vegetated' +20, 15., .60, .92, 10., 5., 2.00, 9.0e25,'Herbaceous Tundra' +21, 15., .60, .93, 30., 5., 1.75, 9.0e25,'Wooded Tundra' +22, 15., .60, .92, 15., 5., 1.75, 9.0e25,'Mixed Tundra' +23, 25., .05, .90, 5., 5., 1.80, 12.0e5,'Bare Ground Tundra' +24, 70., .95, .95, 5., 5., 0., 9.0e25,'Snow or Ice' +25, 40., .40, .90, 1., 5., .62, 12.0E5,'Playa' +26, 18., .40, .95, 15., 5., .62, 12.0E5,'Lava' +27, 70., .40, .90, 1., 5., 0., 12.0E5,'White Sand' +28, 15., .02, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +29, 15., .02, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +30, 15., .10, .88, 80., 3., 1.67, 18.9e5,'Unassigned' +31, 10., .10, .97, 80., 3., 1.67, 18.9e5,'Low Intensity Residential ' +32, 10., .10, .97, 80., 3., 1.67, 18.9e5,'High Intensity Residential' +33, 10., .10, .97, 80., 3., 1.67, 18.9e5,'Industrial or Commercial' +SiB +16,2, 'ALBD SLMO SFEM SFZ0 THERIN SCFX SFHC ' +SUMMER +1, 12., .50, .95, 50., 5., 1.67, 29.2e5,'Evergreen Broadleaf Trees' +2, 16., .30, .93, 50., 4., 2.63, 25.0e5,'Broadleaf Deciduous Trees' +3, 14., .35, .95, 40., 5., 3.00, 41.8e5,'Deciduous and Evergreen Trees' +4, 12., .30, .95, 50., 4., 3.33, 29.2e5,'Evergreen Needleleaf Trees' +5, 16., .30, .93, 50., 4., 2.38, 25.0e5,'Deciduous Needleleaf Trees' +6, 20., .15, .92, 15., 3., 1.80, 25.0e5,'Ground Cover with Trees and Shrubs' +7, 19., .15, .92, 12., 3., 2.16, 20.8e5,'Groundcover Only' +8, 19., .15, .92, 12., 3., 2.53, 20.8e5,'Broadleaf Shrubs with Perennial Ground Cover' +9, 19., .15, .92, 12., 3., 2.63, 20.8e5,'Broadleaf Shrubs with Bare Soil' +10, 15., .50, .92, 10., 5., 2.73, 9.0e25,'Groundcover with Dwarf Trees and Shrubs' +11, 25., .02, .85, 10., 2., 1.76, 12.0e5,'Bare Soil' +12, 17., .30, .92, 15., 4., 2.76, 25.0e5,'Agriculture or C3 Grassland' +13, 14., .50, .95, 20., 6., 1.36, 29.2e5,'Persistent Wetland' +14, 19., .15, .92, 12., 3., 2.16, 20.8e5,'Dry Coastal Complexes' +15, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water' +16, 55., .95, .95, 5., 5., 0., 9.0e25,'Ice Cap and Glacier' +WINTER +1, 12., .50, .95, 50., 5., 1.67, 29.2e5,'Evergreen Broadleaf Trees' +2, 17., .60, .93, 50., 5., 2.41, 25.0e5,'Broadleaf Deciduous Trees' +3, 14., .70, .95, 40., 6., 2.79, 41.8e5,'Deciduous and Evergreen Trees' +4, 12., .60, .95, 50., 5., 3.33, 29.2e5,'Evergreen Needleleaf Trees' +5, 17., .60, .93, 50., 5., 2.16, 25.0e5,'Deciduous Needleleaf Trees' +6, 20., .15, .92, 15., 3., 1.80, 25.0e5,'Ground Cover with Trees and Shrubs' +7, 23., .30, .92, 10., 4., 2.00, 20.8e5,'Groundcover Only' +8, 23., .30, .92, 10., 4., 1.91, 20.8e5,'Broadleaf Shrubs with Perennial Ground Cover' +9, 23., .30, .92, 10., 4., 1.91, 20.8e5,'Broadleaf Shrubs with Bare Soil' +10, 20., .90, .92, 10., 5., 1.80, 9.0e25,'Groundcover with Dwarf Trees and Shrubs' +11, 25., .05, .85, 10., 2., 1.76, 12.0e5,'Bare Soil' +12, 23., .60, .92, 5., 4., 1.78, 25.0e5,'Agriculture or C3 Grassland' +13, 14., .75, .95, 20., 6., 1.50, 29.2e5,'Persistent Wetland' +14, 23., .30, .92, 10., 4., 1.61, 20.8e5,'Dry Coastal Complexes' +15, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water' +16, 70., .95, .95, 5., 5., 0., 9.0e25,'Ice Cap and Glacier' +LW12 +3,1, 'ALBD SLMO SFEM SFZ0 THERIN SCFX SFHC ' +ALL-SEASON +1, 20., 0.3, .85, 10., 4., 2.00, 20.8e5,'Land' +2, 8., 1.0, .98, 0.01, 6., 0., 9.0e25,'Water' +3, 70., .95, .95, 5., 5., 0., 9.0e25,'Snow or Ice' diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist new file mode 100644 index 00000000..b25d9603 --- /dev/null +++ b/wrfv2_fire/run/README.namelist @@ -0,0 +1,550 @@ +Description of namelist variables +--------------------------------- + +For WRF-NMM users, please see Chapter 5 of the WRF-NMM User's Guide for +information on NMM specific settings (http://www.dtcenter.org/wrf-nmm/users) + + + Note: variables followed by (max_dom) indicate that this variable needs to + be defined for the nests when max_dom > 1. + + &time_control + run_days = 1, ; run time in days + run_hours = 0, ; run time in hours + Note: if it is more than 1 day, one may use both run_days and run_hours + or just run_hours. e.g. if the total run length is 36 hrs, you may + set run_days = 1, and run_hours = 12, or run_days = 0, and run_hours = 36 + run_minutes = 0, ; run time in minutes + run_seconds = 0, ; run time in seconds + start_year (max_dom) = 2001, ; four digit year of starting time + start_month (max_dom) = 06, ; two digit month of starting time + start_day (max_dom) = 11, ; two digit day of starting time + start_hour (max_dom) = 12, ; two digit hour of starting time + start_minute (max_dom) = 00, ; two digit minute of starting time + start_second (max_dom) = 00, ; two digit second of starting time + Note: the start time is used to name the first wrfout file. + It also controls the start time for nest domains, and the time to restart + tstart (max_dom) = 00, ; FOR NMM: starting hour of the forecast + end_year (max_dom) = 2001, ; four digit year of ending time + end_month (max_dom) = 06, ; two digit month of ending time + end_day (max_dom) = 12, ; two digit day of ending time + end_hour (max_dom) = 12, ; two digit hour of ending time + end_minute (max_dom) = 00, ; two digit minute of ending time + end_second (max_dom) = 00, ; two digit second of ending time + It also controls when the nest domain integrations end + All start and end times are used by real.exe. + + Note that one may use either run_days/run_hours etc. or + end_year/month/day/hour etc. to control the length of + model integration. But run_days/run_hours + takes precedence over the end times. + Program real.exe uses start and end times only. + + interval_seconds = 10800, ; time interval between incoming real data, which will be the interval + between the lateral boundary condition file + input_from_file (max_dom) = T, ; whether nested run will have input files for domains other than 1 + fine_input_stream (max_dom) = 0, ; field selection from nest input for its initialization + 0: all fields are used; 2: only static and time-varying, masked land + surface fields are used. + history_interval (max_dom) = 60, ; history output file interval in minutes + frames_per_outfile (max_dom) = 1, ; output times per history output file, used to split output files + into smaller pieces + restart = F, ; whether this run is a restart run + restart_interval = 1440, ; restart output file interval in minutes + io_form_history = 2, ; 2 = netCDF + io_form_restart = 2, ; 2 = netCDF + io_form_input = 2, ; 2 = netCDF + io_form_boundary = 2, ; netCDF format + = 4, ; PHD5 format + = 5, ; GRIB1 format + frames_per_emissfile = 12, ; Number of times in each chemistry emission file. + io_style_emiss = 1, ; Style to use for the chemistry emission files. + ; 0 = Do not read emissions from files. + ; 1 = Cycle between two 12 hour files (set frames_per_emissfile=12) + ; 2 = Dated files with length set by frames_per_emissfile + debug_level = 0, ; 50,100,200,300 values give increasing prints + +To choose between SI and WPS input to real for EM core: + auxinput1_inname = "met_em.d." ; Input to real from WPS + = "wrf_real_input_em.d." ; Input to real from SI + = "met_nmm.d." ; Input to real from WPS (NMM) + = "wrf_real_input_nm.d." ; Input to real from SI (NMM) + +To choose between SI and WPS input to real for NMM core: + auxinput1_inname = "met_nm.d." ; Input to real from WPS + = "wrf_real_input_nm.d." ; Input to real from SI + +Other output options: + + auxhist2_outname = "rainfall" ; file name for extra output; if not specified, + auxhist2_d_ will be used + also note that to write variables in output other + than the history file requires Registry.EM file change + auxhist2_interval (max_dom) = 10, ; interval in minutes + io_form_auxhist2 = 2, ; output in netCDF + +Additional ones when running 3DVAR: + + write_input = t, ; write input-formatted data as output + inputout_interval = 180, ; interval in minutes when writing input-formatted data + input_outname = 'wrf_3dvar_input_d_' ; you may change the output file name + inputout_begin_y = 0 + inputout_begin_mo = 0 + inputout_begin_d = 0 + inputout_begin_h = 3 + inputout_begin_m = 0 + inputout_begin_s = 0 + inputout_end_y = 0 + inputout_end_mo = 0 + inputout_end_d = 0 + inputout_end_h = 12 + inputout_end_m = 0 + inputout_end_s = 0 ; the above shows that the input-formatted data are output + starting from hour 3 to hour 12 in 180 min interval. + + &domains + time_step = 60, ; time step for integration in integer seconds + recommend 6*dx (in km) for typical real-data cases + time_step_fract_num = 0, ; numerator for fractional time step + time_step_fract_den = 1, ; denominator for fractional time step + Example, if you want to use 60.3 sec as your time step, + set time_step = 60, time_step_fract_num = 3, and + time_step_fract_den = 10 + max_dom = 1, ; number of domains - set it to > 1 if it is a nested run + s_we (max_dom) = 1, ; start index in x (west-east) direction (leave as is) + e_we (max_dom) = 91, ; end index in x (west-east) direction (staggered dimension) + s_sn (max_dom) = 1, ; start index in y (south-north) direction (leave as is) + e_sn (max_dom) = 82, ; end index in y (south-north) direction (staggered dimension) + s_vert (max_dom) = 1, ; start index in z (vertical) direction (leave as is) + e_vert (max_dom) = 28, ; end index in z (vertical) direction (staggered dimension) + Note: this refers to full levels including surface and top + vertical dimensions need to be the same for all nests + Note: most variables are unstaggered (= staggered dim - 1) + dx (max_dom) = 10000, ; grid length in x direction, unit in meters + dy (max_dom) = 10000, ; grid length in y direction, unit in meters + ztop (max_dom) = 19000. ; used in mass model for idealized cases + grid_id (max_dom) = 1, ; domain identifier + parent_id (max_dom) = 0, ; id of the parent domain + i_parent_start (max_dom) = 0, ; starting LLC I-indices from the parent domain + j_parent_start (max_dom) = 0, ; starting LLC J-indices from the parent domain + parent_grid_ratio (max_dom) = 1, ; parent-to-nest domain grid size ratio: for real-data cases + the ratio has to be odd; for idealized cases, + the ratio can be even if feedback is set to 0. + parent_time_step_ratio (max_dom) = 1, ; parent-to-nest time step ratio; it can be different + from the parent_grid_ratio + feedback = 1, ; feedback from nest to its parent domain; 0 = no feedback + smooth_option = 0 ; smoothing option for parent domain, used only with feedback + option on. 0: no smoothing; 1: 1-2-1 smoothing; 2: smoothing-desmoothing + +Namelist variables specifically for the WPS input for real: + + num_metgrid_levels = 27 ; number of vertical levels of 3d meteorological fields coming + ; from WPS metgrid program + interp_type = 1 ; vertical interpolation + ; 1 = linear in pressure + ; 2 = linear in log(pressure) + extrap_type = 2 ; vertical extrapolation + ; 1 = extrapolate using the two lowest levels + ; 2 = use lowest level as constant below ground + t_extrap_type = 1 ; vertical extrapolation for potential temperature + ; 1 = extrapolate using the two lowest levels + ; 2 = use lowest level as constant below ground + ; 3 = -6.5 K/km lapse rate + lagrange_order = 1 ; vertical interpolation order + ; 1 = linear + ; 2 = quadratic + zap_close_levels = 500 ; ignore isobaric level above surface if delta p (Pa) < zap_close_levels + lowest_lev_from_sfc = .false. ; place the surface value into the lowest eta location + ; T = use surface value as lowest eta (u,v,t,q) + ; F = use traditional interpolation + force_sfc_in_vinterp = 1 ; use the surface level as the lower boundary when interpolating + ; through this many eta levels + ; 0 = perform traditional trapping interpolation + ; n = first n eta levels directly use surface level + p_top_requested = 5000 ; p_top (Pa) to use in the model + ptsgm = 42000. ; FOR NMM: defines the pressure interface dividing + ; the terrain following portion of the hybrid vertical + ; coordinate (p > ptsgm) and the purely + ; isobaric portion of the vertical coordinate (p < ptsgm) + +Users may explicitly define full eta levels. Given are two distributions for 28 and 35 levels. The number +of levels must agree with the number of eta surfaces allocated (e_vert). Users may alternatively request +only the number of levels (with e_vert), and the real program will compute values. The computation assumes +a known first several layers, then generates equi-height spaced levels up to the top of the model. + + eta_levels = 1.000, 0.990, 0.978, 0.964, 0.946, + 0.922, 0.894, 0.860, 0.817, 0.766, + 0.707, 0.644, 0.576, 0.507, 0.444, + 0.380, 0.324, 0.273, 0.228, 0.188, + 0.152, 0.121, 0.093, 0.069, 0.048, + 0.029, 0.014, 0.000, + eta_levels = 1.000, 0.993, 0.983, 0.970, 0.954, + 0.934, 0.909, 0.880, 0.845, 0.807, + 0.765, 0.719, 0.672, 0.622, 0.571, + 0.520, 0.468, 0.420, 0.376, 0.335, + 0.298, 0.263, 0.231, 0.202, 0.175, + 0.150, 0.127, 0.106, 0.088, 0.070, + 0.055, 0.040, 0.026, 0.013, 0.000 + +Namelist variables for controling the specified moving nest: + Note that this moving nest option needs to be activated at the compile time by adding -DMOVE_NESTS + to the ARCHFLAGS. The maximum number of moves, max_moves, is set to 50 + but can be modified in source code file frame/module_driver_constants.F. + num_moves = 4 ; total number of moves + move_id = 2,2,2,2, ; a list of nest domain id's, one per move + move_interval = 60,120,150,180, ; time in minutes since the start of this domain + move_cd_x = 1,1,0,-1,; the number of parent domain grid cells to move in i direction + move_cd_y = 1,0,-1,1,; the number of parent domain grid cells to move in j direction + positive is to move in increasing i and j direction, and + negative is to move in decreasing i and j direction. + 0 means no move. The limitation now is to move only 1 grid cell + at each move. + +Namelist variables for controling the automatic moving nest: + Note that this moving nest option needs to be activated at the compile time by adding -DMOVE_NESTS + and -DVORTEX_CENTER to the ARCHFLAGS. This option uses an mid-level vortex following algorthm to + determine the nest move. This option is experimental. + vortex_interval = 15 ; how often the new vortex position is computed + max_vortex_speed = 40 ; used to compute the search radius for the new vortex position + corral_dist = 8 ; how many coarse grid cells the moving nest is allowed to get + near the mother domain boundary + + tile_sz_x = 0, ; number of points in tile x direction + tile_sz_y = 0, ; number of points in tile y direction + can be determined automatically + numtiles = 1, ; number of tiles per patch (alternative to above two items) + nproc_x = -1, ; number of processors in x for decomposition + nproc_y = -1, ; number of processors in y for decomposition + -1: code will do automatic decomposition + >1: for both: will be used for decomposition + + &physics + + Note: even the physics options can be different in different nest domains, + caution must be used as what options are sensible to use + + chem_opt = 0, ; chemistry option - not yet available + mp_physics (max_dom) microphysics option + = 0, no microphysics + = 1, Kessler scheme + = 2, Lin et al. scheme + = 3, WSM 3-class simple ice scheme + = 4, WSM 5-class scheme + = 5, Ferrier (new Eta) microphysics + = 6, WSM 6-class graupel scheme + = 8, Thompson et al. scheme + = 98, NCEP 3-class simple ice scheme (to be removed) + = 99, NCEP 5-class scheme (to be removed) + + For non-zero mp_physics options, to keep Qv .GE. 0, and to set the other moisture + fields .LT. a critcal value to zero + + mp_zero_out = 0, ; no action taken, no adjustment to any moist field + = 1, ; except for Qv, all other moist arrays are set to zero + ; if they fall below a critical value + = 2, ; Qv is .GE. 0, all other moist arrays are set to zero + ; if they fall below a critical value + mp_zero_out_thresh = 1.e-8 ; critical value for moist array threshold, below which + ; moist arrays (except for Qv) are set to zero (kg/kg) + + ra_lw_physics (max_dom) longwave radiation option + = 0, no longwave radiation + = 1, rrtm scheme + = 3, cam scheme + also must set levsiz, paerlev, cam_abs_dim1/2 (see below) + = 99, GFDL (Eta) longwave (semi-supported) + also must use co2tf = 1 for ARW + + ra_sw_physics (max_dom) shortwave radiation option + = 0, no shortwave radiation + = 1, Dudhia scheme + = 2, Goddard short wave + = 3, cam scheme + also must set levsiz, paerlev, cam_abs_dim1/2 (see below) + = 99, GFDL (Eta) longwave (semi-supported) + also must use co2tf = 1 for ARW + + radt (max_dom) = 30, ; minutes between radiation physics calls + recommend 1 min per km of dx (e.g. 10 for 10 km) + + nrads (max_dom) = FOR NMM: number of fundamental timesteps between + calls to shortwave radiation; the value + is set in Registry.NMM but is overridden + by namelist value; radt will be computed + from this. + + nradl (max_dom) = FOR NMM: number of fundamental timesteps between + calls to longwave radiation; the value + is set in Registry.NMM but is overridden + by namelist value. + + co2tf CO2 transmission function flag only for GFDL radiation + = 0, read CO2 function data from pre-generated file + = 1, generate CO2 functions internally in the forecast + + ra_call_offset radiation call offset + = 0 (no offset), =-1 (old offset) + + cam_abs_freq_s = 21600 CAM clearsky longwave absorption calculation frequency + (recommended minimum value to speed scheme up) + levsiz = 59 for CAM radiation input ozone levels + paerlev = 29 for CAM radiation input aerosol levels + cam_abs_dim1 = 4 for CAM absorption save array + cam_abs_dim2 = value of e_vert for CAM 2nd absorption save array + + sf_sfclay_physics (max_dom) surface-layer option (old bl_sfclay_physics option) + = 0, no surface-layer + = 1, Monin-Obukhov scheme + = 2, Monin-Obukhov (Janjic) scheme + = 3, NCEP Global Forecast System scheme + + sf_surface_physics (max_dom) land-surface option (old bl_surface_physics option) + = 0, no surface temp prediction + = 1, thermal diffusion scheme + = 2, Noah land-surface model + = 3, RUC land-surface model + + bl_pbl_physics (max_dom) boundary-layer option + = 0, no boundary-layer + = 1, YSU scheme + = 2, Mellor-Yamada-Janjic TKE scheme + = 3, NCEP Global Forecast System scheme + = 99, MRF scheme (to be removed) + + bldt (max_dom) = 0, ; minutes between boundary-layer physics calls + + nphs (max_dom) = FOR NMM: number of fundamental timesteps between + calls to turbulence and microphysics; + the value is set in Registry.NMM but is + overridden by namelist value; bldt will + be computed from this. + + cu_physics (max_dom) cumulus option + = 0, no cumulus + = 1, Kain-Fritsch (new Eta) scheme + = 2, Betts-Miller-Janjic scheme + = 3, Grell-Devenyi ensemble scheme + = 4, Simplified Arakawa-Schubert scheme + = 99, previous Kain-Fritsch scheme + + cudt = 0, ; minutes between cumulus physics calls + + ncnvc (max_dom) = FOR NMM: number of fundamental timesteps between + calls to convection; the value is set in Registry.NMM + but is overridden by namelist value; cudt will be + computed from this. + + tprec (max_dom) = FOR NMM: number of hours in precipitation bucket + theat (max_dom) = FOR NMM: number of hours in latent heating bucket + tclod (max_dom) = FOR NMM: number of hours in cloud fraction average + trdsw (max_dom) = FOR NMM: number of hours in short wave buckets + trdlw (max_dom) = FOR NMM: number of hours in long wave buckets + tsrfc (max_dom) = FOR NMM: number of hours in surface flux buckets + pcpflg (max_dom) = FOR NMM: logical switch for precipitation assimilation + + isfflx = 1, ; heat and moisture fluxes from the surface + (only works for sf_sfclay_physics = 1) + 1 = with fluxes from the surface + 0 = no flux from the surface + ifsnow = 0, ; snow-cover effects + (only works for sf_surface_physics = 1) + 1 = with snow-cover effect + 0 = without snow-cover effect + icloud = 1, ; cloud effect to the optical depth in radiation + (only works for ra_sw_physics = 1 and ra_lw_physics = 1) + 1 = with cloud effect + 0 = without cloud effect + swrad_scat = 1. ; scattering tuning parameter (default 1. is 1.e-5 m2/kg) + surface_input_source = 1, ; where landuse and soil category data come from: + 1 = SI/gridgen + 2 = GRIB data from another model (only possible + (VEGCAT/SOILCAT are in wrf_real_input_em files from SI) + num_soil_layers = 5, ; number of soil layers in land surface model + = 5: thermal diffusion scheme + = 4: Noah landsurface model + = 6: RUC landsurface model + ucmcall = 0, ; activate urban canopy model (in Noah LSM only) (0=no, 1=yes) + + maxiens = 1, ; Grell-Devenyi only + maxens = 3, ; G-D only + maxens2 = 3, ; G-D only + maxens3 = 16 ; G-D only + ensdim = 144 ; G-D only + These are recommended numbers. If you would like to use + any other number, consult the code, know what you are doing. + seaice_threshold = 271 ; tsk < seaice_threshold, if water point and 5-layer slab + ; scheme, set to land point and permanent ice; if water point + ; and Noah scheme, set to land point, permanent ice, set temps + ; from 3 m to surface, and set smois and sh2o + sst_update = 0 ; time-varying sea-surface temp (0=no, 1=yes). If selected real + ; puts SST and VEGFRA in wrflowinp_d01 file, and wrf updates these from it + ; at same interval as boundary file. To read this, the time-control + ; namelist must include auxinput5_interval, auxinput5_end_h, and + ; auxinput5_inname = "wrflowinp_d" + + &fdda + grid_fdda (max_dom) = 1 ; grid-nudging fdda on (=0 off) for each domain + gfdda_inname = "wrffdda_d" ; defined name in real + gfdda_interval_m (max_dom) = 360 ; time interval (min) between analysis times + gfdda_end_h (max_dom) = 6 ; time (h) to stop nudging after start of forecast + io_form_gfdda = 2 ; analysis data io format (2 = netCDF) + fgdt (max_dom) = 0 ; calculation frequency (minutes) for grid-nudging (0=every step) + if_no_pbl_nudging_uv (max_dom) = 0 ; 1= no nudging of u and v in the pbl, 0=nudging in the pbl + if_no_pbl_nudging_t (max_dom) = 0 ; 1= no nudging of temp in the pbl, 0=nudging in the pbl + if_no_pbl_nudging_q (max_dom) = 0 ; 1= no nudging of qvapor in the pbl, 0=nudging in the pbl + if_zfac_uv (max_dom) = 0 ; 0= nudge u and v all layers, 1= limit nudging to levels above k_zfac_uv + k_zfac_uv (max_dom) = 10 ; 10=model level below which nudging is switched off for u and v + if_zfac_t (max_dom) = 0 ; 0= nudge temp all layers, 1= limit nudging to levels above k_zfac_t + k_zfac_t (max_dom) = 10 ; 10=model level below which nudging is switched off for temp + if_zfac_q (max_dom) = 0 ; 0= nudge qvapor all layers, 1= limit nudging to levels above k_zfac_q + k_zfac_q (max_dom) = 10 ; 10=model level below which nudging is switched off for qvapor + guv (max_dom) = 0.0003 ; nudging coefficient for u and v (sec-1) + gt (max_dom) = 0.0003 ; nudging coefficient for temp (sec-1) + gq (max_dom) = 0.0003 ; nudging coefficient for qvapor (sec-1) + if_ramping = 0 ; 0= nudging ends as a step function, 1= ramping nudging down at end of period + dtramp_min = 60.0 ; time (min) for ramping function, 60.0=ramping starts at last analysis time, + -60.0=ramping ends at last analysis time + +The following are for observation nudging: + obs_nudge_opt (max_dom) = 1 ; obs-nudging fdda on (=0 off) for each domain + also need to set auxinput11_interval and auxinput11_end_h + in time_control namelist + max_obs = 150000 ; max number of observations used on a domain during any + given time window + fdda_start = 0 ; obs nudging start time in minutes + fdda_end = 180 ; obs nudging end time in minutes + obs_nudge_wind (max_dom) = 1 ; whether to nudge wind: (=0 off) + obs_coef_wind = 6.E-4, ; nudging coefficient for wind, unit: s-1 + obs_nudge_temp = 1 ; whether to nudge temperature: (=0 off) + obs_coef_temp = 6.E-4, ; nudging coefficient for temperature, unit: s-1 + obs_nudge_mois = 1 ; whether to nudge water vapor mixing ratio: (=0 off) + obs_coef_mois = 6.E-4, ; nudging coefficient for water vapor mixing ratio, unit: s-1 + obs_nudge_pstr = 0 ; whether to nudge surface pressure (not used) + obs_coef_pstr = 0. ; nudging coefficient for surface pressure, unit: s-1 (not used) + obs_rinxy = 200., ; horizonal radius of influence in km + obs_rinsig = 0.1, ; vertical radius of influence in eta + obs_twindo = 0.66667 ; half-period time window over which an observation + will be used for nudging (hours) + obs_npfi = 10, ; freq in coarse grid timesteps for diag prints + obs_ionf = 2 ; freq in coarse grid timesteps for obs input and err calc + obs_idynin = 0 ; for dynamic initialization using a ramp-down function to gradually + turn off the FDDA before the pure forecast (=1 on) + obs_dtramp = 40 ; time period in minutes over which the nudging is ramped down + from one to zero. + obs_ipf_in4dob = .true. ; print obs input diagnostics (=.false. off) + obs_ipf_errob = .true. ; print obs error diagnostics (=.false. off) + obs_ipf_nudob = .true. ; print obs nudge diagnostics (=.false. off) + / + + + &dynamics + dyn_opt = 2, ; dynamical core option: advanced research WRF core (Eulerian mass) + rk_ord = 3, ; time-integration scheme option: + 2 = Runge-Kutta 2nd order + 3 = Runge-Kutta 3rd order + diff_opt = 0, ; turbulence and mixing option: + 0 = no turbulence or explicit + spatial numerical filters (km_opt IS IGNORED). + 1 = evaluates 2nd order + diffusion term on coordinate surfaces. + uses kvdif for vertical diff unless PBL option + is used. may be used with km_opt = 1 and 4. + (= 1, recommended for real-data cases) + 2 = evaluates mixing terms in + physical space (stress form) (x,y,z). + turbulence parameterization is chosen + by specifying km_opt. + km_opt = 1, ; eddy coefficient option + 1 = constant (use khdif kvdif) + 2 = 1.5 order TKE closure (3D) + 3 = Smagorinsky first order closure (3D) + Note: option 2 and 3 are not recommended for DX > 2 km + 4 = horizontal Smagorinsky first order closure + (recommended for real-data cases) + damp_opt = 0, ; upper level damping flag + 0 = without damping + 1 = with diffusive damping, maybe used for real-data cases + (dampcoef nondimensional ~0.01-0.1) + 2 = with Rayleigh damping (dampcoef inverse time scale [1/s] e.g. .003; + not for real-data cases) + diff_6th_opt = 0, ; 6th-order numerical diffusion + 0 = no 6th-order diffusion (default) + 1 = 6th-order numerical diffusion + 2 = 6th-order numerical diffusion but prohibit up-gradient diffusion + diff_6th_factor = 0.12, ; 6th-order numerical diffusion non-dimensional rate (max value 1.0 + corresponds to complete removal of 2dx wave in one timestep) + dampcoef (max_dom) = 0., ; damping coefficient (see above) + zdamp (max_dom) = 5000., ; damping depth (m) from model top + w_damping = 0, ; vertical velocity damping flag (for operational use) + 0 = without damping + 1 = with damping + base_temp = 290., ; real-data, em ONLY, base sea-level temp (K) + base_pres = 10^5 ; real-data, em ONLY, base sea-level pres (Pa), DO NOT CHANGE + base_lapse = 50., ; real-data, em ONLY, lapse rate (K), DO NOT CHANGE + khdif (max_dom) = 0, ; horizontal diffusion constant (m^2/s) + kvdif (max_dom) = 0, ; vertical diffusion constant (m^2/s) + smdiv (max_dom) = 0.1, ; divergence damping (0.1 is typical) + emdiv (max_dom) = 0.01, ; external-mode filter coef for mass coordinate model + (0.01 is typical for real-data cases) + epssm (max_dom) = .1, ; time off-centering for vertical sound waves + non_hydrostatic (max_dom) = .true., ; whether running the model in hydrostatic or non-hydro mode + pert_coriolis (max_dom) = .false., ; Coriolis only acts on wind perturbation (idealized) + mix_full_fields(max_dom) = .true., ; used with diff_opt = 2; value of ".true." is recommended, except for + highly idealized numerical tests; damp_opt must not be 1 if ".true." + is chosen. .false. means subtract 1-d base-state profile before mixing + tke_drag_coefficient(max_dom) = 0., ; surface drag coefficient (Cd, dimensionless) for diff_opt=2 only + tke_heat_flux(max_dom) = 0., ; surface thermal flux (H/(rho*cp), K m/s) for diff_opt=2 only + h_mom_adv_order (max_dom) = 5, ; horizontal momentum advection order (5=5th, etc.) + v_mom_adv_order (max_dom) = 3, ; vertical momentum advection order + h_sca_adv_order (max_dom) = 5, ; horizontal scalar advection order + v_sca_adv_order (max_dom) = 3, ; vertical scalar advection order + pd_moist = F ; positive definite advection of moisture + pd_scalar = F ; positive definite advection of scalars + pd_chem = F ; positive definite advection of chem variables + pd_tke = F ; positive definite advection of tke + time_step_sound (max_dom) = 4 / ; number of sound steps per time-step (0=set automatically) + (if using a time_step much larger than 6*dx (in km), + proportionally increase number of sound steps - also + best to use even numbers) + + + &bdy_control + spec_bdy_width = 5, ; total number of rows for specified boundary value nudging + spec_zone = 1, ; number of points in specified zone (spec b.c. option) + relax_zone = 4, ; number of points in relaxation zone (spec b.c. option) + specified (max_dom) = .false., ; specified boundary conditions (only for domain 1) + the above 4 are used for real-data runs + + periodic_x (max_dom) = .false., ; periodic boundary conditions in x direction + symmetric_xs (max_dom) = .false., ; symmetric boundary conditions at x start (west) + symmetric_xe (max_dom) = .false., ; symmetric boundary conditions at x end (east) + open_xs (max_dom) = .false., ; open boundary conditions at x start (west) + open_xe (max_dom) = .false., ; open boundary conditions at x end (east) + periodic_y (max_dom) = .false., ; periodic boundary conditions in y direction + symmetric_ys (max_dom) = .false., ; symmetric boundary conditions at y start (south) + symmetric_ye (max_dom) = .false., ; symmetric boundary conditions at y end (north) + open_ys (max_dom) = .false., ; open boundary conditions at y start (south) + open_ye (max_dom) = .false., ; open boundary conditions at y end (north) + nested (max_dom) = .false., ; nested boundary conditions (inactive) + + + &namelist_quilt This namelist record controls asynchronized I/O for MPI applications. + + nio_tasks_per_group = 0, default value is 0: no quilting; > 0 quilting I/O + nio_groups = 1, default 1, don't change + + + &grib2: + background_proc_id = 255, ; Background generating process identifier, typically defined + by the originating center to identify the background data that + was used in creating the data. This is octet 13 of Section 4 + in the grib2 message + forecast_proc_id = 255, ; Analysis or generating forecast process identifier, typically + defined by the originating center to identify the forecast process + that was used to generate the data. This is octet 14 of Section + 4 in the grib2 message + production_status = 255, ; Production status of processed data in the grib2 message. + See Code Table 1.3 of the grib2 manual. This is octet 20 of + Section 1 in the grib2 record + compression = 40, ; The compression method to encode the output grib2 message. + Only 40 for jpeg2000 or 41 for PNG are supported diff --git a/wrfv2_fire/run/RRTM_DATA b/wrfv2_fire/run/RRTM_DATA new file mode 100644 index 00000000..dbb40596 Binary files /dev/null and b/wrfv2_fire/run/RRTM_DATA differ diff --git a/wrfv2_fire/run/RRTM_DATA_DBL b/wrfv2_fire/run/RRTM_DATA_DBL new file mode 100644 index 00000000..63b5ea0b Binary files /dev/null and b/wrfv2_fire/run/RRTM_DATA_DBL differ diff --git a/wrfv2_fire/run/SOILPARM.TBL b/wrfv2_fire/run/SOILPARM.TBL new file mode 100644 index 00000000..6321e36e --- /dev/null +++ b/wrfv2_fire/run/SOILPARM.TBL @@ -0,0 +1,22 @@ +Soil Parameters +STAS +19,1 'BB DRYSMC F11 MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' +1, 2.79, 0.010, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.010, 0.92, 'SAND' +2, 4.26, 0.028, -1.044, 0.421, 0.383, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.82, 'LOAMY SAND' +3, 4.74, 0.047, -0.569, 0.434, 0.383, 0.141, 5.23E-6, 0.805E-5, 0.047, 0.60, 'SANDY LOAM' +4, 5.33, 0.084, 0.162, 0.476, 0.360, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.25, 'SILT LOAM' +5, 5.33, 0.084, 0.162, 0.476, 0.383, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.10, 'SILT' +6, 5.25, 0.066, -0.327, 0.439, 0.329, 0.355, 3.38E-6, 0.143E-4, 0.066, 0.40, 'LOAM' +7, 6.66, 0.067, -1.491, 0.404, 0.314, 0.135, 4.45E-6, 0.990E-5, 0.067, 0.60, 'SANDY CLAY LOAM' +8, 8.72, 0.120, -1.118, 0.464, 0.387, 0.617, 2.04E-6, 0.237E-4, 0.120, 0.10, 'SILTY CLAY LOAM' +9, 8.17, 0.103, -1.297, 0.465, 0.382, 0.263, 2.45E-6, 0.113E-4, 0.103, 0.35, 'CLAY LOAM' +10, 10.73, 0.100, -3.209, 0.406, 0.338, 0.098, 7.22E-6, 0.187E-4, 0.100, 0.52, 'SANDY CLAY' +11, 10.39, 0.126, -1.916, 0.468, 0.404, 0.324, 1.34E-6, 0.964E-5, 0.126, 0.10, 'SILTY CLAY' +12, 11.55, 0.138, -2.138, 0.468, 0.412, 0.468, 9.74E-7, 0.112E-4, 0.138, 0.25, 'CLAY' +13, 5.25, 0.066, -0.327, 0.439, 0.329, 0.355, 3.38E-6, 0.143E-4, 0.066, 0.05, 'ORGANIC MATERIAL' +14, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.60, 'WATER' +15, 2.79, 0.006, -1.111, 0.20, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.07, 'BEDROCK' +16, 4.26, 0.028, -1.044, 0.421, 0.283, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.25, 'OTHER(land-ice)' +17, 11.55, 0.030, -10.472, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' +18, 2.79, 0.006, -0.472, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.52, 'LAVA' +19, 2.79, 0.01, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/run/VEGPARM.TBL b/wrfv2_fire/run/VEGPARM.TBL new file mode 100644 index 00000000..d17ef9ce --- /dev/null +++ b/wrfv2_fire/run/VEGPARM.TBL @@ -0,0 +1,40 @@ +Vegetation Parameters +USGS +27,1, 'ALBEDO Z0 SHDFAC NROOT RS RGL HS SNUP LAI MAXALB' +1, .15, 1.00, .10, 1, 200., 999., 999.0, 0.04, 4.0, 40., 'Urban and Built-Up Land' +2, .19, .07, .80, 3, 40., 100., 36.25, 0.04, 4.0, 64., 'Dryland Cropland and Pasture' +3, .15, .07, .80, 3, 40., 100., 36.25, 0.04, 4.0, 64., 'Irrigated Cropland and Pasture' +4, .17, .07, .80, 3, 40., 100., 36.25, 0.04, 4.0, 64., 'Mixed Dryland/Irrigated Cropland and Pasture' +5, .19, .07, .80, 3, 40., 100., 36.25, 0.04, 4.0, 64., 'Cropland/Grassland Mosaic' +6, .19, .15, .80, 3, 70., 65., 44.14, 0.04, 4.0, 60., 'Cropland/Woodland Mosaic' +7, .19, .08, .80, 3, 40., 100., 36.35, 0.04, 4.0, 64., 'Grassland' +8, .25, .03, .70, 3, 300., 100., 42.00, 0.03, 4.0, 69., 'Shrubland' +9, .23, .05, .70, 3, 170., 100., 39.18, 0.035, 4.0, 67., 'Mixed Shrubland/Grassland' +10, .20, .86, .50, 3, 70., 65., 54.53, 0.04, 4.0, 45., 'Savanna' +11, .12, .80, .80, 4, 100., 30., 54.53, 0.08, 4.0, 58., 'Deciduous Broadleaf Forest' +12, .11, .85, .70, 4, 150., 30., 47.35, 0.08, 4.0, 54., 'Deciduous Needleleaf Forest' +13, .11, 2.65, .95, 4, 150., 30., 41.69, 0.08, 4.0, 32., 'Evergreen Broadleaf Forest' +14, .10, 1.09, .70, 4, 125., 30., 47.35, 0.08, 4.0, 52., 'Evergreen Needleleaf Forest' +15, .12, .80, .80, 4, 125., 30., 51.93, 0.08, 4.0, 53., 'Mixed Forest' +16, .19, .001, .00, 0, 100., 30., 51.75, 0.01, 4.0, 70., 'Water Bodies' +17, .12, .04, .60, 2, 40., 100., 60.00, 0.01, 4.0, 35., 'Herbaceous Wetland' +18, .12, .05, .60, 2, 100., 30., 51.93, 0.02, 4.0, 30., 'Wooded Wetland' +19, .12, .01, .01, 1, 999., 999., 999.0, 0.02, 4.0, 69., 'Barren or Sparsely Vegetated' +20, .16, .04, .60, 3, 150., 100., 42.00, 0.025, 4.0, 58., 'Herbaceous Tundra' +21, .16, .06, .60, 3, 150., 100., 42.00, 0.025, 4.0, 55., 'Wooded Tundra' +22, .16, .05, .60, 3, 150., 100., 42.00, 0.025, 4.0, 55., 'Mixed Tundra' +23, .17, .03, .30, 2, 200., 100., 42.00, 0.02, 4.0, 65., 'Bare Ground Tundra' +24, .70, .001, .00, 1, 999., 999., 999.0, 0.02, 4.0, 75., 'Snow or Ice' +25, .30, .01, .50, 1, 40., 100., 36.25, 0.02, 4.0, 69., 'Playa' +26, .16, .15, .00, 0, 999., 999., 999.0, 0.02, 4.0, 69., 'Lava' +27, .60, .01, .00, 0, 999., 999., 999.0, 0.02, 4.0, 69., 'White Sand' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +19 diff --git a/wrfv2_fire/run/grib2map.tbl b/wrfv2_fire/run/grib2map.tbl new file mode 100644 index 00000000..08a1339b --- /dev/null +++ b/wrfv2_fire/run/grib2map.tbl @@ -0,0 +1,344 @@ +# Header section that describes the following GRIB 2 table(s) +# +# Ind | center | subcenter | Master Tbl Version | Local Tbl Version | +#-----+--------+-----------+--------------------+-------------------+ + -1 | 255 | 255 | 1 | 1 | +# +# The table itself +# +# The precision is controlled by the decimal and binary scale factors. +# +# The decimal scale factor is the number of digits after the decimal point +# that are retained. If negative, precision is reduced by 10**dec (i.e., +# -1 would reduce the precision to the nearest factor of 10). +# +# When the decimal scale factor is 0, the binary scale factor indicates the +# precision of the data in bits. +# +# The grib2 docuementation, available from http://, describes the decimal +# and binary scale factors in more detail. +# +# +# +#Dis|Cat|Prm| | |Dec |Bin | +#cip|gor|Num| WRF Id(s) | Description |Fctr|Fctr| +#---+---+---+-----------+------------------------------------------+----+----+ + 0 | 0 | 0 | T2,TSK | Temperature | 2 | 0 | + 0 | 0 | 2 | TH2,THZ0,T| Potential Temperature | 1 | 0 | + 0 | 0 |192| T_INIT | Initial Potential Temperature | 3 | 0 | + 0 | 0 |193| RTHFTEN | Temp. Tendency in Grell Cumulus [K/s] | 6 | 0 | + 0 | 0 |194| T_BASE | Base State T in Idealized Cases [K] | 2 | 0 | + 0 | 0 |195| T_1 | Restart Parameter | 4 | 0 | + 0 | 0 |196| T_2 | Restart Parameter | 4 | 0 | + 0 | 0 |197| H_DIABATIC| Previous Timestep Condensational heating | 7 | 0 | + 0 | 0 |198| RTHCUTEN | Coupled theta tend(cumulus sch)[Pa K s-1]| 3 | 0 | + 0 | 0 |199| RTHRATEN | Coupled theta tend due to radia [Pa K/s] | 3 | 0 | + 0 | 0 |200| RTHRATLW | Coupled theta tend due to lw rad [Pa K/s]| 3 | 0 | + 0 | 0 |201| RTHRATSW | Coupled theta tend due to sw rad [Pa K/s]| 3 | 0 | + 0 | 0 |202| MOL | TStar in Similarity theory [K] | 3 | 0 | + 0 | 0 |203| THC | Thermal Inertia [Cal /(cm K s^.5)] | 3 | 0 | + 0 | 0 |204| RTHBLTEN | Coupled theta tend due to PBL [Pa K/s] | 4 | 0 | + 0 | 1 | 0 | QSFC | Specific Humidity [kg/kg] | 5 | 0 | + 0 | 1 | 2 |QVAPOR,Q2,QVG|Humidity Mixing Ratio [kg/kg] | 5 | 0 | + 0 | 1 | 6 |SFCEVP | Evaporation [kg/m^2] | 3 | 0 | + 0 | 1 | 9 | RAINNC | Large-scale precip (non-conv)[Kg/m^2] | 2 | 0 | + 0 | 1 | 10| RAINC | Convective precipitation [kg/m^2] | 2 | 0 | + 0 | 1 | 13| WEASD,SNOW| Water equivalent of snow depth [kg/m^2] | 2 | 0 | + 0 | 1 | 11|SNOWH,SNOWCU,ACSNOW|Snow depth [m] | 4 | 0 | + 0 | 1 | 22| QCLOUD,QCG| Cloud water mixing ratio [kg/kg] | 6 | 0 | + 0 | 1 | 23| QICE | Ice water mixing ratio [kg/kg] | 5 | 0 | + 0 | 1 | 24| QRAIN | Rain water mixing ratio [kg/kg] | 5 | 0 | + 0 | 1 | 25| QSNOW | Snow water mixing ratio [kg/kg] | 5 | 0 | + 0 | 1 | 32| QGRAUP | Graupel mixing ratio [kg/kg] | 5 | 0 | + 0 | 1 |192| LH | Latent heat flux [W/m^2] | 2 | 0 | + 0 | 1 |193| ACSNOM | Accumulated melted snow [cm] | 2 | 0 | + 0 | 1 |194| RAINNCV | Large-scale precip rate [kg/m^2/s] | 7 | 0 | + 0 | 1 |195| RAINCV | Convective precip rate [kg/m^2/s] | 7 | 0 | + 0 | 1 |196| QFX | Upward moisture flux [kg/m^s] | 6 | 0 | + 0 | 1 |197| HFX | Upward heat flux at the surface [W/m^2] | 1 | 0 | + 0 | 1 |198| QNI | Ice crystal number concentration | 0 | 0 | + 0 | 1 |199| QV_BASE | Base State QV in Idealized Cases | 5 | 0 | + 0 | 1 |200| CT | Countergradient term [K] | 5 | 0 | + 0 | 1 |201| QZ0 | Specific humidity at rough length [kg/kg]| 5 | 0 | + 0 | 1 |202| CUPPT | Acc cnv rain since last call to rad | 4 | 0 | + 0 | 1 |203| F_ICE_PHY | Fraction of Ice (eta mp state variable) | 2 | 0 | + 0 | 1 |204| F_RAIN_PHY| Fraction of Rain (eta mp state variable) | 2 | 0 | + 0 | 1 |205|F_RIMEF_PHY| Mass Ratio of Rimed Ice(eta mp variable) | 2 | 0 | + 0 | 1 |206| RQVCUTEN | Coupled QV tend(cum sch)[Pa kg kg-1 s-1] | 6 | 0 | + 0 | 1 |207| RQRCUTEN | Coupled QR tend(cum sch)[Pa kg kg-1 s-1] | 6 | 0 | + 0 | 1 |208| RQCCUTEN | Coupled QC tend(cum sch)[Pa kg kg-1 s-1] | 6 | 0 | + 0 | 1 |209| RQSCUTEN | Coupled QS tend(cum sch)[Pa kg kg-1 s-1] | 6 | 0 | + 0 | 1 |210| RQICUTEN | Coupled QI tend(cum sch)[Pa kg kg-1 s-1] | 6 | 0 | + 0 | 1 |211| RAINBL | Acc pcp over BL time step [kg/m^2] | 2 | 0 | + 0 | 1 |212| NCA | Counter of cloud relax in KF | 2 | 0 | + 0 | 1 |213| APR_GR | Precip from closure (old grell) [mm/hr] | 4 | 0 | + 0 | 1 |214| APR_W | Precip from closure W [mm/hr] | 4 | 0 | + 0 | 1 |215| APR_MC | Precip from closure Krish MV [mm/hr] | 4 | 0 | + 0 | 1 |216| APR_ST | Precip from closure Stability [mm/hr] | 4 | 0 | + 0 | 1 |217| APR_AS | Precip from closure AS-Type [mm/hr] | 4 | 0 | + 0 | 1 |218| APR_CAPMA | Precip from max CAP [mm/hr] | 4 | 0 | + 0 | 1 |219| APR_CAPME | Precip from mean CAP [mm/hr] | 4 | 0 | + 0 | 1 |220| APR_CAPMI | Precip from min CAP [mm/hr] | 4 | 0 | + 0 | 1 |221| PR_ENS | Precip rate in Grell | 4 | 0 | + 0 | 1 |222| RQVFTEN | Moisture tendency in Grell [kg/s] | 6 | 0 | + 0 | 1 |223| CLDEFI | Precipitation efficiency in BMJ | 4 | 0 | + 0 | 1 |224| RQVBLTEN | Coupled QV tend due to PBL [Pa kg/(kg s)]| 0 | 24 | + 0 | 1 |225| RQCBLTEN | Coupled QC tend due to PBL [Pa kg/(kg s)]| 0 | 24 | + 0 | 1 |226| RQIBLTEN | Coupled QI tend due to PBL [Pa kg/(kg s)]| 0 | 24 | + 0 | 1 |227| FLQC | Surface exchange coefficient for moisture| 6 | 0 | + 0 | 1 |228| QSG | Surface saturation wv mixing ratio[kg/kg]| 6 | 0 | + 0 | 1 |229| MAVAIL | Surface moisture availability | 4 | 0 | + 0 | 2 | 2 | U,U10,UZ0 | U-component of wind [m/s] | 2 | 0 | + 0 | 2 | 3 | V,V10,VZ0 | V-component of wind [m/s] | 2 | 0 | + 0 | 2 | 7 | WW | Sigma coordinate vertical velocity [s^-1]| 3 | 0 | + 0 | 2 | 9 | W | Geometric vertical velocity [m/s] | 4 | 0 | + 0 | 2 |192| U_BASE | Base State X Wind in Idealized Cases | 3 | 0 | + 0 | 2 |193| V_BASE | Base State Y Wind in Idealized Cases | 3 | 0 | + 0 | 2 |194| U_1 | Restart Parameter | 4 | 0 | + 0 | 2 |195| U_2 | Restart Parameter | 4 | 0 | + 0 | 2 |196| V_1 | Restart Parameter | 4 | 0 | + 0 | 2 |197| V_2 | Restart Parameter | 4 | 0 | + 0 | 2 |198| W_1 | Restart Parameter | 0 | 24 | + 0 | 2 |199| W_2 | Restart Parameter | 0 | 24 | + 0 | 2 |200| SFCEXC | Exchange coefficient [m/s] | 5 | 0 | + 0 | 2 |201| AKHS | Sfc exchange coefficient for heat [m/s] | 5 | 0 | + 0 | 2 |202| AKMS | Sfc exch coefficient for momentum [m/s] | 3 | 0 | + 0 | 2 |203| W0AVG | Average VV for KF Cum Scheme [m/s] | 6 | 0 | + 0 | 2 |204| MASS_FLUX | Downdraft mass flux in grell [mb/hr] | 4 | 0 | + 0 | 2 |205| RUBLTEN | Coupled X-wind tend due to PBL [Pa m/s^2]| 2 | 0 | + 0 | 2 |206| RVBLTEN | Coupled X-wind tend due to PBL [Pa m/s^2]| 2 | 0 | + 0 | 2 |207| UST | UStar in Similarity theory [m/s] | 4 | 0 | + 0 | 2 |208| FLHC | Surface exchange coefficient for heat | 3 | 0 | + 0 | 3 | 0 | P,PSFC | Pressure [Pa] | 1 | 0 | + 0 | 3 | 1 | PMSL | Pressure reduced to MSL [Pa] | 1 | 0 | + 0 | 3 | 4 | PHP | Geopotential [m^2/s^2] | 3 | 0 | + 0 | 3 |192| PHB | Base-state geopotential [m^2/s^2] | 0 | 0 | + 0 | 3 |193| PH | Perturbation geopotential [m^2/s^2] | 1 | 0 | + 0 | 3 |194| MUB | Base-state dry air mass in column [Pa] | 1 | 0 | + 0 | 3 |195| MU | Perturbation dry air mass in column [Pa] | 1 | 0 | + 0 | 3 |196| MU0 | Initial dry air mass in column [Pa] | 0 | 0 | + 0 | 3 |197| PB | Base-state pressure [Pa] | 0 | 0 | + 0 | 3 |198| GRDFLX | Ground heat flux [W/m^2] | 1 | 0 | + 0 | 3 |199| Z_BASE | Base State Height in Idealized Cases | 5 | 0 | + 0 | 3 |200| PH_1 | Restart Parameter | 3 | 0 | + 0 | 3 |201| PH_2 | Restart Parameter | 3 | 0 | + 0 | 3 |202| PH0 | Initial geopotential | 1 | 0 | + 0 | 3 |203| MU_1 | Restart Parameter | 3 | 0 | + 0 | 3 |204| MU_2 | Restart Parameter | 3 | 0 | + 0 | 3 |205| AL | Inverse perturbation density [m3 kg-1] | 5 | 0 | + 0 | 3 |206| ALT | Inverse density [m3 kg-1] | 4 | 0 | + 0 | 3 |207| XF_ENS | Mass flux PDF in GRELL | 4 | 0 | + 0 | 4 | 0 | GSW | Net short wave flux [W/m^2] | 3 | 0 | + 0 | 4 |192| SWDOWN | Downward short wave flux [W/m^2] | 1 | 0 | + 0 | 4 |193| TOTSWDN | Radiation State Variable | 2 | 0 | + 0 | 4 |194| RSWTOA | Radiation State Variable | 4 | 0 | + 0 | 4 |195| RLWTOA | Radiation State Variable | 4 | 0 | + 0 | 4 |196| CZMEAN | Radiation State Variable | 4 | 0 | + 0 | 4 |197| CFRACL | Radiation State Variable | 4 | 0 | + 0 | 4 |198| CFRACM | Radiation State Variable | 4 | 0 | + 0 | 4 |199| CFRACH | Radiation State Variable | 4 | 0 | + 0 | 4 |200| ACFRST | Radiation State Variable | 4 | 0 | + 0 | 4 |201| NCFRST | Radiation State Variable | 4 | 0 | + 0 | 4 |202| ACFRCV | Radiation State Variable | 4 | 0 | + 0 | 4 |203| NCFRCV | Radiation State Variable | 4 | 0 | + 0 | 5 | 0 | GLW | Net long wave flux [W/m^2] | 2 | 0 | + 0 | 5 |193| TOTLWDN | Radiation State Variable | 4 | 0 | + 0 | 6 | 1 | CLDFRA | Total Cloud Cover [%] | 2 | 0 | + 0 | 6 |192| TAUCLDI | Cloud optical thickness for ice | 2 | 0 | + 0 | 6 |193| TAUCLDC | Cloud optical thickness for water | 2 | 0 | + 0 | 13|192|MASS_AER_WATER| aerosol liquid water content | 6 | 0 | + 0 | 13|193|MASS_AER_DRY| dry aerosol mass | 6 | 0 | + 0 | 19| 1| ALBEDO | Albedo [%] | 2 | 0 | + 0 | 19| 11|TKE,TKE_MYJ| Turbulent Kinetic Energy [J/kg] | 3 | 0 | + 0 | 19|192| ALBBCK | Background Albedo [%] | 4 | 0 | + 0 | 19|193| TKE_1 | Restart Parameter | 3 | 0 | + 0 | 19|194| TKE_2 | Restart Parameter | 3 | 0 | + 0 |191|192| CFN | CFN from WRF [?] | 3 | 0 | + 0 |191|193| CFN1 | CFN1 from WRF [?] | 3 | 0 | + 0 |191|194| ZNU | Eta values on half (mass) levels | 6 | 0 | + 0 |191|195| ZNW | Eta values on full (w) levels | 6 | 0 | + 0 |191|196| DN | DN values [dimensionless] | 4 | 0 | + 0 |191|197| DNW | DNW values [dimensionless] | 4 | 0 | + 0 |191|198| RDN | Inverse DN values [dimensionless] | 3 | 0 | + 0 |191|199| RDNW | Inverse d(eta) values for full (w) levels| 3 | 0 | + 0 |191|200| FNP | Lower weight for vertical strection [dim]| 5 | 0 | + 0 |191|201| FNM | Upper weight for vertical strection [dim]| 5 | 0 | + 0 |191|202| MAPFAC_M | Map Scale Factor [dimensionless] | 4 | 0 | + 0 |191|203| MAPFAC_U | Map Scale Factor [dimensionless] | 4 | 0 | + 0 |191|204| MAPFAC_V | Map Scale Factor [dimensionless] | 4 | 0 | + 0 |191|205| F | Coriolis sine latitude term | 6 | 0 | + 0 |191|206| E | Coriolis cosine latitude term | 6 | 0 | + 0 |191|207| PBLH | Planetary boundary layer height [m] | 0 | 0 | + 0 |191|208| ZS | Depths of centers of soil layers [m] | 3 | 0 | + 0 |191|209| DZS | Thicknesses of soil layers [m] | 3 | 0 | + 0 |191|210| XLAT | Latitude [deg] | 4 | 0 | + 0 |191|211| XLONG | Longitude [deg] | 4 | 0 | + 0 |191|212| COSALPHA | Local cosine of map rotation | 6 | 0 | + 0 |191|213| SINALPHA | Local sine of map rotation | 6 | 0 | + 0 |191|214| NEST_POS | Nest Position | 0 | 0 | + 0 |191|215| ALB | Restart Parameter (??) | 4 | 0 | + 0 |191|216| EXCH_H | Exchange coefficients | 3 | 0 | + 0 |191|217| KPBL | Level of PBL top [m] | 1 | 0 | + 0 |191|218| HTOP | Top of convection level | 1 | 0 | + 0 |191|219| HBOT | Bottom of convection level | 1 | 0 | + 0 |191|220| TKESFCF | TKE at the surface [m^/s^2] | 3 | 0 | + 0 |191|253|WRF_SCALAR | Scalar Output data in local section | 0 | 0 | + 0 |191|254|WRF_GLOBAL | Global Output data in local section | 0 | 0 | + 0 |192| 1 | U_BXS | | 0 | 0 | + 0 |192| 2 | U_BXE | | 0 | 0 | + 0 |192| 3 | U_BYS | | 0 | 0 | + 0 |192| 4 | U_BYE | | 0 | 0 | + 0 |192| 5 | U_BTXS | | 2 | 0 | + 0 |192| 6 | U_BTXE | | 2 | 0 | + 0 |192| 7 | U_BTYS | | 2 | 0 | + 0 |192| 8 | U_BTYE | | 2 | 0 | + 0 |192| 9 | V_BXS | | 0 | 0 | + 0 |192| 10| V_BXE | | 0 | 0 | + 0 |192| 11| V_BYS | | 0 | 0 | + 0 |192| 12| V_BYE | | 0 | 0 | + 0 |192| 13| V_BTXS | | 2 | 0 | + 0 |192| 14| V_BTXE | | 2 | 0 | + 0 |192| 15| V_BTYS | | 2 | 0 | + 0 |192| 16| V_BTYE | | 2 | 0 | + 0 |192| 17| W_BXS | | 4 | 0 | + 0 |192| 18| W_BXE | | 4 | 0 | + 0 |192| 19| W_BYS | | 4 | 0 | + 0 |192| 20| W_BYE | | 4 | 0 | + 0 |192| 21| W_BTXS | | 5 | 0 | + 0 |192| 22| W_BTXE | | 5 | 0 | + 0 |192| 23| W_BTYS | | 5 | 0 | + 0 |192| 24| W_BTYE | | 5 | 0 | + 0 |192| 25| PH_BXS | | -2 | 0 | + 0 |192| 26| PH_BXE | | -2 | 0 | + 0 |192| 27| PH_BYS | | -2 | 0 | + 0 |192| 28| PH_BYE | | -2 | 0 | + 0 |192| 29| PH_BTXS | | 0 | 0 | + 0 |192| 30| PH_BTXE | | 0 | 0 | + 0 |192| 31| PH_BTYS | | 0 | 0 | + 0 |192| 32| PH_BTYE | | 0 | 0 | + 0 |192| 33| T_BXS | | -1 | 0 | + 0 |192| 34| T_BXE | | -1 | 0 | + 0 |192| 35| T_BYS | | -1 | 0 | + 0 |192| 36| T_BYE | | -1 | 0 | + 0 |192| 37| T_BTXS | | 2 | 0 | + 0 |192| 38| T_BTXE | | 2 | 0 | + 0 |192| 39| T_BTYS | | 2 | 0 | + 0 |192| 40| T_BTYE | | 2 | 0 | + 0 |192| 41| MU_BXS | | 2 | 0 | + 0 |192| 42| MU_BXE | | 2 | 0 | + 0 |192| 43| MU_BYS | | 2 | 0 | + 0 |192| 44| MU_BYE | | 4 | 0 | + 0 |192| 45| MU_BTXS | | 4 | 0 | + 0 |192| 46| MU_BTXE | | 4 | 0 | + 0 |192| 47| MU_BTYS | | 4 | 0 | + 0 |192| 48| MU_BTYE | | 4 | 0 | + 0 |192| 49| QVAPOR_BXS| | 1 | 0 | + 0 |192| 50| QVAPOR_BXE| | 1 | 0 | + 0 |192| 51| QVAPOR_BYS| | 1 | 0 | + 0 |192| 52| QVAPOR_BYE| | 1 | 0 | + 0 |192| 53|QVAPOR_BTXS| | 6 | 0 | + 0 |192| 54|QVAPOR_BTXE| | 6 | 0 | + 0 |192| 55|QVAPOR_BTYS| | 6 | 0 | + 0 |192| 56|QVAPOR_BTYE| | 6 | 0 | + 0 |192| 57| QCLOUD_BXS| | 1 | 0 | + 0 |192| 58| QCLOUD_BXE| | 1 | 0 | + 0 |192| 59| QCLOUD_BYS| | 1 | 0 | + 0 |192| 60| QCLOUD_BYE| | 1 | 0 | + 0 |192| 61|QCLOUD_BTXS| | 7 | 0 | + 0 |192| 62|QCLOUD_BTXE| | 7 | 0 | + 0 |192| 63|QCLOUD_BTYS| | 7 | 0 | + 0 |192| 64|QCLOUD_BTYE| | 7 | 0 | + 0 |192| 65| QRAIN_BXS | | 1 | 0 | + 0 |192| 66| QRAIN_BXE | | 1 | 0 | + 0 |192| 67| QRAIN_BYS | | 1 | 0 | + 0 |192| 68| QRAIN_BYE | | 1 | 0 | + 0 |192| 69| QRAIN_BTXS| | 7 | 0 | + 0 |192| 70| QRAIN_BTXE| | 7 | 0 | + 0 |192| 71| QRAIN_BTYS| | 7 | 0 | + 0 |192| 72| QRAIN_BTYE| | 7 | 0 | + 0 |192| 73| QICE_BXS | | 2 | 0 | + 0 |192| 74| QICE_BXE | | 2 | 0 | + 0 |192| 75| QICE_BYS | | 2 | 0 | + 0 |192| 76| QICE_BYE | | 2 | 0 | + 0 |192| 77| QICE_BTXS | | 7 | 0 | + 0 |192| 78| QICE_BTXE | | 7 | 0 | + 0 |192| 79| QICE_BTYS | | 7 | 0 | + 0 |192| 80| QICE_BTYE | | 7 | 0 | + 0 |192| 81| QSNOW_BXS | | 2 | 0 | + 0 |192| 82| QSNOW_BXE | | 2 | 0 | + 0 |192| 83| QSNOW_BYS | | 2 | 0 | + 0 |192| 84| QSNOW_BYE | | 2 | 0 | + 0 |192| 85| QSNOW_BTXS| | 7 | 0 | + 0 |192| 86| QSNOW_BTXE| | 7 | 0 | + 0 |192| 87| QSNOW_BTYS| | 7 | 0 | + 0 |192| 88| QSNOW_BTYE| | 7 | 0 | + 0 |192| 89| QGRAUP_BXS| | 2 | 0 | + 0 |192| 90| QGRAUP_BXE| | 2 | 0 | + 0 |192| 91| QGRAUP_BYS| | 2 | 0 | + 0 |192| 92| QGRAUP_BYE| | 2 | 0 | + 0 |192| 93|QGRAUP_BTXS| | 7 | 0 | + 0 |192| 94|QGRAUP_BTXE| | 7 | 0 | + 0 |192| 95|QGRAUP_BTYS| | 7 | 0 | + 0 |192| 96|QGRAUP_BTYE| | 7 | 0 | + 0 |192| 97| QNICE_BXS | | 4 | 0 | + 0 |192| 98| QNICE_BXE | | 4 | 0 | + 0 |192| 99| QNICE_BYS | | 4 | 0 | + 0 |192|100| QNICE_BYE | | 4 | 0 | + 0 |192|101| QNICE_BTXS| | 7 | 0 | + 0 |192|102| QNICE_BTXE| | 7 | 0 | + 0 |192|103| QNICE_BTYS| | 7 | 0 | + 0 |192|104| QNICE_BTYE| | 7 | 0 | + 0 |193|192| FCX | Relaxation term for boundary zone | 4 | 0 | + 0 |193|193| GCX | 2nd Relaxation term for boundary zone | 4 | 0 | + 0 |193|194|MP_RESTART_STATE|state vect for microphysics restarts | 4 | 0 | + 0 |193|195|TBPVS_STATE| state for etampnew microphysics | 4 | 0 | + 0 |193|196|TBPVS0_STATE| state for etampnew microphysics | 4 | 0 | + 1 | 0 | 1 | SFROFF | Storm surface runoff [kg/m^2] | 4 | 0 | + 1 | 0 |192| SOILT1 | Temperature inside snow | 2 | 0 | + 1 | 0 |193| TSNAV | Average snow temperature | 2 | 0 | + 1 | 0 |194| UDROFF | Baseflow-groundwater runoff [kg/m^2] | 4 | 0 | + 2 | 0 | 0 | LANDMASK | Land Cover (1=land,2=sea) | 1 | 0 | + 2 | 0 | 1 | ZNT | Time Varying Roughness length [m] | 6 | 0 | + 2 | 0 | 4 | VEGFRA | Vegetation [%] | 1 | 0 | + 2 | 0 | 7 |HGT,SOILHGT,DIST| Terrain Height [m] | 2 | 0 | + 2 | 0 |192| LU_INDEX | Land Use Index [Cat] | 1 | 0 | + 2 | 0 |193| CANWAT | Plant Canopy Surface Water [kg/m^2] | 4 | 0 | + 2 | 0 |194| SNOWC | Snow cover [%] | 1 | 0 | + 2 | 0 |195| XLAND | Land cover (land=1; sea=0) [fraction] | 1 | 0 | + 2 | 0 |196| TOPOSTDV | Standard Deviation of topography | 3 | 0 | + 2 | 0 |197| TOPOSLPX | Sub-gridscale mean topographic slope | 6 | 0 | + 2 | 0 |198| TOPOSLPY | Sub-gridscale mean topographic slope | 6 | 0 | + 2 | 0 |199| SLOPECAT | Topographical Categorical Slope | 1 | 0 | + 2 | 0 |200| LANDUSEF | Land use categorical fraction on mass gr | 3 | 0 | + 2 | 0 |201| SOILCTOP | Top layer soil type as a categ. fraction | 3 | 0 | + 2 | 0 |202| SOILCBOT | Bot layer soil type as a categ. fraction | 3 | 0 | + 2 | 0 |203| RMOL | 1./Monin Ob. Length [dimensionless] | 2 | 0 | + 2 | 0 |204| SHDMAX | Annual MAX veg fraction | 3 | 0 | + 2 | 0 |205| SHDMIN | Annual MIN veg fraction | 3 | 0 | + 2 | 0 |206| Z0 | Background Roughness length [m] | 6 | 0 | + 2 | 0 |207| EMISS | Surface Emissivity | 4 | 0 | + 2 | 3 | 0 | ISLTYP | Soil Type | 1 | 0 | + 2 | 3 | 1 |TSLB,ST000010,ST010040,ST040100,ST100200|Soil Temperature|1| 0 | + 2 | 3 | 2 | SMSTOT | Soil Moisture content [kg/m^2] | 3 | 0 | + 2 | 3 | 4 | TMN | Ground Reservoir Temperature | 1 | 0 | + 2 | 3 |192| SOILW | Volumetric soil moisture [fraction] | 4 | 0 | + 2 | 3 |193| SOILL | Liquid volumetric soil moisture[fraction]| 4 | 0 | + 2 | 3 |194| SMSTAV | Moisture availability [%] | 4 | 0 | + 2 | 3 |195| IVGTYP | Vegetation type | 1 | 0 | + 2 | 3 |196| SOILCAT | Soil Category | 1 | 0 | + 2 | 3 |197| VEGCAT | Vegetation Category | 1 | 0 | + 2 | 3 |198| SH2O | Soil liquid water [m^3/m^3] | 3 | 0 | + 2 | 3 |199| SMOIS | Soil moisture [m^3/m^3] | 3 | 0 | + 2 | 3 |200| SNOALB | Annual MAX snow albedor in fraction | 4 | 0 | + 2 | 3 |201| SMFR3D | Soil Ice | 2 | 0 | + 2 | 3 |202|KEEPFR3DFLAG| Flag - 1. Forzen Soil Yes, 0 - NO | 1 | 0 | + 2 | 3 |203| CAPG | Heat capacity for soil [j /(K m^3)] | 0 | 0 | + 10 | 2 | 0 | XICE | Ice Concentration [fraction] | 1 | 0 | + 10 | 3 | 0 | SST | Temperature | 2 | 0 | +# +# Ind | center | subcenter | Master Tbl Version | Local Tbl Version | +#-----+--------+-----------+--------------------+-------------------+ + -1 | 252 | 255 | 1 | 1 | +# +# Another table could go here. +# diff --git a/wrfv2_fire/run/gribmap.txt b/wrfv2_fire/run/gribmap.txt new file mode 100644 index 00000000..2c84150c --- /dev/null +++ b/wrfv2_fire/run/gribmap.txt @@ -0,0 +1,1799 @@ +-1:255:255:2 +0:var0:undefined:: +1:PRES:Pressure [Pa]:P,PSFC:2 +2:PRMSL:Pressure reduced to MSL [Pa]:PMSL:2 +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:PHP:3 +7:HGT:Geopotential height [gpm]:SOILHGT:2 +8:DIST:Geometric height [m]:HGT:4 +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:T2,TSK,SKINTEMP:2 +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:TH2,THZ0,T:4 +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:U,U10,UZ0:3 +34:VGRD:v wind [m/s]:V,V10,VZ0:3 +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:WW:5 +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:W:5 +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:QSFC:5 +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:QVAPOR,Q2,QVG:6 +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:SFCEVP:3 +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:NCPCP:2 +63:ACPCP:Convective precipitation [kg/m^2]:ACPCP:2 +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:WEASD:2 +66:SNOD:Snow depth [m]:SNOWH:4 +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:CLDFRA:2 +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:SST:2 +81:LAND:Land cover (land=1;sea=0) [fraction]:LANDMASK:1 +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:ZNT:6 +84:ALBDO:Albedo [%]:ALBEDO:2 +85:TSOIL:Soil temp. [K]:TSLB:2 +86:SOILM:Soil moisture content [kg/m^2]:SMSTOT:2 +87:VEG:Vegetation [%]:VEGFRA:2 +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:XICE:1 +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:LH:4 +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:MSLSA:Mean sea level pressure (Std Atm) [Pa]:: +129:MSLMA:Mean sea level pressure (MAPS) [Pa]:: +130:LU_INDEX:Land Use Category:LU_INDEX:1 +131:DN:DNW values [dimensionless]:DNW:4 +132:SOILW:Volumetric soil moisture [fraction]:SMOIS:4 +133:XLAND:Land cover (land=1;sea=0) [fraction]:XLAND:1 +134:ZNW:Eta values [dimensionless]:ZNW:4 +135:GP_BASE:Base-state geopotential [m^2/s^2]:PHB:3 +136:GP_PERT:Perturbation geopotential [m^2/s^2]:PH:4 +137:CFN:CFN from WRF [?]:CFN:3 +138:CFN:CFN1 from WRF [?]:CFN1:3 +139:MU_BASE:Base-state dry air mass in column [Pa]:MUB:2 +140:MU_PERT:Perturbation dry air mass in column [Pa]:MU:2 +141:MU_INIT:Initial dry air mass in column [Pa]:MU0:2 +142:P_BASE:Base-state pressure [Pa]:PB:2 +143:DN:DN values [dimensionless]:DN:4 +144:SOILW:Volumetric soil moisture [fraction]:SMOIS:4 +145:RDNW:Inverse DNW values [dimensionless]:RDNW:3 +146:RDN:Inverse DN values [dimensionless]:RDN:3 +147:FNP:Lower weight for vertical stretching [dimensionless]:FNP:3 +148:FNM:Upper weight for vertical stretching [dimensionless]:FNM:3 +149:ZNU:Eta values [dimensionless]:ZNU:4 +150:ZETATOP:ZETA at model top [dimensionless]:ZETATOP:3 +151:PTOP:Pressure at model top [Pa]:P_TOP:3 +152:TIMESTEP:Timestep number:ITIMESTEP:3 +153:CLWMR:Cloud water [kg/kg]:QCLOUD,QCG:8 +154:var154:undefined:: +155:GFLUX:Ground heat flux [W/m^2]:HFX:4 +156:RAINBL:Acc. precip. over Boundary Layer time step [kg/m^2]:RAINBL:2 +157:var157:undefined:: +158:TKE:Turbulent kinetic energy [J/kg]:TKE:3 +159:TKE_MYJ:MYJ Turbulent kinetic energy [J/kg]:TKE_MYJ:3 +160:SOILL:Liquid volumetric soil moisture (non-frozen) [fraction]:SH2O:6 +161:var157:undefined:: +162:var157:undefined:: +163:var157:undefined:: +164:var157:undefined:: +165:var157:undefined:: +166:var157:undefined:: +167:var157:undefined:: +168:var157:undefined:: +169:var157:undefined:: +170:RWMR:Rain water mixing ratio [kg/kg]:QRAIN:5 +171:SNMR:Snow mixing ratio [kg/kg]:QSNOW:5 +172:RESM:Time weight constant for small steps:RESM:3 +173:RDX:Inverse X Grid Length [1/km]:RDX:9 +174:RDY:Inverse Y Grid Length [1/km]:RDY:9 +175:MLYNO:Model layer number (from bottom up) [non-dim]:NEST_POS: +176:NLAT:Latitude (-90 to +90) [deg]:XLAT:4 +177:ELON:East longitude (0-360) [deg]:XLONG:4 +178:ICMR:Ice mixing ratio [kg/kg]:QICE:5 +179:GRMR:Graupel mixing ratio:QGRAUP:5 +180:QNI:Ice Crystal Number Concentration:QNI:0 +181:ZS:Depth of soil layer (midpoint) [m]:ZS:3 +182:DZS:Thickness of soil layer [m]:DZS:3 +183:SINALPHA:Local sine of map rotation:SINALPHA:4 +184:COSALPHA:Local cosine of map rotation:COSALPHA:4 +185:TURB:Turbulence SIGMET/AIRMET [non-dim]:: +186:EPSTS:EPSTS in WRF [?]:EPSTS:3 +187:var187:undefined:: +188:AKMS:Surface Exchange for Momentum [m/s]:AKMS:3 +189:MAPFAC_M:Map Scale Factor [dimensionless]:MAPFAC_M:7 +190:MAPFAC_U:Map Scale Factor [dimensionless]:MAPFAC_U:7 +191:MAPFAC_V:Map Scale Factor [dimensionless]:MAPFAC_V:7 +192:GRDFLX:Ground Heat Flux [W m-2]:GRDFLX:3 +193:RMOL:Reciprical of Monin-Ohukhov length:RMOL:4 +194:var194:undefined:: +195:var195:undefined:: +196:var196:undefined:: +197:var197:undefined:: +198:var198:undefined:: +199:var199:undefined:: +200:var200:undefined:: +201:var201:undefined:: +202:SNOWCU:Cumulative Snow [cm]:SNOWCU,ACSNOW:2 +203:ACSNOM:Accumulated Melted Snow [cm]:ACSNOM:2 +204:DSWRF:Downward short wave flux [W/m^2]:SWDOWN:3 +205:DLWRF:Downward long wave flux [W/m^2]:GLW:3 +206:GSW:Net short wave flux [w/m^2]:GSW:3 +207:MSTAV:Moisture availability [%]:SMSTAV:4 +208:SFEXC:Exchange coefficient [m/s]:SFCEXC:5 +209:AKHS:Exchange coefficient for heat [m/s]:AKHS:5 +210:SOILCAT:Soil Category:SOILCAT:1 +211:VEGCAT:Vegetation Categore:VEGCAT:1 +212:TOPOSTDV:Standard Deviation of Topography:TOPOSTDV:3 +213:TOPOSLPX:Sub-gridscale mean topographic slope in x-direction:TOPOSLPX:6 +214:TOPOSLPY:Sub-gridscale mean topographic slope in y-direction:TOPOSLPY:6 +215:SLOPECAT:Topographical Categorical Slope:SLOPECAT:1 +216:LANDUSEF:Land use categorical fraction on mass grid:LANDUSEF:3 +217:SOILCTOP:Top layer soil type as a categorical fraction:SOILCTOP:3 +218:SOILCBOT:Top layer soil type as a categorical fraction:SOILCBOT:3 +219:var219:undefined:: +220:var220:undefined:: +221:HPBL:Planetary boundary layer height [m]:PBLH:2 +222:var222:undefined:: +223:CNWAT:Plant canopy surface water [kg/m^2]:CANWAT:8 +224:SOTYP:Soil type (Zobler) [0..9]:ISLTYP:0 +225:VGTYP:Vegetation type (as in SiB) [0..13]:IVGTYP:1 +226:var226:undefined:: +227:CSLAT:Coriolis sine latitude term:F:6 +228:CCLAT:Coriolis cosine latitude term:E:6 +229:CF1:Second-order extrapolation constant 1:CF1:5 +230:CF2:Second-order extrapolation constant 2:CF2:5 +231:CF3:Second-order extrapolation constant 3:CF3:5 +232:var232:undefined:: +233:var233:undefined:: +234:BGRUN:Baseflow-groundwater runoff [kg/m^2]:UDROFF:4 +235:SSRUN:Storm surface runoff [kg/m^2]:SFROFF:4 +236:SNOW:Snow Water Equivalent [kg/m^2]:SNOW:2 +237:var237:undefined:: +238:SNOWC:Snow cover [%]:SNOWC:1 +239:var239:undefined:: +240:QFX:Upward moisture flux [kg/(m^s)]:QFX:8 +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:NPRATE:Non-convective Precip Rate[kg/m^2/s]:RAINNCV:7 +248:CPRATE:Convective Precip Rate[kg/m^2/s]:RAINCV:7 +249:TMN:Ground Reservoir Temperature [K]:TMN:3 +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:TNCPCP:Cumulative Large scale precipitation [kg/m^2]:RAINNC:3 +254:TACPCP:Cumulative Convective precipitation [kg/m^2]:RAINC:3 +255:var255:undefined:: +-1:255:255:3 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:STEP_NUMBER::STEP_NUMBER:1 +129:DTS:Small Timestep:DTS:1 +130:DTSEPS:Time Weight Constant for Small Steps:DTSEPS:1 +131:FCX:Relaxation Term for Boundary Zone:FCX:5 +132:GCX:Second relaxation term for boundary Zone:GCX:5 +133:DTBC:Time since boundary read:DTBC:1 +134:SHDMAX:Annual MAX veg fraction:SHDMAX:4 +135:SHDMIN:Annual MIN veg fraction:SHDMIN:4 +136:SNOALB:Annual MAX snow albedor in fraction:SNOALB:4 +137:FNDSNOWH::FNDSNOWH:1 +138:TOTSWDN:Radiation State Variable:TOTSWDN:4 +139:TOTLWDN:Radiation State Variable:TOTLWDN:4 +140:RSWTOA:Radiation State Variable:RSWTOA:4 +141:RLWTOA:Radiation State Variable:RLWTOA:4 +142:CZMEAN:Radiation State Variable:CZMEAN:4 +143:CFRACL:Radiation State Variable:CFRACL:4 +144:CFRACM:Radiation State Variable:CFRACM:4 +145:CFRACH:Radiation State Variable:CFRACH:4 +146:ACFRST:Radiation State Variable:ACFRST:4 +147:NCFRST:Radiation State Variable:NCFRST:4 +148:ACFRCV:Radiation State Variable:ACFRCV:4 +149:NCFRCV:Radiation State Variable:NCFRCV:4 +150:FNDSOILW::FNDSOILW:1 +151:U_FRAME:FRAME X WIND [m/s]:U_FRAME:4 +152:V_FRAME:FRAME Y WIND [m/s]:V_FRAME:4 +153:ALBBCK:Background Albedo:ALBBCK:4 +154:U_BASE:Base State X Wind in Idealized Cases:U_BASE:3 +155:V_BASE:Base State Y Wind in Idealized Cases:V_BASE:3 +156:QV_BASE:Base State QV in Idealized Cases:QV_BASE:5 +157:Z_BASE:Base State Height in Idealized Cases:Z_BASE:5 +158:T_BASE:Base State T in Idealized Cases:T_BASE:2 +159:var159:undefined:: +160:TSOIL1:Soil temp. 0-10 cm [K]:ST000010:2 +161:TSOIL2:Soil temp. 10-40 cm [K]:ST010040:2 +162:TSOIL3:Soil temp. 40-100 cm [K]:ST040100:2 +163:TSOIL4:Soil temp. 100-200 cm [K]:ST100200:2 +164:SOILM1:Soil moisture content 0-10 cm [kg/m^2]:SM000010:2 +165:SOILM2:Soil moisture content 10-40 cm [kg/m^2]:SM010040:2 +166:SOILM3:Soil moisture content 40-100 cm [kg/m^2]:SM040100:2 +167:SOILM4:Soil moisture content 100-200 cm [kg/m^2]:SM100200:2 +168:var168:undefined:: +169:var169:undefined:: +170:var170:undefined:: +171:var171:undefined:: +172:var172:undefined:: +173:var173:undefined:: +174:var174:undefined:: +175:var175:undefined:: +176:var176:undefined:: +177:var177:undefined:: +178:var178:undefined:: +179:var179:undefined:: +180:var180:undefined:: +181:var181:undefined:: +182:var182:undefined:: +183:var183:undefined:: +184:var184:undefined:: +185:var185:undefined:: +186:var186:undefined:: +187:var187:undefined:: +188:var188:undefined:: +189:var189:undefined:: +190:var190:undefined:: +191:var191:undefined:: +192:var192:undefined:: +193:var193:undefined:: +194:var194:undefined:: +195:var195:undefined:: +196:var196:undefined:: +197:var197:undefined:: +198:var198:undefined:: +199:var199:undefined:: +200:var200:undefined:: +201:var201:undefined:: +202:var202:undefined:: +203:var203:undefined:: +204:var204:undefined:: +205:var205:undefined:: +206:var206:undefined:: +207:var207:undefined:: +208:var208:undefined:: +209:var209:undefined:: +210:var210:undefined:: +211:var211:undefined:: +212:var212:undefined:: +213:var213:undefined:: +214:var214:undefined:: +215:var215:undefined:: +216:var216:undefined:: +217:var217:undefined:: +218:var218:undefined:: +219:var219:undefined:: +220:var220:undefined:: +221:var221:undefined:: +222:var222:undefined:: +223:LAT_LL_T:Lower Left Latitude of temp point [deg]:LAT_LL_T:4 +224:LAT_UL_T:Lower Left Latitude of temp point [deg]:LAT_UL_T:4 +225:LAT_UR_T:Lower Left Latitude of temp point [deg]:LAT_UR_T:4 +226:LAT_LR_T:Lower Left Latitude of temp point [deg]:LAT_LR_T:4 +227:LAT_LL_U:Lower Left Latitude of u point [deg]:LAT_LL_U:4 +228:LAT_UL_U:Lower Left Latitude of u point [deg]:LAT_UL_U:4 +229:LAT_UR_U:Lower Left Latitude of u point [deg]:LAT_UR_U:4 +230:LAT_LR_U:Lower Left Latitude of u point [deg]:LAT_LR_U:4 +231:LAT_LL_V:Lower Left Latitude of v point [deg]:LAT_LL_V:4 +232:LAT_UL_V:Lower Left Latitude of v point [deg]:LAT_UL_V:4 +233:LAT_UR_V:Lower Left Latitude of v point [deg]:LAT_UR_V:4 +234:LAT_LR_V:Lower Left Latitude of v point [deg]:LAT_LR_V:4 +235:LAT_LL_D:Lower Left Latitude of massless point [deg]:LAT_LL_D:4 +236:LAT_UL_D:Lower Left Latitude of massless point [deg]:LAT_UL_D:4 +237:LAT_UR_D:Lower Left Latitude of massless point [deg]:LAT_UR_D:4 +238:LAT_LR_D:Lower Left Latitude of massless point [deg]:LAT_LR_D:4 +239:LON_LL_T:Lower Left Longitude of temp point [deg]:LON_LL_T:4 +240:LON_UL_T:Lower Left Longitude of temp point [deg]:LON_UL_T:4 +241:LON_UR_T:Lower Left Longitude of temp point [deg]:LON_UR_T:4 +242:LON_LR_T:Lower Left Longitude of temp point [deg]:LON_LR_T:4 +243:LON_LL_U:Lower Left Longitude of u point [deg]:LON_LL_U:4 +244:LON_UL_U:Lower Left Longitude of u point [deg]:LON_UL_U:4 +245:LON_UR_U:Lower Left Longitude of u point [deg]:LON_UR_U:4 +246:LON_LR_U:Lower Left Longitude of u point [deg]:LON_LR_U:4 +247:LON_LL_V:Lower Left Longitude of v point [deg]:LON_LL_V:4 +248:LON_UL_V:Lower Left Longitude of v point [deg]:LON_UL_V:4 +249:LON_UR_V:Lower Left Longitude of v point [deg]:LON_UR_V:4 +250:LON_LR_V:Lower Left Longitude of v point [deg]:LON_LR_V:4 +251:LON_LL_D:Lower Left Longitude of massless point [deg]:LON_LL_D:4 +252:LON_UL_D:Lower Left Longitude of massless point [deg]:LON_UL_D:4 +253:LON_UR_D:Lower Left Longitude of massless point [deg]:LON_UR_D:4 +254:LON_LR_D:Lower Left Longitude of massless point [deg]:LON_LR_D:4 +255:var255:undefined:: +-1:255:255:4 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:RU_BXS::RU_BXS:1 +129:RU_BXE::RU_BXE:1 +130:RU_BYS::RU_BYS:1 +131:RU_BYE::RU_BYE:1 +132:RU_BTXS::RU_BTXS:6 +133:RU_BTXE::RU_BTXE:6 +134:RU_BTYS::RU_BTYS:6 +135:RU_BTYE::RU_BTYE:6 +136:RV_BXS::RV_BXS:1 +137:RV_BXE::RV_BXE:1 +138:RV_BYS::RV_BYS:1 +139:RV_BYE::RV_BYE:1 +140:RV_BTXS::RV_BTXS:6 +141:RV_BTXE::RV_BTXE:6 +142:RV_BTYS::RV_BTYS:6 +143:RV_BTYE::RV_BTYE:6 +144:RW_BXS::RW_BXS:1 +145:RW_BXE::RW_BXE:1 +146:RW_BYS::RW_BYS:1 +147:RW_BYE::RW_BYE:1 +148:RW_BTXS::RW_BTXS:6 +149:RW_BTXE::RW_BTXE:6 +150:RW_BTYS::RW_BTYS:6 +151:RW_BTYE::RW_BTYE:6 +152:PH_BXS::PH_BXS:-1 +153:PH_BXE::PH_BXE:-1 +154:PH_BYS::PH_BYS:-1 +155:PH_BYE::PH_BYE:-1 +156:PH_BTXS::PH_BTXS:4 +157:PH_BTXE::PH_BTXE:4 +158:PH_BTYS::PH_BTYS:4 +159:PH_BTYE::PH_BTYE:4 +160:T_BXS::T_BXS:1 +161:T_BXE::T_BXE:1 +162:T_BYS::T_BYS:1 +163:T_BYE::T_BYE:1 +164:T_BTXS::T_BTXS:6 +165:T_BTXE::T_BTXE:6 +166:T_BTYS::T_BTYS:6 +167:T_BTYE::T_BTYE:6 +168:MU_BXS::MU_BXS:4 +169:MU_BXE::MU_BXE:4 +170:MU_BYS::MU_BYS:4 +171:MU_BYE::MU_BYE:4 +172:MU_BTXS::MU_BTXS:9 +173:MU_BTXE::MU_BTXE:9 +174:MU_BTYS::MU_BTYS:9 +175:MU_BTYE::MU_BTYE:9 +176:RQV_BXS::RQV_BXS:4 +177:RQV_BXE::RQV_BXE:4 +178:RQV_BYS::RQV_BYS:4 +179:RQV_BYE::RQV_BYE:4 +180:RQV_BTXS::RQV_BTXS:10 +181:RQV_BTXE::RQV_BTXE:10 +182:RQV_BTYS::RQV_BTYS:10 +183:RQV_BTYE::RQV_BTYE:10 +184:RQC_BXS::RQC_BXS:4 +185:RQC_BXE::RQC_BXE:4 +186:RQC_BYS::RQC_BYS:4 +187:RQC_BYE::RQC_BYE:4 +188:RQC_BTXS::RQC_BTXS:10 +189:RQC_BTXE::RQC_BTXE:10 +190:RQC_BTYS::RQC_BTYS:10 +191:RQC_BTYE::RQC_BTYE:10 +192:RQR_BXS::RQR_BXS:4 +193:RQR_BXE::RQR_BXE:4 +194:RQR_BYS::RQR_BYS:4 +195:RQR_BYE::RQR_BYE:4 +196:RQR_BTXS::RQR_BTXS:10 +197:RQR_BTXE::RQR_BTXE:10 +198:RQR_BTYS::RQR_BTYS:10 +199:RQR_BTYE::RQR_BTYE:10 +200:RQI_BXS::RQI_BXS:4 +201:RQI_BXE::RQI_BXE:4 +202:RQI_BYS::RQI_BYS:4 +203:RQI_BYE::RQI_BYE:4 +204:RQI_BTXS::RQI_BTXS:10 +205:RQI_BTXE::RQI_BTXE:10 +206:RQI_BTYS::RQI_BTYS:10 +207:RQI_BTYE::RQI_BTYE:10 +208:RQS_BXS::RQS_BXS:4 +209:RQS_BXE::RQS_BXE:4 +210:RQS_BYS::RQS_BYS:4 +211:RQS_BYE::RQS_BYE:4 +212:RQS_BTXS::RQS_BTXS:10 +213:RQS_BTXE::RQS_BTXE:10 +214:RQS_BTYS::RQS_BTYS:10 +215:RQS_BTYE::RQS_BTYE:10 +216:RQG_BXS::RQG_BXS:4 +217:RQG_BXE::RQG_BXE:4 +218:RQG_BYS::RQG_BYS:4 +219:RQG_BYE::RQG_BYE:4 +220:RQG_BTXS::RQG_BTXS:10 +221:RQG_BTXE::RQG_BTXE:10 +222:RQG_BTYS::RQG_BTYS:10 +223:RQG_BTYE::RQG_BTYE:10 +224:QICE_BXS::QICE_BXS:10 +225:QICE_BXE::QICE_BXE:10 +226:QICE_BYS::QICE_BYS:10 +227:QICE_BYE::QICE_BYE:10 +228:QICE_BTXS::QICE_BTXS:4 +229:QICE_BTXE::QICE_BTXE:4 +230:QICE_BTYS::QICE_BTYS:4 +231:QICE_BTYE::QICE_BTYE:4 +232:QSNOW_BTYE::QSNOW_BTYE:2 +233:QSNOW_BXS::QSNOW_BXS:10 +234:QSNOW_BXE::QSNOW_BXE:10 +235:QSNOW_BYS::QSNOW_BYS:10 +236:QSNOW_BYE::QSNOW_BYE:10 +237:QSNOW_BTXS::QSNOW_BTXS:4 +238:QSNOW_BTXE::QSNOW_BTXE:4 +239:QSNOW_BTYS::QSNOW_BTYS:4 +240:QSNOW_BTYE::QSNOW_BTYE:4 +241:QGRAUP_BXS::QGRAUP_BXS:10 +242:QGRAUP_BXE::QGRAUP_BXE:10 +243:QGRAUP_BYS::QGRAUP_BYS:10 +244:QGRAUP_BYE::QGRAUP_BYE:10 +245:QGRAUP_BTXS::QGRAUP_BTXS:4 +246:QGRAUP_BTXE::QGRAUP_BTXE:4 +247:QGRAUP_BTYS::QGRAUP_BTYS:4 +248:QGRAUP_BTYE::QGRAUP_BTYE:4 +249:var249:undefined:: +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:var253:undefined:: +254:var254:undefined:: +255:var255:undefined:: +-1:255:255:5 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:U_BXS::U_BXS:1 +129:U_BXE::U_BXE:1 +130:U_BYS::U_BYS:1 +131:U_BYE::U_BYE:1 +132:U_BTXS::U_BTXS:5 +133:U_BTXE::U_BTXE:5 +134:U_BTYS::U_BTYS:5 +135:U_BTYE::U_BTYE:5 +136:V_BXS::V_BXS:1 +137:V_BXE::V_BXE:1 +138:V_BYS::V_BYS:1 +139:V_BYE::V_BYE:1 +140:V_BTXS::V_BTXS:5 +141:V_BTXE::V_BTXE:5 +142:V_BTYS::V_BTYS:5 +143:V_BTYE::V_BTYE:5 +144:W_BXS::W_BXS:4 +145:W_BXE::W_BXE:4 +146:W_BYS::W_BYS:4 +147:W_BYE::W_BYE:4 +148:W_BTXS::W_BTXS:8 +149:W_BTXE::W_BTXE:8 +150:W_BTYS::W_BTYS:8 +151:W_BTYE::W_BTYE:8 +152:QVAPOR_BXS::QVAPOR_BXS:4 +153:QVAPOR_BXE::QVAPOR_BXE:4 +154:QVAPOR_BYS::QVAPOR_BYS:4 +155:QVAPOR_BYE::QVAPOR_BYE:4 +156:QVAPOR_BTXS::QVAPOR_BTXS:6 +157:QVAPOR_BTXE::QVAPOR_BTXE:6 +158:QVAPOR_BTYS::QVAPOR_BTYS:6 +159:QVAPOR_BTYE::QVAPOR_BTYE:6 +160:QCLOUD_BXS::QCLOUD_BXS:6 +161:QCLOUD_BXE::QCLOUD_BXE:6 +162:QCLOUD_BYS::QCLOUD_BYS:6 +163:QCLOUD_BYE::QCLOUD_BYE:6 +164:QCLOUD_BTXS::QCLOUD_BTXS:9 +165:QCLOUD_BTXE::QCLOUD_BTXE:9 +166:QCLOUD_BTYS::QCLOUD_BTYS:9 +167:QCLOUD_BTYE::QCLOUD_BTYE:9 +168:QRAIN_BXS::QRAIN_BXS:6 +169:QRAIN_BXE::QRAIN_BXE:6 +170:QRAIN_BYS::QRAIN_BYS:6 +171:QRAIN_BYE::QRAIN_BYE:6 +172:QRAIN_BTXS::QRAIN_BTXS:9 +173:QRAIN_BTXE::QRAIN_BTXE:9 +174:QRAIN_BTYS::QRAIN_BTYS:9 +175:QRAIN_BTYE::QRAIN_BTYE:9 +176:QNICE_BXS::QNICE_BXS:6 +177:QNICE_BXE::QNICE_BXE:6 +178:QNICE_BYS::QNICE_BYS:6 +179:QNICE_BYE::QNICE_BYE:6 +180:QNICE_BTXS::QNICE_BTXS:9 +181:QNICE_BTXE::QNICE_BTXE:9 +182:QNICE_BTYS::QNICE_BTYS:9 +183:QNICE_BTYE::QNICE_BTYE:9 +184:var184:undefined:: +185:var185:undefined:: +186:var186:undefined:: +187:var187:undefined:: +188:var188:undefined:: +189:var189:undefined:: +190:var190:undefined:: +191:var191:undefined:: +192:var192:undefined:: +193:var193:undefined:: +194:var194:undefined:: +195:var195:undefined:: +196:var196:undefined:: +197:var197:undefined:: +198:var198:undefined:: +199:var199:undefined:: +200:var200:undefined:: +201:var201:undefined:: +202:var202:undefined:: +203:var203:undefined:: +204:var204:undefined:: +205:var205:undefined:: +206:var206:undefined:: +207:var207:undefined:: +208:var208:undefined:: +209:var209:undefined:: +210:var210:undefined:: +211:var211:undefined:: +212:var212:undefined:: +213:var213:undefined:: +214:var214:undefined:: +215:var215:undefined:: +216:var216:undefined:: +217:var217:undefined:: +218:var218:undefined:: +219:var219:undefined:: +220:var220:undefined:: +221:var221:undefined:: +222:var222:undefined:: +223:var223:undefined:: +224:var224:undefined:: +225:var225:undefined:: +226:var226:undefined:: +227:var227:undefined:: +228:var228:undefined:: +229:var229:undefined:: +230:var230:undefined:: +231:var231:undefined:: +232:var232:undefined:: +233:var233:undefined:: +234:var234:undefined:: +235:var235:undefined:: +236:var236:undefined:: +237:var237:undefined:: +238:var238:undefined:: +239:var239:undefined:: +240:var240:undefined:: +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:var247:undefined:: +248:var248:undefined:: +249:var249:undefined:: +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:var253:undefined:: +254:var254:undefined:: +255:var255:undefined:: +-1:255:255:6 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:var128:undefined:: +129:PH0:Initial geopotential:PH0:1 +130:T_INIT:initial potential temperature:T_INIT:2 +131:AL:inverse perturbation density [m3 kg-1]:AL:4 +132:ALT:inverse density [m3 kg-1]:ALT:4 +133:SMFR3D:soil ice:SMFR3D:2 +134:KEEPFR3DFLAG:Flag - 1. Frozen Soil Yes, 0 - NO:KEEPFR3DFLAG:1 +135:CT:COUNTERGRADIENT TERM [K]:CT:2 +136:Z0:Background Roughness Length [m]:Z0:6 +137:KPBL:Level of PBL TOP:KPBL:1 +138:HTOP:Top of convection level:HTOP:1 +139:HBOT:Bottom of Convection Level:HBOT:1 +140:CUPPT:Accmulated Convective Rain Since Last Call to the Radiation:CUPPT:4 +141:F_ICE_PHY:Fraction of Ice:F_ICE_PHY:2 +142:F_RAIN_PHY:Fraction of Rain:F_RAIN_PHY:2 +143:F_RIMEF_PHY:Mass Ratio of Rimed Ice:F_RIMEF_PHY:2 +144:H_DIABATIC:Previous Timestep Condensational Heating:H_DIABATIC:9 +145:RTHCUTEN:COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME [Pa K s-1]:RTHCUTEN:4 +146:RQVCUTEN:COUPLED Q_V TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQVCUTEN:4 +147:RQRCUTEN:COUPLED Q_R TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQRCUTEN:4 +148:RQCCUTEN:COUPLED Q_C TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQCCUTEN:4 +149:RQSCUTEN:COUPLED Q_S TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQSCUTEN:4 +150:RQICUTEN:COUPLED Q_I TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQICUTEN:4 +151:W0AVG:AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME [m s-1]:W0AVG:6 +152:NCA:COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME:NCA:0 +153:MASS_FLUX:DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME [mb/hr]:MASS_FLUX:4 +154:APR_GR:PRECIP FROM CLOSURE OLD_GRELL [mm/hr]:APR_GR:4 +155:APR_W:PRECIP FROM CLOSURE W:APR_W:4 +156:APR_MC:PRECIP FROM CLOSURE KRISH MV [mm/hr]:APR_MC:4 +157:APR_ST:PRECIP FROM CLOSURE STABILITY [mm/hr]:APR_ST:4 +158:APR_AS:PRECIP FROM CLOSURE AS-TYPE [mm/hr]:APR_AS:4 +159:var159:undefined:: +160:APR_CAPMA:PRECIP FROM MAX CAP [mm/hr]:APR_CAPMA:4 +161:APR_CAPME:PRECIP FROM MEAN CAP [mm/hr]:APR_CAPME:4 +162:APR_CAPMI:PRECIP FROM MIN CAP [mm/hr]:APR_CAPMI:4 +163:XF_ENS:MASS FLUX PDF IN GRELL CUMULUS SCHEME[mb/hr]:XF_ENS:4 +164:PR_ENS:PRECIP RATE PDF IN GRELL CUMULUS SCHEME [mb/hr]:PR_ENS:4 +165:STEPCU:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS:STEPCU:1 +166:RTHRATEN:COUPLED THETA TENDENCY DUE TO RADIATION [Pa K s-1]:RTHRATEN:4 +167:RTHRATLW:COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION [Pa K s-1]:RTHRATLW:7 +168:RTHRATSW:COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION [Pa K s-1]:RTHRATSW:7 +169:CLDFRA:CLOUD FRACTION:CLDFRA:2 +170:RUBLTEN:COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION [Pa m s-2]:RUBLTEN:4 +171:RVBLTEN:COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION [Pa m s-2]:RVBLTEN:4 +172:RTHBLTEN:COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION [Pa K s-1]:RTHBLTEN:4 +173:RQVBLTEN:COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQVBLTEN:6 +174:RQCBLTEN:COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQCBLTEN:6 +175:RQIBLTEN:COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQIBLTEN:6 +176:UST:U* IN SIMILARITY THEORY [m s-1]:UST:4 +177:CAPG:HEAT CAPACITY FOR SOIL [j K-1 m-3]:CAPG:3 +178:THC:THERMAL INERTIA [Cal cm-1 K-1 s-0.5]:THC:3 +179:FLHC:SURFACE EXCHANGE COEFFICIENT FOR HEAT:FLHC:3 +180:FLQC:SURFACE EXCHANGE COEFFICIENT FOR MOISTURE:FLQC:6 +181:QSG:SURFACE SATURATION WATER VAPOR MIXING RATIO [kg kg-1]:QSG:6 +182:SOILT1:TEMPERATURE INSIDE SNOW [K]:SOILT1:2 +183:TSNAV:AVERAGE SNOW TEMPERATURE [C]:TSNAV:2 +184:MAVAIL:SURFACE MOISTURE AVAILABLITY:MAVAIL:4 +185:TKESFCF:TKE AT THE SURFACE [m2/s2]:TKESFCF:3 +186:STEPBL:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS:STEPBL:1 +187:TAUCLDI:CLOUD OPTICAL THICKNESS FOR ICE:TAUCLDI:2 +188:TAUCLDC:CLOUD OPTICAL THICKNESS FOR WATER:TAUCLDC:2 +189:RTHFTEN:TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME [K/s]:RTHFTEN:6 +190:RQVFTEN:MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME [kg/s]:RQVFTEN:6 +191:EMISS:SURFACE EMISSIVITY:EMISS:4 +192:CLDEFI:Precipitation efficiency in BMJ Scheme:CLDEFI:4 +193:STEPRA:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS:STEPRA:1 +194:MOL:T* in Similarity Theory [K]:MOL:3 +195:ALB:??:ALB:4 +196:U_1:Restart Parm:U_1:3 +197:U_2:Restart Parm:U_2:3 +198:V_1:Restart Parm:V_1:3 +199:V_2:Restart Parm:V_2:3 +200:W_1:Restart Parm:W_1:5 +201:W_2:Restart Parm:W_2:5 +202:PH_1:Restart Parm:PH_1:4 +203:PH_2:Restart Parm:PH_2:4 +204:T_1:Restart Parm:T_1:3 +205:T_2:Restart Parm:T_2:3 +206:MU_1:Restart Parm:MU_1:2 +207:MU_2:Restart Parm:MU_2:2 +208:TKE_1:Restart Parm:TKE_1:3 +209:TKE_2:Restart Parm:TKE_2:3 +210:QVAPOR_1:Restart Parm:QVAPOR_1:6 +211:QVAPOR_2:Restart Parm:QVAPOR_2:6 +212:QCLOUD_1:Restart Parm:QCLOUD_1:6 +213:QCLOUD_2:Restart Parm:QCLOUD_2:6 +214:QRAIN_1:Restart Parm:QRAIN_1:6 +215:QRAIN_2:Restart Parm:QRAIN_2:6 +216:QICE_1:Restart Parm:QICE_1:6 +217:QICE_2:Restart Parm:QICE_2:6 +218:QSNOW_1:Restart Parm:QSNOW_1:6 +219:QSNOW_2:Restart Parm:QSNOW_2:6 +220:QGRAUP_1:Restart Parm:QGRAUP_1:6 +221:QGRAUP_2:Restart Parm:QGRAUP_2:6 +222:QZ0:Specific humidity at roughness length [kg/kg]:QZ0:5 +223:TBPVS_STATE:STATE FOR ETAMPNEW MICROPHYSICS:TBPVS_STATE:3 +224:TBPVS0_STATE:STATE FOR ETAMPNEW MICROPHYSICS:TBPVS0_STATE:3 +225:MP_RESTART_STATE:STATE VECTOR FOR MICROPHYSICS RESTARTS:MP_RESTART_STATE:3 +226:IMICROGRAM:flag 0/1 0=mixratio, 1=mcrograms/m3":IMICROGRAM:1 +227:MASS_AER_WATER:aerosol liquid water content:MASS_AER_WATER:6 +228:MASS_AER_DRY:dry aerosol mass:MASS_AER_DRY:6 +229:EXCH_H:EXCHANGE COEFFICIENTS:EXCH_H:3 +230:var230:undefined:: +231:var231:undefined:: +232:var232:undefined:: +233:var233:undefined:: +234:var234:undefined:: +235:var235:undefined:: +236:var236:undefined:: +237:var237:undefined:: +238:var238:undefined:: +239:var239:undefined:: +240:var240:undefined:: +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:var247:undefined:: +248:var248:undefined:: +249:var249:undefined:: +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:var253:undefined:: +254:var254:undefined:: +255:var255:undefined:: +-1:7:-1:129 +0:var0:undefined +1:PRES:Pressure [Pa] +2:PRMSL:Pressure reduced to MSL [Pa] +3:PTEND:Pressure tendency [Pa/s] +4:PVORT:Pot. vorticity [km^2/kg/s] +5:ICAHT:ICAO Standard Atmosphere Reference Height [M] +6:GP:Geopotential [m^2/s^2] +7:HGT:Geopotential height [gpm] +8:DIST:Geometric height [m] +9:HSTDV:Std dev of height [m] +10:TOZNE:Total ozone [Dobson] +11:TMP:Temp. [K] +12:VTMP:Virtual temp. [K] +13:POT:Potential temp. [K] +14:EPOT:Pseudo-adiabatic pot. temp. [K] +15:TMAX:Max. temp. [K] +16:TMIN:Min. temp. [K] +17:DPT:Dew point temp. [K] +18:DEPR:Dew point depression [K] +19:LAPR:Lapse rate [K/m] +20:VIS:Visibility [m] +21:RDSP1:Radar spectra (1) [non-dim] +22:RDSP2:Radar spectra (2) [non-dim] +23:RDSP3:Radar spectra (3) [non-dim] +24:PLI:Parcel lifted index (to 500 hPa) [K] +25:TMPA:Temp. anomaly [K] +26:PRESA:Pressure anomaly [Pa] +27:GPA:Geopotential height anomaly [gpm] +28:WVSP1:Wave spectra (1) [non-dim] +29:WVSP2:Wave spectra (2) [non-dim] +30:WVSP3:Wave spectra (3) [non-dim] +31:WDIR:Wind direction [deg] +32:WIND:Wind speed [m/s] +33:UGRD:u wind [m/s] +34:VGRD:v wind [m/s] +35:STRM:Stream function [m^2/s] +36:VPOT:Velocity potential [m^2/s] +37:MNTSF:Montgomery stream function [m^2/s^2] +38:SGCVV:Sigma coord. vertical velocity [/s] +39:VVEL:Pressure vertical velocity [Pa/s] +40:DZDT:Geometric vertical velocity [m/s] +41:ABSV:Absolute vorticity [/s] +42:ABSD:Absolute divergence [/s] +43:RELV:Relative vorticity [/s] +44:RELD:Relative divergence [/s] +45:VUCSH:Vertical u shear [/s] +46:VVCSH:Vertical v shear [/s] +47:DIRC:Direction of current [deg] +48:SPC:Speed of current [m/s] +49:UOGRD:u of current [m/s] +50:VOGRD:v of current [m/s] +51:SPFH:Specific humidity [kg/kg] +52:RH:Relative humidity [%] +53:MIXR:Humidity mixing ratio [kg/kg] +54:PWAT:Precipitable water [kg/m^2] +55:VAPP:Vapor pressure [Pa] +56:SATD:Saturation deficit [Pa] +57:EVP:Evaporation [kg/m^2] +58:CICE:Cloud Ice [kg/m^2] +59:PRATE:Precipitation rate [kg/m^2/s] +60:TSTM:Thunderstorm probability [%] +61:APCP:Total precipitation [kg/m^2] +62:NCPCP:Large scale precipitation [kg/m^2] +63:ACPCP:Convective precipitation [kg/m^2] +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s] +65:WEASD:Accum. snow [kg/m^2] +66:SNOD:Snow depth [m] +67:MIXHT:Mixed layer depth [m] +68:TTHDP:Transient thermocline depth [m] +69:MTHD:Main thermocline depth [m] +70:MTHA:Main thermocline anomaly [m] +71:TCDC:Total cloud cover [%] +72:CDCON:Convective cloud cover [%] +73:LCDC:Low level cloud cover [%] +74:MCDC:Mid level cloud cover [%] +75:HCDC:High level cloud cover [%] +76:CWAT:Cloud water [kg/m^2] +77:BLI:Best lifted index (to 500 hPa) [K] +78:SNOC:Convective snow [kg/m^2] +79:SNOL:Large scale snow [kg/m^2] +80:WTMP:Water temp. [K] +81:LAND:Land cover (land=1;sea=0) [fraction] +82:DSLM:Deviation of sea level from mean [m] +83:SFCR:Surface roughness [m] +84:ALBDO:Albedo [%] +85:TSOIL:Soil temp. [K] +86:SOILM:Soil moisture content [kg/m^2] +87:VEG:Vegetation [%] +88:SALTY:Salinity [kg/kg] +89:DEN:Density [kg/m^3] +90:WATR:Water runoff [kg/m^2] +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction] +92:ICETK:Ice thickness [m] +93:DICED:Direction of ice drift [deg] +94:SICED:Speed of ice drift [m/s] +95:UICE:u of ice drift [m/s] +96:VICE:v of ice drift [m/s] +97:ICEG:Ice growth rate [m/s] +98:ICED:Ice divergence [/s] +99:SNOM:Snow melt [kg/m^2] +100:HTSGW:Sig height of wind waves and swell [m] +101:WVDIR:Direction of wind waves [deg] +102:WVHGT:Sig height of wind waves [m] +103:WVPER:Mean period of wind waves [s] +104:SWDIR:Direction of swell waves [deg] +105:SWELL:Sig height of swell waves [m] +106:SWPER:Mean period of swell waves [s] +107:DIRPW:Primary wave direction [deg] +108:PERPW:Primary wave mean period [s] +109:DIRSW:Secondary wave direction [deg] +110:PERSW:Secondary wave mean period [s] +111:NSWRS:Net short wave (surface) [W/m^2] +112:NLWRS:Net long wave (surface) [W/m^2] +113:NSWRT:Net short wave (top) [W/m^2] +114:NLWRT:Net long wave (top) [W/m^2] +115:LWAVR:Long wave [W/m^2] +116:SWAVR:Short wave [W/m^2] +117:GRAD:Global radiation [W/m^2] +118:BRTMP:Brightness temperature [K] +119:LWRAD:Radiance with respect to wave no. [W/m/sr] +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr] +121:LHTFL:Latent heat flux [W/m^2] +122:SHTFL:Sensible heat flux [W/m^2] +123:BLYDP:Boundary layer dissipation [W/m^2] +124:UFLX:Zonal momentum flux [N/m^2] +125:VFLX:Meridional momentum flux [N/m^2] +126:WMIXE:Wind mixing energy [J] +127:IMGD:Image data [] +128:PAOT:Probability anomaly of temp [%] +129:PAOP:Probability anomaly of precip [%] +130:var130:undefined +131:FRAIN:Rain fraction of total liquid water [] +132:FICE:Ice fraction of total condensate [] +133:FRIME:Rime factor [] +134:CUEFI:Convective cloud efficiency [] +135:TCOND:Total condensate [kg/kg] +136:TCOLW:Total column cloud water [kg/m/m] +137:TCOLI:Total column cloud ice [kg/m/m] +138:TCOLR:Total column rain [kg/m/m] +139:TCOLS:Total column snow [kg/m/m] +140:TCOLC:Total column condensate [kg/m/m] +141:PLPL:Pressure of level from which parcel was lifted [Pa] +142:HLPL:Height of level from which parcel was lifted [Pa] +143:var143:undefined +144:var144:undefined +145:var145:undefined +146:var146:undefined +147:var147:undefined +148:var148:undefined +149:var149:undefined +150:var150:undefined +151:var151:undefined +152:var152:undefined +153:var153:undefined +154:var154:undefined +155:var155:undefined +156:var156:undefined +157:var157:undefined +158:var158:undefined +159:var159:undefined +160:var160:undefined +161:var161:undefined +162:var162:undefined +163:var163:undefined +164:var164:undefined +165:var165:undefined +166:var166:undefined +167:var167:undefined +168:var168:undefined +169:var169:undefined +170:ELRDI:Ellrod Index +171:TSEC:Seconds prior to initial reference time [sec] +172:var172:undefined +173:var173:undefined +174:var174:undefined +175:var175:undefined +176:var176:undefined +177:var177:undefined +178:var178:undefined +179:var179:undefined +180:OZCON:Ozone concentration [ppb] +181:OZCAT:Categorical ozone concentration [?] +182:KH:vertical heat eddy diffusivity [m^2/s] +183:var183:undefined +184:var184:undefined +185:var185:undefined +186:var186:undefined +187:var187:undefined +188:var188:undefined +189:var189:undefined +190:var190:undefined +191:var191:undefined +192:var192:undefined +193:var193:undefined +194:var194:undefined +195:var195:undefined +196:var196:undefined +197:var197:undefined +198:var198:undefined +199:var199:undefined +200:var200:undefined +201:var201:undefined +202:var202:undefined +203:var203:undefined +204:var204:undefined +205:var205:undefined +206:var206:undefined +207:var207:undefined +208:var208:undefined +209:var209:undefined +210:var210:undefined +211:var211:undefined +212:var212:undefined +213:var213:undefined +214:var214:undefined +215:var215:undefined +216:var216:undefined +217:var217:undefined +218:var218:undefined +219:var219:undefined +220:var220:undefined +221:var221:undefined +222:var222:undefined +223:var223:undefined +224:var224:undefined +225:var225:undefined +226:var226:undefined +227:var227:undefined +228:var228:undefined +229:var229:undefined +230:var230:undefined +231:var231:undefined +232:var232:undefined +233:var233:undefined +234:var234:undefined +235:var235:undefined +236:var236:undefined +237:var237:undefined +238:var238:undefined +239:var239:undefined +240:var240:undefined +241:var241:undefined +242:var242:undefined +243:var243:undefined +244:var244:undefined +245:var245:undefined +246:var246:undefined +247:var247:undefined +248:var248:undefined +249:var249:undefined +250:var250:undefined +251:var251:undefined +252:var252:undefined +253:var253:undefined +254:var254:undefined +255:var255:undefined +-1:7:-1:130 +0:var0:undefined +1:PRES:Pressure [Pa] +2:PRMSL:Pressure reduced to MSL [Pa] +3:PTEND:Pressure tendency [Pa/s] +4:PVORT:Pot. vorticity [km^2/kg/s] +5:ICAHT:ICAO Standard Atmosphere Reference Height [M] +6:GP:Geopotential [m^2/s^2] +7:HGT:Geopotential height [gpm] +8:DIST:Geometric height [m] +9:HSTDV:Std dev of height [m] +10:TOZNE:Total ozone [Dobson] +11:TMP:Temp. [K] +12:VTMP:Virtual temp. [K] +13:POT:Potential temp. [K] +14:EPOT:Pseudo-adiabatic pot. temp. [K] +15:TMAX:Max. temp. [K] +16:TMIN:Min. temp. [K] +17:DPT:Dew point temp. [K] +18:DEPR:Dew point depression [K] +19:LAPR:Lapse rate [K/m] +20:VIS:Visibility [m] +21:RDSP1:Radar spectra (1) [non-dim] +22:RDSP2:Radar spectra (2) [non-dim] +23:RDSP3:Radar spectra (3) [non-dim] +24:PLI:Parcel lifted index (to 500 hPa) [K] +25:TMPA:Temp. anomaly [K] +26:PRESA:Pressure anomaly [Pa] +27:GPA:Geopotential height anomaly [gpm] +28:WVSP1:Wave spectra (1) [non-dim] +29:WVSP2:Wave spectra (2) [non-dim] +30:WVSP3:Wave spectra (3) [non-dim] +31:WDIR:Wind direction [deg] +32:WIND:Wind speed [m/s] +33:UGRD:u wind [m/s] +34:VGRD:v wind [m/s] +35:STRM:Stream function [m^2/s] +36:VPOT:Velocity potential [m^2/s] +37:MNTSF:Montgomery stream function [m^2/s^2] +38:SGCVV:Sigma coord. vertical velocity [/s] +39:VVEL:Pressure vertical velocity [Pa/s] +40:DZDT:Geometric vertical velocity [m/s] +41:ABSV:Absolute vorticity [/s] +42:ABSD:Absolute divergence [/s] +43:RELV:Relative vorticity [/s] +44:RELD:Relative divergence [/s] +45:VUCSH:Vertical u shear [/s] +46:VVCSH:Vertical v shear [/s] +47:DIRC:Direction of current [deg] +48:SPC:Speed of current [m/s] +49:UOGRD:u of current [m/s] +50:VOGRD:v of current [m/s] +51:SPFH:Specific humidity [kg/kg] +52:RH:Relative humidity [%] +53:MIXR:Humidity mixing ratio [kg/kg] +54:PWAT:Precipitable water [kg/m^2] +55:VAPP:Vapor pressure [Pa] +56:SATD:Saturation deficit [Pa] +57:EVP:Evaporation [kg/m^2] +58:CICE:Cloud Ice [kg/m^2] +59:PRATE:Precipitation rate [kg/m^2/s] +60:TSTM:Thunderstorm probability [%] +61:APCP:Total precipitation [kg/m^2] +62:NCPCP:Large scale precipitation [kg/m^2] +63:ACPCP:Convective precipitation [kg/m^2] +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s] +65:WEASD:Accum. snow [kg/m^2] +66:SNOD:Snow depth [m] +67:MIXHT:Mixed layer depth [m] +68:TTHDP:Transient thermocline depth [m] +69:MTHD:Main thermocline depth [m] +70:MTHA:Main thermocline anomaly [m] +71:TCDC:Total cloud cover [%] +72:CDCON:Convective cloud cover [%] +73:LCDC:Low level cloud cover [%] +74:MCDC:Mid level cloud cover [%] +75:HCDC:High level cloud cover [%] +76:CWAT:Cloud water [kg/m^2] +77:BLI:Best lifted index (to 500 hPa) [K] +78:SNOC:Convective snow [kg/m^2] +79:SNOL:Large scale snow [kg/m^2] +80:WTMP:Water temp. [K] +81:LAND:Land cover (land=1;sea=0) [fraction] +82:DSLM:Deviation of sea level from mean [m] +83:SFCR:Surface roughness [m] +84:ALBDO:Albedo [%] +85:TSOIL:Soil temp. [K] +86:SOILM:Soil moisture content [kg/m^2] +87:VEG:Vegetation [%] +88:SALTY:Salinity [kg/kg] +89:DEN:Density [kg/m^3] +90:WATR:Water runoff [kg/m^2] +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction] +92:ICETK:Ice thickness [m] +93:DICED:Direction of ice drift [deg] +94:SICED:Speed of ice drift [m/s] +95:UICE:u of ice drift [m/s] +96:VICE:v of ice drift [m/s] +97:ICEG:Ice growth rate [m/s] +98:ICED:Ice divergence [/s] +99:SNOM:Snow melt [kg/m^2] +100:HTSGW:Sig height of wind waves and swell [m] +101:WVDIR:Direction of wind waves [deg] +102:WVHGT:Sig height of wind waves [m] +103:WVPER:Mean period of wind waves [s] +104:SWDIR:Direction of swell waves [deg] +105:SWELL:Sig height of swell waves [m] +106:SWPER:Mean period of swell waves [s] +107:DIRPW:Primary wave direction [deg] +108:PERPW:Primary wave mean period [s] +109:DIRSW:Secondary wave direction [deg] +110:PERSW:Secondary wave mean period [s] +111:NSWRS:Net short wave (surface) [W/m^2] +112:NLWRS:Net long wave (surface) [W/m^2] +113:NSWRT:Net short wave (top) [W/m^2] +114:NLWRT:Net long wave (top) [W/m^2] +115:LWAVR:Long wave [W/m^2] +116:SWAVR:Short wave [W/m^2] +117:GRAD:Global radiation [W/m^2] +118:BRTMP:Brightness temperature [K] +119:LWRAD:Radiance with respect to wave no. [W/m/sr] +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr] +121:LHTFL:Latent heat flux [W/m^2] +122:SHTFL:Sensible heat flux [W/m^2] +123:BLYDP:Boundary layer dissipation [W/m^2] +124:UFLX:Zonal momentum flux [N/m^2] +125:VFLX:Meridional momentum flux [N/m^2] +126:WMIXE:Wind mixing energy [J] +127:IMGD:Image data [] +128:var128:undefined +129:var129:undefined +130:var130:undefined +131:var131:undefined +132:var132:undefined +133:var133:undefined +134:var134:undefined +135:var135:undefined +136:var136:undefined +137:var137:undefined +138:var138:undefined +139:var139:undefined +140:var140:undefined +141:var141:undefined +142:var142:undefined +143:CSNOW:Categorical snow [yes=1;no=0] +144:SOILW:Volumetric soil moisture (frozen + liquid) [fraction] +145:PEVPR:Potential evaporation rate [W/m^2] +146:VEGT:Vegetation canopy temperature [K] +147:BARET:Bare soil surface skin temperature [K] +148:AVSFT:Average surface skin temperature [K] +149:RADT:Effective radiative skin temperature [K] +150:SSTOR:Surface water storage [Kg/m^2] +151:LSOIL:Liquid soil moisture content (non-frozen) [Kg/m^2] +152:EWATR:Open water evaporation (standing water) [W/m^2] +153:var153:undefined +154:var154:undefined +155:GFLUX:Ground Heat Flux [W/m^2] +156:CIN:Convective inhibition [J/Kg] +157:CAPE:Convective available potential energy [J/Kg] +158:TKE:Turbulent Kinetic Energy [J/Kg] +159:MXSALB:Maximum snow albedo [%] +160:SOILL:Liquid volumetric soil moisture (non-frozen) [fraction] +161:ASNOW:Frozen precipitation (e.g. snowfall) [Kg/m^2] +162:ARAIN:Liquid precipitation (rainfall) [Kg/m^2] +163:GWREC:Groundwater recharge [Kg/m^2] +164:QREC:Flood plain recharge [Kg/m^2] +165:SNOWT:Snow temperature, depth-avg [K] +166:VBDSF:Visible beam downward solar flux [W/m^2] +167:VDDSF:Visible diffuse downward solar flux [W/m^2] +168:NBDSF:Near IR beam downward solar flux [W/m^2] +169:NDDSF:Near IR diffuse downward solar flux [W/m^2] +170:SNFALB:Snow-free albedo [%] +171:RLYRS:Number of soil layers in root zone [non-dim] +172:MFLX:Momentum flux [N/m^2] +173:var173:undefined +174:var174:undefined +175:var175:undefined +176:NLAT:Latitude (-90 to +90) [deg] +177:ELON:East longitude (0-360) [deg] +178:var178:undefined +179:ACOND:Aerodynamic conductance [m/s] +180:SNOAG:Snow age [s] +181:CCOND:Canopy conductance [m/s] +182:LAI:Leaf area index (0-9) [non-dim] +183:SFCRH:Roughness length for heat [m] +184:SALBD:Snow albedo (over snow cover area only) [%] +185:var185:undefined +186:var186:undefined +187:NDVI:Normalized Difference Vegetation Index [] +188:DRIP:Canopy drip [Kg/m^2] +189:var189:undefined +190:var190:undefined +191:var191:undefined +192:var192:undefined +193:var193:undefined +194:var194:undefined +195:var195:undefined +196:var196:undefined +197:var197:undefined +198:SBSNO:Sublimation (evaporation from snow) [W/m^2] +199:EVBS:Direct evaporation from bare soil [W/m^2] +200:EVCW:Canopy water evaporation [W/m^2] +201:var201:undefined +202:var202:undefined +203:RSMIN:Minimal stomatal resistance [s/m] +204:DSWRF:Downward shortwave radiation flux [W/m^2] +205:DLWRF:Downward longwave radiation flux [W/m^2] +206:var206:undefined +207:MSTAV:Moisture availability [%] +208:SFEXC:Exchange coefficient [(Kg/m^3)(m/s)] +209:var209:undefined +210:TRANS:Transpiration [W/m^2] +211:USWRF:Upward short wave radiation flux [W/m^2] +212:ULWRF:Upward long wave radiation flux [W/m^2] +213:var213:undefined +214:var214:undefined +215:var215:undefined +216:var216:undefined +217:var217:undefined +218:var218:undefined +219:WILT:Wilting point [fraction] +220:FLDCP:Field Capacity [fraction] +221:var221:undefined +222:SLTYP:Surface slope type [Index] +223:CNWAT:Plant canopy surface water [Kg/m^2] +224:SOTYP:Soil type [Index] +225:VGTYP:Vegetation type [Index] +226:BMIXL:Blackadars mixing length scale [m] +227:AMIXL:Asymptotic mixing length scale [m] +228:PEVAP:Potential evaporation [Kg/m^2] +229:SNOHF:Snow phase-change heat flux [W/m^2] +230:SMREF:Transpiration stress-onset (soil moisture) [fraction] +231:SMDRY:Direct evaporation cease (soil moisture) [fraction] +232:var232:undefined +233:var233:undefined +234:BGRUN:Subsurface runoff (baseflow) [Kg/m^2] +235:SSRUN:Surface runoff (non-infiltrating) [Kg/m^2] +236:var236:undefined +237:var237:undefined +238:SNOWC:Snow cover [%] +239:SNOT:Snow temperature [K] +240:POROS:Soil porosity [fraction] +241:var241:undefined +242:var242:undefined +243:var243:undefined +244:var244:undefined +245:var245:undefined +246:RCS:Solar parameter in canopy conductance [fraction] +247:RCT:Temperature parameter in canopy conductance [fraction] +248:RCQ:Humidity parameter in canopy conductance [fraction] +249:RCSOL:Soil moisture parameter in canopy conductance [fraction] +250:var250:undefined +251:var251:undefined +252:CD:Surface drag coefficient [non-dim] +253:FRICV:Surface friction velocity [m/s] +254:RI:Richardson number [non-dim] +255:var255:undefined diff --git a/wrfv2_fire/run/input_sounding b/wrfv2_fire/run/input_sounding new file mode 120000 index 00000000..802f6347 --- /dev/null +++ b/wrfv2_fire/run/input_sounding @@ -0,0 +1 @@ +../test/em_fire/input_sounding \ No newline at end of file diff --git a/wrfv2_fire/run/namelist.input.backup b/wrfv2_fire/run/namelist.input.backup new file mode 100644 index 00000000..3eb432ca --- /dev/null +++ b/wrfv2_fire/run/namelist.input.backup @@ -0,0 +1,138 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 30, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 01, 01, 01, + end_hour = 00, 00, 00, + end_minute = 30, 30, 30, + end_second = 00, 00, 00, + history_interval = 10, 10, 10, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 10, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 1, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 42, 43, 43, + s_sn = 1, 1, 1, + e_sn = 42, 43, 43, + s_vert = 1, 1, 1, + e_vert = 41, 41, 41, + dx = 60, 30, 10, + dy = 60, 30, 10, + ztop = 1500, 1500, 1500, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 1, 1, + j_parent_start = 0, 1, 1, + parent_grid_ratio = 1, 2, 3, + parent_time_step_ratio = 1, 2, 3, + feedback = 1, + smooth_option = 0 + sr_x = 10, 0, 0 ! subgrid ratio in x + sr_y = 10, 0, 0 ! subgrid ratio in y + / + + &physics + mp_physics = 0, 0, 0, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 0, 0, 0, + isfflx = 1, + ifsnow = 0, + icloud = 0, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 2, + damp_opt = 0, + zdamp = 5000., 5000., 5000., + dampcoef = 0.2, 0.2, 0.2 + khdif = 0.05, 0.05, 0.05, + kvdif = 0.05, 0.05, 0.05, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + mix_full_fields = .true., .true., .true., + non_hydrostatic = .true., .true., .true., + time_step_sound = 20, 20, 20, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + periodic_x = .true.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false., .false.,.false., + open_xe = .false., .false.,.false., + periodic_y = .true.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false., .false.,.false., + open_ye = .false., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / + + &fire ! be sure to set sr_x,sr_y in domains-namelist (to set refinement in x,y) + ifire = 1, ! integer, = 0: no fire, = 1: cc_fire +!fire_lat_init = 40., ! real , initial fire latitude (deg) +!fire_lon_init = -105., ! real , initial fire longitude (deg) + fire_lat_init = 6.75e-3, ! real , initial fire latitude (deg) + fire_lon_init = 6.75e-3, ! real , initial fire longitude (deg) + fire_ign_time = 2.0, ! real , time of fire ignition (s) + fire_shape = 0, ! integer, initial fire shape + fire_sprd_mdl = 1, ! integer, = 0: Macarthur, = 1: BEHAVE + fire_crwn_hgt = 15., ! real , height of canopy crown (m) + fire_ext_grnd = 50., ! real , extinction coeff ground fire + fire_ext_crwn = 50., ! real , extinction coeff crown fire + fire_fuel_read = 1, ! integer, = 1: fuels specified; = 2: read from file + fire_fuel_cat = 8, ! integer, if specified which fuel category? + / diff --git a/wrfv2_fire/run/ozone.formatted b/wrfv2_fire/run/ozone.formatted new file mode 100644 index 00000000..08ccb26e --- /dev/null +++ b/wrfv2_fire/run/ozone.formatted @@ -0,0 +1,45312 @@ + .1587E-05 + .1719E-05 + .1844E-05 + .1969E-05 + .2103E-05 + .2246E-05 + .2399E-05 + .2562E-05 + .2736E-05 + .2926E-05 + .3132E-05 + .3353E-05 + .3605E-05 + .3905E-05 + .4230E-05 + .4492E-05 + .4630E-05 + .4700E-05 + .4642E-05 + .4564E-05 + .4458E-05 + .4348E-05 + .4232E-05 + .4112E-05 + .3995E-05 + .3882E-05 + .3766E-05 + .3649E-05 + .3536E-05 + .3426E-05 + .3320E-05 + .3216E-05 + .3119E-05 + .3024E-05 + .2932E-05 + .2843E-05 + .2693E-05 + .2537E-05 + .2356E-05 + .2127E-05 + .1770E-05 + .1429E-05 + .1154E-05 + .9313E-06 + .7108E-06 + .5505E-06 + .3769E-06 + .2039E-06 + .1104E-06 + .7431E-07 + .5551E-07 + .4146E-07 + .3121E-07 + .2565E-07 + .2108E-07 + .1820E-07 + .1644E-07 + .1486E-07 + .1430E-07 + .1546E-05 + .1682E-05 + .1810E-05 + .1933E-05 + .2064E-05 + .2205E-05 + .2355E-05 + .2515E-05 + .2686E-05 + .2876E-05 + .3088E-05 + .3316E-05 + .3580E-05 + .3895E-05 + .4237E-05 + .4495E-05 + .4679E-05 + .4775E-05 + .4753E-05 + .4682E-05 + .4593E-05 + .4500E-05 + .4391E-05 + .4267E-05 + .4146E-05 + .4028E-05 + .3901E-05 + .3766E-05 + .3636E-05 + .3510E-05 + .3389E-05 + .3272E-05 + .3164E-05 + .3060E-05 + .2959E-05 + .2862E-05 + .2726E-05 + .2587E-05 + .2376E-05 + .2144E-05 + .1786E-05 + .1431E-05 + .1147E-05 + .9191E-06 + .7015E-06 + .5433E-06 + .3720E-06 + .2013E-06 + .1089E-06 + .7333E-07 + .5478E-07 + .4092E-07 + .3080E-07 + .2531E-07 + .2080E-07 + .1796E-07 + .1623E-07 + .1467E-07 + .1411E-07 + .1509E-05 + .1648E-05 + .1779E-05 + .1900E-05 + .2030E-05 + .2168E-05 + .2315E-05 + .2472E-05 + .2641E-05 + .2832E-05 + .3050E-05 + .3285E-05 + .3562E-05 + .3892E-05 + .4252E-05 + .4507E-05 + .4736E-05 + .4861E-05 + .4877E-05 + .4813E-05 + .4741E-05 + .4668E-05 + .4566E-05 + .4436E-05 + .4311E-05 + .4188E-05 + .4049E-05 + .3895E-05 + .3746E-05 + .3604E-05 + .3466E-05 + .3334E-05 + .3216E-05 + .3102E-05 + .2992E-05 + .2885E-05 + .2764E-05 + .2643E-05 + .2402E-05 + .2165E-05 + .1805E-05 + .1436E-05 + .1142E-05 + .9086E-06 + .6935E-06 + .5371E-06 + .3677E-06 + .1990E-06 + .1077E-06 + .7250E-07 + .5415E-07 + .4045E-07 + .3045E-07 + .2502E-07 + .2056E-07 + .1775E-07 + .1604E-07 + .1450E-07 + .1395E-07 + .1487E-05 + .1625E-05 + .1752E-05 + .1868E-05 + .1992E-05 + .2126E-05 + .2270E-05 + .2426E-05 + .2594E-05 + .2782E-05 + .3008E-05 + .3246E-05 + .3536E-05 + .3877E-05 + .4252E-05 + .4523E-05 + .4796E-05 + .4959E-05 + .5022E-05 + .4981E-05 + .4927E-05 + .4863E-05 + .4754E-05 + .4616E-05 + .4471E-05 + .4349E-05 + .4193E-05 + .4023E-05 + .3861E-05 + .3705E-05 + .3562E-05 + .3421E-05 + .3276E-05 + .3103E-05 + .2976E-05 + .2896E-05 + .2815E-05 + .2705E-05 + .2455E-05 + .2196E-05 + .1832E-05 + .1444E-05 + .1138E-05 + .8975E-06 + .6851E-06 + .5306E-06 + .3632E-06 + .1965E-06 + .1064E-06 + .7161E-07 + .5349E-07 + .3996E-07 + .3008E-07 + .2472E-07 + .2031E-07 + .1754E-07 + .1585E-07 + .1432E-07 + .1378E-07 + .1528E-05 + .1643E-05 + .1742E-05 + .1841E-05 + .1947E-05 + .2069E-05 + .2206E-05 + .2362E-05 + .2531E-05 + .2703E-05 + .2933E-05 + .3163E-05 + .3462E-05 + .3796E-05 + .4170E-05 + .4519E-05 + .4829E-05 + .5063E-05 + .5210E-05 + .5255E-05 + .5227E-05 + .5132E-05 + .4981E-05 + .4827E-05 + .4628E-05 + .4513E-05 + .4332E-05 + .4158E-05 + .4004E-05 + .3836E-05 + .3720E-05 + .3594E-05 + .3372E-05 + .3012E-05 + .2854E-05 + .2900E-05 + .2911E-05 + .2767E-05 + .2579E-05 + .2228E-05 + .1852E-05 + .1448E-05 + .1132E-05 + .8845E-06 + .6751E-06 + .5229E-06 + .3580E-06 + .1937E-06 + .1048E-06 + .7057E-07 + .5272E-07 + .3938E-07 + .2964E-07 + .2436E-07 + .2002E-07 + .1728E-07 + .1562E-07 + .1412E-07 + .1358E-07 + .1581E-05 + .1685E-05 + .1773E-05 + .1865E-05 + .1963E-05 + .2078E-05 + .2207E-05 + .2356E-05 + .2506E-05 + .2680E-05 + .2892E-05 + .3127E-05 + .3422E-05 + .3752E-05 + .4137E-05 + .4503E-05 + .4858E-05 + .5137E-05 + .5344E-05 + .5442E-05 + .5476E-05 + .5416E-05 + .5308E-05 + .5174E-05 + .5010E-05 + .4857E-05 + .4669E-05 + .4463E-05 + .4280E-05 + .4058E-05 + .3895E-05 + .3750E-05 + .3523E-05 + .3259E-05 + .3128E-05 + .3116E-05 + .3013E-05 + .2819E-05 + .2566E-05 + .2183E-05 + .1787E-05 + .1396E-05 + .1091E-05 + .8519E-06 + .6496E-06 + .5030E-06 + .3459E-06 + .1897E-06 + .1040E-06 + .7064E-07 + .5310E-07 + .3992E-07 + .3023E-07 + .2493E-07 + .2056E-07 + .1773E-07 + .1594E-07 + .1432E-07 + .1375E-07 + .1639E-05 + .1740E-05 + .1826E-05 + .1915E-05 + .2011E-05 + .2125E-05 + .2251E-05 + .2402E-05 + .2540E-05 + .2728E-05 + .2928E-05 + .3172E-05 + .3454E-05 + .3787E-05 + .4181E-05 + .4567E-05 + .4969E-05 + .5310E-05 + .5574E-05 + .5743E-05 + .5835E-05 + .5822E-05 + .5757E-05 + .5655E-05 + .5532E-05 + .5357E-05 + .5164E-05 + .4933E-05 + .4727E-05 + .4450E-05 + .4240E-05 + .4044E-05 + .3774E-05 + .3527E-05 + .3379E-05 + .3314E-05 + .3133E-05 + .2901E-05 + .2591E-05 + .2172E-05 + .1751E-05 + .1333E-05 + .1015E-05 + .7723E-06 + .5873E-06 + .4545E-06 + .3163E-06 + .1797E-06 + .1021E-06 + .7091E-07 + .5421E-07 + .4145E-07 + .3190E-07 + .2656E-07 + .2210E-07 + .1900E-07 + .1683E-07 + .1491E-07 + .1423E-07 + .1664E-05 + .1770E-05 + .1860E-05 + .1950E-05 + .2049E-05 + .2164E-05 + .2292E-05 + .2451E-05 + .2580E-05 + .2792E-05 + .2981E-05 + .3233E-05 + .3486E-05 + .3819E-05 + .4212E-05 + .4613E-05 + .5056E-05 + .5473E-05 + .5785E-05 + .6042E-05 + .6186E-05 + .6240E-05 + .6220E-05 + .6169E-05 + .6098E-05 + .5930E-05 + .5739E-05 + .5501E-05 + .5284E-05 + .4960E-05 + .4705E-05 + .4418E-05 + .4058E-05 + .3730E-05 + .3513E-05 + .3410E-05 + .3199E-05 + .2949E-05 + .2597E-05 + .2147E-05 + .1703E-05 + .1264E-05 + .9378E-06 + .6958E-06 + .5277E-06 + .4081E-06 + .2874E-06 + .1691E-06 + .9951E-07 + .7073E-07 + .5500E-07 + .4277E-07 + .3346E-07 + .2811E-07 + .2361E-07 + .2024E-07 + .1767E-07 + .1542E-07 + .1464E-07 + .1723E-05 + .1826E-05 + .1913E-05 + .2002E-05 + .2101E-05 + .2219E-05 + .2350E-05 + .2517E-05 + .2642E-05 + .2869E-05 + .3054E-05 + .3314E-05 + .3569E-05 + .3911E-05 + .4304E-05 + .4708E-05 + .5193E-05 + .5663E-05 + .6016E-05 + .6323E-05 + .6509E-05 + .6601E-05 + .6625E-05 + .6614E-05 + .6569E-05 + .6423E-05 + .6241E-05 + .5991E-05 + .5770E-05 + .5422E-05 + .5116E-05 + .4782E-05 + .4392E-05 + .4002E-05 + .3746E-05 + .3555E-05 + .3283E-05 + .2988E-05 + .2585E-05 + .2115E-05 + .1659E-05 + .1198E-05 + .8651E-06 + .6248E-06 + .4726E-06 + .3653E-06 + .2602E-06 + .1586E-06 + .9671E-07 + .7033E-07 + .5562E-07 + .4398E-07 + .3498E-07 + .2966E-07 + .2515E-07 + .2148E-07 + .1848E-07 + .1590E-07 + .1501E-07 + .1793E-05 + .1891E-05 + .1972E-05 + .2056E-05 + .2155E-05 + .2277E-05 + .2410E-05 + .2586E-05 + .2707E-05 + .2945E-05 + .3128E-05 + .3396E-05 + .3668E-05 + .4020E-05 + .4414E-05 + .4815E-05 + .5341E-05 + .5854E-05 + .6243E-05 + .6582E-05 + .6806E-05 + .6923E-05 + .6992E-05 + .7015E-05 + .6983E-05 + .6869E-05 + .6702E-05 + .6437E-05 + .6215E-05 + .5858E-05 + .5494E-05 + .5141E-05 + .4753E-05 + .4311E-05 + .4029E-05 + .3717E-05 + .3366E-05 + .3015E-05 + .2559E-05 + .2075E-05 + .1611E-05 + .1132E-05 + .7952E-06 + .5586E-06 + .4214E-06 + .3256E-06 + .2347E-06 + .1482E-06 + .9359E-07 + .6963E-07 + .5600E-07 + .4504E-07 + .3640E-07 + .3116E-07 + .2666E-07 + .2271E-07 + .1925E-07 + .1632E-07 + .1533E-07 + .1815E-05 + .1922E-05 + .2011E-05 + .2097E-05 + .2199E-05 + .2315E-05 + .2463E-05 + .2643E-05 + .2816E-05 + .3002E-05 + .3209E-05 + .3493E-05 + .3773E-05 + .4169E-05 + .4546E-05 + .4996E-05 + .5523E-05 + .6039E-05 + .6424E-05 + .6790E-05 + .7007E-05 + .7170E-05 + .7308E-05 + .7364E-05 + .7320E-05 + .7252E-05 + .7131E-05 + .6913E-05 + .6694E-05 + .6391E-05 + .6027E-05 + .5610E-05 + .5128E-05 + .4579E-05 + .4186E-05 + .3761E-05 + .3388E-05 + .3003E-05 + .2529E-05 + .2022E-05 + .1574E-05 + .1071E-05 + .7291E-06 + .4963E-06 + .3734E-06 + .2883E-06 + .2103E-06 + .1376E-06 + .8998E-07 + .6849E-07 + .5602E-07 + .4583E-07 + .3765E-07 + .3252E-07 + .2809E-07 + .2385E-07 + .1993E-07 + .1665E-07 + .1555E-07 + .1813E-05 + .1929E-05 + .2028E-05 + .2116E-05 + .2221E-05 + .2333E-05 + .2493E-05 + .2676E-05 + .2897E-05 + .3034E-05 + .3264E-05 + .3561E-05 + .3845E-05 + .4280E-05 + .4640E-05 + .5137E-05 + .5655E-05 + .6168E-05 + .6549E-05 + .6937E-05 + .7147E-05 + .7357E-05 + .7561E-05 + .7644E-05 + .7591E-05 + .7567E-05 + .7497E-05 + .7340E-05 + .7131E-05 + .6886E-05 + .6532E-05 + .6042E-05 + .5459E-05 + .4800E-05 + .4287E-05 + .3757E-05 + .3369E-05 + .2953E-05 + .2467E-05 + .1942E-05 + .1512E-05 + .9993E-06 + .6607E-06 + .4368E-06 + .3277E-06 + .2529E-06 + .1867E-06 + .1265E-06 + .8572E-07 + .6675E-07 + .5553E-07 + .4620E-07 + .3857E-07 + .3363E-07 + .2932E-07 + .2482E-07 + .2044E-07 + .1683E-07 + .1563E-07 + .1817E-05 + .1937E-05 + .2043E-05 + .2145E-05 + .2260E-05 + .2388E-05 + .2545E-05 + .2738E-05 + .2912E-05 + .3123E-05 + .3356E-05 + .3649E-05 + .3937E-05 + .4352E-05 + .4749E-05 + .5238E-05 + .5768E-05 + .6324E-05 + .6778E-05 + .7177E-05 + .7446E-05 + .7674E-05 + .7888E-05 + .7923E-05 + .7925E-05 + .7884E-05 + .7835E-05 + .7709E-05 + .7524E-05 + .7205E-05 + .6801E-05 + .6238E-05 + .5669E-05 + .4970E-05 + .4378E-05 + .3803E-05 + .3345E-05 + .2867E-05 + .2343E-05 + .1809E-05 + .1368E-05 + .8999E-06 + .5919E-06 + .3893E-06 + .2913E-06 + .2247E-06 + .1678E-06 + .1178E-06 + .8269E-07 + .6588E-07 + .5574E-07 + .4716E-07 + .4002E-07 + .3522E-07 + .3100E-07 + .2615E-07 + .2122E-07 + .1722E-07 + .1590E-07 + .1801E-05 + .1926E-05 + .2039E-05 + .2155E-05 + .2279E-05 + .2422E-05 + .2578E-05 + .2779E-05 + .2920E-05 + .3180E-05 + .3418E-05 + .3701E-05 + .3993E-05 + .4393E-05 + .4815E-05 + .5297E-05 + .5829E-05 + .6403E-05 + .6915E-05 + .7334E-05 + .7657E-05 + .7899E-05 + .8112E-05 + .8137E-05 + .8188E-05 + .8151E-05 + .8109E-05 + .8003E-05 + .7827E-05 + .7444E-05 + .6992E-05 + .6377E-05 + .5800E-05 + .5067E-05 + .4411E-05 + .3803E-05 + .3286E-05 + .2758E-05 + .2206E-05 + .1674E-05 + .1235E-05 + .8058E-06 + .5260E-06 + .3433E-06 + .2562E-06 + .1975E-06 + .1492E-06 + .1085E-06 + .7892E-07 + .6433E-07 + .5535E-07 + .4763E-07 + .4109E-07 + .3649E-07 + .3241E-07 + .2727E-07 + .2181E-07 + .1744E-07 + .1601E-07 + .1770E-05 + .1905E-05 + .2029E-05 + .2155E-05 + .2292E-05 + .2446E-05 + .2608E-05 + .2821E-05 + .2961E-05 + .3212E-05 + .3466E-05 + .3733E-05 + .4033E-05 + .4436E-05 + .4859E-05 + .5342E-05 + .5870E-05 + .6412E-05 + .6950E-05 + .7411E-05 + .7776E-05 + .8026E-05 + .8217E-05 + .8323E-05 + .8402E-05 + .8421E-05 + .8351E-05 + .8230E-05 + .8025E-05 + .7602E-05 + .7105E-05 + .6484E-05 + .5838E-05 + .5076E-05 + .4387E-05 + .3762E-05 + .3203E-05 + .2644E-05 + .2069E-05 + .1552E-05 + .1124E-05 + .7243E-06 + .4666E-06 + .3006E-06 + .2237E-06 + .1724E-06 + .1318E-06 + .9927E-07 + .7478E-07 + .6236E-07 + .5457E-07 + .4776E-07 + .4187E-07 + .3754E-07 + .3365E-07 + .2822E-07 + .2224E-07 + .1753E-07 + .1601E-07 + .1742E-05 + .1882E-05 + .2012E-05 + .2142E-05 + .2283E-05 + .2440E-05 + .2605E-05 + .2820E-05 + .2964E-05 + .3207E-05 + .3454E-05 + .3714E-05 + .4021E-05 + .4416E-05 + .4843E-05 + .5324E-05 + .5851E-05 + .6387E-05 + .6940E-05 + .7432E-05 + .7831E-05 + .8098E-05 + .8299E-05 + .8458E-05 + .8570E-05 + .8619E-05 + .8558E-05 + .8432E-05 + .8199E-05 + .7773E-05 + .7239E-05 + .6591E-05 + .5872E-05 + .5072E-05 + .4344E-05 + .3694E-05 + .3098E-05 + .2509E-05 + .1925E-05 + .1417E-05 + .1001E-05 + .6410E-06 + .4105E-06 + .2629E-06 + .1951E-06 + .1503E-06 + .1162E-06 + .9071E-07 + .7079E-07 + .6039E-07 + .5375E-07 + .4784E-07 + .4263E-07 + .3858E-07 + .3491E-07 + .2918E-07 + .2267E-07 + .1761E-07 + .1599E-07 + .1720E-05 + .1862E-05 + .1991E-05 + .2120E-05 + .2259E-05 + .2411E-05 + .2575E-05 + .2782E-05 + .2936E-05 + .3173E-05 + .3394E-05 + .3653E-05 + .3967E-05 + .4346E-05 + .4779E-05 + .5254E-05 + .5786E-05 + .6340E-05 + .6897E-05 + .7411E-05 + .7835E-05 + .8130E-05 + .8370E-05 + .8556E-05 + .8706E-05 + .8758E-05 + .8742E-05 + .8621E-05 + .8362E-05 + .7967E-05 + .7404E-05 + .6705E-05 + .5911E-05 + .5064E-05 + .4290E-05 + .3608E-05 + .2979E-05 + .2362E-05 + .1782E-05 + .1278E-05 + .8741E-06 + .5601E-06 + .3589E-06 + .2300E-06 + .1703E-06 + .1310E-06 + .1026E-06 + .8293E-07 + .6704E-07 + .5851E-07 + .5297E-07 + .4794E-07 + .4343E-07 + .3966E-07 + .3622E-07 + .3019E-07 + .2311E-07 + .1769E-07 + .1597E-07 + .1709E-05 + .1849E-05 + .1984E-05 + .2118E-05 + .2258E-05 + .2408E-05 + .2571E-05 + .2765E-05 + .2938E-05 + .3165E-05 + .3387E-05 + .3655E-05 + .3958E-05 + .4334E-05 + .4767E-05 + .5248E-05 + .5769E-05 + .6349E-05 + .6926E-05 + .7448E-05 + .7900E-05 + .8227E-05 + .8502E-05 + .8733E-05 + .8908E-05 + .8971E-05 + .8989E-05 + .8868E-05 + .8571E-05 + .8147E-05 + .7549E-05 + .6791E-05 + .5948E-05 + .5080E-05 + .4262E-05 + .3539E-05 + .2868E-05 + .2226E-05 + .1632E-05 + .1133E-05 + .7502E-06 + .4832E-06 + .3112E-06 + .2005E-06 + .1482E-06 + .1144E-06 + .9072E-07 + .7562E-07 + .6304E-07 + .5620E-07 + .5174E-07 + .4764E-07 + .4384E-07 + .4021E-07 + .3688E-07 + .3059E-07 + .2312E-07 + .1750E-07 + .1574E-07 + .1708E-05 + .1844E-05 + .1986E-05 + .2129E-05 + .2272E-05 + .2421E-05 + .2584E-05 + .2764E-05 + .2959E-05 + .3176E-05 + .3409E-05 + .3690E-05 + .3975E-05 + .4354E-05 + .4787E-05 + .5280E-05 + .5784E-05 + .6395E-05 + .7002E-05 + .7526E-05 + .8009E-05 + .8371E-05 + .8682E-05 + .8967E-05 + .9163E-05 + .9240E-05 + .9291E-05 + .9166E-05 + .8825E-05 + .8346E-05 + .7709E-05 + .6885E-05 + .6001E-05 + .5119E-05 + .4255E-05 + .3486E-05 + .2770E-05 + .2104E-05 + .1494E-05 + .9999E-06 + .6415E-06 + .4142E-06 + .2674E-06 + .1727E-06 + .1277E-06 + .1000E-06 + .8055E-07 + .6840E-07 + .5808E-07 + .5270E-07 + .4936E-07 + .4622E-07 + .4318E-07 + .3926E-07 + .3570E-07 + .2936E-07 + .2203E-07 + .1662E-07 + .1493E-07 + .1709E-05 + .1849E-05 + .1991E-05 + .2133E-05 + .2278E-05 + .2432E-05 + .2596E-05 + .2795E-05 + .2962E-05 + .3190E-05 + .3432E-05 + .3707E-05 + .3989E-05 + .4364E-05 + .4798E-05 + .5301E-05 + .5827E-05 + .6467E-05 + .7092E-05 + .7655E-05 + .8146E-05 + .8548E-05 + .8883E-05 + .9189E-05 + .9395E-05 + .9515E-05 + .9563E-05 + .9417E-05 + .9048E-05 + .8513E-05 + .7842E-05 + .6987E-05 + .6058E-05 + .5133E-05 + .4249E-05 + .3434E-05 + .2679E-05 + .1986E-05 + .1372E-05 + .8837E-06 + .5444E-06 + .3541E-06 + .2304E-06 + .1499E-06 + .1109E-06 + .8807E-07 + .7204E-07 + .6232E-07 + .5391E-07 + .4979E-07 + .4743E-07 + .4518E-07 + .4284E-07 + .3862E-07 + .3482E-07 + .2839E-07 + .2114E-07 + .1591E-07 + .1427E-07 + .1706E-05 + .1851E-05 + .1993E-05 + .2132E-05 + .2276E-05 + .2435E-05 + .2598E-05 + .2814E-05 + .2956E-05 + .3197E-05 + .3444E-05 + .3714E-05 + .3997E-05 + .4367E-05 + .4806E-05 + .5318E-05 + .5866E-05 + .6531E-05 + .7172E-05 + .7773E-05 + .8276E-05 + .8715E-05 + .9071E-05 + .9392E-05 + .9607E-05 + .9764E-05 + .9807E-05 + .9644E-05 + .9244E-05 + .8662E-05 + .7956E-05 + .7073E-05 + .6102E-05 + .5134E-05 + .4233E-05 + .3376E-05 + .2587E-05 + .1873E-05 + .1259E-05 + .7804E-06 + .4621E-06 + .3026E-06 + .1982E-06 + .1298E-06 + .9610E-07 + .7742E-07 + .6433E-07 + .5669E-07 + .4996E-07 + .4695E-07 + .4549E-07 + .4408E-07 + .4244E-07 + .3793E-07 + .3390E-07 + .2741E-07 + .2025E-07 + .1519E-07 + .1362E-07 + .1703E-05 + .1850E-05 + .1994E-05 + .2126E-05 + .2262E-05 + .2412E-05 + .2574E-05 + .2774E-05 + .2939E-05 + .3193E-05 + .3427E-05 + .3706E-05 + .4008E-05 + .4375E-05 + .4842E-05 + .5361E-05 + .5932E-05 + .6597E-05 + .7247E-05 + .7872E-05 + .8427E-05 + .8877E-05 + .9242E-05 + .9556E-05 + .9786E-05 + .9924E-05 + .9963E-05 + .9814E-05 + .9367E-05 + .8783E-05 + .8038E-05 + .7122E-05 + .6132E-05 + .5126E-05 + .4197E-05 + .3311E-05 + .2498E-05 + .1768E-05 + .1161E-05 + .6935E-06 + .3975E-06 + .2607E-06 + .1710E-06 + .1121E-06 + .8306E-07 + .6787E-07 + .5728E-07 + .5142E-07 + .4617E-07 + .4415E-07 + .4352E-07 + .4289E-07 + .4192E-07 + .3714E-07 + .3291E-07 + .2638E-07 + .1935E-07 + .1447E-07 + .1296E-07 + .1676E-05 + .1828E-05 + .1976E-05 + .2106E-05 + .2241E-05 + .2390E-05 + .2555E-05 + .2748E-05 + .2934E-05 + .3195E-05 + .3425E-05 + .3713E-05 + .4027E-05 + .4404E-05 + .4884E-05 + .5413E-05 + .6007E-05 + .6679E-05 + .7337E-05 + .7988E-05 + .8565E-05 + .9029E-05 + .9409E-05 + .9722E-05 + .9979E-05 + .1011E-04 + .1014E-04 + .9985E-05 + .9505E-05 + .8900E-05 + .8118E-05 + .7166E-05 + .6154E-05 + .5120E-05 + .4156E-05 + .3243E-05 + .2412E-05 + .1673E-05 + .1070E-05 + .6143E-06 + .3387E-06 + .2232E-06 + .1470E-06 + .9689E-07 + .7180E-07 + .5950E-07 + .5100E-07 + .4665E-07 + .4266E-07 + .4153E-07 + .4163E-07 + .4174E-07 + .4141E-07 + .3638E-07 + .3196E-07 + .2540E-07 + .1849E-07 + .1379E-07 + .1233E-07 + .1611E-05 + .1770E-05 + .1925E-05 + .2065E-05 + .2210E-05 + .2370E-05 + .2546E-05 + .2748E-05 + .2949E-05 + .3210E-05 + .3452E-05 + .3747E-05 + .4062E-05 + .4473E-05 + .4936E-05 + .5480E-05 + .6102E-05 + .6789E-05 + .7456E-05 + .8140E-05 + .8677E-05 + .9161E-05 + .9568E-05 + .9894E-05 + .1020E-04 + .1035E-04 + .1037E-04 + .1016E-04 + .9675E-05 + .9012E-05 + .8192E-05 + .7205E-05 + .6161E-05 + .5116E-05 + .4108E-05 + .3169E-05 + .2332E-05 + .1592E-05 + .9851E-06 + .5411E-06 + .2837E-06 + .1889E-06 + .1258E-06 + .8374E-07 + .6209E-07 + .5218E-07 + .4544E-07 + .4233E-07 + .3944E-07 + .3907E-07 + .3985E-07 + .4064E-07 + .4092E-07 + .3564E-07 + .3104E-07 + .2446E-07 + .1767E-07 + .1314E-07 + .1174E-07 + .1559E-05 + .1722E-05 + .1883E-05 + .2030E-05 + .2182E-05 + .2349E-05 + .2532E-05 + .2737E-05 + .2956E-05 + .3206E-05 + .3469E-05 + .3768E-05 + .4104E-05 + .4526E-05 + .4997E-05 + .5556E-05 + .6205E-05 + .6895E-05 + .7558E-05 + .8270E-05 + .8829E-05 + .9349E-05 + .9786E-05 + .1014E-04 + .1043E-04 + .1058E-04 + .1055E-04 + .1032E-04 + .9810E-05 + .9106E-05 + .8261E-05 + .7232E-05 + .6161E-05 + .5095E-05 + .4062E-05 + .3110E-05 + .2273E-05 + .1535E-05 + .9206E-06 + .4879E-06 + .2490E-06 + .1649E-06 + .1092E-06 + .7235E-07 + .5368E-07 + .4575E-07 + .4046E-07 + .3841E-07 + .3646E-07 + .3675E-07 + .3813E-07 + .3955E-07 + .4043E-07 + .3491E-07 + .3014E-07 + .2356E-07 + .1689E-07 + .1252E-07 + .1118E-07 + .1516E-05 + .1680E-05 + .1845E-05 + .1996E-05 + .2155E-05 + .2324E-05 + .2511E-05 + .2713E-05 + .2951E-05 + .3183E-05 + .3472E-05 + .3773E-05 + .4144E-05 + .4558E-05 + .5059E-05 + .5631E-05 + .6306E-05 + .6986E-05 + .7636E-05 + .8372E-05 + .9001E-05 + .9571E-05 + .1004E-04 + .1042E-04 + .1067E-04 + .1078E-04 + .1068E-04 + .1044E-04 + .9904E-05 + .9174E-05 + .8311E-05 + .7241E-05 + .6146E-05 + .5053E-05 + .4012E-05 + .3059E-05 + .2227E-05 + .1494E-05 + .8691E-06 + .4473E-06 + .2263E-06 + .1473E-06 + .9588E-07 + .6241E-07 + .4634E-07 + .4005E-07 + .3598E-07 + .3479E-07 + .3364E-07 + .3451E-07 + .3642E-07 + .3843E-07 + .3988E-07 + .3414E-07 + .2922E-07 + .2264E-07 + .1611E-07 + .1191E-07 + .1062E-07 + .1477E-05 + .1633E-05 + .1788E-05 + .1936E-05 + .2092E-05 + .2263E-05 + .2453E-05 + .2665E-05 + .2907E-05 + .3155E-05 + .3449E-05 + .3767E-05 + .4160E-05 + .4595E-05 + .5107E-05 + .5709E-05 + .6366E-05 + .7054E-05 + .7735E-05 + .8489E-05 + .9133E-05 + .9744E-05 + .1021E-04 + .1057E-04 + .1082E-04 + .1089E-04 + .1079E-04 + .1054E-04 + .9972E-05 + .9223E-05 + .8327E-05 + .7241E-05 + .6114E-05 + .5017E-05 + .3971E-05 + .3017E-05 + .2190E-05 + .1455E-05 + .8343E-06 + .4148E-06 + .2090E-06 + .1331E-06 + .8472E-07 + .5394E-07 + .4006E-07 + .3512E-07 + .3205E-07 + .3157E-07 + .3110E-07 + .3247E-07 + .3485E-07 + .3741E-07 + .3940E-07 + .3344E-07 + .2838E-07 + .2180E-07 + .1539E-07 + .1135E-07 + .1011E-07 + .1430E-05 + .1574E-05 + .1716E-05 + .1858E-05 + .2007E-05 + .2178E-05 + .2369E-05 + .2593E-05 + .2832E-05 + .3106E-05 + .3395E-05 + .3733E-05 + .4140E-05 + .4601E-05 + .5115E-05 + .5749E-05 + .6371E-05 + .7067E-05 + .7788E-05 + .8553E-05 + .9192E-05 + .9836E-05 + .1027E-04 + .1061E-04 + .1087E-04 + .1091E-04 + .1081E-04 + .1056E-04 + .9965E-05 + .9204E-05 + .8275E-05 + .7189E-05 + .6037E-05 + .4949E-05 + .3905E-05 + .2958E-05 + .2140E-05 + .1407E-05 + .7993E-06 + .3833E-06 + .1926E-06 + .1259E-06 + .8230E-07 + .5380E-07 + .4050E-07 + .3558E-07 + .3252E-07 + .3207E-07 + .3163E-07 + .3276E-07 + .3473E-07 + .3682E-07 + .3840E-07 + .3311E-07 + .2854E-07 + .2253E-07 + .1624E-07 + .1193E-07 + .1061E-07 + .1400E-05 + .1534E-05 + .1668E-05 + .1800E-05 + .1944E-05 + .2110E-05 + .2302E-05 + .2523E-05 + .2777E-05 + .3046E-05 + .3387E-05 + .3723E-05 + .4124E-05 + .4584E-05 + .5101E-05 + .5728E-05 + .6367E-05 + .7071E-05 + .7796E-05 + .8561E-05 + .9184E-05 + .9722E-05 + .1019E-04 + .1056E-04 + .1077E-04 + .1079E-04 + .1068E-04 + .1048E-04 + .9948E-05 + .9161E-05 + .8198E-05 + .7116E-05 + .5969E-05 + .4865E-05 + .3838E-05 + .2897E-05 + .2070E-05 + .1358E-05 + .7789E-06 + .3766E-06 + .1826E-06 + .1223E-06 + .8195E-07 + .5490E-07 + .4195E-07 + .3688E-07 + .3371E-07 + .3320E-07 + .3269E-07 + .3347E-07 + .3490E-07 + .3639E-07 + .3744E-07 + .3290E-07 + .2891E-07 + .2356E-07 + .1742E-07 + .1274E-07 + .1131E-07 + .1372E-05 + .1496E-05 + .1624E-05 + .1748E-05 + .1887E-05 + .2049E-05 + .2240E-05 + .2460E-05 + .2728E-05 + .2994E-05 + .3374E-05 + .3714E-05 + .4106E-05 + .4565E-05 + .5087E-05 + .5707E-05 + .6364E-05 + .7074E-05 + .7800E-05 + .8553E-05 + .9159E-05 + .9617E-05 + .1011E-04 + .1049E-04 + .1065E-04 + .1065E-04 + .1052E-04 + .1037E-04 + .9920E-05 + .9116E-05 + .8123E-05 + .7037E-05 + .5893E-05 + .4777E-05 + .3769E-05 + .2838E-05 + .2003E-05 + .1311E-05 + .7604E-06 + .3690E-06 + .1743E-06 + .1194E-06 + .8180E-07 + .5604E-07 + .4348E-07 + .3824E-07 + .3495E-07 + .3437E-07 + .3379E-07 + .3420E-07 + .3508E-07 + .3598E-07 + .3651E-07 + .3271E-07 + .2930E-07 + .2465E-07 + .1868E-07 + .1362E-07 + .1207E-07 + .1351E-05 + .1469E-05 + .1594E-05 + .1717E-05 + .1853E-05 + .2012E-05 + .2203E-05 + .2427E-05 + .2698E-05 + .2980E-05 + .3348E-05 + .3714E-05 + .4087E-05 + .4557E-05 + .5088E-05 + .5704E-05 + .6372E-05 + .7086E-05 + .7811E-05 + .8506E-05 + .9089E-05 + .9586E-05 + .1005E-04 + .1035E-04 + .1050E-04 + .1048E-04 + .1034E-04 + .1018E-04 + .9871E-05 + .9082E-05 + .8073E-05 + .6949E-05 + .5789E-05 + .4683E-05 + .3696E-05 + .2790E-05 + .1946E-05 + .1272E-05 + .7483E-06 + .3562E-06 + .1713E-06 + .1190E-06 + .8263E-07 + .5738E-07 + .4520E-07 + .3977E-07 + .3634E-07 + .3569E-07 + .3505E-07 + .3505E-07 + .3537E-07 + .3568E-07 + .3572E-07 + .3261E-07 + .2978E-07 + .2587E-07 + .2011E-07 + .1460E-07 + .1292E-07 + .1335E-05 + .1445E-05 + .1565E-05 + .1685E-05 + .1818E-05 + .1976E-05 + .2168E-05 + .2396E-05 + .2673E-05 + .2966E-05 + .3313E-05 + .3691E-05 + .4056E-05 + .4523E-05 + .5059E-05 + .5681E-05 + .6351E-05 + .7069E-05 + .7800E-05 + .8428E-05 + .8983E-05 + .9484E-05 + .9918E-05 + .1017E-04 + .1031E-04 + .1029E-04 + .1016E-04 + .1001E-04 + .9788E-05 + .9027E-05 + .8012E-05 + .6867E-05 + .5701E-05 + .4604E-05 + .3631E-05 + .2749E-05 + .1907E-05 + .1244E-05 + .7375E-06 + .3502E-06 + .1707E-06 + .1196E-06 + .8380E-07 + .5872E-07 + .4695E-07 + .4134E-07 + .3777E-07 + .3704E-07 + .3632E-07 + .3591E-07 + .3564E-07 + .3536E-07 + .3492E-07 + .3250E-07 + .3025E-07 + .2714E-07 + .2162E-07 + .1564E-07 + .1381E-07 + .1324E-05 + .1429E-05 + .1541E-05 + .1654E-05 + .1784E-05 + .1941E-05 + .2136E-05 + .2369E-05 + .2656E-05 + .2954E-05 + .3269E-05 + .3638E-05 + .4012E-05 + .4452E-05 + .4989E-05 + .5633E-05 + .6291E-05 + .7013E-05 + .7763E-05 + .8309E-05 + .8831E-05 + .9286E-05 + .9702E-05 + .9924E-05 + .1007E-04 + .1009E-04 + .9981E-05 + .9906E-05 + .9659E-05 + .8946E-05 + .7941E-05 + .6799E-05 + .5642E-05 + .4550E-05 + .3581E-05 + .2721E-05 + .1898E-05 + .1232E-05 + .7290E-06 + .3546E-06 + .1735E-06 + .1224E-06 + .8639E-07 + .6096E-07 + .4927E-07 + .4345E-07 + .3965E-07 + .3862E-07 + .3762E-07 + .3693E-07 + .3638E-07 + .3585E-07 + .3519E-07 + .3314E-07 + .3120E-07 + .2841E-07 + .2300E-07 + .1666E-07 + .1467E-07 + .1323E-05 + .1428E-05 + .1538E-05 + .1648E-05 + .1776E-05 + .1934E-05 + .2131E-05 + .2366E-05 + .2655E-05 + .2952E-05 + .3253E-05 + .3622E-05 + .3987E-05 + .4426E-05 + .4964E-05 + .5606E-05 + .6244E-05 + .6935E-05 + .7660E-05 + .8199E-05 + .8692E-05 + .9108E-05 + .9478E-05 + .9684E-05 + .9821E-05 + .9861E-05 + .9795E-05 + .9778E-05 + .9555E-05 + .8844E-05 + .7852E-05 + .6731E-05 + .5585E-05 + .4493E-05 + .3519E-05 + .2678E-05 + .1886E-05 + .1237E-05 + .7311E-06 + .3586E-06 + .1725E-06 + .1241E-06 + .8931E-07 + .6426E-07 + .5226E-07 + .4622E-07 + .4208E-07 + .4050E-07 + .3898E-07 + .3817E-07 + .3768E-07 + .3720E-07 + .3660E-07 + .3460E-07 + .3271E-07 + .2971E-07 + .2421E-07 + .1768E-07 + .1547E-07 + .1326E-05 + .1436E-05 + .1547E-05 + .1658E-05 + .1784E-05 + .1943E-05 + .2142E-05 + .2377E-05 + .2661E-05 + .2954E-05 + .3250E-05 + .3626E-05 + .3970E-05 + .4424E-05 + .4963E-05 + .5586E-05 + .6198E-05 + .6836E-05 + .7506E-05 + .8087E-05 + .8553E-05 + .8935E-05 + .9241E-05 + .9439E-05 + .9566E-05 + .9603E-05 + .9595E-05 + .9627E-05 + .9458E-05 + .8722E-05 + .7743E-05 + .6658E-05 + .5523E-05 + .4429E-05 + .3448E-05 + .2624E-05 + .1869E-05 + .1252E-05 + .7394E-06 + .3620E-06 + .1687E-06 + .1245E-06 + .9180E-07 + .6771E-07 + .5542E-07 + .4914E-07 + .4463E-07 + .4245E-07 + .4037E-07 + .3943E-07 + .3901E-07 + .3859E-07 + .3805E-07 + .3611E-07 + .3427E-07 + .3106E-07 + .2548E-07 + .1875E-07 + .1631E-07 + .1331E-05 + .1445E-05 + .1564E-05 + .1682E-05 + .1816E-05 + .1977E-05 + .2171E-05 + .2394E-05 + .2665E-05 + .2930E-05 + .3233E-05 + .3610E-05 + .3957E-05 + .4408E-05 + .4935E-05 + .5532E-05 + .6164E-05 + .6813E-05 + .7443E-05 + .7993E-05 + .8440E-05 + .8771E-05 + .9000E-05 + .9169E-05 + .9302E-05 + .9370E-05 + .9407E-05 + .9453E-05 + .9211E-05 + .8509E-05 + .7613E-05 + .6575E-05 + .5474E-05 + .4394E-05 + .3429E-05 + .2613E-05 + .1877E-05 + .1275E-05 + .7570E-06 + .3651E-06 + .1717E-06 + .1281E-06 + .9555E-07 + .7129E-07 + .5871E-07 + .5220E-07 + .4731E-07 + .4445E-07 + .4177E-07 + .4070E-07 + .4034E-07 + .3999E-07 + .3952E-07 + .3766E-07 + .3588E-07 + .3244E-07 + .2679E-07 + .1987E-07 + .1718E-07 + .1343E-05 + .1463E-05 + .1589E-05 + .1719E-05 + .1863E-05 + .2027E-05 + .2216E-05 + .2425E-05 + .2681E-05 + .2915E-05 + .3227E-05 + .3606E-05 + .3964E-05 + .4409E-05 + .4924E-05 + .5497E-05 + .6161E-05 + .6838E-05 + .7435E-05 + .7938E-05 + .8370E-05 + .8649E-05 + .8802E-05 + .8939E-05 + .9082E-05 + .9187E-05 + .9264E-05 + .9316E-05 + .8978E-05 + .8319E-05 + .7514E-05 + .6521E-05 + .5454E-05 + .4387E-05 + .3439E-05 + .2624E-05 + .1900E-05 + .1306E-05 + .7816E-06 + .3704E-06 + .1773E-06 + .1333E-06 + .1003E-06 + .7538E-07 + .6248E-07 + .5570E-07 + .5036E-07 + .4676E-07 + .4341E-07 + .4219E-07 + .4191E-07 + .4163E-07 + .4123E-07 + .3944E-07 + .3773E-07 + .3404E-07 + .2829E-07 + .2115E-07 + .1818E-07 + .1359E-05 + .1491E-05 + .1628E-05 + .1765E-05 + .1911E-05 + .2076E-05 + .2261E-05 + .2466E-05 + .2715E-05 + .2940E-05 + .3262E-05 + .3587E-05 + .3978E-05 + .4430E-05 + .4927E-05 + .5457E-05 + .6106E-05 + .6777E-05 + .7367E-05 + .7806E-05 + .8189E-05 + .8448E-05 + .8547E-05 + .8673E-05 + .8793E-05 + .8881E-05 + .8962E-05 + .9010E-05 + .8698E-05 + .8104E-05 + .7380E-05 + .6449E-05 + .5437E-05 + .4428E-05 + .3504E-05 + .2689E-05 + .1974E-05 + .1383E-05 + .8385E-06 + .4069E-06 + .1985E-06 + .1464E-06 + .1080E-06 + .7971E-07 + .6648E-07 + .5943E-07 + .5361E-07 + .4918E-07 + .4512E-07 + .4374E-07 + .4354E-07 + .4334E-07 + .4301E-07 + .4131E-07 + .3967E-07 + .3571E-07 + .2988E-07 + .2250E-07 + .1924E-07 + .1381E-05 + .1523E-05 + .1672E-05 + .1817E-05 + .1966E-05 + .2131E-05 + .2314E-05 + .2514E-05 + .2754E-05 + .2973E-05 + .3299E-05 + .3588E-05 + .4007E-05 + .4469E-05 + .4957E-05 + .5459E-05 + .6098E-05 + .6752E-05 + .7329E-05 + .7720E-05 + .8052E-05 + .8283E-05 + .8339E-05 + .8450E-05 + .8546E-05 + .8607E-05 + .8674E-05 + .8706E-05 + .8405E-05 + .7872E-05 + .7230E-05 + .6385E-05 + .5448E-05 + .4498E-05 + .3606E-05 + .2793E-05 + .2079E-05 + .1478E-05 + .9025E-06 + .4494E-06 + .2232E-06 + .1615E-06 + .1169E-06 + .8459E-07 + .7099E-07 + .6364E-07 + .5727E-07 + .5191E-07 + .4705E-07 + .4551E-07 + .4539E-07 + .4527E-07 + .4503E-07 + .4342E-07 + .4186E-07 + .3760E-07 + .3167E-07 + .2404E-07 + .2043E-07 + .1406E-05 + .1556E-05 + .1714E-05 + .1868E-05 + .2022E-05 + .2187E-05 + .2365E-05 + .2562E-05 + .2781E-05 + .3006E-05 + .3309E-05 + .3620E-05 + .4050E-05 + .4525E-05 + .5035E-05 + .5553E-05 + .6186E-05 + .6788E-05 + .7320E-05 + .7711E-05 + .7974E-05 + .8146E-05 + .8188E-05 + .8271E-05 + .8331E-05 + .8335E-05 + .8334E-05 + .8309E-05 + .7976E-05 + .7503E-05 + .6955E-05 + .6290E-05 + .5498E-05 + .4630E-05 + .3804E-05 + .3012E-05 + .2277E-05 + .1606E-05 + .9725E-06 + .5014E-06 + .2529E-06 + .1792E-06 + .1270E-06 + .9000E-07 + .7601E-07 + .6832E-07 + .6134E-07 + .5494E-07 + .4920E-07 + .4747E-07 + .4744E-07 + .4742E-07 + .4727E-07 + .4575E-07 + .4429E-07 + .3968E-07 + .3365E-07 + .2574E-07 + .2175E-07 + .1443E-05 + .1598E-05 + .1762E-05 + .1922E-05 + .2078E-05 + .2245E-05 + .2420E-05 + .2617E-05 + .2822E-05 + .3056E-05 + .3351E-05 + .3682E-05 + .4105E-05 + .4582E-05 + .5106E-05 + .5644E-05 + .6264E-05 + .6828E-05 + .7322E-05 + .7691E-05 + .7902E-05 + .8014E-05 + .8037E-05 + .8083E-05 + .8103E-05 + .8075E-05 + .8020E-05 + .7945E-05 + .7603E-05 + .7194E-05 + .6739E-05 + .6214E-05 + .5553E-05 + .4785E-05 + .4015E-05 + .3239E-05 + .2493E-05 + .1770E-05 + .1087E-05 + .5894E-06 + .3062E-06 + .2101E-06 + .1442E-06 + .9901E-07 + .8172E-07 + .7236E-07 + .6433E-07 + .5763E-07 + .5163E-07 + .4951E-07 + .4904E-07 + .4857E-07 + .4803E-07 + .4669E-07 + .4539E-07 + .4081E-07 + .3485E-07 + .2733E-07 + .2346E-07 + .1496E-05 + .1653E-05 + .1817E-05 + .1978E-05 + .2134E-05 + .2301E-05 + .2478E-05 + .2680E-05 + .2882E-05 + .3129E-05 + .3434E-05 + .3782E-05 + .4172E-05 + .4639E-05 + .5163E-05 + .5728E-05 + .6324E-05 + .6871E-05 + .7333E-05 + .7654E-05 + .7832E-05 + .7884E-05 + .7882E-05 + .7879E-05 + .7853E-05 + .7824E-05 + .7728E-05 + .7613E-05 + .7286E-05 + .6948E-05 + .6585E-05 + .6159E-05 + .5613E-05 + .4971E-05 + .4238E-05 + .3468E-05 + .2728E-05 + .1981E-05 + .1273E-05 + .7406E-06 + .4035E-06 + .2645E-06 + .1734E-06 + .1136E-06 + .8829E-07 + .7528E-07 + .6565E-07 + .5976E-07 + .5439E-07 + .5161E-07 + .4994E-07 + .4832E-07 + .4679E-07 + .4569E-07 + .4462E-07 + .4057E-07 + .3492E-07 + .2867E-07 + .2572E-07 + .1536E-05 + .1696E-05 + .1859E-05 + .2023E-05 + .2179E-05 + .2348E-05 + .2530E-05 + .2740E-05 + .2953E-05 + .3213E-05 + .3530E-05 + .3883E-05 + .4267E-05 + .4738E-05 + .5253E-05 + .5803E-05 + .6371E-05 + .6867E-05 + .7286E-05 + .7577E-05 + .7734E-05 + .7756E-05 + .7732E-05 + .7702E-05 + .7646E-05 + .7600E-05 + .7518E-05 + .7356E-05 + .7048E-05 + .6767E-05 + .6479E-05 + .6135E-05 + .5692E-05 + .5140E-05 + .4468E-05 + .3729E-05 + .2985E-05 + .2209E-05 + .1491E-05 + .9247E-06 + .5376E-06 + .3354E-06 + .2092E-06 + .1305E-06 + .9545E-07 + .7836E-07 + .6702E-07 + .6199E-07 + .5734E-07 + .5382E-07 + .5088E-07 + .4810E-07 + .4561E-07 + .4474E-07 + .4388E-07 + .4034E-07 + .3501E-07 + .3010E-07 + .2822E-07 + .1558E-05 + .1719E-05 + .1882E-05 + .2046E-05 + .2203E-05 + .2373E-05 + .2561E-05 + .2780E-05 + .3009E-05 + .3281E-05 + .3609E-05 + .3956E-05 + .4348E-05 + .4829E-05 + .5323E-05 + .5833E-05 + .6365E-05 + .6788E-05 + .7157E-05 + .7426E-05 + .7567E-05 + .7575E-05 + .7530E-05 + .7487E-05 + .7410E-05 + .7341E-05 + .7298E-05 + .7088E-05 + .6803E-05 + .6575E-05 + .6353E-05 + .6083E-05 + .5741E-05 + .5264E-05 + .4674E-05 + .3990E-05 + .3242E-05 + .2440E-05 + .1736E-05 + .1142E-05 + .7155E-06 + .4496E-06 + .2825E-06 + .1775E-06 + .1288E-06 + .1022E-06 + .8359E-07 + .7228E-07 + .6249E-07 + .5655E-07 + .5230E-07 + .4836E-07 + .4492E-07 + .4383E-07 + .4277E-07 + .3937E-07 + .3435E-07 + .2996E-07 + .2844E-07 + .1582E-05 + .1745E-05 + .1912E-05 + .2080E-05 + .2242E-05 + .2414E-05 + .2603E-05 + .2823E-05 + .3050E-05 + .3337E-05 + .3658E-05 + .4017E-05 + .4408E-05 + .4874E-05 + .5363E-05 + .5865E-05 + .6363E-05 + .6770E-05 + .7106E-05 + .7346E-05 + .7446E-05 + .7451E-05 + .7396E-05 + .7336E-05 + .7224E-05 + .7105E-05 + .7041E-05 + .6874E-05 + .6651E-05 + .6435E-05 + .6259E-05 + .6051E-05 + .5783E-05 + .5348E-05 + .4830E-05 + .4192E-05 + .3453E-05 + .2667E-05 + .1968E-05 + .1363E-05 + .9137E-06 + .5988E-06 + .3925E-06 + .2572E-06 + .1884E-06 + .1449E-06 + .1123E-06 + .8826E-07 + .6937E-07 + .5999E-07 + .5430E-07 + .4914E-07 + .4471E-07 + .4326E-07 + .4186E-07 + .3847E-07 + .3369E-07 + .2951E-07 + .2806E-07 + .1591E-05 + .1756E-05 + .1925E-05 + .2098E-05 + .2263E-05 + .2437E-05 + .2625E-05 + .2846E-05 + .3067E-05 + .3365E-05 + .3677E-05 + .4047E-05 + .4433E-05 + .4874E-05 + .5355E-05 + .5850E-05 + .6310E-05 + .6705E-05 + .7010E-05 + .7218E-05 + .7276E-05 + .7280E-05 + .7218E-05 + .7139E-05 + .6997E-05 + .6831E-05 + .6739E-05 + .6623E-05 + .6466E-05 + .6260E-05 + .6126E-05 + .5977E-05 + .5776E-05 + .5381E-05 + .4935E-05 + .4350E-05 + .3631E-05 + .2882E-05 + .2197E-05 + .1601E-05 + .1144E-05 + .7853E-06 + .5390E-06 + .3699E-06 + .2736E-06 + .2038E-06 + .1497E-06 + .1070E-06 + .7642E-07 + .6317E-07 + .5595E-07 + .4956E-07 + .4418E-07 + .4238E-07 + .4066E-07 + .3729E-07 + .3280E-07 + .2885E-07 + .2747E-07 + .1549E-05 + .1712E-05 + .1877E-05 + .2055E-05 + .2234E-05 + .2422E-05 + .2628E-05 + .2858E-05 + .3100E-05 + .3382E-05 + .3719E-05 + .4082E-05 + .4464E-05 + .4879E-05 + .5323E-05 + .5767E-05 + .6187E-05 + .6537E-05 + .6812E-05 + .7000E-05 + .7071E-05 + .7067E-05 + .6989E-05 + .6896E-05 + .6767E-05 + .6621E-05 + .6509E-05 + .6368E-05 + .6254E-05 + .6107E-05 + .6017E-05 + .5896E-05 + .5692E-05 + .5343E-05 + .4926E-05 + .4382E-05 + .3727E-05 + .3028E-05 + .2358E-05 + .1786E-05 + .1327E-05 + .9737E-06 + .7146E-06 + .5245E-06 + .3916E-06 + .2826E-06 + .1967E-06 + .1278E-06 + .8300E-07 + .6556E-07 + .5683E-07 + .4926E-07 + .4302E-07 + .4093E-07 + .3894E-07 + .3564E-07 + .3148E-07 + .2781E-07 + .2652E-07 + .1531E-05 + .1694E-05 + .1857E-05 + .2039E-05 + .2228E-05 + .2426E-05 + .2645E-05 + .2885E-05 + .3146E-05 + .3418E-05 + .3775E-05 + .4133E-05 + .4512E-05 + .4907E-05 + .5321E-05 + .5726E-05 + .6116E-05 + .6436E-05 + .6691E-05 + .6866E-05 + .6947E-05 + .6939E-05 + .6854E-05 + .6744E-05 + .6625E-05 + .6496E-05 + .6371E-05 + .6219E-05 + .6140E-05 + .6036E-05 + .5980E-05 + .5873E-05 + .5670E-05 + .5357E-05 + .4962E-05 + .4453E-05 + .3850E-05 + .3194E-05 + .2539E-05 + .1984E-05 + .1518E-05 + .1121E-05 + .8278E-06 + .6114E-06 + .4585E-06 + .3281E-06 + .2240E-06 + .1398E-06 + .8726E-07 + .6732E-07 + .5743E-07 + .4899E-07 + .4213E-07 + .3979E-07 + .3757E-07 + .3441E-07 + .3064E-07 + .2728E-07 + .2609E-07 + .1548E-05 + .1710E-05 + .1875E-05 + .2053E-05 + .2241E-05 + .2437E-05 + .2655E-05 + .2898E-05 + .3166E-05 + .3438E-05 + .3792E-05 + .4144E-05 + .4517E-05 + .4905E-05 + .5297E-05 + .5689E-05 + .6064E-05 + .6381E-05 + .6638E-05 + .6811E-05 + .6899E-05 + .6894E-05 + .6822E-05 + .6693E-05 + .6571E-05 + .6464E-05 + .6340E-05 + .6209E-05 + .6155E-05 + .6065E-05 + .6019E-05 + .5889E-05 + .5702E-05 + .5405E-05 + .5027E-05 + .4544E-05 + .3967E-05 + .3342E-05 + .2707E-05 + .2133E-05 + .1643E-05 + .1215E-05 + .8988E-06 + .6648E-06 + .4999E-06 + .3579E-06 + .2429E-06 + .1489E-06 + .9127E-07 + .6934E-07 + .5834E-07 + .4909E-07 + .4166E-07 + .3907E-07 + .3664E-07 + .3361E-07 + .3020E-07 + .2714E-07 + .2606E-07 + .1510E-05 + .1678E-05 + .1851E-05 + .2036E-05 + .2230E-05 + .2431E-05 + .2656E-05 + .2906E-05 + .3186E-05 + .3482E-05 + .3838E-05 + .4210E-05 + .4584E-05 + .4966E-05 + .5349E-05 + .5718E-05 + .6063E-05 + .6357E-05 + .6602E-05 + .6766E-05 + .6851E-05 + .6851E-05 + .6784E-05 + .6647E-05 + .6521E-05 + .6417E-05 + .6283E-05 + .6164E-05 + .6107E-05 + .6024E-05 + .5972E-05 + .5819E-05 + .5640E-05 + .5368E-05 + .5014E-05 + .4580E-05 + .4055E-05 + .3469E-05 + .2855E-05 + .2272E-05 + .1760E-05 + .1303E-05 + .9650E-06 + .7146E-06 + .5388E-06 + .3859E-06 + .2604E-06 + .1568E-06 + .9436E-07 + .7061E-07 + .5859E-07 + .4862E-07 + .4072E-07 + .3792E-07 + .3532E-07 + .3245E-07 + .2943E-07 + .2670E-07 + .2573E-07 + .1421E-05 + .1601E-05 + .1791E-05 + .1991E-05 + .2201E-05 + .2415E-05 + .2655E-05 + .2916E-05 + .3212E-05 + .3562E-05 + .3926E-05 + .4351E-05 + .4733E-05 + .5112E-05 + .5501E-05 + .5839E-05 + .6135E-05 + .6385E-05 + .6600E-05 + .6751E-05 + .6823E-05 + .6828E-05 + .6759E-05 + .6625E-05 + .6494E-05 + .6371E-05 + .6218E-05 + .6098E-05 + .6008E-05 + .5925E-05 + .5850E-05 + .5676E-05 + .5492E-05 + .5253E-05 + .4932E-05 + .4567E-05 + .4120E-05 + .3580E-05 + .2983E-05 + .2403E-05 + .1869E-05 + .1385E-05 + .1026E-05 + .7606E-06 + .5750E-06 + .4121E-06 + .2764E-06 + .1634E-06 + .9659E-07 + .7119E-07 + .5826E-07 + .4768E-07 + .3940E-07 + .3644E-07 + .3371E-07 + .3102E-07 + .2840E-07 + .2601E-07 + .2515E-07 + .1376E-05 + .1569E-05 + .1766E-05 + .1973E-05 + .2194E-05 + .2425E-05 + .2676E-05 + .2945E-05 + .3253E-05 + .3621E-05 + .3995E-05 + .4425E-05 + .4823E-05 + .5198E-05 + .5581E-05 + .5924E-05 + .6225E-05 + .6471E-05 + .6697E-05 + .6881E-05 + .7006E-05 + .7087E-05 + .6975E-05 + .6783E-05 + .6594E-05 + .6413E-05 + .6220E-05 + .6083E-05 + .5961E-05 + .5853E-05 + .5747E-05 + .5569E-05 + .5390E-05 + .5180E-05 + .4864E-05 + .4518E-05 + .4121E-05 + .3615E-05 + .3064E-05 + .2457E-05 + .1916E-05 + .1438E-05 + .1079E-05 + .8101E-06 + .6043E-06 + .4368E-06 + .2922E-06 + .1687E-06 + .9739E-07 + .7068E-07 + .5718E-07 + .4626E-07 + .3782E-07 + .3485E-07 + .3212E-07 + .2974E-07 + .2766E-07 + .2572E-07 + .2501E-07 + .1346E-05 + .1552E-05 + .1750E-05 + .1960E-05 + .2189E-05 + .2438E-05 + .2696E-05 + .2974E-05 + .3290E-05 + .3658E-05 + .4041E-05 + .4453E-05 + .4868E-05 + .5237E-05 + .5607E-05 + .5970E-05 + .6302E-05 + .6561E-05 + .6816E-05 + .7055E-05 + .7270E-05 + .7466E-05 + .7287E-05 + .7005E-05 + .6732E-05 + .6471E-05 + .6232E-05 + .6068E-05 + .5916E-05 + .5773E-05 + .5633E-05 + .5461E-05 + .5291E-05 + .5108E-05 + .4785E-05 + .4438E-05 + .4079E-05 + .3602E-05 + .3110E-05 + .2464E-05 + .1925E-05 + .1472E-05 + .1125E-05 + .8600E-06 + .6286E-06 + .4599E-06 + .3073E-06 + .1728E-06 + .9718E-07 + .6944E-07 + .5559E-07 + .4450E-07 + .3602E-07 + .3314E-07 + .3048E-07 + .2846E-07 + .2695E-07 + .2552E-07 + .2499E-07 + .1312E-05 + .1530E-05 + .1730E-05 + .1941E-05 + .2178E-05 + .2444E-05 + .2709E-05 + .2994E-05 + .3317E-05 + .3683E-05 + .4074E-05 + .4467E-05 + .4898E-05 + .5259E-05 + .5617E-05 + .5999E-05 + .6361E-05 + .6633E-05 + .6916E-05 + .7212E-05 + .7520E-05 + .7842E-05 + .7590E-05 + .7212E-05 + .6852E-05 + .6510E-05 + .6224E-05 + .6036E-05 + .5853E-05 + .5676E-05 + .5505E-05 + .5338E-05 + .5177E-05 + .5020E-05 + .4692E-05 + .4346E-05 + .4025E-05 + .3578E-05 + .3148E-05 + .2464E-05 + .1929E-05 + .1502E-05 + .1169E-05 + .9101E-06 + .6518E-06 + .4827E-06 + .3222E-06 + .1765E-06 + .9668E-07 + .6801E-07 + .5388E-07 + .4268E-07 + .3421E-07 + .3141E-07 + .2884E-07 + .2716E-07 + .2618E-07 + .2524E-07 + .2489E-07 + .1322E-05 + .1525E-05 + .1720E-05 + .1930E-05 + .2166E-05 + .2430E-05 + .2688E-05 + .2968E-05 + .3290E-05 + .3658E-05 + .4050E-05 + .4451E-05 + .4884E-05 + .5245E-05 + .5611E-05 + .6003E-05 + .6363E-05 + .6665E-05 + .6980E-05 + .7310E-05 + .7632E-05 + .7874E-05 + .7609E-05 + .7222E-05 + .6841E-05 + .6479E-05 + .6165E-05 + .5970E-05 + .5782E-05 + .5600E-05 + .5423E-05 + .5253E-05 + .5087E-05 + .4906E-05 + .4588E-05 + .4262E-05 + .3959E-05 + .3541E-05 + .3144E-05 + .2487E-05 + .1927E-05 + .1523E-05 + .1203E-05 + .9506E-06 + .6861E-06 + .4993E-06 + .3302E-06 + .1819E-06 + .1002E-06 + .7025E-07 + .5521E-07 + .4339E-07 + .3455E-07 + .3198E-07 + .2960E-07 + .2797E-07 + .2692E-07 + .2592E-07 + .2554E-07 + .1332E-05 + .1521E-05 + .1712E-05 + .1921E-05 + .2155E-05 + .2418E-05 + .2670E-05 + .2944E-05 + .3265E-05 + .3635E-05 + .4030E-05 + .4439E-05 + .4874E-05 + .5235E-05 + .5610E-05 + .6012E-05 + .6372E-05 + .6703E-05 + .7051E-05 + .7417E-05 + .7752E-05 + .7914E-05 + .7635E-05 + .7239E-05 + .6835E-05 + .6454E-05 + .6111E-05 + .5911E-05 + .5717E-05 + .5530E-05 + .5348E-05 + .5173E-05 + .5003E-05 + .4799E-05 + .4490E-05 + .4183E-05 + .3898E-05 + .3508E-05 + .3142E-05 + .2512E-05 + .1927E-05 + .1546E-05 + .1239E-05 + .9937E-06 + .7228E-06 + .5169E-06 + .3386E-06 + .1877E-06 + .1040E-06 + .7263E-07 + .5663E-07 + .4415E-07 + .3492E-07 + .3259E-07 + .3042E-07 + .2883E-07 + .2771E-07 + .2664E-07 + .2624E-07 + .1340E-05 + .1513E-05 + .1699E-05 + .1907E-05 + .2139E-05 + .2401E-05 + .2645E-05 + .2914E-05 + .3233E-05 + .3604E-05 + .4000E-05 + .4416E-05 + .4851E-05 + .5213E-05 + .5596E-05 + .6007E-05 + .6364E-05 + .6724E-05 + .7104E-05 + .7506E-05 + .7854E-05 + .7934E-05 + .7642E-05 + .7237E-05 + .6813E-05 + .6413E-05 + .6043E-05 + .5838E-05 + .5639E-05 + .5447E-05 + .5261E-05 + .5082E-05 + .4909E-05 + .4682E-05 + .4383E-05 + .4096E-05 + .3828E-05 + .3466E-05 + .3132E-05 + .2531E-05 + .1923E-05 + .1565E-05 + .1273E-05 + .1036E-05 + .7596E-06 + .5339E-06 + .3465E-06 + .1931E-06 + .1076E-06 + .7491E-07 + .5794E-07 + .4481E-07 + .3521E-07 + .3313E-07 + .3117E-07 + .2964E-07 + .2845E-07 + .2732E-07 + .2689E-07 + .1339E-05 + .1503E-05 + .1683E-05 + .1885E-05 + .2112E-05 + .2365E-05 + .2604E-05 + .2866E-05 + .3178E-05 + .3544E-05 + .3936E-05 + .4353E-05 + .4790E-05 + .5158E-05 + .5547E-05 + .5966E-05 + .6327E-05 + .6705E-05 + .7107E-05 + .7532E-05 + .7849E-05 + .7872E-05 + .7564E-05 + .7162E-05 + .6738E-05 + .6340E-05 + .5970E-05 + .5763E-05 + .5562E-05 + .5369E-05 + .5182E-05 + .5001E-05 + .4827E-05 + .4584E-05 + .4294E-05 + .4023E-05 + .3767E-05 + .3425E-05 + .3115E-05 + .2534E-05 + .1913E-05 + .1583E-05 + .1309E-05 + .1083E-05 + .7999E-06 + .5526E-06 + .3552E-06 + .1992E-06 + .1116E-06 + .7743E-07 + .5941E-07 + .4559E-07 + .3558E-07 + .3375E-07 + .3202E-07 + .3054E-07 + .2928E-07 + .2807E-07 + .2762E-07 + .1328E-05 + .1490E-05 + .1662E-05 + .1854E-05 + .2068E-05 + .2306E-05 + .2541E-05 + .2797E-05 + .3094E-05 + .3446E-05 + .3826E-05 + .4237E-05 + .4675E-05 + .5059E-05 + .5453E-05 + .5877E-05 + .6249E-05 + .6632E-05 + .7037E-05 + .7468E-05 + .7693E-05 + .7697E-05 + .7370E-05 + .6986E-05 + .6593E-05 + .6222E-05 + .5891E-05 + .5686E-05 + .5488E-05 + .5297E-05 + .5113E-05 + .4935E-05 + .4763E-05 + .4510E-05 + .4232E-05 + .3970E-05 + .3717E-05 + .3387E-05 + .3086E-05 + .2512E-05 + .1897E-05 + .1599E-05 + .1347E-05 + .1135E-05 + .8450E-06 + .5737E-06 + .3654E-06 + .2060E-06 + .1162E-06 + .8028E-07 + .6111E-07 + .4651E-07 + .3606E-07 + .3449E-07 + .3299E-07 + .3157E-07 + .3022E-07 + .2893E-07 + .2845E-07 + .1327E-05 + .1489E-05 + .1654E-05 + .1838E-05 + .2041E-05 + .2267E-05 + .2499E-05 + .2751E-05 + .3036E-05 + .3377E-05 + .3750E-05 + .4157E-05 + .4601E-05 + .5003E-05 + .5403E-05 + .5835E-05 + .6222E-05 + .6611E-05 + .7025E-05 + .7465E-05 + .7601E-05 + .7587E-05 + .7239E-05 + .6869E-05 + .6503E-05 + .6156E-05 + .5859E-05 + .5655E-05 + .5458E-05 + .5269E-05 + .5085E-05 + .4908E-05 + .4737E-05 + .4473E-05 + .4203E-05 + .3949E-05 + .3697E-05 + .3375E-05 + .3082E-05 + .2511E-05 + .1896E-05 + .1609E-05 + .1366E-05 + .1159E-05 + .8651E-06 + .5835E-06 + .3703E-06 + .2092E-06 + .1182E-06 + .8161E-07 + .6193E-07 + .4700E-07 + .3634E-07 + .3487E-07 + .3346E-07 + .3205E-07 + .3067E-07 + .2934E-07 + .2885E-07 + .1334E-05 + .1496E-05 + .1655E-05 + .1831E-05 + .2025E-05 + .2240E-05 + .2471E-05 + .2720E-05 + .2995E-05 + .3326E-05 + .3693E-05 + .4100E-05 + .4550E-05 + .4972E-05 + .5381E-05 + .5823E-05 + .6226E-05 + .6625E-05 + .7049E-05 + .7500E-05 + .7549E-05 + .7517E-05 + .7147E-05 + .6789E-05 + .6447E-05 + .6122E-05 + .5857E-05 + .5654E-05 + .5457E-05 + .5267E-05 + .5084E-05 + .4907E-05 + .4736E-05 + .4460E-05 + .4196E-05 + .3949E-05 + .3696E-05 + .3381E-05 + .3094E-05 + .2523E-05 + .1905E-05 + .1617E-05 + .1372E-05 + .1164E-05 + .8691E-06 + .5862E-06 + .3720E-06 + .2102E-06 + .1188E-06 + .8199E-07 + .6222E-07 + .4722E-07 + .3651E-07 + .3503E-07 + .3361E-07 + .3220E-07 + .3081E-07 + .2948E-07 + .2898E-07 + .1304E-05 + .1458E-05 + .1611E-05 + .1780E-05 + .1967E-05 + .2173E-05 + .2402E-05 + .2650E-05 + .2924E-05 + .3247E-05 + .3606E-05 + .4005E-05 + .4449E-05 + .4884E-05 + .5311E-05 + .5753E-05 + .6176E-05 + .6565E-05 + .6939E-05 + .7335E-05 + .7417E-05 + .7342E-05 + .7012E-05 + .6697E-05 + .6396E-05 + .6103E-05 + .5858E-05 + .5657E-05 + .5464E-05 + .5277E-05 + .5096E-05 + .4922E-05 + .4726E-05 + .4451E-05 + .4192E-05 + .3949E-05 + .3687E-05 + .3384E-05 + .3105E-05 + .2502E-05 + .1901E-05 + .1621E-05 + .1382E-05 + .1178E-05 + .8796E-06 + .5933E-06 + .3765E-06 + .2128E-06 + .1202E-06 + .8298E-07 + .6297E-07 + .4779E-07 + .3695E-07 + .3546E-07 + .3402E-07 + .3259E-07 + .3118E-07 + .2984E-07 + .2934E-07 + .1269E-05 + .1412E-05 + .1559E-05 + .1722E-05 + .1902E-05 + .2101E-05 + .2327E-05 + .2574E-05 + .2848E-05 + .3164E-05 + .3515E-05 + .3905E-05 + .4339E-05 + .4785E-05 + .5232E-05 + .5672E-05 + .6114E-05 + .6491E-05 + .6805E-05 + .7135E-05 + .7272E-05 + .7150E-05 + .6871E-05 + .6603E-05 + .6346E-05 + .6086E-05 + .5859E-05 + .5662E-05 + .5472E-05 + .5288E-05 + .5111E-05 + .4939E-05 + .4714E-05 + .4444E-05 + .4189E-05 + .3949E-05 + .3676E-05 + .3385E-05 + .3117E-05 + .2475E-05 + .1893E-05 + .1624E-05 + .1393E-05 + .1194E-05 + .8916E-06 + .6013E-06 + .3816E-06 + .2157E-06 + .1219E-06 + .8411E-07 + .6383E-07 + .4844E-07 + .3746E-07 + .3594E-07 + .3448E-07 + .3304E-07 + .3161E-07 + .3024E-07 + .2974E-07 + .1234E-05 + .1367E-05 + .1509E-05 + .1666E-05 + .1840E-05 + .2031E-05 + .2254E-05 + .2501E-05 + .2774E-05 + .3083E-05 + .3426E-05 + .3808E-05 + .4232E-05 + .4688E-05 + .5154E-05 + .5592E-05 + .6052E-05 + .6417E-05 + .6673E-05 + .6940E-05 + .7129E-05 + .6963E-05 + .6733E-05 + .6510E-05 + .6296E-05 + .6068E-05 + .5859E-05 + .5666E-05 + .5480E-05 + .5300E-05 + .5125E-05 + .4957E-05 + .4702E-05 + .4436E-05 + .4185E-05 + .3948E-05 + .3665E-05 + .3386E-05 + .3128E-05 + .2449E-05 + .1886E-05 + .1627E-05 + .1403E-05 + .1210E-05 + .9035E-06 + .6094E-06 + .3868E-06 + .2186E-06 + .1235E-06 + .8524E-07 + .6468E-07 + .4909E-07 + .3796E-07 + .3642E-07 + .3494E-07 + .3348E-07 + .3203E-07 + .3065E-07 + .3013E-07 + .1449E-05 + .1565E-05 + .1684E-05 + .1806E-05 + .1937E-05 + .2077E-05 + .2232E-05 + .2399E-05 + .2578E-05 + .2795E-05 + .3031E-05 + .3289E-05 + .3587E-05 + .3915E-05 + .4161E-05 + .4299E-05 + .4441E-05 + .4440E-05 + .4418E-05 + .4344E-05 + .4272E-05 + .4201E-05 + .4083E-05 + .3968E-05 + .3856E-05 + .3748E-05 + .3637E-05 + .3527E-05 + .3421E-05 + .3318E-05 + .3213E-05 + .3112E-05 + .3012E-05 + .2915E-05 + .2821E-05 + .2730E-05 + .2642E-05 + .2451E-05 + .2132E-05 + .1849E-05 + .1604E-05 + .1261E-05 + .9917E-06 + .7797E-06 + .5736E-06 + .4829E-06 + .3618E-06 + .2171E-06 + .1302E-06 + .8457E-07 + .5703E-07 + .3846E-07 + .2649E-07 + .2324E-07 + .2039E-07 + .1661E-07 + .1263E-07 + .9602E-08 + .8647E-08 + .1440E-05 + .1555E-05 + .1674E-05 + .1796E-05 + .1925E-05 + .2065E-05 + .2219E-05 + .2384E-05 + .2562E-05 + .2773E-05 + .3003E-05 + .3252E-05 + .3554E-05 + .3890E-05 + .4160E-05 + .4325E-05 + .4496E-05 + .4576E-05 + .4605E-05 + .4511E-05 + .4419E-05 + .4329E-05 + .4209E-05 + .4092E-05 + .3978E-05 + .3867E-05 + .3746E-05 + .3624E-05 + .3507E-05 + .3394E-05 + .3281E-05 + .3172E-05 + .3063E-05 + .2956E-05 + .2853E-05 + .2754E-05 + .2658E-05 + .2496E-05 + .2166E-05 + .1870E-05 + .1613E-05 + .1265E-05 + .9922E-06 + .7781E-06 + .5724E-06 + .4819E-06 + .3611E-06 + .2166E-06 + .1299E-06 + .8439E-07 + .5691E-07 + .3838E-07 + .2643E-07 + .2319E-07 + .2035E-07 + .1657E-07 + .1260E-07 + .9582E-08 + .8629E-08 + .1436E-05 + .1550E-05 + .1670E-05 + .1790E-05 + .1920E-05 + .2059E-05 + .2212E-05 + .2377E-05 + .2555E-05 + .2760E-05 + .2984E-05 + .3226E-05 + .3532E-05 + .3878E-05 + .4171E-05 + .4364E-05 + .4566E-05 + .4732E-05 + .4816E-05 + .4700E-05 + .4587E-05 + .4476E-05 + .4353E-05 + .4233E-05 + .4116E-05 + .4003E-05 + .3870E-05 + .3737E-05 + .3607E-05 + .3482E-05 + .3360E-05 + .3243E-05 + .3125E-05 + .3008E-05 + .2895E-05 + .2787E-05 + .2682E-05 + .2550E-05 + .2209E-05 + .1896E-05 + .1628E-05 + .1273E-05 + .9958E-06 + .7788E-06 + .5730E-06 + .4824E-06 + .3614E-06 + .2168E-06 + .1301E-06 + .8447E-07 + .5697E-07 + .3842E-07 + .2646E-07 + .2321E-07 + .2037E-07 + .1659E-07 + .1261E-07 + .9591E-08 + .8638E-08 + .1433E-05 + .1548E-05 + .1666E-05 + .1784E-05 + .1910E-05 + .2047E-05 + .2198E-05 + .2362E-05 + .2537E-05 + .2736E-05 + .2956E-05 + .3194E-05 + .3500E-05 + .3851E-05 + .4173E-05 + .4414E-05 + .4653E-05 + .4886E-05 + .5017E-05 + .4911E-05 + .4796E-05 + .4671E-05 + .4543E-05 + .4412E-05 + .4281E-05 + .4150E-05 + .4001E-05 + .3854E-05 + .3714E-05 + .3582E-05 + .3461E-05 + .3339E-05 + .3202E-05 + .3033E-05 + .2897E-05 + .2805E-05 + .2722E-05 + .2609E-05 + .2285E-05 + .1958E-05 + .1665E-05 + .1292E-05 + .1003E-05 + .7780E-06 + .5723E-06 + .4819E-06 + .3610E-06 + .2166E-06 + .1299E-06 + .8438E-07 + .5691E-07 + .3838E-07 + .2643E-07 + .2319E-07 + .2035E-07 + .1657E-07 + .1260E-07 + .9581E-08 + .8629E-08 + .1426E-05 + .1540E-05 + .1645E-05 + .1750E-05 + .1861E-05 + .1987E-05 + .2125E-05 + .2282E-05 + .2448E-05 + .2635E-05 + .2852E-05 + .3090E-05 + .3381E-05 + .3712E-05 + .4074E-05 + .4417E-05 + .4709E-05 + .4924E-05 + .5054E-05 + .5092E-05 + .5065E-05 + .4967E-05 + .4836E-05 + .4670E-05 + .4488E-05 + .4295E-05 + .4118E-05 + .3957E-05 + .3812E-05 + .3680E-05 + .3588E-05 + .3478E-05 + .3294E-05 + .2970E-05 + .2780E-05 + .2775E-05 + .2784E-05 + .2636E-05 + .2427E-05 + .2097E-05 + .1735E-05 + .1318E-05 + .1001E-05 + .7606E-06 + .5595E-06 + .4711E-06 + .3529E-06 + .2117E-06 + .1270E-06 + .8249E-07 + .5563E-07 + .3752E-07 + .2584E-07 + .2267E-07 + .1989E-07 + .1620E-07 + .1232E-07 + .9366E-08 + .8435E-08 + .1469E-05 + .1576E-05 + .1673E-05 + .1773E-05 + .1879E-05 + .2000E-05 + .2135E-05 + .2288E-05 + .2446E-05 + .2629E-05 + .2844E-05 + .3085E-05 + .3377E-05 + .3711E-05 + .4090E-05 + .4450E-05 + .4786E-05 + .5043E-05 + .5222E-05 + .5303E-05 + .5316E-05 + .5244E-05 + .5131E-05 + .4981E-05 + .4815E-05 + .4630E-05 + .4446E-05 + .4253E-05 + .4082E-05 + .3896E-05 + .3759E-05 + .3632E-05 + .3444E-05 + .3211E-05 + .3045E-05 + .2984E-05 + .2885E-05 + .2689E-05 + .2437E-05 + .2078E-05 + .1700E-05 + .1286E-05 + .9728E-06 + .7360E-06 + .5413E-06 + .4545E-06 + .3411E-06 + .2066E-06 + .1252E-06 + .8207E-07 + .5588E-07 + .3805E-07 + .2644E-07 + .2324E-07 + .2043E-07 + .1666E-07 + .1268E-07 + .9647E-08 + .8691E-08 + .1528E-05 + .1633E-05 + .1729E-05 + .1828E-05 + .1934E-05 + .2057E-05 + .2192E-05 + .2350E-05 + .2505E-05 + .2698E-05 + .2912E-05 + .3160E-05 + .3451E-05 + .3792E-05 + .4189E-05 + .4575E-05 + .4957E-05 + .5272E-05 + .5502E-05 + .5640E-05 + .5696E-05 + .5659E-05 + .5570E-05 + .5445E-05 + .5302E-05 + .5120E-05 + .4929E-05 + .4712E-05 + .4515E-05 + .4277E-05 + .4096E-05 + .3924E-05 + .3699E-05 + .3486E-05 + .3307E-05 + .3197E-05 + .3016E-05 + .2784E-05 + .2487E-05 + .2093E-05 + .1690E-05 + .1246E-05 + .9180E-06 + .6765E-06 + .4973E-06 + .4147E-06 + .3126E-06 + .1943E-06 + .1207E-06 + .8122E-07 + .5673E-07 + .3963E-07 + .2821E-07 + .2490E-07 + .2199E-07 + .1799E-07 + .1372E-07 + .1046E-07 + .9434E-08 + .1567E-05 + .1675E-05 + .1773E-05 + .1875E-05 + .1985E-05 + .2111E-05 + .2250E-05 + .2418E-05 + .2571E-05 + .2787E-05 + .2995E-05 + .3251E-05 + .3528E-05 + .3873E-05 + .4281E-05 + .4692E-05 + .5116E-05 + .5499E-05 + .5780E-05 + .5992E-05 + .6094E-05 + .6103E-05 + .6050E-05 + .5966E-05 + .5863E-05 + .5684E-05 + .5492E-05 + .5264E-05 + .5049E-05 + .4766E-05 + .4543E-05 + .4295E-05 + .3994E-05 + .3709E-05 + .3474E-05 + .3329E-05 + .3107E-05 + .2857E-05 + .2518E-05 + .2094E-05 + .1666E-05 + .1198E-05 + .8618E-06 + .6197E-06 + .4552E-06 + .3771E-06 + .2855E-06 + .1820E-06 + .1160E-06 + .8009E-07 + .5739E-07 + .4113E-07 + .2998E-07 + .2659E-07 + .2358E-07 + .1936E-07 + .1480E-07 + .1131E-07 + .1020E-07 + .1629E-05 + .1739E-05 + .1837E-05 + .1937E-05 + .2049E-05 + .2177E-05 + .2319E-05 + .2493E-05 + .2644E-05 + .2870E-05 + .3078E-05 + .3344E-05 + .3626E-05 + .3984E-05 + .4397E-05 + .4821E-05 + .5283E-05 + .5719E-05 + .6041E-05 + .6300E-05 + .6436E-05 + .6476E-05 + .6461E-05 + .6410E-05 + .6330E-05 + .6168E-05 + .5982E-05 + .5741E-05 + .5519E-05 + .5208E-05 + .4939E-05 + .4641E-05 + .4301E-05 + .3957E-05 + .3690E-05 + .3476E-05 + .3194E-05 + .2900E-05 + .2517E-05 + .2070E-05 + .1628E-05 + .1143E-05 + .8027E-06 + .5635E-06 + .4137E-06 + .3404E-06 + .2588E-06 + .1693E-06 + .1107E-06 + .7840E-07 + .5764E-07 + .4238E-07 + .3164E-07 + .2818E-07 + .2511E-07 + .2068E-07 + .1584E-07 + .1213E-07 + .1096E-07 + .1694E-05 + .1802E-05 + .1898E-05 + .1996E-05 + .2107E-05 + .2237E-05 + .2379E-05 + .2557E-05 + .2703E-05 + .2932E-05 + .3141E-05 + .3420E-05 + .3713E-05 + .4085E-05 + .4498E-05 + .4925E-05 + .5422E-05 + .5903E-05 + .6260E-05 + .6549E-05 + .6716E-05 + .6779E-05 + .6804E-05 + .6783E-05 + .6718E-05 + .6584E-05 + .6409E-05 + .6155E-05 + .5933E-05 + .5607E-05 + .5288E-05 + .4954E-05 + .4595E-05 + .4199E-05 + .3915E-05 + .3611E-05 + .3260E-05 + .2910E-05 + .2485E-05 + .2022E-05 + .1575E-05 + .1080E-05 + .7402E-06 + .5075E-06 + .3724E-06 + .3043E-06 + .2324E-06 + .1559E-06 + .1046E-06 + .7601E-07 + .5733E-07 + .4324E-07 + .3306E-07 + .2959E-07 + .2647E-07 + .2188E-07 + .1679E-07 + .1289E-07 + .1165E-07 + .1691E-05 + .1802E-05 + .1905E-05 + .2013E-05 + .2135E-05 + .2277E-05 + .2427E-05 + .2628E-05 + .2758E-05 + .2989E-05 + .3203E-05 + .3471E-05 + .3777E-05 + .4153E-05 + .4563E-05 + .5030E-05 + .5523E-05 + .6010E-05 + .6420E-05 + .6720E-05 + .6955E-05 + .7032E-05 + .7109E-05 + .7081E-05 + .7051E-05 + .6928E-05 + .6781E-05 + .6556E-05 + .6325E-05 + .6007E-05 + .5670E-05 + .5290E-05 + .4878E-05 + .4421E-05 + .4071E-05 + .3693E-05 + .3289E-05 + .2882E-05 + .2435E-05 + .1962E-05 + .1514E-05 + .1013E-05 + .6770E-06 + .4527E-06 + .3319E-06 + .2694E-06 + .2066E-06 + .1423E-06 + .9794E-07 + .7299E-07 + .5648E-07 + .4370E-07 + .3422E-07 + .3076E-07 + .2765E-07 + .2292E-07 + .1764E-07 + .1357E-07 + .1228E-07 + .1670E-05 + .1783E-05 + .1894E-05 + .2012E-05 + .2146E-05 + .2299E-05 + .2456E-05 + .2680E-05 + .2795E-05 + .3028E-05 + .3244E-05 + .3499E-05 + .3815E-05 + .4190E-05 + .4600E-05 + .5097E-05 + .5582E-05 + .6067E-05 + .6526E-05 + .6840E-05 + .7142E-05 + .7232E-05 + .7360E-05 + .7325E-05 + .7329E-05 + .7218E-05 + .7105E-05 + .6916E-05 + .6683E-05 + .6374E-05 + .6020E-05 + .5592E-05 + .5119E-05 + .4603E-05 + .4182E-05 + .3736E-05 + .3284E-05 + .2827E-05 + .2363E-05 + .1886E-05 + .1442E-05 + .9411E-06 + .6141E-06 + .4007E-06 + .2937E-06 + .2367E-06 + .1823E-06 + .1288E-06 + .9098E-07 + .6955E-07 + .5521E-07 + .4383E-07 + .3516E-07 + .3174E-07 + .2866E-07 + .2384E-07 + .1838E-07 + .1417E-07 + .1283E-07 + .1661E-05 + .1777E-05 + .1893E-05 + .2026E-05 + .2168E-05 + .2327E-05 + .2490E-05 + .2718E-05 + .2849E-05 + .3100E-05 + .3307E-05 + .3583E-05 + .3897E-05 + .4253E-05 + .4711E-05 + .5160E-05 + .5672E-05 + .6157E-05 + .6630E-05 + .7007E-05 + .7327E-05 + .7432E-05 + .7557E-05 + .7571E-05 + .7547E-05 + .7463E-05 + .7389E-05 + .7204E-05 + .7016E-05 + .6669E-05 + .6245E-05 + .5773E-05 + .5224E-05 + .4685E-05 + .4218E-05 + .3726E-05 + .3247E-05 + .2757E-05 + .2268E-05 + .1788E-05 + .1355E-05 + .8694E-06 + .5577E-06 + .3577E-06 + .2620E-06 + .2098E-06 + .1623E-06 + .1176E-06 + .8522E-07 + .6685E-07 + .5444E-07 + .4433E-07 + .3642E-07 + .3303E-07 + .2996E-07 + .2500E-07 + .1932E-07 + .1493E-07 + .1353E-07 + .1655E-05 + .1776E-05 + .1898E-05 + .2038E-05 + .2185E-05 + .2348E-05 + .2514E-05 + .2742E-05 + .2886E-05 + .3147E-05 + .3358E-05 + .3644E-05 + .3957E-05 + .4309E-05 + .4790E-05 + .5218E-05 + .5746E-05 + .6235E-05 + .6722E-05 + .7145E-05 + .7474E-05 + .7601E-05 + .7726E-05 + .7784E-05 + .7754E-05 + .7703E-05 + .7647E-05 + .7474E-05 + .7307E-05 + .6928E-05 + .6453E-05 + .5938E-05 + .5331E-05 + .4746E-05 + .4218E-05 + .3682E-05 + .3176E-05 + .2659E-05 + .2145E-05 + .1663E-05 + .1243E-05 + .7889E-06 + .5008E-06 + .3180E-06 + .2327E-06 + .1851E-06 + .1438E-06 + .1069E-06 + .7948E-07 + .6396E-07 + .5344E-07 + .4465E-07 + .3756E-07 + .3422E-07 + .3117E-07 + .2610E-07 + .2022E-07 + .1566E-07 + .1420E-07 + .1673E-05 + .1807E-05 + .1937E-05 + .2075E-05 + .2220E-05 + .2382E-05 + .2549E-05 + .2768E-05 + .2920E-05 + .3177E-05 + .3424E-05 + .3701E-05 + .4019E-05 + .4406E-05 + .4855E-05 + .5331E-05 + .5853E-05 + .6363E-05 + .6869E-05 + .7300E-05 + .7622E-05 + .7794E-05 + .7925E-05 + .8011E-05 + .8030E-05 + .8017E-05 + .7930E-05 + .7780E-05 + .7575E-05 + .7174E-05 + .6692E-05 + .6133E-05 + .5505E-05 + .4816E-05 + .4191E-05 + .3611E-05 + .3074E-05 + .2533E-05 + .1991E-05 + .1505E-05 + .1094E-05 + .6972E-06 + .4445E-06 + .2834E-06 + .2073E-06 + .1637E-06 + .1278E-06 + .9746E-07 + .7434E-07 + .6137E-07 + .5260E-07 + .4509E-07 + .3885E-07 + .3555E-07 + .3253E-07 + .2733E-07 + .2121E-07 + .1647E-07 + .1495E-07 + .1674E-05 + .1816E-05 + .1950E-05 + .2085E-05 + .2230E-05 + .2388E-05 + .2556E-05 + .2768E-05 + .2929E-05 + .3181E-05 + .3436E-05 + .3709E-05 + .4030E-05 + .4430E-05 + .4867E-05 + .5365E-05 + .5890E-05 + .6418E-05 + .6936E-05 + .7380E-05 + .7715E-05 + .7921E-05 + .8072E-05 + .8186E-05 + .8249E-05 + .8262E-05 + .8178E-05 + .8048E-05 + .7810E-05 + .7411E-05 + .6914E-05 + .6306E-05 + .5627E-05 + .4861E-05 + .4160E-05 + .3540E-05 + .2971E-05 + .2405E-05 + .1848E-05 + .1362E-05 + .9585E-06 + .6139E-06 + .3932E-06 + .2518E-06 + .1841E-06 + .1444E-06 + .1132E-06 + .8857E-07 + .6931E-07 + .5870E-07 + .5162E-07 + .4539E-07 + .4006E-07 + .3682E-07 + .3385E-07 + .2853E-07 + .2219E-07 + .1726E-07 + .1568E-07 + .1661E-05 + .1806E-05 + .1941E-05 + .2075E-05 + .2217E-05 + .2374E-05 + .2542E-05 + .2750E-05 + .2919E-05 + .3166E-05 + .3400E-05 + .3677E-05 + .4000E-05 + .4392E-05 + .4837E-05 + .5334E-05 + .5870E-05 + .6413E-05 + .6938E-05 + .7401E-05 + .7765E-05 + .7995E-05 + .8180E-05 + .8324E-05 + .8424E-05 + .8450E-05 + .8404E-05 + .8287E-05 + .8024E-05 + .7650E-05 + .7127E-05 + .6465E-05 + .5707E-05 + .4887E-05 + .4131E-05 + .3474E-05 + .2873E-05 + .2279E-05 + .1718E-05 + .1232E-05 + .8381E-06 + .5394E-06 + .3471E-06 + .2234E-06 + .1632E-06 + .1271E-06 + .1001E-06 + .8036E-07 + .6452E-07 + .5606E-07 + .5057E-07 + .4562E-07 + .4123E-07 + .3807E-07 + .3516E-07 + .2973E-07 + .2318E-07 + .1807E-07 + .1643E-07 + .1656E-05 + .1801E-05 + .1941E-05 + .2080E-05 + .2225E-05 + .2380E-05 + .2549E-05 + .2750E-05 + .2934E-05 + .3174E-05 + .3408E-05 + .3692E-05 + .4013E-05 + .4404E-05 + .4851E-05 + .5350E-05 + .5883E-05 + .6449E-05 + .6995E-05 + .7470E-05 + .7859E-05 + .8125E-05 + .8343E-05 + .8531E-05 + .8661E-05 + .8697E-05 + .8689E-05 + .8576E-05 + .8282E-05 + .7879E-05 + .7323E-05 + .6606E-05 + .5792E-05 + .4938E-05 + .4127E-05 + .3421E-05 + .2780E-05 + .2159E-05 + .1584E-05 + .1099E-05 + .7239E-06 + .4677E-06 + .3022E-06 + .1952E-06 + .1433E-06 + .1115E-06 + .8854E-07 + .7300E-07 + .6018E-07 + .5346E-07 + .4921E-07 + .4530E-07 + .4170E-07 + .3850E-07 + .3555E-07 + .3010E-07 + .2365E-07 + .1840E-07 + .1666E-07 + .1657E-05 + .1801E-05 + .1949E-05 + .2096E-05 + .2244E-05 + .2399E-05 + .2569E-05 + .2761E-05 + .2966E-05 + .3197E-05 + .3439E-05 + .3733E-05 + .4051E-05 + .4442E-05 + .4890E-05 + .5395E-05 + .5919E-05 + .6514E-05 + .7088E-05 + .7572E-05 + .7986E-05 + .8295E-05 + .8546E-05 + .8787E-05 + .8945E-05 + .8990E-05 + .9022E-05 + .8908E-05 + .8580E-05 + .8126E-05 + .7531E-05 + .6755E-05 + .5892E-05 + .5009E-05 + .4142E-05 + .3381E-05 + .2695E-05 + .2051E-05 + .1460E-05 + .9756E-06 + .6237E-06 + .3995E-06 + .2558E-06 + .1638E-06 + .1223E-06 + .9660E-07 + .7819E-07 + .6635E-07 + .5631E-07 + .5070E-07 + .4696E-07 + .4349E-07 + .4024E-07 + .3671E-07 + .3349E-07 + .2826E-07 + .2270E-07 + .1743E-07 + .1550E-07 + .1650E-05 + .1797E-05 + .1945E-05 + .2091E-05 + .2242E-05 + .2404E-05 + .2577E-05 + .2787E-05 + .2970E-05 + .3216E-05 + .3467E-05 + .3755E-05 + .4069E-05 + .4461E-05 + .4909E-05 + .5421E-05 + .5969E-05 + .6598E-05 + .7193E-05 + .7709E-05 + .8136E-05 + .8477E-05 + .8760E-05 + .9025E-05 + .9201E-05 + .9288E-05 + .9327E-05 + .9202E-05 + .8848E-05 + .8344E-05 + .7707E-05 + .6889E-05 + .5977E-05 + .5049E-05 + .4151E-05 + .3340E-05 + .2612E-05 + .1942E-05 + .1344E-05 + .8634E-06 + .5291E-06 + .3383E-06 + .2164E-06 + .1384E-06 + .1051E-06 + .8420E-07 + .6949E-07 + .6069E-07 + .5301E-07 + .4838E-07 + .4509E-07 + .4202E-07 + .3906E-07 + .3522E-07 + .3175E-07 + .2670E-07 + .2192E-07 + .1661E-07 + .1452E-07 + .1639E-05 + .1788E-05 + .1935E-05 + .2080E-05 + .2231E-05 + .2398E-05 + .2573E-05 + .2797E-05 + .2962E-05 + .3222E-05 + .3480E-05 + .3763E-05 + .4074E-05 + .4467E-05 + .4918E-05 + .5435E-05 + .6007E-05 + .6661E-05 + .7274E-05 + .7821E-05 + .8265E-05 + .8638E-05 + .8952E-05 + .9237E-05 + .9429E-05 + .9555E-05 + .9596E-05 + .9464E-05 + .9081E-05 + .8530E-05 + .7854E-05 + .6994E-05 + .6039E-05 + .5068E-05 + .4144E-05 + .3287E-05 + .2523E-05 + .1832E-05 + .1233E-05 + .7619E-06 + .4476E-06 + .2858E-06 + .1824E-06 + .1165E-06 + .9004E-07 + .7316E-07 + .6155E-07 + .5533E-07 + .4974E-07 + .4602E-07 + .4315E-07 + .4047E-07 + .3780E-07 + .3368E-07 + .3000E-07 + .2514E-07 + .2110E-07 + .1578E-07 + .1355E-07 + .1638E-05 + .1790E-05 + .1940E-05 + .2079E-05 + .2222E-05 + .2381E-05 + .2553E-05 + .2764E-05 + .2946E-05 + .3216E-05 + .3471E-05 + .3765E-05 + .4090E-05 + .4492E-05 + .4963E-05 + .5490E-05 + .6077E-05 + .6723E-05 + .7340E-05 + .7918E-05 + .8416E-05 + .8818E-05 + .9153E-05 + .9440E-05 + .9645E-05 + .9770E-05 + .9804E-05 + .9680E-05 + .9249E-05 + .8682E-05 + .7968E-05 + .7061E-05 + .6079E-05 + .5069E-05 + .4119E-05 + .3228E-05 + .2433E-05 + .1729E-05 + .1134E-05 + .6745E-06 + .3826E-06 + .2429E-06 + .1542E-06 + .9786E-07 + .7697E-07 + .6344E-07 + .5441E-07 + .5035E-07 + .4659E-07 + .4368E-07 + .4122E-07 + .3890E-07 + .3650E-07 + .3214E-07 + .2830E-07 + .2362E-07 + .2027E-07 + .1496E-07 + .1262E-07 + .1620E-05 + .1775E-05 + .1928E-05 + .2065E-05 + .2206E-05 + .2362E-05 + .2536E-05 + .2740E-05 + .2938E-05 + .3214E-05 + .3467E-05 + .3772E-05 + .4106E-05 + .4519E-05 + .5003E-05 + .5538E-05 + .6139E-05 + .6785E-05 + .7410E-05 + .8019E-05 + .8548E-05 + .8980E-05 + .9342E-05 + .9641E-05 + .9870E-05 + .1000E-04 + .1003E-04 + .9894E-05 + .9427E-05 + .8835E-05 + .8078E-05 + .7127E-05 + .6115E-05 + .5071E-05 + .4090E-05 + .3166E-05 + .2348E-05 + .1636E-05 + .1044E-05 + .5960E-06 + .3252E-06 + .2056E-06 + .1300E-06 + .8224E-07 + .6581E-07 + .5503E-07 + .4811E-07 + .4582E-07 + .4364E-07 + .4148E-07 + .3938E-07 + .3739E-07 + .3526E-07 + .3068E-07 + .2669E-07 + .2220E-07 + .1948E-07 + .1419E-07 + .1176E-07 + .1571E-05 + .1729E-05 + .1885E-05 + .2028E-05 + .2176E-05 + .2341E-05 + .2522E-05 + .2735E-05 + .2943E-05 + .3222E-05 + .3473E-05 + .3788E-05 + .4123E-05 + .4552E-05 + .5031E-05 + .5575E-05 + .6187E-05 + .6849E-05 + .7489E-05 + .8130E-05 + .8647E-05 + .9104E-05 + .9508E-05 + .9838E-05 + .1011E-04 + .1026E-04 + .1028E-04 + .1010E-04 + .9621E-05 + .8991E-05 + .8184E-05 + .7193E-05 + .6142E-05 + .5078E-05 + .4055E-05 + .3101E-05 + .2269E-05 + .1554E-05 + .9630E-06 + .5249E-06 + .2737E-06 + .1730E-06 + .1094E-06 + .6916E-07 + .5631E-07 + .4776E-07 + .4258E-07 + .4174E-07 + .4091E-07 + .3941E-07 + .3766E-07 + .3598E-07 + .3408E-07 + .2931E-07 + .2520E-07 + .2089E-07 + .1873E-07 + .1347E-07 + .1097E-07 + .1533E-05 + .1694E-05 + .1852E-05 + .1999E-05 + .2152E-05 + .2322E-05 + .2508E-05 + .2721E-05 + .2942E-05 + .3210E-05 + .3476E-05 + .3798E-05 + .4148E-05 + .4576E-05 + .5064E-05 + .5619E-05 + .6246E-05 + .6911E-05 + .7552E-05 + .8225E-05 + .8771E-05 + .9273E-05 + .9721E-05 + .1008E-04 + .1037E-04 + .1053E-04 + .1050E-04 + .1030E-04 + .9792E-05 + .9123E-05 + .8282E-05 + .7250E-05 + .6164E-05 + .5076E-05 + .4025E-05 + .3057E-05 + .2215E-05 + .1495E-05 + .8989E-06 + .4738E-06 + .2411E-06 + .1501E-06 + .9344E-07 + .5818E-07 + .4820E-07 + .4147E-07 + .3769E-07 + .3802E-07 + .3836E-07 + .3746E-07 + .3601E-07 + .3462E-07 + .3296E-07 + .2800E-07 + .2379E-07 + .1965E-07 + .1802E-07 + .1278E-07 + .1023E-07 + .1501E-05 + .1664E-05 + .1826E-05 + .1975E-05 + .2131E-05 + .2301E-05 + .2490E-05 + .2697E-05 + .2934E-05 + .3178E-05 + .3471E-05 + .3797E-05 + .4173E-05 + .4588E-05 + .5094E-05 + .5661E-05 + .6305E-05 + .6963E-05 + .7593E-05 + .8298E-05 + .8905E-05 + .9468E-05 + .9960E-05 + .1036E-04 + .1063E-04 + .1078E-04 + .1070E-04 + .1049E-04 + .9931E-05 + .9223E-05 + .8364E-05 + .7289E-05 + .6173E-05 + .5059E-05 + .3994E-05 + .3024E-05 + .2175E-05 + .1451E-05 + .8455E-06 + .4352E-06 + .2196E-06 + .1331E-06 + .8066E-07 + .4888E-07 + .4121E-07 + .3596E-07 + .3332E-07 + .3460E-07 + .3593E-07 + .3556E-07 + .3440E-07 + .3328E-07 + .3183E-07 + .2673E-07 + .2244E-07 + .1847E-07 + .1731E-07 + .1212E-07 + .9532E-08 + .1478E-05 + .1633E-05 + .1786E-05 + .1932E-05 + .2086E-05 + .2256E-05 + .2446E-05 + .2660E-05 + .2900E-05 + .3156E-05 + .3451E-05 + .3785E-05 + .4173E-05 + .4603E-05 + .5112E-05 + .5701E-05 + .6335E-05 + .7000E-05 + .7661E-05 + .8381E-05 + .9022E-05 + .9634E-05 + .1013E-04 + .1052E-04 + .1081E-04 + .1094E-04 + .1087E-04 + .1064E-04 + .1006E-04 + .9320E-05 + .8419E-05 + .7322E-05 + .6173E-05 + .5050E-05 + .3978E-05 + .2999E-05 + .2150E-05 + .1417E-05 + .8115E-06 + .4024E-06 + .2008E-06 + .1184E-06 + .6977E-07 + .4113E-07 + .3528E-07 + .3123E-07 + .2950E-07 + .3153E-07 + .3371E-07 + .3381E-07 + .3291E-07 + .3204E-07 + .3079E-07 + .2555E-07 + .2120E-07 + .1738E-07 + .1666E-07 + .1151E-07 + .8893E-08 + .1446E-05 + .1589E-05 + .1728E-05 + .1868E-05 + .2016E-05 + .2186E-05 + .2377E-05 + .2598E-05 + .2837E-05 + .3111E-05 + .3397E-05 + .3739E-05 + .4131E-05 + .4581E-05 + .5084E-05 + .5692E-05 + .6303E-05 + .6974E-05 + .7673E-05 + .8397E-05 + .9058E-05 + .9710E-05 + .1019E-04 + .1057E-04 + .1087E-04 + .1099E-04 + .1094E-04 + .1070E-04 + .1010E-04 + .9337E-05 + .8395E-05 + .7291E-05 + .6117E-05 + .5002E-05 + .3932E-05 + .2951E-05 + .2110E-05 + .1376E-05 + .7770E-06 + .3696E-06 + .1822E-06 + .1125E-06 + .6941E-07 + .4284E-07 + .3644E-07 + .3228E-07 + .3039E-07 + .3212E-07 + .3395E-07 + .3400E-07 + .3317E-07 + .3237E-07 + .3122E-07 + .2641E-07 + .2233E-07 + .1863E-07 + .1740E-07 + .1209E-07 + .9527E-08 + .1418E-05 + .1555E-05 + .1691E-05 + .1824E-05 + .1969E-05 + .2135E-05 + .2322E-05 + .2538E-05 + .2778E-05 + .3049E-05 + .3368E-05 + .3697E-05 + .4083E-05 + .4500E-05 + .4974E-05 + .5537E-05 + .6159E-05 + .6823E-05 + .7526E-05 + .8260E-05 + .8927E-05 + .9519E-05 + .1004E-04 + .1047E-04 + .1076E-04 + .1091E-04 + .1088E-04 + .1071E-04 + .1016E-04 + .9372E-05 + .8362E-05 + .7255E-05 + .6069E-05 + .4930E-05 + .3876E-05 + .2906E-05 + .2056E-05 + .1339E-05 + .7582E-06 + .3576E-06 + .1713E-06 + .1106E-06 + .7142E-07 + .4612E-07 + .3875E-07 + .3429E-07 + .3206E-07 + .3333E-07 + .3464E-07 + .3454E-07 + .3377E-07 + .3301E-07 + .3196E-07 + .2767E-07 + .2396E-07 + .2038E-07 + .1843E-07 + .1291E-07 + .1044E-07 + .1400E-05 + .1530E-05 + .1660E-05 + .1786E-05 + .1924E-05 + .2083E-05 + .2264E-05 + .2470E-05 + .2707E-05 + .2964E-05 + .3299E-05 + .3612E-05 + .3995E-05 + .4388E-05 + .4853E-05 + .5388E-05 + .6015E-05 + .6677E-05 + .7381E-05 + .8126E-05 + .8810E-05 + .9352E-05 + .9882E-05 + .1033E-04 + .1060E-04 + .1077E-04 + .1076E-04 + .1067E-04 + .1016E-04 + .9349E-05 + .8286E-05 + .7176E-05 + .5995E-05 + .4847E-05 + .3814E-05 + .2861E-05 + .2017E-05 + .1317E-05 + .7536E-06 + .3587E-06 + .1687E-06 + .1121E-06 + .7446E-07 + .4947E-07 + .4107E-07 + .3629E-07 + .3371E-07 + .3446E-07 + .3522E-07 + .3497E-07 + .3425E-07 + .3355E-07 + .3260E-07 + .2890E-07 + .2561E-07 + .2222E-07 + .1945E-07 + .1374E-07 + .1139E-07 + .1427E-05 + .1543E-05 + .1662E-05 + .1772E-05 + .1893E-05 + .2033E-05 + .2194E-05 + .2376E-05 + .2587E-05 + .2802E-05 + .3077E-05 + .3366E-05 + .3759E-05 + .4168E-05 + .4712E-05 + .5295E-05 + .5899E-05 + .6584E-05 + .7292E-05 + .8044E-05 + .8804E-05 + .9341E-05 + .9756E-05 + .1010E-04 + .1033E-04 + .1043E-04 + .1040E-04 + .1045E-04 + .9947E-05 + .9122E-05 + .8065E-05 + .6955E-05 + .5841E-05 + .4746E-05 + .3739E-05 + .2832E-05 + .2049E-05 + .1362E-05 + .8139E-06 + .4211E-06 + .2033E-06 + .1295E-06 + .8247E-07 + .5252E-07 + .4309E-07 + .3802E-07 + .3508E-07 + .3526E-07 + .3544E-07 + .3504E-07 + .3439E-07 + .3375E-07 + .3292E-07 + .2987E-07 + .2710E-07 + .2398E-07 + .2032E-07 + .1448E-07 + .1231E-07 + .1441E-05 + .1548E-05 + .1661E-05 + .1765E-05 + .1877E-05 + .2006E-05 + .2153E-05 + .2319E-05 + .2513E-05 + .2705E-05 + .2950E-05 + .3232E-05 + .3610E-05 + .4034E-05 + .4626E-05 + .5240E-05 + .5838E-05 + .6535E-05 + .7236E-05 + .8001E-05 + .8781E-05 + .9285E-05 + .9637E-05 + .9921E-05 + .1012E-04 + .1020E-04 + .1020E-04 + .1028E-04 + .9797E-05 + .8967E-05 + .7914E-05 + .6800E-05 + .5707E-05 + .4643E-05 + .3655E-05 + .2789E-05 + .2043E-05 + .1368E-05 + .8417E-06 + .4552E-06 + .2250E-06 + .1416E-06 + .8910E-07 + .5607E-07 + .4544E-07 + .4005E-07 + .3671E-07 + .3628E-07 + .3585E-07 + .3531E-07 + .3472E-07 + .3414E-07 + .3342E-07 + .3104E-07 + .2883E-07 + .2602E-07 + .2134E-07 + .1533E-07 + .1337E-07 + .1438E-05 + .1547E-05 + .1663E-05 + .1773E-05 + .1888E-05 + .2018E-05 + .2160E-05 + .2325E-05 + .2511E-05 + .2704E-05 + .2957E-05 + .3258E-05 + .3585E-05 + .4031E-05 + .4635E-05 + .5260E-05 + .5876E-05 + .6570E-05 + .7249E-05 + .8042E-05 + .8761E-05 + .9188E-05 + .9554E-05 + .9828E-05 + .1003E-04 + .1017E-04 + .1022E-04 + .1023E-04 + .9772E-05 + .8939E-05 + .7888E-05 + .6756E-05 + .5617E-05 + .4551E-05 + .3569E-05 + .2736E-05 + .1986E-05 + .1320E-05 + .8173E-06 + .4353E-06 + .2193E-06 + .1418E-06 + .9165E-07 + .5926E-07 + .4771E-07 + .4215E-07 + .3853E-07 + .3759E-07 + .3667E-07 + .3600E-07 + .3544E-07 + .3489E-07 + .3423E-07 + .3228E-07 + .3044E-07 + .2780E-07 + .2255E-07 + .1642E-07 + .1449E-07 + .1433E-05 + .1542E-05 + .1657E-05 + .1768E-05 + .1885E-05 + .2016E-05 + .2161E-05 + .2327E-05 + .2516E-05 + .2712E-05 + .2968E-05 + .3274E-05 + .3603E-05 + .4054E-05 + .4620E-05 + .5217E-05 + .5837E-05 + .6532E-05 + .7230E-05 + .7980E-05 + .8625E-05 + .9034E-05 + .9402E-05 + .9682E-05 + .9896E-05 + .1009E-04 + .1020E-04 + .1020E-04 + .9734E-05 + .8886E-05 + .7848E-05 + .6710E-05 + .5561E-05 + .4484E-05 + .3508E-05 + .2684E-05 + .1944E-05 + .1295E-05 + .8054E-06 + .4209E-06 + .2104E-06 + .1396E-06 + .9260E-07 + .6143E-07 + .4939E-07 + .4390E-07 + .4017E-07 + .3885E-07 + .3757E-07 + .3679E-07 + .3623E-07 + .3568E-07 + .3504E-07 + .3327E-07 + .3159E-07 + .2896E-07 + .2376E-07 + .1760E-07 + .1554E-07 + .1425E-05 + .1532E-05 + .1643E-05 + .1751E-05 + .1869E-05 + .2004E-05 + .2154E-05 + .2323E-05 + .2523E-05 + .2722E-05 + .2976E-05 + .3279E-05 + .3646E-05 + .4089E-05 + .4581E-05 + .5126E-05 + .5739E-05 + .6436E-05 + .7177E-05 + .7840E-05 + .8405E-05 + .8832E-05 + .9193E-05 + .9489E-05 + .9729E-05 + .9972E-05 + .1014E-04 + .1017E-04 + .9672E-05 + .8804E-05 + .7788E-05 + .6651E-05 + .5518E-05 + .4426E-05 + .3458E-05 + .2631E-05 + .1908E-05 + .1282E-05 + .8002E-06 + .4095E-06 + .1995E-06 + .1363E-06 + .9317E-07 + .6367E-07 + .5111E-07 + .4572E-07 + .4188E-07 + .4015E-07 + .3849E-07 + .3759E-07 + .3704E-07 + .3649E-07 + .3587E-07 + .3429E-07 + .3279E-07 + .3017E-07 + .2503E-07 + .1887E-07 + .1665E-07 + .1414E-05 + .1525E-05 + .1640E-05 + .1753E-05 + .1874E-05 + .2012E-05 + .2165E-05 + .2341E-05 + .2536E-05 + .2768E-05 + .3025E-05 + .3317E-05 + .3678E-05 + .4087E-05 + .4588E-05 + .5116E-05 + .5728E-05 + .6415E-05 + .7116E-05 + .7705E-05 + .8228E-05 + .8655E-05 + .9012E-05 + .9328E-05 + .9562E-05 + .9791E-05 + .9962E-05 + .9969E-05 + .9471E-05 + .8683E-05 + .7712E-05 + .6613E-05 + .5490E-05 + .4408E-05 + .3442E-05 + .2636E-05 + .1925E-05 + .1301E-05 + .7984E-06 + .4057E-06 + .1966E-06 + .1366E-06 + .9491E-07 + .6594E-07 + .5286E-07 + .4757E-07 + .4363E-07 + .4146E-07 + .3939E-07 + .3838E-07 + .3783E-07 + .3729E-07 + .3668E-07 + .3531E-07 + .3400E-07 + .3141E-07 + .2634E-07 + .2021E-07 + .1783E-07 + .1411E-05 + .1529E-05 + .1650E-05 + .1769E-05 + .1896E-05 + .2038E-05 + .2193E-05 + .2378E-05 + .2567E-05 + .2842E-05 + .3104E-05 + .3384E-05 + .3732E-05 + .4104E-05 + .4632E-05 + .5156E-05 + .5771E-05 + .6448E-05 + .7096E-05 + .7620E-05 + .8115E-05 + .8538E-05 + .8893E-05 + .9230E-05 + .9454E-05 + .9658E-05 + .9823E-05 + .9797E-05 + .9297E-05 + .8603E-05 + .7675E-05 + .6617E-05 + .5498E-05 + .4425E-05 + .3455E-05 + .2672E-05 + .1966E-05 + .1336E-05 + .8031E-06 + .4067E-06 + .1970E-06 + .1386E-06 + .9759E-07 + .6869E-07 + .5498E-07 + .4979E-07 + .4571E-07 + .4306E-07 + .4056E-07 + .3941E-07 + .3886E-07 + .3832E-07 + .3774E-07 + .3658E-07 + .3546E-07 + .3288E-07 + .2789E-07 + .2178E-07 + .1920E-07 + .1417E-05 + .1544E-05 + .1673E-05 + .1799E-05 + .1932E-05 + .2082E-05 + .2248E-05 + .2442E-05 + .2641E-05 + .2898E-05 + .3173E-05 + .3464E-05 + .3854E-05 + .4240E-05 + .4699E-05 + .5233E-05 + .5821E-05 + .6462E-05 + .7085E-05 + .7599E-05 + .8097E-05 + .8500E-05 + .8853E-05 + .9134E-05 + .9385E-05 + .9561E-05 + .9685E-05 + .9594E-05 + .9089E-05 + .8407E-05 + .7535E-05 + .6524E-05 + .5515E-05 + .4499E-05 + .3552E-05 + .2762E-05 + .2054E-05 + .1395E-05 + .8509E-06 + .4376E-06 + .2101E-06 + .1468E-06 + .1026E-06 + .7165E-07 + .5727E-07 + .5219E-07 + .4796E-07 + .4478E-07 + .4181E-07 + .4052E-07 + .3998E-07 + .3944E-07 + .3888E-07 + .3794E-07 + .3703E-07 + .3447E-07 + .2957E-07 + .2350E-07 + .2071E-07 + .1430E-05 + .1565E-05 + .1703E-05 + .1835E-05 + .1975E-05 + .2134E-05 + .2312E-05 + .2515E-05 + .2730E-05 + .2976E-05 + .3268E-05 + .3562E-05 + .3981E-05 + .4382E-05 + .4795E-05 + .5327E-05 + .5893E-05 + .6508E-05 + .7100E-05 + .7612E-05 + .8104E-05 + .8479E-05 + .8820E-05 + .9055E-05 + .9325E-05 + .9482E-05 + .9572E-05 + .9432E-05 + .8887E-05 + .8201E-05 + .7405E-05 + .6460E-05 + .5554E-05 + .4611E-05 + .3702E-05 + .2908E-05 + .2185E-05 + .1487E-05 + .9160E-06 + .4763E-06 + .2297E-06 + .1582E-06 + .1089E-06 + .7500E-07 + .5985E-07 + .5488E-07 + .5049E-07 + .4673E-07 + .4325E-07 + .4181E-07 + .4127E-07 + .4073E-07 + .4018E-07 + .3949E-07 + .3881E-07 + .3627E-07 + .3145E-07 + .2544E-07 + .2242E-07 + .1441E-05 + .1580E-05 + .1724E-05 + .1863E-05 + .2009E-05 + .2174E-05 + .2363E-05 + .2576E-05 + .2816E-05 + .3074E-05 + .3389E-05 + .3661E-05 + .4045E-05 + .4452E-05 + .4905E-05 + .5389E-05 + .5938E-05 + .6547E-05 + .7083E-05 + .7615E-05 + .8060E-05 + .8364E-05 + .8657E-05 + .8877E-05 + .9139E-05 + .9305E-05 + .9378E-05 + .9236E-05 + .8553E-05 + .7821E-05 + .7182E-05 + .6380E-05 + .5573E-05 + .4774E-05 + .3976E-05 + .3201E-05 + .2426E-05 + .1666E-05 + .1023E-05 + .5300E-06 + .2685E-06 + .1779E-06 + .1178E-06 + .7806E-07 + .6221E-07 + .5740E-07 + .5285E-07 + .4849E-07 + .4449E-07 + .4290E-07 + .4236E-07 + .4182E-07 + .4130E-07 + .4087E-07 + .4044E-07 + .3794E-07 + .3327E-07 + .2738E-07 + .2412E-07 + .1461E-05 + .1605E-05 + .1754E-05 + .1900E-05 + .2051E-05 + .2219E-05 + .2414E-05 + .2632E-05 + .2885E-05 + .3156E-05 + .3485E-05 + .3748E-05 + .4112E-05 + .4515E-05 + .5000E-05 + .5471E-05 + .5998E-05 + .6573E-05 + .7069E-05 + .7602E-05 + .8010E-05 + .8270E-05 + .8522E-05 + .8712E-05 + .8901E-05 + .9007E-05 + .8997E-05 + .8853E-05 + .8184E-05 + .7511E-05 + .6955E-05 + .6284E-05 + .5591E-05 + .4908E-05 + .4208E-05 + .3474E-05 + .2686E-05 + .1879E-05 + .1157E-05 + .6133E-06 + .3245E-06 + .2103E-06 + .1363E-06 + .8836E-07 + .6965E-07 + .6331E-07 + .5756E-07 + .5234E-07 + .4759E-07 + .4555E-07 + .4467E-07 + .4381E-07 + .4299E-07 + .4255E-07 + .4211E-07 + .3952E-07 + .3496E-07 + .2942E-07 + .2627E-07 + .1494E-05 + .1642E-05 + .1799E-05 + .1951E-05 + .2106E-05 + .2274E-05 + .2466E-05 + .2684E-05 + .2930E-05 + .3216E-05 + .3546E-05 + .3820E-05 + .4187E-05 + .4570E-05 + .5079E-05 + .5581E-05 + .6080E-05 + .6584E-05 + .7065E-05 + .7574E-05 + .7956E-05 + .8203E-05 + .8425E-05 + .8567E-05 + .8606E-05 + .8570E-05 + .8404E-05 + .8260E-05 + .7778E-05 + .7282E-05 + .6725E-05 + .6171E-05 + .5613E-05 + .5001E-05 + .4373E-05 + .3705E-05 + .2962E-05 + .2137E-05 + .1334E-05 + .7468E-06 + .4095E-06 + .2654E-06 + .1720E-06 + .1115E-06 + .8587E-07 + .7485E-07 + .6599E-07 + .5945E-07 + .5356E-07 + .5056E-07 + .4879E-07 + .4709E-07 + .4551E-07 + .4465E-07 + .4381E-07 + .4097E-07 + .3645E-07 + .3154E-07 + .2907E-07 + .1534E-05 + .1685E-05 + .1846E-05 + .2003E-05 + .2163E-05 + .2338E-05 + .2536E-05 + .2759E-05 + .3007E-05 + .3306E-05 + .3643E-05 + .3950E-05 + .4309E-05 + .4701E-05 + .5196E-05 + .5708E-05 + .6189E-05 + .6685E-05 + .7154E-05 + .7616E-05 + .7952E-05 + .8195E-05 + .8352E-05 + .8408E-05 + .8358E-05 + .8267E-05 + .8082E-05 + .7926E-05 + .7539E-05 + .7092E-05 + .6611E-05 + .6142E-05 + .5661E-05 + .5126E-05 + .4545E-05 + .3905E-05 + .3188E-05 + .2358E-05 + .1534E-05 + .9092E-06 + .5229E-06 + .3377E-06 + .2180E-06 + .1408E-06 + .1059E-06 + .8855E-07 + .7570E-07 + .6757E-07 + .6032E-07 + .5616E-07 + .5334E-07 + .5066E-07 + .4821E-07 + .4689E-07 + .4561E-07 + .4251E-07 + .3803E-07 + .3384E-07 + .3220E-07 + .1578E-05 + .1731E-05 + .1892E-05 + .2055E-05 + .2222E-05 + .2407E-05 + .2614E-05 + .2847E-05 + .3101E-05 + .3413E-05 + .3758E-05 + .4112E-05 + .4456E-05 + .4874E-05 + .5333E-05 + .5841E-05 + .6310E-05 + .6831E-05 + .7288E-05 + .7689E-05 + .7966E-05 + .8212E-05 + .8285E-05 + .8233E-05 + .8129E-05 + .8027E-05 + .7890E-05 + .7715E-05 + .7381E-05 + .6917E-05 + .6550E-05 + .6152E-05 + .5718E-05 + .5268E-05 + .4719E-05 + .4085E-05 + .3381E-05 + .2558E-05 + .1761E-05 + .1106E-05 + .6715E-06 + .4487E-06 + .2998E-06 + .2003E-06 + .1520E-06 + .1245E-06 + .1022E-06 + .8450E-07 + .6984E-07 + .6212E-07 + .5722E-07 + .5271E-07 + .4873E-07 + .4708E-07 + .4548E-07 + .4246E-07 + .3843E-07 + .3477E-07 + .3347E-07 + .1584E-05 + .1745E-05 + .1911E-05 + .2080E-05 + .2251E-05 + .2441E-05 + .2655E-05 + .2894E-05 + .3166E-05 + .3460E-05 + .3838E-05 + .4204E-05 + .4594E-05 + .5019E-05 + .5483E-05 + .5980E-05 + .6461E-05 + .6964E-05 + .7365E-05 + .7703E-05 + .7921E-05 + .8075E-05 + .8114E-05 + .8039E-05 + .7935E-05 + .7823E-05 + .7678E-05 + .7481E-05 + .7170E-05 + .6796E-05 + .6476E-05 + .6137E-05 + .5741E-05 + .5350E-05 + .4849E-05 + .4238E-05 + .3559E-05 + .2775E-05 + .2003E-05 + .1348E-05 + .8635E-06 + .6037E-06 + .4220E-06 + .2951E-06 + .2284E-06 + .1844E-06 + .1450E-06 + .1085E-06 + .8119E-07 + .6827E-07 + .6068E-07 + .5394E-07 + .4824E-07 + .4631E-07 + .4446E-07 + .4167E-07 + .3821E-07 + .3503E-07 + .3389E-07 + .1566E-05 + .1733E-05 + .1904E-05 + .2076E-05 + .2250E-05 + .2441E-05 + .2660E-05 + .2903E-05 + .3192E-05 + .3462E-05 + .3870E-05 + .4239E-05 + .4677E-05 + .5100E-05 + .5572E-05 + .6054E-05 + .6544E-05 + .7012E-05 + .7348E-05 + .7620E-05 + .7779E-05 + .7835E-05 + .7845E-05 + .7763E-05 + .7666E-05 + .7543E-05 + .7385E-05 + .7169E-05 + .6882E-05 + .6611E-05 + .6332E-05 + .6053E-05 + .5698E-05 + .5362E-05 + .4918E-05 + .4341E-05 + .3699E-05 + .2973E-05 + .2248E-05 + .1621E-05 + .1094E-05 + .8011E-06 + .5867E-06 + .4296E-06 + .3390E-06 + .2700E-06 + .2034E-06 + .1378E-06 + .9329E-07 + .7416E-07 + .6362E-07 + .5457E-07 + .4721E-07 + .4504E-07 + .4296E-07 + .4042E-07 + .3755E-07 + .3489E-07 + .3392E-07 + .1514E-05 + .1680E-05 + .1851E-05 + .2027E-05 + .2210E-05 + .2406E-05 + .2632E-05 + .2879E-05 + .3175E-05 + .3450E-05 + .3844E-05 + .4198E-05 + .4624E-05 + .5047E-05 + .5502E-05 + .6002E-05 + .6443E-05 + .6842E-05 + .7159E-05 + .7379E-05 + .7503E-05 + .7558E-05 + .7512E-05 + .7425E-05 + .7288E-05 + .7138E-05 + .6988E-05 + .6773E-05 + .6559E-05 + .6321E-05 + .6128E-05 + .5922E-05 + .5601E-05 + .5272E-05 + .4873E-05 + .4371E-05 + .3778E-05 + .3083E-05 + .2419E-05 + .1808E-05 + .1283E-05 + .1006E-05 + .7895E-06 + .6193E-06 + .4982E-06 + .3914E-06 + .2824E-06 + .1731E-06 + .1061E-06 + .7976E-07 + .6602E-07 + .5466E-07 + .4574E-07 + .4336E-07 + .4110E-07 + .3882E-07 + .3654E-07 + .3440E-07 + .3361E-07 + .1490E-05 + .1659E-05 + .1835E-05 + .2019E-05 + .2212E-05 + .2417E-05 + .2652E-05 + .2911E-05 + .3216E-05 + .3507E-05 + .3904E-05 + .4263E-05 + .4690E-05 + .5118E-05 + .5569E-05 + .6071E-05 + .6466E-05 + .6813E-05 + .7103E-05 + .7282E-05 + .7379E-05 + .7427E-05 + .7337E-05 + .7241E-05 + .7080E-05 + .6907E-05 + .6766E-05 + .6561E-05 + .6398E-05 + .6193E-05 + .6061E-05 + .5898E-05 + .5610E-05 + .5292E-05 + .4927E-05 + .4475E-05 + .3911E-05 + .3243E-05 + .2625E-05 + .2026E-05 + .1504E-05 + .1181E-05 + .9281E-06 + .7291E-06 + .5871E-06 + .4547E-06 + .3204E-06 + .1884E-06 + .1108E-06 + .8154E-07 + .6672E-07 + .5460E-07 + .4519E-07 + .4268E-07 + .4030E-07 + .3783E-07 + .3532E-07 + .3297E-07 + .3212E-07 + .1481E-05 + .1660E-05 + .1843E-05 + .2037E-05 + .2241E-05 + .2459E-05 + .2704E-05 + .2982E-05 + .3289E-05 + .3619E-05 + .4049E-05 + .4452E-05 + .4901E-05 + .5336E-05 + .5797E-05 + .6236E-05 + .6566E-05 + .6891E-05 + .7117E-05 + .7273E-05 + .7356E-05 + .7377E-05 + .7270E-05 + .7157E-05 + .7013E-05 + .6824E-05 + .6705E-05 + .6544E-05 + .6388E-05 + .6229E-05 + .6115E-05 + .5925E-05 + .5684E-05 + .5399E-05 + .5062E-05 + .4608E-05 + .4039E-05 + .3409E-05 + .2798E-05 + .2212E-05 + .1692E-05 + .1317E-05 + .1025E-05 + .7980E-06 + .6386E-06 + .4875E-06 + .3380E-06 + .1951E-06 + .1126E-06 + .8226E-07 + .6716E-07 + .5484E-07 + .4529E-07 + .4265E-07 + .4017E-07 + .3733E-07 + .3427E-07 + .3146E-07 + .3045E-07 + .1459E-05 + .1642E-05 + .1831E-05 + .2031E-05 + .2240E-05 + .2462E-05 + .2710E-05 + .2994E-05 + .3300E-05 + .3647E-05 + .4088E-05 + .4537E-05 + .5007E-05 + .5454E-05 + .5903E-05 + .6299E-05 + .6600E-05 + .6898E-05 + .7085E-05 + .7214E-05 + .7274E-05 + .7250E-05 + .7126E-05 + .7000E-05 + .6851E-05 + .6659E-05 + .6556E-05 + .6427E-05 + .6294E-05 + .6181E-05 + .6087E-05 + .5900E-05 + .5697E-05 + .5436E-05 + .5106E-05 + .4663E-05 + .4119E-05 + .3536E-05 + .2943E-05 + .2369E-05 + .1861E-05 + .1441E-05 + .1116E-05 + .8639E-06 + .6870E-06 + .5168E-06 + .3527E-06 + .1999E-06 + .1132E-06 + .8208E-07 + .6687E-07 + .5448E-07 + .4489E-07 + .4216E-07 + .3959E-07 + .3643E-07 + .3289E-07 + .2970E-07 + .2856E-07 + .1431E-05 + .1615E-05 + .1807E-05 + .2008E-05 + .2217E-05 + .2436E-05 + .2683E-05 + .2957E-05 + .3262E-05 + .3601E-05 + .4031E-05 + .4527E-05 + .5017E-05 + .5484E-05 + .5902E-05 + .6283E-05 + .6596E-05 + .6868E-05 + .7042E-05 + .7142E-05 + .7171E-05 + .7082E-05 + .6943E-05 + .6805E-05 + .6629E-05 + .6446E-05 + .6353E-05 + .6243E-05 + .6146E-05 + .6078E-05 + .6003E-05 + .5852E-05 + .5673E-05 + .5423E-05 + .5076E-05 + .4656E-05 + .4168E-05 + .3637E-05 + .3066E-05 + .2497E-05 + .2005E-05 + .1552E-05 + .1201E-05 + .9292E-06 + .7344E-06 + .5445E-06 + .3657E-06 + .2034E-06 + .1131E-06 + .8138E-07 + .6615E-07 + .5377E-07 + .4421E-07 + .4140E-07 + .3878E-07 + .3533E-07 + .3137E-07 + .2785E-07 + .2661E-07 + .1403E-05 + .1588E-05 + .1783E-05 + .1985E-05 + .2195E-05 + .2411E-05 + .2656E-05 + .2920E-05 + .3224E-05 + .3556E-05 + .3975E-05 + .4519E-05 + .5028E-05 + .5514E-05 + .5901E-05 + .6268E-05 + .6594E-05 + .6838E-05 + .7002E-05 + .7075E-05 + .7075E-05 + .6926E-05 + .6772E-05 + .6624E-05 + .6422E-05 + .6247E-05 + .6163E-05 + .6072E-05 + .6009E-05 + .5983E-05 + .5924E-05 + .5807E-05 + .5650E-05 + .5411E-05 + .5048E-05 + .4649E-05 + .4212E-05 + .3706E-05 + .3155E-05 + .2592E-05 + .2117E-05 + .1623E-05 + .1244E-05 + .9539E-06 + .7639E-06 + .5717E-06 + .3864E-06 + .2150E-06 + .1196E-06 + .8482E-07 + .6749E-07 + .5370E-07 + .4329E-07 + .4061E-07 + .3809E-07 + .3468E-07 + .3071E-07 + .2720E-07 + .2597E-07 + .1372E-05 + .1557E-05 + .1756E-05 + .1958E-05 + .2168E-05 + .2380E-05 + .2622E-05 + .2876E-05 + .3179E-05 + .3503E-05 + .3908E-05 + .4498E-05 + .5025E-05 + .5530E-05 + .5885E-05 + .6237E-05 + .6574E-05 + .6791E-05 + .6943E-05 + .6991E-05 + .6964E-05 + .6758E-05 + .6591E-05 + .6433E-05 + .6208E-05 + .6042E-05 + .5966E-05 + .5893E-05 + .5861E-05 + .5875E-05 + .5833E-05 + .5748E-05 + .5612E-05 + .5384E-05 + .5006E-05 + .4629E-05 + .4243E-05 + .3751E-05 + .3220E-05 + .2664E-05 + .2206E-05 + .1670E-05 + .1263E-05 + .9560E-06 + .7826E-06 + .5976E-06 + .4106E-06 + .2305E-06 + .1294E-06 + .9019E-07 + .6963E-07 + .5376E-07 + .4217E-07 + .3969E-07 + .3736E-07 + .3414E-07 + .3035E-07 + .2699E-07 + .2580E-07 + .1336E-05 + .1520E-05 + .1721E-05 + .1922E-05 + .2131E-05 + .2339E-05 + .2578E-05 + .2821E-05 + .3120E-05 + .3435E-05 + .3827E-05 + .4459E-05 + .5000E-05 + .5522E-05 + .5844E-05 + .6179E-05 + .6527E-05 + .6715E-05 + .6855E-05 + .6882E-05 + .6830E-05 + .6573E-05 + .6395E-05 + .6230E-05 + .5984E-05 + .5826E-05 + .5759E-05 + .5702E-05 + .5699E-05 + .5750E-05 + .5722E-05 + .5667E-05 + .5551E-05 + .5334E-05 + .4945E-05 + .4589E-05 + .4249E-05 + .3795E-05 + .3292E-05 + .2746E-05 + .2287E-05 + .1709E-05 + .1277E-05 + .9539E-06 + .7983E-06 + .6221E-06 + .4344E-06 + .2462E-06 + .1395E-06 + .9550E-07 + .7154E-07 + .5359E-07 + .4090E-07 + .3863E-07 + .3649E-07 + .3347E-07 + .2987E-07 + .2666E-07 + .2553E-07 + .1292E-05 + .1475E-05 + .1676E-05 + .1876E-05 + .2083E-05 + .2286E-05 + .2519E-05 + .2749E-05 + .3044E-05 + .3348E-05 + .3724E-05 + .4393E-05 + .4946E-05 + .5480E-05 + .5768E-05 + .6086E-05 + .6441E-05 + .6601E-05 + .6727E-05 + .6735E-05 + .6660E-05 + .6357E-05 + .6170E-05 + .5998E-05 + .5736E-05 + .5586E-05 + .5527E-05 + .5486E-05 + .5510E-05 + .5594E-05 + .5581E-05 + .5554E-05 + .5458E-05 + .5253E-05 + .4855E-05 + .4521E-05 + .4229E-05 + .3814E-05 + .3342E-05 + .2810E-05 + .2352E-05 + .1778E-05 + .1344E-05 + .1016E-05 + .8335E-06 + .6388E-06 + .4423E-06 + .2524E-06 + .1440E-06 + .9797E-07 + .7247E-07 + .5361E-07 + .4044E-07 + .3822E-07 + .3612E-07 + .3330E-07 + .3000E-07 + .2702E-07 + .2597E-07 + .1255E-05 + .1437E-05 + .1641E-05 + .1840E-05 + .2045E-05 + .2243E-05 + .2474E-05 + .2692E-05 + .2984E-05 + .3278E-05 + .3640E-05 + .4349E-05 + .4916E-05 + .5464E-05 + .5721E-05 + .6022E-05 + .6386E-05 + .6519E-05 + .6634E-05 + .6625E-05 + .6529E-05 + .6184E-05 + .5988E-05 + .5810E-05 + .5531E-05 + .5389E-05 + .5337E-05 + .5310E-05 + .5359E-05 + .5473E-05 + .5473E-05 + .5471E-05 + .5392E-05 + .5197E-05 + .4791E-05 + .4476E-05 + .4224E-05 + .3821E-05 + .3363E-05 + .2839E-05 + .2389E-05 + .1838E-05 + .1414E-05 + .1088E-05 + .8744E-06 + .6591E-06 + .4525E-06 + .2600E-06 + .1494E-06 + .1010E-06 + .7376E-07 + .5388E-07 + .4018E-07 + .3799E-07 + .3592E-07 + .3328E-07 + .3027E-07 + .2752E-07 + .2654E-07 + .1221E-05 + .1403E-05 + .1608E-05 + .1807E-05 + .2012E-05 + .2206E-05 + .2433E-05 + .2641E-05 + .2930E-05 + .3216E-05 + .3565E-05 + .4313E-05 + .4894E-05 + .5458E-05 + .5684E-05 + .5969E-05 + .6343E-05 + .6449E-05 + .6553E-05 + .6529E-05 + .6414E-05 + .6029E-05 + .5825E-05 + .5641E-05 + .5346E-05 + .5211E-05 + .5165E-05 + .5151E-05 + .5223E-05 + .5366E-05 + .5378E-05 + .5400E-05 + .5337E-05 + .5151E-05 + .4736E-05 + .4438E-05 + .4224E-05 + .3832E-05 + .3387E-05 + .2872E-05 + .2436E-05 + .1906E-05 + .1491E-05 + .1166E-05 + .9189E-06 + .6813E-06 + .4637E-06 + .2683E-06 + .1552E-06 + .1043E-06 + .7521E-07 + .5425E-07 + .3999E-07 + .3783E-07 + .3579E-07 + .3333E-07 + .3060E-07 + .2808E-07 + .2718E-07 + .1194E-05 + .1376E-05 + .1584E-05 + .1783E-05 + .1988E-05 + .2179E-05 + .2405E-05 + .2603E-05 + .2891E-05 + .3170E-05 + .3508E-05 + .4299E-05 + .4896E-05 + .5477E-05 + .5674E-05 + .5947E-05 + .6331E-05 + .6412E-05 + .6506E-05 + .6468E-05 + .6335E-05 + .5912E-05 + .5698E-05 + .5508E-05 + .5197E-05 + .5068E-05 + .5029E-05 + .5026E-05 + .5120E-05 + .5290E-05 + .5313E-05 + .5356E-05 + .5308E-05 + .5129E-05 + .4705E-05 + .4422E-05 + .4242E-05 + .3856E-05 + .3417E-05 + .2915E-05 + .2507E-05 + .1992E-05 + .1582E-05 + .1257E-05 + .9705E-06 + .7076E-06 + .4776E-06 + .2782E-06 + .1621E-06 + .1082E-06 + .7707E-07 + .5489E-07 + .4000E-07 + .3786E-07 + .3583E-07 + .3354E-07 + .3108E-07 + .2880E-07 + .2797E-07 + .1184E-05 + .1366E-05 + .1573E-05 + .1776E-05 + .1985E-05 + .2176E-05 + .2398E-05 + .2601E-05 + .2885E-05 + .3173E-05 + .3538E-05 + .4303E-05 + .4913E-05 + .5472E-05 + .5708E-05 + .6002E-05 + .6331E-05 + .6397E-05 + .6456E-05 + .6410E-05 + .6278E-05 + .5901E-05 + .5705E-05 + .5528E-05 + .5249E-05 + .5127E-05 + .5080E-05 + .5066E-05 + .5134E-05 + .5265E-05 + .5271E-05 + .5297E-05 + .5246E-05 + .5081E-05 + .4682E-05 + .4409E-05 + .4229E-05 + .3864E-05 + .3421E-05 + .2941E-05 + .2553E-05 + .2074E-05 + .1685E-05 + .1369E-05 + .1036E-05 + .7431E-06 + .4973E-06 + .2917E-06 + .1711E-06 + .1135E-06 + .7984E-07 + .5615E-07 + .4045E-07 + .3830E-07 + .3627E-07 + .3413E-07 + .3192E-07 + .2985E-07 + .2910E-07 + .1170E-05 + .1348E-05 + .1549E-05 + .1754E-05 + .1969E-05 + .2159E-05 + .2374E-05 + .2591E-05 + .2863E-05 + .3171E-05 + .3594E-05 + .4256E-05 + .4866E-05 + .5355E-05 + .5691E-05 + .6033E-05 + .6242E-05 + .6298E-05 + .6303E-05 + .6252E-05 + .6141E-05 + .5893E-05 + .5741E-05 + .5600E-05 + .5403E-05 + .5293E-05 + .5226E-05 + .5177E-05 + .5174E-05 + .5204E-05 + .5166E-05 + .5139E-05 + .5072E-05 + .4928E-05 + .4592E-05 + .4329E-05 + .4123E-05 + .3798E-05 + .3347E-05 + .2903E-05 + .2532E-05 + .2084E-05 + .1715E-05 + .1411E-05 + .1060E-05 + .7552E-06 + .5038E-06 + .2963E-06 + .1742E-06 + .1153E-06 + .8072E-07 + .5651E-07 + .4052E-07 + .3838E-07 + .3636E-07 + .3427E-07 + .3217E-07 + .3019E-07 + .2947E-07 + .1160E-05 + .1336E-05 + .1531E-05 + .1739E-05 + .1961E-05 + .2150E-05 + .2358E-05 + .2590E-05 + .2852E-05 + .3181E-05 + .3663E-05 + .4224E-05 + .4836E-05 + .5261E-05 + .5694E-05 + .6087E-05 + .6178E-05 + .6225E-05 + .6177E-05 + .6121E-05 + .6029E-05 + .5906E-05 + .5798E-05 + .5694E-05 + .5582E-05 + .5485E-05 + .5396E-05 + .5310E-05 + .5233E-05 + .5162E-05 + .5082E-05 + .5004E-05 + .4923E-05 + .4798E-05 + .4521E-05 + .4267E-05 + .4033E-05 + .3746E-05 + .3287E-05 + .2877E-05 + .2521E-05 + .2080E-05 + .1716E-05 + .1416E-05 + .1064E-05 + .7580E-06 + .5056E-06 + .2973E-06 + .1749E-06 + .1157E-06 + .8101E-07 + .5671E-07 + .4067E-07 + .3852E-07 + .3649E-07 + .3440E-07 + .3228E-07 + .3030E-07 + .2957E-07 + .1139E-05 + .1315E-05 + .1512E-05 + .1729E-05 + .1966E-05 + .2152E-05 + .2356E-05 + .2587E-05 + .2850E-05 + .3175E-05 + .3643E-05 + .4159E-05 + .4755E-05 + .5196E-05 + .5591E-05 + .5951E-05 + .6064E-05 + .6085E-05 + .6029E-05 + .5973E-05 + .5893E-05 + .5803E-05 + .5715E-05 + .5628E-05 + .5543E-05 + .5458E-05 + .5375E-05 + .5294E-05 + .5213E-05 + .5134E-05 + .5056E-05 + .4958E-05 + .4842E-05 + .4699E-05 + .4448E-05 + .4210E-05 + .3959E-05 + .3657E-05 + .3228E-05 + .2849E-05 + .2515E-05 + .2083E-05 + .1725E-05 + .1428E-05 + .1072E-05 + .7643E-06 + .5098E-06 + .2998E-06 + .1763E-06 + .1167E-06 + .8169E-07 + .5718E-07 + .4101E-07 + .3884E-07 + .3679E-07 + .3468E-07 + .3255E-07 + .3055E-07 + .2982E-07 + .1116E-05 + .1293E-05 + .1494E-05 + .1720E-05 + .1974E-05 + .2157E-05 + .2356E-05 + .2584E-05 + .2850E-05 + .3166E-05 + .3603E-05 + .4088E-05 + .4663E-05 + .5138E-05 + .5468E-05 + .5780E-05 + .5942E-05 + .5934E-05 + .5879E-05 + .5824E-05 + .5754E-05 + .5679E-05 + .5604E-05 + .5530E-05 + .5458E-05 + .5386E-05 + .5315E-05 + .5246E-05 + .5177E-05 + .5109E-05 + .5042E-05 + .4929E-05 + .4775E-05 + .4607E-05 + .4375E-05 + .4154E-05 + .3889E-05 + .3563E-05 + .3170E-05 + .2821E-05 + .2510E-05 + .2086E-05 + .1734E-05 + .1441E-05 + .1082E-05 + .7713E-06 + .5145E-06 + .3026E-06 + .1779E-06 + .1178E-06 + .8244E-07 + .5771E-07 + .4138E-07 + .3920E-07 + .3713E-07 + .3500E-07 + .3285E-07 + .3083E-07 + .3009E-07 + .1093E-05 + .1271E-05 + .1476E-05 + .1711E-05 + .1981E-05 + .2161E-05 + .2356E-05 + .2580E-05 + .2850E-05 + .3157E-05 + .3564E-05 + .4018E-05 + .4574E-05 + .5079E-05 + .5348E-05 + .5613E-05 + .5822E-05 + .5787E-05 + .5733E-05 + .5679E-05 + .5619E-05 + .5556E-05 + .5495E-05 + .5434E-05 + .5374E-05 + .5314E-05 + .5256E-05 + .5197E-05 + .5140E-05 + .5083E-05 + .5027E-05 + .4900E-05 + .4709E-05 + .4517E-05 + .4303E-05 + .4099E-05 + .3820E-05 + .3470E-05 + .3113E-05 + .2793E-05 + .2505E-05 + .2090E-05 + .1743E-05 + .1454E-05 + .1092E-05 + .7782E-06 + .5191E-06 + .3053E-06 + .1795E-06 + .1188E-06 + .8317E-07 + .5822E-07 + .4175E-07 + .3955E-07 + .3746E-07 + .3531E-07 + .3314E-07 + .3111E-07 + .3036E-07 + .1361E-05 + .1493E-05 + .1629E-05 + .1761E-05 + .1903E-05 + .2057E-05 + .2223E-05 + .2401E-05 + .2595E-05 + .2805E-05 + .3033E-05 + .3265E-05 + .3502E-05 + .3756E-05 + .4012E-05 + .4140E-05 + .4272E-05 + .4403E-05 + .4363E-05 + .4317E-05 + .4246E-05 + .4170E-05 + .4095E-05 + .3981E-05 + .3831E-05 + .3687E-05 + .3553E-05 + .3425E-05 + .3301E-05 + .3188E-05 + .3084E-05 + .2983E-05 + .2886E-05 + .2788E-05 + .2684E-05 + .2585E-05 + .2358E-05 + .2103E-05 + .1833E-05 + .1575E-05 + .1289E-05 + .1084E-05 + .9115E-06 + .7664E-06 + .5460E-06 + .3735E-06 + .2629E-06 + .1953E-06 + .1452E-06 + .1018E-06 + .6942E-07 + .4735E-07 + .3297E-07 + .2912E-07 + .2572E-07 + .2308E-07 + .2101E-07 + .1912E-07 + .1845E-07 + .1314E-05 + .1444E-05 + .1580E-05 + .1711E-05 + .1852E-05 + .2005E-05 + .2167E-05 + .2343E-05 + .2535E-05 + .2744E-05 + .2971E-05 + .3210E-05 + .3461E-05 + .3732E-05 + .3988E-05 + .4160E-05 + .4340E-05 + .4514E-05 + .4492E-05 + .4457E-05 + .4361E-05 + .4252E-05 + .4147E-05 + .4017E-05 + .3866E-05 + .3720E-05 + .3591E-05 + .3469E-05 + .3351E-05 + .3240E-05 + .3137E-05 + .3038E-05 + .2941E-05 + .2838E-05 + .2719E-05 + .2605E-05 + .2410E-05 + .2197E-05 + .1900E-05 + .1622E-05 + .1335E-05 + .1102E-05 + .9101E-06 + .7514E-06 + .5353E-06 + .3662E-06 + .2577E-06 + .1915E-06 + .1423E-06 + .9978E-07 + .6806E-07 + .4643E-07 + .3233E-07 + .2855E-07 + .2522E-07 + .2262E-07 + .2059E-07 + .1875E-07 + .1809E-07 + .1280E-05 + .1407E-05 + .1545E-05 + .1675E-05 + .1817E-05 + .1969E-05 + .2130E-05 + .2305E-05 + .2495E-05 + .2706E-05 + .2934E-05 + .3181E-05 + .3449E-05 + .3739E-05 + .3997E-05 + .4215E-05 + .4445E-05 + .4667E-05 + .4665E-05 + .4640E-05 + .4517E-05 + .4373E-05 + .4233E-05 + .4086E-05 + .3932E-05 + .3784E-05 + .3659E-05 + .3542E-05 + .3429E-05 + .3321E-05 + .3218E-05 + .3119E-05 + .3022E-05 + .2914E-05 + .2777E-05 + .2647E-05 + .2483E-05 + .2314E-05 + .1987E-05 + .1685E-05 + .1394E-05 + .1130E-05 + .9161E-06 + .7427E-06 + .5291E-06 + .3619E-06 + .2547E-06 + .1893E-06 + .1407E-06 + .9862E-07 + .6727E-07 + .4589E-07 + .3195E-07 + .2822E-07 + .2492E-07 + .2236E-07 + .2035E-07 + .1853E-07 + .1787E-07 + .1274E-05 + .1401E-05 + .1541E-05 + .1672E-05 + .1815E-05 + .1968E-05 + .2129E-05 + .2305E-05 + .2493E-05 + .2715E-05 + .2941E-05 + .3204E-05 + .3491E-05 + .3810E-05 + .4090E-05 + .4369E-05 + .4643E-05 + .4894E-05 + .4923E-05 + .4915E-05 + .4788E-05 + .4620E-05 + .4466E-05 + .4291E-05 + .4135E-05 + .3927E-05 + .3793E-05 + .3675E-05 + .3561E-05 + .3467E-05 + .3377E-05 + .3282E-05 + .3184E-05 + .3039E-05 + .2856E-05 + .2712E-05 + .2606E-05 + .2469E-05 + .2121E-05 + .1797E-05 + .1488E-05 + .1182E-05 + .9398E-06 + .7469E-06 + .5321E-06 + .3640E-06 + .2562E-06 + .1904E-06 + .1414E-06 + .9918E-07 + .6765E-07 + .4614E-07 + .3213E-07 + .2838E-07 + .2506E-07 + .2249E-07 + .2047E-07 + .1863E-07 + .1798E-07 + .1289E-05 + .1411E-05 + .1546E-05 + .1677E-05 + .1817E-05 + .1965E-05 + .2119E-05 + .2297E-05 + .2470E-05 + .2716E-05 + .2924E-05 + .3208E-05 + .3504E-05 + .3863E-05 + .4227E-05 + .4590E-05 + .4861E-05 + .5044E-05 + .5142E-05 + .5169E-05 + .5142E-05 + .5023E-05 + .4934E-05 + .4716E-05 + .4564E-05 + .4135E-05 + .3951E-05 + .3808E-05 + .3676E-05 + .3626E-05 + .3590E-05 + .3515E-05 + .3418E-05 + .3160E-05 + .2861E-05 + .2713E-05 + .2719E-05 + .2545E-05 + .2257E-05 + .1948E-05 + .1588E-05 + .1236E-05 + .9615E-06 + .7481E-06 + .5330E-06 + .3646E-06 + .2566E-06 + .1907E-06 + .1417E-06 + .9935E-07 + .6776E-07 + .4622E-07 + .3219E-07 + .2843E-07 + .2511E-07 + .2252E-07 + .2050E-07 + .1866E-07 + .1801E-07 + .1305E-05 + .1430E-05 + .1561E-05 + .1692E-05 + .1833E-05 + .1982E-05 + .2145E-05 + .2325E-05 + .2520E-05 + .2747E-05 + .2992E-05 + .3272E-05 + .3585E-05 + .3961E-05 + .4362E-05 + .4742E-05 + .5059E-05 + .5281E-05 + .5401E-05 + .5440E-05 + .5398E-05 + .5289E-05 + .5149E-05 + .4940E-05 + .4750E-05 + .4457E-05 + .4266E-05 + .4094E-05 + .3935E-05 + .3835E-05 + .3756E-05 + .3664E-05 + .3564E-05 + .3395E-05 + .3119E-05 + .2915E-05 + .2816E-05 + .2596E-05 + .2321E-05 + .1992E-05 + .1624E-05 + .1241E-05 + .9487E-06 + .7250E-06 + .5167E-06 + .3558E-06 + .2516E-06 + .1870E-06 + .1390E-06 + .9805E-07 + .6744E-07 + .4639E-07 + .3256E-07 + .2883E-07 + .2552E-07 + .2290E-07 + .2079E-07 + .1887E-07 + .1819E-07 + .1337E-05 + .1461E-05 + .1589E-05 + .1723E-05 + .1867E-05 + .2021E-05 + .2192E-05 + .2380E-05 + .2594E-05 + .2818E-05 + .3085E-05 + .3364E-05 + .3698E-05 + .4088E-05 + .4526E-05 + .4937E-05 + .5296E-05 + .5559E-05 + .5716E-05 + .5779E-05 + .5739E-05 + .5633E-05 + .5470E-05 + .5272E-05 + .5064E-05 + .4846E-05 + .4649E-05 + .4453E-05 + .4264E-05 + .4118E-05 + .4002E-05 + .3885E-05 + .3769E-05 + .3632E-05 + .3357E-05 + .3111E-05 + .2919E-05 + .2668E-05 + .2384E-05 + .2032E-05 + .1648E-05 + .1217E-05 + .8986E-06 + .6635E-06 + .4733E-06 + .3318E-06 + .2374E-06 + .1767E-06 + .1315E-06 + .9417E-07 + .6623E-07 + .4658E-07 + .3339E-07 + .2976E-07 + .2652E-07 + .2378E-07 + .2144E-07 + .1933E-07 + .1858E-07 + .1369E-05 + .1490E-05 + .1615E-05 + .1751E-05 + .1899E-05 + .2059E-05 + .2238E-05 + .2436E-05 + .2663E-05 + .2902E-05 + .3170E-05 + .3447E-05 + .3804E-05 + .4199E-05 + .4668E-05 + .5124E-05 + .5514E-05 + .5820E-05 + .6028E-05 + .6128E-05 + .6114E-05 + .6003E-05 + .5854E-05 + .5674E-05 + .5476E-05 + .5259E-05 + .5059E-05 + .4848E-05 + .4628E-05 + .4444E-05 + .4298E-05 + .4147E-05 + .4000E-05 + .3821E-05 + .3522E-05 + .3257E-05 + .2994E-05 + .2732E-05 + .2417E-05 + .2043E-05 + .1639E-05 + .1177E-05 + .8449E-06 + .6065E-06 + .4331E-06 + .3091E-06 + .2238E-06 + .1667E-06 + .1242E-06 + .9034E-07 + .6497E-07 + .4672E-07 + .3420E-07 + .3068E-07 + .2752E-07 + .2466E-07 + .2208E-07 + .1978E-07 + .1896E-07 + .1430E-05 + .1560E-05 + .1691E-05 + .1831E-05 + .1980E-05 + .2142E-05 + .2322E-05 + .2520E-05 + .2748E-05 + .2980E-05 + .3259E-05 + .3555E-05 + .3921E-05 + .4338E-05 + .4822E-05 + .5314E-05 + .5731E-05 + .6089E-05 + .6338E-05 + .6471E-05 + .6475E-05 + .6371E-05 + .6245E-05 + .6082E-05 + .5900E-05 + .5690E-05 + .5486E-05 + .5262E-05 + .5029E-05 + .4810E-05 + .4633E-05 + .4419E-05 + .4206E-05 + .3977E-05 + .3671E-05 + .3387E-05 + .3069E-05 + .2763E-05 + .2421E-05 + .2022E-05 + .1605E-05 + .1127E-05 + .7914E-06 + .5558E-06 + .3972E-06 + .2885E-06 + .2115E-06 + .1577E-06 + .1176E-06 + .8688E-07 + .6388E-07 + .4697E-07 + .3511E-07 + .3170E-07 + .2863E-07 + .2564E-07 + .2280E-07 + .2028E-07 + .1939E-07 + .1497E-05 + .1640E-05 + .1781E-05 + .1923E-05 + .2072E-05 + .2231E-05 + .2406E-05 + .2598E-05 + .2820E-05 + .3034E-05 + .3323E-05 + .3647E-05 + .4014E-05 + .4458E-05 + .4944E-05 + .5467E-05 + .5904E-05 + .6318E-05 + .6603E-05 + .6767E-05 + .6785E-05 + .6697E-05 + .6599E-05 + .6455E-05 + .6295E-05 + .6099E-05 + .5894E-05 + .5658E-05 + .5425E-05 + .5171E-05 + .4963E-05 + .4667E-05 + .4369E-05 + .4085E-05 + .3783E-05 + .3485E-05 + .3120E-05 + .2757E-05 + .2393E-05 + .1970E-05 + .1547E-05 + .1066E-05 + .7343E-06 + .5058E-06 + .3618E-06 + .2676E-06 + .1985E-06 + .1482E-06 + .1106E-06 + .8297E-07 + .6239E-07 + .4691E-07 + .3581E-07 + .3254E-07 + .2957E-07 + .2648E-07 + .2339E-07 + .2066E-07 + .1970E-07 + .1502E-05 + .1659E-05 + .1816E-05 + .1970E-05 + .2126E-05 + .2294E-05 + .2474E-05 + .2676E-05 + .2887E-05 + .3132E-05 + .3424E-05 + .3754E-05 + .4113E-05 + .4570E-05 + .5072E-05 + .5618E-05 + .6107E-05 + .6565E-05 + .6874E-05 + .7064E-05 + .7107E-05 + .7043E-05 + .6946E-05 + .6824E-05 + .6663E-05 + .6470E-05 + .6268E-05 + .6021E-05 + .5767E-05 + .5508E-05 + .5298E-05 + .4964E-05 + .4604E-05 + .4242E-05 + .3881E-05 + .3529E-05 + .3122E-05 + .2713E-05 + .2319E-05 + .1880E-05 + .1452E-05 + .9885E-06 + .6731E-06 + .4583E-06 + .3281E-06 + .2470E-06 + .1855E-06 + .1386E-06 + .1036E-06 + .7890E-07 + .6066E-07 + .4663E-07 + .3635E-07 + .3326E-07 + .3042E-07 + .2723E-07 + .2388E-07 + .2095E-07 + .1992E-07 + .1495E-05 + .1663E-05 + .1835E-05 + .1999E-05 + .2164E-05 + .2339E-05 + .2524E-05 + .2736E-05 + .2936E-05 + .3214E-05 + .3505E-05 + .3836E-05 + .4188E-05 + .4654E-05 + .5166E-05 + .5734E-05 + .6271E-05 + .6768E-05 + .7101E-05 + .7316E-05 + .7389E-05 + .7348E-05 + .7254E-05 + .7156E-05 + .6993E-05 + .6804E-05 + .6609E-05 + .6356E-05 + .6082E-05 + .5819E-05 + .5605E-05 + .5240E-05 + .4822E-05 + .4381E-05 + .3950E-05 + .3541E-05 + .3094E-05 + .2649E-05 + .2227E-05 + .1777E-05 + .1347E-05 + .9079E-06 + .6119E-06 + .4124E-06 + .2955E-06 + .2265E-06 + .1721E-06 + .1288E-06 + .9632E-07 + .7452E-07 + .5858E-07 + .4605E-07 + .3666E-07 + .3375E-07 + .3108E-07 + .2780E-07 + .2422E-07 + .2110E-07 + .2001E-07 + .1530E-05 + .1695E-05 + .1866E-05 + .2031E-05 + .2198E-05 + .2374E-05 + .2563E-05 + .2780E-05 + .2988E-05 + .3263E-05 + .3545E-05 + .3882E-05 + .4250E-05 + .4730E-05 + .5235E-05 + .5831E-05 + .6371E-05 + .6875E-05 + .7252E-05 + .7487E-05 + .7597E-05 + .7574E-05 + .7502E-05 + .7415E-05 + .7262E-05 + .7088E-05 + .6909E-05 + .6682E-05 + .6416E-05 + .6112E-05 + .5827E-05 + .5431E-05 + .5000E-05 + .4515E-05 + .3992E-05 + .3524E-05 + .3032E-05 + .2580E-05 + .2131E-05 + .1661E-05 + .1234E-05 + .8264E-06 + .5537E-06 + .3709E-06 + .2661E-06 + .2076E-06 + .1597E-06 + .1196E-06 + .8954E-07 + .7034E-07 + .5654E-07 + .4544E-07 + .3695E-07 + .3424E-07 + .3174E-07 + .2838E-07 + .2455E-07 + .2124E-07 + .2009E-07 + .1559E-05 + .1720E-05 + .1888E-05 + .2052E-05 + .2219E-05 + .2395E-05 + .2586E-05 + .2804E-05 + .3018E-05 + .3295E-05 + .3573E-05 + .3911E-05 + .4293E-05 + .4771E-05 + .5270E-05 + .5877E-05 + .6418E-05 + .6931E-05 + .7347E-05 + .7610E-05 + .7749E-05 + .7748E-05 + .7702E-05 + .7634E-05 + .7498E-05 + .7344E-05 + .7178E-05 + .6976E-05 + .6718E-05 + .6380E-05 + .6029E-05 + .5599E-05 + .5136E-05 + .4592E-05 + .3996E-05 + .3481E-05 + .2960E-05 + .2491E-05 + .2018E-05 + .1542E-05 + .1124E-05 + .7483E-06 + .4984E-06 + .3319E-06 + .2383E-06 + .1893E-06 + .1474E-06 + .1105E-06 + .8280E-07 + .6606E-07 + .5429E-07 + .4462E-07 + .3704E-07 + .3456E-07 + .3224E-07 + .2882E-07 + .2476E-07 + .2127E-07 + .2007E-07 + .1592E-05 + .1748E-05 + .1909E-05 + .2071E-05 + .2236E-05 + .2412E-05 + .2601E-05 + .2818E-05 + .3035E-05 + .3326E-05 + .3619E-05 + .3949E-05 + .4341E-05 + .4790E-05 + .5286E-05 + .5876E-05 + .6419E-05 + .6954E-05 + .7395E-05 + .7708E-05 + .7857E-05 + .7885E-05 + .7873E-05 + .7836E-05 + .7732E-05 + .7606E-05 + .7440E-05 + .7256E-05 + .6998E-05 + .6648E-05 + .6248E-05 + .5767E-05 + .5231E-05 + .4587E-05 + .3966E-05 + .3420E-05 + .2898E-05 + .2389E-05 + .1890E-05 + .1426E-05 + .1023E-05 + .6775E-06 + .4486E-06 + .2971E-06 + .2135E-06 + .1726E-06 + .1360E-06 + .1020E-06 + .7658E-07 + .6205E-07 + .5214E-07 + .4382E-07 + .3715E-07 + .3488E-07 + .3275E-07 + .2926E-07 + .2497E-07 + .2130E-07 + .2005E-07 + .1604E-05 + .1760E-05 + .1919E-05 + .2079E-05 + .2242E-05 + .2419E-05 + .2609E-05 + .2828E-05 + .3047E-05 + .3343E-05 + .3638E-05 + .3971E-05 + .4359E-05 + .4800E-05 + .5299E-05 + .5885E-05 + .6442E-05 + .6987E-05 + .7445E-05 + .7785E-05 + .7959E-05 + .8006E-05 + .8023E-05 + .8019E-05 + .7947E-05 + .7857E-05 + .7700E-05 + .7547E-05 + .7279E-05 + .6928E-05 + .6497E-05 + .5961E-05 + .5346E-05 + .4619E-05 + .3945E-05 + .3362E-05 + .2828E-05 + .2285E-05 + .1764E-05 + .1304E-05 + .9081E-06 + .6029E-06 + .4003E-06 + .2657E-06 + .1911E-06 + .1573E-06 + .1255E-06 + .9424E-07 + .7079E-07 + .5825E-07 + .5005E-07 + .4301E-07 + .3723E-07 + .3519E-07 + .3326E-07 + .2971E-07 + .2517E-07 + .2133E-07 + .2002E-07 + .1598E-05 + .1761E-05 + .1921E-05 + .2077E-05 + .2241E-05 + .2420E-05 + .2612E-05 + .2837E-05 + .3057E-05 + .3351E-05 + .3637E-05 + .3984E-05 + .4353E-05 + .4809E-05 + .5317E-05 + .5910E-05 + .6493E-05 + .7038E-05 + .7507E-05 + .7851E-05 + .8064E-05 + .8122E-05 + .8162E-05 + .8194E-05 + .8153E-05 + .8107E-05 + .7969E-05 + .7859E-05 + .7569E-05 + .7228E-05 + .6786E-05 + .6187E-05 + .5487E-05 + .4692E-05 + .3937E-05 + .3309E-05 + .2753E-05 + .2183E-05 + .1644E-05 + .1180E-05 + .7883E-06 + .5287E-06 + .3546E-06 + .2379E-06 + .1713E-06 + .1435E-06 + .1158E-06 + .8709E-07 + .6549E-07 + .5473E-07 + .4808E-07 + .4224E-07 + .3735E-07 + .3553E-07 + .3381E-07 + .3018E-07 + .2539E-07 + .2137E-07 + .2001E-07 + .1588E-05 + .1758E-05 + .1923E-05 + .2082E-05 + .2246E-05 + .2426E-05 + .2623E-05 + .2852E-05 + .3081E-05 + .3369E-05 + .3652E-05 + .3999E-05 + .4390E-05 + .4843E-05 + .5354E-05 + .5935E-05 + .6531E-05 + .7087E-05 + .7572E-05 + .7934E-05 + .8161E-05 + .8265E-05 + .8328E-05 + .8403E-05 + .8407E-05 + .8366E-05 + .8280E-05 + .8185E-05 + .7888E-05 + .7524E-05 + .7057E-05 + .6419E-05 + .5648E-05 + .4790E-05 + .3956E-05 + .3262E-05 + .2672E-05 + .2082E-05 + .1529E-05 + .1058E-05 + .6863E-06 + .4628E-06 + .3121E-06 + .2105E-06 + .1523E-06 + .1296E-06 + .1060E-06 + .8043E-07 + .6101E-07 + .5181E-07 + .4642E-07 + .4159E-07 + .3745E-07 + .3570E-07 + .3403E-07 + .3020E-07 + .2507E-07 + .2094E-07 + .1952E-07 + .1577E-05 + .1753E-05 + .1926E-05 + .2091E-05 + .2256E-05 + .2436E-05 + .2636E-05 + .2871E-05 + .3111E-05 + .3391E-05 + .3674E-05 + .4017E-05 + .4446E-05 + .4889E-05 + .5400E-05 + .5962E-05 + .6565E-05 + .7138E-05 + .7640E-05 + .8027E-05 + .8258E-05 + .8424E-05 + .8510E-05 + .8632E-05 + .8686E-05 + .8638E-05 + .8619E-05 + .8529E-05 + .8228E-05 + .7827E-05 + .7329E-05 + .6662E-05 + .5822E-05 + .4902E-05 + .3986E-05 + .3219E-05 + .2591E-05 + .1983E-05 + .1422E-05 + .9461E-06 + .5983E-06 + .4012E-06 + .2691E-06 + .1805E-06 + .1327E-06 + .1141E-06 + .9493E-07 + .7406E-07 + .5778E-07 + .4995E-07 + .4534E-07 + .4115E-07 + .3747E-07 + .3538E-07 + .3341E-07 + .2905E-07 + .2341E-07 + .1937E-07 + .1792E-07 + .1535E-05 + .1706E-05 + .1874E-05 + .2041E-05 + .2213E-05 + .2403E-05 + .2612E-05 + .2859E-05 + .3099E-05 + .3401E-05 + .3690E-05 + .4025E-05 + .4444E-05 + .4898E-05 + .5404E-05 + .5960E-05 + .6593E-05 + .7207E-05 + .7736E-05 + .8130E-05 + .8385E-05 + .8559E-05 + .8700E-05 + .8855E-05 + .8950E-05 + .8945E-05 + .8956E-05 + .8889E-05 + .8567E-05 + .8132E-05 + .7577E-05 + .6836E-05 + .5946E-05 + .4980E-05 + .4007E-05 + .3179E-05 + .2505E-05 + .1877E-05 + .1308E-05 + .8337E-06 + .5022E-06 + .3399E-06 + .2300E-06 + .1557E-06 + .1163E-06 + .1011E-06 + .8548E-07 + .6860E-07 + .5504E-07 + .4844E-07 + .4455E-07 + .4096E-07 + .3772E-07 + .3528E-07 + .3300E-07 + .2811E-07 + .2198E-07 + .1802E-07 + .1654E-07 + .1492E-05 + .1657E-05 + .1822E-05 + .1989E-05 + .2165E-05 + .2362E-05 + .2576E-05 + .2832E-05 + .3071E-05 + .3392E-05 + .3690E-05 + .4018E-05 + .4423E-05 + .4893E-05 + .5392E-05 + .5943E-05 + .6600E-05 + .7243E-05 + .7791E-05 + .8197E-05 + .8480E-05 + .8671E-05 + .8869E-05 + .9055E-05 + .9187E-05 + .9229E-05 + .9264E-05 + .9218E-05 + .8871E-05 + .8400E-05 + .7788E-05 + .6971E-05 + .6034E-05 + .5027E-05 + .4008E-05 + .3124E-05 + .2409E-05 + .1767E-05 + .1195E-05 + .7300E-06 + .4185E-06 + .2861E-06 + .1956E-06 + .1338E-06 + .1015E-06 + .8916E-07 + .7667E-07 + .6328E-07 + .5223E-07 + .4679E-07 + .4359E-07 + .4061E-07 + .3781E-07 + .3503E-07 + .3245E-07 + .2709E-07 + .2056E-07 + .1670E-07 + .1521E-07 + .1488E-05 + .1658E-05 + .1828E-05 + .1992E-05 + .2159E-05 + .2347E-05 + .2553E-05 + .2802E-05 + .3039E-05 + .3361E-05 + .3685E-05 + .4029E-05 + .4431E-05 + .4944E-05 + .5441E-05 + .6001E-05 + .6650E-05 + .7255E-05 + .7792E-05 + .8247E-05 + .8585E-05 + .8858E-05 + .9112E-05 + .9327E-05 + .9462E-05 + .9552E-05 + .9575E-05 + .9521E-05 + .9127E-05 + .8596E-05 + .7952E-05 + .7054E-05 + .6071E-05 + .5022E-05 + .3989E-05 + .3061E-05 + .2302E-05 + .1658E-05 + .1081E-05 + .6348E-06 + .3479E-06 + .2404E-06 + .1662E-06 + .1148E-06 + .8848E-07 + .7858E-07 + .6871E-07 + .5833E-07 + .4952E-07 + .4516E-07 + .4262E-07 + .4022E-07 + .3787E-07 + .3475E-07 + .3189E-07 + .2609E-07 + .1921E-07 + .1546E-07 + .1397E-07 + .1480E-05 + .1648E-05 + .1817E-05 + .1976E-05 + .2137E-05 + .2319E-05 + .2520E-05 + .2764E-05 + .2998E-05 + .3324E-05 + .3647E-05 + .4008E-05 + .4406E-05 + .4932E-05 + .5437E-05 + .5998E-05 + .6626E-05 + .7210E-05 + .7748E-05 + .8243E-05 + .8641E-05 + .8983E-05 + .9302E-05 + .9564E-05 + .9714E-05 + .9842E-05 + .9854E-05 + .9791E-05 + .9353E-05 + .8791E-05 + .8097E-05 + .7132E-05 + .6101E-05 + .5013E-05 + .3962E-05 + .2994E-05 + .2198E-05 + .1553E-05 + .9827E-06 + .5521E-06 + .2908E-06 + .2027E-06 + .1413E-06 + .9848E-07 + .7708E-07 + .6918E-07 + .6151E-07 + .5371E-07 + .4690E-07 + .4354E-07 + .4163E-07 + .3979E-07 + .3789E-07 + .3444E-07 + .3131E-07 + .2510E-07 + .1793E-07 + .1430E-07 + .1282E-07 + .1469E-05 + .1625E-05 + .1782E-05 + .1934E-05 + .2093E-05 + .2275E-05 + .2476E-05 + .2721E-05 + .2949E-05 + .3285E-05 + .3564E-05 + .3942E-05 + .4338E-05 + .4822E-05 + .5355E-05 + .5903E-05 + .6490E-05 + .7084E-05 + .7649E-05 + .8170E-05 + .8633E-05 + .9015E-05 + .9416E-05 + .9758E-05 + .9944E-05 + .1009E-04 + .1009E-04 + .1002E-04 + .9547E-05 + .9009E-05 + .8230E-05 + .7222E-05 + .6139E-05 + .5011E-05 + .3933E-05 + .2929E-05 + .2105E-05 + .1456E-05 + .9061E-06 + .4818E-06 + .2466E-06 + .1726E-06 + .1208E-06 + .8456E-07 + .6723E-07 + .6099E-07 + .5514E-07 + .4952E-07 + .4447E-07 + .4204E-07 + .4071E-07 + .3943E-07 + .3796E-07 + .3418E-07 + .3078E-07 + .2418E-07 + .1676E-07 + .1324E-07 + .1178E-07 + .1456E-05 + .1610E-05 + .1761E-05 + .1908E-05 + .2064E-05 + .2242E-05 + .2438E-05 + .2674E-05 + .2903E-05 + .3221E-05 + .3497E-05 + .3887E-05 + .4279E-05 + .4726E-05 + .5261E-05 + .5805E-05 + .6366E-05 + .6960E-05 + .7533E-05 + .8093E-05 + .8599E-05 + .9050E-05 + .9529E-05 + .9930E-05 + .1018E-04 + .1038E-04 + .1038E-04 + .1027E-04 + .9741E-05 + .9174E-05 + .8348E-05 + .7302E-05 + .6174E-05 + .5019E-05 + .3916E-05 + .2899E-05 + .2043E-05 + .1376E-05 + .8347E-06 + .4319E-06 + .2175E-06 + .1509E-06 + .1048E-06 + .7271E-07 + .5872E-07 + .5383E-07 + .4949E-07 + .4571E-07 + .4223E-07 + .4063E-07 + .3986E-07 + .3911E-07 + .3808E-07 + .3396E-07 + .3029E-07 + .2332E-07 + .1569E-07 + .1228E-07 + .1084E-07 + .1443E-05 + .1601E-05 + .1752E-05 + .1895E-05 + .2045E-05 + .2215E-05 + .2405E-05 + .2625E-05 + .2857E-05 + .3137E-05 + .3440E-05 + .3839E-05 + .4226E-05 + .4638E-05 + .5157E-05 + .5705E-05 + .6252E-05 + .6836E-05 + .7404E-05 + .8013E-05 + .8544E-05 + .9085E-05 + .9640E-05 + .1008E-04 + .1042E-04 + .1069E-04 + .1070E-04 + .1054E-04 + .9933E-05 + .9296E-05 + .8453E-05 + .7373E-05 + .6205E-05 + .5034E-05 + .3909E-05 + .2894E-05 + .2003E-05 + .1308E-05 + .7682E-06 + .3953E-06 + .1978E-06 + .1348E-06 + .9183E-07 + .6256E-07 + .5132E-07 + .4756E-07 + .4445E-07 + .4223E-07 + .4013E-07 + .3931E-07 + .3907E-07 + .3883E-07 + .3823E-07 + .3378E-07 + .2984E-07 + .2251E-07 + .1470E-07 + .1139E-07 + .9980E-08 + .1455E-05 + .1603E-05 + .1745E-05 + .1882E-05 + .2028E-05 + .2194E-05 + .2382E-05 + .2596E-05 + .2829E-05 + .3101E-05 + .3393E-05 + .3771E-05 + .4137E-05 + .4544E-05 + .5035E-05 + .5571E-05 + .6126E-05 + .6709E-05 + .7300E-05 + .7905E-05 + .8522E-05 + .9129E-05 + .9714E-05 + .1019E-04 + .1057E-04 + .1090E-04 + .1094E-04 + .1076E-04 + .1014E-04 + .9439E-05 + .8541E-05 + .7430E-05 + .6235E-05 + .5057E-05 + .3926E-05 + .2889E-05 + .1991E-05 + .1279E-05 + .7285E-06 + .3577E-06 + .1721E-06 + .1168E-06 + .7923E-07 + .5375E-07 + .4479E-07 + .4195E-07 + .3987E-07 + .3896E-07 + .3807E-07 + .3797E-07 + .3823E-07 + .3849E-07 + .3832E-07 + .3354E-07 + .2935E-07 + .2169E-07 + .1375E-07 + .1056E-07 + .9176E-08 + .1466E-05 + .1599E-05 + .1730E-05 + .1859E-05 + .2002E-05 + .2163E-05 + .2348E-05 + .2558E-05 + .2791E-05 + .3063E-05 + .3331E-05 + .3677E-05 + .4017E-05 + .4425E-05 + .4882E-05 + .5400E-05 + .5966E-05 + .6548E-05 + .7166E-05 + .7747E-05 + .8465E-05 + .9126E-05 + .9724E-05 + .1023E-04 + .1063E-04 + .1101E-04 + .1110E-04 + .1090E-04 + .1030E-04 + .9537E-05 + .8578E-05 + .7443E-05 + .6229E-05 + .5057E-05 + .3929E-05 + .2867E-05 + .1976E-05 + .1253E-05 + .6933E-06 + .3208E-06 + .1470E-06 + .1051E-06 + .7518E-07 + .5377E-07 + .4463E-07 + .4143E-07 + .3919E-07 + .3843E-07 + .3768E-07 + .3756E-07 + .3773E-07 + .3790E-07 + .3768E-07 + .3333E-07 + .2948E-07 + .2250E-07 + .1478E-07 + .1123E-07 + .9774E-08 + .1432E-05 + .1569E-05 + .1701E-05 + .1832E-05 + .1975E-05 + .2136E-05 + .2317E-05 + .2522E-05 + .2744E-05 + .3013E-05 + .3303E-05 + .3623E-05 + .3976E-05 + .4334E-05 + .4746E-05 + .5212E-05 + .5799E-05 + .6391E-05 + .7042E-05 + .7698E-05 + .8421E-05 + .9067E-05 + .9665E-05 + .1019E-04 + .1059E-04 + .1096E-04 + .1106E-04 + .1092E-04 + .1036E-04 + .9572E-05 + .8518E-05 + .7383E-05 + .6156E-05 + .4973E-05 + .3884E-05 + .2867E-05 + .1986E-05 + .1273E-05 + .7062E-06 + .3212E-06 + .1482E-06 + .1066E-06 + .7663E-07 + .5510E-07 + .4544E-07 + .4169E-07 + .3913E-07 + .3837E-07 + .3761E-07 + .3737E-07 + .3737E-07 + .3737E-07 + .3705E-07 + .3321E-07 + .2977E-07 + .2363E-07 + .1625E-07 + .1221E-07 + .1066E-07 + .1401E-05 + .1542E-05 + .1676E-05 + .1809E-05 + .1952E-05 + .2113E-05 + .2291E-05 + .2494E-05 + .2711E-05 + .2980E-05 + .3281E-05 + .3578E-05 + .3927E-05 + .4249E-05 + .4619E-05 + .5048E-05 + .5651E-05 + .6265E-05 + .6950E-05 + .7678E-05 + .8401E-05 + .9025E-05 + .9610E-05 + .1014E-04 + .1054E-04 + .1090E-04 + .1101E-04 + .1095E-04 + .1042E-04 + .9600E-05 + .8462E-05 + .7315E-05 + .6075E-05 + .4888E-05 + .3827E-05 + .2856E-05 + .1992E-05 + .1291E-05 + .7186E-06 + .3243E-06 + .1505E-06 + .1085E-06 + .7826E-07 + .5644E-07 + .4623E-07 + .4192E-07 + .3905E-07 + .3828E-07 + .3753E-07 + .3717E-07 + .3700E-07 + .3683E-07 + .3640E-07 + .3307E-07 + .3005E-07 + .2482E-07 + .1786E-07 + .1326E-07 + .1162E-07 + .1387E-05 + .1534E-05 + .1671E-05 + .1804E-05 + .1945E-05 + .2105E-05 + .2290E-05 + .2504E-05 + .2737E-05 + .3018E-05 + .3285E-05 + .3569E-05 + .3847E-05 + .4185E-05 + .4524E-05 + .4971E-05 + .5577E-05 + .6269E-05 + .7000E-05 + .7788E-05 + .8496E-05 + .9079E-05 + .9601E-05 + .1009E-04 + .1047E-04 + .1080E-04 + .1102E-04 + .1103E-04 + .1047E-04 + .9626E-05 + .8452E-05 + .7226E-05 + .5975E-05 + .4804E-05 + .3732E-05 + .2803E-05 + .1988E-05 + .1296E-05 + .7248E-06 + .3368E-06 + .1553E-06 + .1117E-06 + .8032E-07 + .5777E-07 + .4701E-07 + .4213E-07 + .3894E-07 + .3817E-07 + .3741E-07 + .3694E-07 + .3661E-07 + .3627E-07 + .3574E-07 + .3291E-07 + .3031E-07 + .2604E-07 + .1962E-07 + .1440E-07 + .1266E-07 + .1388E-05 + .1536E-05 + .1674E-05 + .1805E-05 + .1944E-05 + .2104E-05 + .2290E-05 + .2506E-05 + .2740E-05 + .3024E-05 + .3278E-05 + .3543E-05 + .3778E-05 + .4129E-05 + .4466E-05 + .4927E-05 + .5542E-05 + .6257E-05 + .7015E-05 + .7824E-05 + .8524E-05 + .9072E-05 + .9550E-05 + .1001E-04 + .1037E-04 + .1071E-04 + .1099E-04 + .1106E-04 + .1049E-04 + .9633E-05 + .8423E-05 + .7150E-05 + .5893E-05 + .4747E-05 + .3685E-05 + .2776E-05 + .1977E-05 + .1296E-05 + .7311E-06 + .3481E-06 + .1579E-06 + .1139E-06 + .8216E-07 + .5926E-07 + .4790E-07 + .4244E-07 + .3892E-07 + .3814E-07 + .3738E-07 + .3680E-07 + .3630E-07 + .3581E-07 + .3517E-07 + .3283E-07 + .3064E-07 + .2739E-07 + .2160E-07 + .1567E-07 + .1382E-07 + .1409E-05 + .1552E-05 + .1686E-05 + .1812E-05 + .1951E-05 + .2109E-05 + .2287E-05 + .2492E-05 + .2703E-05 + .2976E-05 + .3247E-05 + .3486E-05 + .3721E-05 + .4077E-05 + .4453E-05 + .4922E-05 + .5558E-05 + .6211E-05 + .6968E-05 + .7734E-05 + .8434E-05 + .8959E-05 + .9423E-05 + .9869E-05 + .1023E-04 + .1062E-04 + .1088E-04 + .1097E-04 + .1046E-04 + .9598E-05 + .8355E-05 + .7082E-05 + .5831E-05 + .4720E-05 + .3704E-05 + .2783E-05 + .1952E-05 + .1286E-05 + .7362E-06 + .3568E-06 + .1568E-06 + .1154E-06 + .8489E-07 + .6246E-07 + .5018E-07 + .4384E-07 + .3983E-07 + .3899E-07 + .3816E-07 + .3756E-07 + .3707E-07 + .3659E-07 + .3597E-07 + .3385E-07 + .3186E-07 + .2897E-07 + .2335E-07 + .1698E-07 + .1502E-07 + .1419E-05 + .1558E-05 + .1688E-05 + .1813E-05 + .1952E-05 + .2108E-05 + .2281E-05 + .2477E-05 + .2674E-05 + .2929E-05 + .3200E-05 + .3436E-05 + .3689E-05 + .4048E-05 + .4437E-05 + .4910E-05 + .5524E-05 + .6154E-05 + .6900E-05 + .7632E-05 + .8287E-05 + .8779E-05 + .9243E-05 + .9705E-05 + .1008E-04 + .1053E-04 + .1082E-04 + .1091E-04 + .1039E-04 + .9528E-05 + .8308E-05 + .6975E-05 + .5796E-05 + .4665E-05 + .3660E-05 + .2746E-05 + .1929E-05 + .1281E-05 + .7409E-06 + .3618E-06 + .1665E-06 + .1230E-06 + .9082E-07 + .6707E-07 + .5360E-07 + .4607E-07 + .4138E-07 + .4042E-07 + .3948E-07 + .3897E-07 + .3868E-07 + .3838E-07 + .3793E-07 + .3580E-07 + .3378E-07 + .3057E-07 + .2459E-07 + .1815E-07 + .1611E-07 + .1425E-05 + .1559E-05 + .1687E-05 + .1811E-05 + .1950E-05 + .2105E-05 + .2275E-05 + .2466E-05 + .2655E-05 + .2885E-05 + .3147E-05 + .3396E-05 + .3679E-05 + .4039E-05 + .4426E-05 + .4900E-05 + .5465E-05 + .6097E-05 + .6830E-05 + .7532E-05 + .8115E-05 + .8572E-05 + .9045E-05 + .9541E-05 + .9960E-05 + .1046E-04 + .1080E-04 + .1089E-04 + .1031E-04 + .9447E-05 + .8287E-05 + .6853E-05 + .5786E-05 + .4598E-05 + .3582E-05 + .2685E-05 + .1909E-05 + .1281E-05 + .7463E-06 + .3648E-06 + .1850E-06 + .1350E-06 + .9847E-07 + .7183E-07 + .5709E-07 + .4829E-07 + .4288E-07 + .4179E-07 + .4073E-07 + .4033E-07 + .4024E-07 + .4015E-07 + .3989E-07 + .3775E-07 + .3573E-07 + .3218E-07 + .2582E-07 + .1934E-07 + .1724E-07 + .1413E-05 + .1543E-05 + .1670E-05 + .1798E-05 + .1937E-05 + .2089E-05 + .2255E-05 + .2441E-05 + .2630E-05 + .2856E-05 + .3090E-05 + .3339E-05 + .3643E-05 + .4020E-05 + .4417E-05 + .4883E-05 + .5429E-05 + .6023E-05 + .6670E-05 + .7293E-05 + .7869E-05 + .8356E-05 + .8856E-05 + .9375E-05 + .9806E-05 + .1026E-04 + .1051E-04 + .1059E-04 + .1002E-04 + .9254E-05 + .8180E-05 + .6852E-05 + .5741E-05 + .4595E-05 + .3614E-05 + .2723E-05 + .1938E-05 + .1315E-05 + .7993E-06 + .4086E-06 + .2089E-06 + .1495E-06 + .1069E-06 + .7648E-07 + .6046E-07 + .5031E-07 + .4418E-07 + .4296E-07 + .4177E-07 + .4149E-07 + .4162E-07 + .4176E-07 + .4171E-07 + .3958E-07 + .3756E-07 + .3367E-07 + .2696E-07 + .2050E-07 + .1834E-07 + .1405E-05 + .1532E-05 + .1660E-05 + .1792E-05 + .1931E-05 + .2083E-05 + .2246E-05 + .2427E-05 + .2619E-05 + .2846E-05 + .3052E-05 + .3298E-05 + .3624E-05 + .4021E-05 + .4434E-05 + .4893E-05 + .5429E-05 + .5979E-05 + .6532E-05 + .7073E-05 + .7658E-05 + .8188E-05 + .8720E-05 + .9260E-05 + .9697E-05 + .1007E-04 + .1021E-04 + .1030E-04 + .9751E-05 + .9083E-05 + .8094E-05 + .6913E-05 + .5719E-05 + .4630E-05 + .3691E-05 + .2799E-05 + .1990E-05 + .1366E-05 + .8725E-06 + .4709E-06 + .2381E-06 + .1667E-06 + .1168E-06 + .8179E-07 + .6430E-07 + .5265E-07 + .4571E-07 + .4435E-07 + .4303E-07 + .4287E-07 + .4324E-07 + .4362E-07 + .4380E-07 + .4168E-07 + .3967E-07 + .3539E-07 + .2827E-07 + .2182E-07 + .1960E-07 + .1438E-05 + .1563E-05 + .1692E-05 + .1821E-05 + .1960E-05 + .2112E-05 + .2277E-05 + .2465E-05 + .2657E-05 + .2904E-05 + .3153E-05 + .3417E-05 + .3740E-05 + .4128E-05 + .4553E-05 + .5006E-05 + .5535E-05 + .6073E-05 + .6623E-05 + .7145E-05 + .7720E-05 + .8195E-05 + .8695E-05 + .9159E-05 + .9577E-05 + .9872E-05 + .9920E-05 + .9938E-05 + .9456E-05 + .8796E-05 + .7903E-05 + .6854E-05 + .5772E-05 + .4714E-05 + .3745E-05 + .2870E-05 + .2092E-05 + .1471E-05 + .9311E-06 + .5148E-06 + .2698E-06 + .1866E-06 + .1291E-06 + .8932E-07 + .6984E-07 + .5628E-07 + .4830E-07 + .4676E-07 + .4527E-07 + .4523E-07 + .4588E-07 + .4653E-07 + .4697E-07 + .4482E-07 + .4278E-07 + .3798E-07 + .3028E-07 + .2372E-07 + .2139E-07 + .1472E-05 + .1597E-05 + .1727E-05 + .1853E-05 + .1993E-05 + .2146E-05 + .2315E-05 + .2510E-05 + .2706E-05 + .2971E-05 + .3249E-05 + .3528E-05 + .3846E-05 + .4226E-05 + .4655E-05 + .5105E-05 + .5624E-05 + .6154E-05 + .6700E-05 + .7204E-05 + .7764E-05 + .8201E-05 + .8673E-05 + .9067E-05 + .9467E-05 + .9695E-05 + .9683E-05 + .9647E-05 + .9202E-05 + .8556E-05 + .7739E-05 + .6799E-05 + .5819E-05 + .4812E-05 + .3844E-05 + .2985E-05 + .2231E-05 + .1598E-05 + .1004E-05 + .5645E-06 + .3038E-06 + .2080E-06 + .1424E-06 + .9749E-07 + .7582E-07 + .6011E-07 + .5101E-07 + .4927E-07 + .4760E-07 + .4770E-07 + .4865E-07 + .4961E-07 + .5034E-07 + .4818E-07 + .4610E-07 + .4074E-07 + .3241E-07 + .2577E-07 + .2332E-07 + .1494E-05 + .1623E-05 + .1754E-05 + .1880E-05 + .2020E-05 + .2179E-05 + .2353E-05 + .2558E-05 + .2766E-05 + .3039E-05 + .3294E-05 + .3567E-05 + .3874E-05 + .4247E-05 + .4649E-05 + .5108E-05 + .5599E-05 + .6132E-05 + .6668E-05 + .7155E-05 + .7680E-05 + .8129E-05 + .8584E-05 + .8927E-05 + .9307E-05 + .9499E-05 + .9520E-05 + .9473E-05 + .8983E-05 + .8374E-05 + .7587E-05 + .6698E-05 + .5792E-05 + .4912E-05 + .4064E-05 + .3229E-05 + .2478E-05 + .1768E-05 + .1110E-05 + .6202E-06 + .3318E-06 + .2263E-06 + .1544E-06 + .1053E-06 + .8142E-07 + .6352E-07 + .5329E-07 + .5137E-07 + .4951E-07 + .4977E-07 + .5103E-07 + .5233E-07 + .5338E-07 + .5122E-07 + .4916E-07 + .4323E-07 + .3431E-07 + .2770E-07 + .2516E-07 + .1520E-05 + .1653E-05 + .1787E-05 + .1916E-05 + .2056E-05 + .2219E-05 + .2397E-05 + .2606E-05 + .2823E-05 + .3094E-05 + .3344E-05 + .3617E-05 + .3931E-05 + .4307E-05 + .4708E-05 + .5164E-05 + .5642E-05 + .6158E-05 + .6682E-05 + .7157E-05 + .7645E-05 + .8082E-05 + .8490E-05 + .8783E-05 + .9098E-05 + .9267E-05 + .9315E-05 + .9226E-05 + .8706E-05 + .8148E-05 + .7433E-05 + .6616E-05 + .5790E-05 + .5003E-05 + .4239E-05 + .3438E-05 + .2689E-05 + .1944E-05 + .1249E-05 + .7158E-06 + .3902E-06 + .2666E-06 + .1821E-06 + .1244E-06 + .9422E-07 + .7270E-07 + .6003E-07 + .5642E-07 + .5303E-07 + .5253E-07 + .5335E-07 + .5418E-07 + .5479E-07 + .5273E-07 + .5075E-07 + .4499E-07 + .3646E-07 + .3022E-07 + .2776E-07 + .1547E-05 + .1684E-05 + .1825E-05 + .1957E-05 + .2100E-05 + .2263E-05 + .2444E-05 + .2648E-05 + .2868E-05 + .3123E-05 + .3392E-05 + .3673E-05 + .4018E-05 + .4408E-05 + .4843E-05 + .5275E-05 + .5763E-05 + .6233E-05 + .6740E-05 + .7210E-05 + .7655E-05 + .8046E-05 + .8370E-05 + .8612E-05 + .8810E-05 + .8970E-05 + .9037E-05 + .8870E-05 + .8339E-05 + .7851E-05 + .7259E-05 + .6541E-05 + .5804E-05 + .5069E-05 + .4333E-05 + .3578E-05 + .2824E-05 + .2116E-05 + .1436E-05 + .8783E-06 + .5033E-06 + .3468E-06 + .2390E-06 + .1647E-06 + .1197E-06 + .9199E-07 + .7433E-07 + .6614E-07 + .5884E-07 + .5615E-07 + .5540E-07 + .5466E-07 + .5383E-07 + .5195E-07 + .5014E-07 + .4555E-07 + .3882E-07 + .3350E-07 + .3144E-07 + .1568E-05 + .1704E-05 + .1845E-05 + .1981E-05 + .2128E-05 + .2295E-05 + .2483E-05 + .2691E-05 + .2925E-05 + .3171E-05 + .3458E-05 + .3753E-05 + .4115E-05 + .4525E-05 + .4966E-05 + .5408E-05 + .5903E-05 + .6376E-05 + .6867E-05 + .7326E-05 + .7727E-05 + .8047E-05 + .8306E-05 + .8500E-05 + .8637E-05 + .8735E-05 + .8754E-05 + .8563E-05 + .8061E-05 + .7588E-05 + .7080E-05 + .6468E-05 + .5820E-05 + .5145E-05 + .4466E-05 + .3760E-05 + .3035E-05 + .2316E-05 + .1616E-05 + .1033E-05 + .6247E-06 + .4396E-06 + .3093E-06 + .2176E-06 + .1519E-06 + .1162E-06 + .9190E-07 + .7740E-07 + .6519E-07 + .5993E-07 + .5744E-07 + .5505E-07 + .5280E-07 + .5111E-07 + .4947E-07 + .4605E-07 + .4128E-07 + .3709E-07 + .3556E-07 + .1584E-05 + .1715E-05 + .1851E-05 + .1992E-05 + .2143E-05 + .2317E-05 + .2514E-05 + .2730E-05 + .2983E-05 + .3223E-05 + .3526E-05 + .3839E-05 + .4210E-05 + .4643E-05 + .5072E-05 + .5544E-05 + .6045E-05 + .6548E-05 + .7021E-05 + .7463E-05 + .7819E-05 + .8054E-05 + .8254E-05 + .8404E-05 + .8507E-05 + .8516E-05 + .8454E-05 + .8268E-05 + .7816E-05 + .7331E-05 + .6887E-05 + .6382E-05 + .5825E-05 + .5217E-05 + .4614E-05 + .3966E-05 + .3297E-05 + .2537E-05 + .1794E-05 + .1183E-05 + .7577E-06 + .5498E-06 + .3989E-06 + .2895E-06 + .2053E-06 + .1578E-06 + .1218E-06 + .9481E-07 + .7377E-07 + .6498E-07 + .6071E-07 + .5672E-07 + .5314E-07 + .5140E-07 + .4971E-07 + .4667E-07 + .4265E-07 + .3896E-07 + .3764E-07 + .1598E-05 + .1729E-05 + .1863E-05 + .2003E-05 + .2154E-05 + .2325E-05 + .2518E-05 + .2733E-05 + .2975E-05 + .3223E-05 + .3531E-05 + .3839E-05 + .4213E-05 + .4634E-05 + .5077E-05 + .5565E-05 + .6077E-05 + .6581E-05 + .7048E-05 + .7473E-05 + .7800E-05 + .8012E-05 + .8196E-05 + .8337E-05 + .8365E-05 + .8294E-05 + .8156E-05 + .7928E-05 + .7556E-05 + .7111E-05 + .6715E-05 + .6271E-05 + .5784E-05 + .5243E-05 + .4691E-05 + .4097E-05 + .3462E-05 + .2739E-05 + .2020E-05 + .1404E-05 + .9595E-06 + .7069E-06 + .5208E-06 + .3837E-06 + .2819E-06 + .2184E-06 + .1645E-06 + .1173E-06 + .8363E-07 + .7045E-07 + .6424E-07 + .5858E-07 + .5366E-07 + .5179E-07 + .4998E-07 + .4710E-07 + .4341E-07 + .4000E-07 + .3877E-07 + .1593E-05 + .1725E-05 + .1857E-05 + .1994E-05 + .2141E-05 + .2307E-05 + .2493E-05 + .2704E-05 + .2928E-05 + .3183E-05 + .3491E-05 + .3789E-05 + .4163E-05 + .4565E-05 + .5020E-05 + .5518E-05 + .6036E-05 + .6533E-05 + .6989E-05 + .7394E-05 + .7692E-05 + .7889E-05 + .8060E-05 + .8193E-05 + .8144E-05 + .8004E-05 + .7802E-05 + .7532E-05 + .7238E-05 + .6841E-05 + .6491E-05 + .6102E-05 + .5680E-05 + .5210E-05 + .4710E-05 + .4176E-05 + .3579E-05 + .2921E-05 + .2255E-05 + .1654E-05 + .1204E-05 + .9003E-06 + .6731E-06 + .5033E-06 + .3829E-06 + .2991E-06 + .2197E-06 + .1436E-06 + .9379E-07 + .7557E-07 + .6726E-07 + .5986E-07 + .5361E-07 + .5164E-07 + .4973E-07 + .4703E-07 + .4371E-07 + .4064E-07 + .3952E-07 + .1529E-05 + .1668E-05 + .1806E-05 + .1944E-05 + .2085E-05 + .2245E-05 + .2425E-05 + .2644E-05 + .2856E-05 + .3134E-05 + .3430E-05 + .3742E-05 + .4129E-05 + .4544E-05 + .4996E-05 + .5508E-05 + .6010E-05 + .6501E-05 + .6936E-05 + .7321E-05 + .7590E-05 + .7747E-05 + .7851E-05 + .7922E-05 + .7854E-05 + .7703E-05 + .7539E-05 + .7274E-05 + .6970E-05 + .6600E-05 + .6276E-05 + .5925E-05 + .5532E-05 + .5107E-05 + .4671E-05 + .4208E-05 + .3666E-05 + .3066E-05 + .2433E-05 + .1823E-05 + .1348E-05 + .1060E-05 + .8333E-06 + .6551E-06 + .5161E-06 + .4064E-06 + .2912E-06 + .1744E-06 + .1044E-06 + .8044E-07 + .6988E-07 + .6070E-07 + .5315E-07 + .5109E-07 + .4911E-07 + .4660E-07 + .4369E-07 + .4096E-07 + .3997E-07 + .1494E-05 + .1638E-05 + .1780E-05 + .1919E-05 + .2058E-05 + .2214E-05 + .2391E-05 + .2612E-05 + .2824E-05 + .3113E-05 + .3412E-05 + .3735E-05 + .4138E-05 + .4569E-05 + .5035E-05 + .5566E-05 + .6068E-05 + .6556E-05 + .6975E-05 + .7334E-05 + .7570E-05 + .7691E-05 + .7743E-05 + .7762E-05 + .7680E-05 + .7521E-05 + .7381E-05 + .7123E-05 + .6819E-05 + .6480E-05 + .6182E-05 + .5859E-05 + .5482E-05 + .5095E-05 + .4708E-05 + .4299E-05 + .3804E-05 + .3249E-05 + .2637E-05 + .2023E-05 + .1527E-05 + .1199E-05 + .9414E-06 + .7392E-06 + .5907E-06 + .4700E-06 + .3353E-06 + .1944E-06 + .1127E-06 + .8470E-07 + .7196E-07 + .6114E-07 + .5245E-07 + .5021E-07 + .4806E-07 + .4549E-07 + .4261E-07 + .3990E-07 + .3892E-07 + .1483E-05 + .1622E-05 + .1760E-05 + .1897E-05 + .2036E-05 + .2188E-05 + .2367E-05 + .2565E-05 + .2805E-05 + .3064E-05 + .3393E-05 + .3710E-05 + .4126E-05 + .4567E-05 + .5076E-05 + .5624E-05 + .6156E-05 + .6629E-05 + .7030E-05 + .7337E-05 + .7520E-05 + .7609E-05 + .7637E-05 + .7626E-05 + .7542E-05 + .7386E-05 + .7243E-05 + .7008E-05 + .6737E-05 + .6451E-05 + .6190E-05 + .5884E-05 + .5507E-05 + .5155E-05 + .4791E-05 + .4408E-05 + .3952E-05 + .3413E-05 + .2798E-05 + .2208E-05 + .1724E-05 + .1330E-05 + .1026E-05 + .7910E-06 + .6360E-06 + .5116E-06 + .3664E-06 + .2103E-06 + .1207E-06 + .8906E-07 + .7407E-07 + .6161E-07 + .5180E-07 + .4935E-07 + .4702E-07 + .4429E-07 + .4127E-07 + .3846E-07 + .3744E-07 + .1462E-05 + .1603E-05 + .1742E-05 + .1880E-05 + .2020E-05 + .2170E-05 + .2349E-05 + .2537E-05 + .2783E-05 + .3035E-05 + .3361E-05 + .3694E-05 + .4105E-05 + .4554E-05 + .5083E-05 + .5627E-05 + .6164E-05 + .6619E-05 + .6995E-05 + .7257E-05 + .7404E-05 + .7469E-05 + .7484E-05 + .7455E-05 + .7370E-05 + .7230E-05 + .7087E-05 + .6879E-05 + .6644E-05 + .6382E-05 + .6152E-05 + .5870E-05 + .5519E-05 + .5179E-05 + .4822E-05 + .4454E-05 + .4032E-05 + .3524E-05 + .2936E-05 + .2377E-05 + .1900E-05 + .1449E-05 + .1105E-05 + .8422E-06 + .6812E-06 + .5541E-06 + .3983E-06 + .2262E-06 + .1285E-06 + .9317E-07 + .7586E-07 + .6176E-07 + .5090E-07 + .4826E-07 + .4576E-07 + .4289E-07 + .3977E-07 + .3688E-07 + .3583E-07 + .1435E-05 + .1586E-05 + .1732E-05 + .1873E-05 + .2016E-05 + .2167E-05 + .2347E-05 + .2538E-05 + .2769E-05 + .3037E-05 + .3327E-05 + .3702E-05 + .4091E-05 + .4547E-05 + .5070E-05 + .5590E-05 + .6104E-05 + .6540E-05 + .6887E-05 + .7114E-05 + .7246E-05 + .7294E-05 + .7308E-05 + .7273E-05 + .7188E-05 + .7076E-05 + .6937E-05 + .6759E-05 + .6566E-05 + .6293E-05 + .6085E-05 + .5834E-05 + .5536E-05 + .5181E-05 + .4810E-05 + .4444E-05 + .4047E-05 + .3584E-05 + .3056E-05 + .2530E-05 + .2046E-05 + .1553E-05 + .1179E-05 + .8948E-06 + .7282E-06 + .5989E-06 + .4322E-06 + .2429E-06 + .1366E-06 + .9727E-07 + .7753E-07 + .6179E-07 + .4992E-07 + .4710E-07 + .4445E-07 + .4146E-07 + .3825E-07 + .3529E-07 + .3422E-07 + .1401E-05 + .1554E-05 + .1702E-05 + .1845E-05 + .1988E-05 + .2138E-05 + .2315E-05 + .2511E-05 + .2733E-05 + .3006E-05 + .3292E-05 + .3664E-05 + .4044E-05 + .4497E-05 + .4999E-05 + .5504E-05 + .6008E-05 + .6427E-05 + .6748E-05 + .6956E-05 + .7067E-05 + .7090E-05 + .7084E-05 + .7034E-05 + .6953E-05 + .6852E-05 + .6732E-05 + .6573E-05 + .6418E-05 + .6151E-05 + .5930E-05 + .5693E-05 + .5432E-05 + .5107E-05 + .4761E-05 + .4420E-05 + .4041E-05 + .3604E-05 + .3111E-05 + .2597E-05 + .2126E-05 + .1643E-05 + .1271E-05 + .9825E-06 + .7938E-06 + .6484E-06 + .4699E-06 + .2713E-06 + .1566E-06 + .1090E-06 + .8295E-07 + .6312E-07 + .4887E-07 + .4623E-07 + .4373E-07 + .4076E-07 + .3747E-07 + .3445E-07 + .3336E-07 + .1360E-05 + .1511E-05 + .1659E-05 + .1803E-05 + .1944E-05 + .2093E-05 + .2262E-05 + .2464E-05 + .2680E-05 + .2951E-05 + .3247E-05 + .3594E-05 + .3971E-05 + .4415E-05 + .4888E-05 + .5381E-05 + .5879E-05 + .6283E-05 + .6577E-05 + .6772E-05 + .6860E-05 + .6857E-05 + .6824E-05 + .6756E-05 + .6680E-05 + .6585E-05 + .6487E-05 + .6343E-05 + .6224E-05 + .5970E-05 + .5725E-05 + .5491E-05 + .5259E-05 + .4984E-05 + .4680E-05 + .4378E-05 + .4014E-05 + .3595E-05 + .3126E-05 + .2615E-05 + .2166E-05 + .1724E-05 + .1372E-05 + .1092E-05 + .8707E-06 + .7003E-06 + .5101E-06 + .3075E-06 + .1854E-06 + .1258E-06 + .9037E-07 + .6490E-07 + .4767E-07 + .4535E-07 + .4314E-07 + .4026E-07 + .3690E-07 + .3383E-07 + .3272E-07 + .1339E-05 + .1478E-05 + .1614E-05 + .1752E-05 + .1891E-05 + .2041E-05 + .2212E-05 + .2413E-05 + .2636E-05 + .2892E-05 + .3204E-05 + .3552E-05 + .3930E-05 + .4357E-05 + .4831E-05 + .5316E-05 + .5770E-05 + .6140E-05 + .6409E-05 + .6581E-05 + .6645E-05 + .6640E-05 + .6595E-05 + .6511E-05 + .6417E-05 + .6312E-05 + .6224E-05 + .6088E-05 + .5974E-05 + .5762E-05 + .5547E-05 + .5315E-05 + .5085E-05 + .4834E-05 + .4558E-05 + .4273E-05 + .3943E-05 + .3562E-05 + .3134E-05 + .2657E-05 + .2214E-05 + .1807E-05 + .1475E-05 + .1204E-05 + .9476E-06 + .7505E-06 + .5493E-06 + .3458E-06 + .2177E-06 + .1441E-06 + .9768E-07 + .6621E-07 + .4613E-07 + .4414E-07 + .4224E-07 + .3946E-07 + .3606E-07 + .3296E-07 + .3184E-07 + .1352E-05 + .1484E-05 + .1612E-05 + .1746E-05 + .1887E-05 + .2043E-05 + .2222E-05 + .2426E-05 + .2660E-05 + .2909E-05 + .3244E-05 + .3604E-05 + .3991E-05 + .4414E-05 + .4898E-05 + .5387E-05 + .5806E-05 + .6152E-05 + .6404E-05 + .6556E-05 + .6601E-05 + .6595E-05 + .6538E-05 + .6439E-05 + .6328E-05 + .6212E-05 + .6128E-05 + .5995E-05 + .5884E-05 + .5709E-05 + .5524E-05 + .5292E-05 + .5055E-05 + .4815E-05 + .4557E-05 + .4279E-05 + .3972E-05 + .3619E-05 + .3219E-05 + .2769E-05 + .2320E-05 + .1878E-05 + .1520E-05 + .1230E-05 + .9651E-06 + .7601E-06 + .5559E-06 + .3529E-06 + .2240E-06 + .1480E-06 + .9958E-07 + .6702E-07 + .4637E-07 + .4401E-07 + .4177E-07 + .3860E-07 + .3482E-07 + .3140E-07 + .3018E-07 + .1345E-05 + .1476E-05 + .1607E-05 + .1745E-05 + .1891E-05 + .2051E-05 + .2232E-05 + .2444E-05 + .2675E-05 + .2940E-05 + .3260E-05 + .3620E-05 + .4012E-05 + .4431E-05 + .4890E-05 + .5350E-05 + .5762E-05 + .6090E-05 + .6322E-05 + .6451E-05 + .6496E-05 + .6481E-05 + .6409E-05 + .6324E-05 + .6226E-05 + .6120E-05 + .6033E-05 + .5903E-05 + .5828E-05 + .5686E-05 + .5531E-05 + .5336E-05 + .5101E-05 + .4841E-05 + .4590E-05 + .4324E-05 + .4015E-05 + .3661E-05 + .3267E-05 + .2836E-05 + .2401E-05 + .1936E-05 + .1561E-05 + .1259E-05 + .9852E-06 + .7716E-06 + .5638E-06 + .3608E-06 + .2309E-06 + .1522E-06 + .1017E-06 + .6800E-07 + .4671E-07 + .4397E-07 + .4140E-07 + .3785E-07 + .3369E-07 + .2998E-07 + .2868E-07 + .1334E-05 + .1466E-05 + .1601E-05 + .1744E-05 + .1898E-05 + .2064E-05 + .2248E-05 + .2458E-05 + .2684E-05 + .2948E-05 + .3256E-05 + .3629E-05 + .4026E-05 + .4439E-05 + .4877E-05 + .5276E-05 + .5660E-05 + .5993E-05 + .6205E-05 + .6284E-05 + .6319E-05 + .6300E-05 + .6243E-05 + .6188E-05 + .6083E-05 + .5972E-05 + .5868E-05 + .5740E-05 + .5664E-05 + .5544E-05 + .5415E-05 + .5265E-05 + .5074E-05 + .4857E-05 + .4598E-05 + .4323E-05 + .4020E-05 + .3667E-05 + .3275E-05 + .2881E-05 + .2494E-05 + .2005E-05 + .1611E-05 + .1295E-05 + .1010E-05 + .7868E-06 + .5744E-06 + .3707E-06 + .2392E-06 + .1573E-06 + .1044E-06 + .6930E-07 + .4727E-07 + .4414E-07 + .4122E-07 + .3728E-07 + .3274E-07 + .2876E-07 + .2737E-07 + .1345E-05 + .1484E-05 + .1627E-05 + .1778E-05 + .1942E-05 + .2114E-05 + .2302E-05 + .2510E-05 + .2740E-05 + .2989E-05 + .3303E-05 + .3696E-05 + .4093E-05 + .4494E-05 + .4920E-05 + .5228E-05 + .5555E-05 + .5903E-05 + .6105E-05 + .6130E-05 + .6139E-05 + .6121E-05 + .6103E-05 + .6086E-05 + .5960E-05 + .5833E-05 + .5705E-05 + .5580E-05 + .5458E-05 + .5338E-05 + .5221E-05 + .5096E-05 + .4963E-05 + .4835E-05 + .4554E-05 + .4250E-05 + .3957E-05 + .3610E-05 + .3223E-05 + .2875E-05 + .2540E-05 + .2059E-05 + .1669E-05 + .1353E-05 + .1053E-05 + .8153E-06 + .5947E-06 + .3869E-06 + .2517E-06 + .1652E-06 + .1089E-06 + .7177E-07 + .4861E-07 + .4502E-07 + .4170E-07 + .3731E-07 + .3234E-07 + .2803E-07 + .2654E-07 + .1390E-05 + .1543E-05 + .1690E-05 + .1847E-05 + .2015E-05 + .2192E-05 + .2385E-05 + .2610E-05 + .2864E-05 + .3138E-05 + .3462E-05 + .3852E-05 + .4229E-05 + .4615E-05 + .5026E-05 + .5299E-05 + .5587E-05 + .5890E-05 + .6096E-05 + .6140E-05 + .6132E-05 + .6104E-05 + .6078E-05 + .6051E-05 + .5951E-05 + .5839E-05 + .5716E-05 + .5596E-05 + .5478E-05 + .5363E-05 + .5251E-05 + .5104E-05 + .4927E-05 + .4756E-05 + .4487E-05 + .4195E-05 + .3888E-05 + .3555E-05 + .3187E-05 + .2847E-05 + .2463E-05 + .2048E-05 + .1703E-05 + .1417E-05 + .1099E-05 + .8462E-06 + .6167E-06 + .4045E-06 + .2653E-06 + .1738E-06 + .1138E-06 + .7445E-07 + .5007E-07 + .4600E-07 + .4226E-07 + .3741E-07 + .3199E-07 + .2736E-07 + .2578E-07 + .1440E-05 + .1609E-05 + .1760E-05 + .1923E-05 + .2097E-05 + .2279E-05 + .2477E-05 + .2721E-05 + .3002E-05 + .3302E-05 + .3640E-05 + .4025E-05 + .4380E-05 + .4751E-05 + .5149E-05 + .5386E-05 + .5634E-05 + .5893E-05 + .6103E-05 + .6167E-05 + .6140E-05 + .6104E-05 + .6068E-05 + .6032E-05 + .5957E-05 + .5860E-05 + .5742E-05 + .5627E-05 + .5514E-05 + .5403E-05 + .5295E-05 + .5126E-05 + .4904E-05 + .4692E-05 + .4433E-05 + .4151E-05 + .3831E-05 + .3510E-05 + .3160E-05 + .2827E-05 + .2395E-05 + .2034E-05 + .1727E-05 + .1466E-05 + .1136E-05 + .8730E-06 + .6360E-06 + .4185E-06 + .2753E-06 + .1802E-06 + .1176E-06 + .7680E-07 + .5151E-07 + .4718E-07 + .4321E-07 + .3809E-07 + .3242E-07 + .2759E-07 + .2594E-07 + .1497E-05 + .1682E-05 + .1838E-05 + .2008E-05 + .2188E-05 + .2376E-05 + .2580E-05 + .2843E-05 + .3154E-05 + .3485E-05 + .3836E-05 + .4218E-05 + .4550E-05 + .4905E-05 + .5288E-05 + .5489E-05 + .5696E-05 + .5912E-05 + .6127E-05 + .6210E-05 + .6166E-05 + .6120E-05 + .6075E-05 + .6030E-05 + .5980E-05 + .5897E-05 + .5784E-05 + .5674E-05 + .5565E-05 + .5458E-05 + .5354E-05 + .5163E-05 + .4895E-05 + .4641E-05 + .4392E-05 + .4119E-05 + .3785E-05 + .3474E-05 + .3142E-05 + .2815E-05 + .2335E-05 + .2019E-05 + .1745E-05 + .1509E-05 + .1169E-05 + .8983E-06 + .6544E-06 + .4306E-06 + .2833E-06 + .1854E-06 + .1210E-06 + .7902E-07 + .5300E-07 + .4854E-07 + .4446E-07 + .3919E-07 + .3335E-07 + .2838E-07 + .2669E-07 + .1493E-05 + .1679E-05 + .1846E-05 + .2029E-05 + .2225E-05 + .2414E-05 + .2620E-05 + .2877E-05 + .3183E-05 + .3509E-05 + .3851E-05 + .4213E-05 + .4540E-05 + .4882E-05 + .5238E-05 + .5457E-05 + .5684E-05 + .5888E-05 + .6065E-05 + .6144E-05 + .6121E-05 + .6098E-05 + .6064E-05 + .6018E-05 + .5973E-05 + .5902E-05 + .5806E-05 + .5712E-05 + .5619E-05 + .5483E-05 + .5351E-05 + .5151E-05 + .4891E-05 + .4644E-05 + .4393E-05 + .4111E-05 + .3784E-05 + .3482E-05 + .3166E-05 + .2857E-05 + .2370E-05 + .2055E-05 + .1782E-05 + .1545E-05 + .1197E-05 + .9201E-06 + .6704E-06 + .4411E-06 + .2902E-06 + .1899E-06 + .1240E-06 + .8094E-07 + .5429E-07 + .4972E-07 + .4554E-07 + .4015E-07 + .3417E-07 + .2908E-07 + .2734E-07 + .1474E-05 + .1656E-05 + .1834E-05 + .2032E-05 + .2247E-05 + .2436E-05 + .2640E-05 + .2886E-05 + .3178E-05 + .3493E-05 + .3819E-05 + .4158E-05 + .4484E-05 + .4812E-05 + .5139E-05 + .5386E-05 + .5645E-05 + .5843E-05 + .5975E-05 + .6044E-05 + .6050E-05 + .6056E-05 + .6036E-05 + .5992E-05 + .5948E-05 + .5888E-05 + .5811E-05 + .5736E-05 + .5662E-05 + .5491E-05 + .5324E-05 + .5118E-05 + .4877E-05 + .4648E-05 + .4392E-05 + .4099E-05 + .3785E-05 + .3491E-05 + .3193E-05 + .2905E-05 + .2421E-05 + .2099E-05 + .1820E-05 + .1578E-05 + .1223E-05 + .9397E-06 + .6846E-06 + .4504E-06 + .2964E-06 + .1940E-06 + .1266E-06 + .8266E-07 + .5544E-07 + .5078E-07 + .4651E-07 + .4100E-07 + .3489E-07 + .2969E-07 + .2792E-07 + .1427E-05 + .1602E-05 + .1787E-05 + .1994E-05 + .2223E-05 + .2409E-05 + .2609E-05 + .2838E-05 + .3112E-05 + .3408E-05 + .3712E-05 + .4023E-05 + .4342E-05 + .4650E-05 + .4944E-05 + .5212E-05 + .5496E-05 + .5685E-05 + .5770E-05 + .5830E-05 + .5863E-05 + .5896E-05 + .5891E-05 + .5848E-05 + .5806E-05 + .5758E-05 + .5702E-05 + .5647E-05 + .5593E-05 + .5390E-05 + .5194E-05 + .4986E-05 + .4768E-05 + .4560E-05 + .4306E-05 + .4007E-05 + .3711E-05 + .3432E-05 + .3156E-05 + .2896E-05 + .2423E-05 + .2101E-05 + .1822E-05 + .1580E-05 + .1224E-05 + .9406E-06 + .6853E-06 + .4509E-06 + .2967E-06 + .1942E-06 + .1267E-06 + .8274E-07 + .5550E-07 + .5083E-07 + .4655E-07 + .4104E-07 + .3493E-07 + .2972E-07 + .2795E-07 + .1231E-05 + .1354E-05 + .1488E-05 + .1613E-05 + .1749E-05 + .1899E-05 + .2079E-05 + .2276E-05 + .2472E-05 + .2676E-05 + .2898E-05 + .3126E-05 + .3357E-05 + .3593E-05 + .3845E-05 + .4014E-05 + .4159E-05 + .4125E-05 + .4064E-05 + .4004E-05 + .3945E-05 + .3848E-05 + .3730E-05 + .3615E-05 + .3503E-05 + .3396E-05 + .3291E-05 + .3194E-05 + .3099E-05 + .3005E-05 + .2910E-05 + .2819E-05 + .2730E-05 + .2641E-05 + .2552E-05 + .2466E-05 + .2372E-05 + .2191E-05 + .2004E-05 + .1718E-05 + .1370E-05 + .1112E-05 + .9028E-06 + .7329E-06 + .5099E-06 + .3770E-06 + .2670E-06 + .1742E-06 + .1137E-06 + .7917E-07 + .5690E-07 + .4089E-07 + .3000E-07 + .2788E-07 + .2592E-07 + .2318E-07 + .1999E-07 + .1725E-07 + .1631E-07 + .1214E-05 + .1340E-05 + .1476E-05 + .1598E-05 + .1730E-05 + .1877E-05 + .2069E-05 + .2280E-05 + .2482E-05 + .2695E-05 + .2929E-05 + .3178E-05 + .3438E-05 + .3691E-05 + .3958E-05 + .4178E-05 + .4335E-05 + .4338E-05 + .4277E-05 + .4216E-05 + .4156E-05 + .4040E-05 + .3903E-05 + .3771E-05 + .3643E-05 + .3520E-05 + .3401E-05 + .3295E-05 + .3192E-05 + .3090E-05 + .2990E-05 + .2893E-05 + .2799E-05 + .2701E-05 + .2599E-05 + .2501E-05 + .2400E-05 + .2243E-05 + .2050E-05 + .1769E-05 + .1418E-05 + .1134E-05 + .9072E-06 + .7256E-06 + .5048E-06 + .3732E-06 + .2643E-06 + .1725E-06 + .1125E-06 + .7838E-07 + .5633E-07 + .4048E-07 + .2970E-07 + .2760E-07 + .2566E-07 + .2294E-07 + .1980E-07 + .1708E-07 + .1614E-07 + .1196E-05 + .1325E-05 + .1463E-05 + .1582E-05 + .1710E-05 + .1854E-05 + .2057E-05 + .2283E-05 + .2490E-05 + .2713E-05 + .2960E-05 + .3230E-05 + .3520E-05 + .3789E-05 + .4073E-05 + .4347E-05 + .4516E-05 + .4562E-05 + .4500E-05 + .4439E-05 + .4378E-05 + .4241E-05 + .4084E-05 + .3933E-05 + .3787E-05 + .3647E-05 + .3513E-05 + .3398E-05 + .3286E-05 + .3177E-05 + .3071E-05 + .2968E-05 + .2869E-05 + .2761E-05 + .2646E-05 + .2535E-05 + .2426E-05 + .2295E-05 + .2097E-05 + .1821E-05 + .1468E-05 + .1156E-05 + .9111E-06 + .7179E-06 + .4994E-06 + .3693E-06 + .2615E-06 + .1706E-06 + .1113E-06 + .7755E-07 + .5573E-07 + .4005E-07 + .2938E-07 + .2731E-07 + .2539E-07 + .2270E-07 + .1959E-07 + .1690E-07 + .1597E-07 + .1180E-05 + .1310E-05 + .1450E-05 + .1557E-05 + .1693E-05 + .1841E-05 + .2045E-05 + .2276E-05 + .2478E-05 + .2732E-05 + .2970E-05 + .3271E-05 + .3581E-05 + .3883E-05 + .4189E-05 + .4522E-05 + .4709E-05 + .4798E-05 + .4756E-05 + .4623E-05 + .4569E-05 + .4422E-05 + .4262E-05 + .4093E-05 + .3934E-05 + .3752E-05 + .3602E-05 + .3507E-05 + .3386E-05 + .3266E-05 + .3153E-05 + .3041E-05 + .2921E-05 + .2799E-05 + .2663E-05 + .2556E-05 + .2460E-05 + .2347E-05 + .2155E-05 + .1882E-05 + .1532E-05 + .1185E-05 + .9165E-06 + .7088E-06 + .4931E-06 + .3646E-06 + .2582E-06 + .1685E-06 + .1099E-06 + .7658E-07 + .5503E-07 + .3955E-07 + .2901E-07 + .2697E-07 + .2507E-07 + .2241E-07 + .1934E-07 + .1669E-07 + .1577E-07 + .1180E-05 + .1310E-05 + .1447E-05 + .1516E-05 + .1701E-05 + .1882E-05 + .2059E-05 + .2266E-05 + .2447E-05 + .2787E-05 + .2971E-05 + .3326E-05 + .3623E-05 + .4019E-05 + .4378E-05 + .4767E-05 + .4996E-05 + .5122E-05 + .5167E-05 + .4666E-05 + .4641E-05 + .4542E-05 + .4443E-05 + .4268E-05 + .4116E-05 + .3832E-05 + .3667E-05 + .3669E-05 + .3532E-05 + .3386E-05 + .3262E-05 + .3132E-05 + .2946E-05 + .2816E-05 + .2648E-05 + .2584E-05 + .2545E-05 + .2408E-05 + .2256E-05 + .1963E-05 + .1631E-05 + .1232E-05 + .9307E-06 + .7030E-06 + .4891E-06 + .3616E-06 + .2561E-06 + .1671E-06 + .1090E-06 + .7594E-07 + .5458E-07 + .3922E-07 + .2877E-07 + .2675E-07 + .2486E-07 + .2223E-07 + .1918E-07 + .1655E-07 + .1564E-07 + .1221E-05 + .1356E-05 + .1492E-05 + .1552E-05 + .1752E-05 + .1948E-05 + .2157E-05 + .2382E-05 + .2640E-05 + .2942E-05 + .3233E-05 + .3581E-05 + .3929E-05 + .4375E-05 + .4811E-05 + .5223E-05 + .5508E-05 + .5669E-05 + .5692E-05 + .4989E-05 + .4975E-05 + .4891E-05 + .4773E-05 + .4606E-05 + .4441E-05 + .4217E-05 + .4043E-05 + .3934E-05 + .3774E-05 + .3594E-05 + .3454E-05 + .3326E-05 + .3146E-05 + .3097E-05 + .2947E-05 + .2831E-05 + .2691E-05 + .2508E-05 + .2314E-05 + .1988E-05 + .1634E-05 + .1231E-05 + .9270E-06 + .6981E-06 + .4858E-06 + .3584E-06 + .2539E-06 + .1666E-06 + .1092E-06 + .7664E-07 + .5551E-07 + .4021E-07 + .2971E-07 + .2765E-07 + .2573E-07 + .2304E-07 + .1991E-07 + .1721E-07 + .1627E-07 + .1271E-05 + .1409E-05 + .1545E-05 + .1598E-05 + .1810E-05 + .2023E-05 + .2261E-05 + .2505E-05 + .2827E-05 + .3112E-05 + .3476E-05 + .3816E-05 + .4236E-05 + .4722E-05 + .5240E-05 + .5708E-05 + .6037E-05 + .6224E-05 + .6258E-05 + .5599E-05 + .5545E-05 + .5405E-05 + .5229E-05 + .5018E-05 + .4792E-05 + .4665E-05 + .4483E-05 + .4297E-05 + .4118E-05 + .3907E-05 + .3753E-05 + .3605E-05 + .3405E-05 + .3375E-05 + .3213E-05 + .3049E-05 + .2832E-05 + .2614E-05 + .2377E-05 + .2018E-05 + .1639E-05 + .1207E-05 + .8893E-06 + .6551E-06 + .4562E-06 + .3346E-06 + .2373E-06 + .1579E-06 + .1050E-06 + .7504E-07 + .5550E-07 + .4105E-07 + .3093E-07 + .2886E-07 + .2693E-07 + .2421E-07 + .2101E-07 + .1824E-07 + .1728E-07 + .1321E-05 + .1457E-05 + .1593E-05 + .1642E-05 + .1862E-05 + .2092E-05 + .2349E-05 + .2612E-05 + .2977E-05 + .3269E-05 + .3658E-05 + .3987E-05 + .4502E-05 + .5005E-05 + .5607E-05 + .6166E-05 + .6521E-05 + .6714E-05 + .6808E-05 + .6561E-05 + .6390E-05 + .6089E-05 + .5799E-05 + .5473E-05 + .5127E-05 + .5144E-05 + .4959E-05 + .4746E-05 + .4555E-05 + .4320E-05 + .4157E-05 + .3960E-05 + .3704E-05 + .3610E-05 + .3395E-05 + .3196E-05 + .2938E-05 + .2702E-05 + .2426E-05 + .2036E-05 + .1631E-05 + .1177E-05 + .8492E-06 + .6128E-06 + .4270E-06 + .3114E-06 + .2211E-06 + .1491E-06 + .1006E-06 + .7324E-07 + .5531E-07 + .4177E-07 + .3209E-07 + .3003E-07 + .2810E-07 + .2535E-07 + .2210E-07 + .1927E-07 + .1829E-07 + .1390E-05 + .1536E-05 + .1678E-05 + .1758E-05 + .1982E-05 + .2213E-05 + .2470E-05 + .2722E-05 + .3099E-05 + .3356E-05 + .3774E-05 + .4139E-05 + .4674E-05 + .5220E-05 + .5857E-05 + .6500E-05 + .6862E-05 + .7107E-05 + .7245E-05 + .7169E-05 + .6942E-05 + .6583E-05 + .6255E-05 + .5888E-05 + .5518E-05 + .5559E-05 + .5374E-05 + .5139E-05 + .4946E-05 + .4703E-05 + .4527E-05 + .4306E-05 + .4026E-05 + .3878E-05 + .3631E-05 + .3364E-05 + .3047E-05 + .2767E-05 + .2448E-05 + .2034E-05 + .1612E-05 + .1140E-05 + .8061E-06 + .5701E-06 + .3976E-06 + .2883E-06 + .2049E-06 + .1401E-06 + .9584E-07 + .7110E-07 + .5483E-07 + .4228E-07 + .3312E-07 + .3108E-07 + .2917E-07 + .2641E-07 + .2313E-07 + .2026E-07 + .1926E-07 + .1458E-05 + .1619E-05 + .1770E-05 + .1902E-05 + .2125E-05 + .2343E-05 + .2587E-05 + .2812E-05 + .3181E-05 + .3380E-05 + .3826E-05 + .4247E-05 + .4761E-05 + .5358E-05 + .5999E-05 + .6716E-05 + .7074E-05 + .7394E-05 + .7568E-05 + .7522E-05 + .7278E-05 + .6925E-05 + .6605E-05 + .6238E-05 + .5902E-05 + .5902E-05 + .5721E-05 + .5467E-05 + .5279E-05 + .5041E-05 + .4850E-05 + .4619E-05 + .4336E-05 + .4137E-05 + .3872E-05 + .3518E-05 + .3133E-05 + .2798E-05 + .2437E-05 + .2004E-05 + .1574E-05 + .1091E-05 + .7565E-06 + .5245E-06 + .3660E-06 + .2639E-06 + .1877E-06 + .1302E-06 + .9031E-07 + .6826E-07 + .5375E-07 + .4232E-07 + .3380E-07 + .3181E-07 + .2993E-07 + .2720E-07 + .2393E-07 + .2106E-07 + .2005E-07 + .1452E-05 + .1625E-05 + .1792E-05 + .1952E-05 + .2173E-05 + .2391E-05 + .2629E-05 + .2838E-05 + .3198E-05 + .3474E-05 + .3914E-05 + .4361E-05 + .4826E-05 + .5438E-05 + .6114E-05 + .6816E-05 + .7312E-05 + .7733E-05 + .7875E-05 + .7876E-05 + .7584E-05 + .7268E-05 + .6865E-05 + .6575E-05 + .6178E-05 + .6163E-05 + .6004E-05 + .5773E-05 + .5582E-05 + .5370E-05 + .5191E-05 + .4939E-05 + .4620E-05 + .4360E-05 + .4032E-05 + .3607E-05 + .3170E-05 + .2781E-05 + .2398E-05 + .1955E-05 + .1522E-05 + .1033E-05 + .7012E-06 + .4759E-06 + .3324E-06 + .2382E-06 + .1696E-06 + .1193E-06 + .8393E-07 + .6464E-07 + .5196E-07 + .4178E-07 + .3402E-07 + .3211E-07 + .3030E-07 + .2764E-07 + .2443E-07 + .2159E-07 + .2059E-07 + .1434E-05 + .1616E-05 + .1796E-05 + .1976E-05 + .2194E-05 + .2411E-05 + .2643E-05 + .2840E-05 + .3187E-05 + .3546E-05 + .3975E-05 + .4442E-05 + .4862E-05 + .5478E-05 + .6176E-05 + .6844E-05 + .7468E-05 + .7974E-05 + .8081E-05 + .8128E-05 + .7804E-05 + .7537E-05 + .7059E-05 + .6853E-05 + .6404E-05 + .6370E-05 + .6237E-05 + .6035E-05 + .5848E-05 + .5664E-05 + .5499E-05 + .5225E-05 + .4864E-05 + .4543E-05 + .4147E-05 + .3657E-05 + .3175E-05 + .2736E-05 + .2336E-05 + .1887E-05 + .1457E-05 + .9689E-06 + .6442E-06 + .4284E-06 + .2994E-06 + .2133E-06 + .1521E-06 + .1085E-06 + .7737E-07 + .6071E-07 + .4983E-07 + .4091E-07 + .3396E-07 + .3215E-07 + .3043E-07 + .2786E-07 + .2473E-07 + .2195E-07 + .2097E-07 + .1472E-05 + .1651E-05 + .1831E-05 + .2010E-05 + .2222E-05 + .2431E-05 + .2662E-05 + .2900E-05 + .3225E-05 + .3569E-05 + .4028E-05 + .4503E-05 + .4992E-05 + .5591E-05 + .6220E-05 + .6824E-05 + .7348E-05 + .7755E-05 + .7910E-05 + .7941E-05 + .7765E-05 + .7544E-05 + .7193E-05 + .6982E-05 + .6679E-05 + .6550E-05 + .6449E-05 + .6247E-05 + .6106E-05 + .5905E-05 + .5704E-05 + .5410E-05 + .4990E-05 + .4644E-05 + .4202E-05 + .3665E-05 + .3155E-05 + .2683E-05 + .2257E-05 + .1803E-05 + .1382E-05 + .9061E-06 + .5942E-06 + .3896E-06 + .2725E-06 + .1931E-06 + .1378E-06 + .9965E-07 + .7208E-07 + .5762E-07 + .4829E-07 + .4048E-07 + .3427E-07 + .3253E-07 + .3088E-07 + .2837E-07 + .2530E-07 + .2256E-07 + .2159E-07 + .1506E-05 + .1682E-05 + .1859E-05 + .2037E-05 + .2240E-05 + .2442E-05 + .2671E-05 + .2936E-05 + .3240E-05 + .3578E-05 + .4051E-05 + .4527E-05 + .5059E-05 + .5639E-05 + .6221E-05 + .6782E-05 + .7242E-05 + .7588E-05 + .7781E-05 + .7812E-05 + .7742E-05 + .7563E-05 + .7315E-05 + .7113E-05 + .6921E-05 + .6731E-05 + .6643E-05 + .6446E-05 + .6332E-05 + .6117E-05 + .5897E-05 + .5585E-05 + .5122E-05 + .4727E-05 + .4224E-05 + .3643E-05 + .3104E-05 + .2603E-05 + .2151E-05 + .1694E-05 + .1281E-05 + .8338E-06 + .5426E-06 + .3531E-06 + .2471E-06 + .1741E-06 + .1243E-06 + .9120E-07 + .6690E-07 + .5448E-07 + .4663E-07 + .3991E-07 + .3445E-07 + .3279E-07 + .3121E-07 + .2879E-07 + .2578E-07 + .2309E-07 + .2214E-07 + .1545E-05 + .1718E-05 + .1890E-05 + .2068E-05 + .2259E-05 + .2456E-05 + .2683E-05 + .2944E-05 + .3235E-05 + .3586E-05 + .4044E-05 + .4510E-05 + .5029E-05 + .5592E-05 + .6189E-05 + .6757E-05 + .7229E-05 + .7599E-05 + .7811E-05 + .7874E-05 + .7830E-05 + .7677E-05 + .7475E-05 + .7316E-05 + .7140E-05 + .6974E-05 + .6851E-05 + .6672E-05 + .6526E-05 + .6309E-05 + .6113E-05 + .5781E-05 + .5312E-05 + .4813E-05 + .4215E-05 + .3589E-05 + .3017E-05 + .2492E-05 + .2011E-05 + .1548E-05 + .1143E-05 + .7479E-06 + .4895E-06 + .3203E-06 + .2244E-06 + .1571E-06 + .1124E-06 + .8357E-07 + .6217E-07 + .5158E-07 + .4507E-07 + .3939E-07 + .3467E-07 + .3309E-07 + .3159E-07 + .2924E-07 + .2631E-07 + .2367E-07 + .2273E-07 + .1568E-05 + .1736E-05 + .1906E-05 + .2080E-05 + .2260E-05 + .2451E-05 + .2672E-05 + .2926E-05 + .3205E-05 + .3552E-05 + .3987E-05 + .4439E-05 + .4930E-05 + .5486E-05 + .6085E-05 + .6665E-05 + .7152E-05 + .7542E-05 + .7794E-05 + .7900E-05 + .7882E-05 + .7772E-05 + .7616E-05 + .7502E-05 + .7360E-05 + .7214E-05 + .7082E-05 + .6922E-05 + .6754E-05 + .6521E-05 + .6311E-05 + .5948E-05 + .5447E-05 + .4853E-05 + .4183E-05 + .3516E-05 + .2920E-05 + .2385E-05 + .1884E-05 + .1414E-05 + .1015E-05 + .6683E-06 + .4399E-06 + .2896E-06 + .2030E-06 + .1413E-06 + .1012E-06 + .7631E-07 + .5756E-07 + .4866E-07 + .4342E-07 + .3874E-07 + .3476E-07 + .3328E-07 + .3186E-07 + .2960E-07 + .2675E-07 + .2417E-07 + .2326E-07 + .1577E-05 + .1742E-05 + .1911E-05 + .2079E-05 + .2249E-05 + .2432E-05 + .2645E-05 + .2889E-05 + .3158E-05 + .3487E-05 + .3893E-05 + .4327E-05 + .4778E-05 + .5336E-05 + .5931E-05 + .6526E-05 + .7031E-05 + .7436E-05 + .7748E-05 + .7905E-05 + .7914E-05 + .7861E-05 + .7752E-05 + .7684E-05 + .7595E-05 + .7464E-05 + .7348E-05 + .7208E-05 + .7028E-05 + .6763E-05 + .6501E-05 + .6095E-05 + .5537E-05 + .4858E-05 + .4137E-05 + .3435E-05 + .2819E-05 + .2284E-05 + .1770E-05 + .1293E-05 + .8999E-06 + .5960E-06 + .3947E-06 + .2614E-06 + .1834E-06 + .1269E-06 + .9093E-07 + .6956E-07 + .5321E-07 + .4582E-07 + .4175E-07 + .3804E-07 + .3480E-07 + .3341E-07 + .3208E-07 + .2992E-07 + .2716E-07 + .2465E-07 + .2375E-07 + .1587E-05 + .1741E-05 + .1901E-05 + .2062E-05 + .2229E-05 + .2413E-05 + .2624E-05 + .2869E-05 + .3130E-05 + .3471E-05 + .3835E-05 + .4254E-05 + .4707E-05 + .5246E-05 + .5848E-05 + .6435E-05 + .6976E-05 + .7407E-05 + .7760E-05 + .7957E-05 + .8019E-05 + .8009E-05 + .7965E-05 + .7936E-05 + .7879E-05 + .7753E-05 + .7666E-05 + .7537E-05 + .7342E-05 + .7070E-05 + .6724E-05 + .6254E-05 + .5628E-05 + .4890E-05 + .4117E-05 + .3377E-05 + .2735E-05 + .2167E-05 + .1637E-05 + .1156E-05 + .7746E-06 + .5192E-06 + .3480E-06 + .2332E-06 + .1639E-06 + .1138E-06 + .8220E-07 + .6394E-07 + .4973E-07 + .4357E-07 + .4040E-07 + .3745E-07 + .3483E-07 + .3350E-07 + .3223E-07 + .3004E-07 + .2731E-07 + .2469E-07 + .2360E-07 + .1604E-05 + .1744E-05 + .1892E-05 + .2047E-05 + .2214E-05 + .2402E-05 + .2616E-05 + .2867E-05 + .3122E-05 + .3485E-05 + .3806E-05 + .4212E-05 + .4682E-05 + .5197E-05 + .5813E-05 + .6386E-05 + .6972E-05 + .7434E-05 + .7822E-05 + .8058E-05 + .8182E-05 + .8212E-05 + .8243E-05 + .8253E-05 + .8219E-05 + .8095E-05 + .8043E-05 + .7921E-05 + .7710E-05 + .7440E-05 + .6991E-05 + .6443E-05 + .5743E-05 + .4949E-05 + .4121E-05 + .3340E-05 + .2668E-05 + .2056E-05 + .1510E-05 + .1028E-05 + .6619E-06 + .4441E-06 + .2979E-06 + .1999E-06 + .1411E-06 + .1006E-06 + .7454E-07 + .5934E-07 + .4725E-07 + .4196E-07 + .3924E-07 + .3670E-07 + .3440E-07 + .3309E-07 + .3183E-07 + .2933E-07 + .2650E-07 + .2335E-07 + .2161E-07 + .1598E-05 + .1741E-05 + .1890E-05 + .2043E-05 + .2208E-05 + .2392E-05 + .2602E-05 + .2842E-05 + .3095E-05 + .3426E-05 + .3798E-05 + .4163E-05 + .4628E-05 + .5149E-05 + .5769E-05 + .6351E-05 + .6945E-05 + .7446E-05 + .7885E-05 + .8168E-05 + .8343E-05 + .8433E-05 + .8495E-05 + .8550E-05 + .8567E-05 + .8528E-05 + .8521E-05 + .8420E-05 + .8162E-05 + .7862E-05 + .7384E-05 + .6765E-05 + .5950E-05 + .5058E-05 + .4121E-05 + .3278E-05 + .2555E-05 + .1925E-05 + .1367E-05 + .8852E-06 + .5412E-06 + .3688E-06 + .2513E-06 + .1713E-06 + .1214E-06 + .8892E-07 + .6757E-07 + .5507E-07 + .4488E-07 + .4039E-07 + .3811E-07 + .3596E-07 + .3398E-07 + .3267E-07 + .3142E-07 + .2863E-07 + .2571E-07 + .2209E-07 + .1979E-07 + .1588E-05 + .1734E-05 + .1885E-05 + .2035E-05 + .2197E-05 + .2375E-05 + .2579E-05 + .2809E-05 + .3059E-05 + .3358E-05 + .3771E-05 + .4102E-05 + .4555E-05 + .5082E-05 + .5694E-05 + .6282E-05 + .6888E-05 + .7428E-05 + .7915E-05 + .8247E-05 + .8476E-05 + .8634E-05 + .8727E-05 + .8828E-05 + .8899E-05 + .8948E-05 + .8985E-05 + .8912E-05 + .8609E-05 + .8267E-05 + .7760E-05 + .7063E-05 + .6136E-05 + .5145E-05 + .4105E-05 + .3204E-05 + .2439E-05 + .1795E-05 + .1232E-05 + .7589E-06 + .4414E-06 + .3053E-06 + .2112E-06 + .1461E-06 + .1040E-06 + .7826E-07 + .6101E-07 + .5089E-07 + .4246E-07 + .3873E-07 + .3686E-07 + .3509E-07 + .3342E-07 + .3213E-07 + .3089E-07 + .2784E-07 + .2485E-07 + .2081E-07 + .1804E-07 + .1595E-05 + .1742E-05 + .1894E-05 + .2036E-05 + .2190E-05 + .2362E-05 + .2560E-05 + .2786E-05 + .3023E-05 + .3327E-05 + .3701E-05 + .4050E-05 + .4460E-05 + .4995E-05 + .5550E-05 + .6128E-05 + .6794E-05 + .7368E-05 + .7890E-05 + .8274E-05 + .8594E-05 + .8841E-05 + .8979E-05 + .9117E-05 + .9230E-05 + .9307E-05 + .9356E-05 + .9334E-05 + .9025E-05 + .8596E-05 + .8010E-05 + .7207E-05 + .6225E-05 + .5164E-05 + .4070E-05 + .3123E-05 + .2342E-05 + .1673E-05 + .1107E-05 + .6543E-06 + .3676E-06 + .2559E-06 + .1782E-06 + .1241E-06 + .8868E-07 + .6852E-07 + .5480E-07 + .4679E-07 + .3996E-07 + .3695E-07 + .3547E-07 + .3406E-07 + .3270E-07 + .3144E-07 + .3022E-07 + .2693E-07 + .2389E-07 + .1950E-07 + .1637E-07 + .1608E-05 + .1752E-05 + .1902E-05 + .2035E-05 + .2181E-05 + .2346E-05 + .2537E-05 + .2758E-05 + .2988E-05 + .3284E-05 + .3625E-05 + .3974E-05 + .4365E-05 + .4895E-05 + .5418E-05 + .5992E-05 + .6669E-05 + .7258E-05 + .7810E-05 + .8254E-05 + .8658E-05 + .8990E-05 + .9186E-05 + .9378E-05 + .9545E-05 + .9656E-05 + .9704E-05 + .9694E-05 + .9382E-05 + .8878E-05 + .8218E-05 + .7325E-05 + .6290E-05 + .5166E-05 + .4027E-05 + .3044E-05 + .2237E-05 + .1552E-05 + .9894E-06 + .5624E-06 + .3069E-06 + .2148E-06 + .1503E-06 + .1052E-06 + .7551E-07 + .5992E-07 + .4916E-07 + .4297E-07 + .3756E-07 + .3520E-07 + .3409E-07 + .3302E-07 + .3196E-07 + .3072E-07 + .2953E-07 + .2601E-07 + .2294E-07 + .1825E-07 + .1483E-07 + .1641E-05 + .1775E-05 + .1916E-05 + .2040E-05 + .2178E-05 + .2335E-05 + .2521E-05 + .2733E-05 + .2966E-05 + .3236E-05 + .3555E-05 + .3873E-05 + .4292E-05 + .4798E-05 + .5330E-05 + .5911E-05 + .6517E-05 + .7093E-05 + .7672E-05 + .8188E-05 + .8664E-05 + .9070E-05 + .9347E-05 + .9622E-05 + .9863E-05 + .1002E-04 + .1004E-04 + .9966E-05 + .9651E-05 + .9100E-05 + .8379E-05 + .7426E-05 + .6335E-05 + .5162E-05 + .3989E-05 + .2981E-05 + .2124E-05 + .1432E-05 + .8806E-06 + .4830E-06 + .2586E-06 + .1815E-06 + .1274E-06 + .8943E-07 + .6447E-07 + .5254E-07 + .4422E-07 + .3957E-07 + .3541E-07 + .3363E-07 + .3285E-07 + .3210E-07 + .3132E-07 + .3010E-07 + .2892E-07 + .2520E-07 + .2208E-07 + .1712E-07 + .1347E-07 + .1647E-05 + .1774E-05 + .1909E-05 + .2029E-05 + .2164E-05 + .2317E-05 + .2496E-05 + .2699E-05 + .2921E-05 + .3190E-05 + .3480E-05 + .3786E-05 + .4187E-05 + .4662E-05 + .5172E-05 + .5745E-05 + .6331E-05 + .6917E-05 + .7522E-05 + .8091E-05 + .8615E-05 + .9075E-05 + .9413E-05 + .9782E-05 + .1010E-04 + .1032E-04 + .1034E-04 + .1025E-04 + .9887E-05 + .9279E-05 + .8509E-05 + .7477E-05 + .6335E-05 + .5146E-05 + .3967E-05 + .2933E-05 + .2057E-05 + .1362E-05 + .8083E-06 + .4267E-06 + .2202E-06 + .1543E-06 + .1082E-06 + .7579E-07 + .5488E-07 + .4593E-07 + .3965E-07 + .3632E-07 + .3327E-07 + .3202E-07 + .3156E-07 + .3111E-07 + .3060E-07 + .2940E-07 + .2825E-07 + .2433E-07 + .2120E-07 + .1602E-07 + .1220E-07 + .1635E-05 + .1757E-05 + .1887E-05 + .2007E-05 + .2143E-05 + .2297E-05 + .2468E-05 + .2662E-05 + .2861E-05 + .3148E-05 + .3405E-05 + .3714E-05 + .4064E-05 + .4506E-05 + .4971E-05 + .5527E-05 + .6129E-05 + .6743E-05 + .7372E-05 + .7980E-05 + .8535E-05 + .9031E-05 + .9414E-05 + .9885E-05 + .1028E-04 + .1058E-04 + .1064E-04 + .1056E-04 + .1011E-04 + .9433E-05 + .8624E-05 + .7496E-05 + .6307E-05 + .5128E-05 + .3962E-05 + .2900E-05 + .2025E-05 + .1329E-05 + .7607E-06 + .3857E-06 + .1893E-06 + .1320E-06 + .9202E-07 + .6416E-07 + .4665E-07 + .4010E-07 + .3551E-07 + .3330E-07 + .3122E-07 + .3046E-07 + .3029E-07 + .3011E-07 + .2986E-07 + .2868E-07 + .2755E-07 + .2347E-07 + .2032E-07 + .1497E-07 + .1103E-07 + .1619E-05 + .1738E-05 + .1859E-05 + .1975E-05 + .2104E-05 + .2253E-05 + .2418E-05 + .2606E-05 + .2801E-05 + .3070E-05 + .3316E-05 + .3604E-05 + .3939E-05 + .4339E-05 + .4794E-05 + .5349E-05 + .5907E-05 + .6526E-05 + .7133E-05 + .7831E-05 + .8472E-05 + .9025E-05 + .9462E-05 + .9961E-05 + .1039E-04 + .1075E-04 + .1088E-04 + .1078E-04 + .1017E-04 + .9507E-05 + .8705E-05 + .7551E-05 + .6324E-05 + .5127E-05 + .3970E-05 + .2906E-05 + .2024E-05 + .1317E-05 + .7479E-06 + .3684E-06 + .1794E-06 + .1205E-06 + .8089E-07 + .5431E-07 + .3966E-07 + .3501E-07 + .3181E-07 + .3053E-07 + .2930E-07 + .2897E-07 + .2906E-07 + .2915E-07 + .2913E-07 + .2798E-07 + .2688E-07 + .2263E-07 + .1948E-07 + .1399E-07 + .9978E-08 + .1593E-05 + .1709E-05 + .1820E-05 + .1931E-05 + .2050E-05 + .2192E-05 + .2351E-05 + .2532E-05 + .2727E-05 + .2969E-05 + .3207E-05 + .3468E-05 + .3795E-05 + .4152E-05 + .4604E-05 + .5158E-05 + .5656E-05 + .6269E-05 + .6838E-05 + .7631E-05 + .8369E-05 + .8982E-05 + .9473E-05 + .9974E-05 + .1043E-04 + .1083E-04 + .1104E-04 + .1093E-04 + .1013E-04 + .9507E-05 + .8730E-05 + .7577E-05 + .6320E-05 + .5105E-05 + .3961E-05 + .2908E-05 + .2022E-05 + .1305E-05 + .7408E-06 + .3558E-06 + .1741E-06 + .1179E-06 + .7986E-07 + .5409E-07 + .4015E-07 + .3553E-07 + .3240E-07 + .3127E-07 + .3019E-07 + .2987E-07 + .2989E-07 + .2992E-07 + .2983E-07 + .2855E-07 + .2733E-07 + .2328E-07 + .1982E-07 + .1420E-07 + .1045E-07 + .1615E-05 + .1724E-05 + .1833E-05 + .1942E-05 + .2064E-05 + .2207E-05 + .2366E-05 + .2541E-05 + .2733E-05 + .2961E-05 + .3174E-05 + .3441E-05 + .3751E-05 + .4097E-05 + .4551E-05 + .5080E-05 + .5596E-05 + .6250E-05 + .6868E-05 + .7547E-05 + .8202E-05 + .8766E-05 + .9223E-05 + .9748E-05 + .1018E-04 + .1062E-04 + .1095E-04 + .1095E-04 + .1039E-04 + .9661E-05 + .8744E-05 + .7537E-05 + .6283E-05 + .5081E-05 + .3934E-05 + .2917E-05 + .2051E-05 + .1331E-05 + .7439E-06 + .3401E-06 + .1600E-06 + .1122E-06 + .7872E-07 + .5522E-07 + .4174E-07 + .3690E-07 + .3366E-07 + .3260E-07 + .3158E-07 + .3120E-07 + .3111E-07 + .3102E-07 + .3082E-07 + .2937E-07 + .2800E-07 + .2422E-07 + .2037E-07 + .1462E-07 + .1120E-07 + .1627E-05 + .1731E-05 + .1838E-05 + .1947E-05 + .2073E-05 + .2217E-05 + .2375E-05 + .2548E-05 + .2736E-05 + .2957E-05 + .3151E-05 + .3427E-05 + .3725E-05 + .4065E-05 + .4513E-05 + .5016E-05 + .5542E-05 + .6209E-05 + .6865E-05 + .7464E-05 + .8044E-05 + .8570E-05 + .9009E-05 + .9541E-05 + .9949E-05 + .1040E-04 + .1082E-04 + .1096E-04 + .1060E-04 + .9787E-05 + .8743E-05 + .7490E-05 + .6231E-05 + .5041E-05 + .3903E-05 + .2919E-05 + .2075E-05 + .1358E-05 + .7535E-06 + .3349E-06 + .1520E-06 + .1092E-06 + .7845E-07 + .5636E-07 + .4339E-07 + .3832E-07 + .3497E-07 + .3398E-07 + .3302E-07 + .3258E-07 + .3236E-07 + .3215E-07 + .3182E-07 + .3021E-07 + .2868E-07 + .2518E-07 + .2093E-07 + .1505E-07 + .1201E-07 + .1594E-05 + .1700E-05 + .1811E-05 + .1927E-05 + .2056E-05 + .2203E-05 + .2362E-05 + .2546E-05 + .2727E-05 + .2973E-05 + .3165E-05 + .3465E-05 + .3780E-05 + .4133E-05 + .4538E-05 + .5015E-05 + .5513E-05 + .6074E-05 + .6712E-05 + .7400E-05 + .7946E-05 + .8479E-05 + .8973E-05 + .9449E-05 + .9833E-05 + .1023E-04 + .1060E-04 + .1097E-04 + .1057E-04 + .9798E-05 + .8712E-05 + .7440E-05 + .6137E-05 + .4947E-05 + .3863E-05 + .2902E-05 + .2087E-05 + .1383E-05 + .7937E-06 + .3762E-06 + .1684E-06 + .1178E-06 + .8240E-07 + .5765E-07 + .4519E-07 + .3987E-07 + .3640E-07 + .3549E-07 + .3461E-07 + .3409E-07 + .3374E-07 + .3339E-07 + .3293E-07 + .3113E-07 + .2944E-07 + .2623E-07 + .2155E-07 + .1551E-07 + .1289E-07 + .1578E-05 + .1690E-05 + .1803E-05 + .1920E-05 + .2048E-05 + .2194E-05 + .2351E-05 + .2540E-05 + .2715E-05 + .2986E-05 + .3185E-05 + .3484E-05 + .3810E-05 + .4165E-05 + .4548E-05 + .5002E-05 + .5482E-05 + .5996E-05 + .6639E-05 + .7341E-05 + .7895E-05 + .8436E-05 + .8965E-05 + .9398E-05 + .9768E-05 + .1013E-04 + .1049E-04 + .1098E-04 + .1056E-04 + .9803E-05 + .8681E-05 + .7409E-05 + .6083E-05 + .4874E-05 + .3827E-05 + .2886E-05 + .2090E-05 + .1398E-05 + .8181E-06 + .3973E-06 + .1791E-06 + .1238E-06 + .8556E-07 + .5914E-07 + .4722E-07 + .4161E-07 + .3801E-07 + .3718E-07 + .3637E-07 + .3578E-07 + .3528E-07 + .3479E-07 + .3418E-07 + .3218E-07 + .3031E-07 + .2742E-07 + .2225E-07 + .1605E-07 + .1388E-07 + .1584E-05 + .1709E-05 + .1823E-05 + .1933E-05 + .2050E-05 + .2188E-05 + .2339E-05 + .2524E-05 + .2693E-05 + .2991E-05 + .3209E-05 + .3468E-05 + .3793E-05 + .4135E-05 + .4532E-05 + .4966E-05 + .5443E-05 + .5992E-05 + .6676E-05 + .7280E-05 + .7903E-05 + .8455E-05 + .8984E-05 + .9397E-05 + .9767E-05 + .1014E-04 + .1055E-04 + .1098E-04 + .1057E-04 + .9782E-05 + .8640E-05 + .7395E-05 + .6077E-05 + .4826E-05 + .3790E-05 + .2865E-05 + .2073E-05 + .1393E-05 + .8145E-06 + .3816E-06 + .1788E-06 + .1264E-06 + .8941E-07 + .6322E-07 + .5079E-07 + .4451E-07 + .4052E-07 + .3966E-07 + .3881E-07 + .3812E-07 + .3751E-07 + .3690E-07 + .3618E-07 + .3403E-07 + .3202E-07 + .2909E-07 + .2355E-07 + .1726E-07 + .1532E-07 + .1566E-05 + .1694E-05 + .1814E-05 + .1925E-05 + .2045E-05 + .2184E-05 + .2339E-05 + .2527E-05 + .2695E-05 + .2987E-05 + .3201E-05 + .3461E-05 + .3771E-05 + .4120E-05 + .4514E-05 + .4954E-05 + .5452E-05 + .6019E-05 + .6667E-05 + .7240E-05 + .7868E-05 + .8420E-05 + .8928E-05 + .9375E-05 + .9746E-05 + .1011E-04 + .1053E-04 + .1083E-04 + .1048E-04 + .9694E-05 + .8576E-05 + .7347E-05 + .6081E-05 + .4846E-05 + .3794E-05 + .2861E-05 + .2059E-05 + .1384E-05 + .8125E-06 + .3825E-06 + .1791E-06 + .1309E-06 + .9571E-07 + .6997E-07 + .5591E-07 + .4851E-07 + .4383E-07 + .4279E-07 + .4178E-07 + .4098E-07 + .4029E-07 + .3961E-07 + .3881E-07 + .3659E-07 + .3450E-07 + .3114E-07 + .2537E-07 + .1919E-07 + .1723E-07 + .1538E-05 + .1663E-05 + .1791E-05 + .1909E-05 + .2042E-05 + .2189E-05 + .2353E-05 + .2550E-05 + .2722E-05 + .2985E-05 + .3184E-05 + .3470E-05 + .3759E-05 + .4129E-05 + .4510E-05 + .4974E-05 + .5512E-05 + .6085E-05 + .6649E-05 + .7236E-05 + .7830E-05 + .8378E-05 + .8852E-05 + .9369E-05 + .9743E-05 + .1009E-04 + .1050E-04 + .1063E-04 + .1036E-04 + .9594E-05 + .8526E-05 + .7300E-05 + .6109E-05 + .4928E-05 + .3835E-05 + .2876E-05 + .2052E-05 + .1376E-05 + .8142E-06 + .3957E-06 + .1802E-06 + .1361E-06 + .1027E-06 + .7754E-07 + .6161E-07 + .5293E-07 + .4748E-07 + .4624E-07 + .4504E-07 + .4412E-07 + .4334E-07 + .4258E-07 + .4170E-07 + .3939E-07 + .3722E-07 + .3338E-07 + .2736E-07 + .2136E-07 + .1940E-07 + .1529E-05 + .1658E-05 + .1792E-05 + .1916E-05 + .2052E-05 + .2200E-05 + .2363E-05 + .2555E-05 + .2728E-05 + .2960E-05 + .3181E-05 + .3464E-05 + .3746E-05 + .4114E-05 + .4509E-05 + .4987E-05 + .5515E-05 + .6104E-05 + .6640E-05 + .7210E-05 + .7766E-05 + .8290E-05 + .8768E-05 + .9263E-05 + .9694E-05 + .1006E-04 + .1040E-04 + .1050E-04 + .1015E-04 + .9453E-05 + .8409E-05 + .7254E-05 + .6084E-05 + .4936E-05 + .3864E-05 + .2908E-05 + .2095E-05 + .1436E-05 + .8775E-06 + .4369E-06 + .2026E-06 + .1518E-06 + .1138E-06 + .8534E-07 + .6743E-07 + .5735E-07 + .5107E-07 + .4961E-07 + .4820E-07 + .4716E-07 + .4629E-07 + .4544E-07 + .4448E-07 + .4211E-07 + .3987E-07 + .3553E-07 + .2931E-07 + .2360E-07 + .2168E-07 + .1526E-05 + .1662E-05 + .1801E-05 + .1930E-05 + .2068E-05 + .2216E-05 + .2377E-05 + .2559E-05 + .2734E-05 + .2935E-05 + .3188E-05 + .3461E-05 + .3742E-05 + .4102E-05 + .4519E-05 + .5008E-05 + .5516E-05 + .6122E-05 + .6645E-05 + .7193E-05 + .7710E-05 + .8207E-05 + .8699E-05 + .9154E-05 + .9650E-05 + .1003E-04 + .1031E-04 + .1040E-04 + .9932E-05 + .9319E-05 + .8294E-05 + .7222E-05 + .6058E-05 + .4937E-05 + .3897E-05 + .2952E-05 + .2156E-05 + .1518E-05 + .9631E-06 + .4908E-06 + .2340E-06 + .1726E-06 + .1273E-06 + .9393E-07 + .7380E-07 + .6216E-07 + .5494E-07 + .5324E-07 + .5160E-07 + .5042E-07 + .4946E-07 + .4851E-07 + .4746E-07 + .4503E-07 + .4273E-07 + .3782E-07 + .3140E-07 + .2609E-07 + .2424E-07 + .1525E-05 + .1661E-05 + .1797E-05 + .1924E-05 + .2062E-05 + .2213E-05 + .2378E-05 + .2564E-05 + .2748E-05 + .2957E-05 + .3204E-05 + .3485E-05 + .3793E-05 + .4164E-05 + .4583E-05 + .5064E-05 + .5562E-05 + .6133E-05 + .6632E-05 + .7167E-05 + .7699E-05 + .8165E-05 + .8661E-05 + .9082E-05 + .9529E-05 + .9884E-05 + .1007E-04 + .1012E-04 + .9702E-05 + .9106E-05 + .8212E-05 + .7167E-05 + .6071E-05 + .4984E-05 + .3960E-05 + .3057E-05 + .2269E-05 + .1595E-05 + .1036E-05 + .5582E-06 + .2723E-06 + .1974E-06 + .1431E-06 + .1038E-06 + .8107E-07 + .6760E-07 + .5931E-07 + .5735E-07 + .5544E-07 + .5410E-07 + .5303E-07 + .5198E-07 + .5082E-07 + .4832E-07 + .4595E-07 + .4041E-07 + .3376E-07 + .2895E-07 + .2720E-07 + .1526E-05 + .1662E-05 + .1796E-05 + .1923E-05 + .2062E-05 + .2218E-05 + .2387E-05 + .2577E-05 + .2768E-05 + .2985E-05 + .3231E-05 + .3521E-05 + .3849E-05 + .4232E-05 + .4648E-05 + .5124E-05 + .5613E-05 + .6161E-05 + .6648E-05 + .7166E-05 + .7703E-05 + .8145E-05 + .8629E-05 + .9020E-05 + .9418E-05 + .9732E-05 + .9843E-05 + .9859E-05 + .9471E-05 + .8896E-05 + .8118E-05 + .7110E-05 + .6080E-05 + .5035E-05 + .4037E-05 + .3175E-05 + .2395E-05 + .1688E-05 + .1110E-05 + .6281E-06 + .3176E-06 + .2262E-06 + .1611E-06 + .1148E-06 + .8919E-07 + .7363E-07 + .6413E-07 + .6185E-07 + .5965E-07 + .5813E-07 + .5694E-07 + .5576E-07 + .5449E-07 + .5193E-07 + .4948E-07 + .4323E-07 + .3635E-07 + .3217E-07 + .3057E-07 + .1530E-05 + .1668E-05 + .1808E-05 + .1938E-05 + .2084E-05 + .2243E-05 + .2417E-05 + .2620E-05 + .2804E-05 + .3029E-05 + .3289E-05 + .3595E-05 + .3909E-05 + .4307E-05 + .4707E-05 + .5188E-05 + .5675E-05 + .6237E-05 + .6755E-05 + .7240E-05 + .7745E-05 + .8183E-05 + .8605E-05 + .8980E-05 + .9324E-05 + .9558E-05 + .9629E-05 + .9617E-05 + .9211E-05 + .8672E-05 + .7975E-05 + .7036E-05 + .6071E-05 + .5096E-05 + .4154E-05 + .3322E-05 + .2552E-05 + .1828E-05 + .1178E-05 + .6810E-06 + .3726E-06 + .2605E-06 + .1822E-06 + .1274E-06 + .9844E-07 + .8047E-07 + .6957E-07 + .6693E-07 + .6440E-07 + .6268E-07 + .6134E-07 + .6003E-07 + .5863E-07 + .5599E-07 + .5346E-07 + .4641E-07 + .3928E-07 + .3586E-07 + .3446E-07 + .1547E-05 + .1684E-05 + .1825E-05 + .1957E-05 + .2105E-05 + .2268E-05 + .2445E-05 + .2655E-05 + .2840E-05 + .3078E-05 + .3346E-05 + .3664E-05 + .3970E-05 + .4368E-05 + .4770E-05 + .5254E-05 + .5731E-05 + .6283E-05 + .6825E-05 + .7320E-05 + .7797E-05 + .8219E-05 + .8600E-05 + .8938E-05 + .9230E-05 + .9402E-05 + .9444E-05 + .9379E-05 + .8972E-05 + .8473E-05 + .7831E-05 + .6970E-05 + .6077E-05 + .5174E-05 + .4291E-05 + .3486E-05 + .2728E-05 + .1995E-05 + .1296E-05 + .7699E-06 + .4466E-06 + .3103E-06 + .2156E-06 + .1498E-06 + .1152E-06 + .9234E-07 + .7799E-07 + .7281E-07 + .6797E-07 + .6532E-07 + .6363E-07 + .6199E-07 + .6031E-07 + .5768E-07 + .5518E-07 + .4820E-07 + .4121E-07 + .3799E-07 + .3667E-07 + .1571E-05 + .1704E-05 + .1840E-05 + .1972E-05 + .2117E-05 + .2280E-05 + .2457E-05 + .2668E-05 + .2859E-05 + .3119E-05 + .3385E-05 + .3708E-05 + .4011E-05 + .4388E-05 + .4811E-05 + .5298E-05 + .5749E-05 + .6258E-05 + .6810E-05 + .7369E-05 + .7822E-05 + .8210E-05 + .8574E-05 + .8848E-05 + .9093E-05 + .9222E-05 + .9248E-05 + .9098E-05 + .8713E-05 + .8263E-05 + .7645E-05 + .6881E-05 + .6072E-05 + .5248E-05 + .4430E-05 + .3653E-05 + .2916E-05 + .2187E-05 + .1487E-05 + .9140E-06 + .5478E-06 + .3839E-06 + .2691E-06 + .1886E-06 + .1447E-06 + .1123E-06 + .9073E-07 + .7932E-07 + .6934E-07 + .6482E-07 + .6256E-07 + .6038E-07 + .5824E-07 + .5577E-07 + .5340E-07 + .4773E-07 + .4144E-07 + .3751E-07 + .3602E-07 + .1568E-05 + .1703E-05 + .1842E-05 + .1982E-05 + .2131E-05 + .2296E-05 + .2474E-05 + .2684E-05 + .2879E-05 + .3149E-05 + .3404E-05 + .3721E-05 + .4018E-05 + .4393E-05 + .4817E-05 + .5305E-05 + .5771E-05 + .6298E-05 + .6855E-05 + .7414E-05 + .7865E-05 + .8245E-05 + .8574E-05 + .8801E-05 + .9009E-05 + .9114E-05 + .9118E-05 + .8937E-05 + .8582E-05 + .8123E-05 + .7531E-05 + .6808E-05 + .6057E-05 + .5292E-05 + .4534E-05 + .3793E-05 + .3081E-05 + .2347E-05 + .1632E-05 + .1052E-05 + .6548E-06 + .4673E-06 + .3335E-06 + .2380E-06 + .1821E-06 + .1367E-06 + .1057E-06 + .8657E-07 + .7087E-07 + .6446E-07 + .6163E-07 + .5892E-07 + .5635E-07 + .5402E-07 + .5179E-07 + .4736E-07 + .4174E-07 + .3710E-07 + .3545E-07 + .1540E-05 + .1679E-05 + .1824E-05 + .1976E-05 + .2130E-05 + .2297E-05 + .2475E-05 + .2683E-05 + .2879E-05 + .3149E-05 + .3388E-05 + .3692E-05 + .3980E-05 + .4360E-05 + .4771E-05 + .5255E-05 + .5754E-05 + .6330E-05 + .6885E-05 + .7404E-05 + .7862E-05 + .8246E-05 + .8527E-05 + .8717E-05 + .8891E-05 + .8982E-05 + .8961E-05 + .8779E-05 + .8460E-05 + .7965E-05 + .7404E-05 + .6696E-05 + .5993E-05 + .5282E-05 + .4586E-05 + .3893E-05 + .3212E-05 + .2472E-05 + .1735E-05 + .1182E-05 + .7663E-06 + .5645E-06 + .4158E-06 + .3063E-06 + .2364E-06 + .1789E-06 + .1360E-06 + .1041E-06 + .7972E-07 + .6981E-07 + .6515E-07 + .6080E-07 + .5686E-07 + .5451E-07 + .5225E-07 + .4842E-07 + .4346E-07 + .3902E-07 + .3745E-07 + .1522E-05 + .1648E-05 + .1782E-05 + .1924E-05 + .2073E-05 + .2236E-05 + .2411E-05 + .2612E-05 + .2812E-05 + .3068E-05 + .3309E-05 + .3595E-05 + .3878E-05 + .4261E-05 + .4669E-05 + .5149E-05 + .5683E-05 + .6245E-05 + .6832E-05 + .7353E-05 + .7819E-05 + .8206E-05 + .8483E-05 + .8660E-05 + .8783E-05 + .8819E-05 + .8762E-05 + .8545E-05 + .8206E-05 + .7735E-05 + .7200E-05 + .6539E-05 + .5872E-05 + .5224E-05 + .4577E-05 + .3939E-05 + .3303E-05 + .2609E-05 + .1898E-05 + .1349E-05 + .9282E-06 + .6967E-06 + .5229E-06 + .3925E-06 + .3070E-06 + .2374E-06 + .1787E-06 + .1280E-06 + .9162E-07 + .7697E-07 + .6977E-07 + .6324E-07 + .5758E-07 + .5518E-07 + .5287E-07 + .4947E-07 + .4529E-07 + .4145E-07 + .4008E-07 + .1497E-05 + .1610E-05 + .1730E-05 + .1860E-05 + .2001E-05 + .2157E-05 + .2328E-05 + .2519E-05 + .2723E-05 + .2963E-05 + .3206E-05 + .3472E-05 + .3753E-05 + .4133E-05 + .4539E-05 + .5011E-05 + .5573E-05 + .6110E-05 + .6729E-05 + .7256E-05 + .7724E-05 + .8113E-05 + .8389E-05 + .8558E-05 + .8631E-05 + .8612E-05 + .8517E-05 + .8265E-05 + .7898E-05 + .7459E-05 + .6951E-05 + .6342E-05 + .5714E-05 + .5129E-05 + .4534E-05 + .3953E-05 + .3367E-05 + .2734E-05 + .2069E-05 + .1531E-05 + .1117E-05 + .8541E-06 + .6531E-06 + .4994E-06 + .3958E-06 + .3127E-06 + .2333E-06 + .1562E-06 + .1046E-06 + .8429E-07 + .7420E-07 + .6533E-07 + .5790E-07 + .5546E-07 + .5312E-07 + .5020E-07 + .4686E-07 + .4373E-07 + .4260E-07 + .1472E-05 + .1592E-05 + .1715E-05 + .1840E-05 + .1972E-05 + .2119E-05 + .2277E-05 + .2459E-05 + .2644E-05 + .2896E-05 + .3115E-05 + .3371E-05 + .3685E-05 + .4049E-05 + .4440E-05 + .4910E-05 + .5442E-05 + .5999E-05 + .6600E-05 + .7142E-05 + .7587E-05 + .7974E-05 + .8229E-05 + .8404E-05 + .8487E-05 + .8458E-05 + .8328E-05 + .8049E-05 + .7641E-05 + .7174E-05 + .6687E-05 + .6120E-05 + .5555E-05 + .5014E-05 + .4476E-05 + .3946E-05 + .3384E-05 + .2783E-05 + .2161E-05 + .1640E-05 + .1204E-05 + .9754E-06 + .7901E-06 + .6400E-06 + .5139E-06 + .4148E-06 + .3067E-06 + .1920E-06 + .1202E-06 + .9294E-07 + .7947E-07 + .6795E-07 + .5863E-07 + .5614E-07 + .5375E-07 + .5130E-07 + .4882E-07 + .4646E-07 + .4559E-07 + .1468E-05 + .1595E-05 + .1721E-05 + .1846E-05 + .1974E-05 + .2117E-05 + .2270E-05 + .2450E-05 + .2630E-05 + .2886E-05 + .3096E-05 + .3351E-05 + .3688E-05 + .4049E-05 + .4439E-05 + .4919E-05 + .5441E-05 + .6023E-05 + .6613E-05 + .7171E-05 + .7609E-05 + .7988E-05 + .8228E-05 + .8399E-05 + .8474E-05 + .8426E-05 + .8252E-05 + .7942E-05 + .7507E-05 + .7019E-05 + .6546E-05 + .6018E-05 + .5506E-05 + .4993E-05 + .4505E-05 + .4015E-05 + .3475E-05 + .2899E-05 + .2301E-05 + .1788E-05 + .1333E-05 + .1086E-05 + .8841E-06 + .7200E-06 + .5797E-06 + .4715E-06 + .3476E-06 + .2125E-06 + .1299E-06 + .9850E-07 + .8269E-07 + .6943E-07 + .5890E-07 + .5640E-07 + .5400E-07 + .5122E-07 + .4816E-07 + .4528E-07 + .4423E-07 + .1452E-05 + .1579E-05 + .1707E-05 + .1834E-05 + .1968E-05 + .2116E-05 + .2278E-05 + .2461E-05 + .2663E-05 + .2896E-05 + .3125E-05 + .3392E-05 + .3707E-05 + .4086E-05 + .4497E-05 + .4992E-05 + .5537E-05 + .6128E-05 + .6696E-05 + .7253E-05 + .7704E-05 + .8040E-05 + .8273E-05 + .8403E-05 + .8422E-05 + .8324E-05 + .8097E-05 + .7748E-05 + .7346E-05 + .6864E-05 + .6411E-05 + .5942E-05 + .5491E-05 + .4992E-05 + .4557E-05 + .4106E-05 + .3614E-05 + .3067E-05 + .2463E-05 + .1954E-05 + .1513E-05 + .1205E-05 + .9595E-06 + .7641E-06 + .6143E-06 + .5008E-06 + .3689E-06 + .2241E-06 + .1362E-06 + .1020E-06 + .8447E-07 + .6993E-07 + .5857E-07 + .5608E-07 + .5370E-07 + .5030E-07 + .4616E-07 + .4236E-07 + .4099E-07 + .1439E-05 + .1568E-05 + .1697E-05 + .1824E-05 + .1958E-05 + .2105E-05 + .2268E-05 + .2451E-05 + .2660E-05 + .2884E-05 + .3127E-05 + .3405E-05 + .3710E-05 + .4106E-05 + .4529E-05 + .5044E-05 + .5601E-05 + .6198E-05 + .6747E-05 + .7293E-05 + .7728E-05 + .8030E-05 + .8234E-05 + .8321E-05 + .8296E-05 + .8158E-05 + .7902E-05 + .7534E-05 + .7154E-05 + .6679E-05 + .6251E-05 + .5839E-05 + .5437E-05 + .4963E-05 + .4571E-05 + .4163E-05 + .3713E-05 + .3200E-05 + .2624E-05 + .2126E-05 + .1681E-05 + .1316E-05 + .1031E-05 + .8068E-06 + .6477E-06 + .5292E-06 + .3896E-06 + .2352E-06 + .1420E-06 + .1052E-06 + .8584E-07 + .7007E-07 + .5793E-07 + .5548E-07 + .5313E-07 + .4914E-07 + .4402E-07 + .3942E-07 + .3780E-07 + .1435E-05 + .1568E-05 + .1699E-05 + .1822E-05 + .1952E-05 + .2091E-05 + .2250E-05 + .2429E-05 + .2628E-05 + .2858E-05 + .3112E-05 + .3400E-05 + .3709E-05 + .4122E-05 + .4550E-05 + .5092E-05 + .5652E-05 + .6250E-05 + .6788E-05 + .7314E-05 + .7706E-05 + .7983E-05 + .8135E-05 + .8178E-05 + .8124E-05 + .7956E-05 + .7695E-05 + .7328E-05 + .6959E-05 + .6486E-05 + .6088E-05 + .5728E-05 + .5362E-05 + .4923E-05 + .4563E-05 + .4200E-05 + .3777E-05 + .3301E-05 + .2791E-05 + .2309E-05 + .1834E-05 + .1419E-05 + .1099E-05 + .8503E-06 + .6817E-06 + .5582E-06 + .4107E-06 + .2463E-06 + .1477E-06 + .1082E-06 + .8707E-07 + .7009E-07 + .5721E-07 + .5479E-07 + .5248E-07 + .4793E-07 + .4190E-07 + .3662E-07 + .3479E-07 + .1415E-05 + .1547E-05 + .1679E-05 + .1805E-05 + .1936E-05 + .2080E-05 + .2241E-05 + .2424E-05 + .2625E-05 + .2856E-05 + .3113E-05 + .3410E-05 + .3736E-05 + .4145E-05 + .4591E-05 + .5148E-05 + .5715E-05 + .6305E-05 + .6837E-05 + .7325E-05 + .7678E-05 + .7908E-05 + .7997E-05 + .8002E-05 + .7925E-05 + .7742E-05 + .7475E-05 + .7111E-05 + .6761E-05 + .6318E-05 + .5941E-05 + .5607E-05 + .5288E-05 + .4896E-05 + .4570E-05 + .4235E-05 + .3827E-05 + .3383E-05 + .2904E-05 + .2430E-05 + .1954E-05 + .1508E-05 + .1163E-05 + .8971E-06 + .7174E-06 + .5924E-06 + .4364E-06 + .2587E-06 + .1533E-06 + .1107E-06 + .8779E-07 + .6961E-07 + .5603E-07 + .5365E-07 + .5137E-07 + .4687E-07 + .4088E-07 + .3565E-07 + .3384E-07 + .1386E-05 + .1518E-05 + .1649E-05 + .1780E-05 + .1917E-05 + .2069E-05 + .2238E-05 + .2426E-05 + .2636E-05 + .2864E-05 + .3121E-05 + .3426E-05 + .3776E-05 + .4171E-05 + .4641E-05 + .5208E-05 + .5785E-05 + .6361E-05 + .6890E-05 + .7332E-05 + .7648E-05 + .7821E-05 + .7843E-05 + .7814E-05 + .7717E-05 + .7527E-05 + .7251E-05 + .6894E-05 + .6566E-05 + .6162E-05 + .5802E-05 + .5484E-05 + .5215E-05 + .4875E-05 + .4584E-05 + .4269E-05 + .3869E-05 + .3455E-05 + .2992E-05 + .2521E-05 + .2061E-05 + .1590E-05 + .1227E-05 + .9468E-06 + .7550E-06 + .6304E-06 + .4655E-06 + .2720E-06 + .1590E-06 + .1131E-06 + .8826E-07 + .6890E-07 + .5467E-07 + .5233E-07 + .5009E-07 + .4587E-07 + .4033E-07 + .3546E-07 + .3376E-07 + .1365E-05 + .1496E-05 + .1626E-05 + .1760E-05 + .1900E-05 + .2054E-05 + .2226E-05 + .2416E-05 + .2636E-05 + .2860E-05 + .3136E-05 + .3447E-05 + .3798E-05 + .4220E-05 + .4723E-05 + .5282E-05 + .5864E-05 + .6405E-05 + .6879E-05 + .7235E-05 + .7486E-05 + .7597E-05 + .7582E-05 + .7534E-05 + .7429E-05 + .7219E-05 + .6980E-05 + .6659E-05 + .6344E-05 + .5981E-05 + .5670E-05 + .5392E-05 + .5156E-05 + .4862E-05 + .4574E-05 + .4288E-05 + .3918E-05 + .3527E-05 + .3087E-05 + .2621E-05 + .2158E-05 + .1667E-05 + .1288E-05 + .9946E-06 + .7909E-06 + .6677E-06 + .4943E-06 + .2847E-06 + .1640E-06 + .1149E-06 + .8832E-07 + .6789E-07 + .5310E-07 + .5080E-07 + .4861E-07 + .4469E-07 + .3961E-07 + .3510E-07 + .3352E-07 + .1340E-05 + .1469E-05 + .1599E-05 + .1734E-05 + .1877E-05 + .2032E-05 + .2206E-05 + .2398E-05 + .2626E-05 + .2849E-05 + .3144E-05 + .3461E-05 + .3812E-05 + .4261E-05 + .4795E-05 + .5343E-05 + .5923E-05 + .6422E-05 + .6833E-05 + .7104E-05 + .7288E-05 + .7341E-05 + .7293E-05 + .7228E-05 + .7116E-05 + .6891E-05 + .6685E-05 + .6402E-05 + .6107E-05 + .5788E-05 + .5528E-05 + .5292E-05 + .5085E-05 + .4834E-05 + .4548E-05 + .4291E-05 + .3954E-05 + .3584E-05 + .3170E-05 + .2711E-05 + .2245E-05 + .1740E-05 + .1348E-05 + .1045E-05 + .8325E-06 + .7001E-06 + .5223E-06 + .3102E-06 + .1843E-06 + .1273E-06 + .9450E-07 + .7014E-07 + .5310E-07 + .5038E-07 + .4781E-07 + .4291E-07 + .3658E-07 + .3118E-07 + .2933E-07 + .1310E-05 + .1439E-05 + .1570E-05 + .1705E-05 + .1852E-05 + .2013E-05 + .2194E-05 + .2396E-05 + .2629E-05 + .2881E-05 + .3182E-05 + .3525E-05 + .3896E-05 + .4349E-05 + .4889E-05 + .5439E-05 + .5982E-05 + .6422E-05 + .6772E-05 + .7000E-05 + .7116E-05 + .7117E-05 + .7038E-05 + .6946E-05 + .6805E-05 + .6605E-05 + .6386E-05 + .6132E-05 + .5908E-05 + .5665E-05 + .5456E-05 + .5249E-05 + .5062E-05 + .4828E-05 + .4556E-05 + .4307E-05 + .3989E-05 + .3626E-05 + .3222E-05 + .2764E-05 + .2304E-05 + .1802E-05 + .1409E-05 + .1102E-05 + .8803E-06 + .7373E-06 + .5545E-06 + .3396E-06 + .2080E-06 + .1417E-06 + .1016E-06 + .7281E-07 + .5334E-07 + .5020E-07 + .4724E-07 + .4138E-07 + .3393E-07 + .2782E-07 + .2578E-07 + .1274E-05 + .1405E-05 + .1538E-05 + .1675E-05 + .1824E-05 + .1989E-05 + .2176E-05 + .2387E-05 + .2625E-05 + .2898E-05 + .3210E-05 + .3574E-05 + .3962E-05 + .4420E-05 + .4956E-05 + .5495E-05 + .5989E-05 + .6366E-05 + .6651E-05 + .6831E-05 + .6889E-05 + .6851E-05 + .6747E-05 + .6635E-05 + .6480E-05 + .6295E-05 + .6083E-05 + .5867E-05 + .5706E-05 + .5525E-05 + .5368E-05 + .5194E-05 + .5023E-05 + .4800E-05 + .4538E-05 + .4299E-05 + .4002E-05 + .3650E-05 + .3256E-05 + .2805E-05 + .2359E-05 + .1861E-05 + .1468E-05 + .1158E-05 + .9270E-06 + .7733E-06 + .5862E-06 + .3702E-06 + .2338E-06 + .1571E-06 + .1087E-06 + .7527E-07 + .5336E-07 + .4980E-07 + .4648E-07 + .3974E-07 + .3134E-07 + .2471E-07 + .2257E-07 + .1234E-05 + .1367E-05 + .1504E-05 + .1647E-05 + .1800E-05 + .1968E-05 + .2159E-05 + .2376E-05 + .2620E-05 + .2900E-05 + .3232E-05 + .3607E-05 + .4008E-05 + .4474E-05 + .4989E-05 + .5489E-05 + .5913E-05 + .6227E-05 + .6440E-05 + .6562E-05 + .6582E-05 + .6530E-05 + .6408E-05 + .6294E-05 + .6144E-05 + .5959E-05 + .5792E-05 + .5632E-05 + .5525E-05 + .5376E-05 + .5274E-05 + .5142E-05 + .4978E-05 + .4750E-05 + .4487E-05 + .4263E-05 + .3989E-05 + .3654E-05 + .3268E-05 + .2830E-05 + .2417E-05 + .1921E-05 + .1526E-05 + .1213E-05 + .9728E-06 + .8083E-06 + .6176E-06 + .4021E-06 + .2619E-06 + .1736E-06 + .1160E-06 + .7754E-07 + .5319E-07 + .4924E-07 + .4557E-07 + .3804E-07 + .2885E-07 + .2188E-07 + .1969E-07 + .1202E-05 + .1337E-05 + .1477E-05 + .1625E-05 + .1783E-05 + .1957E-05 + .2156E-05 + .2382E-05 + .2638E-05 + .2930E-05 + .3275E-05 + .3657E-05 + .4071E-05 + .4546E-05 + .5027E-05 + .5477E-05 + .5842E-05 + .6123E-05 + .6250E-05 + .6309E-05 + .6294E-05 + .6232E-05 + .6113E-05 + .6010E-05 + .5882E-05 + .5723E-05 + .5596E-05 + .5472E-05 + .5383E-05 + .5255E-05 + .5172E-05 + .5061E-05 + .4913E-05 + .4673E-05 + .4411E-05 + .4187E-05 + .3924E-05 + .3589E-05 + .3217E-05 + .2804E-05 + .2419E-05 + .1953E-05 + .1576E-05 + .1272E-05 + .1023E-05 + .8464E-06 + .6518E-06 + .4377E-06 + .2939E-06 + .1921E-06 + .1240E-06 + .8003E-07 + .5313E-07 + .4877E-07 + .4477E-07 + .3648E-07 + .2661E-07 + .1941E-07 + .1721E-07 + .1191E-05 + .1327E-05 + .1473E-05 + .1627E-05 + .1791E-05 + .1974E-05 + .2188E-05 + .2430E-05 + .2707E-05 + .3020E-05 + .3372E-05 + .3765E-05 + .4196E-05 + .4683E-05 + .5122E-05 + .5519E-05 + .5837E-05 + .6115E-05 + .6144E-05 + .6135E-05 + .6089E-05 + .6018E-05 + .5918E-05 + .5836E-05 + .5742E-05 + .5631E-05 + .5537E-05 + .5431E-05 + .5332E-05 + .5213E-05 + .5119E-05 + .5011E-05 + .4884E-05 + .4623E-05 + .4357E-05 + .4120E-05 + .3853E-05 + .3499E-05 + .3143E-05 + .2761E-05 + .2394E-05 + .1954E-05 + .1595E-05 + .1302E-05 + .1048E-05 + .8657E-06 + .6687E-06 + .4542E-06 + .3085E-06 + .2006E-06 + .1278E-06 + .8140E-07 + .5338E-07 + .4885E-07 + .4470E-07 + .3609E-07 + .2594E-07 + .1865E-07 + .1644E-07 + .1183E-05 + .1319E-05 + .1471E-05 + .1631E-05 + .1802E-05 + .1996E-05 + .2225E-05 + .2483E-05 + .2783E-05 + .3117E-05 + .3479E-05 + .3883E-05 + .4332E-05 + .4834E-05 + .5229E-05 + .5571E-05 + .5842E-05 + .6118E-05 + .6050E-05 + .5978E-05 + .5901E-05 + .5822E-05 + .5740E-05 + .5678E-05 + .5615E-05 + .5551E-05 + .5489E-05 + .5401E-05 + .5291E-05 + .5180E-05 + .5075E-05 + .4970E-05 + .4863E-05 + .4581E-05 + .4313E-05 + .4062E-05 + .3791E-05 + .3418E-05 + .3077E-05 + .2723E-05 + .2374E-05 + .1945E-05 + .1593E-05 + .1305E-05 + .1050E-05 + .8678E-06 + .6703E-06 + .4553E-06 + .3093E-06 + .2011E-06 + .1281E-06 + .8160E-07 + .5351E-07 + .4897E-07 + .4481E-07 + .3618E-07 + .2600E-07 + .1869E-07 + .1648E-07 + .1197E-05 + .1336E-05 + .1491E-05 + .1658E-05 + .1839E-05 + .2042E-05 + .2279E-05 + .2543E-05 + .2846E-05 + .3180E-05 + .3537E-05 + .3934E-05 + .4369E-05 + .4851E-05 + .5216E-05 + .5505E-05 + .5742E-05 + .5988E-05 + .5945E-05 + .5882E-05 + .5820E-05 + .5758E-05 + .5688E-05 + .5626E-05 + .5565E-05 + .5504E-05 + .5444E-05 + .5362E-05 + .5260E-05 + .5160E-05 + .5061E-05 + .4922E-05 + .4787E-05 + .4515E-05 + .4259E-05 + .4005E-05 + .3730E-05 + .3381E-05 + .3052E-05 + .2707E-05 + .2329E-05 + .1926E-05 + .1593E-05 + .1317E-05 + .1060E-05 + .8755E-06 + .6763E-06 + .4594E-06 + .3120E-06 + .2029E-06 + .1292E-06 + .8233E-07 + .5399E-07 + .4940E-07 + .4521E-07 + .3650E-07 + .2624E-07 + .1886E-07 + .1662E-07 + .1227E-05 + .1369E-05 + .1527E-05 + .1703E-05 + .1897E-05 + .2111E-05 + .2356E-05 + .2626E-05 + .2930E-05 + .3261E-05 + .3614E-05 + .4003E-05 + .4419E-05 + .4879E-05 + .5220E-05 + .5459E-05 + .5666E-05 + .5881E-05 + .5884E-05 + .5845E-05 + .5805E-05 + .5766E-05 + .5707E-05 + .5640E-05 + .5573E-05 + .5507E-05 + .5442E-05 + .5363E-05 + .5272E-05 + .5182E-05 + .5094E-05 + .4912E-05 + .4737E-05 + .4480E-05 + .4237E-05 + .3981E-05 + .3700E-05 + .3380E-05 + .3058E-05 + .2717E-05 + .2299E-05 + .1921E-05 + .1605E-05 + .1341E-05 + .1079E-05 + .8915E-06 + .6886E-06 + .4677E-06 + .3177E-06 + .2066E-06 + .1316E-06 + .8383E-07 + .5497E-07 + .5030E-07 + .4603E-07 + .3716E-07 + .2671E-07 + .1920E-07 + .1693E-07 + .1253E-05 + .1398E-05 + .1561E-05 + .1745E-05 + .1952E-05 + .2177E-05 + .2429E-05 + .2704E-05 + .3009E-05 + .3336E-05 + .3683E-05 + .4063E-05 + .4460E-05 + .4895E-05 + .5210E-05 + .5400E-05 + .5578E-05 + .5762E-05 + .5811E-05 + .5794E-05 + .5777E-05 + .5760E-05 + .5712E-05 + .5639E-05 + .5567E-05 + .5496E-05 + .5426E-05 + .5351E-05 + .5271E-05 + .5191E-05 + .5114E-05 + .4890E-05 + .4676E-05 + .4434E-05 + .4204E-05 + .3947E-05 + .3661E-05 + .3370E-05 + .3056E-05 + .2720E-05 + .2263E-05 + .1910E-05 + .1613E-05 + .1362E-05 + .1096E-05 + .9053E-06 + .6993E-06 + .4750E-06 + .3226E-06 + .2098E-06 + .1336E-06 + .8513E-07 + .5583E-07 + .5109E-07 + .4675E-07 + .3774E-07 + .2713E-07 + .1950E-07 + .1719E-07 + .7804E-06 + .9282E-06 + .1108E-05 + .1314E-05 + .1504E-05 + .1707E-05 + .1893E-05 + .2097E-05 + .2320E-05 + .2570E-05 + .2880E-05 + .3251E-05 + .3645E-05 + .3961E-05 + .4304E-05 + .4446E-05 + .4592E-05 + .4656E-05 + .4619E-05 + .4583E-05 + .4547E-05 + .4511E-05 + .4470E-05 + .4424E-05 + .4378E-05 + .4336E-05 + .4297E-05 + .4258E-05 + .4163E-05 + .4013E-05 + .3855E-05 + .3683E-05 + .3518E-05 + .3332E-05 + .2902E-05 + .2493E-05 + .2141E-05 + .1759E-05 + .1438E-05 + .1176E-05 + .9504E-06 + .8596E-06 + .7775E-06 + .7032E-06 + .4695E-06 + .3290E-06 + .2293E-06 + .1581E-06 + .1090E-06 + .7684E-07 + .5476E-07 + .3903E-07 + .2851E-07 + .2764E-07 + .2679E-07 + .2479E-07 + .2196E-07 + .1946E-07 + .1858E-07 + .7959E-06 + .9566E-06 + .1143E-05 + .1342E-05 + .1541E-05 + .1753E-05 + .1952E-05 + .2169E-05 + .2402E-05 + .2669E-05 + .3013E-05 + .3430E-05 + .3899E-05 + .4188E-05 + .4498E-05 + .4675E-05 + .4859E-05 + .4941E-05 + .4881E-05 + .4822E-05 + .4763E-05 + .4705E-05 + .4644E-05 + .4581E-05 + .4518E-05 + .4462E-05 + .4414E-05 + .4367E-05 + .4282E-05 + .4162E-05 + .4011E-05 + .3815E-05 + .3629E-05 + .3434E-05 + .3031E-05 + .2592E-05 + .2217E-05 + .1822E-05 + .1482E-05 + .1205E-05 + .9700E-06 + .8761E-06 + .7914E-06 + .7148E-06 + .4772E-06 + .3345E-06 + .2331E-06 + .1607E-06 + .1108E-06 + .7810E-07 + .5567E-07 + .3967E-07 + .2898E-07 + .2809E-07 + .2723E-07 + .2520E-07 + .2232E-07 + .1978E-07 + .1888E-07 + .8110E-06 + .9851E-06 + .1177E-05 + .1370E-05 + .1578E-05 + .1798E-05 + .2011E-05 + .2241E-05 + .2486E-05 + .2770E-05 + .3151E-05 + .3617E-05 + .4168E-05 + .4425E-05 + .4698E-05 + .4913E-05 + .5139E-05 + .5240E-05 + .5154E-05 + .5070E-05 + .4986E-05 + .4905E-05 + .4822E-05 + .4740E-05 + .4659E-05 + .4588E-05 + .4531E-05 + .4475E-05 + .4403E-05 + .4313E-05 + .4169E-05 + .3950E-05 + .3742E-05 + .3536E-05 + .3163E-05 + .2693E-05 + .2293E-05 + .1885E-05 + .1526E-05 + .1235E-05 + .9893E-06 + .8923E-06 + .8049E-06 + .7260E-06 + .4847E-06 + .3397E-06 + .2367E-06 + .1632E-06 + .1125E-06 + .7933E-07 + .5654E-07 + .4030E-07 + .2943E-07 + .2853E-07 + .2766E-07 + .2559E-07 + .2267E-07 + .2009E-07 + .1918E-07 + .8265E-06 + .1012E-05 + .1209E-05 + .1396E-05 + .1612E-05 + .1840E-05 + .2064E-05 + .2307E-05 + .2564E-05 + .2866E-05 + .3281E-05 + .3794E-05 + .4420E-05 + .4654E-05 + .4901E-05 + .5149E-05 + .5402E-05 + .5519E-05 + .5414E-05 + .5309E-05 + .5207E-05 + .5107E-05 + .5004E-05 + .4900E-05 + .4799E-05 + .4711E-05 + .4642E-05 + .4579E-05 + .4516E-05 + .4454E-05 + .4321E-05 + .4088E-05 + .3858E-05 + .3639E-05 + .3295E-05 + .2797E-05 + .2372E-05 + .1953E-05 + .1573E-05 + .1267E-05 + .1010E-05 + .9094E-06 + .8185E-06 + .7366E-06 + .4918E-06 + .3447E-06 + .2402E-06 + .1656E-06 + .1141E-06 + .8049E-07 + .5737E-07 + .4088E-07 + .2986E-07 + .2895E-07 + .2807E-07 + .2597E-07 + .2300E-07 + .2038E-07 + .1946E-07 + .8458E-06 + .1030E-05 + .1224E-05 + .1413E-05 + .1632E-05 + .1863E-05 + .2091E-05 + .2341E-05 + .2613E-05 + .2933E-05 + .3350E-05 + .3893E-05 + .4518E-05 + .4800E-05 + .5099E-05 + .5339E-05 + .5536E-05 + .5633E-05 + .5556E-05 + .5471E-05 + .5387E-05 + .5304E-05 + .5192E-05 + .5063E-05 + .4937E-05 + .4822E-05 + .4725E-05 + .4661E-05 + .4599E-05 + .4537E-05 + .4423E-05 + .4237E-05 + .3991E-05 + .3745E-05 + .3413E-05 + .2908E-05 + .2462E-05 + .2037E-05 + .1634E-05 + .1311E-05 + .1043E-05 + .9326E-06 + .8341E-06 + .7460E-06 + .4980E-06 + .3490E-06 + .2432E-06 + .1677E-06 + .1156E-06 + .8151E-07 + .5809E-07 + .4140E-07 + .3024E-07 + .2932E-07 + .2842E-07 + .2630E-07 + .2330E-07 + .2064E-07 + .1971E-07 + .8701E-06 + .1054E-05 + .1246E-05 + .1439E-05 + .1661E-05 + .1897E-05 + .2128E-05 + .2387E-05 + .2677E-05 + .3016E-05 + .3438E-05 + .4015E-05 + .4641E-05 + .4975E-05 + .5333E-05 + .5565E-05 + .5702E-05 + .5779E-05 + .5732E-05 + .5666E-05 + .5602E-05 + .5538E-05 + .5416E-05 + .5258E-05 + .5104E-05 + .4960E-05 + .4834E-05 + .4770E-05 + .4707E-05 + .4644E-05 + .4551E-05 + .4414E-05 + .4151E-05 + .3873E-05 + .3554E-05 + .3038E-05 + .2568E-05 + .2137E-05 + .1707E-05 + .1363E-05 + .1082E-05 + .9520E-06 + .8378E-06 + .7373E-06 + .4931E-06 + .3458E-06 + .2412E-06 + .1663E-06 + .1147E-06 + .8128E-07 + .5833E-07 + .4186E-07 + .3077E-07 + .2983E-07 + .2892E-07 + .2678E-07 + .2378E-07 + .2112E-07 + .2018E-07 + .9024E-06 + .1087E-05 + .1279E-05 + .1477E-05 + .1705E-05 + .1947E-05 + .2184E-05 + .2455E-05 + .2766E-05 + .3127E-05 + .3557E-05 + .4176E-05 + .4807E-05 + .5200E-05 + .5625E-05 + .5848E-05 + .5922E-05 + .5977E-05 + .5962E-05 + .5917E-05 + .5874E-05 + .5830E-05 + .5696E-05 + .5505E-05 + .5321E-05 + .5145E-05 + .4986E-05 + .4921E-05 + .4857E-05 + .4794E-05 + .4722E-05 + .4637E-05 + .4352E-05 + .4040E-05 + .3731E-05 + .3201E-05 + .2701E-05 + .2259E-05 + .1797E-05 + .1430E-05 + .1131E-05 + .9641E-06 + .8215E-06 + .6999E-06 + .4702E-06 + .3304E-06 + .2308E-06 + .1594E-06 + .1101E-06 + .7898E-07 + .5771E-07 + .4217E-07 + .3152E-07 + .3056E-07 + .2963E-07 + .2753E-07 + .2460E-07 + .2197E-07 + .2105E-07 + .9259E-06 + .1118E-05 + .1315E-05 + .1520E-05 + .1750E-05 + .1996E-05 + .2243E-05 + .2527E-05 + .2854E-05 + .3234E-05 + .3675E-05 + .4320E-05 + .4963E-05 + .5400E-05 + .5876E-05 + .6088E-05 + .6152E-05 + .6217E-05 + .6227E-05 + .6179E-05 + .6131E-05 + .6083E-05 + .5945E-05 + .5746E-05 + .5541E-05 + .5343E-05 + .5161E-05 + .5089E-05 + .5021E-05 + .4954E-05 + .4888E-05 + .4823E-05 + .4560E-05 + .4223E-05 + .3901E-05 + .3369E-05 + .2835E-05 + .2373E-05 + .1884E-05 + .1492E-05 + .1177E-05 + .9732E-06 + .8046E-06 + .6652E-06 + .4490E-06 + .3160E-06 + .2211E-06 + .1529E-06 + .1057E-06 + .7683E-07 + .5717E-07 + .4254E-07 + .3234E-07 + .3135E-07 + .3039E-07 + .2833E-07 + .2546E-07 + .2289E-07 + .2197E-07 + .9458E-06 + .1150E-05 + .1359E-05 + .1574E-05 + .1803E-05 + .2052E-05 + .2313E-05 + .2611E-05 + .2953E-05 + .3348E-05 + .3805E-05 + .4465E-05 + .5127E-05 + .5601E-05 + .6118E-05 + .6316E-05 + .6414E-05 + .6512E-05 + .6545E-05 + .6471E-05 + .6398E-05 + .6326E-05 + .6192E-05 + .6003E-05 + .5783E-05 + .5570E-05 + .5373E-05 + .5286E-05 + .5213E-05 + .5140E-05 + .5068E-05 + .4997E-05 + .4789E-05 + .4436E-05 + .4080E-05 + .3555E-05 + .2980E-05 + .2489E-05 + .1974E-05 + .1556E-05 + .1224E-05 + .9833E-06 + .7900E-06 + .6347E-06 + .4303E-06 + .3035E-06 + .2127E-06 + .1472E-06 + .1019E-06 + .7503E-07 + .5686E-07 + .4309E-07 + .3330E-07 + .3229E-07 + .3130E-07 + .2927E-07 + .2647E-07 + .2393E-07 + .2303E-07 + .9580E-06 + .1173E-05 + .1392E-05 + .1616E-05 + .1841E-05 + .2091E-05 + .2364E-05 + .2675E-05 + .3029E-05 + .3437E-05 + .3906E-05 + .4577E-05 + .5253E-05 + .5760E-05 + .6315E-05 + .6497E-05 + .6629E-05 + .6764E-05 + .6821E-05 + .6721E-05 + .6621E-05 + .6523E-05 + .6395E-05 + .6219E-05 + .5985E-05 + .5759E-05 + .5545E-05 + .5445E-05 + .5366E-05 + .5287E-05 + .5210E-05 + .5134E-05 + .4988E-05 + .4619E-05 + .4231E-05 + .3720E-05 + .3106E-05 + .2589E-05 + .2051E-05 + .1610E-05 + .1262E-05 + .9851E-06 + .7691E-06 + .6005E-06 + .4090E-06 + .2890E-06 + .2029E-06 + .1406E-06 + .9747E-07 + .7266E-07 + .5607E-07 + .4327E-07 + .3400E-07 + .3297E-07 + .3197E-07 + .2999E-07 + .2728E-07 + .2482E-07 + .2394E-07 + .9625E-06 + .1187E-05 + .1415E-05 + .1645E-05 + .1865E-05 + .2114E-05 + .2397E-05 + .2718E-05 + .3082E-05 + .3499E-05 + .3977E-05 + .4654E-05 + .5337E-05 + .5875E-05 + .6466E-05 + .6629E-05 + .6797E-05 + .6968E-05 + .7051E-05 + .6923E-05 + .6796E-05 + .6672E-05 + .6550E-05 + .6390E-05 + .6143E-05 + .5905E-05 + .5677E-05 + .5563E-05 + .5479E-05 + .5395E-05 + .5313E-05 + .5232E-05 + .5152E-05 + .4772E-05 + .4352E-05 + .3861E-05 + .3211E-05 + .2671E-05 + .2113E-05 + .1651E-05 + .1290E-05 + .9789E-06 + .7427E-06 + .5634E-06 + .3856E-06 + .2729E-06 + .1919E-06 + .1332E-06 + .9243E-07 + .6979E-07 + .5484E-07 + .4309E-07 + .3444E-07 + .3339E-07 + .3238E-07 + .3047E-07 + .2789E-07 + .2552E-07 + .2468E-07 + .9785E-06 + .1204E-05 + .1434E-05 + .1670E-05 + .1901E-05 + .2153E-05 + .2425E-05 + .2736E-05 + .3090E-05 + .3501E-05 + .3971E-05 + .4637E-05 + .5302E-05 + .5879E-05 + .6471E-05 + .6751E-05 + .6995E-05 + .7197E-05 + .7280E-05 + .7181E-05 + .7061E-05 + .6905E-05 + .6751E-05 + .6576E-05 + .6346E-05 + .6118E-05 + .5904E-05 + .5784E-05 + .5665E-05 + .5573E-05 + .5494E-05 + .5418E-05 + .5277E-05 + .4883E-05 + .4425E-05 + .3890E-05 + .3249E-05 + .2712E-05 + .2169E-05 + .1694E-05 + .1320E-05 + .9683E-06 + .7100E-06 + .5207E-06 + .3579E-06 + .2538E-06 + .1788E-06 + .1242E-06 + .8633E-07 + .6601E-07 + .5282E-07 + .4227E-07 + .3435E-07 + .3331E-07 + .3230E-07 + .3049E-07 + .2808E-07 + .2585E-07 + .2505E-07 + .9874E-06 + .1212E-05 + .1444E-05 + .1683E-05 + .1923E-05 + .2176E-05 + .2434E-05 + .2734E-05 + .3076E-05 + .3478E-05 + .3935E-05 + .4586E-05 + .5228E-05 + .5840E-05 + .6427E-05 + .6825E-05 + .7146E-05 + .7380E-05 + .7461E-05 + .7395E-05 + .7282E-05 + .7093E-05 + .6906E-05 + .6716E-05 + .6508E-05 + .6291E-05 + .6095E-05 + .5969E-05 + .5814E-05 + .5714E-05 + .5640E-05 + .5568E-05 + .5364E-05 + .4959E-05 + .4466E-05 + .3891E-05 + .3264E-05 + .2734E-05 + .2209E-05 + .1726E-05 + .1341E-05 + .9507E-06 + .6739E-06 + .4776E-06 + .3298E-06 + .2344E-06 + .1653E-06 + .1150E-06 + .8003E-07 + .6198E-07 + .5051E-07 + .4116E-07 + .3401E-07 + .3298E-07 + .3198E-07 + .3029E-07 + .2806E-07 + .2599E-07 + .2524E-07 + .1005E-05 + .1228E-05 + .1458E-05 + .1696E-05 + .1940E-05 + .2188E-05 + .2435E-05 + .2723E-05 + .3054E-05 + .3442E-05 + .3897E-05 + .4527E-05 + .5147E-05 + .5781E-05 + .6368E-05 + .6859E-05 + .7244E-05 + .7499E-05 + .7582E-05 + .7539E-05 + .7426E-05 + .7211E-05 + .6989E-05 + .6781E-05 + .6589E-05 + .6386E-05 + .6213E-05 + .6089E-05 + .5923E-05 + .5818E-05 + .5745E-05 + .5668E-05 + .5417E-05 + .5006E-05 + .4491E-05 + .3885E-05 + .3264E-05 + .2731E-05 + .2220E-05 + .1736E-05 + .1341E-05 + .9240E-06 + .6369E-06 + .4389E-06 + .3045E-06 + .2168E-06 + .1532E-06 + .1067E-06 + .7433E-07 + .5831E-07 + .4838E-07 + .4015E-07 + .3373E-07 + .3272E-07 + .3173E-07 + .3014E-07 + .2809E-07 + .2618E-07 + .2549E-07 + .1054E-05 + .1274E-05 + .1498E-05 + .1725E-05 + .1961E-05 + .2197E-05 + .2437E-05 + .2715E-05 + .3042E-05 + .3411E-05 + .3888E-05 + .4490E-05 + .5096E-05 + .5729E-05 + .6331E-05 + .6867E-05 + .7283E-05 + .7543E-05 + .7633E-05 + .7588E-05 + .7460E-05 + .7234E-05 + .6970E-05 + .6738E-05 + .6545E-05 + .6358E-05 + .6218E-05 + .6111E-05 + .5989E-05 + .5888E-05 + .5810E-05 + .5699E-05 + .5441E-05 + .5029E-05 + .4521E-05 + .3900E-05 + .3262E-05 + .2700E-05 + .2185E-05 + .1713E-05 + .1305E-05 + .8863E-06 + .6020E-06 + .4089E-06 + .2850E-06 + .2032E-06 + .1438E-06 + .1003E-06 + .6999E-07 + .5560E-07 + .4698E-07 + .3970E-07 + .3392E-07 + .3290E-07 + .3191E-07 + .3041E-07 + .2851E-07 + .2673E-07 + .2608E-07 + .1126E-05 + .1338E-05 + .1553E-05 + .1770E-05 + .1997E-05 + .2222E-05 + .2460E-05 + .2734E-05 + .3057E-05 + .3415E-05 + .3899E-05 + .4464E-05 + .5051E-05 + .5674E-05 + .6287E-05 + .6857E-05 + .7295E-05 + .7563E-05 + .7673E-05 + .7649E-05 + .7538E-05 + .7331E-05 + .7069E-05 + .6853E-05 + .6676E-05 + .6505E-05 + .6378E-05 + .6277E-05 + .6166E-05 + .6052E-05 + .5945E-05 + .5778E-05 + .5482E-05 + .5044E-05 + .4507E-05 + .3856E-05 + .3198E-05 + .2613E-05 + .2093E-05 + .1626E-05 + .1213E-05 + .8233E-06 + .5590E-06 + .3795E-06 + .2658E-06 + .1899E-06 + .1346E-06 + .9400E-07 + .6565E-07 + .5282E-07 + .4545E-07 + .3911E-07 + .3398E-07 + .3296E-07 + .3197E-07 + .3056E-07 + .2883E-07 + .2719E-07 + .2659E-07 + .1226E-05 + .1422E-05 + .1624E-05 + .1832E-05 + .2049E-05 + .2264E-05 + .2504E-05 + .2779E-05 + .3099E-05 + .3452E-05 + .3930E-05 + .4452E-05 + .5015E-05 + .5621E-05 + .6243E-05 + .6836E-05 + .7289E-05 + .7568E-05 + .7710E-05 + .7730E-05 + .7667E-05 + .7506E-05 + .7287E-05 + .7127E-05 + .6982E-05 + .6828E-05 + .6698E-05 + .6591E-05 + .6459E-05 + .6313E-05 + .6154E-05 + .5908E-05 + .5541E-05 + .5055E-05 + .4457E-05 + .3765E-05 + .3084E-05 + .2483E-05 + .1959E-05 + .1489E-05 + .1081E-05 + .7433E-06 + .5110E-06 + .3513E-06 + .2472E-06 + .1769E-06 + .1256E-06 + .8784E-07 + .6142E-07 + .5005E-07 + .4386E-07 + .3843E-07 + .3395E-07 + .3293E-07 + .3194E-07 + .3064E-07 + .2907E-07 + .2759E-07 + .2705E-07 + .1302E-05 + .1487E-05 + .1675E-05 + .1872E-05 + .2074E-05 + .2281E-05 + .2516E-05 + .2787E-05 + .3095E-05 + .3448E-05 + .3911E-05 + .4393E-05 + .4936E-05 + .5527E-05 + .6143E-05 + .6739E-05 + .7223E-05 + .7550E-05 + .7749E-05 + .7835E-05 + .7815E-05 + .7707E-05 + .7541E-05 + .7427E-05 + .7310E-05 + .7184E-05 + .7046E-05 + .6922E-05 + .6756E-05 + .6564E-05 + .6344E-05 + .6055E-05 + .5629E-05 + .5073E-05 + .4402E-05 + .3667E-05 + .2961E-05 + .2342E-05 + .1808E-05 + .1332E-05 + .9404E-06 + .6553E-06 + .4567E-06 + .3183E-06 + .2252E-06 + .1621E-06 + .1158E-06 + .8174E-07 + .5768E-07 + .4769E-07 + .4252E-07 + .3790E-07 + .3402E-07 + .3298E-07 + .3198E-07 + .3062E-07 + .2910E-07 + .2759E-07 + .2696E-07 + .1373E-05 + .1546E-05 + .1721E-05 + .1904E-05 + .2091E-05 + .2291E-05 + .2519E-05 + .2785E-05 + .3076E-05 + .3432E-05 + .3878E-05 + .4323E-05 + .4847E-05 + .5427E-05 + .6033E-05 + .6624E-05 + .7145E-05 + .7533E-05 + .7798E-05 + .7960E-05 + .7982E-05 + .7931E-05 + .7824E-05 + .7756E-05 + .7665E-05 + .7573E-05 + .7426E-05 + .7278E-05 + .7073E-05 + .6824E-05 + .6537E-05 + .6220E-05 + .5735E-05 + .5100E-05 + .4350E-05 + .3573E-05 + .2841E-05 + .2206E-05 + .1663E-05 + .1182E-05 + .8115E-06 + .5626E-06 + .3900E-06 + .2704E-06 + .1931E-06 + .1410E-06 + .1028E-06 + .7465E-07 + .5423E-07 + .4571E-07 + .4136E-07 + .3742E-07 + .3403E-07 + .3295E-07 + .3189E-07 + .3014E-07 + .2831E-07 + .2635E-07 + .2533E-07 + .1433E-05 + .1597E-05 + .1766E-05 + .1942E-05 + .2123E-05 + .2322E-05 + .2544E-05 + .2804E-05 + .3075E-05 + .3434E-05 + .3839E-05 + .4266E-05 + .4748E-05 + .5309E-05 + .5899E-05 + .6500E-05 + .7058E-05 + .7502E-05 + .7815E-05 + .8033E-05 + .8104E-05 + .8103E-05 + .8072E-05 + .8020E-05 + .7958E-05 + .7864E-05 + .7723E-05 + .7591E-05 + .7379E-05 + .7133E-05 + .6803E-05 + .6393E-05 + .5850E-05 + .5129E-05 + .4309E-05 + .3480E-05 + .2731E-05 + .2088E-05 + .1528E-05 + .1040E-05 + .6824E-06 + .4742E-06 + .3296E-06 + .2290E-06 + .1651E-06 + .1223E-06 + .9086E-07 + .6795E-07 + .5082E-07 + .4368E-07 + .4010E-07 + .3682E-07 + .3394E-07 + .3281E-07 + .3171E-07 + .2957E-07 + .2746E-07 + .2508E-07 + .2373E-07 + .1486E-05 + .1643E-05 + .1805E-05 + .1974E-05 + .2149E-05 + .2345E-05 + .2561E-05 + .2813E-05 + .3065E-05 + .3421E-05 + .3786E-05 + .4197E-05 + .4640E-05 + .5182E-05 + .5756E-05 + .6364E-05 + .6948E-05 + .7443E-05 + .7805E-05 + .8075E-05 + .8199E-05 + .8253E-05 + .8296E-05 + .8270E-05 + .8243E-05 + .8148E-05 + .8019E-05 + .7905E-05 + .7684E-05 + .7439E-05 + .7065E-05 + .6557E-05 + .5953E-05 + .5148E-05 + .4260E-05 + .3383E-05 + .2621E-05 + .1974E-05 + .1401E-05 + .9124E-06 + .5726E-06 + .3988E-06 + .2778E-06 + .1935E-06 + .1407E-06 + .1058E-06 + .8014E-07 + .6170E-07 + .4751E-07 + .4163E-07 + .3879E-07 + .3614E-07 + .3377E-07 + .3258E-07 + .3144E-07 + .2893E-07 + .2657E-07 + .2382E-07 + .2217E-07 + .1513E-05 + .1667E-05 + .1826E-05 + .1984E-05 + .2150E-05 + .2337E-05 + .2544E-05 + .2787E-05 + .3027E-05 + .3349E-05 + .3701E-05 + .4092E-05 + .4522E-05 + .5055E-05 + .5615E-05 + .6213E-05 + .6784E-05 + .7307E-05 + .7728E-05 + .8033E-05 + .8237E-05 + .8366E-05 + .8450E-05 + .8506E-05 + .8542E-05 + .8474E-05 + .8368E-05 + .8270E-05 + .8015E-05 + .7721E-05 + .7292E-05 + .6715E-05 + .6035E-05 + .5158E-05 + .4204E-05 + .3289E-05 + .2515E-05 + .1869E-05 + .1287E-05 + .8018E-06 + .4840E-06 + .3368E-06 + .2343E-06 + .1630E-06 + .1197E-06 + .9122E-07 + .7049E-07 + .5587E-07 + .4428E-07 + .3956E-07 + .3741E-07 + .3537E-07 + .3350E-07 + .3227E-07 + .3109E-07 + .2823E-07 + .2564E-07 + .2256E-07 + .2065E-07 + .1543E-05 + .1695E-05 + .1851E-05 + .2000E-05 + .2158E-05 + .2338E-05 + .2537E-05 + .2770E-05 + .2996E-05 + .3294E-05 + .3634E-05 + .4009E-05 + .4433E-05 + .4944E-05 + .5485E-05 + .6071E-05 + .6647E-05 + .7190E-05 + .7648E-05 + .7980E-05 + .8250E-05 + .8438E-05 + .8578E-05 + .8714E-05 + .8815E-05 + .8794E-05 + .8732E-05 + .8655E-05 + .8357E-05 + .8016E-05 + .7536E-05 + .6882E-05 + .6111E-05 + .5160E-05 + .4144E-05 + .3194E-05 + .2409E-05 + .1762E-05 + .1180E-05 + .7082E-06 + .4111E-06 + .2853E-06 + .1979E-06 + .1373E-06 + .1017E-06 + .7870E-07 + .6200E-07 + .5059E-07 + .4128E-07 + .3760E-07 + .3608E-07 + .3462E-07 + .3323E-07 + .3197E-07 + .3075E-07 + .2755E-07 + .2474E-07 + .2136E-07 + .1924E-07 + .1581E-05 + .1730E-05 + .1883E-05 + .2026E-05 + .2179E-05 + .2354E-05 + .2544E-05 + .2766E-05 + .2975E-05 + .3264E-05 + .3595E-05 + .3959E-05 + .4391E-05 + .4855E-05 + .5369E-05 + .5936E-05 + .6551E-05 + .7104E-05 + .7561E-05 + .7905E-05 + .8212E-05 + .8428E-05 + .8649E-05 + .8858E-05 + .9023E-05 + .9084E-05 + .9108E-05 + .9060E-05 + .8706E-05 + .8320E-05 + .7804E-05 + .7058E-05 + .6172E-05 + .5141E-05 + .4074E-05 + .3096E-05 + .2299E-05 + .1647E-05 + .1078E-05 + .6311E-06 + .3521E-06 + .2429E-06 + .1676E-06 + .1157E-06 + .8648E-07 + .6786E-07 + .5451E-07 + .4579E-07 + .3847E-07 + .3572E-07 + .3479E-07 + .3388E-07 + .3296E-07 + .3165E-07 + .3040E-07 + .2688E-07 + .2386E-07 + .2022E-07 + .1792E-07 + .1608E-05 + .1753E-05 + .1900E-05 + .2037E-05 + .2187E-05 + .2356E-05 + .2540E-05 + .2755E-05 + .2958E-05 + .3235E-05 + .3533E-05 + .3885E-05 + .4310E-05 + .4747E-05 + .5247E-05 + .5798E-05 + .6416E-05 + .6971E-05 + .7461E-05 + .7834E-05 + .8157E-05 + .8411E-05 + .8693E-05 + .8978E-05 + .9209E-05 + .9332E-05 + .9404E-05 + .9382E-05 + .9002E-05 + .8603E-05 + .8012E-05 + .7192E-05 + .6218E-05 + .5131E-05 + .4033E-05 + .3030E-05 + .2212E-05 + .1553E-05 + .9965E-06 + .5685E-06 + .3064E-06 + .2091E-06 + .1427E-06 + .9744E-07 + .7352E-07 + .5853E-07 + .4794E-07 + .4146E-07 + .3586E-07 + .3395E-07 + .3355E-07 + .3316E-07 + .3269E-07 + .3134E-07 + .3006E-07 + .2622E-07 + .2302E-07 + .1915E-07 + .1669E-07 + .1627E-05 + .1765E-05 + .1904E-05 + .2037E-05 + .2184E-05 + .2347E-05 + .2526E-05 + .2736E-05 + .2943E-05 + .3204E-05 + .3453E-05 + .3790E-05 + .4197E-05 + .4622E-05 + .5119E-05 + .5655E-05 + .6251E-05 + .6800E-05 + .7348E-05 + .7763E-05 + .8084E-05 + .8384E-05 + .8711E-05 + .9075E-05 + .9372E-05 + .9540E-05 + .9630E-05 + .9629E-05 + .9249E-05 + .8864E-05 + .8168E-05 + .7286E-05 + .6248E-05 + .5127E-05 + .4013E-05 + .2986E-05 + .2139E-05 + .1473E-05 + .9289E-06 + .5162E-06 + .2698E-06 + .1814E-06 + .1220E-06 + .8205E-07 + .6248E-07 + .5047E-07 + .4215E-07 + .3753E-07 + .3341E-07 + .3225E-07 + .3235E-07 + .3244E-07 + .3241E-07 + .3103E-07 + .2971E-07 + .2558E-07 + .2220E-07 + .1813E-07 + .1554E-07 + .1627E-05 + .1764E-05 + .1901E-05 + .2033E-05 + .2178E-05 + .2340E-05 + .2518E-05 + .2725E-05 + .2932E-05 + .3190E-05 + .3424E-05 + .3746E-05 + .4125E-05 + .4524E-05 + .5013E-05 + .5542E-05 + .6109E-05 + .6644E-05 + .7184E-05 + .7660E-05 + .8047E-05 + .8347E-05 + .8682E-05 + .9102E-05 + .9455E-05 + .9701E-05 + .9874E-05 + .9921E-05 + .9534E-05 + .9077E-05 + .8308E-05 + .7330E-05 + .6225E-05 + .5097E-05 + .3995E-05 + .2962E-05 + .2099E-05 + .1425E-05 + .8765E-06 + .4701E-06 + .2415E-06 + .1591E-06 + .1048E-06 + .6902E-07 + .5305E-07 + .4346E-07 + .3701E-07 + .3393E-07 + .3110E-07 + .3060E-07 + .3115E-07 + .3170E-07 + .3211E-07 + .3069E-07 + .2933E-07 + .2492E-07 + .2139E-07 + .1714E-07 + .1446E-07 + .1619E-05 + .1754E-05 + .1891E-05 + .2023E-05 + .2167E-05 + .2328E-05 + .2506E-05 + .2710E-05 + .2917E-05 + .3173E-05 + .3402E-05 + .3707E-05 + .4055E-05 + .4425E-05 + .4903E-05 + .5427E-05 + .5962E-05 + .6479E-05 + .6993E-05 + .7531E-05 + .8002E-05 + .8290E-05 + .8619E-05 + .9088E-05 + .9491E-05 + .9827E-05 + .1011E-04 + .1021E-04 + .9815E-05 + .9257E-05 + .8426E-05 + .7342E-05 + .6172E-05 + .5049E-05 + .3970E-05 + .2937E-05 + .2065E-05 + .1382E-05 + .8282E-06 + .4276E-06 + .2168E-06 + .1459E-06 + .9816E-07 + .6606E-07 + .5121E-07 + .4252E-07 + .3670E-07 + .3411E-07 + .3171E-07 + .3126E-07 + .3169E-07 + .3213E-07 + .3241E-07 + .3089E-07 + .2944E-07 + .2526E-07 + .2144E-07 + .1686E-07 + .1430E-07 + .1616E-05 + .1748E-05 + .1885E-05 + .2015E-05 + .2156E-05 + .2311E-05 + .2482E-05 + .2683E-05 + .2876E-05 + .3128E-05 + .3374E-05 + .3670E-05 + .3999E-05 + .4373E-05 + .4822E-05 + .5309E-05 + .5826E-05 + .6340E-05 + .6869E-05 + .7412E-05 + .7884E-05 + .8280E-05 + .8653E-05 + .9119E-05 + .9546E-05 + .9908E-05 + .1020E-04 + .1034E-04 + .9978E-05 + .9391E-05 + .8502E-05 + .7354E-05 + .6159E-05 + .5016E-05 + .3952E-05 + .2938E-05 + .2067E-05 + .1378E-05 + .8112E-06 + .4029E-06 + .1885E-06 + .1320E-06 + .9245E-07 + .6475E-07 + .5063E-07 + .4259E-07 + .3723E-07 + .3501E-07 + .3293E-07 + .3244E-07 + .3267E-07 + .3291E-07 + .3299E-07 + .3134E-07 + .2978E-07 + .2590E-07 + .2174E-07 + .1677E-07 + .1435E-07 + .1616E-05 + .1746E-05 + .1881E-05 + .2009E-05 + .2147E-05 + .2297E-05 + .2462E-05 + .2660E-05 + .2844E-05 + .3095E-05 + .3354E-05 + .3641E-05 + .3954E-05 + .4333E-05 + .4756E-05 + .5211E-05 + .5712E-05 + .6221E-05 + .6764E-05 + .7315E-05 + .7787E-05 + .8277E-05 + .8700E-05 + .9159E-05 + .9601E-05 + .9980E-05 + .1027E-04 + .1043E-04 + .1011E-04 + .9510E-05 + .8584E-05 + .7377E-05 + .6151E-05 + .4988E-05 + .3933E-05 + .2935E-05 + .2072E-05 + .1381E-05 + .8029E-06 + .3862E-06 + .1689E-06 + .1219E-06 + .8798E-07 + .6350E-07 + .5007E-07 + .4268E-07 + .3778E-07 + .3595E-07 + .3421E-07 + .3368E-07 + .3370E-07 + .3372E-07 + .3359E-07 + .3181E-07 + .3013E-07 + .2656E-07 + .2204E-07 + .1668E-07 + .1440E-07 + .1628E-05 + .1754E-05 + .1886E-05 + .2008E-05 + .2143E-05 + .2290E-05 + .2456E-05 + .2650E-05 + .2838E-05 + .3108E-05 + .3358E-05 + .3644E-05 + .3940E-05 + .4324E-05 + .4741E-05 + .5188E-05 + .5673E-05 + .6167E-05 + .6712E-05 + .7289E-05 + .7762E-05 + .8284E-05 + .8773E-05 + .9209E-05 + .9638E-05 + .9993E-05 + .1024E-04 + .1041E-04 + .1011E-04 + .9540E-05 + .8674E-05 + .7434E-05 + .6144E-05 + .4962E-05 + .3904E-05 + .2903E-05 + .2079E-05 + .1406E-05 + .8278E-06 + .3965E-06 + .1726E-06 + .1228E-06 + .8740E-07 + .6219E-07 + .4947E-07 + .4272E-07 + .3830E-07 + .3687E-07 + .3550E-07 + .3493E-07 + .3472E-07 + .3451E-07 + .3416E-07 + .3225E-07 + .3045E-07 + .2721E-07 + .2233E-07 + .1658E-07 + .1444E-07 + .1635E-05 + .1759E-05 + .1887E-05 + .2007E-05 + .2140E-05 + .2287E-05 + .2453E-05 + .2647E-05 + .2838E-05 + .3119E-05 + .3360E-05 + .3649E-05 + .3932E-05 + .4320E-05 + .4726E-05 + .5185E-05 + .5666E-05 + .6154E-05 + .6704E-05 + .7285E-05 + .7774E-05 + .8305E-05 + .8844E-05 + .9252E-05 + .9676E-05 + .1003E-04 + .1025E-04 + .1042E-04 + .1013E-04 + .9559E-05 + .8730E-05 + .7468E-05 + .6147E-05 + .4950E-05 + .3883E-05 + .2884E-05 + .2080E-05 + .1422E-05 + .8476E-06 + .4048E-06 + .1755E-06 + .1233E-06 + .8668E-07 + .6092E-07 + .4887E-07 + .4276E-07 + .3882E-07 + .3782E-07 + .3684E-07 + .3622E-07 + .3577E-07 + .3532E-07 + .3475E-07 + .3270E-07 + .3078E-07 + .2787E-07 + .2262E-07 + .1648E-07 + .1448E-07 + .1633E-05 + .1754E-05 + .1879E-05 + .1999E-05 + .2133E-05 + .2284E-05 + .2452E-05 + .2652E-05 + .2840E-05 + .3120E-05 + .3351E-05 + .3653E-05 + .3924E-05 + .4317E-05 + .4704E-05 + .5203E-05 + .5698E-05 + .6191E-05 + .6749E-05 + .7304E-05 + .7826E-05 + .8333E-05 + .8896E-05 + .9264E-05 + .9695E-05 + .1008E-04 + .1031E-04 + .1046E-04 + .1016E-04 + .9543E-05 + .8719E-05 + .7453E-05 + .6152E-05 + .4948E-05 + .3868E-05 + .2880E-05 + .2070E-05 + .1420E-05 + .8571E-06 + .4089E-06 + .1765E-06 + .1261E-06 + .9011E-07 + .6438E-07 + .5153E-07 + .4506E-07 + .4091E-07 + .3988E-07 + .3888E-07 + .3815E-07 + .3755E-07 + .3696E-07 + .3625E-07 + .3407E-07 + .3203E-07 + .2901E-07 + .2333E-07 + .1696E-07 + .1500E-07 + .1647E-05 + .1764E-05 + .1883E-05 + .2000E-05 + .2130E-05 + .2283E-05 + .2454E-05 + .2654E-05 + .2850E-05 + .3114E-05 + .3362E-05 + .3654E-05 + .3937E-05 + .4306E-05 + .4699E-05 + .5206E-05 + .5703E-05 + .6215E-05 + .6794E-05 + .7376E-05 + .7917E-05 + .8407E-05 + .8936E-05 + .9340E-05 + .9753E-05 + .1016E-04 + .1039E-04 + .1051E-04 + .1019E-04 + .9540E-05 + .8670E-05 + .7422E-05 + .6148E-05 + .4955E-05 + .3878E-05 + .2898E-05 + .2077E-05 + .1426E-05 + .8612E-06 + .4119E-06 + .1772E-06 + .1321E-06 + .9847E-07 + .7340E-07 + .5797E-07 + .4999E-07 + .4480E-07 + .4323E-07 + .4170E-07 + .4079E-07 + .4015E-07 + .3953E-07 + .3877E-07 + .3647E-07 + .3431E-07 + .3067E-07 + .2450E-07 + .1809E-07 + .1606E-07 + .1676E-05 + .1790E-05 + .1903E-05 + .2012E-05 + .2139E-05 + .2291E-05 + .2467E-05 + .2664E-05 + .2875E-05 + .3112E-05 + .3397E-05 + .3668E-05 + .3978E-05 + .4305E-05 + .4722E-05 + .5217E-05 + .5711E-05 + .6253E-05 + .6865E-05 + .7511E-05 + .8063E-05 + .8544E-05 + .9001E-05 + .9493E-05 + .9873E-05 + .1029E-04 + .1053E-04 + .1059E-04 + .1026E-04 + .9581E-05 + .8627E-05 + .7409E-05 + .6162E-05 + .4986E-05 + .3919E-05 + .2943E-05 + .2105E-05 + .1441E-05 + .8649E-06 + .4156E-06 + .1784E-06 + .1387E-06 + .1079E-06 + .8387E-07 + .6537E-07 + .5558E-07 + .4918E-07 + .4696E-07 + .4484E-07 + .4371E-07 + .4304E-07 + .4237E-07 + .4157E-07 + .3912E-07 + .3682E-07 + .3250E-07 + .2578E-07 + .1933E-07 + .1722E-07 + .1695E-05 + .1810E-05 + .1925E-05 + .2035E-05 + .2165E-05 + .2315E-05 + .2489E-05 + .2686E-05 + .2891E-05 + .3127E-05 + .3409E-05 + .3665E-05 + .3983E-05 + .4344E-05 + .4806E-05 + .5303E-05 + .5835E-05 + .6376E-05 + .6995E-05 + .7619E-05 + .8191E-05 + .8647E-05 + .9058E-05 + .9530E-05 + .9903E-05 + .1032E-04 + .1052E-04 + .1054E-04 + .1018E-04 + .9511E-05 + .8567E-05 + .7389E-05 + .6188E-05 + .5026E-05 + .3962E-05 + .3010E-05 + .2174E-05 + .1488E-05 + .9003E-06 + .4355E-06 + .1984E-06 + .1558E-06 + .1223E-06 + .9603E-07 + .7387E-07 + .6193E-07 + .5410E-07 + .5113E-07 + .4831E-07 + .4694E-07 + .4622E-07 + .4552E-07 + .4466E-07 + .4206E-07 + .3961E-07 + .3452E-07 + .2720E-07 + .2071E-07 + .1851E-07 + .1709E-05 + .1826E-05 + .1946E-05 + .2059E-05 + .2192E-05 + .2340E-05 + .2510E-05 + .2708E-05 + .2900E-05 + .3141E-05 + .3412E-05 + .3654E-05 + .3976E-05 + .4386E-05 + .4897E-05 + .5400E-05 + .5980E-05 + .6512E-05 + .7131E-05 + .7711E-05 + .8306E-05 + .8733E-05 + .9104E-05 + .9531E-05 + .9901E-05 + .1031E-04 + .1045E-04 + .1045E-04 + .1005E-04 + .9406E-05 + .8494E-05 + .7361E-05 + .6210E-05 + .5062E-05 + .4003E-05 + .3081E-05 + .2254E-05 + .1543E-05 + .9448E-06 + .4603E-06 + .2253E-06 + .1773E-06 + .1396E-06 + .1099E-06 + .8342E-07 + .6897E-07 + .5948E-07 + .5563E-07 + .5202E-07 + .5038E-07 + .4962E-07 + .4887E-07 + .4795E-07 + .4519E-07 + .4259E-07 + .3664E-07 + .2867E-07 + .2216E-07 + .1989E-07 + .1710E-05 + .1824E-05 + .1940E-05 + .2057E-05 + .2193E-05 + .2352E-05 + .2523E-05 + .2748E-05 + .2893E-05 + .3139E-05 + .3415E-05 + .3664E-05 + .4007E-05 + .4395E-05 + .4852E-05 + .5351E-05 + .5915E-05 + .6514E-05 + .7152E-05 + .7714E-05 + .8263E-05 + .8749E-05 + .9094E-05 + .9523E-05 + .9874E-05 + .1018E-04 + .1026E-04 + .1026E-04 + .9855E-05 + .9228E-05 + .8371E-05 + .7331E-05 + .6229E-05 + .5109E-05 + .4069E-05 + .3162E-05 + .2333E-05 + .1639E-05 + .1024E-05 + .5131E-06 + .2511E-06 + .1991E-06 + .1579E-06 + .1253E-06 + .9384E-07 + .7649E-07 + .6514E-07 + .6028E-07 + .5579E-07 + .5386E-07 + .5305E-07 + .5225E-07 + .5129E-07 + .4836E-07 + .4560E-07 + .3873E-07 + .3010E-07 + .2363E-07 + .2128E-07 + .1707E-05 + .1820E-05 + .1935E-05 + .2055E-05 + .2195E-05 + .2361E-05 + .2534E-05 + .2778E-05 + .2892E-05 + .3148E-05 + .3424E-05 + .3680E-05 + .4035E-05 + .4408E-05 + .4834E-05 + .5329E-05 + .5883E-05 + .6528E-05 + .7178E-05 + .7731E-05 + .8237E-05 + .8752E-05 + .9081E-05 + .9506E-05 + .9830E-05 + .1006E-04 + .1009E-04 + .1007E-04 + .9668E-05 + .9060E-05 + .8253E-05 + .7289E-05 + .6242E-05 + .5158E-05 + .4140E-05 + .3246E-05 + .2417E-05 + .1735E-05 + .1107E-05 + .5746E-06 + .2862E-06 + .2271E-06 + .1802E-06 + .1430E-06 + .1057E-06 + .8495E-07 + .7142E-07 + .6541E-07 + .5991E-07 + .5765E-07 + .5679E-07 + .5595E-07 + .5492E-07 + .5182E-07 + .4889E-07 + .4099E-07 + .3164E-07 + .2523E-07 + .2280E-07 + .1690E-05 + .1809E-05 + .1931E-05 + .2054E-05 + .2196E-05 + .2359E-05 + .2533E-05 + .2765E-05 + .2914E-05 + .3194E-05 + .3451E-05 + .3721E-05 + .4053E-05 + .4436E-05 + .4902E-05 + .5398E-05 + .5959E-05 + .6584E-05 + .7222E-05 + .7794E-05 + .8264E-05 + .8709E-05 + .9057E-05 + .9452E-05 + .9727E-05 + .9934E-05 + .9981E-05 + .9882E-05 + .9489E-05 + .8917E-05 + .8143E-05 + .7206E-05 + .6236E-05 + .5214E-05 + .4220E-05 + .3332E-05 + .2514E-05 + .1817E-05 + .1182E-05 + .6528E-06 + .3518E-06 + .2727E-06 + .2114E-06 + .1638E-06 + .1195E-06 + .9473E-07 + .7863E-07 + .7127E-07 + .6461E-07 + .6196E-07 + .6105E-07 + .6014E-07 + .5905E-07 + .5575E-07 + .5264E-07 + .4357E-07 + .3340E-07 + .2704E-07 + .2453E-07 + .1694E-05 + .1817E-05 + .1945E-05 + .2071E-05 + .2212E-05 + .2372E-05 + .2544E-05 + .2764E-05 + .2937E-05 + .3223E-05 + .3472E-05 + .3751E-05 + .4077E-05 + .4476E-05 + .4954E-05 + .5463E-05 + .6040E-05 + .6653E-05 + .7270E-05 + .7834E-05 + .8305E-05 + .8707E-05 + .9061E-05 + .9418E-05 + .9655E-05 + .9829E-05 + .9870E-05 + .9713E-05 + .9356E-05 + .8817E-05 + .8069E-05 + .7173E-05 + .6257E-05 + .5286E-05 + .4323E-05 + .3445E-05 + .2639E-05 + .1920E-05 + .1268E-05 + .7464E-06 + .4339E-06 + .3247E-06 + .2430E-06 + .1818E-06 + .1346E-06 + .1052E-06 + .8601E-07 + .7672E-07 + .6843E-07 + .6512E-07 + .6389E-07 + .6268E-07 + .6131E-07 + .5784E-07 + .5458E-07 + .4548E-07 + .3539E-07 + .2913E-07 + .2664E-07 + .1717E-05 + .1843E-05 + .1973E-05 + .2104E-05 + .2241E-05 + .2396E-05 + .2562E-05 + .2767E-05 + .2950E-05 + .3218E-05 + .3472E-05 + .3751E-05 + .4094E-05 + .4514E-05 + .4964E-05 + .5502E-05 + .6107E-05 + .6713E-05 + .7299E-05 + .7817E-05 + .8332E-05 + .8725E-05 + .9067E-05 + .9373E-05 + .9589E-05 + .9712E-05 + .9724E-05 + .9538E-05 + .9245E-05 + .8736E-05 + .8013E-05 + .7176E-05 + .6291E-05 + .5362E-05 + .4443E-05 + .3580E-05 + .2794E-05 + .2046E-05 + .1364E-05 + .8573E-06 + .5355E-06 + .3810E-06 + .2711E-06 + .1929E-06 + .1502E-06 + .1157E-06 + .9297E-07 + .8101E-07 + .7059E-07 + .6623E-07 + .6436E-07 + .6254E-07 + .6061E-07 + .5707E-07 + .5373E-07 + .4622E-07 + .3755E-07 + .3146E-07 + .2916E-07 + .1720E-05 + .1847E-05 + .1979E-05 + .2115E-05 + .2254E-05 + .2409E-05 + .2575E-05 + .2779E-05 + .2962E-05 + .3226E-05 + .3498E-05 + .3771E-05 + .4117E-05 + .4532E-05 + .4992E-05 + .5514E-05 + .6107E-05 + .6710E-05 + .7303E-05 + .7818E-05 + .8338E-05 + .8733E-05 + .9088E-05 + .9351E-05 + .9543E-05 + .9640E-05 + .9614E-05 + .9419E-05 + .9138E-05 + .8620E-05 + .7949E-05 + .7164E-05 + .6311E-05 + .5411E-05 + .4543E-05 + .3721E-05 + .2929E-05 + .2165E-05 + .1473E-05 + .9750E-06 + .6311E-06 + .4337E-06 + .2980E-06 + .2048E-06 + .1677E-06 + .1273E-06 + .1006E-06 + .8561E-07 + .7287E-07 + .6741E-07 + .6488E-07 + .6244E-07 + .5997E-07 + .5634E-07 + .5292E-07 + .4701E-07 + .3986E-07 + .3401E-07 + .3195E-07 + .1693E-05 + .1820E-05 + .1950E-05 + .2091E-05 + .2234E-05 + .2391E-05 + .2558E-05 + .2766E-05 + .2942E-05 + .3206E-05 + .3501E-05 + .3761E-05 + .4097E-05 + .4490E-05 + .4975E-05 + .5452E-05 + .6007E-05 + .6602E-05 + .7214E-05 + .7747E-05 + .8244E-05 + .8642E-05 + .9019E-05 + .9242E-05 + .9407E-05 + .9489E-05 + .9423E-05 + .9230E-05 + .8936E-05 + .8394E-05 + .7796E-05 + .7067E-05 + .6258E-05 + .5387E-05 + .4582E-05 + .3825E-05 + .3022E-05 + .2259E-05 + .1578E-05 + .1091E-05 + .7175E-06 + .5084E-06 + .3603E-06 + .2553E-06 + .2106E-06 + .1606E-06 + .1246E-06 + .9994E-07 + .8015E-07 + .7181E-07 + .6782E-07 + .6405E-07 + .6048E-07 + .5691E-07 + .5355E-07 + .4853E-07 + .4246E-07 + .3715E-07 + .3530E-07 + .1687E-05 + .1798E-05 + .1918E-05 + .2053E-05 + .2194E-05 + .2350E-05 + .2518E-05 + .2724E-05 + .2902E-05 + .3144E-05 + .3427E-05 + .3740E-05 + .4041E-05 + .4438E-05 + .4913E-05 + .5386E-05 + .5940E-05 + .6508E-05 + .7102E-05 + .7659E-05 + .8137E-05 + .8515E-05 + .8878E-05 + .9095E-05 + .9265E-05 + .9304E-05 + .9233E-05 + .9042E-05 + .8724E-05 + .8182E-05 + .7605E-05 + .6861E-05 + .6095E-05 + .5296E-05 + .4546E-05 + .3840E-05 + .3104E-05 + .2372E-05 + .1711E-05 + .1209E-05 + .8310E-06 + .6138E-06 + .4534E-06 + .3349E-06 + .2741E-06 + .2113E-06 + .1611E-06 + .1202E-06 + .8976E-07 + .7743E-07 + .7154E-07 + .6610E-07 + .6118E-07 + .5775E-07 + .5450E-07 + .5018E-07 + .4513E-07 + .4060E-07 + .3899E-07 + .1680E-05 + .1775E-05 + .1883E-05 + .2011E-05 + .2149E-05 + .2304E-05 + .2472E-05 + .2675E-05 + .2854E-05 + .3076E-05 + .3336E-05 + .3706E-05 + .3972E-05 + .4375E-05 + .4833E-05 + .5308E-05 + .5867E-05 + .6405E-05 + .6977E-05 + .7554E-05 + .8013E-05 + .8371E-05 + .8711E-05 + .8926E-05 + .9101E-05 + .9097E-05 + .9028E-05 + .8835E-05 + .8493E-05 + .7958E-05 + .7392E-05 + .6630E-05 + .5907E-05 + .5186E-05 + .4488E-05 + .3832E-05 + .3178E-05 + .2486E-05 + .1850E-05 + .1332E-05 + .9614E-06 + .7396E-06 + .5690E-06 + .4378E-06 + .3558E-06 + .2772E-06 + .2076E-06 + .1442E-06 + .1002E-06 + .8323E-07 + .7524E-07 + .6801E-07 + .6170E-07 + .5841E-07 + .5530E-07 + .5172E-07 + .4783E-07 + .4423E-07 + .4292E-07 + .1661E-05 + .1759E-05 + .1865E-05 + .1986E-05 + .2118E-05 + .2270E-05 + .2436E-05 + .2643E-05 + .2817E-05 + .3074E-05 + .3279E-05 + .3601E-05 + .3886E-05 + .4278E-05 + .4711E-05 + .5197E-05 + .5756E-05 + .6284E-05 + .6885E-05 + .7438E-05 + .7867E-05 + .8270E-05 + .8530E-05 + .8736E-05 + .8864E-05 + .8873E-05 + .8775E-05 + .8546E-05 + .8201E-05 + .7675E-05 + .7088E-05 + .6388E-05 + .5722E-05 + .5062E-05 + .4424E-05 + .3812E-05 + .3209E-05 + .2558E-05 + .1918E-05 + .1436E-05 + .1070E-05 + .8679E-06 + .7041E-06 + .5713E-06 + .4609E-06 + .3629E-06 + .2670E-06 + .1727E-06 + .1117E-06 + .8930E-07 + .7897E-07 + .6983E-07 + .6211E-07 + .5898E-07 + .5601E-07 + .5321E-07 + .5058E-07 + .4809E-07 + .4717E-07 + .1664E-05 + .1767E-05 + .1876E-05 + .1996E-05 + .2128E-05 + .2280E-05 + .2447E-05 + .2657E-05 + .2831E-05 + .3108E-05 + .3284E-05 + .3566E-05 + .3873E-05 + .4265E-05 + .4689E-05 + .5183E-05 + .5744E-05 + .6274E-05 + .6904E-05 + .7450E-05 + .7863E-05 + .8280E-05 + .8497E-05 + .8694E-05 + .8774E-05 + .8788E-05 + .8671E-05 + .8403E-05 + .8047E-05 + .7516E-05 + .6919E-05 + .6263E-05 + .5635E-05 + .5020E-05 + .4428E-05 + .3855E-05 + .3288E-05 + .2669E-05 + .2031E-05 + .1567E-05 + .1195E-05 + .9730E-06 + .7925E-06 + .6454E-06 + .5219E-06 + .4160E-06 + .3059E-06 + .1929E-06 + .1217E-06 + .9525E-07 + .8265E-07 + .7172E-07 + .6267E-07 + .5934E-07 + .5618E-07 + .5321E-07 + .5043E-07 + .4779E-07 + .4681E-07 + .1660E-05 + .1770E-05 + .1890E-05 + .2021E-05 + .2163E-05 + .2320E-05 + .2488E-05 + .2695E-05 + .2871E-05 + .3119E-05 + .3331E-05 + .3576E-05 + .3900E-05 + .4306E-05 + .4753E-05 + .5222E-05 + .5767E-05 + .6314E-05 + .6946E-05 + .7514E-05 + .7926E-05 + .8265E-05 + .8521E-05 + .8699E-05 + .8722E-05 + .8724E-05 + .8614E-05 + .8299E-05 + .7929E-05 + .7373E-05 + .6811E-05 + .6188E-05 + .5581E-05 + .4996E-05 + .4443E-05 + .3920E-05 + .3368E-05 + .2778E-05 + .2193E-05 + .1699E-05 + .1295E-05 + .1050E-05 + .8510E-06 + .6899E-06 + .5613E-06 + .4533E-06 + .3354E-06 + .2100E-06 + .1315E-06 + .1015E-06 + .8652E-07 + .7376E-07 + .6338E-07 + .5969E-07 + .5621E-07 + .5269E-07 + .4918E-07 + .4590E-07 + .4470E-07 + .1657E-05 + .1770E-05 + .1894E-05 + .2025E-05 + .2168E-05 + .2321E-05 + .2486E-05 + .2684E-05 + .2858E-05 + .3094E-05 + .3317E-05 + .3568E-05 + .3898E-05 + .4288E-05 + .4747E-05 + .5211E-05 + .5746E-05 + .6306E-05 + .6936E-05 + .7485E-05 + .7881E-05 + .8181E-05 + .8441E-05 + .8589E-05 + .8595E-05 + .8575E-05 + .8461E-05 + .8127E-05 + .7749E-05 + .7194E-05 + .6659E-05 + .6055E-05 + .5479E-05 + .4931E-05 + .4416E-05 + .3941E-05 + .3427E-05 + .2871E-05 + .2318E-05 + .1822E-05 + .1401E-05 + .1129E-05 + .9092E-06 + .7325E-06 + .5995E-06 + .4906E-06 + .3653E-06 + .2271E-06 + .1412E-06 + .1074E-06 + .8995E-07 + .7533E-07 + .6365E-07 + .5963E-07 + .5586E-07 + .5181E-07 + .4763E-07 + .4378E-07 + .4239E-07 + .1660E-05 + .1773E-05 + .1892E-05 + .2014E-05 + .2145E-05 + .2288E-05 + .2446E-05 + .2630E-05 + .2798E-05 + .3040E-05 + .3248E-05 + .3553E-05 + .3879E-05 + .4222E-05 + .4683E-05 + .5162E-05 + .5697E-05 + .6267E-05 + .6893E-05 + .7382E-05 + .7747E-05 + .8053E-05 + .8279E-05 + .8386E-05 + .8416E-05 + .8365E-05 + .8237E-05 + .7913E-05 + .7532E-05 + .7003E-05 + .6487E-05 + .5885E-05 + .5347E-05 + .4837E-05 + .4359E-05 + .3929E-05 + .3474E-05 + .2953E-05 + .2402E-05 + .1937E-05 + .1518E-05 + .1213E-05 + .9693E-06 + .7745E-06 + .6377E-06 + .5288E-06 + .3962E-06 + .2445E-06 + .1509E-06 + .1132E-06 + .9314E-07 + .7663E-07 + .6367E-07 + .5933E-07 + .5528E-07 + .5074E-07 + .4594E-07 + .4159E-07 + .4004E-07 + .1651E-05 + .1766E-05 + .1885E-05 + .2005E-05 + .2136E-05 + .2281E-05 + .2440E-05 + .2633E-05 + .2797E-05 + .3030E-05 + .3240E-05 + .3533E-05 + .3860E-05 + .4200E-05 + .4659E-05 + .5151E-05 + .5683E-05 + .6244E-05 + .6846E-05 + .7311E-05 + .7657E-05 + .7946E-05 + .8149E-05 + .8226E-05 + .8254E-05 + .8169E-05 + .8010E-05 + .7694E-05 + .7313E-05 + .6799E-05 + .6293E-05 + .5727E-05 + .5227E-05 + .4754E-05 + .4333E-05 + .3937E-05 + .3518E-05 + .3026E-05 + .2493E-05 + .2029E-05 + .1600E-05 + .1275E-05 + .1016E-05 + .8097E-06 + .6686E-06 + .5579E-06 + .4178E-06 + .2544E-06 + .1550E-06 + .1155E-06 + .9469E-07 + .7764E-07 + .6435E-07 + .6024E-07 + .5639E-07 + .5156E-07 + .4612E-07 + .4125E-07 + .3953E-07 + .1639E-05 + .1755E-05 + .1876E-05 + .1998E-05 + .2134E-05 + .2286E-05 + .2451E-05 + .2662E-05 + .2823E-05 + .3040E-05 + .3259E-05 + .3512E-05 + .3840E-05 + .4197E-05 + .4654E-05 + .5158E-05 + .5685E-05 + .6229E-05 + .6799E-05 + .7256E-05 + .7588E-05 + .7850E-05 + .8036E-05 + .8087E-05 + .8102E-05 + .7983E-05 + .7787E-05 + .7477E-05 + .7099E-05 + .6594E-05 + .6095E-05 + .5578E-05 + .5114E-05 + .4678E-05 + .4322E-05 + .3955E-05 + .3563E-05 + .3097E-05 + .2591E-05 + .2110E-05 + .1665E-05 + .1327E-05 + .1057E-05 + .8422E-06 + .6965E-06 + .5830E-06 + .4350E-06 + .2607E-06 + .1562E-06 + .1160E-06 + .9548E-07 + .7855E-07 + .6535E-07 + .6175E-07 + .5834E-07 + .5328E-07 + .4715E-07 + .4173E-07 + .3982E-07 + .1643E-05 + .1765E-05 + .1885E-05 + .2013E-05 + .2150E-05 + .2296E-05 + .2452E-05 + .2619E-05 + .2826E-05 + .3045E-05 + .3271E-05 + .3525E-05 + .3850E-05 + .4203E-05 + .4644E-05 + .5137E-05 + .5655E-05 + .6143E-05 + .6637E-05 + .7045E-05 + .7357E-05 + .7616E-05 + .7818E-05 + .7820E-05 + .7771E-05 + .7618E-05 + .7408E-05 + .7116E-05 + .6773E-05 + .6324E-05 + .5879E-05 + .5424E-05 + .5011E-05 + .4618E-05 + .4278E-05 + .3930E-05 + .3566E-05 + .3110E-05 + .2631E-05 + .2177E-05 + .1749E-05 + .1391E-05 + .1106E-05 + .8797E-06 + .7286E-06 + .6119E-06 + .4549E-06 + .2682E-06 + .1581E-06 + .1171E-06 + .9668E-07 + .7981E-07 + .6665E-07 + .6356E-07 + .6062E-07 + .5530E-07 + .4842E-07 + .4239E-07 + .4029E-07 + .1641E-05 + .1761E-05 + .1875E-05 + .1998E-05 + .2128E-05 + .2268E-05 + .2427E-05 + .2596E-05 + .2798E-05 + .3019E-05 + .3251E-05 + .3508E-05 + .3824E-05 + .4169E-05 + .4588E-05 + .5062E-05 + .5567E-05 + .5990E-05 + .6402E-05 + .6755E-05 + .7045E-05 + .7301E-05 + .7520E-05 + .7473E-05 + .7360E-05 + .7178E-05 + .6960E-05 + .6689E-05 + .6387E-05 + .5998E-05 + .5611E-05 + .5221E-05 + .4863E-05 + .4516E-05 + .4189E-05 + .3862E-05 + .3529E-05 + .3085E-05 + .2639E-05 + .2221E-05 + .1820E-05 + .1460E-05 + .1171E-05 + .9390E-06 + .7748E-06 + .6529E-06 + .4915E-06 + .2983E-06 + .1811E-06 + .1314E-06 + .1039E-06 + .8210E-07 + .6584E-07 + .6242E-07 + .5918E-07 + .5302E-07 + .4507E-07 + .3832E-07 + .3602E-07 + .1640E-05 + .1758E-05 + .1867E-05 + .1983E-05 + .2107E-05 + .2242E-05 + .2403E-05 + .2575E-05 + .2772E-05 + .2995E-05 + .3231E-05 + .3492E-05 + .3801E-05 + .4137E-05 + .4534E-05 + .4991E-05 + .5482E-05 + .5844E-05 + .6178E-05 + .6481E-05 + .6749E-05 + .7001E-05 + .7236E-05 + .7145E-05 + .6974E-05 + .6766E-05 + .6542E-05 + .6290E-05 + .6024E-05 + .5691E-05 + .5358E-05 + .5028E-05 + .4722E-05 + .4418E-05 + .4103E-05 + .3796E-05 + .3494E-05 + .3062E-05 + .2648E-05 + .2267E-05 + .1895E-05 + .1533E-05 + .1240E-05 + .1003E-05 + .8243E-06 + .6970E-06 + .5311E-06 + .3319E-06 + .2074E-06 + .1476E-06 + .1117E-06 + .8450E-07 + .6507E-07 + .6132E-07 + .5779E-07 + .5085E-07 + .4198E-07 + .3465E-07 + .3220E-07 + .1633E-05 + .1748E-05 + .1852E-05 + .1962E-05 + .2078E-05 + .2208E-05 + .2370E-05 + .2544E-05 + .2736E-05 + .2960E-05 + .3200E-05 + .3463E-05 + .3763E-05 + .4090E-05 + .4464E-05 + .4902E-05 + .5378E-05 + .5680E-05 + .5940E-05 + .6194E-05 + .6441E-05 + .6689E-05 + .6937E-05 + .6805E-05 + .6583E-05 + .6354E-05 + .6125E-05 + .5893E-05 + .5661E-05 + .5379E-05 + .5097E-05 + .4824E-05 + .4567E-05 + .4306E-05 + .4004E-05 + .3718E-05 + .3446E-05 + .3027E-05 + .2647E-05 + .2306E-05 + .1966E-05 + .1604E-05 + .1308E-05 + .1067E-05 + .8736E-06 + .7412E-06 + .5719E-06 + .3680E-06 + .2368E-06 + .1651E-06 + .1196E-06 + .8664E-07 + .6407E-07 + .6002E-07 + .5623E-07 + .4858E-07 + .3894E-07 + .3122E-07 + .2869E-07 + .1622E-05 + .1735E-05 + .1835E-05 + .1941E-05 + .2052E-05 + .2177E-05 + .2338E-05 + .2512E-05 + .2699E-05 + .2921E-05 + .3161E-05 + .3422E-05 + .3712E-05 + .4026E-05 + .4377E-05 + .4786E-05 + .5230E-05 + .5502E-05 + .5733E-05 + .5955E-05 + .6173E-05 + .6399E-05 + .6608E-05 + .6464E-05 + .6237E-05 + .6007E-05 + .5785E-05 + .5572E-05 + .5366E-05 + .5126E-05 + .4886E-05 + .4658E-05 + .4429E-05 + .4192E-05 + .3906E-05 + .3639E-05 + .3371E-05 + .2969E-05 + .2616E-05 + .2304E-05 + .1987E-05 + .1648E-05 + .1367E-05 + .1134E-05 + .9248E-06 + .7874E-06 + .6150E-06 + .4075E-06 + .2700E-06 + .1845E-06 + .1279E-06 + .8873E-07 + .6301E-07 + .5868E-07 + .5464E-07 + .4636E-07 + .3609E-07 + .2809E-07 + .2552E-07 + .1598E-05 + .1708E-05 + .1806E-05 + .1910E-05 + .2019E-05 + .2139E-05 + .2294E-05 + .2465E-05 + .2649E-05 + .2862E-05 + .3095E-05 + .3348E-05 + .3623E-05 + .3918E-05 + .4244E-05 + .4612E-05 + .4997E-05 + .5276E-05 + .5534E-05 + .5744E-05 + .5921E-05 + .6102E-05 + .6208E-05 + .6085E-05 + .5909E-05 + .5702E-05 + .5502E-05 + .5310E-05 + .5124E-05 + .4916E-05 + .4710E-05 + .4513E-05 + .4290E-05 + .4053E-05 + .3788E-05 + .3541E-05 + .3243E-05 + .2865E-05 + .2531E-05 + .2235E-05 + .1924E-05 + .1642E-05 + .1402E-05 + .1197E-05 + .9724E-06 + .8308E-06 + .6569E-06 + .4481E-06 + .3057E-06 + .2048E-06 + .1359E-06 + .9027E-07 + .6155E-07 + .5698E-07 + .5275E-07 + .4395E-07 + .3322E-07 + .2510E-07 + .2256E-07 + .1590E-05 + .1699E-05 + .1797E-05 + .1899E-05 + .2007E-05 + .2123E-05 + .2274E-05 + .2443E-05 + .2626E-05 + .2833E-05 + .3061E-05 + .3309E-05 + .3573E-05 + .3853E-05 + .4158E-05 + .4489E-05 + .4824E-05 + .5112E-05 + .5398E-05 + .5599E-05 + .5737E-05 + .5879E-05 + .5892E-05 + .5788E-05 + .5657E-05 + .5469E-05 + .5287E-05 + .5112E-05 + .4942E-05 + .4763E-05 + .4588E-05 + .4419E-05 + .4198E-05 + .3959E-05 + .3712E-05 + .3481E-05 + .3152E-05 + .2792E-05 + .2473E-05 + .2191E-05 + .1883E-05 + .1632E-05 + .1415E-05 + .1227E-05 + .9957E-06 + .8518E-06 + .6767E-06 + .4667E-06 + .3219E-06 + .2140E-06 + .1397E-06 + .9128E-07 + .6129E-07 + .5661E-07 + .5229E-07 + .4327E-07 + .3235E-07 + .2418E-07 + .2163E-07 + .1593E-05 + .1702E-05 + .1799E-05 + .1901E-05 + .2008E-05 + .2122E-05 + .2269E-05 + .2438E-05 + .2620E-05 + .2823E-05 + .3049E-05 + .3292E-05 + .3548E-05 + .3814E-05 + .4102E-05 + .4400E-05 + .4689E-05 + .4987E-05 + .5301E-05 + .5493E-05 + .5597E-05 + .5703E-05 + .5630E-05 + .5542E-05 + .5452E-05 + .5281E-05 + .5115E-05 + .4955E-05 + .4799E-05 + .4647E-05 + .4499E-05 + .4355E-05 + .4135E-05 + .3893E-05 + .3662E-05 + .3445E-05 + .3085E-05 + .2740E-05 + .2434E-05 + .2162E-05 + .1855E-05 + .1620E-05 + .1416E-05 + .1237E-05 + .1004E-05 + .8587E-06 + .6821E-06 + .4705E-06 + .3245E-06 + .2157E-06 + .1409E-06 + .9201E-07 + .6179E-07 + .5707E-07 + .5271E-07 + .4362E-07 + .3261E-07 + .2437E-07 + .2181E-07 + .1606E-05 + .1712E-05 + .1811E-05 + .1914E-05 + .2022E-05 + .2137E-05 + .2282E-05 + .2447E-05 + .2625E-05 + .2821E-05 + .3041E-05 + .3278E-05 + .3528E-05 + .3781E-05 + .4048E-05 + .4324E-05 + .4595E-05 + .4878E-05 + .5174E-05 + .5367E-05 + .5450E-05 + .5535E-05 + .5475E-05 + .5402E-05 + .5329E-05 + .5188E-05 + .5033E-05 + .4884E-05 + .4739E-05 + .4598E-05 + .4443E-05 + .4285E-05 + .4069E-05 + .3839E-05 + .3613E-05 + .3373E-05 + .3026E-05 + .2703E-05 + .2414E-05 + .2142E-05 + .1830E-05 + .1611E-05 + .1419E-05 + .1249E-05 + .1014E-05 + .8673E-06 + .6890E-06 + .4752E-06 + .3278E-06 + .2179E-06 + .1423E-06 + .9294E-07 + .6241E-07 + .5764E-07 + .5324E-07 + .4406E-07 + .3293E-07 + .2462E-07 + .2203E-07 + .1629E-05 + .1733E-05 + .1834E-05 + .1939E-05 + .2049E-05 + .2166E-05 + .2309E-05 + .2471E-05 + .2645E-05 + .2834E-05 + .3049E-05 + .3281E-05 + .3526E-05 + .3766E-05 + .4015E-05 + .4273E-05 + .4534E-05 + .4798E-05 + .5069E-05 + .5264E-05 + .5331E-05 + .5398E-05 + .5371E-05 + .5309E-05 + .5249E-05 + .5139E-05 + .4995E-05 + .4854E-05 + .4718E-05 + .4585E-05 + .4416E-05 + .4236E-05 + .4023E-05 + .3805E-05 + .3582E-05 + .3311E-05 + .2984E-05 + .2682E-05 + .2410E-05 + .2134E-05 + .1814E-05 + .1610E-05 + .1429E-05 + .1268E-05 + .1029E-05 + .8806E-06 + .6996E-06 + .4825E-06 + .3328E-06 + .2212E-06 + .1445E-06 + .9437E-07 + .6337E-07 + .5853E-07 + .5406E-07 + .4474E-07 + .3344E-07 + .2499E-07 + .2236E-07 + .1645E-05 + .1748E-05 + .1850E-05 + .1956E-05 + .2068E-05 + .2187E-05 + .2328E-05 + .2485E-05 + .2654E-05 + .2836E-05 + .3045E-05 + .3270E-05 + .3510E-05 + .3737E-05 + .3967E-05 + .4207E-05 + .4456E-05 + .4701E-05 + .4947E-05 + .5144E-05 + .5195E-05 + .5246E-05 + .5248E-05 + .5199E-05 + .5151E-05 + .5071E-05 + .4937E-05 + .4806E-05 + .4679E-05 + .4555E-05 + .4372E-05 + .4171E-05 + .3963E-05 + .3757E-05 + .3538E-05 + .3239E-05 + .2932E-05 + .2651E-05 + .2397E-05 + .2117E-05 + .1792E-05 + .1603E-05 + .1434E-05 + .1283E-05 + .1041E-05 + .8906E-06 + .7075E-06 + .4880E-06 + .3366E-06 + .2237E-06 + .1461E-06 + .9544E-07 + .6409E-07 + .5920E-07 + .5468E-07 + .4525E-07 + .3382E-07 + .2528E-07 + .2262E-07 + .8058E-06 + .8995E-06 + .9990E-06 + .1109E-05 + .1232E-05 + .1368E-05 + .1520E-05 + .1686E-05 + .1841E-05 + .2002E-05 + .2177E-05 + .2372E-05 + .2581E-05 + .2802E-05 + .2998E-05 + .3169E-05 + .3350E-05 + .3466E-05 + .3509E-05 + .3553E-05 + .3597E-05 + .3642E-05 + .3650E-05 + .3621E-05 + .3591E-05 + .3562E-05 + .3534E-05 + .3505E-05 + .3477E-05 + .3449E-05 + .3377E-05 + .3265E-05 + .3157E-05 + .3036E-05 + .2905E-05 + .2779E-05 + .2541E-05 + .2165E-05 + .1845E-05 + .1475E-05 + .1106E-05 + .9119E-06 + .7519E-06 + .6199E-06 + .4202E-06 + .2989E-06 + .1981E-06 + .1147E-06 + .6645E-07 + .5063E-07 + .4393E-07 + .3812E-07 + .3326E-07 + .3084E-07 + .2859E-07 + .2595E-07 + .2308E-07 + .2053E-07 + .1963E-07 + .8237E-06 + .9206E-06 + .1025E-05 + .1141E-05 + .1270E-05 + .1413E-05 + .1573E-05 + .1748E-05 + .1917E-05 + .2096E-05 + .2293E-05 + .2511E-05 + .2739E-05 + .2980E-05 + .3206E-05 + .3351E-05 + .3504E-05 + .3612E-05 + .3673E-05 + .3734E-05 + .3797E-05 + .3860E-05 + .3871E-05 + .3828E-05 + .3785E-05 + .3743E-05 + .3702E-05 + .3661E-05 + .3620E-05 + .3580E-05 + .3511E-05 + .3415E-05 + .3321E-05 + .3192E-05 + .3031E-05 + .2878E-05 + .2653E-05 + .2242E-05 + .1894E-05 + .1508E-05 + .1131E-05 + .9321E-06 + .7686E-06 + .6337E-06 + .4296E-06 + .3055E-06 + .2025E-06 + .1173E-06 + .6793E-07 + .5175E-07 + .4491E-07 + .3897E-07 + .3400E-07 + .3152E-07 + .2923E-07 + .2652E-07 + .2359E-07 + .2099E-07 + .2007E-07 + .8411E-06 + .9410E-06 + .1050E-05 + .1171E-05 + .1307E-05 + .1458E-05 + .1627E-05 + .1810E-05 + .1994E-05 + .2193E-05 + .2412E-05 + .2655E-05 + .2905E-05 + .3168E-05 + .3424E-05 + .3541E-05 + .3661E-05 + .3762E-05 + .3841E-05 + .3921E-05 + .4003E-05 + .4087E-05 + .4101E-05 + .4043E-05 + .3986E-05 + .3930E-05 + .3874E-05 + .3820E-05 + .3766E-05 + .3713E-05 + .3647E-05 + .3568E-05 + .3491E-05 + .3352E-05 + .3159E-05 + .2977E-05 + .2768E-05 + .2318E-05 + .1942E-05 + .1539E-05 + .1154E-05 + .9518E-06 + .7848E-06 + .6470E-06 + .4386E-06 + .3119E-06 + .2067E-06 + .1197E-06 + .6936E-07 + .5284E-07 + .4585E-07 + .3979E-07 + .3471E-07 + .3219E-07 + .2984E-07 + .2708E-07 + .2409E-07 + .2143E-07 + .2049E-07 + .8546E-06 + .9603E-06 + .1077E-05 + .1204E-05 + .1347E-05 + .1506E-05 + .1683E-05 + .1876E-05 + .2075E-05 + .2295E-05 + .2538E-05 + .2806E-05 + .3077E-05 + .3360E-05 + .3644E-05 + .3739E-05 + .3838E-05 + .3930E-05 + .4023E-05 + .4119E-05 + .4217E-05 + .4317E-05 + .4333E-05 + .4263E-05 + .4194E-05 + .4126E-05 + .4059E-05 + .3993E-05 + .3926E-05 + .3857E-05 + .3790E-05 + .3723E-05 + .3658E-05 + .3511E-05 + .3291E-05 + .3077E-05 + .2876E-05 + .2393E-05 + .1989E-05 + .1570E-05 + .1177E-05 + .9704E-06 + .8003E-06 + .6599E-06 + .4474E-06 + .3182E-06 + .2109E-06 + .1221E-06 + .7074E-07 + .5390E-07 + .4677E-07 + .4058E-07 + .3541E-07 + .3283E-07 + .3044E-07 + .2762E-07 + .2457E-07 + .2186E-07 + .2090E-07 + .8516E-06 + .9760E-06 + .1117E-05 + .1250E-05 + .1400E-05 + .1566E-05 + .1753E-05 + .1958E-05 + .2174E-05 + .2415E-05 + .2683E-05 + .2965E-05 + .3259E-05 + .3543E-05 + .3819E-05 + .3959E-05 + .4105E-05 + .4191E-05 + .4272E-05 + .4354E-05 + .4438E-05 + .4524E-05 + .4536E-05 + .4474E-05 + .4413E-05 + .4352E-05 + .4293E-05 + .4234E-05 + .4157E-05 + .4062E-05 + .3970E-05 + .3879E-05 + .3791E-05 + .3644E-05 + .3438E-05 + .3183E-05 + .2948E-05 + .2455E-05 + .2031E-05 + .1598E-05 + .1196E-05 + .9869E-06 + .8147E-06 + .6726E-06 + .4559E-06 + .3242E-06 + .2149E-06 + .1245E-06 + .7210E-07 + .5493E-07 + .4766E-07 + .4136E-07 + .3608E-07 + .3345E-07 + .3102E-07 + .2815E-07 + .2504E-07 + .2227E-07 + .2130E-07 + .8503E-06 + .9940E-06 + .1161E-05 + .1301E-05 + .1458E-05 + .1633E-05 + .1830E-05 + .2047E-05 + .2283E-05 + .2547E-05 + .2841E-05 + .3140E-05 + .3459E-05 + .3743E-05 + .4011E-05 + .4201E-05 + .4399E-05 + .4479E-05 + .4545E-05 + .4613E-05 + .4681E-05 + .4751E-05 + .4759E-05 + .4706E-05 + .4653E-05 + .4601E-05 + .4549E-05 + .4498E-05 + .4410E-05 + .4287E-05 + .4167E-05 + .4050E-05 + .3937E-05 + .3790E-05 + .3599E-05 + .3301E-05 + .3027E-05 + .2524E-05 + .2079E-05 + .1630E-05 + .1217E-05 + .9991E-06 + .8202E-06 + .6733E-06 + .4575E-06 + .3259E-06 + .2165E-06 + .1257E-06 + .7302E-07 + .5573E-07 + .4843E-07 + .4209E-07 + .3676E-07 + .3412E-07 + .3167E-07 + .2878E-07 + .2563E-07 + .2284E-07 + .2185E-07 + .8522E-06 + .1016E-05 + .1211E-05 + .1359E-05 + .1524E-05 + .1709E-05 + .1917E-05 + .2149E-05 + .2407E-05 + .2696E-05 + .3020E-05 + .3338E-05 + .3685E-05 + .3970E-05 + .4228E-05 + .4474E-05 + .4733E-05 + .4804E-05 + .4854E-05 + .4905E-05 + .4956E-05 + .5007E-05 + .5011E-05 + .4968E-05 + .4925E-05 + .4882E-05 + .4840E-05 + .4798E-05 + .4697E-05 + .4541E-05 + .4390E-05 + .4244E-05 + .4104E-05 + .3956E-05 + .3782E-05 + .3435E-05 + .3120E-05 + .2604E-05 + .2136E-05 + .1669E-05 + .1244E-05 + .1004E-05 + .8108E-06 + .6547E-06 + .4477E-06 + .3204E-06 + .2140E-06 + .1252E-06 + .7324E-07 + .5617E-07 + .4899E-07 + .4273E-07 + .3746E-07 + .3487E-07 + .3246E-07 + .2959E-07 + .2646E-07 + .2366E-07 + .2267E-07 + .8720E-06 + .1039E-05 + .1238E-05 + .1393E-05 + .1567E-05 + .1759E-05 + .1975E-05 + .2217E-05 + .2490E-05 + .2795E-05 + .3139E-05 + .3486E-05 + .3860E-05 + .4161E-05 + .4441E-05 + .4721E-05 + .5014E-05 + .5120E-05 + .5151E-05 + .5182E-05 + .5214E-05 + .5245E-05 + .5241E-05 + .5202E-05 + .5163E-05 + .5117E-05 + .5070E-05 + .5024E-05 + .4920E-05 + .4761E-05 + .4608E-05 + .4459E-05 + .4286E-05 + .4120E-05 + .3940E-05 + .3589E-05 + .3229E-05 + .2705E-05 + .2207E-05 + .1727E-05 + .1285E-05 + .1015E-05 + .8018E-06 + .6333E-06 + .4359E-06 + .3134E-06 + .2105E-06 + .1240E-06 + .7308E-07 + .5632E-07 + .4931E-07 + .4316E-07 + .3798E-07 + .3545E-07 + .3309E-07 + .3026E-07 + .2716E-07 + .2438E-07 + .2340E-07 + .9051E-06 + .1062E-05 + .1247E-05 + .1409E-05 + .1592E-05 + .1789E-05 + .2011E-05 + .2260E-05 + .2540E-05 + .2855E-05 + .3212E-05 + .3594E-05 + .3993E-05 + .4324E-05 + .4652E-05 + .4949E-05 + .5251E-05 + .5428E-05 + .5438E-05 + .5448E-05 + .5458E-05 + .5468E-05 + .5454E-05 + .5415E-05 + .5376E-05 + .5314E-05 + .5253E-05 + .5193E-05 + .5093E-05 + .4955E-05 + .4822E-05 + .4692E-05 + .4483E-05 + .4283E-05 + .4078E-05 + .3760E-05 + .3349E-05 + .2821E-05 + .2290E-05 + .1798E-05 + .1338E-05 + .1030E-05 + .7929E-06 + .6103E-06 + .4228E-06 + .3054E-06 + .2062E-06 + .1224E-06 + .7263E-07 + .5625E-07 + .4943E-07 + .4343E-07 + .3836E-07 + .3590E-07 + .3360E-07 + .3083E-07 + .2778E-07 + .2503E-07 + .2405E-07 + .9382E-06 + .1085E-05 + .1255E-05 + .1423E-05 + .1615E-05 + .1817E-05 + .2044E-05 + .2300E-05 + .2588E-05 + .2913E-05 + .3281E-05 + .3700E-05 + .4126E-05 + .4488E-05 + .4865E-05 + .5181E-05 + .5493E-05 + .5747E-05 + .5734E-05 + .5720E-05 + .5707E-05 + .5693E-05 + .5667E-05 + .5628E-05 + .5589E-05 + .5512E-05 + .5435E-05 + .5360E-05 + .5264E-05 + .5150E-05 + .5039E-05 + .4930E-05 + .4682E-05 + .4447E-05 + .4216E-05 + .3933E-05 + .3469E-05 + .2938E-05 + .2372E-05 + .1869E-05 + .1392E-05 + .1044E-05 + .7829E-06 + .5873E-06 + .4094E-06 + .2971E-06 + .2017E-06 + .1206E-06 + .7209E-07 + .5610E-07 + .4948E-07 + .4364E-07 + .3868E-07 + .3630E-07 + .3407E-07 + .3137E-07 + .2837E-07 + .2566E-07 + .2470E-07 + .9621E-06 + .1096E-05 + .1249E-05 + .1422E-05 + .1620E-05 + .1825E-05 + .2056E-05 + .2316E-05 + .2609E-05 + .2939E-05 + .3317E-05 + .3770E-05 + .4217E-05 + .4608E-05 + .5034E-05 + .5366E-05 + .5684E-05 + .6021E-05 + .5981E-05 + .5942E-05 + .5903E-05 + .5864E-05 + .5826E-05 + .5788E-05 + .5750E-05 + .5656E-05 + .5564E-05 + .5473E-05 + .5384E-05 + .5296E-05 + .5209E-05 + .5124E-05 + .4838E-05 + .4567E-05 + .4312E-05 + .4070E-05 + .3555E-05 + .3027E-05 + .2431E-05 + .1923E-05 + .1432E-05 + .1046E-05 + .7649E-06 + .5591E-06 + .3923E-06 + .2860E-06 + .1952E-06 + .1176E-06 + .7080E-07 + .5536E-07 + .4901E-07 + .4338E-07 + .3859E-07 + .3632E-07 + .3419E-07 + .3158E-07 + .2867E-07 + .2603E-07 + .2509E-07 + .9672E-06 + .1104E-05 + .1261E-05 + .1439E-05 + .1636E-05 + .1835E-05 + .2059E-05 + .2310E-05 + .2593E-05 + .2929E-05 + .3311E-05 + .3763E-05 + .4238E-05 + .4703E-05 + .5161E-05 + .5557E-05 + .5879E-05 + .6166E-05 + .6148E-05 + .6103E-05 + .6058E-05 + .6014E-05 + .5970E-05 + .5922E-05 + .5871E-05 + .5778E-05 + .5687E-05 + .5598E-05 + .5510E-05 + .5423E-05 + .5338E-05 + .5230E-05 + .4954E-05 + .4692E-05 + .4382E-05 + .4093E-05 + .3573E-05 + .3028E-05 + .2424E-05 + .1918E-05 + .1445E-05 + .1033E-05 + .7382E-06 + .5276E-06 + .3726E-06 + .2728E-06 + .1873E-06 + .1136E-06 + .6891E-07 + .5414E-07 + .4811E-07 + .4275E-07 + .3816E-07 + .3602E-07 + .3400E-07 + .3151E-07 + .2872E-07 + .2617E-07 + .2526E-07 + .9751E-06 + .1116E-05 + .1277E-05 + .1461E-05 + .1656E-05 + .1850E-05 + .2068E-05 + .2310E-05 + .2585E-05 + .2926E-05 + .3315E-05 + .3768E-05 + .4271E-05 + .4813E-05 + .5306E-05 + .5771E-05 + .6098E-05 + .6332E-05 + .6337E-05 + .6286E-05 + .6235E-05 + .6185E-05 + .6136E-05 + .6078E-05 + .6012E-05 + .5920E-05 + .5830E-05 + .5742E-05 + .5655E-05 + .5569E-05 + .5484E-05 + .5354E-05 + .5087E-05 + .4833E-05 + .4466E-05 + .4127E-05 + .3601E-05 + .3038E-05 + .2425E-05 + .1918E-05 + .1463E-05 + .1022E-05 + .7145E-06 + .4993E-06 + .3549E-06 + .2611E-06 + .1802E-06 + .1101E-06 + .6726E-07 + .5311E-07 + .4736E-07 + .4224E-07 + .3785E-07 + .3582E-07 + .3391E-07 + .3153E-07 + .2884E-07 + .2638E-07 + .2550E-07 + .9798E-06 + .1124E-05 + .1288E-05 + .1477E-05 + .1670E-05 + .1859E-05 + .2069E-05 + .2303E-05 + .2568E-05 + .2914E-05 + .3308E-05 + .3760E-05 + .4290E-05 + .4910E-05 + .5437E-05 + .5974E-05 + .6305E-05 + .6482E-05 + .6509E-05 + .6453E-05 + .6396E-05 + .6340E-05 + .6285E-05 + .6216E-05 + .6135E-05 + .6046E-05 + .5957E-05 + .5870E-05 + .5784E-05 + .5700E-05 + .5616E-05 + .5461E-05 + .5206E-05 + .4962E-05 + .4537E-05 + .4147E-05 + .3617E-05 + .3037E-05 + .2417E-05 + .1911E-05 + .1476E-05 + .1009E-05 + .6892E-06 + .4709E-06 + .3368E-06 + .2489E-06 + .1728E-06 + .1063E-06 + .6543E-07 + .5191E-07 + .4647E-07 + .4160E-07 + .3741E-07 + .3551E-07 + .3370E-07 + .3144E-07 + .2887E-07 + .2651E-07 + .2566E-07 + .9889E-06 + .1140E-05 + .1306E-05 + .1489E-05 + .1674E-05 + .1860E-05 + .2062E-05 + .2291E-05 + .2558E-05 + .2901E-05 + .3278E-05 + .3769E-05 + .4350E-05 + .5010E-05 + .5619E-05 + .6253E-05 + .6691E-05 + .6947E-05 + .7076E-05 + .7065E-05 + .6957E-05 + .6809E-05 + .6618E-05 + .6424E-05 + .6254E-05 + .6105E-05 + .5999E-05 + .5893E-05 + .5818E-05 + .5751E-05 + .5707E-05 + .5575E-05 + .5355E-05 + .5094E-05 + .4651E-05 + .4173E-05 + .3599E-05 + .2990E-05 + .2380E-05 + .1871E-05 + .1439E-05 + .9727E-06 + .6575E-06 + .4445E-06 + .3200E-06 + .2376E-06 + .1658E-06 + .1028E-06 + .6371E-07 + .5080E-07 + .4564E-07 + .4100E-07 + .3701E-07 + .3523E-07 + .3353E-07 + .3138E-07 + .2893E-07 + .2666E-07 + .2585E-07 + .1051E-05 + .1210E-05 + .1374E-05 + .1541E-05 + .1715E-05 + .1900E-05 + .2098E-05 + .2330E-05 + .2610E-05 + .2947E-05 + .3316E-05 + .3851E-05 + .4471E-05 + .5122E-05 + .5806E-05 + .6505E-05 + .7082E-05 + .7485E-05 + .7707E-05 + .7767E-05 + .7599E-05 + .7342E-05 + .7003E-05 + .6695E-05 + .6454E-05 + .6260E-05 + .6139E-05 + .6010E-05 + .5938E-05 + .5884E-05 + .5849E-05 + .5731E-05 + .5522E-05 + .5212E-05 + .4761E-05 + .4182E-05 + .3533E-05 + .2885E-05 + .2284E-05 + .1764E-05 + .1317E-05 + .9017E-06 + .6175E-06 + .4228E-06 + .3064E-06 + .2285E-06 + .1603E-06 + .1001E-06 + .6251E-07 + .5008E-07 + .4516E-07 + .4073E-07 + .3689E-07 + .3521E-07 + .3361E-07 + .3156E-07 + .2920E-07 + .2702E-07 + .2623E-07 + .1156E-05 + .1316E-05 + .1474E-05 + .1630E-05 + .1795E-05 + .1972E-05 + .2170E-05 + .2406E-05 + .2692E-05 + .3028E-05 + .3421E-05 + .3950E-05 + .4561E-05 + .5203E-05 + .5887E-05 + .6580E-05 + .7175E-05 + .7582E-05 + .7759E-05 + .7826E-05 + .7667E-05 + .7427E-05 + .7128E-05 + .6885E-05 + .6693E-05 + .6551E-05 + .6446E-05 + .6313E-05 + .6225E-05 + .6161E-05 + .6055E-05 + .5879E-05 + .5627E-05 + .5275E-05 + .4769E-05 + .4134E-05 + .3441E-05 + .2765E-05 + .2156E-05 + .1632E-05 + .1180E-05 + .8238E-06 + .5750E-06 + .4014E-06 + .2927E-06 + .2193E-06 + .1547E-06 + .9731E-07 + .6120E-07 + .4927E-07 + .4460E-07 + .4037E-07 + .3670E-07 + .3513E-07 + .3362E-07 + .3168E-07 + .2942E-07 + .2733E-07 + .2657E-07 + .1242E-05 + .1406E-05 + .1567E-05 + .1726E-05 + .1891E-05 + .2065E-05 + .2265E-05 + .2500E-05 + .2788E-05 + .3100E-05 + .3496E-05 + .4009E-05 + .4580E-05 + .5194E-05 + .5897E-05 + .6589E-05 + .7171E-05 + .7609E-05 + .7813E-05 + .7883E-05 + .7779E-05 + .7566E-05 + .7326E-05 + .7137E-05 + .6973E-05 + .6857E-05 + .6773E-05 + .6671E-05 + .6569E-05 + .6466E-05 + .6319E-05 + .6068E-05 + .5750E-05 + .5325E-05 + .4747E-05 + .4047E-05 + .3291E-05 + .2597E-05 + .1983E-05 + .1461E-05 + .1028E-05 + .7321E-06 + .5213E-06 + .3712E-06 + .2726E-06 + .2060E-06 + .1471E-06 + .9424E-07 + .6039E-07 + .4907E-07 + .4464E-07 + .4061E-07 + .3709E-07 + .3552E-07 + .3402E-07 + .3201E-07 + .2962E-07 + .2752E-07 + .2676E-07 + .1324E-05 + .1494E-05 + .1663E-05 + .1831E-05 + .2001E-05 + .2173E-05 + .2377E-05 + .2608E-05 + .2897E-05 + .3174E-05 + .3566E-05 + .4059E-05 + .4578E-05 + .5160E-05 + .5889E-05 + .6584E-05 + .7143E-05 + .7622E-05 + .7880E-05 + .7951E-05 + .7920E-05 + .7739E-05 + .7569E-05 + .7431E-05 + .7287E-05 + .7188E-05 + .7129E-05 + .7075E-05 + .6959E-05 + .6803E-05 + .6624E-05 + .6288E-05 + .5892E-05 + .5379E-05 + .4720E-05 + .3953E-05 + .3131E-05 + .2425E-05 + .1810E-05 + .1294E-05 + .8876E-06 + .6283E-06 + .4447E-06 + .3148E-06 + .2328E-06 + .1792E-06 + .1317E-06 + .8853E-07 + .5951E-07 + .4938E-07 + .4530E-07 + .4155E-07 + .3822E-07 + .3643E-07 + .3471E-07 + .3220E-07 + .2915E-07 + .2684E-07 + .2602E-07 + .1376E-05 + .1534E-05 + .1694E-05 + .1858E-05 + .2022E-05 + .2193E-05 + .2392E-05 + .2622E-05 + .2895E-05 + .3168E-05 + .3544E-05 + .4006E-05 + .4503E-05 + .5080E-05 + .5736E-05 + .6397E-05 + .6972E-05 + .7494E-05 + .7806E-05 + .7953E-05 + .7962E-05 + .7854E-05 + .7743E-05 + .7669E-05 + .7575E-05 + .7498E-05 + .7422E-05 + .7350E-05 + .7183E-05 + .7027E-05 + .6747E-05 + .6382E-05 + .5941E-05 + .5395E-05 + .4685E-05 + .3878E-05 + .3042E-05 + .2305E-05 + .1667E-05 + .1152E-05 + .7472E-06 + .5285E-06 + .3739E-06 + .2645E-06 + .1971E-06 + .1545E-06 + .1169E-06 + .8240E-07 + .5811E-07 + .4924E-07 + .4554E-07 + .4212E-07 + .3903E-07 + .3701E-07 + .3509E-07 + .3210E-07 + .2842E-07 + .2594E-07 + .2507E-07 + .1418E-05 + .1565E-05 + .1716E-05 + .1872E-05 + .2029E-05 + .2198E-05 + .2391E-05 + .2616E-05 + .2873E-05 + .3142E-05 + .3501E-05 + .3925E-05 + .4397E-05 + .4963E-05 + .5548E-05 + .6175E-05 + .6765E-05 + .7323E-05 + .7684E-05 + .7905E-05 + .7959E-05 + .7925E-05 + .7876E-05 + .7865E-05 + .7824E-05 + .7771E-05 + .7687E-05 + .7595E-05 + .7380E-05 + .7220E-05 + .6848E-05 + .6448E-05 + .5965E-05 + .5382E-05 + .4625E-05 + .3781E-05 + .2939E-05 + .2177E-05 + .1523E-05 + .1013E-05 + .6206E-06 + .4398E-06 + .3118E-06 + .2210E-06 + .1659E-06 + .1325E-06 + .1031E-06 + .7627E-07 + .5642E-07 + .4883E-07 + .4553E-07 + .4246E-07 + .3963E-07 + .3739E-07 + .3528E-07 + .3182E-07 + .2756E-07 + .2493E-07 + .2402E-07 + .1446E-05 + .1597E-05 + .1747E-05 + .1896E-05 + .2044E-05 + .2208E-05 + .2395E-05 + .2613E-05 + .2854E-05 + .3110E-05 + .3461E-05 + .3825E-05 + .4250E-05 + .4782E-05 + .5347E-05 + .5968E-05 + .6576E-05 + .7150E-05 + .7548E-05 + .7806E-05 + .7946E-05 + .7977E-05 + .7993E-05 + .8018E-05 + .8021E-05 + .7985E-05 + .7979E-05 + .7890E-05 + .7667E-05 + .7457E-05 + .7070E-05 + .6577E-05 + .6037E-05 + .5368E-05 + .4551E-05 + .3650E-05 + .2804E-05 + .2020E-05 + .1363E-05 + .8480E-06 + .4945E-06 + .3559E-06 + .2561E-06 + .1843E-06 + .1394E-06 + .1134E-06 + .9082E-07 + .7048E-07 + .5469E-07 + .4834E-07 + .4545E-07 + .4273E-07 + .4017E-07 + .3772E-07 + .3541E-07 + .3149E-07 + .2668E-07 + .2391E-07 + .2297E-07 + .1464E-05 + .1617E-05 + .1767E-05 + .1909E-05 + .2052E-05 + .2212E-05 + .2393E-05 + .2602E-05 + .2828E-05 + .3074E-05 + .3404E-05 + .3734E-05 + .4131E-05 + .4631E-05 + .5174E-05 + .5786E-05 + .6405E-05 + .6985E-05 + .7418E-05 + .7725E-05 + .7926E-05 + .8026E-05 + .8112E-05 + .8185E-05 + .8233E-05 + .8222E-05 + .8264E-05 + .8216E-05 + .7970E-05 + .7693E-05 + .7286E-05 + .6710E-05 + .6106E-05 + .5350E-05 + .4463E-05 + .3515E-05 + .2661E-05 + .1875E-05 + .1219E-05 + .7071E-06 + .3910E-06 + .2864E-06 + .2098E-06 + .1537E-06 + .1171E-06 + .9707E-07 + .7997E-07 + .6510E-07 + .5299E-07 + .4783E-07 + .4534E-07 + .4299E-07 + .4070E-07 + .3803E-07 + .3553E-07 + .3116E-07 + .2582E-07 + .2293E-07 + .2196E-07 + .1470E-05 + .1619E-05 + .1769E-05 + .1908E-05 + .2052E-05 + .2211E-05 + .2387E-05 + .2585E-05 + .2796E-05 + .3039E-05 + .3326E-05 + .3666E-05 + .4067E-05 + .4539E-05 + .5059E-05 + .5659E-05 + .6279E-05 + .6850E-05 + .7316E-05 + .7696E-05 + .7912E-05 + .8091E-05 + .8254E-05 + .8399E-05 + .8493E-05 + .8520E-05 + .8549E-05 + .8614E-05 + .8316E-05 + .7945E-05 + .7506E-05 + .6869E-05 + .6188E-05 + .5341E-05 + .4363E-05 + .3378E-05 + .2509E-05 + .1746E-05 + .1092E-05 + .5872E-06 + .3056E-06 + .2289E-06 + .1714E-06 + .1284E-06 + .9853E-07 + .8322E-07 + .7055E-07 + .6025E-07 + .5145E-07 + .4742E-07 + .4533E-07 + .4333E-07 + .4132E-07 + .3842E-07 + .3572E-07 + .3088E-07 + .2503E-07 + .2204E-07 + .2104E-07 + .1480E-05 + .1629E-05 + .1779E-05 + .1917E-05 + .2062E-05 + .2220E-05 + .2394E-05 + .2589E-05 + .2793E-05 + .3043E-05 + .3319E-05 + .3664E-05 + .4046E-05 + .4504E-05 + .5004E-05 + .5590E-05 + .6174E-05 + .6741E-05 + .7223E-05 + .7636E-05 + .7896E-05 + .8134E-05 + .8345E-05 + .8546E-05 + .8683E-05 + .8752E-05 + .8823E-05 + .8979E-05 + .8681E-05 + .8284E-05 + .7759E-05 + .7023E-05 + .6228E-05 + .5294E-05 + .4261E-05 + .3230E-05 + .2348E-05 + .1612E-05 + .9839E-06 + .5062E-06 + .2556E-06 + .1914E-06 + .1433E-06 + .1073E-06 + .8299E-07 + .7140E-07 + .6229E-07 + .5580E-07 + .4999E-07 + .4706E-07 + .4535E-07 + .4371E-07 + .4198E-07 + .3884E-07 + .3593E-07 + .3064E-07 + .2429E-07 + .2119E-07 + .2017E-07 + .1494E-05 + .1644E-05 + .1795E-05 + .1931E-05 + .2076E-05 + .2234E-05 + .2409E-05 + .2608E-05 + .2811E-05 + .3074E-05 + .3362E-05 + .3708E-05 + .4053E-05 + .4508E-05 + .4988E-05 + .5558E-05 + .6080E-05 + .6644E-05 + .7129E-05 + .7546E-05 + .7871E-05 + .8152E-05 + .8387E-05 + .8631E-05 + .8807E-05 + .8922E-05 + .9082E-05 + .9306E-05 + .9055E-05 + .8694E-05 + .8034E-05 + .7166E-05 + .6229E-05 + .5214E-05 + .4153E-05 + .3073E-05 + .2181E-05 + .1478E-05 + .8887E-06 + .4488E-06 + .2252E-06 + .1657E-06 + .1219E-06 + .8970E-07 + .6988E-07 + .6125E-07 + .5499E-07 + .5167E-07 + .4856E-07 + .4668E-07 + .4536E-07 + .4408E-07 + .4265E-07 + .3926E-07 + .3614E-07 + .3038E-07 + .2356E-07 + .2038E-07 + .1933E-07 + .1488E-05 + .1636E-05 + .1786E-05 + .1921E-05 + .2064E-05 + .2221E-05 + .2394E-05 + .2592E-05 + .2794E-05 + .3056E-05 + .3339E-05 + .3670E-05 + .3982E-05 + .4409E-05 + .4875E-05 + .5433E-05 + .5916E-05 + .6462E-05 + .6927E-05 + .7392E-05 + .7796E-05 + .8076E-05 + .8315E-05 + .8612E-05 + .8842E-05 + .9035E-05 + .9322E-05 + .9497E-05 + .9211E-05 + .8816E-05 + .8119E-05 + .7169E-05 + .6125E-05 + .5066E-05 + .4023E-05 + .2988E-05 + .2124E-05 + .1446E-05 + .8768E-06 + .4534E-06 + .2282E-06 + .1569E-06 + .1079E-06 + .7415E-07 + .5819E-07 + .5196E-07 + .4800E-07 + .4732E-07 + .4665E-07 + .4579E-07 + .4487E-07 + .4396E-07 + .4284E-07 + .3924E-07 + .3595E-07 + .2980E-07 + .2260E-07 + .1937E-07 + .1833E-07 + .1481E-05 + .1627E-05 + .1776E-05 + .1909E-05 + .2051E-05 + .2206E-05 + .2379E-05 + .2573E-05 + .2774E-05 + .3034E-05 + .3307E-05 + .3619E-05 + .3903E-05 + .4297E-05 + .4752E-05 + .5300E-05 + .5754E-05 + .6279E-05 + .6719E-05 + .7246E-05 + .7731E-05 + .7998E-05 + .8237E-05 + .8588E-05 + .8876E-05 + .9160E-05 + .9590E-05 + .9677E-05 + .9330E-05 + .8876E-05 + .8170E-05 + .7151E-05 + .6011E-05 + .4918E-05 + .3901E-05 + .2932E-05 + .2104E-05 + .1447E-05 + .8907E-06 + .4777E-06 + .2419E-06 + .1598E-06 + .1056E-06 + .6976E-07 + .5502E-07 + .4912E-07 + .4543E-07 + .4496E-07 + .4450E-07 + .4379E-07 + .4298E-07 + .4218E-07 + .4117E-07 + .3785E-07 + .3480E-07 + .2926E-07 + .2236E-07 + .1862E-07 + .1741E-07 + .1488E-05 + .1630E-05 + .1778E-05 + .1910E-05 + .2049E-05 + .2199E-05 + .2365E-05 + .2558E-05 + .2745E-05 + .3001E-05 + .3289E-05 + .3591E-05 + .3861E-05 + .4258E-05 + .4685E-05 + .5195E-05 + .5637E-05 + .6159E-05 + .6620E-05 + .7154E-05 + .7639E-05 + .8014E-05 + .8304E-05 + .8660E-05 + .8978E-05 + .9293E-05 + .9764E-05 + .9861E-05 + .9527E-05 + .9066E-05 + .8291E-05 + .7205E-05 + .6027E-05 + .4904E-05 + .3861E-05 + .2895E-05 + .2075E-05 + .1418E-05 + .8686E-06 + .4621E-06 + .2286E-06 + .1523E-06 + .1015E-06 + .6761E-07 + .5358E-07 + .4769E-07 + .4399E-07 + .4344E-07 + .4290E-07 + .4221E-07 + .4145E-07 + .4070E-07 + .3977E-07 + .3674E-07 + .3395E-07 + .2905E-07 + .2248E-07 + .1813E-07 + .1674E-07 + .1504E-05 + .1643E-05 + .1790E-05 + .1920E-05 + .2056E-05 + .2203E-05 + .2364E-05 + .2555E-05 + .2734E-05 + .2990E-05 + .3290E-05 + .3585E-05 + .3843E-05 + .4245E-05 + .4651E-05 + .5130E-05 + .5563E-05 + .6081E-05 + .6562E-05 + .7107E-05 + .7593E-05 + .8067E-05 + .8414E-05 + .8771E-05 + .9114E-05 + .9450E-05 + .9958E-05 + .1006E-04 + .9740E-05 + .9274E-05 + .8444E-05 + .7292E-05 + .6073E-05 + .4917E-05 + .3847E-05 + .2877E-05 + .2061E-05 + .1405E-05 + .8596E-06 + .4551E-06 + .2204E-06 + .1473E-06 + .9844E-07 + .6579E-07 + .5238E-07 + .4648E-07 + .4276E-07 + .4213E-07 + .4152E-07 + .4083E-07 + .4012E-07 + .3943E-07 + .3857E-07 + .3581E-07 + .3324E-07 + .2897E-07 + .2268E-07 + .1772E-07 + .1615E-07 + .1529E-05 + .1665E-05 + .1807E-05 + .1933E-05 + .2067E-05 + .2211E-05 + .2373E-05 + .2561E-05 + .2746E-05 + .3021E-05 + .3310E-05 + .3604E-05 + .3851E-05 + .4258E-05 + .4659E-05 + .5130E-05 + .5553E-05 + .6058E-05 + .6548E-05 + .7120E-05 + .7609E-05 + .8117E-05 + .8536E-05 + .8880E-05 + .9217E-05 + .9534E-05 + .1005E-04 + .1013E-04 + .9824E-05 + .9355E-05 + .8568E-05 + .7387E-05 + .6124E-05 + .4947E-05 + .3865E-05 + .2881E-05 + .2078E-05 + .1436E-05 + .8939E-06 + .4785E-06 + .2295E-06 + .1498E-06 + .9779E-07 + .6384E-07 + .5107E-07 + .4518E-07 + .4145E-07 + .4075E-07 + .4006E-07 + .3939E-07 + .3873E-07 + .3809E-07 + .3729E-07 + .3479E-07 + .3246E-07 + .2880E-07 + .2282E-07 + .1727E-07 + .1554E-07 + .1551E-05 + .1684E-05 + .1822E-05 + .1945E-05 + .2078E-05 + .2222E-05 + .2387E-05 + .2576E-05 + .2764E-05 + .3051E-05 + .3330E-05 + .3628E-05 + .3865E-05 + .4277E-05 + .4670E-05 + .5152E-05 + .5578E-05 + .6078E-05 + .6579E-05 + .7159E-05 + .7664E-05 + .8185E-05 + .8662E-05 + .8985E-05 + .9325E-05 + .9645E-05 + .1016E-04 + .1022E-04 + .9911E-05 + .9428E-05 + .8665E-05 + .7467E-05 + .6184E-05 + .4987E-05 + .3891E-05 + .2896E-05 + .2099E-05 + .1467E-05 + .9240E-06 + .4972E-06 + .2373E-06 + .1517E-06 + .9695E-07 + .6197E-07 + .4981E-07 + .4393E-07 + .4019E-07 + .3943E-07 + .3868E-07 + .3802E-07 + .3741E-07 + .3681E-07 + .3608E-07 + .3382E-07 + .3171E-07 + .2864E-07 + .2297E-07 + .1684E-07 + .1497E-07 + .1562E-05 + .1692E-05 + .1827E-05 + .1950E-05 + .2084E-05 + .2233E-05 + .2401E-05 + .2597E-05 + .2783E-05 + .3071E-05 + .3336E-05 + .3647E-05 + .3878E-05 + .4294E-05 + .4670E-05 + .5194E-05 + .5639E-05 + .6146E-05 + .6661E-05 + .7216E-05 + .7757E-05 + .8256E-05 + .8764E-05 + .9056E-05 + .9411E-05 + .9769E-05 + .1025E-04 + .1030E-04 + .9972E-05 + .9457E-05 + .8690E-05 + .7498E-05 + .6236E-05 + .5028E-05 + .3914E-05 + .2922E-05 + .2122E-05 + .1489E-05 + .9434E-06 + .5056E-06 + .2420E-06 + .1564E-06 + .1011E-06 + .6536E-07 + .5245E-07 + .4553E-07 + .4114E-07 + .4010E-07 + .3909E-07 + .3836E-07 + .3775E-07 + .3716E-07 + .3645E-07 + .3431E-07 + .3229E-07 + .2924E-07 + .2341E-07 + .1698E-07 + .1501E-07 + .1587E-05 + .1713E-05 + .1842E-05 + .1961E-05 + .2092E-05 + .2244E-05 + .2415E-05 + .2612E-05 + .2807E-05 + .3078E-05 + .3358E-05 + .3660E-05 + .3908E-05 + .4298E-05 + .4682E-05 + .5214E-05 + .5668E-05 + .6194E-05 + .6736E-05 + .7320E-05 + .7879E-05 + .8364E-05 + .8844E-05 + .9180E-05 + .9526E-05 + .9906E-05 + .1033E-04 + .1035E-04 + .1002E-04 + .9470E-05 + .8663E-05 + .7495E-05 + .6258E-05 + .5059E-05 + .3949E-05 + .2967E-05 + .2157E-05 + .1513E-05 + .9585E-06 + .5104E-06 + .2446E-06 + .1648E-06 + .1110E-06 + .7481E-07 + .5956E-07 + .5025E-07 + .4439E-07 + .4282E-07 + .4130E-07 + .4039E-07 + .3977E-07 + .3915E-07 + .3842E-07 + .3627E-07 + .3424E-07 + .3061E-07 + .2411E-07 + .1767E-07 + .1567E-07 + .1626E-05 + .1747E-05 + .1869E-05 + .1981E-05 + .2109E-05 + .2260E-05 + .2436E-05 + .2631E-05 + .2842E-05 + .3085E-05 + .3400E-05 + .3680E-05 + .3959E-05 + .4305E-05 + .4716E-05 + .5233E-05 + .5689E-05 + .6244E-05 + .6825E-05 + .7476E-05 + .8044E-05 + .8521E-05 + .8934E-05 + .9367E-05 + .9687E-05 + .1008E-04 + .1044E-04 + .1041E-04 + .1009E-04 + .9497E-05 + .8626E-05 + .7490E-05 + .6279E-05 + .5096E-05 + .4004E-05 + .3033E-05 + .2207E-05 + .1543E-05 + .9733E-06 + .5143E-06 + .2466E-06 + .1734E-06 + .1219E-06 + .8569E-07 + .6768E-07 + .5548E-07 + .4793E-07 + .4575E-07 + .4367E-07 + .4257E-07 + .4192E-07 + .4127E-07 + .4052E-07 + .3837E-07 + .3634E-07 + .3206E-07 + .2486E-07 + .1840E-07 + .1637E-07 + .1653E-05 + .1775E-05 + .1899E-05 + .2012E-05 + .2142E-05 + .2292E-05 + .2466E-05 + .2661E-05 + .2866E-05 + .3109E-05 + .3418E-05 + .3682E-05 + .3973E-05 + .4352E-05 + .4810E-05 + .5328E-05 + .5828E-05 + .6382E-05 + .6974E-05 + .7603E-05 + .8192E-05 + .8644E-05 + .9016E-05 + .9437E-05 + .9756E-05 + .1015E-04 + .1046E-04 + .1041E-04 + .1004E-04 + .9434E-05 + .8577E-05 + .7475E-05 + .6298E-05 + .5140E-05 + .4059E-05 + .3096E-05 + .2263E-05 + .1577E-05 + .9942E-06 + .5316E-06 + .2593E-06 + .1877E-06 + .1359E-06 + .9836E-07 + .7708E-07 + .6140E-07 + .5186E-07 + .4898E-07 + .4627E-07 + .4496E-07 + .4428E-07 + .4361E-07 + .4282E-07 + .4068E-07 + .3864E-07 + .3366E-07 + .2568E-07 + .1921E-07 + .1714E-07 + .1676E-05 + .1800E-05 + .1927E-05 + .2044E-05 + .2177E-05 + .2326E-05 + .2496E-05 + .2693E-05 + .2886E-05 + .3133E-05 + .3428E-05 + .3677E-05 + .3976E-05 + .4404E-05 + .4913E-05 + .5435E-05 + .5989E-05 + .6534E-05 + .7131E-05 + .7716E-05 + .8326E-05 + .8751E-05 + .9088E-05 + .9470E-05 + .9794E-05 + .1018E-04 + .1046E-04 + .1038E-04 + .9959E-05 + .9341E-05 + .8515E-05 + .7451E-05 + .6311E-05 + .5179E-05 + .4110E-05 + .3155E-05 + .2321E-05 + .1610E-05 + .1017E-05 + .5526E-06 + .2753E-06 + .2045E-06 + .1519E-06 + .1128E-06 + .8774E-07 + .6791E-07 + .5609E-07 + .5242E-07 + .4900E-07 + .4746E-07 + .4675E-07 + .4605E-07 + .4524E-07 + .4310E-07 + .4107E-07 + .3531E-07 + .2652E-07 + .2004E-07 + .1794E-07 + .1691E-05 + .1812E-05 + .1934E-05 + .2055E-05 + .2192E-05 + .2353E-05 + .2525E-05 + .2751E-05 + .2896E-05 + .3149E-05 + .3447E-05 + .3703E-05 + .4029E-05 + .4434E-05 + .4892E-05 + .5410E-05 + .5954E-05 + .6568E-05 + .7190E-05 + .7760E-05 + .8325E-05 + .8812E-05 + .9129E-05 + .9522E-05 + .9835E-05 + .1013E-04 + .1032E-04 + .1023E-04 + .9800E-05 + .9187E-05 + .8405E-05 + .7402E-05 + .6312E-05 + .5199E-05 + .4148E-05 + .3213E-05 + .2384E-05 + .1677E-05 + .1073E-05 + .5938E-06 + .3034E-06 + .2283E-06 + .1718E-06 + .1293E-06 + .9976E-07 + .7503E-07 + .6059E-07 + .5604E-07 + .5183E-07 + .5004E-07 + .4930E-07 + .4857E-07 + .4773E-07 + .4562E-07 + .4361E-07 + .3701E-07 + .2735E-07 + .2088E-07 + .1875E-07 + .1704E-05 + .1825E-05 + .1948E-05 + .2073E-05 + .2215E-05 + .2384E-05 + .2559E-05 + .2805E-05 + .2921E-05 + .3181E-05 + .3476E-05 + .3742E-05 + .4087E-05 + .4475E-05 + .4901E-05 + .5416E-05 + .5960E-05 + .6620E-05 + .7261E-05 + .7824E-05 + .8349E-05 + .8869E-05 + .9176E-05 + .9566E-05 + .9861E-05 + .1007E-04 + .1018E-04 + .1007E-04 + .9641E-05 + .9041E-05 + .8295E-05 + .7347E-05 + .6306E-05 + .5219E-05 + .4189E-05 + .3271E-05 + .2448E-05 + .1741E-05 + .1131E-05 + .6380E-06 + .3362E-06 + .2559E-06 + .1948E-06 + .1483E-06 + .1135E-06 + .8292E-07 + .6548E-07 + .5993E-07 + .5485E-07 + .5278E-07 + .5201E-07 + .5125E-07 + .5039E-07 + .4831E-07 + .4631E-07 + .3880E-07 + .2822E-07 + .2177E-07 + .1960E-07 + .1709E-05 + .1845E-05 + .1982E-05 + .2114E-05 + .2260E-05 + .2429E-05 + .2608E-05 + .2842E-05 + .2998E-05 + .3269E-05 + .3535E-05 + .3821E-05 + .4161E-05 + .4555E-05 + .5010E-05 + .5530E-05 + .6100E-05 + .6734E-05 + .7364E-05 + .7953E-05 + .8455E-05 + .8907E-05 + .9235E-05 + .9576E-05 + .9831E-05 + .9990E-05 + .1004E-04 + .9891E-05 + .9472E-05 + .8912E-05 + .8183E-05 + .7269E-05 + .6273E-05 + .5237E-05 + .4234E-05 + .3324E-05 + .2506E-05 + .1792E-05 + .1183E-05 + .6850E-06 + .3792E-06 + .2903E-06 + .2222E-06 + .1701E-06 + .1292E-06 + .9173E-07 + .7082E-07 + .6414E-07 + .5809E-07 + .5571E-07 + .5491E-07 + .5412E-07 + .5323E-07 + .5119E-07 + .4923E-07 + .4071E-07 + .2914E-07 + .2271E-07 + .2051E-07 + .1727E-05 + .1872E-05 + .2018E-05 + .2154E-05 + .2302E-05 + .2468E-05 + .2648E-05 + .2870E-05 + .3054E-05 + .3325E-05 + .3576E-05 + .3871E-05 + .4209E-05 + .4611E-05 + .5073E-05 + .5604E-05 + .6192E-05 + .6810E-05 + .7432E-05 + .8023E-05 + .8515E-05 + .8919E-05 + .9255E-05 + .9557E-05 + .9777E-05 + .9899E-05 + .9912E-05 + .9729E-05 + .9337E-05 + .8807E-05 + .8098E-05 + .7219E-05 + .6264E-05 + .5271E-05 + .4294E-05 + .3395E-05 + .2584E-05 + .1863E-05 + .1243E-05 + .7434E-06 + .4323E-06 + .3231E-06 + .2414E-06 + .1804E-06 + .1378E-06 + .9780E-07 + .7550E-07 + .6843E-07 + .6202E-07 + .5929E-07 + .5813E-07 + .5700E-07 + .5576E-07 + .5316E-07 + .5069E-07 + .4198E-07 + .3058E-07 + .2421E-07 + .2201E-07 + .1761E-05 + .1907E-05 + .2052E-05 + .2189E-05 + .2333E-05 + .2495E-05 + .2670E-05 + .2880E-05 + .3076E-05 + .3332E-05 + .3587E-05 + .3877E-05 + .4216E-05 + .4629E-05 + .5066E-05 + .5614E-05 + .6206E-05 + .6823E-05 + .7439E-05 + .8000E-05 + .8499E-05 + .8883E-05 + .9210E-05 + .9484E-05 + .9677E-05 + .9780E-05 + .9769E-05 + .9575E-05 + .9229E-05 + .8716E-05 + .8034E-05 + .7193E-05 + .6273E-05 + .5313E-05 + .4367E-05 + .3482E-05 + .2687E-05 + .1959E-05 + .1313E-05 + .8164E-06 + .4990E-06 + .3503E-06 + .2460E-06 + .1727E-06 + .1351E-06 + .9929E-07 + .7885E-07 + .7257E-07 + .6680E-07 + .6365E-07 + .6165E-07 + .5972E-07 + .5767E-07 + .5369E-07 + .4999E-07 + .4225E-07 + .3269E-07 + .2649E-07 + .2436E-07 + .1773E-05 + .1919E-05 + .2064E-05 + .2206E-05 + .2353E-05 + .2514E-05 + .2692E-05 + .2897E-05 + .3105E-05 + .3348E-05 + .3612E-05 + .3900E-05 + .4234E-05 + .4646E-05 + .5097E-05 + .5632E-05 + .6214E-05 + .6825E-05 + .7438E-05 + .7991E-05 + .8479E-05 + .8864E-05 + .9189E-05 + .9435E-05 + .9606E-05 + .9683E-05 + .9654E-05 + .9456E-05 + .9121E-05 + .8612E-05 + .7958E-05 + .7156E-05 + .6271E-05 + .5339E-05 + .4433E-05 + .3580E-05 + .2787E-05 + .2053E-05 + .1392E-05 + .8942E-06 + .5602E-06 + .3731E-06 + .2485E-06 + .1655E-06 + .1326E-06 + .1010E-06 + .8247E-07 + .7708E-07 + .7205E-07 + .6843E-07 + .6548E-07 + .6267E-07 + .5973E-07 + .5431E-07 + .4938E-07 + .4259E-07 + .3500E-07 + .2902E-07 + .2700E-07 + .1754E-05 + .1898E-05 + .2042E-05 + .2188E-05 + .2341E-05 + .2503E-05 + .2685E-05 + .2886E-05 + .3103E-05 + .3333E-05 + .3608E-05 + .3892E-05 + .4213E-05 + .4614E-05 + .5092E-05 + .5593E-05 + .6152E-05 + .6749E-05 + .7352E-05 + .7904E-05 + .8366E-05 + .8760E-05 + .9084E-05 + .9297E-05 + .9449E-05 + .9494E-05 + .9453E-05 + .9256E-05 + .8917E-05 + .8410E-05 + .7793E-05 + .7037E-05 + .6194E-05 + .5298E-05 + .4447E-05 + .3645E-05 + .2856E-05 + .2123E-05 + .1463E-05 + .9675E-06 + .6127E-06 + .4233E-06 + .2925E-06 + .2021E-06 + .1628E-06 + .1246E-06 + .1003E-06 + .8877E-07 + .7858E-07 + .7270E-07 + .6870E-07 + .6491E-07 + .6115E-07 + .5564E-07 + .5063E-07 + .4458E-07 + .3808E-07 + .3252E-07 + .3062E-07 + .1749E-05 + .1877E-05 + .2009E-05 + .2152E-05 + .2303E-05 + .2464E-05 + .2646E-05 + .2842E-05 + .3061E-05 + .3286E-05 + .3556E-05 + .3861E-05 + .4173E-05 + .4573E-05 + .5046E-05 + .5540E-05 + .6102E-05 + .6684E-05 + .7263E-05 + .7813E-05 + .8258E-05 + .8610E-05 + .8918E-05 + .9121E-05 + .9259E-05 + .9284E-05 + .9228E-05 + .9032E-05 + .8694E-05 + .8181E-05 + .7586E-05 + .6834E-05 + .6033E-05 + .5202E-05 + .4400E-05 + .3642E-05 + .2901E-05 + .2196E-05 + .1560E-05 + .1061E-05 + .6981E-06 + .5065E-06 + .3675E-06 + .2666E-06 + .2145E-06 + .1636E-06 + .1278E-06 + .1047E-06 + .8574E-07 + .7669E-07 + .7154E-07 + .6673E-07 + .6217E-07 + .5707E-07 + .5240E-07 + .4710E-07 + .4151E-07 + .3659E-07 + .3486E-07 + .1748E-05 + .1859E-05 + .1980E-05 + .2116E-05 + .2264E-05 + .2425E-05 + .2605E-05 + .2798E-05 + .3018E-05 + .3240E-05 + .3501E-05 + .3829E-05 + .4135E-05 + .4535E-05 + .4996E-05 + .5489E-05 + .6057E-05 + .6628E-05 + .7184E-05 + .7730E-05 + .8161E-05 + .8469E-05 + .8757E-05 + .8954E-05 + .9078E-05 + .9085E-05 + .9014E-05 + .8818E-05 + .8482E-05 + .7964E-05 + .7387E-05 + .6635E-05 + .5872E-05 + .5108E-05 + .4351E-05 + .3634E-05 + .2947E-05 + .2274E-05 + .1668E-05 + .1167E-05 + .8014E-06 + .6091E-06 + .4630E-06 + .3519E-06 + .2829E-06 + .2148E-06 + .1630E-06 + .1235E-06 + .9361E-07 + .8096E-07 + .7455E-07 + .6865E-07 + .6324E-07 + .5858E-07 + .5426E-07 + .4979E-07 + .4529E-07 + .4119E-07 + .3973E-07 + .1732E-05 + .1844E-05 + .1960E-05 + .2088E-05 + .2229E-05 + .2388E-05 + .2563E-05 + .2763E-05 + .2971E-05 + .3213E-05 + .3444E-05 + .3752E-05 + .4058E-05 + .4449E-05 + .4889E-05 + .5386E-05 + .5940E-05 + .6497E-05 + .7079E-05 + .7598E-05 + .8008E-05 + .8342E-05 + .8576E-05 + .8755E-05 + .8847E-05 + .8850E-05 + .8758E-05 + .8541E-05 + .8210E-05 + .7719E-05 + .7148E-05 + .6452E-05 + .5742E-05 + .5026E-05 + .4318E-05 + .3641E-05 + .2994E-05 + .2355E-05 + .1748E-05 + .1265E-05 + .9039E-06 + .7249E-06 + .5814E-06 + .4663E-06 + .3745E-06 + .2832E-06 + .2087E-06 + .1463E-06 + .1026E-06 + .8578E-07 + .7798E-07 + .7089E-07 + .6458E-07 + .6036E-07 + .5641E-07 + .5283E-07 + .4959E-07 + .4655E-07 + .4544E-07 + .1755E-05 + .1875E-05 + .1991E-05 + .2116E-05 + .2253E-05 + .2409E-05 + .2583E-05 + .2781E-05 + .2989E-05 + .3241E-05 + .3463E-05 + .3757E-05 + .4076E-05 + .4472E-05 + .4895E-05 + .5398E-05 + .5945E-05 + .6498E-05 + .7096E-05 + .7599E-05 + .8002E-05 + .8333E-05 + .8548E-05 + .8706E-05 + .8771E-05 + .8764E-05 + .8674E-05 + .8439E-05 + .8109E-05 + .7635E-05 + .7065E-05 + .6400E-05 + .5712E-05 + .5025E-05 + .4346E-05 + .3695E-05 + .3084E-05 + .2464E-05 + .1855E-05 + .1372E-05 + .1007E-05 + .8187E-06 + .6655E-06 + .5410E-06 + .4346E-06 + .3335E-06 + .2444E-06 + .1641E-06 + .1102E-06 + .9004E-07 + .8074E-07 + .7241E-07 + .6514E-07 + .6086E-07 + .5687E-07 + .5326E-07 + .4999E-07 + .4692E-07 + .4580E-07 + .1813E-05 + .1952E-05 + .2080E-05 + .2209E-05 + .2349E-05 + .2496E-05 + .2664E-05 + .2829E-05 + .3060E-05 + .3282E-05 + .3546E-05 + .3832E-05 + .4186E-05 + .4613E-05 + .5006E-05 + .5504E-05 + .6037E-05 + .6587E-05 + .7152E-05 + .7651E-05 + .8069E-05 + .8304E-05 + .8579E-05 + .8704E-05 + .8747E-05 + .8715E-05 + .8687E-05 + .8447E-05 + .8121E-05 + .7659E-05 + .7103E-05 + .6432E-05 + .5718E-05 + .5040E-05 + .4367E-05 + .3731E-05 + .3164E-05 + .2547E-05 + .1958E-05 + .1428E-05 + .1043E-05 + .8676E-06 + .7216E-06 + .6001E-06 + .4823E-06 + .3783E-06 + .2785E-06 + .1815E-06 + .1183E-06 + .9484E-07 + .8388E-07 + .7418E-07 + .6588E-07 + .6131E-07 + .5706E-07 + .5300E-07 + .4913E-07 + .4554E-07 + .4424E-07 + .1834E-05 + .1979E-05 + .2112E-05 + .2247E-05 + .2392E-05 + .2541E-05 + .2709E-05 + .2876E-05 + .3092E-05 + .3317E-05 + .3583E-05 + .3861E-05 + .4230E-05 + .4657E-05 + .5042E-05 + .5546E-05 + .6056E-05 + .6618E-05 + .7175E-05 + .7642E-05 + .8052E-05 + .8245E-05 + .8525E-05 + .8617E-05 + .8641E-05 + .8593E-05 + .8564E-05 + .8319E-05 + .7988E-05 + .7536E-05 + .6999E-05 + .6332E-05 + .5641E-05 + .4973E-05 + .4331E-05 + .3743E-05 + .3215E-05 + .2625E-05 + .2057E-05 + .1511E-05 + .1107E-05 + .9301E-06 + .7815E-06 + .6566E-06 + .5280E-06 + .4234E-06 + .3130E-06 + .1980E-06 + .1253E-06 + .9855E-07 + .8596E-07 + .7498E-07 + .6572E-07 + .6092E-07 + .5648E-07 + .5202E-07 + .4763E-07 + .4361E-07 + .4216E-07 + .1816E-05 + .1950E-05 + .2082E-05 + .2221E-05 + .2375E-05 + .2540E-05 + .2715E-05 + .2923E-05 + .3081E-05 + .3346E-05 + .3571E-05 + .3842E-05 + .4201E-05 + .4596E-05 + .4997E-05 + .5522E-05 + .6000E-05 + .6590E-05 + .7164E-05 + .7572E-05 + .7951E-05 + .8159E-05 + .8387E-05 + .8446E-05 + .8455E-05 + .8399E-05 + .8303E-05 + .8053E-05 + .7709E-05 + .7265E-05 + .6752E-05 + .6098E-05 + .5483E-05 + .4824E-05 + .4239E-05 + .3730E-05 + .3235E-05 + .2699E-05 + .2150E-05 + .1628E-05 + .1207E-05 + .1010E-05 + .8459E-06 + .7083E-06 + .5699E-06 + .4672E-06 + .3468E-06 + .2130E-06 + .1308E-06 + .1010E-06 + .8685E-07 + .7471E-07 + .6463E-07 + .5968E-07 + .5512E-07 + .5035E-07 + .4553E-07 + .4117E-07 + .3961E-07 + .1771E-05 + .1895E-05 + .2024E-05 + .2160E-05 + .2311E-05 + .2475E-05 + .2649E-05 + .2858E-05 + .3019E-05 + .3270E-05 + .3489E-05 + .3758E-05 + .4101E-05 + .4469E-05 + .4879E-05 + .5375E-05 + .5874E-05 + .6434E-05 + .6983E-05 + .7391E-05 + .7730E-05 + .7946E-05 + .8135E-05 + .8181E-05 + .8181E-05 + .8107E-05 + .7982E-05 + .7728E-05 + .7389E-05 + .6952E-05 + .6455E-05 + .5853E-05 + .5273E-05 + .4664E-05 + .4156E-05 + .3706E-05 + .3245E-05 + .2754E-05 + .2239E-05 + .1733E-05 + .1300E-05 + .1081E-05 + .8994E-06 + .7482E-06 + .6032E-06 + .5020E-06 + .3734E-06 + .2242E-06 + .1347E-06 + .1024E-06 + .8703E-07 + .7400E-07 + .6332E-07 + .5827E-07 + .5363E-07 + .4896E-07 + .4436E-07 + .4020E-07 + .3871E-07 + .1713E-05 + .1828E-05 + .1951E-05 + .2081E-05 + .2224E-05 + .2379E-05 + .2549E-05 + .2739E-05 + .2930E-05 + .3144E-05 + .3372E-05 + .3640E-05 + .3963E-05 + .4310E-05 + .4722E-05 + .5169E-05 + .5708E-05 + .6215E-05 + .6718E-05 + .7150E-05 + .7447E-05 + .7668E-05 + .7825E-05 + .7867E-05 + .7860E-05 + .7766E-05 + .7630E-05 + .7372E-05 + .7046E-05 + .6617E-05 + .6135E-05 + .5599E-05 + .5037E-05 + .4493E-05 + .4069E-05 + .3672E-05 + .3245E-05 + .2797E-05 + .2324E-05 + .1830E-05 + .1390E-05 + .1147E-05 + .9467E-06 + .7814E-06 + .6315E-06 + .5318E-06 + .3960E-06 + .2333E-06 + .1374E-06 + .1031E-06 + .8673E-07 + .7296E-07 + .6180E-07 + .5670E-07 + .5202E-07 + .4763E-07 + .4353E-07 + .3979E-07 + .3845E-07 + .1692E-05 + .1805E-05 + .1921E-05 + .2043E-05 + .2179E-05 + .2326E-05 + .2489E-05 + .2667E-05 + .2857E-05 + .3063E-05 + .3281E-05 + .3539E-05 + .3847E-05 + .4191E-05 + .4590E-05 + .5031E-05 + .5535E-05 + .6017E-05 + .6482E-05 + .6876E-05 + .7151E-05 + .7349E-05 + .7472E-05 + .7501E-05 + .7475E-05 + .7370E-05 + .7218E-05 + .6961E-05 + .6644E-05 + .6217E-05 + .5769E-05 + .5286E-05 + .4781E-05 + .4302E-05 + .3937E-05 + .3608E-05 + .3233E-05 + .2826E-05 + .2384E-05 + .1895E-05 + .1461E-05 + .1202E-05 + .9884E-06 + .8131E-06 + .6588E-06 + .5613E-06 + .4185E-06 + .2419E-06 + .1398E-06 + .1035E-06 + .8611E-07 + .7168E-07 + .6011E-07 + .5497E-07 + .5027E-07 + .4616E-07 + .4256E-07 + .3924E-07 + .3804E-07 + .1666E-05 + .1776E-05 + .1885E-05 + .2001E-05 + .2128E-05 + .2268E-05 + .2423E-05 + .2589E-05 + .2773E-05 + .2972E-05 + .3179E-05 + .3423E-05 + .3716E-05 + .4058E-05 + .4441E-05 + .4877E-05 + .5338E-05 + .5797E-05 + .6223E-05 + .6576E-05 + .6829E-05 + .7003E-05 + .7094E-05 + .7110E-05 + .7067E-05 + .6952E-05 + .6788E-05 + .6533E-05 + .6224E-05 + .5803E-05 + .5393E-05 + .4958E-05 + .4511E-05 + .4094E-05 + .3785E-05 + .3520E-05 + .3199E-05 + .2832E-05 + .2422E-05 + .1941E-05 + .1520E-05 + .1239E-05 + .1011E-05 + .8245E-06 + .6661E-06 + .5749E-06 + .4343E-06 + .2545E-06 + .1492E-06 + .1098E-06 + .9012E-07 + .7394E-07 + .6116E-07 + .5548E-07 + .5033E-07 + .4535E-07 + .4061E-07 + .3636E-07 + .3485E-07 + .1662E-05 + .1769E-05 + .1877E-05 + .1991E-05 + .2114E-05 + .2249E-05 + .2397E-05 + .2556E-05 + .2732E-05 + .2917E-05 + .3123E-05 + .3358E-05 + .3640E-05 + .3984E-05 + .4359E-05 + .4774E-05 + .5231E-05 + .5668E-05 + .6070E-05 + .6401E-05 + .6628E-05 + .6787E-05 + .6857E-05 + .6862E-05 + .6799E-05 + .6674E-05 + .6495E-05 + .6231E-05 + .5920E-05 + .5510E-05 + .5128E-05 + .4716E-05 + .4322E-05 + .3943E-05 + .3693E-05 + .3463E-05 + .3170E-05 + .2825E-05 + .2431E-05 + .1966E-05 + .1559E-05 + .1268E-05 + .1032E-05 + .8395E-06 + .6762E-06 + .5912E-06 + .4526E-06 + .2690E-06 + .1598E-06 + .1171E-06 + .9470E-07 + .7660E-07 + .6249E-07 + .5624E-07 + .5061E-07 + .4474E-07 + .3890E-07 + .3382E-07 + .3206E-07 + .1664E-05 + .1771E-05 + .1879E-05 + .1994E-05 + .2117E-05 + .2251E-05 + .2397E-05 + .2553E-05 + .2726E-05 + .2907E-05 + .3114E-05 + .3341E-05 + .3622E-05 + .3958E-05 + .4317E-05 + .4709E-05 + .5146E-05 + .5535E-05 + .5866E-05 + .6155E-05 + .6379E-05 + .6569E-05 + .6617E-05 + .6547E-05 + .6430E-05 + .6279E-05 + .6094E-05 + .5861E-05 + .5602E-05 + .5244E-05 + .4900E-05 + .4541E-05 + .4211E-05 + .3881E-05 + .3650E-05 + .3430E-05 + .3143E-05 + .2820E-05 + .2435E-05 + .1991E-05 + .1608E-05 + .1307E-05 + .1063E-05 + .8641E-06 + .6941E-06 + .6147E-06 + .4768E-06 + .2873E-06 + .1732E-06 + .1262E-06 + .1006E-06 + .8023E-07 + .6455E-07 + .5763E-07 + .5145E-07 + .4462E-07 + .3767E-07 + .3181E-07 + .2982E-07 + .1691E-05 + .1800E-05 + .1912E-05 + .2031E-05 + .2158E-05 + .2299E-05 + .2449E-05 + .2609E-05 + .2786E-05 + .2981E-05 + .3189E-05 + .3417E-05 + .3708E-05 + .4023E-05 + .4361E-05 + .4720E-05 + .5108E-05 + .5429E-05 + .5664E-05 + .5891E-05 + .6122E-05 + .6341E-05 + .6362E-05 + .6183E-05 + .5999E-05 + .5816E-05 + .5638E-05 + .5465E-05 + .5298E-05 + .5036E-05 + .4746E-05 + .4466E-05 + .4203E-05 + .3929E-05 + .3673E-05 + .3427E-05 + .3122E-05 + .2818E-05 + .2423E-05 + .2000E-05 + .1641E-05 + .1346E-05 + .1105E-05 + .9065E-06 + .7260E-06 + .6513E-06 + .5119E-06 + .3128E-06 + .1912E-06 + .1386E-06 + .1089E-06 + .8563E-07 + .6796E-07 + .6018E-07 + .5330E-07 + .4535E-07 + .3718E-07 + .3049E-07 + .2826E-07 + .1727E-05 + .1836E-05 + .1950E-05 + .2071E-05 + .2198E-05 + .2337E-05 + .2485E-05 + .2643E-05 + .2821E-05 + .3017E-05 + .3226E-05 + .3458E-05 + .3747E-05 + .4059E-05 + .4382E-05 + .4706E-05 + .5055E-05 + .5362E-05 + .5605E-05 + .5800E-05 + .5984E-05 + .6104E-05 + .6093E-05 + .5951E-05 + .5776E-05 + .5592E-05 + .5413E-05 + .5240E-05 + .5073E-05 + .4846E-05 + .4597E-05 + .4342E-05 + .4102E-05 + .3857E-05 + .3626E-05 + .3385E-05 + .3092E-05 + .2806E-05 + .2398E-05 + .1980E-05 + .1619E-05 + .1351E-05 + .1127E-05 + .9406E-06 + .7511E-06 + .6825E-06 + .5437E-06 + .3369E-06 + .2088E-06 + .1505E-06 + .1167E-06 + .9040E-07 + .7076E-07 + .6216E-07 + .5461E-07 + .4559E-07 + .3630E-07 + .2890E-07 + .2649E-07 + .1770E-05 + .1880E-05 + .1995E-05 + .2118E-05 + .2246E-05 + .2384E-05 + .2530E-05 + .2686E-05 + .2867E-05 + .3064E-05 + .3274E-05 + .3511E-05 + .3798E-05 + .4109E-05 + .4418E-05 + .4709E-05 + .5019E-05 + .5314E-05 + .5565E-05 + .5729E-05 + .5869E-05 + .5897E-05 + .5855E-05 + .5746E-05 + .5580E-05 + .5395E-05 + .5215E-05 + .5042E-05 + .4874E-05 + .4678E-05 + .4468E-05 + .4236E-05 + .4016E-05 + .3798E-05 + .3592E-05 + .3356E-05 + .3073E-05 + .2804E-05 + .2381E-05 + .1966E-05 + .1603E-05 + .1351E-05 + .1139E-05 + .9603E-06 + .7660E-06 + .6995E-06 + .5600E-06 + .3488E-06 + .2173E-06 + .1564E-06 + .1205E-06 + .9290E-07 + .7234E-07 + .6336E-07 + .5550E-07 + .4600E-07 + .3622E-07 + .2852E-07 + .2603E-07 + .1818E-05 + .1929E-05 + .2047E-05 + .2171E-05 + .2301E-05 + .2438E-05 + .2583E-05 + .2737E-05 + .2921E-05 + .3120E-05 + .3332E-05 + .3574E-05 + .3860E-05 + .4169E-05 + .4466E-05 + .4723E-05 + .4996E-05 + .5279E-05 + .5540E-05 + .5674E-05 + .5771E-05 + .5710E-05 + .5641E-05 + .5562E-05 + .5404E-05 + .5217E-05 + .5037E-05 + .4863E-05 + .4695E-05 + .4528E-05 + .4353E-05 + .4143E-05 + .3942E-05 + .3750E-05 + .3567E-05 + .3335E-05 + .3061E-05 + .2808E-05 + .2370E-05 + .1957E-05 + .1591E-05 + .1350E-05 + .1145E-05 + .9714E-06 + .7748E-06 + .7075E-06 + .5664E-06 + .3528E-06 + .2198E-06 + .1582E-06 + .1219E-06 + .9397E-07 + .7317E-07 + .6409E-07 + .5613E-07 + .4653E-07 + .3664E-07 + .2885E-07 + .2633E-07 + .1852E-05 + .1966E-05 + .2087E-05 + .2213E-05 + .2341E-05 + .2476E-05 + .2619E-05 + .2770E-05 + .2954E-05 + .3154E-05 + .3367E-05 + .3605E-05 + .3877E-05 + .4169E-05 + .4453E-05 + .4708E-05 + .4977E-05 + .5240E-05 + .5458E-05 + .5576E-05 + .5648E-05 + .5571E-05 + .5495E-05 + .5417E-05 + .5270E-05 + .5102E-05 + .4938E-05 + .4780E-05 + .4621E-05 + .4460E-05 + .4295E-05 + .4102E-05 + .3918E-05 + .3742E-05 + .3574E-05 + .3336E-05 + .3071E-05 + .2827E-05 + .2382E-05 + .1970E-05 + .1606E-05 + .1363E-05 + .1157E-05 + .9818E-06 + .7831E-06 + .7151E-06 + .5725E-06 + .3566E-06 + .2222E-06 + .1599E-06 + .1232E-06 + .9498E-07 + .7396E-07 + .6478E-07 + .5674E-07 + .4702E-07 + .3703E-07 + .2916E-07 + .2662E-07 + .1884E-05 + .2002E-05 + .2127E-05 + .2255E-05 + .2381E-05 + .2514E-05 + .2654E-05 + .2802E-05 + .2987E-05 + .3187E-05 + .3401E-05 + .3634E-05 + .3888E-05 + .4161E-05 + .4433E-05 + .4691E-05 + .4963E-05 + .5205E-05 + .5372E-05 + .5475E-05 + .5527E-05 + .5448E-05 + .5371E-05 + .5287E-05 + .5152E-05 + .5004E-05 + .4861E-05 + .4721E-05 + .4574E-05 + .4413E-05 + .4253E-05 + .4076E-05 + .3907E-05 + .3745E-05 + .3590E-05 + .3345E-05 + .3088E-05 + .2852E-05 + .2401E-05 + .1990E-05 + .1628E-05 + .1381E-05 + .1171E-05 + .9930E-06 + .7921E-06 + .7233E-06 + .5790E-06 + .3607E-06 + .2247E-06 + .1617E-06 + .1246E-06 + .9606E-07 + .7480E-07 + .6552E-07 + .5738E-07 + .4756E-07 + .3745E-07 + .2949E-07 + .2692E-07 + .1901E-05 + .2022E-05 + .2150E-05 + .2279E-05 + .2402E-05 + .2531E-05 + .2668E-05 + .2812E-05 + .2995E-05 + .3194E-05 + .3406E-05 + .3632E-05 + .3867E-05 + .4118E-05 + .4377E-05 + .4637E-05 + .4909E-05 + .5128E-05 + .5244E-05 + .5334E-05 + .5365E-05 + .5286E-05 + .5208E-05 + .5118E-05 + .4996E-05 + .4869E-05 + .4746E-05 + .4625E-05 + .4490E-05 + .4332E-05 + .4177E-05 + .4018E-05 + .3865E-05 + .3718E-05 + .3577E-05 + .3326E-05 + .3080E-05 + .2853E-05 + .2401E-05 + .1994E-05 + .1637E-05 + .1387E-05 + .1176E-05 + .9961E-06 + .7946E-06 + .7255E-06 + .5808E-06 + .3618E-06 + .2254E-06 + .1622E-06 + .1250E-06 + .9636E-07 + .7504E-07 + .6572E-07 + .5756E-07 + .4771E-07 + .3757E-07 + .2959E-07 + .2700E-07 + .7028E-06 + .8000E-06 + .9107E-06 + .1036E-05 + .1164E-05 + .1302E-05 + .1435E-05 + .1557E-05 + .1689E-05 + .1837E-05 + .2001E-05 + .2174E-05 + .2349E-05 + .2534E-05 + .2737E-05 + .2959E-05 + .3172E-05 + .3402E-05 + .3564E-05 + .3647E-05 + .3731E-05 + .3818E-05 + .3892E-05 + .3890E-05 + .3829E-05 + .3768E-05 + .3708E-05 + .3650E-05 + .3592E-05 + .3526E-05 + .3387E-05 + .3183E-05 + .2992E-05 + .2787E-05 + .2572E-05 + .2375E-05 + .2181E-05 + .1909E-05 + .1657E-05 + .1438E-05 + .1116E-05 + .9454E-06 + .8011E-06 + .6789E-06 + .4396E-06 + .2854E-06 + .1805E-06 + .1086E-06 + .6538E-07 + .5038E-07 + .4365E-07 + .3782E-07 + .3300E-07 + .3114E-07 + .2939E-07 + .2650E-07 + .2291E-07 + .1981E-07 + .1874E-07 + .7279E-06 + .8303E-06 + .9471E-06 + .1078E-05 + .1205E-05 + .1342E-05 + .1480E-05 + .1617E-05 + .1766E-05 + .1932E-05 + .2113E-05 + .2297E-05 + .2489E-05 + .2699E-05 + .2934E-05 + .3186E-05 + .3386E-05 + .3599E-05 + .3753E-05 + .3840E-05 + .3930E-05 + .4021E-05 + .4078E-05 + .4056E-05 + .3994E-05 + .3934E-05 + .3874E-05 + .3815E-05 + .3757E-05 + .3679E-05 + .3552E-05 + .3382E-05 + .3219E-05 + .3002E-05 + .2742E-05 + .2505E-05 + .2281E-05 + .2001E-05 + .1723E-05 + .1484E-05 + .1154E-05 + .9734E-06 + .8211E-06 + .6925E-06 + .4484E-06 + .2911E-06 + .1841E-06 + .1108E-06 + .6669E-07 + .5139E-07 + .4453E-07 + .3858E-07 + .3366E-07 + .3177E-07 + .2998E-07 + .2703E-07 + .2337E-07 + .2020E-07 + .1911E-07 + .7527E-06 + .8604E-06 + .9834E-06 + .1121E-05 + .1245E-05 + .1381E-05 + .1525E-05 + .1677E-05 + .1843E-05 + .2028E-05 + .2227E-05 + .2423E-05 + .2633E-05 + .2870E-05 + .3142E-05 + .3427E-05 + .3609E-05 + .3801E-05 + .3946E-05 + .4038E-05 + .4132E-05 + .4228E-05 + .4265E-05 + .4222E-05 + .4161E-05 + .4100E-05 + .4040E-05 + .3981E-05 + .3923E-05 + .3832E-05 + .3719E-05 + .3587E-05 + .3459E-05 + .3229E-05 + .2919E-05 + .2639E-05 + .2382E-05 + .2095E-05 + .1790E-05 + .1528E-05 + .1192E-05 + .1001E-05 + .8400E-06 + .7052E-06 + .4566E-06 + .2965E-06 + .1875E-06 + .1128E-06 + .6791E-07 + .5233E-07 + .4534E-07 + .3929E-07 + .3428E-07 + .3235E-07 + .3053E-07 + .2753E-07 + .2380E-07 + .2057E-07 + .1946E-07 + .7790E-06 + .8921E-06 + .1021E-05 + .1163E-05 + .1287E-05 + .1423E-05 + .1574E-05 + .1740E-05 + .1924E-05 + .2128E-05 + .2347E-05 + .2558E-05 + .2787E-05 + .3052E-05 + .3356E-05 + .3672E-05 + .3842E-05 + .4016E-05 + .4151E-05 + .4246E-05 + .4344E-05 + .4440E-05 + .4456E-05 + .4394E-05 + .4332E-05 + .4271E-05 + .4209E-05 + .4147E-05 + .4086E-05 + .3982E-05 + .3880E-05 + .3782E-05 + .3685E-05 + .3450E-05 + .3095E-05 + .2774E-05 + .2486E-05 + .2193E-05 + .1861E-05 + .1575E-05 + .1229E-05 + .1027E-05 + .8588E-06 + .7178E-06 + .4648E-06 + .3018E-06 + .1909E-06 + .1149E-06 + .6913E-07 + .5327E-07 + .4616E-07 + .4000E-07 + .3489E-07 + .3293E-07 + .3107E-07 + .2802E-07 + .2422E-07 + .2094E-07 + .1981E-07 + .8154E-06 + .9346E-06 + .1063E-05 + .1206E-05 + .1340E-05 + .1487E-05 + .1649E-05 + .1828E-05 + .2027E-05 + .2247E-05 + .2486E-05 + .2727E-05 + .2980E-05 + .3268E-05 + .3573E-05 + .3886E-05 + .4096E-05 + .4280E-05 + .4403E-05 + .4497E-05 + .4593E-05 + .4667E-05 + .4660E-05 + .4595E-05 + .4531E-05 + .4468E-05 + .4394E-05 + .4310E-05 + .4228E-05 + .4115E-05 + .4005E-05 + .3899E-05 + .3795E-05 + .3591E-05 + .3237E-05 + .2903E-05 + .2604E-05 + .2310E-05 + .1960E-05 + .1633E-05 + .1267E-05 + .1057E-05 + .8809E-06 + .7345E-06 + .4756E-06 + .3088E-06 + .1953E-06 + .1175E-06 + .7073E-07 + .5450E-07 + .4722E-07 + .4092E-07 + .3570E-07 + .3369E-07 + .3179E-07 + .2867E-07 + .2478E-07 + .2143E-07 + .2027E-07 + .8537E-06 + .9792E-06 + .1107E-05 + .1251E-05 + .1395E-05 + .1554E-05 + .1727E-05 + .1920E-05 + .2134E-05 + .2373E-05 + .2635E-05 + .2907E-05 + .3187E-05 + .3500E-05 + .3804E-05 + .4113E-05 + .4366E-05 + .4561E-05 + .4671E-05 + .4763E-05 + .4857E-05 + .4907E-05 + .4874E-05 + .4807E-05 + .4740E-05 + .4674E-05 + .4587E-05 + .4480E-05 + .4375E-05 + .4253E-05 + .4135E-05 + .4020E-05 + .3908E-05 + .3737E-05 + .3386E-05 + .3039E-05 + .2727E-05 + .2432E-05 + .2065E-05 + .1695E-05 + .1307E-05 + .1082E-05 + .8949E-06 + .7405E-06 + .4817E-06 + .3149E-06 + .2001E-06 + .1206E-06 + .7262E-07 + .5592E-07 + .4840E-07 + .4189E-07 + .3650E-07 + .3448E-07 + .3256E-07 + .2940E-07 + .2548E-07 + .2208E-07 + .2090E-07 + .8947E-06 + .1027E-05 + .1155E-05 + .1298E-05 + .1454E-05 + .1625E-05 + .1811E-05 + .2019E-05 + .2250E-05 + .2509E-05 + .2795E-05 + .3103E-05 + .3411E-05 + .3752E-05 + .4054E-05 + .4358E-05 + .4659E-05 + .4867E-05 + .4961E-05 + .5051E-05 + .5142E-05 + .5164E-05 + .5103E-05 + .5033E-05 + .4964E-05 + .4896E-05 + .4794E-05 + .4661E-05 + .4532E-05 + .4401E-05 + .4273E-05 + .4150E-05 + .4029E-05 + .3894E-05 + .3545E-05 + .3184E-05 + .2860E-05 + .2564E-05 + .2177E-05 + .1760E-05 + .1349E-05 + .1099E-05 + .8952E-06 + .7292E-06 + .4803E-06 + .3197E-06 + .2058E-06 + .1243E-06 + .7504E-07 + .5771E-07 + .4978E-07 + .4294E-07 + .3732E-07 + .3532E-07 + .3342E-07 + .3031E-07 + .2642E-07 + .2303E-07 + .2185E-07 + .9211E-06 + .1059E-05 + .1193E-05 + .1338E-05 + .1501E-05 + .1679E-05 + .1874E-05 + .2092E-05 + .2335E-05 + .2608E-05 + .2914E-05 + .3249E-05 + .3589E-05 + .3946E-05 + .4261E-05 + .4573E-05 + .4880E-05 + .5095E-05 + .5203E-05 + .5314E-05 + .5427E-05 + .5442E-05 + .5357E-05 + .5274E-05 + .5192E-05 + .5111E-05 + .4998E-05 + .4855E-05 + .4716E-05 + .4580E-05 + .4445E-05 + .4304E-05 + .4168E-05 + .4037E-05 + .3712E-05 + .3370E-05 + .3005E-05 + .2679E-05 + .2280E-05 + .1827E-05 + .1406E-05 + .1121E-05 + .8935E-06 + .7122E-06 + .4749E-06 + .3220E-06 + .2099E-06 + .1271E-06 + .7691E-07 + .5906E-07 + .5078E-07 + .4366E-07 + .3784E-07 + .3588E-07 + .3403E-07 + .3099E-07 + .2717E-07 + .2383E-07 + .2266E-07 + .9360E-06 + .1077E-05 + .1224E-05 + .1371E-05 + .1536E-05 + .1718E-05 + .1919E-05 + .2143E-05 + .2393E-05 + .2679E-05 + .3001E-05 + .3356E-05 + .3730E-05 + .4092E-05 + .4431E-05 + .4765E-05 + .5043E-05 + .5260E-05 + .5407E-05 + .5558E-05 + .5713E-05 + .5738E-05 + .5631E-05 + .5526E-05 + .5423E-05 + .5323E-05 + .5200E-05 + .5058E-05 + .4919E-05 + .4785E-05 + .4643E-05 + .4479E-05 + .4321E-05 + .4169E-05 + .3885E-05 + .3590E-05 + .3160E-05 + .2782E-05 + .2373E-05 + .1896E-05 + .1475E-05 + .1146E-05 + .8899E-06 + .6913E-06 + .4667E-06 + .3222E-06 + .2128E-06 + .1291E-06 + .7834E-07 + .6007E-07 + .5148E-07 + .4412E-07 + .3813E-07 + .3623E-07 + .3443E-07 + .3148E-07 + .2777E-07 + .2450E-07 + .2335E-07 + .9437E-06 + .1088E-05 + .1246E-05 + .1395E-05 + .1561E-05 + .1745E-05 + .1950E-05 + .2179E-05 + .2434E-05 + .2730E-05 + .3065E-05 + .3439E-05 + .3846E-05 + .4210E-05 + .4572E-05 + .4926E-05 + .5171E-05 + .5389E-05 + .5575E-05 + .5767E-05 + .5967E-05 + .6003E-05 + .5873E-05 + .5745E-05 + .5621E-05 + .5499E-05 + .5368E-05 + .5228E-05 + .5092E-05 + .4959E-05 + .4811E-05 + .4624E-05 + .4444E-05 + .4271E-05 + .4035E-05 + .3796E-05 + .3298E-05 + .2865E-05 + .2451E-05 + .1953E-05 + .1535E-05 + .1162E-05 + .8795E-06 + .6657E-06 + .4551E-06 + .3200E-06 + .2140E-06 + .1302E-06 + .7917E-07 + .6062E-07 + .5178E-07 + .4423E-07 + .3812E-07 + .3630E-07 + .3457E-07 + .3174E-07 + .2816E-07 + .2499E-07 + .2388E-07 + .9410E-06 + .1087E-05 + .1255E-05 + .1403E-05 + .1568E-05 + .1753E-05 + .1960E-05 + .2190E-05 + .2449E-05 + .2752E-05 + .3097E-05 + .3485E-05 + .3922E-05 + .4285E-05 + .4666E-05 + .5036E-05 + .5244E-05 + .5460E-05 + .5685E-05 + .5920E-05 + .6164E-05 + .6211E-05 + .6058E-05 + .5908E-05 + .5762E-05 + .5620E-05 + .5481E-05 + .5345E-05 + .5213E-05 + .5084E-05 + .4931E-05 + .4721E-05 + .4521E-05 + .4329E-05 + .4145E-05 + .3968E-05 + .3404E-05 + .2919E-05 + .2504E-05 + .1989E-05 + .1580E-05 + .1165E-05 + .8596E-06 + .6341E-06 + .4389E-06 + .3143E-06 + .2129E-06 + .1298E-06 + .7914E-07 + .6051E-07 + .5152E-07 + .4386E-07 + .3769E-07 + .3597E-07 + .3433E-07 + .3164E-07 + .2825E-07 + .2522E-07 + .2415E-07 + .9446E-06 + .1096E-05 + .1267E-05 + .1428E-05 + .1602E-05 + .1788E-05 + .1990E-05 + .2213E-05 + .2460E-05 + .2756E-05 + .3087E-05 + .3459E-05 + .3883E-05 + .4282E-05 + .4702E-05 + .5105E-05 + .5412E-05 + .5722E-05 + .6010E-05 + .6253E-05 + .6469E-05 + .6497E-05 + .6345E-05 + .6171E-05 + .5995E-05 + .5812E-05 + .5637E-05 + .5444E-05 + .5259E-05 + .5095E-05 + .4952E-05 + .4792E-05 + .4638E-05 + .4476E-05 + .4280E-05 + .4053E-05 + .3531E-05 + .3013E-05 + .2543E-05 + .2020E-05 + .1585E-05 + .1149E-05 + .8329E-06 + .6037E-06 + .4231E-06 + .3085E-06 + .2117E-06 + .1294E-06 + .7906E-07 + .6037E-07 + .5123E-07 + .4348E-07 + .3725E-07 + .3562E-07 + .3407E-07 + .3154E-07 + .2832E-07 + .2543E-07 + .2441E-07 + .9471E-06 + .1103E-05 + .1278E-05 + .1453E-05 + .1635E-05 + .1821E-05 + .2019E-05 + .2234E-05 + .2469E-05 + .2756E-05 + .3074E-05 + .3430E-05 + .3840E-05 + .4273E-05 + .4732E-05 + .5170E-05 + .5579E-05 + .5989E-05 + .6346E-05 + .6598E-05 + .6782E-05 + .6788E-05 + .6638E-05 + .6437E-05 + .6230E-05 + .6005E-05 + .5791E-05 + .5538E-05 + .5299E-05 + .5099E-05 + .4967E-05 + .4859E-05 + .4753E-05 + .4623E-05 + .4414E-05 + .4134E-05 + .3658E-05 + .3106E-05 + .2580E-05 + .2049E-05 + .1589E-05 + .1132E-05 + .8061E-06 + .5741E-06 + .4074E-06 + .3025E-06 + .2102E-06 + .1288E-06 + .7890E-07 + .6016E-07 + .5088E-07 + .4304E-07 + .3677E-07 + .3524E-07 + .3377E-07 + .3139E-07 + .2836E-07 + .2562E-07 + .2465E-07 + .9761E-06 + .1136E-05 + .1311E-05 + .1492E-05 + .1678E-05 + .1864E-05 + .2059E-05 + .2271E-05 + .2502E-05 + .2790E-05 + .3105E-05 + .3467E-05 + .3885E-05 + .4355E-05 + .4856E-05 + .5338E-05 + .5834E-05 + .6318E-05 + .6713E-05 + .6954E-05 + .7081E-05 + .7047E-05 + .6881E-05 + .6647E-05 + .6412E-05 + .6160E-05 + .5931E-05 + .5656E-05 + .5404E-05 + .5201E-05 + .5088E-05 + .5005E-05 + .4917E-05 + .4786E-05 + .4540E-05 + .4189E-05 + .3720E-05 + .3135E-05 + .2565E-05 + .2033E-05 + .1563E-05 + .1104E-05 + .7793E-06 + .5503E-06 + .3954E-06 + .2990E-06 + .2104E-06 + .1292E-06 + .7937E-07 + .6042E-07 + .5094E-07 + .4295E-07 + .3659E-07 + .3514E-07 + .3375E-07 + .3150E-07 + .2862E-07 + .2601E-07 + .2508E-07 + .1071E-05 + .1231E-05 + .1398E-05 + .1568E-05 + .1746E-05 + .1932E-05 + .2128E-05 + .2352E-05 + .2599E-05 + .2906E-05 + .3239E-05 + .3663E-05 + .4142E-05 + .4654E-05 + .5209E-05 + .5767E-05 + .6309E-05 + .6795E-05 + .7145E-05 + .7328E-05 + .7342E-05 + .7232E-05 + .7004E-05 + .6723E-05 + .6475E-05 + .6237E-05 + .6044E-05 + .5835E-05 + .5673E-05 + .5542E-05 + .5469E-05 + .5349E-05 + .5207E-05 + .4992E-05 + .4647E-05 + .4192E-05 + .3640E-05 + .3029E-05 + .2445E-05 + .1927E-05 + .1477E-05 + .1055E-05 + .7532E-06 + .5378E-06 + .3912E-06 + .3013E-06 + .2148E-06 + .1322E-06 + .8140E-07 + .6188E-07 + .5200E-07 + .4370E-07 + .3713E-07 + .3573E-07 + .3439E-07 + .3222E-07 + .2946E-07 + .2693E-07 + .2603E-07 + .1174E-05 + .1332E-05 + .1493E-05 + .1656E-05 + .1829E-05 + .2015E-05 + .2213E-05 + .2445E-05 + .2703E-05 + .3016E-05 + .3368E-05 + .3822E-05 + .4320E-05 + .4862E-05 + .5452E-05 + .6064E-05 + .6638E-05 + .7114E-05 + .7434E-05 + .7587E-05 + .7537E-05 + .7388E-05 + .7138E-05 + .6855E-05 + .6618E-05 + .6395E-05 + .6236E-05 + .6063E-05 + .5934E-05 + .5816E-05 + .5740E-05 + .5596E-05 + .5400E-05 + .5118E-05 + .4708E-05 + .4186E-05 + .3575E-05 + .2932E-05 + .2333E-05 + .1816E-05 + .1373E-05 + .9952E-06 + .7212E-06 + .5226E-06 + .3849E-06 + .3018E-06 + .2179E-06 + .1345E-06 + .8300E-07 + .6301E-07 + .5278E-07 + .4421E-07 + .3745E-07 + .3611E-07 + .3483E-07 + .3277E-07 + .3014E-07 + .2772E-07 + .2685E-07 + .1283E-05 + .1438E-05 + .1592E-05 + .1752E-05 + .1925E-05 + .2109E-05 + .2311E-05 + .2548E-05 + .2808E-05 + .3116E-05 + .3484E-05 + .3936E-05 + .4410E-05 + .4965E-05 + .5568E-05 + .6209E-05 + .6799E-05 + .7252E-05 + .7561E-05 + .7717E-05 + .7653E-05 + .7503E-05 + .7270E-05 + .7028E-05 + .6828E-05 + .6621E-05 + .6495E-05 + .6332E-05 + .6176E-05 + .6009E-05 + .5882E-05 + .5729E-05 + .5484E-05 + .5155E-05 + .4717E-05 + .4165E-05 + .3519E-05 + .2840E-05 + .2223E-05 + .1701E-05 + .1256E-05 + .9262E-06 + .6833E-06 + .5041E-06 + .3759E-06 + .3002E-06 + .2196E-06 + .1358E-06 + .8403E-07 + .6370E-07 + .5318E-07 + .4440E-07 + .3750E-07 + .3624E-07 + .3503E-07 + .3309E-07 + .3062E-07 + .2833E-07 + .2750E-07 + .1373E-05 + .1532E-05 + .1689E-05 + .1852E-05 + .2024E-05 + .2204E-05 + .2403E-05 + .2637E-05 + .2888E-05 + .3188E-05 + .3543E-05 + .3962E-05 + .4420E-05 + .4954E-05 + .5550E-05 + .6194E-05 + .6791E-05 + .7274E-05 + .7593E-05 + .7767E-05 + .7726E-05 + .7588E-05 + .7398E-05 + .7211E-05 + .7061E-05 + .6894E-05 + .6779E-05 + .6617E-05 + .6434E-05 + .6233E-05 + .6056E-05 + .5859E-05 + .5561E-05 + .5198E-05 + .4727E-05 + .4139E-05 + .3465E-05 + .2751E-05 + .2112E-05 + .1586E-05 + .1146E-05 + .8476E-06 + .6271E-06 + .4640E-06 + .3489E-06 + .2831E-06 + .2102E-06 + .1318E-06 + .8260E-07 + .6302E-07 + .5279E-07 + .4422E-07 + .3747E-07 + .3625E-07 + .3507E-07 + .3320E-07 + .3083E-07 + .2856E-07 + .2770E-07 + .1468E-05 + .1634E-05 + .1800E-05 + .1970E-05 + .2142E-05 + .2318E-05 + .2512E-05 + .2739E-05 + .2979E-05 + .3270E-05 + .3605E-05 + .3981E-05 + .4430E-05 + .4933E-05 + .5519E-05 + .6161E-05 + .6765E-05 + .7299E-05 + .7639E-05 + .7838E-05 + .7833E-05 + .7713E-05 + .7576E-05 + .7451E-05 + .7358E-05 + .7240E-05 + .7127E-05 + .6962E-05 + .6749E-05 + .6519E-05 + .6287E-05 + .6030E-05 + .5674E-05 + .5278E-05 + .4770E-05 + .4140E-05 + .3435E-05 + .2683E-05 + .2018E-05 + .1486E-05 + .1052E-05 + .7498E-06 + .5345E-06 + .3810E-06 + .2861E-06 + .2344E-06 + .1777E-06 + .1160E-06 + .7579E-07 + .5940E-07 + .5076E-07 + .4337E-07 + .3743E-07 + .3617E-07 + .3495E-07 + .3295E-07 + .3053E-07 + .2799E-07 + .2688E-07 + .1552E-05 + .1716E-05 + .1880E-05 + .2046E-05 + .2211E-05 + .2384E-05 + .2577E-05 + .2800E-05 + .3031E-05 + .3320E-05 + .3652E-05 + .4025E-05 + .4467E-05 + .4953E-05 + .5528E-05 + .6163E-05 + .6764E-05 + .7282E-05 + .7666E-05 + .7867E-05 + .7916E-05 + .7837E-05 + .7740E-05 + .7680E-05 + .7621E-05 + .7528E-05 + .7417E-05 + .7274E-05 + .7050E-05 + .6762E-05 + .6482E-05 + .6177E-05 + .5791E-05 + .5329E-05 + .4781E-05 + .4093E-05 + .3329E-05 + .2558E-05 + .1884E-05 + .1341E-05 + .9169E-06 + .6407E-06 + .4477E-06 + .3128E-06 + .2345E-06 + .1940E-06 + .1501E-06 + .1022E-06 + .6952E-07 + .5596E-07 + .4879E-07 + .4253E-07 + .3738E-07 + .3608E-07 + .3482E-07 + .3270E-07 + .3022E-07 + .2743E-07 + .2607E-07 + .1616E-05 + .1775E-05 + .1935E-05 + .2094E-05 + .2250E-05 + .2419E-05 + .2609E-05 + .2827E-05 + .3053E-05 + .3338E-05 + .3670E-05 + .4035E-05 + .4462E-05 + .4933E-05 + .5494E-05 + .6116E-05 + .6707E-05 + .7206E-05 + .7628E-05 + .7835E-05 + .7932E-05 + .7894E-05 + .7841E-05 + .7846E-05 + .7822E-05 + .7754E-05 + .7649E-05 + .7530E-05 + .7299E-05 + .6956E-05 + .6630E-05 + .6274E-05 + .5853E-05 + .5330E-05 + .4747E-05 + .4013E-05 + .3202E-05 + .2420E-05 + .1743E-05 + .1195E-05 + .7835E-06 + .5387E-06 + .3704E-06 + .2547E-06 + .1907E-06 + .1593E-06 + .1258E-06 + .8921E-07 + .6326E-07 + .5230E-07 + .4651E-07 + .4136E-07 + .3702E-07 + .3569E-07 + .3440E-07 + .3218E-07 + .2968E-07 + .2665E-07 + .2509E-07 + .1619E-05 + .1772E-05 + .1926E-05 + .2074E-05 + .2223E-05 + .2390E-05 + .2582E-05 + .2802E-05 + .3039E-05 + .3333E-05 + .3681E-05 + .4023E-05 + .4408E-05 + .4879E-05 + .5437E-05 + .6039E-05 + .6622E-05 + .7120E-05 + .7559E-05 + .7817E-05 + .7920E-05 + .7906E-05 + .7913E-05 + .7967E-05 + .7974E-05 + .7930E-05 + .7849E-05 + .7737E-05 + .7508E-05 + .7149E-05 + .6785E-05 + .6346E-05 + .5841E-05 + .5284E-05 + .4669E-05 + .3933E-05 + .3109E-05 + .2304E-05 + .1610E-05 + .1046E-05 + .6356E-06 + .4371E-06 + .3006E-06 + .2068E-06 + .1546E-06 + .1304E-06 + .1051E-06 + .7765E-07 + .5737E-07 + .4872E-07 + .4420E-07 + .4010E-07 + .3656E-07 + .3520E-07 + .3389E-07 + .3157E-07 + .2905E-07 + .2582E-07 + .2407E-07 + .1620E-05 + .1769E-05 + .1921E-05 + .2061E-05 + .2206E-05 + .2373E-05 + .2566E-05 + .2788E-05 + .3027E-05 + .3330E-05 + .3681E-05 + .4007E-05 + .4376E-05 + .4845E-05 + .5397E-05 + .5985E-05 + .6561E-05 + .7072E-05 + .7516E-05 + .7818E-05 + .7942E-05 + .7961E-05 + .8024E-05 + .8127E-05 + .8160E-05 + .8130E-05 + .8061E-05 + .7959E-05 + .7721E-05 + .7362E-05 + .6947E-05 + .6430E-05 + .5850E-05 + .5242E-05 + .4582E-05 + .3823E-05 + .2987E-05 + .2177E-05 + .1477E-05 + .9115E-06 + .5197E-06 + .3566E-06 + .2447E-06 + .1680E-06 + .1254E-06 + .1068E-06 + .8788E-07 + .6765E-07 + .5207E-07 + .4542E-07 + .4204E-07 + .3891E-07 + .3612E-07 + .3474E-07 + .3340E-07 + .3100E-07 + .2846E-07 + .2503E-07 + .2310E-07 + .1620E-05 + .1772E-05 + .1926E-05 + .2066E-05 + .2212E-05 + .2381E-05 + .2573E-05 + .2800E-05 + .3026E-05 + .3337E-05 + .3668E-05 + .3993E-05 + .4394E-05 + .4859E-05 + .5397E-05 + .5986E-05 + .6558E-05 + .7108E-05 + .7538E-05 + .7872E-05 + .8042E-05 + .8110E-05 + .8223E-05 + .8377E-05 + .8424E-05 + .8390E-05 + .8308E-05 + .8221E-05 + .7950E-05 + .7626E-05 + .7134E-05 + .6550E-05 + .5911E-05 + .5219E-05 + .4486E-05 + .3669E-05 + .2823E-05 + .2033E-05 + .1339E-05 + .7905E-06 + .4320E-06 + .2945E-06 + .2008E-06 + .1369E-06 + .1020E-06 + .8780E-07 + .7374E-07 + .5914E-07 + .4744E-07 + .4250E-07 + .4013E-07 + .3789E-07 + .3582E-07 + .3441E-07 + .3304E-07 + .3054E-07 + .2798E-07 + .2436E-07 + .2226E-07 + .1622E-05 + .1772E-05 + .1925E-05 + .2065E-05 + .2215E-05 + .2387E-05 + .2577E-05 + .2806E-05 + .3022E-05 + .3335E-05 + .3652E-05 + .3976E-05 + .4384E-05 + .4846E-05 + .5380E-05 + .5967E-05 + .6548E-05 + .7122E-05 + .7573E-05 + .7924E-05 + .8125E-05 + .8234E-05 + .8361E-05 + .8561E-05 + .8656E-05 + .8648E-05 + .8597E-05 + .8525E-05 + .8247E-05 + .7917E-05 + .7367E-05 + .6703E-05 + .5957E-05 + .5171E-05 + .4365E-05 + .3511E-05 + .2665E-05 + .1905E-05 + .1232E-05 + .7001E-06 + .3715E-06 + .2491E-06 + .1670E-06 + .1120E-06 + .8331E-07 + .7238E-07 + .6205E-07 + .5186E-07 + .4334E-07 + .3988E-07 + .3841E-07 + .3700E-07 + .3563E-07 + .3418E-07 + .3278E-07 + .3018E-07 + .2758E-07 + .2377E-07 + .2150E-07 + .1619E-05 + .1763E-05 + .1914E-05 + .2055E-05 + .2209E-05 + .2383E-05 + .2572E-05 + .2798E-05 + .3009E-05 + .3316E-05 + .3624E-05 + .3945E-05 + .4340E-05 + .4799E-05 + .5334E-05 + .5915E-05 + .6514E-05 + .7097E-05 + .7597E-05 + .7952E-05 + .8174E-05 + .8313E-05 + .8426E-05 + .8665E-05 + .8838E-05 + .8880E-05 + .8899E-05 + .8843E-05 + .8581E-05 + .8210E-05 + .7619E-05 + .6863E-05 + .5973E-05 + .5090E-05 + .4214E-05 + .3343E-05 + .2507E-05 + .1783E-05 + .1142E-05 + .6284E-06 + .3271E-06 + .2139E-06 + .1399E-06 + .9149E-07 + .6798E-07 + .5964E-07 + .5219E-07 + .4544E-07 + .3957E-07 + .3740E-07 + .3675E-07 + .3612E-07 + .3542E-07 + .3393E-07 + .3251E-07 + .2981E-07 + .2718E-07 + .2318E-07 + .2077E-07 + .1619E-05 + .1763E-05 + .1913E-05 + .2053E-05 + .2207E-05 + .2381E-05 + .2572E-05 + .2798E-05 + .3017E-05 + .3323E-05 + .3624E-05 + .3955E-05 + .4330E-05 + .4790E-05 + .5328E-05 + .5919E-05 + .6526E-05 + .7129E-05 + .7647E-05 + .8034E-05 + .8279E-05 + .8419E-05 + .8544E-05 + .8782E-05 + .8977E-05 + .9054E-05 + .9126E-05 + .9124E-05 + .8845E-05 + .8472E-05 + .7873E-05 + .7010E-05 + .5992E-05 + .5005E-05 + .4073E-05 + .3174E-05 + .2353E-05 + .1667E-05 + .1059E-05 + .5825E-06 + .2988E-06 + .1884E-06 + .1187E-06 + .7484E-07 + .5552E-07 + .4919E-07 + .4394E-07 + .3986E-07 + .3617E-07 + .3511E-07 + .3520E-07 + .3529E-07 + .3524E-07 + .3372E-07 + .3227E-07 + .2947E-07 + .2681E-07 + .2263E-07 + .2007E-07 + .1617E-05 + .1762E-05 + .1910E-05 + .2050E-05 + .2202E-05 + .2375E-05 + .2569E-05 + .2795E-05 + .3026E-05 + .3331E-05 + .3626E-05 + .3969E-05 + .4322E-05 + .4783E-05 + .5325E-05 + .5928E-05 + .6541E-05 + .7165E-05 + .7691E-05 + .8120E-05 + .8387E-05 + .8519E-05 + .8664E-05 + .8889E-05 + .9088E-05 + .9195E-05 + .9316E-05 + .9381E-05 + .9073E-05 + .8714E-05 + .8119E-05 + .7141E-05 + .6001E-05 + .4911E-05 + .3931E-05 + .3006E-05 + .2202E-05 + .1555E-05 + .9812E-06 + .5441E-06 + .2755E-06 + .1755E-06 + .1118E-06 + .7123E-07 + .5354E-07 + .4744E-07 + .4263E-07 + .3933E-07 + .3629E-07 + .3540E-07 + .3545E-07 + .3551E-07 + .3543E-07 + .3380E-07 + .3224E-07 + .2942E-07 + .2624E-07 + .2157E-07 + .1910E-07 + .1606E-05 + .1748E-05 + .1898E-05 + .2035E-05 + .2188E-05 + .2363E-05 + .2559E-05 + .2792E-05 + .3019E-05 + .3326E-05 + .3634E-05 + .3953E-05 + .4330E-05 + .4787E-05 + .5325E-05 + .5914E-05 + .6507E-05 + .7138E-05 + .7670E-05 + .8081E-05 + .8411E-05 + .8568E-05 + .8742E-05 + .8947E-05 + .9133E-05 + .9352E-05 + .9508E-05 + .9569E-05 + .9252E-05 + .8911E-05 + .8236E-05 + .7193E-05 + .6010E-05 + .4885E-05 + .3843E-05 + .2908E-05 + .2121E-05 + .1485E-05 + .9438E-06 + .5313E-06 + .2731E-06 + .1724E-06 + .1089E-06 + .6873E-07 + .5247E-07 + .4643E-07 + .4187E-07 + .3915E-07 + .3661E-07 + .3577E-07 + .3569E-07 + .3561E-07 + .3539E-07 + .3365E-07 + .3199E-07 + .2919E-07 + .2546E-07 + .2033E-07 + .1799E-07 + .1602E-05 + .1742E-05 + .1892E-05 + .2027E-05 + .2183E-05 + .2360E-05 + .2559E-05 + .2799E-05 + .3022E-05 + .3333E-05 + .3654E-05 + .3951E-05 + .4355E-05 + .4809E-05 + .5343E-05 + .5918E-05 + .6503E-05 + .7132E-05 + .7677E-05 + .8082E-05 + .8467E-05 + .8658E-05 + .8859E-05 + .9049E-05 + .9234E-05 + .9547E-05 + .9738E-05 + .9784E-05 + .9459E-05 + .9127E-05 + .8386E-05 + .7280E-05 + .6055E-05 + .4896E-05 + .3797E-05 + .2847E-05 + .2070E-05 + .1443E-05 + .9261E-06 + .5298E-06 + .2751E-06 + .1715E-06 + .1069E-06 + .6663E-07 + .5165E-07 + .4565E-07 + .4132E-07 + .3916E-07 + .3711E-07 + .3632E-07 + .3609E-07 + .3587E-07 + .3552E-07 + .3366E-07 + .3189E-07 + .2909E-07 + .2482E-07 + .1925E-07 + .1702E-07 + .1590E-05 + .1722E-05 + .1866E-05 + .2002E-05 + .2160E-05 + .2342E-05 + .2542E-05 + .2785E-05 + .3003E-05 + .3318E-05 + .3641E-05 + .3926E-05 + .4347E-05 + .4793E-05 + .5305E-05 + .5864E-05 + .6480E-05 + .7048E-05 + .7633E-05 + .8071E-05 + .8467E-05 + .8723E-05 + .8941E-05 + .9135E-05 + .9365E-05 + .9665E-05 + .9886E-05 + .9874E-05 + .9555E-05 + .9191E-05 + .8483E-05 + .7359E-05 + .6120E-05 + .4945E-05 + .3836E-05 + .2865E-05 + .2081E-05 + .1471E-05 + .9635E-06 + .5631E-06 + .2879E-06 + .1748E-06 + .1061E-06 + .6441E-07 + .5071E-07 + .4475E-07 + .4066E-07 + .3905E-07 + .3751E-07 + .3677E-07 + .3640E-07 + .3604E-07 + .3554E-07 + .3357E-07 + .3171E-07 + .2891E-07 + .2412E-07 + .1818E-07 + .1606E-07 + .1584E-05 + .1713E-05 + .1853E-05 + .1990E-05 + .2148E-05 + .2333E-05 + .2535E-05 + .2783E-05 + .3002E-05 + .3310E-05 + .3625E-05 + .3907E-05 + .4338E-05 + .4780E-05 + .5278E-05 + .5840E-05 + .6456E-05 + .7003E-05 + .7603E-05 + .8071E-05 + .8494E-05 + .8793E-05 + .9030E-05 + .9232E-05 + .9493E-05 + .9802E-05 + .1002E-04 + .9971E-05 + .9648E-05 + .9257E-05 + .8564E-05 + .7435E-05 + .6197E-05 + .5006E-05 + .3883E-05 + .2897E-05 + .2110E-05 + .1506E-05 + .9981E-06 + .5892E-06 + .2993E-06 + .1775E-06 + .1052E-06 + .6239E-07 + .4988E-07 + .4396E-07 + .4009E-07 + .3902E-07 + .3798E-07 + .3730E-07 + .3678E-07 + .3627E-07 + .3564E-07 + .3355E-07 + .3158E-07 + .2879E-07 + .2349E-07 + .1720E-07 + .1519E-07 + .1586E-05 + .1717E-05 + .1856E-05 + .1992E-05 + .2148E-05 + .2333E-05 + .2541E-05 + .2792E-05 + .3022E-05 + .3304E-05 + .3598E-05 + .3890E-05 + .4318E-05 + .4760E-05 + .5259E-05 + .5850E-05 + .6416E-05 + .7001E-05 + .7580E-05 + .8073E-05 + .8544E-05 + .8852E-05 + .9110E-05 + .9326E-05 + .9596E-05 + .9945E-05 + .1012E-04 + .1006E-04 + .9718E-05 + .9307E-05 + .8602E-05 + .7494E-05 + .6280E-05 + .5076E-05 + .3934E-05 + .2945E-05 + .2160E-05 + .1549E-05 + .1025E-05 + .6009E-06 + .3073E-06 + .1814E-06 + .1071E-06 + .6323E-07 + .5023E-07 + .4429E-07 + .4040E-07 + .3931E-07 + .3826E-07 + .3764E-07 + .3721E-07 + .3680E-07 + .3624E-07 + .3416E-07 + .3219E-07 + .2906E-07 + .2320E-07 + .1687E-07 + .1492E-07 + .1598E-05 + .1731E-05 + .1872E-05 + .2006E-05 + .2160E-05 + .2340E-05 + .2540E-05 + .2783E-05 + .3007E-05 + .3296E-05 + .3582E-05 + .3894E-05 + .4308E-05 + .4740E-05 + .5238E-05 + .5821E-05 + .6380E-05 + .6978E-05 + .7555E-05 + .8087E-05 + .8561E-05 + .8911E-05 + .9216E-05 + .9464E-05 + .9745E-05 + .1008E-04 + .1020E-04 + .1012E-04 + .9783E-05 + .9336E-05 + .8600E-05 + .7521E-05 + .6330E-05 + .5132E-05 + .3997E-05 + .3017E-05 + .2224E-05 + .1593E-05 + .1052E-05 + .6081E-06 + .3122E-06 + .1868E-06 + .1118E-06 + .6688E-07 + .5168E-07 + .4566E-07 + .4151E-07 + .3984E-07 + .3823E-07 + .3768E-07 + .3760E-07 + .3753E-07 + .3730E-07 + .3535E-07 + .3350E-07 + .2966E-07 + .2319E-07 + .1712E-07 + .1518E-07 + .1619E-05 + .1754E-05 + .1899E-05 + .2033E-05 + .2185E-05 + .2354E-05 + .2541E-05 + .2765E-05 + .2973E-05 + .3291E-05 + .3579E-05 + .3918E-05 + .4310E-05 + .4729E-05 + .5224E-05 + .5775E-05 + .6356E-05 + .6953E-05 + .7542E-05 + .8124E-05 + .8570E-05 + .8986E-05 + .9355E-05 + .9650E-05 + .9944E-05 + .1024E-04 + .1029E-04 + .1018E-04 + .9862E-05 + .9368E-05 + .8586E-05 + .7540E-05 + .6370E-05 + .5186E-05 + .4073E-05 + .3113E-05 + .2301E-05 + .1642E-05 + .1080E-05 + .6133E-06 + .3155E-06 + .1917E-06 + .1165E-06 + .7080E-07 + .5320E-07 + .4711E-07 + .4269E-07 + .4040E-07 + .3824E-07 + .3775E-07 + .3803E-07 + .3830E-07 + .3841E-07 + .3661E-07 + .3489E-07 + .3029E-07 + .2319E-07 + .1738E-07 + .1546E-07 + .1618E-05 + .1761E-05 + .1913E-05 + .2056E-05 + .2214E-05 + .2389E-05 + .2579E-05 + .2801E-05 + .3018E-05 + .3311E-05 + .3616E-05 + .3950E-05 + .4314E-05 + .4754E-05 + .5248E-05 + .5782E-05 + .6383E-05 + .7005E-05 + .7603E-05 + .8187E-05 + .8646E-05 + .9098E-05 + .9494E-05 + .9826E-05 + .1011E-04 + .1033E-04 + .1040E-04 + .1026E-04 + .9890E-05 + .9344E-05 + .8578E-05 + .7556E-05 + .6405E-05 + .5252E-05 + .4154E-05 + .3181E-05 + .2352E-05 + .1666E-05 + .1090E-05 + .6301E-06 + .3213E-06 + .1980E-06 + .1220E-06 + .7522E-07 + .5496E-07 + .4879E-07 + .4406E-07 + .4113E-07 + .3839E-07 + .3796E-07 + .3859E-07 + .3923E-07 + .3970E-07 + .3805E-07 + .3647E-07 + .3105E-07 + .2328E-07 + .1772E-07 + .1580E-07 + .1612E-05 + .1764E-05 + .1923E-05 + .2077E-05 + .2243E-05 + .2427E-05 + .2624E-05 + .2848E-05 + .3080E-05 + .3336E-05 + .3660E-05 + .3981E-05 + .4316E-05 + .4784E-05 + .5277E-05 + .5798E-05 + .6419E-05 + .7071E-05 + .7678E-05 + .8252E-05 + .8734E-05 + .9215E-05 + .9628E-05 + .9995E-05 + .1025E-04 + .1039E-04 + .1050E-04 + .1034E-04 + .9900E-05 + .9302E-05 + .8565E-05 + .7567E-05 + .6436E-05 + .5317E-05 + .4234E-05 + .3242E-05 + .2397E-05 + .1685E-05 + .1095E-05 + .6500E-06 + .3280E-06 + .2049E-06 + .1280E-06 + .7994E-07 + .5681E-07 + .5054E-07 + .4549E-07 + .4187E-07 + .3855E-07 + .3819E-07 + .3918E-07 + .4020E-07 + .4104E-07 + .3956E-07 + .3813E-07 + .3185E-07 + .2337E-07 + .1806E-07 + .1616E-07 + .1662E-05 + .1817E-05 + .1979E-05 + .2134E-05 + .2301E-05 + .2484E-05 + .2678E-05 + .2909E-05 + .3117E-05 + .3389E-05 + .3688E-05 + .3987E-05 + .4345E-05 + .4769E-05 + .5273E-05 + .5816E-05 + .6442E-05 + .7088E-05 + .7716E-05 + .8301E-05 + .8840E-05 + .9288E-05 + .9661E-05 + .1003E-04 + .1026E-04 + .1040E-04 + .1045E-04 + .1027E-04 + .9812E-05 + .9208E-05 + .8498E-05 + .7528E-05 + .6443E-05 + .5329E-05 + .4260E-05 + .3288E-05 + .2455E-05 + .1727E-05 + .1132E-05 + .6818E-06 + .3603E-06 + .2227E-06 + .1377E-06 + .8508E-07 + .5880E-07 + .5243E-07 + .4704E-07 + .4270E-07 + .3876E-07 + .3847E-07 + .3984E-07 + .4126E-07 + .4250E-07 + .4119E-07 + .3992E-07 + .3271E-07 + .2350E-07 + .1844E-07 + .1655E-07 + .1713E-05 + .1873E-05 + .2037E-05 + .2192E-05 + .2360E-05 + .2541E-05 + .2733E-05 + .2969E-05 + .3158E-05 + .3441E-05 + .3717E-05 + .4006E-05 + .4380E-05 + .4773E-05 + .5281E-05 + .5841E-05 + .6471E-05 + .7110E-05 + .7754E-05 + .8354E-05 + .8933E-05 + .9356E-05 + .9696E-05 + .1004E-04 + .1027E-04 + .1039E-04 + .1039E-04 + .1019E-04 + .9728E-05 + .9129E-05 + .8439E-05 + .7497E-05 + .6448E-05 + .5345E-05 + .4291E-05 + .3336E-05 + .2509E-05 + .1768E-05 + .1170E-05 + .7121E-06 + .3923E-06 + .2407E-06 + .1477E-06 + .9061E-07 + .6090E-07 + .5442E-07 + .4866E-07 + .4357E-07 + .3900E-07 + .3878E-07 + .4053E-07 + .4236E-07 + .4403E-07 + .4292E-07 + .4183E-07 + .3361E-07 + .2365E-07 + .1884E-07 + .1695E-07 + .1765E-05 + .1933E-05 + .2101E-05 + .2254E-05 + .2418E-05 + .2598E-05 + .2792E-05 + .3027E-05 + .3220E-05 + .3494E-05 + .3760E-05 + .4072E-05 + .4442E-05 + .4850E-05 + .5333E-05 + .5899E-05 + .6525E-05 + .7165E-05 + .7804E-05 + .8431E-05 + .8989E-05 + .9419E-05 + .9751E-05 + .1004E-04 + .1026E-04 + .1035E-04 + .1034E-04 + .1013E-04 + .9673E-05 + .9114E-05 + .8415E-05 + .7505E-05 + .6459E-05 + .5384E-05 + .4347E-05 + .3393E-05 + .2554E-05 + .1806E-05 + .1210E-05 + .7338E-06 + .4155E-06 + .2557E-06 + .1574E-06 + .9684E-07 + .6330E-07 + .5669E-07 + .5052E-07 + .4461E-07 + .3938E-07 + .3923E-07 + .4138E-07 + .4365E-07 + .4578E-07 + .4487E-07 + .4398E-07 + .3466E-07 + .2388E-07 + .1931E-07 + .1743E-07 + .1811E-05 + .1984E-05 + .2152E-05 + .2302E-05 + .2462E-05 + .2640E-05 + .2833E-05 + .3063E-05 + .3264E-05 + .3527E-05 + .3787E-05 + .4108E-05 + .4469E-05 + .4885E-05 + .5343E-05 + .5912E-05 + .6527E-05 + .7168E-05 + .7813E-05 + .8448E-05 + .8978E-05 + .9396E-05 + .9722E-05 + .9973E-05 + .1018E-04 + .1025E-04 + .1024E-04 + .1002E-04 + .9579E-05 + .9045E-05 + .8356E-05 + .7471E-05 + .6447E-05 + .5402E-05 + .4383E-05 + .3437E-05 + .2598E-05 + .1854E-05 + .1251E-05 + .7601E-06 + .4416E-06 + .2755E-06 + .1719E-06 + .1073E-06 + .7049E-07 + .6220E-07 + .5510E-07 + .4917E-07 + .4387E-07 + .4345E-07 + .4522E-07 + .4705E-07 + .4866E-07 + .4678E-07 + .4498E-07 + .3557E-07 + .2510E-07 + .2061E-07 + .1875E-07 + .1844E-05 + .2016E-05 + .2179E-05 + .2325E-05 + .2480E-05 + .2652E-05 + .2842E-05 + .3060E-05 + .3274E-05 + .3521E-05 + .3783E-05 + .4092E-05 + .4434E-05 + .4848E-05 + .5282E-05 + .5851E-05 + .6443E-05 + .7084E-05 + .7745E-05 + .8363E-05 + .8856E-05 + .9238E-05 + .9557E-05 + .9804E-05 + .9977E-05 + .1006E-04 + .1002E-04 + .9817E-05 + .9409E-05 + .8882E-05 + .8227E-05 + .7364E-05 + .6389E-05 + .5376E-05 + .4379E-05 + .3454E-05 + .2633E-05 + .1911E-05 + .1287E-05 + .7902E-06 + .4702E-06 + .3016E-06 + .1934E-06 + .1241E-06 + .8553E-07 + .7275E-07 + .6384E-07 + .5942E-07 + .5531E-07 + .5393E-07 + .5376E-07 + .5359E-07 + .5304E-07 + .4845E-07 + .4425E-07 + .3619E-07 + .2772E-07 + .2310E-07 + .2132E-07 + .1846E-05 + .2014E-05 + .2174E-05 + .2322E-05 + .2479E-05 + .2649E-05 + .2842E-05 + .3049E-05 + .3284E-05 + .3508E-05 + .3768E-05 + .4075E-05 + .4400E-05 + .4812E-05 + .5257E-05 + .5811E-05 + .6389E-05 + .7015E-05 + .7654E-05 + .8252E-05 + .8712E-05 + .9090E-05 + .9390E-05 + .9619E-05 + .9771E-05 + .9827E-05 + .9796E-05 + .9592E-05 + .9198E-05 + .8693E-05 + .8050E-05 + .7222E-05 + .6293E-05 + .5321E-05 + .4365E-05 + .3471E-05 + .2670E-05 + .1958E-05 + .1322E-05 + .8193E-06 + .4920E-06 + .3260E-06 + .2161E-06 + .1432E-06 + .1036E-06 + .8493E-07 + .7381E-07 + .7167E-07 + .6958E-07 + .6680E-07 + .6379E-07 + .6091E-07 + .5772E-07 + .5008E-07 + .4345E-07 + .3674E-07 + .3055E-07 + .2584E-07 + .2418E-07 + .1835E-05 + .1997E-05 + .2155E-05 + .2310E-05 + .2473E-05 + .2642E-05 + .2842E-05 + .3038E-05 + .3298E-05 + .3496E-05 + .3752E-05 + .4064E-05 + .4373E-05 + .4786E-05 + .5263E-05 + .5793E-05 + .6362E-05 + .6966E-05 + .7565E-05 + .8142E-05 + .8572E-05 + .8965E-05 + .9239E-05 + .9444E-05 + .9583E-05 + .9591E-05 + .9576E-05 + .9373E-05 + .8984E-05 + .8507E-05 + .7865E-05 + .7075E-05 + .6189E-05 + .5259E-05 + .4352E-05 + .3495E-05 + .2714E-05 + .2003E-05 + .1359E-05 + .8497E-06 + .5108E-06 + .3560E-06 + .2482E-06 + .1730E-06 + .1267E-06 + .1025E-06 + .8744E-07 + .8241E-07 + .7767E-07 + .7312E-07 + .6880E-07 + .6473E-07 + .6052E-07 + .5261E-07 + .4573E-07 + .3955E-07 + .3406E-07 + .2933E-07 + .2770E-07 + .1835E-05 + .1981E-05 + .2129E-05 + .2281E-05 + .2442E-05 + .2612E-05 + .2810E-05 + .2999E-05 + .3263E-05 + .3472E-05 + .3732E-05 + .4033E-05 + .4361E-05 + .4769E-05 + .5245E-05 + .5767E-05 + .6344E-05 + .6950E-05 + .7520E-05 + .8069E-05 + .8486E-05 + .8816E-05 + .9071E-05 + .9263E-05 + .9370E-05 + .9381E-05 + .9338E-05 + .9136E-05 + .8774E-05 + .8283E-05 + .7663E-05 + .6894E-05 + .6045E-05 + .5172E-05 + .4306E-05 + .3485E-05 + .2729E-05 + .2042E-05 + .1425E-05 + .9229E-06 + .5706E-06 + .4098E-06 + .2944E-06 + .2114E-06 + .1550E-06 + .1248E-06 + .1041E-06 + .9296E-07 + .8302E-07 + .7654E-07 + .7163E-07 + .6704E-07 + .6247E-07 + .5537E-07 + .4908E-07 + .4328E-07 + .3799E-07 + .3334E-07 + .3172E-07 + .1839E-05 + .1969E-05 + .2105E-05 + .2252E-05 + .2412E-05 + .2582E-05 + .2776E-05 + .2961E-05 + .3225E-05 + .3449E-05 + .3716E-05 + .4005E-05 + .4356E-05 + .4759E-05 + .5228E-05 + .5746E-05 + .6332E-05 + .6943E-05 + .7489E-05 + .8011E-05 + .8419E-05 + .8678E-05 + .8917E-05 + .9097E-05 + .9170E-05 + .9189E-05 + .9115E-05 + .8913E-05 + .8579E-05 + .8072E-05 + .7476E-05 + .6725E-05 + .5911E-05 + .5093E-05 + .4265E-05 + .3478E-05 + .2747E-05 + .2086E-05 + .1503E-05 + .1012E-05 + .6471E-06 + .4769E-06 + .3514E-06 + .2590E-06 + .1900E-06 + .1521E-06 + .1241E-06 + .1051E-06 + .8891E-07 + .8027E-07 + .7472E-07 + .6956E-07 + .6460E-07 + .5839E-07 + .5277E-07 + .4745E-07 + .4245E-07 + .3798E-07 + .3640E-07 + .1822E-05 + .1951E-05 + .2077E-05 + .2214E-05 + .2366E-05 + .2532E-05 + .2720E-05 + .2914E-05 + .3159E-05 + .3388E-05 + .3649E-05 + .3944E-05 + .4275E-05 + .4668E-05 + .5120E-05 + .5632E-05 + .6188E-05 + .6780E-05 + .7347E-05 + .7835E-05 + .8229E-05 + .8494E-05 + .8705E-05 + .8856E-05 + .8912E-05 + .8909E-05 + .8823E-05 + .8616E-05 + .8297E-05 + .7838E-05 + .7277E-05 + .6579E-05 + .5816E-05 + .5035E-05 + .4248E-05 + .3497E-05 + .2799E-05 + .2167E-05 + .1588E-05 + .1100E-05 + .7397E-06 + .5589E-06 + .4223E-06 + .3191E-06 + .2343E-06 + .1865E-06 + .1489E-06 + .1194E-06 + .9579E-07 + .8469E-07 + .7842E-07 + .7261E-07 + .6721E-07 + .6194E-07 + .5709E-07 + .5233E-07 + .4772E-07 + .4352E-07 + .4201E-07 + .1827E-05 + .1955E-05 + .2075E-05 + .2205E-05 + .2351E-05 + .2515E-05 + .2700E-05 + .2900E-05 + .3128E-05 + .3363E-05 + .3622E-05 + .3925E-05 + .4246E-05 + .4632E-05 + .5077E-05 + .5587E-05 + .6126E-05 + .6704E-05 + .7278E-05 + .7746E-05 + .8136E-05 + .8403E-05 + .8596E-05 + .8726E-05 + .8766E-05 + .8743E-05 + .8648E-05 + .8435E-05 + .8123E-05 + .7693E-05 + .7157E-05 + .6505E-05 + .5773E-05 + .5016E-05 + .4268E-05 + .3549E-05 + .2886E-05 + .2276E-05 + .1703E-05 + .1214E-05 + .8530E-06 + .6478E-06 + .4920E-06 + .3736E-06 + .2762E-06 + .2221E-06 + .1750E-06 + .1327E-06 + .1006E-06 + .8699E-07 + .8001E-07 + .7358E-07 + .6768E-07 + .6228E-07 + .5732E-07 + .5233E-07 + .4743E-07 + .4299E-07 + .4141E-07 + .1838E-05 + .1963E-05 + .2080E-05 + .2207E-05 + .2349E-05 + .2509E-05 + .2690E-05 + .2888E-05 + .3096E-05 + .3334E-05 + .3591E-05 + .3903E-05 + .4229E-05 + .4605E-05 + .5050E-05 + .5553E-05 + .6100E-05 + .6654E-05 + .7183E-05 + .7658E-05 + .8054E-05 + .8306E-05 + .8499E-05 + .8622E-05 + .8642E-05 + .8608E-05 + .8514E-05 + .8298E-05 + .7982E-05 + .7546E-05 + .7030E-05 + .6426E-05 + .5695E-05 + .4954E-05 + .4261E-05 + .3584E-05 + .2980E-05 + .2396E-05 + .1842E-05 + .1356E-05 + .9774E-06 + .7420E-06 + .5633E-06 + .4277E-06 + .3191E-06 + .2605E-06 + .2033E-06 + .1457E-06 + .1044E-06 + .8817E-07 + .8049E-07 + .7349E-07 + .6709E-07 + .6114E-07 + .5572E-07 + .5022E-07 + .4479E-07 + .3996E-07 + .3825E-07 + .1843E-05 + .1968E-05 + .2093E-05 + .2227E-05 + .2368E-05 + .2524E-05 + .2695E-05 + .2888E-05 + .3095E-05 + .3331E-05 + .3591E-05 + .3904E-05 + .4236E-05 + .4612E-05 + .5049E-05 + .5532E-05 + .6051E-05 + .6590E-05 + .7074E-05 + .7406E-05 + .7704E-05 + .7936E-05 + .8148E-05 + .8331E-05 + .8266E-05 + .8130E-05 + .7974E-05 + .7766E-05 + .7515E-05 + .7214E-05 + .6737E-05 + .6210E-05 + .5633E-05 + .4958E-05 + .4328E-05 + .3689E-05 + .3103E-05 + .2520E-05 + .1968E-05 + .1507E-05 + .1121E-05 + .8501E-06 + .6448E-06 + .4890E-06 + .3682E-06 + .3053E-06 + .2361E-06 + .1598E-06 + .1082E-06 + .8927E-07 + .8091E-07 + .7333E-07 + .6644E-07 + .5996E-07 + .5411E-07 + .4814E-07 + .4226E-07 + .3710E-07 + .3530E-07 + .1849E-05 + .1975E-05 + .2110E-05 + .2252E-05 + .2396E-05 + .2548E-05 + .2709E-05 + .2895E-05 + .3104E-05 + .3327E-05 + .3580E-05 + .3871E-05 + .4207E-05 + .4592E-05 + .5021E-05 + .5486E-05 + .5977E-05 + .6494E-05 + .6951E-05 + .7200E-05 + .7437E-05 + .7632E-05 + .7831E-05 + .8030E-05 + .7915E-05 + .7730E-05 + .7534E-05 + .7312E-05 + .7096E-05 + .6886E-05 + .6463E-05 + .6002E-05 + .5545E-05 + .4950E-05 + .4351E-05 + .3738E-05 + .3160E-05 + .2576E-05 + .2025E-05 + .1592E-05 + .1220E-05 + .9416E-06 + .7266E-06 + .5607E-06 + .4260E-06 + .3587E-06 + .2748E-06 + .1758E-06 + .1124E-06 + .9063E-07 + .8154E-07 + .7336E-07 + .6597E-07 + .5896E-07 + .5269E-07 + .4627E-07 + .3998E-07 + .3454E-07 + .3266E-07 + .1857E-05 + .1985E-05 + .2122E-05 + .2267E-05 + .2410E-05 + .2559E-05 + .2718E-05 + .2896E-05 + .3092E-05 + .3302E-05 + .3534E-05 + .3795E-05 + .4132E-05 + .4523E-05 + .4951E-05 + .5409E-05 + .5900E-05 + .6383E-05 + .6827E-05 + .7144E-05 + .7419E-05 + .7567E-05 + .7718E-05 + .7856E-05 + .7761E-05 + .7619E-05 + .7443E-05 + .7184E-05 + .6935E-05 + .6694E-05 + .6319E-05 + .5896E-05 + .5424E-05 + .4876E-05 + .4280E-05 + .3687E-05 + .3142E-05 + .2579E-05 + .2049E-05 + .1628E-05 + .1278E-05 + .9969E-06 + .7774E-06 + .6063E-06 + .4648E-06 + .3961E-06 + .3010E-06 + .1838E-06 + .1122E-06 + .8897E-07 + .7986E-07 + .7169E-07 + .6434E-07 + .5754E-07 + .5146E-07 + .4529E-07 + .3927E-07 + .3404E-07 + .3224E-07 + .1856E-05 + .1985E-05 + .2123E-05 + .2270E-05 + .2411E-05 + .2558E-05 + .2713E-05 + .2882E-05 + .3065E-05 + .3260E-05 + .3471E-05 + .3702E-05 + .4037E-05 + .4431E-05 + .4857E-05 + .5306E-05 + .5792E-05 + .6241E-05 + .6670E-05 + .7051E-05 + .7361E-05 + .7463E-05 + .7566E-05 + .7645E-05 + .7570E-05 + .7472E-05 + .7314E-05 + .7022E-05 + .6742E-05 + .6474E-05 + .6147E-05 + .5762E-05 + .5278E-05 + .4779E-05 + .4188E-05 + .3617E-05 + .3107E-05 + .2569E-05 + .2062E-05 + .1655E-05 + .1332E-05 + .1040E-05 + .8123E-06 + .6343E-06 + .4908E-06 + .4226E-06 + .3187E-06 + .1866E-06 + .1093E-06 + .8548E-07 + .7674E-07 + .6889E-07 + .6185E-07 + .5562E-07 + .5002E-07 + .4442E-07 + .3900E-07 + .3424E-07 + .3258E-07 + .1839E-05 + .1968E-05 + .2106E-05 + .2253E-05 + .2392E-05 + .2533E-05 + .2684E-05 + .2843E-05 + .3011E-05 + .3189E-05 + .3378E-05 + .3579E-05 + .3909E-05 + .4302E-05 + .4722E-05 + .5159E-05 + .5637E-05 + .6047E-05 + .6459E-05 + .6898E-05 + .7240E-05 + .7295E-05 + .7352E-05 + .7374E-05 + .7318E-05 + .7262E-05 + .7124E-05 + .6803E-05 + .6497E-05 + .6205E-05 + .5925E-05 + .5581E-05 + .5090E-05 + .4642E-05 + .4062E-05 + .3517E-05 + .3046E-05 + .2536E-05 + .2057E-05 + .1669E-05 + .1376E-05 + .1076E-05 + .8413E-06 + .6578E-06 + .5136E-06 + .4469E-06 + .3345E-06 + .1878E-06 + .1055E-06 + .8140E-07 + .7308E-07 + .6561E-07 + .5894E-07 + .5329E-07 + .4818E-07 + .4318E-07 + .3839E-07 + .3413E-07 + .3262E-07 + .1782E-05 + .1912E-05 + .2045E-05 + .2187E-05 + .2326E-05 + .2464E-05 + .2610E-05 + .2764E-05 + .2928E-05 + .3101E-05 + .3285E-05 + .3480E-05 + .3769E-05 + .4126E-05 + .4508E-05 + .4909E-05 + .5403E-05 + .5870E-05 + .6195E-05 + .6538E-05 + .6813E-05 + .6895E-05 + .6978E-05 + .6962E-05 + .6891E-05 + .6822E-05 + .6698E-05 + .6449E-05 + .6210E-05 + .5979E-05 + .5679E-05 + .5340E-05 + .4906E-05 + .4459E-05 + .3890E-05 + .3402E-05 + .2978E-05 + .2489E-05 + .2026E-05 + .1649E-05 + .1361E-05 + .1080E-05 + .8572E-06 + .6801E-06 + .5293E-06 + .4652E-06 + .3533E-06 + .2031E-06 + .1167E-06 + .8908E-07 + .7778E-07 + .6790E-07 + .5942E-07 + .5334E-07 + .4789E-07 + .4226E-07 + .3670E-07 + .3187E-07 + .3020E-07 + .1727E-05 + .1860E-05 + .1988E-05 + .2125E-05 + .2263E-05 + .2397E-05 + .2540E-05 + .2690E-05 + .2849E-05 + .3018E-05 + .3197E-05 + .3387E-05 + .3636E-05 + .3960E-05 + .4306E-05 + .4674E-05 + .5183E-05 + .5702E-05 + .5946E-05 + .6201E-05 + .6417E-05 + .6522E-05 + .6628E-05 + .6577E-05 + .6495E-05 + .6414E-05 + .6301E-05 + .6118E-05 + .5940E-05 + .5767E-05 + .5447E-05 + .5114E-05 + .4733E-05 + .4286E-05 + .3728E-05 + .3293E-05 + .2915E-05 + .2445E-05 + .1997E-05 + .1630E-05 + .1348E-05 + .1085E-05 + .8740E-06 + .7038E-06 + .5458E-06 + .4846E-06 + .3735E-06 + .2198E-06 + .1293E-06 + .9758E-07 + .8285E-07 + .7034E-07 + .5995E-07 + .5343E-07 + .4763E-07 + .4138E-07 + .3511E-07 + .2979E-07 + .2797E-07 + .1679E-05 + .1814E-05 + .1938E-05 + .2070E-05 + .2208E-05 + .2339E-05 + .2478E-05 + .2625E-05 + .2780E-05 + .2945E-05 + .3120E-05 + .3304E-05 + .3518E-05 + .3810E-05 + .4125E-05 + .4463E-05 + .4986E-05 + .5553E-05 + .5723E-05 + .5897E-05 + .6059E-05 + .6185E-05 + .6313E-05 + .6230E-05 + .6137E-05 + .6046E-05 + .5944E-05 + .5819E-05 + .5697E-05 + .5577E-05 + .5238E-05 + .4910E-05 + .4577E-05 + .4130E-05 + .3583E-05 + .3196E-05 + .2860E-05 + .2408E-05 + .1973E-05 + .1617E-05 + .1338E-05 + .1093E-05 + .8936E-06 + .7303E-06 + .5643E-06 + .5062E-06 + .3959E-06 + .2385E-06 + .1437E-06 + .1072E-06 + .8848E-07 + .7305E-07 + .6065E-07 + .5367E-07 + .4749E-07 + .4063E-07 + .3367E-07 + .2791E-07 + .2598E-07 + .1646E-05 + .1781E-05 + .1904E-05 + .2036E-05 + .2177E-05 + .2308E-05 + .2444E-05 + .2588E-05 + .2740E-05 + .2901E-05 + .3072E-05 + .3253E-05 + .3444E-05 + .3710E-05 + .4000E-05 + .4314E-05 + .4813E-05 + .5362E-05 + .5498E-05 + .5639E-05 + .5782E-05 + .5929E-05 + .6057E-05 + .5953E-05 + .5851E-05 + .5750E-05 + .5651E-05 + .5554E-05 + .5458E-05 + .5364E-05 + .5047E-05 + .4718E-05 + .4411E-05 + .3983E-05 + .3476E-05 + .3130E-05 + .2824E-05 + .2376E-05 + .1951E-05 + .1601E-05 + .1329E-05 + .1105E-05 + .9195E-06 + .7649E-06 + .5890E-06 + .5337E-06 + .4236E-06 + .2612E-06 + .1611E-06 + .1188E-06 + .9539E-07 + .7659E-07 + .6194E-07 + .5442E-07 + .4781E-07 + .4027E-07 + .3261E-07 + .2640E-07 + .2436E-07 + .1619E-05 + .1751E-05 + .1878E-05 + .2014E-05 + .2161E-05 + .2295E-05 + .2428E-05 + .2567E-05 + .2715E-05 + .2872E-05 + .3039E-05 + .3215E-05 + .3402E-05 + .3642E-05 + .3915E-05 + .4209E-05 + .4632E-05 + .5072E-05 + .5229E-05 + .5389E-05 + .5555E-05 + .5726E-05 + .5826E-05 + .5713E-05 + .5602E-05 + .5494E-05 + .5387E-05 + .5283E-05 + .5180E-05 + .5080E-05 + .4835E-05 + .4503E-05 + .4193E-05 + .3815E-05 + .3392E-05 + .3081E-05 + .2793E-05 + .2331E-05 + .1914E-05 + .1571E-05 + .1310E-05 + .1114E-05 + .9472E-06 + .8054E-06 + .6180E-06 + .5657E-06 + .4557E-06 + .2877E-06 + .1816E-06 + .1324E-06 + .1034E-06 + .8072E-07 + .6358E-07 + .5547E-07 + .4839E-07 + .4012E-07 + .3174E-07 + .2511E-07 + .2296E-07 + .1606E-05 + .1736E-05 + .1867E-05 + .2009E-05 + .2162E-05 + .2302E-05 + .2431E-05 + .2569E-05 + .2713E-05 + .2867E-05 + .3031E-05 + .3205E-05 + .3388E-05 + .3605E-05 + .3864E-05 + .4142E-05 + .4495E-05 + .4839E-05 + .5013E-05 + .5194E-05 + .5382E-05 + .5576E-05 + .5650E-05 + .5528E-05 + .5409E-05 + .5293E-05 + .5178E-05 + .5067E-05 + .4958E-05 + .4851E-05 + .4670E-05 + .4333E-05 + .4020E-05 + .3683E-05 + .3337E-05 + .3059E-05 + .2784E-05 + .2306E-05 + .1893E-05 + .1554E-05 + .1302E-05 + .1121E-05 + .9642E-06 + .8296E-06 + .6357E-06 + .5841E-06 + .4732E-06 + .3014E-06 + .1919E-06 + .1394E-06 + .1077E-06 + .8318E-07 + .6487E-07 + .5644E-07 + .4910E-07 + .4048E-07 + .3174E-07 + .2489E-07 + .2268E-07 + .1601E-05 + .1729E-05 + .1866E-05 + .2014E-05 + .2173E-05 + .2319E-05 + .2447E-05 + .2582E-05 + .2725E-05 + .2876E-05 + .3038E-05 + .3210E-05 + .3391E-05 + .3586E-05 + .3832E-05 + .4094E-05 + .4383E-05 + .4638E-05 + .4830E-05 + .5030E-05 + .5238E-05 + .5455E-05 + .5506E-05 + .5375E-05 + .5248E-05 + .5123E-05 + .5002E-05 + .4883E-05 + .4767E-05 + .4654E-05 + .4533E-05 + .4190E-05 + .3873E-05 + .3574E-05 + .3299E-05 + .3051E-05 + .2789E-05 + .2293E-05 + .1882E-05 + .1545E-05 + .1301E-05 + .1126E-05 + .9742E-06 + .8431E-06 + .6460E-06 + .5936E-06 + .4808E-06 + .3063E-06 + .1951E-06 + .1416E-06 + .1094E-06 + .8452E-07 + .6592E-07 + .5735E-07 + .4990E-07 + .4113E-07 + .3225E-07 + .2529E-07 + .2305E-07 + .1560E-05 + .1685E-05 + .1836E-05 + .1989E-05 + .2142E-05 + .2287E-05 + .2419E-05 + .2555E-05 + .2698E-05 + .2849E-05 + .3012E-05 + .3179E-05 + .3355E-05 + .3541E-05 + .3769E-05 + .4011E-05 + .4266E-05 + .4495E-05 + .4692E-05 + .4898E-05 + .5096E-05 + .5294E-05 + .5363E-05 + .5297E-05 + .5200E-05 + .5073E-05 + .4950E-05 + .4829E-05 + .4711E-05 + .4560E-05 + .4413E-05 + .4094E-05 + .3798E-05 + .3528E-05 + .3283E-05 + .3055E-05 + .2808E-05 + .2308E-05 + .1897E-05 + .1559E-05 + .1313E-05 + .1136E-05 + .9831E-06 + .8506E-06 + .6518E-06 + .5989E-06 + .4851E-06 + .3090E-06 + .1968E-06 + .1429E-06 + .1104E-06 + .8528E-07 + .6651E-07 + .5786E-07 + .5034E-07 + .4150E-07 + .3254E-07 + .2552E-07 + .2325E-07 + .1519E-05 + .1644E-05 + .1810E-05 + .1968E-05 + .2113E-05 + .2256E-05 + .2395E-05 + .2532E-05 + .2677E-05 + .2830E-05 + .2994E-05 + .3157E-05 + .3328E-05 + .3509E-05 + .3720E-05 + .3940E-05 + .4170E-05 + .4387E-05 + .4588E-05 + .4798E-05 + .4981E-05 + .5155E-05 + .5250E-05 + .5260E-05 + .5200E-05 + .5072E-05 + .4947E-05 + .4825E-05 + .4705E-05 + .4508E-05 + .4319E-05 + .4028E-05 + .3758E-05 + .3513E-05 + .3288E-05 + .3077E-05 + .2843E-05 + .2340E-05 + .1926E-05 + .1586E-05 + .1335E-05 + .1154E-05 + .9967E-06 + .8611E-06 + .6598E-06 + .6063E-06 + .4911E-06 + .3128E-06 + .1992E-06 + .1446E-06 + .1117E-06 + .8633E-07 + .6733E-07 + .5858E-07 + .5096E-07 + .4201E-07 + .3294E-07 + .2583E-07 + .2354E-07 + .1470E-05 + .1592E-05 + .1771E-05 + .1933E-05 + .2070E-05 + .2210E-05 + .2354E-05 + .2492E-05 + .2637E-05 + .2791E-05 + .2955E-05 + .3112E-05 + .3278E-05 + .3453E-05 + .3646E-05 + .3844E-05 + .4049E-05 + .4253E-05 + .4455E-05 + .4668E-05 + .4835E-05 + .4985E-05 + .5103E-05 + .5187E-05 + .5164E-05 + .5034E-05 + .4909E-05 + .4786E-05 + .4666E-05 + .4426E-05 + .4198E-05 + .3935E-05 + .3692E-05 + .3473E-05 + .3269E-05 + .3077E-05 + .2858E-05 + .2356E-05 + .1942E-05 + .1601E-05 + .1348E-05 + .1163E-05 + .1003E-05 + .8655E-06 + .6632E-06 + .6094E-06 + .4936E-06 + .3144E-06 + .2002E-06 + .1454E-06 + .1123E-06 + .8677E-07 + .6768E-07 + .5888E-07 + .5122E-07 + .4223E-07 + .3311E-07 + .2597E-07 + .2366E-07 + .8288E-06 + .9136E-06 + .1008E-05 + .1108E-05 + .1212E-05 + .1324E-05 + .1439E-05 + .1557E-05 + .1682E-05 + .1816E-05 + .1961E-05 + .2117E-05 + .2286E-05 + .2468E-05 + .2674E-05 + .2899E-05 + .3130E-05 + .3357E-05 + .3525E-05 + .3624E-05 + .3726E-05 + .3762E-05 + .3709E-05 + .3657E-05 + .3605E-05 + .3554E-05 + .3504E-05 + .3414E-05 + .3286E-05 + .3163E-05 + .3045E-05 + .2912E-05 + .2781E-05 + .2583E-05 + .2399E-05 + .2219E-05 + .1966E-05 + .1733E-05 + .1511E-05 + .1267E-05 + .1010E-05 + .9338E-06 + .8630E-06 + .7975E-06 + .5395E-06 + .3037E-06 + .1732E-06 + .1012E-06 + .5912E-07 + .4578E-07 + .4052E-07 + .3587E-07 + .3192E-07 + .3014E-07 + .2847E-07 + .2537E-07 + .2143E-07 + .1811E-07 + .1698E-07 + .8472E-06 + .9378E-06 + .1039E-05 + .1141E-05 + .1249E-05 + .1365E-05 + .1484E-05 + .1610E-05 + .1739E-05 + .1878E-05 + .2028E-05 + .2190E-05 + .2365E-05 + .2553E-05 + .2778E-05 + .3028E-05 + .3267E-05 + .3474E-05 + .3643E-05 + .3768E-05 + .3898E-05 + .3957E-05 + .3887E-05 + .3819E-05 + .3751E-05 + .3685E-05 + .3621E-05 + .3529E-05 + .3414E-05 + .3303E-05 + .3195E-05 + .3045E-05 + .2891E-05 + .2696E-05 + .2512E-05 + .2321E-05 + .2084E-05 + .1851E-05 + .1601E-05 + .1351E-05 + .1084E-05 + .9803E-06 + .8869E-06 + .8024E-06 + .5428E-06 + .3056E-06 + .1742E-06 + .1018E-06 + .5948E-07 + .4606E-07 + .4077E-07 + .3609E-07 + .3211E-07 + .3033E-07 + .2864E-07 + .2553E-07 + .2156E-07 + .1822E-07 + .1708E-07 + .8645E-06 + .9611E-06 + .1069E-05 + .1173E-05 + .1285E-05 + .1404E-05 + .1528E-05 + .1661E-05 + .1796E-05 + .1939E-05 + .2094E-05 + .2261E-05 + .2442E-05 + .2636E-05 + .2881E-05 + .3157E-05 + .3405E-05 + .3589E-05 + .3759E-05 + .3912E-05 + .4072E-05 + .4154E-05 + .4067E-05 + .3981E-05 + .3897E-05 + .3815E-05 + .3735E-05 + .3643E-05 + .3542E-05 + .3443E-05 + .3347E-05 + .3178E-05 + .3000E-05 + .2810E-05 + .2627E-05 + .2423E-05 + .2207E-05 + .1974E-05 + .1695E-05 + .1439E-05 + .1160E-05 + .1028E-05 + .9100E-06 + .8059E-06 + .5452E-06 + .3069E-06 + .1750E-06 + .1022E-06 + .5974E-07 + .4626E-07 + .4095E-07 + .3625E-07 + .3225E-07 + .3046E-07 + .2877E-07 + .2564E-07 + .2166E-07 + .1830E-07 + .1715E-07 + .8843E-06 + .9875E-06 + .1102E-05 + .1209E-05 + .1326E-05 + .1449E-05 + .1578E-05 + .1718E-05 + .1858E-05 + .2007E-05 + .2167E-05 + .2341E-05 + .2529E-05 + .2733E-05 + .2996E-05 + .3297E-05 + .3557E-05 + .3723E-05 + .3893E-05 + .4074E-05 + .4263E-05 + .4366E-05 + .4263E-05 + .4160E-05 + .4059E-05 + .3961E-05 + .3865E-05 + .3771E-05 + .3680E-05 + .3587E-05 + .3498E-05 + .3315E-05 + .3118E-05 + .2928E-05 + .2744E-05 + .2528E-05 + .2325E-05 + .2092E-05 + .1785E-05 + .1520E-05 + .1229E-05 + .1070E-05 + .9312E-06 + .8107E-06 + .5484E-06 + .3087E-06 + .1760E-06 + .1029E-06 + .6010E-07 + .4654E-07 + .4119E-07 + .3646E-07 + .3245E-07 + .3064E-07 + .2894E-07 + .2579E-07 + .2179E-07 + .1840E-07 + .1726E-07 + .9222E-06 + .1034E-05 + .1156E-05 + .1271E-05 + .1395E-05 + .1524E-05 + .1658E-05 + .1804E-05 + .1955E-05 + .2114E-05 + .2284E-05 + .2473E-05 + .2678E-05 + .2905E-05 + .3185E-05 + .3496E-05 + .3778E-05 + .3965E-05 + .4137E-05 + .4333E-05 + .4541E-05 + .4640E-05 + .4536E-05 + .4424E-05 + .4309E-05 + .4199E-05 + .4090E-05 + .3983E-05 + .3882E-05 + .3750E-05 + .3643E-05 + .3468E-05 + .3284E-05 + .3072E-05 + .2869E-05 + .2647E-05 + .2412E-05 + .2164E-05 + .1850E-05 + .1555E-05 + .1241E-05 + .1084E-05 + .9472E-06 + .8275E-06 + .5598E-06 + .3151E-06 + .1797E-06 + .1050E-06 + .6135E-07 + .4750E-07 + .4205E-07 + .3722E-07 + .3312E-07 + .3128E-07 + .2954E-07 + .2633E-07 + .2224E-07 + .1879E-07 + .1761E-07 + .9624E-06 + .1083E-05 + .1213E-05 + .1338E-05 + .1469E-05 + .1603E-05 + .1745E-05 + .1896E-05 + .2058E-05 + .2227E-05 + .2409E-05 + .2613E-05 + .2837E-05 + .3090E-05 + .3388E-05 + .3710E-05 + .4015E-05 + .4227E-05 + .4399E-05 + .4613E-05 + .4842E-05 + .4935E-05 + .4831E-05 + .4707E-05 + .4577E-05 + .4455E-05 + .4331E-05 + .4209E-05 + .4098E-05 + .3924E-05 + .3797E-05 + .3631E-05 + .3461E-05 + .3224E-05 + .3001E-05 + .2773E-05 + .2504E-05 + .2240E-05 + .1917E-05 + .1591E-05 + .1254E-05 + .1092E-05 + .9515E-06 + .8288E-06 + .5629E-06 + .3210E-06 + .1848E-06 + .1082E-06 + .6337E-07 + .4901E-07 + .4326E-07 + .3818E-07 + .3388E-07 + .3201E-07 + .3024E-07 + .2700E-07 + .2288E-07 + .1939E-07 + .1820E-07 + .1009E-05 + .1140E-05 + .1279E-05 + .1414E-05 + .1555E-05 + .1695E-05 + .1844E-05 + .2002E-05 + .2177E-05 + .2358E-05 + .2551E-05 + .2774E-05 + .3019E-05 + .3303E-05 + .3621E-05 + .3956E-05 + .4287E-05 + .4526E-05 + .4699E-05 + .4932E-05 + .5185E-05 + .5273E-05 + .5168E-05 + .5032E-05 + .4885E-05 + .4749E-05 + .4607E-05 + .4469E-05 + .4347E-05 + .4124E-05 + .3976E-05 + .3819E-05 + .3665E-05 + .3400E-05 + .3153E-05 + .2918E-05 + .2611E-05 + .2330E-05 + .1997E-05 + .1636E-05 + .1273E-05 + .1094E-05 + .9397E-06 + .8073E-06 + .5541E-06 + .3270E-06 + .1929E-06 + .1137E-06 + .6698E-07 + .5164E-07 + .4522E-07 + .3960E-07 + .3490E-07 + .3300E-07 + .3120E-07 + .2800E-07 + .2393E-07 + .2046E-07 + .1927E-07 + .1047E-05 + .1188E-05 + .1336E-05 + .1481E-05 + .1629E-05 + .1775E-05 + .1930E-05 + .2093E-05 + .2280E-05 + .2472E-05 + .2677E-05 + .2917E-05 + .3182E-05 + .3495E-05 + .3832E-05 + .4176E-05 + .4533E-05 + .4799E-05 + .4970E-05 + .5223E-05 + .5500E-05 + .5579E-05 + .5475E-05 + .5328E-05 + .5162E-05 + .5012E-05 + .4853E-05 + .4699E-05 + .4565E-05 + .4332E-05 + .4178E-05 + .4026E-05 + .3863E-05 + .3588E-05 + .3334E-05 + .3084E-05 + .2751E-05 + .2444E-05 + .2091E-05 + .1713E-05 + .1331E-05 + .1113E-05 + .9309E-06 + .7786E-06 + .5401E-06 + .3299E-06 + .1995E-06 + .1183E-06 + .7012E-07 + .5388E-07 + .4682E-07 + .4069E-07 + .3560E-07 + .3369E-07 + .3188E-07 + .2875E-07 + .2479E-07 + .2138E-07 + .2020E-07 + .1088E-05 + .1239E-05 + .1395E-05 + .1550E-05 + .1707E-05 + .1858E-05 + .2020E-05 + .2188E-05 + .2388E-05 + .2592E-05 + .2809E-05 + .3068E-05 + .3355E-05 + .3700E-05 + .4056E-05 + .4410E-05 + .4795E-05 + .5090E-05 + .5259E-05 + .5533E-05 + .5834E-05 + .5904E-05 + .5802E-05 + .5641E-05 + .5457E-05 + .5291E-05 + .5114E-05 + .4942E-05 + .4795E-05 + .4580E-05 + .4433E-05 + .4283E-05 + .4087E-05 + .3817E-05 + .3565E-05 + .3292E-05 + .2941E-05 + .2600E-05 + .2213E-05 + .1831E-05 + .1429E-05 + .1153E-05 + .9308E-06 + .7512E-06 + .5265E-06 + .3329E-06 + .2063E-06 + .1231E-06 + .7342E-07 + .5622E-07 + .4848E-07 + .4181E-07 + .3632E-07 + .3440E-07 + .3258E-07 + .2953E-07 + .2568E-07 + .2234E-07 + .2118E-07 + .1131E-05 + .1294E-05 + .1460E-05 + .1626E-05 + .1792E-05 + .1949E-05 + .2118E-05 + .2293E-05 + .2506E-05 + .2723E-05 + .2953E-05 + .3232E-05 + .3543E-05 + .3924E-05 + .4301E-05 + .4666E-05 + .5080E-05 + .5409E-05 + .5574E-05 + .5871E-05 + .6201E-05 + .6259E-05 + .6159E-05 + .5984E-05 + .5778E-05 + .5596E-05 + .5398E-05 + .5207E-05 + .5047E-05 + .4851E-05 + .4713E-05 + .4565E-05 + .4332E-05 + .4068E-05 + .3820E-05 + .3520E-05 + .3150E-05 + .2769E-05 + .2346E-05 + .1960E-05 + .1538E-05 + .1197E-05 + .9324E-06 + .7260E-06 + .5143E-06 + .3365E-06 + .2138E-06 + .1283E-06 + .7701E-07 + .5878E-07 + .5029E-07 + .4303E-07 + .3712E-07 + .3519E-07 + .3336E-07 + .3038E-07 + .2665E-07 + .2338E-07 + .2224E-07 + .1174E-05 + .1348E-05 + .1524E-05 + .1702E-05 + .1877E-05 + .2040E-05 + .2216E-05 + .2396E-05 + .2623E-05 + .2854E-05 + .3096E-05 + .3397E-05 + .3733E-05 + .4151E-05 + .4549E-05 + .4924E-05 + .5370E-05 + .5733E-05 + .5895E-05 + .6215E-05 + .6574E-05 + .6620E-05 + .6523E-05 + .6333E-05 + .6104E-05 + .5904E-05 + .5684E-05 + .5473E-05 + .5298E-05 + .5126E-05 + .4999E-05 + .4853E-05 + .4582E-05 + .4325E-05 + .4083E-05 + .3756E-05 + .3366E-05 + .2944E-05 + .2482E-05 + .2093E-05 + .1651E-05 + .1240E-05 + .9317E-06 + .7000E-06 + .5011E-06 + .3394E-06 + .2210E-06 + .1334E-06 + .8058E-07 + .6131E-07 + .5205E-07 + .4419E-07 + .3785E-07 + .3592E-07 + .3408E-07 + .3119E-07 + .2760E-07 + .2442E-07 + .2331E-07 + .1194E-05 + .1376E-05 + .1557E-05 + .1743E-05 + .1923E-05 + .2089E-05 + .2270E-05 + .2454E-05 + .2692E-05 + .2934E-05 + .3187E-05 + .3496E-05 + .3852E-05 + .4297E-05 + .4711E-05 + .5090E-05 + .5557E-05 + .5948E-05 + .6115E-05 + .6450E-05 + .6819E-05 + .6852E-05 + .6760E-05 + .6559E-05 + .6311E-05 + .6095E-05 + .5856E-05 + .5626E-05 + .5439E-05 + .5291E-05 + .5175E-05 + .5052E-05 + .4933E-05 + .4673E-05 + .4333E-05 + .3981E-05 + .3593E-05 + .3149E-05 + .2680E-05 + .2155E-05 + .1698E-05 + .1240E-05 + .9052E-06 + .6609E-06 + .4782E-06 + .3352E-06 + .2237E-06 + .1359E-06 + .8258E-07 + .6262E-07 + .5275E-07 + .4444E-07 + .3780E-07 + .3590E-07 + .3409E-07 + .3135E-07 + .2798E-07 + .2498E-07 + .2392E-07 + .1243E-05 + .1429E-05 + .1613E-05 + .1803E-05 + .1988E-05 + .2166E-05 + .2364E-05 + .2570E-05 + .2830E-05 + .3114E-05 + .3410E-05 + .3665E-05 + .4043E-05 + .4495E-05 + .4944E-05 + .5359E-05 + .5839E-05 + .6249E-05 + .6555E-05 + .6879E-05 + .7142E-05 + .7181E-05 + .7082E-05 + .6876E-05 + .6609E-05 + .6356E-05 + .6090E-05 + .5822E-05 + .5618E-05 + .5442E-05 + .5312E-05 + .5203E-05 + .5100E-05 + .4880E-05 + .4569E-05 + .4195E-05 + .3740E-05 + .3215E-05 + .2677E-05 + .2137E-05 + .1664E-05 + .1207E-05 + .8759E-06 + .6354E-06 + .4646E-06 + .3371E-06 + .2306E-06 + .1409E-06 + .8617E-07 + .6513E-07 + .5444E-07 + .4551E-07 + .3844E-07 + .3653E-07 + .3472E-07 + .3209E-07 + .2889E-07 + .2601E-07 + .2499E-07 + .1281E-05 + .1471E-05 + .1658E-05 + .1852E-05 + .2042E-05 + .2229E-05 + .2442E-05 + .2667E-05 + .2944E-05 + .3261E-05 + .3590E-05 + .3811E-05 + .4209E-05 + .4665E-05 + .5147E-05 + .5597E-05 + .6086E-05 + .6512E-05 + .6912E-05 + .7217E-05 + .7395E-05 + .7425E-05 + .7324E-05 + .7121E-05 + .6861E-05 + .6599E-05 + .6325E-05 + .6037E-05 + .5813E-05 + .5604E-05 + .5446E-05 + .5340E-05 + .5238E-05 + .5035E-05 + .4735E-05 + .4337E-05 + .3818E-05 + .3227E-05 + .2632E-05 + .2081E-05 + .1597E-05 + .1156E-05 + .8371E-06 + .6061E-06 + .4478E-06 + .3363E-06 + .2358E-06 + .1450E-06 + .8920E-07 + .6720E-07 + .5574E-07 + .4623E-07 + .3877E-07 + .3688E-07 + .3509E-07 + .3259E-07 + .2959E-07 + .2688E-07 + .2590E-07 + .1316E-05 + .1512E-05 + .1708E-05 + .1909E-05 + .2106E-05 + .2302E-05 + .2528E-05 + .2762E-05 + .3049E-05 + .3373E-05 + .3721E-05 + .3966E-05 + .4386E-05 + .4845E-05 + .5363E-05 + .5848E-05 + .6348E-05 + .6792E-05 + .7161E-05 + .7439E-05 + .7611E-05 + .7596E-05 + .7499E-05 + .7315E-05 + .7120E-05 + .6915E-05 + .6673E-05 + .6403E-05 + .6156E-05 + .5896E-05 + .5677E-05 + .5543E-05 + .5403E-05 + .5149E-05 + .4815E-05 + .4381E-05 + .3808E-05 + .3179E-05 + .2545E-05 + .1984E-05 + .1491E-05 + .1088E-05 + .7934E-06 + .5787E-06 + .4322E-06 + .3358E-06 + .2413E-06 + .1494E-06 + .9244E-07 + .6941E-07 + .5713E-07 + .4702E-07 + .3915E-07 + .3728E-07 + .3550E-07 + .3313E-07 + .3035E-07 + .2780E-07 + .2688E-07 + .1338E-05 + .1533E-05 + .1729E-05 + .1929E-05 + .2129E-05 + .2331E-05 + .2564E-05 + .2802E-05 + .3098E-05 + .3409E-05 + .3763E-05 + .4080E-05 + .4500E-05 + .4976E-05 + .5510E-05 + .6035E-05 + .6571E-05 + .7031E-05 + .7381E-05 + .7625E-05 + .7767E-05 + .7718E-05 + .7633E-05 + .7483E-05 + .7345E-05 + .7178E-05 + .6973E-05 + .6742E-05 + .6488E-05 + .6206E-05 + .5956E-05 + .5760E-05 + .5552E-05 + .5241E-05 + .4855E-05 + .4374E-05 + .3761E-05 + .3100E-05 + .2449E-05 + .1878E-05 + .1389E-05 + .1020E-05 + .7487E-06 + .5498E-06 + .4149E-06 + .3337E-06 + .2458E-06 + .1531E-06 + .9530E-07 + .7133E-07 + .5825E-07 + .4757E-07 + .3934E-07 + .3749E-07 + .3573E-07 + .3351E-07 + .3096E-07 + .2860E-07 + .2775E-07 + .1343E-05 + .1530E-05 + .1718E-05 + .1910E-05 + .2108E-05 + .2311E-05 + .2545E-05 + .2779E-05 + .3084E-05 + .3364E-05 + .3711E-05 + .4142E-05 + .4539E-05 + .5043E-05 + .5573E-05 + .6139E-05 + .6736E-05 + .7208E-05 + .7547E-05 + .7753E-05 + .7842E-05 + .7771E-05 + .7706E-05 + .7602E-05 + .7515E-05 + .7367E-05 + .7202E-05 + .7033E-05 + .6788E-05 + .6517E-05 + .6269E-05 + .5975E-05 + .5669E-05 + .5295E-05 + .4842E-05 + .4309E-05 + .3672E-05 + .2986E-05 + .2341E-05 + .1761E-05 + .1286E-05 + .9501E-06 + .7018E-06 + .5183E-06 + .3953E-06 + .3291E-06 + .2484E-06 + .1556E-06 + .9752E-07 + .7274E-07 + .5895E-07 + .4777E-07 + .3922E-07 + .3741E-07 + .3569E-07 + .3363E-07 + .3134E-07 + .2921E-07 + .2844E-07 + .1382E-05 + .1565E-05 + .1746E-05 + .1930E-05 + .2117E-05 + .2312E-05 + .2536E-05 + .2772E-05 + .3057E-05 + .3348E-05 + .3694E-05 + .4117E-05 + .4502E-05 + .5017E-05 + .5570E-05 + .6173E-05 + .6791E-05 + .7299E-05 + .7643E-05 + .7867E-05 + .7962E-05 + .7898E-05 + .7842E-05 + .7779E-05 + .7710E-05 + .7602E-05 + .7480E-05 + .7342E-05 + .7098E-05 + .6799E-05 + .6513E-05 + .6157E-05 + .5756E-05 + .5333E-05 + .4842E-05 + .4273E-05 + .3598E-05 + .2883E-05 + .2219E-05 + .1617E-05 + .1137E-05 + .8483E-06 + .6327E-06 + .4719E-06 + .3629E-06 + .3098E-06 + .2393E-06 + .1526E-06 + .9727E-07 + .7298E-07 + .5914E-07 + .4793E-07 + .3936E-07 + .3758E-07 + .3588E-07 + .3388E-07 + .3167E-07 + .2961E-07 + .2883E-07 + .1446E-05 + .1626E-05 + .1803E-05 + .1979E-05 + .2154E-05 + .2340E-05 + .2550E-05 + .2791E-05 + .3050E-05 + .3368E-05 + .3717E-05 + .4090E-05 + .4472E-05 + .4994E-05 + .5584E-05 + .6227E-05 + .6855E-05 + .7413E-05 + .7770E-05 + .8037E-05 + .8162E-05 + .8115E-05 + .8064E-05 + .8043E-05 + .7977E-05 + .7921E-05 + .7844E-05 + .7724E-05 + .7477E-05 + .7129E-05 + .6784E-05 + .6377E-05 + .5876E-05 + .5406E-05 + .4883E-05 + .4280E-05 + .3556E-05 + .2807E-05 + .2113E-05 + .1483E-05 + .9962E-06 + .7269E-06 + .5304E-06 + .3870E-06 + .2983E-06 + .2552E-06 + .2006E-06 + .1340E-06 + .8952E-07 + .6912E-07 + .5716E-07 + .4727E-07 + .3954E-07 + .3780E-07 + .3613E-07 + .3391E-07 + .3135E-07 + .2899E-07 + .2801E-07 + .1479E-05 + .1653E-05 + .1822E-05 + .1990E-05 + .2158E-05 + .2341E-05 + .2550E-05 + .2789E-05 + .3056E-05 + .3374E-05 + .3706E-05 + .4095E-05 + .4517E-05 + .5020E-05 + .5614E-05 + .6235E-05 + .6857E-05 + .7406E-05 + .7822E-05 + .8119E-05 + .8226E-05 + .8181E-05 + .8157E-05 + .8145E-05 + .8118E-05 + .8086E-05 + .8034E-05 + .7906E-05 + .7671E-05 + .7299E-05 + .6871E-05 + .6427E-05 + .5932E-05 + .5438E-05 + .4901E-05 + .4287E-05 + .3531E-05 + .2719E-05 + .1970E-05 + .1335E-05 + .8715E-06 + .6205E-06 + .4418E-06 + .3146E-06 + .2430E-06 + .2084E-06 + .1667E-06 + .1167E-06 + .8167E-07 + .6489E-07 + .5475E-07 + .4620E-07 + .3938E-07 + .3768E-07 + .3606E-07 + .3364E-07 + .3076E-07 + .2814E-07 + .2698E-07 + .1497E-05 + .1664E-05 + .1825E-05 + .1984E-05 + .2144E-05 + .2324E-05 + .2529E-05 + .2764E-05 + .3034E-05 + .3347E-05 + .3661E-05 + .4057E-05 + .4510E-05 + .4988E-05 + .5583E-05 + .6176E-05 + .6791E-05 + .7329E-05 + .7798E-05 + .8127E-05 + .8224E-05 + .8190E-05 + .8189E-05 + .8182E-05 + .8188E-05 + .8175E-05 + .8141E-05 + .8005E-05 + .7783E-05 + .7398E-05 + .6903E-05 + .6427E-05 + .5937E-05 + .5416E-05 + .4866E-05 + .4242E-05 + .3460E-05 + .2601E-05 + .1815E-05 + .1186E-05 + .7480E-06 + .5216E-06 + .3637E-06 + .2536E-06 + .1963E-06 + .1688E-06 + .1374E-06 + .1008E-06 + .7389E-07 + .6042E-07 + .5202E-07 + .4479E-07 + .3889E-07 + .3726E-07 + .3569E-07 + .3310E-07 + .2993E-07 + .2709E-07 + .2576E-07 + .1516E-05 + .1679E-05 + .1841E-05 + .1996E-05 + .2153E-05 + .2329E-05 + .2525E-05 + .2753E-05 + .2996E-05 + .3304E-05 + .3624E-05 + .3973E-05 + .4403E-05 + .4863E-05 + .5477E-05 + .6063E-05 + .6696E-05 + .7264E-05 + .7767E-05 + .8153E-05 + .8313E-05 + .8341E-05 + .8338E-05 + .8326E-05 + .8303E-05 + .8284E-05 + .8223E-05 + .8095E-05 + .7869E-05 + .7520E-05 + .7041E-05 + .6523E-05 + .5970E-05 + .5371E-05 + .4777E-05 + .4115E-05 + .3301E-05 + .2433E-05 + .1655E-05 + .1035E-05 + .6052E-06 + .4223E-06 + .2948E-06 + .2057E-06 + .1596E-06 + .1375E-06 + .1139E-06 + .8752E-07 + .6725E-07 + .5659E-07 + .4971E-07 + .4367E-07 + .3864E-07 + .3706E-07 + .3554E-07 + .3276E-07 + .2930E-07 + .2623E-07 + .2475E-07 + .1526E-05 + .1685E-05 + .1845E-05 + .1996E-05 + .2149E-05 + .2321E-05 + .2509E-05 + .2728E-05 + .2953E-05 + .3245E-05 + .3563E-05 + .3883E-05 + .4285E-05 + .4740E-05 + .5352E-05 + .5932E-05 + .6584E-05 + .7181E-05 + .7716E-05 + .8159E-05 + .8387E-05 + .8479E-05 + .8488E-05 + .8490E-05 + .8459E-05 + .8435E-05 + .8349E-05 + .8234E-05 + .7994E-05 + .7644E-05 + .7156E-05 + .6586E-05 + .5977E-05 + .5318E-05 + .4670E-05 + .3965E-05 + .3137E-05 + .2281E-05 + .1519E-05 + .9064E-06 + .4921E-06 + .3430E-06 + .2391E-06 + .1667E-06 + .1296E-06 + .1119E-06 + .9435E-07 + .7596E-07 + .6116E-07 + .5296E-07 + .4747E-07 + .4255E-07 + .3835E-07 + .3683E-07 + .3536E-07 + .3240E-07 + .2865E-07 + .2538E-07 + .2377E-07 + .1524E-05 + .1675E-05 + .1831E-05 + .1977E-05 + .2128E-05 + .2294E-05 + .2477E-05 + .2683E-05 + .2909E-05 + .3164E-05 + .3468E-05 + .3787E-05 + .4153E-05 + .4627E-05 + .5202E-05 + .5782E-05 + .6452E-05 + .7079E-05 + .7645E-05 + .8145E-05 + .8448E-05 + .8606E-05 + .8653E-05 + .8710E-05 + .8708E-05 + .8681E-05 + .8575E-05 + .8484E-05 + .8206E-05 + .7787E-05 + .7243E-05 + .6601E-05 + .5947E-05 + .5262E-05 + .4535E-05 + .3780E-05 + .2965E-05 + .2152E-05 + .1412E-05 + .8000E-06 + .4046E-06 + .2807E-06 + .1948E-06 + .1351E-06 + .1053E-06 + .9115E-07 + .7820E-07 + .6597E-07 + .5565E-07 + .4959E-07 + .4535E-07 + .4148E-07 + .3809E-07 + .3662E-07 + .3520E-07 + .3206E-07 + .2804E-07 + .2457E-07 + .2283E-07 + .1527E-05 + .1677E-05 + .1830E-05 + .1969E-05 + .2117E-05 + .2279E-05 + .2460E-05 + .2663E-05 + .2883E-05 + .3131E-05 + .3423E-05 + .3747E-05 + .4102E-05 + .4552E-05 + .5077E-05 + .5677E-05 + .6351E-05 + .7010E-05 + .7606E-05 + .8155E-05 + .8519E-05 + .8748E-05 + .8875E-05 + .9006E-05 + .9059E-05 + .9027E-05 + .8922E-05 + .8819E-05 + .8496E-05 + .8077E-05 + .7469E-05 + .6738E-05 + .5978E-05 + .5188E-05 + .4364E-05 + .3549E-05 + .2740E-05 + .1974E-05 + .1273E-05 + .7046E-06 + .3469E-06 + .2365E-06 + .1613E-06 + .1100E-06 + .8592E-07 + .7453E-07 + .6507E-07 + .5751E-07 + .5083E-07 + .4661E-07 + .4350E-07 + .4060E-07 + .3798E-07 + .3655E-07 + .3518E-07 + .3184E-07 + .2754E-07 + .2388E-07 + .2201E-07 + .1535E-05 + .1686E-05 + .1836E-05 + .1969E-05 + .2112E-05 + .2272E-05 + .2451E-05 + .2660E-05 + .2869E-05 + .3132E-05 + .3413E-05 + .3747E-05 + .4107E-05 + .4502E-05 + .4969E-05 + .5601E-05 + .6270E-05 + .6963E-05 + .7586E-05 + .8178E-05 + .8593E-05 + .8898E-05 + .9140E-05 + .9363E-05 + .9494E-05 + .9455E-05 + .9369E-05 + .9225E-05 + .8848E-05 + .8491E-05 + .7809E-05 + .6971E-05 + .6054E-05 + .5099E-05 + .4167E-05 + .3288E-05 + .2487E-05 + .1770E-05 + .1120E-05 + .6192E-06 + .3069E-06 + .2037E-06 + .1352E-06 + .8975E-07 + .7026E-07 + .6108E-07 + .5427E-07 + .5026E-07 + .4654E-07 + .4392E-07 + .4183E-07 + .3983E-07 + .3796E-07 + .3658E-07 + .3524E-07 + .3171E-07 + .2712E-07 + .2326E-07 + .2128E-07 + .1529E-05 + .1678E-05 + .1826E-05 + .1957E-05 + .2097E-05 + .2255E-05 + .2432E-05 + .2637E-05 + .2845E-05 + .3111E-05 + .3374E-05 + .3698E-05 + .4053E-05 + .4431E-05 + .4935E-05 + .5564E-05 + .6211E-05 + .6895E-05 + .7534E-05 + .8108E-05 + .8584E-05 + .8920E-05 + .9219E-05 + .9493E-05 + .9689E-05 + .9699E-05 + .9664E-05 + .9507E-05 + .9118E-05 + .8747E-05 + .8056E-05 + .7107E-05 + .6064E-05 + .5005E-05 + .4017E-05 + .3125E-05 + .2348E-05 + .1658E-05 + .1037E-05 + .5721E-06 + .2842E-06 + .1803E-06 + .1143E-06 + .7252E-07 + .5690E-07 + .4958E-07 + .4483E-07 + .4350E-07 + .4221E-07 + .4099E-07 + .3983E-07 + .3870E-07 + .3758E-07 + .3625E-07 + .3496E-07 + .3127E-07 + .2645E-07 + .2244E-07 + .2037E-07 + .1518E-05 + .1664E-05 + .1810E-05 + .1938E-05 + .2077E-05 + .2233E-05 + .2407E-05 + .2607E-05 + .2816E-05 + .3082E-05 + .3324E-05 + .3633E-05 + .3980E-05 + .4351E-05 + .4919E-05 + .5534E-05 + .6154E-05 + .6815E-05 + .7465E-05 + .8003E-05 + .8543E-05 + .8897E-05 + .9233E-05 + .9544E-05 + .9802E-05 + .9880E-05 + .9906E-05 + .9746E-05 + .9359E-05 + .8949E-05 + .8270E-05 + .7207E-05 + .6049E-05 + .4906E-05 + .3881E-05 + .2988E-05 + .2242E-05 + .1573E-05 + .9745E-06 + .5361E-06 + .2665E-06 + .1698E-06 + .1082E-06 + .6892E-07 + .5432E-07 + .4743E-07 + .4304E-07 + .4203E-07 + .4105E-07 + .4006E-07 + .3909E-07 + .3814E-07 + .3717E-07 + .3570E-07 + .3430E-07 + .3075E-07 + .2579E-07 + .2128E-07 + .1921E-07 + .1518E-05 + .1662E-05 + .1802E-05 + .1928E-05 + .2065E-05 + .2223E-05 + .2397E-05 + .2602E-05 + .2807E-05 + .3088E-05 + .3333E-05 + .3626E-05 + .3977E-05 + .4362E-05 + .4868E-05 + .5447E-05 + .6086E-05 + .6742E-05 + .7404E-05 + .8005E-05 + .8529E-05 + .8871E-05 + .9198E-05 + .9563E-05 + .9879E-05 + .1002E-04 + .1005E-04 + .9928E-05 + .9579E-05 + .9155E-05 + .8372E-05 + .7233E-05 + .5999E-05 + .4854E-05 + .3815E-05 + .2918E-05 + .2157E-05 + .1503E-05 + .9435E-06 + .5285E-06 + .2656E-06 + .1679E-06 + .1062E-06 + .6716E-07 + .5319E-07 + .4653E-07 + .4228E-07 + .4133E-07 + .4039E-07 + .3948E-07 + .3860E-07 + .3773E-07 + .3682E-07 + .3520E-07 + .3365E-07 + .3028E-07 + .2517E-07 + .2017E-07 + .1812E-07 + .1528E-05 + .1669E-05 + .1804E-05 + .1929E-05 + .2065E-05 + .2224E-05 + .2398E-05 + .2604E-05 + .2807E-05 + .3099E-05 + .3348E-05 + .3631E-05 + .3985E-05 + .4380E-05 + .4835E-05 + .5388E-05 + .6042E-05 + .6694E-05 + .7370E-05 + .8035E-05 + .8545E-05 + .8882E-05 + .9208E-05 + .9618E-05 + .9990E-05 + .1021E-04 + .1026E-04 + .1016E-04 + .9834E-05 + .9373E-05 + .8505E-05 + .7301E-05 + .5995E-05 + .4836E-05 + .3783E-05 + .2885E-05 + .2109E-05 + .1463E-05 + .9318E-06 + .5322E-06 + .2704E-06 + .1688E-06 + .1053E-06 + .6574E-07 + .5232E-07 + .4586E-07 + .4174E-07 + .4082E-07 + .3993E-07 + .3909E-07 + .3829E-07 + .3750E-07 + .3665E-07 + .3487E-07 + .3317E-07 + .2996E-07 + .2469E-07 + .1920E-07 + .1716E-07 + .1541E-05 + .1674E-05 + .1807E-05 + .1930E-05 + .2063E-05 + .2215E-05 + .2381E-05 + .2574E-05 + .2768E-05 + .3056E-05 + .3305E-05 + .3586E-05 + .3932E-05 + .4312E-05 + .4764E-05 + .5322E-05 + .5952E-05 + .6578E-05 + .7265E-05 + .7974E-05 + .8472E-05 + .8831E-05 + .9183E-05 + .9589E-05 + .1000E-04 + .1033E-04 + .1043E-04 + .1037E-04 + .9979E-05 + .9389E-05 + .8569E-05 + .7373E-05 + .6043E-05 + .4842E-05 + .3793E-05 + .2928E-05 + .2158E-05 + .1504E-05 + .9754E-06 + .5705E-06 + .2931E-06 + .1765E-06 + .1063E-06 + .6403E-07 + .5121E-07 + .4497E-07 + .4099E-07 + .4013E-07 + .3928E-07 + .3851E-07 + .3780E-07 + .3709E-07 + .3630E-07 + .3436E-07 + .3253E-07 + .2949E-07 + .2410E-07 + .1819E-07 + .1618E-07 + .1549E-05 + .1680E-05 + .1812E-05 + .1935E-05 + .2067E-05 + .2215E-05 + .2378E-05 + .2566E-05 + .2761E-05 + .3041E-05 + .3294E-05 + .3578E-05 + .3909E-05 + .4277E-05 + .4730E-05 + .5276E-05 + .5881E-05 + .6506E-05 + .7205E-05 + .7924E-05 + .8434E-05 + .8835E-05 + .9203E-05 + .9615E-05 + .1006E-04 + .1043E-04 + .1056E-04 + .1050E-04 + .1006E-04 + .9407E-05 + .8624E-05 + .7453E-05 + .6110E-05 + .4884E-05 + .3833E-05 + .2973E-05 + .2206E-05 + .1550E-05 + .1017E-05 + .6044E-06 + .3103E-06 + .1819E-06 + .1067E-06 + .6255E-07 + .5027E-07 + .4423E-07 + .4038E-07 + .3955E-07 + .3875E-07 + .3805E-07 + .3742E-07 + .3679E-07 + .3605E-07 + .3396E-07 + .3200E-07 + .2911E-07 + .2359E-07 + .1728E-07 + .1529E-07 + .1550E-05 + .1683E-05 + .1819E-05 + .1942E-05 + .2075E-05 + .2222E-05 + .2392E-05 + .2587E-05 + .2798E-05 + .3065E-05 + .3327E-05 + .3617E-05 + .3923E-05 + .4282E-05 + .4742E-05 + .5251E-05 + .5825E-05 + .6487E-05 + .7200E-05 + .7876E-05 + .8429E-05 + .8908E-05 + .9273E-05 + .9704E-05 + .1016E-04 + .1048E-04 + .1058E-04 + .1048E-04 + .1002E-04 + .9411E-05 + .8649E-05 + .7528E-05 + .6194E-05 + .4972E-05 + .3914E-05 + .3014E-05 + .2248E-05 + .1600E-05 + .1052E-05 + .6277E-06 + .3165E-06 + .1851E-06 + .1082E-06 + .6330E-07 + .5025E-07 + .4388E-07 + .3984E-07 + .3895E-07 + .3809E-07 + .3749E-07 + .3703E-07 + .3658E-07 + .3600E-07 + .3411E-07 + .3231E-07 + .2930E-07 + .2349E-07 + .1707E-07 + .1510E-07 + .1564E-05 + .1700E-05 + .1840E-05 + .1964E-05 + .2096E-05 + .2238E-05 + .2403E-05 + .2592E-05 + .2800E-05 + .3080E-05 + .3348E-05 + .3657E-05 + .3943E-05 + .4293E-05 + .4757E-05 + .5236E-05 + .5811E-05 + .6484E-05 + .7204E-05 + .7888E-05 + .8439E-05 + .8982E-05 + .9383E-05 + .9842E-05 + .1030E-04 + .1058E-04 + .1060E-04 + .1049E-04 + .1005E-04 + .9460E-05 + .8672E-05 + .7574E-05 + .6280E-05 + .5072E-05 + .3996E-05 + .3065E-05 + .2285E-05 + .1626E-05 + .1066E-05 + .6269E-06 + .3129E-06 + .1864E-06 + .1110E-06 + .6612E-07 + .5097E-07 + .4376E-07 + .3923E-07 + .3818E-07 + .3717E-07 + .3671E-07 + .3651E-07 + .3631E-07 + .3602E-07 + .3467E-07 + .3337E-07 + .2996E-07 + .2372E-07 + .1747E-07 + .1550E-07 + .1592E-05 + .1730E-05 + .1874E-05 + .1998E-05 + .2130E-05 + .2265E-05 + .2418E-05 + .2592E-05 + .2785E-05 + .3096E-05 + .3367E-05 + .3704E-05 + .3977E-05 + .4319E-05 + .4783E-05 + .5237E-05 + .5835E-05 + .6504E-05 + .7230E-05 + .7958E-05 + .8477E-05 + .9078E-05 + .9539E-05 + .1003E-04 + .1050E-04 + .1073E-04 + .1065E-04 + .1054E-04 + .1015E-04 + .9558E-05 + .8712E-05 + .7617E-05 + .6382E-05 + .5193E-05 + .4086E-05 + .3128E-05 + .2325E-05 + .1640E-05 + .1068E-05 + .6117E-06 + .3038E-06 + .1855E-06 + .1133E-06 + .6915E-07 + .5176E-07 + .4370E-07 + .3868E-07 + .3748E-07 + .3631E-07 + .3598E-07 + .3604E-07 + .3609E-07 + .3608E-07 + .3529E-07 + .3452E-07 + .3068E-07 + .2397E-07 + .1790E-07 + .1594E-07 + .1594E-05 + .1740E-05 + .1892E-05 + .2025E-05 + .2164E-05 + .2307E-05 + .2466E-05 + .2641E-05 + .2844E-05 + .3131E-05 + .3420E-05 + .3752E-05 + .4004E-05 + .4372E-05 + .4838E-05 + .5281E-05 + .5898E-05 + .6589E-05 + .7318E-05 + .8039E-05 + .8568E-05 + .9196E-05 + .9679E-05 + .1020E-04 + .1064E-04 + .1081E-04 + .1068E-04 + .1054E-04 + .1014E-04 + .9544E-05 + .8719E-05 + .7643E-05 + .6454E-05 + .5281E-05 + .4175E-05 + .3190E-05 + .2358E-05 + .1653E-05 + .1071E-05 + .6109E-06 + .3014E-06 + .1874E-06 + .1165E-06 + .7246E-07 + .5267E-07 + .4372E-07 + .3821E-07 + .3686E-07 + .3555E-07 + .3534E-07 + .3564E-07 + .3595E-07 + .3621E-07 + .3599E-07 + .3577E-07 + .3147E-07 + .2428E-07 + .1838E-07 + .1642E-07 + .1589E-05 + .1744E-05 + .1904E-05 + .2049E-05 + .2197E-05 + .2352E-05 + .2519E-05 + .2699E-05 + .2918E-05 + .3167E-05 + .3477E-05 + .3797E-05 + .4026E-05 + .4427E-05 + .4893E-05 + .5328E-05 + .5964E-05 + .6682E-05 + .7412E-05 + .8115E-05 + .8663E-05 + .9309E-05 + .9804E-05 + .1035E-04 + .1076E-04 + .1085E-04 + .1069E-04 + .1051E-04 + .1010E-04 + .9493E-05 + .8707E-05 + .7654E-05 + .6511E-05 + .5354E-05 + .4259E-05 + .3248E-05 + .2388E-05 + .1665E-05 + .1074E-05 + .6134E-06 + .3007E-06 + .1900E-06 + .1201E-06 + .7588E-07 + .5356E-07 + .4371E-07 + .3772E-07 + .3622E-07 + .3478E-07 + .3469E-07 + .3523E-07 + .3578E-07 + .3632E-07 + .3668E-07 + .3704E-07 + .3226E-07 + .2457E-07 + .1886E-07 + .1691E-07 + .1640E-05 + .1798E-05 + .1959E-05 + .2106E-05 + .2257E-05 + .2412E-05 + .2578E-05 + .2767E-05 + .2962E-05 + .3228E-05 + .3513E-05 + .3811E-05 + .4069E-05 + .4430E-05 + .4909E-05 + .5371E-05 + .6011E-05 + .6716E-05 + .7459E-05 + .8165E-05 + .8765E-05 + .9366E-05 + .9815E-05 + .1035E-04 + .1073E-04 + .1081E-04 + .1059E-04 + .1041E-04 + .9968E-05 + .9373E-05 + .8624E-05 + .7623E-05 + .6507E-05 + .5353E-05 + .4266E-05 + .3273E-05 + .2420E-05 + .1696E-05 + .1104E-05 + .6461E-06 + .3324E-06 + .2063E-06 + .1281E-06 + .7948E-07 + .5448E-07 + .4371E-07 + .3725E-07 + .3560E-07 + .3403E-07 + .3406E-07 + .3483E-07 + .3562E-07 + .3644E-07 + .3739E-07 + .3837E-07 + .3308E-07 + .2488E-07 + .1936E-07 + .1741E-07 + .1692E-05 + .1853E-05 + .2018E-05 + .2165E-05 + .2317E-05 + .2472E-05 + .2638E-05 + .2835E-05 + .3012E-05 + .3289E-05 + .3552E-05 + .3839E-05 + .4120E-05 + .4454E-05 + .4938E-05 + .5423E-05 + .6065E-05 + .6760E-05 + .7509E-05 + .8222E-05 + .8858E-05 + .9422E-05 + .9832E-05 + .1033E-04 + .1069E-04 + .1077E-04 + .1049E-04 + .1031E-04 + .9852E-05 + .9272E-05 + .8553E-05 + .7596E-05 + .6504E-05 + .5358E-05 + .4279E-05 + .3299E-05 + .2450E-05 + .1725E-05 + .1135E-05 + .6784E-06 + .3647E-06 + .2230E-06 + .1363E-06 + .8334E-07 + .5547E-07 + .4376E-07 + .3682E-07 + .3503E-07 + .3334E-07 + .3347E-07 + .3447E-07 + .3550E-07 + .3660E-07 + .3816E-07 + .3978E-07 + .3396E-07 + .2521E-07 + .1989E-07 + .1795E-07 + .1745E-05 + .1916E-05 + .2084E-05 + .2230E-05 + .2378E-05 + .2535E-05 + .2704E-05 + .2903E-05 + .3085E-05 + .3354E-05 + .3607E-05 + .3918E-05 + .4203E-05 + .4555E-05 + .5016E-05 + .5511E-05 + .6150E-05 + .6841E-05 + .7579E-05 + .8310E-05 + .8920E-05 + .9482E-05 + .9879E-05 + .1031E-04 + .1066E-04 + .1070E-04 + .1041E-04 + .1022E-04 + .9801E-05 + .9233E-05 + .8525E-05 + .7588E-05 + .6506E-05 + .5387E-05 + .4314E-05 + .3334E-05 + .2473E-05 + .1747E-05 + .1170E-05 + .7048E-06 + .3906E-06 + .2375E-06 + .1444E-06 + .8777E-07 + .5673E-07 + .4400E-07 + .3655E-07 + .3463E-07 + .3280E-07 + .3304E-07 + .3427E-07 + .3554E-07 + .3692E-07 + .3911E-07 + .4143E-07 + .3501E-07 + .2566E-07 + .2053E-07 + .1858E-07 + .1795E-05 + .1970E-05 + .2138E-05 + .2282E-05 + .2428E-05 + .2584E-05 + .2755E-05 + .2952E-05 + .3143E-05 + .3401E-05 + .3650E-05 + .3970E-05 + .4253E-05 + .4618E-05 + .5056E-05 + .5561E-05 + .6188E-05 + .6877E-05 + .7612E-05 + .8343E-05 + .8922E-05 + .9460E-05 + .9846E-05 + .1023E-04 + .1055E-04 + .1058E-04 + .1030E-04 + .1011E-04 + .9702E-05 + .9154E-05 + .8453E-05 + .7532E-05 + .6479E-05 + .5396E-05 + .4337E-05 + .3366E-05 + .2507E-05 + .1786E-05 + .1208E-05 + .7347E-06 + .4181E-06 + .2560E-06 + .1567E-06 + .9592E-07 + .6283E-07 + .4901E-07 + .4090E-07 + .3882E-07 + .3685E-07 + .3684E-07 + .3774E-07 + .3867E-07 + .3964E-07 + .4092E-07 + .4225E-07 + .3567E-07 + .2669E-07 + .2177E-07 + .1988E-07 + .1829E-05 + .2003E-05 + .2165E-05 + .2305E-05 + .2448E-05 + .2600E-05 + .2770E-05 + .2959E-05 + .3164E-05 + .3407E-05 + .3658E-05 + .3965E-05 + .4237E-05 + .4605E-05 + .5020E-05 + .5533E-05 + .6134E-05 + .6817E-05 + .7559E-05 + .8262E-05 + .8799E-05 + .9288E-05 + .9661E-05 + .1002E-04 + .1030E-04 + .1035E-04 + .1008E-04 + .9929E-05 + .9496E-05 + .8979E-05 + .8283E-05 + .7380E-05 + .6382E-05 + .5348E-05 + .4323E-05 + .3378E-05 + .2543E-05 + .1837E-05 + .1245E-05 + .7653E-06 + .4450E-06 + .2787E-06 + .1746E-06 + .1094E-06 + .7673E-07 + .6197E-07 + .5310E-07 + .5093E-07 + .4885E-07 + .4779E-07 + .4719E-07 + .4659E-07 + .4588E-07 + .4375E-07 + .4171E-07 + .3558E-07 + .2840E-07 + .2378E-07 + .2206E-07 + .1829E-05 + .1999E-05 + .2157E-05 + .2300E-05 + .2446E-05 + .2598E-05 + .2773E-05 + .2953E-05 + .3180E-05 + .3400E-05 + .3650E-05 + .3955E-05 + .4217E-05 + .4588E-05 + .5016E-05 + .5518E-05 + .6103E-05 + .6765E-05 + .7475E-05 + .8147E-05 + .8644E-05 + .9117E-05 + .9464E-05 + .9795E-05 + .1004E-04 + .1006E-04 + .9812E-05 + .9659E-05 + .9230E-05 + .8735E-05 + .8057E-05 + .7205E-05 + .6268E-05 + .5285E-05 + .4304E-05 + .3391E-05 + .2581E-05 + .1889E-05 + .1285E-05 + .7971E-06 + .4684E-06 + .3010E-06 + .1934E-06 + .1243E-06 + .9342E-07 + .7811E-07 + .6872E-07 + .6660E-07 + .6455E-07 + .6180E-07 + .5881E-07 + .5597E-07 + .5294E-07 + .4662E-07 + .4106E-07 + .3539E-07 + .3013E-07 + .2590E-07 + .2441E-07 + .1819E-05 + .1983E-05 + .2140E-05 + .2290E-05 + .2443E-05 + .2597E-05 + .2781E-05 + .2953E-05 + .3206E-05 + .3400E-05 + .3648E-05 + .3958E-05 + .4211E-05 + .4588E-05 + .5050E-05 + .5534E-05 + .6109E-05 + .6745E-05 + .7405E-05 + .8047E-05 + .8509E-05 + .8985E-05 + .9300E-05 + .9594E-05 + .9810E-05 + .9790E-05 + .9554E-05 + .9386E-05 + .8973E-05 + .8492E-05 + .7835E-05 + .7049E-05 + .6169E-05 + .5233E-05 + .4302E-05 + .3419E-05 + .2631E-05 + .1950E-05 + .1333E-05 + .8335E-06 + .4920E-06 + .3303E-06 + .2217E-06 + .1488E-06 + .1121E-06 + .9338E-07 + .8119E-07 + .7654E-07 + .7215E-07 + .6808E-07 + .6428E-07 + .6068E-07 + .5694E-07 + .4979E-07 + .4354E-07 + .3793E-07 + .3293E-07 + .2859E-07 + .2709E-07 + .1822E-05 + .1969E-05 + .2117E-05 + .2264E-05 + .2418E-05 + .2574E-05 + .2758E-05 + .2928E-05 + .3186E-05 + .3391E-05 + .3644E-05 + .3944E-05 + .4225E-05 + .4602E-05 + .5065E-05 + .5548E-05 + .6130E-05 + .6763E-05 + .7386E-05 + .7991E-05 + .8436E-05 + .8836E-05 + .9126E-05 + .9395E-05 + .9567E-05 + .9553E-05 + .9258E-05 + .9072E-05 + .8692E-05 + .8215E-05 + .7608E-05 + .6865E-05 + .6035E-05 + .5154E-05 + .4263E-05 + .3412E-05 + .2657E-05 + .1996E-05 + .1400E-05 + .9052E-06 + .5501E-06 + .3796E-06 + .2620E-06 + .1808E-06 + .1333E-06 + .1094E-06 + .9278E-07 + .8398E-07 + .7602E-07 + .7088E-07 + .6702E-07 + .6338E-07 + .5964E-07 + .5305E-07 + .4719E-07 + .4155E-07 + .3624E-07 + .3161E-07 + .3001E-07 + .1825E-05 + .1955E-05 + .2091E-05 + .2234E-05 + .2387E-05 + .2545E-05 + .2727E-05 + .2895E-05 + .3154E-05 + .3375E-05 + .3635E-05 + .3922E-05 + .4234E-05 + .4610E-05 + .5067E-05 + .5551E-05 + .6141E-05 + .6774E-05 + .7362E-05 + .7930E-05 + .8360E-05 + .8677E-05 + .8944E-05 + .9187E-05 + .9315E-05 + .9314E-05 + .8956E-05 + .8754E-05 + .8408E-05 + .7934E-05 + .7380E-05 + .6676E-05 + .5895E-05 + .5067E-05 + .4217E-05 + .3400E-05 + .2677E-05 + .2041E-05 + .1473E-05 + .9888E-06 + .6222E-06 + .4396E-06 + .3106E-06 + .2195E-06 + .1585E-06 + .1280E-06 + .1059E-06 + .9208E-07 + .8004E-07 + .7374E-07 + .6984E-07 + .6615E-07 + .6243E-07 + .5649E-07 + .5111E-07 + .4548E-07 + .3986E-07 + .3493E-07 + .3321E-07 + .1799E-05 + .1927E-05 + .2053E-05 + .2186E-05 + .2331E-05 + .2487E-05 + .2664E-05 + .2843E-05 + .3083E-05 + .3307E-05 + .3562E-05 + .3853E-05 + .4150E-05 + .4519E-05 + .4960E-05 + .5442E-05 + .5996E-05 + .6602E-05 + .7200E-05 + .7721E-05 + .8131E-05 + .8440E-05 + .8673E-05 + .8874E-05 + .8974E-05 + .8954E-05 + .8611E-05 + .8410E-05 + .8078E-05 + .7647E-05 + .7127E-05 + .6488E-05 + .5753E-05 + .4964E-05 + .4158E-05 + .3402E-05 + .2718E-05 + .2110E-05 + .1557E-05 + .1078E-05 + .7189E-06 + .5167E-06 + .3714E-06 + .2670E-06 + .1890E-06 + .1501E-06 + .1212E-06 + .1012E-06 + .8446E-07 + .7689E-07 + .7295E-07 + .6921E-07 + .6550E-07 + .6028E-07 + .5548E-07 + .4990E-07 + .4393E-07 + .3868E-07 + .3684E-07 + .1807E-05 + .1936E-05 + .2053E-05 + .2178E-05 + .2318E-05 + .2475E-05 + .2652E-05 + .2843E-05 + .3066E-05 + .3299E-05 + .3552E-05 + .3851E-05 + .4141E-05 + .4526E-05 + .4966E-05 + .5458E-05 + .5990E-05 + .6574E-05 + .7178E-05 + .7649E-05 + .8033E-05 + .8322E-05 + .8531E-05 + .8680E-05 + .8746E-05 + .8707E-05 + .8407E-05 + .8195E-05 + .7875E-05 + .7463E-05 + .6973E-05 + .6368E-05 + .5666E-05 + .4901E-05 + .4147E-05 + .3440E-05 + .2784E-05 + .2198E-05 + .1656E-05 + .1182E-05 + .8278E-06 + .5995E-06 + .4342E-06 + .3144E-06 + .2231E-06 + .1760E-06 + .1392E-06 + .1105E-06 + .8779E-07 + .7813E-07 + .7339E-07 + .6894E-07 + .6466E-07 + .5954E-07 + .5484E-07 + .4915E-07 + .4295E-07 + .3754E-07 + .3566E-07 + .1855E-05 + .1985E-05 + .2097E-05 + .2217E-05 + .2356E-05 + .2517E-05 + .2697E-05 + .2899E-05 + .3107E-05 + .3357E-05 + .3615E-05 + .3922E-05 + .4215E-05 + .4671E-05 + .5143E-05 + .5661E-05 + .6188E-05 + .6740E-05 + .7331E-05 + .7721E-05 + .8048E-05 + .8275E-05 + .8478E-05 + .8541E-05 + .8550E-05 + .8487E-05 + .8318E-05 + .8066E-05 + .7759E-05 + .7329E-05 + .6869E-05 + .6239E-05 + .5557E-05 + .4805E-05 + .4151E-05 + .3479E-05 + .2839E-05 + .2271E-05 + .1744E-05 + .1281E-05 + .9180E-06 + .6761E-06 + .4979E-06 + .3667E-06 + .2632E-06 + .2071E-06 + .1605E-06 + .1208E-06 + .9099E-07 + .7882E-07 + .7298E-07 + .6757E-07 + .6250E-07 + .5723E-07 + .5239E-07 + .4654E-07 + .4019E-07 + .3471E-07 + .3281E-07 + .1858E-05 + .1984E-05 + .2094E-05 + .2213E-05 + .2352E-05 + .2513E-05 + .2692E-05 + .2898E-05 + .3094E-05 + .3349E-05 + .3610E-05 + .3918E-05 + .4221E-05 + .4706E-05 + .5188E-05 + .5703E-05 + .6235E-05 + .6775E-05 + .7335E-05 + .7671E-05 + .7968E-05 + .8165E-05 + .8347E-05 + .8346E-05 + .8339E-05 + .8250E-05 + .8145E-05 + .7873E-05 + .7580E-05 + .7145E-05 + .6702E-05 + .6095E-05 + .5435E-05 + .4702E-05 + .4103E-05 + .3486E-05 + .2893E-05 + .2352E-05 + .1841E-05 + .1383E-05 + .1013E-05 + .7576E-06 + .5667E-06 + .4239E-06 + .3077E-06 + .2415E-06 + .1834E-06 + .1309E-06 + .9346E-07 + .7881E-07 + .7192E-07 + .6564E-07 + .5989E-07 + .5451E-07 + .4962E-07 + .4367E-07 + .3727E-07 + .3180E-07 + .2993E-07 + .1814E-05 + .1927E-05 + .2041E-05 + .2165E-05 + .2305E-05 + .2461E-05 + .2636E-05 + .2837E-05 + .3025E-05 + .3272E-05 + .3536E-05 + .3835E-05 + .4154E-05 + .4624E-05 + .5090E-05 + .5569E-05 + .6120E-05 + .6671E-05 + .7184E-05 + .7495E-05 + .7795E-05 + .7996E-05 + .8140E-05 + .8100E-05 + .8117E-05 + .8000E-05 + .7890E-05 + .7622E-05 + .7340E-05 + .6914E-05 + .6475E-05 + .5940E-05 + .5302E-05 + .4595E-05 + .4003E-05 + .3462E-05 + .2949E-05 + .2445E-05 + .1951E-05 + .1486E-05 + .1112E-05 + .8435E-06 + .6400E-06 + .4856E-06 + .3566E-06 + .2790E-06 + .2077E-06 + .1406E-06 + .9514E-07 + .7809E-07 + .7025E-07 + .6319E-07 + .5687E-07 + .5146E-07 + .4657E-07 + .4062E-07 + .3425E-07 + .2888E-07 + .2705E-07 + .1788E-05 + .1898E-05 + .2013E-05 + .2141E-05 + .2284E-05 + .2440E-05 + .2617E-05 + .2812E-05 + .3008E-05 + .3247E-05 + .3495E-05 + .3794E-05 + .4122E-05 + .4566E-05 + .5032E-05 + .5510E-05 + .6059E-05 + .6596E-05 + .7066E-05 + .7380E-05 + .7642E-05 + .7828E-05 + .7967E-05 + .7936E-05 + .7923E-05 + .7797E-05 + .7652E-05 + .7379E-05 + .7089E-05 + .6667E-05 + .6245E-05 + .5744E-05 + .5132E-05 + .4463E-05 + .3915E-05 + .3434E-05 + .2977E-05 + .2505E-05 + .2033E-05 + .1570E-05 + .1188E-05 + .9081E-06 + .6940E-06 + .5304E-06 + .3911E-06 + .3117E-06 + .2303E-06 + .1474E-06 + .9427E-07 + .7586E-07 + .6807E-07 + .6108E-07 + .5484E-07 + .4952E-07 + .4472E-07 + .3907E-07 + .3309E-07 + .2804E-07 + .2631E-07 + .1765E-05 + .1876E-05 + .1989E-05 + .2121E-05 + .2267E-05 + .2425E-05 + .2606E-05 + .2793E-05 + .3004E-05 + .3235E-05 + .3457E-05 + .3760E-05 + .4091E-05 + .4505E-05 + .4975E-05 + .5466E-05 + .6003E-05 + .6512E-05 + .6941E-05 + .7267E-05 + .7474E-05 + .7637E-05 + .7784E-05 + .7783E-05 + .7719E-05 + .7591E-05 + .7401E-05 + .7121E-05 + .6816E-05 + .6396E-05 + .6000E-05 + .5516E-05 + .4933E-05 + .4310E-05 + .3819E-05 + .3392E-05 + .2981E-05 + .2541E-05 + .2096E-05 + .1639E-05 + .1250E-05 + .9595E-06 + .7363E-06 + .5651E-06 + .4168E-06 + .3417E-06 + .2521E-06 + .1523E-06 + .9195E-07 + .7278E-07 + .6550E-07 + .5895E-07 + .5307E-07 + .4791E-07 + .4325E-07 + .3802E-07 + .3261E-07 + .2797E-07 + .2637E-07 + .1762E-05 + .1869E-05 + .1977E-05 + .2101E-05 + .2238E-05 + .2391E-05 + .2558E-05 + .2750E-05 + .2935E-05 + .3168E-05 + .3385E-05 + .3693E-05 + .4023E-05 + .4440E-05 + .4900E-05 + .5399E-05 + .5908E-05 + .6378E-05 + .6777E-05 + .7098E-05 + .7300E-05 + .7428E-05 + .7513E-05 + .7503E-05 + .7416E-05 + .7266E-05 + .7072E-05 + .6779E-05 + .6469E-05 + .6050E-05 + .5665E-05 + .5208E-05 + .4694E-05 + .4143E-05 + .3667E-05 + .3312E-05 + .2963E-05 + .2564E-05 + .2152E-05 + .1704E-05 + .1311E-05 + .1011E-05 + .7794E-06 + .6010E-06 + .4435E-06 + .3740E-06 + .2756E-06 + .1571E-06 + .8955E-07 + .6972E-07 + .6293E-07 + .5681E-07 + .5128E-07 + .4628E-07 + .4176E-07 + .3694E-07 + .3208E-07 + .2786E-07 + .2639E-07 + .1740E-05 + .1844E-05 + .1943E-05 + .2058E-05 + .2183E-05 + .2329E-05 + .2481E-05 + .2675E-05 + .2833E-05 + .3066E-05 + .3280E-05 + .3587E-05 + .3913E-05 + .4332E-05 + .4776E-05 + .5274E-05 + .5750E-05 + .6177E-05 + .6543E-05 + .6849E-05 + .7047E-05 + .7138E-05 + .7161E-05 + .7136E-05 + .7032E-05 + .6862E-05 + .6671E-05 + .6369E-05 + .6062E-05 + .5648E-05 + .5277E-05 + .4852E-05 + .4409E-05 + .3939E-05 + .3485E-05 + .3196E-05 + .2912E-05 + .2559E-05 + .2184E-05 + .1751E-05 + .1358E-05 + .1048E-05 + .8087E-06 + .6240E-06 + .4622E-06 + .3897E-06 + .2892E-06 + .1681E-06 + .9776E-07 + .7547E-07 + .6665E-07 + .5887E-07 + .5209E-07 + .4713E-07 + .4264E-07 + .3735E-07 + .3176E-07 + .2700E-07 + .2538E-07 + .1689E-05 + .1795E-05 + .1891E-05 + .1998E-05 + .2116E-05 + .2252E-05 + .2403E-05 + .2583E-05 + .2755E-05 + .2981E-05 + .3201E-05 + .3491E-05 + .3822E-05 + .4223E-05 + .4661E-05 + .5133E-05 + .5592E-05 + .5989E-05 + .6301E-05 + .6556E-05 + .6718E-05 + .6775E-05 + .6770E-05 + .6713E-05 + .6597E-05 + .6422E-05 + .6220E-05 + .5916E-05 + .5627E-05 + .5224E-05 + .4863E-05 + .4464E-05 + .4092E-05 + .3749E-05 + .3368E-05 + .3077E-05 + .2856E-05 + .2542E-05 + .2201E-05 + .1792E-05 + .1399E-05 + .1084E-05 + .8396E-06 + .6504E-06 + .4836E-06 + .4078E-06 + .3047E-06 + .1807E-06 + .1072E-06 + .8205E-07 + .7090E-07 + .6126E-07 + .5314E-07 + .4820E-07 + .4372E-07 + .3793E-07 + .3158E-07 + .2629E-07 + .2451E-07 + .1643E-05 + .1751E-05 + .1846E-05 + .1949E-05 + .2062E-05 + .2192E-05 + .2340E-05 + .2511E-05 + .2688E-05 + .2910E-05 + .3134E-05 + .3411E-05 + .3745E-05 + .4132E-05 + .4563E-05 + .5009E-05 + .5442E-05 + .5802E-05 + .6064E-05 + .6266E-05 + .6383E-05 + .6404E-05 + .6372E-05 + .6281E-05 + .6152E-05 + .5972E-05 + .5763E-05 + .5465E-05 + .5192E-05 + .4812E-05 + .4473E-05 + .4104E-05 + .3784E-05 + .3535E-05 + .3234E-05 + .2960E-05 + .2785E-05 + .2521E-05 + .2212E-05 + .1826E-05 + .1434E-05 + .1116E-05 + .8684E-06 + .6758E-06 + .5045E-06 + .4254E-06 + .3200E-06 + .1936E-06 + .1171E-06 + .8891E-07 + .7516E-07 + .6354E-07 + .5403E-07 + .4913E-07 + .4468E-07 + .3839E-07 + .3129E-07 + .2551E-07 + .2359E-07 + .1614E-05 + .1725E-05 + .1826E-05 + .1932E-05 + .2047E-05 + .2178E-05 + .2323E-05 + .2493E-05 + .2659E-05 + .2882E-05 + .3109E-05 + .3381E-05 + .3718E-05 + .4095E-05 + .4524E-05 + .4947E-05 + .5332E-05 + .5643E-05 + .5860E-05 + .6003E-05 + .6055E-05 + .6032E-05 + .5971E-05 + .5841E-05 + .5696E-05 + .5505E-05 + .5295E-05 + .5019E-05 + .4757E-05 + .4419E-05 + .4119E-05 + .3791E-05 + .3492E-05 + .3285E-05 + .3080E-05 + .2861E-05 + .2700E-05 + .2504E-05 + .2224E-05 + .1853E-05 + .1463E-05 + .1145E-05 + .8961E-06 + .7013E-06 + .5255E-06 + .4431E-06 + .3356E-06 + .2071E-06 + .1278E-06 + .9621E-07 + .7958E-07 + .6582E-07 + .5487E-07 + .5002E-07 + .4560E-07 + .3880E-07 + .3097E-07 + .2472E-07 + .2268E-07 + .1561E-05 + .1678E-05 + .1785E-05 + .1895E-05 + .2014E-05 + .2148E-05 + .2295E-05 + .2466E-05 + .2632E-05 + .2854E-05 + .3083E-05 + .3357E-05 + .3691E-05 + .4063E-05 + .4474E-05 + .4868E-05 + .5207E-05 + .5471E-05 + .5643E-05 + .5730E-05 + .5731E-05 + .5666E-05 + .5577E-05 + .5428E-05 + .5266E-05 + .5067E-05 + .4859E-05 + .4600E-05 + .4345E-05 + .4048E-05 + .3792E-05 + .3517E-05 + .3265E-05 + .3101E-05 + .2958E-05 + .2769E-05 + .2627E-05 + .2479E-05 + .2223E-05 + .1871E-05 + .1488E-05 + .1171E-05 + .9214E-06 + .7250E-06 + .5453E-06 + .4599E-06 + .3507E-06 + .2208E-06 + .1390E-06 + .1037E-06 + .8394E-07 + .6793E-07 + .5551E-07 + .5073E-07 + .4636E-07 + .3906E-07 + .3053E-07 + .2386E-07 + .2172E-07 + .1502E-05 + .1627E-05 + .1742E-05 + .1858E-05 + .1983E-05 + .2123E-05 + .2277E-05 + .2452E-05 + .2630E-05 + .2853E-05 + .3085E-05 + .3370E-05 + .3699E-05 + .4072E-05 + .4454E-05 + .4818E-05 + .5115E-05 + .5338E-05 + .5464E-05 + .5502E-05 + .5462E-05 + .5355E-05 + .5242E-05 + .5086E-05 + .4906E-05 + .4700E-05 + .4495E-05 + .4245E-05 + .3995E-05 + .3733E-05 + .3524E-05 + .3306E-05 + .3121E-05 + .3000E-05 + .2889E-05 + .2706E-05 + .2587E-05 + .2469E-05 + .2230E-05 + .1897E-05 + .1525E-05 + .1194E-05 + .9349E-06 + .7321E-06 + .5514E-06 + .4650E-06 + .3555E-06 + .2255E-06 + .1430E-06 + .1064E-06 + .8540E-07 + .6855E-07 + .5560E-07 + .5086E-07 + .4652E-07 + .3906E-07 + .3028E-07 + .2348E-07 + .2131E-07 + .1520E-05 + .1646E-05 + .1772E-05 + .1906E-05 + .2050E-05 + .2199E-05 + .2359E-05 + .2532E-05 + .2726E-05 + .2952E-05 + .3196E-05 + .3471E-05 + .3776E-05 + .4110E-05 + .4396E-05 + .4674E-05 + .4951E-05 + .5228E-05 + .5206E-05 + .5098E-05 + .4978E-05 + .4850E-05 + .4724E-05 + .4594E-05 + .4463E-05 + .4329E-05 + .4176E-05 + .3966E-05 + .3764E-05 + .3569E-05 + .3391E-05 + .3239E-05 + .3107E-05 + .2989E-05 + .2877E-05 + .2753E-05 + .2646E-05 + .2420E-05 + .2163E-05 + .1799E-05 + .1430E-05 + .1151E-05 + .9256E-06 + .7447E-06 + .5609E-06 + .4730E-06 + .3617E-06 + .2294E-06 + .1455E-06 + .1082E-06 + .8688E-07 + .6973E-07 + .5655E-07 + .5173E-07 + .4732E-07 + .3973E-07 + .3080E-07 + .2389E-07 + .2167E-07 + .1561E-05 + .1689E-05 + .1821E-05 + .1962E-05 + .2113E-05 + .2267E-05 + .2431E-05 + .2608E-05 + .2811E-05 + .3041E-05 + .3288E-05 + .3551E-05 + .3837E-05 + .4147E-05 + .4388E-05 + .4599E-05 + .4810E-05 + .5021E-05 + .4976E-05 + .4867E-05 + .4745E-05 + .4612E-05 + .4483E-05 + .4357E-05 + .4235E-05 + .4116E-05 + .3980E-05 + .3804E-05 + .3638E-05 + .3479E-05 + .3328E-05 + .3202E-05 + .3088E-05 + .2979E-05 + .2874E-05 + .2772E-05 + .2640E-05 + .2386E-05 + .2114E-05 + .1745E-05 + .1371E-05 + .1124E-05 + .9217E-06 + .7557E-06 + .5692E-06 + .4800E-06 + .3670E-06 + .2328E-06 + .1476E-06 + .1098E-06 + .8816E-07 + .7076E-07 + .5739E-07 + .5250E-07 + .4802E-07 + .4032E-07 + .3126E-07 + .2424E-07 + .2199E-07 + .1618E-05 + .1749E-05 + .1887E-05 + .2035E-05 + .2190E-05 + .2350E-05 + .2519E-05 + .2703E-05 + .2916E-05 + .3153E-05 + .3404E-05 + .3656E-05 + .3929E-05 + .4222E-05 + .4436E-05 + .4590E-05 + .4729E-05 + .4850E-05 + .4812E-05 + .4734E-05 + .4626E-05 + .4489E-05 + .4356E-05 + .4227E-05 + .4102E-05 + .3981E-05 + .3850E-05 + .3700E-05 + .3563E-05 + .3430E-05 + .3303E-05 + .3192E-05 + .3090E-05 + .2991E-05 + .2896E-05 + .2803E-05 + .2639E-05 + .2382E-05 + .2095E-05 + .1727E-05 + .1342E-05 + .1117E-05 + .9288E-06 + .7726E-06 + .5820E-06 + .4908E-06 + .3752E-06 + .2380E-06 + .1509E-06 + .1123E-06 + .9014E-07 + .7234E-07 + .5868E-07 + .5367E-07 + .4910E-07 + .4122E-07 + .3196E-07 + .2478E-07 + .2249E-07 + .1663E-05 + .1797E-05 + .1940E-05 + .2093E-05 + .2253E-05 + .2416E-05 + .2591E-05 + .2781E-05 + .3002E-05 + .3243E-05 + .3496E-05 + .3735E-05 + .3992E-05 + .4267E-05 + .4451E-05 + .4547E-05 + .4614E-05 + .4650E-05 + .4619E-05 + .4571E-05 + .4476E-05 + .4337E-05 + .4202E-05 + .4071E-05 + .3944E-05 + .3821E-05 + .3697E-05 + .3573E-05 + .3463E-05 + .3357E-05 + .3253E-05 + .3158E-05 + .3068E-05 + .2981E-05 + .2896E-05 + .2814E-05 + .2618E-05 + .2360E-05 + .2061E-05 + .1696E-05 + .1305E-05 + .1101E-05 + .9289E-06 + .7838E-06 + .5904E-06 + .4979E-06 + .3807E-06 + .2415E-06 + .1531E-06 + .1139E-06 + .9145E-07 + .7340E-07 + .5953E-07 + .5445E-07 + .4981E-07 + .4182E-07 + .3243E-07 + .2514E-07 + .2281E-07 + .8805E-06 + .9774E-06 + .1077E-05 + .1181E-05 + .1288E-05 + .1376E-05 + .1470E-05 + .1572E-05 + .1690E-05 + .1824E-05 + .1965E-05 + .2100E-05 + .2226E-05 + .2361E-05 + .2502E-05 + .2652E-05 + .2811E-05 + .2980E-05 + .3162E-05 + .3316E-05 + .3437E-05 + .3546E-05 + .3641E-05 + .3724E-05 + .3719E-05 + .3640E-05 + .3556E-05 + .3466E-05 + .3378E-05 + .3292E-05 + .3160E-05 + .2986E-05 + .2822E-05 + .2635E-05 + .2414E-05 + .2198E-05 + .1963E-05 + .1671E-05 + .1404E-05 + .1153E-05 + .9212E-06 + .8001E-06 + .6949E-06 + .6036E-06 + .4212E-06 + .2682E-06 + .1667E-06 + .9897E-07 + .5875E-07 + .4506E-07 + .3904E-07 + .3382E-07 + .2941E-07 + .2663E-07 + .2411E-07 + .2129E-07 + .1837E-07 + .1585E-07 + .1498E-07 + .8880E-06 + .9855E-06 + .1084E-05 + .1189E-05 + .1288E-05 + .1377E-05 + .1472E-05 + .1576E-05 + .1695E-05 + .1828E-05 + .1966E-05 + .2097E-05 + .2227E-05 + .2364E-05 + .2508E-05 + .2661E-05 + .2823E-05 + .2994E-05 + .3185E-05 + .3361E-05 + .3521E-05 + .3649E-05 + .3743E-05 + .3803E-05 + .3779E-05 + .3707E-05 + .3618E-05 + .3515E-05 + .3414E-05 + .3316E-05 + .3189E-05 + .3036E-05 + .2891E-05 + .2677E-05 + .2449E-05 + .2224E-05 + .1988E-05 + .1699E-05 + .1410E-05 + .1150E-05 + .9134E-06 + .7906E-06 + .6842E-06 + .5922E-06 + .4132E-06 + .2631E-06 + .1636E-06 + .9710E-07 + .5764E-07 + .4421E-07 + .3830E-07 + .3319E-07 + .2885E-07 + .2613E-07 + .2366E-07 + .2089E-07 + .1803E-07 + .1555E-07 + .1470E-07 + .9248E-06 + .1026E-05 + .1127E-05 + .1235E-05 + .1329E-05 + .1422E-05 + .1521E-05 + .1632E-05 + .1756E-05 + .1893E-05 + .2030E-05 + .2163E-05 + .2300E-05 + .2445E-05 + .2596E-05 + .2756E-05 + .2926E-05 + .3107E-05 + .3312E-05 + .3518E-05 + .3725E-05 + .3879E-05 + .3973E-05 + .4011E-05 + .3966E-05 + .3898E-05 + .3803E-05 + .3681E-05 + .3563E-05 + .3449E-05 + .3323E-05 + .3188E-05 + .3058E-05 + .2808E-05 + .2564E-05 + .2323E-05 + .2080E-05 + .1785E-05 + .1463E-05 + .1185E-05 + .9352E-06 + .8065E-06 + .6956E-06 + .5999E-06 + .4186E-06 + .2666E-06 + .1657E-06 + .9836E-07 + .5839E-07 + .4479E-07 + .3880E-07 + .3362E-07 + .2923E-07 + .2647E-07 + .2397E-07 + .2117E-07 + .1826E-07 + .1575E-07 + .1489E-07 + .9700E-06 + .1076E-05 + .1180E-05 + .1294E-05 + .1385E-05 + .1483E-05 + .1587E-05 + .1705E-05 + .1836E-05 + .1978E-05 + .2118E-05 + .2256E-05 + .2402E-05 + .2558E-05 + .2720E-05 + .2891E-05 + .3073E-05 + .3265E-05 + .3487E-05 + .3723E-05 + .3977E-05 + .4155E-05 + .4251E-05 + .4268E-05 + .4204E-05 + .4141E-05 + .4038E-05 + .3899E-05 + .3763E-05 + .3631E-05 + .3503E-05 + .3378E-05 + .3253E-05 + .2974E-05 + .2715E-05 + .2453E-05 + .2197E-05 + .1894E-05 + .1539E-05 + .1239E-05 + .9711E-06 + .8332E-06 + .7149E-06 + .6135E-06 + .4281E-06 + .2726E-06 + .1694E-06 + .1006E-06 + .5971E-07 + .4580E-07 + .3968E-07 + .3438E-07 + .2989E-07 + .2707E-07 + .2451E-07 + .2164E-07 + .1867E-07 + .1611E-07 + .1523E-07 + .9726E-06 + .1081E-05 + .1187E-05 + .1302E-05 + .1396E-05 + .1494E-05 + .1600E-05 + .1720E-05 + .1854E-05 + .1999E-05 + .2145E-05 + .2292E-05 + .2449E-05 + .2616E-05 + .2790E-05 + .2973E-05 + .3168E-05 + .3368E-05 + .3596E-05 + .3835E-05 + .4098E-05 + .4271E-05 + .4364E-05 + .4382E-05 + .4324E-05 + .4264E-05 + .4165E-05 + .4029E-05 + .3888E-05 + .3743E-05 + .3602E-05 + .3454E-05 + .3287E-05 + .3044E-05 + .2799E-05 + .2518E-05 + .2250E-05 + .1951E-05 + .1598E-05 + .1282E-05 + .9975E-06 + .8450E-06 + .7159E-06 + .6065E-06 + .4232E-06 + .2695E-06 + .1675E-06 + .9944E-07 + .5903E-07 + .4528E-07 + .3923E-07 + .3398E-07 + .2955E-07 + .2676E-07 + .2423E-07 + .2140E-07 + .1846E-07 + .1593E-07 + .1505E-07 + .9953E-06 + .1107E-05 + .1218E-05 + .1336E-05 + .1435E-05 + .1538E-05 + .1647E-05 + .1771E-05 + .1910E-05 + .2062E-05 + .2216E-05 + .2377E-05 + .2548E-05 + .2730E-05 + .2922E-05 + .3120E-05 + .3333E-05 + .3546E-05 + .3785E-05 + .4031E-05 + .4311E-05 + .4480E-05 + .4571E-05 + .4591E-05 + .4539E-05 + .4482E-05 + .4384E-05 + .4250E-05 + .4099E-05 + .3938E-05 + .3780E-05 + .3604E-05 + .3390E-05 + .3179E-05 + .2944E-05 + .2639E-05 + .2351E-05 + .2051E-05 + .1695E-05 + .1354E-05 + .1046E-05 + .8699E-06 + .7236E-06 + .6020E-06 + .4211E-06 + .2706E-06 + .1694E-06 + .1009E-06 + .6010E-07 + .4612E-07 + .3992E-07 + .3455E-07 + .3002E-07 + .2720E-07 + .2466E-07 + .2179E-07 + .1882E-07 + .1625E-07 + .1537E-07 + .1042E-05 + .1161E-05 + .1278E-05 + .1403E-05 + .1510E-05 + .1618E-05 + .1734E-05 + .1866E-05 + .2014E-05 + .2176E-05 + .2343E-05 + .2522E-05 + .2712E-05 + .2916E-05 + .3130E-05 + .3350E-05 + .3587E-05 + .3820E-05 + .4076E-05 + .4335E-05 + .4639E-05 + .4809E-05 + .4900E-05 + .4922E-05 + .4874E-05 + .4820E-05 + .4721E-05 + .4586E-05 + .4422E-05 + .4239E-05 + .4058E-05 + .3848E-05 + .3576E-05 + .3397E-05 + .3169E-05 + .2829E-05 + .2514E-05 + .2207E-05 + .1838E-05 + .1463E-05 + .1122E-05 + .9080E-06 + .7351E-06 + .5951E-06 + .4192E-06 + .2757E-06 + .1758E-06 + .1057E-06 + .6354E-07 + .4882E-07 + .4216E-07 + .3640E-07 + .3156E-07 + .2866E-07 + .2603E-07 + .2307E-07 + .1997E-07 + .1730E-07 + .1637E-07 + .1108E-05 + .1236E-05 + .1363E-05 + .1496E-05 + .1613E-05 + .1730E-05 + .1855E-05 + .1997E-05 + .2156E-05 + .2332E-05 + .2516E-05 + .2717E-05 + .2932E-05 + .3162E-05 + .3405E-05 + .3652E-05 + .3921E-05 + .4178E-05 + .4457E-05 + .4734E-05 + .5069E-05 + .5241E-05 + .5333E-05 + .5359E-05 + .5316E-05 + .5263E-05 + .5163E-05 + .5025E-05 + .4844E-05 + .4633E-05 + .4425E-05 + .4172E-05 + .3855E-05 + .3664E-05 + .3443E-05 + .3096E-05 + .2759E-05 + .2435E-05 + .2043E-05 + .1626E-05 + .1245E-05 + .9749E-06 + .7632E-06 + .5974E-06 + .4237E-06 + .2853E-06 + .1854E-06 + .1125E-06 + .6821E-07 + .5249E-07 + .4521E-07 + .3894E-07 + .3369E-07 + .3067E-07 + .2791E-07 + .2479E-07 + .2153E-07 + .1869E-07 + .1771E-07 + .1184E-05 + .1323E-05 + .1460E-05 + .1603E-05 + .1732E-05 + .1859E-05 + .1994E-05 + .2148E-05 + .2321E-05 + .2512E-05 + .2715E-05 + .2942E-05 + .3186E-05 + .3447E-05 + .3723E-05 + .4003E-05 + .4309E-05 + .4594E-05 + .4899E-05 + .5197E-05 + .5569E-05 + .5742E-05 + .5835E-05 + .5864E-05 + .5827E-05 + .5777E-05 + .5676E-05 + .5535E-05 + .5334E-05 + .5091E-05 + .4849E-05 + .4547E-05 + .4195E-05 + .3954E-05 + .3744E-05 + .3418E-05 + .3067E-05 + .2721E-05 + .2295E-05 + .1833E-05 + .1409E-05 + .1062E-05 + .8001E-06 + .6029E-06 + .4304E-06 + .2968E-06 + .1965E-06 + .1203E-06 + .7362E-07 + .5672E-07 + .4874E-07 + .4188E-07 + .3616E-07 + .3298E-07 + .3008E-07 + .2679E-07 + .2332E-07 + .2031E-07 + .1926E-07 + .1254E-05 + .1403E-05 + .1551E-05 + .1703E-05 + .1843E-05 + .1979E-05 + .2124E-05 + .2289E-05 + .2475E-05 + .2682E-05 + .2904E-05 + .3158E-05 + .3431E-05 + .3724E-05 + .4035E-05 + .4349E-05 + .4692E-05 + .5007E-05 + .5337E-05 + .5655E-05 + .6063E-05 + .6235E-05 + .6327E-05 + .6360E-05 + .6331E-05 + .6285E-05 + .6184E-05 + .6043E-05 + .5822E-05 + .5544E-05 + .5268E-05 + .4911E-05 + .4524E-05 + .4229E-05 + .4035E-05 + .3741E-05 + .3379E-05 + .3013E-05 + .2556E-05 + .2049E-05 + .1581E-05 + .1146E-05 + .8314E-06 + .6030E-06 + .4334E-06 + .3060E-06 + .2063E-06 + .1275E-06 + .7874E-07 + .6074E-07 + .5207E-07 + .4464E-07 + .3846E-07 + .3516E-07 + .3213E-07 + .2868E-07 + .2504E-07 + .2187E-07 + .2076E-07 + .1312E-05 + .1469E-05 + .1626E-05 + .1787E-05 + .1937E-05 + .2082E-05 + .2235E-05 + .2410E-05 + .2607E-05 + .2828E-05 + .3067E-05 + .3347E-05 + .3649E-05 + .3973E-05 + .4319E-05 + .4665E-05 + .5047E-05 + .5388E-05 + .5743E-05 + .6076E-05 + .6519E-05 + .6686E-05 + .6775E-05 + .6812E-05 + .6794E-05 + .6753E-05 + .6654E-05 + .6515E-05 + .6275E-05 + .5963E-05 + .5651E-05 + .5239E-05 + .4819E-05 + .4468E-05 + .4295E-05 + .4043E-05 + .3677E-05 + .3295E-05 + .2811E-05 + .2261E-05 + .1751E-05 + .1222E-05 + .8532E-06 + .5956E-06 + .4310E-06 + .3116E-06 + .2140E-06 + .1334E-06 + .8318E-07 + .6425E-07 + .5494E-07 + .4698E-07 + .4040E-07 + .3701E-07 + .3390E-07 + .3033E-07 + .2656E-07 + .2325E-07 + .2210E-07 + .1348E-05 + .1511E-05 + .1674E-05 + .1839E-05 + .1997E-05 + .2147E-05 + .2307E-05 + .2490E-05 + .2697E-05 + .2931E-05 + .3187E-05 + .3489E-05 + .3817E-05 + .4168E-05 + .4543E-05 + .4918E-05 + .5329E-05 + .5696E-05 + .6067E-05 + .6409E-05 + .6865E-05 + .7024E-05 + .7109E-05 + .7149E-05 + .7139E-05 + .7101E-05 + .7004E-05 + .6867E-05 + .6611E-05 + .6268E-05 + .5926E-05 + .5468E-05 + .5025E-05 + .4630E-05 + .4292E-05 + .4029E-05 + .3778E-05 + .3443E-05 + .3011E-05 + .2470E-05 + .1948E-05 + .1298E-05 + .8653E-06 + .5767E-06 + .4202E-06 + .3110E-06 + .2177E-06 + .1369E-06 + .8613E-07 + .6662E-07 + .5683E-07 + .4848E-07 + .4161E-07 + .3819E-07 + .3506E-07 + .3145E-07 + .2761E-07 + .2424E-07 + .2306E-07 + .1407E-05 + .1571E-05 + .1735E-05 + .1902E-05 + .2062E-05 + .2221E-05 + .2396E-05 + .2602E-05 + .2827E-05 + .3102E-05 + .3399E-05 + .3736E-05 + .4099E-05 + .4474E-05 + .4870E-05 + .5285E-05 + .5696E-05 + .6113E-05 + .6497E-05 + .6826E-05 + .7175E-05 + .7342E-05 + .7422E-05 + .7460E-05 + .7433E-05 + .7360E-05 + .7238E-05 + .7065E-05 + .6790E-05 + .6417E-05 + .6058E-05 + .5612E-05 + .5183E-05 + .4828E-05 + .4520E-05 + .4236E-05 + .3919E-05 + .3505E-05 + .3004E-05 + .2450E-05 + .1912E-05 + .1268E-05 + .8414E-06 + .5581E-06 + .4094E-06 + .3103E-06 + .2212E-06 + .1404E-06 + .8915E-07 + .6904E-07 + .5876E-07 + .5001E-07 + .4282E-07 + .3940E-07 + .3624E-07 + .3259E-07 + .2869E-07 + .2525E-07 + .2405E-07 + .1453E-05 + .1620E-05 + .1784E-05 + .1953E-05 + .2115E-05 + .2282E-05 + .2470E-05 + .2693E-05 + .2932E-05 + .3238E-05 + .3569E-05 + .3934E-05 + .4328E-05 + .4735E-05 + .5158E-05 + .5608E-05 + .6027E-05 + .6480E-05 + .6864E-05 + .7178E-05 + .7430E-05 + .7589E-05 + .7652E-05 + .7685E-05 + .7641E-05 + .7539E-05 + .7402E-05 + .7207E-05 + .6929E-05 + .6543E-05 + .6177E-05 + .5748E-05 + .5321E-05 + .4985E-05 + .4683E-05 + .4365E-05 + .3983E-05 + .3495E-05 + .2940E-05 + .2370E-05 + .1825E-05 + .1213E-05 + .8062E-06 + .5359E-06 + .3958E-06 + .3071E-06 + .2231E-06 + .1429E-06 + .9155E-07 + .7099E-07 + .6027E-07 + .5117E-07 + .4373E-07 + .4031E-07 + .3717E-07 + .3350E-07 + .2957E-07 + .2610E-07 + .2489E-07 + .1501E-05 + .1672E-05 + .1843E-05 + .2017E-05 + .2184E-05 + .2359E-05 + .2557E-05 + .2791E-05 + .3036E-05 + .3348E-05 + .3698E-05 + .4081E-05 + .4496E-05 + .4961E-05 + .5436E-05 + .5908E-05 + .6369E-05 + .6825E-05 + .7190E-05 + .7493E-05 + .7700E-05 + .7821E-05 + .7840E-05 + .7862E-05 + .7802E-05 + .7687E-05 + .7556E-05 + .7370E-05 + .7121E-05 + .6754E-05 + .6396E-05 + .5985E-05 + .5527E-05 + .5148E-05 + .4784E-05 + .4398E-05 + .3950E-05 + .3404E-05 + .2815E-05 + .2219E-05 + .1672E-05 + .1130E-05 + .7642E-06 + .5165E-06 + .3841E-06 + .3051E-06 + .2258E-06 + .1460E-06 + .9437E-07 + .7327E-07 + .6206E-07 + .5256E-07 + .4483E-07 + .4141E-07 + .3826E-07 + .3457E-07 + .3060E-07 + .2709E-07 + .2585E-07 + .1538E-05 + .1707E-05 + .1877E-05 + .2048E-05 + .2216E-05 + .2396E-05 + .2600E-05 + .2837E-05 + .3089E-05 + .3389E-05 + .3745E-05 + .4123E-05 + .4539E-05 + .5015E-05 + .5518E-05 + .6028E-05 + .6537E-05 + .7011E-05 + .7406E-05 + .7725E-05 + .7910E-05 + .8005E-05 + .7993E-05 + .7991E-05 + .7912E-05 + .7798E-05 + .7672E-05 + .7486E-05 + .7248E-05 + .6894E-05 + .6547E-05 + .6137E-05 + .5666E-05 + .5248E-05 + .4837E-05 + .4394E-05 + .3891E-05 + .3294E-05 + .2661E-05 + .2056E-05 + .1527E-05 + .1050E-05 + .7218E-06 + .4963E-06 + .3716E-06 + .3022E-06 + .2279E-06 + .1486E-06 + .9698E-07 + .7539E-07 + .6370E-07 + .5382E-07 + .4581E-07 + .4241E-07 + .3927E-07 + .3557E-07 + .3157E-07 + .2802E-07 + .2677E-07 + .1566E-05 + .1727E-05 + .1889E-05 + .2051E-05 + .2217E-05 + .2397E-05 + .2603E-05 + .2838E-05 + .3098E-05 + .3368E-05 + .3721E-05 + .4071E-05 + .4469E-05 + .4911E-05 + .5421E-05 + .5982E-05 + .6544E-05 + .7047E-05 + .7523E-05 + .7884E-05 + .8074E-05 + .8156E-05 + .8126E-05 + .8087E-05 + .7985E-05 + .7888E-05 + .7763E-05 + .7570E-05 + .7324E-05 + .6975E-05 + .6641E-05 + .6213E-05 + .5748E-05 + .5297E-05 + .4852E-05 + .4363E-05 + .3815E-05 + .3172E-05 + .2490E-05 + .1892E-05 + .1391E-05 + .9731E-06 + .6808E-06 + .4763E-06 + .3590E-06 + .2989E-06 + .2296E-06 + .1512E-06 + .9952E-07 + .7747E-07 + .6530E-07 + .5504E-07 + .4675E-07 + .4337E-07 + .4024E-07 + .3654E-07 + .3252E-07 + .2894E-07 + .2768E-07 + .1608E-05 + .1760E-05 + .1913E-05 + .2069E-05 + .2234E-05 + .2417E-05 + .2624E-05 + .2861E-05 + .3116E-05 + .3391E-05 + .3750E-05 + .4107E-05 + .4523E-05 + .4970E-05 + .5506E-05 + .6084E-05 + .6661E-05 + .7187E-05 + .7670E-05 + .8033E-05 + .8221E-05 + .8282E-05 + .8245E-05 + .8196E-05 + .8099E-05 + .7984E-05 + .7844E-05 + .7638E-05 + .7403E-05 + .7079E-05 + .6730E-05 + .6253E-05 + .5786E-05 + .5318E-05 + .4839E-05 + .4316E-05 + .3730E-05 + .3048E-05 + .2352E-05 + .1760E-05 + .1268E-05 + .8901E-06 + .6248E-06 + .4386E-06 + .3318E-06 + .2818E-06 + .2205E-06 + .1475E-06 + .9874E-07 + .7750E-07 + .6562E-07 + .5556E-07 + .4739E-07 + .4403E-07 + .4090E-07 + .3718E-07 + .3314E-07 + .2943E-07 + .2808E-07 + .1670E-05 + .1814E-05 + .1958E-05 + .2111E-05 + .2276E-05 + .2465E-05 + .2676E-05 + .2916E-05 + .3163E-05 + .3460E-05 + .3833E-05 + .4213E-05 + .4664E-05 + .5137E-05 + .5710E-05 + .6298E-05 + .6882E-05 + .7432E-05 + .7900E-05 + .8252E-05 + .8437E-05 + .8473E-05 + .8434E-05 + .8383E-05 + .8301E-05 + .8154E-05 + .7992E-05 + .7767E-05 + .7550E-05 + .7256E-05 + .6878E-05 + .6334E-05 + .5860E-05 + .5374E-05 + .4857E-05 + .4301E-05 + .3675E-05 + .2953E-05 + .2247E-05 + .1658E-05 + .1167E-05 + .7909E-06 + .5363E-06 + .3636E-06 + .2740E-06 + .2348E-06 + .1871E-06 + .1297E-06 + .8987E-07 + .7242E-07 + .6268E-07 + .5425E-07 + .4722E-07 + .4384E-07 + .4070E-07 + .3691E-07 + .3284E-07 + .2874E-07 + .2709E-07 + .1677E-05 + .1823E-05 + .1972E-05 + .2129E-05 + .2297E-05 + .2485E-05 + .2695E-05 + .2932E-05 + .3186E-05 + .3475E-05 + .3798E-05 + .4174E-05 + .4593E-05 + .5057E-05 + .5624E-05 + .6226E-05 + .6829E-05 + .7430E-05 + .7961E-05 + .8363E-05 + .8572E-05 + .8630E-05 + .8610E-05 + .8568E-05 + .8472E-05 + .8330E-05 + .8192E-05 + .7958E-05 + .7712E-05 + .7370E-05 + .7012E-05 + .6470E-05 + .5940E-05 + .5397E-05 + .4836E-05 + .4259E-05 + .3585E-05 + .2842E-05 + .2131E-05 + .1514E-05 + .1032E-05 + .6835E-06 + .4526E-06 + .2997E-06 + .2249E-06 + .1946E-06 + .1579E-06 + .1133E-06 + .8133E-07 + .6727E-07 + .5953E-07 + .5267E-07 + .4678E-07 + .4340E-07 + .4026E-07 + .3643E-07 + .3235E-07 + .2790E-07 + .2599E-07 + .1669E-05 + .1816E-05 + .1970E-05 + .2129E-05 + .2298E-05 + .2484E-05 + .2691E-05 + .2921E-05 + .3177E-05 + .3456E-05 + .3734E-05 + .4098E-05 + .4481E-05 + .4934E-05 + .5486E-05 + .6096E-05 + .6723E-05 + .7368E-05 + .7957E-05 + .8408E-05 + .8649E-05 + .8735E-05 + .8737E-05 + .8708E-05 + .8599E-05 + .8463E-05 + .8348E-05 + .8113E-05 + .7838E-05 + .7437E-05 + .7096E-05 + .6559E-05 + .5981E-05 + .5386E-05 + .4785E-05 + .4189E-05 + .3472E-05 + .2712E-05 + .1999E-05 + .1364E-05 + .8968E-06 + .5820E-06 + .3777E-06 + .2451E-06 + .1832E-06 + .1600E-06 + .1322E-06 + .9826E-07 + .7303E-07 + .6202E-07 + .5610E-07 + .5074E-07 + .4599E-07 + .4264E-07 + .3953E-07 + .3568E-07 + .3163E-07 + .2688E-07 + .2474E-07 + .1654E-05 + .1803E-05 + .1960E-05 + .2114E-05 + .2280E-05 + .2460E-05 + .2657E-05 + .2878E-05 + .3107E-05 + .3391E-05 + .3676E-05 + .4006E-05 + .4376E-05 + .4834E-05 + .5364E-05 + .5970E-05 + .6665E-05 + .7335E-05 + .7936E-05 + .8419E-05 + .8731E-05 + .8867E-05 + .8900E-05 + .8887E-05 + .8784E-05 + .8637E-05 + .8507E-05 + .8318E-05 + .8030E-05 + .7520E-05 + .7149E-05 + .6583E-05 + .6001E-05 + .5384E-05 + .4759E-05 + .4123E-05 + .3356E-05 + .2561E-05 + .1832E-05 + .1197E-05 + .7383E-06 + .4773E-06 + .3086E-06 + .1995E-06 + .1485E-06 + .1309E-06 + .1101E-06 + .8477E-07 + .6525E-07 + .5688E-07 + .5260E-07 + .4864E-07 + .4499E-07 + .4168E-07 + .3861E-07 + .3477E-07 + .3077E-07 + .2577E-07 + .2343E-07 + .1645E-05 + .1795E-05 + .1952E-05 + .2099E-05 + .2259E-05 + .2431E-05 + .2619E-05 + .2832E-05 + .3041E-05 + .3328E-05 + .3619E-05 + .3942E-05 + .4299E-05 + .4738E-05 + .5267E-05 + .5861E-05 + .6573E-05 + .7247E-05 + .7866E-05 + .8383E-05 + .8759E-05 + .8948E-05 + .9033E-05 + .9041E-05 + .8972E-05 + .8843E-05 + .8686E-05 + .8529E-05 + .8213E-05 + .7658E-05 + .7228E-05 + .6625E-05 + .6019E-05 + .5353E-05 + .4681E-05 + .3997E-05 + .3201E-05 + .2397E-05 + .1687E-05 + .1075E-05 + .6332E-06 + .4018E-06 + .2550E-06 + .1618E-06 + .1199E-06 + .1067E-06 + .9144E-07 + .7290E-07 + .5811E-07 + .5200E-07 + .4916E-07 + .4647E-07 + .4386E-07 + .4060E-07 + .3759E-07 + .3378E-07 + .2983E-07 + .2462E-07 + .2212E-07 + .1649E-05 + .1799E-05 + .1950E-05 + .2091E-05 + .2238E-05 + .2402E-05 + .2579E-05 + .2786E-05 + .2987E-05 + .3273E-05 + .3570E-05 + .3933E-05 + .4276E-05 + .4655E-05 + .5223E-05 + .5793E-05 + .6434E-05 + .7079E-05 + .7724E-05 + .8278E-05 + .8707E-05 + .8950E-05 + .9127E-05 + .9166E-05 + .9181E-05 + .9124E-05 + .8919E-05 + .8765E-05 + .8394E-05 + .7919E-05 + .7374E-05 + .6715E-05 + .6045E-05 + .5281E-05 + .4521E-05 + .3779E-05 + .2986E-05 + .2212E-05 + .1573E-05 + .1009E-05 + .5863E-06 + .3555E-06 + .2156E-06 + .1308E-06 + .9651E-07 + .8669E-07 + .7564E-07 + .6244E-07 + .5155E-07 + .4736E-07 + .4577E-07 + .4423E-07 + .4259E-07 + .3940E-07 + .3645E-07 + .3268E-07 + .2881E-07 + .2343E-07 + .2080E-07 + .1641E-05 + .1794E-05 + .1944E-05 + .2083E-05 + .2229E-05 + .2393E-05 + .2573E-05 + .2779E-05 + .2983E-05 + .3270E-05 + .3546E-05 + .3899E-05 + .4248E-05 + .4621E-05 + .5181E-05 + .5732E-05 + .6332E-05 + .6974E-05 + .7650E-05 + .8209E-05 + .8658E-05 + .8972E-05 + .9245E-05 + .9360E-05 + .9435E-05 + .9442E-05 + .9291E-05 + .9143E-05 + .8729E-05 + .8269E-05 + .7613E-05 + .6855E-05 + .6068E-05 + .5218E-05 + .4385E-05 + .3585E-05 + .2797E-05 + .2055E-05 + .1427E-05 + .8970E-06 + .5075E-06 + .3013E-06 + .1789E-06 + .1062E-06 + .7807E-07 + .7078E-07 + .6289E-07 + .5377E-07 + .4597E-07 + .4335E-07 + .4283E-07 + .4231E-07 + .4158E-07 + .3844E-07 + .3554E-07 + .3179E-07 + .2797E-07 + .2242E-07 + .1966E-07 + .1621E-05 + .1778E-05 + .1929E-05 + .2072E-05 + .2225E-05 + .2396E-05 + .2587E-05 + .2795E-05 + .3011E-05 + .3298E-05 + .3533E-05 + .3838E-05 + .4206E-05 + .4615E-05 + .5127E-05 + .5664E-05 + .6244E-05 + .6900E-05 + .7607E-05 + .8148E-05 + .8592E-05 + .8989E-05 + .9362E-05 + .9590E-05 + .9706E-05 + .9769E-05 + .9763E-05 + .9624E-05 + .9178E-05 + .8681E-05 + .7915E-05 + .7021E-05 + .6075E-05 + .5151E-05 + .4256E-05 + .3401E-05 + .2621E-05 + .1914E-05 + .1264E-05 + .7629E-06 + .4159E-06 + .2463E-06 + .1459E-06 + .8641E-07 + .6325E-07 + .5789E-07 + .5238E-07 + .4638E-07 + .4106E-07 + .3975E-07 + .4015E-07 + .4055E-07 + .4066E-07 + .3756E-07 + .3470E-07 + .3097E-07 + .2720E-07 + .2149E-07 + .1861E-07 + .1613E-05 + .1769E-05 + .1919E-05 + .2062E-05 + .2216E-05 + .2384E-05 + .2575E-05 + .2777E-05 + .3010E-05 + .3278E-05 + .3525E-05 + .3827E-05 + .4196E-05 + .4619E-05 + .5109E-05 + .5661E-05 + .6265E-05 + .6886E-05 + .7563E-05 + .8090E-05 + .8526E-05 + .8944E-05 + .9334E-05 + .9640E-05 + .9875E-05 + .9995E-05 + .1004E-04 + .9962E-05 + .9535E-05 + .8992E-05 + .8133E-05 + .7109E-05 + .6060E-05 + .5045E-05 + .4096E-05 + .3229E-05 + .2461E-05 + .1782E-05 + .1171E-05 + .6985E-06 + .3748E-06 + .2148E-06 + .1231E-06 + .7057E-07 + .5144E-07 + .4752E-07 + .4379E-07 + .4015E-07 + .3682E-07 + .3659E-07 + .3778E-07 + .3900E-07 + .3991E-07 + .3684E-07 + .3401E-07 + .3028E-07 + .2655E-07 + .2067E-07 + .1769E-07 + .1606E-05 + .1759E-05 + .1908E-05 + .2049E-05 + .2202E-05 + .2364E-05 + .2550E-05 + .2744E-05 + .2996E-05 + .3237E-05 + .3512E-05 + .3825E-05 + .4188E-05 + .4617E-05 + .5093E-05 + .5669E-05 + .6308E-05 + .6879E-05 + .7507E-05 + .8021E-05 + .8446E-05 + .8864E-05 + .9247E-05 + .9618E-05 + .9997E-05 + .1017E-04 + .1024E-04 + .1024E-04 + .9853E-05 + .9260E-05 + .8314E-05 + .7161E-05 + .6028E-05 + .4920E-05 + .3925E-05 + .3061E-05 + .2309E-05 + .1656E-05 + .1098E-05 + .6526E-06 + .3468E-06 + .2009E-06 + .1164E-06 + .6748E-07 + .4998E-07 + .4586E-07 + .4228E-07 + .3933E-07 + .3659E-07 + .3639E-07 + .3737E-07 + .3837E-07 + .3908E-07 + .3618E-07 + .3349E-07 + .2993E-07 + .2588E-07 + .1987E-07 + .1707E-07 + .1600E-05 + .1751E-05 + .1906E-05 + .2056E-05 + .2220E-05 + .2395E-05 + .2587E-05 + .2802E-05 + .3022E-05 + .3281E-05 + .3540E-05 + .3879E-05 + .4220E-05 + .4611E-05 + .5066E-05 + .5658E-05 + .6316E-05 + .6885E-05 + .7526E-05 + .8040E-05 + .8473E-05 + .8845E-05 + .9216E-05 + .9638E-05 + .9993E-05 + .1021E-04 + .1030E-04 + .1035E-04 + .9925E-05 + .9334E-05 + .8440E-05 + .7268E-05 + .6062E-05 + .4897E-05 + .3857E-05 + .2979E-05 + .2219E-05 + .1579E-05 + .1040E-05 + .6118E-06 + .3148E-06 + .1871E-06 + .1112E-06 + .6607E-07 + .4986E-07 + .4533E-07 + .4171E-07 + .3925E-07 + .3694E-07 + .3665E-07 + .3728E-07 + .3792E-07 + .3830E-07 + .3557E-07 + .3304E-07 + .2965E-07 + .2525E-07 + .1912E-07 + .1653E-07 + .1597E-05 + .1746E-05 + .1908E-05 + .2066E-05 + .2238E-05 + .2424E-05 + .2625E-05 + .2859E-05 + .3062E-05 + .3332E-05 + .3581E-05 + .3941E-05 + .4267E-05 + .4636E-05 + .5072E-05 + .5672E-05 + .6337E-05 + .6905E-05 + .7555E-05 + .8077E-05 + .8537E-05 + .8881E-05 + .9243E-05 + .9685E-05 + .1001E-04 + .1029E-04 + .1042E-04 + .1049E-04 + .1004E-04 + .9438E-05 + .8587E-05 + .7393E-05 + .6110E-05 + .4899E-05 + .3823E-05 + .2925E-05 + .2161E-05 + .1531E-05 + .1002E-05 + .5837E-06 + .2920E-06 + .1770E-06 + .1072E-06 + .6497E-07 + .4995E-07 + .4501E-07 + .4133E-07 + .3934E-07 + .3746E-07 + .3706E-07 + .3734E-07 + .3763E-07 + .3769E-07 + .3512E-07 + .3273E-07 + .2951E-07 + .2474E-07 + .1848E-07 + .1607E-07 + .1573E-05 + .1722E-05 + .1880E-05 + .2037E-05 + .2210E-05 + .2397E-05 + .2607E-05 + .2835E-05 + .3095E-05 + .3335E-05 + .3602E-05 + .3944E-05 + .4292E-05 + .4702E-05 + .5122E-05 + .5673E-05 + .6294E-05 + .6842E-05 + .7471E-05 + .8016E-05 + .8578E-05 + .8976E-05 + .9327E-05 + .9651E-05 + .9919E-05 + .1036E-04 + .1058E-04 + .1061E-04 + .1016E-04 + .9497E-05 + .8645E-05 + .7434E-05 + .6087E-05 + .4901E-05 + .3846E-05 + .2922E-05 + .2174E-05 + .1560E-05 + .1011E-05 + .5886E-06 + .2924E-06 + .1760E-06 + .1059E-06 + .6373E-07 + .4992E-07 + .4457E-07 + .4085E-07 + .3934E-07 + .3789E-07 + .3739E-07 + .3732E-07 + .3725E-07 + .3700E-07 + .3459E-07 + .3235E-07 + .2929E-07 + .2419E-07 + .1782E-07 + .1559E-07 + .1550E-05 + .1699E-05 + .1854E-05 + .2009E-05 + .2182E-05 + .2372E-05 + .2587E-05 + .2816E-05 + .3096E-05 + .3335E-05 + .3614E-05 + .3945E-05 + .4291E-05 + .4709E-05 + .5154E-05 + .5670E-05 + .6234E-05 + .6773E-05 + .7403E-05 + .7976E-05 + .8590E-05 + .9020E-05 + .9377E-05 + .9657E-05 + .9923E-05 + .1046E-04 + .1072E-04 + .1071E-04 + .1024E-04 + .9548E-05 + .8689E-05 + .7470E-05 + .6091E-05 + .4902E-05 + .3866E-05 + .2944E-05 + .2202E-05 + .1586E-05 + .1022E-05 + .5955E-06 + .2946E-06 + .1756E-06 + .1047E-06 + .6243E-07 + .4983E-07 + .4408E-07 + .4032E-07 + .3928E-07 + .3827E-07 + .3766E-07 + .3724E-07 + .3683E-07 + .3627E-07 + .3403E-07 + .3192E-07 + .2903E-07 + .2361E-07 + .1715E-07 + .1510E-07 + .1524E-05 + .1673E-05 + .1824E-05 + .1978E-05 + .2148E-05 + .2344E-05 + .2555E-05 + .2795E-05 + .3042E-05 + .3320E-05 + .3601E-05 + .3935E-05 + .4239E-05 + .4614E-05 + .5147E-05 + .5645E-05 + .6133E-05 + .6677E-05 + .7339E-05 + .7944E-05 + .8535E-05 + .8961E-05 + .9349E-05 + .9698E-05 + .1004E-04 + .1057E-04 + .1081E-04 + .1074E-04 + .1024E-04 + .9561E-05 + .8688E-05 + .7478E-05 + .6119E-05 + .4889E-05 + .3871E-05 + .3000E-05 + .2247E-05 + .1603E-05 + .1034E-05 + .6041E-06 + .2990E-06 + .1778E-06 + .1057E-06 + .6287E-07 + .4988E-07 + .4345E-07 + .3946E-07 + .3879E-07 + .3813E-07 + .3760E-07 + .3714E-07 + .3668E-07 + .3609E-07 + .3396E-07 + .3196E-07 + .2893E-07 + .2324E-07 + .1692E-07 + .1497E-07 + .1526E-05 + .1673E-05 + .1823E-05 + .1975E-05 + .2143E-05 + .2336E-05 + .2543E-05 + .2784E-05 + .3018E-05 + .3310E-05 + .3596E-05 + .3915E-05 + .4223E-05 + .4598E-05 + .5130E-05 + .5616E-05 + .6100E-05 + .6682E-05 + .7338E-05 + .7933E-05 + .8484E-05 + .8939E-05 + .9374E-05 + .9782E-05 + .1017E-04 + .1061E-04 + .1081E-04 + .1072E-04 + .1023E-04 + .9558E-05 + .8672E-05 + .7494E-05 + .6176E-05 + .4958E-05 + .3921E-05 + .3039E-05 + .2273E-05 + .1604E-05 + .1034E-05 + .6010E-06 + .2938E-06 + .1782E-06 + .1080E-06 + .6552E-07 + .5043E-07 + .4297E-07 + .3854E-07 + .3813E-07 + .3772E-07 + .3745E-07 + .3725E-07 + .3704E-07 + .3668E-07 + .3462E-07 + .3267E-07 + .2917E-07 + .2324E-07 + .1721E-07 + .1530E-07 + .1552E-05 + .1695E-05 + .1846E-05 + .1996E-05 + .2162E-05 + .2349E-05 + .2552E-05 + .2787E-05 + .3020E-05 + .3314E-05 + .3605E-05 + .3899E-05 + .4241E-05 + .4646E-05 + .5120E-05 + .5601E-05 + .6128E-05 + .6773E-05 + .7400E-05 + .7956E-05 + .8460E-05 + .8966E-05 + .9459E-05 + .9922E-05 + .1032E-04 + .1063E-04 + .1078E-04 + .1069E-04 + .1024E-04 + .9571E-05 + .8668E-05 + .7536E-05 + .6270E-05 + .5097E-05 + .4013E-05 + .3075E-05 + .2294E-05 + .1599E-05 + .1029E-05 + .5919E-06 + .2835E-06 + .1766E-06 + .1100E-06 + .6855E-07 + .5119E-07 + .4266E-07 + .3780E-07 + .3763E-07 + .3747E-07 + .3745E-07 + .3751E-07 + .3756E-07 + .3744E-07 + .3543E-07 + .3352E-07 + .2953E-07 + .2332E-07 + .1757E-07 + .1570E-07 + .1569E-05 + .1712E-05 + .1865E-05 + .2016E-05 + .2182E-05 + .2368E-05 + .2567E-05 + .2809E-05 + .3022E-05 + .3352E-05 + .3597E-05 + .3897E-05 + .4262E-05 + .4700E-05 + .5168E-05 + .5674E-05 + .6235E-05 + .6855E-05 + .7459E-05 + .8046E-05 + .8568E-05 + .9094E-05 + .9545E-05 + .1006E-04 + .1042E-04 + .1069E-04 + .1072E-04 + .1059E-04 + .1017E-04 + .9535E-05 + .8669E-05 + .7562E-05 + .6361E-05 + .5194E-05 + .4105E-05 + .3128E-05 + .2312E-05 + .1604E-05 + .1030E-05 + .5779E-06 + .2747E-06 + .1756E-06 + .1123E-06 + .7183E-07 + .5203E-07 + .4241E-07 + .3712E-07 + .3720E-07 + .3727E-07 + .3751E-07 + .3782E-07 + .3813E-07 + .3826E-07 + .3631E-07 + .3445E-07 + .2994E-07 + .2344E-07 + .1796E-07 + .1614E-07 + .1583E-05 + .1725E-05 + .1880E-05 + .2032E-05 + .2199E-05 + .2385E-05 + .2580E-05 + .2831E-05 + .3018E-05 + .3391E-05 + .3579E-05 + .3893E-05 + .4278E-05 + .4747E-05 + .5221E-05 + .5759E-05 + .6351E-05 + .6925E-05 + .7507E-05 + .8141E-05 + .8696E-05 + .9231E-05 + .9615E-05 + .1019E-04 + .1049E-04 + .1073E-04 + .1064E-04 + .1045E-04 + .1008E-04 + .9471E-05 + .8656E-05 + .7570E-05 + .6440E-05 + .5272E-05 + .4190E-05 + .3181E-05 + .2326E-05 + .1609E-05 + .1030E-05 + .5631E-06 + .2667E-06 + .1749E-06 + .1146E-06 + .7517E-07 + .5281E-07 + .4211E-07 + .3641E-07 + .3672E-07 + .3703E-07 + .3752E-07 + .3809E-07 + .3867E-07 + .3906E-07 + .3716E-07 + .3536E-07 + .3032E-07 + .2353E-07 + .1834E-07 + .1656E-07 + .1582E-05 + .1732E-05 + .1888E-05 + .2037E-05 + .2199E-05 + .2377E-05 + .2570E-05 + .2803E-05 + .3013E-05 + .3331E-05 + .3583E-05 + .3888E-05 + .4296E-05 + .4755E-05 + .5231E-05 + .5795E-05 + .6402E-05 + .7004E-05 + .7605E-05 + .8242E-05 + .8833E-05 + .9266E-05 + .9678E-05 + .1011E-04 + .1036E-04 + .1055E-04 + .1049E-04 + .1033E-04 + .9904E-05 + .9331E-05 + .8560E-05 + .7549E-05 + .6428E-05 + .5259E-05 + .4179E-05 + .3185E-05 + .2332E-05 + .1627E-05 + .1052E-05 + .5963E-06 + .2973E-06 + .1908E-06 + .1225E-06 + .7863E-07 + .5359E-07 + .4180E-07 + .3569E-07 + .3623E-07 + .3677E-07 + .3750E-07 + .3834E-07 + .3920E-07 + .3985E-07 + .3802E-07 + .3627E-07 + .3068E-07 + .2361E-07 + .1872E-07 + .1699E-07 + .1586E-05 + .1740E-05 + .1895E-05 + .2042E-05 + .2199E-05 + .2371E-05 + .2564E-05 + .2784E-05 + .3012E-05 + .3291E-05 + .3591E-05 + .3892E-05 + .4313E-05 + .4762E-05 + .5248E-05 + .5839E-05 + .6459E-05 + .7091E-05 + .7703E-05 + .8342E-05 + .8954E-05 + .9306E-05 + .9727E-05 + .1005E-04 + .1024E-04 + .1038E-04 + .1034E-04 + .1020E-04 + .9747E-05 + .9198E-05 + .8469E-05 + .7518E-05 + .6408E-05 + .5246E-05 + .4168E-05 + .3187E-05 + .2334E-05 + .1641E-05 + .1074E-05 + .6292E-06 + .3289E-06 + .2072E-06 + .1306E-06 + .8226E-07 + .5438E-07 + .4149E-07 + .3500E-07 + .3575E-07 + .3652E-07 + .3750E-07 + .3860E-07 + .3974E-07 + .4067E-07 + .3890E-07 + .3722E-07 + .3106E-07 + .2369E-07 + .1911E-07 + .1743E-07 + .1609E-05 + .1756E-05 + .1906E-05 + .2048E-05 + .2205E-05 + .2380E-05 + .2575E-05 + .2799E-05 + .3034E-05 + .3322E-05 + .3622E-05 + .3937E-05 + .4341E-05 + .4776E-05 + .5305E-05 + .5932E-05 + .6547E-05 + .7222E-05 + .7822E-05 + .8465E-05 + .9044E-05 + .9393E-05 + .9756E-05 + .1002E-04 + .1019E-04 + .1030E-04 + .1021E-04 + .1005E-04 + .9673E-05 + .9112E-05 + .8413E-05 + .7473E-05 + .6384E-05 + .5251E-05 + .4169E-05 + .3189E-05 + .2328E-05 + .1644E-05 + .1099E-05 + .6578E-06 + .3559E-06 + .2220E-06 + .1385E-06 + .8638E-07 + .5540E-07 + .4134E-07 + .3445E-07 + .3541E-07 + .3640E-07 + .3763E-07 + .3901E-07 + .4043E-07 + .4165E-07 + .3996E-07 + .3833E-07 + .3155E-07 + .2386E-07 + .1958E-07 + .1795E-07 + .1611E-05 + .1758E-05 + .1910E-05 + .2054E-05 + .2213E-05 + .2390E-05 + .2586E-05 + .2814E-05 + .3045E-05 + .3357E-05 + .3645E-05 + .3971E-05 + .4377E-05 + .4824E-05 + .5372E-05 + .6016E-05 + .6645E-05 + .7345E-05 + .7946E-05 + .8561E-05 + .9091E-05 + .9430E-05 + .9733E-05 + .9957E-05 + .1009E-04 + .1017E-04 + .1007E-04 + .9926E-05 + .9557E-05 + .9010E-05 + .8316E-05 + .7385E-05 + .6331E-05 + .5241E-05 + .4172E-05 + .3203E-05 + .2348E-05 + .1670E-05 + .1132E-05 + .6894E-06 + .3835E-06 + .2379E-06 + .1476E-06 + .9155E-07 + .5956E-07 + .4487E-07 + .3757E-07 + .3849E-07 + .3942E-07 + .4041E-07 + .4144E-07 + .4250E-07 + .4333E-07 + .4133E-07 + .3942E-07 + .3265E-07 + .2511E-07 + .2094E-07 + .1933E-07 + .1580E-05 + .1735E-05 + .1898E-05 + .2051E-05 + .2214E-05 + .2394E-05 + .2588E-05 + .2819E-05 + .3028E-05 + .3384E-05 + .3642E-05 + .3976E-05 + .4406E-05 + .4900E-05 + .5430E-05 + .6065E-05 + .6732E-05 + .7428E-05 + .8046E-05 + .8593E-05 + .9049E-05 + .9369E-05 + .9612E-05 + .9799E-05 + .9871E-05 + .9955E-05 + .9896E-05 + .9799E-05 + .9353E-05 + .8858E-05 + .8138E-05 + .7216E-05 + .6221E-05 + .5192E-05 + .4162E-05 + .3221E-05 + .2393E-05 + .1721E-05 + .1172E-05 + .7221E-06 + .4094E-06 + .2540E-06 + .1577E-06 + .9784E-07 + .6841E-07 + .5418E-07 + .4662E-07 + .4696E-07 + .4731E-07 + .4716E-07 + .4678E-07 + .4641E-07 + .4583E-07 + .4299E-07 + .4032E-07 + .3445E-07 + .2787E-07 + .2357E-07 + .2199E-07 + .1577E-05 + .1734E-05 + .1897E-05 + .2053E-05 + .2218E-05 + .2400E-05 + .2599E-05 + .2836E-05 + .3053E-05 + .3394E-05 + .3650E-05 + .4000E-05 + .4424E-05 + .4903E-05 + .5446E-05 + .6078E-05 + .6739E-05 + .7415E-05 + .8023E-05 + .8555E-05 + .8940E-05 + .9227E-05 + .9435E-05 + .9596E-05 + .9658E-05 + .9709E-05 + .9650E-05 + .9550E-05 + .9095E-05 + .8618E-05 + .7917E-05 + .7058E-05 + .6129E-05 + .5153E-05 + .4167E-05 + .3251E-05 + .2447E-05 + .1787E-05 + .1225E-05 + .7606E-06 + .4365E-06 + .2710E-06 + .1682E-06 + .1044E-06 + .7846E-07 + .6534E-07 + .5776E-07 + .5723E-07 + .5670E-07 + .5497E-07 + .5274E-07 + .5061E-07 + .4841E-07 + .4465E-07 + .4118E-07 + .3630E-07 + .3088E-07 + .2650E-07 + .2497E-07 + .1592E-05 + .1748E-05 + .1905E-05 + .2060E-05 + .2227E-05 + .2412E-05 + .2619E-05 + .2864E-05 + .3106E-05 + .3400E-05 + .3669E-05 + .4041E-05 + .4441E-05 + .4874E-05 + .5446E-05 + .6079E-05 + .6712E-05 + .7358E-05 + .7945E-05 + .8492E-05 + .8808E-05 + .9056E-05 + .9244E-05 + .9384E-05 + .9462E-05 + .9463E-05 + .9386E-05 + .9256E-05 + .8826E-05 + .8348E-05 + .7687E-05 + .6917E-05 + .6056E-05 + .5128E-05 + .4186E-05 + .3291E-05 + .2510E-05 + .1867E-05 + .1288E-05 + .8047E-06 + .4659E-06 + .3012E-06 + .1947E-06 + .1258E-06 + .9435E-07 + .7864E-07 + .6854E-07 + .6506E-07 + .6174E-07 + .5861E-07 + .5563E-07 + .5281E-07 + .5002E-07 + .4619E-07 + .4266E-07 + .3816E-07 + .3313E-07 + .2877E-07 + .2726E-07 + .1607E-05 + .1761E-05 + .1920E-05 + .2078E-05 + .2246E-05 + .2434E-05 + .2640E-05 + .2885E-05 + .3122E-05 + .3444E-05 + .3708E-05 + .4065E-05 + .4471E-05 + .4905E-05 + .5456E-05 + .6059E-05 + .6730E-05 + .7345E-05 + .7899E-05 + .8383E-05 + .8674E-05 + .8889E-05 + .9065E-05 + .9173E-05 + .9183E-05 + .9178E-05 + .9077E-05 + .8910E-05 + .8517E-05 + .8058E-05 + .7471E-05 + .6762E-05 + .5961E-05 + .5080E-05 + .4175E-05 + .3303E-05 + .2556E-05 + .1928E-05 + .1360E-05 + .8777E-06 + .5237E-06 + .3512E-06 + .2356E-06 + .1580E-06 + .1153E-06 + .9461E-07 + .8019E-07 + .7226E-07 + .6512E-07 + .6066E-07 + .5739E-07 + .5430E-07 + .5131E-07 + .4773E-07 + .4440E-07 + .4007E-07 + .3517E-07 + .3087E-07 + .2936E-07 + .1620E-05 + .1773E-05 + .1935E-05 + .2096E-05 + .2267E-05 + .2455E-05 + .2658E-05 + .2901E-05 + .3131E-05 + .3490E-05 + .3746E-05 + .4083E-05 + .4501E-05 + .4944E-05 + .5465E-05 + .6037E-05 + .6749E-05 + .7333E-05 + .7853E-05 + .8263E-05 + .8538E-05 + .8721E-05 + .8884E-05 + .8959E-05 + .8898E-05 + .8890E-05 + .8766E-05 + .8565E-05 + .8208E-05 + .7770E-05 + .7258E-05 + .6604E-05 + .5858E-05 + .5024E-05 + .4154E-05 + .3310E-05 + .2599E-05 + .1988E-05 + .1438E-05 + .9624E-06 + .5952E-06 + .4126E-06 + .2860E-06 + .1983E-06 + .1408E-06 + .1138E-06 + .9378E-07 + .8024E-07 + .6866E-07 + .6276E-07 + .5919E-07 + .5582E-07 + .5262E-07 + .4931E-07 + .4620E-07 + .4207E-07 + .3732E-07 + .3311E-07 + .3163E-07 + .1614E-05 + .1773E-05 + .1938E-05 + .2101E-05 + .2272E-05 + .2457E-05 + .2658E-05 + .2889E-05 + .3132E-05 + .3451E-05 + .3728E-05 + .4069E-05 + .4486E-05 + .4945E-05 + .5467E-05 + .6038E-05 + .6681E-05 + .7257E-05 + .7746E-05 + .8104E-05 + .8366E-05 + .8515E-05 + .8625E-05 + .8676E-05 + .8635E-05 + .8565E-05 + .8423E-05 + .8228E-05 + .7883E-05 + .7477E-05 + .6998E-05 + .6415E-05 + .5706E-05 + .4907E-05 + .4079E-05 + .3317E-05 + .2645E-05 + .2059E-05 + .1529E-05 + .1059E-05 + .6999E-06 + .4954E-06 + .3506E-06 + .2481E-06 + .1715E-06 + .1365E-06 + .1094E-06 + .8886E-07 + .7219E-07 + .6475E-07 + .6088E-07 + .5723E-07 + .5382E-07 + .5079E-07 + .4794E-07 + .4405E-07 + .3950E-07 + .3541E-07 + .3397E-07 + .1631E-05 + .1794E-05 + .1962E-05 + .2126E-05 + .2296E-05 + .2478E-05 + .2680E-05 + .2904E-05 + .3157E-05 + .3449E-05 + .3747E-05 + .4101E-05 + .4509E-05 + .4986E-05 + .5509E-05 + .6081E-05 + .6686E-05 + .7248E-05 + .7720E-05 + .8042E-05 + .8284E-05 + .8405E-05 + .8471E-05 + .8500E-05 + .8461E-05 + .8344E-05 + .8183E-05 + .7982E-05 + .7648E-05 + .7263E-05 + .6808E-05 + .6273E-05 + .5598E-05 + .4820E-05 + .4027E-05 + .3340E-05 + .2711E-05 + .2150E-05 + .1638E-05 + .1172E-05 + .8180E-06 + .5797E-06 + .4109E-06 + .2912E-06 + .2007E-06 + .1566E-06 + .1223E-06 + .9559E-07 + .7473E-07 + .6582E-07 + .6135E-07 + .5719E-07 + .5337E-07 + .5052E-07 + .4781E-07 + .4357E-07 + .3834E-07 + .3373E-07 + .3212E-07 + .1682E-05 + .1838E-05 + .2001E-05 + .2161E-05 + .2326E-05 + .2506E-05 + .2709E-05 + .2941E-05 + .3188E-05 + .3482E-05 + .3796E-05 + .4180E-05 + .4552E-05 + .5037E-05 + .5553E-05 + .6121E-05 + .6754E-05 + .7279E-05 + .7764E-05 + .8082E-05 + .8275E-05 + .8382E-05 + .8419E-05 + .8427E-05 + .8344E-05 + .8218E-05 + .8033E-05 + .7797E-05 + .7478E-05 + .7097E-05 + .6656E-05 + .6128E-05 + .5491E-05 + .4713E-05 + .3955E-05 + .3339E-05 + .2783E-05 + .2251E-05 + .1754E-05 + .1291E-05 + .9216E-06 + .6574E-06 + .4689E-06 + .3345E-06 + .2320E-06 + .1772E-06 + .1349E-06 + .1020E-06 + .7715E-07 + .6675E-07 + .6156E-07 + .5677E-07 + .5247E-07 + .4972E-07 + .4711E-07 + .4229E-07 + .3609E-07 + .3080E-07 + .2899E-07 + .1697E-05 + .1856E-05 + .2021E-05 + .2182E-05 + .2347E-05 + .2528E-05 + .2729E-05 + .2965E-05 + .3195E-05 + .3500E-05 + .3808E-05 + .4197E-05 + .4558E-05 + .5054E-05 + .5570E-05 + .6139E-05 + .6768E-05 + .7277E-05 + .7742E-05 + .8052E-05 + .8200E-05 + .8299E-05 + .8310E-05 + .8282E-05 + .8172E-05 + .8036E-05 + .7827E-05 + .7570E-05 + .7249E-05 + .6862E-05 + .6433E-05 + .5931E-05 + .5332E-05 + .4590E-05 + .3892E-05 + .3334E-05 + .2838E-05 + .2340E-05 + .1867E-05 + .1413E-05 + .1029E-05 + .7401E-06 + .5321E-06 + .3825E-06 + .2672E-06 + .1998E-06 + .1482E-06 + .1084E-06 + .7933E-07 + .6741E-07 + .6151E-07 + .5612E-07 + .5137E-07 + .4874E-07 + .4624E-07 + .4087E-07 + .3383E-07 + .2801E-07 + .2606E-07 + .1673E-05 + .1845E-05 + .2018E-05 + .2191E-05 + .2360E-05 + .2545E-05 + .2739E-05 + .2978E-05 + .3177E-05 + .3503E-05 + .3783E-05 + .4146E-05 + .4526E-05 + .5037E-05 + .5564E-05 + .6136E-05 + .6726E-05 + .7245E-05 + .7655E-05 + .7950E-05 + .8059E-05 + .8160E-05 + .8146E-05 + .8066E-05 + .7950E-05 + .7801E-05 + .7568E-05 + .7308E-05 + .6965E-05 + .6563E-05 + .6144E-05 + .5687E-05 + .5123E-05 + .4453E-05 + .3840E-05 + .3328E-05 + .2877E-05 + .2414E-05 + .1974E-05 + .1535E-05 + .1140E-05 + .8274E-06 + .6005E-06 + .4359E-06 + .3065E-06 + .2243E-06 + .1623E-06 + .1148E-06 + .8126E-07 + .6782E-07 + .6123E-07 + .5527E-07 + .5010E-07 + .4759E-07 + .4521E-07 + .3935E-07 + .3160E-07 + .2538E-07 + .2334E-07 + .1655E-05 + .1827E-05 + .2000E-05 + .2171E-05 + .2338E-05 + .2521E-05 + .2713E-05 + .2944E-05 + .3142E-05 + .3443E-05 + .3731E-05 + .4086E-05 + .4476E-05 + .4977E-05 + .5516E-05 + .6095E-05 + .6658E-05 + .7156E-05 + .7520E-05 + .7805E-05 + .7901E-05 + .7963E-05 + .7930E-05 + .7819E-05 + .7678E-05 + .7493E-05 + .7266E-05 + .6982E-05 + .6648E-05 + .6259E-05 + .5868E-05 + .5438E-05 + .4916E-05 + .4308E-05 + .3754E-05 + .3272E-05 + .2865E-05 + .2454E-05 + .2046E-05 + .1623E-05 + .1227E-05 + .8966E-06 + .6553E-06 + .4789E-06 + .3433E-06 + .2557E-06 + .1851E-06 + .1268E-06 + .8691E-07 + .7103E-07 + .6312E-07 + .5609E-07 + .5007E-07 + .4716E-07 + .4442E-07 + .3841E-07 + .3070E-07 + .2453E-07 + .2252E-07 + .1632E-05 + .1800E-05 + .1968E-05 + .2130E-05 + .2292E-05 + .2470E-05 + .2660E-05 + .2879E-05 + .3087E-05 + .3344E-05 + .3653E-05 + .4006E-05 + .4402E-05 + .4882E-05 + .5430E-05 + .6015E-05 + .6556E-05 + .7018E-05 + .7340E-05 + .7616E-05 + .7709E-05 + .7716E-05 + .7666E-05 + .7535E-05 + .7365E-05 + .7138E-05 + .6928E-05 + .6616E-05 + .6303E-05 + .5939E-05 + .5584E-05 + .5175E-05 + .4699E-05 + .4147E-05 + .3643E-05 + .3184E-05 + .2819E-05 + .2469E-05 + .2094E-05 + .1690E-05 + .1299E-05 + .9544E-06 + .7015E-06 + .5155E-06 + .3788E-06 + .2925E-06 + .2144E-06 + .1423E-06 + .9447E-07 + .7549E-07 + .6587E-07 + .5748E-07 + .5042E-07 + .4688E-07 + .4359E-07 + .3759E-07 + .3024E-07 + .2433E-07 + .2239E-07 + .1604E-05 + .1757E-05 + .1912E-05 + .2068E-05 + .2223E-05 + .2391E-05 + .2571E-05 + .2782E-05 + .2981E-05 + .3262E-05 + .3553E-05 + .3893E-05 + .4296E-05 + .4768E-05 + .5305E-05 + .5858E-05 + .6377E-05 + .6807E-05 + .7113E-05 + .7340E-05 + .7405E-05 + .7394E-05 + .7318E-05 + .7173E-05 + .7011E-05 + .6778E-05 + .6547E-05 + .6249E-05 + .5963E-05 + .5603E-05 + .5284E-05 + .4907E-05 + .4463E-05 + .3959E-05 + .3502E-05 + .3123E-05 + .2775E-05 + .2466E-05 + .2116E-05 + .1720E-05 + .1326E-05 + .9896E-06 + .7387E-06 + .5515E-06 + .4154E-06 + .3323E-06 + .2466E-06 + .1586E-06 + .1020E-06 + .7971E-07 + .6831E-07 + .5854E-07 + .5044E-07 + .4630E-07 + .4250E-07 + .3656E-07 + .2961E-07 + .2398E-07 + .2213E-07 + .1578E-05 + .1718E-05 + .1861E-05 + .2010E-05 + .2161E-05 + .2321E-05 + .2492E-05 + .2697E-05 + .2889E-05 + .3193E-05 + .3467E-05 + .3795E-05 + .4204E-05 + .4671E-05 + .5196E-05 + .5716E-05 + .6214E-05 + .6612E-05 + .6906E-05 + .7084E-05 + .7120E-05 + .7092E-05 + .6993E-05 + .6838E-05 + .6684E-05 + .6450E-05 + .6199E-05 + .5917E-05 + .5653E-05 + .5296E-05 + .5003E-05 + .4654E-05 + .4240E-05 + .3786E-05 + .3380E-05 + .3079E-05 + .2742E-05 + .2468E-05 + .2140E-05 + .1752E-05 + .1353E-05 + .1017E-05 + .7649E-06 + .5751E-06 + .4298E-06 + .3428E-06 + .2542E-06 + .1640E-06 + .1058E-06 + .8214E-07 + .6962E-07 + .5900E-07 + .5032E-07 + .4618E-07 + .4239E-07 + .3662E-07 + .2992E-07 + .2445E-07 + .2263E-07 + .1525E-05 + .1663E-05 + .1804E-05 + .1951E-05 + .2103E-05 + .2266E-05 + .2442E-05 + .2644E-05 + .2854E-05 + .3130E-05 + .3410E-05 + .3728E-05 + .4134E-05 + .4578E-05 + .5097E-05 + .5580E-05 + .6046E-05 + .6408E-05 + .6668E-05 + .6808E-05 + .6816E-05 + .6752E-05 + .6645E-05 + .6488E-05 + .6317E-05 + .6090E-05 + .5857E-05 + .5581E-05 + .5312E-05 + .4974E-05 + .4655E-05 + .4302E-05 + .3953E-05 + .3607E-05 + .3304E-05 + .3054E-05 + .2730E-05 + .2463E-05 + .2149E-05 + .1776E-05 + .1388E-05 + .1050E-05 + .7940E-06 + .6005E-06 + .4453E-06 + .3541E-06 + .2623E-06 + .1698E-06 + .1099E-06 + .8475E-07 + .7103E-07 + .5954E-07 + .5026E-07 + .4613E-07 + .4233E-07 + .3674E-07 + .3028E-07 + .2495E-07 + .2317E-07 + .1478E-05 + .1612E-05 + .1747E-05 + .1892E-05 + .2046E-05 + .2210E-05 + .2391E-05 + .2592E-05 + .2812E-05 + .3070E-05 + .3349E-05 + .3658E-05 + .4059E-05 + .4482E-05 + .4985E-05 + .5435E-05 + .5865E-05 + .6185E-05 + .6410E-05 + .6513E-05 + .6499E-05 + .6409E-05 + .6288E-05 + .6124E-05 + .5939E-05 + .5713E-05 + .5489E-05 + .5218E-05 + .4948E-05 + .4628E-05 + .4307E-05 + .3966E-05 + .3674E-05 + .3423E-05 + .3213E-05 + .3005E-05 + .2696E-05 + .2453E-05 + .2156E-05 + .1798E-05 + .1424E-05 + .1083E-05 + .8232E-06 + .6259E-06 + .4604E-06 + .3649E-06 + .2701E-06 + .1754E-06 + .1139E-06 + .8727E-07 + .7234E-07 + .5996E-07 + .5011E-07 + .4598E-07 + .4219E-07 + .3678E-07 + .3057E-07 + .2542E-07 + .2368E-07 + .1448E-05 + .1571E-05 + .1700E-05 + .1841E-05 + .1994E-05 + .2161E-05 + .2344E-05 + .2548E-05 + .2767E-05 + .3027E-05 + .3295E-05 + .3594E-05 + .3990E-05 + .4393E-05 + .4864E-05 + .5286E-05 + .5673E-05 + .5940E-05 + .6130E-05 + .6194E-05 + .6165E-05 + .6066E-05 + .5919E-05 + .5737E-05 + .5541E-05 + .5301E-05 + .5072E-05 + .4805E-05 + .4537E-05 + .4234E-05 + .3953E-05 + .3650E-05 + .3407E-05 + .3236E-05 + .3102E-05 + .2918E-05 + .2630E-05 + .2441E-05 + .2167E-05 + .1826E-05 + .1470E-05 + .1121E-05 + .8550E-06 + .6521E-06 + .4759E-06 + .3760E-06 + .2780E-06 + .1811E-06 + .1180E-06 + .8984E-07 + .7365E-07 + .6037E-07 + .4994E-07 + .4582E-07 + .4204E-07 + .3681E-07 + .3087E-07 + .2588E-07 + .2420E-07 + .1416E-05 + .1529E-05 + .1650E-05 + .1788E-05 + .1939E-05 + .2109E-05 + .2293E-05 + .2500E-05 + .2717E-05 + .2978E-05 + .3233E-05 + .3522E-05 + .3912E-05 + .4297E-05 + .4735E-05 + .5131E-05 + .5478E-05 + .5694E-05 + .5851E-05 + .5880E-05 + .5837E-05 + .5730E-05 + .5558E-05 + .5361E-05 + .5156E-05 + .4904E-05 + .4671E-05 + .4409E-05 + .4145E-05 + .3857E-05 + .3614E-05 + .3346E-05 + .3149E-05 + .3053E-05 + .2989E-05 + .2828E-05 + .2561E-05 + .2422E-05 + .2171E-05 + .1846E-05 + .1508E-05 + .1155E-05 + .8846E-06 + .6776E-06 + .4907E-06 + .3865E-06 + .2855E-06 + .1866E-06 + .1220E-06 + .9224E-07 + .7478E-07 + .6063E-07 + .4964E-07 + .4554E-07 + .4178E-07 + .3675E-07 + .3108E-07 + .2629E-07 + .2466E-07 + .1382E-05 + .1485E-05 + .1599E-05 + .1734E-05 + .1883E-05 + .2055E-05 + .2240E-05 + .2448E-05 + .2662E-05 + .2924E-05 + .3168E-05 + .3446E-05 + .3830E-05 + .4196E-05 + .4604E-05 + .4974E-05 + .5282E-05 + .5452E-05 + .5578E-05 + .5574E-05 + .5519E-05 + .5405E-05 + .5212E-05 + .5001E-05 + .4788E-05 + .4527E-05 + .4291E-05 + .4034E-05 + .3774E-05 + .3501E-05 + .3293E-05 + .3059E-05 + .2903E-05 + .2876E-05 + .2876E-05 + .2737E-05 + .2489E-05 + .2398E-05 + .2168E-05 + .1859E-05 + .1538E-05 + .1172E-05 + .8933E-06 + .6807E-06 + .4915E-06 + .3866E-06 + .2855E-06 + .1868E-06 + .1223E-06 + .9225E-07 + .7447E-07 + .6012E-07 + .4904E-07 + .4499E-07 + .4128E-07 + .3636E-07 + .3086E-07 + .2618E-07 + .2459E-07 + .1376E-05 + .1487E-05 + .1606E-05 + .1736E-05 + .1877E-05 + .2043E-05 + .2238E-05 + .2453E-05 + .2658E-05 + .2886E-05 + .3128E-05 + .3436E-05 + .3789E-05 + .4110E-05 + .4433E-05 + .4768E-05 + .4987E-05 + .5062E-05 + .5092E-05 + .5060E-05 + .5020E-05 + .4932E-05 + .4741E-05 + .4554E-05 + .4373E-05 + .4188E-05 + .4014E-05 + .3797E-05 + .3548E-05 + .3311E-05 + .3107E-05 + .2977E-05 + .2866E-05 + .2783E-05 + .2707E-05 + .2606E-05 + .2488E-05 + .2318E-05 + .2082E-05 + .1784E-05 + .1464E-05 + .1131E-05 + .8738E-06 + .6750E-06 + .4873E-06 + .3834E-06 + .2831E-06 + .1853E-06 + .1212E-06 + .9148E-07 + .7385E-07 + .5962E-07 + .4863E-07 + .4461E-07 + .4093E-07 + .3606E-07 + .3060E-07 + .2596E-07 + .2438E-07 + .1407E-05 + .1522E-05 + .1645E-05 + .1777E-05 + .1922E-05 + .2095E-05 + .2297E-05 + .2503E-05 + .2702E-05 + .2916E-05 + .3155E-05 + .3457E-05 + .3788E-05 + .4080E-05 + .4350E-05 + .4639E-05 + .4800E-05 + .4819E-05 + .4804E-05 + .4754E-05 + .4705E-05 + .4622E-05 + .4449E-05 + .4282E-05 + .4122E-05 + .3968E-05 + .3820E-05 + .3637E-05 + .3427E-05 + .3228E-05 + .3049E-05 + .2944E-05 + .2844E-05 + .2746E-05 + .2652E-05 + .2561E-05 + .2440E-05 + .2246E-05 + .1996E-05 + .1692E-05 + .1379E-05 + .1088E-05 + .8578E-06 + .6766E-06 + .4885E-06 + .3843E-06 + .2838E-06 + .1857E-06 + .1215E-06 + .9169E-07 + .7402E-07 + .5976E-07 + .4874E-07 + .4472E-07 + .4103E-07 + .3614E-07 + .3067E-07 + .2602E-07 + .2444E-07 + .1463E-05 + .1582E-05 + .1709E-05 + .1845E-05 + .2000E-05 + .2185E-05 + .2396E-05 + .2592E-05 + .2787E-05 + .2996E-05 + .3233E-05 + .3524E-05 + .3841E-05 + .4112E-05 + .4344E-05 + .4589E-05 + .4705E-05 + .4681E-05 + .4636E-05 + .4571E-05 + .4506E-05 + .4422E-05 + .4264E-05 + .4113E-05 + .3966E-05 + .3825E-05 + .3689E-05 + .3533E-05 + .3361E-05 + .3197E-05 + .3046E-05 + .2944E-05 + .2845E-05 + .2750E-05 + .2658E-05 + .2568E-05 + .2408E-05 + .2210E-05 + .1944E-05 + .1627E-05 + .1320E-05 + .1062E-05 + .8547E-06 + .6878E-06 + .4966E-06 + .3907E-06 + .2885E-06 + .1888E-06 + .1235E-06 + .9322E-07 + .7525E-07 + .6075E-07 + .4955E-07 + .4546E-07 + .4171E-07 + .3675E-07 + .3118E-07 + .2646E-07 + .2485E-07 + .1537E-05 + .1661E-05 + .1794E-05 + .1937E-05 + .2104E-05 + .2304E-05 + .2526E-05 + .2713E-05 + .2906E-05 + .3112E-05 + .3349E-05 + .3631E-05 + .3937E-05 + .4190E-05 + .4385E-05 + .4589E-05 + .4662E-05 + .4597E-05 + .4524E-05 + .4444E-05 + .4364E-05 + .4278E-05 + .4133E-05 + .3994E-05 + .3859E-05 + .3729E-05 + .3603E-05 + .3471E-05 + .3333E-05 + .3202E-05 + .3077E-05 + .2976E-05 + .2878E-05 + .2784E-05 + .2692E-05 + .2603E-05 + .2403E-05 + .2198E-05 + .1914E-05 + .1582E-05 + .1277E-05 + .1048E-05 + .8609E-06 + .7069E-06 + .5104E-06 + .4015E-06 + .2965E-06 + .1940E-06 + .1270E-06 + .9580E-07 + .7734E-07 + .6244E-07 + .5092E-07 + .4672E-07 + .4286E-07 + .3776E-07 + .3204E-07 + .2719E-07 + .2554E-07 + .8213E-06 + .8936E-06 + .9722E-06 + .1054E-05 + .1140E-05 + .1232E-05 + .1322E-05 + .1409E-05 + .1507E-05 + .1613E-05 + .1741E-05 + .1881E-05 + .2032E-05 + .2194E-05 + .2365E-05 + .2549E-05 + .2681E-05 + .2806E-05 + .2929E-05 + .3058E-05 + .3192E-05 + .3253E-05 + .3315E-05 + .3379E-05 + .3343E-05 + .3285E-05 + .3228E-05 + .3116E-05 + .2957E-05 + .2806E-05 + .2662E-05 + .2495E-05 + .2323E-05 + .2170E-05 + .2033E-05 + .1895E-05 + .1762E-05 + .1635E-05 + .1469E-05 + .1253E-05 + .1039E-05 + .8816E-06 + .7480E-06 + .6346E-06 + .4442E-06 + .2853E-06 + .1771E-06 + .1030E-06 + .5987E-07 + .4521E-07 + .3865E-07 + .3305E-07 + .2840E-07 + .2579E-07 + .2342E-07 + .2066E-07 + .1775E-07 + .1525E-07 + .1439E-07 + .8750E-06 + .9547E-06 + .1042E-05 + .1126E-05 + .1206E-05 + .1292E-05 + .1378E-05 + .1464E-05 + .1570E-05 + .1683E-05 + .1816E-05 + .1963E-05 + .2122E-05 + .2293E-05 + .2465E-05 + .2650E-05 + .2805E-05 + .2932E-05 + .3049E-05 + .3171E-05 + .3298E-05 + .3376E-05 + .3456E-05 + .3538E-05 + .3513E-05 + .3432E-05 + .3353E-05 + .3239E-05 + .3094E-05 + .2955E-05 + .2822E-05 + .2627E-05 + .2418E-05 + .2241E-05 + .2091E-05 + .1945E-05 + .1800E-05 + .1661E-05 + .1500E-05 + .1271E-05 + .1050E-05 + .8874E-06 + .7503E-06 + .6344E-06 + .4440E-06 + .2853E-06 + .1771E-06 + .1029E-06 + .5985E-07 + .4520E-07 + .3864E-07 + .3304E-07 + .2839E-07 + .2578E-07 + .2341E-07 + .2066E-07 + .1774E-07 + .1524E-07 + .1438E-07 + .9475E-06 + .1037E-05 + .1134E-05 + .1222E-05 + .1297E-05 + .1377E-05 + .1459E-05 + .1545E-05 + .1661E-05 + .1786E-05 + .1924E-05 + .2082E-05 + .2253E-05 + .2435E-05 + .2611E-05 + .2800E-05 + .2981E-05 + .3114E-05 + .3225E-05 + .3341E-05 + .3461E-05 + .3560E-05 + .3661E-05 + .3766E-05 + .3752E-05 + .3644E-05 + .3540E-05 + .3421E-05 + .3289E-05 + .3162E-05 + .3040E-05 + .2812E-05 + .2557E-05 + .2351E-05 + .2185E-05 + .2027E-05 + .1869E-05 + .1714E-05 + .1556E-05 + .1310E-05 + .1077E-05 + .9076E-06 + .7647E-06 + .6443E-06 + .4509E-06 + .2897E-06 + .1798E-06 + .1045E-06 + .6078E-07 + .4590E-07 + .3924E-07 + .3355E-07 + .2883E-07 + .2618E-07 + .2378E-07 + .2098E-07 + .1802E-07 + .1548E-07 + .1461E-07 + .1025E-05 + .1124E-05 + .1233E-05 + .1326E-05 + .1398E-05 + .1474E-05 + .1554E-05 + .1643E-05 + .1770E-05 + .1906E-05 + .2054E-05 + .2224E-05 + .2409E-05 + .2606E-05 + .2792E-05 + .2990E-05 + .3200E-05 + .3342E-05 + .3452E-05 + .3565E-05 + .3680E-05 + .3798E-05 + .3919E-05 + .4044E-05 + .4040E-05 + .3908E-05 + .3780E-05 + .3656E-05 + .3534E-05 + .3416E-05 + .3302E-05 + .3038E-05 + .2737E-05 + .2505E-05 + .2317E-05 + .2143E-05 + .1968E-05 + .1793E-05 + .1632E-05 + .1369E-05 + .1121E-05 + .9400E-06 + .7879E-06 + .6604E-06 + .4622E-06 + .2969E-06 + .1843E-06 + .1072E-06 + .6230E-07 + .4704E-07 + .4022E-07 + .3439E-07 + .2955E-07 + .2684E-07 + .2437E-07 + .2150E-07 + .1847E-07 + .1587E-07 + .1497E-07 + .1054E-05 + .1160E-05 + .1275E-05 + .1374E-05 + .1454E-05 + .1538E-05 + .1627E-05 + .1726E-05 + .1862E-05 + .2008E-05 + .2165E-05 + .2350E-05 + .2554E-05 + .2770E-05 + .2982E-05 + .3210E-05 + .3442E-05 + .3608E-05 + .3735E-05 + .3861E-05 + .3981E-05 + .4101E-05 + .4217E-05 + .4336E-05 + .4329E-05 + .4204E-05 + .4078E-05 + .3956E-05 + .3825E-05 + .3692E-05 + .3566E-05 + .3284E-05 + .2966E-05 + .2750E-05 + .2523E-05 + .2316E-05 + .2114E-05 + .1920E-05 + .1726E-05 + .1457E-05 + .1197E-05 + .9894E-06 + .8181E-06 + .6764E-06 + .4734E-06 + .3041E-06 + .1888E-06 + .1098E-06 + .6381E-07 + .4819E-07 + .4120E-07 + .3523E-07 + .3027E-07 + .2749E-07 + .2496E-07 + .2203E-07 + .1892E-07 + .1625E-07 + .1533E-07 + .1103E-05 + .1219E-05 + .1341E-05 + .1450E-05 + .1540E-05 + .1634E-05 + .1735E-05 + .1847E-05 + .1995E-05 + .2152E-05 + .2324E-05 + .2527E-05 + .2756E-05 + .2996E-05 + .3243E-05 + .3509E-05 + .3768E-05 + .3965E-05 + .4115E-05 + .4257E-05 + .4384E-05 + .4509E-05 + .4620E-05 + .4733E-05 + .4723E-05 + .4603E-05 + .4478E-05 + .4359E-05 + .4215E-05 + .4063E-05 + .3921E-05 + .3615E-05 + .3272E-05 + .3072E-05 + .2797E-05 + .2547E-05 + .2313E-05 + .2093E-05 + .1859E-05 + .1580E-05 + .1300E-05 + .1054E-05 + .8543E-06 + .6926E-06 + .4863E-06 + .3147E-06 + .1965E-06 + .1147E-06 + .6698E-07 + .5063E-07 + .4327E-07 + .3698E-07 + .3176E-07 + .2884E-07 + .2619E-07 + .2312E-07 + .1988E-07 + .1709E-07 + .1613E-07 + .1170E-05 + .1297E-05 + .1431E-05 + .1550E-05 + .1652E-05 + .1759E-05 + .1874E-05 + .2002E-05 + .2166E-05 + .2339E-05 + .2529E-05 + .2755E-05 + .3014E-05 + .3285E-05 + .3574E-05 + .3887E-05 + .4181E-05 + .4417E-05 + .4595E-05 + .4758E-05 + .4894E-05 + .5024E-05 + .5129E-05 + .5236E-05 + .5223E-05 + .5109E-05 + .4985E-05 + .4867E-05 + .4708E-05 + .4532E-05 + .4371E-05 + .4032E-05 + .3658E-05 + .3479E-05 + .3144E-05 + .2840E-05 + .2564E-05 + .2313E-05 + .2029E-05 + .1735E-05 + .1431E-05 + .1126E-05 + .8865E-06 + .6977E-06 + .4941E-06 + .3259E-06 + .2069E-06 + .1221E-06 + .7205E-07 + .5461E-07 + .4661E-07 + .3979E-07 + .3413E-07 + .3099E-07 + .2814E-07 + .2487E-07 + .2143E-07 + .1847E-07 + .1745E-07 + .1244E-05 + .1385E-05 + .1530E-05 + .1662E-05 + .1778E-05 + .1900E-05 + .2030E-05 + .2177E-05 + .2358E-05 + .2549E-05 + .2760E-05 + .3012E-05 + .3307E-05 + .3612E-05 + .3951E-05 + .4319E-05 + .4653E-05 + .4935E-05 + .5145E-05 + .5333E-05 + .5479E-05 + .5614E-05 + .5712E-05 + .5810E-05 + .5792E-05 + .5686E-05 + .5565E-05 + .5450E-05 + .5273E-05 + .5070E-05 + .4885E-05 + .4511E-05 + .4102E-05 + .3896E-05 + .3511E-05 + .3164E-05 + .2849E-05 + .2561E-05 + .2235E-05 + .1897E-05 + .1554E-05 + .1194E-05 + .9174E-06 + .7048E-06 + .5034E-06 + .3384E-06 + .2183E-06 + .1303E-06 + .7772E-07 + .5907E-07 + .5036E-07 + .4293E-07 + .3679E-07 + .3340E-07 + .3033E-07 + .2683E-07 + .2318E-07 + .2002E-07 + .1893E-07 + .1318E-05 + .1473E-05 + .1630E-05 + .1775E-05 + .1905E-05 + .2042E-05 + .2191E-05 + .2358E-05 + .2557E-05 + .2766E-05 + .2998E-05 + .3279E-05 + .3612E-05 + .3955E-05 + .4349E-05 + .4778E-05 + .5156E-05 + .5489E-05 + .5737E-05 + .5952E-05 + .6108E-05 + .6246E-05 + .6333E-05 + .6419E-05 + .6396E-05 + .6303E-05 + .6186E-05 + .6078E-05 + .5881E-05 + .5647E-05 + .5438E-05 + .5026E-05 + .4580E-05 + .4301E-05 + .3879E-05 + .3499E-05 + .3151E-05 + .2822E-05 + .2464E-05 + .2052E-05 + .1662E-05 + .1251E-05 + .9418E-06 + .7090E-06 + .5107E-06 + .3499E-06 + .2295E-06 + .1384E-06 + .8349E-07 + .6362E-07 + .5417E-07 + .4613E-07 + .3948E-07 + .3584E-07 + .3254E-07 + .2883E-07 + .2496E-07 + .2161E-07 + .2045E-07 + .1370E-05 + .1536E-05 + .1704E-05 + .1860E-05 + .2004E-05 + .2155E-05 + .2319E-05 + .2506E-05 + .2721E-05 + .2946E-05 + .3197E-05 + .3503E-05 + .3872E-05 + .4249E-05 + .4698E-05 + .5188E-05 + .5607E-05 + .5993E-05 + .6278E-05 + .6520E-05 + .6682E-05 + .6821E-05 + .6891E-05 + .6960E-05 + .6931E-05 + .6856E-05 + .6749E-05 + .6652E-05 + .6437E-05 + .6173E-05 + .5939E-05 + .5495E-05 + .5019E-05 + .4659E-05 + .4206E-05 + .3797E-05 + .3420E-05 + .3053E-05 + .2666E-05 + .2180E-05 + .1744E-05 + .1286E-05 + .9488E-06 + .6999E-06 + .5084E-06 + .3551E-06 + .2367E-06 + .1443E-06 + .8801E-07 + .6725E-07 + .5719E-07 + .4864E-07 + .4158E-07 + .3775E-07 + .3427E-07 + .3039E-07 + .2638E-07 + .2289E-07 + .2169E-07 + .1401E-05 + .1576E-05 + .1751E-05 + .1916E-05 + .2072E-05 + .2236E-05 + .2415E-05 + .2618E-05 + .2848E-05 + .3085E-05 + .3352E-05 + .3680E-05 + .4081E-05 + .4490E-05 + .4990E-05 + .5539E-05 + .5997E-05 + .6434E-05 + .6756E-05 + .7023E-05 + .7189E-05 + .7325E-05 + .7374E-05 + .7421E-05 + .7387E-05 + .7333E-05 + .7241E-05 + .7158E-05 + .6929E-05 + .6636E-05 + .6380E-05 + .5907E-05 + .5409E-05 + .4964E-05 + .4485E-05 + .4053E-05 + .3650E-05 + .3247E-05 + .2836E-05 + .2277E-05 + .1799E-05 + .1300E-05 + .9400E-06 + .6795E-06 + .4978E-06 + .3544E-06 + .2401E-06 + .1480E-06 + .9124E-07 + .6990E-07 + .5938E-07 + .5044E-07 + .4307E-07 + .3909E-07 + .3549E-07 + .3151E-07 + .2741E-07 + .2385E-07 + .2261E-07 + .1382E-05 + .1560E-05 + .1735E-05 + .1902E-05 + .2063E-05 + .2232E-05 + .2418E-05 + .2630E-05 + .2863E-05 + .3106E-05 + .3380E-05 + .3715E-05 + .4133E-05 + .4559E-05 + .5091E-05 + .5679E-05 + .6165E-05 + .6638E-05 + .6986E-05 + .7272E-05 + .7437E-05 + .7562E-05 + .7592E-05 + .7616E-05 + .7578E-05 + .7548E-05 + .7472E-05 + .7407E-05 + .7175E-05 + .6867E-05 + .6597E-05 + .6116E-05 + .5611E-05 + .5096E-05 + .4607E-05 + .4176E-05 + .3801E-05 + .3419E-05 + .2973E-05 + .2444E-05 + .1896E-05 + .1317E-05 + .9154E-06 + .6361E-06 + .4700E-06 + .3411E-06 + .2349E-06 + .1464E-06 + .9121E-07 + .7006E-07 + .5944E-07 + .5043E-07 + .4302E-07 + .3904E-07 + .3543E-07 + .3150E-07 + .2747E-07 + .2395E-07 + .2273E-07 + .1389E-05 + .1556E-05 + .1724E-05 + .1883E-05 + .2038E-05 + .2203E-05 + .2384E-05 + .2595E-05 + .2816E-05 + .3070E-05 + .3360E-05 + .3674E-05 + .4086E-05 + .4530E-05 + .5063E-05 + .5663E-05 + .6228E-05 + .6713E-05 + .7076E-05 + .7404E-05 + .7580E-05 + .7678E-05 + .7736E-05 + .7755E-05 + .7732E-05 + .7701E-05 + .7622E-05 + .7539E-05 + .7351E-05 + .7071E-05 + .6783E-05 + .6310E-05 + .5788E-05 + .5244E-05 + .4741E-05 + .4287E-05 + .3873E-05 + .3452E-05 + .2974E-05 + .2423E-05 + .1851E-05 + .1272E-05 + .8741E-06 + .6006E-06 + .4476E-06 + .3311E-06 + .2317E-06 + .1460E-06 + .9197E-07 + .7084E-07 + .6002E-07 + .5086E-07 + .4334E-07 + .3933E-07 + .3569E-07 + .3177E-07 + .2777E-07 + .2427E-07 + .2306E-07 + .1394E-05 + .1552E-05 + .1710E-05 + .1860E-05 + .2011E-05 + .2173E-05 + .2352E-05 + .2562E-05 + .2775E-05 + .3044E-05 + .3339E-05 + .3638E-05 + .4042E-05 + .4492E-05 + .5023E-05 + .5637E-05 + .6250E-05 + .6760E-05 + .7145E-05 + .7495E-05 + .7677E-05 + .7760E-05 + .7837E-05 + .7854E-05 + .7843E-05 + .7810E-05 + .7729E-05 + .7623E-05 + .7462E-05 + .7201E-05 + .6901E-05 + .6431E-05 + .5891E-05 + .5336E-05 + .4820E-05 + .4342E-05 + .3884E-05 + .3428E-05 + .2912E-05 + .2342E-05 + .1758E-05 + .1204E-05 + .8250E-06 + .5652E-06 + .4248E-06 + .3203E-06 + .2279E-06 + .1451E-06 + .9242E-07 + .7138E-07 + .6041E-07 + .5113E-07 + .4351E-07 + .3948E-07 + .3583E-07 + .3193E-07 + .2797E-07 + .2451E-07 + .2330E-07 + .1420E-05 + .1572E-05 + .1720E-05 + .1864E-05 + .2016E-05 + .2183E-05 + .2367E-05 + .2581E-05 + .2802E-05 + .3093E-05 + .3380E-05 + .3680E-05 + .4078E-05 + .4516E-05 + .5051E-05 + .5694E-05 + .6300E-05 + .6871E-05 + .7299E-05 + .7630E-05 + .7809E-05 + .7911E-05 + .7986E-05 + .8009E-05 + .7999E-05 + .7965E-05 + .7879E-05 + .7739E-05 + .7564E-05 + .7294E-05 + .6986E-05 + .6500E-05 + .5932E-05 + .5396E-05 + .4863E-05 + .4347E-05 + .3836E-05 + .3345E-05 + .2775E-05 + .2182E-05 + .1599E-05 + .1112E-05 + .7734E-06 + .5378E-06 + .4076E-06 + .3133E-06 + .2266E-06 + .1459E-06 + .9391E-07 + .7272E-07 + .6147E-07 + .5196E-07 + .4417E-07 + .4008E-07 + .3637E-07 + .3244E-07 + .2849E-07 + .2502E-07 + .2381E-07 + .1430E-05 + .1582E-05 + .1729E-05 + .1875E-05 + .2030E-05 + .2200E-05 + .2388E-05 + .2601E-05 + .2826E-05 + .3112E-05 + .3391E-05 + .3698E-05 + .4078E-05 + .4521E-05 + .5049E-05 + .5697E-05 + .6290E-05 + .6911E-05 + .7398E-05 + .7761E-05 + .7970E-05 + .8096E-05 + .8171E-05 + .8193E-05 + .8183E-05 + .8128E-05 + .8021E-05 + .7876E-05 + .7680E-05 + .7377E-05 + .7025E-05 + .6510E-05 + .5931E-05 + .5387E-05 + .4838E-05 + .4299E-05 + .3760E-05 + .3223E-05 + .2615E-05 + .2014E-05 + .1455E-05 + .1027E-05 + .7242E-06 + .5108E-06 + .3905E-06 + .3059E-06 + .2248E-06 + .1463E-06 + .9526E-07 + .7396E-07 + .6244E-07 + .5272E-07 + .4476E-07 + .4061E-07 + .3685E-07 + .3291E-07 + .2897E-07 + .2551E-07 + .2429E-07 + .1428E-05 + .1583E-05 + .1738E-05 + .1892E-05 + .2053E-05 + .2226E-05 + .2415E-05 + .2623E-05 + .2849E-05 + .3104E-05 + .3376E-05 + .3694E-05 + .4047E-05 + .4510E-05 + .5023E-05 + .5654E-05 + .6229E-05 + .6887E-05 + .7450E-05 + .7892E-05 + .8165E-05 + .8319E-05 + .8395E-05 + .8413E-05 + .8399E-05 + .8304E-05 + .8160E-05 + .8039E-05 + .7815E-05 + .7453E-05 + .7026E-05 + .6471E-05 + .5895E-05 + .5317E-05 + .4755E-05 + .4208E-05 + .3663E-05 + .3072E-05 + .2440E-05 + .1844E-05 + .1326E-05 + .9480E-06 + .6778E-06 + .4847E-06 + .3737E-06 + .2984E-06 + .2229E-06 + .1467E-06 + .9651E-07 + .7514E-07 + .6336E-07 + .5343E-07 + .4531E-07 + .4111E-07 + .3729E-07 + .3335E-07 + .2943E-07 + .2597E-07 + .2476E-07 + .1459E-05 + .1612E-05 + .1762E-05 + .1910E-05 + .2062E-05 + .2228E-05 + .2409E-05 + .2612E-05 + .2827E-05 + .3101E-05 + .3374E-05 + .3689E-05 + .4023E-05 + .4473E-05 + .4973E-05 + .5582E-05 + .6192E-05 + .6868E-05 + .7478E-05 + .7951E-05 + .8279E-05 + .8457E-05 + .8538E-05 + .8561E-05 + .8517E-05 + .8414E-05 + .8286E-05 + .8153E-05 + .7886E-05 + .7501E-05 + .7040E-05 + .6472E-05 + .5875E-05 + .5285E-05 + .4710E-05 + .4144E-05 + .3572E-05 + .2952E-05 + .2312E-05 + .1698E-05 + .1202E-05 + .8615E-06 + .6174E-06 + .4424E-06 + .3423E-06 + .2775E-06 + .2110E-06 + .1419E-06 + .9545E-07 + .7509E-07 + .6363E-07 + .5393E-07 + .4595E-07 + .4165E-07 + .3776E-07 + .3369E-07 + .2975E-07 + .2619E-07 + .2490E-07 + .1518E-05 + .1668E-05 + .1809E-05 + .1947E-05 + .2086E-05 + .2242E-05 + .2412E-05 + .2614E-05 + .2815E-05 + .3128E-05 + .3410E-05 + .3720E-05 + .4040E-05 + .4468E-05 + .4963E-05 + .5554E-05 + .6222E-05 + .6915E-05 + .7569E-05 + .8059E-05 + .8443E-05 + .8647E-05 + .8735E-05 + .8765E-05 + .8680E-05 + .8582E-05 + .8489E-05 + .8329E-05 + .8008E-05 + .7610E-05 + .7125E-05 + .6550E-05 + .5916E-05 + .5316E-05 + .4723E-05 + .4131E-05 + .3519E-05 + .2872E-05 + .2224E-05 + .1582E-05 + .1099E-05 + .7608E-06 + .5269E-06 + .3649E-06 + .2796E-06 + .2279E-06 + .1768E-06 + .1251E-06 + .8849E-07 + .7176E-07 + .6209E-07 + .5372E-07 + .4665E-07 + .4218E-07 + .3815E-07 + .3368E-07 + .2965E-07 + .2572E-07 + .2417E-07 + .1539E-05 + .1676E-05 + .1804E-05 + .1943E-05 + .2092E-05 + .2261E-05 + .2446E-05 + .2658E-05 + .2879E-05 + .3150E-05 + .3424E-05 + .3731E-05 + .4054E-05 + .4475E-05 + .4953E-05 + .5531E-05 + .6210E-05 + .6914E-05 + .7587E-05 + .8148E-05 + .8548E-05 + .8829E-05 + .8988E-05 + .8947E-05 + .8895E-05 + .8813E-05 + .8705E-05 + .8522E-05 + .8201E-05 + .7768E-05 + .7275E-05 + .6638E-05 + .5987E-05 + .5351E-05 + .4717E-05 + .4105E-05 + .3459E-05 + .2765E-05 + .2067E-05 + .1427E-05 + .9544E-06 + .6490E-06 + .4413E-06 + .3001E-06 + .2279E-06 + .1866E-06 + .1478E-06 + .1100E-06 + .8183E-07 + .6840E-07 + .6042E-07 + .5338E-07 + .4723E-07 + .4261E-07 + .3845E-07 + .3358E-07 + .2947E-07 + .2520E-07 + .2339E-07 + .1546E-05 + .1673E-05 + .1794E-05 + .1935E-05 + .2094E-05 + .2274E-05 + .2471E-05 + .2690E-05 + .2929E-05 + .3160E-05 + .3426E-05 + .3727E-05 + .4056E-05 + .4467E-05 + .4928E-05 + .5492E-05 + .6175E-05 + .6878E-05 + .7560E-05 + .8176E-05 + .8595E-05 + .8947E-05 + .9176E-05 + .9086E-05 + .9073E-05 + .9009E-05 + .8881E-05 + .8679E-05 + .8358E-05 + .7895E-05 + .7388E-05 + .6698E-05 + .6031E-05 + .5355E-05 + .4686E-05 + .4054E-05 + .3378E-05 + .2641E-05 + .1907E-05 + .1277E-05 + .8219E-06 + .5493E-06 + .3672E-06 + .2454E-06 + .1846E-06 + .1519E-06 + .1229E-06 + .9614E-07 + .7522E-07 + .6481E-07 + .5845E-07 + .5272E-07 + .4755E-07 + .4279E-07 + .3852E-07 + .3329E-07 + .2912E-07 + .2454E-07 + .2251E-07 + .1525E-05 + .1675E-05 + .1824E-05 + .1974E-05 + .2134E-05 + .2311E-05 + .2503E-05 + .2718E-05 + .2947E-05 + .3184E-05 + .3457E-05 + .3758E-05 + .4106E-05 + .4504E-05 + .4957E-05 + .5522E-05 + .6191E-05 + .6855E-05 + .7507E-05 + .8096E-05 + .8571E-05 + .8931E-05 + .9191E-05 + .9226E-05 + .9256E-05 + .9198E-05 + .9041E-05 + .8844E-05 + .8501E-05 + .8032E-05 + .7457E-05 + .6778E-05 + .6072E-05 + .5328E-05 + .4650E-05 + .3977E-05 + .3266E-05 + .2493E-05 + .1750E-05 + .1142E-05 + .7054E-06 + .4632E-06 + .3042E-06 + .1997E-06 + .1489E-06 + .1231E-06 + .1017E-06 + .8366E-07 + .6883E-07 + .6113E-07 + .5629E-07 + .5184E-07 + .4764E-07 + .4278E-07 + .3841E-07 + .3285E-07 + .2864E-07 + .2379E-07 + .2156E-07 + .1519E-05 + .1682E-05 + .1846E-05 + .1999E-05 + .2158E-05 + .2329E-05 + .2516E-05 + .2725E-05 + .2945E-05 + .3188E-05 + .3461E-05 + .3767E-05 + .4117E-05 + .4504E-05 + .4955E-05 + .5512E-05 + .6159E-05 + .6798E-05 + .7441E-05 + .8026E-05 + .8540E-05 + .8924E-05 + .9221E-05 + .9361E-05 + .9438E-05 + .9392E-05 + .9238E-05 + .9056E-05 + .8672E-05 + .8196E-05 + .7567E-05 + .6865E-05 + .6111E-05 + .5313E-05 + .4605E-05 + .3879E-05 + .3122E-05 + .2325E-05 + .1599E-05 + .1020E-05 + .6013E-06 + .3888E-06 + .2514E-06 + .1626E-06 + .1200E-06 + .9980E-07 + .8411E-07 + .7278E-07 + .6298E-07 + .5765E-07 + .5421E-07 + .5097E-07 + .4773E-07 + .4276E-07 + .3831E-07 + .3241E-07 + .2816E-07 + .2306E-07 + .2065E-07 + .1544E-05 + .1700E-05 + .1857E-05 + .2002E-05 + .2154E-05 + .2316E-05 + .2496E-05 + .2698E-05 + .2912E-05 + .3160E-05 + .3419E-05 + .3742E-05 + .4062E-05 + .4443E-05 + .4904E-05 + .5439E-05 + .6052E-05 + .6691E-05 + .7366E-05 + .7989E-05 + .8512E-05 + .8951E-05 + .9296E-05 + .9504E-05 + .9634E-05 + .9608E-05 + .9519E-05 + .9372E-05 + .8912E-05 + .8425E-05 + .7769E-05 + .6976E-05 + .6158E-05 + .5328E-05 + .4555E-05 + .3751E-05 + .2926E-05 + .2128E-05 + .1451E-05 + .9107E-06 + .5073E-06 + .3243E-06 + .2073E-06 + .1325E-06 + .9695E-07 + .8100E-07 + .6969E-07 + .6342E-07 + .5771E-07 + .5446E-07 + .5228E-07 + .5018E-07 + .4790E-07 + .4281E-07 + .3826E-07 + .3202E-07 + .2774E-07 + .2238E-07 + .1981E-07 + .1563E-05 + .1717E-05 + .1868E-05 + .2006E-05 + .2152E-05 + .2311E-05 + .2489E-05 + .2686E-05 + .2906E-05 + .3144E-05 + .3400E-05 + .3718E-05 + .4041E-05 + .4432E-05 + .4890E-05 + .5418E-05 + .6012E-05 + .6671E-05 + .7331E-05 + .7957E-05 + .8490E-05 + .8953E-05 + .9370E-05 + .9634E-05 + .9822E-05 + .9850E-05 + .9820E-05 + .9697E-05 + .9212E-05 + .8697E-05 + .7991E-05 + .7106E-05 + .6189E-05 + .5287E-05 + .4426E-05 + .3566E-05 + .2732E-05 + .1968E-05 + .1325E-05 + .8074E-06 + .4279E-06 + .2704E-06 + .1709E-06 + .1080E-06 + .7830E-07 + .6575E-07 + .5775E-07 + .5527E-07 + .5289E-07 + .5144E-07 + .5042E-07 + .4942E-07 + .4807E-07 + .4286E-07 + .3821E-07 + .3164E-07 + .2732E-07 + .2173E-07 + .1901E-07 + .1576E-05 + .1732E-05 + .1876E-05 + .2009E-05 + .2150E-05 + .2309E-05 + .2489E-05 + .2683E-05 + .2916E-05 + .3134E-05 + .3396E-05 + .3690E-05 + .4043E-05 + .4455E-05 + .4897E-05 + .5430E-05 + .6017E-05 + .6709E-05 + .7321E-05 + .7921E-05 + .8464E-05 + .8927E-05 + .9433E-05 + .9743E-05 + .9992E-05 + .1010E-04 + .1013E-04 + .1002E-04 + .9553E-05 + .8998E-05 + .8224E-05 + .7244E-05 + .6199E-05 + .5197E-05 + .4236E-05 + .3343E-05 + .2541E-05 + .1833E-05 + .1215E-05 + .7111E-06 + .3604E-06 + .2253E-06 + .1408E-06 + .8797E-07 + .6318E-07 + .5332E-07 + .4781E-07 + .4811E-07 + .4842E-07 + .4855E-07 + .4858E-07 + .4861E-07 + .4819E-07 + .4286E-07 + .3813E-07 + .3124E-07 + .2689E-07 + .2107E-07 + .1822E-07 + .1555E-05 + .1704E-05 + .1848E-05 + .1984E-05 + .2131E-05 + .2295E-05 + .2478E-05 + .2675E-05 + .2905E-05 + .3129E-05 + .3387E-05 + .3676E-05 + .4024E-05 + .4421E-05 + .4885E-05 + .5424E-05 + .6002E-05 + .6652E-05 + .7268E-05 + .7852E-05 + .8404E-05 + .8881E-05 + .9372E-05 + .9702E-05 + .9981E-05 + .1020E-04 + .1030E-04 + .1024E-04 + .9824E-05 + .9225E-05 + .8387E-05 + .7317E-05 + .6167E-05 + .5097E-05 + .4101E-05 + .3197E-05 + .2405E-05 + .1714E-05 + .1115E-05 + .6339E-06 + .3158E-06 + .1924E-06 + .1172E-06 + .7137E-07 + .5078E-07 + .4307E-07 + .3942E-07 + .4172E-07 + .4416E-07 + .4564E-07 + .4663E-07 + .4764E-07 + .4813E-07 + .4271E-07 + .3790E-07 + .3072E-07 + .2636E-07 + .2036E-07 + .1739E-07 + .1524E-05 + .1664E-05 + .1808E-05 + .1949E-05 + .2106E-05 + .2277E-05 + .2463E-05 + .2663E-05 + .2886E-05 + .3125E-05 + .3374E-05 + .3664E-05 + .3996E-05 + .4368E-05 + .4866E-05 + .5409E-05 + .5977E-05 + .6564E-05 + .7199E-05 + .7768E-05 + .8331E-05 + .8824E-05 + .9271E-05 + .9611E-05 + .9910E-05 + .1024E-04 + .1042E-04 + .1042E-04 + .1007E-04 + .9426E-05 + .8526E-05 + .7366E-05 + .6118E-05 + .4992E-05 + .3982E-05 + .3073E-05 + .2286E-05 + .1603E-05 + .1023E-05 + .5667E-06 + .2799E-06 + .1745E-06 + .1088E-06 + .6787E-07 + .4923E-07 + .4203E-07 + .3855E-07 + .4050E-07 + .4256E-07 + .4376E-07 + .4453E-07 + .4532E-07 + .4566E-07 + .4088E-07 + .3661E-07 + .3022E-07 + .2566E-07 + .1957E-07 + .1679E-07 + .1523E-05 + .1662E-05 + .1806E-05 + .1947E-05 + .2103E-05 + .2274E-05 + .2462E-05 + .2665E-05 + .2892E-05 + .3114E-05 + .3366E-05 + .3657E-05 + .3993E-05 + .4360E-05 + .4811E-05 + .5338E-05 + .5925E-05 + .6503E-05 + .7105E-05 + .7708E-05 + .8264E-05 + .8750E-05 + .9160E-05 + .9491E-05 + .9866E-05 + .1021E-04 + .1050E-04 + .1056E-04 + .1016E-04 + .9514E-05 + .8568E-05 + .7358E-05 + .6091E-05 + .4933E-05 + .3912E-05 + .3007E-05 + .2235E-05 + .1556E-05 + .9681E-06 + .5173E-06 + .2534E-06 + .1620E-06 + .1036E-06 + .6628E-07 + .4921E-07 + .4231E-07 + .3877E-07 + .4011E-07 + .4149E-07 + .4224E-07 + .4267E-07 + .4310E-07 + .4316E-07 + .3907E-07 + .3536E-07 + .2984E-07 + .2505E-07 + .1887E-07 + .1629E-07 + .1528E-05 + .1667E-05 + .1811E-05 + .1951E-05 + .2105E-05 + .2276E-05 + .2465E-05 + .2671E-05 + .2902E-05 + .3111E-05 + .3365E-05 + .3661E-05 + .4002E-05 + .4362E-05 + .4774E-05 + .5288E-05 + .5890E-05 + .6464E-05 + .7048E-05 + .7678E-05 + .8231E-05 + .8704E-05 + .9084E-05 + .9399E-05 + .9818E-05 + .1018E-04 + .1057E-04 + .1070E-04 + .1027E-04 + .9605E-05 + .8620E-05 + .7375E-05 + .6085E-05 + .4898E-05 + .3865E-05 + .2961E-05 + .2202E-05 + .1526E-05 + .9322E-06 + .4829E-06 + .2345E-06 + .1528E-06 + .9956E-07 + .6487E-07 + .4930E-07 + .4268E-07 + .3907E-07 + .3980E-07 + .4055E-07 + .4086E-07 + .4097E-07 + .4108E-07 + .4089E-07 + .3741E-07 + .3423E-07 + .2953E-07 + .2451E-07 + .1824E-07 + .1585E-07 + .1534E-05 + .1675E-05 + .1814E-05 + .1950E-05 + .2102E-05 + .2270E-05 + .2455E-05 + .2659E-05 + .2884E-05 + .3106E-05 + .3343E-05 + .3665E-05 + .3999E-05 + .4340E-05 + .4748E-05 + .5258E-05 + .5852E-05 + .6428E-05 + .7050E-05 + .7672E-05 + .8226E-05 + .8663E-05 + .9025E-05 + .9297E-05 + .9621E-05 + .1002E-04 + .1050E-04 + .1072E-04 + .1031E-04 + .9584E-05 + .8607E-05 + .7402E-05 + .6085E-05 + .4894E-05 + .3854E-05 + .2953E-05 + .2204E-05 + .1538E-05 + .9504E-06 + .4886E-06 + .2349E-06 + .1517E-06 + .9792E-07 + .6322E-07 + .4918E-07 + .4287E-07 + .3922E-07 + .3933E-07 + .3945E-07 + .3936E-07 + .3918E-07 + .3899E-07 + .3858E-07 + .3568E-07 + .3299E-07 + .2909E-07 + .2388E-07 + .1755E-07 + .1535E-07 + .1544E-05 + .1687E-05 + .1826E-05 + .1960E-05 + .2110E-05 + .2275E-05 + .2458E-05 + .2662E-05 + .2881E-05 + .3112E-05 + .3340E-05 + .3682E-05 + .4007E-05 + .4345E-05 + .4760E-05 + .5268E-05 + .5838E-05 + .6419E-05 + .7048E-05 + .7664E-05 + .8230E-05 + .8639E-05 + .8984E-05 + .9234E-05 + .9520E-05 + .9938E-05 + .1042E-04 + .1069E-04 + .1028E-04 + .9550E-05 + .8599E-05 + .7431E-05 + .6089E-05 + .4895E-05 + .3850E-05 + .2942E-05 + .2200E-05 + .1548E-05 + .9681E-06 + .5008E-06 + .2389E-06 + .1521E-06 + .9686E-07 + .6167E-07 + .4911E-07 + .4310E-07 + .3940E-07 + .3891E-07 + .3842E-07 + .3795E-07 + .3749E-07 + .3704E-07 + .3643E-07 + .3405E-07 + .3183E-07 + .2870E-07 + .2329E-07 + .1691E-07 + .1488E-07 + .1560E-05 + .1703E-05 + .1845E-05 + .1983E-05 + .2131E-05 + .2295E-05 + .2477E-05 + .2683E-05 + .2895E-05 + .3132E-05 + .3362E-05 + .3713E-05 + .4027E-05 + .4382E-05 + .4822E-05 + .5327E-05 + .5853E-05 + .6442E-05 + .7029E-05 + .7641E-05 + .8235E-05 + .8629E-05 + .8958E-05 + .9212E-05 + .9544E-05 + .9952E-05 + .1031E-04 + .1055E-04 + .1013E-04 + .9481E-05 + .8587E-05 + .7452E-05 + .6092E-05 + .4898E-05 + .3851E-05 + .2921E-05 + .2186E-05 + .1554E-05 + .9831E-06 + .5227E-06 + .2483E-06 + .1562E-06 + .9826E-07 + .6180E-07 + .4938E-07 + .4326E-07 + .3936E-07 + .3847E-07 + .3760E-07 + .3697E-07 + .3646E-07 + .3595E-07 + .3533E-07 + .3333E-07 + .3144E-07 + .2872E-07 + .2322E-07 + .1672E-07 + .1469E-07 + .1578E-05 + .1716E-05 + .1854E-05 + .1988E-05 + .2133E-05 + .2296E-05 + .2477E-05 + .2684E-05 + .2891E-05 + .3131E-05 + .3363E-05 + .3698E-05 + .4016E-05 + .4396E-05 + .4839E-05 + .5316E-05 + .5867E-05 + .6462E-05 + .7042E-05 + .7600E-05 + .8180E-05 + .8594E-05 + .8935E-05 + .9193E-05 + .9563E-05 + .9979E-05 + .1028E-04 + .1043E-04 + .9998E-05 + .9391E-05 + .8554E-05 + .7434E-05 + .6116E-05 + .4937E-05 + .3886E-05 + .2951E-05 + .2192E-05 + .1553E-05 + .9847E-06 + .5336E-06 + .2488E-06 + .1580E-06 + .1003E-06 + .6366E-07 + .5001E-07 + .4338E-07 + .3913E-07 + .3804E-07 + .3698E-07 + .3639E-07 + .3603E-07 + .3567E-07 + .3520E-07 + .3345E-07 + .3180E-07 + .2918E-07 + .2368E-07 + .1697E-07 + .1478E-07 + .1604E-05 + .1731E-05 + .1862E-05 + .1988E-05 + .2129E-05 + .2292E-05 + .2473E-05 + .2679E-05 + .2886E-05 + .3127E-05 + .3362E-05 + .3664E-05 + .3996E-05 + .4410E-05 + .4840E-05 + .5277E-05 + .5901E-05 + .6502E-05 + .7097E-05 + .7574E-05 + .8111E-05 + .8570E-05 + .8942E-05 + .9204E-05 + .9609E-05 + .1005E-04 + .1033E-04 + .1036E-04 + .9913E-05 + .9318E-05 + .8536E-05 + .7416E-05 + .6175E-05 + .5017E-05 + .3957E-05 + .3025E-05 + .2218E-05 + .1553E-05 + .9806E-06 + .5385E-06 + .2442E-06 + .1577E-06 + .1019E-06 + .6581E-07 + .5083E-07 + .4364E-07 + .3903E-07 + .3774E-07 + .3650E-07 + .3595E-07 + .3573E-07 + .3551E-07 + .3519E-07 + .3370E-07 + .3227E-07 + .2975E-07 + .2423E-07 + .1729E-07 + .1492E-07 + .1620E-05 + .1744E-05 + .1875E-05 + .1999E-05 + .2138E-05 + .2295E-05 + .2473E-05 + .2676E-05 + .2882E-05 + .3140E-05 + .3358E-05 + .3664E-05 + .4007E-05 + .4411E-05 + .4852E-05 + .5322E-05 + .5896E-05 + .6483E-05 + .7097E-05 + .7574E-05 + .8119E-05 + .8605E-05 + .9014E-05 + .9305E-05 + .9698E-05 + .1001E-04 + .1023E-04 + .1023E-04 + .9855E-05 + .9280E-05 + .8518E-05 + .7439E-05 + .6242E-05 + .5089E-05 + .4011E-05 + .3072E-05 + .2252E-05 + .1564E-05 + .9867E-06 + .5341E-06 + .2375E-06 + .1566E-06 + .1032E-06 + .6803E-07 + .5167E-07 + .4391E-07 + .3894E-07 + .3745E-07 + .3603E-07 + .3552E-07 + .3544E-07 + .3536E-07 + .3518E-07 + .3395E-07 + .3276E-07 + .3034E-07 + .2480E-07 + .1761E-07 + .1507E-07 + .1631E-05 + .1755E-05 + .1886E-05 + .2009E-05 + .2145E-05 + .2296E-05 + .2469E-05 + .2670E-05 + .2873E-05 + .3150E-05 + .3347E-05 + .3664E-05 + .4018E-05 + .4403E-05 + .4858E-05 + .5377E-05 + .5874E-05 + .6441E-05 + .7075E-05 + .7570E-05 + .8133E-05 + .8639E-05 + .9086E-05 + .9411E-05 + .9778E-05 + .9942E-05 + .1008E-04 + .1007E-04 + .9787E-05 + .9233E-05 + .8485E-05 + .7457E-05 + .6299E-05 + .5151E-05 + .4055E-05 + .3107E-05 + .2283E-05 + .1576E-05 + .9940E-06 + .5277E-06 + .2312E-06 + .1554E-06 + .1045E-06 + .7021E-07 + .5243E-07 + .4410E-07 + .3878E-07 + .3711E-07 + .3550E-07 + .3504E-07 + .3509E-07 + .3515E-07 + .3512E-07 + .3415E-07 + .3320E-07 + .3088E-07 + .2534E-07 + .1791E-07 + .1519E-07 + .1647E-05 + .1775E-05 + .1903E-05 + .2018E-05 + .2146E-05 + .2290E-05 + .2457E-05 + .2646E-05 + .2849E-05 + .3095E-05 + .3332E-05 + .3656E-05 + .3991E-05 + .4386E-05 + .4813E-05 + .5358E-05 + .5934E-05 + .6521E-05 + .7145E-05 + .7687E-05 + .8227E-05 + .8693E-05 + .9109E-05 + .9416E-05 + .9701E-05 + .9854E-05 + .9994E-05 + .9984E-05 + .9659E-05 + .9111E-05 + .8358E-05 + .7373E-05 + .6282E-05 + .5146E-05 + .4050E-05 + .3094E-05 + .2263E-05 + .1574E-05 + .1018E-05 + .5716E-06 + .2722E-06 + .1750E-06 + .1125E-06 + .7233E-07 + .5311E-07 + .4422E-07 + .3855E-07 + .3669E-07 + .3492E-07 + .3450E-07 + .3469E-07 + .3488E-07 + .3499E-07 + .3428E-07 + .3358E-07 + .3138E-07 + .2584E-07 + .1819E-07 + .1528E-07 + .1659E-05 + .1789E-05 + .1915E-05 + .2026E-05 + .2150E-05 + .2291E-05 + .2455E-05 + .2637E-05 + .2842E-05 + .3069E-05 + .3335E-05 + .3660E-05 + .3986E-05 + .4397E-05 + .4811E-05 + .5376E-05 + .6014E-05 + .6623E-05 + .7244E-05 + .7823E-05 + .8338E-05 + .8769E-05 + .9154E-05 + .9434E-05 + .9644E-05 + .9787E-05 + .9911E-05 + .9887E-05 + .9528E-05 + .8986E-05 + .8243E-05 + .7296E-05 + .6259E-05 + .5140E-05 + .4048E-05 + .3082E-05 + .2249E-05 + .1577E-05 + .1041E-05 + .6139E-06 + .3119E-06 + .1937E-06 + .1202E-06 + .7465E-07 + .5389E-07 + .4442E-07 + .3840E-07 + .3635E-07 + .3441E-07 + .3403E-07 + .3435E-07 + .3467E-07 + .3493E-07 + .3448E-07 + .3403E-07 + .3194E-07 + .2640E-07 + .1850E-07 + .1540E-07 + .1655E-05 + .1783E-05 + .1915E-05 + .2033E-05 + .2167E-05 + .2317E-05 + .2490E-05 + .2682E-05 + .2892E-05 + .3145E-05 + .3403E-05 + .3715E-05 + .4066E-05 + .4510E-05 + .4968E-05 + .5529E-05 + .6173E-05 + .6813E-05 + .7455E-05 + .8033E-05 + .8520E-05 + .8934E-05 + .9287E-05 + .9514E-05 + .9667E-05 + .9808E-05 + .9856E-05 + .9778E-05 + .9401E-05 + .8868E-05 + .8173E-05 + .7255E-05 + .6224E-05 + .5139E-05 + .4066E-05 + .3082E-05 + .2259E-05 + .1595E-05 + .1059E-05 + .6420E-06 + .3268E-06 + .2024E-06 + .1253E-06 + .7761E-07 + .5509E-07 + .4495E-07 + .3853E-07 + .3628E-07 + .3417E-07 + .3381E-07 + .3426E-07 + .3471E-07 + .3512E-07 + .3493E-07 + .3474E-07 + .3276E-07 + .2718E-07 + .1895E-07 + .1564E-07 + .1661E-05 + .1788E-05 + .1922E-05 + .2043E-05 + .2181E-05 + .2336E-05 + .2514E-05 + .2714E-05 + .2925E-05 + .3195E-05 + .3465E-05 + .3772E-05 + .4150E-05 + .4618E-05 + .5119E-05 + .5684E-05 + .6326E-05 + .6972E-05 + .7622E-05 + .8179E-05 + .8631E-05 + .8998E-05 + .9309E-05 + .9486E-05 + .9609E-05 + .9716E-05 + .9711E-05 + .9600E-05 + .9233E-05 + .8717E-05 + .8062E-05 + .7185E-05 + .6176E-05 + .5130E-05 + .4090E-05 + .3106E-05 + .2291E-05 + .1636E-05 + .1098E-05 + .6775E-06 + .3511E-06 + .2163E-06 + .1332E-06 + .8205E-07 + .5877E-07 + .4834E-07 + .4149E-07 + .3860E-07 + .3592E-07 + .3536E-07 + .3576E-07 + .3617E-07 + .3653E-07 + .3632E-07 + .3611E-07 + .3396E-07 + .2843E-07 + .2050E-07 + .1723E-07 + .1675E-05 + .1800E-05 + .1931E-05 + .2049E-05 + .2181E-05 + .2338E-05 + .2515E-05 + .2720E-05 + .2925E-05 + .3197E-05 + .3504E-05 + .3820E-05 + .4222E-05 + .4700E-05 + .5238E-05 + .5820E-05 + .6446E-05 + .7059E-05 + .7699E-05 + .8205E-05 + .8617E-05 + .8896E-05 + .9154E-05 + .9287E-05 + .9413E-05 + .9449E-05 + .9417E-05 + .9302E-05 + .8981E-05 + .8496E-05 + .7870E-05 + .7055E-05 + .6091E-05 + .5095E-05 + .4107E-05 + .3152E-05 + .2345E-05 + .1701E-05 + .1164E-05 + .7206E-06 + .3883E-06 + .2370E-06 + .1447E-06 + .8830E-07 + .6597E-07 + .5603E-07 + .4876E-07 + .4444E-07 + .4050E-07 + .3936E-07 + .3944E-07 + .3951E-07 + .3953E-07 + .3889E-07 + .3826E-07 + .3557E-07 + .3025E-07 + .2368E-07 + .2099E-07 + .1647E-05 + .1774E-05 + .1905E-05 + .2029E-05 + .2168E-05 + .2329E-05 + .2512E-05 + .2723E-05 + .2934E-05 + .3215E-05 + .3532E-05 + .3858E-05 + .4266E-05 + .4759E-05 + .5315E-05 + .5915E-05 + .6525E-05 + .7128E-05 + .7715E-05 + .8171E-05 + .8521E-05 + .8744E-05 + .8948E-05 + .9050E-05 + .9149E-05 + .9155E-05 + .9104E-05 + .8952E-05 + .8653E-05 + .8203E-05 + .7620E-05 + .6874E-05 + .5982E-05 + .5045E-05 + .4103E-05 + .3187E-05 + .2412E-05 + .1781E-05 + .1250E-05 + .7879E-06 + .4436E-06 + .2651E-06 + .1584E-06 + .9463E-07 + .7375E-07 + .6468E-07 + .5707E-07 + .5095E-07 + .4549E-07 + .4363E-07 + .4330E-07 + .4298E-07 + .4259E-07 + .4147E-07 + .4038E-07 + .3709E-07 + .3205E-07 + .2724E-07 + .2546E-07 + .1597E-05 + .1725E-05 + .1860E-05 + .1994E-05 + .2145E-05 + .2314E-05 + .2505E-05 + .2725E-05 + .2947E-05 + .3242E-05 + .3552E-05 + .3890E-05 + .4293E-05 + .4801E-05 + .5364E-05 + .5984E-05 + .6579E-05 + .7184E-05 + .7695E-05 + .8100E-05 + .8379E-05 + .8563E-05 + .8715E-05 + .8793E-05 + .8850E-05 + .8848E-05 + .8782E-05 + .8579E-05 + .8289E-05 + .7875E-05 + .7343E-05 + .6665E-05 + .5858E-05 + .4985E-05 + .4086E-05 + .3216E-05 + .2485E-05 + .1871E-05 + .1351E-05 + .8741E-06 + .5157E-06 + .3155E-06 + .1931E-06 + .1181E-06 + .9065E-07 + .7714E-07 + .6601E-07 + .5710E-07 + .4940E-07 + .4657E-07 + .4573E-07 + .4491E-07 + .4406E-07 + .4276E-07 + .4149E-07 + .3799E-07 + .3295E-07 + .2859E-07 + .2707E-07 + .1592E-05 + .1723E-05 + .1859E-05 + .1997E-05 + .2146E-05 + .2312E-05 + .2500E-05 + .2718E-05 + .2943E-05 + .3245E-05 + .3573E-05 + .3907E-05 + .4332E-05 + .4835E-05 + .5376E-05 + .6012E-05 + .6597E-05 + .7195E-05 + .7659E-05 + .8018E-05 + .8270E-05 + .8399E-05 + .8484E-05 + .8514E-05 + .8522E-05 + .8476E-05 + .8385E-05 + .8183E-05 + .7885E-05 + .7514E-05 + .7060E-05 + .6449E-05 + .5737E-05 + .4937E-05 + .4083E-05 + .3248E-05 + .2545E-05 + .1947E-05 + .1425E-05 + .9639E-06 + .6016E-06 + .3832E-06 + .2440E-06 + .1554E-06 + .1152E-06 + .9314E-07 + .7616E-07 + .6361E-07 + .5312E-07 + .4915E-07 + .4774E-07 + .4637E-07 + .4504E-07 + .4366E-07 + .4233E-07 + .3873E-07 + .3359E-07 + .2913E-07 + .2758E-07 + .1592E-05 + .1728E-05 + .1866E-05 + .2006E-05 + .2150E-05 + .2313E-05 + .2496E-05 + .2712E-05 + .2939E-05 + .3248E-05 + .3597E-05 + .3927E-05 + .4378E-05 + .4872E-05 + .5390E-05 + .6037E-05 + .6612E-05 + .7199E-05 + .7621E-05 + .7933E-05 + .8162E-05 + .8237E-05 + .8256E-05 + .8238E-05 + .8201E-05 + .8108E-05 + .7994E-05 + .7799E-05 + .7496E-05 + .7167E-05 + .6788E-05 + .6240E-05 + .5619E-05 + .4889E-05 + .4082E-05 + .3282E-05 + .2606E-05 + .2025E-05 + .1500E-05 + .1063E-05 + .7026E-06 + .4657E-06 + .3086E-06 + .2045E-06 + .1464E-06 + .1125E-06 + .8790E-07 + .7087E-07 + .5715E-07 + .5189E-07 + .4985E-07 + .4789E-07 + .4604E-07 + .4459E-07 + .4319E-07 + .3949E-07 + .3424E-07 + .2969E-07 + .2811E-07 + .1561E-05 + .1706E-05 + .1851E-05 + .1997E-05 + .2144E-05 + .2308E-05 + .2495E-05 + .2720E-05 + .2950E-05 + .3281E-05 + .3642E-05 + .3990E-05 + .4454E-05 + .4947E-05 + .5483E-05 + .6092E-05 + .6629E-05 + .7139E-05 + .7525E-05 + .7766E-05 + .7933E-05 + .7958E-05 + .7935E-05 + .7899E-05 + .7836E-05 + .7722E-05 + .7574E-05 + .7376E-05 + .7146E-05 + .6834E-05 + .6512E-05 + .6032E-05 + .5468E-05 + .4800E-05 + .4057E-05 + .3316E-05 + .2681E-05 + .2125E-05 + .1622E-05 + .1186E-05 + .8185E-06 + .5642E-06 + .3889E-06 + .2680E-06 + .1853E-06 + .1353E-06 + .1010E-06 + .7864E-07 + .6122E-07 + .5455E-07 + .5184E-07 + .4926E-07 + .4688E-07 + .4535E-07 + .4388E-07 + .4010E-07 + .3476E-07 + .3013E-07 + .2853E-07 + .1539E-05 + .1694E-05 + .1847E-05 + .2000E-05 + .2152E-05 + .2320E-05 + .2514E-05 + .2748E-05 + .2988E-05 + .3330E-05 + .3708E-05 + .4076E-05 + .4555E-05 + .5054E-05 + .5615E-05 + .6201E-05 + .6714E-05 + .7161E-05 + .7510E-05 + .7692E-05 + .7800E-05 + .7778E-05 + .7717E-05 + .7655E-05 + .7565E-05 + .7432E-05 + .7257E-05 + .7056E-05 + .6877E-05 + .6583E-05 + .6303E-05 + .5883E-05 + .5374E-05 + .4761E-05 + .4074E-05 + .3382E-05 + .2780E-05 + .2244E-05 + .1762E-05 + .1328E-05 + .9538E-06 + .6544E-06 + .4490E-06 + .3081E-06 + .2105E-06 + .1518E-06 + .1115E-06 + .8482E-07 + .6454E-07 + .5655E-07 + .5299E-07 + .4965E-07 + .4663E-07 + .4504E-07 + .4350E-07 + .3962E-07 + .3417E-07 + .2947E-07 + .2786E-07 + .1511E-05 + .1671E-05 + .1830E-05 + .1993E-05 + .2156E-05 + .2332E-05 + .2534E-05 + .2771E-05 + .3034E-05 + .3348E-05 + .3750E-05 + .4136E-05 + .4623E-05 + .5137E-05 + .5733E-05 + .6329E-05 + .6843E-05 + .7255E-05 + .7555E-05 + .7698E-05 + .7746E-05 + .7683E-05 + .7586E-05 + .7474E-05 + .7356E-05 + .7201E-05 + .7015E-05 + .6816E-05 + .6648E-05 + .6380E-05 + .6120E-05 + .5755E-05 + .5308E-05 + .4754E-05 + .4120E-05 + .3467E-05 + .2878E-05 + .2365E-05 + .1901E-05 + .1472E-05 + .1089E-05 + .7364E-06 + .4978E-06 + .3366E-06 + .2294E-06 + .1657E-06 + .1211E-06 + .9055E-07 + .6768E-07 + .5836E-07 + .5385E-07 + .4969E-07 + .4601E-07 + .4435E-07 + .4274E-07 + .3875E-07 + .3320E-07 + .2844E-07 + .2681E-07 + .1467E-05 + .1632E-05 + .1798E-05 + .1970E-05 + .2143E-05 + .2325E-05 + .2533E-05 + .2772E-05 + .3049E-05 + .3344E-05 + .3762E-05 + .4169E-05 + .4663E-05 + .5191E-05 + .5793E-05 + .6394E-05 + .6899E-05 + .7290E-05 + .7547E-05 + .7664E-05 + .7667E-05 + .7574E-05 + .7447E-05 + .7302E-05 + .7155E-05 + .6986E-05 + .6801E-05 + .6609E-05 + .6450E-05 + .6213E-05 + .5934E-05 + .5633E-05 + .5229E-05 + .4718E-05 + .4113E-05 + .3514E-05 + .2967E-05 + .2482E-05 + .2034E-05 + .1605E-05 + .1216E-05 + .8159E-06 + .5476E-06 + .3675E-06 + .2498E-06 + .1809E-06 + .1316E-06 + .9661E-07 + .7093E-07 + .6018E-07 + .5469E-07 + .4970E-07 + .4538E-07 + .4364E-07 + .4197E-07 + .3788E-07 + .3224E-07 + .2743E-07 + .2579E-07 + .1407E-05 + .1576E-05 + .1749E-05 + .1929E-05 + .2111E-05 + .2298E-05 + .2507E-05 + .2748E-05 + .3026E-05 + .3314E-05 + .3739E-05 + .4169E-05 + .4670E-05 + .5208E-05 + .5783E-05 + .6386E-05 + .6872E-05 + .7254E-05 + .7478E-05 + .7584E-05 + .7558E-05 + .7447E-05 + .7296E-05 + .7137E-05 + .6958E-05 + .6781E-05 + .6611E-05 + .6431E-05 + .6281E-05 + .6078E-05 + .5742E-05 + .5515E-05 + .5135E-05 + .4649E-05 + .4047E-05 + .3517E-05 + .3042E-05 + .2590E-05 + .2157E-05 + .1720E-05 + .1323E-05 + .8886E-06 + .5968E-06 + .4008E-06 + .2717E-06 + .1972E-06 + .1428E-06 + .1030E-06 + .7425E-07 + .6199E-07 + .5548E-07 + .4966E-07 + .4470E-07 + .4290E-07 + .4117E-07 + .3699E-07 + .3127E-07 + .2643E-07 + .2478E-07 + .1368E-05 + .1546E-05 + .1723E-05 + .1905E-05 + .2091E-05 + .2279E-05 + .2490E-05 + .2733E-05 + .3022E-05 + .3311E-05 + .3746E-05 + .4191E-05 + .4694E-05 + .5239E-05 + .5807E-05 + .6393E-05 + .6887E-05 + .7248E-05 + .7472E-05 + .7562E-05 + .7518E-05 + .7388E-05 + .7216E-05 + .7037E-05 + .6854E-05 + .6664E-05 + .6492E-05 + .6323E-05 + .6185E-05 + .5992E-05 + .5524E-05 + .5337E-05 + .4988E-05 + .4543E-05 + .3979E-05 + .3504E-05 + .3083E-05 + .2661E-05 + .2249E-05 + .1813E-05 + .1407E-05 + .9527E-06 + .6452E-06 + .4370E-06 + .2998E-06 + .2169E-06 + .1537E-06 + .1047E-06 + .7124E-07 + .5892E-07 + .5345E-07 + .4848E-07 + .4416E-07 + .4215E-07 + .4022E-07 + .3616E-07 + .3075E-07 + .2616E-07 + .2459E-07 + .1335E-05 + .1521E-05 + .1700E-05 + .1883E-05 + .2070E-05 + .2256E-05 + .2468E-05 + .2714E-05 + .3017E-05 + .3310E-05 + .3754E-05 + .4209E-05 + .4709E-05 + .5257E-05 + .5828E-05 + .6386E-05 + .6899E-05 + .7230E-05 + .7468E-05 + .7540E-05 + .7483E-05 + .7335E-05 + .7143E-05 + .6943E-05 + .6767E-05 + .6563E-05 + .6384E-05 + .6224E-05 + .6102E-05 + .5908E-05 + .5282E-05 + .5119E-05 + .4804E-05 + .4408E-05 + .3898E-05 + .3474E-05 + .3096E-05 + .2705E-05 + .2321E-05 + .1889E-05 + .1475E-05 + .1011E-05 + .6927E-06 + .4747E-06 + .3317E-06 + .2388E-06 + .1644E-06 + .1037E-06 + .6547E-07 + .5380E-07 + .5011E-07 + .4668E-07 + .4354E-07 + .4126E-07 + .3910E-07 + .3524E-07 + .3034E-07 + .2611E-07 + .2466E-07 + .1307E-05 + .1501E-05 + .1682E-05 + .1865E-05 + .2053E-05 + .2237E-05 + .2450E-05 + .2697E-05 + .3013E-05 + .3310E-05 + .3749E-05 + .4155E-05 + .4655E-05 + .5193E-05 + .5788E-05 + .6346E-05 + .6871E-05 + .7228E-05 + .7465E-05 + .7531E-05 + .7443E-05 + .7297E-05 + .7090E-05 + .6845E-05 + .6654E-05 + .6398E-05 + .6147E-05 + .5930E-05 + .5753E-05 + .5495E-05 + .4959E-05 + .4831E-05 + .4587E-05 + .4264E-05 + .3767E-05 + .3410E-05 + .3092E-05 + .2740E-05 + .2386E-05 + .1963E-05 + .1543E-05 + .1071E-05 + .7429E-06 + .5155E-06 + .3669E-06 + .2628E-06 + .1756E-06 + .1028E-06 + .6013E-07 + .4910E-07 + .4696E-07 + .4492E-07 + .4290E-07 + .4037E-07 + .3798E-07 + .3434E-07 + .2991E-07 + .2606E-07 + .2473E-07 + .1261E-05 + .1459E-05 + .1638E-05 + .1820E-05 + .2005E-05 + .2185E-05 + .2395E-05 + .2641E-05 + .2963E-05 + .3258E-05 + .3685E-05 + .4037E-05 + .4530E-05 + .5047E-05 + .5657E-05 + .6203E-05 + .6727E-05 + .7102E-05 + .7332E-05 + .7390E-05 + .7272E-05 + .7129E-05 + .6912E-05 + .6632E-05 + .6428E-05 + .6130E-05 + .5819E-05 + .5554E-05 + .5328E-05 + .5016E-05 + .4588E-05 + .4492E-05 + .4318E-05 + .4067E-05 + .3585E-05 + .3296E-05 + .3038E-05 + .2730E-05 + .2412E-05 + .2006E-05 + .1587E-05 + .1113E-05 + .7809E-06 + .5478E-06 + .3898E-06 + .2803E-06 + .1898E-06 + .1145E-06 + .6912E-07 + .5556E-07 + .5118E-07 + .4715E-07 + .4350E-07 + .4077E-07 + .3822E-07 + .3471E-07 + .3061E-07 + .2700E-07 + .2574E-07 + .1211E-05 + .1411E-05 + .1587E-05 + .1765E-05 + .1946E-05 + .2121E-05 + .2327E-05 + .2569E-05 + .2892E-05 + .3184E-05 + .3609E-05 + .3955E-05 + .4431E-05 + .4916E-05 + .5512E-05 + .6006E-05 + .6478E-05 + .6808E-05 + .7019E-05 + .7053E-05 + .6916E-05 + .6738E-05 + .6535E-05 + .6284E-05 + .6061E-05 + .5785E-05 + .5521E-05 + .5272E-05 + .5030E-05 + .4692E-05 + .4329E-05 + .4252E-05 + .4117E-05 + .3908E-05 + .3440E-05 + .3191E-05 + .2968E-05 + .2686E-05 + .2391E-05 + .2019E-05 + .1605E-05 + .1142E-05 + .8122E-06 + .5777E-06 + .4110E-06 + .2967E-06 + .2035E-06 + .1267E-06 + .7885E-07 + .6241E-07 + .5536E-07 + .4912E-07 + .4375E-07 + .4086E-07 + .3815E-07 + .3481E-07 + .3109E-07 + .2776E-07 + .2659E-07 + .1158E-05 + .1357E-05 + .1529E-05 + .1702E-05 + .1878E-05 + .2047E-05 + .2248E-05 + .2484E-05 + .2807E-05 + .3092E-05 + .3498E-05 + .3832E-05 + .4289E-05 + .4740E-05 + .5302E-05 + .5747E-05 + .6168E-05 + .6447E-05 + .6635E-05 + .6647E-05 + .6511E-05 + .6320E-05 + .6120E-05 + .5891E-05 + .5657E-05 + .5391E-05 + .5156E-05 + .4915E-05 + .4745E-05 + .4390E-05 + .4081E-05 + .4020E-05 + .3917E-05 + .3743E-05 + .3291E-05 + .3076E-05 + .2883E-05 + .2625E-05 + .2351E-05 + .2018E-05 + .1612E-05 + .1163E-05 + .8390E-06 + .6053E-06 + .4306E-06 + .3120E-06 + .2168E-06 + .1392E-06 + .8938E-07 + .6965E-07 + .5951E-07 + .5084E-07 + .4374E-07 + .4069E-07 + .3786E-07 + .3470E-07 + .3137E-07 + .2836E-07 + .2729E-07 + .1106E-05 + .1302E-05 + .1470E-05 + .1638E-05 + .1809E-05 + .1972E-05 + .2167E-05 + .2397E-05 + .2717E-05 + .2995E-05 + .3352E-05 + .3665E-05 + .4101E-05 + .4515E-05 + .5006E-05 + .5414E-05 + .5790E-05 + .6008E-05 + .6167E-05 + .6159E-05 + .6057E-05 + .5893E-05 + .5673E-05 + .5450E-05 + .5214E-05 + .4939E-05 + .4700E-05 + .4451E-05 + .4516E-05 + .4157E-05 + .3882E-05 + .3831E-05 + .3748E-05 + .3596E-05 + .3160E-05 + .2967E-05 + .2794E-05 + .2553E-05 + .2295E-05 + .2006E-05 + .1609E-05 + .1179E-05 + .8634E-06 + .6324E-06 + .4498E-06 + .3271E-06 + .2303E-06 + .1525E-06 + .1010E-06 + .7751E-07 + .6377E-07 + .5247E-07 + .4359E-07 + .4040E-07 + .3744E-07 + .3448E-07 + .3156E-07 + .2889E-07 + .2793E-07 + .1052E-05 + .1246E-05 + .1409E-05 + .1571E-05 + .1736E-05 + .1892E-05 + .2081E-05 + .2303E-05 + .2617E-05 + .2888E-05 + .3187E-05 + .3472E-05 + .3890E-05 + .4265E-05 + .4704E-05 + .5080E-05 + .5413E-05 + .5576E-05 + .5712E-05 + .5687E-05 + .5608E-05 + .5470E-05 + .5235E-05 + .5006E-05 + .4773E-05 + .4489E-05 + .4308E-05 + .4098E-05 + .4196E-05 + .3941E-05 + .3695E-05 + .3651E-05 + .3583E-05 + .3448E-05 + .3029E-05 + .2853E-05 + .2695E-05 + .2470E-05 + .2226E-05 + .1982E-05 + .1600E-05 + .1190E-05 + .8845E-06 + .6575E-06 + .4676E-06 + .3413E-06 + .2435E-06 + .1664E-06 + .1136E-06 + .8584E-07 + .6802E-07 + .5390E-07 + .4323E-07 + .3992E-07 + .3686E-07 + .3410E-07 + .3161E-07 + .2929E-07 + .2845E-07 + .9969E-06 + .1186E-05 + .1342E-05 + .1498E-05 + .1657E-05 + .1806E-05 + .1987E-05 + .2201E-05 + .2507E-05 + .2767E-05 + .3004E-05 + .3257E-05 + .3659E-05 + .3992E-05 + .4391E-05 + .4740E-05 + .5034E-05 + .5146E-05 + .5264E-05 + .5224E-05 + .5159E-05 + .5049E-05 + .4801E-05 + .4560E-05 + .4333E-05 + .4044E-05 + .3961E-05 + .3824E-05 + .3806E-05 + .3735E-05 + .3510E-05 + .3472E-05 + .3414E-05 + .3293E-05 + .2891E-05 + .2730E-05 + .2585E-05 + .2374E-05 + .2143E-05 + .1944E-05 + .1583E-05 + .1176E-05 + .8735E-06 + .6489E-06 + .4614E-06 + .3373E-06 + .2419E-06 + .1672E-06 + .1155E-06 + .8675E-07 + .6777E-07 + .5294E-07 + .4191E-07 + .3865E-07 + .3564E-07 + .3303E-07 + .3075E-07 + .2863E-07 + .2786E-07 + .1049E-05 + .1224E-05 + .1376E-05 + .1542E-05 + .1726E-05 + .1901E-05 + .2085E-05 + .2291E-05 + .2531E-05 + .2779E-05 + .3038E-05 + .3323E-05 + .3652E-05 + .3950E-05 + .4280E-05 + .4587E-05 + .4756E-05 + .4894E-05 + .4997E-05 + .4907E-05 + .4815E-05 + .4717E-05 + .4594E-05 + .4446E-05 + .4293E-05 + .4130E-05 + .4015E-05 + .3892E-05 + .3786E-05 + .3687E-05 + .3537E-05 + .3386E-05 + .3239E-05 + .3086E-05 + .2889E-05 + .2701E-05 + .2517E-05 + .2332E-05 + .2059E-05 + .1787E-05 + .1518E-05 + .1152E-05 + .8748E-06 + .6640E-06 + .4722E-06 + .3452E-06 + .2475E-06 + .1711E-06 + .1182E-06 + .8878E-07 + .6935E-07 + .5418E-07 + .4289E-07 + .3955E-07 + .3647E-07 + .3380E-07 + .3147E-07 + .2930E-07 + .2851E-07 + .1144E-05 + .1318E-05 + .1479E-05 + .1660E-05 + .1854E-05 + .2036E-05 + .2225E-05 + .2431E-05 + .2656E-05 + .2902E-05 + .3167E-05 + .3451E-05 + .3752E-05 + .4042E-05 + .4318E-05 + .4580E-05 + .4723E-05 + .4870E-05 + .4955E-05 + .4858E-05 + .4763E-05 + .4670E-05 + .4579E-05 + .4464E-05 + .4341E-05 + .4222E-05 + .4098E-05 + .3971E-05 + .3848E-05 + .3728E-05 + .3596E-05 + .3431E-05 + .3274E-05 + .3115E-05 + .2955E-05 + .2764E-05 + .2576E-05 + .2374E-05 + .2074E-05 + .1779E-05 + .1495E-05 + .1160E-05 + .9000E-06 + .6983E-06 + .4966E-06 + .3630E-06 + .2603E-06 + .1799E-06 + .1243E-06 + .9336E-07 + .7293E-07 + .5698E-07 + .4510E-07 + .4159E-07 + .3835E-07 + .3554E-07 + .3309E-07 + .3081E-07 + .2998E-07 + .1240E-05 + .1415E-05 + .1588E-05 + .1782E-05 + .1980E-05 + .2161E-05 + .2351E-05 + .2558E-05 + .2783E-05 + .3027E-05 + .3284E-05 + .3553E-05 + .3838E-05 + .4122E-05 + .4347E-05 + .4564E-05 + .4707E-05 + .4853E-05 + .4919E-05 + .4827E-05 + .4737E-05 + .4649E-05 + .4562E-05 + .4461E-05 + .4355E-05 + .4251E-05 + .4134E-05 + .4003E-05 + .3877E-05 + .3755E-05 + .3626E-05 + .3477E-05 + .3335E-05 + .3178E-05 + .3010E-05 + .2825E-05 + .2645E-05 + .2417E-05 + .2097E-05 + .1799E-05 + .1475E-05 + .1167E-05 + .9235E-06 + .7306E-06 + .5195E-06 + .3798E-06 + .2723E-06 + .1882E-06 + .1301E-06 + .9768E-07 + .7631E-07 + .5961E-07 + .4719E-07 + .4352E-07 + .4013E-07 + .3719E-07 + .3462E-07 + .3224E-07 + .3137E-07 + .1343E-05 + .1518E-05 + .1703E-05 + .1910E-05 + .2111E-05 + .2291E-05 + .2482E-05 + .2688E-05 + .2912E-05 + .3155E-05 + .3403E-05 + .3655E-05 + .3923E-05 + .4200E-05 + .4374E-05 + .4546E-05 + .4687E-05 + .4833E-05 + .4880E-05 + .4793E-05 + .4708E-05 + .4624E-05 + .4542E-05 + .4454E-05 + .4365E-05 + .4278E-05 + .4166E-05 + .4033E-05 + .3904E-05 + .3779E-05 + .3654E-05 + .3522E-05 + .3394E-05 + .3240E-05 + .3063E-05 + .2884E-05 + .2713E-05 + .2458E-05 + .2119E-05 + .1817E-05 + .1455E-05 + .1174E-05 + .9467E-06 + .7637E-06 + .5431E-06 + .3970E-06 + .2847E-06 + .1967E-06 + .1360E-06 + .1021E-06 + .7977E-07 + .6231E-07 + .4933E-07 + .4549E-07 + .4195E-07 + .3887E-07 + .3619E-07 + .3370E-07 + .3279E-07 + .1450E-05 + .1544E-05 + .1643E-05 + .1747E-05 + .1858E-05 + .1975E-05 + .2092E-05 + .2216E-05 + .2347E-05 + .2488E-05 + .2638E-05 + .2797E-05 + .2965E-05 + .3148E-05 + .3327E-05 + .3515E-05 + .3710E-05 + .3910E-05 + .4082E-05 + .4220E-05 + .4342E-05 + .4446E-05 + .4552E-05 + .4661E-05 + .4672E-05 + .4584E-05 + .4499E-05 + .4415E-05 + .4332E-05 + .4233E-05 + .4117E-05 + .4005E-05 + .3763E-05 + .3535E-05 + .3292E-05 + .3004E-05 + .2669E-05 + .2343E-05 + .2054E-05 + .1741E-05 + .1444E-05 + .1249E-05 + .1081E-05 + .9352E-06 + .6607E-06 + .4587E-06 + .2828E-06 + .1391E-06 + .6837E-07 + .4941E-07 + .4288E-07 + .3721E-07 + .3242E-07 + .2960E-07 + .2703E-07 + .2420E-07 + .2127E-07 + .1870E-07 + .1781E-07 + .1440E-05 + .1535E-05 + .1636E-05 + .1742E-05 + .1856E-05 + .1973E-05 + .2090E-05 + .2214E-05 + .2345E-05 + .2486E-05 + .2640E-05 + .2803E-05 + .2975E-05 + .3168E-05 + .3365E-05 + .3574E-05 + .3785E-05 + .3996E-05 + .4193E-05 + .4373E-05 + .4509E-05 + .4597E-05 + .4687E-05 + .4778E-05 + .4788E-05 + .4714E-05 + .4642E-05 + .4570E-05 + .4500E-05 + .4387E-05 + .4234E-05 + .4086E-05 + .3856E-05 + .3638E-05 + .3364E-05 + .3065E-05 + .2712E-05 + .2354E-05 + .2055E-05 + .1735E-05 + .1431E-05 + .1238E-05 + .1071E-05 + .9268E-06 + .6547E-06 + .4546E-06 + .2803E-06 + .1378E-06 + .6776E-07 + .4897E-07 + .4249E-07 + .3688E-07 + .3213E-07 + .2934E-07 + .2679E-07 + .2398E-07 + .2108E-07 + .1854E-07 + .1765E-07 + .1441E-05 + .1537E-05 + .1640E-05 + .1749E-05 + .1866E-05 + .1984E-05 + .2102E-05 + .2227E-05 + .2359E-05 + .2503E-05 + .2661E-05 + .2828E-05 + .3007E-05 + .3211E-05 + .3428E-05 + .3660E-05 + .3890E-05 + .4114E-05 + .4339E-05 + .4564E-05 + .4716E-05 + .4788E-05 + .4860E-05 + .4934E-05 + .4941E-05 + .4882E-05 + .4824E-05 + .4766E-05 + .4709E-05 + .4580E-05 + .4385E-05 + .4199E-05 + .3979E-05 + .3771E-05 + .3462E-05 + .3150E-05 + .2775E-05 + .2381E-05 + .2070E-05 + .1740E-05 + .1428E-05 + .1235E-05 + .1069E-05 + .9248E-06 + .6534E-06 + .4536E-06 + .2797E-06 + .1375E-06 + .6761E-07 + .4887E-07 + .4240E-07 + .3680E-07 + .3206E-07 + .2928E-07 + .2673E-07 + .2393E-07 + .2104E-07 + .1850E-07 + .1761E-07 + .1446E-05 + .1544E-05 + .1649E-05 + .1761E-05 + .1880E-05 + .1999E-05 + .2118E-05 + .2244E-05 + .2378E-05 + .2526E-05 + .2691E-05 + .2865E-05 + .3052E-05 + .3270E-05 + .3508E-05 + .3764E-05 + .4016E-05 + .4257E-05 + .4503E-05 + .4763E-05 + .4929E-05 + .4990E-05 + .5049E-05 + .5101E-05 + .5103E-05 + .5054E-05 + .5006E-05 + .4959E-05 + .4912E-05 + .4771E-05 + .4546E-05 + .4325E-05 + .4113E-05 + .3910E-05 + .3574E-05 + .3245E-05 + .2850E-05 + .2423E-05 + .2095E-05 + .1755E-05 + .1432E-05 + .1238E-05 + .1071E-05 + .9259E-06 + .6541E-06 + .4541E-06 + .2800E-06 + .1377E-06 + .6769E-07 + .4892E-07 + .4245E-07 + .3684E-07 + .3210E-07 + .2931E-07 + .2676E-07 + .2396E-07 + .2106E-07 + .1852E-07 + .1763E-07 + .1464E-05 + .1565E-05 + .1668E-05 + .1777E-05 + .1894E-05 + .2013E-05 + .2137E-05 + .2269E-05 + .2408E-05 + .2568E-05 + .2745E-05 + .2936E-05 + .3143E-05 + .3380E-05 + .3639E-05 + .3922E-05 + .4209E-05 + .4482E-05 + .4702E-05 + .4932E-05 + .5094E-05 + .5180E-05 + .5252E-05 + .5266E-05 + .5242E-05 + .5182E-05 + .5123E-05 + .5065E-05 + .5007E-05 + .4883E-05 + .4696E-05 + .4479E-05 + .4248E-05 + .4029E-05 + .3716E-05 + .3363E-05 + .2955E-05 + .2513E-05 + .2157E-05 + .1802E-05 + .1458E-05 + .1257E-05 + .1084E-05 + .9351E-06 + .6606E-06 + .4586E-06 + .2828E-06 + .1390E-06 + .6836E-07 + .4941E-07 + .4287E-07 + .3721E-07 + .3242E-07 + .2960E-07 + .2703E-07 + .2420E-07 + .2127E-07 + .1870E-07 + .1780E-07 + .1506E-05 + .1611E-05 + .1714E-05 + .1823E-05 + .1939E-05 + .2061E-05 + .2192E-05 + .2330E-05 + .2478E-05 + .2652E-05 + .2847E-05 + .3057E-05 + .3289E-05 + .3552E-05 + .3837E-05 + .4152E-05 + .4484E-05 + .4796E-05 + .4989E-05 + .5190E-05 + .5350E-05 + .5465E-05 + .5553E-05 + .5524E-05 + .5473E-05 + .5401E-05 + .5329E-05 + .5258E-05 + .5188E-05 + .5078E-05 + .4931E-05 + .4713E-05 + .4459E-05 + .4218E-05 + .3926E-05 + .3543E-05 + .3114E-05 + .2650E-05 + .2258E-05 + .1880E-05 + .1510E-05 + .1285E-05 + .1093E-05 + .9304E-06 + .6586E-06 + .4603E-06 + .2861E-06 + .1422E-06 + .7064E-07 + .5122E-07 + .4444E-07 + .3856E-07 + .3359E-07 + .3065E-07 + .2797E-07 + .2503E-07 + .2199E-07 + .1931E-07 + .1838E-07 + .1568E-05 + .1680E-05 + .1784E-05 + .1894E-05 + .2011E-05 + .2137E-05 + .2276E-05 + .2424E-05 + .2583E-05 + .2774E-05 + .2990E-05 + .3223E-05 + .3486E-05 + .3779E-05 + .4097E-05 + .4453E-05 + .4837E-05 + .5197E-05 + .5361E-05 + .5531E-05 + .5690E-05 + .5839E-05 + .5945E-05 + .5869E-05 + .5787E-05 + .5699E-05 + .5613E-05 + .5528E-05 + .5444E-05 + .5349E-05 + .5243E-05 + .5023E-05 + .4740E-05 + .4473E-05 + .4201E-05 + .3779E-05 + .3324E-05 + .2830E-05 + .2393E-05 + .1986E-05 + .1583E-05 + .1307E-05 + .1079E-05 + .8908E-06 + .6339E-06 + .4510E-06 + .2863E-06 + .1463E-06 + .7476E-07 + .5468E-07 + .4741E-07 + .4111E-07 + .3579E-07 + .3262E-07 + .2974E-07 + .2656E-07 + .2328E-07 + .2040E-07 + .1940E-07 + .1611E-05 + .1727E-05 + .1830E-05 + .1938E-05 + .2053E-05 + .2178E-05 + .2327E-05 + .2485E-05 + .2654E-05 + .2857E-05 + .3085E-05 + .3331E-05 + .3621E-05 + .3944E-05 + .4296E-05 + .4688E-05 + .5116E-05 + .5456E-05 + .5619E-05 + .5786E-05 + .5958E-05 + .6136E-05 + .6281E-05 + .6281E-05 + .6186E-05 + .6070E-05 + .5956E-05 + .5844E-05 + .5734E-05 + .5626E-05 + .5520E-05 + .5323E-05 + .5074E-05 + .4773E-05 + .4451E-05 + .4011E-05 + .3511E-05 + .2993E-05 + .2523E-05 + .2103E-05 + .1666E-05 + .1326E-05 + .1056E-05 + .8409E-06 + .6016E-06 + .4356E-06 + .2825E-06 + .1485E-06 + .7801E-07 + .5755E-07 + .4987E-07 + .4322E-07 + .3760E-07 + .3423E-07 + .3117E-07 + .2779E-07 + .2430E-07 + .2125E-07 + .2019E-07 + .1631E-05 + .1749E-05 + .1849E-05 + .1954E-05 + .2065E-05 + .2185E-05 + .2342E-05 + .2509E-05 + .2689E-05 + .2899E-05 + .3130E-05 + .3380E-05 + .3691E-05 + .4042E-05 + .4427E-05 + .4850E-05 + .5314E-05 + .5576E-05 + .5759E-05 + .5947E-05 + .6143E-05 + .6344E-05 + .6546E-05 + .6727E-05 + .6635E-05 + .6477E-05 + .6324E-05 + .6174E-05 + .6028E-05 + .5885E-05 + .5745E-05 + .5592E-05 + .5433E-05 + .5093E-05 + .4663E-05 + .4226E-05 + .3666E-05 + .3131E-05 + .2640E-05 + .2222E-05 + .1752E-05 + .1339E-05 + .1024E-05 + .7824E-06 + .5627E-06 + .4148E-06 + .2748E-06 + .1485E-06 + .8023E-07 + .5970E-07 + .5170E-07 + .4478E-07 + .3894E-07 + .3541E-07 + .3220E-07 + .2866E-07 + .2501E-07 + .2182E-07 + .2071E-07 + .1589E-05 + .1688E-05 + .1792E-05 + .1897E-05 + .2009E-05 + .2133E-05 + .2277E-05 + .2437E-05 + .2613E-05 + .2788E-05 + .3030E-05 + .3285E-05 + .3583E-05 + .3925E-05 + .4316E-05 + .4771E-05 + .5257E-05 + .5717E-05 + .6108E-05 + .6429E-05 + .6647E-05 + .6801E-05 + .6884E-05 + .6924E-05 + .6899E-05 + .6803E-05 + .6721E-05 + .6665E-05 + .6518E-05 + .6381E-05 + .6249E-05 + .5993E-05 + .5653E-05 + .5245E-05 + .4743E-05 + .4293E-05 + .3789E-05 + .3309E-05 + .2782E-05 + .2258E-05 + .1748E-05 + .1293E-05 + .9570E-06 + .7082E-06 + .5120E-06 + .3842E-06 + .2600E-06 + .1445E-06 + .8028E-07 + .6025E-07 + .5215E-07 + .4514E-07 + .3922E-07 + .3563E-07 + .3236E-07 + .2876E-07 + .2503E-07 + .2179E-07 + .2066E-07 + .1626E-05 + .1722E-05 + .1824E-05 + .1931E-05 + .2049E-05 + .2182E-05 + .2329E-05 + .2506E-05 + .2670E-05 + .2871E-05 + .3089E-05 + .3374E-05 + .3675E-05 + .4037E-05 + .4453E-05 + .4933E-05 + .5427E-05 + .5962E-05 + .6413E-05 + .6781E-05 + .7014E-05 + .7158E-05 + .7226E-05 + .7224E-05 + .7187E-05 + .7107E-05 + .7033E-05 + .6966E-05 + .6818E-05 + .6660E-05 + .6513E-05 + .6179E-05 + .5809E-05 + .5356E-05 + .4826E-05 + .4344E-05 + .3842E-05 + .3344E-05 + .2823E-05 + .2293E-05 + .1770E-05 + .1271E-05 + .9124E-06 + .6551E-06 + .4762E-06 + .3637E-06 + .2514E-06 + .1437E-06 + .8209E-07 + .6214E-07 + .5376E-07 + .4651E-07 + .4038E-07 + .3664E-07 + .3324E-07 + .2949E-07 + .2561E-07 + .2224E-07 + .2107E-07 + .1654E-05 + .1748E-05 + .1846E-05 + .1955E-05 + .2078E-05 + .2218E-05 + .2370E-05 + .2562E-05 + .2714E-05 + .2945E-05 + .3138E-05 + .3448E-05 + .3750E-05 + .4133E-05 + .4571E-05 + .5067E-05 + .5566E-05 + .6145E-05 + .6630E-05 + .7026E-05 + .7276E-05 + .7415E-05 + .7487E-05 + .7467E-05 + .7408E-05 + .7335E-05 + .7257E-05 + .7162E-05 + .7015E-05 + .6825E-05 + .6658E-05 + .6260E-05 + .5886E-05 + .5396E-05 + .4849E-05 + .4338E-05 + .3834E-05 + .3313E-05 + .2805E-05 + .2285E-05 + .1760E-05 + .1230E-05 + .8598E-06 + .6010E-06 + .4392E-06 + .3414E-06 + .2411E-06 + .1417E-06 + .8326E-07 + .6357E-07 + .5496E-07 + .4752E-07 + .4124E-07 + .3737E-07 + .3387E-07 + .2999E-07 + .2598E-07 + .2252E-07 + .2132E-07 + .1680E-05 + .1778E-05 + .1880E-05 + .1993E-05 + .2120E-05 + .2262E-05 + .2416E-05 + .2607E-05 + .2770E-05 + .3002E-05 + .3230E-05 + .3532E-05 + .3831E-05 + .4222E-05 + .4680E-05 + .5170E-05 + .5705E-05 + .6306E-05 + .6835E-05 + .7254E-05 + .7557E-05 + .7697E-05 + .7779E-05 + .7773E-05 + .7707E-05 + .7618E-05 + .7540E-05 + .7418E-05 + .7276E-05 + .7000E-05 + .6780E-05 + .6361E-05 + .5925E-05 + .5410E-05 + .4835E-05 + .4300E-05 + .3792E-05 + .3246E-05 + .2701E-05 + .2154E-05 + .1628E-05 + .1139E-05 + .7968E-06 + .5574E-06 + .4095E-06 + .3240E-06 + .2337E-06 + .1412E-06 + .8535E-07 + .6573E-07 + .5680E-07 + .4908E-07 + .4257E-07 + .3853E-07 + .3488E-07 + .3083E-07 + .2665E-07 + .2304E-07 + .2180E-07 + .1689E-05 + .1791E-05 + .1896E-05 + .2014E-05 + .2143E-05 + .2287E-05 + .2441E-05 + .2633E-05 + .2794E-05 + .3038E-05 + .3285E-05 + .3584E-05 + .3880E-05 + .4272E-05 + .4739E-05 + .5238E-05 + .5797E-05 + .6417E-05 + .6981E-05 + .7433E-05 + .7785E-05 + .7936E-05 + .8029E-05 + .8036E-05 + .7969E-05 + .7868E-05 + .7787E-05 + .7643E-05 + .7493E-05 + .7145E-05 + .6858E-05 + .6414E-05 + .5912E-05 + .5363E-05 + .4771E-05 + .4221E-05 + .3708E-05 + .3148E-05 + .2575E-05 + .2012E-05 + .1494E-05 + .1046E-05 + .7328E-06 + .5132E-06 + .3790E-06 + .3053E-06 + .2249E-06 + .1398E-06 + .8686E-07 + .6747E-07 + .5827E-07 + .5032E-07 + .4362E-07 + .3943E-07 + .3565E-07 + .3146E-07 + .2714E-07 + .2341E-07 + .2212E-07 + .1683E-05 + .1789E-05 + .1897E-05 + .2020E-05 + .2150E-05 + .2296E-05 + .2447E-05 + .2646E-05 + .2783E-05 + .3063E-05 + .3295E-05 + .3608E-05 + .3902E-05 + .4283E-05 + .4745E-05 + .5288E-05 + .5852E-05 + .6494E-05 + .7073E-05 + .7586E-05 + .7976E-05 + .8165E-05 + .8269E-05 + .8286E-05 + .8227E-05 + .8125E-05 + .8034E-05 + .7879E-05 + .7696E-05 + .7306E-05 + .6919E-05 + .6441E-05 + .5859E-05 + .5253E-05 + .4661E-05 + .4104E-05 + .3583E-05 + .3021E-05 + .2433E-05 + .1869E-05 + .1365E-05 + .9571E-06 + .6712E-06 + .4708E-06 + .3495E-06 + .2866E-06 + .2157E-06 + .1378E-06 + .8808E-07 + .6901E-07 + .5956E-07 + .5141E-07 + .4453E-07 + .4021E-07 + .3632E-07 + .3199E-07 + .2753E-07 + .2369E-07 + .2237E-07 + .1648E-05 + .1758E-05 + .1871E-05 + .1997E-05 + .2128E-05 + .2275E-05 + .2427E-05 + .2627E-05 + .2770E-05 + .3053E-05 + .3284E-05 + .3594E-05 + .3890E-05 + .4269E-05 + .4725E-05 + .5260E-05 + .5822E-05 + .6458E-05 + .7061E-05 + .7625E-05 + .8030E-05 + .8276E-05 + .8403E-05 + .8434E-05 + .8393E-05 + .8288E-05 + .8181E-05 + .8009E-05 + .7764E-05 + .7364E-05 + .6932E-05 + .6412E-05 + .5811E-05 + .5182E-05 + .4587E-05 + .4017E-05 + .3471E-05 + .2898E-05 + .2300E-05 + .1738E-05 + .1244E-05 + .8735E-06 + .6131E-06 + .4304E-06 + .3212E-06 + .2681E-06 + .2061E-06 + .1354E-06 + .8901E-07 + .7034E-07 + .6068E-07 + .5234E-07 + .4531E-07 + .4087E-07 + .3686E-07 + .3241E-07 + .2783E-07 + .2390E-07 + .2255E-07 + .1593E-05 + .1706E-05 + .1824E-05 + .1953E-05 + .2085E-05 + .2232E-05 + .2391E-05 + .2586E-05 + .2763E-05 + .3016E-05 + .3263E-05 + .3554E-05 + .3856E-05 + .4241E-05 + .4691E-05 + .5175E-05 + .5729E-05 + .6335E-05 + .6969E-05 + .7575E-05 + .7976E-05 + .8294E-05 + .8457E-05 + .8504E-05 + .8490E-05 + .8379E-05 + .8250E-05 + .8056E-05 + .7724E-05 + .7344E-05 + .6917E-05 + .6349E-05 + .5781E-05 + .5157E-05 + .4554E-05 + .3965E-05 + .3381E-05 + .2784E-05 + .2181E-05 + .1623E-05 + .1136E-05 + .7974E-06 + .5599E-06 + .3931E-06 + .2949E-06 + .2506E-06 + .1968E-06 + .1330E-06 + .8988E-07 + .7164E-07 + .6176E-07 + .5324E-07 + .4606E-07 + .4150E-07 + .3739E-07 + .3282E-07 + .2812E-07 + .2409E-07 + .2271E-07 + .1599E-05 + .1709E-05 + .1824E-05 + .1947E-05 + .2078E-05 + .2224E-05 + .2384E-05 + .2575E-05 + .2761E-05 + .3008E-05 + .3243E-05 + .3529E-05 + .3837E-05 + .4222E-05 + .4657E-05 + .5129E-05 + .5707E-05 + .6322E-05 + .6969E-05 + .7585E-05 + .8041E-05 + .8377E-05 + .8575E-05 + .8671E-05 + .8671E-05 + .8569E-05 + .8431E-05 + .8209E-05 + .7899E-05 + .7463E-05 + .6996E-05 + .6390E-05 + .5789E-05 + .5140E-05 + .4509E-05 + .3906E-05 + .3290E-05 + .2656E-05 + .2036E-05 + .1489E-05 + .1029E-05 + .7189E-06 + .5025E-06 + .3512E-06 + .2647E-06 + .2284E-06 + .1831E-06 + .1274E-06 + .8865E-07 + .7155E-07 + .6196E-07 + .5366E-07 + .4662E-07 + .4202E-07 + .3788E-07 + .3306E-07 + .2808E-07 + .2396E-07 + .2253E-07 + .1638E-05 + .1743E-05 + .1852E-05 + .1969E-05 + .2097E-05 + .2242E-05 + .2402E-05 + .2593E-05 + .2779E-05 + .3032E-05 + .3245E-05 + .3533E-05 + .3849E-05 + .4232E-05 + .4653E-05 + .5130E-05 + .5748E-05 + .6391E-05 + .7048E-05 + .7667E-05 + .8205E-05 + .8542E-05 + .8776E-05 + .8935E-05 + .8945E-05 + .8857E-05 + .8716E-05 + .8460E-05 + .8215E-05 + .7688E-05 + .7158E-05 + .6513E-05 + .5848E-05 + .5160E-05 + .4489E-05 + .3869E-05 + .3220E-05 + .2545E-05 + .1903E-05 + .1366E-05 + .9349E-06 + .6373E-06 + .4344E-06 + .2962E-06 + .2235E-06 + .1951E-06 + .1593E-06 + .1144E-06 + .8222E-07 + .6785E-07 + .5979E-07 + .5270E-07 + .4654E-07 + .4217E-07 + .3820E-07 + .3281E-07 + .2720E-07 + .2298E-07 + .2151E-07 + .1630E-05 + .1735E-05 + .1847E-05 + .1970E-05 + .2104E-05 + .2255E-05 + .2421E-05 + .2614E-05 + .2813E-05 + .3068E-05 + .3308E-05 + .3570E-05 + .3882E-05 + .4249E-05 + .4678E-05 + .5183E-05 + .5779E-05 + .6395E-05 + .7062E-05 + .7719E-05 + .8277E-05 + .8698E-05 + .8969E-05 + .9140E-05 + .9192E-05 + .9105E-05 + .8989E-05 + .8705E-05 + .8410E-05 + .7912E-05 + .7318E-05 + .6630E-05 + .5920E-05 + .5194E-05 + .4505E-05 + .3841E-05 + .3147E-05 + .2440E-05 + .1789E-05 + .1227E-05 + .8102E-06 + .5481E-06 + .3708E-06 + .2509E-06 + .1896E-06 + .1674E-06 + .1392E-06 + .1033E-06 + .7661E-07 + .6463E-07 + .5797E-07 + .5199E-07 + .4669E-07 + .4251E-07 + .3871E-07 + .3272E-07 + .2646E-07 + .2215E-07 + .2062E-07 + .1617E-05 + .1725E-05 + .1840E-05 + .1968E-05 + .2107E-05 + .2261E-05 + .2432E-05 + .2626E-05 + .2838E-05 + .3089E-05 + .3355E-05 + .3597E-05 + .3903E-05 + .4256E-05 + .4690E-05 + .5220E-05 + .5794E-05 + .6386E-05 + .7058E-05 + .7745E-05 + .8311E-05 + .8811E-05 + .9120E-05 + .9304E-05 + .9397E-05 + .9318E-05 + .9236E-05 + .8930E-05 + .8582E-05 + .8109E-05 + .7458E-05 + .6727E-05 + .5970E-05 + .5208E-05 + .4502E-05 + .3794E-05 + .3060E-05 + .2330E-05 + .1672E-05 + .1098E-05 + .6974E-06 + .4687E-06 + .3150E-06 + .2117E-06 + .1602E-06 + .1430E-06 + .1211E-06 + .9280E-07 + .7109E-07 + .6133E-07 + .5598E-07 + .5109E-07 + .4665E-07 + .4269E-07 + .3906E-07 + .3250E-07 + .2564E-07 + .2127E-07 + .1969E-07 + .1637E-05 + .1754E-05 + .1872E-05 + .1994E-05 + .2130E-05 + .2280E-05 + .2452E-05 + .2640E-05 + .2859E-05 + .3080E-05 + .3344E-05 + .3617E-05 + .3930E-05 + .4295E-05 + .4718E-05 + .5242E-05 + .5836E-05 + .6456E-05 + .7131E-05 + .7790E-05 + .8330E-05 + .8844E-05 + .9196E-05 + .9424E-05 + .9538E-05 + .9506E-05 + .9479E-05 + .9194E-05 + .8824E-05 + .8280E-05 + .7628E-05 + .6838E-05 + .6009E-05 + .5213E-05 + .4463E-05 + .3714E-05 + .2952E-05 + .2212E-05 + .1540E-05 + .9820E-06 + .6000E-06 + .4000E-06 + .2666E-06 + .1778E-06 + .1347E-06 + .1217E-06 + .1050E-06 + .8303E-07 + .6567E-07 + .5793E-07 + .5381E-07 + .4998E-07 + .4639E-07 + .4266E-07 + .3924E-07 + .3213E-07 + .2474E-07 + .2032E-07 + .1872E-07 + .1643E-05 + .1768E-05 + .1890E-05 + .2010E-05 + .2145E-05 + .2294E-05 + .2467E-05 + .2655E-05 + .2873E-05 + .3080E-05 + .3336E-05 + .3636E-05 + .3945E-05 + .4328E-05 + .4752E-05 + .5276E-05 + .5883E-05 + .6516E-05 + .7190E-05 + .7827E-05 + .8362E-05 + .8884E-05 + .9263E-05 + .9544E-05 + .9678E-05 + .9705E-05 + .9721E-05 + .9479E-05 + .9088E-05 + .8485E-05 + .7797E-05 + .6949E-05 + .6054E-05 + .5220E-05 + .4418E-05 + .3624E-05 + .2831E-05 + .2083E-05 + .1414E-05 + .8745E-06 + .5109E-06 + .3389E-06 + .2248E-06 + .1491E-06 + .1132E-06 + .1034E-06 + .9084E-07 + .7419E-07 + .6060E-07 + .5465E-07 + .5166E-07 + .4884E-07 + .4608E-07 + .4259E-07 + .3937E-07 + .3173E-07 + .2384E-07 + .1940E-07 + .1777E-07 + .1622E-05 + .1754E-05 + .1883E-05 + .2007E-05 + .2143E-05 + .2296E-05 + .2469E-05 + .2668E-05 + .2871E-05 + .3094E-05 + .3328E-05 + .3649E-05 + .3937E-05 + .4343E-05 + .4795E-05 + .5328E-05 + .5938E-05 + .6553E-05 + .7217E-05 + .7846E-05 + .8410E-05 + .8930E-05 + .9309E-05 + .9659E-05 + .9810E-05 + .9916E-05 + .9953E-05 + .9793E-05 + .9385E-05 + .8745E-05 + .7958E-05 + .7053E-05 + .6107E-05 + .5227E-05 + .4362E-05 + .3512E-05 + .2685E-05 + .1933E-05 + .1290E-05 + .7719E-06 + .4266E-06 + .2832E-06 + .1879E-06 + .1248E-06 + .9482E-07 + .8758E-07 + .7841E-07 + .6613E-07 + .5577E-07 + .5142E-07 + .4947E-07 + .4759E-07 + .4566E-07 + .4241E-07 + .3940E-07 + .3125E-07 + .2291E-07 + .1847E-07 + .1683E-07 + .1628E-05 + .1759E-05 + .1888E-05 + .2010E-05 + .2143E-05 + .2296E-05 + .2465E-05 + .2668E-05 + .2857E-05 + .3097E-05 + .3316E-05 + .3631E-05 + .3929E-05 + .4345E-05 + .4807E-05 + .5335E-05 + .5958E-05 + .6569E-05 + .7232E-05 + .7855E-05 + .8426E-05 + .8951E-05 + .9351E-05 + .9749E-05 + .9950E-05 + .1012E-04 + .1018E-04 + .1007E-04 + .9680E-05 + .9013E-05 + .8141E-05 + .7158E-05 + .6142E-05 + .5185E-05 + .4266E-05 + .3380E-05 + .2546E-05 + .1806E-05 + .1188E-05 + .6820E-06 + .3602E-06 + .2385E-06 + .1580E-06 + .1046E-06 + .7962E-07 + .7438E-07 + .6782E-07 + .5906E-07 + .5143E-07 + .4849E-07 + .4747E-07 + .4648E-07 + .4533E-07 + .4232E-07 + .3951E-07 + .3085E-07 + .2206E-07 + .1762E-07 + .1597E-07 + .1650E-05 + .1777E-05 + .1898E-05 + .2015E-05 + .2142E-05 + .2290E-05 + .2453E-05 + .2653E-05 + .2831E-05 + .3085E-05 + .3295E-05 + .3582E-05 + .3914E-05 + .4328E-05 + .4786E-05 + .5299E-05 + .5940E-05 + .6559E-05 + .7227E-05 + .7844E-05 + .8404E-05 + .8937E-05 + .9374E-05 + .9801E-05 + .1008E-04 + .1030E-04 + .1040E-04 + .1031E-04 + .9958E-05 + .9272E-05 + .8330E-05 + .7253E-05 + .6153E-05 + .5098E-05 + .4134E-05 + .3230E-05 + .2409E-05 + .1695E-05 + .1100E-05 + .6022E-06 + .3064E-06 + .2019E-06 + .1331E-06 + .8770E-07 + .6685E-07 + .6316E-07 + .5867E-07 + .5275E-07 + .4743E-07 + .4572E-07 + .4556E-07 + .4539E-07 + .4501E-07 + .4223E-07 + .3963E-07 + .3045E-07 + .2125E-07 + .1681E-07 + .1515E-07 + .1645E-05 + .1768E-05 + .1891E-05 + .2007E-05 + .2134E-05 + .2281E-05 + .2441E-05 + .2642E-05 + .2810E-05 + .3101E-05 + .3334E-05 + .3579E-05 + .3916E-05 + .4310E-05 + .4791E-05 + .5323E-05 + .5944E-05 + .6541E-05 + .7200E-05 + .7815E-05 + .8378E-05 + .8911E-05 + .9355E-05 + .9768E-05 + .1012E-04 + .1038E-04 + .1054E-04 + .1048E-04 + .1009E-04 + .9378E-05 + .8425E-05 + .7285E-05 + .6129E-05 + .5028E-05 + .4026E-05 + .3122E-05 + .2317E-05 + .1612E-05 + .1022E-05 + .5454E-06 + .2670E-06 + .1736E-06 + .1129E-06 + .7345E-07 + .5607E-07 + .5358E-07 + .5069E-07 + .4706E-07 + .4370E-07 + .4307E-07 + .4367E-07 + .4428E-07 + .4464E-07 + .4209E-07 + .3970E-07 + .3002E-07 + .2044E-07 + .1602E-07 + .1436E-07 + .1629E-05 + .1751E-05 + .1877E-05 + .1995E-05 + .2124E-05 + .2268E-05 + .2428E-05 + .2629E-05 + .2787E-05 + .3124E-05 + .3388E-05 + .3585E-05 + .3921E-05 + .4287E-05 + .4800E-05 + .5361E-05 + .5950E-05 + .6515E-05 + .7162E-05 + .7775E-05 + .8345E-05 + .8874E-05 + .9315E-05 + .9700E-05 + .1013E-04 + .1042E-04 + .1066E-04 + .1061E-04 + .1016E-04 + .9430E-05 + .8485E-05 + .7292E-05 + .6089E-05 + .4959E-05 + .3923E-05 + .3025E-05 + .2236E-05 + .1537E-05 + .9494E-06 + .4973E-06 + .2341E-06 + .1563E-06 + .1044E-06 + .6968E-07 + .5367E-07 + .5066E-07 + .4776E-07 + .4488E-07 + .4218E-07 + .4165E-07 + .4210E-07 + .4256E-07 + .4279E-07 + .4035E-07 + .3805E-07 + .2961E-07 + .2067E-07 + .1597E-07 + .1428E-07 + .1609E-05 + .1728E-05 + .1851E-05 + .1965E-05 + .2093E-05 + .2240E-05 + .2407E-05 + .2606E-05 + .2791E-05 + .3084E-05 + .3318E-05 + .3580E-05 + .3920E-05 + .4304E-05 + .4792E-05 + .5273E-05 + .5865E-05 + .6438E-05 + .7098E-05 + .7728E-05 + .8281E-05 + .8801E-05 + .9250E-05 + .9588E-05 + .9931E-05 + .1018E-04 + .1057E-04 + .1058E-04 + .1017E-04 + .9472E-05 + .8520E-05 + .7339E-05 + .6103E-05 + .4922E-05 + .3849E-05 + .2949E-05 + .2168E-05 + .1485E-05 + .9073E-06 + .4738E-06 + .2206E-06 + .1483E-06 + .9975E-07 + .6709E-07 + .5219E-07 + .4852E-07 + .4541E-07 + .4308E-07 + .4086E-07 + .4031E-07 + .4051E-07 + .4071E-07 + .4070E-07 + .3835E-07 + .3613E-07 + .2913E-07 + .2100E-07 + .1598E-07 + .1424E-07 + .1591E-05 + .1708E-05 + .1827E-05 + .1938E-05 + .2065E-05 + .2214E-05 + .2389E-05 + .2586E-05 + .2795E-05 + .3053E-05 + .3266E-05 + .3576E-05 + .3918E-05 + .4316E-05 + .4776E-05 + .5194E-05 + .5777E-05 + .6354E-05 + .7028E-05 + .7668E-05 + .8208E-05 + .8721E-05 + .9171E-05 + .9481E-05 + .9751E-05 + .9968E-05 + .1046E-04 + .1055E-04 + .1017E-04 + .9498E-05 + .8541E-05 + .7376E-05 + .6111E-05 + .4895E-05 + .3787E-05 + .2879E-05 + .2110E-05 + .1445E-05 + .8769E-06 + .4549E-06 + .2102E-06 + .1419E-06 + .9576E-07 + .6464E-07 + .5079E-07 + .4649E-07 + .4322E-07 + .4138E-07 + .3962E-07 + .3904E-07 + .3900E-07 + .3896E-07 + .3874E-07 + .3647E-07 + .3434E-07 + .2867E-07 + .2135E-07 + .1600E-07 + .1422E-07 + .1574E-05 + .1694E-05 + .1811E-05 + .1919E-05 + .2046E-05 + .2197E-05 + .2373E-05 + .2577E-05 + .2792E-05 + .3058E-05 + .3291E-05 + .3574E-05 + .3902E-05 + .4295E-05 + .4711E-05 + .5147E-05 + .5665E-05 + .6225E-05 + .6918E-05 + .7530E-05 + .8078E-05 + .8589E-05 + .9014E-05 + .9375E-05 + .9617E-05 + .9881E-05 + .1031E-04 + .1054E-04 + .1009E-04 + .9431E-05 + .8477E-05 + .7342E-05 + .6075E-05 + .4889E-05 + .3759E-05 + .2821E-05 + .2080E-05 + .1442E-05 + .8852E-06 + .4488E-06 + .2087E-06 + .1395E-06 + .9325E-07 + .6233E-07 + .4947E-07 + .4459E-07 + .4116E-07 + .3978E-07 + .3844E-07 + .3784E-07 + .3758E-07 + .3732E-07 + .3690E-07 + .3472E-07 + .3266E-07 + .2824E-07 + .2172E-07 + .1603E-07 + .1421E-07 + .1562E-05 + .1685E-05 + .1802E-05 + .1910E-05 + .2037E-05 + .2190E-05 + .2368E-05 + .2575E-05 + .2791E-05 + .3057E-05 + .3311E-05 + .3572E-05 + .3893E-05 + .4277E-05 + .4666E-05 + .5116E-05 + .5589E-05 + .6149E-05 + .6833E-05 + .7436E-05 + .7979E-05 + .8497E-05 + .8915E-05 + .9289E-05 + .9528E-05 + .9801E-05 + .1019E-04 + .1052E-04 + .1004E-04 + .9370E-05 + .8427E-05 + .7317E-05 + .6057E-05 + .4884E-05 + .3735E-05 + .2787E-05 + .2064E-05 + .1439E-05 + .8867E-06 + .4468E-06 + .2039E-06 + .1358E-06 + .9045E-07 + .6024E-07 + .4829E-07 + .4286E-07 + .3930E-07 + .3833E-07 + .3739E-07 + .3676E-07 + .3629E-07 + .3583E-07 + .3523E-07 + .3312E-07 + .3114E-07 + .2789E-07 + .2214E-07 + .1610E-07 + .1423E-07 + .1554E-05 + .1679E-05 + .1797E-05 + .1910E-05 + .2039E-05 + .2193E-05 + .2370E-05 + .2576E-05 + .2786E-05 + .3041E-05 + .3316E-05 + .3563E-05 + .3886E-05 + .4252E-05 + .4640E-05 + .5094E-05 + .5549E-05 + .6132E-05 + .6766E-05 + .7386E-05 + .7904E-05 + .8444E-05 + .8876E-05 + .9208E-05 + .9479E-05 + .9702E-05 + .1007E-04 + .1046E-04 + .9993E-05 + .9289E-05 + .8375E-05 + .7284E-05 + .6049E-05 + .4869E-05 + .3708E-05 + .2782E-05 + .2066E-05 + .1431E-05 + .8756E-06 + .4500E-06 + .1938E-06 + .1320E-06 + .8987E-07 + .6120E-07 + .4900E-07 + .4290E-07 + .3902E-07 + .3818E-07 + .3737E-07 + .3672E-07 + .3616E-07 + .3561E-07 + .3494E-07 + .3285E-07 + .3088E-07 + .2813E-07 + .2279E-07 + .1661E-07 + .1468E-07 + .1543E-05 + .1669E-05 + .1792E-05 + .1909E-05 + .2041E-05 + .2194E-05 + .2369E-05 + .2568E-05 + .2775E-05 + .3013E-05 + .3294E-05 + .3553E-05 + .3872E-05 + .4228E-05 + .4615E-05 + .5083E-05 + .5541E-05 + .6114E-05 + .6718E-05 + .7337E-05 + .7839E-05 + .8359E-05 + .8803E-05 + .9130E-05 + .9431E-05 + .9661E-05 + .1001E-04 + .1028E-04 + .9825E-05 + .9156E-05 + .8299E-05 + .7230E-05 + .6029E-05 + .4850E-05 + .3714E-05 + .2806E-05 + .2074E-05 + .1433E-05 + .8811E-06 + .4462E-06 + .1924E-06 + .1341E-06 + .9351E-07 + .6520E-07 + .5157E-07 + .4459E-07 + .4020E-07 + .3924E-07 + .3830E-07 + .3763E-07 + .3709E-07 + .3656E-07 + .3590E-07 + .3379E-07 + .3180E-07 + .2894E-07 + .2362E-07 + .1757E-07 + .1556E-07 + .1537E-05 + .1662E-05 + .1791E-05 + .1911E-05 + .2048E-05 + .2200E-05 + .2371E-05 + .2562E-05 + .2767E-05 + .2986E-05 + .3264E-05 + .3553E-05 + .3864E-05 + .4216E-05 + .4604E-05 + .5092E-05 + .5569E-05 + .6112E-05 + .6702E-05 + .7310E-05 + .7803E-05 + .8279E-05 + .8734E-05 + .9079E-05 + .9411E-05 + .9686E-05 + .1002E-04 + .1005E-04 + .9611E-05 + .9016E-05 + .8233E-05 + .7184E-05 + .6017E-05 + .4843E-05 + .3751E-05 + .2858E-05 + .2092E-05 + .1446E-05 + .9002E-06 + .4394E-06 + .1969E-06 + .1392E-06 + .9843E-07 + .6959E-07 + .5437E-07 + .4645E-07 + .4150E-07 + .4040E-07 + .3933E-07 + .3864E-07 + .3812E-07 + .3761E-07 + .3697E-07 + .3483E-07 + .3281E-07 + .2982E-07 + .2452E-07 + .1862E-07 + .1653E-07 + .1533E-05 + .1660E-05 + .1792E-05 + .1914E-05 + .2049E-05 + .2201E-05 + .2370E-05 + .2563E-05 + .2765E-05 + .2993E-05 + .3273E-05 + .3550E-05 + .3867E-05 + .4232E-05 + .4649E-05 + .5152E-05 + .5677E-05 + .6190E-05 + .6753E-05 + .7302E-05 + .7766E-05 + .8168E-05 + .8594E-05 + .8946E-05 + .9273E-05 + .9592E-05 + .9857E-05 + .9843E-05 + .9448E-05 + .8903E-05 + .8138E-05 + .7112E-05 + .5966E-05 + .4815E-05 + .3762E-05 + .2872E-05 + .2101E-05 + .1453E-05 + .9159E-06 + .4587E-06 + .2106E-06 + .1489E-06 + .1052E-06 + .7436E-07 + .5738E-07 + .4843E-07 + .4289E-07 + .4164E-07 + .4043E-07 + .3971E-07 + .3922E-07 + .3873E-07 + .3811E-07 + .3593E-07 + .3388E-07 + .3076E-07 + .2549E-07 + .1975E-07 + .1757E-07 + .1529E-05 + .1658E-05 + .1791E-05 + .1914E-05 + .2046E-05 + .2197E-05 + .2366E-05 + .2562E-05 + .2760E-05 + .3004E-05 + .3287E-05 + .3542E-05 + .3868E-05 + .4249E-05 + .4703E-05 + .5219E-05 + .5797E-05 + .6280E-05 + .6814E-05 + .7291E-05 + .7720E-05 + .8043E-05 + .8432E-05 + .8787E-05 + .9102E-05 + .9459E-05 + .9643E-05 + .9637E-05 + .9284E-05 + .8784E-05 + .8026E-05 + .7024E-05 + .5898E-05 + .4777E-05 + .3761E-05 + .2875E-05 + .2105E-05 + .1457E-05 + .9302E-06 + .4852E-06 + .2276E-06 + .1602E-06 + .1128E-06 + .7937E-07 + .6050E-07 + .5044E-07 + .4428E-07 + .4288E-07 + .4152E-07 + .4077E-07 + .4030E-07 + .3984E-07 + .3924E-07 + .3704E-07 + .3496E-07 + .3170E-07 + .2647E-07 + .2093E-07 + .1866E-07 + .1521E-05 + .1651E-05 + .1785E-05 + .1910E-05 + .2043E-05 + .2195E-05 + .2363E-05 + .2555E-05 + .2758E-05 + .2993E-05 + .3281E-05 + .3558E-05 + .3896E-05 + .4308E-05 + .4784E-05 + .5319E-05 + .5894E-05 + .6432E-05 + .6932E-05 + .7385E-05 + .7738E-05 + .8043E-05 + .8392E-05 + .8712E-05 + .9001E-05 + .9246E-05 + .9369E-05 + .9345E-05 + .9016E-05 + .8576E-05 + .7850E-05 + .6907E-05 + .5842E-05 + .4766E-05 + .3761E-05 + .2882E-05 + .2120E-05 + .1483E-05 + .9619E-06 + .5267E-06 + .2561E-06 + .1771E-06 + .1225E-06 + .8478E-07 + .6383E-07 + .5257E-07 + .4574E-07 + .4418E-07 + .4267E-07 + .4189E-07 + .4145E-07 + .4101E-07 + .4043E-07 + .3820E-07 + .3609E-07 + .3269E-07 + .2750E-07 + .2220E-07 + .1983E-07 + .1516E-05 + .1650E-05 + .1786E-05 + .1914E-05 + .2048E-05 + .2199E-05 + .2367E-05 + .2557E-05 + .2761E-05 + .2999E-05 + .3293E-05 + .3596E-05 + .3946E-05 + .4386E-05 + .4880E-05 + .5433E-05 + .6007E-05 + .6577E-05 + .7049E-05 + .7475E-05 + .7766E-05 + .8050E-05 + .8356E-05 + .8639E-05 + .8902E-05 + .9057E-05 + .9121E-05 + .9102E-05 + .8782E-05 + .8386E-05 + .7694E-05 + .6809E-05 + .5802E-05 + .4767E-05 + .3776E-05 + .2900E-05 + .2143E-05 + .1518E-05 + .9997E-06 + .5725E-06 + .2887E-06 + .1963E-06 + .1335E-06 + .9077E-07 + .6750E-07 + .5493E-07 + .4737E-07 + .4563E-07 + .4395E-07 + .4314E-07 + .4273E-07 + .4232E-07 + .4176E-07 + .3949E-07 + .3735E-07 + .3379E-07 + .2864E-07 + .2360E-07 + .2112E-07 + .1512E-05 + .1655E-05 + .1800E-05 + .1933E-05 + .2067E-05 + .2216E-05 + .2381E-05 + .2577E-05 + .2765E-05 + .3043E-05 + .3340E-05 + .3683E-05 + .4047E-05 + .4496E-05 + .4991E-05 + .5559E-05 + .6128E-05 + .6650E-05 + .7115E-05 + .7499E-05 + .7775E-05 + .8033E-05 + .8279E-05 + .8512E-05 + .8751E-05 + .8884E-05 + .8884E-05 + .8940E-05 + .8586E-05 + .8192E-05 + .7549E-05 + .6727E-05 + .5774E-05 + .4780E-05 + .3816E-05 + .2937E-05 + .2182E-05 + .1573E-05 + .1050E-05 + .6208E-06 + .3257E-06 + .2178E-06 + .1456E-06 + .9738E-07 + .7153E-07 + .5750E-07 + .4915E-07 + .4722E-07 + .4536E-07 + .4452E-07 + .4413E-07 + .4375E-07 + .4322E-07 + .4091E-07 + .3873E-07 + .3499E-07 + .2989E-07 + .2513E-07 + .2254E-07 + .1515E-05 + .1665E-05 + .1815E-05 + .1953E-05 + .2087E-05 + .2237E-05 + .2403E-05 + .2605E-05 + .2790E-05 + .3092E-05 + .3391E-05 + .3756E-05 + .4137E-05 + .4607E-05 + .5119E-05 + .5688E-05 + .6255E-05 + .6748E-05 + .7196E-05 + .7548E-05 + .7804E-05 + .8023E-05 + .8221E-05 + .8413E-05 + .8609E-05 + .8709E-05 + .8676E-05 + .8732E-05 + .8378E-05 + .7997E-05 + .7402E-05 + .6649E-05 + .5759E-05 + .4813E-05 + .3871E-05 + .2994E-05 + .2244E-05 + .1645E-05 + .1118E-05 + .6801E-06 + .3731E-06 + .2422E-06 + .1572E-06 + .1020E-06 + .7464E-07 + .6082E-07 + .5210E-07 + .4906E-07 + .4620E-07 + .4509E-07 + .4476E-07 + .4444E-07 + .4396E-07 + .4178E-07 + .3970E-07 + .3591E-07 + .3084E-07 + .2629E-07 + .2381E-07 + .1525E-05 + .1677E-05 + .1828E-05 + .1968E-05 + .2104E-05 + .2258E-05 + .2430E-05 + .2640E-05 + .2838E-05 + .3143E-05 + .3442E-05 + .3800E-05 + .4203E-05 + .4708E-05 + .5255E-05 + .5808E-05 + .6376E-05 + .6867E-05 + .7284E-05 + .7613E-05 + .7840E-05 + .8006E-05 + .8167E-05 + .8329E-05 + .8460E-05 + .8512E-05 + .8483E-05 + .8451E-05 + .8137E-05 + .7782E-05 + .7237E-05 + .6561E-05 + .5748E-05 + .4862E-05 + .3935E-05 + .3073E-05 + .2332E-05 + .1737E-05 + .1210E-05 + .7531E-06 + .4352E-06 + .2696E-06 + .1670E-06 + .1035E-06 + .7618E-07 + .6506E-07 + .5664E-07 + .5113E-07 + .4616E-07 + .4450E-07 + .4426E-07 + .4401E-07 + .4364E-07 + .4179E-07 + .4003E-07 + .3634E-07 + .3129E-07 + .2683E-07 + .2477E-07 + .1505E-05 + .1663E-05 + .1820E-05 + .1968E-05 + .2113E-05 + .2275E-05 + .2463E-05 + .2668E-05 + .2884E-05 + .3180E-05 + .3506E-05 + .3871E-05 + .4284E-05 + .4791E-05 + .5358E-05 + .5906E-05 + .6475E-05 + .6974E-05 + .7369E-05 + .7665E-05 + .7865E-05 + .7983E-05 + .8090E-05 + .8214E-05 + .8287E-05 + .8287E-05 + .8239E-05 + .8167E-05 + .7897E-05 + .7562E-05 + .7063E-05 + .6448E-05 + .5714E-05 + .4893E-05 + .4011E-05 + .3174E-05 + .2439E-05 + .1837E-05 + .1312E-05 + .8513E-06 + .5202E-06 + .3052E-06 + .1791E-06 + .1051E-06 + .7785E-07 + .6968E-07 + .6166E-07 + .5336E-07 + .4619E-07 + .4398E-07 + .4382E-07 + .4365E-07 + .4338E-07 + .4187E-07 + .4041E-07 + .3682E-07 + .3178E-07 + .2741E-07 + .2580E-07 + .1460E-05 + .1625E-05 + .1786E-05 + .1945E-05 + .2102E-05 + .2272E-05 + .2480E-05 + .2672E-05 + .2908E-05 + .3186E-05 + .3550E-05 + .3930E-05 + .4341E-05 + .4827E-05 + .5401E-05 + .5947E-05 + .6513E-05 + .7022E-05 + .7397E-05 + .7652E-05 + .7826E-05 + .7896E-05 + .7941E-05 + .8023E-05 + .8045E-05 + .7992E-05 + .7914E-05 + .7828E-05 + .7604E-05 + .7288E-05 + .6835E-05 + .6275E-05 + .5626E-05 + .4877E-05 + .4063E-05 + .3266E-05 + .2540E-05 + .1931E-05 + .1414E-05 + .9660E-06 + .6253E-06 + .3718E-06 + .2211E-06 + .1315E-06 + .9691E-07 + .8444E-07 + .7246E-07 + .6039E-07 + .5033E-07 + .4675E-07 + .4573E-07 + .4472E-07 + .4369E-07 + .4211E-07 + .4060E-07 + .3704E-07 + .3212E-07 + .2785E-07 + .2638E-07 + .1405E-05 + .1570E-05 + .1735E-05 + .1902E-05 + .2067E-05 + .2248E-05 + .2459E-05 + .2670E-05 + .2922E-05 + .3208E-05 + .3568E-05 + .3951E-05 + .4377E-05 + .4877E-05 + .5451E-05 + .6012E-05 + .6535E-05 + .7036E-05 + .7378E-05 + .7604E-05 + .7719E-05 + .7748E-05 + .7745E-05 + .7770E-05 + .7740E-05 + .7688E-05 + .7620E-05 + .7497E-05 + .7262E-05 + .6982E-05 + .6607E-05 + .6104E-05 + .5541E-05 + .4885E-05 + .4141E-05 + .3369E-05 + .2651E-05 + .2038E-05 + .1519E-05 + .1076E-05 + .7274E-06 + .4536E-06 + .2828E-06 + .1763E-06 + .1287E-06 + .1065E-06 + .8727E-07 + .7014E-07 + .5637E-07 + .5088E-07 + .4852E-07 + .4627E-07 + .4414E-07 + .4237E-07 + .4067E-07 + .3713E-07 + .3237E-07 + .2822E-07 + .2678E-07 + .1352E-05 + .1517E-05 + .1686E-05 + .1859E-05 + .2032E-05 + .2224E-05 + .2434E-05 + .2668E-05 + .2937E-05 + .3235E-05 + .3586E-05 + .3972E-05 + .4417E-05 + .4937E-05 + .5509E-05 + .6087E-05 + .6563E-05 + .7048E-05 + .7356E-05 + .7552E-05 + .7606E-05 + .7595E-05 + .7549E-05 + .7520E-05 + .7445E-05 + .7399E-05 + .7342E-05 + .7186E-05 + .6938E-05 + .6691E-05 + .6393E-05 + .5949E-05 + .5468E-05 + .4904E-05 + .4229E-05 + .3482E-05 + .2773E-05 + .2157E-05 + .1634E-05 + .1197E-05 + .8432E-06 + .5520E-06 + .3614E-06 + .2366E-06 + .1710E-06 + .1344E-06 + .1051E-06 + .8149E-07 + .6316E-07 + .5538E-07 + .5149E-07 + .4788E-07 + .4461E-07 + .4264E-07 + .4076E-07 + .3724E-07 + .3263E-07 + .2860E-07 + .2719E-07 + .1296E-05 + .1466E-05 + .1638E-05 + .1815E-05 + .1992E-05 + .2178E-05 + .2385E-05 + .2622E-05 + .2893E-05 + .3195E-05 + .3577E-05 + .3991E-05 + .4469E-05 + .4989E-05 + .5540E-05 + .6087E-05 + .6561E-05 + .6959E-05 + .7213E-05 + .7339E-05 + .7365E-05 + .7318E-05 + .7243E-05 + .7186E-05 + .7101E-05 + .7018E-05 + .6942E-05 + .6819E-05 + .6626E-05 + .6389E-05 + .6156E-05 + .5821E-05 + .5404E-05 + .4890E-05 + .4277E-05 + .3581E-05 + .2899E-05 + .2292E-05 + .1782E-05 + .1344E-05 + .9814E-06 + .6710E-06 + .4588E-06 + .3137E-06 + .2245E-06 + .1676E-06 + .1252E-06 + .9359E-07 + .6995E-07 + .5959E-07 + .5402E-07 + .4897E-07 + .4457E-07 + .4242E-07 + .4037E-07 + .3691E-07 + .3252E-07 + .2865E-07 + .2729E-07 + .1245E-05 + .1421E-05 + .1600E-05 + .1785E-05 + .1970E-05 + .2156E-05 + .2365E-05 + .2608E-05 + .2888E-05 + .3196E-05 + .3608E-05 + .4054E-05 + .4563E-05 + .5089E-05 + .5626E-05 + .6148E-05 + .6614E-05 + .6946E-05 + .7155E-05 + .7230E-05 + .7230E-05 + .7152E-05 + .7049E-05 + .6964E-05 + .6866E-05 + .6751E-05 + .6656E-05 + .6553E-05 + .6403E-05 + .6185E-05 + .6003E-05 + .5749E-05 + .5389E-05 + .4924E-05 + .4362E-05 + .3711E-05 + .3052E-05 + .2452E-05 + .1950E-05 + .1513E-05 + .1141E-05 + .7771E-06 + .5291E-06 + .3603E-06 + .2549E-06 + .1871E-06 + .1371E-06 + .1001E-06 + .7310E-07 + .6097E-07 + .5417E-07 + .4813E-07 + .4300E-07 + .4097E-07 + .3903E-07 + .3575E-07 + .3157E-07 + .2788E-07 + .2658E-07 + .1172E-05 + .1357E-05 + .1546E-05 + .1744E-05 + .1945E-05 + .2146E-05 + .2363E-05 + .2615E-05 + .2909E-05 + .3229E-05 + .3657E-05 + .4133E-05 + .4653E-05 + .5189E-05 + .5720E-05 + .6219E-05 + .6654E-05 + .6958E-05 + .7144E-05 + .7206E-05 + .7178E-05 + .7086E-05 + .6950E-05 + .6835E-05 + .6718E-05 + .6581E-05 + .6466E-05 + .6350E-05 + .6229E-05 + .6061E-05 + .5909E-05 + .5679E-05 + .5371E-05 + .4961E-05 + .4434E-05 + .3826E-05 + .3193E-05 + .2607E-05 + .2102E-05 + .1673E-05 + .1291E-05 + .8683E-06 + .5841E-06 + .3928E-06 + .2746E-06 + .2008E-06 + .1458E-06 + .1046E-06 + .7499E-07 + .6142E-07 + .5360E-07 + .4676E-07 + .4110E-07 + .3928E-07 + .3755E-07 + .3446E-07 + .3047E-07 + .2694E-07 + .2570E-07 + .1110E-05 + .1302E-05 + .1501E-05 + .1711E-05 + .1926E-05 + .2139E-05 + .2365E-05 + .2625E-05 + .2930E-05 + .3261E-05 + .3696E-05 + .4187E-05 + .4722E-05 + .5263E-05 + .5792E-05 + .6284E-05 + .6691E-05 + .6964E-05 + .7131E-05 + .7192E-05 + .7149E-05 + .7043E-05 + .6884E-05 + .6742E-05 + .6609E-05 + .6459E-05 + .6340E-05 + .6225E-05 + .6127E-05 + .5984E-05 + .5857E-05 + .5655E-05 + .5369E-05 + .4991E-05 + .4490E-05 + .3908E-05 + .3290E-05 + .2709E-05 + .2204E-05 + .1778E-05 + .1394E-05 + .9411E-06 + .6352E-06 + .4287E-06 + .2961E-06 + .2157E-06 + .1553E-06 + .1093E-06 + .7700E-07 + .6193E-07 + .5307E-07 + .4547E-07 + .3932E-07 + .3770E-07 + .3614E-07 + .3325E-07 + .2943E-07 + .2606E-07 + .2487E-07 + .1061E-05 + .1259E-05 + .1467E-05 + .1688E-05 + .1915E-05 + .2138E-05 + .2372E-05 + .2640E-05 + .2955E-05 + .3296E-05 + .3728E-05 + .4218E-05 + .4775E-05 + .5312E-05 + .5847E-05 + .6350E-05 + .6733E-05 + .6972E-05 + .7124E-05 + .7195E-05 + .7151E-05 + .7035E-05 + .6859E-05 + .6694E-05 + .6547E-05 + .6395E-05 + .6288E-05 + .6189E-05 + .6106E-05 + .5965E-05 + .5856E-05 + .5688E-05 + .5391E-05 + .5018E-05 + .4535E-05 + .3956E-05 + .3338E-05 + .2750E-05 + .2244E-05 + .1813E-05 + .1433E-05 + .9876E-06 + .6805E-06 + .4688E-06 + .3199E-06 + .2321E-06 + .1657E-06 + .1146E-06 + .7922E-07 + .6258E-07 + .5266E-07 + .4431E-07 + .3769E-07 + .3625E-07 + .3486E-07 + .3214E-07 + .2849E-07 + .2525E-07 + .2412E-07 + .1050E-05 + .1275E-05 + .1499E-05 + .1724E-05 + .1951E-05 + .2187E-05 + .2443E-05 + .2728E-05 + .3057E-05 + .3418E-05 + .3855E-05 + .4351E-05 + .4919E-05 + .5446E-05 + .5973E-05 + .6488E-05 + .6808E-05 + .7017E-05 + .7167E-05 + .7208E-05 + .7146E-05 + .7030E-05 + .6868E-05 + .6707E-05 + .6552E-05 + .6396E-05 + .6279E-05 + .6169E-05 + .6072E-05 + .5929E-05 + .5815E-05 + .5662E-05 + .5393E-05 + .4985E-05 + .4512E-05 + .3922E-05 + .3280E-05 + .2650E-05 + .2172E-05 + .1783E-05 + .1442E-05 + .1024E-05 + .7269E-06 + .5162E-06 + .3559E-06 + .2582E-06 + .1835E-06 + .1252E-06 + .8546E-07 + .6687E-07 + .5583E-07 + .4662E-07 + .3935E-07 + .3766E-07 + .3603E-07 + .3300E-07 + .2901E-07 + .2551E-07 + .2428E-07 + .1050E-05 + .1313E-05 + .1556E-05 + .1780E-05 + .2000E-05 + .2250E-05 + .2535E-05 + .2841E-05 + .3186E-05 + .3568E-05 + .4014E-05 + .4517E-05 + .5087E-05 + .5595E-05 + .6106E-05 + .6631E-05 + .6866E-05 + .7047E-05 + .7199E-05 + .7191E-05 + .7105E-05 + .6993E-05 + .6859E-05 + .6717E-05 + .6556E-05 + .6397E-05 + .6259E-05 + .6127E-05 + .6003E-05 + .5858E-05 + .5730E-05 + .5583E-05 + .5361E-05 + .4903E-05 + .4437E-05 + .3835E-05 + .3162E-05 + .2482E-05 + .2045E-05 + .1716E-05 + .1429E-05 + .1050E-05 + .7719E-06 + .5674E-06 + .3993E-06 + .2903E-06 + .2057E-06 + .1389E-06 + .9376E-07 + .7296E-07 + .6073E-07 + .5056E-07 + .4253E-07 + .4033E-07 + .3825E-07 + .3466E-07 + .3009E-07 + .2613E-07 + .2476E-07 + .1043E-05 + .1343E-05 + .1604E-05 + .1826E-05 + .2038E-05 + .2299E-05 + .2613E-05 + .2939E-05 + .3298E-05 + .3700E-05 + .4152E-05 + .4658E-05 + .5227E-05 + .5712E-05 + .6202E-05 + .6733E-05 + .6880E-05 + .7030E-05 + .7184E-05 + .7127E-05 + .7018E-05 + .6911E-05 + .6806E-05 + .6683E-05 + .6518E-05 + .6357E-05 + .6200E-05 + .6046E-05 + .5897E-05 + .5751E-05 + .5609E-05 + .5470E-05 + .5295E-05 + .4791E-05 + .4334E-05 + .3725E-05 + .3028E-05 + .2310E-05 + .1912E-05 + .1640E-05 + .1407E-05 + .1070E-05 + .8144E-06 + .6196E-06 + .4452E-06 + .3242E-06 + .2291E-06 + .1530E-06 + .1022E-06 + .7908E-07 + .6563E-07 + .5447E-07 + .4566E-07 + .4292E-07 + .4035E-07 + .3616E-07 + .3101E-07 + .2659E-07 + .2508E-07 + .1103E-05 + .1400E-05 + .1659E-05 + .1878E-05 + .2099E-05 + .2373E-05 + .2692E-05 + .3026E-05 + .3389E-05 + .3786E-05 + .4231E-05 + .4734E-05 + .5296E-05 + .5769E-05 + .6253E-05 + .6779E-05 + .6903E-05 + .7029E-05 + .7138E-05 + .7074E-05 + .6964E-05 + .6846E-05 + .6730E-05 + .6602E-05 + .6445E-05 + .6292E-05 + .6143E-05 + .5997E-05 + .5854E-05 + .5715E-05 + .5579E-05 + .5352E-05 + .5084E-05 + .4590E-05 + .4136E-05 + .3538E-05 + .2867E-05 + .2235E-05 + .1869E-05 + .1603E-05 + .1363E-05 + .1080E-05 + .8557E-06 + .6780E-06 + .4878E-06 + .3500E-06 + .2458E-06 + .1655E-06 + .1114E-06 + .8529E-07 + .6938E-07 + .5643E-07 + .4643E-07 + .4359E-07 + .4091E-07 + .3702E-07 + .3237E-07 + .2831E-07 + .2689E-07 + .1167E-05 + .1460E-05 + .1717E-05 + .1934E-05 + .2164E-05 + .2452E-05 + .2776E-05 + .3119E-05 + .3485E-05 + .3877E-05 + .4316E-05 + .4815E-05 + .5371E-05 + .5830E-05 + .6311E-05 + .6831E-05 + .6932E-05 + .7034E-05 + .7097E-05 + .7027E-05 + .6915E-05 + .6787E-05 + .6660E-05 + .6528E-05 + .6379E-05 + .6234E-05 + .6091E-05 + .5952E-05 + .5817E-05 + .5684E-05 + .5554E-05 + .5241E-05 + .4885E-05 + .4401E-05 + .3949E-05 + .3364E-05 + .2716E-05 + .2164E-05 + .1827E-05 + .1567E-05 + .1321E-05 + .1090E-05 + .8998E-06 + .7426E-06 + .5349E-06 + .3783E-06 + .2638E-06 + .1791E-06 + .1216E-06 + .9207E-07 + .7340E-07 + .5851E-07 + .4726E-07 + .4430E-07 + .4152E-07 + .3792E-07 + .3382E-07 + .3016E-07 + .2886E-07 + .1219E-05 + .1502E-05 + .1753E-05 + .1963E-05 + .2201E-05 + .2498E-05 + .2824E-05 + .3170E-05 + .3534E-05 + .3916E-05 + .4342E-05 + .4829E-05 + .5372E-05 + .5811E-05 + .6281E-05 + .6788E-05 + .6864E-05 + .6942E-05 + .6960E-05 + .6884E-05 + .6773E-05 + .6635E-05 + .6500E-05 + .6365E-05 + .6226E-05 + .6090E-05 + .5957E-05 + .5827E-05 + .5700E-05 + .5575E-05 + .5453E-05 + .5061E-05 + .4629E-05 + .4162E-05 + .3719E-05 + .3154E-05 + .2538E-05 + .2066E-05 + .1762E-05 + .1511E-05 + .1263E-05 + .1086E-05 + .9332E-06 + .8021E-06 + .5784E-06 + .4032E-06 + .2793E-06 + .1912E-06 + .1309E-06 + .9800E-07 + .7658E-07 + .5983E-07 + .4743E-07 + .4440E-07 + .4156E-07 + .3832E-07 + .3484E-07 + .3168E-07 + .3055E-07 + .1257E-05 + .1536E-05 + .1785E-05 + .1992E-05 + .2235E-05 + .2540E-05 + .2867E-05 + .3213E-05 + .3574E-05 + .3942E-05 + .4352E-05 + .4822E-05 + .5346E-05 + .5783E-05 + .6218E-05 + .6687E-05 + .6773E-05 + .6861E-05 + .6864E-05 + .6781E-05 + .6669E-05 + .6530E-05 + .6395E-05 + .6261E-05 + .6131E-05 + .6004E-05 + .5879E-05 + .5757E-05 + .5637E-05 + .5493E-05 + .5346E-05 + .4922E-05 + .4463E-05 + .4014E-05 + .3587E-05 + .3032E-05 + .2447E-05 + .2023E-05 + .1735E-05 + .1488E-05 + .1238E-05 + .1102E-05 + .9813E-06 + .8737E-06 + .6308E-06 + .4334E-06 + .2982E-06 + .2058E-06 + .1421E-06 + .1052E-06 + .8057E-07 + .6170E-07 + .4801E-07 + .4488E-07 + .4195E-07 + .3904E-07 + .3620E-07 + .3357E-07 + .3262E-07 + .1249E-05 + .1527E-05 + .1774E-05 + .1980E-05 + .2222E-05 + .2525E-05 + .2845E-05 + .3179E-05 + .3527E-05 + .3871E-05 + .4251E-05 + .4687E-05 + .5179E-05 + .5626E-05 + .5989E-05 + .6376E-05 + .6516E-05 + .6660E-05 + .6686E-05 + .6595E-05 + .6485E-05 + .6358E-05 + .6233E-05 + .6111E-05 + .5991E-05 + .5873E-05 + .5758E-05 + .5645E-05 + .5534E-05 + .5336E-05 + .5124E-05 + .4737E-05 + .4318E-05 + .3901E-05 + .3509E-05 + .2957E-05 + .2414E-05 + .2011E-05 + .1725E-05 + .1479E-05 + .1230E-05 + .1126E-05 + .1031E-05 + .9439E-06 + .6823E-06 + .4620E-06 + .3157E-06 + .2197E-06 + .1529E-06 + .1120E-06 + .8408E-07 + .6310E-07 + .4820E-07 + .4499E-07 + .4199E-07 + .3946E-07 + .3731E-07 + .3528E-07 + .3453E-07 + .1256E-05 + .1536E-05 + .1784E-05 + .1991E-05 + .2234E-05 + .2539E-05 + .2857E-05 + .3183E-05 + .3522E-05 + .3846E-05 + .4201E-05 + .4610E-05 + .5076E-05 + .5538E-05 + .5837E-05 + .6152E-05 + .6343E-05 + .6540E-05 + .6590E-05 + .6490E-05 + .6381E-05 + .6263E-05 + .6147E-05 + .6034E-05 + .5923E-05 + .5813E-05 + .5706E-05 + .5601E-05 + .5498E-05 + .5245E-05 + .4970E-05 + .4613E-05 + .4227E-05 + .3836E-05 + .3472E-05 + .2918E-05 + .2411E-05 + .2022E-05 + .1734E-05 + .1487E-05 + .1237E-05 + .1145E-05 + .1059E-05 + .9795E-06 + .7084E-06 + .4770E-06 + .3252E-06 + .2270E-06 + .1585E-06 + .1156E-06 + .8612E-07 + .6415E-07 + .4865E-07 + .4539E-07 + .4234E-07 + .3993E-07 + .3803E-07 + .3623E-07 + .3556E-07 + .1273E-05 + .1556E-05 + .1808E-05 + .2018E-05 + .2264E-05 + .2573E-05 + .2891E-05 + .3212E-05 + .3544E-05 + .3851E-05 + .4184E-05 + .4569E-05 + .5013E-05 + .5493E-05 + .5732E-05 + .5982E-05 + .6222E-05 + .6473E-05 + .6546E-05 + .6436E-05 + .6326E-05 + .6217E-05 + .6110E-05 + .6004E-05 + .5900E-05 + .5798E-05 + .5698E-05 + .5600E-05 + .5503E-05 + .5196E-05 + .4857E-05 + .4526E-05 + .4171E-05 + .3801E-05 + .3463E-05 + .2902E-05 + .2426E-05 + .2049E-05 + .1757E-05 + .1507E-05 + .1254E-05 + .1160E-05 + .1073E-05 + .9926E-06 + .7178E-06 + .4834E-06 + .3295E-06 + .2301E-06 + .1606E-06 + .1172E-06 + .8727E-07 + .6500E-07 + .4930E-07 + .4599E-07 + .4291E-07 + .4046E-07 + .3854E-07 + .3671E-07 + .3604E-07 + .1293E-05 + .1580E-05 + .1837E-05 + .2049E-05 + .2299E-05 + .2613E-05 + .2932E-05 + .3249E-05 + .3580E-05 + .3870E-05 + .4184E-05 + .4541E-05 + .4954E-05 + .5412E-05 + .5685E-05 + .5930E-05 + .6141E-05 + .6360E-05 + .6426E-05 + .6333E-05 + .6241E-05 + .6151E-05 + .6062E-05 + .5974E-05 + .5888E-05 + .5803E-05 + .5685E-05 + .5536E-05 + .5391E-05 + .5082E-05 + .4751E-05 + .4438E-05 + .4111E-05 + .3775E-05 + .3420E-05 + .2893E-05 + .2447E-05 + .2081E-05 + .1785E-05 + .1531E-05 + .1273E-05 + .1178E-05 + .1090E-05 + .1008E-05 + .7290E-06 + .4909E-06 + .3347E-06 + .2336E-06 + .1631E-06 + .1190E-06 + .8863E-07 + .6602E-07 + .5007E-07 + .4671E-07 + .4358E-07 + .4109E-07 + .3914E-07 + .3728E-07 + .3660E-07 + .1314E-05 + .1606E-05 + .1866E-05 + .2082E-05 + .2336E-05 + .2655E-05 + .2975E-05 + .3289E-05 + .3618E-05 + .3892E-05 + .4186E-05 + .4514E-05 + .4894E-05 + .5325E-05 + .5649E-05 + .5901E-05 + .6068E-05 + .6240E-05 + .6291E-05 + .6220E-05 + .6150E-05 + .6080E-05 + .6011E-05 + .5943E-05 + .5876E-05 + .5810E-05 + .5669E-05 + .5459E-05 + .5256E-05 + .4958E-05 + .4647E-05 + .4351E-05 + .4051E-05 + .3751E-05 + .3371E-05 + .2885E-05 + .2468E-05 + .2114E-05 + .1813E-05 + .1555E-05 + .1294E-05 + .1197E-05 + .1107E-05 + .1024E-05 + .7406E-06 + .4987E-06 + .3400E-06 + .2374E-06 + .1657E-06 + .1209E-06 + .9004E-07 + .6707E-07 + .5087E-07 + .4745E-07 + .4427E-07 + .4175E-07 + .3976E-07 + .3788E-07 + .3718E-07 + .1334E-05 + .1631E-05 + .1895E-05 + .2114E-05 + .2372E-05 + .2696E-05 + .3018E-05 + .3328E-05 + .3656E-05 + .3912E-05 + .4187E-05 + .4486E-05 + .4835E-05 + .5238E-05 + .5613E-05 + .5871E-05 + .5994E-05 + .6120E-05 + .6159E-05 + .6109E-05 + .6059E-05 + .6009E-05 + .5960E-05 + .5912E-05 + .5863E-05 + .5815E-05 + .5652E-05 + .5382E-05 + .5125E-05 + .4836E-05 + .4545E-05 + .4264E-05 + .3991E-05 + .3726E-05 + .3323E-05 + .2876E-05 + .2489E-05 + .2147E-05 + .1841E-05 + .1579E-05 + .1314E-05 + .1215E-05 + .1124E-05 + .1040E-05 + .7521E-06 + .5065E-06 + .3453E-06 + .2410E-06 + .1683E-06 + .1228E-06 + .9144E-07 + .6811E-07 + .5166E-07 + .4819E-07 + .4496E-07 + .4239E-07 + .4038E-07 + .3847E-07 + .3776E-07 + .2010E-05 + .2152E-05 + .2263E-05 + .2377E-05 + .2491E-05 + .2610E-05 + .2735E-05 + .2865E-05 + .3007E-05 + .3158E-05 + .3317E-05 + .3527E-05 + .3806E-05 + .4109E-05 + .4371E-05 + .4555E-05 + .4741E-05 + .4878E-05 + .4962E-05 + .5048E-05 + .5030E-05 + .5000E-05 + .4970E-05 + .4940E-05 + .4910E-05 + .4834E-05 + .4713E-05 + .4595E-05 + .4480E-05 + .4345E-05 + .4203E-05 + .4065E-05 + .3930E-05 + .3784E-05 + .3642E-05 + .3506E-05 + .3192E-05 + .2793E-05 + .2435E-05 + .2108E-05 + .1783E-05 + .1452E-05 + .1182E-05 + .9623E-06 + .6707E-06 + .5015E-06 + .3407E-06 + .1928E-06 + .1091E-06 + .7513E-07 + .5680E-07 + .4294E-07 + .3291E-07 + .2943E-07 + .2633E-07 + .2395E-07 + .2214E-07 + .2046E-07 + .1986E-07 + .1909E-05 + .2042E-05 + .2159E-05 + .2277E-05 + .2388E-05 + .2504E-05 + .2626E-05 + .2754E-05 + .2897E-05 + .3056E-05 + .3223E-05 + .3425E-05 + .3693E-05 + .3987E-05 + .4264E-05 + .4460E-05 + .4652E-05 + .4817E-05 + .4950E-05 + .5087E-05 + .5073E-05 + .5031E-05 + .4989E-05 + .4947E-05 + .4906E-05 + .4834E-05 + .4734E-05 + .4636E-05 + .4540E-05 + .4408E-05 + .4267E-05 + .4131E-05 + .3994E-05 + .3824E-05 + .3661E-05 + .3505E-05 + .3237E-05 + .2840E-05 + .2470E-05 + .2139E-05 + .1803E-05 + .1455E-05 + .1174E-05 + .9477E-06 + .6606E-06 + .4939E-06 + .3356E-06 + .1899E-06 + .1074E-06 + .7399E-07 + .5594E-07 + .4229E-07 + .3241E-07 + .2899E-07 + .2593E-07 + .2359E-07 + .2180E-07 + .2015E-07 + .1955E-07 + .1815E-05 + .1940E-05 + .2062E-05 + .2184E-05 + .2292E-05 + .2405E-05 + .2524E-05 + .2649E-05 + .2795E-05 + .2960E-05 + .3134E-05 + .3331E-05 + .3587E-05 + .3874E-05 + .4164E-05 + .4373E-05 + .4571E-05 + .4762E-05 + .4944E-05 + .5133E-05 + .5124E-05 + .5069E-05 + .5015E-05 + .4961E-05 + .4908E-05 + .4841E-05 + .4762E-05 + .4684E-05 + .4607E-05 + .4479E-05 + .4339E-05 + .4203E-05 + .4065E-05 + .3870E-05 + .3685E-05 + .3509E-05 + .3287E-05 + .2892E-05 + .2509E-05 + .2173E-05 + .1824E-05 + .1460E-05 + .1168E-05 + .9345E-06 + .6514E-06 + .4871E-06 + .3309E-06 + .1872E-06 + .1059E-06 + .7296E-07 + .5516E-07 + .4171E-07 + .3196E-07 + .2859E-07 + .2557E-07 + .2326E-07 + .2150E-07 + .1987E-07 + .1928E-07 + .1716E-05 + .1833E-05 + .1956E-05 + .2075E-05 + .2181E-05 + .2291E-05 + .2407E-05 + .2534E-05 + .2666E-05 + .2842E-05 + .3012E-05 + .3208E-05 + .3451E-05 + .3721E-05 + .4036E-05 + .4279E-05 + .4508E-05 + .4756E-05 + .4972E-05 + .5178E-05 + .5182E-05 + .5126E-05 + .5057E-05 + .4984E-05 + .4893E-05 + .4839E-05 + .4770E-05 + .4720E-05 + .4656E-05 + .4514E-05 + .4398E-05 + .4278E-05 + .4157E-05 + .3933E-05 + .3720E-05 + .3519E-05 + .3331E-05 + .2955E-05 + .2601E-05 + .2241E-05 + .1866E-05 + .1471E-05 + .1160E-05 + .9142E-06 + .6373E-06 + .4765E-06 + .3237E-06 + .1832E-06 + .1036E-06 + .7138E-07 + .5396E-07 + .4080E-07 + .3126E-07 + .2796E-07 + .2501E-07 + .2276E-07 + .2103E-07 + .1944E-07 + .1886E-07 + .1610E-05 + .1722E-05 + .1827E-05 + .1925E-05 + .2031E-05 + .2140E-05 + .2254E-05 + .2397E-05 + .2472E-05 + .2668E-05 + .2801E-05 + .3017E-05 + .3236E-05 + .3472E-05 + .3839E-05 + .4183E-05 + .4522E-05 + .4922E-05 + .5126E-05 + .5223E-05 + .5284E-05 + .5277E-05 + .5195E-05 + .5088E-05 + .4888E-05 + .4858E-05 + .4754E-05 + .4741E-05 + .4649E-05 + .4431E-05 + .4397E-05 + .4335E-05 + .4292E-05 + .4052E-05 + .3809E-05 + .3570E-05 + .3340E-05 + .3032E-05 + .2845E-05 + .2392E-05 + .1940E-05 + .1487E-05 + .1140E-05 + .8739E-06 + .6091E-06 + .4555E-06 + .3094E-06 + .1751E-06 + .9907E-07 + .6823E-07 + .5158E-07 + .3900E-07 + .2988E-07 + .2673E-07 + .2391E-07 + .2175E-07 + .2011E-07 + .1858E-07 + .1803E-07 + .1612E-05 + .1725E-05 + .1830E-05 + .1931E-05 + .2040E-05 + .2154E-05 + .2273E-05 + .2420E-05 + .2511E-05 + .2705E-05 + .2849E-05 + .3067E-05 + .3295E-05 + .3547E-05 + .3912E-05 + .4265E-05 + .4627E-05 + .5017E-05 + .5273E-05 + .5416E-05 + .5528E-05 + .5545E-05 + .5498E-05 + .5405E-05 + .5237E-05 + .5164E-05 + .5046E-05 + .4987E-05 + .4862E-05 + .4596E-05 + .4509E-05 + .4424E-05 + .4360E-05 + .4200E-05 + .3989E-05 + .3721E-05 + .3404E-05 + .3064E-05 + .2815E-05 + .2339E-05 + .1875E-05 + .1445E-05 + .1113E-05 + .8579E-06 + .5989E-06 + .4490E-06 + .3065E-06 + .1749E-06 + .9986E-07 + .6916E-07 + .5251E-07 + .3986E-07 + .3067E-07 + .2746E-07 + .2458E-07 + .2232E-07 + .2052E-07 + .1887E-07 + .1828E-07 + .1633E-05 + .1747E-05 + .1854E-05 + .1960E-05 + .2073E-05 + .2193E-05 + .2320E-05 + .2473E-05 + .2581E-05 + .2776E-05 + .2932E-05 + .3155E-05 + .3394E-05 + .3666E-05 + .4035E-05 + .4402E-05 + .4790E-05 + .5192E-05 + .5498E-05 + .5703E-05 + .5862E-05 + .5918E-05 + .5906E-05 + .5840E-05 + .5711E-05 + .5611E-05 + .5481E-05 + .5386E-05 + .5234E-05 + .4920E-05 + .4782E-05 + .4642E-05 + .4520E-05 + .4362E-05 + .4141E-05 + .3849E-05 + .3479E-05 + .3118E-05 + .2814E-05 + .2313E-05 + .1832E-05 + .1392E-05 + .1057E-05 + .8035E-06 + .5630E-06 + .4250E-06 + .2938E-06 + .1717E-06 + .1003E-06 + .7053E-07 + .5414E-07 + .4156E-07 + .3230E-07 + .2899E-07 + .2601E-07 + .2348E-07 + .2131E-07 + .1933E-07 + .1863E-07 + .1642E-05 + .1758E-05 + .1866E-05 + .1975E-05 + .2092E-05 + .2217E-05 + .2351E-05 + .2509E-05 + .2634E-05 + .2829E-05 + .2997E-05 + .3224E-05 + .3473E-05 + .3764E-05 + .4133E-05 + .4511E-05 + .4926E-05 + .5354E-05 + .5701E-05 + .5986E-05 + .6187E-05 + .6298E-05 + .6322E-05 + .6301E-05 + .6223E-05 + .6120E-05 + .5985E-05 + .5868E-05 + .5699E-05 + .5345E-05 + .5156E-05 + .4923E-05 + .4698E-05 + .4452E-05 + .4175E-05 + .3872E-05 + .3498E-05 + .3135E-05 + .2790E-05 + .2270E-05 + .1775E-05 + .1330E-05 + .9972E-06 + .7474E-06 + .5256E-06 + .3996E-06 + .2797E-06 + .1673E-06 + .1001E-06 + .7143E-07 + .5544E-07 + .4303E-07 + .3379E-07 + .3040E-07 + .2734E-07 + .2454E-07 + .2197E-07 + .1967E-07 + .1886E-07 + .1636E-05 + .1753E-05 + .1861E-05 + .1973E-05 + .2092E-05 + .2222E-05 + .2362E-05 + .2523E-05 + .2666E-05 + .2858E-05 + .3037E-05 + .3266E-05 + .3524E-05 + .3830E-05 + .4197E-05 + .4584E-05 + .5021E-05 + .5462E-05 + .5839E-05 + .6172E-05 + .6397E-05 + .6540E-05 + .6596E-05 + .6604E-05 + .6555E-05 + .6446E-05 + .6306E-05 + .6167E-05 + .5973E-05 + .5654E-05 + .5435E-05 + .5174E-05 + .4908E-05 + .4607E-05 + .4286E-05 + .3954E-05 + .3557E-05 + .3169E-05 + .2764E-05 + .2238E-05 + .1743E-05 + .1279E-05 + .9391E-06 + .6893E-06 + .4865E-06 + .3724E-06 + .2640E-06 + .1616E-06 + .9898E-07 + .7171E-07 + .5628E-07 + .4416E-07 + .3505E-07 + .3160E-07 + .2849E-07 + .2542E-07 + .2246E-07 + .1984E-07 + .1893E-07 + .1620E-05 + .1736E-05 + .1843E-05 + .1957E-05 + .2078E-05 + .2212E-05 + .2357E-05 + .2521E-05 + .2680E-05 + .2867E-05 + .3057E-05 + .3286E-05 + .3550E-05 + .3872E-05 + .4233E-05 + .4626E-05 + .5084E-05 + .5529E-05 + .5931E-05 + .6296E-05 + .6535E-05 + .6698E-05 + .6784E-05 + .6813E-05 + .6780E-05 + .6665E-05 + .6520E-05 + .6360E-05 + .6136E-05 + .5893E-05 + .5654E-05 + .5401E-05 + .5124E-05 + .4783E-05 + .4424E-05 + .4052E-05 + .3627E-05 + .3203E-05 + .2731E-05 + .2205E-05 + .1718E-05 + .1231E-05 + .8814E-06 + .6314E-06 + .4473E-06 + .3448E-06 + .2475E-06 + .1551E-06 + .9724E-07 + .7152E-07 + .5675E-07 + .4503E-07 + .3610E-07 + .3263E-07 + .2949E-07 + .2616E-07 + .2281E-07 + .1988E-07 + .1887E-07 + .1635E-05 + .1755E-05 + .1871E-05 + .1994E-05 + .2123E-05 + .2264E-05 + .2419E-05 + .2592E-05 + .2765E-05 + .2951E-05 + .3163E-05 + .3392E-05 + .3675E-05 + .4004E-05 + .4386E-05 + .4796E-05 + .5262E-05 + .5747E-05 + .6192E-05 + .6584E-05 + .6864E-05 + .7053E-05 + .7175E-05 + .7227E-05 + .7211E-05 + .7111E-05 + .6976E-05 + .6806E-05 + .6547E-05 + .6263E-05 + .5975E-05 + .5640E-05 + .5303E-05 + .4909E-05 + .4500E-05 + .4085E-05 + .3630E-05 + .3159E-05 + .2661E-05 + .2134E-05 + .1648E-05 + .1167E-05 + .8264E-06 + .5852E-06 + .4161E-06 + .3230E-06 + .2348E-06 + .1506E-06 + .9666E-07 + .7217E-07 + .5790E-07 + .4645E-07 + .3763E-07 + .3409E-07 + .3088E-07 + .2724E-07 + .2343E-07 + .2016E-07 + .1903E-07 + .1640E-05 + .1765E-05 + .1890E-05 + .2021E-05 + .2158E-05 + .2306E-05 + .2470E-05 + .2650E-05 + .2835E-05 + .3020E-05 + .3252E-05 + .3481E-05 + .3780E-05 + .4114E-05 + .4514E-05 + .4941E-05 + .5410E-05 + .5932E-05 + .6420E-05 + .6836E-05 + .7156E-05 + .7369E-05 + .7526E-05 + .7606E-05 + .7609E-05 + .7529E-05 + .7411E-05 + .7237E-05 + .6947E-05 + .6607E-05 + .6260E-05 + .5833E-05 + .5428E-05 + .4982E-05 + .4524E-05 + .4065E-05 + .3583E-05 + .3073E-05 + .2558E-05 + .2036E-05 + .1556E-05 + .1092E-05 + .7660E-06 + .5374E-06 + .3836E-06 + .2998E-06 + .2207E-06 + .1450E-06 + .9521E-07 + .7216E-07 + .5854E-07 + .4748E-07 + .3887E-07 + .3529E-07 + .3205E-07 + .2810E-07 + .2386E-07 + .2025E-07 + .1902E-07 + .1669E-05 + .1806E-05 + .1942E-05 + .2083E-05 + .2227E-05 + .2381E-05 + .2548E-05 + .2733E-05 + .2923E-05 + .3115E-05 + .3353E-05 + .3604E-05 + .3903E-05 + .4254E-05 + .4646E-05 + .5105E-05 + .5600E-05 + .6114E-05 + .6639E-05 + .7070E-05 + .7403E-05 + .7630E-05 + .7788E-05 + .7918E-05 + .7944E-05 + .7877E-05 + .7787E-05 + .7650E-05 + .7361E-05 + .6985E-05 + .6528E-05 + .6037E-05 + .5545E-05 + .5047E-05 + .4537E-05 + .3997E-05 + .3486E-05 + .2965E-05 + .2420E-05 + .1901E-05 + .1437E-05 + .1004E-05 + .7021E-06 + .4907E-06 + .3516E-06 + .2767E-06 + .2063E-06 + .1387E-06 + .9324E-07 + .7174E-07 + .5884E-07 + .4826E-07 + .3991E-07 + .3633E-07 + .3307E-07 + .2883E-07 + .2415E-07 + .2023E-07 + .1890E-07 + .1685E-05 + .1825E-05 + .1963E-05 + .2106E-05 + .2252E-05 + .2409E-05 + .2580E-05 + .2769E-05 + .2967E-05 + .3152E-05 + .3406E-05 + .3667E-05 + .3964E-05 + .4323E-05 + .4715E-05 + .5190E-05 + .5701E-05 + .6206E-05 + .6750E-05 + .7203E-05 + .7551E-05 + .7793E-05 + .7970E-05 + .8140E-05 + .8194E-05 + .8152E-05 + .8112E-05 + .8007E-05 + .7717E-05 + .7311E-05 + .6777E-05 + .6225E-05 + .5651E-05 + .5088E-05 + .4514E-05 + .3914E-05 + .3374E-05 + .2841E-05 + .2277E-05 + .1762E-05 + .1310E-05 + .9135E-06 + .6370E-06 + .4442E-06 + .3194E-06 + .2531E-06 + .1911E-06 + .1315E-06 + .9052E-07 + .7070E-07 + .5863E-07 + .4862E-07 + .4063E-07 + .3707E-07 + .3382E-07 + .2931E-07 + .2423E-07 + .2003E-07 + .1862E-07 + .1691E-05 + .1812E-05 + .1933E-05 + .2063E-05 + .2204E-05 + .2359E-05 + .2534E-05 + .2727E-05 + .2942E-05 + .3093E-05 + .3383E-05 + .3628E-05 + .3924E-05 + .4273E-05 + .4688E-05 + .5146E-05 + .5658E-05 + .6156E-05 + .6683E-05 + .7172E-05 + .7546E-05 + .7808E-05 + .8045E-05 + .8232E-05 + .8318E-05 + .8328E-05 + .8379E-05 + .8284E-05 + .7983E-05 + .7569E-05 + .7043E-05 + .6433E-05 + .5789E-05 + .5129E-05 + .4463E-05 + .3836E-05 + .3266E-05 + .2710E-05 + .2141E-05 + .1626E-05 + .1174E-05 + .8191E-06 + .5714E-06 + .3986E-06 + .2877E-06 + .2296E-06 + .1755E-06 + .1236E-06 + .8712E-07 + .6907E-07 + .5792E-07 + .4856E-07 + .4101E-07 + .3750E-07 + .3429E-07 + .2955E-07 + .2410E-07 + .1966E-07 + .1819E-07 + .1674E-05 + .1791E-05 + .1907E-05 + .2032E-05 + .2168E-05 + .2321E-05 + .2493E-05 + .2688E-05 + .2895E-05 + .3061E-05 + .3345E-05 + .3592E-05 + .3890E-05 + .4244E-05 + .4673E-05 + .5128E-05 + .5648E-05 + .6165E-05 + .6706E-05 + .7228E-05 + .7621E-05 + .7906E-05 + .8155E-05 + .8314E-05 + .8434E-05 + .8472E-05 + .8584E-05 + .8496E-05 + .8180E-05 + .7776E-05 + .7242E-05 + .6580E-05 + .5864E-05 + .5132E-05 + .4400E-05 + .3746E-05 + .3144E-05 + .2565E-05 + .1995E-05 + .1484E-05 + .1039E-05 + .7284E-06 + .5104E-06 + .3576E-06 + .2591E-06 + .2082E-06 + .1612E-06 + .1162E-06 + .8384E-07 + .6747E-07 + .5721E-07 + .4850E-07 + .4138E-07 + .3793E-07 + .3477E-07 + .2979E-07 + .2397E-07 + .1930E-07 + .1776E-07 + .1641E-05 + .1765E-05 + .1887E-05 + .2015E-05 + .2149E-05 + .2298E-05 + .2461E-05 + .2658E-05 + .2836E-05 + .3060E-05 + .3302E-05 + .3568E-05 + .3873E-05 + .4246E-05 + .4682E-05 + .5147E-05 + .5682E-05 + .6243E-05 + .6828E-05 + .7384E-05 + .7792E-05 + .8102E-05 + .8320E-05 + .8407E-05 + .8564E-05 + .8606E-05 + .8751E-05 + .8664E-05 + .8329E-05 + .7955E-05 + .7393E-05 + .6683E-05 + .5895E-05 + .5114E-05 + .4339E-05 + .3654E-05 + .3020E-05 + .2415E-05 + .1848E-05 + .1342E-05 + .9120E-06 + .6444E-06 + .4553E-06 + .3217E-06 + .2340E-06 + .1893E-06 + .1484E-06 + .1096E-06 + .8089E-07 + .6609E-07 + .5665E-07 + .4857E-07 + .4186E-07 + .3846E-07 + .3534E-07 + .3010E-07 + .2391E-07 + .1899E-07 + .1739E-07 + .1641E-05 + .1765E-05 + .1889E-05 + .2017E-05 + .2151E-05 + .2298E-05 + .2458E-05 + .2649E-05 + .2827E-05 + .3063E-05 + .3290E-05 + .3565E-05 + .3868E-05 + .4246E-05 + .4677E-05 + .5150E-05 + .5696E-05 + .6289E-05 + .6898E-05 + .7464E-05 + .7915E-05 + .8244E-05 + .8478E-05 + .8599E-05 + .8780E-05 + .8833E-05 + .9001E-05 + .8911E-05 + .8544E-05 + .8139E-05 + .7543E-05 + .6776E-05 + .5938E-05 + .5131E-05 + .4313E-05 + .3587E-05 + .2913E-05 + .2281E-05 + .1699E-05 + .1197E-05 + .7895E-06 + .5617E-06 + .3997E-06 + .2844E-06 + .2081E-06 + .1695E-06 + .1347E-06 + .1020E-06 + .7721E-07 + .6405E-07 + .5548E-07 + .4805E-07 + .4183E-07 + .3855E-07 + .3553E-07 + .3009E-07 + .2364E-07 + .1864E-07 + .1701E-07 + .1662E-05 + .1782E-05 + .1906E-05 + .2035E-05 + .2170E-05 + .2316E-05 + .2477E-05 + .2661E-05 + .2850E-05 + .3084E-05 + .3306E-05 + .3588E-05 + .3887E-05 + .4266E-05 + .4690E-05 + .5172E-05 + .5730E-05 + .6354E-05 + .6982E-05 + .7551E-05 + .8059E-05 + .8406E-05 + .8676E-05 + .8874E-05 + .9075E-05 + .9144E-05 + .9333E-05 + .9238E-05 + .8830E-05 + .8369E-05 + .7731E-05 + .6897E-05 + .6016E-05 + .5187E-05 + .4320E-05 + .3547E-05 + .2826E-05 + .2166E-05 + .1566E-05 + .1067E-05 + .6833E-06 + .4816E-06 + .3395E-06 + .2393E-06 + .1772E-06 + .1454E-06 + .1173E-06 + .9149E-07 + .7137E-07 + .6013E-07 + .5253E-07 + .4590E-07 + .4029E-07 + .3731E-07 + .3455E-07 + .2909E-07 + .2275E-07 + .1808E-07 + .1653E-07 + .1663E-05 + .1785E-05 + .1912E-05 + .2043E-05 + .2182E-05 + .2334E-05 + .2498E-05 + .2694E-05 + .2876E-05 + .3117E-05 + .3357E-05 + .3625E-05 + .3920E-05 + .4290E-05 + .4720E-05 + .5222E-05 + .5781E-05 + .6407E-05 + .7051E-05 + .7659E-05 + .8182E-05 + .8592E-05 + .8893E-05 + .9141E-05 + .9353E-05 + .9464E-05 + .9643E-05 + .9524E-05 + .9091E-05 + .8572E-05 + .7897E-05 + .7029E-05 + .6099E-05 + .5220E-05 + .4330E-05 + .3508E-05 + .2745E-05 + .2056E-05 + .1448E-05 + .9526E-06 + .5878E-06 + .4123E-06 + .2892E-06 + .2028E-06 + .1520E-06 + .1257E-06 + .1029E-06 + .8268E-07 + .6646E-07 + .5686E-07 + .5011E-07 + .4416E-07 + .3909E-07 + .3637E-07 + .3385E-07 + .2834E-07 + .2206E-07 + .1767E-07 + .1618E-07 + .1663E-05 + .1789E-05 + .1918E-05 + .2051E-05 + .2193E-05 + .2349E-05 + .2517E-05 + .2722E-05 + .2899E-05 + .3145E-05 + .3402E-05 + .3658E-05 + .3953E-05 + .4315E-05 + .4752E-05 + .5273E-05 + .5835E-05 + .6463E-05 + .7121E-05 + .7766E-05 + .8301E-05 + .8771E-05 + .9103E-05 + .9400E-05 + .9622E-05 + .9771E-05 + .9936E-05 + .9797E-05 + .9337E-05 + .8765E-05 + .8053E-05 + .7153E-05 + .6175E-05 + .5246E-05 + .4333E-05 + .3465E-05 + .2665E-05 + .1950E-05 + .1339E-05 + .8505E-06 + .5061E-06 + .3530E-06 + .2462E-06 + .1718E-06 + .1304E-06 + .1085E-06 + .9015E-07 + .7466E-07 + .6184E-07 + .5374E-07 + .4777E-07 + .4246E-07 + .3790E-07 + .3544E-07 + .3313E-07 + .2759E-07 + .2138E-07 + .1726E-07 + .1583E-07 + .1678E-05 + .1811E-05 + .1943E-05 + .2070E-05 + .2207E-05 + .2358E-05 + .2526E-05 + .2721E-05 + .2914E-05 + .3153E-05 + .3403E-05 + .3681E-05 + .3990E-05 + .4358E-05 + .4805E-05 + .5329E-05 + .5914E-05 + .6560E-05 + .7226E-05 + .7871E-05 + .8423E-05 + .8907E-05 + .9267E-05 + .9613E-05 + .9850E-05 + .9982E-05 + .1013E-04 + .1001E-04 + .9501E-05 + .8924E-05 + .8170E-05 + .7232E-05 + .6232E-05 + .5256E-05 + .4311E-05 + .3411E-05 + .2583E-05 + .1849E-05 + .1241E-05 + .7620E-06 + .4404E-06 + .3041E-06 + .2099E-06 + .1449E-06 + .1113E-06 + .9331E-07 + .7870E-07 + .6717E-07 + .5732E-07 + .5058E-07 + .4536E-07 + .4067E-07 + .3660E-07 + .3439E-07 + .3231E-07 + .2675E-07 + .2063E-07 + .1679E-07 + .1542E-07 + .1672E-05 + .1811E-05 + .1947E-05 + .2073E-05 + .2209E-05 + .2359E-05 + .2529E-05 + .2721E-05 + .2924E-05 + .3160E-05 + .3405E-05 + .3701E-05 + .4015E-05 + .4398E-05 + .4853E-05 + .5383E-05 + .5989E-05 + .6645E-05 + .7316E-05 + .7965E-05 + .8525E-05 + .9022E-05 + .9404E-05 + .9801E-05 + .1007E-04 + .1019E-04 + .1033E-04 + .1019E-04 + .9654E-05 + .9054E-05 + .8260E-05 + .7287E-05 + .6262E-05 + .5252E-05 + .4272E-05 + .3343E-05 + .2497E-05 + .1752E-05 + .1146E-05 + .6785E-06 + .3788E-06 + .2596E-06 + .1779E-06 + .1219E-06 + .9480E-07 + .8003E-07 + .6852E-07 + .6025E-07 + .5298E-07 + .4748E-07 + .4294E-07 + .3884E-07 + .3525E-07 + .3328E-07 + .3141E-07 + .2586E-07 + .1985E-07 + .1629E-07 + .1499E-07 + .1632E-05 + .1778E-05 + .1922E-05 + .2055E-05 + .2196E-05 + .2355E-05 + .2530E-05 + .2733E-05 + .2937E-05 + .3181E-05 + .3421E-05 + .3732E-05 + .4037E-05 + .4449E-05 + .4910E-05 + .5454E-05 + .6076E-05 + .6732E-05 + .7404E-05 + .8066E-05 + .8622E-05 + .9129E-05 + .9525E-05 + .9980E-05 + .1029E-04 + .1044E-04 + .1055E-04 + .1036E-04 + .9823E-05 + .9163E-05 + .8333E-05 + .7324E-05 + .6268E-05 + .5243E-05 + .4219E-05 + .3263E-05 + .2411E-05 + .1665E-05 + .1055E-05 + .5996E-06 + .3202E-06 + .2190E-06 + .1498E-06 + .1024E-06 + .8063E-07 + .6855E-07 + .5958E-07 + .5398E-07 + .4890E-07 + .4451E-07 + .4061E-07 + .3705E-07 + .3391E-07 + .3216E-07 + .3051E-07 + .2497E-07 + .1908E-07 + .1579E-07 + .1454E-07 + .1610E-05 + .1758E-05 + .1904E-05 + .2040E-05 + .2184E-05 + .2346E-05 + .2523E-05 + .2729E-05 + .2935E-05 + .3182E-05 + .3425E-05 + .3736E-05 + .4056E-05 + .4479E-05 + .4950E-05 + .5499E-05 + .6142E-05 + .6798E-05 + .7468E-05 + .8142E-05 + .8713E-05 + .9240E-05 + .9663E-05 + .1023E-04 + .1053E-04 + .1067E-04 + .1073E-04 + .1051E-04 + .9957E-05 + .9255E-05 + .8398E-05 + .7350E-05 + .6265E-05 + .5216E-05 + .4166E-05 + .3199E-05 + .2347E-05 + .1602E-05 + .9836E-06 + .5405E-06 + .2817E-06 + .1897E-06 + .1277E-06 + .8603E-07 + .6855E-07 + .5870E-07 + .5178E-07 + .4834E-07 + .4512E-07 + .4172E-07 + .3839E-07 + .3533E-07 + .3260E-07 + .3107E-07 + .2962E-07 + .2410E-07 + .1834E-07 + .1529E-07 + .1411E-07 + .1598E-05 + .1744E-05 + .1889E-05 + .2024E-05 + .2168E-05 + .2328E-05 + .2505E-05 + .2708E-05 + .2917E-05 + .3162E-05 + .3414E-05 + .3711E-05 + .4066E-05 + .4484E-05 + .4968E-05 + .5515E-05 + .6179E-05 + .6834E-05 + .7499E-05 + .8181E-05 + .8781E-05 + .9338E-05 + .9795E-05 + .1052E-04 + .1077E-04 + .1087E-04 + .1085E-04 + .1063E-04 + .1004E-04 + .9315E-05 + .8441E-05 + .7352E-05 + .6244E-05 + .5165E-05 + .4108E-05 + .3140E-05 + .2295E-05 + .1555E-05 + .9252E-06 + .4939E-06 + .2552E-06 + .1674E-06 + .1099E-06 + .7210E-07 + .5815E-07 + .5015E-07 + .4491E-07 + .4320E-07 + .4155E-07 + .3901E-07 + .3621E-07 + .3361E-07 + .3128E-07 + .2995E-07 + .2869E-07 + .2322E-07 + .1758E-07 + .1478E-07 + .1366E-07 + .1575E-05 + .1716E-05 + .1856E-05 + .1990E-05 + .2132E-05 + .2292E-05 + .2469E-05 + .2677E-05 + .2883E-05 + .3156E-05 + .3422E-05 + .3705E-05 + .4074E-05 + .4491E-05 + .4992E-05 + .5564E-05 + .6209E-05 + .6857E-05 + .7533E-05 + .8223E-05 + .8832E-05 + .9409E-05 + .9866E-05 + .1066E-04 + .1091E-04 + .1098E-04 + .1093E-04 + .1070E-04 + .1010E-04 + .9347E-05 + .8441E-05 + .7338E-05 + .6200E-05 + .5114E-05 + .4054E-05 + .3088E-05 + .2248E-05 + .1507E-05 + .8826E-06 + .4547E-06 + .2337E-06 + .1489E-06 + .9490E-07 + .6047E-07 + .4937E-07 + .4288E-07 + .3898E-07 + .3863E-07 + .3828E-07 + .3651E-07 + .3418E-07 + .3200E-07 + .3003E-07 + .2890E-07 + .2781E-07 + .2238E-07 + .1687E-07 + .1429E-07 + .1323E-07 + .1538E-05 + .1672E-05 + .1807E-05 + .1938E-05 + .2077E-05 + .2236E-05 + .2412E-05 + .2626E-05 + .2826E-05 + .3133E-05 + .3411E-05 + .3680E-05 + .4053E-05 + .4469E-05 + .4985E-05 + .5587E-05 + .6195E-05 + .6830E-05 + .7517E-05 + .8210E-05 + .8818E-05 + .9408E-05 + .9850E-05 + .1068E-04 + .1095E-04 + .1098E-04 + .1094E-04 + .1069E-04 + .1007E-04 + .9308E-05 + .8370E-05 + .7270E-05 + .6108E-05 + .5029E-05 + .3974E-05 + .3017E-05 + .2189E-05 + .1450E-05 + .8397E-06 + .4167E-06 + .2134E-06 + .1390E-06 + .9058E-07 + .5902E-07 + .4814E-07 + .4194E-07 + .3821E-07 + .3792E-07 + .3763E-07 + .3612E-07 + .3413E-07 + .3224E-07 + .3050E-07 + .2925E-07 + .2805E-07 + .2302E-07 + .1754E-07 + .1449E-07 + .1331E-07 + .1509E-05 + .1636E-05 + .1765E-05 + .1888E-05 + .2024E-05 + .2181E-05 + .2361E-05 + .2572E-05 + .2792E-05 + .3074E-05 + .3362E-05 + .3662E-05 + .4033E-05 + .4456E-05 + .4960E-05 + .5516E-05 + .6133E-05 + .6773E-05 + .7467E-05 + .8167E-05 + .8757E-05 + .9287E-05 + .9749E-05 + .1031E-04 + .1055E-04 + .1063E-04 + .1071E-04 + .1058E-04 + .1006E-04 + .9315E-05 + .8357E-05 + .7243E-05 + .6058E-05 + .4929E-05 + .3871E-05 + .2935E-05 + .2120E-05 + .1413E-05 + .8282E-06 + .4149E-06 + .2017E-06 + .1338E-06 + .8876E-07 + .5888E-07 + .4790E-07 + .4183E-07 + .3814E-07 + .3774E-07 + .3735E-07 + .3604E-07 + .3436E-07 + .3276E-07 + .3123E-07 + .2982E-07 + .2847E-07 + .2392E-07 + .1846E-07 + .1479E-07 + .1347E-07 + .1482E-05 + .1602E-05 + .1726E-05 + .1843E-05 + .1976E-05 + .2131E-05 + .2314E-05 + .2523E-05 + .2761E-05 + .3023E-05 + .3320E-05 + .3645E-05 + .4011E-05 + .4440E-05 + .4931E-05 + .5449E-05 + .6069E-05 + .6713E-05 + .7412E-05 + .8109E-05 + .8682E-05 + .9167E-05 + .9640E-05 + .9983E-05 + .1020E-04 + .1031E-04 + .1049E-04 + .1046E-04 + .1004E-04 + .9306E-05 + .8331E-05 + .7206E-05 + .6001E-05 + .4836E-05 + .3778E-05 + .2858E-05 + .2057E-05 + .1378E-05 + .8186E-06 + .4119E-06 + .1922E-06 + .1295E-06 + .8724E-07 + .5877E-07 + .4768E-07 + .4174E-07 + .3808E-07 + .3757E-07 + .3708E-07 + .3597E-07 + .3460E-07 + .3329E-07 + .3200E-07 + .3042E-07 + .2891E-07 + .2486E-07 + .1943E-07 + .1511E-07 + .1364E-07 + .1459E-05 + .1577E-05 + .1698E-05 + .1813E-05 + .1944E-05 + .2098E-05 + .2282E-05 + .2495E-05 + .2737E-05 + .3010E-05 + .3310E-05 + .3633E-05 + .3982E-05 + .4413E-05 + .4885E-05 + .5409E-05 + .6000E-05 + .6635E-05 + .7342E-05 + .7994E-05 + .8557E-05 + .9059E-05 + .9502E-05 + .9835E-05 + .1003E-04 + .1015E-04 + .1030E-04 + .1033E-04 + .9953E-05 + .9230E-05 + .8251E-05 + .7125E-05 + .5915E-05 + .4772E-05 + .3717E-05 + .2797E-05 + .2007E-05 + .1354E-05 + .8145E-06 + .4014E-06 + .1895E-06 + .1283E-06 + .8684E-07 + .5879E-07 + .4756E-07 + .4174E-07 + .3810E-07 + .3749E-07 + .3689E-07 + .3597E-07 + .3493E-07 + .3391E-07 + .3286E-07 + .3109E-07 + .2942E-07 + .2589E-07 + .2049E-07 + .1547E-07 + .1384E-07 + .1441E-05 + .1557E-05 + .1675E-05 + .1788E-05 + .1918E-05 + .2072E-05 + .2256E-05 + .2472E-05 + .2717E-05 + .2996E-05 + .3295E-05 + .3613E-05 + .3954E-05 + .4377E-05 + .4837E-05 + .5370E-05 + .5938E-05 + .6573E-05 + .7277E-05 + .7890E-05 + .8435E-05 + .8943E-05 + .9366E-05 + .9679E-05 + .9866E-05 + .9994E-05 + .1012E-04 + .1021E-04 + .9862E-05 + .9150E-05 + .8176E-05 + .7055E-05 + .5848E-05 + .4719E-05 + .3664E-05 + .2754E-05 + .1976E-05 + .1335E-05 + .8079E-06 + .3965E-06 + .1864E-06 + .1269E-06 + .8646E-07 + .5889E-07 + .4751E-07 + .4179E-07 + .3817E-07 + .3746E-07 + .3675E-07 + .3603E-07 + .3530E-07 + .3459E-07 + .3378E-07 + .3182E-07 + .2997E-07 + .2700E-07 + .2165E-07 + .1586E-07 + .1406E-07 + .1430E-05 + .1544E-05 + .1659E-05 + .1771E-05 + .1900E-05 + .2054E-05 + .2239E-05 + .2457E-05 + .2705E-05 + .2979E-05 + .3272E-05 + .3578E-05 + .3925E-05 + .4325E-05 + .4785E-05 + .5331E-05 + .5884E-05 + .6532E-05 + .7219E-05 + .7799E-05 + .8316E-05 + .8810E-05 + .9232E-05 + .9507E-05 + .9713E-05 + .9836E-05 + .9963E-05 + .1012E-04 + .9765E-05 + .9062E-05 + .8108E-05 + .6998E-05 + .5810E-05 + .4681E-05 + .3622E-05 + .2735E-05 + .1970E-05 + .1323E-05 + .7974E-06 + .3998E-06 + .1826E-06 + .1260E-06 + .8692E-07 + .5997E-07 + .4823E-07 + .4249E-07 + .3880E-07 + .3793E-07 + .3707E-07 + .3644E-07 + .3591E-07 + .3538E-07 + .3473E-07 + .3266E-07 + .3070E-07 + .2801E-07 + .2278E-07 + .1657E-07 + .1463E-07 + .1426E-05 + .1541E-05 + .1657E-05 + .1769E-05 + .1899E-05 + .2054E-05 + .2238E-05 + .2455E-05 + .2701E-05 + .2967E-05 + .3256E-05 + .3569E-05 + .3909E-05 + .4305E-05 + .4765E-05 + .5317E-05 + .5862E-05 + .6491E-05 + .7152E-05 + .7728E-05 + .8223E-05 + .8688E-05 + .9094E-05 + .9358E-05 + .9577E-05 + .9712E-05 + .9852E-05 + .9976E-05 + .9641E-05 + .8954E-05 + .8035E-05 + .6945E-05 + .5777E-05 + .4648E-05 + .3598E-05 + .2728E-05 + .1970E-05 + .1328E-05 + .8020E-06 + .4004E-06 + .1815E-06 + .1270E-06 + .8879E-07 + .6210E-07 + .4975E-07 + .4388E-07 + .4002E-07 + .3892E-07 + .3786E-07 + .3721E-07 + .3675E-07 + .3630E-07 + .3572E-07 + .3361E-07 + .3162E-07 + .2891E-07 + .2389E-07 + .1765E-07 + .1558E-07 + .1425E-05 + .1542E-05 + .1661E-05 + .1776E-05 + .1907E-05 + .2062E-05 + .2246E-05 + .2458E-05 + .2702E-05 + .2957E-05 + .3242E-05 + .3573E-05 + .3900E-05 + .4301E-05 + .4762E-05 + .5315E-05 + .5857E-05 + .6445E-05 + .7072E-05 + .7664E-05 + .8141E-05 + .8568E-05 + .8947E-05 + .9217E-05 + .9445E-05 + .9601E-05 + .9764E-05 + .9791E-05 + .9491E-05 + .8829E-05 + .7952E-05 + .6890E-05 + .5744E-05 + .4615E-05 + .3583E-05 + .2728E-05 + .1971E-05 + .1343E-05 + .8160E-06 + .3989E-06 + .1820E-06 + .1287E-06 + .9097E-07 + .6432E-07 + .5134E-07 + .4532E-07 + .4129E-07 + .3996E-07 + .3867E-07 + .3800E-07 + .3762E-07 + .3725E-07 + .3673E-07 + .3459E-07 + .3257E-07 + .2984E-07 + .2506E-07 + .1880E-07 + .1660E-07 + .1424E-05 + .1544E-05 + .1668E-05 + .1788E-05 + .1922E-05 + .2077E-05 + .2258E-05 + .2465E-05 + .2700E-05 + .2945E-05 + .3235E-05 + .3560E-05 + .3891E-05 + .4296E-05 + .4766E-05 + .5314E-05 + .5889E-05 + .6467E-05 + .7060E-05 + .7606E-05 + .8059E-05 + .8423E-05 + .8749E-05 + .9008E-05 + .9237E-05 + .9429E-05 + .9579E-05 + .9595E-05 + .9278E-05 + .8658E-05 + .7831E-05 + .6805E-05 + .5688E-05 + .4579E-05 + .3575E-05 + .2727E-05 + .1978E-05 + .1356E-05 + .8317E-06 + .4096E-06 + .1901E-06 + .1340E-06 + .9439E-07 + .6652E-07 + .5290E-07 + .4674E-07 + .4254E-07 + .4096E-07 + .3943E-07 + .3876E-07 + .3846E-07 + .3817E-07 + .3773E-07 + .3555E-07 + .3351E-07 + .3075E-07 + .2624E-07 + .1999E-07 + .1765E-07 + .1427E-05 + .1551E-05 + .1680E-05 + .1805E-05 + .1943E-05 + .2099E-05 + .2277E-05 + .2478E-05 + .2704E-05 + .2941E-05 + .3237E-05 + .3552E-05 + .3893E-05 + .4303E-05 + .4785E-05 + .5327E-05 + .5943E-05 + .6519E-05 + .7079E-05 + .7566E-05 + .7993E-05 + .8292E-05 + .8561E-05 + .8804E-05 + .9032E-05 + .9261E-05 + .9392E-05 + .9417E-05 + .9072E-05 + .8497E-05 + .7722E-05 + .6732E-05 + .5643E-05 + .4555E-05 + .3579E-05 + .2733E-05 + .1991E-05 + .1374E-05 + .8510E-06 + .4253E-06 + .2012E-06 + .1408E-06 + .9853E-07 + .6895E-07 + .5463E-07 + .4831E-07 + .4392E-07 + .4208E-07 + .4031E-07 + .3962E-07 + .3941E-07 + .3920E-07 + .3883E-07 + .3663E-07 + .3455E-07 + .3177E-07 + .2754E-07 + .2132E-07 + .1882E-07 + .1447E-05 + .1575E-05 + .1708E-05 + .1835E-05 + .1970E-05 + .2124E-05 + .2300E-05 + .2498E-05 + .2725E-05 + .2959E-05 + .3240E-05 + .3549E-05 + .3937E-05 + .4374E-05 + .4872E-05 + .5410E-05 + .5990E-05 + .6512E-05 + .6994E-05 + .7395E-05 + .7738E-05 + .8009E-05 + .8207E-05 + .8410E-05 + .8604E-05 + .8792E-05 + .8954E-05 + .9025E-05 + .8657E-05 + .8176E-05 + .7569E-05 + .6707E-05 + .5692E-05 + .4643E-05 + .3664E-05 + .2803E-05 + .2073E-05 + .1464E-05 + .9182E-06 + .4719E-06 + .2267E-06 + .1547E-06 + .1056E-06 + .7208E-07 + .5691E-07 + .5037E-07 + .4574E-07 + .4360E-07 + .4156E-07 + .4084E-07 + .4073E-07 + .4061E-07 + .4032E-07 + .3806E-07 + .3592E-07 + .3310E-07 + .2916E-07 + .2292E-07 + .2024E-07 + .1464E-05 + .1597E-05 + .1733E-05 + .1863E-05 + .1995E-05 + .2147E-05 + .2320E-05 + .2513E-05 + .2739E-05 + .2968E-05 + .3241E-05 + .3548E-05 + .3970E-05 + .4435E-05 + .4956E-05 + .5505E-05 + .6056E-05 + .6532E-05 + .6954E-05 + .7287E-05 + .7568E-05 + .7809E-05 + .7959E-05 + .8123E-05 + .8279E-05 + .8431E-05 + .8597E-05 + .8682E-05 + .8303E-05 + .7910E-05 + .7433E-05 + .6676E-05 + .5736E-05 + .4731E-05 + .3760E-05 + .2888E-05 + .2164E-05 + .1558E-05 + .9882E-06 + .5201E-06 + .2544E-06 + .1697E-06 + .1131E-06 + .7544E-07 + .5934E-07 + .5257E-07 + .4768E-07 + .4523E-07 + .4289E-07 + .4215E-07 + .4213E-07 + .4211E-07 + .4190E-07 + .3959E-07 + .3740E-07 + .3452E-07 + .3091E-07 + .2467E-07 + .2179E-07 + .1463E-05 + .1600E-05 + .1739E-05 + .1871E-05 + .2002E-05 + .2148E-05 + .2314E-05 + .2499E-05 + .2712E-05 + .2931E-05 + .3216E-05 + .3534E-05 + .3940E-05 + .4435E-05 + .4995E-05 + .5599E-05 + .6145E-05 + .6601E-05 + .7019E-05 + .7332E-05 + .7614E-05 + .7816E-05 + .7971E-05 + .8094E-05 + .8187E-05 + .8313E-05 + .8403E-05 + .8409E-05 + .8049E-05 + .7750E-05 + .7302E-05 + .6583E-05 + .5730E-05 + .4791E-05 + .3864E-05 + .3005E-05 + .2266E-05 + .1637E-05 + .1048E-05 + .5568E-06 + .2801E-06 + .1835E-06 + .1202E-06 + .7877E-07 + .6172E-07 + .5474E-07 + .4959E-07 + .4680E-07 + .4416E-07 + .4340E-07 + .4348E-07 + .4356E-07 + .4344E-07 + .4107E-07 + .3883E-07 + .3592E-07 + .3268E-07 + .2649E-07 + .2340E-07 + .1471E-05 + .1611E-05 + .1753E-05 + .1887E-05 + .2016E-05 + .2160E-05 + .2322E-05 + .2504E-05 + .2711E-05 + .2932E-05 + .3220E-05 + .3565E-05 + .3962E-05 + .4469E-05 + .5052E-05 + .5677E-05 + .6224E-05 + .6678E-05 + .7078E-05 + .7372E-05 + .7629E-05 + .7799E-05 + .7921E-05 + .8012E-05 + .8074E-05 + .8163E-05 + .8193E-05 + .8138E-05 + .7816E-05 + .7576E-05 + .7165E-05 + .6524E-05 + .5751E-05 + .4892E-05 + .4017E-05 + .3157E-05 + .2394E-05 + .1732E-05 + .1124E-05 + .6218E-06 + .3255E-06 + .2107E-06 + .1364E-06 + .8828E-07 + .6802E-07 + .6002E-07 + .5372E-07 + .4939E-07 + .4541E-07 + .4409E-07 + .4394E-07 + .4379E-07 + .4348E-07 + .4147E-07 + .3955E-07 + .3660E-07 + .3325E-07 + .2743E-07 + .2449E-07 + .1485E-05 + .1626E-05 + .1770E-05 + .1903E-05 + .2031E-05 + .2174E-05 + .2336E-05 + .2523E-05 + .2733E-05 + .2970E-05 + .3248E-05 + .3636E-05 + .4036E-05 + .4528E-05 + .5112E-05 + .5707E-05 + .6259E-05 + .6734E-05 + .7093E-05 + .7374E-05 + .7569E-05 + .7715E-05 + .7757E-05 + .7830E-05 + .7899E-05 + .7938E-05 + .7925E-05 + .7831E-05 + .7571E-05 + .7350E-05 + .6989E-05 + .6477E-05 + .5782E-05 + .5029E-05 + .4222E-05 + .3344E-05 + .2547E-05 + .1842E-05 + .1219E-05 + .7301E-06 + .4035E-06 + .2600E-06 + .1675E-06 + .1079E-06 + .8036E-07 + .7004E-07 + .6106E-07 + .5323E-07 + .4641E-07 + .4384E-07 + .4302E-07 + .4222E-07 + .4140E-07 + .4023E-07 + .3909E-07 + .3614E-07 + .3206E-07 + .2696E-07 + .2468E-07 + .1509E-05 + .1647E-05 + .1790E-05 + .1926E-05 + .2059E-05 + .2205E-05 + .2372E-05 + .2563E-05 + .2780E-05 + .3019E-05 + .3324E-05 + .3702E-05 + .4107E-05 + .4614E-05 + .5195E-05 + .5775E-05 + .6320E-05 + .6772E-05 + .7102E-05 + .7357E-05 + .7502E-05 + .7591E-05 + .7605E-05 + .7640E-05 + .7670E-05 + .7668E-05 + .7638E-05 + .7565E-05 + .7363E-05 + .7170E-05 + .6861E-05 + .6434E-05 + .5828E-05 + .5160E-05 + .4403E-05 + .3545E-05 + .2719E-05 + .1978E-05 + .1346E-05 + .8573E-06 + .5066E-06 + .3233E-06 + .2064E-06 + .1317E-06 + .9482E-07 + .8164E-07 + .6932E-07 + .5730E-07 + .4737E-07 + .4354E-07 + .4207E-07 + .4066E-07 + .3937E-07 + .3898E-07 + .3859E-07 + .3564E-07 + .3088E-07 + .2647E-07 + .2485E-07 + .1532E-05 + .1663E-05 + .1803E-05 + .1942E-05 + .2083E-05 + .2234E-05 + .2408E-05 + .2601E-05 + .2825E-05 + .3057E-05 + .3410E-05 + .3743E-05 + .4154E-05 + .4690E-05 + .5261E-05 + .5834E-05 + .6361E-05 + .6763E-05 + .7068E-05 + .7290E-05 + .7392E-05 + .7405E-05 + .7419E-05 + .7407E-05 + .7375E-05 + .7339E-05 + .7308E-05 + .7282E-05 + .7136E-05 + .6976E-05 + .6721E-05 + .6358E-05 + .5850E-05 + .5259E-05 + .4548E-05 + .3740E-05 + .2892E-05 + .2122E-05 + .1493E-05 + .1001E-05 + .6367E-06 + .4124E-06 + .2671E-06 + .1730E-06 + .1236E-06 + .1022E-06 + .8322E-07 + .6584E-07 + .5209E-07 + .4663E-07 + .4428E-07 + .4204E-07 + .4004E-07 + .3950E-07 + .3897E-07 + .3569E-07 + .3050E-07 + .2607E-07 + .2456E-07 + .1529E-05 + .1668E-05 + .1811E-05 + .1958E-05 + .2106E-05 + .2265E-05 + .2445E-05 + .2649E-05 + .2864E-05 + .3115E-05 + .3439E-05 + .3802E-05 + .4206E-05 + .4704E-05 + .5263E-05 + .5794E-05 + .6294E-05 + .6677E-05 + .6961E-05 + .7152E-05 + .7242E-05 + .7226E-05 + .7227E-05 + .7183E-05 + .7154E-05 + .7125E-05 + .7083E-05 + .7054E-05 + .6898E-05 + .6774E-05 + .6566E-05 + .6245E-05 + .5800E-05 + .5276E-05 + .4630E-05 + .3868E-05 + .3057E-05 + .2308E-05 + .1693E-05 + .1185E-05 + .8018E-06 + .5296E-06 + .3497E-06 + .2310E-06 + .1654E-06 + .1300E-06 + .1010E-06 + .7672E-07 + .5826E-07 + .5084E-07 + .4740E-07 + .4419E-07 + .4134E-07 + .4033E-07 + .3934E-07 + .3565E-07 + .3016E-07 + .2551E-07 + .2393E-07 + .1517E-05 + .1664E-05 + .1810E-05 + .1964E-05 + .2119E-05 + .2286E-05 + .2469E-05 + .2684E-05 + .2889E-05 + .3161E-05 + .3446E-05 + .3846E-05 + .4240E-05 + .4688E-05 + .5228E-05 + .5712E-05 + .6179E-05 + .6548E-05 + .6810E-05 + .6971E-05 + .7053E-05 + .7017E-05 + .7002E-05 + .6934E-05 + .6917E-05 + .6899E-05 + .6847E-05 + .6809E-05 + .6641E-05 + .6550E-05 + .6386E-05 + .6105E-05 + .5718E-05 + .5259E-05 + .4681E-05 + .3972E-05 + .3215E-05 + .2505E-05 + .1915E-05 + .1397E-05 + .1000E-05 + .6745E-06 + .4549E-06 + .3068E-06 + .2202E-06 + .1646E-06 + .1220E-06 + .8893E-07 + .6483E-07 + .5514E-07 + .5047E-07 + .4619E-07 + .4246E-07 + .4096E-07 + .3951E-07 + .3542E-07 + .2966E-07 + .2483E-07 + .2320E-07 + .1516E-05 + .1656E-05 + .1796E-05 + .1944E-05 + .2097E-05 + .2263E-05 + .2448E-05 + .2662E-05 + .2897E-05 + .3138E-05 + .3468E-05 + .3841E-05 + .4224E-05 + .4642E-05 + .5132E-05 + .5593E-05 + .5994E-05 + .6340E-05 + .6570E-05 + .6694E-05 + .6756E-05 + .6719E-05 + .6677E-05 + .6632E-05 + .6612E-05 + .6582E-05 + .6534E-05 + .6502E-05 + .6427E-05 + .6325E-05 + .6203E-05 + .5987E-05 + .5661E-05 + .5256E-05 + .4717E-05 + .4074E-05 + .3374E-05 + .2687E-05 + .2097E-05 + .1573E-05 + .1138E-05 + .8095E-06 + .5756E-06 + .4093E-06 + .2944E-06 + .2093E-06 + .1480E-06 + .1035E-06 + .7245E-07 + .6007E-07 + .5398E-07 + .4851E-07 + .4380E-07 + .4178E-07 + .3986E-07 + .3535E-07 + .2929E-07 + .2428E-07 + .2260E-07 + .1519E-05 + .1657E-05 + .1795E-05 + .1941E-05 + .2095E-05 + .2261E-05 + .2449E-05 + .2664E-05 + .2921E-05 + .3146E-05 + .3502E-05 + .3854E-05 + .4231E-05 + .4626E-05 + .5077E-05 + .5524E-05 + .5883E-05 + .6213E-05 + .6421E-05 + .6525E-05 + .6569E-05 + .6532E-05 + .6470E-05 + .6430E-05 + .6404E-05 + .6362E-05 + .6317E-05 + .6283E-05 + .6263E-05 + .6152E-05 + .6067E-05 + .5901E-05 + .5632E-05 + .5279E-05 + .4787E-05 + .4211E-05 + .3562E-05 + .2891E-05 + .2296E-05 + .1769E-05 + .1301E-05 + .9278E-06 + .6618E-06 + .4721E-06 + .3399E-06 + .2382E-06 + .1653E-06 + .1125E-06 + .7660E-07 + .6215E-07 + .5482E-07 + .4835E-07 + .4291E-07 + .4089E-07 + .3896E-07 + .3468E-07 + .2897E-07 + .2420E-07 + .2260E-07 + .1502E-05 + .1652E-05 + .1797E-05 + .1950E-05 + .2107E-05 + .2275E-05 + .2464E-05 + .2681E-05 + .2931E-05 + .3177E-05 + .3500E-05 + .3840E-05 + .4216E-05 + .4603E-05 + .5034E-05 + .5479E-05 + .5846E-05 + .6169E-05 + .6375E-05 + .6495E-05 + .6522E-05 + .6491E-05 + .6416E-05 + .6343E-05 + .6303E-05 + .6246E-05 + .6206E-05 + .6147E-05 + .6096E-05 + .5984E-05 + .5928E-05 + .5780E-05 + .5568E-05 + .5270E-05 + .4854E-05 + .4357E-05 + .3744E-05 + .3075E-05 + .2464E-05 + .1938E-05 + .1472E-05 + .1036E-05 + .7288E-06 + .5129E-06 + .3697E-06 + .2589E-06 + .1782E-06 + .1187E-06 + .7902E-07 + .6286E-07 + .5441E-07 + .4709E-07 + .4109E-07 + .3926E-07 + .3752E-07 + .3371E-07 + .2859E-07 + .2425E-07 + .2277E-07 + .1501E-05 + .1652E-05 + .1800E-05 + .1958E-05 + .2122E-05 + .2299E-05 + .2493E-05 + .2714E-05 + .2959E-05 + .3219E-05 + .3510E-05 + .3826E-05 + .4187E-05 + .4580E-05 + .5011E-05 + .5377E-05 + .5717E-05 + .6007E-05 + .6251E-05 + .6401E-05 + .6436E-05 + .6403E-05 + .6346E-05 + .6259E-05 + .6191E-05 + .6117E-05 + .6056E-05 + .5980E-05 + .5907E-05 + .5812E-05 + .5752E-05 + .5614E-05 + .5428E-05 + .5205E-05 + .4897E-05 + .4413E-05 + .3868E-05 + .3129E-05 + .2509E-05 + .2051E-05 + .1654E-05 + .1155E-05 + .8060E-06 + .5626E-06 + .4060E-06 + .2842E-06 + .1941E-06 + .1264E-06 + .8232E-07 + .6419E-07 + .5453E-07 + .4632E-07 + .3973E-07 + .3807E-07 + .3649E-07 + .3308E-07 + .2849E-07 + .2454E-07 + .2318E-07 + .1530E-05 + .1679E-05 + .1830E-05 + .1993E-05 + .2164E-05 + .2349E-05 + .2549E-05 + .2773E-05 + .3017E-05 + .3281E-05 + .3562E-05 + .3868E-05 + .4215E-05 + .4612E-05 + .5046E-05 + .5329E-05 + .5627E-05 + .5885E-05 + .6124E-05 + .6271E-05 + .6319E-05 + .6297E-05 + .6274E-05 + .6211E-05 + .6133E-05 + .6057E-05 + .5981E-05 + .5906E-05 + .5832E-05 + .5759E-05 + .5668E-05 + .5528E-05 + .5344E-05 + .5166E-05 + .4878E-05 + .4381E-05 + .3869E-05 + .3107E-05 + .2505E-05 + .2085E-05 + .1732E-05 + .1231E-05 + .8752E-06 + .6222E-06 + .4494E-06 + .3145E-06 + .2131E-06 + .1357E-06 + .8644E-07 + .6608E-07 + .5509E-07 + .4592E-07 + .3872E-07 + .3721E-07 + .3577E-07 + .3273E-07 + .2862E-07 + .2503E-07 + .2378E-07 + .1565E-05 + .1716E-05 + .1875E-05 + .2042E-05 + .2215E-05 + .2402E-05 + .2605E-05 + .2829E-05 + .3073E-05 + .3339E-05 + .3625E-05 + .3936E-05 + .4280E-05 + .4667E-05 + .5089E-05 + .5345E-05 + .5614E-05 + .5858E-05 + .6031E-05 + .6143E-05 + .6191E-05 + .6192E-05 + .6193E-05 + .6167E-05 + .6100E-05 + .6033E-05 + .5968E-05 + .5903E-05 + .5838E-05 + .5775E-05 + .5659E-05 + .5512E-05 + .5338E-05 + .5169E-05 + .4818E-05 + .4344E-05 + .3820E-05 + .3124E-05 + .2562E-05 + .2109E-05 + .1725E-05 + .1249E-05 + .9043E-06 + .6547E-06 + .4760E-06 + .3302E-06 + .2231E-06 + .1433E-06 + .9209E-07 + .6967E-07 + .5697E-07 + .4658E-07 + .3858E-07 + .3698E-07 + .3545E-07 + .3253E-07 + .2866E-07 + .2526E-07 + .2406E-07 + .1596E-05 + .1750E-05 + .1915E-05 + .2086E-05 + .2261E-05 + .2449E-05 + .2654E-05 + .2878E-05 + .3121E-05 + .3388E-05 + .3679E-05 + .3994E-05 + .4334E-05 + .4709E-05 + .5117E-05 + .5345E-05 + .5584E-05 + .5815E-05 + .5923E-05 + .6001E-05 + .6047E-05 + .6071E-05 + .6095E-05 + .6105E-05 + .6049E-05 + .5993E-05 + .5937E-05 + .5882E-05 + .5828E-05 + .5774E-05 + .5634E-05 + .5481E-05 + .5316E-05 + .5157E-05 + .4746E-05 + .4295E-05 + .3761E-05 + .3133E-05 + .2613E-05 + .2127E-05 + .1715E-05 + .1255E-05 + .9193E-06 + .6731E-06 + .4939E-06 + .3383E-06 + .2285E-06 + .1502E-06 + .9870E-07 + .7424E-07 + .5953E-07 + .4774E-07 + .3881E-07 + .3702E-07 + .3531E-07 + .3239E-07 + .2866E-07 + .2535E-07 + .2420E-07 + .1625E-05 + .1782E-05 + .1954E-05 + .2129E-05 + .2305E-05 + .2495E-05 + .2701E-05 + .2925E-05 + .3166E-05 + .3435E-05 + .3729E-05 + .4049E-05 + .4385E-05 + .4747E-05 + .5139E-05 + .5340E-05 + .5549E-05 + .5766E-05 + .5811E-05 + .5856E-05 + .5901E-05 + .5946E-05 + .5992E-05 + .6038E-05 + .5992E-05 + .5946E-05 + .5901E-05 + .5855E-05 + .5811E-05 + .5766E-05 + .5603E-05 + .5444E-05 + .5289E-05 + .5139E-05 + .4669E-05 + .4242E-05 + .3699E-05 + .3138E-05 + .2662E-05 + .2142E-05 + .1702E-05 + .1260E-05 + .9334E-06 + .6913E-06 + .5119E-06 + .3463E-06 + .2337E-06 + .1572E-06 + .1057E-06 + .7901E-07 + .6214E-07 + .4886E-07 + .3901E-07 + .3701E-07 + .3512E-07 + .3221E-07 + .2862E-07 + .2542E-07 + .2430E-07 + .1648E-05 + .1807E-05 + .1981E-05 + .2155E-05 + .2333E-05 + .2525E-05 + .2730E-05 + .2952E-05 + .3191E-05 + .3447E-05 + .3725E-05 + .4026E-05 + .4346E-05 + .4696E-05 + .5073E-05 + .5303E-05 + .5498E-05 + .5700E-05 + .5780E-05 + .5840E-05 + .5879E-05 + .5918E-05 + .5957E-05 + .5997E-05 + .5970E-05 + .5934E-05 + .5888E-05 + .5843E-05 + .5784E-05 + .5711E-05 + .5554E-05 + .5402E-05 + .5253E-05 + .5036E-05 + .4600E-05 + .4202E-05 + .3629E-05 + .3074E-05 + .2595E-05 + .2093E-05 + .1667E-05 + .1273E-05 + .9719E-06 + .7421E-06 + .5483E-06 + .3711E-06 + .2495E-06 + .1656E-06 + .1100E-06 + .8171E-07 + .6402E-07 + .5017E-07 + .3991E-07 + .3778E-07 + .3576E-07 + .3296E-07 + .2965E-07 + .2668E-07 + .2562E-07 + .1671E-05 + .1832E-05 + .2009E-05 + .2181E-05 + .2361E-05 + .2556E-05 + .2759E-05 + .2978E-05 + .3215E-05 + .3458E-05 + .3720E-05 + .4002E-05 + .4308E-05 + .4644E-05 + .5007E-05 + .5265E-05 + .5446E-05 + .5634E-05 + .5749E-05 + .5824E-05 + .5856E-05 + .5889E-05 + .5921E-05 + .5954E-05 + .5947E-05 + .5920E-05 + .5875E-05 + .5830E-05 + .5757E-05 + .5656E-05 + .5505E-05 + .5359E-05 + .5216E-05 + .4934E-05 + .4531E-05 + .4161E-05 + .3561E-05 + .3010E-05 + .2529E-05 + .2044E-05 + .1632E-05 + .1285E-05 + .1012E-05 + .7965E-06 + .5872E-06 + .3976E-06 + .2662E-06 + .1745E-06 + .1144E-06 + .8447E-07 + .6596E-07 + .5150E-07 + .4083E-07 + .3855E-07 + .3639E-07 + .3373E-07 + .3072E-07 + .2799E-07 + .2701E-07 + .1693E-05 + .1856E-05 + .2035E-05 + .2205E-05 + .2388E-05 + .2584E-05 + .2785E-05 + .3003E-05 + .3237E-05 + .3466E-05 + .3711E-05 + .3974E-05 + .4265E-05 + .4589E-05 + .4937E-05 + .5222E-05 + .5390E-05 + .5563E-05 + .5713E-05 + .5802E-05 + .5828E-05 + .5854E-05 + .5880E-05 + .5907E-05 + .5918E-05 + .5901E-05 + .5856E-05 + .5812E-05 + .5724E-05 + .5596E-05 + .5452E-05 + .5311E-05 + .5174E-05 + .4830E-05 + .4459E-05 + .4117E-05 + .3490E-05 + .2946E-05 + .2462E-05 + .1995E-05 + .1596E-05 + .1296E-05 + .1052E-05 + .8542E-06 + .6282E-06 + .4256E-06 + .2839E-06 + .1838E-06 + .1190E-06 + .8724E-07 + .6788E-07 + .5282E-07 + .4173E-07 + .3930E-07 + .3701E-07 + .3448E-07 + .3180E-07 + .2933E-07 + .2844E-07 + .1702E-05 + .1866E-05 + .2046E-05 + .2214E-05 + .2396E-05 + .2592E-05 + .2791E-05 + .3005E-05 + .3235E-05 + .3452E-05 + .3682E-05 + .3927E-05 + .4200E-05 + .4506E-05 + .4836E-05 + .5133E-05 + .5310E-05 + .5473E-05 + .5633E-05 + .5730E-05 + .5761E-05 + .5792E-05 + .5823E-05 + .5855E-05 + .5865E-05 + .5845E-05 + .5796E-05 + .5747E-05 + .5654E-05 + .5518E-05 + .5386E-05 + .5256E-05 + .5100E-05 + .4729E-05 + .4385E-05 + .4047E-05 + .3421E-05 + .2892E-05 + .2414E-05 + .1960E-05 + .1573E-05 + .1312E-05 + .1095E-05 + .9139E-06 + .6707E-06 + .4546E-06 + .3020E-06 + .1930E-06 + .1234E-06 + .8991E-07 + .6971E-07 + .5405E-07 + .4256E-07 + .3998E-07 + .3755E-07 + .3517E-07 + .3284E-07 + .3068E-07 + .2989E-07 + .1693E-05 + .1857E-05 + .2036E-05 + .2202E-05 + .2381E-05 + .2574E-05 + .2768E-05 + .2976E-05 + .3200E-05 + .3409E-05 + .3625E-05 + .3855E-05 + .4107E-05 + .4388E-05 + .4695E-05 + .4984E-05 + .5200E-05 + .5359E-05 + .5496E-05 + .5591E-05 + .5642E-05 + .5693E-05 + .5745E-05 + .5798E-05 + .5779E-05 + .5739E-05 + .5680E-05 + .5622E-05 + .5534E-05 + .5418E-05 + .5305E-05 + .5194E-05 + .4983E-05 + .4635E-05 + .4311E-05 + .3945E-05 + .3355E-05 + .2854E-05 + .2391E-05 + .1946E-05 + .1565E-05 + .1337E-05 + .1142E-05 + .9752E-06 + .7140E-06 + .4843E-06 + .3204E-06 + .2022E-06 + .1277E-06 + .9241E-07 + .7140E-07 + .5517E-07 + .4328E-07 + .4055E-07 + .3799E-07 + .3577E-07 + .3383E-07 + .3199E-07 + .3132E-07 + .1701E-05 + .1865E-05 + .2044E-05 + .2209E-05 + .2388E-05 + .2580E-05 + .2771E-05 + .2975E-05 + .3195E-05 + .3397E-05 + .3602E-05 + .3818E-05 + .4052E-05 + .4313E-05 + .4599E-05 + .4884E-05 + .5139E-05 + .5296E-05 + .5411E-05 + .5505E-05 + .5576E-05 + .5648E-05 + .5721E-05 + .5795E-05 + .5746E-05 + .5687E-05 + .5618E-05 + .5550E-05 + .5467E-05 + .5369E-05 + .5273E-05 + .5178E-05 + .4913E-05 + .4584E-05 + .4276E-05 + .3880E-05 + .3321E-05 + .2842E-05 + .2389E-05 + .1950E-05 + .1572E-05 + .1355E-05 + .1167E-05 + .1006E-05 + .7356E-06 + .4990E-06 + .3296E-06 + .2071E-06 + .1301E-06 + .9394E-07 + .7248E-07 + .5593E-07 + .4383E-07 + .4102E-07 + .3840E-07 + .3622E-07 + .3442E-07 + .3270E-07 + .3207E-07 + .1718E-05 + .1884E-05 + .2065E-05 + .2230E-05 + .2408E-05 + .2601E-05 + .2789E-05 + .2992E-05 + .3209E-05 + .3406E-05 + .3599E-05 + .3804E-05 + .4021E-05 + .4263E-05 + .4532E-05 + .4815E-05 + .5108E-05 + .5265E-05 + .5359E-05 + .5452E-05 + .5543E-05 + .5636E-05 + .5730E-05 + .5825E-05 + .5747E-05 + .5668E-05 + .5589E-05 + .5511E-05 + .5432E-05 + .5351E-05 + .5272E-05 + .5194E-05 + .4872E-05 + .4560E-05 + .4267E-05 + .3839E-05 + .3306E-05 + .2846E-05 + .2402E-05 + .1965E-05 + .1589E-05 + .1369E-05 + .1179E-05 + .1016E-05 + .7430E-06 + .5040E-06 + .3330E-06 + .2092E-06 + .1314E-06 + .9489E-07 + .7322E-07 + .5650E-07 + .4427E-07 + .4144E-07 + .3879E-07 + .3659E-07 + .3477E-07 + .3304E-07 + .3240E-07 + .1738E-05 + .1906E-05 + .2090E-05 + .2256E-05 + .2436E-05 + .2631E-05 + .2813E-05 + .3008E-05 + .3216E-05 + .3411E-05 + .3600E-05 + .3800E-05 + .4011E-05 + .4242E-05 + .4495E-05 + .4760E-05 + .5040E-05 + .5214E-05 + .5340E-05 + .5449E-05 + .5541E-05 + .5635E-05 + .5730E-05 + .5827E-05 + .5747E-05 + .5669E-05 + .5592E-05 + .5516E-05 + .5440E-05 + .5366E-05 + .5245E-05 + .5126E-05 + .4816E-05 + .4525E-05 + .4220E-05 + .3784E-05 + .3287E-05 + .2855E-05 + .2419E-05 + .1984E-05 + .1608E-05 + .1385E-05 + .1193E-05 + .1028E-05 + .7518E-06 + .5100E-06 + .3369E-06 + .2116E-06 + .1330E-06 + .9602E-07 + .7409E-07 + .5716E-07 + .4480E-07 + .4193E-07 + .3925E-07 + .3702E-07 + .3518E-07 + .3343E-07 + .3278E-07 + .1759E-05 + .1929E-05 + .2115E-05 + .2283E-05 + .2466E-05 + .2662E-05 + .2837E-05 + .3023E-05 + .3222E-05 + .3415E-05 + .3601E-05 + .3797E-05 + .4003E-05 + .4227E-05 + .4464E-05 + .4708E-05 + .4965E-05 + .5159E-05 + .5326E-05 + .5456E-05 + .5545E-05 + .5636E-05 + .5728E-05 + .5822E-05 + .5747E-05 + .5673E-05 + .5601E-05 + .5529E-05 + .5458E-05 + .5388E-05 + .5212E-05 + .5042E-05 + .4756E-05 + .4487E-05 + .4164E-05 + .3726E-05 + .3267E-05 + .2864E-05 + .2438E-05 + .2004E-05 + .1627E-05 + .1402E-05 + .1207E-05 + .1040E-05 + .7609E-06 + .5161E-06 + .3410E-06 + .2142E-06 + .1346E-06 + .9717E-07 + .7498E-07 + .5785E-07 + .4534E-07 + .4243E-07 + .3972E-07 + .3747E-07 + .3560E-07 + .3383E-07 + .3317E-07 + .1780E-05 + .1952E-05 + .2140E-05 + .2311E-05 + .2495E-05 + .2694E-05 + .2861E-05 + .3038E-05 + .3227E-05 + .3419E-05 + .3602E-05 + .3794E-05 + .3996E-05 + .4212E-05 + .4433E-05 + .4656E-05 + .4891E-05 + .5104E-05 + .5312E-05 + .5462E-05 + .5548E-05 + .5636E-05 + .5726E-05 + .5816E-05 + .5746E-05 + .5677E-05 + .5609E-05 + .5541E-05 + .5474E-05 + .5408E-05 + .5179E-05 + .4959E-05 + .4697E-05 + .4449E-05 + .4109E-05 + .3669E-05 + .3247E-05 + .2873E-05 + .2456E-05 + .2023E-05 + .1646E-05 + .1418E-05 + .1222E-05 + .1052E-05 + .7699E-06 + .5222E-06 + .3450E-06 + .2167E-06 + .1362E-06 + .9832E-07 + .7587E-07 + .5854E-07 + .4587E-07 + .4294E-07 + .4019E-07 + .3791E-07 + .3602E-07 + .3423E-07 + .3357E-07 diff --git a/wrfv2_fire/run/ozone_lat.formatted b/wrfv2_fire/run/ozone_lat.formatted new file mode 100644 index 00000000..919cb349 --- /dev/null +++ b/wrfv2_fire/run/ozone_lat.formatted @@ -0,0 +1,64 @@ +-87.8638 +-85.0965 +-82.3129 +-79.5256 +-76.7369 +-73.9475 +-71.1577 +-68.3678 +-65.5776 +-62.7873 +-59.997 +-57.2066 +-54.4162 +-51.6257 +-48.8352 +-46.0447 +-43.2542 +-40.4636 +-37.6731 +-34.8825 +-32.0919 +-29.3014 +-26.5108 +-23.7202 +-20.9296 +-18.1390 +-15.3484 +-12.5578 +-9.76709 +-6.9765 +-4.1859 +-1.3953 +1.3953 +4.1859 +6.9765 +9.7671 +12.5578 +15.3484 +18.1390 +20.9296 +23.7202 +26.5108 +29.3014 +32.0919 +34.8825 +37.6731 +40.4636 +43.2542 +46.0447 +48.8352 +51.6257 +54.4162 +57.2066 +59.9970 +62.7873 +65.5776 +68.3678 +71.1577 +73.9475 +76.7369 +79.5256 +82.3129 +85.0965 +87.8638 diff --git a/wrfv2_fire/run/ozone_plev.formatted b/wrfv2_fire/run/ozone_plev.formatted new file mode 100644 index 00000000..787ee2f4 --- /dev/null +++ b/wrfv2_fire/run/ozone_plev.formatted @@ -0,0 +1,59 @@ + 0.2842 + 0.3254 + 0.3719 + 0.4246 + 0.4842 + 0.5514 + 0.6275 + 0.7135 + 0.8110 + 0.9217 + 1.0476 + 1.1911 + 1.3551 + 1.5431 + 1.7589 + 2.0074 + 2.2940 + 2.6253 + 3.0088 + 3.4537 + 3.9705 + 4.5719 + 5.2728 + 6.0907 + 7.0464 + 8.1637 + 9.4708 + 11.0000 + 12.7894 + 14.8832 + 17.3342 + 20.2039 + 23.5659 + 27.5066 + 32.1283 + 37.5509 + 43.9150 + 51.3840 + 60.1483 + 70.4289 + 82.4830 + 96.6096 + 113.1550 + 132.5140 + 155.1220 + 181.4450 + 211.9470 + 247.0790 + 287.2730 + 332.9560 + 384.5730 + 442.6100 + 507.6010 + 580.1320 + 660.8370 + 750.3930 + 849.5210 + 958.9810 + 1003.6900 diff --git a/wrfv2_fire/run/tr49t67 b/wrfv2_fire/run/tr49t67 new file mode 100644 index 00000000..6b36e799 --- /dev/null +++ b/wrfv2_fire/run/tr49t67 @@ -0,0 +1,35643 @@ + 1.00000000000000 + 0.99978679806192 + 0.99976874082573 + 0.99975001764713 + 0.99973064756487 + 0.99971063381381 + 0.99968996116844 + 0.99966859327030 + 0.99964646724852 + 0.99962347465225 + 0.99959940658188 + 0.99957392952393 + 0.99954669942132 + 0.99951741127653 + 0.99948575971138 + 0.99945141498355 + 0.99941401451777 + 0.99937315888812 + 0.99932837938961 + 0.99927913630465 + 0.99922488358160 + 0.99916503432144 + 0.99909896302326 + 0.99902600520383 + 0.99894544184005 + 0.99885641179705 + 0.99875775525805 + 0.99864820911009 + 0.99852664997248 + 0.99839196743253 + 0.99824269514606 + 0.99807727169976 + 0.99789391919384 + 0.99769051311040 + 0.99746449235919 + 0.99721275989947 + 0.99693157830630 + 0.99661646857608 + 0.99626188730592 + 0.99586114395139 + 0.99540680984623 + 0.99489041190969 + 0.99430243129243 + 0.99363287765041 + 0.99287482684623 + 0.99202453998517 + 0.99107244419652 + 0.99000789161614 + 0.98882560560229 + 0.98751577349849 + 0.98606245652070 + 0.98444820306597 + 0.98265489127193 + 0.98066317919246 + 0.97844990675642 + 0.97598803432567 + 0.97324583494554 + 0.97018459901261 + 0.96675916465250 + 0.96291961791137 + 0.95861111418580 + 0.95376839527323 + 0.94832363924203 + 0.94222132651581 + 0.93541540028552 + 0.92786402853233 + 0.91953627048912 + 0.91041288518984 + 0.90048894484372 + 0.88977761801563 + 0.87831521515180 + 0.86616651334025 + 0.85342361662212 + 0.84019232603256 + 0.82659950109453 + 0.81280688863087 + 0.79898488690631 + 0.79210571761580 + 0.78527122126111 + 0.77849230760569 + 0.77177591212674 + 0.76512473850487 + 0.75853716997976 + 0.75200741690213 + 0.74552599568715 + 0.73908049454238 + 0.73265377602074 + 0.72617828831957 + 0.71945586406432 + 0.71238127760853 + 0.70494010764348 + 0.69711669398278 + 0.68891981361283 + 0.68036371453171 + 0.67146676679530 + 0.66225033229122 + 0.65273801837462 + 0.64295365234961 + 0.63289134418940 + 0.62257356916950 + 0.61202671585284 + 0.60128245919334 + 0.59037889621860 + 0.57936092144629 + 0.56826250515447 + 0.55711622753009 + 0.54596825674889 + 0.53485938094428 + 0.52382005204112 + 0.99978679806192 + 1.00000000000000 + 0.99993759291029 + 0.99988761807634 + 0.99984437909879 + 0.99980566494739 + 0.99977013637010 + 0.99973685055758 + 0.99970508503948 + 0.99967423769252 + 0.99964371857500 + 0.99961289296232 + 0.99958118571261 + 0.99954811641697 + 0.99951324344131 + 0.99947613047658 + 0.99943633159018 + 0.99939338150568 + 0.99934675754039 + 0.99929587513783 + 0.99924015210409 + 0.99917897179121 + 0.99911168474902 + 0.99903760765400 + 0.99895600686321 + 0.99886600960107 + 0.99876644646453 + 0.99865604847542 + 0.99853369035752 + 0.99839826167734 + 0.99824829591267 + 0.99808223224592 + 0.99789829323878 + 0.99769435421445 + 0.99746785319661 + 0.99721569148713 + 0.99693412928073 + 0.99661868451280 + 0.99626381000239 + 0.99586281102380 + 0.99540825473026 + 0.99489166391102 + 0.99430351587523 + 0.99363381688492 + 0.99287564004931 + 0.99202524406685 + 0.99107305367305 + 0.99000841904271 + 0.98882606202937 + 0.98751616858452 + 0.98606279867622 + 0.98444849964773 + 0.98265514871133 + 0.98066340310538 + 0.97845010202198 + 0.97598820515645 + 0.97324598498327 + 0.97018473137032 + 0.96675928197951 + 0.96291972243674 + 0.95861120776469 + 0.95376847941682 + 0.94832371516797 + 0.94222139522030 + 0.93541546259281 + 0.92786408511473 + 0.91953632190356 + 0.91041293189885 + 0.90048898723494 + 0.88977765642395 + 0.87831524986819 + 0.86616654462237 + 0.85342364470698 + 0.84019235113625 + 0.82659952342516 + 0.81280690839505 + 0.79898490431974 + 0.79210573393495 + 0.78527123654112 + 0.77849232190509 + 0.77177592550123 + 0.76512475101173 + 0.75853718167662 + 0.75200742784475 + 0.74552600593117 + 0.73908050414130 + 0.73265378502552 + 0.72617829677425 + 0.71945587199775 + 0.71238128504211 + 0.70494011459712 + 0.69711670047388 + 0.68891981965707 + 0.68036372014392 + 0.67146677198881 + 0.66225033707823 + 0.65273802276703 + 0.64295365636102 + 0.63289134783292 + 0.62257357246023 + 0.61202671880633 + 0.60128246182793 + 0.59037889855313 + 0.57936092350246 + 0.56826250695384 + 0.55711622909492 + 0.54596825810285 + 0.53485938211089 + 0.52382005304374 + 0.99976874082573 + 0.99993759291029 + 1.00000000000000 + 0.99992943850127 + 0.99987498888527 + 0.99982896145742 + 0.99978837106255 + 0.99975145763143 + 0.99971702353081 + 0.99968416873985 + 0.99965210870810 + 0.99962007744817 + 0.99958741030902 + 0.99955356469627 + 0.99951805437088 + 0.99948041054446 + 0.99944016354196 + 0.99939683053628 + 0.99934987541175 + 0.99929870311618 + 0.99924272332402 + 0.99918131294575 + 0.99911381748299 + 0.99903954975490 + 0.99895777317145 + 0.99886761266681 + 0.99876789699705 + 0.99865735603331 + 0.99853486406899 + 0.99839931058213 + 0.99824922895688 + 0.99808305842754 + 0.99789902159942 + 0.99769499374405 + 0.99746841270988 + 0.99721617951168 + 0.99693455393155 + 0.99661905338566 + 0.99626413006149 + 0.99586308853279 + 0.99540849525133 + 0.99489187232115 + 0.99430369641172 + 0.99363397322062 + 0.99287577539886 + 0.99202536124410 + 0.99107315509498 + 0.99000850679921 + 0.98882613796252 + 0.98751623430209 + 0.98606285558107 + 0.98444854896285 + 0.98265519151131 + 0.98066344032557 + 0.97845013447326 + 0.97598823354227 + 0.97324600990947 + 0.97018475335500 + 0.96675930146493 + 0.96291973979280 + 0.95861122330129 + 0.95376849338466 + 0.94832372776929 + 0.94222140662276 + 0.93541547293066 + 0.92786409450201 + 0.91953633043163 + 0.91041293964544 + 0.90048899426411 + 0.88977766279255 + 0.87831525562328 + 0.86616654980804 + 0.85342364936199 + 0.84019235529676 + 0.82659952712588 + 0.81280691167052 + 0.79898490720485 + 0.79210573663883 + 0.78527123907313 + 0.77849232427405 + 0.77177592771714 + 0.76512475308429 + 0.75853718361455 + 0.75200742965747 + 0.74552600762846 + 0.73908050573172 + 0.73265378651732 + 0.72617829817472 + 0.71945587331211 + 0.71238128627328 + 0.70494011574935 + 0.69711670154940 + 0.68891982065853 + 0.68036372107357 + 0.67146677284871 + 0.66225033787151 + 0.65273802349491 + 0.64295365702520 + 0.63289134843665 + 0.62257357300548 + 0.61202671929559 + 0.60128246226436 + 0.59037889893982 + 0.57936092384315 + 0.56826250725177 + 0.55711622935424 + 0.54596825832741 + 0.53485938230429 + 0.52382005320988 + 0.99975001764713 + 0.99988761807634 + 0.99992943850127 + 1.00000000000000 + 0.99992044606847 + 0.99986145391334 + 0.99981273690587 + 0.99977037034550 + 0.99973211807169 + 0.99969649988358 + 0.99966238244876 + 0.99962878038721 + 0.99959488748718 + 0.99956006693697 + 0.99952376722231 + 0.99948547337324 + 0.99944468275402 + 0.99940088872283 + 0.99935353737057 + 0.99930201998498 + 0.99924573582416 + 0.99918405363231 + 0.99911631259938 + 0.99904182072483 + 0.99895983778609 + 0.99886948590203 + 0.99876959158090 + 0.99865888329404 + 0.99853623478340 + 0.99840053538772 + 0.99825031836328 + 0.99808402298842 + 0.99789987190745 + 0.99769574031376 + 0.99746906585305 + 0.99721674919122 + 0.99693504962954 + 0.99661948397311 + 0.99626450366819 + 0.99586341247003 + 0.99540877601214 + 0.99489211559910 + 0.99430390714900 + 0.99363415570534 + 0.99287593338403 + 0.99202549801483 + 0.99107327347251 + 0.99000860922368 + 0.98882622658324 + 0.98751631099641 + 0.98606292198697 + 0.98444860651142 + 0.98265524145125 + 0.98066348375067 + 0.97845017233239 + 0.97598826665880 + 0.97324603898730 + 0.97018477900150 + 0.96675932419485 + 0.96291976003884 + 0.95861124142365 + 0.95376850967564 + 0.94832374246596 + 0.94222141991875 + 0.93541548498578 + 0.92786410544801 + 0.91953634037522 + 0.91041294867776 + 0.90048900245979 + 0.88977767021727 + 0.87831526233329 + 0.86616655585244 + 0.85342365478870 + 0.84019236014704 + 0.82659953143943 + 0.81280691548773 + 0.79898491056861 + 0.79210573979073 + 0.78527124202429 + 0.77849232703478 + 0.77177593029994 + 0.76512475549939 + 0.75853718587305 + 0.75200743177071 + 0.74552600960678 + 0.73908050758514 + 0.73265378825594 + 0.72617829980732 + 0.71945587484429 + 0.71238128770864 + 0.70494011709182 + 0.69711670280275 + 0.68891982182588 + 0.68036372215754 + 0.67146677385200 + 0.66225033879601 + 0.65273802434310 + 0.64295365780008 + 0.63289134913988 + 0.62257357364010 + 0.61202671986605 + 0.60128246277287 + 0.59037889939065 + 0.57936092424031 + 0.56826250759887 + 0.55711622965629 + 0.54596825858866 + 0.53485938252926 + 0.52382005340312 + 0.99973064756487 + 0.99984437909879 + 0.99987498888527 + 0.99992044606847 + 1.00000000000000 + 0.99991058074322 + 0.99984703396032 + 0.99979574697771 + 0.99975168793239 + 0.99971208885131 + 0.99967512816553 + 0.99963942446294 + 0.99960393340318 + 0.99956786825425 + 0.99953057816332 + 0.99949148027328 + 0.99945002490003 + 0.99940567230938 + 0.99935784449997 + 0.99930591469987 + 0.99924926860685 + 0.99918726450117 + 0.99911923355792 + 0.99904447772984 + 0.99896225225767 + 0.99887167577903 + 0.99877157205120 + 0.99866066780893 + 0.99853783608785 + 0.99840196603039 + 0.99825159070572 + 0.99808514942039 + 0.99790086484070 + 0.99769661206523 + 0.99746982848545 + 0.99721741435467 + 0.99693562840639 + 0.99661998672737 + 0.99626493989022 + 0.99586379069639 + 0.99540910382609 + 0.99489239964403 + 0.99430415320026 + 0.99363436876787 + 0.99287611783627 + 0.99202565769355 + 0.99107341167141 + 0.99000872879449 + 0.98882633003261 + 0.98751640051987 + 0.98606299949580 + 0.98444867367600 + 0.98265529973470 + 0.98066353442866 + 0.97845021651320 + 0.97598830529844 + 0.97324607291526 + 0.97018480892470 + 0.96675935071096 + 0.96291978365571 + 0.95861126256099 + 0.95376852867612 + 0.94832375960685 + 0.94222143542592 + 0.93541549904545 + 0.92786411821186 + 0.91953635197036 + 0.91041295920901 + 0.90048901201642 + 0.88977767887383 + 0.87831527015578 + 0.86616656290039 + 0.85342366111433 + 0.84019236580045 + 0.82659953646791 + 0.81280691993855 + 0.79898491448918 + 0.79210574346459 + 0.78527124546430 + 0.77849233025414 + 0.77177593331065 + 0.76512475831481 + 0.75853718850595 + 0.75200743423430 + 0.74552601191279 + 0.73908050974615 + 0.73265379028274 + 0.72617830171075 + 0.71945587662972 + 0.71238128938201 + 0.70494011865689 + 0.69711670426322 + 0.68891982318608 + 0.68036372342091 + 0.67146677502030 + 0.66225033987287 + 0.65273802533157 + 0.64295365870299 + 0.63289134995995 + 0.62257357438082 + 0.61202672053053 + 0.60128246336589 + 0.59037889991627 + 0.57936092470323 + 0.56826250800388 + 0.55711623000852 + 0.54596825889355 + 0.53485938279197 + 0.52382005362900 + 0.99971063381381 + 0.99980566494739 + 0.99982896145742 + 0.99986145391334 + 0.99991058074322 + 1.00000000000000 + 0.99989981678591 + 0.99983175887755 + 0.99977802651453 + 0.99973230953766 + 0.99969122934175 + 0.99965261243258 + 0.99961498041405 + 0.99957729266943 + 0.99953873956193 + 0.99949863439888 + 0.99945635805476 + 0.99941132347269 + 0.99936291924280 + 0.99931049420431 + 0.99925341611696 + 0.99919102964108 + 0.99912265565544 + 0.99904758842766 + 0.99896507748667 + 0.99887423712612 + 0.99877388769481 + 0.99866275377774 + 0.99853970749977 + 0.99840363770721 + 0.99825307720828 + 0.99808646531142 + 0.99790202468795 + 0.99769763029887 + 0.99747071922761 + 0.99721819123644 + 0.99693630437943 + 0.99662057390623 + 0.99626544936538 + 0.99586423243652 + 0.99540948668910 + 0.99489273138859 + 0.99430444056549 + 0.99363461760008 + 0.99287633324958 + 0.99202584416926 + 0.99107357305496 + 0.99000886841577 + 0.98882645082533 + 0.98751650504451 + 0.98606308998518 + 0.98444875208379 + 0.98265536776965 + 0.98066359358045 + 0.97845026807651 + 0.97598835039393 + 0.97324611250656 + 0.97018484383865 + 0.96675938165006 + 0.96291981121043 + 0.95861128722206 + 0.95376855084471 + 0.94832377960326 + 0.94222145351438 + 0.93541551544352 + 0.92786413309813 + 0.91953636549245 + 0.91041297148919 + 0.90048902315904 + 0.88977768896649 + 0.87831527927652 + 0.86616657111742 + 0.85342366848988 + 0.84019237239225 + 0.82659954233009 + 0.81280692512620 + 0.79898491905927 + 0.79210574774778 + 0.78527124947421 + 0.77849233400626 + 0.77177593682018 + 0.76512476159670 + 0.75853719157496 + 0.75200743710553 + 0.74552601460023 + 0.73908051226455 + 0.73265379264527 + 0.72617830392851 + 0.71945587871106 + 0.71238129133206 + 0.70494012048123 + 0.69711670596605 + 0.68891982477192 + 0.68036372489319 + 0.67146677638308 + 0.66225034112892 + 0.65273802648422 + 0.64295365975478 + 0.63289135091596 + 0.62257357524408 + 0.61202672130548 + 0.60128246405716 + 0.59037890052874 + 0.57936092524251 + 0.56826250847608 + 0.55711623041893 + 0.54596825924857 + 0.53485938309795 + 0.52382005389197 + 0.99968996116844 + 0.99977013637010 + 0.99978837106255 + 0.99981273690587 + 0.99984703396032 + 0.99989981678591 + 1.00000000000000 + 0.99988813844206 + 0.99981566063521 + 0.99975957607093 + 0.99971210757360 + 0.99966925026501 + 0.99962864417104 + 0.99958878195434 + 0.99954858379829 + 0.99950719618826 + 0.99946389326136 + 0.99941801793111 + 0.99936891109945 + 0.99931588789526 + 0.99925829184222 + 0.99919544956913 + 0.99912666854550 + 0.99905123313950 + 0.99896838560522 + 0.99887723476182 + 0.99877659670857 + 0.99866519333489 + 0.99854189558272 + 0.99840559186352 + 0.99825481462040 + 0.99808800312367 + 0.99790338000631 + 0.99769882005668 + 0.99747175996784 + 0.99721909891298 + 0.99693709414797 + 0.99662125992744 + 0.99626604460261 + 0.99586474853938 + 0.99540993399961 + 0.99489311897081 + 0.99430477629639 + 0.99363490830524 + 0.99287658490604 + 0.99202606200753 + 0.99107376157224 + 0.99000903150606 + 0.98882659190924 + 0.98751662711865 + 0.98606319566154 + 0.98444884364137 + 0.98265544720655 + 0.98066366264034 + 0.97845032827081 + 0.97598840303412 + 0.97324615871821 + 0.97018488459037 + 0.96675941775777 + 0.96291984336665 + 0.95861131599784 + 0.95376857670777 + 0.94832380292979 + 0.94222147461439 + 0.93541553456993 + 0.92786415046046 + 0.91953638126299 + 0.91041298581129 + 0.90048903615288 + 0.88977770073593 + 0.87831528991073 + 0.86616658069796 + 0.85342367708824 + 0.84019238007659 + 0.82659954916384 + 0.81280693117409 + 0.79898492438730 + 0.79210575273973 + 0.78527125414897 + 0.77849233837993 + 0.77177594091090 + 0.76512476542182 + 0.75853719515298 + 0.75200744045162 + 0.74552601773337 + 0.73908051519999 + 0.73265379539922 + 0.72617830651400 + 0.71945588113714 + 0.71238129360466 + 0.70494012260747 + 0.69711670795121 + 0.68891982662014 + 0.68036372660936 + 0.67146677797056 + 0.66225034259244 + 0.65273802782725 + 0.64295366098148 + 0.63289135202989 + 0.62257357625005 + 0.61202672220816 + 0.60128246486219 + 0.59037890124252 + 0.57936092587116 + 0.56826250902617 + 0.55711623089760 + 0.54596825966280 + 0.53485938345462 + 0.52382005419856 + 0.99966859327030 + 0.99973685055758 + 0.99975145763143 + 0.99977037034550 + 0.99979574697771 + 0.99983175887755 + 0.99988813844206 + 1.00000000000000 + 0.99987553735781 + 0.99979874658312 + 0.99974028336078 + 0.99969080081701 + 0.99964585016350 + 0.99960296383534 + 0.99956056260235 + 0.99951750757852 + 0.99947290039314 + 0.99942597595334 + 0.99937600468624 + 0.99932225375409 + 0.99926403316695 + 0.99920064521321 + 0.99913137957920 + 0.99905550770245 + 0.99897226244993 + 0.99888074566505 + 0.99877976809219 + 0.99866804821598 + 0.99854445541564 + 0.99840787748445 + 0.99825684635341 + 0.99808980117389 + 0.99790496450527 + 0.99770021087900 + 0.99747297652090 + 0.99722015988496 + 0.99693801727844 + 0.99662206178441 + 0.99626674034461 + 0.99586535178251 + 0.99541045683515 + 0.99489357199010 + 0.99430516870123 + 0.99363524807572 + 0.99287687902471 + 0.99202631659281 + 0.99107398187726 + 0.99000922208067 + 0.98882675675813 + 0.98751676974409 + 0.98606331911606 + 0.98444895059262 + 0.98265553998964 + 0.98066374329420 + 0.97845039856421 + 0.97598846449795 + 0.97324621267386 + 0.97018493216400 + 0.96675945990896 + 0.96291988089884 + 0.95861134958500 + 0.95376860689269 + 0.94832383015248 + 0.94222149923525 + 0.93541555688664 + 0.92786417071643 + 0.91953639965980 + 0.91041300251680 + 0.90048905130770 + 0.88977771446297 + 0.87831530231330 + 0.86616659187048 + 0.85342368711611 + 0.84019238903738 + 0.82659955713230 + 0.81280693822536 + 0.79898493059824 + 0.79210575856069 + 0.78527125959843 + 0.77849234347914 + 0.77177594568012 + 0.76512476988155 + 0.75853719932300 + 0.75200744435364 + 0.74552602138574 + 0.73908051862290 + 0.73265379861003 + 0.72617830952869 + 0.71945588396575 + 0.71238129625503 + 0.70494012508631 + 0.69711671026474 + 0.68891982877527 + 0.68036372860983 + 0.67146677982277 + 0.66225034429900 + 0.65273802939323 + 0.64295366241129 + 0.63289135332857 + 0.62257357742294 + 0.61202672326102 + 0.60128246580121 + 0.59037890207493 + 0.57936092660405 + 0.56826250966735 + 0.55711623145547 + 0.54596826014543 + 0.53485938387043 + 0.52382005455580 + 0.99964646724852 + 0.99970508503948 + 0.99971702353081 + 0.99973211807169 + 0.99975168793239 + 0.99977802651453 + 0.99981566063521 + 0.99987553735781 + 1.00000000000000 + 0.99986199385256 + 0.99978091964894 + 0.99971987960328 + 0.99966809857845 + 0.99962078311803 + 0.99957531790825 + 0.99953003349400 + 0.99948373441063 + 0.99943548018219 + 0.99938443258588 + 0.99932978812367 + 0.99927080912900 + 0.99920676425450 + 0.99913691913741 + 0.99906052803783 + 0.99897681152920 + 0.99888486243735 + 0.99878348468941 + 0.99867139242575 + 0.99854745295282 + 0.99841055316767 + 0.99825922427938 + 0.99809190522676 + 0.99790681840410 + 0.99770183800830 + 0.99747439966362 + 0.99722140096553 + 0.99693909708574 + 0.99662299971966 + 0.99626755414749 + 0.99586605738577 + 0.99541106837987 + 0.99489410186759 + 0.99430562767033 + 0.99363564546850 + 0.99287722300888 + 0.99202661432557 + 0.99107423950315 + 0.99000944492232 + 0.98882694950335 + 0.98751693648977 + 0.98606346343365 + 0.98444907560550 + 0.98265564843011 + 0.98066383754805 + 0.97845048070428 + 0.97598853631422 + 0.97324627570846 + 0.97018498773741 + 0.96675950914479 + 0.96291992473689 + 0.95861138880743 + 0.95376864213944 + 0.94832386193841 + 0.94222152798017 + 0.93541558293983 + 0.92786419436193 + 0.91953642113303 + 0.91041302201340 + 0.90048906899426 + 0.88977773047860 + 0.87831531678431 + 0.86616660490492 + 0.85342369881452 + 0.84019239949041 + 0.82659956642830 + 0.81280694645169 + 0.79898493784350 + 0.79210576535046 + 0.78527126595641 + 0.77849234942835 + 0.77177595124425 + 0.76512477508477 + 0.75853720418870 + 0.75200744890587 + 0.74552602564658 + 0.73908052261525 + 0.73265380235564 + 0.72617831304511 + 0.71945588726585 + 0.71238129934672 + 0.70494012797866 + 0.69711671296507 + 0.68891983128943 + 0.68036373094473 + 0.67146678198298 + 0.66225034628982 + 0.65273803121998 + 0.64295366407994 + 0.63289135484417 + 0.62257357879138 + 0.61202672448940 + 0.60128246689717 + 0.59037890304612 + 0.57936092745899 + 0.56826251041584 + 0.55711623210600 + 0.54596826070861 + 0.53485938435605 + 0.52382005497303 + 0.99962347465225 + 0.99967423769252 + 0.99968416873985 + 0.99969649988358 + 0.99971208885131 + 0.99973230953766 + 0.99975957607093 + 0.99979874658312 + 0.99986199385256 + 1.00000000000000 + 0.99984741803121 + 0.99976194335116 + 0.99969810471430 + 0.99964378832142 + 0.99959382777689 + 0.99954544500065 + 0.99949688791556 + 0.99944691198193 + 0.99939450238224 + 0.99933874693367 + 0.99927883779748 + 0.99921399578994 + 0.99914345325988 + 0.99906644117064 + 0.99898216370106 + 0.99888970186610 + 0.99878785078138 + 0.99867531896136 + 0.99855097094027 + 0.99841369232435 + 0.99826201331416 + 0.99809437247161 + 0.99790899191730 + 0.99770374537410 + 0.99747606772674 + 0.99722285550810 + 0.99694036253824 + 0.99662409885549 + 0.99626850778282 + 0.99586688420247 + 0.99541178495890 + 0.99489472272543 + 0.99430616542135 + 0.99363611105204 + 0.99287762600009 + 0.99202696310677 + 0.99107454128263 + 0.99000970593814 + 0.98882717524870 + 0.98751713176877 + 0.98606363243539 + 0.98444922199047 + 0.98265577539988 + 0.98066394790001 + 0.97845057686604 + 0.97598862038450 + 0.97324634949504 + 0.97018505278879 + 0.96675956677095 + 0.96291997604412 + 0.95861143471210 + 0.95376868338799 + 0.94832389913310 + 0.94222156161553 + 0.93541561342140 + 0.92786422202366 + 0.91953644625225 + 0.91041304482049 + 0.90048908968156 + 0.88977774921308 + 0.87831533370932 + 0.86616662014886 + 0.85342371249554 + 0.84019241171575 + 0.82659957730043 + 0.81280695607268 + 0.79898494632106 + 0.79210577329388 + 0.78527127339382 + 0.77849235638820 + 0.77177595775419 + 0.76512478117297 + 0.75853720988269 + 0.75200745423341 + 0.74552603063479 + 0.73908052728906 + 0.73265380674073 + 0.72617831716241 + 0.71945589112956 + 0.71238130296781 + 0.70494013136560 + 0.69711671612730 + 0.68891983423416 + 0.68036373367911 + 0.67146678451347 + 0.66225034862214 + 0.65273803336027 + 0.64295366603439 + 0.63289135661940 + 0.62257358039463 + 0.61202672592858 + 0.60128246818098 + 0.59037890418412 + 0.57936092846121 + 0.56826251129316 + 0.55711623286920 + 0.54596826136865 + 0.53485938492486 + 0.52382005546169 + 0.99959940658188 + 0.99964371857500 + 0.99965210870810 + 0.99966238244876 + 0.99967512816553 + 0.99969122934175 + 0.99971210757360 + 0.99974028336078 + 0.99978091964894 + 0.99984741803121 + 1.00000000000000 + 0.99983166142802 + 0.99974166082106 + 0.99967484741482 + 0.99961774308048 + 0.99956480558502 + 0.99951310945798 + 0.99946083536528 + 0.99940666111037 + 0.99934949799571 + 0.99928843023473 + 0.99922260819854 + 0.99915121676030 + 0.99907345446391 + 0.99898850315091 + 0.99889542802124 + 0.99879301260668 + 0.99867995801736 + 0.99855512501713 + 0.99841739735989 + 0.99826530382117 + 0.99809728235343 + 0.99791155462597 + 0.99770599372063 + 0.99747803356128 + 0.99722456938760 + 0.99694185336429 + 0.99662539355644 + 0.99626963094738 + 0.99586785789226 + 0.99541262873541 + 0.99489545371678 + 0.99430679850391 + 0.99363665912188 + 0.99287810034568 + 0.99202737361983 + 0.99107489645668 + 0.99001001312975 + 0.98882744092920 + 0.98751736160219 + 0.98606383135093 + 0.98444939429473 + 0.98265592486655 + 0.98066407781701 + 0.97845069008751 + 0.97598871937909 + 0.97324643639413 + 0.97018512940818 + 0.96675963465502 + 0.96292003649124 + 0.95861148880007 + 0.95376873199392 + 0.94832394296509 + 0.94222160125283 + 0.93541564934262 + 0.92786425462455 + 0.91953647585802 + 0.91041307169959 + 0.90048911406416 + 0.88977777129425 + 0.87831535366051 + 0.86616663812282 + 0.85342372862858 + 0.84019242613522 + 0.82659959012678 + 0.81280696742883 + 0.79898495632844 + 0.79210578267534 + 0.78527128218015 + 0.77849236461313 + 0.77177596545013 + 0.76512478837259 + 0.75853721661935 + 0.75200746053805 + 0.74552603653918 + 0.73908053282481 + 0.73265381193605 + 0.72617832204288 + 0.71945589571060 + 0.71238130726159 + 0.70494013538411 + 0.69711671987955 + 0.68891983772912 + 0.68036373692519 + 0.67146678751779 + 0.66225035139199 + 0.65273803590234 + 0.64295366835648 + 0.63289135872876 + 0.62257358230013 + 0.61202672763919 + 0.60128246970704 + 0.59037890553678 + 0.57936092965328 + 0.56826251233637 + 0.55711623377689 + 0.54596826215451 + 0.53485938560207 + 0.52382005604420 + 0.99957392952393 + 0.99961289296232 + 0.99962007744817 + 0.99962878038721 + 0.99963942446294 + 0.99965261243258 + 0.99966925026501 + 0.99969080081701 + 0.99971987960328 + 0.99976194335116 + 0.99983166142802 + 1.00000000000000 + 0.99981470990234 + 0.99972011994956 + 0.99965012661643 + 0.99958991130821 + 0.99953358806198 + 0.99947811195820 + 0.99942157516668 + 0.99936258106405 + 0.99930003827090 + 0.99923298863878 + 0.99916054675579 + 0.99908186459365 + 0.99899609267135 + 0.99890227448168 + 0.99879917795593 + 0.99868549424275 + 0.99856007890003 + 0.99842181299492 + 0.99826922326611 + 0.99810074671019 + 0.99791460429063 + 0.99770866818416 + 0.99748037107982 + 0.99722660658659 + 0.99694362484865 + 0.99662693152273 + 0.99627096477195 + 0.99586901390444 + 0.99541363027434 + 0.99489632119912 + 0.99430754965114 + 0.99363730929390 + 0.99287866299220 + 0.99202786051637 + 0.99107531771935 + 0.99001037750025 + 0.98882775610731 + 0.98751763430971 + 0.98606406743676 + 0.98444959886567 + 0.98265610238336 + 0.98066423217529 + 0.97845082466466 + 0.97598883710015 + 0.97324653977482 + 0.97018522060166 + 0.96675971548765 + 0.96292010849730 + 0.95861155325471 + 0.95376878993477 + 0.94832399523143 + 0.94222164853042 + 0.93541569219863 + 0.92786429352590 + 0.91953651118978 + 0.91041310378711 + 0.90048914317740 + 0.88977779766655 + 0.87831537749628 + 0.86616665960342 + 0.85342374791871 + 0.84019244338587 + 0.82659960548389 + 0.81280698103623 + 0.79898496833452 + 0.79210579393617 + 0.78527129273525 + 0.77849237449965 + 0.77177597470828 + 0.76512479704014 + 0.75853722473580 + 0.75200746814130 + 0.74552604366609 + 0.73908053951196 + 0.73265381821683 + 0.72617832794744 + 0.71945590125721 + 0.71238131246443 + 0.70494014025563 + 0.69711672443078 + 0.68891984197046 + 0.68036374086642 + 0.67146679116676 + 0.66225035475743 + 0.65273803899223 + 0.64295367117990 + 0.63289136129494 + 0.62257358461839 + 0.61202672972112 + 0.60128247156565 + 0.59037890718545 + 0.57936093110587 + 0.56826251360881 + 0.55711623488443 + 0.54596826311403 + 0.53485938642988 + 0.52382005675632 + 0.99954669942132 + 0.99958118571261 + 0.99958741030902 + 0.99959488748718 + 0.99960393340318 + 0.99961498041405 + 0.99962864417104 + 0.99964585016350 + 0.99966809857845 + 0.99969810471430 + 0.99974166082106 + 0.99981470990234 + 1.00000000000000 + 0.99979663390491 + 0.99969738040151 + 0.99962392344023 + 0.99956018515822 + 0.99949998618413 + 0.99944015539121 + 0.99937870637433 + 0.99931424087924 + 0.99924562404772 + 0.99917186169300 + 0.99909203634557 + 0.99900525317348 + 0.99891052503415 + 0.99880659831257 + 0.99869215046121 + 0.99856602969579 + 0.99842711314760 + 0.99827392461958 + 0.99810489961520 + 0.99791825800018 + 0.99771187068616 + 0.99748316872321 + 0.99722904365623 + 0.99694574311603 + 0.99662876980540 + 0.99627255844031 + 0.99587039463781 + 0.99541482612426 + 0.99489735668794 + 0.99430844604882 + 0.99363808502363 + 0.99287933418182 + 0.99202844130473 + 0.99107582022351 + 0.99001081219203 + 0.98882813219139 + 0.98751795982253 + 0.98606434935081 + 0.98444984326468 + 0.98265631457690 + 0.98066441679268 + 0.97845098572488 + 0.97598897807501 + 0.97324666365836 + 0.97018532995456 + 0.96675981247689 + 0.96292019494778 + 0.95861163068602 + 0.95376885957789 + 0.94832405808107 + 0.94222170540478 + 0.93541574377170 + 0.92786434035497 + 0.91953655373776 + 0.91041314243803 + 0.90048917826033 + 0.88977782945878 + 0.87831540624286 + 0.86616668552436 + 0.85342377121164 + 0.84019246423404 + 0.82659962406061 + 0.81280699751694 + 0.79898498289840 + 0.79210580760719 + 0.78527130555982 + 0.77849238652472 + 0.77177598597983 + 0.76512480760543 + 0.75853723464012 + 0.75200747742947 + 0.74552605238276 + 0.73908054769957 + 0.73265382591552 + 0.72617833519196 + 0.71945590806942 + 0.71238131885968 + 0.70494014624845 + 0.69711673003381 + 0.68891984719538 + 0.68036374572453 + 0.67146679566748 + 0.66225035890991 + 0.65273804280727 + 0.64295367466733 + 0.63289136446527 + 0.62257358748456 + 0.61202673229675 + 0.60128247386623 + 0.59037890922668 + 0.57936093290629 + 0.56826251518653 + 0.55711623625945 + 0.54596826430565 + 0.53485938745918 + 0.52382005764282 + 0.99951741127653 + 0.99954811641697 + 0.99955356469627 + 0.99956006693697 + 0.99956786825425 + 0.99957729266943 + 0.99958878195434 + 0.99960296383534 + 0.99962078311803 + 0.99964378832142 + 0.99967484741482 + 0.99972011994956 + 0.99979663390491 + 1.00000000000000 + 0.99977746204509 + 0.99967340581783 + 0.99959610855424 + 0.99952834669678 + 0.99946366897018 + 0.99939880447447 + 0.99933176547786 + 0.99926110845574 + 0.99918566156535 + 0.99910439921422 + 0.99901635849517 + 0.99892050769131 + 0.99881556267526 + 0.99870018161613 + 0.99857320218831 + 0.99843349567965 + 0.99827958160374 + 0.99810989314328 + 0.99792264847990 + 0.99771571670820 + 0.99748652670083 + 0.99723196735576 + 0.99694828314556 + 0.99663097312690 + 0.99627446779579 + 0.99587204825640 + 0.99541625782845 + 0.99489859602228 + 0.99430951861471 + 0.99363901298442 + 0.99288013694692 + 0.99202913588631 + 0.99107642119127 + 0.99001133211073 + 0.98882858211566 + 0.98751834937838 + 0.98606468688165 + 0.98445013603018 + 0.98265656891083 + 0.98066463821257 + 0.97845117901954 + 0.97598914738286 + 0.97324681254760 + 0.97018546147000 + 0.96675992920635 + 0.96292029906536 + 0.95861172399745 + 0.95376894355054 + 0.94832413390149 + 0.94222177404390 + 0.93541580603950 + 0.92786439691510 + 0.91953660514628 + 0.91041318915512 + 0.90048922067868 + 0.88977786791655 + 0.87831544103469 + 0.86616671691559 + 0.85342379944034 + 0.84019248952272 + 0.82659964661886 + 0.81280701755558 + 0.79898500063317 + 0.79210582427017 + 0.78527132120649 + 0.77849240121142 + 0.77177599976088 + 0.76512482053707 + 0.75853724677656 + 0.75200748882520 + 0.74552606308943 + 0.73908055776766 + 0.73265383539346 + 0.72617834412026 + 0.71945591647345 + 0.71238132675711 + 0.70494015365450 + 0.69711673696419 + 0.68891985366236 + 0.68036375174037 + 0.67146680124393 + 0.66225036405780 + 0.65273804753886 + 0.64295367899450 + 0.63289136840174 + 0.62257359104496 + 0.61202673549879 + 0.60128247672718 + 0.59037891176722 + 0.57936093514822 + 0.56826251715295 + 0.55711623797477 + 0.54596826579395 + 0.53485938874606 + 0.52382005875263 + 0.99948575971138 + 0.99951324344131 + 0.99951805437088 + 0.99952376722231 + 0.99953057816332 + 0.99953873956193 + 0.99954858379829 + 0.99956056260235 + 0.99957531790825 + 0.99959382777689 + 0.99961774308048 + 0.99965012661643 + 0.99969738040151 + 0.99977746204509 + 1.00000000000000 + 0.99975718809736 + 0.99964809725795 + 0.99956648167183 + 0.99949406805086 + 0.99942419792207 + 0.99935359137820 + 0.99928021252023 + 0.99920257870143 + 0.99911948680842 + 0.99902986727874 + 0.99893262121715 + 0.99882641998575 + 0.99870989395441 + 0.99858186532427 + 0.99844119659727 + 0.99828640092983 + 0.99811590791484 + 0.99792793312952 + 0.99772034306908 + 0.99749056365587 + 0.99723548035024 + 0.99695133364720 + 0.99663361805867 + 0.99627675889523 + 0.99587403173592 + 0.99541797453575 + 0.99490008160035 + 0.99431080392425 + 0.99364012472620 + 0.99288109851085 + 0.99202996778310 + 0.99107714096189 + 0.99001195486953 + 0.98882912114375 + 0.98751881623620 + 0.98606509156232 + 0.98445048721617 + 0.98265687416573 + 0.98066490412940 + 0.97845141131154 + 0.97598935098807 + 0.97324699171843 + 0.97018561984923 + 0.96676006987533 + 0.96292042461867 + 0.95861183658738 + 0.95376904493169 + 0.94832422548481 + 0.94222185699242 + 0.93541588131494 + 0.92786446531625 + 0.91953666733460 + 0.91041324569255 + 0.90048927203510 + 0.88977791449814 + 0.87831548319880 + 0.86616675497945 + 0.85342383369618 + 0.84019252023732 + 0.82659967404696 + 0.81280704195233 + 0.79898502225831 + 0.79210584460591 + 0.78527134032056 + 0.77849241916935 + 0.77177601663050 + 0.76512483638410 + 0.75853726166629 + 0.75200750282157 + 0.74552607625458 + 0.73908057016257 + 0.73265384707450 + 0.72617835513530 + 0.71945592685174 + 0.71238133651794 + 0.70494016281647 + 0.69711674554301 + 0.68891986167333 + 0.68036375919709 + 0.67146680815888 + 0.66225037044516 + 0.65273805341187 + 0.64295368436960 + 0.63289137329365 + 0.62257359547218 + 0.61202673948182 + 0.60128248028890 + 0.59037891493224 + 0.57936093794344 + 0.56826251960690 + 0.55711624011563 + 0.54596826765393 + 0.53485939035562 + 0.52382006014235 + 0.99945141498355 + 0.99947613047658 + 0.99948041054446 + 0.99948547337324 + 0.99949148027328 + 0.99949863439888 + 0.99950719618826 + 0.99951750757852 + 0.99953003349400 + 0.99954544500065 + 0.99956480558502 + 0.99958991130821 + 0.99962392344023 + 0.99967340581783 + 0.99975718809736 + 1.00000000000000 + 0.99973578599354 + 0.99962131571816 + 0.99953475144372 + 0.99945693189525 + 0.99938112218295 + 0.99930398683769 + 0.99922344674536 + 0.99913798685706 + 0.99904636142514 + 0.99894736590649 + 0.99883960444956 + 0.99872166618481 + 0.99859235009406 + 0.99845050525288 + 0.99829463527314 + 0.99812316418198 + 0.99793430353255 + 0.99772591603882 + 0.99749542359604 + 0.99723970714894 + 0.99695500211770 + 0.99663679734373 + 0.99627951171712 + 0.99587641404295 + 0.99542003571786 + 0.99490186471149 + 0.99431234621558 + 0.99364145840431 + 0.99288225179087 + 0.99203096542270 + 0.99107800411385 + 0.99001270173319 + 0.98882976770909 + 0.98751937639625 + 0.98606557731003 + 0.98445090895078 + 0.98265724094040 + 0.98066522382507 + 0.97845169075416 + 0.97598959608305 + 0.97324720754781 + 0.97018581076051 + 0.96676023955260 + 0.96292057615909 + 0.95861197256492 + 0.95376916743641 + 0.94832433620330 + 0.94222195731177 + 0.93541597238999 + 0.92786454810329 + 0.91953674263058 + 0.91041331416712 + 0.90048933425753 + 0.88977797095953 + 0.87831553433125 + 0.86616680116919 + 0.85342387529292 + 0.84019255756614 + 0.82659970741730 + 0.81280707167340 + 0.79898504864211 + 0.79210586943849 + 0.78527136368224 + 0.77849244114078 + 0.77177603729038 + 0.76512485581223 + 0.75853727994104 + 0.75200752001916 + 0.74552609244941 + 0.73908058542544 + 0.73265386147298 + 0.72617836872669 + 0.71945593966949 + 0.71238134858329 + 0.70494017414971 + 0.69711675616220 + 0.68891987159599 + 0.68036376843813 + 0.67146681673460 + 0.66225037836942 + 0.65273806070248 + 0.64295369104393 + 0.63289137937202 + 0.62257360097578 + 0.61202674443530 + 0.60128248472133 + 0.59037891887294 + 0.57936094142631 + 0.56826252266652 + 0.55711624278878 + 0.54596826997769 + 0.53485939236867 + 0.52382006188228 + 0.99941401451777 + 0.99943633159018 + 0.99944016354196 + 0.99944468275402 + 0.99945002490003 + 0.99945635805476 + 0.99946389326136 + 0.99947290039314 + 0.99948373441063 + 0.99949688791556 + 0.99951310945798 + 0.99953358806198 + 0.99956018515822 + 0.99959610855424 + 0.99964809725795 + 0.99973578599354 + 1.00000000000000 + 0.99971321105598 + 0.99959283598402 + 0.99950053910499 + 0.99941651685667 + 0.99933393346912 + 0.99924940243611 + 0.99916080835808 + 0.99906659408558 + 0.99896537988890 + 0.99885566410566 + 0.99873597257968 + 0.99860506854283 + 0.99846178017354 + 0.99830459655666 + 0.99813193302127 + 0.99794199490771 + 0.99773263937739 + 0.99750128272358 + 0.99724479990739 + 0.99695941981641 + 0.99664062414107 + 0.99628282379511 + 0.99587927924252 + 0.99542251383953 + 0.99490400783759 + 0.99431419935418 + 0.99364306045341 + 0.99288363683627 + 0.99203216338698 + 0.99107904053075 + 0.99001359854944 + 0.98883054420249 + 0.98752004930333 + 0.98606616103609 + 0.98445141597318 + 0.98265768210618 + 0.98066560856991 + 0.97845202725439 + 0.97598989140376 + 0.97324746777345 + 0.97018604109159 + 0.96676044439586 + 0.96292075921978 + 0.95861213691950 + 0.95376931558205 + 0.94832447015412 + 0.94222207873102 + 0.93541608265696 + 0.92786464836914 + 0.91953683385316 + 0.91041339715356 + 0.90048940969385 + 0.88977803944151 + 0.87831559637782 + 0.86616685725132 + 0.85342392583478 + 0.84019260296071 + 0.82659974804126 + 0.81280710789767 + 0.79898508084635 + 0.79210589977465 + 0.78527139224511 + 0.77849246802994 + 0.77177606259843 + 0.76512487963596 + 0.75853730237439 + 0.75200754115293 + 0.74552611237185 + 0.73908060422067 + 0.73265387922240 + 0.72617838549681 + 0.71945595549791 + 0.71238136349466 + 0.70494018816770 + 0.69711676930572 + 0.68891988388394 + 0.68036377988912 + 0.67146682736520 + 0.66225038819830 + 0.65273806974817 + 0.64295369932989 + 0.63289138692051 + 0.62257360781444 + 0.61202675059430 + 0.60128249023468 + 0.59037892377862 + 0.57936094576470 + 0.56826252648041 + 0.55711624612398 + 0.54596827288002 + 0.53485939488503 + 0.52382006406008 + 0.99937315888812 + 0.99939338150568 + 0.99939683053628 + 0.99940088872283 + 0.99940567230938 + 0.99941132347269 + 0.99941801793111 + 0.99942597595334 + 0.99943548018219 + 0.99944691198193 + 0.99946083536528 + 0.99947811195820 + 0.99949998618413 + 0.99952834669678 + 0.99956648167183 + 0.99962131571816 + 0.99971321105598 + 1.00000000000000 + 0.99968933383384 + 0.99956234303292 + 0.99946346691135 + 0.99937234543511 + 0.99928206315170 + 0.99918918799501 + 0.99909156043955 + 0.99898748993203 + 0.99887529923053 + 0.99875341306841 + 0.99862053792982 + 0.99847546880500 + 0.99831667225595 + 0.99814254993369 + 0.99795129750777 + 0.99774076391419 + 0.99750835755081 + 0.99725094532025 + 0.99696474760295 + 0.99664523700275 + 0.99628681446568 + 0.99588273013036 + 0.99542549748487 + 0.99490658731554 + 0.99431642913676 + 0.99364498757711 + 0.99288530253332 + 0.99203360386414 + 0.99108028666066 + 0.99001467684138 + 0.98883147793575 + 0.98752085864966 + 0.98606686334340 + 0.98445202623353 + 0.98265821334181 + 0.98066607209671 + 0.97845243287821 + 0.97599024759430 + 0.97324778182470 + 0.97018631923289 + 0.96676069190977 + 0.96292098053827 + 0.95861233572685 + 0.95376949487046 + 0.94832463233401 + 0.94222222578809 + 0.93541621625455 + 0.92786476988157 + 0.91953694444010 + 0.91041349778602 + 0.90048950120456 + 0.88977812254733 + 0.87831567171162 + 0.86616692537910 + 0.85342398727623 + 0.84019265819141 + 0.82659979751317 + 0.81280715206539 + 0.79898512017022 + 0.79210593684699 + 0.78527142718086 + 0.77849250094440 + 0.77177609360935 + 0.76512490885739 + 0.75853732991808 + 0.75200756712556 + 0.74552613688060 + 0.73908062736622 + 0.73265390109917 + 0.72617840618454 + 0.71945597504153 + 0.71238138191983 + 0.70494020549964 + 0.69711678556754 + 0.68891989909561 + 0.68036379407182 + 0.67146684053833 + 0.66225040038308 + 0.65273808096757 + 0.64295370961186 + 0.63289139629216 + 0.62257361630844 + 0.61202675824853 + 0.60128249709016 + 0.59037892988166 + 0.57936095116602 + 0.56826253123303 + 0.55711625028167 + 0.54596827650195 + 0.53485939802912 + 0.52382006678368 + 0.99932837938961 + 0.99934675754039 + 0.99934987541175 + 0.99935353737057 + 0.99935784449997 + 0.99936291924280 + 0.99936891109945 + 0.99937600468624 + 0.99938443258588 + 0.99939450238224 + 0.99940666111037 + 0.99942157516668 + 0.99944015539121 + 0.99946366897018 + 0.99949406805086 + 0.99953475144372 + 0.99959283598402 + 0.99968933383384 + 1.00000000000000 + 0.99966399359843 + 0.99952957278254 + 0.99942313647580 + 0.99932390865827 + 0.99922490322264 + 0.99912263471298 + 0.99901480863558 + 0.99889943595242 + 0.99877477137211 + 0.99863942791124 + 0.99849214643729 + 0.99833135787030 + 0.99815544208333 + 0.99796257960007 + 0.99775060696975 + 0.99751692132362 + 0.99725837853333 + 0.99697118776398 + 0.99665080993792 + 0.99629163344855 + 0.99588689557319 + 0.99542909760395 + 0.99490969871428 + 0.99431911788353 + 0.99364731068457 + 0.99288730998462 + 0.99203533957679 + 0.99108178804210 + 0.99001597598274 + 0.98883260300936 + 0.98752183404812 + 0.98606770998626 + 0.98445276218688 + 0.98265885426460 + 0.98066663160337 + 0.97845292274691 + 0.97599067800391 + 0.97324816153716 + 0.97018665572926 + 0.96676099152523 + 0.96292124859824 + 0.95861257665089 + 0.95376971224157 + 0.94832482904127 + 0.94222240422027 + 0.93541637840126 + 0.92786491740621 + 0.91953707873731 + 0.91041362003301 + 0.90048961240679 + 0.88977822357651 + 0.87831576333598 + 0.86616700828645 + 0.85342406209676 + 0.84019272550417 + 0.82659985786924 + 0.81280720601521 + 0.79898516826874 + 0.79210598222551 + 0.78527146998168 + 0.77849254130700 + 0.77177613167157 + 0.76512494475615 + 0.75853736378649 + 0.75200759909690 + 0.74552616707999 + 0.73908065591243 + 0.73265392810595 + 0.72617843174622 + 0.71945599920772 + 0.71238140472083 + 0.70494022696371 + 0.69711680571750 + 0.68891991795513 + 0.68036381166380 + 0.67146685688578 + 0.66225041551051 + 0.65273809490389 + 0.64295372238827 + 0.63289140794279 + 0.62257362687317 + 0.61202676777356 + 0.60128250562628 + 0.59037893748584 + 0.57936095790048 + 0.56826253716177 + 0.55711625547462 + 0.54596828102902 + 0.53485940196328 + 0.52382007019445 + 0.99927913630465 + 0.99929587513783 + 0.99929870311618 + 0.99930201998498 + 0.99930591469987 + 0.99931049420431 + 0.99931588789526 + 0.99932225375409 + 0.99932978812367 + 0.99933874693367 + 0.99934949799571 + 0.99936258106405 + 0.99937870637433 + 0.99939880447447 + 0.99942419792207 + 0.99945693189525 + 0.99950053910499 + 0.99956234303292 + 0.99966399359843 + 1.00000000000000 + 0.99963712440318 + 0.99949424843173 + 0.99937912433799 + 0.99927065940830 + 0.99916178487621 + 0.99904887078732 + 0.99892932119393 + 0.99880108533061 + 0.99866261480065 + 0.99851255926595 + 0.99834929171331 + 0.99817115678286 + 0.99797631095885 + 0.99776257192198 + 0.99752732039740 + 0.99726739692629 + 0.99697899563725 + 0.99665756226236 + 0.99629746920796 + 0.99589193761486 + 0.99543345361036 + 0.99491346202397 + 0.99432236889054 + 0.99365011870752 + 0.99288973579490 + 0.99203743659329 + 0.99108360173160 + 0.99001754530300 + 0.98883396215939 + 0.98752301259633 + 0.98606873325298 + 0.98445365198491 + 0.98265962949885 + 0.98066730867953 + 0.97845351586145 + 0.97599119941741 + 0.97324862180477 + 0.97018706385748 + 0.96676135514224 + 0.96292157410437 + 0.95861286936146 + 0.95376997646159 + 0.94832506824267 + 0.94222262127076 + 0.93541657570479 + 0.92786509697196 + 0.91953724224879 + 0.91041376891965 + 0.90048974788770 + 0.88977834671263 + 0.87831587506425 + 0.86616710944449 + 0.85342415345239 + 0.84019280776187 + 0.82659993170178 + 0.81280727208880 + 0.79898522726229 + 0.79210603792777 + 0.78527152256257 + 0.77849259093598 + 0.77177617851677 + 0.76512498898035 + 0.75853740555286 + 0.75200763856026 + 0.74552620439155 + 0.73908069121630 + 0.73265396153613 + 0.72617846341424 + 0.71945602917116 + 0.71238143301342 + 0.70494025361424 + 0.69711683075219 + 0.68891994139877 + 0.68036383354283 + 0.67146687722644 + 0.66225043434236 + 0.65273811225999 + 0.64295373830696 + 0.63289142246550 + 0.62257364004937 + 0.61202677965873 + 0.60128251628401 + 0.59037894698554 + 0.57936096631921 + 0.56826254458032 + 0.55711626197699 + 0.54596828670311 + 0.53485940689875 + 0.52382007447959 + 0.99922488358160 + 0.99924015210409 + 0.99924272332402 + 0.99924573582416 + 0.99924926860685 + 0.99925341611696 + 0.99925829184222 + 0.99926403316695 + 0.99927080912900 + 0.99927883779748 + 0.99928843023473 + 0.99930003827090 + 0.99931424087924 + 0.99933176547786 + 0.99935359137820 + 0.99938112218295 + 0.99941651685667 + 0.99946346691135 + 0.99952957278254 + 0.99963712440318 + 1.00000000000000 + 0.99960855026346 + 0.99945598808306 + 0.99933090108576 + 0.99921192596740 + 0.99909181512221 + 0.99896662746414 + 0.99883371213485 + 0.99869122440278 + 0.99853765356677 + 0.99837127532253 + 0.99819037606069 + 0.99799307349174 + 0.99777715605718 + 0.99753998019480 + 0.99727836471639 + 0.99698848327940 + 0.99666576156497 + 0.99630455142224 + 0.99589805357043 + 0.99543873515091 + 0.99491802318582 + 0.99432630774031 + 0.99365351970881 + 0.99289267299852 + 0.99203997511592 + 0.99108579694087 + 0.99001944459918 + 0.98883560714314 + 0.98752443919838 + 0.98606997218116 + 0.98445472965084 + 0.98266056875559 + 0.98066812935643 + 0.97845423510850 + 0.97599183203975 + 0.97324918054132 + 0.97018755957940 + 0.96676179704161 + 0.96292196990059 + 0.95861322545485 + 0.95377029803468 + 0.94832535947319 + 0.94222288561953 + 0.93541681607149 + 0.92786531578369 + 0.91953744155147 + 0.91041395044611 + 0.90048991312578 + 0.88977849695229 + 0.87831601144508 + 0.86616723299515 + 0.85342426510562 + 0.84019290837890 + 0.82660002210113 + 0.81280735308584 + 0.79898529967818 + 0.79210610635373 + 0.78527158720760 + 0.77849265200470 + 0.77177623621077 + 0.76512504349874 + 0.75853745708737 + 0.75200768729950 + 0.74552625051584 + 0.73908073489856 + 0.73265400293540 + 0.72617850266401 + 0.71945606633665 + 0.71238146812965 + 0.70494028671423 + 0.69711686186304 + 0.68891997054786 + 0.68036386075884 + 0.67146690254099 + 0.66225045778826 + 0.65273813387752 + 0.64295375814425 + 0.63289144057231 + 0.62257365648450 + 0.61202679449138 + 0.60128252959208 + 0.59037895885601 + 0.57936097684505 + 0.56826255386230 + 0.55711627011976 + 0.54596829381541 + 0.53485941309141 + 0.52382007986151 + 0.99916503432144 + 0.99917897179121 + 0.99918131294575 + 0.99918405363231 + 0.99918726450117 + 0.99919102964108 + 0.99919544956913 + 0.99920064521321 + 0.99920676425450 + 0.99921399578994 + 0.99922260819854 + 0.99923298863878 + 0.99924562404772 + 0.99926110845574 + 0.99928021252023 + 0.99930398683769 + 0.99933393346912 + 0.99937234543511 + 0.99942313647580 + 0.99949424843173 + 0.99960855026346 + 1.00000000000000 + 0.99957805127606 + 0.99941434980198 + 0.99927784580115 + 0.99914683216726 + 0.99901371432730 + 0.99887450087563 + 0.99872675530197 + 0.99856866844331 + 0.99839834559940 + 0.99821397402690 + 0.99801360756668 + 0.99779498844278 + 0.99755543640238 + 0.99729173887208 + 0.99700004109397 + 0.99667574188642 + 0.99631316630857 + 0.99590548899182 + 0.99544515312716 + 0.99492356348188 + 0.99433109031673 + 0.99365764775366 + 0.99289623695816 + 0.99204305453401 + 0.99108845939989 + 0.99002174790549 + 0.98883760201888 + 0.98752616940322 + 0.98607147504264 + 0.98445603722817 + 0.98266170875617 + 0.98066912579900 + 0.97845510875746 + 0.97599260081915 + 0.97324985986187 + 0.97018816259171 + 0.96676233485887 + 0.96292245183776 + 0.95861365924041 + 0.95377068992228 + 0.94832571450186 + 0.94222320796679 + 0.93541710924596 + 0.92786558272823 + 0.91953768475099 + 0.91041417201100 + 0.90049011486694 + 0.88977868044880 + 0.87831617809007 + 0.86616738403960 + 0.85342440169634 + 0.84019303156654 + 0.82660013288564 + 0.81280745245945 + 0.79898538864033 + 0.79210619047818 + 0.78527166674593 + 0.77849272720285 + 0.77177630731350 + 0.76512511074669 + 0.75853752071231 + 0.75200774752801 + 0.74552630756389 + 0.73908078897151 + 0.73265405422588 + 0.72617855132758 + 0.71945611244921 + 0.71238151173070 + 0.70494032783455 + 0.69711690053232 + 0.68892000679892 + 0.68036389462146 + 0.67146693404882 + 0.66225048698495 + 0.65273816080836 + 0.64295378286617 + 0.63289146314770 + 0.62257367698626 + 0.61202681300308 + 0.60128254621144 + 0.59037897368724 + 0.57936099000636 + 0.56826256547633 + 0.55711628031622 + 0.54596830272975 + 0.53485942086106 + 0.52382008662094 + 0.99909896302326 + 0.99911168474902 + 0.99911381748299 + 0.99911631259938 + 0.99911923355792 + 0.99912265565544 + 0.99912666854550 + 0.99913137957920 + 0.99913691913741 + 0.99914345325988 + 0.99915121676030 + 0.99916054675579 + 0.99917186169300 + 0.99918566156535 + 0.99920257870143 + 0.99922344674536 + 0.99924940243611 + 0.99928206315170 + 0.99932390865827 + 0.99937912433799 + 0.99945598808306 + 0.99957805127606 + 1.00000000000000 + 0.99954535390768 + 0.99936880047673 + 0.99921911762098 + 0.99907409045318 + 0.99892605995073 + 0.99877125240417 + 0.99860725722898 + 0.99843186398094 + 0.99824308459185 + 0.99803886465642 + 0.99781687160595 + 0.99757436848209 + 0.99730809635514 + 0.99701416023655 + 0.99668792228981 + 0.99632367216903 + 0.99591455077693 + 0.99545297079004 + 0.99493030896467 + 0.99433691083885 + 0.99366266975868 + 0.99290057120845 + 0.99204679844415 + 0.99109169566141 + 0.99002454718483 + 0.98884002630905 + 0.98752827213649 + 0.98607330171279 + 0.98445762684524 + 0.98266309499844 + 0.98067033784143 + 0.97845617180720 + 0.97599353662815 + 0.97325068713437 + 0.97018889726461 + 0.96676299039447 + 0.96292303951967 + 0.95861418841496 + 0.95377116814802 + 0.94832614787184 + 0.94222360153229 + 0.93541746726521 + 0.92786590877589 + 0.91953798185051 + 0.91041444274009 + 0.90049036143971 + 0.88977890479275 + 0.87831638191386 + 0.86616756887882 + 0.85342456895137 + 0.84019318252678 + 0.82660026877110 + 0.81280757447945 + 0.79898549801510 + 0.79210629397863 + 0.78527176467549 + 0.77849281986160 + 0.77177639499777 + 0.76512519374528 + 0.75853759930827 + 0.75200782198998 + 0.74552637815368 + 0.73908085593507 + 0.73265411779303 + 0.72617861168426 + 0.71945616968148 + 0.71238156587704 + 0.70494037893178 + 0.69711694861138 + 0.68892005188975 + 0.68036393675938 + 0.67146697327532 + 0.66225052334475 + 0.65273819436055 + 0.64295381367963 + 0.63289149129849 + 0.62257370256292 + 0.61202683610947 + 0.60128256696461 + 0.59037899222046 + 0.57936100646270 + 0.56826258000935 + 0.55711629308608 + 0.54596831390391 + 0.53485943060928 + 0.52382009511107 + 0.99902600520383 + 0.99903760765400 + 0.99903954975490 + 0.99904182072483 + 0.99904447772984 + 0.99904758842766 + 0.99905123313950 + 0.99905550770245 + 0.99906052803783 + 0.99906644117064 + 0.99907345446391 + 0.99908186459365 + 0.99909203634557 + 0.99910439921422 + 0.99911948680842 + 0.99913798685706 + 0.99916080835808 + 0.99918918799501 + 0.99922490322264 + 0.99927065940830 + 0.99933090108576 + 0.99941434980198 + 0.99954535390768 + 1.00000000000000 + 0.99951009674676 + 0.99931857117888 + 0.99915343067426 + 0.99899226190323 + 0.99882760397310 + 0.99865568212624 + 0.99847365307770 + 0.99827920179942 + 0.99807008339798 + 0.99784384053703 + 0.99759764628978 + 0.99732817154769 + 0.99703146304010 + 0.99670283188570 + 0.99633652014971 + 0.99592562452189 + 0.99546251836514 + 0.99493854283742 + 0.99434401239607 + 0.99366879446143 + 0.99290585511461 + 0.99205136118702 + 0.99109563869398 + 0.99002795713086 + 0.98884297914076 + 0.98753083326164 + 0.98607552673938 + 0.98445956337811 + 0.98266478408237 + 0.98067181500949 + 0.97845746775670 + 0.97599467782962 + 0.97325169633993 + 0.97018979385069 + 0.96676379071546 + 0.96292375726676 + 0.95861483492511 + 0.95377175257991 + 0.94832667760295 + 0.94222408269653 + 0.93541790503575 + 0.92786630750842 + 0.91953834523643 + 0.91041477392733 + 0.90049066314138 + 0.88977917937774 + 0.87831663147675 + 0.86616779530529 + 0.85342477395942 + 0.84019336769458 + 0.82660043559088 + 0.81280772443694 + 0.79898563259538 + 0.79210642141624 + 0.78527188533857 + 0.77849293411664 + 0.77177650320327 + 0.76512529625022 + 0.75853769645263 + 0.75200791410224 + 0.74552646554478 + 0.73908093890111 + 0.73265419660763 + 0.72617868657144 + 0.71945624073764 + 0.71238163314283 + 0.70494044244433 + 0.69711700839987 + 0.68892010798901 + 0.68036398920692 + 0.67146702211667 + 0.66225056863596 + 0.65273823616937 + 0.64295385209194 + 0.63289152640422 + 0.62257373447305 + 0.61202686495117 + 0.60128259288393 + 0.59037901537937 + 0.57936102703999 + 0.56826259819477 + 0.55711630907744 + 0.54596832790887 + 0.53485944283944 + 0.52382010577322 + 0.99894544184005 + 0.99895600686321 + 0.99895777317145 + 0.99895983778609 + 0.99896225225767 + 0.99896507748667 + 0.99896838560522 + 0.99897226244993 + 0.99897681152920 + 0.99898216370106 + 0.99898850315091 + 0.99899609267135 + 0.99900525317348 + 0.99901635849517 + 0.99902986727874 + 0.99904636142514 + 0.99906659408558 + 0.99909156043955 + 0.99912263471298 + 0.99916178487621 + 0.99921192596740 + 0.99927784580115 + 0.99936880047673 + 0.99951009674676 + 1.00000000000000 + 0.99947167804723 + 0.99926241655682 + 0.99907935124793 + 0.99890010854394 + 0.99871715547789 + 0.99852622367438 + 0.99832434064753 + 0.99810890836771 + 0.99787725310844 + 0.99762640049747 + 0.99735291210872 + 0.99705274800148 + 0.99672114654534 + 0.99635228453880 + 0.99593919977110 + 0.99547421423824 + 0.99494862334853 + 0.99435270209342 + 0.99367628530240 + 0.99291231485869 + 0.99205693724873 + 0.99110045594864 + 0.99003212209210 + 0.98884658519759 + 0.98753396073840 + 0.98607824380608 + 0.98446192830727 + 0.98266684706661 + 0.98067361947271 + 0.97845905117798 + 0.97599607253728 + 0.97325293009810 + 0.97019089028919 + 0.96676476975441 + 0.96292463557005 + 0.95861562627448 + 0.95377246810931 + 0.94832732627587 + 0.94222467197312 + 0.93541844122069 + 0.92786679592277 + 0.91953879039754 + 0.91041517969950 + 0.90049103285951 + 0.88977951595052 + 0.87831693748358 + 0.86616807306606 + 0.85342502558736 + 0.84019359513015 + 0.82660064066509 + 0.81280790896319 + 0.79898579839401 + 0.79210657851428 + 0.78527203418912 + 0.77849307516206 + 0.77177663687935 + 0.76512542297972 + 0.75853781664870 + 0.75200802815912 + 0.74552657384004 + 0.73908104178820 + 0.73265429441727 + 0.72617877956819 + 0.71945632903197 + 0.71238171677513 + 0.70494052144903 + 0.69711708280697 + 0.68892017783355 + 0.68036405452983 + 0.67146708297194 + 0.66225062508811 + 0.65273828830222 + 0.64295390000623 + 0.63289157021317 + 0.62257377431155 + 0.61202690097699 + 0.60128262527573 + 0.59037904433880 + 0.57936105278755 + 0.56826262096505 + 0.55711632911646 + 0.54596834547349 + 0.53485945819230 + 0.52382011917133 + 0.99885641179705 + 0.99886600960107 + 0.99886761266681 + 0.99886948590203 + 0.99887167577903 + 0.99887423712612 + 0.99887723476182 + 0.99888074566505 + 0.99888486243735 + 0.99888970186610 + 0.99889542802124 + 0.99890227448168 + 0.99891052503415 + 0.99892050769131 + 0.99893262121715 + 0.99894736590649 + 0.99896537988890 + 0.99898748993203 + 0.99901480863558 + 0.99904887078732 + 0.99909181512221 + 0.99914683216726 + 0.99921911762098 + 0.99931857117888 + 0.99947167804723 + 1.00000000000000 + 0.99942908821485 + 0.99919904671194 + 0.99899576237877 + 0.99879653723919 + 0.99859321461713 + 0.99838134060799 + 0.99815761155813 + 0.99791895780407 + 0.99766215305542 + 0.99738358251315 + 0.99707907327395 + 0.99674375708899 + 0.99637171908751 + 0.99595591694121 + 0.99548860435310 + 0.99496101705441 + 0.99436337929184 + 0.99368548445007 + 0.99292024394306 + 0.99206377883256 + 0.99110636446360 + 0.99003722912033 + 0.98885100605021 + 0.98753779447665 + 0.98608157437228 + 0.98446482734037 + 0.98266937619569 + 0.98067583196878 + 0.97846099301638 + 0.97599778334245 + 0.97325444389550 + 0.97019223600907 + 0.96676597175782 + 0.96292571421866 + 0.95861659839579 + 0.95377334727770 + 0.94832812342284 + 0.94222539620976 + 0.93541910026224 + 0.92786739629150 + 0.91953933764808 + 0.91041567859172 + 0.90049148750153 + 0.88977992994022 + 0.87831731400584 + 0.86616841498770 + 0.85342533551966 + 0.84019387545884 + 0.82660089364911 + 0.81280813682835 + 0.79898600337141 + 0.79210677286387 + 0.78527221845862 + 0.77849324989427 + 0.77177680260509 + 0.76512558021737 + 0.75853796589367 + 0.75200816989084 + 0.74552670851315 + 0.73908116982966 + 0.73265441622574 + 0.72617889545805 + 0.71945643913014 + 0.71238182111885 + 0.70494062007147 + 0.69711717573323 + 0.68892026509810 + 0.68036413617830 + 0.67146715906282 + 0.66225069569988 + 0.65273835353484 + 0.64295395998391 + 0.63289162507429 + 0.62257382422335 + 0.61202694613304 + 0.60128266589815 + 0.59037908067811 + 0.57936108511633 + 0.56826264957738 + 0.55711635431652 + 0.54596836758299 + 0.53485947753517 + 0.52382013606928 + 0.99875775525805 + 0.99876644646453 + 0.99876789699705 + 0.99876959158090 + 0.99877157205120 + 0.99877388769481 + 0.99877659670857 + 0.99877976809219 + 0.99878348468941 + 0.99878785078138 + 0.99879301260668 + 0.99879917795593 + 0.99880659831257 + 0.99881556267526 + 0.99882641998575 + 0.99883960444956 + 0.99885566410566 + 0.99887529923053 + 0.99889943595242 + 0.99892932119393 + 0.99896662746414 + 0.99901371432730 + 0.99907409045318 + 0.99915343067426 + 0.99926241655682 + 0.99942908821485 + 1.00000000000000 + 0.99938159446290 + 0.99912775929259 + 0.99890188537535 + 0.99868027583368 + 0.99845444251262 + 0.99821950033501 + 0.99797159684188 + 0.99770705012193 + 0.99742194742610 + 0.99711190370419 + 0.99677188895707 + 0.99639585555083 + 0.99597664928517 + 0.99550643093951 + 0.99497635680986 + 0.99437658474524 + 0.99369685461127 + 0.99293003889387 + 0.99207222650355 + 0.99111365730572 + 0.99004353086373 + 0.98885646008017 + 0.98754252382399 + 0.98608568306884 + 0.98446840400743 + 0.98267249696909 + 0.98067856260646 + 0.97846339023087 + 0.97599989600123 + 0.97325631393480 + 0.97019389905711 + 0.96676745779358 + 0.96292704825527 + 0.95861780109550 + 0.95377443528896 + 0.94832911015197 + 0.94222629284441 + 0.93541991630016 + 0.92786813978167 + 0.91954001546029 + 0.91041629662121 + 0.90049205085516 + 0.88978044308517 + 0.87831778090997 + 0.86616883921445 + 0.85342572030967 + 0.84019422378053 + 0.82660120829340 + 0.81280842055190 + 0.79898625892601 + 0.79210701533896 + 0.78527244852994 + 0.77849346822772 + 0.77177700985094 + 0.76512577700585 + 0.75853815283624 + 0.75200834756953 + 0.74552687747835 + 0.73908133060434 + 0.73265456928860 + 0.72617904118621 + 0.71945657766506 + 0.71238195249029 + 0.70494074430836 + 0.69711729285230 + 0.68892037513005 + 0.68036423917270 + 0.67146725508611 + 0.66225078484366 + 0.65273843592078 + 0.64295403576656 + 0.63289169442402 + 0.62257388734533 + 0.61202700327236 + 0.60128271733117 + 0.59037912671692 + 0.57936112610650 + 0.56826268588237 + 0.55711638632071 + 0.54596839568866 + 0.53485950215004 + 0.52382015759674 + 0.99864820911009 + 0.99865604847542 + 0.99865735603331 + 0.99865888329404 + 0.99866066780893 + 0.99866275377774 + 0.99866519333489 + 0.99866804821598 + 0.99867139242575 + 0.99867531896136 + 0.99867995801736 + 0.99868549424275 + 0.99869215046121 + 0.99870018161613 + 0.99870989395441 + 0.99872166618481 + 0.99873597257968 + 0.99875341306841 + 0.99877477137211 + 0.99880108533061 + 0.99883371213485 + 0.99887450087563 + 0.99892605995073 + 0.99899226190323 + 0.99907935124793 + 0.99919904671194 + 0.99938159446290 + 1.00000000000000 + 0.99932889898433 + 0.99904800006919 + 0.99879655462060 + 0.99855006801748 + 0.99829937963882 + 0.99803890146045 + 0.99776406055092 + 0.99747041047154 + 0.99715321108438 + 0.99680717671855 + 0.99642606053946 + 0.99600254730009 + 0.99552866793195 + 0.99499547052518 + 0.99439302426869 + 0.99371099868240 + 0.99294221570703 + 0.99208272300991 + 0.99112271521379 + 0.99005135540659 + 0.98886323083029 + 0.98754839460082 + 0.98609078364906 + 0.98447284471982 + 0.98267637244727 + 0.98068195449976 + 0.97846636891829 + 0.97600252209635 + 0.97325863943277 + 0.97019596809298 + 0.96676930745909 + 0.96292870947281 + 0.95861929937719 + 0.95377579117410 + 0.94833034017329 + 0.94222741082051 + 0.93542093398987 + 0.92786906717269 + 0.91954086110067 + 0.91041706786523 + 0.90049275408241 + 0.88978108389094 + 0.87831836425768 + 0.86616936956655 + 0.85342620172059 + 0.84019465995505 + 0.82660160270889 + 0.81280877663592 + 0.79898658009920 + 0.79210732030111 + 0.78527273811999 + 0.77849374326691 + 0.77177727114339 + 0.76512602532864 + 0.75853838893725 + 0.75200857216402 + 0.74552709124279 + 0.73908153416988 + 0.73265476323829 + 0.72617922597961 + 0.71945675345557 + 0.71238211929631 + 0.70494090214252 + 0.69711744171983 + 0.68892051505675 + 0.68036437020574 + 0.67146737729928 + 0.66225089834869 + 0.65273854086719 + 0.64295413234579 + 0.63289178284635 + 0.62257396787034 + 0.61202707620437 + 0.60128278302178 + 0.59037918555969 + 0.57936117853462 + 0.56826273236015 + 0.55711642733215 + 0.54596843174127 + 0.53485953376214 + 0.52382018527564 + 0.99852664997248 + 0.99853369035752 + 0.99853486406899 + 0.99853623478340 + 0.99853783608785 + 0.99853970749977 + 0.99854189558272 + 0.99854445541564 + 0.99854745295282 + 0.99855097094027 + 0.99855512501713 + 0.99856007890003 + 0.99856602969579 + 0.99857320218831 + 0.99858186532427 + 0.99859235009406 + 0.99860506854283 + 0.99862053792982 + 0.99863942791124 + 0.99866261480065 + 0.99869122440278 + 0.99872675530197 + 0.99877125240417 + 0.99882760397310 + 0.99890010854394 + 0.99899576237877 + 0.99912775929259 + 0.99932889898433 + 1.00000000000000 + 0.99927044967264 + 0.99895844761937 + 0.99867836883132 + 0.99840433469801 + 0.99812613199771 + 0.99783723962550 + 0.99753217920404 + 0.99720558075758 + 0.99685173494763 + 0.99646408393050 + 0.99603507269762 + 0.99555654547724 + 0.99501939932507 + 0.99441358253827 + 0.99372867045916 + 0.99295741825155 + 0.99209581990921 + 0.99113401177847 + 0.99006111025878 + 0.98887166995475 + 0.98755571123702 + 0.98609714043748 + 0.98447837962679 + 0.98268120361523 + 0.98068618376416 + 0.97847008399341 + 0.97600579849448 + 0.97326154189361 + 0.97019855153000 + 0.96677161796285 + 0.96293078543260 + 0.95862117242160 + 0.95377748674170 + 0.94833187873623 + 0.94222880951395 + 0.93542220743301 + 0.92787022781454 + 0.91954191962024 + 0.91041803347166 + 0.90049363478494 + 0.88978188671838 + 0.87831909544995 + 0.86617003473054 + 0.85342680594805 + 0.84019520787685 + 0.82660209868052 + 0.81280922493120 + 0.79898698497824 + 0.79210770501901 + 0.78527310372050 + 0.77849409077129 + 0.77177760154362 + 0.76512633958674 + 0.75853868797589 + 0.75200885686102 + 0.74552736242858 + 0.73908179262018 + 0.73265500966241 + 0.72617946093015 + 0.71945697710267 + 0.71238233163803 + 0.70494110317034 + 0.69711763142065 + 0.68892069344244 + 0.68036453732187 + 0.67146753323105 + 0.66225104322774 + 0.65273867487444 + 0.64295425572134 + 0.63289189585683 + 0.62257407083881 + 0.61202716951716 + 0.60128286712183 + 0.59037926094424 + 0.57936124575383 + 0.56826279199878 + 0.55711648000789 + 0.54596847809656 + 0.53485957445284 + 0.52382022094705 + 0.99839196743253 + 0.99839826167734 + 0.99839931058213 + 0.99840053538772 + 0.99840196603039 + 0.99840363770721 + 0.99840559186352 + 0.99840787748445 + 0.99841055316767 + 0.99841369232435 + 0.99841739735989 + 0.99842181299492 + 0.99842711314760 + 0.99843349567965 + 0.99844119659727 + 0.99845050525288 + 0.99846178017354 + 0.99847546880500 + 0.99849214643729 + 0.99851255926595 + 0.99853765356677 + 0.99856866844331 + 0.99860725722898 + 0.99865568212624 + 0.99871715547789 + 0.99879653723919 + 0.99890188537535 + 0.99904800006919 + 0.99927044967264 + 1.00000000000000 + 0.99920491419641 + 0.99885764820995 + 0.99854569994719 + 0.99824115239532 + 0.99793238641030 + 0.99761169835951 + 0.99727251299795 + 0.99690837680303 + 0.99651222285495 + 0.99607612501991 + 0.99559165007240 + 0.99504947831441 + 0.99443938920898 + 0.99375082938538 + 0.99297646404807 + 0.99211221613761 + 0.99114814615903 + 0.99007331022260 + 0.98888222111154 + 0.98756485730247 + 0.98610508603323 + 0.98448529794685 + 0.98268724271941 + 0.98069147113719 + 0.97847472936996 + 0.97600989630665 + 0.97326517304907 + 0.97020178459097 + 0.96677451041985 + 0.96293338509737 + 0.95862351865742 + 0.95377961116404 + 0.94833380677805 + 0.94223056250323 + 0.93542380360184 + 0.92787168273206 + 0.91954324667508 + 0.91041924423770 + 0.90049473933824 + 0.88978289391920 + 0.87832001316255 + 0.86617087002105 + 0.85342756522219 + 0.84019589695292 + 0.82660272300298 + 0.81280978984937 + 0.79898749580762 + 0.79210819073327 + 0.78527356561733 + 0.77849453011925 + 0.77177801957538 + 0.76512673749190 + 0.75853906689758 + 0.75200921788274 + 0.74552770656854 + 0.73908212083089 + 0.73265532281235 + 0.72617975968927 + 0.71945726165477 + 0.71238260195150 + 0.70494135920752 + 0.69711787313493 + 0.68892092082991 + 0.68036475042529 + 0.67146773214650 + 0.66225122810857 + 0.65273884594928 + 0.64295441328574 + 0.63289204024804 + 0.62257420246461 + 0.61202728886263 + 0.60128297474716 + 0.59037935747897 + 0.57936133189600 + 0.56826286849024 + 0.55711654762936 + 0.54596853766417 + 0.53485962679721 + 0.52382026688726 + 0.99824269514606 + 0.99824829591267 + 0.99824922895688 + 0.99825031836328 + 0.99825159070572 + 0.99825307720828 + 0.99825481462040 + 0.99825684635341 + 0.99825922427938 + 0.99826201331416 + 0.99826530382117 + 0.99826922326611 + 0.99827392461958 + 0.99827958160374 + 0.99828640092983 + 0.99829463527314 + 0.99830459655666 + 0.99831667225595 + 0.99833135787030 + 0.99834929171331 + 0.99837127532253 + 0.99839834559940 + 0.99843186398094 + 0.99847365307770 + 0.99852622367438 + 0.99859321461713 + 0.99868027583368 + 0.99879655462060 + 0.99895844761937 + 0.99920491419641 + 1.00000000000000 + 0.99913145121917 + 0.99874437225621 + 0.99839693881000 + 0.99805848230264 + 0.99771557192506 + 0.99735905887084 + 0.99698107605650 + 0.99657367094126 + 0.99612831383574 + 0.99563614197672 + 0.99508751354668 + 0.99447196505793 + 0.99377876253492 + 0.99300044696874 + 0.99213284521983 + 0.99116591763057 + 0.99008864152820 + 0.98889547546575 + 0.98757634388291 + 0.98611506371142 + 0.98449398530582 + 0.98269482629102 + 0.98069811132403 + 0.97848056414595 + 0.97601504433401 + 0.97326973595648 + 0.97020584841003 + 0.96677814719942 + 0.96293665468960 + 0.95862647026958 + 0.95378228427830 + 0.94833623314953 + 0.94223276879957 + 0.93542581267616 + 0.92787351414701 + 0.91954491729345 + 0.91042076867343 + 0.90049613033865 + 0.88978416270085 + 0.87832116969032 + 0.86617192323710 + 0.85342852321683 + 0.84019676706286 + 0.82660351207353 + 0.81281050458709 + 0.79898814287780 + 0.79210880638603 + 0.78527415146934 + 0.77849508775519 + 0.77177855053307 + 0.76512724325426 + 0.75853954887840 + 0.75200967742440 + 0.74552814493171 + 0.73908253918563 + 0.73265572222789 + 0.72618014097579 + 0.71945762501539 + 0.71238294730523 + 0.70494168647269 + 0.69711818222468 + 0.68892121171362 + 0.68036502313553 + 0.67146798678745 + 0.66225146487134 + 0.65273906511147 + 0.64295461522444 + 0.63289222538091 + 0.62257437131078 + 0.61202744203786 + 0.60128311295944 + 0.59037948153012 + 0.57936144267317 + 0.56826296693834 + 0.55711663474069 + 0.54596861447772 + 0.53485969436920 + 0.52382032625845 + 0.99807727169976 + 0.99808223224592 + 0.99808305842754 + 0.99808402298842 + 0.99808514942039 + 0.99808646531142 + 0.99808800312367 + 0.99808980117389 + 0.99809190522676 + 0.99809437247161 + 0.99809728235343 + 0.99810074671019 + 0.99810489961520 + 0.99810989314328 + 0.99811590791484 + 0.99812316418198 + 0.99813193302127 + 0.99814254993369 + 0.99815544208333 + 0.99817115678286 + 0.99819037606069 + 0.99821397402690 + 0.99824308459185 + 0.99827920179942 + 0.99832434064753 + 0.99838134060799 + 0.99845444251262 + 0.99855006801748 + 0.99867836883132 + 0.99885764820995 + 0.99913145121917 + 1.00000000000000 + 0.99904899540169 + 0.99861706122368 + 0.99823009306324 + 0.99785381150062 + 0.99747253667967 + 0.99707540694604 + 0.99665280256748 + 0.99619515063947 + 0.99569288996922 + 0.99513588013662 + 0.99451329566979 + 0.99381414140915 + 0.99303078198267 + 0.99215891107198 + 0.99118835455124 + 0.99010798539157 + 0.98891219093319 + 0.98759082528940 + 0.98612764023420 + 0.98450493417047 + 0.98270438357223 + 0.98070647977968 + 0.97848791802664 + 0.97602153342949 + 0.97327548845817 + 0.97021097275369 + 0.96678273407416 + 0.96294077932498 + 0.95863019445697 + 0.95378565752473 + 0.94833929526875 + 0.94223555327305 + 0.93542834827467 + 0.92787582555364 + 0.91954702584138 + 0.91042269288128 + 0.90049788639452 + 0.88978576486453 + 0.87832263062900 + 0.86617325430997 + 0.85342973468167 + 0.84019786819206 + 0.82660451150252 + 0.81281141075682 + 0.79898896415534 + 0.79210958824763 + 0.78527489594704 + 0.77849579682987 + 0.77177922612637 + 0.76512788721446 + 0.75854016297107 + 0.75201026331578 + 0.74552870418292 + 0.73908307324464 + 0.73265623241035 + 0.72618062827627 + 0.71945808964411 + 0.71238338911510 + 0.70494210532011 + 0.69711857796403 + 0.68892158427467 + 0.68036537253507 + 0.67146831314624 + 0.66225176841667 + 0.65273934619262 + 0.64295487431253 + 0.63289246300643 + 0.62257458813015 + 0.61202763883201 + 0.60128329063255 + 0.59037964110155 + 0.57936158527026 + 0.56826309376510 + 0.55711674706108 + 0.54596871361637 + 0.53485978167181 + 0.52382040304926 + 0.99789391919384 + 0.99789829323878 + 0.99789902159942 + 0.99789987190745 + 0.99790086484070 + 0.99790202468795 + 0.99790338000631 + 0.99790496450527 + 0.99790681840410 + 0.99790899191730 + 0.99791155462597 + 0.99791460429063 + 0.99791825800018 + 0.99792264847990 + 0.99792793312952 + 0.99793430353255 + 0.99794199490771 + 0.99795129750777 + 0.99796257960007 + 0.99797631095885 + 0.99799307349174 + 0.99801360756668 + 0.99803886465642 + 0.99807008339798 + 0.99810890836771 + 0.99815761155813 + 0.99821950033501 + 0.99829937963882 + 0.99840433469801 + 0.99854569994719 + 0.99874437225621 + 0.99904899540169 + 1.00000000000000 + 0.99895622860268 + 0.99847386120189 + 0.99804278303610 + 0.99762412308316 + 0.99719950031744 + 0.99675579246862 + 0.99628147454156 + 0.99576577830686 + 0.99519775259994 + 0.99456600990773 + 0.99385916370500 + 0.99306931998521 + 0.99219198252297 + 0.99121679309150 + 0.99013248418322 + 0.98893334822775 + 0.98760914687327 + 0.98614354685590 + 0.98451877912684 + 0.98271646706274 + 0.98071705924049 + 0.97849721448836 + 0.97602973676808 + 0.97328276107403 + 0.97021745187047 + 0.96678853431969 + 0.96294599565661 + 0.95863490476012 + 0.95378992414464 + 0.94834316831952 + 0.94223907497793 + 0.93543155498442 + 0.92787874853730 + 0.91954969218021 + 0.91042512614602 + 0.90050010721107 + 0.88978779142448 + 0.87832447909179 + 0.86617493914746 + 0.85343126893854 + 0.84019926362707 + 0.82660577902635 + 0.81281256101657 + 0.79899000769194 + 0.79211058223434 + 0.78527584293307 + 0.77849669930268 + 0.77178008649528 + 0.76512870779413 + 0.75854094596265 + 0.75201101079796 + 0.74552941809615 + 0.73908375538308 + 0.73265688440311 + 0.72618125133604 + 0.71945868398797 + 0.71238395450919 + 0.70494264153420 + 0.69711908477089 + 0.68892206154848 + 0.68036582027486 + 0.67146873148336 + 0.66225215762714 + 0.65273970671571 + 0.64295520674357 + 0.63289276801726 + 0.62257486655439 + 0.61202789166117 + 0.60128351901729 + 0.59037984634050 + 0.57936176880124 + 0.56826325712298 + 0.55711689185761 + 0.54596884153734 + 0.53485989443210 + 0.52382050233783 + 0.99769051311040 + 0.99769435421445 + 0.99769499374405 + 0.99769574031376 + 0.99769661206523 + 0.99769763029887 + 0.99769882005668 + 0.99770021087900 + 0.99770183800830 + 0.99770374537410 + 0.99770599372063 + 0.99770866818416 + 0.99771187068616 + 0.99771571670820 + 0.99772034306908 + 0.99772591603882 + 0.99773263937739 + 0.99774076391419 + 0.99775060696975 + 0.99776257192198 + 0.99777715605718 + 0.99779498844278 + 0.99781687160595 + 0.99784384053703 + 0.99787725310844 + 0.99791895780407 + 0.99797159684188 + 0.99803890146045 + 0.99812613199771 + 0.99824115239532 + 0.99839693881000 + 0.99861706122368 + 0.99895622860268 + 1.00000000000000 + 0.99885165449975 + 0.99831264487018 + 0.99783222438361 + 0.99736585549486 + 0.99689169989161 + 0.99639415334104 + 0.99586018897364 + 0.99527745385275 + 0.99463364291918 + 0.99391675789317 + 0.99311851097708 + 0.99223412610884 + 0.99125298690198 + 0.99016363303512 + 0.98896022811678 + 0.98763241068387 + 0.98616373549817 + 0.98453634526095 + 0.98273179431149 + 0.98073047599685 + 0.97850900239139 + 0.97604013757112 + 0.97329198139562 + 0.97022566612100 + 0.96679588798513 + 0.96295260909140 + 0.95864087655161 + 0.95379533312013 + 0.94834807783373 + 0.94224353848266 + 0.93543561861058 + 0.92788245204638 + 0.91955307009870 + 0.91042820857056 + 0.90050292052963 + 0.88979035892386 + 0.87832682145211 + 0.86617707487109 + 0.85343321466318 + 0.84020103430099 + 0.82660738848156 + 0.81281402271482 + 0.79899133493674 + 0.79211184706072 + 0.78527704855266 + 0.77849784884523 + 0.77178118298801 + 0.76512975413779 + 0.75854194491649 + 0.75201196495952 + 0.74553032988517 + 0.73908462703078 + 0.73265771792848 + 0.72618204822939 + 0.71945944446765 + 0.71238467821867 + 0.70494332812584 + 0.69711973390599 + 0.68892267303173 + 0.68036639407030 + 0.67146926773746 + 0.66225265668398 + 0.65274016912091 + 0.64295563325540 + 0.63289315948669 + 0.62257522404168 + 0.61202821643292 + 0.60128381253490 + 0.59038011026029 + 0.57936200495710 + 0.56826346747278 + 0.55711707845643 + 0.54596900653456 + 0.53486004001222 + 0.52382063065279 + 0.99746449235919 + 0.99746785319661 + 0.99746841270988 + 0.99746906585305 + 0.99746982848545 + 0.99747071922761 + 0.99747175996784 + 0.99747297652090 + 0.99747439966362 + 0.99747606772674 + 0.99747803356128 + 0.99748037107982 + 0.99748316872321 + 0.99748652670083 + 0.99749056365587 + 0.99749542359604 + 0.99750128272358 + 0.99750835755081 + 0.99751692132362 + 0.99752732039740 + 0.99753998019480 + 0.99755543640238 + 0.99757436848209 + 0.99759764628978 + 0.99762640049747 + 0.99766215305542 + 0.99770705012193 + 0.99776406055092 + 0.99783723962550 + 0.99793238641030 + 0.99805848230264 + 0.99823009306324 + 0.99847386120189 + 0.99885165449975 + 1.00000000000000 + 0.99873356871123 + 0.99813095144329 + 0.99759514830809 + 0.99707449138390 + 0.99654328046117 + 0.99598376962408 + 0.99538098113865 + 0.99472101579839 + 0.99399086885602 + 0.99318162614414 + 0.99228808328327 + 0.99129925130067 + 0.99020339883978 + 0.98899451080140 + 0.98766205931440 + 0.98618945000857 + 0.98455870902556 + 0.98275130021005 + 0.98074754504748 + 0.97852399515480 + 0.97605336326346 + 0.97330370405221 + 0.97023610837535 + 0.96680523529419 + 0.96296101464060 + 0.95864846566040 + 0.95380220587404 + 0.94835431466460 + 0.94224920735599 + 0.93544077829948 + 0.92788715333234 + 0.91955735715268 + 0.91043211998351 + 0.90050649017755 + 0.88979361671836 + 0.87832979395780 + 0.86617978581840 + 0.85343568533898 + 0.84020328376661 + 0.82660943431665 + 0.81281588198297 + 0.79899302447838 + 0.79211345781576 + 0.78527858457494 + 0.77849931408502 + 0.77178258125625 + 0.76513108908929 + 0.75854322001686 + 0.75201318346326 + 0.74553149481699 + 0.73908574117453 + 0.73265878379387 + 0.72618306765460 + 0.71946041766489 + 0.71238560466608 + 0.70494420731501 + 0.69712056535366 + 0.68892345644063 + 0.68036712936393 + 0.67146995508304 + 0.66225329650502 + 0.65274076210714 + 0.64295618036705 + 0.63289366181256 + 0.62257568292966 + 0.61202863349339 + 0.60128418963613 + 0.59038044951556 + 0.57936230870704 + 0.56826373821404 + 0.55711731881048 + 0.54596921924002 + 0.53486022785516 + 0.52382079637425 + 0.99721275989947 + 0.99721569148713 + 0.99721617951168 + 0.99721674919122 + 0.99721741435467 + 0.99721819123644 + 0.99721909891298 + 0.99722015988496 + 0.99722140096553 + 0.99722285550810 + 0.99722456938760 + 0.99722660658659 + 0.99722904365623 + 0.99723196735576 + 0.99723548035024 + 0.99723970714894 + 0.99724479990739 + 0.99725094532025 + 0.99725837853333 + 0.99726739692629 + 0.99727836471639 + 0.99729173887208 + 0.99730809635514 + 0.99732817154769 + 0.99735291210872 + 0.99738358251315 + 0.99742194742610 + 0.99747041047154 + 0.99753217920404 + 0.99761169835951 + 0.99771557192506 + 0.99785381150062 + 0.99804278303610 + 0.99831264487018 + 0.99873356871123 + 1.00000000000000 + 0.99860002177067 + 0.99792591759980 + 0.99732735992410 + 0.99674444959811 + 0.99614777242937 + 0.99551686433050 + 0.99483482456927 + 0.99408688427245 + 0.99326307986300 + 0.99235752186337 + 0.99135866451793 + 0.99025438429841 + 0.98903841167458 + 0.98769998954843 + 0.98622232218412 + 0.98458727999362 + 0.98277620698683 + 0.98076933032220 + 0.97854312285399 + 0.97607023077023 + 0.97331865033316 + 0.97024941888778 + 0.96681714748314 + 0.96297172432423 + 0.95865813281893 + 0.95381095813822 + 0.94836225459868 + 0.94225642173913 + 0.93544734233248 + 0.92789313212003 + 0.91956280744915 + 0.91043709144547 + 0.90051102645951 + 0.88979775638843 + 0.87833357124958 + 0.86618323126265 + 0.85343882625662 + 0.84020614454279 + 0.82661203735722 + 0.81281824897968 + 0.79899517679645 + 0.79211551049507 + 0.78528054275171 + 0.77850118275173 + 0.77178436523059 + 0.76513279298035 + 0.75854484818757 + 0.75201474000649 + 0.74553298352966 + 0.73908716553736 + 0.73266014693830 + 0.72618437185224 + 0.71946166311066 + 0.71238679061955 + 0.70494533305727 + 0.69712163020401 + 0.68892445997371 + 0.68036807144671 + 0.67147083590242 + 0.66225411658851 + 0.65274152233624 + 0.64295688196103 + 0.63289430615809 + 0.62257627174917 + 0.61202916884405 + 0.60128467390196 + 0.59038088539224 + 0.57936269918638 + 0.56826408648266 + 0.55711762820956 + 0.54596949326405 + 0.53486047005240 + 0.52382101023760 + 0.99693157830630 + 0.99693412928073 + 0.99693455393155 + 0.99693504962954 + 0.99693562840639 + 0.99693630437943 + 0.99693709414797 + 0.99693801727844 + 0.99693909708574 + 0.99694036253824 + 0.99694185336429 + 0.99694362484865 + 0.99694574311603 + 0.99694828314556 + 0.99695133364720 + 0.99695500211770 + 0.99695941981641 + 0.99696474760295 + 0.99697118776398 + 0.99697899563725 + 0.99698848327940 + 0.99700004109397 + 0.99701416023655 + 0.99703146304010 + 0.99705274800148 + 0.99707907327395 + 0.99711190370419 + 0.99715321108438 + 0.99720558075758 + 0.99727251299795 + 0.99735905887084 + 0.99747253667967 + 0.99762412308316 + 0.99783222438361 + 0.99813095144329 + 0.99860002177067 + 1.00000000000000 + 0.99844877436209 + 0.99769377713849 + 0.99702363536431 + 0.99636960365881 + 0.99569766198363 + 0.99498460039632 + 0.99421229548929 + 0.99336891021044 + 0.99244740076985 + 0.99143535349658 + 0.99032005721521 + 0.98909486873056 + 0.98774870783076 + 0.98626450220596 + 0.98462391121595 + 0.98280811824417 + 0.98079722530807 + 0.97856760174714 + 0.97609180683010 + 0.97333776080507 + 0.97026643147801 + 0.96683236756246 + 0.96298540332570 + 0.95867047586196 + 0.95382212869352 + 0.94837238402589 + 0.94226562133224 + 0.93545570872193 + 0.92790074911278 + 0.91956974824755 + 0.91044342020248 + 0.90051679963084 + 0.88980302387479 + 0.87833837731760 + 0.86618761533532 + 0.85344282351070 + 0.84020978626899 + 0.82661535219675 + 0.81282126458262 + 0.79899792034556 + 0.79211812780206 + 0.78528304033500 + 0.77850356694449 + 0.77178664213686 + 0.76513496842759 + 0.75854692769018 + 0.75201672872389 + 0.74553488623522 + 0.73908898660483 + 0.73266189028689 + 0.72618604030114 + 0.71946325682283 + 0.71238830855933 + 0.70494677423220 + 0.69712299367414 + 0.68892574514099 + 0.68036927810643 + 0.67147196427196 + 0.66225516733247 + 0.65274249657229 + 0.64295778125341 + 0.63289513227816 + 0.62257702689929 + 0.61202985565161 + 0.60128529541533 + 0.59038144505560 + 0.57936320081676 + 0.56826453415035 + 0.55711802617760 + 0.54596984598889 + 0.53486078205827 + 0.52382128597128 + 0.99661646857608 + 0.99661868451280 + 0.99661905338566 + 0.99661948397311 + 0.99661998672737 + 0.99662057390623 + 0.99662125992744 + 0.99662206178441 + 0.99662299971966 + 0.99662409885549 + 0.99662539355644 + 0.99662693152273 + 0.99662876980540 + 0.99663097312690 + 0.99663361805867 + 0.99663679734373 + 0.99664062414107 + 0.99664523700275 + 0.99665080993792 + 0.99665756226236 + 0.99666576156497 + 0.99667574188642 + 0.99668792228981 + 0.99670283188570 + 0.99672114654534 + 0.99674375708899 + 0.99677188895707 + 0.99680717671855 + 0.99685173494763 + 0.99690837680303 + 0.99698107605650 + 0.99707540694604 + 0.99719950031744 + 0.99736585549486 + 0.99759514830809 + 0.99792591759980 + 0.99844877436209 + 1.00000000000000 + 0.99827666198600 + 0.99742976272519 + 0.99667831637714 + 0.99594281226257 + 0.99518438168512 + 0.99437777369391 + 0.99350752327757 + 0.99256451440326 + 0.99153490880630 + 0.99040507647774 + 0.98916780486691 + 0.98781154529242 + 0.98631883737478 + 0.98467104939556 + 0.98284914619113 + 0.98083306162357 + 0.97859902750568 + 0.97611948858221 + 0.97336226542321 + 0.97028823489698 + 0.96685186435504 + 0.96300291780150 + 0.95868627218896 + 0.95383641719513 + 0.94838533369986 + 0.94227737553824 + 0.93546639214365 + 0.92791047009099 + 0.91957860157129 + 0.91045148906267 + 0.90052415730985 + 0.88980973516644 + 0.87834449966698 + 0.86619319981033 + 0.85344791555325 + 0.84021442614942 + 0.82661957664777 + 0.81282510894971 + 0.79900141930240 + 0.79212146652650 + 0.78528622712184 + 0.77850660983981 + 0.77178954889840 + 0.76513774645083 + 0.75854958396124 + 0.75201926976492 + 0.74553731807224 + 0.73909131473877 + 0.73266411964340 + 0.72618817439115 + 0.71946529576000 + 0.71239025092524 + 0.70494861866815 + 0.69712473891062 + 0.68892739035462 + 0.68037082299736 + 0.67147340909943 + 0.66225651293871 + 0.65274374438980 + 0.64295893328976 + 0.63289619080320 + 0.62257799473175 + 0.61203073615531 + 0.60128609248323 + 0.59038216309401 + 0.57936384470415 + 0.56826510908206 + 0.55711853759613 + 0.54597029957250 + 0.53486118357207 + 0.52382164108060 + 0.99626188730592 + 0.99626381000239 + 0.99626413006149 + 0.99626450366819 + 0.99626493989022 + 0.99626544936538 + 0.99626604460261 + 0.99626674034461 + 0.99626755414749 + 0.99626850778282 + 0.99626963094738 + 0.99627096477195 + 0.99627255844031 + 0.99627446779579 + 0.99627675889523 + 0.99627951171712 + 0.99628282379511 + 0.99628681446568 + 0.99629163344855 + 0.99629746920796 + 0.99630455142224 + 0.99631316630857 + 0.99632367216903 + 0.99633652014971 + 0.99635228453880 + 0.99637171908751 + 0.99639585555083 + 0.99642606053946 + 0.99646408393050 + 0.99651222285495 + 0.99657367094126 + 0.99665280256748 + 0.99675579246862 + 0.99689169989161 + 0.99707449138390 + 0.99732735992410 + 0.99769377713849 + 0.99827666198600 + 1.00000000000000 + 0.99808000955086 + 0.99712918376269 + 0.99628503826580 + 0.99545609291566 + 0.99459919904706 + 0.99369103518666 + 0.99271844698191 + 0.99166509976541 + 0.99051584864540 + 0.98926257393451 + 0.98789302332236 + 0.98638917686472 + 0.98473199223102 + 0.98290213116077 + 0.98087929783986 + 0.97863953887682 + 0.97615514638365 + 0.97339380901322 + 0.97031628380977 + 0.96687693121019 + 0.96302542313252 + 0.95870655801396 + 0.95385475550732 + 0.94840194304071 + 0.94229244150488 + 0.93548007641915 + 0.92792291339751 + 0.91958992721933 + 0.91046180542236 + 0.90053355992657 + 0.88981830854047 + 0.87835231865989 + 0.86620033085346 + 0.85345441759333 + 0.84022035123856 + 0.82662497207396 + 0.81283002007537 + 0.79900589052694 + 0.79212573375446 + 0.78529030094235 + 0.77851050053603 + 0.77179326635090 + 0.76514130008439 + 0.75855298265337 + 0.75202252179744 + 0.74554043108142 + 0.73909429568076 + 0.73266697472626 + 0.72619090801241 + 0.71946790795687 + 0.71239273977510 + 0.70495098233393 + 0.69712697568073 + 0.68892949912365 + 0.68037280333759 + 0.67147526133337 + 0.66225823814534 + 0.65274534441441 + 0.64296041071509 + 0.63289754854928 + 0.62257923641801 + 0.61203186609657 + 0.60128711567314 + 0.59038308517484 + 0.57936467192125 + 0.56826584808253 + 0.55711919533426 + 0.54597088330113 + 0.53486170064520 + 0.52382209872718 + 0.99586114395139 + 0.99586281102380 + 0.99586308853279 + 0.99586341247003 + 0.99586379069639 + 0.99586423243652 + 0.99586474853938 + 0.99586535178251 + 0.99586605738577 + 0.99586688420247 + 0.99586785789226 + 0.99586901390444 + 0.99587039463781 + 0.99587204825640 + 0.99587403173592 + 0.99587641404295 + 0.99587927924252 + 0.99588273013036 + 0.99588689557319 + 0.99589193761486 + 0.99589805357043 + 0.99590548899182 + 0.99591455077693 + 0.99592562452189 + 0.99593919977110 + 0.99595591694121 + 0.99597664928517 + 0.99600254730009 + 0.99603507269762 + 0.99607612501991 + 0.99612831383574 + 0.99619515063947 + 0.99628147454156 + 0.99639415334104 + 0.99654328046117 + 0.99674444959811 + 0.99702363536431 + 0.99742976272519 + 0.99808000955086 + 1.00000000000000 + 0.99785572376167 + 0.99678685023760 + 0.99583670388890 + 0.99490141108390 + 0.99393751801070 + 0.99292305687750 + 0.99183692750411 + 0.99066131426567 + 0.98938657114526 + 0.98799934160658 + 0.98648077056288 + 0.98481121976906 + 0.98297092042459 + 0.98093925650674 + 0.97869202093382 + 0.97620129952695 + 0.97343460435239 + 0.97035253308550 + 0.96690930457441 + 0.96305446920698 + 0.95873272221068 + 0.95387839162842 + 0.94842333531508 + 0.94231183154947 + 0.93549767503204 + 0.92793890433440 + 0.91960447173614 + 0.91047504540639 + 0.90054562057189 + 0.88982930059343 + 0.87836234015546 + 0.86620946863329 + 0.85346274849729 + 0.84022794286535 + 0.82663188559526 + 0.81283631397537 + 0.79901162191889 + 0.79213120438470 + 0.78529552440756 + 0.77851549001173 + 0.77179803450107 + 0.76514585895660 + 0.75855734359907 + 0.75202669538196 + 0.74554442702176 + 0.73909812281802 + 0.73267064092710 + 0.72619441881187 + 0.71947126328070 + 0.71239593703163 + 0.70495401905328 + 0.69712984958262 + 0.68893220871408 + 0.68037534804897 + 0.67147764156287 + 0.66226045529030 + 0.65274740086870 + 0.64296230982232 + 0.63289929408206 + 0.62258083304406 + 0.61203331937091 + 0.60128843201848 + 0.59038427184275 + 0.57936573693306 + 0.56826679996551 + 0.55712004300130 + 0.54597163603840 + 0.53486236786540 + 0.52382268967044 + 0.99540680984623 + 0.99540825473026 + 0.99540849525133 + 0.99540877601214 + 0.99540910382609 + 0.99540948668910 + 0.99540993399961 + 0.99541045683515 + 0.99541106837987 + 0.99541178495890 + 0.99541262873541 + 0.99541363027434 + 0.99541482612426 + 0.99541625782845 + 0.99541797453575 + 0.99542003571786 + 0.99542251383953 + 0.99542549748487 + 0.99542909760395 + 0.99543345361036 + 0.99543873515091 + 0.99544515312716 + 0.99545297079004 + 0.99546251836514 + 0.99547421423824 + 0.99548860435310 + 0.99550643093951 + 0.99552866793195 + 0.99555654547724 + 0.99559165007240 + 0.99563614197672 + 0.99569288996922 + 0.99576577830686 + 0.99586018897364 + 0.99598376962408 + 0.99614777242937 + 0.99636960365881 + 0.99667831637714 + 0.99712918376269 + 0.99785572376167 + 1.00000000000000 + 0.99759955105691 + 0.99639639779967 + 0.99532586542944 + 0.99427490675558 + 0.99319875574190 + 0.99206608733563 + 0.99085395318659 + 0.98954996119900 + 0.98813892665953 + 0.98660069457739 + 0.98491473177509 + 0.98306064006894 + 0.98101734607245 + 0.97876028812857 + 0.97626126861975 + 0.97348756008931 + 0.97039954604107 + 0.96695125618980 + 0.96309207934787 + 0.95876657416862 + 0.95390894811068 + 0.94845096791354 + 0.94233685642259 + 0.93552036835548 + 0.92795950717209 + 0.91962319590645 + 0.91049207747989 + 0.90056112529128 + 0.88984342367831 + 0.87837521051074 + 0.86622120023496 + 0.85347344189492 + 0.84023768619794 + 0.82664075829904 + 0.81284439173736 + 0.79901897846641 + 0.79213822675327 + 0.78530223009967 + 0.77852189597867 + 0.77180415701808 + 0.76515171349926 + 0.75856294471852 + 0.75203205660182 + 0.74554956076418 + 0.73910304035499 + 0.73267535227309 + 0.72619893096791 + 0.71947557601855 + 0.71240004688639 + 0.70495792273545 + 0.69713354406299 + 0.68893569202632 + 0.68037861943068 + 0.67148070153638 + 0.66226330568492 + 0.65275004480398 + 0.64296475164064 + 0.63290153867964 + 0.62258288645447 + 0.61203518876150 + 0.60129012566562 + 0.59038579908375 + 0.57936710808076 + 0.56826802597563 + 0.55712113531121 + 0.54597260654980 + 0.53486322862921 + 0.52382345251140 + 0.99489041190969 + 0.99489166391102 + 0.99489187232115 + 0.99489211559910 + 0.99489239964403 + 0.99489273138859 + 0.99489311897081 + 0.99489357199010 + 0.99489410186759 + 0.99489472272543 + 0.99489545371678 + 0.99489632119912 + 0.99489735668794 + 0.99489859602228 + 0.99490008160035 + 0.99490186471149 + 0.99490400783759 + 0.99490658731554 + 0.99490969871428 + 0.99491346202397 + 0.99491802318582 + 0.99492356348188 + 0.99493030896467 + 0.99493854283742 + 0.99494862334853 + 0.99496101705441 + 0.99497635680986 + 0.99499547052518 + 0.99501939932507 + 0.99504947831441 + 0.99508751354668 + 0.99513588013662 + 0.99519775259994 + 0.99527745385275 + 0.99538098113865 + 0.99551686433050 + 0.99569766198363 + 0.99594281226257 + 0.99628503826580 + 0.99678685023760 + 0.99759955105691 + 1.00000000000000 + 0.99730671398805 + 0.99595168655635 + 0.99475009997727 + 0.99357733781160 + 0.99237590736735 + 0.99111175098872 + 0.98976708827564 + 0.98832349518251 + 0.98675868319199 + 0.98505071649890 + 0.98317824367778 + 0.98111951820383 + 0.97884947042405 + 0.97633950526739 + 0.97355656505971 + 0.97046074179787 + 0.96700580998474 + 0.96314094173023 + 0.95881051356567 + 0.95394857312967 + 0.94848676707572 + 0.94236924559294 + 0.93554971117493 + 0.92798612139943 + 0.91964736104848 + 0.91051403994108 + 0.90058110274919 + 0.88986160867478 + 0.87839177321634 + 0.86623629083228 + 0.85348719250084 + 0.84025021218675 + 0.82665216323512 + 0.81285477394644 + 0.79902843348098 + 0.79214725236780 + 0.78531084893113 + 0.77853012991451 + 0.77181202705415 + 0.76515923957541 + 0.75857014555841 + 0.75203894958754 + 0.74555616182874 + 0.73910936393513 + 0.73268141116142 + 0.72620473406667 + 0.71948112289211 + 0.71240533293621 + 0.70496294360603 + 0.69713829577402 + 0.68894017199651 + 0.68038282667612 + 0.67148463676971 + 0.66226697132116 + 0.65275344493539 + 0.64296789193347 + 0.63290442549845 + 0.62258552762825 + 0.61203759356092 + 0.60129230477914 + 0.59038776454863 + 0.57936887318144 + 0.56826960480240 + 0.55712254255317 + 0.54597385747634 + 0.53486433868389 + 0.52382443683823 + 0.99430243129243 + 0.99430351587523 + 0.99430369641172 + 0.99430390714900 + 0.99430415320026 + 0.99430444056549 + 0.99430477629639 + 0.99430516870123 + 0.99430562767033 + 0.99430616542135 + 0.99430679850391 + 0.99430754965114 + 0.99430844604882 + 0.99430951861471 + 0.99431080392425 + 0.99431234621558 + 0.99431419935418 + 0.99431642913676 + 0.99431911788353 + 0.99432236889054 + 0.99432630774031 + 0.99433109031673 + 0.99433691083885 + 0.99434401239607 + 0.99435270209342 + 0.99436337929184 + 0.99437658474524 + 0.99439302426869 + 0.99441358253827 + 0.99443938920898 + 0.99447196505793 + 0.99451329566979 + 0.99456600990773 + 0.99463364291918 + 0.99472101579839 + 0.99483482456927 + 0.99498460039632 + 0.99518438168512 + 0.99545609291566 + 0.99583670388890 + 0.99639639779967 + 0.99730671398805 + 1.00000000000000 + 0.99697325507719 + 0.99545269574094 + 0.99411223715650 + 0.99280277860203 + 0.99146148671745 + 0.99005866453724 + 0.98856961301911 + 0.98696829485552 + 0.98523045444043 + 0.98333323169098 + 0.98125385221522 + 0.97896649588697 + 0.97644199609375 + 0.97364683065426 + 0.97054068852704 + 0.96707699548119 + 0.96320462997841 + 0.95886772350103 + 0.95400011019169 + 0.94853327724877 + 0.94241127891269 + 0.93558774890903 + 0.92802058443812 + 0.91967861990227 + 0.91054242144865 + 0.90060689574184 + 0.88988506858242 + 0.87841312557865 + 0.86625573431596 + 0.85350490137711 + 0.84026633808578 + 0.82666684170842 + 0.81286813321387 + 0.79904059777630 + 0.79215886358305 + 0.78532193639735 + 0.77854072198598 + 0.77182215090632 + 0.76516892098621 + 0.75857940871398 + 0.75204781689739 + 0.74556465381357 + 0.73911749914534 + 0.73268920600842 + 0.72621219991800 + 0.71948825905396 + 0.71241213333998 + 0.70496940253192 + 0.69714440801603 + 0.68894593421190 + 0.68038823763371 + 0.67148969746123 + 0.66227168497068 + 0.65275781693747 + 0.64297192971448 + 0.63290813737084 + 0.62258892376312 + 0.61204068598332 + 0.60129510731358 + 0.59039029273912 + 0.57937114415886 + 0.56827163670430 + 0.55712435426572 + 0.54597546860247 + 0.53486576902244 + 0.52382570579167 + 0.99363287765041 + 0.99363381688492 + 0.99363397322062 + 0.99363415570534 + 0.99363436876787 + 0.99363461760008 + 0.99363490830524 + 0.99363524807572 + 0.99363564546850 + 0.99363611105204 + 0.99363665912188 + 0.99363730929390 + 0.99363808502363 + 0.99363901298442 + 0.99364012472620 + 0.99364145840431 + 0.99364306045341 + 0.99364498757711 + 0.99364731068457 + 0.99365011870752 + 0.99365351970881 + 0.99365764775366 + 0.99366266975868 + 0.99366879446143 + 0.99367628530240 + 0.99368548445007 + 0.99369685461127 + 0.99371099868240 + 0.99372867045916 + 0.99375082938538 + 0.99377876253492 + 0.99381414140915 + 0.99385916370500 + 0.99391675789317 + 0.99399086885602 + 0.99408688427245 + 0.99421229548929 + 0.99437777369391 + 0.99459919904706 + 0.99490141108390 + 0.99532586542944 + 0.99595168655635 + 0.99697325507719 + 1.00000000000000 + 0.99660286845754 + 0.99490501080884 + 0.99340737704098 + 0.99194452086249 + 0.99045516952249 + 0.98890087718755 + 0.98724840203865 + 0.98546938135451 + 0.98353843434586 + 0.98143114527987 + 0.97912054352949 + 0.97657661511602 + 0.97376516821940 + 0.97064532384718 + 0.96717002408927 + 0.96328774463076 + 0.95894228390243 + 0.95406718852989 + 0.94859373240591 + 0.94246584200246 + 0.93563705973905 + 0.92806520275396 + 0.91971903865073 + 0.91057907559971 + 0.90064016969860 + 0.88991530214979 + 0.87844061846235 + 0.86628075000417 + 0.85352767033081 + 0.84028706010639 + 0.82668569467860 + 0.81288528472047 + 0.79905620969271 + 0.79217376346902 + 0.78533616232957 + 0.77855431074740 + 0.77183513770630 + 0.76518133919429 + 0.75859128959490 + 0.75205918938667 + 0.74557554435543 + 0.73912793161983 + 0.73269920150078 + 0.72622177298905 + 0.71949740870348 + 0.71242085166053 + 0.70497768209347 + 0.69715224210712 + 0.68895331857219 + 0.68039517078279 + 0.67149618082789 + 0.66227772288432 + 0.65276341653411 + 0.64297710072771 + 0.63291289065585 + 0.62259327254451 + 0.61204464582638 + 0.60129869607395 + 0.59039353045524 + 0.57937405286168 + 0.56827423969456 + 0.55712667575537 + 0.54597753368183 + 0.53486760301097 + 0.52382733346550 + 0.99287482684623 + 0.99287564004931 + 0.99287577539886 + 0.99287593338403 + 0.99287611783627 + 0.99287633324958 + 0.99287658490604 + 0.99287687902471 + 0.99287722300888 + 0.99287762600009 + 0.99287810034568 + 0.99287866299220 + 0.99287933418182 + 0.99288013694692 + 0.99288109851085 + 0.99288225179087 + 0.99288363683627 + 0.99288530253332 + 0.99288730998462 + 0.99288973579490 + 0.99289267299852 + 0.99289623695816 + 0.99290057120845 + 0.99290585511461 + 0.99291231485869 + 0.99292024394306 + 0.99293003889387 + 0.99294221570703 + 0.99295741825155 + 0.99297646404807 + 0.99300044696874 + 0.99303078198267 + 0.99306931998521 + 0.99311851097708 + 0.99318162614414 + 0.99326307986300 + 0.99336891021044 + 0.99350752327757 + 0.99369103518666 + 0.99393751801070 + 0.99427490675558 + 0.99475009997727 + 0.99545269574094 + 0.99660286845754 + 1.00000000000000 + 0.99619986748205 + 0.99430045217539 + 0.99262610039668 + 0.99100055921215 + 0.98934930024502 + 0.98762347790409 + 0.98578681504402 + 0.98380944154279 + 0.98166418468605 + 0.97932223648846 + 0.97675228415457 + 0.97391914446960 + 0.97078112167294 + 0.96729047665220 + 0.96339512622781 + 0.95903841260568 + 0.95415349375753 + 0.94867135758827 + 0.94253575946448 + 0.93570011974529 + 0.92812214885063 + 0.91977052539465 + 0.91062568028701 + 0.90068240215432 + 0.88995361256244 + 0.87847540326061 + 0.86631235693241 + 0.85355640267838 + 0.84031317993698 + 0.82670943432389 + 0.81290686197849 + 0.79907583392257 + 0.79219248566844 + 0.78535403145131 + 0.77857137399647 + 0.77185144020318 + 0.76519692363203 + 0.75860619590922 + 0.75207345448992 + 0.74558920193257 + 0.73914101204012 + 0.73271173155221 + 0.72623377116508 + 0.71950887383699 + 0.71243177386852 + 0.70498805213305 + 0.69716205169037 + 0.68896256255002 + 0.68040384755863 + 0.67150429251097 + 0.66228527525490 + 0.65277041889821 + 0.64298356564250 + 0.63291883205204 + 0.62259870729090 + 0.61204959368765 + 0.60130317964716 + 0.59039757502811 + 0.57937768618524 + 0.56827749104880 + 0.55712957551897 + 0.54598011329092 + 0.53486989413559 + 0.52382936707298 + 0.99202453998517 + 0.99202524406685 + 0.99202536124410 + 0.99202549801483 + 0.99202565769355 + 0.99202584416926 + 0.99202606200753 + 0.99202631659281 + 0.99202661432557 + 0.99202696310677 + 0.99202737361983 + 0.99202786051637 + 0.99202844130473 + 0.99202913588631 + 0.99202996778310 + 0.99203096542270 + 0.99203216338698 + 0.99203360386414 + 0.99203533957679 + 0.99203743659329 + 0.99203997511592 + 0.99204305453401 + 0.99204679844415 + 0.99205136118702 + 0.99205693724873 + 0.99206377883256 + 0.99207222650355 + 0.99208272300991 + 0.99209581990921 + 0.99211221613761 + 0.99213284521983 + 0.99215891107198 + 0.99219198252297 + 0.99223412610884 + 0.99228808328327 + 0.99235752186337 + 0.99244740076985 + 0.99256451440326 + 0.99271844698191 + 0.99292305687750 + 0.99319875574190 + 0.99357733781160 + 0.99411223715650 + 0.99490501080884 + 0.99619986748205 + 1.00000000000000 + 0.99574835485468 + 0.99362433372929 + 0.99176316690829 + 0.98996005347963 + 0.98812574672318 + 0.98620685801188 + 0.98416485067249 + 0.98196763285470 + 0.97958332092512 + 0.97697853536388 + 0.97411658114468 + 0.97095456132956 + 0.96744376145119 + 0.96353131373510 + 0.95915993101825 + 0.95426224547872 + 0.94876886192570 + 0.94262330579203 + 0.93577883328230 + 0.92819301212954 + 0.91983440205928 + 0.91068333084003 + 0.90073449703803 + 0.89000074259478 + 0.87851808749382 + 0.86635104946410 + 0.85359149843009 + 0.84034501915795 + 0.82673831737858 + 0.81293306857953 + 0.79909963096374 + 0.79221517238977 + 0.78537566962198 + 0.77859202300752 + 0.77187115668006 + 0.76521576101955 + 0.75862420410705 + 0.75209067952682 + 0.74560568575644 + 0.73915679241695 + 0.73272684176445 + 0.72624823430243 + 0.71952268898046 + 0.71244492949708 + 0.70500053752718 + 0.69717385731067 + 0.68897368270255 + 0.68041428087053 + 0.67151404211475 + 0.66229434871637 + 0.65277882803123 + 0.64299132614518 + 0.63292596124013 + 0.62260522596224 + 0.61205552607887 + 0.60130855334734 + 0.59040242080260 + 0.57938203769989 + 0.56828138375651 + 0.55713304613596 + 0.54598319974954 + 0.53487263460232 + 0.52383179882964 + 0.99107244419652 + 0.99107305367305 + 0.99107315509498 + 0.99107327347251 + 0.99107341167141 + 0.99107357305496 + 0.99107376157224 + 0.99107398187726 + 0.99107423950315 + 0.99107454128263 + 0.99107489645668 + 0.99107531771935 + 0.99107582022351 + 0.99107642119127 + 0.99107714096189 + 0.99107800411385 + 0.99107904053075 + 0.99108028666066 + 0.99108178804210 + 0.99108360173160 + 0.99108579694087 + 0.99108845939989 + 0.99109169566141 + 0.99109563869398 + 0.99110045594864 + 0.99110636446360 + 0.99111365730572 + 0.99112271521379 + 0.99113401177847 + 0.99114814615903 + 0.99116591763057 + 0.99118835455124 + 0.99121679309150 + 0.99125298690198 + 0.99129925130067 + 0.99135866451793 + 0.99143535349658 + 0.99153490880630 + 0.99166509976541 + 0.99183692750411 + 0.99206608733563 + 0.99237590736735 + 0.99280277860203 + 0.99340737704098 + 0.99430045217539 + 0.99574835485468 + 1.00000000000000 + 0.99524148295369 + 0.99287881492195 + 0.99081276542353 + 0.98880839843478 + 0.98676778785692 + 0.98463352081222 + 0.98236393726476 + 0.97992165326684 + 0.97726982454063 + 0.97436935325109 + 0.97117551802651 + 0.96763817243702 + 0.96370332537026 + 0.95931280809833 + 0.95439853356824 + 0.94889058875810 + 0.94273218687843 + 0.93587636116763 + 0.92828048702320 + 0.91991296427832 + 0.91075398227659 + 0.90079811887149 + 0.89005810940844 + 0.87856987795207 + 0.86639785562350 + 0.85363383373993 + 0.84038332480600 + 0.82677298118055 + 0.81296444909847 + 0.79912806745132 + 0.79224225619097 + 0.78540147829796 + 0.77861663088355 + 0.77189463438877 + 0.76523817505127 + 0.75864561638525 + 0.75211114705944 + 0.74562526040755 + 0.73917552082145 + 0.73274476499464 + 0.72626538103979 + 0.71953905900332 + 0.71246050986183 + 0.70501531626047 + 0.69718782387334 + 0.68898683115796 + 0.68042661044800 + 0.67152555739879 + 0.66230505955511 + 0.65278874928088 + 0.64300047722402 + 0.63293436341038 + 0.62261290454939 + 0.61206251040009 + 0.60131487659890 + 0.59040811986042 + 0.57938715278678 + 0.56828595713102 + 0.55713712147708 + 0.54598682210428 + 0.53487584924494 + 0.52383464992607 + 0.99000789161614 + 0.99000841904271 + 0.99000850679921 + 0.99000860922368 + 0.99000872879449 + 0.99000886841577 + 0.99000903150606 + 0.99000922208067 + 0.99000944492232 + 0.99000970593814 + 0.99001001312975 + 0.99001037750025 + 0.99001081219203 + 0.99001133211073 + 0.99001195486953 + 0.99001270173319 + 0.99001359854944 + 0.99001467684138 + 0.99001597598274 + 0.99001754530300 + 0.99001944459918 + 0.99002174790549 + 0.99002454718483 + 0.99002795713086 + 0.99003212209210 + 0.99003722912033 + 0.99004353086373 + 0.99005135540659 + 0.99006111025878 + 0.99007331022260 + 0.99008864152820 + 0.99010798539157 + 0.99013248418322 + 0.99016363303512 + 0.99020339883978 + 0.99025438429841 + 0.99032005721521 + 0.99040507647774 + 0.99051584864540 + 0.99066131426567 + 0.99085395318659 + 0.99111175098872 + 0.99146148671745 + 0.99194452086249 + 0.99262610039668 + 0.99362433372929 + 0.99524148295369 + 1.00000000000000 + 0.99468713451546 + 0.99205986518093 + 0.98976051495234 + 0.98752881051919 + 0.98525780225562 + 0.98288482705445 + 0.98036176988087 + 0.97764557994898 + 0.97469313822313 + 0.97145683842666 + 0.96788436485589 + 0.96392007793924 + 0.95950454981359 + 0.95456869487056 + 0.94904189145608 + 0.94286692338051 + 0.93599651742480 + 0.92838778733319 + 0.92000891625962 + 0.91083990667200 + 0.90087517391174 + 0.89012731020063 + 0.87863211121410 + 0.86645389258602 + 0.85368434134398 + 0.84042887470420 + 0.82681407378203 + 0.81300154358001 + 0.79916159424373 + 0.79227414948222 + 0.78543183514604 + 0.77864554392352 + 0.77192219134149 + 0.76526445822705 + 0.75867070222830 + 0.75213510578699 + 0.74564815578169 + 0.73919741010432 + 0.73276569858467 + 0.72628539442499 + 0.71955815331553 + 0.71247867114811 + 0.70503253172619 + 0.69720408240411 + 0.68900212705640 + 0.68044094406802 + 0.67153893535168 + 0.66231749457346 + 0.65280025989195 + 0.64301108721390 + 0.63294409861320 + 0.62262179544106 + 0.61207059200146 + 0.60132218833535 + 0.59041470531986 + 0.57939305934040 + 0.56829123441303 + 0.55714182068461 + 0.54599099594702 + 0.53487955061323 + 0.52383793036125 + 0.98882560560229 + 0.98882606202937 + 0.98882613796252 + 0.98882622658324 + 0.98882633003261 + 0.98882645082533 + 0.98882659190924 + 0.98882675675813 + 0.98882694950335 + 0.98882717524870 + 0.98882744092920 + 0.98882775610731 + 0.98882813219139 + 0.98882858211566 + 0.98882912114375 + 0.98882976770909 + 0.98883054420249 + 0.98883147793575 + 0.98883260300936 + 0.98883396215939 + 0.98883560714314 + 0.98883760201888 + 0.98884002630905 + 0.98884297914076 + 0.98884658519759 + 0.98885100605021 + 0.98885646008017 + 0.98886323083029 + 0.98887166995475 + 0.98888222111154 + 0.98889547546575 + 0.98891219093319 + 0.98893334822775 + 0.98896022811678 + 0.98899451080140 + 0.98903841167458 + 0.98909486873056 + 0.98916780486691 + 0.98926257393451 + 0.98938657114526 + 0.98954996119900 + 0.98976708827564 + 0.99005866453724 + 0.99045516952249 + 0.99100055921215 + 0.99176316690829 + 0.99287881492195 + 0.99468713451546 + 1.00000000000000 + 0.99407024113421 + 0.99114308287292 + 0.98858125017546 + 0.98609650014221 + 0.98357100068908 + 0.98093315134351 + 0.97812784652558 + 0.97510482173917 + 0.97181169729561 + 0.96819275627850 + 0.96418987628452 + 0.95974179622759 + 0.95477802697941 + 0.94922696849659 + 0.94303080793593 + 0.93614184682082 + 0.92851684075970 + 0.92012367801426 + 0.91094210819141 + 0.90096632777114 + 0.89020873706569 + 0.87870496052787 + 0.86651916069590 + 0.85374288740873 + 0.84048143353610 + 0.82686128600130 + 0.81304399201665 + 0.79919981924850 + 0.79231044988522 + 0.78546633071358 + 0.77867834838753 + 0.77195341190480 + 0.76529419507408 + 0.75869904808479 + 0.75216214558486 + 0.74567396648567 + 0.73922206071688 + 0.73278924981143 + 0.72630788952863 + 0.71957959599838 + 0.71249904780981 + 0.70505183003046 + 0.69722229187184 + 0.68901924326890 + 0.68045696937482 + 0.67155387906079 + 0.66233137278894 + 0.65281309512808 + 0.64302290776402 + 0.63295493493845 + 0.62263168306728 + 0.61207957139018 + 0.60133030471858 + 0.59042200843204 + 0.57939960299624 + 0.56829707482767 + 0.55714701571447 + 0.54599560504644 + 0.53488363335606 + 0.52384154472917 + 0.98751577349849 + 0.98751616858452 + 0.98751623430209 + 0.98751631099641 + 0.98751640051987 + 0.98751650504451 + 0.98751662711865 + 0.98751676974409 + 0.98751693648977 + 0.98751713176877 + 0.98751736160219 + 0.98751763430971 + 0.98751795982253 + 0.98751834937838 + 0.98751881623620 + 0.98751937639625 + 0.98752004930333 + 0.98752085864966 + 0.98752183404812 + 0.98752301259633 + 0.98752443919838 + 0.98752616940322 + 0.98752827213649 + 0.98753083326164 + 0.98753396073840 + 0.98753779447665 + 0.98754252382399 + 0.98754839460082 + 0.98755571123702 + 0.98756485730247 + 0.98757634388291 + 0.98759082528940 + 0.98760914687327 + 0.98763241068387 + 0.98766205931440 + 0.98769998954843 + 0.98774870783076 + 0.98781154529242 + 0.98789302332236 + 0.98799934160658 + 0.98813892665953 + 0.98832349518251 + 0.98856961301911 + 0.98890087718755 + 0.98934930024502 + 0.98996005347963 + 0.99081276542353 + 0.99205986518093 + 0.99407024113421 + 1.00000000000000 + 0.99336876538950 + 0.99010544165159 + 0.98725210568300 + 0.98448857147841 + 0.98168168245253 + 0.97875004317908 + 0.97562961368168 + 0.97225962494370 + 0.96857877783643 + 0.96452507646103 + 0.96003451599316 + 0.95503459191985 + 0.94945232973647 + 0.94322907438718 + 0.93631652961315 + 0.92867095608213 + 0.92025983793252 + 0.91106258103562 + 0.90107308629584 + 0.89030349641607 + 0.87878920750097 + 0.86659417943559 + 0.85380978201233 + 0.84054114643523 + 0.82691463557988 + 0.81309171641210 + 0.79924259492097 + 0.79235098328662 + 0.78550476901393 + 0.77871483056167 + 0.77198806827467 + 0.76532714687599 + 0.75873040709064 + 0.75219201384549 + 0.74570243623930 + 0.73924921451959 + 0.73281516023815 + 0.72633260900608 + 0.71960313222581 + 0.71252138895046 + 0.70507296556138 + 0.69724221319218 + 0.68903794836683 + 0.68047446354646 + 0.67157017511465 + 0.66234649083803 + 0.65282706215346 + 0.64303575691402 + 0.63296670153849 + 0.62264240779587 + 0.61208930012410 + 0.60133908833482 + 0.59042990251506 + 0.57940666738532 + 0.56830337182434 + 0.55715260927749 + 0.54600056076971 + 0.53488801686111 + 0.52384541979501 + 0.98606245652070 + 0.98606279867622 + 0.98606285558107 + 0.98606292198697 + 0.98606299949580 + 0.98606308998518 + 0.98606319566154 + 0.98606331911606 + 0.98606346343365 + 0.98606363243539 + 0.98606383135093 + 0.98606406743676 + 0.98606434935081 + 0.98606468688165 + 0.98606509156232 + 0.98606557731003 + 0.98606616103609 + 0.98606686334340 + 0.98606770998626 + 0.98606873325298 + 0.98606997218116 + 0.98607147504264 + 0.98607330171279 + 0.98607552673938 + 0.98607824380608 + 0.98608157437228 + 0.98608568306884 + 0.98609078364906 + 0.98609714043748 + 0.98610508603323 + 0.98611506371142 + 0.98612764023420 + 0.98614354685590 + 0.98616373549817 + 0.98618945000857 + 0.98622232218412 + 0.98626450220596 + 0.98631883737478 + 0.98638917686472 + 0.98648077056288 + 0.98660069457739 + 0.98675868319199 + 0.98696829485552 + 0.98724840203865 + 0.98762347790409 + 0.98812574672318 + 0.98880839843478 + 0.98976051495234 + 0.99114308287292 + 0.99336876538950 + 1.00000000000000 + 0.99256928632622 + 0.98893129228138 + 0.98575625300207 + 0.98268479087999 + 0.97956664464797 + 0.97630787664194 + 0.97283168030718 + 0.96906700156771 + 0.96494550133190 + 0.96039890463767 + 0.95535171623482 + 0.94972897611748 + 0.94347081253736 + 0.93652807320763 + 0.92885632445268 + 0.92042249005500 + 0.91120550440165 + 0.90119886643970 + 0.89041437115722 + 0.87888710874067 + 0.86668076961969 + 0.85388648629618 + 0.84060917883407 + 0.82697504641118 + 0.81314544537136 + 0.79929049387619 + 0.79239625695705 + 0.78554759944853 + 0.77875538871226 + 0.77202651364135 + 0.76536362714550 + 0.75876505787647 + 0.75222495854038 + 0.74573378607893 + 0.73927906884600 + 0.73284360630113 + 0.72635971068451 + 0.71962890274200 + 0.71254581944278 + 0.70509604846670 + 0.69726394288860 + 0.68905832632261 + 0.68049349907227 + 0.67158788554937 + 0.66236290129824 + 0.65284220505116 + 0.64304967115394 + 0.63297942815215 + 0.62265399340697 + 0.61209979675694 + 0.60134855318810 + 0.59043839763921 + 0.57941425922250 + 0.56831012927604 + 0.55715860288917 + 0.54600586271599 + 0.53489269922204 + 0.52384955252106 + 0.98444820306597 + 0.98444849964773 + 0.98444854896285 + 0.98444860651142 + 0.98444867367600 + 0.98444875208379 + 0.98444884364137 + 0.98444895059262 + 0.98444907560550 + 0.98444922199047 + 0.98444939429473 + 0.98444959886567 + 0.98444984326468 + 0.98445013603018 + 0.98445048721617 + 0.98445090895078 + 0.98445141597318 + 0.98445202623353 + 0.98445276218688 + 0.98445365198491 + 0.98445472965084 + 0.98445603722817 + 0.98445762684524 + 0.98445956337811 + 0.98446192830727 + 0.98446482734037 + 0.98446840400743 + 0.98447284471982 + 0.98447837962679 + 0.98448529794685 + 0.98449398530582 + 0.98450493417047 + 0.98451877912684 + 0.98453634526095 + 0.98455870902556 + 0.98458727999362 + 0.98462391121595 + 0.98467104939556 + 0.98473199223102 + 0.98481121976906 + 0.98491473177509 + 0.98505071649890 + 0.98523045444043 + 0.98546938135451 + 0.98578681504402 + 0.98620685801188 + 0.98676778785692 + 0.98752881051919 + 0.98858125017546 + 0.99010544165159 + 0.99256928632622 + 1.00000000000000 + 0.99165991285463 + 0.98760620531155 + 0.98407555057810 + 0.98066438122289 + 0.97720078923183 + 0.97357343489020 + 0.96969271249554 + 0.96547921411151 + 0.96085767667499 + 0.95574797730390 + 0.95007218536766 + 0.94376862051325 + 0.93678687625183 + 0.92908152644556 + 0.92061870635654 + 0.91137669615719 + 0.90134844322800 + 0.89054526982748 + 0.87900185375437 + 0.86678152513947 + 0.85397510195295 + 0.84068722696091 + 0.82704388251989 + 0.81320627326890 + 0.79934439404541 + 0.79244705775712 + 0.78559552794428 + 0.77880065702298 + 0.77206931867711 + 0.76540415040718 + 0.75880346535423 + 0.75226140074879 + 0.74576839830006 + 0.73931197162258 + 0.73287490536379 + 0.72638948442254 + 0.71965717186791 + 0.71257257954674 + 0.70512129634646 + 0.69728767724192 + 0.68908055343752 + 0.68051423361545 + 0.67160715071870 + 0.66238072853575 + 0.65285863347727 + 0.64306474668511 + 0.63299319868223 + 0.62266651262215 + 0.61211112389092 + 0.60135875277636 + 0.59044753915683 + 0.57942241662093 + 0.56831737892217 + 0.55716502271846 + 0.54601153226496 + 0.53489769775736 + 0.52385395683340 + 0.98265489127193 + 0.98265514871133 + 0.98265519151131 + 0.98265524145125 + 0.98265529973470 + 0.98265536776965 + 0.98265544720655 + 0.98265553998964 + 0.98265564843011 + 0.98265577539988 + 0.98265592486655 + 0.98265610238336 + 0.98265631457690 + 0.98265656891083 + 0.98265687416573 + 0.98265724094040 + 0.98265768210618 + 0.98265821334181 + 0.98265885426460 + 0.98265962949885 + 0.98266056875559 + 0.98266170875617 + 0.98266309499844 + 0.98266478408237 + 0.98266684706661 + 0.98266937619569 + 0.98267249696909 + 0.98267637244727 + 0.98268120361523 + 0.98268724271941 + 0.98269482629102 + 0.98270438357223 + 0.98271646706274 + 0.98273179431149 + 0.98275130021005 + 0.98277620698683 + 0.98280811824417 + 0.98284914619113 + 0.98290213116077 + 0.98297092042459 + 0.98306064006894 + 0.98317824367778 + 0.98333323169098 + 0.98353843434586 + 0.98380944154279 + 0.98416485067249 + 0.98463352081222 + 0.98525780225562 + 0.98609650014221 + 0.98725210568300 + 0.98893129228138 + 0.99165991285463 + 1.00000000000000 + 0.99062830069236 + 0.98611310897377 + 0.98219102886245 + 0.97840451422282 + 0.97455287191782 + 0.97050674582785 + 0.96616569757096 + 0.96144226156810 + 0.95624876839223 + 0.95050264702735 + 0.94413943406686 + 0.93710683390441 + 0.92935796950036 + 0.92085784646586 + 0.91158382438395 + 0.90152808542888 + 0.89070130356929 + 0.87913759671284 + 0.86689981015495 + 0.85407834245204 + 0.84077747001893 + 0.82712288697543 + 0.81327559054171 + 0.79940540403169 + 0.79250437614705 + 0.78564944026728 + 0.77885142867969 + 0.77211719486745 + 0.76544935614724 + 0.75884620559984 + 0.75230186069885 + 0.74580674390658 + 0.73934835037819 + 0.73290944643045 + 0.72642228469138 + 0.71968826213021 + 0.71260196181576 + 0.70514897364269 + 0.69731365434536 + 0.68910484321343 + 0.68053685781638 + 0.67162814012520 + 0.66240012257988 + 0.65287647961915 + 0.64308109941154 + 0.63300811420564 + 0.62268005306386 + 0.61212335700699 + 0.60136975166481 + 0.59045738189295 + 0.57943118576183 + 0.56832515933198 + 0.55717190070155 + 0.54601759563772 + 0.53490303384003 + 0.52385865006008 + 0.98066317919246 + 0.98066340310538 + 0.98066344032557 + 0.98066348375067 + 0.98066353442866 + 0.98066359358045 + 0.98066366264034 + 0.98066374329420 + 0.98066383754805 + 0.98066394790001 + 0.98066407781701 + 0.98066423217529 + 0.98066441679268 + 0.98066463821257 + 0.98066490412940 + 0.98066522382507 + 0.98066560856991 + 0.98066607209671 + 0.98066663160337 + 0.98066730867953 + 0.98066812935643 + 0.98066912579900 + 0.98067033784143 + 0.98067181500949 + 0.98067361947271 + 0.98067583196878 + 0.98067856260646 + 0.98068195449976 + 0.98068618376416 + 0.98069147113719 + 0.98069811132403 + 0.98070647977968 + 0.98071705924049 + 0.98073047599685 + 0.98074754504748 + 0.98076933032220 + 0.98079722530807 + 0.98083306162357 + 0.98087929783986 + 0.98093925650674 + 0.98101734607245 + 0.98111951820383 + 0.98125385221522 + 0.98143114527987 + 0.98166418468605 + 0.98196763285470 + 0.98236393726476 + 0.98288482705445 + 0.98357100068908 + 0.98448857147841 + 0.98575625300207 + 0.98760620531155 + 0.99062830069236 + 1.00000000000000 + 0.98945838147820 + 0.98443487123787 + 0.98008272458488 + 0.97587659302025 + 0.97158475655837 + 0.96706172780023 + 0.96219680944242 + 0.95688916950347 + 0.95104858883630 + 0.94460613709155 + 0.93750657620436 + 0.92970084929587 + 0.92115230805344 + 0.91183699421555 + 0.90174601404944 + 0.89088914309306 + 0.87929973264362 + 0.86703997091773 + 0.85419969356695 + 0.84088269006523 + 0.82721426975372 + 0.81335514673017 + 0.79947490726606 + 0.79256944275220 + 0.78571043204471 + 0.77890868034135 + 0.77217101425212 + 0.76550002454435 + 0.75889397821678 + 0.75234696732484 + 0.74584938981458 + 0.73938871749998 + 0.73294769379275 + 0.72645853286511 + 0.71972255543436 + 0.71263431132475 + 0.70517939108349 + 0.69734215291722 + 0.68913144465415 + 0.68056159322812 + 0.67165105005613 + 0.66242125659475 + 0.65289589555937 + 0.64309886227964 + 0.63302429031560 + 0.62269471466055 + 0.61213658195415 + 0.60138162311026 + 0.59046798789443 + 0.57944061878967 + 0.56833351395637 + 0.55717927272993 + 0.54602408223769 + 0.53490873138728 + 0.52386365154214 + 0.97844990675642 + 0.97845010202198 + 0.97845013447326 + 0.97845017233239 + 0.97845021651320 + 0.97845026807651 + 0.97845032827081 + 0.97845039856421 + 0.97845048070428 + 0.97845057686604 + 0.97845069008751 + 0.97845082466466 + 0.97845098572488 + 0.97845117901954 + 0.97845141131154 + 0.97845169075416 + 0.97845202725439 + 0.97845243287821 + 0.97845292274691 + 0.97845351586145 + 0.97845423510850 + 0.97845510875746 + 0.97845617180720 + 0.97845746775670 + 0.97845905117798 + 0.97846099301638 + 0.97846339023087 + 0.97846636891829 + 0.97847008399341 + 0.97847472936996 + 0.97848056414595 + 0.97848791802664 + 0.97849721448836 + 0.97850900239139 + 0.97852399515480 + 0.97854312285399 + 0.97856760174714 + 0.97859902750568 + 0.97863953887682 + 0.97869202093382 + 0.97876028812857 + 0.97884947042405 + 0.97896649588697 + 0.97912054352949 + 0.97932223648846 + 0.97958332092512 + 0.97992165326684 + 0.98036176988087 + 0.98093315134351 + 0.98168168245253 + 0.98268479087999 + 0.98407555057810 + 0.98611310897377 + 0.98945838147820 + 1.00000000000000 + 0.98813756029728 + 0.98255699988704 + 0.97772723440160 + 0.97304635942562 + 0.96825272386982 + 0.96318565396885 + 0.95771920555779 + 0.95174965529478 + 0.94520051430527 + 0.93801176656575 + 0.93013096751316 + 0.92151898054273 + 0.91214991957580 + 0.90201335197341 + 0.89111779126212 + 0.87949552768235 + 0.86720785084795 + 0.85434383489748 + 0.84100661736103 + 0.82732099122163 + 0.81344728396228 + 0.79955475539408 + 0.79264390488723 + 0.78577997027736 + 0.77897372030027 + 0.77223194572515 + 0.76555720224550 + 0.75894772275306 + 0.75239756635659 + 0.74589709948920 + 0.73943376418954 + 0.73299027495105 + 0.72649879963627 + 0.71976057022330 + 0.71267009776983 + 0.70521297288163 + 0.69737355475658 + 0.68916070015158 + 0.68058874577756 + 0.67167615285632 + 0.66244437210275 + 0.65291709465761 + 0.64311822301251 + 0.63304189141680 + 0.62271064069143 + 0.61215092293208 + 0.60139447417082 + 0.59047944889141 + 0.57945079381192 + 0.56834250888283 + 0.55718719436921 + 0.54603103852943 + 0.53491482909195 + 0.52386899342887 + 0.97598803432567 + 0.97598820515645 + 0.97598823354227 + 0.97598826665880 + 0.97598830529844 + 0.97598835039393 + 0.97598840303412 + 0.97598846449795 + 0.97598853631422 + 0.97598862038450 + 0.97598871937909 + 0.97598883710015 + 0.97598897807501 + 0.97598914738286 + 0.97598935098807 + 0.97598959608305 + 0.97598989140376 + 0.97599024759430 + 0.97599067800391 + 0.97599119941741 + 0.97599183203975 + 0.97599260081915 + 0.97599353662815 + 0.97599467782962 + 0.97599607253728 + 0.97599778334245 + 0.97599989600123 + 0.97600252209635 + 0.97600579849448 + 0.97600989630665 + 0.97601504433401 + 0.97602153342949 + 0.97602973676808 + 0.97604013757112 + 0.97605336326346 + 0.97607023077023 + 0.97609180683010 + 0.97611948858221 + 0.97615514638365 + 0.97620129952695 + 0.97626126861975 + 0.97633950526739 + 0.97644199609375 + 0.97657661511602 + 0.97675228415457 + 0.97697853536388 + 0.97726982454063 + 0.97764557994898 + 0.97812784652558 + 0.97875004317908 + 0.97956664464797 + 0.98066438122289 + 0.98219102886245 + 0.98443487123787 + 0.98813756029728 + 1.00000000000000 + 0.98665521472668 + 0.98046107168111 + 0.97509419793128 + 0.96987205001081 + 0.96450429177855 + 0.95881069729693 + 0.95266144685399 + 0.94596638139861 + 0.93865731848231 + 0.93067632761478 + 0.92198040318280 + 0.91254076382268 + 0.90234472948165 + 0.89139901184836 + 0.87973441359570 + 0.86741098263761 + 0.85451675388937 + 0.84115398534873 + 0.82744677319471 + 0.81355491626135 + 0.79964722555503 + 0.79272977576704 + 0.78585983616723 + 0.77904812638057 + 0.77230138926086 + 0.76562213399889 + 0.75900854863367 + 0.75245464930711 + 0.74595076166256 + 0.73948428942732 + 0.73303791025729 + 0.72654373569489 + 0.71980289361424 + 0.71270984941994 + 0.70525019285648 + 0.69740828331940 + 0.68919298677287 + 0.68061864998038 + 0.67170374416853 + 0.66246972940427 + 0.65294030520500 + 0.64313938102043 + 0.63306109087231 + 0.62272798110654 + 0.61216650894124 + 0.60140841515921 + 0.59049185861586 + 0.57946178993942 + 0.56835221040453 + 0.55719572077146 + 0.54603851010012 + 0.53492136443701 + 0.52387470643611 + 0.97324583494554 + 0.97324598498327 + 0.97324600990947 + 0.97324603898730 + 0.97324607291526 + 0.97324611250656 + 0.97324615871821 + 0.97324621267386 + 0.97324627570846 + 0.97324634949504 + 0.97324643639413 + 0.97324653977482 + 0.97324666365836 + 0.97324681254760 + 0.97324699171843 + 0.97324720754781 + 0.97324746777345 + 0.97324778182470 + 0.97324816153716 + 0.97324862180477 + 0.97324918054132 + 0.97324985986187 + 0.97325068713437 + 0.97325169633993 + 0.97325293009810 + 0.97325444389550 + 0.97325631393480 + 0.97325863943277 + 0.97326154189361 + 0.97326517304907 + 0.97326973595648 + 0.97327548845817 + 0.97328276107403 + 0.97329198139562 + 0.97330370405221 + 0.97331865033316 + 0.97333776080507 + 0.97336226542321 + 0.97339380901322 + 0.97343460435239 + 0.97348756008931 + 0.97355656505971 + 0.97364683065426 + 0.97376516821940 + 0.97391914446960 + 0.97411658114468 + 0.97436935325109 + 0.97469313822313 + 0.97510482173917 + 0.97562961368168 + 0.97630787664194 + 0.97720078923183 + 0.97840451422282 + 0.98008272458488 + 0.98255699988704 + 0.98665521472668 + 1.00000000000000 + 0.98499675113405 + 0.97812142650874 + 0.97214414971803 + 0.96630092737303 + 0.96026962017335 + 0.95386326443460 + 0.94696473377610 + 0.93949096166496 + 0.93137467564719 + 0.92256660957594 + 0.91303349365153 + 0.90275928243142 + 0.89174806418021 + 0.88002852417021 + 0.86765897389873 + 0.85472601626813 + 0.84133071316492 + 0.82759621501137 + 0.81368159624421 + 0.79975505127766 + 0.79282945169098 + 0.78595213092953 + 0.77913374241741 + 0.77238096483370 + 0.76569624553451 + 0.75907771333796 + 0.75251932806748 + 0.74601136222934 + 0.73954116994851 + 0.73309138160762 + 0.72659403966084 + 0.71985014900424 + 0.71275412082991 + 0.70529154258321 + 0.69744677264072 + 0.68922868619239 + 0.68065164009237 + 0.67173411552286 + 0.66249758169501 + 0.65296574615535 + 0.64316252478906 + 0.63308205009557 + 0.62274687334077 + 0.61218345625045 + 0.60142354374309 + 0.59050529845860 + 0.57947367439805 + 0.56836267350239 + 0.55720489642954 + 0.54604653256224 + 0.53492836564119 + 0.52388081271216 + 0.97018459901261 + 0.97018473137032 + 0.97018475335500 + 0.97018477900150 + 0.97018480892470 + 0.97018484383865 + 0.97018488459037 + 0.97018493216400 + 0.97018498773741 + 0.97018505278879 + 0.97018512940818 + 0.97018522060166 + 0.97018532995456 + 0.97018546147000 + 0.97018561984923 + 0.97018581076051 + 0.97018604109159 + 0.97018631923289 + 0.97018665572926 + 0.97018706385748 + 0.97018755957940 + 0.97018816259171 + 0.97018889726461 + 0.97018979385069 + 0.97019089028919 + 0.97019223600907 + 0.97019389905711 + 0.97019596809298 + 0.97019855153000 + 0.97020178459097 + 0.97020584841003 + 0.97021097275369 + 0.97021745187047 + 0.97022566612100 + 0.97023610837535 + 0.97024941888778 + 0.97026643147801 + 0.97028823489698 + 0.97031628380977 + 0.97035253308550 + 0.97039954604107 + 0.97046074179787 + 0.97054068852704 + 0.97064532384718 + 0.97078112167294 + 0.97095456132956 + 0.97117551802651 + 0.97145683842666 + 0.97181169729561 + 0.97225962494370 + 0.97283168030718 + 0.97357343489020 + 0.97455287191782 + 0.97587659302025 + 0.97772723440160 + 0.98046107168111 + 0.98499675113405 + 1.00000000000000 + 0.98314534809988 + 0.97550493733391 + 0.96882608203484 + 0.96226167195957 + 0.95547320561340 + 0.94828348146262 + 0.94057991134243 + 0.93227826861116 + 0.92331864248347 + 0.91366052651830 + 0.90328267652214 + 0.89218526676451 + 0.88039391078034 + 0.86796445537495 + 0.85498150657278 + 0.84154448384538 + 0.82777524476980 + 0.81383186764195 + 0.79988169898886 + 0.79294595757129 + 0.78605949437534 + 0.77923287346559 + 0.77247268740572 + 0.76578130106155 + 0.75915676477636 + 0.75259296418255 + 0.74608010220662 + 0.73960546835909 + 0.73315163193578 + 0.72665054992368 + 0.71990308091311 + 0.71280357113481 + 0.70533760357819 + 0.69748953373845 + 0.68926824568828 + 0.68068810604075 + 0.67176760547341 + 0.66252822173963 + 0.65299366963400 + 0.64318787050801 + 0.63310495351752 + 0.62276747386147 + 0.61220189677977 + 0.60143997037540 + 0.59051986017415 + 0.57948652274278 + 0.56837395978597 + 0.55721477103922 + 0.54605514557454 + 0.53493586401786 + 0.52388733676322 + 0.96675916465250 + 0.96675928197951 + 0.96675930146493 + 0.96675932419485 + 0.96675935071096 + 0.96675938165006 + 0.96675941775777 + 0.96675945990896 + 0.96675950914479 + 0.96675956677095 + 0.96675963465502 + 0.96675971548765 + 0.96675981247689 + 0.96675992920635 + 0.96676006987533 + 0.96676023955260 + 0.96676044439586 + 0.96676069190977 + 0.96676099152523 + 0.96676135514224 + 0.96676179704161 + 0.96676233485887 + 0.96676299039447 + 0.96676379071546 + 0.96676476975441 + 0.96676597175782 + 0.96676745779358 + 0.96676930745909 + 0.96677161796285 + 0.96677451041985 + 0.96677814719942 + 0.96678273407416 + 0.96678853431969 + 0.96679588798513 + 0.96680523529419 + 0.96681714748314 + 0.96683236756246 + 0.96685186435504 + 0.96687693121019 + 0.96690930457441 + 0.96695125618980 + 0.96700580998474 + 0.96707699548119 + 0.96717002408927 + 0.96729047665220 + 0.96744376145119 + 0.96763817243702 + 0.96788436485589 + 0.96819275627850 + 0.96857877783643 + 0.96906700156771 + 0.96969271249554 + 0.97050674582785 + 0.97158475655837 + 0.97304635942562 + 0.97509419793128 + 0.97812142650874 + 0.98314534809988 + 1.00000000000000 + 0.98107918920583 + 0.97256480943506 + 0.96506693853716 + 0.95767616871657 + 0.95005376351415 + 0.94202120779005 + 0.93346081820968 + 0.92429341112576 + 0.91446622678868 + 0.90394967306746 + 0.89273790373817 + 0.88085196847582 + 0.86834414958720 + 0.85529622683622 + 0.84180533746198 + 0.82799155592146 + 0.81401158346151 + 0.80003159770901 + 0.79308314154476 + 0.78618526959303 + 0.77934842507594 + 0.77257908469508 + 0.76587950296411 + 0.75924762580566 + 0.75267724070231 + 0.74615845900033 + 0.73967848555912 + 0.73321981026163 + 0.72671428348559 + 0.71996258846096 + 0.71285899285424 + 0.70538907199699 + 0.69753717576765 + 0.68931219620028 + 0.68072850877756 + 0.67180461267502 + 0.66256199297974 + 0.65302437035266 + 0.64321567004629 + 0.63313001535217 + 0.62278996389158 + 0.61222198293576 + 0.60145782236579 + 0.59053564929942 + 0.57950042172489 + 0.56838613987835 + 0.55722540149815 + 0.54606439448788 + 0.53494389535395 + 0.52389430657124 + 0.96291961791137 + 0.96291972243674 + 0.96291973979280 + 0.96291976003884 + 0.96291978365571 + 0.96291981121043 + 0.96291984336665 + 0.96291988089884 + 0.96291992473689 + 0.96291997604412 + 0.96292003649124 + 0.96292010849730 + 0.96292019494778 + 0.96292029906536 + 0.96292042461867 + 0.96292057615909 + 0.96292075921978 + 0.96292098053827 + 0.96292124859824 + 0.96292157410437 + 0.96292196990059 + 0.96292245183776 + 0.96292303951967 + 0.96292375726676 + 0.96292463557005 + 0.96292571421866 + 0.96292704825527 + 0.96292870947281 + 0.96293078543260 + 0.96293338509737 + 0.96293665468960 + 0.96294077932498 + 0.96294599565661 + 0.96295260909140 + 0.96296101464060 + 0.96297172432423 + 0.96298540332570 + 0.96300291780150 + 0.96302542313252 + 0.96305446920698 + 0.96309207934787 + 0.96314094173023 + 0.96320462997841 + 0.96328774463076 + 0.96339512622781 + 0.96353131373510 + 0.96370332537026 + 0.96392007793924 + 0.96418987628452 + 0.96452507646103 + 0.96494550133190 + 0.96547921411151 + 0.96616569757096 + 0.96706172780023 + 0.96825272386982 + 0.96987205001081 + 0.97214414971803 + 0.97550493733391 + 0.98107918920583 + 1.00000000000000 + 0.97876244579909 + 0.96922721826589 + 0.96078550275629 + 0.95248170090261 + 0.94396026012112 + 0.93502925862518 + 0.92557160216906 + 0.91551244473561 + 0.90480811949023 + 0.89344315691788 + 0.88143161823439 + 0.86882050687765 + 0.85568752641973 + 0.84212659482020 + 0.82825529903124 + 0.81422842251904 + 0.80021052434321 + 0.79324600795299 + 0.78633379109439 + 0.77948415312849 + 0.77270341442319 + 0.76599368131915 + 0.75935276027813 + 0.75277430833577 + 0.74624831570041 + 0.73976187575245 + 0.73329737450999 + 0.72678652825280 + 0.72002980830740 + 0.71292138637271 + 0.70544682547431 + 0.69759046587717 + 0.68936120585577 + 0.68077342810707 + 0.67184563850184 + 0.66259932746385 + 0.65305821933211 + 0.64324624086733 + 0.63315750608439 + 0.62281457279969 + 0.61224390819756 + 0.60147726195492 + 0.59055280097945 + 0.57951548308217 + 0.56839930540927 + 0.55723686229319 + 0.54607433933910 + 0.53495250767371 + 0.52390176032647 + 0.95861111418580 + 0.95861120776469 + 0.95861122330129 + 0.95861124142365 + 0.95861126256099 + 0.95861128722206 + 0.95861131599784 + 0.95861134958500 + 0.95861138880743 + 0.95861143471210 + 0.95861148880007 + 0.95861155325471 + 0.95861163068602 + 0.95861172399745 + 0.95861183658738 + 0.95861197256492 + 0.95861213691950 + 0.95861233572685 + 0.95861257665089 + 0.95861286936146 + 0.95861322545485 + 0.95861365924041 + 0.95861418841496 + 0.95861483492511 + 0.95861562627448 + 0.95861659839579 + 0.95861780109550 + 0.95861929937719 + 0.95862117242160 + 0.95862351865742 + 0.95862647026958 + 0.95863019445697 + 0.95863490476012 + 0.95864087655161 + 0.95864846566040 + 0.95865813281893 + 0.95867047586196 + 0.95868627218896 + 0.95870655801396 + 0.95873272221068 + 0.95876657416862 + 0.95881051356567 + 0.95886772350103 + 0.95894228390243 + 0.95903841260568 + 0.95915993101825 + 0.95931280809833 + 0.95950454981359 + 0.95974179622759 + 0.96003451599316 + 0.96039890463767 + 0.96085767667499 + 0.96144226156810 + 0.96219680944242 + 0.96318565396885 + 0.96450429177855 + 0.96630092737303 + 0.96882608203484 + 0.97256480943506 + 0.97876244579909 + 1.00000000000000 + 0.97613065298766 + 0.96541187815909 + 0.95592107726078 + 0.94662928130008 + 0.93714681405943 + 0.92727274939156 + 0.91688896180354 + 0.90592650100172 + 0.89435373428336 + 0.88217359605264 + 0.86942502655042 + 0.85617970307609 + 0.84252691108563 + 0.82858071355497 + 0.81449319444368 + 0.80042665563147 + 0.79344166512651 + 0.78651124114631 + 0.77964543992336 + 0.77285036994975 + 0.76612793772912 + 0.75947576250726 + 0.75288732703075 + 0.74635246035270 + 0.73985810812964 + 0.73338651962499 + 0.72686924071091 + 0.72010648372670 + 0.71299230164985 + 0.70551223858594 + 0.69765061954504 + 0.68941634629974 + 0.68082380615796 + 0.67189150893701 + 0.66264094740276 + 0.65309584636177 + 0.64328013066987 + 0.63318790044283 + 0.62284171058357 + 0.61226802525621 + 0.60149859120952 + 0.59057157270233 + 0.57953192522060 + 0.56841364068316 + 0.55724930817215 + 0.54608510951748 + 0.53496180886530 + 0.52390978790633 + 0.95376839527323 + 0.95376847941682 + 0.95376849338466 + 0.95376850967564 + 0.95376852867612 + 0.95376855084471 + 0.95376857670777 + 0.95376860689269 + 0.95376864213944 + 0.95376868338799 + 0.95376873199392 + 0.95376878993477 + 0.95376885957789 + 0.95376894355054 + 0.95376904493169 + 0.95376916743641 + 0.95376931558205 + 0.95376949487046 + 0.95376971224157 + 0.95376997646159 + 0.95377029803468 + 0.95377068992228 + 0.95377116814802 + 0.95377175257991 + 0.95377246810931 + 0.95377334727770 + 0.95377443528896 + 0.95377579117410 + 0.95377748674170 + 0.95377961116404 + 0.95378228427830 + 0.95378565752473 + 0.95378992414464 + 0.95379533312013 + 0.95380220587404 + 0.95381095813822 + 0.95382212869352 + 0.95383641719513 + 0.95385475550732 + 0.95387839162842 + 0.95390894811068 + 0.95394857312967 + 0.95400011019169 + 0.95406718852989 + 0.95415349375753 + 0.95426224547872 + 0.95439853356824 + 0.95456869487056 + 0.95477802697941 + 0.95503459191985 + 0.95535171623482 + 0.95574797730390 + 0.95624876839223 + 0.95688916950347 + 0.95771920555779 + 0.95881069729693 + 0.96026962017335 + 0.96226167195957 + 0.96506693853716 + 0.96922721826589 + 0.97613065298766 + 1.00000000000000 + 0.97312824538837 + 0.96107436683481 + 0.95043731991299 + 0.94008248802145 + 0.92958611077539 + 0.91873444667945 + 0.90740901081003 + 0.89554915924785 + 0.88313916240173 + 0.87020512105336 + 0.85680949695553 + 0.84303472193201 + 0.82898975602123 + 0.81482282239475 + 0.80069303901442 + 0.79368158102847 + 0.78672771349500 + 0.77984118666687 + 0.77302781990339 + 0.76628924826164 + 0.75962283783416 + 0.75302183669945 + 0.74647585777916 + 0.73997164934009 + 0.73349127890687 + 0.72696607254281 + 0.72019591985999 + 0.71307472425217 + 0.70558800185357 + 0.69772005476686 + 0.68947978459204 + 0.68088157977721 + 0.67194395042090 + 0.66268838763104 + 0.65313861234609 + 0.64331854287771 + 0.63322225917123 + 0.62287230898630 + 0.61229514948248 + 0.60152252084026 + 0.59059258138909 + 0.57955028143402 + 0.56842960482145 + 0.55726313290668 + 0.54609704179149 + 0.53497208649544 + 0.52391863486514 + 0.94832363924203 + 0.94832371516797 + 0.94832372776929 + 0.94832374246596 + 0.94832375960685 + 0.94832377960326 + 0.94832380292979 + 0.94832383015248 + 0.94832386193841 + 0.94832389913310 + 0.94832394296509 + 0.94832399523143 + 0.94832405808107 + 0.94832413390149 + 0.94832422548481 + 0.94832433620330 + 0.94832447015412 + 0.94832463233401 + 0.94832482904127 + 0.94832506824267 + 0.94832535947319 + 0.94832571450186 + 0.94832614787184 + 0.94832667760295 + 0.94832732627587 + 0.94832812342284 + 0.94832911015197 + 0.94833034017329 + 0.94833187873623 + 0.94833380677805 + 0.94833623314953 + 0.94833929526875 + 0.94834316831952 + 0.94834807783373 + 0.94835431466460 + 0.94836225459868 + 0.94837238402589 + 0.94838533369986 + 0.94840194304071 + 0.94842333531508 + 0.94845096791354 + 0.94848676707572 + 0.94853327724877 + 0.94859373240591 + 0.94867135758827 + 0.94876886192570 + 0.94889058875810 + 0.94904189145608 + 0.94922696849659 + 0.94945232973647 + 0.94972897611748 + 0.95007218536766 + 0.95050264702735 + 0.95104858883630 + 0.95174965529478 + 0.95266144685399 + 0.95386326443460 + 0.95547320561340 + 0.95767616871657 + 0.96078550275629 + 0.96541187815909 + 0.97312824538837 + 1.00000000000000 + 0.96973032413334 + 0.95618760005446 + 0.94430286305369 + 0.93281724262359 + 0.92126284254532 + 0.90941159323556 + 0.89714597703801 + 0.88441677669785 + 0.87122853674680 + 0.85762901332355 + 0.84369014082439 + 0.82951328376051 + 0.81524102843110 + 0.80102793236590 + 0.79398179343062 + 0.78699731713266 + 0.78008383044327 + 0.77324675489102 + 0.76648735387933 + 0.75980264846943 + 0.75318556825992 + 0.74662543397798 + 0.74010872796319 + 0.73361727410025 + 0.72708211088948 + 0.72030271808970 + 0.71317280736029 + 0.70567785455850 + 0.69780212853289 + 0.68955452582583 + 0.68094943141824 + 0.67200535081747 + 0.66274376805278 + 0.65318839428951 + 0.64336313491797 + 0.63326204107914 + 0.62290764755057 + 0.61232639900020 + 0.60155002401429 + 0.59061667052626 + 0.57957127976791 + 0.56844782361402 + 0.55727887233779 + 0.54611059363510 + 0.53498373050952 + 0.52392863356750 + 0.94222132651581 + 0.94222139522030 + 0.94222140662276 + 0.94222141991875 + 0.94222143542592 + 0.94222145351438 + 0.94222147461439 + 0.94222149923525 + 0.94222152798017 + 0.94222156161553 + 0.94222160125283 + 0.94222164853042 + 0.94222170540478 + 0.94222177404390 + 0.94222185699242 + 0.94222195731177 + 0.94222207873102 + 0.94222222578809 + 0.94222240422027 + 0.94222262127076 + 0.94222288561953 + 0.94222320796679 + 0.94222360153229 + 0.94222408269653 + 0.94222467197312 + 0.94222539620976 + 0.94222629284441 + 0.94222741082051 + 0.94222880951395 + 0.94223056250323 + 0.94223276879957 + 0.94223555327305 + 0.94223907497793 + 0.94224353848266 + 0.94224920735599 + 0.94225642173913 + 0.94226562133224 + 0.94227737553824 + 0.94229244150488 + 0.94231183154947 + 0.94233685642259 + 0.94236924559294 + 0.94241127891269 + 0.94246584200246 + 0.94253575946448 + 0.94262330579203 + 0.94273218687843 + 0.94286692338051 + 0.94303080793593 + 0.94322907438718 + 0.94347081253736 + 0.94376862051325 + 0.94413943406686 + 0.94460613709155 + 0.94520051430527 + 0.94596638139861 + 0.94696473377610 + 0.94828348146262 + 0.95005376351415 + 0.95248170090261 + 0.95592107726078 + 0.96107436683481 + 0.96973032413334 + 1.00000000000000 + 0.96589952133947 + 0.95070748750699 + 0.93748222857892 + 0.92480769814716 + 0.91216463438936 + 0.89930977502850 + 0.88612838959462 + 0.87258638701641 + 0.85870682750131 + 0.84454490152692 + 0.83019030127866 + 0.81577717952790 + 0.80145344152403 + 0.79436149343130 + 0.78733673070219 + 0.78038788936543 + 0.77351983911053 + 0.76673333074689 + 0.76002491193027 + 0.75338707730370 + 0.74680875022169 + 0.74027605273045 + 0.73377048018217 + 0.72722269184622 + 0.72043164174082 + 0.71329079336709 + 0.70578556505640 + 0.69790017793811 + 0.68964351623565 + 0.68102995463077 + 0.67207798683231 + 0.66280908192999 + 0.65324693278665 + 0.64341542279095 + 0.63330856241900 + 0.62294886520401 + 0.61236275561507 + 0.60158194363934 + 0.59064456058780 + 0.57959553321373 + 0.56846881614589 + 0.55729696401846 + 0.54612613251026 + 0.53499704877951 + 0.52394004181446 + 0.93541540028552 + 0.93541546259281 + 0.93541547293066 + 0.93541548498578 + 0.93541549904545 + 0.93541551544352 + 0.93541553456993 + 0.93541555688664 + 0.93541558293983 + 0.93541561342140 + 0.93541564934262 + 0.93541569219863 + 0.93541574377170 + 0.93541580603950 + 0.93541588131494 + 0.93541597238999 + 0.93541608265696 + 0.93541621625455 + 0.93541637840126 + 0.93541657570479 + 0.93541681607149 + 0.93541710924596 + 0.93541746726521 + 0.93541790503575 + 0.93541844122069 + 0.93541910026224 + 0.93541991630016 + 0.93542093398987 + 0.93542220743301 + 0.93542380360184 + 0.93542581267616 + 0.93542834827467 + 0.93543155498442 + 0.93543561861058 + 0.93544077829948 + 0.93544734233248 + 0.93545570872193 + 0.93546639214365 + 0.93548007641915 + 0.93549767503204 + 0.93552036835548 + 0.93554971117493 + 0.93558774890903 + 0.93563705973905 + 0.93570011974529 + 0.93577883328230 + 0.93587636116763 + 0.93599651742480 + 0.93614184682082 + 0.93631652961315 + 0.93652807320763 + 0.93678687625183 + 0.93710683390441 + 0.93750657620436 + 0.93801176656575 + 0.93865731848231 + 0.93949096166496 + 0.94057991134243 + 0.94202120779005 + 0.94396026012112 + 0.94662928130008 + 0.95043731991299 + 0.95618760005446 + 0.96589952133947 + 1.00000000000000 + 0.96158103464109 + 0.94458899293080 + 0.92994043043424 + 0.91603290285929 + 0.90228930938011 + 0.88845045258209 + 0.87440681212922 + 0.86013720915653 + 0.84566874925387 + 0.83107246777401 + 0.81646951098537 + 0.80199785612153 + 0.79484502458436 + 0.78776692065429 + 0.78077144618030 + 0.77386269805221 + 0.76704071422753 + 0.76030138804323 + 0.75363661627279 + 0.74703477869204 + 0.74048150658298 + 0.73395785008023 + 0.72739396533751 + 0.72058812761227 + 0.71343347694136 + 0.70591534962553 + 0.69801789854390 + 0.68974998448849 + 0.68112596141016 + 0.67216430041208 + 0.66288644401603 + 0.65331605443841 + 0.64347698007877 + 0.63336317450314 + 0.62299711837368 + 0.61240520517421 + 0.60161911653358 + 0.59067695852203 + 0.57962363597800 + 0.56849307914448 + 0.55731782093391 + 0.54614400015991 + 0.53501232314772 + 0.52395309170726 + 0.92786402853233 + 0.92786408511473 + 0.92786409450201 + 0.92786410544801 + 0.92786411821186 + 0.92786413309813 + 0.92786415046046 + 0.92786417071643 + 0.92786419436193 + 0.92786422202366 + 0.92786425462455 + 0.92786429352590 + 0.92786434035497 + 0.92786439691510 + 0.92786446531625 + 0.92786454810329 + 0.92786464836914 + 0.92786476988157 + 0.92786491740621 + 0.92786509697196 + 0.92786531578369 + 0.92786558272823 + 0.92786590877589 + 0.92786630750842 + 0.92786679592277 + 0.92786739629150 + 0.92786813978167 + 0.92786906717269 + 0.92787022781454 + 0.92787168273206 + 0.92787351414701 + 0.92787582555364 + 0.92787874853730 + 0.92788245204638 + 0.92788715333234 + 0.92789313212003 + 0.92790074911278 + 0.92791047009099 + 0.92792291339751 + 0.92793890433440 + 0.92795950717209 + 0.92798612139943 + 0.92802058443812 + 0.92806520275396 + 0.92812214885063 + 0.92819301212954 + 0.92828048702320 + 0.92838778733319 + 0.92851684075970 + 0.92867095608213 + 0.92885632445268 + 0.92908152644556 + 0.92935796950036 + 0.92970084929587 + 0.93013096751316 + 0.93067632761478 + 0.93137467564719 + 0.93227826861116 + 0.93346081820968 + 0.93502925862518 + 0.93714681405943 + 0.94008248802145 + 0.94430286305369 + 0.95070748750699 + 0.96158103464109 + 1.00000000000000 + 0.95673077679849 + 0.93779450644006 + 0.92165239160225 + 0.90648623722220 + 0.89165388533505 + 0.87687977610429 + 0.86205637025051 + 0.84716049316538 + 0.83223181623724 + 0.81737062870887 + 0.80269964380328 + 0.79546530915884 + 0.78831609461747 + 0.78125870706342 + 0.77429614740025 + 0.76742745131378 + 0.76064759911071 + 0.75394765883978 + 0.74731526115411 + 0.74073536438759 + 0.73418841161163 + 0.72760388702447 + 0.72077918343408 + 0.71360701605612 + 0.70607260413280 + 0.69816000303281 + 0.68987803333049 + 0.68124101252319 + 0.67226737305520 + 0.66297851393385 + 0.65339804893097 + 0.64354977304163 + 0.63342756069250 + 0.62305384339324 + 0.61245496864201 + 0.60166257620401 + 0.59071473505778 + 0.57965631792599 + 0.56852122106633 + 0.55734194752443 + 0.54616461277701 + 0.53502989580183 + 0.52396806413645 + 0.91953627048912 + 0.91953632190356 + 0.91953633043163 + 0.91953634037522 + 0.91953635197036 + 0.91953636549245 + 0.91953638126299 + 0.91953639965980 + 0.91953642113303 + 0.91953644625225 + 0.91953647585802 + 0.91953651118978 + 0.91953655373776 + 0.91953660514628 + 0.91953666733460 + 0.91953674263058 + 0.91953683385316 + 0.91953694444010 + 0.91953707873731 + 0.91953724224879 + 0.91953744155147 + 0.91953768475099 + 0.91953798185051 + 0.91953834523643 + 0.91953879039754 + 0.91953933764808 + 0.91954001546029 + 0.91954086110067 + 0.91954191962024 + 0.91954324667508 + 0.91954491729345 + 0.91954702584138 + 0.91954969218021 + 0.91955307009870 + 0.91955735715268 + 0.91956280744915 + 0.91956974824755 + 0.91957860157129 + 0.91958992721933 + 0.91960447173614 + 0.91962319590645 + 0.91964736104848 + 0.91967861990227 + 0.91971903865073 + 0.91977052539465 + 0.91983440205928 + 0.91991296427832 + 0.92000891625962 + 0.92012367801426 + 0.92025983793252 + 0.92042249005500 + 0.92061870635654 + 0.92085784646586 + 0.92115230805344 + 0.92151898054273 + 0.92198040318280 + 0.92256660957594 + 0.92331864248347 + 0.92429341112576 + 0.92557160216906 + 0.92727274939156 + 0.92958611077539 + 0.93281724262359 + 0.93748222857892 + 0.94458899293080 + 0.95673077679849 + 1.00000000000000 + 0.95130230303502 + 0.93028875429091 + 0.91260154639849 + 0.89617558929343 + 0.88029599277203 + 0.86466516241272 + 0.84916180865250 + 0.83376934565253 + 0.81855291754347 + 0.80361086408074 + 0.79626655820483 + 0.78902185048132 + 0.78188170348953 + 0.77484753850160 + 0.76791696232520 + 0.76108366590340 + 0.75433755659527 + 0.74766522332695 + 0.74105069436661 + 0.73447357914036 + 0.72786245809502 + 0.72101356899478 + 0.71381906486268 + 0.70626399742351 + 0.69833228252038 + 0.69003267513979 + 0.68137943274643 + 0.67239092541218 + 0.66308848399996 + 0.65349564838365 + 0.64363613417165 + 0.63350370627826 + 0.62312072442692 + 0.61251346937362 + 0.60171352046478 + 0.59075889336001 + 0.57969441477095 + 0.56855393410075 + 0.55736991369425 + 0.54618843707600 + 0.53505014739365 + 0.52398526889567 + 0.91041288518984 + 0.91041293189885 + 0.91041293964544 + 0.91041294867776 + 0.91041295920901 + 0.91041297148919 + 0.91041298581129 + 0.91041300251680 + 0.91041302201340 + 0.91041304482049 + 0.91041307169959 + 0.91041310378711 + 0.91041314243803 + 0.91041318915512 + 0.91041324569255 + 0.91041331416712 + 0.91041339715356 + 0.91041349778602 + 0.91041362003301 + 0.91041376891965 + 0.91041395044611 + 0.91041417201100 + 0.91041444274009 + 0.91041477392733 + 0.91041517969950 + 0.91041567859172 + 0.91041629662121 + 0.91041706786523 + 0.91041803347166 + 0.91041924423770 + 0.91042076867343 + 0.91042269288128 + 0.91042512614602 + 0.91042820857056 + 0.91043211998351 + 0.91043709144547 + 0.91044342020248 + 0.91045148906267 + 0.91046180542236 + 0.91047504540639 + 0.91049207747989 + 0.91051403994108 + 0.91054242144865 + 0.91057907559971 + 0.91062568028701 + 0.91068333084003 + 0.91075398227659 + 0.91083990667200 + 0.91094210819141 + 0.91106258103562 + 0.91120550440165 + 0.91137669615719 + 0.91158382438395 + 0.91183699421555 + 0.91214991957580 + 0.91254076382268 + 0.91303349365153 + 0.91366052651830 + 0.91446622678868 + 0.91551244473561 + 0.91688896180354 + 0.91873444667945 + 0.92126284254532 + 0.92480769814716 + 0.92994043043424 + 0.93779450644006 + 0.95130230303502 + 1.00000000000000 + 0.94525058023532 + 0.92204380397335 + 0.90278497765540 + 0.88512834158455 + 0.86827351919523 + 0.85188323425578 + 0.83583090617698 + 0.82011852956249 + 0.80480357977244 + 0.79730944206595 + 0.78993536474964 + 0.78268370087865 + 0.77555354649559 + 0.76854043408535 + 0.76163620513667 + 0.75482911941859 + 0.74810430036587 + 0.74144447781831 + 0.73482810621209 + 0.72818254040507 + 0.72130249490185 + 0.71407937235148 + 0.70649798357684 + 0.69854204407120 + 0.69022020493151 + 0.68154662832958 + 0.67253958707683 + 0.66322030826358 + 0.65361222159691 + 0.64373892676785 + 0.63359403774233 + 0.62319981108636 + 0.61258243224997 + 0.60177339475169 + 0.59081063882115 + 0.57973892632019 + 0.56859204259703 + 0.55740239489563 + 0.54621602335389 + 0.53507352424979 + 0.52400506706057 + 0.90048894484372 + 0.90048898723494 + 0.90048899426411 + 0.90048900245979 + 0.90048901201642 + 0.90048902315904 + 0.90048903615288 + 0.90048905130770 + 0.90048906899426 + 0.90048908968156 + 0.90048911406416 + 0.90048914317740 + 0.90048917826033 + 0.90048922067868 + 0.90048927203510 + 0.90048933425753 + 0.90048940969385 + 0.90048950120456 + 0.90048961240679 + 0.90048974788770 + 0.90048991312578 + 0.90049011486694 + 0.90049036143971 + 0.90049066314138 + 0.90049103285951 + 0.90049148750153 + 0.90049205085516 + 0.90049275408241 + 0.90049363478494 + 0.90049473933824 + 0.90049613033865 + 0.90049788639452 + 0.90050010721107 + 0.90050292052963 + 0.90050649017755 + 0.90051102645951 + 0.90051679963084 + 0.90052415730985 + 0.90053355992657 + 0.90054562057189 + 0.90056112529128 + 0.90058110274919 + 0.90060689574184 + 0.90064016969860 + 0.90068240215432 + 0.90073449703803 + 0.90079811887149 + 0.90087517391174 + 0.90096632777114 + 0.90107308629584 + 0.90119886643970 + 0.90134844322800 + 0.90152808542888 + 0.90174601404944 + 0.90201335197341 + 0.90234472948165 + 0.90275928243142 + 0.90328267652214 + 0.90394967306746 + 0.90480811949023 + 0.90592650100172 + 0.90740901081003 + 0.90941159323556 + 0.91216463438936 + 0.91603290285929 + 0.92165239160225 + 0.93028875429091 + 0.94525058023532 + 1.00000000000000 + 0.93853441426526 + 0.91304247697310 + 0.89221648645871 + 0.87338938091044 + 0.85565177449266 + 0.83863437034472 + 0.82221553474238 + 0.80637972577692 + 0.79867886802731 + 0.79112755414221 + 0.78372410569362 + 0.77646409991911 + 0.76933998533923 + 0.76234089566204 + 0.75545271031919 + 0.74865845962083 + 0.74193903683302 + 0.73527127783649 + 0.72858085838180 + 0.72166046617696 + 0.71440049222198 + 0.70678539835278 + 0.69879861071308 + 0.69044861852294 + 0.68174943590048 + 0.67271918708764 + 0.66337894394125 + 0.65375197439245 + 0.64386171094197 + 0.63370156001038 + 0.62329363165119 + 0.61266397678703 + 0.60184396841652 + 0.59087144130898 + 0.57979106698148 + 0.56863654376396 + 0.55744020470056 + 0.54624803136611 + 0.53510055879872 + 0.52402788703611 + 0.88977761801563 + 0.88977765642395 + 0.88977766279255 + 0.88977767021727 + 0.88977767887383 + 0.88977768896649 + 0.88977770073593 + 0.88977771446297 + 0.88977773047860 + 0.88977774921308 + 0.88977777129425 + 0.88977779766655 + 0.88977782945878 + 0.88977786791655 + 0.88977791449814 + 0.88977797095953 + 0.88977803944151 + 0.88977812254733 + 0.88977822357651 + 0.88977834671263 + 0.88977849695229 + 0.88977868044880 + 0.88977890479275 + 0.88977917937774 + 0.88977951595052 + 0.88977992994022 + 0.88978044308517 + 0.88978108389094 + 0.88978188671838 + 0.88978289391920 + 0.88978416270085 + 0.88978576486453 + 0.88978779142448 + 0.88979035892386 + 0.88979361671836 + 0.88979775638843 + 0.88980302387479 + 0.88980973516644 + 0.88981830854047 + 0.88982930059343 + 0.88984342367831 + 0.88986160867478 + 0.88988506858242 + 0.88991530214979 + 0.88995361256244 + 0.89000074259478 + 0.89005810940844 + 0.89012731020063 + 0.89020873706569 + 0.89030349641607 + 0.89041437115722 + 0.89054526982748 + 0.89070130356929 + 0.89088914309306 + 0.89111779126212 + 0.89139901184836 + 0.89174806418021 + 0.89218526676451 + 0.89273790373817 + 0.89344315691788 + 0.89435373428336 + 0.89554915924785 + 0.89714597703801 + 0.89930977502850 + 0.90228930938011 + 0.90648623722220 + 0.91260154639849 + 0.92204380397335 + 0.93853441426526 + 1.00000000000000 + 0.93111784934378 + 0.90327981445836 + 0.88092252483320 + 0.86100742202701 + 0.84252015279412 + 0.82506601249078 + 0.80848735640856 + 0.80049647425874 + 0.79269874757999 + 0.78508600182629 + 0.77764829200895 + 0.77037333554260 + 0.76324619307030 + 0.75624922421598 + 0.74936240947042 + 0.74256399937633 + 0.73582852759594 + 0.72907933951026 + 0.72210639656478 + 0.71479870912657 + 0.70714022829847 + 0.69911395878691 + 0.69072813949676 + 0.68199655716362 + 0.67293711175538 + 0.66357064538260 + 0.65392019068447 + 0.64400894098893 + 0.63383001765573 + 0.62340532437061 + 0.61276072371792 + 0.60192742086663 + 0.59094310438920 + 0.57985232102404 + 0.56868865143836 + 0.55748432910615 + 0.54628525694985 + 0.53513189001685 + 0.52405424012072 + 0.87831521515180 + 0.87831524986819 + 0.87831525562328 + 0.87831526233329 + 0.87831527015578 + 0.87831527927652 + 0.87831528991073 + 0.87831530231330 + 0.87831531678431 + 0.87831533370932 + 0.87831535366051 + 0.87831537749628 + 0.87831540624286 + 0.87831544103469 + 0.87831548319880 + 0.87831553433125 + 0.87831559637782 + 0.87831567171162 + 0.87831576333598 + 0.87831587506425 + 0.87831601144508 + 0.87831617809007 + 0.87831638191386 + 0.87831663147675 + 0.87831693748358 + 0.87831731400584 + 0.87831778090997 + 0.87831836425768 + 0.87831909544995 + 0.87832001316255 + 0.87832116969032 + 0.87832263062900 + 0.87832447909179 + 0.87832682145211 + 0.87832979395780 + 0.87833357124958 + 0.87833837731760 + 0.87834449966698 + 0.87835231865989 + 0.87836234015546 + 0.87837521051074 + 0.87839177321634 + 0.87841312557865 + 0.87844061846235 + 0.87847540326061 + 0.87851808749382 + 0.87856987795207 + 0.87863211121410 + 0.87870496052787 + 0.87878920750097 + 0.87888710874067 + 0.87900185375437 + 0.87913759671284 + 0.87929973264362 + 0.87949552768235 + 0.87973441359570 + 0.88002852417021 + 0.88039391078034 + 0.88085196847582 + 0.88143161823439 + 0.88217359605264 + 0.88313916240173 + 0.88441677669785 + 0.88612838959462 + 0.88845045258209 + 0.89165388533505 + 0.89617558929343 + 0.90278497765540 + 0.91304247697310 + 0.93111784934378 + 1.00000000000000 + 0.92297006110449 + 0.89275606064753 + 0.86892694501834 + 0.84805505802080 + 0.82901907346755 + 0.81134935694952 + 0.80294209415676 + 0.79479487866938 + 0.78688847088158 + 0.77920383408478 + 0.77172112092167 + 0.76441904243774 + 0.75727459100796 + 0.75026318447020 + 0.74335918338934 + 0.73653378203903 + 0.72970703705165 + 0.72266519208998 + 0.71529534449148 + 0.70758068760875 + 0.69950360510546 + 0.69107194907879 + 0.68229915848320 + 0.67320279651495 + 0.66380336705455 + 0.65412356230046 + 0.64418623500188 + 0.63398411492182 + 0.62353881658393 + 0.61287594038761 + 0.60202645913721 + 0.59102785992358 + 0.57992451821988 + 0.56874985608189 + 0.55753597373458 + 0.54632866878148 + 0.53516829177747 + 0.52408474218852 + 0.86616651334025 + 0.86616654462237 + 0.86616654980804 + 0.86616655585244 + 0.86616656290039 + 0.86616657111742 + 0.86616658069796 + 0.86616659187048 + 0.86616660490492 + 0.86616662014886 + 0.86616663812282 + 0.86616665960342 + 0.86616668552436 + 0.86616671691559 + 0.86616675497945 + 0.86616680116919 + 0.86616685725132 + 0.86616692537910 + 0.86616700828645 + 0.86616710944449 + 0.86616723299515 + 0.86616738403960 + 0.86616756887882 + 0.86616779530529 + 0.86616807306606 + 0.86616841498770 + 0.86616883921445 + 0.86616936956655 + 0.86617003473054 + 0.86617087002105 + 0.86617192323710 + 0.86617325430997 + 0.86617493914746 + 0.86617707487109 + 0.86617978581840 + 0.86618323126265 + 0.86618761533532 + 0.86619319981033 + 0.86620033085346 + 0.86620946863329 + 0.86622120023496 + 0.86623629083228 + 0.86625573431596 + 0.86628075000417 + 0.86631235693241 + 0.86635104946410 + 0.86639785562350 + 0.86645389258602 + 0.86651916069590 + 0.86659417943559 + 0.86668076961969 + 0.86678152513947 + 0.86689981015495 + 0.86703997091773 + 0.86720785084795 + 0.86741098263761 + 0.86765897389873 + 0.86796445537495 + 0.86834414958720 + 0.86882050687765 + 0.86942502655042 + 0.87020512105336 + 0.87122853674680 + 0.87258638701641 + 0.87440681212922 + 0.87687977610429 + 0.88029599277203 + 0.88512834158455 + 0.89221648645871 + 0.90327981445836 + 0.92297006110449 + 1.00000000000000 + 0.91405454405763 + 0.88145796437281 + 0.85627645966365 + 0.83466170555805 + 0.81531868857739 + 0.80629369658922 + 0.79763673914043 + 0.78930827469834 + 0.78127331074043 + 0.77349921943302 + 0.76595433152437 + 0.75860711308157 + 0.75142591180071 + 0.74437918694115 + 0.73743316143360 + 0.73050314717717 + 0.72337022637903 + 0.71591879361168 + 0.70813089759935 + 0.69998799246478 + 0.69149732930723 + 0.68267181407081 + 0.67352850407484 + 0.66408740554672 + 0.65437071869193 + 0.64440081195364 + 0.63416987608182 + 0.62369912150582 + 0.61301378471738 + 0.60214451788971 + 0.59112853146121 + 0.58000996672335 + 0.56882203228329 + 0.55759665022823 + 0.54637947740648 + 0.53521072773965 + 0.52412015717887 + 0.85342361662212 + 0.85342364470698 + 0.85342364936199 + 0.85342365478870 + 0.85342366111433 + 0.85342366848988 + 0.85342367708824 + 0.85342368711611 + 0.85342369881452 + 0.85342371249554 + 0.85342372862858 + 0.85342374791871 + 0.85342377121164 + 0.85342379944034 + 0.85342383369618 + 0.85342387529292 + 0.85342392583478 + 0.85342398727623 + 0.85342406209676 + 0.85342415345239 + 0.85342426510562 + 0.85342440169634 + 0.85342456895137 + 0.85342477395942 + 0.85342502558736 + 0.85342533551966 + 0.85342572030967 + 0.85342620172059 + 0.85342680594805 + 0.85342756522219 + 0.85342852321683 + 0.85342973468167 + 0.85343126893854 + 0.85343321466318 + 0.85343568533898 + 0.85343882625662 + 0.85344282351070 + 0.85344791555325 + 0.85345441759333 + 0.85346274849729 + 0.85347344189492 + 0.85348719250084 + 0.85350490137711 + 0.85352767033081 + 0.85355640267838 + 0.85359149843009 + 0.85363383373993 + 0.85368434134398 + 0.85374288740873 + 0.85380978201233 + 0.85388648629618 + 0.85397510195295 + 0.85407834245204 + 0.85419969356695 + 0.85434383489748 + 0.85451675388937 + 0.85472601626813 + 0.85498150657278 + 0.85529622683622 + 0.85568752641973 + 0.85617970307609 + 0.85680949695553 + 0.85762901332355 + 0.85870682750131 + 0.86013720915653 + 0.86205637025051 + 0.86466516241272 + 0.86827351919523 + 0.87338938091044 + 0.88092252483320 + 0.89275606064753 + 0.91405454405763 + 1.00000000000000 + 0.90431058210660 + 0.86939759060682 + 0.84308718149042 + 0.82099880240699 + 0.81101128433289 + 0.80157966248910 + 0.79262311009261 + 0.78407607963044 + 0.77588267737302 + 0.76799313923974 + 0.76036161723607 + 0.75294497102112 + 0.74570233510012 + 0.73859226751905 + 0.73152302722346 + 0.72426835233034 + 0.71670871964912 + 0.70882440842277 + 0.70059545295379 + 0.69202816007072 + 0.68313461238250 + 0.67393110289483 + 0.66443690237887 + 0.65467349767214 + 0.64466256668580 + 0.63439555452222 + 0.62389310629794 + 0.61317995320714 + 0.60228630496137 + 0.59124899224015 + 0.58011183632915 + 0.56890775823648 + 0.55766844154423 + 0.54643935480205 + 0.53526053266688 + 0.52416154679713 + 0.84019232603256 + 0.84019235113625 + 0.84019235529676 + 0.84019236014704 + 0.84019236580045 + 0.84019237239225 + 0.84019238007659 + 0.84019238903738 + 0.84019239949041 + 0.84019241171575 + 0.84019242613522 + 0.84019244338587 + 0.84019246423404 + 0.84019248952272 + 0.84019252023732 + 0.84019255756614 + 0.84019260296071 + 0.84019265819141 + 0.84019272550417 + 0.84019280776187 + 0.84019290837890 + 0.84019303156654 + 0.84019318252678 + 0.84019336769458 + 0.84019359513015 + 0.84019387545884 + 0.84019422378053 + 0.84019465995505 + 0.84019520787685 + 0.84019589695292 + 0.84019676706286 + 0.84019786819206 + 0.84019926362707 + 0.84020103430099 + 0.84020328376661 + 0.84020614454279 + 0.84020978626899 + 0.84021442614942 + 0.84022035123856 + 0.84022794286535 + 0.84023768619794 + 0.84025021218675 + 0.84026633808578 + 0.84028706010639 + 0.84031317993698 + 0.84034501915795 + 0.84038332480600 + 0.84042887470420 + 0.84048143353610 + 0.84054114643523 + 0.84060917883407 + 0.84068722696091 + 0.84077747001893 + 0.84088269006523 + 0.84100661736103 + 0.84115398534873 + 0.84133071316492 + 0.84154448384538 + 0.84180533746198 + 0.84212659482020 + 0.84252691108563 + 0.84303472193201 + 0.84369014082439 + 0.84454490152692 + 0.84566874925387 + 0.84716049316538 + 0.84916180865250 + 0.85188323425578 + 0.85565177449266 + 0.86100742202701 + 0.86892694501834 + 0.88145796437281 + 0.90431058210660 + 1.00000000000000 + 0.89372279675389 + 0.85668404000189 + 0.82954195947643 + 0.81793337757719 + 0.80724732932407 + 0.79730537086844 + 0.78797568814500 + 0.77915536362826 + 0.77076015399150 + 0.76271827749454 + 0.75496666695985 + 0.74744887373875 + 0.74011105446527 + 0.73285053965158 + 0.72543024554319 + 0.71772476899910 + 0.70971157064068 + 0.70136845729705 + 0.69270022526646 + 0.68371766635747 + 0.67443590407260 + 0.66487311021526 + 0.65504972719958 + 0.64498643964325 + 0.63467365022667 + 0.62413120777155 + 0.61338313745691 + 0.60245903497908 + 0.59139520698765 + 0.58023503532173 + 0.56901105098950 + 0.55775461607598 + 0.54651094566871 + 0.53531983725738 + 0.52421062338392 + 0.82659950109453 + 0.82659952342516 + 0.82659952712588 + 0.82659953143943 + 0.82659953646791 + 0.82659954233009 + 0.82659954916384 + 0.82659955713230 + 0.82659956642830 + 0.82659957730043 + 0.82659959012678 + 0.82659960548389 + 0.82659962406061 + 0.82659964661886 + 0.82659967404696 + 0.82659970741730 + 0.82659974804126 + 0.82659979751317 + 0.82659985786924 + 0.82659993170178 + 0.82660002210113 + 0.82660013288564 + 0.82660026877110 + 0.82660043559088 + 0.82660064066509 + 0.82660089364911 + 0.82660120829340 + 0.82660160270889 + 0.82660209868052 + 0.82660272300298 + 0.82660351207353 + 0.82660451150252 + 0.82660577902635 + 0.82660738848156 + 0.82660943431665 + 0.82661203735722 + 0.82661535219675 + 0.82661957664777 + 0.82662497207396 + 0.82663188559526 + 0.82664075829904 + 0.82665216323512 + 0.82666684170842 + 0.82668569467860 + 0.82670943432389 + 0.82673831737858 + 0.82677298118055 + 0.82681407378203 + 0.82686128600130 + 0.82691463557988 + 0.82697504641118 + 0.82704388251989 + 0.82712288697543 + 0.82721426975372 + 0.82732099122163 + 0.82744677319471 + 0.82759621501137 + 0.82777524476980 + 0.82799155592146 + 0.82825529903124 + 0.82858071355497 + 0.82898975602123 + 0.82951328376051 + 0.83019030127866 + 0.83107246777401 + 0.83223181623724 + 0.83376934565253 + 0.83583090617698 + 0.83863437034472 + 0.84252015279412 + 0.84805505802080 + 0.85627645966365 + 0.86939759060682 + 0.89372279675389 + 1.00000000000000 + 0.88236277192793 + 0.84349061602185 + 0.82876702421416 + 0.81583192658283 + 0.80421301482265 + 0.79360489777244 + 0.78379394172097 + 0.77462133670771 + 0.76596302561232 + 0.75771810173784 + 0.74980198918408 + 0.74213941504816 + 0.73460979766183 + 0.72695934183078 + 0.71905340676575 + 0.71086477723520 + 0.70236763611487 + 0.69356429369496 + 0.68446346796127 + 0.67507845447167 + 0.66542575237805 + 0.65552425040300 + 0.64539318423913 + 0.63502147847938 + 0.62442784815082 + 0.61363532247000 + 0.60267263760627 + 0.59157537132183 + 0.58038629748540 + 0.56913741382171 + 0.55785964539080 + 0.54659786342326 + 0.53539154864127 + 0.52426971989037 + 0.81280688863087 + 0.81280690839505 + 0.81280691167052 + 0.81280691548773 + 0.81280691993855 + 0.81280692512620 + 0.81280693117409 + 0.81280693822536 + 0.81280694645169 + 0.81280695607268 + 0.81280696742883 + 0.81280698103623 + 0.81280699751694 + 0.81280701755558 + 0.81280704195233 + 0.81280707167340 + 0.81280710789767 + 0.81280715206539 + 0.81280720601521 + 0.81280727208880 + 0.81280735308584 + 0.81280745245945 + 0.81280757447945 + 0.81280772443694 + 0.81280790896319 + 0.81280813682835 + 0.81280842055190 + 0.81280877663592 + 0.81280922493120 + 0.81280978984937 + 0.81281050458709 + 0.81281141075682 + 0.81281256101657 + 0.81281402271482 + 0.81281588198297 + 0.81281824897968 + 0.81282126458262 + 0.81282510894971 + 0.81283002007537 + 0.81283631397537 + 0.81284439173736 + 0.81285477394644 + 0.81286813321387 + 0.81288528472047 + 0.81290686197849 + 0.81293306857953 + 0.81296444909847 + 0.81300154358001 + 0.81304399201665 + 0.81309171641210 + 0.81314544537136 + 0.81320627326890 + 0.81327559054171 + 0.81335514673017 + 0.81344728396228 + 0.81355491626135 + 0.81368159624421 + 0.81383186764195 + 0.81401158346151 + 0.81422842251904 + 0.81449319444368 + 0.81482282239475 + 0.81524102843110 + 0.81577717952790 + 0.81646951098537 + 0.81737062870887 + 0.81855291754347 + 0.82011852956249 + 0.82221553474238 + 0.82506601249078 + 0.82901907346755 + 0.83466170555805 + 0.84308718149042 + 0.85668404000189 + 0.88236277192793 + 1.00000000000000 + 0.87031817413273 + 0.84775683216212 + 0.82997392148772 + 0.81508623081895 + 0.80215935612480 + 0.79064743058917 + 0.78019653339607 + 0.77055957641902 + 0.76155394957446 + 0.75303854784886 + 0.74489756287912 + 0.73697873253367 + 0.72900079849258 + 0.72081371317937 + 0.71238207249280 + 0.70367387311670 + 0.69468716753350 + 0.68542722544484 + 0.67590440032910 + 0.66613258200776 + 0.65612830027080 + 0.64590864126323 + 0.63546040237495 + 0.62480066556697 + 0.61395104157411 + 0.60293905365626 + 0.59179925881558 + 0.58057358485939 + 0.56929329592903 + 0.55798871968167 + 0.54670425857077 + 0.53547896778002 + 0.52434145183187 + 0.79898488690631 + 0.79898490431974 + 0.79898490720485 + 0.79898491056861 + 0.79898491448918 + 0.79898491905927 + 0.79898492438730 + 0.79898493059824 + 0.79898493784350 + 0.79898494632106 + 0.79898495632844 + 0.79898496833452 + 0.79898498289840 + 0.79898500063317 + 0.79898502225831 + 0.79898504864211 + 0.79898508084635 + 0.79898512017022 + 0.79898516826874 + 0.79898522726229 + 0.79898529967818 + 0.79898538864033 + 0.79898549801510 + 0.79898563259538 + 0.79898579839401 + 0.79898600337141 + 0.79898625892601 + 0.79898658009920 + 0.79898698497824 + 0.79898749580762 + 0.79898814287780 + 0.79898896415534 + 0.79899000769194 + 0.79899133493674 + 0.79899302447838 + 0.79899517679645 + 0.79899792034556 + 0.79900141930240 + 0.79900589052694 + 0.79901162191889 + 0.79901897846641 + 0.79902843348098 + 0.79904059777630 + 0.79905620969271 + 0.79907583392257 + 0.79909963096374 + 0.79912806745132 + 0.79916159424373 + 0.79919981924850 + 0.79924259492097 + 0.79929049387619 + 0.79934439404541 + 0.79940540403169 + 0.79947490726606 + 0.79955475539408 + 0.79964722555503 + 0.79975505127766 + 0.79988169898886 + 0.80003159770901 + 0.80021052434321 + 0.80042665563147 + 0.80069303901442 + 0.80102793236590 + 0.80145344152403 + 0.80199785612153 + 0.80269964380328 + 0.80361086408074 + 0.80480357977244 + 0.80637972577692 + 0.80848735640856 + 0.81134935694952 + 0.81531868857739 + 0.82099880240699 + 0.82954195947643 + 0.84349061602185 + 0.87031817413273 + 1.00000000000000 + 0.89204722408040 + 0.85765334452202 + 0.83435568419087 + 0.81633762860702 + 0.80146258679730 + 0.78866918368729 + 0.77734001222504 + 0.76707815133877 + 0.75760945969100 + 0.74873082434766 + 0.74022756672034 + 0.73176912760667 + 0.72317758970451 + 0.71440215561029 + 0.70539958720620 + 0.69616025841920 + 0.68668344500371 + 0.67697458246133 + 0.66704335872961 + 0.65690262695115 + 0.64656621524645 + 0.63601780436594 + 0.62527209039087 + 0.61434864043191 + 0.60327325009958 + 0.59207903591744 + 0.58080674087226 + 0.56948661415709 + 0.55814816263105 + 0.54683514695947 + 0.53558604805330 + 0.52442892045963 + 0.79210571761580 + 0.79210573393495 + 0.79210573663883 + 0.79210573979073 + 0.79210574346459 + 0.79210574774778 + 0.79210575273973 + 0.79210575856069 + 0.79210576535046 + 0.79210577329388 + 0.79210578267534 + 0.79210579393617 + 0.79210580760719 + 0.79210582427017 + 0.79210584460591 + 0.79210586943849 + 0.79210589977465 + 0.79210593684699 + 0.79210598222551 + 0.79210603792777 + 0.79210610635373 + 0.79210619047818 + 0.79210629397863 + 0.79210642141624 + 0.79210657851428 + 0.79210677286387 + 0.79210701533896 + 0.79210732030111 + 0.79210770501901 + 0.79210819073327 + 0.79210880638603 + 0.79210958824763 + 0.79211058223434 + 0.79211184706072 + 0.79211345781576 + 0.79211551049507 + 0.79211812780206 + 0.79212146652650 + 0.79212573375446 + 0.79213120438470 + 0.79213822675327 + 0.79214725236780 + 0.79215886358305 + 0.79217376346902 + 0.79219248566844 + 0.79221517238977 + 0.79224225619097 + 0.79227414948222 + 0.79231044988522 + 0.79235098328662 + 0.79239625695705 + 0.79244705775712 + 0.79250437614705 + 0.79256944275220 + 0.79264390488723 + 0.79272977576704 + 0.79282945169098 + 0.79294595757129 + 0.79308314154476 + 0.79324600795299 + 0.79344166512651 + 0.79368158102847 + 0.79398179343062 + 0.79436149343130 + 0.79484502458436 + 0.79546530915884 + 0.79626655820483 + 0.79730944206595 + 0.79867886802731 + 0.80049647425874 + 0.80294209415676 + 0.80629369658922 + 0.81101128433289 + 0.81793337757719 + 0.82876702421416 + 0.84775683216212 + 0.89204722408040 + 1.00000000000000 + 0.88642351376170 + 0.85115986787105 + 0.82759250970881 + 0.80953713076084 + 0.79472350691466 + 0.78202807305449 + 0.77080133793754 + 0.76062864836436 + 0.75122232693937 + 0.74231192507136 + 0.73352624509108 + 0.72466447546050 + 0.71566296021636 + 0.70646936605301 + 0.69706792905390 + 0.68745328177204 + 0.67762717186018 + 0.66759623247674 + 0.65737071586737 + 0.64696219890588 + 0.63635226658419 + 0.62555401783715 + 0.61458566816503 + 0.60347188172398 + 0.59224483917689 + 0.58094451879655 + 0.56960052082276 + 0.55824183027231 + 0.54691180111907 + 0.53564855422015 + 0.52447980343917 + 0.78527122126111 + 0.78527123654112 + 0.78527123907313 + 0.78527124202429 + 0.78527124546430 + 0.78527124947421 + 0.78527125414897 + 0.78527125959843 + 0.78527126595641 + 0.78527127339382 + 0.78527128218015 + 0.78527129273525 + 0.78527130555982 + 0.78527132120649 + 0.78527134032056 + 0.78527136368224 + 0.78527139224511 + 0.78527142718086 + 0.78527146998168 + 0.78527152256257 + 0.78527158720760 + 0.78527166674593 + 0.78527176467549 + 0.78527188533857 + 0.78527203418912 + 0.78527221845862 + 0.78527244852994 + 0.78527273811999 + 0.78527310372050 + 0.78527356561733 + 0.78527415146934 + 0.78527489594704 + 0.78527584293307 + 0.78527704855266 + 0.78527858457494 + 0.78528054275171 + 0.78528304033500 + 0.78528622712184 + 0.78529030094235 + 0.78529552440756 + 0.78530223009967 + 0.78531084893113 + 0.78532193639735 + 0.78533616232957 + 0.78535403145131 + 0.78537566962198 + 0.78540147829796 + 0.78543183514604 + 0.78546633071358 + 0.78550476901393 + 0.78554759944853 + 0.78559552794428 + 0.78564944026728 + 0.78571043204471 + 0.78577997027736 + 0.78585983616723 + 0.78595213092953 + 0.78605949437534 + 0.78618526959303 + 0.78633379109439 + 0.78651124114631 + 0.78672771349500 + 0.78699731713266 + 0.78733673070219 + 0.78776692065429 + 0.78831609461747 + 0.78902185048132 + 0.78993536474964 + 0.79112755414221 + 0.79269874757999 + 0.79479487866938 + 0.79763673914043 + 0.80157966248910 + 0.80724732932407 + 0.81583192658283 + 0.82997392148772 + 0.85765334452202 + 0.88642351376170 + 1.00000000000000 + 0.88062766450444 + 0.84457464589059 + 0.82081116842592 + 0.80276995135193 + 0.78804739607014 + 0.77546179500757 + 0.76433555377361 + 0.75423591456773 + 0.74480358817880 + 0.73560697217484 + 0.72641159794577 + 0.71713484704607 + 0.70771133755753 + 0.69811662621777 + 0.68833894722088 + 0.67837509677469 + 0.66822770580514 + 0.65790369169093 + 0.64741179782244 + 0.63673102539530 + 0.62587251362487 + 0.61485283559269 + 0.60369529139767 + 0.59243094067737 + 0.58109885049582 + 0.56972785314264 + 0.55834631876085 + 0.54699712338915 + 0.53571796783163 + 0.52453617177900 + 0.77849230760569 + 0.77849232190509 + 0.77849232427405 + 0.77849232703478 + 0.77849233025414 + 0.77849233400626 + 0.77849233837993 + 0.77849234347914 + 0.77849234942835 + 0.77849235638820 + 0.77849236461313 + 0.77849237449965 + 0.77849238652472 + 0.77849240121142 + 0.77849241916935 + 0.77849244114078 + 0.77849246802994 + 0.77849250094440 + 0.77849254130700 + 0.77849259093598 + 0.77849265200470 + 0.77849272720285 + 0.77849281986160 + 0.77849293411664 + 0.77849307516206 + 0.77849324989427 + 0.77849346822772 + 0.77849374326691 + 0.77849409077129 + 0.77849453011925 + 0.77849508775519 + 0.77849579682987 + 0.77849669930268 + 0.77849784884523 + 0.77849931408502 + 0.77850118275173 + 0.77850356694449 + 0.77850660983981 + 0.77851050053603 + 0.77851549001173 + 0.77852189597867 + 0.77853012991451 + 0.77854072198598 + 0.77855431074740 + 0.77857137399647 + 0.77859202300752 + 0.77861663088355 + 0.77864554392352 + 0.77867834838753 + 0.77871483056167 + 0.77875538871226 + 0.77880065702298 + 0.77885142867969 + 0.77890868034135 + 0.77897372030027 + 0.77904812638057 + 0.77913374241741 + 0.77923287346559 + 0.77934842507594 + 0.77948415312849 + 0.77964543992336 + 0.77984118666687 + 0.78008383044327 + 0.78038788936543 + 0.78077144618030 + 0.78125870706342 + 0.78188170348953 + 0.78268370087865 + 0.78372410569362 + 0.78508600182629 + 0.78688847088158 + 0.78930827469834 + 0.79262311009261 + 0.79730537086844 + 0.80421301482265 + 0.81508623081895 + 0.83435568419087 + 0.85115986787105 + 0.88062766450444 + 1.00000000000000 + 0.87467010137790 + 0.83791912718357 + 0.81403379840931 + 0.79605276883645 + 0.78144315860845 + 0.76897102613115 + 0.75793150919631 + 0.74781375800323 + 0.73809133519687 + 0.72847806213998 + 0.71886237356919 + 0.70915961818783 + 0.69933278779223 + 0.68936112336431 + 0.67923466111985 + 0.66895071419793 + 0.65851187349416 + 0.64792328103324 + 0.63716072653424 + 0.62623292838856 + 0.61515445281144 + 0.60394694791744 + 0.59264012545290 + 0.58127196332097 + 0.56987038260248 + 0.55846302729435 + 0.54709221068148 + 0.53579514267583 + 0.52459868611927 + 0.77177591212674 + 0.77177592550123 + 0.77177592771714 + 0.77177593029994 + 0.77177593331065 + 0.77177593682018 + 0.77177594091090 + 0.77177594568012 + 0.77177595124425 + 0.77177595775419 + 0.77177596545013 + 0.77177597470828 + 0.77177598597983 + 0.77177599976088 + 0.77177601663050 + 0.77177603729038 + 0.77177606259843 + 0.77177609360935 + 0.77177613167157 + 0.77177617851677 + 0.77177623621077 + 0.77177630731350 + 0.77177639499777 + 0.77177650320327 + 0.77177663687935 + 0.77177680260509 + 0.77177700985094 + 0.77177727114339 + 0.77177760154362 + 0.77177801957538 + 0.77177855053307 + 0.77177922612637 + 0.77178008649528 + 0.77178118298801 + 0.77178258125625 + 0.77178436523059 + 0.77178664213686 + 0.77178954889840 + 0.77179326635090 + 0.77179803450107 + 0.77180415701808 + 0.77181202705415 + 0.77182215090632 + 0.77183513770630 + 0.77185144020318 + 0.77187115668006 + 0.77189463438877 + 0.77192219134149 + 0.77195341190480 + 0.77198806827467 + 0.77202651364135 + 0.77206931867711 + 0.77211719486745 + 0.77217101425212 + 0.77223194572515 + 0.77230138926086 + 0.77238096483370 + 0.77247268740572 + 0.77257908469508 + 0.77270341442319 + 0.77285036994975 + 0.77302781990339 + 0.77324675489102 + 0.77351983911053 + 0.77386269805221 + 0.77429614740025 + 0.77484753850160 + 0.77555354649559 + 0.77646409991911 + 0.77764829200895 + 0.77920383408478 + 0.78127331074043 + 0.78407607963044 + 0.78797568814500 + 0.79360489777244 + 0.80215935612480 + 0.81633762860702 + 0.82759250970881 + 0.84457464589059 + 0.87467010137790 + 1.00000000000000 + 0.86856350751466 + 0.83121587321189 + 0.80728111906480 + 0.78939890986497 + 0.77491517674424 + 0.76254695466650 + 0.75150015576119 + 0.74108855947239 + 0.73094206354044 + 0.72090302095283 + 0.71085732653368 + 0.70074927022083 + 0.69054515693877 + 0.68022561360001 + 0.66978077244006 + 0.65920753519093 + 0.64850641494392 + 0.63764917229462 + 0.62664151198719 + 0.61549553232646 + 0.60423087015726 + 0.59287560947531 + 0.58146642156834 + 0.57003014298193 + 0.55859355788307 + 0.54719831547578 + 0.53588105081634 + 0.52466809629796 + 0.76512473850487 + 0.76512475101173 + 0.76512475308429 + 0.76512475549939 + 0.76512475831481 + 0.76512476159670 + 0.76512476542182 + 0.76512476988155 + 0.76512477508477 + 0.76512478117297 + 0.76512478837259 + 0.76512479704014 + 0.76512480760543 + 0.76512482053707 + 0.76512483638410 + 0.76512485581223 + 0.76512487963596 + 0.76512490885739 + 0.76512494475615 + 0.76512498898035 + 0.76512504349874 + 0.76512511074669 + 0.76512519374528 + 0.76512529625022 + 0.76512542297972 + 0.76512558021737 + 0.76512577700585 + 0.76512602532864 + 0.76512633958674 + 0.76512673749190 + 0.76512724325426 + 0.76512788721446 + 0.76512870779413 + 0.76512975413779 + 0.76513108908929 + 0.76513279298035 + 0.76513496842759 + 0.76513774645083 + 0.76514130008439 + 0.76514585895660 + 0.76515171349926 + 0.76515923957541 + 0.76516892098621 + 0.76518133919429 + 0.76519692363203 + 0.76521576101955 + 0.76523817505127 + 0.76526445822705 + 0.76529419507408 + 0.76532714687599 + 0.76536362714550 + 0.76540415040718 + 0.76544935614724 + 0.76550002454435 + 0.76555720224550 + 0.76562213399889 + 0.76569624553451 + 0.76578130106155 + 0.76587950296411 + 0.76599368131915 + 0.76612793772912 + 0.76628924826164 + 0.76648735387933 + 0.76673333074689 + 0.76704071422753 + 0.76742745131378 + 0.76791696232520 + 0.76854043408535 + 0.76933998533923 + 0.77037333554260 + 0.77172112092167 + 0.77349921943302 + 0.77588267737302 + 0.77915536362826 + 0.78379394172097 + 0.79064743058917 + 0.80146258679730 + 0.80953713076084 + 0.82081116842592 + 0.83791912718357 + 0.86856350751466 + 1.00000000000000 + 0.86232286155958 + 0.82448795346545 + 0.80057160230817 + 0.78281756464277 + 0.76845786148678 + 0.75609706257850 + 0.74475316823235 + 0.73390999076166 + 0.72333259282031 + 0.71285992124855 + 0.70240748687235 + 0.69192247054362 + 0.68137210254672 + 0.67073663493620 + 0.66000537128745 + 0.64917279775867 + 0.63820556540149 + 0.62710559369751 + 0.61588192365858 + 0.60455172845715 + 0.59314111640632 + 0.58168518471098 + 0.57020947446060 + 0.55873974861017 + 0.54731687068157 + 0.53597680103660 + 0.52474525489345 + 0.75853716997976 + 0.75853718167662 + 0.75853718361455 + 0.75853718587305 + 0.75853718850595 + 0.75853719157496 + 0.75853719515298 + 0.75853719932300 + 0.75853720418870 + 0.75853720988269 + 0.75853721661935 + 0.75853722473580 + 0.75853723464012 + 0.75853724677656 + 0.75853726166629 + 0.75853727994104 + 0.75853730237439 + 0.75853732991808 + 0.75853736378649 + 0.75853740555286 + 0.75853745708737 + 0.75853752071231 + 0.75853759930827 + 0.75853769645263 + 0.75853781664870 + 0.75853796589367 + 0.75853815283624 + 0.75853838893725 + 0.75853868797589 + 0.75853906689758 + 0.75853954887840 + 0.75854016297107 + 0.75854094596265 + 0.75854194491649 + 0.75854322001686 + 0.75854484818757 + 0.75854692769018 + 0.75854958396124 + 0.75855298265337 + 0.75855734359907 + 0.75856294471852 + 0.75857014555841 + 0.75857940871398 + 0.75859128959490 + 0.75860619590922 + 0.75862420410705 + 0.75864561638525 + 0.75867070222830 + 0.75869904808479 + 0.75873040709064 + 0.75876505787647 + 0.75880346535423 + 0.75884620559984 + 0.75889397821678 + 0.75894772275306 + 0.75900854863367 + 0.75907771333796 + 0.75915676477636 + 0.75924762580566 + 0.75935276027813 + 0.75947576250726 + 0.75962283783416 + 0.75980264846943 + 0.76002491193027 + 0.76030138804323 + 0.76064759911071 + 0.76108366590340 + 0.76163620513667 + 0.76234089566204 + 0.76324619307030 + 0.76441904243774 + 0.76595433152437 + 0.76799313923974 + 0.77076015399150 + 0.77462133670771 + 0.78019653339607 + 0.78866918368729 + 0.79472350691466 + 0.80276995135193 + 0.81403379840931 + 0.83121587321189 + 0.86232286155958 + 1.00000000000000 + 0.85596539306000 + 0.81775819911252 + 0.79392045364852 + 0.77630752209713 + 0.76197426550934 + 0.74931410021286 + 0.73753180255932 + 0.72625382461054 + 0.71524027326325 + 0.70436052962594 + 0.69353255462880 + 0.68270398592361 + 0.67184117972118 + 0.66092310722050 + 0.64993628969481 + 0.63884081766976 + 0.62763380715237 + 0.61632047938426 + 0.60491496841297 + 0.59344097052912 + 0.58193167738358 + 0.57041107630763 + 0.55890371312105 + 0.54744951905037 + 0.53608366054263 + 0.52483113307879 + 0.75200741690213 + 0.75200742784475 + 0.75200742965747 + 0.75200743177071 + 0.75200743423430 + 0.75200743710553 + 0.75200744045162 + 0.75200744435364 + 0.75200744890587 + 0.75200745423341 + 0.75200746053805 + 0.75200746814130 + 0.75200747742947 + 0.75200748882520 + 0.75200750282157 + 0.75200752001916 + 0.75200754115293 + 0.75200756712556 + 0.75200759909690 + 0.75200763856026 + 0.75200768729950 + 0.75200774752801 + 0.75200782198998 + 0.75200791410224 + 0.75200802815912 + 0.75200816989084 + 0.75200834756953 + 0.75200857216402 + 0.75200885686102 + 0.75200921788274 + 0.75200967742440 + 0.75201026331578 + 0.75201101079796 + 0.75201196495952 + 0.75201318346326 + 0.75201474000649 + 0.75201672872389 + 0.75201926976492 + 0.75202252179744 + 0.75202669538196 + 0.75203205660182 + 0.75203894958754 + 0.75204781689739 + 0.75205918938667 + 0.75207345448992 + 0.75209067952682 + 0.75211114705944 + 0.75213510578699 + 0.75216214558486 + 0.75219201384549 + 0.75222495854038 + 0.75226140074879 + 0.75230186069885 + 0.75234696732484 + 0.75239756635659 + 0.75245464930711 + 0.75251932806748 + 0.75259296418255 + 0.75267724070231 + 0.75277430833577 + 0.75288732703075 + 0.75302183669945 + 0.75318556825992 + 0.75338707730370 + 0.75363661627279 + 0.75394765883978 + 0.75433755659527 + 0.75482911941859 + 0.75545271031919 + 0.75624922421598 + 0.75727459100796 + 0.75860711308157 + 0.76036161723607 + 0.76271827749454 + 0.76596302561232 + 0.77055957641902 + 0.77734001222504 + 0.78202807305449 + 0.78804739607014 + 0.79605276883645 + 0.80728111906480 + 0.82448795346545 + 0.85596539306000 + 1.00000000000000 + 0.84951044217617 + 0.81104805120297 + 0.78733217136566 + 0.76976563597819 + 0.75513189949618 + 0.74202876747731 + 0.72981085431785 + 0.71809670589630 + 0.70667788458323 + 0.69542586010704 + 0.68425867183433 + 0.67312261604116 + 0.66198231317936 + 0.65081357471986 + 0.63956794584839 + 0.62823637434107 + 0.61681926201553 + 0.60532696338970 + 0.59378021013747 + 0.58220987410379 + 0.57063807021280 + 0.55908788781445 + 0.54759814811330 + 0.53620308060444 + 0.52492683928621 + 0.74552599568715 + 0.74552600593117 + 0.74552600762846 + 0.74552600960678 + 0.74552601191279 + 0.74552601460023 + 0.74552601773337 + 0.74552602138574 + 0.74552602564658 + 0.74552603063479 + 0.74552603653918 + 0.74552604366609 + 0.74552605238276 + 0.74552606308943 + 0.74552607625458 + 0.74552609244941 + 0.74552611237185 + 0.74552613688060 + 0.74552616707999 + 0.74552620439155 + 0.74552625051584 + 0.74552630756389 + 0.74552637815368 + 0.74552646554478 + 0.74552657384004 + 0.74552670851315 + 0.74552687747835 + 0.74552709124279 + 0.74552736242858 + 0.74552770656854 + 0.74552814493171 + 0.74552870418292 + 0.74552941809615 + 0.74553032988517 + 0.74553149481699 + 0.74553298352966 + 0.74553488623522 + 0.74553731807224 + 0.74554043108142 + 0.74554442702176 + 0.74554956076418 + 0.74555616182874 + 0.74556465381357 + 0.74557554435543 + 0.74558920193257 + 0.74560568575644 + 0.74562526040755 + 0.74564815578169 + 0.74567396648567 + 0.74570243623930 + 0.74573378607893 + 0.74576839830006 + 0.74580674390658 + 0.74584938981458 + 0.74589709948920 + 0.74595076166256 + 0.74601136222934 + 0.74608010220662 + 0.74615845900033 + 0.74624831570041 + 0.74635246035270 + 0.74647585777916 + 0.74662543397798 + 0.74680875022169 + 0.74703477869204 + 0.74731526115411 + 0.74766522332695 + 0.74810430036587 + 0.74865845962083 + 0.74936240947042 + 0.75026318447020 + 0.75142591180071 + 0.75294497102112 + 0.75496666695985 + 0.75771810173784 + 0.76155394957446 + 0.76707815133877 + 0.77080133793754 + 0.77546179500757 + 0.78144315860845 + 0.78939890986497 + 0.80057160230817 + 0.81775819911252 + 0.84951044217617 + 1.00000000000000 + 0.84297875267180 + 0.80436823826504 + 0.78069348456178 + 0.76282385124566 + 0.74774787725261 + 0.73421520302811 + 0.72156642068870 + 0.70945285764358 + 0.69766814238621 + 0.68608377754086 + 0.67461617343920 + 0.66320951154240 + 0.65182490718794 + 0.64040258720352 + 0.62892546918441 + 0.61738780499210 + 0.60579520458101 + 0.59416472740336 + 0.58252440285719 + 0.57089407717049 + 0.55929508878680 + 0.54776493211657 + 0.53633672720154 + 0.52503364137650 + 0.73908049454238 + 0.73908050414130 + 0.73908050573172 + 0.73908050758514 + 0.73908050974615 + 0.73908051226455 + 0.73908051519999 + 0.73908051862290 + 0.73908052261525 + 0.73908052728906 + 0.73908053282481 + 0.73908053951196 + 0.73908054769957 + 0.73908055776766 + 0.73908057016257 + 0.73908058542544 + 0.73908060422067 + 0.73908062736622 + 0.73908065591243 + 0.73908069121630 + 0.73908073489856 + 0.73908078897151 + 0.73908085593507 + 0.73908093890111 + 0.73908104178820 + 0.73908116982966 + 0.73908133060434 + 0.73908153416988 + 0.73908179262018 + 0.73908212083089 + 0.73908253918563 + 0.73908307324464 + 0.73908375538308 + 0.73908462703078 + 0.73908574117453 + 0.73908716553736 + 0.73908898660483 + 0.73909131473877 + 0.73909429568076 + 0.73909812281802 + 0.73910304035499 + 0.73910936393513 + 0.73911749914534 + 0.73912793161983 + 0.73914101204012 + 0.73915679241695 + 0.73917552082145 + 0.73919741010432 + 0.73922206071688 + 0.73924921451959 + 0.73927906884600 + 0.73931197162258 + 0.73934835037819 + 0.73938871749998 + 0.73943376418954 + 0.73948428942732 + 0.73954116994851 + 0.73960546835909 + 0.73967848555912 + 0.73976187575245 + 0.73985810812964 + 0.73997164934009 + 0.74010872796319 + 0.74027605273045 + 0.74048150658298 + 0.74073536438759 + 0.74105069436661 + 0.74144447781831 + 0.74193903683302 + 0.74256399937633 + 0.74335918338934 + 0.74437918694115 + 0.74570233510012 + 0.74744887373875 + 0.74980198918408 + 0.75303854784886 + 0.75760945969100 + 0.76062864836436 + 0.76433555377361 + 0.76897102613115 + 0.77491517674424 + 0.78281756464277 + 0.79392045364852 + 0.81104805120297 + 0.84297875267180 + 1.00000000000000 + 0.83638005564248 + 0.79758471119121 + 0.77358174871988 + 0.75528116191680 + 0.73979665838014 + 0.72584952789859 + 0.71281495353271 + 0.70034731509617 + 0.68824114967222 + 0.67636657188444 + 0.66463775452032 + 0.65299515387938 + 0.64136370786670 + 0.62971571131537 + 0.61803746430336 + 0.60632855578834 + 0.59460145543650 + 0.58288068367658 + 0.57118332056965 + 0.55952858851122 + 0.54795238887088 + 0.53648652294896 + 0.52515299739748 + 0.73265377602074 + 0.73265378502552 + 0.73265378651732 + 0.73265378825594 + 0.73265379028274 + 0.73265379264527 + 0.73265379539922 + 0.73265379861003 + 0.73265380235564 + 0.73265380674073 + 0.73265381193605 + 0.73265381821683 + 0.73265382591552 + 0.73265383539346 + 0.73265384707450 + 0.73265386147298 + 0.73265387922240 + 0.73265390109917 + 0.73265392810595 + 0.73265396153613 + 0.73265400293540 + 0.73265405422588 + 0.73265411779303 + 0.73265419660763 + 0.73265429441727 + 0.73265441622574 + 0.73265456928860 + 0.73265476323829 + 0.73265500966241 + 0.73265532281235 + 0.73265572222789 + 0.73265623241035 + 0.73265688440311 + 0.73265771792848 + 0.73265878379387 + 0.73266014693830 + 0.73266189028689 + 0.73266411964340 + 0.73266697472626 + 0.73267064092710 + 0.73267535227309 + 0.73268141116142 + 0.73268920600842 + 0.73269920150078 + 0.73271173155221 + 0.73272684176445 + 0.73274476499464 + 0.73276569858467 + 0.73278924981143 + 0.73281516023815 + 0.73284360630113 + 0.73287490536379 + 0.73290944643045 + 0.73294769379275 + 0.73299027495105 + 0.73303791025729 + 0.73309138160762 + 0.73315163193578 + 0.73321981026163 + 0.73329737450999 + 0.73338651962499 + 0.73349127890687 + 0.73361727410025 + 0.73377048018217 + 0.73395785008023 + 0.73418841161163 + 0.73447357914036 + 0.73482810621209 + 0.73527127783649 + 0.73582852759594 + 0.73653378203903 + 0.73743316143360 + 0.73859226751905 + 0.74011105446527 + 0.74213941504816 + 0.74489756287912 + 0.74873082434766 + 0.75122232693937 + 0.75423591456773 + 0.75793150919631 + 0.76254695466650 + 0.76845786148678 + 0.77630752209713 + 0.78733217136566 + 0.80436823826504 + 0.83638005564248 + 1.00000000000000 + 0.82952692651092 + 0.79018398716823 + 0.76577478470398 + 0.74711832864277 + 0.73125867140919 + 0.71695413444264 + 0.70358664151544 + 0.69081468781057 + 0.67843299503583 + 0.66630996783275 + 0.65435614754907 + 0.64247532111473 + 0.63062545745243 + 0.61878241086314 + 0.60693802858566 + 0.59509898066970 + 0.58328541589245 + 0.57151101530059 + 0.55979242688201 + 0.54816362833643 + 0.53665484567907 + 0.52528671430870 + 0.72617828831957 + 0.72617829677425 + 0.72617829817472 + 0.72617829980732 + 0.72617830171075 + 0.72617830392851 + 0.72617830651400 + 0.72617830952869 + 0.72617831304511 + 0.72617831716241 + 0.72617832204288 + 0.72617832794744 + 0.72617833519196 + 0.72617834412026 + 0.72617835513530 + 0.72617836872669 + 0.72617838549681 + 0.72617840618454 + 0.72617843174622 + 0.72617846341424 + 0.72617850266401 + 0.72617855132758 + 0.72617861168426 + 0.72617868657144 + 0.72617877956819 + 0.72617889545805 + 0.72617904118621 + 0.72617922597961 + 0.72617946093015 + 0.72617975968927 + 0.72618014097579 + 0.72618062827627 + 0.72618125133604 + 0.72618204822939 + 0.72618306765460 + 0.72618437185224 + 0.72618604030114 + 0.72618817439115 + 0.72619090801241 + 0.72619441881187 + 0.72619893096791 + 0.72620473406667 + 0.72621219991800 + 0.72622177298905 + 0.72623377116508 + 0.72624823430243 + 0.72626538103979 + 0.72628539442499 + 0.72630788952863 + 0.72633260900608 + 0.72635971068451 + 0.72638948442254 + 0.72642228469138 + 0.72645853286511 + 0.72649879963627 + 0.72654373569489 + 0.72659403966084 + 0.72665054992368 + 0.72671428348559 + 0.72678652825280 + 0.72686924071091 + 0.72696607254281 + 0.72708211088948 + 0.72722269184622 + 0.72739396533751 + 0.72760388702447 + 0.72786245809502 + 0.72818254040507 + 0.72858085838180 + 0.72907933951026 + 0.72970703705165 + 0.73050314717717 + 0.73152302722346 + 0.73285053965158 + 0.73460979766183 + 0.73697873253367 + 0.74022756672034 + 0.74231192507136 + 0.74480358817880 + 0.74781375800323 + 0.75150015576119 + 0.75609706257850 + 0.76197426550934 + 0.76976563597819 + 0.78069348456178 + 0.79758471119121 + 0.82952692651092 + 1.00000000000000 + 0.82186068016789 + 0.78201792386703 + 0.75734342287487 + 0.73838203467464 + 0.72221043140769 + 0.70760206895586 + 0.69395080157280 + 0.68091942234481 + 0.66830257496420 + 0.65596554722634 + 0.64378178398673 + 0.63168933506609 + 0.61964996468429 + 0.60764533126874 + 0.59567462269337 + 0.58375243796031 + 0.57188820832376 + 0.56009539854009 + 0.54840562787032 + 0.53684721310349 + 0.52543914679917 + 0.71945586406432 + 0.71945587199775 + 0.71945587331211 + 0.71945587484429 + 0.71945587662972 + 0.71945587871106 + 0.71945588113714 + 0.71945588396575 + 0.71945588726585 + 0.71945589112956 + 0.71945589571060 + 0.71945590125721 + 0.71945590806942 + 0.71945591647345 + 0.71945592685174 + 0.71945593966949 + 0.71945595549791 + 0.71945597504153 + 0.71945599920772 + 0.71945602917116 + 0.71945606633665 + 0.71945611244921 + 0.71945616968148 + 0.71945624073764 + 0.71945632903197 + 0.71945643913014 + 0.71945657766506 + 0.71945675345557 + 0.71945697710267 + 0.71945726165477 + 0.71945762501539 + 0.71945808964411 + 0.71945868398797 + 0.71945944446765 + 0.71946041766489 + 0.71946166311066 + 0.71946325682283 + 0.71946529576000 + 0.71946790795687 + 0.71947126328070 + 0.71947557601855 + 0.71948112289211 + 0.71948825905396 + 0.71949740870348 + 0.71950887383699 + 0.71952268898046 + 0.71953905900332 + 0.71955815331553 + 0.71957959599838 + 0.71960313222581 + 0.71962890274200 + 0.71965717186791 + 0.71968826213021 + 0.71972255543436 + 0.71976057022330 + 0.71980289361424 + 0.71985014900424 + 0.71990308091311 + 0.71996258846096 + 0.72002980830740 + 0.72010648372670 + 0.72019591985999 + 0.72030271808970 + 0.72043164174082 + 0.72058812761227 + 0.72077918343408 + 0.72101356899478 + 0.72130249490185 + 0.72166046617696 + 0.72210639656478 + 0.72266519208998 + 0.72337022637903 + 0.72426835233034 + 0.72543024554319 + 0.72695934183078 + 0.72900079849258 + 0.73176912760667 + 0.73352624509108 + 0.73560697217484 + 0.73809133519687 + 0.74108855947239 + 0.74475316823235 + 0.74931410021286 + 0.75513189949618 + 0.76282385124566 + 0.77358174871988 + 0.79018398716823 + 0.82186068016789 + 1.00000000000000 + 0.81369042053892 + 0.77349387180097 + 0.74856139698039 + 0.72931795079074 + 0.71285292984457 + 0.69796271378083 + 0.68405179201274 + 0.67078494927093 + 0.65795386304396 + 0.64538563130708 + 0.63298902922546 + 0.62070583024529 + 0.60850364134186 + 0.59637156503695 + 0.58431685599950 + 0.57234341422510 + 0.56046061185188 + 0.54869706505986 + 0.53707868846709 + 0.52562243184825 + 0.71238127760853 + 0.71238128504211 + 0.71238128627328 + 0.71238128770864 + 0.71238128938201 + 0.71238129133206 + 0.71238129360466 + 0.71238129625503 + 0.71238129934672 + 0.71238130296781 + 0.71238130726159 + 0.71238131246443 + 0.71238131885968 + 0.71238132675711 + 0.71238133651794 + 0.71238134858329 + 0.71238136349466 + 0.71238138191983 + 0.71238140472083 + 0.71238143301342 + 0.71238146812965 + 0.71238151173070 + 0.71238156587704 + 0.71238163314283 + 0.71238171677513 + 0.71238182111885 + 0.71238195249029 + 0.71238211929631 + 0.71238233163803 + 0.71238260195150 + 0.71238294730523 + 0.71238338911510 + 0.71238395450919 + 0.71238467821867 + 0.71238560466608 + 0.71238679061955 + 0.71238830855933 + 0.71239025092524 + 0.71239273977510 + 0.71239593703163 + 0.71240004688639 + 0.71240533293621 + 0.71241213333998 + 0.71242085166053 + 0.71243177386852 + 0.71244492949708 + 0.71246050986183 + 0.71247867114811 + 0.71249904780981 + 0.71252138895046 + 0.71254581944278 + 0.71257257954674 + 0.71260196181576 + 0.71263431132475 + 0.71267009776983 + 0.71270984941994 + 0.71275412082991 + 0.71280357113481 + 0.71285899285424 + 0.71292138637271 + 0.71299230164985 + 0.71307472425217 + 0.71317280736029 + 0.71329079336709 + 0.71343347694136 + 0.71360701605612 + 0.71381906486268 + 0.71407937235148 + 0.71440049222198 + 0.71479870912657 + 0.71529534449148 + 0.71591879361168 + 0.71670871964912 + 0.71772476899910 + 0.71905340676575 + 0.72081371317937 + 0.72317758970451 + 0.72466447546050 + 0.72641159794577 + 0.72847806213998 + 0.73094206354044 + 0.73390999076166 + 0.73753180255932 + 0.74202876747731 + 0.74774787725261 + 0.75528116191680 + 0.76577478470398 + 0.78201792386703 + 0.81369042053892 + 1.00000000000000 + 0.80533543596695 + 0.76477679123205 + 0.73958205408412 + 0.72004505685607 + 0.70328574288256 + 0.68812202857737 + 0.67396413563662 + 0.66047388586033 + 0.64740286593969 + 0.63461446763481 + 0.62202077557694 + 0.60956922875218 + 0.59723484502390 + 0.58501484465173 + 0.57290571560449 + 0.56091142422893 + 0.54905666515836 + 0.53736425833588 + 0.52584855631289 + 0.70494010764348 + 0.70494011459712 + 0.70494011574935 + 0.70494011709182 + 0.70494011865689 + 0.70494012048123 + 0.70494012260747 + 0.70494012508631 + 0.70494012797866 + 0.70494013136560 + 0.70494013538411 + 0.70494014025563 + 0.70494014624845 + 0.70494015365450 + 0.70494016281647 + 0.70494017414971 + 0.70494018816770 + 0.70494020549964 + 0.70494022696371 + 0.70494025361424 + 0.70494028671423 + 0.70494032783455 + 0.70494037893178 + 0.70494044244433 + 0.70494052144903 + 0.70494062007147 + 0.70494074430836 + 0.70494090214252 + 0.70494110317034 + 0.70494135920752 + 0.70494168647269 + 0.70494210532011 + 0.70494264153420 + 0.70494332812584 + 0.70494420731501 + 0.70494533305727 + 0.70494677423220 + 0.70494861866815 + 0.70495098233393 + 0.70495401905328 + 0.70495792273545 + 0.70496294360603 + 0.70496940253192 + 0.70497768209347 + 0.70498805213305 + 0.70500053752718 + 0.70501531626047 + 0.70503253172619 + 0.70505183003046 + 0.70507296556138 + 0.70509604846670 + 0.70512129634646 + 0.70514897364269 + 0.70517939108349 + 0.70521297288163 + 0.70525019285648 + 0.70529154258321 + 0.70533760357819 + 0.70538907199699 + 0.70544682547431 + 0.70551223858594 + 0.70558800185357 + 0.70567785455850 + 0.70578556505640 + 0.70591534962553 + 0.70607260413280 + 0.70626399742351 + 0.70649798357684 + 0.70678539835278 + 0.70714022829847 + 0.70758068760875 + 0.70813089759935 + 0.70882440842277 + 0.70971157064068 + 0.71086477723520 + 0.71238207249280 + 0.71440215561029 + 0.71566296021636 + 0.71713484704607 + 0.71886237356919 + 0.72090302095283 + 0.72333259282031 + 0.72625382461054 + 0.72981085431785 + 0.73421520302811 + 0.73979665838014 + 0.74711832864277 + 0.75734342287487 + 0.77349387180097 + 0.80533543596695 + 1.00000000000000 + 0.79675934448684 + 0.75589072189642 + 0.73041981538364 + 0.71057865727349 + 0.69352758288274 + 0.67810046355478 + 0.66370608621676 + 0.64996379394893 + 0.63666263439958 + 0.62366862608698 + 0.61089921115673 + 0.59830915087889 + 0.58588161517257 + 0.57360295368386 + 0.56146986662895 + 0.54950184989251 + 0.53771768583826 + 0.52612839041446 + 0.69711669398278 + 0.69711670047388 + 0.69711670154940 + 0.69711670280275 + 0.69711670426322 + 0.69711670596605 + 0.69711670795121 + 0.69711671026474 + 0.69711671296507 + 0.69711671612730 + 0.69711671987955 + 0.69711672443078 + 0.69711673003381 + 0.69711673696419 + 0.69711674554301 + 0.69711675616220 + 0.69711676930572 + 0.69711678556754 + 0.69711680571750 + 0.69711683075219 + 0.69711686186304 + 0.69711690053232 + 0.69711694861138 + 0.69711700839987 + 0.69711708280697 + 0.69711717573323 + 0.69711729285230 + 0.69711744171983 + 0.69711763142065 + 0.69711787313493 + 0.69711818222468 + 0.69711857796403 + 0.69711908477089 + 0.69711973390599 + 0.69712056535366 + 0.69712163020401 + 0.69712299367414 + 0.69712473891062 + 0.69712697568073 + 0.69712984958262 + 0.69713354406299 + 0.69713829577402 + 0.69714440801603 + 0.69715224210712 + 0.69716205169037 + 0.69717385731067 + 0.69718782387334 + 0.69720408240411 + 0.69722229187184 + 0.69724221319218 + 0.69726394288860 + 0.69728767724192 + 0.69731365434536 + 0.69734215291722 + 0.69737355475658 + 0.69740828331940 + 0.69744677264072 + 0.69748953373845 + 0.69753717576765 + 0.69759046587717 + 0.69765061954504 + 0.69772005476686 + 0.69780212853289 + 0.69790017793811 + 0.69801789854390 + 0.69816000303281 + 0.69833228252038 + 0.69854204407120 + 0.69879861071308 + 0.69911395878691 + 0.69950360510546 + 0.69998799246478 + 0.70059545295379 + 0.70136845729705 + 0.70236763611487 + 0.70367387311670 + 0.70539958720620 + 0.70646936605301 + 0.70771133755753 + 0.70915961818783 + 0.71085732653368 + 0.71285992124855 + 0.71524027326325 + 0.71809670589630 + 0.72156642068870 + 0.72584952789859 + 0.73125867140919 + 0.73838203467464 + 0.74856139698039 + 0.76477679123205 + 0.79675934448684 + 1.00000000000000 + 0.78805110469368 + 0.74687868034707 + 0.72110322512812 + 0.70094586894901 + 0.68360581049561 + 0.66792176330676 + 0.65325724416621 + 0.63927034647207 + 0.62575148322011 + 0.61257142918355 + 0.59965472186322 + 0.58696424796291 + 0.57447213086621 + 0.56216508912384 + 0.55005559545422 + 0.53815707944383 + 0.52647621299510 + 0.68891981361283 + 0.68891981965707 + 0.68891982065853 + 0.68891982182588 + 0.68891982318608 + 0.68891982477192 + 0.68891982662014 + 0.68891982877527 + 0.68891983128943 + 0.68891983423416 + 0.68891983772912 + 0.68891984197046 + 0.68891984719538 + 0.68891985366236 + 0.68891986167333 + 0.68891987159599 + 0.68891988388394 + 0.68891989909561 + 0.68891991795513 + 0.68891994139877 + 0.68891997054786 + 0.68892000679892 + 0.68892005188975 + 0.68892010798901 + 0.68892017783355 + 0.68892026509810 + 0.68892037513005 + 0.68892051505675 + 0.68892069344244 + 0.68892092082991 + 0.68892121171362 + 0.68892158427467 + 0.68892206154848 + 0.68892267303173 + 0.68892345644063 + 0.68892445997371 + 0.68892574514099 + 0.68892739035462 + 0.68892949912365 + 0.68893220871408 + 0.68893569202632 + 0.68894017199651 + 0.68894593421190 + 0.68895331857219 + 0.68896256255002 + 0.68897368270255 + 0.68898683115796 + 0.68900212705640 + 0.68901924326890 + 0.68903794836683 + 0.68905832632261 + 0.68908055343752 + 0.68910484321343 + 0.68913144465415 + 0.68916070015158 + 0.68919298677287 + 0.68922868619239 + 0.68926824568828 + 0.68931219620028 + 0.68936120585577 + 0.68941634629974 + 0.68947978459204 + 0.68955452582583 + 0.68964351623565 + 0.68974998448849 + 0.68987803333049 + 0.69003267513979 + 0.69022020493151 + 0.69044861852294 + 0.69072813949676 + 0.69107194907879 + 0.69149732930723 + 0.69202816007072 + 0.69270022526646 + 0.69356429369496 + 0.69468716753350 + 0.69616025841920 + 0.69706792905390 + 0.69811662621777 + 0.69933278779223 + 0.70074927022083 + 0.70240748687235 + 0.70436052962594 + 0.70667788458323 + 0.70945285764358 + 0.71281495353271 + 0.71695413444264 + 0.72221043140769 + 0.72931795079074 + 0.73958205408412 + 0.75589072189642 + 0.78805110469368 + 1.00000000000000 + 0.77922366905700 + 0.73774174345725 + 0.71163550213952 + 0.69115644255466 + 0.67353103422607 + 0.65755218247202 + 0.64262403561827 + 0.62840387582499 + 0.61468583487164 + 0.60134737820102 + 0.58832107952753 + 0.57555852726987 + 0.56303240193809 + 0.55074549796033 + 0.53870403074812 + 0.52690894088239 + 0.68036371453171 + 0.68036372014392 + 0.68036372107357 + 0.68036372215754 + 0.68036372342091 + 0.68036372489319 + 0.68036372660936 + 0.68036372860983 + 0.68036373094473 + 0.68036373367911 + 0.68036373692519 + 0.68036374086642 + 0.68036374572453 + 0.68036375174037 + 0.68036375919709 + 0.68036376843813 + 0.68036377988912 + 0.68036379407182 + 0.68036381166380 + 0.68036383354283 + 0.68036386075884 + 0.68036389462146 + 0.68036393675938 + 0.68036398920692 + 0.68036405452983 + 0.68036413617830 + 0.68036423917270 + 0.68036437020574 + 0.68036453732187 + 0.68036475042529 + 0.68036502313553 + 0.68036537253507 + 0.68036582027486 + 0.68036639407030 + 0.68036712936393 + 0.68036807144671 + 0.68036927810643 + 0.68037082299736 + 0.68037280333759 + 0.68037534804897 + 0.68037861943068 + 0.68038282667612 + 0.68038823763371 + 0.68039517078279 + 0.68040384755863 + 0.68041428087053 + 0.68042661044800 + 0.68044094406802 + 0.68045696937482 + 0.68047446354646 + 0.68049349907227 + 0.68051423361545 + 0.68053685781638 + 0.68056159322812 + 0.68058874577756 + 0.68061864998038 + 0.68065164009237 + 0.68068810604075 + 0.68072850877756 + 0.68077342810707 + 0.68082380615796 + 0.68088157977721 + 0.68094943141824 + 0.68102995463077 + 0.68112596141016 + 0.68124101252319 + 0.68137943274643 + 0.68154662832958 + 0.68174943590048 + 0.68199655716362 + 0.68229915848320 + 0.68267181407081 + 0.68313461238250 + 0.68371766635747 + 0.68446346796127 + 0.68542722544484 + 0.68668344500371 + 0.68745328177204 + 0.68833894722088 + 0.68936112336431 + 0.69054515693877 + 0.69192247054362 + 0.69353255462880 + 0.69542586010704 + 0.69766814238621 + 0.70034731509617 + 0.70358664151544 + 0.70760206895586 + 0.71285292984457 + 0.72004505685607 + 0.73041981538364 + 0.74687868034707 + 0.77922366905700 + 1.00000000000000 + 0.77028952878162 + 0.72848184292640 + 0.70202333694556 + 0.68121964112547 + 0.66326478539235 + 0.64699680416323 + 0.63181518391868 + 0.61737905073842 + 0.60348849448907 + 0.59002881228130 + 0.57692091494833 + 0.56411717427056 + 0.55160672746062 + 0.53938587397189 + 0.52744787089827 + 0.67146676679530 + 0.67146677198881 + 0.67146677284871 + 0.67146677385200 + 0.67146677502030 + 0.67146677638308 + 0.67146677797056 + 0.67146677982277 + 0.67146678198298 + 0.67146678451347 + 0.67146678751779 + 0.67146679116676 + 0.67146679566748 + 0.67146680124393 + 0.67146680815888 + 0.67146681673460 + 0.67146682736520 + 0.67146684053833 + 0.67146685688578 + 0.67146687722644 + 0.67146690254099 + 0.67146693404882 + 0.67146697327532 + 0.67146702211667 + 0.67146708297194 + 0.67146715906282 + 0.67146725508611 + 0.67146737729928 + 0.67146753323105 + 0.67146773214650 + 0.67146798678745 + 0.67146831314624 + 0.67146873148336 + 0.67146926773746 + 0.67146995508304 + 0.67147083590242 + 0.67147196427196 + 0.67147340909943 + 0.67147526133337 + 0.67147764156287 + 0.67148070153638 + 0.67148463676971 + 0.67148969746123 + 0.67149618082789 + 0.67150429251097 + 0.67151404211475 + 0.67152555739879 + 0.67153893535168 + 0.67155387906079 + 0.67157017511465 + 0.67158788554937 + 0.67160715071870 + 0.67162814012520 + 0.67165105005613 + 0.67167615285632 + 0.67170374416853 + 0.67173411552286 + 0.67176760547341 + 0.67180461267502 + 0.67184563850184 + 0.67189150893701 + 0.67194395042090 + 0.67200535081747 + 0.67207798683231 + 0.67216430041208 + 0.67226737305520 + 0.67239092541218 + 0.67253958707683 + 0.67271918708764 + 0.67293711175538 + 0.67320279651495 + 0.67352850407484 + 0.67393110289483 + 0.67443590407260 + 0.67507845447167 + 0.67590440032910 + 0.67697458246133 + 0.67762717186018 + 0.67837509677469 + 0.67923466111985 + 0.68022561360001 + 0.68137210254672 + 0.68270398592361 + 0.68425867183433 + 0.68608377754086 + 0.68824114967222 + 0.69081468781057 + 0.69395080157280 + 0.69796271378083 + 0.70328574288256 + 0.71057865727349 + 0.72110322512812 + 0.73774174345725 + 0.77028952878162 + 1.00000000000000 + 0.76126064728386 + 0.71910261364863 + 0.69227299741361 + 0.67108968809153 + 0.65281052743636 + 0.63626244802029 + 0.62084322287179 + 0.60621656528799 + 0.59218997908444 + 0.57863656343330 + 0.56547828523316 + 0.55268445440016 + 0.54023741633124 + 0.52811992788202 + 0.66225033229122 + 0.66225033707823 + 0.66225033787151 + 0.66225033879601 + 0.66225033987287 + 0.66225034112892 + 0.66225034259244 + 0.66225034429900 + 0.66225034628982 + 0.66225034862214 + 0.66225035139199 + 0.66225035475743 + 0.66225035890991 + 0.66225036405780 + 0.66225037044516 + 0.66225037836942 + 0.66225038819830 + 0.66225040038308 + 0.66225041551051 + 0.66225043434236 + 0.66225045778826 + 0.66225048698495 + 0.66225052334475 + 0.66225056863596 + 0.66225062508811 + 0.66225069569988 + 0.66225078484366 + 0.66225089834869 + 0.66225104322774 + 0.66225122810857 + 0.66225146487134 + 0.66225176841667 + 0.66225215762714 + 0.66225265668398 + 0.66225329650502 + 0.66225411658851 + 0.66225516733247 + 0.66225651293871 + 0.66225823814534 + 0.66226045529030 + 0.66226330568492 + 0.66226697132116 + 0.66227168497068 + 0.66227772288432 + 0.66228527525490 + 0.66229434871637 + 0.66230505955511 + 0.66231749457346 + 0.66233137278894 + 0.66234649083803 + 0.66236290129824 + 0.66238072853575 + 0.66240012257988 + 0.66242125659475 + 0.66244437210275 + 0.66246972940427 + 0.66249758169501 + 0.66252822173963 + 0.66256199297974 + 0.66259932746385 + 0.66264094740276 + 0.66268838763104 + 0.66274376805278 + 0.66280908192999 + 0.66288644401603 + 0.66297851393385 + 0.66308848399996 + 0.66322030826358 + 0.66337894394125 + 0.66357064538260 + 0.66380336705455 + 0.66408740554672 + 0.66443690237887 + 0.66487311021526 + 0.66542575237805 + 0.66613258200776 + 0.66704335872961 + 0.66759623247674 + 0.66822770580514 + 0.66895071419793 + 0.66978077244006 + 0.67073663493620 + 0.67184117972118 + 0.67312261604116 + 0.67461617343920 + 0.67636657188444 + 0.67843299503583 + 0.68091942234481 + 0.68405179201274 + 0.68812202857737 + 0.69352758288274 + 0.70094586894901 + 0.71163550213952 + 0.72848184292640 + 0.76126064728386 + 1.00000000000000 + 0.75214838074741 + 0.70960515374871 + 0.68232575502092 + 0.66076786194235 + 0.64217282605451 + 0.62535905179298 + 0.60972620780948 + 0.59494460206226 + 0.58080874653820 + 0.56719312962785 + 0.55403727153025 + 0.54130331863483 + 0.52895934329594 + 0.65273801837462 + 0.65273802276703 + 0.65273802349491 + 0.65273802434310 + 0.65273802533157 + 0.65273802648422 + 0.65273802782725 + 0.65273802939323 + 0.65273803121998 + 0.65273803336027 + 0.65273803590234 + 0.65273803899223 + 0.65273804280727 + 0.65273804753886 + 0.65273805341187 + 0.65273806070248 + 0.65273806974817 + 0.65273808096757 + 0.65273809490389 + 0.65273811225999 + 0.65273813387752 + 0.65273816080836 + 0.65273819436055 + 0.65273823616937 + 0.65273828830222 + 0.65273835353484 + 0.65273843592078 + 0.65273854086719 + 0.65273867487444 + 0.65273884594928 + 0.65273906511147 + 0.65273934619262 + 0.65273970671571 + 0.65274016912091 + 0.65274076210714 + 0.65274152233624 + 0.65274249657229 + 0.65274374438980 + 0.65274534441441 + 0.65274740086870 + 0.65275004480398 + 0.65275344493539 + 0.65275781693747 + 0.65276341653411 + 0.65277041889821 + 0.65277882803123 + 0.65278874928088 + 0.65280025989195 + 0.65281309512808 + 0.65282706215346 + 0.65284220505116 + 0.65285863347727 + 0.65287647961915 + 0.65289589555937 + 0.65291709465761 + 0.65294030520500 + 0.65296574615535 + 0.65299366963400 + 0.65302437035266 + 0.65305821933211 + 0.65309584636177 + 0.65313861234609 + 0.65318839428951 + 0.65324693278665 + 0.65331605443841 + 0.65339804893097 + 0.65349564838365 + 0.65361222159691 + 0.65375197439245 + 0.65392019068447 + 0.65412356230046 + 0.65437071869193 + 0.65467349767214 + 0.65504972719958 + 0.65552425040300 + 0.65612830027080 + 0.65690262695115 + 0.65737071586737 + 0.65790369169093 + 0.65851187349416 + 0.65920753519093 + 0.66000537128745 + 0.66092310722050 + 0.66198231317936 + 0.66320951154240 + 0.66463775452032 + 0.66630996783275 + 0.66830257496420 + 0.67078494927093 + 0.67396413563662 + 0.67810046355478 + 0.68360581049561 + 0.69115644255466 + 0.70202333694556 + 0.71910261364863 + 0.75214838074741 + 1.00000000000000 + 0.74295515045733 + 0.69990422666478 + 0.67217905454532 + 0.65025599293710 + 0.63135848677096 + 0.61430137344627 + 0.59848931880110 + 0.58357846060518 + 0.56936512691085 + 0.55574216044140 + 0.54264145318888 + 0.53000996253551 + 0.64295365234961 + 0.64295365636102 + 0.64295365702520 + 0.64295365780008 + 0.64295365870299 + 0.64295365975478 + 0.64295366098148 + 0.64295366241129 + 0.64295366407994 + 0.64295366603439 + 0.64295366835648 + 0.64295367117990 + 0.64295367466733 + 0.64295367899450 + 0.64295368436960 + 0.64295369104393 + 0.64295369932989 + 0.64295370961186 + 0.64295372238827 + 0.64295373830696 + 0.64295375814425 + 0.64295378286617 + 0.64295381367963 + 0.64295385209194 + 0.64295390000623 + 0.64295395998391 + 0.64295403576656 + 0.64295413234579 + 0.64295425572134 + 0.64295441328574 + 0.64295461522444 + 0.64295487431253 + 0.64295520674357 + 0.64295563325540 + 0.64295618036705 + 0.64295688196103 + 0.64295778125341 + 0.64295893328976 + 0.64296041071509 + 0.64296230982232 + 0.64296475164064 + 0.64296789193347 + 0.64297192971448 + 0.64297710072771 + 0.64298356564250 + 0.64299132614518 + 0.64300047722402 + 0.64301108721390 + 0.64302290776402 + 0.64303575691402 + 0.64304967115394 + 0.64306474668511 + 0.64308109941154 + 0.64309886227964 + 0.64311822301251 + 0.64313938102043 + 0.64316252478906 + 0.64318787050801 + 0.64321567004629 + 0.64324624086733 + 0.64328013066987 + 0.64331854287771 + 0.64336313491797 + 0.64341542279095 + 0.64347698007877 + 0.64354977304163 + 0.64363613417165 + 0.64373892676785 + 0.64386171094197 + 0.64400894098893 + 0.64418623500188 + 0.64440081195364 + 0.64466256668580 + 0.64498643964325 + 0.64539318423913 + 0.64590864126323 + 0.64656621524645 + 0.64696219890588 + 0.64741179782244 + 0.64792328103324 + 0.64850641494392 + 0.64917279775867 + 0.64993628969481 + 0.65081357471986 + 0.65182490718794 + 0.65299515387938 + 0.65435614754907 + 0.65596554722634 + 0.65795386304396 + 0.66047388586033 + 0.66370608621676 + 0.66792176330676 + 0.67353103422607 + 0.68121964112547 + 0.69227299741361 + 0.70960515374871 + 0.74295515045733 + 1.00000000000000 + 0.73354006839631 + 0.68999182455114 + 0.66183327664307 + 0.63955886384258 + 0.62037946587011 + 0.60311173050498 + 0.58714441408297 + 0.57213607026636 + 0.55790244945337 + 0.54432818439859 + 0.53132882402547 + 0.63289134418940 + 0.63289134783292 + 0.63289134843665 + 0.63289134913988 + 0.63289134995995 + 0.63289135091596 + 0.63289135202989 + 0.63289135332857 + 0.63289135484417 + 0.63289135661940 + 0.63289135872876 + 0.63289136129494 + 0.63289136446527 + 0.63289136840174 + 0.63289137329365 + 0.63289137937202 + 0.63289138692051 + 0.63289139629216 + 0.63289140794279 + 0.63289142246550 + 0.63289144057231 + 0.63289146314770 + 0.63289149129849 + 0.63289152640422 + 0.63289157021317 + 0.63289162507429 + 0.63289169442402 + 0.63289178284635 + 0.63289189585683 + 0.63289204024804 + 0.63289222538091 + 0.63289246300643 + 0.63289276801726 + 0.63289315948669 + 0.63289366181256 + 0.63289430615809 + 0.63289513227816 + 0.63289619080320 + 0.63289754854928 + 0.63289929408206 + 0.63290153867964 + 0.63290442549845 + 0.63290813737084 + 0.63291289065585 + 0.63291883205204 + 0.63292596124013 + 0.63293436341038 + 0.63294409861320 + 0.63295493493845 + 0.63296670153849 + 0.63297942815215 + 0.63299319868223 + 0.63300811420564 + 0.63302429031560 + 0.63304189141680 + 0.63306109087231 + 0.63308205009557 + 0.63310495351752 + 0.63313001535217 + 0.63315750608439 + 0.63318790044283 + 0.63322225917123 + 0.63326204107914 + 0.63330856241900 + 0.63336317450314 + 0.63342756069250 + 0.63350370627826 + 0.63359403774233 + 0.63370156001038 + 0.63383001765573 + 0.63398411492182 + 0.63416987608182 + 0.63439555452222 + 0.63467365022667 + 0.63502147847938 + 0.63546040237495 + 0.63601780436594 + 0.63635226658419 + 0.63673102539530 + 0.63716072653424 + 0.63764917229462 + 0.63820556540149 + 0.63884081766976 + 0.63956794584839 + 0.64040258720352 + 0.64136370786670 + 0.64247532111473 + 0.64378178398673 + 0.64538563130708 + 0.64740286593969 + 0.64996379394893 + 0.65325724416621 + 0.65755218247202 + 0.66326478539235 + 0.67108968809153 + 0.68232575502092 + 0.69990422666478 + 0.73354006839631 + 1.00000000000000 + 0.72400955938042 + 0.67992779935652 + 0.65133229063658 + 0.62871460125448 + 0.60927652962671 + 0.59181434083941 + 0.57571934115053 + 0.56067054797393 + 0.54647452619081 + 0.53299795281695 + 0.62257356916950 + 0.62257357246023 + 0.62257357300548 + 0.62257357364010 + 0.62257357438082 + 0.62257357524408 + 0.62257357625005 + 0.62257357742294 + 0.62257357879138 + 0.62257358039463 + 0.62257358230013 + 0.62257358461839 + 0.62257358748456 + 0.62257359104496 + 0.62257359547218 + 0.62257360097578 + 0.62257360781444 + 0.62257361630844 + 0.62257362687317 + 0.62257364004937 + 0.62257365648450 + 0.62257367698626 + 0.62257370256292 + 0.62257373447305 + 0.62257377431155 + 0.62257382422335 + 0.62257388734533 + 0.62257396787034 + 0.62257407083881 + 0.62257420246461 + 0.62257437131078 + 0.62257458813015 + 0.62257486655439 + 0.62257522404168 + 0.62257568292966 + 0.62257627174917 + 0.62257702689929 + 0.62257799473175 + 0.62257923641801 + 0.62258083304406 + 0.62258288645447 + 0.62258552762825 + 0.62258892376312 + 0.62259327254451 + 0.62259870729090 + 0.62260522596224 + 0.62261290454939 + 0.62262179544106 + 0.62263168306728 + 0.62264240779587 + 0.62265399340697 + 0.62266651262215 + 0.62268005306386 + 0.62269471466055 + 0.62271064069143 + 0.62272798110654 + 0.62274687334077 + 0.62276747386147 + 0.62278996389158 + 0.62281457279969 + 0.62284171058357 + 0.62287230898630 + 0.62290764755057 + 0.62294886520401 + 0.62299711837368 + 0.62305384339324 + 0.62312072442692 + 0.62319981108636 + 0.62329363165119 + 0.62340532437061 + 0.62353881658393 + 0.62369912150582 + 0.62389310629794 + 0.62413120777155 + 0.62442784815082 + 0.62480066556697 + 0.62527209039087 + 0.62555401783715 + 0.62587251362487 + 0.62623292838856 + 0.62664151198719 + 0.62710559369751 + 0.62763380715237 + 0.62823637434107 + 0.62892546918441 + 0.62971571131537 + 0.63062545745243 + 0.63168933506609 + 0.63298902922546 + 0.63461446763481 + 0.63666263439958 + 0.63927034647207 + 0.64262403561827 + 0.64699680416323 + 0.65281052743636 + 0.66076786194235 + 0.67217905454532 + 0.68999182455114 + 0.72400955938042 + 1.00000000000000 + 0.71436575927646 + 0.66971927971795 + 0.64068613295073 + 0.61774056568006 + 0.59805252497930 + 0.58042005991278 + 0.56425590226034 + 0.54922835522019 + 0.53512382873399 + 0.61202671585284 + 0.61202671880633 + 0.61202671929559 + 0.61202671986605 + 0.61202672053053 + 0.61202672130548 + 0.61202672220816 + 0.61202672326102 + 0.61202672448940 + 0.61202672592858 + 0.61202672763919 + 0.61202672972112 + 0.61202673229675 + 0.61202673549879 + 0.61202673948182 + 0.61202674443530 + 0.61202675059430 + 0.61202675824853 + 0.61202676777356 + 0.61202677965873 + 0.61202679449138 + 0.61202681300308 + 0.61202683610947 + 0.61202686495117 + 0.61202690097699 + 0.61202694613304 + 0.61202700327236 + 0.61202707620437 + 0.61202716951716 + 0.61202728886263 + 0.61202744203786 + 0.61202763883201 + 0.61202789166117 + 0.61202821643292 + 0.61202863349339 + 0.61202916884405 + 0.61202985565161 + 0.61203073615531 + 0.61203186609657 + 0.61203331937091 + 0.61203518876150 + 0.61203759356092 + 0.61204068598332 + 0.61204464582638 + 0.61204959368765 + 0.61205552607887 + 0.61206251040009 + 0.61207059200146 + 0.61207957139018 + 0.61208930012410 + 0.61209979675694 + 0.61211112389092 + 0.61212335700699 + 0.61213658195415 + 0.61215092293208 + 0.61216650894124 + 0.61218345625045 + 0.61220189677977 + 0.61222198293576 + 0.61224390819756 + 0.61226802525621 + 0.61229514948248 + 0.61232639900020 + 0.61236275561507 + 0.61240520517421 + 0.61245496864201 + 0.61251346937362 + 0.61258243224997 + 0.61266397678703 + 0.61276072371792 + 0.61287594038761 + 0.61301378471738 + 0.61317995320714 + 0.61338313745691 + 0.61363532247000 + 0.61395104157411 + 0.61434864043191 + 0.61458566816503 + 0.61485283559269 + 0.61515445281144 + 0.61549553232646 + 0.61588192365858 + 0.61632047938426 + 0.61681926201553 + 0.61738780499210 + 0.61803746430336 + 0.61878241086314 + 0.61964996468429 + 0.62070583024529 + 0.62202077557694 + 0.62366862608698 + 0.62575148322011 + 0.62840387582499 + 0.63181518391868 + 0.63626244802029 + 0.64217282605451 + 0.65025599293710 + 0.66183327664307 + 0.67992779935652 + 0.71436575927646 + 1.00000000000000 + 0.70461157014101 + 0.65937455271387 + 0.62990780849837 + 0.60663093476822 + 0.58671100020588 + 0.56896765353495 + 0.55280027158749 + 0.53785389819752 + 0.60128245919334 + 0.60128246182793 + 0.60128246226436 + 0.60128246277287 + 0.60128246336589 + 0.60128246405716 + 0.60128246486219 + 0.60128246580121 + 0.60128246689717 + 0.60128246818098 + 0.60128246970704 + 0.60128247156565 + 0.60128247386623 + 0.60128247672718 + 0.60128248028890 + 0.60128248472133 + 0.60128249023468 + 0.60128249709016 + 0.60128250562628 + 0.60128251628401 + 0.60128252959208 + 0.60128254621144 + 0.60128256696461 + 0.60128259288393 + 0.60128262527573 + 0.60128266589815 + 0.60128271733117 + 0.60128278302178 + 0.60128286712183 + 0.60128297474716 + 0.60128311295944 + 0.60128329063255 + 0.60128351901729 + 0.60128381253490 + 0.60128418963613 + 0.60128467390196 + 0.60128529541533 + 0.60128609248323 + 0.60128711567314 + 0.60128843201848 + 0.60129012566562 + 0.60129230477914 + 0.60129510731358 + 0.60129869607395 + 0.60130317964716 + 0.60130855334734 + 0.60131487659890 + 0.60132218833535 + 0.60133030471858 + 0.60133908833482 + 0.60134855318810 + 0.60135875277636 + 0.60136975166481 + 0.60138162311026 + 0.60139447417082 + 0.60140841515921 + 0.60142354374309 + 0.60143997037540 + 0.60145782236579 + 0.60147726195492 + 0.60149859120952 + 0.60152252084026 + 0.60155002401429 + 0.60158194363934 + 0.60161911653358 + 0.60166257620401 + 0.60171352046478 + 0.60177339475169 + 0.60184396841652 + 0.60192742086663 + 0.60202645913721 + 0.60214451788971 + 0.60228630496137 + 0.60245903497908 + 0.60267263760627 + 0.60293905365626 + 0.60327325009958 + 0.60347188172398 + 0.60369529139767 + 0.60394694791744 + 0.60423087015726 + 0.60455172845715 + 0.60491496841297 + 0.60532696338970 + 0.60579520458101 + 0.60632855578834 + 0.60693802858566 + 0.60764533126874 + 0.60850364134186 + 0.60956922875218 + 0.61089921115673 + 0.61257142918355 + 0.61468583487164 + 0.61737905073842 + 0.62084322287179 + 0.62535905179298 + 0.63135848677096 + 0.63955886384258 + 0.65133229063658 + 0.66971927971795 + 0.70461157014101 + 1.00000000000000 + 0.69475120341667 + 0.64890327736651 + 0.61897959703179 + 0.59537873277996 + 0.57528577361944 + 0.55750186058744 + 0.54139850794504 + 0.59037889621860 + 0.59037889855313 + 0.59037889893982 + 0.59037889939065 + 0.59037889991627 + 0.59037890052874 + 0.59037890124252 + 0.59037890207493 + 0.59037890304612 + 0.59037890418412 + 0.59037890553678 + 0.59037890718545 + 0.59037890922668 + 0.59037891176722 + 0.59037891493224 + 0.59037891887294 + 0.59037892377862 + 0.59037892988166 + 0.59037893748584 + 0.59037894698554 + 0.59037895885601 + 0.59037897368724 + 0.59037899222046 + 0.59037901537937 + 0.59037904433880 + 0.59037908067811 + 0.59037912671692 + 0.59037918555969 + 0.59037926094424 + 0.59037935747897 + 0.59037948153012 + 0.59037964110155 + 0.59037984634050 + 0.59038011026029 + 0.59038044951556 + 0.59038088539224 + 0.59038144505560 + 0.59038216309401 + 0.59038308517484 + 0.59038427184275 + 0.59038579908375 + 0.59038776454863 + 0.59039029273912 + 0.59039353045524 + 0.59039757502811 + 0.59040242080260 + 0.59040811986042 + 0.59041470531986 + 0.59042200843204 + 0.59042990251506 + 0.59043839763921 + 0.59044753915683 + 0.59045738189295 + 0.59046798789443 + 0.59047944889141 + 0.59049185861586 + 0.59050529845860 + 0.59051986017415 + 0.59053564929942 + 0.59055280097945 + 0.59057157270233 + 0.59059258138909 + 0.59061667052626 + 0.59064456058780 + 0.59067695852203 + 0.59071473505778 + 0.59075889336001 + 0.59081063882115 + 0.59087144130898 + 0.59094310438920 + 0.59102785992358 + 0.59112853146121 + 0.59124899224015 + 0.59139520698765 + 0.59157537132183 + 0.59179925881558 + 0.59207903591744 + 0.59224483917689 + 0.59243094067737 + 0.59264012545290 + 0.59287560947531 + 0.59314111640632 + 0.59344097052912 + 0.59378021013747 + 0.59416472740336 + 0.59460145543650 + 0.59509898066970 + 0.59567462269337 + 0.59637156503695 + 0.59723484502390 + 0.59830915087889 + 0.59965472186322 + 0.60134737820102 + 0.60348849448907 + 0.60621656528799 + 0.60972620780948 + 0.61430137344627 + 0.62037946587011 + 0.62871460125448 + 0.64068613295073 + 0.65937455271387 + 0.69475120341667 + 1.00000000000000 + 0.68479047645074 + 0.63827058097081 + 0.60787909776329 + 0.58400997994613 + 0.56381815987117 + 0.54606960159257 + 0.57936092144629 + 0.57936092350246 + 0.57936092384315 + 0.57936092424031 + 0.57936092470323 + 0.57936092524251 + 0.57936092587116 + 0.57936092660405 + 0.57936092745899 + 0.57936092846121 + 0.57936092965328 + 0.57936093110587 + 0.57936093290629 + 0.57936093514822 + 0.57936093794344 + 0.57936094142631 + 0.57936094576470 + 0.57936095116602 + 0.57936095790048 + 0.57936096631921 + 0.57936097684505 + 0.57936099000636 + 0.57936100646270 + 0.57936102703999 + 0.57936105278755 + 0.57936108511633 + 0.57936112610650 + 0.57936117853462 + 0.57936124575383 + 0.57936133189600 + 0.57936144267317 + 0.57936158527026 + 0.57936176880124 + 0.57936200495710 + 0.57936230870704 + 0.57936269918638 + 0.57936320081676 + 0.57936384470415 + 0.57936467192125 + 0.57936573693306 + 0.57936710808076 + 0.57936887318144 + 0.57937114415886 + 0.57937405286168 + 0.57937768618524 + 0.57938203769989 + 0.57938715278678 + 0.57939305934040 + 0.57939960299624 + 0.57940666738532 + 0.57941425922250 + 0.57942241662093 + 0.57943118576183 + 0.57944061878967 + 0.57945079381192 + 0.57946178993942 + 0.57947367439805 + 0.57948652274278 + 0.57950042172489 + 0.57951548308217 + 0.57953192522060 + 0.57955028143402 + 0.57957127976791 + 0.57959553321373 + 0.57962363597800 + 0.57965631792599 + 0.57969441477095 + 0.57973892632019 + 0.57979106698148 + 0.57985232102404 + 0.57992451821988 + 0.58000996672335 + 0.58011183632915 + 0.58023503532173 + 0.58038629748540 + 0.58057358485939 + 0.58080674087226 + 0.58094451879655 + 0.58109885049582 + 0.58127196332097 + 0.58146642156834 + 0.58168518471098 + 0.58193167738358 + 0.58220987410379 + 0.58252440285719 + 0.58288068367658 + 0.58328541589245 + 0.58375243796031 + 0.58431685599950 + 0.58501484465173 + 0.58588161517257 + 0.58696424796291 + 0.58832107952753 + 0.59002881228130 + 0.59218997908444 + 0.59494460206226 + 0.59848931880110 + 0.60311173050498 + 0.60927652962671 + 0.61774056568006 + 0.62990780849837 + 0.64890327736651 + 0.68479047645074 + 1.00000000000000 + 0.67465728490784 + 0.62743021832894 + 0.59662040375027 + 0.57255926300827 + 0.55235421578454 + 0.56826250515447 + 0.56826250695384 + 0.56826250725177 + 0.56826250759887 + 0.56826250800388 + 0.56826250847608 + 0.56826250902617 + 0.56826250966735 + 0.56826251041584 + 0.56826251129316 + 0.56826251233637 + 0.56826251360881 + 0.56826251518653 + 0.56826251715295 + 0.56826251960690 + 0.56826252266652 + 0.56826252648041 + 0.56826253123303 + 0.56826253716177 + 0.56826254458032 + 0.56826255386230 + 0.56826256547633 + 0.56826258000935 + 0.56826259819477 + 0.56826262096505 + 0.56826264957738 + 0.56826268588237 + 0.56826273236015 + 0.56826279199878 + 0.56826286849024 + 0.56826296693834 + 0.56826309376510 + 0.56826325712298 + 0.56826346747278 + 0.56826373821404 + 0.56826408648266 + 0.56826453415035 + 0.56826510908206 + 0.56826584808253 + 0.56826679996551 + 0.56826802597563 + 0.56826960480240 + 0.56827163670430 + 0.56827423969456 + 0.56827749104880 + 0.56828138375651 + 0.56828595713102 + 0.56829123441303 + 0.56829707482767 + 0.56830337182434 + 0.56831012927604 + 0.56831737892217 + 0.56832515933198 + 0.56833351395637 + 0.56834250888283 + 0.56835221040453 + 0.56836267350239 + 0.56837395978597 + 0.56838613987835 + 0.56839930540927 + 0.56841364068316 + 0.56842960482145 + 0.56844782361402 + 0.56846881614589 + 0.56849307914448 + 0.56852122106633 + 0.56855393410075 + 0.56859204259703 + 0.56863654376396 + 0.56868865143836 + 0.56874985608189 + 0.56882203228329 + 0.56890775823648 + 0.56901105098950 + 0.56913741382171 + 0.56929329592903 + 0.56948661415709 + 0.56960052082276 + 0.56972785314264 + 0.56987038260248 + 0.57003014298193 + 0.57020947446060 + 0.57041107630763 + 0.57063807021280 + 0.57089407717049 + 0.57118332056965 + 0.57151101530059 + 0.57188820832376 + 0.57234341422510 + 0.57290571560449 + 0.57360295368386 + 0.57447213086621 + 0.57555852726987 + 0.57692091494833 + 0.57863656343330 + 0.58080874653820 + 0.58357846060518 + 0.58714441408297 + 0.59181434083941 + 0.59805252497930 + 0.60663093476822 + 0.61897959703179 + 0.63827058097081 + 0.67465728490784 + 1.00000000000000 + 0.66432402589024 + 0.61641337018376 + 0.58524849695672 + 0.56108414125216 + 0.55711622753009 + 0.55711622909492 + 0.55711622935424 + 0.55711622965629 + 0.55711623000852 + 0.55711623041893 + 0.55711623089760 + 0.55711623145547 + 0.55711623210600 + 0.55711623286920 + 0.55711623377689 + 0.55711623488443 + 0.55711623625945 + 0.55711623797477 + 0.55711624011563 + 0.55711624278878 + 0.55711624612398 + 0.55711625028167 + 0.55711625547462 + 0.55711626197699 + 0.55711627011976 + 0.55711628031622 + 0.55711629308608 + 0.55711630907744 + 0.55711632911646 + 0.55711635431652 + 0.55711638632071 + 0.55711642733215 + 0.55711648000789 + 0.55711654762936 + 0.55711663474069 + 0.55711674706108 + 0.55711689185761 + 0.55711707845643 + 0.55711731881048 + 0.55711762820956 + 0.55711802617760 + 0.55711853759613 + 0.55711919533426 + 0.55712004300130 + 0.55712113531121 + 0.55712254255317 + 0.55712435426572 + 0.55712667575537 + 0.55712957551897 + 0.55713304613596 + 0.55713712147708 + 0.55714182068461 + 0.55714701571447 + 0.55715260927749 + 0.55715860288917 + 0.55716502271846 + 0.55717190070155 + 0.55717927272993 + 0.55718719436921 + 0.55719572077146 + 0.55720489642954 + 0.55721477103922 + 0.55722540149815 + 0.55723686229319 + 0.55724930817215 + 0.55726313290668 + 0.55727887233779 + 0.55729696401846 + 0.55731782093391 + 0.55734194752443 + 0.55736991369425 + 0.55740239489563 + 0.55744020470056 + 0.55748432910615 + 0.55753597373458 + 0.55759665022823 + 0.55766844154423 + 0.55775461607598 + 0.55785964539080 + 0.55798871968167 + 0.55814816263105 + 0.55824183027231 + 0.55834631876085 + 0.55846302729435 + 0.55859355788307 + 0.55873974861017 + 0.55890371312105 + 0.55908788781445 + 0.55929508878680 + 0.55952858851122 + 0.55979242688201 + 0.56009539854009 + 0.56046061185188 + 0.56091142422893 + 0.56146986662895 + 0.56216508912384 + 0.56303240193809 + 0.56411717427056 + 0.56547828523316 + 0.56719312962785 + 0.56936512691085 + 0.57213607026636 + 0.57571934115053 + 0.58042005991278 + 0.58671100020588 + 0.59537873277996 + 0.60787909776329 + 0.62743021832894 + 0.66432402589024 + 1.00000000000000 + 0.65385016520380 + 0.60526819798771 + 0.57382366273828 + 0.54596825674889 + 0.54596825810285 + 0.54596825832741 + 0.54596825858866 + 0.54596825889355 + 0.54596825924857 + 0.54596825966280 + 0.54596826014543 + 0.54596826070861 + 0.54596826136865 + 0.54596826215451 + 0.54596826311403 + 0.54596826430565 + 0.54596826579395 + 0.54596826765393 + 0.54596826997769 + 0.54596827288002 + 0.54596827650195 + 0.54596828102902 + 0.54596828670311 + 0.54596829381541 + 0.54596830272975 + 0.54596831390391 + 0.54596832790887 + 0.54596834547349 + 0.54596836758299 + 0.54596839568866 + 0.54596843174127 + 0.54596847809656 + 0.54596853766417 + 0.54596861447772 + 0.54596871361637 + 0.54596884153734 + 0.54596900653456 + 0.54596921924002 + 0.54596949326405 + 0.54596984598889 + 0.54597029957250 + 0.54597088330113 + 0.54597163603840 + 0.54597260654980 + 0.54597385747634 + 0.54597546860247 + 0.54597753368183 + 0.54598011329092 + 0.54598319974954 + 0.54598682210428 + 0.54599099594702 + 0.54599560504644 + 0.54600056076971 + 0.54600586271599 + 0.54601153226496 + 0.54601759563772 + 0.54602408223769 + 0.54603103852943 + 0.54603851010012 + 0.54604653256224 + 0.54605514557454 + 0.54606439448788 + 0.54607433933910 + 0.54608510951748 + 0.54609704179149 + 0.54611059363510 + 0.54612613251026 + 0.54614400015991 + 0.54616461277701 + 0.54618843707600 + 0.54621602335389 + 0.54624803136611 + 0.54628525694985 + 0.54632866878148 + 0.54637947740648 + 0.54643935480205 + 0.54651094566871 + 0.54659786342326 + 0.54670425857077 + 0.54683514695947 + 0.54691180111907 + 0.54699712338915 + 0.54709221068148 + 0.54719831547578 + 0.54731687068157 + 0.54744951905037 + 0.54759814811330 + 0.54776493211657 + 0.54795238887088 + 0.54816362833643 + 0.54840562787032 + 0.54869706505986 + 0.54905666515836 + 0.54950184989251 + 0.55005559545422 + 0.55074549796033 + 0.55160672746062 + 0.55268445440016 + 0.55403727153025 + 0.55574216044140 + 0.55790244945337 + 0.56067054797393 + 0.56425590226034 + 0.56896765353495 + 0.57528577361944 + 0.58400997994613 + 0.59662040375027 + 0.61641337018376 + 0.65385016520380 + 1.00000000000000 + 0.64324097120346 + 0.59402249857221 + 0.53485938094428 + 0.53485938211089 + 0.53485938230429 + 0.53485938252926 + 0.53485938279197 + 0.53485938309795 + 0.53485938345462 + 0.53485938387043 + 0.53485938435605 + 0.53485938492486 + 0.53485938560207 + 0.53485938642988 + 0.53485938745918 + 0.53485938874606 + 0.53485939035562 + 0.53485939236867 + 0.53485939488503 + 0.53485939802912 + 0.53485940196328 + 0.53485940689875 + 0.53485941309141 + 0.53485942086106 + 0.53485943060928 + 0.53485944283944 + 0.53485945819230 + 0.53485947753517 + 0.53485950215004 + 0.53485953376214 + 0.53485957445284 + 0.53485962679721 + 0.53485969436920 + 0.53485978167181 + 0.53485989443210 + 0.53486004001222 + 0.53486022785516 + 0.53486047005240 + 0.53486078205827 + 0.53486118357207 + 0.53486170064520 + 0.53486236786540 + 0.53486322862921 + 0.53486433868389 + 0.53486576902244 + 0.53486760301097 + 0.53486989413559 + 0.53487263460232 + 0.53487584924494 + 0.53487955061323 + 0.53488363335606 + 0.53488801686111 + 0.53489269922204 + 0.53489769775736 + 0.53490303384003 + 0.53490873138728 + 0.53491482909195 + 0.53492136443701 + 0.53492836564119 + 0.53493586401786 + 0.53494389535395 + 0.53495250767371 + 0.53496180886530 + 0.53497208649544 + 0.53498373050952 + 0.53499704877951 + 0.53501232314772 + 0.53502989580183 + 0.53505014739365 + 0.53507352424979 + 0.53510055879872 + 0.53513189001685 + 0.53516829177747 + 0.53521072773965 + 0.53526053266688 + 0.53531983725738 + 0.53539154864127 + 0.53547896778002 + 0.53558604805330 + 0.53564855422015 + 0.53571796783163 + 0.53579514267583 + 0.53588105081634 + 0.53597680103660 + 0.53608366054263 + 0.53620308060444 + 0.53633672720154 + 0.53648652294896 + 0.53665484567907 + 0.53684721310349 + 0.53707868846709 + 0.53736425833588 + 0.53771768583826 + 0.53815707944383 + 0.53870403074812 + 0.53938587397189 + 0.54023741633124 + 0.54130331863483 + 0.54264145318888 + 0.54432818439859 + 0.54647452619081 + 0.54922835522019 + 0.55280027158749 + 0.55750186058744 + 0.56381815987117 + 0.57255926300827 + 0.58524849695672 + 0.60526819798771 + 0.64324097120346 + 1.00000000000000 + 0.63250515642238 + 0.52382005204112 + 0.52382005304374 + 0.52382005320988 + 0.52382005340312 + 0.52382005362900 + 0.52382005389197 + 0.52382005419856 + 0.52382005455580 + 0.52382005497303 + 0.52382005546169 + 0.52382005604420 + 0.52382005675632 + 0.52382005764282 + 0.52382005875263 + 0.52382006014235 + 0.52382006188228 + 0.52382006406008 + 0.52382006678368 + 0.52382007019445 + 0.52382007447959 + 0.52382007986151 + 0.52382008662094 + 0.52382009511107 + 0.52382010577322 + 0.52382011917133 + 0.52382013606928 + 0.52382015759674 + 0.52382018527564 + 0.52382022094705 + 0.52382026688726 + 0.52382032625845 + 0.52382040304926 + 0.52382050233783 + 0.52382063065279 + 0.52382079637425 + 0.52382101023760 + 0.52382128597128 + 0.52382164108060 + 0.52382209872718 + 0.52382268967044 + 0.52382345251140 + 0.52382443683823 + 0.52382570579167 + 0.52382733346550 + 0.52382936707298 + 0.52383179882964 + 0.52383464992607 + 0.52383793036125 + 0.52384154472917 + 0.52384541979501 + 0.52384955252106 + 0.52385395683340 + 0.52385865006008 + 0.52386365154214 + 0.52386899342887 + 0.52387470643611 + 0.52388081271216 + 0.52388733676322 + 0.52389430657124 + 0.52390176032647 + 0.52390978790633 + 0.52391863486514 + 0.52392863356750 + 0.52394004181446 + 0.52395309170726 + 0.52396806413645 + 0.52398526889567 + 0.52400506706057 + 0.52402788703611 + 0.52405424012072 + 0.52408474218852 + 0.52412015717887 + 0.52416154679713 + 0.52421062338392 + 0.52426971989037 + 0.52434145183187 + 0.52442892045963 + 0.52447980343917 + 0.52453617177900 + 0.52459868611927 + 0.52466809629796 + 0.52474525489345 + 0.52483113307879 + 0.52492683928621 + 0.52503364137650 + 0.52515299739748 + 0.52528671430870 + 0.52543914679917 + 0.52562243184825 + 0.52584855631289 + 0.52612839041446 + 0.52647621299510 + 0.52690894088239 + 0.52744787089827 + 0.52811992788202 + 0.52895934329594 + 0.53000996253551 + 0.53132882402547 + 0.53299795281695 + 0.53512382873399 + 0.53785389819752 + 0.54139850794504 + 0.54606960159257 + 0.55235421578454 + 0.56108414125216 + 0.57382366273828 + 0.59402249857221 + 0.63250515642238 + 1.00000000000000 + 1.00000000000000 + 0.99977115932313 + 0.99975060100276 + 0.99972913022501 + 0.99970676302134 + 0.99968349868726 + 0.99965931589955 + 0.99963416912529 + 0.99960798251153 + 0.99958062922869 + 0.99955187184113 + 0.99952133290695 + 0.99948861435693 + 0.99945335284575 + 0.99941518045027 + 0.99937370118383 + 0.99932848431783 + 0.99927906290230 + 0.99922490904203 + 0.99916543567899 + 0.99910005398490 + 0.99902814684755 + 0.99894907260907 + 0.99886216542264 + 0.99876671847444 + 0.99866188928604 + 0.99854653069086 + 0.99841939285594 + 0.99827936974869 + 0.99812535375803 + 0.99795588680009 + 0.99776936905356 + 0.99756393214537 + 0.99733730392138 + 0.99708670512959 + 0.99680873923165 + 0.99649928688288 + 0.99615341810059 + 0.99576512631396 + 0.99532727082600 + 0.99483192942722 + 0.99427011934478 + 0.99363176741456 + 0.99290628946520 + 0.99208632999542 + 0.99116785406392 + 0.99014050940579 + 0.98899272094630 + 0.98771864297099 + 0.98630759209269 + 0.98474230412491 + 0.98300388055340 + 0.98107277025842 + 0.97892833587844 + 0.97654658864649 + 0.97389969019845 + 0.97095469883327 + 0.96767123670600 + 0.96400176623743 + 0.95989318170236 + 0.95528652653768 + 0.95011122041841 + 0.94429401144548 + 0.93777519848146 + 0.93050514778001 + 0.92243875884664 + 0.91354163601666 + 0.90379090141893 + 0.89317765416446 + 0.88171067337343 + 0.86942181862021 + 0.85637200399154 + 0.84265002323852 + 0.82835810165022 + 0.81362107826320 + 0.79860299910828 + 0.78348165148290 + 0.77592905028965 + 0.76840830933443 + 0.76093322054133 + 0.75351400076725 + 0.74615696778866 + 0.73886434533017 + 0.73163424339785 + 0.72446090474278 + 0.71733520331718 + 0.71024264326340 + 0.70311836290402 + 0.69576973921882 + 0.68809664968667 + 0.68008818613635 + 0.67173425755674 + 0.66304395544433 + 0.65403014815054 + 0.64470848704948 + 0.63509687732998 + 0.62521548210643 + 0.61508585458111 + 0.60470858510796 + 0.59410841884335 + 0.58331549646903 + 0.57236583026736 + 0.56130083459441 + 0.55016559316895 + 0.53899293004464 + 0.52780886868658 + 0.51664296694839 + 0.50551388479639 + 0.49442693882672 + 0.99977115932313 + 1.00000000000000 + 0.99993600196531 + 0.99988285233658 + 0.99983563972043 + 0.99979248120702 + 0.99975220672573 + 0.99971395809085 + 0.99967704418553 + 0.99964085925431 + 0.99960478471041 + 0.99956813474940 + 0.99953026858624 + 0.99949063410131 + 0.99944871395466 + 0.99940399338894 + 0.99935594755489 + 0.99930403460554 + 0.99924766567528 + 0.99918620379036 + 0.99911902048082 + 0.99904546691275 + 0.99896487658056 + 0.99887656458075 + 0.99877980970255 + 0.99867375825221 + 0.99855725390719 + 0.99842904161716 + 0.99828801430557 + 0.99813306493105 + 0.99796273531976 + 0.99777542588333 + 0.99756926798580 + 0.99734198834508 + 0.99709080567598 + 0.99681232046585 + 0.99650240945752 + 0.99615613791298 + 0.99576749382642 + 0.99532933087843 + 0.99483372153415 + 0.99427167803636 + 0.99363312272524 + 0.99290746754313 + 0.99208735396118 + 0.99116874439032 + 0.99014128370042 + 0.98899339440523 + 0.98771922897932 + 0.98630810229824 + 0.98474274860035 + 0.98300426807026 + 0.98107310849761 + 0.97892863156461 + 0.97654684765557 + 0.97389991764813 + 0.97095489917744 + 0.96767141379837 + 0.96400192339169 + 0.95989332174068 + 0.95528665183770 + 0.95011133293366 + 0.94429411277332 + 0.93777528994838 + 0.93050523050042 + 0.92243883375265 + 0.91354170389332 + 0.90379096292710 + 0.89317770986487 + 0.88171072374534 + 0.86942186407835 + 0.85637204490023 + 0.84265005992202 + 0.82835813440728 + 0.81362110737892 + 0.79860302487175 + 0.78348167419496 + 0.77592907159091 + 0.76840832930233 + 0.76093323925618 + 0.75351401830684 + 0.74615698423148 + 0.73886436075179 + 0.73163425787237 + 0.72446091834094 + 0.71733521610511 + 0.71024265530318 + 0.70311837424806 + 0.69576974989856 + 0.68809665972522 + 0.68008819555243 + 0.67173426636686 + 0.66304396366311 + 0.65403015579371 + 0.64470849413043 + 0.63509688386494 + 0.62521548811102 + 0.61508586007490 + 0.60470859010979 + 0.59410842337458 + 0.58331550055321 + 0.57236583393041 + 0.56130083786402 + 0.55016559607376 + 0.53899293261521 + 0.52780887095442 + 0.51664296894330 + 0.50551388654871 + 0.49442694036512 + 0.99975060100276 + 0.99993600196531 + 1.00000000000000 + 0.99992743809398 + 0.99986917647402 + 0.99981854907176 + 0.99977295419798 + 0.99973080310902 + 0.99969096548323 + 0.99965254948575 + 0.99961474265869 + 0.99957672460623 + 0.99953776052240 + 0.99949723169297 + 0.99945457225236 + 0.99940923160476 + 0.99936065831284 + 0.99930829069918 + 0.99925152473219 + 0.99918971167902 + 0.99912221406817 + 0.99904837609621 + 0.99896752593759 + 0.99887897468820 + 0.99878199815778 + 0.99867574038028 + 0.99855904321822 + 0.99843065054851 + 0.99828945497418 + 0.99813434944998 + 0.99796387570042 + 0.99777643412207 + 0.99757015598387 + 0.99734276778038 + 0.99709148785884 + 0.99681291618893 + 0.99650292884469 + 0.99615659028365 + 0.99576788758937 + 0.99532967349691 + 0.99483401958413 + 0.99427193726055 + 0.99363334811704 + 0.99290766345362 + 0.99208752423434 + 0.99116889243007 + 0.99014141243589 + 0.98899350636286 + 0.98771932638691 + 0.98630818709368 + 0.98474282246106 + 0.98300433245720 + 0.98107316468804 + 0.97892868067899 + 0.97654689067126 + 0.97389995541667 + 0.97095493244072 + 0.96767144319681 + 0.96400194947640 + 0.95989334498235 + 0.95528667263032 + 0.95011135160274 + 0.94429412958456 + 0.93777530512139 + 0.93050524422043 + 0.92243884617525 + 0.91354171514938 + 0.90379097312567 + 0.89317771909970 + 0.88171073209581 + 0.86942187161391 + 0.85637205168049 + 0.84265006600135 + 0.82835813983631 + 0.81362111220345 + 0.79860302914130 + 0.78348167795878 + 0.77592907512003 + 0.76840833261079 + 0.76093324235612 + 0.75351402121289 + 0.74615698695594 + 0.73886436330704 + 0.73163426027071 + 0.72446092059347 + 0.71733521822351 + 0.71024265729802 + 0.70311837612714 + 0.69576975166807 + 0.68809666138820 + 0.68008819711203 + 0.67173426782581 + 0.66304396502500 + 0.65403015705957 + 0.64470849530347 + 0.63509688494765 + 0.62521548910546 + 0.61508586098470 + 0.60470859093821 + 0.59410842412534 + 0.58331550122975 + 0.57236583453722 + 0.56130083840515 + 0.55016559655482 + 0.53899293304103 + 0.52780887132982 + 0.51664296927370 + 0.50551388683910 + 0.49442694061964 + 0.99972913022501 + 0.99988285233658 + 0.99992743809398 + 1.00000000000000 + 0.99991794455870 + 0.99985441502771 + 0.99980042663313 + 0.99975247825067 + 0.99970848997083 + 0.99966701877857 + 0.99962690758842 + 0.99958711193305 + 0.99954674861984 + 0.99950509823333 + 0.99946152410165 + 0.99941542478112 + 0.99936621205214 + 0.99931329736479 + 0.99925605659050 + 0.99919382568308 + 0.99912595560681 + 0.99905178169904 + 0.99897062542479 + 0.99888179287399 + 0.99878455614891 + 0.99867805646645 + 0.99856113345787 + 0.99843252966923 + 0.99829113728214 + 0.99813584919713 + 0.99796520700252 + 0.99777761104319 + 0.99757119246789 + 0.99734367749315 + 0.99709228402662 + 0.99681361142598 + 0.99650353497948 + 0.99615711820208 + 0.99576834710619 + 0.99533007332549 + 0.99483436739828 + 0.99427223976558 + 0.99363361113939 + 0.99290789206849 + 0.99208772292856 + 0.99116906517675 + 0.99014156265075 + 0.98899363699812 + 0.98771944003958 + 0.98630828602941 + 0.98474290863324 + 0.98300440757214 + 0.98107323023795 + 0.97892873797130 + 0.97654694084613 + 0.97389999946969 + 0.97095497123568 + 0.96767147748471 + 0.96400197989908 + 0.95989337208724 + 0.95528669687810 + 0.95011137337295 + 0.94429414918649 + 0.93777532281356 + 0.93050526021801 + 0.92243886065974 + 0.91354172827209 + 0.90379098501620 + 0.89317772986608 + 0.88171074183060 + 0.86942188039784 + 0.85637205958412 + 0.84265007308879 + 0.82835814616421 + 0.81362111782758 + 0.79860303411722 + 0.78348168234470 + 0.77592907923430 + 0.76840833646690 + 0.76093324597028 + 0.75351402460031 + 0.74615699013113 + 0.73886436628516 + 0.73163426306591 + 0.72446092322014 + 0.71733522069353 + 0.71024265962312 + 0.70311837831794 + 0.69576975373053 + 0.68809666332659 + 0.68008819893061 + 0.67173426952699 + 0.66304396661187 + 0.65403015853545 + 0.64470849667104 + 0.63509688620950 + 0.62521549026499 + 0.61508586204533 + 0.60470859190378 + 0.59410842500043 + 0.58331550201858 + 0.57236583524446 + 0.56130083903656 + 0.55016559711550 + 0.53899293353743 + 0.52780887176768 + 0.51664296965872 + 0.50551388717746 + 0.49442694091692 + 0.99970676302134 + 0.99983563972043 + 0.99986917647402 + 0.99991794455870 + 1.00000000000000 + 0.99990747031838 + 0.99983857243637 + 0.99978130506096 + 0.99973107507324 + 0.99968523427147 + 0.99964195397637 + 0.99959978823833 + 0.99955760517443 + 0.99951452558088 + 0.99946980532590 + 0.99942276846713 + 0.99937277441947 + 0.99931919737382 + 0.99926138599879 + 0.99919865596679 + 0.99913034315080 + 0.99905577147688 + 0.99897425386115 + 0.99888509005959 + 0.99878754751460 + 0.99868076392470 + 0.99856357616186 + 0.99843472510830 + 0.99829310237290 + 0.99813760074220 + 0.99796676160341 + 0.99777898521484 + 0.99757240255423 + 0.99734473949884 + 0.99709321342741 + 0.99681442297629 + 0.99650424249947 + 0.99615773441046 + 0.99576888346667 + 0.99533054001301 + 0.99483477337284 + 0.99427259284954 + 0.99363391813561 + 0.99290815890183 + 0.99208795483409 + 0.99116926679270 + 0.99014173796306 + 0.98899378945339 + 0.98771957267076 + 0.98630840147796 + 0.98474300918467 + 0.98300449521665 + 0.98107330671726 + 0.97892880481264 + 0.97654699938120 + 0.97390005086065 + 0.97095501649187 + 0.96767151747861 + 0.96400201538326 + 0.95989340370031 + 0.95528672515854 + 0.95011139876299 + 0.94429417204614 + 0.93777534344495 + 0.93050527887254 + 0.92243887754945 + 0.91354174357333 + 0.90379099887848 + 0.89317774241772 + 0.88171075318012 + 0.86942189063889 + 0.85637206879851 + 0.84265008135066 + 0.82835815354092 + 0.81362112438357 + 0.79860303991744 + 0.78348168745755 + 0.77592908402933 + 0.76840834096247 + 0.76093325018330 + 0.75351402854876 + 0.74615699383256 + 0.73886436975634 + 0.73163426632374 + 0.72446092628017 + 0.71733522357144 + 0.71024266233259 + 0.70311838087054 + 0.69576975613411 + 0.68809666558582 + 0.68008820104935 + 0.67173427150961 + 0.66304396846157 + 0.65403016025569 + 0.64470849826431 + 0.63509688767980 + 0.62521549161667 + 0.61508586328183 + 0.60470859302983 + 0.59410842601994 + 0.58331550293737 + 0.57236583606872 + 0.56130083977236 + 0.55016559776972 + 0.53899293411577 + 0.52780887227809 + 0.51664297010763 + 0.50551388757184 + 0.49442694126319 + 0.99968349868726 + 0.99979248120702 + 0.99981854907176 + 0.99985441502771 + 0.99990747031838 + 1.00000000000000 + 0.99989597232808 + 0.99982166410200 + 0.99976121312210 + 0.99970872733591 + 0.99966088585775 + 0.99961544967491 + 0.99957083664167 + 0.99952589799489 + 0.99947971840747 + 0.99943150838574 + 0.99938055029678 + 0.99932616516982 + 0.99926766396418 + 0.99920433492960 + 0.99913549390051 + 0.99906044988870 + 0.99897850476603 + 0.99888895018266 + 0.99879104766337 + 0.99868393047497 + 0.99856643203691 + 0.99843729114005 + 0.99829539861848 + 0.99813964704850 + 0.99796857752592 + 0.99778059016379 + 0.99757381571040 + 0.99734597962163 + 0.99709429863813 + 0.99681537053264 + 0.99650506856572 + 0.99615845384903 + 0.99576950967283 + 0.99533108486983 + 0.99483524734245 + 0.99427300506591 + 0.99363427654282 + 0.99290847041436 + 0.99208822556473 + 0.99116950215370 + 0.99014194261241 + 0.98899396741292 + 0.98771972748420 + 0.98630853622524 + 0.98474312653921 + 0.98300459749878 + 0.98107339596424 + 0.97892888280715 + 0.97654706767833 + 0.97390011081741 + 0.97095506928818 + 0.96767156413715 + 0.96400205677627 + 0.95989344057573 + 0.95528675814388 + 0.95011142837586 + 0.94429419870885 + 0.93777536750564 + 0.93050530062672 + 0.92243889724338 + 0.91354176141554 + 0.90379101504331 + 0.89317775705300 + 0.88171076641275 + 0.86942190257848 + 0.85637207954029 + 0.84265009098200 + 0.82835816214003 + 0.81362113202650 + 0.79860304667984 + 0.78348169341888 + 0.77592908961866 + 0.76840834620262 + 0.76093325509412 + 0.75351403315034 + 0.74615699814706 + 0.73886437380294 + 0.73163427012200 + 0.72446092984745 + 0.71733522692679 + 0.71024266549172 + 0.70311838384647 + 0.69576975893560 + 0.68809666821882 + 0.68008820351956 + 0.67173427382105 + 0.66304397061774 + 0.65403016226066 + 0.64470850012214 + 0.63509688939440 + 0.62521549319165 + 0.61508586472262 + 0.60470859434157 + 0.59410842720865 + 0.58331550400906 + 0.57236583702959 + 0.56130084062967 + 0.55016559853134 + 0.53899293478979 + 0.52780887287258 + 0.51664297063112 + 0.50551388803155 + 0.49442694166690 + 0.99965931589955 + 0.99975220672573 + 0.99977295419798 + 0.99980042663313 + 0.99983857243637 + 0.99989597232808 + 1.00000000000000 + 0.99988341691760 + 0.99980371016694 + 0.99974014765679 + 0.99968530126417 + 0.99963513392659 + 0.99958715956488 + 0.99953973683999 + 0.99949166029680 + 0.99944195872290 + 0.99938979645790 + 0.99933441606358 + 0.99927507471536 + 0.99921102267650 + 0.99914154864113 + 0.99906594178081 + 0.99898348947968 + 0.99889347288253 + 0.99879514590319 + 0.99868763616790 + 0.99856977274548 + 0.99844029175907 + 0.99829808299725 + 0.99814203868458 + 0.99797069948973 + 0.99778246530744 + 0.99757546656747 + 0.99734742819776 + 0.99709556616592 + 0.99681647721933 + 0.99650603332168 + 0.99615929405373 + 0.99577024098116 + 0.99533172116773 + 0.99483580085104 + 0.99427348645513 + 0.99363469508549 + 0.99290883418605 + 0.99208854170371 + 0.99116977698297 + 0.99014218156933 + 0.98899417519384 + 0.98771990822770 + 0.98630869353660 + 0.98474326353171 + 0.98300471689251 + 0.98107350013193 + 0.97892897383470 + 0.97654714738275 + 0.97390018078364 + 0.97095513089573 + 0.96767161857434 + 0.96400210506951 + 0.95989348359652 + 0.95528679662510 + 0.95011146292065 + 0.94429422980841 + 0.93777539556959 + 0.93050532599943 + 0.92243892021112 + 0.91354178222305 + 0.90379103389238 + 0.89317777411767 + 0.88171078184054 + 0.86942191649928 + 0.85637209206507 + 0.84265010221091 + 0.82835817216518 + 0.81362114093594 + 0.79860305456285 + 0.78348170036639 + 0.77592909613443 + 0.76840835230941 + 0.76093326081786 + 0.75351403851522 + 0.74615700317570 + 0.73886437851962 + 0.73163427454799 + 0.72446093400606 + 0.71733523083749 + 0.71024266917402 + 0.70311838731548 + 0.69576976220219 + 0.68809667128886 + 0.68008820639854 + 0.67173427651515 + 0.66304397313142 + 0.65403016459758 + 0.64470850228730 + 0.63509689139183 + 0.62521549502765 + 0.61508586640272 + 0.60470859587092 + 0.59410842859402 + 0.58331550525792 + 0.57236583814947 + 0.56130084162935 + 0.55016559941949 + 0.53899293557598 + 0.52780887356572 + 0.51664297124126 + 0.50551388856753 + 0.49442694213721 + 0.99963416912529 + 0.99971395809085 + 0.99973080310902 + 0.99975247825067 + 0.99978130506096 + 0.99982166410200 + 0.99988341691760 + 1.00000000000000 + 0.99986977807036 + 0.99978470978620 + 0.99971799289014 + 0.99966049915139 + 0.99960764256181 + 0.99955677848854 + 0.99950616808775 + 0.99945453062168 + 0.99940084046386 + 0.99934421949915 + 0.99928384548943 + 0.99921891455925 + 0.99914867775362 + 0.99907239731621 + 0.99898934130385 + 0.99889877702508 + 0.99879994848561 + 0.99869197603314 + 0.99857368320471 + 0.99844380269798 + 0.99830122286288 + 0.99814483536359 + 0.99797318026660 + 0.99778465712242 + 0.99757739593710 + 0.99734912096227 + 0.99709704723391 + 0.99681777026278 + 0.99650716048434 + 0.99616027566802 + 0.99577109535488 + 0.99533246453113 + 0.99483644748604 + 0.99427404882680 + 0.99363518402993 + 0.99290925913819 + 0.99208891100368 + 0.99117009801000 + 0.99014246068097 + 0.98899441787610 + 0.98772011931706 + 0.98630887724248 + 0.98474342349951 + 0.98300485629527 + 0.98107362174933 + 0.97892908010078 + 0.97654724042351 + 0.97390026245043 + 0.97095520279875 + 0.96767168210710 + 0.96400216142743 + 0.95989353379738 + 0.95528684152542 + 0.95011150322608 + 0.94429426609000 + 0.93777542830725 + 0.93050535559628 + 0.92243894700351 + 0.91354180649097 + 0.90379105587573 + 0.89317779401921 + 0.88171079983367 + 0.86942193273130 + 0.85637210666931 + 0.84265011530381 + 0.82835818385459 + 0.81362115132313 + 0.79860306375303 + 0.78348170846706 + 0.77592910373053 + 0.76840835943091 + 0.76093326749157 + 0.75351404476905 + 0.74615700903838 + 0.73886438401823 + 0.73163427970921 + 0.72446093885392 + 0.71733523539663 + 0.71024267346576 + 0.70311839136028 + 0.69576976600941 + 0.68809667486687 + 0.68008820975480 + 0.67173427965531 + 0.66304397606115 + 0.65403016732215 + 0.64470850481175 + 0.63509689372147 + 0.62521549716848 + 0.61508586836061 + 0.60470859765390 + 0.59410843020934 + 0.58331550671364 + 0.57236583945524 + 0.56130084279479 + 0.55016560045460 + 0.53899293649248 + 0.52780887437388 + 0.51664297195213 + 0.50551388919231 + 0.49442694268546 + 0.99960798251153 + 0.99967704418553 + 0.99969096548323 + 0.99970848997083 + 0.99973107507324 + 0.99976121312210 + 0.99980371016694 + 0.99986977807036 + 1.00000000000000 + 0.99985502067764 + 0.99976456199754 + 0.99969446963638 + 0.99963400034856 + 0.99957812276641 + 0.99952400058542 + 0.99946978066363 + 0.99941411170333 + 0.99935592031618 + 0.99929426198879 + 0.99922825298836 + 0.99915709061659 + 0.99907999970304 + 0.99899622199271 + 0.99890500626032 + 0.99880558340357 + 0.99869706427577 + 0.99857826526835 + 0.99844791463805 + 0.99830489875362 + 0.99814810841558 + 0.99797608283448 + 0.99778722104205 + 0.99757965245679 + 0.99735110048601 + 0.99709877901257 + 0.99681928206975 + 0.99650847826808 + 0.99616142324344 + 0.99577209414930 + 0.99533333353182 + 0.99483720339826 + 0.99427470622469 + 0.99363575558085 + 0.99290975586933 + 0.99208934266261 + 0.99117047323085 + 0.99014278689015 + 0.98899470149189 + 0.98772036599311 + 0.98630909190314 + 0.98474361040516 + 0.98300501915998 + 0.98107376382089 + 0.97892920422827 + 0.97654734909241 + 0.97390035782689 + 0.97095528676576 + 0.96767175629473 + 0.96400222723234 + 0.95989359240917 + 0.95528689394676 + 0.95011155027657 + 0.94429430844301 + 0.93777546652196 + 0.93050539013954 + 0.92243897826975 + 0.91354183481170 + 0.90379108153000 + 0.89317781724090 + 0.88171082082620 + 0.86942195166993 + 0.85637212370749 + 0.84265013057836 + 0.82835819749086 + 0.81362116344137 + 0.79860307447345 + 0.78348171791639 + 0.77592911259222 + 0.76840836773752 + 0.76093327527651 + 0.75351405206470 + 0.74615701587754 + 0.73886439043309 + 0.73163428572879 + 0.72446094450990 + 0.71733524071523 + 0.71024267847316 + 0.70311839607768 + 0.69576977045192 + 0.68809667904162 + 0.68008821367108 + 0.67173428331913 + 0.66304397947932 + 0.65403017050067 + 0.64470850775667 + 0.63509689643877 + 0.62521549966564 + 0.61508587064539 + 0.60470859973385 + 0.59410843209343 + 0.58331550841184 + 0.57236584097856 + 0.56130084415430 + 0.55016560166287 + 0.53899293756099 + 0.52780887531684 + 0.51664297278167 + 0.50551388992101 + 0.49442694332505 + 0.99958062922869 + 0.99964085925431 + 0.99965254948575 + 0.99966701877857 + 0.99968523427147 + 0.99970872733591 + 0.99974014765679 + 0.99978470978620 + 0.99985502067764 + 1.00000000000000 + 0.99983904535181 + 0.99974302496958 + 0.99966929421016 + 0.99960555317759 + 0.99954630412785 + 0.99948850656956 + 0.99943020243242 + 0.99936998126636 + 0.99930670017710 + 0.99923935251681 + 0.99916705620444 + 0.99908898259334 + 0.99900433674787 + 0.99891234209072 + 0.99881221189196 + 0.99870304439732 + 0.99858364666601 + 0.99845274111561 + 0.99830921136454 + 0.99815194690684 + 0.99797948573639 + 0.99779022612081 + 0.99758229666899 + 0.99735341970411 + 0.99710080769012 + 0.99682105287297 + 0.99651002168353 + 0.99616276722254 + 0.99577326383019 + 0.99533435117606 + 0.99483808857791 + 0.99427547601600 + 0.99363642482223 + 0.99291033747897 + 0.99208984805493 + 0.99117091252126 + 0.99014316877494 + 0.98899503349311 + 0.98772065473489 + 0.98630934315474 + 0.98474382915866 + 0.98300520976186 + 0.98107393008164 + 0.97892934948131 + 0.97654747624885 + 0.97390046942527 + 0.97095538501112 + 0.96767184309414 + 0.96400230422199 + 0.95989366098104 + 0.95528695527176 + 0.95011160531934 + 0.94429435798682 + 0.93777551122334 + 0.93050543054565 + 0.92243901484044 + 0.91354186793460 + 0.90379111153192 + 0.89317784439943 + 0.88171084537628 + 0.86942197381801 + 0.85637214363304 + 0.84265014844067 + 0.82835821343747 + 0.81362117761238 + 0.79860308701208 + 0.78348172896952 + 0.77592912295755 + 0.76840837745448 + 0.76093328438306 + 0.75351406060007 + 0.74615702387952 + 0.73886439793745 + 0.73163429277378 + 0.72446095112777 + 0.71733524693879 + 0.71024268433256 + 0.70311840159920 + 0.69576977565035 + 0.68809668392836 + 0.68008821825394 + 0.67173428760840 + 0.66304398348075 + 0.65403017422118 + 0.64470851120418 + 0.63509689962049 + 0.62521550258913 + 0.61508587332042 + 0.60470860216903 + 0.59410843429978 + 0.58331551040078 + 0.57236584276234 + 0.56130084574647 + 0.55016560307703 + 0.53899293881310 + 0.52780887642124 + 0.51664297375368 + 0.50551389077462 + 0.49442694407486 + 0.99955187184113 + 0.99960478471041 + 0.99961474265869 + 0.99962690758842 + 0.99964195397637 + 0.99966088585775 + 0.99968530126417 + 0.99971799289014 + 0.99976456199754 + 0.99983904535181 + 1.00000000000000 + 0.99982169548940 + 0.99971992473989 + 0.99964232333392 + 0.99957498885645 + 0.99951195790386 + 0.99945000268026 + 0.99938707924277 + 0.99932170056286 + 0.99925266036892 + 0.99917895419198 + 0.99909967422093 + 0.99901397286726 + 0.99892103802775 + 0.99882005871568 + 0.99871011614047 + 0.99859000494210 + 0.99845843973253 + 0.99831430029411 + 0.99815647415409 + 0.99798349758106 + 0.99779376771592 + 0.99758541205442 + 0.99735615150895 + 0.99710319677283 + 0.99682313790736 + 0.99651183871745 + 0.99616434927664 + 0.99577464056985 + 0.99533554885510 + 0.99483913027207 + 0.99427638184790 + 0.99363721227068 + 0.99291102175982 + 0.99209044262183 + 0.99117142928753 + 0.99014361799412 + 0.98899542402178 + 0.98772099437913 + 0.98630963870583 + 0.98474408649298 + 0.98300543399731 + 0.98107412569530 + 0.97892952039557 + 0.97654762588780 + 0.97390060076975 + 0.97095550065661 + 0.96767194528003 + 0.96400239487214 + 0.95989374173345 + 0.95528702750016 + 0.95011167015267 + 0.94429441635177 + 0.93777556388522 + 0.93050547815157 + 0.92243905793117 + 0.91354190696512 + 0.90379114688614 + 0.89317787640381 + 0.88171087431083 + 0.86942199992416 + 0.85637216712152 + 0.84265016950116 + 0.82835823224374 + 0.81362119432880 + 0.79860310180541 + 0.78348174201471 + 0.77592913519484 + 0.76840838892805 + 0.76093329513844 + 0.75351407068405 + 0.74615703333498 + 0.73886440680830 + 0.73163430110198 + 0.72446095895428 + 0.71733525430155 + 0.71024269126632 + 0.70311840813392 + 0.69576978180376 + 0.68809668971316 + 0.68008822368224 + 0.67173429268767 + 0.66304398821994 + 0.65403017862911 + 0.64470851528848 + 0.63509690339026 + 0.62521550605351 + 0.61508587648979 + 0.60470860505563 + 0.59410843691549 + 0.58331551275955 + 0.57236584487796 + 0.56130084763510 + 0.55016560475558 + 0.53899294029887 + 0.52780887773230 + 0.51664297490759 + 0.50551389178877 + 0.49442694496535 + 0.99952133290695 + 0.99956813474940 + 0.99957672460623 + 0.99958711193305 + 0.99959978823833 + 0.99961544967491 + 0.99963513392659 + 0.99966049915139 + 0.99969446963638 + 0.99974302496958 + 0.99982169548940 + 1.00000000000000 + 0.99980293672513 + 0.99969528511313 + 0.99961354479672 + 0.99954221759697 + 0.99947490946882 + 0.99940823663192 + 0.99934006001320 + 0.99926882586556 + 0.99919333039621 + 0.99911254338264 + 0.99902553887097 + 0.99893145339428 + 0.99882944169286 + 0.99871856138796 + 0.99859759023416 + 0.99846523220967 + 0.99832036165535 + 0.99816186317967 + 0.99798827054907 + 0.99779797927717 + 0.99758911528983 + 0.99735939764103 + 0.99710603478108 + 0.99682561406138 + 0.99651399608020 + 0.99616622724962 + 0.99577627451507 + 0.99533697004358 + 0.99484036616408 + 0.99427745637887 + 0.99363814623148 + 0.99291183324368 + 0.99209114763003 + 0.99117204200297 + 0.99014415061193 + 0.98899588707376 + 0.98772139714086 + 0.98630998924729 + 0.98474439178349 + 0.98300570010181 + 0.98107435791280 + 0.97892972336655 + 0.97654780366362 + 0.97390075687876 + 0.97095563816488 + 0.96767206683921 + 0.96400250275454 + 0.95989383787540 + 0.95528711352885 + 0.95011174740510 + 0.94429448591747 + 0.93777562667145 + 0.93050553492519 + 0.92243910933163 + 0.91354195353495 + 0.90379118908098 + 0.89317791461163 + 0.88171090886321 + 0.86942203110770 + 0.85637219518816 + 0.84265019467821 + 0.82835825473633 + 0.81362121433443 + 0.79860311952366 + 0.78348175765252 + 0.77592914986982 + 0.76840840269500 + 0.76093330805165 + 0.75351408279552 + 0.74615704469792 + 0.73886441747587 + 0.73163431112316 + 0.72446096837635 + 0.71733526316939 + 0.71024269962281 + 0.70311841601318 + 0.69576978922686 + 0.68809669669530 + 0.68008823023435 + 0.67173429882127 + 0.66304399394545 + 0.65403018395575 + 0.64470852022499 + 0.63509690794802 + 0.62521551024393 + 0.61508588032488 + 0.60470860854927 + 0.59410844008196 + 0.58331551561534 + 0.57236584744079 + 0.56130084992406 + 0.55016560679057 + 0.53899294210140 + 0.52780887932406 + 0.51664297630933 + 0.50551389302164 + 0.49442694604797 + 0.99948861435693 + 0.99953026858624 + 0.99953776052240 + 0.99954674861984 + 0.99955760517443 + 0.99957083664167 + 0.99958715956488 + 0.99960764256181 + 0.99963400034856 + 0.99966929421016 + 0.99971992473989 + 0.99980293672513 + 1.00000000000000 + 0.99978281610569 + 0.99966914359382 + 0.99958290968038 + 0.99950709238706 + 0.99943492147398 + 0.99936286302668 + 0.99928870072738 + 0.99921088268218 + 0.99912817877093 + 0.99903954119389 + 0.99894402948514 + 0.99884074844468 + 0.99872872213267 + 0.99860670479632 + 0.99847338560647 + 0.99832763107487 + 0.99816832143115 + 0.99799398682698 + 0.99780302036123 + 0.99759354574266 + 0.99736327954230 + 0.99710942732312 + 0.99682857303605 + 0.99651657332325 + 0.99616847011413 + 0.99577822545598 + 0.99533866656320 + 0.99484184116950 + 0.99427873854380 + 0.99363926044185 + 0.99291280116083 + 0.99209198841852 + 0.99117277266456 + 0.99014478575835 + 0.98899643930834 + 0.98772187756245 + 0.98631040749915 + 0.98474475618279 + 0.98300601786725 + 0.98107463535437 + 0.97892996600019 + 0.97654801630289 + 0.97390094371627 + 0.97095580284399 + 0.96767221251261 + 0.96400263212340 + 0.95989395323612 + 0.95528721681460 + 0.95011184020284 + 0.94429456952358 + 0.93777570216562 + 0.93050560321539 + 0.92243917118559 + 0.91354200959439 + 0.90379123989153 + 0.89317796063904 + 0.88171095050561 + 0.86942206870664 + 0.85637222904866 + 0.84265022507087 + 0.82835828190738 + 0.81362123852101 + 0.79860314096651 + 0.78348177659848 + 0.77592916766213 + 0.76840841939652 + 0.76093332372771 + 0.75351409751056 + 0.74615705851565 + 0.73886443045744 + 0.73163432332670 + 0.72446097986014 + 0.71733527398604 + 0.71024270982187 + 0.70311842563602 + 0.69576979829796 + 0.68809670523081 + 0.68008823824935 + 0.67173430632792 + 0.66304400095510 + 0.65403019047935 + 0.64470852627482 + 0.63509691353479 + 0.62521551538208 + 0.61508588502949 + 0.60470861283657 + 0.59410844397028 + 0.58331551912367 + 0.57236585059058 + 0.56130085273890 + 0.55016560929520 + 0.53899294432137 + 0.52780888128525 + 0.51664297803801 + 0.50551389454323 + 0.49442694738675 + 0.99945335284575 + 0.99949063410131 + 0.99949723169297 + 0.99950509823333 + 0.99951452558088 + 0.99952589799489 + 0.99953973683999 + 0.99955677848854 + 0.99957812276641 + 0.99960555317759 + 0.99964232333392 + 0.99969528511313 + 0.99978281610569 + 1.00000000000000 + 0.99976134386637 + 0.99964144165789 + 0.99955025441687 + 0.99946934903132 + 0.99939161348088 + 0.99931339939630 + 0.99923248802853 + 0.99914729948750 + 0.99905658612704 + 0.99895928697971 + 0.99885443143805 + 0.99874099437758 + 0.99861769645517 + 0.99848320577891 + 0.99833637739340 + 0.99817608491522 + 0.99800085319396 + 0.99780907174596 + 0.99759886112270 + 0.99736793452398 + 0.99711349373878 + 0.99683211842577 + 0.99651966030073 + 0.99617115579142 + 0.99578056095150 + 0.99534069699051 + 0.99484360608281 + 0.99428027237022 + 0.99364059306073 + 0.99291395857449 + 0.99209299364894 + 0.99117364614855 + 0.99014554504846 + 0.98899709953419 + 0.98772245204447 + 0.98631090779436 + 0.98474519223250 + 0.98300639829826 + 0.98107496768571 + 0.97893025681181 + 0.97654827132551 + 0.97390116794227 + 0.97095600061631 + 0.96767238757718 + 0.96400278769887 + 0.95989409206072 + 0.95528734118902 + 0.95011195201528 + 0.94429467031286 + 0.93777579321983 + 0.93050568561934 + 0.92243924585031 + 0.91354207729484 + 0.90379130128083 + 0.89317801627111 + 0.88171100085907 + 0.86942211419507 + 0.85637227003681 + 0.84265026188612 + 0.82835831484638 + 0.81362126786999 + 0.79860316701169 + 0.78348179964068 + 0.77592918931410 + 0.76840843973682 + 0.76093334283411 + 0.75351411545945 + 0.74615707538348 + 0.73886444631646 + 0.73163433824830 + 0.72446099391213 + 0.71733528723129 + 0.71024272232039 + 0.70311843743723 + 0.69576980942934 + 0.68809671571189 + 0.68008824809590 + 0.67173431555346 + 0.66304400957429 + 0.65403019850345 + 0.64470853371871 + 0.63509692041286 + 0.62521552170976 + 0.61508589082602 + 0.60470861812107 + 0.59410844876457 + 0.58331552345175 + 0.57236585447946 + 0.56130085621619 + 0.55016561239164 + 0.53899294706780 + 0.52780888371381 + 0.51664298018041 + 0.50551389643145 + 0.49442694904857 + 0.99941518045027 + 0.99944871395466 + 0.99945457225236 + 0.99946152410165 + 0.99946980532590 + 0.99947971840747 + 0.99949166029680 + 0.99950616808775 + 0.99952400058542 + 0.99954630412785 + 0.99957498885645 + 0.99961354479672 + 0.99966914359382 + 0.99976134386637 + 1.00000000000000 + 0.99973849782626 + 0.99961205484017 + 0.99951533870347 + 0.99942861343871 + 0.99934449930828 + 0.99925932448831 + 0.99917083775293 + 0.99907744058210 + 0.99897787319739 + 0.99887104620494 + 0.99875585982751 + 0.99863098533852 + 0.99849506012575 + 0.99834692214613 + 0.99818543490831 + 0.99800911540851 + 0.99781634781617 + 0.99760524812203 + 0.99737352489379 + 0.99711837495867 + 0.99683637247648 + 0.99652336299712 + 0.99617437614484 + 0.99578336064303 + 0.99534313036941 + 0.99484572075418 + 0.99428210974419 + 0.99364218905568 + 0.99291534444026 + 0.99209419707644 + 0.99117469174611 + 0.99014645392944 + 0.98899788988591 + 0.98772313987304 + 0.98631150696887 + 0.98474571466969 + 0.98300685430941 + 0.98107536625386 + 0.97893060578362 + 0.97654857754280 + 0.97390143735892 + 0.97095623840782 + 0.96767259821355 + 0.96400297501494 + 0.95989425931795 + 0.95528749113041 + 0.95011208688928 + 0.94429479195963 + 0.93777590316783 + 0.93050578516619 + 0.92243933608921 + 0.91354215914608 + 0.90379137552914 + 0.89317808358811 + 0.88171106181635 + 0.86942216929266 + 0.85637231971114 + 0.84265030653050 + 0.82835835482160 + 0.81362130351967 + 0.79860319868418 + 0.78348182769338 + 0.77592921569276 + 0.76840846453550 + 0.76093336614615 + 0.75351413737546 + 0.74615709599476 + 0.73886446571103 + 0.73163435651162 + 0.72446101112446 + 0.71733530346842 + 0.71024273765165 + 0.70311845192151 + 0.69576982310143 + 0.68809672859167 + 0.68008826020196 + 0.67173432690237 + 0.66304402018051 + 0.65403020838273 + 0.64470854288638 + 0.63509692888671 + 0.62521552950945 + 0.61508589797350 + 0.60470862464066 + 0.59410845468241 + 0.58331552879737 + 0.57236585928460 + 0.56130086051548 + 0.55016561622222 + 0.53899295046819 + 0.52780888672292 + 0.51664298283759 + 0.50551389877430 + 0.49442695111392 + 0.99937370118383 + 0.99940399338894 + 0.99940923160476 + 0.99941542478112 + 0.99942276846713 + 0.99943150838574 + 0.99944195872290 + 0.99945453062168 + 0.99946978066363 + 0.99948850656956 + 0.99951195790386 + 0.99954221759697 + 0.99958290968038 + 0.99964144165789 + 0.99973849782626 + 1.00000000000000 + 0.99971423607258 + 0.99958081419354 + 0.99947783299417 + 0.99938442396684 + 0.99929307338836 + 0.99920006150097 + 0.99910311467113 + 0.99900062223593 + 0.99889129760317 + 0.99877392286190 + 0.99864709414125 + 0.99850940277868 + 0.99835966072798 + 0.99819671587834 + 0.99801907343790 + 0.99782510953355 + 0.99761293349397 + 0.99738024745650 + 0.99712424162203 + 0.99684148304651 + 0.99652780949208 + 0.99617824213649 + 0.99578672067256 + 0.99534605002286 + 0.99484825739754 + 0.99428431324679 + 0.99364410264445 + 0.99291700572097 + 0.99209563939093 + 0.99117594474373 + 0.99014754305186 + 0.98899883701345 + 0.98772396426646 + 0.98631222529926 + 0.98474634122925 + 0.98300740144094 + 0.98107584470560 + 0.97893102493111 + 0.97654894555656 + 0.97390176134893 + 0.97095652455140 + 0.96767285185044 + 0.96400320072003 + 0.95989446098598 + 0.95528767203116 + 0.95011224970932 + 0.94429493888254 + 0.93777603602632 + 0.93050590550733 + 0.92243944521948 + 0.91354225817412 + 0.90379146539694 + 0.89317816509784 + 0.88171113565998 + 0.86942223606992 + 0.85637237995127 + 0.84265036070755 + 0.82835840336938 + 0.81362134685030 + 0.79860323721904 + 0.78348186186692 + 0.77592924784724 + 0.76840849478371 + 0.76093339460020 + 0.75351416414829 + 0.74615712119120 + 0.73886448943892 + 0.73163437887133 + 0.72446103221255 + 0.71733532337667 + 0.71024275646396 + 0.70311846970618 + 0.69576983989631 + 0.68809674442269 + 0.68008827508934 + 0.67173434086480 + 0.66304403323462 + 0.65403022054728 + 0.64470855417871 + 0.63509693932814 + 0.62521553912407 + 0.61508590678763 + 0.60470863268353 + 0.59410846198610 + 0.58331553539809 + 0.57236586522159 + 0.56130086583052 + 0.55016562096149 + 0.53899295467848 + 0.52780889045169 + 0.51664298613387 + 0.50551390168322 + 0.49442695368018 + 0.99932848431783 + 0.99935594755489 + 0.99936065831284 + 0.99936621205214 + 0.99937277441947 + 0.99938055029678 + 0.99938979645790 + 0.99940084046386 + 0.99941411170333 + 0.99943020243242 + 0.99945000268026 + 0.99947490946882 + 0.99950709238706 + 0.99955025441687 + 0.99961205484017 + 0.99971423607258 + 1.00000000000000 + 0.99968849688290 + 0.99954746895072 + 0.99943732209371 + 0.99933630538503 + 0.99923677718712 + 0.99913498362670 + 0.99902863612861 + 0.99891609803076 + 0.99879595453589 + 0.99866668262474 + 0.99852680232387 + 0.99837508505628 + 0.99821035421657 + 0.99803109707217 + 0.99783567753141 + 0.99762219510193 + 0.99738834284864 + 0.99713130201172 + 0.99684763035974 + 0.99653315574635 + 0.99618288875907 + 0.99579075793957 + 0.99534955720391 + 0.99485130374349 + 0.99428695888285 + 0.99364639965637 + 0.99291899941132 + 0.99209736995623 + 0.99117744795396 + 0.99014884957806 + 0.98899997322469 + 0.98772495336851 + 0.98631308735108 + 0.98474709339369 + 0.98300805852267 + 0.98107641957354 + 0.97893152880847 + 0.97654938821250 + 0.97390215128431 + 0.97095686915357 + 0.96767315750142 + 0.96400347288611 + 0.95989470431689 + 0.95528789043478 + 0.95011244639097 + 0.94429511645156 + 0.93777619666962 + 0.93050605107560 + 0.92243957727806 + 0.91354237805275 + 0.90379157422662 + 0.89317826384632 + 0.88171122516080 + 0.86942231704654 + 0.85637245304083 + 0.84265042648173 + 0.82835846235248 + 0.81362139954120 + 0.79860328412387 + 0.78348190350886 + 0.77592928705512 + 0.76840853169266 + 0.76093342934388 + 0.75351419685988 + 0.74615715200159 + 0.73886451847289 + 0.73163440625302 + 0.72446105805619 + 0.71733534778966 + 0.71024277954719 + 0.70311849154101 + 0.69576986052917 + 0.68809676388103 + 0.68008829339650 + 0.67173435804145 + 0.66304404930001 + 0.65403023552226 + 0.64470856808616 + 0.63509695219270 + 0.62521555097369 + 0.61508591765633 + 0.60470864260463 + 0.59410847099991 + 0.58331554354869 + 0.57236587255611 + 0.56130087240145 + 0.55016562682351 + 0.53899295988990 + 0.52780889507113 + 0.51664299021931 + 0.50551390529272 + 0.49442695686716 + 0.99927906290230 + 0.99930403460554 + 0.99930829069918 + 0.99931329736479 + 0.99931919737382 + 0.99932616516982 + 0.99933441606358 + 0.99934421949915 + 0.99935592031618 + 0.99936998126636 + 0.99938707924277 + 0.99940823663192 + 0.99943492147398 + 0.99946934903132 + 0.99951533870347 + 0.99958081419354 + 0.99968849688290 + 1.00000000000000 + 0.99966114464719 + 0.99951168201288 + 0.99939337911586 + 0.99928372840283 + 0.99917499953169 + 0.99906341336974 + 0.99894665352511 + 0.99882295444162 + 0.99869059426430 + 0.99854797814012 + 0.99839381253607 + 0.99822688171939 + 0.99804564518445 + 0.99784844805671 + 0.99763337518911 + 0.99739810666807 + 0.99713981143296 + 0.99685503495618 + 0.99653959233822 + 0.99618848081658 + 0.99579561504262 + 0.99535377536520 + 0.99485496669421 + 0.99429013922851 + 0.99364916024840 + 0.99292139489425 + 0.99209944883587 + 0.99117925344397 + 0.99015041870153 + 0.98900133779871 + 0.98772614137832 + 0.98631412297190 + 0.98474799726745 + 0.98300884843076 + 0.98107711094544 + 0.97893213509298 + 0.97654992111094 + 0.97390262098222 + 0.97095728449470 + 0.96767352611437 + 0.96400380131614 + 0.95989499812768 + 0.95528815429867 + 0.95011268413289 + 0.94429533119414 + 0.93777639102287 + 0.93050622725946 + 0.92243973717083 + 0.91354252325097 + 0.90379170609162 + 0.89317838354395 + 0.88171133369416 + 0.86942241528735 + 0.85637254176018 + 0.84265050637204 + 0.82835853404340 + 0.81362146363723 + 0.79860334123698 + 0.78348195426869 + 0.77592933487747 + 0.76840857673695 + 0.76093347177522 + 0.75351423683639 + 0.74615718968087 + 0.73886455400769 + 0.73163443978687 + 0.72446108972704 + 0.71733537772795 + 0.71024280787185 + 0.70311851835051 + 0.69576988587622 + 0.68809678779499 + 0.68008831590595 + 0.67173437916924 + 0.66304406906977 + 0.65403025395720 + 0.64470858521259 + 0.63509696803919 + 0.62521556557630 + 0.61508593105374 + 0.60470865484032 + 0.59410848212170 + 0.58331555360942 + 0.57236588161474 + 0.56130088052145 + 0.55016563407298 + 0.53899296633892 + 0.52780890079172 + 0.51664299528332 + 0.50551390977062 + 0.49442696082450 + 0.99922490904203 + 0.99924766567528 + 0.99925152473219 + 0.99925605659050 + 0.99926138599879 + 0.99926766396418 + 0.99927507471536 + 0.99928384548943 + 0.99929426198879 + 0.99930670017710 + 0.99932170056286 + 0.99934006001320 + 0.99936286302668 + 0.99939161348088 + 0.99942861343871 + 0.99947783299417 + 0.99954746895072 + 0.99966114464719 + 1.00000000000000 + 0.99963200933904 + 0.99947314443061 + 0.99934555014320 + 0.99922613319315 + 0.99910709615492 + 0.99898462207788 + 0.99885626196031 + 0.99871993941164 + 0.99857386516932 + 0.99841663787906 + 0.99824697777599 + 0.99806330051041 + 0.99786392190693 + 0.99764690462406 + 0.99740990988916 + 0.99715008948435 + 0.99686397235988 + 0.99654735699080 + 0.99619522361498 + 0.99580146945975 + 0.99535885803513 + 0.99485937911631 + 0.99429396929000 + 0.99365248394832 + 0.99292427828051 + 0.99210195056173 + 0.99118142579765 + 0.99015230646744 + 0.98900297943150 + 0.98772757070385 + 0.98631536917684 + 0.98474908522702 + 0.98300979953679 + 0.98107794374506 + 0.97893286573793 + 0.97655056364259 + 0.97390318761545 + 0.97095778583771 + 0.96767397132160 + 0.96400419822798 + 0.95989535340999 + 0.95528847354548 + 0.95011297192343 + 0.94429559126038 + 0.93777662649678 + 0.93050644080020 + 0.92243993103573 + 0.91354269935943 + 0.90379186608504 + 0.89317852882877 + 0.88171146548220 + 0.86942253463643 + 0.85637264960006 + 0.84265060353782 + 0.82835862130037 + 0.81362154171464 + 0.79860341087416 + 0.78348201622791 + 0.77592939328174 + 0.76840863178541 + 0.76093352366274 + 0.75351428575574 + 0.74615723581940 + 0.73886459754792 + 0.73163448090331 + 0.72446112858705 + 0.71733541448549 + 0.71024284266873 + 0.70311855130359 + 0.69576991704825 + 0.68809681721901 + 0.68008834361429 + 0.67173440518648 + 0.66304409342345 + 0.65403027667407 + 0.64470860632375 + 0.63509698758130 + 0.62521558358937 + 0.61508594758788 + 0.60470866994593 + 0.59410849585836 + 0.58331556604199 + 0.57236589281460 + 0.56130089056657 + 0.55016564304611 + 0.53899297432637 + 0.52780890788309 + 0.51664300156649 + 0.50551391533040 + 0.49442696574224 + 0.99916543567899 + 0.99918620379036 + 0.99918971167902 + 0.99919382568308 + 0.99919865596679 + 0.99920433492960 + 0.99921102267650 + 0.99921891455925 + 0.99922825298836 + 0.99923935251681 + 0.99925266036892 + 0.99926882586556 + 0.99928870072738 + 0.99931339939630 + 0.99934449930828 + 0.99938442396684 + 0.99943732209371 + 0.99951168201288 + 0.99963200933904 + 1.00000000000000 + 0.99960098587454 + 0.99943152456051 + 0.99929335266560 + 0.99916292533300 + 0.99903236796418 + 0.99889771784471 + 0.99875620720275 + 0.99860569598287 + 0.99844459568065 + 0.99827151841447 + 0.99808480881724 + 0.99788273614568 + 0.99766332886810 + 0.99742422032681 + 0.99716253793066 + 0.99687478806368 + 0.99655674721565 + 0.99620337370284 + 0.99580854270229 + 0.99536499665888 + 0.99486470657931 + 0.99429859229660 + 0.99365649464933 + 0.99292775671024 + 0.99210496781920 + 0.99118404531009 + 0.99015458253085 + 0.98900495863737 + 0.98772929403802 + 0.98631687195608 + 0.98475039750971 + 0.98301094712282 + 0.98107894897478 + 0.97893374804846 + 0.97655133993221 + 0.97390387256894 + 0.97095839221075 + 0.96767451011542 + 0.96400467885682 + 0.95989578387739 + 0.95528886056580 + 0.95011332098861 + 0.94429590684331 + 0.93777691235449 + 0.93050670012924 + 0.92244016655171 + 0.91354291338115 + 0.90379206059181 + 0.89317870552071 + 0.88171162582930 + 0.86942267991596 + 0.85637278093978 + 0.84265072195285 + 0.82835872771570 + 0.81362163701287 + 0.79860349594922 + 0.78348209200590 + 0.77592946475549 + 0.76840869919380 + 0.76093358724079 + 0.75351434573571 + 0.74615729242907 + 0.73886465100546 + 0.73163453141966 + 0.72446117636109 + 0.71733545970203 + 0.71024288550046 + 0.70311859188899 + 0.69576995545785 + 0.68809685349447 + 0.68008837778649 + 0.67173443728694 + 0.66304412348076 + 0.65403030472180 + 0.64470863239867 + 0.63509701172659 + 0.62521560585419 + 0.61508596803108 + 0.60470868863131 + 0.59410851285664 + 0.58331558143413 + 0.57236590668825 + 0.56130090301732 + 0.55016565417493 + 0.53899298424092 + 0.52780891669097 + 0.51664300937615 + 0.50551392224751 + 0.49442697186604 + 0.99910005398490 + 0.99911902048082 + 0.99912221406817 + 0.99912595560681 + 0.99913034315080 + 0.99913549390051 + 0.99914154864113 + 0.99914867775362 + 0.99915709061659 + 0.99916705620444 + 0.99917895419198 + 0.99919333039621 + 0.99921088268218 + 0.99923248802853 + 0.99925932448831 + 0.99929307338836 + 0.99933630538503 + 0.99939337911586 + 0.99947314443061 + 0.99960098587454 + 1.00000000000000 + 0.99956787091993 + 0.99938639198756 + 0.99923620880861 + 0.99909339902281 + 0.99894989785663 + 0.99880140524549 + 0.99864509085273 + 0.99847902152079 + 0.99830161923919 + 0.99811110985735 + 0.99790568686936 + 0.99768332502218 + 0.99744161559298 + 0.99717765072893 + 0.99688790539655 + 0.99656812657510 + 0.99621324395575 + 0.99581710449948 + 0.99537242408448 + 0.99487115027934 + 0.99430418217011 + 0.99366134270768 + 0.99293196014489 + 0.99210861298326 + 0.99118720928055 + 0.99015733125391 + 0.98900734866474 + 0.98773137511544 + 0.98631868691270 + 0.98475198272321 + 0.98301233377421 + 0.98108016403100 + 0.97893481494914 + 0.97655227904470 + 0.97390470159567 + 0.97095912651021 + 0.96767516293309 + 0.96400526152902 + 0.95989630602240 + 0.95528933025354 + 0.95011374481358 + 0.94429629018094 + 0.93777725971761 + 0.93050701536696 + 0.92244045293792 + 0.91354317371352 + 0.90379229726523 + 0.89317892059702 + 0.88171182108591 + 0.86942285690398 + 0.85637294103074 + 0.84265086637554 + 0.82835885759101 + 0.81362175341329 + 0.79860359996080 + 0.78348218474491 + 0.77592955227735 + 0.76840878178598 + 0.76093366518877 + 0.75351441931868 + 0.74615736192197 + 0.73886471667296 + 0.73163459351396 + 0.72446123512000 + 0.71733551534993 + 0.71024293824158 + 0.70311864189003 + 0.69577000280383 + 0.68809689822582 + 0.68008841994415 + 0.67173447690304 + 0.66304416058933 + 0.65403033936179 + 0.64470866461123 + 0.63509704156469 + 0.62521563337892 + 0.61508599331265 + 0.60470871174790 + 0.59410853389664 + 0.58331560049388 + 0.57236592387684 + 0.56130091845073 + 0.55016566797956 + 0.53899299654750 + 0.52780892763145 + 0.51664301908452 + 0.50551393085375 + 0.49442697949085 + 0.99902814684755 + 0.99904546691275 + 0.99904837609621 + 0.99905178169904 + 0.99905577147688 + 0.99906044988870 + 0.99906594178081 + 0.99907239731621 + 0.99907999970304 + 0.99908898259334 + 0.99909967422093 + 0.99911254338264 + 0.99912817877093 + 0.99914729948750 + 0.99917083775293 + 0.99920006150097 + 0.99923677718712 + 0.99928372840283 + 0.99934555014320 + 0.99943152456051 + 0.99956787091993 + 1.00000000000000 + 0.99953241348501 + 0.99933725459238 + 0.99917345379636 + 0.99901664385385 + 0.99885836956061 + 0.99869426055740 + 0.99852169495348 + 0.99833874132639 + 0.99814341846191 + 0.99793379280473 + 0.99770775258040 + 0.99746282420871 + 0.99719604767724 + 0.99690385338158 + 0.99658194795565 + 0.99622522313112 + 0.99582748935755 + 0.99538142865623 + 0.99487895908644 + 0.99431095386397 + 0.99366721381315 + 0.99293704899090 + 0.99211302467816 + 0.99119103767035 + 0.99016065659519 + 0.98901023974130 + 0.98773389241445 + 0.98632088246910 + 0.98475390066625 + 0.98301401186414 + 0.98108163488929 + 0.97893610690808 + 0.97655341670489 + 0.97390570633182 + 0.97096001686803 + 0.96767595489067 + 0.96400596874683 + 0.95989694009566 + 0.95528990090018 + 0.95011425996950 + 0.94429675630285 + 0.93777768224480 + 0.93050739893707 + 0.92244080150498 + 0.91354349066256 + 0.90379258550026 + 0.89317918261587 + 0.88171205904959 + 0.86942307269743 + 0.85637313631716 + 0.84265104265063 + 0.82835901621777 + 0.81362189569059 + 0.79860372720444 + 0.78348229831428 + 0.77592965951537 + 0.76840888304190 + 0.76093376080443 + 0.75351450963758 + 0.74615744727295 + 0.73886479737476 + 0.73163466987039 + 0.72446130741783 + 0.71733558386012 + 0.71024300320886 + 0.70311870351279 + 0.69577006118060 + 0.68809695340543 + 0.68008847196688 + 0.67173452580695 + 0.66304420641428 + 0.65403038214980 + 0.64470870441551 + 0.63509707844562 + 0.62521566741297 + 0.61508602458471 + 0.60470874035389 + 0.59410855994209 + 0.58331562410021 + 0.57236594517460 + 0.56130093758489 + 0.55016568510448 + 0.53899301182337 + 0.52780894122236 + 0.51664303115356 + 0.50551394156094 + 0.49442698898655 + 0.99894907260907 + 0.99896487658056 + 0.99896752593759 + 0.99897062542479 + 0.99897425386115 + 0.99897850476603 + 0.99898348947968 + 0.99898934130385 + 0.99899622199271 + 0.99900433674787 + 0.99901397286726 + 0.99902553887097 + 0.99903954119389 + 0.99905658612704 + 0.99907744058210 + 0.99910311467113 + 0.99913498362670 + 0.99917499953169 + 0.99922613319315 + 0.99929335266560 + 0.99938639198756 + 0.99953241348501 + 1.00000000000000 + 0.99949430497117 + 0.99928352799665 + 0.99910419984420 + 0.99893132270937 + 0.99875633050671 + 0.99857504888286 + 0.99838483621869 + 0.99818332973034 + 0.99796837415640 + 0.99773771405268 + 0.99748877311116 + 0.99721851232508 + 0.99692329737891 + 0.99659877864153 + 0.99623979667521 + 0.99584011396558 + 0.99539236890469 + 0.99488844201156 + 0.99431917397794 + 0.99367433808145 + 0.99294322187723 + 0.99211837444425 + 0.99119567884507 + 0.99016468705649 + 0.98901374331889 + 0.98773694283157 + 0.98632354307423 + 0.98475622510402 + 0.98301604597435 + 0.98108341821811 + 0.97893767377943 + 0.97655479690978 + 0.97390692573579 + 0.97096109791049 + 0.96767691689269 + 0.96400682821690 + 0.95989771102930 + 0.95529059501860 + 0.95011488683394 + 0.94429732370305 + 0.93777819673059 + 0.93050786611708 + 0.92244122616506 + 0.91354387690282 + 0.90379293684445 + 0.89317950210280 + 0.88171234930840 + 0.86942333601969 + 0.85637337472771 + 0.84265125796759 + 0.82835921010080 + 0.81362206971878 + 0.79860388297826 + 0.78348243747723 + 0.77592979098945 + 0.76840900724815 + 0.76093387816179 + 0.75351462055399 + 0.74615755215073 + 0.73886489659751 + 0.73163476380540 + 0.72446139641266 + 0.71733566823674 + 0.71024308326280 + 0.70311877948332 + 0.69577013317915 + 0.68809702148752 + 0.68008853617798 + 0.67173458619071 + 0.66304426301285 + 0.65403043501550 + 0.64470875360898 + 0.63509712404166 + 0.62521570950083 + 0.61508606327191 + 0.60470877575428 + 0.59410859218740 + 0.58331565333724 + 0.57236597156661 + 0.56130096130800 + 0.55016570634923 + 0.53899303078694 + 0.52780895810573 + 0.51664304615812 + 0.50551395488156 + 0.49442700080900 + 0.99886216542264 + 0.99887656458075 + 0.99887897468820 + 0.99888179287399 + 0.99888509005959 + 0.99888895018266 + 0.99889347288253 + 0.99889877702508 + 0.99890500626032 + 0.99891234209072 + 0.99892103802775 + 0.99893145339428 + 0.99894402948514 + 0.99895928697971 + 0.99897787319739 + 0.99900062223593 + 0.99902863612861 + 0.99906341336974 + 0.99910709615492 + 0.99916292533300 + 0.99923620880861 + 0.99933725459238 + 0.99949430497117 + 1.00000000000000 + 0.99945314340030 + 0.99922438308703 + 0.99902709475894 + 0.99883595276293 + 0.99864252936236 + 0.99844257968718 + 0.99823298102926 + 0.99801116997314 + 0.99777464274393 + 0.99752065501676 + 0.99724604470241 + 0.99694708112554 + 0.99661933437352 + 0.99625757463465 + 0.99585550037756 + 0.99540569297504 + 0.99489998462589 + 0.99432917471795 + 0.99368300193153 + 0.99295072582412 + 0.99212487545790 + 0.99120131705176 + 0.99016958211409 + 0.98901799765066 + 0.98774064648042 + 0.98632677335469 + 0.98475904738764 + 0.98301851603486 + 0.98108558412032 + 0.97893957721685 + 0.97655647403359 + 0.97390840794118 + 0.97096241241084 + 0.96767808710618 + 0.96400787413739 + 0.95989864958696 + 0.95529144038453 + 0.95011565056147 + 0.94429801518946 + 0.93777882389911 + 0.93050843575168 + 0.92244174406731 + 0.91354434805682 + 0.90379336553448 + 0.89317989202600 + 0.88171270366912 + 0.86942365761415 + 0.85637366602745 + 0.84265152118903 + 0.82835944726060 + 0.81362228274301 + 0.79860407380770 + 0.78348260811468 + 0.77592995227860 + 0.76840915969905 + 0.76093402228135 + 0.75351475684256 + 0.74615768108885 + 0.73886501865081 + 0.73163487942045 + 0.72446150600597 + 0.71733577219695 + 0.71024318194617 + 0.70311887317460 + 0.69577022200937 + 0.68809710551716 + 0.68008861546053 + 0.67173466076748 + 0.66304433293825 + 0.65403050034771 + 0.64470881442143 + 0.63509718042317 + 0.62521576156107 + 0.61508611114051 + 0.60470881957255 + 0.59410863211692 + 0.58331568955764 + 0.57236600427731 + 0.56130099072621 + 0.55016573270858 + 0.53899305433013 + 0.52780897907974 + 0.51664306481197 + 0.50551397145537 + 0.49442701553024 + 0.99876671847444 + 0.99877980970255 + 0.99878199815778 + 0.99878455614891 + 0.99878754751460 + 0.99879104766337 + 0.99879514590319 + 0.99879994848561 + 0.99880558340357 + 0.99881221189196 + 0.99882005871568 + 0.99882944169286 + 0.99884074844468 + 0.99885443143805 + 0.99887104620494 + 0.99889129760317 + 0.99891609803076 + 0.99894665352511 + 0.99898462207788 + 0.99903236796418 + 0.99909339902281 + 0.99917345379636 + 0.99928352799665 + 0.99945314340030 + 1.00000000000000 + 0.99940827216525 + 0.99915848879969 + 0.99894064311000 + 0.99872928290759 + 0.99851578291262 + 0.99829532211878 + 0.99806452671251 + 0.99782044014373 + 0.99756003175656 + 0.99727994104845 + 0.99697628953996 + 0.99664452970218 + 0.99627933270416 + 0.99587430989668 + 0.99542196691573 + 0.99491407286557 + 0.99434137405672 + 0.99369356527089 + 0.99295987089231 + 0.99213279506350 + 0.99120818317533 + 0.99017554148679 + 0.98902317575480 + 0.98774515360238 + 0.98633070410877 + 0.98476248165753 + 0.98302152188273 + 0.98108822013403 + 0.97894189416415 + 0.97655851593476 + 0.97391021299678 + 0.97096401372116 + 0.96767951313829 + 0.96400914916001 + 0.95989979414020 + 0.95529247164301 + 0.95011658250979 + 0.94429885920191 + 0.93777958957213 + 0.93050913132031 + 0.92244237658340 + 0.91354492358238 + 0.90379388929782 + 0.89318036853831 + 0.88171313684674 + 0.86942405087460 + 0.85637402238717 + 0.84265184335615 + 0.82835973769933 + 0.81362254379501 + 0.79860430784181 + 0.78348281756921 + 0.77593015034999 + 0.76840934701139 + 0.76093419944935 + 0.75351492446700 + 0.74615783976026 + 0.73886516893253 + 0.73163502184630 + 0.72446164108220 + 0.71733590039450 + 0.71024330369195 + 0.70311898881187 + 0.69577033169229 + 0.68809720931165 + 0.68008871342170 + 0.67173475294715 + 0.66304441939055 + 0.65403058114384 + 0.64470888965015 + 0.63509725019100 + 0.62521582600098 + 0.61508617041122 + 0.60470887384700 + 0.59410868159213 + 0.58331573445622 + 0.57236604484419 + 0.56130102722856 + 0.55016576543398 + 0.53899308357710 + 0.52780900515278 + 0.51664308801617 + 0.50551399208700 + 0.49442703386992 + 0.99866188928604 + 0.99867375825221 + 0.99867574038028 + 0.99867805646645 + 0.99868076392470 + 0.99868393047497 + 0.99868763616790 + 0.99869197603314 + 0.99869706427577 + 0.99870304439732 + 0.99871011614047 + 0.99871856138796 + 0.99872872213267 + 0.99874099437758 + 0.99875585982751 + 0.99877392286190 + 0.99879595453589 + 0.99882295444162 + 0.99885626196031 + 0.99889771784471 + 0.99894989785663 + 0.99901664385385 + 0.99910419984420 + 0.99922438308703 + 0.99940827216525 + 1.00000000000000 + 0.99935859967096 + 0.99908447819449 + 0.99884370768251 + 0.99861022967318 + 0.99837463662605 + 0.99813175270087 + 0.99787773097565 + 0.99760902530500 + 0.99732194127324 + 0.99701236524015 + 0.99667557181645 + 0.99630608896732 + 0.99589740668168 + 0.99544192792995 + 0.99493133799427 + 0.99435631390898 + 0.99370649400809 + 0.99297105798821 + 0.99214247859842 + 0.99121657525400 + 0.99018282283706 + 0.98902950078747 + 0.98775065796703 + 0.98633550405427 + 0.98476667518433 + 0.98302519238059 + 0.98109143929298 + 0.97894472405760 + 0.97656101035182 + 0.97391241860177 + 0.97096597093059 + 0.96768125667400 + 0.96401070860658 + 0.95990119450133 + 0.95529373379783 + 0.95011772344883 + 0.94429989273758 + 0.93778052737390 + 0.93050998341081 + 0.92244315156496 + 0.91354562886303 + 0.90379453127157 + 0.89318095273481 + 0.88171366806604 + 0.86942453330609 + 0.85637445973455 + 0.84265223893641 + 0.82836009452660 + 0.81362286473581 + 0.79860459579164 + 0.78348307549965 + 0.77593039437963 + 0.76840957789645 + 0.76093441794347 + 0.75351513130366 + 0.74615803565010 + 0.73886535456272 + 0.73163519786739 + 0.72446180810751 + 0.71733605899065 + 0.71024345437736 + 0.70311913199811 + 0.69577046755927 + 0.68809733793105 + 0.68008883485411 + 0.67173486724549 + 0.66304452662246 + 0.65403068138798 + 0.64470898301121 + 0.63509733680040 + 0.62521590602072 + 0.61508624403563 + 0.60470894128819 + 0.59410874309474 + 0.58331579029073 + 0.57236609531564 + 0.56130107266780 + 0.55016580619392 + 0.53899312002839 + 0.52780903767022 + 0.51664311697571 + 0.50551401785686 + 0.49442705679309 + 0.99854653069086 + 0.99855725390719 + 0.99855904321822 + 0.99856113345787 + 0.99856357616186 + 0.99856643203691 + 0.99856977274548 + 0.99857368320471 + 0.99857826526835 + 0.99858364666601 + 0.99859000494210 + 0.99859759023416 + 0.99860670479632 + 0.99861769645517 + 0.99863098533852 + 0.99864709414125 + 0.99866668262474 + 0.99869059426430 + 0.99871993941164 + 0.99875620720275 + 0.99880140524549 + 0.99885836956061 + 0.99893132270937 + 0.99902709475894 + 0.99915848879969 + 0.99935859967096 + 1.00000000000000 + 0.99930332534652 + 0.99900163432396 + 0.99873553283544 + 0.99847758811119 + 0.99821779082835 + 0.99795033189177 + 0.99767066210489 + 0.99737449156214 + 0.99705731453851 + 0.99671412570352 + 0.99633923866197 + 0.99592596924369 + 0.99546657767931 + 0.99495263530947 + 0.99437472692584 + 0.99372241699641 + 0.99298482752451 + 0.99215439115009 + 0.99122689446197 + 0.99019177296032 + 0.98903727316973 + 0.98775742058048 + 0.98634140067897 + 0.98477182683018 + 0.98302970181656 + 0.98109539476283 + 0.97894820189626 + 0.97656407666156 + 0.97391513070774 + 0.97096837845190 + 0.96768340221334 + 0.96401262841847 + 0.95990291918395 + 0.95529528888710 + 0.95011912969240 + 0.94430116700295 + 0.93778168391330 + 0.93051103449990 + 0.92244410775619 + 0.91354649925837 + 0.90379532374008 + 0.89318167409594 + 0.88171432423907 + 0.86942512946356 + 0.85637500044285 + 0.84265272828635 + 0.82836053623052 + 0.81362326231861 + 0.79860495280870 + 0.78348339560817 + 0.77593069739316 + 0.76840986474632 + 0.76093468954647 + 0.75351538856144 + 0.74615827943430 + 0.73886558571076 + 0.73163541717570 + 0.72446201632016 + 0.71733625680139 + 0.71024364241542 + 0.70311931076058 + 0.69577063725760 + 0.68809749863857 + 0.68008898663695 + 0.67173501015957 + 0.66304466074109 + 0.65403080680578 + 0.64470909985189 + 0.63509744522675 + 0.62521600623030 + 0.61508633626964 + 0.60470902580837 + 0.59410882020227 + 0.58331586032794 + 0.57236615865690 + 0.56130112972456 + 0.55016585740753 + 0.53899316585819 + 0.52780907858395 + 0.51664315344232 + 0.50551405033215 + 0.49442708570653 + 0.99841939285594 + 0.99842904161716 + 0.99843065054851 + 0.99843252966923 + 0.99843472510830 + 0.99843729114005 + 0.99844029175907 + 0.99844380269798 + 0.99844791463805 + 0.99845274111561 + 0.99845843973253 + 0.99846523220967 + 0.99847338560647 + 0.99848320577891 + 0.99849506012575 + 0.99850940277868 + 0.99852680232387 + 0.99854797814012 + 0.99857386516932 + 0.99860569598287 + 0.99864509085273 + 0.99869426055740 + 0.99875633050671 + 0.99883595276293 + 0.99894064311000 + 0.99908447819449 + 0.99930332534652 + 1.00000000000000 + 0.99924212015878 + 0.99890941774120 + 0.99861502465102 + 0.99833015585712 + 0.99804379808495 + 0.99774921579464 + 0.99744097057749 + 0.99711386281591 + 0.99676242452855 + 0.99638063504844 + 0.99596155147175 + 0.99549722953164 + 0.99497908159019 + 0.99439756676882 + 0.99374215086009 + 0.99300188003239 + 0.99216913477392 + 0.99123965959714 + 0.99020283999394 + 0.98904688090656 + 0.98776577845717 + 0.98634868770655 + 0.98477819334111 + 0.98303527526248 + 0.98110028439476 + 0.97895250212466 + 0.97656786918401 + 0.97391848634368 + 0.97097135846781 + 0.96768605916803 + 0.96401500698026 + 0.95990505702397 + 0.95529721739233 + 0.95012087433958 + 0.94430274848618 + 0.93778311975635 + 0.93051233980871 + 0.92244529554320 + 0.91354758077912 + 0.90379630873777 + 0.89318257102282 + 0.88171514044420 + 0.86942587136620 + 0.85637567371165 + 0.84265333799497 + 0.82836108697758 + 0.81362375846230 + 0.79860539874502 + 0.78348379585202 + 0.77593107647057 + 0.76841022380556 + 0.76093502972100 + 0.75351571096026 + 0.74615858513344 + 0.73886587573892 + 0.73163569250980 + 0.72446227787638 + 0.71733650542623 + 0.71024387888126 + 0.70311953567119 + 0.69577085085906 + 0.68809770100675 + 0.68008917783673 + 0.67173519024958 + 0.66304482980144 + 0.65403096494968 + 0.64470924723010 + 0.63509758203417 + 0.62521613271502 + 0.61508645272920 + 0.60470913257097 + 0.59410891764741 + 0.58331594887905 + 0.57236623878641 + 0.56130120194631 + 0.55016592227651 + 0.53899322394972 + 0.52780913048439 + 0.51664319973919 + 0.50551409159804 + 0.49442712247922 + 0.99827936974869 + 0.99828801430557 + 0.99828945497418 + 0.99829113728214 + 0.99829310237290 + 0.99829539861848 + 0.99829808299725 + 0.99830122286288 + 0.99830489875362 + 0.99830921136454 + 0.99831430029411 + 0.99832036165535 + 0.99832763107487 + 0.99833637739340 + 0.99834692214613 + 0.99835966072798 + 0.99837508505628 + 0.99839381253607 + 0.99841663787906 + 0.99844459568065 + 0.99847902152079 + 0.99852169495348 + 0.99857504888286 + 0.99864252936236 + 0.99872928290759 + 0.99884370768251 + 0.99900163432396 + 0.99924212015878 + 1.00000000000000 + 0.99917439855882 + 0.99880654942456 + 0.99848082641016 + 0.99816636871100 + 0.99785072980711 + 0.99752599643956 + 0.99718564224405 + 0.99682338785796 + 0.99643266568086 + 0.99600613296093 + 0.99553554261810 + 0.99501207876415 + 0.99442602495571 + 0.99376671229732 + 0.99302308532143 + 0.99218745544789 + 0.99125551233394 + 0.99021657734546 + 0.98905880244853 + 0.98777614655934 + 0.98635772624054 + 0.98478608991030 + 0.98304218858333 + 0.98110635030697 + 0.97895783787860 + 0.97657257618241 + 0.97392265242812 + 0.97097505959648 + 0.96768936044103 + 0.96401796366759 + 0.95990771566758 + 0.95529961672931 + 0.95012304577349 + 0.94430471750785 + 0.93778490796710 + 0.93051396588443 + 0.92244677560075 + 0.91354892877315 + 0.90379753678083 + 0.89318368963421 + 0.88171615877702 + 0.86942679742329 + 0.85637651454915 + 0.84265409992666 + 0.82836177571362 + 0.81362437940963 + 0.79860595735585 + 0.78348429772070 + 0.77593155205055 + 0.76841067451574 + 0.76093545696533 + 0.75351611611092 + 0.74615896951762 + 0.73886624062722 + 0.73163603910683 + 0.72446260730979 + 0.71733681873970 + 0.71024417701682 + 0.70311981937022 + 0.69577112040616 + 0.68809795647890 + 0.68008941929641 + 0.67173541775318 + 0.66304504344065 + 0.65403116485294 + 0.64470943357962 + 0.63509775507275 + 0.62521629274958 + 0.61508660013362 + 0.60470926775581 + 0.59410904108432 + 0.58331606110391 + 0.57236634039161 + 0.56130129357908 + 0.55016600463338 + 0.53899329775344 + 0.52780919647423 + 0.51664325865195 + 0.50551414415234 + 0.49442716935408 + 0.99812535375803 + 0.99813306493105 + 0.99813434944998 + 0.99813584919713 + 0.99813760074220 + 0.99813964704850 + 0.99814203868458 + 0.99814483536359 + 0.99814810841558 + 0.99815194690684 + 0.99815647415409 + 0.99816186317967 + 0.99816832143115 + 0.99817608491522 + 0.99818543490831 + 0.99819671587834 + 0.99821035421657 + 0.99822688171939 + 0.99824697777599 + 0.99827151841447 + 0.99830161923919 + 0.99833874132639 + 0.99838483621869 + 0.99844257968718 + 0.99851578291262 + 0.99861022967318 + 0.99873553283544 + 0.99890941774120 + 0.99917439855882 + 1.00000000000000 + 0.99909883545985 + 0.99869160838452 + 0.99833133335945 + 0.99798428561627 + 0.99763618862328 + 0.99727768634382 + 0.99690096162875 + 0.99649849704275 + 0.99606230191445 + 0.99558366300306 + 0.99505342571334 + 0.99446162127721 + 0.99379739232278 + 0.99304954415945 + 0.99221029474664 + 0.99127526092445 + 0.99023368087578 + 0.98907363848448 + 0.98778904513863 + 0.98636896840335 + 0.98479591064408 + 0.98305078627568 + 0.98111389446836 + 0.97896447465494 + 0.97657843185739 + 0.97392783636460 + 0.97097966629548 + 0.96769347081954 + 0.96402164633733 + 0.95991102832910 + 0.95530260734326 + 0.95012575316429 + 0.94430717317738 + 0.93778713864755 + 0.93051599471850 + 0.92244862259939 + 0.91355061131217 + 0.90379906995500 + 0.89318508657257 + 0.88171743091461 + 0.86942795475298 + 0.85637756588665 + 0.84265505314346 + 0.82836263792095 + 0.81362515733052 + 0.79860665775536 + 0.78348492754719 + 0.77593214917192 + 0.76841124069642 + 0.76093599394446 + 0.75351662558568 + 0.74615945313352 + 0.73886669995707 + 0.73163647563790 + 0.72446302243166 + 0.71733721373371 + 0.71024455305019 + 0.70312017734487 + 0.69577146065735 + 0.68809827907670 + 0.68008972429752 + 0.67173570521379 + 0.66304531345486 + 0.65403141757810 + 0.64470966923682 + 0.63509797396073 + 0.62521649525094 + 0.61508678671500 + 0.60470943893080 + 0.59410919744870 + 0.58331620332824 + 0.57236646922149 + 0.56130140982786 + 0.55016610917676 + 0.53899339150522 + 0.52780928035989 + 0.51664333360016 + 0.50551421106594 + 0.49442722908428 + 0.99795588680009 + 0.99796273531976 + 0.99796387570042 + 0.99796520700252 + 0.99796676160341 + 0.99796857752592 + 0.99797069948973 + 0.99797318026660 + 0.99797608283448 + 0.99797948573639 + 0.99798349758106 + 0.99798827054907 + 0.99799398682698 + 0.99800085319396 + 0.99800911540851 + 0.99801907343790 + 0.99803109707217 + 0.99804564518445 + 0.99806330051041 + 0.99808480881724 + 0.99811110985735 + 0.99814341846191 + 0.99818332973034 + 0.99823298102926 + 0.99829532211878 + 0.99837463662605 + 0.99847758811119 + 0.99861502465102 + 0.99880654942456 + 0.99909883545985 + 1.00000000000000 + 0.99901456179325 + 0.99856336075936 + 0.99816491454838 + 0.99778178870294 + 0.99739744198236 + 0.99700080168606 + 0.99658256377931 + 0.99613362139993 + 0.99564450778705 + 0.99510554485722 + 0.99450638826926 + 0.99383590875910 + 0.99308271573732 + 0.99223889741279 + 0.99129997171106 + 0.99025506732771 + 0.98909217957367 + 0.98780515843403 + 0.98638300862558 + 0.98480817362820 + 0.98306152121664 + 0.98112331390753 + 0.97897276160184 + 0.97658574433174 + 0.97393431112113 + 0.97098542144141 + 0.96769860738377 + 0.96402624987384 + 0.95991517067512 + 0.95530634813515 + 0.95012914060504 + 0.94431024636729 + 0.93778993079427 + 0.93051853463537 + 0.92245093524771 + 0.91355271839822 + 0.90380099037590 + 0.89318683678545 + 0.88171902526123 + 0.86942940576832 + 0.85637888462243 + 0.84265624945259 + 0.82836372068962 + 0.81362613493818 + 0.79860753863798 + 0.78348572035837 + 0.77593290116147 + 0.76841195405936 + 0.76093667084291 + 0.75351726813544 + 0.74616006337321 + 0.73886727984009 + 0.73163702700860 + 0.72446354701225 + 0.71733771311197 + 0.71024502865798 + 0.70312063029471 + 0.69577189133901 + 0.68809868755083 + 0.68009011061102 + 0.67173606941139 + 0.66304565564563 + 0.65403173794221 + 0.64470996804394 + 0.63509825158065 + 0.62521675216325 + 0.61508702350616 + 0.60470965624746 + 0.59410939603749 + 0.58331638403686 + 0.57236663299147 + 0.56130155768668 + 0.55016624222743 + 0.53899351089927 + 0.52780938726359 + 0.51664342918715 + 0.50551429647373 + 0.49442730538509 + 0.99776936905356 + 0.99777542588333 + 0.99777643412207 + 0.99777761104319 + 0.99777898521484 + 0.99778059016379 + 0.99778246530744 + 0.99778465712242 + 0.99778722104205 + 0.99779022612081 + 0.99779376771592 + 0.99779797927717 + 0.99780302036123 + 0.99780907174596 + 0.99781634781617 + 0.99782510953355 + 0.99783567753141 + 0.99784844805671 + 0.99786392190693 + 0.99788273614568 + 0.99790568686936 + 0.99793379280473 + 0.99796837415640 + 0.99801116997314 + 0.99806452671251 + 0.99813175270087 + 0.99821779082835 + 0.99833015585712 + 0.99848082641016 + 0.99869160838452 + 0.99901456179325 + 1.00000000000000 + 0.99892049272448 + 0.99842024846731 + 0.99797953697215 + 0.99755624465037 + 0.99713111263803 + 0.99669108122612 + 0.99622496075285 + 0.99572199014533 + 0.99517164170265 + 0.99456298863392 + 0.99388449537639 + 0.99312448705241 + 0.99227486644008 + 0.99133101358409 + 0.99028191059759 + 0.98911543597698 + 0.98782535935045 + 0.98640060408709 + 0.98482353789424 + 0.98307496876342 + 0.98113511241716 + 0.97898314124694 + 0.97659490367352 + 0.97394242189948 + 0.97099263187297 + 0.96770504412467 + 0.96403202002703 + 0.95992036404056 + 0.95531103915036 + 0.95013338935654 + 0.94431410156558 + 0.93779343385899 + 0.93052172157013 + 0.92245383729960 + 0.91355536280200 + 0.90380340086658 + 0.89318903406135 + 0.88172102737605 + 0.86943122849843 + 0.85638054186434 + 0.84265775358442 + 0.82836508284136 + 0.81362736559464 + 0.79860864833550 + 0.78348671990221 + 0.77593384964115 + 0.76841285421150 + 0.76093752536745 + 0.75351807966148 + 0.74616083444778 + 0.73886801289328 + 0.73163772433195 + 0.72446421074379 + 0.71733834521912 + 0.71024563091719 + 0.70312120407299 + 0.69577243709627 + 0.68809920532402 + 0.68009060043214 + 0.67173653131371 + 0.66304608974146 + 0.65403214444645 + 0.64471034728770 + 0.63509860402800 + 0.62521707840923 + 0.61508732429146 + 0.60470993238513 + 0.59410964847336 + 0.58331661383904 + 0.57236684134702 + 0.56130174589493 + 0.55016641168503 + 0.53899366305691 + 0.52780952359765 + 0.51664355117581 + 0.50551440555355 + 0.49442740291044 + 0.99756393214537 + 0.99756926798580 + 0.99757015598387 + 0.99757119246789 + 0.99757240255423 + 0.99757381571040 + 0.99757546656747 + 0.99757739593710 + 0.99757965245679 + 0.99758229666899 + 0.99758541205442 + 0.99758911528983 + 0.99759354574266 + 0.99759886112270 + 0.99760524812203 + 0.99761293349397 + 0.99762219510193 + 0.99763337518911 + 0.99764690462406 + 0.99766332886810 + 0.99768332502218 + 0.99770775258040 + 0.99773771405268 + 0.99777464274393 + 0.99782044014373 + 0.99787773097565 + 0.99795033189177 + 0.99804379808495 + 0.99816636871100 + 0.99833133335945 + 0.99856336075936 + 0.99892049272448 + 1.00000000000000 + 0.99881530302569 + 0.99826041175770 + 0.99777274673157 + 0.99730445760244 + 0.99683311317446 + 0.99634317846524 + 0.99582148503642 + 0.99525603967901 + 0.99463496640939 + 0.99394609659855 + 0.99317732769475 + 0.99232028859502 + 0.99137016144495 + 0.99031572806931 + 0.98914471036962 + 0.98785077119739 + 0.98642272754694 + 0.98484284887844 + 0.98309186603043 + 0.98114993463865 + 0.97899617917827 + 0.97660640788371 + 0.97395260895416 + 0.97100168853594 + 0.96771312981791 + 0.96403926936334 + 0.95992688970799 + 0.95531693441355 + 0.95013872940068 + 0.94431894730307 + 0.93779783714987 + 0.93052572757028 + 0.92245748527698 + 0.91355868702834 + 0.90380643127173 + 0.89319179676926 + 0.88172354518231 + 0.86943352132695 + 0.85638262724569 + 0.84265964710369 + 0.82836679848951 + 0.81362891651169 + 0.79861004771706 + 0.78348798127037 + 0.77593504702139 + 0.76841399102574 + 0.76093860498905 + 0.75351910538205 + 0.74616180943984 + 0.73886894018781 + 0.73163860678790 + 0.72446505102020 + 0.71733914576228 + 0.71024639392945 + 0.70312193124316 + 0.69577312896097 + 0.68809986189851 + 0.68009122171429 + 0.67173711732033 + 0.66304664059240 + 0.65403266039687 + 0.64471082874662 + 0.63509905156599 + 0.62521749278367 + 0.61508770642864 + 0.60471028331614 + 0.59410996938841 + 0.58331690609278 + 0.57236710643973 + 0.56130198546870 + 0.55016662750572 + 0.53899385695873 + 0.52780969744533 + 0.51664370683717 + 0.50551454484182 + 0.49442752753853 + 0.99733730392138 + 0.99734198834508 + 0.99734276778038 + 0.99734367749315 + 0.99734473949884 + 0.99734597962163 + 0.99734742819776 + 0.99734912096227 + 0.99735110048601 + 0.99735341970411 + 0.99735615150895 + 0.99735939764103 + 0.99736327954230 + 0.99736793452398 + 0.99737352489379 + 0.99738024745650 + 0.99738834284864 + 0.99739810666807 + 0.99740990988916 + 0.99742422032681 + 0.99744161559298 + 0.99746282420871 + 0.99748877311116 + 0.99752065501676 + 0.99756003175656 + 0.99760902530500 + 0.99767066210489 + 0.99774921579464 + 0.99785072980711 + 0.99798428561627 + 0.99816491454838 + 0.99842024846731 + 0.99881530302569 + 1.00000000000000 + 0.99869749200869 + 0.99808169435994 + 0.99754163290407 + 0.99702260784255 + 0.99649831955621 + 0.99595059516436 + 0.99536470440735 + 0.99472712573825 + 0.99402465288586 + 0.99324451188593 + 0.99237791161191 + 0.99141974047126 + 0.99035849989404 + 0.98918169763405 + 0.98788285204364 + 0.98645063923195 + 0.98486720008341 + 0.98311316508229 + 0.98116861214173 + 0.97901260413927 + 0.97662089791635 + 0.97396543834581 + 0.97101309361726 + 0.96772331208847 + 0.96404839870614 + 0.95993510808975 + 0.95532435915356 + 0.95014545494421 + 0.94432505013530 + 0.93780338245351 + 0.93053077220206 + 0.92246207876501 + 0.91356287267406 + 0.90381024694112 + 0.89319527554679 + 0.88172671595372 + 0.86943640933364 + 0.85638525467304 + 0.84266203364035 + 0.82836896176535 + 0.81363087305016 + 0.79861181408134 + 0.78348957441807 + 0.77593655985437 + 0.76841542783427 + 0.76093996999293 + 0.75352040270265 + 0.74616304305117 + 0.73887011387818 + 0.73163972412422 + 0.72446611532081 + 0.71734016007561 + 0.71024736099830 + 0.70312285315613 + 0.69577400634996 + 0.68810069473294 + 0.68009200995966 + 0.67173786095707 + 0.66304733975313 + 0.65403331538263 + 0.64471144006082 + 0.63509961993056 + 0.62521801914552 + 0.61508819196025 + 0.60471072931620 + 0.59411037736943 + 0.58331727776345 + 0.57236744370253 + 0.56130229040097 + 0.55016690234098 + 0.53899410401655 + 0.52780991908541 + 0.51664390541774 + 0.50551472265634 + 0.49442768674643 + 0.99708670512959 + 0.99709080567598 + 0.99709148785884 + 0.99709228402662 + 0.99709321342741 + 0.99709429863813 + 0.99709556616592 + 0.99709704723391 + 0.99709877901257 + 0.99710080769012 + 0.99710319677283 + 0.99710603478108 + 0.99710942732312 + 0.99711349373878 + 0.99711837495867 + 0.99712424162203 + 0.99713130201172 + 0.99713981143296 + 0.99715008948435 + 0.99716253793066 + 0.99717765072893 + 0.99719604767724 + 0.99721851232508 + 0.99724604470241 + 0.99727994104845 + 0.99732194127324 + 0.99737449156214 + 0.99744097057749 + 0.99752599643956 + 0.99763618862328 + 0.99778178870294 + 0.99797953697215 + 0.99826041175770 + 0.99869749200869 + 1.00000000000000 + 0.99856534964725 + 0.99788157112833 + 0.99728273252215 + 0.99670587061216 + 0.99612046692519 + 0.99550608236814 + 0.99484610410758 + 0.99412551452755 + 0.99333042995356 + 0.99245138645573 + 0.99148281958193 + 0.99041282653344 + 0.98922861507053 + 0.98792350367773 + 0.98648597895364 + 0.98489801156630 + 0.98314010020066 + 0.98119222138592 + 0.97903335818825 + 0.97663920129769 + 0.97398164002965 + 0.97102749399397 + 0.96773616693760 + 0.96405992332150 + 0.95994548207767 + 0.95533373068970 + 0.95015394315713 + 0.94433275145509 + 0.93781037915342 + 0.93053713615078 + 0.92246787267278 + 0.91356815145873 + 0.90381505868625 + 0.89319966231051 + 0.88173071446654 + 0.86944005167928 + 0.85638856902021 + 0.84266504494749 + 0.82837169231330 + 0.81363334367090 + 0.79861404561730 + 0.78349158819178 + 0.77593847265420 + 0.76841724504715 + 0.76094169692249 + 0.75352204451472 + 0.74616460473040 + 0.73887160016888 + 0.73164113949669 + 0.72446746392592 + 0.71734144571813 + 0.71024858709526 + 0.70312402230138 + 0.69577511929241 + 0.68810175138168 + 0.68009301022288 + 0.67173880477966 + 0.66304822726701 + 0.65403414695437 + 0.64471221631575 + 0.63510034177200 + 0.62521868776989 + 0.61508880885321 + 0.60471129612134 + 0.59411089599792 + 0.58331775038425 + 0.57236787272235 + 0.56130267845465 + 0.55016725225432 + 0.53899441872695 + 0.52781020157391 + 0.51664415866675 + 0.50551494956397 + 0.49442789004339 + 0.99680873923165 + 0.99681232046585 + 0.99681291618893 + 0.99681361142598 + 0.99681442297629 + 0.99681537053264 + 0.99681647721933 + 0.99681777026278 + 0.99681928206975 + 0.99682105287297 + 0.99682313790736 + 0.99682561406138 + 0.99682857303605 + 0.99683211842577 + 0.99683637247648 + 0.99684148304651 + 0.99684763035974 + 0.99685503495618 + 0.99686397235988 + 0.99687478806368 + 0.99688790539655 + 0.99690385338158 + 0.99692329737891 + 0.99694708112554 + 0.99697628953996 + 0.99701236524015 + 0.99705731453851 + 0.99711386281591 + 0.99718564224405 + 0.99727768634382 + 0.99739744198236 + 0.99755624465037 + 0.99777274673157 + 0.99808169435994 + 0.99856534964725 + 1.00000000000000 + 0.99841691324224 + 0.99765706501118 + 0.99699162218178 + 0.99634830355386 + 0.99569256519416 + 0.99500130781593 + 0.99425608328004 + 0.99344105300484 + 0.99254561840003 + 0.99156348566777 + 0.99048214836510 + 0.98928838162077 + 0.98797522013842 + 0.98653089072063 + 0.98493713548032 + 0.98317427793013 + 0.98122216097313 + 0.97905966334048 + 0.97666238988543 + 0.97400215821179 + 0.97104572533880 + 0.96775243758921 + 0.96407450733078 + 0.95995860763540 + 0.95534558573804 + 0.95016467859529 + 0.94434248939280 + 0.93781922385662 + 0.93054517884640 + 0.92247519308641 + 0.91357481950749 + 0.90382113566122 + 0.89320520186767 + 0.88173576348073 + 0.86944465107860 + 0.85639275469887 + 0.84266884863517 + 0.82837514226692 + 0.81363646623369 + 0.79861686709071 + 0.78349413544775 + 0.77594089276191 + 0.76841954478716 + 0.76094388296683 + 0.75352412336345 + 0.74616658264377 + 0.73887348311287 + 0.73164293307296 + 0.72446917334022 + 0.71734307573055 + 0.71025014198403 + 0.70312550529104 + 0.69577653126900 + 0.68810309217646 + 0.68009427966712 + 0.67174000276159 + 0.66304935392724 + 0.65403520273545 + 0.64471320199478 + 0.63510125849177 + 0.62521953704293 + 0.61508959256046 + 0.60471201634753 + 0.59411155516883 + 0.58331835124746 + 0.57236841833262 + 0.56130317214730 + 0.55016769761205 + 0.53899481946705 + 0.52781056146982 + 0.51664448149074 + 0.50551523897980 + 0.49442814949947 + 0.99649928688288 + 0.99650240945752 + 0.99650292884469 + 0.99650353497948 + 0.99650424249947 + 0.99650506856572 + 0.99650603332168 + 0.99650716048434 + 0.99650847826808 + 0.99651002168353 + 0.99651183871745 + 0.99651399608020 + 0.99651657332325 + 0.99651966030073 + 0.99652336299712 + 0.99652780949208 + 0.99653315574635 + 0.99653959233822 + 0.99654735699080 + 0.99655674721565 + 0.99656812657510 + 0.99658194795565 + 0.99659877864153 + 0.99661933437352 + 0.99664452970218 + 0.99667557181645 + 0.99671412570352 + 0.99676242452855 + 0.99682338785796 + 0.99690096162875 + 0.99700080168606 + 0.99713111263803 + 0.99730445760244 + 0.99754163290407 + 0.99788157112833 + 0.99841691324224 + 1.00000000000000 + 0.99824991311883 + 0.99740429159911 + 0.99666280231899 + 0.99594328685565 + 0.99520654340452 + 0.99442685822562 + 0.99358465297232 + 0.99266729079028 + 0.99166724124116 + 0.99057105737512 + 0.98936486806993 + 0.98804129249675 + 0.98658819290215 + 0.98498699911170 + 0.98321779837347 + 0.98126025524567 + 0.97909311056446 + 0.97669185676335 + 0.97402821811325 + 0.97106887046347 + 0.96777308576497 + 0.96409300898650 + 0.95997525398532 + 0.95536061621468 + 0.95017828518164 + 0.94435482739037 + 0.93783042598916 + 0.93055536140393 + 0.92248445783535 + 0.91358325581575 + 0.90382882196241 + 0.89321220687050 + 0.88174214723055 + 0.86945046597144 + 0.85639804663049 + 0.84267365809190 + 0.82837950519968 + 0.81364041605443 + 0.79862043708397 + 0.78349735957271 + 0.77594395652828 + 0.76842245674801 + 0.76094665153730 + 0.75352675673648 + 0.74616908870767 + 0.73887586937478 + 0.73164520658479 + 0.72447134063425 + 0.71734514278864 + 0.71025211415821 + 0.70312738661138 + 0.69577832279161 + 0.68810479362118 + 0.68009589076889 + 0.67174152333188 + 0.66305078411252 + 0.65403654307878 + 0.64471445347394 + 0.63510242254708 + 0.62522061559474 + 0.61509058799518 + 0.60471293131340 + 0.59411239274268 + 0.58331911491984 + 0.57236911197901 + 0.56130379999835 + 0.55016826420873 + 0.53899532951937 + 0.52781101975059 + 0.51664489277536 + 0.50551560790036 + 0.49442848041999 + 0.99615341810059 + 0.99615613791298 + 0.99615659028365 + 0.99615711820208 + 0.99615773441046 + 0.99615845384903 + 0.99615929405373 + 0.99616027566802 + 0.99616142324344 + 0.99616276722254 + 0.99616434927664 + 0.99616622724962 + 0.99616847011413 + 0.99617115579142 + 0.99617437614484 + 0.99617824213649 + 0.99618288875907 + 0.99618848081658 + 0.99619522361498 + 0.99620337370284 + 0.99621324395575 + 0.99622522313112 + 0.99623979667521 + 0.99625757463465 + 0.99627933270416 + 0.99630608896732 + 0.99633923866197 + 0.99638063504844 + 0.99643266568086 + 0.99649849704275 + 0.99658256377931 + 0.99669108122612 + 0.99683311317446 + 0.99702260784255 + 0.99728273252215 + 0.99765706501118 + 0.99824991311883 + 1.00000000000000 + 0.99806120875380 + 0.99711834755490 + 0.99629018704312 + 0.99548313138155 + 0.99465325708742 + 0.99377297494466 + 0.99282567630895 + 0.99180159799006 + 0.99068574958896 + 0.98946325267177 + 0.98812609523986 + 0.98666161329733 + 0.98505080059724 + 0.98327341993465 + 0.98130889413474 + 0.97913577933073 + 0.97672941908050 + 0.97406141502316 + 0.97109833687244 + 0.96779935962668 + 0.96411654055112 + 0.95999641662036 + 0.95537971633421 + 0.95019556815974 + 0.94437049164465 + 0.93784464123112 + 0.93056827650409 + 0.92249620324517 + 0.91359394623277 + 0.90383855814642 + 0.89322107715189 + 0.88175022880380 + 0.86945782616955 + 0.85640474435012 + 0.84267974516878 + 0.82838502753444 + 0.81364541617009 + 0.79862495722722 + 0.78350144276251 + 0.77594783716496 + 0.76842614564717 + 0.76095015933484 + 0.75353009378485 + 0.74617226496780 + 0.73887889431677 + 0.73164808909688 + 0.72447408894783 + 0.71734776442365 + 0.71025461584235 + 0.70312977338438 + 0.69578059592398 + 0.68810695268586 + 0.68009793536819 + 0.67174345318459 + 0.66305259937558 + 0.65403824442057 + 0.64471604212727 + 0.63510390034070 + 0.62522198497092 + 0.61509185198995 + 0.60471409329103 + 0.59411345661766 + 0.58332008512527 + 0.57236999343680 + 0.56130459808083 + 0.55016898467227 + 0.53899597833022 + 0.52781160295703 + 0.51664541641719 + 0.50551607783817 + 0.49442890216921 + 0.99576512631396 + 0.99576749382642 + 0.99576788758937 + 0.99576834710619 + 0.99576888346667 + 0.99576950967283 + 0.99577024098116 + 0.99577109535488 + 0.99577209414930 + 0.99577326383019 + 0.99577464056985 + 0.99577627451507 + 0.99577822545598 + 0.99578056095150 + 0.99578336064303 + 0.99578672067256 + 0.99579075793957 + 0.99579561504262 + 0.99580146945975 + 0.99580854270229 + 0.99581710449948 + 0.99582748935755 + 0.99584011396558 + 0.99585550037756 + 0.99587430989668 + 0.99589740668168 + 0.99592596924369 + 0.99596155147175 + 0.99600613296093 + 0.99606230191445 + 0.99613362139993 + 0.99622496075285 + 0.99634317846524 + 0.99649831955621 + 0.99670587061216 + 0.99699162218178 + 0.99740429159911 + 0.99806120875380 + 1.00000000000000 + 0.99784712831919 + 0.99679420617170 + 0.99586687611888 + 0.99495926004620 + 0.99402341702016 + 0.99303407485824 + 0.99197709652825 + 0.99083478714061 + 0.98959061284633 + 0.98823555967010 + 0.98675617674601 + 0.98513283184747 + 0.98334483188843 + 0.98137126557464 + 0.97919043748628 + 0.97677749116858 + 0.97410386522792 + 0.97113598925515 + 0.96783291080877 + 0.96414657223433 + 0.96002341009158 + 0.95540406578189 + 0.95021758882882 + 0.94439043836093 + 0.93786273208997 + 0.93058470303991 + 0.92251113348142 + 0.91360752806621 + 0.90385092161705 + 0.89323233631298 + 0.88176048334930 + 0.86946716300378 + 0.85641323937439 + 0.84268746504731 + 0.82839203110868 + 0.81365175776772 + 0.79863069067254 + 0.78350662275496 + 0.77595276065165 + 0.76843082635473 + 0.76095461075315 + 0.75353432903022 + 0.74617629665944 + 0.73888273444012 + 0.73165174889554 + 0.72447757882232 + 0.71735109386067 + 0.71025779332392 + 0.70313280524152 + 0.69578348368999 + 0.68810969574450 + 0.68010053315016 + 0.67174590528449 + 0.66305490596148 + 0.65404040632715 + 0.64471806092487 + 0.63510577836018 + 0.62522372532493 + 0.61509345854935 + 0.60471557034747 + 0.59411480915607 + 0.58332131879342 + 0.57237111449796 + 0.56130561336093 + 0.55016990148660 + 0.53899680425428 + 0.52781234565538 + 0.51664608354749 + 0.50551667682189 + 0.49442943999234 + 0.99532727082600 + 0.99532933087843 + 0.99532967349691 + 0.99533007332549 + 0.99533054001301 + 0.99533108486983 + 0.99533172116773 + 0.99533246453113 + 0.99533333353182 + 0.99533435117606 + 0.99533554885510 + 0.99533697004358 + 0.99533866656320 + 0.99534069699051 + 0.99534313036941 + 0.99534605002286 + 0.99534955720391 + 0.99535377536520 + 0.99535885803513 + 0.99536499665888 + 0.99537242408448 + 0.99538142865623 + 0.99539236890469 + 0.99540569297504 + 0.99542196691573 + 0.99544192792995 + 0.99546657767931 + 0.99549722953164 + 0.99553554261810 + 0.99558366300306 + 0.99564450778705 + 0.99572199014533 + 0.99582148503642 + 0.99595059516436 + 0.99612046692519 + 0.99634830355386 + 0.99666280231899 + 0.99711834755490 + 0.99784712831919 + 1.00000000000000 + 0.99760436808000 + 0.99642620405768 + 0.99538516135384 + 0.99436307153634 + 0.99331222875318 + 0.99220889954327 + 0.99103022572952 + 0.98975676491497 + 0.98837782441704 + 0.98687872441198 + 0.98523890249599 + 0.98343700636984 + 0.98145165154827 + 0.97926079277218 + 0.97683930014470 + 0.97415839230364 + 0.97118431160897 + 0.96787593649950 + 0.96418505751720 + 0.96005797909982 + 0.95543522862378 + 0.95024575284988 + 0.94441593270297 + 0.93788583860409 + 0.93060566947155 + 0.92253017740451 + 0.91362484117251 + 0.90386667258366 + 0.89324667315775 + 0.88177353544876 + 0.86947904306473 + 0.85642404569913 + 0.84269728376559 + 0.82840093801771 + 0.81365982260029 + 0.79863798229685 + 0.78351321100523 + 0.77595902300374 + 0.76843678029425 + 0.76096027344808 + 0.75353971717452 + 0.74618142629518 + 0.73888762080112 + 0.73165640625375 + 0.72448202036708 + 0.71735533161900 + 0.71026183802459 + 0.70313666487247 + 0.69578716011928 + 0.68811318809867 + 0.68010384064137 + 0.67174902734518 + 0.66305784277989 + 0.65404315896384 + 0.64472063137999 + 0.63510816962384 + 0.62522594138434 + 0.61509550436124 + 0.60471745139903 + 0.59411653182114 + 0.58332289028132 + 0.57237254280198 + 0.56130690718581 + 0.55017107014826 + 0.53899785738953 + 0.52781329301055 + 0.51664693484609 + 0.50551744148911 + 0.49443012689053 + 0.99483192942722 + 0.99483372153415 + 0.99483401958413 + 0.99483436739828 + 0.99483477337284 + 0.99483524734245 + 0.99483580085104 + 0.99483644748604 + 0.99483720339826 + 0.99483808857791 + 0.99483913027207 + 0.99484036616408 + 0.99484184116950 + 0.99484360608281 + 0.99484572075418 + 0.99484825739754 + 0.99485130374349 + 0.99485496669421 + 0.99485937911631 + 0.99486470657931 + 0.99487115027934 + 0.99487895908644 + 0.99488844201156 + 0.99489998462589 + 0.99491407286557 + 0.99493133799427 + 0.99495263530947 + 0.99497908159019 + 0.99501207876415 + 0.99505342571334 + 0.99510554485722 + 0.99517164170265 + 0.99525603967901 + 0.99536470440735 + 0.99550608236814 + 0.99569256519416 + 0.99594328685565 + 0.99629018704312 + 0.99679420617170 + 0.99760436808000 + 1.00000000000000 + 0.99732847486116 + 0.99600747028600 + 0.99483706786920 + 0.99369059217089 + 0.99251929440238 + 0.99128922737421 + 0.98997537665328 + 0.98856404392779 + 0.98703852509728 + 0.98537681600827 + 0.98355657746875 + 0.98155573500979 + 0.97935174460143 + 0.97691909463192 + 0.97422870176143 + 0.97124655466368 + 0.96793130485814 + 0.96423454055027 + 0.96010239100946 + 0.95547523327225 + 0.95028187953312 + 0.94444860886111 + 0.93791543038921 + 0.93063249896841 + 0.92255452770488 + 0.91364696189486 + 0.90388678351556 + 0.89326496723787 + 0.88179018130579 + 0.86949418749965 + 0.85643781656351 + 0.84270979281710 + 0.82841228329603 + 0.81367009397131 + 0.79864726821422 + 0.78352160093283 + 0.77596699793122 + 0.76844436256692 + 0.76096748499350 + 0.75354657929384 + 0.74618795944868 + 0.73889384440142 + 0.73166233847749 + 0.72448767799584 + 0.71736072993477 + 0.71026699064723 + 0.70314158192005 + 0.69579184388122 + 0.68811763738022 + 0.68010805436779 + 0.67175300475509 + 0.66306158409775 + 0.65404666554543 + 0.64472390580425 + 0.63511121573503 + 0.62522876430761 + 0.61509811045864 + 0.60471984770733 + 0.59411872650418 + 0.58332489256538 + 0.57237436290121 + 0.56130855621403 + 0.55017255998450 + 0.53899920030939 + 0.52781450141953 + 0.51664802110982 + 0.50551841758385 + 0.49443100406963 + 0.99427011934478 + 0.99427167803636 + 0.99427193726055 + 0.99427223976558 + 0.99427259284954 + 0.99427300506591 + 0.99427348645513 + 0.99427404882680 + 0.99427470622469 + 0.99427547601600 + 0.99427638184790 + 0.99427745637887 + 0.99427873854380 + 0.99428027237022 + 0.99428210974419 + 0.99428431324679 + 0.99428695888285 + 0.99429013922851 + 0.99429396929000 + 0.99429859229660 + 0.99430418217011 + 0.99431095386397 + 0.99431917397794 + 0.99432917471795 + 0.99434137405672 + 0.99435631390898 + 0.99437472692584 + 0.99439756676882 + 0.99442602495571 + 0.99446162127721 + 0.99450638826926 + 0.99456298863392 + 0.99463496640939 + 0.99472712573825 + 0.99484610410758 + 0.99500130781593 + 0.99520654340452 + 0.99548313138155 + 0.99586687611888 + 0.99642620405768 + 0.99732847486116 + 1.00000000000000 + 0.99701439372487 + 0.99553138866399 + 0.99422014672055 + 0.99294289781660 + 0.99163722395785 + 0.99026607928118 + 0.98880989861273 + 0.98724841130201 + 0.98555725670799 + 0.98371255315681 + 0.98169118321479 + 0.97946986973520 + 0.97702255439812 + 0.97431973042109 + 0.97132703679641 + 0.96800281648362 + 0.96429838510004 + 0.96015963755623 + 0.95552675112380 + 0.95032836053001 + 0.94449061128756 + 0.93795343251868 + 0.93066692172512 + 0.92258574126951 + 0.91367529287977 + 0.90391251963253 + 0.89328836110535 + 0.88181145368632 + 0.86951353043666 + 0.85645539705992 + 0.84272575651033 + 0.82842675753439 + 0.81368319505353 + 0.79865911018759 + 0.78353229882721 + 0.77597716615067 + 0.76845402975330 + 0.76097667923565 + 0.75355532786202 + 0.74619628851823 + 0.73890177878877 + 0.73166990139829 + 0.72449489086696 + 0.71736761224034 + 0.71027355973736 + 0.70314785064707 + 0.69579781508695 + 0.68812330946044 + 0.68011342589227 + 0.67175807472134 + 0.66306635279445 + 0.65405113473721 + 0.64472807883394 + 0.63511509757430 + 0.62523236156985 + 0.61510143132808 + 0.60472290123136 + 0.59412152316025 + 0.58332744418043 + 0.57237668255513 + 0.56131065811684 + 0.55017445930856 + 0.53900091271154 + 0.52781604270283 + 0.51664940701439 + 0.50551966334189 + 0.49443212398857 + 0.99363176741456 + 0.99363312272524 + 0.99363334811704 + 0.99363361113939 + 0.99363391813561 + 0.99363427654282 + 0.99363469508549 + 0.99363518402993 + 0.99363575558085 + 0.99363642482223 + 0.99363721227068 + 0.99363814623148 + 0.99363926044185 + 0.99364059306073 + 0.99364218905568 + 0.99364410264445 + 0.99364639965637 + 0.99364916024840 + 0.99365248394832 + 0.99365649464933 + 0.99366134270768 + 0.99366721381315 + 0.99367433808145 + 0.99368300193153 + 0.99369356527089 + 0.99370649400809 + 0.99372241699641 + 0.99374215086009 + 0.99376671229732 + 0.99379739232278 + 0.99383590875910 + 0.99388449537639 + 0.99394609659855 + 0.99402465288586 + 0.99412551452755 + 0.99425608328004 + 0.99442685822562 + 0.99465325708742 + 0.99495926004620 + 0.99538516135384 + 0.99600747028600 + 0.99701439372487 + 1.00000000000000 + 0.99665791066640 + 0.99499804229288 + 0.99353772566656 + 0.99211378324667 + 0.99065801692367 + 0.98913795279326 + 0.98752645504247 + 0.98579504070794 + 0.98391728331151 + 0.98186841728894 + 0.97962404687331 + 0.97715730572459 + 0.97443807753039 + 0.97143150906705 + 0.96809551675369 + 0.96438104418938 + 0.96023366935668 + 0.95559330162558 + 0.95038833978643 + 0.94454475291170 + 0.93800236483651 + 0.93071119777093 + 0.92262584758876 + 0.91371165889454 + 0.90394552372291 + 0.89331833552234 + 0.88183868870239 + 0.86953827837300 + 0.85647787699637 + 0.84274615904043 + 0.82844524879741 + 0.81369992616503 + 0.79867422877032 + 0.78354595330572 + 0.77599014315008 + 0.76846636610570 + 0.76098841103909 + 0.75356649012960 + 0.74620691483577 + 0.73891190097065 + 0.73167954918216 + 0.72450409166889 + 0.71737639097552 + 0.71028193857053 + 0.70315584597357 + 0.69580543047182 + 0.68813054277662 + 0.68012027528209 + 0.67176453890237 + 0.66307243217392 + 0.65405683163820 + 0.64473339761820 + 0.63512004470129 + 0.62523694559468 + 0.61510566281716 + 0.60472679184311 + 0.59412508637275 + 0.58333069518171 + 0.57237963811522 + 0.56131333643138 + 0.55017687977099 + 0.53900309531556 + 0.52781800759875 + 0.51665117425523 + 0.50552125231356 + 0.49443355288745 + 0.99290628946520 + 0.99290746754313 + 0.99290766345362 + 0.99290789206849 + 0.99290815890183 + 0.99290847041436 + 0.99290883418605 + 0.99290925913819 + 0.99290975586933 + 0.99291033747897 + 0.99291102175982 + 0.99291183324368 + 0.99291280116083 + 0.99291395857449 + 0.99291534444026 + 0.99291700572097 + 0.99291899941132 + 0.99292139489425 + 0.99292427828051 + 0.99292775671024 + 0.99293196014489 + 0.99293704899090 + 0.99294322187723 + 0.99295072582412 + 0.99295987089231 + 0.99297105798821 + 0.99298482752451 + 0.99300188003239 + 0.99302308532143 + 0.99304954415945 + 0.99308271573732 + 0.99312448705241 + 0.99317732769475 + 0.99324451188593 + 0.99333042995356 + 0.99344105300484 + 0.99358465297232 + 0.99377297494466 + 0.99402341702016 + 0.99436307153634 + 0.99483706786920 + 0.99553138866399 + 0.99665791066640 + 1.00000000000000 + 0.99626305557845 + 0.99441370728410 + 0.99278470276140 + 0.99119608651201 + 0.98958131067599 + 0.98789830516759 + 0.98611070455685 + 0.98418758800038 + 0.98210143942966 + 0.97982607740754 + 0.97733339544132 + 0.97459237183024 + 0.97156744264463 + 0.96821592294043 + 0.96448824066654 + 0.96032953984999 + 0.95567936683186 + 0.95046580410745 + 0.94461458586603 + 0.93806539616747 + 0.93076815754409 + 0.92267737804305 + 0.91375832685895 + 0.90398782862768 + 0.89335671584465 + 0.88187352736018 + 0.86956990791687 + 0.85650658571853 + 0.84277219714393 + 0.82846883368579 + 0.81372125478516 + 0.79869349266356 + 0.78356334435456 + 0.77600666817875 + 0.76848207253610 + 0.76100334529487 + 0.75358069720389 + 0.74622043784305 + 0.73892478072575 + 0.73169182380093 + 0.72451579625758 + 0.71738755741589 + 0.71029259519796 + 0.70316601372463 + 0.69581511386866 + 0.68813973909685 + 0.68012898216519 + 0.67177275476978 + 0.66308015764821 + 0.65406406981490 + 0.64474015422519 + 0.63512632814621 + 0.62524276695633 + 0.61511103573044 + 0.60473173132290 + 0.59412960973275 + 0.58333482190204 + 0.57238338966514 + 0.56131673606136 + 0.55017995222811 + 0.53900586606782 + 0.52782050228436 + 0.51665341835459 + 0.50552327044014 + 0.49443536812431 + 0.99208632999542 + 0.99208735396118 + 0.99208752423434 + 0.99208772292856 + 0.99208795483409 + 0.99208822556473 + 0.99208854170371 + 0.99208891100368 + 0.99208934266261 + 0.99208984805493 + 0.99209044262183 + 0.99209114763003 + 0.99209198841852 + 0.99209299364894 + 0.99209419707644 + 0.99209563939093 + 0.99209736995623 + 0.99209944883587 + 0.99210195056173 + 0.99210496781920 + 0.99210861298326 + 0.99211302467816 + 0.99211837444425 + 0.99212487545790 + 0.99213279506350 + 0.99214247859842 + 0.99215439115009 + 0.99216913477392 + 0.99218745544789 + 0.99221029474664 + 0.99223889741279 + 0.99227486644008 + 0.99232028859502 + 0.99237791161191 + 0.99245138645573 + 0.99254561840003 + 0.99266729079028 + 0.99282567630895 + 0.99303407485824 + 0.99331222875318 + 0.99369059217089 + 0.99422014672055 + 0.99499804229288 + 0.99626305557845 + 1.00000000000000 + 0.99583461304786 + 0.99376966689186 + 0.99195092673325 + 0.99018758481594 + 0.98839864487201 + 0.98653077675716 + 0.98454442542872 + 0.98240718224631 + 0.98008986710781 + 0.97756238999189 + 0.97479233802486 + 0.97174309274553 + 0.96837110338771 + 0.96462607174909 + 0.96045254048389 + 0.95578955981669 + 0.95056478635976 + 0.94470364061792 + 0.93814561999748 + 0.93084051407394 + 0.92274271423524 + 0.91381738969170 + 0.90404127582228 + 0.89340512445773 + 0.88191740092482 + 0.86960968324824 + 0.85654264084408 + 0.84280485937767 + 0.82849838654400 + 0.81374795394049 + 0.79871758532066 + 0.78358507673656 + 0.77602731044047 + 0.76850168511281 + 0.76102198724695 + 0.75359842567771 + 0.74623730752832 + 0.73894084332412 + 0.73170712755152 + 0.72453038554657 + 0.71740147251327 + 0.71030587188021 + 0.70317867843875 + 0.69582717244553 + 0.68815118829048 + 0.68013981922216 + 0.67178297795544 + 0.66308976800337 + 0.65407307151457 + 0.64474855473033 + 0.63513413826658 + 0.62525000083083 + 0.61511771066696 + 0.60473786632382 + 0.59413522664945 + 0.58333994525027 + 0.57238804640469 + 0.56132095533937 + 0.55018376500207 + 0.53900930415259 + 0.52782359765634 + 0.51665620275914 + 0.50552577450685 + 0.49443762055501 + 0.99116785406392 + 0.99116874439032 + 0.99116889243007 + 0.99116906517675 + 0.99116926679270 + 0.99116950215370 + 0.99116977698297 + 0.99117009801000 + 0.99117047323085 + 0.99117091252126 + 0.99117142928753 + 0.99117204200297 + 0.99117277266456 + 0.99117364614855 + 0.99117469174611 + 0.99117594474373 + 0.99117744795396 + 0.99117925344397 + 0.99118142579765 + 0.99118404531009 + 0.99118720928055 + 0.99119103767035 + 0.99119567884507 + 0.99120131705176 + 0.99120818317533 + 0.99121657525400 + 0.99122689446197 + 0.99123965959714 + 0.99125551233394 + 0.99127526092445 + 0.99129997171106 + 0.99133101358409 + 0.99137016144495 + 0.99141974047126 + 0.99148281958193 + 0.99156348566777 + 0.99166724124116 + 0.99180159799006 + 0.99197709652825 + 0.99220889954327 + 0.99251929440238 + 0.99294289781660 + 0.99353772566656 + 0.99441370728410 + 0.99583461304786 + 1.00000000000000 + 0.99535551584079 + 0.99305002913368 + 0.99103066926898 + 0.98907634021913 + 0.98709012553364 + 0.98501388943643 + 0.98280579671535 + 0.98043132039584 + 0.97785704562483 + 0.97504834009864 + 0.97196697311985 + 0.96856811850854 + 0.96480043790676 + 0.96060763022959 + 0.95592806245102 + 0.95068881655465 + 0.94481489409719 + 0.93824554210242 + 0.93093037172409 + 0.92282361883713 + 0.91389031977424 + 0.90410709166176 + 0.89346457977578 + 0.88197115252748 + 0.86965830006407 + 0.85658661433420 + 0.84284461405579 + 0.82853428905905 + 0.81378033321276 + 0.79874675677323 + 0.78361135178235 + 0.77605225044609 + 0.76852536564610 + 0.76104448193321 + 0.75361980557115 + 0.74625764047235 + 0.73896019333344 + 0.73172555426294 + 0.72454794376200 + 0.71741821192055 + 0.71032183659347 + 0.70319390116060 + 0.69584166080891 + 0.68816493891786 + 0.68015282934785 + 0.67179524605636 + 0.66310129592580 + 0.65408386486703 + 0.64475862308198 + 0.63514349519274 + 0.62525866387637 + 0.61512570114826 + 0.60474520755642 + 0.59414194532300 + 0.58334607121623 + 0.57239361240067 + 0.56132599666956 + 0.55018831909559 + 0.53901340939892 + 0.52782729259756 + 0.51665952560039 + 0.50552876207296 + 0.49444030731721 + 0.99014050940579 + 0.99014128370042 + 0.99014141243589 + 0.99014156265075 + 0.99014173796306 + 0.99014194261241 + 0.99014218156933 + 0.99014246068097 + 0.99014278689015 + 0.99014316877494 + 0.99014361799412 + 0.99014415061193 + 0.99014478575835 + 0.99014554504846 + 0.99014645392944 + 0.99014754305186 + 0.99014884957806 + 0.99015041870153 + 0.99015230646744 + 0.99015458253085 + 0.99015733125391 + 0.99016065659519 + 0.99016468705649 + 0.99016958211409 + 0.99017554148679 + 0.99018282283706 + 0.99019177296032 + 0.99020283999394 + 0.99021657734546 + 0.99023368087578 + 0.99025506732771 + 0.99028191059759 + 0.99031572806931 + 0.99035849989404 + 0.99041282653344 + 0.99048214836510 + 0.99057105737512 + 0.99068574958896 + 0.99083478714061 + 0.99103022572952 + 0.99128922737421 + 0.99163722395785 + 0.99211378324667 + 0.99278470276140 + 0.99376966689186 + 0.99535551584079 + 1.00000000000000 + 0.99481838529198 + 0.99225714255390 + 0.99001747428963 + 0.98784627764563 + 0.98563739466083 + 0.98332852707563 + 0.98087476152391 + 0.97823673160579 + 0.97537607472476 + 0.97225199042498 + 0.96881771120488 + 0.96502037034348 + 0.96080245904427 + 0.95610138843479 + 0.95084345614531 + 0.94495309874642 + 0.93836922383690 + 0.93104120060619 + 0.92292305593203 + 0.91397964836212 + 0.90418743755951 + 0.89353692751591 + 0.88203635861500 + 0.86971710513752 + 0.85663965690934 + 0.84289244439695 + 0.82857738107634 + 0.81381910975422 + 0.79878161965540 + 0.78364269370719 + 0.77608197356849 + 0.76855356396666 + 0.76107124670526 + 0.75364522457588 + 0.74628179729490 + 0.73898316665939 + 0.73174741725509 + 0.72456876356873 + 0.71743804935893 + 0.71034074564037 + 0.70321192198438 + 0.69585880347420 + 0.68818120030170 + 0.68016820706531 + 0.67180973920166 + 0.66311490758994 + 0.65409660259880 + 0.64477049909132 + 0.63515452639201 + 0.62526887183208 + 0.61513511183043 + 0.60475384922824 + 0.59414985018781 + 0.58335327513660 + 0.57240015459173 + 0.56133191930554 + 0.55019366678079 + 0.53901822781390 + 0.52783162751599 + 0.51666342234172 + 0.50553226426018 + 0.49444345574381 + 0.98899272094630 + 0.98899339440523 + 0.98899350636286 + 0.98899363699812 + 0.98899378945339 + 0.98899396741292 + 0.98899417519384 + 0.98899441787610 + 0.98899470149189 + 0.98899503349311 + 0.98899542402178 + 0.98899588707376 + 0.98899643930834 + 0.98899709953419 + 0.98899788988591 + 0.98899883701345 + 0.98899997322469 + 0.98900133779871 + 0.98900297943150 + 0.98900495863737 + 0.98900734866474 + 0.98901023974130 + 0.98901374331889 + 0.98901799765066 + 0.98902317575480 + 0.98902950078747 + 0.98903727316973 + 0.98904688090656 + 0.98905880244853 + 0.98907363848448 + 0.98909217957367 + 0.98911543597698 + 0.98914471036962 + 0.98918169763405 + 0.98922861507053 + 0.98928838162077 + 0.98936486806993 + 0.98946325267177 + 0.98959061284633 + 0.98975676491497 + 0.98997537665328 + 0.99026607928118 + 0.99065801692367 + 0.99119608651201 + 0.99195092673325 + 0.99305002913368 + 0.99481838529198 + 1.00000000000000 + 0.99423170863244 + 0.99138647371220 + 0.98889547757651 + 0.98647893327171 + 0.98402116377835 + 0.98145451655256 + 0.97872801291169 + 0.97579659402940 + 0.97261514614145 + 0.96913382439202 + 0.96529744391221 + 0.96104672348856 + 0.95631771016650 + 0.95103561441674 + 0.94512410103759 + 0.93852161137174 + 0.93117718258205 + 0.92304455796116 + 0.91408835636697 + 0.90428482655305 + 0.89362428438955 + 0.88211480060656 + 0.86978759646402 + 0.85670302709461 + 0.84294940660837 + 0.82862854786740 + 0.81386502467053 + 0.79882279418709 + 0.78367962214416 + 0.77611695583089 + 0.76858671654587 + 0.76110268220236 + 0.75367505090720 + 0.74631011687985 + 0.73901007565173 + 0.73177300487180 + 0.72459311155067 + 0.71746123166719 + 0.71036282789204 + 0.70323295324712 + 0.69587879707241 + 0.68820015395153 + 0.68018611934251 + 0.67182661038883 + 0.66313074263787 + 0.65411141162846 + 0.64478429761424 + 0.63516733534176 + 0.62528071748477 + 0.61514602551613 + 0.60476386485002 + 0.59415900614692 + 0.58336161401143 + 0.57240772276547 + 0.56133876650500 + 0.55019984547771 + 0.53902379162128 + 0.52783663008153 + 0.51666791668087 + 0.50553630134301 + 0.49444708317743 + 0.98771864297099 + 0.98771922897932 + 0.98771932638691 + 0.98771944003958 + 0.98771957267076 + 0.98771972748420 + 0.98771990822770 + 0.98772011931706 + 0.98772036599311 + 0.98772065473489 + 0.98772099437913 + 0.98772139714086 + 0.98772187756245 + 0.98772245204447 + 0.98772313987304 + 0.98772396426646 + 0.98772495336851 + 0.98772614137832 + 0.98772757070385 + 0.98772929403802 + 0.98773137511544 + 0.98773389241445 + 0.98773694283157 + 0.98774064648042 + 0.98774515360238 + 0.98775065796703 + 0.98775742058048 + 0.98776577845717 + 0.98777614655934 + 0.98778904513863 + 0.98780515843403 + 0.98782535935045 + 0.98785077119739 + 0.98788285204364 + 0.98792350367773 + 0.98797522013842 + 0.98804129249675 + 0.98812609523986 + 0.98823555967010 + 0.98837782441704 + 0.98856404392779 + 0.98880989861273 + 0.98913795279326 + 0.98958131067599 + 0.99018758481594 + 0.99103066926898 + 0.99225714255390 + 0.99423170863244 + 1.00000000000000 + 0.99357905678337 + 0.99041136755147 + 0.98763720726873 + 0.98494731727583 + 0.98221464021478 + 0.97936282695608 + 0.97633380142398 + 0.97307476654721 + 0.96953077245594 + 0.96564299398435 + 0.96134947880786 + 0.95658428829358 + 0.95127110573786 + 0.94533253116519 + 0.93870635851388 + 0.93134116480491 + 0.92319030604098 + 0.91421807655959 + 0.90440044206225 + 0.89372746797667 + 0.88220700071417 + 0.86987006020233 + 0.85677682485837 + 0.84301545648070 + 0.82868763638048 + 0.81391784572881 + 0.79886999350720 + 0.78372181535094 + 0.77615686405136 + 0.76862448207297 + 0.76113844184124 + 0.75370893513100 + 0.74634224899408 + 0.73904057101744 + 0.73180197021624 + 0.72462064446822 + 0.71748742033445 + 0.71038775050124 + 0.70325666865651 + 0.69590132295845 + 0.68822149002779 + 0.68020626623170 + 0.67184557057043 + 0.66314852378189 + 0.65412802713686 + 0.64479976684829 + 0.63518168364210 + 0.62529397606956 + 0.61515823114289 + 0.60477505702472 + 0.59416922929174 + 0.58337091710867 + 0.57241615893485 + 0.56134639250529 + 0.55020672101379 + 0.53902997757183 + 0.52784218724408 + 0.51667290504786 + 0.50554077849722 + 0.49445110283433 + 0.98630759209269 + 0.98630810229824 + 0.98630818709368 + 0.98630828602941 + 0.98630840147796 + 0.98630853622524 + 0.98630869353660 + 0.98630887724248 + 0.98630909190314 + 0.98630934315474 + 0.98630963870583 + 0.98630998924729 + 0.98631040749915 + 0.98631090779436 + 0.98631150696887 + 0.98631222529926 + 0.98631308735108 + 0.98631412297190 + 0.98631536917684 + 0.98631687195608 + 0.98631868691270 + 0.98632088246910 + 0.98632354307423 + 0.98632677335469 + 0.98633070410877 + 0.98633550405427 + 0.98634140067897 + 0.98634868770655 + 0.98635772624054 + 0.98636896840335 + 0.98638300862558 + 0.98640060408709 + 0.98642272754694 + 0.98645063923195 + 0.98648597895364 + 0.98653089072063 + 0.98658819290215 + 0.98666161329733 + 0.98675617674601 + 0.98687872441198 + 0.98703852509728 + 0.98724841130201 + 0.98752645504247 + 0.98789830516759 + 0.98839864487201 + 0.98907634021913 + 0.99001747428963 + 0.99138647371220 + 0.99357905678337 + 1.00000000000000 + 0.99283648529862 + 0.98930677455033 + 0.98621782147163 + 0.98322670866011 + 0.98019089104297 + 0.97702393369568 + 0.97365820515047 + 0.97002976146800 + 0.96607379225927 + 0.96172417401441 + 0.95691199527788 + 0.95155874617969 + 0.94558553094816 + 0.93892922997853 + 0.93153777415884 + 0.92336398525279 + 0.91437171497975 + 0.90453654722901 + 0.89384821288036 + 0.88231426119226 + 0.86996544703189 + 0.85686171708279 + 0.84309103403706 + 0.82875490768750 + 0.81397769535987 + 0.79892323519358 + 0.78376921388131 + 0.77620160895309 + 0.76866674639622 + 0.76117839095230 + 0.75374672587849 + 0.74637802889062 + 0.73907447750321 + 0.73183413003071 + 0.72465117320959 + 0.71751642227362 + 0.71041531803596 + 0.70328287187353 + 0.69592618523127 + 0.68824501437703 + 0.68022845655241 + 0.67186643266465 + 0.66316806904589 + 0.65414627312635 + 0.64481673751131 + 0.63519740931674 + 0.62530849336643 + 0.61517158256326 + 0.60478728788598 + 0.59418039012336 + 0.58338106327257 + 0.57242535016279 + 0.56135469235522 + 0.55021419613338 + 0.53903669575081 + 0.52784821604619 + 0.51667831101086 + 0.50554562538932 + 0.49445545004387 + 0.98474230412491 + 0.98474274860035 + 0.98474282246106 + 0.98474290863324 + 0.98474300918467 + 0.98474312653921 + 0.98474326353171 + 0.98474342349951 + 0.98474361040516 + 0.98474382915866 + 0.98474408649298 + 0.98474439178349 + 0.98474475618279 + 0.98474519223250 + 0.98474571466969 + 0.98474634122925 + 0.98474709339369 + 0.98474799726745 + 0.98474908522702 + 0.98475039750971 + 0.98475198272321 + 0.98475390066625 + 0.98475622510402 + 0.98475904738764 + 0.98476248165753 + 0.98476667518433 + 0.98477182683018 + 0.98477819334111 + 0.98478608991030 + 0.98479591064408 + 0.98480817362820 + 0.98482353789424 + 0.98484284887844 + 0.98486720008341 + 0.98489801156630 + 0.98493713548032 + 0.98498699911170 + 0.98505080059724 + 0.98513283184747 + 0.98523890249599 + 0.98537681600827 + 0.98555725670799 + 0.98579504070794 + 0.98611070455685 + 0.98653077675716 + 0.98709012553364 + 0.98784627764563 + 0.98889547757651 + 0.99041136755147 + 0.99283648529862 + 1.00000000000000 + 0.99198938313799 + 0.98805565623425 + 0.98461909297868 + 0.98129601239667 + 0.97792598307474 + 0.97440918319002 + 0.97066444206864 + 0.96661647150248 + 0.96219230978818 + 0.95731841661210 + 0.95191302661814 + 0.94589508273432 + 0.93920014583605 + 0.93177522229897 + 0.92357238553819 + 0.91455487606184 + 0.90469775753446 + 0.89399031023555 + 0.88243968696760 + 0.87007629147426 + 0.85695976491380 + 0.84317780847555 + 0.82883170740038 + 0.81404565343352 + 0.79898338281110 + 0.78382250711580 + 0.77625180641762 + 0.76871405996573 + 0.76122302186081 + 0.75378886392673 + 0.74641785169759 + 0.73911214984159 + 0.73186980331049 + 0.72468498515754 + 0.71754849686528 + 0.71044576502037 + 0.70331177514949 + 0.69595357562254 + 0.68827089957882 + 0.68025284503791 + 0.67188933479322 + 0.66318950114373 + 0.65416625808607 + 0.64483530499983 + 0.63521459576759 + 0.62532434183848 + 0.61518614231328 + 0.60480061097982 + 0.59419253409794 + 0.58339209071752 + 0.57243532822899 + 0.56136369218085 + 0.55022229203714 + 0.53904396311962 + 0.52785472984690 + 0.51668414492029 + 0.50555084988006 + 0.49446013064917 + 0.98300388055340 + 0.98300426807026 + 0.98300433245720 + 0.98300440757214 + 0.98300449521665 + 0.98300459749878 + 0.98300471689251 + 0.98300485629527 + 0.98300501915998 + 0.98300520976186 + 0.98300543399731 + 0.98300570010181 + 0.98300601786725 + 0.98300639829826 + 0.98300685430941 + 0.98300740144094 + 0.98300805852267 + 0.98300884843076 + 0.98300979953679 + 0.98301094712282 + 0.98301233377421 + 0.98301401186414 + 0.98301604597435 + 0.98301851603486 + 0.98302152188273 + 0.98302519238059 + 0.98302970181656 + 0.98303527526248 + 0.98304218858333 + 0.98305078627568 + 0.98306152121664 + 0.98307496876342 + 0.98309186603043 + 0.98311316508229 + 0.98314010020066 + 0.98317427793013 + 0.98321779837347 + 0.98327341993465 + 0.98334483188843 + 0.98343700636984 + 0.98355657746875 + 0.98371255315681 + 0.98391728331151 + 0.98418758800038 + 0.98454442542872 + 0.98501388943643 + 0.98563739466083 + 0.98647893327171 + 0.98763720726873 + 0.98930677455033 + 0.99198938313799 + 1.00000000000000 + 0.99102478236098 + 0.98664232131735 + 0.98282210939745 + 0.97913381071037 + 0.97539391313865 + 0.97148412940928 + 0.96730921655480 + 0.96278426745145 + 0.95782816277796 + 0.95235409817555 + 0.94627778176316 + 0.93953281289731 + 0.93206484420575 + 0.92382488067551 + 0.91477530569762 + 0.90489046521378 + 0.89415902623516 + 0.88258760795182 + 0.87020614541976 + 0.85707387426167 + 0.84327815017875 + 0.82891996287528 + 0.81412328241510 + 0.79905170072404 + 0.78388271829175 + 0.77630837755258 + 0.76876725272548 + 0.76127308328911 + 0.75383602574773 + 0.74646232968443 + 0.73915414329187 + 0.73190949468392 + 0.72472253993173 + 0.71758406366317 + 0.71047947525123 + 0.70334373001346 + 0.69598381568233 + 0.68829943895921 + 0.68027969844054 + 0.67191451871165 + 0.66321303839252 + 0.65418817841859 + 0.64485564531314 + 0.63523340006638 + 0.62534166106385 + 0.61520203387180 + 0.60481513500554 + 0.59420575640999 + 0.58340408236781 + 0.57244616499129 + 0.56137345392544 + 0.55023106187223 + 0.53905182509695 + 0.52786176733945 + 0.51669043967102 + 0.50555647991977 + 0.49446516840355 + 0.98107277025842 + 0.98107310849761 + 0.98107316468804 + 0.98107323023795 + 0.98107330671726 + 0.98107339596424 + 0.98107350013193 + 0.98107362174933 + 0.98107376382089 + 0.98107393008164 + 0.98107412569530 + 0.98107435791280 + 0.98107463535437 + 0.98107496768571 + 0.98107536625386 + 0.98107584470560 + 0.98107641957354 + 0.98107711094544 + 0.98107794374506 + 0.98107894897478 + 0.98108016403100 + 0.98108163488929 + 0.98108341821811 + 0.98108558412032 + 0.98108822013403 + 0.98109143929298 + 0.98109539476283 + 0.98110028439476 + 0.98110635030697 + 0.98111389446836 + 0.98112331390753 + 0.98113511241716 + 0.98114993463865 + 0.98116861214173 + 0.98119222138592 + 0.98122216097313 + 0.98126025524567 + 0.98130889413474 + 0.98137126557464 + 0.98145165154827 + 0.98155573500979 + 0.98169118321479 + 0.98186841728894 + 0.98210143942966 + 0.98240718224631 + 0.98280579671535 + 0.98332852707563 + 0.98402116377835 + 0.98494731727583 + 0.98621782147163 + 0.98805565623425 + 0.99102478236098 + 1.00000000000000 + 0.98992921873898 + 0.98504895685039 + 0.98080726179205 + 0.97671642999019 + 0.97256234233869 + 0.96820698318670 + 0.96354273274440 + 0.95847523175395 + 0.95290945597637 + 0.94675605827403 + 0.93994561905461 + 0.93242175252277 + 0.92413390291274 + 0.91504322920865 + 0.90512307223256 + 0.89436125410707 + 0.88276366852571 + 0.87035961959393 + 0.85720780076664 + 0.84339510838942 + 0.82902214109441 + 0.81421257158310 + 0.79912978956150 + 0.78395113508573 + 0.77637247798035 + 0.76882736271935 + 0.76132950881237 + 0.75388905225952 + 0.74651222167942 + 0.73920114400750 + 0.73195382596420 + 0.72476440234938 + 0.71762363692125 + 0.71051691798610 + 0.70337916526447 + 0.69601729676656 + 0.68833098874528 + 0.68030934004227 + 0.67194227681144 + 0.66323894431776 + 0.65421227076338 + 0.64487797013262 + 0.63525401081229 + 0.62536061838376 + 0.61521940507118 + 0.60483098992862 + 0.59422017074201 + 0.58341713715371 + 0.57245794608897 + 0.56138405135633 + 0.55024056889684 + 0.53906033571597 + 0.52786937453708 + 0.51669723437948 + 0.50556254874512 + 0.49447059157208 + 0.97892833587844 + 0.97892863156461 + 0.97892868067899 + 0.97892873797130 + 0.97892880481264 + 0.97892888280715 + 0.97892897383470 + 0.97892908010078 + 0.97892920422827 + 0.97892934948131 + 0.97892952039557 + 0.97892972336655 + 0.97892996600019 + 0.97893025681181 + 0.97893060578362 + 0.97893102493111 + 0.97893152880847 + 0.97893213509298 + 0.97893286573793 + 0.97893374804846 + 0.97893481494914 + 0.97893610690808 + 0.97893767377943 + 0.97893957721685 + 0.97894189416415 + 0.97894472405760 + 0.97894820189626 + 0.97895250212466 + 0.97895783787860 + 0.97896447465494 + 0.97897276160184 + 0.97898314124694 + 0.97899617917827 + 0.97901260413927 + 0.97903335818825 + 0.97905966334048 + 0.97909311056446 + 0.97913577933073 + 0.97919043748628 + 0.97926079277218 + 0.97935174460143 + 0.97946986973520 + 0.97962404687331 + 0.97982607740754 + 0.98008986710781 + 0.98043132039584 + 0.98087476152391 + 0.98145451655256 + 0.98221464021478 + 0.98322670866011 + 0.98461909297868 + 0.98664232131735 + 0.98992921873898 + 1.00000000000000 + 0.98868607074795 + 0.98325773976661 + 0.97855376633704 + 0.97401433341074 + 0.96939150630526 + 0.96452902399059 + 0.95930731818167 + 0.95361702557612 + 0.94736046363869 + 0.94046336547831 + 0.93286617040556 + 0.92451597878383 + 0.91537216100414 + 0.90540662474632 + 0.89460601117111 + 0.88297521594109 + 0.87054268560416 + 0.85736638295825 + 0.84353258945200 + 0.82914138326771 + 0.81431603720557 + 0.79921965957408 + 0.78402936241190 + 0.77644554232423 + 0.76889567340628 + 0.76139344801278 + 0.75394897469046 + 0.74656845443644 + 0.73925398657998 + 0.73200355047274 + 0.72481125401990 + 0.71766783488283 + 0.71055865532838 + 0.70341859273894 + 0.69605448441199 + 0.68836597125369 + 0.68034215181058 + 0.67197295342408 + 0.66326752824162 + 0.65423881198567 + 0.64490252633992 + 0.63527664728457 + 0.62538140775258 + 0.61523842673241 + 0.60484832548109 + 0.59423590767574 + 0.58343136836410 + 0.57247076929779 + 0.56139556842701 + 0.55025088486646 + 0.53906955606242 + 0.52787760328418 + 0.51670457296717 + 0.50556909354680 + 0.49447643166906 + 0.97654658864649 + 0.97654684765557 + 0.97654689067126 + 0.97654694084613 + 0.97654699938120 + 0.97654706767833 + 0.97654714738275 + 0.97654724042351 + 0.97654734909241 + 0.97654747624885 + 0.97654762588780 + 0.97654780366362 + 0.97654801630289 + 0.97654827132551 + 0.97654857754280 + 0.97654894555656 + 0.97654938821250 + 0.97654992111094 + 0.97655056364259 + 0.97655133993221 + 0.97655227904470 + 0.97655341670489 + 0.97655479690978 + 0.97655647403359 + 0.97655851593476 + 0.97656101035182 + 0.97656407666156 + 0.97656786918401 + 0.97657257618241 + 0.97657843185739 + 0.97658574433174 + 0.97659490367352 + 0.97660640788371 + 0.97662089791635 + 0.97663920129769 + 0.97666238988543 + 0.97669185676335 + 0.97672941908050 + 0.97677749116858 + 0.97683930014470 + 0.97691909463192 + 0.97702255439812 + 0.97715730572459 + 0.97733339544132 + 0.97756238999189 + 0.97785704562483 + 0.97823673160579 + 0.97872801291169 + 0.97936282695608 + 0.98019089104297 + 0.98129601239667 + 0.98282210939745 + 0.98504895685039 + 0.98868607074795 + 1.00000000000000 + 0.98728150336170 + 0.98125293547486 + 0.97603717980361 + 0.97099167765214 + 0.96583507697733 + 0.96039363235906 + 0.95453063519484 + 0.94813368363124 + 0.94112030625192 + 0.93342578674115 + 0.92499358378376 + 0.91578038196423 + 0.90575599954691 + 0.89490539708123 + 0.88323207732172 + 0.87076330759393 + 0.85755605651764 + 0.84369577581957 + 0.82928184630464 + 0.81443700097118 + 0.79932395810810 + 0.78411950898902 + 0.77652945353515 + 0.76897386764568 + 0.76146640682043 + 0.75401714281534 + 0.74663224010919 + 0.73931376199216 + 0.73205965251624 + 0.72486398529537 + 0.71771746501025 + 0.71060542141080 + 0.70346268101027 + 0.69609598689694 + 0.68840493855167 + 0.68037863340482 + 0.67200699936348 + 0.66329919557149 + 0.65426816542655 + 0.64492963842444 + 0.63530159821544 + 0.62540428511550 + 0.61525932483475 + 0.60486734029524 + 0.59425314101457 + 0.58344692735714 + 0.57248476580745 + 0.56140811834553 + 0.55026210708110 + 0.53907956949273 + 0.52788652482119 + 0.51671251625233 + 0.50557616625902 + 0.49448273310189 + 0.97389969019845 + 0.97389991764813 + 0.97389995541667 + 0.97389999946969 + 0.97390005086065 + 0.97390011081741 + 0.97390018078364 + 0.97390026245043 + 0.97390035782689 + 0.97390046942527 + 0.97390060076975 + 0.97390075687876 + 0.97390094371627 + 0.97390116794227 + 0.97390143735892 + 0.97390176134893 + 0.97390215128431 + 0.97390262098222 + 0.97390318761545 + 0.97390387256894 + 0.97390470159567 + 0.97390570633182 + 0.97390692573579 + 0.97390840794118 + 0.97391021299678 + 0.97391241860177 + 0.97391513070774 + 0.97391848634368 + 0.97392265242812 + 0.97392783636460 + 0.97393431112113 + 0.97394242189948 + 0.97395260895416 + 0.97396543834581 + 0.97398164002965 + 0.97400215821179 + 0.97402821811325 + 0.97406141502316 + 0.97410386522792 + 0.97415839230364 + 0.97422870176143 + 0.97431973042109 + 0.97443807753039 + 0.97459237183024 + 0.97479233802486 + 0.97504834009864 + 0.97537607472476 + 0.97579659402940 + 0.97633380142398 + 0.97702393369568 + 0.97792598307474 + 0.97913381071037 + 0.98080726179205 + 0.98325773976661 + 0.98728150336170 + 1.00000000000000 + 0.98570331122396 + 0.97901520184793 + 0.97322592265846 + 0.96760442523475 + 0.96183686705372 + 0.95572751712493 + 0.94913554049255 + 0.94196362478310 + 0.93413824078955 + 0.92559695060211 + 0.91629226906511 + 0.90619088522807 + 0.89527531586492 + 0.88354708612275 + 0.87103181955179 + 0.85778511720581 + 0.84389130114924 + 0.82944881093557 + 0.81457964771883 + 0.79944599020337 + 0.78422418141952 + 0.77662652695646 + 0.76906400355827 + 0.76155021675729 + 0.75409518897541 + 0.74670503623557 + 0.73938177455226 + 0.73212330214344 + 0.72492364853835 + 0.71777347638823 + 0.71065807443223 + 0.70351220747956 + 0.69614250777481 + 0.68844852579967 + 0.68041935663553 + 0.67204492778080 + 0.66333440531024 + 0.65430074024725 + 0.64495966982776 + 0.63532918524156 + 0.62542953401846 + 0.61528234833983 + 0.60488825198330 + 0.59427206005959 + 0.58346397799634 + 0.57250007676024 + 0.56142182209965 + 0.55027433880313 + 0.53909046381378 + 0.52789621360738 + 0.51672112728456 + 0.50558382026478 + 0.49448954112656 + 0.97095469883327 + 0.97095489917744 + 0.97095493244072 + 0.97095497123568 + 0.97095501649187 + 0.97095506928818 + 0.97095513089573 + 0.97095520279875 + 0.97095528676576 + 0.97095538501112 + 0.97095550065661 + 0.97095563816488 + 0.97095580284399 + 0.97095600061631 + 0.97095623840782 + 0.97095652455140 + 0.97095686915357 + 0.97095728449470 + 0.97095778583771 + 0.97095839221075 + 0.97095912651021 + 0.97096001686803 + 0.97096109791049 + 0.97096241241084 + 0.97096401372116 + 0.97096597093059 + 0.97096837845190 + 0.97097135846781 + 0.97097505959648 + 0.97097966629548 + 0.97098542144141 + 0.97099263187297 + 0.97100168853594 + 0.97101309361726 + 0.97102749399397 + 0.97104572533880 + 0.97106887046347 + 0.97109833687244 + 0.97113598925515 + 0.97118431160897 + 0.97124655466368 + 0.97132703679641 + 0.97143150906705 + 0.97156744264463 + 0.97174309274553 + 0.97196697311985 + 0.97225199042498 + 0.97261514614145 + 0.97307476654721 + 0.97365820515047 + 0.97440918319002 + 0.97539391313865 + 0.97671642999019 + 0.97855376633704 + 0.98125293547486 + 0.98570331122396 + 1.00000000000000 + 0.98393613095220 + 0.97651832728428 + 0.97007894235728 + 0.96379658088274 + 0.95732175680629 + 0.95045145526278 + 0.94305908802033 + 0.93505506042941 + 0.92636689246504 + 0.91694035927217 + 0.90673730935087 + 0.89573661287251 + 0.88393692923762 + 0.87136155373425 + 0.85806418236498 + 0.84412758370955 + 0.82964891679067 + 0.81474918559010 + 0.79958982247369 + 0.78434654661390 + 0.77673955657124 + 0.76916854717483 + 0.76164705625079 + 0.75418503999067 + 0.74678854996689 + 0.73945953988839 + 0.73219584814778 + 0.72499144721014 + 0.71783694575777 + 0.71071758037016 + 0.70356804035491 + 0.69619482663045 + 0.68849743122519 + 0.68046494503748 + 0.67208729367091 + 0.66337364973776 + 0.65433697153878 + 0.64499300366588 + 0.63535974440945 + 0.62545744802303 + 0.61530775259253 + 0.60491128156503 + 0.59429285511708 + 0.58348268323794 + 0.57251684089109 + 0.56143679712621 + 0.55028767890430 + 0.53910232186200 + 0.52790673876535 + 0.51673046358303 + 0.50559210337295 + 0.49449689549402 + 0.96767123670600 + 0.96767141379837 + 0.96767144319681 + 0.96767147748471 + 0.96767151747861 + 0.96767156413715 + 0.96767161857434 + 0.96767168210710 + 0.96767175629473 + 0.96767184309414 + 0.96767194528003 + 0.96767206683921 + 0.96767221251261 + 0.96767238757718 + 0.96767259821355 + 0.96767285185044 + 0.96767315750142 + 0.96767352611437 + 0.96767397132160 + 0.96767451011542 + 0.96767516293309 + 0.96767595489067 + 0.96767691689269 + 0.96767808710618 + 0.96767951313829 + 0.96768125667400 + 0.96768340221334 + 0.96768605916803 + 0.96768936044103 + 0.96769347081954 + 0.96769860738377 + 0.96770504412467 + 0.96771312981791 + 0.96772331208847 + 0.96773616693760 + 0.96775243758921 + 0.96777308576497 + 0.96779935962668 + 0.96783291080877 + 0.96787593649950 + 0.96793130485814 + 0.96800281648362 + 0.96809551675369 + 0.96821592294043 + 0.96837110338771 + 0.96856811850854 + 0.96881771120488 + 0.96913382439202 + 0.96953077245594 + 0.97002976146800 + 0.97066444206864 + 0.97148412940928 + 0.97256234233869 + 0.97401433341074 + 0.97603717980361 + 0.97901520184793 + 0.98393613095220 + 1.00000000000000 + 0.98196266143404 + 0.97372823985543 + 0.96654239658520 + 0.95949160997023 + 0.95220852644471 + 0.94450138614108 + 0.93624872656058 + 0.92735984049287 + 0.91776905299301 + 0.90743042114232 + 0.89631719783580 + 0.88442378384427 + 0.87177011101211 + 0.85840718021882 + 0.84441559745429 + 0.82989076285669 + 0.81495231295344 + 0.79976064598401 + 0.78449061432531 + 0.77687206472898 + 0.76929059355659 + 0.76175964689337 + 0.75428909186471 + 0.74688489408037 + 0.73954892483503 + 0.73227894399221 + 0.72506884970916 + 0.71790918086724 + 0.71078510720383 + 0.70363122484299 + 0.69625387798936 + 0.68855248830658 + 0.68051613983521 + 0.67213475406857 + 0.66341750928558 + 0.65437737025818 + 0.64503008809567 + 0.63539366730243 + 0.62548836791414 + 0.61533583291890 + 0.60493668372945 + 0.59431574469177 + 0.58350322950085 + 0.57253521632909 + 0.56145317676855 + 0.55030223920506 + 0.53911523692834 + 0.52791817779265 + 0.51674058934134 + 0.50560106868343 + 0.49450484013653 + 0.96400176623743 + 0.96400192339169 + 0.96400194947640 + 0.96400197989908 + 0.96400201538326 + 0.96400205677627 + 0.96400210506951 + 0.96400216142743 + 0.96400222723234 + 0.96400230422199 + 0.96400239487214 + 0.96400250275454 + 0.96400263212340 + 0.96400278769887 + 0.96400297501494 + 0.96400320072003 + 0.96400347288611 + 0.96400380131614 + 0.96400419822798 + 0.96400467885682 + 0.96400526152902 + 0.96400596874683 + 0.96400682821690 + 0.96400787413739 + 0.96400914916001 + 0.96401070860658 + 0.96401262841847 + 0.96401500698026 + 0.96401796366759 + 0.96402164633733 + 0.96402624987384 + 0.96403202002703 + 0.96403926936334 + 0.96404839870614 + 0.96405992332150 + 0.96407450733078 + 0.96409300898650 + 0.96411654055112 + 0.96414657223433 + 0.96418505751720 + 0.96423454055027 + 0.96429838510004 + 0.96438104418938 + 0.96448824066654 + 0.96462607174909 + 0.96480043790676 + 0.96502037034348 + 0.96529744391221 + 0.96564299398435 + 0.96607379225927 + 0.96661647150248 + 0.96730921655480 + 0.96820698318670 + 0.96939150630526 + 0.97099167765214 + 0.97322592265846 + 0.97651832728428 + 0.98196266143404 + 1.00000000000000 + 0.97976069312602 + 0.97059600426645 + 0.96253816326211 + 0.95460556062305 + 0.94643162823510 + 0.93782376450862 + 0.92865529550419 + 0.91883982973445 + 0.90831824874253 + 0.89705480595119 + 0.88503737328925 + 0.87228090340675 + 0.85883251041135 + 0.84476974383598 + 0.83018555909986 + 0.81519770179170 + 0.79996513185705 + 0.78466149671431 + 0.77702852334744 + 0.76943405513403 + 0.76189141369235 + 0.75441034615871 + 0.74699670314685 + 0.73965224647685 + 0.73237463246093 + 0.72515766191414 + 0.71799178285552 + 0.71086207873691 + 0.70370302971303 + 0.69632079160053 + 0.68861470057590 + 0.68057382994605 + 0.67218809385169 + 0.66346667466294 + 0.65442254215303 + 0.64507145246777 + 0.63543141479972 + 0.62552269340602 + 0.61536693455420 + 0.60496475524820 + 0.59434098258230 + 0.58352583264350 + 0.57255538559244 + 0.56147111445266 + 0.55031814794122 + 0.53912931563549 + 0.52793061895285 + 0.51675157740056 + 0.50561077622156 + 0.49451342452470 + 0.95989318170236 + 0.95989332174068 + 0.95989334498235 + 0.95989337208724 + 0.95989340370031 + 0.95989344057573 + 0.95989348359652 + 0.95989353379738 + 0.95989359240917 + 0.95989366098104 + 0.95989374173345 + 0.95989383787540 + 0.95989395323612 + 0.95989409206072 + 0.95989425931795 + 0.95989446098598 + 0.95989470431689 + 0.95989499812768 + 0.95989535340999 + 0.95989578387739 + 0.95989630602240 + 0.95989694009566 + 0.95989771102930 + 0.95989864958696 + 0.95989979414020 + 0.95990119450133 + 0.95990291918395 + 0.95990505702397 + 0.95990771566758 + 0.95991102832910 + 0.95991517067512 + 0.95992036404056 + 0.95992688970799 + 0.95993510808975 + 0.95994548207767 + 0.95995860763540 + 0.95997525398532 + 0.95999641662036 + 0.96002341009158 + 0.96005797909982 + 0.96010239100946 + 0.96015963755623 + 0.96023366935668 + 0.96032953984999 + 0.96045254048389 + 0.96060763022959 + 0.96080245904427 + 0.96104672348856 + 0.96134947880786 + 0.96172417401441 + 0.96219230978818 + 0.96278426745145 + 0.96354273274440 + 0.96452902399059 + 0.96583507697733 + 0.96760442523475 + 0.97007894235728 + 0.97372823985543 + 0.97976069312602 + 1.00000000000000 + 0.97729326660107 + 0.96704312168407 + 0.95797907819734 + 0.94907134575104 + 0.93993661110503 + 0.93036844209065 + 0.92023973278097 + 0.90946764420440 + 0.89800128576954 + 0.88581812340145 + 0.87292550947323 + 0.85936481596177 + 0.84520918944128 + 0.83054813611206 + 0.81549675813621 + 0.80021200257120 + 0.78486583708424 + 0.77721472549625 + 0.76960398405140 + 0.76204676516599 + 0.75455265389095 + 0.74712734648313 + 0.73977245876092 + 0.73248550980568 + 0.72526017220082 + 0.71808677494936 + 0.71095028934965 + 0.70378504999894 + 0.69639698443314 + 0.68868532398825 + 0.68063912565368 + 0.67224829156002 + 0.66352200557389 + 0.65447324007062 + 0.64511775386062 + 0.63547355841200 + 0.62556091978225 + 0.61540148508075 + 0.60499586361332 + 0.59436888312494 + 0.58355076014287 + 0.57257757505494 + 0.56149080071370 + 0.55033556464581 + 0.53914469092893 + 0.52794417260085 + 0.51676351913412 + 0.50562130157877 + 0.49452271125312 + 0.95528652653768 + 0.95528665183770 + 0.95528667263032 + 0.95528669687810 + 0.95528672515854 + 0.95528675814388 + 0.95528679662510 + 0.95528684152542 + 0.95528689394676 + 0.95528695527176 + 0.95528702750016 + 0.95528711352885 + 0.95528721681460 + 0.95528734118902 + 0.95528749113041 + 0.95528767203116 + 0.95528789043478 + 0.95528815429867 + 0.95528847354548 + 0.95528886056580 + 0.95528933025354 + 0.95528990090018 + 0.95529059501860 + 0.95529144038453 + 0.95529247164301 + 0.95529373379783 + 0.95529528888710 + 0.95529721739233 + 0.95529961672931 + 0.95530260734326 + 0.95530634813515 + 0.95531103915036 + 0.95531693441355 + 0.95532435915356 + 0.95533373068970 + 0.95534558573804 + 0.95536061621468 + 0.95537971633421 + 0.95540406578189 + 0.95543522862378 + 0.95547523327225 + 0.95552675112380 + 0.95559330162558 + 0.95567936683186 + 0.95578955981669 + 0.95592806245102 + 0.95610138843479 + 0.95631771016650 + 0.95658428829358 + 0.95691199527788 + 0.95731841661210 + 0.95782816277796 + 0.95847523175395 + 0.95930731818167 + 0.96039363235906 + 0.96183686705372 + 0.96379658088274 + 0.96654239658520 + 0.97059600426645 + 0.97729326660107 + 1.00000000000000 + 0.97449264616444 + 0.96298371424855 + 0.95280019118856 + 0.94283674030359 + 0.93267485244367 + 0.92209752125305 + 0.91097548896219 + 0.89923071015617 + 0.88682321820812 + 0.87374829934807 + 0.86003857378432 + 0.84576068543228 + 0.83099917661356 + 0.81586539864436 + 0.80051345431144 + 0.78511295621735 + 0.77743881750881 + 0.76980750363417 + 0.76223193615016 + 0.75472148026975 + 0.74728162412866 + 0.73991378783755 + 0.73261530755033 + 0.72537968586488 + 0.71819709480333 + 0.71105235877262 + 0.70387962780595 + 0.69648454979826 + 0.68876622597870 + 0.68071368915827 + 0.67231682285403 + 0.66358480854501 + 0.65453061759675 + 0.64517000794397 + 0.63552098979223 + 0.62560382748384 + 0.61544016544016 + 0.60503060079947 + 0.59439995895793 + 0.58357845414416 + 0.57260216450088 + 0.56151256048589 + 0.55035476635567 + 0.53916159833481 + 0.52795903859871 + 0.51677658405482 + 0.50563278866422 + 0.49453282276895 + 0.95011122041841 + 0.95011133293366 + 0.95011135160274 + 0.95011137337295 + 0.95011139876299 + 0.95011142837586 + 0.95011146292065 + 0.95011150322608 + 0.95011155027657 + 0.95011160531934 + 0.95011167015267 + 0.95011174740510 + 0.95011184020284 + 0.95011195201528 + 0.95011208688928 + 0.95011224970932 + 0.95011244639097 + 0.95011268413289 + 0.95011297192343 + 0.95011332098861 + 0.95011374481358 + 0.95011425996950 + 0.95011488683394 + 0.95011565056147 + 0.95011658250979 + 0.95011772344883 + 0.95011912969240 + 0.95012087433958 + 0.95012304577349 + 0.95012575316429 + 0.95012914060504 + 0.95013338935654 + 0.95013872940068 + 0.95014545494421 + 0.95015394315713 + 0.95016467859529 + 0.95017828518164 + 0.95019556815974 + 0.95021758882882 + 0.95024575284988 + 0.95028187953312 + 0.95032836053001 + 0.95038833978643 + 0.95046580410745 + 0.95056478635976 + 0.95068881655465 + 0.95084345614531 + 0.95103561441674 + 0.95127110573786 + 0.95155874617969 + 0.95191302661814 + 0.95235409817555 + 0.95290945597637 + 0.95361702557612 + 0.95453063519484 + 0.95572751712493 + 0.95732175680629 + 0.95949160997023 + 0.96253816326211 + 0.96704312168407 + 0.97449264616444 + 1.00000000000000 + 0.97130033112451 + 0.95837042950509 + 0.94696290772369 + 0.93586347391805 + 0.92461677284597 + 0.91299118701131 + 0.90085557390012 + 0.88813875534760 + 0.87481583274501 + 0.86090551841174 + 0.84646452181333 + 0.83157004205687 + 0.81632799321518 + 0.80088839852918 + 0.78541753494326 + 0.77771374548709 + 0.77005604382374 + 0.76245703443676 + 0.75492578237186 + 0.74746749317303 + 0.74008332262106 + 0.73277036108364 + 0.72552188385671 + 0.71832785400863 + 0.71117290160674 + 0.70399093920039 + 0.69658726588942 + 0.68886081867228 + 0.68080059541666 + 0.67239645204132 + 0.66365756229344 + 0.65459689159512 + 0.64523019215167 + 0.63557546803334 + 0.62565297701809 + 0.61548435600580 + 0.60507018385134 + 0.59443527949953 + 0.58360985112691 + 0.57262997125404 + 0.56153710491087 + 0.55037637027405 + 0.53918057254316 + 0.52797567970487 + 0.51679117273653 + 0.50564558468609 + 0.49454406071839 + 0.94429401144548 + 0.94429411277332 + 0.94429412958456 + 0.94429414918649 + 0.94429417204614 + 0.94429419870885 + 0.94429422980841 + 0.94429426609000 + 0.94429430844301 + 0.94429435798682 + 0.94429441635177 + 0.94429448591747 + 0.94429456952358 + 0.94429467031286 + 0.94429479195963 + 0.94429493888254 + 0.94429511645156 + 0.94429533119414 + 0.94429559126038 + 0.94429590684331 + 0.94429629018094 + 0.94429675630285 + 0.94429732370305 + 0.94429801518946 + 0.94429885920191 + 0.94429989273758 + 0.94430116700295 + 0.94430274848618 + 0.94430471750785 + 0.94430717317738 + 0.94431024636729 + 0.94431410156558 + 0.94431894730307 + 0.94432505013530 + 0.94433275145509 + 0.94434248939280 + 0.94435482739037 + 0.94437049164465 + 0.94439043836093 + 0.94441593270297 + 0.94444860886111 + 0.94449061128756 + 0.94454475291170 + 0.94461458586603 + 0.94470364061792 + 0.94481489409719 + 0.94495309874642 + 0.94512410103759 + 0.94533253116519 + 0.94558553094816 + 0.94589508273432 + 0.94627778176316 + 0.94675605827403 + 0.94736046363869 + 0.94813368363124 + 0.94913554049255 + 0.95045145526278 + 0.95220852644471 + 0.95460556062305 + 0.95797907819734 + 0.96298371424855 + 0.97130033112451 + 1.00000000000000 + 0.96769045556594 + 0.95317467892583 + 0.94043464312887 + 0.92812568610043 + 0.91574490503588 + 0.90304397268700 + 0.88989068588248 + 0.87622402861577 + 0.86203940932161 + 0.84737769951782 + 0.83230485377545 + 0.81691868754231 + 0.80136325472442 + 0.78580003898396 + 0.77805754189404 + 0.77036551392281 + 0.76273612033964 + 0.75517801296061 + 0.74769601050299 + 0.74029090882600 + 0.73295946527614 + 0.72569464858482 + 0.71848614120117 + 0.71131831362401 + 0.70412476855135 + 0.69671036224577 + 0.68897382108445 + 0.68090409330217 + 0.67249099499235 + 0.66374368488679 + 0.65467511570743 + 0.64530102724858 + 0.63563941071393 + 0.62571051058157 + 0.61553594948702 + 0.60511627959389 + 0.59447630768295 + 0.58364623066323 + 0.57266211075556 + 0.56156540337444 + 0.55040121673245 + 0.53920234066332 + 0.52799472445519 + 0.51680782861487 + 0.50566016014535 + 0.49455683341907 + 0.93777519848146 + 0.93777528994838 + 0.93777530512139 + 0.93777532281356 + 0.93777534344495 + 0.93777536750564 + 0.93777539556959 + 0.93777542830725 + 0.93777546652196 + 0.93777551122334 + 0.93777556388522 + 0.93777562667145 + 0.93777570216562 + 0.93777579321983 + 0.93777590316783 + 0.93777603602632 + 0.93777619666962 + 0.93777639102287 + 0.93777662649678 + 0.93777691235449 + 0.93777725971761 + 0.93777768224480 + 0.93777819673059 + 0.93777882389911 + 0.93777958957213 + 0.93778052737390 + 0.93778168391330 + 0.93778311975635 + 0.93778490796710 + 0.93778713864755 + 0.93778993079427 + 0.93779343385899 + 0.93779783714987 + 0.93780338245351 + 0.93781037915342 + 0.93781922385662 + 0.93783042598916 + 0.93784464123112 + 0.93786273208997 + 0.93788583860409 + 0.93791543038921 + 0.93795343251868 + 0.93800236483651 + 0.93806539616747 + 0.93814561999748 + 0.93824554210242 + 0.93836922383690 + 0.93852161137174 + 0.93870635851388 + 0.93892922997853 + 0.93920014583605 + 0.93953281289731 + 0.93994561905461 + 0.94046336547831 + 0.94112030625192 + 0.94196362478310 + 0.94305908802033 + 0.94450138614108 + 0.94643162823510 + 0.94907134575104 + 0.95280019118856 + 0.95837042950509 + 0.96769045556594 + 1.00000000000000 + 0.96362350877922 + 0.94735038929106 + 0.93317751383501 + 0.91959487357583 + 0.90604380735829 + 0.89225762219307 + 0.87810486298964 + 0.86353926020912 + 0.84857511345010 + 0.83326044721586 + 0.81768062585078 + 0.80197075632657 + 0.78628531102906 + 0.77849186353930 + 0.77075481249368 + 0.76308570916224 + 0.75549263179326 + 0.74797986559571 + 0.74054771289120 + 0.73319247677495 + 0.72590670983875 + 0.71867971527983 + 0.71149551468399 + 0.70428730314666 + 0.69685936930796 + 0.68911016690410 + 0.68102857400979 + 0.67260434976176 + 0.66384662731258 + 0.65476833684735 + 0.64538519606805 + 0.63571517358307 + 0.62577849087168 + 0.61559674668601 + 0.60517045485074 + 0.59452440186394 + 0.58368876599172 + 0.57269959255911 + 0.56159832148902 + 0.55043004564125 + 0.53922753364289 + 0.52801671009219 + 0.51682700908504 + 0.50567690495512 + 0.49457147411105 + 0.93050514778001 + 0.93050523050042 + 0.93050524422043 + 0.93050526021801 + 0.93050527887254 + 0.93050530062672 + 0.93050532599943 + 0.93050535559628 + 0.93050539013954 + 0.93050543054565 + 0.93050547815157 + 0.93050553492519 + 0.93050560321539 + 0.93050568561934 + 0.93050578516619 + 0.93050590550733 + 0.93050605107560 + 0.93050622725946 + 0.93050644080020 + 0.93050670012924 + 0.93050701536696 + 0.93050739893707 + 0.93050786611708 + 0.93050843575168 + 0.93050913132031 + 0.93050998341081 + 0.93051103449990 + 0.93051233980871 + 0.93051396588443 + 0.93051599471850 + 0.93051853463537 + 0.93052172157013 + 0.93052572757028 + 0.93053077220206 + 0.93053713615078 + 0.93054517884640 + 0.93055536140393 + 0.93056827650409 + 0.93058470303991 + 0.93060566947155 + 0.93063249896841 + 0.93066692172512 + 0.93071119777093 + 0.93076815754409 + 0.93084051407394 + 0.93093037172409 + 0.93104120060619 + 0.93117718258205 + 0.93134116480491 + 0.93153777415884 + 0.93177522229897 + 0.93206484420575 + 0.93242175252277 + 0.93286617040556 + 0.93342578674115 + 0.93413824078955 + 0.93505506042941 + 0.93624872656058 + 0.93782376450862 + 0.93993661110503 + 0.94283674030359 + 0.94696290772369 + 0.95317467892583 + 0.96362350877922 + 1.00000000000000 + 0.95904222205580 + 0.94084967956577 + 0.92515355695315 + 0.91024686292947 + 0.89550737256128 + 0.88064890295396 + 0.86554402971801 + 0.85015950660075 + 0.83451329577380 + 0.81867085500826 + 0.80275347294545 + 0.78690513284667 + 0.77904418756590 + 0.77124771659724 + 0.76352640324782 + 0.75588752189122 + 0.74833461560451 + 0.74086730475564 + 0.73348126854357 + 0.72616849108287 + 0.71891775999505 + 0.71171262521425 + 0.70448574230866 + 0.69704066772555 + 0.68927549984502 + 0.68117901749407 + 0.67274089859528 + 0.66397023506702 + 0.65487992006396 + 0.64548563499370 + 0.63580531172226 + 0.62585913475041 + 0.61566866518714 + 0.60523436244791 + 0.59458098124306 + 0.58373867078523 + 0.57274345024749 + 0.56163673586956 + 0.55046359774668 + 0.53925677548374 + 0.52804216114734 + 0.51684915475099 + 0.50569618954951 + 0.49458829499870 + 0.92243875884664 + 0.92243883375265 + 0.92243884617525 + 0.92243886065974 + 0.92243887754945 + 0.92243889724338 + 0.92243892021112 + 0.92243894700351 + 0.92243897826975 + 0.92243901484044 + 0.92243905793117 + 0.92243910933163 + 0.92243917118559 + 0.92243924585031 + 0.92243933608921 + 0.92243944521948 + 0.92243957727806 + 0.92243973717083 + 0.92243993103573 + 0.92244016655171 + 0.92244045293792 + 0.92244080150498 + 0.92244122616506 + 0.92244174406731 + 0.92244237658340 + 0.92244315156496 + 0.92244410775619 + 0.92244529554320 + 0.92244677560075 + 0.92244862259939 + 0.92245093524771 + 0.92245383729960 + 0.92245748527698 + 0.92246207876501 + 0.92246787267278 + 0.92247519308641 + 0.92248445783535 + 0.92249620324517 + 0.92251113348142 + 0.92253017740451 + 0.92255452770488 + 0.92258574126951 + 0.92262584758876 + 0.92267737804305 + 0.92274271423524 + 0.92282361883713 + 0.92292305593203 + 0.92304455796116 + 0.92319030604098 + 0.92336398525279 + 0.92357238553819 + 0.92382488067551 + 0.92413390291274 + 0.92451597878383 + 0.92499358378376 + 0.92559695060211 + 0.92636689246504 + 0.92735984049287 + 0.92865529550419 + 0.93036844209065 + 0.93267485244367 + 0.93586347391805 + 0.94043464312887 + 0.94735038929106 + 0.95904222205580 + 1.00000000000000 + 0.95389890734749 + 0.93363157242318 + 0.91633429528203 + 0.90007109573027 + 0.88414779924732 + 0.86825898982663 + 0.85227875579749 + 0.83617127554665 + 0.81996854481977 + 0.80376967049845 + 0.78770247613829 + 0.77975145466701 + 0.77187601808254 + 0.76408560441078 + 0.75638634680749 + 0.74878074439006 + 0.74126746587888 + 0.73384132600529 + 0.72649352615093 + 0.71921214800508 + 0.71198009966481 + 0.70472931763032 + 0.69726240752961 + 0.68947700111011 + 0.68136173654283 + 0.67290617593643 + 0.66411934691179 + 0.65501408426972 + 0.64560601243634 + 0.63591300609550 + 0.62595519272452 + 0.61575407624662 + 0.60531003954509 + 0.59464778934684 + 0.58379743122673 + 0.57279494530738 + 0.56168171281114 + 0.55050277091190 + 0.53929081977040 + 0.52807170865530 + 0.51687479356600 + 0.50571845599103 + 0.49460766713137 + 0.91354163601666 + 0.91354170389332 + 0.91354171514938 + 0.91354172827209 + 0.91354174357333 + 0.91354176141554 + 0.91354178222305 + 0.91354180649097 + 0.91354183481170 + 0.91354186793460 + 0.91354190696512 + 0.91354195353495 + 0.91354200959439 + 0.91354207729484 + 0.91354215914608 + 0.91354225817412 + 0.91354237805275 + 0.91354252325097 + 0.91354269935943 + 0.91354291338115 + 0.91354317371352 + 0.91354349066256 + 0.91354387690282 + 0.91354434805682 + 0.91354492358238 + 0.91354562886303 + 0.91354649925837 + 0.91354758077912 + 0.91354892877315 + 0.91355061131217 + 0.91355271839822 + 0.91355536280200 + 0.91355868702834 + 0.91356287267406 + 0.91356815145873 + 0.91357481950749 + 0.91358325581575 + 0.91359394623277 + 0.91360752806621 + 0.91362484117251 + 0.91364696189486 + 0.91367529287977 + 0.91371165889454 + 0.91375832685895 + 0.91381738969170 + 0.91389031977424 + 0.91397964836212 + 0.91408835636697 + 0.91421807655959 + 0.91437171497975 + 0.91455487606184 + 0.91477530569762 + 0.91504322920865 + 0.91537216100414 + 0.91578038196423 + 0.91629226906511 + 0.91694035927217 + 0.91776905299301 + 0.91883982973445 + 0.92023973278097 + 0.92209752125305 + 0.92461677284597 + 0.92812568610043 + 0.93317751383501 + 0.94084967956577 + 0.95389890734749 + 1.00000000000000 + 0.94814399733492 + 0.92565767520442 + 0.90669971168936 + 0.88907099692743 + 0.87199771413950 + 0.85515053773392 + 0.83838880952715 + 0.82168453425786 + 0.80509941959276 + 0.78873544216611 + 0.78066323770221 + 0.77268207390462 + 0.76479956788353 + 0.75702020588682 + 0.74934499747309 + 0.74177126685525 + 0.73429261793983 + 0.72689916407381 + 0.71957801216075 + 0.71231119019896 + 0.70502966932052 + 0.69753481210178 + 0.68972363292924 + 0.68158456983002 + 0.67310701950383 + 0.66429991119546 + 0.65517599007187 + 0.64575079349821 + 0.63604210956365 + 0.62606998012792 + 0.61585582429590 + 0.60539991803849 + 0.59472689742382 + 0.58386680410515 + 0.57285556129786 + 0.56173449961593 + 0.55054860948403 + 0.53933053775941 + 0.52810607750376 + 0.51690452789617 + 0.50574420508259 + 0.49463000782174 + 0.90379090141893 + 0.90379096292710 + 0.90379097312567 + 0.90379098501620 + 0.90379099887848 + 0.90379101504331 + 0.90379103389238 + 0.90379105587573 + 0.90379108153000 + 0.90379111153192 + 0.90379114688614 + 0.90379118908098 + 0.90379123989153 + 0.90379130128083 + 0.90379137552914 + 0.90379146539694 + 0.90379157422662 + 0.90379170609162 + 0.90379186608504 + 0.90379206059181 + 0.90379229726523 + 0.90379258550026 + 0.90379293684445 + 0.90379336553448 + 0.90379388929782 + 0.90379453127157 + 0.90379532374008 + 0.90379630873777 + 0.90379753678083 + 0.90379906995500 + 0.90380099037590 + 0.90380340086658 + 0.90380643127173 + 0.90381024694112 + 0.90381505868625 + 0.90382113566122 + 0.90382882196241 + 0.90383855814642 + 0.90385092161705 + 0.90386667258366 + 0.90388678351556 + 0.90391251963253 + 0.90394552372291 + 0.90398782862768 + 0.90404127582228 + 0.90410709166176 + 0.90418743755951 + 0.90428482655305 + 0.90440044206225 + 0.90453654722901 + 0.90469775753446 + 0.90489046521378 + 0.90512307223256 + 0.90540662474632 + 0.90575599954691 + 0.90619088522807 + 0.90673730935087 + 0.90743042114232 + 0.90831824874253 + 0.90946764420440 + 0.91097548896219 + 0.91299118701131 + 0.91574490503588 + 0.91959487357583 + 0.92515355695315 + 0.93363157242318 + 0.94814399733492 + 1.00000000000000 + 0.94172947827659 + 0.91689692649386 + 0.89624288014849 + 0.87726889655241 + 0.85910986740765 + 0.84139477552017 + 0.82397845610232 + 0.80685541670222 + 0.79008424628820 + 0.78184739006852 + 0.77372339366657 + 0.76571714472000 + 0.75783070143559 + 0.75006290838780 + 0.74240915956351 + 0.73486133919042 + 0.72740802975009 + 0.72003497776595 + 0.71272299302231 + 0.70540173943471 + 0.69787094221715 + 0.69002679197524 + 0.68185744037005 + 0.67335204698930 + 0.66451939227163 + 0.65537208581886 + 0.64592553426281 + 0.63619739685319 + 0.62620758915818 + 0.61597740655168 + 0.60550697636750 + 0.59482083245294 + 0.58394892442708 + 0.57292709400193 + 0.56179659985524 + 0.55060236689772 + 0.53937697030517 + 0.52814612941232 + 0.51693907005248 + 0.50577402577338 + 0.49465580506606 + 0.89317765416446 + 0.89317770986487 + 0.89317771909970 + 0.89317772986608 + 0.89317774241772 + 0.89317775705300 + 0.89317777411767 + 0.89317779401921 + 0.89317781724090 + 0.89317784439943 + 0.89317787640381 + 0.89317791461163 + 0.89317796063904 + 0.89317801627111 + 0.89317808358811 + 0.89317816509784 + 0.89317826384632 + 0.89317838354395 + 0.89317852882877 + 0.89317870552071 + 0.89317892059702 + 0.89317918261587 + 0.89317950210280 + 0.89317989202600 + 0.89318036853831 + 0.89318095273481 + 0.89318167409594 + 0.89318257102282 + 0.89318368963421 + 0.89318508657257 + 0.89318683678545 + 0.89318903406135 + 0.89319179676926 + 0.89319527554679 + 0.89319966231051 + 0.89320520186767 + 0.89321220687050 + 0.89322107715189 + 0.89323233631298 + 0.89324667315775 + 0.89326496723787 + 0.89328836110535 + 0.89331833552234 + 0.89335671584465 + 0.89340512445773 + 0.89346457977578 + 0.89353692751591 + 0.89362428438955 + 0.89372746797667 + 0.89384821288036 + 0.89399031023555 + 0.89415902623516 + 0.89436125410707 + 0.89460601117111 + 0.89490539708123 + 0.89527531586492 + 0.89573661287251 + 0.89631719783580 + 0.89705480595119 + 0.89800128576954 + 0.89923071015617 + 0.90085557390012 + 0.90304397268700 + 0.90604380735829 + 0.91024686292947 + 0.91633429528203 + 0.92565767520442 + 0.94172947827659 + 1.00000000000000 + 0.93461113214173 + 0.90732871818307 + 0.88497268695725 + 0.86470403236160 + 0.84554354932729 + 0.82708801927015 + 0.80920049563102 + 0.79186199489583 + 0.78339857172493 + 0.77507942019115 + 0.76690520217417 + 0.75887429473705 + 0.75098231877477 + 0.74322183860222 + 0.73558225139919 + 0.72804995167186 + 0.72060876137280 + 0.71323778378571 + 0.70586489393622 + 0.69828764094582 + 0.69040110510974 + 0.68219302518570 + 0.67365221892754 + 0.66478724290437 + 0.65561050350090 + 0.64613721307670 + 0.63638484134378 + 0.62637311976964 + 0.61612316524423 + 0.60563489914046 + 0.59493270923016 + 0.58404641428987 + 0.57301174075743 + 0.56186984625309 + 0.55066556481842 + 0.53943137555551 + 0.52819290118223 + 0.51697927284226 + 0.50580861950741 + 0.49468563693726 + 0.88171067337343 + 0.88171072374534 + 0.88171073209581 + 0.88171074183060 + 0.88171075318012 + 0.88171076641275 + 0.88171078184054 + 0.88171079983367 + 0.88171082082620 + 0.88171084537628 + 0.88171087431083 + 0.88171090886321 + 0.88171095050561 + 0.88171100085907 + 0.88171106181635 + 0.88171113565998 + 0.88171122516080 + 0.88171133369416 + 0.88171146548220 + 0.88171162582930 + 0.88171182108591 + 0.88171205904959 + 0.88171234930840 + 0.88171270366912 + 0.88171313684674 + 0.88171366806604 + 0.88171432423907 + 0.88171514044420 + 0.88171615877702 + 0.88171743091461 + 0.88171902526123 + 0.88172102737605 + 0.88172354518231 + 0.88172671595372 + 0.88173071446654 + 0.88173576348073 + 0.88174214723055 + 0.88175022880380 + 0.88176048334930 + 0.88177353544876 + 0.88179018130579 + 0.88181145368632 + 0.88183868870239 + 0.88187352736018 + 0.88191740092482 + 0.88197115252748 + 0.88203635861500 + 0.88211480060656 + 0.88220700071417 + 0.88231426119226 + 0.88243968696760 + 0.88258760795182 + 0.88276366852571 + 0.88297521594109 + 0.88323207732172 + 0.88354708612275 + 0.88393692923762 + 0.88442378384427 + 0.88503737328925 + 0.88581812340145 + 0.88682321820812 + 0.88813875534760 + 0.88989068588248 + 0.89225762219307 + 0.89550737256128 + 0.90007109573027 + 0.90669971168936 + 0.91689692649386 + 0.93461113214173 + 1.00000000000000 + 0.92674990020663 + 0.89694380550348 + 0.87290940025284 + 0.85141819186907 + 0.83138331575428 + 0.81237802270424 + 0.79423240342331 + 0.78545193297047 + 0.77686216972839 + 0.76845695126977 + 0.76022886591710 + 0.75216858009756 + 0.74426439462643 + 0.73650202358024 + 0.72886466959048 + 0.72133338319041 + 0.71388484006577 + 0.70644443444927 + 0.69880679150771 + 0.69086547670237 + 0.68260762726340 + 0.67402156403997 + 0.66511550700251 + 0.65590155897664 + 0.64639464519512 + 0.63661195832422 + 0.62657296337832 + 0.61629852166544 + 0.60578826967519 + 0.59506638822552 + 0.58416251172267 + 0.57311220502717 + 0.56195648504337 + 0.55074006069426 + 0.53949528264325 + 0.52824764705078 + 0.51702616273472 + 0.50584882604836 + 0.49472019164096 + 0.86942181862021 + 0.86942186407835 + 0.86942187161391 + 0.86942188039784 + 0.86942189063889 + 0.86942190257848 + 0.86942191649928 + 0.86942193273130 + 0.86942195166993 + 0.86942197381801 + 0.86942199992416 + 0.86942203110770 + 0.86942206870664 + 0.86942211419507 + 0.86942216929266 + 0.86942223606992 + 0.86942231704654 + 0.86942241528735 + 0.86942253463643 + 0.86942267991596 + 0.86942285690398 + 0.86942307269743 + 0.86942333601969 + 0.86942365761415 + 0.86942405087460 + 0.86942453330609 + 0.86942512946356 + 0.86942587136620 + 0.86942679742329 + 0.86942795475298 + 0.86942940576832 + 0.86943122849843 + 0.86943352132695 + 0.86943640933364 + 0.86944005167928 + 0.86944465107860 + 0.86945046597144 + 0.86945782616955 + 0.86946716300378 + 0.86947904306473 + 0.86949418749965 + 0.86951353043666 + 0.86953827837300 + 0.86956990791687 + 0.86960968324824 + 0.86965830006407 + 0.86971710513752 + 0.86978759646402 + 0.86987006020233 + 0.86996544703189 + 0.87007629147426 + 0.87020614541976 + 0.87035961959393 + 0.87054268560416 + 0.87076330759393 + 0.87103181955179 + 0.87136155373425 + 0.87177011101211 + 0.87228090340675 + 0.87292550947323 + 0.87374829934807 + 0.87481583274501 + 0.87622402861577 + 0.87810486298964 + 0.88064890295396 + 0.88414779924732 + 0.88907099692743 + 0.89624288014849 + 0.90732871818307 + 0.92674990020663 + 1.00000000000000 + 0.91811154760759 + 0.88573615592585 + 0.86006864407609 + 0.83747801534049 + 0.81676905063249 + 0.79744099430467 + 0.78820654214201 + 0.77923398756754 + 0.77050551924746 + 0.76200417502395 + 0.75371268358478 + 0.74561268631236 + 0.73768427035705 + 0.72990585506999 + 0.72225440638158 + 0.71470307653158 + 0.70717376012661 + 0.69945709872387 + 0.69144455939079 + 0.68312239100103 + 0.67447818386696 + 0.66551964985494 + 0.65625843786861 + 0.64670904912769 + 0.63688827231371 + 0.62681518816141 + 0.61651029344075 + 0.60597283066362 + 0.59522668909172 + 0.58430124487931 + 0.57323183783410 + 0.56205929012008 + 0.55082813927712 + 0.53957056454625 + 0.52831189626453 + 0.51708098508449 + 0.50589565883341 + 0.49476029507667 + 0.85637200399154 + 0.85637204490023 + 0.85637205168049 + 0.85637205958412 + 0.85637206879851 + 0.85637207954029 + 0.85637209206507 + 0.85637210666931 + 0.85637212370749 + 0.85637214363304 + 0.85637216712152 + 0.85637219518816 + 0.85637222904866 + 0.85637227003681 + 0.85637231971114 + 0.85637237995127 + 0.85637245304083 + 0.85637254176018 + 0.85637264960006 + 0.85637278093978 + 0.85637294103074 + 0.85637313631716 + 0.85637337472771 + 0.85637366602745 + 0.85637402238717 + 0.85637445973455 + 0.85637500044285 + 0.85637567371165 + 0.85637651454915 + 0.85637756588665 + 0.85637888462243 + 0.85638054186434 + 0.85638262724569 + 0.85638525467304 + 0.85638856902021 + 0.85639275469887 + 0.85639804663049 + 0.85640474435012 + 0.85641323937439 + 0.85642404569913 + 0.85643781656351 + 0.85645539705992 + 0.85647787699637 + 0.85650658571853 + 0.85654264084408 + 0.85658661433420 + 0.85663965690934 + 0.85670302709461 + 0.85677682485837 + 0.85686171708279 + 0.85695976491380 + 0.85707387426167 + 0.85720780076664 + 0.85736638295825 + 0.85755605651764 + 0.85778511720581 + 0.85806418236498 + 0.85840718021882 + 0.85883251041135 + 0.85936481596177 + 0.86003857378432 + 0.86090551841174 + 0.86203940932161 + 0.86353926020912 + 0.86554402971801 + 0.86825898982663 + 0.87199771413950 + 0.87726889655241 + 0.88497268695725 + 0.89694380550348 + 0.91811154760759 + 1.00000000000000 + 0.90865460720705 + 0.87368283351751 + 0.84648959177524 + 0.82301127904859 + 0.80187487073339 + 0.79196879801000 + 0.78243949609407 + 0.77324774229882 + 0.76435978109697 + 0.75574490420264 + 0.74737384374151 + 0.73921772864840 + 0.73124755066607 + 0.72343406833930 + 0.71574518284230 + 0.70809773994698 + 0.70027685482053 + 0.69217103081361 + 0.68376518135993 + 0.67504580642162 + 0.66601984428817 + 0.65669826126047 + 0.64709493036681 + 0.63722605029405 + 0.62711014753087 + 0.61676719935431 + 0.60619590253137 + 0.59541973668981 + 0.58446771747266 + 0.57337487236732 + 0.56218175507079 + 0.55093266912340 + 0.53965956502540 + 0.52838755563106 + 0.51714528673859 + 0.50595037145798 + 0.49480696442748 + 0.84265002323852 + 0.84265005992202 + 0.84265006600135 + 0.84265007308879 + 0.84265008135066 + 0.84265009098200 + 0.84265010221091 + 0.84265011530381 + 0.84265013057836 + 0.84265014844067 + 0.84265016950116 + 0.84265019467821 + 0.84265022507087 + 0.84265026188612 + 0.84265030653050 + 0.84265036070755 + 0.84265042648173 + 0.84265050637204 + 0.84265060353782 + 0.84265072195285 + 0.84265086637554 + 0.84265104265063 + 0.84265125796759 + 0.84265152118903 + 0.84265184335615 + 0.84265223893641 + 0.84265272828635 + 0.84265333799497 + 0.84265409992666 + 0.84265505314346 + 0.84265624945259 + 0.84265775358442 + 0.84265964710369 + 0.84266203364035 + 0.84266504494749 + 0.84266884863517 + 0.84267365809190 + 0.84267974516878 + 0.84268746504731 + 0.84269728376559 + 0.84270979281710 + 0.84272575651033 + 0.84274615904043 + 0.84277219714393 + 0.84280485937767 + 0.84284461405579 + 0.84289244439695 + 0.84294940660837 + 0.84301545648070 + 0.84309103403706 + 0.84317780847555 + 0.84327815017875 + 0.84339510838942 + 0.84353258945200 + 0.84369577581957 + 0.84389130114924 + 0.84412758370955 + 0.84441559745429 + 0.84476974383598 + 0.84520918944128 + 0.84576068543228 + 0.84646452181333 + 0.84737769951782 + 0.84857511345010 + 0.85015950660075 + 0.85227875579749 + 0.85515053773392 + 0.85910986740765 + 0.86470403236160 + 0.87290940025284 + 0.88573615592585 + 0.90865460720705 + 1.00000000000000 + 0.89830986623430 + 0.86078666052970 + 0.83228567677799 + 0.80819234822610 + 0.79724314986747 + 0.78687042232797 + 0.77699135387608 + 0.76753998225009 + 0.75846109735093 + 0.74970637788851 + 0.74123188011241 + 0.73299649828297 + 0.72496116158034 + 0.71708566278630 + 0.70927934006443 + 0.70131944956016 + 0.69309020018362 + 0.68457445138058 + 0.67575704319436 + 0.66664372010612 + 0.65724441114993 + 0.64757205116317 + 0.63764197205329 + 0.62747189755268 + 0.61708106236809 + 0.60646740373413 + 0.59565382530078 + 0.58466883938262 + 0.57354704021973 + 0.56232861161178 + 0.55105753764729 + 0.53976546298392 + 0.52847721426198 + 0.51722117092186 + 0.50601467120245 + 0.49486158764444 + 0.82835810165022 + 0.82835813440728 + 0.82835813983631 + 0.82835814616421 + 0.82835815354092 + 0.82835816214003 + 0.82835817216518 + 0.82835818385459 + 0.82835819749086 + 0.82835821343747 + 0.82835823224374 + 0.82835825473633 + 0.82835828190738 + 0.82835831484638 + 0.82835835482160 + 0.82835840336938 + 0.82835846235248 + 0.82835853404340 + 0.82835862130037 + 0.82835872771570 + 0.82835885759101 + 0.82835901621777 + 0.82835921010080 + 0.82835944726060 + 0.82835973769933 + 0.82836009452660 + 0.82836053623052 + 0.82836108697758 + 0.82836177571362 + 0.82836263792095 + 0.82836372068962 + 0.82836508284136 + 0.82836679848951 + 0.82836896176535 + 0.82837169231330 + 0.82837514226692 + 0.82837950519968 + 0.82838502753444 + 0.82839203110868 + 0.82840093801771 + 0.82841228329603 + 0.82842675753439 + 0.82844524879741 + 0.82846883368579 + 0.82849838654400 + 0.82853428905905 + 0.82857738107634 + 0.82862854786740 + 0.82868763638048 + 0.82875490768750 + 0.82883170740038 + 0.82891996287528 + 0.82902214109441 + 0.82914138326771 + 0.82928184630464 + 0.82944881093557 + 0.82964891679067 + 0.82989076285669 + 0.83018555909986 + 0.83054813611206 + 0.83099917661356 + 0.83157004205687 + 0.83230485377545 + 0.83326044721586 + 0.83451329577380 + 0.83617127554665 + 0.83838880952715 + 0.84139477552017 + 0.84554354932729 + 0.85141819186907 + 0.86006864407609 + 0.87368283351751 + 0.89830986623430 + 1.00000000000000 + 0.88705420898573 + 0.84715407755175 + 0.81764238667139 + 0.80494340125914 + 0.79321011704971 + 0.78225666288141 + 0.77194717739744 + 0.76217687563312 + 0.75286107720615 + 0.74392847525155 + 0.73531692895492 + 0.72697090114565 + 0.71883704080554 + 0.71081304504243 + 0.70266459390324 + 0.69426945396654 + 0.68560722962047 + 0.67666016644711 + 0.66743212933132 + 0.65793144419077 + 0.64816962448960 + 0.63816071322236 + 0.62792125948051 + 0.61746942713674 + 0.60680208587082 + 0.59594132433752 + 0.58491494827926 + 0.57375694799239 + 0.56250699525662 + 0.55120863593858 + 0.53989310287540 + 0.52858484300738 + 0.51731188644989 + 0.50609121620673 + 0.49492634422826 + 0.81362107826320 + 0.81362110737892 + 0.81362111220345 + 0.81362111782758 + 0.81362112438357 + 0.81362113202650 + 0.81362114093594 + 0.81362115132313 + 0.81362116344137 + 0.81362117761238 + 0.81362119432880 + 0.81362121433443 + 0.81362123852101 + 0.81362126786999 + 0.81362130351967 + 0.81362134685030 + 0.81362139954120 + 0.81362146363723 + 0.81362154171464 + 0.81362163701287 + 0.81362175341329 + 0.81362189569059 + 0.81362206971878 + 0.81362228274301 + 0.81362254379501 + 0.81362286473581 + 0.81362326231861 + 0.81362375846230 + 0.81362437940963 + 0.81362515733052 + 0.81362613493818 + 0.81362736559464 + 0.81362891651169 + 0.81363087305016 + 0.81363334367090 + 0.81363646623369 + 0.81364041605443 + 0.81364541617009 + 0.81365175776772 + 0.81365982260029 + 0.81367009397131 + 0.81368319505353 + 0.81369992616503 + 0.81372125478516 + 0.81374795394049 + 0.81378033321276 + 0.81381910975422 + 0.81386502467053 + 0.81391784572881 + 0.81397769535987 + 0.81404565343352 + 0.81412328241510 + 0.81421257158310 + 0.81431603720557 + 0.81443700097118 + 0.81457964771883 + 0.81474918559010 + 0.81495231295344 + 0.81519770179170 + 0.81549675813621 + 0.81586539864436 + 0.81632799321518 + 0.81691868754231 + 0.81768062585078 + 0.81867085500826 + 0.81996854481977 + 0.82168453425786 + 0.82397845610232 + 0.82708801927015 + 0.83138331575428 + 0.83747801534049 + 0.84648959177524 + 0.86078666052970 + 0.88705420898573 + 1.00000000000000 + 0.87495529382731 + 0.83295962723066 + 0.81691668115644 + 0.80275626291467 + 0.78998291106144 + 0.77827778092502 + 0.76741935856070 + 0.75724428884909 + 0.74762603752109 + 0.73846243740930 + 0.72966815822627 + 0.72116708904565 + 0.71283782717705 + 0.70442817855202 + 0.69580579401227 + 0.68694490757746 + 0.67782356236861 + 0.66844257590952 + 0.65880773288649 + 0.64892834588358 + 0.63881650514848 + 0.62848701334573 + 0.61795646873097 + 0.60722021998569 + 0.59629919069626 + 0.58522018573018 + 0.57401634665683 + 0.56272663118475 + 0.55139397954365 + 0.54004906523102 + 0.52871582666548 + 0.51742183135579 + 0.50618359842208 + 0.49500417390399 + 0.79860299910828 + 0.79860302487175 + 0.79860302914130 + 0.79860303411722 + 0.79860303991744 + 0.79860304667984 + 0.79860305456285 + 0.79860306375303 + 0.79860307447345 + 0.79860308701208 + 0.79860310180541 + 0.79860311952366 + 0.79860314096651 + 0.79860316701169 + 0.79860319868418 + 0.79860323721904 + 0.79860328412387 + 0.79860334123698 + 0.79860341087416 + 0.79860349594922 + 0.79860359996080 + 0.79860372720444 + 0.79860388297826 + 0.79860407380770 + 0.79860430784181 + 0.79860459579164 + 0.79860495280870 + 0.79860539874502 + 0.79860595735585 + 0.79860665775536 + 0.79860753863798 + 0.79860864833550 + 0.79861004771706 + 0.79861181408134 + 0.79861404561730 + 0.79861686709071 + 0.79862043708397 + 0.79862495722722 + 0.79863069067254 + 0.79863798229685 + 0.79864726821422 + 0.79865911018759 + 0.79867422877032 + 0.79869349266356 + 0.79871758532066 + 0.79874675677323 + 0.79878161965540 + 0.79882279418709 + 0.79886999350720 + 0.79892323519358 + 0.79898338281110 + 0.79905170072404 + 0.79912978956150 + 0.79921965957408 + 0.79932395810810 + 0.79944599020337 + 0.79958982247369 + 0.79976064598401 + 0.79996513185705 + 0.80021200257120 + 0.80051345431144 + 0.80088839852918 + 0.80136325472442 + 0.80197075632657 + 0.80275347294545 + 0.80376967049845 + 0.80509941959276 + 0.80685541670222 + 0.80920049563102 + 0.81237802270424 + 0.81676905063249 + 0.82301127904859 + 0.83228567677799 + 0.84715407755175 + 0.87495529382731 + 1.00000000000000 + 0.86209647895041 + 0.83771357803411 + 0.81835986972312 + 0.80206200364547 + 0.78784011685028 + 0.77512299866756 + 0.76354164301388 + 0.75283956575218 + 0.74282809768518 + 0.73336192711227 + 0.72432181184159 + 0.71555252825067 + 0.70677249772095 + 0.69783251203982 + 0.68869746009378 + 0.67933825115028 + 0.66975056240945 + 0.65993601064615 + 0.64990040055230 + 0.63965279122866 + 0.62920533587320 + 0.61857230494887 + 0.60774684767808 + 0.59674820271628 + 0.58560174338363 + 0.57433940870949 + 0.56299915349472 + 0.55162307565409 + 0.54024108390865 + 0.52887643108104 + 0.51755606805631 + 0.50629590415837 + 0.49509837941621 + 0.78348165148290 + 0.78348167419496 + 0.78348167795878 + 0.78348168234470 + 0.78348168745755 + 0.78348169341888 + 0.78348170036639 + 0.78348170846706 + 0.78348171791639 + 0.78348172896952 + 0.78348174201471 + 0.78348175765252 + 0.78348177659848 + 0.78348179964068 + 0.78348182769338 + 0.78348186186692 + 0.78348190350886 + 0.78348195426869 + 0.78348201622791 + 0.78348209200590 + 0.78348218474491 + 0.78348229831428 + 0.78348243747723 + 0.78348260811468 + 0.78348281756921 + 0.78348307549965 + 0.78348339560817 + 0.78348379585202 + 0.78348429772070 + 0.78348492754719 + 0.78348572035837 + 0.78348671990221 + 0.78348798127037 + 0.78348957441807 + 0.78349158819178 + 0.78349413544775 + 0.78349735957271 + 0.78350144276251 + 0.78350662275496 + 0.78351321100523 + 0.78352160093283 + 0.78353229882721 + 0.78354595330572 + 0.78356334435456 + 0.78358507673656 + 0.78361135178235 + 0.78364269370719 + 0.78367962214416 + 0.78372181535094 + 0.78376921388131 + 0.78382250711580 + 0.78388271829175 + 0.78395113508573 + 0.78402936241190 + 0.78411950898902 + 0.78422418141952 + 0.78434654661390 + 0.78449061432531 + 0.78466149671431 + 0.78486583708424 + 0.78511295621735 + 0.78541753494326 + 0.78580003898396 + 0.78628531102906 + 0.78690513284667 + 0.78770247613829 + 0.78873544216611 + 0.79008424628820 + 0.79186199489583 + 0.79423240342331 + 0.79744099430467 + 0.80187487073339 + 0.80819234822610 + 0.81764238667139 + 0.83295962723066 + 0.86209647895041 + 1.00000000000000 + 0.88546845724055 + 0.84853615738989 + 0.82326268891796 + 0.80356253823983 + 0.78719750844714 + 0.77305536297679 + 0.76048947782607 + 0.74908459338755 + 0.73855422762318 + 0.72868616385075 + 0.71925848512811 + 0.70993682388381 + 0.70054151135007 + 0.69102000145807 + 0.68133033610266 + 0.67145906558084 + 0.66140066339672 + 0.65115513059894 + 0.64072667173637 + 0.63012331478990 + 0.61935579406310 + 0.60841401972034 + 0.59731475776661 + 0.58608130917854 + 0.57474389208616 + 0.56333904093964 + 0.55190767376475 + 0.54047864659022 + 0.52907428214304 + 0.51772070468179 + 0.50643301758183 + 0.49521286857944 + 0.77592905028965 + 0.77592907159091 + 0.77592907512003 + 0.77592907923430 + 0.77592908402933 + 0.77592908961866 + 0.77592909613443 + 0.77592910373053 + 0.77592911259222 + 0.77592912295755 + 0.77592913519484 + 0.77592914986982 + 0.77592916766213 + 0.77592918931410 + 0.77592921569276 + 0.77592924784724 + 0.77592928705512 + 0.77592933487747 + 0.77592939328174 + 0.77592946475549 + 0.77592955227735 + 0.77592965951537 + 0.77592979098945 + 0.77592995227860 + 0.77593015034999 + 0.77593039437963 + 0.77593069739316 + 0.77593107647057 + 0.77593155205055 + 0.77593214917192 + 0.77593290116147 + 0.77593384964115 + 0.77593504702139 + 0.77593655985437 + 0.77593847265420 + 0.77594089276191 + 0.77594395652828 + 0.77594783716496 + 0.77595276065165 + 0.77595902300374 + 0.77596699793122 + 0.77597716615067 + 0.77599014315008 + 0.77600666817875 + 0.77602731044047 + 0.77605225044609 + 0.77608197356849 + 0.77611695583089 + 0.77615686405136 + 0.77620160895309 + 0.77625180641762 + 0.77630837755258 + 0.77637247798035 + 0.77644554232423 + 0.77652945353515 + 0.77662652695646 + 0.77673955657124 + 0.77687206472898 + 0.77702852334744 + 0.77721472549625 + 0.77743881750881 + 0.77771374548709 + 0.77805754189404 + 0.77849186353930 + 0.77904418756590 + 0.77975145466701 + 0.78066323770221 + 0.78184739006852 + 0.78339857172493 + 0.78545193297047 + 0.78820654214201 + 0.79196879801000 + 0.79724314986747 + 0.80494340125914 + 0.81691668115644 + 0.83771357803411 + 0.88546845724055 + 1.00000000000000 + 0.87948524935796 + 0.84156405545615 + 0.81594459574110 + 0.79615534796642 + 0.77981830542262 + 0.76575531669415 + 0.75328480105016 + 0.74197140671251 + 0.73151290903640 + 0.72162779672847 + 0.71193816830532 + 0.70223936587216 + 0.69246436585856 + 0.68256085115139 + 0.67250815693063 + 0.66229527907596 + 0.65191789961369 + 0.64137670854049 + 0.63067681816585 + 0.61982651518150 + 0.60881352290930 + 0.59765294617228 + 0.58636670992872 + 0.57498390084852 + 0.56354012767633 + 0.55207554631195 + 0.54061834183798 + 0.52919025077105 + 0.51781688121086 + 0.50651283869697 + 0.49527928563813 + 0.76840830933443 + 0.76840832930233 + 0.76840833261079 + 0.76840833646690 + 0.76840834096247 + 0.76840834620262 + 0.76840835230941 + 0.76840835943091 + 0.76840836773752 + 0.76840837745448 + 0.76840838892805 + 0.76840840269500 + 0.76840841939652 + 0.76840843973682 + 0.76840846453550 + 0.76840849478371 + 0.76840853169266 + 0.76840857673695 + 0.76840863178541 + 0.76840869919380 + 0.76840878178598 + 0.76840888304190 + 0.76840900724815 + 0.76840915969905 + 0.76840934701139 + 0.76840957789645 + 0.76840986474632 + 0.76841022380556 + 0.76841067451574 + 0.76841124069642 + 0.76841195405936 + 0.76841285421150 + 0.76841399102574 + 0.76841542783427 + 0.76841724504715 + 0.76841954478716 + 0.76842245674801 + 0.76842614564717 + 0.76843082635473 + 0.76843678029425 + 0.76844436256692 + 0.76845402975330 + 0.76846636610570 + 0.76848207253610 + 0.76850168511281 + 0.76852536564610 + 0.76855356396666 + 0.76858671654587 + 0.76862448207297 + 0.76866674639622 + 0.76871405996573 + 0.76876725272548 + 0.76882736271935 + 0.76889567340628 + 0.76897386764568 + 0.76906400355827 + 0.76916854717483 + 0.76929059355659 + 0.76943405513403 + 0.76960398405140 + 0.76980750363417 + 0.77005604382374 + 0.77036551392281 + 0.77075481249368 + 0.77124771659724 + 0.77187601808254 + 0.77268207390462 + 0.77372339366657 + 0.77507942019115 + 0.77686216972839 + 0.77923398756754 + 0.78243949609407 + 0.78687042232797 + 0.79321011704971 + 0.80275626291467 + 0.81835986972312 + 0.84853615738989 + 0.87948524935796 + 1.00000000000000 + 0.87331118105551 + 0.83447919655920 + 0.80858876712649 + 0.78876599408511 + 0.77249233022701 + 0.75852674648019 + 0.74615598886393 + 0.73492363319599 + 0.72445329189333 + 0.71430234916811 + 0.70422945995132 + 0.69414634803725 + 0.68398589789911 + 0.67371732025244 + 0.66332211555947 + 0.65279019758135 + 0.64211766526341 + 0.63130589474351 + 0.62036008822105 + 0.60926526491843 + 0.59803448592520 + 0.58668799915984 + 0.57525352310192 + 0.56376555480332 + 0.55226334114706 + 0.54077427458012 + 0.52931940463517 + 0.51792373853671 + 0.50660130671377 + 0.49535271420985 + 0.76093322054133 + 0.76093323925618 + 0.76093324235612 + 0.76093324597028 + 0.76093325018330 + 0.76093325509412 + 0.76093326081786 + 0.76093326749157 + 0.76093327527651 + 0.76093328438306 + 0.76093329513844 + 0.76093330805165 + 0.76093332372771 + 0.76093334283411 + 0.76093336614615 + 0.76093339460020 + 0.76093342934388 + 0.76093347177522 + 0.76093352366274 + 0.76093358724079 + 0.76093366518877 + 0.76093376080443 + 0.76093387816179 + 0.76093402228135 + 0.76093419944935 + 0.76093441794347 + 0.76093468954647 + 0.76093502972100 + 0.76093545696533 + 0.76093599394446 + 0.76093667084291 + 0.76093752536745 + 0.76093860498905 + 0.76093996999293 + 0.76094169692249 + 0.76094388296683 + 0.76094665153730 + 0.76095015933484 + 0.76095461075315 + 0.76096027344808 + 0.76096748499350 + 0.76097667923565 + 0.76098841103909 + 0.76100334529487 + 0.76102198724695 + 0.76104448193321 + 0.76107124670526 + 0.76110268220236 + 0.76113844184124 + 0.76117839095230 + 0.76122302186081 + 0.76127308328911 + 0.76132950881237 + 0.76139344801278 + 0.76146640682043 + 0.76155021675729 + 0.76164705625079 + 0.76175964689337 + 0.76189141369235 + 0.76204676516599 + 0.76223193615016 + 0.76245703443676 + 0.76273612033964 + 0.76308570916224 + 0.76352640324782 + 0.76408560441078 + 0.76479956788353 + 0.76571714472000 + 0.76690520217417 + 0.76845695126977 + 0.77050551924746 + 0.77324774229882 + 0.77699135387608 + 0.78225666288141 + 0.78998291106144 + 0.80206200364547 + 0.82326268891796 + 0.84156405545615 + 0.87331118105551 + 1.00000000000000 + 0.86695589481981 + 0.82730288305450 + 0.80121829967769 + 0.78141341741645 + 0.76523173184310 + 0.75137412183292 + 0.73909571172526 + 0.72785848783083 + 0.71711827145600 + 0.70657745486309 + 0.69611547683770 + 0.68564346787328 + 0.67511609238277 + 0.66450438789737 + 0.65379043406075 + 0.64296424753677 + 0.63202236018964 + 0.62096604859840 + 0.60977696037870 + 0.59846562480670 + 0.58705023406746 + 0.57555684417134 + 0.56401861167281 + 0.55247369545064 + 0.54094854871489 + 0.52946341378900 + 0.51804259682200 + 0.50669946253541 + 0.49543397476754 + 0.75351400076725 + 0.75351401830684 + 0.75351402121289 + 0.75351402460031 + 0.75351402854876 + 0.75351403315034 + 0.75351403851522 + 0.75351404476905 + 0.75351405206470 + 0.75351406060007 + 0.75351407068405 + 0.75351408279552 + 0.75351409751056 + 0.75351411545945 + 0.75351413737546 + 0.75351416414829 + 0.75351419685988 + 0.75351423683639 + 0.75351428575574 + 0.75351434573571 + 0.75351441931868 + 0.75351450963758 + 0.75351462055399 + 0.75351475684256 + 0.75351492446700 + 0.75351513130366 + 0.75351538856144 + 0.75351571096026 + 0.75351611611092 + 0.75351662558568 + 0.75351726813544 + 0.75351807966148 + 0.75351910538205 + 0.75352040270265 + 0.75352204451472 + 0.75352412336345 + 0.75352675673648 + 0.75353009378485 + 0.75353432903022 + 0.75353971717452 + 0.75354657929384 + 0.75355532786202 + 0.75356649012960 + 0.75358069720389 + 0.75359842567771 + 0.75361980557115 + 0.75364522457588 + 0.75367505090720 + 0.75370893513100 + 0.75374672587849 + 0.75378886392673 + 0.75383602574773 + 0.75388905225952 + 0.75394897469046 + 0.75401714281534 + 0.75409518897541 + 0.75418503999067 + 0.75428909186471 + 0.75441034615871 + 0.75455265389095 + 0.75472148026975 + 0.75492578237186 + 0.75517801296061 + 0.75549263179326 + 0.75588752189122 + 0.75638634680749 + 0.75702020588682 + 0.75783070143559 + 0.75887429473705 + 0.76022886591710 + 0.76200417502395 + 0.76435978109697 + 0.76753998225009 + 0.77194717739744 + 0.77827778092502 + 0.78784011685028 + 0.80356253823983 + 0.81594459574110 + 0.83447919655920 + 0.86695589481981 + 1.00000000000000 + 0.86043135690588 + 0.82005771621152 + 0.79385533962771 + 0.77411370964495 + 0.75804450306784 + 0.74429250300859 + 0.73201844944087 + 0.72050724516232 + 0.70937019518090 + 0.69843561074450 + 0.68758153206011 + 0.67674113315285 + 0.66587050182158 + 0.65494086863531 + 0.64393406044264 + 0.63284024241650 + 0.62165563810305 + 0.61035765088086 + 0.59895364856275 + 0.58745928658687 + 0.57589858962614 + 0.56430309019435 + 0.55270963969522 + 0.54114357450744 + 0.52962418562289 + 0.51817495908394 + 0.50680848732222 + 0.49552399510040 + 0.74615696778866 + 0.74615698423148 + 0.74615698695594 + 0.74615699013113 + 0.74615699383256 + 0.74615699814706 + 0.74615700317570 + 0.74615700903838 + 0.74615701587754 + 0.74615702387952 + 0.74615703333498 + 0.74615704469792 + 0.74615705851565 + 0.74615707538348 + 0.74615709599476 + 0.74615712119120 + 0.74615715200159 + 0.74615718968087 + 0.74615723581940 + 0.74615729242907 + 0.74615736192197 + 0.74615744727295 + 0.74615755215073 + 0.74615768108885 + 0.74615783976026 + 0.74615803565010 + 0.74615827943430 + 0.74615858513344 + 0.74615896951762 + 0.74615945313352 + 0.74616006337321 + 0.74616083444778 + 0.74616180943984 + 0.74616304305117 + 0.74616460473040 + 0.74616658264377 + 0.74616908870767 + 0.74617226496780 + 0.74617629665944 + 0.74618142629518 + 0.74618795944868 + 0.74619628851823 + 0.74620691483577 + 0.74622043784305 + 0.74623730752832 + 0.74625764047235 + 0.74628179729490 + 0.74631011687985 + 0.74634224899408 + 0.74637802889062 + 0.74641785169759 + 0.74646232968443 + 0.74651222167942 + 0.74656845443644 + 0.74663224010919 + 0.74670503623557 + 0.74678854996689 + 0.74688489408037 + 0.74699670314685 + 0.74712734648313 + 0.74728162412866 + 0.74746749317303 + 0.74769601050299 + 0.74797986559571 + 0.74833461560451 + 0.74878074439006 + 0.74934499747309 + 0.75006290838780 + 0.75098231877477 + 0.75216858009756 + 0.75371268358478 + 0.75574490420264 + 0.75846109735093 + 0.76217687563312 + 0.76741935856070 + 0.77512299866756 + 0.78719750844714 + 0.79615534796642 + 0.80858876712649 + 0.82730288305450 + 0.86043135690588 + 1.00000000000000 + 0.85375188638693 + 0.81276707284501 + 0.78652030530175 + 0.76687928668760 + 0.75092886927389 + 0.73719296775661 + 0.72464086550082 + 0.71272584519390 + 0.70119095226651 + 0.68986175762873 + 0.67863860591779 + 0.66745562626001 + 0.65626867787991 + 0.64504834982742 + 0.63377630764931 + 0.62244218525280 + 0.61101798428137 + 0.59950708861097 + 0.58792199933861 + 0.57628424310435 + 0.56462337413415 + 0.55297466532287 + 0.54136211973621 + 0.52980390332998 + 0.51832253996466 + 0.50692972389324 + 0.49562382617468 + 0.73886434533017 + 0.73886436075179 + 0.73886436330704 + 0.73886436628516 + 0.73886436975634 + 0.73886437380294 + 0.73886437851962 + 0.73886438401823 + 0.73886439043309 + 0.73886439793745 + 0.73886440680830 + 0.73886441747587 + 0.73886443045744 + 0.73886444631646 + 0.73886446571103 + 0.73886448943892 + 0.73886451847289 + 0.73886455400769 + 0.73886459754792 + 0.73886465100546 + 0.73886471667296 + 0.73886479737476 + 0.73886489659751 + 0.73886501865081 + 0.73886516893253 + 0.73886535456272 + 0.73886558571076 + 0.73886587573892 + 0.73886624062722 + 0.73886669995707 + 0.73886727984009 + 0.73886801289328 + 0.73886894018781 + 0.73887011387818 + 0.73887160016888 + 0.73887348311287 + 0.73887586937478 + 0.73887889431677 + 0.73888273444012 + 0.73888762080112 + 0.73889384440142 + 0.73890177878877 + 0.73891190097065 + 0.73892478072575 + 0.73894084332412 + 0.73896019333344 + 0.73898316665939 + 0.73901007565173 + 0.73904057101744 + 0.73907447750321 + 0.73911214984159 + 0.73915414329187 + 0.73920114400750 + 0.73925398657998 + 0.73931376199216 + 0.73938177455226 + 0.73945953988839 + 0.73954892483503 + 0.73965224647685 + 0.73977245876092 + 0.73991378783755 + 0.74008332262106 + 0.74029090882600 + 0.74054771289120 + 0.74086730475564 + 0.74126746587888 + 0.74177126685525 + 0.74240915956351 + 0.74322183860222 + 0.74426439462643 + 0.74561268631236 + 0.74737384374151 + 0.74970637788851 + 0.75286107720615 + 0.75724428884909 + 0.76354164301388 + 0.77305536297679 + 0.77981830542262 + 0.78876599408511 + 0.80121829967769 + 0.82005771621152 + 0.85375188638693 + 1.00000000000000 + 0.84693410069659 + 0.80545445570553 + 0.77923087791790 + 0.75971248312548 + 0.74379140923376 + 0.72977330820170 + 0.71681102383835 + 0.70449565768160 + 0.69256516964361 + 0.68086766102317 + 0.66930391773941 + 0.65780742168293 + 0.64633299606272 + 0.63485075070082 + 0.62334159526070 + 0.61177056884407 + 0.60013598183997 + 0.58844637843480 + 0.57672019052877 + 0.56498454746925 + 0.55327280624541 + 0.54160737087779 + 0.53000507162867 + 0.51848729972014 + 0.50706470186536 + 0.49573466064651 + 0.73163424339785 + 0.73163425787237 + 0.73163426027071 + 0.73163426306591 + 0.73163426632374 + 0.73163427012200 + 0.73163427454799 + 0.73163427970921 + 0.73163428572879 + 0.73163429277378 + 0.73163430110198 + 0.73163431112316 + 0.73163432332670 + 0.73163433824830 + 0.73163435651162 + 0.73163437887133 + 0.73163440625302 + 0.73163443978687 + 0.73163448090331 + 0.73163453141966 + 0.73163459351396 + 0.73163466987039 + 0.73163476380540 + 0.73163487942045 + 0.73163502184630 + 0.73163519786739 + 0.73163541717570 + 0.73163569250980 + 0.73163603910683 + 0.73163647563790 + 0.73163702700860 + 0.73163772433195 + 0.73163860678790 + 0.73163972412422 + 0.73164113949669 + 0.73164293307296 + 0.73164520658479 + 0.73164808909688 + 0.73165174889554 + 0.73165640625375 + 0.73166233847749 + 0.73166990139829 + 0.73167954918216 + 0.73169182380093 + 0.73170712755152 + 0.73172555426294 + 0.73174741725509 + 0.73177300487180 + 0.73180197021624 + 0.73183413003071 + 0.73186980331049 + 0.73190949468392 + 0.73195382596420 + 0.73200355047274 + 0.73205965251624 + 0.73212330214344 + 0.73219584814778 + 0.73227894399221 + 0.73237463246093 + 0.73248550980568 + 0.73261530755033 + 0.73277036108364 + 0.73295946527614 + 0.73319247677495 + 0.73348126854357 + 0.73384132600529 + 0.73429261793983 + 0.73486133919042 + 0.73558225139919 + 0.73650202358024 + 0.73768427035705 + 0.73921772864840 + 0.74123188011241 + 0.74392847525155 + 0.74762603752109 + 0.75283956575218 + 0.76048947782607 + 0.76575531669415 + 0.77249233022701 + 0.78141341741645 + 0.79385533962771 + 0.81276707284501 + 0.84693410069659 + 1.00000000000000 + 0.83999677497644 + 0.79814242737369 + 0.77199443405047 + 0.75251330907912 + 0.73630457332841 + 0.72187170830476 + 0.70851001598133 + 0.69580114891909 + 0.68350571275776 + 0.67147175839651 + 0.65959910749326 + 0.64781987387588 + 0.63608811680298 + 0.62437299089127 + 0.61263042823771 + 0.60085219938147 + 0.58904183431517 + 0.57721389831111 + 0.56539252702247 + 0.55360873778555 + 0.54188300682188 + 0.53023057150287 + 0.51867148466188 + 0.50721516737340 + 0.49585785461866 + 0.72446090474278 + 0.72446091834094 + 0.72446092059347 + 0.72446092322014 + 0.72446092628017 + 0.72446092984745 + 0.72446093400606 + 0.72446093885392 + 0.72446094450990 + 0.72446095112777 + 0.72446095895428 + 0.72446096837635 + 0.72446097986014 + 0.72446099391213 + 0.72446101112446 + 0.72446103221255 + 0.72446105805619 + 0.72446108972704 + 0.72446112858705 + 0.72446117636109 + 0.72446123512000 + 0.72446130741783 + 0.72446139641266 + 0.72446150600597 + 0.72446164108220 + 0.72446180810751 + 0.72446201632016 + 0.72446227787638 + 0.72446260730979 + 0.72446302243166 + 0.72446354701225 + 0.72446421074379 + 0.72446505102020 + 0.72446611532081 + 0.72446746392592 + 0.72446917334022 + 0.72447134063425 + 0.72447408894783 + 0.72447757882232 + 0.72448202036708 + 0.72448767799584 + 0.72449489086696 + 0.72450409166889 + 0.72451579625758 + 0.72453038554657 + 0.72454794376200 + 0.72456876356873 + 0.72459311155067 + 0.72462064446822 + 0.72465117320959 + 0.72468498515754 + 0.72472253993173 + 0.72476440234938 + 0.72481125401990 + 0.72486398529537 + 0.72492364853835 + 0.72499144721014 + 0.72506884970916 + 0.72515766191414 + 0.72526017220082 + 0.72537968586488 + 0.72552188385671 + 0.72569464858482 + 0.72590670983875 + 0.72616849108287 + 0.72649352615093 + 0.72689916407381 + 0.72740802975009 + 0.72804995167186 + 0.72886466959048 + 0.72990585506999 + 0.73124755066607 + 0.73299649828297 + 0.73531692895492 + 0.73846243740930 + 0.74282809768518 + 0.74908459338755 + 0.75328480105016 + 0.75852674648019 + 0.76523173184310 + 0.77411370964495 + 0.78652030530175 + 0.80545445570553 + 0.83999677497644 + 1.00000000000000 + 0.83296014199578 + 0.79084318795675 + 0.76469987823903 + 0.74491813331490 + 0.72829374682804 + 0.71346952385858 + 0.69972249495409 + 0.68665677377861 + 0.67403263252343 + 0.66169717956258 + 0.64954875791577 + 0.63751855810888 + 0.62555956566823 + 0.61361559538498 + 0.60166986852336 + 0.58971948649096 + 0.57777413611474 + 0.56585422658495 + 0.55398789804940 + 0.54219328863044 + 0.53048372636805 + 0.51887767572534 + 0.50738311855387 + 0.49599495347903 + 0.71733520331718 + 0.71733521610511 + 0.71733521822351 + 0.71733522069353 + 0.71733522357144 + 0.71733522692679 + 0.71733523083749 + 0.71733523539663 + 0.71733524071523 + 0.71733524693879 + 0.71733525430155 + 0.71733526316939 + 0.71733527398604 + 0.71733528723129 + 0.71733530346842 + 0.71733532337667 + 0.71733534778966 + 0.71733537772795 + 0.71733541448549 + 0.71733545970203 + 0.71733551534993 + 0.71733558386012 + 0.71733566823674 + 0.71733577219695 + 0.71733590039450 + 0.71733605899065 + 0.71733625680139 + 0.71733650542623 + 0.71733681873970 + 0.71733721373371 + 0.71733771311197 + 0.71733834521912 + 0.71733914576228 + 0.71734016007561 + 0.71734144571813 + 0.71734307573055 + 0.71734514278864 + 0.71734776442365 + 0.71735109386067 + 0.71735533161900 + 0.71736072993477 + 0.71736761224034 + 0.71737639097552 + 0.71738755741589 + 0.71740147251327 + 0.71741821192055 + 0.71743804935893 + 0.71746123166719 + 0.71748742033445 + 0.71751642227362 + 0.71754849686528 + 0.71758406366317 + 0.71762363692125 + 0.71766783488283 + 0.71771746501025 + 0.71777347638823 + 0.71783694575777 + 0.71790918086724 + 0.71799178285552 + 0.71808677494936 + 0.71819709480333 + 0.71832785400863 + 0.71848614120117 + 0.71867971527983 + 0.71891775999505 + 0.71921214800508 + 0.71957801216075 + 0.72003497776595 + 0.72060876137280 + 0.72133338319041 + 0.72225440638158 + 0.72343406833930 + 0.72496116158034 + 0.72697090114565 + 0.72966815822627 + 0.73336192711227 + 0.73855422762318 + 0.74197140671251 + 0.74615598886393 + 0.75137412183292 + 0.75804450306784 + 0.76687928668760 + 0.77923087791790 + 0.79814242737369 + 0.83296014199578 + 1.00000000000000 + 0.82583322304923 + 0.78342266399309 + 0.75692749032324 + 0.73673497745763 + 0.71974179351193 + 0.70455243280638 + 0.69046538573791 + 0.67708483913219 + 0.66417104602077 + 0.65157011174753 + 0.63917962383044 + 0.62692977420441 + 0.61474792775011 + 0.60260594514408 + 0.59049257355344 + 0.57841127502822 + 0.56637777603089 + 0.55441664991698 + 0.54254317957982 + 0.53076839098703 + 0.51910885419463 + 0.50757085405152 + 0.49614772768356 + 0.71024264326340 + 0.71024265530318 + 0.71024265729802 + 0.71024265962312 + 0.71024266233259 + 0.71024266549172 + 0.71024266917402 + 0.71024267346576 + 0.71024267847316 + 0.71024268433256 + 0.71024269126632 + 0.71024269962281 + 0.71024270982187 + 0.71024272232039 + 0.71024273765165 + 0.71024275646396 + 0.71024277954719 + 0.71024280787185 + 0.71024284266873 + 0.71024288550046 + 0.71024293824158 + 0.71024300320886 + 0.71024308326280 + 0.71024318194617 + 0.71024330369195 + 0.71024345437736 + 0.71024364241542 + 0.71024387888126 + 0.71024417701682 + 0.71024455305019 + 0.71024502865798 + 0.71024563091719 + 0.71024639392945 + 0.71024736099830 + 0.71024858709526 + 0.71025014198403 + 0.71025211415821 + 0.71025461584235 + 0.71025779332392 + 0.71026183802459 + 0.71026699064723 + 0.71027355973736 + 0.71028193857053 + 0.71029259519796 + 0.71030587188021 + 0.71032183659347 + 0.71034074564037 + 0.71036282789204 + 0.71038775050124 + 0.71041531803596 + 0.71044576502037 + 0.71047947525123 + 0.71051691798610 + 0.71055865532838 + 0.71060542141080 + 0.71065807443223 + 0.71071758037016 + 0.71078510720383 + 0.71086207873691 + 0.71095028934965 + 0.71105235877262 + 0.71117290160674 + 0.71131831362401 + 0.71149551468399 + 0.71171262521425 + 0.71198009966481 + 0.71231119019896 + 0.71272299302231 + 0.71323778378571 + 0.71388484006577 + 0.71470307653158 + 0.71574518284230 + 0.71708566278630 + 0.71883704080554 + 0.72116708904565 + 0.72432181184159 + 0.72868616385075 + 0.73151290903640 + 0.73492363319599 + 0.73909571172526 + 0.74429250300859 + 0.75092886927389 + 0.75971248312548 + 0.77199443405047 + 0.79084318795675 + 0.82583322304923 + 1.00000000000000 + 0.81842392530135 + 0.77536658924005 + 0.74846440767078 + 0.72795447140260 + 0.71064010950552 + 0.69514373961704 + 0.68076618664517 + 0.66711476047493 + 0.65395059443102 + 0.64111996224216 + 0.62851994183725 + 0.61605501689705 + 0.60368165197657 + 0.59137756012907 + 0.57913815286085 + 0.56697320494069 + 0.55490282496998 + 0.54293877986250 + 0.53108929999157 + 0.51936868202958 + 0.50778119938452 + 0.49631835652816 + 0.70311836290402 + 0.70311837424806 + 0.70311837612714 + 0.70311837831794 + 0.70311838087054 + 0.70311838384647 + 0.70311838731548 + 0.70311839136028 + 0.70311839607768 + 0.70311840159920 + 0.70311840813392 + 0.70311841601318 + 0.70311842563602 + 0.70311843743723 + 0.70311845192151 + 0.70311846970618 + 0.70311849154101 + 0.70311851835051 + 0.70311855130359 + 0.70311859188899 + 0.70311864189003 + 0.70311870351279 + 0.70311877948332 + 0.70311887317460 + 0.70311898881187 + 0.70311913199811 + 0.70311931076058 + 0.70311953567119 + 0.70311981937022 + 0.70312017734487 + 0.70312063029471 + 0.70312120407299 + 0.70312193124316 + 0.70312285315613 + 0.70312402230138 + 0.70312550529104 + 0.70312738661138 + 0.70312977338438 + 0.70313280524152 + 0.70313666487247 + 0.70314158192005 + 0.70314785064707 + 0.70315584597357 + 0.70316601372463 + 0.70317867843875 + 0.70319390116060 + 0.70321192198438 + 0.70323295324712 + 0.70325666865651 + 0.70328287187353 + 0.70331177514949 + 0.70334373001346 + 0.70337916526447 + 0.70341859273894 + 0.70346268101027 + 0.70351220747956 + 0.70356804035491 + 0.70363122484299 + 0.70370302971303 + 0.70378504999894 + 0.70387962780595 + 0.70399093920039 + 0.70412476855135 + 0.70428730314666 + 0.70448574230866 + 0.70472931763032 + 0.70502966932052 + 0.70540173943471 + 0.70586489393622 + 0.70644443444927 + 0.70717376012661 + 0.70809773994698 + 0.70927934006443 + 0.71081304504243 + 0.71283782717705 + 0.71555252825067 + 0.71925848512811 + 0.72162779672847 + 0.72445329189333 + 0.72785848783083 + 0.73201844944087 + 0.73719296775661 + 0.74379140923376 + 0.75251330907912 + 0.76469987823903 + 0.78342266399309 + 0.81842392530135 + 1.00000000000000 + 0.81016511499101 + 0.76653600403957 + 0.73939370307181 + 0.71863696058749 + 0.70106759954993 + 0.68531476710520 + 0.67068968015863 + 0.65680501648369 + 0.64342426400384 + 0.63039425162975 + 0.61758646829263 + 0.60493587437778 + 0.59240522547364 + 0.57997928115206 + 0.56766009616334 + 0.55546208606498 + 0.54339261341742 + 0.53145645907464 + 0.51966515058261 + 0.50802054354536 + 0.49651196276040 + 0.69576973921882 + 0.69576974989856 + 0.69576975166807 + 0.69576975373053 + 0.69576975613411 + 0.69576975893560 + 0.69576976220219 + 0.69576976600941 + 0.69576977045192 + 0.69576977565035 + 0.69576978180376 + 0.69576978922686 + 0.69576979829796 + 0.69576980942934 + 0.69576982310143 + 0.69576983989631 + 0.69576986052917 + 0.69576988587622 + 0.69576991704825 + 0.69576995545785 + 0.69577000280383 + 0.69577006118060 + 0.69577013317915 + 0.69577022200937 + 0.69577033169229 + 0.69577046755927 + 0.69577063725760 + 0.69577085085906 + 0.69577112040616 + 0.69577146065735 + 0.69577189133901 + 0.69577243709627 + 0.69577312896097 + 0.69577400634996 + 0.69577511929241 + 0.69577653126900 + 0.69577832279161 + 0.69578059592398 + 0.69578348368999 + 0.69578716011928 + 0.69579184388122 + 0.69579781508695 + 0.69580543047182 + 0.69581511386866 + 0.69582717244553 + 0.69584166080891 + 0.69585880347420 + 0.69587879707241 + 0.69590132295845 + 0.69592618523127 + 0.69595357562254 + 0.69598381568233 + 0.69601729676656 + 0.69605448441199 + 0.69609598689694 + 0.69614250777481 + 0.69619482663045 + 0.69625387798936 + 0.69632079160053 + 0.69639698443314 + 0.69648454979826 + 0.69658726588942 + 0.69671036224577 + 0.69685936930796 + 0.69704066772555 + 0.69726240752961 + 0.69753481210178 + 0.69787094221715 + 0.69828764094582 + 0.69880679150771 + 0.69945709872387 + 0.70027685482053 + 0.70131944956016 + 0.70266459390324 + 0.70442817855202 + 0.70677249772095 + 0.70993682388381 + 0.71193816830532 + 0.71430234916811 + 0.71711827145600 + 0.72050724516232 + 0.72464086550082 + 0.72977330820170 + 0.73630457332841 + 0.74491813331490 + 0.75692749032324 + 0.77536658924005 + 0.81016511499101 + 1.00000000000000 + 0.80137795279735 + 0.75735525191025 + 0.73000804874827 + 0.70903414045479 + 0.69122647219963 + 0.67523290804861 + 0.66037655189695 + 0.64627525609840 + 0.63269400789989 + 0.61945374022115 + 0.60645773877309 + 0.59364748663947 + 0.58099301348285 + 0.56848593856898 + 0.55613312854047 + 0.54393621629465 + 0.53189556724887 + 0.52001921368656 + 0.50830600159968 + 0.49674257267225 + 0.68809664968667 + 0.68809665972522 + 0.68809666138820 + 0.68809666332659 + 0.68809666558582 + 0.68809666821882 + 0.68809667128886 + 0.68809667486687 + 0.68809667904162 + 0.68809668392836 + 0.68809668971316 + 0.68809669669530 + 0.68809670523081 + 0.68809671571189 + 0.68809672859167 + 0.68809674442269 + 0.68809676388103 + 0.68809678779499 + 0.68809681721901 + 0.68809685349447 + 0.68809689822582 + 0.68809695340543 + 0.68809702148752 + 0.68809710551716 + 0.68809720931165 + 0.68809733793105 + 0.68809749863857 + 0.68809770100675 + 0.68809795647890 + 0.68809827907670 + 0.68809868755083 + 0.68809920532402 + 0.68809986189851 + 0.68810069473294 + 0.68810175138168 + 0.68810309217646 + 0.68810479362118 + 0.68810695268586 + 0.68810969574450 + 0.68811318809867 + 0.68811763738022 + 0.68812330946044 + 0.68813054277662 + 0.68813973909685 + 0.68815118829048 + 0.68816493891786 + 0.68818120030170 + 0.68820015395153 + 0.68822149002779 + 0.68824501437703 + 0.68827089957882 + 0.68829943895921 + 0.68833098874528 + 0.68836597125369 + 0.68840493855167 + 0.68844852579967 + 0.68849743122519 + 0.68855248830658 + 0.68861470057590 + 0.68868532398825 + 0.68876622597870 + 0.68886081867228 + 0.68897382108445 + 0.68911016690410 + 0.68927549984502 + 0.68947700111011 + 0.68972363292924 + 0.69002679197524 + 0.69040110510974 + 0.69086547670237 + 0.69144455939079 + 0.69217103081361 + 0.69309020018362 + 0.69426945396654 + 0.69580579401227 + 0.69783251203982 + 0.70054151135007 + 0.70223936587216 + 0.70422945995132 + 0.70657745486309 + 0.70937019518090 + 0.71272584519390 + 0.71681102383835 + 0.72187170830476 + 0.72829374682804 + 0.73673497745763 + 0.74846440767078 + 0.76653600403957 + 0.80137795279735 + 1.00000000000000 + 0.79239622386697 + 0.74801018026511 + 0.72046830547758 + 0.69926700058382 + 0.68121431041119 + 0.66497978441546 + 0.64989638517230 + 0.63558465291208 + 0.62178295001423 + 0.60834538931179 + 0.59518181698765 + 0.58224108603321 + 0.56950021461606 + 0.55695574325395 + 0.54460163624137 + 0.53243245732086 + 0.52045171881541 + 0.50865443533463 + 0.49702387564181 + 0.68008818613635 + 0.68008819555243 + 0.68008819711203 + 0.68008819893061 + 0.68008820104935 + 0.68008820351956 + 0.68008820639854 + 0.68008820975480 + 0.68008821367108 + 0.68008821825394 + 0.68008822368224 + 0.68008823023435 + 0.68008823824935 + 0.68008824809590 + 0.68008826020196 + 0.68008827508934 + 0.68008829339650 + 0.68008831590595 + 0.68008834361429 + 0.68008837778649 + 0.68008841994415 + 0.68008847196688 + 0.68008853617798 + 0.68008861546053 + 0.68008871342170 + 0.68008883485411 + 0.68008898663695 + 0.68008917783673 + 0.68008941929641 + 0.68008972429752 + 0.68009011061102 + 0.68009060043214 + 0.68009122171429 + 0.68009200995966 + 0.68009301022288 + 0.68009427966712 + 0.68009589076889 + 0.68009793536819 + 0.68010053315016 + 0.68010384064137 + 0.68010805436779 + 0.68011342589227 + 0.68012027528209 + 0.68012898216519 + 0.68013981922216 + 0.68015282934785 + 0.68016820706531 + 0.68018611934251 + 0.68020626623170 + 0.68022845655241 + 0.68025284503791 + 0.68027969844054 + 0.68030934004227 + 0.68034215181058 + 0.68037863340482 + 0.68041935663553 + 0.68046494503748 + 0.68051613983521 + 0.68057382994605 + 0.68063912565368 + 0.68071368915827 + 0.68080059541666 + 0.68090409330217 + 0.68102857400979 + 0.68117901749407 + 0.68136173654283 + 0.68158456983002 + 0.68185744037005 + 0.68219302518570 + 0.68260762726340 + 0.68312239100103 + 0.68376518135993 + 0.68457445138058 + 0.68560722962047 + 0.68694490757746 + 0.68869746009378 + 0.69102000145807 + 0.69246436585856 + 0.69414634803725 + 0.69611547683770 + 0.69843561074450 + 0.70119095226651 + 0.70449565768160 + 0.70851001598133 + 0.71346952385858 + 0.71974179351193 + 0.72795447140260 + 0.73939370307181 + 0.75735525191025 + 0.79239622386697 + 1.00000000000000 + 0.78320111748820 + 0.73853174567095 + 0.71079092033823 + 0.68934809545793 + 0.67104396149969 + 0.65456881162692 + 0.63926164162646 + 0.62471580421364 + 0.61070472258169 + 0.59708907773738 + 0.58378617181678 + 0.57075198095211 + 0.55796856486207 + 0.54541940639961 + 0.53309130937978 + 0.52098185226964 + 0.50908111100443 + 0.49736807076972 + 0.67173425755674 + 0.67173426636686 + 0.67173426782581 + 0.67173426952699 + 0.67173427150961 + 0.67173427382105 + 0.67173427651515 + 0.67173427965531 + 0.67173428331913 + 0.67173428760840 + 0.67173429268767 + 0.67173429882127 + 0.67173430632792 + 0.67173431555346 + 0.67173432690237 + 0.67173434086480 + 0.67173435804145 + 0.67173437916924 + 0.67173440518648 + 0.67173443728694 + 0.67173447690304 + 0.67173452580695 + 0.67173458619071 + 0.67173466076748 + 0.67173475294715 + 0.67173486724549 + 0.67173501015957 + 0.67173519024958 + 0.67173541775318 + 0.67173570521379 + 0.67173606941139 + 0.67173653131371 + 0.67173711732033 + 0.67173786095707 + 0.67173880477966 + 0.67174000276159 + 0.67174152333188 + 0.67174345318459 + 0.67174590528449 + 0.67174902734518 + 0.67175300475509 + 0.67175807472134 + 0.67176453890237 + 0.67177275476978 + 0.67178297795544 + 0.67179524605636 + 0.67180973920166 + 0.67182661038883 + 0.67184557057043 + 0.67186643266465 + 0.67188933479322 + 0.67191451871165 + 0.67194227681144 + 0.67197295342408 + 0.67200699936348 + 0.67204492778080 + 0.67208729367091 + 0.67213475406857 + 0.67218809385169 + 0.67224829156002 + 0.67231682285403 + 0.67239645204132 + 0.67249099499235 + 0.67260434976176 + 0.67274089859528 + 0.67290617593643 + 0.67310701950383 + 0.67335204698930 + 0.67365221892754 + 0.67402156403997 + 0.67447818386696 + 0.67504580642162 + 0.67575704319436 + 0.67666016644711 + 0.67782356236861 + 0.67933825115028 + 0.68133033610266 + 0.68256085115139 + 0.68398589789911 + 0.68564346787328 + 0.68758153206011 + 0.68986175762873 + 0.69256516964361 + 0.69580114891909 + 0.69972249495409 + 0.70455243280638 + 0.71064010950552 + 0.71863696058749 + 0.73000804874827 + 0.74801018026511 + 0.78320111748820 + 1.00000000000000 + 0.77387775280859 + 0.72896133332505 + 0.70099911708864 + 0.67929600538499 + 0.66073292490807 + 0.64401518356108 + 0.62845485128541 + 0.61368296496397 + 0.59947940418837 + 0.58571232467358 + 0.57230625721927 + 0.55922233034848 + 0.54642933111267 + 0.53390345758464 + 0.52163435393921 + 0.50960563231004 + 0.49779076885039 + 0.66304395544433 + 0.66304396366311 + 0.66304396502500 + 0.66304396661187 + 0.66304396846157 + 0.66304397061774 + 0.66304397313142 + 0.66304397606115 + 0.66304397947932 + 0.66304398348075 + 0.66304398821994 + 0.66304399394545 + 0.66304400095510 + 0.66304400957429 + 0.66304402018051 + 0.66304403323462 + 0.66304404930001 + 0.66304406906977 + 0.66304409342345 + 0.66304412348076 + 0.66304416058933 + 0.66304420641428 + 0.66304426301285 + 0.66304433293825 + 0.66304441939055 + 0.66304452662246 + 0.66304466074109 + 0.66304482980144 + 0.66304504344065 + 0.66304531345486 + 0.66304565564563 + 0.66304608974146 + 0.66304664059240 + 0.66304733975313 + 0.66304822726701 + 0.66304935392724 + 0.66305078411252 + 0.66305259937558 + 0.66305490596148 + 0.66305784277989 + 0.66306158409775 + 0.66306635279445 + 0.66307243217392 + 0.66308015764821 + 0.66308976800337 + 0.66310129592580 + 0.66311490758994 + 0.66313074263787 + 0.66314852378189 + 0.66316806904589 + 0.66318950114373 + 0.66321303839252 + 0.66323894431776 + 0.66326752824162 + 0.66329919557149 + 0.66333440531024 + 0.66337364973776 + 0.66341750928558 + 0.66346667466294 + 0.66352200557389 + 0.66358480854501 + 0.66365756229344 + 0.66374368488679 + 0.66384662731258 + 0.66397023506702 + 0.66411934691179 + 0.66429991119546 + 0.66451939227163 + 0.66478724290437 + 0.66511550700251 + 0.66551964985494 + 0.66601984428817 + 0.66664372010612 + 0.66743212933132 + 0.66844257590952 + 0.66975056240945 + 0.67145906558084 + 0.67250815693063 + 0.67371732025244 + 0.67511609238277 + 0.67674113315285 + 0.67863860591779 + 0.68086766102317 + 0.68350571275776 + 0.68665677377861 + 0.69046538573791 + 0.69514373961704 + 0.70106759954993 + 0.70903414045479 + 0.72046830547758 + 0.73853174567095 + 0.77387775280859 + 1.00000000000000 + 0.76444478563401 + 0.71930299053514 + 0.69109307338954 + 0.66911368201921 + 0.65028475035206 + 0.63328927726680 + 0.61748146505154 + 0.60249864193721 + 0.58812814039322 + 0.57424544147693 + 0.56078034825947 + 0.54768044361574 + 0.53490708035974 + 0.52243908016631 + 0.51025145677190 + 0.49831050813373 + 0.65403014815054 + 0.65403015579371 + 0.65403015705957 + 0.65403015853545 + 0.65403016025569 + 0.65403016226066 + 0.65403016459758 + 0.65403016732215 + 0.65403017050067 + 0.65403017422118 + 0.65403017862911 + 0.65403018395575 + 0.65403019047935 + 0.65403019850345 + 0.65403020838273 + 0.65403022054728 + 0.65403023552226 + 0.65403025395720 + 0.65403027667407 + 0.65403030472180 + 0.65403033936179 + 0.65403038214980 + 0.65403043501550 + 0.65403050034771 + 0.65403058114384 + 0.65403068138798 + 0.65403080680578 + 0.65403096494968 + 0.65403116485294 + 0.65403141757810 + 0.65403173794221 + 0.65403214444645 + 0.65403266039687 + 0.65403331538263 + 0.65403414695437 + 0.65403520273545 + 0.65403654307878 + 0.65403824442057 + 0.65404040632715 + 0.65404315896384 + 0.65404666554543 + 0.65405113473721 + 0.65405683163820 + 0.65406406981490 + 0.65407307151457 + 0.65408386486703 + 0.65409660259880 + 0.65411141162846 + 0.65412802713686 + 0.65414627312635 + 0.65416625808607 + 0.65418817841859 + 0.65421227076338 + 0.65423881198567 + 0.65426816542655 + 0.65430074024725 + 0.65433697153878 + 0.65437737025818 + 0.65442254215303 + 0.65447324007062 + 0.65453061759675 + 0.65459689159512 + 0.65467511570743 + 0.65476833684735 + 0.65487992006396 + 0.65501408426972 + 0.65517599007187 + 0.65537208581886 + 0.65561050350090 + 0.65590155897664 + 0.65625843786861 + 0.65669826126047 + 0.65724441114993 + 0.65793144419077 + 0.65880773288649 + 0.65993601064615 + 0.66140066339672 + 0.66229527907596 + 0.66332211555947 + 0.66450438789737 + 0.66587050182158 + 0.66745562626001 + 0.66930391773941 + 0.67147175839651 + 0.67403263252343 + 0.67708483913219 + 0.68076618664517 + 0.68531476710520 + 0.69122647219963 + 0.69926700058382 + 0.71079092033823 + 0.72896133332505 + 0.76444478563401 + 1.00000000000000 + 0.75492031282836 + 0.70955944698628 + 0.68107414010615 + 0.65880306865287 + 0.63966479310177 + 0.62239413021524 + 0.60635155041368 + 0.59118177667787 + 0.57667954739414 + 0.56272574128704 + 0.54923626672383 + 0.53615109406575 + 0.52343392813044 + 0.51104812067338 + 0.49895046893843 + 0.64470848704948 + 0.64470849413043 + 0.64470849530347 + 0.64470849667104 + 0.64470849826431 + 0.64470850012214 + 0.64470850228730 + 0.64470850481175 + 0.64470850775667 + 0.64470851120418 + 0.64470851528848 + 0.64470852022499 + 0.64470852627482 + 0.64470853371871 + 0.64470854288638 + 0.64470855417871 + 0.64470856808616 + 0.64470858521259 + 0.64470860632375 + 0.64470863239867 + 0.64470866461123 + 0.64470870441551 + 0.64470875360898 + 0.64470881442143 + 0.64470888965015 + 0.64470898301121 + 0.64470909985189 + 0.64470924723010 + 0.64470943357962 + 0.64470966923682 + 0.64470996804394 + 0.64471034728770 + 0.64471082874662 + 0.64471144006082 + 0.64471221631575 + 0.64471320199478 + 0.64471445347394 + 0.64471604212727 + 0.64471806092487 + 0.64472063137999 + 0.64472390580425 + 0.64472807883394 + 0.64473339761820 + 0.64474015422519 + 0.64474855473033 + 0.64475862308198 + 0.64477049909132 + 0.64478429761424 + 0.64479976684829 + 0.64481673751131 + 0.64483530499983 + 0.64485564531314 + 0.64487797013262 + 0.64490252633992 + 0.64492963842444 + 0.64495966982776 + 0.64499300366588 + 0.64503008809567 + 0.64507145246777 + 0.64511775386062 + 0.64517000794397 + 0.64523019215167 + 0.64530102724858 + 0.64538519606805 + 0.64548563499370 + 0.64560601243634 + 0.64575079349821 + 0.64592553426281 + 0.64613721307670 + 0.64639464519512 + 0.64670904912769 + 0.64709493036681 + 0.64757205116317 + 0.64816962448960 + 0.64892834588358 + 0.64990040055230 + 0.65115513059894 + 0.65191789961369 + 0.65279019758135 + 0.65379043406075 + 0.65494086863531 + 0.65626867787991 + 0.65780742168293 + 0.65959910749326 + 0.66169717956258 + 0.66417104602077 + 0.66711476047493 + 0.67068968015863 + 0.67523290804861 + 0.68121431041119 + 0.68934809545793 + 0.70099911708864 + 0.71930299053514 + 0.75492031282836 + 1.00000000000000 + 0.74532143427564 + 0.69973270286933 + 0.67094205905118 + 0.64832247902466 + 0.62887318355244 + 0.61133679832962 + 0.59508124775734 + 0.57975874904383 + 0.56516957193475 + 0.55118025313255 + 0.53769888024648 + 0.52466743315799 + 0.51203307488004 + 0.49973978960978 + 0.63509687732998 + 0.63509688386494 + 0.63509688494765 + 0.63509688620950 + 0.63509688767980 + 0.63509688939440 + 0.63509689139183 + 0.63509689372147 + 0.63509689643877 + 0.63509689962049 + 0.63509690339026 + 0.63509690794802 + 0.63509691353479 + 0.63509692041286 + 0.63509692888671 + 0.63509693932814 + 0.63509695219270 + 0.63509696803919 + 0.63509698758130 + 0.63509701172659 + 0.63509704156469 + 0.63509707844562 + 0.63509712404166 + 0.63509718042317 + 0.63509725019100 + 0.63509733680040 + 0.63509744522675 + 0.63509758203417 + 0.63509775507275 + 0.63509797396073 + 0.63509825158065 + 0.63509860402800 + 0.63509905156599 + 0.63509961993056 + 0.63510034177200 + 0.63510125849177 + 0.63510242254708 + 0.63510390034070 + 0.63510577836018 + 0.63510816962384 + 0.63511121573503 + 0.63511509757430 + 0.63512004470129 + 0.63512632814621 + 0.63513413826658 + 0.63514349519274 + 0.63515452639201 + 0.63516733534176 + 0.63518168364210 + 0.63519740931674 + 0.63521459576759 + 0.63523340006638 + 0.63525401081229 + 0.63527664728457 + 0.63530159821544 + 0.63532918524156 + 0.63535974440945 + 0.63539366730243 + 0.63543141479972 + 0.63547355841200 + 0.63552098979223 + 0.63557546803334 + 0.63563941071393 + 0.63571517358307 + 0.63580531172226 + 0.63591300609550 + 0.63604210956365 + 0.63619739685319 + 0.63638484134378 + 0.63661195832422 + 0.63688827231371 + 0.63722605029405 + 0.63764197205329 + 0.63816071322236 + 0.63881650514848 + 0.63965279122866 + 0.64072667173637 + 0.64137670854049 + 0.64211766526341 + 0.64296424753677 + 0.64393406044264 + 0.64504834982742 + 0.64633299606272 + 0.64781987387588 + 0.64954875791577 + 0.65157011174753 + 0.65395059443102 + 0.65680501648369 + 0.66037655189695 + 0.66497978441546 + 0.67104396149969 + 0.67929600538499 + 0.69109307338954 + 0.70955944698628 + 0.74532143427564 + 1.00000000000000 + 0.73566372795992 + 0.68982071700331 + 0.66064413969438 + 0.63766849176450 + 0.61791326525658 + 0.60012985219443 + 0.58369397081111 + 0.56826355984903 + 0.55362398345817 + 0.53963372781311 + 0.52620245776835 + 0.51325422733634 + 0.50071534633034 + 0.62521548210643 + 0.62521548811102 + 0.62521548910546 + 0.62521549026499 + 0.62521549161667 + 0.62521549319165 + 0.62521549502765 + 0.62521549716848 + 0.62521549966564 + 0.62521550258913 + 0.62521550605351 + 0.62521551024393 + 0.62521551538208 + 0.62521552170976 + 0.62521552950945 + 0.62521553912407 + 0.62521555097369 + 0.62521556557630 + 0.62521558358937 + 0.62521560585419 + 0.62521563337892 + 0.62521566741297 + 0.62521570950083 + 0.62521576156107 + 0.62521582600098 + 0.62521590602072 + 0.62521600623030 + 0.62521613271502 + 0.62521629274958 + 0.62521649525094 + 0.62521675216325 + 0.62521707840923 + 0.62521749278367 + 0.62521801914552 + 0.62521868776989 + 0.62521953704293 + 0.62522061559474 + 0.62522198497092 + 0.62522372532493 + 0.62522594138434 + 0.62522876430761 + 0.62523236156985 + 0.62523694559468 + 0.62524276695633 + 0.62525000083083 + 0.62525866387637 + 0.62526887183208 + 0.62528071748477 + 0.62529397606956 + 0.62530849336643 + 0.62532434183848 + 0.62534166106385 + 0.62536061838376 + 0.62538140775258 + 0.62540428511550 + 0.62542953401846 + 0.62545744802303 + 0.62548836791414 + 0.62552269340602 + 0.62556091978225 + 0.62560382748384 + 0.62565297701809 + 0.62571051058157 + 0.62577849087168 + 0.62585913475041 + 0.62595519272452 + 0.62606998012792 + 0.62620758915818 + 0.62637311976964 + 0.62657296337832 + 0.62681518816141 + 0.62711014753087 + 0.62747189755268 + 0.62792125948051 + 0.62848701334573 + 0.62920533587320 + 0.63012331478990 + 0.63067681816585 + 0.63130589474351 + 0.63202236018964 + 0.63284024241650 + 0.63377630764931 + 0.63485075070082 + 0.63608811680298 + 0.63751855810888 + 0.63917962383044 + 0.64111996224216 + 0.64342426400384 + 0.64627525609840 + 0.64989638517230 + 0.65456881162692 + 0.66073292490807 + 0.66911368201921 + 0.68107414010615 + 0.69973270286933 + 0.73566372795992 + 1.00000000000000 + 0.72595413211481 + 0.67975101817430 + 0.65017232050204 + 0.62683989440202 + 0.60679307087079 + 0.58879276800594 + 0.57222095414619 + 0.55672001377909 + 0.54206704967567 + 0.52812158709516 + 0.51477355674579 + 0.50192421609276 + 0.61508585458111 + 0.61508586007490 + 0.61508586098470 + 0.61508586204533 + 0.61508586328183 + 0.61508586472262 + 0.61508586640272 + 0.61508586836061 + 0.61508587064539 + 0.61508587332042 + 0.61508587648979 + 0.61508588032488 + 0.61508588502949 + 0.61508589082602 + 0.61508589797350 + 0.61508590678763 + 0.61508591765633 + 0.61508593105374 + 0.61508594758788 + 0.61508596803108 + 0.61508599331265 + 0.61508602458471 + 0.61508606327191 + 0.61508611114051 + 0.61508617041122 + 0.61508624403563 + 0.61508633626964 + 0.61508645272920 + 0.61508660013362 + 0.61508678671500 + 0.61508702350616 + 0.61508732429146 + 0.61508770642864 + 0.61508819196025 + 0.61508880885321 + 0.61508959256046 + 0.61509058799518 + 0.61509185198995 + 0.61509345854935 + 0.61509550436124 + 0.61509811045864 + 0.61510143132808 + 0.61510566281716 + 0.61511103573044 + 0.61511771066696 + 0.61512570114826 + 0.61513511183043 + 0.61514602551613 + 0.61515823114289 + 0.61517158256326 + 0.61518614231328 + 0.61520203387180 + 0.61521940507118 + 0.61523842673241 + 0.61525932483475 + 0.61528234833983 + 0.61530775259253 + 0.61533583291890 + 0.61536693455420 + 0.61540148508075 + 0.61544016544016 + 0.61548435600580 + 0.61553594948702 + 0.61559674668601 + 0.61566866518714 + 0.61575407624662 + 0.61585582429590 + 0.61597740655168 + 0.61612316524423 + 0.61629852166544 + 0.61651029344075 + 0.61676719935431 + 0.61708106236809 + 0.61746942713674 + 0.61795646873097 + 0.61857230494887 + 0.61935579406310 + 0.61982651518150 + 0.62036008822105 + 0.62096604859840 + 0.62165563810305 + 0.62244218525280 + 0.62334159526070 + 0.62437299089127 + 0.62555956566823 + 0.62692977420441 + 0.62851994183725 + 0.63039425162975 + 0.63269400789989 + 0.63558465291208 + 0.63926164162646 + 0.64401518356108 + 0.65028475035206 + 0.65880306865287 + 0.67094205905118 + 0.68982071700331 + 0.72595413211481 + 1.00000000000000 + 0.71608383556752 + 0.66951141484420 + 0.63952167041737 + 0.61584040931950 + 0.59552793529284 + 0.57735369734696 + 0.56068363540690 + 0.54515180932183 + 0.53053571460708 + 0.51667274738668 + 0.50342745656389 + 0.60470858510796 + 0.60470859010979 + 0.60470859093821 + 0.60470859190378 + 0.60470859302983 + 0.60470859434157 + 0.60470859587092 + 0.60470859765390 + 0.60470859973385 + 0.60470860216903 + 0.60470860505563 + 0.60470860854927 + 0.60470861283657 + 0.60470861812107 + 0.60470862464066 + 0.60470863268353 + 0.60470864260463 + 0.60470865484032 + 0.60470866994593 + 0.60470868863131 + 0.60470871174790 + 0.60470874035389 + 0.60470877575428 + 0.60470881957255 + 0.60470887384700 + 0.60470894128819 + 0.60470902580837 + 0.60470913257097 + 0.60470926775581 + 0.60470943893080 + 0.60470965624746 + 0.60470993238513 + 0.60471028331614 + 0.60471072931620 + 0.60471129612134 + 0.60471201634753 + 0.60471293131340 + 0.60471409329103 + 0.60471557034747 + 0.60471745139903 + 0.60471984770733 + 0.60472290123136 + 0.60472679184311 + 0.60473173132290 + 0.60473786632382 + 0.60474520755642 + 0.60475384922824 + 0.60476386485002 + 0.60477505702472 + 0.60478728788598 + 0.60480061097982 + 0.60481513500554 + 0.60483098992862 + 0.60484832548109 + 0.60486734029524 + 0.60488825198330 + 0.60491128156503 + 0.60493668372945 + 0.60496475524820 + 0.60499586361332 + 0.60503060079947 + 0.60507018385134 + 0.60511627959389 + 0.60517045485074 + 0.60523436244791 + 0.60531003954509 + 0.60539991803849 + 0.60550697636750 + 0.60563489914046 + 0.60578826967519 + 0.60597283066362 + 0.60619590253137 + 0.60646740373413 + 0.60680208587082 + 0.60722021998569 + 0.60774684767808 + 0.60841401972034 + 0.60881352290930 + 0.60926526491843 + 0.60977696037870 + 0.61035765088086 + 0.61101798428137 + 0.61177056884407 + 0.61263042823771 + 0.61361559538498 + 0.61474792775011 + 0.61605501689705 + 0.61758646829263 + 0.61945374022115 + 0.62178295001423 + 0.62471580421364 + 0.62845485128541 + 0.63328927726680 + 0.63966479310177 + 0.64832247902466 + 0.66064413969438 + 0.67975101817430 + 0.71608383556752 + 1.00000000000000 + 0.70613914738327 + 0.65914351542758 + 0.62872432627375 + 0.60470410218517 + 0.58415979469598 + 0.56584439730123 + 0.54911536917373 + 0.53360612698163 + 0.51906862334291 + 0.50531123561910 + 0.59410841884335 + 0.59410842337458 + 0.59410842412534 + 0.59410842500043 + 0.59410842601994 + 0.59410842720865 + 0.59410842859402 + 0.59410843020934 + 0.59410843209343 + 0.59410843429978 + 0.59410843691549 + 0.59410844008196 + 0.59410844397028 + 0.59410844876457 + 0.59410845468241 + 0.59410846198610 + 0.59410847099991 + 0.59410848212170 + 0.59410849585836 + 0.59410851285664 + 0.59410853389664 + 0.59410855994209 + 0.59410859218740 + 0.59410863211692 + 0.59410868159213 + 0.59410874309474 + 0.59410882020227 + 0.59410891764741 + 0.59410904108432 + 0.59410919744870 + 0.59410939603749 + 0.59410964847336 + 0.59410996938841 + 0.59411037736943 + 0.59411089599792 + 0.59411155516883 + 0.59411239274268 + 0.59411345661766 + 0.59411480915607 + 0.59411653182114 + 0.59411872650418 + 0.59412152316025 + 0.59412508637275 + 0.59412960973275 + 0.59413522664945 + 0.59414194532300 + 0.59414985018781 + 0.59415900614692 + 0.59416922929174 + 0.59418039012336 + 0.59419253409794 + 0.59420575640999 + 0.59422017074201 + 0.59423590767574 + 0.59425314101457 + 0.59427206005959 + 0.59429285511708 + 0.59431574469177 + 0.59434098258230 + 0.59436888312494 + 0.59439995895793 + 0.59443527949953 + 0.59447630768295 + 0.59452440186394 + 0.59458098124306 + 0.59464778934684 + 0.59472689742382 + 0.59482083245294 + 0.59493270923016 + 0.59506638822552 + 0.59522668909172 + 0.59541973668981 + 0.59565382530078 + 0.59594132433752 + 0.59629919069626 + 0.59674820271628 + 0.59731475776661 + 0.59765294617228 + 0.59803448592520 + 0.59846562480670 + 0.59895364856275 + 0.59950708861097 + 0.60013598183997 + 0.60085219938147 + 0.60166986852336 + 0.60260594514408 + 0.60368165197657 + 0.60493587437778 + 0.60645773877309 + 0.60834538931179 + 0.61070472258169 + 0.61368296496397 + 0.61748146505154 + 0.62239413021524 + 0.62887318355244 + 0.63766849176450 + 0.65017232050204 + 0.66951141484420 + 0.70613914738327 + 1.00000000000000 + 0.69612078291725 + 0.64864651129098 + 0.61778752739976 + 0.59345118197935 + 0.57270211354430 + 0.55428532718371 + 0.53755622912816 + 0.52211784040191 + 0.50768793230431 + 0.58331549646903 + 0.58331550055321 + 0.58331550122975 + 0.58331550201858 + 0.58331550293737 + 0.58331550400906 + 0.58331550525792 + 0.58331550671364 + 0.58331550841184 + 0.58331551040078 + 0.58331551275955 + 0.58331551561534 + 0.58331551912367 + 0.58331552345175 + 0.58331552879737 + 0.58331553539809 + 0.58331554354869 + 0.58331555360942 + 0.58331556604199 + 0.58331558143413 + 0.58331560049388 + 0.58331562410021 + 0.58331565333724 + 0.58331568955764 + 0.58331573445622 + 0.58331579029073 + 0.58331586032794 + 0.58331594887905 + 0.58331606110391 + 0.58331620332824 + 0.58331638403686 + 0.58331661383904 + 0.58331690609278 + 0.58331727776345 + 0.58331775038425 + 0.58331835124746 + 0.58331911491984 + 0.58332008512527 + 0.58332131879342 + 0.58332289028132 + 0.58332489256538 + 0.58332744418043 + 0.58333069518171 + 0.58333482190204 + 0.58333994525027 + 0.58334607121623 + 0.58335327513660 + 0.58336161401143 + 0.58337091710867 + 0.58338106327257 + 0.58339209071752 + 0.58340408236781 + 0.58341713715371 + 0.58343136836410 + 0.58344692735714 + 0.58346397799634 + 0.58348268323794 + 0.58350322950085 + 0.58352583264350 + 0.58355076014287 + 0.58357845414416 + 0.58360985112691 + 0.58364623066323 + 0.58368876599172 + 0.58373867078523 + 0.58379743122673 + 0.58386680410515 + 0.58394892442708 + 0.58404641428987 + 0.58416251172267 + 0.58430124487931 + 0.58446771747266 + 0.58466883938262 + 0.58491494827926 + 0.58522018573018 + 0.58560174338363 + 0.58608130917854 + 0.58636670992872 + 0.58668799915984 + 0.58705023406746 + 0.58745928658687 + 0.58792199933861 + 0.58844637843480 + 0.58904183431517 + 0.58971948649096 + 0.59049257355344 + 0.59137756012907 + 0.59240522547364 + 0.59364748663947 + 0.59518181698765 + 0.59708907773738 + 0.59947940418837 + 0.60249864193721 + 0.60635155041368 + 0.61133679832962 + 0.61791326525658 + 0.62683989440202 + 0.63952167041737 + 0.65914351542758 + 0.69612078291725 + 1.00000000000000 + 0.68602780968259 + 0.63802152559385 + 0.60672392718878 + 0.58208617418830 + 0.56116994062211 + 0.54271648396711 + 0.52604373731034 + 0.51071298084535 + 0.57236583026736 + 0.57236583393041 + 0.57236583453722 + 0.57236583524446 + 0.57236583606872 + 0.57236583702959 + 0.57236583814947 + 0.57236583945524 + 0.57236584097856 + 0.57236584276234 + 0.57236584487796 + 0.57236584744079 + 0.57236585059058 + 0.57236585447946 + 0.57236585928460 + 0.57236586522159 + 0.57236587255611 + 0.57236588161474 + 0.57236589281460 + 0.57236590668825 + 0.57236592387684 + 0.57236594517460 + 0.57236597156661 + 0.57236600427731 + 0.57236604484419 + 0.57236609531564 + 0.57236615865690 + 0.57236623878641 + 0.57236634039161 + 0.57236646922149 + 0.57236663299147 + 0.57236684134702 + 0.57236710643973 + 0.57236744370253 + 0.57236787272235 + 0.57236841833262 + 0.57236911197901 + 0.57236999343680 + 0.57237111449796 + 0.57237254280198 + 0.57237436290121 + 0.57237668255513 + 0.57237963811522 + 0.57238338966514 + 0.57238804640469 + 0.57239361240067 + 0.57240015459173 + 0.57240772276547 + 0.57241615893485 + 0.57242535016279 + 0.57243532822899 + 0.57244616499129 + 0.57245794608897 + 0.57247076929779 + 0.57248476580745 + 0.57250007676024 + 0.57251684089109 + 0.57253521632909 + 0.57255538559244 + 0.57257757505494 + 0.57260216450088 + 0.57262997125404 + 0.57266211075556 + 0.57269959255911 + 0.57274345024749 + 0.57279494530738 + 0.57285556129786 + 0.57292709400193 + 0.57301174075743 + 0.57311220502717 + 0.57323183783410 + 0.57337487236732 + 0.57354704021973 + 0.57375694799239 + 0.57401634665683 + 0.57433940870949 + 0.57474389208616 + 0.57498390084852 + 0.57525352310192 + 0.57555684417134 + 0.57589858962614 + 0.57628424310435 + 0.57672019052877 + 0.57721389831111 + 0.57777413611474 + 0.57841127502822 + 0.57913815286085 + 0.57997928115206 + 0.58099301348285 + 0.58224108603321 + 0.58378617181678 + 0.58571232467358 + 0.58812814039322 + 0.59118177667787 + 0.59508124775734 + 0.60012985219443 + 0.60679307087079 + 0.61584040931950 + 0.62872432627375 + 0.64864651129098 + 0.68602780968259 + 1.00000000000000 + 0.67585838089946 + 0.62727272267385 + 0.59552470200955 + 0.57061487320860 + 0.54960139753442 + 0.53117759393863 + 0.51460823401948 + 0.56130083459441 + 0.56130083786402 + 0.56130083840515 + 0.56130083903656 + 0.56130083977236 + 0.56130084062967 + 0.56130084162935 + 0.56130084279479 + 0.56130084415430 + 0.56130084574647 + 0.56130084763510 + 0.56130084992406 + 0.56130085273890 + 0.56130085621619 + 0.56130086051548 + 0.56130086583052 + 0.56130087240145 + 0.56130088052145 + 0.56130089056657 + 0.56130090301732 + 0.56130091845073 + 0.56130093758489 + 0.56130096130800 + 0.56130099072621 + 0.56130102722856 + 0.56130107266780 + 0.56130112972456 + 0.56130120194631 + 0.56130129357908 + 0.56130140982786 + 0.56130155768668 + 0.56130174589493 + 0.56130198546870 + 0.56130229040097 + 0.56130267845465 + 0.56130317214730 + 0.56130379999835 + 0.56130459808083 + 0.56130561336093 + 0.56130690718581 + 0.56130855621403 + 0.56131065811684 + 0.56131333643138 + 0.56131673606136 + 0.56132095533937 + 0.56132599666956 + 0.56133191930554 + 0.56133876650500 + 0.56134639250529 + 0.56135469235522 + 0.56136369218085 + 0.56137345392544 + 0.56138405135633 + 0.56139556842701 + 0.56140811834553 + 0.56142182209965 + 0.56143679712621 + 0.56145317676855 + 0.56147111445266 + 0.56149080071370 + 0.56151256048589 + 0.56153710491087 + 0.56156540337444 + 0.56159832148902 + 0.56163673586956 + 0.56168171281114 + 0.56173449961593 + 0.56179659985524 + 0.56186984625309 + 0.56195648504337 + 0.56205929012008 + 0.56218175507079 + 0.56232861161178 + 0.56250699525662 + 0.56272663118475 + 0.56299915349472 + 0.56333904093964 + 0.56354012767633 + 0.56376555480332 + 0.56401861167281 + 0.56430309019435 + 0.56462337413415 + 0.56498454746925 + 0.56539252702247 + 0.56585422658495 + 0.56637777603089 + 0.56697320494069 + 0.56766009616334 + 0.56848593856898 + 0.56950021461606 + 0.57075198095211 + 0.57230625721927 + 0.57424544147693 + 0.57667954739414 + 0.57975874904383 + 0.58369397081111 + 0.58879276800594 + 0.59552793529284 + 0.60470410218517 + 0.61778752739976 + 0.63802152559385 + 0.67585838089946 + 1.00000000000000 + 0.66561054745255 + 0.61637126355691 + 0.58418026195346 + 0.55907021288061 + 0.53803709593675 + 0.51970347358345 + 0.55016559316895 + 0.55016559607376 + 0.55016559655482 + 0.55016559711550 + 0.55016559776972 + 0.55016559853134 + 0.55016559941949 + 0.55016560045460 + 0.55016560166287 + 0.55016560307703 + 0.55016560475558 + 0.55016560679057 + 0.55016560929520 + 0.55016561239164 + 0.55016561622222 + 0.55016562096149 + 0.55016562682351 + 0.55016563407298 + 0.55016564304611 + 0.55016565417493 + 0.55016566797956 + 0.55016568510448 + 0.55016570634923 + 0.55016573270858 + 0.55016576543398 + 0.55016580619392 + 0.55016585740753 + 0.55016592227651 + 0.55016600463338 + 0.55016610917676 + 0.55016624222743 + 0.55016641168503 + 0.55016662750572 + 0.55016690234098 + 0.55016725225432 + 0.55016769761205 + 0.55016826420873 + 0.55016898467227 + 0.55016990148660 + 0.55017107014826 + 0.55017255998450 + 0.55017445930856 + 0.55017687977099 + 0.55017995222811 + 0.55018376500207 + 0.55018831909559 + 0.55019366678079 + 0.55019984547771 + 0.55020672101379 + 0.55021419613338 + 0.55022229203714 + 0.55023106187223 + 0.55024056889684 + 0.55025088486646 + 0.55026210708110 + 0.55027433880313 + 0.55028767890430 + 0.55030223920506 + 0.55031814794122 + 0.55033556464581 + 0.55035476635567 + 0.55037637027405 + 0.55040121673245 + 0.55043004564125 + 0.55046359774668 + 0.55050277091190 + 0.55054860948403 + 0.55060236689772 + 0.55066556481842 + 0.55074006069426 + 0.55082813927712 + 0.55093266912340 + 0.55105753764729 + 0.55120863593858 + 0.55139397954365 + 0.55162307565409 + 0.55190767376475 + 0.55207554631195 + 0.55226334114706 + 0.55247369545064 + 0.55270963969522 + 0.55297466532287 + 0.55327280624541 + 0.55360873778555 + 0.55398789804940 + 0.55441664991698 + 0.55490282496998 + 0.55546208606498 + 0.55613312854047 + 0.55695574325395 + 0.55796856486207 + 0.55922233034848 + 0.56078034825947 + 0.56272574128704 + 0.56516957193475 + 0.56826355984903 + 0.57222095414619 + 0.57735369734696 + 0.58415979469598 + 0.59345118197935 + 0.60672392718878 + 0.62727272267385 + 0.66561054745255 + 1.00000000000000 + 0.65521995950787 + 0.60528214975594 + 0.57271263887652 + 0.54749065082079 + 0.52651579202342 + 0.53899293004464 + 0.53899293261521 + 0.53899293304103 + 0.53899293353743 + 0.53899293411577 + 0.53899293478979 + 0.53899293557598 + 0.53899293649248 + 0.53899293756099 + 0.53899293881310 + 0.53899294029887 + 0.53899294210140 + 0.53899294432137 + 0.53899294706780 + 0.53899295046819 + 0.53899295467848 + 0.53899295988990 + 0.53899296633892 + 0.53899297432637 + 0.53899298424092 + 0.53899299654750 + 0.53899301182337 + 0.53899303078694 + 0.53899305433013 + 0.53899308357710 + 0.53899312002839 + 0.53899316585819 + 0.53899322394972 + 0.53899329775344 + 0.53899339150522 + 0.53899351089927 + 0.53899366305691 + 0.53899385695873 + 0.53899410401655 + 0.53899441872695 + 0.53899481946705 + 0.53899532951937 + 0.53899597833022 + 0.53899680425428 + 0.53899785738953 + 0.53899920030939 + 0.53900091271154 + 0.53900309531556 + 0.53900586606782 + 0.53900930415259 + 0.53901340939892 + 0.53901822781390 + 0.53902379162128 + 0.53902997757183 + 0.53903669575081 + 0.53904396311962 + 0.53905182509695 + 0.53906033571597 + 0.53906955606242 + 0.53907956949273 + 0.53909046381378 + 0.53910232186200 + 0.53911523692834 + 0.53912931563549 + 0.53914469092893 + 0.53916159833481 + 0.53918057254316 + 0.53920234066332 + 0.53922753364289 + 0.53925677548374 + 0.53929081977040 + 0.53933053775941 + 0.53937697030517 + 0.53943137555551 + 0.53949528264325 + 0.53957056454625 + 0.53965956502540 + 0.53976546298392 + 0.53989310287540 + 0.54004906523102 + 0.54024108390865 + 0.54047864659022 + 0.54061834183798 + 0.54077427458012 + 0.54094854871489 + 0.54114357450744 + 0.54136211973621 + 0.54160737087779 + 0.54188300682188 + 0.54219328863044 + 0.54254317957982 + 0.54293877986250 + 0.54339261341742 + 0.54393621629465 + 0.54460163624137 + 0.54541940639961 + 0.54642933111267 + 0.54768044361574 + 0.54923626672383 + 0.55118025313255 + 0.55362398345817 + 0.55672001377909 + 0.56068363540690 + 0.56584439730123 + 0.57270211354430 + 0.58208617418830 + 0.59552470200955 + 0.61637126355691 + 0.65521995950787 + 1.00000000000000 + 0.64465845691180 + 0.59403584058953 + 0.56117022284911 + 0.53592960570624 + 0.52780886868658 + 0.52780887095442 + 0.52780887132982 + 0.52780887176768 + 0.52780887227809 + 0.52780887287258 + 0.52780887356572 + 0.52780887437388 + 0.52780887531684 + 0.52780887642124 + 0.52780887773230 + 0.52780887932406 + 0.52780888128525 + 0.52780888371381 + 0.52780888672292 + 0.52780889045169 + 0.52780889507113 + 0.52780890079172 + 0.52780890788309 + 0.52780891669097 + 0.52780892763145 + 0.52780894122236 + 0.52780895810573 + 0.52780897907974 + 0.52780900515278 + 0.52780903767022 + 0.52780907858395 + 0.52780913048439 + 0.52780919647423 + 0.52780928035989 + 0.52780938726359 + 0.52780952359765 + 0.52780969744533 + 0.52780991908541 + 0.52781020157391 + 0.52781056146982 + 0.52781101975059 + 0.52781160295703 + 0.52781234565538 + 0.52781329301055 + 0.52781450141953 + 0.52781604270283 + 0.52781800759875 + 0.52782050228436 + 0.52782359765634 + 0.52782729259756 + 0.52783162751599 + 0.52783663008153 + 0.52784218724408 + 0.52784821604619 + 0.52785472984690 + 0.52786176733945 + 0.52786937453708 + 0.52787760328418 + 0.52788652482119 + 0.52789621360738 + 0.52790673876535 + 0.52791817779265 + 0.52793061895285 + 0.52794417260085 + 0.52795903859871 + 0.52797567970487 + 0.52799472445519 + 0.52801671009219 + 0.52804216114734 + 0.52807170865530 + 0.52810607750376 + 0.52814612941232 + 0.52819290118223 + 0.52824764705078 + 0.52831189626453 + 0.52838755563106 + 0.52847721426198 + 0.52858484300738 + 0.52871582666548 + 0.52887643108104 + 0.52907428214304 + 0.52919025077105 + 0.52931940463517 + 0.52946341378900 + 0.52962418562289 + 0.52980390332998 + 0.53000507162867 + 0.53023057150287 + 0.53048372636805 + 0.53076839098703 + 0.53108929999157 + 0.53145645907464 + 0.53189556724887 + 0.53243245732086 + 0.53309130937978 + 0.53390345758464 + 0.53490708035974 + 0.53615109406575 + 0.53769888024648 + 0.53963372781311 + 0.54206704967567 + 0.54515180932183 + 0.54911536917373 + 0.55428532718371 + 0.56116994062211 + 0.57061487320860 + 0.58418026195346 + 0.60528214975594 + 0.64465845691180 + 1.00000000000000 + 0.63396799202894 + 0.58267962593386 + 0.54961289834916 + 0.51664296694839 + 0.51664296894330 + 0.51664296927370 + 0.51664296965872 + 0.51664297010763 + 0.51664297063112 + 0.51664297124126 + 0.51664297195213 + 0.51664297278167 + 0.51664297375368 + 0.51664297490759 + 0.51664297630933 + 0.51664297803801 + 0.51664298018041 + 0.51664298283759 + 0.51664298613387 + 0.51664299021931 + 0.51664299528332 + 0.51664300156649 + 0.51664300937615 + 0.51664301908452 + 0.51664303115356 + 0.51664304615812 + 0.51664306481197 + 0.51664308801617 + 0.51664311697571 + 0.51664315344232 + 0.51664319973919 + 0.51664325865195 + 0.51664333360016 + 0.51664342918715 + 0.51664355117581 + 0.51664370683717 + 0.51664390541774 + 0.51664415866675 + 0.51664448149074 + 0.51664489277536 + 0.51664541641719 + 0.51664608354749 + 0.51664693484609 + 0.51664802110982 + 0.51664940701439 + 0.51665117425523 + 0.51665341835459 + 0.51665620275914 + 0.51665952560039 + 0.51666342234172 + 0.51666791668087 + 0.51667290504786 + 0.51667831101086 + 0.51668414492029 + 0.51669043967102 + 0.51669723437948 + 0.51670457296717 + 0.51671251625233 + 0.51672112728456 + 0.51673046358303 + 0.51674058934134 + 0.51675157740056 + 0.51676351913412 + 0.51677658405482 + 0.51679117273653 + 0.51680782861487 + 0.51682700908504 + 0.51684915475099 + 0.51687479356600 + 0.51690452789617 + 0.51693907005248 + 0.51697927284226 + 0.51702616273472 + 0.51708098508449 + 0.51714528673859 + 0.51722117092186 + 0.51731188644989 + 0.51742183135579 + 0.51755606805631 + 0.51772070468179 + 0.51781688121086 + 0.51792373853671 + 0.51804259682200 + 0.51817495908394 + 0.51832253996466 + 0.51848729972014 + 0.51867148466188 + 0.51887767572534 + 0.51910885419463 + 0.51936868202958 + 0.51966515058261 + 0.52001921368656 + 0.52045171881541 + 0.52098185226964 + 0.52163435393921 + 0.52243908016631 + 0.52343392813044 + 0.52466743315799 + 0.52620245776835 + 0.52812158709516 + 0.53053571460708 + 0.53360612698163 + 0.53755622912816 + 0.54271648396711 + 0.54960139753442 + 0.55907021288061 + 0.57271263887652 + 0.59403584058953 + 0.63396799202894 + 1.00000000000000 + 0.62314954351801 + 0.57124649298238 + 0.50551388479639 + 0.50551388654871 + 0.50551388683910 + 0.50551388717746 + 0.50551388757184 + 0.50551388803155 + 0.50551388856753 + 0.50551388919231 + 0.50551388992101 + 0.50551389077462 + 0.50551389178877 + 0.50551389302164 + 0.50551389454323 + 0.50551389643145 + 0.50551389877430 + 0.50551390168322 + 0.50551390529272 + 0.50551390977062 + 0.50551391533040 + 0.50551392224751 + 0.50551393085375 + 0.50551394156094 + 0.50551395488156 + 0.50551397145537 + 0.50551399208700 + 0.50551401785686 + 0.50551405033215 + 0.50551409159804 + 0.50551414415234 + 0.50551421106594 + 0.50551429647373 + 0.50551440555355 + 0.50551454484182 + 0.50551472265634 + 0.50551494956397 + 0.50551523897980 + 0.50551560790036 + 0.50551607783817 + 0.50551667682189 + 0.50551744148911 + 0.50551841758385 + 0.50551966334189 + 0.50552125231356 + 0.50552327044014 + 0.50552577450685 + 0.50552876207296 + 0.50553226426018 + 0.50553630134301 + 0.50554077849722 + 0.50554562538932 + 0.50555084988006 + 0.50555647991977 + 0.50556254874512 + 0.50556909354680 + 0.50557616625902 + 0.50558382026478 + 0.50559210337295 + 0.50560106868343 + 0.50561077622156 + 0.50562130157877 + 0.50563278866422 + 0.50564558468609 + 0.50566016014535 + 0.50567690495512 + 0.50569618954951 + 0.50571845599103 + 0.50574420508259 + 0.50577402577338 + 0.50580861950741 + 0.50584882604836 + 0.50589565883341 + 0.50595037145798 + 0.50601467120245 + 0.50609121620673 + 0.50618359842208 + 0.50629590415837 + 0.50643301758183 + 0.50651283869697 + 0.50660130671377 + 0.50669946253541 + 0.50680848732222 + 0.50692972389324 + 0.50706470186536 + 0.50721516737340 + 0.50738311855387 + 0.50757085405152 + 0.50778119938452 + 0.50802054354536 + 0.50830600159968 + 0.50865443533463 + 0.50908111100443 + 0.50960563231004 + 0.51025145677190 + 0.51104812067338 + 0.51203307488004 + 0.51325422733634 + 0.51477355674579 + 0.51667274738668 + 0.51906862334291 + 0.52211784040191 + 0.52604373731034 + 0.53117759393863 + 0.53803709593675 + 0.54749065082079 + 0.56117022284911 + 0.58267962593386 + 0.62314954351801 + 1.00000000000000 + 0.61220963015604 + 0.49442693882672 + 0.49442694036512 + 0.49442694061964 + 0.49442694091692 + 0.49442694126319 + 0.49442694166690 + 0.49442694213721 + 0.49442694268546 + 0.49442694332505 + 0.49442694407486 + 0.49442694496535 + 0.49442694604797 + 0.49442694738675 + 0.49442694904857 + 0.49442695111392 + 0.49442695368018 + 0.49442695686716 + 0.49442696082450 + 0.49442696574224 + 0.49442697186604 + 0.49442697949085 + 0.49442698898655 + 0.49442700080900 + 0.49442701553024 + 0.49442703386992 + 0.49442705679309 + 0.49442708570653 + 0.49442712247922 + 0.49442716935408 + 0.49442722908428 + 0.49442730538509 + 0.49442740291044 + 0.49442752753853 + 0.49442768674643 + 0.49442789004339 + 0.49442814949947 + 0.49442848041999 + 0.49442890216921 + 0.49442943999234 + 0.49443012689053 + 0.49443100406963 + 0.49443212398857 + 0.49443355288745 + 0.49443536812431 + 0.49443762055501 + 0.49444030731721 + 0.49444345574381 + 0.49444708317743 + 0.49445110283433 + 0.49445545004387 + 0.49446013064917 + 0.49446516840355 + 0.49447059157208 + 0.49447643166906 + 0.49448273310189 + 0.49448954112656 + 0.49449689549402 + 0.49450484013653 + 0.49451342452470 + 0.49452271125312 + 0.49453282276895 + 0.49454406071839 + 0.49455683341907 + 0.49457147411105 + 0.49458829499870 + 0.49460766713137 + 0.49463000782174 + 0.49465580506606 + 0.49468563693726 + 0.49472019164096 + 0.49476029507667 + 0.49480696442748 + 0.49486158764444 + 0.49492634422826 + 0.49500417390399 + 0.49509837941621 + 0.49521286857944 + 0.49527928563813 + 0.49535271420985 + 0.49543397476754 + 0.49552399510040 + 0.49562382617468 + 0.49573466064651 + 0.49585785461866 + 0.49599495347903 + 0.49614772768356 + 0.49631835652816 + 0.49651196276040 + 0.49674257267225 + 0.49702387564181 + 0.49736807076972 + 0.49779076885039 + 0.49831050813373 + 0.49895046893843 + 0.49973978960978 + 0.50071534633034 + 0.50192421609276 + 0.50342745656389 + 0.50531123561910 + 0.50768793230431 + 0.51071298084535 + 0.51460823401948 + 0.51970347358345 + 0.52651579202342 + 0.53592960570624 + 0.54961289834916 + 0.57124649298238 + 0.61220963015604 + 1.00000000000000 + 1.00000000000000 + 0.99980294055239 + 0.99978725169099 + 0.99977108792677 + 0.99975446533170 + 0.99973738584160 + 0.99971983565203 + 0.99970178326464 + 0.99968317485406 + 0.99966391688655 + 0.99964382634133 + 0.99962261224061 + 0.99959998431075 + 0.99957569646607 + 0.99954950769084 + 0.99952115878732 + 0.99949036367508 + 0.99945680429487 + 0.99942009128245 + 0.99937975840479 + 0.99933533276899 + 0.99928628951066 + 0.99923204933829 + 0.99917197398342 + 0.99910534833222 + 0.99903129785758 + 0.99894864309867 + 0.99885607760436 + 0.99875239993435 + 0.99863641230539 + 0.99850651323055 + 0.99836105074256 + 0.99819821171593 + 0.99801589930848 + 0.99781166553197 + 0.99758263863879 + 0.99732544611632 + 0.99703613181838 + 0.99670979100797 + 0.99634045199343 + 0.99592149821447 + 0.99544524810263 + 0.99490291181345 + 0.99428511425266 + 0.99358517268136 + 0.99279925772045 + 0.99191818784395 + 0.99093189260093 + 0.98983536514082 + 0.98861952425537 + 0.98726970102119 + 0.98576979385882 + 0.98410291803985 + 0.98225076178639 + 0.98019088127523 + 0.97789699989396 + 0.97533856031247 + 0.97247863324142 + 0.96927464230664 + 0.96568000377191 + 0.96164387337967 + 0.95710601810119 + 0.95200372661752 + 0.94628526219689 + 0.93990758370421 + 0.93283057890289 + 0.92502573151907 + 0.91647669951438 + 0.90718247706307 + 0.89716202410742 + 0.88645951234304 + 0.87514888038169 + 0.86333193747454 + 0.85112461310575 + 0.83866131816596 + 0.82610497552011 + 0.81361970092254 + 0.80744249541767 + 0.80132884399652 + 0.79528639567776 + 0.78931835983529 + 0.78342334971664 + 0.77759546379777 + 0.77182468846637 + 0.76609769476963 + 0.76039891691677 + 0.75470897614481 + 0.74895892700104 + 0.74294818123040 + 0.73656731052002 + 0.72979585505037 + 0.72260596914900 + 0.71500153279062 + 0.70699367040969 + 0.69859990083158 + 0.68984319557636 + 0.68075095811549 + 0.67135173040755 + 0.66163449301850 + 0.65162404202249 + 0.64134771418509 + 0.63083632909097 + 0.62012560891484 + 0.60925773014479 + 0.59826033668597 + 0.58716220000386 + 0.57601644883011 + 0.56487858894069 + 0.55380137461067 + 0.99980294055239 + 1.00000000000000 + 0.99993942509474 + 0.99989288908031 + 0.99985375236689 + 0.99981944078283 + 0.99978844785717 + 0.99975976118203 + 0.99973264392661 + 0.99970651079303 + 0.99968080951923 + 0.99965496369310 + 0.99962847060745 + 0.99960092750355 + 0.99957197363530 + 0.99954125697960 + 0.99950841930679 + 0.99947308588831 + 0.99943482085543 + 0.99939311932692 + 0.99934747739368 + 0.99929734415548 + 0.99924211882001 + 0.99918114573161 + 0.99911369591426 + 0.99903888353352 + 0.99895551963918 + 0.99886229133294 + 0.99875799391961 + 0.99864142803297 + 0.99851099066424 + 0.99836502949960 + 0.99820173140827 + 0.99801899937803 + 0.99781438490044 + 0.99758501524597 + 0.99732751644781 + 0.99703793047051 + 0.99671135017216 + 0.99634180116293 + 0.99592266415505 + 0.99544625473226 + 0.99490378023337 + 0.99428586294596 + 0.99358581785084 + 0.99279981348585 + 0.99191866633841 + 0.99093230432244 + 0.98983571928403 + 0.98861982886189 + 0.98726996312789 + 0.98577001962063 + 0.98410311282920 + 0.98225093027202 + 0.98019102747683 + 0.97789712726535 + 0.97533867180802 + 0.97247873136588 + 0.96927472916134 + 0.96568008111501 + 0.96164394265236 + 0.95710608046636 + 0.95200378300591 + 0.94628531335897 + 0.93990763024173 + 0.93283062130024 + 0.92502577016823 + 0.91647673473274 + 0.90718250911659 + 0.89716205321764 + 0.88645953870461 + 0.87514890416813 + 0.86333195884421 + 0.85112463220565 + 0.83866133513803 + 0.82610499051069 + 0.81361971407917 + 0.80744250771463 + 0.80132885547319 + 0.79528640637444 + 0.78931836979342 + 0.78342335897823 + 0.77759547240466 + 0.77182469646080 + 0.76609770219468 + 0.76039892381405 + 0.75470898255602 + 0.74895893296237 + 0.74294818676761 + 0.73656731565509 + 0.72979585980505 + 0.72260597354459 + 0.71500153684870 + 0.70699367415104 + 0.69859990427263 + 0.68984319873424 + 0.68075096100424 + 0.67135173303927 + 0.66163449540431 + 0.65162404417310 + 0.64134771611152 + 0.63083633080527 + 0.62012561042971 + 0.60925773147321 + 0.59826033784117 + 0.58716220100052 + 0.57601644968252 + 0.56487858966377 + 0.55380137521979 + 0.99978725169099 + 0.99993942509474 + 1.00000000000000 + 0.99993172505935 + 0.99988135862193 + 0.99984001196353 + 0.99980429970483 + 0.99977231002295 + 0.99974280478794 + 0.99971489787160 + 0.99968784750722 + 0.99966095287135 + 0.99963362862360 + 0.99960541590350 + 0.99957591432801 + 0.99954474328985 + 0.99951152380734 + 0.99947586591468 + 0.99943732211055 + 0.99939537843757 + 0.99934952399832 + 0.99929920226998 + 0.99924380796881 + 0.99918268191263 + 0.99911509237859 + 0.99904015134794 + 0.99895666808584 + 0.99886332848168 + 0.99875892719871 + 0.99864226453751 + 0.99851173718756 + 0.99836569274329 + 0.99820231804273 + 0.99801951602453 + 0.99781483807563 + 0.99758541129513 + 0.99732786146051 + 0.99703823021457 + 0.99671161001183 + 0.99634202601067 + 0.99592285846862 + 0.99544642249384 + 0.99490392495868 + 0.99428598771375 + 0.99358592535890 + 0.99279990608819 + 0.99191874605643 + 0.99093237290562 + 0.98983577826688 + 0.98861987958634 + 0.98727000676541 + 0.98577005720043 + 0.98410314524649 + 0.98225095830536 + 0.98019105179789 + 0.97789714844848 + 0.97533869034720 + 0.97247874767970 + 0.96927474359846 + 0.96568009396796 + 0.96164395416049 + 0.95710609082629 + 0.95200379237123 + 0.94628532185281 + 0.93990763796646 + 0.93283062833662 + 0.92502577658080 + 0.91647674057549 + 0.90718251443252 + 0.89716205804535 + 0.88645954307559 + 0.87514890811197 + 0.86333196238647 + 0.85112463537126 + 0.83866133795132 + 0.82610499299453 + 0.81361971625903 + 0.80744250975211 + 0.80132885737457 + 0.79528640814759 + 0.78931837144353 + 0.78342336051287 + 0.77759547383067 + 0.77182469778562 + 0.76609770342488 + 0.76039892495679 + 0.75470898361777 + 0.74895893395019 + 0.74294818768503 + 0.73656731650551 + 0.72979586059270 + 0.72260597427288 + 0.71500153752096 + 0.70699367477079 + 0.69859990484299 + 0.68984319925721 + 0.68075096148284 + 0.67135173347513 + 0.66163449579937 + 0.65162404452947 + 0.64134771643074 + 0.63083633108936 + 0.62012561068028 + 0.60925773169308 + 0.59826033803273 + 0.58716220116568 + 0.57601644982368 + 0.56487858978360 + 0.55380137532057 + 0.99977108792677 + 0.99989288908031 + 0.99993172505935 + 1.00000000000000 + 0.99992328365813 + 0.99986909361117 + 0.99982566010598 + 0.99978864584709 + 0.99975569891627 + 0.99972533911908 + 0.99969648214072 + 0.99966821840457 + 0.99963983147522 + 0.99961077719006 + 0.99958059696421 + 0.99954886941526 + 0.99951518668877 + 0.99947913810311 + 0.99944026071385 + 0.99939802875406 + 0.99935192236532 + 0.99930137791735 + 0.99924578450450 + 0.99918447856578 + 0.99911672500134 + 0.99904163312473 + 0.99895801003790 + 0.99886454016064 + 0.99876001737266 + 0.99864324155958 + 0.99851260904011 + 0.99836646728362 + 0.99820300308477 + 0.99802011932117 + 0.99781536724963 + 0.99758587375695 + 0.99732826432700 + 0.99703858022460 + 0.99671191342800 + 0.99634228856929 + 0.99592308537358 + 0.99544661839344 + 0.99490409395560 + 0.99428613340231 + 0.99358605089182 + 0.99280001421276 + 0.99191883913389 + 0.99093245298116 + 0.98983584712929 + 0.98861993880404 + 0.98727005770725 + 0.98577010106557 + 0.98410318308450 + 0.98225099102336 + 0.98019108018083 + 0.97789717316914 + 0.97533871198060 + 0.97247876671273 + 0.96927476044301 + 0.96568010896192 + 0.96164396758714 + 0.95710610290976 + 0.95200380329322 + 0.94628533175992 + 0.93990764697587 + 0.93283063654238 + 0.92502578405949 + 0.91647674738823 + 0.90718252063149 + 0.89716206367420 + 0.88645954817184 + 0.87514891270934 + 0.86333196651611 + 0.85112463906191 + 0.83866134123033 + 0.82610499588993 + 0.81361971880045 + 0.80744251212754 + 0.80132885959137 + 0.79528641021292 + 0.78931837336640 + 0.78342336230151 + 0.77759547549252 + 0.77182469932954 + 0.76609770485874 + 0.76039892628903 + 0.75470898485570 + 0.74895893510138 + 0.74294818875431 + 0.73656731749743 + 0.72979586151067 + 0.72260597512165 + 0.71500153830428 + 0.70699367549291 + 0.69859990550719 + 0.68984319986716 + 0.68075096204066 + 0.67135173398363 + 0.66163449626039 + 0.65162404494475 + 0.64134771680313 + 0.63083633142024 + 0.62012561097291 + 0.60925773194948 + 0.59826033825565 + 0.58716220135793 + 0.57601644998827 + 0.56487858992298 + 0.55380137543816 + 0.99975446533170 + 0.99985375236689 + 0.99988135862193 + 0.99992328365813 + 1.00000000000000 + 0.99991408120141 + 0.99985612557657 + 0.99981073939553 + 0.99977250080669 + 0.99973858450208 + 0.99970722082564 + 0.99967712063132 + 0.99964734595348 + 0.99961721631196 + 0.99958618418729 + 0.99955376807169 + 0.99951951878575 + 0.99948299679801 + 0.99944371823281 + 0.99940114169272 + 0.99935473566012 + 0.99930392739392 + 0.99924809888307 + 0.99918658108608 + 0.99911863470615 + 0.99904336577755 + 0.99895957876332 + 0.99886595629494 + 0.99876129128370 + 0.99864438310011 + 0.99851362759767 + 0.99836737208463 + 0.99820380329540 + 0.99802082401629 + 0.99781598535152 + 0.99758641393234 + 0.99732873489438 + 0.99703898905400 + 0.99671226783825 + 0.99634259525762 + 0.99592335041444 + 0.99544684721782 + 0.99490429135615 + 0.99428630357457 + 0.99358619751725 + 0.99280014050130 + 0.99191894784244 + 0.99093254649877 + 0.98983592754855 + 0.98862000795295 + 0.98727011718925 + 0.98577015228194 + 0.98410322726009 + 0.98225102921855 + 0.98019111331445 + 0.97789720202333 + 0.97533873723019 + 0.97247878892624 + 0.96927478009886 + 0.96568012645965 + 0.96164398325305 + 0.95710611700915 + 0.95200381603676 + 0.94628534331653 + 0.93990765748441 + 0.93283064611342 + 0.92502579278138 + 0.91647675533322 + 0.90718252786029 + 0.89716207023700 + 0.88645955411390 + 0.87514891806966 + 0.86333197133126 + 0.85112464336444 + 0.83866134505324 + 0.82610499926561 + 0.81361972176272 + 0.80744251489632 + 0.80132886217523 + 0.79528641262111 + 0.78931837560809 + 0.78342336438638 + 0.77759547742986 + 0.77182470112912 + 0.76609770653010 + 0.76039892784129 + 0.75470898629889 + 0.74895893644316 + 0.74294819000052 + 0.73656731865303 + 0.72979586258067 + 0.72260597611104 + 0.71500153921816 + 0.70699367633463 + 0.69859990628174 + 0.68984320057778 + 0.68075096269077 + 0.67135173457583 + 0.66163449679716 + 0.65162404542849 + 0.64134771723655 + 0.63083633180614 + 0.62012561131378 + 0.60925773224818 + 0.59826033851587 + 0.58716220158208 + 0.57601645018018 + 0.56487859008566 + 0.55380137557496 + 0.99973738584160 + 0.99981944078283 + 0.99984001196353 + 0.99986909361117 + 0.99991408120141 + 1.00000000000000 + 0.99990410752075 + 0.99984249224192 + 0.99979528296539 + 0.99975584710188 + 0.99972083080641 + 0.99968817611341 + 0.99965653838836 + 0.99962500504111 + 0.99959288574979 + 0.99955960672209 + 0.99952465761571 + 0.99948755754991 + 0.99944779357892 + 0.99940480319798 + 0.99935803945566 + 0.99930691776893 + 0.99925081102764 + 0.99918904324710 + 0.99912086987590 + 0.99904539288256 + 0.99896141349464 + 0.99886761214167 + 0.99876278054082 + 0.99864571740314 + 0.99851481800737 + 0.99836842945386 + 0.99820473837613 + 0.99802164745047 + 0.99781670758166 + 0.99758704510441 + 0.99732928473280 + 0.99703946675886 + 0.99671268195856 + 0.99634295361858 + 0.99592366011412 + 0.99544711459735 + 0.99490452201195 + 0.99428650241363 + 0.99358636883782 + 0.99280028805244 + 0.99191907484956 + 0.99093265575119 + 0.98983602149079 + 0.98862008872622 + 0.98727018666570 + 0.98577021209907 + 0.98410327884750 + 0.98225107381919 + 0.98019115199807 + 0.97789723571124 + 0.97533876670525 + 0.97247881485502 + 0.96927480304201 + 0.96568014687965 + 0.96164400153461 + 0.95710613346040 + 0.95200383090430 + 0.94628535679965 + 0.93990766974302 + 0.93283065727680 + 0.92502580295334 + 0.91647676459918 + 0.90718253629046 + 0.89716207789027 + 0.88645956104321 + 0.87514892431973 + 0.86333197694444 + 0.85112464838100 + 0.83866134950975 + 0.82610500320040 + 0.81361972521620 + 0.80744251812364 + 0.80132886518670 + 0.79528641542825 + 0.78931837822165 + 0.78342336681645 + 0.77759547968816 + 0.77182470322643 + 0.76609770847804 + 0.76039892965132 + 0.75470898798110 + 0.74895893800735 + 0.74294819145301 + 0.73656732000028 + 0.72979586382790 + 0.72260597726419 + 0.71500154028270 + 0.70699367731595 + 0.69859990718449 + 0.68984320140648 + 0.68075096344850 + 0.67135173526605 + 0.66163449742327 + 0.65162404599281 + 0.64134771774182 + 0.63083633225563 + 0.62012561171118 + 0.60925773259667 + 0.59826033881877 + 0.58716220184363 + 0.57601645040343 + 0.56487859027522 + 0.55380137573457 + 0.99971983565203 + 0.99978844785717 + 0.99980429970483 + 0.99982566010598 + 0.99985612557657 + 0.99990410752075 + 1.00000000000000 + 0.99989336216507 + 0.99982822999125 + 0.99977928763076 + 0.99973855773909 + 0.99970216631928 + 0.99966793295147 + 0.99963451528178 + 0.99960097869990 + 0.99956660054384 + 0.99953077617234 + 0.99949296338126 + 0.99945260768214 + 0.99940911736955 + 0.99936192464705 + 0.99931042928377 + 0.99925399234058 + 0.99919192893873 + 0.99912348787258 + 0.99904776601996 + 0.99896356060114 + 0.99886954933164 + 0.99876452242928 + 0.99864727776681 + 0.99851620990786 + 0.99836966566363 + 0.99820583153338 + 0.99802261003676 + 0.99781755184038 + 0.99758778291036 + 0.99732992746534 + 0.99704002517416 + 0.99671316605168 + 0.99634337253296 + 0.99592402214684 + 0.99544742715737 + 0.99490479164177 + 0.99428673484350 + 0.99358656909391 + 0.99280046051980 + 0.99191922329317 + 0.99093278343611 + 0.98983613127538 + 0.98862018311354 + 0.98727026784273 + 0.98577028198265 + 0.98410333911127 + 0.98225112591649 + 0.98019119718062 + 0.97789727505334 + 0.97533880112550 + 0.97247884513121 + 0.96927482982811 + 0.96568017072001 + 0.96164402287390 + 0.95710615266177 + 0.95200384825532 + 0.94628537253234 + 0.93990768404633 + 0.93283067030055 + 0.92502581481881 + 0.91647677540617 + 0.90718254612140 + 0.89716208681578 + 0.88645956912160 + 0.87514893160622 + 0.86333198348933 + 0.85112465422883 + 0.83866135470477 + 0.82610500778787 + 0.81361972924202 + 0.80744252188560 + 0.80132886869777 + 0.79528641870033 + 0.78931838126780 + 0.78342336964975 + 0.77759548232086 + 0.77182470567175 + 0.76609771074916 + 0.76039893176075 + 0.75470898994161 + 0.74895893983026 + 0.74294819314665 + 0.73656732157029 + 0.72979586528217 + 0.72260597860846 + 0.71500154152386 + 0.70699367845992 + 0.69859990823664 + 0.68984320237190 + 0.68075096433174 + 0.67135173607107 + 0.66163449815269 + 0.65162404665041 + 0.64134771833111 + 0.63083633278015 + 0.62012561217439 + 0.60925773300300 + 0.59826033917191 + 0.58716220214814 + 0.57601645066377 + 0.56487859049624 + 0.55380137592087 + 0.99970178326464 + 0.99975976118203 + 0.99977231002295 + 0.99978864584709 + 0.99981073939553 + 0.99984249224192 + 0.99989336216507 + 1.00000000000000 + 0.99988185079474 + 0.99981334626045 + 0.99976263760925 + 0.99972036357264 + 0.99968232235710 + 0.99964627784550 + 0.99961084084096 + 0.99957503278317 + 0.99953809614367 + 0.99949939389586 + 0.99945831009562 + 0.99941421147476 + 0.99936650140506 + 0.99931455857335 + 0.99925772840970 + 0.99919531447755 + 0.99912655703105 + 0.99905054650984 + 0.99896607512933 + 0.99887181722508 + 0.99876656111951 + 0.99864910360805 + 0.99851783835574 + 0.99837111178103 + 0.99820711019228 + 0.99802373590268 + 0.99781853927141 + 0.99758864581999 + 0.99733067917747 + 0.99704067828068 + 0.99671373223777 + 0.99634386249511 + 0.99592444557808 + 0.99544779272547 + 0.99490510699290 + 0.99428700668039 + 0.99358680329553 + 0.99280066220771 + 0.99191939687601 + 0.99093293273557 + 0.98983625963270 + 0.98862029345563 + 0.98727036273361 + 0.98577036366370 + 0.98410340954047 + 0.98225118679446 + 0.98019124997028 + 0.97789732101364 + 0.97533884133281 + 0.97247888049380 + 0.96927486111051 + 0.96568019855779 + 0.96164404779073 + 0.95710617507855 + 0.95200386850968 + 0.94628539089608 + 0.93990770073788 + 0.93283068549688 + 0.92502582866412 + 0.91647678801499 + 0.90718255759026 + 0.89716209722589 + 0.88645957854487 + 0.87514894010548 + 0.86333199112231 + 0.85112466104822 + 0.83866136076328 + 0.82610501313717 + 0.81361973393609 + 0.80744252627210 + 0.80132887279154 + 0.79528642251596 + 0.78931838481901 + 0.78342337295214 + 0.77759548538994 + 0.77182470852229 + 0.76609771339658 + 0.76039893422009 + 0.75470899222736 + 0.74895894195551 + 0.74294819512092 + 0.73656732340119 + 0.72979586697704 + 0.72260598017542 + 0.71500154297074 + 0.70699367979347 + 0.69859990946406 + 0.68984320349772 + 0.68075096536137 + 0.67135173700918 + 0.66163449900296 + 0.65162404741704 + 0.64134771901765 + 0.63083633339119 + 0.62012561271424 + 0.60925773347647 + 0.59826033958406 + 0.58716220250340 + 0.57601645096782 + 0.56487859075381 + 0.55380137613787 + 0.99968317485406 + 0.99973264392661 + 0.99974280478794 + 0.99975569891627 + 0.99977250080669 + 0.99979528296539 + 0.99982822999125 + 0.99988185079474 + 1.00000000000000 + 0.99986956407585 + 0.99979773911892 + 0.99974506887807 + 0.99970100175098 + 0.99966109629568 + 0.99962301139529 + 0.99958528990641 + 0.99954690993684 + 0.99950708011770 + 0.99946508963281 + 0.99942024396861 + 0.99937190550297 + 0.99931942383469 + 0.99926212334155 + 0.99919929230765 + 0.99913015987259 + 0.99905380822554 + 0.99896902327228 + 0.99887447508746 + 0.99876894958440 + 0.99865124215960 + 0.99851974531957 + 0.99837280497132 + 0.99820860714952 + 0.99802505387547 + 0.99781969513158 + 0.99758965589378 + 0.99733155908174 + 0.99704144276004 + 0.99671439497705 + 0.99634443601124 + 0.99592494121816 + 0.99544822062833 + 0.99490547610968 + 0.99428732485306 + 0.99358707740184 + 0.99280089824860 + 0.99191960001396 + 0.99093310743483 + 0.98983640981533 + 0.98862042254747 + 0.98727047373538 + 0.98577045920308 + 0.98410349190790 + 0.98225125798021 + 0.98019131169293 + 0.97789737474483 + 0.97533888832977 + 0.97247892182476 + 0.96927489766838 + 0.96568023108613 + 0.96164407690138 + 0.95710620126512 + 0.95200389216787 + 0.94628541234273 + 0.93990772022995 + 0.93283070324129 + 0.92502584482668 + 0.91647680273290 + 0.90718257097559 + 0.89716210937510 + 0.88645958954132 + 0.87514895002276 + 0.86333200002765 + 0.85112466900480 + 0.83866136783099 + 0.82610501937677 + 0.81361973941169 + 0.80744253138866 + 0.80132887756673 + 0.79528642696633 + 0.78931838896190 + 0.78342337680508 + 0.77759548897068 + 0.77182471184824 + 0.76609771648545 + 0.76039893708926 + 0.75470899489434 + 0.74895894443529 + 0.74294819742430 + 0.73656732553731 + 0.72979586895507 + 0.72260598200374 + 0.71500154465869 + 0.70699368134964 + 0.69859991089548 + 0.68984320481138 + 0.68075096656331 + 0.67135173810413 + 0.66163449999554 + 0.65162404831190 + 0.64134771981958 + 0.63083633410435 + 0.62012561334476 + 0.60925773402885 + 0.59826034006475 + 0.58716220291815 + 0.57601645132237 + 0.56487859105447 + 0.55380137639123 + 0.99966391688655 + 0.99970651079303 + 0.99971489787160 + 0.99972533911908 + 0.99973858450208 + 0.99975584710188 + 0.99977928763076 + 0.99981334626045 + 0.99986956407585 + 1.00000000000000 + 0.99985641445879 + 0.99978116949588 + 0.99972634215811 + 0.99968029878983 + 0.99963831743894 + 0.99959793287047 + 0.99955762538281 + 0.99951633518000 + 0.99947319702841 + 0.99942742218441 + 0.99937831269013 + 0.99932517687299 + 0.99926731008276 + 0.99920397997661 + 0.99913440098550 + 0.99905764456771 + 0.99897248854381 + 0.99887759756763 + 0.99877175443616 + 0.99865375271688 + 0.99852198343190 + 0.99837479178522 + 0.99821036341469 + 0.99802659996503 + 0.99782105092139 + 0.99759084060035 + 0.99733259106161 + 0.99704233932904 + 0.99671517220328 + 0.99634510857835 + 0.99592552243863 + 0.99544872239517 + 0.99490590892042 + 0.99428769790791 + 0.99358739877235 + 0.99280117497017 + 0.99191983814131 + 0.99093331221384 + 0.98983658583860 + 0.98862057383997 + 0.98727060381377 + 0.98577057114882 + 0.98410358841203 + 0.98225134137800 + 0.98019138399567 + 0.97789743768266 + 0.97533894337649 + 0.97247897022922 + 0.96927494047901 + 0.96568026917627 + 0.96164411098484 + 0.95710623192174 + 0.95200391985971 + 0.94628543744406 + 0.93990774304116 + 0.93283072400320 + 0.92502586373679 + 0.91647681995094 + 0.90718258663401 + 0.89716212358682 + 0.88645960240270 + 0.87514896162118 + 0.86333201044229 + 0.85112467830928 + 0.83866137609596 + 0.82610502667541 + 0.81361974581642 + 0.80744253737471 + 0.80132888315343 + 0.79528643217320 + 0.78931839380988 + 0.78342338131390 + 0.77759549316123 + 0.77182471574102 + 0.76609772010113 + 0.76039894044857 + 0.75470899801707 + 0.74895894734030 + 0.74294820012300 + 0.73656732803988 + 0.72979587127254 + 0.72260598414682 + 0.71500154663730 + 0.70699368317332 + 0.69859991257348 + 0.68984320635153 + 0.68075096797172 + 0.67135173938760 + 0.66163450115964 + 0.65162404936107 + 0.64134772075954 + 0.63083633494065 + 0.62012561408324 + 0.60925773467701 + 0.59826034062836 + 0.58716220340432 + 0.57601645173828 + 0.56487859140758 + 0.55380137668846 + 0.99964382634133 + 0.99968080951923 + 0.99968784750722 + 0.99969648214072 + 0.99970722082564 + 0.99972083080641 + 0.99973855773909 + 0.99976263760925 + 0.99979773911892 + 0.99985641445879 + 1.00000000000000 + 0.99984225397517 + 0.99976349334847 + 0.99970637766395 + 0.99965817056942 + 0.99961385968004 + 0.99957086813060 + 0.99952762638090 + 0.99948299977883 + 0.99943604638483 + 0.99938597539084 + 0.99933203444907 + 0.99927347763925 + 0.99920954405776 + 0.99913942819914 + 0.99906218724931 + 0.99897658848583 + 0.99888128952189 + 0.99877506906654 + 0.99865671825410 + 0.99852462615571 + 0.99837713702081 + 0.99821243593031 + 0.99802842400662 + 0.99782265010077 + 0.99759223770140 + 0.99733380783100 + 0.99704339626096 + 0.99671608829237 + 0.99634590118555 + 0.99592620729179 + 0.99544931354421 + 0.99490641876004 + 0.99428813730430 + 0.99358777725163 + 0.99280150084236 + 0.99192011854777 + 0.99093355334331 + 0.98983679310842 + 0.98862075198852 + 0.98727075699071 + 0.98577070298052 + 0.98410370206584 + 0.98225143960177 + 0.98019146916116 + 0.97789751181993 + 0.97533900822573 + 0.97247902725887 + 0.96927499092496 + 0.96568031406109 + 0.96164415115379 + 0.95710626805241 + 0.95200395249587 + 0.94628546702425 + 0.93990776992355 + 0.93283074847081 + 0.92502588601950 + 0.91647684023913 + 0.90718260508439 + 0.89716214033170 + 0.88645961755796 + 0.87514897528938 + 0.86333202271817 + 0.85112468927876 + 0.83866138584308 + 0.82610503528488 + 0.81361975337535 + 0.80744254444225 + 0.80132888975164 + 0.79528643832522 + 0.78931839954008 + 0.78342338664579 + 0.77759549811906 + 0.77182472034933 + 0.76609772438394 + 0.76039894442984 + 0.75470900171970 + 0.74895895078562 + 0.74294820332560 + 0.73656733101240 + 0.72979587402644 + 0.72260598669484 + 0.71500154899083 + 0.70699368534397 + 0.69859991457136 + 0.68984320818515 + 0.68075096964969 + 0.67135174091703 + 0.66163450254646 + 0.65162405061174 + 0.64134772187989 + 0.63083633593811 + 0.62012561496493 + 0.60925773545010 + 0.59826034130136 + 0.58716220398486 + 0.57601645223500 + 0.56487859182896 + 0.55380137704354 + 0.99962261224061 + 0.99965496369310 + 0.99966095287135 + 0.99966821840457 + 0.99967712063132 + 0.99968817611341 + 0.99970216631928 + 0.99972036357264 + 0.99974506887807 + 0.99978116949588 + 0.99984225397517 + 1.00000000000000 + 0.99982708399705 + 0.99974478097656 + 0.99968522537760 + 0.99963460479485 + 0.99958764273138 + 0.99954167480831 + 0.99949505082255 + 0.99944656091347 + 0.99939526300633 + 0.99934031130503 + 0.99928089893251 + 0.99921622408856 + 0.99914545340684 + 0.99906762459065 + 0.99898149078919 + 0.99888570023991 + 0.99877902617186 + 0.99866025641566 + 0.99852777743723 + 0.99837993215870 + 0.99821490486787 + 0.99803059597065 + 0.99782455349181 + 0.99759389987744 + 0.99733525486522 + 0.99704465270895 + 0.99671717689387 + 0.99634684270366 + 0.99592702053157 + 0.99545001529378 + 0.99490702382317 + 0.99428865864506 + 0.99358822624049 + 0.99280188738685 + 0.99192045115829 + 0.99093383937773 + 0.98983703900963 + 0.98862096338650 + 0.98727093880247 + 0.98577085950619 + 0.98410383705524 + 0.98225155631025 + 0.98019157039353 + 0.97789759998261 + 0.97533908537370 + 0.97247909513264 + 0.96927505098481 + 0.96568036752120 + 0.96164419901096 + 0.95710631111029 + 0.95200399140030 + 0.94628550229426 + 0.93990780197903 + 0.93283077765042 + 0.92502591259877 + 0.91647686444345 + 0.90718262709750 + 0.89716216031479 + 0.88645963564842 + 0.87514899161040 + 0.86333203738188 + 0.85112470238951 + 0.83866139750077 + 0.82610504559311 + 0.81361976243626 + 0.80744255291886 + 0.80132889767204 + 0.79528644571782 + 0.78931840643082 + 0.78342339306514 + 0.77759550409388 + 0.77182472590898 + 0.76609772955761 + 0.76039894924543 + 0.75470900620476 + 0.74895895496434 + 0.74294820721457 + 0.73656733462543 + 0.72979587737821 + 0.72260598979909 + 0.71500155186089 + 0.70699368799308 + 0.69859991701148 + 0.68984321042689 + 0.68075097170205 + 0.67135174278854 + 0.66163450424411 + 0.65162405214353 + 0.64134772325333 + 0.63083633716103 + 0.62012561604602 + 0.60925773639900 + 0.59826034212757 + 0.58716220469810 + 0.57601645284556 + 0.56487859234748 + 0.55380137748053 + 0.99959998431075 + 0.99962847060745 + 0.99963362862360 + 0.99963983147522 + 0.99964734595348 + 0.99965653838836 + 0.99966793295147 + 0.99968232235710 + 0.99970100175098 + 0.99972634215811 + 0.99976349334847 + 0.99982708399705 + 1.00000000000000 + 0.99981099395988 + 0.99972511224266 + 0.99966289589150 + 0.99960953363858 + 0.99955952844543 + 0.99951011009399 + 0.99945955330993 + 0.99940665090111 + 0.99935040479440 + 0.99928991388073 + 0.99922431553864 + 0.99915273619115 + 0.99907418612406 + 0.99898739906257 + 0.99889101047579 + 0.99878378606461 + 0.99866450909443 + 0.99853156247774 + 0.99838328727147 + 0.99821786661840 + 0.99803319993437 + 0.99782683414654 + 0.99759589037475 + 0.99733698675684 + 0.99704615567036 + 0.99671847838107 + 0.99634796777063 + 0.99592799185268 + 0.99545085309450 + 0.99490774592263 + 0.99428928063617 + 0.99358876179106 + 0.99280234840639 + 0.99192084785487 + 0.99093418056195 + 0.98983733238697 + 0.98862121567986 + 0.98727115587688 + 0.98577104648024 + 0.98410399838815 + 0.98225169587448 + 0.98019169152272 + 0.97789770554063 + 0.97533917780119 + 0.97247917650353 + 0.96927512303313 + 0.96568043168638 + 0.96164425648061 + 0.95710636284255 + 0.95200403815970 + 0.94628554469860 + 0.93990784052839 + 0.93283081275220 + 0.92502594458038 + 0.91647689357265 + 0.90718265360174 + 0.89716218438119 + 0.88645965744325 + 0.87514901128328 + 0.86333205506727 + 0.85112471821492 + 0.83866141158774 + 0.82610505806393 + 0.81361977341784 + 0.80744256320295 + 0.80132890729134 + 0.79528645470583 + 0.78931841482077 + 0.78342340089002 + 0.77759551138955 + 0.77182473270850 + 0.76609773589452 + 0.76039895515321 + 0.75470901171607 + 0.74895896010757 + 0.74294821201016 + 0.73656733908800 + 0.72979588152414 + 0.72260599364382 + 0.71500155542078 + 0.70699369128255 + 0.69859992004446 + 0.68984321321551 + 0.68075097425734 + 0.67135174511991 + 0.66163450636120 + 0.65162405405487 + 0.64134772496759 + 0.63083633868914 + 0.62012561739765 + 0.60925773758603 + 0.59826034316198 + 0.58716220559178 + 0.57601645361097 + 0.56487859299790 + 0.55380137803000 + 0.99957569646607 + 0.99960092750355 + 0.99960541590350 + 0.99961077719006 + 0.99961721631196 + 0.99962500504111 + 0.99963451528178 + 0.99964627784550 + 0.99966109629568 + 0.99968029878983 + 0.99970637766395 + 0.99974478097656 + 0.99981099395988 + 1.00000000000000 + 0.99979402520418 + 0.99970447069279 + 0.99963929381914 + 0.99958278709099 + 0.99952923970946 + 0.99947579627701 + 0.99942073814734 + 0.99936280083590 + 0.99930092947032 + 0.99923416694587 + 0.99916157950074 + 0.99908213767613 + 0.99899454779677 + 0.99889742753643 + 0.99878953205820 + 0.99866963819187 + 0.99853612392415 + 0.99838732765122 + 0.99822143085491 + 0.99803633155307 + 0.99782957520361 + 0.99759828121796 + 0.99733906571367 + 0.99704795874452 + 0.99672003885202 + 0.99634931597008 + 0.99592915521546 + 0.99545185607106 + 0.99490861003457 + 0.99429002469803 + 0.99358940229014 + 0.99280289970274 + 0.99192132223101 + 0.99093458860108 + 0.98983768333190 + 0.98862151758892 + 0.98727141575603 + 0.98577127043920 + 0.98410419174793 + 0.98225186324606 + 0.98019183688305 + 0.97789783230007 + 0.97533928887401 + 0.97247927435259 + 0.96927520972726 + 0.96568050894555 + 0.96164432571776 + 0.95710642519930 + 0.95200409454571 + 0.94628559585287 + 0.93990788704799 + 0.93283085512142 + 0.92502598319287 + 0.91647692875468 + 0.90718268561930 + 0.89716221346556 + 0.88645968379505 + 0.87514903508206 + 0.86333207647723 + 0.85112473738889 + 0.83866142867544 + 0.82610507321152 + 0.81361978678062 + 0.80744257572982 + 0.80132891902149 + 0.79528646568002 + 0.78931842507878 + 0.78342341047257 + 0.77759552033631 + 0.77182474106114 + 0.76609774369200 + 0.76039896243564 + 0.75470901852148 + 0.74895896647004 + 0.74294821795168 + 0.73656734462612 + 0.72979588667759 + 0.72260599843014 + 0.71500155985824 + 0.70699369538856 + 0.69859992383334 + 0.68984321670244 + 0.68075097745492 + 0.67135174804057 + 0.66163450901459 + 0.65162405645154 + 0.64134772711932 + 0.63083634060735 + 0.62012561909683 + 0.60925773907913 + 0.59826034446368 + 0.58716220671734 + 0.57601645457656 + 0.56487859381948 + 0.55380137872425 + 0.99954950769084 + 0.99957197363530 + 0.99957591432801 + 0.99958059696421 + 0.99958618418729 + 0.99959288574979 + 0.99960097869990 + 0.99961084084096 + 0.99962301139529 + 0.99963831743894 + 0.99965817056942 + 0.99968522537760 + 0.99972511224266 + 0.99979402520418 + 1.00000000000000 + 0.99977618174920 + 0.99968278110097 + 0.99961425943290 + 0.99955408629111 + 0.99949639366226 + 0.99943833453497 + 0.99937813176359 + 0.99931446157166 + 0.99924621208856 + 0.99917235557847 + 0.99909180288955 + 0.99900322056320 + 0.99890520086903 + 0.99879648389849 + 0.99867583722882 + 0.99854163191442 + 0.99839220249305 + 0.99822572801547 + 0.99804010450180 + 0.99783287541297 + 0.99760115792476 + 0.99734156559705 + 0.99705012558009 + 0.99672191304657 + 0.99635093431574 + 0.99593055095909 + 0.99545305882016 + 0.99490964582796 + 0.99429091627326 + 0.99359016956903 + 0.99280356003422 + 0.99192189042084 + 0.99093507737825 + 0.98983810381202 + 0.98862187943504 + 0.98727172736373 + 0.98577153911485 + 0.98410442384409 + 0.98225206427608 + 0.98019201158900 + 0.97789798475046 + 0.97533942254883 + 0.97247939219514 + 0.96927531420422 + 0.96568060211106 + 0.96164440925864 + 0.95710650047374 + 0.95200416264221 + 0.94628565765028 + 0.93990794326429 + 0.93283090633830 + 0.92502602988279 + 0.91647697130406 + 0.90718272435619 + 0.89716224866601 + 0.88645971570206 + 0.87514906391284 + 0.86333210243099 + 0.85112476065432 + 0.83866144943049 + 0.82610509163980 + 0.81361980306399 + 0.80744259101185 + 0.80132893334822 + 0.79528647909906 + 0.78931843763883 + 0.78342342222268 + 0.77759553132402 + 0.77182475133441 + 0.76609775329899 + 0.76039897142307 + 0.75470902693496 + 0.74895897434860 + 0.74294822532143 + 0.73656735150657 + 0.72979589309017 + 0.72260600439458 + 0.71500156539406 + 0.70699370051607 + 0.69859992857081 + 0.68984322106603 + 0.68075098146003 + 0.67135175170069 + 0.66163451234237 + 0.65162405945935 + 0.64134772982096 + 0.63083634301846 + 0.62012562123275 + 0.60925774095814 + 0.59826034610310 + 0.58716220813628 + 0.57601645579444 + 0.56487859485702 + 0.55380137960160 + 0.99952115878732 + 0.99954125697960 + 0.99954474328985 + 0.99954886941526 + 0.99955376807169 + 0.99955960672209 + 0.99956660054384 + 0.99957503278317 + 0.99958528990641 + 0.99959793287047 + 0.99961385968004 + 0.99963460479485 + 0.99966289589150 + 0.99970447069279 + 0.99977618174920 + 1.00000000000000 + 0.99975744829905 + 0.99965993328078 + 0.99958754059162 + 0.99952306356322 + 0.99946060673086 + 0.99939726295375 + 0.99933119213792 + 0.99926101110425 + 0.99918553738816 + 0.99910358831259 + 0.99901377065314 + 0.99891463935458 + 0.99880491243158 + 0.99868334388729 + 0.99854829482848 + 0.99839809413280 + 0.99823091724036 + 0.99804465727992 + 0.99783685496125 + 0.99760462450237 + 0.99734457617738 + 0.99705273349271 + 0.99672416743819 + 0.99635287987741 + 0.99593222804383 + 0.99545450332300 + 0.99491088929062 + 0.99429198621597 + 0.99359109009688 + 0.99280435212900 + 0.99192257196110 + 0.99093566370544 + 0.98983860830522 + 0.98862231371598 + 0.98727210150071 + 0.98577186185841 + 0.98410470279826 + 0.98225230603042 + 0.98019222181637 + 0.97789816832001 + 0.97533958361487 + 0.97247953427670 + 0.96927544025300 + 0.96568071457941 + 0.96164451016165 + 0.95710659143592 + 0.95200424496169 + 0.94628573238219 + 0.93990801126762 + 0.93283096830812 + 0.92502608638743 + 0.91647702281436 + 0.90718277126362 + 0.89716229130724 + 0.88645975437041 + 0.87514909887162 + 0.86333213392392 + 0.85112478890844 + 0.83866147466610 + 0.82610511407390 + 0.81361982292270 + 0.80744260966641 + 0.80132895085707 + 0.79528649551860 + 0.78931845302765 + 0.78342343663822 + 0.77759554482455 + 0.77182476397716 + 0.76609776514066 + 0.76039898251905 + 0.75470903733873 + 0.74895898410691 + 0.74294823446314 + 0.73656736005503 + 0.72979590106853 + 0.72260601182502 + 0.71500157229971 + 0.70699370691919 + 0.69859993449164 + 0.68984322652442 + 0.68075098647331 + 0.67135175628537 + 0.66163451651394 + 0.65162406323198 + 0.64134773321267 + 0.63083634604664 + 0.62012562391766 + 0.60925774332102 + 0.59826034816679 + 0.58716220992367 + 0.57601645733003 + 0.56487859616658 + 0.55380138071131 + 0.99949036367508 + 0.99950841930679 + 0.99951152380734 + 0.99951518668877 + 0.99951951878575 + 0.99952465761571 + 0.99953077617234 + 0.99953809614367 + 0.99954690993684 + 0.99955762538281 + 0.99957086813060 + 0.99958764273138 + 0.99960953363858 + 0.99963929381914 + 0.99968278110097 + 0.99975744829905 + 1.00000000000000 + 0.99973779310537 + 0.99963572588810 + 0.99955879772961 + 0.99948936065618 + 0.99942143754267 + 0.99935205406747 + 0.99927930582989 + 0.99920173786376 + 0.99911801300233 + 0.99902664436010 + 0.99892613018113 + 0.99881515520254 + 0.99869245306820 + 0.99855637032162 + 0.99840522740776 + 0.99823719433545 + 0.99805016001056 + 0.99784166127554 + 0.99760880838981 + 0.99734820736498 + 0.99705587708287 + 0.99672688331411 + 0.99635522241674 + 0.99593424628387 + 0.99545624085069 + 0.99491238436070 + 0.99429327218039 + 0.99359219615880 + 0.99280530370820 + 0.99192339067741 + 0.99093636807402 + 0.98983921446283 + 0.98862283565819 + 0.98727255132415 + 0.98577225006292 + 0.98410503849995 + 0.98225259712112 + 0.98019247509373 + 0.97789838961214 + 0.97533977790177 + 0.97247970577175 + 0.96927559248769 + 0.96568085048814 + 0.96164463215423 + 0.95710670145841 + 0.95200434457085 + 0.94628582283680 + 0.93990809359629 + 0.93283104334930 + 0.92502615482940 + 0.91647708522039 + 0.90718282811039 + 0.89716234299891 + 0.88645980126574 + 0.87514914129137 + 0.86333217216314 + 0.85112482324384 + 0.83866150536312 + 0.82610514140279 + 0.81361984715561 + 0.80744263245283 + 0.80132897226525 + 0.79528651561888 + 0.78931847189011 + 0.78342345433195 + 0.77759556141869 + 0.77182477953934 + 0.76609777973832 + 0.76039899621883 + 0.75470905020367 + 0.74895899619170 + 0.74294824580183 + 0.73656737067272 + 0.72979591099077 + 0.72260602107768 + 0.71500158090861 + 0.70699371490973 + 0.69859994188805 + 0.68984323334821 + 0.68075099274463 + 0.67135176202484 + 0.66163452173802 + 0.65162406796118 + 0.64134773746553 + 0.63083634984658 + 0.62012562728894 + 0.60925774629065 + 0.59826035076220 + 0.58716221217348 + 0.57601645926463 + 0.56487859781786 + 0.55380138211142 + 0.99945680429487 + 0.99947308588831 + 0.99947586591468 + 0.99947913810311 + 0.99948299679801 + 0.99948755754991 + 0.99949296338126 + 0.99949939389586 + 0.99950708011770 + 0.99951633518000 + 0.99952762638090 + 0.99954167480831 + 0.99955952844543 + 0.99958278709099 + 0.99961425943290 + 0.99965993328078 + 0.99973779310537 + 1.00000000000000 + 0.99971708560362 + 0.99960986559792 + 0.99952770843623 + 0.99945256460431 + 0.99937838002049 + 0.99930210787295 + 0.99922176788587 + 0.99913574986870 + 0.99904241220214 + 0.99894016334000 + 0.99882763622918 + 0.99870353314505 + 0.99856617885428 + 0.99841388100663 + 0.99824480136272 + 0.99805682255199 + 0.99784747592278 + 0.99761386633666 + 0.99735259420383 + 0.99705967249341 + 0.99673016041214 + 0.99635804748182 + 0.99593667900592 + 0.99545833422177 + 0.99491418485218 + 0.99429482026832 + 0.99359352727504 + 0.99280644869107 + 0.99192437570660 + 0.99093721553494 + 0.98983994385385 + 0.98862346385762 + 0.98727309290297 + 0.98577271763808 + 0.98410544301770 + 0.98225294805948 + 0.98019278060877 + 0.97789865669655 + 0.97534001252563 + 0.97247991299157 + 0.96927577653601 + 0.96568101488243 + 0.96164477978922 + 0.95710683466174 + 0.95200446520121 + 0.94628593241073 + 0.93990819335089 + 0.93283113429368 + 0.92502623778817 + 0.91647716088211 + 0.90718289704742 + 0.89716240570598 + 0.88645985817506 + 0.87514919279451 + 0.86333221862111 + 0.85112486499301 + 0.83866154272866 + 0.82610517471147 + 0.81361987673856 + 0.80744266029545 + 0.80132899845140 + 0.79528654023328 + 0.78931849501529 + 0.78342347605246 + 0.77759558181587 + 0.77182479869646 + 0.76609779773523 + 0.76039901313231 + 0.75470906610920 + 0.74895901115450 + 0.74294825986092 + 0.73656738385505 + 0.72979592332557 + 0.72260603259396 + 0.71500159163490 + 0.70699372487469 + 0.69859995111983 + 0.68984324187133 + 0.68075100058385 + 0.67135176920230 + 0.66163452827671 + 0.65162407388243 + 0.64134774279459 + 0.63083635461079 + 0.62012563151890 + 0.60925775001850 + 0.59826035402242 + 0.58716221500206 + 0.57601646169943 + 0.56487859989815 + 0.55380138387729 + 0.99942009128245 + 0.99943482085543 + 0.99943732211055 + 0.99944026071385 + 0.99944371823281 + 0.99944779357892 + 0.99945260768214 + 0.99945831009562 + 0.99946508963281 + 0.99947319702841 + 0.99948299977883 + 0.99949505082255 + 0.99951011009399 + 0.99952923970946 + 0.99955408629111 + 0.99958754059162 + 0.99963572588810 + 0.99971708560362 + 1.00000000000000 + 0.99969517008384 + 0.99958213740177 + 0.99949393819819 + 0.99941223323614 + 0.99933088358812 + 0.99924675585021 + 0.99915771128930 + 0.99906183451665 + 0.99895738413177 + 0.99884290917861 + 0.99871706210492 + 0.99857813422572 + 0.99842441342035 + 0.99825404872736 + 0.99806491333528 + 0.99785453063627 + 0.99761999802857 + 0.99735790846120 + 0.99706426723664 + 0.99673412525061 + 0.99636146346616 + 0.99593961901545 + 0.99546086288463 + 0.99491635876736 + 0.99429668868913 + 0.99359513330998 + 0.99280782985511 + 0.99192556379248 + 0.99093823768435 + 0.98984082368619 + 0.98862422179616 + 0.98727374653225 + 0.98577328217156 + 0.98410593163403 + 0.98225337216405 + 0.98019315001088 + 0.97789897981090 + 0.97534029653606 + 0.97248016397000 + 0.96927599957537 + 0.96568121421046 + 0.96164495887844 + 0.95710699630503 + 0.95200461163752 + 0.94628606545648 + 0.93990831450033 + 0.93283124476419 + 0.92502633858125 + 0.91647725282573 + 0.90718298084133 + 0.89716248195116 + 0.88645992739959 + 0.87514925547649 + 0.86333227519738 + 0.85112491587680 + 0.83866158831816 + 0.82610521540462 + 0.81361991293879 + 0.80744269439806 + 0.80132903055897 + 0.79528657044681 + 0.78931852343709 + 0.78342350278042 + 0.77759560695004 + 0.77182482233370 + 0.76609781997209 + 0.76039903406091 + 0.75470908582081 + 0.74895902972249 + 0.74294827733031 + 0.73656740025753 + 0.72979593869336 + 0.72260604695840 + 0.71500160502772 + 0.70699373732877 + 0.69859996266635 + 0.68984325253992 + 0.68075101040257 + 0.67135177819897 + 0.66163453647602 + 0.65162408131212 + 0.64134774948523 + 0.63083636059622 + 0.62012563683573 + 0.60925775470805 + 0.59826035812710 + 0.58716221856616 + 0.57601646476971 + 0.56487860252363 + 0.55380138610904 + 0.99937975840479 + 0.99939311932692 + 0.99939537843757 + 0.99939802875406 + 0.99940114169272 + 0.99940480319798 + 0.99940911736955 + 0.99941421147476 + 0.99942024396861 + 0.99942742218441 + 0.99943604638483 + 0.99944656091347 + 0.99945955330993 + 0.99947579627701 + 0.99949639366226 + 0.99952306356322 + 0.99955879772961 + 0.99960986559792 + 0.99969517008384 + 1.00000000000000 + 0.99967202416195 + 0.99955232422158 + 0.99945713334397 + 0.99936788502113 + 0.99927833010454 + 0.99918516479529 + 0.99908594233227 + 0.99897865353287 + 0.99886170446294 + 0.99873366537031 + 0.99859277453955 + 0.99843728859531 + 0.99826533661141 + 0.99807477734743 + 0.99786312249016 + 0.99762745891651 + 0.99736436947029 + 0.99706984939132 + 0.99673893891956 + 0.99636560821266 + 0.99594318421394 + 0.99546392765980 + 0.99491899233135 + 0.99429895120427 + 0.99359707742050 + 0.99280950136298 + 0.99192700144879 + 0.99093947451459 + 0.98984188841301 + 0.98862513920916 + 0.98727453793808 + 0.98577396596596 + 0.98410652373822 + 0.98225388635021 + 0.98019359812217 + 0.97789937199833 + 0.97534064146667 + 0.97248046897106 + 0.96927627078031 + 0.96568145671304 + 0.96164517686275 + 0.95710719313900 + 0.95200479001419 + 0.94628622756663 + 0.93990846214761 + 0.93283137942262 + 0.92502646146805 + 0.91647736495035 + 0.90718308305647 + 0.89716257498726 + 0.88646001190384 + 0.87514933203244 + 0.86333234434585 + 0.85112497812275 + 0.83866164414999 + 0.82610526530738 + 0.81361995740856 + 0.80744273633175 + 0.80132907008141 + 0.79528660768023 + 0.78931855850335 + 0.78342353580001 + 0.77759563804278 + 0.77182485161677 + 0.76609784755902 + 0.76039906006389 + 0.75470911034391 + 0.74895905285793 + 0.74294829912755 + 0.73656742075003 + 0.72979595791709 + 0.72260606494609 + 0.71500162181779 + 0.70699375295581 + 0.69859997716634 + 0.68984326594770 + 0.68075102274963 + 0.67135178951958 + 0.66163454679947 + 0.65162409067266 + 0.64134775792038 + 0.63083636814592 + 0.62012564354728 + 0.60925776063126 + 0.59826036331569 + 0.58716222307543 + 0.57601646865785 + 0.56487860585223 + 0.55380138894185 + 0.99933533276899 + 0.99934747739368 + 0.99934952399832 + 0.99935192236532 + 0.99935473566012 + 0.99935803945566 + 0.99936192464705 + 0.99936650140506 + 0.99937190550297 + 0.99937831269013 + 0.99938597539084 + 0.99939526300633 + 0.99940665090111 + 0.99942073814734 + 0.99943833453497 + 0.99946060673086 + 0.99948936065618 + 0.99952770843623 + 0.99958213740177 + 0.99967202416195 + 1.00000000000000 + 0.99964749893816 + 0.99952009793277 + 0.99941682682267 + 0.99931890237359 + 0.99921987146112 + 0.99911611233735 + 0.99900509159853 + 0.99888495543081 + 0.99875413195267 + 0.99861077225043 + 0.99845308215652 + 0.99827915880542 + 0.99808683847778 + 0.99787361532542 + 0.99763656111904 + 0.99737224476387 + 0.99707664808317 + 0.99674479750277 + 0.99637064943673 + 0.99594751799627 + 0.99546765114448 + 0.99492219036404 + 0.99430169745679 + 0.99359943632663 + 0.99281152897447 + 0.99192874511085 + 0.99094097451665 + 0.98984317976355 + 0.98862625208693 + 0.98727549821639 + 0.98577479595536 + 0.98410724272527 + 0.98225451100407 + 0.98019414277394 + 0.97789984893038 + 0.97534106116095 + 0.97248084028611 + 0.96927660113111 + 0.96568175224868 + 0.96164544263628 + 0.95710743321514 + 0.95200500763907 + 0.94628642539242 + 0.93990864235803 + 0.93283154380838 + 0.92502661150871 + 0.91647750187735 + 0.90718320790963 + 0.89716268866646 + 0.88646011520004 + 0.87514942566251 + 0.86333242897264 + 0.85112505436607 + 0.83866171260730 + 0.82610532658040 + 0.81362001209934 + 0.80744278795162 + 0.80132911878148 + 0.79528665361161 + 0.78931860181154 + 0.78342357663247 + 0.77759567654327 + 0.77182488792523 + 0.76609788181102 + 0.76039909239323 + 0.75470914087636 + 0.74895908170045 + 0.74294832633774 + 0.73656744636347 + 0.72979598197318 + 0.72260608748114 + 0.71500164287208 + 0.70699377256955 + 0.69859999538004 + 0.68984328280024 + 0.68075103827932 + 0.67135180376608 + 0.66163455979959 + 0.65162410246634 + 0.64134776855346 + 0.63083637766987 + 0.62012565201944 + 0.60925776811437 + 0.59826036987518 + 0.58716222878088 + 0.57601647358239 + 0.56487861007319 + 0.55380139253719 + 0.99928628951066 + 0.99929734415548 + 0.99929920226998 + 0.99930137791735 + 0.99930392739392 + 0.99930691776893 + 0.99931042928377 + 0.99931455857335 + 0.99931942383469 + 0.99932517687299 + 0.99933203444907 + 0.99934031130503 + 0.99935040479440 + 0.99936280083590 + 0.99937813176359 + 0.99939726295375 + 0.99942143754267 + 0.99945256460431 + 0.99949393819819 + 0.99955232422158 + 0.99964749893816 + 1.00000000000000 + 0.99962140613130 + 0.99948507431476 + 0.99937245869668 + 0.99926446555351 + 0.99915428837440 + 0.99903822461043 + 0.99891390474212 + 0.99877949571008 + 0.99863299837841 + 0.99847253330061 + 0.99829614521030 + 0.99810163468446 + 0.99788646904081 + 0.99764769791173 + 0.99738187061143 + 0.99708495076275 + 0.99675194664165 + 0.99637679697443 + 0.99595279960788 + 0.99547218646707 + 0.99492608370717 + 0.99430503927573 + 0.99360230568917 + 0.99281399464485 + 0.99193086508953 + 0.99094279806528 + 0.98984474968064 + 0.98862760519866 + 0.98727666604583 + 0.98577580562349 + 0.98410811766210 + 0.98225527144743 + 0.98019480611075 + 0.97790043006604 + 0.97534157280818 + 0.97248129318379 + 0.96927700425552 + 0.96568211305436 + 0.96164576723429 + 0.95710772652001 + 0.95200527358074 + 0.94628666718361 + 0.93990886265192 + 0.93283174478348 + 0.92502679496849 + 0.91647766932958 + 0.90718336063108 + 0.89716282775829 + 0.88646024163413 + 0.87514954032127 + 0.86333253267303 + 0.85112514787119 + 0.83866179665273 + 0.82610540190119 + 0.81362007943423 + 0.80744285156602 + 0.80132917885796 + 0.79528671032965 + 0.78931865535283 + 0.78342362717385 + 0.77759572425632 + 0.77182493297919 + 0.76609792437168 + 0.76039913261656 + 0.75470917891403 + 0.74895911767851 + 0.74294836032071 + 0.73656747839094 + 0.72979601208613 + 0.72260611572042 + 0.71500166927977 + 0.70699379719093 + 0.69860001826062 + 0.68984330398398 + 0.68075105781316 + 0.67135182169591 + 0.66163457617004 + 0.65162411732540 + 0.64134778195784 + 0.63083638968401 + 0.62012566271321 + 0.60925777756592 + 0.59826037816718 + 0.58716223599921 + 0.57601647981824 + 0.56487861542295 + 0.55380139710017 + 0.99923204933829 + 0.99924211882001 + 0.99924380796881 + 0.99924578450450 + 0.99924809888307 + 0.99925081102764 + 0.99925399234058 + 0.99925772840970 + 0.99926212334155 + 0.99926731008276 + 0.99927347763925 + 0.99928089893251 + 0.99928991388073 + 0.99930092947032 + 0.99931446157166 + 0.99933119213792 + 0.99935205406747 + 0.99937838002049 + 0.99941223323614 + 0.99945713334397 + 0.99952009793277 + 0.99962140613130 + 1.00000000000000 + 0.99959350884248 + 0.99944678238077 + 0.99932325705636 + 0.99920336437570 + 0.99908020505057 + 0.99895024717952 + 0.99881113584465 + 0.99866059712431 + 0.99849660215089 + 0.99831710704123 + 0.99811985421293 + 0.99790226900181 + 0.99766136787353 + 0.99739367199001 + 0.99709511983410 + 0.99676069544279 + 0.99638431451287 + 0.99595925403190 + 0.99547772565569 + 0.99493083631829 + 0.99430911669663 + 0.99360580522429 + 0.99281700088054 + 0.99193344926174 + 0.99094502059924 + 0.98984666302631 + 0.98862925443251 + 0.98727808967607 + 0.98577703673224 + 0.98410918479028 + 0.98225619923511 + 0.98019561572335 + 0.97790113963778 + 0.97534219780414 + 0.97248184665723 + 0.96927749711696 + 0.96568255434241 + 0.96164616437041 + 0.95710808546528 + 0.95200559910195 + 0.94628696318276 + 0.93990913235562 + 0.93283199085440 + 0.92502701961529 + 0.91647787440023 + 0.90718354769312 + 0.89716299816739 + 0.88646039658946 + 0.87514968090905 + 0.86333265990270 + 0.85112526268468 + 0.83866189995470 + 0.82610549459496 + 0.81362016242731 + 0.80744293004109 + 0.80132925303853 + 0.79528678043667 + 0.78931872160426 + 0.78342368978332 + 0.77759578343462 + 0.77182498892802 + 0.76609797728898 + 0.76039918269259 + 0.75470922632699 + 0.74895916257915 + 0.74294840278124 + 0.73656751845344 + 0.72979604979365 + 0.72260615111477 + 0.71500170240783 + 0.70699382810319 + 0.69860004700618 + 0.68984333061591 + 0.68075108238434 + 0.67135184426144 + 0.66163459678319 + 0.65162413604700 + 0.64134779885597 + 0.63083640483722 + 0.62012567621088 + 0.60925778950372 + 0.59826038864771 + 0.58716224512985 + 0.57601648771458 + 0.56487862220416 + 0.55380140289055 + 0.99917197398342 + 0.99918114573161 + 0.99918268191263 + 0.99918447856578 + 0.99918658108608 + 0.99918904324710 + 0.99919192893873 + 0.99919531447755 + 0.99919929230765 + 0.99920397997661 + 0.99920954405776 + 0.99921622408856 + 0.99922431553864 + 0.99923416694587 + 0.99924621208856 + 0.99926101110425 + 0.99927930582989 + 0.99930210787295 + 0.99933088358812 + 0.99936788502113 + 0.99941682682267 + 0.99948507431476 + 0.99959350884248 + 1.00000000000000 + 0.99956348962522 + 0.99940453112325 + 0.99926803367242 + 0.99913422752125 + 0.99899637345712 + 0.99885093737927 + 0.99869509961491 + 0.99852655437059 + 0.99834310182432 + 0.99814238670858 + 0.99792176692600 + 0.99767820800663 + 0.99740818973950 + 0.99710761509155 + 0.99677143515633 + 0.99639353517379 + 0.99596716509279 + 0.99548451068095 + 0.99493665460143 + 0.99431410588194 + 0.99361008542702 + 0.99282067646386 + 0.99193660797415 + 0.99094773677869 + 0.98984900115182 + 0.98863126984828 + 0.98727982956657 + 0.98577854157715 + 0.98411048947003 + 0.98225733384662 + 0.98019660611247 + 0.97790200793794 + 0.97534296288443 + 0.97248252443485 + 0.96927810088188 + 0.96568309510475 + 0.96164665115833 + 0.95710852552776 + 0.95200599823593 + 0.94628732614369 + 0.93990946308617 + 0.93283229261120 + 0.92502729510879 + 0.91647812590477 + 0.90718377714074 + 0.89716320723211 + 0.88646058675522 + 0.87514985351909 + 0.86333281620149 + 0.85112540383450 + 0.83866202707429 + 0.82610560879809 + 0.81362026483004 + 0.80744302694855 + 0.80132934472664 + 0.79528686717545 + 0.78931880365788 + 0.78342376741068 + 0.77759585689010 + 0.77182505845953 + 0.76609804313011 + 0.76039924507234 + 0.75470928545973 + 0.74895921864261 + 0.74294845585653 + 0.73656756858438 + 0.72979609702446 + 0.72260619548884 + 0.71500174397598 + 0.70699386691903 + 0.69860008312722 + 0.68984336409953 + 0.68075111329320 + 0.67135187266246 + 0.66163462273990 + 0.65162415963354 + 0.64134782015703 + 0.63083642395039 + 0.62012569324521 + 0.60925780458032 + 0.59826040189352 + 0.58716225668013 + 0.57601649771161 + 0.56487863079766 + 0.55380141023726 + 0.99910534833222 + 0.99911369591426 + 0.99911509237859 + 0.99911672500134 + 0.99911863470615 + 0.99912086987590 + 0.99912348787258 + 0.99912655703105 + 0.99913015987259 + 0.99913440098550 + 0.99913942819914 + 0.99914545340684 + 0.99915273619115 + 0.99916157950074 + 0.99917235557847 + 0.99918553738816 + 0.99920173786376 + 0.99922176788587 + 0.99924675585021 + 0.99927833010454 + 0.99931890237359 + 0.99937245869668 + 0.99944678238077 + 0.99956348962522 + 1.00000000000000 + 0.99953081053832 + 0.99935719191473 + 0.99920544711567 + 0.99905583597427 + 0.99890157188558 + 0.99873861223742 + 0.99856409628966 + 0.99837553463071 + 0.99817040132089 + 0.99794594245374 + 0.99769904309632 + 0.99742612059302 + 0.99712302653458 + 0.99678466628654 + 0.99640488410681 + 0.99597689433814 + 0.99549284932928 + 0.99494380079499 + 0.99432023042139 + 0.99361533715907 + 0.99282518459856 + 0.99194048099264 + 0.99095106643632 + 0.98985186699095 + 0.98863374005271 + 0.98728196215673 + 0.98578038625094 + 0.98411208901186 + 0.98225872514500 + 0.98019782083652 + 0.97790307319723 + 0.97534390178407 + 0.97248335645160 + 0.96927884225958 + 0.96568375929152 + 0.96164724917215 + 0.95710906621200 + 0.95200648866444 + 0.94628777212881 + 0.93990986945936 + 0.93283266337195 + 0.92502763359562 + 0.91647843492724 + 0.90718405908775 + 0.89716346417812 + 0.88646082053512 + 0.87515006580114 + 0.86333300852917 + 0.85112557764612 + 0.83866218375466 + 0.82610574972264 + 0.81362039136978 + 0.80744314679728 + 0.80132945821754 + 0.79528697464012 + 0.78931890542053 + 0.78342386378606 + 0.77759594818583 + 0.77182514497194 + 0.76609812514717 + 0.76039932286463 + 0.75470935928601 + 0.74895928871378 + 0.74294852226424 + 0.73656763137006 + 0.72979615623498 + 0.72260625116891 + 0.71500179617469 + 0.70699391569462 + 0.69860012854429 + 0.68984340622544 + 0.68075115220024 + 0.67135190843051 + 0.66163465544636 + 0.65162418936856 + 0.64134784702508 + 0.63083644807255 + 0.62012571475643 + 0.60925782363145 + 0.59826041864470 + 0.58716227129818 + 0.57601651037515 + 0.56487864169573 + 0.55380141956341 + 0.99903129785758 + 0.99903888353352 + 0.99904015134794 + 0.99904163312473 + 0.99904336577755 + 0.99904539288256 + 0.99904776601996 + 0.99905054650984 + 0.99905380822554 + 0.99905764456771 + 0.99906218724931 + 0.99906762459065 + 0.99907418612406 + 0.99908213767613 + 0.99909180288955 + 0.99910358831259 + 0.99911801300233 + 0.99913574986870 + 0.99915771128930 + 0.99918516479529 + 0.99921987146112 + 0.99926446555351 + 0.99932325705636 + 0.99940453112325 + 0.99953081053832 + 1.00000000000000 + 0.99949456421717 + 0.99930358477141 + 0.99913441350766 + 0.99896707338333 + 0.99879418263700 + 0.99861163061519 + 0.99841634722118 + 0.99820549177200 + 0.99797611715853 + 0.99772497685937 + 0.99744839101997 + 0.99714213478234 + 0.99680104840215 + 0.99641891978131 + 0.99598891550474 + 0.99550314407696 + 0.99495261727331 + 0.99432778187838 + 0.99362180906746 + 0.99283073777376 + 0.99194525020489 + 0.99095516549872 + 0.98985539448927 + 0.98863678037472 + 0.98728458698676 + 0.98578265688408 + 0.98411405815079 + 0.98226043820533 + 0.98019931679109 + 0.97790438540613 + 0.97534505865882 + 0.97248438191900 + 0.96927975626686 + 0.96568457832284 + 0.96164798673961 + 0.95710973314984 + 0.95200709363968 + 0.94628832227173 + 0.93991037071818 + 0.93283312068294 + 0.92502805108727 + 0.91647881608110 + 0.90718440687411 + 0.89716378117636 + 0.88646110903456 + 0.87515032787741 + 0.86333324610153 + 0.85112579250664 + 0.83866237761968 + 0.82610592429505 + 0.81362054834997 + 0.80744329559556 + 0.80132959924850 + 0.79528710830651 + 0.78931903212079 + 0.78342398390596 + 0.77759606209909 + 0.77182525303711 + 0.76609822771276 + 0.76039942025787 + 0.75470945181793 + 0.74895937663366 + 0.74294860567510 + 0.73656771031078 + 0.72979623075081 + 0.72260632129873 + 0.71500186197230 + 0.70699397722225 + 0.69860018586982 + 0.68984345942665 + 0.68075120136155 + 0.67135195364761 + 0.66163469681261 + 0.65162422699613 + 0.64134788104295 + 0.63083647863103 + 0.62012574202569 + 0.60925784779887 + 0.59826043990988 + 0.58716228987208 + 0.57601652648072 + 0.56487865557008 + 0.55380143145174 + 0.99894864309867 + 0.99895551963918 + 0.99895666808584 + 0.99895801003790 + 0.99895957876332 + 0.99896141349464 + 0.99896356060114 + 0.99896607512933 + 0.99896902327228 + 0.99897248854381 + 0.99897658848583 + 0.99898149078919 + 0.99898739906257 + 0.99899454779677 + 0.99900322056320 + 0.99901377065314 + 0.99902664436010 + 0.99904241220214 + 0.99906183451665 + 0.99908594233227 + 0.99911611233735 + 0.99915428837440 + 0.99920336437570 + 0.99926803367242 + 0.99935719191473 + 0.99949456421717 + 1.00000000000000 + 0.99945410333522 + 0.99924303469626 + 0.99905412245354 + 0.99886653467260 + 0.99867274234160 + 0.99846836649286 + 0.99824993858881 + 0.99801415807133 + 0.99775755328056 + 0.99747628704640 + 0.99716601670254 + 0.99682148684764 + 0.99643640569016 + 0.99600387413963 + 0.99551594197001 + 0.99496356845977 + 0.99433715513503 + 0.99362983756019 + 0.99283762332688 + 0.99195116157419 + 0.99096024491126 + 0.98985976502895 + 0.98864054722894 + 0.98728783930093 + 0.98578547073905 + 0.98411649887647 + 0.98226256206462 + 0.98020117202968 + 0.97790601331846 + 0.97534649438876 + 0.97248565505268 + 0.96928089143709 + 0.96568559587594 + 0.96164890333249 + 0.95711056213423 + 0.95200784569820 + 0.94628900621041 + 0.93991099390026 + 0.93283368923657 + 0.92502857015573 + 0.91647929001117 + 0.90718483938187 + 0.89716417549286 + 0.88646146803016 + 0.87515065415668 + 0.86333354207105 + 0.85112606041326 + 0.83866261960597 + 0.82610614248782 + 0.81362074486226 + 0.80744348203191 + 0.80132977612203 + 0.79528727611859 + 0.78931919135847 + 0.78342413504240 + 0.77759620559594 + 0.77182538933337 + 0.76609835722719 + 0.76039954339204 + 0.75470956894229 + 0.74895948804844 + 0.74294871149235 + 0.73656781056590 + 0.72979632547836 + 0.72260641053585 + 0.71500194576461 + 0.70699405563444 + 0.69860025897533 + 0.68984352731157 + 0.68075126412641 + 0.67135201140854 + 0.66163474968365 + 0.65162427511491 + 0.64134792457085 + 0.63083651775744 + 0.62012577696374 + 0.60925787878590 + 0.59826046720012 + 0.58716231372973 + 0.57601654719073 + 0.56487867343285 + 0.55380144677606 + 0.99885607760436 + 0.99886229133294 + 0.99886332848168 + 0.99886454016064 + 0.99886595629494 + 0.99886761214167 + 0.99886954933164 + 0.99887181722508 + 0.99887447508746 + 0.99887759756763 + 0.99888128952189 + 0.99888570023991 + 0.99889101047579 + 0.99889742753643 + 0.99890520086903 + 0.99891463935458 + 0.99892613018113 + 0.99894016334000 + 0.99895738413177 + 0.99897865353287 + 0.99900509159853 + 0.99903822461043 + 0.99908020505057 + 0.99913422752125 + 0.99920544711567 + 0.99930358477141 + 0.99945410333522 + 1.00000000000000 + 0.99940916838564 + 0.99917497204473 + 0.99896328171245 + 0.99875283707104 + 0.99853568787289 + 0.99830695839908 + 0.99806264864520 + 0.99779887858891 + 0.99751154412101 + 0.99719611345471 + 0.99684718546794 + 0.99645835201211 + 0.99602262109602 + 0.99553196191718 + 0.99497726332908 + 0.99434886711542 + 0.99363986245550 + 0.99284621659166 + 0.99195853619659 + 0.99096657996522 + 0.98986521529653 + 0.98864524473403 + 0.98729189564538 + 0.98578898096213 + 0.98411954446698 + 0.98226521313005 + 0.98020348866977 + 0.97790804693928 + 0.97534828874453 + 0.97248724693250 + 0.96928231144534 + 0.96568686928059 + 0.96165005079671 + 0.95711160020889 + 0.95200878762492 + 0.94628986293195 + 0.93991177458440 + 0.93283440154421 + 0.92502922053441 + 0.91647988391803 + 0.90718538150112 + 0.89716466990031 + 0.88646191835147 + 0.87515106368041 + 0.86333391383877 + 0.85112639724875 + 0.83866292421003 + 0.82610641753300 + 0.81362099299520 + 0.80744371766686 + 0.80132999989702 + 0.79528748865685 + 0.78931939326533 + 0.78342432690796 + 0.77759638798186 + 0.77182556278470 + 0.76609852225701 + 0.76039970048734 + 0.75470971855665 + 0.74895963053896 + 0.74294884698102 + 0.73656793907119 + 0.72979644702535 + 0.72260652514245 + 0.71500205347152 + 0.70699415650097 + 0.69860035308068 + 0.68984361475073 + 0.68075134501647 + 0.67135208589043 + 0.66163481789899 + 0.65162433723371 + 0.64134798079800 + 0.63083656833321 + 0.62012582215984 + 0.60925791890539 + 0.59826050256417 + 0.58716234467663 + 0.57601657408657 + 0.56487869665983 + 0.55380146673124 + 0.99875239993435 + 0.99875799391961 + 0.99875892719871 + 0.99876001737266 + 0.99876129128370 + 0.99876278054082 + 0.99876452242928 + 0.99876656111951 + 0.99876894958440 + 0.99877175443616 + 0.99877506906654 + 0.99877902617186 + 0.99878378606461 + 0.99878953205820 + 0.99879648389849 + 0.99880491243158 + 0.99881515520254 + 0.99882763622918 + 0.99884290917861 + 0.99886170446294 + 0.99888495543081 + 0.99891390474212 + 0.99895024717952 + 0.99899637345712 + 0.99905583597427 + 0.99913441350766 + 0.99924303469626 + 0.99940916838564 + 1.00000000000000 + 0.99935925127815 + 0.99909799233490 + 0.99886039386872 + 0.99862431098416 + 0.99838106627784 + 0.99812511016742 + 0.99785176320682 + 0.99755644160909 + 0.99723429549964 + 0.99687969271739 + 0.99648604928318 + 0.99604623783077 + 0.99555211417433 + 0.99499447071005 + 0.99436356899649 + 0.99365243683742 + 0.99285698884572 + 0.99196777668803 + 0.99097451537257 + 0.98987204125291 + 0.98865112775768 + 0.98729697612634 + 0.98579337818214 + 0.98412336053649 + 0.98226853581939 + 0.98020639317497 + 0.97791059756238 + 0.97535054018319 + 0.97248924515496 + 0.96928409465183 + 0.96568846897524 + 0.96165149273347 + 0.95711290499393 + 0.95200997174433 + 0.94629094003604 + 0.93991275615404 + 0.93283529718929 + 0.92503003836735 + 0.91648063083512 + 0.90718606342303 + 0.89716529199855 + 0.88646248521833 + 0.87515157949115 + 0.86333438244108 + 0.85112682222170 + 0.83866330895782 + 0.82610676542230 + 0.81362130735494 + 0.80744401646415 + 0.80133028393170 + 0.79528775870828 + 0.78931965008852 + 0.78342457123347 + 0.77759662051020 + 0.77182578418271 + 0.76609873315994 + 0.76039990148895 + 0.75470991020828 + 0.74895981327046 + 0.74294902092294 + 0.73656810421862 + 0.72979660338081 + 0.72260667270042 + 0.71500219225896 + 0.70699428656606 + 0.69860047450361 + 0.68984372763805 + 0.68075144950667 + 0.67135218215402 + 0.66163490610936 + 0.65162441760690 + 0.64134805359346 + 0.63083663385526 + 0.62012588075523 + 0.60925797096028 + 0.59826054849152 + 0.58716238491130 + 0.57601660909290 + 0.56487872693033 + 0.55380149277661 + 0.99863641230539 + 0.99864142803297 + 0.99864226453751 + 0.99864324155958 + 0.99864438310011 + 0.99864571740314 + 0.99864727776681 + 0.99864910360805 + 0.99865124215960 + 0.99865375271688 + 0.99865671825410 + 0.99866025641566 + 0.99866450909443 + 0.99866963819187 + 0.99867583722882 + 0.99868334388729 + 0.99869245306820 + 0.99870353314505 + 0.99871706210492 + 0.99873366537031 + 0.99875413195267 + 0.99877949571008 + 0.99881113584465 + 0.99885093737927 + 0.99890157188558 + 0.99896707338333 + 0.99905412245354 + 0.99917497204473 + 0.99935925127815 + 1.00000000000000 + 0.99930296735526 + 0.99901057572747 + 0.99874374997222 + 0.99847896690154 + 0.99820655669701 + 0.99792009386442 + 0.99761406559652 + 0.99728305550006 + 0.99692104759809 + 0.99652118152792 + 0.99607612584886 + 0.99557757226748 + 0.99501617795548 + 0.99438209458006 + 0.99366826729296 + 0.99287054107458 + 0.99197939568334 + 0.99098448943414 + 0.98988061872311 + 0.98865851954213 + 0.98730335954933 + 0.98579890356001 + 0.98412815633752 + 0.98227271235982 + 0.98021004491406 + 0.97791380524117 + 0.97535337245682 + 0.97249175967281 + 0.96928633927988 + 0.96569048315034 + 0.96165330866572 + 0.95711454843435 + 0.95201146330710 + 0.94629229681206 + 0.93991399256089 + 0.93283642533575 + 0.92503106850526 + 0.91648157169955 + 0.90718692253245 + 0.89716607592256 + 0.88646319980781 + 0.87515223005009 + 0.86333497386160 + 0.85112735903503 + 0.83866379547460 + 0.82610720588761 + 0.81362170596896 + 0.80744439566260 + 0.80133064471616 + 0.79528810205511 + 0.78931997694438 + 0.78342488250591 + 0.77759691706989 + 0.77182606685818 + 0.76609900272854 + 0.76040015868243 + 0.75471015569961 + 0.74896004757827 + 0.74294924418072 + 0.73656831638863 + 0.72979680443197 + 0.72260686259409 + 0.71500237099269 + 0.70699445417827 + 0.69860063106842 + 0.68984387327430 + 0.68075158437556 + 0.67135230646488 + 0.66163502007769 + 0.65162452150460 + 0.64134814775054 + 0.63083671865776 + 0.62012595664724 + 0.60925803843531 + 0.59826060807573 + 0.58716243716069 + 0.57601665460415 + 0.56487876633411 + 0.55380152672585 + 0.99850651323055 + 0.99851099066424 + 0.99851173718756 + 0.99851260904011 + 0.99851362759767 + 0.99851481800737 + 0.99851620990786 + 0.99851783835574 + 0.99851974531957 + 0.99852198343190 + 0.99852462615571 + 0.99852777743723 + 0.99853156247774 + 0.99853612392415 + 0.99854163191442 + 0.99854829482848 + 0.99855637032162 + 0.99856617885428 + 0.99857813422572 + 0.99859277453955 + 0.99861077225043 + 0.99863299837841 + 0.99866059712431 + 0.99869509961491 + 0.99873861223742 + 0.99879418263700 + 0.99886653467260 + 0.99896328171245 + 0.99909799233490 + 0.99930296735526 + 1.00000000000000 + 0.99923952902198 + 0.99891148980946 + 0.99861171645138 + 0.99831477754800 + 0.99800968196202 + 0.99768890924112 + 0.99734595299080 + 0.99697411985098 + 0.99656609288147 + 0.99611421971983 + 0.99560994582453 + 0.99504373289362 + 0.99440557811288 + 0.99368831263864 + 0.99288768745950 + 0.99199408701158 + 0.99099709513852 + 0.98989145621961 + 0.98866785767702 + 0.98731142367507 + 0.98580588422480 + 0.98413421609278 + 0.98227799063386 + 0.98021466100971 + 0.97791786109714 + 0.97535695471272 + 0.97249494102456 + 0.96928918002804 + 0.96569303292559 + 0.96165560797635 + 0.95711662963809 + 0.95201335229635 + 0.94629401511396 + 0.93991555838207 + 0.93283785401381 + 0.92503237306590 + 0.91648276326761 + 0.90718801071004 + 0.89716706911204 + 0.88646410549192 + 0.87515305501393 + 0.86333572435115 + 0.85112804082225 + 0.83866441403623 + 0.82610776660985 + 0.81362221416542 + 0.80744487950744 + 0.80133110547146 + 0.79528854094852 + 0.78932039516282 + 0.78342528118927 + 0.77759729730388 + 0.77182642967256 + 0.76609934908866 + 0.76040048948973 + 0.75471047177781 + 0.74896034955847 + 0.74294953219189 + 0.73656859034456 + 0.72979706425107 + 0.72260710818328 + 0.71500260231031 + 0.70699467123602 + 0.69860083393458 + 0.68984406207623 + 0.68075175930297 + 0.67135246777547 + 0.66163516804234 + 0.65162465646552 + 0.64134827012934 + 0.63083682894818 + 0.62012605541856 + 0.60925812632217 + 0.59826068575600 + 0.58716250534879 + 0.57601671406709 + 0.56487881788337 + 0.55380157120252 + 0.99836105074256 + 0.99836502949960 + 0.99836569274329 + 0.99836646728362 + 0.99836737208463 + 0.99836842945386 + 0.99836966566363 + 0.99837111178103 + 0.99837280497132 + 0.99837479178522 + 0.99837713702081 + 0.99837993215870 + 0.99838328727147 + 0.99838732765122 + 0.99839220249305 + 0.99839809413280 + 0.99840522740776 + 0.99841388100663 + 0.99842441342035 + 0.99843728859531 + 0.99845308215652 + 0.99847253330061 + 0.99849660215089 + 0.99852655437059 + 0.99856409628966 + 0.99861163061519 + 0.99867274234160 + 0.99875283707104 + 0.99886039386872 + 0.99901057572747 + 0.99923952902198 + 1.00000000000000 + 0.99916789909270 + 0.99879914692110 + 0.99846228065699 + 0.99812927995622 + 0.99778745924675 + 0.99742797561204 + 0.99704284357882 + 0.99662394490971 + 0.99616309689718 + 0.99565135982311 + 0.99507890279870 + 0.99443549929777 + 0.99371381899978 + 0.99290948314673 + 0.99201274784694 + 0.99101309787665 + 0.98990520909962 + 0.98867970535589 + 0.98732165410442 + 0.98581474019612 + 0.98414190430942 + 0.98228468817227 + 0.98022051927734 + 0.97792300939660 + 0.97536150289058 + 0.97249898118176 + 0.96929278847762 + 0.96569627242042 + 0.96165852969139 + 0.95711927441998 + 0.95201575282660 + 0.94629619861871 + 0.93991754796552 + 0.93283966919493 + 0.92503403046588 + 0.91648427712749 + 0.90718939333728 + 0.89716833130291 + 0.88646525685871 + 0.87515410426896 + 0.86333667949611 + 0.85112890924303 + 0.83866520271133 + 0.82610848239104 + 0.81362286379809 + 0.80744549848433 + 0.80133169539553 + 0.79528910336927 + 0.78932093157567 + 0.78342579302732 + 0.77759778592963 + 0.77182689636923 + 0.76609979505899 + 0.76040091584753 + 0.75471087954341 + 0.74896073949202 + 0.74294990441798 + 0.73656894470082 + 0.72979740058298 + 0.72260742632020 + 0.71500290215174 + 0.70699495275390 + 0.69860109718208 + 0.68984430718702 + 0.68075198650358 + 0.67135267738525 + 0.66163536039792 + 0.65162483200533 + 0.64134842938991 + 0.63083697256906 + 0.62012618412925 + 0.60925824094009 + 0.59826078715214 + 0.58716259444447 + 0.57601679185112 + 0.56487888540084 + 0.55380162953695 + 0.99819821171593 + 0.99820173140827 + 0.99820231804273 + 0.99820300308477 + 0.99820380329540 + 0.99820473837613 + 0.99820583153338 + 0.99820711019228 + 0.99820860714952 + 0.99821036341469 + 0.99821243593031 + 0.99821490486787 + 0.99821786661840 + 0.99822143085491 + 0.99822572801547 + 0.99823091724036 + 0.99823719433545 + 0.99824480136272 + 0.99825404872736 + 0.99826533661141 + 0.99827915880542 + 0.99829614521030 + 0.99831710704123 + 0.99834310182432 + 0.99837553463071 + 0.99841634722118 + 0.99846836649286 + 0.99853568787289 + 0.99862431098416 + 0.99874374997222 + 0.99891148980946 + 0.99916789909270 + 1.00000000000000 + 0.99908675835337 + 0.99867165558970 + 0.99829307038004 + 0.99791957315593 + 0.99753638546906 + 0.99713277577085 + 0.99669910524115 + 0.99622625985529 + 0.99570466668044 + 0.99512403846427 + 0.99447381324497 + 0.99374642475631 + 0.99293731035208 + 0.99203655021849 + 0.99103349538535 + 0.98992273019738 + 0.98869479445328 + 0.98733468110019 + 0.98582601602438 + 0.98415169308316 + 0.98229321583172 + 0.98022797882366 + 0.97792956557713 + 0.97536729558240 + 0.97250412756954 + 0.96929738557303 + 0.96570039990587 + 0.96166225249762 + 0.95712264431762 + 0.95201881125482 + 0.94629898017033 + 0.93992008207285 + 0.93284198079618 + 0.92503614086817 + 0.91648620462459 + 0.90719115378261 + 0.89716993860874 + 0.88646672342215 + 0.87515544131428 + 0.86333789731916 + 0.85113001730191 + 0.83866620992789 + 0.82610939750558 + 0.81362369539393 + 0.80744629139684 + 0.80133245165231 + 0.79528982493734 + 0.78932162034450 + 0.78342645080370 + 0.77759841442757 + 0.77182749719617 + 0.76610036971617 + 0.76040146572061 + 0.75471140588849 + 0.74896124323789 + 0.74295038567305 + 0.73656940319947 + 0.72979783606263 + 0.72260783850678 + 0.71500329085742 + 0.70699531789302 + 0.69860143877951 + 0.68984462538515 + 0.68075228157100 + 0.67135294971520 + 0.66163561041844 + 0.65162506027718 + 0.64134863660263 + 0.63083715954165 + 0.62012635180270 + 0.60925839036911 + 0.59826091945682 + 0.58716271081310 + 0.57601689355573 + 0.56487897379092 + 0.55380170601028 + 0.99801589930848 + 0.99801899937803 + 0.99801951602453 + 0.99802011932117 + 0.99802082401629 + 0.99802164745047 + 0.99802261003676 + 0.99802373590268 + 0.99802505387547 + 0.99802659996503 + 0.99802842400662 + 0.99803059597065 + 0.99803319993437 + 0.99803633155307 + 0.99804010450180 + 0.99804465727992 + 0.99805016001056 + 0.99805682255199 + 0.99806491333528 + 0.99807477734743 + 0.99808683847778 + 0.99810163468446 + 0.99811985421293 + 0.99814238670858 + 0.99817040132089 + 0.99820549177200 + 0.99824993858881 + 0.99830695839908 + 0.99838106627784 + 0.99847896690154 + 0.99861171645138 + 0.99879914692110 + 0.99908675835337 + 1.00000000000000 + 0.99899460148382 + 0.99852686820171 + 0.99810136593678 + 0.99768231167968 + 0.99725207077874 + 0.99679778835683 + 0.99630858136692 + 0.99577376977986 + 0.99518231801419 + 0.99452313974919 + 0.99378831111299 + 0.99297300057421 + 0.99206704173351 + 0.99105960169142 + 0.98994514048287 + 0.98871408545973 + 0.98735133078540 + 0.98584042473723 + 0.98416420000481 + 0.98230411062362 + 0.98023750865312 + 0.97793794128208 + 0.97537469607454 + 0.97251070260863 + 0.96930325900327 + 0.96570567335441 + 0.96166700869215 + 0.95712694917587 + 0.95202271753809 + 0.94630253201505 + 0.93992331713963 + 0.93284493109242 + 0.92503883380508 + 0.91648866380403 + 0.90719339969060 + 0.89717198925484 + 0.88646859484943 + 0.87515714803689 + 0.86333945261026 + 0.85113143332957 + 0.83866749812235 + 0.82611056903528 + 0.81362476121016 + 0.80744730827357 + 0.80133342217169 + 0.79529075159573 + 0.78932250553903 + 0.78342729681732 + 0.77759922342190 + 0.77182827119714 + 0.76610111060057 + 0.76040217521678 + 0.75471208555680 + 0.74896189421059 + 0.74295100802441 + 0.73656999652358 + 0.72979839995411 + 0.72260837254059 + 0.71500379472457 + 0.70699579142709 + 0.69860188196266 + 0.68984503836478 + 0.68075266466698 + 0.67135330342172 + 0.66163593527767 + 0.65162535700379 + 0.64134890608634 + 0.63083740283888 + 0.62012657012568 + 0.60925858507525 + 0.59826109199435 + 0.58716286271093 + 0.57601702645546 + 0.56487908942931 + 0.55380180618906 + 0.99781166553197 + 0.99781438490044 + 0.99781483807563 + 0.99781536724963 + 0.99781598535152 + 0.99781670758166 + 0.99781755184038 + 0.99781853927141 + 0.99781969513158 + 0.99782105092139 + 0.99782265010077 + 0.99782455349181 + 0.99782683414654 + 0.99782957520361 + 0.99783287541297 + 0.99783685496125 + 0.99784166127554 + 0.99784747592278 + 0.99785453063627 + 0.99786312249016 + 0.99787361532542 + 0.99788646904081 + 0.99790226900181 + 0.99792176692600 + 0.99794594245374 + 0.99797611715853 + 0.99801415807133 + 0.99806264864520 + 0.99812511016742 + 0.99820655669701 + 0.99831477754800 + 0.99846228065699 + 0.99867165558970 + 0.99899460148382 + 1.00000000000000 + 0.99888971189453 + 0.99836233724355 + 0.99788404247134 + 0.99741327365800 + 0.99692913796942 + 0.99641700800154 + 0.99586410812175 + 0.99525809699988 + 0.99458702620448 + 0.99384240597306 + 0.99301899687366 + 0.99210627726606 + 0.99109315557085 + 0.98997391944880 + 0.98873884354619 + 0.98737268962894 + 0.98585890285696 + 0.98418023533270 + 0.98231807637089 + 0.98024972285941 + 0.97794867501283 + 0.97538417917954 + 0.97251912732419 + 0.96931078412067 + 0.96571242904140 + 0.96167310081972 + 0.95713246202652 + 0.95202771858860 + 0.94630707782086 + 0.93992745609799 + 0.93284870443931 + 0.92504227695916 + 0.91649180733100 + 0.90719627017427 + 0.89717461008132 + 0.88647098686357 + 0.87515933006094 + 0.86334144182061 + 0.85113324541030 + 0.83866914776213 + 0.82611207054418 + 0.81362612859209 + 0.80744861359879 + 0.80133466872972 + 0.79529194256303 + 0.78932364396398 + 0.78342838560046 + 0.77760026529856 + 0.77182926871997 + 0.76610206612871 + 0.76040309091249 + 0.75471296336194 + 0.74896273551718 + 0.74295181285716 + 0.73657076427757 + 0.72979913002737 + 0.72260906430230 + 0.71500444770463 + 0.70699640533829 + 0.69860245672844 + 0.68984557413430 + 0.68075316182421 + 0.67135376258762 + 0.66163635714322 + 0.65162574248882 + 0.64134925633872 + 0.63083771922076 + 0.62012685420051 + 0.60925883859614 + 0.59826131682879 + 0.58716306082741 + 0.57601719996971 + 0.56487924058159 + 0.55380193730144 + 0.99758263863879 + 0.99758501524597 + 0.99758541129513 + 0.99758587375695 + 0.99758641393234 + 0.99758704510441 + 0.99758778291036 + 0.99758864581999 + 0.99758965589378 + 0.99759084060035 + 0.99759223770140 + 0.99759389987744 + 0.99759589037475 + 0.99759828121796 + 0.99760115792476 + 0.99760462450237 + 0.99760880838981 + 0.99761386633666 + 0.99761999802857 + 0.99762745891651 + 0.99763656111904 + 0.99764769791173 + 0.99766136787353 + 0.99767820800663 + 0.99769904309632 + 0.99772497685937 + 0.99775755328056 + 0.99779887858891 + 0.99785176320682 + 0.99792009386442 + 0.99800968196202 + 0.99812927995622 + 0.99829307038004 + 0.99852686820171 + 0.99888971189453 + 1.00000000000000 + 0.99877013155282 + 0.99817526496176 + 0.99763710209653 + 0.99710726745538 + 0.99656178177254 + 0.99598344649699 + 0.99535745186013 + 0.99467034049523 + 0.99391267989749 + 0.99307858435111 + 0.99215700300347 + 0.99113647026458 + 0.99001102874199 + 0.98877074188944 + 0.98740019157607 + 0.98588268439228 + 0.98420086520926 + 0.98233603802647 + 0.98026542755500 + 0.97796247287546 + 0.97539636684967 + 0.97252995264682 + 0.96932045159956 + 0.96572110612269 + 0.96168092357451 + 0.95713953868434 + 0.95203413581778 + 0.94631290840314 + 0.93993276248491 + 0.93285353998229 + 0.92504668760367 + 0.91649583280820 + 0.90719994510674 + 0.89717796495607 + 0.88647404884719 + 0.87516212365075 + 0.86334398930937 + 0.85113556708021 + 0.83867126253293 + 0.82611399679760 + 0.81362788428396 + 0.80745029041530 + 0.80133627087825 + 0.79529347410295 + 0.78932510878090 + 0.78342978738461 + 0.77760160751893 + 0.77183055460920 + 0.76610329866615 + 0.76040427281008 + 0.75471409705030 + 0.74896382270519 + 0.74295285349359 + 0.73657175749425 + 0.72980007495319 + 0.72260996003448 + 0.71500529354374 + 0.70699720083891 + 0.69860320172793 + 0.68984626877725 + 0.68075380657879 + 0.67135435823906 + 0.66163690457753 + 0.65162624289222 + 0.64134971119448 + 0.63083813028717 + 0.62012722349964 + 0.60925916839012 + 0.59826160952332 + 0.58716331896330 + 0.57601742627266 + 0.56487943793594 + 0.55380210869515 + 0.99732544611632 + 0.99732751644781 + 0.99732786146051 + 0.99732826432700 + 0.99732873489438 + 0.99732928473280 + 0.99732992746534 + 0.99733067917747 + 0.99733155908174 + 0.99733259106161 + 0.99733380783100 + 0.99733525486522 + 0.99733698675684 + 0.99733906571367 + 0.99734156559705 + 0.99734457617738 + 0.99734820736498 + 0.99735259420383 + 0.99735790846120 + 0.99736436947029 + 0.99737224476387 + 0.99738187061143 + 0.99739367199001 + 0.99740818973950 + 0.99742612059302 + 0.99744839101997 + 0.99747628704640 + 0.99751154412101 + 0.99755644160909 + 0.99761406559652 + 0.99768890924112 + 0.99778745924675 + 0.99791957315593 + 0.99810136593678 + 0.99836233724355 + 0.99877013155282 + 1.00000000000000 + 0.99863362646283 + 0.99796196541159 + 0.99735558789629 + 0.99675875149316 + 0.99614324963416 + 0.99548906591571 + 0.99477988044723 + 0.99400458811208 + 0.99315622471188 + 0.99222291795753 + 0.99119264285498 + 0.99005908300441 + 0.98881200312782 + 0.98743573652526 + 0.98591340093934 + 0.98422749683543 + 0.98235921457892 + 0.98028568364444 + 0.97798026298361 + 0.97541207559148 + 0.97254390100302 + 0.96933290410674 + 0.96573227913059 + 0.96169099270642 + 0.95714864353636 + 0.95204238818707 + 0.94632040236301 + 0.93993957894584 + 0.93285974824720 + 0.92505234749467 + 0.91650099618025 + 0.90720465720871 + 0.89718226567157 + 0.88647797370288 + 0.87516570463194 + 0.86334725543281 + 0.85113854464970 + 0.83867397598695 + 0.82611646980624 + 0.81363013992056 + 0.80745244559012 + 0.80133833098381 + 0.79529544433343 + 0.78932699410386 + 0.78343159251001 + 0.77760333686547 + 0.77183221228256 + 0.76610488843106 + 0.76040579809036 + 0.75471556088793 + 0.74896522722045 + 0.74295419852396 + 0.73657304181638 + 0.72980129733843 + 0.72261111920679 + 0.71500638850270 + 0.70699823092018 + 0.69860416665344 + 0.68984716868317 + 0.68075464204043 + 0.67135513025632 + 0.66163761428970 + 0.65162689183740 + 0.64135030128786 + 0.63083866380679 + 0.62012770306190 + 0.60925959690920 + 0.59826199010718 + 0.58716365488416 + 0.57601772104221 + 0.56487969526732 + 0.55380233243822 + 0.99703613181838 + 0.99703793047051 + 0.99703823021457 + 0.99703858022460 + 0.99703898905400 + 0.99703946675886 + 0.99704002517416 + 0.99704067828068 + 0.99704144276004 + 0.99704233932904 + 0.99704339626096 + 0.99704465270895 + 0.99704615567036 + 0.99704795874452 + 0.99705012558009 + 0.99705273349271 + 0.99705587708287 + 0.99705967249341 + 0.99706426723664 + 0.99706984939132 + 0.99707664808317 + 0.99708495076275 + 0.99709511983410 + 0.99710761509155 + 0.99712302653458 + 0.99714213478234 + 0.99716601670254 + 0.99719611345471 + 0.99723429549964 + 0.99728305550006 + 0.99734595299080 + 0.99742797561204 + 0.99753638546906 + 0.99768231167968 + 0.99788404247134 + 0.99817526496176 + 0.99863362646283 + 1.00000000000000 + 0.99847699618473 + 0.99771777475745 + 0.99703430225135 + 0.99636128905229 + 0.99566577090894 + 0.99492536675906 + 0.99412575564313 + 0.99325805584868 + 0.99230905369400 + 0.99126585196441 + 0.99012158899491 + 0.98886559507427 + 0.98748185275534 + 0.98595321794025 + 0.98426199375913 + 0.98238921732541 + 0.98031189115727 + 0.97800326826237 + 0.97543237974493 + 0.97256192167565 + 0.96934898502411 + 0.96574670104542 + 0.96170398329508 + 0.95716038361417 + 0.95205302260095 + 0.94633005319665 + 0.93994835146715 + 0.93286773283096 + 0.92505962233578 + 0.91650762918398 + 0.90721070772845 + 0.89718778605663 + 0.88648301056271 + 0.87517029986020 + 0.86335144692146 + 0.85114236660100 + 0.83867746005136 + 0.82611964654649 + 0.81363303905573 + 0.80745521650410 + 0.80134098060617 + 0.79529797933452 + 0.78932942085065 + 0.78343391703066 + 0.77760556480555 + 0.77183434886696 + 0.76610693844414 + 0.76040776585883 + 0.75471745024625 + 0.74896704080119 + 0.74295593600900 + 0.73657470151819 + 0.72980287754325 + 0.72261261814745 + 0.71500780477757 + 0.70699956357271 + 0.69860541524955 + 0.68984833334595 + 0.68075572348408 + 0.67135612976464 + 0.66163853333853 + 0.65162773241790 + 0.64135106588851 + 0.63083935537993 + 0.62012832498365 + 0.60926015294849 + 0.59826248427282 + 0.58716409139103 + 0.57601810441194 + 0.56488003027791 + 0.55380262403934 + 0.99670979100797 + 0.99671135017216 + 0.99671161001183 + 0.99671191342800 + 0.99671226783825 + 0.99671268195856 + 0.99671316605168 + 0.99671373223777 + 0.99671439497705 + 0.99671517220328 + 0.99671608829237 + 0.99671717689387 + 0.99671847838107 + 0.99672003885202 + 0.99672191304657 + 0.99672416743819 + 0.99672688331411 + 0.99673016041214 + 0.99673412525061 + 0.99673893891956 + 0.99674479750277 + 0.99675194664165 + 0.99676069544279 + 0.99677143515633 + 0.99678466628654 + 0.99680104840215 + 0.99682148684764 + 0.99684718546794 + 0.99687969271739 + 0.99692104759809 + 0.99697411985098 + 0.99704284357882 + 0.99713277577085 + 0.99725207077874 + 0.99741327365800 + 0.99763710209653 + 0.99796196541159 + 0.99847699618473 + 1.00000000000000 + 0.99829653984351 + 0.99743831912417 + 0.99666750843188 + 0.99590769392437 + 0.99512134556969 + 0.99428723766930 + 0.99339278819035 + 0.99242244605732 + 0.99136188086504 + 0.99020336521674 + 0.98893557507851 + 0.98754198439892 + 0.98600507780095 + 0.98430688358188 + 0.98242822883110 + 0.98034594459864 + 0.97803314229941 + 0.97545873109171 + 0.97258529676128 + 0.96936983288805 + 0.96576538794426 + 0.96172080590385 + 0.95717557733978 + 0.95206677604060 + 0.94634252558025 + 0.93995968039778 + 0.93287803671241 + 0.92506900383360 + 0.91651617763192 + 0.90721850131249 + 0.89719489377974 + 0.88648949383584 + 0.87517621378225 + 0.86335684116850 + 0.85114728583196 + 0.83868194541823 + 0.82612373764904 + 0.81363677432672 + 0.80745878752830 + 0.80134439631941 + 0.79530124833107 + 0.78933255133120 + 0.78343691673754 + 0.77760844098064 + 0.77183710819874 + 0.76610958703597 + 0.76041030921161 + 0.75471989321123 + 0.74896938666751 + 0.74295818424370 + 0.73657684979908 + 0.72980492351934 + 0.72261455939626 + 0.71500963934727 + 0.70700129012414 + 0.69860703313155 + 0.68984984267048 + 0.68075712514669 + 0.67135742542688 + 0.66163972491986 + 0.65162882251713 + 0.64135205774527 + 0.63084025282930 + 0.62012913240415 + 0.60926087522164 + 0.59826312657473 + 0.58716465916540 + 0.57601860349090 + 0.56488046681940 + 0.55380300441566 + 0.99634045199343 + 0.99634180116293 + 0.99634202601067 + 0.99634228856929 + 0.99634259525762 + 0.99634295361858 + 0.99634337253296 + 0.99634386249511 + 0.99634443601124 + 0.99634510857835 + 0.99634590118555 + 0.99634684270366 + 0.99634796777063 + 0.99634931597008 + 0.99635093431574 + 0.99635287987741 + 0.99635522241674 + 0.99635804748182 + 0.99636146346616 + 0.99636560821266 + 0.99637064943673 + 0.99637679697443 + 0.99638431451287 + 0.99639353517379 + 0.99640488410681 + 0.99641891978131 + 0.99643640569016 + 0.99645835201211 + 0.99648604928318 + 0.99652118152792 + 0.99656609288147 + 0.99662394490971 + 0.99669910524115 + 0.99679778835683 + 0.99692913796942 + 0.99710726745538 + 0.99735558789629 + 0.99771777475745 + 0.99829653984351 + 1.00000000000000 + 0.99808932983301 + 0.99711890261038 + 0.99624887310040 + 0.99539069170854 + 0.99450562264099 + 0.99357309411495 + 0.99257312027791 + 0.99148885314736 + 0.99031111354117 + 0.98902754767390 + 0.98762086607573 + 0.98607301169112 + 0.98436562081700 + 0.98247922686315 + 0.98039042540540 + 0.97807213605728 + 0.97549310438519 + 0.97261576916178 + 0.96939699465531 + 0.96578971977385 + 0.96174269666507 + 0.95719533527675 + 0.95208464810631 + 0.94635872058753 + 0.93997437918469 + 0.93289139521332 + 0.92508115754029 + 0.91652724464943 + 0.90722858514849 + 0.89720408584009 + 0.88649787543221 + 0.87518385773792 + 0.86336381292823 + 0.85115364399418 + 0.83868774373751 + 0.82612902768422 + 0.81364160600604 + 0.80746340776624 + 0.80134881670354 + 0.79530547999106 + 0.78933660486912 + 0.78344080216527 + 0.77761216763469 + 0.77184068468591 + 0.76611302118549 + 0.76041360805756 + 0.75472306292700 + 0.74897243139377 + 0.74296110314378 + 0.73657963970233 + 0.72980758120798 + 0.72261708155510 + 0.71501202330255 + 0.70700353400481 + 0.69860913600608 + 0.68985180462421 + 0.68075894733008 + 0.67135911000820 + 0.66164127441888 + 0.65163024034226 + 0.64135334813648 + 0.63084142079034 + 0.62013018363788 + 0.60926181607086 + 0.59826396375677 + 0.58716539973408 + 0.57601925499199 + 0.56488103721441 + 0.55380350193940 + 0.99592149821447 + 0.99592266415505 + 0.99592285846862 + 0.99592308537358 + 0.99592335041444 + 0.99592366011412 + 0.99592402214684 + 0.99592444557808 + 0.99592494121816 + 0.99592552243863 + 0.99592620729179 + 0.99592702053157 + 0.99592799185268 + 0.99592915521546 + 0.99593055095909 + 0.99593222804383 + 0.99593424628387 + 0.99593667900592 + 0.99593961901545 + 0.99594318421394 + 0.99594751799627 + 0.99595279960788 + 0.99595925403190 + 0.99596716509279 + 0.99597689433814 + 0.99598891550474 + 0.99600387413963 + 0.99602262109602 + 0.99604623783077 + 0.99607612584886 + 0.99611421971983 + 0.99616309689718 + 0.99622625985529 + 0.99630858136692 + 0.99641700800154 + 0.99656178177254 + 0.99675875149316 + 0.99703430225135 + 0.99743831912417 + 0.99808932983301 + 1.00000000000000 + 0.99785129202546 + 0.99675373379952 + 0.99577165384001 + 0.99480662673120 + 0.99381769037885 + 0.99277541548278 + 0.99165813574483 + 0.99045406857766 + 0.98914915074600 + 0.98772489785362 + 0.98616243522352 + 0.98444282392275 + 0.98254617682133 + 0.98044875981012 + 0.97812322856551 + 0.97553810643272 + 0.97265563426126 + 0.96943250324252 + 0.96582150622939 + 0.96177127340430 + 0.95722110799910 + 0.95210794177133 + 0.94637981033854 + 0.93999350376109 + 0.93290876087532 + 0.92509694384614 + 0.91654160837156 + 0.90724166384153 + 0.89721600104012 + 0.88650873519742 + 0.87519375866347 + 0.86337284155766 + 0.85116187746742 + 0.83869525252514 + 0.82613587914216 + 0.81364786521151 + 0.80746939394713 + 0.80135454492458 + 0.79531096471970 + 0.78934185987798 + 0.78344584043138 + 0.77761700124937 + 0.77184532476767 + 0.76611747782358 + 0.76041789028415 + 0.75472717864859 + 0.74897638584589 + 0.74296489508238 + 0.73658326482504 + 0.72981103514658 + 0.72262035982394 + 0.71501512225727 + 0.70700645108246 + 0.69861186990079 + 0.68985435541322 + 0.68076131650334 + 0.67136130041524 + 0.66164328939113 + 0.65163208437087 + 0.64135502678761 + 0.63084294061046 + 0.62013155207062 + 0.60926304136849 + 0.59826505464900 + 0.58716636536474 + 0.57602010513790 + 0.56488178217642 + 0.55380415236160 + 0.99544524810263 + 0.99544625473226 + 0.99544642249384 + 0.99544661839344 + 0.99544684721782 + 0.99544711459735 + 0.99544742715737 + 0.99544779272547 + 0.99544822062833 + 0.99544872239517 + 0.99544931354421 + 0.99545001529378 + 0.99545085309450 + 0.99545185607106 + 0.99545305882016 + 0.99545450332300 + 0.99545624085069 + 0.99545833422177 + 0.99546086288463 + 0.99546392765980 + 0.99546765114448 + 0.99547218646707 + 0.99547772565569 + 0.99548451068095 + 0.99549284932928 + 0.99550314407696 + 0.99551594197001 + 0.99553196191718 + 0.99555211417433 + 0.99557757226748 + 0.99560994582453 + 0.99565135982311 + 0.99570466668044 + 0.99577376977986 + 0.99586410812175 + 0.99598344649699 + 0.99614324963416 + 0.99636128905229 + 0.99666750843188 + 0.99711890261038 + 0.99785129202546 + 1.00000000000000 + 0.99757791757565 + 0.99633726030609 + 0.99523358389693 + 0.99415584846803 + 0.99305072369023 + 0.99188616886839 + 0.99064530967898 + 0.98931104612640 + 0.98786292178188 + 0.98628077412272 + 0.98454478992937 + 0.98263446187021 + 0.98052558302705 + 0.97819043870227 + 0.97559724566743 + 0.97270797509783 + 0.96947908425129 + 0.96586316967451 + 0.96180869833209 + 0.95725483125094 + 0.95213839318711 + 0.94640735424359 + 0.94001845680496 + 0.93293139709210 + 0.92511750219286 + 0.91656029777236 + 0.90725866780565 + 0.89723148176492 + 0.88652283680025 + 0.87520660973958 + 0.86338455693783 + 0.85117255908540 + 0.83870499308028 + 0.82614476692758 + 0.81365598535220 + 0.80747716044797 + 0.80136197745469 + 0.79531808214503 + 0.78934868014926 + 0.78345238044220 + 0.77762327671975 + 0.77185135012432 + 0.76612326612398 + 0.76042345318946 + 0.75473252632091 + 0.74898152495585 + 0.74296982383481 + 0.73658797742942 + 0.72981552571359 + 0.72262462231747 + 0.71501915176181 + 0.70701024412905 + 0.69861542471308 + 0.68985767205807 + 0.68076439695644 + 0.67136414845851 + 0.66164590944872 + 0.65163448238319 + 0.64135721008904 + 0.63084491779109 + 0.62013333285943 + 0.60926463652618 + 0.59826647553027 + 0.58716762384771 + 0.57602121389073 + 0.56488275453479 + 0.55380500208756 + 0.99490291181345 + 0.99490378023337 + 0.99490392495868 + 0.99490409395560 + 0.99490429135615 + 0.99490452201195 + 0.99490479164177 + 0.99490510699290 + 0.99490547610968 + 0.99490590892042 + 0.99490641876004 + 0.99490702382317 + 0.99490774592263 + 0.99490861003457 + 0.99490964582796 + 0.99491088929062 + 0.99491238436070 + 0.99491418485218 + 0.99491635876736 + 0.99491899233135 + 0.99492219036404 + 0.99492608370717 + 0.99493083631829 + 0.99493665460143 + 0.99494380079499 + 0.99495261727331 + 0.99496356845977 + 0.99497726332908 + 0.99499447071005 + 0.99501617795548 + 0.99504373289362 + 0.99507890279870 + 0.99512403846427 + 0.99518231801419 + 0.99525809699988 + 0.99535745186013 + 0.99548906591571 + 0.99566577090894 + 0.99590769392437 + 0.99624887310040 + 0.99675373379952 + 0.99757791757565 + 1.00000000000000 + 0.99726551337550 + 0.99586947997481 + 0.99463696677404 + 0.99343254302882 + 0.99219751339588 + 0.99090378464612 + 0.98952836056826 + 0.98804730066436 + 0.98643830189786 + 0.98468016272527 + 0.98275142726445 + 0.98062718992982 + 0.97827920351419 + 0.97567525359332 + 0.97277693834943 + 0.96954039505745 + 0.96591795374655 + 0.96185786109992 + 0.95729908721117 + 0.95217831399070 + 0.94644342477415 + 0.94005109904241 + 0.93296097673928 + 0.92514433857903 + 0.91658467043565 + 0.90728082247551 + 0.89725163567607 + 0.88654118283497 + 0.87522331967106 + 0.86339978366229 + 0.85118643774786 + 0.83871764603485 + 0.82615631030882 + 0.81366653086663 + 0.80748724660116 + 0.80137163000742 + 0.79532732579868 + 0.78935753837500 + 0.78346087531770 + 0.77763142875412 + 0.77185917811273 + 0.76613078704371 + 0.76043068215796 + 0.75473947647181 + 0.74898820483845 + 0.74297623093511 + 0.73659410399554 + 0.72982136385940 + 0.72263016397356 + 0.71502439035095 + 0.70701517500989 + 0.69862004551537 + 0.68986198288992 + 0.68076840046412 + 0.67136784969920 + 0.66164931433713 + 0.65163759881690 + 0.64136004775423 + 0.63084748798506 + 0.62013564832444 + 0.60926671131433 + 0.59826832442369 + 0.58716926228200 + 0.57602265829844 + 0.56488402218341 + 0.55380611077431 + 0.99428511425266 + 0.99428586294596 + 0.99428598771375 + 0.99428613340231 + 0.99428630357457 + 0.99428650241363 + 0.99428673484350 + 0.99428700668039 + 0.99428732485306 + 0.99428769790791 + 0.99428813730430 + 0.99428865864506 + 0.99428928063617 + 0.99429002469803 + 0.99429091627326 + 0.99429198621597 + 0.99429327218039 + 0.99429482026832 + 0.99429668868913 + 0.99429895120427 + 0.99430169745679 + 0.99430503927573 + 0.99430911669663 + 0.99431410588194 + 0.99432023042139 + 0.99432778187838 + 0.99433715513503 + 0.99434886711542 + 0.99436356899649 + 0.99438209458006 + 0.99440557811288 + 0.99443549929777 + 0.99447381324497 + 0.99452313974919 + 0.99458702620448 + 0.99467034049523 + 0.99477988044723 + 0.99492536675906 + 0.99512134556969 + 0.99539069170854 + 0.99577165384001 + 0.99633726030609 + 0.99726551337550 + 1.00000000000000 + 0.99691745698033 + 0.99535531748081 + 0.99397697979850 + 0.99263024704653 + 0.99125746900386 + 0.98982271217820 + 0.98829530382407 + 0.98664913175081 + 0.98486066689968 + 0.98290693661663 + 0.98076196459243 + 0.97839671481124 + 0.97577835174535 + 0.97286794813324 + 0.96962119723369 + 0.96599006298985 + 0.96192249187429 + 0.95735719564611 + 0.95223066419877 + 0.94649066503911 + 0.94009379402803 + 0.93299961627365 + 0.92517935080986 + 0.91661643045872 + 0.90730966018282 + 0.89727784267673 + 0.88656501780797 + 0.87524501250660 + 0.86341953831919 + 0.85120443374160 + 0.83873404516218 + 0.82617126557268 + 0.81368018908003 + 0.80750030824197 + 0.80138412885151 + 0.79533929421187 + 0.78936900709522 + 0.78347187322971 + 0.77764198265515 + 0.77186931252793 + 0.76614052408173 + 0.76044004146934 + 0.75474847507033 + 0.74899685374254 + 0.74298452672220 + 0.73660203641049 + 0.72982892246750 + 0.72263733811606 + 0.71503117134479 + 0.70702155675568 + 0.69862602494155 + 0.68986756022274 + 0.68077357931747 + 0.67137263685476 + 0.66165371772608 + 0.65164162893211 + 0.64136371738529 + 0.63085081196900 + 0.62013864331847 + 0.60926939561858 + 0.59827071724190 + 0.58717138360190 + 0.57602452936157 + 0.56488566526841 + 0.55380754881042 + 0.99358517268136 + 0.99358581785084 + 0.99358592535890 + 0.99358605089182 + 0.99358619751725 + 0.99358636883782 + 0.99358656909391 + 0.99358680329553 + 0.99358707740184 + 0.99358739877235 + 0.99358777725163 + 0.99358822624049 + 0.99358876179106 + 0.99358940229014 + 0.99359016956903 + 0.99359109009688 + 0.99359219615880 + 0.99359352727504 + 0.99359513330998 + 0.99359707742050 + 0.99359943632663 + 0.99360230568917 + 0.99360580522429 + 0.99361008542702 + 0.99361533715907 + 0.99362180906746 + 0.99362983756019 + 0.99363986245550 + 0.99365243683742 + 0.99366826729296 + 0.99368831263864 + 0.99371381899978 + 0.99374642475631 + 0.99378831111299 + 0.99384240597306 + 0.99391267989749 + 0.99400458811208 + 0.99412575564313 + 0.99428723766930 + 0.99450562264099 + 0.99480662673120 + 0.99523358389693 + 0.99586947997481 + 0.99691745698033 + 1.00000000000000 + 0.99653761615501 + 0.99478707589206 + 0.99324478235481 + 0.99174689344088 + 0.99022354458231 + 0.98862940890922 + 0.98693099248847 + 0.98510060442898 + 0.98311271979962 + 0.98093965278956 + 0.97855115936403 + 0.97591348529328 + 0.97298694808502 + 0.96972661554508 + 0.96608394316745 + 0.96200646528449 + 0.95743254312789 + 0.95229840807062 + 0.94655167223254 + 0.94014881958202 + 0.93304931531834 + 0.92522429609969 + 0.91665712378665 + 0.90734654269356 + 0.89731130395168 + 0.88659540284982 + 0.87527262714697 + 0.86344465294376 + 0.85122728535056 + 0.83875484636553 + 0.82619021647665 + 0.81369748093894 + 0.80751683811010 + 0.80139994053688 + 0.79535442964611 + 0.78938350604953 + 0.78348577302587 + 0.77765531788965 + 0.77188211480816 + 0.76615282186857 + 0.76045186000837 + 0.75475983619496 + 0.74900777158514 + 0.74299499699364 + 0.73661204610642 + 0.72983845836508 + 0.72264638672149 + 0.71503972172181 + 0.70702960130106 + 0.69863355996463 + 0.68987458629070 + 0.68078010134872 + 0.67137866382782 + 0.66165926007563 + 0.65164670032325 + 0.64136833434607 + 0.63085499354365 + 0.62014241079091 + 0.60927277227143 + 0.59827372742696 + 0.58717405260080 + 0.57602688397100 + 0.56488773354323 + 0.55380935956664 + 0.99279925772045 + 0.99279981348585 + 0.99279990608819 + 0.99280001421276 + 0.99280014050130 + 0.99280028805244 + 0.99280046051980 + 0.99280066220771 + 0.99280089824860 + 0.99280117497017 + 0.99280150084236 + 0.99280188738685 + 0.99280234840639 + 0.99280289970274 + 0.99280356003422 + 0.99280435212900 + 0.99280530370820 + 0.99280644869107 + 0.99280782985511 + 0.99280950136298 + 0.99281152897447 + 0.99281399464485 + 0.99281700088054 + 0.99282067646386 + 0.99282518459856 + 0.99283073777376 + 0.99283762332688 + 0.99284621659166 + 0.99285698884572 + 0.99287054107458 + 0.99288768745950 + 0.99290948314673 + 0.99293731035208 + 0.99297300057421 + 0.99301899687366 + 0.99307858435111 + 0.99315622471188 + 0.99325805584868 + 0.99339278819035 + 0.99357309411495 + 0.99381769037885 + 0.99415584846803 + 0.99463696677404 + 0.99535531748081 + 0.99653761615501 + 1.00000000000000 + 0.99611129356916 + 0.99415120771890 + 0.99243540396886 + 0.99077255945969 + 0.98907929110516 + 0.98730604784095 + 0.98541706282585 + 0.98338224414111 + 0.98117104290040 + 0.97875129314276 + 0.97608783999108 + 0.97313989062533 + 0.96986161719013 + 0.96620376084387 + 0.96211328654138 + 0.95752808000663 + 0.95238402528821 + 0.94662852534542 + 0.94021791362768 + 0.93311152167965 + 0.92528037593203 + 0.91670774317670 + 0.90739228628887 + 0.89735268692299 + 0.88663288016933 + 0.87530660079456 + 0.86347547698884 + 0.85125526892445 + 0.83878026540897 + 0.82621332905158 + 0.81371853213811 + 0.80753694479537 + 0.80141915838522 + 0.79537281182206 + 0.78940110288056 + 0.78350263165495 + 0.77767148193507 + 0.77189762408140 + 0.76616771216825 + 0.76046616306246 + 0.75477357943568 + 0.74902097290273 + 0.74300765167490 + 0.73662413876899 + 0.72984997336800 + 0.72265730812576 + 0.71505003673121 + 0.70703930121148 + 0.69864264086718 + 0.68988304948333 + 0.68078795342335 + 0.67138591630530 + 0.66166592621816 + 0.65165279726089 + 0.64137388260689 + 0.63086001662787 + 0.62014693480396 + 0.60927682564580 + 0.59827733980044 + 0.58717725465780 + 0.57602970814546 + 0.56489021371085 + 0.55381153047808 + 0.99191818784395 + 0.99191866633841 + 0.99191874605643 + 0.99191883913389 + 0.99191894784244 + 0.99191907484956 + 0.99191922329317 + 0.99191939687601 + 0.99191960001396 + 0.99191983814131 + 0.99192011854777 + 0.99192045115829 + 0.99192084785487 + 0.99192132223101 + 0.99192189042084 + 0.99192257196110 + 0.99192339067741 + 0.99192437570660 + 0.99192556379248 + 0.99192700144879 + 0.99192874511085 + 0.99193086508953 + 0.99193344926174 + 0.99193660797415 + 0.99194048099264 + 0.99194525020489 + 0.99195116157419 + 0.99195853619659 + 0.99196777668803 + 0.99197939568334 + 0.99199408701158 + 0.99201274784694 + 0.99203655021849 + 0.99206704173351 + 0.99210627726606 + 0.99215700300347 + 0.99222291795753 + 0.99230905369400 + 0.99242244605732 + 0.99257312027791 + 0.99277541548278 + 0.99305072369023 + 0.99343254302882 + 0.99397697979850 + 0.99478707589206 + 0.99611129356916 + 1.00000000000000 + 0.99563215690209 + 0.99344950052668 + 0.99154347062347 + 0.98969399627627 + 0.98780951763989 + 0.98583656754283 + 0.98373613451488 + 0.98147254277586 + 0.97901040313326 + 0.97631233443215 + 0.97333585780318 + 0.97003383034746 + 0.96635596992164 + 0.96224844305208 + 0.95764848371138 + 0.95249150535012 + 0.94672462657667 + 0.94030397636276 + 0.93318870612293 + 0.92534969386423 + 0.91677007839156 + 0.90744841275827 + 0.89740328476530 + 0.88667854810856 + 0.87534786594964 + 0.86351280189891 + 0.85128905590869 + 0.83881087180878 + 0.82624108674830 + 0.81374375402497 + 0.80756100823244 + 0.80144213374709 + 0.79539476611822 + 0.78942209938239 + 0.78352272950384 + 0.77769073575197 + 0.77191608364632 + 0.76618542220159 + 0.76048316317679 + 0.75478990387886 + 0.74903664427275 + 0.74302266523043 + 0.73663847693045 + 0.72986361827236 + 0.72267024156976 + 0.71506224431261 + 0.70705077344564 + 0.69865337401734 + 0.68989304602833 + 0.68079722214971 + 0.67139447183435 + 0.66167378519526 + 0.65165998086174 + 0.64138041595004 + 0.63086592824616 + 0.62015225620934 + 0.60928159098793 + 0.59828158453899 + 0.58718101538415 + 0.57603302342898 + 0.56489312374330 + 0.55381407640478 + 0.99093189260093 + 0.99093230432244 + 0.99093237290562 + 0.99093245298116 + 0.99093254649877 + 0.99093265575119 + 0.99093278343611 + 0.99093293273557 + 0.99093310743483 + 0.99093331221384 + 0.99093355334331 + 0.99093383937773 + 0.99093418056195 + 0.99093458860108 + 0.99093507737825 + 0.99093566370544 + 0.99093636807402 + 0.99093721553494 + 0.99093823768435 + 0.99093947451459 + 0.99094097451665 + 0.99094279806528 + 0.99094502059924 + 0.99094773677869 + 0.99095106643632 + 0.99095516549872 + 0.99096024491126 + 0.99096657996522 + 0.99097451537257 + 0.99098448943414 + 0.99099709513852 + 0.99101309787665 + 0.99103349538535 + 0.99105960169142 + 0.99109315557085 + 0.99113647026458 + 0.99119264285498 + 0.99126585196441 + 0.99136188086504 + 0.99148885314736 + 0.99165813574483 + 0.99188616886839 + 0.99219751339588 + 0.99263024704653 + 0.99324478235481 + 0.99415120771890 + 0.99563215690209 + 1.00000000000000 + 0.99510741662395 + 0.99267824550503 + 0.99055596683617 + 0.98849599079146 + 0.98639809303749 + 0.98420357009084 + 0.98186671692621 + 0.97934636287928 + 0.97660139835209 + 0.97358667824180 + 0.97025306713454 + 0.96654878046738 + 0.96241884337314 + 0.95779958367102 + 0.95262576970025 + 0.94684412862246 + 0.94041050835183 + 0.93328381541966 + 0.92543472652996 + 0.91684620720170 + 0.90751666182432 + 0.89746455106223 + 0.88673361844289 + 0.87539743043028 + 0.86355746379645 + 0.85132933807488 + 0.83884723636318 + 0.82627395973444 + 0.81377353386011 + 0.80758938004605 + 0.80146918612581 + 0.79542058313378 + 0.78944676018341 + 0.78354630787773 + 0.77771329971767 + 0.77193769508683 + 0.76620613666142 + 0.76050302983427 + 0.75480896527017 + 0.74905492886460 + 0.74304016889366 + 0.73665518029637 + 0.72987950167484 + 0.72268528497652 + 0.71507643218885 + 0.70706409605801 + 0.69866582837287 + 0.68990463639733 + 0.68080796014676 + 0.67140437583525 + 0.66168287585069 + 0.65166828400651 + 0.64138796189706 + 0.63087275114305 + 0.62015839351574 + 0.60928708307580 + 0.59828647316035 + 0.58718534347197 + 0.57603683608391 + 0.56489646784352 + 0.55381699984947 + 0.98983536514082 + 0.98983571928403 + 0.98983577826688 + 0.98983584712929 + 0.98983592754855 + 0.98983602149079 + 0.98983613127538 + 0.98983625963270 + 0.98983640981533 + 0.98983658583860 + 0.98983679310842 + 0.98983703900963 + 0.98983733238697 + 0.98983768333190 + 0.98983810381202 + 0.98983860830522 + 0.98983921446283 + 0.98983994385385 + 0.98984082368619 + 0.98984188841301 + 0.98984317976355 + 0.98984474968064 + 0.98984666302631 + 0.98984900115182 + 0.98985186699095 + 0.98985539448927 + 0.98985976502895 + 0.98986521529653 + 0.98987204125291 + 0.98988061872311 + 0.98989145621961 + 0.98990520909962 + 0.98992273019738 + 0.98994514048287 + 0.98997391944880 + 0.99001102874199 + 0.99005908300441 + 0.99012158899491 + 0.99020336521674 + 0.99031111354117 + 0.99045406857766 + 0.99064530967898 + 0.99090378464612 + 0.99125746900386 + 0.99174689344088 + 0.99243540396886 + 0.99344950052668 + 0.99510741662395 + 1.00000000000000 + 0.99452332623841 + 0.99181527096341 + 0.98945000373803 + 0.98715583677333 + 0.98482196779935 + 0.98238063553067 + 0.97977940433245 + 0.97697052435861 + 0.97390443388640 + 0.97052887099883 + 0.96678978659547 + 0.96263054294000 + 0.95798619348506 + 0.95279061508685 + 0.94698999045181 + 0.94053977739220 + 0.93339854763884 + 0.92553670383609 + 0.91693697650524 + 0.90759756874097 + 0.89753676923520 + 0.88679817293949 + 0.87545521652983 + 0.86360926104702 + 0.85137581984216 + 0.83888899481305 + 0.82631153615873 + 0.81380742938786 + 0.80762160808582 + 0.80149985644353 + 0.79544979945454 + 0.78947461976846 + 0.78357290109919 + 0.77773870964526 + 0.77196199716724 + 0.76622939853256 + 0.76052531136411 + 0.75483031830544 + 0.74907538877721 + 0.74305973355578 + 0.73667383017846 + 0.72989721695363 + 0.72270204542677 + 0.71509222267858 + 0.70707890794191 + 0.69867966049985 + 0.68991749566065 + 0.68081986152567 + 0.67141534171443 + 0.66169293099286 + 0.65167745880550 + 0.64139629156907 + 0.63088027499240 + 0.62016515435074 + 0.60929312675755 + 0.59829184690177 + 0.58719009563842 + 0.57604101730925 + 0.56490013060684 + 0.55382019766282 + 0.98861952425537 + 0.98861982886189 + 0.98861987958634 + 0.98861993880404 + 0.98862000795295 + 0.98862008872622 + 0.98862018311354 + 0.98862029345563 + 0.98862042254747 + 0.98862057383997 + 0.98862075198852 + 0.98862096338650 + 0.98862121567986 + 0.98862151758892 + 0.98862187943504 + 0.98862231371598 + 0.98862283565819 + 0.98862346385762 + 0.98862422179616 + 0.98862513920916 + 0.98862625208693 + 0.98862760519866 + 0.98862925443251 + 0.98863126984828 + 0.98863374005271 + 0.98863678037472 + 0.98864054722894 + 0.98864524473403 + 0.98865112775768 + 0.98865851954213 + 0.98866785767702 + 0.98867970535589 + 0.98869479445328 + 0.98871408545973 + 0.98873884354619 + 0.98877074188944 + 0.98881200312782 + 0.98886559507427 + 0.98893557507851 + 0.98902754767390 + 0.98914915074600 + 0.98931104612640 + 0.98952836056826 + 0.98982271217820 + 0.99022354458231 + 0.99077255945969 + 0.99154347062347 + 0.99267824550503 + 0.99452332623841 + 1.00000000000000 + 0.99385972107851 + 0.99083955164507 + 0.98820459411616 + 0.98565221825267 + 0.98305646681125 + 0.98034021119959 + 0.97744285088046 + 0.97430704396569 + 0.97087538920258 + 0.96709030028681 + 0.96289264888401 + 0.95821565814526 + 0.95299195201275 + 0.94716694385284 + 0.94069554283131 + 0.93353585858314 + 0.92565791814587 + 0.91704413203102 + 0.90769243024840 + 0.89762086884346 + 0.88687284262151 + 0.87552161446965 + 0.86366839174664 + 0.85142854822914 + 0.83893607774634 + 0.82635365933740 + 0.81384522079216 + 0.80765744853828 + 0.80153388122535 + 0.79548213575576 + 0.78950538631121 + 0.78360220775869 + 0.77776665710361 + 0.77198867664333 + 0.76625489169557 + 0.76054969047068 + 0.75485364600077 + 0.74909770872348 + 0.74308104712979 + 0.73669411930196 + 0.72991646326372 + 0.72272023012118 + 0.71510933252674 + 0.70709493674399 + 0.69869461009992 + 0.68993137647614 + 0.68083269255533 + 0.67142714976997 + 0.66170374520510 + 0.65168731418895 + 0.64140522814198 + 0.63088833697277 + 0.62017238951563 + 0.60929958594978 + 0.59829758221823 + 0.58719516022651 + 0.57604546659900 + 0.56490402187730 + 0.55382358918528 + 0.98726970102119 + 0.98726996312789 + 0.98727000676541 + 0.98727005770725 + 0.98727011718925 + 0.98727018666570 + 0.98727026784273 + 0.98727036273361 + 0.98727047373538 + 0.98727060381377 + 0.98727075699071 + 0.98727093880247 + 0.98727115587688 + 0.98727141575603 + 0.98727172736373 + 0.98727210150071 + 0.98727255132415 + 0.98727309290297 + 0.98727374653225 + 0.98727453793808 + 0.98727549821639 + 0.98727666604583 + 0.98727808967607 + 0.98727982956657 + 0.98728196215673 + 0.98728458698676 + 0.98728783930093 + 0.98729189564538 + 0.98729697612634 + 0.98730335954933 + 0.98731142367507 + 0.98732165410442 + 0.98733468110019 + 0.98735133078540 + 0.98737268962894 + 0.98740019157607 + 0.98743573652526 + 0.98748185275534 + 0.98754198439892 + 0.98762086607573 + 0.98772489785362 + 0.98786292178188 + 0.98804730066436 + 0.98829530382407 + 0.98862940890922 + 0.98907929110516 + 0.98969399627627 + 0.99055596683617 + 0.99181527096341 + 0.99385972107851 + 1.00000000000000 + 0.99310431677040 + 0.98973672073150 + 0.98680406663773 + 0.98396554548619 + 0.98107890800571 + 0.97805551084926 + 0.97482308592986 + 0.97131522887227 + 0.96746855003197 + 0.96322004012052 + 0.95850020522329 + 0.95323985866834 + 0.94738330126150 + 0.94088465597090 + 0.93370138495197 + 0.92580299442506 + 0.91717145541350 + 0.90780432524369 + 0.89771934395060 + 0.88695963592346 + 0.87559823073558 + 0.86373613107388 + 0.85148852666129 + 0.83898926730831 + 0.82640093326496 + 0.81388737057995 + 0.80769730496210 + 0.80157161203087 + 0.79551789786559 + 0.78953932551410 + 0.78363445842146 + 0.77779734192879 + 0.77201790651691 + 0.76628276572008 + 0.76057629625006 + 0.75487905954540 + 0.74912198407272 + 0.74310419061464 + 0.73671611548232 + 0.72993729641630 + 0.72273988401018 + 0.71512779699276 + 0.70711220917875 + 0.69871069645164 + 0.68994629174080 + 0.68084646072821 + 0.67143980297910 + 0.66171531774179 + 0.65169784640617 + 0.64141476548126 + 0.63089692911479 + 0.62018008967168 + 0.60930645035105 + 0.59830366817776 + 0.58720052595809 + 0.57605017256196 + 0.56490813034537 + 0.55382716335107 + 0.98576979385882 + 0.98577001962063 + 0.98577005720043 + 0.98577010106557 + 0.98577015228194 + 0.98577021209907 + 0.98577028198265 + 0.98577036366370 + 0.98577045920308 + 0.98577057114882 + 0.98577070298052 + 0.98577085950619 + 0.98577104648024 + 0.98577127043920 + 0.98577153911485 + 0.98577186185841 + 0.98577225006292 + 0.98577271763808 + 0.98577328217156 + 0.98577396596596 + 0.98577479595536 + 0.98577580562349 + 0.98577703673224 + 0.98577854157715 + 0.98578038625094 + 0.98578265688408 + 0.98578547073905 + 0.98578898096213 + 0.98579337818214 + 0.98579890356001 + 0.98580588422480 + 0.98581474019612 + 0.98582601602438 + 0.98584042473723 + 0.98585890285696 + 0.98588268439228 + 0.98591340093934 + 0.98595321794025 + 0.98600507780095 + 0.98607301169112 + 0.98616243522352 + 0.98628077412272 + 0.98643830189786 + 0.98664913175081 + 0.98693099248847 + 0.98730604784095 + 0.98780951763989 + 0.98849599079146 + 0.98945000373803 + 0.99083955164507 + 0.99310431677040 + 1.00000000000000 + 0.99224624030084 + 0.98849343505057 + 0.98523086654335 + 0.98207544539737 + 0.97886486532528 + 0.97549454812376 + 0.97188090397636 + 0.96795038779041 + 0.96363362650483 + 0.95885691846992 + 0.95354836658538 + 0.94765061605939 + 0.94111663712158 + 0.93390296744978 + 0.92597838044327 + 0.91732423678687 + 0.90793758104255 + 0.89783572142937 + 0.88706141526369 + 0.87568737757258 + 0.86381433733274 + 0.85155724043051 + 0.83904974426392 + 0.82645429266657 + 0.81393461718463 + 0.80774183367402 + 0.80161363251707 + 0.79555760530076 + 0.78957690038530 + 0.78367006638932 + 0.77783113372620 + 0.77205001797498 + 0.76631331798480 + 0.76060539628271 + 0.75490680016605 + 0.74914843247140 + 0.74312935985321 + 0.73673999413779 + 0.72995987275094 + 0.72276114566218 + 0.71514773821092 + 0.70713083229541 + 0.69872801285874 + 0.68996232233329 + 0.68086123576517 + 0.67145336110442 + 0.66172769949276 + 0.65170909847685 + 0.64142493967447 + 0.63090608140801 + 0.62018827948125 + 0.60931373998547 + 0.59831012078674 + 0.58720620538219 + 0.57605514480589 + 0.56491246314786 + 0.55383092526488 + 0.98410291803985 + 0.98410311282920 + 0.98410314524649 + 0.98410318308450 + 0.98410322726009 + 0.98410327884750 + 0.98410333911127 + 0.98410340954047 + 0.98410349190790 + 0.98410358841203 + 0.98410370206584 + 0.98410383705524 + 0.98410399838815 + 0.98410419174793 + 0.98410442384409 + 0.98410470279826 + 0.98410503849995 + 0.98410544301770 + 0.98410593163403 + 0.98410652373822 + 0.98410724272527 + 0.98410811766210 + 0.98410918479028 + 0.98411048947003 + 0.98411208901186 + 0.98411405815079 + 0.98411649887647 + 0.98411954446698 + 0.98412336053649 + 0.98412815633752 + 0.98413421609278 + 0.98414190430942 + 0.98415169308316 + 0.98416420000481 + 0.98418023533270 + 0.98420086520926 + 0.98422749683543 + 0.98426199375913 + 0.98430688358188 + 0.98436562081700 + 0.98444282392275 + 0.98454478992937 + 0.98468016272527 + 0.98486066689968 + 0.98510060442898 + 0.98541706282585 + 0.98583656754283 + 0.98639809303749 + 0.98715583677333 + 0.98820459411616 + 0.98973672073150 + 0.99224624030084 + 1.00000000000000 + 0.99127419749142 + 0.98709328314627 + 0.98346642368321 + 0.97995964411825 + 0.97638414586237 + 0.97261931539904 + 0.96857223336352 + 0.96416238088869 + 0.95930918351712 + 0.95393650628931 + 0.94798444368335 + 0.94140422816211 + 0.93415104715841 + 0.92619262436492 + 0.91750946116856 + 0.90809788933829 + 0.89797462249248 + 0.88718191667584 + 0.87579206069007 + 0.86390541572906 + 0.85163660309507 + 0.83911902236858 + 0.82651492968745 + 0.81398789740153 + 0.80779186508043 + 0.80166067921847 + 0.79560191198064 + 0.78961869229927 + 0.78370954941050 + 0.77786849450209 + 0.77208542418082 + 0.76634691882346 + 0.76063732325926 + 0.75493716736472 + 0.74917732381212 + 0.74315679745649 + 0.73676597240022 + 0.72998438566628 + 0.72278418644076 + 0.71516930721445 + 0.70715093852444 + 0.69874667485972 + 0.68997956854592 + 0.68087710430293 + 0.67146789862277 + 0.66174095412104 + 0.65172112448896 + 0.64143579636231 + 0.63091583208050 + 0.62019699068470 + 0.60932148093930 + 0.59831696122309 + 0.58721221543700 + 0.57606039664466 + 0.56491703054581 + 0.55383488265097 + 0.98225076178639 + 0.98225093027202 + 0.98225095830536 + 0.98225099102336 + 0.98225102921855 + 0.98225107381919 + 0.98225112591649 + 0.98225118679446 + 0.98225125798021 + 0.98225134137800 + 0.98225143960177 + 0.98225155631025 + 0.98225169587448 + 0.98225186324606 + 0.98225206427608 + 0.98225230603042 + 0.98225259712112 + 0.98225294805948 + 0.98225337216405 + 0.98225388635021 + 0.98225451100407 + 0.98225527144743 + 0.98225619923511 + 0.98225733384662 + 0.98225872514500 + 0.98226043820533 + 0.98226256206462 + 0.98226521313005 + 0.98226853581939 + 0.98227271235982 + 0.98227799063386 + 0.98228468817227 + 0.98229321583172 + 0.98230411062362 + 0.98231807637089 + 0.98233603802647 + 0.98235921457892 + 0.98238921732541 + 0.98242822883110 + 0.98247922686315 + 0.98254617682133 + 0.98263446187021 + 0.98275142726445 + 0.98290693661663 + 0.98311271979962 + 0.98338224414111 + 0.98373613451488 + 0.98420357009084 + 0.98482196779935 + 0.98565221825267 + 0.98680406663773 + 0.98849343505057 + 0.99127419749142 + 1.00000000000000 + 0.99017279396182 + 0.98551964465251 + 0.98149124191400 + 0.97759037590183 + 0.97360035883963 + 0.96938653021208 + 0.96484705934105 + 0.95988935244115 + 0.95443027890698 + 0.94840583292871 + 0.94176453733010 + 0.93445955250405 + 0.92645706540824 + 0.91773634702136 + 0.90829272543037 + 0.89814208748189 + 0.88732599949826 + 0.87591616915886 + 0.86401246077688 + 0.85172906137662 + 0.83919902397169 + 0.82658434696074 + 0.81404838248480 + 0.80784843302764 + 0.80171366514882 + 0.79565162496803 + 0.78966541560730 + 0.78375354087309 + 0.77790998698586 + 0.77212462622525 + 0.76638401549248 + 0.76067247733879 + 0.75497051995389 + 0.74920898017071 + 0.74318679182082 + 0.73679430737340 + 0.73001106328080 + 0.72280920767223 + 0.71519268077063 + 0.70717268227469 + 0.69876681666690 + 0.68999814648832 + 0.68089416632241 + 0.67148350123090 + 0.66175515469205 + 0.65173398638643 + 0.64144738773360 + 0.63092622478896 + 0.62020625949756 + 0.60932970296916 + 0.59832421365334 + 0.58721857547770 + 0.57606594333046 + 0.56492184433282 + 0.55383904444642 + 0.98019088127523 + 0.98019102747683 + 0.98019105179789 + 0.98019108018083 + 0.98019111331445 + 0.98019115199807 + 0.98019119718062 + 0.98019124997028 + 0.98019131169293 + 0.98019138399567 + 0.98019146916116 + 0.98019157039353 + 0.98019169152272 + 0.98019183688305 + 0.98019201158900 + 0.98019222181637 + 0.98019247509373 + 0.98019278060877 + 0.98019315001088 + 0.98019359812217 + 0.98019414277394 + 0.98019480611075 + 0.98019561572335 + 0.98019660611247 + 0.98019782083652 + 0.98019931679109 + 0.98020117202968 + 0.98020348866977 + 0.98020639317497 + 0.98021004491406 + 0.98021466100971 + 0.98022051927734 + 0.98022797882366 + 0.98023750865312 + 0.98024972285941 + 0.98026542755500 + 0.98028568364444 + 0.98031189115727 + 0.98034594459864 + 0.98039042540540 + 0.98044875981012 + 0.98052558302705 + 0.98062718992982 + 0.98076196459243 + 0.98093965278956 + 0.98117104290040 + 0.98147254277586 + 0.98186671692621 + 0.98238063553067 + 0.98305646681125 + 0.98396554548619 + 0.98523086654335 + 0.98709328314627 + 0.99017279396182 + 1.00000000000000 + 0.98893055659833 + 0.98375876986998 + 0.97928267005352 + 0.97493496857636 + 0.97047250176769 + 0.96574731264965 + 0.96064378077398 + 0.95506639069235 + 0.94894418348740 + 0.94222127524034 + 0.93484767705662 + 0.92678726359451 + 0.91801750544926 + 0.90853229339457 + 0.89834634960883 + 0.88750028159835 + 0.87606499808473 + 0.86413968724672 + 0.85183795125728 + 0.83929237512640 + 0.82666460333235 + 0.81411768420399 + 0.80791296413678 + 0.80177385425084 + 0.79570786564173 + 0.78971806705142 + 0.78380292870592 + 0.77795640420528 + 0.77216833433572 + 0.76642524590503 + 0.76071143311800 + 0.75500737687886 + 0.74924387096858 + 0.74321976682859 + 0.73682538046816 + 0.73004024745994 + 0.72283651448170 + 0.71521813007304 + 0.70719630362426 + 0.69878865000693 + 0.69001824222070 + 0.68091258478471 + 0.67150031120416 + 0.66177042494731 + 0.65174779136991 + 0.64145980625953 + 0.63093733892062 + 0.62021615371486 + 0.60933846362268 + 0.59833192659742 + 0.58722532609548 + 0.57607181855144 + 0.56492693225829 + 0.55384343334880 + 0.97789699989396 + 0.97789712726535 + 0.97789714844848 + 0.97789717316914 + 0.97789720202333 + 0.97789723571124 + 0.97789727505334 + 0.97789732101364 + 0.97789737474483 + 0.97789743768266 + 0.97789751181993 + 0.97789759998261 + 0.97789770554063 + 0.97789783230007 + 0.97789798475046 + 0.97789816832001 + 0.97789838961214 + 0.97789865669655 + 0.97789897981090 + 0.97789937199833 + 0.97789984893038 + 0.97790043006604 + 0.97790113963778 + 0.97790200793794 + 0.97790307319723 + 0.97790438540613 + 0.97790601331846 + 0.97790804693928 + 0.97791059756238 + 0.97791380524117 + 0.97791786109714 + 0.97792300939660 + 0.97792956557713 + 0.97793794128208 + 0.97794867501283 + 0.97796247287546 + 0.97798026298361 + 0.97800326826237 + 0.97803314229941 + 0.97807213605728 + 0.97812322856551 + 0.97819043870227 + 0.97827920351419 + 0.97839671481124 + 0.97855115936403 + 0.97875129314276 + 0.97901040313326 + 0.97934636287928 + 0.97977940433245 + 0.98034021119959 + 0.98107890800571 + 0.98207544539737 + 0.98346642368321 + 0.98551964465251 + 0.98893055659833 + 1.00000000000000 + 0.98753801743995 + 0.98179273148372 + 0.97681146267384 + 0.97195401719434 + 0.96695178351723 + 0.96163907528795 + 0.95589634995027 + 0.94964003590090 + 0.94280670077374 + 0.93534125441906 + 0.92720397439994 + 0.91836962650524 + 0.90883000031690 + 0.89859815090978 + 0.88771333619499 + 0.87624535554647 + 0.86429246962746 + 0.85196748751140 + 0.83940235914721 + 0.82675824257007 + 0.81419776748596 + 0.80798718506533 + 0.80184276470885 + 0.79577197036586 + 0.78977782480372 + 0.78385875371823 + 0.77800866782457 + 0.77221736685931 + 0.76647133872601 + 0.76075484125707 + 0.75504832069061 + 0.74928251856653 + 0.74325618994470 + 0.73685960839811 + 0.73007230811371 + 0.72286643370218 + 0.71524594258317 + 0.70722205431737 + 0.69881239445137 + 0.69004004653326 + 0.68093252489069 + 0.67151847110220 + 0.66178688743487 + 0.65176264434822 + 0.64147314134188 + 0.63094925027479 + 0.62022673722535 + 0.60934781639525 + 0.59834014448789 + 0.58723250386148 + 0.57607805211620 + 0.56493231836956 + 0.55384806857393 + 0.97533856031247 + 0.97533867180802 + 0.97533869034720 + 0.97533871198060 + 0.97533873723019 + 0.97533876670525 + 0.97533880112550 + 0.97533884133281 + 0.97533888832977 + 0.97533894337649 + 0.97533900822573 + 0.97533908537370 + 0.97533917780119 + 0.97533928887401 + 0.97533942254883 + 0.97533958361487 + 0.97533977790177 + 0.97534001252563 + 0.97534029653606 + 0.97534064146667 + 0.97534106116095 + 0.97534157280818 + 0.97534219780414 + 0.97534296288443 + 0.97534390178407 + 0.97534505865882 + 0.97534649438876 + 0.97534828874453 + 0.97535054018319 + 0.97535337245682 + 0.97535695471272 + 0.97536150289058 + 0.97536729558240 + 0.97537469607454 + 0.97538417917954 + 0.97539636684967 + 0.97541207559148 + 0.97543237974493 + 0.97545873109171 + 0.97549310438519 + 0.97553810643272 + 0.97559724566743 + 0.97567525359332 + 0.97577835174535 + 0.97591348529328 + 0.97608783999108 + 0.97631233443215 + 0.97660139835209 + 0.97697052435861 + 0.97744285088046 + 0.97805551084926 + 0.97886486532528 + 0.97995964411825 + 0.98149124191400 + 0.98375876986998 + 0.98753801743995 + 1.00000000000000 + 0.98598104984896 + 0.97959628297068 + 0.97403988364671 + 0.96859816133723 + 0.96297354379995 + 0.95699360079162 + 0.95054978257239 + 0.94356485878554 + 0.93597504428325 + 0.92773479102543 + 0.91881466975191 + 0.90920332069264 + 0.89891136596894 + 0.88797613528453 + 0.87646586973202 + 0.86447754599932 + 0.85212288979905 + 0.83953298494123 + 0.82686831979946 + 0.81429094747971 + 0.80807310867982 + 0.80192214638718 + 0.79584546096332 + 0.78984601357479 + 0.78392217065394 + 0.77806778627425 + 0.77227260637783 + 0.76652306824077 + 0.76080338268005 + 0.75509395157287 + 0.74932545251939 + 0.74329652710136 + 0.73689739906695 + 0.73010760038285 + 0.72289927266989 + 0.71527638268461 + 0.70725016046318 + 0.69883824231074 + 0.69006372212421 + 0.68095412359358 + 0.67153809564518 + 0.66180463769405 + 0.65177862439318 + 0.64148745796523 + 0.63096201181793 + 0.62023805277273 + 0.60935779535494 + 0.59834889406147 + 0.58724012934517 + 0.57608465945042 + 0.56493801387228 + 0.55385295792544 + 0.97247863324142 + 0.97247873136588 + 0.97247874767970 + 0.97247876671273 + 0.97247878892624 + 0.97247881485502 + 0.97247884513121 + 0.97247888049380 + 0.97247892182476 + 0.97247897022922 + 0.97247902725887 + 0.97247909513264 + 0.97247917650353 + 0.97247927435259 + 0.97247939219514 + 0.97247953427670 + 0.97247970577175 + 0.97247991299157 + 0.97248016397000 + 0.97248046897106 + 0.97248084028611 + 0.97248129318379 + 0.97248184665723 + 0.97248252443485 + 0.97248335645160 + 0.97248438191900 + 0.97248565505268 + 0.97248724693250 + 0.97248924515496 + 0.97249175967281 + 0.97249494102456 + 0.97249898118176 + 0.97250412756954 + 0.97251070260863 + 0.97251912732419 + 0.97252995264682 + 0.97254390100302 + 0.97256192167565 + 0.97258529676128 + 0.97261576916178 + 0.97265563426126 + 0.97270797509783 + 0.97277693834943 + 0.97286794813324 + 0.97298694808502 + 0.97313989062533 + 0.97333585780318 + 0.97358667824180 + 0.97390443388640 + 0.97430704396569 + 0.97482308592986 + 0.97549454812376 + 0.97638414586237 + 0.97759037590183 + 0.97928267005352 + 0.98179273148372 + 0.98598104984896 + 1.00000000000000 + 0.98424303917488 + 0.97713731922489 + 0.97091998511516 + 0.96480134072571 + 0.95846779678132 + 0.95175488682106 + 0.94455790800907 + 0.93679726662027 + 0.92841749504933 + 0.91938239524670 + 0.90967573757524 + 0.89930450589357 + 0.88830322224732 + 0.87673790639896 + 0.86470373705120 + 0.85231094655249 + 0.83968942975704 + 0.82699875026606 + 0.81440016616170 + 0.80817328138319 + 0.80201420271599 + 0.79593024461563 + 0.78992428549815 + 0.78399461266937 + 0.77813500506730 + 0.77233513774877 + 0.76658138173249 + 0.76085788667926 + 0.75514499726286 + 0.74937331218607 + 0.74334133846816 + 0.73693924083496 + 0.73014654769692 + 0.72293539630830 + 0.71530976300653 + 0.70728088836414 + 0.69886641919804 + 0.69008945916667 + 0.68097754042499 + 0.67155931803615 + 0.66182378635005 + 0.65179582284353 + 0.64150283105950 + 0.63097568454157 + 0.62025014954363 + 0.60936843971415 + 0.59835820612119 + 0.58724822629906 + 0.57609165845012 + 0.56494403185737 + 0.55385811062699 + 0.96927464230664 + 0.96927472916134 + 0.96927474359846 + 0.96927476044301 + 0.96927478009886 + 0.96927480304201 + 0.96927482982811 + 0.96927486111051 + 0.96927489766838 + 0.96927494047901 + 0.96927499092496 + 0.96927505098481 + 0.96927512303313 + 0.96927520972726 + 0.96927531420422 + 0.96927544025300 + 0.96927559248769 + 0.96927577653601 + 0.96927599957537 + 0.96927627078031 + 0.96927660113111 + 0.96927700425552 + 0.96927749711696 + 0.96927810088188 + 0.96927884225958 + 0.96927975626686 + 0.96928089143709 + 0.96928231144534 + 0.96928409465183 + 0.96928633927988 + 0.96928918002804 + 0.96929278847762 + 0.96929738557303 + 0.96930325900327 + 0.96931078412067 + 0.96932045159956 + 0.96933290410674 + 0.96934898502411 + 0.96936983288805 + 0.96939699465531 + 0.96943250324252 + 0.96947908425129 + 0.96954039505745 + 0.96962119723369 + 0.96972661554508 + 0.96986161719013 + 0.97003383034746 + 0.97025306713454 + 0.97052887099883 + 0.97087538920258 + 0.97131522887227 + 0.97188090397636 + 0.97261931539904 + 0.97360035883963 + 0.97493496857636 + 0.97681146267384 + 0.97959628297068 + 0.98424303917488 + 1.00000000000000 + 0.98230241003587 + 0.97437147408125 + 0.96738403913443 + 0.96049118131981 + 0.95337722824438 + 0.94587583131072 + 0.93787611184241 + 0.92930460259053 + 0.92011362992817 + 0.91027913466891 + 0.89980249053495 + 0.88871403207000 + 0.87707655263962 + 0.86498267606240 + 0.85254055240479 + 0.83987843069455 + 0.82715459128671 + 0.81452919334275 + 0.80829095229788 + 0.80212173294818 + 0.79602873344254 + 0.79001472071052 + 0.78407787606406 + 0.77821187834650 + 0.77240630878354 + 0.76664745117282 + 0.76091937512514 + 0.75520235108225 + 0.74942687953795 + 0.74339130679182 + 0.73698572694217 + 0.73018966277156 + 0.72297524512436 + 0.71534645981886 + 0.70731455764573 + 0.69889719520803 + 0.69011748480764 + 0.68100296556342 + 0.67158229682813 + 0.66184446494189 + 0.65181434826017 + 0.64151934968245 + 0.63099034100630 + 0.62026308615461 + 0.60937979634320 + 0.59836811765996 + 0.58725682343524 + 0.57609907095447 + 0.56495038853360 + 0.55386353834753 + 0.96568000377191 + 0.96568008111501 + 0.96568009396796 + 0.96568010896192 + 0.96568012645965 + 0.96568014687965 + 0.96568017072001 + 0.96568019855779 + 0.96568023108613 + 0.96568026917627 + 0.96568031406109 + 0.96568036752120 + 0.96568043168638 + 0.96568050894555 + 0.96568060211106 + 0.96568071457941 + 0.96568085048814 + 0.96568101488243 + 0.96568121421046 + 0.96568145671304 + 0.96568175224868 + 0.96568211305436 + 0.96568255434241 + 0.96568309510475 + 0.96568375929152 + 0.96568457832284 + 0.96568559587594 + 0.96568686928059 + 0.96568846897524 + 0.96569048315034 + 0.96569303292559 + 0.96569627242042 + 0.96570039990587 + 0.96570567335441 + 0.96571242904140 + 0.96572110612269 + 0.96573227913059 + 0.96574670104542 + 0.96576538794426 + 0.96578971977385 + 0.96582150622939 + 0.96586316967451 + 0.96591795374655 + 0.96599006298985 + 0.96608394316745 + 0.96620376084387 + 0.96635596992164 + 0.96654878046738 + 0.96678978659547 + 0.96709030028681 + 0.96746855003197 + 0.96795038779041 + 0.96857223336352 + 0.96938653021208 + 0.97047250176769 + 0.97195401719434 + 0.97403988364671 + 0.97713731922489 + 0.98230241003587 + 1.00000000000000 + 0.98012448130176 + 0.97123006243670 + 0.96335685504698 + 0.95560906671381 + 0.94765390821580 + 0.93931081125201 + 0.93047079499485 + 0.92106546262234 + 0.91105753289993 + 0.90043938773179 + 0.88923492315236 + 0.87750213295544 + 0.86532994168935 + 0.85282355283502 + 0.84010891203464 + 0.82734250646421 + 0.81468296973112 + 0.80843036848717 + 0.80224838663553 + 0.79614406439674 + 0.79012001805228 + 0.78417428636655 + 0.77830041431440 + 0.77248785827037 + 0.76672278661094 + 0.76098916354496 + 0.75526716252978 + 0.74948716076149 + 0.74344731096919 + 0.73703762179233 + 0.73023760724114 + 0.72301938875007 + 0.71538696101601 + 0.70735158414692 + 0.69893092319440 + 0.69014809724771 + 0.68103065011724 + 0.67160724277894 + 0.66186684968300 + 0.65183434738222 + 0.64153713548722 + 0.63100608153801 + 0.62027694483219 + 0.60939193212209 + 0.59837868256436 + 0.58726596367895 + 0.57610693070554 + 0.56495711003301 + 0.55386926101345 + 0.96164387337967 + 0.96164394265236 + 0.96164395416049 + 0.96164396758714 + 0.96164398325305 + 0.96164400153461 + 0.96164402287390 + 0.96164404779073 + 0.96164407690138 + 0.96164411098484 + 0.96164415115379 + 0.96164419901096 + 0.96164425648061 + 0.96164432571776 + 0.96164440925864 + 0.96164451016165 + 0.96164463215423 + 0.96164477978922 + 0.96164495887844 + 0.96164517686275 + 0.96164544263628 + 0.96164576723429 + 0.96164616437041 + 0.96164665115833 + 0.96164724917215 + 0.96164798673961 + 0.96164890333249 + 0.96165005079671 + 0.96165149273347 + 0.96165330866572 + 0.96165560797635 + 0.96165852969139 + 0.96166225249762 + 0.96166700869215 + 0.96167310081972 + 0.96168092357451 + 0.96169099270642 + 0.96170398329508 + 0.96172080590385 + 0.96174269666507 + 0.96177127340430 + 0.96180869833209 + 0.96185786109992 + 0.96192249187429 + 0.96200646528449 + 0.96211328654138 + 0.96224844305208 + 0.96241884337314 + 0.96263054294000 + 0.96289264888401 + 0.96322004012052 + 0.96363362650483 + 0.96416238088869 + 0.96484705934105 + 0.96574731264965 + 0.96695178351723 + 0.96859816133723 + 0.97091998511516 + 0.97437147408125 + 0.98012448130176 + 1.00000000000000 + 0.97764822358886 + 0.96763868079772 + 0.95878171071675 + 0.95010894713889 + 0.94125333483623 + 0.93202706599864 + 0.92232103416758 + 0.91207415818185 + 0.90126367186772 + 0.88990317459110 + 0.87804329424192 + 0.86576746451253 + 0.85317663583217 + 0.84039348129157 + 0.82757195653745 + 0.81486856279373 + 0.80859763459530 + 0.80239943913587 + 0.79628080128944 + 0.79024413285235 + 0.78428728002154 + 0.77840360779177 + 0.77258240548527 + 0.76680968778255 + 0.76106927917662 + 0.75534122546551 + 0.74955574736047 + 0.74351076161621 + 0.73709617196727 + 0.73029147900873 + 0.72306879045190 + 0.71543210862895 + 0.70739270144632 + 0.69896824030782 + 0.69018184842430 + 0.68106107112462 + 0.67163456735780 + 0.66189129461529 + 0.65185612405959 + 0.64155644851618 + 0.63102312796876 + 0.62029191409614 + 0.60940500655960 + 0.59839003509050 + 0.58727575934567 + 0.57611533107628 + 0.56496427351690 + 0.55387534207519 + 0.95710601810119 + 0.95710608046636 + 0.95710609082629 + 0.95710610290976 + 0.95710611700915 + 0.95710613346040 + 0.95710615266177 + 0.95710617507855 + 0.95710620126512 + 0.95710623192174 + 0.95710626805241 + 0.95710631111029 + 0.95710636284255 + 0.95710642519930 + 0.95710650047374 + 0.95710659143592 + 0.95710670145841 + 0.95710683466174 + 0.95710699630503 + 0.95710719313900 + 0.95710743321514 + 0.95710772652001 + 0.95710808546528 + 0.95710852552776 + 0.95710906621200 + 0.95710973314984 + 0.95711056213423 + 0.95711160020889 + 0.95711290499393 + 0.95711454843435 + 0.95711662963809 + 0.95711927441998 + 0.95712264431762 + 0.95712694917587 + 0.95713246202652 + 0.95713953868434 + 0.95714864353636 + 0.95716038361417 + 0.95717557733978 + 0.95719533527675 + 0.95722110799910 + 0.95725483125094 + 0.95729908721117 + 0.95735719564611 + 0.95743254312789 + 0.95752808000663 + 0.95764848371138 + 0.95779958367102 + 0.95798619348506 + 0.95821565814526 + 0.95850020522329 + 0.95885691846992 + 0.95930918351712 + 0.95988935244115 + 0.96064378077398 + 0.96163907528795 + 0.96297354379995 + 0.96480134072571 + 0.96738403913443 + 0.97123006243670 + 0.97764822358886 + 1.00000000000000 + 0.97482137991661 + 0.96355558455708 + 0.95362406620411 + 0.94395480229731 + 0.93414957270895 + 0.92400906250873 + 0.91342545200985 + 0.90234869854599 + 0.89077504917036 + 0.87874334416367 + 0.86632858613945 + 0.85362541432917 + 0.84075175077518 + 0.82785792193285 + 0.81509741570775 + 0.80880276321926 + 0.80258366526975 + 0.79644665109616 + 0.79039385310591 + 0.78442285556788 + 0.77852677974819 + 0.77269468974617 + 0.76691239388205 + 0.76116352981421 + 0.75542797364834 + 0.74963574424093 + 0.74358446457111 + 0.73716390680340 + 0.73035355161312 + 0.72312548704362 + 0.71548372139625 + 0.70743952841609 + 0.69901058326364 + 0.69022000993127 + 0.68109535123105 + 0.67166525945136 + 0.66191866840751 + 0.65188043920076 + 0.64157795325647 + 0.63104205863854 + 0.62030849542462 + 0.60941945269298 + 0.59840254740364 + 0.58728652860464 + 0.57612454265423 + 0.56497210801943 + 0.55388197467185 + 0.95200372661752 + 0.95200378300591 + 0.95200379237123 + 0.95200380329322 + 0.95200381603676 + 0.95200383090430 + 0.95200384825532 + 0.95200386850968 + 0.95200389216787 + 0.95200391985971 + 0.95200395249587 + 0.95200399140030 + 0.95200403815970 + 0.95200409454571 + 0.95200416264221 + 0.95200424496169 + 0.95200434457085 + 0.95200446520121 + 0.95200461163752 + 0.95200479001419 + 0.95200500763907 + 0.95200527358074 + 0.95200559910195 + 0.95200599823593 + 0.95200648866444 + 0.95200709363968 + 0.95200784569820 + 0.95200878762492 + 0.95200997174433 + 0.95201146330710 + 0.95201335229635 + 0.95201575282660 + 0.95201881125482 + 0.95202271753809 + 0.95202771858860 + 0.95203413581778 + 0.95204238818707 + 0.95205302260095 + 0.95206677604060 + 0.95208464810631 + 0.95210794177133 + 0.95213839318711 + 0.95217831399070 + 0.95223066419877 + 0.95229840807062 + 0.95238402528821 + 0.95249150535012 + 0.95262576970025 + 0.95279061508685 + 0.95299195201275 + 0.95323985866834 + 0.95354836658538 + 0.95393650628931 + 0.95443027890698 + 0.95506639069235 + 0.95589634995027 + 0.95699360079162 + 0.95846779678132 + 0.96049118131981 + 0.96335685504698 + 0.96763868079772 + 0.97482137991661 + 1.00000000000000 + 0.97162047153886 + 0.95895469340681 + 0.94785217904700 + 0.93712343099698 + 0.92632854639547 + 0.91525602675904 + 0.90380217474672 + 0.89193194916665 + 0.87966429491374 + 0.86706070304767 + 0.85420611649307 + 0.84121136876001 + 0.82822147734744 + 0.81538560850393 + 0.80905981967585 + 0.80281338917243 + 0.79665243699448 + 0.79057871081930 + 0.78458943595251 + 0.77867740111876 + 0.77283136442557 + 0.76703685492967 + 0.76127725839163 + 0.75553222326467 + 0.74973150412791 + 0.74367235060436 + 0.73724436654253 + 0.73042700377204 + 0.72319232254321 + 0.71554433499055 + 0.70749431826411 + 0.69905994802227 + 0.69026434478820 + 0.68113504369844 + 0.67170068427384 + 0.66195016765735 + 0.65190833861736 + 0.64160256095616 + 0.63106366488292 + 0.62032737345242 + 0.60943586038935 + 0.59841672529369 + 0.58729870284351 + 0.57613493139948 + 0.56498092248073 + 0.55388941860495 + 0.94628526219689 + 0.94628531335897 + 0.94628532185281 + 0.94628533175992 + 0.94628534331653 + 0.94628535679965 + 0.94628537253234 + 0.94628539089608 + 0.94628541234273 + 0.94628543744406 + 0.94628546702425 + 0.94628550229426 + 0.94628554469860 + 0.94628559585287 + 0.94628565765028 + 0.94628573238219 + 0.94628582283680 + 0.94628593241073 + 0.94628606545648 + 0.94628622756663 + 0.94628642539242 + 0.94628666718361 + 0.94628696318276 + 0.94628732614369 + 0.94628777212881 + 0.94628832227173 + 0.94628900621041 + 0.94628986293195 + 0.94629094003604 + 0.94629229681206 + 0.94629401511396 + 0.94629619861871 + 0.94629898017033 + 0.94630253201505 + 0.94630707782086 + 0.94631290840314 + 0.94632040236301 + 0.94633005319665 + 0.94634252558025 + 0.94635872058753 + 0.94637981033854 + 0.94640735424359 + 0.94644342477415 + 0.94649066503911 + 0.94655167223254 + 0.94662852534542 + 0.94672462657667 + 0.94684412862246 + 0.94698999045181 + 0.94716694385284 + 0.94738330126150 + 0.94765061605939 + 0.94798444368335 + 0.94840583292871 + 0.94894418348740 + 0.94964003590090 + 0.95054978257239 + 0.95175488682106 + 0.95337722824438 + 0.95560906671381 + 0.95878171071675 + 0.96355558455708 + 0.97162047153886 + 1.00000000000000 + 0.96801045949519 + 0.95379221968263 + 0.94143223320853 + 0.92959081578587 + 0.91778017021343 + 0.90577754712818 + 0.89348637114159 + 0.88088972118852 + 0.86802629123859 + 0.85496550752076 + 0.84180728493503 + 0.82868868438646 + 0.81575256156779 + 0.80938557886039 + 0.80310311811715 + 0.79691072782857 + 0.79080962174450 + 0.78479652974474 + 0.77886378391484 + 0.77299972409682 + 0.76718949924116 + 0.76141615354103 + 0.75565902827675 + 0.74984752912320 + 0.74377842619637 + 0.73734110569654 + 0.73051497795541 + 0.72327206405615 + 0.71561637651368 + 0.70755919208769 + 0.69911818208926 + 0.69031645746534 + 0.68118153837224 + 0.67174204307973 + 0.66198682789355 + 0.65194071262789 + 0.64163103493220 + 0.63108859906470 + 0.62034910368405 + 0.60945470068869 + 0.59843296617300 + 0.58731261540328 + 0.57614677522979 + 0.56499094727711 + 0.55389786392611 + 0.93990758370421 + 0.93990763024173 + 0.93990763796646 + 0.93990764697587 + 0.93990765748441 + 0.93990766974302 + 0.93990768404633 + 0.93990770073788 + 0.93990772022995 + 0.93990774304116 + 0.93990776992355 + 0.93990780197903 + 0.93990784052839 + 0.93990788704799 + 0.93990794326429 + 0.93990801126762 + 0.93990809359629 + 0.93990819335089 + 0.93990831450033 + 0.93990846214761 + 0.93990864235803 + 0.93990886265192 + 0.93990913235562 + 0.93990946308617 + 0.93990986945936 + 0.93991037071818 + 0.93991099390026 + 0.93991177458440 + 0.93991275615404 + 0.93991399256089 + 0.93991555838207 + 0.93991754796552 + 0.93992008207285 + 0.93992331713963 + 0.93992745609799 + 0.93993276248491 + 0.93993957894584 + 0.93994835146715 + 0.93995968039778 + 0.93997437918469 + 0.93999350376109 + 0.94001845680496 + 0.94005109904241 + 0.94009379402803 + 0.94014881958202 + 0.94021791362768 + 0.94030397636276 + 0.94041050835183 + 0.94053977739220 + 0.94069554283131 + 0.94088465597090 + 0.94111663712158 + 0.94140422816211 + 0.94176453733010 + 0.94222127524034 + 0.94280670077374 + 0.94356485878554 + 0.94455790800907 + 0.94587583131072 + 0.94765390821580 + 0.95010894713889 + 0.95362406620411 + 0.95895469340681 + 0.96801045949519 + 1.00000000000000 + 0.96393705251073 + 0.94802536243982 + 0.93433156484828 + 0.92133845814458 + 0.90850615218054 + 0.89560163942969 + 0.88253753436409 + 0.86931148245458 + 0.85596679096214 + 0.84258588085088 + 0.82929352173177 + 0.81622314261737 + 0.80980132232072 + 0.80347108248701 + 0.79723716482036 + 0.79110003516988 + 0.78505573413292 + 0.77909596225483 + 0.77320848403696 + 0.76737792805191 + 0.76158687289417 + 0.75581424326006 + 0.74998898143338 + 0.74390723764468 + 0.73745811453236 + 0.73062096272690 + 0.72336774796879 + 0.71570247731565 + 0.70763642094099 + 0.69918723831458 + 0.69037802174145 + 0.68123626585631 + 0.67179055571772 + 0.66202968641331 + 0.65197844090775 + 0.64166411904461 + 0.63111748815822 + 0.62037421256274 + 0.60947641364636 + 0.59845163585376 + 0.58732856838851 + 0.57616032188735 + 0.56500238415215 + 0.55390747390103 + 0.93283057890289 + 0.93283062130024 + 0.93283062833662 + 0.93283063654238 + 0.93283064611342 + 0.93283065727680 + 0.93283067030055 + 0.93283068549688 + 0.93283070324129 + 0.93283072400320 + 0.93283074847081 + 0.93283077765042 + 0.93283081275220 + 0.93283085512142 + 0.93283090633830 + 0.93283096830812 + 0.93283104334930 + 0.93283113429368 + 0.93283124476419 + 0.93283137942262 + 0.93283154380838 + 0.93283174478348 + 0.93283199085440 + 0.93283229261120 + 0.93283266337195 + 0.93283312068294 + 0.93283368923657 + 0.93283440154421 + 0.93283529718929 + 0.93283642533575 + 0.93283785401381 + 0.93283966919493 + 0.93284198079618 + 0.93284493109242 + 0.93284870443931 + 0.93285353998229 + 0.93285974824720 + 0.93286773283096 + 0.93287803671241 + 0.93289139521332 + 0.93290876087532 + 0.93293139709210 + 0.93296097673928 + 0.93299961627365 + 0.93304931531834 + 0.93311152167965 + 0.93318870612293 + 0.93328381541966 + 0.93339854763884 + 0.93353585858314 + 0.93370138495197 + 0.93390296744978 + 0.93415104715841 + 0.93445955250405 + 0.93484767705662 + 0.93534125441906 + 0.93597504428325 + 0.93679726662027 + 0.93787611184241 + 0.93931081125201 + 0.94125333483623 + 0.94395480229731 + 0.94785217904700 + 0.95379221968263 + 0.96393705251073 + 1.00000000000000 + 0.95936057839037 + 0.94162035642938 + 0.92652840867832 + 0.91236386319468 + 0.89853015519334 + 0.88478372080147 + 0.87104160485342 + 0.85730016326679 + 0.84361232755560 + 0.83008312037819 + 0.81683146228553 + 0.81033609338810 + 0.80394204206561 + 0.79765289439078 + 0.79146805539935 + 0.78538259620717 + 0.77938733561636 + 0.77346924003047 + 0.76761222028760 + 0.76179821596422 + 0.75600558317959 + 0.75016264447525 + 0.74406474278531 + 0.73760060824605 + 0.73074950546430 + 0.72348332173391 + 0.71580604916690 + 0.70772894157106 + 0.69926963523321 + 0.69045119052117 + 0.68130106145374 + 0.67184778310421 + 0.66208006721984 + 0.65202264356082 + 0.64170275827619 + 0.63115112690329 + 0.62040336601095 + 0.60950155481160 + 0.59847319529657 + 0.58734694181213 + 0.57617588247317 + 0.56501548602786 + 0.55391845288830 + 0.92502573151907 + 0.92502577016823 + 0.92502577658080 + 0.92502578405949 + 0.92502579278138 + 0.92502580295334 + 0.92502581481881 + 0.92502582866412 + 0.92502584482668 + 0.92502586373679 + 0.92502588601950 + 0.92502591259877 + 0.92502594458038 + 0.92502598319287 + 0.92502602988279 + 0.92502608638743 + 0.92502615482940 + 0.92502623778817 + 0.92502633858125 + 0.92502646146805 + 0.92502661150871 + 0.92502679496849 + 0.92502701961529 + 0.92502729510879 + 0.92502763359562 + 0.92502805108727 + 0.92502857015573 + 0.92502922053441 + 0.92503003836735 + 0.92503106850526 + 0.92503237306590 + 0.92503403046588 + 0.92503614086817 + 0.92503883380508 + 0.92504227695916 + 0.92504668760367 + 0.92505234749467 + 0.92505962233578 + 0.92506900383360 + 0.92508115754029 + 0.92509694384614 + 0.92511750219286 + 0.92514433857903 + 0.92517935080986 + 0.92522429609969 + 0.92528037593203 + 0.92534969386423 + 0.92543472652996 + 0.92553670383609 + 0.92565791814587 + 0.92580299442506 + 0.92597838044327 + 0.92619262436492 + 0.92645706540824 + 0.92678726359451 + 0.92720397439994 + 0.92773479102543 + 0.92841749504933 + 0.92930460259053 + 0.93047079499485 + 0.93202706599864 + 0.93414957270895 + 0.93712343099698 + 0.94143223320853 + 0.94802536243982 + 0.95936057839037 + 1.00000000000000 + 0.95423769847571 + 0.93454461790157 + 0.91800924962195 + 0.90268040731814 + 0.88789846716467 + 0.87340196720736 + 0.85909523569725 + 0.84497815211009 + 0.83112239661919 + 0.81762369593453 + 0.81102888889848 + 0.80454898099724 + 0.79818587199873 + 0.79193743821919 + 0.78579736849109 + 0.77975523600159 + 0.77379688875246 + 0.76790523875626 + 0.76206134164305 + 0.75624277195790 + 0.75037701753045 + 0.74425836280159 + 0.73777504464989 + 0.73090620322731 + 0.72362361404538 + 0.71593123900715 + 0.70784030021198 + 0.69936839361966 + 0.69053852821621 + 0.68137809586717 + 0.67191555818439 + 0.66213951376303 + 0.65207461675930 + 0.64174803806033 + 0.63119042136547 + 0.62043731752097 + 0.60953074796645 + 0.59849815799029 + 0.58736815547038 + 0.57619379761439 + 0.56503052717704 + 0.55393102017322 + 0.91647669951438 + 0.91647673473274 + 0.91647674057549 + 0.91647674738823 + 0.91647675533322 + 0.91647676459918 + 0.91647677540617 + 0.91647678801499 + 0.91647680273290 + 0.91647681995094 + 0.91647684023913 + 0.91647686444345 + 0.91647689357265 + 0.91647692875468 + 0.91647697130406 + 0.91647702281436 + 0.91647708522039 + 0.91647716088211 + 0.91647725282573 + 0.91647736495035 + 0.91647750187735 + 0.91647766932958 + 0.91647787440023 + 0.91647812590477 + 0.91647843492724 + 0.91647881608110 + 0.91647929001117 + 0.91647988391803 + 0.91648063083512 + 0.91648157169955 + 0.91648276326761 + 0.91648427712749 + 0.91648620462459 + 0.91648866380403 + 0.91649180733100 + 0.91649583280820 + 0.91650099618025 + 0.91650762918398 + 0.91651617763192 + 0.91652724464943 + 0.91654160837156 + 0.91656029777236 + 0.91658467043565 + 0.91661643045872 + 0.91665712378665 + 0.91670774317670 + 0.91677007839156 + 0.91684620720170 + 0.91693697650524 + 0.91704413203102 + 0.91717145541350 + 0.91732423678687 + 0.91750946116856 + 0.91773634702136 + 0.91801750544926 + 0.91836962650524 + 0.91881466975191 + 0.91938239524670 + 0.92011362992817 + 0.92106546262234 + 0.92232103416758 + 0.92400906250873 + 0.92632854639547 + 0.92959081578587 + 0.93433156484828 + 0.94162035642938 + 0.95423769847571 + 1.00000000000000 + 0.94852605172407 + 0.92677271825667 + 0.90877551251980 + 0.89232349568145 + 0.87667988426040 + 0.86154546215546 + 0.84681605319170 + 0.83250329140158 + 0.81866396331839 + 0.81193338101474 + 0.80533691793261 + 0.79887395268338 + 0.79254011230269 + 0.78632707934059 + 0.78022264018718 + 0.77421105477738 + 0.76827382919056 + 0.76239078400972 + 0.75653840982353 + 0.75064306090543 + 0.74449762346086 + 0.73798967540984 + 0.73109817574635 + 0.72379473963092 + 0.71608327443697 + 0.70797494671660 + 0.69948728636285 + 0.69064322266095 + 0.68147005465639 + 0.67199613776299 + 0.66220991721236 + 0.65213594097813 + 0.64180127548795 + 0.63123646564975 + 0.62047697253811 + 0.60956473902829 + 0.59852713488860 + 0.58739270625690 + 0.57621446828670 + 0.56504782856366 + 0.55394543072780 + 0.90718247706307 + 0.90718250911659 + 0.90718251443252 + 0.90718252063149 + 0.90718252786029 + 0.90718253629046 + 0.90718254612140 + 0.90718255759026 + 0.90718257097559 + 0.90718258663401 + 0.90718260508439 + 0.90718262709750 + 0.90718265360174 + 0.90718268561930 + 0.90718272435619 + 0.90718277126362 + 0.90718282811039 + 0.90718289704742 + 0.90718298084133 + 0.90718308305647 + 0.90718320790963 + 0.90718336063108 + 0.90718354769312 + 0.90718377714074 + 0.90718405908775 + 0.90718440687411 + 0.90718483938187 + 0.90718538150112 + 0.90718606342303 + 0.90718692253245 + 0.90718801071004 + 0.90718939333728 + 0.90719115378261 + 0.90719339969060 + 0.90719627017427 + 0.90719994510674 + 0.90720465720871 + 0.90721070772845 + 0.90721850131249 + 0.90722858514849 + 0.90724166384153 + 0.90725866780565 + 0.90728082247551 + 0.90730966018282 + 0.90734654269356 + 0.90739228628887 + 0.90744841275827 + 0.90751666182432 + 0.90759756874097 + 0.90769243024840 + 0.90780432524369 + 0.90793758104255 + 0.90809788933829 + 0.90829272543037 + 0.90853229339457 + 0.90883000031690 + 0.90920332069264 + 0.90967573757524 + 0.91027913466891 + 0.91105753289993 + 0.91207415818185 + 0.91342545200985 + 0.91525602675904 + 0.91778017021343 + 0.92133845814458 + 0.92652840867832 + 0.93454461790157 + 0.94852605172407 + 1.00000000000000 + 0.94218704521131 + 0.91829064559793 + 0.89884794931811 + 0.88134902408946 + 0.86495296905035 + 0.84932526265870 + 0.83435969232323 + 0.82004334389495 + 0.81312498065991 + 0.80636846953016 + 0.79976929758701 + 0.79331969050300 + 0.78700834957996 + 0.78082044585061 + 0.77473794484500 + 0.76874034384998 + 0.76280571531169 + 0.75690902923552 + 0.75097508469845 + 0.74479490452744 + 0.73825517717223 + 0.73133459571652 + 0.72400454335383 + 0.71626883436871 + 0.70813854285377 + 0.69963109408992 + 0.69076929645058 + 0.68158031257123 + 0.67209234600642 + 0.66229363431481 + 0.65220857757607 + 0.64186409827095 + 0.63129060630891 + 0.62052344083425 + 0.60960443846107 + 0.59856086860061 + 0.58742119552434 + 0.57623837755024 + 0.56506777496751 + 0.55396198859255 + 0.89716202410742 + 0.89716205321764 + 0.89716205804535 + 0.89716206367420 + 0.89716207023700 + 0.89716207789027 + 0.89716208681578 + 0.89716209722589 + 0.89716210937510 + 0.89716212358682 + 0.89716214033170 + 0.89716216031479 + 0.89716218438119 + 0.89716221346556 + 0.89716224866601 + 0.89716229130724 + 0.89716234299891 + 0.89716240570598 + 0.89716248195116 + 0.89716257498726 + 0.89716268866646 + 0.89716282775829 + 0.89716299816739 + 0.89716320723211 + 0.89716346417812 + 0.89716378117636 + 0.89716417549286 + 0.89716466990031 + 0.89716529199855 + 0.89716607592256 + 0.89716706911204 + 0.89716833130291 + 0.89716993860874 + 0.89717198925484 + 0.89717461008132 + 0.89717796495607 + 0.89718226567157 + 0.89718778605663 + 0.89719489377974 + 0.89720408584009 + 0.89721600104012 + 0.89723148176492 + 0.89725163567607 + 0.89727784267673 + 0.89731130395168 + 0.89735268692299 + 0.89740328476530 + 0.89746455106223 + 0.89753676923520 + 0.89762086884346 + 0.89771934395060 + 0.89783572142937 + 0.89797462249248 + 0.89814208748189 + 0.89834634960883 + 0.89859815090978 + 0.89891136596894 + 0.89930450589357 + 0.89980249053495 + 0.90043938773179 + 0.90126367186772 + 0.90234869854599 + 0.90380217474672 + 0.90577754712818 + 0.90850615218054 + 0.91236386319468 + 0.91800924962195 + 0.92677271825667 + 0.94218704521131 + 1.00000000000000 + 0.93518728722664 + 0.90909848917299 + 0.88826363571583 + 0.86981989375060 + 0.85281889946781 + 0.83689347223873 + 0.82189474645354 + 0.81471219453218 + 0.80773258207414 + 0.80094513187940 + 0.79433673694705 + 0.78789152879050 + 0.78159074677114 + 0.77541296469498 + 0.76933475262733 + 0.76333166614059 + 0.75737651019512 + 0.75139192246439 + 0.74516641561188 + 0.73858546237247 + 0.73162736119193 + 0.72426315607747 + 0.71649650694692 + 0.70833833821528 + 0.69980591268781 + 0.69092185772044 + 0.68171313743903 + 0.67220773980964 + 0.66239362110129 + 0.65229497657413 + 0.64193853135367 + 0.63135451169749 + 0.62057809182198 + 0.60965096516077 + 0.59860026795113 + 0.58745435606738 + 0.57626611138323 + 0.56509083086338 + 0.55398105881959 + 0.88645951234304 + 0.88645953870461 + 0.88645954307559 + 0.88645954817184 + 0.88645955411390 + 0.88645956104321 + 0.88645956912160 + 0.88645957854487 + 0.88645958954132 + 0.88645960240270 + 0.88645961755796 + 0.88645963564842 + 0.88645965744325 + 0.88645968379505 + 0.88645971570206 + 0.88645975437041 + 0.88645980126574 + 0.88645985817506 + 0.88645992739959 + 0.88646001190384 + 0.88646011520004 + 0.88646024163413 + 0.88646039658946 + 0.88646058675522 + 0.88646082053512 + 0.88646110903456 + 0.88646146803016 + 0.88646191835147 + 0.88646248521833 + 0.88646319980781 + 0.88646410549192 + 0.88646525685871 + 0.88646672342215 + 0.88646859484943 + 0.88647098686357 + 0.88647404884719 + 0.88647797370288 + 0.88648301056271 + 0.88648949383584 + 0.88649787543221 + 0.88650873519742 + 0.88652283680025 + 0.88654118283497 + 0.88656501780797 + 0.88659540284982 + 0.88663288016933 + 0.88667854810856 + 0.88673361844289 + 0.88679817293949 + 0.88687284262151 + 0.88695963592346 + 0.88706141526369 + 0.88718191667584 + 0.88732599949826 + 0.88750028159835 + 0.88771333619499 + 0.88797613528453 + 0.88830322224732 + 0.88871403207000 + 0.88923492315236 + 0.88990317459110 + 0.89077504917036 + 0.89193194916665 + 0.89348637114159 + 0.89560163942969 + 0.89853015519334 + 0.90268040731814 + 0.90877551251980 + 0.91829064559793 + 0.93518728722664 + 1.00000000000000 + 0.92749893384830 + 0.89920540897553 + 0.87706144178996 + 0.85782191785741 + 0.84042392789102 + 0.82441932834745 + 0.81685623450758 + 0.80955921631256 + 0.80250683672550 + 0.79567721869434 + 0.78904719459943 + 0.78259188025602 + 0.77628468089439 + 0.77009778826169 + 0.76400305188062 + 0.75797013329887 + 0.75191861569473 + 0.74563358403466 + 0.73899882346022 + 0.73199203822435 + 0.72458376960010 + 0.71677742500799 + 0.70858368991492 + 0.70001957719469 + 0.69110744503466 + 0.68187397018004 + 0.67234683565505 + 0.66251361621944 + 0.65239822445739 + 0.64202711575671 + 0.63143026725067 + 0.62064263065210 + 0.60970570696141 + 0.59864645579083 + 0.58749308957118 + 0.57629838771556 + 0.56511756267544 + 0.55400308429984 + 0.87514888038169 + 0.87514890416813 + 0.87514890811197 + 0.87514891270934 + 0.87514891806966 + 0.87514892431973 + 0.87514893160622 + 0.87514894010548 + 0.87514895002276 + 0.87514896162118 + 0.87514897528938 + 0.87514899161040 + 0.87514901128328 + 0.87514903508206 + 0.87514906391284 + 0.87514909887162 + 0.87514914129137 + 0.87514919279451 + 0.87514925547649 + 0.87514933203244 + 0.87514942566251 + 0.87514954032127 + 0.87514968090905 + 0.87514985351909 + 0.87515006580114 + 0.87515032787741 + 0.87515065415668 + 0.87515106368041 + 0.87515157949115 + 0.87515223005009 + 0.87515305501393 + 0.87515410426896 + 0.87515544131428 + 0.87515714803689 + 0.87515933006094 + 0.87516212365075 + 0.87516570463194 + 0.87517029986020 + 0.87517621378225 + 0.87518385773792 + 0.87519375866347 + 0.87520660973958 + 0.87522331967106 + 0.87524501250660 + 0.87527262714697 + 0.87530660079456 + 0.87534786594964 + 0.87539743043028 + 0.87545521652983 + 0.87552161446965 + 0.87559823073558 + 0.87568737757258 + 0.87579206069007 + 0.87591616915886 + 0.87606499808473 + 0.87624535554647 + 0.87646586973202 + 0.87673790639896 + 0.87707655263962 + 0.87750213295544 + 0.87804329424192 + 0.87874334416367 + 0.87966429491374 + 0.88088972118852 + 0.88253753436409 + 0.88478372080147 + 0.88789846716467 + 0.89232349568145 + 0.89884794931811 + 0.90909848917299 + 0.92749893384830 + 1.00000000000000 + 0.91909056993644 + 0.88861281547611 + 0.86530295786180 + 0.84549181156403 + 0.82793764127769 + 0.81980771921211 + 0.81204602280113 + 0.80461156956699 + 0.79746710660012 + 0.79057714860679 + 0.78390681222085 + 0.77742130006030 + 0.77108602313400 + 0.76486720807668 + 0.75872983285780 + 0.75258906800218 + 0.74622523399417 + 0.73951972663643 + 0.73244933882154 + 0.72498385385785 + 0.71712626756545 + 0.70888688557086 + 0.70028233728281 + 0.69133458118002 + 0.68206987839010 + 0.67251548088494 + 0.66265844445954 + 0.65252229200573 + 0.64213311066149 + 0.63152053998706 + 0.62071923181904 + 0.60977042879589 + 0.59870085615984 + 0.58753853644088 + 0.57633611197202 + 0.56514868261047 + 0.55402862011831 + 0.86333193747454 + 0.86333195884421 + 0.86333196238647 + 0.86333196651611 + 0.86333197133126 + 0.86333197694444 + 0.86333198348933 + 0.86333199112231 + 0.86333200002765 + 0.86333201044229 + 0.86333202271817 + 0.86333203738188 + 0.86333205506727 + 0.86333207647723 + 0.86333210243099 + 0.86333213392392 + 0.86333217216314 + 0.86333221862111 + 0.86333227519738 + 0.86333234434585 + 0.86333242897264 + 0.86333253267303 + 0.86333265990270 + 0.86333281620149 + 0.86333300852917 + 0.86333324610153 + 0.86333354207105 + 0.86333391383877 + 0.86333438244108 + 0.86333497386160 + 0.86333572435115 + 0.86333667949611 + 0.86333789731916 + 0.86333945261026 + 0.86334144182061 + 0.86334398930937 + 0.86334725543281 + 0.86335144692146 + 0.86335684116850 + 0.86336381292823 + 0.86337284155766 + 0.86338455693783 + 0.86339978366229 + 0.86341953831919 + 0.86344465294376 + 0.86347547698884 + 0.86351280189891 + 0.86355746379645 + 0.86360926104702 + 0.86366839174664 + 0.86373613107388 + 0.86381433733274 + 0.86390541572906 + 0.86401246077688 + 0.86413968724672 + 0.86429246962746 + 0.86447754599932 + 0.86470373705120 + 0.86498267606240 + 0.86532994168935 + 0.86576746451253 + 0.86632858613945 + 0.86706070304767 + 0.86802629123859 + 0.86931148245458 + 0.87104160485342 + 0.87340196720736 + 0.87667988426040 + 0.88134902408946 + 0.88826363571583 + 0.89920540897553 + 0.91909056993644 + 1.00000000000000 + 0.90991108235802 + 0.87734826728180 + 0.85311298198714 + 0.83300186446928 + 0.82398428961876 + 0.81551313867722 + 0.80750768423890 + 0.79990124761920 + 0.79263594231607 + 0.78565947595273 + 0.77892329782185 + 0.77238181121049 + 0.76599235984672 + 0.75971269559962 + 0.75345142128151 + 0.74698207049924 + 0.74018256709931 + 0.73302827347312 + 0.72548780560214 + 0.71756348552222 + 0.70926501331776 + 0.70060842796155 + 0.69161509214391 + 0.68231066381545 + 0.67272178358460 + 0.66283479705886 + 0.65267268864858 + 0.64226104166126 + 0.63162903725694 + 0.62081092230780 + 0.60984759186878 + 0.59876545920137 + 0.58759229463120 + 0.57638055689950 + 0.56518519567739 + 0.55405845320296 + 0.85112461310575 + 0.85112463220565 + 0.85112463537126 + 0.85112463906191 + 0.85112464336444 + 0.85112464838100 + 0.85112465422883 + 0.85112466104822 + 0.85112466900480 + 0.85112467830928 + 0.85112468927876 + 0.85112470238951 + 0.85112471821492 + 0.85112473738889 + 0.85112476065432 + 0.85112478890844 + 0.85112482324384 + 0.85112486499301 + 0.85112491587680 + 0.85112497812275 + 0.85112505436607 + 0.85112514787119 + 0.85112526268468 + 0.85112540383450 + 0.85112557764612 + 0.85112579250664 + 0.85112606041326 + 0.85112639724875 + 0.85112682222170 + 0.85112735903503 + 0.85112804082225 + 0.85112890924303 + 0.85113001730191 + 0.85113143332957 + 0.85113324541030 + 0.85113556708021 + 0.85113854464970 + 0.85114236660100 + 0.85114728583196 + 0.85115364399418 + 0.85116187746742 + 0.85117255908540 + 0.85118643774786 + 0.85120443374160 + 0.85122728535056 + 0.85125526892445 + 0.85128905590869 + 0.85132933807488 + 0.85137581984216 + 0.85142854822914 + 0.85148852666129 + 0.85155724043051 + 0.85163660309507 + 0.85172906137662 + 0.85183795125728 + 0.85196748751140 + 0.85212288979905 + 0.85231094655249 + 0.85254055240479 + 0.85282355283502 + 0.85317663583217 + 0.85362541432917 + 0.85420611649307 + 0.85496550752076 + 0.85596679096214 + 0.85730016326679 + 0.85909523569725 + 0.86154546215546 + 0.86495296905035 + 0.86981989375060 + 0.87706144178996 + 0.88861281547611 + 0.90991108235802 + 1.00000000000000 + 0.89995507987027 + 0.86552971348367 + 0.84067606358199 + 0.83015381508106 + 0.82052701549479 + 0.81162088293232 + 0.80330491647833 + 0.79547597606832 + 0.78804863066183 + 0.78094944533377 + 0.77411375324616 + 0.76748406214777 + 0.76100642764092 + 0.75457926355563 + 0.74796609061164 + 0.74103960723281 + 0.73377286395053 + 0.72613262969989 + 0.71812011051557 + 0.70974403102025 + 0.70101951145394 + 0.69196701712917 + 0.68261132192952 + 0.67297819104324 + 0.66305298672179 + 0.65285794305271 + 0.64241794838873 + 0.63176155643432 + 0.62092246282493 + 0.60994109138866 + 0.59884343638106 + 0.58765693023532 + 0.57643378411372 + 0.56522874592839 + 0.55409388547947 + 0.83866131816596 + 0.83866133513803 + 0.83866133795132 + 0.83866134123033 + 0.83866134505324 + 0.83866134950975 + 0.83866135470477 + 0.83866136076328 + 0.83866136783099 + 0.83866137609596 + 0.83866138584308 + 0.83866139750077 + 0.83866141158774 + 0.83866142867544 + 0.83866144943049 + 0.83866147466610 + 0.83866150536312 + 0.83866154272866 + 0.83866158831816 + 0.83866164414999 + 0.83866171260730 + 0.83866179665273 + 0.83866189995470 + 0.83866202707429 + 0.83866218375466 + 0.83866237761968 + 0.83866261960597 + 0.83866292421003 + 0.83866330895782 + 0.83866379547460 + 0.83866441403623 + 0.83866520271133 + 0.83866620992789 + 0.83866749812235 + 0.83866914776213 + 0.83867126253293 + 0.83867397598695 + 0.83867746005136 + 0.83868194541823 + 0.83868774373751 + 0.83869525252514 + 0.83870499308028 + 0.83871764603485 + 0.83873404516218 + 0.83875484636553 + 0.83878026540897 + 0.83881087180878 + 0.83884723636318 + 0.83888899481305 + 0.83893607774634 + 0.83898926730831 + 0.83904974426392 + 0.83911902236858 + 0.83919902397169 + 0.83929237512640 + 0.83940235914721 + 0.83953298494123 + 0.83968942975704 + 0.83987843069455 + 0.84010891203464 + 0.84039348129157 + 0.84075175077518 + 0.84121136876001 + 0.84180728493503 + 0.84258588085088 + 0.84361232755560 + 0.84497815211009 + 0.84681605319170 + 0.84932526265870 + 0.85281889946781 + 0.85782191785741 + 0.86530295786180 + 0.87734826728180 + 0.89995507987027 + 1.00000000000000 + 0.88930216291634 + 0.85333495936770 + 0.83989606505294 + 0.82818084299581 + 0.81773096246040 + 0.80824857551558 + 0.79952394014823 + 0.79139997110893 + 0.78375311748842 + 0.77648254083478 + 0.76950398909305 + 0.76274330076627 + 0.75608216877228 + 0.74926863182034 + 0.74216715289627 + 0.73474689316667 + 0.72697158958057 + 0.71884055401291 + 0.71036090491762 + 0.70154630350413 + 0.69241583803623 + 0.68299296476855 + 0.67330217634669 + 0.66332745231623 + 0.65308996844873 + 0.64261364364645 + 0.63192616358232 + 0.62106046595223 + 0.61005632951083 + 0.59893917996983 + 0.58773599250474 + 0.57649864157467 + 0.56528160173923 + 0.55413671107746 + 0.82610497552011 + 0.82610499051069 + 0.82610499299453 + 0.82610499588993 + 0.82610499926561 + 0.82610500320040 + 0.82610500778787 + 0.82610501313717 + 0.82610501937677 + 0.82610502667541 + 0.82610503528488 + 0.82610504559311 + 0.82610505806393 + 0.82610507321152 + 0.82610509163980 + 0.82610511407390 + 0.82610514140279 + 0.82610517471147 + 0.82610521540462 + 0.82610526530738 + 0.82610532658040 + 0.82610540190119 + 0.82610549459496 + 0.82610560879809 + 0.82610574972264 + 0.82610592429505 + 0.82610614248782 + 0.82610641753300 + 0.82610676542230 + 0.82610720588761 + 0.82610776660985 + 0.82610848239104 + 0.82610939750558 + 0.82611056903528 + 0.82611207054418 + 0.82611399679760 + 0.82611646980624 + 0.82611964654649 + 0.82612373764904 + 0.82612902768422 + 0.82613587914216 + 0.82614476692758 + 0.82615631030882 + 0.82617126557268 + 0.82619021647665 + 0.82621332905158 + 0.82624108674830 + 0.82627395973444 + 0.82631153615873 + 0.82635365933740 + 0.82640093326496 + 0.82645429266657 + 0.82651492968745 + 0.82658434696074 + 0.82666460333235 + 0.82675824257007 + 0.82686831979946 + 0.82699875026606 + 0.82715459128671 + 0.82734250646421 + 0.82757195653745 + 0.82785792193285 + 0.82822147734744 + 0.82868868438646 + 0.82929352173177 + 0.83008312037819 + 0.83112239661919 + 0.83250329140158 + 0.83435969232323 + 0.83689347223873 + 0.84042392789102 + 0.84549181156403 + 0.85311298198714 + 0.86552971348367 + 0.88930216291634 + 1.00000000000000 + 0.87805024198853 + 0.85719115731466 + 0.84092533213723 + 0.82743635298630 + 0.81581963555918 + 0.80554512060922 + 0.79626800166744 + 0.78774672330449 + 0.77980236207922 + 0.77229689488797 + 0.76511789311505 + 0.75811743167107 + 0.75101807378223 + 0.74367049493195 + 0.73603694515748 + 0.72807593456191 + 0.71978343543316 + 0.71116383131755 + 0.70222839654272 + 0.69299405110264 + 0.68348224421261 + 0.67371558479784 + 0.66367607744608 + 0.65338338642191 + 0.64286006406193 + 0.63213258451484 + 0.62123283533911 + 0.61019970633595 + 0.59905784666241 + 0.58783360897812 + 0.57657840768925 + 0.56534634536640 + 0.55418894718444 + 0.81361970092254 + 0.81361971407917 + 0.81361971625903 + 0.81361971880045 + 0.81361972176272 + 0.81361972521620 + 0.81361972924202 + 0.81361973393609 + 0.81361973941169 + 0.81361974581642 + 0.81361975337535 + 0.81361976243626 + 0.81361977341784 + 0.81361978678062 + 0.81361980306399 + 0.81361982292270 + 0.81361984715561 + 0.81361987673856 + 0.81361991293879 + 0.81361995740856 + 0.81362001209934 + 0.81362007943423 + 0.81362016242731 + 0.81362026483004 + 0.81362039136978 + 0.81362054834997 + 0.81362074486226 + 0.81362099299520 + 0.81362130735494 + 0.81362170596896 + 0.81362221416542 + 0.81362286379809 + 0.81362369539393 + 0.81362476121016 + 0.81362612859209 + 0.81362788428396 + 0.81363013992056 + 0.81363303905573 + 0.81363677432672 + 0.81364160600604 + 0.81364786521151 + 0.81365598535220 + 0.81366653086663 + 0.81368018908003 + 0.81369748093894 + 0.81371853213811 + 0.81374375402497 + 0.81377353386011 + 0.81380742938786 + 0.81384522079216 + 0.81388737057995 + 0.81393461718463 + 0.81398789740153 + 0.81404838248480 + 0.81411768420399 + 0.81419776748596 + 0.81429094747971 + 0.81440016616170 + 0.81452919334275 + 0.81468296973112 + 0.81486856279373 + 0.81509741570775 + 0.81538560850393 + 0.81575256156779 + 0.81622314261737 + 0.81683146228553 + 0.81762369593453 + 0.81866396331839 + 0.82004334389495 + 0.82189474645354 + 0.82441932834745 + 0.82793764127769 + 0.83300186446928 + 0.84067606358199 + 0.85333495936770 + 0.87805024198853 + 1.00000000000000 + 0.89830022226776 + 0.86627578287474 + 0.84486484758909 + 0.82850302807422 + 0.81513003181492 + 0.80371962134349 + 0.79367433107802 + 0.78461010449951 + 0.77626222857961 + 0.76843572153969 + 0.76092417451301 + 0.75340434385960 + 0.74570184216134 + 0.73776572804871 + 0.72954491538123 + 0.72102918632916 + 0.71221805993338 + 0.70311875378702 + 0.69374465976962 + 0.68411408441533 + 0.67424678429980 + 0.66412189063855 + 0.65375687652072 + 0.64317234487370 + 0.63239306266281 + 0.62144945117915 + 0.61037916741721 + 0.59920579391152 + 0.58795483170221 + 0.57667706443067 + 0.56542608692286 + 0.55425300052240 + 0.80744249541767 + 0.80744250771463 + 0.80744250975211 + 0.80744251212754 + 0.80744251489632 + 0.80744251812364 + 0.80744252188560 + 0.80744252627210 + 0.80744253138866 + 0.80744253737471 + 0.80744254444225 + 0.80744255291886 + 0.80744256320295 + 0.80744257572982 + 0.80744259101185 + 0.80744260966641 + 0.80744263245283 + 0.80744266029545 + 0.80744269439806 + 0.80744273633175 + 0.80744278795162 + 0.80744285156602 + 0.80744293004109 + 0.80744302694855 + 0.80744314679728 + 0.80744329559556 + 0.80744348203191 + 0.80744371766686 + 0.80744401646415 + 0.80744439566260 + 0.80744487950744 + 0.80744549848433 + 0.80744629139684 + 0.80744730827357 + 0.80744861359879 + 0.80745029041530 + 0.80745244559012 + 0.80745521650410 + 0.80745878752830 + 0.80746340776624 + 0.80746939394713 + 0.80747716044797 + 0.80748724660116 + 0.80750030824197 + 0.80751683811010 + 0.80753694479537 + 0.80756100823244 + 0.80758938004605 + 0.80762160808582 + 0.80765744853828 + 0.80769730496210 + 0.80774183367402 + 0.80779186508043 + 0.80784843302764 + 0.80791296413678 + 0.80798718506533 + 0.80807310867982 + 0.80817328138319 + 0.80829095229788 + 0.80843036848717 + 0.80859763459530 + 0.80880276321926 + 0.80905981967585 + 0.80938557886039 + 0.80980132232072 + 0.81033609338810 + 0.81102888889848 + 0.81193338101474 + 0.81312498065991 + 0.81471219453218 + 0.81685623450758 + 0.81980771921211 + 0.82398428961876 + 0.83015381508106 + 0.83989606505294 + 0.85719115731466 + 0.89830022226776 + 1.00000000000000 + 0.89302481352780 + 0.86026675003615 + 0.83867991886949 + 0.82234682021694 + 0.80907983415314 + 0.79779462198201 + 0.78786491038532 + 0.77889192802371 + 0.77060056812721 + 0.76273204366720 + 0.75492528725391 + 0.74698523143752 + 0.73884979134368 + 0.73046004742984 + 0.72180074221966 + 0.71286756705963 + 0.70366466148168 + 0.69420283212798 + 0.68449815334418 + 0.67456841078354 + 0.66439081271660 + 0.65398137316652 + 0.64335941485493 + 0.63254859547328 + 0.62157839118279 + 0.61048566908564 + 0.59929333351472 + 0.58802634593270 + 0.57673509001349 + 0.56547283981876 + 0.55429043050486 + 0.80132884399652 + 0.80132885547319 + 0.80132885737457 + 0.80132885959137 + 0.80132886217523 + 0.80132886518670 + 0.80132886869777 + 0.80132887279154 + 0.80132887756673 + 0.80132888315343 + 0.80132888975164 + 0.80132889767204 + 0.80132890729134 + 0.80132891902149 + 0.80132893334822 + 0.80132895085707 + 0.80132897226525 + 0.80132899845140 + 0.80132903055897 + 0.80132907008141 + 0.80132911878148 + 0.80132917885796 + 0.80132925303853 + 0.80132934472664 + 0.80132945821754 + 0.80132959924850 + 0.80132977612203 + 0.80132999989702 + 0.80133028393170 + 0.80133064471616 + 0.80133110547146 + 0.80133169539553 + 0.80133245165231 + 0.80133342217169 + 0.80133466872972 + 0.80133627087825 + 0.80133833098381 + 0.80134098060617 + 0.80134439631941 + 0.80134881670354 + 0.80135454492458 + 0.80136197745469 + 0.80137163000742 + 0.80138412885151 + 0.80139994053688 + 0.80141915838522 + 0.80144213374709 + 0.80146918612581 + 0.80149985644353 + 0.80153388122535 + 0.80157161203087 + 0.80161363251707 + 0.80166067921847 + 0.80171366514882 + 0.80177385425084 + 0.80184276470885 + 0.80192214638718 + 0.80201420271599 + 0.80212173294818 + 0.80224838663553 + 0.80239943913587 + 0.80258366526975 + 0.80281338917243 + 0.80310311811715 + 0.80347108248701 + 0.80394204206561 + 0.80454898099724 + 0.80533691793261 + 0.80636846953016 + 0.80773258207414 + 0.80955921631256 + 0.81204602280113 + 0.81551313867722 + 0.82052701549479 + 0.82818084299581 + 0.84092533213723 + 0.86627578287474 + 0.89302481352780 + 1.00000000000000 + 0.88759804913920 + 0.85419336185137 + 0.83250384711569 + 0.81624666848803 + 0.80310886202635 + 0.79195331785505 + 0.78212995631118 + 0.77322592460413 + 0.76489880996829 + 0.75673122375433 + 0.74849757848911 + 0.74011921996680 + 0.73152592037493 + 0.72269520804949 + 0.71361744451168 + 0.70429260355584 + 0.69472808597517 + 0.68493709530094 + 0.67493493581122 + 0.66469645268111 + 0.65423587590817 + 0.64357098009103 + 0.63272409292430 + 0.62172356472443 + 0.61060532628602 + 0.59939148263796 + 0.58810636118799 + 0.57679987557452 + 0.56552492397627 + 0.55433203088283 + 0.79528639567776 + 0.79528640637444 + 0.79528640814759 + 0.79528641021292 + 0.79528641262111 + 0.79528641542825 + 0.79528641870033 + 0.79528642251596 + 0.79528642696633 + 0.79528643217320 + 0.79528643832522 + 0.79528644571782 + 0.79528645470583 + 0.79528646568002 + 0.79528647909906 + 0.79528649551860 + 0.79528651561888 + 0.79528654023328 + 0.79528657044681 + 0.79528660768023 + 0.79528665361161 + 0.79528671032965 + 0.79528678043667 + 0.79528686717545 + 0.79528697464012 + 0.79528710830651 + 0.79528727611859 + 0.79528748865685 + 0.79528775870828 + 0.79528810205511 + 0.79528854094852 + 0.79528910336927 + 0.79528982493734 + 0.79529075159573 + 0.79529194256303 + 0.79529347410295 + 0.79529544433343 + 0.79529797933452 + 0.79530124833107 + 0.79530547999106 + 0.79531096471970 + 0.79531808214503 + 0.79532732579868 + 0.79533929421187 + 0.79535442964611 + 0.79537281182206 + 0.79539476611822 + 0.79542058313378 + 0.79544979945454 + 0.79548213575576 + 0.79551789786559 + 0.79555760530076 + 0.79560191198064 + 0.79565162496803 + 0.79570786564173 + 0.79577197036586 + 0.79584546096332 + 0.79593024461563 + 0.79602873344254 + 0.79614406439674 + 0.79628080128944 + 0.79644665109616 + 0.79665243699448 + 0.79691072782857 + 0.79723716482036 + 0.79765289439078 + 0.79818587199873 + 0.79887395268338 + 0.79976929758701 + 0.80094513187940 + 0.80250683672550 + 0.80461156956699 + 0.80750768423890 + 0.81162088293232 + 0.81773096246040 + 0.82743635298630 + 0.84486484758909 + 0.86026675003615 + 0.88759804913920 + 1.00000000000000 + 0.88203192396180 + 0.84807771798148 + 0.82635782362084 + 0.81021666321961 + 0.79722220555436 + 0.78619194551287 + 0.77645408444869 + 0.76752315258217 + 0.75889312388549 + 0.75029130327366 + 0.74161352537176 + 0.73277275336801 + 0.72373594872616 + 0.71448590699755 + 0.70501687105489 + 0.69533169162872 + 0.68543983599987 + 0.67535345312548 + 0.66504446030051 + 0.65452489124097 + 0.64381063806186 + 0.63292242669225 + 0.62188726148872 + 0.61073996010859 + 0.59950168328792 + 0.58819601180638 + 0.57687230605724 + 0.56558302314462 + 0.55437832455932 + 0.78931835983529 + 0.78931836979342 + 0.78931837144353 + 0.78931837336640 + 0.78931837560809 + 0.78931837822165 + 0.78931838126780 + 0.78931838481901 + 0.78931838896190 + 0.78931839380988 + 0.78931839954008 + 0.78931840643082 + 0.78931841482077 + 0.78931842507878 + 0.78931843763883 + 0.78931845302765 + 0.78931847189011 + 0.78931849501529 + 0.78931852343709 + 0.78931855850335 + 0.78931860181154 + 0.78931865535283 + 0.78931872160426 + 0.78931880365788 + 0.78931890542053 + 0.78931903212079 + 0.78931919135847 + 0.78931939326533 + 0.78931965008852 + 0.78931997694438 + 0.78932039516282 + 0.78932093157567 + 0.78932162034450 + 0.78932250553903 + 0.78932364396398 + 0.78932510878090 + 0.78932699410386 + 0.78932942085065 + 0.78933255133120 + 0.78933660486912 + 0.78934185987798 + 0.78934868014926 + 0.78935753837500 + 0.78936900709522 + 0.78938350604953 + 0.78940110288056 + 0.78942209938239 + 0.78944676018341 + 0.78947461976846 + 0.78950538631121 + 0.78953932551410 + 0.78957690038530 + 0.78961869229927 + 0.78966541560730 + 0.78971806705142 + 0.78977782480372 + 0.78984601357479 + 0.78992428549815 + 0.79001472071052 + 0.79012001805228 + 0.79024413285235 + 0.79039385310591 + 0.79057871081930 + 0.79080962174450 + 0.79110003516988 + 0.79146805539935 + 0.79193743821919 + 0.79254011230269 + 0.79331969050300 + 0.79433673694705 + 0.79567721869434 + 0.79746710660012 + 0.79990124761920 + 0.80330491647833 + 0.80824857551558 + 0.81581963555918 + 0.82850302807422 + 0.83867991886949 + 0.85419336185137 + 0.88203192396180 + 1.00000000000000 + 0.87634066882480 + 0.84194269834623 + 0.82026099448402 + 0.80426689746267 + 0.79141998341775 + 0.78049729070230 + 0.77074519627838 + 0.76150786888593 + 0.75243573988321 + 0.74338366523391 + 0.73423873519337 + 0.72495200586822 + 0.71549528734865 + 0.70585478780212 + 0.69602718143436 + 0.68601700680927 + 0.67583235477767 + 0.66544148077327 + 0.65485369348157 + 0.64408258133938 + 0.63314693123328 + 0.62207213166704 + 0.61089167245188 + 0.59962559557183 + 0.58829660059263 + 0.57695339546170 + 0.56564791892792 + 0.55442990774917 + 0.78342334971664 + 0.78342335897823 + 0.78342336051287 + 0.78342336230151 + 0.78342336438638 + 0.78342336681645 + 0.78342336964975 + 0.78342337295214 + 0.78342337680508 + 0.78342338131390 + 0.78342338664579 + 0.78342339306514 + 0.78342340089002 + 0.78342341047257 + 0.78342342222268 + 0.78342343663822 + 0.78342345433195 + 0.78342347605246 + 0.78342350278042 + 0.78342353580001 + 0.78342357663247 + 0.78342362717385 + 0.78342368978332 + 0.78342376741068 + 0.78342386378606 + 0.78342398390596 + 0.78342413504240 + 0.78342432690796 + 0.78342457123347 + 0.78342488250591 + 0.78342528118927 + 0.78342579302732 + 0.78342645080370 + 0.78342729681732 + 0.78342838560046 + 0.78342978738461 + 0.78343159251001 + 0.78343391703066 + 0.78343691673754 + 0.78344080216527 + 0.78344584043138 + 0.78345238044220 + 0.78346087531770 + 0.78347187322971 + 0.78348577302587 + 0.78350263165495 + 0.78352272950384 + 0.78354630787773 + 0.78357290109919 + 0.78360220775869 + 0.78363445842146 + 0.78367006638932 + 0.78370954941050 + 0.78375354087309 + 0.78380292870592 + 0.78385875371823 + 0.78392217065394 + 0.78399461266937 + 0.78407787606406 + 0.78417428636655 + 0.78428728002154 + 0.78442285556788 + 0.78458943595251 + 0.78479652974474 + 0.78505573413292 + 0.78538259620717 + 0.78579736849109 + 0.78632707934059 + 0.78700834957996 + 0.78789152879050 + 0.78904719459943 + 0.79057714860679 + 0.79263594231607 + 0.79547597606832 + 0.79952394014823 + 0.80554512060922 + 0.81513003181492 + 0.82234682021694 + 0.83250384711569 + 0.84807771798148 + 0.87634066882480 + 1.00000000000000 + 0.87054076136248 + 0.83581126046596 + 0.81422958533651 + 0.79840274207068 + 0.78569216718205 + 0.77477348716488 + 0.76471256858706 + 0.75502518294880 + 0.74549680060986 + 0.73597296005532 + 0.72637997564074 + 0.71667327349901 + 0.70682754545841 + 0.69683092551682 + 0.68668134922268 + 0.67638162003767 + 0.66589536401709 + 0.65522847827735 + 0.64439171142313 + 0.63340148897211 + 0.62228125017312 + 0.61106289461200 + 0.59976513453814 + 0.58840962663127 + 0.57704430774913 + 0.56572050632666 + 0.55448746140414 + 0.77759546379777 + 0.77759547240466 + 0.77759547383067 + 0.77759547549252 + 0.77759547742986 + 0.77759547968816 + 0.77759548232086 + 0.77759548538994 + 0.77759548897068 + 0.77759549316123 + 0.77759549811906 + 0.77759550409388 + 0.77759551138955 + 0.77759552033631 + 0.77759553132402 + 0.77759554482455 + 0.77759556141869 + 0.77759558181587 + 0.77759560695004 + 0.77759563804278 + 0.77759567654327 + 0.77759572425632 + 0.77759578343462 + 0.77759585689010 + 0.77759594818583 + 0.77759606209909 + 0.77759620559594 + 0.77759638798186 + 0.77759662051020 + 0.77759691706989 + 0.77759729730388 + 0.77759778592963 + 0.77759841442757 + 0.77759922342190 + 0.77760026529856 + 0.77760160751893 + 0.77760333686547 + 0.77760556480555 + 0.77760844098064 + 0.77761216763469 + 0.77761700124937 + 0.77762327671975 + 0.77763142875412 + 0.77764198265515 + 0.77765531788965 + 0.77767148193507 + 0.77769073575197 + 0.77771329971767 + 0.77773870964526 + 0.77776665710361 + 0.77779734192879 + 0.77783113372620 + 0.77786849450209 + 0.77790998698586 + 0.77795640420528 + 0.77800866782457 + 0.77806778627425 + 0.77813500506730 + 0.77821187834650 + 0.77830041431440 + 0.77840360779177 + 0.77852677974819 + 0.77867740111876 + 0.77886378391484 + 0.77909596225483 + 0.77938733561636 + 0.77975523600159 + 0.78022264018718 + 0.78082044585061 + 0.78159074677114 + 0.78259188025602 + 0.78390681222085 + 0.78565947595273 + 0.78804863066183 + 0.79139997110893 + 0.79626800166744 + 0.80371962134349 + 0.80907983415314 + 0.81624666848803 + 0.82635782362084 + 0.84194269834623 + 0.87054076136248 + 1.00000000000000 + 0.86465085201536 + 0.82970558797543 + 0.80827587825843 + 0.79261877911250 + 0.77993823768951 + 0.76871053924785 + 0.75819248739305 + 0.74804387243714 + 0.73803987897757 + 0.72806674310527 + 0.71805465008235 + 0.70796134620774 + 0.69776290057516 + 0.68744824350861 + 0.67701318607880 + 0.66641542886851 + 0.65565655370178 + 0.64474377873901 + 0.63369063400254 + 0.62251819410830 + 0.61125644550636 + 0.59992251402495 + 0.58853681827613 + 0.57714638147790 + 0.56580181199519 + 0.55455176456781 + 0.77182468846637 + 0.77182469646080 + 0.77182469778562 + 0.77182469932954 + 0.77182470112912 + 0.77182470322643 + 0.77182470567175 + 0.77182470852229 + 0.77182471184824 + 0.77182471574102 + 0.77182472034933 + 0.77182472590898 + 0.77182473270850 + 0.77182474106114 + 0.77182475133441 + 0.77182476397716 + 0.77182477953934 + 0.77182479869646 + 0.77182482233370 + 0.77182485161677 + 0.77182488792523 + 0.77182493297919 + 0.77182498892802 + 0.77182505845953 + 0.77182514497194 + 0.77182525303711 + 0.77182538933337 + 0.77182556278470 + 0.77182578418271 + 0.77182606685818 + 0.77182642967256 + 0.77182689636923 + 0.77182749719617 + 0.77182827119714 + 0.77182926871997 + 0.77183055460920 + 0.77183221228256 + 0.77183434886696 + 0.77183710819874 + 0.77184068468591 + 0.77184532476767 + 0.77185135012432 + 0.77185917811273 + 0.77186931252793 + 0.77188211480816 + 0.77189762408140 + 0.77191608364632 + 0.77193769508683 + 0.77196199716724 + 0.77198867664333 + 0.77201790651691 + 0.77205001797498 + 0.77208542418082 + 0.77212462622525 + 0.77216833433572 + 0.77221736685931 + 0.77227260637783 + 0.77233513774877 + 0.77240630878354 + 0.77248785827037 + 0.77258240548527 + 0.77269468974617 + 0.77283136442557 + 0.77299972409682 + 0.77320848403696 + 0.77346924003047 + 0.77379688875246 + 0.77421105477738 + 0.77473794484500 + 0.77541296469498 + 0.77628468089439 + 0.77742130006030 + 0.77892329782185 + 0.78094944533377 + 0.78375311748842 + 0.78774672330449 + 0.79367433107802 + 0.79779462198201 + 0.80310886202635 + 0.81021666321961 + 0.82026099448402 + 0.83581126046596 + 0.86465085201536 + 1.00000000000000 + 0.85869158129920 + 0.82364585082172 + 0.80240089614276 + 0.78680829155979 + 0.77382256326591 + 0.76213363930405 + 0.75115232461459 + 0.74052634004514 + 0.73007360171556 + 0.71968382023843 + 0.70928900363951 + 0.69884773714035 + 0.68833641171695 + 0.67774143068790 + 0.66701280093575 + 0.65614658077364 + 0.64514555647468 + 0.63401967935205 + 0.62278713691958 + 0.61147560186875 + 0.60010029916744 + 0.58868017239826 + 0.57726115903459 + 0.56589301580461 + 0.55462371010781 + 0.76609769476963 + 0.76609770219468 + 0.76609770342488 + 0.76609770485874 + 0.76609770653010 + 0.76609770847804 + 0.76609771074916 + 0.76609771339658 + 0.76609771648545 + 0.76609772010113 + 0.76609772438394 + 0.76609772955761 + 0.76609773589452 + 0.76609774369200 + 0.76609775329899 + 0.76609776514066 + 0.76609777973832 + 0.76609779773523 + 0.76609781997209 + 0.76609784755902 + 0.76609788181102 + 0.76609792437168 + 0.76609797728898 + 0.76609804313011 + 0.76609812514717 + 0.76609822771276 + 0.76609835722719 + 0.76609852225701 + 0.76609873315994 + 0.76609900272854 + 0.76609934908866 + 0.76609979505899 + 0.76610036971617 + 0.76610111060057 + 0.76610206612871 + 0.76610329866615 + 0.76610488843106 + 0.76610693844414 + 0.76610958703597 + 0.76611302118549 + 0.76611747782358 + 0.76612326612398 + 0.76613078704371 + 0.76614052408173 + 0.76615282186857 + 0.76616771216825 + 0.76618542220159 + 0.76620613666142 + 0.76622939853256 + 0.76625489169557 + 0.76628276572008 + 0.76631331798480 + 0.76634691882346 + 0.76638401549248 + 0.76642524590503 + 0.76647133872601 + 0.76652306824077 + 0.76658138173249 + 0.76664745117282 + 0.76672278661094 + 0.76680968778255 + 0.76691239388205 + 0.76703685492967 + 0.76718949924116 + 0.76737792805191 + 0.76761222028760 + 0.76790523875626 + 0.76827382919056 + 0.76874034384998 + 0.76933475262733 + 0.77009778826169 + 0.77108602313400 + 0.77238181121049 + 0.77411375324616 + 0.77648254083478 + 0.77980236207922 + 0.78461010449951 + 0.78786491038532 + 0.79195331785505 + 0.79722220555436 + 0.80426689746267 + 0.81422958533651 + 0.82970558797543 + 0.85869158129920 + 1.00000000000000 + 0.85268482480427 + 0.81764094260420 + 0.79648832689841 + 0.78059973703122 + 0.76715609551384 + 0.75500894178739 + 0.74355331906473 + 0.73248272108611 + 0.72161858134227 + 0.71085224873045 + 0.70011618022168 + 0.68936887164092 + 0.67858381206816 + 0.66770085138041 + 0.65670888039947 + 0.64560505910420 + 0.63439487495444 + 0.62309296404651 + 0.61172418368626 + 0.60030146987963 + 0.58884200157093 + 0.57739042157384 + 0.56599547652126 + 0.55470432337527 + 0.76039891691677 + 0.76039892381405 + 0.76039892495679 + 0.76039892628903 + 0.76039892784129 + 0.76039892965132 + 0.76039893176075 + 0.76039893422009 + 0.76039893708926 + 0.76039894044857 + 0.76039894442984 + 0.76039894924543 + 0.76039895515321 + 0.76039896243564 + 0.76039897142307 + 0.76039898251905 + 0.76039899621883 + 0.76039901313231 + 0.76039903406091 + 0.76039906006389 + 0.76039909239323 + 0.76039913261656 + 0.76039918269259 + 0.76039924507234 + 0.76039932286463 + 0.76039942025787 + 0.76039954339204 + 0.76039970048734 + 0.76039990148895 + 0.76040015868243 + 0.76040048948973 + 0.76040091584753 + 0.76040146572061 + 0.76040217521678 + 0.76040309091249 + 0.76040427281008 + 0.76040579809036 + 0.76040776585883 + 0.76041030921161 + 0.76041360805756 + 0.76041789028415 + 0.76042345318946 + 0.76043068215796 + 0.76044004146934 + 0.76045186000837 + 0.76046616306246 + 0.76048316317679 + 0.76050302983427 + 0.76052531136411 + 0.76054969047068 + 0.76057629625006 + 0.76060539628271 + 0.76063732325926 + 0.76067247733879 + 0.76071143311800 + 0.76075484125707 + 0.76080338268005 + 0.76085788667926 + 0.76091937512514 + 0.76098916354496 + 0.76106927917662 + 0.76116352981421 + 0.76127725839163 + 0.76141615354103 + 0.76158687289417 + 0.76179821596422 + 0.76206134164305 + 0.76239078400972 + 0.76280571531169 + 0.76333166614059 + 0.76400305188062 + 0.76486720807668 + 0.76599235984672 + 0.76748406214777 + 0.76950398909305 + 0.77229689488797 + 0.77626222857961 + 0.77889192802371 + 0.78212995631118 + 0.78619194551287 + 0.79141998341775 + 0.79840274207068 + 0.80827587825843 + 0.82364585082172 + 0.85268482480427 + 1.00000000000000 + 0.84664156229309 + 0.81155564412425 + 0.79011208477360 + 0.77378529787578 + 0.75990463336193 + 0.74729688636052 + 0.73540790367556 + 0.72393606868816 + 0.71270521029234 + 0.70160722296200 + 0.69057429510562 + 0.67956176182557 + 0.66849580004560 + 0.65735585057004 + 0.64613183710315 + 0.63482361967095 + 0.62344142777036 + 0.61200666866004 + 0.60052950605817 + 0.58902499768269 + 0.57753623641125 + 0.56611076693213 + 0.55479478801362 + 0.75470897614481 + 0.75470898255602 + 0.75470898361777 + 0.75470898485570 + 0.75470898629889 + 0.75470898798110 + 0.75470898994161 + 0.75470899222736 + 0.75470899489434 + 0.75470899801707 + 0.75470900171970 + 0.75470900620476 + 0.75470901171607 + 0.75470901852148 + 0.75470902693496 + 0.75470903733873 + 0.75470905020367 + 0.75470906610920 + 0.75470908582081 + 0.75470911034391 + 0.75470914087636 + 0.75470917891403 + 0.75470922632699 + 0.75470928545973 + 0.75470935928601 + 0.75470945181793 + 0.75470956894229 + 0.75470971855665 + 0.75470991020828 + 0.75471015569961 + 0.75471047177781 + 0.75471087954341 + 0.75471140588849 + 0.75471208555680 + 0.75471296336194 + 0.75471409705030 + 0.75471556088793 + 0.75471745024625 + 0.75471989321123 + 0.75472306292700 + 0.75472717864859 + 0.75473252632091 + 0.75473947647181 + 0.75474847507033 + 0.75475983619496 + 0.75477357943568 + 0.75478990387886 + 0.75480896527017 + 0.75483031830544 + 0.75485364600077 + 0.75487905954540 + 0.75490680016605 + 0.75493716736472 + 0.75497051995389 + 0.75500737687886 + 0.75504832069061 + 0.75509395157287 + 0.75514499726286 + 0.75520235108225 + 0.75526716252978 + 0.75534122546551 + 0.75542797364834 + 0.75553222326467 + 0.75565902827675 + 0.75581424326006 + 0.75600558317959 + 0.75624277195790 + 0.75653840982353 + 0.75690902923552 + 0.75737651019512 + 0.75797013329887 + 0.75872983285780 + 0.75971269559962 + 0.76100642764092 + 0.76274330076627 + 0.76511789311505 + 0.76843572153969 + 0.77060056812721 + 0.77322592460413 + 0.77645408444869 + 0.78049729070230 + 0.78569216718205 + 0.79261877911250 + 0.80240089614276 + 0.81764094260420 + 0.84664156229309 + 1.00000000000000 + 0.84038050349488 + 0.80487508103927 + 0.78304294713365 + 0.76633639041482 + 0.75203178652148 + 0.73901586035420 + 0.72674436186686 + 0.71492132850651 + 0.70337251745678 + 0.69198997954376 + 0.68070277648423 + 0.66941823887876 + 0.65810310669455 + 0.64673784899036 + 0.63531513912112 + 0.62383968035788 + 0.61232861482020 + 0.60078872394152 + 0.58923249979774 + 0.57770116999241 + 0.56624084259848 + 0.55489657918048 + 0.74895892700104 + 0.74895893296237 + 0.74895893395019 + 0.74895893510138 + 0.74895893644316 + 0.74895893800735 + 0.74895893983026 + 0.74895894195551 + 0.74895894443529 + 0.74895894734030 + 0.74895895078562 + 0.74895895496434 + 0.74895896010757 + 0.74895896647004 + 0.74895897434860 + 0.74895898410691 + 0.74895899619170 + 0.74895901115450 + 0.74895902972249 + 0.74895905285793 + 0.74895908170045 + 0.74895911767851 + 0.74895916257915 + 0.74895921864261 + 0.74895928871378 + 0.74895937663366 + 0.74895948804844 + 0.74895963053896 + 0.74895981327046 + 0.74896004757827 + 0.74896034955847 + 0.74896073949202 + 0.74896124323789 + 0.74896189421059 + 0.74896273551718 + 0.74896382270519 + 0.74896522722045 + 0.74896704080119 + 0.74896938666751 + 0.74897243139377 + 0.74897638584589 + 0.74898152495585 + 0.74898820483845 + 0.74899685374254 + 0.74900777158514 + 0.74902097290273 + 0.74903664427275 + 0.74905492886460 + 0.74907538877721 + 0.74909770872348 + 0.74912198407272 + 0.74914843247140 + 0.74917732381212 + 0.74920898017071 + 0.74924387096858 + 0.74928251856653 + 0.74932545251939 + 0.74937331218607 + 0.74942687953795 + 0.74948716076149 + 0.74955574736047 + 0.74963574424093 + 0.74973150412791 + 0.74984752912320 + 0.74998898143338 + 0.75016264447525 + 0.75037701753045 + 0.75064306090543 + 0.75097508469845 + 0.75139192246439 + 0.75191861569473 + 0.75258906800218 + 0.75345142128151 + 0.75457926355563 + 0.75608216877228 + 0.75811743167107 + 0.76092417451301 + 0.76273204366720 + 0.76489880996829 + 0.76752315258217 + 0.77074519627838 + 0.77477348716488 + 0.77993823768951 + 0.78680829155979 + 0.79648832689841 + 0.81155564412425 + 0.84038050349488 + 1.00000000000000 + 0.83335473876782 + 0.79744462563301 + 0.77534122817997 + 0.75828040669300 + 0.74360904830988 + 0.73023608327193 + 0.71763142970407 + 0.70550497335107 + 0.69368407655487 + 0.68205807760898 + 0.67050735687300 + 0.65898104434660 + 0.64744691559579 + 0.63588824262634 + 0.62430264758948 + 0.61270189594209 + 0.60108856764091 + 0.58947199895221 + 0.57789113693271 + 0.56639034626470 + 0.55501331871306 + 0.74294818123040 + 0.74294818676761 + 0.74294818768503 + 0.74294818875431 + 0.74294819000052 + 0.74294819145301 + 0.74294819314665 + 0.74294819512092 + 0.74294819742430 + 0.74294820012300 + 0.74294820332560 + 0.74294820721457 + 0.74294821201016 + 0.74294821795168 + 0.74294822532143 + 0.74294823446314 + 0.74294824580183 + 0.74294825986092 + 0.74294827733031 + 0.74294829912755 + 0.74294832633774 + 0.74294836032071 + 0.74294840278124 + 0.74294845585653 + 0.74294852226424 + 0.74294860567510 + 0.74294871149235 + 0.74294884698102 + 0.74294902092294 + 0.74294924418072 + 0.74294953219189 + 0.74294990441798 + 0.74295038567305 + 0.74295100802441 + 0.74295181285716 + 0.74295285349359 + 0.74295419852396 + 0.74295593600900 + 0.74295818424370 + 0.74296110314378 + 0.74296489508238 + 0.74296982383481 + 0.74297623093511 + 0.74298452672220 + 0.74299499699364 + 0.74300765167490 + 0.74302266523043 + 0.74304016889366 + 0.74305973355578 + 0.74308104712979 + 0.74310419061464 + 0.74312935985321 + 0.74315679745649 + 0.74318679182082 + 0.74321976682859 + 0.74325618994470 + 0.74329652710136 + 0.74334133846816 + 0.74339130679182 + 0.74344731096919 + 0.74351076161621 + 0.74358446457111 + 0.74367235060436 + 0.74377842619637 + 0.74390723764468 + 0.74406474278531 + 0.74425836280159 + 0.74449762346086 + 0.74479490452744 + 0.74516641561188 + 0.74563358403466 + 0.74622523399417 + 0.74698207049924 + 0.74796609061164 + 0.74926863182034 + 0.75101807378223 + 0.75340434385960 + 0.75492528725391 + 0.75673122375433 + 0.75889312388549 + 0.76150786888593 + 0.76471256858706 + 0.76871053924785 + 0.77382256326591 + 0.78059973703122 + 0.79011208477360 + 0.80487508103927 + 0.83335473876782 + 1.00000000000000 + 0.82586081436224 + 0.78965703110948 + 0.76725544778685 + 0.74985426535157 + 0.73483122873300 + 0.72112326720386 + 0.70821254244665 + 0.69581233093537 + 0.68374727609712 + 0.67185662736787 + 0.66006364471087 + 0.64831813067848 + 0.63659043205775 + 0.62486866121278 + 0.61315749540697 + 0.60145406414689 + 0.58976365444467 + 0.57812230784266 + 0.56657218468615 + 0.55515525732183 + 0.73656731052002 + 0.73656731565509 + 0.73656731650551 + 0.73656731749743 + 0.73656731865303 + 0.73656732000028 + 0.73656732157029 + 0.73656732340119 + 0.73656732553731 + 0.73656732803988 + 0.73656733101240 + 0.73656733462543 + 0.73656733908800 + 0.73656734462612 + 0.73656735150657 + 0.73656736005503 + 0.73656737067272 + 0.73656738385505 + 0.73656740025753 + 0.73656742075003 + 0.73656744636347 + 0.73656747839094 + 0.73656751845344 + 0.73656756858438 + 0.73656763137006 + 0.73656771031078 + 0.73656781056590 + 0.73656793907119 + 0.73656810421862 + 0.73656831638863 + 0.73656859034456 + 0.73656894470082 + 0.73656940319947 + 0.73656999652358 + 0.73657076427757 + 0.73657175749425 + 0.73657304181638 + 0.73657470151819 + 0.73657684979908 + 0.73657963970233 + 0.73658326482504 + 0.73658797742942 + 0.73659410399554 + 0.73660203641049 + 0.73661204610642 + 0.73662413876899 + 0.73663847693045 + 0.73665518029637 + 0.73667383017846 + 0.73669411930196 + 0.73671611548232 + 0.73673999413779 + 0.73676597240022 + 0.73679430737340 + 0.73682538046816 + 0.73685960839811 + 0.73689739906695 + 0.73693924083496 + 0.73698572694217 + 0.73703762179233 + 0.73709617196727 + 0.73716390680340 + 0.73724436654253 + 0.73734110569654 + 0.73745811453236 + 0.73760060824605 + 0.73777504464989 + 0.73798967540984 + 0.73825517717223 + 0.73858546237247 + 0.73899882346022 + 0.73951972663643 + 0.74018256709931 + 0.74103960723281 + 0.74216715289627 + 0.74367049493195 + 0.74570184216134 + 0.74698523143752 + 0.74849757848911 + 0.75029130327366 + 0.75243573988321 + 0.75502518294880 + 0.75819248739305 + 0.76213363930405 + 0.76715609551384 + 0.77378529787578 + 0.78304294713365 + 0.79744462563301 + 0.82586081436224 + 1.00000000000000 + 0.81819641027634 + 0.78164640658218 + 0.75892905140921 + 0.74117039640524 + 0.72579448095692 + 0.71176297501515 + 0.69856487031142 + 0.68591046322850 + 0.67357198743117 + 0.66143257276176 + 0.64941535542540 + 0.63747216913381 + 0.62557788068420 + 0.61372751048362 + 0.60191090210655 + 0.59012800034441 + 0.57841104685393 + 0.56679934469466 + 0.55533265596481 + 0.72979585505037 + 0.72979585980505 + 0.72979586059270 + 0.72979586151067 + 0.72979586258067 + 0.72979586382790 + 0.72979586528217 + 0.72979586697704 + 0.72979586895507 + 0.72979587127254 + 0.72979587402644 + 0.72979587737821 + 0.72979588152414 + 0.72979588667759 + 0.72979589309017 + 0.72979590106853 + 0.72979591099077 + 0.72979592332557 + 0.72979593869336 + 0.72979595791709 + 0.72979598197318 + 0.72979601208613 + 0.72979604979365 + 0.72979609702446 + 0.72979615623498 + 0.72979623075081 + 0.72979632547836 + 0.72979644702535 + 0.72979660338081 + 0.72979680443197 + 0.72979706425107 + 0.72979740058298 + 0.72979783606263 + 0.72979839995411 + 0.72979913002737 + 0.72980007495319 + 0.72980129733843 + 0.72980287754325 + 0.72980492351934 + 0.72980758120798 + 0.72981103514658 + 0.72981552571359 + 0.72982136385940 + 0.72982892246750 + 0.72983845836508 + 0.72984997336800 + 0.72986361827236 + 0.72987950167484 + 0.72989721695363 + 0.72991646326372 + 0.72993729641630 + 0.72995987275094 + 0.72998438566628 + 0.73001106328080 + 0.73004024745994 + 0.73007230811371 + 0.73010760038285 + 0.73014654769692 + 0.73018966277156 + 0.73023760724114 + 0.73029147900873 + 0.73035355161312 + 0.73042700377204 + 0.73051497795541 + 0.73062096272690 + 0.73074950546430 + 0.73090620322731 + 0.73109817574635 + 0.73133459571652 + 0.73162736119193 + 0.73199203822435 + 0.73244933882154 + 0.73302827347312 + 0.73377286395053 + 0.73474689316667 + 0.73603694515748 + 0.73776572804871 + 0.73884979134368 + 0.74011921996680 + 0.74161352537176 + 0.74338366523391 + 0.74549680060986 + 0.74804387243714 + 0.75115232461459 + 0.75500894178739 + 0.75990463336193 + 0.76633639041482 + 0.77534122817997 + 0.78965703110948 + 0.81819641027634 + 1.00000000000000 + 0.81029196830474 + 0.77343076509439 + 0.75037238303400 + 0.73224311130954 + 0.71651944147433 + 0.70218049618664 + 0.68871333907282 + 0.67577283724205 + 0.66317632821592 + 0.65080560751419 + 0.63858503244347 + 0.62647047499955 + 0.61444347755063 + 0.60248394803167 + 0.59058466378302 + 0.57877282418368 + 0.56708398291890 + 0.55555503164812 + 0.72260596914900 + 0.72260597354459 + 0.72260597427288 + 0.72260597512165 + 0.72260597611104 + 0.72260597726419 + 0.72260597860846 + 0.72260598017542 + 0.72260598200374 + 0.72260598414682 + 0.72260598669484 + 0.72260598979909 + 0.72260599364382 + 0.72260599843014 + 0.72260600439458 + 0.72260601182502 + 0.72260602107768 + 0.72260603259396 + 0.72260604695840 + 0.72260606494609 + 0.72260608748114 + 0.72260611572042 + 0.72260615111477 + 0.72260619548884 + 0.72260625116891 + 0.72260632129873 + 0.72260641053585 + 0.72260652514245 + 0.72260667270042 + 0.72260686259409 + 0.72260710818328 + 0.72260742632020 + 0.72260783850678 + 0.72260837254059 + 0.72260906430230 + 0.72260996003448 + 0.72261111920679 + 0.72261261814745 + 0.72261455939626 + 0.72261708155510 + 0.72262035982394 + 0.72262462231747 + 0.72263016397356 + 0.72263733811606 + 0.72264638672149 + 0.72265730812576 + 0.72267024156976 + 0.72268528497652 + 0.72270204542677 + 0.72272023012118 + 0.72273988401018 + 0.72276114566218 + 0.72278418644076 + 0.72280920767223 + 0.72283651448170 + 0.72286643370218 + 0.72289927266989 + 0.72293539630830 + 0.72297524512436 + 0.72301938875007 + 0.72306879045190 + 0.72312548704362 + 0.72319232254321 + 0.72327206405615 + 0.72336774796879 + 0.72348332173391 + 0.72362361404538 + 0.72379473963092 + 0.72400454335383 + 0.72426315607747 + 0.72458376960010 + 0.72498385385785 + 0.72548780560214 + 0.72613262969989 + 0.72697158958057 + 0.72807593456191 + 0.72954491538123 + 0.73046004742984 + 0.73152592037493 + 0.73277275336801 + 0.73423873519337 + 0.73597296005532 + 0.73803987897757 + 0.74052634004514 + 0.74355331906473 + 0.74729688636052 + 0.75203178652148 + 0.75828040669300 + 0.76725544778685 + 0.78164640658218 + 0.81029196830474 + 1.00000000000000 + 0.80225729305704 + 0.76506093367611 + 0.74162037321246 + 0.72310699000953 + 0.70704256785480 + 0.69240971080229 + 0.67863606659822 + 0.66542287258236 + 0.65258406487332 + 0.64000130851124 + 0.62760219431502 + 0.61534885735916 + 0.60320729942674 + 0.59116046605131 + 0.57922873505944 + 0.56744265745979 + 0.55583534345099 + 0.71500153279062 + 0.71500153684870 + 0.71500153752096 + 0.71500153830428 + 0.71500153921816 + 0.71500154028270 + 0.71500154152386 + 0.71500154297074 + 0.71500154465869 + 0.71500154663730 + 0.71500154899083 + 0.71500155186089 + 0.71500155542078 + 0.71500155985824 + 0.71500156539406 + 0.71500157229971 + 0.71500158090861 + 0.71500159163490 + 0.71500160502772 + 0.71500162181779 + 0.71500164287208 + 0.71500166927977 + 0.71500170240783 + 0.71500174397598 + 0.71500179617469 + 0.71500186197230 + 0.71500194576461 + 0.71500205347152 + 0.71500219225896 + 0.71500237099269 + 0.71500260231031 + 0.71500290215174 + 0.71500329085742 + 0.71500379472457 + 0.71500444770463 + 0.71500529354374 + 0.71500638850270 + 0.71500780477757 + 0.71500963934727 + 0.71501202330255 + 0.71501512225727 + 0.71501915176181 + 0.71502439035095 + 0.71503117134479 + 0.71503972172181 + 0.71505003673121 + 0.71506224431261 + 0.71507643218885 + 0.71509222267858 + 0.71510933252674 + 0.71512779699276 + 0.71514773821092 + 0.71516930721445 + 0.71519268077063 + 0.71521813007304 + 0.71524594258317 + 0.71527638268461 + 0.71530976300653 + 0.71534645981886 + 0.71538696101601 + 0.71543210862895 + 0.71548372139625 + 0.71554433499055 + 0.71561637651368 + 0.71570247731565 + 0.71580604916690 + 0.71593123900715 + 0.71608327443697 + 0.71626883436871 + 0.71649650694692 + 0.71677742500799 + 0.71712626756545 + 0.71756348552222 + 0.71812011051557 + 0.71884055401291 + 0.71978343543316 + 0.72102918632916 + 0.72180074221966 + 0.72269520804949 + 0.72373594872616 + 0.72495200586822 + 0.72637997564074 + 0.72806674310527 + 0.73007360171556 + 0.73248272108611 + 0.73540790367556 + 0.73901586035420 + 0.74360904830988 + 0.74985426535157 + 0.75892905140921 + 0.77343076509439 + 0.80225729305704 + 1.00000000000000 + 0.79410051331323 + 0.75653328872805 + 0.73267574100552 + 0.71377512438970 + 0.69738033712498 + 0.68241182969206 + 0.66834528965248 + 0.65487513528331 + 0.64181300798337 + 0.62904255128093 + 0.61649697721336 + 0.60412227555824 + 0.59188759336539 + 0.57980390041624 + 0.56789496579278 + 0.55618885306608 + 0.70699367040969 + 0.70699367415104 + 0.70699367477079 + 0.70699367549291 + 0.70699367633463 + 0.70699367731595 + 0.70699367845992 + 0.70699367979347 + 0.70699368134964 + 0.70699368317332 + 0.70699368534397 + 0.70699368799308 + 0.70699369128255 + 0.70699369538856 + 0.70699370051607 + 0.70699370691919 + 0.70699371490973 + 0.70699372487469 + 0.70699373732877 + 0.70699375295581 + 0.70699377256955 + 0.70699379719093 + 0.70699382810319 + 0.70699386691903 + 0.70699391569462 + 0.70699397722225 + 0.70699405563444 + 0.70699415650097 + 0.70699428656606 + 0.70699445417827 + 0.70699467123602 + 0.70699495275390 + 0.70699531789302 + 0.70699579142709 + 0.70699640533829 + 0.70699720083891 + 0.70699823092018 + 0.70699956357271 + 0.70700129012414 + 0.70700353400481 + 0.70700645108246 + 0.70701024412905 + 0.70701517500989 + 0.70702155675568 + 0.70702960130106 + 0.70703930121148 + 0.70705077344564 + 0.70706409605801 + 0.70707890794191 + 0.70709493674399 + 0.70711220917875 + 0.70713083229541 + 0.70715093852444 + 0.70717268227469 + 0.70719630362426 + 0.70722205431737 + 0.70725016046318 + 0.70728088836414 + 0.70731455764573 + 0.70735158414692 + 0.70739270144632 + 0.70743952841609 + 0.70749431826411 + 0.70755919208769 + 0.70763642094099 + 0.70772894157106 + 0.70784030021198 + 0.70797494671660 + 0.70813854285377 + 0.70833833821528 + 0.70858368991492 + 0.70888688557086 + 0.70926501331776 + 0.70974403102025 + 0.71036090491762 + 0.71116383131755 + 0.71221805993338 + 0.71286756705963 + 0.71361744451168 + 0.71448590699755 + 0.71549528734865 + 0.71667327349901 + 0.71805465008235 + 0.71968382023843 + 0.72161858134227 + 0.72393606868816 + 0.72674436186686 + 0.73023608327193 + 0.73483122873300 + 0.74117039640524 + 0.75037238303400 + 0.76506093367611 + 0.79410051331323 + 1.00000000000000 + 0.78582911424657 + 0.74784663967486 + 0.72354699503630 + 0.70426173190545 + 0.68748803534388 + 0.67219802358978 + 0.65785465311093 + 0.64414639803633 + 0.63088483868643 + 0.61795821206157 + 0.60528271270102 + 0.59280757726871 + 0.58053049646438 + 0.56846586801799 + 0.55663491424304 + 0.69859990083158 + 0.69859990427263 + 0.69859990484299 + 0.69859990550719 + 0.69859990628174 + 0.69859990718449 + 0.69859990823664 + 0.69859990946406 + 0.69859991089548 + 0.69859991257348 + 0.69859991457136 + 0.69859991701148 + 0.69859992004446 + 0.69859992383334 + 0.69859992857081 + 0.69859993449164 + 0.69859994188805 + 0.69859995111983 + 0.69859996266635 + 0.69859997716634 + 0.69859999538004 + 0.69860001826062 + 0.69860004700618 + 0.69860008312722 + 0.69860012854429 + 0.69860018586982 + 0.69860025897533 + 0.69860035308068 + 0.69860047450361 + 0.69860063106842 + 0.69860083393458 + 0.69860109718208 + 0.69860143877951 + 0.69860188196266 + 0.69860245672844 + 0.69860320172793 + 0.69860416665344 + 0.69860541524955 + 0.69860703313155 + 0.69860913600608 + 0.69861186990079 + 0.69861542471308 + 0.69862004551537 + 0.69862602494155 + 0.69863355996463 + 0.69864264086718 + 0.69865337401734 + 0.69866582837287 + 0.69867966049985 + 0.69869461009992 + 0.69871069645164 + 0.69872801285874 + 0.69874667485972 + 0.69876681666690 + 0.69878865000693 + 0.69881239445137 + 0.69883824231074 + 0.69886641919804 + 0.69889719520803 + 0.69893092319440 + 0.69896824030782 + 0.69901058326364 + 0.69905994802227 + 0.69911818208926 + 0.69918723831458 + 0.69926963523321 + 0.69936839361966 + 0.69948728636285 + 0.69963109408992 + 0.69980591268781 + 0.70001957719469 + 0.70028233728281 + 0.70060842796155 + 0.70101951145394 + 0.70154630350413 + 0.70222839654272 + 0.70311875378702 + 0.70366466148168 + 0.70429260355584 + 0.70501687105489 + 0.70585478780212 + 0.70682754545841 + 0.70796134620774 + 0.70928900363951 + 0.71085224873045 + 0.71270521029234 + 0.71492132850651 + 0.71763142970407 + 0.72112326720386 + 0.72579448095692 + 0.73224311130954 + 0.74162037321246 + 0.75653328872805 + 0.78582911424657 + 1.00000000000000 + 0.77745016892176 + 0.73900353778717 + 0.71424370431590 + 0.69451253945363 + 0.67737518856610 + 0.66178073710810 + 0.64717966396417 + 0.63325689088864 + 0.61982688457624 + 0.60675957176031 + 0.59397446915151 + 0.58144999377810 + 0.56918729299860 + 0.55719813861747 + 0.68984319557636 + 0.68984319873424 + 0.68984319925721 + 0.68984319986716 + 0.68984320057778 + 0.68984320140648 + 0.68984320237190 + 0.68984320349772 + 0.68984320481138 + 0.68984320635153 + 0.68984320818515 + 0.68984321042689 + 0.68984321321551 + 0.68984321670244 + 0.68984322106603 + 0.68984322652442 + 0.68984323334821 + 0.68984324187133 + 0.68984325253992 + 0.68984326594770 + 0.68984328280024 + 0.68984330398398 + 0.68984333061591 + 0.68984336409953 + 0.68984340622544 + 0.68984345942665 + 0.68984352731157 + 0.68984361475073 + 0.68984372763805 + 0.68984387327430 + 0.68984406207623 + 0.68984430718702 + 0.68984462538515 + 0.68984503836478 + 0.68984557413430 + 0.68984626877725 + 0.68984716868317 + 0.68984833334595 + 0.68984984267048 + 0.68985180462421 + 0.68985435541322 + 0.68985767205807 + 0.68986198288992 + 0.68986756022274 + 0.68987458629070 + 0.68988304948333 + 0.68989304602833 + 0.68990463639733 + 0.68991749566065 + 0.68993137647614 + 0.68994629174080 + 0.68996232233329 + 0.68997956854592 + 0.68999814648832 + 0.69001824222070 + 0.69004004653326 + 0.69006372212421 + 0.69008945916667 + 0.69011748480764 + 0.69014809724771 + 0.69018184842430 + 0.69022000993127 + 0.69026434478820 + 0.69031645746534 + 0.69037802174145 + 0.69045119052117 + 0.69053852821621 + 0.69064322266095 + 0.69076929645058 + 0.69092185772044 + 0.69110744503466 + 0.69133458118002 + 0.69161509214391 + 0.69196701712917 + 0.69241583803623 + 0.69299405110264 + 0.69374465976962 + 0.69420283212798 + 0.69472808597517 + 0.69533169162872 + 0.69602718143436 + 0.69683092551682 + 0.69776290057516 + 0.69884773714035 + 0.70011618022168 + 0.70160722296200 + 0.70337251745678 + 0.70550497335107 + 0.70821254244665 + 0.71176297501515 + 0.71651944147433 + 0.72310699000953 + 0.73267574100552 + 0.74784663967486 + 0.77745016892176 + 1.00000000000000 + 0.76897063194339 + 0.73000513378236 + 0.70469447787549 + 0.68453419067042 + 0.66705255871538 + 0.65117390329144 + 0.63633878120785 + 0.62223203011318 + 0.60864782246916 + 0.59545941624942 + 0.58261628928585 + 0.57010032800124 + 0.55790994968705 + 0.68075095811549 + 0.68075096100424 + 0.68075096148284 + 0.68075096204066 + 0.68075096269077 + 0.68075096344850 + 0.68075096433174 + 0.68075096536137 + 0.68075096656331 + 0.68075096797172 + 0.68075096964969 + 0.68075097170205 + 0.68075097425734 + 0.68075097745492 + 0.68075098146003 + 0.68075098647331 + 0.68075099274463 + 0.68075100058385 + 0.68075101040257 + 0.68075102274963 + 0.68075103827932 + 0.68075105781316 + 0.68075108238434 + 0.68075111329320 + 0.68075115220024 + 0.68075120136155 + 0.68075126412641 + 0.68075134501647 + 0.68075144950667 + 0.68075158437556 + 0.68075175930297 + 0.68075198650358 + 0.68075228157100 + 0.68075266466698 + 0.68075316182421 + 0.68075380657879 + 0.68075464204043 + 0.68075572348408 + 0.68075712514669 + 0.68075894733008 + 0.68076131650334 + 0.68076439695644 + 0.68076840046412 + 0.68077357931747 + 0.68078010134872 + 0.68078795342335 + 0.68079722214971 + 0.68080796014676 + 0.68081986152567 + 0.68083269255533 + 0.68084646072821 + 0.68086123576517 + 0.68087710430293 + 0.68089416632241 + 0.68091258478471 + 0.68093252489069 + 0.68095412359358 + 0.68097754042499 + 0.68100296556342 + 0.68103065011724 + 0.68106107112462 + 0.68109535123105 + 0.68113504369844 + 0.68118153837224 + 0.68123626585631 + 0.68130106145374 + 0.68137809586717 + 0.68147005465639 + 0.68158031257123 + 0.68171313743903 + 0.68187397018004 + 0.68206987839010 + 0.68231066381545 + 0.68261132192952 + 0.68299296476855 + 0.68348224421261 + 0.68411408441533 + 0.68449815334418 + 0.68493709530094 + 0.68543983599987 + 0.68601700680927 + 0.68668134922268 + 0.68744824350861 + 0.68833641171695 + 0.68936887164092 + 0.69057429510562 + 0.69198997954376 + 0.69368407655487 + 0.69581233093537 + 0.69856487031142 + 0.70218049618664 + 0.70704256785480 + 0.71377512438970 + 0.72354699503630 + 0.73900353778717 + 0.76897063194339 + 1.00000000000000 + 0.76038762685261 + 0.72074529058867 + 0.69490002972540 + 0.67433478824339 + 0.65653205412739 + 0.64039381289726 + 0.62535506108894 + 0.61107716250172 + 0.59735748746726 + 0.58410021463600 + 0.57125827675294 + 0.55881069645986 + 0.67135173040755 + 0.67135173303927 + 0.67135173347513 + 0.67135173398363 + 0.67135173457583 + 0.67135173526605 + 0.67135173607107 + 0.67135173700918 + 0.67135173810413 + 0.67135173938760 + 0.67135174091703 + 0.67135174278854 + 0.67135174511991 + 0.67135174804057 + 0.67135175170069 + 0.67135175628537 + 0.67135176202484 + 0.67135176920230 + 0.67135177819897 + 0.67135178951958 + 0.67135180376608 + 0.67135182169591 + 0.67135184426144 + 0.67135187266246 + 0.67135190843051 + 0.67135195364761 + 0.67135201140854 + 0.67135208589043 + 0.67135218215402 + 0.67135230646488 + 0.67135246777547 + 0.67135267738525 + 0.67135294971520 + 0.67135330342172 + 0.67135376258762 + 0.67135435823906 + 0.67135513025632 + 0.67135612976464 + 0.67135742542688 + 0.67135911000820 + 0.67136130041524 + 0.67136414845851 + 0.67136784969920 + 0.67137263685476 + 0.67137866382782 + 0.67138591630530 + 0.67139447183435 + 0.67140437583525 + 0.67141534171443 + 0.67142714976997 + 0.67143980297910 + 0.67145336110442 + 0.67146789862277 + 0.67148350123090 + 0.67150031120416 + 0.67151847110220 + 0.67153809564518 + 0.67155931803615 + 0.67158229682813 + 0.67160724277894 + 0.67163456735780 + 0.67166525945136 + 0.67170068427384 + 0.67174204307973 + 0.67179055571772 + 0.67184778310421 + 0.67191555818439 + 0.67199613776299 + 0.67209234600642 + 0.67220773980964 + 0.67234683565505 + 0.67251548088494 + 0.67272178358460 + 0.67297819104324 + 0.67330217634669 + 0.67371558479784 + 0.67424678429980 + 0.67456841078354 + 0.67493493581122 + 0.67535345312548 + 0.67583235477767 + 0.67638162003767 + 0.67701318607880 + 0.67774143068790 + 0.67858381206816 + 0.67956176182557 + 0.68070277648423 + 0.68205807760898 + 0.68374727609712 + 0.68591046322850 + 0.68871333907282 + 0.69240971080229 + 0.69738033712498 + 0.70426173190545 + 0.71424370431590 + 0.73000513378236 + 0.76038762685261 + 1.00000000000000 + 0.75152248722047 + 0.71121503974517 + 0.68486633887788 + 0.66392555250710 + 0.64582887609058 + 0.62946183485825 + 0.61423051811607 + 0.59979903701628 + 0.58599685379609 + 0.57273153694425 + 0.55995298505111 + 0.66163449301850 + 0.66163449540431 + 0.66163449579937 + 0.66163449626039 + 0.66163449679716 + 0.66163449742327 + 0.66163449815269 + 0.66163449900296 + 0.66163449999554 + 0.66163450115964 + 0.66163450254646 + 0.66163450424411 + 0.66163450636120 + 0.66163450901459 + 0.66163451234237 + 0.66163451651394 + 0.66163452173802 + 0.66163452827671 + 0.66163453647602 + 0.66163454679947 + 0.66163455979959 + 0.66163457617004 + 0.66163459678319 + 0.66163462273990 + 0.66163465544636 + 0.66163469681261 + 0.66163474968365 + 0.66163481789899 + 0.66163490610936 + 0.66163502007769 + 0.66163516804234 + 0.66163536039792 + 0.66163561041844 + 0.66163593527767 + 0.66163635714322 + 0.66163690457753 + 0.66163761428970 + 0.66163853333853 + 0.66163972491986 + 0.66164127441888 + 0.66164328939113 + 0.66164590944872 + 0.66164931433713 + 0.66165371772608 + 0.66165926007563 + 0.66166592621816 + 0.66167378519526 + 0.66168287585069 + 0.66169293099286 + 0.66170374520510 + 0.66171531774179 + 0.66172769949276 + 0.66174095412104 + 0.66175515469205 + 0.66177042494731 + 0.66178688743487 + 0.66180463769405 + 0.66182378635005 + 0.66184446494189 + 0.66186684968300 + 0.66189129461529 + 0.66191866840751 + 0.66195016765735 + 0.66198682789355 + 0.66202968641331 + 0.66208006721984 + 0.66213951376303 + 0.66220991721236 + 0.66229363431481 + 0.66239362110129 + 0.66251361621944 + 0.66265844445954 + 0.66283479705886 + 0.66305298672179 + 0.66332745231623 + 0.66367607744608 + 0.66412189063855 + 0.66439081271660 + 0.66469645268111 + 0.66504446030051 + 0.66544148077327 + 0.66589536401709 + 0.66641542886851 + 0.66701280093575 + 0.66770085138041 + 0.66849580004560 + 0.66941823887876 + 0.67050735687300 + 0.67185662736787 + 0.67357198743117 + 0.67577283724205 + 0.67863606659822 + 0.68241182969206 + 0.68748803534388 + 0.69451253945363 + 0.70469447787549 + 0.72074529058867 + 0.75152248722047 + 1.00000000000000 + 0.74249877460116 + 0.70149250767389 + 0.67465452943276 + 0.65335689095233 + 0.63498958099743 + 0.61839648127911 + 0.60298408211384 + 0.58844939729572 + 0.57462478896519 + 0.56141437689134 + 0.65162404202249 + 0.65162404417310 + 0.65162404452947 + 0.65162404494475 + 0.65162404542849 + 0.65162404599281 + 0.65162404665041 + 0.65162404741704 + 0.65162404831190 + 0.65162404936107 + 0.65162405061174 + 0.65162405214353 + 0.65162405405487 + 0.65162405645154 + 0.65162405945935 + 0.65162406323198 + 0.65162406796118 + 0.65162407388243 + 0.65162408131212 + 0.65162409067266 + 0.65162410246634 + 0.65162411732540 + 0.65162413604700 + 0.65162415963354 + 0.65162418936856 + 0.65162422699613 + 0.65162427511491 + 0.65162433723371 + 0.65162441760690 + 0.65162452150460 + 0.65162465646552 + 0.65162483200533 + 0.65162506027718 + 0.65162535700379 + 0.65162574248882 + 0.65162624289222 + 0.65162689183740 + 0.65162773241790 + 0.65162882251713 + 0.65163024034226 + 0.65163208437087 + 0.65163448238319 + 0.65163759881690 + 0.65164162893211 + 0.65164670032325 + 0.65165279726089 + 0.65165998086174 + 0.65166828400651 + 0.65167745880550 + 0.65168731418895 + 0.65169784640617 + 0.65170909847685 + 0.65172112448896 + 0.65173398638643 + 0.65174779136991 + 0.65176264434822 + 0.65177862439318 + 0.65179582284353 + 0.65181434826017 + 0.65183434738222 + 0.65185612405959 + 0.65188043920076 + 0.65190833861736 + 0.65194071262789 + 0.65197844090775 + 0.65202264356082 + 0.65207461675930 + 0.65213594097813 + 0.65220857757607 + 0.65229497657413 + 0.65239822445739 + 0.65252229200573 + 0.65267268864858 + 0.65285794305271 + 0.65308996844873 + 0.65338338642191 + 0.65375687652072 + 0.65398137316652 + 0.65423587590817 + 0.65452489124097 + 0.65485369348157 + 0.65522847827735 + 0.65565655370178 + 0.65614658077364 + 0.65670888039947 + 0.65735585057004 + 0.65810310669455 + 0.65898104434660 + 0.66006364471087 + 0.66143257276176 + 0.66317632821592 + 0.66542287258236 + 0.66834528965248 + 0.67219802358978 + 0.67737518856610 + 0.68453419067042 + 0.69490002972540 + 0.71121503974517 + 0.74249877460116 + 1.00000000000000 + 0.73331662439381 + 0.69159243377275 + 0.66428308762650 + 0.64265003575770 + 0.62400886854520 + 0.60719678282994 + 0.59165301650239 + 0.57707629248110 + 0.56329479644440 + 0.64134771418509 + 0.64134771611152 + 0.64134771643074 + 0.64134771680313 + 0.64134771723655 + 0.64134771774182 + 0.64134771833111 + 0.64134771901765 + 0.64134771981958 + 0.64134772075954 + 0.64134772187989 + 0.64134772325333 + 0.64134772496759 + 0.64134772711932 + 0.64134772982096 + 0.64134773321267 + 0.64134773746553 + 0.64134774279459 + 0.64134774948523 + 0.64134775792038 + 0.64134776855346 + 0.64134778195784 + 0.64134779885597 + 0.64134782015703 + 0.64134784702508 + 0.64134788104295 + 0.64134792457085 + 0.64134798079800 + 0.64134805359346 + 0.64134814775054 + 0.64134827012934 + 0.64134842938991 + 0.64134863660263 + 0.64134890608634 + 0.64134925633872 + 0.64134971119448 + 0.64135030128786 + 0.64135106588851 + 0.64135205774527 + 0.64135334813648 + 0.64135502678761 + 0.64135721008904 + 0.64136004775423 + 0.64136371738529 + 0.64136833434607 + 0.64137388260689 + 0.64138041595004 + 0.64138796189706 + 0.64139629156907 + 0.64140522814198 + 0.64141476548126 + 0.64142493967447 + 0.64143579636231 + 0.64144738773360 + 0.64145980625953 + 0.64147314134188 + 0.64148745796523 + 0.64150283105950 + 0.64151934968245 + 0.64153713548722 + 0.64155644851618 + 0.64157795325647 + 0.64160256095616 + 0.64163103493220 + 0.64166411904461 + 0.64170275827619 + 0.64174803806033 + 0.64180127548795 + 0.64186409827095 + 0.64193853135367 + 0.64202711575671 + 0.64213311066149 + 0.64226104166126 + 0.64241794838873 + 0.64261364364645 + 0.64286006406193 + 0.64317234487370 + 0.64335941485493 + 0.64357098009103 + 0.64381063806186 + 0.64408258133938 + 0.64439171142313 + 0.64474377873901 + 0.64514555647468 + 0.64560505910420 + 0.64613183710315 + 0.64673784899036 + 0.64744691559579 + 0.64831813067848 + 0.64941535542540 + 0.65080560751419 + 0.65258406487332 + 0.65487513528331 + 0.65785465311093 + 0.66178073710810 + 0.66705255871538 + 0.67433478824339 + 0.68486633887788 + 0.70149250767389 + 0.73331662439381 + 1.00000000000000 + 0.72397954117824 + 0.68153227377961 + 0.65377206325459 + 0.63179247807029 + 0.61287842688327 + 0.59589590738604 + 0.58028295232743 + 0.56573274621365 + 0.63083632909097 + 0.63083633080527 + 0.63083633108936 + 0.63083633142024 + 0.63083633180614 + 0.63083633225563 + 0.63083633278015 + 0.63083633339119 + 0.63083633410435 + 0.63083633494065 + 0.63083633593811 + 0.63083633716103 + 0.63083633868914 + 0.63083634060735 + 0.63083634301846 + 0.63083634604664 + 0.63083634984658 + 0.63083635461079 + 0.63083636059622 + 0.63083636814592 + 0.63083637766987 + 0.63083638968401 + 0.63083640483722 + 0.63083642395039 + 0.63083644807255 + 0.63083647863103 + 0.63083651775744 + 0.63083656833321 + 0.63083663385526 + 0.63083671865776 + 0.63083682894818 + 0.63083697256906 + 0.63083715954165 + 0.63083740283888 + 0.63083771922076 + 0.63083813028717 + 0.63083866380679 + 0.63083935537993 + 0.63084025282930 + 0.63084142079034 + 0.63084294061046 + 0.63084491779109 + 0.63084748798506 + 0.63085081196900 + 0.63085499354365 + 0.63086001662787 + 0.63086592824616 + 0.63087275114305 + 0.63088027499240 + 0.63088833697277 + 0.63089692911479 + 0.63090608140801 + 0.63091583208050 + 0.63092622478896 + 0.63093733892062 + 0.63094925027479 + 0.63096201181793 + 0.63097568454157 + 0.63099034100630 + 0.63100608153801 + 0.63102312796876 + 0.63104205863854 + 0.63106366488292 + 0.63108859906470 + 0.63111748815822 + 0.63115112690329 + 0.63119042136547 + 0.63123646564975 + 0.63129060630891 + 0.63135451169749 + 0.63143026725067 + 0.63152053998706 + 0.63162903725694 + 0.63176155643432 + 0.63192616358232 + 0.63213258451484 + 0.63239306266281 + 0.63254859547328 + 0.63272409292430 + 0.63292242669225 + 0.63314693123328 + 0.63340148897211 + 0.63369063400254 + 0.63401967935205 + 0.63439487495444 + 0.63482361967095 + 0.63531513912112 + 0.63588824262634 + 0.63659043205775 + 0.63747216913381 + 0.63858503244347 + 0.64000130851124 + 0.64181300798337 + 0.64414639803633 + 0.64717966396417 + 0.65117390329144 + 0.65653205412739 + 0.66392555250710 + 0.67465452943276 + 0.69159243377275 + 0.72397954117824 + 1.00000000000000 + 0.71449514817427 + 0.67133138979839 + 0.64309908514551 + 0.62076591578526 + 0.60162582038041 + 0.58453584384454 + 0.56892570831266 + 0.62012560891484 + 0.62012561042971 + 0.62012561068028 + 0.62012561097291 + 0.62012561131378 + 0.62012561171118 + 0.62012561217439 + 0.62012561271424 + 0.62012561334476 + 0.62012561408324 + 0.62012561496493 + 0.62012561604602 + 0.62012561739765 + 0.62012561909683 + 0.62012562123275 + 0.62012562391766 + 0.62012562728894 + 0.62012563151890 + 0.62012563683573 + 0.62012564354728 + 0.62012565201944 + 0.62012566271321 + 0.62012567621088 + 0.62012569324521 + 0.62012571475643 + 0.62012574202569 + 0.62012577696374 + 0.62012582215984 + 0.62012588075523 + 0.62012595664724 + 0.62012605541856 + 0.62012618412925 + 0.62012635180270 + 0.62012657012568 + 0.62012685420051 + 0.62012722349964 + 0.62012770306190 + 0.62012832498365 + 0.62012913240415 + 0.62013018363788 + 0.62013155207062 + 0.62013333285943 + 0.62013564832444 + 0.62013864331847 + 0.62014241079091 + 0.62014693480396 + 0.62015225620934 + 0.62015839351574 + 0.62016515435074 + 0.62017238951563 + 0.62018008967168 + 0.62018827948125 + 0.62019699068470 + 0.62020625949756 + 0.62021615371486 + 0.62022673722535 + 0.62023805277273 + 0.62025014954363 + 0.62026308615461 + 0.62027694483219 + 0.62029191409614 + 0.62030849542462 + 0.62032737345242 + 0.62034910368405 + 0.62037421256274 + 0.62040336601095 + 0.62043731752097 + 0.62047697253811 + 0.62052344083425 + 0.62057809182198 + 0.62064263065210 + 0.62071923181904 + 0.62081092230780 + 0.62092246282493 + 0.62106046595223 + 0.62123283533911 + 0.62144945117915 + 0.62157839118279 + 0.62172356472443 + 0.62188726148872 + 0.62207213166704 + 0.62228125017312 + 0.62251819410830 + 0.62278713691958 + 0.62309296404651 + 0.62344142777036 + 0.62383968035788 + 0.62430264758948 + 0.62486866121278 + 0.62557788068420 + 0.62647047499955 + 0.62760219431502 + 0.62904255128093 + 0.63088483868643 + 0.63325689088864 + 0.63633878120785 + 0.64039381289726 + 0.64582887609058 + 0.65335689095233 + 0.66428308762650 + 0.68153227377961 + 0.71449514817427 + 1.00000000000000 + 0.70487542954572 + 0.66095142463399 + 0.63223167373888 + 0.60959026613595 + 0.59028758325248 + 0.57316599943935 + 0.60925773014479 + 0.60925773147321 + 0.60925773169308 + 0.60925773194948 + 0.60925773224818 + 0.60925773259667 + 0.60925773300300 + 0.60925773347647 + 0.60925773402885 + 0.60925773467701 + 0.60925773545010 + 0.60925773639900 + 0.60925773758603 + 0.60925773907913 + 0.60925774095814 + 0.60925774332102 + 0.60925774629065 + 0.60925775001850 + 0.60925775470805 + 0.60925776063126 + 0.60925776811437 + 0.60925777756592 + 0.60925778950372 + 0.60925780458032 + 0.60925782363145 + 0.60925784779887 + 0.60925787878590 + 0.60925791890539 + 0.60925797096028 + 0.60925803843531 + 0.60925812632217 + 0.60925824094009 + 0.60925839036911 + 0.60925858507525 + 0.60925883859614 + 0.60925916839012 + 0.60925959690920 + 0.60926015294849 + 0.60926087522164 + 0.60926181607086 + 0.60926304136849 + 0.60926463652618 + 0.60926671131433 + 0.60926939561858 + 0.60927277227143 + 0.60927682564580 + 0.60928159098793 + 0.60928708307580 + 0.60929312675755 + 0.60929958594978 + 0.60930645035105 + 0.60931373998547 + 0.60932148093930 + 0.60932970296916 + 0.60933846362268 + 0.60934781639525 + 0.60935779535494 + 0.60936843971415 + 0.60937979634320 + 0.60939193212209 + 0.60940500655960 + 0.60941945269298 + 0.60943586038935 + 0.60945470068869 + 0.60947641364636 + 0.60950155481160 + 0.60953074796645 + 0.60956473902829 + 0.60960443846107 + 0.60965096516077 + 0.60970570696141 + 0.60977042879589 + 0.60984759186878 + 0.60994109138866 + 0.61005632951083 + 0.61019970633595 + 0.61037916741721 + 0.61048566908564 + 0.61060532628602 + 0.61073996010859 + 0.61089167245188 + 0.61106289461200 + 0.61125644550636 + 0.61147560186875 + 0.61172418368626 + 0.61200666866004 + 0.61232861482020 + 0.61270189594209 + 0.61315749540697 + 0.61372751048362 + 0.61444347755063 + 0.61534885735916 + 0.61649697721336 + 0.61795821206157 + 0.61982688457624 + 0.62223203011318 + 0.62535506108894 + 0.62946183485825 + 0.63498958099743 + 0.64265003575770 + 0.65377206325459 + 0.67133138979839 + 0.70487542954572 + 1.00000000000000 + 0.69503519946366 + 0.65033701482641 + 0.62117938952820 + 0.59829395513725 + 0.57890875109723 + 0.59826033668597 + 0.59826033784117 + 0.59826033803273 + 0.59826033825565 + 0.59826033851587 + 0.59826033881877 + 0.59826033917191 + 0.59826033958406 + 0.59826034006475 + 0.59826034062836 + 0.59826034130136 + 0.59826034212757 + 0.59826034316198 + 0.59826034446368 + 0.59826034610310 + 0.59826034816679 + 0.59826035076220 + 0.59826035402242 + 0.59826035812710 + 0.59826036331569 + 0.59826036987518 + 0.59826037816718 + 0.59826038864771 + 0.59826040189352 + 0.59826041864470 + 0.59826043990988 + 0.59826046720012 + 0.59826050256417 + 0.59826054849152 + 0.59826060807573 + 0.59826068575600 + 0.59826078715214 + 0.59826091945682 + 0.59826109199435 + 0.59826131682879 + 0.59826160952332 + 0.59826199010718 + 0.59826248427282 + 0.59826312657473 + 0.59826396375677 + 0.59826505464900 + 0.59826647553027 + 0.59826832442369 + 0.59827071724190 + 0.59827372742696 + 0.59827733980044 + 0.59828158453899 + 0.59828647316035 + 0.59829184690177 + 0.59829758221823 + 0.59830366817776 + 0.59831012078674 + 0.59831696122309 + 0.59832421365334 + 0.59833192659742 + 0.59834014448789 + 0.59834889406147 + 0.59835820612119 + 0.59836811765996 + 0.59837868256436 + 0.59839003509050 + 0.59840254740364 + 0.59841672529369 + 0.59843296617300 + 0.59845163585376 + 0.59847319529657 + 0.59849815799029 + 0.59852713488860 + 0.59856086860061 + 0.59860026795113 + 0.59864645579083 + 0.59870085615984 + 0.59876545920137 + 0.59884343638106 + 0.59893917996983 + 0.59905784666241 + 0.59920579391152 + 0.59929333351472 + 0.59939148263796 + 0.59950168328792 + 0.59962559557183 + 0.59976513453814 + 0.59992251402495 + 0.60010029916744 + 0.60030146987963 + 0.60052950605817 + 0.60078872394152 + 0.60108856764091 + 0.60145406414689 + 0.60191090210655 + 0.60248394803167 + 0.60320729942674 + 0.60412227555824 + 0.60528271270102 + 0.60675957176031 + 0.60864782246916 + 0.61107716250172 + 0.61423051811607 + 0.61839648127911 + 0.62400886854520 + 0.63179247807029 + 0.64309908514551 + 0.66095142463399 + 0.69503519946366 + 1.00000000000000 + 0.68494590749820 + 0.63952693773291 + 0.60998630341496 + 0.58693376305541 + 0.58716220000386 + 0.58716220100052 + 0.58716220116568 + 0.58716220135793 + 0.58716220158208 + 0.58716220184363 + 0.58716220214814 + 0.58716220250340 + 0.58716220291815 + 0.58716220340432 + 0.58716220398486 + 0.58716220469810 + 0.58716220559178 + 0.58716220671734 + 0.58716220813628 + 0.58716220992367 + 0.58716221217348 + 0.58716221500206 + 0.58716221856616 + 0.58716222307543 + 0.58716222878088 + 0.58716223599921 + 0.58716224512985 + 0.58716225668013 + 0.58716227129818 + 0.58716228987208 + 0.58716231372973 + 0.58716234467663 + 0.58716238491130 + 0.58716243716069 + 0.58716250534879 + 0.58716259444447 + 0.58716271081310 + 0.58716286271093 + 0.58716306082741 + 0.58716331896330 + 0.58716365488416 + 0.58716409139103 + 0.58716465916540 + 0.58716539973408 + 0.58716636536474 + 0.58716762384771 + 0.58716926228200 + 0.58717138360190 + 0.58717405260080 + 0.58717725465780 + 0.58718101538415 + 0.58718534347197 + 0.58719009563842 + 0.58719516022651 + 0.58720052595809 + 0.58720620538219 + 0.58721221543700 + 0.58721857547770 + 0.58722532609548 + 0.58723250386148 + 0.58724012934517 + 0.58724822629906 + 0.58725682343524 + 0.58726596367895 + 0.58727575934567 + 0.58728652860464 + 0.58729870284351 + 0.58731261540328 + 0.58732856838851 + 0.58734694181213 + 0.58736815547038 + 0.58739270625690 + 0.58742119552434 + 0.58745435606738 + 0.58749308957118 + 0.58753853644088 + 0.58759229463120 + 0.58765693023532 + 0.58773599250474 + 0.58783360897812 + 0.58795483170221 + 0.58802634593270 + 0.58810636118799 + 0.58819601180638 + 0.58829660059263 + 0.58840962663127 + 0.58853681827613 + 0.58868017239826 + 0.58884200157093 + 0.58902499768269 + 0.58923249979774 + 0.58947199895221 + 0.58976365444467 + 0.59012800034441 + 0.59058466378302 + 0.59116046605131 + 0.59188759336539 + 0.59280757726871 + 0.59397446915151 + 0.59545941624942 + 0.59735748746726 + 0.59979903701628 + 0.60298408211384 + 0.60719678282994 + 0.61287842688327 + 0.62076591578526 + 0.63223167373888 + 0.65033701482641 + 0.68494590749820 + 1.00000000000000 + 0.67469046186568 + 0.62857688142644 + 0.59871303670040 + 0.57601644883011 + 0.57601644968252 + 0.57601644982368 + 0.57601644998827 + 0.57601645018018 + 0.57601645040343 + 0.57601645066377 + 0.57601645096782 + 0.57601645132237 + 0.57601645173828 + 0.57601645223500 + 0.57601645284556 + 0.57601645361097 + 0.57601645457656 + 0.57601645579444 + 0.57601645733003 + 0.57601645926463 + 0.57601646169943 + 0.57601646476971 + 0.57601646865785 + 0.57601647358239 + 0.57601647981824 + 0.57601648771458 + 0.57601649771161 + 0.57601651037515 + 0.57601652648072 + 0.57601654719073 + 0.57601657408657 + 0.57601660909290 + 0.57601665460415 + 0.57601671406709 + 0.57601679185112 + 0.57601689355573 + 0.57601702645546 + 0.57601719996971 + 0.57601742627266 + 0.57601772104221 + 0.57601810441194 + 0.57601860349090 + 0.57601925499199 + 0.57602010513790 + 0.57602121389073 + 0.57602265829844 + 0.57602452936157 + 0.57602688397100 + 0.57602970814546 + 0.57603302342898 + 0.57603683608391 + 0.57604101730925 + 0.57604546659900 + 0.57605017256196 + 0.57605514480589 + 0.57606039664466 + 0.57606594333046 + 0.57607181855144 + 0.57607805211620 + 0.57608465945042 + 0.57609165845012 + 0.57609907095447 + 0.57610693070554 + 0.57611533107628 + 0.57612454265423 + 0.57613493139948 + 0.57614677522979 + 0.57616032188735 + 0.57617588247317 + 0.57619379761439 + 0.57621446828670 + 0.57623837755024 + 0.57626611138323 + 0.57629838771556 + 0.57633611197202 + 0.57638055689950 + 0.57643378411372 + 0.57649864157467 + 0.57657840768925 + 0.57667706443067 + 0.57673509001349 + 0.57679987557452 + 0.57687230605724 + 0.57695339546170 + 0.57704430774913 + 0.57714638147790 + 0.57726115903459 + 0.57739042157384 + 0.57753623641125 + 0.57770116999241 + 0.57789113693271 + 0.57812230784266 + 0.57841104685393 + 0.57877282418368 + 0.57922873505944 + 0.57980390041624 + 0.58053049646438 + 0.58144999377810 + 0.58261628928585 + 0.58410021463600 + 0.58599685379609 + 0.58844939729572 + 0.59165301650239 + 0.59589590738604 + 0.60162582038041 + 0.60959026613595 + 0.62117938952820 + 0.63952693773291 + 0.67469046186568 + 1.00000000000000 + 0.66428224195436 + 0.61751283685187 + 0.56487858894069 + 0.56487858966377 + 0.56487858978360 + 0.56487858992298 + 0.56487859008566 + 0.56487859027522 + 0.56487859049624 + 0.56487859075381 + 0.56487859105447 + 0.56487859140758 + 0.56487859182896 + 0.56487859234748 + 0.56487859299790 + 0.56487859381948 + 0.56487859485702 + 0.56487859616658 + 0.56487859781786 + 0.56487859989815 + 0.56487860252363 + 0.56487860585223 + 0.56487861007319 + 0.56487861542295 + 0.56487862220416 + 0.56487863079766 + 0.56487864169573 + 0.56487865557008 + 0.56487867343285 + 0.56487869665983 + 0.56487872693033 + 0.56487876633411 + 0.56487881788337 + 0.56487888540084 + 0.56487897379092 + 0.56487908942931 + 0.56487924058159 + 0.56487943793594 + 0.56487969526732 + 0.56488003027791 + 0.56488046681940 + 0.56488103721441 + 0.56488178217642 + 0.56488275453479 + 0.56488402218341 + 0.56488566526841 + 0.56488773354323 + 0.56489021371085 + 0.56489312374330 + 0.56489646784352 + 0.56490013060684 + 0.56490402187730 + 0.56490813034537 + 0.56491246314786 + 0.56491703054581 + 0.56492184433282 + 0.56492693225829 + 0.56493231836956 + 0.56493801387228 + 0.56494403185737 + 0.56495038853360 + 0.56495711003301 + 0.56496427351690 + 0.56497210801943 + 0.56498092248073 + 0.56499094727711 + 0.56500238415215 + 0.56501548602786 + 0.56503052717704 + 0.56504782856366 + 0.56506777496751 + 0.56509083086338 + 0.56511756267544 + 0.56514868261047 + 0.56518519567739 + 0.56522874592839 + 0.56528160173923 + 0.56534634536640 + 0.56542608692286 + 0.56547283981876 + 0.56552492397627 + 0.56558302314462 + 0.56564791892792 + 0.56572050632666 + 0.56580181199519 + 0.56589301580461 + 0.56599547652126 + 0.56611076693213 + 0.56624084259848 + 0.56639034626470 + 0.56657218468615 + 0.56679934469466 + 0.56708398291890 + 0.56744265745979 + 0.56789496579278 + 0.56846586801799 + 0.56918729299860 + 0.57010032800124 + 0.57125827675294 + 0.57273153694425 + 0.57462478896519 + 0.57707629248110 + 0.58028295232743 + 0.58453584384454 + 0.59028758325248 + 0.59829395513725 + 0.60998630341496 + 0.62857688142644 + 0.66428224195436 + 1.00000000000000 + 0.65373680104293 + 0.55380137461067 + 0.55380137521979 + 0.55380137532057 + 0.55380137543816 + 0.55380137557496 + 0.55380137573457 + 0.55380137592087 + 0.55380137613787 + 0.55380137639123 + 0.55380137668846 + 0.55380137704354 + 0.55380137748053 + 0.55380137803000 + 0.55380137872425 + 0.55380137960160 + 0.55380138071131 + 0.55380138211142 + 0.55380138387729 + 0.55380138610904 + 0.55380138894185 + 0.55380139253719 + 0.55380139710017 + 0.55380140289055 + 0.55380141023726 + 0.55380141956341 + 0.55380143145174 + 0.55380144677606 + 0.55380146673124 + 0.55380149277661 + 0.55380152672585 + 0.55380157120252 + 0.55380162953695 + 0.55380170601028 + 0.55380180618906 + 0.55380193730144 + 0.55380210869515 + 0.55380233243822 + 0.55380262403934 + 0.55380300441566 + 0.55380350193940 + 0.55380415236160 + 0.55380500208756 + 0.55380611077431 + 0.55380754881042 + 0.55380935956664 + 0.55381153047808 + 0.55381407640478 + 0.55381699984947 + 0.55382019766282 + 0.55382358918528 + 0.55382716335107 + 0.55383092526488 + 0.55383488265097 + 0.55383904444642 + 0.55384343334880 + 0.55384806857393 + 0.55385295792544 + 0.55385811062699 + 0.55386353834753 + 0.55386926101345 + 0.55387534207519 + 0.55388197467185 + 0.55388941860495 + 0.55389786392611 + 0.55390747390103 + 0.55391845288830 + 0.55393102017322 + 0.55394543072780 + 0.55396198859255 + 0.55398105881959 + 0.55400308429984 + 0.55402862011831 + 0.55405845320296 + 0.55409388547947 + 0.55413671107746 + 0.55418894718444 + 0.55425300052240 + 0.55429043050486 + 0.55433203088283 + 0.55437832455932 + 0.55442990774917 + 0.55448746140414 + 0.55455176456781 + 0.55462371010781 + 0.55470432337527 + 0.55479478801362 + 0.55489657918048 + 0.55501331871306 + 0.55515525732183 + 0.55533265596481 + 0.55555503164812 + 0.55583534345099 + 0.55618885306608 + 0.55663491424304 + 0.55719813861747 + 0.55790994968705 + 0.55881069645986 + 0.55995298505111 + 0.56141437689134 + 0.56329479644440 + 0.56573274621365 + 0.56892570831266 + 0.57316599943935 + 0.57890875109723 + 0.58693376305541 + 0.59871303670040 + 0.61751283685187 + 0.65373680104293 + 1.00000000000000 diff --git a/wrfv2_fire/run/tr49t85 b/wrfv2_fire/run/tr49t85 new file mode 100644 index 00000000..b298001c --- /dev/null +++ b/wrfv2_fire/run/tr49t85 @@ -0,0 +1,35643 @@ + 1.00000000000000 + 0.99983101931004 + 0.99981648094803 + 0.99980141549953 + 0.99978584719972 + 0.99976978646073 + 0.99975322661275 + 0.99973614099618 + 0.99971847842183 + 0.99970014730751 + 0.99968096834901 + 0.99966065282018 + 0.99963890194630 + 0.99961545042208 + 0.99959003119930 + 0.99956235365207 + 0.99953209588182 + 0.99949890129527 + 0.99946234862179 + 0.99942194869172 + 0.99937720269949 + 0.99932756952992 + 0.99927246791874 + 0.99921127818826 + 0.99914333155147 + 0.99906783147570 + 0.99898370699432 + 0.99888980436857 + 0.99878513236717 + 0.99866875172343 + 0.99853941778640 + 0.99839584345631 + 0.99823657968322 + 0.99805988331042 + 0.99786362452819 + 0.99764518766204 + 0.99740137075766 + 0.99712828957644 + 0.99682105773981 + 0.99647369112758 + 0.99607948633617 + 0.99563068942909 + 0.99511847739824 + 0.99453355640203 + 0.99386989151070 + 0.99312488040937 + 0.99228974270724 + 0.99135437676330 + 0.99031410558035 + 0.98915897262174 + 0.98787184917519 + 0.98643320574094 + 0.98482197525992 + 0.98301518362534 + 0.98098581457927 + 0.97870339796769 + 0.97613386951301 + 0.97323753656390 + 0.96996916487397 + 0.96627853860768 + 0.96210857265949 + 0.95738765135282 + 0.95203783011127 + 0.94599224305604 + 0.93919252590932 + 0.93158327315622 + 0.92311977689610 + 0.91376926187661 + 0.90351412705949 + 0.89235648498143 + 0.88032365420464 + 0.86747325536123 + 0.85389103242537 + 0.83967660456851 + 0.82495891774037 + 0.80992002162047 + 0.79476653159387 + 0.78720347981310 + 0.77968015086061 + 0.77221217850729 + 0.76481013385765 + 0.75747891964607 + 0.75021745950684 + 0.74301880357604 + 0.73587078141742 + 0.72875714052595 + 0.72165573291163 + 0.71448443038467 + 0.70700620983649 + 0.69909670547639 + 0.69074172446137 + 0.68192727404110 + 0.67266998815965 + 0.66299428659111 + 0.65293056150325 + 0.64251365367052 + 0.63178176403541 + 0.62077382511600 + 0.60949515556263 + 0.59798341422709 + 0.58627947342740 + 0.57442778429691 + 0.56247622387791 + 0.55047508887407 + 0.53845663637773 + 0.52644560121028 + 0.51447595557505 + 0.50257129789460 + 0.49074141488310 + 0.99983101931004 + 1.00000000000000 + 0.99995146801025 + 0.99991191555422 + 0.99987733422806 + 0.99984621095943 + 0.99981760613258 + 0.99979083241725 + 0.99976534042794 + 0.99974065036083 + 0.99971627127685 + 0.99969166167376 + 0.99966632758547 + 0.99963985713877 + 0.99961187134596 + 0.99958199290586 + 0.99954983206376 + 0.99951497835252 + 0.99947696634258 + 0.99943527050377 + 0.99938936312793 + 0.99933867938974 + 0.99928261869844 + 0.99922054576355 + 0.99915177931202 + 0.99907551264702 + 0.99899066635146 + 0.99889608163653 + 0.99879076607661 + 0.99867378122316 + 0.99854388328033 + 0.99839978688988 + 0.99824004464426 + 0.99806291430572 + 0.99786626602121 + 0.99764748301246 + 0.99740336123554 + 0.99713001355693 + 0.99682255003376 + 0.99647498271003 + 0.99608060446836 + 0.99563165776109 + 0.99511931625078 + 0.99453428319812 + 0.99387052140183 + 0.99312542661329 + 0.99229021644733 + 0.99135478767558 + 0.99031446213877 + 0.98915928220700 + 0.98787211817948 + 0.98643343973362 + 0.98482217909954 + 0.98301536154861 + 0.98098597026357 + 0.97870353459335 + 0.97613398983256 + 0.97323764294167 + 0.96996925933651 + 0.96627862288064 + 0.96210864819383 + 0.95738771934444 + 0.95203789153294 + 0.94599229871133 + 0.93919257646863 + 0.93158331916783 + 0.92311981881394 + 0.91376930007596 + 0.90351416184889 + 0.89235651662470 + 0.88032368292767 + 0.86747328135887 + 0.85389105587520 + 0.83967662563023 + 0.82495893656842 + 0.80992003837143 + 0.79476654643545 + 0.78720349376394 + 0.77968016396490 + 0.77221219081055 + 0.76481014540438 + 0.75747893048177 + 0.75021746967678 + 0.74301881312299 + 0.73587079038471 + 0.72875714895412 + 0.72165574083979 + 0.71448443784497 + 0.70700621684667 + 0.69909671204775 + 0.69074173060515 + 0.68192727976738 + 0.67266999347891 + 0.66299429151406 + 0.65293056604118 + 0.64251365783545 + 0.63178176783957 + 0.62077382857390 + 0.60949515868882 + 0.59798341703679 + 0.58627947593755 + 0.57442778652554 + 0.56247622584359 + 0.55047509059805 + 0.53845663788022 + 0.52644560251216 + 0.51447595669786 + 0.50257129885980 + 0.49074141571124 + 0.99981648094803 + 0.99995146801025 + 1.00000000000000 + 0.99994505157972 + 0.99990184299975 + 0.99986495159423 + 0.99983228778413 + 0.99980257590909 + 0.99977491323594 + 0.99974859140174 + 0.99972296474421 + 0.99969738384144 + 0.99967127971040 + 0.99964418841446 + 0.99961569414954 + 0.99958539316346 + 0.99955287644245 + 0.99951771922699 + 0.99947944512839 + 0.99943752009604 + 0.99939140990311 + 0.99934054458885 + 0.99928431950812 + 0.99922209619805 + 0.99915319089719 + 0.99907679493087 + 0.99899182727523 + 0.99889712816042 + 0.99879170486932 + 0.99867461902012 + 0.99854462691169 + 0.99840044343743 + 0.99824062143469 + 0.99806341880343 + 0.99786670565966 + 0.99764786503206 + 0.99740369251728 + 0.99713030049146 + 0.99682279841782 + 0.99647519769590 + 0.99608079059028 + 0.99563181895111 + 0.99511945588822 + 0.99453440418030 + 0.99387062625017 + 0.99312551752584 + 0.99229029529246 + 0.99135485605613 + 0.99031452146801 + 0.98915933371340 + 0.98787216292831 + 0.98643347865122 + 0.98482221299750 + 0.98301539113307 + 0.98098599614593 + 0.97870355730321 + 0.97613400982868 + 0.97323766061676 + 0.96996927503007 + 0.96627863687871 + 0.96210866073876 + 0.95738773063518 + 0.95203790173059 + 0.94599230795083 + 0.93919258485973 + 0.93158332680291 + 0.92311982576848 + 0.91376930641263 + 0.90351416761872 + 0.89235652187271 + 0.88032368769008 + 0.86747328566931 + 0.85389105976233 + 0.83967662912120 + 0.82495893968897 + 0.80992004114775 + 0.79476654889454 + 0.78720349607556 + 0.77968016613642 + 0.77221219284898 + 0.76481014731769 + 0.75747893227714 + 0.75021747136172 + 0.74301881470456 + 0.73587079187034 + 0.72875715035072 + 0.72165574215349 + 0.71448443908105 + 0.70700621800793 + 0.69909671313599 + 0.69074173162294 + 0.68192728071612 + 0.67266999436013 + 0.66299429232939 + 0.65293056679270 + 0.64251365852540 + 0.63178176847000 + 0.62077382914665 + 0.60949515920652 + 0.59798341750216 + 0.58627947635336 + 0.57442778689469 + 0.56247622616941 + 0.55047509088352 + 0.53845663812911 + 0.52644560272799 + 0.51447595688408 + 0.50257129901978 + 0.49074141584835 + 0.99980141549953 + 0.99991191555422 + 0.99994505157972 + 1.00000000000000 + 0.99993795807384 + 0.99989102075375 + 0.99985190303934 + 0.99981779506598 + 0.99978703072226 + 0.99975846097696 + 0.99973116603711 + 0.99970431787321 + 0.99967722944926 + 0.99964935796511 + 0.99962023364267 + 0.99958941506364 + 0.99955646648810 + 0.99952094379071 + 0.99948235607195 + 0.99944015819545 + 0.99939380757453 + 0.99934272773920 + 0.99928630897763 + 0.99922390887480 + 0.99915484060827 + 0.99907829308286 + 0.99899318331862 + 0.99889835035249 + 0.99879280108665 + 0.99867559719188 + 0.99854549505936 + 0.99840120986610 + 0.99824129472762 + 0.99806400768564 + 0.99786721882522 + 0.99764831093788 + 0.99740407920081 + 0.99713063541591 + 0.99682308834660 + 0.99647544864453 + 0.99608100784705 + 0.99563200710735 + 0.99511961888547 + 0.99453454540152 + 0.99387074863621 + 0.99312562364332 + 0.99229038732278 + 0.99135493587089 + 0.99031459071367 + 0.98915939382658 + 0.98787221515214 + 0.98643352407018 + 0.98482225255484 + 0.98301542565322 + 0.98098602634458 + 0.97870358380079 + 0.97613403315766 + 0.97323768123940 + 0.96996929333787 + 0.96627865320897 + 0.96210867537360 + 0.95738774380470 + 0.95203791362476 + 0.94599231872573 + 0.93919259464491 + 0.93158333570743 + 0.92311983387751 + 0.91376931380093 + 0.90351417434681 + 0.89235652799094 + 0.88032369324249 + 0.86747329069401 + 0.85389106429446 + 0.83967663319112 + 0.82495894332632 + 0.80992004438350 + 0.79476655176205 + 0.78720349877068 + 0.77968016866723 + 0.77221219522463 + 0.76481014954759 + 0.75747893436974 + 0.75021747332546 + 0.74301881654838 + 0.73587079360282 + 0.72875715197828 + 0.72165574368421 + 0.71448444052154 + 0.70700621936180 + 0.69909671440526 + 0.69074173280924 + 0.68192728182174 + 0.67266999538730 + 0.66299429328009 + 0.65293056766928 + 0.64251365932976 + 0.63178176920471 + 0.62077382981458 + 0.60949515981012 + 0.59798341804429 + 0.58627947683794 + 0.57442778732490 + 0.56247622654906 + 0.55047509121638 + 0.53845663841909 + 0.52644560297917 + 0.51447595710080 + 0.50257129920600 + 0.49074141600811 + 0.99978584719972 + 0.99987733422806 + 0.99990184299975 + 0.99993795807384 + 1.00000000000000 + 0.99993015535047 + 0.99987946488828 + 0.99983822730282 + 0.99980276154815 + 0.99977095346034 + 0.99974134935034 + 0.99971280269560 + 0.99968442930337 + 0.99965556103261 + 0.99962564578333 + 0.99959418667629 + 0.99956070981865 + 0.99952474420853 + 0.99948577931815 + 0.99944325534989 + 0.99939661882699 + 0.99934528493651 + 0.99928863753655 + 0.99922602926760 + 0.99915676949973 + 0.99908004415109 + 0.99899476785372 + 0.99889977817261 + 0.99879408151422 + 0.99867673958350 + 0.99854650884954 + 0.99840210480035 + 0.99824208086152 + 0.99806469523517 + 0.99786781795716 + 0.99764883153792 + 0.99740453065996 + 0.99713102645103 + 0.99682342685267 + 0.99647574164160 + 0.99608126151163 + 0.99563222679461 + 0.99511980920039 + 0.99453471028808 + 0.99387089152972 + 0.99312574754001 + 0.99229049476720 + 0.99135502905133 + 0.99031467155194 + 0.98915946399964 + 0.98787227611322 + 0.98643357708350 + 0.98482229872489 + 0.98301546594246 + 0.98098606158926 + 0.97870361472145 + 0.97613406038158 + 0.97323770530309 + 0.96996931470099 + 0.96627867226118 + 0.96210869244457 + 0.95738775916688 + 0.95203792749884 + 0.94599233129419 + 0.93919260605914 + 0.93158334609166 + 0.92311984333502 + 0.91376932241670 + 0.90351418219142 + 0.89235653512493 + 0.88032369971634 + 0.86747329655276 + 0.85389106957709 + 0.83967663793537 + 0.82495894756727 + 0.80992004815624 + 0.79476655510392 + 0.78720350191165 + 0.77968017161771 + 0.77221219799463 + 0.76481015214705 + 0.75747893680901 + 0.75021747561458 + 0.74301881869801 + 0.73587079562124 + 0.72875715387560 + 0.72165574546906 + 0.71448444220118 + 0.70700622093950 + 0.69909671588442 + 0.69074173419190 + 0.68192728311008 + 0.67266999658440 + 0.66299429438822 + 0.65293056869033 + 0.64251366026689 + 0.63178177006061 + 0.62077383059291 + 0.60949516051368 + 0.59798341867678 + 0.58627947740290 + 0.57442778782658 + 0.56247622699163 + 0.55047509160450 + 0.53845663875727 + 0.52644560327219 + 0.51447595735374 + 0.50257129942322 + 0.49074141619460 + 0.99976978646073 + 0.99984621095943 + 0.99986495159423 + 0.99989102075375 + 0.99993015535047 + 1.00000000000000 + 0.99992161843063 + 0.99986720051513 + 0.99982395927744 + 0.99978718289718 + 0.99975422875696 + 0.99972332277930 + 0.99969322509307 + 0.99966305591467 + 0.99963213129249 + 0.99959986931107 + 0.99956573973266 + 0.99952923316800 + 0.99948981189770 + 0.99944689632538 + 0.99939991855315 + 0.99934828289915 + 0.99929136497863 + 0.99922851115946 + 0.99915902603350 + 0.99908209180957 + 0.99899662017314 + 0.99890144686560 + 0.99879557764967 + 0.99867807421469 + 0.99854769308949 + 0.99840315010108 + 0.99824299901839 + 0.99806549821369 + 0.99786851765472 + 0.99764943951723 + 0.99740505789227 + 0.99713148312128 + 0.99682382218271 + 0.99647608383042 + 0.99608155776869 + 0.99563248337289 + 0.99512003147164 + 0.99453490286179 + 0.99387105841562 + 0.99312589223524 + 0.99229062024430 + 0.99135513786445 + 0.99031476595060 + 0.98915954593940 + 0.98787234729032 + 0.98643363897756 + 0.98482235262632 + 0.98301551297517 + 0.98098610272912 + 0.97870365081342 + 0.97613409215457 + 0.97323773338555 + 0.96996933962959 + 0.96627869449314 + 0.96210871236494 + 0.95738777709205 + 0.95203794368595 + 0.94599234595638 + 0.93919261937334 + 0.93158335820357 + 0.92311985436558 + 0.91376933246460 + 0.90351419133977 + 0.89235654344313 + 0.88032370726495 + 0.86747330338306 + 0.85389107573671 + 0.83967664346666 + 0.82495895251039 + 0.80992005255382 + 0.79476655899980 + 0.78720350557357 + 0.77968017505685 + 0.77221220122321 + 0.76481015517722 + 0.75747893965220 + 0.75021747828297 + 0.74301882120261 + 0.73587079797376 + 0.72875715608698 + 0.72165574754933 + 0.71448444415825 + 0.70700622277869 + 0.69909671760837 + 0.69074173580370 + 0.68192728461252 + 0.67266999797992 + 0.66299429567979 + 0.65293056988104 + 0.64251366135938 + 0.63178177105885 + 0.62077383149975 + 0.60949516133390 + 0.59798341941389 + 0.58627947806144 + 0.57442778841115 + 0.56247622750745 + 0.55047509205663 + 0.53845663915151 + 0.52644560361368 + 0.51447595764813 + 0.50257129967641 + 0.49074141641182 + 0.99975322661275 + 0.99981760613258 + 0.99983228778413 + 0.99985190303934 + 0.99987946488828 + 0.99992161843063 + 1.00000000000000 + 0.99991233058529 + 0.99985425619785 + 0.99980910618562 + 0.99977095654913 + 0.99973660855612 + 0.99970411028606 + 0.99967219519678 + 0.99963995469918 + 0.99960666981562 + 0.99957172359821 + 0.99953454989766 + 0.99949457222866 + 0.99945118362417 + 0.99940379668168 + 0.99935180132873 + 0.99929456244720 + 0.99923141834964 + 0.99916166756984 + 0.99908448765804 + 0.99899878663693 + 0.99890339797433 + 0.99879732658289 + 0.99867963406251 + 0.99854907696412 + 0.99840437147962 + 0.99824407174508 + 0.99806643632162 + 0.99786933507342 + 0.99765014977687 + 0.99740567382253 + 0.99713201662500 + 0.99682428403551 + 0.99647648360816 + 0.99608190388797 + 0.99563278313833 + 0.99512029115733 + 0.99453512784882 + 0.99387125338717 + 0.99312606127532 + 0.99229076682767 + 0.99135526497682 + 0.99031487621636 + 0.98915964164622 + 0.98787243042220 + 0.98643371126072 + 0.98482241556991 + 0.98301556789434 + 0.98098615076348 + 0.97870369295121 + 0.97613412924713 + 0.97323776616788 + 0.96996936872790 + 0.96627872044222 + 0.96210873561314 + 0.95738779800875 + 0.95203796257162 + 0.94599236306274 + 0.93919263490477 + 0.93158337233255 + 0.92311986723142 + 0.91376934418410 + 0.90351420200994 + 0.89235655314414 + 0.88032371606715 + 0.86747331134865 + 0.85389108291882 + 0.83967664991522 + 0.82495895827402 + 0.80992005768088 + 0.79476656354142 + 0.78720350984180 + 0.77968017906609 + 0.77221220498669 + 0.76481015870921 + 0.75747894296648 + 0.75021748139388 + 0.74301882412254 + 0.73587080071672 + 0.72875715866493 + 0.72165574997402 + 0.71448444643979 + 0.70700622492252 + 0.69909671961756 + 0.69074173768235 + 0.68192728636366 + 0.67266999960642 + 0.66299429718514 + 0.65293057126839 + 0.64251366263284 + 0.63178177222230 + 0.62077383255729 + 0.60949516228959 + 0.59798342027288 + 0.58627947882871 + 0.57442778909237 + 0.56247622810858 + 0.55047509258374 + 0.53845663961071 + 0.52644560401189 + 0.51447595799164 + 0.50257129997155 + 0.49074141666507 + 0.99973614099618 + 0.99979083241725 + 0.99980257590909 + 0.99981779506598 + 0.99983822730282 + 0.99986720051513 + 0.99991233058529 + 1.00000000000000 + 0.99990228163128 + 0.99984064147628 + 0.99979357922109 + 0.99975384385039 + 0.99971782891724 + 0.99968348077812 + 0.99964947588633 + 0.99961485992566 + 0.99957887548565 + 0.99954086891159 + 0.99950020650201 + 0.99945624234351 + 0.99940836203481 + 0.99935593605970 + 0.99929831508207 + 0.99923482692411 + 0.99916476233120 + 0.99908729294337 + 0.99900132219270 + 0.99890568067816 + 0.99879937217463 + 0.99868145809326 + 0.99855069493982 + 0.99840579927876 + 0.99824532565022 + 0.99806753279591 + 0.99787029044890 + 0.99765097989231 + 0.99740639369088 + 0.99713264016432 + 0.99682482384284 + 0.99647695087003 + 0.99608230844395 + 0.99563313351661 + 0.99512059468887 + 0.99453539082026 + 0.99387148126949 + 0.99312625884508 + 0.99229093814282 + 0.99135541352628 + 0.99031500506916 + 0.98915975347838 + 0.98787252755422 + 0.98643379570998 + 0.98482248910132 + 0.98301563204598 + 0.98098620686801 + 0.97870374216355 + 0.97613417256545 + 0.97323780444738 + 0.96996940270374 + 0.96627875073601 + 0.96210876275288 + 0.95738782242600 + 0.95203798461773 + 0.94599238302780 + 0.93919265303107 + 0.93158338881878 + 0.92311988224313 + 0.91376935785630 + 0.90351421445602 + 0.89235656446023 + 0.88032372633452 + 0.86747332063774 + 0.85389109129520 + 0.83967665743631 + 0.82495896499412 + 0.80992006365899 + 0.79476656883632 + 0.78720351481894 + 0.77968018374067 + 0.77221220937487 + 0.76481016282743 + 0.75747894683097 + 0.75021748501973 + 0.74301882752697 + 0.73587080391413 + 0.72875716167029 + 0.72165575280092 + 0.71448444909974 + 0.70700622742210 + 0.69909672196072 + 0.69074173987275 + 0.68192728840481 + 0.67267000150287 + 0.66299429894006 + 0.65293057288651 + 0.64251366411769 + 0.63178177357857 + 0.62077383378996 + 0.60949516340391 + 0.59798342127449 + 0.58627947972328 + 0.57442778988653 + 0.56247622880932 + 0.55047509319819 + 0.53845664014612 + 0.52644560447595 + 0.51447595839194 + 0.50257130031558 + 0.49074141696016 + 0.99971847842183 + 0.99976534042794 + 0.99977491323594 + 0.99978703072226 + 0.99980276154815 + 0.99982395927744 + 0.99985425619785 + 0.99990228163128 + 1.00000000000000 + 0.99989145276977 + 0.99982627870916 + 0.99977715293228 + 0.99973559215415 + 0.99969767029044 + 0.99966120724550 + 0.99962480964919 + 0.99958747729620 + 0.99954841436531 + 0.99950689905309 + 0.99946222809328 + 0.99941374863296 + 0.99936080425505 + 0.99930272640898 + 0.99923882902625 + 0.99916839269383 + 0.99909058145199 + 0.99900429291129 + 0.99890835402333 + 0.99880176703877 + 0.99868359300278 + 0.99855258828342 + 0.99840746981366 + 0.99824679255066 + 0.99806881541778 + 0.99787140795367 + 0.99765195085091 + 0.99740723569333 + 0.99713336949945 + 0.99682545524595 + 0.99647749742883 + 0.99608278165923 + 0.99563354336372 + 0.99512094973417 + 0.99453569841893 + 0.99387174781751 + 0.99312648992748 + 0.99229113850707 + 0.99135558725456 + 0.99031515575301 + 0.98915988424771 + 0.98787264112299 + 0.98643389444256 + 0.98482257506154 + 0.98301570703326 + 0.98098627244565 + 0.97870379967922 + 0.97613422318612 + 0.97323784917837 + 0.96996944240306 + 0.96627878613212 + 0.96210879445806 + 0.95738785094775 + 0.95203801036621 + 0.94599240634344 + 0.93919267419835 + 0.93158340806959 + 0.92311989976935 + 0.91376937381693 + 0.90351422898416 + 0.89235657766702 + 0.88032373831614 + 0.86747333147801 + 0.85389110106861 + 0.83967666621075 + 0.82495897283653 + 0.80992007063404 + 0.79476657501449 + 0.78720352062537 + 0.77968018919499 + 0.77221221449476 + 0.76481016763262 + 0.75747895134011 + 0.75021748925133 + 0.74301883149946 + 0.73587080764491 + 0.72875716517684 + 0.72165575609971 + 0.71448445220330 + 0.70700623033849 + 0.69909672469421 + 0.69074174242834 + 0.68192729078707 + 0.67267000371554 + 0.66299430098827 + 0.65293057477419 + 0.64251366585020 + 0.63178177516105 + 0.62077383522860 + 0.60949516470448 + 0.59798342244321 + 0.58627948076743 + 0.57442779081381 + 0.56247622962736 + 0.55047509391533 + 0.53845664077119 + 0.52644560501739 + 0.51447595885923 + 0.50257130071731 + 0.49074141730464 + 0.99970014730751 + 0.99974065036083 + 0.99974859140174 + 0.99975846097696 + 0.99977095346034 + 0.99978718289718 + 0.99980910618562 + 0.99984064147628 + 0.99989145276977 + 1.00000000000000 + 0.99987976759570 + 0.99981097073682 + 0.99975960400455 + 0.99971601166527 + 0.99967593263763 + 0.99963705520332 + 0.99959792198263 + 0.99955749022598 + 0.99951489504348 + 0.99946934500615 + 0.99942013059501 + 0.99936655709296 + 0.99930792936750 + 0.99924354255974 + 0.99917266377926 + 0.99909444715334 + 0.99900778281091 + 0.99891149299555 + 0.99880457789403 + 0.99868609794181 + 0.99855480920880 + 0.99840942896910 + 0.99824851260820 + 0.99807031919764 + 0.99787271802484 + 0.99765308904577 + 0.99740822267405 + 0.99713422438698 + 0.99682619533020 + 0.99647813805323 + 0.99608333630771 + 0.99563402372577 + 0.99512136585444 + 0.99453605891601 + 0.99387206019216 + 0.99312676072238 + 0.99229137329431 + 0.99135579081810 + 0.99031533230436 + 0.98916003745740 + 0.98787277417422 + 0.98643401010767 + 0.98482267576053 + 0.98301579487443 + 0.98098634925913 + 0.97870386704963 + 0.97613428247978 + 0.97323790157141 + 0.96996948889850 + 0.96627882758587 + 0.96210883158993 + 0.95738788434882 + 0.95203804051927 + 0.94599243364573 + 0.93919269898225 + 0.93158343060753 + 0.92311992028709 + 0.91376939250164 + 0.90351424599002 + 0.89235659312669 + 0.88032375234086 + 0.86747334416469 + 0.85389111250785 + 0.83967667648096 + 0.82495898201432 + 0.80992007879739 + 0.79476658224689 + 0.78720352742265 + 0.77968019557903 + 0.77221222048877 + 0.76481017325767 + 0.75747895661893 + 0.75021749420578 + 0.74301883615109 + 0.73587081201416 + 0.72875716928391 + 0.72165575996306 + 0.71448445583844 + 0.70700623375464 + 0.69909672789701 + 0.69074174542253 + 0.68192729357795 + 0.67267000630849 + 0.66299430338800 + 0.65293057698647 + 0.64251366788064 + 0.63178177701560 + 0.62077383691426 + 0.60949516622833 + 0.59798342381310 + 0.58627948199135 + 0.57442779190044 + 0.56247623058609 + 0.55047509475607 + 0.53845664150403 + 0.52644560565263 + 0.51447595940691 + 0.50257130118815 + 0.49074141770870 + 0.99968096834901 + 0.99971627127685 + 0.99972296474421 + 0.99973116603711 + 0.99974134935034 + 0.99975422875696 + 0.99977095654913 + 0.99979357922109 + 0.99982627870916 + 0.99987976759570 + 1.00000000000000 + 0.99986710051283 + 0.99979458468070 + 0.99974083290212 + 0.99969498464283 + 0.99965245330036 + 0.99961081278124 + 0.99956855168209 + 0.99952455608405 + 0.99947789147409 + 0.99942776107795 + 0.99937341368569 + 0.99931411625869 + 0.99924913786532 + 0.99917772732886 + 0.99909902558261 + 0.99901191296311 + 0.99891520554547 + 0.99880790068867 + 0.99868905784861 + 0.99855743256647 + 0.99841174240035 + 0.99825054314343 + 0.99807209398814 + 0.99787426386037 + 0.99765443181701 + 0.99740938684670 + 0.99713523259163 + 0.99682706801282 + 0.99647889335375 + 0.99608399015696 + 0.99563458993323 + 0.99512185628288 + 0.99453648374040 + 0.99387242826843 + 0.99312707978419 + 0.99229164991567 + 0.99135603064876 + 0.99031554031426 + 0.98916021797940 + 0.98787293095992 + 0.98643414642110 + 0.98482279445224 + 0.98301589842958 + 0.98098643982996 + 0.97870394649921 + 0.97613435242106 + 0.97323796338384 + 0.96996954376691 + 0.96627887651593 + 0.96210887542621 + 0.95738792378737 + 0.95203807612612 + 0.94599246588967 + 0.93919272825353 + 0.93158345722968 + 0.92311994452618 + 0.91376941457470 + 0.90351426608208 + 0.89235661139239 + 0.88032376891275 + 0.86747335916033 + 0.85389112602942 + 0.83967668862356 + 0.82495899286819 + 0.80992008845537 + 0.79476659080504 + 0.78720353546879 + 0.77968020313769 + 0.77221222758713 + 0.76481017992154 + 0.75747896287437 + 0.75021750007915 + 0.74301884166638 + 0.73587081719606 + 0.72875717415666 + 0.72165576454789 + 0.71448446015474 + 0.70700623781141 + 0.69909673170103 + 0.69074174898039 + 0.68192729689487 + 0.67267000939037 + 0.66299430624095 + 0.65293057961701 + 0.64251367029513 + 0.63178177922185 + 0.62077383892024 + 0.60949516804199 + 0.59798342544353 + 0.58627948344828 + 0.57442779319426 + 0.56247623172786 + 0.55047509575763 + 0.53845664237713 + 0.52644560640949 + 0.51447596006030 + 0.50257130174981 + 0.49074141819105 + 0.99966065282018 + 0.99969166167376 + 0.99969738384144 + 0.99970431787321 + 0.99971280269560 + 0.99972332277930 + 0.99973660855612 + 0.99975384385039 + 0.99977715293228 + 0.99981097073682 + 0.99986710051283 + 1.00000000000000 + 0.99985343714728 + 0.99977716112720 + 0.99972085128758 + 0.99967245981553 + 0.99962711535186 + 0.99958230107133 + 0.99953642783038 + 0.99948831168521 + 0.99943701382914 + 0.99938169586767 + 0.99932156861910 + 0.99925586378693 + 0.99918380466907 + 0.99910451418253 + 0.99901685955039 + 0.99891964858861 + 0.99881187472184 + 0.99869259588050 + 0.99856056672738 + 0.99841450499338 + 0.99825296684905 + 0.99807421153297 + 0.99787610748045 + 0.99765603261858 + 0.99741077419654 + 0.99713643362823 + 0.99682810723868 + 0.99647979249187 + 0.99608476827767 + 0.99563526355878 + 0.99512243959772 + 0.99453698890842 + 0.99387286587825 + 0.99312745907912 + 0.99229197875087 + 0.99135631576412 + 0.99031578764036 + 0.98916043267721 + 0.98787311748848 + 0.98643430866120 + 0.98482293578667 + 0.98301602180297 + 0.98098654779452 + 0.97870404126576 + 0.97613443589417 + 0.97323803720295 + 0.96996960933431 + 0.96627893502054 + 0.96210892787199 + 0.95738797099558 + 0.95203811876927 + 0.94599250452339 + 0.93919276333970 + 0.93158348915014 + 0.92311997359596 + 0.91376944105723 + 0.90351429019522 + 0.89235663332106 + 0.88032378881655 + 0.86747337717708 + 0.85389114228309 + 0.83967670322822 + 0.82495900593148 + 0.80992010008832 + 0.79476660112417 + 0.78720354517525 + 0.77968021226228 + 0.77221223616020 + 0.76481018797540 + 0.75747897043934 + 0.75021750718579 + 0.74301884834564 + 0.73587082347640 + 0.72875718006576 + 0.72165577011184 + 0.71448446539590 + 0.70700624274087 + 0.69909673632586 + 0.69074175330808 + 0.68192730093178 + 0.67267001314236 + 0.66299430971667 + 0.65293058282224 + 0.64251367323875 + 0.63178178191252 + 0.62077384136757 + 0.60949517025595 + 0.59798342743469 + 0.58627948522788 + 0.57442779477577 + 0.56247623312433 + 0.55047509698307 + 0.53845664344637 + 0.52644560733692 + 0.51447596086113 + 0.50257130243912 + 0.49074141878314 + 0.99963890194630 + 0.99966632758547 + 0.99967127971040 + 0.99967722944926 + 0.99968442930337 + 0.99969322509307 + 0.99970411028606 + 0.99971782891724 + 0.99973559215415 + 0.99975960400455 + 0.99979458468070 + 0.99985343714728 + 1.00000000000000 + 0.99983883501240 + 0.99975875172217 + 0.99969963831217 + 0.99964833862482 + 0.99959975019831 + 0.99955125406925 + 0.99950118860328 + 0.99944836667686 + 0.99939180764866 + 0.99933063536940 + 0.99926402592519 + 0.99919116581727 + 0.99911115267942 + 0.99902283572244 + 0.99892501145402 + 0.99881666772787 + 0.99869686009789 + 0.99856434181820 + 0.99841783058761 + 0.99825588285861 + 0.99807675781672 + 0.99787832320008 + 0.99765795550299 + 0.99741243982540 + 0.99713787485111 + 0.99682935368590 + 0.99648087042195 + 0.99608570072328 + 0.99563607046332 + 0.99512313807438 + 0.99453759361813 + 0.99387338959006 + 0.99312791294261 + 0.99229237222688 + 0.99135665696319 + 0.99031608368779 + 0.98916068976385 + 0.98787334095660 + 0.98643450314734 + 0.98482310532673 + 0.98301616990784 + 0.98098667750646 + 0.97870415521591 + 0.97613453635468 + 0.97323812612528 + 0.96996968838522 + 0.96627900561764 + 0.96210899121175 + 0.95738802805496 + 0.95203817034697 + 0.94599255128043 + 0.93919280582709 + 0.93158352782368 + 0.92312000883464 + 0.91376947317387 + 0.90351431945456 + 0.89235665994238 + 0.88032381299118 + 0.86747339907335 + 0.85389116205114 + 0.83967672100393 + 0.82495902184669 + 0.80992011427729 + 0.79476661372674 + 0.78720355703746 + 0.77968022342188 + 0.77221224665512 + 0.76481019784227 + 0.75747897971615 + 0.75021751590955 + 0.74301885655133 + 0.73587083119984 + 0.72875718733928 + 0.72165577696673 + 0.71448447185782 + 0.70700624882350 + 0.69909674203723 + 0.69074175865597 + 0.68192730592346 + 0.67267001778561 + 0.66299431401971 + 0.65293058679399 + 0.64251367688780 + 0.63178178524974 + 0.62077384440460 + 0.60949517300438 + 0.59798342990796 + 0.58627948744057 + 0.57442779674318 + 0.56247623486281 + 0.55047509851005 + 0.53845664477928 + 0.52644560849440 + 0.51447596186138 + 0.50257130330117 + 0.49074141952440 + 0.99961545042208 + 0.99963985713877 + 0.99964418841446 + 0.99964935796511 + 0.99965556103261 + 0.99966305591467 + 0.99967219519678 + 0.99968348077812 + 0.99969767029044 + 0.99971601166527 + 0.99974083290212 + 0.99977716112720 + 0.99983883501240 + 1.00000000000000 + 0.99982331830641 + 0.99973932526697 + 0.99967707684895 + 0.99962242697084 + 0.99957006284161 + 0.99951728027430 + 0.99946241512529 + 0.99940423781112 + 0.99934172990703 + 0.99927398100985 + 0.99920012262376 + 0.99911921578152 + 0.99903008433641 + 0.99893150894042 + 0.99882246939647 + 0.99870201756107 + 0.99856890442400 + 0.99842184727895 + 0.99825940267340 + 0.99807982952531 + 0.99788099459968 + 0.99766027254979 + 0.99741444579170 + 0.99713960964078 + 0.99683085326831 + 0.99648216663563 + 0.99608682148302 + 0.99563703992168 + 0.99512397693816 + 0.99453831962539 + 0.99387401818575 + 0.99312845762142 + 0.99229284442357 + 0.99135706646048 + 0.99031643908381 + 0.98916099851412 + 0.98787360947733 + 0.98643473699300 + 0.98482330932687 + 0.98301634825793 + 0.98098683384369 + 0.97870429268067 + 0.97613465766128 + 0.97323823360117 + 0.96996978402248 + 0.96627909111041 + 0.96210906798107 + 0.95738809727129 + 0.95203823296127 + 0.94599260808091 + 0.93919285747225 + 0.93158357485972 + 0.92312005171671 + 0.91376951227519 + 0.90351435509264 + 0.89235669238673 + 0.88032384247046 + 0.86747342579214 + 0.85389118619081 + 0.83967674273103 + 0.82495904131859 + 0.80992013165658 + 0.79476662918530 + 0.78720357159931 + 0.77968023713308 + 0.77221225956033 + 0.76481020998629 + 0.75747899114491 + 0.75021752666648 + 0.74301886668044 + 0.73587084074193 + 0.72875719633437 + 0.72165578545267 + 0.71448447986428 + 0.70700625636653 + 0.69909674912581 + 0.69074176529814 + 0.68192731212804 + 0.67267002356061 + 0.66299431937436 + 0.65293059173857 + 0.64251368143353 + 0.63178178940978 + 0.62077384819256 + 0.60949517643458 + 0.59798343299675 + 0.58627949020596 + 0.57442779920348 + 0.56247623703831 + 0.55047510042204 + 0.53845664645007 + 0.52644560994683 + 0.51447596311797 + 0.50257130438524 + 0.49074142045749 + 0.99959003119930 + 0.99961187134596 + 0.99961569414954 + 0.99962023364267 + 0.99962564578333 + 0.99963213129249 + 0.99963995469918 + 0.99964947588633 + 0.99966120724550 + 0.99967593263763 + 0.99969498464283 + 0.99972085128758 + 0.99975875172217 + 0.99982331830641 + 1.00000000000000 + 0.99980688310299 + 0.99971879467425 + 0.99965298757121 + 0.99959443309172 + 0.99953765993295 + 0.99947995755142 + 0.99941961787621 + 0.99935537301251 + 0.99928617061632 + 0.99921105633608 + 0.99912903635474 + 0.99903889772386 + 0.99893939833640 + 0.99882950609127 + 0.99870826704417 + 0.99857442856741 + 0.99842670688743 + 0.99826365826227 + 0.99808354100323 + 0.99788422047739 + 0.99766306893612 + 0.99741686542662 + 0.99714170109019 + 0.99683266025495 + 0.99648372782683 + 0.99608817075507 + 0.99563820656194 + 0.99512498603838 + 0.99453919266604 + 0.99387477388136 + 0.99312911232650 + 0.99229341198233 + 0.99135755870073 + 0.99031686639091 + 0.98916136988117 + 0.98787393262255 + 0.98643501858594 + 0.98482355515247 + 0.98301656334911 + 0.98098702254670 + 0.97870445875354 + 0.97613480434570 + 0.97323836368831 + 0.96996989988911 + 0.96627919478154 + 0.96210916115612 + 0.95738818134917 + 0.95203830907542 + 0.94599267717454 + 0.93919292033226 + 0.93158363214155 + 0.92312010396203 + 0.91376955994266 + 0.90351439856026 + 0.89235673198013 + 0.88032387846815 + 0.86747345843855 + 0.85389121570753 + 0.83967676931934 + 0.82495906517238 + 0.80992015297252 + 0.79476664817022 + 0.78720358949674 + 0.77968025399781 + 0.77221227544730 + 0.76481022495022 + 0.75747900524030 + 0.75021753994653 + 0.74301887919654 + 0.73587085254383 + 0.72875720747065 + 0.72165579596747 + 0.71448448979447 + 0.70700626572929 + 0.69909675793156 + 0.69074177355581 + 0.68192731984626 + 0.67267003074953 + 0.66299432604448 + 0.65293059790078 + 0.64251368710259 + 0.63178179459998 + 0.62077385292131 + 0.60949518071968 + 0.59798343685778 + 0.58627949366461 + 0.57442780228269 + 0.56247623976336 + 0.55047510281936 + 0.53845664854702 + 0.52644561177063 + 0.51447596469772 + 0.50257130574912 + 0.49074142163341 + 0.99956235365207 + 0.99958199290586 + 0.99958539316346 + 0.99958941506364 + 0.99959418667629 + 0.99959986931107 + 0.99960666981562 + 0.99961485992566 + 0.99962480964919 + 0.99963705520332 + 0.99965245330036 + 0.99967245981553 + 0.99969963831217 + 0.99973932526697 + 0.99980688310299 + 1.00000000000000 + 0.99978950935051 + 0.99969703593200 + 0.99962711047959 + 0.99956398358182 + 0.99950213534827 + 0.99943880681599 + 0.99937225003454 + 0.99930116307293 + 0.99922445019682 + 0.99914103176964 + 0.99904963958681 + 0.99894899786506 + 0.99883805653593 + 0.99871585244725 + 0.99858112717948 + 0.99843259476033 + 0.99826881046351 + 0.99808803141164 + 0.99788812093456 + 0.99766644812749 + 0.99741978775570 + 0.99714422576066 + 0.99683484048859 + 0.99648561063870 + 0.99608979729403 + 0.99563961237575 + 0.99512620156605 + 0.99454024394845 + 0.99387568360571 + 0.99312990034299 + 0.99229409507097 + 0.99135815117778 + 0.99031738082010 + 0.98916181712444 + 0.98787432198093 + 0.98643535807965 + 0.98482385173108 + 0.98301682304265 + 0.98098725056425 + 0.97870465960096 + 0.97613498190778 + 0.97323852129989 + 0.96997004040077 + 0.96627932061358 + 0.96210927434774 + 0.95738828356816 + 0.95203840167878 + 0.94599276128821 + 0.93919299690251 + 0.93158370195280 + 0.92312016767011 + 0.91376961809232 + 0.90351445161257 + 0.89235678032691 + 0.88032392244858 + 0.86747349835183 + 0.85389125182041 + 0.83967680187668 + 0.82495909440792 + 0.80992017912817 + 0.79476667149680 + 0.78720361150326 + 0.77968027475082 + 0.77221229501357 + 0.76481024339582 + 0.75747902262979 + 0.75021755634494 + 0.74301889466624 + 0.73587086714525 + 0.72875722126054 + 0.72165580899926 + 0.71448450211152 + 0.70700627735291 + 0.69909676887048 + 0.69074178382101 + 0.68192732944739 + 0.67267003969752 + 0.66299433435108 + 0.65293060558051 + 0.64251369417040 + 0.63178180107541 + 0.62077385882372 + 0.60949518607181 + 0.59798344168274 + 0.58627949798922 + 0.57442780613609 + 0.56247624317550 + 0.55047510582315 + 0.53845665117652 + 0.52644561406073 + 0.51447596668301 + 0.50257130746502 + 0.49074142311407 + 0.99953209588182 + 0.99954983206376 + 0.99955287644245 + 0.99955646648810 + 0.99956070981865 + 0.99956573973266 + 0.99957172359821 + 0.99957887548565 + 0.99958747729620 + 0.99959792198263 + 0.99961081278124 + 0.99962711535186 + 0.99964833862482 + 0.99967707684895 + 0.99971879467425 + 0.99978950935051 + 1.00000000000000 + 0.99977116119065 + 0.99967384731903 + 0.99959910681949 + 0.99953069975547 + 0.99946302965996 + 0.99939329367567 + 0.99931970853783 + 0.99924092912251 + 0.99915573419544 + 0.99906276901262 + 0.99896070626421 + 0.99884846802125 + 0.99872507634457 + 0.99858926350885 + 0.99843973940368 + 0.99827505711745 + 0.99809347161643 + 0.99789284323694 + 0.99767053684981 + 0.99742332172877 + 0.99714727729513 + 0.99683747446716 + 0.99648788429697 + 0.99609176067216 + 0.99564130866888 + 0.99512766772060 + 0.99454151156536 + 0.99387678023214 + 0.99313085008703 + 0.99229491829044 + 0.99135886522332 + 0.99031800091473 + 0.98916235641458 + 0.98787479168742 + 0.98643576786071 + 0.98482420994063 + 0.98301713692538 + 0.98098752637880 + 0.97870490274866 + 0.97613519704929 + 0.97323871243624 + 0.96997021094762 + 0.96627947347528 + 0.96210941196318 + 0.95738840793588 + 0.95203851442116 + 0.94599286375738 + 0.93919309023104 + 0.93158378708488 + 0.92312024539351 + 0.91376968906754 + 0.90351451639799 + 0.89235683939361 + 0.88032397620883 + 0.86747354717095 + 0.85389129602153 + 0.83967684175687 + 0.82495913025537 + 0.80992021123356 + 0.79476670016496 + 0.78720363856979 + 0.77968030029409 + 0.77221231911525 + 0.76481026613475 + 0.75747904408603 + 0.75021757659641 + 0.74301891378725 + 0.73587088520857 + 0.72875723833454 + 0.72165582514836 + 0.71448451738738 + 0.70700629177850 + 0.69909678245661 + 0.69074179657993 + 0.68192734138815 + 0.67267005083199 + 0.66299434469392 + 0.65293061514706 + 0.64251370298037 + 0.63178180914949 + 0.62077386618838 + 0.60949519275285 + 0.59798344770995 + 0.58627950339481 + 0.57442781095519 + 0.56247624744633 + 0.55047510958634 + 0.53845665447296 + 0.52644561693419 + 0.51447596917679 + 0.50257130962256 + 0.49074142497809 + 0.99949890129527 + 0.99951497835252 + 0.99951771922699 + 0.99952094379071 + 0.99952474420853 + 0.99952923316800 + 0.99953454989766 + 0.99954086891159 + 0.99954841436531 + 0.99955749022598 + 0.99956855168209 + 0.99958230107133 + 0.99959975019831 + 0.99962242697084 + 0.99965298757121 + 0.99969703593200 + 0.99977116119065 + 1.00000000000000 + 0.99975172806498 + 0.99964894579082 + 0.99956863775702 + 0.99949415076759 + 0.99941982743894 + 0.99934282552555 + 0.99926131767775 + 0.99917383251254 + 0.99907887243690 + 0.99897502801690 + 0.99886117680842 + 0.99873631674400 + 0.99859916499898 + 0.99844842406023 + 0.99828264276719 + 0.99810007234900 + 0.99789856868284 + 0.99767549090089 + 0.99742760115622 + 0.99715097060664 + 0.99684066091432 + 0.99649063366729 + 0.99609413390256 + 0.99564335829137 + 0.99512943864751 + 0.99454304217916 + 0.99387810400417 + 0.99313199633245 + 0.99229591174462 + 0.99135972694468 + 0.99031874937295 + 0.98916300752695 + 0.98787535902578 + 0.98643626307255 + 0.98482464309529 + 0.98301751673347 + 0.98098786036478 + 0.97870519740785 + 0.97613545798063 + 0.97323894444391 + 0.96997041813303 + 0.96627965932373 + 0.96210957940144 + 0.95738855936378 + 0.95203865178148 + 0.94599298866925 + 0.93919320405590 + 0.93158389095819 + 0.92312034026754 + 0.91376977573962 + 0.90351459554263 + 0.89235691158885 + 0.88032404195233 + 0.86747360690188 + 0.85389135013953 + 0.83967689062555 + 0.82495917421825 + 0.80992025064985 + 0.79476673540587 + 0.78720367186402 + 0.77968033173788 + 0.77221234880551 + 0.76481029416877 + 0.75747907056082 + 0.75021760160610 + 0.74301893742008 + 0.73587090755276 + 0.72875725947232 + 0.72165584515594 + 0.71448453632738 + 0.70700630967811 + 0.69909679932704 + 0.69074181243124 + 0.68192735623245 + 0.67267006468215 + 0.66299435756559 + 0.65293062705975 + 0.64251371395575 + 0.63178181921410 + 0.62077387537340 + 0.60949520108978 + 0.59798345523453 + 0.58627951014756 + 0.57442781697939 + 0.56247625278838 + 0.55047511429667 + 0.53845665860349 + 0.52644562053672 + 0.51447597230644 + 0.50257131233349 + 0.49074142732251 + 0.99946234862179 + 0.99947696634258 + 0.99947944512839 + 0.99948235607195 + 0.99948577931815 + 0.99948981189770 + 0.99949457222866 + 0.99950020650201 + 0.99950689905309 + 0.99951489504348 + 0.99952455608405 + 0.99953642783038 + 0.99955125406925 + 0.99957006284161 + 0.99959443309172 + 0.99962711047959 + 0.99967384731903 + 0.99975172806498 + 1.00000000000000 + 0.99973106970270 + 0.99962209314442 + 0.99953534518647 + 0.99945387660470 + 0.99937197668990 + 0.99928675472140 + 0.99919625481289 + 0.99909872696504 + 0.99899262397716 + 0.99887674962598 + 0.99875006158483 + 0.99861125221749 + 0.99845901105958 + 0.99829187920635 + 0.99810810154919 + 0.99790552726566 + 0.99768150755271 + 0.99743279520126 + 0.99715545080043 + 0.99684452437783 + 0.99649396573382 + 0.99609700895449 + 0.99564584038606 + 0.99513158248402 + 0.99454489448239 + 0.99387970553030 + 0.99313338280503 + 0.99229711327688 + 0.99136076915080 + 0.99031965471519 + 0.98916379533956 + 0.98787604574473 + 0.98643686279053 + 0.98482516796018 + 0.98301797726036 + 0.98098826562088 + 0.97870555521419 + 0.97613577508339 + 0.97323922662311 + 0.96997067032476 + 0.96627988572203 + 0.96210978352669 + 0.95738874409368 + 0.95203881945224 + 0.94599314122679 + 0.93919334313691 + 0.93158401793619 + 0.92312045629077 + 0.91376988177507 + 0.90351469240966 + 0.89235699998784 + 0.88032412249184 + 0.86747368011913 + 0.85389141651956 + 0.83967695061061 + 0.82495922823247 + 0.80992029912827 + 0.79476677880101 + 0.78720371288817 + 0.77968037050969 + 0.77221238544350 + 0.76481032879146 + 0.75747910328267 + 0.75021763253937 + 0.74301896667695 + 0.73587093523741 + 0.72875728568275 + 0.72165586998573 + 0.71448455984943 + 0.70700633192298 + 0.69909682030607 + 0.69074183215717 + 0.68192737471522 + 0.67267008193640 + 0.66299437360971 + 0.65293064191523 + 0.64251372764968 + 0.63178183177807 + 0.62077388684487 + 0.60949521150749 + 0.59798346464314 + 0.58627951859619 + 0.57442782452119 + 0.56247625948104 + 0.55047512020253 + 0.53845666378567 + 0.52644562506135 + 0.51447597624075 + 0.50257131574455 + 0.49074143027508 + 0.99942194869172 + 0.99943527050377 + 0.99943752009604 + 0.99944015819545 + 0.99944325534989 + 0.99944689632538 + 0.99945118362417 + 0.99945624234351 + 0.99946222809328 + 0.99946934500615 + 0.99947789147409 + 0.99948831168521 + 0.99950118860328 + 0.99951728027430 + 0.99953765993295 + 0.99956398358182 + 0.99959910681949 + 0.99964894579082 + 0.99973106970270 + 1.00000000000000 + 0.99970912707862 + 0.99959304090326 + 0.99949884836319 + 0.99940938296947 + 0.99931886936545 + 0.99922428137322 + 0.99912337996408 + 0.99901437099675 + 0.99889593014881 + 0.99876694592869 + 0.99862606907864 + 0.99847196662972 + 0.99830316598489 + 0.99811790143001 + 0.99791401192583 + 0.99768883751311 + 0.99743911847322 + 0.99716090170591 + 0.99684922245773 + 0.99649801574509 + 0.99610050203184 + 0.99564885487908 + 0.99513418522517 + 0.99454714251959 + 0.99388164863497 + 0.99313506462767 + 0.99229857059365 + 0.99136203320819 + 0.99032075290805 + 0.98916475121892 + 0.98787687929229 + 0.98643759108982 + 0.98482580573112 + 0.98301853721881 + 0.98098875872432 + 0.97870599091374 + 0.97613616152165 + 0.97323957078218 + 0.96997097816106 + 0.96628016228850 + 0.96211003307138 + 0.95738897008115 + 0.95203902469429 + 0.94599332806575 + 0.93919351355356 + 0.93158417358853 + 0.92312059857275 + 0.91377001186085 + 0.90351481129558 + 0.89235710852837 + 0.88032422143239 + 0.86747377011555 + 0.85389149816719 + 0.83967702444949 + 0.82495929478267 + 0.80992035891994 + 0.79476683238890 + 0.78720376358186 + 0.77968041845475 + 0.77221243078446 + 0.76481037167083 + 0.75747914384022 + 0.75021767091354 + 0.74301900299991 + 0.73587096963541 + 0.72875731827666 + 0.72165590088527 + 0.71448458914352 + 0.70700635964615 + 0.69909684646991 + 0.69074185677248 + 0.68192739779371 + 0.67267010349282 + 0.66299439366443 + 0.65293066049389 + 0.64251374478447 + 0.63178184750664 + 0.62077390121308 + 0.60949522456296 + 0.59798347644067 + 0.58627952919611 + 0.57442783398949 + 0.56247626788966 + 0.55047512762763 + 0.53845667030707 + 0.52644563076039 + 0.51447598120071 + 0.50257132004909 + 0.49074143400573 + 0.99937720269949 + 0.99938936312793 + 0.99939140990311 + 0.99939380757453 + 0.99939661882699 + 0.99939991855315 + 0.99940379668168 + 0.99940836203481 + 0.99941374863296 + 0.99942013059501 + 0.99942776107795 + 0.99943701382914 + 0.99944836667686 + 0.99946241512529 + 0.99947995755142 + 0.99950213534827 + 0.99953069975547 + 0.99956863775702 + 0.99962209314442 + 0.99970912707862 + 1.00000000000000 + 0.99968574252453 + 0.99956144688677 + 0.99945867017330 + 0.99936006105756 + 0.99925968754373 + 0.99915423049623 + 0.99904141196367 + 0.99891967133223 + 0.99878777353121 + 0.99864429753326 + 0.99848787104625 + 0.99831699750145 + 0.99812989348126 + 0.99792438216556 + 0.99769778760211 + 0.99744683306986 + 0.99716754748617 + 0.99685494714346 + 0.99650294835747 + 0.99610475452899 + 0.99565252333224 + 0.99513735145933 + 0.99454987631637 + 0.99388401088741 + 0.99313710878064 + 0.99230034163224 + 0.99136356932421 + 0.99032208758344 + 0.98916591320135 + 0.98787789291808 + 0.98643847712998 + 0.98482658204581 + 0.98301921922577 + 0.98098935970276 + 0.97870652230615 + 0.97613663318545 + 0.97323999116152 + 0.96997135445582 + 0.96628050061038 + 0.96211033854837 + 0.95738924689397 + 0.95203927623396 + 0.94599355716355 + 0.93919372260284 + 0.93158436459900 + 0.92312077323828 + 0.91377017161231 + 0.90351495734845 + 0.89235724192939 + 0.88032434308978 + 0.86747388083792 + 0.85389159867877 + 0.83967711541705 + 0.82495937684179 + 0.80992043272090 + 0.79476689861144 + 0.78720382626804 + 0.77968047778320 + 0.77221248692958 + 0.76481042480762 + 0.75747919414048 + 0.75021771854166 + 0.74301904811709 + 0.73587101239582 + 0.72875735882501 + 0.72165593935410 + 0.71448462563956 + 0.70700639420827 + 0.69909687910808 + 0.69074188749818 + 0.68192742661627 + 0.67267013042973 + 0.66299441873664 + 0.65293068373280 + 0.64251376622719 + 0.63178186719996 + 0.62077391921220 + 0.60949524092693 + 0.59798349123558 + 0.58627954249674 + 0.57442784587798 + 0.56247627845441 + 0.55047513696346 + 0.53845667851260 + 0.52644563793797 + 0.51447598745337 + 0.50257132548104 + 0.49074143871785 + 0.99932756952992 + 0.99933867938974 + 0.99934054458885 + 0.99934272773920 + 0.99934528493651 + 0.99934828289915 + 0.99935180132873 + 0.99935593605970 + 0.99936080425505 + 0.99936655709296 + 0.99937341368569 + 0.99938169586767 + 0.99939180764866 + 0.99940423781112 + 0.99941961787621 + 0.99943880681599 + 0.99946302965996 + 0.99949415076759 + 0.99953534518647 + 0.99959304090326 + 0.99968574252453 + 1.00000000000000 + 0.99966071786268 + 0.99952691473881 + 0.99941424982573 + 0.99930511078929 + 0.99919324641847 + 0.99907530107829 + 0.99894924064422 + 0.99881359692422 + 0.99866682038099 + 0.99850746882710 + 0.99833400364962 + 0.99814461169021 + 0.99793709139070 + 0.99770874340506 + 0.99745626745259 + 0.99717566847939 + 0.99686193814865 + 0.99650896891342 + 0.99610994263304 + 0.99565699711049 + 0.99514121135005 + 0.99455320787538 + 0.99388688876991 + 0.99313959853009 + 0.99230249839724 + 0.99136543987890 + 0.99032371293499 + 0.98916732851721 + 0.98787912790623 + 0.98643955709909 + 0.98482752872808 + 0.98302005135960 + 0.98099009341551 + 0.97870717148466 + 0.97613720978616 + 0.97324050542905 + 0.96997181511610 + 0.96628091506319 + 0.96211071300124 + 0.95738958640752 + 0.95203958490256 + 0.94599383841555 + 0.93919397933799 + 0.93158459926022 + 0.92312098788631 + 0.91377036799403 + 0.90351513695211 + 0.89235740603634 + 0.88032449281656 + 0.86747401717295 + 0.85389172251926 + 0.83967722757625 + 0.82495947810121 + 0.80992052387975 + 0.79476698050044 + 0.78720390383394 + 0.77968055124147 + 0.77221255649546 + 0.76481049069172 + 0.75747925655303 + 0.75021777768347 + 0.74301910418443 + 0.73587106557355 + 0.72875740928784 + 0.72165598726407 + 0.71448467112207 + 0.70700643730829 + 0.69909691983507 + 0.69074192585878 + 0.68192746262056 + 0.67267016409539 + 0.66299445008811 + 0.65293071280414 + 0.64251379306500 + 0.63178189185970 + 0.62077394176141 + 0.60949526143786 + 0.59798350978998 + 0.58627955918674 + 0.57442786080566 + 0.56247629172860 + 0.55047514870236 + 0.53845668883849 + 0.52644564697700 + 0.51447599533497 + 0.50257133233502 + 0.49074144466958 + 0.99927246791874 + 0.99928261869844 + 0.99928431950812 + 0.99928630897763 + 0.99928863753655 + 0.99929136497863 + 0.99929456244720 + 0.99929831508207 + 0.99930272640898 + 0.99930792936750 + 0.99931411625869 + 0.99932156861910 + 0.99933063536940 + 0.99934172990703 + 0.99935537301251 + 0.99937225003454 + 0.99939329367567 + 0.99941982743894 + 0.99945387660470 + 0.99949884836319 + 0.99956144688677 + 0.99966071786268 + 1.00000000000000 + 0.99963380653155 + 0.99948896498417 + 0.99936482203773 + 0.99924334136813 + 0.99911822430143 + 0.99898636479404 + 0.99884581973855 + 0.99869479704269 + 0.99853172656711 + 0.99835499484524 + 0.99816273817055 + 0.99795271547207 + 0.99772219243215 + 0.99746783544873 + 0.99718561691535 + 0.99687049605815 + 0.99651633450917 + 0.99611628668919 + 0.99566246537020 + 0.99514592745228 + 0.99455727699262 + 0.99389040263812 + 0.99314263772247 + 0.99230513065235 + 0.99136772261257 + 0.99032569647733 + 0.98916905598861 + 0.98788063566023 + 0.98644087605017 + 0.98482868538592 + 0.98302106855510 + 0.98099099078392 + 0.97870796592854 + 0.97613791585115 + 0.97324113556365 + 0.96997237992345 + 0.96628142352891 + 0.96211117265599 + 0.95739000338287 + 0.95203996416735 + 0.94599418411786 + 0.93919429500775 + 0.93158488786861 + 0.92312125195214 + 0.91377060965394 + 0.90351535803026 + 0.89235760810631 + 0.88032467725183 + 0.86747418519202 + 0.85389187522385 + 0.83967736597212 + 0.82495960314738 + 0.80992063655641 + 0.79476708182696 + 0.78720399986832 + 0.77968064224775 + 0.77221264273514 + 0.76481057242420 + 0.75747933403184 + 0.75021785115709 + 0.74301917388636 + 0.73587113173052 + 0.72875747211145 + 0.72165604694915 + 0.71448472781977 + 0.70700649106914 + 0.69909697066372 + 0.69074197376212 + 0.68192750760543 + 0.67267020617761 + 0.66299448929569 + 0.65293074917794 + 0.64251382665759 + 0.63178192274071 + 0.62077397001229 + 0.60949528714867 + 0.59798353306063 + 0.58627958013057 + 0.57442787954803 + 0.56247630840650 + 0.55047516346136 + 0.53845670183136 + 0.52644565836014 + 0.51447600526959 + 0.50257134098199 + 0.49074145218606 + 0.99921127818826 + 0.99922054576355 + 0.99922209619805 + 0.99922390887480 + 0.99922602926760 + 0.99922851115946 + 0.99923141834964 + 0.99923482692411 + 0.99923882902625 + 0.99924354255974 + 0.99924913786532 + 0.99925586378693 + 0.99926402592519 + 0.99927398100985 + 0.99928617061632 + 0.99930116307293 + 0.99931970853783 + 0.99934282552555 + 0.99937197668990 + 0.99940938296947 + 0.99945867017330 + 0.99952691473881 + 0.99963380653155 + 1.00000000000000 + 0.99960468334963 + 0.99944690018856 + 0.99930920029151 + 0.99917341317500 + 0.99903347621354 + 0.99888636022513 + 0.99872977949664 + 0.99856191861460 + 0.99838102715766 + 0.99818515367248 + 0.99797199257593 + 0.99773875598852 + 0.99748206207295 + 0.99719783810954 + 0.99688099988104 + 0.99652536868359 + 0.99612406358652 + 0.99566916554457 + 0.99515170365659 + 0.99456225890111 + 0.99389470328890 + 0.99314635639395 + 0.99230835075105 + 0.99137051479072 + 0.99032812265403 + 0.98917116915894 + 0.98788248043010 + 0.98644249028241 + 0.98483010149732 + 0.98302231444511 + 0.98099209042654 + 0.97870893994693 + 0.97613878198844 + 0.97324190899566 + 0.96997307356239 + 0.96628204831316 + 0.96211173774901 + 0.95739051623755 + 0.95204043080811 + 0.94599460959782 + 0.93919468362270 + 0.93158524325237 + 0.92312157718378 + 0.91377090735398 + 0.90351563044281 + 0.89235785717017 + 0.88032490465824 + 0.86747439244898 + 0.85389206368686 + 0.83967753688033 + 0.82495975768467 + 0.80992077593069 + 0.79476720729157 + 0.78720411884751 + 0.77968075506330 + 0.77221274970984 + 0.76481067387505 + 0.75747943026782 + 0.75021794247741 + 0.74301926058092 + 0.73587121407066 + 0.72875755035431 + 0.72165612132936 + 0.71448479852174 + 0.70700655814721 + 0.69909703411806 + 0.69074203359560 + 0.68192756382122 + 0.67267025879124 + 0.66299453833707 + 0.65293079469394 + 0.64251386871245 + 0.63178196141698 + 0.62077400541207 + 0.60949531937847 + 0.59798356224701 + 0.58627960641284 + 0.57442790308164 + 0.56247632936034 + 0.55047518201736 + 0.53845671817898 + 0.52644567269404 + 0.51447601779027 + 0.50257135188980 + 0.49074146167614 + 0.99914333155147 + 0.99915177931202 + 0.99915319089719 + 0.99915484060827 + 0.99915676949973 + 0.99915902603350 + 0.99916166756984 + 0.99916476233120 + 0.99916839269383 + 0.99917266377926 + 0.99917772732886 + 0.99918380466907 + 0.99919116581727 + 0.99920012262376 + 0.99921105633608 + 0.99922445019682 + 0.99924092912251 + 0.99926131767775 + 0.99928675472140 + 0.99931886936545 + 0.99936006105756 + 0.99941424982573 + 0.99948896498417 + 0.99960468334963 + 1.00000000000000 + 0.99957280503368 + 0.99939957521443 + 0.99924604917507 + 0.99909418204200 + 0.99893793784564 + 0.99877390542221 + 0.99859976516214 + 0.99841350482471 + 0.99821301573279 + 0.99799588396161 + 0.99775923728899 + 0.99749962219089 + 0.99721290195673 + 0.99689393302879 + 0.99653648305090 + 0.99613362492687 + 0.99567739872323 + 0.99515879822390 + 0.99456837538918 + 0.99389998144767 + 0.99315091893079 + 0.99231230067035 + 0.99137393926796 + 0.99033109808826 + 0.98917376087016 + 0.98788474330354 + 0.98644447082900 + 0.98483183948950 + 0.98302384407503 + 0.98099344105160 + 0.97871013681809 + 0.97613984680855 + 0.97324286032025 + 0.96997392716828 + 0.96628281755390 + 0.96211243380058 + 0.95739114818208 + 0.95204100598986 + 0.94599513417728 + 0.93919516284855 + 0.93158568157108 + 0.92312197837698 + 0.91377127465019 + 0.90351596660732 + 0.89235816459517 + 0.88032518544122 + 0.86747464845146 + 0.85389229658747 + 0.83967774821268 + 0.82495994890860 + 0.80992094853588 + 0.79476736282396 + 0.78720426641894 + 0.77968089507110 + 0.77221288254755 + 0.76481079993118 + 0.75747954992030 + 0.75021805609377 + 0.74301936851100 + 0.73587131664799 + 0.72875764788734 + 0.72165621410543 + 0.71448488676122 + 0.70700664191138 + 0.69909711340033 + 0.69074210838973 + 0.68192763412488 + 0.67267032461872 + 0.66299459972119 + 0.65293085168996 + 0.64251392139695 + 0.63178200989083 + 0.62077404979696 + 0.60949535980844 + 0.59798359887672 + 0.58627963941613 + 0.57442793265039 + 0.56247635570378 + 0.55047520536167 + 0.53845673876016 + 0.52644569075463 + 0.51447603357881 + 0.50257136565769 + 0.49074147366572 + 0.99906783147570 + 0.99907551264702 + 0.99907679493087 + 0.99907829308286 + 0.99908004415109 + 0.99908209180957 + 0.99908448765804 + 0.99908729294337 + 0.99909058145199 + 0.99909444715334 + 0.99909902558261 + 0.99910451418253 + 0.99911115267942 + 0.99911921578152 + 0.99912903635474 + 0.99914103176964 + 0.99915573419544 + 0.99917383251254 + 0.99919625481289 + 0.99922428137322 + 0.99925968754373 + 0.99930511078929 + 0.99936482203773 + 0.99944690018856 + 0.99957280503368 + 1.00000000000000 + 0.99953725100417 + 0.99934579149584 + 0.99917433147178 + 0.99900466365224 + 0.99883027787419 + 0.99864769818589 + 0.99845437619248 + 0.99824790785117 + 0.99802569024304 + 0.99778471374920 + 0.99752141490377 + 0.99723156366085 + 0.99690993345720 + 0.99655021910225 + 0.99614543214263 + 0.99568755932273 + 0.99516754902511 + 0.99457591629476 + 0.99390648617654 + 0.99315653988654 + 0.99231716564752 + 0.99137815632749 + 0.99033476190050 + 0.98917695230087 + 0.98788753017885 + 0.98644691052903 + 0.98483398101232 + 0.98302572949976 + 0.98099510648834 + 0.97871161329955 + 0.97614116100488 + 0.97324403500980 + 0.96997498170442 + 0.96628376830536 + 0.96211329445570 + 0.95739192985414 + 0.95204171765761 + 0.94599578338405 + 0.93919575603464 + 0.93158622420378 + 0.92312247512341 + 0.91377172949502 + 0.90351638297685 + 0.89235854545998 + 0.88032553340419 + 0.86747496582429 + 0.85389258546302 + 0.83967801048919 + 0.82496018639843 + 0.80992116308329 + 0.79476755633797 + 0.78720445012901 + 0.77968106946540 + 0.77221304811066 + 0.76481095714080 + 0.75747969924142 + 0.75021819797357 + 0.74301950337790 + 0.73587144490723 + 0.72875776991800 + 0.72165633025574 + 0.71448499729509 + 0.70700674689797 + 0.69909721282140 + 0.69074220223091 + 0.68192772237362 + 0.67267040728619 + 0.66299467684206 + 0.65293092332700 + 0.64251398764251 + 0.63178207086687 + 0.62077410565558 + 0.60949541071408 + 0.59798364501980 + 0.58627968101272 + 0.57442796993875 + 0.56247638894683 + 0.55047523483990 + 0.53845676476852 + 0.52644571359514 + 0.51447605356525 + 0.50257138310091 + 0.49074148886978 + 0.99898370699432 + 0.99899066635146 + 0.99899182727523 + 0.99899318331862 + 0.99899476785372 + 0.99899662017314 + 0.99899878663693 + 0.99900132219270 + 0.99900429291129 + 0.99900778281091 + 0.99901191296311 + 0.99901685955039 + 0.99902283572244 + 0.99903008433641 + 0.99903889772386 + 0.99904963958681 + 0.99906276901262 + 0.99907887243690 + 0.99909872696504 + 0.99912337996408 + 0.99915423049623 + 0.99919324641847 + 0.99924334136813 + 0.99930920029151 + 0.99939957521443 + 0.99953725100417 + 1.00000000000000 + 0.99949734514212 + 0.99928489932275 + 0.99909335011182 + 0.99890373077731 + 0.99870937200612 + 0.99850649996098 + 0.99829211395567 + 0.99806326323393 + 0.99781670406381 + 0.99754869761854 + 0.99725487290917 + 0.99692988363996 + 0.99656732309069 + 0.99616011935296 + 0.99570018819659 + 0.99517841860579 + 0.99458527792893 + 0.99391455772580 + 0.99316351224833 + 0.99232319863866 + 0.99138338491974 + 0.99033930429066 + 0.98918090932911 + 0.98789098625176 + 0.98644993691275 + 0.98483663846706 + 0.98302807014910 + 0.98099717502414 + 0.97871344810730 + 0.97614279505071 + 0.97324549643743 + 0.96997629440996 + 0.96628495247164 + 0.96211436695708 + 0.95739290436440 + 0.95204260522351 + 0.94599659329599 + 0.93919649624266 + 0.93158690147833 + 0.92312309525113 + 0.91377229743706 + 0.90351690301009 + 0.89235902129347 + 0.88032596829349 + 0.86747536266738 + 0.85389294687340 + 0.83967833884542 + 0.82496048396273 + 0.80992143215460 + 0.79476779929588 + 0.78720468091426 + 0.77968128868596 + 0.77221325636832 + 0.76481115502438 + 0.75747988732419 + 0.75021837680974 + 0.74301967349669 + 0.73587160680440 + 0.72875792405888 + 0.72165647706476 + 0.71448513709258 + 0.70700687975928 + 0.69909733870957 + 0.69074232111843 + 0.68192783423321 + 0.67267051211971 + 0.66299477468797 + 0.65293101425716 + 0.64251407176727 + 0.63178214833674 + 0.62077417665819 + 0.60949547545342 + 0.59798370373350 + 0.58627973397227 + 0.57442801744372 + 0.56247643132622 + 0.55047527244856 + 0.53845679797721 + 0.52644574278579 + 0.51447607913117 + 0.50257140543559 + 0.49074150835840 + 0.99888980436857 + 0.99889608163653 + 0.99889712816042 + 0.99889835035249 + 0.99889977817261 + 0.99890144686560 + 0.99890339797433 + 0.99890568067816 + 0.99890835402333 + 0.99891149299555 + 0.99891520554547 + 0.99891964858861 + 0.99892501145402 + 0.99893150894042 + 0.99893939833640 + 0.99894899786506 + 0.99896070626421 + 0.99897502801690 + 0.99899262397716 + 0.99901437099675 + 0.99904141196367 + 0.99907530107829 + 0.99911822430143 + 0.99917341317500 + 0.99924604917507 + 0.99934579149584 + 0.99949734514212 + 1.00000000000000 + 0.99945281395814 + 0.99921640493221 + 0.99900206261732 + 0.99879032072062 + 0.99857403909672 + 0.99834887090239 + 0.99811117514879 + 0.99785728563144 + 0.99758317011529 + 0.99728423582290 + 0.99695495754095 + 0.99658878262449 + 0.99617852253517 + 0.99571599637130 + 0.99519201380070 + 0.99459697945613 + 0.99392464136318 + 0.99317221914576 + 0.99233073027924 + 0.99138991117020 + 0.99034497381307 + 0.98918584876478 + 0.98789530136362 + 0.98645371680502 + 0.98483995897233 + 0.98303099624464 + 0.98099976236654 + 0.97871574447181 + 0.97614484145180 + 0.97324732785997 + 0.96997794052810 + 0.96628643834038 + 0.96211571349315 + 0.95739412850553 + 0.95204372063546 + 0.94599761149072 + 0.93919742709697 + 0.93158775342455 + 0.92312387551756 + 0.91377301223842 + 0.90351755771178 + 0.89235962056713 + 0.88032651624052 + 0.86747586293997 + 0.85389340276305 + 0.83967875335070 + 0.82496085992506 + 0.80992177246476 + 0.79476810693578 + 0.78720497332711 + 0.77968156663135 + 0.77221352059756 + 0.76481140627187 + 0.75748012630552 + 0.75021860421069 + 0.74301988997077 + 0.73587181296811 + 0.72875812048672 + 0.72165666427682 + 0.71448531548237 + 0.70700704940394 + 0.69909749954686 + 0.69074247309442 + 0.68192797730096 + 0.67267064627068 + 0.66299489995772 + 0.65293113072659 + 0.64251417957205 + 0.63178224766246 + 0.62077426773791 + 0.60949555854322 + 0.59798377913395 + 0.58627980202413 + 0.57442807852768 + 0.56247648585929 + 0.55047532088146 + 0.53845684078158 + 0.52644578044689 + 0.51447611214880 + 0.50257143431222 + 0.49074153358080 + 0.99878513236717 + 0.99879076607661 + 0.99879170486932 + 0.99879280108665 + 0.99879408151422 + 0.99879557764967 + 0.99879732658289 + 0.99879937217463 + 0.99880176703877 + 0.99880457789403 + 0.99880790068867 + 0.99881187472184 + 0.99881666772787 + 0.99882246939647 + 0.99882950609127 + 0.99883805653593 + 0.99884846802125 + 0.99886117680842 + 0.99887674962598 + 0.99889593014881 + 0.99891967133223 + 0.99894924064422 + 0.99898636479404 + 0.99903347621354 + 0.99909418204200 + 0.99917433147178 + 0.99928489932275 + 0.99945281395814 + 1.00000000000000 + 0.99940315834840 + 0.99913909759151 + 0.99889923895623 + 0.99866311318459 + 0.99842273464998 + 0.99817293516244 + 0.99790922670927 + 0.99762705703930 + 0.99732146756782 + 0.99698665493435 + 0.99661584961051 + 0.99620169534458 + 0.99573587629396 + 0.99520909401646 + 0.99461166917398 + 0.99393729220881 + 0.99318313763521 + 0.99234017179342 + 0.99139809057142 + 0.99035207894748 + 0.98919203940042 + 0.98790071060678 + 0.98645845654836 + 0.98484412427516 + 0.98303466845101 + 0.98100301109001 + 0.97871862943477 + 0.97614741389638 + 0.97324963146394 + 0.96998001230891 + 0.96628830952569 + 0.96211741013202 + 0.95739567165474 + 0.95204512727862 + 0.94599889594868 + 0.93919860169493 + 0.93158882870414 + 0.92312486055101 + 0.91377391484224 + 0.90351838465868 + 0.89236037775545 + 0.88032720885744 + 0.86747649560778 + 0.85389397965372 + 0.83967927824553 + 0.82496133641733 + 0.80992220419259 + 0.79476849765436 + 0.78720534493377 + 0.77968192007984 + 0.77221385682805 + 0.76481172620570 + 0.75748043083263 + 0.75021889418854 + 0.74302016621171 + 0.73587207623655 + 0.72875837149142 + 0.72165690366342 + 0.71448554373107 + 0.70700726659118 + 0.69909770557663 + 0.69074266787753 + 0.68192816075912 + 0.67267081837807 + 0.66299506074417 + 0.65293128028868 + 0.64251431807072 + 0.63178237532574 + 0.62077438486146 + 0.60949566544870 + 0.59798387619929 + 0.58627988968213 + 0.57442815726261 + 0.56247655620008 + 0.55047538340288 + 0.53845689608398 + 0.52644582915095 + 0.51447615489075 + 0.50257147173147 + 0.49074156630036 + 0.99866875172343 + 0.99867378122316 + 0.99867461902012 + 0.99867559719188 + 0.99867673958350 + 0.99867807421469 + 0.99867963406251 + 0.99868145809326 + 0.99868359300278 + 0.99868609794181 + 0.99868905784861 + 0.99869259588050 + 0.99869686009789 + 0.99870201756107 + 0.99870826704417 + 0.99871585244725 + 0.99872507634457 + 0.99873631674400 + 0.99875006158483 + 0.99876694592869 + 0.99878777353121 + 0.99881359692422 + 0.99884581973855 + 0.99888636022513 + 0.99893793784564 + 0.99900466365224 + 0.99909335011182 + 0.99921640493221 + 0.99940315834840 + 1.00000000000000 + 0.99934714491465 + 0.99905166105877 + 0.99878347621078 + 0.99852051076951 + 0.99825356271103 + 0.99797636426294 + 0.99768336975121 + 0.99736898142103 + 0.99702694279556 + 0.99665014926039 + 0.99623099530400 + 0.99576097144264 + 0.99523062835004 + 0.99463017197733 + 0.99395321509532 + 0.99319687243649 + 0.99235204378786 + 0.99140837267639 + 0.99036100941191 + 0.98919982047936 + 0.98790751040883 + 0.98646441607374 + 0.98484936309399 + 0.98303928876227 + 0.98100710027509 + 0.97872226241400 + 0.97615065490920 + 0.97325253523699 + 0.96998262518301 + 0.96629067055393 + 0.96211955186642 + 0.95739762037137 + 0.95204690415113 + 0.94600051886535 + 0.93920008607819 + 0.93159018779393 + 0.92312610576231 + 0.91377505604483 + 0.90351943041678 + 0.89236133554887 + 0.88032808526708 + 0.86747729650426 + 0.85389471032744 + 0.83967994349314 + 0.82496194077834 + 0.80992275226643 + 0.79476899417786 + 0.78720581743420 + 0.77968236975713 + 0.77221428486314 + 0.76481213374987 + 0.75748081900357 + 0.75021926405613 + 0.74302051878868 + 0.73587241247237 + 0.72875869226593 + 0.72165720977477 + 0.71448583576845 + 0.70700754462978 + 0.69909796946921 + 0.69074291748765 + 0.68192839596591 + 0.67267103912807 + 0.66299526706489 + 0.65293147228605 + 0.64251449594097 + 0.63178253935483 + 0.62077453541525 + 0.60949580293411 + 0.59798400109539 + 0.58628000253834 + 0.57442825869205 + 0.56247664687813 + 0.55047546406131 + 0.53845696748744 + 0.52644589208968 + 0.51447621017794 + 0.50257152018191 + 0.49074160870901 + 0.99853941778640 + 0.99854388328033 + 0.99854462691169 + 0.99854549505936 + 0.99854650884954 + 0.99854769308949 + 0.99854907696412 + 0.99855069493982 + 0.99855258828342 + 0.99855480920880 + 0.99855743256647 + 0.99856056672738 + 0.99856434181820 + 0.99856890442400 + 0.99857442856741 + 0.99858112717948 + 0.99858926350885 + 0.99859916499898 + 0.99861125221749 + 0.99862606907864 + 0.99864429753326 + 0.99866682038099 + 0.99869479704269 + 0.99872977949664 + 0.99877390542221 + 0.99883027787419 + 0.99890373077731 + 0.99900206261732 + 0.99913909759151 + 0.99934714491465 + 1.00000000000000 + 0.99928401480820 + 0.99895303522899 + 0.99865345012049 + 0.99836086870367 + 0.99806443166612 + 0.99775647842334 + 0.99743020463990 + 0.99707856986211 + 0.99669392565343 + 0.99626828042797 + 0.99579283684976 + 0.99525792862367 + 0.99465360081268 + 0.99397335879459 + 0.99321423632745 + 0.99236704531783 + 0.99142136083259 + 0.99037228817875 + 0.98920964734812 + 0.98791609883325 + 0.98647194465973 + 0.98485598302966 + 0.98304512907883 + 0.98101227120395 + 0.97872685840098 + 0.97615475690651 + 0.97325621214543 + 0.96998593529956 + 0.96629366296752 + 0.96212226744758 + 0.95740009206968 + 0.95204915850233 + 0.94600257831375 + 0.93920197002927 + 0.93159191294627 + 0.92312768655817 + 0.91377650500719 + 0.90352075843627 + 0.89236255215307 + 0.88032919885387 + 0.86747831455507 + 0.85389563958897 + 0.83968079007157 + 0.82496271044199 + 0.80992345085167 + 0.79476962768278 + 0.78720642061818 + 0.77968294413266 + 0.77221483191869 + 0.76481265493808 + 0.75748131572687 + 0.75021973765504 + 0.74302097053170 + 0.73587284354507 + 0.72875910376595 + 0.72165760269365 + 0.71448621082764 + 0.70700790190144 + 0.69909830873214 + 0.69074323854171 + 0.68192869862934 + 0.67267132331177 + 0.66299553278095 + 0.65293171965769 + 0.64251472520687 + 0.63178275086806 + 0.62077472964238 + 0.60949598038559 + 0.59798416238092 + 0.58628014835637 + 0.57442838982512 + 0.56247676418994 + 0.55047556848734 + 0.53845706000718 + 0.52644597371368 + 0.51447628194661 + 0.50257158313806 + 0.49074166386961 + 0.99839584345631 + 0.99839978688988 + 0.99840044343743 + 0.99840120986610 + 0.99840210480035 + 0.99840315010108 + 0.99840437147962 + 0.99840579927876 + 0.99840746981366 + 0.99840942896910 + 0.99841174240035 + 0.99841450499338 + 0.99841783058761 + 0.99842184727895 + 0.99842670688743 + 0.99843259476033 + 0.99843973940368 + 0.99844842406023 + 0.99845901105958 + 0.99847196662972 + 0.99848787104625 + 0.99850746882710 + 0.99853172656711 + 0.99856191861460 + 0.99859976516214 + 0.99864769818589 + 0.99870937200612 + 0.99879032072062 + 0.99889923895623 + 0.99905166105877 + 0.99928401480820 + 1.00000000000000 + 0.99921281241063 + 0.99884188697548 + 0.99850752339728 + 0.99818213645345 + 0.99785272505265 + 0.99750994892537 + 0.99714530181359 + 0.99675019783029 + 0.99631601723679 + 0.99583351685474 + 0.99529270732113 + 0.99468340118131 + 0.99399895107746 + 0.99323627827755 + 0.99238607676739 + 0.99143783093763 + 0.99038658694552 + 0.98922210421254 + 0.98792698610612 + 0.98648148962492 + 0.98486437766861 + 0.98305253702887 + 0.98101883210836 + 0.97873269183432 + 0.97615996529399 + 0.97326088262015 + 0.96999014150859 + 0.96629746686547 + 0.96212572057500 + 0.95740323591767 + 0.95205202645901 + 0.94600519866529 + 0.93920436729680 + 0.93159410828564 + 0.92312969832182 + 0.91377834914081 + 0.90352244884795 + 0.89236410102690 + 0.88033061693940 + 0.86747961143404 + 0.85389682389626 + 0.83968186960323 + 0.82496369255745 + 0.80992434297828 + 0.79477043743964 + 0.78720719200409 + 0.77968367906520 + 0.77221553228119 + 0.76481332256247 + 0.75748195238054 + 0.75022034502613 + 0.74302155021142 + 0.73587339701957 + 0.72875963240443 + 0.72165810773274 + 0.71448669316192 + 0.70700836158380 + 0.69909874544556 + 0.69074365199567 + 0.68192908856411 + 0.67267168958424 + 0.66299587538233 + 0.65293203872869 + 0.64251502103886 + 0.63178302390412 + 0.62077498046850 + 0.60949620965129 + 0.59798437086052 + 0.58628033694134 + 0.57442855951872 + 0.56247691609633 + 0.55047570380345 + 0.53845717998801 + 0.52644607965486 + 0.51447637518029 + 0.50257166500162 + 0.49074173566491 + 0.99823657968322 + 0.99824004464426 + 0.99824062143469 + 0.99824129472762 + 0.99824208086152 + 0.99824299901839 + 0.99824407174508 + 0.99824532565022 + 0.99824679255066 + 0.99824851260820 + 0.99825054314343 + 0.99825296684905 + 0.99825588285861 + 0.99825940267340 + 0.99826365826227 + 0.99826881046351 + 0.99827505711745 + 0.99828264276719 + 0.99829187920635 + 0.99830316598489 + 0.99831699750145 + 0.99833400364962 + 0.99835499484524 + 0.99838102715766 + 0.99841350482471 + 0.99845437619248 + 0.99850649996098 + 0.99857403909672 + 0.99866311318459 + 0.99878347621078 + 0.99895303522899 + 0.99921281241063 + 1.00000000000000 + 0.99913236101119 + 0.99871664938789 + 0.99834374293116 + 0.99798182169960 + 0.99761524621839 + 0.99723245917546 + 0.99682312751939 + 0.99637754530103 + 0.99588574364047 + 0.99533723176989 + 0.99472147409060 + 0.99403159882492 + 0.99326436638420 + 0.99241030944277 + 0.99145879040151 + 0.99040477652245 + 0.98923794754833 + 0.98794083224682 + 0.98649362907337 + 0.98487505528031 + 0.98306196117487 + 0.98102718042043 + 0.97874011630651 + 0.97616659605470 + 0.97326683027521 + 0.96999549947002 + 0.96630231364361 + 0.96213012141028 + 0.95740724326549 + 0.95205568251112 + 0.94600853921898 + 0.93920742345223 + 0.93159690694988 + 0.92313226289794 + 0.91378070002669 + 0.90352460386133 + 0.89236607580744 + 0.88033242529677 + 0.86748126567849 + 0.85389833510787 + 0.83968324777987 + 0.82496494710551 + 0.80992548337470 + 0.79477147339601 + 0.78720817931796 + 0.77968462016828 + 0.77221642956074 + 0.76481417833962 + 0.75748276888884 + 0.75022112439270 + 0.74302229443860 + 0.73587410797452 + 0.72876031180175 + 0.72165875711939 + 0.71448731364346 + 0.70700895318635 + 0.69909930772554 + 0.69074418454164 + 0.68192959100404 + 0.67267216170312 + 0.66299631714521 + 0.65293245029452 + 0.64251540276243 + 0.63178337634259 + 0.62077530436376 + 0.60949650582853 + 0.59798464030759 + 0.58628058079626 + 0.57442877906409 + 0.56247711274680 + 0.55047587909482 + 0.53845733552920 + 0.52644621710510 + 0.51447649624801 + 0.50257177140056 + 0.49074182906376 + 0.99805988331042 + 0.99806291430572 + 0.99806341880343 + 0.99806400768564 + 0.99806469523517 + 0.99806549821369 + 0.99806643632162 + 0.99806753279591 + 0.99806881541778 + 0.99807031919764 + 0.99807209398814 + 0.99807421153297 + 0.99807675781672 + 0.99807982952531 + 0.99808354100323 + 0.99808803141164 + 0.99809347161643 + 0.99810007234900 + 0.99810810154919 + 0.99811790143001 + 0.99812989348126 + 0.99814461169021 + 0.99816273817055 + 0.99818515367248 + 0.99821301573279 + 0.99824790785117 + 0.99829211395567 + 0.99834887090239 + 0.99842273464998 + 0.99852051076951 + 0.99865345012049 + 0.99884188697548 + 0.99913236101119 + 1.00000000000000 + 0.99904134234629 + 0.99857555038353 + 0.99815982093320 + 0.99775694111005 + 0.99734786300770 + 0.99691862670419 + 0.99645749375981 + 0.99595323850930 + 0.99539455164167 + 0.99477035373195 + 0.99407343054715 + 0.99330030464991 + 0.99244128276929 + 0.99148556003419 + 0.99042799653169 + 0.98925816596022 + 0.98795849883875 + 0.98650911698371 + 0.98488867822780 + 0.98307398565375 + 0.98103783333910 + 0.97874959166913 + 0.97617505984985 + 0.97327442348556 + 0.97000234105272 + 0.96630850347465 + 0.96213574240629 + 0.95741236201900 + 0.95206035254746 + 0.94601280602468 + 0.93921132664261 + 0.93160048088210 + 0.92313553754008 + 0.91378370155256 + 0.90352735519114 + 0.89236859708959 + 0.88033473432577 + 0.86748337832820 + 0.85390026564735 + 0.83968500905677 + 0.82496655118572 + 0.80992694239072 + 0.79477279974172 + 0.78720944389300 + 0.77968582606670 + 0.77221757981694 + 0.76481527589857 + 0.75748381657517 + 0.75022212489618 + 0.74302325028869 + 0.73587502151883 + 0.72876118519613 + 0.72165959230131 + 0.71448811198420 + 0.70700971467616 + 0.69910003174519 + 0.69074487051755 + 0.68193023841913 + 0.67267277024416 + 0.66299688673727 + 0.65293298111543 + 0.64251589525359 + 0.63178383120096 + 0.62077572253120 + 0.60949688835527 + 0.59798498845363 + 0.58628089602092 + 0.57442906300749 + 0.56247736722393 + 0.55047610607326 + 0.53845753707348 + 0.52644639534473 + 0.51447665337268 + 0.50257190960482 + 0.49074195048691 + 0.99786362452819 + 0.99786626602121 + 0.99786670565966 + 0.99786721882522 + 0.99786781795716 + 0.99786851765472 + 0.99786933507342 + 0.99787029044890 + 0.99787140795367 + 0.99787271802484 + 0.99787426386037 + 0.99787610748045 + 0.99787832320008 + 0.99788099459968 + 0.99788422047739 + 0.99788812093456 + 0.99789284323694 + 0.99789856868284 + 0.99790552726566 + 0.99791401192583 + 0.99792438216556 + 0.99793709139070 + 0.99795271547207 + 0.99797199257593 + 0.99799588396161 + 0.99802569024304 + 0.99806326323393 + 0.99811117514879 + 0.99817293516244 + 0.99825356271103 + 0.99836086870367 + 0.99850752339728 + 0.99871664938789 + 0.99904134234629 + 1.00000000000000 + 0.99893827735379 + 0.99841655825976 + 0.99795304903898 + 0.99750360497546 + 0.99704539530633 + 0.99656244285404 + 0.99604116368300 + 0.99546882525658 + 0.99483345377243 + 0.99412728891160 + 0.99334648769651 + 0.99248103120026 + 0.99151987972830 + 0.99045774458359 + 0.98928405621545 + 0.98798111440357 + 0.98652893975530 + 0.98490611216873 + 0.98308937319618 + 0.98105146562209 + 0.97876171738892 + 0.97618589161975 + 0.97328414174410 + 0.97001109790395 + 0.96631642649167 + 0.96214293739965 + 0.95741891385823 + 0.95206632944009 + 0.94601826600756 + 0.93921632037836 + 0.93160505241923 + 0.92313972539306 + 0.91378753944598 + 0.90353087271423 + 0.89237182027885 + 0.88033768621128 + 0.86748607942978 + 0.85390273440667 + 0.83968726203989 + 0.82496860391419 + 0.80992881043109 + 0.79477449896588 + 0.78721106454080 + 0.77968737208691 + 0.77221905507467 + 0.76481668413359 + 0.75748516138341 + 0.75022340968385 + 0.74302447825220 + 0.73587619562138 + 0.72876230815359 + 0.72166066654687 + 0.71448913922698 + 0.70701069484712 + 0.69910096399755 + 0.69074575406169 + 0.68193107254225 + 0.67267355450482 + 0.66299762100377 + 0.65293366559159 + 0.64251653048233 + 0.63178441806389 + 0.62077626222542 + 0.60949738222117 + 0.59798543810223 + 0.58628130331733 + 0.57442943005806 + 0.56247769635487 + 0.55047639981288 + 0.53845779806857 + 0.52644662632504 + 0.51447685714570 + 0.50257208898518 + 0.49074210821504 + 0.99764518766204 + 0.99764748301246 + 0.99764786503206 + 0.99764831093788 + 0.99764883153792 + 0.99764943951723 + 0.99765014977687 + 0.99765097989231 + 0.99765195085091 + 0.99765308904577 + 0.99765443181701 + 0.99765603261858 + 0.99765795550299 + 0.99766027254979 + 0.99766306893612 + 0.99766644812749 + 0.99767053684981 + 0.99767549090089 + 0.99768150755271 + 0.99768883751311 + 0.99769778760211 + 0.99770874340506 + 0.99772219243215 + 0.99773875598852 + 0.99775923728899 + 0.99778471374920 + 0.99781670406381 + 0.99785728563144 + 0.99790922670927 + 0.99797636426294 + 0.99806443166612 + 0.99818213645345 + 0.99834374293116 + 0.99857555038353 + 0.99893827735379 + 1.00000000000000 + 0.99882149968971 + 0.99823731409950 + 0.99771985132161 + 0.99721690277686 + 0.99670207975267 + 0.99615685960732 + 0.99556582499805 + 0.99491543413350 + 0.99419700917301 + 0.99340611975984 + 0.99253226098195 + 0.99156405394672 + 0.99049599790781 + 0.98931732624230 + 0.98801016247137 + 0.98655439211952 + 0.98492849189577 + 0.98310912253746 + 0.98106895990965 + 0.97877727685191 + 0.97619978978261 + 0.97329661052261 + 0.97002233258954 + 0.96632659070997 + 0.96215216671752 + 0.95742731690756 + 0.95207399349039 + 0.94602526542151 + 0.93922272021614 + 0.93161090937905 + 0.92314508916886 + 0.91379245364992 + 0.90353537568024 + 0.89237594579085 + 0.88034146415235 + 0.86748953643369 + 0.85390589437183 + 0.83969014640118 + 0.82497123269653 + 0.80993120366546 + 0.79477667703172 + 0.78721314249353 + 0.77968935497556 + 0.77222094783191 + 0.76481849153397 + 0.75748688799681 + 0.75022505983867 + 0.74302605600359 + 0.73587770471892 + 0.72876375202465 + 0.72166204825730 + 0.71449046090980 + 0.70701195635676 + 0.69910216418191 + 0.69074689184608 + 0.68193214695832 + 0.67267456493998 + 0.66299856725146 + 0.65293454788193 + 0.64251734949273 + 0.63178517491269 + 0.62077695843622 + 0.60949801950643 + 0.59798601852459 + 0.58628182926912 + 0.57442990423964 + 0.56247812175430 + 0.55047677967511 + 0.53845813579127 + 0.52644692540897 + 0.51447712119031 + 0.50257232159664 + 0.49074231290505 + 0.99740137075766 + 0.99740336123554 + 0.99740369251728 + 0.99740407920081 + 0.99740453065996 + 0.99740505789227 + 0.99740567382253 + 0.99740639369088 + 0.99740723569333 + 0.99740822267405 + 0.99740938684670 + 0.99741077419654 + 0.99741243982540 + 0.99741444579170 + 0.99741686542662 + 0.99741978775570 + 0.99742332172877 + 0.99742760115622 + 0.99743279520126 + 0.99743911847322 + 0.99744683306986 + 0.99745626745259 + 0.99746783544873 + 0.99748206207295 + 0.99749962219089 + 0.99752141490377 + 0.99754869761854 + 0.99758317011529 + 0.99762705703930 + 0.99768336975121 + 0.99775647842334 + 0.99785272505265 + 0.99798182169960 + 0.99815982093320 + 0.99841655825976 + 0.99882149968971 + 1.00000000000000 + 0.99868912037802 + 0.99803463270719 + 0.99745567023621 + 0.99689140849988 + 0.99631113144737 + 0.99569376037957 + 0.99502276810952 + 0.99428783347909 + 0.99348353147818 + 0.99259860059823 + 0.99162115462991 + 0.99054538103090 + 0.98936023586751 + 0.98804760114044 + 0.98658717961602 + 0.98495730984015 + 0.98313454532598 + 0.98109147392219 + 0.97879729640778 + 0.97621766837501 + 0.97331264753575 + 0.97003677983699 + 0.96633965893598 + 0.96216403034153 + 0.95743811554583 + 0.95208383929240 + 0.94603425407591 + 0.93923093561698 + 0.93161842479233 + 0.92315196896654 + 0.91379875443860 + 0.90354114730776 + 0.89238123223238 + 0.88034630432655 + 0.86749396501949 + 0.85390994244827 + 0.83969384178452 + 0.82497460130362 + 0.80993427134608 + 0.79477947001243 + 0.78721580772103 + 0.77969189892674 + 0.77222337681772 + 0.76482081165696 + 0.75748910508494 + 0.75022717940628 + 0.74302808320364 + 0.73587964430740 + 0.72876560834437 + 0.72166382517853 + 0.71449216110862 + 0.70701357957296 + 0.69910370886312 + 0.69074835655275 + 0.68193353038226 + 0.67267586624225 + 0.66299978612840 + 0.65293568459870 + 0.64251840489786 + 0.63178615042572 + 0.62077785600680 + 0.60949884132514 + 0.59798676723594 + 0.58628250794422 + 0.57443051634760 + 0.56247867113026 + 0.55047727048517 + 0.53845857239710 + 0.52644731230241 + 0.51447746298583 + 0.50257262291608 + 0.49074257824476 + 0.99712828957644 + 0.99713001355693 + 0.99713030049146 + 0.99713063541591 + 0.99713102645103 + 0.99713148312128 + 0.99713201662500 + 0.99713264016432 + 0.99713336949945 + 0.99713422438698 + 0.99713523259163 + 0.99713643362823 + 0.99713787485111 + 0.99713960964078 + 0.99714170109019 + 0.99714422576066 + 0.99714727729513 + 0.99715097060664 + 0.99715545080043 + 0.99716090170591 + 0.99716754748617 + 0.99717566847939 + 0.99718561691535 + 0.99719783810954 + 0.99721290195673 + 0.99723156366085 + 0.99725487290917 + 0.99728423582290 + 0.99732146756782 + 0.99736898142103 + 0.99743020463990 + 0.99750994892537 + 0.99761524621839 + 0.99775694111005 + 0.99795304903898 + 0.99823731409950 + 0.99868912037802 + 1.00000000000000 + 0.99853840955257 + 0.99780439304830 + 0.99715554321574 + 0.99652070778842 + 0.99586471103019 + 0.99516466381451 + 0.99440705062642 + 0.99358465119238 + 0.99268496328180 + 0.99169530898791 + 0.99060940001453 + 0.98941579120452 + 0.98809602673990 + 0.98662955796591 + 0.98499453576798 + 0.98316736970122 + 0.98112053064675 + 0.97882312435860 + 0.97624072660456 + 0.97333332430675 + 0.97005540129234 + 0.96635649767352 + 0.96217931171768 + 0.95745201978815 + 0.95209651113746 + 0.94604581718117 + 0.93924149859987 + 0.93162808272275 + 0.92316080554072 + 0.91380684340986 + 0.90354855371747 + 0.89238801352337 + 0.88035251136543 + 0.86749964310391 + 0.85391513212242 + 0.83969857926121 + 0.82497892023127 + 0.80993820517914 + 0.79478305259272 + 0.78721922703716 + 0.77969516329603 + 0.77222649433894 + 0.76482379014564 + 0.75749195200026 + 0.75022990178854 + 0.74303068761454 + 0.73588213680047 + 0.72876799442821 + 0.72166610975781 + 0.71449434754813 + 0.70701566746227 + 0.69910569613187 + 0.69075024127292 + 0.68193531081274 + 0.67267754125070 + 0.66300135528047 + 0.65293714820629 + 0.64251976403206 + 0.63178740689671 + 0.62077901231578 + 0.60949990027899 + 0.59798773223113 + 0.58628338292706 + 0.57443130577257 + 0.56247937992735 + 0.55047790400587 + 0.53845913624020 + 0.52644781222885 + 0.51447790490968 + 0.50257301275965 + 0.49074292176468 + 0.99682105773981 + 0.99682255003376 + 0.99682279841782 + 0.99682308834660 + 0.99682342685267 + 0.99682382218271 + 0.99682428403551 + 0.99682482384284 + 0.99682545524595 + 0.99682619533020 + 0.99682706801282 + 0.99682810723868 + 0.99682935368590 + 0.99683085326831 + 0.99683266025495 + 0.99683484048859 + 0.99683747446716 + 0.99684066091432 + 0.99684452437783 + 0.99684922245773 + 0.99685494714346 + 0.99686193814865 + 0.99687049605815 + 0.99688099988104 + 0.99689393302879 + 0.99690993345720 + 0.99692988363996 + 0.99695495754095 + 0.99698665493435 + 0.99702694279556 + 0.99707856986211 + 0.99714530181359 + 0.99723245917546 + 0.99734786300770 + 0.99750360497546 + 0.99771985132161 + 0.99803463270719 + 0.99853840955257 + 1.00000000000000 + 0.99836620403404 + 0.99754258717719 + 0.99681382614293 + 0.99609755210646 + 0.99535482046460 + 0.99456516406993 + 0.99371784333435 + 0.99279818225845 + 0.99179219983331 + 0.99069284845621 + 0.98948808172635 + 0.98815895853554 + 0.98668457667659 + 0.98504282738773 + 0.98320992385894 + 0.98115817948178 + 0.97885657329856 + 0.97627057534275 + 0.97336007919436 + 0.97007948700143 + 0.96637826864237 + 0.96219906060470 + 0.95746998040201 + 0.95211287122356 + 0.94606073732652 + 0.93925512012676 + 0.93164052955599 + 0.92317218700856 + 0.91381725602166 + 0.90355808271772 + 0.89239673427510 + 0.88036049061938 + 0.86750694027985 + 0.85392180033733 + 0.83970466585656 + 0.82498446906358 + 0.80994325971565 + 0.79478765666842 + 0.78722362186278 + 0.77969935959371 + 0.77223050254648 + 0.76482762030399 + 0.75749561368620 + 0.75023340401657 + 0.74303403878479 + 0.73588534463879 + 0.72877106595340 + 0.72166905120839 + 0.71449716317578 + 0.70701835665151 + 0.69910825613248 + 0.69075266952110 + 0.68193760499390 + 0.67267969985263 + 0.66300337770098 + 0.65293903482089 + 0.64252151620229 + 0.63178902694620 + 0.62078050345639 + 0.60950126612759 + 0.59798897715959 + 0.58628451201566 + 0.57443232476251 + 0.56248029516416 + 0.55047872237695 + 0.53845986494486 + 0.52644845866958 + 0.51447847668042 + 0.50257351745210 + 0.49074336676379 + 0.99647369112758 + 0.99647498271003 + 0.99647519769590 + 0.99647544864453 + 0.99647574164160 + 0.99647608383042 + 0.99647648360816 + 0.99647695087003 + 0.99647749742883 + 0.99647813805323 + 0.99647889335375 + 0.99647979249187 + 0.99648087042195 + 0.99648216663563 + 0.99648372782683 + 0.99648561063870 + 0.99648788429697 + 0.99649063366729 + 0.99649396573382 + 0.99649801574509 + 0.99650294835747 + 0.99650896891342 + 0.99651633450917 + 0.99652536868359 + 0.99653648305090 + 0.99655021910225 + 0.99656732309069 + 0.99658878262449 + 0.99661584961051 + 0.99665014926039 + 0.99669392565343 + 0.99675019783029 + 0.99682312751939 + 0.99691862670419 + 0.99704539530633 + 0.99721690277686 + 0.99745567023621 + 0.99780439304830 + 0.99836620403404 + 1.00000000000000 + 0.99816998726423 + 0.99724473857694 + 0.99642415990603 + 0.99561465959712 + 0.99477783067468 + 0.99389519990703 + 0.99294793703231 + 0.99191976583391 + 0.99080235840229 + 0.98958272691205 + 0.98824120897176 + 0.98675639109530 + 0.98510579672570 + 0.98326536578124 + 0.98120719604775 + 0.97890009518115 + 0.97630939153126 + 0.97339485439018 + 0.97011077762801 + 0.96640653831422 + 0.96222469159275 + 0.95749327776340 + 0.95213407986385 + 0.94608006695192 + 0.93927275558676 + 0.93165663324496 + 0.92318690246837 + 0.91383071018437 + 0.90357038784829 + 0.89240798972530 + 0.88037078441573 + 0.86751635074584 + 0.85393039739888 + 0.83971251169845 + 0.82499162113032 + 0.80994977474779 + 0.79479359170647 + 0.78722928765021 + 0.77970477002556 + 0.77223567111768 + 0.76483255998908 + 0.75750033682451 + 0.75023792222037 + 0.74303836284609 + 0.73588948446497 + 0.72877503053545 + 0.72167284851395 + 0.71450079860589 + 0.70702182931831 + 0.69911156238452 + 0.69075580595832 + 0.68194056855427 + 0.67268248851806 + 0.66300599065865 + 0.65294147252805 + 0.64252378040517 + 0.63179112064501 + 0.62078243080467 + 0.60950303179940 + 0.59799058680790 + 0.58628597220885 + 0.57443364292020 + 0.56248147948385 + 0.55047978175069 + 0.53846080865797 + 0.52644929625956 + 0.51447921792057 + 0.50257417211233 + 0.49074394433234 + 0.99607948633617 + 0.99608060446836 + 0.99608079059028 + 0.99608100784705 + 0.99608126151163 + 0.99608155776869 + 0.99608190388797 + 0.99608230844395 + 0.99608278165923 + 0.99608333630771 + 0.99608399015696 + 0.99608476827767 + 0.99608570072328 + 0.99608682148302 + 0.99608817075507 + 0.99608979729403 + 0.99609176067216 + 0.99609413390256 + 0.99609700895449 + 0.99610050203184 + 0.99610475452899 + 0.99610994263304 + 0.99611628668919 + 0.99612406358652 + 0.99613362492687 + 0.99614543214263 + 0.99616011935296 + 0.99617852253517 + 0.99620169534458 + 0.99623099530400 + 0.99626828042797 + 0.99631601723679 + 0.99637754530103 + 0.99645749375981 + 0.99656244285404 + 0.99670207975267 + 0.99689140849988 + 0.99715554321574 + 0.99754258717719 + 0.99816998726423 + 1.00000000000000 + 0.99794616632948 + 0.99690522950478 + 0.99597987868104 + 0.99506917794305 + 0.99413447620331 + 0.99314800222369 + 0.99208906738335 + 0.99094703435095 + 0.98970735994652 + 0.98834926407528 + 0.98685056844745 + 0.98518826058596 + 0.98333789095092 + 0.98127125624090 + 0.97895692849698 + 0.97636004358365 + 0.97344020349756 + 0.97015155724311 + 0.96644335830970 + 0.96225805398909 + 0.95752358269073 + 0.95216164843043 + 0.94610517436541 + 0.93929564478830 + 0.93167751802360 + 0.92320597209694 + 0.91384813230545 + 0.90358631093170 + 0.89242254526171 + 0.88038408893890 + 0.86752850790003 + 0.85394149958643 + 0.83972264092260 + 0.82500085291362 + 0.80995818342078 + 0.79480125174256 + 0.78723660040015 + 0.77971175354665 + 0.77224234291893 + 0.76483893688202 + 0.75750643477446 + 0.75024375622278 + 0.74304394681253 + 0.73589483115002 + 0.72878015149035 + 0.72167775396364 + 0.71450549544414 + 0.70702631629046 + 0.69911583466674 + 0.69075985906584 + 0.68194439845048 + 0.67268609254555 + 0.66300936773079 + 0.65294462322722 + 0.64252670699440 + 0.63179382701495 + 0.62078492234416 + 0.60950531457199 + 0.59799266814125 + 0.58628786061247 + 0.57443534800038 + 0.56248301184890 + 0.55048115289286 + 0.53846203056927 + 0.52645038124037 + 0.51448017856330 + 0.50257502098945 + 0.49074469364876 + 0.99563068942909 + 0.99563165776109 + 0.99563181895111 + 0.99563200710735 + 0.99563222679461 + 0.99563248337289 + 0.99563278313833 + 0.99563313351661 + 0.99563354336372 + 0.99563402372577 + 0.99563458993323 + 0.99563526355878 + 0.99563607046332 + 0.99563703992168 + 0.99563820656194 + 0.99563961237575 + 0.99564130866888 + 0.99564335829137 + 0.99564584038606 + 0.99564885487908 + 0.99565252333224 + 0.99565699711049 + 0.99566246537020 + 0.99566916554457 + 0.99567739872323 + 0.99568755932273 + 0.99570018819659 + 0.99571599637130 + 0.99573587629396 + 0.99576097144264 + 0.99579283684976 + 0.99583351685474 + 0.99588574364047 + 0.99595323850930 + 0.99604116368300 + 0.99615685960732 + 0.99631113144737 + 0.99652070778842 + 0.99681382614293 + 0.99724473857694 + 0.99794616632948 + 1.00000000000000 + 0.99769068667278 + 0.99651873178705 + 0.99547962982142 + 0.99446325342356 + 0.99341880488537 + 0.99231602019000 + 0.99113971480568 + 0.98987259410788 + 0.98849205159770 + 0.98697471511778 + 0.98529676328114 + 0.98343317479271 + 0.98135531544746 + 0.97903142661802 + 0.97642637824234 + 0.97349954406359 + 0.97020487714310 + 0.96649146485997 + 0.96230161037381 + 0.95756311669737 + 0.95219758339417 + 0.94613787333638 + 0.93932542863645 + 0.93170466950038 + 0.92323074191428 + 0.91387074282244 + 0.90360695929080 + 0.89244140619351 + 0.88040131732845 + 0.86754424142809 + 0.85395586083584 + 0.83973573844339 + 0.82501278636686 + 0.80996905054444 + 0.79481115011104 + 0.78724604972665 + 0.77972077737304 + 0.77225096404290 + 0.76484717715512 + 0.75751431492223 + 0.75025129567174 + 0.74305116356664 + 0.73590174168361 + 0.72878677070186 + 0.72168409501661 + 0.71451156717924 + 0.70703211698125 + 0.69912135796960 + 0.69076509908495 + 0.68194934989536 + 0.67269075193836 + 0.66301373365339 + 0.65294869644687 + 0.64253049047187 + 0.63179732583013 + 0.62078814351266 + 0.60950826598474 + 0.59799535932661 + 0.58629030261929 + 0.57443755329084 + 0.56248499416957 + 0.55048292712002 + 0.53846361220580 + 0.52645178616716 + 0.51448142301851 + 0.50257612116685 + 0.49074566525533 + 0.99511847739824 + 0.99511931625078 + 0.99511945588822 + 0.99511961888547 + 0.99511980920039 + 0.99512003147164 + 0.99512029115733 + 0.99512059468887 + 0.99512094973417 + 0.99512136585444 + 0.99512185628288 + 0.99512243959772 + 0.99512313807438 + 0.99512397693816 + 0.99512498603838 + 0.99512620156605 + 0.99512766772060 + 0.99512943864751 + 0.99513158248402 + 0.99513418522517 + 0.99513735145933 + 0.99514121135005 + 0.99514592745228 + 0.99515170365659 + 0.99515879822390 + 0.99516754902511 + 0.99517841860579 + 0.99519201380070 + 0.99520909401646 + 0.99523062835004 + 0.99525792862367 + 0.99529270732113 + 0.99533723176989 + 0.99539455164167 + 0.99546882525658 + 0.99556582499805 + 0.99569376037957 + 0.99586471103019 + 0.99609755210646 + 0.99642415990603 + 0.99690522950478 + 0.99769068667278 + 1.00000000000000 + 0.99740041838830 + 0.99608639376923 + 0.99492773941684 + 0.99379210748451 + 0.99262426144884 + 0.99139890701912 + 0.99009342269920 + 0.98868200526651 + 0.98713931527503 + 0.98544025531038 + 0.98355893323024 + 0.98146607893055 + 0.97912945771921 + 0.97651356434210 + 0.97357745585360 + 0.97027481665566 + 0.96655450833910 + 0.96235863959708 + 0.95761483209775 + 0.95224454632292 + 0.94618056534630 + 0.93936427569001 + 0.93174004736794 + 0.92326298418057 + 0.91390014568081 + 0.90363378559456 + 0.89246588905313 + 0.88042366340144 + 0.86756463430650 + 0.85397446375363 + 0.83975269563020 + 0.82502822982987 + 0.80998310923896 + 0.79482395230131 + 0.78725827000102 + 0.77973244652641 + 0.77226211184708 + 0.76485783210642 + 0.75752450399842 + 0.75026104413533 + 0.74306049478167 + 0.73591067700825 + 0.72879532941620 + 0.72169229413345 + 0.71451941808907 + 0.70703961735754 + 0.69912849949353 + 0.69077187405068 + 0.68195575140450 + 0.67269677547448 + 0.66301937740953 + 0.65295396147230 + 0.64253538067648 + 0.63180184787840 + 0.62079230658490 + 0.60951208038493 + 0.59799883746702 + 0.58629345888324 + 0.57444040386972 + 0.56248755690260 + 0.55048522128835 + 0.53846565786436 + 0.52645360383804 + 0.51448303365107 + 0.50257754562622 + 0.49074692376344 + 0.99453355640203 + 0.99453428319812 + 0.99453440418030 + 0.99453454540152 + 0.99453471028808 + 0.99453490286179 + 0.99453512784882 + 0.99453539082026 + 0.99453569841893 + 0.99453605891601 + 0.99453648374040 + 0.99453698890842 + 0.99453759361813 + 0.99453831962539 + 0.99453919266604 + 0.99454024394845 + 0.99454151156536 + 0.99454304217916 + 0.99454489448239 + 0.99454714251959 + 0.99454987631637 + 0.99455320787538 + 0.99455727699262 + 0.99456225890111 + 0.99456837538918 + 0.99457591629476 + 0.99458527792893 + 0.99459697945613 + 0.99461166917398 + 0.99463017197733 + 0.99465360081268 + 0.99468340118131 + 0.99472147409060 + 0.99477035373195 + 0.99483345377243 + 0.99491543413350 + 0.99502276810952 + 0.99516466381451 + 0.99535482046460 + 0.99561465959712 + 0.99597987868104 + 0.99651873178705 + 0.99740041838830 + 1.00000000000000 + 0.99708032925868 + 0.99561544480733 + 0.99432055312755 + 0.99305008170786 + 0.99175170259834 + 0.99039110835584 + 0.98893636933957 + 0.98735867335019 + 0.98563079702357 + 0.98372546093339 + 0.98161242113591 + 0.97925873602885 + 0.97662835739580 + 0.97367989392379 + 0.97036665568879 + 0.96663719331544 + 0.96243335033331 + 0.95768250356940 + 0.95230592696069 + 0.94623629707964 + 0.93941492651577 + 0.93178611867387 + 0.92330492141474 + 0.91393834467377 + 0.90366859784638 + 0.89249762640077 + 0.88045260228078 + 0.86759102012668 + 0.85399851437981 + 0.83977460313540 + 0.82504816941784 + 0.81000125133465 + 0.79484046571864 + 0.78727402990539 + 0.77974749322325 + 0.77227648424524 + 0.76487156738457 + 0.75753763731090 + 0.75027360834122 + 0.74307252024026 + 0.73592219141922 + 0.72880635776545 + 0.72170285843540 + 0.71452953306005 + 0.70704927993826 + 0.69913769888870 + 0.69078060027885 + 0.68196399557207 + 0.67270453180930 + 0.66302664367443 + 0.65296073915951 + 0.64254167499379 + 0.63180766760017 + 0.62079766372597 + 0.60951698840216 + 0.59800331253178 + 0.58629751967930 + 0.57444407140136 + 0.56249085427018 + 0.55048817340792 + 0.53846829062193 + 0.52645594366706 + 0.51448510749491 + 0.50257938029073 + 0.49074854519090 + 0.99386989151070 + 0.99387052140183 + 0.99387062625017 + 0.99387074863621 + 0.99387089152972 + 0.99387105841562 + 0.99387125338717 + 0.99387148126949 + 0.99387174781751 + 0.99387206019216 + 0.99387242826843 + 0.99387286587825 + 0.99387338959006 + 0.99387401818575 + 0.99387477388136 + 0.99387568360571 + 0.99387678023214 + 0.99387810400417 + 0.99387970553030 + 0.99388164863497 + 0.99388401088741 + 0.99388688876991 + 0.99389040263812 + 0.99389470328890 + 0.99389998144767 + 0.99390648617654 + 0.99391455772580 + 0.99392464136318 + 0.99393729220881 + 0.99395321509532 + 0.99397335879459 + 0.99399895107746 + 0.99403159882492 + 0.99407343054715 + 0.99412728891160 + 0.99419700917301 + 0.99428783347909 + 0.99440705062642 + 0.99456516406993 + 0.99477783067468 + 0.99506917794305 + 0.99547962982142 + 0.99608639376923 + 0.99708032925868 + 1.00000000000000 + 0.99673630984471 + 0.99509883481521 + 0.99364964714188 + 0.99223636888574 + 0.99079388909229 + 0.98927703465830 + 0.98765031982694 + 0.98588274664330 + 0.98394471253482 + 0.98180442140921 + 0.97942784727968 + 0.97677813520346 + 0.97381324607794 + 0.97048596031277 + 0.96674439532916 + 0.96253003045540 + 0.95776991116787 + 0.95238506099474 + 0.94630801355599 + 0.93947998235878 + 0.93184518188983 + 0.92335858545485 + 0.91398713689601 + 0.90371298653307 + 0.89253802690763 + 0.88048938259206 + 0.86762450655097 + 0.85402899605926 + 0.83980233432409 + 0.82507338108931 + 0.81002416688091 + 0.79486130512807 + 0.78729391021490 + 0.77976646656792 + 0.77229460085023 + 0.76488887515850 + 0.75755418147078 + 0.75028943109013 + 0.74308766050878 + 0.73593668469386 + 0.72882023601163 + 0.72171614979909 + 0.71454225638404 + 0.70706143152383 + 0.69914926524558 + 0.69079156898304 + 0.68197435561233 + 0.67271427615667 + 0.66303576980954 + 0.65296924929337 + 0.64254957603701 + 0.63181497095749 + 0.62080438487344 + 0.60952314460535 + 0.59800892444203 + 0.58630261108399 + 0.57444866896304 + 0.56249498724132 + 0.55049187328176 + 0.53847159004576 + 0.52645887592644 + 0.51448770646516 + 0.50258167961837 + 0.49075057740711 + 0.99312488040937 + 0.99312542661329 + 0.99312551752584 + 0.99312562364332 + 0.99312574754001 + 0.99312589223524 + 0.99312606127532 + 0.99312625884508 + 0.99312648992748 + 0.99312676072238 + 0.99312707978419 + 0.99312745907912 + 0.99312791294261 + 0.99312845762142 + 0.99312911232650 + 0.99312990034299 + 0.99313085008703 + 0.99313199633245 + 0.99313338280503 + 0.99313506462767 + 0.99313710878064 + 0.99313959853009 + 0.99314263772247 + 0.99314635639395 + 0.99315091893079 + 0.99315653988654 + 0.99316351224833 + 0.99317221914576 + 0.99318313763521 + 0.99319687243649 + 0.99321423632745 + 0.99323627827755 + 0.99326436638420 + 0.99330030464991 + 0.99334648769651 + 0.99340611975984 + 0.99348353147818 + 0.99358465119238 + 0.99371784333435 + 0.99389519990703 + 0.99413447620331 + 0.99446325342356 + 0.99492773941684 + 0.99561544480733 + 0.99673630984471 + 1.00000000000000 + 0.99635318922729 + 0.99452262430407 + 0.99291088406201 + 0.99134047027550 + 0.98973194068914 + 0.98803542450284 + 0.98621266550154 + 0.98422993424428 + 0.98205284610492 + 0.97964565120931 + 0.97697026170101 + 0.97398368242069 + 0.97063793252963 + 0.96688051942407 + 0.96265241942643 + 0.95788023029137 + 0.95248464048811 + 0.94639799117832 + 0.93956136208304 + 0.93191884854990 + 0.92342532417790 + 0.91404764463806 + 0.90376788157218 + 0.89258785704571 + 0.88053463252136 + 0.86766560526823 + 0.85406632274987 + 0.83983622143070 + 0.82510412906123 + 0.81005206395247 + 0.79488663275640 + 0.78731805360209 + 0.77978949170854 + 0.77231657114669 + 0.76490985094247 + 0.75757421956113 + 0.75030858442834 + 0.74310597785498 + 0.73595421043970 + 0.72883701010164 + 0.72173220739444 + 0.71455762117724 + 0.70707609963495 + 0.69916322085653 + 0.69080479760255 + 0.68198684449494 + 0.67272601742518 + 0.66304676107069 + 0.65297949389777 + 0.64255908301777 + 0.63182375475940 + 0.62081246481988 + 0.60953054213169 + 0.59801566501230 + 0.58630872388622 + 0.57445418659084 + 0.56249994533545 + 0.55049631011180 + 0.53847554520561 + 0.52646238971130 + 0.51449081981779 + 0.50258443315116 + 0.49075301034280 + 0.99228974270724 + 0.99229021644733 + 0.99229029529246 + 0.99229038732278 + 0.99229049476720 + 0.99229062024430 + 0.99229076682767 + 0.99229093814282 + 0.99229113850707 + 0.99229137329431 + 0.99229164991567 + 0.99229197875087 + 0.99229237222688 + 0.99229284442357 + 0.99229341198233 + 0.99229409507097 + 0.99229491829044 + 0.99229591174462 + 0.99229711327688 + 0.99229857059365 + 0.99230034163224 + 0.99230249839724 + 0.99230513065235 + 0.99230835075105 + 0.99231230067035 + 0.99231716564752 + 0.99232319863866 + 0.99233073027924 + 0.99234017179342 + 0.99235204378786 + 0.99236704531783 + 0.99238607676739 + 0.99241030944277 + 0.99244128276929 + 0.99248103120026 + 0.99253226098195 + 0.99259860059823 + 0.99268496328180 + 0.99279818225845 + 0.99294793703231 + 0.99314800222369 + 0.99341880488537 + 0.99379210748451 + 0.99432055312755 + 0.99509883481521 + 0.99635318922729 + 1.00000000000000 + 0.99592521362881 + 0.99389051452675 + 0.99209917838687 + 0.99034736695819 + 0.98854779604736 + 0.98664644532028 + 0.98460159035841 + 0.98237423522063 + 0.97992574324158 + 0.97721606236070 + 0.97420073923065 + 0.97083067028788 + 0.96705248624073 + 0.96280645783206 + 0.95801857147228 + 0.95260906352078 + 0.94651001324091 + 0.93966231773112 + 0.93200991127964 + 0.92350753316138 + 0.91412192073359 + 0.90383504039700 + 0.89264862013005 + 0.88058963715231 + 0.86771541427812 + 0.85411143225939 + 0.83987706506447 + 0.82514109655342 + 0.81008552587289 + 0.79491694754527 + 0.78734692199147 + 0.77981699672664 + 0.77234279231793 + 0.76493486372743 + 0.75759809486669 + 0.75033138818335 + 0.74312777069046 + 0.73597504747559 + 0.72885694089698 + 0.72175127555270 + 0.71457585634474 + 0.70709349820444 + 0.69917976488342 + 0.69082047075743 + 0.68200163255812 + 0.67273991202070 + 0.66305976037637 + 0.65299160292405 + 0.64257031351587 + 0.63183412486735 + 0.62082199840534 + 0.60953926548364 + 0.59802360911842 + 0.58631592404959 + 0.57446068204705 + 0.56250577883579 + 0.55050152741376 + 0.53848019354604 + 0.52646651706985 + 0.51449447485935 + 0.50258766408618 + 0.49075586367065 + 0.99135437676330 + 0.99135478767558 + 0.99135485605613 + 0.99135493587089 + 0.99135502905133 + 0.99135513786445 + 0.99135526497682 + 0.99135541352628 + 0.99135558725456 + 0.99135579081810 + 0.99135603064876 + 0.99135631576412 + 0.99135665696319 + 0.99135706646048 + 0.99135755870073 + 0.99135815117778 + 0.99135886522332 + 0.99135972694468 + 0.99136076915080 + 0.99136203320819 + 0.99136356932421 + 0.99136543987890 + 0.99136772261257 + 0.99137051479072 + 0.99137393926796 + 0.99137815632749 + 0.99138338491974 + 0.99138991117020 + 0.99139809057142 + 0.99140837267639 + 0.99142136083259 + 0.99143783093763 + 0.99145879040151 + 0.99148556003419 + 0.99151987972830 + 0.99156405394672 + 0.99162115462991 + 0.99169530898791 + 0.99179219983331 + 0.99191976583391 + 0.99208906738335 + 0.99231602019000 + 0.99262426144884 + 0.99305008170786 + 0.99364964714188 + 0.99452262430407 + 0.99592521362881 + 1.00000000000000 + 0.99546216036799 + 0.99319945451120 + 0.99119995050697 + 0.98923915104768 + 0.98722168325737 + 0.98508832348229 + 0.98279111105192 + 0.98028624390410 + 0.97753037434347 + 0.97447673219793 + 0.97107450374530 + 0.96726902718908 + 0.96299956356421 + 0.95819125223441 + 0.95276371219811 + 0.94664866160005 + 0.93978674504075 + 0.93212167689541 + 0.92360801394001 + 0.91421233376427 + 0.90391646129189 + 0.89272199847588 + 0.88065580986698 + 0.86777511865283 + 0.85416531630175 + 0.83992569334212 + 0.82518497361754 + 0.81012512694977 + 0.79495272759665 + 0.78738095183289 + 0.77984938034589 + 0.77237362896400 + 0.76496424729918 + 0.75762611336535 + 0.75035812325708 + 0.74315329728236 + 0.73599943363357 + 0.72888024773561 + 0.72177355682739 + 0.71459714899502 + 0.70711379959335 + 0.69919905536576 + 0.69083873262611 + 0.68201885060873 + 0.67275607793145 + 0.66307487351761 + 0.65300567065817 + 0.64258335104596 + 0.63184615478884 + 0.62083304990763 + 0.60954937045587 + 0.59803280480389 + 0.58632425258926 + 0.57446819002235 + 0.56251251677437 + 0.55050754921272 + 0.53848555469512 + 0.52647127381579 + 0.51449868415276 + 0.50259138225504 + 0.49075914497680 + 0.99031410558035 + 0.99031446213877 + 0.99031452146801 + 0.99031459071367 + 0.99031467155194 + 0.99031476595060 + 0.99031487621636 + 0.99031500506916 + 0.99031515575301 + 0.99031533230436 + 0.99031554031426 + 0.99031578764036 + 0.99031608368779 + 0.99031643908381 + 0.99031686639091 + 0.99031738082010 + 0.99031800091473 + 0.99031874937295 + 0.99031965471519 + 0.99032075290805 + 0.99032208758344 + 0.99032371293499 + 0.99032569647733 + 0.99032812265403 + 0.99033109808826 + 0.99033476190050 + 0.99033930429066 + 0.99034497381307 + 0.99035207894748 + 0.99036100941191 + 0.99037228817875 + 0.99038658694552 + 0.99040477652245 + 0.99042799653169 + 0.99045774458359 + 0.99049599790781 + 0.99054538103090 + 0.99060940001453 + 0.99069284845621 + 0.99080235840229 + 0.99094703435095 + 0.99113971480568 + 0.99139890701912 + 0.99175170259834 + 0.99223636888574 + 0.99291088406201 + 0.99389051452675 + 0.99546216036799 + 1.00000000000000 + 0.99494950433451 + 0.99242454481227 + 0.99018671595775 + 0.98798870854682 + 0.98572543910004 + 0.98332941123152 + 0.98074681572010 + 0.97792844233400 + 0.97482367357875 + 0.97137900183769 + 0.96753781081536 + 0.96323788998926 + 0.95840319252349 + 0.95295248822443 + 0.94681699220456 + 0.93993699630239 + 0.93225591259080 + 0.92372804869844 + 0.91431976590489 + 0.90401269893815 + 0.89280828117188 + 0.88073322698527 + 0.86784462692313 + 0.85422775377751 + 0.83998178771753 + 0.82523537122097 + 0.81017042998715 + 0.79499350568642 + 0.78741966651330 + 0.77988615974071 + 0.77240859484903 + 0.76499751446352 + 0.75765778905015 + 0.75038830669434 + 0.74318207936724 + 0.73602689675418 + 0.72890646578982 + 0.72179859479620 + 0.71462105217686 + 0.70713656772393 + 0.69922066869489 + 0.69085917358570 + 0.68203810444542 + 0.67277413764941 + 0.66309174075278 + 0.65302135596387 + 0.64259787368744 + 0.63185954219515 + 0.62084533673808 + 0.60956059420216 + 0.59804300875982 + 0.58633348532096 + 0.57447650485493 + 0.56251997124973 + 0.55051420444996 + 0.53849147343716 + 0.52647651952492 + 0.51450332096069 + 0.50259547349966 + 0.49076275159371 + 0.98915897262174 + 0.98915928220700 + 0.98915933371340 + 0.98915939382658 + 0.98915946399964 + 0.98915954593940 + 0.98915964164622 + 0.98915975347838 + 0.98915988424771 + 0.98916003745740 + 0.98916021797940 + 0.98916043267721 + 0.98916068976385 + 0.98916099851412 + 0.98916136988117 + 0.98916181712444 + 0.98916235641458 + 0.98916300752695 + 0.98916379533956 + 0.98916475121892 + 0.98916591320135 + 0.98916732851721 + 0.98916905598861 + 0.98917116915894 + 0.98917376087016 + 0.98917695230087 + 0.98918090932911 + 0.98918584876478 + 0.98919203940042 + 0.98919982047936 + 0.98920964734812 + 0.98922210421254 + 0.98923794754833 + 0.98925816596022 + 0.98928405621545 + 0.98931732624230 + 0.98936023586751 + 0.98941579120452 + 0.98948808172635 + 0.98958272691205 + 0.98970735994652 + 0.98987259410788 + 0.99009342269920 + 0.99039110835584 + 0.99079388909229 + 0.99134047027550 + 0.99209917838687 + 0.99319945451120 + 0.99494950433451 + 1.00000000000000 + 0.99436517792839 + 0.99154197219238 + 0.98903478492637 + 0.98657012818865 + 0.98402950341456 + 0.98133734982287 + 0.97843315443988 + 0.97525951840977 + 0.97175849333713 + 0.96787040158767 + 0.96353082815183 + 0.95866202999581 + 0.95318158903768 + 0.94702000847789 + 0.94011708073897 + 0.93241579818077 + 0.92387012577005 + 0.91444613045826 + 0.90412519044318 + 0.89290851328694 + 0.88082261319158 + 0.86792440434716 + 0.85429900226319 + 0.84004544180614 + 0.82529225588229 + 0.81022130545861 + 0.79503908209706 + 0.78746283942239 + 0.77992708616215 + 0.77244742333816 + 0.76503438447481 + 0.75769283041058 + 0.75042163917460 + 0.74321381239705 + 0.73605712931406 + 0.72893528652381 + 0.72182608160097 + 0.71464726022008 + 0.70716150069786 + 0.69924430834497 + 0.69088150403123 + 0.68205911284152 + 0.67279381964773 + 0.66311010140272 + 0.65303840997487 + 0.64261364515288 + 0.63187406394242 + 0.62085864926060 + 0.60957274081841 + 0.59805403885160 + 0.58634345374794 + 0.57448547138821 + 0.56252799999322 + 0.55052136317135 + 0.53849783147734 + 0.52648214684876 + 0.51450828812899 + 0.50259985008422 + 0.49076660443377 + 0.98787184917519 + 0.98787211817948 + 0.98787216292831 + 0.98787221515214 + 0.98787227611322 + 0.98787234729032 + 0.98787243042220 + 0.98787252755422 + 0.98787264112299 + 0.98787277417422 + 0.98787293095992 + 0.98787311748848 + 0.98787334095660 + 0.98787360947733 + 0.98787393262255 + 0.98787432198093 + 0.98787479168742 + 0.98787535902578 + 0.98787604574473 + 0.98787687929229 + 0.98787789291808 + 0.98787912790623 + 0.98788063566023 + 0.98788248043010 + 0.98788474330354 + 0.98788753017885 + 0.98789098625176 + 0.98789530136362 + 0.98790071060678 + 0.98790751040883 + 0.98791609883325 + 0.98792698610612 + 0.98794083224682 + 0.98795849883875 + 0.98798111440357 + 0.98801016247137 + 0.98804760114044 + 0.98809602673990 + 0.98815895853554 + 0.98824120897176 + 0.98834926407528 + 0.98849205159770 + 0.98868200526651 + 0.98893636933957 + 0.98927703465830 + 0.98973194068914 + 0.99034736695819 + 0.99119995050697 + 0.99242454481227 + 0.99436517792839 + 1.00000000000000 + 0.99369601487776 + 0.99053523232850 + 0.98772509162286 + 0.98495980371553 + 0.98210699385062 + 0.97908162201102 + 0.97581328768798 + 0.97223624433533 + 0.96828577711267 + 0.96389403368765 + 0.95898076253459 + 0.95346183585465 + 0.94726672524608 + 0.94033450283017 + 0.93260756922569 + 0.92403941233836 + 0.91459569471377 + 0.90425744585988 + 0.89302556895419 + 0.88092631002840 + 0.86801634791752 + 0.85438058914001 + 0.84011787683220 + 0.82535659670992 + 0.81027851689578 + 0.79509005483105 + 0.78751099886341 + 0.77997262602000 + 0.77249052604415 + 0.76507522059912 + 0.75773155815187 + 0.75045840401576 + 0.74324874689069 + 0.73609035308075 + 0.72896690648090 + 0.72185619161425 + 0.71467592779513 + 0.70718873509901 + 0.69927009408584 + 0.69090582815488 + 0.68208196561424 + 0.67281520058045 + 0.66313002017470 + 0.65305688665231 + 0.64263070981688 + 0.63188975593452 + 0.62087301596016 + 0.60958583232339 + 0.59806591151558 + 0.58635416952658 + 0.57449509722319 + 0.56253660720606 + 0.55052902676617 + 0.53850462791890 + 0.52648815308204 + 0.51451358157161 + 0.50260450693212 + 0.49077069777267 + 0.98643320574094 + 0.98643343973362 + 0.98643347865122 + 0.98643352407018 + 0.98643357708350 + 0.98643363897756 + 0.98643371126072 + 0.98643379570998 + 0.98643389444256 + 0.98643401010767 + 0.98643414642110 + 0.98643430866120 + 0.98643450314734 + 0.98643473699300 + 0.98643501858594 + 0.98643535807965 + 0.98643576786071 + 0.98643626307255 + 0.98643686279053 + 0.98643759108982 + 0.98643847712998 + 0.98643955709909 + 0.98644087605017 + 0.98644249028241 + 0.98644447082900 + 0.98644691052903 + 0.98644993691275 + 0.98645371680502 + 0.98645845654836 + 0.98646441607374 + 0.98647194465973 + 0.98648148962492 + 0.98649362907337 + 0.98650911698371 + 0.98652893975530 + 0.98655439211952 + 0.98658717961602 + 0.98662955796591 + 0.98668457667659 + 0.98675639109530 + 0.98685056844745 + 0.98697471511778 + 0.98713931527503 + 0.98735867335019 + 0.98765031982694 + 0.98803542450284 + 0.98854779604736 + 0.98923915104768 + 0.99018671595775 + 0.99154197219238 + 0.99369601487776 + 1.00000000000000 + 0.99293018923157 + 0.98938846033415 + 0.98623656861179 + 0.98313334351781 + 0.97992979050871 + 0.97652743441120 + 0.97284562275284 + 0.96881080309119 + 0.96434948229725 + 0.95937753696532 + 0.95380828864616 + 0.94756967014011 + 0.94059969064131 + 0.93283990047493 + 0.92424311316304 + 0.91477442872230 + 0.90441439795777 + 0.89316351042919 + 0.88104765053686 + 0.86812318140677 + 0.85447473069183 + 0.84020088765992 + 0.82542984033564 + 0.81034322582212 + 0.79514735472205 + 0.78756497810571 + 0.78002352566098 + 0.77253857211012 + 0.76512062354482 + 0.75777451246894 + 0.75049908796606 + 0.74328732242078 + 0.73612696596118 + 0.72900168671265 + 0.72188925317558 + 0.71470735383733 + 0.70721854251362 + 0.69929827167646 + 0.69093236735721 + 0.68210686125145 + 0.67283845750448 + 0.66315165420730 + 0.65307692473831 + 0.64264918955520 + 0.63190672466668 + 0.62088852938923 + 0.60959994866079 + 0.59807869535130 + 0.58636569109778 + 0.57450543176475 + 0.56254583429789 + 0.55053722963098 + 0.53851189105757 + 0.52649456126464 + 0.51451921987124 + 0.50260945890171 + 0.49077504340882 + 0.98482197525992 + 0.98482217909954 + 0.98482221299750 + 0.98482225255484 + 0.98482229872489 + 0.98482235262632 + 0.98482241556991 + 0.98482248910132 + 0.98482257506154 + 0.98482267576053 + 0.98482279445224 + 0.98482293578667 + 0.98482310532673 + 0.98482330932687 + 0.98482355515247 + 0.98482385173108 + 0.98482420994063 + 0.98482464309529 + 0.98482516796018 + 0.98482580573112 + 0.98482658204581 + 0.98482752872808 + 0.98482868538592 + 0.98483010149732 + 0.98483183948950 + 0.98483398101232 + 0.98483663846706 + 0.98483995897233 + 0.98484412427516 + 0.98484936309399 + 0.98485598302966 + 0.98486437766861 + 0.98487505528031 + 0.98488867822780 + 0.98490611216873 + 0.98492849189577 + 0.98495730984015 + 0.98499453576798 + 0.98504282738773 + 0.98510579672570 + 0.98518826058596 + 0.98529676328114 + 0.98544025531038 + 0.98563079702357 + 0.98588274664330 + 0.98621266550154 + 0.98664644532028 + 0.98722168325737 + 0.98798870854682 + 0.98903478492637 + 0.99053523232850 + 0.99293018923157 + 1.00000000000000 + 0.99205501366038 + 0.98808239789176 + 0.98454676517868 + 0.98106466888086 + 0.97746480843880 + 0.97363443773352 + 0.96948311965241 + 0.96492747838569 + 0.95987708693774 + 0.95424129123992 + 0.94794564728458 + 0.94092655185553 + 0.93312430528252 + 0.92449074999720 + 0.91499019187378 + 0.90460251667835 + 0.89332764653847 + 0.88119097447718 + 0.86824843755434 + 0.85458428956437 + 0.84029678221768 + 0.82551383788805 + 0.81041691071134 + 0.79521215994384 + 0.78762582877519 + 0.78008072425456 + 0.77259240106258 + 0.76517134481058 + 0.75782236724388 + 0.75054429658061 + 0.74333008443534 + 0.73616746050657 + 0.72904007314055 + 0.72192567096424 + 0.71474190608721 + 0.70725125644682 + 0.69932914241470 + 0.69096139268487 + 0.68213404243107 + 0.67286380665432 + 0.66317519523355 + 0.65309869342273 + 0.64266923292626 + 0.63192509994243 + 0.62090530239040 + 0.60961518736499 + 0.59809247414009 + 0.58637808995675 + 0.57451653557888 + 0.56255573218673 + 0.55054601421902 + 0.53851965598304 + 0.52650140014708 + 0.51452522638915 + 0.50261472484483 + 0.49077965648841 + 0.98301518362534 + 0.98301536154861 + 0.98301539113307 + 0.98301542565322 + 0.98301546594246 + 0.98301551297517 + 0.98301556789434 + 0.98301563204598 + 0.98301570703326 + 0.98301579487443 + 0.98301589842958 + 0.98301602180297 + 0.98301616990784 + 0.98301634825793 + 0.98301656334911 + 0.98301682304265 + 0.98301713692538 + 0.98301751673347 + 0.98301797726036 + 0.98301853721881 + 0.98301921922577 + 0.98302005135960 + 0.98302106855510 + 0.98302231444511 + 0.98302384407503 + 0.98302572949976 + 0.98302807014910 + 0.98303099624464 + 0.98303466845101 + 0.98303928876227 + 0.98304512907883 + 0.98305253702887 + 0.98306196117487 + 0.98307398565375 + 0.98308937319618 + 0.98310912253746 + 0.98313454532598 + 0.98316736970122 + 0.98320992385894 + 0.98326536578124 + 0.98333789095092 + 0.98343317479271 + 0.98355893323024 + 0.98372546093339 + 0.98394471253482 + 0.98422993424428 + 0.98460159035841 + 0.98508832348229 + 0.98572543910004 + 0.98657012818865 + 0.98772509162286 + 0.98938846033415 + 0.99205501366038 + 1.00000000000000 + 0.99105361018603 + 0.98659692045909 + 0.98263223712559 + 0.97872295257085 + 0.97467332359106 + 0.97035655980793 + 0.96567040667456 + 0.96051345524886 + 0.95478850991688 + 0.94841729709516 + 0.94133368474536 + 0.93347608429626 + 0.92479490847741 + 0.91525332175691 + 0.90483027271080 + 0.89352489614735 + 0.88136191141496 + 0.86839667654752 + 0.85471294132890 + 0.84040850657694 + 0.82561093706569 + 0.81050143323405 + 0.79528594238269 + 0.78769485917819 + 0.78014538518082 + 0.77265304830208 + 0.76522830710717 + 0.75787594620725 + 0.75059476680996 + 0.74337769386501 + 0.73621243104382 + 0.72908260164575 + 0.72196592940800 + 0.71478002309652 + 0.70728727317252 + 0.69936306301281 + 0.69099322388136 + 0.68216379442529 + 0.67289150133209 + 0.66320086709868 + 0.65312238956481 + 0.64269101224158 + 0.63194503185990 + 0.62092346506635 + 0.60963166057424 + 0.59810734395408 + 0.58639144787605 + 0.57452847777606 + 0.56256635883182 + 0.55055542874923 + 0.53852796246329 + 0.52650870224139 + 0.51453162748950 + 0.50262032599865 + 0.49078455403305 + 0.98098581457927 + 0.98098597026357 + 0.98098599614593 + 0.98098602634458 + 0.98098606158926 + 0.98098610272912 + 0.98098615076348 + 0.98098620686801 + 0.98098627244565 + 0.98098634925913 + 0.98098643982996 + 0.98098654779452 + 0.98098667750646 + 0.98098683384369 + 0.98098702254670 + 0.98098725056425 + 0.98098752637880 + 0.98098786036478 + 0.98098826562088 + 0.98098875872432 + 0.98098935970276 + 0.98099009341551 + 0.98099099078392 + 0.98099209042654 + 0.98099344105160 + 0.98099510648834 + 0.98099717502414 + 0.98099976236654 + 0.98100301109001 + 0.98100710027509 + 0.98101227120395 + 0.98101883210836 + 0.98102718042043 + 0.98103783333910 + 0.98105146562209 + 0.98106895990965 + 0.98109147392219 + 0.98112053064675 + 0.98115817948178 + 0.98120719604775 + 0.98127125624090 + 0.98135531544746 + 0.98146607893055 + 0.98161242113591 + 0.98180442140921 + 0.98205284610492 + 0.98237423522063 + 0.98279111105192 + 0.98332941123152 + 0.98402950341456 + 0.98495980371553 + 0.98623656861179 + 0.98808239789176 + 0.99105361018603 + 1.00000000000000 + 0.98991174750228 + 0.98491406354542 + 0.98046685837943 + 0.97607303916610 + 0.97151168114026 + 0.96663980117754 + 0.96133505950198 + 0.95548872616709 + 0.94901602352736 + 0.94184668622519 + 0.93391617284234 + 0.92517273218795 + 0.91557785109283 + 0.90510913338119 + 0.89376460564529 + 0.88156805302744 + 0.86857403949377 + 0.85486563041810 + 0.84054002060608 + 0.82572429188073 + 0.81059929412187 + 0.79537067990090 + 0.78777382810583 + 0.78021907334568 + 0.77272190770915 + 0.76529275390082 + 0.75793636086267 + 0.75065149458637 + 0.74343104551222 + 0.73626268384657 + 0.72913000087817 + 0.72201068884734 + 0.71482230432703 + 0.70732713603371 + 0.69940052428151 + 0.69102830262647 + 0.68219651302424 + 0.67292189469904 + 0.66322898358656 + 0.65314829080400 + 0.64271477213182 + 0.63196673507613 + 0.62094320498401 + 0.60964953140078 + 0.59812344592913 + 0.58640588631182 + 0.57454136228330 + 0.56257780263080 + 0.55056554794719 + 0.53853687328250 + 0.52651651998444 + 0.51453846675075 + 0.50262629845456 + 0.49078976589658 + 0.97870339796769 + 0.97870353459335 + 0.97870355730321 + 0.97870358380079 + 0.97870361472145 + 0.97870365081342 + 0.97870369295121 + 0.97870374216355 + 0.97870379967922 + 0.97870386704963 + 0.97870394649921 + 0.97870404126576 + 0.97870415521591 + 0.97870429268067 + 0.97870445875354 + 0.97870465960096 + 0.97870490274866 + 0.97870519740785 + 0.97870555521419 + 0.97870599091374 + 0.97870652230615 + 0.97870717148466 + 0.97870796592854 + 0.97870893994693 + 0.97871013681809 + 0.97871161329955 + 0.97871344810730 + 0.97871574447181 + 0.97871862943477 + 0.97872226241400 + 0.97872685840098 + 0.97873269183432 + 0.97874011630651 + 0.97874959166913 + 0.97876171738892 + 0.97877727685191 + 0.97879729640778 + 0.97882312435860 + 0.97885657329856 + 0.97890009518115 + 0.97895692849698 + 0.97903142661802 + 0.97912945771921 + 0.97925873602885 + 0.97942784727968 + 0.97964565120931 + 0.97992574324158 + 0.98028624390410 + 0.98074681572010 + 0.98133734982287 + 0.98210699385062 + 0.98313334351781 + 0.98454676517868 + 0.98659692045909 + 0.98991174750228 + 1.00000000000000 + 0.98861633162748 + 0.98301211454101 + 0.97801876064268 + 0.97307312486313 + 0.96792638532261 + 0.96241102898666 + 0.95639607184465 + 0.94978493541264 + 0.94250024729969 + 0.93447265654757 + 0.92564702619465 + 0.91598230999659 + 0.90545414005490 + 0.89405895609086 + 0.88181923019710 + 0.86878842586125 + 0.85504867130550 + 0.84069634131140 + 0.82585786280508 + 0.81071360196410 + 0.79546880328324 + 0.78786488380737 + 0.78030368786756 + 0.77280065952603 + 0.76536617377175 + 0.75800493243982 + 0.75071565532322 + 0.74349118789274 + 0.73631915700938 + 0.72918311270294 + 0.72206070700476 + 0.71486943300509 + 0.70737146011648 + 0.69944207802636 + 0.69106712201628 + 0.68223263694492 + 0.67295537537509 + 0.66325988744177 + 0.65317669811329 + 0.64274077577608 + 0.63199043875061 + 0.62096472082655 + 0.60966897125726 + 0.59814092716670 + 0.58642153079479 + 0.57455529556682 + 0.56259015329093 + 0.55057644689231 + 0.53854645083207 + 0.52652490486017 + 0.51454578640100 + 0.50263267669131 + 0.49079532016287 + 0.97613386951301 + 0.97613398983256 + 0.97613400982868 + 0.97613403315766 + 0.97613406038158 + 0.97613409215457 + 0.97613412924713 + 0.97613417256545 + 0.97613422318612 + 0.97613428247978 + 0.97613435242106 + 0.97613443589417 + 0.97613453635468 + 0.97613465766128 + 0.97613480434570 + 0.97613498190778 + 0.97613519704929 + 0.97613545798063 + 0.97613577508339 + 0.97613616152165 + 0.97613663318545 + 0.97613720978616 + 0.97613791585115 + 0.97613878198844 + 0.97613984680855 + 0.97614116100488 + 0.97614279505071 + 0.97614484145180 + 0.97614741389638 + 0.97615065490920 + 0.97615475690651 + 0.97615996529399 + 0.97616659605470 + 0.97617505984985 + 0.97618589161975 + 0.97619978978261 + 0.97621766837501 + 0.97624072660456 + 0.97627057534275 + 0.97630939153126 + 0.97636004358365 + 0.97642637824234 + 0.97651356434210 + 0.97662835739580 + 0.97677813520346 + 0.97697026170101 + 0.97721606236070 + 0.97753037434347 + 0.97792844233400 + 0.97843315443988 + 0.97908162201102 + 0.97992979050871 + 0.98106466888086 + 0.98263223712559 + 0.98491406354542 + 0.98861633162748 + 1.00000000000000 + 0.98714973287848 + 0.98086290663039 + 0.97524802678512 + 0.96966967876875 + 0.96384261954483 + 0.95758726452178 + 0.95078370487384 + 0.94334154889376 + 0.93518321105034 + 0.92624804147987 + 0.91649104439918 + 0.90588488560314 + 0.89442368592312 + 0.88212804249822 + 0.86904987495336 + 0.85527001615057 + 0.84088372306314 + 0.82601653039414 + 0.81084813689766 + 0.79558322343040 + 0.78797057712632 + 0.78040146355056 + 0.77289126227483 + 0.76545028463229 + 0.75808317000989 + 0.75078857732343 + 0.74355929312282 + 0.73638288776542 + 0.72924285776699 + 0.72211680344996 + 0.71492214003636 + 0.70742089606799 + 0.69948830121145 + 0.69111019144314 + 0.68227261373907 + 0.67299233463844 + 0.66329391906249 + 0.65320790620596 + 0.64276927710657 + 0.63201636062647 + 0.62098819838099 + 0.60969013776346 + 0.59815992055621 + 0.58643849258971 + 0.57457037006776 + 0.56260348695682 + 0.55058818770995 + 0.53855674526815 + 0.52653389691342 + 0.51455361804839 + 0.50263948540086 + 0.49080123595170 + 0.97323753656390 + 0.97323764294167 + 0.97323766061676 + 0.97323768123940 + 0.97323770530309 + 0.97323773338555 + 0.97323776616788 + 0.97323780444738 + 0.97323784917837 + 0.97323790157141 + 0.97323796338384 + 0.97323803720295 + 0.97323812612528 + 0.97323823360117 + 0.97323836368831 + 0.97323852129989 + 0.97323871243624 + 0.97323894444391 + 0.97323922662311 + 0.97323957078218 + 0.97323999116152 + 0.97324050542905 + 0.97324113556365 + 0.97324190899566 + 0.97324286032025 + 0.97324403500980 + 0.97324549643743 + 0.97324732785997 + 0.97324963146394 + 0.97325253523699 + 0.97325621214543 + 0.97326088262015 + 0.97326683027521 + 0.97327442348556 + 0.97328414174410 + 0.97329661052261 + 0.97331264753575 + 0.97333332430675 + 0.97336007919436 + 0.97339485439018 + 0.97344020349756 + 0.97349954406359 + 0.97357745585360 + 0.97367989392379 + 0.97381324607794 + 0.97398368242069 + 0.97420073923065 + 0.97447673219793 + 0.97482367357875 + 0.97525951840977 + 0.97581328768798 + 0.97652743441120 + 0.97746480843880 + 0.97872295257085 + 0.98046685837943 + 0.98301211454101 + 0.98714973287848 + 1.00000000000000 + 0.98549180684488 + 0.97843190234322 + 0.97210299652561 + 0.96578690981652 + 0.95917583940704 + 0.95209788717857 + 0.94443674024780 + 0.93609979789497 + 0.92701698100871 + 0.91713688850099 + 0.90642758044491 + 0.89487970310842 + 0.88251112326930 + 0.86937156139270 + 0.85554003863275 + 0.84111027419007 + 0.82620657960592 + 0.81100773082180 + 0.79571763049991 + 0.78809412736575 + 0.78051520767602 + 0.77299616425964 + 0.76554722330090 + 0.75817294108919 + 0.75087189598250 + 0.74363679694432 + 0.73645514027552 + 0.72931035266275 + 0.72217996748436 + 0.71498130364454 + 0.70747622218143 + 0.69953988093542 + 0.69115811487055 + 0.68231697172764 + 0.67303323238789 + 0.66333147685553 + 0.65324225857134 + 0.64280057088606 + 0.63204475247412 + 0.62101385166682 + 0.60971321183503 + 0.59818057810347 + 0.58645689854333 + 0.57458669083699 + 0.56261788988572 + 0.55060084055781 + 0.53856781306174 + 0.52654354107862 + 0.51456199704847 + 0.50264675210419 + 0.49080753450039 + 0.96996916487397 + 0.96996925933651 + 0.96996927503007 + 0.96996929333787 + 0.96996931470099 + 0.96996933962959 + 0.96996936872790 + 0.96996940270374 + 0.96996944240306 + 0.96996948889850 + 0.96996954376691 + 0.96996960933431 + 0.96996968838522 + 0.96996978402248 + 0.96996989988911 + 0.96997004040077 + 0.96997021094762 + 0.96997041813303 + 0.96997067032476 + 0.96997097816106 + 0.96997135445582 + 0.96997181511610 + 0.96997237992345 + 0.96997307356239 + 0.96997392716828 + 0.96997498170442 + 0.96997629440996 + 0.96997794052810 + 0.96998001230891 + 0.96998262518301 + 0.96998593529956 + 0.96999014150859 + 0.96999549947002 + 0.97000234105272 + 0.97001109790395 + 0.97002233258954 + 0.97003677983699 + 0.97005540129234 + 0.97007948700143 + 0.97011077762801 + 0.97015155724311 + 0.97020487714310 + 0.97027481665566 + 0.97036665568879 + 0.97048596031277 + 0.97063793252963 + 0.97083067028788 + 0.97107450374530 + 0.97137900183769 + 0.97175849333713 + 0.97223624433533 + 0.97284562275284 + 0.97363443773352 + 0.97467332359106 + 0.97607303916610 + 0.97801876064268 + 0.98086290663039 + 0.98549180684488 + 1.00000000000000 + 0.98361762372475 + 0.97567125066270 + 0.96850675295795 + 0.96133818738907 + 0.95385431574660 + 0.94588083202849 + 0.93729539650639 + 0.92801076720430 + 0.91796463548485 + 0.90711762634339 + 0.89545501590733 + 0.88299059658469 + 0.86977089585618 + 0.85587236305632 + 0.84138657728499 + 0.82643615932888 + 0.81119860386812 + 0.79587673737964 + 0.78823962858365 + 0.78064847449649 + 0.77311845096830 + 0.76565966994234 + 0.75827657677805 + 0.75096764276798 + 0.74372547424083 + 0.73653746994311 + 0.72938696493783 + 0.72225140542542 + 0.71504799017558 + 0.70753837958063 + 0.69959764471864 + 0.69121161683205 + 0.68236634225707 + 0.67307861612496 + 0.66337303335919 + 0.65328016117028 + 0.64283500430636 + 0.63207590989715 + 0.62104193121698 + 0.60973840466990 + 0.59820307680673 + 0.58647689602262 + 0.57460437966301 + 0.56263346189282 + 0.55061448649502 + 0.53857971936053 + 0.52655388914321 + 0.51457096411215 + 0.50265450848057 + 0.49081424024816 + 0.96627853860768 + 0.96627862288064 + 0.96627863687871 + 0.96627865320897 + 0.96627867226118 + 0.96627869449314 + 0.96627872044222 + 0.96627875073601 + 0.96627878613212 + 0.96627882758587 + 0.96627887651593 + 0.96627893502054 + 0.96627900561764 + 0.96627909111041 + 0.96627919478154 + 0.96627932061358 + 0.96627947347528 + 0.96627965932373 + 0.96627988572203 + 0.96628016228850 + 0.96628050061038 + 0.96628091506319 + 0.96628142352891 + 0.96628204831316 + 0.96628281755390 + 0.96628376830536 + 0.96628495247164 + 0.96628643834038 + 0.96628830952569 + 0.96629067055393 + 0.96629366296752 + 0.96629746686547 + 0.96630231364361 + 0.96630850347465 + 0.96631642649167 + 0.96632659070997 + 0.96633965893598 + 0.96635649767352 + 0.96637826864237 + 0.96640653831422 + 0.96644335830970 + 0.96649146485997 + 0.96655450833910 + 0.96663719331544 + 0.96674439532916 + 0.96688051942407 + 0.96705248624073 + 0.96726902718908 + 0.96753781081536 + 0.96787040158767 + 0.96828577711267 + 0.96881080309119 + 0.96948311965241 + 0.97035655980793 + 0.97151168114026 + 0.97307312486313 + 0.97524802678512 + 0.97843190234322 + 0.98361762372475 + 1.00000000000000 + 0.98148843995870 + 0.97250373527213 + 0.96437041874481 + 0.95625089399886 + 0.94781537377943 + 0.93887539481537 + 0.92930981037796 + 0.91903654953113 + 0.90800363613798 + 0.89618771934933 + 0.88359632257669 + 0.87027122417526 + 0.85628515286761 + 0.84172666497156 + 0.82671601847231 + 0.81142891715453 + 0.79606669344200 + 0.78841240750424 + 0.78080587502991 + 0.77326211364890 + 0.76579108150631 + 0.75839707528309 + 0.75107842340737 + 0.74382759580235 + 0.73663186207845 + 0.72947443645373 + 0.72233265092382 + 0.71512355317391 + 0.70760856130450 + 0.69966264050420 + 0.69127161417144 + 0.68242152388058 + 0.67312917825272 + 0.66341918630649 + 0.65332212782801 + 0.64287301725994 + 0.63211020799350 + 0.62107275558301 + 0.60976598552234 + 0.59822764306528 + 0.58649867429772 + 0.57462359375219 + 0.56265033261662 + 0.55062923158087 + 0.53859255019553 + 0.52656501026819 + 0.51458057436720 + 0.50266279815563 + 0.49082138754795 + 0.96210857265949 + 0.96210864819383 + 0.96210866073876 + 0.96210867537360 + 0.96210869244457 + 0.96210871236494 + 0.96210873561314 + 0.96210876275288 + 0.96210879445806 + 0.96210883158993 + 0.96210887542621 + 0.96210892787199 + 0.96210899121175 + 0.96210906798107 + 0.96210916115612 + 0.96210927434774 + 0.96210941196318 + 0.96210957940144 + 0.96210978352669 + 0.96211003307138 + 0.96211033854837 + 0.96211071300124 + 0.96211117265599 + 0.96211173774901 + 0.96211243380058 + 0.96211329445570 + 0.96211436695708 + 0.96211571349315 + 0.96211741013202 + 0.96211955186642 + 0.96212226744758 + 0.96212572057500 + 0.96213012141028 + 0.96213574240629 + 0.96214293739965 + 0.96215216671752 + 0.96216403034153 + 0.96217931171768 + 0.96219906060470 + 0.96222469159275 + 0.96225805398909 + 0.96230161037381 + 0.96235863959708 + 0.96243335033331 + 0.96253003045540 + 0.96265241942643 + 0.96280645783206 + 0.96299956356421 + 0.96323788998926 + 0.96353082815183 + 0.96389403368765 + 0.96434948229725 + 0.96492747838569 + 0.96567040667456 + 0.96663980117754 + 0.96792638532261 + 0.96966967876875 + 0.97210299652561 + 0.97567125066270 + 0.98148843995870 + 1.00000000000000 + 0.97903579069273 + 0.96884309549542 + 0.95962479304696 + 0.95046531571711 + 0.94100018483195 + 0.93103306541883 + 0.92044299148523 + 0.90915523968130 + 0.89713189520070 + 0.88437044801113 + 0.87090538771096 + 0.85680392418340 + 0.84215025829459 + 0.82706129545433 + 0.81171021013147 + 0.79629624598456 + 0.78862007047584 + 0.78099402310121 + 0.77343290643715 + 0.76594647057475 + 0.75853881193208 + 0.75120806729046 + 0.74394652431025 + 0.73674128066316 + 0.72957539022979 + 0.72242603441899 + 0.71521006893233 + 0.70768861589184 + 0.69973650956911 + 0.69133955946801 + 0.68248379750157 + 0.67318604418583 + 0.66347092103200 + 0.65336901836611 + 0.64291535767878 + 0.63214829538214 + 0.62110688555288 + 0.60979643749567 + 0.59825469145486 + 0.58652258763933 + 0.57464463446165 + 0.56266875716152 + 0.55064529070103 + 0.53860648566518 + 0.52657705468066 + 0.51459095265550 + 0.50267172465136 + 0.49082906223107 + 0.95738765135282 + 0.95738771934444 + 0.95738773063518 + 0.95738774380470 + 0.95738775916688 + 0.95738777709205 + 0.95738779800875 + 0.95738782242600 + 0.95738785094775 + 0.95738788434882 + 0.95738792378737 + 0.95738797099558 + 0.95738802805496 + 0.95738809727129 + 0.95738818134917 + 0.95738828356816 + 0.95738840793588 + 0.95738855936378 + 0.95738874409368 + 0.95738897008115 + 0.95738924689397 + 0.95738958640752 + 0.95739000338287 + 0.95739051623755 + 0.95739114818208 + 0.95739192985414 + 0.95739290436440 + 0.95739412850553 + 0.95739567165474 + 0.95739762037137 + 0.95740009206968 + 0.95740323591767 + 0.95740724326549 + 0.95741236201900 + 0.95741891385823 + 0.95742731690756 + 0.95743811554583 + 0.95745201978815 + 0.95746998040201 + 0.95749327776340 + 0.95752358269073 + 0.95756311669737 + 0.95761483209775 + 0.95768250356940 + 0.95776991116787 + 0.95788023029137 + 0.95801857147228 + 0.95819125223441 + 0.95840319252349 + 0.95866202999581 + 0.95898076253459 + 0.95937753696532 + 0.95987708693774 + 0.96051345524886 + 0.96133505950198 + 0.96241102898666 + 0.96384261954483 + 0.96578690981652 + 0.96850675295795 + 0.97250373527213 + 0.97903579069273 + 1.00000000000000 + 0.97620088992349 + 0.96464025925403 + 0.95422564432515 + 0.94393414306761 + 0.93336938951514 + 0.92232418549928 + 0.91067903703139 + 0.89836975043249 + 0.88537688817664 + 0.87172326929711 + 0.85746763083324 + 0.84268771877976 + 0.82749557475445 + 0.81206074264466 + 0.79657951026729 + 0.78887503148718 + 0.78122384676374 + 0.77364046397805 + 0.76613434951962 + 0.75870932794328 + 0.75136327692875 + 0.74408823864905 + 0.73687107999978 + 0.72969464035197 + 0.72253590072983 + 0.71531146910984 + 0.70778209874843 + 0.69982245892562 + 0.69141833691677 + 0.68255574826647 + 0.67325152322455 + 0.66353029365131 + 0.65342265769277 + 0.64296364035585 + 0.63219159673856 + 0.62114557437404 + 0.60983085926693 + 0.59828518166027 + 0.58654947110453 + 0.57466822548816 + 0.56268936013053 + 0.55066320075971 + 0.53862198548616 + 0.52659041461696 + 0.51460243278557 + 0.50268157169496 + 0.49083750553111 + 0.95203783011127 + 0.95203789153294 + 0.95203790173059 + 0.95203791362476 + 0.95203792749884 + 0.95203794368595 + 0.95203796257162 + 0.95203798461773 + 0.95203801036621 + 0.95203804051927 + 0.95203807612612 + 0.95203811876927 + 0.95203817034697 + 0.95203823296127 + 0.95203830907542 + 0.95203840167878 + 0.95203851442116 + 0.95203865178148 + 0.95203881945224 + 0.95203902469429 + 0.95203927623396 + 0.95203958490256 + 0.95203996416735 + 0.95204043080811 + 0.95204100598986 + 0.95204171765761 + 0.95204260522351 + 0.95204372063546 + 0.95204512727862 + 0.95204690415113 + 0.95204915850233 + 0.95205202645901 + 0.95205568251112 + 0.95206035254746 + 0.95206632944009 + 0.95207399349039 + 0.95208383929240 + 0.95209651113746 + 0.95211287122356 + 0.95213407986385 + 0.95216164843043 + 0.95219758339417 + 0.95224454632292 + 0.95230592696069 + 0.95238506099474 + 0.95248464048811 + 0.95260906352078 + 0.95276371219811 + 0.95295248822443 + 0.95318158903768 + 0.95346183585465 + 0.95380828864616 + 0.95424129123992 + 0.95478850991688 + 0.95548872616709 + 0.95639607184465 + 0.95758726452178 + 0.95917583940704 + 0.96133818738907 + 0.96437041874481 + 0.96884309549542 + 0.97620088992349 + 1.00000000000000 + 0.97295846355362 + 0.95986374746830 + 0.94813283230482 + 0.93662260197114 + 0.92489617332559 + 0.91273461015149 + 0.90002193449108 + 0.88670814884684 + 0.87279635550067 + 0.85833170740918 + 0.84338204087217 + 0.82805214053563 + 0.81250622648389 + 0.79693633454026 + 0.78919473859335 + 0.78151070034859 + 0.77389831979679 + 0.76636667287818 + 0.75891921185431 + 0.75155346114592 + 0.74426112956711 + 0.73702877175219 + 0.72983893775577 + 0.72266833962465 + 0.71543326102964 + 0.70789398639545 + 0.69992497332839 + 0.69151197552710 + 0.68264098306728 + 0.67332883308578 + 0.66360016495289 + 0.65348558102774 + 0.64302010505109 + 0.63224208489527 + 0.62119055463105 + 0.60987076719329 + 0.59832043598555 + 0.58658047335502 + 0.57469536061917 + 0.56271299776608 + 0.55068369649860 + 0.53863967764094 + 0.52660562489521 + 0.51461546903383 + 0.50269272465896 + 0.49084704445347 + 0.94599224305604 + 0.94599229871133 + 0.94599230795083 + 0.94599231872573 + 0.94599233129419 + 0.94599234595638 + 0.94599236306274 + 0.94599238302780 + 0.94599240634344 + 0.94599243364573 + 0.94599246588967 + 0.94599250452339 + 0.94599255128043 + 0.94599260808091 + 0.94599267717454 + 0.94599276128821 + 0.94599286375738 + 0.94599298866925 + 0.94599314122679 + 0.94599332806575 + 0.94599355716355 + 0.94599383841555 + 0.94599418411786 + 0.94599460959782 + 0.94599513417728 + 0.94599578338405 + 0.94599659329599 + 0.94599761149072 + 0.94599889594868 + 0.94600051886535 + 0.94600257831375 + 0.94600519866529 + 0.94600853921898 + 0.94601280602468 + 0.94601826600756 + 0.94602526542151 + 0.94603425407591 + 0.94604581718117 + 0.94606073732652 + 0.94608006695192 + 0.94610517436541 + 0.94613787333638 + 0.94618056534630 + 0.94623629707964 + 0.94630801355599 + 0.94639799117832 + 0.94651001324091 + 0.94664866160005 + 0.94681699220456 + 0.94702000847789 + 0.94726672524608 + 0.94756967014011 + 0.94794564728458 + 0.94841729709516 + 0.94901602352736 + 0.94978493541264 + 0.95078370487384 + 0.95209788717857 + 0.95385431574660 + 0.95625089399886 + 0.95962479304696 + 0.96464025925403 + 0.97295846355362 + 1.00000000000000 + 0.96926949858263 + 0.95446139661183 + 0.94129979908008 + 0.92849255104240 + 0.91555583415010 + 0.90225869261241 + 0.88849099515801 + 0.87422027783174 + 0.85946876460720 + 0.84428844305330 + 0.82877291528698 + 0.81307839712885 + 0.79739069006246 + 0.78960002192674 + 0.78187269485051 + 0.77422223870040 + 0.76665718742484 + 0.75918047953038 + 0.75178915449305 + 0.74447446557487 + 0.73722254238903 + 0.73001554261180 + 0.72282981518668 + 0.71558121578782 + 0.70802942689212 + 0.70004863184367 + 0.69162453465302 + 0.68274308698907 + 0.67342112818500 + 0.66368330050380 + 0.65356020486239 + 0.64308685659963 + 0.63230158775617 + 0.62124340908033 + 0.60991752705286 + 0.59836162865751 + 0.58661659993604 + 0.57472689729840 + 0.56274039794563 + 0.55070739299353 + 0.53866007951575 + 0.52662311885999 + 0.51463042315822 + 0.50270548498349 + 0.49085793019290 + 0.93919252590932 + 0.93919257646863 + 0.93919258485973 + 0.93919259464491 + 0.93919260605914 + 0.93919261937334 + 0.93919263490477 + 0.93919265303107 + 0.93919267419835 + 0.93919269898225 + 0.93919272825353 + 0.93919276333970 + 0.93919280582709 + 0.93919285747225 + 0.93919292033226 + 0.93919299690251 + 0.93919309023104 + 0.93919320405590 + 0.93919334313691 + 0.93919351355356 + 0.93919372260284 + 0.93919397933799 + 0.93919429500775 + 0.93919468362270 + 0.93919516284855 + 0.93919575603464 + 0.93919649624266 + 0.93919742709697 + 0.93919860169493 + 0.93920008607819 + 0.93920197002927 + 0.93920436729680 + 0.93920742345223 + 0.93921132664261 + 0.93921632037836 + 0.93922272021614 + 0.93923093561698 + 0.93924149859987 + 0.93925512012676 + 0.93927275558676 + 0.93929564478830 + 0.93932542863645 + 0.93936427569001 + 0.93941492651577 + 0.93947998235878 + 0.93956136208304 + 0.93966231773112 + 0.93978674504075 + 0.93993699630239 + 0.94011708073897 + 0.94033450283017 + 0.94059969064131 + 0.94092655185553 + 0.94133368474536 + 0.94184668622519 + 0.94250024729969 + 0.94334154889376 + 0.94443674024780 + 0.94588083202849 + 0.94781537377943 + 0.95046531571711 + 0.95422564432515 + 0.95986374746830 + 0.96926949858263 + 1.00000000000000 + 0.96507438072655 + 0.94837768564572 + 0.93367891750090 + 0.91951004833565 + 0.90533415932654 + 0.89090789888454 + 0.87612895029146 + 0.86097825352950 + 0.84548113885700 + 0.82971328284232 + 0.81381849066742 + 0.79797320460771 + 0.79011726576005 + 0.78233256669928 + 0.77463183119777 + 0.76702283340418 + 0.75950779687427 + 0.75208309044221 + 0.74473934082251 + 0.73746209582828 + 0.73023297820514 + 0.72302784435642 + 0.71576198181436 + 0.70819429530481 + 0.70019861033324 + 0.69176055793802 + 0.68286603264458 + 0.67353186802032 + 0.66378270146826 + 0.65364912348404 + 0.64316613015757 + 0.63237202509269 + 0.62130578161742 + 0.60997254149090 + 0.59840995189776 + 0.58665885998105 + 0.57476368577153 + 0.56277227350295 + 0.55073488479979 + 0.53868368435716 + 0.52664330358981 + 0.51464762968475 + 0.50272012682095 + 0.49087038728281 + 0.93158327315622 + 0.93158331916783 + 0.93158332680291 + 0.93158333570743 + 0.93158334609166 + 0.93158335820357 + 0.93158337233255 + 0.93158338881878 + 0.93158340806959 + 0.93158343060753 + 0.93158345722968 + 0.93158348915014 + 0.93158352782368 + 0.93158357485972 + 0.93158363214155 + 0.93158370195280 + 0.93158378708488 + 0.93158389095819 + 0.93158401793619 + 0.93158417358853 + 0.93158436459900 + 0.93158459926022 + 0.93158488786861 + 0.93158524325237 + 0.93158568157108 + 0.93158622420378 + 0.93158690147833 + 0.93158775342455 + 0.93158882870414 + 0.93159018779393 + 0.93159191294627 + 0.93159410828564 + 0.93159690694988 + 0.93160048088210 + 0.93160505241923 + 0.93161090937905 + 0.93161842479233 + 0.93162808272275 + 0.93164052955599 + 0.93165663324496 + 0.93167751802360 + 0.93170466950038 + 0.93174004736794 + 0.93178611867387 + 0.93184518188983 + 0.93191884854990 + 0.93200991127964 + 0.93212167689541 + 0.93225591259080 + 0.93241579818077 + 0.93260756922569 + 0.93283990047493 + 0.93312430528252 + 0.93347608429626 + 0.93391617284234 + 0.93447265654757 + 0.93518321105034 + 0.93609979789497 + 0.93729539650639 + 0.93887539481537 + 0.94100018483195 + 0.94393414306761 + 0.94813283230482 + 0.95446139661183 + 0.96507438072655 + 1.00000000000000 + 0.96032259281222 + 0.94156352405956 + 0.92523239193451 + 0.90965631048900 + 0.89423790792362 + 0.87872035157929 + 0.86300360640557 + 0.84706514886751 + 0.83095043288034 + 0.81478324788145 + 0.79872555013064 + 0.79078218070235 + 0.78292093429467 + 0.77515337744560 + 0.76748620524899 + 0.75992063514891 + 0.75245209961491 + 0.74507035642917 + 0.73776015116214 + 0.73050237253798 + 0.72327220484005 + 0.71598417647880 + 0.70839618040120 + 0.70038157171281 + 0.69192587471588 + 0.68301489959274 + 0.67366546119941 + 0.66390217961281 + 0.65375562098787 + 0.64326074600837 + 0.63245581153669 + 0.62137973348181 + 0.61003756394773 + 0.59846689172221 + 0.58670850767974 + 0.57480677976017 + 0.56280950537278 + 0.55076690458746 + 0.53871109824061 + 0.52666667778833 + 0.51466749716770 + 0.50273698391788 + 0.49088468815474 + 0.92311977689610 + 0.92311981881394 + 0.92311982576848 + 0.92311983387751 + 0.92311984333502 + 0.92311985436558 + 0.92311986723142 + 0.92311988224313 + 0.92311989976935 + 0.92311992028709 + 0.92311994452618 + 0.92311997359596 + 0.92312000883464 + 0.92312005171671 + 0.92312010396203 + 0.92312016767011 + 0.92312024539351 + 0.92312034026754 + 0.92312045629077 + 0.92312059857275 + 0.92312077323828 + 0.92312098788631 + 0.92312125195214 + 0.92312157718378 + 0.92312197837698 + 0.92312247512341 + 0.92312309525113 + 0.92312387551756 + 0.92312486055101 + 0.92312610576231 + 0.92312768655817 + 0.92312969832182 + 0.92313226289794 + 0.92313553754008 + 0.92313972539306 + 0.92314508916886 + 0.92315196896654 + 0.92316080554072 + 0.92317218700856 + 0.92318690246837 + 0.92320597209694 + 0.92323074191428 + 0.92326298418057 + 0.92330492141474 + 0.92335858545485 + 0.92342532417790 + 0.92350753316138 + 0.92360801394001 + 0.92372804869844 + 0.92387012577005 + 0.92403941233836 + 0.92424311316304 + 0.92449074999720 + 0.92479490847741 + 0.92517273218795 + 0.92564702619465 + 0.92624804147987 + 0.92701698100871 + 0.92801076720430 + 0.92930981037796 + 0.93103306541883 + 0.93336938951514 + 0.93662260197114 + 0.94129979908008 + 0.94837768564572 + 0.96032259281222 + 1.00000000000000 + 0.95495897699770 + 0.93397106773884 + 0.91593095027399 + 0.89892819183133 + 0.88229603154988 + 0.86575555237741 + 0.84919063434431 + 0.83259237529286 + 0.81605063861122 + 0.79970407845524 + 0.79164269487576 + 0.78367859227319 + 0.77582164337019 + 0.76807698533163 + 0.76044439976128 + 0.75291799600985 + 0.74548631439072 + 0.73813298446747 + 0.73083788001575 + 0.72357526183055 + 0.71625863712283 + 0.70864457404212 + 0.70060580470416 + 0.69212769733195 + 0.68319593801619 + 0.67382730215835 + 0.66404637280262 + 0.65388367050274 + 0.64337409663112 + 0.63255583495015 + 0.62146771573475 + 0.61011466746436 + 0.59853419482351 + 0.58676700859003 + 0.57485740320668 + 0.56285311048205 + 0.55080429268401 + 0.53874301155414 + 0.52669380540238 + 0.51469048400084 + 0.50275642760080 + 0.49090113324296 + 0.91376926187661 + 0.91376930007596 + 0.91376930641263 + 0.91376931380093 + 0.91376932241670 + 0.91376933246460 + 0.91376934418410 + 0.91376935785630 + 0.91376937381693 + 0.91376939250164 + 0.91376941457470 + 0.91376944105723 + 0.91376947317387 + 0.91376951227519 + 0.91376955994266 + 0.91376961809232 + 0.91376968906754 + 0.91376977573962 + 0.91376988177507 + 0.91377001186085 + 0.91377017161231 + 0.91377036799403 + 0.91377060965394 + 0.91377090735398 + 0.91377127465019 + 0.91377172949502 + 0.91377229743706 + 0.91377301223842 + 0.91377391484224 + 0.91377505604483 + 0.91377650500719 + 0.91377834914081 + 0.91378070002669 + 0.91378370155256 + 0.91378753944598 + 0.91379245364992 + 0.91379875443860 + 0.91380684340986 + 0.91381725602166 + 0.91383071018437 + 0.91384813230545 + 0.91387074282244 + 0.91390014568081 + 0.91393834467377 + 0.91398713689601 + 0.91404764463806 + 0.91412192073359 + 0.91421233376427 + 0.91431976590489 + 0.91444613045826 + 0.91459569471377 + 0.91477442872230 + 0.91499019187378 + 0.91525332175691 + 0.91557785109283 + 0.91598230999659 + 0.91649104439918 + 0.91713688850099 + 0.91796463548485 + 0.91903654953113 + 0.92044299148523 + 0.92232418549928 + 0.92489617332559 + 0.92849255104240 + 0.93367891750090 + 0.94156352405956 + 0.95495897699770 + 1.00000000000000 + 0.94892797367278 + 0.92555950059456 + 0.90575985619924 + 0.88734364894138 + 0.86955785534501 + 0.85208001397974 + 0.83479472144339 + 0.81773053532827 + 0.80098673462487 + 0.79276454743749 + 0.78466105318520 + 0.77668358229363 + 0.76883497382637 + 0.76111292246782 + 0.75350963864536 + 0.74601193410600 + 0.73860186825370 + 0.73125789769306 + 0.72395300341850 + 0.71659930788326 + 0.70895163201281 + 0.70088187592785 + 0.69237517901917 + 0.68341704481323 + 0.67402417643319 + 0.66422108918210 + 0.65403822586046 + 0.64351039345956 + 0.63267566486707 + 0.62157274506063 + 0.61020639268102 + 0.59861399287909 + 0.58683614376302 + 0.57491703721226 + 0.56290431407572 + 0.55084805700079 + 0.53878024846438 + 0.52672535627619 + 0.51471713173435 + 0.50277889403387 + 0.49092007327761 + 0.90351412705949 + 0.90351416184889 + 0.90351416761872 + 0.90351417434681 + 0.90351418219142 + 0.90351419133977 + 0.90351420200994 + 0.90351421445602 + 0.90351422898416 + 0.90351424599002 + 0.90351426608208 + 0.90351429019522 + 0.90351431945456 + 0.90351435509264 + 0.90351439856026 + 0.90351445161257 + 0.90351451639799 + 0.90351459554263 + 0.90351469240966 + 0.90351481129558 + 0.90351495734845 + 0.90351513695211 + 0.90351535803026 + 0.90351563044281 + 0.90351596660732 + 0.90351638297685 + 0.90351690301009 + 0.90351755771178 + 0.90351838465868 + 0.90351943041678 + 0.90352075843627 + 0.90352244884795 + 0.90352460386133 + 0.90352735519114 + 0.90353087271423 + 0.90353537568024 + 0.90354114730776 + 0.90354855371747 + 0.90355808271772 + 0.90357038784829 + 0.90358631093170 + 0.90360695929080 + 0.90363378559456 + 0.90366859784638 + 0.90371298653307 + 0.90376788157218 + 0.90383504039700 + 0.90391646129189 + 0.90401269893815 + 0.90412519044318 + 0.90425744585988 + 0.90441439795777 + 0.90460251667835 + 0.90483027271080 + 0.90510913338119 + 0.90545414005490 + 0.90588488560314 + 0.90642758044491 + 0.90711762634339 + 0.90800363613798 + 0.90915523968130 + 0.91067903703139 + 0.91273461015149 + 0.91555583415010 + 0.91951004833565 + 0.92523239193451 + 0.93397106773884 + 0.94892797367278 + 1.00000000000000 + 0.94217662167529 + 0.91629907793958 + 0.89472244292222 + 0.87493813865642 + 0.85607727277021 + 0.83778920628899 + 0.81998187932369 + 0.80268365352590 + 0.79423967174644 + 0.78594520746758 + 0.77780364845546 + 0.76981434745684 + 0.76197189238027 + 0.75426571207771 + 0.74668012103589 + 0.73919493654035 + 0.73178661108161 + 0.72442633234245 + 0.71702432639714 + 0.70933309006587 + 0.70122340136688 + 0.69268006236079 + 0.68368830711467 + 0.67426471484612 + 0.66443368559172 + 0.65422553604394 + 0.64367492753696 + 0.63281976809912 + 0.62169858176281 + 0.61031589436293 + 0.59870892279855 + 0.58691810806368 + 0.57498750006767 + 0.56296461452929 + 0.55089942521776 + 0.53882380863698 + 0.52676213928498 + 0.51474809119523 + 0.50280490470535 + 0.49094192530085 + 0.89235648498143 + 0.89235651662470 + 0.89235652187271 + 0.89235652799094 + 0.89235653512493 + 0.89235654344313 + 0.89235655314414 + 0.89235656446023 + 0.89235657766702 + 0.89235659312669 + 0.89235661139239 + 0.89235663332106 + 0.89235665994238 + 0.89235669238673 + 0.89235673198013 + 0.89235678032691 + 0.89235683939361 + 0.89235691158885 + 0.89235699998784 + 0.89235710852837 + 0.89235724192939 + 0.89235740603634 + 0.89235760810631 + 0.89235785717017 + 0.89235816459517 + 0.89235854545998 + 0.89235902129347 + 0.89235962056713 + 0.89236037775545 + 0.89236133554887 + 0.89236255215307 + 0.89236410102690 + 0.89236607580744 + 0.89236859708959 + 0.89237182027885 + 0.89237594579085 + 0.89238123223238 + 0.89238801352337 + 0.89239673427510 + 0.89240798972530 + 0.89242254526171 + 0.89244140619351 + 0.89246588905313 + 0.89249762640077 + 0.89253802690763 + 0.89258785704571 + 0.89264862013005 + 0.89272199847588 + 0.89280828117188 + 0.89290851328694 + 0.89302556895419 + 0.89316351042919 + 0.89332764653847 + 0.89352489614735 + 0.89376460564529 + 0.89405895609086 + 0.89442368592312 + 0.89487970310842 + 0.89545501590733 + 0.89618771934933 + 0.89713189520070 + 0.89836975043249 + 0.90002193449108 + 0.90225869261241 + 0.90533415932654 + 0.90965631048900 + 0.91593095027399 + 0.92555950059456 + 0.94217662167529 + 1.00000000000000 + 0.93465646363437 + 0.90617291192113 + 0.88283438742310 + 0.86174724344914 + 0.84193638139614 + 0.82304237862851 + 0.80495453604087 + 0.79619961758385 + 0.78763974958611 + 0.77927193950541 + 0.77109005377314 + 0.76308390749249 + 0.75523874399153 + 0.74753518630705 + 0.73994978698211 + 0.73245611661268 + 0.72502281348002 + 0.71755747391475 + 0.70980947079313 + 0.70164805055492 + 0.69305751362862 + 0.68402269379663 + 0.67455996502041 + 0.66469353857186 + 0.65445353230743 + 0.64387438691439 + 0.63299376836467 + 0.62184994165820 + 0.61044711381837 + 0.59882226652259 + 0.58701562302998 + 0.57507103789273 + 0.56303585567387 + 0.55095990206531 + 0.53887491222862 + 0.52680513731084 + 0.51478414942648 + 0.50283508696761 + 0.49096718820767 + 0.88032365420464 + 0.88032368292767 + 0.88032368769008 + 0.88032369324249 + 0.88032369971634 + 0.88032370726495 + 0.88032371606715 + 0.88032372633452 + 0.88032373831614 + 0.88032375234086 + 0.88032376891275 + 0.88032378881655 + 0.88032381299118 + 0.88032384247046 + 0.88032387846815 + 0.88032392244858 + 0.88032397620883 + 0.88032404195233 + 0.88032412249184 + 0.88032422143239 + 0.88032434308978 + 0.88032449281656 + 0.88032467725183 + 0.88032490465824 + 0.88032518544122 + 0.88032553340419 + 0.88032596829349 + 0.88032651624052 + 0.88032720885744 + 0.88032808526708 + 0.88032919885387 + 0.88033061693940 + 0.88033242529677 + 0.88033473432577 + 0.88033768621128 + 0.88034146415235 + 0.88034630432655 + 0.88035251136543 + 0.88036049061938 + 0.88037078441573 + 0.88038408893890 + 0.88040131732845 + 0.88042366340144 + 0.88045260228078 + 0.88048938259206 + 0.88053463252136 + 0.88058963715231 + 0.88065580986698 + 0.88073322698527 + 0.88082261319158 + 0.88092631002840 + 0.88104765053686 + 0.88119097447718 + 0.88136191141496 + 0.88156805302744 + 0.88181923019710 + 0.88212804249822 + 0.88251112326930 + 0.88299059658469 + 0.88359632257669 + 0.88437044801113 + 0.88537688817664 + 0.88670814884684 + 0.88849099515801 + 0.89090789888454 + 0.89423790792362 + 0.89892819183133 + 0.90575985619924 + 0.91629907793958 + 0.93465646363437 + 1.00000000000000 + 0.92632352131885 + 0.89516822005947 + 0.87010406025506 + 0.84783319820504 + 0.82728424265547 + 0.80803923130769 + 0.79883853787987 + 0.78990259317696 + 0.78121748708703 + 0.77276802696983 + 0.76453638583577 + 0.75650128132698 + 0.74863771181513 + 0.74091735155877 + 0.73330953450146 + 0.72577920505853 + 0.71823025327315 + 0.71040779706118 + 0.70217896095036 + 0.69352729002136 + 0.68443701735059 + 0.67492418253705 + 0.66501269377480 + 0.65473236021806 + 0.64411729175701 + 0.63320480155880 + 0.62203278564748 + 0.61060501434539 + 0.59895814186814 + 0.58713209097738 + 0.57517044848213 + 0.56312032574584 + 0.55103134784320 + 0.53893506167971 + 0.52685555545916 + 0.51482626694780 + 0.50287020259462 + 0.49099646447845 + 0.86747325536123 + 0.86747328135887 + 0.86747328566931 + 0.86747329069401 + 0.86747329655276 + 0.86747330338306 + 0.86747331134865 + 0.86747332063774 + 0.86747333147801 + 0.86747334416469 + 0.86747335916033 + 0.86747337717708 + 0.86747339907335 + 0.86747342579214 + 0.86747345843855 + 0.86747349835183 + 0.86747354717095 + 0.86747360690188 + 0.86747368011913 + 0.86747377011555 + 0.86747388083792 + 0.86747401717295 + 0.86747418519202 + 0.86747439244898 + 0.86747464845146 + 0.86747496582429 + 0.86747536266738 + 0.86747586293997 + 0.86747649560778 + 0.86747729650426 + 0.86747831455507 + 0.86747961143404 + 0.86748126567849 + 0.86748337832820 + 0.86748607942978 + 0.86748953643369 + 0.86749396501949 + 0.86749964310391 + 0.86750694027985 + 0.86751635074584 + 0.86752850790003 + 0.86754424142809 + 0.86756463430650 + 0.86759102012668 + 0.86762450655097 + 0.86766560526823 + 0.86771541427812 + 0.86777511865283 + 0.86784462692313 + 0.86792440434716 + 0.86801634791752 + 0.86812318140677 + 0.86824843755434 + 0.86839667654752 + 0.86857403949377 + 0.86878842586125 + 0.86904987495336 + 0.86937156139270 + 0.86977089585618 + 0.87027122417526 + 0.87090538771096 + 0.87172326929711 + 0.87279635550067 + 0.87422027783174 + 0.87612895029146 + 0.87872035157929 + 0.88229603154988 + 0.88734364894138 + 0.89472244292222 + 0.90617291192113 + 0.92632352131885 + 1.00000000000000 + 0.91712515666474 + 0.88325273347279 + 0.85656413836959 + 0.83332998596228 + 0.81231633875356 + 0.80245583729305 + 0.79297228031245 + 0.78383163457042 + 0.77500276267342 + 0.76645491054752 + 0.75815613016921 + 0.75007249644921 + 0.74216813883503 + 0.73440597692478 + 0.72674546598187 + 0.71908515944121 + 0.71116427852633 + 0.70284695118409 + 0.69411556568060 + 0.68495344062558 + 0.67537607367885 + 0.66540689032543 + 0.65507522344741 + 0.64441468901574 + 0.63346208735214 + 0.62225478979649 + 0.61079596725533 + 0.59912181893803 + 0.58727185366648 + 0.57528929203696 + 0.56322092835286 + 0.55111611643898 + 0.53900615251997 + 0.52691490946370 + 0.51487564791468 + 0.50291120321729 + 0.49103050389096 + 0.85389103242537 + 0.85389105587520 + 0.85389105976233 + 0.85389106429446 + 0.85389106957709 + 0.85389107573671 + 0.85389108291882 + 0.85389109129520 + 0.85389110106861 + 0.85389111250785 + 0.85389112602942 + 0.85389114228309 + 0.85389116205114 + 0.85389118619081 + 0.85389121570753 + 0.85389125182041 + 0.85389129602153 + 0.85389135013953 + 0.85389141651956 + 0.85389149816719 + 0.85389159867877 + 0.85389172251926 + 0.85389187522385 + 0.85389206368686 + 0.85389229658747 + 0.85389258546302 + 0.85389294687340 + 0.85389340276305 + 0.85389397965372 + 0.85389471032744 + 0.85389563958897 + 0.85389682389626 + 0.85389833510787 + 0.85390026564735 + 0.85390273440667 + 0.85390589437183 + 0.85390994244827 + 0.85391513212242 + 0.85392180033733 + 0.85393039739888 + 0.85394149958643 + 0.85395586083584 + 0.85397446375363 + 0.85399851437981 + 0.85402899605926 + 0.85406632274987 + 0.85411143225939 + 0.85416531630175 + 0.85422775377751 + 0.85429900226319 + 0.85438058914001 + 0.85447473069183 + 0.85458428956437 + 0.85471294132890 + 0.85486563041810 + 0.85504867130550 + 0.85527001615057 + 0.85554003863275 + 0.85587236305632 + 0.85628515286761 + 0.85680392418340 + 0.85746763083324 + 0.85833170740918 + 0.85946876460720 + 0.86097825352950 + 0.86300360640557 + 0.86575555237741 + 0.86955785534501 + 0.87493813865642 + 0.88283438742310 + 0.89516822005947 + 0.91712515666474 + 1.00000000000000 + 0.90697712136617 + 0.87042134398627 + 0.84233138846673 + 0.81843065518251 + 0.80754572926745 + 0.79723217059724 + 0.78741484667883 + 0.77803200402703 + 0.76902933337074 + 0.76035630712551 + 0.75196404894994 + 0.74380446234679 + 0.73583036081357 + 0.72799275872553 + 0.72018229819531 + 0.71212983059041 + 0.70369514339318 + 0.69485881378290 + 0.68560274143896 + 0.67594154248494 + 0.66589787295721 + 0.65550033011568 + 0.64478179100293 + 0.63377830872629 + 0.62252650662581 + 0.61102872856824 + 0.59932054039689 + 0.58744087988412 + 0.57543246608136 + 0.56334166172547 + 0.55121745351040 + 0.53909080298562 + 0.52698529758715 + 0.51493396377024 + 0.50295941403547 + 0.49107035448390 + 0.83967660456851 + 0.83967662563023 + 0.83967662912120 + 0.83967663319112 + 0.83967663793537 + 0.83967664346666 + 0.83967664991522 + 0.83967665743631 + 0.83967666621075 + 0.83967667648096 + 0.83967668862356 + 0.83967670322822 + 0.83967672100393 + 0.83967674273103 + 0.83967676931934 + 0.83967680187668 + 0.83967684175687 + 0.83967689062555 + 0.83967695061061 + 0.83967702444949 + 0.83967711541705 + 0.83967722757625 + 0.83967736597212 + 0.83967753688033 + 0.83967774821268 + 0.83967801048919 + 0.83967833884542 + 0.83967875335070 + 0.83967927824553 + 0.83967994349314 + 0.83968079007157 + 0.83968186960323 + 0.83968324777987 + 0.83968500905677 + 0.83968726203989 + 0.83969014640118 + 0.83969384178452 + 0.83969857926121 + 0.83970466585656 + 0.83971251169845 + 0.83972264092260 + 0.83973573844339 + 0.83975269563020 + 0.83977460313540 + 0.83980233432409 + 0.83983622143070 + 0.83987706506447 + 0.83992569334212 + 0.83998178771753 + 0.84004544180614 + 0.84011787683220 + 0.84020088765992 + 0.84029678221768 + 0.84040850657694 + 0.84054002060608 + 0.84069634131140 + 0.84088372306314 + 0.84111027419007 + 0.84138657728499 + 0.84172666497156 + 0.84215025829459 + 0.84268771877976 + 0.84338204087217 + 0.84428844305330 + 0.84548113885700 + 0.84706514886751 + 0.84919063434431 + 0.85208001397974 + 0.85607727277021 + 0.86174724344914 + 0.87010406025506 + 0.88325273347279 + 0.90697712136617 + 1.00000000000000 + 0.89584762253298 + 0.85678395926570 + 0.82760773217937 + 0.81500661639423 + 0.80335443280664 + 0.79247847641466 + 0.78225043054010 + 0.77256834447812 + 0.76334632636466 + 0.75450848207966 + 0.74598558384289 + 0.73771362119237 + 0.72963000041784 + 0.72161314819667 + 0.71338162028066 + 0.70478869639888 + 0.69581203583400 + 0.68643127977827 + 0.67665959290928 + 0.66651839283177 + 0.65603512988077 + 0.64524156511439 + 0.63417265283208 + 0.62286394024684 + 0.61131661738384 + 0.59956536143552 + 0.58764831641838 + 0.57560750951605 + 0.56348871190225 + 0.55134040991189 + 0.53919311459214 + 0.52707003174260 + 0.51500387558171 + 0.50301696553836 + 0.49111771953599 + 0.82495891774037 + 0.82495893656842 + 0.82495893968897 + 0.82495894332632 + 0.82495894756727 + 0.82495895251039 + 0.82495895827402 + 0.82495896499412 + 0.82495897283653 + 0.82495898201432 + 0.82495899286819 + 0.82495900593148 + 0.82495902184669 + 0.82495904131859 + 0.82495906517238 + 0.82495909440792 + 0.82495913025537 + 0.82495917421825 + 0.82495922823247 + 0.82495929478267 + 0.82495937684179 + 0.82495947810121 + 0.82495960314738 + 0.82495975768467 + 0.82495994890860 + 0.82496018639843 + 0.82496048396273 + 0.82496085992506 + 0.82496133641733 + 0.82496194077834 + 0.82496271044199 + 0.82496369255745 + 0.82496494710551 + 0.82496655118572 + 0.82496860391419 + 0.82497123269653 + 0.82497460130362 + 0.82497892023127 + 0.82498446906358 + 0.82499162113032 + 0.82500085291362 + 0.82501278636686 + 0.82502822982987 + 0.82504816941784 + 0.82507338108931 + 0.82510412906123 + 0.82514109655342 + 0.82518497361754 + 0.82523537122097 + 0.82529225588229 + 0.82535659670992 + 0.82542984033564 + 0.82551383788805 + 0.82561093706569 + 0.82572429188073 + 0.82585786280508 + 0.82601653039414 + 0.82620657960592 + 0.82643615932888 + 0.82671601847231 + 0.82706129545433 + 0.82749557475445 + 0.82805214053563 + 0.82877291528698 + 0.82971328284232 + 0.83095043288034 + 0.83259237529286 + 0.83479472144339 + 0.83778920628899 + 0.84193638139614 + 0.84783319820504 + 0.85656413836959 + 0.87042134398627 + 0.89584762253298 + 1.00000000000000 + 0.88380886669928 + 0.84252773040301 + 0.82665530383922 + 0.81261818272135 + 0.79994887867463 + 0.78834434960476 + 0.77759043745627 + 0.76752488995191 + 0.75801753221777 + 0.74895919049910 + 0.74025563766450 + 0.73182087549921 + 0.72351339962345 + 0.71503285322921 + 0.70622230580847 + 0.69705452521671 + 0.68750542781245 + 0.67758572892161 + 0.66731481014716 + 0.65671829886210 + 0.64582624088965 + 0.63467194895132 + 0.62328939969331 + 0.61167814949464 + 0.59987161402864 + 0.58790682202127 + 0.57582483658121 + 0.56367061025139 + 0.55149194116383 + 0.53931872790885 + 0.52717366086867 + 0.51508903392071 + 0.50308677691706 + 0.49117493002142 + 0.80992002162047 + 0.80992003837143 + 0.80992004114775 + 0.80992004438350 + 0.80992004815624 + 0.80992005255382 + 0.80992005768088 + 0.80992006365899 + 0.80992007063404 + 0.80992007879739 + 0.80992008845537 + 0.80992010008832 + 0.80992011427729 + 0.80992013165658 + 0.80992015297252 + 0.80992017912817 + 0.80992021123356 + 0.80992025064985 + 0.80992029912827 + 0.80992035891994 + 0.80992043272090 + 0.80992052387975 + 0.80992063655641 + 0.80992077593069 + 0.80992094853588 + 0.80992116308329 + 0.80992143215460 + 0.80992177246476 + 0.80992220419259 + 0.80992275226643 + 0.80992345085167 + 0.80992434297828 + 0.80992548337470 + 0.80992694239072 + 0.80992881043109 + 0.80993120366546 + 0.80993427134608 + 0.80993820517914 + 0.80994325971565 + 0.80994977474779 + 0.80995818342078 + 0.80996905054444 + 0.80998310923896 + 0.81000125133465 + 0.81002416688091 + 0.81005206395247 + 0.81008552587289 + 0.81012512694977 + 0.81017042998715 + 0.81022130545861 + 0.81027851689578 + 0.81034322582212 + 0.81041691071134 + 0.81050143323405 + 0.81059929412187 + 0.81071360196410 + 0.81084813689766 + 0.81100773082180 + 0.81119860386812 + 0.81142891715453 + 0.81171021013147 + 0.81206074264466 + 0.81250622648389 + 0.81307839712885 + 0.81381849066742 + 0.81478324788145 + 0.81605063861122 + 0.81773053532827 + 0.81998187932369 + 0.82304237862851 + 0.82728424265547 + 0.83332998596228 + 0.84233138846673 + 0.85678395926570 + 0.88380886669928 + 1.00000000000000 + 0.87095017597133 + 0.84695389306836 + 0.82782921682836 + 0.81169164289496 + 0.79760417733893 + 0.78501608843456 + 0.77356578935529 + 0.76299590099148 + 0.75311149389012 + 0.74375800067525 + 0.73480542438769 + 0.72607721948327 + 0.71724211402622 + 0.70812617987957 + 0.69869353302959 + 0.68891364695934 + 0.67879294588764 + 0.66834735426378 + 0.65759951962993 + 0.64657678757057 + 0.63530996851107 + 0.62383070796543 + 0.61213621458410 + 0.60025809182285 + 0.58823178551010 + 0.57609700373316 + 0.56389755766492 + 0.55168029260939 + 0.53947426900364 + 0.52730147675677 + 0.51519364061205 + 0.50317216932013 + 0.49124460446703 + 0.79476653159387 + 0.79476654643545 + 0.79476654889454 + 0.79476655176205 + 0.79476655510392 + 0.79476655899980 + 0.79476656354142 + 0.79476656883632 + 0.79476657501449 + 0.79476658224689 + 0.79476659080504 + 0.79476660112417 + 0.79476661372674 + 0.79476662918530 + 0.79476664817022 + 0.79476667149680 + 0.79476670016496 + 0.79476673540587 + 0.79476677880101 + 0.79476683238890 + 0.79476689861144 + 0.79476698050044 + 0.79476708182696 + 0.79476720729157 + 0.79476736282396 + 0.79476755633797 + 0.79476779929588 + 0.79476810693578 + 0.79476849765436 + 0.79476899417786 + 0.79476962768278 + 0.79477043743964 + 0.79477147339601 + 0.79477279974172 + 0.79477449896588 + 0.79477667703172 + 0.79477947001243 + 0.79478305259272 + 0.79478765666842 + 0.79479359170647 + 0.79480125174256 + 0.79481115011104 + 0.79482395230131 + 0.79484046571864 + 0.79486130512807 + 0.79488663275640 + 0.79491694754527 + 0.79495272759665 + 0.79499350568642 + 0.79503908209706 + 0.79509005483105 + 0.79514735472205 + 0.79521215994384 + 0.79528594238269 + 0.79537067990090 + 0.79546880328324 + 0.79558322343040 + 0.79571763049991 + 0.79587673737964 + 0.79606669344200 + 0.79629624598456 + 0.79657951026729 + 0.79693633454026 + 0.79739069006246 + 0.79797320460771 + 0.79872555013064 + 0.79970407845524 + 0.80098673462487 + 0.80268365352590 + 0.80495453604087 + 0.80803923130769 + 0.81231633875356 + 0.81843065518251 + 0.82760773217937 + 0.84252773040301 + 0.87095017597133 + 1.00000000000000 + 0.89356925502319 + 0.85733993885891 + 0.83240305492274 + 0.81291920149317 + 0.79672925707784 + 0.78275139164296 + 0.77034744095174 + 0.75909916518744 + 0.74871115697164 + 0.73895942232230 + 0.72959892209419 + 0.72024328656101 + 0.71068791757217 + 0.70088051743604 + 0.69077871051852 + 0.68038102272941 + 0.66969725311345 + 0.65874499636629 + 0.64754721300422 + 0.63613079952571 + 0.62452386750480 + 0.61272019158345 + 0.60074873470901 + 0.58864266997286 + 0.57643978276642 + 0.56418228039288 + 0.55191568034271 + 0.53966788926775 + 0.52745994010424 + 0.51532278352112 + 0.50327712800849 + 0.49132985393551 + 0.78720347981310 + 0.78720349376394 + 0.78720349607556 + 0.78720349877068 + 0.78720350191165 + 0.78720350557357 + 0.78720350984180 + 0.78720351481894 + 0.78720352062537 + 0.78720352742265 + 0.78720353546879 + 0.78720354517525 + 0.78720355703746 + 0.78720357159931 + 0.78720358949674 + 0.78720361150326 + 0.78720363856979 + 0.78720367186402 + 0.78720371288817 + 0.78720376358186 + 0.78720382626804 + 0.78720390383394 + 0.78720399986832 + 0.78720411884751 + 0.78720426641894 + 0.78720445012901 + 0.78720468091426 + 0.78720497332711 + 0.78720534493377 + 0.78720581743420 + 0.78720642061818 + 0.78720719200409 + 0.78720817931796 + 0.78720944389300 + 0.78721106454080 + 0.78721314249353 + 0.78721580772103 + 0.78721922703716 + 0.78722362186278 + 0.78722928765021 + 0.78723660040015 + 0.78724604972665 + 0.78725827000102 + 0.78727402990539 + 0.78729391021490 + 0.78731805360209 + 0.78734692199147 + 0.78738095183289 + 0.78741966651330 + 0.78746283942239 + 0.78751099886341 + 0.78756497810571 + 0.78762582877519 + 0.78769485917819 + 0.78777382810583 + 0.78786488380737 + 0.78797057712632 + 0.78809412736575 + 0.78823962858365 + 0.78841240750424 + 0.78862007047584 + 0.78887503148718 + 0.78919473859335 + 0.78960002192674 + 0.79011726576005 + 0.79078218070235 + 0.79164269487576 + 0.79276454743749 + 0.79423967174644 + 0.79619961758385 + 0.79883853787987 + 0.80245583729305 + 0.80754572926745 + 0.81500661639423 + 0.82665530383922 + 0.84695389306836 + 0.89356925502319 + 1.00000000000000 + 0.88758904371338 + 0.85032530033273 + 0.82502670760556 + 0.80545850781843 + 0.78931228527121 + 0.77543176506541 + 0.76313707818396 + 0.75198508520816 + 0.74166138687659 + 0.73186017258173 + 0.72214995355228 + 0.71230099829617 + 0.70224722035468 + 0.69193657268204 + 0.68136118530165 + 0.67052605327543 + 0.65944494660278 + 0.64813762021019 + 0.63662819578864 + 0.62494234336170 + 0.61307153180048 + 0.60104296016078 + 0.58888830223790 + 0.57664408781271 + 0.56435148546096 + 0.55205515880994 + 0.53978227965267 + 0.52755327516730 + 0.51539860794449 + 0.50333854892051 + 0.49137956928521 + 0.77968015086061 + 0.77968016396490 + 0.77968016613642 + 0.77968016866723 + 0.77968017161771 + 0.77968017505685 + 0.77968017906609 + 0.77968018374067 + 0.77968018919499 + 0.77968019557903 + 0.77968020313769 + 0.77968021226228 + 0.77968022342188 + 0.77968023713308 + 0.77968025399781 + 0.77968027475082 + 0.77968030029409 + 0.77968033173788 + 0.77968037050969 + 0.77968041845475 + 0.77968047778320 + 0.77968055124147 + 0.77968064224775 + 0.77968075506330 + 0.77968089507110 + 0.77968106946540 + 0.77968128868596 + 0.77968156663135 + 0.77968192007984 + 0.77968236975713 + 0.77968294413266 + 0.77968367906520 + 0.77968462016828 + 0.77968582606670 + 0.77968737208691 + 0.77968935497556 + 0.77969189892674 + 0.77969516329603 + 0.77969935959371 + 0.77970477002556 + 0.77971175354665 + 0.77972077737304 + 0.77973244652641 + 0.77974749322325 + 0.77976646656792 + 0.77978949170854 + 0.77981699672664 + 0.77984938034589 + 0.77988615974071 + 0.77992708616215 + 0.77997262602000 + 0.78002352566098 + 0.78008072425456 + 0.78014538518082 + 0.78021907334568 + 0.78030368786756 + 0.78040146355056 + 0.78051520767602 + 0.78064847449649 + 0.78080587502991 + 0.78099402310121 + 0.78122384676374 + 0.78151070034859 + 0.78187269485051 + 0.78233256669928 + 0.78292093429467 + 0.78367859227319 + 0.78466105318520 + 0.78594520746758 + 0.78763974958611 + 0.78990259317696 + 0.79297228031245 + 0.79723217059724 + 0.80335443280664 + 0.81261818272135 + 0.82782921682836 + 0.85733993885891 + 0.88758904371338 + 1.00000000000000 + 0.88140447884305 + 0.84318942977099 + 0.81761222718656 + 0.79802239025800 + 0.78195868849882 + 0.76819263981095 + 0.75600621743261 + 0.74493083864774 + 0.73456445707581 + 0.72440888994927 + 0.71419753488833 + 0.70384389975814 + 0.69328198758463 + 0.68249480835772 + 0.67148068390210 + 0.66024821743372 + 0.64881294898229 + 0.63719543769579 + 0.62541828141016 + 0.61347010963942 + 0.60137596048384 + 0.58916568919374 + 0.57687431480169 + 0.56454176432524 + 0.55221168649503 + 0.53991038579044 + 0.52765757774740 + 0.51548315328555 + 0.50340687404136 + 0.49143473812126 + 0.77221217850729 + 0.77221219081055 + 0.77221219284898 + 0.77221219522463 + 0.77221219799463 + 0.77221220122321 + 0.77221220498669 + 0.77221220937487 + 0.77221221449476 + 0.77221222048877 + 0.77221222758713 + 0.77221223616020 + 0.77221224665512 + 0.77221225956033 + 0.77221227544730 + 0.77221229501357 + 0.77221231911525 + 0.77221234880551 + 0.77221238544350 + 0.77221243078446 + 0.77221248692958 + 0.77221255649546 + 0.77221264273514 + 0.77221274970984 + 0.77221288254755 + 0.77221304811066 + 0.77221325636832 + 0.77221352059756 + 0.77221385682805 + 0.77221428486314 + 0.77221483191869 + 0.77221553228119 + 0.77221642956074 + 0.77221757981694 + 0.77221905507467 + 0.77222094783191 + 0.77222337681772 + 0.77222649433894 + 0.77223050254648 + 0.77223567111768 + 0.77224234291893 + 0.77225096404290 + 0.77226211184708 + 0.77227648424524 + 0.77229460085023 + 0.77231657114669 + 0.77234279231793 + 0.77237362896400 + 0.77240859484903 + 0.77244742333816 + 0.77249052604415 + 0.77253857211012 + 0.77259240106258 + 0.77265304830208 + 0.77272190770915 + 0.77280065952603 + 0.77289126227483 + 0.77299616425964 + 0.77311845096830 + 0.77326211364890 + 0.77343290643715 + 0.77364046397805 + 0.77389831979679 + 0.77422223870040 + 0.77463183119777 + 0.77515337744560 + 0.77582164337019 + 0.77668358229363 + 0.77780364845546 + 0.77927193950541 + 0.78121748708703 + 0.78383163457042 + 0.78741484667883 + 0.79247847641466 + 0.79994887867463 + 0.81169164289496 + 0.83240305492274 + 0.85032530033273 + 0.88140447884305 + 1.00000000000000 + 0.87502615191701 + 0.83595635434875 + 0.81018635237341 + 0.79063232992375 + 0.77468076581121 + 0.76103568663248 + 0.74894127712936 + 0.73783243471266 + 0.72710694049799 + 0.71644169210865 + 0.70571895615521 + 0.69485203409452 + 0.68381063163702 + 0.67258362092527 + 0.66117251058922 + 0.64958722170294 + 0.63784368637500 + 0.62596059942118 + 0.61392306600995 + 0.60175345931336 + 0.58947941677841 + 0.57713413153651 + 0.56475604109566 + 0.55238758417667 + 0.54005403896211 + 0.52777428311262 + 0.51557753671558 + 0.50348296762491 + 0.49149602610139 + 0.76481013385765 + 0.76481014540438 + 0.76481014731769 + 0.76481014954759 + 0.76481015214705 + 0.76481015517722 + 0.76481015870921 + 0.76481016282743 + 0.76481016763262 + 0.76481017325767 + 0.76481017992154 + 0.76481018797540 + 0.76481019784227 + 0.76481020998629 + 0.76481022495022 + 0.76481024339582 + 0.76481026613475 + 0.76481029416877 + 0.76481032879146 + 0.76481037167083 + 0.76481042480762 + 0.76481049069172 + 0.76481057242420 + 0.76481067387505 + 0.76481079993118 + 0.76481095714080 + 0.76481115502438 + 0.76481140627187 + 0.76481172620570 + 0.76481213374987 + 0.76481265493808 + 0.76481332256247 + 0.76481417833962 + 0.76481527589857 + 0.76481668413359 + 0.76481849153397 + 0.76482081165696 + 0.76482379014564 + 0.76482762030399 + 0.76483255998908 + 0.76483893688202 + 0.76484717715512 + 0.76485783210642 + 0.76487156738457 + 0.76488887515850 + 0.76490985094247 + 0.76493486372743 + 0.76496424729918 + 0.76499751446352 + 0.76503438447481 + 0.76507522059912 + 0.76512062354482 + 0.76517134481058 + 0.76522830710717 + 0.76529275390082 + 0.76536617377175 + 0.76545028463229 + 0.76554722330090 + 0.76565966994234 + 0.76579108150631 + 0.76594647057475 + 0.76613434951962 + 0.76636667287818 + 0.76665718742484 + 0.76702283340418 + 0.76748620524899 + 0.76807698533163 + 0.76883497382637 + 0.76981434745684 + 0.77109005377314 + 0.77276802696983 + 0.77500276267342 + 0.77803200402703 + 0.78225043054010 + 0.78834434960476 + 0.79760417733893 + 0.81291920149317 + 0.82502670760556 + 0.84318942977099 + 0.87502615191701 + 1.00000000000000 + 0.86846724736786 + 0.82865191374792 + 0.80277464251007 + 0.78330590025898 + 0.76748499599428 + 0.75395053409900 + 0.74183509521177 + 0.73036249027321 + 0.71911822253976 + 0.70793471560861 + 0.69669349071670 + 0.68534431396201 + 0.67386237152537 + 0.66223924447029 + 0.65047724335329 + 0.63858621056276 + 0.62657982755233 + 0.61443878473852 + 0.60218214386413 + 0.58983482065597 + 0.57742778997690 + 0.56499769468250 + 0.55258552572428 + 0.54021534322730 + 0.52790503585637 + 0.51568303484002 + 0.50356781443010 + 0.49156418939597 + 0.75747891964607 + 0.75747893048177 + 0.75747893227714 + 0.75747893436974 + 0.75747893680901 + 0.75747893965220 + 0.75747894296648 + 0.75747894683097 + 0.75747895134011 + 0.75747895661893 + 0.75747896287437 + 0.75747897043934 + 0.75747897971615 + 0.75747899114491 + 0.75747900524030 + 0.75747902262979 + 0.75747904408603 + 0.75747907056082 + 0.75747910328267 + 0.75747914384022 + 0.75747919414048 + 0.75747925655303 + 0.75747933403184 + 0.75747943026782 + 0.75747954992030 + 0.75747969924142 + 0.75747988732419 + 0.75748012630552 + 0.75748043083263 + 0.75748081900357 + 0.75748131572687 + 0.75748195238054 + 0.75748276888884 + 0.75748381657517 + 0.75748516138341 + 0.75748688799681 + 0.75748910508494 + 0.75749195200026 + 0.75749561368620 + 0.75750033682451 + 0.75750643477446 + 0.75751431492223 + 0.75752450399842 + 0.75753763731090 + 0.75755418147078 + 0.75757421956113 + 0.75759809486669 + 0.75762611336535 + 0.75765778905015 + 0.75769283041058 + 0.75773155815187 + 0.75777451246894 + 0.75782236724388 + 0.75787594620725 + 0.75793636086267 + 0.75800493243982 + 0.75808317000989 + 0.75817294108919 + 0.75827657677805 + 0.75839707528309 + 0.75853881193208 + 0.75870932794328 + 0.75891921185431 + 0.75918047953038 + 0.75950779687427 + 0.75992063514891 + 0.76044439976128 + 0.76111292246782 + 0.76197189238027 + 0.76308390749249 + 0.76453638583577 + 0.76645491054752 + 0.76902933337074 + 0.77256834447812 + 0.77759043745627 + 0.78501608843456 + 0.79672925707784 + 0.80545850781843 + 0.81761222718656 + 0.83595635434875 + 0.86846724736786 + 1.00000000000000 + 0.86174365892211 + 0.82130307939406 + 0.79540034609117 + 0.77605558128683 + 0.76036534273729 + 0.74682621782627 + 0.73434281562729 + 0.72234223481323 + 0.71057320027700 + 0.69886639422363 + 0.68714071067686 + 0.67535097725568 + 0.66347457195864 + 0.65150330603162 + 0.63943888392413 + 0.62728846561411 + 0.61502715306687 + 0.60266985724481 + 0.59023812958268 + 0.57776023385362 + 0.56527063986907 + 0.55280859921054 + 0.54039672137559 + 0.52805172427901 + 0.51580110922188 + 0.50366253854395 + 0.49164008844426 + 0.75021745950684 + 0.75021746967678 + 0.75021747136172 + 0.75021747332546 + 0.75021747561458 + 0.75021747828297 + 0.75021748139388 + 0.75021748501973 + 0.75021748925133 + 0.75021749420578 + 0.75021750007915 + 0.75021750718579 + 0.75021751590955 + 0.75021752666648 + 0.75021753994653 + 0.75021755634494 + 0.75021757659641 + 0.75021760160610 + 0.75021763253937 + 0.75021767091354 + 0.75021771854166 + 0.75021777768347 + 0.75021785115709 + 0.75021794247741 + 0.75021805609377 + 0.75021819797357 + 0.75021837680974 + 0.75021860421069 + 0.75021889418854 + 0.75021926405613 + 0.75021973765504 + 0.75022034502613 + 0.75022112439270 + 0.75022212489618 + 0.75022340968385 + 0.75022505983867 + 0.75022717940628 + 0.75022990178854 + 0.75023340401657 + 0.75023792222037 + 0.75024375622278 + 0.75025129567174 + 0.75026104413533 + 0.75027360834122 + 0.75028943109013 + 0.75030858442834 + 0.75033138818335 + 0.75035812325708 + 0.75038830669434 + 0.75042163917460 + 0.75045840401576 + 0.75049908796606 + 0.75054429658061 + 0.75059476680996 + 0.75065149458637 + 0.75071565532322 + 0.75078857732343 + 0.75087189598250 + 0.75096764276798 + 0.75107842340737 + 0.75120806729046 + 0.75136327692875 + 0.75155346114592 + 0.75178915449305 + 0.75208309044221 + 0.75245209961491 + 0.75291799600985 + 0.75350963864536 + 0.75426571207771 + 0.75523874399153 + 0.75650128132698 + 0.75815613016921 + 0.76035630712551 + 0.76334632636466 + 0.76752488995191 + 0.77356578935529 + 0.78275139164296 + 0.78931228527121 + 0.79802239025800 + 0.81018635237341 + 0.82865191374792 + 0.86174365892211 + 1.00000000000000 + 0.85487403293428 + 0.81393705050193 + 0.78808299211130 + 0.76888103424614 + 0.75320600107050 + 0.73929546166998 + 0.72627568375547 + 0.71374531331536 + 0.70144943071355 + 0.68925718558638 + 0.67709212718084 + 0.66491077123087 + 0.65269012862001 + 0.64042083461226 + 0.62810144137563 + 0.61569989063166 + 0.60322583811492 + 0.59069664206176 + 0.57813722998625 + 0.56557942543165 + 0.55306038035574 + 0.54060096981877 + 0.52821652121484 + 0.51593343656291 + 0.50376842550589 + 0.49172470404994 + 0.74301880357604 + 0.74301881312299 + 0.74301881470456 + 0.74301881654838 + 0.74301881869801 + 0.74301882120261 + 0.74301882412254 + 0.74301882752697 + 0.74301883149946 + 0.74301883615109 + 0.74301884166638 + 0.74301884834564 + 0.74301885655133 + 0.74301886668044 + 0.74301887919654 + 0.74301889466624 + 0.74301891378725 + 0.74301893742008 + 0.74301896667695 + 0.74301900299991 + 0.74301904811709 + 0.74301910418443 + 0.74301917388636 + 0.74301926058092 + 0.74301936851100 + 0.74301950337790 + 0.74301967349669 + 0.74301988997077 + 0.74302016621171 + 0.74302051878868 + 0.74302097053170 + 0.74302155021142 + 0.74302229443860 + 0.74302325028869 + 0.74302447825220 + 0.74302605600359 + 0.74302808320364 + 0.74303068761454 + 0.74303403878479 + 0.74303836284609 + 0.74304394681253 + 0.74305116356664 + 0.74306049478167 + 0.74307252024026 + 0.74308766050878 + 0.74310597785498 + 0.74312777069046 + 0.74315329728236 + 0.74318207936724 + 0.74321381239705 + 0.74324874689069 + 0.74328732242078 + 0.74333008443534 + 0.74337769386501 + 0.74343104551222 + 0.74349118789274 + 0.74355929312282 + 0.74363679694432 + 0.74372547424083 + 0.74382759580235 + 0.74394652431025 + 0.74408823864905 + 0.74426112956711 + 0.74447446557487 + 0.74473934082251 + 0.74507035642917 + 0.74548631439072 + 0.74601193410600 + 0.74668012103589 + 0.74753518630705 + 0.74863771181513 + 0.75007249644921 + 0.75196404894994 + 0.75450848207966 + 0.75801753221777 + 0.76299590099148 + 0.77034744095174 + 0.77543176506541 + 0.78195868849882 + 0.79063232992375 + 0.80277464251007 + 0.82130307939406 + 0.85487403293428 + 1.00000000000000 + 0.84787970147435 + 0.80657981076031 + 0.78082925400804 + 0.76165954616191 + 0.74560984737933 + 0.73115710641846 + 0.71760625234722 + 0.70454845501447 + 0.69176859361191 + 0.67914021228736 + 0.66658819078838 + 0.65406813487865 + 0.64155530808192 + 0.62903670705600 + 0.61647097024732 + 0.60386102268229 + 0.59121894614118 + 0.57856552993697 + 0.56592935382898 + 0.55334502142826 + 0.54083132457593 + 0.52840193282124 + 0.51608194454794 + 0.50388694845014 + 0.49181915631381 + 0.73587078141742 + 0.73587079038471 + 0.73587079187034 + 0.73587079360282 + 0.73587079562124 + 0.73587079797376 + 0.73587080071672 + 0.73587080391413 + 0.73587080764491 + 0.73587081201416 + 0.73587081719606 + 0.73587082347640 + 0.73587083119984 + 0.73587084074193 + 0.73587085254383 + 0.73587086714525 + 0.73587088520857 + 0.73587090755276 + 0.73587093523741 + 0.73587096963541 + 0.73587101239582 + 0.73587106557355 + 0.73587113173052 + 0.73587121407066 + 0.73587131664799 + 0.73587144490723 + 0.73587160680440 + 0.73587181296811 + 0.73587207623655 + 0.73587241247237 + 0.73587284354507 + 0.73587339701957 + 0.73587410797452 + 0.73587502151883 + 0.73587619562138 + 0.73587770471892 + 0.73587964430740 + 0.73588213680047 + 0.73588534463879 + 0.73588948446497 + 0.73589483115002 + 0.73590174168361 + 0.73591067700825 + 0.73592219141922 + 0.73593668469386 + 0.73595421043970 + 0.73597504747559 + 0.73599943363357 + 0.73602689675418 + 0.73605712931406 + 0.73609035308075 + 0.73612696596118 + 0.73616746050657 + 0.73621243104382 + 0.73626268384657 + 0.73631915700938 + 0.73638288776542 + 0.73645514027552 + 0.73653746994311 + 0.73663186207845 + 0.73674128066316 + 0.73687107999978 + 0.73702877175219 + 0.73722254238903 + 0.73746209582828 + 0.73776015116214 + 0.73813298446747 + 0.73860186825370 + 0.73919493654035 + 0.73994978698211 + 0.74091735155877 + 0.74216813883503 + 0.74380446234679 + 0.74598558384289 + 0.74895919049910 + 0.75311149389012 + 0.75909916518744 + 0.76313707818396 + 0.76819263981095 + 0.77468076581121 + 0.78330590025898 + 0.79540034609117 + 0.81393705050193 + 0.84787970147435 + 1.00000000000000 + 0.84078391436793 + 0.79924480725798 + 0.77350458703852 + 0.75395188850618 + 0.73735993632033 + 0.72238315000594 + 0.70831067566394 + 0.69477509244579 + 0.68156588897099 + 0.66855804474498 + 0.65567523232917 + 0.64287083601590 + 0.63011602915353 + 0.61735716430744 + 0.60458843042772 + 0.59181519627767 + 0.57905307126944 + 0.56632662876332 + 0.55366735992628 + 0.54109154136965 + 0.52861085744086 + 0.51624885486928 + 0.50401979932866 + 0.49192472711449 + 0.72875714052595 + 0.72875714895412 + 0.72875715035072 + 0.72875715197828 + 0.72875715387560 + 0.72875715608698 + 0.72875715866493 + 0.72875716167029 + 0.72875716517684 + 0.72875716928391 + 0.72875717415666 + 0.72875718006576 + 0.72875718733928 + 0.72875719633437 + 0.72875720747065 + 0.72875722126054 + 0.72875723833454 + 0.72875725947232 + 0.72875728568275 + 0.72875731827666 + 0.72875735882501 + 0.72875740928784 + 0.72875747211145 + 0.72875755035431 + 0.72875764788734 + 0.72875776991800 + 0.72875792405888 + 0.72875812048672 + 0.72875837149142 + 0.72875869226593 + 0.72875910376595 + 0.72875963240443 + 0.72876031180175 + 0.72876118519613 + 0.72876230815359 + 0.72876375202465 + 0.72876560834437 + 0.72876799442821 + 0.72877106595340 + 0.72877503053545 + 0.72878015149035 + 0.72878677070186 + 0.72879532941620 + 0.72880635776545 + 0.72882023601163 + 0.72883701010164 + 0.72885694089698 + 0.72888024773561 + 0.72890646578982 + 0.72893528652381 + 0.72896690648090 + 0.72900168671265 + 0.72904007314055 + 0.72908260164575 + 0.72913000087817 + 0.72918311270294 + 0.72924285776699 + 0.72931035266275 + 0.72938696493783 + 0.72947443645373 + 0.72957539022979 + 0.72969464035197 + 0.72983893775577 + 0.73001554261180 + 0.73023297820514 + 0.73050237253798 + 0.73083788001575 + 0.73125789769306 + 0.73178661108161 + 0.73245611661268 + 0.73330953450146 + 0.73440597692478 + 0.73583036081357 + 0.73771362119237 + 0.74025563766450 + 0.74375800067525 + 0.74871115697164 + 0.75198508520816 + 0.75600621743261 + 0.76103568663248 + 0.76748499599428 + 0.77605558128683 + 0.78808299211130 + 0.80657981076031 + 0.84078391436793 + 1.00000000000000 + 0.83359679361514 + 0.79177177877806 + 0.76560469437029 + 0.74552029857497 + 0.72842918093799 + 0.71294999015598 + 0.69841511504814 + 0.68446324457225 + 0.67088661863304 + 0.65755940246191 + 0.64440289564727 + 0.63136608777781 + 0.61837879402876 + 0.60542368730525 + 0.59249748609162 + 0.57960924730115 + 0.56677855258439 + 0.55403306403965 + 0.54138600310745 + 0.52884666494459 + 0.51643674160456 + 0.50416893168551 + 0.49204289133222 + 0.72165573291163 + 0.72165574083979 + 0.72165574215349 + 0.72165574368421 + 0.72165574546906 + 0.72165574754933 + 0.72165574997402 + 0.72165575280092 + 0.72165575609971 + 0.72165575996306 + 0.72165576454789 + 0.72165577011184 + 0.72165577696673 + 0.72165578545267 + 0.72165579596747 + 0.72165580899926 + 0.72165582514836 + 0.72165584515594 + 0.72165586998573 + 0.72165590088527 + 0.72165593935410 + 0.72165598726407 + 0.72165604694915 + 0.72165612132936 + 0.72165621410543 + 0.72165633025574 + 0.72165647706476 + 0.72165666427682 + 0.72165690366342 + 0.72165720977477 + 0.72165760269365 + 0.72165810773274 + 0.72165875711939 + 0.72165959230131 + 0.72166066654687 + 0.72166204825730 + 0.72166382517853 + 0.72166610975781 + 0.72166905120839 + 0.72167284851395 + 0.72167775396364 + 0.72168409501661 + 0.72169229413345 + 0.72170285843540 + 0.72171614979909 + 0.72173220739444 + 0.72175127555270 + 0.72177355682739 + 0.72179859479620 + 0.72182608160097 + 0.72185619161425 + 0.72188925317558 + 0.72192567096424 + 0.72196592940800 + 0.72201068884734 + 0.72206070700476 + 0.72211680344996 + 0.72217996748436 + 0.72225140542542 + 0.72233265092382 + 0.72242603441899 + 0.72253590072983 + 0.72266833962465 + 0.72282981518668 + 0.72302784435642 + 0.72327220484005 + 0.72357526183055 + 0.72395300341850 + 0.72442633234245 + 0.72502281348002 + 0.72577920505853 + 0.72674546598187 + 0.72799275872553 + 0.72963000041784 + 0.73182087549921 + 0.73480542438769 + 0.73895942232230 + 0.74166138687659 + 0.74493083864774 + 0.74894127712936 + 0.75395053409900 + 0.76036534273729 + 0.76888103424614 + 0.78082925400804 + 0.79924480725798 + 0.83359679361514 + 1.00000000000000 + 0.82608932695800 + 0.78354637152570 + 0.75686783422573 + 0.73634626201379 + 0.71879955255195 + 0.70289096284326 + 0.68796372582906 + 0.67366356656026 + 0.65978400474791 + 0.64619749363047 + 0.63282100773893 + 0.61956157978690 + 0.60638641535674 + 0.59328091340468 + 0.58024573539962 + 0.56729417688290 + 0.55444914684419 + 0.54172012759528 + 0.52911352040750 + 0.51664878830384 + 0.50433676498623 + 0.49217547955651 + 0.71448443038467 + 0.71448443784497 + 0.71448443908105 + 0.71448444052154 + 0.71448444220118 + 0.71448444415825 + 0.71448444643979 + 0.71448444909974 + 0.71448445220330 + 0.71448445583844 + 0.71448446015474 + 0.71448446539590 + 0.71448447185782 + 0.71448447986428 + 0.71448448979447 + 0.71448450211152 + 0.71448451738738 + 0.71448453632738 + 0.71448455984943 + 0.71448458914352 + 0.71448462563956 + 0.71448467112207 + 0.71448472781977 + 0.71448479852174 + 0.71448488676122 + 0.71448499729509 + 0.71448513709258 + 0.71448531548237 + 0.71448554373107 + 0.71448583576845 + 0.71448621082764 + 0.71448669316192 + 0.71448731364346 + 0.71448811198420 + 0.71448913922698 + 0.71449046090980 + 0.71449216110862 + 0.71449434754813 + 0.71449716317578 + 0.71450079860589 + 0.71450549544414 + 0.71451156717924 + 0.71451941808907 + 0.71452953306005 + 0.71454225638404 + 0.71455762117724 + 0.71457585634474 + 0.71459714899502 + 0.71462105217686 + 0.71464726022008 + 0.71467592779513 + 0.71470735383733 + 0.71474190608721 + 0.71478002309652 + 0.71482230432703 + 0.71486943300509 + 0.71492214003636 + 0.71498130364454 + 0.71504799017558 + 0.71512355317391 + 0.71521006893233 + 0.71531146910984 + 0.71543326102964 + 0.71558121578782 + 0.71576198181436 + 0.71598417647880 + 0.71625863712283 + 0.71659930788326 + 0.71702432639714 + 0.71755747391475 + 0.71823025327315 + 0.71908515944121 + 0.72018229819531 + 0.72161314819667 + 0.72351339962345 + 0.72607721948327 + 0.72959892209419 + 0.73186017258173 + 0.73456445707581 + 0.73783243471266 + 0.74183509521177 + 0.74682621782627 + 0.75320600107050 + 0.76165954616191 + 0.77350458703852 + 0.79177177877806 + 0.82608932695800 + 1.00000000000000 + 0.81758430864514 + 0.77439645119823 + 0.74738404206359 + 0.72649055671690 + 0.70856789508997 + 0.69229998937957 + 0.67704714833165 + 0.66246170620520 + 0.64833752137422 + 0.63454329569159 + 0.62095351265231 + 0.60751395423371 + 0.59419480328721 + 0.58098570427410 + 0.56789186404178 + 0.55493017418161 + 0.54210545663049 + 0.52942054736880 + 0.51689218754148 + 0.50452895781408 + 0.49232694129547 + 0.70700620983649 + 0.70700621684667 + 0.70700621800793 + 0.70700621936180 + 0.70700622093950 + 0.70700622277869 + 0.70700622492252 + 0.70700622742210 + 0.70700623033849 + 0.70700623375464 + 0.70700623781141 + 0.70700624274087 + 0.70700624882350 + 0.70700625636653 + 0.70700626572929 + 0.70700627735291 + 0.70700629177850 + 0.70700630967811 + 0.70700633192298 + 0.70700635964615 + 0.70700639420827 + 0.70700643730829 + 0.70700649106914 + 0.70700655814721 + 0.70700664191138 + 0.70700674689797 + 0.70700687975928 + 0.70700704940394 + 0.70700726659118 + 0.70700754462978 + 0.70700790190144 + 0.70700836158380 + 0.70700895318635 + 0.70700971467616 + 0.70701069484712 + 0.70701195635676 + 0.70701357957296 + 0.70701566746227 + 0.70701835665151 + 0.70702182931831 + 0.70702631629046 + 0.70703211698125 + 0.70703961735754 + 0.70704927993826 + 0.70706143152383 + 0.70707609963495 + 0.70709349820444 + 0.70711379959335 + 0.70713656772393 + 0.70716150069786 + 0.70718873509901 + 0.70721854251362 + 0.70725125644682 + 0.70728727317252 + 0.70732713603371 + 0.70737146011648 + 0.70742089606799 + 0.70747622218143 + 0.70753837958063 + 0.70760856130450 + 0.70768861589184 + 0.70778209874843 + 0.70789398639545 + 0.70802942689212 + 0.70819429530481 + 0.70839618040120 + 0.70864457404212 + 0.70895163201281 + 0.70933309006587 + 0.70980947079313 + 0.71040779706118 + 0.71116427852633 + 0.71212983059041 + 0.71338162028066 + 0.71503285322921 + 0.71724211402622 + 0.72024328656101 + 0.72214995355228 + 0.72440888994927 + 0.72710694049799 + 0.73036249027321 + 0.73434281562729 + 0.73929546166998 + 0.74560984737933 + 0.75395188850618 + 0.76560469437029 + 0.78354637152570 + 0.81758430864514 + 1.00000000000000 + 0.80846050860016 + 0.76481434451011 + 0.73748251611578 + 0.71624764970774 + 0.69797596755303 + 0.68138224354070 + 0.66584168744405 + 0.65100967447950 + 0.63667645397143 + 0.62266687668222 + 0.60889528062648 + 0.59531027536033 + 0.58188630978510 + 0.56861768006858 + 0.55551330873034 + 0.54257195030682 + 0.52979185869452 + 0.51718631267945 + 0.50476106002856 + 0.49250976319039 + 0.69909670547639 + 0.69909671204775 + 0.69909671313599 + 0.69909671440526 + 0.69909671588442 + 0.69909671760837 + 0.69909671961756 + 0.69909672196072 + 0.69909672469421 + 0.69909672789701 + 0.69909673170103 + 0.69909673632586 + 0.69909674203723 + 0.69909674912581 + 0.69909675793156 + 0.69909676887048 + 0.69909678245661 + 0.69909679932704 + 0.69909682030607 + 0.69909684646991 + 0.69909687910808 + 0.69909691983507 + 0.69909697066372 + 0.69909703411806 + 0.69909711340033 + 0.69909721282140 + 0.69909733870957 + 0.69909749954686 + 0.69909770557663 + 0.69909796946921 + 0.69909830873214 + 0.69909874544556 + 0.69909930772554 + 0.69910003174519 + 0.69910096399755 + 0.69910216418191 + 0.69910370886312 + 0.69910569613187 + 0.69910825613248 + 0.69911156238452 + 0.69911583466674 + 0.69912135796960 + 0.69912849949353 + 0.69913769888870 + 0.69914926524558 + 0.69916322085653 + 0.69917976488342 + 0.69919905536576 + 0.69922066869489 + 0.69924430834497 + 0.69927009408584 + 0.69929827167646 + 0.69932914241470 + 0.69936306301281 + 0.69940052428151 + 0.69944207802636 + 0.69948830121145 + 0.69953988093542 + 0.69959764471864 + 0.69966264050420 + 0.69973650956911 + 0.69982245892562 + 0.69992497332839 + 0.70004863184367 + 0.70019861033324 + 0.70038157171281 + 0.70060580470416 + 0.70088187592785 + 0.70122340136688 + 0.70164805055492 + 0.70217896095036 + 0.70284695118409 + 0.70369514339318 + 0.70478869639888 + 0.70622230580847 + 0.70812617987957 + 0.71068791757217 + 0.71230099829617 + 0.71419753488833 + 0.71644169210865 + 0.71911822253976 + 0.72234223481323 + 0.72627568375547 + 0.73115710641846 + 0.73735993632033 + 0.74552029857497 + 0.75686783422573 + 0.77439645119823 + 0.80846050860016 + 1.00000000000000 + 0.79910786234545 + 0.75500033186000 + 0.72734755998186 + 0.70576116722599 + 0.68714565604840 + 0.67024478894840 + 0.65444180407160 + 0.63938848603922 + 0.62482887749449 + 0.61062858875417 + 0.59670418116529 + 0.58300826672051 + 0.56951987476451 + 0.55623701797090 + 0.54315030851228 + 0.53025194414785 + 0.51755068314592 + 0.50504862362687 + 0.49273634744749 + 0.69074172446137 + 0.69074173060515 + 0.69074173162294 + 0.69074173280924 + 0.69074173419190 + 0.69074173580370 + 0.69074173768235 + 0.69074173987275 + 0.69074174242834 + 0.69074174542253 + 0.69074174898039 + 0.69074175330808 + 0.69074175865597 + 0.69074176529814 + 0.69074177355581 + 0.69074178382101 + 0.69074179657993 + 0.69074181243124 + 0.69074183215717 + 0.69074185677248 + 0.69074188749818 + 0.69074192585878 + 0.69074197376212 + 0.69074203359560 + 0.69074210838973 + 0.69074220223091 + 0.69074232111843 + 0.69074247309442 + 0.69074266787753 + 0.69074291748765 + 0.69074323854171 + 0.69074365199567 + 0.69074418454164 + 0.69074487051755 + 0.69074575406169 + 0.69074689184608 + 0.69074835655275 + 0.69075024127292 + 0.69075266952110 + 0.69075580595832 + 0.69075985906584 + 0.69076509908495 + 0.69077187405068 + 0.69078060027885 + 0.69079156898304 + 0.69080479760255 + 0.69082047075743 + 0.69083873262611 + 0.69085917358570 + 0.69088150403123 + 0.69090582815488 + 0.69093236735721 + 0.69096139268487 + 0.69099322388136 + 0.69102830262647 + 0.69106712201628 + 0.69111019144314 + 0.69115811487055 + 0.69121161683205 + 0.69127161417144 + 0.69133955946801 + 0.69141833691677 + 0.69151197552710 + 0.69162453465302 + 0.69176055793802 + 0.69192587471588 + 0.69212769733195 + 0.69237517901917 + 0.69268006236079 + 0.69305751362862 + 0.69352729002136 + 0.69411556568060 + 0.69485881378290 + 0.69581203583400 + 0.69705452521671 + 0.69869353302959 + 0.70088051743604 + 0.70224722035468 + 0.70384389975814 + 0.70571895615521 + 0.70793471560861 + 0.71057320027700 + 0.71374531331536 + 0.71760625234722 + 0.72238315000594 + 0.72842918093799 + 0.73634626201379 + 0.74738404206359 + 0.76481434451011 + 0.79910786234545 + 1.00000000000000 + 0.78948587772285 + 0.74498537459471 + 0.71699869591006 + 0.69505313734631 + 0.67610487327255 + 0.65891902041329 + 0.64287727227275 + 0.62758226170141 + 0.61281983660105 + 0.59845684001232 + 0.58441337903016 + 0.57064649218416 + 0.55713889161584 + 0.54387004176392 + 0.53082400040698 + 0.51800353879391 + 0.50540599701662 + 0.49301799803312 + 0.68192727404110 + 0.68192727976738 + 0.68192728071612 + 0.68192728182174 + 0.68192728311008 + 0.68192728461252 + 0.68192728636366 + 0.68192728840481 + 0.68192729078707 + 0.68192729357795 + 0.68192729689487 + 0.68192730093178 + 0.68192730592346 + 0.68192731212804 + 0.68192731984626 + 0.68192732944739 + 0.68192734138815 + 0.68192735623245 + 0.68192737471522 + 0.68192739779371 + 0.68192742661627 + 0.68192746262056 + 0.68192750760543 + 0.68192756382122 + 0.68192763412488 + 0.68192772237362 + 0.68192783423321 + 0.68192797730096 + 0.68192816075912 + 0.68192839596591 + 0.68192869862934 + 0.68192908856411 + 0.68192959100404 + 0.68193023841913 + 0.68193107254225 + 0.68193214695832 + 0.68193353038226 + 0.68193531081274 + 0.68193760499390 + 0.68194056855427 + 0.68194439845048 + 0.68194934989536 + 0.68195575140450 + 0.68196399557207 + 0.68197435561233 + 0.68198684449494 + 0.68200163255812 + 0.68201885060873 + 0.68203810444542 + 0.68205911284152 + 0.68208196561424 + 0.68210686125145 + 0.68213404243107 + 0.68216379442529 + 0.68219651302424 + 0.68223263694492 + 0.68227261373907 + 0.68231697172764 + 0.68236634225707 + 0.68242152388058 + 0.68248379750157 + 0.68255574826647 + 0.68264098306728 + 0.68274308698907 + 0.68286603264458 + 0.68301489959274 + 0.68319593801619 + 0.68341704481323 + 0.68368830711467 + 0.68402269379663 + 0.68443701735059 + 0.68495344062558 + 0.68560274143896 + 0.68643127977827 + 0.68750542781245 + 0.68891364695934 + 0.69077871051852 + 0.69193657268204 + 0.69328198758463 + 0.69485203409452 + 0.69669349071670 + 0.69886639422363 + 0.70144943071355 + 0.70454845501447 + 0.70831067566394 + 0.71294999015598 + 0.71879955255195 + 0.72649055671690 + 0.73748251611578 + 0.75500033186000 + 0.78948587772285 + 1.00000000000000 + 0.77970187165303 + 0.73482218164786 + 0.70647212416276 + 0.68415998732524 + 0.66489213903294 + 0.64744047715156 + 0.63113420891980 + 0.61561882559746 + 0.60067962044522 + 0.58618611173608 + 0.57206248638769 + 0.55826934011746 + 0.54477048658371 + 0.53153880850936 + 0.51856900298946 + 0.50585211191519 + 0.49336960562584 + 0.67266998815965 + 0.67266999347891 + 0.67266999436013 + 0.67266999538730 + 0.67266999658440 + 0.67266999797992 + 0.67266999960642 + 0.67267000150287 + 0.67267000371554 + 0.67267000630849 + 0.67267000939037 + 0.67267001314236 + 0.67267001778561 + 0.67267002356061 + 0.67267003074953 + 0.67267003969752 + 0.67267005083199 + 0.67267006468215 + 0.67267008193640 + 0.67267010349282 + 0.67267013042973 + 0.67267016409539 + 0.67267020617761 + 0.67267025879124 + 0.67267032461872 + 0.67267040728619 + 0.67267051211971 + 0.67267064627068 + 0.67267081837807 + 0.67267103912807 + 0.67267132331177 + 0.67267168958424 + 0.67267216170312 + 0.67267277024416 + 0.67267355450482 + 0.67267456493998 + 0.67267586624225 + 0.67267754125070 + 0.67267969985263 + 0.67268248851806 + 0.67268609254555 + 0.67269075193836 + 0.67269677547448 + 0.67270453180930 + 0.67271427615667 + 0.67272601742518 + 0.67273991202070 + 0.67275607793145 + 0.67277413764941 + 0.67279381964773 + 0.67281520058045 + 0.67283845750448 + 0.67286380665432 + 0.67289150133209 + 0.67292189469904 + 0.67295537537509 + 0.67299233463844 + 0.67303323238789 + 0.67307861612496 + 0.67312917825272 + 0.67318604418583 + 0.67325152322455 + 0.67332883308578 + 0.67342112818500 + 0.67353186802032 + 0.67366546119941 + 0.67382730215835 + 0.67402417643319 + 0.67426471484612 + 0.67455996502041 + 0.67492418253705 + 0.67537607367885 + 0.67594154248494 + 0.67665959290928 + 0.67758572892161 + 0.67879294588764 + 0.68038102272941 + 0.68136118530165 + 0.68249480835772 + 0.68381063163702 + 0.68534431396201 + 0.68714071067686 + 0.68925718558638 + 0.69176859361191 + 0.69477509244579 + 0.69841511504814 + 0.70289096284326 + 0.70856789508997 + 0.71624764970774 + 0.72734755998186 + 0.74498537459471 + 0.77970187165303 + 1.00000000000000 + 0.76977319957386 + 0.72451416435441 + 0.69577506335614 + 0.67309877125764 + 0.65352723882948 + 0.63577969171606 + 0.61922980467612 + 0.60351946359251 + 0.58843513103223 + 0.57384979614160 + 0.55969097632205 + 0.54589989578263 + 0.53243374288037 + 0.51927611788160 + 0.50640959597455 + 0.49380885749007 + 0.66299428659111 + 0.66299429151406 + 0.66299429232939 + 0.66299429328009 + 0.66299429438822 + 0.66299429567979 + 0.66299429718514 + 0.66299429894006 + 0.66299430098827 + 0.66299430338800 + 0.66299430624095 + 0.66299430971667 + 0.66299431401971 + 0.66299431937436 + 0.66299432604448 + 0.66299433435108 + 0.66299434469392 + 0.66299435756559 + 0.66299437360971 + 0.66299439366443 + 0.66299441873664 + 0.66299445008811 + 0.66299448929569 + 0.66299453833707 + 0.66299459972119 + 0.66299467684206 + 0.66299477468797 + 0.66299489995772 + 0.66299506074417 + 0.66299526706489 + 0.66299553278095 + 0.66299587538233 + 0.66299631714521 + 0.66299688673727 + 0.66299762100377 + 0.66299856725146 + 0.66299978612840 + 0.66300135528047 + 0.66300337770098 + 0.66300599065865 + 0.66300936773079 + 0.66301373365339 + 0.66301937740953 + 0.66302664367443 + 0.66303576980954 + 0.66304676107069 + 0.66305976037637 + 0.66307487351761 + 0.66309174075278 + 0.66311010140272 + 0.66313002017470 + 0.66315165420730 + 0.66317519523355 + 0.66320086709868 + 0.66322898358656 + 0.66325988744177 + 0.66329391906249 + 0.66333147685553 + 0.66337303335919 + 0.66341918630649 + 0.66347092103200 + 0.66353029365131 + 0.66360016495289 + 0.66368330050380 + 0.66378270146826 + 0.66390217961281 + 0.66404637280262 + 0.66422108918210 + 0.66443368559172 + 0.66469353857186 + 0.66501269377480 + 0.66540689032543 + 0.66589787295721 + 0.66651839283177 + 0.66731481014716 + 0.66834735426378 + 0.66969725311345 + 0.67052605327543 + 0.67148068390210 + 0.67258362092527 + 0.67386237152537 + 0.67535097725568 + 0.67709212718084 + 0.67914021228736 + 0.68156588897099 + 0.68446324457225 + 0.68796372582906 + 0.69229998937957 + 0.69797596755303 + 0.70576116722599 + 0.71699869591006 + 0.73482218164786 + 0.76977319957386 + 1.00000000000000 + 0.75971675733297 + 0.71406596610915 + 0.68491958484324 + 0.66188680718655 + 0.64197484717567 + 0.62395216327487 + 0.60718352454192 + 0.59130926882443 + 0.57611823098866 + 0.56148632488566 + 0.54732104817695 + 0.53355693194405 + 0.52016197357721 + 0.50710715219098 + 0.49435806468648 + 0.65293056150325 + 0.65293056604118 + 0.65293056679270 + 0.65293056766928 + 0.65293056869033 + 0.65293056988104 + 0.65293057126839 + 0.65293057288651 + 0.65293057477419 + 0.65293057698647 + 0.65293057961701 + 0.65293058282224 + 0.65293058679399 + 0.65293059173857 + 0.65293059790078 + 0.65293060558051 + 0.65293061514706 + 0.65293062705975 + 0.65293064191523 + 0.65293066049389 + 0.65293068373280 + 0.65293071280414 + 0.65293074917794 + 0.65293079469394 + 0.65293085168996 + 0.65293092332700 + 0.65293101425716 + 0.65293113072659 + 0.65293128028868 + 0.65293147228605 + 0.65293171965769 + 0.65293203872869 + 0.65293245029452 + 0.65293298111543 + 0.65293366559159 + 0.65293454788193 + 0.65293568459870 + 0.65293714820629 + 0.65293903482089 + 0.65294147252805 + 0.65294462322722 + 0.65294869644687 + 0.65295396147230 + 0.65296073915951 + 0.65296924929337 + 0.65297949389777 + 0.65299160292405 + 0.65300567065817 + 0.65302135596387 + 0.65303840997487 + 0.65305688665231 + 0.65307692473831 + 0.65309869342273 + 0.65312238956481 + 0.65314829080400 + 0.65317669811329 + 0.65320790620596 + 0.65324225857134 + 0.65328016117028 + 0.65332212782801 + 0.65336901836611 + 0.65342265769277 + 0.65348558102774 + 0.65356020486239 + 0.65364912348404 + 0.65375562098787 + 0.65388367050274 + 0.65403822586046 + 0.65422553604394 + 0.65445353230743 + 0.65473236021806 + 0.65507522344741 + 0.65550033011568 + 0.65603512988077 + 0.65671829886210 + 0.65759951962993 + 0.65874499636629 + 0.65944494660278 + 0.66024821743372 + 0.66117251058922 + 0.66223924447029 + 0.66347457195864 + 0.66491077123087 + 0.66658819078838 + 0.66855804474498 + 0.67088661863304 + 0.67366356656026 + 0.67704714833165 + 0.68138224354070 + 0.68714565604840 + 0.69505313734631 + 0.70647212416276 + 0.72451416435441 + 0.75971675733297 + 1.00000000000000 + 0.74954887193916 + 0.70348457589314 + 0.67391813966159 + 0.65047966314471 + 0.63024836423911 + 0.61197518499655 + 0.59501823362634 + 0.57901815537840 + 0.56376597408411 + 0.54911667954344 + 0.53497097335512 + 0.52127430064985 + 0.50798139652647 + 0.49504548273874 + 0.64251365367052 + 0.64251365783545 + 0.64251365852540 + 0.64251365932976 + 0.64251366026689 + 0.64251366135938 + 0.64251366263284 + 0.64251366411769 + 0.64251366585020 + 0.64251366788064 + 0.64251367029513 + 0.64251367323875 + 0.64251367688780 + 0.64251368143353 + 0.64251368710259 + 0.64251369417040 + 0.64251370298037 + 0.64251371395575 + 0.64251372764968 + 0.64251374478447 + 0.64251376622719 + 0.64251379306500 + 0.64251382665759 + 0.64251386871245 + 0.64251392139695 + 0.64251398764251 + 0.64251407176727 + 0.64251417957205 + 0.64251431807072 + 0.64251449594097 + 0.64251472520687 + 0.64251502103886 + 0.64251540276243 + 0.64251589525359 + 0.64251653048233 + 0.64251734949273 + 0.64251840489786 + 0.64251976403206 + 0.64252151620229 + 0.64252378040517 + 0.64252670699440 + 0.64253049047187 + 0.64253538067648 + 0.64254167499379 + 0.64254957603701 + 0.64255908301777 + 0.64257031351587 + 0.64258335104596 + 0.64259787368744 + 0.64261364515288 + 0.64263070981688 + 0.64264918955520 + 0.64266923292626 + 0.64269101224158 + 0.64271477213182 + 0.64274077577608 + 0.64276927710657 + 0.64280057088606 + 0.64283500430636 + 0.64287301725994 + 0.64291535767878 + 0.64296364035585 + 0.64302010505109 + 0.64308685659963 + 0.64316613015757 + 0.64326074600837 + 0.64337409663112 + 0.64351039345956 + 0.64367492753696 + 0.64387438691439 + 0.64411729175701 + 0.64441468901574 + 0.64478179100293 + 0.64524156511439 + 0.64582624088965 + 0.64657678757057 + 0.64754721300422 + 0.64813762021019 + 0.64881294898229 + 0.64958722170294 + 0.65047724335329 + 0.65150330603162 + 0.65269012862001 + 0.65406813487865 + 0.65567523232917 + 0.65755940246191 + 0.65978400474791 + 0.66246170620520 + 0.66584168744405 + 0.67024478894840 + 0.67610487327255 + 0.68415998732524 + 0.69577506335614 + 0.71406596610915 + 0.74954887193916 + 1.00000000000000 + 0.73928517205374 + 0.69277461316154 + 0.66271019045791 + 0.63888779571163 + 0.61836247214297 + 0.59986887807268 + 0.58276134493502 + 0.56668133005743 + 0.55139764503031 + 0.53675833377886 + 0.52267513089789 + 0.50907938681978 + 0.49590708669836 + 0.63178176403541 + 0.63178176783957 + 0.63178176847000 + 0.63178176920471 + 0.63178177006061 + 0.63178177105885 + 0.63178177222230 + 0.63178177357857 + 0.63178177516105 + 0.63178177701560 + 0.63178177922185 + 0.63178178191252 + 0.63178178524974 + 0.63178178940978 + 0.63178179459998 + 0.63178180107541 + 0.63178180914949 + 0.63178181921410 + 0.63178183177807 + 0.63178184750664 + 0.63178186719996 + 0.63178189185970 + 0.63178192274071 + 0.63178196141698 + 0.63178200989083 + 0.63178207086687 + 0.63178214833674 + 0.63178224766246 + 0.63178237532574 + 0.63178253935483 + 0.63178275086806 + 0.63178302390412 + 0.63178337634259 + 0.63178383120096 + 0.63178441806389 + 0.63178517491269 + 0.63178615042572 + 0.63178740689671 + 0.63178902694620 + 0.63179112064501 + 0.63179382701495 + 0.63179732583013 + 0.63180184787840 + 0.63180766760017 + 0.63181497095749 + 0.63182375475940 + 0.63183412486735 + 0.63184615478884 + 0.63185954219515 + 0.63187406394242 + 0.63188975593452 + 0.63190672466668 + 0.63192509994243 + 0.63194503185990 + 0.63196673507613 + 0.63199043875061 + 0.63201636062647 + 0.63204475247412 + 0.63207590989715 + 0.63211020799350 + 0.63214829538214 + 0.63219159673856 + 0.63224208489527 + 0.63230158775617 + 0.63237202509269 + 0.63245581153669 + 0.63255583495015 + 0.63267566486707 + 0.63281976809912 + 0.63299376836467 + 0.63320480155880 + 0.63346208735214 + 0.63377830872629 + 0.63417265283208 + 0.63467194895132 + 0.63530996851107 + 0.63613079952571 + 0.63662819578864 + 0.63719543769579 + 0.63784368637500 + 0.63858621056276 + 0.63943888392413 + 0.64042083461226 + 0.64155530808192 + 0.64287083601590 + 0.64440289564727 + 0.64619749363047 + 0.64833752137422 + 0.65100967447950 + 0.65444180407160 + 0.65891902041329 + 0.66489213903294 + 0.67309877125764 + 0.68491958484324 + 0.70348457589314 + 0.73928517205374 + 1.00000000000000 + 0.72893099753752 + 0.68184313441311 + 0.65130092854279 + 0.62712261300876 + 0.60633393620603 + 0.58765744189770 + 0.57044557044799 + 0.55431568962161 + 0.53902946756463 + 0.52444611935711 + 0.51046219202168 + 0.49698900951510 + 0.62077382511600 + 0.62077382857390 + 0.62077382914665 + 0.62077382981458 + 0.62077383059291 + 0.62077383149975 + 0.62077383255729 + 0.62077383378996 + 0.62077383522860 + 0.62077383691426 + 0.62077383892024 + 0.62077384136757 + 0.62077384440460 + 0.62077384819256 + 0.62077385292131 + 0.62077385882372 + 0.62077386618838 + 0.62077387537340 + 0.62077388684487 + 0.62077390121308 + 0.62077391921220 + 0.62077394176141 + 0.62077397001229 + 0.62077400541207 + 0.62077404979696 + 0.62077410565558 + 0.62077417665819 + 0.62077426773791 + 0.62077438486146 + 0.62077453541525 + 0.62077472964238 + 0.62077498046850 + 0.62077530436376 + 0.62077572253120 + 0.62077626222542 + 0.62077695843622 + 0.62077785600680 + 0.62077901231578 + 0.62078050345639 + 0.62078243080467 + 0.62078492234416 + 0.62078814351266 + 0.62079230658490 + 0.62079766372597 + 0.62080438487344 + 0.62081246481988 + 0.62082199840534 + 0.62083304990763 + 0.62084533673808 + 0.62085864926060 + 0.62087301596016 + 0.62088852938923 + 0.62090530239040 + 0.62092346506635 + 0.62094320498401 + 0.62096472082655 + 0.62098819838099 + 0.62101385166682 + 0.62104193121698 + 0.62107275558301 + 0.62110688555288 + 0.62114557437404 + 0.62119055463105 + 0.62124340908033 + 0.62130578161742 + 0.62137973348181 + 0.62146771573475 + 0.62157274506063 + 0.62169858176281 + 0.62184994165820 + 0.62203278564748 + 0.62225478979649 + 0.62252650662581 + 0.62286394024684 + 0.62328939969331 + 0.62383070796543 + 0.62452386750480 + 0.62494234336170 + 0.62541828141016 + 0.62596059942118 + 0.62657982755233 + 0.62728846561411 + 0.62810144137563 + 0.62903670705600 + 0.63011602915353 + 0.63136608777781 + 0.63282100773893 + 0.63454329569159 + 0.63667645397143 + 0.63938848603922 + 0.64287727227275 + 0.64744047715156 + 0.65352723882948 + 0.66188680718655 + 0.67391813966159 + 0.69277461316154 + 0.72893099753752 + 1.00000000000000 + 0.71832788467362 + 0.67068737680181 + 0.63969956202839 + 0.61519869359378 + 0.59418427196724 + 0.57537129615599 + 0.55808526745901 + 0.54193619376653 + 0.52669708449425 + 0.51221050886033 + 0.49835132320236 + 0.60949515556263 + 0.60949515868882 + 0.60949515920652 + 0.60949515981012 + 0.60949516051368 + 0.60949516133390 + 0.60949516228959 + 0.60949516340391 + 0.60949516470448 + 0.60949516622833 + 0.60949516804199 + 0.60949517025595 + 0.60949517300438 + 0.60949517643458 + 0.60949518071968 + 0.60949518607181 + 0.60949519275285 + 0.60949520108978 + 0.60949521150749 + 0.60949522456296 + 0.60949524092693 + 0.60949526143786 + 0.60949528714867 + 0.60949531937847 + 0.60949535980844 + 0.60949541071408 + 0.60949547545342 + 0.60949555854322 + 0.60949566544870 + 0.60949580293411 + 0.60949598038559 + 0.60949620965129 + 0.60949650582853 + 0.60949688835527 + 0.60949738222117 + 0.60949801950643 + 0.60949884132514 + 0.60949990027899 + 0.60950126612759 + 0.60950303179940 + 0.60950531457199 + 0.60950826598474 + 0.60951208038493 + 0.60951698840216 + 0.60952314460535 + 0.60953054213169 + 0.60953926548364 + 0.60954937045587 + 0.60956059420216 + 0.60957274081841 + 0.60958583232339 + 0.60959994866079 + 0.60961518736499 + 0.60963166057424 + 0.60964953140078 + 0.60966897125726 + 0.60969013776346 + 0.60971321183503 + 0.60973840466990 + 0.60976598552234 + 0.60979643749567 + 0.60983085926693 + 0.60987076719329 + 0.60991752705286 + 0.60997254149090 + 0.61003756394773 + 0.61011466746436 + 0.61020639268102 + 0.61031589436293 + 0.61044711381837 + 0.61060501434539 + 0.61079596725533 + 0.61102872856824 + 0.61131661738384 + 0.61167814949464 + 0.61213621458410 + 0.61272019158345 + 0.61307153180048 + 0.61347010963942 + 0.61392306600995 + 0.61443878473852 + 0.61502715306687 + 0.61569989063166 + 0.61647097024732 + 0.61735716430744 + 0.61837879402876 + 0.61956157978690 + 0.62095351265231 + 0.62266687668222 + 0.62482887749449 + 0.62758226170141 + 0.63113420891980 + 0.63577969171606 + 0.64197484717567 + 0.65047966314471 + 0.66271019045791 + 0.68184313441311 + 0.71832788467362 + 1.00000000000000 + 0.70760150975841 + 0.65938174705251 + 0.62796388960835 + 0.60316667237947 + 0.58196481519484 + 0.56303944483891 + 0.54570759982256 + 0.52959037077023 + 0.51444184764708 + 0.50008052063561 + 0.59798341422709 + 0.59798341703679 + 0.59798341750216 + 0.59798341804429 + 0.59798341867678 + 0.59798341941389 + 0.59798342027288 + 0.59798342127449 + 0.59798342244321 + 0.59798342381310 + 0.59798342544353 + 0.59798342743469 + 0.59798342990796 + 0.59798343299675 + 0.59798343685778 + 0.59798344168274 + 0.59798344770995 + 0.59798345523453 + 0.59798346464314 + 0.59798347644067 + 0.59798349123558 + 0.59798350978998 + 0.59798353306063 + 0.59798356224701 + 0.59798359887672 + 0.59798364501980 + 0.59798370373350 + 0.59798377913395 + 0.59798387619929 + 0.59798400109539 + 0.59798416238092 + 0.59798437086052 + 0.59798464030759 + 0.59798498845363 + 0.59798543810223 + 0.59798601852459 + 0.59798676723594 + 0.59798773223113 + 0.59798897715959 + 0.59799058680790 + 0.59799266814125 + 0.59799535932661 + 0.59799883746702 + 0.59800331253178 + 0.59800892444203 + 0.59801566501230 + 0.59802360911842 + 0.59803280480389 + 0.59804300875982 + 0.59805403885160 + 0.59806591151558 + 0.59807869535130 + 0.59809247414009 + 0.59810734395408 + 0.59812344592913 + 0.59814092716670 + 0.59815992055621 + 0.59818057810347 + 0.59820307680673 + 0.59822764306528 + 0.59825469145486 + 0.59828518166027 + 0.59832043598555 + 0.59836162865751 + 0.59840995189776 + 0.59846689172221 + 0.59853419482351 + 0.59861399287909 + 0.59870892279855 + 0.59882226652259 + 0.59895814186814 + 0.59912181893803 + 0.59932054039689 + 0.59956536143552 + 0.59987161402864 + 0.60025809182285 + 0.60074873470901 + 0.60104296016078 + 0.60137596048384 + 0.60175345931336 + 0.60218214386413 + 0.60266985724481 + 0.60322583811492 + 0.60386102268229 + 0.60458843042772 + 0.60542368730525 + 0.60638641535674 + 0.60751395423371 + 0.60889528062648 + 0.61062858875417 + 0.61281983660105 + 0.61561882559746 + 0.61922980467612 + 0.62395216327487 + 0.63024836423911 + 0.63888779571163 + 0.65130092854279 + 0.67068737680181 + 0.70760150975841 + 1.00000000000000 + 0.69675781668320 + 0.64794122899301 + 0.61611319529101 + 0.59105264067929 + 0.56968246505704 + 0.55067242462171 + 0.53334971637253 + 0.51731303489430 + 0.50228899214410 + 0.58627947342740 + 0.58627947593755 + 0.58627947635336 + 0.58627947683794 + 0.58627947740290 + 0.58627947806144 + 0.58627947882871 + 0.58627947972328 + 0.58627948076743 + 0.58627948199135 + 0.58627948344828 + 0.58627948522788 + 0.58627948744057 + 0.58627949020596 + 0.58627949366461 + 0.58627949798922 + 0.58627950339481 + 0.58627951014756 + 0.58627951859619 + 0.58627952919611 + 0.58627954249674 + 0.58627955918674 + 0.58627958013057 + 0.58627960641284 + 0.58627963941613 + 0.58627968101272 + 0.58627973397227 + 0.58627980202413 + 0.58627988968213 + 0.58628000253834 + 0.58628014835637 + 0.58628033694134 + 0.58628058079626 + 0.58628089602092 + 0.58628130331733 + 0.58628182926912 + 0.58628250794422 + 0.58628338292706 + 0.58628451201566 + 0.58628597220885 + 0.58628786061247 + 0.58629030261929 + 0.58629345888324 + 0.58629751967930 + 0.58630261108399 + 0.58630872388622 + 0.58631592404959 + 0.58632425258926 + 0.58633348532096 + 0.58634345374794 + 0.58635416952658 + 0.58636569109778 + 0.58637808995675 + 0.58639144787605 + 0.58640588631182 + 0.58642153079479 + 0.58643849258971 + 0.58645689854333 + 0.58647689602262 + 0.58649867429772 + 0.58652258763933 + 0.58654947110453 + 0.58658047335502 + 0.58661659993604 + 0.58665885998105 + 0.58670850767974 + 0.58676700859003 + 0.58683614376302 + 0.58691810806368 + 0.58701562302998 + 0.58713209097738 + 0.58727185366648 + 0.58744087988412 + 0.58764831641838 + 0.58790682202127 + 0.58823178551010 + 0.58864266997286 + 0.58888830223790 + 0.58916568919374 + 0.58947941677841 + 0.58983482065597 + 0.59023812958268 + 0.59069664206176 + 0.59121894614118 + 0.59181519627767 + 0.59249748609162 + 0.59328091340468 + 0.59419480328721 + 0.59531027536033 + 0.59670418116529 + 0.59845684001232 + 0.60067962044522 + 0.60351946359251 + 0.60718352454192 + 0.61197518499655 + 0.61836247214297 + 0.62712261300876 + 0.63969956202839 + 0.65938174705251 + 0.69675781668320 + 1.00000000000000 + 0.68580389491748 + 0.63638242870044 + 0.60416924711332 + 0.57885523882447 + 0.55734190517548 + 0.53830641181684 + 0.52104789821730 + 0.50513253305445 + 0.57442778429691 + 0.57442778652554 + 0.57442778689469 + 0.57442778732490 + 0.57442778782658 + 0.57442778841115 + 0.57442778909237 + 0.57442778988653 + 0.57442779081381 + 0.57442779190044 + 0.57442779319426 + 0.57442779477577 + 0.57442779674318 + 0.57442779920348 + 0.57442780228269 + 0.57442780613609 + 0.57442781095519 + 0.57442781697939 + 0.57442782452119 + 0.57442783398949 + 0.57442784587798 + 0.57442786080566 + 0.57442787954803 + 0.57442790308164 + 0.57442793265039 + 0.57442796993875 + 0.57442801744372 + 0.57442807852768 + 0.57442815726261 + 0.57442825869205 + 0.57442838982512 + 0.57442855951872 + 0.57442877906409 + 0.57442906300749 + 0.57442943005806 + 0.57442990423964 + 0.57443051634760 + 0.57443130577257 + 0.57443232476251 + 0.57443364292020 + 0.57443534800038 + 0.57443755329084 + 0.57444040386972 + 0.57444407140136 + 0.57444866896304 + 0.57445418659084 + 0.57446068204705 + 0.57446819002235 + 0.57447650485493 + 0.57448547138821 + 0.57449509722319 + 0.57450543176475 + 0.57451653557888 + 0.57452847777606 + 0.57454136228330 + 0.57455529556682 + 0.57457037006776 + 0.57458669083699 + 0.57460437966301 + 0.57462359375219 + 0.57464463446165 + 0.57466822548816 + 0.57469536061917 + 0.57472689729840 + 0.57476368577153 + 0.57480677976017 + 0.57485740320668 + 0.57491703721226 + 0.57498750006767 + 0.57507103789273 + 0.57517044848213 + 0.57528929203696 + 0.57543246608136 + 0.57560750951605 + 0.57582483658121 + 0.57609700373316 + 0.57643978276642 + 0.57664408781271 + 0.57687431480169 + 0.57713413153651 + 0.57742778997690 + 0.57776023385362 + 0.57813722998625 + 0.57856552993697 + 0.57905307126944 + 0.57960924730115 + 0.58024573539962 + 0.58098570427410 + 0.58188630978510 + 0.58300826672051 + 0.58441337903016 + 0.58618611173608 + 0.58843513103223 + 0.59130926882443 + 0.59501823362634 + 0.59986887807268 + 0.60633393620603 + 0.61519869359378 + 0.62796388960835 + 0.64794122899301 + 0.68580389491748 + 1.00000000000000 + 0.67474867539224 + 0.62472337956120 + 0.59211856614890 + 0.56656984063805 + 0.54497678381617 + 0.52597850236381 + 0.50883370363164 + 0.56247622387791 + 0.56247622584359 + 0.56247622616941 + 0.56247622654906 + 0.56247622699163 + 0.56247622750745 + 0.56247622810858 + 0.56247622880932 + 0.56247622962736 + 0.56247623058609 + 0.56247623172786 + 0.56247623312433 + 0.56247623486281 + 0.56247623703831 + 0.56247623976336 + 0.56247624317550 + 0.56247624744633 + 0.56247625278838 + 0.56247625948104 + 0.56247626788966 + 0.56247627845441 + 0.56247629172860 + 0.56247630840650 + 0.56247632936034 + 0.56247635570378 + 0.56247638894683 + 0.56247643132622 + 0.56247648585929 + 0.56247655620008 + 0.56247664687813 + 0.56247676418994 + 0.56247691609633 + 0.56247711274680 + 0.56247736722393 + 0.56247769635487 + 0.56247812175430 + 0.56247867113026 + 0.56247937992735 + 0.56248029516416 + 0.56248147948385 + 0.56248301184890 + 0.56248499416957 + 0.56248755690260 + 0.56249085427018 + 0.56249498724132 + 0.56249994533545 + 0.56250577883579 + 0.56251251677437 + 0.56251997124973 + 0.56252799999322 + 0.56253660720606 + 0.56254583429789 + 0.56255573218673 + 0.56256635883182 + 0.56257780263080 + 0.56259015329093 + 0.56260348695682 + 0.56261788988572 + 0.56263346189282 + 0.56265033261662 + 0.56266875716152 + 0.56268936013053 + 0.56271299776608 + 0.56274039794563 + 0.56277227350295 + 0.56280950537278 + 0.56285311048205 + 0.56290431407572 + 0.56296461452929 + 0.56303585567387 + 0.56312032574584 + 0.56322092835286 + 0.56334166172547 + 0.56348871190225 + 0.56367061025139 + 0.56389755766492 + 0.56418228039288 + 0.56435148546096 + 0.56454176432524 + 0.56475604109566 + 0.56499769468250 + 0.56527063986907 + 0.56557942543165 + 0.56592935382898 + 0.56632662876332 + 0.56677855258439 + 0.56729417688290 + 0.56789186404178 + 0.56861768006858 + 0.56951987476451 + 0.57064649218416 + 0.57206248638769 + 0.57384979614160 + 0.57611823098866 + 0.57901815537840 + 0.58276134493502 + 0.58765744189770 + 0.59418427196724 + 0.60316667237947 + 0.61611319529101 + 0.63638242870044 + 0.67474867539224 + 1.00000000000000 + 0.66360331827048 + 0.61293211397126 + 0.57994155598837 + 0.55422490587973 + 0.53262361972735 + 0.51372320841372 + 0.55047508887407 + 0.55047509059805 + 0.55047509088352 + 0.55047509121638 + 0.55047509160450 + 0.55047509205663 + 0.55047509258374 + 0.55047509319819 + 0.55047509391533 + 0.55047509475607 + 0.55047509575763 + 0.55047509698307 + 0.55047509851005 + 0.55047510042204 + 0.55047510281936 + 0.55047510582315 + 0.55047510958634 + 0.55047511429667 + 0.55047512020253 + 0.55047512762763 + 0.55047513696346 + 0.55047514870236 + 0.55047516346136 + 0.55047518201736 + 0.55047520536167 + 0.55047523483990 + 0.55047527244856 + 0.55047532088146 + 0.55047538340288 + 0.55047546406131 + 0.55047556848734 + 0.55047570380345 + 0.55047587909482 + 0.55047610607326 + 0.55047639981288 + 0.55047677967511 + 0.55047727048517 + 0.55047790400587 + 0.55047872237695 + 0.55047978175069 + 0.55048115289286 + 0.55048292712002 + 0.55048522128835 + 0.55048817340792 + 0.55049187328176 + 0.55049631011180 + 0.55050152741376 + 0.55050754921272 + 0.55051420444996 + 0.55052136317135 + 0.55052902676617 + 0.55053722963098 + 0.55054601421902 + 0.55055542874923 + 0.55056554794719 + 0.55057644689231 + 0.55058818770995 + 0.55060084055781 + 0.55061448649502 + 0.55062923158087 + 0.55064529070103 + 0.55066320075971 + 0.55068369649860 + 0.55070739299353 + 0.55073488479979 + 0.55076690458746 + 0.55080429268401 + 0.55084805700079 + 0.55089942521776 + 0.55095990206531 + 0.55103134784320 + 0.55111611643898 + 0.55121745351040 + 0.55134040991189 + 0.55149194116383 + 0.55168029260939 + 0.55191568034271 + 0.55205515880994 + 0.55221168649503 + 0.55238758417667 + 0.55258552572428 + 0.55280859921054 + 0.55306038035574 + 0.55334502142826 + 0.55366735992628 + 0.55403306403965 + 0.55444914684419 + 0.55493017418161 + 0.55551330873034 + 0.55623701797090 + 0.55713889161584 + 0.55826934011746 + 0.55969097632205 + 0.56148632488566 + 0.56376597408411 + 0.56668133005743 + 0.57044557044799 + 0.57537129615599 + 0.58196481519484 + 0.59105264067929 + 0.60416924711332 + 0.62472337956120 + 0.66360331827048 + 1.00000000000000 + 0.65229250472390 + 0.60096412277437 + 0.56765705251662 + 0.54185366757329 + 0.52031889197405 + 0.53845663637773 + 0.53845663788022 + 0.53845663812911 + 0.53845663841909 + 0.53845663875727 + 0.53845663915151 + 0.53845663961071 + 0.53845664014612 + 0.53845664077119 + 0.53845664150403 + 0.53845664237713 + 0.53845664344637 + 0.53845664477928 + 0.53845664645007 + 0.53845664854702 + 0.53845665117652 + 0.53845665447296 + 0.53845665860349 + 0.53845666378567 + 0.53845667030707 + 0.53845667851260 + 0.53845668883849 + 0.53845670183136 + 0.53845671817898 + 0.53845673876016 + 0.53845676476852 + 0.53845679797721 + 0.53845684078158 + 0.53845689608398 + 0.53845696748744 + 0.53845706000718 + 0.53845717998801 + 0.53845733552920 + 0.53845753707348 + 0.53845779806857 + 0.53845813579127 + 0.53845857239710 + 0.53845913624020 + 0.53845986494486 + 0.53846080865797 + 0.53846203056927 + 0.53846361220580 + 0.53846565786436 + 0.53846829062193 + 0.53847159004576 + 0.53847554520561 + 0.53848019354604 + 0.53848555469512 + 0.53849147343716 + 0.53849783147734 + 0.53850462791890 + 0.53851189105757 + 0.53851965598304 + 0.53852796246329 + 0.53853687328250 + 0.53854645083207 + 0.53855674526815 + 0.53856781306174 + 0.53857971936053 + 0.53859255019553 + 0.53860648566518 + 0.53862198548616 + 0.53863967764094 + 0.53866007951575 + 0.53868368435716 + 0.53871109824061 + 0.53874301155414 + 0.53878024846438 + 0.53882380863698 + 0.53887491222862 + 0.53893506167971 + 0.53900615251997 + 0.53909080298562 + 0.53919311459214 + 0.53931872790885 + 0.53947426900364 + 0.53966788926775 + 0.53978227965267 + 0.53991038579044 + 0.54005403896211 + 0.54021534322730 + 0.54039672137559 + 0.54060096981877 + 0.54083132457593 + 0.54109154136965 + 0.54138600310745 + 0.54172012759528 + 0.54210545663049 + 0.54257195030682 + 0.54315030851228 + 0.54387004176392 + 0.54477048658371 + 0.54589989578263 + 0.54732104817695 + 0.54911667954344 + 0.55139764503031 + 0.55431568962161 + 0.55808526745901 + 0.56303944483891 + 0.56968246505704 + 0.57885523882447 + 0.59211856614890 + 0.61293211397126 + 0.65229250472390 + 1.00000000000000 + 0.64079189630860 + 0.58885973447742 + 0.55531415988303 + 0.52950903152148 + 0.52644560121028 + 0.52644560251216 + 0.52644560272799 + 0.52644560297917 + 0.52644560327219 + 0.52644560361368 + 0.52644560401189 + 0.52644560447595 + 0.52644560501739 + 0.52644560565263 + 0.52644560640949 + 0.52644560733692 + 0.52644560849440 + 0.52644560994683 + 0.52644561177063 + 0.52644561406073 + 0.52644561693419 + 0.52644562053672 + 0.52644562506135 + 0.52644563076039 + 0.52644563793797 + 0.52644564697700 + 0.52644565836014 + 0.52644567269404 + 0.52644569075463 + 0.52644571359514 + 0.52644574278579 + 0.52644578044689 + 0.52644582915095 + 0.52644589208968 + 0.52644597371368 + 0.52644607965486 + 0.52644621710510 + 0.52644639534473 + 0.52644662632504 + 0.52644692540897 + 0.52644731230241 + 0.52644781222885 + 0.52644845866958 + 0.52644929625956 + 0.52645038124037 + 0.52645178616716 + 0.52645360383804 + 0.52645594366706 + 0.52645887592644 + 0.52646238971130 + 0.52646651706985 + 0.52647127381579 + 0.52647651952492 + 0.52648214684876 + 0.52648815308204 + 0.52649456126464 + 0.52650140014708 + 0.52650870224139 + 0.52651651998444 + 0.52652490486017 + 0.52653389691342 + 0.52654354107862 + 0.52655388914321 + 0.52656501026819 + 0.52657705468066 + 0.52659041461696 + 0.52660562489521 + 0.52662311885999 + 0.52664330358981 + 0.52666667778833 + 0.52669380540238 + 0.52672535627619 + 0.52676213928498 + 0.52680513731084 + 0.52685555545916 + 0.52691490946370 + 0.52698529758715 + 0.52707003174260 + 0.52717366086867 + 0.52730147675677 + 0.52745994010424 + 0.52755327516730 + 0.52765757774740 + 0.52777428311262 + 0.52790503585637 + 0.52805172427901 + 0.52821652121484 + 0.52840193282124 + 0.52861085744086 + 0.52884666494459 + 0.52911352040750 + 0.52942054736880 + 0.52979185869452 + 0.53025194414785 + 0.53082400040698 + 0.53153880850936 + 0.53243374288037 + 0.53355693194405 + 0.53497097335512 + 0.53675833377886 + 0.53902946756463 + 0.54193619376653 + 0.54570759982256 + 0.55067242462171 + 0.55734190517548 + 0.56656984063805 + 0.57994155598837 + 0.60096412277437 + 0.64079189630860 + 1.00000000000000 + 0.62917404658507 + 0.57667553524870 + 0.54297398019538 + 0.51447595557505 + 0.51447595669786 + 0.51447595688408 + 0.51447595710080 + 0.51447595735374 + 0.51447595764813 + 0.51447595799164 + 0.51447595839194 + 0.51447595885923 + 0.51447595940691 + 0.51447596006030 + 0.51447596086113 + 0.51447596186138 + 0.51447596311797 + 0.51447596469772 + 0.51447596668301 + 0.51447596917679 + 0.51447597230644 + 0.51447597624075 + 0.51447598120071 + 0.51447598745337 + 0.51447599533497 + 0.51447600526959 + 0.51447601779027 + 0.51447603357881 + 0.51447605356525 + 0.51447607913117 + 0.51447611214880 + 0.51447615489075 + 0.51447621017794 + 0.51447628194661 + 0.51447637518029 + 0.51447649624801 + 0.51447665337268 + 0.51447685714570 + 0.51447712119031 + 0.51447746298583 + 0.51447790490968 + 0.51447847668042 + 0.51447921792057 + 0.51448017856330 + 0.51448142301851 + 0.51448303365107 + 0.51448510749491 + 0.51448770646516 + 0.51449081981779 + 0.51449447485935 + 0.51449868415276 + 0.51450332096069 + 0.51450828812899 + 0.51451358157161 + 0.51451921987124 + 0.51452522638915 + 0.51453162748950 + 0.51453846675075 + 0.51454578640100 + 0.51455361804839 + 0.51456199704847 + 0.51457096411215 + 0.51458057436720 + 0.51459095265550 + 0.51460243278557 + 0.51461546903383 + 0.51463042315822 + 0.51464762968475 + 0.51466749716770 + 0.51469048400084 + 0.51471713173435 + 0.51474809119523 + 0.51478414942648 + 0.51482626694780 + 0.51487564791468 + 0.51493396377024 + 0.51500387558171 + 0.51508903392071 + 0.51519364061205 + 0.51532278352112 + 0.51539860794449 + 0.51548315328555 + 0.51557753671558 + 0.51568303484002 + 0.51580110922188 + 0.51593343656291 + 0.51608194454794 + 0.51624885486928 + 0.51643674160456 + 0.51664878830384 + 0.51689218754148 + 0.51718631267945 + 0.51755068314592 + 0.51800353879391 + 0.51856900298946 + 0.51927611788160 + 0.52016197357721 + 0.52127430064985 + 0.52267513089789 + 0.52444611935711 + 0.52669708449425 + 0.52959037077023 + 0.53334971637253 + 0.53830641181684 + 0.54497678381617 + 0.55422490587973 + 0.56765705251662 + 0.58885973447742 + 0.62917404658507 + 1.00000000000000 + 0.61745040000211 + 0.56444294935455 + 0.50257129789460 + 0.50257129885980 + 0.50257129901978 + 0.50257129920600 + 0.50257129942322 + 0.50257129967641 + 0.50257129997155 + 0.50257130031558 + 0.50257130071731 + 0.50257130118815 + 0.50257130174981 + 0.50257130243912 + 0.50257130330117 + 0.50257130438524 + 0.50257130574912 + 0.50257130746502 + 0.50257130962256 + 0.50257131233349 + 0.50257131574455 + 0.50257132004909 + 0.50257132548104 + 0.50257133233502 + 0.50257134098199 + 0.50257135188980 + 0.50257136565769 + 0.50257138310091 + 0.50257140543559 + 0.50257143431222 + 0.50257147173147 + 0.50257152018191 + 0.50257158313806 + 0.50257166500162 + 0.50257177140056 + 0.50257190960482 + 0.50257208898518 + 0.50257232159664 + 0.50257262291608 + 0.50257301275965 + 0.50257351745210 + 0.50257417211233 + 0.50257502098945 + 0.50257612116685 + 0.50257754562622 + 0.50257938029073 + 0.50258167961837 + 0.50258443315116 + 0.50258766408618 + 0.50259138225504 + 0.50259547349966 + 0.50259985008422 + 0.50260450693212 + 0.50260945890171 + 0.50261472484483 + 0.50262032599865 + 0.50262629845456 + 0.50263267669131 + 0.50263948540086 + 0.50264675210419 + 0.50265450848057 + 0.50266279815563 + 0.50267172465136 + 0.50268157169496 + 0.50269272465896 + 0.50270548498349 + 0.50272012682095 + 0.50273698391788 + 0.50275642760080 + 0.50277889403387 + 0.50280490470535 + 0.50283508696761 + 0.50287020259462 + 0.50291120321729 + 0.50295941403547 + 0.50301696553836 + 0.50308677691706 + 0.50317216932013 + 0.50327712800849 + 0.50333854892051 + 0.50340687404136 + 0.50348296762491 + 0.50356781443010 + 0.50366253854395 + 0.50376842550589 + 0.50388694845014 + 0.50401979932866 + 0.50416893168551 + 0.50433676498623 + 0.50452895781408 + 0.50476106002856 + 0.50504862362687 + 0.50540599701662 + 0.50585211191519 + 0.50640959597455 + 0.50710715219098 + 0.50798139652647 + 0.50907938681978 + 0.51046219202168 + 0.51221050886033 + 0.51444184764708 + 0.51731303489430 + 0.52104789821730 + 0.52597850236381 + 0.53262361972735 + 0.54185366757329 + 0.55531415988303 + 0.57667553524870 + 0.61745040000211 + 1.00000000000000 + 0.60563531673619 + 0.49074141488310 + 0.49074141571124 + 0.49074141584835 + 0.49074141600811 + 0.49074141619460 + 0.49074141641182 + 0.49074141666507 + 0.49074141696016 + 0.49074141730464 + 0.49074141770870 + 0.49074141819105 + 0.49074141878314 + 0.49074141952440 + 0.49074142045749 + 0.49074142163341 + 0.49074142311407 + 0.49074142497809 + 0.49074142732251 + 0.49074143027508 + 0.49074143400573 + 0.49074143871785 + 0.49074144466958 + 0.49074145218606 + 0.49074146167614 + 0.49074147366572 + 0.49074148886978 + 0.49074150835840 + 0.49074153358080 + 0.49074156630036 + 0.49074160870901 + 0.49074166386961 + 0.49074173566491 + 0.49074182906376 + 0.49074195048691 + 0.49074210821504 + 0.49074231290505 + 0.49074257824476 + 0.49074292176468 + 0.49074336676379 + 0.49074394433234 + 0.49074469364876 + 0.49074566525533 + 0.49074692376344 + 0.49074854519090 + 0.49075057740711 + 0.49075301034280 + 0.49075586367065 + 0.49075914497680 + 0.49076275159371 + 0.49076660443377 + 0.49077069777267 + 0.49077504340882 + 0.49077965648841 + 0.49078455403305 + 0.49078976589658 + 0.49079532016287 + 0.49080123595170 + 0.49080753450039 + 0.49081424024816 + 0.49082138754795 + 0.49082906223107 + 0.49083750553111 + 0.49084704445347 + 0.49085793019290 + 0.49087038728281 + 0.49088468815474 + 0.49090113324296 + 0.49092007327761 + 0.49094192530085 + 0.49096718820767 + 0.49099646447845 + 0.49103050389096 + 0.49107035448390 + 0.49111771953599 + 0.49117493002142 + 0.49124460446703 + 0.49132985393551 + 0.49137956928521 + 0.49143473812126 + 0.49149602610139 + 0.49156418939597 + 0.49164008844426 + 0.49172470404994 + 0.49181915631381 + 0.49192472711449 + 0.49204289133222 + 0.49217547955651 + 0.49232694129547 + 0.49250976319039 + 0.49273634744749 + 0.49301799803312 + 0.49336960562584 + 0.49380885749007 + 0.49435806468648 + 0.49504548273874 + 0.49590708669836 + 0.49698900951510 + 0.49835132320236 + 0.50008052063561 + 0.50228899214410 + 0.50513253305445 + 0.50883370363164 + 0.51372320841372 + 0.52031889197405 + 0.52950903152148 + 0.54297398019538 + 0.56444294935455 + 0.60563531673619 + 1.00000000000000 + 1.00000000000000 + 0.99981764310624 + 0.99980089491470 + 0.99978338415097 + 0.99976513044803 + 0.99974613942541 + 0.99972639811890 + 0.99970587071924 + 0.99968449255719 + 0.99966215178790 + 0.99963863625723 + 0.99961360653757 + 0.99958670284751 + 0.99955759552284 + 0.99952594953606 + 0.99949140262675 + 0.99945355874971 + 0.99941198658109 + 0.99936619566688 + 0.99931563727132 + 0.99925975960969 + 0.99919798381592 + 0.99912971002340 + 0.99905432151219 + 0.99897117295076 + 0.99887950214681 + 0.99877826647875 + 0.99866634237250 + 0.99854277399635 + 0.99840663588471 + 0.99825668711793 + 0.99809157662338 + 0.99790971545862 + 0.99770914272240 + 0.99748742841706 + 0.99724157408360 + 0.99696791771694 + 0.99666204953624 + 0.99631853886686 + 0.99593086190687 + 0.99549174255368 + 0.99499286047974 + 0.99442481563193 + 0.99377774025322 + 0.99304529736781 + 0.99222479943614 + 0.99130673246762 + 0.99028004917805 + 0.98913954452647 + 0.98787424065422 + 0.98646531499500 + 0.98489131212128 + 0.98312913571318 + 0.98115373596680 + 0.97893624233149 + 0.97644419689310 + 0.97364110859478 + 0.97048450840933 + 0.96692590062899 + 0.96291122084119 + 0.95837867459299 + 0.95325041660921 + 0.94744187934306 + 0.94088098901275 + 0.93350510949296 + 0.92525542304737 + 0.91608421080846 + 0.90595631325223 + 0.89485237801391 + 0.88277327128617 + 0.86974547159775 + 0.85582591526708 + 0.84109868089064 + 0.82565898327992 + 0.80963049211213 + 0.79319310720328 + 0.77655708727286 + 0.76822469121220 + 0.75991652590712 + 0.75165160322280 + 0.74344456721614 + 0.73530500671060 + 0.72723698423004 + 0.71923887849120 + 0.71130367848184 + 0.70341972712240 + 0.69556866256628 + 0.68767289884629 + 0.67950557940440 + 0.67095090402380 + 0.66200007694885 + 0.65264720192452 + 0.64291000817494 + 0.63281181795368 + 0.62238010509073 + 0.61164553639810 + 0.60064154419697 + 0.58940281314246 + 0.57793959431361 + 0.56628796022434 + 0.55448726714102 + 0.54257945074660 + 0.53060745256331 + 0.51861281553956 + 0.50661863747423 + 0.49463683639836 + 0.48268105283562 + 0.47075289767456 + 0.45884148496229 + 0.99981764310624 + 1.00000000000000 + 0.99995010061812 + 0.99990790230441 + 0.99986995335351 + 0.99983498621448 + 0.99980220579837 + 0.99977100556582 + 0.99974087274893 + 0.99971133168214 + 0.99968186714007 + 0.99965188487370 + 0.99962082018807 + 0.99958818377593 + 0.99955351561384 + 0.99951635521057 + 0.99947622910908 + 0.99943264444325 + 0.99938506068889 + 0.99933288821535 + 0.99927554291408 + 0.99921242004291 + 0.99914289941721 + 0.99906634879655 + 0.99898211136757 + 0.99888941632985 + 0.99878721430474 + 0.99867437861730 + 0.99854995436250 + 0.99841301859396 + 0.99826233219419 + 0.99809654598897 + 0.99791407204810 + 0.99771294911635 + 0.99749074542208 + 0.99724445941629 + 0.99697042495634 + 0.99666422738993 + 0.99632043069647 + 0.99593250571449 + 0.99549317138671 + 0.99499410283595 + 0.99442589599087 + 0.99377867972365 + 0.99304611458541 + 0.99222551092885 + 0.99130735235332 + 0.99028058957516 + 0.98914001612002 + 0.98787465269842 + 0.98646567541793 + 0.98489162777261 + 0.98312941256037 + 0.98115397920530 + 0.97893645648516 + 0.97644438589374 + 0.97364127585799 + 0.97048465689734 + 0.96692603289935 + 0.96291133909459 + 0.95837878070031 + 0.95325051212168 + 0.94744196554068 + 0.94088106697349 + 0.93350518013554 + 0.92525548714377 + 0.91608426901472 + 0.90595636611901 + 0.89485242600512 + 0.88277331479532 + 0.86974551096169 + 0.85582595077808 + 0.84109871280816 + 0.82565901184137 + 0.80963051754462 + 0.79319312974458 + 0.77655710717416 + 0.76822470989015 + 0.75991654342839 + 0.75165161965572 + 0.74344458262758 + 0.73530502116731 + 0.72723699779633 + 0.71923889122927 + 0.71130369045156 + 0.70341973837793 + 0.69556867315882 + 0.68767290881804 + 0.67950558877854 + 0.67095091281409 + 0.66200008516877 + 0.65264720958665 + 0.64291001529159 + 0.63281182453959 + 0.62238011116116 + 0.61164554197023 + 0.60064154928918 + 0.58940281777587 + 0.57793959850947 + 0.56628796400576 + 0.55448727053232 + 0.54257945377398 + 0.53060745525440 + 0.51861281792129 + 0.50661863957546 + 0.49463683824710 + 0.48268105445825 + 0.47075289909755 + 0.45884148620969 + 0.99980089491470 + 0.99995010061812 + 1.00000000000000 + 0.99994334349175 + 0.99989694967105 + 0.99985613236650 + 0.99981910619286 + 0.99978475158422 + 0.99975223762075 + 0.99972087479692 + 0.99968999765650 + 0.99965890352215 + 0.99962694960888 + 0.99959359063229 + 0.99955832598461 + 0.99952066552218 + 0.99948011396793 + 0.99943616221005 + 0.99938825730328 + 0.99933580000425 + 0.99927819887823 + 0.99921484351442 + 0.99914510939661 + 0.99906836103213 + 0.99898393922913 + 0.99889107142488 + 0.99878870688401 + 0.99867571825357 + 0.99855115066487 + 0.99841408151508 + 0.99826327191776 + 0.99809737297200 + 0.99791479687383 + 0.99771358228330 + 0.99749129710378 + 0.99724493925653 + 0.99697084189445 + 0.99666458954243 + 0.99632074528483 + 0.99593277906126 + 0.99549340898906 + 0.99499430942920 + 0.99442607564349 + 0.99377883594732 + 0.99304625047519 + 0.99222562923246 + 0.99130745541895 + 0.99028067941647 + 0.98914009451502 + 0.98787472118629 + 0.98646573531715 + 0.98489168022587 + 0.98312945855893 + 0.98115401961499 + 0.97893649205842 + 0.97644441728346 + 0.97364130363422 + 0.97048468155309 + 0.96692605485862 + 0.96291135872495 + 0.95837879831133 + 0.95325052797203 + 0.94744197984518 + 0.94088107990854 + 0.93350519185461 + 0.92525549777520 + 0.91608427866807 + 0.90595637488582 + 0.89485243396331 + 0.88277332200936 + 0.86974551748715 + 0.85582595666442 + 0.84109871809871 + 0.82565901657529 + 0.80963052175939 + 0.79319313348013 + 0.77655711047225 + 0.76822471298503 + 0.75991654633126 + 0.75165162237839 + 0.74344458518112 + 0.73530502356246 + 0.72723700004387 + 0.71923889334005 + 0.71130369243414 + 0.70341974024259 + 0.69556867491407 + 0.68767291047019 + 0.67950559033133 + 0.67095091427029 + 0.66200008653058 + 0.65264721085585 + 0.64291001647089 + 0.63281182563068 + 0.62238011216678 + 0.61164554289335 + 0.60064155013261 + 0.58940281854329 + 0.57793959920441 + 0.56628796463223 + 0.55448727109415 + 0.54257945427577 + 0.53060745569987 + 0.51861281831587 + 0.50661863992350 + 0.49463683855314 + 0.48268105472714 + 0.47075289933340 + 0.45884148641622 + 0.99978338415097 + 0.99990790230441 + 0.99994334349175 + 1.00000000000000 + 0.99993583345757 + 0.99988508970878 + 0.99984143921823 + 0.99980242775747 + 0.99976654299527 + 0.99973268673305 + 0.99969992908906 + 0.99966738875331 + 0.99963430064118 + 0.99960003508485 + 0.99956403225474 + 0.99952575991543 + 0.99948469259346 + 0.99944029918331 + 0.99939201029076 + 0.99933921415945 + 0.99928130994397 + 0.99921768003648 + 0.99914769446160 + 0.99907071366044 + 0.99898607547973 + 0.99889300516695 + 0.99879045031246 + 0.99867728270900 + 0.99855254749338 + 0.99841532242381 + 0.99826436887281 + 0.99809833822847 + 0.99791564282839 + 0.99771432121609 + 0.99749194091311 + 0.99724549921146 + 0.99697132843488 + 0.99666501214890 + 0.99632111238614 + 0.99593309803639 + 0.99549368625060 + 0.99499455050908 + 0.99442628528561 + 0.99377901824732 + 0.99304640904626 + 0.99222576728087 + 0.99130757568186 + 0.99028078424703 + 0.98914018598646 + 0.98787480109601 + 0.98646580520443 + 0.98489174142129 + 0.98312951222235 + 0.98115406675500 + 0.97893653355409 + 0.97644445389871 + 0.97364133603260 + 0.97048471031027 + 0.96692608047191 + 0.96291138161952 + 0.95837881885117 + 0.95325054645753 + 0.94744199652388 + 0.94088109499188 + 0.93350520551890 + 0.92525551017263 + 0.91608428992359 + 0.90595638510692 + 0.89485244324061 + 0.88277333041928 + 0.86974552509483 + 0.85582596352640 + 0.84109872426588 + 0.82565902209292 + 0.80963052667258 + 0.79319313783387 + 0.77655711431561 + 0.76822471659263 + 0.75991654971502 + 0.75165162555171 + 0.74344458815742 + 0.73530502635417 + 0.72723700266378 + 0.71923889579994 + 0.71130369474597 + 0.70341974241648 + 0.69556867695970 + 0.68767291239580 + 0.67950559214143 + 0.67095091596767 + 0.66200008811789 + 0.65264721233533 + 0.64291001784500 + 0.63281182690229 + 0.62238011333914 + 0.61164554396930 + 0.60064155111586 + 0.58940281943787 + 0.57793960001448 + 0.56628796536238 + 0.55448727174903 + 0.54257945486021 + 0.53060745621949 + 0.51861281877547 + 0.50661864032919 + 0.49463683891014 + 0.48268105504042 + 0.47075289960817 + 0.45884148665725 + 0.99976513044803 + 0.99986995335351 + 0.99989694967105 + 0.99993583345757 + 1.00000000000000 + 0.99992752433971 + 0.99987232162349 + 0.99982590164237 + 0.99978497392780 + 0.99974755720898 + 0.99971221214649 + 0.99967774128405 + 0.99964317654032 + 0.99960775496393 + 0.99957082687106 + 0.99953179829978 + 0.99949010077597 + 0.99944517270973 + 0.99939642245988 + 0.99934322170549 + 0.99928495732571 + 0.99922100244784 + 0.99915072014564 + 0.99907346572384 + 0.99898857330008 + 0.99889526538378 + 0.99879248748556 + 0.99867911031198 + 0.99855417894550 + 0.99841677152570 + 0.99826564968973 + 0.99809946514536 + 0.99791663037358 + 0.99771518376636 + 0.99749269238772 + 0.99724615278654 + 0.99697189631007 + 0.99666550539547 + 0.99632154084748 + 0.99593347032835 + 0.99549400986008 + 0.99499483188565 + 0.99442652997125 + 0.99377923101906 + 0.99304659412063 + 0.99222592839914 + 0.99130771603866 + 0.99028090658932 + 0.98914029273412 + 0.98787489434679 + 0.98646588675615 + 0.98489181282925 + 0.98312957483559 + 0.98115412175639 + 0.97893658196665 + 0.97644449661639 + 0.97364137382895 + 0.97048474385643 + 0.96692611034874 + 0.96291140832339 + 0.95837884280724 + 0.95325056801700 + 0.94744201597662 + 0.94088111258236 + 0.93350522145462 + 0.92525552462899 + 0.91608430304815 + 0.90595639702568 + 0.89485245405785 + 0.88277334022402 + 0.86974553396439 + 0.85582597152639 + 0.84109873145488 + 0.82565902852610 + 0.80963053239985 + 0.79319314290937 + 0.77655711879650 + 0.76822472079739 + 0.75991655365979 + 0.75165162925144 + 0.74344459162688 + 0.73530502960890 + 0.72723700571797 + 0.71923889866689 + 0.71130369743960 + 0.70341974494966 + 0.69556867934374 + 0.68767291464018 + 0.67950559425115 + 0.67095091794635 + 0.66200008996778 + 0.65264721405948 + 0.64291001944662 + 0.63281182838490 + 0.62238011470499 + 0.61164554522320 + 0.60064155226215 + 0.58940282048090 + 0.57793960095898 + 0.56628796621340 + 0.55448727251206 + 0.54257945554155 + 0.53060745682497 + 0.51861281931198 + 0.50661864080189 + 0.49463683932630 + 0.48268105540569 + 0.47075289992836 + 0.45884148693801 + 0.99974613942541 + 0.99983498621448 + 0.99985613236650 + 0.99988508970878 + 0.99992752433971 + 1.00000000000000 + 0.99991837568760 + 0.99985865494112 + 0.99980954599020 + 0.99976673502880 + 0.99972766703492 + 0.99969052898066 + 0.99965398980328 + 0.99961706317814 + 0.99957895642486 + 0.99953898138541 + 0.99949650626684 + 0.99945092600126 + 0.99940161812856 + 0.99934793193434 + 0.99928923801238 + 0.99922489738255 + 0.99915426415241 + 0.99907668705872 + 0.99899149547703 + 0.99889790846208 + 0.99879486891018 + 0.99868124614299 + 0.99855608509517 + 0.99841846428910 + 0.99826714562946 + 0.99810078116251 + 0.99791778350951 + 0.99771619086636 + 0.99749356974506 + 0.99724691581171 + 0.99697255926657 + 0.99666608122274 + 0.99632204104134 + 0.99593390494924 + 0.99549438764902 + 0.99499516037241 + 0.99442681562368 + 0.99377947941217 + 0.99304681017715 + 0.99222611648547 + 0.99130787988609 + 0.99028104940139 + 0.98914041733930 + 0.98787500318949 + 0.98646598193977 + 0.98489189616572 + 0.98312964790607 + 0.98115418593956 + 0.97893663845835 + 0.97644454645832 + 0.97364141792724 + 0.97048478299479 + 0.96692614520408 + 0.96291143947677 + 0.95837887075241 + 0.95325059316572 + 0.94744203866715 + 0.94088113309873 + 0.93350524003937 + 0.92525554148715 + 0.91608431835338 + 0.90595641092251 + 0.89485246667114 + 0.88277335165658 + 0.86974554430564 + 0.85582598085324 + 0.84109873983668 + 0.82565903602462 + 0.80963053907659 + 0.79319314882640 + 0.77655712401946 + 0.76822472569913 + 0.75991655825780 + 0.75165163356368 + 0.74344459567070 + 0.73530503340211 + 0.72723700927736 + 0.71923890200946 + 0.71130370057991 + 0.70341974790286 + 0.69556868212318 + 0.68767291725617 + 0.67950559671021 + 0.67095092025213 + 0.66200009212448 + 0.65264721606988 + 0.64291002131346 + 0.63281183011263 + 0.62238011629754 + 0.61164554668515 + 0.60064155359778 + 0.58940282169627 + 0.57793960205949 + 0.56628796720547 + 0.55448727340179 + 0.54257945633553 + 0.53060745753051 + 0.51861281993648 + 0.50661864135294 + 0.49463683981079 + 0.48268105583140 + 0.47075290030174 + 0.45884148726542 + 0.99972639811890 + 0.99980220579837 + 0.99981910619286 + 0.99984143921823 + 0.99987232162349 + 0.99991837568760 + 1.00000000000000 + 0.99990835419959 + 0.99984410460148 + 0.99979237277500 + 0.99974759912490 + 0.99970659907513 + 0.99966732423323 + 0.99962838408072 + 0.99958874420523 + 0.99954756549067 + 0.99950411903565 + 0.99945773559588 + 0.99940774877753 + 0.99935347686949 + 0.99929426839829 + 0.99922946829814 + 0.99915841892549 + 0.99908046050699 + 0.99899491632469 + 0.99890100101941 + 0.99879765418027 + 0.99868374333231 + 0.99855831312436 + 0.99842044244589 + 0.99826889344558 + 0.99810231852348 + 0.99791913042647 + 0.99771736709526 + 0.99749459436974 + 0.99724780687094 + 0.99697333344406 + 0.99666675364041 + 0.99632262513627 + 0.99593441247356 + 0.99549482880970 + 0.99499554396363 + 0.99442714919257 + 0.99377976947110 + 0.99304706247143 + 0.99222633611221 + 0.99130807120159 + 0.99028121614992 + 0.98914056281886 + 0.98787513026470 + 0.98646609305848 + 0.98489199345160 + 0.98312973320120 + 0.98115426085408 + 0.97893670439333 + 0.97644460462813 + 0.97364146939036 + 0.97048482866558 + 0.96692618587322 + 0.96291147582377 + 0.95837890335622 + 0.95325062250535 + 0.94744206513644 + 0.94088115702937 + 0.93350526171727 + 0.92525556114960 + 0.91608433620375 + 0.90595642712964 + 0.89485248137845 + 0.88277336498700 + 0.86974555636380 + 0.85582599172818 + 0.84109874960876 + 0.82565904476722 + 0.80963054686084 + 0.79319315572421 + 0.77655713010832 + 0.76822473141296 + 0.75991656361727 + 0.75165163858968 + 0.74344460038471 + 0.73530503782404 + 0.72723701342705 + 0.71923890590484 + 0.71130370424054 + 0.70341975134516 + 0.69556868536244 + 0.68767292030549 + 0.67950559957710 + 0.67095092294036 + 0.66200009463788 + 0.65264721841267 + 0.64291002349024 + 0.63281183212646 + 0.62238011815374 + 0.61164554838827 + 0.60064155515477 + 0.58940282311312 + 0.57793960334253 + 0.56628796836166 + 0.55448727443866 + 0.54257945726123 + 0.53060745835327 + 0.51861282066476 + 0.50661864199540 + 0.49463684037591 + 0.48268105632771 + 0.47075290073690 + 0.45884148764689 + 0.99970587071924 + 0.99977100556582 + 0.99978475158422 + 0.99980242775747 + 0.99982590164237 + 0.99985865494112 + 0.99990835419959 + 1.00000000000000 + 0.99989743261982 + 0.99982866904128 + 0.99977428523796 + 0.99972730670574 + 0.99968405131683 + 0.99964231702029 + 0.99960062728800 + 0.99955788564789 + 0.99951320659541 + 0.99946582213677 + 0.99941500103688 + 0.99936001742428 + 0.99930018922309 + 0.99923483953937 + 0.99916329507393 + 0.99908488485620 + 0.99899892422719 + 0.99890462212167 + 0.99880091390052 + 0.99868666474646 + 0.99856091880440 + 0.99842275527260 + 0.99827093650605 + 0.99810411524909 + 0.99792070435160 + 0.99771874140831 + 0.99749579144832 + 0.99724884784247 + 0.99697423783735 + 0.99666753914707 + 0.99632330746094 + 0.99593500535087 + 0.99549534416320 + 0.99499599206466 + 0.99442753885751 + 0.99378010830658 + 0.99304735718715 + 0.99222659265990 + 0.99130829467268 + 0.99028141091377 + 0.98914073273326 + 0.98787527866979 + 0.98646622282232 + 0.98489210705046 + 0.98312983279305 + 0.98115434832017 + 0.97893678136917 + 0.97644467253311 + 0.97364152946164 + 0.97048488197304 + 0.96692623334037 + 0.96291151824568 + 0.95837894140497 + 0.95325065674213 + 0.94744209602052 + 0.94088118495033 + 0.93350528700677 + 0.92525558408781 + 0.91608435702508 + 0.90595644603358 + 0.89485249853229 + 0.88277338053473 + 0.86974557042487 + 0.85582600441002 + 0.84109876100402 + 0.82565905496106 + 0.80963055593585 + 0.79319316376656 + 0.77655713720759 + 0.76822473807479 + 0.75991656986699 + 0.75165164445080 + 0.74344460588028 + 0.73530504297910 + 0.72723701826446 + 0.71923891044720 + 0.71130370850801 + 0.70341975535810 + 0.69556868913887 + 0.68767292386138 + 0.67950560291909 + 0.67095092607380 + 0.66200009756824 + 0.65264722114419 + 0.64291002602739 + 0.63281183447419 + 0.62238012031803 + 0.61164555037457 + 0.60064155697044 + 0.58940282476450 + 0.57793960483834 + 0.56628796970966 + 0.55448727564745 + 0.54257945834038 + 0.53060745931250 + 0.51861282151373 + 0.50661864274461 + 0.49463684103486 + 0.48268105690591 + 0.47075290124445 + 0.45884148809137 + 0.99968449255719 + 0.99974087274893 + 0.99975223762075 + 0.99976654299527 + 0.99978497392780 + 0.99980954599020 + 0.99984410460148 + 0.99989743261982 + 1.00000000000000 + 0.99988557582446 + 0.99981226136738 + 0.99975504174628 + 0.99970557185546 + 0.99965975798354 + 0.99961522313670 + 0.99957039515577 + 0.99952411938550 + 0.99947546783812 + 0.99942360945826 + 0.99936775325165 + 0.99930717346221 + 0.99924116287838 + 0.99916902690654 + 0.99909007959157 + 0.99900362576744 + 0.99890886690052 + 0.99880473287122 + 0.99869008577173 + 0.99856396892602 + 0.99842546172785 + 0.99827332665556 + 0.99810621676410 + 0.99792254494950 + 0.99772034835799 + 0.99749719102189 + 0.99725006481738 + 0.99697529509294 + 0.99666845739792 + 0.99632410508278 + 0.99593569840701 + 0.99549594659756 + 0.99499651588285 + 0.99442799436559 + 0.99378050438791 + 0.99304770168513 + 0.99222689253486 + 0.99130855587148 + 0.99028163854739 + 0.98914093131286 + 0.98787545210149 + 0.98646637445790 + 0.98489223978791 + 0.98312994915415 + 0.98115445050404 + 0.97893687128874 + 0.97644475185331 + 0.97364159962642 + 0.97048494423379 + 0.96692628877592 + 0.96291156778354 + 0.95837898583488 + 0.95325069671682 + 0.94744213207953 + 0.94088121754911 + 0.93350531652980 + 0.92525561086207 + 0.91608438132776 + 0.90595646809754 + 0.89485251855226 + 0.88277339867822 + 0.86974558683289 + 0.85582601920787 + 0.84109877430018 + 0.82565906685534 + 0.80963056652469 + 0.79319317314872 + 0.77655714548956 + 0.76822474584695 + 0.75991657715772 + 0.75165165128819 + 0.74344461229276 + 0.73530504899311 + 0.72723702390812 + 0.71923891574581 + 0.71130371348728 + 0.70341976004018 + 0.69556869354508 + 0.68767292800852 + 0.67950560681856 + 0.67095092973010 + 0.66200010098718 + 0.65264722433068 + 0.64291002898732 + 0.63281183721369 + 0.62238012284279 + 0.61164555269202 + 0.60064155908829 + 0.58940282669204 + 0.57793960658330 + 0.56628797128229 + 0.55448727705796 + 0.54257945959957 + 0.53060746043161 + 0.51861282250437 + 0.50661864361815 + 0.49463684180367 + 0.48268105758101 + 0.47075290183620 + 0.45884148861003 + 0.99966215178790 + 0.99971133168214 + 0.99972087479692 + 0.99973268673305 + 0.99974755720898 + 0.99976673502880 + 0.99979237277500 + 0.99982866904128 + 0.99988557582446 + 1.00000000000000 + 0.99987269382478 + 0.99979467179726 + 0.99973439176082 + 0.99968216383878 + 0.99963346634398 + 0.99958574478697 + 0.99953734174358 + 0.99948705241214 + 0.99943388373259 + 0.99937694450138 + 0.99931544442377 + 0.99924863296816 + 0.99917578588158 + 0.99909619672853 + 0.99900915620715 + 0.99891385584314 + 0.99880921832627 + 0.99869410162273 + 0.99856754775543 + 0.99842863612317 + 0.99827612917629 + 0.99810868021081 + 0.99792470208757 + 0.99772223134694 + 0.99749883079642 + 0.99725149051585 + 0.99697653359438 + 0.99666953300979 + 0.99632503936540 + 0.99593651019032 + 0.99549665221960 + 0.99499712940781 + 0.99442852786521 + 0.99378096827412 + 0.99304810514037 + 0.99222724371525 + 0.99130886174191 + 0.99028190510104 + 0.98914116383119 + 0.98787565516373 + 0.98646655199236 + 0.98489239519000 + 0.98313008537977 + 0.98115457012992 + 0.97893697655402 + 0.97644484470766 + 0.97364168176031 + 0.97048501711444 + 0.96692635366651 + 0.96291162577005 + 0.95837903783926 + 0.95325074350689 + 0.94744217428435 + 0.94088125570131 + 0.93350535108247 + 0.92525564219684 + 0.91608440976800 + 0.90595649391582 + 0.89485254197878 + 0.88277341990771 + 0.86974560603223 + 0.85582603652162 + 0.84109878985603 + 0.82565908077252 + 0.80963057891368 + 0.79319318412830 + 0.77655715518137 + 0.76822475494245 + 0.75991658568997 + 0.75165165928935 + 0.74344461979672 + 0.73530505603283 + 0.72723703051411 + 0.71923892194921 + 0.71130371931577 + 0.70341976552075 + 0.69556869870289 + 0.68767293286475 + 0.67950561138387 + 0.67095093401125 + 0.66200010499013 + 0.65264722806248 + 0.64291003245388 + 0.63281184042145 + 0.62238012579968 + 0.61164555540635 + 0.60064156156884 + 0.58940282894901 + 0.57793960862737 + 0.56628797312439 + 0.55448727871035 + 0.54257946107454 + 0.53060746174270 + 0.51861282366482 + 0.50661864464215 + 0.49463684270445 + 0.48268105837208 + 0.47075290252977 + 0.45884148921849 + 0.99963863625723 + 0.99968186714007 + 0.99968999765650 + 0.99969992908906 + 0.99971221214649 + 0.99972766703492 + 0.99974759912490 + 0.99977428523796 + 0.99981226136738 + 0.99987269382478 + 1.00000000000000 + 0.99985864732791 + 0.99977574680884 + 0.99971220376189 + 0.99965692191790 + 0.99960495965834 + 0.99955360676282 + 0.99950113638458 + 0.99944627408428 + 0.99938796590678 + 0.99932532203441 + 0.99925752779890 + 0.99918381639010 + 0.99910345270622 + 0.99901570798437 + 0.99891976028755 + 0.99881452269337 + 0.99869884757872 + 0.99857177496486 + 0.99843238392675 + 0.99827943665957 + 0.99811158657657 + 0.99792724636751 + 0.99772445175631 + 0.99750076403116 + 0.99725317108592 + 0.99697799329974 + 0.99667080058909 + 0.99632614027988 + 0.99593746666883 + 0.99549748354151 + 0.99499785216570 + 0.99442915629508 + 0.99378151464990 + 0.99304858030094 + 0.99222765727728 + 0.99130922192946 + 0.99028221897900 + 0.98914143763380 + 0.98787589429131 + 0.98646676107246 + 0.98489257822268 + 0.98313024584547 + 0.98115471106019 + 0.97893710058730 + 0.97644495413419 + 0.97364177857065 + 0.97048510303365 + 0.96692643018062 + 0.96291169415564 + 0.95837909918269 + 0.95325079870480 + 0.94744222408201 + 0.94088130072126 + 0.93350539185953 + 0.92525567918013 + 0.91608444333747 + 0.90595652439272 + 0.89485256963502 + 0.88277344497193 + 0.86974562870273 + 0.85582605696763 + 0.84109880823142 + 0.82565909721295 + 0.80963059355315 + 0.79319319710393 + 0.77655716663936 + 0.76822476569777 + 0.75991659578023 + 0.75165166875467 + 0.74344462867648 + 0.73530506436381 + 0.72723703833316 + 0.71923892929306 + 0.71130372621840 + 0.70341977201372 + 0.69556870481485 + 0.68767293861968 + 0.67950561679447 + 0.67095093908598 + 0.66200010973736 + 0.65264723248810 + 0.64291003656495 + 0.63281184422678 + 0.62238012930729 + 0.61164555862668 + 0.60064156451217 + 0.58940283162772 + 0.57793961105367 + 0.56628797531169 + 0.55448728067276 + 0.54257946282664 + 0.53060746330021 + 0.51861282504402 + 0.50661864585906 + 0.49463684377550 + 0.48268105931265 + 0.47075290335493 + 0.45884148994195 + 0.99961360653757 + 0.99965188487370 + 0.99965890352215 + 0.99966738875331 + 0.99967774128405 + 0.99969052898066 + 0.99970659907513 + 0.99972730670574 + 0.99975504174628 + 0.99979467179726 + 0.99985864732791 + 1.00000000000000 + 0.99984340132296 + 0.99975550436564 + 0.99968846014342 + 0.99962975528278 + 0.99957407099492 + 0.99951857230779 + 0.99946145027114 + 0.99940136752035 + 0.99933727210048 + 0.99926825011541 + 0.99919347143663 + 0.99911215953848 + 0.99902355815851 + 0.99892682667623 + 0.99882086505410 + 0.99870451795056 + 0.99857682233178 + 0.99843685644838 + 0.99828338185181 + 0.99811505188389 + 0.99793027884577 + 0.99772709736067 + 0.99750306679726 + 0.99725517236658 + 0.99697973115011 + 0.99667230937023 + 0.99632745041110 + 0.99593860469103 + 0.99549847245784 + 0.99499871176862 + 0.99442990356285 + 0.99378216422487 + 0.99304914511482 + 0.99222814881550 + 0.99130965000626 + 0.99028259202581 + 0.98914176308581 + 0.98787617858360 + 0.98646700971091 + 0.98489279596133 + 0.98313043681216 + 0.98115487885229 + 0.97893724833173 + 0.97644508454451 + 0.97364189400595 + 0.97048520553626 + 0.96692652151114 + 0.96291177582660 + 0.95837917248001 + 0.95325086469337 + 0.94744228363800 + 0.94088135458490 + 0.93350544066213 + 0.92525572345735 + 0.91608448354148 + 0.90595656090450 + 0.89485260277684 + 0.88277347501806 + 0.86974565588730 + 0.85582608149417 + 0.84109883028181 + 0.82565911695170 + 0.80963061113964 + 0.79319321270194 + 0.77655718042423 + 0.76822477864184 + 0.75991660793080 + 0.75165168015785 + 0.74344463937759 + 0.73530507440872 + 0.72723704776683 + 0.71923893815714 + 0.71130373455343 + 0.70341977985736 + 0.69556871220226 + 0.68767294557869 + 0.67950562334018 + 0.67095094522874 + 0.66200011548401 + 0.65264723784777 + 0.64291004154620 + 0.63281184883840 + 0.62238013356011 + 0.61164556253232 + 0.60064156808408 + 0.58940283487935 + 0.57793961399995 + 0.56628797796821 + 0.55448728305696 + 0.54257946495643 + 0.53060746519463 + 0.51861282672186 + 0.50661864734081 + 0.49463684508046 + 0.48268106045942 + 0.47075290436148 + 0.45884149082445 + 0.99958670284751 + 0.99962082018807 + 0.99962694960888 + 0.99963430064118 + 0.99964317654032 + 0.99965398980328 + 0.99966732423323 + 0.99968405131683 + 0.99970557185546 + 0.99973439176082 + 0.99977574680884 + 0.99984340132296 + 1.00000000000000 + 0.99982699132794 + 0.99973397549846 + 0.99966311028878 + 0.99960052295222 + 0.99954057841457 + 0.99948031956653 + 0.99941786791227 + 0.99935188817580 + 0.99928130432083 + 0.99920518774918 + 0.99912269985742 + 0.99903304430244 + 0.99893535382763 + 0.99882851005594 + 0.99871134677873 + 0.99858289628564 + 0.99844223516902 + 0.99828812375307 + 0.99811921494110 + 0.99793392033254 + 0.99773027302813 + 0.99750582995269 + 0.99725757297708 + 0.99698181513767 + 0.99667411814831 + 0.99632902061597 + 0.99593996825986 + 0.99549965705879 + 0.99499974120023 + 0.99443079823266 + 0.99378294173309 + 0.99304982101698 + 0.99222873694544 + 0.99131016217731 + 0.99028303837753 + 0.98914215255428 + 0.98787651889663 + 0.98646730746721 + 0.98489305684241 + 0.98313066574791 + 0.98115508013400 + 0.97893742568336 + 0.97644524120220 + 0.97364203277741 + 0.97048532885495 + 0.96692663147429 + 0.96291187423246 + 0.95837926085800 + 0.95325094431256 + 0.94744235554279 + 0.94088141965535 + 0.93350549964964 + 0.92525577700054 + 0.91608453217933 + 0.90595660509369 + 0.89485264290640 + 0.88277351141571 + 0.86974568883511 + 0.85582611123732 + 0.84109885703808 + 0.82565914091934 + 0.80963063251045 + 0.79319323167388 + 0.77655719720708 + 0.76822479441131 + 0.75991662274062 + 0.75165169406533 + 0.74344465243792 + 0.73530508667761 + 0.72723705929710 + 0.71923894899835 + 0.71130374475472 + 0.70341978946420 + 0.69556872125519 + 0.68767295411153 + 0.67950563137113 + 0.67095095276814 + 0.66200012254197 + 0.65264724443327 + 0.64291004766962 + 0.63281185451056 + 0.62238013879369 + 0.61164556734076 + 0.60064157248259 + 0.58940283888536 + 0.57793961763159 + 0.56628798124516 + 0.55448728599934 + 0.54257946758626 + 0.53060746753501 + 0.51861282879680 + 0.50661864917405 + 0.49463684669544 + 0.48268106187967 + 0.47075290560926 + 0.45884149192045 + 0.99955759552284 + 0.99958818377593 + 0.99959359063229 + 0.99960003508485 + 0.99960775496393 + 0.99961706317814 + 0.99962838408072 + 0.99964231702029 + 0.99965975798354 + 0.99968216383878 + 0.99971220376189 + 0.99975550436564 + 0.99982699132794 + 1.00000000000000 + 0.99980942237286 + 0.99971110672500 + 0.99963600039939 + 0.99956897912864 + 0.99950412923556 + 0.99943839891613 + 0.99936990964333 + 0.99929730139991 + 0.99921948399010 + 0.99913552167223 + 0.99904455755856 + 0.99894568526209 + 0.99883776010871 + 0.99871960023670 + 0.99859023071376 + 0.99844872511390 + 0.99829384155581 + 0.99812423190969 + 0.99793830655645 + 0.99773409648702 + 0.99750915544358 + 0.99726046111776 + 0.99698432154361 + 0.99667629291292 + 0.99633090799998 + 0.99594160681879 + 0.99550108017417 + 0.99500097756271 + 0.99443187244633 + 0.99378387501923 + 0.99305063214568 + 0.99222944262995 + 0.99131077668318 + 0.99028357393276 + 0.98914261994116 + 0.98787692742417 + 0.98646766505939 + 0.98489337031602 + 0.98313094100429 + 0.98115532230506 + 0.97893763921792 + 0.97644542996508 + 0.97364220012460 + 0.97048547768568 + 0.96692676429321 + 0.96291199318868 + 0.95837936777748 + 0.95325104070596 + 0.94744244265215 + 0.94088149853390 + 0.93350557119408 + 0.92525584197548 + 0.91608459123232 + 0.90595665877456 + 0.89485269167686 + 0.88277355567402 + 0.86974572891856 + 0.85582614744168 + 0.84109888962799 + 0.82565917013389 + 0.80963065858177 + 0.79319325484082 + 0.77655721772423 + 0.76822481369950 + 0.75991664086856 + 0.75165171110046 + 0.74344466844698 + 0.73530510172644 + 0.72723707344897 + 0.71923896231529 + 0.71130375729420 + 0.70341980128025 + 0.69556873239743 + 0.68767296462134 + 0.67950564126830 + 0.67095096206447 + 0.66200013124934 + 0.65264725256177 + 0.64291005523176 + 0.63281186151830 + 0.62238014526237 + 0.61164557328709 + 0.60064157792485 + 0.58940284384490 + 0.57793962212993 + 0.56628798530593 + 0.55448728964776 + 0.54257947084948 + 0.53060747044108 + 0.51861283137497 + 0.50661865145346 + 0.49463684870575 + 0.48268106364893 + 0.47075290716501 + 0.45884149328737 + 0.99952594953606 + 0.99955351561384 + 0.99955832598461 + 0.99956403225474 + 0.99957082687106 + 0.99957895642486 + 0.99958874420523 + 0.99960062728800 + 0.99961522313670 + 0.99963346634398 + 0.99965692191790 + 0.99968846014342 + 0.99973397549846 + 0.99980942237286 + 1.00000000000000 + 0.99979067255680 + 0.99968678443851 + 0.99960690673745 + 0.99953477742180 + 0.99946427143895 + 0.99939232400745 + 0.99931702939675 + 0.99923701338331 + 0.99915117990666 + 0.99905857665632 + 0.99895823773659 + 0.99884897963479 + 0.99872959739037 + 0.99859910481860 + 0.99845657019544 + 0.99830074786033 + 0.99813028766006 + 0.99794359792882 + 0.99773870666802 + 0.99751316346712 + 0.99726394071196 + 0.99698734021577 + 0.99667891136777 + 0.99633317980874 + 0.99594357859027 + 0.99550279223253 + 0.99500246455315 + 0.99443316406716 + 0.99378499688220 + 0.99305160693143 + 0.99223029055638 + 0.99131151499509 + 0.99028421740688 + 0.98914318160230 + 0.98787741849682 + 0.98646809508782 + 0.98489374748399 + 0.98313127238873 + 0.98115561404872 + 0.97893789665017 + 0.97644565770484 + 0.97364240218388 + 0.97048565753478 + 0.96692692492266 + 0.96291213716773 + 0.95837949728472 + 0.95325115754765 + 0.94744254831222 + 0.94088159426767 + 0.93350565807629 + 0.92525592092038 + 0.91608466301598 + 0.90595672405426 + 0.89485275101472 + 0.88277360954754 + 0.86974577773744 + 0.85582619156204 + 0.84109892936802 + 0.82565920578503 + 0.80963069042309 + 0.79319328316303 + 0.77655724283417 + 0.76822483731961 + 0.75991666308123 + 0.75165173198776 + 0.74344468808913 + 0.73530512020366 + 0.72723709083753 + 0.71923897868951 + 0.71130377272300 + 0.70341981582874 + 0.69556874612547 + 0.68767297757690 + 0.67950565347673 + 0.67095097353894 + 0.66200014200181 + 0.65264726260546 + 0.64291006457867 + 0.63281187018546 + 0.62238015326602 + 0.61164558064758 + 0.60064158466530 + 0.58940284998990 + 0.57793962770697 + 0.56628799034294 + 0.55448729417640 + 0.54257947490191 + 0.53060747405224 + 0.51861283458082 + 0.50661865429031 + 0.49463685120904 + 0.48268106585424 + 0.47075290910547 + 0.45884149499418 + 0.99949140262675 + 0.99951635521057 + 0.99952066552218 + 0.99952575991543 + 0.99953179829978 + 0.99953898138541 + 0.99954756549067 + 0.99955788564789 + 0.99957039515577 + 0.99958574478697 + 0.99960495965834 + 0.99962975528278 + 0.99966311028878 + 0.99971110672500 + 0.99979067255680 + 1.00000000000000 + 0.99977070369344 + 0.99966085289483 + 0.99957552340203 + 0.99949748915891 + 0.99942053384883 + 0.99934155591565 + 0.99925863378024 + 0.99917038819937 + 0.99907570832615 + 0.99897353389747 + 0.99886262206068 + 0.99874173283649 + 0.99860986221765 + 0.99846606943220 + 0.99830910247580 + 0.99813760751839 + 0.99794998953647 + 0.99774427226643 + 0.99751799976779 + 0.99726813764688 + 0.99699097991075 + 0.99668206752925 + 0.99633591736769 + 0.99594595397652 + 0.99550485420956 + 0.99500425499612 + 0.99443471885462 + 0.99378634695968 + 0.99305277972736 + 0.99223131054326 + 0.99131240305155 + 0.99028499140010 + 0.98914385728274 + 0.98787800942344 + 0.98646861276318 + 0.98489420174678 + 0.98313167173667 + 0.98115596585215 + 0.97893820729078 + 0.97644593271751 + 0.97364264636938 + 0.97048587504868 + 0.96692711934335 + 0.96291231156674 + 0.95837965427275 + 0.95325129928216 + 0.94744267656239 + 0.94088171053716 + 0.93350576365198 + 0.92525601689597 + 0.91608475032641 + 0.90595680349396 + 0.89485282325828 + 0.88277367516729 + 0.86974583723031 + 0.85582624535971 + 0.84109897785621 + 0.82565924931328 + 0.80963072933105 + 0.79319331780306 + 0.77655727357912 + 0.76822486625703 + 0.75991669031151 + 0.75165175760890 + 0.74344471220062 + 0.73530514289832 + 0.72723711220976 + 0.71923899882778 + 0.71130379171181 + 0.70341983374666 + 0.69556876304389 + 0.68767299355364 + 0.67950566853931 + 0.67095098770324 + 0.66200015528247 + 0.65264727501582 + 0.64291007613480 + 0.63281188090485 + 0.62238016316983 + 0.61164558975961 + 0.60064159301374 + 0.58940285760527 + 0.57793963462093 + 0.56628799659111 + 0.55448729979639 + 0.54257947993477 + 0.53060747853995 + 0.51861283856768 + 0.50661865782082 + 0.49463685432717 + 0.48268106860325 + 0.47075291152609 + 0.45884149712499 + 0.99945355874971 + 0.99947622910908 + 0.99948011396793 + 0.99948469259346 + 0.99949010077597 + 0.99949650626684 + 0.99950411903565 + 0.99951320659541 + 0.99952411938550 + 0.99953734174358 + 0.99955360676282 + 0.99957407099492 + 0.99960052295222 + 0.99963600039939 + 0.99968678443851 + 0.99977070369344 + 1.00000000000000 + 0.99974946073576 + 0.99963307968900 + 0.99954146450406 + 0.99945667196357 + 0.99937239486692 + 0.99928550905210 + 0.99919408726547 + 0.99909673696810 + 0.99899224029149 + 0.99887925991956 + 0.99875650104858 + 0.99862293095032 + 0.99847759352662 + 0.99831922622238 + 0.99814646883486 + 0.99795772089213 + 0.99775099994356 + 0.99752384260077 + 0.99727320568569 + 0.99699537334394 + 0.99668587603666 + 0.99633921980202 + 0.99594881874641 + 0.99550734037453 + 0.99500641321558 + 0.99443659252050 + 0.99378797349753 + 0.99305419233340 + 0.99223253887523 + 0.99131347239674 + 0.99028592339471 + 0.98914467099560 + 0.98787872124923 + 0.98646923657654 + 0.98489474939763 + 0.98313215344388 + 0.98115639046334 + 0.97893858246606 + 0.97644626509202 + 0.97364294170238 + 0.97048613831976 + 0.96692735483856 + 0.96291252296695 + 0.95837984470214 + 0.95325147132161 + 0.94744283233307 + 0.94088185183296 + 0.93350589201586 + 0.92525613364369 + 0.91608485658102 + 0.90595690020943 + 0.89485291124956 + 0.88277375513043 + 0.86974590976293 + 0.85582631098411 + 0.84109903703801 + 0.82565930248001 + 0.80963077689184 + 0.79319336018358 + 0.77655731123177 + 0.76822490171756 + 0.75991672369952 + 0.75165178904398 + 0.74344474180015 + 0.73530517077874 + 0.72723713848238 + 0.71923902360093 + 0.71130381508593 + 0.70341985581527 + 0.69556878389411 + 0.68767301325332 + 0.67950568712293 + 0.67095100518821 + 0.66200017168416 + 0.65264729035037 + 0.64291009041938 + 0.63281189416135 + 0.62238017542325 + 0.61164560103897 + 0.60064160335173 + 0.58940286704013 + 0.57793964319109 + 0.56628800434030 + 0.55448730677080 + 0.54257948618376 + 0.53060748411550 + 0.51861284352404 + 0.50661866221275 + 0.49463685820898 + 0.48268107202777 + 0.47075291454406 + 0.45884149978359 + 0.99941198658109 + 0.99943264444325 + 0.99943616221005 + 0.99944029918331 + 0.99944517270973 + 0.99945092600126 + 0.99945773559588 + 0.99946582213677 + 0.99947546783812 + 0.99948705241214 + 0.99950113638458 + 0.99951857230779 + 0.99954057841457 + 0.99956897912864 + 0.99960690673745 + 0.99966085289483 + 0.99974946073576 + 1.00000000000000 + 0.99972682263238 + 0.99960315081364 + 0.99950433266309 + 0.99941183194821 + 0.99931928342555 + 0.99922355202180 + 0.99912269735398 + 0.99901522025014 + 0.99889962514843 + 0.99877452804871 + 0.99863884886153 + 0.99849160548922 + 0.99833151787527 + 0.99815721497160 + 0.99796708753726 + 0.99775914403830 + 0.99753091087591 + 0.99727933335244 + 0.99700068301820 + 0.99669047713429 + 0.99634320828960 + 0.99595227771314 + 0.99551034144652 + 0.99500901776919 + 0.99443885309216 + 0.99378993538591 + 0.99305589576096 + 0.99223401981813 + 0.99131476151531 + 0.99028704691194 + 0.98914565201652 + 0.98787957962509 + 0.98646998907074 + 0.98489541030234 + 0.98313273505757 + 0.98115690342874 + 0.97893903598538 + 0.97644666714071 + 0.97364329919064 + 0.97048645721775 + 0.96692764029497 + 0.96291277939680 + 0.95838007585152 + 0.95325168027898 + 0.94744302163764 + 0.94088202363572 + 0.93350604816847 + 0.92525627572866 + 0.91608498594786 + 0.90595701801317 + 0.89485301847186 + 0.88277385261176 + 0.86974599822645 + 0.85582639106228 + 0.84109910929877 + 0.82565936743681 + 0.80963083504429 + 0.79319341204820 + 0.77655735735566 + 0.76822494518088 + 0.75991676464373 + 0.75165182761600 + 0.74344477814329 + 0.73530520503275 + 0.72723717078249 + 0.71923905407524 + 0.71130384385641 + 0.70341988299568 + 0.69556880958809 + 0.68767303754457 + 0.67950571004984 + 0.67095102676876 + 0.66200019193774 + 0.65264730929428 + 0.64291010807451 + 0.63281191055307 + 0.62238019058103 + 0.61164561499714 + 0.60064161615168 + 0.58940287872629 + 0.57793965381213 + 0.56628801394879 + 0.55448731542302 + 0.54257949394034 + 0.53060749104057 + 0.51861284968403 + 0.50661866767503 + 0.49463686304011 + 0.48268107629281 + 0.47075291830587 + 0.45884150309983 + 0.99936619566688 + 0.99938506068889 + 0.99938825730328 + 0.99939201029076 + 0.99939642245988 + 0.99940161812856 + 0.99940774877753 + 0.99941500103688 + 0.99942360945826 + 0.99943388373259 + 0.99944627408428 + 0.99946145027114 + 0.99948031956653 + 0.99950412923556 + 0.99953477742180 + 0.99957552340203 + 0.99963307968900 + 0.99972682263238 + 1.00000000000000 + 0.99970263524669 + 0.99957077700650 + 0.99946370521546 + 0.99936244670118 + 0.99926059927076 + 0.99915501010317 + 0.99904363079396 + 0.99892468265658 + 0.99879662938810 + 0.99865831037955 + 0.99850869894432 + 0.99834648580830 + 0.99817028165107 + 0.99797846309566 + 0.99776902508606 + 0.99753947979673 + 0.99728675718883 + 0.99700711252129 + 0.99669604632400 + 0.99634803434469 + 0.99595646184176 + 0.99551397072618 + 0.99501216672319 + 0.99444158545525 + 0.99379230609712 + 0.99305795363783 + 0.99223580856683 + 0.99131631838229 + 0.99028840373111 + 0.98914683684713 + 0.98788061654227 + 0.98647089836558 + 0.98489620924265 + 0.98313343848345 + 0.98115752416722 + 0.97893958511412 + 0.97644715425503 + 0.97364373260379 + 0.97048684411251 + 0.96692798685891 + 0.96291309093198 + 0.95838035685537 + 0.95325193445998 + 0.94744325203914 + 0.94088223284267 + 0.93350623840486 + 0.92525644889994 + 0.91608514368296 + 0.90595716170418 + 0.89485314930761 + 0.88277397160995 + 0.86974610626746 + 0.85582648891477 + 0.84109919764619 + 0.82565944690849 + 0.80963090624286 + 0.79319347560482 + 0.77655741393288 + 0.76822499851957 + 0.75991681492286 + 0.75165187500907 + 0.74344482282368 + 0.73530524717014 + 0.72723721054005 + 0.71923909160878 + 0.71130387931434 + 0.70341991651387 + 0.69556884129092 + 0.68767306753170 + 0.67950573836726 + 0.67095105343692 + 0.66200021697771 + 0.65264733272478 + 0.64291012992171 + 0.63281193084419 + 0.62238020935251 + 0.61164563229115 + 0.60064163201668 + 0.58940289321858 + 0.57793966698961 + 0.56628802587498 + 0.55448732616823 + 0.54257950357889 + 0.53060749965078 + 0.51861285734780 + 0.50661867447479 + 0.49463686905887 + 0.48268108161084 + 0.47075292299952 + 0.45884150724004 + 0.99931563727132 + 0.99933288821535 + 0.99933580000425 + 0.99933921415945 + 0.99934322170549 + 0.99934793193434 + 0.99935347686949 + 0.99936001742428 + 0.99936775325165 + 0.99937694450138 + 0.99938796590678 + 0.99940136752035 + 0.99941786791227 + 0.99943839891613 + 0.99946427143895 + 0.99949748915891 + 0.99954146450406 + 0.99960315081364 + 0.99970263524669 + 1.00000000000000 + 0.99967680087970 + 0.99953564911928 + 0.99941913334590 + 0.99930796310854 + 0.99919569477140 + 0.99907906029986 + 0.99895572716966 + 0.99882388209940 + 0.99868222192092 + 0.99852964179264 + 0.99836478296348 + 0.99818622526963 + 0.99799232241743 + 0.99778104890653 + 0.99754989670490 + 0.99729577500557 + 0.99701491769405 + 0.99670280383091 + 0.99635388788910 + 0.99596153516448 + 0.99551837004647 + 0.99501598278917 + 0.99444489578882 + 0.99379517750192 + 0.99306044549230 + 0.99223797410035 + 0.99131820293874 + 0.99029004605431 + 0.98914827108661 + 0.98788187196797 + 0.98647199960602 + 0.98489717721003 + 0.98313429112436 + 0.98115827697444 + 0.97894025146738 + 0.97644774571965 + 0.97364425920944 + 0.97048731451909 + 0.96692840851198 + 0.96291347021993 + 0.95838069919559 + 0.95325224431249 + 0.94744353305705 + 0.94088248813476 + 0.93350647065087 + 0.92525666039879 + 0.91608533640590 + 0.90595733733454 + 0.89485330928906 + 0.88277411718221 + 0.86974623849547 + 0.85582660873141 + 0.84109930588959 + 0.82565954433949 + 0.80963099359772 + 0.79319355364765 + 0.77655748347519 + 0.76822506411803 + 0.75991687679099 + 0.75165193336082 + 0.74344487786865 + 0.73530529911353 + 0.72723725957969 + 0.71923913793361 + 0.71130392310308 + 0.70341995793075 + 0.69556888048772 + 0.68767310462712 + 0.67950577341474 + 0.67095108646065 + 0.66200024799789 + 0.65264736176531 + 0.64291015700907 + 0.63281195601465 + 0.62238023264737 + 0.61164565376286 + 0.60064165172216 + 0.58940291122649 + 0.57793968337097 + 0.56628804070903 + 0.55448733954006 + 0.54257951557987 + 0.53060751037852 + 0.51861286690214 + 0.50661868295814 + 0.49463687657232 + 0.48268108825408 + 0.47075292886693 + 0.45884151242021 + 0.99925975960969 + 0.99927554291408 + 0.99927819887823 + 0.99928130994397 + 0.99928495732571 + 0.99928923801238 + 0.99929426839829 + 0.99930018922309 + 0.99930717346221 + 0.99931544442377 + 0.99932532203441 + 0.99933727210048 + 0.99935188817580 + 0.99936990964333 + 0.99939232400745 + 0.99942053384883 + 0.99945667196357 + 0.99950433266309 + 0.99957077700650 + 0.99967680087970 + 1.00000000000000 + 0.99964913160242 + 0.99949736710867 + 0.99937007904563 + 0.99924772517637 + 0.99912371941933 + 0.99899449800756 + 0.99885769895400 + 0.99871175221230 + 0.99855541138376 + 0.99838723191787 + 0.99820574102107 + 0.99800925485347 + 0.99779571644341 + 0.99756258851353 + 0.99730675158081 + 0.99702441107917 + 0.99671101816155 + 0.99636100015016 + 0.99596769719065 + 0.99552371178309 + 0.99502061502146 + 0.99444891302026 + 0.99379866110394 + 0.99306346782636 + 0.99224060008699 + 0.99132048787109 + 0.99029203715135 + 0.98915000997951 + 0.98788339430661 + 0.98647333532584 + 0.98489835169137 + 0.98313532611233 + 0.98115919122243 + 0.97894106114967 + 0.97644846482578 + 0.97364489985071 + 0.97048788714909 + 0.96692892212766 + 0.96291393252315 + 0.95838111671635 + 0.95325262241927 + 0.94744387615322 + 0.94088279996548 + 0.93350675445140 + 0.92525691894362 + 0.91608557208271 + 0.90595755218922 + 0.89485350507191 + 0.88277429539711 + 0.86974640044271 + 0.85582675555013 + 0.84109943860022 + 0.82565966386882 + 0.80963110084296 + 0.79319364954171 + 0.77655756900302 + 0.76822514483727 + 0.75991695296271 + 0.75165200524247 + 0.74344494571501 + 0.73530536317509 + 0.72723732009656 + 0.71923919513490 + 0.71130397720314 + 0.70342000912916 + 0.69556892896615 + 0.68767315053098 + 0.67950581680656 + 0.67095112736370 + 0.66200028643727 + 0.65264739776736 + 0.64291019060458 + 0.63281198724542 + 0.62238026156247 + 0.61164568042443 + 0.60064167620247 + 0.58940293360720 + 0.57793970374026 + 0.56628805916260 + 0.55448735618304 + 0.54257953052527 + 0.53060752374507 + 0.51861287881423 + 0.50661869354255 + 0.49463688595294 + 0.48268109655328 + 0.47075293620273 + 0.45884151890017 + 0.99919798381592 + 0.99921242004291 + 0.99921484351442 + 0.99921768003648 + 0.99922100244784 + 0.99922489738255 + 0.99922946829814 + 0.99923483953937 + 0.99924116287838 + 0.99924863296816 + 0.99925752779890 + 0.99926825011541 + 0.99928130432083 + 0.99929730139991 + 0.99931702939675 + 0.99934155591565 + 0.99937239486692 + 0.99941183194821 + 0.99946370521546 + 0.99953564911928 + 0.99964913160242 + 1.00000000000000 + 0.99961939402162 + 0.99945547377959 + 0.99931592366647 + 0.99918088557280 + 0.99904344367050 + 0.99890000479341 + 0.99874845845075 + 0.99858728887089 + 0.99841489754259 + 0.99822971998836 + 0.99803000978581 + 0.99781366055704 + 0.99757809172786 + 0.99732014345351 + 0.99703598258108 + 0.99672102345905 + 0.99636965835532 + 0.99597519540362 + 0.99553020955847 + 0.99502624801258 + 0.99445379672311 + 0.99380289486092 + 0.99306713999036 + 0.99224378996597 + 0.99132326300560 + 0.99029445519689 + 0.98915212176429 + 0.98788524332696 + 0.98647495803976 + 0.98489977896016 + 0.98313658433999 + 0.98116030315147 + 0.97894204638301 + 0.97644934030615 + 0.97364568024196 + 0.97048858510441 + 0.96692954851684 + 0.96291449666278 + 0.95838162649343 + 0.95325308431727 + 0.94744429547589 + 0.94088318123541 + 0.93350710157385 + 0.92525723528554 + 0.91608586053685 + 0.90595781524124 + 0.89485374485645 + 0.88277451374678 + 0.86974659894007 + 0.85582693558786 + 0.84109960142045 + 0.82565981060452 + 0.80963123259079 + 0.79319376743813 + 0.77655767425142 + 0.76822524421675 + 0.75991704679071 + 0.75165209383265 + 0.74344502938122 + 0.73530544221889 + 0.72723739480833 + 0.71923926579183 + 0.71130404406581 + 0.70342007244147 + 0.69556898894714 + 0.68767320735344 + 0.67950587054333 + 0.67095117804279 + 0.66200033408450 + 0.65264744240999 + 0.64291023228093 + 0.63281202600184 + 0.62238029746079 + 0.61164571353729 + 0.60064170661936 + 0.58940296142735 + 0.57793972907168 + 0.56628808212265 + 0.55448737690092 + 0.54257954913932 + 0.53060754040168 + 0.51861289366790 + 0.50661870674748 + 0.49463689766406 + 0.48268110692180 + 0.47075294537303 + 0.45884152700729 + 0.99912971002340 + 0.99914289941721 + 0.99914510939661 + 0.99914769446160 + 0.99915072014564 + 0.99915426415241 + 0.99915841892549 + 0.99916329507393 + 0.99916902690654 + 0.99917578588158 + 0.99918381639010 + 0.99919347143663 + 0.99920518774918 + 0.99921948399010 + 0.99923701338331 + 0.99925863378024 + 0.99928550905210 + 0.99931928342555 + 0.99936244670118 + 0.99941913334590 + 0.99949736710867 + 0.99961939402162 + 1.00000000000000 + 0.99958730066814 + 0.99940942582947 + 0.99925583850857 + 0.99910618951596 + 0.99895351317869 + 0.99879446782664 + 0.99862698631249 + 0.99844917974188 + 0.99825931874844 + 0.99805555001961 + 0.99783568769156 + 0.99759708553350 + 0.99733652554107 + 0.99705012119703 + 0.99673323748824 + 0.99638022076749 + 0.99598433797418 + 0.99553812904330 + 0.99503311111449 + 0.99445974502957 + 0.99380804996647 + 0.99307161000917 + 0.99224767198676 + 0.99132663967148 + 0.99029739703035 + 0.98915469095019 + 0.98788749302580 + 0.98647693274914 + 0.98490151627959 + 0.98313811639436 + 0.98116165758807 + 0.97894324701305 + 0.97645040769127 + 0.97364663217968 + 0.97048943693521 + 0.96693031342095 + 0.96291518591983 + 0.95838224964855 + 0.95325364920355 + 0.94744480851017 + 0.94088364787956 + 0.93350752656660 + 0.92525762270782 + 0.91608621390792 + 0.90595813758465 + 0.89485403877534 + 0.88277478147859 + 0.86974684242301 + 0.85582715651839 + 0.84109980131858 + 0.82565999086063 + 0.80963139454043 + 0.79319391247169 + 0.77655780383729 + 0.76822536663568 + 0.75991716242637 + 0.75165220307230 + 0.74344513260047 + 0.73530553978738 + 0.72723748708072 + 0.71923935310429 + 0.71130412673460 + 0.70342015075939 + 0.69556906318039 + 0.68767327771200 + 0.67950593711046 + 0.67095124084852 + 0.66200039315692 + 0.65264749778116 + 0.64291028399101 + 0.63281207410843 + 0.62238034203622 + 0.61164575467101 + 0.60064174441820 + 0.58940299601404 + 0.57793976057665 + 0.56628811069092 + 0.55448740269160 + 0.54257957232296 + 0.53060756115891 + 0.51861291218868 + 0.50661872322330 + 0.49463691228532 + 0.48268111987528 + 0.47075295683655 + 0.45884153714748 + 0.99905432151219 + 0.99906634879655 + 0.99906836103213 + 0.99907071366044 + 0.99907346572384 + 0.99907668705872 + 0.99908046050699 + 0.99908488485620 + 0.99909007959157 + 0.99909619672853 + 0.99910345270622 + 0.99911215953848 + 0.99912269985742 + 0.99913552167223 + 0.99915117990666 + 0.99917038819937 + 0.99919408726547 + 0.99922355202180 + 0.99926059927076 + 0.99930796310854 + 0.99937007904563 + 0.99945547377959 + 0.99958730066814 + 1.00000000000000 + 0.99955247757232 + 0.99935844885469 + 0.99918854969489 + 0.99902224385626 + 0.99885278755166 + 0.99867685098374 + 0.99849195625907 + 0.99829606314194 + 0.99808712930329 + 0.99786283711147 + 0.99762043792947 + 0.99735662775755 + 0.99706744455675 + 0.99674818580795 + 0.99639313675095 + 0.99599551057379 + 0.99554780217782 + 0.99504149054930 + 0.99446700497640 + 0.99381433972997 + 0.99307706222945 + 0.99225240578110 + 0.99133075638385 + 0.99030098310465 + 0.98915782260393 + 0.98789023537243 + 0.98647934021180 + 0.98490363477157 + 0.98313998509300 + 0.98116331018097 + 0.97894471248638 + 0.97645171107104 + 0.97364779510656 + 0.97049047805956 + 0.96693124875236 + 0.96291602914906 + 0.95838301235482 + 0.95325434088103 + 0.94744543692366 + 0.94088421965355 + 0.93350804745064 + 0.92525809766394 + 0.91608664722153 + 0.90595853295069 + 0.89485439936965 + 0.88277511004033 + 0.86974714132441 + 0.85582742784101 + 0.84110004692631 + 0.82566021244915 + 0.80963159375193 + 0.79319409100191 + 0.77655796348374 + 0.76822551752005 + 0.75991730501985 + 0.75165233784248 + 0.74344526001088 + 0.73530566028352 + 0.72723760109297 + 0.71923946104494 + 0.71130422898644 + 0.70342024767718 + 0.69556915508765 + 0.68767336486022 + 0.67950601959870 + 0.67095131870672 + 0.66200046641772 + 0.65264756647504 + 0.64291034816818 + 0.63281213383500 + 0.62238039739871 + 0.61164580577767 + 0.60064179139845 + 0.58940303901932 + 0.57793979976649 + 0.56628814624438 + 0.55448743480277 + 0.54257960120222 + 0.53060758703010 + 0.51861293528441 + 0.50661874378068 + 0.49463693053961 + 0.48268113605777 + 0.47075297116731 + 0.45884154983192 + 0.99897117295076 + 0.99898211136757 + 0.99898393922913 + 0.99898607547973 + 0.99898857330008 + 0.99899149547703 + 0.99899491632469 + 0.99899892422719 + 0.99900362576744 + 0.99900915620715 + 0.99901570798437 + 0.99902355815851 + 0.99903304430244 + 0.99904455755856 + 0.99905857665632 + 0.99907570832615 + 0.99909673696810 + 0.99912269735398 + 0.99915501010317 + 0.99919569477140 + 0.99924772517637 + 0.99931592366647 + 0.99940942582947 + 0.99955247757232 + 1.00000000000000 + 0.99951431364939 + 0.99930128742217 + 0.99911264173821 + 0.99892789331516 + 0.99874022421969 + 0.99854582143875 + 0.99834201599562 + 0.99812641463852 + 0.99789647267389 + 0.99764927623784 + 0.99738139032220 + 0.99708874315029 + 0.99676653775529 + 0.99640897646508 + 0.99600920119079 + 0.99555964810534 + 0.99505174718770 + 0.99447588767994 + 0.99382203255487 + 0.99308372845010 + 0.99225819196022 + 0.99133578713381 + 0.99030536464818 + 0.98916164859217 + 0.98789358576079 + 0.98648228172908 + 0.98490622363092 + 0.98314226920499 + 0.98116533069454 + 0.97894650479253 + 0.97645330570614 + 0.97364921846729 + 0.97049175287366 + 0.96693239451814 + 0.96291706252784 + 0.95838394742917 + 0.95325518918202 + 0.94744620787671 + 0.94088492130686 + 0.93350868680245 + 0.92525868076413 + 0.91608717930325 + 0.90595901853044 + 0.89485484234487 + 0.88277551376653 + 0.86974750871364 + 0.85582776145006 + 0.84110034904565 + 0.82566048516296 + 0.80963183906672 + 0.79319431100247 + 0.77655816037053 + 0.76822570368007 + 0.75991748103191 + 0.75165250427607 + 0.74344541742801 + 0.73530580923411 + 0.72723774210220 + 0.71923959460837 + 0.71130435557178 + 0.70342036771724 + 0.69556926897148 + 0.68767347289452 + 0.67950612189898 + 0.67095141530499 + 0.66200055734365 + 0.65264765176651 + 0.64291042787883 + 0.63281220804271 + 0.62238046620958 + 0.61164586932215 + 0.60064184983367 + 0.58940309253072 + 0.57793984855018 + 0.56628819051935 + 0.55448747480936 + 0.54257963719959 + 0.53060761929375 + 0.51861296410373 + 0.50661876944689 + 0.49463695334378 + 0.48268115628534 + 0.47075298909131 + 0.45884156570642 + 0.99887950214681 + 0.99888941632985 + 0.99889107142488 + 0.99889300516695 + 0.99889526538378 + 0.99889790846208 + 0.99890100101941 + 0.99890462212167 + 0.99890886690052 + 0.99891385584314 + 0.99891976028755 + 0.99892682667623 + 0.99893535382763 + 0.99894568526209 + 0.99895823773659 + 0.99897353389747 + 0.99899224029149 + 0.99901522025014 + 0.99904363079396 + 0.99907906029986 + 0.99912371941933 + 0.99918088557280 + 0.99925583850857 + 0.99935844885469 + 0.99951431364939 + 1.00000000000000 + 0.99947178611301 + 0.99923664157689 + 0.99902705166676 + 0.99882217457436 + 0.99861455214142 + 0.99840009774954 + 0.99817571838905 + 0.99793845695622 + 0.99768512145269 + 0.99741206981298 + 0.99711506569291 + 0.99678917631175 + 0.99642848884433 + 0.99602604876401 + 0.99557421431020 + 0.99506435155473 + 0.99448679824405 + 0.99383147756117 + 0.99309190994221 + 0.99226529111101 + 0.99134195784033 + 0.99031073799682 + 0.98916634013128 + 0.98789769404921 + 0.98648588890391 + 0.98490939879629 + 0.98314507117296 + 0.98116780993476 + 0.97894870467667 + 0.97645526363910 + 0.97365096676700 + 0.97049331934777 + 0.96693380300604 + 0.96291833338184 + 0.95838509783027 + 0.95325623319228 + 0.94744715698019 + 0.94088578531999 + 0.93350947426690 + 0.92525939908501 + 0.91608783489428 + 0.90595961694230 + 0.89485538836298 + 0.88277601153189 + 0.86974796180974 + 0.85582817303300 + 0.84110072193542 + 0.82566082192714 + 0.80963214217689 + 0.79319458302508 + 0.77655840400631 + 0.76822593414336 + 0.75991769902748 + 0.75165271050948 + 0.74344561258602 + 0.73530599398598 + 0.72723791708943 + 0.71923976043931 + 0.71130451281653 + 0.70342051690014 + 0.69556941056973 + 0.68767360727909 + 0.67950624920270 + 0.67095153556018 + 0.66200067058111 + 0.65264775802444 + 0.64291052722049 + 0.63281230056120 + 0.62238055202839 + 0.61164594860141 + 0.60064192276700 + 0.58940315934269 + 0.57793990948435 + 0.56628824584601 + 0.55448752482352 + 0.54257968222419 + 0.53060765966976 + 0.51861300018776 + 0.50661880160285 + 0.49463698193214 + 0.48268118165853 + 0.47075301158943 + 0.45884158564338 + 0.99877826647875 + 0.99878721430474 + 0.99878870688401 + 0.99879045031246 + 0.99879248748556 + 0.99879486891018 + 0.99879765418027 + 0.99880091390052 + 0.99880473287122 + 0.99880921832627 + 0.99881452269337 + 0.99882086505410 + 0.99882851005594 + 0.99883776010871 + 0.99884897963479 + 0.99886262206068 + 0.99887925991956 + 0.99889962514843 + 0.99892468265658 + 0.99895572716966 + 0.99899449800756 + 0.99904344367050 + 0.99910618951596 + 0.99918854969489 + 0.99930128742217 + 0.99947178611301 + 1.00000000000000 + 0.99942413452197 + 0.99916383586279 + 0.99893111357356 + 0.99870404432781 + 0.99847470023877 + 0.99823843051061 + 0.99799147040576 + 0.99773013209450 + 0.99745043061725 + 0.99714787277101 + 0.99681732366300 + 0.99645270571051 + 0.99604693050951 + 0.99559225049575 + 0.99507994669736 + 0.99450028948672 + 0.99384315062366 + 0.99310201700980 + 0.99227405797787 + 0.99134957602669 + 0.99031737046600 + 0.98917213046350 + 0.98790276459353 + 0.98649034145883 + 0.98491331884750 + 0.98314853137930 + 0.98117087257563 + 0.97895142323192 + 0.97645768420300 + 0.97365312914285 + 0.97049525776845 + 0.96693554678741 + 0.96291990753085 + 0.95838652344447 + 0.95325752750550 + 0.94744833406523 + 0.94088685721009 + 0.93351045146501 + 0.92526029070314 + 0.91608864884658 + 0.90596036008246 + 0.89485606662302 + 0.88277663003818 + 0.86974852501498 + 0.85582868484829 + 0.84110118586203 + 0.82566124114999 + 0.80963251976161 + 0.79319492214442 + 0.77655870800622 + 0.76822622184442 + 0.75991797130547 + 0.75165296822678 + 0.74344585659539 + 0.73530622510901 + 0.72723813611666 + 0.71923996811887 + 0.71130470984554 + 0.70342070392584 + 0.69556958817509 + 0.68767377591322 + 0.67950640902493 + 0.67095168659660 + 0.66200081286378 + 0.65264789159019 + 0.64291065214223 + 0.63281241694549 + 0.62238066002764 + 0.61164604841024 + 0.60064201462379 + 0.58940324352659 + 0.57793998629484 + 0.56628831561937 + 0.55448758793116 + 0.54257973906455 + 0.53060771067022 + 0.51861304579496 + 0.50661884227035 + 0.49463701811023 + 0.48268121379147 + 0.47075304009930 + 0.45884161092449 + 0.99866634237250 + 0.99867437861730 + 0.99867571825357 + 0.99867728270900 + 0.99867911031198 + 0.99868124614299 + 0.99868374333231 + 0.99868666474646 + 0.99869008577173 + 0.99869410162273 + 0.99869884757872 + 0.99870451795056 + 0.99871134677873 + 0.99871960023670 + 0.99872959739037 + 0.99874173283649 + 0.99875650104858 + 0.99877452804871 + 0.99879662938810 + 0.99882388209940 + 0.99885769895400 + 0.99890000479341 + 0.99895351317869 + 0.99902224385626 + 0.99911264173821 + 0.99923664157689 + 0.99942413452197 + 1.00000000000000 + 0.99937104383505 + 0.99908238893079 + 0.99882386932690 + 0.99857251071062 + 0.99831950314628 + 0.99805931470104 + 0.99778730266863 + 0.99749887950070 + 0.99718913117835 + 0.99685260953051 + 0.99648299288286 + 0.99607300129463 + 0.99561473971697 + 0.99509937339526 + 0.99451708267733 + 0.99385767166929 + 0.99311458356559 + 0.99228495380825 + 0.99135904133472 + 0.99032560933500 + 0.98917932258192 + 0.98790906289155 + 0.98649587292047 + 0.98491818992092 + 0.98315283237848 + 0.98117468082681 + 0.97895480507299 + 0.97646069678190 + 0.97365582177973 + 0.97049767284572 + 0.96693772057171 + 0.96292187093621 + 0.95838830251883 + 0.95325914350387 + 0.94744980432291 + 0.94088819657347 + 0.93351167290731 + 0.92526140550770 + 0.91608966683495 + 0.90596128978436 + 0.89485691542644 + 0.88277740433803 + 0.86974923036986 + 0.85582932614521 + 0.84110176747575 + 0.82566176705646 + 0.80963299378006 + 0.79319534823215 + 0.77655909033057 + 0.76822658385721 + 0.75991831409161 + 0.75165329286439 + 0.74344616413810 + 0.73530651657836 + 0.72723841249095 + 0.71924023032396 + 0.71130495874568 + 0.70342094031499 + 0.69556981277492 + 0.68767398927533 + 0.67950661133398 + 0.67095187787120 + 0.66200099312951 + 0.65264806088336 + 0.64291081054203 + 0.63281256458166 + 0.62238079708352 + 0.61164617512488 + 0.60064213129234 + 0.58940335049635 + 0.57794008394105 + 0.56628840436528 + 0.55448766823955 + 0.54257981143872 + 0.53060777564684 + 0.51861310393718 + 0.50661889414975 + 0.49463706429492 + 0.48268125483965 + 0.47075307654566 + 0.45884164326618 + 0.99854277399635 + 0.99854995436250 + 0.99855115066487 + 0.99855254749338 + 0.99855417894550 + 0.99855608509517 + 0.99855831312436 + 0.99856091880440 + 0.99856396892602 + 0.99856754775543 + 0.99857177496486 + 0.99857682233178 + 0.99858289628564 + 0.99859023071376 + 0.99859910481860 + 0.99860986221765 + 0.99862293095032 + 0.99863884886153 + 0.99865831037955 + 0.99868222192092 + 0.99871175221230 + 0.99874845845075 + 0.99879446782664 + 0.99885278755166 + 0.99892789331516 + 0.99902705166676 + 0.99916383586279 + 0.99937104383505 + 1.00000000000000 + 0.99931196698473 + 0.99899112948087 + 0.99870414616122 + 0.99842627606007 + 0.99814736715189 + 0.99786072565685 + 0.99756062083397 + 0.99724140756835 + 0.99689712845250 + 0.99652108565591 + 0.99610571592525 + 0.99564291264738 + 0.99512367941938 + 0.99453807372510 + 0.99387580890328 + 0.99313027007757 + 0.99229854838310 + 0.99137084686390 + 0.99033588263993 + 0.98918828954343 + 0.98791691547093 + 0.98650277019395 + 0.98492426496023 + 0.98315819791542 + 0.98117943325367 + 0.97895902702206 + 0.97646445938592 + 0.97365918639399 + 0.97050069216259 + 0.96694043963947 + 0.96292432811708 + 0.95839053010299 + 0.95326116780330 + 0.94745164677583 + 0.94088987556076 + 0.93351320452518 + 0.92526280378831 + 0.91609094401578 + 0.90596245650993 + 0.89485798093972 + 0.88277837664837 + 0.86975011644364 + 0.85583013211215 + 0.84110249881842 + 0.82566242875531 + 0.80963359061775 + 0.79319588515501 + 0.77655957254875 + 0.76822704068343 + 0.75991874688130 + 0.75165370295804 + 0.74344655284968 + 0.73530688517934 + 0.72723876219662 + 0.71924056228261 + 0.71130527402835 + 0.70342123990934 + 0.69557009756889 + 0.68767425995028 + 0.67950686810248 + 0.67095212074299 + 0.66200122211818 + 0.65264827602157 + 0.64291101191709 + 0.63281275234581 + 0.62238097145889 + 0.61164633640728 + 0.60064227984859 + 0.58940348676342 + 0.57794020838780 + 0.56628851752013 + 0.55448777068931 + 0.54257990381707 + 0.53060785863153 + 0.51861317824007 + 0.50661896049159 + 0.49463712339542 + 0.48268130740325 + 0.47075312324835 + 0.45884168473778 + 0.99840663588471 + 0.99841301859396 + 0.99841408151508 + 0.99841532242381 + 0.99841677152570 + 0.99841846428910 + 0.99842044244589 + 0.99842275527260 + 0.99842546172785 + 0.99842863612317 + 0.99843238392675 + 0.99843685644838 + 0.99844223516902 + 0.99844872511390 + 0.99845657019544 + 0.99846606943220 + 0.99847759352662 + 0.99849160548922 + 0.99850869894432 + 0.99852964179264 + 0.99855541138376 + 0.99858728887089 + 0.99862698631249 + 0.99867685098374 + 0.99874022421969 + 0.99882217457436 + 0.99893111357356 + 0.99908238893079 + 0.99931196698473 + 1.00000000000000 + 0.99924565669259 + 0.99888877630164 + 0.99857057445170 + 0.99826372030486 + 0.99795627734466 + 0.99764009947188 + 0.99730817073866 + 0.99695365607053 + 0.99656924997072 + 0.99614695343044 + 0.99567834609628 + 0.99515419941909 + 0.99456439898685 + 0.99389853368045 + 0.99314990974261 + 0.99231555925670 + 0.99138561273531 + 0.99034872805109 + 0.98919949946654 + 0.98792673165748 + 0.98651139257663 + 0.98493186044908 + 0.98316490767284 + 0.98118537783854 + 0.97896430968603 + 0.97646916896737 + 0.97366339948192 + 0.97050447447404 + 0.96694384731546 + 0.96292740891171 + 0.95839332417496 + 0.95326370782441 + 0.94745395934844 + 0.94089198351671 + 0.93351512789826 + 0.92526456007222 + 0.91609254850415 + 0.90596392253885 + 0.89485932010071 + 0.88277959900297 + 0.86975123074994 + 0.85583114607417 + 0.84110341933264 + 0.82566326207183 + 0.80963434273600 + 0.79319656227506 + 0.77656018119319 + 0.76822761754238 + 0.75991929364740 + 0.75165422130839 + 0.74344704442090 + 0.73530735155699 + 0.72723920489549 + 0.71924098272914 + 0.71130567355466 + 0.70342161973693 + 0.69557045880115 + 0.68767460342550 + 0.67950719407013 + 0.67095242919178 + 0.66200151304816 + 0.65264854945598 + 0.64291126795187 + 0.63281299116272 + 0.62238119332897 + 0.61164654169517 + 0.60064246901260 + 0.58940366034624 + 0.57794036698014 + 0.56628866178927 + 0.55448790137015 + 0.54258002171212 + 0.53060796459624 + 0.51861327317267 + 0.50661904530737 + 0.49463719900124 + 0.48268137469110 + 0.47075318307239 + 0.45884173789417 + 0.99825668711793 + 0.99826233219419 + 0.99826327191776 + 0.99826436887281 + 0.99826564968973 + 0.99826714562946 + 0.99826889344558 + 0.99827093650605 + 0.99827332665556 + 0.99827612917629 + 0.99827943665957 + 0.99828338185181 + 0.99828812375307 + 0.99829384155581 + 0.99830074786033 + 0.99830910247580 + 0.99831922622238 + 0.99833151787527 + 0.99834648580830 + 0.99836478296348 + 0.99838723191787 + 0.99841489754259 + 0.99844917974188 + 0.99849195625907 + 0.99854582143875 + 0.99861455214142 + 0.99870404432781 + 0.99882386932690 + 0.99899112948087 + 0.99924565669259 + 1.00000000000000 + 0.99917131152357 + 0.99877427227190 + 0.99842181216161 + 0.99808309853620 + 0.99774392665978 + 0.99739441576480 + 0.99702609529379 + 0.99663061673841 + 0.99619927710272 + 0.99572317121672 + 0.99519272519740 + 0.99459757669543 + 0.99392713927824 + 0.99317460915545 + 0.99233693777752 + 0.99140416014930 + 0.99036485703580 + 0.98921357151794 + 0.98793905279692 + 0.98652221527820 + 0.98494139505638 + 0.98317333176433 + 0.98119284287323 + 0.97897094527215 + 0.97647508654443 + 0.97366869506685 + 0.97050923040219 + 0.96694813385353 + 0.96293128576716 + 0.95839684150786 + 0.95326690637856 + 0.94745687228301 + 0.94089463930892 + 0.93351755158915 + 0.92526677357770 + 0.91609457102096 + 0.90596577083696 + 0.89486100878452 + 0.88278114076782 + 0.86975263664820 + 0.85583242583888 + 0.84110458166097 + 0.82566431485091 + 0.80963529351614 + 0.79319741885689 + 0.77656095177224 + 0.76822834819939 + 0.75991998650747 + 0.75165487846918 + 0.74344766793540 + 0.73530794340673 + 0.72723976697113 + 0.71924151681426 + 0.71130618130613 + 0.70342210268000 + 0.69557091830440 + 0.68767504052815 + 0.67950760905884 + 0.67095282203077 + 0.66200188371324 + 0.65264889795566 + 0.64291159439226 + 0.63281329575645 + 0.62238147640836 + 0.61164680371086 + 0.60064271053767 + 0.58940388206428 + 0.57794056963463 + 0.56628884621873 + 0.55448806850740 + 0.54258017257241 + 0.53060810026391 + 0.51861339478590 + 0.50661915402502 + 0.49463729597321 + 0.48268146105053 + 0.47075325990186 + 0.45884180620235 + 0.99809157662338 + 0.99809654598897 + 0.99809737297200 + 0.99809833822847 + 0.99809946514536 + 0.99810078116251 + 0.99810231852348 + 0.99810411524909 + 0.99810621676410 + 0.99810868021081 + 0.99811158657657 + 0.99811505188389 + 0.99811921494110 + 0.99812423190969 + 0.99813028766006 + 0.99813760751839 + 0.99814646883486 + 0.99815721497160 + 0.99817028165107 + 0.99818622526963 + 0.99820574102107 + 0.99822971998836 + 0.99825931874844 + 0.99829606314194 + 0.99834201599562 + 0.99840009774954 + 0.99847470023877 + 0.99857251071062 + 0.99870414616122 + 0.99888877630164 + 0.99917131152357 + 1.00000000000000 + 0.99908794413199 + 0.99864629099818 + 0.99825617469786 + 0.99788220085770 + 0.99750740488516 + 0.99711992094328 + 0.99670946438752 + 0.99626612348850 + 0.99578020590498 + 0.99524160233263 + 0.99463957996166 + 0.99396329763135 + 0.99320579342053 + 0.99236390563813 + 0.99142754139189 + 0.99038517972940 + 0.98923129668802 + 0.98795456963855 + 0.98653584405764 + 0.98495340197174 + 0.98318394112029 + 0.98120224572661 + 0.97897930495613 + 0.97648254340146 + 0.97367536995559 + 0.97051522687738 + 0.96695354019739 + 0.96293617692704 + 0.95840128036973 + 0.95327094395827 + 0.94746055005582 + 0.94089799294197 + 0.93352061250383 + 0.92526956932475 + 0.91609712578970 + 0.90596810579740 + 0.89486314240376 + 0.88278308911474 + 0.86975441372746 + 0.85583404398139 + 0.84110605188764 + 0.82566564713096 + 0.80963649738818 + 0.79319850416009 + 0.77656192883524 + 0.76822927501850 + 0.75992086575173 + 0.75165571277719 + 0.74344845988141 + 0.73530869547605 + 0.72724048153290 + 0.71924219609889 + 0.71130682738598 + 0.70342271745550 + 0.69557150348358 + 0.68767559739756 + 0.67950813795960 + 0.67095332287996 + 0.66200235645623 + 0.65264934257865 + 0.64291201100653 + 0.63281368461647 + 0.62238183791893 + 0.61164713843839 + 0.60064301919361 + 0.58940416551210 + 0.57794082880860 + 0.56628908218304 + 0.55448828244241 + 0.54258036576270 + 0.53060827408626 + 0.51861355068718 + 0.50661929347456 + 0.49463742043116 + 0.48268157195442 + 0.47075335862647 + 0.45884189403034 + 0.99790971545862 + 0.99791407204810 + 0.99791479687383 + 0.99791564282839 + 0.99791663037358 + 0.99791778350951 + 0.99791913042647 + 0.99792070435160 + 0.99792254494950 + 0.99792470208757 + 0.99792724636751 + 0.99793027884577 + 0.99793392033254 + 0.99793830655645 + 0.99794359792882 + 0.99794998953647 + 0.99795772089213 + 0.99796708753726 + 0.99797846309566 + 0.99799232241743 + 0.99800925485347 + 0.99803000978581 + 0.99805555001961 + 0.99808712930329 + 0.99812641463852 + 0.99817571838905 + 0.99823843051061 + 0.99831950314628 + 0.99842627606007 + 0.99857057445170 + 0.99877427227190 + 0.99908794413199 + 1.00000000000000 + 0.99899436210865 + 0.99850326282481 + 0.99807161448348 + 0.99765830028731 + 0.99724313309287 + 0.99681182300328 + 0.99635221211911 + 0.99585324881909 + 0.99530395096612 + 0.99469300849491 + 0.99400919646594 + 0.99324531796131 + 0.99239804761794 + 0.99145711775641 + 0.99041087107108 + 0.98925369440784 + 0.98797417124214 + 0.98655305769135 + 0.98496856599014 + 0.98319734003940 + 0.98121412150884 + 0.97898986423904 + 0.97649196361891 + 0.97368380380651 + 0.97052280509369 + 0.96696037412283 + 0.96294236097927 + 0.95840689367692 + 0.95327605063110 + 0.94746520217738 + 0.94090223535181 + 0.93352448476816 + 0.92527310620851 + 0.91610035787603 + 0.90597105990688 + 0.89486584196374 + 0.88278555453982 + 0.86975666281961 + 0.85583609241347 + 0.84110791365663 + 0.82566733489091 + 0.80963802321516 + 0.79319988049872 + 0.77656316872982 + 0.76823045157923 + 0.75992198234536 + 0.75165677272287 + 0.74344946641924 + 0.73530965172615 + 0.72724139046900 + 0.71924306051752 + 0.71130764988104 + 0.70342350040540 + 0.69557224902167 + 0.68767630712451 + 0.67950881226814 + 0.67095396163680 + 0.66200295955483 + 0.65264990997809 + 0.64291254282114 + 0.63281418115037 + 0.62238229967257 + 0.61164756610857 + 0.60064341368186 + 0.58940452790056 + 0.57794116028208 + 0.56628938408516 + 0.55448855626974 + 0.54258061314752 + 0.53060849677584 + 0.51861375051826 + 0.50661947231355 + 0.49463758013474 + 0.48268171434629 + 0.47075348545301 + 0.45884200692223 + 0.99770914272240 + 0.99771294911635 + 0.99771358228330 + 0.99771432121609 + 0.99771518376636 + 0.99771619086636 + 0.99771736709526 + 0.99771874140831 + 0.99772034835799 + 0.99772223134694 + 0.99772445175631 + 0.99772709736067 + 0.99773027302813 + 0.99773409648702 + 0.99773870666802 + 0.99774427226643 + 0.99775099994356 + 0.99775914403830 + 0.99776902508606 + 0.99778104890653 + 0.99779571644341 + 0.99781366055704 + 0.99783568769156 + 0.99786283711147 + 0.99789647267389 + 0.99793845695622 + 0.99799147040576 + 0.99805931470104 + 0.99814736715189 + 0.99826372030486 + 0.99842181216161 + 0.99864629099818 + 0.99899436210865 + 1.00000000000000 + 0.99888923822870 + 0.99834338387423 + 0.99786568127874 + 0.99740808765242 + 0.99694653881026 + 0.99646422125265 + 0.99594754029975 + 0.99538399888874 + 0.99476134030019 + 0.99406773609100 + 0.99329562649322 + 0.99244144105964 + 0.99149466736830 + 0.99044346171637 + 0.98928209007617 + 0.98799901167033 + 0.98657486578760 + 0.98498777392429 + 0.98321431033204 + 0.98122916192138 + 0.97900323728356 + 0.97650389452789 + 0.97369448626877 + 0.97053240480039 + 0.96696903204059 + 0.96295019650093 + 0.95841400675147 + 0.95328252213140 + 0.94747109776448 + 0.94090761160648 + 0.93352939171247 + 0.92527758787419 + 0.91610445307052 + 0.90597480272201 + 0.89486926223127 + 0.88278867827832 + 0.86975951273415 + 0.85583868849272 + 0.84111027374219 + 0.82566947508167 + 0.80963995885425 + 0.79320162736430 + 0.77656474332971 + 0.76823194622941 + 0.75992340129435 + 0.75165812015876 + 0.74345074642394 + 0.73531086823059 + 0.72724254721344 + 0.71924416101231 + 0.71130869738190 + 0.70342449789424 + 0.69557319917109 + 0.68767721192668 + 0.67950967218302 + 0.67095477645217 + 0.66200372910398 + 0.65265063416861 + 0.64291322177885 + 0.63281481523389 + 0.62238288949905 + 0.61164811255230 + 0.60064391787218 + 0.58940499120475 + 0.57794158419679 + 0.56628977031630 + 0.55448890671520 + 0.54258092988015 + 0.53060878201553 + 0.51861400660027 + 0.50661970160865 + 0.49463778500301 + 0.48268189710481 + 0.47075364832187 + 0.45884215197056 + 0.99748742841706 + 0.99749074542208 + 0.99749129710378 + 0.99749194091311 + 0.99749269238772 + 0.99749356974506 + 0.99749459436974 + 0.99749579144832 + 0.99749719102189 + 0.99749883079642 + 0.99750076403116 + 0.99750306679726 + 0.99750582995269 + 0.99750915544358 + 0.99751316346712 + 0.99751799976779 + 0.99752384260077 + 0.99753091087591 + 0.99753947979673 + 0.99754989670490 + 0.99756258851353 + 0.99757809172786 + 0.99759708553350 + 0.99762043792947 + 0.99764927623784 + 0.99768512145269 + 0.99773013209450 + 0.99778730266863 + 0.99786072565685 + 0.99795627734466 + 0.99808309853620 + 0.99825617469786 + 0.99850326282481 + 0.99888923822870 + 1.00000000000000 + 0.99877108567453 + 0.99816454624620 + 0.99763542148467 + 0.99712728873865 + 0.99661194992744 + 0.99607049796496 + 0.99548758320086 + 0.99484929438945 + 0.99414280352906 + 0.99335996546402 + 0.99249682830504 + 0.99154252671909 + 0.99048495601123 + 0.98931821469299 + 0.98803059507456 + 0.98660258206206 + 0.98501217813052 + 0.98323586671869 + 0.98124826378100 + 0.97902021959720 + 0.97651904441892 + 0.97370805045087 + 0.97054459411807 + 0.96698002567344 + 0.96296014602324 + 0.95842303889886 + 0.95329073931954 + 0.94747858311118 + 0.94091443680068 + 0.93353562023140 + 0.92528327569143 + 0.91610964961694 + 0.90597955149633 + 0.89487360135205 + 0.88279264102205 + 0.86976312816306 + 0.85584198218341 + 0.84111326851138 + 0.82567219147971 + 0.80964241642843 + 0.79320384616847 + 0.77656674431636 + 0.76823384614161 + 0.75992520550875 + 0.75165983396981 + 0.74345237498589 + 0.73531241650443 + 0.72724401990856 + 0.71924556255283 + 0.71131003186127 + 0.70342576905744 + 0.69557441036889 + 0.68767836565109 + 0.67951076897110 + 0.67095581598818 + 0.66200471113297 + 0.65265155854186 + 0.64291408861734 + 0.63281562497254 + 0.62238364290005 + 0.61164881071001 + 0.60064456221018 + 0.58940558345393 + 0.57794212625085 + 0.56629026433819 + 0.55448935511686 + 0.54258133529483 + 0.53060914726914 + 0.51861433465985 + 0.50661999548971 + 0.49463804770409 + 0.48268213157130 + 0.47075385737398 + 0.45884233824042 + 0.99724157408360 + 0.99724445941629 + 0.99724493925653 + 0.99724549921146 + 0.99724615278654 + 0.99724691581171 + 0.99724780687094 + 0.99724884784247 + 0.99725006481738 + 0.99725149051585 + 0.99725317108592 + 0.99725517236658 + 0.99725757297708 + 0.99726046111776 + 0.99726394071196 + 0.99726813764688 + 0.99727320568569 + 0.99727933335244 + 0.99728675718883 + 0.99729577500557 + 0.99730675158081 + 0.99732014345351 + 0.99733652554107 + 0.99735662775755 + 0.99738139032220 + 0.99741206981298 + 0.99745043061725 + 0.99749887950070 + 0.99756062083397 + 0.99764009947188 + 0.99774392665978 + 0.99788220085770 + 0.99807161448348 + 0.99834338387423 + 0.99877108567453 + 1.00000000000000 + 0.99863822328908 + 0.99796425374898 + 0.99737696323143 + 0.99681054958214 + 0.99623300372097 + 0.99562296864762 + 0.99496339207688 + 0.99423968045525 + 0.99344269406085 + 0.99256786060204 + 0.99160378756156 + 0.99053799410261 + 0.98936434051024 + 0.98807089070898 + 0.98663792284798 + 0.98504328153544 + 0.98326333068620 + 0.98127259352538 + 0.97904184464196 + 0.97653833246663 + 0.97372531712182 + 0.97056010885382 + 0.96699401717198 + 0.96297280749188 + 0.95843453168209 + 0.95330119365534 + 0.94748810464272 + 0.94092311672780 + 0.93354353943295 + 0.92529050560708 + 0.91611625344036 + 0.90598558493205 + 0.89487911328294 + 0.88279767416761 + 0.86976771983622 + 0.85584616523975 + 0.84111707222002 + 0.82567564216625 + 0.80964553906946 + 0.79320666633055 + 0.77656928864957 + 0.76823626250953 + 0.75992750073133 + 0.75166201475551 + 0.74345444785874 + 0.73531438773248 + 0.72724589544568 + 0.71924734797316 + 0.71131173232951 + 0.70342738928251 + 0.69557595456808 + 0.68767983694263 + 0.67951216798481 + 0.67095714227332 + 0.66200596431762 + 0.65265273839267 + 0.64291519525875 + 0.63281665892821 + 0.62238460511368 + 0.61164970256090 + 0.60064538549336 + 0.58940634035978 + 0.57794281918429 + 0.56629089604620 + 0.55448992866537 + 0.54258185403424 + 0.53060961479168 + 0.51861475474255 + 0.50662037196814 + 0.49463838438999 + 0.48268243220912 + 0.47075412554999 + 0.45884257729695 + 0.99696791771694 + 0.99697042495634 + 0.99697084189445 + 0.99697132843488 + 0.99697189631007 + 0.99697255926657 + 0.99697333344406 + 0.99697423783735 + 0.99697529509294 + 0.99697653359438 + 0.99697799329974 + 0.99697973115011 + 0.99698181513767 + 0.99698432154361 + 0.99698734021577 + 0.99699097991075 + 0.99699537334394 + 0.99700068301820 + 0.99700711252129 + 0.99701491769405 + 0.99702441107917 + 0.99703598258108 + 0.99705012119703 + 0.99706744455675 + 0.99708874315029 + 0.99711506569291 + 0.99714787277101 + 0.99718913117835 + 0.99724140756835 + 0.99730817073866 + 0.99739441576480 + 0.99750740488516 + 0.99765830028731 + 0.99786568127874 + 0.99816454624620 + 0.99863822328908 + 1.00000000000000 + 0.99848872895069 + 0.99773916043820 + 0.99708539426285 + 0.99645187288988 + 0.99580227581045 + 0.99511287047025 + 0.99436567364725 + 0.99354974532811 + 0.99265945080582 + 0.99168257575766 + 0.99060607787460 + 0.98942346783595 + 0.98812248984542 + 0.98668314052962 + 0.98508305219380 + 0.98329842954358 + 0.98130367339814 + 0.97906945923295 + 0.97656295499756 + 0.97374735325997 + 0.97057990446666 + 0.96701186542147 + 0.96298895569674 + 0.95844918610766 + 0.95331452060462 + 0.94750023896894 + 0.94093417494160 + 0.93355362500525 + 0.92529971007714 + 0.91612465791106 + 0.90599326100676 + 0.89488612387466 + 0.88280407431265 + 0.86977355763449 + 0.85585148302651 + 0.84112190768205 + 0.82568002913671 + 0.80964950956441 + 0.79321025303295 + 0.77657252554378 + 0.76823933717044 + 0.75993042182255 + 0.75166479079342 + 0.74345708711880 + 0.73531689815827 + 0.72724828456995 + 0.71924962284731 + 0.71131389946897 + 0.70342945463292 + 0.69557792343896 + 0.68768171325286 + 0.67951395247848 + 0.67095883431966 + 0.66200756339119 + 0.65265424415201 + 0.64291660782253 + 0.63281797893488 + 0.62238583374519 + 0.61165084154932 + 0.60064643711281 + 0.58940730738932 + 0.57794370467584 + 0.56629170349375 + 0.55449066196974 + 0.54258251746169 + 0.53061021291440 + 0.51861529236734 + 0.50662085397551 + 0.49463881562569 + 0.48268281743680 + 0.47075446932685 + 0.45884288387525 + 0.99666204953624 + 0.99666422738993 + 0.99666458954243 + 0.99666501214890 + 0.99666550539547 + 0.99666608122274 + 0.99666675364041 + 0.99666753914707 + 0.99666845739792 + 0.99666953300979 + 0.99667080058909 + 0.99667230937023 + 0.99667411814831 + 0.99667629291292 + 0.99667891136777 + 0.99668206752925 + 0.99668587603666 + 0.99669047713429 + 0.99669604632400 + 0.99670280383091 + 0.99671101816155 + 0.99672102345905 + 0.99673323748824 + 0.99674818580795 + 0.99676653775529 + 0.99678917631175 + 0.99681732366300 + 0.99685260953051 + 0.99689712845250 + 0.99695365607053 + 0.99702609529379 + 0.99711992094328 + 0.99724313309287 + 0.99740808765242 + 0.99763542148467 + 0.99796425374898 + 0.99848872895069 + 1.00000000000000 + 0.99831988266489 + 0.99748494790930 + 0.99675524764615 + 0.99604421467079 + 0.99531127216454 + 0.99453113876714 + 0.99368933817649 + 0.99277829830005 + 0.99178445498096 + 0.99069389138927 + 0.98949958584394 + 0.98818882231673 + 0.98674120601474 + 0.98513407878713 + 0.98334343015543 + 0.98134349727111 + 0.97910482446881 + 0.97659447396352 + 0.97377554999049 + 0.97060522505788 + 0.96703468738976 + 0.96300959702336 + 0.95846791162340 + 0.95333154360684 + 0.94751573234629 + 0.94094828819068 + 0.93356649105066 + 0.92531144668341 + 0.91613536957750 + 0.90600304012285 + 0.89489505171811 + 0.88281222204810 + 0.86978098748477 + 0.85585824974949 + 0.84112805996321 + 0.82568561061176 + 0.80965456140869 + 0.79321481714670 + 0.77657664537708 + 0.76824325103455 + 0.75993414075478 + 0.75166832563192 + 0.74346044838107 + 0.73532009592896 + 0.72725132840282 + 0.71925252167540 + 0.71131666153979 + 0.70343208746241 + 0.69558043373545 + 0.68768410594492 + 0.67951622845405 + 0.67096099271005 + 0.66200960347284 + 0.65265616544508 + 0.64291841044416 + 0.63281966366332 + 0.62238740206382 + 0.61165229564737 + 0.60064777987562 + 0.58940854234827 + 0.57794483571275 + 0.56629273505568 + 0.55449159902537 + 0.54258336544362 + 0.53061097764923 + 0.51861597997283 + 0.50662147066162 + 0.49463936756045 + 0.48268331067434 + 0.47075490966201 + 0.45884327671158 + 0.99631853886686 + 0.99632043069647 + 0.99632074528483 + 0.99632111238614 + 0.99632154084748 + 0.99632204104134 + 0.99632262513627 + 0.99632330746094 + 0.99632410508278 + 0.99632503936540 + 0.99632614027988 + 0.99632745041110 + 0.99632902061597 + 0.99633090799998 + 0.99633317980874 + 0.99633591736769 + 0.99633921980202 + 0.99634320828960 + 0.99634803434469 + 0.99635388788910 + 0.99636100015016 + 0.99636965835532 + 0.99638022076749 + 0.99639313675095 + 0.99640897646508 + 0.99642848884433 + 0.99645270571051 + 0.99648299288286 + 0.99652108565591 + 0.99656924997072 + 0.99663061673841 + 0.99670946438752 + 0.99681182300328 + 0.99694653881026 + 0.99712728873865 + 0.99737696323143 + 0.99773916043820 + 0.99831988266489 + 1.00000000000000 + 0.99812850474987 + 0.99719721057039 + 0.99638026738465 + 0.99557965207795 + 0.99475139980679 + 0.99387325169488 + 0.99293380149365 + 0.99191711610945 + 0.99080784223577 + 0.98959811076759 + 0.98827451960825 + 0.98681611495718 + 0.98519983235065 + 0.98340136491967 + 0.98139472743007 + 0.97915028826074 + 0.97663496910374 + 0.97381175757603 + 0.97063772373463 + 0.96706396594024 + 0.96303606642518 + 0.95849191363520 + 0.95335335317495 + 0.94753557226264 + 0.94096635121225 + 0.93358294877660 + 0.92532645132303 + 0.91614905639442 + 0.90601552886093 + 0.89490644784384 + 0.88282261798319 + 0.86979046407598 + 0.85586687811875 + 0.84113590329328 + 0.82569272540401 + 0.80966100082983 + 0.79322063512356 + 0.77658189765869 + 0.76824824117431 + 0.75993888285906 + 0.75167283353578 + 0.74346473549402 + 0.73532417509684 + 0.72725521177842 + 0.71925622061260 + 0.71132018650970 + 0.70343544799498 + 0.69558363833251 + 0.68768716083267 + 0.67951913469664 + 0.67096374913351 + 0.66201220909463 + 0.65265861960372 + 0.64292071324711 + 0.63282181607776 + 0.62238940596247 + 0.61165415381097 + 0.60064949597271 + 0.58941012087841 + 0.57794628162702 + 0.56629405402742 + 0.55449279739715 + 0.54258445014924 + 0.53061195611749 + 0.51861686000854 + 0.50662226018206 + 0.49464007441926 + 0.48268394258160 + 0.47075547399361 + 0.45884378034599 + 0.99593086190687 + 0.99593250571449 + 0.99593277906126 + 0.99593309803639 + 0.99593347032835 + 0.99593390494924 + 0.99593441247356 + 0.99593500535087 + 0.99593569840701 + 0.99593651019032 + 0.99593746666883 + 0.99593860469103 + 0.99593996825986 + 0.99594160681879 + 0.99594357859027 + 0.99594595397652 + 0.99594881874641 + 0.99595227771314 + 0.99595646184176 + 0.99596153516448 + 0.99596769719065 + 0.99597519540362 + 0.99598433797418 + 0.99599551057379 + 0.99600920119079 + 0.99602604876401 + 0.99604693050951 + 0.99607300129463 + 0.99610571592525 + 0.99614695343044 + 0.99619927710272 + 0.99626612348850 + 0.99635221211911 + 0.99646422125265 + 0.99661194992744 + 0.99681054958214 + 0.99708539426285 + 0.99748494790930 + 0.99812850474987 + 1.00000000000000 + 0.99791185612462 + 0.99687093447353 + 0.99595340798638 + 0.99505028993774 + 0.99411894813500 + 0.99313947028442 + 0.99209138773259 + 0.99095682312110 + 0.98972648327316 + 0.98838589793861 + 0.98691328736432 + 0.98528500251521 + 0.98347631841007 + 0.98146094141660 + 0.97920899973388 + 0.97668722553642 + 0.97385845056880 + 0.97067960886434 + 0.96710168001202 + 0.96307014378736 + 0.95852279788070 + 0.95338140073099 + 0.94756107183609 + 0.94098955272429 + 0.93360407490992 + 0.92534569986063 + 0.91616660330378 + 0.90603153012039 + 0.89492104098051 + 0.88283592361599 + 0.86980258775266 + 0.85587791267584 + 0.84114593110466 + 0.82570181999520 + 0.80966923117397 + 0.79322807092639 + 0.77658861074732 + 0.76825461953135 + 0.75994494458578 + 0.75167859635821 + 0.74347021657716 + 0.73532939086518 + 0.72726017775190 + 0.71926095127767 + 0.71132469520906 + 0.70343974686990 + 0.69558773819130 + 0.68769106957718 + 0.67952285361235 + 0.67096727664528 + 0.66201554388664 + 0.65266176077635 + 0.64292366090367 + 0.63282457143153 + 0.62239197138788 + 0.61165653285506 + 0.60065169332559 + 0.58941214229702 + 0.57794813344371 + 0.56629574350594 + 0.55449433265259 + 0.54258584005640 + 0.53061321018127 + 0.51861798820791 + 0.50662327262876 + 0.49464098114383 + 0.48268475342185 + 0.47075619836247 + 0.45884442701436 + 0.99549174255368 + 0.99549317138671 + 0.99549340898906 + 0.99549368625060 + 0.99549400986008 + 0.99549438764902 + 0.99549482880970 + 0.99549534416320 + 0.99549594659756 + 0.99549665221960 + 0.99549748354151 + 0.99549847245784 + 0.99549965705879 + 0.99550108017417 + 0.99550279223253 + 0.99550485420956 + 0.99550734037453 + 0.99551034144652 + 0.99551397072618 + 0.99551837004647 + 0.99552371178309 + 0.99553020955847 + 0.99553812904330 + 0.99554780217782 + 0.99555964810534 + 0.99557421431020 + 0.99559225049575 + 0.99561473971697 + 0.99564291264738 + 0.99567834609628 + 0.99572317121672 + 0.99578020590498 + 0.99585324881909 + 0.99594754029975 + 0.99607049796496 + 0.99623300372097 + 0.99645187288988 + 0.99675524764615 + 0.99719721057039 + 0.99791185612462 + 1.00000000000000 + 0.99766611347030 + 0.99649992299565 + 0.99546741983821 + 0.99445327094097 + 0.99341509943071 + 0.99232264647326 + 0.99115319368869 + 0.98989488967730 + 0.98853151013756 + 0.98704000299882 + 0.98539584894597 + 0.98357371602847 + 0.98154687232713 + 0.97928511141050 + 0.97675490539076 + 0.97391887466036 + 0.97073377055158 + 0.96715041415554 + 0.96311414922602 + 0.95856265359076 + 0.95341757129654 + 0.94759393337542 + 0.94101943093111 + 0.93363126021441 + 0.92537045044868 + 0.91618914915311 + 0.90605207530055 + 0.89493976560004 + 0.88285298575647 + 0.86981812579873 + 0.85589204831014 + 0.84115877217344 + 0.82571346255988 + 0.80967976506477 + 0.79323758657901 + 0.77659720101683 + 0.76826278145293 + 0.75995270145486 + 0.75168597096144 + 0.74347723094993 + 0.73533606606374 + 0.72726653366048 + 0.71926700642909 + 0.71133046666225 + 0.70344525012455 + 0.69559298704083 + 0.68769607408239 + 0.67952761534666 + 0.67097179352197 + 0.66201981415798 + 0.65266578325318 + 0.64292743568658 + 0.63282810005796 + 0.62239525689731 + 0.61165957979173 + 0.60065450770188 + 0.58941473149564 + 0.57795050558872 + 0.56629790791260 + 0.55449629972843 + 0.54258762117288 + 0.53061481751534 + 0.51861943452931 + 0.50662457087405 + 0.49464214413234 + 0.48268579372208 + 0.47075712798879 + 0.45884525716175 + 0.99499286047974 + 0.99499410283595 + 0.99499430942920 + 0.99499455050908 + 0.99499483188565 + 0.99499516037241 + 0.99499554396363 + 0.99499599206466 + 0.99499651588285 + 0.99499712940781 + 0.99499785216570 + 0.99499871176862 + 0.99499974120023 + 0.99500097756271 + 0.99500246455315 + 0.99500425499612 + 0.99500641321558 + 0.99500901776919 + 0.99501216672319 + 0.99501598278917 + 0.99502061502146 + 0.99502624801258 + 0.99503311111449 + 0.99504149054930 + 0.99505174718770 + 0.99506435155473 + 0.99507994669736 + 0.99509937339526 + 0.99512367941938 + 0.99515419941909 + 0.99519272519740 + 0.99524160233263 + 0.99530395096612 + 0.99538399888874 + 0.99548758320086 + 0.99562296864762 + 0.99580227581045 + 0.99604421467079 + 0.99638026738465 + 0.99687093447353 + 0.99766611347030 + 1.00000000000000 + 0.99738690576258 + 0.99607831981785 + 0.99492102957740 + 0.99379133892327 + 0.99263362430561 + 0.99141467930684 + 0.99011763905636 + 0.98872319688114 + 0.98720623427702 + 0.98554087966922 + 0.98370088791562 + 0.98165888511970 + 0.97938418657918 + 0.97684289982647 + 0.97399735355538 + 0.97080405017525 + 0.96721359680186 + 0.96317115481931 + 0.95861424244846 + 0.95346435253350 + 0.94763639976551 + 0.94105800922196 + 0.93366633113359 + 0.92540235270545 + 0.91621818471715 + 0.90607851237543 + 0.89496384109867 + 0.88287490775899 + 0.86983807650955 + 0.85591018789763 + 0.84117524242460 + 0.82572838950367 + 0.80969326616143 + 0.79324977959631 + 0.77660820641405 + 0.76827323748950 + 0.75996263820239 + 0.75169541779566 + 0.74348621624520 + 0.73534461690587 + 0.72727467558731 + 0.71927476322878 + 0.71133786020415 + 0.70345230026592 + 0.69559971143708 + 0.68770248558650 + 0.67953371591284 + 0.67097758041156 + 0.66202528508447 + 0.65267093666160 + 0.64293227169762 + 0.63283262065053 + 0.62239946598432 + 0.61166348322536 + 0.60065811321974 + 0.58941804859158 + 0.57795354470962 + 0.56630068102876 + 0.55449882020918 + 0.54258990361905 + 0.53061687754357 + 0.51862128850829 + 0.50662623536695 + 0.49464363553852 + 0.48268712811024 + 0.47075832070984 + 0.45884632251664 + 0.99442481563193 + 0.99442589599087 + 0.99442607564349 + 0.99442628528561 + 0.99442652997125 + 0.99442681562368 + 0.99442714919257 + 0.99442753885751 + 0.99442799436559 + 0.99442852786521 + 0.99442915629508 + 0.99442990356285 + 0.99443079823266 + 0.99443187244633 + 0.99443316406716 + 0.99443471885462 + 0.99443659252050 + 0.99443885309216 + 0.99444158545525 + 0.99444489578882 + 0.99444891302026 + 0.99445379672311 + 0.99445974502957 + 0.99446700497640 + 0.99447588767994 + 0.99448679824405 + 0.99450028948672 + 0.99451708267733 + 0.99453807372510 + 0.99456439898685 + 0.99459757669543 + 0.99463957996166 + 0.99469300849491 + 0.99476134030019 + 0.99484929438945 + 0.99496339207688 + 0.99511287047025 + 0.99531127216454 + 0.99557965207795 + 0.99595340798638 + 0.99649992299565 + 0.99738690576258 + 1.00000000000000 + 0.99707082498793 + 0.99560749084588 + 0.99431936210853 + 0.99305956740957 + 0.99176752919718 + 0.99041529060486 + 0.98897762124049 + 0.98742580918977 + 0.98573176477873 + 0.98386780656774 + 0.98180558447717 + 0.97951370839918 + 0.97695776103490 + 0.97409965957506 + 0.97089556125154 + 0.96729578018453 + 0.96324523035196 + 0.95868121532746 + 0.95352502643701 + 0.94769142423847 + 0.94110794661519 + 0.93371168321178 + 0.92544356606631 + 0.91625565775733 + 0.90611259919557 + 0.89499485470523 + 0.88290312321460 + 0.86986373474203 + 0.85593350060516 + 0.84119639679135 + 0.82574755154506 + 0.80971059007362 + 0.79326541930588 + 0.77662231870926 + 0.76828664378615 + 0.75997537743790 + 0.75170752795711 + 0.74349773397257 + 0.73535557713225 + 0.72728511121773 + 0.71928470487450 + 0.71134733599008 + 0.70346133570218 + 0.69560832919124 + 0.68771070214321 + 0.67954153373525 + 0.67098499593484 + 0.66203229535913 + 0.65267753969227 + 0.64293846766699 + 0.63283841213914 + 0.62240485807069 + 0.61166848347649 + 0.60066273162824 + 0.58942229740521 + 0.57795743739072 + 0.56630423299477 + 0.55450204866138 + 0.54259282732424 + 0.53061951655948 + 0.51862366382996 + 0.50662836822282 + 0.49464554692406 + 0.48268883858039 + 0.47075984989043 + 0.45884768867946 + 0.99377774025322 + 0.99377867972365 + 0.99377883594732 + 0.99377901824732 + 0.99377923101906 + 0.99377947941217 + 0.99377976947110 + 0.99378010830658 + 0.99378050438791 + 0.99378096827412 + 0.99378151464990 + 0.99378216422487 + 0.99378294173309 + 0.99378387501923 + 0.99378499688220 + 0.99378634695968 + 0.99378797349753 + 0.99378993538591 + 0.99379230609712 + 0.99379517750192 + 0.99379866110394 + 0.99380289486092 + 0.99380804996647 + 0.99381433972997 + 0.99382203255487 + 0.99383147756117 + 0.99384315062366 + 0.99385767166929 + 0.99387580890328 + 0.99389853368045 + 0.99392713927824 + 0.99396329763135 + 0.99400919646594 + 0.99406773609100 + 0.99414280352906 + 0.99423968045525 + 0.99436567364725 + 0.99453113876714 + 0.99475139980679 + 0.99505028993774 + 0.99546741983821 + 0.99607831981785 + 0.99707082498793 + 1.00000000000000 + 0.99672330798788 + 0.99509567091745 + 0.99365871064026 + 0.99225194016263 + 0.99081785475452 + 0.98931833410361 + 0.98771782952569 + 0.98598435495052 + 0.98408784267129 + 0.98199838954629 + 0.97968352496989 + 0.97710805173513 + 0.97423329105385 + 0.97101491136779 + 0.96740281877520 + 0.96334158701436 + 0.95876822778291 + 0.95360376154677 + 0.94776274309696 + 0.94117259412840 + 0.93377032376851 + 0.92549679099831 + 0.91630399470699 + 0.90615651731439 + 0.89503476887873 + 0.88293939818382 + 0.86989669001710 + 0.85596341681165 + 0.84122352171751 + 0.82577210447135 + 0.80973277391028 + 0.79328543561671 + 0.77664037186081 + 0.76830379035790 + 0.75999166788743 + 0.75172301143299 + 0.74351245781616 + 0.73536958641856 + 0.72729844836031 + 0.71929740928601 + 0.71135944384664 + 0.70347287979889 + 0.69561933864473 + 0.68772119811651 + 0.67955151939525 + 0.67099446673807 + 0.66204124756315 + 0.65268597081238 + 0.64294637803076 + 0.63284580516675 + 0.62241174038559 + 0.61167486489779 + 0.60066862506945 + 0.58942771865929 + 0.57796240380114 + 0.56630876438852 + 0.55450616713554 + 0.54259655695880 + 0.53062288305401 + 0.51862669405845 + 0.50663108931874 + 0.49464798569815 + 0.48269102125396 + 0.47076180147972 + 0.45884943246197 + 0.99304529736781 + 0.99304611458541 + 0.99304625047519 + 0.99304640904626 + 0.99304659412063 + 0.99304681017715 + 0.99304706247143 + 0.99304735718715 + 0.99304770168513 + 0.99304810514037 + 0.99304858030094 + 0.99304914511482 + 0.99304982101698 + 0.99305063214568 + 0.99305160693143 + 0.99305277972736 + 0.99305419233340 + 0.99305589576096 + 0.99305795363783 + 0.99306044549230 + 0.99306346782636 + 0.99306713999036 + 0.99307161000917 + 0.99307706222945 + 0.99308372845010 + 0.99309190994221 + 0.99310201700980 + 0.99311458356559 + 0.99313027007757 + 0.99314990974261 + 0.99317460915545 + 0.99320579342053 + 0.99324531796131 + 0.99329562649322 + 0.99335996546402 + 0.99344269406085 + 0.99354974532811 + 0.99368933817649 + 0.99387325169488 + 0.99411894813500 + 0.99445327094097 + 0.99492102957740 + 0.99560749084588 + 0.99672330798788 + 1.00000000000000 + 0.99635092525587 + 0.99453532302888 + 0.99292994571114 + 0.99136762206298 + 0.98977653027133 + 0.98810646818148 + 0.98631800532891 + 0.98437685097024 + 0.98225050475912 + 0.97990477305709 + 0.97730326078721 + 0.97440640251899 + 0.97116915985615 + 0.96754086151208 + 0.96346560762986 + 0.95888000976932 + 0.95370472315747 + 0.94785402730453 + 0.94125518812834 + 0.93384510679739 + 0.92556454493432 + 0.91636541681908 + 0.90621222740997 + 0.89508531504418 + 0.88298526226252 + 0.86993829402989 + 0.85600113113637 + 0.84125767286639 + 0.82580298062426 + 0.80976064050711 + 0.79331055462046 + 0.77666300715040 + 0.76832528023375 + 0.76001207698648 + 0.75174240258315 + 0.74353089142922 + 0.73538711992281 + 0.72731513571345 + 0.71931330057966 + 0.71137458501160 + 0.70348731243636 + 0.69563309967884 + 0.68773431441710 + 0.67956399516648 + 0.67100629649750 + 0.66205242686504 + 0.65269649681415 + 0.64295625143497 + 0.63285503056127 + 0.62242032637128 + 0.61168282406580 + 0.60067597387111 + 0.58943447713035 + 0.57796859388877 + 0.56631441112450 + 0.55451129835880 + 0.54260120295127 + 0.53062707608523 + 0.51863046781800 + 0.50663447778173 + 0.49465102238955 + 0.48269373892997 + 0.47076423136220 + 0.45885160358105 + 0.99222479943614 + 0.99222551092885 + 0.99222562923246 + 0.99222576728087 + 0.99222592839914 + 0.99222611648547 + 0.99222633611221 + 0.99222659265990 + 0.99222689253486 + 0.99222724371525 + 0.99222765727728 + 0.99222814881550 + 0.99222873694544 + 0.99222944262995 + 0.99223029055638 + 0.99223131054326 + 0.99223253887523 + 0.99223401981813 + 0.99223580856683 + 0.99223797410035 + 0.99224060008699 + 0.99224378996597 + 0.99224767198676 + 0.99225240578110 + 0.99225819196022 + 0.99226529111101 + 0.99227405797787 + 0.99228495380825 + 0.99229854838310 + 0.99231555925670 + 0.99233693777752 + 0.99236390563813 + 0.99239804761794 + 0.99244144105964 + 0.99249682830504 + 0.99256786060204 + 0.99265945080582 + 0.99277829830005 + 0.99293380149365 + 0.99313947028442 + 0.99341509943071 + 0.99379133892327 + 0.99431936210853 + 0.99509567091745 + 0.99635092525587 + 1.00000000000000 + 0.99593719253583 + 0.99391118845030 + 0.99212856160004 + 0.99039493445768 + 0.98862255591096 + 0.98675607033991 + 0.98475310282819 + 0.98257654915702 + 0.98018934148580 + 0.97755317809080 + 0.97462713652180 + 0.97136513379905 + 0.96771566830020 + 0.96362217332099 + 0.95902070832794 + 0.95383143606162 + 0.94796826843509 + 0.94135826155356 + 0.93393817072595 + 0.92564862719773 + 0.91644143252728 + 0.90628098903655 + 0.89514754048400 + 0.88304158232454 + 0.86998926086490 + 0.85604722876614 + 0.84129932706354 + 0.82584056601979 + 0.80979450010707 + 0.79334102385825 + 0.77669042077677 + 0.76835128766882 + 0.76003675929239 + 0.75176583833453 + 0.74355315598731 + 0.73540828477960 + 0.72733526792085 + 0.71933246229624 + 0.71139283316617 + 0.70350469855441 + 0.69564966946948 + 0.68775010126169 + 0.67957900484152 + 0.67102052301284 + 0.66206586549859 + 0.65270914478926 + 0.64296811026101 + 0.63286610642699 + 0.62243063028626 + 0.61169237181268 + 0.60068478584173 + 0.58944257798394 + 0.57797601053113 + 0.56632117412122 + 0.55451744160010 + 0.54260676320791 + 0.53063209245891 + 0.51863498105836 + 0.50663852891826 + 0.49465465186475 + 0.48269698620553 + 0.47076713401317 + 0.45885419651196 + 0.99130673246762 + 0.99130735235332 + 0.99130745541895 + 0.99130757568186 + 0.99130771603866 + 0.99130787988609 + 0.99130807120159 + 0.99130829467268 + 0.99130855587148 + 0.99130886174191 + 0.99130922192946 + 0.99130965000626 + 0.99131016217731 + 0.99131077668318 + 0.99131151499509 + 0.99131240305155 + 0.99131347239674 + 0.99131476151531 + 0.99131631838229 + 0.99131820293874 + 0.99132048787109 + 0.99132326300560 + 0.99132663967148 + 0.99133075638385 + 0.99133578713381 + 0.99134195784033 + 0.99134957602669 + 0.99135904133472 + 0.99137084686390 + 0.99138561273531 + 0.99140416014930 + 0.99142754139189 + 0.99145711775641 + 0.99149466736830 + 0.99154252671909 + 0.99160378756156 + 0.99168257575766 + 0.99178445498096 + 0.99191711610945 + 0.99209138773259 + 0.99232264647326 + 0.99263362430561 + 0.99305956740957 + 0.99365871064026 + 0.99453532302888 + 0.99593719253583 + 1.00000000000000 + 0.99547585004252 + 0.99322746740620 + 0.99124890322959 + 0.98931714750626 + 0.98733583495495 + 0.98524514595348 + 0.98299908689933 + 0.98055547169211 + 0.97787280243462 + 0.97490799134512 + 0.97161335948407 + 0.96793617924199 + 0.96381892520235 + 0.95919688271580 + 0.95398954290718 + 0.94811032224625 + 0.94148599112302 + 0.93405310547901 + 0.92575212039186 + 0.91653468611490 + 0.90636506820817 + 0.89522338522168 + 0.88311001783325 + 0.87005100880052 + 0.85610292080544 + 0.84134951759002 + 0.82588574120595 + 0.80983510223854 + 0.79337748109127 + 0.77672315592888 + 0.76838231432724 + 0.76006617850912 + 0.75179374773783 + 0.74357964894523 + 0.73543344965179 + 0.72735918741324 + 0.71935521295048 + 0.71141448500072 + 0.70352531487962 + 0.69566930642883 + 0.68776880005155 + 0.67959677347277 + 0.67103735538709 + 0.66208175704005 + 0.65272409323278 + 0.64298211843087 + 0.63287918268259 + 0.62244278866425 + 0.61170363195511 + 0.60069517278613 + 0.58945212174092 + 0.57798474369019 + 0.56632913352718 + 0.55452466794222 + 0.54261330050468 + 0.53063798740330 + 0.51864028220867 + 0.50664328509092 + 0.49465891110174 + 0.48270079532657 + 0.47077053754361 + 0.45885723577120 + 0.99028004917805 + 0.99028058957516 + 0.99028067941647 + 0.99028078424703 + 0.99028090658932 + 0.99028104940139 + 0.99028121614992 + 0.99028141091377 + 0.99028163854739 + 0.99028190510104 + 0.99028221897900 + 0.99028259202581 + 0.99028303837753 + 0.99028357393276 + 0.99028421740688 + 0.99028499140010 + 0.99028592339471 + 0.99028704691194 + 0.99028840373111 + 0.99029004605431 + 0.99029203715135 + 0.99029445519689 + 0.99029739703035 + 0.99030098310465 + 0.99030536464818 + 0.99031073799682 + 0.99031737046600 + 0.99032560933500 + 0.99033588263993 + 0.99034872805109 + 0.99036485703580 + 0.99038517972940 + 0.99041087107108 + 0.99044346171637 + 0.99048495601123 + 0.99053799410261 + 0.99060607787460 + 0.99069389138927 + 0.99080784223577 + 0.99095682312110 + 0.99115319368869 + 0.99141467930684 + 0.99176752919718 + 0.99225194016263 + 0.99292994571114 + 0.99391118845030 + 0.99547585004252 + 1.00000000000000 + 0.99497766460514 + 0.99248075848338 + 0.99027470676637 + 0.98811430547961 + 0.98589440909868 + 0.98354967258267 + 0.98102797592638 + 0.97828210008281 + 0.97526531892716 + 0.97192741286425 + 0.96821378404313 + 0.96406549245640 + 0.95941671549558 + 0.95418601429618 + 0.94828612906592 + 0.94164343574573 + 0.93419421428297 + 0.92587867924924 + 0.91664827604178 + 0.90646708682539 + 0.89531506360710 + 0.88319243528007 + 0.87012510799340 + 0.85616952548085 + 0.84140934884383 + 0.82593942925747 + 0.80988321658482 + 0.79342056709197 + 0.77676174598004 + 0.76841884701456 + 0.76010077922473 + 0.75182653717390 + 0.74361074216215 + 0.73546295523919 + 0.72738720677943 + 0.71938183977110 + 0.71143980484158 + 0.70354940503410 + 0.69569223540427 + 0.68779061841167 + 0.67961749235068 + 0.67105696920455 + 0.66210026199775 + 0.65274148822317 + 0.64299840828620 + 0.63289437866460 + 0.62245690860316 + 0.61171670013405 + 0.60070721968363 + 0.58946318352206 + 0.57799485939859 + 0.56633834704612 + 0.55453302751773 + 0.54262085814380 + 0.53064479811049 + 0.51864640305671 + 0.50664877334366 + 0.49466382303187 + 0.48270518568369 + 0.47077445832985 + 0.45886073518269 + 0.98913954452647 + 0.98914001612002 + 0.98914009451502 + 0.98914018598646 + 0.98914029273412 + 0.98914041733930 + 0.98914056281886 + 0.98914073273326 + 0.98914093131286 + 0.98914116383119 + 0.98914143763380 + 0.98914176308581 + 0.98914215255428 + 0.98914261994116 + 0.98914318160230 + 0.98914385728274 + 0.98914467099560 + 0.98914565201652 + 0.98914683684713 + 0.98914827108661 + 0.98915000997951 + 0.98915212176429 + 0.98915469095019 + 0.98915782260393 + 0.98916164859217 + 0.98916634013128 + 0.98917213046350 + 0.98917932258192 + 0.98918828954343 + 0.98919949946654 + 0.98921357151794 + 0.98923129668802 + 0.98925369440784 + 0.98928209007617 + 0.98931821469299 + 0.98936434051024 + 0.98942346783595 + 0.98949958584394 + 0.98959811076759 + 0.98972648327316 + 0.98989488967730 + 0.99011763905636 + 0.99041529060486 + 0.99081785475452 + 0.99136762206298 + 0.99212856160004 + 0.99322746740620 + 0.99497766460514 + 1.00000000000000 + 0.99442664796312 + 0.99164349022300 + 0.98917664617352 + 0.98675644848706 + 0.98426729903032 + 0.98163552013182 + 0.97880282249176 + 0.97571600434954 + 0.97232061987054 + 0.96855912024591 + 0.96437042369976 + 0.95968709150758 + 0.95442638157262 + 0.94850010305353 + 0.94183408149173 + 0.93436421071276 + 0.92603037461811 + 0.91678373997223 + 0.90658814244807 + 0.89542331258365 + 0.88328927902418 + 0.87021176836306 + 0.85624706785075 + 0.84147870314516 + 0.82600140521173 + 0.80993854049315 + 0.79346992585924 + 0.77680580115195 + 0.76846048506306 + 0.76014015324132 + 0.75186379384851 + 0.74364602079341 + 0.73549638684219 + 0.72741891336604 + 0.71941193378508 + 0.71146838881526 + 0.70357657145389 + 0.69571806619523 + 0.68781517449958 + 0.67964078923736 + 0.67107900316756 + 0.66212103127735 + 0.65276099403264 + 0.64301665847639 + 0.63291138823200 + 0.62247269981283 + 0.61173130236952 + 0.60072066911179 + 0.58947552251504 + 0.57800613336601 + 0.56634860664190 + 0.55454232811691 + 0.54262925917156 + 0.53065236219961 + 0.51865319500870 + 0.50665485804539 + 0.49466926412978 + 0.48271004500503 + 0.47077879450250 + 0.45886460246797 + 0.98787424065422 + 0.98787465269842 + 0.98787472118629 + 0.98787480109601 + 0.98787489434679 + 0.98787500318949 + 0.98787513026470 + 0.98787527866979 + 0.98787545210149 + 0.98787565516373 + 0.98787589429131 + 0.98787617858360 + 0.98787651889663 + 0.98787692742417 + 0.98787741849682 + 0.98787800942344 + 0.98787872124923 + 0.98787957962509 + 0.98788061654227 + 0.98788187196797 + 0.98788339430661 + 0.98788524332696 + 0.98788749302580 + 0.98789023537243 + 0.98789358576079 + 0.98789769404921 + 0.98790276459353 + 0.98790906289155 + 0.98791691547093 + 0.98792673165748 + 0.98793905279692 + 0.98795456963855 + 0.98797417124214 + 0.98799901167033 + 0.98803059507456 + 0.98807089070898 + 0.98812248984542 + 0.98818882231673 + 0.98827451960825 + 0.98838589793861 + 0.98853151013756 + 0.98872319688114 + 0.98897762124049 + 0.98931833410361 + 0.98977653027133 + 0.99039493445768 + 0.99124890322959 + 0.99248075848338 + 0.99442664796312 + 1.00000000000000 + 0.99379851456251 + 0.99068939014545 + 0.98792751049146 + 0.98521512274868 + 0.98242271646747 + 0.97946802812781 + 0.97628538208509 + 0.97281287485836 + 0.96898808537307 + 0.96474657234393 + 0.96001847290869 + 0.95471917876941 + 0.94875919451252 + 0.94206356523813 + 0.93456763746950 + 0.92621083585051 + 0.91694394525435 + 0.90673046827983 + 0.89554983986460 + 0.88340182390785 + 0.87031191082177 + 0.85633618208232 + 0.84155798495453 + 0.82607189197573 + 0.81000115578001 + 0.79352553201096 + 0.77685521690169 + 0.76850709319416 + 0.76018413964284 + 0.75190533576053 + 0.74368528578164 + 0.73553353191836 + 0.72745408427325 + 0.71944526448467 + 0.71150000118686 + 0.70360657525558 + 0.69574655856136 + 0.68784222829385 + 0.67966642583188 + 0.67110322217114 + 0.66214383434994 + 0.65278238599475 + 0.64303665134590 + 0.63293000174927 + 0.62248996152766 + 0.61174724743095 + 0.60073533988078 + 0.58948896789958 + 0.57801840533326 + 0.56635976265740 + 0.55455243058218 + 0.54263837469862 + 0.53066056071336 + 0.51866054862463 + 0.50666143880096 + 0.49467514254736 + 0.48271528945735 + 0.47078346971369 + 0.45886876823768 + 0.98646531499500 + 0.98646567541793 + 0.98646573531715 + 0.98646580520443 + 0.98646588675615 + 0.98646598193977 + 0.98646609305848 + 0.98646622282232 + 0.98646637445790 + 0.98646655199236 + 0.98646676107246 + 0.98646700971091 + 0.98646730746721 + 0.98646766505939 + 0.98646809508782 + 0.98646861276318 + 0.98646923657654 + 0.98646998907074 + 0.98647089836558 + 0.98647199960602 + 0.98647333532584 + 0.98647495803976 + 0.98647693274914 + 0.98647934021180 + 0.98648228172908 + 0.98648588890391 + 0.98649034145883 + 0.98649587292047 + 0.98650277019395 + 0.98651139257663 + 0.98652221527820 + 0.98653584405764 + 0.98655305769135 + 0.98657486578760 + 0.98660258206206 + 0.98663792284798 + 0.98668314052962 + 0.98674120601474 + 0.98681611495718 + 0.98691328736432 + 0.98704000299882 + 0.98720623427702 + 0.98742580918977 + 0.98771782952569 + 0.98810646818148 + 0.98862255591096 + 0.98931714750626 + 0.99027470676637 + 0.99164349022300 + 0.99379851456251 + 1.00000000000000 + 0.99307876859470 + 0.98960027002748 + 0.98650633726780 + 0.98346504101173 + 0.98033195310681 + 0.97701441052672 + 0.97343621036462 + 0.96952636519265 + 0.96521489807427 + 0.96042816128170 + 0.95507878216708 + 0.94907538413467 + 0.94234187931805 + 0.93481282398363 + 0.92642699504162 + 0.91713464729338 + 0.90689882844181 + 0.89569857531036 + 0.88353329900197 + 0.87042817719801 + 0.85643901940838 + 0.84164893707589 + 0.82615229346008 + 0.81007218658300 + 0.79358828074942 + 0.77691070318690 + 0.76855930298667 + 0.76023330016575 + 0.75195166258204 + 0.74372898180222 + 0.73557478650935 + 0.72749307262145 + 0.71948214714779 + 0.71153492389934 + 0.70363966899090 + 0.69577793909648 + 0.68787198322793 + 0.67969458428401 + 0.67112978855408 + 0.66216881516364 + 0.65280579102377 + 0.64305849812909 + 0.63295031609370 + 0.62250877755486 + 0.61176460730405 + 0.60075129334224 + 0.58950357151952 + 0.57803171867099 + 0.56637185096344 + 0.55456336419047 + 0.54264822826075 + 0.53066941224224 + 0.51866847828731 + 0.50666852646480 + 0.49468146622841 + 0.48272092462967 + 0.47078848768355 + 0.45887323476560 + 0.98489131212128 + 0.98489162777261 + 0.98489168022587 + 0.98489174142129 + 0.98489181282925 + 0.98489189616572 + 0.98489199345160 + 0.98489210705046 + 0.98489223978791 + 0.98489239519000 + 0.98489257822268 + 0.98489279596133 + 0.98489305684241 + 0.98489337031602 + 0.98489374748399 + 0.98489420174678 + 0.98489474939763 + 0.98489541030234 + 0.98489620924265 + 0.98489717721003 + 0.98489835169137 + 0.98489977896016 + 0.98490151627959 + 0.98490363477157 + 0.98490622363092 + 0.98490939879629 + 0.98491331884750 + 0.98491818992092 + 0.98492426496023 + 0.98493186044908 + 0.98494139505638 + 0.98495340197174 + 0.98496856599014 + 0.98498777392429 + 0.98501217813052 + 0.98504328153544 + 0.98508305219380 + 0.98513407878713 + 0.98519983235065 + 0.98528500251521 + 0.98539584894597 + 0.98554087966922 + 0.98573176477873 + 0.98598435495052 + 0.98631800532891 + 0.98675607033991 + 0.98733583495495 + 0.98811430547961 + 0.98917664617352 + 0.99068939014545 + 0.99307876859470 + 1.00000000000000 + 0.99225438252293 + 0.98835866604848 + 0.98489060341689 + 0.98148016827820 + 0.97796478587868 + 0.97423743392373 + 0.97021074485463 + 0.96580501925877 + 0.96094039071653 + 0.95552521304879 + 0.94946529783601 + 0.94268286424274 + 0.93511130117423 + 0.92668845434683 + 0.91736383110134 + 0.90709984963644 + 0.89587500449723 + 0.88368823210341 + 0.87056429266568 + 0.85655863385220 + 0.84175405385541 + 0.82624463848443 + 0.81015327618147 + 0.79365949864139 + 0.77697332914782 + 0.76861807423998 + 0.76028849689917 + 0.75200354931146 + 0.74377780640233 + 0.73562077942324 + 0.72753644628906 + 0.71952309568413 + 0.71157362303696 + 0.70367627632438 + 0.69581259373061 + 0.68790479128388 + 0.67972558507237 + 0.67115899315479 + 0.66219623669499 + 0.65283144596191 + 0.64308241124881 + 0.63297252098559 + 0.62252931661342 + 0.61178353136730 + 0.60076866115487 + 0.58951944886950 + 0.57804617417476 + 0.56638495905463 + 0.55457520447366 + 0.54265888471328 + 0.53067897218548 + 0.51867703110245 + 0.50667616093753 + 0.49468826887004 + 0.48272697893459 + 0.47079387236217 + 0.45887802225563 + 0.98312913571318 + 0.98312941256037 + 0.98312945855893 + 0.98312951222235 + 0.98312957483559 + 0.98312964790607 + 0.98312973320120 + 0.98312983279305 + 0.98312994915415 + 0.98313008537977 + 0.98313024584547 + 0.98313043681216 + 0.98313066574791 + 0.98313094100429 + 0.98313127238873 + 0.98313167173667 + 0.98313215344388 + 0.98313273505757 + 0.98313343848345 + 0.98313429112436 + 0.98313532611233 + 0.98313658433999 + 0.98313811639436 + 0.98313998509300 + 0.98314226920499 + 0.98314507117296 + 0.98314853137930 + 0.98315283237848 + 0.98315819791542 + 0.98316490767284 + 0.98317333176433 + 0.98318394112029 + 0.98319734003940 + 0.98321431033204 + 0.98323586671869 + 0.98326333068620 + 0.98329842954358 + 0.98334343015543 + 0.98340136491967 + 0.98347631841007 + 0.98357371602847 + 0.98370088791562 + 0.98386780656774 + 0.98408784267129 + 0.98437685097024 + 0.98475310282819 + 0.98524514595348 + 0.98589440909868 + 0.98675644848706 + 0.98792751049146 + 0.98960027002748 + 0.99225438252293 + 1.00000000000000 + 0.99131137958294 + 0.98694405649871 + 0.98305633336857 + 0.97923243313114 + 0.97528581644681 + 0.97109389753865 + 0.96655839707105 + 0.96158854466347 + 0.95608572709266 + 0.94995136518213 + 0.94310505882166 + 0.93547842429994 + 0.92700793750842 + 0.91764203167888 + 0.90734224009118 + 0.89608630892199 + 0.88387252886983 + 0.87072509777359 + 0.85669897842261 + 0.84187655061460 + 0.82635153084942 + 0.81024652370054 + 0.79374087176640 + 0.77704444646427 + 0.76868461707582 + 0.76035081374684 + 0.75206196763176 + 0.74383263173892 + 0.73567229472009 + 0.72758491147632 + 0.71956874753184 + 0.71161667531035 + 0.70371692026643 + 0.69585099785650 + 0.68794108514952 + 0.67975982140062 + 0.67119119215216 + 0.66222642044458 + 0.65285963986834 + 0.64310864955958 + 0.63299684727884 + 0.62255178371797 + 0.61180420091448 + 0.60078760292510 + 0.58953673982746 + 0.57806189381311 + 0.56639919273004 + 0.55458804272357 + 0.54267042241199 + 0.53068930746644 + 0.51868626398151 + 0.50668439043768 + 0.49469559121678 + 0.48273348675109 + 0.47079965275618 + 0.45888315521593 + 0.98115373596680 + 0.98115397920530 + 0.98115401961499 + 0.98115406675500 + 0.98115412175639 + 0.98115418593956 + 0.98115426085408 + 0.98115434832017 + 0.98115445050404 + 0.98115457012992 + 0.98115471106019 + 0.98115487885229 + 0.98115508013400 + 0.98115532230506 + 0.98115561404872 + 0.98115596585215 + 0.98115639046334 + 0.98115690342874 + 0.98115752416722 + 0.98115827697444 + 0.98115919122243 + 0.98116030315147 + 0.98116165758807 + 0.98116331018097 + 0.98116533069454 + 0.98116780993476 + 0.98117087257563 + 0.98117468082681 + 0.98117943325367 + 0.98118537783854 + 0.98119284287323 + 0.98120224572661 + 0.98121412150884 + 0.98122916192138 + 0.98124826378100 + 0.98127259352538 + 0.98130367339814 + 0.98134349727111 + 0.98139472743007 + 0.98146094141660 + 0.98154687232713 + 0.98165888511970 + 0.98180558447717 + 0.98199838954629 + 0.98225050475912 + 0.98257654915702 + 0.98299908689933 + 0.98354967258267 + 0.98426729903032 + 0.98521512274868 + 0.98650633726780 + 0.98835866604848 + 0.99131137958294 + 1.00000000000000 + 0.99023200863300 + 0.98533493546988 + 0.98097821020951 + 0.97668885027548 + 0.97225362172570 + 0.96753429791410 + 0.96241927937093 + 0.95679780441719 + 0.95056405791216 + 0.94363341311181 + 0.93593470332340 + 0.92740233291863 + 0.91798315612863 + 0.90763743880279 + 0.89634187830774 + 0.88409387578717 + 0.87091686373260 + 0.85686514992766 + 0.84202055188656 + 0.82647629228981 + 0.81035459106891 + 0.79383452436710 + 0.77712574609714 + 0.76876043975274 + 0.76042159651731 + 0.75212811933687 + 0.74389453227284 + 0.73573029453239 + 0.72763933138809 + 0.71961987885577 + 0.71166478030711 + 0.70376223296162 + 0.69589372406055 + 0.68798138422911 + 0.67979776372466 + 0.67122681032852 + 0.66225974859891 + 0.65289071528007 + 0.64313751883297 + 0.63302356681344 + 0.62257641954184 + 0.61182682811372 + 0.60080830487651 + 0.58955560710771 + 0.57807901904946 + 0.56641467433261 + 0.55460198418358 + 0.54268293141451 + 0.53070049475934 + 0.51869624191428 + 0.50669326984726 + 0.49470347948688 + 0.48274048694922 + 0.47080586155753 + 0.45888866117599 + 0.97893624233149 + 0.97893645648516 + 0.97893649205842 + 0.97893653355409 + 0.97893658196665 + 0.97893663845835 + 0.97893670439333 + 0.97893678136917 + 0.97893687128874 + 0.97893697655402 + 0.97893710058730 + 0.97893724833173 + 0.97893742568336 + 0.97893763921792 + 0.97893789665017 + 0.97893820729078 + 0.97893858246606 + 0.97893903598538 + 0.97893958511412 + 0.97894025146738 + 0.97894106114967 + 0.97894204638301 + 0.97894324701305 + 0.97894471248638 + 0.97894650479253 + 0.97894870467667 + 0.97895142323192 + 0.97895480507299 + 0.97895902702206 + 0.97896430968603 + 0.97897094527215 + 0.97897930495613 + 0.97898986423904 + 0.97900323728356 + 0.97902021959720 + 0.97904184464196 + 0.97906945923295 + 0.97910482446881 + 0.97915028826074 + 0.97920899973388 + 0.97928511141050 + 0.97938418657918 + 0.97951370839918 + 0.97968352496989 + 0.97990477305709 + 0.98018934148580 + 0.98055547169211 + 0.98102797592638 + 0.98163552013182 + 0.98242271646747 + 0.98346504101173 + 0.98489060341689 + 0.98694405649871 + 0.99023200863300 + 1.00000000000000 + 0.98900047856077 + 0.98351127690071 + 0.97862790424566 + 0.97381157554393 + 0.96882111217782 + 0.96350006001487 + 0.95771450907918 + 0.95134587467052 + 0.94430234381167 + 0.93650819736074 + 0.92789459893748 + 0.91840601589648 + 0.90800085661067 + 0.89665432056577 + 0.88436256444633 + 0.87114796619360 + 0.85706394003115 + 0.84219154208822 + 0.82662333082754 + 0.81048100393396 + 0.79394326483003 + 0.77721945987467 + 0.76884753147695 + 0.76050261898261 + 0.75220358748196 + 0.74396492267464 + 0.73579604521630 + 0.72770084196479 + 0.71967751103448 + 0.71171885877234 + 0.70381304665204 + 0.69594152653465 + 0.68802637310171 + 0.67984003263655 + 0.67126640861495 + 0.66229672650459 + 0.65292512580574 + 0.64316942471775 + 0.63305304096903 + 0.62260354477759 + 0.61185169643177 + 0.60083101656644 + 0.58957626949942 + 0.57809774081771 + 0.56643156970883 + 0.55461717221777 + 0.54269653507062 + 0.53071263973561 + 0.51870705508991 + 0.50670287591473 + 0.49471199885664 + 0.48274803483513 + 0.47081254572255 + 0.45889458007051 + 0.97644419689310 + 0.97644438589374 + 0.97644441728346 + 0.97644445389871 + 0.97644449661639 + 0.97644454645832 + 0.97644460462813 + 0.97644467253311 + 0.97644475185331 + 0.97644484470766 + 0.97644495413419 + 0.97644508454451 + 0.97644524120220 + 0.97644542996508 + 0.97644565770484 + 0.97644593271751 + 0.97644626509202 + 0.97644666714071 + 0.97644715425503 + 0.97644774571965 + 0.97644846482578 + 0.97644934030615 + 0.97645040769127 + 0.97645171107104 + 0.97645330570614 + 0.97645526363910 + 0.97645768420300 + 0.97646069678190 + 0.97646445938592 + 0.97646916896737 + 0.97647508654443 + 0.97648254340146 + 0.97649196361891 + 0.97650389452789 + 0.97651904441892 + 0.97653833246663 + 0.97656295499756 + 0.97659447396352 + 0.97663496910374 + 0.97668722553642 + 0.97675490539076 + 0.97684289982647 + 0.97695776103490 + 0.97710805173513 + 0.97730326078721 + 0.97755317809080 + 0.97787280243462 + 0.97828210008281 + 0.97880282249176 + 0.97946802812781 + 0.98033195310681 + 0.98148016827820 + 0.98305633336857 + 0.98533493546988 + 0.98900047856077 + 1.00000000000000 + 0.98760170747127 + 0.98144940670151 + 0.97597117453567 + 0.97055563934255 + 0.96493037266256 + 0.95891161066923 + 0.95235613831517 + 0.94515909777263 + 0.93723693794296 + 0.92851554051441 + 0.91893564192591 + 0.90845285249996 + 0.89704018400715 + 0.88469202044645 + 0.87142926568181 + 0.85730410119956 + 0.84239654316143 + 0.82679825075593 + 0.81063021039560 + 0.79407060632283 + 0.77732835361631 + 0.76894834502619 + 0.76059605686118 + 0.75229030336516 + 0.74404551927235 + 0.73587107449700 + 0.72777080580843 + 0.71974286228258 + 0.71178000270429 + 0.70387034290895 + 0.69599528997833 + 0.68807685055639 + 0.67988734843683 + 0.67131063461808 + 0.66233793446211 + 0.65296338951353 + 0.64320482795985 + 0.63308567792341 + 0.62263351961032 + 0.61187912242470 + 0.60085601505902 + 0.58959896847381 + 0.57811826857242 + 0.56645005963998 + 0.55463376207666 + 0.54271136604143 + 0.53072585522121 + 0.51871879906956 + 0.50671328930034 + 0.49472121724923 + 0.48275618754819 + 0.47081975333933 + 0.45890095244239 + 0.97364110859478 + 0.97364127585799 + 0.97364130363422 + 0.97364133603260 + 0.97364137382895 + 0.97364141792724 + 0.97364146939036 + 0.97364152946164 + 0.97364159962642 + 0.97364168176031 + 0.97364177857065 + 0.97364189400595 + 0.97364203277741 + 0.97364220012460 + 0.97364240218388 + 0.97364264636938 + 0.97364294170238 + 0.97364329919064 + 0.97364373260379 + 0.97364425920944 + 0.97364489985071 + 0.97364568024196 + 0.97364663217968 + 0.97364779510656 + 0.97364921846729 + 0.97365096676700 + 0.97365312914285 + 0.97365582177973 + 0.97365918639399 + 0.97366339948192 + 0.97366869506685 + 0.97367536995559 + 0.97368380380651 + 0.97369448626877 + 0.97370805045087 + 0.97372531712182 + 0.97374735325997 + 0.97377554999049 + 0.97381175757603 + 0.97385845056880 + 0.97391887466036 + 0.97399735355538 + 0.97409965957506 + 0.97423329105385 + 0.97440640251899 + 0.97462713652180 + 0.97490799134512 + 0.97526531892716 + 0.97571600434954 + 0.97628538208509 + 0.97701441052672 + 0.97796478587868 + 0.97923243313114 + 0.98097821020951 + 0.98351127690071 + 0.98760170747127 + 1.00000000000000 + 0.98601660019276 + 0.97911941972328 + 0.97296550647206 + 0.96686347093616 + 0.96050029924264 + 0.95367909542519 + 0.94626922140313 + 0.93817277604002 + 0.92930659263651 + 0.91960533697483 + 0.90902026437293 + 0.89752110538143 + 0.88509966456098 + 0.87177475053204 + 0.85759682188160 + 0.84264446023305 + 0.82700809826520 + 0.81080774982135 + 0.79422087732905 + 0.77745579423258 + 0.76906584676587 + 0.76070452339893 + 0.75239057002084 + 0.74413835347745 + 0.73595717666466 + 0.72785081069789 + 0.71981734083796 + 0.71184946435883 + 0.70393523839984 + 0.69605601292137 + 0.68813371110114 + 0.67994051138603 + 0.67136020205703 + 0.66238400676789 + 0.65300606790256 + 0.64324422360687 + 0.63312191233282 + 0.62266672406703 + 0.61190943692839 + 0.60088358708486 + 0.58962395138175 + 0.57814081457817 + 0.56647032527410 + 0.55465190745505 + 0.54272755396207 + 0.53074024992699 + 0.51873156453548 + 0.50672458530008 + 0.49473119695709 + 0.48276499650970 + 0.47082752683905 + 0.45890781335038 + 0.97048450840933 + 0.97048465689734 + 0.97048468155309 + 0.97048471031027 + 0.97048474385643 + 0.97048478299479 + 0.97048482866558 + 0.97048488197304 + 0.97048494423379 + 0.97048501711444 + 0.97048510303365 + 0.97048520553626 + 0.97048532885495 + 0.97048547768568 + 0.97048565753478 + 0.97048587504868 + 0.97048613831976 + 0.97048645721775 + 0.97048684411251 + 0.97048731451909 + 0.97048788714909 + 0.97048858510441 + 0.97048943693521 + 0.97049047805956 + 0.97049175287366 + 0.97049331934777 + 0.97049525776845 + 0.97049767284572 + 0.97050069216259 + 0.97050447447404 + 0.97050923040219 + 0.97051522687738 + 0.97052280509369 + 0.97053240480039 + 0.97054459411807 + 0.97056010885382 + 0.97057990446666 + 0.97060522505788 + 0.97063772373463 + 0.97067960886434 + 0.97073377055158 + 0.97080405017525 + 0.97089556125154 + 0.97101491136779 + 0.97116915985615 + 0.97136513379905 + 0.97161335948407 + 0.97192741286425 + 0.97232061987054 + 0.97281287485836 + 0.97343621036462 + 0.97423743392373 + 0.97528581644681 + 0.97668885027548 + 0.97862790424566 + 0.98144940670151 + 0.98601660019276 + 1.00000000000000 + 0.98422360284077 + 0.97648468773532 + 0.96955550845267 + 0.96265299845184 + 0.95543936925395 + 0.94772664330095 + 0.93938836375078 + 0.93032486125948 + 0.92046042461314 + 0.90973925564022 + 0.89812600220765 + 0.88560861713158 + 0.87220286937860 + 0.85795677102797 + 0.84294690067468 + 0.82726200280237 + 0.81102075391058 + 0.79439961237739 + 0.77760605444603 + 0.76920378601305 + 0.76083130779796 + 0.75250727368446 + 0.74424595984561 + 0.73605658033020 + 0.72794281980487 + 0.71990268001594 + 0.71192877819609 + 0.70400909549340 + 0.69612490847333 + 0.68819803704688 + 0.68000048591268 + 0.67141596769753 + 0.66243570189603 + 0.65305382981875 + 0.64328819910148 + 0.63316225803708 + 0.62270360572971 + 0.61194302814854 + 0.60091406786984 + 0.58965150636537 + 0.57816562521160 + 0.56649257610877 + 0.55467178545482 + 0.54274524765211 + 0.53075594816975 + 0.51874545477052 + 0.50673684930590 + 0.49474200830663 + 0.48277451950934 + 0.47083591368439 + 0.45891520182623 + 0.96692590062899 + 0.96692603289935 + 0.96692605485862 + 0.96692608047191 + 0.96692611034874 + 0.96692614520408 + 0.96692618587322 + 0.96692623334037 + 0.96692628877592 + 0.96692635366651 + 0.96692643018062 + 0.96692652151114 + 0.96692663147429 + 0.96692676429321 + 0.96692692492266 + 0.96692711934335 + 0.96692735483856 + 0.96692764029497 + 0.96692798685891 + 0.96692840851198 + 0.96692892212766 + 0.96692954851684 + 0.96693031342095 + 0.96693124875236 + 0.96693239451814 + 0.96693380300604 + 0.96693554678741 + 0.96693772057171 + 0.96694043963947 + 0.96694384731546 + 0.96694813385353 + 0.96695354019739 + 0.96696037412283 + 0.96696903204059 + 0.96698002567344 + 0.96699401717198 + 0.96701186542147 + 0.96703468738976 + 0.96706396594024 + 0.96710168001202 + 0.96715041415554 + 0.96721359680186 + 0.96729578018453 + 0.96740281877520 + 0.96754086151208 + 0.96771566830020 + 0.96793617924199 + 0.96821378404313 + 0.96855912024591 + 0.96898808537307 + 0.96952636519265 + 0.97021074485463 + 0.97109389753865 + 0.97225362172570 + 0.97381157554393 + 0.97597117453567 + 0.97911941972328 + 0.98422360284077 + 1.00000000000000 + 0.98219625883047 + 0.97349409558502 + 0.96565799886589 + 0.95783045216096 + 0.94967052060143 + 0.94098797784814 + 0.93165048683399 + 0.92156346340968 + 0.91065911163909 + 0.89889388963014 + 0.88624981357508 + 0.87273813068134 + 0.85840331010363 + 0.84331909086428 + 0.82757186696274 + 0.81127846176888 + 0.79461393299192 + 0.77778459184744 + 0.76936693309236 + 0.76098057798878 + 0.75264405631564 + 0.74437152280957 + 0.73617207328090 + 0.72804927804589 + 0.72000102900307 + 0.71201983863152 + 0.70409358907916 + 0.69620346196256 + 0.68827114838344 + 0.68006844377022 + 0.67147896861925 + 0.66249393460295 + 0.65310747902890 + 0.64333745789232 + 0.63320732819726 + 0.62274469687409 + 0.61198035620988 + 0.60094785344633 + 0.58968197274800 + 0.57819298971031 + 0.56651705732588 + 0.55469360270551 + 0.54276462020395 + 0.53077309408734 + 0.51876058913343 + 0.50675017966888 + 0.49475373202102 + 0.48278482264250 + 0.47084496796288 + 0.45892316219315 + 0.96291122084119 + 0.96291133909459 + 0.96291135872495 + 0.96291138161952 + 0.96291140832339 + 0.96291143947677 + 0.96291147582377 + 0.96291151824568 + 0.96291156778354 + 0.96291162577005 + 0.96291169415564 + 0.96291177582660 + 0.96291187423246 + 0.96291199318868 + 0.96291213716773 + 0.96291231156674 + 0.96291252296695 + 0.96291277939680 + 0.96291309093198 + 0.96291347021993 + 0.96291393252315 + 0.96291449666278 + 0.96291518591983 + 0.96291602914906 + 0.96291706252784 + 0.96291833338184 + 0.96291990753085 + 0.96292187093621 + 0.96292432811708 + 0.96292740891171 + 0.96293128576716 + 0.96293617692704 + 0.96294236097927 + 0.96295019650093 + 0.96296014602324 + 0.96297280749188 + 0.96298895569674 + 0.96300959702336 + 0.96303606642518 + 0.96307014378736 + 0.96311414922602 + 0.96317115481931 + 0.96324523035196 + 0.96334158701436 + 0.96346560762986 + 0.96362217332099 + 0.96381892520235 + 0.96406549245640 + 0.96437042369976 + 0.96474657234393 + 0.96521489807427 + 0.96580501925877 + 0.96655839707105 + 0.96753429791410 + 0.96882111217782 + 0.97055563934255 + 0.97296550647206 + 0.97648468773532 + 0.98219625883047 + 1.00000000000000 + 0.97989328220775 + 0.97006426139656 + 0.96117676097961 + 0.95231777165158 + 0.94312682316037 + 0.93339907862227 + 0.92300272354589 + 0.91184825193064 + 0.89987826448926 + 0.88706526264640 + 0.87341355464362 + 0.85896235147167 + 0.84378128886772 + 0.82795343982596 + 0.81159303310420 + 0.79487316148239 + 0.77799851083083 + 0.76956147991733 + 0.76115772814922 + 0.75280561743066 + 0.74451913926693 + 0.73630723149864 + 0.72817331248719 + 0.72011512889944 + 0.71212505535298 + 0.70419084425313 + 0.69629355359265 + 0.68835471245094 + 0.68014586216901 + 0.67155050995743 + 0.66255985426031 + 0.65316802403154 + 0.64339288152659 + 0.63325789044023 + 0.62279066333396 + 0.61202199637190 + 0.60098543880128 + 0.58971577463375 + 0.57822326968326 + 0.56654407566140 + 0.55471761797470 + 0.54278588869980 + 0.53079186879214 + 0.51877711796290 + 0.50676470063424 + 0.49476647043085 + 0.48279599003669 + 0.47085475884096 + 0.45893175142817 + 0.95837867459299 + 0.95837878070031 + 0.95837879831133 + 0.95837881885117 + 0.95837884280724 + 0.95837887075241 + 0.95837890335622 + 0.95837894140497 + 0.95837898583488 + 0.95837903783926 + 0.95837909918269 + 0.95837917248001 + 0.95837926085800 + 0.95837936777748 + 0.95837949728472 + 0.95837965427275 + 0.95837984470214 + 0.95838007585152 + 0.95838035685537 + 0.95838069919559 + 0.95838111671635 + 0.95838162649343 + 0.95838224964855 + 0.95838301235482 + 0.95838394742917 + 0.95838509783027 + 0.95838652344447 + 0.95838830251883 + 0.95839053010299 + 0.95839332417496 + 0.95839684150786 + 0.95840128036973 + 0.95840689367692 + 0.95841400675147 + 0.95842303889886 + 0.95843453168209 + 0.95844918610766 + 0.95846791162340 + 0.95849191363520 + 0.95852279788070 + 0.95856265359076 + 0.95861424244846 + 0.95868121532746 + 0.95876822778291 + 0.95888000976932 + 0.95902070832794 + 0.95919688271580 + 0.95941671549558 + 0.95968709150758 + 0.96001847290869 + 0.96042816128170 + 0.96094039071653 + 0.96158854466347 + 0.96241927937093 + 0.96350006001487 + 0.96493037266256 + 0.96686347093616 + 0.96955550845267 + 0.97349409558502 + 0.97989328220775 + 1.00000000000000 + 0.97724100875665 + 0.96610184275050 + 0.95603735628565 + 0.94605119649303 + 0.93574632167392 + 0.92490856717082 + 0.91340577540160 + 0.90115557567077 + 0.88811444116632 + 0.87427560061846 + 0.85967021032442 + 0.84436182574497 + 0.82842873419358 + 0.81198147823214 + 0.79519036827237 + 0.77825780931310 + 0.76979616168065 + 0.76137038990914 + 0.75299862775709 + 0.74469464624903 + 0.73646717102014 + 0.72831941736403 + 0.72024893875666 + 0.71224792721686 + 0.70430396397651 + 0.69639794488679 + 0.68845119319262 + 0.68023493830423 + 0.67163254644366 + 0.66263519510222 + 0.65323699859012 + 0.64345582209721 + 0.63331513282207 + 0.62284254561855 + 0.61206885691968 + 0.60102761414877 + 0.58975359714225 + 0.57825705681129 + 0.56657414000595 + 0.55474426712048 + 0.54280942490745 + 0.53081258816877 + 0.51879530878817 + 0.50678063821040 + 0.49478041417944 + 0.48280818248479 + 0.47086542211160 + 0.45894108450646 + 0.95325041660921 + 0.95325051212168 + 0.95325052797203 + 0.95325054645753 + 0.95325056801700 + 0.95325059316572 + 0.95325062250535 + 0.95325065674213 + 0.95325069671682 + 0.95325074350689 + 0.95325079870480 + 0.95325086469337 + 0.95325094431256 + 0.95325104070596 + 0.95325115754765 + 0.95325129928216 + 0.95325147132161 + 0.95325168027898 + 0.95325193445998 + 0.95325224431249 + 0.95325262241927 + 0.95325308431727 + 0.95325364920355 + 0.95325434088103 + 0.95325518918202 + 0.95325623319228 + 0.95325752750550 + 0.95325914350387 + 0.95326116780330 + 0.95326370782441 + 0.95326690637856 + 0.95327094395827 + 0.95327605063110 + 0.95328252213140 + 0.95329073931954 + 0.95330119365534 + 0.95331452060462 + 0.95333154360684 + 0.95335335317495 + 0.95338140073099 + 0.95341757129654 + 0.95346435253350 + 0.95352502643701 + 0.95360376154677 + 0.95370472315747 + 0.95383143606162 + 0.95398954290718 + 0.95418601429618 + 0.95442638157262 + 0.95471917876941 + 0.95507878216708 + 0.95552521304879 + 0.95608572709266 + 0.95679780441719 + 0.95771450907918 + 0.95891161066923 + 0.96050029924264 + 0.96265299845184 + 0.96565799886589 + 0.97006426139656 + 0.97724100875665 + 1.00000000000000 + 0.97417640447654 + 0.96155435617247 + 0.95019283145299 + 0.93898132626661 + 0.92748757111133 + 0.91548510884552 + 0.90284252489212 + 0.88948743390003 + 0.87539441329071 + 0.86058174439069 + 0.84510365665672 + 0.82903134615545 + 0.81247000434399 + 0.79558594122308 + 0.77857832547377 + 0.77008493991063 + 0.76163087937110 + 0.75323396498473 + 0.74490766748933 + 0.73666042508744 + 0.72849517935859 + 0.72040922455059 + 0.71239450865442 + 0.70443838496727 + 0.69652153458458 + 0.68856501537083 + 0.68033966667583 + 0.67172867621897 + 0.66272318988229 + 0.65331729872113 + 0.64352886623065 + 0.63338135871081 + 0.62290238870587 + 0.61212274796406 + 0.60107597683861 + 0.58979684551598 + 0.57829558305379 + 0.56660832659688 + 0.55477448704396 + 0.54283604170589 + 0.53083595539628 + 0.51881576846021 + 0.50679851523147 + 0.49479601332755 + 0.48282178746885 + 0.47087729177538 + 0.45895144990482 + 0.94744187934306 + 0.94744196554068 + 0.94744197984518 + 0.94744199652388 + 0.94744201597662 + 0.94744203866715 + 0.94744206513644 + 0.94744209602052 + 0.94744213207953 + 0.94744217428435 + 0.94744222408201 + 0.94744228363800 + 0.94744235554279 + 0.94744244265215 + 0.94744254831222 + 0.94744267656239 + 0.94744283233307 + 0.94744302163764 + 0.94744325203914 + 0.94744353305705 + 0.94744387615322 + 0.94744429547589 + 0.94744480851017 + 0.94744543692366 + 0.94744620787671 + 0.94744715698019 + 0.94744833406523 + 0.94744980432291 + 0.94745164677583 + 0.94745395934844 + 0.94745687228301 + 0.94746055005582 + 0.94746520217738 + 0.94747109776448 + 0.94747858311118 + 0.94748810464272 + 0.94750023896894 + 0.94751573234629 + 0.94753557226264 + 0.94756107183609 + 0.94759393337542 + 0.94763639976551 + 0.94769142423847 + 0.94776274309696 + 0.94785402730453 + 0.94796826843509 + 0.94811032224625 + 0.94828612906592 + 0.94850010305353 + 0.94875919451252 + 0.94907538413467 + 0.94946529783601 + 0.94995136518213 + 0.95056405791216 + 0.95134587467052 + 0.95235613831517 + 0.95367909542519 + 0.95543936925395 + 0.95783045216096 + 0.96117676097961 + 0.96610184275050 + 0.97417640447654 + 1.00000000000000 + 0.97067311521997 + 0.95638876002600 + 0.94360171389744 + 0.93107176583138 + 0.91832240688390 + 0.90511360781919 + 0.89131625616284 + 0.87687133298427 + 0.86177540375817 + 0.84606775970693 + 0.82980871463006 + 0.81309547533226 + 0.79608848062311 + 0.77898223511895 + 0.77044734877727 + 0.76195641809966 + 0.75352683145516 + 0.74517164663904 + 0.73689890886524 + 0.72871118740755 + 0.72060542552548 + 0.71257324213956 + 0.70460168431210 + 0.69667114597858 + 0.68870233805610 + 0.68046560323874 + 0.67184389956386 + 0.66282832674731 + 0.65341294080201 + 0.64361559715920 + 0.63345975515160 + 0.62297301863654 + 0.61218616782010 + 0.60113272871806 + 0.58984745428336 + 0.57834054218295 + 0.56664811316634 + 0.55480956245183 + 0.54286685224614 + 0.53086293210418 + 0.51883932574488 + 0.50681904474786 + 0.49481388083097 + 0.48283733200773 + 0.47089082151841 + 0.45896323897539 + 0.94088098901275 + 0.94088106697349 + 0.94088107990854 + 0.94088109499188 + 0.94088111258236 + 0.94088113309873 + 0.94088115702937 + 0.94088118495033 + 0.94088121754911 + 0.94088125570131 + 0.94088130072126 + 0.94088135458490 + 0.94088141965535 + 0.94088149853390 + 0.94088159426767 + 0.94088171053716 + 0.94088185183296 + 0.94088202363572 + 0.94088223284267 + 0.94088248813476 + 0.94088279996548 + 0.94088318123541 + 0.94088364787956 + 0.94088421965355 + 0.94088492130686 + 0.94088578531999 + 0.94088685721009 + 0.94088819657347 + 0.94088987556076 + 0.94089198351671 + 0.94089463930892 + 0.94089799294197 + 0.94090223535181 + 0.94090761160648 + 0.94091443680068 + 0.94092311672780 + 0.94093417494160 + 0.94094828819068 + 0.94096635121225 + 0.94098955272429 + 0.94101943093111 + 0.94105800922196 + 0.94110794661519 + 0.94117259412840 + 0.94125518812834 + 0.94135826155356 + 0.94148599112302 + 0.94164343574573 + 0.94183408149173 + 0.94206356523813 + 0.94234187931805 + 0.94268286424274 + 0.94310505882166 + 0.94363341311181 + 0.94430234381167 + 0.94515909777263 + 0.94626922140313 + 0.94772664330095 + 0.94967052060143 + 0.95231777165158 + 0.95603735628565 + 0.96155435617247 + 0.97067311521997 + 1.00000000000000 + 0.96668971052978 + 0.95055053187009 + 0.93621484428530 + 0.92228217329753 + 0.90822449463731 + 0.89378716327468 + 0.87884523185863 + 0.86335616669093 + 0.84733406992191 + 0.83082186178879 + 0.81390444962025 + 0.79673344273375 + 0.77949649861044 + 0.77090689519270 + 0.76236751186701 + 0.75389513193632 + 0.74550224023716 + 0.73719634031887 + 0.72897949126170 + 0.72084815778933 + 0.71279351217501 + 0.70480218745779 + 0.69685419121330 + 0.68886977710697 + 0.68061864936856 + 0.67198346777324 + 0.66295526535280 + 0.65352804638391 + 0.64371964874712 + 0.63355351575233 + 0.62305723318872 + 0.61226155974425 + 0.60119999665471 + 0.58990726887746 + 0.57839352954141 + 0.56669487358872 + 0.55485067191243 + 0.54290286372712 + 0.53089437605338 + 0.51886670903384 + 0.50684284397111 + 0.49483453906518 + 0.48285525825253 + 0.47090638612009 + 0.45897677021878 + 0.93350510949296 + 0.93350518013554 + 0.93350519185461 + 0.93350520551890 + 0.93350522145462 + 0.93350524003937 + 0.93350526171727 + 0.93350528700677 + 0.93350531652980 + 0.93350535108247 + 0.93350539185953 + 0.93350544066213 + 0.93350549964964 + 0.93350557119408 + 0.93350565807629 + 0.93350576365198 + 0.93350589201586 + 0.93350604816847 + 0.93350623840486 + 0.93350647065087 + 0.93350675445140 + 0.93350710157385 + 0.93350752656660 + 0.93350804745064 + 0.93350868680245 + 0.93350947426690 + 0.93351045146501 + 0.93351167290731 + 0.93351320452518 + 0.93351512789826 + 0.93351755158915 + 0.93352061250383 + 0.93352448476816 + 0.93352939171247 + 0.93353562023140 + 0.93354353943295 + 0.93355362500525 + 0.93356649105066 + 0.93358294877660 + 0.93360407490992 + 0.93363126021441 + 0.93366633113359 + 0.93371168321178 + 0.93377032376851 + 0.93384510679739 + 0.93393817072595 + 0.93405310547901 + 0.93419421428297 + 0.93436421071276 + 0.93456763746950 + 0.93481282398363 + 0.93511130117423 + 0.93547842429994 + 0.93593470332340 + 0.93650819736074 + 0.93723693794296 + 0.93817277604002 + 0.93938836375078 + 0.94098797784814 + 0.94312682316037 + 0.94605119649303 + 0.95019283145299 + 0.95638876002600 + 0.96668971052978 + 1.00000000000000 + 0.96216365293709 + 0.94398076144913 + 0.92798168093795 + 0.91257643318956 + 0.89717797819341 + 0.88151585525459 + 0.86547092814520 + 0.84901200532813 + 0.83215277710258 + 0.81495845029394 + 0.79756694867284 + 0.78015564295885 + 0.77149344600933 + 0.76289000536323 + 0.75436124837811 + 0.74591885680503 + 0.73756958096345 + 0.72931477530275 + 0.72115024755849 + 0.71306655996251 + 0.70504978258754 + 0.69707940038208 + 0.68907506077740 + 0.68080564217661 + 0.67215341442544 + 0.66310931453354 + 0.65366727111161 + 0.64384509002768 + 0.63366618490039 + 0.62315810948214 + 0.61235158635038 + 0.60128007691312 + 0.58997826283320 + 0.57845623464287 + 0.56675004827200 + 0.55489903821972 + 0.54294510977648 + 0.53093115744588 + 0.51889864839479 + 0.50687052370090 + 0.49485849814699 + 0.48287599210434 + 0.47092434162045 + 0.45899234210182 + 0.92525542304737 + 0.92525548714377 + 0.92525549777520 + 0.92525551017263 + 0.92525552462899 + 0.92525554148715 + 0.92525556114960 + 0.92525558408781 + 0.92525561086207 + 0.92525564219684 + 0.92525567918013 + 0.92525572345735 + 0.92525577700054 + 0.92525584197548 + 0.92525592092038 + 0.92525601689597 + 0.92525613364369 + 0.92525627572866 + 0.92525644889994 + 0.92525666039879 + 0.92525691894362 + 0.92525723528554 + 0.92525762270782 + 0.92525809766394 + 0.92525868076413 + 0.92525939908501 + 0.92526029070314 + 0.92526140550770 + 0.92526280378831 + 0.92526456007222 + 0.92526677357770 + 0.92526956932475 + 0.92527310620851 + 0.92527758787419 + 0.92528327569143 + 0.92529050560708 + 0.92529971007714 + 0.92531144668341 + 0.92532645132303 + 0.92534569986063 + 0.92537045044868 + 0.92540235270545 + 0.92544356606631 + 0.92549679099831 + 0.92556454493432 + 0.92564862719773 + 0.92575212039186 + 0.92587867924924 + 0.92603037461811 + 0.92621083585051 + 0.92642699504162 + 0.92668845434683 + 0.92700793750842 + 0.92740233291863 + 0.92789459893748 + 0.92851554051441 + 0.92930659263651 + 0.93032486125948 + 0.93165048683399 + 0.93339907862227 + 0.93574632167392 + 0.93898132626661 + 0.94360171389744 + 0.95055053187009 + 0.96216365293709 + 1.00000000000000 + 0.95704011943569 + 0.93662658450917 + 0.91886156990509 + 0.90193366041731 + 0.88518785672431 + 0.86833619659311 + 0.85125882519449 + 0.83391703214555 + 0.81634285382840 + 0.79865216441559 + 0.78100641063128 + 0.77224721722192 + 0.76355851815009 + 0.75495501112782 + 0.74644723720240 + 0.73804088712630 + 0.72973633235934 + 0.72152847066730 + 0.71340702453156 + 0.70535729318345 + 0.69735805004898 + 0.68932813351483 + 0.68103534682277 + 0.67236144639356 + 0.66329723107747 + 0.65383651931916 + 0.64399706318061 + 0.63380222609715 + 0.62327950918139 + 0.61245957771165 + 0.60137583170885 + 0.59006288790441 + 0.57853074945929 + 0.56681541485171 + 0.55495616541744 + 0.54299485745174 + 0.53097433929005 + 0.51893603242846 + 0.50690282458555 + 0.49488637423354 + 0.48290004593937 + 0.47094511462603 + 0.45901031082867 + 0.91608421080846 + 0.91608426901472 + 0.91608427866807 + 0.91608428992359 + 0.91608430304815 + 0.91608431835338 + 0.91608433620375 + 0.91608435702508 + 0.91608438132776 + 0.91608440976800 + 0.91608444333747 + 0.91608448354148 + 0.91608453217933 + 0.91608459123232 + 0.91608466301598 + 0.91608475032641 + 0.91608485658102 + 0.91608498594786 + 0.91608514368296 + 0.91608533640590 + 0.91608557208271 + 0.91608586053685 + 0.91608621390792 + 0.91608664722153 + 0.91608717930325 + 0.91608783489428 + 0.91608864884658 + 0.91608966683495 + 0.91609094401578 + 0.91609254850415 + 0.91609457102096 + 0.91609712578970 + 0.91610035787603 + 0.91610445307052 + 0.91610964961694 + 0.91611625344036 + 0.91612465791106 + 0.91613536957750 + 0.91614905639442 + 0.91616660330378 + 0.91618914915311 + 0.91621818471715 + 0.91625565775733 + 0.91630399470699 + 0.91636541681908 + 0.91644143252728 + 0.91653468611490 + 0.91664827604178 + 0.91678373997223 + 0.91694394525435 + 0.91713464729338 + 0.91736383110134 + 0.91764203167888 + 0.91798315612863 + 0.91840601589648 + 0.91893564192591 + 0.91960533697483 + 0.92046042461314 + 0.92156346340968 + 0.92300272354589 + 0.92490856717082 + 0.92748757111133 + 0.93107176583138 + 0.93621484428530 + 0.94398076144913 + 0.95704011943569 + 1.00000000000000 + 0.95126011525616 + 0.92843709006996 + 0.90882312317839 + 0.89034902647094 + 0.87228148845298 + 0.85430539650012 + 0.83627975498783 + 0.81817705851441 + 0.80007587026432 + 0.78211203254139 + 0.77322222267657 + 0.76441922840293 + 0.75571594591763 + 0.74712126847317 + 0.73863937457800 + 0.73026924714983 + 0.72200450991232 + 0.71383371851206 + 0.70574110798337 + 0.69770447594770 + 0.68964157353908 + 0.68131879523833 + 0.67261721651622 + 0.66352743706041 + 0.65404311519252 + 0.64418191633636 + 0.63396712319062 + 0.62342615396770 + 0.61258958601821 + 0.60149072723077 + 0.59016409892902 + 0.57861958298894 + 0.56689309478767 + 0.55502383934713 + 0.54305360327652 + 0.53102517016848 + 0.51897989877975 + 0.50694060615979 + 0.49491887772565 + 0.48292800648252 + 0.47096919023002 + 0.45903107859576 + 0.90595631325223 + 0.90595636611901 + 0.90595637488582 + 0.90595638510692 + 0.90595639702568 + 0.90595641092251 + 0.90595642712964 + 0.90595644603358 + 0.90595646809754 + 0.90595649391582 + 0.90595652439272 + 0.90595656090450 + 0.90595660509369 + 0.90595665877456 + 0.90595672405426 + 0.90595680349396 + 0.90595690020943 + 0.90595701801317 + 0.90595716170418 + 0.90595733733454 + 0.90595755218922 + 0.90595781524124 + 0.90595813758465 + 0.90595853295069 + 0.90595901853044 + 0.90595961694230 + 0.90596036008246 + 0.90596128978436 + 0.90596245650993 + 0.90596392253885 + 0.90596577083696 + 0.90596810579740 + 0.90597105990688 + 0.90597480272201 + 0.90597955149633 + 0.90598558493205 + 0.90599326100676 + 0.90600304012285 + 0.90601552886093 + 0.90603153012039 + 0.90605207530055 + 0.90607851237543 + 0.90611259919557 + 0.90615651731439 + 0.90621222740997 + 0.90628098903655 + 0.90636506820817 + 0.90646708682539 + 0.90658814244807 + 0.90673046827983 + 0.90689882844181 + 0.90709984963644 + 0.90734224009118 + 0.90763743880279 + 0.90800085661067 + 0.90845285249996 + 0.90902026437293 + 0.90973925564022 + 0.91065911163909 + 0.91184825193064 + 0.91340577540160 + 0.91548510884552 + 0.91832240688390 + 0.92228217329753 + 0.92798168093795 + 0.93662658450917 + 0.95126011525616 + 1.00000000000000 + 0.94476452387936 + 0.91936894289002 + 0.89784982937771 + 0.87783876758596 + 0.85850578186573 + 0.83948505308636 + 0.82063272667062 + 0.80196010434331 + 0.78355980762922 + 0.77449242399543 + 0.76553488052992 + 0.75669736610710 + 0.74798634108782 + 0.73940378476318 + 0.73094668676005 + 0.72260686214048 + 0.71437122577459 + 0.70622252823940 + 0.69813721671383 + 0.69003156919270 + 0.68167012101034 + 0.67293303709513 + 0.66381062888048 + 0.65429632166533 + 0.64440764483957 + 0.63416775488603 + 0.62360394279587 + 0.61274665383017 + 0.60162906002510 + 0.59028554449626 + 0.57872582139566 + 0.56698568748686 + 0.55510423959279 + 0.54312316634119 + 0.53108516139589 + 0.51903149786757 + 0.50698489935105 + 0.49495685644588 + 0.48296057031021 + 0.47099714124835 + 0.45905511776152 + 0.89485237801391 + 0.89485242600512 + 0.89485243396331 + 0.89485244324061 + 0.89485245405785 + 0.89485246667114 + 0.89485248137845 + 0.89485249853229 + 0.89485251855226 + 0.89485254197878 + 0.89485256963502 + 0.89485260277684 + 0.89485264290640 + 0.89485269167686 + 0.89485275101472 + 0.89485282325828 + 0.89485291124956 + 0.89485301847186 + 0.89485314930761 + 0.89485330928906 + 0.89485350507191 + 0.89485374485645 + 0.89485403877534 + 0.89485439936965 + 0.89485484234487 + 0.89485538836298 + 0.89485606662302 + 0.89485691542644 + 0.89485798093972 + 0.89485932010071 + 0.89486100878452 + 0.89486314240376 + 0.89486584196374 + 0.89486926223127 + 0.89487360135205 + 0.89487911328294 + 0.89488612387466 + 0.89489505171811 + 0.89490644784384 + 0.89492104098051 + 0.89493976560004 + 0.89496384109867 + 0.89499485470523 + 0.89503476887873 + 0.89508531504418 + 0.89514754048400 + 0.89522338522168 + 0.89531506360710 + 0.89542331258365 + 0.89554983986460 + 0.89569857531036 + 0.89587500449723 + 0.89608630892199 + 0.89634187830774 + 0.89665432056577 + 0.89704018400715 + 0.89752110538143 + 0.89812600220765 + 0.89889388963014 + 0.89987826448926 + 0.90115557567077 + 0.90284252489212 + 0.90511360781919 + 0.90822449463731 + 0.91257643318956 + 0.91886156990509 + 0.92843709006996 + 0.94476452387936 + 1.00000000000000 + 0.93749705396425 + 0.90939027961547 + 0.88594310180476 + 0.86443565099354 + 0.84390951942710 + 0.82396480913719 + 0.80448091680111 + 0.78547275665518 + 0.77616098679752 + 0.76699216978322 + 0.75797228965634 + 0.74910411114199 + 0.74038633607942 + 0.73181303191241 + 0.72337339937879 + 0.71505201017531 + 0.70682951647211 + 0.69868047481363 + 0.69051914697732 + 0.68210759385754 + 0.67332475101135 + 0.66416050996210 + 0.65460795559069 + 0.64468440665572 + 0.63441282564082 + 0.62382031133908 + 0.61293711326152 + 0.60179620544891 + 0.59043177273753 + 0.57885329790952 + 0.56709640999973 + 0.55520005383181 + 0.54320578144189 + 0.53115616246186 + 0.51909235366729 + 0.50703695518667 + 0.49500133449120 + 0.48299857473666 + 0.47102965275216 + 0.45908299035040 + 0.88277327128617 + 0.88277331479532 + 0.88277332200936 + 0.88277333041928 + 0.88277334022402 + 0.88277335165658 + 0.88277336498700 + 0.88277338053473 + 0.88277339867822 + 0.88277341990771 + 0.88277344497193 + 0.88277347501806 + 0.88277351141571 + 0.88277355567402 + 0.88277360954754 + 0.88277367516729 + 0.88277375513043 + 0.88277385261176 + 0.88277397160995 + 0.88277411718221 + 0.88277429539711 + 0.88277451374678 + 0.88277478147859 + 0.88277511004033 + 0.88277551376653 + 0.88277601153189 + 0.88277663003818 + 0.88277740433803 + 0.88277837664837 + 0.88277959900297 + 0.88278114076782 + 0.88278308911474 + 0.88278555453982 + 0.88278867827832 + 0.88279264102205 + 0.88279767416761 + 0.88280407431265 + 0.88281222204810 + 0.88282261798319 + 0.88283592361599 + 0.88285298575647 + 0.88287490775899 + 0.88290312321460 + 0.88293939818382 + 0.88298526226252 + 0.88304158232454 + 0.88311001783325 + 0.88319243528007 + 0.88328927902418 + 0.88340182390785 + 0.88353329900197 + 0.88368823210341 + 0.88387252886983 + 0.88409387578717 + 0.88436256444633 + 0.88469202044645 + 0.88509966456098 + 0.88560861713158 + 0.88624981357508 + 0.88706526264640 + 0.88811444116632 + 0.88948743390003 + 0.89131625616284 + 0.89378716327468 + 0.89717797819341 + 0.90193366041731 + 0.90882312317839 + 0.91936894289002 + 0.93749705396425 + 1.00000000000000 + 0.92940619664570 + 0.89848203595415 + 0.87311548850634 + 0.85016976550911 + 0.82856875679504 + 0.80790075456444 + 0.78802870319051 + 0.77837508435208 + 0.76891329655602 + 0.75964250794810 + 0.75055965798906 + 0.74165840582742 + 0.73292841567928 + 0.72435501932490 + 0.71591937395824 + 0.70759911367568 + 0.69936610828804 + 0.69113182467522 + 0.68265499584769 + 0.67381287789617 + 0.66459474485400 + 0.65499318086861 + 0.64502518058606 + 0.63471341088461 + 0.62408468275625 + 0.61316895790205 + 0.60199892384758 + 0.59060848272978 + 0.57900679853236 + 0.56722926464191 + 0.55531461374515 + 0.54330420863590 + 0.53124044877980 + 0.51916433351332 + 0.50709829993454 + 0.49505355550470 + 0.48304303158288 + 0.47106754832381 + 0.45911536845657 + 0.86974547159775 + 0.86974551096169 + 0.86974551748715 + 0.86974552509483 + 0.86974553396439 + 0.86974554430564 + 0.86974555636380 + 0.86974557042487 + 0.86974558683289 + 0.86974560603223 + 0.86974562870273 + 0.86974565588730 + 0.86974568883511 + 0.86974572891856 + 0.86974577773744 + 0.86974583723031 + 0.86974590976293 + 0.86974599822645 + 0.86974610626746 + 0.86974623849547 + 0.86974640044271 + 0.86974659894007 + 0.86974684242301 + 0.86974714132441 + 0.86974750871364 + 0.86974796180974 + 0.86974852501498 + 0.86974923036986 + 0.86975011644364 + 0.86975123074994 + 0.86975263664820 + 0.86975441372746 + 0.86975666281961 + 0.86975951273415 + 0.86976312816306 + 0.86976771983622 + 0.86977355763449 + 0.86978098748477 + 0.86979046407598 + 0.86980258775266 + 0.86981812579873 + 0.86983807650955 + 0.86986373474203 + 0.86989669001710 + 0.86993829402989 + 0.86998926086490 + 0.87005100880052 + 0.87012510799340 + 0.87021176836306 + 0.87031191082177 + 0.87042817719801 + 0.87056429266568 + 0.87072509777359 + 0.87091686373260 + 0.87114796619360 + 0.87142926568181 + 0.87177475053204 + 0.87220286937860 + 0.87273813068134 + 0.87341355464362 + 0.87427560061846 + 0.87539441329071 + 0.87687133298427 + 0.87884523185863 + 0.88151585525459 + 0.88518785672431 + 0.89034902647094 + 0.89784982937771 + 0.90939027961547 + 0.92940619664570 + 1.00000000000000 + 0.92044500142701 + 0.88662772396295 + 0.85936910860467 + 0.83509697409714 + 0.81262902104213 + 0.79149372164981 + 0.78135114648724 + 0.77147518721974 + 0.76185332939345 + 0.75247287591594 + 0.74331939645884 + 0.73437567712187 + 0.72562114400601 + 0.71703184499872 + 0.70858097367369 + 0.70023650653376 + 0.69190597191891 + 0.68334356765056 + 0.67442422141085 + 0.66513628741309 + 0.65547160564489 + 0.64544667195769 + 0.63508370390198 + 0.62440908287054 + 0.61345234883975 + 0.60224577614944 + 0.59082286515531 + 0.57919234044746 + 0.56738926569290 + 0.55545207876999 + 0.54342188139886 + 0.53134084043665 + 0.51924974267318 + 0.50717080993508 + 0.49511504151666 + 0.48309517322208 + 0.47111182598697 + 0.45915306226477 + 0.85582591526708 + 0.85582595077808 + 0.85582595666442 + 0.85582596352640 + 0.85582597152639 + 0.85582598085324 + 0.85582599172818 + 0.85582600441002 + 0.85582601920787 + 0.85582603652162 + 0.85582605696763 + 0.85582608149417 + 0.85582611123732 + 0.85582614744168 + 0.85582619156204 + 0.85582624535971 + 0.85582631098411 + 0.85582639106228 + 0.85582648891477 + 0.85582660873141 + 0.85582675555013 + 0.85582693558786 + 0.85582715651839 + 0.85582742784101 + 0.85582776145006 + 0.85582817303300 + 0.85582868484829 + 0.85582932614521 + 0.85583013211215 + 0.85583114607417 + 0.85583242583888 + 0.85583404398139 + 0.85583609241347 + 0.85583868849272 + 0.85584198218341 + 0.85584616523975 + 0.85585148302651 + 0.85585824974949 + 0.85586687811875 + 0.85587791267584 + 0.85589204831014 + 0.85591018789763 + 0.85593350060516 + 0.85596341681165 + 0.85600113113637 + 0.85604722876614 + 0.85610292080544 + 0.85616952548085 + 0.85624706785075 + 0.85633618208232 + 0.85643901940838 + 0.85655863385220 + 0.85669897842261 + 0.85686514992766 + 0.85706394003115 + 0.85730410119956 + 0.85759682188160 + 0.85795677102797 + 0.85840331010363 + 0.85896235147167 + 0.85967021032442 + 0.86058174439069 + 0.86177540375817 + 0.86335616669093 + 0.86547092814520 + 0.86833619659311 + 0.87228148845298 + 0.87783876758596 + 0.88594310180476 + 0.89848203595415 + 0.92044500142701 + 1.00000000000000 + 0.91055648586088 + 0.87378754019083 + 0.84472974401551 + 0.81934742436070 + 0.79628594102779 + 0.78542148102086 + 0.77494398696794 + 0.76481937898526 + 0.75501796724701 + 0.74551160921258 + 0.73627182388935 + 0.72726864637421 + 0.71847020612973 + 0.70984296402736 + 0.70134910744459 + 0.69289049306209 + 0.68421503021317 + 0.67519435690936 + 0.66581543347591 + 0.65606897806934 + 0.64597071443534 + 0.63554217495965 + 0.62480909870876 + 0.61380040718534 + 0.60254777880733 + 0.59108414305103 + 0.57941761767240 + 0.56758280573433 + 0.55561773627960 + 0.54356315164411 + 0.53146090134189 + 0.51935148553438 + 0.50725684153111 + 0.49518769733266 + 0.48315653629104 + 0.47116372533341 + 0.45919707402192 + 0.84109868089064 + 0.84109871280816 + 0.84109871809871 + 0.84109872426588 + 0.84109873145488 + 0.84109873983668 + 0.84109874960876 + 0.84109876100402 + 0.84109877430018 + 0.84109878985603 + 0.84109880823142 + 0.84109883028181 + 0.84109885703808 + 0.84109888962799 + 0.84109892936802 + 0.84109897785621 + 0.84109903703801 + 0.84109910929877 + 0.84109919764619 + 0.84109930588959 + 0.84109943860022 + 0.84109960142045 + 0.84109980131858 + 0.84110004692631 + 0.84110034904565 + 0.84110072193542 + 0.84110118586203 + 0.84110176747575 + 0.84110249881842 + 0.84110341933264 + 0.84110458166097 + 0.84110605188764 + 0.84110791365663 + 0.84111027374219 + 0.84111326851138 + 0.84111707222002 + 0.84112190768205 + 0.84112805996321 + 0.84113590329328 + 0.84114593110466 + 0.84115877217344 + 0.84117524242460 + 0.84119639679135 + 0.84122352171751 + 0.84125767286639 + 0.84129932706354 + 0.84134951759002 + 0.84140934884383 + 0.84147870314516 + 0.84155798495453 + 0.84164893707589 + 0.84175405385541 + 0.84187655061460 + 0.84202055188656 + 0.84219154208822 + 0.84239654316143 + 0.84264446023305 + 0.84294690067468 + 0.84331909086428 + 0.84378128886772 + 0.84436182574497 + 0.84510365665672 + 0.84606775970693 + 0.84733406992191 + 0.84901200532813 + 0.85125882519449 + 0.85430539650012 + 0.85850578186573 + 0.86443565099354 + 0.87311548850634 + 0.88662772396295 + 0.91055648586088 + 1.00000000000000 + 0.89964848281917 + 0.85994910593452 + 0.82931074215871 + 0.80311359776142 + 0.79113160432517 + 0.77974508293430 + 0.76887586353013 + 0.75846157478316 + 0.74844903802801 + 0.73879009776296 + 0.72943901190891 + 0.72035104479520 + 0.71148202774409 + 0.70278523584969 + 0.69415411474056 + 0.68532764315260 + 0.67617269331149 + 0.66667406560933 + 0.65682075439447 + 0.64662727440527 + 0.63611410406683 + 0.62530601534883 + 0.61423101771042 + 0.60291992631031 + 0.59140485655546 + 0.57969308385226 + 0.56781856668019 + 0.55581876642554 + 0.54373393027706 + 0.53160547435522 + 0.51947351167191 + 0.50735960228526 + 0.49527411919084 + 0.48322921843437 + 0.47122494151351 + 0.45924877699726 + 0.82565898327992 + 0.82565901184137 + 0.82565901657529 + 0.82565902209292 + 0.82565902852610 + 0.82565903602462 + 0.82565904476722 + 0.82565905496106 + 0.82565906685534 + 0.82565908077252 + 0.82565909721295 + 0.82565911695170 + 0.82565914091934 + 0.82565917013389 + 0.82565920578503 + 0.82565924931328 + 0.82565930248001 + 0.82565936743681 + 0.82565944690849 + 0.82565954433949 + 0.82565966386882 + 0.82565981060452 + 0.82565999086063 + 0.82566021244915 + 0.82566048516296 + 0.82566082192714 + 0.82566124114999 + 0.82566176705646 + 0.82566242875531 + 0.82566326207183 + 0.82566431485091 + 0.82566564713096 + 0.82566733489091 + 0.82566947508167 + 0.82567219147971 + 0.82567564216625 + 0.82568002913671 + 0.82568561061176 + 0.82569272540401 + 0.82570181999520 + 0.82571346255988 + 0.82572838950367 + 0.82574755154506 + 0.82577210447135 + 0.82580298062426 + 0.82584056601979 + 0.82588574120595 + 0.82593942925747 + 0.82600140521173 + 0.82607189197573 + 0.82615229346008 + 0.82624463848443 + 0.82635153084942 + 0.82647629228981 + 0.82662333082754 + 0.82679825075593 + 0.82700809826520 + 0.82726200280237 + 0.82757186696274 + 0.82795343982596 + 0.82842873419358 + 0.82903134615545 + 0.82980871463006 + 0.83082186178879 + 0.83215277710258 + 0.83391703214555 + 0.83627975498783 + 0.83948505308636 + 0.84390951942710 + 0.85016976550911 + 0.85936910860467 + 0.87378754019083 + 0.89964848281917 + 1.00000000000000 + 0.88768416680891 + 0.84522161637157 + 0.81331425314423 + 0.79946664509944 + 0.78661928091859 + 0.77458929466356 + 0.76324318007752 + 0.75247703613999 + 0.74220517358928 + 0.73235325818106 + 0.72285424930915 + 0.71364623548211 + 0.70466809920621 + 0.69580029083917 + 0.68676866446876 + 0.67743294789723 + 0.66777449506204 + 0.65777958234106 + 0.64746079592754 + 0.63683696709267 + 0.62593139145679 + 0.61477071704917 + 0.60338449505479 + 0.59180366883883 + 0.58003433215509 + 0.56810953470760 + 0.55606594439426 + 0.54394312187592 + 0.53178188764135 + 0.51962182822731 + 0.50748399930869 + 0.49537830514527 + 0.48331647348814 + 0.47129812480790 + 0.45931033609407 + 0.80963049211213 + 0.80963051754462 + 0.80963052175939 + 0.80963052667258 + 0.80963053239985 + 0.80963053907659 + 0.80963054686084 + 0.80963055593585 + 0.80963056652469 + 0.80963057891368 + 0.80963059355315 + 0.80963061113964 + 0.80963063251045 + 0.80963065858177 + 0.80963069042309 + 0.80963072933105 + 0.80963077689184 + 0.80963083504429 + 0.80963090624286 + 0.80963099359772 + 0.80963110084296 + 0.80963123259079 + 0.80963139454043 + 0.80963159375193 + 0.80963183906672 + 0.80963214217689 + 0.80963251976161 + 0.80963299378006 + 0.80963359061775 + 0.80963434273600 + 0.80963529351614 + 0.80963649738818 + 0.80963802321516 + 0.80963995885425 + 0.80964241642843 + 0.80964553906946 + 0.80964950956441 + 0.80965456140869 + 0.80966100082983 + 0.80966923117397 + 0.80967976506477 + 0.80969326616143 + 0.80971059007362 + 0.80973277391028 + 0.80976064050711 + 0.80979450010707 + 0.80983510223854 + 0.80988321658482 + 0.80993854049315 + 0.81000115578001 + 0.81007218658300 + 0.81015327618147 + 0.81024652370054 + 0.81035459106891 + 0.81048100393396 + 0.81063021039560 + 0.81080774982135 + 0.81102075391058 + 0.81127846176888 + 0.81159303310420 + 0.81198147823214 + 0.81247000434399 + 0.81309547533226 + 0.81390444962025 + 0.81495845029394 + 0.81634285382840 + 0.81817705851441 + 0.82063272667062 + 0.82396480913719 + 0.82856875679504 + 0.83509697409714 + 0.84472974401551 + 0.85994910593452 + 0.88768416680891 + 1.00000000000000 + 0.87473652640341 + 0.82979337213186 + 0.81240542209096 + 0.79696702213045 + 0.78297942166206 + 0.77012234201881 + 0.75817230085001 + 0.74696242875044 + 0.73636080179809 + 0.72625808071032 + 0.71656038871384 + 0.70718180047002 + 0.69798154288457 + 0.68866527359738 + 0.67908151621489 + 0.66920590188408 + 0.65902026718985 + 0.64853403333372 + 0.63776339273202 + 0.62672933777940 + 0.61545644542591 + 0.60397238540845 + 0.59230638903019 + 0.58046286876590 + 0.56847357861166 + 0.55637406607739 + 0.54420293107589 + 0.53200016820425 + 0.51980464165690 + 0.50763672611567 + 0.49550570057210 + 0.48342272656215 + 0.47138687404568 + 0.45938468652631 + 0.79319310720328 + 0.79319312974458 + 0.79319313348013 + 0.79319313783387 + 0.79319314290937 + 0.79319314882640 + 0.79319315572421 + 0.79319316376656 + 0.79319317314872 + 0.79319318412830 + 0.79319319710393 + 0.79319321270194 + 0.79319323167388 + 0.79319325484082 + 0.79319328316303 + 0.79319331780306 + 0.79319336018358 + 0.79319341204820 + 0.79319347560482 + 0.79319355364765 + 0.79319364954171 + 0.79319376743813 + 0.79319391247169 + 0.79319409100191 + 0.79319431100247 + 0.79319458302508 + 0.79319492214442 + 0.79319534823215 + 0.79319588515501 + 0.79319656227506 + 0.79319741885689 + 0.79319850416009 + 0.79319988049872 + 0.79320162736430 + 0.79320384616847 + 0.79320666633055 + 0.79321025303295 + 0.79321481714670 + 0.79322063512356 + 0.79322807092639 + 0.79323758657901 + 0.79324977959631 + 0.79326541930588 + 0.79328543561671 + 0.79331055462046 + 0.79334102385825 + 0.79337748109127 + 0.79342056709197 + 0.79346992585924 + 0.79352553201096 + 0.79358828074942 + 0.79365949864139 + 0.79374087176640 + 0.79383452436710 + 0.79394326483003 + 0.79407060632283 + 0.79422087732905 + 0.79439961237739 + 0.79461393299192 + 0.79487316148239 + 0.79519036827237 + 0.79558594122308 + 0.79608848062311 + 0.79673344273375 + 0.79756694867284 + 0.79865216441559 + 0.80007587026432 + 0.80196010434331 + 0.80448091680111 + 0.80790075456444 + 0.81262902104213 + 0.81934742436070 + 0.82931074215871 + 0.84522161637157 + 0.87473652640341 + 1.00000000000000 + 0.86089379175260 + 0.83476994204463 + 0.81383751215571 + 0.79608614957671 + 0.78051893418410 + 0.76655376551544 + 0.75381176566532 + 0.74202586539926 + 0.73099569513121 + 0.72056336061563 + 0.71059619200425 + 0.70091605920369 + 0.69119558276186 + 0.68126464959754 + 0.67108887102604 + 0.66064248440878 + 0.64992951006540 + 0.63896176794703 + 0.62775655222166 + 0.61633521157605 + 0.60472255748478 + 0.59294527727463 + 0.58100535506463 + 0.56893267517819 + 0.55676118708018 + 0.54452813449911 + 0.53227235813017 + 0.52003172418865 + 0.50782568146421 + 0.49566266916613 + 0.48355309536766 + 0.47149530549436 + 0.45947514706901 + 0.77655708727286 + 0.77655710717416 + 0.77655711047225 + 0.77655711431561 + 0.77655711879650 + 0.77655712401946 + 0.77655713010832 + 0.77655713720759 + 0.77655714548956 + 0.77655715518137 + 0.77655716663936 + 0.77655718042423 + 0.77655719720708 + 0.77655721772423 + 0.77655724283417 + 0.77655727357912 + 0.77655731123177 + 0.77655735735566 + 0.77655741393288 + 0.77655748347519 + 0.77655756900302 + 0.77655767425142 + 0.77655780383729 + 0.77655796348374 + 0.77655816037053 + 0.77655840400631 + 0.77655870800622 + 0.77655909033057 + 0.77655957254875 + 0.77656018119319 + 0.77656095177224 + 0.77656192883524 + 0.77656316872982 + 0.77656474332971 + 0.77656674431636 + 0.77656928864957 + 0.77657252554378 + 0.77657664537708 + 0.77658189765869 + 0.77658861074732 + 0.77659720101683 + 0.77660820641405 + 0.77662231870926 + 0.77664037186081 + 0.77666300715040 + 0.77669042077677 + 0.77672315592888 + 0.77676174598004 + 0.77680580115195 + 0.77685521690169 + 0.77691070318690 + 0.77697332914782 + 0.77704444646427 + 0.77712574609714 + 0.77721945987467 + 0.77732835361631 + 0.77745579423258 + 0.77760605444603 + 0.77778459184744 + 0.77799851083083 + 0.77825780931310 + 0.77857832547377 + 0.77898223511895 + 0.77949649861044 + 0.78015564295885 + 0.78100641063128 + 0.78211203254139 + 0.78355980762922 + 0.78547275665518 + 0.78802870319051 + 0.79149372164981 + 0.79628594102779 + 0.80311359776142 + 0.81331425314423 + 0.82979337213186 + 0.86089379175260 + 1.00000000000000 + 0.88546131418185 + 0.84621819970261 + 0.81899687474665 + 0.79758580461821 + 0.77969233258924 + 0.76417239997729 + 0.75035460752940 + 0.73780138196172 + 0.72620513799674 + 0.71533315893542 + 0.70493421316070 + 0.69462198654982 + 0.68419278897535 + 0.67359343160187 + 0.66278433602830 + 0.65175982811478 + 0.64052416063640 + 0.62908846538061 + 0.61746889962986 + 0.60568581846592 + 0.59376204692356 + 0.58169599762364 + 0.56951481706575 + 0.55725014761692 + 0.54493729934775 + 0.53261348717936 + 0.52031518855502 + 0.50806058508250 + 0.49585698131269 + 0.48371377723786 + 0.47162835987488 + 0.45958566440339 + 0.76822469121220 + 0.76822470989015 + 0.76822471298503 + 0.76822471659263 + 0.76822472079739 + 0.76822472569913 + 0.76822473141296 + 0.76822473807479 + 0.76822474584695 + 0.76822475494245 + 0.76822476569777 + 0.76822477864184 + 0.76822479441131 + 0.76822481369950 + 0.76822483731961 + 0.76822486625703 + 0.76822490171756 + 0.76822494518088 + 0.76822499851957 + 0.76822506411803 + 0.76822514483727 + 0.76822524421675 + 0.76822536663568 + 0.76822551752005 + 0.76822570368007 + 0.76822593414336 + 0.76822622184442 + 0.76822658385721 + 0.76822704068343 + 0.76822761754238 + 0.76822834819939 + 0.76822927501850 + 0.76823045157923 + 0.76823194622941 + 0.76823384614161 + 0.76823626250953 + 0.76823933717044 + 0.76824325103455 + 0.76824824117431 + 0.76825461953135 + 0.76826278145293 + 0.76827323748950 + 0.76828664378615 + 0.76830379035790 + 0.76832528023375 + 0.76835128766882 + 0.76838231432724 + 0.76841884701456 + 0.76846048506306 + 0.76850709319416 + 0.76855930298667 + 0.76861807423998 + 0.76868461707582 + 0.76876043975274 + 0.76884753147695 + 0.76894834502619 + 0.76906584676587 + 0.76920378601305 + 0.76936693309236 + 0.76956147991733 + 0.76979616168065 + 0.77008493991063 + 0.77044734877727 + 0.77090689519270 + 0.77149344600933 + 0.77224721722192 + 0.77322222267657 + 0.77449242399543 + 0.77616098679752 + 0.77837508435208 + 0.78135114648724 + 0.78542148102086 + 0.79113160432517 + 0.79946664509944 + 0.81240542209096 + 0.83476994204463 + 0.88546131418185 + 1.00000000000000 + 0.87903716569646 + 0.83864043703859 + 0.81097774623190 + 0.78942505954716 + 0.77153679214346 + 0.75609219207944 + 0.74237606624497 + 0.72992381656469 + 0.71840644950650 + 0.70750784303334 + 0.69679339245606 + 0.68603193674773 + 0.67515462235157 + 0.66411069075055 + 0.65288674911837 + 0.64148120958548 + 0.62990059560640 + 0.61815729552607 + 0.60626851185176 + 0.59425439766561 + 0.58211095699463 + 0.56986350008614 + 0.55754214064110 + 0.54518092101031 + 0.53281600075956 + 0.52048296483544 + 0.50819919090330 + 0.49597127082708 + 0.48380797632006 + 0.47170610227224 + 0.45965002410830 + 0.75991652590712 + 0.75991654342839 + 0.75991654633126 + 0.75991654971502 + 0.75991655365979 + 0.75991655825780 + 0.75991656361727 + 0.75991656986699 + 0.75991657715772 + 0.75991658568997 + 0.75991659578023 + 0.75991660793080 + 0.75991662274062 + 0.75991664086856 + 0.75991666308123 + 0.75991669031151 + 0.75991672369952 + 0.75991676464373 + 0.75991681492286 + 0.75991687679099 + 0.75991695296271 + 0.75991704679071 + 0.75991716242637 + 0.75991730501985 + 0.75991748103191 + 0.75991769902748 + 0.75991797130547 + 0.75991831409161 + 0.75991874688130 + 0.75991929364740 + 0.75991998650747 + 0.75992086575173 + 0.75992198234536 + 0.75992340129435 + 0.75992520550875 + 0.75992750073133 + 0.75993042182255 + 0.75993414075478 + 0.75993888285906 + 0.75994494458578 + 0.75995270145486 + 0.75996263820239 + 0.75997537743790 + 0.75999166788743 + 0.76001207698648 + 0.76003675929239 + 0.76006617850912 + 0.76010077922473 + 0.76014015324132 + 0.76018413964284 + 0.76023330016575 + 0.76028849689917 + 0.76035081374684 + 0.76042159651731 + 0.76050261898261 + 0.76059605686118 + 0.76070452339893 + 0.76083130779796 + 0.76098057798878 + 0.76115772814922 + 0.76137038990914 + 0.76163087937110 + 0.76195641809966 + 0.76236751186701 + 0.76289000536323 + 0.76355851815009 + 0.76441922840293 + 0.76553488052992 + 0.76699216978322 + 0.76891329655602 + 0.77147518721974 + 0.77494398696794 + 0.77974508293430 + 0.78661928091859 + 0.79696702213045 + 0.81383751215571 + 0.84621819970261 + 0.87903716569646 + 1.00000000000000 + 0.87238977769132 + 0.83091997553498 + 0.80289911068009 + 0.78127116192599 + 0.76343320069471 + 0.74808883289777 + 0.73448162718586 + 0.72211845743333 + 0.71058045238111 + 0.69936160855899 + 0.68819052898800 + 0.67697531782434 + 0.66564919148551 + 0.65418787538946 + 0.64258175501173 + 0.63083117934132 + 0.61894360439280 + 0.60693219084663 + 0.59481372608921 + 0.58258123848966 + 0.57025778189912 + 0.55787160968450 + 0.54545523427169 + 0.53304355132194 + 0.52067108497766 + 0.50835426619646 + 0.49609885366068 + 0.48391288871263 + 0.47179248217335 + 0.45972136599381 + 0.75165160322280 + 0.75165161965572 + 0.75165162237839 + 0.75165162555171 + 0.75165162925144 + 0.75165163356368 + 0.75165163858968 + 0.75165164445080 + 0.75165165128819 + 0.75165165928935 + 0.75165166875467 + 0.75165168015785 + 0.75165169406533 + 0.75165171110046 + 0.75165173198776 + 0.75165175760890 + 0.75165178904398 + 0.75165182761600 + 0.75165187500907 + 0.75165193336082 + 0.75165200524247 + 0.75165209383265 + 0.75165220307230 + 0.75165233784248 + 0.75165250427607 + 0.75165271050948 + 0.75165296822678 + 0.75165329286439 + 0.75165370295804 + 0.75165422130839 + 0.75165487846918 + 0.75165571277719 + 0.75165677272287 + 0.75165812015876 + 0.75165983396981 + 0.75166201475551 + 0.75166479079342 + 0.75166832563192 + 0.75167283353578 + 0.75167859635821 + 0.75168597096144 + 0.75169541779566 + 0.75170752795711 + 0.75172301143299 + 0.75174240258315 + 0.75176583833453 + 0.75179374773783 + 0.75182653717390 + 0.75186379384851 + 0.75190533576053 + 0.75195166258204 + 0.75200354931146 + 0.75206196763176 + 0.75212811933687 + 0.75220358748196 + 0.75229030336516 + 0.75239057002084 + 0.75250727368446 + 0.75264405631564 + 0.75280561743066 + 0.75299862775709 + 0.75323396498473 + 0.75352683145516 + 0.75389513193632 + 0.75436124837811 + 0.75495501112782 + 0.75571594591763 + 0.75669736610710 + 0.75797228965634 + 0.75964250794810 + 0.76185332939345 + 0.76481937898526 + 0.76887586353013 + 0.77458929466356 + 0.78297942166206 + 0.79608614957671 + 0.81899687474665 + 0.83864043703859 + 0.87238977769132 + 1.00000000000000 + 0.86552912087173 + 0.82308025474499 + 0.79478838729288 + 0.77314803068685 + 0.75539779960947 + 0.74016894370524 + 0.72666297656216 + 0.71428705438092 + 0.70242381274687 + 0.69074032493058 + 0.67910963651287 + 0.66744133560305 + 0.65569544554899 + 0.64385110188147 + 0.63190024231211 + 0.61984377740897 + 0.60768962514544 + 0.59545029180527 + 0.58311509933645 + 0.57070430995546 + 0.55824390017104 + 0.54576452725565 + 0.53329956718467 + 0.52088227901318 + 0.50852797568279 + 0.49624143945188 + 0.48402986082973 + 0.47188855891568 + 0.45980052476672 + 0.74344456721614 + 0.74344458262758 + 0.74344458518112 + 0.74344458815742 + 0.74344459162688 + 0.74344459567070 + 0.74344460038471 + 0.74344460588028 + 0.74344461229276 + 0.74344461979672 + 0.74344462867648 + 0.74344463937759 + 0.74344465243792 + 0.74344466844698 + 0.74344468808913 + 0.74344471220062 + 0.74344474180015 + 0.74344477814329 + 0.74344482282368 + 0.74344487786865 + 0.74344494571501 + 0.74344502938122 + 0.74344513260047 + 0.74344526001088 + 0.74344541742801 + 0.74344561258602 + 0.74344585659539 + 0.74344616413810 + 0.74344655284968 + 0.74344704442090 + 0.74344766793540 + 0.74344845988141 + 0.74344946641924 + 0.74345074642394 + 0.74345237498589 + 0.74345444785874 + 0.74345708711880 + 0.74346044838107 + 0.74346473549402 + 0.74347021657716 + 0.74347723094993 + 0.74348621624520 + 0.74349773397257 + 0.74351245781616 + 0.74353089142922 + 0.74355315598731 + 0.74357964894523 + 0.74361074216215 + 0.74364602079341 + 0.74368528578164 + 0.74372898180222 + 0.74377780640233 + 0.74383263173892 + 0.74389453227284 + 0.74396492267464 + 0.74404551927235 + 0.74413835347745 + 0.74424595984561 + 0.74437152280957 + 0.74451913926693 + 0.74469464624903 + 0.74490766748933 + 0.74517164663904 + 0.74550224023716 + 0.74591885680503 + 0.74644723720240 + 0.74712126847317 + 0.74798634108782 + 0.74910411114199 + 0.75055965798906 + 0.75247287591594 + 0.75501796724701 + 0.75846157478316 + 0.76324318007752 + 0.77012234201881 + 0.78051893418410 + 0.79758580461821 + 0.81097774623190 + 0.83091997553498 + 0.86552912087173 + 1.00000000000000 + 0.85846769647122 + 0.81514670928165 + 0.78667244801878 + 0.76507642471886 + 0.74744164493835 + 0.73232740762545 + 0.71881882822383 + 0.70611246170039 + 0.69377611466874 + 0.68162726078951 + 0.66953945433802 + 0.65744942972507 + 0.64532018783360 + 0.63313198518885 + 0.62087690553359 + 0.60855597475252 + 0.59617619243481 + 0.58372222034803 + 0.57121083974751 + 0.55866522222829 + 0.54611376321841 + 0.53358800304304 + 0.52111968621655 + 0.50872280102602 + 0.49640098223971 + 0.48416042685204 + 0.47199553577275 + 0.45988844549454 + 0.73530500671060 + 0.73530502116731 + 0.73530502356246 + 0.73530502635417 + 0.73530502960890 + 0.73530503340211 + 0.73530503782404 + 0.73530504297910 + 0.73530504899311 + 0.73530505603283 + 0.73530506436381 + 0.73530507440872 + 0.73530508667761 + 0.73530510172644 + 0.73530512020366 + 0.73530514289832 + 0.73530517077874 + 0.73530520503275 + 0.73530524717014 + 0.73530529911353 + 0.73530536317509 + 0.73530544221889 + 0.73530553978738 + 0.73530566028352 + 0.73530580923411 + 0.73530599398598 + 0.73530622510901 + 0.73530651657836 + 0.73530688517934 + 0.73530735155699 + 0.73530794340673 + 0.73530869547605 + 0.73530965172615 + 0.73531086823059 + 0.73531241650443 + 0.73531438773248 + 0.73531689815827 + 0.73532009592896 + 0.73532417509684 + 0.73532939086518 + 0.73533606606374 + 0.73534461690587 + 0.73535557713225 + 0.73536958641856 + 0.73538711992281 + 0.73540828477960 + 0.73543344965179 + 0.73546295523919 + 0.73549638684219 + 0.73553353191836 + 0.73557478650935 + 0.73562077942324 + 0.73567229472009 + 0.73573029453239 + 0.73579604521630 + 0.73587107449700 + 0.73595717666466 + 0.73605658033020 + 0.73617207328090 + 0.73630723149864 + 0.73646717102014 + 0.73666042508744 + 0.73689890886524 + 0.73719634031887 + 0.73756958096345 + 0.73804088712630 + 0.73863937457800 + 0.73940378476318 + 0.74038633607942 + 0.74165840582742 + 0.74331939645884 + 0.74551160921258 + 0.74844903802801 + 0.75247703613999 + 0.75817230085001 + 0.76655376551544 + 0.77969233258924 + 0.78942505954716 + 0.80289911068009 + 0.82308025474499 + 0.85846769647122 + 1.00000000000000 + 0.85122063537493 + 0.80714623134180 + 0.77857657186796 + 0.75707273697069 + 0.73956375652382 + 0.72445917249621 + 0.71061470103587 + 0.69742668896026 + 0.68461992476577 + 0.67201071308931 + 0.65950008905240 + 0.64702727359602 + 0.63455593062952 + 0.62206601628800 + 0.60954935493679 + 0.59700577139708 + 0.58441400456660 + 0.57178645606304 + 0.55914281599310 + 0.54650870469061 + 0.53391343343065 + 0.52138692545419 + 0.50894159366101 + 0.49657972000082 + 0.48430633819995 + 0.47211478187177 + 0.45998619989008 + 0.72723698423004 + 0.72723699779633 + 0.72723700004387 + 0.72723700266378 + 0.72723700571797 + 0.72723700927736 + 0.72723701342705 + 0.72723701826446 + 0.72723702390812 + 0.72723703051411 + 0.72723703833316 + 0.72723704776683 + 0.72723705929710 + 0.72723707344897 + 0.72723709083753 + 0.72723711220976 + 0.72723713848238 + 0.72723717078249 + 0.72723721054005 + 0.72723725957969 + 0.72723732009656 + 0.72723739480833 + 0.72723748708072 + 0.72723760109297 + 0.72723774210220 + 0.72723791708943 + 0.72723813611666 + 0.72723841249095 + 0.72723876219662 + 0.72723920489549 + 0.72723976697113 + 0.72724048153290 + 0.72724139046900 + 0.72724254721344 + 0.72724401990856 + 0.72724589544568 + 0.72724828456995 + 0.72725132840282 + 0.72725521177842 + 0.72726017775190 + 0.72726653366048 + 0.72727467558731 + 0.72728511121773 + 0.72729844836031 + 0.72731513571345 + 0.72733526792085 + 0.72735918741324 + 0.72738720677943 + 0.72741891336604 + 0.72745408427325 + 0.72749307262145 + 0.72753644628906 + 0.72758491147632 + 0.72763933138809 + 0.72770084196479 + 0.72777080580843 + 0.72785081069789 + 0.72794281980487 + 0.72804927804589 + 0.72817331248719 + 0.72831941736403 + 0.72849517935859 + 0.72871118740755 + 0.72897949126170 + 0.72931477530275 + 0.72973633235934 + 0.73026924714983 + 0.73094668676005 + 0.73181303191241 + 0.73292841567928 + 0.73437567712187 + 0.73627182388935 + 0.73879009776296 + 0.74220517358928 + 0.74696242875044 + 0.75381176566532 + 0.76417239997729 + 0.77153679214346 + 0.78127116192599 + 0.79478838729288 + 0.81514670928165 + 0.85122063537493 + 1.00000000000000 + 0.84380573985112 + 0.79910641638843 + 0.77052307716060 + 0.74914116111210 + 0.73165405166884 + 0.71620739688010 + 0.70187336524594 + 0.68821176232279 + 0.67494318927646 + 0.66191170945116 + 0.64902032657686 + 0.63620849500201 + 0.62343913915960 + 0.61069157597708 + 0.59795614234121 + 0.58520395546437 + 0.57244184949047 + 0.55968515585183 + 0.54695606537138 + 0.53428116607961 + 0.52168817986021 + 0.50918763794706 + 0.49678022159242 + 0.48446959831644 + 0.47224785789288 + 0.46009500528908 + 0.71923887849120 + 0.71923889122927 + 0.71923889334005 + 0.71923889579994 + 0.71923889866689 + 0.71923890200946 + 0.71923890590484 + 0.71923891044720 + 0.71923891574581 + 0.71923892194921 + 0.71923892929306 + 0.71923893815714 + 0.71923894899835 + 0.71923896231529 + 0.71923897868951 + 0.71923899882778 + 0.71923902360093 + 0.71923905407524 + 0.71923909160878 + 0.71923913793361 + 0.71923919513490 + 0.71923926579183 + 0.71923935310429 + 0.71923946104494 + 0.71923959460837 + 0.71923976043931 + 0.71923996811887 + 0.71924023032396 + 0.71924056228261 + 0.71924098272914 + 0.71924151681426 + 0.71924219609889 + 0.71924306051752 + 0.71924416101231 + 0.71924556255283 + 0.71924734797316 + 0.71924962284731 + 0.71925252167540 + 0.71925622061260 + 0.71926095127767 + 0.71926700642909 + 0.71927476322878 + 0.71928470487450 + 0.71929740928601 + 0.71931330057966 + 0.71933246229624 + 0.71935521295048 + 0.71938183977110 + 0.71941193378508 + 0.71944526448467 + 0.71948214714779 + 0.71952309568413 + 0.71956874753184 + 0.71961987885577 + 0.71967751103448 + 0.71974286228258 + 0.71981734083796 + 0.71990268001594 + 0.72000102900307 + 0.72011512889944 + 0.72024893875666 + 0.72040922455059 + 0.72060542552548 + 0.72084815778933 + 0.72115024755849 + 0.72152847066730 + 0.72200450991232 + 0.72260686214048 + 0.72337339937879 + 0.72435501932490 + 0.72562114400601 + 0.72726864637421 + 0.72943901190891 + 0.73235325818106 + 0.73636080179809 + 0.74202586539926 + 0.75035460752940 + 0.75609219207944 + 0.76343320069471 + 0.77314803068685 + 0.78667244801878 + 0.80714623134180 + 0.84380573985112 + 1.00000000000000 + 0.83624344485071 + 0.79105424618737 + 0.76252210195845 + 0.74116405471086 + 0.72332565736094 + 0.70738337088869 + 0.69257670057822 + 0.67845550567988 + 0.66476823846921 + 0.65136047800893 + 0.63813519343210 + 0.62503075909579 + 0.61200912862909 + 0.59904787375514 + 0.58610816215037 + 0.57318966596802 + 0.56030220540499 + 0.54746369770948 + 0.53469738061347 + 0.52202829956791 + 0.50946472720484 + 0.49700544290158 + 0.48465250398629 + 0.47239654640249 + 0.46021624690541 + 0.71130367848184 + 0.71130369045156 + 0.71130369243414 + 0.71130369474597 + 0.71130369743960 + 0.71130370057991 + 0.71130370424054 + 0.71130370850801 + 0.71130371348728 + 0.71130371931577 + 0.71130372621840 + 0.71130373455343 + 0.71130374475472 + 0.71130375729420 + 0.71130377272300 + 0.71130379171181 + 0.71130381508593 + 0.71130384385641 + 0.71130387931434 + 0.71130392310308 + 0.71130397720314 + 0.71130404406581 + 0.71130412673460 + 0.71130422898644 + 0.71130435557178 + 0.71130451281653 + 0.71130470984554 + 0.71130495874568 + 0.71130527402835 + 0.71130567355466 + 0.71130618130613 + 0.71130682738598 + 0.71130764988104 + 0.71130869738190 + 0.71131003186127 + 0.71131173232951 + 0.71131389946897 + 0.71131666153979 + 0.71132018650970 + 0.71132469520906 + 0.71133046666225 + 0.71133786020415 + 0.71134733599008 + 0.71135944384664 + 0.71137458501160 + 0.71139283316617 + 0.71141448500072 + 0.71143980484158 + 0.71146838881526 + 0.71150000118686 + 0.71153492389934 + 0.71157362303696 + 0.71161667531035 + 0.71166478030711 + 0.71171885877234 + 0.71178000270429 + 0.71184946435883 + 0.71192877819609 + 0.71201983863152 + 0.71212505535298 + 0.71224792721686 + 0.71239450865442 + 0.71257324213956 + 0.71279351217501 + 0.71306655996251 + 0.71340702453156 + 0.71383371851206 + 0.71437122577459 + 0.71505201017531 + 0.71591937395824 + 0.71703184499872 + 0.71847020612973 + 0.72035104479520 + 0.72285424930915 + 0.72625808071032 + 0.73099569513121 + 0.73780138196172 + 0.74237606624497 + 0.74808883289777 + 0.75539779960947 + 0.76507642471886 + 0.77857657186796 + 0.79910641638843 + 0.83624344485071 + 1.00000000000000 + 0.82855609996012 + 0.78300469233326 + 0.75444264095088 + 0.73271164208534 + 0.71437514626162 + 0.69796967223590 + 0.68271291421534 + 0.66818215504065 + 0.65412720791065 + 0.64039382017638 + 0.62688384620640 + 0.61353452349262 + 0.60030589837142 + 0.58714593158442 + 0.57404495485291 + 0.56100573982076 + 0.54804082728714 + 0.53516930010267 + 0.52241292768495 + 0.50977725622764 + 0.49725879463517 + 0.48485769490090 + 0.47256288801021 + 0.46035150420565 + 0.70341972712240 + 0.70341973837793 + 0.70341974024259 + 0.70341974241648 + 0.70341974494966 + 0.70341974790286 + 0.70341975134516 + 0.70341975535810 + 0.70341976004018 + 0.70341976552075 + 0.70341977201372 + 0.70341977985736 + 0.70341978946420 + 0.70341980128025 + 0.70341981582874 + 0.70341983374666 + 0.70341985581527 + 0.70341988299568 + 0.70341991651387 + 0.70341995793075 + 0.70342000912916 + 0.70342007244147 + 0.70342015075939 + 0.70342024767718 + 0.70342036771724 + 0.70342051690014 + 0.70342070392584 + 0.70342094031499 + 0.70342123990934 + 0.70342161973693 + 0.70342210268000 + 0.70342271745550 + 0.70342350040540 + 0.70342449789424 + 0.70342576905744 + 0.70342738928251 + 0.70342945463292 + 0.70343208746241 + 0.70343544799498 + 0.70343974686990 + 0.70344525012455 + 0.70345230026592 + 0.70346133570218 + 0.70347287979889 + 0.70348731243636 + 0.70350469855441 + 0.70352531487962 + 0.70354940503410 + 0.70357657145389 + 0.70360657525558 + 0.70363966899090 + 0.70367627632438 + 0.70371692026643 + 0.70376223296162 + 0.70381304665204 + 0.70387034290895 + 0.70393523839984 + 0.70400909549340 + 0.70409358907916 + 0.70419084425313 + 0.70430396397651 + 0.70443838496727 + 0.70460168431210 + 0.70480218745779 + 0.70504978258754 + 0.70535729318345 + 0.70574110798337 + 0.70622252823940 + 0.70682951647211 + 0.70759911367568 + 0.70858097367369 + 0.70984296402736 + 0.71148202774409 + 0.71364623548211 + 0.71656038871384 + 0.72056336061563 + 0.72620513799674 + 0.72992381656469 + 0.73448162718586 + 0.74016894370524 + 0.74744164493835 + 0.75707273697069 + 0.77052307716060 + 0.79105424618737 + 0.82855609996012 + 1.00000000000000 + 0.82075265406193 + 0.77479787859201 + 0.74578764385578 + 0.72356069779543 + 0.70478763670903 + 0.68795606851688 + 0.67230924268507 + 0.65742651161228 + 0.64305924611570 + 0.62905281663361 + 0.61530819444726 + 0.60176077967980 + 0.58834065556993 + 0.57502577647639 + 0.56180977948289 + 0.54869836657076 + 0.53570542015525 + 0.52284866846291 + 0.51013034504538 + 0.49754423344490 + 0.48508822071466 + 0.47274923074873 + 0.46050258736421 + 0.69556866256628 + 0.69556867315882 + 0.69556867491407 + 0.69556867695970 + 0.69556867934374 + 0.69556868212318 + 0.69556868536244 + 0.69556868913887 + 0.69556869354508 + 0.69556869870289 + 0.69556870481485 + 0.69556871220226 + 0.69556872125519 + 0.69556873239743 + 0.69556874612547 + 0.69556876304389 + 0.69556878389411 + 0.69556880958809 + 0.69556884129092 + 0.69556888048772 + 0.69556892896615 + 0.69556898894714 + 0.69556906318039 + 0.69556915508765 + 0.69556926897148 + 0.69556941056973 + 0.69556958817509 + 0.69556981277492 + 0.69557009756889 + 0.69557045880115 + 0.69557091830440 + 0.69557150348358 + 0.69557224902167 + 0.69557319917109 + 0.69557441036889 + 0.69557595456808 + 0.69557792343896 + 0.69558043373545 + 0.69558363833251 + 0.69558773819130 + 0.69559298704083 + 0.69559971143708 + 0.69560832919124 + 0.69561933864473 + 0.69563309967884 + 0.69564966946948 + 0.69566930642883 + 0.69569223540427 + 0.69571806619523 + 0.69574655856136 + 0.69577793909648 + 0.69581259373061 + 0.69585099785650 + 0.69589372406055 + 0.69594152653465 + 0.69599528997833 + 0.69605601292137 + 0.69612490847333 + 0.69620346196256 + 0.69629355359265 + 0.69639794488679 + 0.69652153458458 + 0.69667114597858 + 0.69685419121330 + 0.69707940038208 + 0.69735805004898 + 0.69770447594770 + 0.69813721671383 + 0.69868047481363 + 0.69936610828804 + 0.70023650653376 + 0.70134910744459 + 0.70278523584969 + 0.70466809920621 + 0.70718180047002 + 0.71059619200425 + 0.71533315893542 + 0.71840644950650 + 0.72211845743333 + 0.72666297656216 + 0.73232740762545 + 0.73956375652382 + 0.74914116111210 + 0.76252210195845 + 0.78300469233326 + 0.82075265406193 + 1.00000000000000 + 0.81259818820305 + 0.76582138253058 + 0.73631026971224 + 0.71370690216601 + 0.69456030368409 + 0.67737746025229 + 0.66140654924114 + 0.64623269433876 + 0.63160943833100 + 0.61738247946282 + 0.60345151990464 + 0.58972186246201 + 0.57615474232173 + 0.56273176958701 + 0.54944983142504 + 0.53631622819594 + 0.52334365577901 + 0.51053029044957 + 0.49786662201498 + 0.48534782943847 + 0.47295846220216 + 0.46067172525988 + 0.68767289884629 + 0.68767290881804 + 0.68767291047019 + 0.68767291239580 + 0.68767291464018 + 0.68767291725617 + 0.68767292030549 + 0.68767292386138 + 0.68767292800852 + 0.68767293286475 + 0.68767293861968 + 0.68767294557869 + 0.68767295411153 + 0.68767296462134 + 0.68767297757690 + 0.68767299355364 + 0.68767301325332 + 0.68767303754457 + 0.68767306753170 + 0.68767310462712 + 0.68767315053098 + 0.68767320735344 + 0.68767327771200 + 0.68767336486022 + 0.68767347289452 + 0.68767360727909 + 0.68767377591322 + 0.68767398927533 + 0.68767425995028 + 0.68767460342550 + 0.68767504052815 + 0.68767559739756 + 0.68767630712451 + 0.68767721192668 + 0.68767836565109 + 0.68767983694263 + 0.68768171325286 + 0.68768410594492 + 0.68768716083267 + 0.68769106957718 + 0.68769607408239 + 0.68770248558650 + 0.68771070214321 + 0.68772119811651 + 0.68773431441710 + 0.68775010126169 + 0.68776880005155 + 0.68779061841167 + 0.68781517449958 + 0.68784222829385 + 0.68787198322793 + 0.68790479128388 + 0.68794108514952 + 0.68798138422911 + 0.68802637310171 + 0.68807685055639 + 0.68813371110114 + 0.68819803704688 + 0.68827114838344 + 0.68835471245094 + 0.68845119319262 + 0.68856501537083 + 0.68870233805610 + 0.68886977710697 + 0.68907506077740 + 0.68932813351483 + 0.68964157353908 + 0.69003156919270 + 0.69051914697732 + 0.69113182467522 + 0.69190597191891 + 0.69289049306209 + 0.69415411474056 + 0.69580029083917 + 0.69798154288457 + 0.70091605920369 + 0.70493421316070 + 0.70750784303334 + 0.71058045238111 + 0.71428705438092 + 0.71881882822383 + 0.72445917249621 + 0.73165405166884 + 0.74116405471086 + 0.75444264095088 + 0.77479787859201 + 0.81259818820305 + 1.00000000000000 + 0.80340629959267 + 0.75591715007565 + 0.72611724584277 + 0.70322906795287 + 0.68379274145511 + 0.66632499087040 + 0.65008911426756 + 0.63467828696757 + 0.61984919465966 + 0.60544753079424 + 0.59134298933625 + 0.57747352713418 + 0.56380449716470 + 0.55032115742023 + 0.53702230151777 + 0.52391423827289 + 0.51099008662242 + 0.49823629028948 + 0.48564474073243 + 0.47319713813899 + 0.46086416838057 + 0.67950557940440 + 0.67950558877854 + 0.67950559033133 + 0.67950559214143 + 0.67950559425115 + 0.67950559671021 + 0.67950559957710 + 0.67950560291909 + 0.67950560681856 + 0.67950561138387 + 0.67950561679447 + 0.67950562334018 + 0.67950563137113 + 0.67950564126830 + 0.67950565347673 + 0.67950566853931 + 0.67950568712293 + 0.67950571004984 + 0.67950573836726 + 0.67950577341474 + 0.67950581680656 + 0.67950587054333 + 0.67950593711046 + 0.67950601959870 + 0.67950612189898 + 0.67950624920270 + 0.67950640902493 + 0.67950661133398 + 0.67950686810248 + 0.67950719407013 + 0.67950760905884 + 0.67950813795960 + 0.67950881226814 + 0.67950967218302 + 0.67951076897110 + 0.67951216798481 + 0.67951395247848 + 0.67951622845405 + 0.67951913469664 + 0.67952285361235 + 0.67952761534666 + 0.67953371591284 + 0.67954153373525 + 0.67955151939525 + 0.67956399516648 + 0.67957900484152 + 0.67959677347277 + 0.67961749235068 + 0.67964078923736 + 0.67966642583188 + 0.67969458428401 + 0.67972558507237 + 0.67975982140062 + 0.67979776372466 + 0.67984003263655 + 0.67988734843683 + 0.67994051138603 + 0.68000048591268 + 0.68006844377022 + 0.68014586216901 + 0.68023493830423 + 0.68033966667583 + 0.68046560323874 + 0.68061864936856 + 0.68080564217661 + 0.68103534682277 + 0.68131879523833 + 0.68167012101034 + 0.68210759385754 + 0.68265499584769 + 0.68334356765056 + 0.68421503021317 + 0.68532764315260 + 0.68676866446876 + 0.68866527359738 + 0.69119558276186 + 0.69462198654982 + 0.69679339245606 + 0.69936160855899 + 0.70242381274687 + 0.70611246170039 + 0.71061470103587 + 0.71620739688010 + 0.72332565736094 + 0.73271164208534 + 0.74578764385578 + 0.76582138253058 + 0.80340629959267 + 1.00000000000000 + 0.79357216874043 + 0.74559825466745 + 0.71556044256153 + 0.69242699978110 + 0.67272576133502 + 0.65499899045805 + 0.63852664711624 + 0.62290878701353 + 0.60790322952470 + 0.59332519894446 + 0.57907840832381 + 0.56510510762463 + 0.55137448353900 + 0.53787384414641 + 0.52460104722946 + 0.51154264977450 + 0.49867992863609 + 0.48600063190062 + 0.47348291338627 + 0.46109435521607 + 0.67095090402380 + 0.67095091281409 + 0.67095091427029 + 0.67095091596767 + 0.67095091794635 + 0.67095092025213 + 0.67095092294036 + 0.67095092607380 + 0.67095092973010 + 0.67095093401125 + 0.67095093908598 + 0.67095094522874 + 0.67095095276814 + 0.67095096206447 + 0.67095097353894 + 0.67095098770324 + 0.67095100518821 + 0.67095102676876 + 0.67095105343692 + 0.67095108646065 + 0.67095112736370 + 0.67095117804279 + 0.67095124084852 + 0.67095131870672 + 0.67095141530499 + 0.67095153556018 + 0.67095168659660 + 0.67095187787120 + 0.67095212074299 + 0.67095242919178 + 0.67095282203077 + 0.67095332287996 + 0.67095396163680 + 0.67095477645217 + 0.67095581598818 + 0.67095714227332 + 0.67095883431966 + 0.67096099271005 + 0.67096374913351 + 0.67096727664528 + 0.67097179352197 + 0.67097758041156 + 0.67098499593484 + 0.67099446673807 + 0.67100629649750 + 0.67102052301284 + 0.67103735538709 + 0.67105696920455 + 0.67107900316756 + 0.67110322217114 + 0.67112978855408 + 0.67115899315479 + 0.67119119215216 + 0.67122681032852 + 0.67126640861495 + 0.67131063461808 + 0.67136020205703 + 0.67141596769753 + 0.67147896861925 + 0.67155050995743 + 0.67163254644366 + 0.67172867621897 + 0.67184389956386 + 0.67198346777324 + 0.67215341442544 + 0.67236144639356 + 0.67261721651622 + 0.67293303709513 + 0.67332475101135 + 0.67381287789617 + 0.67442422141085 + 0.67519435690936 + 0.67617269331149 + 0.67743294789723 + 0.67908151621489 + 0.68126464959754 + 0.68419278897535 + 0.68603193674773 + 0.68819052898800 + 0.69074032493058 + 0.69377611466874 + 0.69742668896026 + 0.70187336524594 + 0.70738337088869 + 0.71437514626162 + 0.72356069779543 + 0.73631026971224 + 0.75591715007565 + 0.79357216874043 + 1.00000000000000 + 0.78350441146888 + 0.73509111963440 + 0.70483234737707 + 0.68144530418303 + 0.66147724986494 + 0.64349994349644 + 0.62680655665163 + 0.61099980486519 + 0.59580603286149 + 0.58107582625017 + 0.56671707740585 + 0.55267586244895 + 0.53892342330946 + 0.52544607272643 + 0.51222160218637 + 0.49922451183485 + 0.48643719717958 + 0.47383329579480 + 0.46137648290222 + 0.66200007694885 + 0.66200008516877 + 0.66200008653058 + 0.66200008811789 + 0.66200008996778 + 0.66200009212448 + 0.66200009463788 + 0.66200009756824 + 0.66200010098718 + 0.66200010499013 + 0.66200010973736 + 0.66200011548401 + 0.66200012254197 + 0.66200013124934 + 0.66200014200181 + 0.66200015528247 + 0.66200017168416 + 0.66200019193774 + 0.66200021697771 + 0.66200024799789 + 0.66200028643727 + 0.66200033408450 + 0.66200039315692 + 0.66200046641772 + 0.66200055734365 + 0.66200067058111 + 0.66200081286378 + 0.66200099312951 + 0.66200122211818 + 0.66200151304816 + 0.66200188371324 + 0.66200235645623 + 0.66200295955483 + 0.66200372910398 + 0.66200471113297 + 0.66200596431762 + 0.66200756339119 + 0.66200960347284 + 0.66201220909463 + 0.66201554388664 + 0.66201981415798 + 0.66202528508447 + 0.66203229535913 + 0.66204124756315 + 0.66205242686504 + 0.66206586549859 + 0.66208175704005 + 0.66210026199775 + 0.66212103127735 + 0.66214383434994 + 0.66216881516364 + 0.66219623669499 + 0.66222642044458 + 0.66225974859891 + 0.66229672650459 + 0.66233793446211 + 0.66238400676789 + 0.66243570189603 + 0.66249393460295 + 0.66255985426031 + 0.66263519510222 + 0.66272318988229 + 0.66282832674731 + 0.66295526535280 + 0.66310931453354 + 0.66329723107747 + 0.66352743706041 + 0.66381062888048 + 0.66416050996210 + 0.66459474485400 + 0.66513628741309 + 0.66581543347591 + 0.66667406560933 + 0.66777449506204 + 0.66920590188408 + 0.67108887102604 + 0.67359343160187 + 0.67515462235157 + 0.67697531782434 + 0.67910963651287 + 0.68162726078951 + 0.68461992476577 + 0.68821176232279 + 0.69257670057822 + 0.69796967223590 + 0.70478763670903 + 0.71370690216601 + 0.72611724584277 + 0.74559825466745 + 0.78350441146888 + 1.00000000000000 + 0.77318590767653 + 0.72443526912551 + 0.69395462957056 + 0.67030201178486 + 0.65006747454149 + 0.63185046368842 + 0.61495123280454 + 0.59894020734041 + 0.58358088721349 + 0.56872779685848 + 0.55429258312152 + 0.54022334752485 + 0.52649024068809 + 0.51305910395373 + 0.49989539626444 + 0.48697449828116 + 0.47426422728106 + 0.46172329197378 + 0.65264720192452 + 0.65264720958665 + 0.65264721085585 + 0.65264721233533 + 0.65264721405948 + 0.65264721606988 + 0.65264721841267 + 0.65264722114419 + 0.65264722433068 + 0.65264722806248 + 0.65264723248810 + 0.65264723784777 + 0.65264724443327 + 0.65264725256177 + 0.65264726260546 + 0.65264727501582 + 0.65264729035037 + 0.65264730929428 + 0.65264733272478 + 0.65264736176531 + 0.65264739776736 + 0.65264744240999 + 0.65264749778116 + 0.65264756647504 + 0.65264765176651 + 0.65264775802444 + 0.65264789159019 + 0.65264806088336 + 0.65264827602157 + 0.65264854945598 + 0.65264889795566 + 0.65264934257865 + 0.65264990997809 + 0.65265063416861 + 0.65265155854186 + 0.65265273839267 + 0.65265424415201 + 0.65265616544508 + 0.65265861960372 + 0.65266176077635 + 0.65266578325318 + 0.65267093666160 + 0.65267753969227 + 0.65268597081238 + 0.65269649681415 + 0.65270914478926 + 0.65272409323278 + 0.65274148822317 + 0.65276099403264 + 0.65278238599475 + 0.65280579102377 + 0.65283144596191 + 0.65285963986834 + 0.65289071528007 + 0.65292512580574 + 0.65296338951353 + 0.65300606790256 + 0.65305382981875 + 0.65310747902890 + 0.65316802403154 + 0.65323699859012 + 0.65331729872113 + 0.65341294080201 + 0.65352804638391 + 0.65366727111161 + 0.65383651931916 + 0.65404311519252 + 0.65429632166533 + 0.65460795559069 + 0.65499318086861 + 0.65547160564489 + 0.65606897806934 + 0.65682075439447 + 0.65777958234106 + 0.65902026718985 + 0.66064248440878 + 0.66278433602830 + 0.66411069075055 + 0.66564919148551 + 0.66744133560305 + 0.66953945433802 + 0.67201071308931 + 0.67494318927646 + 0.67845550567988 + 0.68271291421534 + 0.68795606851688 + 0.69456030368409 + 0.70322906795287 + 0.71556044256153 + 0.73509111963440 + 0.77318590767653 + 1.00000000000000 + 0.76271811642410 + 0.71368079908876 + 0.68295611509124 + 0.65902231603742 + 0.63852255016074 + 0.62007541270915 + 0.60294918599894 + 0.58675393148513 + 0.57125655288868 + 0.55631509130690 + 0.54184309629513 + 0.52778740646232 + 0.51409716075928 + 0.50072550152047 + 0.48763845283423 + 0.47479622046725 + 0.46215112235837 + 0.64291000817494 + 0.64291001529159 + 0.64291001647089 + 0.64291001784500 + 0.64291001944662 + 0.64291002131346 + 0.64291002349024 + 0.64291002602739 + 0.64291002898732 + 0.64291003245388 + 0.64291003656495 + 0.64291004154620 + 0.64291004766962 + 0.64291005523176 + 0.64291006457867 + 0.64291007613480 + 0.64291009041938 + 0.64291010807451 + 0.64291012992171 + 0.64291015700907 + 0.64291019060458 + 0.64291023228093 + 0.64291028399101 + 0.64291034816818 + 0.64291042787883 + 0.64291052722049 + 0.64291065214223 + 0.64291081054203 + 0.64291101191709 + 0.64291126795187 + 0.64291159439226 + 0.64291201100653 + 0.64291254282114 + 0.64291322177885 + 0.64291408861734 + 0.64291519525875 + 0.64291660782253 + 0.64291841044416 + 0.64292071324711 + 0.64292366090367 + 0.64292743568658 + 0.64293227169762 + 0.64293846766699 + 0.64294637803076 + 0.64295625143497 + 0.64296811026101 + 0.64298211843087 + 0.64299840828620 + 0.64301665847639 + 0.64303665134590 + 0.64305849812909 + 0.64308241124881 + 0.64310864955958 + 0.64313751883297 + 0.64316942471775 + 0.64320482795985 + 0.64324422360687 + 0.64328819910148 + 0.64333745789232 + 0.64339288152659 + 0.64345582209721 + 0.64352886623065 + 0.64361559715920 + 0.64371964874712 + 0.64384509002768 + 0.64399706318061 + 0.64418191633636 + 0.64440764483957 + 0.64468440665572 + 0.64502518058606 + 0.64544667195769 + 0.64597071443534 + 0.64662727440527 + 0.64746079592754 + 0.64853403333372 + 0.64992951006540 + 0.65175982811478 + 0.65288674911837 + 0.65418787538946 + 0.65569544554899 + 0.65744942972507 + 0.65950008905240 + 0.66191170945116 + 0.66476823846921 + 0.66818215504065 + 0.67230924268507 + 0.67737746025229 + 0.68379274145511 + 0.69242699978110 + 0.70483234737707 + 0.72443526912551 + 0.76271811642410 + 1.00000000000000 + 0.75212564700625 + 0.70283456065656 + 0.67183972516242 + 0.64761469005982 + 0.62685368608892 + 0.60814959064111 + 0.59081474846401 + 0.57446175820831 + 0.55886059635228 + 0.54387098348730 + 0.52940495823822 + 0.51538765123713 + 0.50175503501490 + 0.48846041348256 + 0.47545388274678 + 0.46267943350738 + 0.63281181795368 + 0.63281182453959 + 0.63281182563068 + 0.63281182690229 + 0.63281182838490 + 0.63281183011263 + 0.63281183212646 + 0.63281183447419 + 0.63281183721369 + 0.63281184042145 + 0.63281184422678 + 0.63281184883840 + 0.63281185451056 + 0.63281186151830 + 0.63281187018546 + 0.63281188090485 + 0.63281189416135 + 0.63281191055307 + 0.63281193084419 + 0.63281195601465 + 0.63281198724542 + 0.63281202600184 + 0.63281207410843 + 0.63281213383500 + 0.63281220804271 + 0.63281230056120 + 0.63281241694549 + 0.63281256458166 + 0.63281275234581 + 0.63281299116272 + 0.63281329575645 + 0.63281368461647 + 0.63281418115037 + 0.63281481523389 + 0.63281562497254 + 0.63281665892821 + 0.63281797893488 + 0.63281966366332 + 0.63282181607776 + 0.63282457143153 + 0.63282810005796 + 0.63283262065053 + 0.63283841213914 + 0.63284580516675 + 0.63285503056127 + 0.63286610642699 + 0.63287918268259 + 0.63289437866460 + 0.63291138823200 + 0.63293000174927 + 0.63295031609370 + 0.63297252098559 + 0.63299684727884 + 0.63302356681344 + 0.63305304096903 + 0.63308567792341 + 0.63312191233282 + 0.63316225803708 + 0.63320732819726 + 0.63325789044023 + 0.63331513282207 + 0.63338135871081 + 0.63345975515160 + 0.63355351575233 + 0.63366618490039 + 0.63380222609715 + 0.63396712319062 + 0.63416775488603 + 0.63441282564082 + 0.63471341088461 + 0.63508370390198 + 0.63554217495965 + 0.63611410406683 + 0.63683696709267 + 0.63776339273202 + 0.63896176794703 + 0.64052416063640 + 0.64148120958548 + 0.64258175501173 + 0.64385110188147 + 0.64532018783360 + 0.64702727359602 + 0.64902032657686 + 0.65136047800893 + 0.65412720791065 + 0.65742651161228 + 0.66140654924114 + 0.66632499087040 + 0.67272576133502 + 0.68144530418303 + 0.69395462957056 + 0.71368079908876 + 0.75212564700625 + 1.00000000000000 + 0.74143241163043 + 0.69190170421871 + 0.66061044435793 + 0.63608748093676 + 0.61502968748136 + 0.59608473424341 + 0.57856635843616 + 0.56208943727204 + 0.54642523085734 + 0.53143158465900 + 0.51699792159023 + 0.50303560325843 + 0.48948023983600 + 0.47626824671713 + 0.46333259881727 + 0.62238010509073 + 0.62238011116116 + 0.62238011216678 + 0.62238011333914 + 0.62238011470499 + 0.62238011629754 + 0.62238011815374 + 0.62238012031803 + 0.62238012284279 + 0.62238012579968 + 0.62238012930729 + 0.62238013356011 + 0.62238013879369 + 0.62238014526237 + 0.62238015326602 + 0.62238016316983 + 0.62238017542325 + 0.62238019058103 + 0.62238020935251 + 0.62238023264737 + 0.62238026156247 + 0.62238029746079 + 0.62238034203622 + 0.62238039739871 + 0.62238046620958 + 0.62238055202839 + 0.62238066002764 + 0.62238079708352 + 0.62238097145889 + 0.62238119332897 + 0.62238147640836 + 0.62238183791893 + 0.62238229967257 + 0.62238288949905 + 0.62238364290005 + 0.62238460511368 + 0.62238583374519 + 0.62238740206382 + 0.62238940596247 + 0.62239197138788 + 0.62239525689731 + 0.62239946598432 + 0.62240485807069 + 0.62241174038559 + 0.62242032637128 + 0.62243063028626 + 0.62244278866425 + 0.62245690860316 + 0.62247269981283 + 0.62248996152766 + 0.62250877755486 + 0.62252931661342 + 0.62255178371797 + 0.62257641954184 + 0.62260354477759 + 0.62263351961032 + 0.62266672406703 + 0.62270360572971 + 0.62274469687409 + 0.62279066333396 + 0.62284254561855 + 0.62290238870587 + 0.62297301863654 + 0.62305723318872 + 0.62315810948214 + 0.62327950918139 + 0.62342615396770 + 0.62360394279587 + 0.62382031133908 + 0.62408468275625 + 0.62440908287054 + 0.62480909870876 + 0.62530601534883 + 0.62593139145679 + 0.62672933777940 + 0.62775655222166 + 0.62908846538061 + 0.62990059560640 + 0.63083117934132 + 0.63190024231211 + 0.63313198518885 + 0.63455593062952 + 0.63620849500201 + 0.63813519343210 + 0.64039382017638 + 0.64305924611570 + 0.64623269433876 + 0.65008911426756 + 0.65499899045805 + 0.66147724986494 + 0.67030201178486 + 0.68295611509124 + 0.70283456065656 + 0.74143241163043 + 1.00000000000000 + 0.73066099732665 + 0.68088652387282 + 0.64927239007564 + 0.62440081099410 + 0.60305903560749 + 0.58389630551400 + 0.56622735745160 + 0.54966766769731 + 0.53398608127680 + 0.51901663068607 + 0.50463418435697 + 0.49074905025904 + 0.47727870947182 + 0.46414129640327 + 0.61164553639810 + 0.61164554197023 + 0.61164554289335 + 0.61164554396930 + 0.61164554522320 + 0.61164554668515 + 0.61164554838827 + 0.61164555037457 + 0.61164555269202 + 0.61164555540635 + 0.61164555862668 + 0.61164556253232 + 0.61164556734076 + 0.61164557328709 + 0.61164558064758 + 0.61164558975961 + 0.61164560103897 + 0.61164561499714 + 0.61164563229115 + 0.61164565376286 + 0.61164568042443 + 0.61164571353729 + 0.61164575467101 + 0.61164580577767 + 0.61164586932215 + 0.61164594860141 + 0.61164604841024 + 0.61164617512488 + 0.61164633640728 + 0.61164654169517 + 0.61164680371086 + 0.61164713843839 + 0.61164756610857 + 0.61164811255230 + 0.61164881071001 + 0.61164970256090 + 0.61165084154932 + 0.61165229564737 + 0.61165415381097 + 0.61165653285506 + 0.61165957979173 + 0.61166348322536 + 0.61166848347649 + 0.61167486489779 + 0.61168282406580 + 0.61169237181268 + 0.61170363195511 + 0.61171670013405 + 0.61173130236952 + 0.61174724743095 + 0.61176460730405 + 0.61178353136730 + 0.61180420091448 + 0.61182682811372 + 0.61185169643177 + 0.61187912242470 + 0.61190943692839 + 0.61194302814854 + 0.61198035620988 + 0.61202199637190 + 0.61206885691968 + 0.61212274796406 + 0.61218616782010 + 0.61226155974425 + 0.61235158635038 + 0.61245957771165 + 0.61258958601821 + 0.61274665383017 + 0.61293711326152 + 0.61316895790205 + 0.61345234883975 + 0.61380040718534 + 0.61423101771042 + 0.61477071704917 + 0.61545644542591 + 0.61633521157605 + 0.61746889962986 + 0.61815729552607 + 0.61894360439280 + 0.61984377740897 + 0.62087690553359 + 0.62206601628800 + 0.62343913915960 + 0.62503075909579 + 0.62688384620640 + 0.62905281663361 + 0.63160943833100 + 0.63467828696757 + 0.63852664711624 + 0.64349994349644 + 0.65006747454149 + 0.65902231603742 + 0.67183972516242 + 0.69190170421871 + 0.73066099732665 + 1.00000000000000 + 0.71983194694698 + 0.66978898970338 + 0.63777172022174 + 0.61255889837415 + 0.59095339103777 + 0.57160443419610 + 0.55382627126092 + 0.53723117319859 + 0.52156257992765 + 0.50663893686983 + 0.49233313115107 + 0.47853571555757 + 0.46514438612193 + 0.60064154419697 + 0.60064154928918 + 0.60064155013261 + 0.60064155111586 + 0.60064155226215 + 0.60064155359778 + 0.60064155515477 + 0.60064155697044 + 0.60064155908829 + 0.60064156156884 + 0.60064156451217 + 0.60064156808408 + 0.60064157248259 + 0.60064157792485 + 0.60064158466530 + 0.60064159301374 + 0.60064160335173 + 0.60064161615168 + 0.60064163201668 + 0.60064165172216 + 0.60064167620247 + 0.60064170661936 + 0.60064174441820 + 0.60064179139845 + 0.60064184983367 + 0.60064192276700 + 0.60064201462379 + 0.60064213129234 + 0.60064227984859 + 0.60064246901260 + 0.60064271053767 + 0.60064301919361 + 0.60064341368186 + 0.60064391787218 + 0.60064456221018 + 0.60064538549336 + 0.60064643711281 + 0.60064777987562 + 0.60064949597271 + 0.60065169332559 + 0.60065450770188 + 0.60065811321974 + 0.60066273162824 + 0.60066862506945 + 0.60067597387111 + 0.60068478584173 + 0.60069517278613 + 0.60070721968363 + 0.60072066911179 + 0.60073533988078 + 0.60075129334224 + 0.60076866115487 + 0.60078760292510 + 0.60080830487651 + 0.60083101656644 + 0.60085601505902 + 0.60088358708486 + 0.60091406786984 + 0.60094785344633 + 0.60098543880128 + 0.60102761414877 + 0.60107597683861 + 0.60113272871806 + 0.60119999665471 + 0.60128007691312 + 0.60137583170885 + 0.60149072723077 + 0.60162906002510 + 0.60179620544891 + 0.60199892384758 + 0.60224577614944 + 0.60254777880733 + 0.60291992631031 + 0.60338449505479 + 0.60397238540845 + 0.60472255748478 + 0.60568581846592 + 0.60626851185176 + 0.60693219084663 + 0.60768962514544 + 0.60855597475252 + 0.60954935493679 + 0.61069157597708 + 0.61200912862909 + 0.61353452349262 + 0.61530819444726 + 0.61738247946282 + 0.61984919465966 + 0.62290878701353 + 0.62680655665163 + 0.63185046368842 + 0.63852255016074 + 0.64761469005982 + 0.66061044435793 + 0.68088652387282 + 0.71983194694698 + 1.00000000000000 + 0.70895558617711 + 0.65853033543259 + 0.62610644303130 + 0.60056849257858 + 0.57872860158358 + 0.55923452966076 + 0.54139627219248 + 0.52479859293398 + 0.50916798851561 + 0.49431965864183 + 0.48010456741217 + 0.46639150160075 + 0.58940281314246 + 0.58940281777587 + 0.58940281854329 + 0.58940281943787 + 0.58940282048090 + 0.58940282169627 + 0.58940282311312 + 0.58940282476450 + 0.58940282669204 + 0.58940282894901 + 0.58940283162772 + 0.58940283487935 + 0.58940283888536 + 0.58940284384490 + 0.58940284998990 + 0.58940285760527 + 0.58940286704013 + 0.58940287872629 + 0.58940289321858 + 0.58940291122649 + 0.58940293360720 + 0.58940296142735 + 0.58940299601404 + 0.58940303901932 + 0.58940309253072 + 0.58940315934269 + 0.58940324352659 + 0.58940335049635 + 0.58940348676342 + 0.58940366034624 + 0.58940388206428 + 0.58940416551210 + 0.58940452790056 + 0.58940499120475 + 0.58940558345393 + 0.58940634035978 + 0.58940730738932 + 0.58940854234827 + 0.58941012087841 + 0.58941214229702 + 0.58941473149564 + 0.58941804859158 + 0.58942229740521 + 0.58942771865929 + 0.58943447713035 + 0.58944257798394 + 0.58945212174092 + 0.58946318352206 + 0.58947552251504 + 0.58948896789958 + 0.58950357151952 + 0.58951944886950 + 0.58953673982746 + 0.58955560710771 + 0.58957626949942 + 0.58959896847381 + 0.58962395138175 + 0.58965150636537 + 0.58968197274800 + 0.58971577463375 + 0.58975359714225 + 0.58979684551598 + 0.58984745428336 + 0.58990726887746 + 0.58997826283320 + 0.59006288790441 + 0.59016409892902 + 0.59028554449626 + 0.59043177273753 + 0.59060848272978 + 0.59082286515531 + 0.59108414305103 + 0.59140485655546 + 0.59180366883883 + 0.59230638903019 + 0.59294527727463 + 0.59376204692356 + 0.59425439766561 + 0.59481372608921 + 0.59545029180527 + 0.59617619243481 + 0.59700577139708 + 0.59795614234121 + 0.59904787375514 + 0.60030589837142 + 0.60176077967980 + 0.60345151990464 + 0.60544753079424 + 0.60790322952470 + 0.61099980486519 + 0.61495123280454 + 0.62007541270915 + 0.62685368608892 + 0.63608748093676 + 0.64927239007564 + 0.66978898970338 + 0.70895558617711 + 1.00000000000000 + 0.69791103443902 + 0.64710147433579 + 0.61427876690168 + 0.58844130582681 + 0.56640679491626 + 0.54681810863748 + 0.52895509736065 + 0.51238383328469 + 0.49682581489843 + 0.48207136567687 + 0.46794702118493 + 0.57793959431361 + 0.57793959850947 + 0.57793959920441 + 0.57793960001448 + 0.57793960095898 + 0.57793960205949 + 0.57793960334253 + 0.57793960483834 + 0.57793960658330 + 0.57793960862737 + 0.57793961105367 + 0.57793961399995 + 0.57793961763159 + 0.57793962212993 + 0.57793962770697 + 0.57793963462093 + 0.57793964319109 + 0.57793965381213 + 0.57793966698961 + 0.57793968337097 + 0.57793970374026 + 0.57793972907168 + 0.57793976057665 + 0.57793979976649 + 0.57793984855018 + 0.57793990948435 + 0.57793998629484 + 0.57794008394105 + 0.57794020838780 + 0.57794036698014 + 0.57794056963463 + 0.57794082880860 + 0.57794116028208 + 0.57794158419679 + 0.57794212625085 + 0.57794281918429 + 0.57794370467584 + 0.57794483571275 + 0.57794628162702 + 0.57794813344371 + 0.57795050558872 + 0.57795354470962 + 0.57795743739072 + 0.57796240380114 + 0.57796859388877 + 0.57797601053113 + 0.57798474369019 + 0.57799485939859 + 0.57800613336601 + 0.57801840533326 + 0.57803171867099 + 0.57804617417476 + 0.57806189381311 + 0.57807901904946 + 0.57809774081771 + 0.57811826857242 + 0.57814081457817 + 0.57816562521160 + 0.57819298971031 + 0.57822326968326 + 0.57825705681129 + 0.57829558305379 + 0.57834054218295 + 0.57839352954141 + 0.57845623464287 + 0.57853074945929 + 0.57861958298894 + 0.57872582139566 + 0.57885329790952 + 0.57900679853236 + 0.57919234044746 + 0.57941761767240 + 0.57969308385226 + 0.58003433215509 + 0.58046286876590 + 0.58100535506463 + 0.58169599762364 + 0.58211095699463 + 0.58258123848966 + 0.58311509933645 + 0.58372222034803 + 0.58441400456660 + 0.58520395546437 + 0.58610816215037 + 0.58714593158442 + 0.58834065556993 + 0.58972186246201 + 0.59134298933625 + 0.59332519894446 + 0.59580603286149 + 0.59894020734041 + 0.60294918599894 + 0.60814959064111 + 0.61502968748136 + 0.62440081099410 + 0.63777172022174 + 0.65853033543259 + 0.69791103443902 + 1.00000000000000 + 0.68679838615652 + 0.63555443628906 + 0.60233202337519 + 0.57622113308327 + 0.55403628519078 + 0.53438599376214 + 0.51652858200425 + 0.50002226837753 + 0.48455931066445 + 0.46990178121070 + 0.56628796022434 + 0.56628796400576 + 0.56628796463223 + 0.56628796536238 + 0.56628796621340 + 0.56628796720547 + 0.56628796836166 + 0.56628796970966 + 0.56628797128229 + 0.56628797312439 + 0.56628797531169 + 0.56628797796821 + 0.56628798124516 + 0.56628798530593 + 0.56628799034294 + 0.56628799659111 + 0.56628800434030 + 0.56628801394879 + 0.56628802587498 + 0.56628804070903 + 0.56628805916260 + 0.56628808212265 + 0.56628811069092 + 0.56628814624438 + 0.56628819051935 + 0.56628824584601 + 0.56628831561937 + 0.56628840436528 + 0.56628851752013 + 0.56628866178927 + 0.56628884621873 + 0.56628908218304 + 0.56628938408516 + 0.56628977031630 + 0.56629026433819 + 0.56629089604620 + 0.56629170349375 + 0.56629273505568 + 0.56629405402742 + 0.56629574350594 + 0.56629790791260 + 0.56630068102876 + 0.56630423299477 + 0.56630876438852 + 0.56631441112450 + 0.56632117412122 + 0.56632913352718 + 0.56633834704612 + 0.56634860664190 + 0.56635976265740 + 0.56637185096344 + 0.56638495905463 + 0.56639919273004 + 0.56641467433261 + 0.56643156970883 + 0.56645005963998 + 0.56647032527410 + 0.56649257610877 + 0.56651705732588 + 0.56654407566140 + 0.56657414000595 + 0.56660832659688 + 0.56664811316634 + 0.56669487358872 + 0.56675004827200 + 0.56681541485171 + 0.56689309478767 + 0.56698568748686 + 0.56709640999973 + 0.56722926464191 + 0.56738926569290 + 0.56758280573433 + 0.56781856668019 + 0.56810953470760 + 0.56847357861166 + 0.56893267517819 + 0.56951481706575 + 0.56986350008614 + 0.57025778189912 + 0.57070430995546 + 0.57121083974751 + 0.57178645606304 + 0.57244184949047 + 0.57318966596802 + 0.57404495485291 + 0.57502577647639 + 0.57615474232173 + 0.57747352713418 + 0.57907840832381 + 0.58107582625017 + 0.58358088721349 + 0.58675393148513 + 0.59081474846401 + 0.59608473424341 + 0.60305903560749 + 0.61255889837415 + 0.62610644303130 + 0.64710147433579 + 0.68679838615652 + 1.00000000000000 + 0.67562018262252 + 0.62389437629539 + 0.59028108274930 + 0.56393428893897 + 0.54163034820185 + 0.52195221804787 + 0.50414585732882 + 0.48773371469149 + 0.47237423511631 + 0.55448726714102 + 0.55448727053232 + 0.55448727109415 + 0.55448727174903 + 0.55448727251206 + 0.55448727340179 + 0.55448727443866 + 0.55448727564745 + 0.55448727705796 + 0.55448727871035 + 0.55448728067276 + 0.55448728305696 + 0.55448728599934 + 0.55448728964776 + 0.55448729417640 + 0.55448729979639 + 0.55448730677080 + 0.55448731542302 + 0.55448732616823 + 0.55448733954006 + 0.55448735618304 + 0.55448737690092 + 0.55448740269160 + 0.55448743480277 + 0.55448747480936 + 0.55448752482352 + 0.55448758793116 + 0.55448766823955 + 0.55448777068931 + 0.55448790137015 + 0.55448806850740 + 0.55448828244241 + 0.55448855626974 + 0.55448890671520 + 0.55448935511686 + 0.55448992866537 + 0.55449066196974 + 0.55449159902537 + 0.55449279739715 + 0.55449433265259 + 0.55449629972843 + 0.55449882020918 + 0.55450204866138 + 0.55450616713554 + 0.55451129835880 + 0.55451744160010 + 0.55452466794222 + 0.55453302751773 + 0.55454232811691 + 0.55455243058218 + 0.55456336419047 + 0.55457520447366 + 0.55458804272357 + 0.55460198418358 + 0.55461717221777 + 0.55463376207666 + 0.55465190745505 + 0.55467178545482 + 0.55469360270551 + 0.55471761797470 + 0.55474426712048 + 0.55477448704396 + 0.55480956245183 + 0.55485067191243 + 0.55489903821972 + 0.55495616541744 + 0.55502383934713 + 0.55510423959279 + 0.55520005383181 + 0.55531461374515 + 0.55545207876999 + 0.55561773627960 + 0.55581876642554 + 0.55606594439426 + 0.55637406607739 + 0.55676118708018 + 0.55725014761692 + 0.55754214064110 + 0.55787160968450 + 0.55824390017104 + 0.55866522222829 + 0.55914281599310 + 0.55968515585183 + 0.56030220540499 + 0.56100573982076 + 0.56180977948289 + 0.56273176958701 + 0.56380449716470 + 0.56510510762463 + 0.56671707740585 + 0.56872779685848 + 0.57125655288868 + 0.57446175820831 + 0.57856635843616 + 0.58389630551400 + 0.59095339103777 + 0.60056849257858 + 0.61427876690168 + 0.63555443628906 + 0.67562018262252 + 1.00000000000000 + 0.66437715047758 + 0.61212907292879 + 0.57814560352272 + 0.55158695263297 + 0.52919992326905 + 0.50954777678201 + 0.49183045961273 + 0.47552815822704 + 0.54257945074660 + 0.54257945377398 + 0.54257945427577 + 0.54257945486021 + 0.54257945554155 + 0.54257945633553 + 0.54257945726123 + 0.54257945834038 + 0.54257945959957 + 0.54257946107454 + 0.54257946282664 + 0.54257946495643 + 0.54257946758626 + 0.54257947084948 + 0.54257947490191 + 0.54257947993477 + 0.54257948618376 + 0.54257949394034 + 0.54257950357889 + 0.54257951557987 + 0.54257953052527 + 0.54257954913932 + 0.54257957232296 + 0.54257960120222 + 0.54257963719959 + 0.54257968222419 + 0.54257973906455 + 0.54257981143872 + 0.54257990381707 + 0.54258002171212 + 0.54258017257241 + 0.54258036576270 + 0.54258061314752 + 0.54258092988015 + 0.54258133529483 + 0.54258185403424 + 0.54258251746169 + 0.54258336544362 + 0.54258445014924 + 0.54258584005640 + 0.54258762117288 + 0.54258990361905 + 0.54259282732424 + 0.54259655695880 + 0.54260120295127 + 0.54260676320791 + 0.54261330050468 + 0.54262085814380 + 0.54262925917156 + 0.54263837469862 + 0.54264822826075 + 0.54265888471328 + 0.54267042241199 + 0.54268293141451 + 0.54269653507062 + 0.54271136604143 + 0.54272755396207 + 0.54274524765211 + 0.54276462020395 + 0.54278588869980 + 0.54280942490745 + 0.54283604170589 + 0.54286685224614 + 0.54290286372712 + 0.54294510977648 + 0.54299485745174 + 0.54305360327652 + 0.54312316634119 + 0.54320578144189 + 0.54330420863590 + 0.54342188139886 + 0.54356315164411 + 0.54373393027706 + 0.54394312187592 + 0.54420293107589 + 0.54452813449911 + 0.54493729934775 + 0.54518092101031 + 0.54545523427169 + 0.54576452725565 + 0.54611376321841 + 0.54650870469061 + 0.54695606537138 + 0.54746369770948 + 0.54804082728714 + 0.54869836657076 + 0.54944983142504 + 0.55032115742023 + 0.55137448353900 + 0.55267586244895 + 0.55429258312152 + 0.55631509130690 + 0.55886059635228 + 0.56208943727204 + 0.56622735745160 + 0.57160443419610 + 0.57872860158358 + 0.58844130582681 + 0.60233202337519 + 0.62389437629539 + 0.66437715047758 + 1.00000000000000 + 0.65306942424987 + 0.60026957607292 + 0.56591968457094 + 0.53918343098822 + 0.51677674043819 + 0.49719995954214 + 0.47959726192170 + 0.53060745256331 + 0.53060745525440 + 0.53060745569987 + 0.53060745621949 + 0.53060745682497 + 0.53060745753051 + 0.53060745835327 + 0.53060745931250 + 0.53060746043161 + 0.53060746174270 + 0.53060746330021 + 0.53060746519463 + 0.53060746753501 + 0.53060747044108 + 0.53060747405224 + 0.53060747853995 + 0.53060748411550 + 0.53060749104057 + 0.53060749965078 + 0.53060751037852 + 0.53060752374507 + 0.53060754040168 + 0.53060756115891 + 0.53060758703010 + 0.53060761929375 + 0.53060765966976 + 0.53060771067022 + 0.53060777564684 + 0.53060785863153 + 0.53060796459624 + 0.53060810026391 + 0.53060827408626 + 0.53060849677584 + 0.53060878201553 + 0.53060914726914 + 0.53060961479168 + 0.53061021291440 + 0.53061097764923 + 0.53061195611749 + 0.53061321018127 + 0.53061481751534 + 0.53061687754357 + 0.53061951655948 + 0.53062288305401 + 0.53062707608523 + 0.53063209245891 + 0.53063798740330 + 0.53064479811049 + 0.53065236219961 + 0.53066056071336 + 0.53066941224224 + 0.53067897218548 + 0.53068930746644 + 0.53070049475934 + 0.53071263973561 + 0.53072585522121 + 0.53074024992699 + 0.53075594816975 + 0.53077309408734 + 0.53079186879214 + 0.53081258816877 + 0.53083595539628 + 0.53086293210418 + 0.53089437605338 + 0.53093115744588 + 0.53097433929005 + 0.53102517016848 + 0.53108516139589 + 0.53115616246186 + 0.53124044877980 + 0.53134084043665 + 0.53146090134189 + 0.53160547435522 + 0.53178188764135 + 0.53200016820425 + 0.53227235813017 + 0.53261348717936 + 0.53281600075956 + 0.53304355132194 + 0.53329956718467 + 0.53358800304304 + 0.53391343343065 + 0.53428116607961 + 0.53469738061347 + 0.53516930010267 + 0.53570542015525 + 0.53631622819594 + 0.53702230151777 + 0.53787384414641 + 0.53892342330946 + 0.54022334752485 + 0.54184309629513 + 0.54387098348730 + 0.54642523085734 + 0.54966766769731 + 0.55382627126092 + 0.55923452966076 + 0.56640679491626 + 0.57622113308327 + 0.59028108274930 + 0.61212907292879 + 0.65306942424987 + 1.00000000000000 + 0.64169777979302 + 0.58828956446727 + 0.55359462304970 + 0.52675367746434 + 0.50439124586571 + 0.48492907500364 + 0.51861281553956 + 0.51861281792129 + 0.51861281831587 + 0.51861281877547 + 0.51861281931198 + 0.51861281993648 + 0.51861282066476 + 0.51861282151373 + 0.51861282250437 + 0.51861282366482 + 0.51861282504402 + 0.51861282672186 + 0.51861282879680 + 0.51861283137497 + 0.51861283458082 + 0.51861283856768 + 0.51861284352404 + 0.51861284968403 + 0.51861285734780 + 0.51861286690214 + 0.51861287881423 + 0.51861289366790 + 0.51861291218868 + 0.51861293528441 + 0.51861296410373 + 0.51861300018776 + 0.51861304579496 + 0.51861310393718 + 0.51861317824007 + 0.51861327317267 + 0.51861339478590 + 0.51861355068718 + 0.51861375051826 + 0.51861400660027 + 0.51861433465985 + 0.51861475474255 + 0.51861529236734 + 0.51861597997283 + 0.51861686000854 + 0.51861798820791 + 0.51861943452931 + 0.51862128850829 + 0.51862366382996 + 0.51862669405845 + 0.51863046781800 + 0.51863498105836 + 0.51864028220867 + 0.51864640305671 + 0.51865319500870 + 0.51866054862463 + 0.51866847828731 + 0.51867703110245 + 0.51868626398151 + 0.51869624191428 + 0.51870705508991 + 0.51871879906956 + 0.51873156453548 + 0.51874545477052 + 0.51876058913343 + 0.51877711796290 + 0.51879530878817 + 0.51881576846021 + 0.51883932574488 + 0.51886670903384 + 0.51889864839479 + 0.51893603242846 + 0.51897989877975 + 0.51903149786757 + 0.51909235366729 + 0.51916433351332 + 0.51924974267318 + 0.51935148553438 + 0.51947351167191 + 0.51962182822731 + 0.51980464165690 + 0.52003172418865 + 0.52031518855502 + 0.52048296483544 + 0.52067108497766 + 0.52088227901318 + 0.52111968621655 + 0.52138692545419 + 0.52168817986021 + 0.52202829956791 + 0.52241292768495 + 0.52284866846291 + 0.52334365577901 + 0.52391423827289 + 0.52460104722946 + 0.52544607272643 + 0.52649024068809 + 0.52778740646232 + 0.52940495823822 + 0.53143158465900 + 0.53398608127680 + 0.53723117319859 + 0.54139627219248 + 0.54681810863748 + 0.55403628519078 + 0.56393428893897 + 0.57814560352272 + 0.60026957607292 + 0.64169777979302 + 1.00000000000000 + 0.63019378334648 + 0.57615557029023 + 0.54119349805877 + 0.51432930613100 + 0.49206929554877 + 0.50661863747423 + 0.50661863957546 + 0.50661863992350 + 0.50661864032919 + 0.50661864080189 + 0.50661864135294 + 0.50661864199540 + 0.50661864274461 + 0.50661864361815 + 0.50661864464215 + 0.50661864585906 + 0.50661864734081 + 0.50661864917405 + 0.50661865145346 + 0.50661865429031 + 0.50661865782082 + 0.50661866221275 + 0.50661866767503 + 0.50661867447479 + 0.50661868295814 + 0.50661869354255 + 0.50661870674748 + 0.50661872322330 + 0.50661874378068 + 0.50661876944689 + 0.50661880160285 + 0.50661884227035 + 0.50661889414975 + 0.50661896049159 + 0.50661904530737 + 0.50661915402502 + 0.50661929347456 + 0.50661947231355 + 0.50661970160865 + 0.50661999548971 + 0.50662037196814 + 0.50662085397551 + 0.50662147066162 + 0.50662226018206 + 0.50662327262876 + 0.50662457087405 + 0.50662623536695 + 0.50662836822282 + 0.50663108931874 + 0.50663447778173 + 0.50663852891826 + 0.50664328509092 + 0.50664877334366 + 0.50665485804539 + 0.50666143880096 + 0.50666852646480 + 0.50667616093753 + 0.50668439043768 + 0.50669326984726 + 0.50670287591473 + 0.50671328930034 + 0.50672458530008 + 0.50673684930590 + 0.50675017966888 + 0.50676470063424 + 0.50678063821040 + 0.50679851523147 + 0.50681904474786 + 0.50684284397111 + 0.50687052370090 + 0.50690282458555 + 0.50694060615979 + 0.50698489935105 + 0.50703695518667 + 0.50709829993454 + 0.50717080993508 + 0.50725684153111 + 0.50735960228526 + 0.50748399930869 + 0.50763672611567 + 0.50782568146421 + 0.50806058508250 + 0.50819919090330 + 0.50835426619646 + 0.50852797568279 + 0.50872280102602 + 0.50894159366101 + 0.50918763794706 + 0.50946472720484 + 0.50977725622764 + 0.51013034504538 + 0.51053029044957 + 0.51099008662242 + 0.51154264977450 + 0.51222160218637 + 0.51305910395373 + 0.51409716075928 + 0.51538765123713 + 0.51699792159023 + 0.51901663068607 + 0.52156257992765 + 0.52479859293398 + 0.52895509736065 + 0.53438599376214 + 0.54163034820185 + 0.55158695263297 + 0.56591968457094 + 0.58828956446727 + 0.63019378334648 + 1.00000000000000 + 0.61853140617222 + 0.56390516389865 + 0.52876392822657 + 0.50195447617043 + 0.49463683639836 + 0.49463683824710 + 0.49463683855314 + 0.49463683891014 + 0.49463683932630 + 0.49463683981079 + 0.49463684037591 + 0.49463684103486 + 0.49463684180367 + 0.49463684270445 + 0.49463684377550 + 0.49463684508046 + 0.49463684669544 + 0.49463684870575 + 0.49463685120904 + 0.49463685432717 + 0.49463685820898 + 0.49463686304011 + 0.49463686905887 + 0.49463687657232 + 0.49463688595294 + 0.49463689766406 + 0.49463691228532 + 0.49463693053961 + 0.49463695334378 + 0.49463698193214 + 0.49463701811023 + 0.49463706429492 + 0.49463712339542 + 0.49463719900124 + 0.49463729597321 + 0.49463742043116 + 0.49463758013474 + 0.49463778500301 + 0.49463804770409 + 0.49463838438999 + 0.49463881562569 + 0.49463936756045 + 0.49464007441926 + 0.49464098114383 + 0.49464214413234 + 0.49464363553852 + 0.49464554692406 + 0.49464798569815 + 0.49465102238955 + 0.49465465186475 + 0.49465891110174 + 0.49466382303187 + 0.49466926412978 + 0.49467514254736 + 0.49468146622841 + 0.49468826887004 + 0.49469559121678 + 0.49470347948688 + 0.49471199885664 + 0.49472121724923 + 0.49473119695709 + 0.49474200830663 + 0.49475373202102 + 0.49476647043085 + 0.49478041417944 + 0.49479601332755 + 0.49481388083097 + 0.49483453906518 + 0.49485849814699 + 0.49488637423354 + 0.49491887772565 + 0.49495685644588 + 0.49500133449120 + 0.49505355550470 + 0.49511504151666 + 0.49518769733266 + 0.49527411919084 + 0.49537830514527 + 0.49550570057210 + 0.49566266916613 + 0.49585698131269 + 0.49597127082708 + 0.49609885366068 + 0.49624143945188 + 0.49640098223971 + 0.49657972000082 + 0.49678022159242 + 0.49700544290158 + 0.49725879463517 + 0.49754423344490 + 0.49786662201498 + 0.49823629028948 + 0.49867992863609 + 0.49922451183485 + 0.49989539626444 + 0.50072550152047 + 0.50175503501490 + 0.50303560325843 + 0.50463418435697 + 0.50663893686983 + 0.50916798851561 + 0.51238383328469 + 0.51652858200425 + 0.52195221804787 + 0.52919992326905 + 0.53918343098822 + 0.55359462304970 + 0.57615557029023 + 0.61853140617222 + 1.00000000000000 + 0.60676333699963 + 0.55159127857473 + 0.51636160916791 + 0.48268105283562 + 0.48268105445825 + 0.48268105472714 + 0.48268105504042 + 0.48268105540569 + 0.48268105583140 + 0.48268105632771 + 0.48268105690591 + 0.48268105758101 + 0.48268105837208 + 0.48268105931265 + 0.48268106045942 + 0.48268106187967 + 0.48268106364893 + 0.48268106585424 + 0.48268106860325 + 0.48268107202777 + 0.48268107629281 + 0.48268108161084 + 0.48268108825408 + 0.48268109655328 + 0.48268110692180 + 0.48268111987528 + 0.48268113605777 + 0.48268115628534 + 0.48268118165853 + 0.48268121379147 + 0.48268125483965 + 0.48268130740325 + 0.48268137469110 + 0.48268146105053 + 0.48268157195442 + 0.48268171434629 + 0.48268189710481 + 0.48268213157130 + 0.48268243220912 + 0.48268281743680 + 0.48268331067434 + 0.48268394258160 + 0.48268475342185 + 0.48268579372208 + 0.48268712811024 + 0.48268883858039 + 0.48269102125396 + 0.48269373892997 + 0.48269698620553 + 0.48270079532657 + 0.48270518568369 + 0.48271004500503 + 0.48271528945735 + 0.48272092462967 + 0.48272697893459 + 0.48273348675109 + 0.48274048694922 + 0.48274803483513 + 0.48275618754819 + 0.48276499650970 + 0.48277451950934 + 0.48278482264250 + 0.48279599003669 + 0.48280818248479 + 0.48282178746885 + 0.48283733200773 + 0.48285525825253 + 0.48287599210434 + 0.48290004593937 + 0.48292800648252 + 0.48296057031021 + 0.48299857473666 + 0.48304303158288 + 0.48309517322208 + 0.48315653629104 + 0.48322921843437 + 0.48331647348814 + 0.48342272656215 + 0.48355309536766 + 0.48371377723786 + 0.48380797632006 + 0.48391288871263 + 0.48402986082973 + 0.48416042685204 + 0.48430633819995 + 0.48446959831644 + 0.48465250398629 + 0.48485769490090 + 0.48508822071466 + 0.48534782943847 + 0.48564474073243 + 0.48600063190062 + 0.48643719717958 + 0.48697449828116 + 0.48763845283423 + 0.48846041348256 + 0.48948023983600 + 0.49074905025904 + 0.49233313115107 + 0.49431965864183 + 0.49682581489843 + 0.50002226837753 + 0.50414585732882 + 0.50954777678201 + 0.51677674043819 + 0.52675367746434 + 0.54119349805877 + 0.56390516389865 + 0.60676333699963 + 1.00000000000000 + 0.59489568819780 + 0.53924757178223 + 0.47075289767456 + 0.47075289909755 + 0.47075289933340 + 0.47075289960817 + 0.47075289992836 + 0.47075290030174 + 0.47075290073690 + 0.47075290124445 + 0.47075290183620 + 0.47075290252977 + 0.47075290335493 + 0.47075290436148 + 0.47075290560926 + 0.47075290716501 + 0.47075290910547 + 0.47075291152609 + 0.47075291454406 + 0.47075291830587 + 0.47075292299952 + 0.47075292886693 + 0.47075293620273 + 0.47075294537303 + 0.47075295683655 + 0.47075297116731 + 0.47075298909131 + 0.47075301158943 + 0.47075304009930 + 0.47075307654566 + 0.47075312324835 + 0.47075318307239 + 0.47075325990186 + 0.47075335862647 + 0.47075348545301 + 0.47075364832187 + 0.47075385737398 + 0.47075412554999 + 0.47075446932685 + 0.47075490966201 + 0.47075547399361 + 0.47075619836247 + 0.47075712798879 + 0.47075832070984 + 0.47075984989043 + 0.47076180147972 + 0.47076423136220 + 0.47076713401317 + 0.47077053754361 + 0.47077445832985 + 0.47077879450250 + 0.47078346971369 + 0.47078848768355 + 0.47079387236217 + 0.47079965275618 + 0.47080586155753 + 0.47081254572255 + 0.47081975333933 + 0.47082752683905 + 0.47083591368439 + 0.47084496796288 + 0.47085475884096 + 0.47086542211160 + 0.47087729177538 + 0.47089082151841 + 0.47090638612009 + 0.47092434162045 + 0.47094511462603 + 0.47096919023002 + 0.47099714124835 + 0.47102965275216 + 0.47106754832381 + 0.47111182598697 + 0.47116372533341 + 0.47122494151351 + 0.47129812480790 + 0.47138687404568 + 0.47149530549436 + 0.47162835987488 + 0.47170610227224 + 0.47179248217335 + 0.47188855891568 + 0.47199553577275 + 0.47211478187177 + 0.47224785789288 + 0.47239654640249 + 0.47256288801021 + 0.47274923074873 + 0.47295846220216 + 0.47319713813899 + 0.47348291338627 + 0.47383329579480 + 0.47426422728106 + 0.47479622046725 + 0.47545388274678 + 0.47626824671713 + 0.47727870947182 + 0.47853571555757 + 0.48010456741217 + 0.48207136567687 + 0.48455931066445 + 0.48773371469149 + 0.49183045961273 + 0.49719995954214 + 0.50439124586571 + 0.51432930613100 + 0.52876392822657 + 0.55159127857473 + 0.59489568819780 + 1.00000000000000 + 0.58293985357905 + 0.45884148496229 + 0.45884148620969 + 0.45884148641622 + 0.45884148665725 + 0.45884148693801 + 0.45884148726542 + 0.45884148764689 + 0.45884148809137 + 0.45884148861003 + 0.45884148921849 + 0.45884148994195 + 0.45884149082445 + 0.45884149192045 + 0.45884149328737 + 0.45884149499418 + 0.45884149712499 + 0.45884149978359 + 0.45884150309983 + 0.45884150724004 + 0.45884151242021 + 0.45884151890017 + 0.45884152700729 + 0.45884153714748 + 0.45884154983192 + 0.45884156570642 + 0.45884158564338 + 0.45884161092449 + 0.45884164326618 + 0.45884168473778 + 0.45884173789417 + 0.45884180620235 + 0.45884189403034 + 0.45884200692223 + 0.45884215197056 + 0.45884233824042 + 0.45884257729695 + 0.45884288387525 + 0.45884327671158 + 0.45884378034599 + 0.45884442701436 + 0.45884525716175 + 0.45884632251664 + 0.45884768867946 + 0.45884943246197 + 0.45885160358105 + 0.45885419651196 + 0.45885723577120 + 0.45886073518269 + 0.45886460246797 + 0.45886876823768 + 0.45887323476560 + 0.45887802225563 + 0.45888315521593 + 0.45888866117599 + 0.45889458007051 + 0.45890095244239 + 0.45890781335038 + 0.45891520182623 + 0.45892316219315 + 0.45893175142817 + 0.45894108450646 + 0.45895144990482 + 0.45896323897539 + 0.45897677021878 + 0.45899234210182 + 0.45901031082867 + 0.45903107859576 + 0.45905511776152 + 0.45908299035040 + 0.45911536845657 + 0.45915306226477 + 0.45919707402192 + 0.45924877699726 + 0.45931033609407 + 0.45938468652631 + 0.45947514706901 + 0.45958566440339 + 0.45965002410830 + 0.45972136599381 + 0.45980052476672 + 0.45988844549454 + 0.45998619989008 + 0.46009500528908 + 0.46021624690541 + 0.46035150420565 + 0.46050258736421 + 0.46067172525988 + 0.46086416838057 + 0.46109435521607 + 0.46137648290222 + 0.46172329197378 + 0.46215112235837 + 0.46267943350738 + 0.46333259881727 + 0.46414129640327 + 0.46514438612193 + 0.46639150160075 + 0.46794702118493 + 0.46990178121070 + 0.47237423511631 + 0.47552815822704 + 0.47959726192170 + 0.48492907500364 + 0.49206929554877 + 0.50195447617043 + 0.51636160916791 + 0.53924757178223 + 0.58293985357905 + 1.00000000000000 + 1.00000000000000 + 0.99984454894847 + 0.99983207011229 + 0.99981924330322 + 0.99980609015675 + 0.99979261951901 + 0.99977882560866 + 0.99976468645376 + 0.99975016072160 + 0.99973517403915 + 0.99971957720477 + 0.99970312985577 + 0.99968559240583 + 0.99966676245599 + 0.99964644019320 + 0.99962440762897 + 0.99960042113061 + 0.99957420764856 + 0.99954542982069 + 0.99951367975449 + 0.99947854121247 + 0.99943954686618 + 0.99939617394043 + 0.99934783904767 + 0.99929388259113 + 0.99923349439757 + 0.99916557945862 + 0.99908892790658 + 0.99900244596047 + 0.99890507691708 + 0.99879542253157 + 0.99867209261841 + 0.99853360766893 + 0.99837828227277 + 0.99820415509620 + 0.99800890828094 + 0.99778978009138 + 0.99754347426932 + 0.99726579923166 + 0.99695155376628 + 0.99659493349668 + 0.99618909332979 + 0.99572606468099 + 0.99519725689707 + 0.99459682505113 + 0.99392189178677 + 0.99316401545978 + 0.99231365679660 + 0.99136628440340 + 0.99031272814148 + 0.98913742816868 + 0.98782265518467 + 0.98634919286249 + 0.98469590392430 + 0.98283748365780 + 0.98074532250084 + 0.97838758934593 + 0.97572724591573 + 0.97272225428316 + 0.96932616742859 + 0.96548643643924 + 0.96113750502590 + 0.95620794978686 + 0.95063593993336 + 0.94436714563568 + 0.93734866584697 + 0.92953857268844 + 0.92090669352424 + 0.91143805167349 + 0.90113801858185 + 0.89003828363715 + 0.87820221118385 + 0.86572357956389 + 0.85271384825934 + 0.83931439246707 + 0.82571449810067 + 0.81211953430712 + 0.80537739391204 + 0.79869903143533 + 0.79209635409468 + 0.78557542488123 + 0.77913597769938 + 0.77277132995972 + 0.76646883681535 + 0.76021098885213 + 0.75397699152659 + 0.74774120836016 + 0.74141812809549 + 0.73476309475571 + 0.72764244507114 + 0.72003206225317 + 0.71190117775669 + 0.70325883642458 + 0.69412466393630 + 0.68452764856428 + 0.67450480125254 + 0.66409973310682 + 0.65335849162471 + 0.64228120335253 + 0.63091181769725 + 0.61929719598411 + 0.60748715500285 + 0.59553479242522 + 0.58349668799590 + 0.57140796967911 + 0.55929895121005 + 0.54721985404169 + 0.53521625125906 + 0.52332462773726 + 0.99984454894847 + 1.00000000000000 + 0.99995296980157 + 0.99991622175446 + 0.99988506550817 + 0.99985769711526 + 0.99983302212297 + 0.99981027770922 + 0.99978888869722 + 0.99976838245567 + 0.99974830222432 + 0.99972816748648 + 0.99970756152032 + 0.99968615417897 + 0.99966365000884 + 0.99963975721761 + 0.99961417405466 + 0.99958658094322 + 0.99955660197293 + 0.99952379748711 + 0.99948772634448 + 0.99944790076023 + 0.99940378113146 + 0.99935477016678 + 0.99930019666311 + 0.99923924043330 + 0.99917079762726 + 0.99909365204628 + 0.99900670649872 + 0.99890890262157 + 0.99879884085759 + 0.99867513108380 + 0.99853629444860 + 0.99838064622330 + 0.99820622549238 + 0.99801071432185 + 0.99779135031794 + 0.99754483596797 + 0.99726697779990 + 0.99695257236921 + 0.99659581304043 + 0.99618985238436 + 0.99572671952568 + 0.99519782170005 + 0.99459731217638 + 0.99392231195617 + 0.99316437778664 + 0.99231396910530 + 0.99136655353713 + 0.99031296007061 + 0.98913762809994 + 0.98782282766508 + 0.98634934186563 + 0.98469603290704 + 0.98283759560456 + 0.98074541998818 + 0.97838767458762 + 0.97572732080739 + 0.97272232042796 + 0.96932622618648 + 0.96548648894080 + 0.96113755219463 + 0.95620799236939 + 0.95063597853625 + 0.94436718074954 + 0.93734869786348 + 0.92953860192341 + 0.92090672022975 + 0.91143807605710 + 0.90113804081270 + 0.89003830385933 + 0.87820222952337 + 0.86572359613460 + 0.85271386316565 + 0.83931440580963 + 0.82571450998337 + 0.81211954483678 + 0.80537740380650 + 0.79869904072216 + 0.79209636280409 + 0.78557543304193 + 0.77913598534110 + 0.77277133711139 + 0.76646884350676 + 0.76021099511258 + 0.75397699738503 + 0.74774121384493 + 0.74141813323072 + 0.73476309955516 + 0.72764244954600 + 0.72003206641462 + 0.71190118161557 + 0.70325883999364 + 0.69412466722767 + 0.68452765158897 + 0.67450480402211 + 0.66409973563253 + 0.65335849391705 + 0.64228120542178 + 0.63091181955402 + 0.61929719763943 + 0.60748715646855 + 0.59553479371399 + 0.58349668911996 + 0.57140797065113 + 0.55929895204386 + 0.54721985475042 + 0.53521625185653 + 0.52332462823751 + 0.99983207011229 + 0.99995296980157 + 1.00000000000000 + 0.99994692108805 + 0.99990705829157 + 0.99987410513677 + 0.99984563277899 + 0.99982021364679 + 0.99979688974713 + 0.99977495156688 + 0.99975378831560 + 0.99973281596783 + 0.99971154871633 + 0.99968961017009 + 0.99966667289401 + 0.99964242231495 + 0.99961654007421 + 0.99958869420486 + 0.99955849922470 + 0.99952550802270 + 0.99948927382432 + 0.99944930440778 + 0.99940505665390 + 0.99935593045997 + 0.99930125235059 + 0.99924020023096 + 0.99917166861258 + 0.99909444012897 + 0.99900741694009 + 0.99890954035158 + 0.99879941054601 + 0.99867563738617 + 0.99853674210712 + 0.99838104007641 + 0.99820657043682 + 0.99801101523568 + 0.99779161195843 + 0.99754506287888 + 0.99726717421028 + 0.99695274213360 + 0.99659595963698 + 0.99618997890289 + 0.99572682867618 + 0.99519791584200 + 0.99459739336733 + 0.99392238198405 + 0.99316443816868 + 0.99231402114518 + 0.99136659837676 + 0.99031299870725 + 0.98913766140042 + 0.98782285638936 + 0.98634936667577 + 0.98469605437910 + 0.98283761423795 + 0.98074543621091 + 0.97838768877068 + 0.97572733326609 + 0.97272233142968 + 0.96932623595707 + 0.96548649766872 + 0.96113756003540 + 0.95620799944582 + 0.95063598494858 + 0.94436718658120 + 0.93734870317954 + 0.92953860677645 + 0.92090672466230 + 0.91143808010266 + 0.90113804450043 + 0.89003830721350 + 0.87820223256468 + 0.86572359888201 + 0.85271386563669 + 0.83931440802164 + 0.82571451195253 + 0.81211954658170 + 0.80537740544609 + 0.79869904226102 + 0.79209636424780 + 0.78557543439425 + 0.77913598660722 + 0.77277133829635 + 0.76646884461569 + 0.76021099615001 + 0.75397699835595 + 0.74774121475340 + 0.74141813408171 + 0.73476310035056 + 0.72764245028725 + 0.72003206710400 + 0.71190118225510 + 0.70325884058487 + 0.69412466777293 + 0.68452765209019 + 0.67450480448085 + 0.66409973605097 + 0.65335849429653 + 0.64228120576441 + 0.63091181986171 + 0.61929719791367 + 0.60748715671142 + 0.59553479392716 + 0.58349668930604 + 0.57140797081229 + 0.55929895218191 + 0.54721985486774 + 0.53521625195560 + 0.52332462832037 + 0.99981924330322 + 0.99991622175446 + 0.99994692108805 + 1.00000000000000 + 0.99994027428799 + 0.99989729467832 + 0.99986265692516 + 0.99983317995060 + 0.99980706646636 + 0.99978314460010 + 0.99976052825905 + 0.99973846098607 + 0.99971634751931 + 0.99969374093797 + 0.99967026666465 + 0.99964557757238 + 0.99961933221627 + 0.99959118183787 + 0.99956072826880 + 0.99952751470457 + 0.99949108714398 + 0.99945094774417 + 0.99940654898158 + 0.99935728727283 + 0.99930248635292 + 0.99924132180801 + 0.99917268617347 + 0.99909536067300 + 0.99900824668238 + 0.99891028509751 + 0.99880007578622 + 0.99867622857937 + 0.99853726480521 + 0.99838149994534 + 0.99820697320098 + 0.99801136658998 + 0.99779191746143 + 0.99754532783724 + 0.99726740355904 + 0.99695294037241 + 0.99659613082572 + 0.99619012664736 + 0.99572695613905 + 0.99519802577609 + 0.99459748817864 + 0.99392246375629 + 0.99316450867589 + 0.99231408191099 + 0.99136665073398 + 0.99031304381826 + 0.98913770027913 + 0.98782288992216 + 0.98634939563841 + 0.98469607944388 + 0.98283763598739 + 0.98074545514683 + 0.97838770532410 + 0.97572734780489 + 0.97272234426855 + 0.96932624735778 + 0.96548650785344 + 0.96113756918183 + 0.95620800769997 + 0.95063599243007 + 0.94436719338343 + 0.93734870937998 + 0.92953861243680 + 0.92090672983146 + 0.91143808482053 + 0.90113804880093 + 0.89003831112413 + 0.87820223611058 + 0.86572360208481 + 0.85271386851765 + 0.83931441060017 + 0.82571451424805 + 0.81211954861585 + 0.80537740735744 + 0.79869904405514 + 0.79209636592957 + 0.78557543597009 + 0.77913598808290 + 0.77277133967722 + 0.76646884590775 + 0.76021099735891 + 0.75397699948733 + 0.74774121581263 + 0.74141813507335 + 0.73476310127742 + 0.72764245115157 + 0.72003206790748 + 0.71190118300028 + 0.70325884127405 + 0.69412466840836 + 0.68452765267416 + 0.67450480501584 + 0.66409973653867 + 0.65335849473933 + 0.64228120616423 + 0.63091182022021 + 0.61929719823356 + 0.60748715699437 + 0.59553479417595 + 0.58349668952287 + 0.57140797099990 + 0.55929895234289 + 0.54721985500468 + 0.53521625207085 + 0.52332462841684 + 0.99980609015675 + 0.99988506550817 + 0.99990705829157 + 0.99994027428799 + 1.00000000000000 + 0.99993301061593 + 0.99988695863502 + 0.99985076261771 + 0.99982036512003 + 0.99979356256723 + 0.99976892540313 + 0.99974538674182 + 0.99972216694631 + 0.99969870609044 + 0.99967455723586 + 0.99964932513340 + 0.99962263532338 + 0.99959411572513 + 0.99956335101758 + 0.99952987158100 + 0.99949321399323 + 0.99945287320041 + 0.99940829610655 + 0.99935887477815 + 0.99930392949526 + 0.99924263300399 + 0.99917387544335 + 0.99909643633191 + 0.99900921608689 + 0.99891115509814 + 0.99880085284244 + 0.99867691910082 + 0.99853787530465 + 0.99838203705107 + 0.99820744360990 + 0.99801177696085 + 0.99779227428718 + 0.99754563731454 + 0.99726767145242 + 0.99695317193250 + 0.99659633079273 + 0.99619029923150 + 0.99572710503433 + 0.99519815419519 + 0.99459759892888 + 0.99392255927440 + 0.99316459103231 + 0.99231415288537 + 0.99136671188393 + 0.99031309650294 + 0.98913774568251 + 0.98782292908145 + 0.98634942945824 + 0.98469610871038 + 0.98283766138201 + 0.98074547725359 + 0.97838772464829 + 0.97572736477700 + 0.97272235925301 + 0.96932626066500 + 0.96548651973885 + 0.96113757985640 + 0.95620801733297 + 0.95063600115843 + 0.94436720131911 + 0.93734871661340 + 0.92953861903884 + 0.92090673586002 + 0.91143809032280 + 0.90113805381563 + 0.89003831568409 + 0.87820224024502 + 0.86572360582011 + 0.85271387187640 + 0.83931441360593 + 0.82571451692439 + 0.81211955098715 + 0.80537740958566 + 0.79869904614618 + 0.79209636789048 + 0.78557543780728 + 0.77913598980331 + 0.77277134128693 + 0.76646884741395 + 0.76021099876822 + 0.75397700080609 + 0.74774121704754 + 0.74141813622902 + 0.73476310235746 + 0.72764245215861 + 0.72003206884417 + 0.71190118386902 + 0.70325884207755 + 0.69412466914889 + 0.68452765335479 + 0.67450480563905 + 0.66409973710699 + 0.65335849525504 + 0.64228120662978 + 0.63091182063800 + 0.61929719860587 + 0.60748715732422 + 0.59553479446592 + 0.58349668977559 + 0.57140797121886 + 0.55929895253043 + 0.54721985516420 + 0.53521625220528 + 0.52332462852933 + 0.99979261951901 + 0.99985769711526 + 0.99987410513677 + 0.99989729467832 + 0.99993301061593 + 1.00000000000000 + 0.99992511927151 + 0.99987608455385 + 0.99983845734096 + 0.99980718177437 + 0.99977959251270 + 0.99975400221979 + 0.99972929486208 + 0.99970471780577 + 0.99967970734441 + 0.99965379410796 + 0.99962655478825 + 0.99959758396849 + 0.99956644257576 + 0.99953264369414 + 0.99949571142018 + 0.99945513130679 + 0.99941034312290 + 0.99936073342730 + 0.99930561819177 + 0.99924416665833 + 0.99917526604108 + 0.99909769378007 + 0.99901034911422 + 0.99891217180253 + 0.99880176083853 + 0.99867772592631 + 0.99853858859824 + 0.99838266458158 + 0.99820799321246 + 0.99801225642602 + 0.99779269120241 + 0.99754599891943 + 0.99726798447787 + 0.99695344251326 + 0.99659656446201 + 0.99619050090529 + 0.99572727902505 + 0.99519830425903 + 0.99459772834423 + 0.99392267088672 + 0.99316468726295 + 0.99231423581318 + 0.99136678332864 + 0.99031315805334 + 0.98913779872471 + 0.98782297482509 + 0.98634946896053 + 0.98469614289201 + 0.98283769103867 + 0.98074550306994 + 0.97838774721244 + 0.97572738459345 + 0.97272237674905 + 0.96932627619888 + 0.96548653361216 + 0.96113759231488 + 0.95620802857435 + 0.95063601134383 + 0.94436721057876 + 0.93734872505215 + 0.92953862673988 + 0.92090674289234 + 0.91143809674075 + 0.90113805966466 + 0.89003832100207 + 0.87820224506619 + 0.86572361017491 + 0.85271387579280 + 0.83931441711036 + 0.82571452004453 + 0.81211955375163 + 0.80537741218268 + 0.79869904858384 + 0.79209637017620 + 0.78557543994926 + 0.77913599180823 + 0.77277134316351 + 0.76646884916947 + 0.76021100041067 + 0.75397700234351 + 0.74774121848657 + 0.74141813757628 + 0.73476310361669 + 0.72764245333275 + 0.72003206993588 + 0.71190118488166 + 0.70325884301384 + 0.69412467001224 + 0.68452765414823 + 0.67450480636572 + 0.66409973776960 + 0.65335849585642 + 0.64228120717275 + 0.63091182112510 + 0.61929719903996 + 0.60748715770864 + 0.59553479480405 + 0.58349669007047 + 0.57140797147378 + 0.55929895274920 + 0.54721985534995 + 0.53521625236199 + 0.52332462866045 + 0.99977882560866 + 0.99983302212297 + 0.99984563277899 + 0.99986265692516 + 0.99988695863502 + 0.99992511927151 + 1.00000000000000 + 0.99991659800860 + 0.99986470729419 + 0.99982574662351 + 0.99979352968448 + 0.99976492907221 + 0.99973814466314 + 0.99971206729845 + 0.99968593248992 + 0.99965915074750 + 0.99963122339977 + 0.99960169572165 + 0.99957009480649 + 0.99953590983505 + 0.99949864802458 + 0.99945778249877 + 0.99941274373440 + 0.99936291125137 + 0.99930759558229 + 0.99924596161017 + 0.99917689294600 + 0.99909916448397 + 0.99901167401067 + 0.99891336048375 + 0.99880282229994 + 0.99867866903898 + 0.99853942233867 + 0.99838339805730 + 0.99820863560619 + 0.99801281684780 + 0.99779317852688 + 0.99754642160833 + 0.99726835039399 + 0.99695375882176 + 0.99659683762899 + 0.99619073667307 + 0.99572748243133 + 0.99519847969187 + 0.99459787963609 + 0.99392280136300 + 0.99316479975043 + 0.99231433274726 + 0.99136686683516 + 0.99031322999025 + 0.98913786071154 + 0.98782302827911 + 0.98634951511801 + 0.98469618283032 + 0.98283772568523 + 0.98074553322780 + 0.97838777357011 + 0.97572740773894 + 0.97272239718161 + 0.96932629434002 + 0.96548654981149 + 0.96113760686035 + 0.95620804169707 + 0.95063602323167 + 0.94436722138560 + 0.93734873489909 + 0.92953863572579 + 0.92090675109573 + 0.91143810422557 + 0.90113806648620 + 0.89003832720361 + 0.87820225068809 + 0.86572361525245 + 0.85271388035891 + 0.83931442119625 + 0.82571452368200 + 0.81211955697421 + 0.80537741521049 + 0.79869905142544 + 0.79209637284093 + 0.78557544244572 + 0.77913599414605 + 0.77277134535132 + 0.76646885121629 + 0.76021100232588 + 0.75397700413509 + 0.74774122016363 + 0.74141813914663 + 0.73476310508460 + 0.72764245470097 + 0.72003207120864 + 0.71190118606175 + 0.70325884410554 + 0.69412467101867 + 0.68452765507312 + 0.67450480721252 + 0.66409973854170 + 0.65335849655730 + 0.64228120780532 + 0.63091182169273 + 0.61929719954631 + 0.60748715815711 + 0.59553479519808 + 0.58349669041424 + 0.57140797177097 + 0.55929895300392 + 0.54721985556652 + 0.53521625254472 + 0.52332462881344 + 0.99976468645376 + 0.99981027770922 + 0.99982021364679 + 0.99983317995060 + 0.99985076261771 + 0.99987608455385 + 0.99991659800860 + 1.00000000000000 + 0.99990745058629 + 0.99985283914674 + 0.99981254113064 + 0.99977918530315 + 0.99974934440208 + 0.99972117168774 + 0.99969352744890 + 0.99966561448366 + 0.99963681168103 + 0.99960658825808 + 0.99957442141914 + 0.99953976637671 + 0.99950210697438 + 0.99946089955282 + 0.99941556230144 + 0.99936546560392 + 0.99930991303938 + 0.99924806401197 + 0.99917879766267 + 0.99910088574337 + 0.99901322422146 + 0.99891475104738 + 0.99880406386198 + 0.99867977206642 + 0.99854039738665 + 0.99838425582433 + 0.99820938685022 + 0.99801347224025 + 0.99779374845113 + 0.99754691596048 + 0.99726877836542 + 0.99695412878768 + 0.99659715714306 + 0.99619101244748 + 0.99572772035503 + 0.99519868489367 + 0.99459805659713 + 0.99392295396960 + 0.99316493131163 + 0.99231444611064 + 0.99136696448922 + 0.99031331410650 + 0.98913793318845 + 0.98782309077335 + 0.98634956907661 + 0.98469622951347 + 0.98283776617892 + 0.98074556847233 + 0.97838780437095 + 0.97572743478236 + 0.97272242105301 + 0.96932631553152 + 0.96548656873361 + 0.96113762384736 + 0.95620805702077 + 0.95063603711225 + 0.94436723400118 + 0.93734874639313 + 0.92953864621396 + 0.92090676066938 + 0.91143811296060 + 0.90113807444436 + 0.89003833443950 + 0.87820225724604 + 0.86572362117546 + 0.85271388568417 + 0.83931442596123 + 0.82571452792349 + 0.81211956073209 + 0.80537741874097 + 0.79869905473922 + 0.79209637594815 + 0.78557544535641 + 0.77913599687153 + 0.77277134790170 + 0.76646885360266 + 0.76021100455819 + 0.75397700622440 + 0.74774122211966 + 0.74141814097747 + 0.73476310679575 + 0.72764245629669 + 0.72003207269228 + 0.71190118743758 + 0.70325884537809 + 0.69412467219198 + 0.68452765615162 + 0.67450480820003 + 0.66409973944187 + 0.65335849737457 + 0.64228120854287 + 0.63091182235489 + 0.61929720013627 + 0.60748715867951 + 0.59553479565726 + 0.58349669081484 + 0.57140797211771 + 0.55929895330124 + 0.54721985581926 + 0.53521625275764 + 0.52332462899163 + 0.99975016072160 + 0.99978888869722 + 0.99979688974713 + 0.99980706646636 + 0.99982036512003 + 0.99983845734096 + 0.99986470729419 + 0.99990745058629 + 1.00000000000000 + 0.99989766982902 + 0.99984040209431 + 0.99979862410015 + 0.99976392635324 + 0.99973266533942 + 0.99970291464153 + 0.99967348586112 + 0.99964354534455 + 0.99961243867686 + 0.99957956633641 + 0.99954433357203 + 0.99950619097201 + 0.99946457165906 + 0.99941887725741 + 0.99936846608369 + 0.99931263271188 + 0.99925052956617 + 0.99918103019674 + 0.99910290242867 + 0.99901503994614 + 0.99891637940638 + 0.99880551748801 + 0.99868106333707 + 0.99854153874769 + 0.99838525985213 + 0.99821026617892 + 0.99801423937932 + 0.99779441556433 + 0.99754749463160 + 0.99726927935049 + 0.99695456188428 + 0.99659753118750 + 0.99619133529016 + 0.99572799888730 + 0.99519892511520 + 0.99459826375075 + 0.99392313260670 + 0.99316508530829 + 0.99231457879354 + 0.99136707877749 + 0.99031341254570 + 0.98913801799733 + 0.98782316389533 + 0.98634963220657 + 0.98469628412259 + 0.98283781354715 + 0.98074560969302 + 0.97838784039001 + 0.97572746640627 + 0.97272244896443 + 0.96932634030598 + 0.96548659085161 + 0.96113764370165 + 0.95620807492813 + 0.95063605333128 + 0.94436724874032 + 0.93734875982011 + 0.92953865846323 + 0.92090677184902 + 0.91143812315974 + 0.90113808373567 + 0.89003834288536 + 0.87820226490103 + 0.86572362808789 + 0.85271389189931 + 0.83931443152174 + 0.82571453287360 + 0.81211956511652 + 0.80537742286008 + 0.79869905860480 + 0.79209637957348 + 0.78557544875299 + 0.77913600005157 + 0.77277135087776 + 0.76646885638687 + 0.76021100716354 + 0.75397700866220 + 0.74774122440147 + 0.74141814311397 + 0.73476310879290 + 0.72764245815858 + 0.72003207442377 + 0.71190118904305 + 0.70325884686309 + 0.69412467356145 + 0.68452765740997 + 0.67450480935233 + 0.66409974049284 + 0.65335849832852 + 0.64228120940387 + 0.63091182312739 + 0.61929720082535 + 0.60748715928936 + 0.59553479619350 + 0.58349669128242 + 0.57140797252216 + 0.55929895364827 + 0.54721985611415 + 0.53521625300623 + 0.52332462919978 + 0.99973517403915 + 0.99976838245567 + 0.99977495156688 + 0.99978314460010 + 0.99979356256723 + 0.99980718177437 + 0.99982574662351 + 0.99985283914674 + 0.99989766982902 + 1.00000000000000 + 0.99988718569615 + 0.99982720208745 + 0.99978379515480 + 0.99974760370429 + 0.99971474592878 + 0.99968320400116 + 0.99965174147987 + 0.99961948887963 + 0.99958572223700 + 0.99954977014376 + 0.99951103419933 + 0.99946891451120 + 0.99942278981760 + 0.99937200216802 + 0.99931583427070 + 0.99925342953370 + 0.99918365440588 + 0.99910527175861 + 0.99901717236727 + 0.99891829122176 + 0.99880722377250 + 0.99868257878437 + 0.99854287808355 + 0.99838643792057 + 0.99821129786172 + 0.99801513939555 + 0.99779519820760 + 0.99754817350025 + 0.99726986707402 + 0.99695506995494 + 0.99659796997403 + 0.99619171400197 + 0.99572832560521 + 0.99519920688176 + 0.99459850671907 + 0.99392334211615 + 0.99316526590698 + 0.99231473439062 + 0.99136721279392 + 0.99031352797083 + 0.98913811743570 + 0.98782324962433 + 0.98634970621654 + 0.98469634814450 + 0.98283786907299 + 0.98074565801471 + 0.97838788261228 + 0.97572750347426 + 0.97272248167870 + 0.96932636934316 + 0.96548661677303 + 0.96113766696817 + 0.95620809591155 + 0.95063607233334 + 0.94436726600556 + 0.93734877554681 + 0.92953867280941 + 0.92090678494172 + 0.91143813510226 + 0.90113809461455 + 0.89003835277414 + 0.87820227386315 + 0.86572363617989 + 0.85271389917398 + 0.83931443803063 + 0.82571453866798 + 0.81211957024983 + 0.80537742768340 + 0.79869906313253 + 0.79209638381826 + 0.78557545273053 + 0.77913600377586 + 0.77277135436383 + 0.76646885964882 + 0.76021101021534 + 0.75397701151820 + 0.74774122707544 + 0.74141814561812 + 0.73476311113388 + 0.72764246034126 + 0.72003207645366 + 0.71190119092599 + 0.70325884860437 + 0.69412467516702 + 0.68452765888556 + 0.67450481070389 + 0.66409974172507 + 0.65335849944714 + 0.64228121041408 + 0.63091182403382 + 0.61929720163339 + 0.60748716000473 + 0.59553479682218 + 0.58349669183121 + 0.57140797299679 + 0.55929895405534 + 0.54721985646024 + 0.53521625329812 + 0.52332462944400 + 0.99971957720477 + 0.99974830222432 + 0.99975378831560 + 0.99976052825905 + 0.99976892540313 + 0.99977959251270 + 0.99979352968448 + 0.99981254113064 + 0.99984040209431 + 0.99988718569615 + 1.00000000000000 + 0.99987587816081 + 0.99981312113405 + 0.99976798562108 + 0.99973014382596 + 0.99969547939023 + 0.99966189305822 + 0.99962810567300 + 0.99959317680775 + 0.99955631082719 + 0.99951683393523 + 0.99947409756791 + 0.99942744786435 + 0.99937620436889 + 0.99931963377804 + 0.99925686760132 + 0.99918676309741 + 0.99910807678415 + 0.99901969566827 + 0.99892055255874 + 0.99880924130021 + 0.99868437012084 + 0.99854446081416 + 0.99838782973046 + 0.99821251644144 + 0.99801620221785 + 0.99779612222474 + 0.99754897483155 + 0.99727056067343 + 0.99695566943292 + 0.99659848760012 + 0.99619216067585 + 0.99572871088776 + 0.99519953910502 + 0.99459879315961 + 0.99392358909061 + 0.99316547878753 + 0.99231491779922 + 0.99136737077033 + 0.99031366403936 + 0.98913823467092 + 0.98782335071031 + 0.98634979349758 + 0.98469642365792 + 0.98283793458106 + 0.98074571503312 + 0.97838793244522 + 0.97572754723271 + 0.97272252030955 + 0.96932640363762 + 0.96548664739478 + 0.96113769445745 + 0.95620812070543 + 0.95063609478757 + 0.94436728641216 + 0.93734879413469 + 0.92953868976457 + 0.92090680041598 + 0.91143814921779 + 0.90113810747434 + 0.89003836446388 + 0.87820228445862 + 0.86572364574882 + 0.85271390777923 + 0.83931444573200 + 0.82571454552605 + 0.81211957632814 + 0.80537743339688 + 0.79869906849632 + 0.79209638884959 + 0.78557545744663 + 0.77913600819379 + 0.77277135850024 + 0.76646886352124 + 0.76021101383999 + 0.75397701491225 + 0.74774123025441 + 0.74141814859605 + 0.73476311391866 + 0.72764246293956 + 0.72003207887085 + 0.71190119316922 + 0.70325885067961 + 0.69412467708137 + 0.68452766064598 + 0.67450481231563 + 0.66409974319564 + 0.65335850078233 + 0.64228121161955 + 0.63091182511589 + 0.61929720259837 + 0.60748716085952 + 0.59553479757400 + 0.58349669248694 + 0.57140797356441 + 0.55929895454224 + 0.54721985687443 + 0.53521625364744 + 0.52332462973667 + 0.99970312985577 + 0.99972816748648 + 0.99973281596783 + 0.99973846098607 + 0.99974538674182 + 0.99975400221979 + 0.99976492907221 + 0.99977918530315 + 0.99979862410015 + 0.99982720208745 + 0.99987587816081 + 1.00000000000000 + 0.99986374869790 + 0.99979821989685 + 0.99975123656270 + 0.99971153633086 + 0.99967480010730 + 0.99963886263021 + 0.99960236969983 + 0.99956430923682 + 0.99952388469148 + 0.99948037233878 + 0.99943307004064 + 0.99938126512910 + 0.99932420202202 + 0.99926099610327 + 0.99919049244446 + 0.99911143919068 + 0.99902271837564 + 0.99892325989087 + 0.99881165545867 + 0.99868651253465 + 0.99854635279773 + 0.99838949265475 + 0.99821397164943 + 0.99801747076440 + 0.99779722451406 + 0.99754993025809 + 0.99727138721616 + 0.99695638344714 + 0.99659910382337 + 0.99619269219295 + 0.99572916917252 + 0.99519993414418 + 0.99459913367416 + 0.99392388264829 + 0.99316573181524 + 0.99231513580979 + 0.99136755858301 + 0.99031382585332 + 0.98913837413824 + 0.98782347102099 + 0.98634989743105 + 0.98469651363123 + 0.98283801267954 + 0.98074578305513 + 0.97838799193556 + 0.97572759951026 + 0.97272256648930 + 0.96932644466206 + 0.96548668404944 + 0.96113772738175 + 0.95620815041839 + 0.95063612170973 + 0.94436731088582 + 0.93734881643564 + 0.92953871011430 + 0.92090681899542 + 0.91143816617125 + 0.90113812292317 + 0.89003837851297 + 0.87820229719830 + 0.86572365726065 + 0.85271391813819 + 0.83931445500949 + 0.82571455379656 + 0.81211958366723 + 0.80537744029787 + 0.79869907498077 + 0.79209639493740 + 0.78557546315731 + 0.77913601354835 + 0.77277136351827 + 0.76646886822282 + 0.76021101824600 + 0.75397701904194 + 0.74774123412681 + 0.74141815222740 + 0.73476311731822 + 0.72764246611317 + 0.72003208182664 + 0.71190119591436 + 0.70325885322173 + 0.69412467942805 + 0.68452766280473 + 0.67450481429430 + 0.66409974500121 + 0.65335850242249 + 0.64228121310131 + 0.63091182644650 + 0.61929720378556 + 0.60748716191176 + 0.59553479849933 + 0.58349669329512 + 0.57140797426450 + 0.55929895514308 + 0.54721985738577 + 0.53521625407919 + 0.52332463009837 + 0.99968559240583 + 0.99970756152032 + 0.99971154871633 + 0.99971634751931 + 0.99972216694631 + 0.99972929486208 + 0.99973814466314 + 0.99974934440208 + 0.99976392635324 + 0.99978379515480 + 0.99981312113405 + 0.99986374869790 + 1.00000000000000 + 0.99985087256667 + 0.99978256805447 + 0.99973355681799 + 0.99969172587591 + 0.99965259388459 + 0.99961390516127 + 0.99957423271682 + 0.99953256521206 + 0.99948805614797 + 0.99943992851189 + 0.99938742171088 + 0.99932974813953 + 0.99926600066385 + 0.99919500776477 + 0.99911550632298 + 0.99902637163768 + 0.99892652963905 + 0.99881456917954 + 0.99868909659804 + 0.99854863331502 + 0.99839149573729 + 0.99821572332338 + 0.99801899666147 + 0.99779854946215 + 0.99755107783216 + 0.99727237925867 + 0.99695723981696 + 0.99659984240550 + 0.99619332885565 + 0.99572971781602 + 0.99520040685492 + 0.99459954100408 + 0.99392423374508 + 0.99316603442961 + 0.99231539657701 + 0.99136778329117 + 0.99031401953552 + 0.98913854116691 + 0.98782361520138 + 0.98635002207709 + 0.98469662162320 + 0.98283810650376 + 0.98074586485185 + 0.97838806354211 + 0.97572766249789 + 0.97272262218972 + 0.96932649419153 + 0.96548672834405 + 0.96113776720381 + 0.95620818638427 + 0.95063615432036 + 0.94436734054842 + 0.93734884348102 + 0.92953873480690 + 0.92090684154880 + 0.91143818676316 + 0.90113814169889 + 0.89003839559597 + 0.87820231269941 + 0.86572367127815 + 0.85271393076349 + 0.83931446632914 + 0.82571456390110 + 0.81211959264758 + 0.80537744875139 + 0.79869908293121 + 0.79209640240920 + 0.78557547017442 + 0.77913602013474 + 0.77277136969944 + 0.76646887402225 + 0.76021102368779 + 0.75397702414897 + 0.74774123892182 + 0.74141815672976 + 0.73476312153915 + 0.72764247005935 + 0.72003208550628 + 0.71190119933524 + 0.70325885639246 + 0.69412468235763 + 0.68452766550252 + 0.67450481676860 + 0.66409974726109 + 0.65335850447642 + 0.64228121495828 + 0.63091182811542 + 0.61929720527567 + 0.60748716323346 + 0.59553479966288 + 0.58349669431158 + 0.57140797514572 + 0.55929895590049 + 0.54721985803091 + 0.53521625462437 + 0.52332463055649 + 0.99966676245599 + 0.99968615417897 + 0.99968961017009 + 0.99969374093797 + 0.99969870609044 + 0.99970471780577 + 0.99971206729845 + 0.99972117168774 + 0.99973266533942 + 0.99974760370429 + 0.99976798562108 + 0.99979821989685 + 0.99985087256667 + 1.00000000000000 + 0.99983728729619 + 0.99976615390629 + 0.99971486599368 + 0.99967057085581 + 0.99962862490203 + 0.99958669266550 + 0.99954334962943 + 0.99949753411381 + 0.99944834645611 + 0.99939495152742 + 0.99933651395098 + 0.99927209421122 + 0.99920049761603 + 0.99912044553732 + 0.99903080399366 + 0.99893049339951 + 0.99881809866305 + 0.99869222448767 + 0.99855139180457 + 0.99839391689515 + 0.99821783903202 + 0.99802083827596 + 0.99780014731199 + 0.99755246068979 + 0.99727357376834 + 0.99695827017794 + 0.99660073040577 + 0.99619409380760 + 0.99573037662353 + 0.99520097420155 + 0.99460002970096 + 0.99392465489176 + 0.99316639740873 + 0.99231570939790 + 0.99136805293513 + 0.99031425205834 + 0.98913874180842 + 0.98782378851963 + 0.98635017203456 + 0.98469675166021 + 0.98283821958907 + 0.98074596354267 + 0.97838815003247 + 0.97572773865970 + 0.97272268961036 + 0.96932655420981 + 0.96548678207380 + 0.96113781555458 + 0.95620823008858 + 0.95063619397847 + 0.94436737664729 + 0.93734887641266 + 0.92953876488983 + 0.92090686904304 + 0.91143821187795 + 0.90113816461202 + 0.89003841645781 + 0.87820233164368 + 0.86572368842344 + 0.85271394622029 + 0.83931448020553 + 0.82571457630289 + 0.81211960369005 + 0.80537745915530 + 0.79869909272553 + 0.79209641162370 + 0.78557547883909 + 0.77913602827884 + 0.77277137735140 + 0.76646888121179 + 0.76021103044297 + 0.75397703049787 + 0.74774124489159 + 0.74141816234298 + 0.73476312680776 + 0.72764247499175 + 0.72003209011145 + 0.71190120362165 + 0.70325886037014 + 0.69412468603657 + 0.68452766889258 + 0.67450481988074 + 0.66409975010534 + 0.65335850706424 + 0.64228121729928 + 0.63091183022023 + 0.61929720715673 + 0.60748716490252 + 0.59553480113399 + 0.58349669559814 + 0.57140797626177 + 0.55929895686059 + 0.54721985885015 + 0.53521625531765 + 0.52332463113935 + 0.99964644019320 + 0.99966365000884 + 0.99966667289401 + 0.99967026666465 + 0.99967455723586 + 0.99967970734441 + 0.99968593248992 + 0.99969352744890 + 0.99970291464153 + 0.99971474592878 + 0.99973014382596 + 0.99975123656270 + 0.99978256805447 + 0.99983728729619 + 1.00000000000000 + 0.99982300065622 + 0.99974891488679 + 0.99969502969795 + 0.99964783487839 + 0.99960256192365 + 0.99955687765242 + 0.99950930613824 + 0.99945873234257 + 0.99940419874328 + 0.99934479558533 + 0.99927953506841 + 0.99920718921678 + 0.99912645752768 + 0.99903619292299 + 0.99893530799052 + 0.99882238212179 + 0.99869601757298 + 0.99855473439735 + 0.99839684853485 + 0.99822039890189 + 0.99802306481752 + 0.99780207764952 + 0.99755413001047 + 0.99727501461670 + 0.99695951209519 + 0.99660179996414 + 0.99619501455075 + 0.99573116913564 + 0.99520165634657 + 0.99460061705881 + 0.99392516095804 + 0.99316683355825 + 0.99231608531773 + 0.99136837706014 + 0.99031453168412 + 0.98913898323809 + 0.98782399721749 + 0.98635035274921 + 0.98469690850892 + 0.98283835612369 + 0.98074608281601 + 0.97838825467377 + 0.97572783090513 + 0.97272277135821 + 0.96932662705861 + 0.96548684735528 + 0.96113787435479 + 0.95620828328424 + 0.95063624228192 + 0.94436742064455 + 0.93734891657564 + 0.92953880160100 + 0.92090690260963 + 0.91143824255778 + 0.90113819261758 + 0.89003844197266 + 0.87820235482795 + 0.86572370942461 + 0.85271396517240 + 0.83931449723752 + 0.82571459154980 + 0.81211961728584 + 0.80537747197771 + 0.79869910480956 + 0.79209642300509 + 0.78557548955243 + 0.77913603836095 + 0.77277138683688 + 0.76646889013543 + 0.76021103883895 + 0.75397703839946 + 0.74774125233162 + 0.74141816934812 + 0.73476313339203 + 0.72764248116342 + 0.72003209588038 + 0.71190120899745 + 0.70325886536353 + 0.69412469065976 + 0.68452767315681 + 0.67450482379808 + 0.66409975368855 + 0.65335851032599 + 0.64228122025209 + 0.63091183287747 + 0.61929720953242 + 0.60748716701269 + 0.59553480299473 + 0.58349669722723 + 0.57140797767651 + 0.55929895807867 + 0.54721985989055 + 0.53521625619947 + 0.52332463188134 + 0.99962440762897 + 0.99963975721761 + 0.99964242231495 + 0.99964557757238 + 0.99964932513340 + 0.99965379410796 + 0.99965915074750 + 0.99966561448366 + 0.99967348586112 + 0.99968320400116 + 0.99969547939023 + 0.99971153633086 + 0.99973355681799 + 0.99976615390629 + 0.99982300065622 + 1.00000000000000 + 0.99980800482025 + 0.99973075778274 + 0.99967383405556 + 0.99962320144182 + 0.99957407140299 + 0.99952405633481 + 0.99947162604771 + 0.99941560767444 + 0.99935496917105 + 0.99928864763146 + 0.99921536558902 + 0.99913379079042 + 0.99904275722173 + 0.99894116610608 + 0.99882758895222 + 0.99870062431995 + 0.99855879073166 + 0.99840040340085 + 0.99822350059956 + 0.99802576059275 + 0.99780441303498 + 0.99755614809072 + 0.99727675519993 + 0.99696101127185 + 0.99660309018590 + 0.99619612453469 + 0.99573212397711 + 0.99520247780345 + 0.99460132410172 + 0.99392577000849 + 0.99316735842949 + 0.99231653774862 + 0.99136876725231 + 0.99031486845108 + 0.98913927416416 + 0.98782424887190 + 0.98635057082916 + 0.98469709795219 + 0.98283852118314 + 0.98074622715546 + 0.97838838143325 + 0.97572794276769 + 0.97272287059472 + 0.96932671558264 + 0.96548692675954 + 0.96113794593975 + 0.95620834809604 + 0.95063630117738 + 0.94436747432276 + 0.93734896560316 + 0.92953884643573 + 0.92090694362739 + 0.91143828006682 + 0.90113822687738 + 0.89003847320376 + 0.87820238322584 + 0.86572373516806 + 0.85271398842637 + 0.83931451816214 + 0.82571461030371 + 0.81211963403655 + 0.80537748779031 + 0.79869911972578 + 0.79209643706805 + 0.78557550280556 + 0.77913605084723 + 0.77277139859882 + 0.76646890121481 + 0.76021104927658 + 0.75397704823623 + 0.74774126160503 + 0.74141817809057 + 0.73476314161896 + 0.72764248888501 + 0.72003210310671 + 0.71190121573870 + 0.70325887163146 + 0.69412469646754 + 0.68452767851816 + 0.67450482872714 + 0.66409975820024 + 0.65335851443564 + 0.64228122397520 + 0.63091183622959 + 0.61929721253214 + 0.60748716967887 + 0.59553480534804 + 0.58349669928862 + 0.57140797946816 + 0.55929895962325 + 0.54721986121096 + 0.53521625732007 + 0.52332463282637 + 0.99960042113061 + 0.99961417405466 + 0.99961654007421 + 0.99961933221627 + 0.99962263532338 + 0.99962655478825 + 0.99963122339977 + 0.99963681168103 + 0.99964354534455 + 0.99965174147987 + 0.99966189305822 + 0.99967480010730 + 0.99969172587591 + 0.99971486599368 + 0.99974891488679 + 0.99980800482025 + 1.00000000000000 + 0.99979227800425 + 0.99971151032746 + 0.99965098781763 + 0.99959636026843 + 0.99954276781673 + 0.99948776620755 + 0.99942976681568 + 0.99936752216837 + 0.99929984606943 + 0.99922538429554 + 0.99914275691849 + 0.99905076972293 + 0.99894830703848 + 0.99883392885296 + 0.99870622806542 + 0.99856372057887 + 0.99840472023644 + 0.99822726417682 + 0.99802902913991 + 0.99780724250937 + 0.99755859134096 + 0.99727886097796 + 0.99696282372747 + 0.99660464897613 + 0.99619746473581 + 0.99573327620524 + 0.99520346858417 + 0.99460217655690 + 0.99392650414528 + 0.99316799104955 + 0.99231708309385 + 0.99136923768526 + 0.99031527463106 + 0.98913962524223 + 0.98782455275381 + 0.98635083436426 + 0.98469732706701 + 0.98283872098602 + 0.98074640204118 + 0.97838853517064 + 0.97572807857476 + 0.97272299119483 + 0.96932682326900 + 0.96548702344184 + 0.96113803317262 + 0.95620842713703 + 0.95063637304904 + 0.94436753986398 + 0.93734902549565 + 0.92953890123526 + 0.92090699378544 + 0.91143832595688 + 0.90113826881102 + 0.89003851145404 + 0.87820241803014 + 0.86572376674293 + 0.85271401697409 + 0.83931454387536 + 0.82571463338118 + 0.81211965468201 + 0.80537750729501 + 0.79869913814363 + 0.79209645445016 + 0.78557551920390 + 0.77913606631400 + 0.77277141318524 + 0.76646891497110 + 0.76021106225208 + 0.75397706047892 + 0.74774127316139 + 0.74141818899823 + 0.73476315189613 + 0.72764249854104 + 0.72003211215253 + 0.71190122418631 + 0.70325887949375 + 0.69412470375928 + 0.68452768525472 + 0.67450483492480 + 0.66409976387668 + 0.65335851960975 + 0.64228122866467 + 0.63091184045564 + 0.61929721631535 + 0.60748717304414 + 0.59553480832034 + 0.58349670189492 + 0.57140798173558 + 0.55929896157976 + 0.54721986288581 + 0.53521625874308 + 0.52332463402756 + 0.99957420764856 + 0.99958658094322 + 0.99958869420486 + 0.99959118183787 + 0.99959411572513 + 0.99959758396849 + 0.99960169572165 + 0.99960658825808 + 0.99961243867686 + 0.99961948887963 + 0.99962810567300 + 0.99963886263021 + 0.99965259388459 + 0.99967057085581 + 0.99969502969795 + 0.99973075778274 + 0.99979227800425 + 1.00000000000000 + 0.99977571329931 + 0.99969091948950 + 0.99962621332708 + 0.99956695125763 + 0.99950820791493 + 0.99944747853650 + 0.99938309928628 + 0.99931366712204 + 0.99923770227295 + 0.99915375018045 + 0.99906057320460 + 0.99895702983730 + 0.99884166284760 + 0.99871305630143 + 0.99856972172061 + 0.99840997046412 + 0.99823183774603 + 0.99803299804998 + 0.99781067571118 + 0.99756155378475 + 0.99728141246342 + 0.99696501833235 + 0.99660653522091 + 0.99619908549347 + 0.99573466887576 + 0.99520466553801 + 0.99460320600380 + 0.99392739049814 + 0.99316875476374 + 0.99231774147216 + 0.99136980574076 + 0.99031576527292 + 0.98914004953230 + 0.98782492022518 + 0.98635115326482 + 0.98469760453213 + 0.98283896315992 + 0.98074661420273 + 0.97838872185243 + 0.97572824363984 + 0.97272313791515 + 0.96932695439763 + 0.96548714127336 + 0.96113813957315 + 0.95620852360823 + 0.95063646082352 + 0.94436761995210 + 0.93734909871641 + 0.92953896825662 + 0.92090705515685 + 0.91143838212899 + 0.90113832016785 + 0.89003855832213 + 0.87820246070351 + 0.86572380548526 + 0.85271405203321 + 0.83931457548690 + 0.82571466178834 + 0.81211968013251 + 0.80537753135937 + 0.79869916088556 + 0.79209647593430 + 0.78557553949260 + 0.77913608547091 + 0.77277143127115 + 0.76646893204827 + 0.76021107837871 + 0.75397707571284 + 0.74774128755741 + 0.74141820260152 + 0.73476316472757 + 0.72764251061026 + 0.72003212347079 + 0.71190123476582 + 0.70325888934908 + 0.69412471290637 + 0.68452769371176 + 0.67450484271072 + 0.66409977101239 + 0.65335852611731 + 0.64228123456733 + 0.63091184577766 + 0.61929722108370 + 0.60748717728835 + 0.59553481207149 + 0.58349670518658 + 0.57140798460176 + 0.55929896405536 + 0.54721986500727 + 0.53521626054763 + 0.52332463555312 + 0.99954542982069 + 0.99955660197293 + 0.99955849922470 + 0.99956072826880 + 0.99956335101758 + 0.99956644257576 + 0.99957009480649 + 0.99957442141914 + 0.99957956633641 + 0.99958572223700 + 0.99959317680775 + 0.99960236969983 + 0.99961390516127 + 0.99962862490203 + 0.99964783487839 + 0.99967383405556 + 0.99971151032746 + 0.99977571329931 + 1.00000000000000 + 0.99975817932470 + 0.99966880047997 + 0.99959922132089 + 0.99953458846682 + 0.99946990908234 + 0.99940260059113 + 0.99933084116134 + 0.99925293092103 + 0.99916729213481 + 0.99907261749330 + 0.99896772467805 + 0.99885112999193 + 0.99872140352674 + 0.99857704946002 + 0.99841637484404 + 0.99823741165518 + 0.99803783100755 + 0.99781485306461 + 0.99756515567225 + 0.99728451249203 + 0.99696768294680 + 0.99660882395376 + 0.99620105090492 + 0.99573635675931 + 0.99520611550334 + 0.99460445255986 + 0.99392846351228 + 0.99316967920639 + 0.99231853843307 + 0.99137049349262 + 0.99031635950942 + 0.98914056365341 + 0.98782536576461 + 0.98635154018230 + 0.98469794143767 + 0.98283925745878 + 0.98074687226054 + 0.97838894913136 + 0.97572844479197 + 0.97272331688147 + 0.96932711449277 + 0.96548728525701 + 0.96113826968819 + 0.95620864166369 + 0.95063656829745 + 0.94436771806380 + 0.93734918845746 + 0.92953905043524 + 0.92090713043733 + 0.91143845106456 + 0.90113838322347 + 0.89003861589859 + 0.87820251315800 + 0.86572385314399 + 0.85271409519588 + 0.83931461444772 + 0.82571469684130 + 0.81211971158369 + 0.80537756112328 + 0.79869918903971 + 0.79209650255585 + 0.78557556465962 + 0.77913610925707 + 0.77277145375345 + 0.76646895329853 + 0.76021109846971 + 0.75397709471332 + 0.74774130553398 + 0.74141821960707 + 0.73476318078508 + 0.72764252572951 + 0.72003213766449 + 0.71190124804611 + 0.70325890173027 + 0.69412472440727 + 0.68452770435252 + 0.67450485251373 + 0.66409978000256 + 0.65335853432179 + 0.64228124201271 + 0.63091185249446 + 0.61929722710560 + 0.60748718265211 + 0.59553481681566 + 0.58349670935303 + 0.57140798823312 + 0.55929896719479 + 0.54721986770019 + 0.53521626284122 + 0.52332463749477 + 0.99951367975449 + 0.99952379748711 + 0.99952550802270 + 0.99952751470457 + 0.99952987158100 + 0.99953264369414 + 0.99953590983505 + 0.99953976637671 + 0.99954433357203 + 0.99954977014376 + 0.99955631082719 + 0.99956430923682 + 0.99957423271682 + 0.99958669266550 + 0.99960256192365 + 0.99962320144182 + 0.99965098781763 + 0.99969091948950 + 0.99975817932470 + 1.00000000000000 + 0.99973965726052 + 0.99964496842642 + 0.99956970586027 + 0.99949885254853 + 0.99942732787349 + 0.99935238558314 + 0.99927190184083 + 0.99918408112649 + 0.99908749846291 + 0.99898090449840 + 0.99886277352701 + 0.99873165304496 + 0.99858603494508 + 0.99842421889414 + 0.99824423150621 + 0.99804373878088 + 0.99781995507439 + 0.99756955134320 + 0.99728829287771 + 0.99697093004573 + 0.99661161113779 + 0.99620344285236 + 0.99573840977143 + 0.99520787822793 + 0.99460596737607 + 0.99392976708621 + 0.99317080214810 + 0.99231950653702 + 0.99137132909385 + 0.99031708174169 + 0.98914118882470 + 0.98782590787052 + 0.98635201129507 + 0.98469835198233 + 0.98283961639852 + 0.98074718729340 + 0.97838922685888 + 0.97572869083859 + 0.97272353600310 + 0.96932731069394 + 0.96548746186788 + 0.96113842941668 + 0.95620878668896 + 0.95063670040550 + 0.94436783872507 + 0.93734929887573 + 0.92953915159572 + 0.92090722314698 + 0.91143853599770 + 0.90113846094837 + 0.89003868690861 + 0.87820257789306 + 0.86572391200453 + 0.85271414855518 + 0.83931466266334 + 0.82571474027810 + 0.81211975061656 + 0.80537759809199 + 0.79869922404083 + 0.79209653568356 + 0.78557559600790 + 0.77913613891842 + 0.77277148181801 + 0.76646897985637 + 0.76021112360753 + 0.75397711851433 + 0.74774132807644 + 0.74141824095694 + 0.73476320096716 + 0.72764254475290 + 0.72003215554086 + 0.71190126478696 + 0.70325891735281 + 0.69412473893001 + 0.68452771779907 + 0.67450486491019 + 0.66409979137735 + 0.65335854470949 + 0.64228125144514 + 0.63091186100981 + 0.61929723474530 + 0.60748718946054 + 0.59553482284277 + 0.58349671464997 + 0.57140799285360 + 0.55929897119398 + 0.54721987113481 + 0.53521626576978 + 0.52332463997763 + 0.99947854121247 + 0.99948772634448 + 0.99948927382432 + 0.99949108714398 + 0.99949321399323 + 0.99949571142018 + 0.99949864802458 + 0.99950210697438 + 0.99950619097201 + 0.99951103419933 + 0.99951683393523 + 0.99952388469148 + 0.99953256521206 + 0.99954334962943 + 0.99955687765242 + 0.99957407140299 + 0.99959636026843 + 0.99962621332708 + 0.99966880047997 + 0.99973965726052 + 1.00000000000000 + 0.99972001897700 + 0.99961914145160 + 0.99953726047264 + 0.99945920250532 + 0.99937970819508 + 0.99929572033648 + 0.99920502131529 + 0.99910597404447 + 0.99899721366755 + 0.99887714525349 + 0.99874427883734 + 0.99859708556546 + 0.99843385251890 + 0.99825259741317 + 0.99805097838578 + 0.99782620153331 + 0.99757492855989 + 0.99729291388819 + 0.99697489637690 + 0.99661501342743 + 0.99620636088839 + 0.99574091291359 + 0.99521002635139 + 0.99460781262511 + 0.99393135457065 + 0.99317216946577 + 0.99232068531664 + 0.99137234669176 + 0.99031796156186 + 0.98914195075002 + 0.98782656893916 + 0.98635258617728 + 0.98469885333165 + 0.98284005508863 + 0.98074757265877 + 0.97838956690219 + 0.97572899237211 + 0.97272380479080 + 0.96932755157782 + 0.96548767888005 + 0.96113862583016 + 0.95620896513591 + 0.95063686304643 + 0.94436798734576 + 0.93734943493695 + 0.92953927629577 + 0.92090733747608 + 0.91143864077810 + 0.90113855688195 + 0.89003877460142 + 0.87820265788571 + 0.86572398479134 + 0.85271421459423 + 0.83931472239841 + 0.82571479415917 + 0.81211979910437 + 0.80537764405342 + 0.79869926759321 + 0.79209657694383 + 0.78557563508862 + 0.77913617593350 + 0.77277151687913 + 0.76646901307112 + 0.76021115507931 + 0.75397714834560 + 0.74774135636211 + 0.74141826777390 + 0.73476322634367 + 0.72764256869617 + 0.72003217806270 + 0.71190128589729 + 0.70325893706891 + 0.69412475727301 + 0.68452773479409 + 0.67450488058836 + 0.66409980577296 + 0.65335855786289 + 0.64228126339702 + 0.63091187180546 + 0.61929724443659 + 0.60748719810404 + 0.59553483049937 + 0.58349672138550 + 0.57140799873410 + 0.55929897628859 + 0.54721987551505 + 0.53521626950958 + 0.52332464315179 + 0.99943954686618 + 0.99944790076023 + 0.99944930440778 + 0.99945094774417 + 0.99945287320041 + 0.99945513130679 + 0.99945778249877 + 0.99946089955282 + 0.99946457165906 + 0.99946891451120 + 0.99947409756791 + 0.99948037233878 + 0.99948805614797 + 0.99949753411381 + 0.99950930613824 + 0.99952405633481 + 0.99954276781673 + 0.99956695125763 + 0.99959922132089 + 0.99964496842642 + 0.99972001897700 + 1.00000000000000 + 0.99969910174616 + 0.99959098789580 + 0.99950139647244 + 0.99941491220699 + 0.99932594467624 + 0.99923134281745 + 0.99912905206079 + 0.99901749589603 + 0.99889495981013 + 0.99875988980995 + 0.99861072145805 + 0.99844572031455 + 0.99826288928111 + 0.99805987421095 + 0.99783386922900 + 0.99758152336018 + 0.99729857675146 + 0.99697975344051 + 0.99661917702397 + 0.99620992970200 + 0.99574397259971 + 0.99521265077514 + 0.99461006608220 + 0.99393329268391 + 0.99317383851991 + 0.99232212418003 + 0.99137358896557 + 0.99031903593404 + 0.98914288154440 + 0.98782737694187 + 0.98635328926979 + 0.98469946692130 + 0.98284059239985 + 0.98074804504540 + 0.97838998408750 + 0.97572936263597 + 0.97272413512611 + 0.96932784786732 + 0.96548794600966 + 0.96113886776499 + 0.95620918506583 + 0.95063706359592 + 0.94436817068464 + 0.93734960284250 + 0.92953943023230 + 0.92090747865791 + 0.91143877021767 + 0.90113867544004 + 0.89003888302766 + 0.87820275684560 + 0.86572407490063 + 0.85271429641936 + 0.83931479648602 + 0.82571486106380 + 0.81211985939605 + 0.80537770124940 + 0.79869932183666 + 0.79209662837540 + 0.78557568385058 + 0.77913622216367 + 0.77277156071132 + 0.76646905463711 + 0.76021119450692 + 0.75397718575590 + 0.74774139187099 + 0.74141830147297 + 0.73476325826385 + 0.72764259884271 + 0.72003220644508 + 0.71190131252444 + 0.70325896195703 + 0.69412478044436 + 0.68452775627813 + 0.67450490041835 + 0.66409982399203 + 0.65335857451941 + 0.64228127854026 + 0.63091188549201 + 0.61929725673033 + 0.60748720907613 + 0.59553484022591 + 0.58349672994791 + 0.57140800621659 + 0.55929898277761 + 0.54721988109973 + 0.53521627428348 + 0.52332464720943 + 0.99939617394043 + 0.99940378113146 + 0.99940505665390 + 0.99940654898158 + 0.99940829610655 + 0.99941034312290 + 0.99941274373440 + 0.99941556230144 + 0.99941887725741 + 0.99942278981760 + 0.99942744786435 + 0.99943307004064 + 0.99943992851189 + 0.99944834645611 + 0.99945873234257 + 0.99947162604771 + 0.99948776620755 + 0.99950820791493 + 0.99953458846682 + 0.99956970586027 + 0.99961914145160 + 0.99969910174616 + 1.00000000000000 + 0.99967670100348 + 0.99956009875612 + 0.99946143350323 + 0.99936489047796 + 0.99926477666475 + 0.99915810425341 + 0.99904287508031 + 0.99891715523906 + 0.99877927675169 + 0.99862761274012 + 0.99846039155329 + 0.99827559120634 + 0.99807083806539 + 0.99784330850690 + 0.99758963385410 + 0.99730553516423 + 0.99698571720191 + 0.99662428585296 + 0.99621430604306 + 0.99574772253729 + 0.99521586565298 + 0.99461282538144 + 0.99393566514111 + 0.99317588125616 + 0.99232388508626 + 0.99137510941684 + 0.99032035119392 + 0.98914402144713 + 0.98782836693347 + 0.98635415120133 + 0.98470021960730 + 0.98284125197762 + 0.98074862535684 + 0.97839049699354 + 0.97572981821629 + 0.97272454189844 + 0.96932821298502 + 0.96548827541908 + 0.96113916628600 + 0.95620945657409 + 0.95063731128016 + 0.94436839718900 + 0.93734981034464 + 0.92953962052788 + 0.92090765323307 + 0.91143893032456 + 0.90113882214011 + 0.89003901724699 + 0.87820287941376 + 0.86572418657644 + 0.85271439790974 + 0.83931488846603 + 0.82571494422066 + 0.81211993443161 + 0.80537777248446 + 0.79869938944755 + 0.79209669253693 + 0.78557574473399 + 0.77913627993895 + 0.77277161554389 + 0.76646910668471 + 0.76021124392539 + 0.75397723269310 + 0.74774143646537 + 0.74141834383559 + 0.73476329842783 + 0.72764263680990 + 0.72003224222066 + 0.71190134611482 + 0.70325899337707 + 0.69412480971867 + 0.68452778343642 + 0.67450492550204 + 0.66409984705037 + 0.65335859561129 + 0.64228129772659 + 0.63091190284307 + 0.61929727232487 + 0.60748722300263 + 0.59553485258075 + 0.58349674083198 + 0.57140801573596 + 0.55929899104037 + 0.54721988821946 + 0.53521628037672 + 0.52332465239540 + 0.99934783904767 + 0.99935477016678 + 0.99935593045997 + 0.99935728727283 + 0.99935887477815 + 0.99936073342730 + 0.99936291125137 + 0.99936546560392 + 0.99936846608369 + 0.99937200216802 + 0.99937620436889 + 0.99938126512910 + 0.99938742171088 + 0.99939495152742 + 0.99940419874328 + 0.99941560767444 + 0.99942976681568 + 0.99944747853650 + 0.99946990908234 + 0.99949885254853 + 0.99953726047264 + 0.99959098789580 + 0.99967670100348 + 1.00000000000000 + 0.99965254256180 + 0.99952586682218 + 0.99941630600699 + 0.99930788549092 + 0.99919506052842 + 0.99907488399892 + 0.99894498504621 + 0.99880348145462 + 0.99864863302182 + 0.99847860245936 + 0.99829132539394 + 0.99808439668480 + 0.99785496581868 + 0.99759963881857 + 0.99731411078167 + 0.99699306100794 + 0.99663057242424 + 0.99621968788469 + 0.99575233146547 + 0.99521981497902 + 0.99461621361466 + 0.99393857744950 + 0.99317838830819 + 0.99232604606095 + 0.99137697539641 + 0.99032196566057 + 0.98914542109542 + 0.98782958301049 + 0.98635521049722 + 0.98470114516570 + 0.98284206355328 + 0.98074933988477 + 0.97839112897087 + 0.97573037996456 + 0.97272504381816 + 0.96932866380661 + 0.96548868239726 + 0.96113953529586 + 0.95620979233365 + 0.95063761768165 + 0.94436867746873 + 0.93735006716869 + 0.92953985610555 + 0.92090786939956 + 0.91143912862418 + 0.90113900389269 + 0.89003918360169 + 0.87820303140190 + 0.86572432514230 + 0.85271452392627 + 0.83931500277588 + 0.82571504767515 + 0.81212002790170 + 0.80537786128133 + 0.79869947379069 + 0.79209677264080 + 0.78557582080981 + 0.77913635219312 + 0.77277168417820 + 0.76646917189655 + 0.76021130589969 + 0.75397729161081 + 0.74774149249509 + 0.74141839710975 + 0.73476334898169 + 0.72764268464011 + 0.72003228732675 + 0.71190138849849 + 0.70325903305127 + 0.69412484670639 + 0.68452781777332 + 0.67450495723252 + 0.66409987623465 + 0.65335862232106 + 0.64228132203511 + 0.63091192483772 + 0.61929729210531 + 0.60748724067815 + 0.59553486827113 + 0.58349675466583 + 0.57140802784537 + 0.55929900156154 + 0.54721989729434 + 0.53521628815184 + 0.52332465902123 + 0.99929388259113 + 0.99930019666311 + 0.99930125235059 + 0.99930248635292 + 0.99930392949526 + 0.99930561819177 + 0.99930759558229 + 0.99930991303938 + 0.99931263271188 + 0.99931583427070 + 0.99931963377804 + 0.99932420202202 + 0.99932974813953 + 0.99933651395098 + 0.99934479558533 + 0.99935496917105 + 0.99936752216837 + 0.99938309928628 + 0.99940260059113 + 0.99942732787349 + 0.99945920250532 + 0.99950139647244 + 0.99956009875612 + 0.99965254256180 + 1.00000000000000 + 0.99962615715451 + 0.99948728377973 + 0.99936479564835 + 0.99924278087300 + 0.99911568997068 + 0.99898017120118 + 0.99883390772692 + 0.99867494337389 + 0.99850132146375 + 0.99831090379624 + 0.99810123318812 + 0.99786941735275 + 0.99761202527489 + 0.99732471597466 + 0.99700213453491 + 0.99663833367174 + 0.99622632773232 + 0.99575801439663 + 0.99522468208160 + 0.99462038740256 + 0.99394216378383 + 0.99318147490493 + 0.99232870626753 + 0.99137927248721 + 0.99032395341945 + 0.98914714481577 + 0.98783108118681 + 0.98635651609261 + 0.98470228650160 + 0.98284306489465 + 0.98075022201986 + 0.97839190968952 + 0.97573107437350 + 0.97272566466248 + 0.96932922177892 + 0.96548918637116 + 0.96113999245281 + 0.95621020844585 + 0.95063799751162 + 0.94436902498983 + 0.93735038566008 + 0.92954014829185 + 0.92090813755843 + 0.91143937466792 + 0.90113922946263 + 0.89003939013180 + 0.87820322017667 + 0.86572449734115 + 0.85271468063866 + 0.83931514505004 + 0.82571517656930 + 0.81212014449423 + 0.80537797212106 + 0.79869957914518 + 0.79209687277545 + 0.78557591598620 + 0.77913644266435 + 0.77277177019118 + 0.76646925369046 + 0.76021138370496 + 0.75397736564433 + 0.74774156296236 + 0.74141846416923 + 0.73476341267153 + 0.72764274494691 + 0.72003234424426 + 0.71190144202141 + 0.70325908318626 + 0.69412489347545 + 0.68452786121450 + 0.67450499739986 + 0.66409991319754 + 0.65335865616643 + 0.64228135285377 + 0.63091195273751 + 0.61929731720932 + 0.60748726312573 + 0.59553488821037 + 0.58349677225888 + 0.57140804325791 + 0.55929901496442 + 0.54721990886655 + 0.53521629807854 + 0.52332466749090 + 0.99923349439757 + 0.99923924043330 + 0.99924020023096 + 0.99924132180801 + 0.99924263300399 + 0.99924416665833 + 0.99924596161017 + 0.99924806401197 + 0.99925052956617 + 0.99925342953370 + 0.99925686760132 + 0.99926099610327 + 0.99926600066385 + 0.99927209421122 + 0.99927953506841 + 0.99928864763146 + 0.99929984606943 + 0.99931366712204 + 0.99933084116134 + 0.99935238558314 + 0.99937970819508 + 0.99941491220699 + 0.99946143350323 + 0.99952586682218 + 0.99962615715451 + 1.00000000000000 + 0.99959674135678 + 0.99944328383719 + 0.99930591424780 + 0.99916856451149 + 0.99902520731905 + 0.99887253669924 + 0.99870815381102 + 0.99852987430361 + 0.99833542707906 + 0.99812226647869 + 0.99788743344237 + 0.99762744116563 + 0.99733789723038 + 0.99701339974445 + 0.99664796092146 + 0.99623455771849 + 0.99576505372634 + 0.99523070747090 + 0.99462555204889 + 0.99394659993263 + 0.99318529196380 + 0.99233199558503 + 0.99138211280943 + 0.99032641158028 + 0.98914927698566 + 0.98783293501337 + 0.98635813230536 + 0.98470370007524 + 0.98284430576363 + 0.98075131582064 + 0.97839287834496 + 0.97573193649080 + 0.97272643592768 + 0.96932991533349 + 0.96548981312748 + 0.96114056123011 + 0.95621072632956 + 0.95063847035797 + 0.94436945769371 + 0.93735078227874 + 0.92954051220289 + 0.92090847159164 + 0.91143968121449 + 0.90113951057327 + 0.89003964760090 + 0.87820345561343 + 0.86572471222173 + 0.85271487633119 + 0.83931532286221 + 0.82571533782377 + 0.81212029053614 + 0.80537811104739 + 0.79869971129224 + 0.79209699847105 + 0.78557603555221 + 0.77913655641522 + 0.77277187843089 + 0.76646935671036 + 0.76021148178847 + 0.75397745905578 + 0.74774165195251 + 0.74141854892904 + 0.73476349323885 + 0.72764282129796 + 0.72003241636008 + 0.71190150988359 + 0.70325914679656 + 0.69412495285403 + 0.68452791639993 + 0.67450504845378 + 0.66409996020221 + 0.65335869922857 + 0.64228139208456 + 0.63091198827217 + 0.61929734920173 + 0.60748729174827 + 0.59553491365310 + 0.58349679472384 + 0.57140806295488 + 0.55929903210996 + 0.54721992368582 + 0.53521631080524 + 0.52332467836363 + 0.99916557945862 + 0.99917079762726 + 0.99917166861258 + 0.99917268617347 + 0.99917387544335 + 0.99917526604108 + 0.99917689294600 + 0.99917879766267 + 0.99918103019674 + 0.99918365440588 + 0.99918676309741 + 0.99919049244446 + 0.99919500776477 + 0.99920049761603 + 0.99920718921678 + 0.99921536558902 + 0.99922538429554 + 0.99923770227295 + 0.99925293092103 + 0.99927190184083 + 0.99929572033648 + 0.99932594467624 + 0.99936489047796 + 0.99941630600699 + 0.99948728377973 + 0.99959674135678 + 1.00000000000000 + 0.99956371579216 + 0.99939326086817 + 0.99923893538407 + 0.99908397254724 + 0.99892234121397 + 0.99875062579919 + 0.99856617473891 + 0.99836646524386 + 0.99814879513166 + 0.99791009460104 + 0.99764678983247 + 0.99735441269171 + 0.99702749493835 + 0.99665999311486 + 0.99624483407312 + 0.99577383656766 + 0.99523822032543 + 0.99463198823986 + 0.99395212611587 + 0.99319004573007 + 0.99233609159231 + 0.99138564982346 + 0.99032947328048 + 0.98915193352387 + 0.98783524575968 + 0.98636014794035 + 0.98470546405584 + 0.98284585526106 + 0.98075268265085 + 0.97839408969732 + 0.97573301542933 + 0.97272740187937 + 0.96933078456638 + 0.96549059913933 + 0.96114127491533 + 0.95621137643892 + 0.95063906413813 + 0.94437000121775 + 0.93735128059357 + 0.92954096952698 + 0.92090889146876 + 0.91144006664769 + 0.90113986414295 + 0.89003997157316 + 0.87820375202143 + 0.86572498292986 + 0.85271512306491 + 0.83931554726966 + 0.82571554156699 + 0.81212047530110 + 0.80537828694260 + 0.79869987873431 + 0.79209715787037 + 0.78557618731045 + 0.77913670092123 + 0.77277201606319 + 0.76646948783107 + 0.76021160674298 + 0.75397757817323 + 0.74774176553700 + 0.74141865721392 + 0.73476359626022 + 0.72764291901294 + 0.72003250873113 + 0.71190159687706 + 0.70325922839758 + 0.69412502907714 + 0.68452798728428 + 0.67450511406795 + 0.66410002064635 + 0.65335875463251 + 0.64228144258783 + 0.63091203404245 + 0.61929739043420 + 0.60748732866302 + 0.59553494648948 + 0.58349682374113 + 0.57140808842121 + 0.55929905429964 + 0.54721994288726 + 0.53521632731719 + 0.52332469248957 + 0.99908892790658 + 0.99909365204628 + 0.99909444012897 + 0.99909536067300 + 0.99909643633191 + 0.99909769378007 + 0.99909916448397 + 0.99910088574337 + 0.99910290242867 + 0.99910527175861 + 0.99910807678415 + 0.99911143919068 + 0.99911550632298 + 0.99912044553732 + 0.99912645752768 + 0.99913379079042 + 0.99914275691849 + 0.99915375018045 + 0.99916729213481 + 0.99918408112649 + 0.99920502131529 + 0.99923134281745 + 0.99926477666475 + 0.99930788549092 + 0.99936479564835 + 0.99944328383719 + 0.99956371579216 + 1.00000000000000 + 0.99952685241931 + 0.99933671721261 + 0.99916269788086 + 0.99898779766110 + 0.99880578262245 + 0.99861292794938 + 0.99840619770593 + 0.99818259738213 + 0.99793886503853 + 0.99767128552283 + 0.99737527507629 + 0.99704526866383 + 0.99667514410713 + 0.99625775945130 + 0.99578487324736 + 0.99524765395651 + 0.99464006507098 + 0.99395905800091 + 0.99319600712460 + 0.99234122754162 + 0.99139008513021 + 0.99033331348340 + 0.98915526684941 + 0.98783814669467 + 0.98636267994875 + 0.98470768149082 + 0.98284780457152 + 0.98075440356206 + 0.97839561615530 + 0.97573437619995 + 0.97272862117434 + 0.96933188265736 + 0.96549159281933 + 0.96114217773415 + 0.95621219926841 + 0.95063981599952 + 0.94437068968980 + 0.93735191200014 + 0.92954154916929 + 0.92090942381255 + 0.91144055549395 + 0.90114031276705 + 0.89004038285043 + 0.87820412853684 + 0.86572532705921 + 0.85271543699382 + 0.83931583309338 + 0.82571580139168 + 0.81212071126104 + 0.80537851175042 + 0.79870009291528 + 0.79209736194133 + 0.78557638177355 + 0.77913688626786 + 0.77277219276225 + 0.76646965633616 + 0.76021176748392 + 0.75397773155634 + 0.74774191193946 + 0.74141879691711 + 0.73476372929893 + 0.72764304531123 + 0.72003262822604 + 0.71190170950323 + 0.70325933412431 + 0.69412512790387 + 0.68452807924916 + 0.67450519924653 + 0.66410009915712 + 0.65335882663825 + 0.64228150826137 + 0.63091209359673 + 0.61929744411828 + 0.60748737675908 + 0.59553498930605 + 0.58349686161115 + 0.57140812168855 + 0.55929908331822 + 0.54721996802972 + 0.53521634896703 + 0.52332471103890 + 0.99900244596047 + 0.99900670649872 + 0.99900741694009 + 0.99900824668238 + 0.99900921608689 + 0.99901034911422 + 0.99901167401067 + 0.99901322422146 + 0.99901503994614 + 0.99901717236727 + 0.99901969566827 + 0.99902271837564 + 0.99902637163768 + 0.99903080399366 + 0.99903619292299 + 0.99904275722173 + 0.99905076972293 + 0.99906057320460 + 0.99907261749330 + 0.99908749846291 + 0.99910597404447 + 0.99912905206079 + 0.99915810425341 + 0.99919506052842 + 0.99924278087300 + 0.99930591424780 + 0.99939326086817 + 0.99952685241931 + 1.00000000000000 + 0.99948570821712 + 0.99927238827766 + 0.99907587018166 + 0.99887860813389 + 0.99867391408976 + 0.99845758511142 + 0.99822603952560 + 0.99797566321409 + 0.99770250063834 + 0.99740178427514 + 0.99706780295863 + 0.99669431980121 + 0.99627409597626 + 0.99579880751595 + 0.99525955398579 + 0.99465024668993 + 0.99396779211887 + 0.99320351612923 + 0.99234769585925 + 0.99139567122803 + 0.99033815109100 + 0.98915946745113 + 0.98784180417158 + 0.98636587413883 + 0.98471048068814 + 0.98285026707694 + 0.98075657921788 + 0.97839754752020 + 0.97573609932300 + 0.97273016637209 + 0.96933327529256 + 0.96549285389413 + 0.96114332416677 + 0.95621324462978 + 0.95064077156604 + 0.94437156497358 + 0.93735271495503 + 0.92954228648614 + 0.92091010115521 + 0.91144117768907 + 0.90114088398936 + 0.89004090676943 + 0.87820460846045 + 0.86572576601277 + 0.85271583777431 + 0.83931619836164 + 0.82571613382717 + 0.81212101357136 + 0.80537879998785 + 0.79870036774615 + 0.79209762401624 + 0.78557663172803 + 0.77913712471566 + 0.77277242029668 + 0.76646987352211 + 0.76021197485771 + 0.75397792962288 + 0.74774210116707 + 0.74141897764808 + 0.73476390155928 + 0.72764320898517 + 0.72003278320884 + 0.71190185569129 + 0.70325947145432 + 0.69412525635622 + 0.68452819885515 + 0.67450531009025 + 0.66410020138144 + 0.65335892044250 + 0.64228159386222 + 0.63091217126615 + 0.61929751417519 + 0.60748743956599 + 0.59553504526127 + 0.58349691114284 + 0.57140816524291 + 0.55929912135283 + 0.54722000102326 + 0.53521637741657 + 0.52332473545175 + 0.99890507691708 + 0.99890890262157 + 0.99890954035158 + 0.99891028509751 + 0.99891115509814 + 0.99891217180253 + 0.99891336048375 + 0.99891475104738 + 0.99891637940638 + 0.99891829122176 + 0.99892055255874 + 0.99892325989087 + 0.99892652963905 + 0.99893049339951 + 0.99893530799052 + 0.99894116610608 + 0.99894830703848 + 0.99895702983730 + 0.99896772467805 + 0.99898090449840 + 0.99899721366755 + 0.99901749589603 + 0.99904287508031 + 0.99907488399892 + 0.99911568997068 + 0.99916856451149 + 0.99923893538407 + 0.99933671721261 + 0.99948570821712 + 1.00000000000000 + 0.99943904127828 + 0.99919890664140 + 0.99897695491799 + 0.99875472393994 + 0.99852483330261 + 0.99828238933704 + 0.99802308374446 + 0.99774252860269 + 0.99743565042803 + 0.99709650863004 + 0.99671869346184 + 0.99629482583455 + 0.99581646602631 + 0.99527461922786 + 0.99466312641421 + 0.99397883461081 + 0.99321300620335 + 0.99235586898389 + 0.99140272939722 + 0.99034426439364 + 0.98916477727840 + 0.98784642929598 + 0.98636991537875 + 0.98471402416922 + 0.98285338626546 + 0.98075933687156 + 0.97839999720706 + 0.97573828638468 + 0.97273212891658 + 0.96933504517177 + 0.96549445746997 + 0.96114478264762 + 0.95621457502082 + 0.95064198802304 + 0.94437267947170 + 0.93735373753677 + 0.92954322563985 + 0.92091096408126 + 0.91144197054551 + 0.90114161211372 + 0.89004157486426 + 0.87820522075992 + 0.86572632639754 + 0.85271634981625 + 0.83931666546307 + 0.82571655939796 + 0.81212140105922 + 0.80537916968986 + 0.79870072050517 + 0.79209796065896 + 0.78557695305584 + 0.77913743150278 + 0.77277271328701 + 0.76647015342634 + 0.76021224234655 + 0.75397818532701 + 0.74774234566527 + 0.74141921136312 + 0.73476412449958 + 0.72764342097746 + 0.72003298409505 + 0.71190204531082 + 0.70325964970120 + 0.69412542318236 + 0.68452835427719 + 0.67450545420158 + 0.66410033435221 + 0.65335904251960 + 0.64228170532125 + 0.63091227245133 + 0.61929760549697 + 0.60748752148776 + 0.59553511829796 + 0.58349697584853 + 0.57140822219119 + 0.55929917113482 + 0.54722004425803 + 0.53521641474584 + 0.52332476752870 + 0.99879542253157 + 0.99879884085759 + 0.99879941054601 + 0.99880007578622 + 0.99880085284244 + 0.99880176083853 + 0.99880282229994 + 0.99880406386198 + 0.99880551748801 + 0.99880722377250 + 0.99880924130021 + 0.99881165545867 + 0.99881456917954 + 0.99881809866305 + 0.99882238212179 + 0.99882758895222 + 0.99883392885296 + 0.99884166284760 + 0.99885112999193 + 0.99886277352701 + 0.99887714525349 + 0.99889495981013 + 0.99891715523906 + 0.99894498504621 + 0.99898017120118 + 0.99902520731905 + 0.99908397254724 + 0.99916269788086 + 0.99927238827766 + 0.99943904127828 + 1.00000000000000 + 0.99938615832760 + 0.99911519702570 + 0.99886457777414 + 0.99861449730069 + 0.99835655776478 + 0.99808492697701 + 0.99779437788301 + 0.99747929608883 + 0.99713336244830 + 0.99674989546840 + 0.99632130543156 + 0.99583898516933 + 0.99529380717301 + 0.99467951535614 + 0.99399287644414 + 0.99322506867210 + 0.99236625493580 + 0.99141169803190 + 0.99035203341528 + 0.98917152710467 + 0.98785231108313 + 0.98637505716555 + 0.98471853518886 + 0.98285735959898 + 0.98076285198736 + 0.97840312189479 + 0.97574107799633 + 0.97273463561602 + 0.96933730719076 + 0.96549650807464 + 0.96114664857494 + 0.95621627769121 + 0.95064354530797 + 0.94437410652938 + 0.93735504713108 + 0.92954442858992 + 0.92091206959438 + 0.91144298653005 + 0.90114254543280 + 0.89004243157690 + 0.87820600631966 + 0.86572704580844 + 0.85271700766732 + 0.83931726612049 + 0.82571710723168 + 0.81212190047668 + 0.80537964650331 + 0.79870117578898 + 0.79209839546218 + 0.78557736839763 + 0.77913782836508 + 0.77277309261183 + 0.76647051610951 + 0.76021258923175 + 0.75397851720295 + 0.74774266325652 + 0.74141951519016 + 0.73476441454525 + 0.72764369698863 + 0.72003324583455 + 0.71190229253929 + 0.70325988224704 + 0.69412564095420 + 0.68452855727453 + 0.67450564252108 + 0.66410050819798 + 0.65335920220092 + 0.64228185118622 + 0.63091240494065 + 0.61929772513788 + 0.60748762888305 + 0.59553521411229 + 0.58349706080168 + 0.57140829702926 + 0.55929923662372 + 0.54722010120080 + 0.53521646397524 + 0.52332480989279 + 0.99867209261841 + 0.99867513108380 + 0.99867563738617 + 0.99867622857937 + 0.99867691910082 + 0.99867772592631 + 0.99867866903898 + 0.99867977206642 + 0.99868106333707 + 0.99868257878437 + 0.99868437012084 + 0.99868651253465 + 0.99868909659804 + 0.99869222448767 + 0.99869601757298 + 0.99870062431995 + 0.99870622806542 + 0.99871305630143 + 0.99872140352674 + 0.99873165304496 + 0.99874427883734 + 0.99875988980995 + 0.99877927675169 + 0.99880348145462 + 0.99883390772692 + 0.99887253669924 + 0.99892234121397 + 0.99898779766110 + 0.99907587018166 + 0.99919890664140 + 0.99938615832760 + 1.00000000000000 + 0.99932614762641 + 0.99901988523763 + 0.99873706373317 + 0.99845593188677 + 0.99816667830881 + 0.99786226412546 + 0.99753604226537 + 0.99718103029703 + 0.99679009788665 + 0.99635532560522 + 0.99586785542417 + 0.99531836764989 + 0.99470046862714 + 0.99401081420925 + 0.99324046939149 + 0.99237951072668 + 0.99142314344660 + 0.99036194859542 + 0.98918014345028 + 0.98785982190746 + 0.98638162586347 + 0.98472430095225 + 0.98286244091538 + 0.98076734993793 + 0.97840712267931 + 0.97574465448683 + 0.97273784896561 + 0.96934020844651 + 0.96549913942177 + 0.96114904386778 + 0.95621846404597 + 0.95064554538263 + 0.94437593961416 + 0.93735672951539 + 0.92954597413201 + 0.92091349013523 + 0.91144429225578 + 0.90114374521512 + 0.89004353325437 + 0.87820701695522 + 0.86572797186612 + 0.85271785508124 + 0.83931804050670 + 0.82571781421034 + 0.81212254570207 + 0.80538026290574 + 0.79870176474459 + 0.79209895830917 + 0.78557790643632 + 0.77913834284593 + 0.77277358472951 + 0.76647098699642 + 0.76021303995385 + 0.75397894875541 + 0.74774307654693 + 0.74141991086238 + 0.73476479254082 + 0.72764405694663 + 0.72003358740742 + 0.71190261537768 + 0.70326018609062 + 0.69412592564844 + 0.68452882278645 + 0.67450588894987 + 0.66410073578966 + 0.65335941134459 + 0.64228204232082 + 0.63091257863397 + 0.61929788207152 + 0.60748776983819 + 0.59553533995417 + 0.58349717246540 + 0.57140839548364 + 0.55929932286710 + 0.54722017627657 + 0.53521652896453 + 0.52332486589539 + 0.99853360766893 + 0.99853629444860 + 0.99853674210712 + 0.99853726480521 + 0.99853787530465 + 0.99853858859824 + 0.99853942233867 + 0.99854039738665 + 0.99854153874769 + 0.99854287808355 + 0.99854446081416 + 0.99854635279773 + 0.99854863331502 + 0.99855139180457 + 0.99855473439735 + 0.99855879073166 + 0.99856372057887 + 0.99856972172061 + 0.99857704946002 + 0.99858603494508 + 0.99859708556546 + 0.99861072145805 + 0.99862761274012 + 0.99864863302182 + 0.99867494337389 + 0.99870815381102 + 0.99875062579919 + 0.99880578262245 + 0.99887860813389 + 0.99897695491799 + 0.99911519702570 + 0.99932614762641 + 1.00000000000000 + 0.99925784830501 + 0.99891135424488 + 0.99859245968800 + 0.99827667518345 + 0.99795232981522 + 0.99761058295879 + 0.99724319672137 + 0.99684225339686 + 0.99639929122387 + 0.99590506049346 + 0.99534995332228 + 0.99472737494010 + 0.99403382404452 + 0.99326021059154 + 0.99239649461310 + 0.99143780441456 + 0.99037464905501 + 0.98919118165539 + 0.98786944625823 + 0.98639004582043 + 0.98473169465991 + 0.98286895984093 + 0.98077312321914 + 0.97841226037217 + 0.97574924957740 + 0.97274197943429 + 0.96934393933928 + 0.96550252444945 + 0.96115212608983 + 0.95622127792836 + 0.95064811979383 + 0.94437829919791 + 0.93735889515222 + 0.92954796364899 + 0.92091531881688 + 0.91144597329210 + 0.90114529010883 + 0.89004495218950 + 0.87820831910676 + 0.86572916562372 + 0.85271894812294 + 0.83931904009310 + 0.82571872758572 + 0.81212338013935 + 0.80538106051236 + 0.79870252728244 + 0.79209968749757 + 0.78557860393295 + 0.77913901024655 + 0.77277422355648 + 0.76647159868875 + 0.76021362586258 + 0.75397951013495 + 0.74774361453819 + 0.74142042626170 + 0.73476528524207 + 0.72764452643261 + 0.72003403318294 + 0.71190303694329 + 0.70326058306303 + 0.69412629778392 + 0.68452917000408 + 0.67450621134972 + 0.66410103366685 + 0.65335968518571 + 0.64228229268739 + 0.63091280625825 + 0.61929808783460 + 0.60748795475445 + 0.59553550514868 + 0.58349731915648 + 0.57140852493116 + 0.55929943636855 + 0.54722027518901 + 0.53521661469185 + 0.52332493986934 + 0.99837828227277 + 0.99838064622330 + 0.99838104007641 + 0.99838149994534 + 0.99838203705107 + 0.99838266458158 + 0.99838339805730 + 0.99838425582433 + 0.99838525985213 + 0.99838643792057 + 0.99838782973046 + 0.99838949265475 + 0.99839149573729 + 0.99839391689515 + 0.99839684853485 + 0.99840040340085 + 0.99840472023644 + 0.99840997046412 + 0.99841637484404 + 0.99842421889414 + 0.99843385251890 + 0.99844572031455 + 0.99846039155329 + 0.99847860245936 + 0.99850132146375 + 0.99852987430361 + 0.99856617473891 + 0.99861292794938 + 0.99867391408976 + 0.99875472393994 + 0.99886457777414 + 0.99901988523763 + 0.99925784830501 + 1.00000000000000 + 0.99917994395182 + 0.99878779853610 + 0.99842854745714 + 0.99807400080203 + 0.99770981566708 + 0.99732510998859 + 0.99691047344912 + 0.99645649588193 + 0.99595328458570 + 0.99539078107752 + 0.99476208557876 + 0.99406346697046 + 0.99328561830634 + 0.99241833957284 + 0.99145665459952 + 0.99039097610704 + 0.98920537210073 + 0.98788182088677 + 0.98640087442251 + 0.98474120626807 + 0.98287734893934 + 0.98078055548226 + 0.97841887691771 + 0.97575516956127 + 0.97274730270436 + 0.96934874912681 + 0.96550688943609 + 0.96115610127011 + 0.95622490731233 + 0.95065144030897 + 0.94438134246494 + 0.93736168805999 + 0.92955052922582 + 0.92091767686846 + 0.91144814095908 + 0.90114728237566 + 0.89004678232774 + 0.87820999907863 + 0.86573070635498 + 0.85272035958992 + 0.83932033169926 + 0.82571990869452 + 0.81212446013346 + 0.80538209334669 + 0.79870351522452 + 0.79210063274978 + 0.78557950862491 + 0.77913987641881 + 0.77277505315210 + 0.76647239354298 + 0.76021438768998 + 0.75398024052463 + 0.74774431493304 + 0.74142109765124 + 0.73476592743742 + 0.72764513871827 + 0.72003461486243 + 0.71190358731167 + 0.70326110156797 + 0.69412678405943 + 0.68452962390005 + 0.67450663296364 + 0.66410142335319 + 0.65336004355929 + 0.64228262046591 + 0.63091310438244 + 0.61929835745006 + 0.60748819717936 + 0.59553572184694 + 0.58349751171316 + 0.57140869498922 + 0.55929958561497 + 0.54722040538736 + 0.53521672766679 + 0.52332503747858 + 0.99820415509620 + 0.99820622549238 + 0.99820657043682 + 0.99820697320098 + 0.99820744360990 + 0.99820799321246 + 0.99820863560619 + 0.99820938685022 + 0.99821026617892 + 0.99821129786172 + 0.99821251644144 + 0.99821397164943 + 0.99821572332338 + 0.99821783903202 + 0.99822039890189 + 0.99822350059956 + 0.99822726417682 + 0.99823183774603 + 0.99823741165518 + 0.99824423150621 + 0.99825259741317 + 0.99826288928111 + 0.99827559120634 + 0.99829132539394 + 0.99831090379624 + 0.99833542707906 + 0.99836646524386 + 0.99840619770593 + 0.99845758511142 + 0.99852483330261 + 0.99861449730069 + 0.99873706373317 + 0.99891135424488 + 0.99917994395182 + 1.00000000000000 + 0.99909094756867 + 0.99864718952047 + 0.99824278303198 + 0.99784436838532 + 0.99743450115649 + 0.99700062359551 + 0.99653153126295 + 0.99601620816874 + 0.99544385461364 + 0.99480708773710 + 0.99410182771467 + 0.99331845590588 + 0.99244654766105 + 0.99148098198067 + 0.99041204085560 + 0.98922367820292 + 0.98789778491320 + 0.98641484563315 + 0.98475348050741 + 0.98288817705161 + 0.98079015095209 + 0.97842742145859 + 0.97576281650615 + 0.97275418044313 + 0.96935496460733 + 0.96551253084232 + 0.96116123914474 + 0.95622959808495 + 0.95065573142696 + 0.94438527468665 + 0.93736529613703 + 0.92955384303298 + 0.92092072217761 + 0.91145094013433 + 0.90114985500135 + 0.89004914577067 + 0.87821216898406 + 0.86573269699406 + 0.85272218396058 + 0.83932200202460 + 0.82572143710692 + 0.81212585877030 + 0.80538343148532 + 0.79870479578508 + 0.79210185856786 + 0.78558068243531 + 0.77914100084209 + 0.77277613067976 + 0.76647342651604 + 0.76021537829336 + 0.75398119077859 + 0.74774522666060 + 0.74142197209163 + 0.73476676429523 + 0.72764593700295 + 0.72003537360735 + 0.71190430553583 + 0.70326177849363 + 0.69412741915167 + 0.68453021691358 + 0.67450718397863 + 0.66410193280394 + 0.65336051222531 + 0.64228304926369 + 0.63091349452968 + 0.61929871043441 + 0.60748851471566 + 0.59553600584052 + 0.58349776423019 + 0.57140891816911 + 0.55929978165062 + 0.54722057657293 + 0.53521687637195 + 0.52332516611548 + 0.99800890828094 + 0.99801071432185 + 0.99801101523568 + 0.99801136658998 + 0.99801177696085 + 0.99801225642602 + 0.99801281684780 + 0.99801347224025 + 0.99801423937932 + 0.99801513939555 + 0.99801620221785 + 0.99801747076440 + 0.99801899666147 + 0.99802083827596 + 0.99802306481752 + 0.99802576059275 + 0.99802902913991 + 0.99803299804998 + 0.99803783100755 + 0.99804373878088 + 0.99805097838578 + 0.99805987421095 + 0.99807083806539 + 0.99808439668480 + 0.99810123318812 + 0.99812226647869 + 0.99814879513166 + 0.99818259738213 + 0.99822603952560 + 0.99828238933704 + 0.99835655776478 + 0.99845593188677 + 0.99859245968800 + 0.99878779853610 + 0.99909094756867 + 1.00000000000000 + 0.99898918296928 + 0.99848723060317 + 0.99803182392685 + 0.99758332052011 + 0.99712135863041 + 0.99663095451731 + 0.99609896653325 + 0.99551329644355 + 0.99486575560825 + 0.99415171148205 + 0.99336108250651 + 0.99248312004569 + 0.99151249737257 + 0.99043931591650 + 0.98924737472130 + 0.98791844719588 + 0.98643292832389 + 0.98476936770167 + 0.98290219381423 + 0.98080257359595 + 0.97843848499323 + 0.97577271908081 + 0.97276308783871 + 0.96936301481422 + 0.96551983756783 + 0.96116789324093 + 0.95623567223170 + 0.95066128683710 + 0.94439036410810 + 0.93736996468724 + 0.92955812961895 + 0.92092466046114 + 0.91145455939919 + 0.90115318093915 + 0.89005220118393 + 0.87821497440591 + 0.86573527112888 + 0.85272454379506 + 0.83932416348573 + 0.82572341596676 + 0.81212767076616 + 0.80538516572884 + 0.79870645604981 + 0.79210344851755 + 0.78558220559414 + 0.77914246058035 + 0.77277753019179 + 0.76647476880652 + 0.76021666615774 + 0.75398242678693 + 0.74774641313049 + 0.74142311057572 + 0.73476785434890 + 0.72764697727242 + 0.72003636276471 + 0.71190524223639 + 0.70326266164837 + 0.69412824799923 + 0.68453099107710 + 0.67450790351799 + 0.66410259824730 + 0.65336112456193 + 0.64228360967407 + 0.63091400459198 + 0.61929917207920 + 0.60748893017546 + 0.59553637760186 + 0.58349809498434 + 0.57140921069880 + 0.55930003881080 + 0.54722080134343 + 0.53521707182993 + 0.52332533538819 + 0.99778978009138 + 0.99779135031794 + 0.99779161195843 + 0.99779191746143 + 0.99779227428718 + 0.99779269120241 + 0.99779317852688 + 0.99779374845113 + 0.99779441556433 + 0.99779519820760 + 0.99779612222474 + 0.99779722451406 + 0.99779854946215 + 0.99780014731199 + 0.99780207764952 + 0.99780441303498 + 0.99780724250937 + 0.99781067571118 + 0.99781485306461 + 0.99781995507439 + 0.99782620153331 + 0.99783386922900 + 0.99784330850690 + 0.99785496581868 + 0.99786941735275 + 0.99788743344237 + 0.99791009460104 + 0.99793886503853 + 0.99797566321409 + 0.99802308374446 + 0.99808492697701 + 0.99816667830881 + 0.99827667518345 + 0.99842854745714 + 0.99864718952047 + 0.99898918296928 + 1.00000000000000 + 0.99887276133435 + 0.99830482531722 + 0.99779143067200 + 0.99728608543056 + 0.99676444953042 + 0.99620889668248 + 0.99560486187400 + 0.99494272444369 + 0.99421692888083 + 0.99341667747629 + 0.99253073851237 + 0.99155348412971 + 0.99047476087839 + 0.98927815417575 + 0.98794527744640 + 0.98645640488795 + 0.98478999200427 + 0.98292038922665 + 0.98081869944374 + 0.97845284656340 + 0.97578557353289 + 0.97277465014855 + 0.96937346376700 + 0.96552932036568 + 0.96117652740759 + 0.95624355175212 + 0.95066849104077 + 0.94439696153043 + 0.93737601413031 + 0.92956368194545 + 0.92092975981062 + 0.91145924425611 + 0.90115748512665 + 0.89005615473619 + 0.87821860435982 + 0.86573860206381 + 0.85272759798538 + 0.83932696174382 + 0.82572597884379 + 0.81213001872331 + 0.80538741359786 + 0.79870860872104 + 0.79210551072428 + 0.78558418189364 + 0.77914435532045 + 0.77277934748597 + 0.76647651251503 + 0.76021833986019 + 0.75398403377322 + 0.74774795635096 + 0.74142459198512 + 0.73476927330177 + 0.72764833193507 + 0.72003765132953 + 0.71190646286828 + 0.70326381285371 + 0.69412932870834 + 0.68453200073603 + 0.67450884215108 + 0.66410346650738 + 0.65336192371193 + 0.64228434123361 + 0.63091467060941 + 0.61929977506742 + 0.60748947304411 + 0.59553686358994 + 0.58349852759730 + 0.57140959356233 + 0.55930037563653 + 0.54722109600332 + 0.53521732831517 + 0.52332555775395 + 0.99754347426932 + 0.99754483596797 + 0.99754506287888 + 0.99754532783724 + 0.99754563731454 + 0.99754599891943 + 0.99754642160833 + 0.99754691596048 + 0.99754749463160 + 0.99754817350025 + 0.99754897483155 + 0.99754993025809 + 0.99755107783216 + 0.99755246068979 + 0.99755413001047 + 0.99755614809072 + 0.99755859134096 + 0.99756155378475 + 0.99756515567225 + 0.99756955134320 + 0.99757492855989 + 0.99758152336018 + 0.99758963385410 + 0.99759963881857 + 0.99761202527489 + 0.99762744116563 + 0.99764678983247 + 0.99767128552283 + 0.99770250063834 + 0.99774252860269 + 0.99779437788301 + 0.99786226412546 + 0.99795232981522 + 0.99807400080203 + 0.99824278303198 + 0.99848723060317 + 0.99887276133435 + 1.00000000000000 + 0.99873891130098 + 0.99809597950184 + 0.99751716317103 + 0.99694703379404 + 0.99635683645174 + 0.99572677486060 + 0.99504446880317 + 0.99430272005831 + 0.99348956554201 + 0.99259302287777 + 0.99160700727037 + 0.99052099557623 + 0.98931827256315 + 0.98798023016489 + 0.98648697759626 + 0.98481684337185 + 0.98294407371284 + 0.98083968667170 + 0.97847153496757 + 0.97580229835407 + 0.97278969133743 + 0.96938705393069 + 0.96554165087564 + 0.96118775089985 + 0.95625379029532 + 0.95067784784256 + 0.94440552601196 + 0.93738386322485 + 0.92957088240806 + 0.92093636971316 + 0.91146531435530 + 0.90116306008915 + 0.89006127425182 + 0.87822330413859 + 0.86574291450991 + 0.85273155237896 + 0.83933058535969 + 0.82572929853914 + 0.81213306115626 + 0.80539032699224 + 0.79871139942765 + 0.79210818488515 + 0.78558674540670 + 0.77914681381004 + 0.77278170626467 + 0.76647877655247 + 0.76022051376018 + 0.75398612175125 + 0.74774996217948 + 0.74142651813625 + 0.73477111885855 + 0.72765009443485 + 0.72003932832851 + 0.71190805188612 + 0.70326531185533 + 0.69413073622244 + 0.68453331596947 + 0.67451006508067 + 0.66410459794111 + 0.65336296527231 + 0.64228529488848 + 0.63091553901869 + 0.61930056150491 + 0.60749018130443 + 0.59553749789288 + 0.58349909251103 + 0.57141009380591 + 0.55930081603509 + 0.54722148158090 + 0.53521766424825 + 0.52332584929402 + 0.99726579923166 + 0.99726697779990 + 0.99726717421028 + 0.99726740355904 + 0.99726767145242 + 0.99726798447787 + 0.99726835039399 + 0.99726877836542 + 0.99726927935049 + 0.99726986707402 + 0.99727056067343 + 0.99727138721616 + 0.99727237925867 + 0.99727357376834 + 0.99727501461670 + 0.99727675519993 + 0.99727886097796 + 0.99728141246342 + 0.99728451249203 + 0.99728829287771 + 0.99729291388819 + 0.99729857675146 + 0.99730553516423 + 0.99731411078167 + 0.99732471597466 + 0.99733789723038 + 0.99735441269171 + 0.99737527507629 + 0.99740178427514 + 0.99743565042803 + 0.99747929608883 + 0.99753604226537 + 0.99761058295879 + 0.99770981566708 + 0.99784436838532 + 0.99803182392685 + 0.99830482531722 + 0.99873891130098 + 1.00000000000000 + 0.99858443600527 + 0.99785703937535 + 0.99720407691945 + 0.99655980789676 + 0.99589135110878 + 0.99518038283642 + 0.99441652934114 + 0.99358580330586 + 0.99267499302832 + 0.99167728875250 + 0.99058161212298 + 0.98937081335743 + 0.98802597098643 + 0.98652696467245 + 0.98485194887083 + 0.98297502887945 + 0.98086710915570 + 0.97849594779944 + 0.97582414095974 + 0.97280933021356 + 0.96940479327668 + 0.96555774072655 + 0.96120239049112 + 0.95626713894180 + 0.95069004048459 + 0.94441667986449 + 0.93739407942077 + 0.92958024892995 + 0.92094496332128 + 0.91147320226200 + 0.90117030153684 + 0.89006792190564 + 0.87822940535158 + 0.86574851217411 + 0.85273668514465 + 0.83933528911311 + 0.82573360850208 + 0.81213701220923 + 0.80539411112090 + 0.79871502490701 + 0.79211165971456 + 0.78559007725954 + 0.77915000998402 + 0.77278477364833 + 0.76648172157822 + 0.76022334236850 + 0.75398883937390 + 0.74775257365770 + 0.74142902661413 + 0.73477352305922 + 0.72765239104618 + 0.72004151406959 + 0.71191012341835 + 0.70326726641782 + 0.69413257180692 + 0.68453503146184 + 0.67451166039413 + 0.66410607409009 + 0.65336432435118 + 0.64228653945398 + 0.63091667254363 + 0.61930158826937 + 0.60749110626644 + 0.59553832656695 + 0.58349983086438 + 0.57141074799031 + 0.55930139233363 + 0.54722198653052 + 0.53521810456857 + 0.52332623179579 + 0.99695155376628 + 0.99695257236921 + 0.99695274213360 + 0.99695294037241 + 0.99695317193250 + 0.99695344251326 + 0.99695375882176 + 0.99695412878768 + 0.99695456188428 + 0.99695506995494 + 0.99695566943292 + 0.99695638344714 + 0.99695723981696 + 0.99695827017794 + 0.99695951209519 + 0.99696101127185 + 0.99696282372747 + 0.99696501833235 + 0.99696768294680 + 0.99697093004573 + 0.99697489637690 + 0.99697975344051 + 0.99698571720191 + 0.99699306100794 + 0.99700213453491 + 0.99701339974445 + 0.99702749493835 + 0.99704526866383 + 0.99706780295863 + 0.99709650863004 + 0.99713336244830 + 0.99718103029703 + 0.99724319672137 + 0.99732510998859 + 0.99743450115649 + 0.99758332052011 + 0.99779143067200 + 0.99809597950184 + 0.99858443600527 + 1.00000000000000 + 0.99840697698772 + 0.99758407226173 + 0.99684665721608 + 0.99611797340476 + 0.99536456952225 + 0.99456919526052 + 0.99371403143633 + 0.99278371294568 + 0.99177021455984 + 0.99066158666423 + 0.98944002954502 + 0.98808616562633 + 0.98657954758643 + 0.98489808653152 + 0.98301569403014 + 0.98090312037783 + 0.97852799647539 + 0.97585280683406 + 0.97283509606628 + 0.96942805931558 + 0.96557883554594 + 0.96122157562995 + 0.95628462348427 + 0.95070600181596 + 0.94443127245597 + 0.93740743689452 + 0.92959248786012 + 0.92095618564933 + 0.91148349744417 + 0.90117974851914 + 0.89007659090561 + 0.87823735946122 + 0.86575580844220 + 0.85274337483615 + 0.83934141967336 + 0.82573922635694 + 0.81214216321284 + 0.80539904514337 + 0.79871975279468 + 0.79211619193360 + 0.78559442383407 + 0.77915418044715 + 0.77278877697336 + 0.76648556613378 + 0.76022703587310 + 0.75399238885797 + 0.74775598537378 + 0.74143230458684 + 0.73477666551808 + 0.72765539355279 + 0.72004437220928 + 0.71191283269847 + 0.70326982311455 + 0.69413497318144 + 0.68453727597162 + 0.67451374786063 + 0.66410800580604 + 0.65336610304332 + 0.64228816846929 + 0.63091815644008 + 0.61930293266464 + 0.60749231767196 + 0.59553941222009 + 0.58350079858506 + 0.57141160583490 + 0.55930214851625 + 0.54722264957862 + 0.53521868324013 + 0.52332673495165 + 0.99659493349668 + 0.99659581304043 + 0.99659595963698 + 0.99659613082572 + 0.99659633079273 + 0.99659656446201 + 0.99659683762899 + 0.99659715714306 + 0.99659753118750 + 0.99659796997403 + 0.99659848760012 + 0.99659910382337 + 0.99659984240550 + 0.99660073040577 + 0.99660179996414 + 0.99660309018590 + 0.99660464897613 + 0.99660653522091 + 0.99660882395376 + 0.99661161113779 + 0.99661501342743 + 0.99661917702397 + 0.99662428585296 + 0.99663057242424 + 0.99663833367174 + 0.99664796092146 + 0.99665999311486 + 0.99667514410713 + 0.99669431980121 + 0.99671869346184 + 0.99674989546840 + 0.99679009788665 + 0.99684225339686 + 0.99691047344912 + 0.99700062359551 + 0.99712135863041 + 0.99728608543056 + 0.99751716317103 + 0.99785703937535 + 0.99840697698772 + 1.00000000000000 + 0.99820312438145 + 0.99727209549941 + 0.99643902074246 + 0.99561884212527 + 0.99477668647879 + 0.99388658214360 + 0.99292905069279 + 0.99189388640944 + 0.99076769725133 + 0.98953167017480 + 0.98816574108257 + 0.98664898365108 + 0.98495896069257 + 0.98306931234012 + 0.98095057631997 + 0.97857021033403 + 0.97589054826291 + 0.97286900469283 + 0.96945866450675 + 0.96560657136527 + 0.96124678712825 + 0.95630758639363 + 0.95072695040895 + 0.94445041121982 + 0.93742494314306 + 0.92960851667453 + 0.92097087295902 + 0.91149696274233 + 0.90119209739760 + 0.89008791731295 + 0.87824774775909 + 0.86576533477403 + 0.85275210742442 + 0.83934942146024 + 0.82574655874072 + 0.81214888667598 + 0.80540548580478 + 0.79872592490814 + 0.79212210924339 + 0.78560009949345 + 0.77915962693679 + 0.77279400603477 + 0.76649058869364 + 0.76023186198689 + 0.75399702767218 + 0.74776044500193 + 0.74143659020643 + 0.73478077470830 + 0.72765932037910 + 0.72004811075972 + 0.71191637695836 + 0.70327316807912 + 0.69413811515542 + 0.68454021284708 + 0.67451647935562 + 0.66411053358447 + 0.65336843067708 + 0.64229030036364 + 0.63092009859727 + 0.61930469248366 + 0.60749390371664 + 0.59554083400475 + 0.58350206637408 + 0.57141273018820 + 0.55930314017857 + 0.54722351968878 + 0.53521944321341 + 0.52332739632544 + 0.99618909332979 + 0.99618985238436 + 0.99618997890289 + 0.99619012664736 + 0.99619029923150 + 0.99619050090529 + 0.99619073667307 + 0.99619101244748 + 0.99619133529016 + 0.99619171400197 + 0.99619216067585 + 0.99619269219295 + 0.99619332885565 + 0.99619409380760 + 0.99619501455075 + 0.99619612453469 + 0.99619746473581 + 0.99619908549347 + 0.99620105090492 + 0.99620344285236 + 0.99620636088839 + 0.99620992970200 + 0.99621430604306 + 0.99621968788469 + 0.99622632773232 + 0.99623455771849 + 0.99624483407312 + 0.99625775945130 + 0.99627409597626 + 0.99629482583455 + 0.99632130543156 + 0.99635532560522 + 0.99639929122387 + 0.99645649588193 + 0.99653153126295 + 0.99663095451731 + 0.99676444953042 + 0.99694703379404 + 0.99720407691945 + 0.99758407226173 + 0.99820312438145 + 1.00000000000000 + 0.99796910551746 + 0.99691642402108 + 0.99597991934374 + 0.99506393155124 + 0.99412182369112 + 0.99312526331961 + 0.99205977420655 + 0.99090940748417 + 0.98965368418023 + 0.98827146194742 + 0.98674108775649 + 0.98503961113526 + 0.98314028269866 + 0.98101334122738 + 0.97862600474313 + 0.97594040128126 + 0.97291376923559 + 0.96949904497086 + 0.96564314433294 + 0.96128001022728 + 0.95633782512002 + 0.95075451567841 + 0.94447557496669 + 0.93744794168690 + 0.92962955718140 + 0.92099013737962 + 0.91151461129981 + 0.90120827182572 + 0.89010274375464 + 0.87826133940007 + 0.86577779357731 + 0.85276352450778 + 0.83935988060496 + 0.82575614141483 + 0.81215767292205 + 0.80541390245405 + 0.79873399076533 + 0.79212984241339 + 0.78560751728722 + 0.77916674576304 + 0.77280084130932 + 0.76649715474177 + 0.76023817196585 + 0.75400309352909 + 0.74776627730755 + 0.74144219566080 + 0.73478615003452 + 0.72766445766970 + 0.72005300212722 + 0.71192101438123 + 0.70327754486912 + 0.69414222636144 + 0.68454405563792 + 0.67452005331736 + 0.66411384090338 + 0.65337147606834 + 0.64229308965196 + 0.63092263971692 + 0.61930699520254 + 0.60749597933021 + 0.59554269503699 + 0.58350372631717 + 0.57141420289748 + 0.55930443972890 + 0.54722466063453 + 0.53522044044646 + 0.52332826486585 + 0.99572606468099 + 0.99572671952568 + 0.99572682867618 + 0.99572695613905 + 0.99572710503433 + 0.99572727902505 + 0.99572748243133 + 0.99572772035503 + 0.99572799888730 + 0.99572832560521 + 0.99572871088776 + 0.99572916917252 + 0.99572971781602 + 0.99573037662353 + 0.99573116913564 + 0.99573212397711 + 0.99573327620524 + 0.99573466887576 + 0.99573635675931 + 0.99573840977143 + 0.99574091291359 + 0.99574397259971 + 0.99574772253729 + 0.99575233146547 + 0.99575801439663 + 0.99576505372634 + 0.99577383656766 + 0.99578487324736 + 0.99579880751595 + 0.99581646602631 + 0.99583898516933 + 0.99586785542417 + 0.99590506049346 + 0.99595328458570 + 0.99601620816874 + 0.99609896653325 + 0.99620889668248 + 0.99635683645174 + 0.99655980789676 + 0.99684665721608 + 0.99727209549941 + 0.99796910551746 + 1.00000000000000 + 0.99770205747967 + 0.99651814844626 + 0.99547291559125 + 0.99444845027863 + 0.99339360738696 + 0.99228447189621 + 0.99110013559714 + 0.98981718587527 + 0.98841269269867 + 0.98686385091517 + 0.98514692552054 + 0.98323459115491 + 0.98109665565661 + 0.97869999858915 + 0.97600646214302 + 0.97297304286828 + 0.96955247489672 + 0.96569150113024 + 0.96132390432111 + 0.95637774359409 + 0.95079087325524 + 0.94450873499567 + 0.93747822052633 + 0.92965723270868 + 0.92101545410246 + 0.91153778483923 + 0.90122949308758 + 0.89012218267627 + 0.87827914833977 + 0.86579410953034 + 0.85277846955249 + 0.83937356661794 + 0.82576867684541 + 0.81216916402829 + 0.80542490933068 + 0.79874453829132 + 0.79213995452929 + 0.78561721684838 + 0.77917605441635 + 0.77280977936111 + 0.76650574103921 + 0.76024642379920 + 0.75401102656236 + 0.74777390537163 + 0.74144952748657 + 0.73479318121877 + 0.72767117771553 + 0.72005940055465 + 0.71192708053514 + 0.70328326985939 + 0.69414760360979 + 0.68454908138366 + 0.67452472702296 + 0.66411816547909 + 0.65337545778512 + 0.64229673625739 + 0.63092596173681 + 0.61931000556689 + 0.60749869295979 + 0.59554512844524 + 0.58350589725995 + 0.57141612956841 + 0.55930614057195 + 0.54722615467814 + 0.53522174711794 + 0.52332940372227 + 0.99519725689707 + 0.99519782170005 + 0.99519791584200 + 0.99519802577609 + 0.99519815419519 + 0.99519830425903 + 0.99519847969187 + 0.99519868489367 + 0.99519892511520 + 0.99519920688176 + 0.99519953910502 + 0.99519993414418 + 0.99520040685492 + 0.99520097420155 + 0.99520165634657 + 0.99520247780345 + 0.99520346858417 + 0.99520466553801 + 0.99520611550334 + 0.99520787822793 + 0.99521002635139 + 0.99521265077514 + 0.99521586565298 + 0.99521981497902 + 0.99522468208160 + 0.99523070747090 + 0.99523822032543 + 0.99524765395651 + 0.99525955398579 + 0.99527461922786 + 0.99529380717301 + 0.99531836764989 + 0.99534995332228 + 0.99539078107752 + 0.99544385461364 + 0.99551329644355 + 0.99560486187400 + 0.99572677486060 + 0.99589135110878 + 0.99611797340476 + 0.99643902074246 + 0.99691642402108 + 0.99770205747967 + 1.00000000000000 + 0.99740650879188 + 0.99608358323837 + 0.99491429677529 + 0.99376686877903 + 0.99259236273072 + 0.99135897825759 + 0.99003764621776 + 0.98860226082130 + 0.98702808749970 + 0.98529013718974 + 0.98336020114826 + 0.98120744688534 + 0.97879826402722 + 0.97609409001264 + 0.97305158425441 + 0.96962320206258 + 0.96575544994671 + 0.96138189340857 + 0.95643042537095 + 0.95083880344531 + 0.94455240108215 + 0.93751804756691 + 0.92969359465606 + 0.92104868047350 + 0.91156816653914 + 0.90125728784103 + 0.89014761988952 + 0.87830243347800 + 0.86581542696393 + 0.85279798311142 + 0.83939142592641 + 0.82578502644064 + 0.81218414511567 + 0.80543925648871 + 0.79875828446411 + 0.79215313138532 + 0.78562985459571 + 0.77918818163135 + 0.77282142282154 + 0.76651692557004 + 0.76025717213968 + 0.75402135928641 + 0.74778384061101 + 0.74145907665785 + 0.73480233850366 + 0.72767992930170 + 0.72006773264668 + 0.71193497911440 + 0.70329072323886 + 0.69415460316908 + 0.68455562223608 + 0.67453080854629 + 0.66412379162016 + 0.65338063691458 + 0.64230147870292 + 0.63093028146258 + 0.61931391966731 + 0.60750222110880 + 0.59554829235964 + 0.58350872023384 + 0.57141863541802 + 0.55930835337355 + 0.54722809921641 + 0.53522344863454 + 0.52333088757790 + 0.99459682505113 + 0.99459731217638 + 0.99459739336733 + 0.99459748817864 + 0.99459759892888 + 0.99459772834423 + 0.99459787963609 + 0.99459805659713 + 0.99459826375075 + 0.99459850671907 + 0.99459879315961 + 0.99459913367416 + 0.99459954100408 + 0.99460002970096 + 0.99460061705881 + 0.99460132410172 + 0.99460217655690 + 0.99460320600380 + 0.99460445255986 + 0.99460596737607 + 0.99460781262511 + 0.99461006608220 + 0.99461282538144 + 0.99461621361466 + 0.99462038740256 + 0.99462555204889 + 0.99463198823986 + 0.99464006507098 + 0.99465024668993 + 0.99466312641421 + 0.99467951535614 + 0.99470046862714 + 0.99472737494010 + 0.99476208557876 + 0.99480708773710 + 0.99486575560825 + 0.99494272444369 + 0.99504446880317 + 0.99518038283642 + 0.99536456952225 + 0.99561884212527 + 0.99597991934374 + 0.99651814844626 + 0.99740650879188 + 1.00000000000000 + 0.99708772690191 + 0.99560611855101 + 0.99429617090679 + 0.99301809027124 + 0.99171141730038 + 0.99033478643275 + 0.98885594754651 + 0.98724672044240 + 0.98548000761257 + 0.98352618989034 + 0.98135345175922 + 0.97892745462762 + 0.97620905109287 + 0.97315442342526 + 0.96971563825574 + 0.96583887682213 + 0.96145740952713 + 0.95649890535485 + 0.95090099213259 + 0.94460895201725 + 0.93756953101720 + 0.92974051273040 + 0.92109147591772 + 0.91160723036175 + 0.90129296641594 + 0.89018022129258 + 0.87833223318802 + 0.86584267154028 + 0.85282289093222 + 0.83941419562069 + 0.82580584893829 + 0.81220320611841 + 0.80545750275633 + 0.79877575909107 + 0.79216987573925 + 0.78564590808003 + 0.77920358147337 + 0.77283620386329 + 0.76653112006429 + 0.76027080959499 + 0.75403446636628 + 0.74779644079023 + 0.74147118475431 + 0.73481394725464 + 0.72769102121018 + 0.72007829024801 + 0.71194498467265 + 0.70330016202887 + 0.69416346441584 + 0.68456389997168 + 0.67453850229249 + 0.66413090675261 + 0.65338718447065 + 0.64230747221436 + 0.63093573907724 + 0.61931886348076 + 0.60750667644238 + 0.59555228707104 + 0.58351228410998 + 0.57142179883117 + 0.55931114695063 + 0.54723055440120 + 0.53522559737701 + 0.52333276190900 + 0.99392189178677 + 0.99392231195617 + 0.99392238198405 + 0.99392246375629 + 0.99392255927440 + 0.99392267088672 + 0.99392280136300 + 0.99392295396960 + 0.99392313260670 + 0.99392334211615 + 0.99392358909061 + 0.99392388264829 + 0.99392423374508 + 0.99392465489176 + 0.99392516095804 + 0.99392577000849 + 0.99392650414528 + 0.99392739049814 + 0.99392846351228 + 0.99392976708621 + 0.99393135457065 + 0.99393329268391 + 0.99393566514111 + 0.99393857744950 + 0.99394216378383 + 0.99394659993263 + 0.99395212611587 + 0.99395905800091 + 0.99396779211887 + 0.99397883461081 + 0.99399287644414 + 0.99401081420925 + 0.99403382404452 + 0.99406346697046 + 0.99410182771467 + 0.99415171148205 + 0.99421692888083 + 0.99430272005831 + 0.99441652934114 + 0.99456919526052 + 0.99477668647879 + 0.99506393155124 + 0.99547291559125 + 0.99608358323837 + 0.99708772690191 + 1.00000000000000 + 0.99673186591293 + 0.99507304595406 + 0.99361452370634 + 0.99219255718090 + 0.99073386268229 + 0.98919285243427 + 0.98753467450705 + 0.98572846615831 + 0.98374224963806 + 0.98154264400362 + 0.97909419624308 + 0.97635689525153 + 0.97328623725610 + 0.96983374126586 + 0.96594513878365 + 0.96155330048727 + 0.95658559500139 + 0.95097947551679 + 0.94468010129287 + 0.93763410699026 + 0.92979918508073 + 0.92114483492712 + 0.91165579698914 + 0.90133720162837 + 0.89022053436155 + 0.87836898912558 + 0.86587619593099 + 0.85285347107872 + 0.83944209147933 + 0.82583130862179 + 0.81222646925964 + 0.80547975244359 + 0.79879705046206 + 0.79219026159363 + 0.78566543861083 + 0.77922230400739 + 0.77285416261360 + 0.76654835590278 + 0.76028735985768 + 0.75405036474923 + 0.74781171694455 + 0.74148585758310 + 0.73482800850159 + 0.72770445006768 + 0.72009106597140 + 0.71195708622362 + 0.70331157208302 + 0.69417417050500 + 0.68457389552234 + 0.67454778744056 + 0.66413948877117 + 0.65339507750733 + 0.64231469341887 + 0.63094231115338 + 0.61932481385142 + 0.60751203635150 + 0.59555709072939 + 0.58351656795769 + 0.57142559991106 + 0.55931450252081 + 0.54723350260687 + 0.53522817689018 + 0.52333501143479 + 0.99316401545978 + 0.99316437778664 + 0.99316443816868 + 0.99316450867589 + 0.99316459103231 + 0.99316468726295 + 0.99316479975043 + 0.99316493131163 + 0.99316508530829 + 0.99316526590698 + 0.99316547878753 + 0.99316573181524 + 0.99316603442961 + 0.99316639740873 + 0.99316683355825 + 0.99316735842949 + 0.99316799104955 + 0.99316875476374 + 0.99316967920639 + 0.99317080214810 + 0.99317216946577 + 0.99317383851991 + 0.99317588125616 + 0.99317838830819 + 0.99318147490493 + 0.99318529196380 + 0.99319004573007 + 0.99319600712460 + 0.99320351612923 + 0.99321300620335 + 0.99322506867210 + 0.99324046939149 + 0.99326021059154 + 0.99328561830634 + 0.99331845590588 + 0.99336108250651 + 0.99341667747629 + 0.99348956554201 + 0.99358580330586 + 0.99371403143633 + 0.99388658214360 + 0.99412182369112 + 0.99444845027863 + 0.99491429677529 + 0.99560611855101 + 0.99673186591293 + 1.00000000000000 + 0.99633366795277 + 0.99448739656378 + 0.99286458554140 + 0.99127677900476 + 0.98964349963443 + 0.98791529173543 + 0.98605395028703 + 0.98402328003432 + 0.98178727218493 + 0.97930869500041 + 0.97654621886421 + 0.97345432772893 + 0.96998375327624 + 0.96607959568523 + 0.96167417888152 + 0.95669446553943 + 0.95107767144572 + 0.94476878864621 + 0.93771430171526 + 0.92987178044500 + 0.92121061742563 + 0.91171545985010 + 0.90139135721076 + 0.89026972514802 + 0.87841369749444 + 0.86591685058100 + 0.85289044886348 + 0.83947573152849 + 0.82586193206471 + 0.81225438381240 + 0.80550642092250 + 0.79882254296847 + 0.79221464507840 + 0.78568877655979 + 0.77924465615152 + 0.77287558463965 + 0.76656889919360 + 0.76030707129179 + 0.75406928657962 + 0.74782988633305 + 0.74150329854143 + 0.73484471215300 + 0.72772039241052 + 0.72010622312769 + 0.71197143399910 + 0.70332509079484 + 0.69418684632317 + 0.68458572170277 + 0.67455876526829 + 0.66414962804443 + 0.65340439618723 + 0.64232321298462 + 0.63095005961476 + 0.61933182471061 + 0.60751834751701 + 0.59556274348606 + 0.58352160608315 + 0.57143006775308 + 0.55931844454877 + 0.54723696422764 + 0.53523120402969 + 0.52333764996789 + 0.99231365679660 + 0.99231396910530 + 0.99231402114518 + 0.99231408191099 + 0.99231415288537 + 0.99231423581318 + 0.99231433274726 + 0.99231444611064 + 0.99231457879354 + 0.99231473439062 + 0.99231491779922 + 0.99231513580979 + 0.99231539657701 + 0.99231570939790 + 0.99231608531773 + 0.99231653774862 + 0.99231708309385 + 0.99231774147216 + 0.99231853843307 + 0.99231950653702 + 0.99232068531664 + 0.99232212418003 + 0.99232388508626 + 0.99232604606095 + 0.99232870626753 + 0.99233199558503 + 0.99233609159231 + 0.99234122754162 + 0.99234769585925 + 0.99235586898389 + 0.99236625493580 + 0.99237951072668 + 0.99239649461310 + 0.99241833957284 + 0.99244654766105 + 0.99248312004569 + 0.99253073851237 + 0.99259302287777 + 0.99267499302832 + 0.99278371294568 + 0.99292905069279 + 0.99312526331961 + 0.99339360738696 + 0.99376686877903 + 0.99429617090679 + 0.99507304595406 + 0.99633366795277 + 1.00000000000000 + 0.99590190561713 + 0.99384626311949 + 0.99203327595360 + 0.99025471573827 + 0.98842252313797 + 0.98648229183544 + 0.98438958333550 + 0.98210366969013 + 0.97958432655209 + 0.97678812638081 + 0.97366801005144 + 0.97017354794012 + 0.96624893626922 + 0.96182574059411 + 0.95683036871172 + 0.95119970950124 + 0.94487852456051 + 0.93781309423248 + 0.92996082180255 + 0.92129095538638 + 0.91178801613620 + 0.90145694422112 + 0.89032906066586 + 0.87846741769734 + 0.86596551866984 + 0.85293455804262 + 0.83951572315878 + 0.82589822058702 + 0.81228736293957 + 0.80553788324164 + 0.79885257717811 + 0.79224333563526 + 0.78571620332714 + 0.77927089406690 + 0.77290070341543 + 0.76659296302603 + 0.76033013864360 + 0.75409141008740 + 0.74785111226639 + 0.74152365726856 + 0.73486419480406 + 0.72773897216468 + 0.72012387337078 + 0.71198812780914 + 0.70334080662423 + 0.69420156956551 + 0.68459944609830 + 0.67457149397685 + 0.66416137416991 + 0.65341518232309 + 0.64233306573525 + 0.63095901307516 + 0.61933991922675 + 0.60752562837258 + 0.59556925968680 + 0.58352740932540 + 0.57143521021082 + 0.55932297836676 + 0.54724094248640 + 0.53523468028870 + 0.52334067762192 + 0.99136628440340 + 0.99136655353713 + 0.99136659837676 + 0.99136665073398 + 0.99136671188393 + 0.99136678332864 + 0.99136686683516 + 0.99136696448922 + 0.99136707877749 + 0.99136721279392 + 0.99136737077033 + 0.99136755858301 + 0.99136778329117 + 0.99136805293513 + 0.99136837706014 + 0.99136876725231 + 0.99136923768526 + 0.99136980574076 + 0.99137049349262 + 0.99137132909385 + 0.99137234669176 + 0.99137358896557 + 0.99137510941684 + 0.99137697539641 + 0.99137927248721 + 0.99138211280943 + 0.99138564982346 + 0.99139008513021 + 0.99139567122803 + 0.99140272939722 + 0.99141169803190 + 0.99142314344660 + 0.99143780441456 + 0.99145665459952 + 0.99148098198067 + 0.99151249737257 + 0.99155348412971 + 0.99160700727037 + 0.99167728875250 + 0.99177021455984 + 0.99189388640944 + 0.99205977420655 + 0.99228447189621 + 0.99259236273072 + 0.99301809027124 + 0.99361452370634 + 0.99448739656378 + 0.99590190561713 + 1.00000000000000 + 0.99542345057571 + 0.99312732250996 + 0.99109686296154 + 0.98910195246580 + 0.98704534406880 + 0.98486449776932 + 0.98250949008094 + 0.97993474893444 + 0.97709335286952 + 0.97393580781622 + 0.97040992621525 + 0.96645858607823 + 0.96201229055842 + 0.95699668407181 + 0.95134820067094 + 0.94501128087535 + 0.93793192532179 + 0.93006731023756 + 0.92138648782321 + 0.91187380887931 + 0.90153406600527 + 0.89039845253893 + 0.87852991042435 + 0.86602184456288 + 0.85298535583740 + 0.83956156100614 + 0.82593962677747 + 0.81232483412242 + 0.80557355965121 + 0.79888656914906 + 0.79227574781032 + 0.78574713428888 + 0.77930043601194 + 0.77292894184016 + 0.76661997645526 + 0.76035599843466 + 0.75411618037082 + 0.74787484939823 + 0.74154639899064 + 0.73488593377768 + 0.72775968059562 + 0.72014352378168 + 0.71200669244444 + 0.70335826387219 + 0.69421790565103 + 0.68461465660411 + 0.67458558499629 + 0.66417436282067 + 0.65342709617395 + 0.64234393664024 + 0.63096888102864 + 0.61934883092400 + 0.60753363571605 + 0.59557641842849 + 0.58353377792643 + 0.57144084741533 + 0.55932794268622 + 0.54724529330290 + 0.53523847737460 + 0.52334398046122 + 0.99031272814148 + 0.99031296007061 + 0.99031299870725 + 0.99031304381826 + 0.99031309650294 + 0.99031315805334 + 0.99031322999025 + 0.99031331410650 + 0.99031341254570 + 0.99031352797083 + 0.99031366403936 + 0.99031382585332 + 0.99031401953552 + 0.99031425205834 + 0.99031453168412 + 0.99031486845108 + 0.99031527463106 + 0.99031576527292 + 0.99031635950942 + 0.99031708174169 + 0.99031796156186 + 0.99031903593404 + 0.99032035119392 + 0.99032196566057 + 0.99032395341945 + 0.99032641158028 + 0.99032947328048 + 0.99033331348340 + 0.99033815109100 + 0.99034426439364 + 0.99035203341528 + 0.99036194859542 + 0.99037464905501 + 0.99039097610704 + 0.99041204085560 + 0.99043931591650 + 0.99047476087839 + 0.99052099557623 + 0.99058161212298 + 0.99066158666423 + 0.99076769725133 + 0.99090940748417 + 0.99110013559714 + 0.99135897825759 + 0.99171141730038 + 0.99219255718090 + 0.99286458554140 + 0.99384626311949 + 0.99542345057571 + 1.00000000000000 + 0.99487835883373 + 0.99230913932611 + 0.99003304520565 + 0.98779488723999 + 0.98548443891249 + 0.98303163172692 + 0.98038051839764 + 0.97747799230828 + 0.97427053404549 + 0.97070319754762 + 0.96671688414227 + 0.96224057747514 + 0.95719885424184 + 0.95152750528113 + 0.94517051743452 + 0.93807350430370 + 0.93019333014722 + 0.92149878017921 + 0.91197397438725 + 0.90162350606285 + 0.89047839639348 + 0.87860143868711 + 0.86608590559121 + 0.85304277361973 + 0.83961306411305 + 0.82598588587948 + 0.81236647275198 + 0.80561310327901 + 0.79892415418597 + 0.79231150305061 + 0.78578118055424 + 0.77933288583495 + 0.77295989920043 + 0.76664953653633 + 0.76038424749166 + 0.75414319575042 + 0.74790069901333 + 0.74157112932164 + 0.73490954062475 + 0.72778213696065 + 0.72016480311409 + 0.71202676796239 + 0.70337711561122 + 0.69423552224407 + 0.68463103685087 + 0.67460073901920 + 0.66418831255238 + 0.65343987465273 + 0.64235558125165 + 0.63097943765975 + 0.61935835235311 + 0.60754217997379 + 0.59558404732205 + 0.58354055583240 + 0.57144683871966 + 0.55933321128397 + 0.54724990383383 + 0.53524249474771 + 0.52334746915493 + 0.98913742816868 + 0.98913762809994 + 0.98913766140042 + 0.98913770027913 + 0.98913774568251 + 0.98913779872471 + 0.98913786071154 + 0.98913793318845 + 0.98913801799733 + 0.98913811743570 + 0.98913823467092 + 0.98913837413824 + 0.98913854116691 + 0.98913874180842 + 0.98913898323809 + 0.98913927416416 + 0.98913962524223 + 0.98914004953230 + 0.98914056365341 + 0.98914118882470 + 0.98914195075002 + 0.98914288154440 + 0.98914402144713 + 0.98914542109542 + 0.98914714481577 + 0.98914927698566 + 0.98915193352387 + 0.98915526684941 + 0.98915946745113 + 0.98916477727840 + 0.98917152710467 + 0.98918014345028 + 0.98919118165539 + 0.98920537210073 + 0.98922367820292 + 0.98924737472130 + 0.98927815417575 + 0.98931827256315 + 0.98937081335743 + 0.98944002954502 + 0.98953167017480 + 0.98965368418023 + 0.98981718587527 + 0.99003764621776 + 0.99033478643275 + 0.99073386268229 + 0.99127677900476 + 0.99203327595360 + 0.99312732250996 + 0.99487835883373 + 1.00000000000000 + 0.99425470447073 + 0.99137674541345 + 0.98882440012022 + 0.98631137668933 + 0.98371449542819 + 0.98095511508511 + 0.97796820236900 + 0.97469314112089 + 0.97107043408205 + 0.96703789527909 + 0.96252225980915 + 0.95744656746008 + 0.95174567733224 + 0.94536292272453 + 0.93824337311868 + 0.93034345871041 + 0.92163159745537 + 0.91209159441316 + 0.90172777236597 + 0.89057091966109 + 0.87868362897875 + 0.86615899518600 + 0.85310782939585 + 0.83967102430564 + 0.82603760615424 + 0.81241274040862 + 0.80565691441961 + 0.79896567849713 + 0.79235090002351 + 0.78581859913911 + 0.77936846419711 + 0.77299376449143 + 0.76668180474024 + 0.76041502337561 + 0.75417257300487 + 0.74792875979711 + 0.74159793100976 + 0.73493508360118 + 0.72780639619484 + 0.72018775415672 + 0.71204838617793 + 0.70339738390183 + 0.69425443288533 + 0.68464859308024 + 0.67461695618329 + 0.66420321852180 + 0.65345350897203 + 0.64236798775940 + 0.63099066895117 + 0.61936846798851 + 0.60755124469024 + 0.59559212944470 + 0.58354772602308 + 0.57145316729131 + 0.55933876774050 + 0.54725475824583 + 0.53524671729532 + 0.52335112941277 + 0.98782265518467 + 0.98782282766508 + 0.98782285638936 + 0.98782288992216 + 0.98782292908145 + 0.98782297482509 + 0.98782302827911 + 0.98782309077335 + 0.98782316389533 + 0.98782324962433 + 0.98782335071031 + 0.98782347102099 + 0.98782361520138 + 0.98782378851963 + 0.98782399721749 + 0.98782424887190 + 0.98782455275381 + 0.98782492022518 + 0.98782536576461 + 0.98782590787052 + 0.98782656893916 + 0.98782737694187 + 0.98782836693347 + 0.98782958301049 + 0.98783108118681 + 0.98783293501337 + 0.98783524575968 + 0.98783814669467 + 0.98784180417158 + 0.98784642929598 + 0.98785231108313 + 0.98785982190746 + 0.98786944625823 + 0.98788182088677 + 0.98789778491320 + 0.98791844719588 + 0.98794527744640 + 0.98798023016489 + 0.98802597098643 + 0.98808616562633 + 0.98816574108257 + 0.98827146194742 + 0.98841269269867 + 0.98860226082130 + 0.98885594754651 + 0.98919285243427 + 0.98964349963443 + 0.99025471573827 + 0.99109686296154 + 0.99230913932611 + 0.99425470447073 + 1.00000000000000 + 0.99354177194948 + 0.99031567171380 + 0.98745111969798 + 0.98462840280322 + 0.98170913472450 + 0.97860233586157 + 0.97523375145855 + 0.97153586850246 + 0.96744142127631 + 0.96287366962869 + 0.95775335928597 + 0.95201395932615 + 0.94559783921630 + 0.93844928835584 + 0.93052412359287 + 0.92179025151034 + 0.91223104351823 + 0.90185045274376 + 0.89067895105435 + 0.87877885940831 + 0.86624303318591 + 0.85318206300046 + 0.83973666823101 + 0.82609575894739 + 0.81246440324161 + 0.80570567304595 + 0.79901174568724 + 0.79239447487348 + 0.78585986679340 + 0.77940759565875 + 0.77303091649794 + 0.76671711971397 + 0.76044862951724 + 0.75420458461120 + 0.74795927690757 + 0.74162702478105 + 0.73496276075421 + 0.72783263497746 + 0.72021253352531 + 0.71207168492931 + 0.70341918916701 + 0.69427474199532 + 0.68466741515981 + 0.67463431325775 + 0.66421914583524 + 0.65346805395163 + 0.64238120195644 + 0.63100261283865 + 0.61937920897078 + 0.60756085515467 + 0.59560068507614 + 0.58355530450044 + 0.57145984549610 + 0.55934462135035 + 0.54725986326993 + 0.53525114964246 + 0.52335496417165 + 0.98634919286249 + 0.98634934186563 + 0.98634936667577 + 0.98634939563841 + 0.98634942945824 + 0.98634946896053 + 0.98634951511801 + 0.98634956907661 + 0.98634963220657 + 0.98634970621654 + 0.98634979349758 + 0.98634989743105 + 0.98635002207709 + 0.98635017203456 + 0.98635035274921 + 0.98635057082916 + 0.98635083436426 + 0.98635115326482 + 0.98635154018230 + 0.98635201129507 + 0.98635258617728 + 0.98635328926979 + 0.98635415120133 + 0.98635521049722 + 0.98635651609261 + 0.98635813230536 + 0.98636014794035 + 0.98636267994875 + 0.98636587413883 + 0.98636991537875 + 0.98637505716555 + 0.98638162586347 + 0.98639004582043 + 0.98640087442251 + 0.98641484563315 + 0.98643292832389 + 0.98645640488795 + 0.98648697759626 + 0.98652696467245 + 0.98657954758643 + 0.98664898365108 + 0.98674108775649 + 0.98686385091517 + 0.98702808749970 + 0.98724672044240 + 0.98753467450705 + 0.98791529173543 + 0.98842252313797 + 0.98910195246580 + 0.99003304520565 + 0.99137674541345 + 0.99354177194948 + 1.00000000000000 + 0.99272805921323 + 0.98910780982567 + 0.98589202126523 + 0.98272148920036 + 0.97943729511704 + 0.97593560657842 + 0.97213351438506 + 0.96795481861889 + 0.96331710812677 + 0.95813754856393 + 0.95234746052017 + 0.94588775142603 + 0.93870156588227 + 0.93074383769525 + 0.92198175090311 + 0.91239807302067 + 0.90199624772316 + 0.89080631400330 + 0.87889022317455 + 0.86634050695393 + 0.85326746109358 + 0.83981157137377 + 0.82616158587763 + 0.81252243574663 + 0.80576024190381 + 0.79906311973610 + 0.79244290461800 + 0.78590558419403 + 0.77945081405255 + 0.77307183062284 + 0.76675590581398 + 0.76048544565354 + 0.75423957120790 + 0.74799255659887 + 0.74165868622944 + 0.73499281931929 + 0.72786107390860 + 0.72023933687861 + 0.71209683660192 + 0.70344268224937 + 0.69429658066998 + 0.68468761626303 + 0.67465290730627 + 0.66423617722390 + 0.65348357968482 + 0.64239528284103 + 0.63101531864368 + 0.61939061623622 + 0.60757104506919 + 0.59560974169468 + 0.58356331340828 + 0.57146689091595 + 0.55935078581692 + 0.54726522935099 + 0.53525579953514 + 0.52335897898332 + 0.98469590392430 + 0.98469603290704 + 0.98469605437910 + 0.98469607944388 + 0.98469610871038 + 0.98469614289201 + 0.98469618283032 + 0.98469622951347 + 0.98469628412259 + 0.98469634814450 + 0.98469642365792 + 0.98469651363123 + 0.98469662162320 + 0.98469675166021 + 0.98469690850892 + 0.98469709795219 + 0.98469732706701 + 0.98469760453213 + 0.98469794143767 + 0.98469835198233 + 0.98469885333165 + 0.98469946692130 + 0.98470021960730 + 0.98470114516570 + 0.98470228650160 + 0.98470370007524 + 0.98470546405584 + 0.98470768149082 + 0.98471048068814 + 0.98471402416922 + 0.98471853518886 + 0.98472430095225 + 0.98473169465991 + 0.98474120626807 + 0.98475348050741 + 0.98476936770167 + 0.98478999200427 + 0.98481684337185 + 0.98485194887083 + 0.98489808653152 + 0.98495896069257 + 0.98503961113526 + 0.98514692552054 + 0.98529013718974 + 0.98548000761257 + 0.98572846615831 + 0.98605395028703 + 0.98648229183544 + 0.98704534406880 + 0.98779488723999 + 0.98882440012022 + 0.99031567171380 + 0.99272805921323 + 1.00000000000000 + 0.99179760636243 + 0.98773422647160 + 0.98412512529680 + 0.98056164080000 + 0.97686273600992 + 0.97291211593145 + 0.96861642180976 + 0.96388332671481 + 0.95862409289306 + 0.95276657447079 + 0.94624938447868 + 0.93901393966283 + 0.93101387355266 + 0.92221533091113 + 0.91260022656465 + 0.90217129464693 + 0.89095797736276 + 0.87902172025484 + 0.86645461574327 + 0.85336656377130 + 0.83989773481316 + 0.82623665239095 + 0.81258805665274 + 0.80582169533821 + 0.79912074782951 + 0.79249702487179 + 0.78595648939229 + 0.77949877236537 + 0.77311708581708 + 0.76679867762323 + 0.76052593035288 + 0.75427794253602 + 0.74802896586630 + 0.74169324440037 + 0.73502555343416 + 0.72789197451846 + 0.72026839537730 + 0.71212404415835 + 0.70346804016467 + 0.69432010226647 + 0.68470932838792 + 0.67467285123823 + 0.66425440869290 + 0.65350016734808 + 0.64241029862841 + 0.63102884333278 + 0.61940273703544 + 0.60758185332568 + 0.59561933102123 + 0.58357177833703 + 0.57147432391624 + 0.55935727707231 + 0.54727086869305 + 0.53526067609371 + 0.52336318046810 + 0.98283748365780 + 0.98283759560456 + 0.98283761423795 + 0.98283763598739 + 0.98283766138201 + 0.98283769103867 + 0.98283772568523 + 0.98283776617892 + 0.98283781354715 + 0.98283786907299 + 0.98283793458106 + 0.98283801267954 + 0.98283810650376 + 0.98283821958907 + 0.98283835612369 + 0.98283852118314 + 0.98283872098602 + 0.98283896315992 + 0.98283925745878 + 0.98283961639852 + 0.98284005508863 + 0.98284059239985 + 0.98284125197762 + 0.98284206355328 + 0.98284306489465 + 0.98284430576363 + 0.98284585526106 + 0.98284780457152 + 0.98285026707694 + 0.98285338626546 + 0.98285735959898 + 0.98286244091538 + 0.98286895984093 + 0.98287734893934 + 0.98288817705161 + 0.98290219381423 + 0.98292038922665 + 0.98294407371284 + 0.98297502887945 + 0.98301569403014 + 0.98306931234012 + 0.98314028269866 + 0.98323459115491 + 0.98336020114826 + 0.98352618989034 + 0.98374224963806 + 0.98402328003432 + 0.98438958333550 + 0.98486449776932 + 0.98548443891249 + 0.98631137668933 + 0.98745111969798 + 0.98910780982567 + 0.99179760636243 + 1.00000000000000 + 0.99073761010592 + 0.98617853208022 + 0.98212607156198 + 0.97811608555990 + 0.97394501220103 + 0.96948220224617 + 0.96461632821072 + 0.95924820636013 + 0.95329978961441 + 0.94670593539398 + 0.93940536041318 + 0.93134972894221 + 0.92250365678672 + 0.91284783313350 + 0.90238399007049 + 0.89114073816050 + 0.87917882525167 + 0.86658974367693 + 0.85348285905097 + 0.83999791485716 + 0.82632312410843 + 0.81266296190563 + 0.80589153384135 + 0.79918595835449 + 0.79255801305108 + 0.78601362782963 + 0.77955240095540 + 0.77316751227889 + 0.76684617819939 + 0.76057075080991 + 0.75432029955780 + 0.74806904759628 + 0.74173119052911 + 0.73506140664980 + 0.72792573561365 + 0.72030006592050 + 0.71215362533049 + 0.70349554430198 + 0.69434555472631 + 0.68473276894699 + 0.67469433483473 + 0.66427400522752 + 0.65351795982698 + 0.64242637255328 + 0.63104329276167 + 0.61941566191307 + 0.60759335702199 + 0.59562951836847 + 0.58358075429516 + 0.57148219051435 + 0.55936413331639 + 0.54727681275672 + 0.53526580502920 + 0.52336758949661 + 0.98074532250084 + 0.98074541998818 + 0.98074543621091 + 0.98074545514683 + 0.98074547725359 + 0.98074550306994 + 0.98074553322780 + 0.98074556847233 + 0.98074560969302 + 0.98074565801471 + 0.98074571503312 + 0.98074578305513 + 0.98074586485185 + 0.98074596354267 + 0.98074608281601 + 0.98074622715546 + 0.98074640204118 + 0.98074661420273 + 0.98074687226054 + 0.98074718729340 + 0.98074757265877 + 0.98074804504540 + 0.98074862535684 + 0.98074933988477 + 0.98075022201986 + 0.98075131582064 + 0.98075268265085 + 0.98075440356206 + 0.98075657921788 + 0.98075933687156 + 0.98076285198736 + 0.98076734993793 + 0.98077312321914 + 0.98078055548226 + 0.98079015095209 + 0.98080257359595 + 0.98081869944374 + 0.98083968667170 + 0.98086710915570 + 0.98090312037783 + 0.98095057631997 + 0.98101334122738 + 0.98109665565661 + 0.98120744688534 + 0.98135345175922 + 0.98154264400362 + 0.98178727218493 + 0.98210366969013 + 0.98250949008094 + 0.98303163172692 + 0.98371449542819 + 0.98462840280322 + 0.98589202126523 + 0.98773422647160 + 0.99073761010592 + 1.00000000000000 + 0.98953658637558 + 0.98442049967240 + 0.97986500573127 + 0.97534593813363 + 0.97063481913737 + 0.96557901397766 + 0.96005908218130 + 0.95398623234013 + 0.94728884876103 + 0.93990124826821 + 0.93177201021206 + 0.92286343903729 + 0.91315442386259 + 0.90264525767090 + 0.89136337698704 + 0.87936855762707 + 0.86675146594884 + 0.85362074167595 + 0.84011554771965 + 0.82642366809694 + 0.81274921113919 + 0.80597156575847 + 0.79926033936235 + 0.79262726490347 + 0.78607822799042 + 0.77961278330001 + 0.77322406804265 + 0.76689925717305 + 0.76062066291768 + 0.75436731694344 + 0.74811340576087 + 0.74177306617728 + 0.73510086342220 + 0.72796278857439 + 0.72033473066696 + 0.71218591674261 + 0.70352548948678 + 0.69437319484590 + 0.68475816044328 + 0.67471754995357 + 0.66429513152519 + 0.65353709793957 + 0.64244362448741 + 0.63105876852301 + 0.61942947657609 + 0.60760562809463 + 0.59564036376176 + 0.58359029102585 + 0.57149053158956 + 0.55937138781981 + 0.54728308833776 + 0.53527120768650 + 0.52337222289957 + 0.97838758934593 + 0.97838767458762 + 0.97838768877068 + 0.97838770532410 + 0.97838772464829 + 0.97838774721244 + 0.97838777357011 + 0.97838780437095 + 0.97838784039001 + 0.97838788261228 + 0.97838793244522 + 0.97838799193556 + 0.97838806354211 + 0.97838815003247 + 0.97838825467377 + 0.97838838143325 + 0.97838853517064 + 0.97838872185243 + 0.97838894913136 + 0.97838922685888 + 0.97838956690219 + 0.97838998408750 + 0.97839049699354 + 0.97839112897087 + 0.97839190968952 + 0.97839287834496 + 0.97839408969732 + 0.97839561615530 + 0.97839754752020 + 0.97839999720706 + 0.97840312189479 + 0.97840712267931 + 0.97841226037217 + 0.97841887691771 + 0.97842742145859 + 0.97843848499323 + 0.97845284656340 + 0.97847153496757 + 0.97849594779944 + 0.97852799647539 + 0.97857021033403 + 0.97862600474313 + 0.97869999858915 + 0.97879826402722 + 0.97892745462762 + 0.97909419624308 + 0.97930869500041 + 0.97958432655209 + 0.97993474893444 + 0.98038051839764 + 0.98095511508511 + 0.98170913472450 + 0.98272148920036 + 0.98412512529680 + 0.98617853208022 + 0.98953658637558 + 1.00000000000000 + 0.98817808679128 + 0.98243339812240 + 0.97730442736464 + 0.97220157794533 + 0.96686356893973 + 0.96112642646055 + 0.95488001808832 + 0.94804082969911 + 0.94053563430006 + 0.93230797908404 + 0.92331655923635 + 0.91353755126161 + 0.90296913939140 + 0.89163707694797 + 0.87959976957228 + 0.86694673666955 + 0.85378562500321 + 0.84025480450457 + 0.82654146623545 + 0.81284921173543 + 0.80606388054039 + 0.79934570316470 + 0.79270635231138 + 0.78615165411050 + 0.77968110498267 + 0.77328778544208 + 0.76695881565617 + 0.76067645543986 + 0.75441968709450 + 0.74816264978510 + 0.74181940836055 + 0.73514439542099 + 0.72800354522884 + 0.72037274681022 + 0.71222122589109 + 0.70355813843918 + 0.69440324539912 + 0.68478569040532 + 0.67474265334640 + 0.66431791774421 + 0.65355768906750 + 0.64246214238747 + 0.63107534212008 + 0.61944423866103 + 0.60761871253276 + 0.59565190343545 + 0.58360041661696 + 0.57149936845014 + 0.55937905627925 + 0.54728970654104 + 0.53527689148567 + 0.52337708520506 + 0.97572724591573 + 0.97572732080739 + 0.97572733326609 + 0.97572734780489 + 0.97572736477700 + 0.97572738459345 + 0.97572740773894 + 0.97572743478236 + 0.97572746640627 + 0.97572750347426 + 0.97572754723271 + 0.97572759951026 + 0.97572766249789 + 0.97572773865970 + 0.97572783090513 + 0.97572794276769 + 0.97572807857476 + 0.97572824363984 + 0.97572844479197 + 0.97572869083859 + 0.97572899237211 + 0.97572936263597 + 0.97572981821629 + 0.97573037996456 + 0.97573107437350 + 0.97573193649080 + 0.97573301542933 + 0.97573437619995 + 0.97573609932300 + 0.97573828638468 + 0.97574107799633 + 0.97574465448683 + 0.97574924957740 + 0.97575516956127 + 0.97576281650615 + 0.97577271908081 + 0.97578557353289 + 0.97580229835407 + 0.97582414095974 + 0.97585280683406 + 0.97589054826291 + 0.97594040128126 + 0.97600646214302 + 0.97609409001264 + 0.97620905109287 + 0.97635689525153 + 0.97654621886421 + 0.97678812638081 + 0.97709335286952 + 0.97747799230828 + 0.97796820236900 + 0.97860233586157 + 0.97943729511704 + 0.98056164080000 + 0.98212607156198 + 0.98442049967240 + 0.98817808679128 + 1.00000000000000 + 0.98664309363465 + 0.98018460171824 + 0.97439635485000 + 0.96861354310703 + 0.96255373870376 + 0.95605896867845 + 0.94902192225841 + 0.94135558280313 + 0.93299486847674 + 0.92389260945917 + 0.91402076261376 + 0.90337434388010 + 0.89197664592874 + 0.87988411395881 + 0.86718465647351 + 0.85398454982565 + 0.84042107414263 + 0.82668059895263 + 0.81296602530540 + 0.80617112353760 + 0.79944433348419 + 0.79279724641978 + 0.78623560844989 + 0.77975883792756 + 0.77335993975535 + 0.76702596137203 + 0.76073909339975 + 0.75447825330794 + 0.74821751870881 + 0.74187086564870 + 0.73519257004278 + 0.72804849910290 + 0.72041454082209 + 0.71225991861069 + 0.70359380265167 + 0.69443596968226 + 0.68481557982515 + 0.67476982926702 + 0.66434251654181 + 0.65357985893626 + 0.64248202910692 + 0.63109309710116 + 0.61946001550385 + 0.60763266409517 + 0.59566417980774 + 0.58361116403601 + 0.57150872620888 + 0.55938715732432 + 0.54729668070346 + 0.53528286551335 + 0.52338218216597 + 0.97272225428316 + 0.97272232042796 + 0.97272233142968 + 0.97272234426855 + 0.97272235925301 + 0.97272237674905 + 0.97272239718161 + 0.97272242105301 + 0.97272244896443 + 0.97272248167870 + 0.97272252030955 + 0.97272256648930 + 0.97272262218972 + 0.97272268961036 + 0.97272277135821 + 0.97272287059472 + 0.97272299119483 + 0.97272313791515 + 0.97272331688147 + 0.97272353600310 + 0.97272380479080 + 0.97272413512611 + 0.97272454189844 + 0.97272504381816 + 0.97272566466248 + 0.97272643592768 + 0.97272740187937 + 0.97272862117434 + 0.97273016637209 + 0.97273212891658 + 0.97273463561602 + 0.97273784896561 + 0.97274197943429 + 0.97274730270436 + 0.97275418044313 + 0.97276308783871 + 0.97277465014855 + 0.97278969133743 + 0.97280933021356 + 0.97283509606628 + 0.97286900469283 + 0.97291376923559 + 0.97297304286828 + 0.97305158425441 + 0.97315442342526 + 0.97328623725610 + 0.97345432772893 + 0.97366801005144 + 0.97393580781622 + 0.97427053404549 + 0.97469314112089 + 0.97523375145855 + 0.97593560657842 + 0.97686273600992 + 0.97811608555990 + 0.97986500573127 + 0.98243339812240 + 0.98664309363465 + 1.00000000000000 + 0.98490797558566 + 0.97762952212453 + 0.97107032394761 + 0.96450247862434 + 0.95763887597187 + 0.95031866318800 + 0.94242741298345 + 0.93388428408443 + 0.92463209339958 + 0.91463597095705 + 0.90388602194230 + 0.89240185277974 + 0.88023704985567 + 0.86747722577748 + 0.85422674384743 + 0.84062137396413 + 0.82684634238527 + 0.81310357988153 + 0.80629667453887 + 0.79955913537887 + 0.79290244341946 + 0.78633223682070 + 0.77984782907131 + 0.77344212389428 + 0.76710207186515 + 0.76080977184964 + 0.75454405577472 + 0.74827892078824 + 0.74192823239468 + 0.73524608005080 + 0.72809825102182 + 0.72046063052720 + 0.71230243803733 + 0.70363285864662 + 0.69447168539975 + 0.68484809500515 + 0.67479929955248 + 0.66436911165709 + 0.65360375890526 + 0.64250340858147 + 0.63111213430849 + 0.61947688857169 + 0.60764754804869 + 0.59567724461707 + 0.58362257375895 + 0.57151863598888 + 0.55939571434730 + 0.54730402790431 + 0.53528914177308 + 0.52338752179045 + 0.96932616742859 + 0.96932622618648 + 0.96932623595707 + 0.96932624735778 + 0.96932626066500 + 0.96932627619888 + 0.96932629434002 + 0.96932631553152 + 0.96932634030598 + 0.96932636934316 + 0.96932640363762 + 0.96932644466206 + 0.96932649419153 + 0.96932655420981 + 0.96932662705861 + 0.96932671558264 + 0.96932682326900 + 0.96932695439763 + 0.96932711449277 + 0.96932731069394 + 0.96932755157782 + 0.96932784786732 + 0.96932821298502 + 0.96932866380661 + 0.96932922177892 + 0.96932991533349 + 0.96933078456638 + 0.96933188265736 + 0.96933327529256 + 0.96933504517177 + 0.96933730719076 + 0.96934020844651 + 0.96934393933928 + 0.96934874912681 + 0.96935496460733 + 0.96936301481422 + 0.96937346376700 + 0.96938705393069 + 0.96940479327668 + 0.96942805931558 + 0.96945866450675 + 0.96949904497086 + 0.96955247489672 + 0.96962320206258 + 0.96971563825574 + 0.96983374126586 + 0.96998375327624 + 0.97017354794012 + 0.97040992621525 + 0.97070319754762 + 0.97107043408205 + 0.97153586850246 + 0.97213351438506 + 0.97291211593145 + 0.97394501220103 + 0.97534593813363 + 0.97730442736464 + 0.98018460171824 + 0.98490797558566 + 1.00000000000000 + 0.98293636693677 + 0.97469735654826 + 0.96724503280304 + 0.95980119192350 + 0.95206048759654 + 0.94384725835228 + 0.93504940007789 + 0.92559152887692 + 0.91542717391863 + 0.90453852683008 + 0.89293949907857 + 0.88067940616496 + 0.86784052611344 + 0.85452451177576 + 0.84086501691583 + 0.82704566570122 + 0.81326703929837 + 0.80644496612575 + 0.79969390994791 + 0.79302520207602 + 0.78644433467362 + 0.77995047990707 + 0.77353640569180 + 0.76718893308599 + 0.76089003879019 + 0.75461844133761 + 0.74834803209004 + 0.74199253775906 + 0.73530582401753 + 0.72815358173565 + 0.72051169052995 + 0.71234936340486 + 0.70367580067701 + 0.69451081175797 + 0.68488358952182 + 0.67483136091035 + 0.66439795094215 + 0.65362959516432 + 0.64252645155258 + 0.63113259446156 + 0.61949497324485 + 0.60766345842641 + 0.59569117394179 + 0.58363470678530 + 0.57152914614660 + 0.55940476515499 + 0.54731177722320 + 0.53529574222158 + 0.52339312032456 + 0.96548643643924 + 0.96548648894080 + 0.96548649766872 + 0.96548650785344 + 0.96548651973885 + 0.96548653361216 + 0.96548654981149 + 0.96548656873361 + 0.96548659085161 + 0.96548661677303 + 0.96548664739478 + 0.96548668404944 + 0.96548672834405 + 0.96548678207380 + 0.96548684735528 + 0.96548692675954 + 0.96548702344184 + 0.96548714127336 + 0.96548728525701 + 0.96548746186788 + 0.96548767888005 + 0.96548794600966 + 0.96548827541908 + 0.96548868239726 + 0.96548918637116 + 0.96548981312748 + 0.96549059913933 + 0.96549159281933 + 0.96549285389413 + 0.96549445746997 + 0.96549650807464 + 0.96549913942177 + 0.96550252444945 + 0.96550688943609 + 0.96551253084232 + 0.96551983756783 + 0.96552932036568 + 0.96554165087564 + 0.96555774072655 + 0.96557883554594 + 0.96560657136527 + 0.96564314433294 + 0.96569150113024 + 0.96575544994671 + 0.96583887682213 + 0.96594513878365 + 0.96607959568523 + 0.96624893626922 + 0.96645858607823 + 0.96671688414227 + 0.96703789527909 + 0.96744142127631 + 0.96795481861889 + 0.96861642180976 + 0.96948220224617 + 0.97063481913737 + 0.97220157794533 + 0.97439635485000 + 0.97762952212453 + 0.98293636693677 + 1.00000000000000 + 0.98066485130384 + 0.97130915179120 + 0.96285645125516 + 0.95445391373727 + 0.94576197812687 + 0.93659887489861 + 0.92685326160813 + 0.91645766154416 + 0.90538086163606 + 0.89362761956386 + 0.88124066617100 + 0.86829731339836 + 0.85489529605611 + 0.84116525670234 + 0.82728855070754 + 0.81346386849647 + 0.80662244385783 + 0.79985422208098 + 0.79317033033281 + 0.78657606247548 + 0.78007039945729 + 0.77364592609757 + 0.76728928948214 + 0.76098230285159 + 0.75470353359874 + 0.74842673313587 + 0.74206545195836 + 0.73537328377566 + 0.72821580146553 + 0.72056887473266 + 0.71240170633919 + 0.70372351167318 + 0.69455411613124 + 0.68492272774628 + 0.67486658656745 + 0.66442952752217 + 0.65365779083249 + 0.64255151999742 + 0.63115478632921 + 0.61951453209610 + 0.60768061775380 + 0.59570615562834 + 0.58364772097222 + 0.57154038863180 + 0.55941441936674 + 0.54732001916376 + 0.53530274114528 + 0.52339903846251 + 0.96113750502590 + 0.96113755219463 + 0.96113756003540 + 0.96113756918183 + 0.96113757985640 + 0.96113759231488 + 0.96113760686035 + 0.96113762384736 + 0.96113764370165 + 0.96113766696817 + 0.96113769445745 + 0.96113772738175 + 0.96113776720381 + 0.96113781555458 + 0.96113787435479 + 0.96113794593975 + 0.96113803317262 + 0.96113813957315 + 0.96113826968819 + 0.96113842941668 + 0.96113862583016 + 0.96113886776499 + 0.96113916628600 + 0.96113953529586 + 0.96113999245281 + 0.96114056123011 + 0.96114127491533 + 0.96114217773415 + 0.96114332416677 + 0.96114478264762 + 0.96114664857494 + 0.96114904386778 + 0.96115212608983 + 0.96115610127011 + 0.96116123914474 + 0.96116789324093 + 0.96117652740759 + 0.96118775089985 + 0.96120239049112 + 0.96122157562995 + 0.96124678712825 + 0.96128001022728 + 0.96132390432111 + 0.96138189340857 + 0.96145740952713 + 0.96155330048727 + 0.96167417888152 + 0.96182574059411 + 0.96201229055842 + 0.96224057747514 + 0.96252225980915 + 0.96287366962869 + 0.96331710812677 + 0.96388332671481 + 0.96461632821072 + 0.96557901397766 + 0.96686356893973 + 0.96861354310703 + 0.97107032394761 + 0.97469735654826 + 0.98066485130384 + 1.00000000000000 + 0.97803896554140 + 0.96741904614572 + 0.95786270511580 + 0.94841426142020 + 0.93870562624366 + 0.92854539510489 + 0.91782460718360 + 0.90648777686997 + 0.89452415050549 + 0.88196586689871 + 0.86888258291425 + 0.85536620706263 + 0.84154299989389 + 0.82759105110557 + 0.81370637041728 + 0.80683988234101 + 0.80004951907021 + 0.79334612736358 + 0.78673472991804 + 0.78021404721545 + 0.77377641559558 + 0.76740824690170 + 0.76109113408339 + 0.75480344158531 + 0.74851873401551 + 0.74215033442989 + 0.73545149856700 + 0.72828765159063 + 0.72063464723658 + 0.71246167276746 + 0.70377795842880 + 0.69460334515823 + 0.68496705497293 + 0.67490633892309 + 0.66446503873984 + 0.65368939519698 + 0.64257953049734 + 0.63117950805787 + 0.61953625792577 + 0.60769962536941 + 0.59572270627577 + 0.58366205984391 + 0.57155274251566 + 0.55942499934908 + 0.54732902652415 + 0.53531036837968 + 0.52340546918549 + 0.95620794978686 + 0.95620799236939 + 0.95620799944582 + 0.95620800769997 + 0.95620801733297 + 0.95620802857435 + 0.95620804169707 + 0.95620805702077 + 0.95620807492813 + 0.95620809591155 + 0.95620812070543 + 0.95620815041839 + 0.95620818638427 + 0.95620823008858 + 0.95620828328424 + 0.95620834809604 + 0.95620842713703 + 0.95620852360823 + 0.95620864166369 + 0.95620878668896 + 0.95620896513591 + 0.95620918506583 + 0.95620945657409 + 0.95620979233365 + 0.95621020844585 + 0.95621072632956 + 0.95621137643892 + 0.95621219926841 + 0.95621324462978 + 0.95621457502082 + 0.95621627769121 + 0.95621846404597 + 0.95622127792836 + 0.95622490731233 + 0.95622959808495 + 0.95623567223170 + 0.95624355175212 + 0.95625379029532 + 0.95626713894180 + 0.95628462348427 + 0.95630758639363 + 0.95633782512002 + 0.95637774359409 + 0.95643042537095 + 0.95649890535485 + 0.95658559500139 + 0.95669446553943 + 0.95683036871172 + 0.95699668407181 + 0.95719885424184 + 0.95744656746008 + 0.95775335928597 + 0.95813754856393 + 0.95862409289306 + 0.95924820636013 + 0.96005908218130 + 0.96112642646055 + 0.96255373870376 + 0.96450247862434 + 0.96724503280304 + 0.97130915179120 + 0.97803896554140 + 1.00000000000000 + 0.97503481781810 + 0.96299671203877 + 0.95222358950527 + 0.94164845055366 + 0.93086563884597 + 0.91967370074401 + 0.90796914176509 + 0.89571307722457 + 0.88291966542673 + 0.86964623909124 + 0.85597572982849 + 0.84202783821418 + 0.82797585144789 + 0.81401191625645 + 0.80711249273318 + 0.80029313784368 + 0.79356430972852 + 0.78693065722936 + 0.78039054336075 + 0.77393596482561 + 0.76755301311418 + 0.76122298223189 + 0.75492396211164 + 0.74862926596042 + 0.74225191873201 + 0.73554474693400 + 0.72837298692379 + 0.72071246818504 + 0.71253235528563 + 0.70384189320073 + 0.69466093801211 + 0.68501872439064 + 0.67495251179545 + 0.66450614484661 + 0.65372585948658 + 0.64261174745619 + 0.63120785781467 + 0.61956110150727 + 0.60772130169090 + 0.59574153126088 + 0.58367832748241 + 0.57156672278602 + 0.55943694192497 + 0.54733916796233 + 0.53531893364079 + 0.52341267178225 + 0.95063593993336 + 0.95063597853625 + 0.95063598494858 + 0.95063599243007 + 0.95063600115843 + 0.95063601134383 + 0.95063602323167 + 0.95063603711225 + 0.95063605333128 + 0.95063607233334 + 0.95063609478757 + 0.95063612170973 + 0.95063615432036 + 0.95063619397847 + 0.95063624228192 + 0.95063630117738 + 0.95063637304904 + 0.95063646082352 + 0.95063656829745 + 0.95063670040550 + 0.95063686304643 + 0.95063706359592 + 0.95063731128016 + 0.95063761768165 + 0.95063799751162 + 0.95063847035797 + 0.95063906413813 + 0.95063981599952 + 0.95064077156604 + 0.95064198802304 + 0.95064354530797 + 0.95064554538263 + 0.95064811979383 + 0.95065144030897 + 0.95065573142696 + 0.95066128683710 + 0.95066849104077 + 0.95067784784256 + 0.95069004048459 + 0.95070600181596 + 0.95072695040895 + 0.95075451567841 + 0.95079087325524 + 0.95083880344531 + 0.95090099213259 + 0.95097947551679 + 0.95107767144572 + 0.95119970950124 + 0.95134820067094 + 0.95152750528113 + 0.95174567733224 + 0.95201395932615 + 0.95234746052017 + 0.95276657447079 + 0.95329978961441 + 0.95398623234013 + 0.95488001808832 + 0.95605896867845 + 0.95763887597187 + 0.95980119192350 + 0.96285645125516 + 0.96741904614572 + 0.97503481781810 + 1.00000000000000 + 0.97161594673545 + 0.95799096386446 + 0.94589466574396 + 0.93412031613195 + 0.92221905041656 + 0.90998034916288 + 0.89730970417260 + 0.88418867159514 + 0.87065368839416 + 0.85677327294164 + 0.84265697976079 + 0.82847085238595 + 0.81440136284102 + 0.80745830344271 + 0.80060067270048 + 0.79383838512884 + 0.78717557001811 + 0.78061009634740 + 0.77413349370865 + 0.76773141487917 + 0.76138474604090 + 0.75507120394399 + 0.74876376167898 + 0.74237505022825 + 0.73565734498322 + 0.72847563829668 + 0.72080572354291 + 0.71261673239951 + 0.70391792368775 + 0.69472916743354 + 0.68507970851025 + 0.67500681068812 + 0.66455431564705 + 0.65376844679085 + 0.64264925291349 + 0.63124075976675 + 0.61958984977577 + 0.60774631461728 + 0.59576319537238 + 0.58369699949159 + 0.57158272796082 + 0.55945057911293 + 0.54735071848379 + 0.53532866346836 + 0.52342083204492 + 0.94436714563568 + 0.94436718074954 + 0.94436718658120 + 0.94436719338343 + 0.94436720131911 + 0.94436721057876 + 0.94436722138560 + 0.94436723400118 + 0.94436724874032 + 0.94436726600556 + 0.94436728641216 + 0.94436731088582 + 0.94436734054842 + 0.94436737664729 + 0.94436742064455 + 0.94436747432276 + 0.94436753986398 + 0.94436761995210 + 0.94436771806380 + 0.94436783872507 + 0.94436798734576 + 0.94436817068464 + 0.94436839718900 + 0.94436867746873 + 0.94436902498983 + 0.94436945769371 + 0.94437000121775 + 0.94437068968980 + 0.94437156497358 + 0.94437267947170 + 0.94437410652938 + 0.94437593961416 + 0.94437829919791 + 0.94438134246494 + 0.94438527468665 + 0.94439036410810 + 0.94439696153043 + 0.94440552601196 + 0.94441667986449 + 0.94443127245597 + 0.94445041121982 + 0.94447557496669 + 0.94450873499567 + 0.94455240108215 + 0.94460895201725 + 0.94468010129287 + 0.94476878864621 + 0.94487852456051 + 0.94501128087535 + 0.94517051743452 + 0.94536292272453 + 0.94559783921630 + 0.94588775142603 + 0.94624938447868 + 0.94670593539398 + 0.94728884876103 + 0.94804082969911 + 0.94902192225841 + 0.95031866318800 + 0.95206048759654 + 0.95445391373727 + 0.95786270511580 + 0.96299671203877 + 0.97161594673545 + 1.00000000000000 + 0.96772402491865 + 0.95234926758054 + 0.93883108362633 + 0.92579821542797 + 0.91275415431645 + 0.89948053560884 + 0.88589452548300 + 0.87199475338862 + 0.85782539064176 + 0.84347966036584 + 0.82911233371784 + 0.81490134514888 + 0.80790012117927 + 0.80099165958076 + 0.79418510590909 + 0.78748386058987 + 0.78088510436302 + 0.77437971995570 + 0.76795275577155 + 0.76158453868601 + 0.75525227568792 + 0.74892847761164 + 0.74252525173209 + 0.73579416117073 + 0.72859988055433 + 0.72091814983463 + 0.71271805304507 + 0.70400886022222 + 0.69481045232974 + 0.68515207982826 + 0.67507100406065 + 0.66461105484029 + 0.65381843182875 + 0.64269312389069 + 0.63127912101920 + 0.61962326427304 + 0.60777530123880 + 0.59578822943694 + 0.58371851608632 + 0.57160112102413 + 0.55946620821312 + 0.54736391987237 + 0.53533975313974 + 0.52343010675272 + 0.93734866584697 + 0.93734869786348 + 0.93734870317954 + 0.93734870937998 + 0.93734871661340 + 0.93734872505215 + 0.93734873489909 + 0.93734874639313 + 0.93734875982011 + 0.93734877554681 + 0.93734879413469 + 0.93734881643564 + 0.93734884348102 + 0.93734887641266 + 0.93734891657564 + 0.93734896560316 + 0.93734902549565 + 0.93734909871641 + 0.93734918845746 + 0.93734929887573 + 0.93734943493695 + 0.93734960284250 + 0.93734981034464 + 0.93735006716869 + 0.93735038566008 + 0.93735078227874 + 0.93735128059357 + 0.93735191200014 + 0.93735271495503 + 0.93735373753677 + 0.93735504713108 + 0.93735672951539 + 0.93735889515222 + 0.93736168805999 + 0.93736529613703 + 0.93736996468724 + 0.93737601413031 + 0.93738386322485 + 0.93739407942077 + 0.93740743689452 + 0.93742494314306 + 0.93744794168690 + 0.93747822052633 + 0.93751804756691 + 0.93756953101720 + 0.93763410699026 + 0.93771430171526 + 0.93781309423248 + 0.93793192532179 + 0.93807350430370 + 0.93824337311868 + 0.93844928835584 + 0.93870156588227 + 0.93901393966283 + 0.93940536041318 + 0.93990124826821 + 0.94053563430006 + 0.94135558280313 + 0.94242741298345 + 0.94384725835228 + 0.94576197812687 + 0.94841426142020 + 0.95222358950527 + 0.95799096386446 + 0.96772402491865 + 1.00000000000000 + 0.96331366572331 + 0.94602697293082 + 0.93099851188715 + 0.91666654423267 + 0.90248185125184 + 0.88821828806211 + 0.87379991751399 + 0.85922699159659 + 0.84456506734621 + 0.82995065731042 + 0.81554844599903 + 0.80846911796691 + 0.80149267587413 + 0.79462716111500 + 0.78787493852791 + 0.78123221961539 + 0.77468898297683 + 0.76822943770343 + 0.76183313821065 + 0.75547659075065 + 0.74913167417871 + 0.74270979485807 + 0.73596158852214 + 0.72875131265032 + 0.72105462840353 + 0.71284055078726 + 0.70411835556971 + 0.69490792880546 + 0.68523851865142 + 0.67514737343328 + 0.66467829774625 + 0.65387745139068 + 0.64274474018842 + 0.63132410114320 + 0.61966231642993 + 0.60780907257736 + 0.59581730788047 + 0.58374343551657 + 0.57162236145655 + 0.55948420491053 + 0.54737907714934 + 0.53535244861480 + 0.52344069307419 + 0.92953857268844 + 0.92953860192341 + 0.92953860677645 + 0.92953861243680 + 0.92953861903884 + 0.92953862673988 + 0.92953863572579 + 0.92953864621396 + 0.92953865846323 + 0.92953867280941 + 0.92953868976457 + 0.92953871011430 + 0.92953873480690 + 0.92953876488983 + 0.92953880160100 + 0.92953884643573 + 0.92953890123526 + 0.92953896825662 + 0.92953905043524 + 0.92953915159572 + 0.92953927629577 + 0.92953943023230 + 0.92953962052788 + 0.92953985610555 + 0.92954014829185 + 0.92954051220289 + 0.92954096952698 + 0.92954154916929 + 0.92954228648614 + 0.92954322563985 + 0.92954442858992 + 0.92954597413201 + 0.92954796364899 + 0.92955052922582 + 0.92955384303298 + 0.92955812961895 + 0.92956368194545 + 0.92957088240806 + 0.92958024892995 + 0.92959248786012 + 0.92960851667453 + 0.92962955718140 + 0.92965723270868 + 0.92969359465606 + 0.92974051273040 + 0.92979918508073 + 0.92987178044500 + 0.92996082180255 + 0.93006731023756 + 0.93019333014722 + 0.93034345871041 + 0.93052412359287 + 0.93074383769525 + 0.93101387355266 + 0.93134972894221 + 0.93177201021206 + 0.93230797908404 + 0.93299486847674 + 0.93388428408443 + 0.93504940007789 + 0.93659887489861 + 0.93870562624366 + 0.94164845055366 + 0.94589466574396 + 0.95234926758054 + 0.96331366572331 + 1.00000000000000 + 0.95833367537520 + 0.93897942824833 + 0.92237035012283 + 0.90672562592816 + 0.89143651522899 + 0.87626136400262 + 0.86111407285811 + 0.84601018314811 + 0.83105510940190 + 0.81639215526241 + 0.80920712783401 + 0.80213911167499 + 0.79519453222011 + 0.78837425906117 + 0.78167312004128 + 0.77507981543937 + 0.76857737729922 + 0.76214428414259 + 0.75575607184927 + 0.74938374947104 + 0.74293777893392 + 0.73616758043117 + 0.72893685944355 + 0.72122116082808 + 0.71298939921496 + 0.70425084579578 + 0.69502538115886 + 0.68534223811532 + 0.67523863557152 + 0.66475833316292 + 0.65394742778469 + 0.64280571084642 + 0.63137704261329 + 0.61970812264240 + 0.60784855367304 + 0.59585119398031 + 0.58377238448570 + 0.57164696071440 + 0.55950498360537 + 0.54739652349278 + 0.53536701570594 + 0.52345280161575 + 0.92090669352424 + 0.92090672022975 + 0.92090672466230 + 0.92090672983146 + 0.92090673586002 + 0.92090674289234 + 0.92090675109573 + 0.92090676066938 + 0.92090677184902 + 0.92090678494172 + 0.92090680041598 + 0.92090681899542 + 0.92090684154880 + 0.92090686904304 + 0.92090690260963 + 0.92090694362739 + 0.92090699378544 + 0.92090705515685 + 0.92090713043733 + 0.92090722314698 + 0.92090733747608 + 0.92090747865791 + 0.92090765323307 + 0.92090786939956 + 0.92090813755843 + 0.92090847159164 + 0.92090889146876 + 0.92090942381255 + 0.92091010115521 + 0.92091096408126 + 0.92091206959438 + 0.92091349013523 + 0.92091531881688 + 0.92091767686846 + 0.92092072217761 + 0.92092466046114 + 0.92092975981062 + 0.92093636971316 + 0.92094496332128 + 0.92095618564933 + 0.92097087295902 + 0.92099013737962 + 0.92101545410246 + 0.92104868047350 + 0.92109147591772 + 0.92114483492712 + 0.92121061742563 + 0.92129095538638 + 0.92138648782321 + 0.92149878017921 + 0.92163159745537 + 0.92179025151034 + 0.92198175090311 + 0.92221533091113 + 0.92250365678672 + 0.92286343903729 + 0.92331655923635 + 0.92389260945917 + 0.92463209339958 + 0.92559152887692 + 0.92685326160813 + 0.92854539510489 + 0.93086563884597 + 0.93412031613195 + 0.93883108362633 + 0.94602697293082 + 0.95833367537520 + 1.00000000000000 + 0.95273198289786 + 0.93116854160361 + 0.91293489233335 + 0.89599847798232 + 0.87967566569418 + 0.86368894155102 + 0.84795531712709 + 0.83252371306232 + 0.81750117332118 + 0.81017172490647 + 0.80297927579426 + 0.79592782709958 + 0.78901604358703 + 0.78223674236817 + 0.77557678888905 + 0.76901754330525 + 0.76253596919418 + 0.75610624590660 + 0.74969817530974 + 0.74322093660616 + 0.73642234512300 + 0.72916536953006 + 0.72142538234861 + 0.71317115150421 + 0.70441192535139 + 0.69516756095781 + 0.68546725485043 + 0.67534817156954 + 0.66485399687079 + 0.65403073204168 + 0.64287801150906 + 0.63143958623675 + 0.61976204106264 + 0.60789486456506 + 0.59589080744656 + 0.58380611437534 + 0.57167552880782 + 0.55952903583594 + 0.54741665177008 + 0.53538376585188 + 0.52346667741930 + 0.91143805167349 + 0.91143807605710 + 0.91143808010266 + 0.91143808482053 + 0.91143809032280 + 0.91143809674075 + 0.91143810422557 + 0.91143811296060 + 0.91143812315974 + 0.91143813510226 + 0.91143814921779 + 0.91143816617125 + 0.91143818676316 + 0.91143821187795 + 0.91143824255778 + 0.91143828006682 + 0.91143832595688 + 0.91143838212899 + 0.91143845106456 + 0.91143853599770 + 0.91143864077810 + 0.91143877021767 + 0.91143893032456 + 0.91143912862418 + 0.91143937466792 + 0.91143968121449 + 0.91144006664769 + 0.91144055549395 + 0.91144117768907 + 0.91144197054551 + 0.91144298653005 + 0.91144429225578 + 0.91144597329210 + 0.91144814095908 + 0.91145094013433 + 0.91145455939919 + 0.91145924425611 + 0.91146531435530 + 0.91147320226200 + 0.91148349744417 + 0.91149696274233 + 0.91151461129981 + 0.91153778483923 + 0.91156816653914 + 0.91160723036175 + 0.91165579698914 + 0.91171545985010 + 0.91178801613620 + 0.91187380887931 + 0.91197397438725 + 0.91209159441316 + 0.91223104351823 + 0.91239807302067 + 0.91260022656465 + 0.91284783313350 + 0.91315442386259 + 0.91353755126161 + 0.91402076261376 + 0.91463597095705 + 0.91542717391863 + 0.91645766154416 + 0.91782460718360 + 0.91967370074401 + 0.92221905041656 + 0.92579821542797 + 0.93099851188715 + 0.93897942824833 + 0.95273198289786 + 1.00000000000000 + 0.94645893112968 + 0.92256738250957 + 0.90270004751717 + 0.88452869714615 + 0.86726611710141 + 0.85061049736838 + 0.83449897866389 + 0.81897302812207 + 0.81144378515363 + 0.80408036546079 + 0.79688301331689 + 0.78984705129093 + 0.78296230507055 + 0.77621295353988 + 0.76957794166420 + 0.76303206897008 + 0.75654759483106 + 0.75009262738472 + 0.74357458644361 + 0.73673915017902 + 0.72944829370137 + 0.72167713253116 + 0.71339421859441 + 0.70460874618811 + 0.69534051886880 + 0.68561866389272 + 0.67548025386719 + 0.66496885859365 + 0.65413033750772 + 0.64296411026134 + 0.63151377393874 + 0.61982575532210 + 0.60794938825972 + 0.59593727937279 + 0.58384554545889 + 0.57170880967372 + 0.55955695835655 + 0.54743993665910 + 0.53540307339201 + 0.52348261335366 + 0.90113801858185 + 0.90113804081270 + 0.90113804450043 + 0.90113804880093 + 0.90113805381563 + 0.90113805966466 + 0.90113806648620 + 0.90113807444436 + 0.90113808373567 + 0.90113809461455 + 0.90113810747434 + 0.90113812292317 + 0.90113814169889 + 0.90113816461202 + 0.90113819261758 + 0.90113822687738 + 0.90113826881102 + 0.90113832016785 + 0.90113838322347 + 0.90113846094837 + 0.90113855688195 + 0.90113867544004 + 0.90113882214011 + 0.90113900389269 + 0.90113922946263 + 0.90113951057327 + 0.90113986414295 + 0.90114031276705 + 0.90114088398936 + 0.90114161211372 + 0.90114254543280 + 0.90114374521512 + 0.90114529010883 + 0.90114728237566 + 0.90114985500135 + 0.90115318093915 + 0.90115748512665 + 0.90116306008915 + 0.90117030153684 + 0.90117974851914 + 0.90119209739760 + 0.90120827182572 + 0.90122949308758 + 0.90125728784103 + 0.90129296641594 + 0.90133720162837 + 0.90139135721076 + 0.90145694422112 + 0.90153406600527 + 0.90162350606285 + 0.90172777236597 + 0.90185045274376 + 0.90199624772316 + 0.90217129464693 + 0.90238399007049 + 0.90264525767090 + 0.90296913939140 + 0.90337434388010 + 0.90388602194230 + 0.90453852683008 + 0.90538086163606 + 0.90648777686997 + 0.90796914176509 + 0.90998034916288 + 0.91275415431645 + 0.91666654423267 + 0.92237035012283 + 0.93116854160361 + 0.94645893112968 + 1.00000000000000 + 0.93946918257443 + 0.91316287641365 + 0.89168934814897 + 0.87236506866299 + 0.85430438675905 + 0.83719522932304 + 0.82094987235720 + 0.81313960396699 + 0.80553780973173 + 0.79813866022509 + 0.79093222448344 + 0.78390373767765 + 0.77703333997026 + 0.77029640844454 + 0.76366459193845 + 0.75710738757835 + 0.75059049304115 + 0.74401888469931 + 0.73713536476815 + 0.72980055204102 + 0.72198917506343 + 0.71366946463172 + 0.70485050841781 + 0.69555200741297 + 0.68580296804413 + 0.67564031465339 + 0.66510744003578 + 0.65424999648101 + 0.64306711022022 + 0.63160216346126 + 0.61990136642395 + 0.60801384402097 + 0.59599201038188 + 0.58389181272845 + 0.57174771697837 + 0.55958948083454 + 0.54746695581228 + 0.53542539153077 + 0.52350096198578 + 0.89003828363715 + 0.89003830385933 + 0.89003830721350 + 0.89003831112413 + 0.89003831568409 + 0.89003832100207 + 0.89003832720361 + 0.89003833443950 + 0.89003834288536 + 0.89003835277414 + 0.89003836446388 + 0.89003837851297 + 0.89003839559597 + 0.89003841645781 + 0.89003844197266 + 0.89003847320376 + 0.89003851145404 + 0.89003855832213 + 0.89003861589859 + 0.89003868690861 + 0.89003877460142 + 0.89003888302766 + 0.89003901724699 + 0.89003918360169 + 0.89003939013180 + 0.89003964760090 + 0.89003997157316 + 0.89004038285043 + 0.89004090676943 + 0.89004157486426 + 0.89004243157690 + 0.89004353325437 + 0.89004495218950 + 0.89004678232774 + 0.89004914577067 + 0.89005220118393 + 0.89005615473619 + 0.89006127425182 + 0.89006792190564 + 0.89007659090561 + 0.89008791731295 + 0.89010274375464 + 0.89012218267627 + 0.89014761988952 + 0.89018022129258 + 0.89022053436155 + 0.89026972514802 + 0.89032906066586 + 0.89039845253893 + 0.89047839639348 + 0.89057091966109 + 0.89067895105435 + 0.89080631400330 + 0.89095797736276 + 0.89114073816050 + 0.89136337698704 + 0.89163707694797 + 0.89197664592874 + 0.89240185277974 + 0.89293949907857 + 0.89362761956386 + 0.89452415050549 + 0.89571307722457 + 0.89730970417260 + 0.89948053560884 + 0.90248185125184 + 0.90672562592816 + 0.91293489233335 + 0.92256738250957 + 0.93946918257443 + 1.00000000000000 + 0.93172207293232 + 0.90294922190543 + 0.87992457721910 + 0.85958465647580 + 0.84095016275192 + 0.82364643962293 + 0.81543175867226 + 0.80749095356482 + 0.79980781285968 + 0.79236374286113 + 0.78513663954116 + 0.77810035541934 + 0.77122483764859 + 0.76447703026162 + 0.75782236923558 + 0.75122305663940 + 0.74458062016330 + 0.73763394048184 + 0.73024175641365 + 0.72237820602940 + 0.71401103653252 + 0.70514914089762 + 0.69581203763954 + 0.68602853185243 + 0.67583531509732 + 0.66527551446758 + 0.65439448271366 + 0.64319094525144 + 0.63170798584111 + 0.61999151902629 + 0.60809038822850 + 0.59605675078087 + 0.58394632921225 + 0.57179338376817 + 0.55962750439856 + 0.54749841946027 + 0.53545127479961 + 0.52352215240342 + 0.87820221118385 + 0.87820222952337 + 0.87820223256468 + 0.87820223611058 + 0.87820224024502 + 0.87820224506619 + 0.87820225068809 + 0.87820225724604 + 0.87820226490103 + 0.87820227386315 + 0.87820228445862 + 0.87820229719830 + 0.87820231269941 + 0.87820233164368 + 0.87820235482795 + 0.87820238322584 + 0.87820241803014 + 0.87820246070351 + 0.87820251315800 + 0.87820257789306 + 0.87820265788571 + 0.87820275684560 + 0.87820287941376 + 0.87820303140190 + 0.87820322017667 + 0.87820345561343 + 0.87820375202143 + 0.87820412853684 + 0.87820460846045 + 0.87820522075992 + 0.87820600631966 + 0.87820701695522 + 0.87820831910676 + 0.87820999907863 + 0.87821216898406 + 0.87821497440591 + 0.87821860435982 + 0.87822330413859 + 0.87822940535158 + 0.87823735946122 + 0.87824774775909 + 0.87826133940007 + 0.87827914833977 + 0.87830243347800 + 0.87833223318802 + 0.87836898912558 + 0.87841369749444 + 0.87846741769734 + 0.87852991042435 + 0.87860143868711 + 0.87868362897875 + 0.87877885940831 + 0.87889022317455 + 0.87902172025484 + 0.87917882525167 + 0.87936855762707 + 0.87959976957228 + 0.87988411395881 + 0.88023704985567 + 0.88067940616496 + 0.88124066617100 + 0.88196586689871 + 0.88291966542673 + 0.88418867159514 + 0.88589452548300 + 0.88821828806211 + 0.89143651522899 + 0.89599847798232 + 0.90270004751717 + 0.91316287641365 + 0.93172207293232 + 1.00000000000000 + 0.92317024783547 + 0.89190717352690 + 0.86745345721944 + 0.84633259353166 + 0.82740393995013 + 0.81858805163883 + 0.81015151441908 + 0.80205899891048 + 0.79427668658772 + 0.78677008046466 + 0.77950277582100 + 0.77243612026410 + 0.76552979006485 + 0.75874307465852 + 0.75203297828786 + 0.74529605618083 + 0.73826574867242 + 0.73079813755457 + 0.72286644397663 + 0.71443767489153 + 0.70552038045758 + 0.69613376615261 + 0.68630630946493 + 0.67607434167567 + 0.66548059461097 + 0.65456999015463 + 0.64334070526269 + 0.63183541027859 + 0.62009961664022 + 0.60818178876887 + 0.59613374141585 + 0.58401089927840 + 0.57184725310027 + 0.55967217366181 + 0.54753522722113 + 0.53548142352293 + 0.52354672478942 + 0.86572357956389 + 0.86572359613460 + 0.86572359888201 + 0.86572360208481 + 0.86572360582011 + 0.86572361017491 + 0.86572361525245 + 0.86572362117546 + 0.86572362808789 + 0.86572363617989 + 0.86572364574882 + 0.86572365726065 + 0.86572367127815 + 0.86572368842344 + 0.86572370942461 + 0.86572373516806 + 0.86572376674293 + 0.86572380548526 + 0.86572385314399 + 0.86572391200453 + 0.86572398479134 + 0.86572407490063 + 0.86572418657644 + 0.86572432514230 + 0.86572449734115 + 0.86572471222173 + 0.86572498292986 + 0.86572532705921 + 0.86572576601277 + 0.86572632639754 + 0.86572704580844 + 0.86572797186612 + 0.86572916562372 + 0.86573070635498 + 0.86573269699406 + 0.86573527112888 + 0.86573860206381 + 0.86574291450991 + 0.86574851217411 + 0.86575580844220 + 0.86576533477403 + 0.86577779357731 + 0.86579410953034 + 0.86581542696393 + 0.86584267154028 + 0.86587619593099 + 0.86591685058100 + 0.86596551866984 + 0.86602184456288 + 0.86608590559121 + 0.86615899518600 + 0.86624303318591 + 0.86634050695393 + 0.86645461574327 + 0.86658974367693 + 0.86675146594884 + 0.86694673666955 + 0.86718465647351 + 0.86747722577748 + 0.86784052611344 + 0.86829731339836 + 0.86888258291425 + 0.86964623909124 + 0.87065368839416 + 0.87199475338862 + 0.87379991751399 + 0.87626136400262 + 0.87967566569418 + 0.88452869714615 + 0.89168934814897 + 0.90294922190543 + 0.92317024783547 + 1.00000000000000 + 0.91373926919940 + 0.88004559203335 + 0.85440341405415 + 0.83280802658349 + 0.82305385294757 + 0.81386217338489 + 0.80515863841046 + 0.79688023543474 + 0.78896992692805 + 0.78137347911596 + 0.77403786340359 + 0.76691100022524 + 0.75994250314768 + 0.75308138092387 + 0.74621680790556 + 0.73907449424943 + 0.73150666863651 + 0.72348509660358 + 0.71497562860449 + 0.70598622081214 + 0.69653555066238 + 0.68665156805888 + 0.67637004959454 + 0.66573314049563 + 0.65478514293589 + 0.64352347964454 + 0.63199024757236 + 0.62023040746249 + 0.60829191206171 + 0.59622611764876 + 0.58408805275482 + 0.57191135335389 + 0.55972510250236 + 0.54757865234867 + 0.53551683346386 + 0.52357545149196 + 0.85271384825934 + 0.85271386316565 + 0.85271386563669 + 0.85271386851765 + 0.85271387187640 + 0.85271387579280 + 0.85271388035891 + 0.85271388568417 + 0.85271389189931 + 0.85271389917398 + 0.85271390777923 + 0.85271391813819 + 0.85271393076349 + 0.85271394622029 + 0.85271396517240 + 0.85271398842637 + 0.85271401697409 + 0.85271405203321 + 0.85271409519588 + 0.85271414855518 + 0.85271421459423 + 0.85271429641936 + 0.85271439790974 + 0.85271452392627 + 0.85271468063866 + 0.85271487633119 + 0.85271512306491 + 0.85271543699382 + 0.85271583777431 + 0.85271634981625 + 0.85271700766732 + 0.85271785508124 + 0.85271894812294 + 0.85272035958992 + 0.85272218396058 + 0.85272454379506 + 0.85272759798538 + 0.85273155237896 + 0.85273668514465 + 0.85274337483615 + 0.85275210742442 + 0.85276352450778 + 0.85277846955249 + 0.85279798311142 + 0.85282289093222 + 0.85285347107872 + 0.85289044886348 + 0.85293455804262 + 0.85298535583740 + 0.85304277361973 + 0.85310782939585 + 0.85318206300046 + 0.85326746109358 + 0.85336656377130 + 0.85348285905097 + 0.85362074167595 + 0.85378562500321 + 0.85398454982565 + 0.85422674384743 + 0.85452451177576 + 0.85489529605611 + 0.85536620706263 + 0.85597572982849 + 0.85677327294164 + 0.85782539064176 + 0.85922699159659 + 0.86111407285811 + 0.86368894155102 + 0.86726611710141 + 0.87236506866299 + 0.87992457721910 + 0.89190717352690 + 0.91373926919940 + 1.00000000000000 + 0.90340535431926 + 0.86748169766871 + 0.84098198951341 + 0.82964607221849 + 0.81922908535120 + 0.80956406949350 + 0.80052460870277 + 0.79200815285384 + 0.78392660954816 + 0.77620104005037 + 0.76875909501251 + 0.76153430410962 + 0.75446278736732 + 0.74742230934329 + 0.74012721045855 + 0.73242393316145 + 0.72428186668490 + 0.71566500711804 + 0.70658028357138 + 0.69704548536925 + 0.68708771207765 + 0.67674188292880 + 0.66604926770017 + 0.65505327093677 + 0.64375026643913 + 0.63218154959147 + 0.62039132232456 + 0.60842684021564 + 0.59633884002755 + 0.58418181806860 + 0.57198893809700 + 0.55978890120930 + 0.54763077392371 + 0.53555914854314 + 0.52360962382175 + 0.83931439246707 + 0.83931440580963 + 0.83931440802164 + 0.83931441060017 + 0.83931441360593 + 0.83931441711036 + 0.83931442119625 + 0.83931442596123 + 0.83931443152174 + 0.83931443803063 + 0.83931444573200 + 0.83931445500949 + 0.83931446632914 + 0.83931448020553 + 0.83931449723752 + 0.83931451816214 + 0.83931454387536 + 0.83931457548690 + 0.83931461444772 + 0.83931466266334 + 0.83931472239841 + 0.83931479648602 + 0.83931488846603 + 0.83931500277588 + 0.83931514505004 + 0.83931532286221 + 0.83931554726966 + 0.83931583309338 + 0.83931619836164 + 0.83931666546307 + 0.83931726612049 + 0.83931804050670 + 0.83931904009310 + 0.83932033169926 + 0.83932200202460 + 0.83932416348573 + 0.83932696174382 + 0.83933058535969 + 0.83933528911311 + 0.83934141967336 + 0.83934942146024 + 0.83935988060496 + 0.83937356661794 + 0.83939142592641 + 0.83941419562069 + 0.83944209147933 + 0.83947573152849 + 0.83951572315878 + 0.83956156100614 + 0.83961306411305 + 0.83967102430564 + 0.83973666823101 + 0.83981157137377 + 0.83989773481316 + 0.83999791485716 + 0.84011554771965 + 0.84025480450457 + 0.84042107414263 + 0.84062137396413 + 0.84086501691583 + 0.84116525670234 + 0.84154299989389 + 0.84202783821418 + 0.84265697976079 + 0.84347966036584 + 0.84456506734621 + 0.84601018314811 + 0.84795531712709 + 0.85061049736838 + 0.85430438675905 + 0.85958465647580 + 0.86745345721944 + 0.88004559203335 + 0.90340535431926 + 1.00000000000000 + 0.89224436454738 + 0.85440823881024 + 0.84003385909222 + 0.82741716496213 + 0.81611144666822 + 0.80582396947050 + 0.79634511278826 + 0.78751380884789 + 0.77919919499301 + 0.77129070662080 + 0.76369304069674 + 0.75632015890892 + 0.74903118798733 + 0.74152295615973 + 0.73363280868946 + 0.72532609929817 + 0.71656374110913 + 0.70735085840908 + 0.69770372594581 + 0.68764805288963 + 0.67721741396803 + 0.66645175417717 + 0.65539316041455 + 0.64403652560660 + 0.63242201112161 + 0.62059276089373 + 0.60859506934403 + 0.59647882621658 + 0.58429780438178 + 0.57208453125458 + 0.55986719462778 + 0.54769447570433 + 0.53561064640029 + 0.52365102896855 + 0.82571449810067 + 0.82571450998337 + 0.82571451195253 + 0.82571451424805 + 0.82571451692439 + 0.82571452004453 + 0.82571452368200 + 0.82571452792349 + 0.82571453287360 + 0.82571453866798 + 0.82571454552605 + 0.82571455379656 + 0.82571456390110 + 0.82571457630289 + 0.82571459154980 + 0.82571461030371 + 0.82571463338118 + 0.82571466178834 + 0.82571469684130 + 0.82571474027810 + 0.82571479415917 + 0.82571486106380 + 0.82571494422066 + 0.82571504767515 + 0.82571517656930 + 0.82571533782377 + 0.82571554156699 + 0.82571580139168 + 0.82571613382717 + 0.82571655939796 + 0.82571710723168 + 0.82571781421034 + 0.82571872758572 + 0.82571990869452 + 0.82572143710692 + 0.82572341596676 + 0.82572597884379 + 0.82572929853914 + 0.82573360850208 + 0.82573922635694 + 0.82574655874072 + 0.82575614141483 + 0.82576867684541 + 0.82578502644064 + 0.82580584893829 + 0.82583130862179 + 0.82586193206471 + 0.82589822058702 + 0.82593962677747 + 0.82598588587948 + 0.82603760615424 + 0.82609575894739 + 0.82616158587763 + 0.82623665239095 + 0.82632312410843 + 0.82642366809694 + 0.82654146623545 + 0.82668059895263 + 0.82684634238527 + 0.82704566570122 + 0.82728855070754 + 0.82759105110557 + 0.82797585144789 + 0.82847085238595 + 0.82911233371784 + 0.82995065731042 + 0.83105510940190 + 0.83252371306232 + 0.83449897866389 + 0.83719522932304 + 0.84095016275192 + 0.84633259353166 + 0.85440341405415 + 0.86748169766871 + 0.89224436454738 + 1.00000000000000 + 0.88035282240018 + 0.85836614957660 + 0.84101186653248 + 0.82650283419382 + 0.81394379732362 + 0.80280422557929 + 0.79273271872414 + 0.78347692861587 + 0.77484442880066 + 0.76668244102851 + 0.75886328350671 + 0.75121327226815 + 0.74340056949999 + 0.73524733242684 + 0.72671167686921 + 0.71774913320890 + 0.70836154701504 + 0.69856253467885 + 0.68837547198645 + 0.67783177607330 + 0.66696934739281 + 0.65582830621302 + 0.64440142326233 + 0.63272723636525 + 0.62084739898383 + 0.60880686822742 + 0.59665436613064 + 0.58444267473304 + 0.57220345747240 + 0.55996420746186 + 0.54777308300295 + 0.53567392274726 + 0.52370167723782 + 0.81211953430712 + 0.81211954483678 + 0.81211954658170 + 0.81211954861585 + 0.81211955098715 + 0.81211955375163 + 0.81211955697421 + 0.81211956073209 + 0.81211956511652 + 0.81211957024983 + 0.81211957632814 + 0.81211958366723 + 0.81211959264758 + 0.81211960369005 + 0.81211961728584 + 0.81211963403655 + 0.81211965468201 + 0.81211968013251 + 0.81211971158369 + 0.81211975061656 + 0.81211979910437 + 0.81211985939605 + 0.81211993443161 + 0.81212002790170 + 0.81212014449423 + 0.81212029053614 + 0.81212047530110 + 0.81212071126104 + 0.81212101357136 + 0.81212140105922 + 0.81212190047668 + 0.81212254570207 + 0.81212338013935 + 0.81212446013346 + 0.81212585877030 + 0.81212767076616 + 0.81213001872331 + 0.81213306115626 + 0.81213701220923 + 0.81214216321284 + 0.81214888667598 + 0.81215767292205 + 0.81216916402829 + 0.81218414511567 + 0.81220320611841 + 0.81222646925964 + 0.81225438381240 + 0.81228736293957 + 0.81232483412242 + 0.81236647275198 + 0.81241274040862 + 0.81246440324161 + 0.81252243574663 + 0.81258805665274 + 0.81266296190563 + 0.81274921113919 + 0.81284921173543 + 0.81296602530540 + 0.81310357988153 + 0.81326703929837 + 0.81346386849647 + 0.81370637041728 + 0.81401191625645 + 0.81440136284102 + 0.81490134514888 + 0.81554844599903 + 0.81639215526241 + 0.81750117332118 + 0.81897302812207 + 0.82094987235720 + 0.82364643962293 + 0.82740393995013 + 0.83280802658349 + 0.84098198951341 + 0.85440823881024 + 0.88035282240018 + 1.00000000000000 + 0.90121842990790 + 0.86781218359175 + 0.84508217243979 + 0.82752683360357 + 0.81308903473402 + 0.80073050219632 + 0.78983537290813 + 0.77999824470450 + 0.77093231741270 + 0.76242092223629 + 0.75422612272953 + 0.74596490339160 + 0.73743190105092 + 0.72857129010770 + 0.71932859388093 + 0.70969942094811 + 0.69969253286800 + 0.68932724950644 + 0.67863141825818 + 0.66763970208542 + 0.65638922332003 + 0.64486965789396 + 0.63311718638252 + 0.62117133839816 + 0.60907519279101 + 0.59687584911582 + 0.58462472334050 + 0.57235229888903 + 0.56008512382285 + 0.54787064395499 + 0.53575210990890 + 0.52376397076674 + 0.80537739391204 + 0.80537740380650 + 0.80537740544609 + 0.80537740735744 + 0.80537740958566 + 0.80537741218268 + 0.80537741521049 + 0.80537741874097 + 0.80537742286008 + 0.80537742768340 + 0.80537743339688 + 0.80537744029787 + 0.80537744875139 + 0.80537745915530 + 0.80537747197771 + 0.80537748779031 + 0.80537750729501 + 0.80537753135937 + 0.80537756112328 + 0.80537759809199 + 0.80537764405342 + 0.80537770124940 + 0.80537777248446 + 0.80537786128133 + 0.80537797212106 + 0.80537811104739 + 0.80537828694260 + 0.80537851175042 + 0.80537879998785 + 0.80537916968986 + 0.80537964650331 + 0.80538026290574 + 0.80538106051236 + 0.80538209334669 + 0.80538343148532 + 0.80538516572884 + 0.80538741359786 + 0.80539032699224 + 0.80539411112090 + 0.80539904514337 + 0.80540548580478 + 0.80541390245405 + 0.80542490933068 + 0.80543925648871 + 0.80545750275633 + 0.80547975244359 + 0.80550642092250 + 0.80553788324164 + 0.80557355965121 + 0.80561310327901 + 0.80565691441961 + 0.80570567304595 + 0.80576024190381 + 0.80582169533821 + 0.80589153384135 + 0.80597156575847 + 0.80606388054039 + 0.80617112353760 + 0.80629667453887 + 0.80644496612575 + 0.80662244385783 + 0.80683988234101 + 0.80711249273318 + 0.80745830344271 + 0.80790012117927 + 0.80846911796691 + 0.80920712783401 + 0.81017172490647 + 0.81144378515363 + 0.81313960396699 + 0.81543175867226 + 0.81858805163883 + 0.82305385294757 + 0.82964607221849 + 0.84003385909222 + 0.85836614957660 + 0.90121842990790 + 1.00000000000000 + 0.89567203988028 + 0.86137333474063 + 0.83838506535260 + 0.82082301454973 + 0.80648403875128 + 0.79425802908183 + 0.78349003321458 + 0.77375266064740 + 0.76474359657659 + 0.75616779316704 + 0.74760025305157 + 0.73881296735822 + 0.72973826394998 + 0.72031342895841 + 0.71052891165492 + 0.70038959051418 + 0.68991166423216 + 0.67912033695099 + 0.66804795636879 + 0.65672956541639 + 0.64515276698147 + 0.63335217126114 + 0.62136591480836 + 0.60923585925322 + 0.59700806214564 + 0.58473306790524 + 0.57244061274636 + 0.56015664839893 + 0.54792817092744 + 0.53579806102217 + 0.52380045377872 + 0.79869903143533 + 0.79869904072216 + 0.79869904226102 + 0.79869904405514 + 0.79869904614618 + 0.79869904858384 + 0.79869905142544 + 0.79869905473922 + 0.79869905860480 + 0.79869906313253 + 0.79869906849632 + 0.79869907498077 + 0.79869908293121 + 0.79869909272553 + 0.79869910480956 + 0.79869911972578 + 0.79869913814363 + 0.79869916088556 + 0.79869918903971 + 0.79869922404083 + 0.79869926759321 + 0.79869932183666 + 0.79869938944755 + 0.79869947379069 + 0.79869957914518 + 0.79869971129224 + 0.79869987873431 + 0.79870009291528 + 0.79870036774615 + 0.79870072050517 + 0.79870117578898 + 0.79870176474459 + 0.79870252728244 + 0.79870351522452 + 0.79870479578508 + 0.79870645604981 + 0.79870860872104 + 0.79871139942765 + 0.79871502490701 + 0.79871975279468 + 0.79872592490814 + 0.79873399076533 + 0.79874453829132 + 0.79875828446411 + 0.79877575909107 + 0.79879705046206 + 0.79882254296847 + 0.79885257717811 + 0.79888656914906 + 0.79892415418597 + 0.79896567849713 + 0.79901174568724 + 0.79906311973610 + 0.79912074782951 + 0.79918595835449 + 0.79926033936235 + 0.79934570316470 + 0.79944433348419 + 0.79955913537887 + 0.79969390994791 + 0.79985422208098 + 0.80004951907021 + 0.80029313784368 + 0.80060067270048 + 0.80099165958076 + 0.80149267587413 + 0.80213911167499 + 0.80297927579426 + 0.80408036546079 + 0.80553780973173 + 0.80749095356482 + 0.81015151441908 + 0.81386217338489 + 0.81922908535120 + 0.82741716496213 + 0.84101186653248 + 0.86781218359175 + 0.89567203988028 + 1.00000000000000 + 0.88994309386304 + 0.85484290575549 + 0.83168126932918 + 0.81417168535914 + 0.79996332457949 + 0.78787810432945 + 0.77722692656326 + 0.76756128376870 + 0.75849553790862 + 0.74954252821854 + 0.74044089787006 + 0.73110529193586 + 0.72146103837213 + 0.71149112624258 + 0.70119497079510 + 0.69058450853571 + 0.67968143819175 + 0.66851511726217 + 0.65711796506417 + 0.64547503623509 + 0.63361902084606 + 0.62158637266588 + 0.60941749675491 + 0.59715721261936 + 0.58485503459712 + 0.57253982075081 + 0.56023682397737 + 0.54799251337020 + 0.53584933728303 + 0.52384106506021 + 0.79209635409468 + 0.79209636280409 + 0.79209636424780 + 0.79209636592957 + 0.79209636789048 + 0.79209637017620 + 0.79209637284093 + 0.79209637594815 + 0.79209637957348 + 0.79209638381826 + 0.79209638884959 + 0.79209639493740 + 0.79209640240920 + 0.79209641162370 + 0.79209642300509 + 0.79209643706805 + 0.79209645445016 + 0.79209647593430 + 0.79209650255585 + 0.79209653568356 + 0.79209657694383 + 0.79209662837540 + 0.79209669253693 + 0.79209677264080 + 0.79209687277545 + 0.79209699847105 + 0.79209715787037 + 0.79209736194133 + 0.79209762401624 + 0.79209796065896 + 0.79209839546218 + 0.79209895830917 + 0.79209968749757 + 0.79210063274978 + 0.79210185856786 + 0.79210344851755 + 0.79210551072428 + 0.79210818488515 + 0.79211165971456 + 0.79211619193360 + 0.79212210924339 + 0.79212984241339 + 0.79213995452929 + 0.79215313138532 + 0.79216987573925 + 0.79219026159363 + 0.79221464507840 + 0.79224333563526 + 0.79227574781032 + 0.79231150305061 + 0.79235090002351 + 0.79239447487348 + 0.79244290461800 + 0.79249702487179 + 0.79255801305108 + 0.79262726490347 + 0.79270635231138 + 0.79279724641978 + 0.79290244341946 + 0.79302520207602 + 0.79317033033281 + 0.79334612736358 + 0.79356430972852 + 0.79383838512884 + 0.79418510590909 + 0.79462716111500 + 0.79519453222011 + 0.79592782709958 + 0.79688301331689 + 0.79813866022509 + 0.79980781285968 + 0.80205899891048 + 0.80515863841046 + 0.80956406949350 + 0.81611144666822 + 0.82650283419382 + 0.84508217243979 + 0.86137333474063 + 0.88994309386304 + 1.00000000000000 + 0.88404364406065 + 0.84824629971699 + 0.82499705215179 + 0.80759162923358 + 0.79353465921339 + 0.78158674031921 + 0.77102673909539 + 0.76131522930404 + 0.75186786506679 + 0.74237195060284 + 0.73271481232232 + 0.72280390965059 + 0.71261120461825 + 0.70212828398741 + 0.69136117243969 + 0.68032685734185 + 0.66905079015264 + 0.65756204823337 + 0.64584252918063 + 0.63392255997021 + 0.62183655080867 + 0.60962315625714 + 0.59732571969329 + 0.58499253449032 + 0.57265142421916 + 0.56032682116138 + 0.54806457598281 + 0.53590663108567 + 0.52388632927413 + 0.78557542488123 + 0.78557543304193 + 0.78557543439425 + 0.78557543597009 + 0.78557543780728 + 0.78557543994926 + 0.78557544244572 + 0.78557544535641 + 0.78557544875299 + 0.78557545273053 + 0.78557545744663 + 0.78557546315731 + 0.78557547017442 + 0.78557547883909 + 0.78557548955243 + 0.78557550280556 + 0.78557551920390 + 0.78557553949260 + 0.78557556465962 + 0.78557559600790 + 0.78557563508862 + 0.78557568385058 + 0.78557574473399 + 0.78557582080981 + 0.78557591598620 + 0.78557603555221 + 0.78557618731045 + 0.78557638177355 + 0.78557663172803 + 0.78557695305584 + 0.78557736839763 + 0.78557790643632 + 0.78557860393295 + 0.78557950862491 + 0.78558068243531 + 0.78558220559414 + 0.78558418189364 + 0.78558674540670 + 0.78559007725954 + 0.78559442383407 + 0.78560009949345 + 0.78560751728722 + 0.78561721684838 + 0.78562985459571 + 0.78564590808003 + 0.78566543861083 + 0.78568877655979 + 0.78571620332714 + 0.78574713428888 + 0.78578118055424 + 0.78581859913911 + 0.78585986679340 + 0.78590558419403 + 0.78595648939229 + 0.78601362782963 + 0.78607822799042 + 0.78615165411050 + 0.78623560844989 + 0.78633223682070 + 0.78644433467362 + 0.78657606247548 + 0.78673472991804 + 0.78693065722936 + 0.78717557001811 + 0.78748386058987 + 0.78787493852791 + 0.78837425906117 + 0.78901604358703 + 0.78984705129093 + 0.79093222448344 + 0.79236374286113 + 0.79427668658772 + 0.79688023543474 + 0.80052460870277 + 0.80582396947050 + 0.81394379732362 + 0.82752683360357 + 0.83838506535260 + 0.85484290575549 + 0.88404364406065 + 1.00000000000000 + 0.87798848322466 + 0.84161040004224 + 0.81835665575781 + 0.80109677674696 + 0.78719923633552 + 0.77536772174012 + 0.76477709716966 + 0.75468005607409 + 0.74468039511401 + 0.73462143592815 + 0.72438300264466 + 0.71392032417539 + 0.70321352461418 + 0.69226027894378 + 0.68107114451128 + 0.66966640372704 + 0.65807083037611 + 0.64626237544119 + 0.63426843580585 + 0.62212092479815 + 0.60985638276397 + 0.59751638593855 + 0.58514777568769 + 0.57277715355870 + 0.56042798603420 + 0.54814539666613 + 0.53597073486847 + 0.52393684535500 + 0.77913597769938 + 0.77913598534110 + 0.77913598660722 + 0.77913598808290 + 0.77913598980331 + 0.77913599180823 + 0.77913599414605 + 0.77913599687153 + 0.77913600005157 + 0.77913600377586 + 0.77913600819379 + 0.77913601354835 + 0.77913602013474 + 0.77913602827884 + 0.77913603836095 + 0.77913605084723 + 0.77913606631400 + 0.77913608547091 + 0.77913610925707 + 0.77913613891842 + 0.77913617593350 + 0.77913622216367 + 0.77913627993895 + 0.77913635219312 + 0.77913644266435 + 0.77913655641522 + 0.77913670092123 + 0.77913688626786 + 0.77913712471566 + 0.77913743150278 + 0.77913782836508 + 0.77913834284593 + 0.77913901024655 + 0.77913987641881 + 0.77914100084209 + 0.77914246058035 + 0.77914435532045 + 0.77914681381004 + 0.77915000998402 + 0.77915418044715 + 0.77915962693679 + 0.77916674576304 + 0.77917605441635 + 0.77918818163135 + 0.77920358147337 + 0.77922230400739 + 0.77924465615152 + 0.77927089406690 + 0.77930043601194 + 0.77933288583495 + 0.77936846419711 + 0.77940759565875 + 0.77945081405255 + 0.77949877236537 + 0.77955240095540 + 0.77961278330001 + 0.77968110498267 + 0.77975883792756 + 0.77984782907131 + 0.77995047990707 + 0.78007039945729 + 0.78021404721545 + 0.78039054336075 + 0.78061009634740 + 0.78088510436302 + 0.78123221961539 + 0.78167312004128 + 0.78223674236817 + 0.78296230507055 + 0.78390373767765 + 0.78513663954116 + 0.78677008046466 + 0.78896992692805 + 0.79200815285384 + 0.79634511278826 + 0.80280422557929 + 0.81308903473402 + 0.82082301454973 + 0.83168126932918 + 0.84824629971699 + 0.87798848322466 + 1.00000000000000 + 0.87179525321849 + 0.83496270870047 + 0.81178107878669 + 0.79469506726052 + 0.78094527676255 + 0.76910459464145 + 0.75812580281050 + 0.74746703387683 + 0.73689695712835 + 0.72625082978566 + 0.71545766565827 + 0.70448036565671 + 0.69330455841295 + 0.68193186853794 + 0.67037563537985 + 0.65865502125298 + 0.64674299228550 + 0.63466328086954 + 0.62244472806769 + 0.61012130606147 + 0.59773246566634 + 0.58532331486740 + 0.57291900713119 + 0.56054186929862 + 0.54823616822683 + 0.53604255710202 + 0.52399329814048 + 0.77277132995972 + 0.77277133711139 + 0.77277133829635 + 0.77277133967722 + 0.77277134128693 + 0.77277134316351 + 0.77277134535132 + 0.77277134790170 + 0.77277135087776 + 0.77277135436383 + 0.77277135850024 + 0.77277136351827 + 0.77277136969944 + 0.77277137735140 + 0.77277138683688 + 0.77277139859882 + 0.77277141318524 + 0.77277143127115 + 0.77277145375345 + 0.77277148181801 + 0.77277151687913 + 0.77277156071132 + 0.77277161554389 + 0.77277168417820 + 0.77277177019118 + 0.77277187843089 + 0.77277201606319 + 0.77277219276225 + 0.77277242029668 + 0.77277271328701 + 0.77277309261183 + 0.77277358472951 + 0.77277422355648 + 0.77277505315210 + 0.77277613067976 + 0.77277753019179 + 0.77277934748597 + 0.77278170626467 + 0.77278477364833 + 0.77278877697336 + 0.77279400603477 + 0.77280084130932 + 0.77280977936111 + 0.77282142282154 + 0.77283620386329 + 0.77285416261360 + 0.77287558463965 + 0.77290070341543 + 0.77292894184016 + 0.77295989920043 + 0.77299376449143 + 0.77303091649794 + 0.77307183062284 + 0.77311708581708 + 0.77316751227889 + 0.77322406804265 + 0.77328778544208 + 0.77335993975535 + 0.77344212389428 + 0.77353640569180 + 0.77364592609757 + 0.77377641559558 + 0.77393596482561 + 0.77413349370865 + 0.77437971995570 + 0.77468898297683 + 0.77507981543937 + 0.77557678888905 + 0.77621295353988 + 0.77703333997026 + 0.77810035541934 + 0.77950277582100 + 0.78137347911596 + 0.78392660954816 + 0.78751380884789 + 0.79273271872414 + 0.80073050219632 + 0.80648403875128 + 0.81417168535914 + 0.82499705215179 + 0.84161040004224 + 0.87179525321849 + 1.00000000000000 + 0.86548445275108 + 0.82833026630729 + 0.80528663567131 + 0.78838091680073 + 0.77465136882573 + 0.76242240023644 + 0.75087359695758 + 0.73963831845682 + 0.72847611025790 + 0.71727326247253 + 0.70596597099536 + 0.69452203829375 + 0.68293041889627 + 0.67119496423413 + 0.65932741412529 + 0.64729436312415 + 0.63511491521629 + 0.62281410051991 + 0.61042275097794 + 0.59797774727775 + 0.58552211901635 + 0.57307929751688 + 0.56067026082727 + 0.54833826397090 + 0.53612314107644 + 0.52405647199998 + 0.76646883681535 + 0.76646884350676 + 0.76646884461569 + 0.76646884590775 + 0.76646884741395 + 0.76646884916947 + 0.76646885121629 + 0.76646885360266 + 0.76646885638687 + 0.76646885964882 + 0.76646886352124 + 0.76646886822282 + 0.76646887402225 + 0.76646888121179 + 0.76646889013543 + 0.76646890121481 + 0.76646891497110 + 0.76646893204827 + 0.76646895329853 + 0.76646897985637 + 0.76646901307112 + 0.76646905463711 + 0.76646910668471 + 0.76646917189655 + 0.76646925369046 + 0.76646935671036 + 0.76646948783107 + 0.76646965633616 + 0.76646987352211 + 0.76647015342634 + 0.76647051610951 + 0.76647098699642 + 0.76647159868875 + 0.76647239354298 + 0.76647342651604 + 0.76647476880652 + 0.76647651251503 + 0.76647877655247 + 0.76648172157822 + 0.76648556613378 + 0.76649058869364 + 0.76649715474177 + 0.76650574103921 + 0.76651692557004 + 0.76653112006429 + 0.76654835590278 + 0.76656889919360 + 0.76659296302603 + 0.76661997645526 + 0.76664953653633 + 0.76668180474024 + 0.76671711971397 + 0.76675590581398 + 0.76679867762323 + 0.76684617819939 + 0.76689925717305 + 0.76695881565617 + 0.76702596137203 + 0.76710207186515 + 0.76718893308599 + 0.76728928948214 + 0.76740824690170 + 0.76755301311418 + 0.76773141487917 + 0.76795275577155 + 0.76822943770343 + 0.76857737729922 + 0.76901754330525 + 0.76957794166420 + 0.77029640844454 + 0.77122483764859 + 0.77243612026410 + 0.77403786340359 + 0.77620104005037 + 0.77919919499301 + 0.78347692861587 + 0.78983537290813 + 0.79425802908183 + 0.79996332457949 + 0.80759162923358 + 0.81835665575781 + 0.83496270870047 + 0.86548445275108 + 1.00000000000000 + 0.85907929365156 + 0.82173806818176 + 0.79887592874283 + 0.78202628685700 + 0.76791238942761 + 0.75510874810960 + 0.74298096385632 + 0.73115110612726 + 0.71943227266102 + 0.70771760463446 + 0.69594769945724 + 0.68409309114110 + 0.67214440205517 + 0.66010338969023 + 0.64792839185597 + 0.63563259989095 + 0.62323627244021 + 0.61076637239465 + 0.59825665322742 + 0.58574763982115 + 0.57326070692204 + 0.56081523080391 + 0.54845326807571 + 0.53621368710024 + 0.52412726687318 + 0.76021098885213 + 0.76021099511258 + 0.76021099615001 + 0.76021099735891 + 0.76021099876822 + 0.76021100041067 + 0.76021100232588 + 0.76021100455819 + 0.76021100716354 + 0.76021101021534 + 0.76021101383999 + 0.76021101824600 + 0.76021102368779 + 0.76021103044297 + 0.76021103883895 + 0.76021104927658 + 0.76021106225208 + 0.76021107837871 + 0.76021109846971 + 0.76021112360753 + 0.76021115507931 + 0.76021119450692 + 0.76021124392539 + 0.76021130589969 + 0.76021138370496 + 0.76021148178847 + 0.76021160674298 + 0.76021176748392 + 0.76021197485771 + 0.76021224234655 + 0.76021258923175 + 0.76021303995385 + 0.76021362586258 + 0.76021438768998 + 0.76021537829336 + 0.76021666615774 + 0.76021833986019 + 0.76022051376018 + 0.76022334236850 + 0.76022703587310 + 0.76023186198689 + 0.76023817196585 + 0.76024642379920 + 0.76025717213968 + 0.76027080959499 + 0.76028735985768 + 0.76030707129179 + 0.76033013864360 + 0.76035599843466 + 0.76038424749166 + 0.76041502337561 + 0.76044862951724 + 0.76048544565354 + 0.76052593035288 + 0.76057075080991 + 0.76062066291768 + 0.76067645543986 + 0.76073909339975 + 0.76080977184964 + 0.76089003879019 + 0.76098230285159 + 0.76109113408339 + 0.76122298223189 + 0.76138474604090 + 0.76158453868601 + 0.76183313821065 + 0.76214428414259 + 0.76253596919418 + 0.76303206897008 + 0.76366459193845 + 0.76447703026162 + 0.76552979006485 + 0.76691100022524 + 0.76875909501251 + 0.77129070662080 + 0.77484442880066 + 0.77999824470450 + 0.78349003321458 + 0.78787810432945 + 0.79353465921339 + 0.80109677674696 + 0.81178107878669 + 0.82833026630729 + 0.85907929365156 + 1.00000000000000 + 0.85260483143051 + 0.81519779552524 + 0.79241021303238 + 0.77518388889071 + 0.76049927217283 + 0.74712278384946 + 0.73440380854404 + 0.72202165316297 + 0.70979651313231 + 0.69762584568438 + 0.68545259015354 + 0.67324847828122 + 0.66100157977345 + 0.64865936048848 + 0.63622735884407 + 0.62371979486320 + 0.61115882240976 + 0.59857436259944 + 0.58600390414039 + 0.57346635414092 + 0.56097917918603 + 0.54858301191826 + 0.53631557895424 + 0.52420671731309 + 0.75397699152659 + 0.75397699738503 + 0.75397699835595 + 0.75397699948733 + 0.75397700080609 + 0.75397700234351 + 0.75397700413509 + 0.75397700622440 + 0.75397700866220 + 0.75397701151820 + 0.75397701491225 + 0.75397701904194 + 0.75397702414897 + 0.75397703049787 + 0.75397703839946 + 0.75397704823623 + 0.75397706047892 + 0.75397707571284 + 0.75397709471332 + 0.75397711851433 + 0.75397714834560 + 0.75397718575590 + 0.75397723269310 + 0.75397729161081 + 0.75397736564433 + 0.75397745905578 + 0.75397757817323 + 0.75397773155634 + 0.75397792962288 + 0.75397818532701 + 0.75397851720295 + 0.75397894875541 + 0.75397951013495 + 0.75398024052463 + 0.75398119077859 + 0.75398242678693 + 0.75398403377322 + 0.75398612175125 + 0.75398883937390 + 0.75399238885797 + 0.75399702767218 + 0.75400309352909 + 0.75401102656236 + 0.75402135928641 + 0.75403446636628 + 0.75405036474923 + 0.75406928657962 + 0.75409141008740 + 0.75411618037082 + 0.75414319575042 + 0.75417257300487 + 0.75420458461120 + 0.75423957120790 + 0.75427794253602 + 0.75432029955780 + 0.75436731694344 + 0.75441968709450 + 0.75447825330794 + 0.75454405577472 + 0.75461844133761 + 0.75470353359874 + 0.75480344158531 + 0.75492396211164 + 0.75507120394399 + 0.75525227568792 + 0.75547659075065 + 0.75575607184927 + 0.75610624590660 + 0.75654759483106 + 0.75710738757835 + 0.75782236923558 + 0.75874307465852 + 0.75994250314768 + 0.76153430410962 + 0.76369304069674 + 0.76668244102851 + 0.77093231741270 + 0.77375266064740 + 0.77722692656326 + 0.78158674031921 + 0.78719923633552 + 0.79469506726052 + 0.80528663567131 + 0.82173806818176 + 0.85260483143051 + 1.00000000000000 + 0.84607325554347 + 0.80854801960169 + 0.78537796245047 + 0.76760296301836 + 0.75237107763380 + 0.73841967706722 + 0.72516121659025 + 0.71228400561471 + 0.69961365978332 + 0.68705021399316 + 0.67453763565608 + 0.66204478978353 + 0.64950455604129 + 0.63691241535950 + 0.62427484966592 + 0.61160797440120 + 0.59893697511302 + 0.58629563515348 + 0.57369988442405 + 0.56116490237610 + 0.54872962335980 + 0.53643042008986 + 0.52429601884656 + 0.74774120836016 + 0.74774121384493 + 0.74774121475340 + 0.74774121581263 + 0.74774121704754 + 0.74774121848657 + 0.74774122016363 + 0.74774122211966 + 0.74774122440147 + 0.74774122707544 + 0.74774123025441 + 0.74774123412681 + 0.74774123892182 + 0.74774124489159 + 0.74774125233162 + 0.74774126160503 + 0.74774127316139 + 0.74774128755741 + 0.74774130553398 + 0.74774132807644 + 0.74774135636211 + 0.74774139187099 + 0.74774143646537 + 0.74774149249509 + 0.74774156296236 + 0.74774165195251 + 0.74774176553700 + 0.74774191193946 + 0.74774210116707 + 0.74774234566527 + 0.74774266325652 + 0.74774307654693 + 0.74774361453819 + 0.74774431493304 + 0.74774522666060 + 0.74774641313049 + 0.74774795635096 + 0.74774996217948 + 0.74775257365770 + 0.74775598537378 + 0.74776044500193 + 0.74776627730755 + 0.74777390537163 + 0.74778384061101 + 0.74779644079023 + 0.74781171694455 + 0.74782988633305 + 0.74785111226639 + 0.74787484939823 + 0.74790069901333 + 0.74792875979711 + 0.74795927690757 + 0.74799255659887 + 0.74802896586630 + 0.74806904759628 + 0.74811340576087 + 0.74816264978510 + 0.74821751870881 + 0.74827892078824 + 0.74834803209004 + 0.74842673313587 + 0.74851873401551 + 0.74862926596042 + 0.74876376167898 + 0.74892847761164 + 0.74913167417871 + 0.74938374947104 + 0.74969817530974 + 0.75009262738472 + 0.75059049304115 + 0.75122305663940 + 0.75203297828786 + 0.75308138092387 + 0.75446278736732 + 0.75632015890892 + 0.75886328350671 + 0.76242092223629 + 0.76474359657659 + 0.76756128376870 + 0.77102673909539 + 0.77536772174012 + 0.78094527676255 + 0.78838091680073 + 0.79887592874283 + 0.81519779552524 + 0.84607325554347 + 1.00000000000000 + 0.83926414276640 + 0.80117121572833 + 0.77750417276573 + 0.75925004862443 + 0.74348717946897 + 0.72902575471576 + 0.71529353129059 + 0.70198843497498 + 0.68894050176174 + 0.67605138542155 + 0.66326223389299 + 0.65048590598764 + 0.63770441900594 + 0.62491418779292 + 0.61212365064502 + 0.59935208099647 + 0.58662870144489 + 0.57396582436552 + 0.56137587364491 + 0.54889574790882 + 0.53656020754867 + 0.52439666434781 + 0.74141812809549 + 0.74141813323072 + 0.74141813408171 + 0.74141813507335 + 0.74141813622902 + 0.74141813757628 + 0.74141813914663 + 0.74141814097747 + 0.74141814311397 + 0.74141814561812 + 0.74141814859605 + 0.74141815222740 + 0.74141815672976 + 0.74141816234298 + 0.74141816934812 + 0.74141817809057 + 0.74141818899823 + 0.74141820260152 + 0.74141821960707 + 0.74141824095694 + 0.74141826777390 + 0.74141830147297 + 0.74141834383559 + 0.74141839710975 + 0.74141846416923 + 0.74141854892904 + 0.74141865721392 + 0.74141879691711 + 0.74141897764808 + 0.74141921136312 + 0.74141951519016 + 0.74141991086238 + 0.74142042626170 + 0.74142109765124 + 0.74142197209163 + 0.74142311057572 + 0.74142459198512 + 0.74142651813625 + 0.74142902661413 + 0.74143230458684 + 0.74143659020643 + 0.74144219566080 + 0.74144952748657 + 0.74145907665785 + 0.74147118475431 + 0.74148585758310 + 0.74150329854143 + 0.74152365726856 + 0.74154639899064 + 0.74157112932164 + 0.74159793100976 + 0.74162702478105 + 0.74165868622944 + 0.74169324440037 + 0.74173119052911 + 0.74177306617728 + 0.74181940836055 + 0.74187086564870 + 0.74192823239468 + 0.74199253775906 + 0.74206545195836 + 0.74215033442989 + 0.74225191873201 + 0.74237505022825 + 0.74252525173209 + 0.74270979485807 + 0.74293777893392 + 0.74322093660616 + 0.74357458644361 + 0.74401888469931 + 0.74458062016330 + 0.74529605618083 + 0.74621680790556 + 0.74742230934329 + 0.74903118798733 + 0.75121327226815 + 0.75422612272953 + 0.75616779316704 + 0.75849553790862 + 0.76131522930404 + 0.76477709716966 + 0.76910459464145 + 0.77465136882573 + 0.78202628685700 + 0.79241021303238 + 0.80854801960169 + 0.83926414276640 + 1.00000000000000 + 0.83151553336020 + 0.79288318286443 + 0.76886268067018 + 0.75016088655037 + 0.73393680692667 + 0.71903066481209 + 0.70489045604714 + 0.69122351030506 + 0.67786335789421 + 0.66470935330342 + 0.65164584139831 + 0.63863624062816 + 0.62566350071775 + 0.61272605379805 + 0.59983562369891 + 0.58701570142396 + 0.57427411761059 + 0.56161991494204 + 0.54908750934360 + 0.53670970923928 + 0.52451234597691 + 0.73476309475571 + 0.73476309955516 + 0.73476310035056 + 0.73476310127742 + 0.73476310235746 + 0.73476310361669 + 0.73476310508460 + 0.73476310679575 + 0.73476310879290 + 0.73476311113388 + 0.73476311391866 + 0.73476311731822 + 0.73476312153915 + 0.73476312680776 + 0.73476313339203 + 0.73476314161896 + 0.73476315189613 + 0.73476316472757 + 0.73476318078508 + 0.73476320096716 + 0.73476322634367 + 0.73476325826385 + 0.73476329842783 + 0.73476334898169 + 0.73476341267153 + 0.73476349323885 + 0.73476359626022 + 0.73476372929893 + 0.73476390155928 + 0.73476412449958 + 0.73476441454525 + 0.73476479254082 + 0.73476528524207 + 0.73476592743742 + 0.73476676429523 + 0.73476785434890 + 0.73476927330177 + 0.73477111885855 + 0.73477352305922 + 0.73477666551808 + 0.73478077470830 + 0.73478615003452 + 0.73479318121877 + 0.73480233850366 + 0.73481394725464 + 0.73482800850159 + 0.73484471215300 + 0.73486419480406 + 0.73488593377768 + 0.73490954062475 + 0.73493508360118 + 0.73496276075421 + 0.73499281931929 + 0.73502555343416 + 0.73506140664980 + 0.73510086342220 + 0.73514439542099 + 0.73519257004278 + 0.73524608005080 + 0.73530582401753 + 0.73537328377566 + 0.73545149856700 + 0.73554474693400 + 0.73565734498322 + 0.73579416117073 + 0.73596158852214 + 0.73616758043117 + 0.73642234512300 + 0.73673915017902 + 0.73713536476815 + 0.73763394048184 + 0.73826574867242 + 0.73907449424943 + 0.74012721045855 + 0.74152295615973 + 0.74340056949999 + 0.74596490339160 + 0.74760025305157 + 0.74954252821854 + 0.75186786506679 + 0.75468005607409 + 0.75812580281050 + 0.76242240023644 + 0.76791238942761 + 0.77518388889071 + 0.78537796245047 + 0.80117121572833 + 0.83151553336020 + 1.00000000000000 + 0.82318774591729 + 0.78415639071821 + 0.75975253791976 + 0.74061984413940 + 0.72395539042941 + 0.70863664456302 + 0.69412909253149 + 0.68014592281197 + 0.66651841142960 + 0.65308743236213 + 0.63978909467902 + 0.62658728576279 + 0.61346667561487 + 0.60042883748802 + 0.58748969119397 + 0.57465123784128 + 0.56191816863763 + 0.54932172745425 + 0.53689224882378 + 0.52465357629301 + 0.72764244507114 + 0.72764244954600 + 0.72764245028725 + 0.72764245115157 + 0.72764245215861 + 0.72764245333275 + 0.72764245470097 + 0.72764245629669 + 0.72764245815858 + 0.72764246034126 + 0.72764246293956 + 0.72764246611317 + 0.72764247005935 + 0.72764247499175 + 0.72764248116342 + 0.72764248888501 + 0.72764249854104 + 0.72764251061026 + 0.72764252572951 + 0.72764254475290 + 0.72764256869617 + 0.72764259884271 + 0.72764263680990 + 0.72764268464011 + 0.72764274494691 + 0.72764282129796 + 0.72764291901294 + 0.72764304531123 + 0.72764320898517 + 0.72764342097746 + 0.72764369698863 + 0.72764405694663 + 0.72764452643261 + 0.72764513871827 + 0.72764593700295 + 0.72764697727242 + 0.72764833193507 + 0.72765009443485 + 0.72765239104618 + 0.72765539355279 + 0.72765932037910 + 0.72766445766970 + 0.72767117771553 + 0.72767992930170 + 0.72769102121018 + 0.72770445006768 + 0.72772039241052 + 0.72773897216468 + 0.72775968059562 + 0.72778213696065 + 0.72780639619484 + 0.72783263497746 + 0.72786107390860 + 0.72789197451846 + 0.72792573561365 + 0.72796278857439 + 0.72800354522884 + 0.72804849910290 + 0.72809825102182 + 0.72815358173565 + 0.72821580146553 + 0.72828765159063 + 0.72837298692379 + 0.72847563829668 + 0.72859988055433 + 0.72875131265032 + 0.72893685944355 + 0.72916536953006 + 0.72944829370137 + 0.72980055204102 + 0.73024175641365 + 0.73079813755457 + 0.73150666863651 + 0.73242393316145 + 0.73363280868946 + 0.73524733242684 + 0.73743190105092 + 0.73881296735822 + 0.74044089787006 + 0.74237195060284 + 0.74468039511401 + 0.74746703387683 + 0.75087359695758 + 0.75510874810960 + 0.76049927217283 + 0.76760296301836 + 0.77750417276573 + 0.79288318286443 + 0.82318774591729 + 1.00000000000000 + 0.81464360833809 + 0.77515466640219 + 0.75034605154015 + 0.73076327803872 + 0.71366159888473 + 0.69795147596134 + 0.68310872035968 + 0.66884405923665 + 0.65492751294956 + 0.64125278995550 + 0.62775545979123 + 0.61440044305554 + 0.60117513519832 + 0.58808510174968 + 0.57512451548601 + 0.56229229846527 + 0.54961552678737 + 0.53712131582317 + 0.52483094573099 + 0.72003206225317 + 0.72003206641462 + 0.72003206710400 + 0.72003206790748 + 0.72003206884417 + 0.72003206993588 + 0.72003207120864 + 0.72003207269228 + 0.72003207442377 + 0.72003207645366 + 0.72003207887085 + 0.72003208182664 + 0.72003208550628 + 0.72003209011145 + 0.72003209588038 + 0.72003210310671 + 0.72003211215253 + 0.72003212347079 + 0.72003213766449 + 0.72003215554086 + 0.72003217806270 + 0.72003220644508 + 0.72003224222066 + 0.72003228732675 + 0.72003234424426 + 0.72003241636008 + 0.72003250873113 + 0.72003262822604 + 0.72003278320884 + 0.72003298409505 + 0.72003324583455 + 0.72003358740742 + 0.72003403318294 + 0.72003461486243 + 0.72003537360735 + 0.72003636276471 + 0.72003765132953 + 0.72003932832851 + 0.72004151406959 + 0.72004437220928 + 0.72004811075972 + 0.72005300212722 + 0.72005940055465 + 0.72006773264668 + 0.72007829024801 + 0.72009106597140 + 0.72010622312769 + 0.72012387337078 + 0.72014352378168 + 0.72016480311409 + 0.72018775415672 + 0.72021253352531 + 0.72023933687861 + 0.72026839537730 + 0.72030006592050 + 0.72033473066696 + 0.72037274681022 + 0.72041454082209 + 0.72046063052720 + 0.72051169052995 + 0.72056887473266 + 0.72063464723658 + 0.72071246818504 + 0.72080572354291 + 0.72091814983463 + 0.72105462840353 + 0.72122116082808 + 0.72142538234861 + 0.72167713253116 + 0.72198917506343 + 0.72237820602940 + 0.72286644397663 + 0.72348509660358 + 0.72428186668490 + 0.72532609929817 + 0.72671167686921 + 0.72857129010770 + 0.72973826394998 + 0.73110529193586 + 0.73271481232232 + 0.73462143592815 + 0.73689695712835 + 0.73963831845682 + 0.74298096385632 + 0.74712278384946 + 0.75237107763380 + 0.75925004862443 + 0.76886268067018 + 0.78415639071821 + 0.81464360833809 + 1.00000000000000 + 0.80580419144212 + 0.76590030565430 + 0.74065706482634 + 0.72061177948738 + 0.70308572092411 + 0.68701289411455 + 0.67186812048301 + 0.65729727478463 + 0.64312449964564 + 0.62924142334093 + 0.61558361225678 + 0.60211808408835 + 0.58883590653443 + 0.57572053522587 + 0.56276311956783 + 0.54998518420810 + 0.53740960771570 + 0.52505433348565 + 0.71190117775669 + 0.71190118161557 + 0.71190118225510 + 0.71190118300028 + 0.71190118386902 + 0.71190118488166 + 0.71190118606175 + 0.71190118743758 + 0.71190118904305 + 0.71190119092599 + 0.71190119316922 + 0.71190119591436 + 0.71190119933524 + 0.71190120362165 + 0.71190120899745 + 0.71190121573870 + 0.71190122418631 + 0.71190123476582 + 0.71190124804611 + 0.71190126478696 + 0.71190128589729 + 0.71190131252444 + 0.71190134611482 + 0.71190138849849 + 0.71190144202141 + 0.71190150988359 + 0.71190159687706 + 0.71190170950323 + 0.71190185569129 + 0.71190204531082 + 0.71190229253929 + 0.71190261537768 + 0.71190303694329 + 0.71190358731167 + 0.71190430553583 + 0.71190524223639 + 0.71190646286828 + 0.71190805188612 + 0.71191012341835 + 0.71191283269847 + 0.71191637695836 + 0.71192101438123 + 0.71192708053514 + 0.71193497911440 + 0.71194498467265 + 0.71195708622362 + 0.71197143399910 + 0.71198812780914 + 0.71200669244444 + 0.71202676796239 + 0.71204838617793 + 0.71207168492931 + 0.71209683660192 + 0.71212404415835 + 0.71215362533049 + 0.71218591674261 + 0.71222122589109 + 0.71225991861069 + 0.71230243803733 + 0.71234936340486 + 0.71240170633919 + 0.71246167276746 + 0.71253235528563 + 0.71261673239951 + 0.71271805304507 + 0.71284055078726 + 0.71298939921496 + 0.71317115150421 + 0.71339421859441 + 0.71366946463172 + 0.71401103653252 + 0.71443767489153 + 0.71497562860449 + 0.71566500711804 + 0.71656374110913 + 0.71774913320890 + 0.71932859388093 + 0.72031342895841 + 0.72146103837213 + 0.72280390965059 + 0.72438300264466 + 0.72625082978566 + 0.72847611025790 + 0.73115110612726 + 0.73440380854404 + 0.73841967706722 + 0.74348717946897 + 0.75016088655037 + 0.75975253791976 + 0.77515466640219 + 0.80580419144212 + 1.00000000000000 + 0.79679834819575 + 0.75645314002104 + 0.73072841830997 + 0.71021027649643 + 0.69227718752263 + 0.67586906521787 + 0.66039120685873 + 0.64554489790867 + 0.63114958414967 + 0.61709516788113 + 0.60331826887668 + 0.58978902104386 + 0.57647582848323 + 0.56335914005752 + 0.55045294694538 + 0.53777446267405 + 0.52533722851948 + 0.70325883642458 + 0.70325883999364 + 0.70325884058487 + 0.70325884127405 + 0.70325884207755 + 0.70325884301384 + 0.70325884410554 + 0.70325884537809 + 0.70325884686309 + 0.70325884860437 + 0.70325885067961 + 0.70325885322173 + 0.70325885639246 + 0.70325886037014 + 0.70325886536353 + 0.70325887163146 + 0.70325887949375 + 0.70325888934908 + 0.70325890173027 + 0.70325891735281 + 0.70325893706891 + 0.70325896195703 + 0.70325899337707 + 0.70325903305127 + 0.70325908318626 + 0.70325914679656 + 0.70325922839758 + 0.70325933412431 + 0.70325947145432 + 0.70325964970120 + 0.70325988224704 + 0.70326018609062 + 0.70326058306303 + 0.70326110156797 + 0.70326177849363 + 0.70326266164837 + 0.70326381285371 + 0.70326531185533 + 0.70326726641782 + 0.70326982311455 + 0.70327316807912 + 0.70327754486912 + 0.70328326985939 + 0.70329072323886 + 0.70330016202887 + 0.70331157208302 + 0.70332509079484 + 0.70334080662423 + 0.70335826387219 + 0.70337711561122 + 0.70339738390183 + 0.70341918916701 + 0.70344268224937 + 0.70346804016467 + 0.70349554430198 + 0.70352548948678 + 0.70355813843918 + 0.70359380265167 + 0.70363285864662 + 0.70367580067701 + 0.70372351167318 + 0.70377795842880 + 0.70384189320073 + 0.70391792368775 + 0.70400886022222 + 0.70411835556971 + 0.70425084579578 + 0.70441192535139 + 0.70460874618811 + 0.70485050841781 + 0.70514914089762 + 0.70552038045758 + 0.70598622081214 + 0.70658028357138 + 0.70735085840908 + 0.70836154701504 + 0.70969942094811 + 0.71052891165492 + 0.71149112624258 + 0.71261120461825 + 0.71392032417539 + 0.71545766565827 + 0.71727326247253 + 0.71943227266102 + 0.72202165316297 + 0.72516121659025 + 0.72902575471576 + 0.73393680692667 + 0.74061984413940 + 0.75034605154015 + 0.76590030565430 + 0.79679834819575 + 1.00000000000000 + 0.78763658638201 + 0.74681017943161 + 0.72056674619305 + 0.69958009784347 + 0.68126335782816 + 0.66448392340109 + 0.64870422730085 + 0.63361654383424 + 0.61903583297823 + 0.60485142166851 + 0.59100218402125 + 0.57743480830969 + 0.56411468596884 + 0.55104539815066 + 0.53823647178391 + 0.52569557197741 + 0.69412466393630 + 0.69412466722767 + 0.69412466777293 + 0.69412466840836 + 0.69412466914889 + 0.69412467001224 + 0.69412467101867 + 0.69412467219198 + 0.69412467356145 + 0.69412467516702 + 0.69412467708137 + 0.69412467942805 + 0.69412468235763 + 0.69412468603657 + 0.69412469065976 + 0.69412469646754 + 0.69412470375928 + 0.69412471290637 + 0.69412472440727 + 0.69412473893001 + 0.69412475727301 + 0.69412478044436 + 0.69412480971867 + 0.69412484670639 + 0.69412489347545 + 0.69412495285403 + 0.69412502907714 + 0.69412512790387 + 0.69412525635622 + 0.69412542318236 + 0.69412564095420 + 0.69412592564844 + 0.69412629778392 + 0.69412678405943 + 0.69412741915167 + 0.69412824799923 + 0.69412932870834 + 0.69413073622244 + 0.69413257180692 + 0.69413497318144 + 0.69413811515542 + 0.69414222636144 + 0.69414760360979 + 0.69415460316908 + 0.69416346441584 + 0.69417417050500 + 0.69418684632317 + 0.69420156956551 + 0.69421790565103 + 0.69423552224407 + 0.69425443288533 + 0.69427474199532 + 0.69429658066998 + 0.69432010226647 + 0.69434555472631 + 0.69437319484590 + 0.69440324539912 + 0.69443596968226 + 0.69447168539975 + 0.69451081175797 + 0.69455411613124 + 0.69460334515823 + 0.69466093801211 + 0.69472916743354 + 0.69481045232974 + 0.69490792880546 + 0.69502538115886 + 0.69516756095781 + 0.69534051886880 + 0.69555200741297 + 0.69581203763954 + 0.69613376615261 + 0.69653555066238 + 0.69704548536925 + 0.69770372594581 + 0.69856253467885 + 0.69969253286800 + 0.70038959051418 + 0.70119497079510 + 0.70212828398741 + 0.70321352461418 + 0.70448036565671 + 0.70596597099536 + 0.70771760463446 + 0.70979651313231 + 0.71228400561471 + 0.71529353129059 + 0.71903066481209 + 0.72395539042941 + 0.73076327803872 + 0.74065706482634 + 0.75645314002104 + 0.78763658638201 + 1.00000000000000 + 0.77832874920566 + 0.73697203237332 + 0.71018659981888 + 0.68874489844083 + 0.67000049409977 + 0.65288201276253 + 0.63683546819088 + 0.62154400538101 + 0.60681936551442 + 0.59255175600650 + 0.57865547731562 + 0.56507415646602 + 0.55179666875244 + 0.53882192342418 + 0.52614962821113 + 0.68452764856428 + 0.68452765158897 + 0.68452765209019 + 0.68452765267416 + 0.68452765335479 + 0.68452765414823 + 0.68452765507312 + 0.68452765615162 + 0.68452765740997 + 0.68452765888556 + 0.68452766064598 + 0.68452766280473 + 0.68452766550252 + 0.68452766889258 + 0.68452767315681 + 0.68452767851816 + 0.68452768525472 + 0.68452769371176 + 0.68452770435252 + 0.68452771779907 + 0.68452773479409 + 0.68452775627813 + 0.68452778343642 + 0.68452781777332 + 0.68452786121450 + 0.68452791639993 + 0.68452798728428 + 0.68452807924916 + 0.68452819885515 + 0.68452835427719 + 0.68452855727453 + 0.68452882278645 + 0.68452917000408 + 0.68452962390005 + 0.68453021691358 + 0.68453099107710 + 0.68453200073603 + 0.68453331596947 + 0.68453503146184 + 0.68453727597162 + 0.68454021284708 + 0.68454405563792 + 0.68454908138366 + 0.68455562223608 + 0.68456389997168 + 0.68457389552234 + 0.68458572170277 + 0.68459944609830 + 0.68461465660411 + 0.68463103685087 + 0.68464859308024 + 0.68466741515981 + 0.68468761626303 + 0.68470932838792 + 0.68473276894699 + 0.68475816044328 + 0.68478569040532 + 0.68481557982515 + 0.68484809500515 + 0.68488358952182 + 0.68492272774628 + 0.68496705497293 + 0.68501872439064 + 0.68507970851025 + 0.68515207982826 + 0.68523851865142 + 0.68534223811532 + 0.68546725485043 + 0.68561866389272 + 0.68580296804413 + 0.68602853185243 + 0.68630630946493 + 0.68665156805888 + 0.68708771207765 + 0.68764805288963 + 0.68837547198645 + 0.68932724950644 + 0.68991166423216 + 0.69058450853571 + 0.69136117243969 + 0.69226027894378 + 0.69330455841295 + 0.69452203829375 + 0.69594769945724 + 0.69762584568438 + 0.69961365978332 + 0.70198843497498 + 0.70489045604714 + 0.70863664456302 + 0.71366159888473 + 0.72061177948738 + 0.73072841830997 + 0.74681017943161 + 0.77832874920566 + 1.00000000000000 + 0.76888433321186 + 0.72694455769704 + 0.69960475879112 + 0.67764873414581 + 0.65851062601231 + 0.64108989646173 + 0.62481516364706 + 0.60936184453934 + 0.59454029009974 + 0.58021446131338 + 0.56629546982375 + 0.55275084967145 + 0.53956452055180 + 0.52672522342723 + 0.67450480125254 + 0.67450480402211 + 0.67450480448085 + 0.67450480501584 + 0.67450480563905 + 0.67450480636572 + 0.67450480721252 + 0.67450480820003 + 0.67450480935233 + 0.67450481070389 + 0.67450481231563 + 0.67450481429430 + 0.67450481676860 + 0.67450481988074 + 0.67450482379808 + 0.67450482872714 + 0.67450483492480 + 0.67450484271072 + 0.67450485251373 + 0.67450486491019 + 0.67450488058836 + 0.67450490041835 + 0.67450492550204 + 0.67450495723252 + 0.67450499739986 + 0.67450504845378 + 0.67450511406795 + 0.67450519924653 + 0.67450531009025 + 0.67450545420158 + 0.67450564252108 + 0.67450588894987 + 0.67450621134972 + 0.67450663296364 + 0.67450718397863 + 0.67450790351799 + 0.67450884215108 + 0.67451006508067 + 0.67451166039413 + 0.67451374786063 + 0.67451647935562 + 0.67452005331736 + 0.67452472702296 + 0.67453080854629 + 0.67453850229249 + 0.67454778744056 + 0.67455876526829 + 0.67457149397685 + 0.67458558499629 + 0.67460073901920 + 0.67461695618329 + 0.67463431325775 + 0.67465290730627 + 0.67467285123823 + 0.67469433483473 + 0.67471754995357 + 0.67474265334640 + 0.67476982926702 + 0.67479929955248 + 0.67483136091035 + 0.67486658656745 + 0.67490633892309 + 0.67495251179545 + 0.67500681068812 + 0.67507100406065 + 0.67514737343328 + 0.67523863557152 + 0.67534817156954 + 0.67548025386719 + 0.67564031465339 + 0.67583531509732 + 0.67607434167567 + 0.67637004959454 + 0.67674188292880 + 0.67721741396803 + 0.67783177607330 + 0.67863141825818 + 0.67912033695099 + 0.67968143819175 + 0.68032685734185 + 0.68107114451128 + 0.68193186853794 + 0.68293041889627 + 0.68409309114110 + 0.68545259015354 + 0.68705021399316 + 0.68894050176174 + 0.69122351030506 + 0.69412909253149 + 0.69795147596134 + 0.70308572092411 + 0.71021027649643 + 0.72056674619305 + 0.73697203237332 + 0.76888433321186 + 1.00000000000000 + 0.75931292786139 + 0.71673280149597 + 0.68874378827102 + 0.66630946594638 + 0.64681792980285 + 0.62913585829935 + 0.61267596504666 + 0.59710834722450 + 0.58221453848203 + 0.56785503816633 + 0.55396537071940 + 0.54050772403501 + 0.52745539709066 + 0.66409973310682 + 0.66409973563253 + 0.66409973605097 + 0.66409973653867 + 0.66409973710699 + 0.66409973776960 + 0.66409973854170 + 0.66409973944187 + 0.66409974049284 + 0.66409974172507 + 0.66409974319564 + 0.66409974500121 + 0.66409974726109 + 0.66409975010534 + 0.66409975368855 + 0.66409975820024 + 0.66409976387668 + 0.66409977101239 + 0.66409978000256 + 0.66409979137735 + 0.66409980577296 + 0.66409982399203 + 0.66409984705037 + 0.66409987623465 + 0.66409991319754 + 0.66409996020221 + 0.66410002064635 + 0.66410009915712 + 0.66410020138144 + 0.66410033435221 + 0.66410050819798 + 0.66410073578966 + 0.66410103366685 + 0.66410142335319 + 0.66410193280394 + 0.66410259824730 + 0.66410346650738 + 0.66410459794111 + 0.66410607409009 + 0.66410800580604 + 0.66411053358447 + 0.66411384090338 + 0.66411816547909 + 0.66412379162016 + 0.66413090675261 + 0.66413948877117 + 0.66414962804443 + 0.66416137416991 + 0.66417436282067 + 0.66418831255238 + 0.66420321852180 + 0.66421914583524 + 0.66423617722390 + 0.66425440869290 + 0.66427400522752 + 0.66429513152519 + 0.66431791774421 + 0.66434251654181 + 0.66436911165709 + 0.66439795094215 + 0.66442952752217 + 0.66446503873984 + 0.66450614484661 + 0.66455431564705 + 0.66461105484029 + 0.66467829774625 + 0.66475833316292 + 0.66485399687079 + 0.66496885859365 + 0.66510744003578 + 0.66527551446758 + 0.66548059461097 + 0.66573314049563 + 0.66604926770017 + 0.66645175417717 + 0.66696934739281 + 0.66763970208542 + 0.66804795636879 + 0.66851511726217 + 0.66905079015264 + 0.66966640372704 + 0.67037563537985 + 0.67119496423413 + 0.67214440205517 + 0.67324847828122 + 0.67453763565608 + 0.67605138542155 + 0.67786335789421 + 0.68014592281197 + 0.68310872035968 + 0.68701289411455 + 0.69227718752263 + 0.69958009784347 + 0.71018659981888 + 0.72694455769704 + 0.75931292786139 + 1.00000000000000 + 0.74961284898869 + 0.70621654960453 + 0.67761348149394 + 0.65474758502003 + 0.63494815759626 + 0.61705019113123 + 0.60045388082035 + 0.58479637319275 + 0.56985519932832 + 0.55551587197673 + 0.54170802889656 + 0.52838264870775 + 0.65335849162471 + 0.65335849391705 + 0.65335849429653 + 0.65335849473933 + 0.65335849525504 + 0.65335849585642 + 0.65335849655730 + 0.65335849737457 + 0.65335849832852 + 0.65335849944714 + 0.65335850078233 + 0.65335850242249 + 0.65335850447642 + 0.65335850706424 + 0.65335851032599 + 0.65335851443564 + 0.65335851960975 + 0.65335852611731 + 0.65335853432179 + 0.65335854470949 + 0.65335855786289 + 0.65335857451941 + 0.65335859561129 + 0.65335862232106 + 0.65335865616643 + 0.65335869922857 + 0.65335875463251 + 0.65335882663825 + 0.65335892044250 + 0.65335904251960 + 0.65335920220092 + 0.65335941134459 + 0.65335968518571 + 0.65336004355929 + 0.65336051222531 + 0.65336112456193 + 0.65336192371193 + 0.65336296527231 + 0.65336432435118 + 0.65336610304332 + 0.65336843067708 + 0.65337147606834 + 0.65337545778512 + 0.65338063691458 + 0.65338718447065 + 0.65339507750733 + 0.65340439618723 + 0.65341518232309 + 0.65342709617395 + 0.65343987465273 + 0.65345350897203 + 0.65346805395163 + 0.65348357968482 + 0.65350016734808 + 0.65351795982698 + 0.65353709793957 + 0.65355768906750 + 0.65357985893626 + 0.65360375890526 + 0.65362959516432 + 0.65365779083249 + 0.65368939519698 + 0.65372585948658 + 0.65376844679085 + 0.65381843182875 + 0.65387745139068 + 0.65394742778469 + 0.65403073204168 + 0.65413033750772 + 0.65424999648101 + 0.65439448271366 + 0.65456999015463 + 0.65478514293589 + 0.65505327093677 + 0.65539316041455 + 0.65582830621302 + 0.65638922332003 + 0.65672956541639 + 0.65711796506417 + 0.65756204823337 + 0.65807083037611 + 0.65865502125298 + 0.65932741412529 + 0.66010338969023 + 0.66100157977345 + 0.66204478978353 + 0.66326223389299 + 0.66470935330342 + 0.66651841142960 + 0.66884405923665 + 0.67186812048301 + 0.67586906521787 + 0.68126335782816 + 0.68874489844083 + 0.69960475879112 + 0.71673280149597 + 0.74961284898869 + 1.00000000000000 + 0.73957571203458 + 0.69539261556567 + 0.66623095218144 + 0.64298771225760 + 0.62293044209203 + 0.60486741678173 + 0.58815878407553 + 0.57243660790139 + 0.55750412392669 + 0.54324019712656 + 0.52956248201388 + 0.64228120335253 + 0.64228120542178 + 0.64228120576441 + 0.64228120616423 + 0.64228120662978 + 0.64228120717275 + 0.64228120780532 + 0.64228120854287 + 0.64228120940387 + 0.64228121041408 + 0.64228121161955 + 0.64228121310131 + 0.64228121495828 + 0.64228121729928 + 0.64228122025209 + 0.64228122397520 + 0.64228122866467 + 0.64228123456733 + 0.64228124201271 + 0.64228125144514 + 0.64228126339702 + 0.64228127854026 + 0.64228129772659 + 0.64228132203511 + 0.64228135285377 + 0.64228139208456 + 0.64228144258783 + 0.64228150826137 + 0.64228159386222 + 0.64228170532125 + 0.64228185118622 + 0.64228204232082 + 0.64228229268739 + 0.64228262046591 + 0.64228304926369 + 0.64228360967407 + 0.64228434123361 + 0.64228529488848 + 0.64228653945398 + 0.64228816846929 + 0.64229030036364 + 0.64229308965196 + 0.64229673625739 + 0.64230147870292 + 0.64230747221436 + 0.64231469341887 + 0.64232321298462 + 0.64233306573525 + 0.64234393664024 + 0.64235558125165 + 0.64236798775940 + 0.64238120195644 + 0.64239528284103 + 0.64241029862841 + 0.64242637255328 + 0.64244362448741 + 0.64246214238747 + 0.64248202910692 + 0.64250340858147 + 0.64252645155258 + 0.64255151999742 + 0.64257953049734 + 0.64261174745619 + 0.64264925291349 + 0.64269312389069 + 0.64274474018842 + 0.64280571084642 + 0.64287801150906 + 0.64296411026134 + 0.64306711022022 + 0.64319094525144 + 0.64334070526269 + 0.64352347964454 + 0.64375026643913 + 0.64403652560660 + 0.64440142326233 + 0.64486965789396 + 0.64515276698147 + 0.64547503623509 + 0.64584252918063 + 0.64626237544119 + 0.64674299228550 + 0.64729436312415 + 0.64792839185597 + 0.64865936048848 + 0.64950455604129 + 0.65048590598764 + 0.65164584139831 + 0.65308743236213 + 0.65492751294956 + 0.65729727478463 + 0.66039120685873 + 0.66448392340109 + 0.67000049409977 + 0.67764873414581 + 0.68874378827102 + 0.70621654960453 + 0.73957571203458 + 1.00000000000000 + 0.72935132575460 + 0.68436008259231 + 0.65467731371170 + 0.63109880606100 + 0.61082789473226 + 0.59261642903728 + 0.57581583618384 + 0.56008391334117 + 0.54521575460515 + 0.53107696778608 + 0.63091181769725 + 0.63091181955402 + 0.63091181986171 + 0.63091182022021 + 0.63091182063800 + 0.63091182112510 + 0.63091182169273 + 0.63091182235489 + 0.63091182312739 + 0.63091182403382 + 0.63091182511589 + 0.63091182644650 + 0.63091182811542 + 0.63091183022023 + 0.63091183287747 + 0.63091183622959 + 0.63091184045564 + 0.63091184577766 + 0.63091185249446 + 0.63091186100981 + 0.63091187180546 + 0.63091188549201 + 0.63091190284307 + 0.63091192483772 + 0.63091195273751 + 0.63091198827217 + 0.63091203404245 + 0.63091209359673 + 0.63091217126615 + 0.63091227245133 + 0.63091240494065 + 0.63091257863397 + 0.63091280625825 + 0.63091310438244 + 0.63091349452968 + 0.63091400459198 + 0.63091467060941 + 0.63091553901869 + 0.63091667254363 + 0.63091815644008 + 0.63092009859727 + 0.63092263971692 + 0.63092596173681 + 0.63093028146258 + 0.63093573907724 + 0.63094231115338 + 0.63095005961476 + 0.63095901307516 + 0.63096888102864 + 0.63097943765975 + 0.63099066895117 + 0.63100261283865 + 0.63101531864368 + 0.63102884333278 + 0.63104329276167 + 0.63105876852301 + 0.63107534212008 + 0.63109309710116 + 0.63111213430849 + 0.63113259446156 + 0.63115478632921 + 0.63117950805787 + 0.63120785781467 + 0.63124075976675 + 0.63127912101920 + 0.63132410114320 + 0.63137704261329 + 0.63143958623675 + 0.63151377393874 + 0.63160216346126 + 0.63170798584111 + 0.63183541027859 + 0.63199024757236 + 0.63218154959147 + 0.63242201112161 + 0.63272723636525 + 0.63311718638252 + 0.63335217126114 + 0.63361902084606 + 0.63392255997021 + 0.63426843580585 + 0.63466328086954 + 0.63511491521629 + 0.63563259989095 + 0.63622735884407 + 0.63691241535950 + 0.63770441900594 + 0.63863624062816 + 0.63978909467902 + 0.64125278995550 + 0.64312449964564 + 0.64554489790867 + 0.64870422730085 + 0.65288201276253 + 0.65851062601231 + 0.66630946594638 + 0.67761348149394 + 0.69539261556567 + 0.72935132575460 + 1.00000000000000 + 0.71894424599500 + 0.67314430258021 + 0.64298404928106 + 0.61911515057607 + 0.59864318464156 + 0.58030137825111 + 0.56346542534908 + 0.54778234365529 + 0.53303202241657 + 0.61929719598411 + 0.61929719763943 + 0.61929719791367 + 0.61929719823356 + 0.61929719860587 + 0.61929719903996 + 0.61929719954631 + 0.61929720013627 + 0.61929720082535 + 0.61929720163339 + 0.61929720259837 + 0.61929720378556 + 0.61929720527567 + 0.61929720715673 + 0.61929720953242 + 0.61929721253214 + 0.61929721631535 + 0.61929722108370 + 0.61929722710560 + 0.61929723474530 + 0.61929724443659 + 0.61929725673033 + 0.61929727232487 + 0.61929729210531 + 0.61929731720932 + 0.61929734920173 + 0.61929739043420 + 0.61929744411828 + 0.61929751417519 + 0.61929760549697 + 0.61929772513788 + 0.61929788207152 + 0.61929808783460 + 0.61929835745006 + 0.61929871043441 + 0.61929917207920 + 0.61929977506742 + 0.61930056150491 + 0.61930158826937 + 0.61930293266464 + 0.61930469248366 + 0.61930699520254 + 0.61931000556689 + 0.61931391966731 + 0.61931886348076 + 0.61932481385142 + 0.61933182471061 + 0.61933991922675 + 0.61934883092400 + 0.61935835235311 + 0.61936846798851 + 0.61937920897078 + 0.61939061623622 + 0.61940273703544 + 0.61941566191307 + 0.61942947657609 + 0.61944423866103 + 0.61946001550385 + 0.61947688857169 + 0.61949497324485 + 0.61951453209610 + 0.61953625792577 + 0.61956110150727 + 0.61958984977577 + 0.61962326427304 + 0.61966231642993 + 0.61970812264240 + 0.61976204106264 + 0.61982575532210 + 0.61990136642395 + 0.61999151902629 + 0.62009961664022 + 0.62023040746249 + 0.62039132232456 + 0.62059276089373 + 0.62084739898383 + 0.62117133839816 + 0.62136591480836 + 0.62158637266588 + 0.62183655080867 + 0.62212092479815 + 0.62244472806769 + 0.62281410051991 + 0.62323627244021 + 0.62371979486320 + 0.62427484966592 + 0.62491418779292 + 0.62566350071775 + 0.62658728576279 + 0.62775545979123 + 0.62924142334093 + 0.63114958414967 + 0.63361654383424 + 0.63683546819088 + 0.64108989646173 + 0.64681792980285 + 0.65474758502003 + 0.66623095218144 + 0.68436008259231 + 0.71894424599500 + 1.00000000000000 + 0.70836375382622 + 0.66177424586778 + 0.63118398455016 + 0.60703193255414 + 0.58637363232091 + 0.56795999764370 + 0.55115082249515 + 0.53557476843076 + 0.60748715500285 + 0.60748715646855 + 0.60748715671142 + 0.60748715699437 + 0.60748715732422 + 0.60748715770864 + 0.60748715815711 + 0.60748715867951 + 0.60748715928936 + 0.60748716000473 + 0.60748716085952 + 0.60748716191176 + 0.60748716323346 + 0.60748716490252 + 0.60748716701269 + 0.60748716967887 + 0.60748717304414 + 0.60748717728835 + 0.60748718265211 + 0.60748718946054 + 0.60748719810404 + 0.60748720907613 + 0.60748722300263 + 0.60748724067815 + 0.60748726312573 + 0.60748729174827 + 0.60748732866302 + 0.60748737675908 + 0.60748743956599 + 0.60748752148776 + 0.60748762888305 + 0.60748776983819 + 0.60748795475445 + 0.60748819717936 + 0.60748851471566 + 0.60748893017546 + 0.60748947304411 + 0.60749018130443 + 0.60749110626644 + 0.60749231767196 + 0.60749390371664 + 0.60749597933021 + 0.60749869295979 + 0.60750222110880 + 0.60750667644238 + 0.60751203635150 + 0.60751834751701 + 0.60752562837258 + 0.60753363571605 + 0.60754217997379 + 0.60755124469024 + 0.60756085515467 + 0.60757104506919 + 0.60758185332568 + 0.60759335702199 + 0.60760562809463 + 0.60761871253276 + 0.60763266409517 + 0.60764754804869 + 0.60766345842641 + 0.60768061775380 + 0.60769962536941 + 0.60772130169090 + 0.60774631461728 + 0.60777530123880 + 0.60780907257736 + 0.60784855367304 + 0.60789486456506 + 0.60794938825972 + 0.60801384402097 + 0.60809038822850 + 0.60818178876887 + 0.60829191206171 + 0.60842684021564 + 0.60859506934403 + 0.60880686822742 + 0.60907519279101 + 0.60923585925322 + 0.60941749675491 + 0.60962315625714 + 0.60985638276397 + 0.61012130606147 + 0.61042275097794 + 0.61076637239465 + 0.61115882240976 + 0.61160797440120 + 0.61212365064502 + 0.61272605379805 + 0.61346667561487 + 0.61440044305554 + 0.61558361225678 + 0.61709516788113 + 0.61903583297823 + 0.62154400538101 + 0.62481516364706 + 0.62913585829935 + 0.63494815759626 + 0.64298771225760 + 0.65467731371170 + 0.67314430258021 + 0.70836375382622 + 1.00000000000000 + 0.69762461025856 + 0.65028118395227 + 0.61926161954540 + 0.59483668531354 + 0.57405292808547 + 0.55563388460776 + 0.53891548995409 + 0.59553479242522 + 0.59553479371399 + 0.59553479392716 + 0.59553479417595 + 0.59553479446592 + 0.59553479480405 + 0.59553479519808 + 0.59553479565726 + 0.59553479619350 + 0.59553479682218 + 0.59553479757400 + 0.59553479849933 + 0.59553479966288 + 0.59553480113399 + 0.59553480299473 + 0.59553480534804 + 0.59553480832034 + 0.59553481207149 + 0.59553481681566 + 0.59553482284277 + 0.59553483049937 + 0.59553484022591 + 0.59553485258075 + 0.59553486827113 + 0.59553488821037 + 0.59553491365310 + 0.59553494648948 + 0.59553498930605 + 0.59553504526127 + 0.59553511829796 + 0.59553521411229 + 0.59553533995417 + 0.59553550514868 + 0.59553572184694 + 0.59553600584052 + 0.59553637760186 + 0.59553686358994 + 0.59553749789288 + 0.59553832656695 + 0.59553941222009 + 0.59554083400475 + 0.59554269503699 + 0.59554512844524 + 0.59554829235964 + 0.59555228707104 + 0.59555709072939 + 0.59556274348606 + 0.59556925968680 + 0.59557641842849 + 0.59558404732205 + 0.59559212944470 + 0.59560068507614 + 0.59560974169468 + 0.59561933102123 + 0.59562951836847 + 0.59564036376176 + 0.59565190343545 + 0.59566417980774 + 0.59567724461707 + 0.59569117394179 + 0.59570615562834 + 0.59572270627577 + 0.59574153126088 + 0.59576319537238 + 0.59578822943694 + 0.59581730788047 + 0.59585119398031 + 0.59589080744656 + 0.59593727937279 + 0.59599201038188 + 0.59605675078087 + 0.59613374141585 + 0.59622611764876 + 0.59633884002755 + 0.59647882621658 + 0.59665436613064 + 0.59687584911582 + 0.59700806214564 + 0.59715721261936 + 0.59732571969329 + 0.59751638593855 + 0.59773246566634 + 0.59797774727775 + 0.59825665322742 + 0.59857436259944 + 0.59893697511302 + 0.59935208099647 + 0.59983562369891 + 0.60042883748802 + 0.60117513519832 + 0.60211808408835 + 0.60331826887668 + 0.60485142166851 + 0.60681936551442 + 0.60936184453934 + 0.61267596504666 + 0.61705019113123 + 0.62293044209203 + 0.63109880606100 + 0.64298404928106 + 0.66177424586778 + 0.69762461025856 + 1.00000000000000 + 0.68674716373068 + 0.63863144537846 + 0.60718986691018 + 0.58255698494096 + 0.56171950771243 + 0.54336635779483 + 0.58349668799590 + 0.58349668911996 + 0.58349668930604 + 0.58349668952287 + 0.58349668977559 + 0.58349669007047 + 0.58349669041424 + 0.58349669081484 + 0.58349669128242 + 0.58349669183121 + 0.58349669248694 + 0.58349669329512 + 0.58349669431158 + 0.58349669559814 + 0.58349669722723 + 0.58349669928862 + 0.58349670189492 + 0.58349670518658 + 0.58349670935303 + 0.58349671464997 + 0.58349672138550 + 0.58349672994791 + 0.58349674083198 + 0.58349675466583 + 0.58349677225888 + 0.58349679472384 + 0.58349682374113 + 0.58349686161115 + 0.58349691114284 + 0.58349697584853 + 0.58349706080168 + 0.58349717246540 + 0.58349731915648 + 0.58349751171316 + 0.58349776423019 + 0.58349809498434 + 0.58349852759730 + 0.58349909251103 + 0.58349983086438 + 0.58350079858506 + 0.58350206637408 + 0.58350372631717 + 0.58350589725995 + 0.58350872023384 + 0.58351228410998 + 0.58351656795769 + 0.58352160608315 + 0.58352740932540 + 0.58353377792643 + 0.58354055583240 + 0.58354772602308 + 0.58355530450044 + 0.58356331340828 + 0.58357177833703 + 0.58358075429516 + 0.58359029102585 + 0.58360041661696 + 0.58361116403601 + 0.58362257375895 + 0.58363470678530 + 0.58364772097222 + 0.58366205984391 + 0.58367832748241 + 0.58369699949159 + 0.58371851608632 + 0.58374343551657 + 0.58377238448570 + 0.58380611437534 + 0.58384554545889 + 0.58389181272845 + 0.58394632921225 + 0.58401089927840 + 0.58408805275482 + 0.58418181806860 + 0.58429780438178 + 0.58444267473304 + 0.58462472334050 + 0.58473306790524 + 0.58485503459712 + 0.58499253449032 + 0.58514777568769 + 0.58532331486740 + 0.58552211901635 + 0.58574763982115 + 0.58600390414039 + 0.58629563515348 + 0.58662870144489 + 0.58701570142396 + 0.58748969119397 + 0.58808510174968 + 0.58883590653443 + 0.58978902104386 + 0.59100218402125 + 0.59255175600650 + 0.59454029009974 + 0.59710834722450 + 0.60045388082035 + 0.60486741678173 + 0.61082789473226 + 0.61911515057607 + 0.63118398455016 + 0.65028118395227 + 0.68674716373068 + 1.00000000000000 + 0.67564265955552 + 0.62677318588660 + 0.59498719431147 + 0.57022565759438 + 0.54941513472537 + 0.57140796967911 + 0.57140797065113 + 0.57140797081229 + 0.57140797099990 + 0.57140797121886 + 0.57140797147378 + 0.57140797177097 + 0.57140797211771 + 0.57140797252216 + 0.57140797299679 + 0.57140797356441 + 0.57140797426450 + 0.57140797514572 + 0.57140797626177 + 0.57140797767651 + 0.57140797946816 + 0.57140798173558 + 0.57140798460176 + 0.57140798823312 + 0.57140799285360 + 0.57140799873410 + 0.57140800621659 + 0.57140801573596 + 0.57140802784537 + 0.57140804325791 + 0.57140806295488 + 0.57140808842121 + 0.57140812168855 + 0.57140816524291 + 0.57140822219119 + 0.57140829702926 + 0.57140839548364 + 0.57140852493116 + 0.57140869498922 + 0.57140891816911 + 0.57140921069880 + 0.57140959356233 + 0.57141009380591 + 0.57141074799031 + 0.57141160583490 + 0.57141273018820 + 0.57141420289748 + 0.57141612956841 + 0.57141863541802 + 0.57142179883117 + 0.57142559991106 + 0.57143006775308 + 0.57143521021082 + 0.57144084741533 + 0.57144683871966 + 0.57145316729131 + 0.57145984549610 + 0.57146689091595 + 0.57147432391624 + 0.57148219051435 + 0.57149053158956 + 0.57149936845014 + 0.57150872620888 + 0.57151863598888 + 0.57152914614660 + 0.57154038863180 + 0.57155274251566 + 0.57156672278602 + 0.57158272796082 + 0.57160112102413 + 0.57162236145655 + 0.57164696071440 + 0.57167552880782 + 0.57170880967372 + 0.57174771697837 + 0.57179338376817 + 0.57184725310027 + 0.57191135335389 + 0.57198893809700 + 0.57208453125458 + 0.57220345747240 + 0.57235229888903 + 0.57244061274636 + 0.57253982075081 + 0.57265142421916 + 0.57277715355870 + 0.57291900713119 + 0.57307929751688 + 0.57326070692204 + 0.57346635414092 + 0.57369988442405 + 0.57396582436552 + 0.57427411761059 + 0.57465123784128 + 0.57512451548601 + 0.57572053522587 + 0.57647582848323 + 0.57743480830969 + 0.57865547731562 + 0.58021446131338 + 0.58221453848203 + 0.58479637319275 + 0.58815878407553 + 0.59261642903728 + 0.59864318464156 + 0.60703193255414 + 0.61926161954540 + 0.63863144537846 + 0.67564265955552 + 1.00000000000000 + 0.66428832169132 + 0.61475911162871 + 0.58270684787165 + 0.55790105999687 + 0.55929895121005 + 0.55929895204386 + 0.55929895218191 + 0.55929895234289 + 0.55929895253043 + 0.55929895274920 + 0.55929895300392 + 0.55929895330124 + 0.55929895364827 + 0.55929895405534 + 0.55929895454224 + 0.55929895514308 + 0.55929895590049 + 0.55929895686059 + 0.55929895807867 + 0.55929895962325 + 0.55929896157976 + 0.55929896405536 + 0.55929896719479 + 0.55929897119398 + 0.55929897628859 + 0.55929898277761 + 0.55929899104037 + 0.55929900156154 + 0.55929901496442 + 0.55929903210996 + 0.55929905429964 + 0.55929908331822 + 0.55929912135283 + 0.55929917113482 + 0.55929923662372 + 0.55929932286710 + 0.55929943636855 + 0.55929958561497 + 0.55929978165062 + 0.55930003881080 + 0.55930037563653 + 0.55930081603509 + 0.55930139233363 + 0.55930214851625 + 0.55930314017857 + 0.55930443972890 + 0.55930614057195 + 0.55930835337355 + 0.55931114695063 + 0.55931450252081 + 0.55931844454877 + 0.55932297836676 + 0.55932794268622 + 0.55933321128397 + 0.55933876774050 + 0.55934462135035 + 0.55935078581692 + 0.55935727707231 + 0.55936413331639 + 0.55937138781981 + 0.55937905627925 + 0.55938715732432 + 0.55939571434730 + 0.55940476515499 + 0.55941441936674 + 0.55942499934908 + 0.55943694192497 + 0.55945057911293 + 0.55946620821312 + 0.55948420491053 + 0.55950498360537 + 0.55952903583594 + 0.55955695835655 + 0.55958948083454 + 0.55962750439856 + 0.55967217366181 + 0.55972510250236 + 0.55978890120930 + 0.55986719462778 + 0.55996420746186 + 0.56008512382285 + 0.56015664839893 + 0.56023682397737 + 0.56032682116138 + 0.56042798603420 + 0.56054186929862 + 0.56067026082727 + 0.56081523080391 + 0.56097917918603 + 0.56116490237610 + 0.56137587364491 + 0.56161991494204 + 0.56191816863763 + 0.56229229846527 + 0.56276311956783 + 0.56335914005752 + 0.56411468596884 + 0.56507415646602 + 0.56629546982375 + 0.56785503816633 + 0.56985519932832 + 0.57243660790139 + 0.57581583618384 + 0.58030137825111 + 0.58637363232091 + 0.59483668531354 + 0.60718986691018 + 0.62677318588660 + 0.66428832169132 + 1.00000000000000 + 0.65278668114291 + 0.60265791962548 + 0.57041562921395 + 0.54721985404169 + 0.54721985475042 + 0.54721985486774 + 0.54721985500468 + 0.54721985516420 + 0.54721985534995 + 0.54721985556652 + 0.54721985581926 + 0.54721985611415 + 0.54721985646024 + 0.54721985687443 + 0.54721985738577 + 0.54721985803091 + 0.54721985885015 + 0.54721985989055 + 0.54721986121096 + 0.54721986288581 + 0.54721986500727 + 0.54721986770019 + 0.54721987113481 + 0.54721987551505 + 0.54721988109973 + 0.54721988821946 + 0.54721989729434 + 0.54721990886655 + 0.54721992368582 + 0.54721994288726 + 0.54721996802972 + 0.54722000102326 + 0.54722004425803 + 0.54722010120080 + 0.54722017627657 + 0.54722027518901 + 0.54722040538736 + 0.54722057657293 + 0.54722080134343 + 0.54722109600332 + 0.54722148158090 + 0.54722198653052 + 0.54722264957862 + 0.54722351968878 + 0.54722466063453 + 0.54722615467814 + 0.54722809921641 + 0.54723055440120 + 0.54723350260687 + 0.54723696422764 + 0.54724094248640 + 0.54724529330290 + 0.54724990383383 + 0.54725475824583 + 0.54725986326993 + 0.54726522935099 + 0.54727086869305 + 0.54727681275672 + 0.54728308833776 + 0.54728970654104 + 0.54729668070346 + 0.54730402790431 + 0.54731177722320 + 0.54732001916376 + 0.54732902652415 + 0.54733916796233 + 0.54735071848379 + 0.54736391987237 + 0.54737907714934 + 0.54739652349278 + 0.54741665177008 + 0.54743993665910 + 0.54746695581228 + 0.54749841946027 + 0.54753522722113 + 0.54757865234867 + 0.54763077392371 + 0.54769447570433 + 0.54777308300295 + 0.54787064395499 + 0.54792817092744 + 0.54799251337020 + 0.54806457598281 + 0.54814539666613 + 0.54823616822683 + 0.54833826397090 + 0.54845326807571 + 0.54858301191826 + 0.54872962335980 + 0.54889574790882 + 0.54908750934360 + 0.54932172745425 + 0.54961552678737 + 0.54998518420810 + 0.55045294694538 + 0.55104539815066 + 0.55179666875244 + 0.55275084967145 + 0.55396537071940 + 0.55551587197673 + 0.55750412392669 + 0.56008391334117 + 0.56346542534908 + 0.56795999764370 + 0.57405292808547 + 0.58255698494096 + 0.59498719431147 + 0.61475911162871 + 0.65278668114291 + 1.00000000000000 + 0.64116098358138 + 0.59050257364516 + 0.53521625125906 + 0.53521625185653 + 0.53521625195560 + 0.53521625207085 + 0.53521625220528 + 0.53521625236199 + 0.53521625254472 + 0.53521625275764 + 0.53521625300623 + 0.53521625329812 + 0.53521625364744 + 0.53521625407919 + 0.53521625462437 + 0.53521625531765 + 0.53521625619947 + 0.53521625732007 + 0.53521625874308 + 0.53521626054763 + 0.53521626284122 + 0.53521626576978 + 0.53521626950958 + 0.53521627428348 + 0.53521628037672 + 0.53521628815184 + 0.53521629807854 + 0.53521631080524 + 0.53521632731719 + 0.53521634896703 + 0.53521637741657 + 0.53521641474584 + 0.53521646397524 + 0.53521652896453 + 0.53521661469185 + 0.53521672766679 + 0.53521687637195 + 0.53521707182993 + 0.53521732831517 + 0.53521766424825 + 0.53521810456857 + 0.53521868324013 + 0.53521944321341 + 0.53522044044646 + 0.53522174711794 + 0.53522344863454 + 0.53522559737701 + 0.53522817689018 + 0.53523120402969 + 0.53523468028870 + 0.53523847737460 + 0.53524249474771 + 0.53524671729532 + 0.53525114964246 + 0.53525579953514 + 0.53526067609371 + 0.53526580502920 + 0.53527120768650 + 0.53527689148567 + 0.53528286551335 + 0.53528914177308 + 0.53529574222158 + 0.53530274114528 + 0.53531036837968 + 0.53531893364079 + 0.53532866346836 + 0.53533975313974 + 0.53535244861480 + 0.53536701570594 + 0.53538376585188 + 0.53540307339201 + 0.53542539153077 + 0.53545127479961 + 0.53548142352293 + 0.53551683346386 + 0.53555914854314 + 0.53561064640029 + 0.53567392274726 + 0.53575210990890 + 0.53579806102217 + 0.53584933728303 + 0.53590663108567 + 0.53597073486847 + 0.53604255710202 + 0.53612314107644 + 0.53621368710024 + 0.53631557895424 + 0.53643042008986 + 0.53656020754867 + 0.53670970923928 + 0.53689224882378 + 0.53712131582317 + 0.53740960771570 + 0.53777446267405 + 0.53823647178391 + 0.53882192342418 + 0.53956452055180 + 0.54050772403501 + 0.54170802889656 + 0.54324019712656 + 0.54521575460515 + 0.54778234365529 + 0.55115082249515 + 0.55563388460776 + 0.56171950771243 + 0.57022565759438 + 0.58270684787165 + 0.60265791962548 + 0.64116098358138 + 1.00000000000000 + 0.62943585548199 + 0.52332462773726 + 0.52332462823751 + 0.52332462832037 + 0.52332462841684 + 0.52332462852933 + 0.52332462866045 + 0.52332462881344 + 0.52332462899163 + 0.52332462919978 + 0.52332462944400 + 0.52332462973667 + 0.52332463009837 + 0.52332463055649 + 0.52332463113935 + 0.52332463188134 + 0.52332463282637 + 0.52332463402756 + 0.52332463555312 + 0.52332463749477 + 0.52332463997763 + 0.52332464315179 + 0.52332464720943 + 0.52332465239540 + 0.52332465902123 + 0.52332466749090 + 0.52332467836363 + 0.52332469248957 + 0.52332471103890 + 0.52332473545175 + 0.52332476752870 + 0.52332480989279 + 0.52332486589539 + 0.52332493986934 + 0.52332503747858 + 0.52332516611548 + 0.52332533538819 + 0.52332555775395 + 0.52332584929402 + 0.52332623179579 + 0.52332673495165 + 0.52332739632544 + 0.52332826486585 + 0.52332940372227 + 0.52333088757790 + 0.52333276190900 + 0.52333501143479 + 0.52333764996789 + 0.52334067762192 + 0.52334398046122 + 0.52334746915493 + 0.52335112941277 + 0.52335496417165 + 0.52335897898332 + 0.52336318046810 + 0.52336758949661 + 0.52337222289957 + 0.52337708520506 + 0.52338218216597 + 0.52338752179045 + 0.52339312032456 + 0.52339903846251 + 0.52340546918549 + 0.52341267178225 + 0.52342083204492 + 0.52343010675272 + 0.52344069307419 + 0.52345280161575 + 0.52346667741930 + 0.52348261335366 + 0.52350096198578 + 0.52352215240342 + 0.52354672478942 + 0.52357545149196 + 0.52360962382175 + 0.52365102896855 + 0.52370167723782 + 0.52376397076674 + 0.52380045377872 + 0.52384106506021 + 0.52388632927413 + 0.52393684535500 + 0.52399329814048 + 0.52405647199998 + 0.52412726687318 + 0.52420671731309 + 0.52429601884656 + 0.52439666434781 + 0.52451234597691 + 0.52465357629301 + 0.52483094573099 + 0.52505433348565 + 0.52533722851948 + 0.52569557197741 + 0.52614962821113 + 0.52672522342723 + 0.52745539709066 + 0.52838264870775 + 0.52956248201388 + 0.53107696778608 + 0.53303202241657 + 0.53557476843076 + 0.53891548995409 + 0.54336635779483 + 0.54941513472537 + 0.55790105999687 + 0.57041562921395 + 0.59050257364516 + 0.62943585548199 + 1.00000000000000 diff --git a/wrfv2_fire/run/tr67t85 b/wrfv2_fire/run/tr67t85 new file mode 100644 index 00000000..72c4b16d --- /dev/null +++ b/wrfv2_fire/run/tr67t85 @@ -0,0 +1,35643 @@ + 1.00000000000000 + 0.99988727416533 + 0.99987721224321 + 0.99986679987633 + 0.99985606791039 + 0.99984503588803 + 0.99983370802308 + 0.99982206999429 + 0.99981008547296 + 0.99979768433575 + 0.99978472492768 + 0.99977097549743 + 0.99975619487502 + 0.99974016824859 + 0.99972267733025 + 0.99970348125504 + 0.99968230987020 + 0.99965886107080 + 0.99963277392851 + 0.99960362357683 + 0.99957097131309 + 0.99953433426468 + 0.99949318744176 + 0.99944696816492 + 0.99939507155338 + 0.99933678325661 + 0.99927114533627 + 0.99919714319086 + 0.99911395369942 + 0.99902085531399 + 0.99891688540471 + 0.99880110583217 + 0.99867248588389 + 0.99852976754143 + 0.99837136963676 + 0.99819528885234 + 0.99799900441820 + 0.99777938870992 + 0.99753239116443 + 0.99725292631983 + 0.99693521339580 + 0.99657241329557 + 0.99615658820653 + 0.99567933032360 + 0.99513573589840 + 0.99452464848497 + 0.99383829582439 + 0.99306727113832 + 0.99220766025125 + 0.99124932359317 + 0.99017361871697 + 0.98895837278315 + 0.98757877208106 + 0.98600722194955 + 0.98421180058787 + 0.98215767380471 + 0.97980780396087 + 0.97712124784739 + 0.97405267915185 + 0.97055149800812 + 0.96655776911687 + 0.96199178931435 + 0.95676273677758 + 0.95078931173848 + 0.94399749330812 + 0.93631460881879 + 0.92767843688624 + 0.91803898498468 + 0.90736253014951 + 0.89563712029265 + 0.88287863519612 + 0.86913559160177 + 0.85448564269777 + 0.83902054356642 + 0.82287189434825 + 0.80624757244849 + 0.78940026587448 + 0.78096723162619 + 0.77256762306183 + 0.76422308346951 + 0.75594880891800 + 0.74775249960798 + 0.73963376662196 + 0.73158418416066 + 0.72358816378296 + 0.71562456712604 + 0.70766487217433 + 0.69960840778446 + 0.69116872158509 + 0.68219709917272 + 0.67267963834072 + 0.66260446752219 + 0.65199821567565 + 0.64089824232285 + 0.62935023323344 + 0.61740617598027 + 0.60512283634016 + 0.59255836251746 + 0.57973233197550 + 0.56670171893877 + 0.55352582083943 + 0.54026534167932 + 0.52698059987977 + 0.51372876438808 + 0.50053991291415 + 0.48742880001134 + 0.47441388310922 + 0.46149689320824 + 0.44866132833815 + 0.99988727416533 + 1.00000000000000 + 0.99996911884038 + 0.99994282492835 + 0.99991925719738 + 0.99989779046335 + 0.99987799349688 + 0.99985950396845 + 0.99984199267777 + 0.99982513542641 + 0.99980856721874 + 0.99979186514277 + 0.99977463849804 + 0.99975656259713 + 0.99973733814626 + 0.99971666290946 + 0.99969421859721 + 0.99966966446652 + 0.99964260792078 + 0.99961259851865 + 0.99957917786445 + 0.99954184705759 + 0.99950006766252 + 0.99945326549276 + 0.99940082589606 + 0.99934202623591 + 0.99927590156841 + 0.99920143327915 + 0.99911779794479 + 0.99902427590274 + 0.99891990669245 + 0.99880375537369 + 0.99867479437869 + 0.99853176797895 + 0.99837309603537 + 0.99819677483084 + 0.99800028187566 + 0.99778048686174 + 0.99753333593350 + 0.99725374023296 + 0.99693591585957 + 0.99657302076538 + 0.99615711445996 + 0.99567978687190 + 0.99513613259421 + 0.99452499384901 + 0.99383859689102 + 0.99306753383019 + 0.99220788976446 + 0.99124952441095 + 0.99017379466389 + 0.98895852715491 + 0.98757890773513 + 0.98600734136835 + 0.98421190591991 + 0.98215776691724 + 0.97980788647527 + 0.97712132117549 + 0.97405274452802 + 0.97055155651755 + 0.96655782169638 + 0.96199183675871 + 0.95676277974809 + 0.95078935079354 + 0.94399752892249 + 0.93631464138302 + 0.92767846672321 + 0.91803901235866 + 0.90736255526851 + 0.89563714332999 + 0.88287865629482 + 0.86913561087685 + 0.85448566025133 + 0.83902055948628 + 0.82287190872059 + 0.80624758536629 + 0.78940027744437 + 0.78096724256424 + 0.77256763339832 + 0.76422309323349 + 0.75594881813962 + 0.74775250831778 + 0.73963377484949 + 0.73158419193216 + 0.72358817112609 + 0.71562457406489 + 0.70766487873291 + 0.69960841397982 + 0.69116872742078 + 0.68219710464720 + 0.67267964345425 + 0.66260447227550 + 0.65199822007265 + 0.64089824636896 + 0.62935023693733 + 0.61740617935380 + 0.60512283939600 + 0.59255836527122 + 0.57973233444358 + 0.56670172113652 + 0.55352582278559 + 0.54026534339151 + 0.52698060137622 + 0.51372876568949 + 0.50053991403897 + 0.48742880097872 + 0.47441388393798 + 0.46149689391724 + 0.44866132894435 + 0.99987721224321 + 0.99996911884038 + 1.00000000000000 + 0.99996491333184 + 0.99993600472949 + 0.99991073546562 + 0.99988815524428 + 0.99986760463253 + 0.99984855604622 + 0.99983054493495 + 0.99981310231904 + 0.99979572706225 + 0.99977797188305 + 0.99975947290719 + 0.99973990393231 + 0.99971894394039 + 0.99969626108626 + 0.99967150447948 + 0.99964427371137 + 0.99961411233282 + 0.99958055748156 + 0.99954310678295 + 0.99950121901158 + 0.99945431767955 + 0.99940178622990 + 0.99934290044578 + 0.99927669407427 + 0.99920214773579 + 0.99911843789204 + 0.99902484514463 + 0.99892040936740 + 0.99880419612590 + 0.99867517835321 + 0.99853210069948 + 0.99837338317835 + 0.99819702199916 + 0.99800049438052 + 0.99778066956058 + 0.99753349313812 + 0.99725387568185 + 0.99693603277910 + 0.99657312188562 + 0.99615720206879 + 0.99567986288008 + 0.99513619864123 + 0.99452505134970 + 0.99383864701571 + 0.99306757756212 + 0.99220792797149 + 0.99124955783903 + 0.99017382394882 + 0.98895855284562 + 0.98757893030869 + 0.98600736123916 + 0.98421192344583 + 0.98215778240660 + 0.97980790019967 + 0.97712133336826 + 0.97405275539782 + 0.97055156624381 + 0.96655783043553 + 0.96199184464388 + 0.95676278688799 + 0.95078935728148 + 0.94399753483710 + 0.93631464678904 + 0.92767847167606 + 0.91803901690173 + 0.90736255943634 + 0.89563714715244 + 0.88287865979446 + 0.86913561407392 + 0.85448566316162 + 0.83902056212554 + 0.82287191110310 + 0.80624758750754 + 0.78940027936149 + 0.78096724437690 + 0.77256763511122 + 0.76422309485140 + 0.75594881966796 + 0.74775250976050 + 0.73963377621256 + 0.73158419321965 + 0.72358817234247 + 0.71562457521492 + 0.70766487982004 + 0.69960841500679 + 0.69116872838728 + 0.68219710555361 + 0.67267964430104 + 0.66260447306296 + 0.65199822080095 + 0.64089824703890 + 0.62935023755099 + 0.61740617991230 + 0.60512283990247 + 0.59255836572766 + 0.57973233485183 + 0.56670172150028 + 0.55352582310798 + 0.54026534367508 + 0.52698060162460 + 0.51372876590472 + 0.50053991422546 + 0.48742880113923 + 0.47441388407546 + 0.46149689403471 + 0.44866132904451 + 0.99986679987633 + 0.99994282492835 + 0.99996491333184 + 1.00000000000000 + 0.99996023549411 + 0.99992863340377 + 0.99990172716842 + 0.99987812513139 + 0.99985688635380 + 0.99983728309284 + 0.99981866720397 + 0.99980041082689 + 0.99978197853170 + 0.99976294711256 + 0.99974295076966 + 0.99972164165163 + 0.99969866911819 + 0.99967366857261 + 0.99964622927133 + 0.99961588695430 + 0.99958217301536 + 0.99954458067884 + 0.99950256523610 + 0.99945554735113 + 0.99940290813282 + 0.99934392144590 + 0.99927761945266 + 0.99920298184308 + 0.99911918491534 + 0.99902550956786 + 0.99892099604685 + 0.99880471050609 + 0.99867562646119 + 0.99853248898391 + 0.99837371827523 + 0.99819731044954 + 0.99800074238419 + 0.99778088279002 + 0.99753367661837 + 0.99725403377987 + 0.99693616925093 + 0.99657323992028 + 0.99615730433484 + 0.99567995160911 + 0.99513627574086 + 0.99452511847241 + 0.99383870552913 + 0.99306762861455 + 0.99220797256976 + 0.99124959685892 + 0.99017385813130 + 0.98895858283414 + 0.98757895665807 + 0.98600738443115 + 0.98421194389941 + 0.98215780048405 + 0.97980791621545 + 0.97712134759990 + 0.97405276808016 + 0.97055157759270 + 0.96655784063381 + 0.96199185384253 + 0.95676279521702 + 0.95078936484921 + 0.94399754173462 + 0.93631465309663 + 0.92767847745124 + 0.91803902219864 + 0.90736256429743 + 0.89563715160867 + 0.88287866387427 + 0.86913561780143 + 0.85448566655572 + 0.83902056520269 + 0.82287191388025 + 0.80624759000365 + 0.78940028159769 + 0.78096724649093 + 0.77256763710732 + 0.76422309673715 + 0.75594882144895 + 0.74775251144284 + 0.73963377780139 + 0.73158419472073 + 0.72358817376221 + 0.71562457655513 + 0.70766488108630 + 0.69960841620289 + 0.69116872951433 + 0.68219710661160 + 0.67267964528863 + 0.66260447398063 + 0.65199822164975 + 0.64089824782005 + 0.62935023826640 + 0.61740618056386 + 0.60512284049280 + 0.59255836625954 + 0.57973233532868 + 0.56670172192475 + 0.55352582348329 + 0.54026534400568 + 0.52698060191371 + 0.51372876615578 + 0.50053991444279 + 0.48742880132568 + 0.47441388423547 + 0.46149689417161 + 0.44866132916165 + 0.99985606791039 + 0.99991925719738 + 0.99993600472949 + 0.99996023549411 + 1.00000000000000 + 0.99995505665346 + 0.99992072100925 + 0.99989226749042 + 0.99986773345621 + 0.99984583646803 + 0.99982559082540 + 0.99980614881402 + 0.99978682996844 + 0.99976711701012 + 0.99974658346459 + 0.99972484182710 + 0.99970151462058 + 0.99967621827919 + 0.99964852810959 + 0.99961796951388 + 0.99958406639277 + 0.99954630632570 + 0.99950414019006 + 0.99945698510732 + 0.99940421930674 + 0.99934511429551 + 0.99927870030965 + 0.99920395590367 + 0.99912005714818 + 0.99902628526877 + 0.99892168092678 + 0.99880531094678 + 0.99867614952089 + 0.99853294220601 + 0.99837410941454 + 0.99819764714722 + 0.99800103187968 + 0.99778113170468 + 0.99753389081776 + 0.99725421835493 + 0.99693632858842 + 0.99657337773667 + 0.99615742374637 + 0.99568005520987 + 0.99513636576650 + 0.99452519684995 + 0.99383877385014 + 0.99306768822326 + 0.99220802464387 + 0.99124964241587 + 0.99017389804160 + 0.98895861784534 + 0.98757898741842 + 0.98600741150463 + 0.98421196777623 + 0.98215782158519 + 0.97980793491099 + 0.97712136420967 + 0.97405278288802 + 0.97055159083813 + 0.96655785253188 + 0.96199186457633 + 0.95676280493532 + 0.95078937367929 + 0.94399754978359 + 0.93631466045368 + 0.92767848418940 + 0.91803902837771 + 0.90736256996405 + 0.89563715680575 + 0.88287866863246 + 0.86913562214735 + 0.85448567051151 + 0.83902056879039 + 0.82287191711933 + 0.80624759291379 + 0.78940028420340 + 0.78096724895396 + 0.77256763943510 + 0.76422309893555 + 0.75594882352524 + 0.74775251340359 + 0.73963377965313 + 0.73158419647096 + 0.72358817541480 + 0.71562457811704 + 0.70766488256336 + 0.69960841759782 + 0.69116873082774 + 0.68219710784371 + 0.67267964643924 + 0.66260447505006 + 0.65199822263937 + 0.64089824873066 + 0.62935023910011 + 0.61740618132322 + 0.60512284118008 + 0.59255836687941 + 0.57973233588402 + 0.56670172241954 + 0.55352582392167 + 0.54026534439114 + 0.52698060225062 + 0.51372876644872 + 0.50053991469594 + 0.48742880154339 + 0.47441388442236 + 0.46149689433097 + 0.44866132929803 + 0.99984503588803 + 0.99989779046335 + 0.99991073546562 + 0.99992863340377 + 0.99995505665346 + 1.00000000000000 + 0.99994935279867 + 0.99991228662823 + 0.99988239138960 + 0.99985698854566 + 0.99983437174561 + 0.99981327501926 + 0.99979276192855 + 0.99977215728923 + 0.99975093703668 + 0.99972865254497 + 0.99970488665247 + 0.99967922877271 + 0.99965123492953 + 0.99962041656541 + 0.99958628763372 + 0.99954832834476 + 0.99950598394514 + 0.99945866708079 + 0.99940575239033 + 0.99934650847911 + 0.99927996322381 + 0.99920509377063 + 0.99912107588592 + 0.99902719113656 + 0.99892248065160 + 0.99880601202356 + 0.99867676021795 + 0.99853347135354 + 0.99837456607989 + 0.99819804026190 + 0.99800136989545 + 0.99778142235189 + 0.99753414094117 + 0.99725443390223 + 0.99693651467206 + 0.99657353869422 + 0.99615756321009 + 0.99568017621588 + 0.99513647091960 + 0.99452528839531 + 0.99383885364978 + 0.99306775784457 + 0.99220808546609 + 0.99124969562492 + 0.99017394465113 + 0.98895865873190 + 0.98757902334023 + 0.98600744312037 + 0.98421199565618 + 0.98215784622363 + 0.97980795673814 + 0.97712138360157 + 0.97405280017053 + 0.97055160629890 + 0.96655786642148 + 0.96199187710342 + 0.95676281627649 + 0.95078938398278 + 0.94399755917472 + 0.93631466903626 + 0.92767849205048 + 0.91803903558583 + 0.90736257657552 + 0.89563716286662 + 0.88287867418116 + 0.86913562721359 + 0.85448567512433 + 0.83902057297259 + 0.82287192089336 + 0.80624759630629 + 0.78940028724158 + 0.78096725182554 + 0.77256764214810 + 0.76422310149817 + 0.75594882594559 + 0.74775251568870 + 0.73963378181189 + 0.73158419850916 + 0.72358817734121 + 0.71562457993787 + 0.70766488428455 + 0.69960841922331 + 0.69116873235890 + 0.68219710928003 + 0.67267964778068 + 0.66260447629753 + 0.65199822379281 + 0.64089824979237 + 0.62935024007192 + 0.61740618220762 + 0.60512284198191 + 0.59255836760182 + 0.57973233653152 + 0.56670172299617 + 0.55352582443210 + 0.54026534484002 + 0.52698060264349 + 0.51372876679002 + 0.50053991499100 + 0.48742880179721 + 0.47441388463962 + 0.46149689451699 + 0.44866132945705 + 0.99983370802308 + 0.99987799349688 + 0.99988815524428 + 0.99990172716842 + 0.99992072100925 + 0.99994935279867 + 1.00000000000000 + 0.99994310596082 + 0.99990335449077 + 0.99987211457082 + 0.99984581966910 + 0.99982229656993 + 0.99980011244709 + 0.99977830707928 + 0.99975618969998 + 0.99973321247904 + 0.99970889702176 + 0.99968279286227 + 0.99965442860868 + 0.99962329639756 + 0.99958889669675 + 0.99955069995757 + 0.99950814409746 + 0.99946063605290 + 0.99940754595235 + 0.99934813878029 + 0.99928143949745 + 0.99920642351296 + 0.99912226616675 + 0.99902824937564 + 0.99892341478316 + 0.99880683085951 + 0.99867747345337 + 0.99853408933193 + 0.99837509940615 + 0.99819849938298 + 0.99800176468214 + 0.99778176183466 + 0.99753443311258 + 0.99725468570018 + 0.99693673206370 + 0.99657372674594 + 0.99615772615689 + 0.99568031760140 + 0.99513659378101 + 0.99452539535814 + 0.99383894688806 + 0.99306783918864 + 0.99220815652735 + 0.99124975778928 + 0.99017399910369 + 0.98895870649564 + 0.98757906530227 + 0.98600748005086 + 0.98421202822161 + 0.98215787500104 + 0.97980798223011 + 0.97712140624590 + 0.97405282035209 + 0.97055162435169 + 0.96655788263791 + 0.96199189172771 + 0.95676282951285 + 0.95078939600876 + 0.94399757013286 + 0.93631467905199 + 0.92767850122117 + 0.91803904399455 + 0.90736258428970 + 0.89563716993632 + 0.88287868065282 + 0.86913563312466 + 0.85448568050479 + 0.83902057784910 + 0.82287192529559 + 0.80624760026197 + 0.78940029078282 + 0.78096725517314 + 0.77256764531072 + 0.76422310448535 + 0.75594882876684 + 0.74775251835317 + 0.73963378432858 + 0.73158420088697 + 0.72358817958782 + 0.71562458206103 + 0.70766488629038 + 0.69960842111816 + 0.69116873414371 + 0.68219711095410 + 0.67267964934438 + 0.66260447775100 + 0.65199822513722 + 0.64089825102953 + 0.62935024120468 + 0.61740618323931 + 0.60512284291686 + 0.59255836844417 + 0.57973233728590 + 0.56670172366822 + 0.55352582502714 + 0.54026534536372 + 0.52698060310131 + 0.51372876718792 + 0.50053991533458 + 0.48742880209306 + 0.47441388489315 + 0.46149689473386 + 0.44866132964246 + 0.99982206999429 + 0.99985950396845 + 0.99986760463253 + 0.99987812513139 + 0.99989226749042 + 0.99991228662823 + 0.99994310596082 + 1.00000000000000 + 0.99993630362974 + 0.99989393692256 + 0.99986137809692 + 0.99983404232673 + 0.99980939472667 + 0.99978590821196 + 0.99976258449678 + 0.99973870406023 + 0.99971368881070 + 0.99968702685645 + 0.99965820645622 + 0.99962669227502 + 0.99959196606966 + 0.99955348507683 + 0.99951067753145 + 0.99946294298371 + 0.99940964580769 + 0.99935004643304 + 0.99928316620208 + 0.99920797833710 + 0.99912365758061 + 0.99902948620698 + 0.99892450640874 + 0.99880778765379 + 0.99867830680260 + 0.99853481135936 + 0.99837572253169 + 0.99819903582060 + 0.99800222597615 + 0.99778215853208 + 0.99753477455182 + 0.99725497997716 + 0.99693698615353 + 0.99657394655229 + 0.99615791663071 + 0.99568048287500 + 0.99513673740256 + 0.99452552039710 + 0.99383905588206 + 0.99306793427697 + 0.99220823958875 + 0.99124983044858 + 0.99017406275019 + 0.98895876231960 + 0.98757911434315 + 0.98600752320962 + 0.98421206627616 + 0.98215790862801 + 0.97980801201641 + 0.97712143270211 + 0.97405284392788 + 0.97055164543735 + 0.96655790157571 + 0.96199190880776 + 0.95676284497374 + 0.95078941005110 + 0.94399758292849 + 0.93631469074266 + 0.92767851192659 + 0.91803905380796 + 0.90736259328990 + 0.89563717818542 + 0.88287868820395 + 0.86913564001791 + 0.85448568678027 + 0.83902058353871 + 0.82287193042765 + 0.80624760487489 + 0.78940029491241 + 0.78096725907680 + 0.77256764899956 + 0.76422310796906 + 0.75594883205689 + 0.74775252146043 + 0.73963378726219 + 0.73158420365845 + 0.72358818220652 + 0.71562458453518 + 0.70766488862888 + 0.69960842332679 + 0.69116873622471 + 0.68219711290648 + 0.67267965116785 + 0.66260447944566 + 0.65199822670464 + 0.64089825247210 + 0.62935024252501 + 0.61740618444210 + 0.60512284400640 + 0.59255836942608 + 0.57973233816570 + 0.56670172445192 + 0.55352582572031 + 0.54026534597362 + 0.52698060363454 + 0.51372876765171 + 0.50053991573542 + 0.48742880243780 + 0.47441388518872 + 0.46149689498662 + 0.44866132985849 + 0.99981008547296 + 0.99984199267777 + 0.99984855604622 + 0.99985688635380 + 0.99986773345621 + 0.99988239138960 + 0.99990335449077 + 0.99993630362974 + 1.00000000000000 + 0.99992892812820 + 0.99988398100115 + 0.99985001163651 + 0.99982145226662 + 0.99979548021088 + 0.99977046902453 + 0.99974537655142 + 0.99971945098007 + 0.99969208050780 + 0.99966269143093 + 0.99963070799026 + 0.99959558522642 + 0.99955676204269 + 0.99951365360965 + 0.99946564976828 + 0.99941210744997 + 0.99935228128862 + 0.99928518807158 + 0.99920979826015 + 0.99912528577063 + 0.99903093318602 + 0.99892578330410 + 0.99880890670063 + 0.99867928139356 + 0.99853565572550 + 0.99837645122754 + 0.99819966315086 + 0.99800276546164 + 0.99778262250226 + 0.99753517392011 + 0.99725532421193 + 0.99693728339683 + 0.99657420370600 + 0.99615813947219 + 0.99568067624459 + 0.99513690544228 + 0.99452566669204 + 0.99383918340254 + 0.99306804552694 + 0.99220833676534 + 0.99124991545162 + 0.99017413720276 + 0.98895882762045 + 0.98757917170580 + 0.98600757368749 + 0.98421211078436 + 0.98215794795158 + 0.97980804684506 + 0.97712146364019 + 0.97405287149552 + 0.97055167009428 + 0.96655792371801 + 0.96199192877447 + 0.95676286304182 + 0.95078942646001 + 0.94399759788026 + 0.93631470440292 + 0.92767852443176 + 0.91803906527043 + 0.90736260380018 + 0.89563718781899 + 0.88287869701877 + 0.86913564806692 + 0.85448569410492 + 0.83902059017777 + 0.82287193642089 + 0.80624761025813 + 0.78940029973308 + 0.78096726363231 + 0.77256765330431 + 0.76422311203389 + 0.75594883589664 + 0.74775252508660 + 0.73963379068710 + 0.73158420689339 + 0.72358818526295 + 0.71562458742375 + 0.70766489135929 + 0.69960842590520 + 0.69116873865293 + 0.68219711518430 + 0.67267965329504 + 0.66260448142328 + 0.65199822853375 + 0.64089825415558 + 0.62935024406602 + 0.61740618584606 + 0.60512284527813 + 0.59255837057209 + 0.57973233919273 + 0.56670172536657 + 0.55352582653013 + 0.54026534668630 + 0.52698060425775 + 0.51372876819354 + 0.50053991620349 + 0.48742880284047 + 0.47441388553404 + 0.46149689528161 + 0.44866133011042 + 0.99979768433575 + 0.99982513542641 + 0.99983054493495 + 0.99983728309284 + 0.99984583646803 + 0.99985698854566 + 0.99987211457082 + 0.99989393692256 + 0.99992892812820 + 1.00000000000000 + 0.99992092021232 + 0.99987333958899 + 0.99983783865015 + 0.99980788862331 + 0.99978038009804 + 0.99975359462536 + 0.99972644971683 + 0.99969815932484 + 0.99966804928557 + 0.99963548178395 + 0.99959987237574 + 0.99956063379575 + 0.99951716316424 + 0.99946883726419 + 0.99941500326078 + 0.99935490828916 + 0.99928756334697 + 0.99921193535504 + 0.99912719706700 + 0.99903263132236 + 0.99892728152462 + 0.99881021950401 + 0.99868042459984 + 0.99853664609454 + 0.99837730588894 + 0.99820039891264 + 0.99800339819203 + 0.99778316667596 + 0.99753564234112 + 0.99725572797684 + 0.99693763204975 + 0.99657450534015 + 0.99615840086321 + 0.99568090305878 + 0.99513710254153 + 0.99452583827885 + 0.99383933296738 + 0.99306817600416 + 0.99220845073590 + 0.99125001514388 + 0.99017422452047 + 0.98895890420609 + 0.98757923898512 + 0.98600763289215 + 0.98421216298443 + 0.98215799407770 + 0.97980808770194 + 0.97712149993028 + 0.97405290383132 + 0.97055169901319 + 0.96655794968984 + 0.96199195219259 + 0.95676288423705 + 0.95078944570585 + 0.94399761541605 + 0.93631472042277 + 0.92767853909585 + 0.91803907871093 + 0.90736261612281 + 0.89563719911271 + 0.88287870735398 + 0.86913565750041 + 0.85448570269229 + 0.83902059796080 + 0.82287194344328 + 0.80624761656722 + 0.78940030538149 + 0.78096726897159 + 0.77256765834836 + 0.76422311679924 + 0.75594884039600 + 0.74775252933579 + 0.73963379470079 + 0.73158421068518 + 0.72358818884481 + 0.71562459080985 + 0.70766489455892 + 0.69960842892695 + 0.69116874149974 + 0.68219711785495 + 0.67267965578957 + 0.66260448374176 + 0.65199823067919 + 0.64089825612957 + 0.62935024587349 + 0.61740618749244 + 0.60512284676915 + 0.59255837191582 + 0.57973234039679 + 0.56670172643963 + 0.55352582748023 + 0.54026534752211 + 0.52698060498845 + 0.51372876882889 + 0.50053991675254 + 0.48742880331292 + 0.47441388593877 + 0.46149689562781 + 0.44866133040689 + 0.99978472492768 + 0.99980856721874 + 0.99981310231904 + 0.99981866720397 + 0.99982559082540 + 0.99983437174561 + 0.99984581966910 + 0.99986137809692 + 0.99988398100115 + 0.99992092021232 + 1.00000000000000 + 0.99991218337857 + 0.99986191032603 + 0.99982477454104 + 0.99979324539076 + 0.99976395195216 + 0.99973510340054 + 0.99970558005819 + 0.99967453296098 + 0.99964122373761 + 0.99960500701206 + 0.99956525677526 + 0.99952134441494 + 0.99947262871531 + 0.99941844370862 + 0.99935802667025 + 0.99929038108435 + 0.99921446927551 + 0.99912946236859 + 0.99903464333391 + 0.99892905618643 + 0.99881177417693 + 0.99868177814515 + 0.99853781846362 + 0.99837831743416 + 0.99820126958861 + 0.99800414682147 + 0.99778381042216 + 0.99753619638001 + 0.99725620545937 + 0.99693804428823 + 0.99657486192228 + 0.99615870981810 + 0.99568117109985 + 0.99513733543023 + 0.99452604100347 + 0.99383950966008 + 0.99306833014337 + 0.99220858538168 + 0.99125013293583 + 0.99017432771190 + 0.98895899473477 + 0.98757931852734 + 0.98600770291179 + 0.98421222474089 + 0.98215804866359 + 0.97980813607074 + 0.97712154290646 + 0.97405294214224 + 0.97055173329217 + 0.96655798048467 + 0.96199197996908 + 0.95676290938053 + 0.95078946854458 + 0.94399763622779 + 0.93631473943920 + 0.92767855650786 + 0.91803909467018 + 0.90736263075671 + 0.89563721252468 + 0.88287871962696 + 0.86913566870731 + 0.85448571289176 + 0.83902060720698 + 0.82287195178795 + 0.80624762406492 + 0.78940031209604 + 0.78096727531901 + 0.77256766434528 + 0.76422312246449 + 0.75594884574692 + 0.74775253439012 + 0.73963379947596 + 0.73158421519634 + 0.72358819310761 + 0.71562459483921 + 0.70766489836712 + 0.69960843252557 + 0.69116874488959 + 0.68219712103595 + 0.67267965876146 + 0.66260448650491 + 0.65199823323562 + 0.64089825848245 + 0.62935024802856 + 0.61740618945488 + 0.60512284854823 + 0.59255837351965 + 0.57973234183424 + 0.56670172772014 + 0.55352582861444 + 0.54026534852046 + 0.52698060586195 + 0.51372876958809 + 0.50053991740926 + 0.48742880387789 + 0.47441388642363 + 0.46149689604248 + 0.44866133076180 + 0.99977097549743 + 0.99979186514277 + 0.99979572706225 + 0.99980041082689 + 0.99980614881402 + 0.99981327501926 + 0.99982229656993 + 0.99983404232673 + 0.99985001163651 + 0.99987333958899 + 0.99991218337857 + 1.00000000000000 + 0.99990270295619 + 0.99984972450639 + 0.99981082175002 + 0.99977747164888 + 0.99974609354410 + 0.99971484241139 + 0.99968253451560 + 0.99964825646755 + 0.99961126355164 + 0.99957086971513 + 0.99952640819302 + 0.99947721211748 + 0.99942259736997 + 0.99936178790492 + 0.99929377725678 + 0.99921752165672 + 0.99913218991263 + 0.99903706494690 + 0.99893119136964 + 0.99881364404030 + 0.99868340555402 + 0.99853922753950 + 0.99837953275485 + 0.99820231523910 + 0.99800504550505 + 0.99778458284280 + 0.99753686084016 + 0.99725677782216 + 0.99693853819352 + 0.99657528893823 + 0.99615907962955 + 0.99568149180496 + 0.99513761397799 + 0.99452628341595 + 0.99383972091620 + 0.99306851443660 + 0.99220874639170 + 0.99125027383809 + 0.99017445119745 + 0.98895910312486 + 0.98757941383329 + 0.98600778686857 + 0.98421229885095 + 0.98215811422921 + 0.97980819421898 + 0.97712159462320 + 0.97405298829042 + 0.97055177462126 + 0.96655801765377 + 0.96199201352407 + 0.95676293978180 + 0.95078949618220 + 0.94399766142976 + 0.93631476247910 + 0.92767857761166 + 0.91803911402243 + 0.90736264850916 + 0.89563722880050 + 0.88287873452882 + 0.86913568231760 + 0.85448572528262 + 0.83902061844563 + 0.82287196193320 + 0.80624763318605 + 0.78940032026915 + 0.78096728304812 + 0.77256767165012 + 0.76422312936671 + 0.75594885226878 + 0.74775254055248 + 0.73963380529796 + 0.73158422070016 + 0.72358819831100 + 0.71562459975851 + 0.70766490301918 + 0.69960843692279 + 0.69116874903396 + 0.68219712492548 + 0.67267966239733 + 0.66260448988749 + 0.65199823636505 + 0.64089826136600 + 0.62935025066927 + 0.61740619186189 + 0.60512285073104 + 0.59255837548857 + 0.57973234360019 + 0.56670172929515 + 0.55352583000942 + 0.54026534974947 + 0.52698060693761 + 0.51372877052457 + 0.50053991821999 + 0.48742880457618 + 0.47441388702259 + 0.46149689655559 + 0.44866133120119 + 0.99975619487502 + 0.99977463849804 + 0.99977797188305 + 0.99978197853170 + 0.99978682996844 + 0.99979276192855 + 0.99980011244709 + 0.99980939472667 + 0.99982145226662 + 0.99983783865015 + 0.99986191032603 + 0.99990270295619 + 1.00000000000000 + 0.99989252000086 + 0.99983682357473 + 0.99979595692251 + 0.99976048065432 + 0.99972666226938 + 0.99969258522400 + 0.99965700103198 + 0.99961899115405 + 0.99957777113167 + 0.99953261497363 + 0.99948281778046 + 0.99942766951912 + 0.99936637566928 + 0.99929791624876 + 0.99922123921829 + 0.99913551006800 + 0.99904001132745 + 0.99893378814072 + 0.99881591719372 + 0.99868538311868 + 0.99854093903309 + 0.99838100819601 + 0.99820358401678 + 0.99800613532214 + 0.99778551895692 + 0.99753766557942 + 0.99725747054933 + 0.99693913555652 + 0.99657580505547 + 0.99615952632635 + 0.99568187895623 + 0.99513795007996 + 0.99452657581541 + 0.99383997569501 + 0.99306873670145 + 0.99220894062269 + 0.99125044387824 + 0.99017460031519 + 0.98895923411567 + 0.98757952911288 + 0.98600788852508 + 0.98421238868406 + 0.98215819380067 + 0.97980826488261 + 0.97712165755533 + 0.97405304452153 + 0.97055182505090 + 0.96655806306734 + 0.96199205457538 + 0.95676297702025 + 0.95078953006876 + 0.94399769235899 + 0.93631479077786 + 0.92767860355204 + 0.91803913782668 + 0.90736267036013 + 0.89563724884380 + 0.88287875288734 + 0.86913569909400 + 0.85448574056661 + 0.83902063231276 + 0.82287197446266 + 0.80624764445970 + 0.78940033037666 + 0.78096729260929 + 0.77256768069161 + 0.76422313791510 + 0.75594886034875 + 0.74775254819018 + 0.73963381251995 + 0.73158422752878 + 0.72358820477094 + 0.71562460586922 + 0.70766490880064 + 0.69960844238916 + 0.69116875418851 + 0.68219712976686 + 0.67267966692482 + 0.66260449410148 + 0.65199824026833 + 0.64089826496287 + 0.62935025396812 + 0.61740619487050 + 0.60512285346039 + 0.59255837795263 + 0.57973234581189 + 0.56670173126859 + 0.55352583176042 + 0.54026535129306 + 0.52698060829093 + 0.51372877170368 + 0.50053991924147 + 0.48742880545692 + 0.47441388777941 + 0.46149689720492 + 0.44866133175769 + 0.99974016824859 + 0.99975656259713 + 0.99975947290719 + 0.99976294711256 + 0.99976711701012 + 0.99977215728923 + 0.99977830707928 + 0.99978590821196 + 0.99979548021088 + 0.99980788862331 + 0.99982477454104 + 0.99984972450639 + 0.99989252000086 + 1.00000000000000 + 0.99988165309924 + 0.99982318289720 + 0.99978007845790 + 0.99974210862688 + 0.99970540890490 + 0.99966799603337 + 0.99962861751277 + 0.99958631591886 + 0.99954026799345 + 0.99948970986834 + 0.99943389315055 + 0.99937199686173 + 0.99930298221985 + 0.99922578569006 + 0.99913956788033 + 0.99904361035266 + 0.99893695856291 + 0.99881869122885 + 0.99868779534083 + 0.99854302571995 + 0.99838280618408 + 0.99820512932685 + 0.99800746189450 + 0.99778665771663 + 0.99753864388015 + 0.99725831210003 + 0.99693986075677 + 0.99657643119845 + 0.99616006789238 + 0.99568234805379 + 0.99513835711076 + 0.99452692979949 + 0.99384028407910 + 0.99306900572911 + 0.99220917576716 + 0.99125064983394 + 0.99017478104669 + 0.98895939300813 + 0.98757966908225 + 0.98600801208508 + 0.98421249800687 + 0.98215829075708 + 0.97980835110066 + 0.97712173444999 + 0.97405311332697 + 0.97055188685064 + 0.96655811879300 + 0.96199210501987 + 0.95676302283471 + 0.95078957180905 + 0.94399773049089 + 0.93631482569801 + 0.92767863558736 + 0.91803916723984 + 0.90736269737290 + 0.89563727363831 + 0.88287877560843 + 0.86913571986885 + 0.85448575950454 + 0.83902064950907 + 0.82287199000831 + 0.80624765845597 + 0.78940034293966 + 0.78096730449830 + 0.77256769194065 + 0.76422314855402 + 0.75594887041026 + 0.74775255770710 + 0.73963382152196 + 0.73158423604659 + 0.72358821283155 + 0.71562461349929 + 0.70766491602464 + 0.69960844922292 + 0.69116876063622 + 0.68219713582646 + 0.67267967259519 + 0.66260449938273 + 0.65199824516308 + 0.64089826947646 + 0.62935025810889 + 0.61740619865025 + 0.60512285689333 + 0.59255838105467 + 0.57973234859804 + 0.56670173375745 + 0.55352583397030 + 0.54026535324369 + 0.52698061000203 + 0.51372877319597 + 0.50053992053621 + 0.48742880657497 + 0.47441388874125 + 0.46149689803096 + 0.44866133246596 + 0.99972267733025 + 0.99973733814626 + 0.99973990393231 + 0.99974295076966 + 0.99974658346459 + 0.99975093703668 + 0.99975618969998 + 0.99976258449678 + 0.99977046902453 + 0.99978038009804 + 0.99979324539076 + 0.99981082175002 + 0.99983682357473 + 0.99988165309924 + 1.00000000000000 + 0.99987010124968 + 0.99980873046516 + 0.99976303369296 + 0.99972210974246 + 0.99968199753708 + 0.99964071083396 + 0.99959695859968 + 0.99954974613020 + 0.99949821287873 + 0.99944155105622 + 0.99937890051777 + 0.99930919548632 + 0.99923135607970 + 0.99914453554234 + 0.99904801343291 + 0.99894083507498 + 0.99882208132809 + 0.99869074183805 + 0.99854557335446 + 0.99838500027181 + 0.99820701409971 + 0.99800907898948 + 0.99778804506850 + 0.99753983501594 + 0.99725933608866 + 0.99694074260604 + 0.99657719211071 + 0.99616072562043 + 0.99568291743731 + 0.99513885091658 + 0.99452735909497 + 0.99384065800567 + 0.99306933193375 + 0.99220946095149 + 0.99125089972503 + 0.99017500046870 + 0.98895958607011 + 0.98757983930656 + 0.98600816251975 + 0.98421263125934 + 0.98215840908421 + 0.97980845645839 + 0.97712182854615 + 0.97405319764188 + 0.97055196268494 + 0.96655818726994 + 0.96199216708587 + 0.95676307927016 + 0.95078962327756 + 0.94399777755692 + 0.93631486883480 + 0.92767867518397 + 0.91803920362359 + 0.90736273080502 + 0.89563730434188 + 0.88287880376164 + 0.86913574562363 + 0.85448578299254 + 0.83902067084826 + 0.82287200931514 + 0.80624767585273 + 0.78940035856596 + 0.78096731929384 + 0.77256770594393 + 0.76422316180645 + 0.75594888294993 + 0.74775256957417 + 0.73963383275427 + 0.73158424667959 + 0.72358822289928 + 0.71562462303445 + 0.70766492505579 + 0.69960845777304 + 0.69116876870710 + 0.68219714341725 + 0.67267967970250 + 0.66260450600617 + 0.65199825130623 + 0.64089827514591 + 0.62935026331351 + 0.61740620340550 + 0.60512286121495 + 0.59255838496119 + 0.57973235211120 + 0.56670173689820 + 0.55352583676189 + 0.54026535570907 + 0.52698061216739 + 0.51372877508710 + 0.50053992217899 + 0.48742880799540 + 0.47441388996450 + 0.46149689908230 + 0.44866133336991 + 0.99970348125504 + 0.99971666290946 + 0.99971894394039 + 0.99972164165163 + 0.99972484182710 + 0.99972865254497 + 0.99973321247904 + 0.99973870406023 + 0.99974537655142 + 0.99975359462536 + 0.99976395195216 + 0.99977747164888 + 0.99979595692251 + 0.99982318289720 + 0.99987010124968 + 1.00000000000000 + 0.99985785205459 + 0.99979336133792 + 0.99974460250935 + 0.99970016646670 + 0.99965607894769 + 0.99961031437620 + 0.99956154608256 + 0.99950874324776 + 0.99945100097302 + 0.99938739851814 + 0.99931683006118 + 0.99923819166509 + 0.99915062528801 + 0.99905340664728 + 0.99894558004843 + 0.99882622843558 + 0.99869434433718 + 0.99854868661198 + 0.99838768014888 + 0.99820931503044 + 0.99801105213506 + 0.99778973698885 + 0.99754128684704 + 0.99726058348142 + 0.99694181622560 + 0.99657811795598 + 0.99616152546466 + 0.99568360947774 + 0.99513945080821 + 0.99452788044508 + 0.99384111203177 + 0.99306972801206 + 0.99220980728725 + 0.99125120332427 + 0.99017526720806 + 0.98895982094329 + 0.98758004658715 + 0.98600834588325 + 0.98421279385789 + 0.98215855364325 + 0.97980858533977 + 0.97712194379643 + 0.97405330105136 + 0.97055205581277 + 0.96655827147511 + 0.96199224349891 + 0.95676314882887 + 0.95078968677562 + 0.94399783567532 + 0.93631492213923 + 0.92767872415084 + 0.91803924863869 + 0.90736277219176 + 0.89563734236587 + 0.88287883864385 + 0.86913577755249 + 0.85448581212928 + 0.83902069733570 + 0.82287203329070 + 0.80624769747271 + 0.78940037800331 + 0.78096733770532 + 0.77256772337844 + 0.76422317831306 + 0.75594889857869 + 0.74775258437029 + 0.73963384676577 + 0.73158425995125 + 0.72358823547363 + 0.71562463495052 + 0.70766493634904 + 0.69960846846898 + 0.69116877881161 + 0.68219715292322 + 0.67267968860900 + 0.66260451431220 + 0.65199825901437 + 0.64089828226377 + 0.62935026985339 + 0.61740620938381 + 0.60512286665335 + 0.59255838988159 + 0.57973235653948 + 0.56670174085991 + 0.55352584028653 + 0.54026535882586 + 0.52698061490715 + 0.51372877748143 + 0.50053992426135 + 0.48742880979822 + 0.47441389151921 + 0.46149690042017 + 0.44866133452075 + 0.99968230987020 + 0.99969421859721 + 0.99969626108626 + 0.99969866911819 + 0.99970151462058 + 0.99970488665247 + 0.99970889702176 + 0.99971368881070 + 0.99971945098007 + 0.99972644971683 + 0.99973510340054 + 0.99974609354410 + 0.99976048065432 + 0.99978007845790 + 0.99980873046516 + 0.99985785205459 + 1.00000000000000 + 0.99984488087475 + 0.99977690368048 + 0.99972449705055 + 0.99967595441761 + 0.99962725585998 + 0.99957634099364 + 0.99952184906989 + 0.99946270468737 + 0.99939788823745 + 0.99932623187438 + 0.99924659509483 + 0.99915810203274 + 0.99906002139112 + 0.99895139481211 + 0.99883130690232 + 0.99869875312837 + 0.99855249451312 + 0.99839095627013 + 0.99821212649557 + 0.99801346190074 + 0.99779180229382 + 0.99754305819994 + 0.99726210462656 + 0.99694312478680 + 0.99657924582272 + 0.99616249932792 + 0.99568445165589 + 0.99514018053037 + 0.99452851442251 + 0.99384166403787 + 0.99307020955078 + 0.99221022842342 + 0.99125157263721 + 0.99017559186768 + 0.98896010702148 + 0.98758029926616 + 0.98600856962071 + 0.98421299247283 + 0.98215873042051 + 0.97980874312874 + 0.97712208507224 + 0.97405342796895 + 0.97055217025766 + 0.96655837507511 + 0.96199233761820 + 0.95676323459151 + 0.95078976513794 + 0.94399790745612 + 0.93631498801928 + 0.92767878470161 + 0.91803930433416 + 0.90736282342796 + 0.89563738945519 + 0.88287888186291 + 0.86913581713214 + 0.85448584826418 + 0.83902073020090 + 0.82287206306188 + 0.80624772433842 + 0.78940040217315 + 0.78096736061248 + 0.77256774508039 + 0.76422319886876 + 0.75594891804932 + 0.74775260281477 + 0.73963386424160 + 0.73158427651176 + 0.72358825117188 + 0.71562464983494 + 0.70766495046237 + 0.69960848184393 + 0.69116879145265 + 0.68219716482351 + 0.67267969976622 + 0.66260452472290 + 0.65199826868147 + 0.64089829119692 + 0.62935027806641 + 0.61740621689761 + 0.60512287349145 + 0.59255839607425 + 0.57973236211701 + 0.56670174585479 + 0.55352584473367 + 0.54026536276179 + 0.52698061837039 + 0.51372878051291 + 0.50053992689951 + 0.48742881208430 + 0.47441389349326 + 0.46149690212128 + 0.44866133598561 + 0.99965886107080 + 0.99966966446652 + 0.99967150447948 + 0.99967366857261 + 0.99967621827919 + 0.99967922877271 + 0.99968279286227 + 0.99968702685645 + 0.99969208050780 + 0.99969815932484 + 0.99970558005819 + 0.99971484241139 + 0.99972666226938 + 0.99974210862688 + 0.99976303369296 + 0.99979336133792 + 0.99984488087475 + 1.00000000000000 + 0.99983110118522 + 0.99975911512851 + 0.99970242798143 + 0.99964910210089 + 0.99959508052152 + 0.99953827132181 + 0.99947726972077 + 0.99941088314661 + 0.99933784254200 + 0.99925694943245 + 0.99916729899803 + 0.99906814733897 + 0.99895853044131 + 0.99883753349225 + 0.99870415460656 + 0.99855715677970 + 0.99839496513738 + 0.99821556498824 + 0.99801640768671 + 0.99779432582466 + 0.99754522157626 + 0.99726396158049 + 0.99694472149443 + 0.99658062140404 + 0.99616368653416 + 0.99568547786039 + 0.99514106933172 + 0.99452928636910 + 0.99384233605748 + 0.99307079576782 + 0.99221074118910 + 0.99125202245659 + 0.99017598750892 + 0.98896045587742 + 0.98758060764987 + 0.98600884292830 + 0.98421323532665 + 0.98215894680430 + 0.97980893648497 + 0.97712225839224 + 0.97405358385154 + 0.97055231098383 + 0.96655850260804 + 0.96199245360415 + 0.95676334037832 + 0.95078986187842 + 0.94399799612758 + 0.93631506945347 + 0.92767885958688 + 0.91803937324694 + 0.90736288684140 + 0.89563744777082 + 0.88287893540634 + 0.86913586618122 + 0.85448589306581 + 0.83902077097632 + 0.82287210001661 + 0.80624775771030 + 0.78940043222001 + 0.78096738910047 + 0.77256777208197 + 0.76422322445742 + 0.75594894229640 + 0.74775262579549 + 0.73963388602778 + 0.73158429716809 + 0.72358827076253 + 0.71562466841860 + 0.70766496809205 + 0.69960849856064 + 0.69116880726088 + 0.68219717971611 + 0.67267971373402 + 0.66260453776395 + 0.65199828079961 + 0.64089830240080 + 0.62935028837563 + 0.61740622633452 + 0.60512288208701 + 0.59255840386383 + 0.57973236913764 + 0.56670175214616 + 0.55352585033962 + 0.54026536772852 + 0.52698062274435 + 0.51372878434420 + 0.50053993023864 + 0.48742881498058 + 0.47441389599668 + 0.46149690428118 + 0.44866133784767 + 0.99963277392851 + 0.99964260792078 + 0.99964427371137 + 0.99964622927133 + 0.99964852810959 + 0.99965123492953 + 0.99965442860868 + 0.99965820645622 + 0.99966269143093 + 0.99966804928557 + 0.99967453296098 + 0.99968253451560 + 0.99969258522400 + 0.99970540890490 + 0.99972210974246 + 0.99974460250935 + 0.99977690368048 + 0.99983110118522 + 1.00000000000000 + 0.99981639874026 + 0.99973979040062 + 0.99967808843890 + 0.99961921178482 + 0.99955907219208 + 0.99949553551619 + 0.99942707662113 + 0.99935224959414 + 0.99926975923006 + 0.99917865197604 + 0.99907816130910 + 0.99896731218142 + 0.99884518805747 + 0.99871078872376 + 0.99856287853322 + 0.99839988172150 + 0.99821977960033 + 0.99802001651932 + 0.99779741591725 + 0.99754786950183 + 0.99726623349004 + 0.99694667417199 + 0.99658230294675 + 0.99616513717791 + 0.99568673124283 + 0.99514215447132 + 0.99453022856541 + 0.99384315614481 + 0.99307151112079 + 0.99221136700611 + 0.99125257163698 + 0.99017647078500 + 0.98896088228732 + 0.98758098487480 + 0.98600917754078 + 0.98421353294516 + 0.98215921225034 + 0.97980917394058 + 0.97712247147334 + 0.97405377571448 + 0.97055248438339 + 0.96655865992065 + 0.96199259681036 + 0.95676347111106 + 0.95078998152024 + 0.94399810586621 + 0.93631517029360 + 0.92767895236338 + 0.91803945865934 + 0.90736296547236 + 0.89563752010262 + 0.88287900184457 + 0.86913592707150 + 0.85448594870854 + 0.83902082163967 + 0.82287214596317 + 0.80624779922840 + 0.78940046963186 + 0.78096742458531 + 0.77256780572839 + 0.76422325635725 + 0.75594897254358 + 0.74775265447592 + 0.73963391322716 + 0.73158432297180 + 0.72358829524811 + 0.71562469165760 + 0.70766499015246 + 0.69960851948801 + 0.69116882706157 + 0.68219719837735 + 0.67267973124878 + 0.66260455412583 + 0.65199829601176 + 0.64089831647584 + 0.62935030133315 + 0.61740623820484 + 0.60512289290519 + 0.59255841367526 + 0.57973237798693 + 0.56670176008407 + 0.55352585741892 + 0.54026537400543 + 0.52698062827746 + 0.51372878919602 + 0.50053993447111 + 0.48742881865505 + 0.47441389917694 + 0.46149690702676 + 0.44866134021736 + 0.99960362357683 + 0.99961259851865 + 0.99961411233282 + 0.99961588695430 + 0.99961796951388 + 0.99962041656541 + 0.99962329639756 + 0.99962669227502 + 0.99963070799026 + 0.99963548178395 + 0.99964122373761 + 0.99964825646755 + 0.99965700103198 + 0.99966799603337 + 0.99968199753708 + 0.99970016646670 + 0.99972449705055 + 0.99975911512851 + 0.99981639874026 + 1.00000000000000 + 0.99980072331938 + 0.99971871705284 + 0.99965115201817 + 0.99958585636622 + 0.99951870011627 + 0.99944742516841 + 0.99937024653853 + 0.99928569654278 + 0.99919273590884 + 0.99909055698713 + 0.99897816385905 + 0.99885463367646 + 0.99871896569624 + 0.99856992417740 + 0.99840593101260 + 0.99822496166725 + 0.99802445119613 + 0.99780121125809 + 0.99755112031380 + 0.99726902151689 + 0.99694906949765 + 0.99658436485304 + 0.99616691524533 + 0.99568826690940 + 0.99514348351512 + 0.99453138221045 + 0.99384416011171 + 0.99307238684632 + 0.99221213322937 + 0.99125324425425 + 0.99017706298652 + 0.98896140514040 + 0.98758144777555 + 0.98600958851112 + 0.98421389882219 + 0.98215953891123 + 0.97980946645880 + 0.97712273425581 + 0.97405401259090 + 0.97055269869263 + 0.96655885455314 + 0.96199277416139 + 0.95676363315260 + 0.95079012992639 + 0.94399824207943 + 0.93631529552511 + 0.92767906763882 + 0.91803956482809 + 0.90736306324739 + 0.89563761007584 + 0.88287908451757 + 0.86913600286900 + 0.85448601800636 + 0.83902088476871 + 0.82287220324935 + 0.80624785102871 + 0.78940051634313 + 0.78096746890749 + 0.77256784777611 + 0.76422329624334 + 0.75594901037795 + 0.74775269036908 + 0.73963394728606 + 0.73158435529984 + 0.72358832593972 + 0.71562472080413 + 0.70766501783272 + 0.69960854576214 + 0.69116885193485 + 0.68219722183319 + 0.67267975327508 + 0.66260457471584 + 0.65199831516738 + 0.64089833420984 + 0.62935031767034 + 0.61740625318073 + 0.60512290656332 + 0.59255842607107 + 0.57973238917589 + 0.56670177012776 + 0.55352586638388 + 0.54026538196064 + 0.52698063529808 + 0.51372879535710 + 0.50053993985122 + 0.48742882333214 + 0.47441390322841 + 0.46149691052869 + 0.44866134324259 + 0.99957097131309 + 0.99957917786445 + 0.99958055748156 + 0.99958217301536 + 0.99958406639277 + 0.99958628763372 + 0.99958889669675 + 0.99959196606966 + 0.99959558522642 + 0.99959987237574 + 0.99960500701206 + 0.99961126355164 + 0.99961899115405 + 0.99962861751277 + 0.99964071083396 + 0.99965607894769 + 0.99967595441761 + 0.99970242798143 + 0.99973979040062 + 0.99980072331938 + 1.00000000000000 + 0.99978394055523 + 0.99969560342909 + 0.99962120813503 + 0.99954850707439 + 0.99947324186859 + 0.99939288457944 + 0.99930563163906 + 0.99921028386615 + 0.99910595682573 + 0.99899161529612 + 0.99886632118245 + 0.99872906860031 + 0.99857861877977 + 0.99841338865396 + 0.99823134499279 + 0.99802991026122 + 0.99780588076726 + 0.99755511805655 + 0.99727244877155 + 0.99695201292525 + 0.99658689767119 + 0.99616909861766 + 0.99569015194017 + 0.99514511435913 + 0.99453279746464 + 0.99384539155317 + 0.99307346095262 + 0.99221307315445 + 0.99125406960800 + 0.99017779000005 + 0.98896204740906 + 0.98758201680793 + 0.98601009411288 + 0.98421434934849 + 0.98215994152672 + 0.97980982735537 + 0.97712305879014 + 0.97405430542854 + 0.97055296390008 + 0.96655909563982 + 0.96199299403359 + 0.95676383420069 + 0.95079031418061 + 0.94399841128910 + 0.93631545116904 + 0.92767921096284 + 0.91803969687909 + 0.90736318489428 + 0.89563772205604 + 0.88287918744491 + 0.86913609727219 + 0.85448610434447 + 0.83902096346100 + 0.82287227469865 + 0.80624791567536 + 0.78940057468699 + 0.78096752429197 + 0.77256790034124 + 0.76422334612500 + 0.75594905771742 + 0.74775273530333 + 0.73963398994476 + 0.73158439580925 + 0.72358836442083 + 0.71562475736571 + 0.70766505257366 + 0.69960857875513 + 0.69116888318518 + 0.68219725131890 + 0.67267978098038 + 0.66260460062739 + 0.65199833929015 + 0.64089835655486 + 0.62935033826876 + 0.61740627207518 + 0.60512292380884 + 0.59255844173182 + 0.57973240332277 + 0.56670178283608 + 0.55352587773557 + 0.54026539204322 + 0.52698064420181 + 0.51372880317906 + 0.50053994668741 + 0.48742882928189 + 0.47441390838753 + 0.46149691499292 + 0.44866134710266 + 0.99953433426468 + 0.99954184705759 + 0.99954310678295 + 0.99954458067884 + 0.99954630632570 + 0.99954832834476 + 0.99955069995757 + 0.99955348507683 + 0.99955676204269 + 0.99956063379575 + 0.99956525677526 + 0.99957086971513 + 0.99957777113167 + 0.99958631591886 + 0.99959695859968 + 0.99961031437620 + 0.99962725585998 + 0.99964910210089 + 0.99967808843890 + 0.99971871705284 + 0.99978394055523 + 1.00000000000000 + 0.99976587990736 + 0.99967011115466 + 0.99958777248723 + 0.99950646062366 + 0.99942163327421 + 0.99933074358228 + 0.99923226930740 + 0.99912517601452 + 0.99900835325585 + 0.99888083023657 + 0.99874158679260 + 0.99858937537373 + 0.99842260338022 + 0.99823922435421 + 0.99803664337810 + 0.99781163646679 + 0.99756004328562 + 0.99727666944493 + 0.99695563648092 + 0.99659001470791 + 0.99617178473885 + 0.99569247027146 + 0.99514711946730 + 0.99453453708320 + 0.99384690501323 + 0.99307478099411 + 0.99221422842588 + 0.99125508434646 + 0.99017868422044 + 0.98896283783256 + 0.98758271756560 + 0.98601071722580 + 0.98421490504514 + 0.98216043855820 + 0.97981027328392 + 0.97712346016340 + 0.97405466793569 + 0.97055329250452 + 0.96655939461419 + 0.96199326692096 + 0.95676408389362 + 0.95079054315444 + 0.94399862166898 + 0.93631564476188 + 0.92767938928995 + 0.91803986122476 + 0.90736333633636 + 0.89563786149708 + 0.88287931564962 + 0.86913621489502 + 0.85448621196507 + 0.83902106159065 + 0.82287236384101 + 0.80624799638402 + 0.78940064757808 + 0.78096759351460 + 0.77256796606494 + 0.76422340852596 + 0.75594911696272 + 0.74775279156469 + 0.73963404338349 + 0.73158444658308 + 0.72358841267505 + 0.71562480323605 + 0.70766509618323 + 0.69960862019092 + 0.69116892245288 + 0.68219728838976 + 0.67267981583024 + 0.66260463324150 + 0.65199836966688 + 0.64089838471186 + 0.62935036424057 + 0.61740629591219 + 0.60512294557945 + 0.59255846151706 + 0.57973242120745 + 0.56670179891325 + 0.55352589210815 + 0.54026540481884 + 0.52698065549522 + 0.51372881310849 + 0.50053995537459 + 0.48742883684854 + 0.47441391495536 + 0.46149692068210 + 0.44866135202690 + 0.99949318744176 + 0.99950006766252 + 0.99950121901158 + 0.99950256523610 + 0.99950414019006 + 0.99950598394514 + 0.99950814409746 + 0.99951067753145 + 0.99951365360965 + 0.99951716316424 + 0.99952134441494 + 0.99952640819302 + 0.99953261497363 + 0.99954026799345 + 0.99954974613020 + 0.99956154608256 + 0.99957634099364 + 0.99959508052152 + 0.99961921178482 + 0.99965115201817 + 0.99969560342909 + 0.99976587990736 + 1.00000000000000 + 0.99974632912586 + 0.99964182898661 + 0.99955017593963 + 0.99945864930586 + 0.99936268094176 + 0.99926001415687 + 0.99914930053188 + 0.99902928016968 + 0.99889891458761 + 0.99875715124725 + 0.99860272289250 + 0.99843401928169 + 0.99824897346836 + 0.99804496600279 + 0.99781874556618 + 0.99756612316243 + 0.99728187727966 + 0.99696010592849 + 0.99659385818308 + 0.99617509588344 + 0.99569532719850 + 0.99514958970883 + 0.99453667978807 + 0.99384876889813 + 0.99307640661831 + 0.99221565128286 + 0.99125633443873 + 0.99017978627397 + 0.98896381246331 + 0.98758358216385 + 0.98601148655216 + 0.98421559164662 + 0.98216105316830 + 0.97981082515795 + 0.97712395731249 + 0.97405511732552 + 0.97055370019751 + 0.96655976583126 + 0.96199360597829 + 0.95676439433001 + 0.95079082796893 + 0.94399888346503 + 0.93631588574290 + 0.92767961133282 + 0.91804006590505 + 0.90736352498224 + 0.89563803523181 + 0.88287947542037 + 0.86913636151679 + 0.85448634615972 + 0.83902118400314 + 0.82287247509831 + 0.80624809717481 + 0.78940073866616 + 0.78096768005121 + 0.77256804826394 + 0.76422348659980 + 0.75594919112382 + 0.74775286202164 + 0.73963411034086 + 0.73158451022967 + 0.72358847319293 + 0.71562486079317 + 0.70766515092982 + 0.69960867223396 + 0.69116897179765 + 0.68219733499792 + 0.67267985967062 + 0.66260467429019 + 0.65199840792175 + 0.64089842019168 + 0.62935039698542 + 0.61740632598459 + 0.60512297306235 + 0.59255848650803 + 0.57973244381431 + 0.56670181925035 + 0.55352591030091 + 0.54026542100326 + 0.52698066981290 + 0.51372882570826 + 0.50053996640821 + 0.48742884646759 + 0.47441392331311 + 0.46149692792812 + 0.44866135830476 + 0.99944696816492 + 0.99945326549276 + 0.99945431767955 + 0.99945554735113 + 0.99945698510732 + 0.99945866708079 + 0.99946063605290 + 0.99946294298371 + 0.99946564976828 + 0.99946883726419 + 0.99947262871531 + 0.99947721211748 + 0.99948281778046 + 0.99948970986834 + 0.99949821287873 + 0.99950874324776 + 0.99952184906989 + 0.99953827132181 + 0.99955907219208 + 0.99958585636622 + 0.99962120813503 + 0.99967011115466 + 0.99974632912586 + 1.00000000000000 + 0.99972500911801 + 0.99961015044005 + 0.99950735836386 + 0.99940385982727 + 0.99929537097213 + 0.99917981108037 + 0.99905560373854 + 0.99892156910421 + 0.99877658578529 + 0.99861934587362 + 0.99844820699923 + 0.99826106979249 + 0.99805527934936 + 0.99782754678345 + 0.99757364492885 + 0.99728831687000 + 0.99696563030629 + 0.99659860730480 + 0.99617918607613 + 0.99569885533245 + 0.99515263953806 + 0.99453932469712 + 0.99385106933622 + 0.99307841291984 + 0.99221740748980 + 0.99125787775549 + 0.99018114731058 + 0.98896501668956 + 0.98758465102074 + 0.98601243822804 + 0.98421644156278 + 0.98216181450933 + 0.97981150929492 + 0.97712457407739 + 0.97405567525182 + 0.97055420672159 + 0.96656022735171 + 0.96199402777799 + 0.95676478071199 + 0.95079118261161 + 0.94399920954800 + 0.93631618598171 + 0.92767988802753 + 0.91804032100531 + 0.90736376013545 + 0.89563825182967 + 0.88287967464105 + 0.86913654438779 + 0.85448651357539 + 0.83902133677140 + 0.82287261401072 + 0.80624822308594 + 0.78940085253456 + 0.78096778827025 + 0.77256815109643 + 0.76422358431299 + 0.75594928398192 + 0.74775295028274 + 0.73963419425228 + 0.73158459003225 + 0.72358854910762 + 0.71562493302753 + 0.70766521966895 + 0.69960873761180 + 0.69116903381511 + 0.68219739360362 + 0.67267991482382 + 0.66260472596105 + 0.65199845610124 + 0.64089846489995 + 0.62935043827115 + 0.61740636392239 + 0.60512300775367 + 0.59255851807552 + 0.57973247238555 + 0.56670184497177 + 0.55352593332730 + 0.54026544150197 + 0.52698068796168 + 0.51372884169294 + 0.50053998041794 + 0.48742885869300 + 0.47441393394559 + 0.46149693715372 + 0.44866136630383 + 0.99939507155338 + 0.99940082589606 + 0.99940178622990 + 0.99940290813282 + 0.99940421930674 + 0.99940575239033 + 0.99940754595235 + 0.99940964580769 + 0.99941210744997 + 0.99941500326078 + 0.99941844370862 + 0.99942259736997 + 0.99942766951912 + 0.99943389315055 + 0.99944155105622 + 0.99945100097302 + 0.99946270468737 + 0.99947726972077 + 0.99949553551619 + 0.99951870011627 + 0.99954850707439 + 0.99958777248723 + 0.99964182898661 + 0.99972500911801 + 1.00000000000000 + 0.99970145097279 + 0.99957405786179 + 0.99945810939890 + 0.99934106735208 + 0.99921880011627 + 0.99908898700596 + 0.99895013895033 + 0.99880098890426 + 0.99864014700256 + 0.99846591227846 + 0.99827613279072 + 0.99806810100928 + 0.99783847519817 + 0.99758297639012 + 0.99729630069355 + 0.99697247625899 + 0.99660449044990 + 0.99618425144226 + 0.99570322347491 + 0.99515641457532 + 0.99454259790598 + 0.99385391589851 + 0.99308089541059 + 0.99221958069468 + 0.99125978790718 + 0.99018283239452 + 0.98896650825438 + 0.98758597558303 + 0.98601361823627 + 0.98421749604239 + 0.98216275970813 + 0.97981235920503 + 0.97712534079930 + 0.97405636929145 + 0.97055483722137 + 0.96656080217281 + 0.96199455339232 + 0.95676526240395 + 0.95079162488840 + 0.94399961631490 + 0.93631656057264 + 0.92768023328816 + 0.91804063935533 + 0.90736405361561 + 0.89563852217506 + 0.88287992333618 + 0.86913677271103 + 0.85448672265257 + 0.83902152761849 + 0.82287278761542 + 0.80624838052609 + 0.78940099500703 + 0.78096792372269 + 0.77256827985520 + 0.76422370670953 + 0.75594940034456 + 0.74775306093236 + 0.73963429949843 + 0.73158469016827 + 0.72358864441107 + 0.71562502374955 + 0.70766530604171 + 0.69960881979946 + 0.69116911181636 + 0.68219746735210 + 0.67267998426165 + 0.66260479104465 + 0.65199851681853 + 0.64089852127346 + 0.62935049035775 + 0.61740641181399 + 0.60512305157283 + 0.59255855797057 + 0.57973250851707 + 0.56670187751953 + 0.55352596248558 + 0.54026546747944 + 0.52698071097721 + 0.51372886198000 + 0.50053999821430 + 0.48742887423676 + 0.47441394747476 + 0.46149694890534 + 0.44866137650161 + 0.99933678325661 + 0.99934202623591 + 0.99934290044578 + 0.99934392144590 + 0.99934511429551 + 0.99934650847911 + 0.99934813878029 + 0.99935004643304 + 0.99935228128862 + 0.99935490828916 + 0.99935802667025 + 0.99936178790492 + 0.99936637566928 + 0.99937199686173 + 0.99937890051777 + 0.99938739851814 + 0.99939788823745 + 0.99941088314661 + 0.99942707662113 + 0.99944742516841 + 0.99947324186859 + 0.99950646062366 + 0.99955017593963 + 0.99961015044005 + 0.99970145097279 + 1.00000000000000 + 0.99967484734809 + 0.99953246887240 + 0.99940149327568 + 0.99926942599510 + 0.99913185143437 + 0.99898653771768 + 0.99883189723236 + 0.99866637268647 + 0.99848815416631 + 0.99829500191639 + 0.99808412774999 + 0.99785211349365 + 0.99759460819598 + 0.99730624439586 + 0.99698099771008 + 0.99661181026399 + 0.99619055162978 + 0.99570865489304 + 0.99516110734912 + 0.99454666607298 + 0.99385745336748 + 0.99308398032073 + 0.99222228145860 + 0.99126216224391 + 0.99018492762825 + 0.98896836362633 + 0.98758762402318 + 0.98601508758613 + 0.98421880986230 + 0.98216393810110 + 0.97981341948433 + 0.97712629791724 + 0.97405723623110 + 0.97055562527197 + 0.96656152102922 + 0.96199521103702 + 0.95676586533166 + 0.95079217864793 + 0.94400012572477 + 0.93631702975803 + 0.92768066578719 + 0.91804103816646 + 0.90736442129783 + 0.89563886090102 + 0.88288023496818 + 0.86913705885477 + 0.85448698474134 + 0.83902176693039 + 0.82287300539475 + 0.80624857813169 + 0.78940117393820 + 0.78096809389800 + 0.77256844168705 + 0.76422386060842 + 0.75594954672064 + 0.74775320018264 + 0.73963443200885 + 0.73158481630226 + 0.72358876451110 + 0.71562513813373 + 0.70766541499413 + 0.69960892351987 + 0.69116921030039 + 0.68219756051095 + 0.67268007202043 + 0.66260487334299 + 0.65199859363795 + 0.64089859263467 + 0.62935055632892 + 0.61740647250517 + 0.60512310713398 + 0.59255860858924 + 0.57973255439084 + 0.56670191886829 + 0.55352599955410 + 0.54026550052649 + 0.52698074028148 + 0.51372888783199 + 0.50054002091010 + 0.48742889407566 + 0.47441396476041 + 0.46149696393196 + 0.44866138955083 + 0.99927114533627 + 0.99927590156841 + 0.99927669407427 + 0.99927761945266 + 0.99927870030965 + 0.99927996322381 + 0.99928143949745 + 0.99928316620208 + 0.99928518807158 + 0.99928756334697 + 0.99929038108435 + 0.99929377725678 + 0.99929791624876 + 0.99930298221985 + 0.99930919548632 + 0.99931683006118 + 0.99932623187438 + 0.99933784254200 + 0.99935224959414 + 0.99937024653853 + 0.99939288457944 + 0.99942163327421 + 0.99945864930586 + 0.99950735836386 + 0.99957405786179 + 0.99967484734809 + 1.00000000000000 + 0.99964459421331 + 0.99948480072851 + 0.99933691675706 + 0.99918799289254 + 0.99903367361195 + 0.99887159871159 + 0.99869985106473 + 0.99851641003407 + 0.99831888295948 + 0.99810435308973 + 0.99786928777777 + 0.99760923291608 + 0.99731873267072 + 0.99699169124875 + 0.99662099056374 + 0.99619844969367 + 0.99571546143427 + 0.99516698652008 + 0.99455176166033 + 0.99386188367353 + 0.99308784373302 + 0.99222566413107 + 0.99126513678742 + 0.99018755348374 + 0.98897068998211 + 0.98758969207972 + 0.98601693212245 + 0.98422046027854 + 0.98216541944825 + 0.97981475331753 + 0.97712750285896 + 0.97405832843934 + 0.97055661878484 + 0.96656242790233 + 0.96199604116009 + 0.95676662674973 + 0.95079287823799 + 0.94400076946781 + 0.93631762279816 + 0.92768121253313 + 0.91804154239111 + 0.90736488622223 + 0.89563928926971 + 0.88288062913070 + 0.86913742086251 + 0.85448731640997 + 0.83902206988811 + 0.82287328123121 + 0.80624882856358 + 0.78940140087155 + 0.78096830981229 + 0.77256864710412 + 0.76422405604841 + 0.75594973269428 + 0.74775337719075 + 0.73963460053267 + 0.73158497680397 + 0.72358891741683 + 0.71562528383559 + 0.70766555384748 + 0.69960905577280 + 0.69116933594417 + 0.68219767942377 + 0.67268018410292 + 0.66260497851184 + 0.65199869185842 + 0.64089868393106 + 0.62935064078000 + 0.61740655024514 + 0.60512317835000 + 0.59255867351106 + 0.57973261326523 + 0.56670197197413 + 0.55352604719645 + 0.54026554303448 + 0.52698077800562 + 0.51372892113894 + 0.50054005017990 + 0.48742891968715 + 0.47441398709545 + 0.46149698336595 + 0.44866140644579 + 0.99919714319086 + 0.99920143327915 + 0.99920214773579 + 0.99920298184308 + 0.99920395590367 + 0.99920509377063 + 0.99920642351296 + 0.99920797833710 + 0.99920979826015 + 0.99921193535504 + 0.99921446927551 + 0.99921752165672 + 0.99922123921829 + 0.99922578569006 + 0.99923135607970 + 0.99923819166509 + 0.99924659509483 + 0.99925694943245 + 0.99926975923006 + 0.99928569654278 + 0.99930563163906 + 0.99933074358228 + 0.99936268094176 + 0.99940385982727 + 0.99945810939890 + 0.99953246887240 + 0.99964459421331 + 1.00000000000000 + 0.99961044901416 + 0.99943063658800 + 0.99926349401319 + 0.99909595164763 + 0.99892343963899 + 0.99874319007822 + 0.99855274752218 + 0.99834943831996 + 0.99813013077585 + 0.99789111355800 + 0.99762777944376 + 0.99733454591180 + 0.99700521735375 + 0.99663259368506 + 0.99620842655357 + 0.99572405574581 + 0.99517440738093 + 0.99455819195555 + 0.99386747371452 + 0.99309271839617 + 0.99222993275662 + 0.99126889144284 + 0.99019086938345 + 0.98897362923009 + 0.98759230659132 + 0.98601926566604 + 0.98422254978205 + 0.98216729635487 + 0.97981644467313 + 0.97712903200819 + 0.97405971562024 + 0.97055788158836 + 0.96656358139933 + 0.96199709770666 + 0.95676759636451 + 0.95079376949850 + 0.94400158985685 + 0.93631837876933 + 0.92768190963588 + 0.91804218539053 + 0.90736547919346 + 0.89563983570946 + 0.88288113204376 + 0.86913788287028 + 0.85448773983340 + 0.83902245682739 + 0.82287363371884 + 0.80624914880746 + 0.78940169129550 + 0.78096858626087 + 0.77256891023605 + 0.76422430652609 + 0.75594997116333 + 0.74775360428856 + 0.73963481686604 + 0.73158518294790 + 0.72358911391149 + 0.71562547118339 + 0.70766573248849 + 0.69960922601646 + 0.69116949777056 + 0.68219783266808 + 0.67268032862656 + 0.66260511420157 + 0.65199881866194 + 0.64089880186923 + 0.62935074994270 + 0.61740665079849 + 0.60512327052547 + 0.59255875759469 + 0.57973268957136 + 0.56670204085552 + 0.55352610904016 + 0.54026559825822 + 0.52698082705624 + 0.51372896448945 + 0.50054008831125 + 0.48742895308617 + 0.47441401625220 + 0.46149700876275 + 0.44866142854322 + 0.99911395369942 + 0.99911779794479 + 0.99911843789204 + 0.99911918491534 + 0.99912005714818 + 0.99912107588592 + 0.99912226616675 + 0.99912365758061 + 0.99912528577063 + 0.99912719706700 + 0.99912946236859 + 0.99913218991263 + 0.99913551006800 + 0.99913956788033 + 0.99914453554234 + 0.99915062528801 + 0.99915810203274 + 0.99916729899803 + 0.99917865197604 + 0.99919273590884 + 0.99921028386615 + 0.99923226930740 + 0.99926001415687 + 0.99929537097213 + 0.99934106735208 + 0.99940149327568 + 0.99948480072851 + 0.99961044901416 + 1.00000000000000 + 0.99957198007270 + 0.99936890652906 + 0.99918021286474 + 0.99899231118206 + 0.99880004962876 + 0.99859998108880 + 0.99838887741480 + 0.99816322660168 + 0.99791902511578 + 0.99765142939165 + 0.99735466912834 + 0.99702240516173 + 0.99664732293891 + 0.99622108225799 + 0.99573495191866 + 0.99518381215242 + 0.99456633924036 + 0.99387455537676 + 0.99309889363032 + 0.99223534089197 + 0.99127364966759 + 0.99019507323273 + 0.98897735742767 + 0.98759562483197 + 0.98602222922622 + 0.98422520524898 + 0.98216968336430 + 0.97981859729653 + 0.97713097963023 + 0.97406148371617 + 0.97055949227544 + 0.96656505362871 + 0.96199844696105 + 0.95676883518958 + 0.95079490863495 + 0.94400263871162 + 0.93631934545763 + 0.92768280118607 + 0.91804300784727 + 0.90736623775659 + 0.89564053483917 + 0.88288177558805 + 0.86913847419892 + 0.85448828194831 + 0.83902295242916 + 0.82287408543098 + 0.80624955945942 + 0.78940206400023 + 0.78096894118848 + 0.77256924822567 + 0.76422462841475 + 0.75595027778260 + 0.74775389643669 + 0.73963509531750 + 0.73158544843168 + 0.72358936710811 + 0.71562571271639 + 0.70766596292248 + 0.69960944573954 + 0.69116970674004 + 0.68219803066835 + 0.67268051546568 + 0.66260528971834 + 0.65199898278259 + 0.64089895460354 + 0.62935089140178 + 0.61740678118053 + 0.60512339011849 + 0.59255886676497 + 0.57973278871053 + 0.56670213041134 + 0.55352618950458 + 0.54026567016804 + 0.52698089098075 + 0.51372902103468 + 0.50054013809746 + 0.48742899673778 + 0.47441405439753 + 0.46149704202031 + 0.44866145750769 + 0.99902085531399 + 0.99902427590274 + 0.99902484514463 + 0.99902550956786 + 0.99902628526877 + 0.99902719113656 + 0.99902824937564 + 0.99902948620698 + 0.99903093318602 + 0.99903263132236 + 0.99903464333391 + 0.99903706494690 + 0.99904001132745 + 0.99904361035266 + 0.99904801343291 + 0.99905340664728 + 0.99906002139112 + 0.99906814733897 + 0.99907816130910 + 0.99909055698713 + 0.99910595682573 + 0.99912517601452 + 0.99914930053188 + 0.99917981108037 + 0.99921880011627 + 0.99926942599510 + 0.99933691675706 + 0.99943063658800 + 0.99957198007270 + 1.00000000000000 + 0.99952807984565 + 0.99929846921562 + 0.99908595680279 + 0.99887588890996 + 0.99866213838682 + 0.99844026405127 + 0.99820602996999 + 0.99795492702985 + 0.99768172973680 + 0.99738037855015 + 0.99704432091198 + 0.99666607803051 + 0.99623718165432 + 0.99574880368496 + 0.99519576231403 + 0.99457668837960 + 0.99388354933845 + 0.99310673598349 + 0.99224220963676 + 0.99127969431611 + 0.99020041544455 + 0.98898209724854 + 0.98759984558957 + 0.98602600095300 + 0.98422858689015 + 0.98217272501898 + 0.97982134200002 + 0.97713346450853 + 0.97406374092652 + 0.97056154972863 + 0.96656693521220 + 0.96200017215843 + 0.95677041975611 + 0.95079636608327 + 0.94400398088989 + 0.93632058264281 + 0.92768394228217 + 0.91804406055660 + 0.90736720872000 + 0.89564142978028 + 0.88288259945527 + 0.86913923134201 + 0.85448897623881 + 0.83902358736404 + 0.82287466439859 + 0.80625008610523 + 0.78940254232486 + 0.78096939687925 + 0.77256968235820 + 0.76422504205850 + 0.75595067198527 + 0.74775427222450 + 0.73963545366711 + 0.73158579026590 + 0.72358969328886 + 0.71562602403114 + 0.70766626007992 + 0.69960972922611 + 0.69116997649271 + 0.68219828639271 + 0.67268075689977 + 0.66260551664680 + 0.65199919508887 + 0.64089915229585 + 0.62935107459850 + 0.61740695013249 + 0.60512354518453 + 0.59255900840041 + 0.57973291741092 + 0.56670224674645 + 0.55352629410564 + 0.54026576371557 + 0.52698097420838 + 0.51372909471715 + 0.50054020302834 + 0.48742905371949 + 0.47441410423951 + 0.46149708551721 + 0.44866149542371 + 0.99891688540471 + 0.99891990669245 + 0.99892040936740 + 0.99892099604685 + 0.99892168092678 + 0.99892248065160 + 0.99892341478316 + 0.99892450640874 + 0.99892578330410 + 0.99892728152462 + 0.99892905618643 + 0.99893119136964 + 0.99893378814072 + 0.99893695856291 + 0.99894083507498 + 0.99894558004843 + 0.99895139481211 + 0.99895853044131 + 0.99896731218142 + 0.99897816385905 + 0.99899161529612 + 0.99900835325585 + 0.99902928016968 + 0.99905560373854 + 0.99908898700596 + 0.99913185143437 + 0.99918799289254 + 0.99926349401319 + 0.99936890652906 + 0.99952807984565 + 1.00000000000000 + 0.99947809441912 + 0.99921848014168 + 0.99897976399164 + 0.99874554132077 + 0.99850822407591 + 0.99826204487350 + 0.99800155132415 + 0.99772086326081 + 0.99741345330884 + 0.99707243812674 + 0.99669009466282 + 0.99625777074863 + 0.99576650247982 + 0.99521102205252 + 0.99458989854651 + 0.99389502716272 + 0.99311674336602 + 0.99225097521401 + 0.99128740982795 + 0.99020723656766 + 0.98898815173311 + 0.98760523966206 + 0.98603082373641 + 0.98423291332402 + 0.98217661874281 + 0.97982485766309 + 0.97713664921922 + 0.97406663548760 + 0.97056418953700 + 0.96656935053296 + 0.96200238763092 + 0.95677245527641 + 0.95079823872310 + 0.94400570566884 + 0.93632217261610 + 0.92768540881286 + 0.91804541350760 + 0.90736845662002 + 0.89564258000848 + 0.88288365841586 + 0.86914020465829 + 0.85448986894828 + 0.83902440400746 + 0.82287540937428 + 0.80625076414251 + 0.78940315857309 + 0.78096998420142 + 0.77257024213428 + 0.76422557565453 + 0.75595118074551 + 0.74775475744902 + 0.73963591660323 + 0.73158623208806 + 0.72359011508721 + 0.71562642681111 + 0.70766664473420 + 0.69961009636334 + 0.69117032601844 + 0.68219861790737 + 0.67268107005255 + 0.66260581113514 + 0.65199947074940 + 0.64089940911445 + 0.62935131272267 + 0.61740716986144 + 0.60512374696734 + 0.59255919281747 + 0.57973308509072 + 0.56670239841393 + 0.55352643056442 + 0.54026588584303 + 0.52698108294691 + 0.51372919106375 + 0.50054028800644 + 0.48742912836295 + 0.47441416959046 + 0.46149714260144 + 0.44866154522793 + 0.99880110583217 + 0.99880375537369 + 0.99880419612590 + 0.99880471050609 + 0.99880531094678 + 0.99880601202356 + 0.99880683085951 + 0.99880778765379 + 0.99880890670063 + 0.99881021950401 + 0.99881177417693 + 0.99881364404030 + 0.99881591719372 + 0.99881869122885 + 0.99882208132809 + 0.99882622843558 + 0.99883130690232 + 0.99883753349225 + 0.99884518805747 + 0.99885463367646 + 0.99886632118245 + 0.99888083023657 + 0.99889891458761 + 0.99892156910421 + 0.99895013895033 + 0.99898653771768 + 0.99903367361195 + 0.99909595164763 + 0.99918021286474 + 0.99929846921562 + 0.99947809441912 + 1.00000000000000 + 0.99942120775286 + 0.99912789292694 + 0.99886044883397 + 0.99859980609214 + 0.99833637132747 + 0.99806273965888 + 0.99777182130407 + 0.99745628598363 + 0.99710871160389 + 0.99672099638831 + 0.99628421460677 + 0.99578920630461 + 0.99523058099932 + 0.99460682159933 + 0.99390972643499 + 0.99312955769774 + 0.99226219964086 + 0.99129729122632 + 0.99021597490729 + 0.98899591076585 + 0.98761215527745 + 0.98603700980543 + 0.98423846546528 + 0.98218161809353 + 0.97982937387052 + 0.97714074231693 + 0.97407035744317 + 0.97056758541758 + 0.96657245883885 + 0.96200523965588 + 0.95677507623454 + 0.95080065029137 + 0.94400792696240 + 0.93632422030359 + 0.92768729745501 + 0.91804715577700 + 0.90737006352424 + 0.89564406109103 + 0.88288502198694 + 0.86914145803840 + 0.85449101870788 + 0.83902545606438 + 0.82287636946478 + 0.80625163840455 + 0.78940395367421 + 0.78097074226099 + 0.77257096492414 + 0.76422626493407 + 0.75595183823246 + 0.74775538480787 + 0.73963651542365 + 0.73158680386583 + 0.72359066121302 + 0.71562694855401 + 0.70766714323029 + 0.69961057237997 + 0.69117077940842 + 0.68219904813748 + 0.67268147664537 + 0.66260619368575 + 0.65199982902200 + 0.64089974306771 + 0.62935162252276 + 0.61740745588110 + 0.60512400976904 + 0.59255943313331 + 0.57973330372172 + 0.56670259628431 + 0.55352660870630 + 0.54026604538570 + 0.52698122510244 + 0.51372931711756 + 0.50054039927846 + 0.48742922618897 + 0.47441425531228 + 0.46149721754587 + 0.44866161066833 + 0.99867248588389 + 0.99867479437869 + 0.99867517835321 + 0.99867562646119 + 0.99867614952089 + 0.99867676021795 + 0.99867747345337 + 0.99867830680260 + 0.99867928139356 + 0.99868042459984 + 0.99868177814515 + 0.99868340555402 + 0.99868538311868 + 0.99868779534083 + 0.99869074183805 + 0.99869434433718 + 0.99869875312837 + 0.99870415460656 + 0.99871078872376 + 0.99871896569624 + 0.99872906860031 + 0.99874158679260 + 0.99875715124725 + 0.99877658578529 + 0.99880098890426 + 0.99883189723236 + 0.99887159871159 + 0.99892343963899 + 0.99899231118206 + 0.99908595680279 + 0.99921848014168 + 0.99942120775286 + 1.00000000000000 + 0.99935642305331 + 0.99902550576033 + 0.99872660085751 + 0.99843685824369 + 0.99814412603311 + 0.99783883773273 + 0.99751217658978 + 0.99715578800600 + 0.99676095268816 + 0.99631832063852 + 0.99581843874122 + 0.99525573561938 + 0.99462857028031 + 0.99392860873407 + 0.99314601470228 + 0.99227661391684 + 0.99130998192643 + 0.99022719986331 + 0.98900588059888 + 0.98762104443871 + 0.98604496424919 + 0.98424560761462 + 0.98218805175205 + 0.97983518811269 + 0.97714601388746 + 0.97407515276487 + 0.97057196207832 + 0.96657646599303 + 0.96200891717780 + 0.95677845623767 + 0.95080376039853 + 0.94401079159422 + 0.93632686081833 + 0.92768973257648 + 0.91804940186685 + 0.90737213482788 + 0.89564597000178 + 0.88288677932532 + 0.86914307336478 + 0.85449250060306 + 0.83902681228629 + 0.82287760750608 + 0.80625276625359 + 0.78940497998766 + 0.78097172108615 + 0.77257189854338 + 0.76422715560717 + 0.75595268816831 + 0.74775619613687 + 0.73963729017876 + 0.73158754395227 + 0.72359136840468 + 0.71562762446432 + 0.70766778930167 + 0.69961118958171 + 0.69117136752373 + 0.68219960645595 + 0.67268200452499 + 0.66260669057046 + 0.65200029458320 + 0.64090017722729 + 0.62935202547466 + 0.61740782808044 + 0.60512435192292 + 0.59255974617002 + 0.57973358866155 + 0.56670285431133 + 0.55352684114490 + 0.54026625368632 + 0.52698141082730 + 0.51372948192711 + 0.50054054487584 + 0.48742935429384 + 0.47441436766186 + 0.46149731585236 + 0.44866169657475 + 0.99852976754143 + 0.99853176797895 + 0.99853210069948 + 0.99853248898391 + 0.99853294220601 + 0.99853347135354 + 0.99853408933193 + 0.99853481135936 + 0.99853565572550 + 0.99853664609454 + 0.99853781846362 + 0.99853922753950 + 0.99854093903309 + 0.99854302571995 + 0.99854557335446 + 0.99854868661198 + 0.99855249451312 + 0.99855715677970 + 0.99856287853322 + 0.99856992417740 + 0.99857861877977 + 0.99858937537373 + 0.99860272289250 + 0.99861934587362 + 0.99864014700256 + 0.99866637268647 + 0.99869985106473 + 0.99874319007822 + 0.99880004962876 + 0.99887588890996 + 0.99897976399164 + 0.99912789292694 + 0.99935642305331 + 1.00000000000000 + 0.99928264856942 + 0.99890999846554 + 0.99857656395353 + 0.99825445001449 + 0.99792815848086 + 0.99758582119603 + 0.99721733876113 + 0.99681291953839 + 0.99636252093082 + 0.99585623240935 + 0.99528820544728 + 0.99465661461718 + 0.99395294096419 + 0.99316721343060 + 0.99229517810971 + 0.99132632621730 + 0.99024165809772 + 0.98901872475354 + 0.98763249930573 + 0.98605521758026 + 0.98425481669389 + 0.98219634984083 + 0.97984268951338 + 0.97715281705852 + 0.97408134291553 + 0.97057761303337 + 0.96658164073408 + 0.96201366673336 + 0.95678282162882 + 0.95080777697892 + 0.94401449069065 + 0.93633026991289 + 0.92769287583840 + 0.91805230047969 + 0.90737480730039 + 0.89564843248992 + 0.88288904595275 + 0.86914515666164 + 0.85449441182521 + 0.83902856160901 + 0.82287920474865 + 0.80625422185752 + 0.78940630518959 + 0.78097298534149 + 0.77257310479653 + 0.76422830677119 + 0.75595378708365 + 0.74775724553130 + 0.73963829265358 + 0.73158850195033 + 0.72359228418192 + 0.71562850008068 + 0.70766862659092 + 0.69961198976370 + 0.69117213029853 + 0.68220033087020 + 0.67268268971764 + 0.66260733579747 + 0.65200089938138 + 0.64090074147210 + 0.62935254938387 + 0.61740831221923 + 0.60512479718078 + 0.59256015372238 + 0.57973395981210 + 0.56670319057413 + 0.55352714422450 + 0.54026652545011 + 0.52698165329221 + 0.51372969723077 + 0.50054073521844 + 0.48742952189952 + 0.47441451477169 + 0.46149744467363 + 0.44866180923067 + 0.99837136963676 + 0.99837309603537 + 0.99837338317835 + 0.99837371827523 + 0.99837410941454 + 0.99837456607989 + 0.99837509940615 + 0.99837572253169 + 0.99837645122754 + 0.99837730588894 + 0.99837831743416 + 0.99837953275485 + 0.99838100819601 + 0.99838280618408 + 0.99838500027181 + 0.99838768014888 + 0.99839095627013 + 0.99839496513738 + 0.99839988172150 + 0.99840593101260 + 0.99841338865396 + 0.99842260338022 + 0.99843401928169 + 0.99844820699923 + 0.99846591227846 + 0.99848815416631 + 0.99851641003407 + 0.99855274752218 + 0.99859998108880 + 0.99866213838682 + 0.99874554132077 + 0.99886044883397 + 0.99902550576033 + 0.99928264856942 + 1.00000000000000 + 0.99919869187310 + 0.99877988518571 + 0.99840834269747 + 0.99804949013343 + 0.99768414701902 + 0.99729858622902 + 0.99688099691039 + 0.99642013067367 + 0.99590532520521 + 0.99533028802267 + 0.99469290801891 + 0.99398440028445 + 0.99319460500362 + 0.99231915755219 + 0.99134743535788 + 0.99026033142334 + 0.98903531507010 + 0.98764729746229 + 0.98606846603784 + 0.98426671827882 + 0.98220707626049 + 0.97985238796601 + 0.97716161430550 + 0.97408934863191 + 0.97058492221028 + 0.96658833436427 + 0.96201981032971 + 0.95678846784810 + 0.95081297122753 + 0.94401927331364 + 0.93633467639359 + 0.92769693749548 + 0.91805604484719 + 0.90737825851433 + 0.89565161165709 + 0.88289197160685 + 0.86914784523821 + 0.85449687814647 + 0.83903081906687 + 0.82288126624633 + 0.80625610105722 + 0.78940801673113 + 0.78097461857408 + 0.77257466353534 + 0.76422979477296 + 0.75595520799762 + 0.74775860287846 + 0.73963958976467 + 0.73158974194783 + 0.72359346995078 + 0.71562963425030 + 0.70766971149712 + 0.69961302695141 + 0.69117311934087 + 0.68220127050714 + 0.67268357880187 + 0.66260817332412 + 0.65200168472555 + 0.64090147443196 + 0.62935323020976 + 0.61740894160599 + 0.60512537625409 + 0.59256068398073 + 0.57973444291588 + 0.56670362846911 + 0.55352753909980 + 0.54026687971506 + 0.52698196954378 + 0.51372997823602 + 0.50054098381518 + 0.48742974095531 + 0.47441470718153 + 0.46149761328856 + 0.44866195679029 + 0.99819528885234 + 0.99819677483084 + 0.99819702199916 + 0.99819731044954 + 0.99819764714722 + 0.99819804026190 + 0.99819849938298 + 0.99819903582060 + 0.99819966315086 + 0.99820039891264 + 0.99820126958861 + 0.99820231523910 + 0.99820358401678 + 0.99820512932685 + 0.99820701409971 + 0.99820931503044 + 0.99821212649557 + 0.99821556498824 + 0.99821977960033 + 0.99822496166725 + 0.99823134499279 + 0.99823922435421 + 0.99824897346836 + 0.99826106979249 + 0.99827613279072 + 0.99829500191639 + 0.99831888295948 + 0.99834943831996 + 0.99838887741480 + 0.99844026405127 + 0.99850822407591 + 0.99859980609214 + 0.99872660085751 + 0.99890999846554 + 0.99919869187310 + 1.00000000000000 + 0.99910324678699 + 0.99863344866800 + 0.99821914855369 + 0.99781792120919 + 0.99740722670367 + 0.99697101215257 + 0.99649574726666 + 0.99596945125313 + 0.99538508188606 + 0.99474006498926 + 0.99402521973170 + 0.99323011448851 + 0.99235022650090 + 0.99137477702919 + 0.99028451475668 + 0.98905680018747 + 0.98766646247188 + 0.98608562542194 + 0.98428213466629 + 0.98222097173127 + 0.97986495279410 + 0.97717301229514 + 0.97409972145003 + 0.97059439252972 + 0.96659700669504 + 0.96202776913486 + 0.95679578094034 + 0.95081969717427 + 0.94402546427496 + 0.93634037837340 + 0.92770219120642 + 0.91806088621196 + 0.90738271909836 + 0.89565571915828 + 0.88289575037392 + 0.86915131694746 + 0.85450006234242 + 0.83903373343131 + 0.82288392777534 + 0.80625852766909 + 0.78941022755126 + 0.78097672867767 + 0.77257667786056 + 0.76423171817630 + 0.75595704519884 + 0.74776035839749 + 0.73964126788599 + 0.73159134667862 + 0.72359500498040 + 0.71563110293818 + 0.70767111682574 + 0.69961437087754 + 0.69117440128577 + 0.68220248879491 + 0.67268473190529 + 0.66260925990891 + 0.65200270394102 + 0.64090242597796 + 0.62935411437139 + 0.61740975925130 + 0.60512612880272 + 0.59256137334344 + 0.57973507121962 + 0.56670419820927 + 0.55352805309508 + 0.54026734106819 + 0.52698238161484 + 0.51373034459198 + 0.50054130812219 + 0.48743002691708 + 0.47441495853109 + 0.46149783370572 + 0.44866214981071 + 0.99799900441820 + 0.99800028187566 + 0.99800049438052 + 0.99800074238419 + 0.99800103187968 + 0.99800136989545 + 0.99800176468214 + 0.99800222597615 + 0.99800276546164 + 0.99800339819203 + 0.99800414682147 + 0.99800504550505 + 0.99800613532214 + 0.99800746189450 + 0.99800907898948 + 0.99801105213506 + 0.99801346190074 + 0.99801640768671 + 0.99802001651932 + 0.99802445119613 + 0.99802991026122 + 0.99803664337810 + 0.99804496600279 + 0.99805527934936 + 0.99806810100928 + 0.99808412774999 + 0.99810435308973 + 0.99813013077585 + 0.99816322660168 + 0.99820602996999 + 0.99826204487350 + 0.99833637132747 + 0.99843685824369 + 0.99857656395353 + 0.99877988518571 + 0.99910324678699 + 1.00000000000000 + 0.99899487001036 + 0.99846824282723 + 0.99800527162130 + 0.99755520830411 + 0.99709153990263 + 0.99659589892072 + 0.99605378875999 + 0.99545681666569 + 0.99480161691409 + 0.99407839368875 + 0.99327631023839 + 0.99239061071313 + 0.99141029732959 + 0.99031592184306 + 0.98908469799291 + 0.98769134534253 + 0.98610790327197 + 0.98430214910951 + 0.98223901122299 + 0.97988126428446 + 0.97718780825451 + 0.97411318556055 + 0.97060668377438 + 0.96660826043926 + 0.96203809464910 + 0.95680526593628 + 0.95082841748874 + 0.94403348759973 + 0.93634776456508 + 0.92770899340370 + 0.91806715142144 + 0.90738848876197 + 0.89566102971315 + 0.88290063393532 + 0.86915580215944 + 0.85450417507116 + 0.83903749707314 + 0.82288736478137 + 0.80626166159895 + 0.78941308341504 + 0.78097945486596 + 0.77257928079737 + 0.76423420414437 + 0.75595942029876 + 0.74776262845792 + 0.73964343842121 + 0.73159342283333 + 0.72359699148844 + 0.71563300410311 + 0.70767293645549 + 0.69961611146614 + 0.69117606203469 + 0.68220406749453 + 0.67268622654723 + 0.66261066871657 + 0.65200402576899 + 0.64090366039667 + 0.62935526170683 + 0.61741082058600 + 0.60512710594023 + 0.59256226872368 + 0.57973588756645 + 0.56670493872971 + 0.55352872142470 + 0.54026794121133 + 0.52698291790397 + 0.51373082163728 + 0.50054173065596 + 0.48743039972228 + 0.47441528642319 + 0.46149812143072 + 0.44866240192802 + 0.99777938870992 + 0.99778048686174 + 0.99778066956058 + 0.99778088279002 + 0.99778113170468 + 0.99778142235189 + 0.99778176183466 + 0.99778215853208 + 0.99778262250226 + 0.99778316667596 + 0.99778381042216 + 0.99778458284280 + 0.99778551895692 + 0.99778665771663 + 0.99778804506850 + 0.99778973698885 + 0.99779180229382 + 0.99779432582466 + 0.99779741591725 + 0.99780121125809 + 0.99780588076726 + 0.99781163646679 + 0.99781874556618 + 0.99782754678345 + 0.99783847519817 + 0.99785211349365 + 0.99786928777777 + 0.99789111355800 + 0.99791902511578 + 0.99795492702985 + 0.99800155132415 + 0.99806273965888 + 0.99814412603311 + 0.99825445001449 + 0.99840834269747 + 0.99863344866800 + 0.99899487001036 + 1.00000000000000 + 0.99887138458419 + 0.99828096880148 + 0.99776263432935 + 0.99725586182832 + 0.99673017346093 + 0.99616568463099 + 0.99555135982237 + 0.99488239039994 + 0.99414797373257 + 0.99333664310426 + 0.99244328598400 + 0.99145658891027 + 0.99035682974495 + 0.98912102125523 + 0.98772373463532 + 0.98613689608950 + 0.98432819213204 + 0.98226248091103 + 0.97990248253019 + 0.97720705179098 + 0.97413069347944 + 0.97062266288987 + 0.96662288673468 + 0.96205151006640 + 0.95681758434888 + 0.95083973749040 + 0.94404389736964 + 0.93635734229098 + 0.92771780867041 + 0.91807526597644 + 0.90739595716313 + 0.89566790005188 + 0.88290694870967 + 0.86916159932649 + 0.85450948894466 + 0.83904235870424 + 0.82289180389488 + 0.80626570924367 + 0.78941677237462 + 0.78098297670466 + 0.77258264386107 + 0.76423741659889 + 0.75596249003318 + 0.74776556301240 + 0.73964624490497 + 0.73159610785846 + 0.72359956114347 + 0.71563546390629 + 0.70767529128491 + 0.69961836450063 + 0.69117821219714 + 0.68220611188520 + 0.67268816251384 + 0.66261249391813 + 0.65200573868007 + 0.64090526041188 + 0.62935674920504 + 0.61741219692944 + 0.60512837341953 + 0.59256343046796 + 0.57973694706578 + 0.56670590011554 + 0.55352958938433 + 0.54026872091357 + 0.52698361494495 + 0.51373144197029 + 0.50054228039300 + 0.48743088502938 + 0.47441571351442 + 0.46149849642829 + 0.44866273070476 + 0.99753239116443 + 0.99753333593350 + 0.99753349313812 + 0.99753367661837 + 0.99753389081776 + 0.99753414094117 + 0.99753443311258 + 0.99753477455182 + 0.99753517392011 + 0.99753564234112 + 0.99753619638001 + 0.99753686084016 + 0.99753766557942 + 0.99753864388015 + 0.99753983501594 + 0.99754128684704 + 0.99754305819994 + 0.99754522157626 + 0.99754786950183 + 0.99755112031380 + 0.99755511805655 + 0.99756004328562 + 0.99756612316243 + 0.99757364492885 + 0.99758297639012 + 0.99759460819598 + 0.99760923291608 + 0.99762777944376 + 0.99765142939165 + 0.99768172973680 + 0.99772086326081 + 0.99777182130407 + 0.99783883773273 + 0.99792815848086 + 0.99804949013343 + 0.99821914855369 + 0.99846824282723 + 0.99887138458419 + 1.00000000000000 + 0.99873027854416 + 0.99806848706166 + 0.99748650922616 + 0.99691356693002 + 0.99631606365283 + 0.99567716330019 + 0.99498919816078 + 0.99423960226446 + 0.99341587520399 + 0.99251233320003 + 0.99151719179406 + 0.99041033804420 + 0.98916850375203 + 0.98776605573799 + 0.98617476621679 + 0.98436219946981 + 0.98229311990815 + 0.97993017520892 + 0.97723216051976 + 0.97415353105036 + 0.97064349965991 + 0.96664195257074 + 0.96206899020159 + 0.95683362735237 + 0.95085447213320 + 0.94405743907259 + 0.93636979361065 + 0.92772926114786 + 0.91808580103277 + 0.90740564693870 + 0.89567680828611 + 0.88291513183535 + 0.86916910784376 + 0.85451636855436 + 0.83904865075529 + 0.82289754787863 + 0.80627094621639 + 0.78942154545331 + 0.78098753385014 + 0.77258699596472 + 0.76424157429530 + 0.75596646356720 + 0.74776936215427 + 0.73964987884344 + 0.73159958514407 + 0.72360288961607 + 0.71563865066445 + 0.70767834260584 + 0.69962128445048 + 0.69118099933011 + 0.68220876239828 + 0.67269067291882 + 0.66261486113318 + 0.65200796067556 + 0.64090733636365 + 0.62935867955607 + 0.61741398340066 + 0.60513001894316 + 0.59256493905611 + 0.57973832322178 + 0.56670714916847 + 0.55353071738823 + 0.54026973456060 + 0.52698452147534 + 0.51373224908813 + 0.50054299600015 + 0.48743151709843 + 0.47441627007324 + 0.46149898537101 + 0.44866315961477 + 0.99725292631983 + 0.99725374023296 + 0.99725387568185 + 0.99725403377987 + 0.99725421835493 + 0.99725443390223 + 0.99725468570018 + 0.99725497997716 + 0.99725532421193 + 0.99725572797684 + 0.99725620545937 + 0.99725677782216 + 0.99725747054933 + 0.99725831210003 + 0.99725933608866 + 0.99726058348142 + 0.99726210462656 + 0.99726396158049 + 0.99726623349004 + 0.99726902151689 + 0.99727244877155 + 0.99727666944493 + 0.99728187727966 + 0.99728831687000 + 0.99729630069355 + 0.99730624439586 + 0.99731873267072 + 0.99733454591180 + 0.99735466912834 + 0.99738037855015 + 0.99741345330884 + 0.99745628598363 + 0.99751217658978 + 0.99758582119603 + 0.99768414701902 + 0.99781792120919 + 0.99800527162130 + 0.99828096880148 + 0.99873027854416 + 1.00000000000000 + 0.99856976901222 + 0.99782722874592 + 0.99717147606427 + 0.99652199925022 + 0.99584681152339 + 0.99513188516165 + 0.99436127751770 + 0.99352067069134 + 0.99260341356732 + 0.99159698736570 + 0.99048070270446 + 0.98923088777302 + 0.98782162141588 + 0.98622446228558 + 0.98440680750579 + 0.98233329450410 + 0.97996647367484 + 0.97726506050498 + 0.97418344430173 + 0.97067078165242 + 0.96666690525186 + 0.96209185661903 + 0.95685460238755 + 0.95087372489795 + 0.94407512140661 + 0.93638604073406 + 0.92774419406818 + 0.91809952765701 + 0.90741826308448 + 0.89568839880992 + 0.88292577203173 + 0.86917886520003 + 0.85452530420098 + 0.83905681999003 + 0.82290500340444 + 0.80627774255578 + 0.78942773955418 + 0.78099344790145 + 0.77259264424108 + 0.76424697069795 + 0.75597162146574 + 0.74777429425919 + 0.73965459709883 + 0.73160410063030 + 0.72360721248272 + 0.71564279009316 + 0.70768230669267 + 0.69962507842610 + 0.69118462127156 + 0.68221220730597 + 0.67269393620937 + 0.66261793875012 + 0.65201084993409 + 0.64091003613900 + 0.62936119038182 + 0.61741630746700 + 0.60513216002155 + 0.59256690233047 + 0.57974011451295 + 0.56670877538270 + 0.55353218638306 + 0.54027105502382 + 0.52698570280781 + 0.51373330128953 + 0.50054392932016 + 0.48743234186917 + 0.47441699668767 + 0.46149962405342 + 0.44866372016904 + 0.99693521339580 + 0.99693591585957 + 0.99693603277910 + 0.99693616925093 + 0.99693632858842 + 0.99693651467206 + 0.99693673206370 + 0.99693698615353 + 0.99693728339683 + 0.99693763204975 + 0.99693804428823 + 0.99693853819352 + 0.99693913555652 + 0.99693986075677 + 0.99694074260604 + 0.99694181622560 + 0.99694312478680 + 0.99694472149443 + 0.99694667417199 + 0.99694906949765 + 0.99695201292525 + 0.99695563648092 + 0.99696010592849 + 0.99696563030629 + 0.99697247625899 + 0.99698099771008 + 0.99699169124875 + 0.99700521735375 + 0.99702240516173 + 0.99704432091198 + 0.99707243812674 + 0.99710871160389 + 0.99715578800600 + 0.99721733876113 + 0.99729858622902 + 0.99740722670367 + 0.99755520830411 + 0.99776263432935 + 0.99806848706166 + 0.99856976901222 + 1.00000000000000 + 0.99838710349981 + 0.99755252588778 + 0.99681186381079 + 0.99607958838251 + 0.99532482748077 + 0.99452433075578 + 0.99366028423987 + 0.99272428287729 + 0.99170259959742 + 0.99057365909647 + 0.98931319029970 + 0.98789485502820 + 0.98628990886053 + 0.98446551587662 + 0.98238613872672 + 0.98001419515772 + 0.97730829299327 + 0.97422273298862 + 0.97070659648598 + 0.96669964486581 + 0.96212184153768 + 0.95688208949771 + 0.95089893731294 + 0.94409825978913 + 0.93640728417624 + 0.92776370316201 + 0.91811744596653 + 0.90743471837831 + 0.89570350447779 + 0.88293962886968 + 0.86919156370923 + 0.85453692641955 + 0.83906744011558 + 0.82291469198098 + 0.80628657218815 + 0.78943578566496 + 0.78100113005218 + 0.77259998119472 + 0.76425398067305 + 0.75597832195611 + 0.74778070185310 + 0.73966072735694 + 0.73160996795773 + 0.72361283005696 + 0.71564816982061 + 0.70768745906614 + 0.69963001020277 + 0.69118932989114 + 0.68221668621592 + 0.67269817940429 + 0.66262194091194 + 0.65201460752623 + 0.64091354766234 + 0.62936445649519 + 0.61741933098510 + 0.60513494581605 + 0.59256945712141 + 0.57974244584882 + 0.56671089223743 + 0.55353409897357 + 0.54027277464823 + 0.52698724169129 + 0.51373467242467 + 0.50054514601726 + 0.48743341752644 + 0.47441794477621 + 0.46150045780923 + 0.44866445228059 + 0.99657241329557 + 0.99657302076538 + 0.99657312188562 + 0.99657323992028 + 0.99657337773667 + 0.99657353869422 + 0.99657372674594 + 0.99657394655229 + 0.99657420370600 + 0.99657450534015 + 0.99657486192228 + 0.99657528893823 + 0.99657580505547 + 0.99657643119845 + 0.99657719211071 + 0.99657811795598 + 0.99657924582272 + 0.99658062140404 + 0.99658230294675 + 0.99658436485304 + 0.99658689767119 + 0.99659001470791 + 0.99659385818308 + 0.99659860730480 + 0.99660449044990 + 0.99661181026399 + 0.99662099056374 + 0.99663259368506 + 0.99664732293891 + 0.99666607803051 + 0.99669009466282 + 0.99672099638831 + 0.99676095268816 + 0.99681291953839 + 0.99688099691039 + 0.99697101215257 + 0.99709153990263 + 0.99725586182832 + 0.99748650922616 + 0.99782722874592 + 0.99838710349981 + 1.00000000000000 + 0.99817914705663 + 0.99724008291975 + 0.99640768132585 + 0.99559024681948 + 0.99474549853380 + 0.99384799842628 + 0.99288586422844 + 0.99184323807769 + 0.99069710896381 + 0.98942227751300 + 0.98799178024420 + 0.98637642995256 + 0.98454305788523 + 0.98245588098310 + 0.98007713285222 + 0.97736527352889 + 0.97427448322281 + 0.97075374152497 + 0.96674271401186 + 0.96216125976540 + 0.95691819721769 + 0.95093203038832 + 0.94412860467997 + 0.93643511910028 + 0.92778924220056 + 0.91814088089004 + 0.90745622020609 + 0.89572322528230 + 0.88295770409094 + 0.86920811512415 + 0.85455206448242 + 0.83908126469519 + 0.82292729777287 + 0.80629805618265 + 0.78944624803405 + 0.78101111839227 + 0.77260952022434 + 0.76426309434781 + 0.75598703321616 + 0.74778903242346 + 0.73966869755824 + 0.73161759658498 + 0.72362013427311 + 0.71565516511149 + 0.70769415906715 + 0.69963642367625 + 0.69119545346862 + 0.68222251133371 + 0.67270369820724 + 0.66262714644277 + 0.65201949516663 + 0.64091811544176 + 0.62936870525037 + 0.61742326437112 + 0.60513857016908 + 0.59257278117366 + 0.57974547943295 + 0.56671364704368 + 0.55353658831280 + 0.54027501323900 + 0.52698924545458 + 0.51373645826186 + 0.50054673122816 + 0.48743481950808 + 0.47441918099908 + 0.46150154542151 + 0.44866540770542 + 0.99615658820653 + 0.99615711445996 + 0.99615720206879 + 0.99615730433484 + 0.99615742374637 + 0.99615756321009 + 0.99615772615689 + 0.99615791663071 + 0.99615813947219 + 0.99615840086321 + 0.99615870981810 + 0.99615907962955 + 0.99615952632635 + 0.99616006789238 + 0.99616072562043 + 0.99616152546466 + 0.99616249932792 + 0.99616368653416 + 0.99616513717791 + 0.99616691524533 + 0.99616909861766 + 0.99617178473885 + 0.99617509588344 + 0.99617918607613 + 0.99618425144226 + 0.99619055162978 + 0.99619844969367 + 0.99620842655357 + 0.99622108225799 + 0.99623718165432 + 0.99625777074863 + 0.99628421460677 + 0.99631832063852 + 0.99636252093082 + 0.99642013067367 + 0.99649574726666 + 0.99659589892072 + 0.99673017346093 + 0.99691356693002 + 0.99717147606427 + 0.99755252588778 + 0.99817914705663 + 1.00000000000000 + 0.99794382255007 + 0.99689253544145 + 0.99596515838695 + 0.99505065525346 + 0.99410345362639 + 0.99310385995773 + 0.99203189564507 + 0.99086205525053 + 0.98956762055067 + 0.98812064797083 + 0.98649127920751 + 0.98464585536138 + 0.98254823876644 + 0.98016040145662 + 0.97744059662656 + 0.97434283769093 + 0.97081596477881 + 0.96679951334714 + 0.96221320203412 + 0.95696573610728 + 0.95097556033299 + 0.94416848128722 + 0.93647166074237 + 0.92782273548826 + 0.91817158303191 + 0.90748436100839 + 0.89574900946238 + 0.88298131428594 + 0.86922971574913 + 0.85457180473075 + 0.83909927938208 + 0.82294371439674 + 0.80631300463435 + 0.78945986170505 + 0.78102411346458 + 0.77262192935520 + 0.76427494911220 + 0.75599836379073 + 0.74779986731231 + 0.73967906339314 + 0.73162751794437 + 0.72362963358039 + 0.71566426257510 + 0.70770287246486 + 0.69964476442779 + 0.69120341717036 + 0.68223008680440 + 0.67271087521445 + 0.66263391593525 + 0.65202585113478 + 0.64092405534624 + 0.62937423021360 + 0.61742837917549 + 0.60514328309451 + 0.59257710363174 + 0.57974942426111 + 0.56671722950523 + 0.55353982579102 + 0.54027792493631 + 0.52699185212997 + 0.51373878193186 + 0.50054879438689 + 0.48743664475866 + 0.47442079100377 + 0.46150296240184 + 0.44866665292578 + 0.99567933032360 + 0.99567978687190 + 0.99567986288008 + 0.99567995160911 + 0.99568005520987 + 0.99568017621588 + 0.99568031760140 + 0.99568048287500 + 0.99568067624459 + 0.99568090305878 + 0.99568117109985 + 0.99568149180496 + 0.99568187895623 + 0.99568234805379 + 0.99568291743731 + 0.99568360947774 + 0.99568445165589 + 0.99568547786039 + 0.99568673124283 + 0.99568826690940 + 0.99569015194017 + 0.99569247027146 + 0.99569532719850 + 0.99569885533245 + 0.99570322347491 + 0.99570865489304 + 0.99571546143427 + 0.99572405574581 + 0.99573495191866 + 0.99574880368496 + 0.99576650247982 + 0.99578920630461 + 0.99581843874122 + 0.99585623240935 + 0.99590532520521 + 0.99596945125313 + 0.99605378875999 + 0.99616568463099 + 0.99631606365283 + 0.99652199925022 + 0.99681186381079 + 0.99724008291975 + 0.99794382255007 + 1.00000000000000 + 0.99768771800134 + 0.99651920405222 + 0.99548222519307 + 0.99445649079995 + 0.99340105180755 + 0.99228686531322 + 0.99108367092782 + 0.98976208466074 + 0.98829253916669 + 0.98664411204949 + 0.98478239530492 + 0.98267072303413 + 0.98027068545665 + 0.97754023952504 + 0.97443316343869 + 0.97089810315444 + 0.96687441532767 + 0.96228162804425 + 0.95702829407001 + 0.95103277872437 + 0.94422083675198 + 0.93651958043007 + 0.92786660442265 + 0.91821174725344 + 0.90752113016033 + 0.89578265980312 + 0.88301209264920 + 0.86925784454534 + 0.85459748580168 + 0.83912269496916 + 0.82296503629587 + 0.80633240688091 + 0.78947752194217 + 0.78104096741791 + 0.77263802016540 + 0.76429031839253 + 0.75601305122500 + 0.74781391032539 + 0.73969249687231 + 0.73164037406003 + 0.72364194162945 + 0.71567604895018 + 0.70771416036239 + 0.69965556876200 + 0.69121373226253 + 0.68223989818551 + 0.67272016965737 + 0.66264268177041 + 0.65203408066684 + 0.64093174537537 + 0.62938138231269 + 0.61743499966970 + 0.60514938284247 + 0.59258269755028 + 0.57975452911673 + 0.56672186521793 + 0.55354401501170 + 0.54028169267468 + 0.52699522538153 + 0.51374178928286 + 0.50055146501211 + 0.48743900791762 + 0.47442287599712 + 0.46150479792630 + 0.44866826640711 + 0.99513573589840 + 0.99513613259421 + 0.99513619864123 + 0.99513627574086 + 0.99513636576650 + 0.99513647091960 + 0.99513659378101 + 0.99513673740256 + 0.99513690544228 + 0.99513710254153 + 0.99513733543023 + 0.99513761397799 + 0.99513795007996 + 0.99513835711076 + 0.99513885091658 + 0.99513945080821 + 0.99514018053037 + 0.99514106933172 + 0.99514215447132 + 0.99514348351512 + 0.99514511435913 + 0.99514711946730 + 0.99514958970883 + 0.99515263953806 + 0.99515641457532 + 0.99516110734912 + 0.99516698652008 + 0.99517440738093 + 0.99518381215242 + 0.99519576231403 + 0.99521102205252 + 0.99523058099932 + 0.99525573561938 + 0.99528820544728 + 0.99533028802267 + 0.99538508188606 + 0.99545681666569 + 0.99555135982237 + 0.99567716330019 + 0.99584681152339 + 0.99607958838251 + 0.99640768132585 + 0.99689253544145 + 0.99768771800134 + 1.00000000000000 + 0.99741873037310 + 0.99611447552674 + 0.99495172423212 + 0.99380847047409 + 0.99263158341513 + 0.99138056180757 + 0.99002092663785 + 0.98852024520909 + 0.98684582387096 + 0.98496206529235 + 0.98283149197403 + 0.98041512233011 + 0.97767048048472 + 0.97455100774344 + 0.97100507671614 + 0.96697179692222 + 0.96237043799380 + 0.95710934754864 + 0.95110678376768 + 0.94428843154436 + 0.93658133688163 + 0.92792303825074 + 0.91826332228864 + 0.90756826183744 + 0.89582571916630 + 0.88305141149796 + 0.86929372191928 + 0.85463019284592 + 0.83915247600316 + 0.82299212056531 + 0.80635702489405 + 0.78949990720913 + 0.78106232098563 + 0.77265839821712 + 0.76430977499554 + 0.75603163783475 + 0.74783167536962 + 0.73970948543848 + 0.73165662764620 + 0.72365749801386 + 0.71569094212881 + 0.70772842020873 + 0.69966921456317 + 0.69122675709939 + 0.68225228397886 + 0.67273189993643 + 0.66265374205953 + 0.65204446154573 + 0.64094144315060 + 0.62939039932488 + 0.61744334426735 + 0.60515706910010 + 0.59258974465715 + 0.57976095858078 + 0.56672770250233 + 0.55354928902123 + 0.54028643524367 + 0.52699947080614 + 0.51374557381681 + 0.50055482558635 + 0.48744198151564 + 0.47442549959712 + 0.46150710768916 + 0.44867029685344 + 0.99452464848497 + 0.99452499384901 + 0.99452505134970 + 0.99452511847241 + 0.99452519684995 + 0.99452528839531 + 0.99452539535814 + 0.99452552039710 + 0.99452566669204 + 0.99452583827885 + 0.99452604100347 + 0.99452628341595 + 0.99452657581541 + 0.99452692979949 + 0.99452735909497 + 0.99452788044508 + 0.99452851442251 + 0.99452928636910 + 0.99453022856541 + 0.99453138221045 + 0.99453279746464 + 0.99453453708320 + 0.99453667978807 + 0.99453932469712 + 0.99454259790598 + 0.99454666607298 + 0.99455176166033 + 0.99455819195555 + 0.99456633924036 + 0.99457668837960 + 0.99458989854651 + 0.99460682159933 + 0.99462857028031 + 0.99465661461718 + 0.99469290801891 + 0.99474006498926 + 0.99480161691409 + 0.99488239039994 + 0.99498919816078 + 0.99513188516165 + 0.99532482748077 + 0.99559024681948 + 0.99596515838695 + 0.99651920405222 + 0.99741873037310 + 1.00000000000000 + 0.99712261278671 + 0.99566536017159 + 0.99437092115264 + 0.99309652987252 + 0.99177521655845 + 0.99036158551804 + 0.98881773731337 + 0.98710785928725 + 0.98519438524373 + 0.98303854992710 + 0.98060049363009 + 0.97783709624368 + 0.97470131019473 + 0.97114112014268 + 0.96709529335050 + 0.96248275104536 + 0.95721156689504 + 0.95119985429540 + 0.94437320298607 + 0.93665856978664 + 0.92799341786335 + 0.91832746472582 + 0.90762671901795 + 0.89587898417031 + 0.88309992530762 + 0.86933788159999 + 0.85467035756465 + 0.83918896827168 + 0.82302524094088 + 0.80638707245165 + 0.78952718193224 + 0.78108831743059 + 0.77268318775378 + 0.76433342612920 + 0.75605421561184 + 0.74785324090131 + 0.73973009553582 + 0.73167633454392 + 0.72367634921235 + 0.71570898034396 + 0.70774568299169 + 0.69968572637328 + 0.69124251029003 + 0.68226725726558 + 0.67274607402982 + 0.66266710013564 + 0.65205699294999 + 0.64095314419170 + 0.62940127363080 + 0.61745340273785 + 0.60516632952680 + 0.59259823097526 + 0.57976869746631 + 0.56673472535528 + 0.55355563132841 + 0.54029213596506 + 0.52700457178459 + 0.51375011917852 + 0.50055886019300 + 0.48744555021528 + 0.47442864716224 + 0.46150987784361 + 0.44867273128899 + 0.99383829582439 + 0.99383859689102 + 0.99383864701571 + 0.99383870552913 + 0.99383877385014 + 0.99383885364978 + 0.99383894688806 + 0.99383905588206 + 0.99383918340254 + 0.99383933296738 + 0.99383950966008 + 0.99383972091620 + 0.99383997569501 + 0.99384028407910 + 0.99384065800567 + 0.99384111203177 + 0.99384166403787 + 0.99384233605748 + 0.99384315614481 + 0.99384416011171 + 0.99384539155317 + 0.99384690501323 + 0.99384876889813 + 0.99385106933622 + 0.99385391589851 + 0.99385745336748 + 0.99386188367353 + 0.99386747371452 + 0.99387455537676 + 0.99388354933845 + 0.99389502716272 + 0.99390972643499 + 0.99392860873407 + 0.99395294096419 + 0.99398440028445 + 0.99402521973170 + 0.99407839368875 + 0.99414797373257 + 0.99423960226446 + 0.99436127751770 + 0.99452433075578 + 0.99474549853380 + 0.99505065525346 + 0.99548222519307 + 0.99611447552674 + 0.99712261278671 + 1.00000000000000 + 0.99679500296880 + 0.99517752060028 + 0.99373565357082 + 0.99230512381331 + 0.99081218494419 + 0.98920713236136 + 0.98744815974359 + 0.98549422049629 + 0.98330439781728 + 0.98083742575382 + 0.97804919191871 + 0.97489191940211 + 0.97131302994474 + 0.96725080910474 + 0.96262370401054 + 0.95733941982536 + 0.95131587206535 + 0.94447851916908 + 0.93675419668421 + 0.92808026597889 + 0.91840635183246 + 0.90769837732988 + 0.89594406772784 + 0.88315901876074 + 0.86939151060420 + 0.85471899619668 + 0.83923304053477 + 0.82306513900978 + 0.80642318217018 + 0.78955988615086 + 0.78111945603519 + 0.77271285072728 + 0.76436169960996 + 0.75608118120223 + 0.74787897512655 + 0.73975466942011 + 0.73169981332733 + 0.72369879215662 + 0.71573044072803 + 0.70776620763895 + 0.69970534615749 + 0.69126121729710 + 0.68228502718902 + 0.67276288499877 + 0.66268293324834 + 0.65207183672732 + 0.64096699547385 + 0.62941413797010 + 0.61746529430642 + 0.60517727063765 + 0.59260825115609 + 0.57977782940080 + 0.56674300723415 + 0.55356310606947 + 0.54029885048673 + 0.52701057631234 + 0.51375546651062 + 0.50056360389928 + 0.48744974374642 + 0.47443234378545 + 0.46151312950455 + 0.44867558745549 + 0.99306727113832 + 0.99306753383019 + 0.99306757756212 + 0.99306762861455 + 0.99306768822326 + 0.99306775784457 + 0.99306783918864 + 0.99306793427697 + 0.99306804552694 + 0.99306817600416 + 0.99306833014337 + 0.99306851443660 + 0.99306873670145 + 0.99306900572911 + 0.99306933193375 + 0.99306972801206 + 0.99307020955078 + 0.99307079576782 + 0.99307151112079 + 0.99307238684632 + 0.99307346095262 + 0.99307478099411 + 0.99307640661831 + 0.99307841291984 + 0.99308089541059 + 0.99308398032073 + 0.99308784373302 + 0.99309271839617 + 0.99309889363032 + 0.99310673598349 + 0.99311674336602 + 0.99312955769774 + 0.99314601470228 + 0.99316721343060 + 0.99319460500362 + 0.99323011448851 + 0.99327631023839 + 0.99333664310426 + 0.99341587520399 + 0.99352067069134 + 0.99366028423987 + 0.99384799842628 + 0.99410345362639 + 0.99445649079995 + 0.99495172423212 + 0.99566536017159 + 0.99679500296880 + 1.00000000000000 + 0.99644808837930 + 0.99464915201277 + 0.99303108920910 + 0.99141491412756 + 0.98971998093886 + 0.98789144139614 + 0.98588153119937 + 0.98364549257069 + 0.98113968693161 + 0.97831840773743 + 0.97513275197103 + 0.97152930168575 + 0.96744565003380 + 0.96279958983479 + 0.95749832499915 + 0.95145949678674 + 0.94460837978166 + 0.93687164271707 + 0.92818650794358 + 0.91850247495816 + 0.90778535212775 + 0.89602276043465 + 0.88323020294268 + 0.86945588037737 + 0.85477717548297 + 0.83928558488896 + 0.82311255825213 + 0.80646597194399 + 0.78959853262423 + 0.78115620383064 + 0.77274781264820 + 0.76439498331909 + 0.75611288845759 + 0.74790920116893 + 0.73978350251767 + 0.73172733443509 + 0.72372507477463 + 0.71575555087157 + 0.70779020333398 + 0.69972826618999 + 0.69128305423573 + 0.68230575414732 + 0.67278247802045 + 0.66270137192596 + 0.65208910940046 + 0.64098310026173 + 0.62942908319062 + 0.61747909830540 + 0.60518996118571 + 0.59261986431636 + 0.57978840476513 + 0.56675259065472 + 0.55357174874500 + 0.54030660810193 + 0.52701750822310 + 0.51376163491577 + 0.50056907173757 + 0.48745457368825 + 0.47443659817647 + 0.46151686904582 + 0.44867886986962 + 0.99220766025125 + 0.99220788976446 + 0.99220792797149 + 0.99220797256976 + 0.99220802464387 + 0.99220808546609 + 0.99220815652735 + 0.99220823958875 + 0.99220833676534 + 0.99220845073590 + 0.99220858538168 + 0.99220874639170 + 0.99220894062269 + 0.99220917576716 + 0.99220946095149 + 0.99220980728725 + 0.99221022842342 + 0.99221074118910 + 0.99221136700611 + 0.99221213322937 + 0.99221307315445 + 0.99221422842588 + 0.99221565128286 + 0.99221740748980 + 0.99221958069468 + 0.99222228145860 + 0.99222566413107 + 0.99222993275662 + 0.99223534089197 + 0.99224220963676 + 0.99225097521401 + 0.99226219964086 + 0.99227661391684 + 0.99229517810971 + 0.99231915755219 + 0.99235022650090 + 0.99239061071313 + 0.99244328598400 + 0.99251233320003 + 0.99260341356732 + 0.99272428287729 + 0.99288586422844 + 0.99310385995773 + 0.99340105180755 + 0.99380847047409 + 0.99437092115264 + 0.99517752060028 + 0.99644808837930 + 1.00000000000000 + 0.99606803504625 + 0.99405472168601 + 0.99222906548806 + 0.99039582988760 + 0.98846614919506 + 0.98637774792658 + 0.98407846598840 + 0.98152043430250 + 0.97865527710155 + 0.97543229726951 + 0.97179679446481 + 0.96768535036550 + 0.96301484804923 + 0.95769180658942 + 0.95163348331140 + 0.94476489226047 + 0.93701247089449 + 0.92831325061002 + 0.91861656109099 + 0.90788805697487 + 0.89611522034359 + 0.88331343086899 + 0.86953078265216 + 0.85484456331118 + 0.83934617690966 + 0.82316700805520 + 0.80651490638390 + 0.78964255855151 + 0.78119798976826 + 0.77278749735169 + 0.76443269879696 + 0.75614875914962 + 0.74794334329336 + 0.73981602358322 + 0.73175833292287 + 0.72375463997201 + 0.71578376290395 + 0.70781713262112 + 0.69975396062014 + 0.69130750849851 + 0.68232894066923 + 0.67280437257787 + 0.66272195432817 + 0.65210836937317 + 0.64100103853315 + 0.62944571189821 + 0.61749444073584 + 0.60520405102028 + 0.59263274431262 + 0.57980012135852 + 0.56676319702085 + 0.55358130376005 + 0.54031517538643 + 0.52702515525102 + 0.51376843209825 + 0.50057509012167 + 0.48745988386765 + 0.47444127023300 + 0.46152097110574 + 0.44868246662629 + 0.99124932359317 + 0.99124952441095 + 0.99124955783903 + 0.99124959685892 + 0.99124964241587 + 0.99124969562492 + 0.99124975778928 + 0.99124983044858 + 0.99124991545162 + 0.99125001514388 + 0.99125013293583 + 0.99125027383809 + 0.99125044387824 + 0.99125064983394 + 0.99125089972503 + 0.99125120332427 + 0.99125157263721 + 0.99125202245659 + 0.99125257163698 + 0.99125324425425 + 0.99125406960800 + 0.99125508434646 + 0.99125633443873 + 0.99125787775549 + 0.99125978790718 + 0.99126216224391 + 0.99126513678742 + 0.99126889144284 + 0.99127364966759 + 0.99127969431611 + 0.99128740982795 + 0.99129729122632 + 0.99130998192643 + 0.99132632621730 + 0.99134743535788 + 0.99137477702919 + 0.99141029732959 + 0.99145658891027 + 0.99151719179406 + 0.99159698736570 + 0.99170259959742 + 0.99184323807769 + 0.99203189564507 + 0.99228686531322 + 0.99263158341513 + 0.99309652987252 + 0.99373565357082 + 0.99464915201277 + 0.99606803504625 + 1.00000000000000 + 0.99563273697780 + 0.99336941536035 + 0.99130257173040 + 0.98921812381479 + 0.98701621985040 + 0.98462872144043 + 0.98199960239164 + 0.97907575110621 + 0.97580348173310 + 0.97212606575479 + 0.96797856635585 + 0.96327657646100 + 0.95792566459897 + 0.95184254194145 + 0.94495184825153 + 0.93717969697308 + 0.92846285502695 + 0.91875042062149 + 0.90800784153457 + 0.89622241448708 + 0.88340935481072 + 0.86961661370680 + 0.85492135046927 + 0.83941484467498 + 0.82322838977564 + 0.80656979041082 + 0.78969169784486 + 0.78124452045510 + 0.77283158896853 + 0.76447451208675 + 0.75618844518454 + 0.74798104282870 + 0.73985186656516 + 0.73179243816798 + 0.72378711503784 + 0.71581470417917 + 0.70784662477225 + 0.69978206230175 + 0.69133421830542 + 0.68235423218267 + 0.67282822310143 + 0.66274434561804 + 0.65212929410875 + 0.64102050144983 + 0.62946373012369 + 0.61751104342706 + 0.60521927844188 + 0.59264664630187 + 0.57981275140205 + 0.56677461557209 + 0.55359157710600 + 0.54032437461265 + 0.52703335529913 + 0.51377571082190 + 0.50058152581670 + 0.48746555413943 + 0.47444625196081 + 0.46152533888657 + 0.44868629119243 + 0.99017361871697 + 0.99017379466389 + 0.99017382394882 + 0.99017385813130 + 0.99017389804160 + 0.99017394465113 + 0.99017399910369 + 0.99017406275019 + 0.99017413720276 + 0.99017422452047 + 0.99017432771190 + 0.99017445119745 + 0.99017460031519 + 0.99017478104669 + 0.99017500046870 + 0.99017526720806 + 0.99017559186768 + 0.99017598750892 + 0.99017647078500 + 0.99017706298652 + 0.99017779000005 + 0.99017868422044 + 0.99017978627397 + 0.99018114731058 + 0.99018283239452 + 0.99018492762825 + 0.99018755348374 + 0.99019086938345 + 0.99019507323273 + 0.99020041544455 + 0.99020723656766 + 0.99021597490729 + 0.99022719986331 + 0.99024165809772 + 0.99026033142334 + 0.99028451475668 + 0.99031592184306 + 0.99035682974495 + 0.99041033804420 + 0.99048070270446 + 0.99057365909647 + 0.99069710896381 + 0.99086205525053 + 0.99108367092782 + 0.99138056180757 + 0.99177521655845 + 0.99230512381331 + 0.99303108920910 + 0.99405472168601 + 0.99563273697780 + 1.00000000000000 + 0.99512935189023 + 0.99257564093641 + 0.99022969600421 + 0.98785389927794 + 0.98533862983945 + 0.98261016657065 + 0.97960625823957 + 0.97626791012938 + 0.97253501789207 + 0.96834026683217 + 0.96359735485790 + 0.95821049161242 + 0.95209559212279 + 0.94517674851208 + 0.93737961300567 + 0.92864058142469 + 0.91890843290356 + 0.90814833429310 + 0.89634733305097 + 0.88352042435844 + 0.86971536744155 + 0.85500914860364 + 0.83949288038326 + 0.82329773004103 + 0.80663143198734 + 0.78974658080270 + 0.78129635095052 + 0.77288057554529 + 0.76452085177952 + 0.75623232264598 + 0.74802262962993 + 0.73989132074420 + 0.73182990392989 + 0.72382272266974 + 0.71584857023513 + 0.70787885153458 + 0.69981272188949 + 0.69136331494789 + 0.68238174196603 + 0.67285412620714 + 0.66276862708168 + 0.65215195095124 + 0.64104154381933 + 0.62948318155593 + 0.61752894031863 + 0.60523566894945 + 0.59266158858560 + 0.57982630709355 + 0.56678685340258 + 0.55360257166500 + 0.54033420523608 + 0.52704210510254 + 0.51378346570127 + 0.50058837185815 + 0.48747157642889 + 0.47445153458573 + 0.46152996327880 + 0.44869033442607 + 0.98895837278315 + 0.98895852715491 + 0.98895855284562 + 0.98895858283414 + 0.98895861784534 + 0.98895865873190 + 0.98895870649564 + 0.98895876231960 + 0.98895882762045 + 0.98895890420609 + 0.98895899473477 + 0.98895910312486 + 0.98895923411567 + 0.98895939300813 + 0.98895958607011 + 0.98895982094329 + 0.98896010702148 + 0.98896045587742 + 0.98896088228732 + 0.98896140514040 + 0.98896204740906 + 0.98896283783256 + 0.98896381246331 + 0.98896501668956 + 0.98896650825438 + 0.98896836362633 + 0.98897068998211 + 0.98897362923009 + 0.98897735742767 + 0.98898209724854 + 0.98898815173311 + 0.98899591076585 + 0.98900588059888 + 0.98901872475354 + 0.98903531507010 + 0.98905680018747 + 0.98908469799291 + 0.98912102125523 + 0.98916850375203 + 0.98923088777302 + 0.98931319029970 + 0.98942227751300 + 0.98956762055067 + 0.98976208466074 + 0.99002092663785 + 0.99036158551804 + 0.99081218494419 + 0.99141491412756 + 0.99222906548806 + 0.99336941536035 + 0.99512935189023 + 1.00000000000000 + 0.99454613669705 + 0.99165570747731 + 0.98898564879451 + 0.98627416659797 + 0.98340141509112 + 0.98028528437649 + 0.97685651158905 + 0.97304899319333 + 0.96879148763382 + 0.96399478234768 + 0.95856107058661 + 0.95240507180723 + 0.94545005853048 + 0.93762101354400 + 0.92885380348150 + 0.91909676158363 + 0.90831466869004 + 0.89649423383804 + 0.88365015514573 + 0.86982993285399 + 0.85511031977219 + 0.83958220437565 + 0.82337658056937 + 0.80670107805869 + 0.78980820555709 + 0.78135437356144 + 0.77293525484767 + 0.76457243149114 + 0.75628103045198 + 0.74806867654785 + 0.73993490064699 + 0.73187119330695 + 0.72386188063435 + 0.71588573882029 + 0.70791415521055 + 0.69984624986535 + 0.69139507925458 + 0.68241172277365 + 0.67288230813028 + 0.66279500001452 + 0.65217651791888 + 0.64106432211289 + 0.62950420288681 + 0.61754825011805 + 0.60525332501722 + 0.59267765907457 + 0.57984086334034 + 0.56679997386811 + 0.55361434058419 + 0.54034471145483 + 0.52705144105528 + 0.51379172640490 + 0.50059565216097 + 0.48747796979548 + 0.47445713313232 + 0.46153485601103 + 0.44869460541889 + 0.98757877208106 + 0.98757890773513 + 0.98757893030869 + 0.98757895665807 + 0.98757898741842 + 0.98757902334023 + 0.98757906530227 + 0.98757911434315 + 0.98757917170580 + 0.98757923898512 + 0.98757931852734 + 0.98757941383329 + 0.98757952911288 + 0.98757966908225 + 0.98757983930656 + 0.98758004658715 + 0.98758029926616 + 0.98758060764987 + 0.98758098487480 + 0.98758144777555 + 0.98758201680793 + 0.98758271756560 + 0.98758358216385 + 0.98758465102074 + 0.98758597558303 + 0.98758762402318 + 0.98758969207972 + 0.98759230659132 + 0.98759562483197 + 0.98759984558957 + 0.98760523966206 + 0.98761215527745 + 0.98762104443871 + 0.98763249930573 + 0.98764729746229 + 0.98766646247188 + 0.98769134534253 + 0.98772373463532 + 0.98776605573799 + 0.98782162141588 + 0.98789485502820 + 0.98799178024420 + 0.98812064797083 + 0.98829253916669 + 0.98852024520909 + 0.98881773731337 + 0.98920713236136 + 0.98971998093886 + 0.99039582988760 + 0.99130257173040 + 0.99257564093641 + 0.99454613669705 + 1.00000000000000 + 0.99386996767069 + 0.99058757510639 + 0.98754355091656 + 0.98444871211389 + 0.98116914910527 + 0.97761324573113 + 0.97370328772125 + 0.96936110195399 + 0.96449275346833 + 0.95899730556040 + 0.95278761767305 + 0.94578570192242 + 0.93791554667840 + 0.92911224919249 + 0.91932350941921 + 0.90851357058409 + 0.89666867715317 + 0.88380312302547 + 0.86996405713721 + 0.85522791639131 + 0.83968528833471 + 0.82346692995380 + 0.80678031909201 + 0.78987783878426 + 0.78141971772407 + 0.77299663398082 + 0.76463014969902 + 0.75633537100288 + 0.74811990122031 + 0.73998324932978 + 0.73191688383013 + 0.72390510889374 + 0.71592667925379 + 0.70795296041995 + 0.69988303085013 + 0.69142985869643 + 0.68244448702744 + 0.67291304831937 + 0.66282371292686 + 0.65220321472236 + 0.64108902945350 + 0.62952696290839 + 0.61756911951267 + 0.60527237341621 + 0.59269496671676 + 0.57985651317011 + 0.56681405586365 + 0.55362695028850 + 0.54035594874727 + 0.52706140910515 + 0.51380053064359 + 0.50060339738846 + 0.48748475893711 + 0.47446306732390 + 0.46154003272802 + 0.44869911654153 + 0.98600722194955 + 0.98600734136835 + 0.98600736123916 + 0.98600738443115 + 0.98600741150463 + 0.98600744312037 + 0.98600748005086 + 0.98600752320962 + 0.98600757368749 + 0.98600763289215 + 0.98600770291179 + 0.98600778686857 + 0.98600788852508 + 0.98600801208508 + 0.98600816251975 + 0.98600834588325 + 0.98600856962071 + 0.98600884292830 + 0.98600917754078 + 0.98600958851112 + 0.98601009411288 + 0.98601071722580 + 0.98601148655216 + 0.98601243822804 + 0.98601361823627 + 0.98601508758613 + 0.98601693212245 + 0.98601926566604 + 0.98602222922622 + 0.98602600095300 + 0.98603082373641 + 0.98603700980543 + 0.98604496424919 + 0.98605521758026 + 0.98606846603784 + 0.98608562542194 + 0.98610790327197 + 0.98613689608950 + 0.98617476621679 + 0.98622446228558 + 0.98628990886053 + 0.98637642995256 + 0.98649127920751 + 0.98664411204949 + 0.98684582387096 + 0.98710785928725 + 0.98744815974359 + 0.98789144139614 + 0.98846614919506 + 0.98921812381479 + 0.99022969600421 + 0.99165570747731 + 0.99386996767069 + 1.00000000000000 + 0.99308293690116 + 0.98934731243894 + 0.98587553000515 + 0.98234387128205 + 0.97860235994811 + 0.97454799053020 + 0.97008924870397 + 0.96512399156269 + 0.95954614857018 + 0.95326556040246 + 0.94620223654974 + 0.93827864658998 + 0.92942874331037 + 0.91959930971038 + 0.90875382829070 + 0.89687789754535 + 0.88398525592443 + 0.87012257263096 + 0.85536585547821 + 0.83980528697840 + 0.82357130109305 + 0.80687115940152 + 0.78995706489643 + 0.78149379056445 + 0.77306596251471 + 0.76469511653029 + 0.75639633146920 + 0.74817718278121 + 0.74003715125325 + 0.73196767713330 + 0.72395303664469 + 0.71597195730399 + 0.70799577720617 + 0.69992352524772 + 0.69146806782587 + 0.68248040624376 + 0.67294667798663 + 0.66285505942814 + 0.65223230013181 + 0.64111589260225 + 0.62955165920755 + 0.61759171972938 + 0.60529296172005 + 0.59271363799738 + 0.57987336432619 + 0.56682919055555 + 0.55364047736470 + 0.54036798094933 + 0.52707206201144 + 0.51380992164253 + 0.50061164262343 + 0.48749197206667 + 0.47446935965825 + 0.46154551125757 + 0.44870388186502 + 0.98421180058787 + 0.98421190591991 + 0.98421192344583 + 0.98421194389941 + 0.98421196777623 + 0.98421199565618 + 0.98421202822161 + 0.98421206627616 + 0.98421211078436 + 0.98421216298443 + 0.98421222474089 + 0.98421229885095 + 0.98421238868406 + 0.98421249800687 + 0.98421263125934 + 0.98421279385789 + 0.98421299247283 + 0.98421323532665 + 0.98421353294516 + 0.98421389882219 + 0.98421434934849 + 0.98421490504514 + 0.98421559164662 + 0.98421644156278 + 0.98421749604239 + 0.98421880986230 + 0.98422046027854 + 0.98422254978205 + 0.98422520524898 + 0.98422858689015 + 0.98423291332402 + 0.98423846546528 + 0.98424560761462 + 0.98425481669389 + 0.98426671827882 + 0.98428213466629 + 0.98430214910951 + 0.98432819213204 + 0.98436219946981 + 0.98440680750579 + 0.98446551587662 + 0.98454305788523 + 0.98464585536138 + 0.98478239530492 + 0.98496206529235 + 0.98519438524373 + 0.98549422049629 + 0.98588153119937 + 0.98637774792658 + 0.98701621985040 + 0.98785389927794 + 0.98898564879451 + 0.99058757510639 + 0.99308293690116 + 1.00000000000000 + 0.99216873139117 + 0.98791253782544 + 0.98395199634133 + 0.97992334729135 + 0.97565747479339 + 0.97103390038981 + 0.96593486952976 + 0.96024528325115 + 0.95386981957436 + 0.94672517473097 + 0.93873141861805 + 0.92982075274303 + 0.91993860072762 + 0.90904734730884 + 0.89713167841126 + 0.88420455964867 + 0.87031199913751 + 0.85552941836563 + 0.83994645226362 + 0.82369309433980 + 0.80697630148185 + 0.79004802231906 + 0.78157849268546 + 0.77314492990273 + 0.76476883474424 + 0.75646525018212 + 0.74824171523978 + 0.74009767407725 + 0.73202453044522 + 0.72400652461861 + 0.71602234925965 + 0.70804330768635 + 0.69996836911780 + 0.69151028166180 + 0.68251999809365 + 0.67298366103201 + 0.66288945310687 + 0.65226414100845 + 0.64114523533817 + 0.62957857615912 + 0.61761629935288 + 0.60531530623626 + 0.59273386028462 + 0.57989157827642 + 0.56684551635320 + 0.55365503977879 + 0.54038090800490 + 0.52708348393244 + 0.51381996982516 + 0.50062044644793 + 0.48749965764098 + 0.47447605004236 + 0.46155132438169 + 0.44870892832307 + 0.98215767380471 + 0.98215776691724 + 0.98215778240660 + 0.98215780048405 + 0.98215782158519 + 0.98215784622363 + 0.98215787500104 + 0.98215790862801 + 0.98215794795158 + 0.98215799407770 + 0.98215804866359 + 0.98215811422921 + 0.98215819380067 + 0.98215829075708 + 0.98215840908421 + 0.98215855364325 + 0.98215873042051 + 0.98215894680430 + 0.98215921225034 + 0.98215953891123 + 0.98215994152672 + 0.98216043855820 + 0.98216105316830 + 0.98216181450933 + 0.98216275970813 + 0.98216393810110 + 0.98216541944825 + 0.98216729635487 + 0.98216968336430 + 0.98217272501898 + 0.98217661874281 + 0.98218161809353 + 0.98218805175205 + 0.98219634984083 + 0.98220707626049 + 0.98222097173127 + 0.98223901122299 + 0.98226248091103 + 0.98229311990815 + 0.98233329450410 + 0.98238613872672 + 0.98245588098310 + 0.98254823876644 + 0.98267072303413 + 0.98283149197403 + 0.98303854992710 + 0.98330439781728 + 0.98364549257069 + 0.98407846598840 + 0.98462872144043 + 0.98533862983945 + 0.98627416659797 + 0.98754355091656 + 0.98934731243894 + 0.99216873139117 + 1.00000000000000 + 0.99111111303321 + 0.98625735417440 + 0.98173916337306 + 0.97714528497603 + 0.97227970833926 + 0.96699109280155 + 0.96114697322150 + 0.95464260480873 + 0.94738892443740 + 0.93930205291241 + 0.93031142070787 + 0.92036037914596 + 0.90940969195387 + 0.89744273164952 + 0.88447137280491 + 0.87054070270941 + 0.85572533554645 + 0.84011416192458 + 0.82383657376620 + 0.80709910143436 + 0.79015333729295 + 0.78167614411663 + 0.77323558526739 + 0.76485311487144 + 0.75654372843954 + 0.74831491711949 + 0.74016607716054 + 0.73208856479619 + 0.72406657370500 + 0.71607875154057 + 0.70809635712291 + 0.70001828707689 + 0.69155715087014 + 0.68256384432424 + 0.67302451507398 + 0.66292735209403 + 0.65229914066875 + 0.64117741087389 + 0.62960802151687 + 0.61764312522445 + 0.60533963722890 + 0.59275583133675 + 0.57991132395246 + 0.56686317673422 + 0.55367075864761 + 0.54039483148689 + 0.52709575945551 + 0.51383074514237 + 0.50062986628973 + 0.48750786247760 + 0.47448317643114 + 0.46155750275738 + 0.44871428065139 + 0.97980780396087 + 0.97980788647527 + 0.97980790019967 + 0.97980791621545 + 0.97980793491099 + 0.97980795673814 + 0.97980798223011 + 0.97980801201641 + 0.97980804684506 + 0.97980808770194 + 0.97980813607074 + 0.97980819421898 + 0.97980826488261 + 0.97980835110066 + 0.97980845645839 + 0.97980858533977 + 0.97980874312874 + 0.97980893648497 + 0.97980917394058 + 0.97980946645880 + 0.97980982735537 + 0.97981027328392 + 0.97981082515795 + 0.97981150929492 + 0.97981235920503 + 0.97981341948433 + 0.97981475331753 + 0.97981644467313 + 0.97981859729653 + 0.97982134200002 + 0.97982485766309 + 0.97982937387052 + 0.97983518811269 + 0.97984268951338 + 0.97985238796601 + 0.97986495279410 + 0.97988126428446 + 0.97990248253019 + 0.97993017520892 + 0.97996647367484 + 0.98001419515772 + 0.98007713285222 + 0.98016040145662 + 0.98027068545665 + 0.98041512233011 + 0.98060049363009 + 0.98083742575382 + 0.98113968693161 + 0.98152043430250 + 0.98199960239164 + 0.98261016657065 + 0.98340141509112 + 0.98444871211389 + 0.98587553000515 + 0.98791253782544 + 0.99111111303321 + 1.00000000000000 + 0.98988858991486 + 0.98435040583504 + 0.97919653938507 + 0.97395514402550 + 0.96838791329620 + 0.96232464971730 + 0.95564190485156 + 0.94823996847083 + 0.94002813554367 + 0.93093127472149 + 0.92088947333082 + 0.90986103647482 + 0.89782740518650 + 0.88479888750678 + 0.87081927181438 + 0.85596205077168 + 0.84031509679004 + 0.82400697767017 + 0.80724362882934 + 0.79027614635748 + 0.78178949230059 + 0.77334033335423 + 0.76495006132988 + 0.75663360874271 + 0.74839840351180 + 0.74024377890235 + 0.73216102891634 + 0.72413428644598 + 0.71614214065475 + 0.70815579301104 + 0.70007405110222 + 0.69160936076352 + 0.68261255040678 + 0.67306977217043 + 0.66296922113622 + 0.65233770260807 + 0.64121276742156 + 0.62964029404343 + 0.61767245221316 + 0.60536617090105 + 0.59277973350768 + 0.57993275414798 + 0.56688229880569 + 0.55368773887016 + 0.54040983718767 + 0.52710895805142 + 0.51384230323101 + 0.50063994616730 + 0.48751662096297 + 0.47449076533878 + 0.46156406659016 + 0.44871995411711 + 0.97712124784739 + 0.97712132117549 + 0.97712133336826 + 0.97712134759990 + 0.97712136420967 + 0.97712138360157 + 0.97712140624590 + 0.97712143270211 + 0.97712146364019 + 0.97712149993028 + 0.97712154290646 + 0.97712159462320 + 0.97712165755533 + 0.97712173444999 + 0.97712182854615 + 0.97712194379643 + 0.97712208507224 + 0.97712225839224 + 0.97712247147334 + 0.97712273425581 + 0.97712305879014 + 0.97712346016340 + 0.97712395731249 + 0.97712457407739 + 0.97712534079930 + 0.97712629791724 + 0.97712750285896 + 0.97712903200819 + 0.97713097963023 + 0.97713346450853 + 0.97713664921922 + 0.97714074231693 + 0.97714601388746 + 0.97715281705852 + 0.97716161430550 + 0.97717301229514 + 0.97718780825451 + 0.97720705179098 + 0.97723216051976 + 0.97726506050498 + 0.97730829299327 + 0.97736527352889 + 0.97744059662656 + 0.97754023952504 + 0.97767048048472 + 0.97783709624368 + 0.97804919191871 + 0.97831840773743 + 0.97865527710155 + 0.97907575110621 + 0.97960625823957 + 0.98028528437649 + 0.98116914910527 + 0.98234387128205 + 0.98395199634133 + 0.98625735417440 + 0.98988858991486 + 1.00000000000000 + 0.98847679037343 + 0.98215536109146 + 0.97627163396713 + 0.97027144505907 + 0.96388604405472 + 0.95695027943034 + 0.94934310000353 + 0.94096125219940 + 0.93172172154772 + 0.92155924763243 + 0.91042828424095 + 0.89830735685359 + 0.88520447742238 + 0.87116157295574 + 0.85625055996741 + 0.84055790621354 + 0.82421104497913 + 0.80741508215129 + 0.79042042428318 + 0.78192200382947 + 0.77346219448737 + 0.76506230465446 + 0.75673718292641 + 0.74849417335236 + 0.74033252598987 + 0.73224345293512 + 0.72421100732895 + 0.71621370187199 + 0.70822266363736 + 0.70013659009131 + 0.69166773259904 + 0.68266683901322 + 0.67312006484053 + 0.66301561056591 + 0.65238030278032 + 0.64125171417503 + 0.62967574350631 + 0.61770457762365 + 0.60539515857154 + 0.59280577805636 + 0.57995604530684 + 0.56690302889776 + 0.55370610083921 + 0.54042602328607 + 0.52712315898422 + 0.51385470738286 + 0.50065073601482 + 0.48752597197452 + 0.47449884664659 + 0.46157103857655 + 0.44872596579908 + 0.97405267915185 + 0.97405274452802 + 0.97405275539782 + 0.97405276808016 + 0.97405278288802 + 0.97405280017053 + 0.97405282035209 + 0.97405284392788 + 0.97405287149552 + 0.97405290383132 + 0.97405294214224 + 0.97405298829042 + 0.97405304452153 + 0.97405311332697 + 0.97405319764188 + 0.97405330105136 + 0.97405342796895 + 0.97405358385154 + 0.97405377571448 + 0.97405401259090 + 0.97405430542854 + 0.97405466793569 + 0.97405511732552 + 0.97405567525182 + 0.97405636929145 + 0.97405723623110 + 0.97405832843934 + 0.97405971562024 + 0.97406148371617 + 0.97406374092652 + 0.97406663548760 + 0.97407035744317 + 0.97407515276487 + 0.97408134291553 + 0.97408934863191 + 0.97409972145003 + 0.97411318556055 + 0.97413069347944 + 0.97415353105036 + 0.97418344430173 + 0.97422273298862 + 0.97427448322281 + 0.97434283769093 + 0.97443316343869 + 0.97455100774344 + 0.97470131019473 + 0.97489191940211 + 0.97513275197103 + 0.97543229726951 + 0.97580348173310 + 0.97626791012938 + 0.97685651158905 + 0.97761324573113 + 0.97860235994811 + 0.97992334729135 + 0.98173916337306 + 0.98435040583504 + 0.98847679037343 + 1.00000000000000 + 0.98684682400086 + 0.97962302518962 + 0.97288261910485 + 0.96599672461757 + 0.95868908466694 + 0.95079074779099 + 0.94217345075691 + 0.93273970040534 + 0.92241504074188 + 0.91114765174571 + 0.89891151608545 + 0.88571119403493 + 0.87158589222950 + 0.85660527904336 + 0.84085386294112 + 0.82445750395336 + 0.80762014855953 + 0.79059124507211 + 0.78207808560316 + 0.77360499154611 + 0.76519315923478 + 0.75685732508617 + 0.74860472148434 + 0.74043448805688 + 0.73233772855981 + 0.72429839097978 + 0.71629488752381 + 0.70829824820908 + 0.70020703316153 + 0.69173326093438 + 0.68272758218904 + 0.67317615371794 + 0.66306717995979 + 0.65242750975558 + 0.64129473841172 + 0.62971478516057 + 0.61773985341841 + 0.60542689697861 + 0.59283421381601 + 0.57998140479009 + 0.56692553863427 + 0.55372598551088 + 0.54044350454698 + 0.52713845479035 + 0.51386803141591 + 0.50066229401457 + 0.48753596079884 + 0.47450745516292 + 0.46157844517043 + 0.44873233562981 + 0.97055149800812 + 0.97055155651755 + 0.97055156624381 + 0.97055157759270 + 0.97055159083813 + 0.97055160629890 + 0.97055162435169 + 0.97055164543735 + 0.97055167009428 + 0.97055169901319 + 0.97055173329217 + 0.97055177462126 + 0.97055182505090 + 0.97055188685064 + 0.97055196268494 + 0.97055205581277 + 0.97055217025766 + 0.97055231098383 + 0.97055248438339 + 0.97055269869263 + 0.97055296390008 + 0.97055329250452 + 0.97055370019751 + 0.97055420672159 + 0.97055483722137 + 0.97055562527197 + 0.97055661878484 + 0.97055788158836 + 0.97055949227544 + 0.97056154972863 + 0.97056418953700 + 0.97056758541758 + 0.97057196207832 + 0.97057761303337 + 0.97058492221028 + 0.97059439252972 + 0.97060668377438 + 0.97062266288987 + 0.97064349965991 + 0.97067078165242 + 0.97070659648598 + 0.97075374152497 + 0.97081596477881 + 0.97089810315444 + 0.97100507671614 + 0.97114112014268 + 0.97131302994474 + 0.97152930168575 + 0.97179679446481 + 0.97212606575479 + 0.97253501789207 + 0.97304899319333 + 0.97370328772125 + 0.97454799053020 + 0.97565747479339 + 0.97714528497603 + 0.97919653938507 + 0.98215536109146 + 0.98684682400086 + 1.00000000000000 + 0.98495623911889 + 0.97667186706457 + 0.96893087189558 + 0.96104577024893 + 0.95271955153034 + 0.94376815212493 + 0.93406527004824 + 0.92351964338043 + 0.91206872553241 + 0.89967913963036 + 0.88635009219642 + 0.87211671463916 + 0.85704540706208 + 0.84121790511657 + 0.82475786466966 + 0.80786760271887 + 0.79079523192082 + 0.78226347445611 + 0.77377368729812 + 0.76534691573622 + 0.75699774561460 + 0.74873325999594 + 0.74055245131362 + 0.73244627933813 + 0.72439855274548 + 0.71638755098292 + 0.70838417670937 + 0.70028681735712 + 0.69180721052992 + 0.68279588837775 + 0.67323900552528 + 0.66312476782127 + 0.65248004681858 + 0.64134246067227 + 0.62975794867071 + 0.61777872946844 + 0.60546176640677 + 0.59286536072236 + 0.58000910028651 + 0.56695005063737 + 0.55374757680082 + 0.54046243177253 + 0.52715496810337 + 0.51388237416568 + 0.50067469907529 + 0.48754664982179 + 0.47451663977060 + 0.46158632440184 + 0.44873909308068 + 0.96655776911687 + 0.96655782169638 + 0.96655783043553 + 0.96655784063381 + 0.96655785253188 + 0.96655786642148 + 0.96655788263791 + 0.96655790157571 + 0.96655792371801 + 0.96655794968984 + 0.96655798048467 + 0.96655801765377 + 0.96655806306734 + 0.96655811879300 + 0.96655818726994 + 0.96655827147511 + 0.96655837507511 + 0.96655850260804 + 0.96655865992065 + 0.96655885455314 + 0.96655909563982 + 0.96655939461419 + 0.96655976583126 + 0.96656022735171 + 0.96656080217281 + 0.96656152102922 + 0.96656242790233 + 0.96656358139933 + 0.96656505362871 + 0.96656693521220 + 0.96656935053296 + 0.96657245883885 + 0.96657646599303 + 0.96658164073408 + 0.96658833436427 + 0.96659700669504 + 0.96660826043926 + 0.96662288673468 + 0.96664195257074 + 0.96666690525186 + 0.96669964486581 + 0.96674271401186 + 0.96679951334714 + 0.96687441532767 + 0.96697179692222 + 0.96709529335050 + 0.96725080910474 + 0.96744565003380 + 0.96768535036550 + 0.96797856635585 + 0.96834026683217 + 0.96879148763382 + 0.96936110195399 + 0.97008924870397 + 0.97103390038981 + 0.97227970833926 + 0.97395514402550 + 0.97627163396713 + 0.97962302518962 + 0.98495623911889 + 1.00000000000000 + 0.98273148243089 + 0.97320802509556 + 0.96433637412187 + 0.95534522233135 + 0.94590214541826 + 0.93581664894762 + 0.92496415346280 + 0.91326259157788 + 0.90066605687969 + 0.88716511334444 + 0.87278858880704 + 0.85759801004889 + 0.84167110971390 + 0.82512840913655 + 0.80816991250214 + 0.79104185794618 + 0.78248641027648 + 0.77397544456313 + 0.76552980131480 + 0.75716386318341 + 0.74888451242708 + 0.74069054419572 + 0.73257272585344 + 0.72451468041949 + 0.71649451095786 + 0.70848295194432 + 0.70037817138036 + 0.69189156383378 + 0.68287351502322 + 0.67331017207192 + 0.66318973828286 + 0.65253910778571 + 0.64139592125446 + 0.62980613690492 + 0.61782198642618 + 0.60550043942852 + 0.59289979621453 + 0.58003962555303 + 0.56697698530642 + 0.55377123098938 + 0.54048310541717 + 0.52717295099525 + 0.51389794603958 + 0.50068812594486 + 0.48755818351965 + 0.47452651952658 + 0.46159477423846 + 0.44874631883582 + 0.96199178931435 + 0.96199183675871 + 0.96199184464388 + 0.96199185384253 + 0.96199186457633 + 0.96199187710342 + 0.96199189172771 + 0.96199190880776 + 0.96199192877447 + 0.96199195219259 + 0.96199197996908 + 0.96199201352407 + 0.96199205457538 + 0.96199210501987 + 0.96199216708587 + 0.96199224349891 + 0.96199233761820 + 0.96199245360415 + 0.96199259681036 + 0.96199277416139 + 0.96199299403359 + 0.96199326692096 + 0.96199360597829 + 0.96199402777799 + 0.96199455339232 + 0.96199521103702 + 0.96199604116009 + 0.96199709770666 + 0.96199844696105 + 0.96200017215843 + 0.96200238763092 + 0.96200523965588 + 0.96200891717780 + 0.96201366673336 + 0.96201981032971 + 0.96202776913486 + 0.96203809464910 + 0.96205151006640 + 0.96206899020159 + 0.96209185661903 + 0.96212184153768 + 0.96216125976540 + 0.96221320203412 + 0.96228162804425 + 0.96237043799380 + 0.96248275104536 + 0.96262370401054 + 0.96279958983479 + 0.96301484804923 + 0.96327657646100 + 0.96359735485790 + 0.96399478234768 + 0.96449275346833 + 0.96512399156269 + 0.96593486952976 + 0.96699109280155 + 0.96838791329620 + 0.97027144505907 + 0.97288261910485 + 0.97667186706457 + 0.98273148243089 + 1.00000000000000 + 0.98010967090929 + 0.96917651208976 + 0.95904485795727 + 0.94883392103937 + 0.93818218443259 + 0.92689077388351 + 0.91483891174872 + 0.90195788861941 + 0.88822355002132 + 0.87365454020099 + 0.85830485790516 + 0.84224628817881 + 0.82559479278692 + 0.80854703818418 + 0.79134659680541 + 0.78276051051359 + 0.77422225273558 + 0.76575238363966 + 0.75736500908519 + 0.74906673893705 + 0.74085610167653 + 0.73272360541692 + 0.72465262377162 + 0.71662102351649 + 0.70859931502280 + 0.70048538305421 + 0.69199019461907 + 0.68296395084401 + 0.67339278392905 + 0.66326488912730 + 0.65260718290434 + 0.64145732799808 + 0.62986130003461 + 0.61787134080154 + 0.60554442184398 + 0.59293883692182 + 0.58007412752254 + 0.56700733787156 + 0.55379780817693 + 0.54050626569755 + 0.52719303784146 + 0.51391528853468 + 0.50070303509722 + 0.48757095217553 + 0.47453742447408 + 0.46160407352314 + 0.44875424863238 + 0.95676273677758 + 0.95676277974809 + 0.95676278688799 + 0.95676279521702 + 0.95676280493532 + 0.95676281627649 + 0.95676282951285 + 0.95676284497374 + 0.95676286304182 + 0.95676288423705 + 0.95676290938053 + 0.95676293978180 + 0.95676297702025 + 0.95676302283471 + 0.95676307927016 + 0.95676314882887 + 0.95676323459151 + 0.95676334037832 + 0.95676347111106 + 0.95676363315260 + 0.95676383420069 + 0.95676408389362 + 0.95676439433001 + 0.95676478071199 + 0.95676526240395 + 0.95676586533166 + 0.95676662674973 + 0.95676759636451 + 0.95676883518958 + 0.95677041975611 + 0.95677245527641 + 0.95677507623454 + 0.95677845623767 + 0.95678282162882 + 0.95678846784810 + 0.95679578094034 + 0.95680526593628 + 0.95681758434888 + 0.95683362735237 + 0.95685460238755 + 0.95688208949771 + 0.95691819721769 + 0.95696573610728 + 0.95702829407001 + 0.95710934754864 + 0.95721156689504 + 0.95733941982536 + 0.95749832499915 + 0.95769180658942 + 0.95792566459897 + 0.95821049161242 + 0.95856107058661 + 0.95899730556040 + 0.95954614857018 + 0.96024528325115 + 0.96114697322150 + 0.96232464971730 + 0.96388604405472 + 0.96599672461757 + 0.96893087189558 + 0.97320802509556 + 0.98010967090929 + 1.00000000000000 + 0.97706505311884 + 0.96454025818991 + 0.95300502328361 + 0.94146348613195 + 0.92951821603396 + 0.91696189553643 + 0.90368050536711 + 0.88962305546389 + 0.87479081338999 + 0.85922562053490 + 0.84299009991662 + 0.82619338701251 + 0.80902722273676 + 0.79173131990230 + 0.78310501727606 + 0.77453105037057 + 0.76602959104336 + 0.75761436409488 + 0.74929160628284 + 0.74105948236312 + 0.73290814816207 + 0.72482063950431 + 0.71677450409535 + 0.70873995109677 + 0.70061449422521 + 0.69210855662961 + 0.68307210239742 + 0.67349123867572 + 0.66335414515237 + 0.65268776037495 + 0.64152976855578 + 0.62992616073415 + 0.61792918482573 + 0.60559580839067 + 0.59298431103818 + 0.58011419575982 + 0.56704248503452 + 0.55382849587318 + 0.54053293263269 + 0.52721610111154 + 0.51393514491103 + 0.50072005730408 + 0.48758548930639 + 0.47454980482176 + 0.46161460181114 + 0.44876320265814 + 0.95078931173848 + 0.95078935079354 + 0.95078935728148 + 0.95078936484921 + 0.95078937367929 + 0.95078938398278 + 0.95078939600876 + 0.95078941005110 + 0.95078942646001 + 0.95078944570585 + 0.95078946854458 + 0.95078949618220 + 0.95078953006876 + 0.95078957180905 + 0.95078962327756 + 0.95078968677562 + 0.95078976513794 + 0.95078986187842 + 0.95078998152024 + 0.95079012992639 + 0.95079031418061 + 0.95079054315444 + 0.95079082796893 + 0.95079118261161 + 0.95079162488840 + 0.95079217864793 + 0.95079287823799 + 0.95079376949850 + 0.95079490863495 + 0.95079636608327 + 0.95079823872310 + 0.95080065029137 + 0.95080376039853 + 0.95080777697892 + 0.95081297122753 + 0.95081969717427 + 0.95082841748874 + 0.95083973749040 + 0.95085447213320 + 0.95087372489795 + 0.95089893731294 + 0.95093203038832 + 0.95097556033299 + 0.95103277872437 + 0.95110678376768 + 0.95119985429540 + 0.95131587206535 + 0.95145949678674 + 0.95163348331140 + 0.95184254194145 + 0.95209559212279 + 0.95240507180723 + 0.95278761767305 + 0.95326556040246 + 0.95386981957436 + 0.95464260480873 + 0.95564190485156 + 0.95695027943034 + 0.95868908466694 + 0.96104577024893 + 0.96433637412187 + 0.96917651208976 + 0.97706505311884 + 1.00000000000000 + 0.97355652326773 + 0.95923682974893 + 0.94615621732709 + 0.93318013620480 + 0.91986985648246 + 0.90601007772999 + 0.89149651942141 + 0.87629878749298 + 0.86043804212623 + 0.84396219639708 + 0.82696982633523 + 0.80964521466804 + 0.79222237154024 + 0.78354284574878 + 0.77492177059003 + 0.76637877428099 + 0.75792705215711 + 0.74957232574414 + 0.74131226017405 + 0.73313652951965 + 0.72502770941239 + 0.71696291436330 + 0.70891194645249 + 0.70077182936390 + 0.69225228735370 + 0.68320297703973 + 0.67360996585158 + 0.66346140691689 + 0.65278425944471 + 0.64161622732174 + 0.63000331331956 + 0.61799776526867 + 0.60565653804065 + 0.59303788624207 + 0.58016125904574 + 0.56708364592696 + 0.55386432982287 + 0.54056398215780 + 0.52724287810107 + 0.51395813289605 + 0.50073970779064 + 0.48760222290323 + 0.47456401507142 + 0.46162665236055 + 0.44877342370383 + 0.94399749330812 + 0.94399752892249 + 0.94399753483710 + 0.94399754173462 + 0.94399754978359 + 0.94399755917472 + 0.94399757013286 + 0.94399758292849 + 0.94399759788026 + 0.94399761541605 + 0.94399763622779 + 0.94399766142976 + 0.94399769235899 + 0.94399773049089 + 0.94399777755692 + 0.94399783567532 + 0.94399790745612 + 0.94399799612758 + 0.94399810586621 + 0.94399824207943 + 0.94399841128910 + 0.94399862166898 + 0.94399888346503 + 0.94399920954800 + 0.94399961631490 + 0.94400012572477 + 0.94400076946781 + 0.94400158985685 + 0.94400263871162 + 0.94400398088989 + 0.94400570566884 + 0.94400792696240 + 0.94401079159422 + 0.94401449069065 + 0.94401927331364 + 0.94402546427496 + 0.94403348759973 + 0.94404389736964 + 0.94405743907259 + 0.94407512140661 + 0.94409825978913 + 0.94412860467997 + 0.94416848128722 + 0.94422083675198 + 0.94428843154436 + 0.94437320298607 + 0.94447851916908 + 0.94460837978166 + 0.94476489226047 + 0.94495184825153 + 0.94517674851208 + 0.94545005853048 + 0.94578570192242 + 0.94620223654974 + 0.94672517473097 + 0.94738892443740 + 0.94823996847083 + 0.94934310000353 + 0.95079074779099 + 0.95271955153034 + 0.95534522233135 + 0.95904485795727 + 0.96454025818991 + 0.97355652326773 + 1.00000000000000 + 0.96951834572137 + 0.95319736780418 + 0.93843473191248 + 0.92393340416726 + 0.90920758218407 + 0.89403407220883 + 0.87831972140943 + 0.86204816520192 + 0.84524247540484 + 0.82798423278250 + 0.81044606743605 + 0.79285335389543 + 0.78410297624924 + 0.77541940145455 + 0.76682148736212 + 0.75832168604524 + 0.74992500140878 + 0.74162840717785 + 0.73342091439598 + 0.72528446827213 + 0.71719559220166 + 0.70912353552412 + 0.70096467106039 + 0.69242781938770 + 0.68336223555696 + 0.67375392554892 + 0.66359099947695 + 0.65290043325724 + 0.64171994610620 + 0.63009554587425 + 0.61807947045350 + 0.60572864908966 + 0.59310129587629 + 0.58021678532736 + 0.56713205830562 + 0.55390634878267 + 0.54060028160009 + 0.52727408913085 + 0.51398484748877 + 0.50076247537532 + 0.48762155253039 + 0.47458038056818 + 0.46164048954130 + 0.44878512667573 + 0.93631460881879 + 0.93631464138302 + 0.93631464678904 + 0.93631465309663 + 0.93631466045368 + 0.93631466903626 + 0.93631467905199 + 0.93631469074266 + 0.93631470440292 + 0.93631472042277 + 0.93631473943920 + 0.93631476247910 + 0.93631479077786 + 0.93631482569801 + 0.93631486883480 + 0.93631492213923 + 0.93631498801928 + 0.93631506945347 + 0.93631517029360 + 0.93631529552511 + 0.93631545116904 + 0.93631564476188 + 0.93631588574290 + 0.93631618598171 + 0.93631656057264 + 0.93631702975803 + 0.93631762279816 + 0.93631837876933 + 0.93631934545763 + 0.93632058264281 + 0.93632217261610 + 0.93632422030359 + 0.93632686081833 + 0.93633026991289 + 0.93633467639359 + 0.93634037837340 + 0.93634776456508 + 0.93635734229098 + 0.93636979361065 + 0.93638604073406 + 0.93640728417624 + 0.93643511910028 + 0.93647166074237 + 0.93651958043007 + 0.93658133688163 + 0.93665856978664 + 0.93675419668421 + 0.93687164271707 + 0.93701247089449 + 0.93717969697308 + 0.93737961300567 + 0.93762101354400 + 0.93791554667840 + 0.93827864658998 + 0.93873141861805 + 0.93930205291241 + 0.94002813554367 + 0.94096125219940 + 0.94217345075691 + 0.94376815212493 + 0.94590214541826 + 0.94883392103937 + 0.95300502328361 + 0.95923682974893 + 0.96951834572137 + 1.00000000000000 + 0.96489182364199 + 0.94635817708171 + 0.92978659176721 + 0.91368903277996 + 0.89752510181980 + 0.88106178949621 + 0.86420860705876 + 0.84694385921805 + 0.82932035597307 + 0.81149178189320 + 0.79367001519780 + 0.78482466649736 + 0.77605762816075 + 0.76738664880211 + 0.75882312297859 + 0.75037104359875 + 0.74202641833865 + 0.73377733816060 + 0.72560487845581 + 0.71748475090537 + 0.70938544996872 + 0.70120247845858 + 0.69264348065055 + 0.68355718321386 + 0.67392949852457 + 0.66374846910329 + 0.65304107951363 + 0.64184505597825 + 0.63020640022128 + 0.61817732504353 + 0.60581471511587 + 0.59317672200567 + 0.58028261719448 + 0.56718927138823 + 0.55395584920886 + 0.54064291039662 + 0.52731062811876 + 0.51401602492722 + 0.50078896310456 + 0.48764396959395 + 0.47459930014903 + 0.46165643636164 + 0.44879857324439 + 0.92767843688624 + 0.92767846672321 + 0.92767847167606 + 0.92767847745124 + 0.92767848418940 + 0.92767849205048 + 0.92767850122117 + 0.92767851192659 + 0.92767852443176 + 0.92767853909585 + 0.92767855650786 + 0.92767857761166 + 0.92767860355204 + 0.92767863558736 + 0.92767867518397 + 0.92767872415084 + 0.92767878470161 + 0.92767885958688 + 0.92767895236338 + 0.92767906763882 + 0.92767921096284 + 0.92767938928995 + 0.92767961133282 + 0.92767988802753 + 0.92768023328816 + 0.92768066578719 + 0.92768121253313 + 0.92768190963588 + 0.92768280118607 + 0.92768394228217 + 0.92768540881286 + 0.92768729745501 + 0.92768973257648 + 0.92769287583840 + 0.92769693749548 + 0.92770219120642 + 0.92770899340370 + 0.92771780867041 + 0.92772926114786 + 0.92774419406818 + 0.92776370316201 + 0.92778924220056 + 0.92782273548826 + 0.92786660442265 + 0.92792303825074 + 0.92799341786335 + 0.92808026597889 + 0.92818650794358 + 0.92831325061002 + 0.92846285502695 + 0.92864058142469 + 0.92885380348150 + 0.92911224919249 + 0.92942874331037 + 0.92982075274303 + 0.93031142070787 + 0.93093127472149 + 0.93172172154772 + 0.93273970040534 + 0.93406527004824 + 0.93581664894762 + 0.93818218443259 + 0.94146348613195 + 0.94615621732709 + 0.95319736780418 + 0.96489182364199 + 1.00000000000000 + 0.95961071509923 + 0.93865542241262 + 0.92016636065543 + 0.90242984011462 + 0.88484032636055 + 0.86714266224719 + 0.84922730416235 + 0.83109512453370 + 0.81286743267906 + 0.79473416761977 + 0.78576057318706 + 0.77688131199960 + 0.76811250308512 + 0.75946401068008 + 0.75093838299583 + 0.74253026164893 + 0.73422644790288 + 0.72600680664891 + 0.71784592663813 + 0.70971126455034 + 0.70149715259036 + 0.69290969428887 + 0.68379691598375 + 0.67414458852256 + 0.66394064996826 + 0.65321207867454 + 0.64199659309009 + 0.63034017067294 + 0.61829497614924 + 0.60591782210492 + 0.59326676652596 + 0.58036093931676 + 0.56725711141137 + 0.55401435034643 + 0.54069312572800 + 0.52735352949869 + 0.51405251140880 + 0.50081985907499 + 0.48767003046213 + 0.47462122162283 + 0.46167485228528 + 0.44881405193784 + 0.91803898498468 + 0.91803901235866 + 0.91803901690173 + 0.91803902219864 + 0.91803902837771 + 0.91803903558583 + 0.91803904399455 + 0.91803905380796 + 0.91803906527043 + 0.91803907871093 + 0.91803909467018 + 0.91803911402243 + 0.91803913782668 + 0.91803916723984 + 0.91803920362359 + 0.91803924863869 + 0.91803930433416 + 0.91803937324694 + 0.91803945865934 + 0.91803956482809 + 0.91803969687909 + 0.91803986122476 + 0.91804006590505 + 0.91804032100531 + 0.91804063935533 + 0.91804103816646 + 0.91804154239111 + 0.91804218539053 + 0.91804300784727 + 0.91804406055660 + 0.91804541350760 + 0.91804715577700 + 0.91804940186685 + 0.91805230047969 + 0.91805604484719 + 0.91806088621196 + 0.91806715142144 + 0.91807526597644 + 0.91808580103277 + 0.91809952765701 + 0.91811744596653 + 0.91814088089004 + 0.91817158303191 + 0.91821174725344 + 0.91826332228864 + 0.91832746472582 + 0.91840635183246 + 0.91850247495816 + 0.91861656109099 + 0.91875042062149 + 0.91890843290356 + 0.91909676158363 + 0.91932350941921 + 0.91959930971038 + 0.91993860072762 + 0.92036037914596 + 0.92088947333082 + 0.92155924763243 + 0.92241504074188 + 0.92351964338043 + 0.92496415346280 + 0.92689077388351 + 0.92951821603396 + 0.93318013620480 + 0.93843473191248 + 0.94635817708171 + 0.95961071509923 + 1.00000000000000 + 0.95360606948937 + 0.93003189821412 + 0.90954426684429 + 0.89016179180659 + 0.87119168856721 + 0.85233034194140 + 0.83347656728071 + 0.81469271355934 + 0.79613123911662 + 0.78698288362856 + 0.77795148150494 + 0.76905069499742 + 0.76028812475190 + 0.75166421603569 + 0.74317164861164 + 0.73479539216490 + 0.72651360827616 + 0.71829931747038 + 0.71011853785227 + 0.70186401438674 + 0.69323981846999 + 0.68409304061304 + 0.67440923818536 + 0.66417618931095 + 0.65342084027881 + 0.64218087684560 + 0.63050222353166 + 0.61843696262915 + 0.60604179494864 + 0.59337464124648 + 0.58045443755781 + 0.56733781445013 + 0.55408370470190 + 0.54075245406626 + 0.52740404377042 + 0.51409532515418 + 0.50085598722080 + 0.48770039784507 + 0.47464667541267 + 0.46169616054846 + 0.44883190032549 + 0.90736253014951 + 0.90736255526851 + 0.90736255943634 + 0.90736256429743 + 0.90736256996405 + 0.90736257657552 + 0.90736258428970 + 0.90736259328990 + 0.90736260380018 + 0.90736261612281 + 0.90736263075671 + 0.90736264850916 + 0.90736267036013 + 0.90736269737290 + 0.90736273080502 + 0.90736277219176 + 0.90736282342796 + 0.90736288684140 + 0.90736296547236 + 0.90736306324739 + 0.90736318489428 + 0.90736333633636 + 0.90736352498224 + 0.90736376013545 + 0.90736405361561 + 0.90736442129783 + 0.90736488622223 + 0.90736547919346 + 0.90736623775659 + 0.90736720872000 + 0.90736845662002 + 0.90737006352424 + 0.90737213482788 + 0.90737480730039 + 0.90737825851433 + 0.90738271909836 + 0.90738848876197 + 0.90739595716313 + 0.90740564693870 + 0.90741826308448 + 0.90743471837831 + 0.90745622020609 + 0.90748436100839 + 0.90752113016033 + 0.90756826183744 + 0.90762671901795 + 0.90769837732988 + 0.90778535212775 + 0.90788805697487 + 0.90800784153457 + 0.90814833429310 + 0.90831466869004 + 0.90851357058409 + 0.90875382829070 + 0.90904734730884 + 0.90940969195387 + 0.90986103647482 + 0.91042828424095 + 0.91114765174571 + 0.91206872553241 + 0.91326259157788 + 0.91483891174872 + 0.91696189553643 + 0.91986985648246 + 0.92393340416726 + 0.92978659176721 + 0.93865542241262 + 0.95360606948937 + 1.00000000000000 + 0.94680995654623 + 0.92044187408493 + 0.89791032712549 + 0.87690834860418 + 0.85661855880500 + 0.83671405387444 + 0.81714039547168 + 0.79798179596578 + 0.78859246920909 + 0.77935262641492 + 0.77027210017013 + 0.76135504613259 + 0.75259877377490 + 0.74399308740845 + 0.73552031071775 + 0.72715617362681 + 0.71887147941460 + 0.71063023056276 + 0.70232299926112 + 0.69365115458738 + 0.68446052443982 + 0.67473634368658 + 0.66446614629513 + 0.65367680295295 + 0.64240592585955 + 0.63069934200114 + 0.61860900019493 + 0.60619143246991 + 0.59350436113904 + 0.58056645729707 + 0.56743415560486 + 0.55416620299340 + 0.54082277595846 + 0.52746370557485 + 0.51414571072718 + 0.50089835033310 + 0.48773587464317 + 0.47467630098756 + 0.46172086872216 + 0.44885252099463 + 0.89563712029265 + 0.89563714332999 + 0.89563714715244 + 0.89563715160867 + 0.89563715680575 + 0.89563716286662 + 0.89563716993632 + 0.89563717818542 + 0.89563718781899 + 0.89563719911271 + 0.89563721252468 + 0.89563722880050 + 0.89563724884380 + 0.89563727363831 + 0.89563730434188 + 0.89563734236587 + 0.89563738945519 + 0.89563744777082 + 0.89563752010262 + 0.89563761007584 + 0.89563772205604 + 0.89563786149708 + 0.89563803523181 + 0.89563825182967 + 0.89563852217506 + 0.89563886090102 + 0.89563928926971 + 0.89563983570946 + 0.89564053483917 + 0.89564142978028 + 0.89564258000848 + 0.89564406109103 + 0.89564597000178 + 0.89564843248992 + 0.89565161165709 + 0.89565571915828 + 0.89566102971315 + 0.89566790005188 + 0.89567680828611 + 0.89568839880992 + 0.89570350447779 + 0.89572322528230 + 0.89574900946238 + 0.89578265980312 + 0.89582571916630 + 0.89587898417031 + 0.89594406772784 + 0.89602276043465 + 0.89611522034359 + 0.89622241448708 + 0.89634733305097 + 0.89649423383804 + 0.89666867715317 + 0.89687789754535 + 0.89713167841126 + 0.89744273164952 + 0.89782740518650 + 0.89830735685359 + 0.89891151608545 + 0.89967913963036 + 0.90066605687969 + 0.90195788861941 + 0.90368050536711 + 0.90601007772999 + 0.90920758218407 + 0.91368903277996 + 0.92016636065543 + 0.93003189821412 + 0.94680995654623 + 1.00000000000000 + 0.93915801534236 + 0.90985328699325 + 0.88526651129995 + 0.86268838710395 + 0.84119375252565 + 0.82046806797440 + 0.80046035491392 + 0.79073348849613 + 0.78120408319520 + 0.77187573861379 + 0.76274716977741 + 0.75381086030656 + 0.74505228592705 + 0.73644986052371 + 0.72797577586939 + 0.71959764909329 + 0.71127661882858 + 0.70290024668066 + 0.69416627188392 + 0.68491879873673 + 0.67514257205274 + 0.66482475242344 + 0.65399206260079 + 0.64268197514641 + 0.63094015057059 + 0.61881832861924 + 0.60637279065969 + 0.59366097470855 + 0.58070119011395 + 0.56754959960940 + 0.55426469499500 + 0.54090642239097 + 0.52753440996546 + 0.51420519888726 + 0.50094817660825 + 0.48777743977573 + 0.47471087420315 + 0.46174958937152 + 0.44887639706147 + 0.88287863519612 + 0.88287865629482 + 0.88287865979446 + 0.88287866387427 + 0.88287866863246 + 0.88287867418116 + 0.88287868065282 + 0.88287868820395 + 0.88287869701877 + 0.88287870735398 + 0.88287871962696 + 0.88287873452882 + 0.88287875288734 + 0.88287877560843 + 0.88287880376164 + 0.88287883864385 + 0.88287888186291 + 0.88287893540634 + 0.88287900184457 + 0.88287908451757 + 0.88287918744491 + 0.88287931564962 + 0.88287947542037 + 0.88287967464105 + 0.88287992333618 + 0.88288023496818 + 0.88288062913070 + 0.88288113204376 + 0.88288177558805 + 0.88288259945527 + 0.88288365841586 + 0.88288502198694 + 0.88288677932532 + 0.88288904595275 + 0.88289197160685 + 0.88289575037392 + 0.88290063393532 + 0.88290694870967 + 0.88291513183535 + 0.88292577203173 + 0.88293962886968 + 0.88295770409094 + 0.88298131428594 + 0.88301209264920 + 0.88305141149796 + 0.88309992530762 + 0.88315901876074 + 0.88323020294268 + 0.88331343086899 + 0.88340935481072 + 0.88352042435844 + 0.88365015514573 + 0.88380312302547 + 0.88398525592443 + 0.88420455964867 + 0.88447137280491 + 0.88479888750678 + 0.88520447742238 + 0.88571119403493 + 0.88635009219642 + 0.88716511334444 + 0.88822355002132 + 0.88962305546389 + 0.89149651942141 + 0.89403407220883 + 0.89752510181980 + 0.90242984011462 + 0.90954426684429 + 0.92044187408493 + 0.93915801534236 + 1.00000000000000 + 0.93058953431603 + 0.89823678290047 + 0.87160149531559 + 0.84755096528826 + 0.82507732492889 + 0.80382834520562 + 0.79361831062410 + 0.78367900555027 + 0.77400329964241 + 0.76458089038704 + 0.75539652095036 + 0.74642891736611 + 0.73765054138918 + 0.72902830498560 + 0.72052514761971 + 0.71209806311989 + 0.70363037564363 + 0.69481488610891 + 0.68549331117796 + 0.67564964337278 + 0.66527046844973 + 0.65438224151514 + 0.64302218892081 + 0.63123569818258 + 0.61907418770486 + 0.60659357032164 + 0.59385087894893 + 0.58086392885567 + 0.56768850659164 + 0.55438275472120 + 0.54100630661560 + 0.52761851689421 + 0.51427568876930 + 0.50100698372504 + 0.48782629769084 + 0.47475134520289 + 0.46178306887872 + 0.44890411396799 + 0.86913559160177 + 0.86913561087685 + 0.86913561407392 + 0.86913561780143 + 0.86913562214735 + 0.86913562721359 + 0.86913563312466 + 0.86913564001791 + 0.86913564806692 + 0.86913565750041 + 0.86913566870731 + 0.86913568231760 + 0.86913569909400 + 0.86913571986885 + 0.86913574562363 + 0.86913577755249 + 0.86913581713214 + 0.86913586618122 + 0.86913592707150 + 0.86913600286900 + 0.86913609727219 + 0.86913621489502 + 0.86913636151679 + 0.86913654438779 + 0.86913677271103 + 0.86913705885477 + 0.86913742086251 + 0.86913788287028 + 0.86913847419892 + 0.86913923134201 + 0.86914020465829 + 0.86914145803840 + 0.86914307336478 + 0.86914515666164 + 0.86914784523821 + 0.86915131694746 + 0.86915580215944 + 0.86916159932649 + 0.86916910784376 + 0.86917886520003 + 0.86919156370923 + 0.86920811512415 + 0.86922971574913 + 0.86925784454534 + 0.86929372191928 + 0.86933788159999 + 0.86939151060420 + 0.86945588037737 + 0.86953078265216 + 0.86961661370680 + 0.86971536744155 + 0.86982993285399 + 0.86996405713721 + 0.87012257263096 + 0.87031199913751 + 0.87054070270941 + 0.87081927181438 + 0.87116157295574 + 0.87158589222950 + 0.87211671463916 + 0.87278858880704 + 0.87365454020099 + 0.87479081338999 + 0.87629878749298 + 0.87831972140943 + 0.88106178949621 + 0.88484032636055 + 0.89016179180659 + 0.89791032712549 + 0.90985328699325 + 0.93058953431603 + 1.00000000000000 + 0.92103135278867 + 0.88553590005831 + 0.85693010099329 + 0.83163587518091 + 0.80849698126850 + 0.79757360920850 + 0.78703851616643 + 0.77686467612354 + 0.76702585588357 + 0.75749368502495 + 0.74823586089229 + 0.73921541655189 + 0.73039111532137 + 0.72171882966973 + 0.71314940555691 + 0.70456007759442 + 0.69563681469667 + 0.68621796317503 + 0.67628634323471 + 0.66582764534157 + 0.65486785779275 + 0.64344378822036 + 0.63160038552918 + 0.61938857895433 + 0.60686374195745 + 0.59408233140444 + 0.58106148630878 + 0.56785647344771 + 0.55452495779887 + 0.54112614853532 + 0.52771903181303 + 0.51435959243904 + 0.50107669385269 + 0.48788396932688 + 0.47479891001341 + 0.46182224357334 + 0.44893640347664 + 0.85448564269777 + 0.85448566025133 + 0.85448566316162 + 0.85448566655572 + 0.85448567051151 + 0.85448567512433 + 0.85448568050479 + 0.85448568678027 + 0.85448569410492 + 0.85448570269229 + 0.85448571289176 + 0.85448572528262 + 0.85448574056661 + 0.85448575950454 + 0.85448578299254 + 0.85448581212928 + 0.85448584826418 + 0.85448589306581 + 0.85448594870854 + 0.85448601800636 + 0.85448610434447 + 0.85448621196507 + 0.85448634615972 + 0.85448651357539 + 0.85448672265257 + 0.85448698474134 + 0.85448731640997 + 0.85448773983340 + 0.85448828194831 + 0.85448897623881 + 0.85448986894828 + 0.85449101870788 + 0.85449250060306 + 0.85449441182521 + 0.85449687814647 + 0.85450006234242 + 0.85450417507116 + 0.85450948894466 + 0.85451636855436 + 0.85452530420098 + 0.85453692641955 + 0.85455206448242 + 0.85457180473075 + 0.85459748580168 + 0.85463019284592 + 0.85467035756465 + 0.85471899619668 + 0.85477717548297 + 0.85484456331118 + 0.85492135046927 + 0.85500914860364 + 0.85511031977219 + 0.85522791639131 + 0.85536585547821 + 0.85552941836563 + 0.85572533554645 + 0.85596205077168 + 0.85625055996741 + 0.85660527904336 + 0.85704540706208 + 0.85759801004889 + 0.85830485790516 + 0.85922562053490 + 0.86043804212623 + 0.86204816520192 + 0.86420860705876 + 0.86714266224719 + 0.87119168856721 + 0.87690834860418 + 0.88526651129995 + 0.89823678290047 + 0.92103135278867 + 1.00000000000000 + 0.91036928659602 + 0.87172368394066 + 0.84136992697434 + 0.81516365669792 + 0.80313711786110 + 0.79170162729855 + 0.78078929635299 + 0.77034319800813 + 0.76031103861870 + 0.75064131932955 + 0.74128131137040 + 0.73217661340475 + 0.72327199783250 + 0.71450888255387 + 0.70575549890766 + 0.69668814105209 + 0.68714027710610 + 0.67709286326048 + 0.66653017218303 + 0.65547739044045 + 0.64397062476667 + 0.63205412494306 + 0.61977807685958 + 0.60719706370657 + 0.59436672124412 + 0.58130325790485 + 0.56806122052802 + 0.55469761939712 + 0.54127108697925 + 0.52784011195826 + 0.51446025206137 + 0.50115997616619 + 0.48795257241720 + 0.47485523939843 + 0.46186842648915 + 0.44897429624049 + 0.83902054356642 + 0.83902055948628 + 0.83902056212554 + 0.83902056520269 + 0.83902056879039 + 0.83902057297259 + 0.83902057784910 + 0.83902058353871 + 0.83902059017777 + 0.83902059796080 + 0.83902060720698 + 0.83902061844563 + 0.83902063231276 + 0.83902064950907 + 0.83902067084826 + 0.83902069733570 + 0.83902073020090 + 0.83902077097632 + 0.83902082163967 + 0.83902088476871 + 0.83902096346100 + 0.83902106159065 + 0.83902118400314 + 0.83902133677140 + 0.83902152761849 + 0.83902176693039 + 0.83902206988811 + 0.83902245682739 + 0.83902295242916 + 0.83902358736404 + 0.83902440400746 + 0.83902545606438 + 0.83902681228629 + 0.83902856160901 + 0.83903081906687 + 0.83903373343131 + 0.83903749707314 + 0.83904235870424 + 0.83904865075529 + 0.83905681999003 + 0.83906744011558 + 0.83908126469519 + 0.83909927938208 + 0.83912269496916 + 0.83915247600316 + 0.83918896827168 + 0.83923304053477 + 0.83928558488896 + 0.83934617690966 + 0.83941484467498 + 0.83949288038326 + 0.83958220437565 + 0.83968528833471 + 0.83980528697840 + 0.83994645226362 + 0.84011416192458 + 0.84031509679004 + 0.84055790621354 + 0.84085386294112 + 0.84121790511657 + 0.84167110971390 + 0.84224628817881 + 0.84299009991662 + 0.84396219639708 + 0.84524247540484 + 0.84694385921805 + 0.84922730416235 + 0.85233034194140 + 0.85661855880500 + 0.86268838710395 + 0.87160149531559 + 0.88553590005831 + 0.91036928659602 + 1.00000000000000 + 0.89855066172557 + 0.85691106883338 + 0.82514715764998 + 0.81128341693807 + 0.79840219062140 + 0.78633807421524 + 0.77496720014715 + 0.76418884762678 + 0.75391502764827 + 0.74406461463962 + 0.73456054377777 + 0.72532918504609 + 0.71629681322237 + 0.70731780698586 + 0.69805429009551 + 0.68833242427468 + 0.67813012152759 + 0.66742935658156 + 0.65625393971983 + 0.64463880586406 + 0.63262708659326 + 0.62026783016545 + 0.60761445177941 + 0.59472140569367 + 0.58160360475986 + 0.56831458967815 + 0.55491046535918 + 0.54144907336433 + 0.52798822490362 + 0.51458289985722 + 0.50126103963392 + 0.48803547423720 + 0.47492301524561 + 0.46192374784943 + 0.44901948401034 + 0.82287189434825 + 0.82287190872059 + 0.82287191110310 + 0.82287191388025 + 0.82287191711933 + 0.82287192089336 + 0.82287192529559 + 0.82287193042765 + 0.82287193642089 + 0.82287194344328 + 0.82287195178795 + 0.82287196193320 + 0.82287197446266 + 0.82287199000831 + 0.82287200931514 + 0.82287203329070 + 0.82287206306188 + 0.82287210001661 + 0.82287214596317 + 0.82287220324935 + 0.82287227469865 + 0.82287236384101 + 0.82287247509831 + 0.82287261401072 + 0.82287278761542 + 0.82287300539475 + 0.82287328123121 + 0.82287363371884 + 0.82287408543098 + 0.82287466439859 + 0.82287540937428 + 0.82287636946478 + 0.82287760750608 + 0.82287920474865 + 0.82288126624633 + 0.82288392777534 + 0.82288736478137 + 0.82289180389488 + 0.82289754787863 + 0.82290500340444 + 0.82291469198098 + 0.82292729777287 + 0.82294371439674 + 0.82296503629587 + 0.82299212056531 + 0.82302524094088 + 0.82306513900978 + 0.82311255825213 + 0.82316700805520 + 0.82322838977564 + 0.82329773004103 + 0.82337658056937 + 0.82346692995380 + 0.82357130109305 + 0.82369309433980 + 0.82383657376620 + 0.82400697767017 + 0.82421104497913 + 0.82445750395336 + 0.82475786466966 + 0.82512840913655 + 0.82559479278692 + 0.82619338701251 + 0.82696982633523 + 0.82798423278250 + 0.82932035597307 + 0.83109512453370 + 0.83347656728071 + 0.83671405387444 + 0.84119375252565 + 0.84755096528826 + 0.85693010099329 + 0.87172368394066 + 0.89855066172557 + 1.00000000000000 + 0.88564847674245 + 0.84130282171101 + 0.82396893632920 + 0.80852990607382 + 0.79452437411319 + 0.78165228665449 + 0.76969881861192 + 0.75849733865891 + 0.74790988938809 + 0.73781678033249 + 0.72811150681004 + 0.71869442669287 + 0.70939741934402 + 0.69986089586790 + 0.68989957049835 + 0.67948618957547 + 0.66859887466068 + 0.65725903331695 + 0.64549961257719 + 0.63336192739678 + 0.62089325662760 + 0.60814526208824 + 0.59517067272711 + 0.58198256986017 + 0.56863307018708 + 0.55517701152807 + 0.54167113837170 + 0.52817232913262 + 0.51473477342245 + 0.50138569947494 + 0.48813732215134 + 0.47500593539209 + 0.46199114218832 + 0.44907429524556 + 0.80624757244849 + 0.80624758536629 + 0.80624758750754 + 0.80624759000365 + 0.80624759291379 + 0.80624759630629 + 0.80624760026197 + 0.80624760487489 + 0.80624761025813 + 0.80624761656722 + 0.80624762406492 + 0.80624763318605 + 0.80624764445970 + 0.80624765845597 + 0.80624767585273 + 0.80624769747271 + 0.80624772433842 + 0.80624775771030 + 0.80624779922840 + 0.80624785102871 + 0.80624791567536 + 0.80624799638402 + 0.80624809717481 + 0.80624822308594 + 0.80624838052609 + 0.80624857813169 + 0.80624882856358 + 0.80624914880746 + 0.80624955945942 + 0.80625008610523 + 0.80625076414251 + 0.80625163840455 + 0.80625276625359 + 0.80625422185752 + 0.80625610105722 + 0.80625852766909 + 0.80626166159895 + 0.80626570924367 + 0.80627094621639 + 0.80627774255578 + 0.80628657218815 + 0.80629805618265 + 0.80631300463435 + 0.80633240688091 + 0.80635702489405 + 0.80638707245165 + 0.80642318217018 + 0.80646597194399 + 0.80651490638390 + 0.80656979041082 + 0.80663143198734 + 0.80670107805869 + 0.80678031909201 + 0.80687115940152 + 0.80697630148185 + 0.80709910143436 + 0.80724362882934 + 0.80741508215129 + 0.80762014855953 + 0.80786760271887 + 0.80816991250214 + 0.80854703818418 + 0.80902722273676 + 0.80964521466804 + 0.81044606743605 + 0.81149178189320 + 0.81286743267906 + 0.81469271355934 + 0.81714039547168 + 0.82046806797440 + 0.82507732492889 + 0.83163587518091 + 0.84136992697434 + 0.85691106883338 + 0.88564847674245 + 1.00000000000000 + 0.87175415988203 + 0.84593245598813 + 0.82510088926009 + 0.80737331040309 + 0.79180943081949 + 0.77785233002158 + 0.76513066907625 + 0.75337397748027 + 0.74237165403054 + 0.73195200557378 + 0.72196698551501 + 0.71220915682874 + 0.70228362412119 + 0.69198608025129 + 0.68128003069770 + 0.67013682761343 + 0.65857354509347 + 0.64661966173394 + 0.63431346463504 + 0.62169941676348 + 0.60882649526557 + 0.59574486695973 + 0.58246498489764 + 0.56903692565886 + 0.55551373500894 + 0.54195062163124 + 0.52840316913968 + 0.51492447849767 + 0.50154080675993 + 0.48826353719664 + 0.47510826694765 + 0.46207395633483 + 0.44914135230387 + 0.78940026587448 + 0.78940027744437 + 0.78940027936149 + 0.78940028159769 + 0.78940028420340 + 0.78940028724158 + 0.78940029078282 + 0.78940029491241 + 0.78940029973308 + 0.78940030538149 + 0.78940031209604 + 0.78940032026915 + 0.78940033037666 + 0.78940034293966 + 0.78940035856596 + 0.78940037800331 + 0.78940040217315 + 0.78940043222001 + 0.78940046963186 + 0.78940051634313 + 0.78940057468699 + 0.78940064757808 + 0.78940073866616 + 0.78940085253456 + 0.78940099500703 + 0.78940117393820 + 0.78940140087155 + 0.78940169129550 + 0.78940206400023 + 0.78940254232486 + 0.78940315857309 + 0.78940395367421 + 0.78940497998766 + 0.78940630518959 + 0.78940801673113 + 0.78941022755126 + 0.78941308341504 + 0.78941677237462 + 0.78942154545331 + 0.78942773955418 + 0.78943578566496 + 0.78944624803405 + 0.78945986170505 + 0.78947752194217 + 0.78949990720913 + 0.78952718193224 + 0.78955988615086 + 0.78959853262423 + 0.78964255855151 + 0.78969169784486 + 0.78974658080270 + 0.78980820555709 + 0.78987783878426 + 0.78995706489643 + 0.79004802231906 + 0.79015333729295 + 0.79027614635748 + 0.79042042428318 + 0.79059124507211 + 0.79079523192082 + 0.79104185794618 + 0.79134659680541 + 0.79173131990230 + 0.79222237154024 + 0.79285335389543 + 0.79367001519780 + 0.79473416761977 + 0.79613123911662 + 0.79798179596578 + 0.80046035491392 + 0.80382834520562 + 0.80849698126850 + 0.81516365669792 + 0.82514715764998 + 0.84130282171101 + 0.87175415988203 + 1.00000000000000 + 0.89550546519688 + 0.85694124838795 + 0.82991907082745 + 0.80857054262579 + 0.79070788070467 + 0.77522323381132 + 0.76145203202219 + 0.74894891546021 + 0.73739142373274 + 0.72652899960178 + 0.71607798156729 + 0.70558100206640 + 0.69479952163445 + 0.68367933402924 + 0.67217916080183 + 0.66030789818475 + 0.64808873213973 + 0.63555472534957 + 0.62274572267986 + 0.60970648550139 + 0.59648329569428 + 0.58308276856946 + 0.56955201627905 + 0.55594152039190 + 0.54230431877236 + 0.52869418331107 + 0.51516270525332 + 0.50173481125098 + 0.48842075437022 + 0.47523518939239 + 0.46217621610680 + 0.44922377872935 + 0.78096723162619 + 0.78096724256424 + 0.78096724437690 + 0.78096724649093 + 0.78096724895396 + 0.78096725182554 + 0.78096725517314 + 0.78096725907680 + 0.78096726363231 + 0.78096726897159 + 0.78096727531901 + 0.78096728304812 + 0.78096729260929 + 0.78096730449830 + 0.78096731929384 + 0.78096733770532 + 0.78096736061248 + 0.78096738910047 + 0.78096742458531 + 0.78096746890749 + 0.78096752429197 + 0.78096759351460 + 0.78096768005121 + 0.78096778827025 + 0.78096792372269 + 0.78096809389800 + 0.78096830981229 + 0.78096858626087 + 0.78096894118848 + 0.78096939687925 + 0.78096998420142 + 0.78097074226099 + 0.78097172108615 + 0.78097298534149 + 0.78097461857408 + 0.78097672867767 + 0.78097945486596 + 0.78098297670466 + 0.78098753385014 + 0.78099344790145 + 0.78100113005218 + 0.78101111839227 + 0.78102411346458 + 0.78104096741791 + 0.78106232098563 + 0.78108831743059 + 0.78111945603519 + 0.78115620383064 + 0.78119798976826 + 0.78124452045510 + 0.78129635095052 + 0.78135437356144 + 0.78141971772407 + 0.78149379056445 + 0.78157849268546 + 0.78167614411663 + 0.78178949230059 + 0.78192200382947 + 0.78207808560316 + 0.78226347445611 + 0.78248641027648 + 0.78276051051359 + 0.78310501727606 + 0.78354284574878 + 0.78410297624924 + 0.78482466649736 + 0.78576057318706 + 0.78698288362856 + 0.78859246920909 + 0.79073348849613 + 0.79361831062410 + 0.79757360920850 + 0.80313711786110 + 0.81128341693807 + 0.82396893632920 + 0.84593245598813 + 0.89550546519688 + 1.00000000000000 + 0.88907174086933 + 0.84926362798893 + 0.82176269240301 + 0.80026999882448 + 0.78242854716608 + 0.76704045167081 + 0.75338719906429 + 0.74098941196038 + 0.72949869760463 + 0.71856426056427 + 0.70767791438612 + 0.69657313784691 + 0.68518075259942 + 0.67344907575555 + 0.66138027939923 + 0.64899254097561 + 0.63631492438459 + 0.62338387705231 + 0.61024116430653 + 0.59693038438705 + 0.58345557967252 + 0.56986188630325 + 0.55619809867763 + 0.54251584110761 + 0.52886771589728 + 0.51530434701989 + 0.50184981698614 + 0.48851366635302 + 0.47530995828942 + 0.46223625644146 + 0.44927200871059 + 0.77256762306183 + 0.77256763339832 + 0.77256763511122 + 0.77256763710732 + 0.77256763943510 + 0.77256764214810 + 0.77256764531072 + 0.77256764899956 + 0.77256765330431 + 0.77256765834836 + 0.77256766434528 + 0.77256767165012 + 0.77256768069161 + 0.77256769194065 + 0.77256770594393 + 0.77256772337844 + 0.77256774508039 + 0.77256777208197 + 0.77256780572839 + 0.77256784777611 + 0.77256790034124 + 0.77256796606494 + 0.77256804826394 + 0.77256815109643 + 0.77256827985520 + 0.77256844168705 + 0.77256864710412 + 0.77256891023605 + 0.77256924822567 + 0.77256968235820 + 0.77257024213428 + 0.77257096492414 + 0.77257189854338 + 0.77257310479653 + 0.77257466353534 + 0.77257667786056 + 0.77257928079737 + 0.77258264386107 + 0.77258699596472 + 0.77259264424108 + 0.77259998119472 + 0.77260952022434 + 0.77262192935520 + 0.77263802016540 + 0.77265839821712 + 0.77268318775378 + 0.77271285072728 + 0.77274781264820 + 0.77278749735169 + 0.77283158896853 + 0.77288057554529 + 0.77293525484767 + 0.77299663398082 + 0.77306596251471 + 0.77314492990273 + 0.77323558526739 + 0.77334033335423 + 0.77346219448737 + 0.77360499154611 + 0.77377368729812 + 0.77397544456313 + 0.77422225273558 + 0.77453105037057 + 0.77492177059003 + 0.77541940145455 + 0.77605762816075 + 0.77688131199960 + 0.77795148150494 + 0.77935262641492 + 0.78120408319520 + 0.78367900555027 + 0.78703851616643 + 0.79170162729855 + 0.79840219062140 + 0.80852990607382 + 0.82510088926009 + 0.85694124838795 + 0.88907174086933 + 1.00000000000000 + 0.88239268202807 + 0.84142726484508 + 0.81354278129123 + 0.79198290982966 + 0.77421310513865 + 0.75894538218292 + 0.74541027926207 + 0.73309363997019 + 0.72153902555935 + 0.71016355490300 + 0.69865974752218 + 0.68693618347379 + 0.67492608335716 + 0.66262193861401 + 0.65003490377328 + 0.63718860201440 + 0.62411499533167 + 0.61085199687784 + 0.59743982904418 + 0.58387936974747 + 0.57021333817556 + 0.55648848612767 + 0.54275474055839 + 0.52906330888105 + 0.51546366826850 + 0.50197890751523 + 0.48861773243476 + 0.47539351528143 + 0.46230319686861 + 0.44932565163059 + 0.76422308346951 + 0.76422309323349 + 0.76422309485140 + 0.76422309673715 + 0.76422309893555 + 0.76422310149817 + 0.76422310448535 + 0.76422310796906 + 0.76422311203389 + 0.76422311679924 + 0.76422312246449 + 0.76422312936671 + 0.76422313791510 + 0.76422314855402 + 0.76422316180645 + 0.76422317831306 + 0.76422319886876 + 0.76422322445742 + 0.76422325635725 + 0.76422329624334 + 0.76422334612500 + 0.76422340852596 + 0.76422348659980 + 0.76422358431299 + 0.76422370670953 + 0.76422386060842 + 0.76422405604841 + 0.76422430652609 + 0.76422462841475 + 0.76422504205850 + 0.76422557565453 + 0.76422626493407 + 0.76422715560717 + 0.76422830677119 + 0.76422979477296 + 0.76423171817630 + 0.76423420414437 + 0.76423741659889 + 0.76424157429530 + 0.76424697069795 + 0.76425398067305 + 0.76426309434781 + 0.76427494911220 + 0.76429031839253 + 0.76430977499554 + 0.76433342612920 + 0.76436169960996 + 0.76439498331909 + 0.76443269879696 + 0.76447451208675 + 0.76452085177952 + 0.76457243149114 + 0.76463014969902 + 0.76469511653029 + 0.76476883474424 + 0.76485311487144 + 0.76495006132988 + 0.76506230465446 + 0.76519315923478 + 0.76534691573622 + 0.76552980131480 + 0.76575238363966 + 0.76602959104336 + 0.76637877428099 + 0.76682148736212 + 0.76738664880211 + 0.76811250308512 + 0.76905069499742 + 0.77027210017013 + 0.77187573861379 + 0.77400329964241 + 0.77686467612354 + 0.78078929635299 + 0.78633807421524 + 0.79452437411319 + 0.80737331040309 + 0.82991907082745 + 0.84926362798893 + 0.88239268202807 + 1.00000000000000 + 0.87547909190450 + 0.83345946639162 + 0.80529192877926 + 0.78373686632080 + 0.76607817215537 + 0.75094096080467 + 0.73750459847690 + 0.72513496637696 + 0.71313344221372 + 0.70112995208178 + 0.68899891597832 + 0.67665103101149 + 0.66406454381433 + 0.65124057854804 + 0.63819523816150 + 0.62495448256951 + 0.61155121554111 + 0.59802137270576 + 0.58436190962691 + 0.57061257003371 + 0.55681761958425 + 0.54302493808839 + 0.52928406329396 + 0.51564310862940 + 0.50212399018630 + 0.48873443376954 + 0.47548700331222 + 0.46237791495592 + 0.44938537953011 + 0.75594880891800 + 0.75594881813962 + 0.75594881966796 + 0.75594882144895 + 0.75594882352524 + 0.75594882594559 + 0.75594882876684 + 0.75594883205689 + 0.75594883589664 + 0.75594884039600 + 0.75594884574692 + 0.75594885226878 + 0.75594886034875 + 0.75594887041026 + 0.75594888294993 + 0.75594889857869 + 0.75594891804932 + 0.75594894229640 + 0.75594897254358 + 0.75594901037795 + 0.75594905771742 + 0.75594911696272 + 0.75594919112382 + 0.75594928398192 + 0.75594940034456 + 0.75594954672064 + 0.75594973269428 + 0.75594997116333 + 0.75595027778260 + 0.75595067198527 + 0.75595118074551 + 0.75595183823246 + 0.75595268816831 + 0.75595378708365 + 0.75595520799762 + 0.75595704519884 + 0.75595942029876 + 0.75596249003318 + 0.75596646356720 + 0.75597162146574 + 0.75597832195611 + 0.75598703321616 + 0.75599836379073 + 0.75601305122500 + 0.75603163783475 + 0.75605421561184 + 0.75608118120223 + 0.75611288845759 + 0.75614875914962 + 0.75618844518454 + 0.75623232264598 + 0.75628103045198 + 0.75633537100288 + 0.75639633146920 + 0.75646525018212 + 0.75654372843954 + 0.75663360874271 + 0.75673718292641 + 0.75685732508617 + 0.75699774561460 + 0.75716386318341 + 0.75736500908519 + 0.75761436409488 + 0.75792705215711 + 0.75832168604524 + 0.75882312297859 + 0.75946401068008 + 0.76028812475190 + 0.76135504613259 + 0.76274716977741 + 0.76458089038704 + 0.76702585588357 + 0.77034319800813 + 0.77496720014715 + 0.78165228665449 + 0.79180943081949 + 0.80857054262579 + 0.82176269240301 + 0.84142726484508 + 0.87547909190450 + 1.00000000000000 + 0.86834479264608 + 0.82539024260873 + 0.79704185120641 + 0.77555484418268 + 0.75803289409811 + 0.74301483201036 + 0.72953995190097 + 0.71671761373149 + 0.70407684552576 + 0.69143743947777 + 0.67867535308482 + 0.66574731879269 + 0.65263982083037 + 0.63935837528597 + 0.62592078503507 + 0.61235335456932 + 0.59868651711558 + 0.58491232291856 + 0.57106682546278 + 0.55719124580910 + 0.54333098217091 + 0.52953356532400 + 0.51584548136245 + 0.50228725846361 + 0.48886546912175 + 0.47559172967816 + 0.46246141161231 + 0.44945195663509 + 0.74775249960798 + 0.74775250831778 + 0.74775250976050 + 0.74775251144284 + 0.74775251340359 + 0.74775251568870 + 0.74775251835317 + 0.74775252146043 + 0.74775252508660 + 0.74775252933579 + 0.74775253439012 + 0.74775254055248 + 0.74775254819018 + 0.74775255770710 + 0.74775256957417 + 0.74775258437029 + 0.74775260281477 + 0.74775262579549 + 0.74775265447592 + 0.74775269036908 + 0.74775273530333 + 0.74775279156469 + 0.74775286202164 + 0.74775295028274 + 0.74775306093236 + 0.74775320018264 + 0.74775337719075 + 0.74775360428856 + 0.74775389643669 + 0.74775427222450 + 0.74775475744902 + 0.74775538480787 + 0.74775619613687 + 0.74775724553130 + 0.74775860287846 + 0.74776035839749 + 0.74776262845792 + 0.74776556301240 + 0.74776936215427 + 0.74777429425919 + 0.74778070185310 + 0.74778903242346 + 0.74779986731231 + 0.74781391032539 + 0.74783167536962 + 0.74785324090131 + 0.74787897512655 + 0.74790920116893 + 0.74794334329336 + 0.74798104282870 + 0.74802262962993 + 0.74806867654785 + 0.74811990122031 + 0.74817718278121 + 0.74824171523978 + 0.74831491711949 + 0.74839840351180 + 0.74849417335236 + 0.74860472148434 + 0.74873325999594 + 0.74888451242708 + 0.74906673893705 + 0.74929160628284 + 0.74957232574414 + 0.74992500140878 + 0.75037104359875 + 0.75093838299583 + 0.75166421603569 + 0.75259877377490 + 0.75381086030656 + 0.75539652095036 + 0.75749368502495 + 0.76031103861870 + 0.76418884762678 + 0.76969881861192 + 0.77785233002158 + 0.79070788070467 + 0.80026999882448 + 0.81354278129123 + 0.83345946639162 + 0.86834479264608 + 1.00000000000000 + 0.86100684207574 + 0.81725152866300 + 0.78882187346186 + 0.76745350849058 + 0.75007066561020 + 0.73503256539563 + 0.72109956934444 + 0.70762662941762 + 0.69434168687096 + 0.68106491027898 + 0.66771949750835 + 0.65427000380431 + 0.64070671630333 + 0.62703615096153 + 0.61327578766230 + 0.59944890903797 + 0.58554136765326 + 0.57158460122872 + 0.55761607599261 + 0.54367816432340 + 0.52981597288461 + 0.51607403813482 + 0.50247124022688 + 0.48901279067421 + 0.47570919239291 + 0.46255483039286 + 0.44952625338473 + 0.73963376662196 + 0.73963377484949 + 0.73963377621256 + 0.73963377780139 + 0.73963377965313 + 0.73963378181189 + 0.73963378432858 + 0.73963378726219 + 0.73963379068710 + 0.73963379470079 + 0.73963379947596 + 0.73963380529796 + 0.73963381251995 + 0.73963382152196 + 0.73963383275427 + 0.73963384676577 + 0.73963386424160 + 0.73963388602778 + 0.73963391322716 + 0.73963394728606 + 0.73963398994476 + 0.73963404338349 + 0.73963411034086 + 0.73963419425228 + 0.73963429949843 + 0.73963443200885 + 0.73963460053267 + 0.73963481686604 + 0.73963509531750 + 0.73963545366711 + 0.73963591660323 + 0.73963651542365 + 0.73963729017876 + 0.73963829265358 + 0.73963958976467 + 0.73964126788599 + 0.73964343842121 + 0.73964624490497 + 0.73964987884344 + 0.73965459709883 + 0.73966072735694 + 0.73966869755824 + 0.73967906339314 + 0.73969249687231 + 0.73970948543848 + 0.73973009553582 + 0.73975466942011 + 0.73978350251767 + 0.73981602358322 + 0.73985186656516 + 0.73989132074420 + 0.73993490064699 + 0.73998324932978 + 0.74003715125325 + 0.74009767407725 + 0.74016607716054 + 0.74024377890235 + 0.74033252598987 + 0.74043448805688 + 0.74055245131362 + 0.74069054419572 + 0.74085610167653 + 0.74105948236312 + 0.74131226017405 + 0.74162840717785 + 0.74202641833865 + 0.74253026164893 + 0.74317164861164 + 0.74399308740845 + 0.74505228592705 + 0.74642891736611 + 0.74823586089229 + 0.75064131932955 + 0.75391502764827 + 0.75849733865891 + 0.76513066907625 + 0.77522323381132 + 0.78242854716608 + 0.79198290982966 + 0.80529192877926 + 0.82539024260873 + 0.86100684207574 + 1.00000000000000 + 0.85348568890055 + 0.80907608046052 + 0.78065702454450 + 0.75943363017071 + 0.74205169248535 + 0.72655052375328 + 0.71195651905818 + 0.69783295165016 + 0.68390578629895 + 0.67004387817991 + 0.65617788556496 + 0.64227561819819 + 0.62832764101464 + 0.61433942740064 + 0.60032483429900 + 0.58626179111621 + 0.57217590565924 + 0.55809997591152 + 0.54407266000131 + 0.53013612033482 + 0.51633254686631 + 0.50267885546522 + 0.48917864655673 + 0.47584111134726 + 0.46265948015935 + 0.44960926283411 + 0.73158418416066 + 0.73158419193216 + 0.73158419321965 + 0.73158419472073 + 0.73158419647096 + 0.73158419850916 + 0.73158420088697 + 0.73158420365845 + 0.73158420689339 + 0.73158421068518 + 0.73158421519634 + 0.73158422070016 + 0.73158422752878 + 0.73158423604659 + 0.73158424667959 + 0.73158425995125 + 0.73158427651176 + 0.73158429716809 + 0.73158432297180 + 0.73158435529984 + 0.73158439580925 + 0.73158444658308 + 0.73158451022967 + 0.73158459003225 + 0.73158469016827 + 0.73158481630226 + 0.73158497680397 + 0.73158518294790 + 0.73158544843168 + 0.73158579026590 + 0.73158623208806 + 0.73158680386583 + 0.73158754395227 + 0.73158850195033 + 0.73158974194783 + 0.73159134667862 + 0.73159342283333 + 0.73159610785846 + 0.73159958514407 + 0.73160410063030 + 0.73160996795773 + 0.73161759658498 + 0.73162751794437 + 0.73164037406003 + 0.73165662764620 + 0.73167633454392 + 0.73169981332733 + 0.73172733443509 + 0.73175833292287 + 0.73179243816798 + 0.73182990392989 + 0.73187119330695 + 0.73191688383013 + 0.73196767713330 + 0.73202453044522 + 0.73208856479619 + 0.73216102891634 + 0.73224345293512 + 0.73233772855981 + 0.73244627933813 + 0.73257272585344 + 0.73272360541692 + 0.73290814816207 + 0.73313652951965 + 0.73342091439598 + 0.73377733816060 + 0.73422644790288 + 0.73479539216490 + 0.73552031071775 + 0.73644986052371 + 0.73765054138918 + 0.73921541655189 + 0.74128131137040 + 0.74406461463962 + 0.74790988938809 + 0.75337397748027 + 0.76145203202219 + 0.76704045167081 + 0.77421310513865 + 0.78373686632080 + 0.79704185120641 + 0.81725152866300 + 0.85348568890055 + 1.00000000000000 + 0.84580519914410 + 0.80089566048431 + 0.77255674495947 + 0.75134760497212 + 0.73349662834766 + 0.71732701916126 + 0.70208050064474 + 0.68731341697716 + 0.67280214552642 + 0.65842286935636 + 0.64410917001880 + 0.62982849608829 + 0.61556965038238 + 0.60133385848955 + 0.58708878235435 + 0.57285258353570 + 0.55865220215999 + 0.54452170188024 + 0.53049964618369 + 0.51662538594595 + 0.50291348563862 + 0.48936563166831 + 0.47598946530633 + 0.46277686185994 + 0.44970211992787 + 0.72358816378296 + 0.72358817112609 + 0.72358817234247 + 0.72358817376221 + 0.72358817541480 + 0.72358817734121 + 0.72358817958782 + 0.72358818220652 + 0.72358818526295 + 0.72358818884481 + 0.72358819310761 + 0.72358819831100 + 0.72358820477094 + 0.72358821283155 + 0.72358822289928 + 0.72358823547363 + 0.72358825117188 + 0.72358827076253 + 0.72358829524811 + 0.72358832593972 + 0.72358836442083 + 0.72358841267505 + 0.72358847319293 + 0.72358854910762 + 0.72358864441107 + 0.72358876451110 + 0.72358891741683 + 0.72358911391149 + 0.72358936710811 + 0.72358969328886 + 0.72359011508721 + 0.72359066121302 + 0.72359136840468 + 0.72359228418192 + 0.72359346995078 + 0.72359500498040 + 0.72359699148844 + 0.72359956114347 + 0.72360288961607 + 0.72360721248272 + 0.72361283005696 + 0.72362013427311 + 0.72362963358039 + 0.72364194162945 + 0.72365749801386 + 0.72367634921235 + 0.72369879215662 + 0.72372507477463 + 0.72375463997201 + 0.72378711503784 + 0.72382272266974 + 0.72386188063435 + 0.72390510889374 + 0.72395303664469 + 0.72400652461861 + 0.72406657370500 + 0.72413428644598 + 0.72421100732895 + 0.72429839097978 + 0.72439855274548 + 0.72451468041949 + 0.72465262377162 + 0.72482063950431 + 0.72502770941239 + 0.72528446827213 + 0.72560487845581 + 0.72600680664891 + 0.72651360827616 + 0.72715617362681 + 0.72797577586939 + 0.72902830498560 + 0.73039111532137 + 0.73217661340475 + 0.73456054377777 + 0.73781678033249 + 0.74237165403054 + 0.74894891546021 + 0.75338719906429 + 0.75894538218292 + 0.76607817215537 + 0.77555484418268 + 0.78882187346186 + 0.80907608046052 + 0.84580519914410 + 1.00000000000000 + 0.83799181065041 + 0.79272717416580 + 0.76435942702187 + 0.74266566295465 + 0.72414520043606 + 0.70733132629270 + 0.69144774097905 + 0.67610317356171 + 0.66108184623231 + 0.64626316151592 + 0.63158003042149 + 0.61699754437220 + 0.60249967174081 + 0.58804055778280 + 0.57362872999516 + 0.55928369920470 + 0.54503379536117 + 0.53091315043820 + 0.51695765939770 + 0.50317905786046 + 0.48957674897881 + 0.47615653631976 + 0.46290870048677 + 0.44980612437702 + 0.71562456712604 + 0.71562457406489 + 0.71562457521492 + 0.71562457655513 + 0.71562457811704 + 0.71562457993787 + 0.71562458206103 + 0.71562458453518 + 0.71562458742375 + 0.71562459080985 + 0.71562459483921 + 0.71562459975851 + 0.71562460586922 + 0.71562461349929 + 0.71562462303445 + 0.71562463495052 + 0.71562464983494 + 0.71562466841860 + 0.71562469165760 + 0.71562472080413 + 0.71562475736571 + 0.71562480323605 + 0.71562486079317 + 0.71562493302753 + 0.71562502374955 + 0.71562513813373 + 0.71562528383559 + 0.71562547118339 + 0.71562571271639 + 0.71562602403114 + 0.71562642681111 + 0.71562694855401 + 0.71562762446432 + 0.71562850008068 + 0.71562963425030 + 0.71563110293818 + 0.71563300410311 + 0.71563546390629 + 0.71563865066445 + 0.71564279009316 + 0.71564816982061 + 0.71565516511149 + 0.71566426257510 + 0.71567604895018 + 0.71569094212881 + 0.71570898034396 + 0.71573044072803 + 0.71575555087157 + 0.71578376290395 + 0.71581470417917 + 0.71584857023513 + 0.71588573882029 + 0.71592667925379 + 0.71597195730399 + 0.71602234925965 + 0.71607875154057 + 0.71614214065475 + 0.71621370187199 + 0.71629488752381 + 0.71638755098292 + 0.71649451095786 + 0.71662102351649 + 0.71677450409535 + 0.71696291436330 + 0.71719559220166 + 0.71748475090537 + 0.71784592663813 + 0.71829931747038 + 0.71887147941460 + 0.71959764909329 + 0.72052514761971 + 0.72171882966973 + 0.72327199783250 + 0.72532918504609 + 0.72811150681004 + 0.73195200557378 + 0.73739142373274 + 0.74098941196038 + 0.74541027926207 + 0.75094096080467 + 0.75803289409811 + 0.76745350849058 + 0.78065702454450 + 0.80089566048431 + 0.83799181065041 + 1.00000000000000 + 0.83005614269812 + 0.78437701526774 + 0.75545690213200 + 0.73310328235338 + 0.71396835438463 + 0.69654019485499 + 0.68009675305605 + 0.66425675725117 + 0.64880952505182 + 0.63363437455991 + 0.61866167152926 + 0.60385126093978 + 0.58913916245300 + 0.57452125115544 + 0.56000749902314 + 0.54561900737102 + 0.53138440516663 + 0.51733535109764 + 0.50348015796554 + 0.48981549226108 + 0.47634497004359 + 0.46305698892938 + 0.44992277247472 + 0.70766487217433 + 0.70766487873291 + 0.70766487982004 + 0.70766488108630 + 0.70766488256336 + 0.70766488428455 + 0.70766488629038 + 0.70766488862888 + 0.70766489135929 + 0.70766489455892 + 0.70766489836712 + 0.70766490301918 + 0.70766490880064 + 0.70766491602464 + 0.70766492505579 + 0.70766493634904 + 0.70766495046237 + 0.70766496809205 + 0.70766499015246 + 0.70766501783272 + 0.70766505257366 + 0.70766509618323 + 0.70766515092982 + 0.70766521966895 + 0.70766530604171 + 0.70766541499413 + 0.70766555384748 + 0.70766573248849 + 0.70766596292248 + 0.70766626007992 + 0.70766664473420 + 0.70766714323029 + 0.70766778930167 + 0.70766862659092 + 0.70766971149712 + 0.70767111682574 + 0.70767293645549 + 0.70767529128491 + 0.70767834260584 + 0.70768230669267 + 0.70768745906614 + 0.70769415906715 + 0.70770287246486 + 0.70771416036239 + 0.70772842020873 + 0.70774568299169 + 0.70776620763895 + 0.70779020333398 + 0.70781713262112 + 0.70784662477225 + 0.70787885153458 + 0.70791415521055 + 0.70795296041995 + 0.70799577720617 + 0.70804330768635 + 0.70809635712291 + 0.70815579301104 + 0.70822266363736 + 0.70829824820908 + 0.70838417670937 + 0.70848295194432 + 0.70859931502280 + 0.70873995109677 + 0.70891194645249 + 0.70912353552412 + 0.70938544996872 + 0.70971126455034 + 0.71011853785227 + 0.71063023056276 + 0.71127661882858 + 0.71209806311989 + 0.71314940555691 + 0.71450888255387 + 0.71629681322237 + 0.71869442669287 + 0.72196698551501 + 0.72652899960178 + 0.72949869760463 + 0.73309363997019 + 0.73750459847690 + 0.74301483201036 + 0.75007066561020 + 0.75943363017071 + 0.77255674495947 + 0.79272717416580 + 0.83005614269812 + 1.00000000000000 + 0.82171627839483 + 0.77510250972583 + 0.74553709997610 + 0.72264287109561 + 0.70295002413020 + 0.68500088245173 + 0.66808945951551 + 0.65184523519709 + 0.63606020012008 + 0.62061195783522 + 0.60542566667213 + 0.59041248837973 + 0.57555137870509 + 0.56083987857752 + 0.54628986224842 + 0.53192305369769 + 0.51776587324414 + 0.50382246189332 + 0.49008618583547 + 0.47655804364327 + 0.46322419961584 + 0.45005392487073 + 0.69960840778446 + 0.69960841397982 + 0.69960841500679 + 0.69960841620289 + 0.69960841759782 + 0.69960841922331 + 0.69960842111816 + 0.69960842332679 + 0.69960842590520 + 0.69960842892695 + 0.69960843252557 + 0.69960843692279 + 0.69960844238916 + 0.69960844922292 + 0.69960845777304 + 0.69960846846898 + 0.69960848184393 + 0.69960849856064 + 0.69960851948801 + 0.69960854576214 + 0.69960857875513 + 0.69960862019092 + 0.69960867223396 + 0.69960873761180 + 0.69960881979946 + 0.69960892351987 + 0.69960905577280 + 0.69960922601646 + 0.69960944573954 + 0.69960972922611 + 0.69961009636334 + 0.69961057237997 + 0.69961118958171 + 0.69961198976370 + 0.69961302695141 + 0.69961437087754 + 0.69961611146614 + 0.69961836450063 + 0.69962128445048 + 0.69962507842610 + 0.69963001020277 + 0.69963642367625 + 0.69964476442779 + 0.69965556876200 + 0.69966921456317 + 0.69968572637328 + 0.69970534615749 + 0.69972826618999 + 0.69975396062014 + 0.69978206230175 + 0.69981272188949 + 0.69984624986535 + 0.69988303085013 + 0.69992352524772 + 0.69996836911780 + 0.70001828707689 + 0.70007405110222 + 0.70013659009131 + 0.70020703316153 + 0.70028681735712 + 0.70037817138036 + 0.70048538305421 + 0.70061449422521 + 0.70077182936390 + 0.70096467106039 + 0.70120247845858 + 0.70149715259036 + 0.70186401438674 + 0.70232299926112 + 0.70290024668066 + 0.70363037564363 + 0.70456007759442 + 0.70575549890766 + 0.70731780698586 + 0.70939741934402 + 0.71220915682874 + 0.71607798156729 + 0.71856426056427 + 0.72153902555935 + 0.72513496637696 + 0.72953995190097 + 0.73503256539563 + 0.74205169248535 + 0.75134760497212 + 0.76435942702187 + 0.78437701526774 + 0.82171627839483 + 1.00000000000000 + 0.81214423918529 + 0.76470100250206 + 0.73471448725476 + 0.71136313719173 + 0.69121291440559 + 0.67283386597750 + 0.65554362665041 + 0.63898122577105 + 0.62293952269222 + 0.60729156236702 + 0.59191314956736 + 0.57675990252281 + 0.56181271361741 + 0.54707138652783 + 0.53254878497442 + 0.51826471700346 + 0.50421814093446 + 0.49039837164023 + 0.47680322347588 + 0.46341617033544 + 0.45020415169463 + 0.69116872158509 + 0.69116872742078 + 0.69116872838728 + 0.69116872951433 + 0.69116873082774 + 0.69116873235890 + 0.69116873414371 + 0.69116873622471 + 0.69116873865293 + 0.69116874149974 + 0.69116874488959 + 0.69116874903396 + 0.69116875418851 + 0.69116876063622 + 0.69116876870710 + 0.69116877881161 + 0.69116879145265 + 0.69116880726088 + 0.69116882706157 + 0.69116885193485 + 0.69116888318518 + 0.69116892245288 + 0.69116897179765 + 0.69116903381511 + 0.69116911181636 + 0.69116921030039 + 0.69116933594417 + 0.69116949777056 + 0.69116970674004 + 0.69116997649271 + 0.69117032601844 + 0.69117077940842 + 0.69117136752373 + 0.69117213029853 + 0.69117311934087 + 0.69117440128577 + 0.69117606203469 + 0.69117821219714 + 0.69118099933011 + 0.69118462127156 + 0.69118932989114 + 0.69119545346862 + 0.69120341717036 + 0.69121373226253 + 0.69122675709939 + 0.69124251029003 + 0.69126121729710 + 0.69128305423573 + 0.69130750849851 + 0.69133421830542 + 0.69136331494789 + 0.69139507925458 + 0.69142985869643 + 0.69146806782587 + 0.69151028166180 + 0.69155715087014 + 0.69160936076352 + 0.69166773259904 + 0.69173326093438 + 0.69180721052992 + 0.69189156383378 + 0.69199019461907 + 0.69210855662961 + 0.69225228735370 + 0.69242781938770 + 0.69264348065055 + 0.69290969428887 + 0.69323981846999 + 0.69365115458738 + 0.69416627188392 + 0.69481488610891 + 0.69563681469667 + 0.69668814105209 + 0.69805429009551 + 0.69986089586790 + 0.70228362412119 + 0.70558100206640 + 0.70767791438612 + 0.71016355490300 + 0.71313344221372 + 0.71671761373149 + 0.72109956934444 + 0.72655052375328 + 0.73349662834766 + 0.74266566295465 + 0.75545690213200 + 0.77510250972583 + 0.81214423918529 + 1.00000000000000 + 0.80180741869343 + 0.75377292046881 + 0.72338881983142 + 0.69962062247823 + 0.67905064551621 + 0.66028985030431 + 0.64267619932004 + 0.62585309772277 + 0.60960897803678 + 0.59376583229393 + 0.57824507513603 + 0.56300401249007 + 0.54802579702714 + 0.53331133187024 + 0.51887166124958 + 0.50469899404604 + 0.49077744038815 + 0.47710076801416 + 0.46364906998116 + 0.45038638440060 + 0.68219709917272 + 0.68219710464720 + 0.68219710555361 + 0.68219710661160 + 0.68219710784371 + 0.68219710928003 + 0.68219711095410 + 0.68219711290648 + 0.68219711518430 + 0.68219711785495 + 0.68219712103595 + 0.68219712492548 + 0.68219712976686 + 0.68219713582646 + 0.68219714341725 + 0.68219715292322 + 0.68219716482351 + 0.68219717971611 + 0.68219719837735 + 0.68219722183319 + 0.68219725131890 + 0.68219728838976 + 0.68219733499792 + 0.68219739360362 + 0.68219746735210 + 0.68219756051095 + 0.68219767942377 + 0.68219783266808 + 0.68219803066835 + 0.68219828639271 + 0.68219861790737 + 0.68219904813748 + 0.68219960645595 + 0.68220033087020 + 0.68220127050714 + 0.68220248879491 + 0.68220406749453 + 0.68220611188520 + 0.68220876239828 + 0.68221220730597 + 0.68221668621592 + 0.68222251133371 + 0.68223008680440 + 0.68223989818551 + 0.68225228397886 + 0.68226725726558 + 0.68228502718902 + 0.68230575414732 + 0.68232894066923 + 0.68235423218267 + 0.68238174196603 + 0.68241172277365 + 0.68244448702744 + 0.68248040624376 + 0.68251999809365 + 0.68256384432424 + 0.68261255040678 + 0.68266683901322 + 0.68272758218904 + 0.68279588837775 + 0.68287351502322 + 0.68296395084401 + 0.68307210239742 + 0.68320297703973 + 0.68336223555696 + 0.68355718321386 + 0.68379691598375 + 0.68409304061304 + 0.68446052443982 + 0.68491879873673 + 0.68549331117796 + 0.68621796317503 + 0.68714027710610 + 0.68833242427468 + 0.68989957049835 + 0.69198608025129 + 0.69479952163445 + 0.69657313784691 + 0.69865974752218 + 0.70112995208178 + 0.70407684552576 + 0.70762662941762 + 0.71195651905818 + 0.71732701916126 + 0.72414520043606 + 0.73310328235338 + 0.74553709997610 + 0.76470100250206 + 0.80180741869343 + 1.00000000000000 + 0.79118562432498 + 0.74256347557370 + 0.71178378181896 + 0.68759030640845 + 0.66661348455717 + 0.64750274588361 + 0.62960700214519 + 0.61256526943966 + 0.59611199345539 + 0.58011560678538 + 0.56449836570870 + 0.54921946291729 + 0.53426303085235 + 0.51962809023545 + 0.50529777850506 + 0.49124932233268 + 0.47747120697420 + 0.46393916984813 + 0.45061355357015 + 0.67267963834072 + 0.67267964345425 + 0.67267964430104 + 0.67267964528863 + 0.67267964643924 + 0.67267964778068 + 0.67267964934438 + 0.67267965116785 + 0.67267965329504 + 0.67267965578957 + 0.67267965876146 + 0.67267966239733 + 0.67267966692482 + 0.67267967259519 + 0.67267967970250 + 0.67267968860900 + 0.67267969976622 + 0.67267971373402 + 0.67267973124878 + 0.67267975327508 + 0.67267978098038 + 0.67267981583024 + 0.67267985967062 + 0.67267991482382 + 0.67267998426165 + 0.67268007202043 + 0.67268018410292 + 0.67268032862656 + 0.67268051546568 + 0.67268075689977 + 0.67268107005255 + 0.67268147664537 + 0.67268200452499 + 0.67268268971764 + 0.67268357880187 + 0.67268473190529 + 0.67268622654723 + 0.67268816251384 + 0.67269067291882 + 0.67269393620937 + 0.67269817940429 + 0.67270369820724 + 0.67271087521445 + 0.67272016965737 + 0.67273189993643 + 0.67274607402982 + 0.67276288499877 + 0.67278247802045 + 0.67280437257787 + 0.67282822310143 + 0.67285412620714 + 0.67288230813028 + 0.67291304831937 + 0.67294667798663 + 0.67298366103201 + 0.67302451507398 + 0.67306977217043 + 0.67312006484053 + 0.67317615371794 + 0.67323900552528 + 0.67331017207192 + 0.67339278392905 + 0.67349123867572 + 0.67360996585158 + 0.67375392554892 + 0.67392949852457 + 0.67414458852256 + 0.67440923818536 + 0.67473634368658 + 0.67514257205274 + 0.67564964337278 + 0.67628634323471 + 0.67709286326048 + 0.67813012152759 + 0.67948618957547 + 0.68128003069770 + 0.68367933402924 + 0.68518075259942 + 0.68693618347379 + 0.68899891597832 + 0.69143743947777 + 0.69434168687096 + 0.69783295165016 + 0.70208050064474 + 0.70733132629270 + 0.71396835438463 + 0.72264287109561 + 0.73471448725476 + 0.75377292046881 + 0.79118562432498 + 1.00000000000000 + 0.78023313525195 + 0.73111243430193 + 0.69992538462819 + 0.67530277039285 + 0.65394104818077 + 0.63451787040236 + 0.61638046440228 + 0.59911020556784 + 0.58248887133048 + 0.56638435362462 + 0.55072014968771 + 0.53545619500299 + 0.52057461936280 + 0.50604612837691 + 0.49183869709157 + 0.47793382096613 + 0.46430156289097 + 0.45089751494643 + 0.66260446752219 + 0.66260447227550 + 0.66260447306296 + 0.66260447398063 + 0.66260447505006 + 0.66260447629753 + 0.66260447775100 + 0.66260447944566 + 0.66260448142328 + 0.66260448374176 + 0.66260448650491 + 0.66260448988749 + 0.66260449410148 + 0.66260449938273 + 0.66260450600617 + 0.66260451431220 + 0.66260452472290 + 0.66260453776395 + 0.66260455412583 + 0.66260457471584 + 0.66260460062739 + 0.66260463324150 + 0.66260467429019 + 0.66260472596105 + 0.66260479104465 + 0.66260487334299 + 0.66260497851184 + 0.66260511420157 + 0.66260528971834 + 0.66260551664680 + 0.66260581113514 + 0.66260619368575 + 0.66260669057046 + 0.66260733579747 + 0.66260817332412 + 0.66260925990891 + 0.66261066871657 + 0.66261249391813 + 0.66261486113318 + 0.66261793875012 + 0.66262194091194 + 0.66262714644277 + 0.66263391593525 + 0.66264268177041 + 0.66265374205953 + 0.66266710013564 + 0.66268293324834 + 0.66270137192596 + 0.66272195432817 + 0.66274434561804 + 0.66276862708168 + 0.66279500001452 + 0.66282371292686 + 0.66285505942814 + 0.66288945310687 + 0.66292735209403 + 0.66296922113622 + 0.66301561056591 + 0.66306717995979 + 0.66312476782127 + 0.66318973828286 + 0.66326488912730 + 0.66335414515237 + 0.66346140691689 + 0.66359099947695 + 0.66374846910329 + 0.66394064996826 + 0.66417618931095 + 0.66446614629513 + 0.66482475242344 + 0.66527046844973 + 0.66582764534157 + 0.66653017218303 + 0.66742935658156 + 0.66859887466068 + 0.67013682761343 + 0.67217916080183 + 0.67344907575555 + 0.67492608335716 + 0.67665103101149 + 0.67867535308482 + 0.68106491027898 + 0.68390578629895 + 0.68731341697716 + 0.69144774097905 + 0.69654019485499 + 0.70295002413020 + 0.71136313719173 + 0.72338881983142 + 0.74256347557370 + 0.78023313525195 + 1.00000000000000 + 0.76908062243840 + 0.71948483548488 + 0.68785956790991 + 0.66280628559664 + 0.64108605201184 + 0.62138576728407 + 0.60299099269963 + 0.58553118805151 + 0.56878513366903 + 0.55262074940261 + 0.53696177618511 + 0.52176589531808 + 0.50698634946934 + 0.49257842049062 + 0.47851419270226 + 0.46475622809917 + 0.45125393753910 + 0.65199821567565 + 0.65199822007265 + 0.65199822080095 + 0.65199822164975 + 0.65199822263937 + 0.65199822379281 + 0.65199822513722 + 0.65199822670464 + 0.65199822853375 + 0.65199823067919 + 0.65199823323562 + 0.65199823636505 + 0.65199824026833 + 0.65199824516308 + 0.65199825130623 + 0.65199825901437 + 0.65199826868147 + 0.65199828079961 + 0.65199829601176 + 0.65199831516738 + 0.65199833929015 + 0.65199836966688 + 0.65199840792175 + 0.65199845610124 + 0.65199851681853 + 0.65199859363795 + 0.65199869185842 + 0.65199881866194 + 0.65199898278259 + 0.65199919508887 + 0.65199947074940 + 0.65199982902200 + 0.65200029458320 + 0.65200089938138 + 0.65200168472555 + 0.65200270394102 + 0.65200402576899 + 0.65200573868007 + 0.65200796067556 + 0.65201084993409 + 0.65201460752623 + 0.65201949516663 + 0.65202585113478 + 0.65203408066684 + 0.65204446154573 + 0.65205699294999 + 0.65207183672732 + 0.65208910940046 + 0.65210836937317 + 0.65212929410875 + 0.65215195095124 + 0.65217651791888 + 0.65220321472236 + 0.65223230013181 + 0.65226414100845 + 0.65229914066875 + 0.65233770260807 + 0.65238030278032 + 0.65242750975558 + 0.65248004681858 + 0.65253910778571 + 0.65260718290434 + 0.65268776037495 + 0.65278425944471 + 0.65290043325724 + 0.65304107951363 + 0.65321207867454 + 0.65342084027881 + 0.65367680295295 + 0.65399206260079 + 0.65438224151514 + 0.65486785779275 + 0.65547739044045 + 0.65625393971983 + 0.65725903331695 + 0.65857354509347 + 0.66030789818475 + 0.66138027939923 + 0.66262193861401 + 0.66406454381433 + 0.66574731879269 + 0.66771949750835 + 0.67004387817991 + 0.67280214552642 + 0.67610317356171 + 0.68009675305605 + 0.68500088245173 + 0.69121291440559 + 0.69962062247823 + 0.71178378181896 + 0.73111243430193 + 0.76908062243840 + 1.00000000000000 + 0.75775104243836 + 0.70768706017931 + 0.67559863850957 + 0.65012719696485 + 0.62807995581428 + 0.60808241111366 + 0.58946947150411 + 0.57186343691400 + 0.55504101373074 + 0.53886949670211 + 0.52326997097888 + 0.50817047622326 + 0.49350849287210 + 0.47924320386210 + 0.46532711111578 + 0.45170148870279 + 0.64089824232285 + 0.64089824636896 + 0.64089824703890 + 0.64089824782005 + 0.64089824873066 + 0.64089824979237 + 0.64089825102953 + 0.64089825247210 + 0.64089825415558 + 0.64089825612957 + 0.64089825848245 + 0.64089826136600 + 0.64089826496287 + 0.64089826947646 + 0.64089827514591 + 0.64089828226377 + 0.64089829119692 + 0.64089830240080 + 0.64089831647584 + 0.64089833420984 + 0.64089835655486 + 0.64089838471186 + 0.64089842019168 + 0.64089846489995 + 0.64089852127346 + 0.64089859263467 + 0.64089868393106 + 0.64089880186923 + 0.64089895460354 + 0.64089915229585 + 0.64089940911445 + 0.64089974306771 + 0.64090017722729 + 0.64090074147210 + 0.64090147443196 + 0.64090242597796 + 0.64090366039667 + 0.64090526041188 + 0.64090733636365 + 0.64091003613900 + 0.64091354766234 + 0.64091811544176 + 0.64092405534624 + 0.64093174537537 + 0.64094144315060 + 0.64095314419170 + 0.64096699547385 + 0.64098310026173 + 0.64100103853315 + 0.64102050144983 + 0.64104154381933 + 0.64106432211289 + 0.64108902945350 + 0.64111589260225 + 0.64114523533817 + 0.64117741087389 + 0.64121276742156 + 0.64125171417503 + 0.64129473841172 + 0.64134246067227 + 0.64139592125446 + 0.64145732799808 + 0.64152976855578 + 0.64161622732174 + 0.64171994610620 + 0.64184505597825 + 0.64199659309009 + 0.64218087684560 + 0.64240592585955 + 0.64268197514641 + 0.64302218892081 + 0.64344378822036 + 0.64397062476667 + 0.64463880586406 + 0.64549961257719 + 0.64661966173394 + 0.64808873213973 + 0.64899254097561 + 0.65003490377328 + 0.65124057854804 + 0.65263982083037 + 0.65427000380431 + 0.65617788556496 + 0.65842286935636 + 0.66108184623231 + 0.66425675725117 + 0.66808945951551 + 0.67283386597750 + 0.67905064551621 + 0.68759030640845 + 0.69992538462819 + 0.71948483548488 + 0.75775104243836 + 1.00000000000000 + 0.74626689434572 + 0.69572720138938 + 0.66316151285038 + 0.63729306949948 + 0.61489143263185 + 0.59463655156005 + 0.57584903051883 + 0.55814530641845 + 0.54129989638334 + 0.52517677760658 + 0.50966638454892 + 0.49468055273313 + 0.48016038710078 + 0.46604465618750 + 0.45226376973423 + 0.62935023323344 + 0.62935023693733 + 0.62935023755099 + 0.62935023826640 + 0.62935023910011 + 0.62935024007192 + 0.62935024120468 + 0.62935024252501 + 0.62935024406602 + 0.62935024587349 + 0.62935024802856 + 0.62935025066927 + 0.62935025396812 + 0.62935025810889 + 0.62935026331351 + 0.62935026985339 + 0.62935027806641 + 0.62935028837563 + 0.62935030133315 + 0.62935031767034 + 0.62935033826876 + 0.62935036424057 + 0.62935039698542 + 0.62935043827115 + 0.62935049035775 + 0.62935055632892 + 0.62935064078000 + 0.62935074994270 + 0.62935089140178 + 0.62935107459850 + 0.62935131272267 + 0.62935162252276 + 0.62935202547466 + 0.62935254938387 + 0.62935323020976 + 0.62935411437139 + 0.62935526170683 + 0.62935674920504 + 0.62935867955607 + 0.62936119038182 + 0.62936445649519 + 0.62936870525037 + 0.62937423021360 + 0.62938138231269 + 0.62939039932488 + 0.62940127363080 + 0.62941413797010 + 0.62942908319062 + 0.62944571189821 + 0.62946373012369 + 0.62948318155593 + 0.62950420288681 + 0.62952696290839 + 0.62955165920755 + 0.62957857615912 + 0.62960802151687 + 0.62964029404343 + 0.62967574350631 + 0.62971478516057 + 0.62975794867071 + 0.62980613690492 + 0.62986130003461 + 0.62992616073415 + 0.63000331331956 + 0.63009554587425 + 0.63020640022128 + 0.63034017067294 + 0.63050222353166 + 0.63069934200114 + 0.63094015057059 + 0.63123569818258 + 0.63160038552918 + 0.63205412494306 + 0.63262708659326 + 0.63336192739678 + 0.63431346463504 + 0.63555472534957 + 0.63631492438459 + 0.63718860201440 + 0.63819523816150 + 0.63935837528597 + 0.64070671630333 + 0.64227561819819 + 0.64410917001880 + 0.64626316151592 + 0.64880952505182 + 0.65184523519709 + 0.65554362665041 + 0.66028985030431 + 0.66661348455717 + 0.67530277039285 + 0.68785956790991 + 0.70768706017931 + 0.74626689434572 + 1.00000000000000 + 0.73465005619451 + 0.68361651490641 + 0.65056850772131 + 0.62426118173291 + 0.60154652336681 + 0.58107880540581 + 0.56216567754068 + 0.54441843963397 + 0.52760715095440 + 0.51156376395780 + 0.49616192817137 + 0.48131672978953 + 0.46694778022309 + 0.45297072895104 + 0.61740617598027 + 0.61740617935380 + 0.61740617991230 + 0.61740618056386 + 0.61740618132322 + 0.61740618220762 + 0.61740618323931 + 0.61740618444210 + 0.61740618584606 + 0.61740618749244 + 0.61740618945488 + 0.61740619186189 + 0.61740619487050 + 0.61740619865025 + 0.61740620340550 + 0.61740620938381 + 0.61740621689761 + 0.61740622633452 + 0.61740623820484 + 0.61740625318073 + 0.61740627207518 + 0.61740629591219 + 0.61740632598459 + 0.61740636392239 + 0.61740641181399 + 0.61740647250517 + 0.61740655024514 + 0.61740665079849 + 0.61740678118053 + 0.61740695013249 + 0.61740716986144 + 0.61740745588110 + 0.61740782808044 + 0.61740831221923 + 0.61740894160599 + 0.61740975925130 + 0.61741082058600 + 0.61741219692944 + 0.61741398340066 + 0.61741630746700 + 0.61741933098510 + 0.61742326437112 + 0.61742837917549 + 0.61743499966970 + 0.61744334426735 + 0.61745340273785 + 0.61746529430642 + 0.61747909830540 + 0.61749444073584 + 0.61751104342706 + 0.61752894031863 + 0.61754825011805 + 0.61756911951267 + 0.61759171972938 + 0.61761629935288 + 0.61764312522445 + 0.61767245221316 + 0.61770457762365 + 0.61773985341841 + 0.61777872946844 + 0.61782198642618 + 0.61787134080154 + 0.61792918482573 + 0.61799776526867 + 0.61807947045350 + 0.61817732504353 + 0.61829497614924 + 0.61843696262915 + 0.61860900019493 + 0.61881832861924 + 0.61907418770486 + 0.61938857895433 + 0.61977807685958 + 0.62026783016545 + 0.62089325662760 + 0.62169941676348 + 0.62274572267986 + 0.62338387705231 + 0.62411499533167 + 0.62495448256951 + 0.62592078503507 + 0.62703615096153 + 0.62832764101464 + 0.62982849608829 + 0.63158003042149 + 0.63363437455991 + 0.63606020012008 + 0.63898122577105 + 0.64267619932004 + 0.64750274588361 + 0.65394104818077 + 0.66280628559664 + 0.67559863850957 + 0.69572720138938 + 0.73465005619451 + 1.00000000000000 + 0.72292159176202 + 0.67136409975000 + 0.63775678471460 + 0.61105366590150 + 0.58807277947889 + 0.56744224843031 + 0.54845872968489 + 0.53072697902643 + 0.51398311398650 + 0.49804153788467 + 0.48277863861677 + 0.46808659037782 + 0.45386055946424 + 0.60512283634016 + 0.60512283939600 + 0.60512283990247 + 0.60512284049280 + 0.60512284118008 + 0.60512284198191 + 0.60512284291686 + 0.60512284400640 + 0.60512284527813 + 0.60512284676915 + 0.60512284854823 + 0.60512285073104 + 0.60512285346039 + 0.60512285689333 + 0.60512286121495 + 0.60512286665335 + 0.60512287349145 + 0.60512288208701 + 0.60512289290519 + 0.60512290656332 + 0.60512292380884 + 0.60512294557945 + 0.60512297306235 + 0.60512300775367 + 0.60512305157283 + 0.60512310713398 + 0.60512317835000 + 0.60512327052547 + 0.60512339011849 + 0.60512354518453 + 0.60512374696734 + 0.60512400976904 + 0.60512435192292 + 0.60512479718078 + 0.60512537625409 + 0.60512612880272 + 0.60512710594023 + 0.60512837341953 + 0.60513001894316 + 0.60513216002155 + 0.60513494581605 + 0.60513857016908 + 0.60514328309451 + 0.60514938284247 + 0.60515706910010 + 0.60516632952680 + 0.60517727063765 + 0.60518996118571 + 0.60520405102028 + 0.60521927844188 + 0.60523566894945 + 0.60525332501722 + 0.60527237341621 + 0.60529296172005 + 0.60531530623626 + 0.60533963722890 + 0.60536617090105 + 0.60539515857154 + 0.60542689697861 + 0.60546176640677 + 0.60550043942852 + 0.60554442184398 + 0.60559580839067 + 0.60565653804065 + 0.60572864908966 + 0.60581471511587 + 0.60591782210492 + 0.60604179494864 + 0.60619143246991 + 0.60637279065969 + 0.60659357032164 + 0.60686374195745 + 0.60719706370657 + 0.60761445177941 + 0.60814526208824 + 0.60882649526557 + 0.60970648550139 + 0.61024116430653 + 0.61085199687784 + 0.61155121554111 + 0.61235335456932 + 0.61327578766230 + 0.61433942740064 + 0.61556965038238 + 0.61699754437220 + 0.61866167152926 + 0.62061195783522 + 0.62293952269222 + 0.62585309772277 + 0.62960700214519 + 0.63451787040236 + 0.64108605201184 + 0.65012719696485 + 0.66316151285038 + 0.68361651490641 + 0.72292159176202 + 1.00000000000000 + 0.71109055369557 + 0.65886720824613 + 0.62474138968128 + 0.59769411434321 + 0.57449963636797 + 0.55376309068532 + 0.53477048044633 + 0.51708985321088 + 0.50043878547003 + 0.48463371381419 + 0.46952622212667 + 0.45498230427332 + 0.59255836251746 + 0.59255836527122 + 0.59255836572766 + 0.59255836625954 + 0.59255836687941 + 0.59255836760182 + 0.59255836844417 + 0.59255836942608 + 0.59255837057209 + 0.59255837191582 + 0.59255837351965 + 0.59255837548857 + 0.59255837795263 + 0.59255838105467 + 0.59255838496119 + 0.59255838988159 + 0.59255839607425 + 0.59255840386383 + 0.59255841367526 + 0.59255842607107 + 0.59255844173182 + 0.59255846151706 + 0.59255848650803 + 0.59255851807552 + 0.59255855797057 + 0.59255860858924 + 0.59255867351106 + 0.59255875759469 + 0.59255886676497 + 0.59255900840041 + 0.59255919281747 + 0.59255943313331 + 0.59255974617002 + 0.59256015372238 + 0.59256068398073 + 0.59256137334344 + 0.59256226872368 + 0.59256343046796 + 0.59256493905611 + 0.59256690233047 + 0.59256945712141 + 0.59257278117366 + 0.59257710363174 + 0.59258269755028 + 0.59258974465715 + 0.59259823097526 + 0.59260825115609 + 0.59261986431636 + 0.59263274431262 + 0.59264664630187 + 0.59266158858560 + 0.59267765907457 + 0.59269496671676 + 0.59271363799738 + 0.59273386028462 + 0.59275583133675 + 0.59277973350768 + 0.59280577805636 + 0.59283421381601 + 0.59286536072236 + 0.59289979621453 + 0.59293883692182 + 0.59298431103818 + 0.59303788624207 + 0.59310129587629 + 0.59317672200567 + 0.59326676652596 + 0.59337464124648 + 0.59350436113904 + 0.59366097470855 + 0.59385087894893 + 0.59408233140444 + 0.59436672124412 + 0.59472140569367 + 0.59517067272711 + 0.59574486695973 + 0.59648329569428 + 0.59693038438705 + 0.59743982904418 + 0.59802137270576 + 0.59868651711558 + 0.59944890903797 + 0.60032483429900 + 0.60133385848955 + 0.60249967174081 + 0.60385126093978 + 0.60542566667213 + 0.60729156236702 + 0.60960897803678 + 0.61256526943966 + 0.61638046440228 + 0.62138576728407 + 0.62807995581428 + 0.63729306949948 + 0.65056850772131 + 0.67136409975000 + 0.71109055369557 + 1.00000000000000 + 0.69897611983121 + 0.64612974983205 + 0.61154276034102 + 0.58420956706407 + 0.56086077011833 + 0.54008205879639 + 0.52111846622660 + 0.50351824411856 + 0.48700003011217 + 0.47135288344435 + 0.45639989448888 + 0.57973233197550 + 0.57973233444358 + 0.57973233485183 + 0.57973233532868 + 0.57973233588402 + 0.57973233653152 + 0.57973233728590 + 0.57973233816570 + 0.57973233919273 + 0.57973234039679 + 0.57973234183424 + 0.57973234360019 + 0.57973234581189 + 0.57973234859804 + 0.57973235211120 + 0.57973235653948 + 0.57973236211701 + 0.57973236913764 + 0.57973237798693 + 0.57973238917589 + 0.57973240332277 + 0.57973242120745 + 0.57973244381431 + 0.57973247238555 + 0.57973250851707 + 0.57973255439084 + 0.57973261326523 + 0.57973268957136 + 0.57973278871053 + 0.57973291741092 + 0.57973308509072 + 0.57973330372172 + 0.57973358866155 + 0.57973395981210 + 0.57973444291588 + 0.57973507121962 + 0.57973588756645 + 0.57973694706578 + 0.57973832322178 + 0.57974011451295 + 0.57974244584882 + 0.57974547943295 + 0.57974942426111 + 0.57975452911673 + 0.57976095858078 + 0.57976869746631 + 0.57977782940080 + 0.57978840476513 + 0.57980012135852 + 0.57981275140205 + 0.57982630709355 + 0.57984086334034 + 0.57985651317011 + 0.57987336432619 + 0.57989157827642 + 0.57991132395246 + 0.57993275414798 + 0.57995604530684 + 0.57998140479009 + 0.58000910028651 + 0.58003962555303 + 0.58007412752254 + 0.58011419575982 + 0.58016125904574 + 0.58021678532736 + 0.58028261719448 + 0.58036093931676 + 0.58045443755781 + 0.58056645729707 + 0.58070119011395 + 0.58086392885567 + 0.58106148630878 + 0.58130325790485 + 0.58160360475986 + 0.58198256986017 + 0.58246498489764 + 0.58308276856946 + 0.58345557967252 + 0.58387936974747 + 0.58436190962691 + 0.58491232291856 + 0.58554136765326 + 0.58626179111621 + 0.58708878235435 + 0.58804055778280 + 0.58913916245300 + 0.59041248837973 + 0.59191314956736 + 0.59376583229393 + 0.59611199345539 + 0.59911020556784 + 0.60299099269963 + 0.60808241111366 + 0.61489143263185 + 0.62426118173291 + 0.63775678471460 + 0.65886720824613 + 0.69897611983121 + 1.00000000000000 + 0.68672845671119 + 0.63324464669435 + 0.59823641525721 + 0.57066657109144 + 0.54722096219103 + 0.52643424528856 + 0.50752898120497 + 0.49005257057863 + 0.47369234884071 + 0.45820550660732 + 0.56670171893877 + 0.56670172113652 + 0.56670172150028 + 0.56670172192475 + 0.56670172241954 + 0.56670172299617 + 0.56670172366822 + 0.56670172445192 + 0.56670172536657 + 0.56670172643963 + 0.56670172772014 + 0.56670172929515 + 0.56670173126859 + 0.56670173375745 + 0.56670173689820 + 0.56670174085991 + 0.56670174585479 + 0.56670175214616 + 0.56670176008407 + 0.56670177012776 + 0.56670178283608 + 0.56670179891325 + 0.56670181925035 + 0.56670184497177 + 0.56670187751953 + 0.56670191886829 + 0.56670197197413 + 0.56670204085552 + 0.56670213041134 + 0.56670224674645 + 0.56670239841393 + 0.56670259628431 + 0.56670285431133 + 0.56670319057413 + 0.56670362846911 + 0.56670419820927 + 0.56670493872971 + 0.56670590011554 + 0.56670714916847 + 0.56670877538270 + 0.56671089223743 + 0.56671364704368 + 0.56671722950523 + 0.56672186521793 + 0.56672770250233 + 0.56673472535528 + 0.56674300723415 + 0.56675259065472 + 0.56676319702085 + 0.56677461557209 + 0.56678685340258 + 0.56679997386811 + 0.56681405586365 + 0.56682919055555 + 0.56684551635320 + 0.56686317673422 + 0.56688229880569 + 0.56690302889776 + 0.56692553863427 + 0.56695005063737 + 0.56697698530642 + 0.56700733787156 + 0.56704248503452 + 0.56708364592696 + 0.56713205830562 + 0.56718927138823 + 0.56725711141137 + 0.56733781445013 + 0.56743415560486 + 0.56754959960940 + 0.56768850659164 + 0.56785647344771 + 0.56806122052802 + 0.56831458967815 + 0.56863307018708 + 0.56903692565886 + 0.56955201627905 + 0.56986188630325 + 0.57021333817556 + 0.57061257003371 + 0.57106682546278 + 0.57158460122872 + 0.57217590565924 + 0.57285258353570 + 0.57362872999516 + 0.57452125115544 + 0.57555137870509 + 0.57675990252281 + 0.57824507513603 + 0.58011560678538 + 0.58248887133048 + 0.58553118805151 + 0.58946947150411 + 0.59463655156005 + 0.60154652336681 + 0.61105366590150 + 0.62474138968128 + 0.64612974983205 + 0.68672845671119 + 1.00000000000000 + 0.67435835250141 + 0.62023687542765 + 0.58485340249951 + 0.55710232439590 + 0.53359226668787 + 0.51282978129947 + 0.49403325449046 + 0.47671283014560 + 0.46051904984594 + 0.55352582083943 + 0.55352582278559 + 0.55352582310798 + 0.55352582348329 + 0.55352582392167 + 0.55352582443210 + 0.55352582502714 + 0.55352582572031 + 0.55352582653013 + 0.55352582748023 + 0.55352582861444 + 0.55352583000942 + 0.55352583176042 + 0.55352583397030 + 0.55352583676189 + 0.55352584028653 + 0.55352584473367 + 0.55352585033962 + 0.55352585741892 + 0.55352586638388 + 0.55352587773557 + 0.55352589210815 + 0.55352591030091 + 0.55352593332730 + 0.55352596248558 + 0.55352599955410 + 0.55352604719645 + 0.55352610904016 + 0.55352618950458 + 0.55352629410564 + 0.55352643056442 + 0.55352660870630 + 0.55352684114490 + 0.55352714422450 + 0.55352753909980 + 0.55352805309508 + 0.55352872142470 + 0.55352958938433 + 0.55353071738823 + 0.55353218638306 + 0.55353409897357 + 0.55353658831280 + 0.55353982579102 + 0.55354401501170 + 0.55354928902123 + 0.55355563132841 + 0.55356310606947 + 0.55357174874500 + 0.55358130376005 + 0.55359157710600 + 0.55360257166500 + 0.55361434058419 + 0.55362695028850 + 0.55364047736470 + 0.55365503977879 + 0.55367075864761 + 0.55368773887016 + 0.55370610083921 + 0.55372598551088 + 0.55374757680082 + 0.55377123098938 + 0.55379780817693 + 0.55382849587318 + 0.55386432982287 + 0.55390634878267 + 0.55395584920886 + 0.55401435034643 + 0.55408370470190 + 0.55416620299340 + 0.55426469499500 + 0.55438275472120 + 0.55452495779887 + 0.55469761939712 + 0.55491046535918 + 0.55517701152807 + 0.55551373500894 + 0.55594152039190 + 0.55619809867763 + 0.55648848612767 + 0.55681761958425 + 0.55719124580910 + 0.55761607599261 + 0.55809997591152 + 0.55865220215999 + 0.55928369920470 + 0.56000749902314 + 0.56083987857752 + 0.56181271361741 + 0.56300401249007 + 0.56449836570870 + 0.56638435362462 + 0.56878513366903 + 0.57186343691400 + 0.57584903051883 + 0.58107880540581 + 0.58807277947889 + 0.59769411434321 + 0.61154276034102 + 0.63324464669435 + 0.67435835250141 + 1.00000000000000 + 0.66187822357453 + 0.60713362489648 + 0.57142663787427 + 0.54352114438838 + 0.51998081152695 + 0.49930154898313 + 0.48065498199638 + 0.46350694036414 + 0.54026534167932 + 0.54026534339151 + 0.54026534367508 + 0.54026534400568 + 0.54026534439114 + 0.54026534484002 + 0.54026534536372 + 0.54026534597362 + 0.54026534668630 + 0.54026534752211 + 0.54026534852046 + 0.54026534974947 + 0.54026535129306 + 0.54026535324369 + 0.54026535570907 + 0.54026535882586 + 0.54026536276179 + 0.54026536772852 + 0.54026537400543 + 0.54026538196064 + 0.54026539204322 + 0.54026540481884 + 0.54026542100326 + 0.54026544150197 + 0.54026546747944 + 0.54026550052649 + 0.54026554303448 + 0.54026559825822 + 0.54026567016804 + 0.54026576371557 + 0.54026588584303 + 0.54026604538570 + 0.54026625368632 + 0.54026652545011 + 0.54026687971506 + 0.54026734106819 + 0.54026794121133 + 0.54026872091357 + 0.54026973456060 + 0.54027105502382 + 0.54027277464823 + 0.54027501323900 + 0.54027792493631 + 0.54028169267468 + 0.54028643524367 + 0.54029213596506 + 0.54029885048673 + 0.54030660810193 + 0.54031517538643 + 0.54032437461265 + 0.54033420523608 + 0.54034471145483 + 0.54035594874727 + 0.54036798094933 + 0.54038090800490 + 0.54039483148689 + 0.54040983718767 + 0.54042602328607 + 0.54044350454698 + 0.54046243177253 + 0.54048310541717 + 0.54050626569755 + 0.54053293263269 + 0.54056398215780 + 0.54060028160009 + 0.54064291039662 + 0.54069312572800 + 0.54075245406626 + 0.54082277595846 + 0.54090642239097 + 0.54100630661560 + 0.54112614853532 + 0.54127108697925 + 0.54144907336433 + 0.54167113837170 + 0.54195062163124 + 0.54230431877236 + 0.54251584110761 + 0.54275474055839 + 0.54302493808839 + 0.54333098217091 + 0.54367816432340 + 0.54407266000131 + 0.54452170188024 + 0.54503379536117 + 0.54561900737102 + 0.54628986224842 + 0.54707138652783 + 0.54802579702714 + 0.54921946291729 + 0.55072014968771 + 0.55262074940261 + 0.55504101373074 + 0.55814530641845 + 0.56216567754068 + 0.56744224843031 + 0.57449963636797 + 0.58420956706407 + 0.59823641525721 + 0.62023687542765 + 0.66187822357453 + 1.00000000000000 + 0.64930300463002 + 0.59396358170632 + 0.55794803793641 + 0.52992139382312 + 0.50642002865365 + 0.48587692151872 + 0.46740727553300 + 0.52698059987977 + 0.52698060137622 + 0.52698060162460 + 0.52698060191371 + 0.52698060225062 + 0.52698060264349 + 0.52698060310131 + 0.52698060363454 + 0.52698060425775 + 0.52698060498845 + 0.52698060586195 + 0.52698060693761 + 0.52698060829093 + 0.52698061000203 + 0.52698061216739 + 0.52698061490715 + 0.52698061837039 + 0.52698062274435 + 0.52698062827746 + 0.52698063529808 + 0.52698064420181 + 0.52698065549522 + 0.52698066981290 + 0.52698068796168 + 0.52698071097721 + 0.52698074028148 + 0.52698077800562 + 0.52698082705624 + 0.52698089098075 + 0.52698097420838 + 0.52698108294691 + 0.52698122510244 + 0.52698141082730 + 0.52698165329221 + 0.52698196954378 + 0.52698238161484 + 0.52698291790397 + 0.52698361494495 + 0.52698452147534 + 0.52698570280781 + 0.52698724169129 + 0.52698924545458 + 0.52699185212997 + 0.52699522538153 + 0.52699947080614 + 0.52700457178459 + 0.52701057631234 + 0.52701750822310 + 0.52702515525102 + 0.52703335529913 + 0.52704210510254 + 0.52705144105528 + 0.52706140910515 + 0.52707206201144 + 0.52708348393244 + 0.52709575945551 + 0.52710895805142 + 0.52712315898422 + 0.52713845479035 + 0.52715496810337 + 0.52717295099525 + 0.52719303784146 + 0.52721610111154 + 0.52724287810107 + 0.52727408913085 + 0.52731062811876 + 0.52735352949869 + 0.52740404377042 + 0.52746370557485 + 0.52753440996546 + 0.52761851689421 + 0.52771903181303 + 0.52784011195826 + 0.52798822490362 + 0.52817232913262 + 0.52840316913968 + 0.52869418331107 + 0.52886771589728 + 0.52906330888105 + 0.52928406329396 + 0.52953356532400 + 0.52981597288461 + 0.53013612033482 + 0.53049964618369 + 0.53091315043820 + 0.53138440516663 + 0.53192305369769 + 0.53254878497442 + 0.53331133187024 + 0.53426303085235 + 0.53545619500299 + 0.53696177618511 + 0.53886949670211 + 0.54129989638334 + 0.54441843963397 + 0.54845872968489 + 0.55376309068532 + 0.56086077011833 + 0.57066657109144 + 0.58485340249951 + 0.60713362489648 + 0.64930300463002 + 1.00000000000000 + 0.63665065254825 + 0.58069847389822 + 0.54440157379000 + 0.51633463584002 + 0.49294033583897 + 0.47257462608606 + 0.51372876438808 + 0.51372876568949 + 0.51372876590472 + 0.51372876615578 + 0.51372876644872 + 0.51372876679002 + 0.51372876718792 + 0.51372876765171 + 0.51372876819354 + 0.51372876882889 + 0.51372876958809 + 0.51372877052457 + 0.51372877170368 + 0.51372877319597 + 0.51372877508710 + 0.51372877748143 + 0.51372878051291 + 0.51372878434420 + 0.51372878919602 + 0.51372879535710 + 0.51372880317906 + 0.51372881310849 + 0.51372882570826 + 0.51372884169294 + 0.51372886198000 + 0.51372888783199 + 0.51372892113894 + 0.51372896448945 + 0.51372902103468 + 0.51372909471715 + 0.51372919106375 + 0.51372931711756 + 0.51372948192711 + 0.51372969723077 + 0.51372997823602 + 0.51373034459198 + 0.51373082163728 + 0.51373144197029 + 0.51373224908813 + 0.51373330128953 + 0.51373467242467 + 0.51373645826186 + 0.51373878193186 + 0.51374178928286 + 0.51374557381681 + 0.51375011917852 + 0.51375546651062 + 0.51376163491577 + 0.51376843209825 + 0.51377571082190 + 0.51378346570127 + 0.51379172640490 + 0.51380053064359 + 0.51380992164253 + 0.51381996982516 + 0.51383074514237 + 0.51384230323101 + 0.51385470738286 + 0.51386803141591 + 0.51388237416568 + 0.51389794603958 + 0.51391528853468 + 0.51393514491103 + 0.51395813289605 + 0.51398484748877 + 0.51401602492722 + 0.51405251140880 + 0.51409532515418 + 0.51414571072718 + 0.51420519888726 + 0.51427568876930 + 0.51435959243904 + 0.51446025206137 + 0.51458289985722 + 0.51473477342245 + 0.51492447849767 + 0.51516270525332 + 0.51530434701989 + 0.51546366826850 + 0.51564310862940 + 0.51584548136245 + 0.51607403813482 + 0.51633254686631 + 0.51662538594595 + 0.51695765939770 + 0.51733535109764 + 0.51776587324414 + 0.51826471700346 + 0.51887166124958 + 0.51962809023545 + 0.52057461936280 + 0.52176589531808 + 0.52326997097888 + 0.52517677760658 + 0.52760715095440 + 0.53072697902643 + 0.53477048044633 + 0.54008205879639 + 0.54722096219103 + 0.55710232439590 + 0.57142663787427 + 0.59396358170632 + 0.63665065254825 + 1.00000000000000 + 0.62384175927134 + 0.56729600077394 + 0.53081211477866 + 0.50279238136775 + 0.47956602806368 + 0.50053991291415 + 0.50053991403897 + 0.50053991422546 + 0.50053991444279 + 0.50053991469594 + 0.50053991499100 + 0.50053991533458 + 0.50053991573542 + 0.50053991620349 + 0.50053991675254 + 0.50053991740926 + 0.50053991821999 + 0.50053991924147 + 0.50053992053621 + 0.50053992217899 + 0.50053992426135 + 0.50053992689951 + 0.50053993023864 + 0.50053993447111 + 0.50053993985122 + 0.50053994668741 + 0.50053995537459 + 0.50053996640821 + 0.50053998041794 + 0.50053999821430 + 0.50054002091010 + 0.50054005017990 + 0.50054008831125 + 0.50054013809746 + 0.50054020302834 + 0.50054028800644 + 0.50054039927846 + 0.50054054487584 + 0.50054073521844 + 0.50054098381518 + 0.50054130812219 + 0.50054173065596 + 0.50054228039300 + 0.50054299600015 + 0.50054392932016 + 0.50054514601726 + 0.50054673122816 + 0.50054879438689 + 0.50055146501211 + 0.50055482558635 + 0.50055886019300 + 0.50056360389928 + 0.50056907173757 + 0.50057509012167 + 0.50058152581670 + 0.50058837185815 + 0.50059565216097 + 0.50060339738846 + 0.50061164262343 + 0.50062044644793 + 0.50062986628973 + 0.50063994616730 + 0.50065073601482 + 0.50066229401457 + 0.50067469907529 + 0.50068812594486 + 0.50070303509722 + 0.50072005730408 + 0.50073970779064 + 0.50076247537532 + 0.50078896310456 + 0.50081985907499 + 0.50085598722080 + 0.50089835033310 + 0.50094817660825 + 0.50100698372504 + 0.50107669385269 + 0.50115997616619 + 0.50126103963392 + 0.50138569947494 + 0.50154080675993 + 0.50173481125098 + 0.50184981698614 + 0.50197890751523 + 0.50212399018630 + 0.50228725846361 + 0.50247124022688 + 0.50267885546522 + 0.50291348563862 + 0.50317905786046 + 0.50348015796554 + 0.50382246189332 + 0.50421814093446 + 0.50469899404604 + 0.50529777850506 + 0.50604612837691 + 0.50698634946934 + 0.50817047622326 + 0.50966638454892 + 0.51156376395780 + 0.51398311398650 + 0.51708985321088 + 0.52111846622660 + 0.52643424528856 + 0.53359226668787 + 0.54352114438838 + 0.55794803793641 + 0.58069847389822 + 0.62384175927134 + 1.00000000000000 + 0.61085613914145 + 0.55380812791899 + 0.51723400897747 + 0.48934161640741 + 0.48742880001134 + 0.48742880097872 + 0.48742880113923 + 0.48742880132568 + 0.48742880154339 + 0.48742880179721 + 0.48742880209306 + 0.48742880243780 + 0.48742880284047 + 0.48742880331292 + 0.48742880387789 + 0.48742880457618 + 0.48742880545692 + 0.48742880657497 + 0.48742880799540 + 0.48742880979822 + 0.48742881208430 + 0.48742881498058 + 0.48742881865505 + 0.48742882333214 + 0.48742882928189 + 0.48742883684854 + 0.48742884646759 + 0.48742885869300 + 0.48742887423676 + 0.48742889407566 + 0.48742891968715 + 0.48742895308617 + 0.48742899673778 + 0.48742905371949 + 0.48742912836295 + 0.48742922618897 + 0.48742935429384 + 0.48742952189952 + 0.48742974095531 + 0.48743002691708 + 0.48743039972228 + 0.48743088502938 + 0.48743151709843 + 0.48743234186917 + 0.48743341752644 + 0.48743481950808 + 0.48743664475866 + 0.48743900791762 + 0.48744198151564 + 0.48744555021528 + 0.48744974374642 + 0.48745457368825 + 0.48745988386765 + 0.48746555413943 + 0.48747157642889 + 0.48747796979548 + 0.48748475893711 + 0.48749197206667 + 0.48749965764098 + 0.48750786247760 + 0.48751662096297 + 0.48752597197452 + 0.48753596079884 + 0.48754664982179 + 0.48755818351965 + 0.48757095217553 + 0.48758548930639 + 0.48760222290323 + 0.48762155253039 + 0.48764396959395 + 0.48767003046213 + 0.48770039784507 + 0.48773587464317 + 0.48777743977573 + 0.48782629769084 + 0.48788396932688 + 0.48795257241720 + 0.48803547423720 + 0.48813732215134 + 0.48826353719664 + 0.48842075437022 + 0.48851366635302 + 0.48861773243476 + 0.48873443376954 + 0.48886546912175 + 0.48901279067421 + 0.48917864655673 + 0.48936563166831 + 0.48957674897881 + 0.48981549226108 + 0.49008618583547 + 0.49039837164023 + 0.49077744038815 + 0.49124932233268 + 0.49183869709157 + 0.49257842049062 + 0.49350849287210 + 0.49468055273313 + 0.49616192817137 + 0.49804153788467 + 0.50043878547003 + 0.50351824411856 + 0.50752898120497 + 0.51282978129947 + 0.51998081152695 + 0.52992139382312 + 0.54440157379000 + 0.56729600077394 + 0.61085613914145 + 1.00000000000000 + 0.59778299494925 + 0.54030215877432 + 0.50372939750331 + 0.47441388310922 + 0.47441388393798 + 0.47441388407546 + 0.47441388423547 + 0.47441388442236 + 0.47441388463962 + 0.47441388489315 + 0.47441388518872 + 0.47441388553404 + 0.47441388593877 + 0.47441388642363 + 0.47441388702259 + 0.47441388777941 + 0.47441388874125 + 0.47441388996450 + 0.47441389151921 + 0.47441389349326 + 0.47441389599668 + 0.47441389917694 + 0.47441390322841 + 0.47441390838753 + 0.47441391495536 + 0.47441392331311 + 0.47441393394559 + 0.47441394747476 + 0.47441396476041 + 0.47441398709545 + 0.47441401625220 + 0.47441405439753 + 0.47441410423951 + 0.47441416959046 + 0.47441425531228 + 0.47441436766186 + 0.47441451477169 + 0.47441470718153 + 0.47441495853109 + 0.47441528642319 + 0.47441571351442 + 0.47441627007324 + 0.47441699668767 + 0.47441794477621 + 0.47441918099908 + 0.47442079100377 + 0.47442287599712 + 0.47442549959712 + 0.47442864716224 + 0.47443234378545 + 0.47443659817647 + 0.47444127023300 + 0.47444625196081 + 0.47445153458573 + 0.47445713313232 + 0.47446306732390 + 0.47446935965825 + 0.47447605004236 + 0.47448317643114 + 0.47449076533878 + 0.47449884664659 + 0.47450745516292 + 0.47451663977060 + 0.47452651952658 + 0.47453742447408 + 0.47454980482176 + 0.47456401507142 + 0.47458038056818 + 0.47459930014903 + 0.47462122162283 + 0.47464667541267 + 0.47467630098756 + 0.47471087420315 + 0.47475134520289 + 0.47479891001341 + 0.47485523939843 + 0.47492301524561 + 0.47500593539209 + 0.47510826694765 + 0.47523518939239 + 0.47530995828942 + 0.47539351528143 + 0.47548700331222 + 0.47559172967816 + 0.47570919239291 + 0.47584111134726 + 0.47598946530633 + 0.47615653631976 + 0.47634497004359 + 0.47655804364327 + 0.47680322347588 + 0.47710076801416 + 0.47747120697420 + 0.47793382096613 + 0.47851419270226 + 0.47924320386210 + 0.48016038710078 + 0.48131672978953 + 0.48277863861677 + 0.48463371381419 + 0.48700003011217 + 0.49005257057863 + 0.49403325449046 + 0.49930154898313 + 0.50642002865365 + 0.51633463584002 + 0.53081211477866 + 0.55380812791899 + 0.59778299494925 + 1.00000000000000 + 0.58464162789299 + 0.52681413214863 + 0.46149689320824 + 0.46149689391724 + 0.46149689403471 + 0.46149689417161 + 0.46149689433097 + 0.46149689451699 + 0.46149689473386 + 0.46149689498662 + 0.46149689528161 + 0.46149689562781 + 0.46149689604248 + 0.46149689655559 + 0.46149689720492 + 0.46149689803096 + 0.46149689908230 + 0.46149690042017 + 0.46149690212128 + 0.46149690428118 + 0.46149690702676 + 0.46149691052869 + 0.46149691499292 + 0.46149692068210 + 0.46149692792812 + 0.46149693715372 + 0.46149694890534 + 0.46149696393196 + 0.46149698336595 + 0.46149700876275 + 0.46149704202031 + 0.46149708551721 + 0.46149714260144 + 0.46149721754587 + 0.46149731585236 + 0.46149744467363 + 0.46149761328856 + 0.46149783370572 + 0.46149812143072 + 0.46149849642829 + 0.46149898537101 + 0.46149962405342 + 0.46150045780923 + 0.46150154542151 + 0.46150296240184 + 0.46150479792630 + 0.46150710768916 + 0.46150987784361 + 0.46151312950455 + 0.46151686904582 + 0.46152097110574 + 0.46152533888657 + 0.46152996327880 + 0.46153485601103 + 0.46154003272802 + 0.46154551125757 + 0.46155132438169 + 0.46155750275738 + 0.46156406659016 + 0.46157103857655 + 0.46157844517043 + 0.46158632440184 + 0.46159477423846 + 0.46160407352314 + 0.46161460181114 + 0.46162665236055 + 0.46164048954130 + 0.46165643636164 + 0.46167485228528 + 0.46169616054846 + 0.46172086872216 + 0.46174958937152 + 0.46178306887872 + 0.46182224357334 + 0.46186842648915 + 0.46192374784943 + 0.46199114218832 + 0.46207395633483 + 0.46217621610680 + 0.46223625644146 + 0.46230319686861 + 0.46237791495592 + 0.46246141161231 + 0.46255483039286 + 0.46265948015935 + 0.46277686185994 + 0.46290870048677 + 0.46305698892938 + 0.46322419961584 + 0.46341617033544 + 0.46364906998116 + 0.46393916984813 + 0.46430156289097 + 0.46475622809917 + 0.46532711111578 + 0.46604465618750 + 0.46694778022309 + 0.46808659037782 + 0.46952622212667 + 0.47135288344435 + 0.47369234884071 + 0.47671283014560 + 0.48065498199638 + 0.48587692151872 + 0.49294033583897 + 0.50279238136775 + 0.51723400897747 + 0.54030215877432 + 0.58464162789299 + 1.00000000000000 + 0.57145358264470 + 0.44866132833815 + 0.44866132894435 + 0.44866132904451 + 0.44866132916165 + 0.44866132929803 + 0.44866132945705 + 0.44866132964246 + 0.44866132985849 + 0.44866133011042 + 0.44866133040689 + 0.44866133076180 + 0.44866133120119 + 0.44866133175769 + 0.44866133246596 + 0.44866133336991 + 0.44866133452075 + 0.44866133598561 + 0.44866133784767 + 0.44866134021736 + 0.44866134324259 + 0.44866134710266 + 0.44866135202690 + 0.44866135830476 + 0.44866136630383 + 0.44866137650161 + 0.44866138955083 + 0.44866140644579 + 0.44866142854322 + 0.44866145750769 + 0.44866149542371 + 0.44866154522793 + 0.44866161066833 + 0.44866169657475 + 0.44866180923067 + 0.44866195679029 + 0.44866214981071 + 0.44866240192802 + 0.44866273070476 + 0.44866315961477 + 0.44866372016904 + 0.44866445228059 + 0.44866540770542 + 0.44866665292578 + 0.44866826640711 + 0.44867029685344 + 0.44867273128899 + 0.44867558745549 + 0.44867886986962 + 0.44868246662629 + 0.44868629119243 + 0.44869033442607 + 0.44869460541889 + 0.44869911654153 + 0.44870388186502 + 0.44870892832307 + 0.44871428065139 + 0.44871995411711 + 0.44872596579908 + 0.44873233562981 + 0.44873909308068 + 0.44874631883582 + 0.44875424863238 + 0.44876320265814 + 0.44877342370383 + 0.44878512667573 + 0.44879857324439 + 0.44881405193784 + 0.44883190032549 + 0.44885252099463 + 0.44887639706147 + 0.44890411396799 + 0.44893640347664 + 0.44897429624049 + 0.44901948401034 + 0.44907429524556 + 0.44914135230387 + 0.44922377872935 + 0.44927200871059 + 0.44932565163059 + 0.44938537953011 + 0.44945195663509 + 0.44952625338473 + 0.44960926283411 + 0.44970211992787 + 0.44980612437702 + 0.44992277247472 + 0.45005392487073 + 0.45020415169463 + 0.45038638440060 + 0.45061355357015 + 0.45089751494643 + 0.45125393753910 + 0.45170148870279 + 0.45226376973423 + 0.45297072895104 + 0.45386055946424 + 0.45498230427332 + 0.45639989448888 + 0.45820550660732 + 0.46051904984594 + 0.46350694036414 + 0.46740727553300 + 0.47257462608606 + 0.47956602806368 + 0.48934161640741 + 0.50372939750331 + 0.52681413214863 + 0.57145358264470 + 1.00000000000000 + 1.00000000000000 + 0.99987677618377 + 0.99986487494382 + 0.99985240180392 + 0.99983938097884 + 0.99982582613285 + 0.99981173493558 + 0.99979708394743 + 0.99978182272616 + 0.99976585848934 + 0.99974901124398 + 0.99973098992139 + 0.99971148344692 + 0.99969020500286 + 0.99966686140904 + 0.99964113330880 + 0.99961266877871 + 0.99958108181559 + 0.99954592959527 + 0.99950671213250 + 0.99946292476675 + 0.99941403728548 + 0.99935950298591 + 0.99929876764338 + 0.99923126413944 + 0.99915633241552 + 0.99907306284423 + 0.99898049246822 + 0.99887785652967 + 0.99876446127449 + 0.99863934204255 + 0.99850146419999 + 0.99834959427460 + 0.99818216731686 + 0.99799719762356 + 0.99779219314151 + 0.99756407365774 + 0.99730909115191 + 0.99702254756011 + 0.99669870384660 + 0.99633110583612 + 0.99591227591279 + 0.99543367030336 + 0.99488633261764 + 0.99426522156938 + 0.99356936367927 + 0.99279031134476 + 0.99191768869575 + 0.99094710570682 + 0.98986720991529 + 0.98865719630447 + 0.98729235673942 + 0.98574508497040 + 0.98398471802533 + 0.98197617512544 + 0.97968112172201 + 0.97705855154200 + 0.97406333531755 + 0.97064575848398 + 0.96675053706058 + 0.96231226645031 + 0.95724385946959 + 0.95144635367882 + 0.94483193577400 + 0.93732142900778 + 0.92883856562871 + 0.91931867801992 + 0.90871098288733 + 0.89698283230635 + 0.88412502625465 + 0.87015719791040 + 0.85513122338249 + 0.83912518301196 + 0.82222537342246 + 0.80455397672246 + 0.78631106068866 + 0.76774819167497 + 0.75842380083074 + 0.74911393510396 + 0.73984424676562 + 0.73063501181440 + 0.72149998024692 + 0.71244555376555 + 0.70347045291982 + 0.69456607175677 + 0.68571753341369 + 0.67690155803155 + 0.66802437278482 + 0.65881557185352 + 0.64913941106764 + 0.63898978192345 + 0.62836612441048 + 0.61729715600270 + 0.60581949760023 + 0.59397566264818 + 0.58181255230946 + 0.56938047896499 + 0.55673083208976 + 0.54388615239073 + 0.53089692217112 + 0.51781422105190 + 0.50468752000873 + 0.49156170330657 + 0.47847380959938 + 0.46543456369616 + 0.45243793978443 + 0.43947732959057 + 0.42653265548361 + 0.41357241987949 + 0.99987677618377 + 1.00000000000000 + 0.99996803583495 + 0.99993976893815 + 0.99991360450642 + 0.99988905780101 + 0.99986581075564 + 0.99984357695598 + 0.99982207051590 + 0.99980098126012 + 0.99977992545169 + 0.99975842531130 + 0.99973601293989 + 0.99971227893525 + 0.99968683618765 + 0.99965929323901 + 0.99962924200939 + 0.99959625194236 + 0.99955984401007 + 0.99951948880798 + 0.99947465866079 + 0.99942480491630 + 0.99936936631599 + 0.99930777761321 + 0.99923946391600 + 0.99916375987448 + 0.99907975215577 + 0.99898647739415 + 0.99888317426547 + 0.99876915401477 + 0.99864345619100 + 0.99850505017771 + 0.99835270513668 + 0.99818485674925 + 0.99799951786775 + 0.99779419320211 + 0.99756579811512 + 0.99731057956768 + 0.99702383426275 + 0.99669981813977 + 0.99633207254021 + 0.99591311585158 + 0.99543440088989 + 0.99488696855002 + 0.99426577577793 + 0.99356984767358 + 0.99279073480331 + 0.99191805982198 + 0.99094743175071 + 0.98986749708624 + 0.98865744980230 + 0.98729258096895 + 0.98574528371944 + 0.98398489454394 + 0.98197633221758 + 0.97968126181082 + 0.97705867672212 + 0.97406344741735 + 0.97064585909897 + 0.96675062760093 + 0.96231234814215 + 0.95724393335247 + 0.95144642062895 + 0.94483199655323 + 0.93732148428592 + 0.92883861597399 + 0.91931872392418 + 0.90871102476123 + 0.89698287049056 + 0.88412506103350 + 0.87015722952174 + 0.85513125202697 + 0.83912520886660 + 0.82222539664650 + 0.80455399746936 + 0.78631107913097 + 0.76774820800062 + 0.75842381617154 + 0.74911394951287 + 0.73984426029568 + 0.73063502451853 + 0.72149999217709 + 0.71244556497161 + 0.70347046344894 + 0.69456608165488 + 0.68571754271983 + 0.67690156678305 + 0.66802438101085 + 0.65881557956679 + 0.64913941826998 + 0.63898978862165 + 0.62836613061219 + 0.61729716171729 + 0.60581950284124 + 0.59397566743307 + 0.58181255665674 + 0.56938048289658 + 0.55673083562865 + 0.54388615556132 + 0.53089692499869 + 0.51781422356178 + 0.50468752222748 + 0.49156170526173 + 0.47847381131567 + 0.46543456520032 + 0.45243794110001 + 0.43947733073964 + 0.42653265648766 + 0.41357242075670 + 0.99986487494382 + 0.99996803583495 + 1.00000000000000 + 0.99996357710992 + 0.99993228058661 + 0.99990394293042 + 0.99987781719504 + 0.99985338066629 + 0.99983018330020 + 0.99980779297897 + 0.99978573125047 + 0.99976344518977 + 0.99974040907396 + 0.99971617103022 + 0.99969031346681 + 0.99966242314254 + 0.99963207622322 + 0.99959883046679 + 0.99956219791626 + 0.99952164228489 + 0.99947663070219 + 0.99942661050258 + 0.99937101735313 + 0.99930928370691 + 0.99924083305817 + 0.99916499894337 + 0.99908086725583 + 0.99898747445403 + 0.99888405970398 + 0.99876993503621 + 0.99864414065414 + 0.99850564658118 + 0.99835322238714 + 0.99818530384486 + 0.99799990353598 + 0.99779452562507 + 0.99756608472551 + 0.99731082695152 + 0.99702404813129 + 0.99670000336438 + 0.99633223324572 + 0.99591325549186 + 0.99543452235669 + 0.99488707428721 + 0.99426586792788 + 0.99356992814923 + 0.99279080521374 + 0.99191812152857 + 0.99094748595940 + 0.98986754482880 + 0.98865749194080 + 0.98729261824111 + 0.98574531675267 + 0.98398492388017 + 0.98197635832308 + 0.97968128508589 + 0.97705869751819 + 0.97406346603984 + 0.97064587581022 + 0.96675064263724 + 0.96231236170581 + 0.95724394561704 + 0.95144643174459 + 0.94483200664131 + 0.93732149345955 + 0.92883862432681 + 0.91931873153871 + 0.90871103170664 + 0.89698287682469 + 0.88412506680189 + 0.87015723476223 + 0.85513125677612 + 0.83912521315368 + 0.82222540049621 + 0.80455400090847 + 0.78631108218720 + 0.76774821070627 + 0.75842381871403 + 0.74911395189978 + 0.73984426253839 + 0.73063502662365 + 0.72149999415330 + 0.71244556682770 + 0.70347046519387 + 0.69456608329404 + 0.68571754426171 + 0.67690156823349 + 0.66802438237432 + 0.65881558084387 + 0.64913941946314 + 0.63898978973190 + 0.62836613164002 + 0.61729716266436 + 0.60581950370995 + 0.59397566822573 + 0.58181255737684 + 0.56938048354787 + 0.55673083621493 + 0.54388615608646 + 0.53089692546705 + 0.51781422397769 + 0.50468752259565 + 0.49156170558549 + 0.47847381160027 + 0.46543456544939 + 0.45243794131784 + 0.43947733093028 + 0.42653265665409 + 0.41357242090218 + 0.99985240180392 + 0.99993976893815 + 0.99996357710992 + 1.00000000000000 + 0.99995859033258 + 0.99992411166811 + 0.99989361226037 + 0.99986596966090 + 0.99984039356781 + 0.99981622443126 + 0.99979282140056 + 0.99976951072183 + 0.99974567755848 + 0.99972080641251 + 0.99969443520733 + 0.99966611974881 + 0.99963541438434 + 0.99960186108466 + 0.99956496008446 + 0.99952416614637 + 0.99947893972902 + 0.99942872308405 + 0.99937294800993 + 0.99931104408898 + 0.99924243280306 + 0.99916644629681 + 0.99908216949785 + 0.99898863861661 + 0.99888509336760 + 0.99877084667077 + 0.99864493949096 + 0.99850634257425 + 0.99835382596484 + 0.99818582552454 + 0.99800035352666 + 0.99779491348461 + 0.99756641912725 + 0.99731111558820 + 0.99702429766876 + 0.99670021948404 + 0.99633242075565 + 0.99591341843139 + 0.99543466409261 + 0.99488719766899 + 0.99426597545731 + 0.99357002205716 + 0.99279088737413 + 0.99191819353238 + 0.99094754921357 + 0.98986760053511 + 0.98865754111169 + 0.98729266172919 + 0.98574535529504 + 0.98398495810520 + 0.98197638877777 + 0.97968131223936 + 0.97705872177931 + 0.97406348776126 + 0.97064589530531 + 0.96675066017573 + 0.96231237752868 + 0.95724395992396 + 0.95144644470454 + 0.94483201840589 + 0.93732150415559 + 0.92883863406922 + 0.91931874041890 + 0.90871103980399 + 0.89698288420774 + 0.88412507352646 + 0.87015724087362 + 0.85513126231300 + 0.83912521815017 + 0.82222540498307 + 0.80455400491729 + 0.78631108574945 + 0.76774821385941 + 0.75842382167701 + 0.74911395468264 + 0.73984426515089 + 0.73063502907695 + 0.72149999645717 + 0.71244556899195 + 0.70347046722721 + 0.69456608520537 + 0.68571754605889 + 0.67690156992361 + 0.66802438396259 + 0.65881558233290 + 0.64913942085397 + 0.63898979102495 + 0.62836613283748 + 0.61729716376777 + 0.60581950472174 + 0.59397566914976 + 0.58181255821629 + 0.56938048430689 + 0.55673083689831 + 0.54388615669870 + 0.53089692601280 + 0.51781422446217 + 0.50468752302388 + 0.49156170596292 + 0.47847381193125 + 0.46543456573970 + 0.45243794157198 + 0.43947733115229 + 0.42653265684798 + 0.41357242107165 + 0.99983938097884 + 0.99991360450642 + 0.99993228058661 + 0.99995859033258 + 1.00000000000000 + 0.99995303551627 + 0.99991525473186 + 0.99988263396763 + 0.99985353988633 + 0.99982683963503 + 0.99980158916237 + 0.99977690712609 + 0.99975203382073 + 0.99972635418216 + 0.99969933867590 + 0.99967049762922 + 0.99963935430208 + 0.99960542879923 + 0.99956820541281 + 0.99952712706913 + 0.99948164553355 + 0.99943119652336 + 0.99937520691900 + 0.99931310268998 + 0.99924430277315 + 0.99916813756762 + 0.99908369078594 + 0.99898999828696 + 0.99888630039041 + 0.99877191102776 + 0.99864587202110 + 0.99850715495279 + 0.99835453041037 + 0.99818643434304 + 0.99800087865738 + 0.99779536609579 + 0.99756680935712 + 0.99731145241230 + 0.99702458886912 + 0.99670047169326 + 0.99633263958667 + 0.99591360858737 + 0.99543482951155 + 0.99488734166778 + 0.99426610095669 + 0.99357013165741 + 0.99279098326322 + 0.99191827756727 + 0.99094762303419 + 0.98986766554762 + 0.98865759849346 + 0.98729271248224 + 0.98574540026893 + 0.98398499804479 + 0.98197642431332 + 0.97968134392357 + 0.97705875008583 + 0.97406351310507 + 0.97064591804892 + 0.96675068063458 + 0.96231239598360 + 0.95724397661050 + 0.95144645982330 + 0.94483203212798 + 0.93732151663272 + 0.92883864543010 + 0.91931875077444 + 0.90871104925039 + 0.89698289281860 + 0.88412508136602 + 0.87015724799849 + 0.85513126876811 + 0.83912522397436 + 0.82222541021597 + 0.80455400959030 + 0.78631108990299 + 0.76774821753637 + 0.75842382513096 + 0.74911395792672 + 0.73984426819769 + 0.73063503193703 + 0.72149999914366 + 0.71244557151564 + 0.70347046959693 + 0.69456608743289 + 0.68571754815351 + 0.67690157189366 + 0.66802438581487 + 0.65881558406884 + 0.64913942247570 + 0.63898979253284 + 0.62836613423283 + 0.61729716505382 + 0.60581950590198 + 0.59397567022629 + 0.58181255919493 + 0.56938048519191 + 0.55673083769522 + 0.54388615741227 + 0.53089692664951 + 0.51781422502703 + 0.50468752352341 + 0.49156170640261 + 0.47847381231803 + 0.46543456607800 + 0.45243794186825 + 0.43947733141116 + 0.42653265707378 + 0.41357242126907 + 0.99982582613285 + 0.99988905780101 + 0.99990394293042 + 0.99992411166811 + 0.99995303551627 + 1.00000000000000 + 0.99994687551069 + 0.99990571182873 + 0.99987103133076 + 0.99984052793401 + 0.99981262088902 + 0.99978603907283 + 0.99975977083106 + 0.99973303648085 + 0.99970519936348 + 0.99967570023216 + 0.99964401649319 + 0.99960963709201 + 0.99957202426717 + 0.99953060494947 + 0.99948481939329 + 0.99943409477905 + 0.99937785166462 + 0.99931551140789 + 0.99924648969899 + 0.99917011472540 + 0.99908546865139 + 0.99899158684981 + 0.99888771029025 + 0.99877315404122 + 0.99864696090343 + 0.99850810341313 + 0.99835535276870 + 0.99818714500945 + 0.99800149159967 + 0.99779589437463 + 0.99756726481796 + 0.99731184554835 + 0.99702492875986 + 0.99670076608049 + 0.99633289502196 + 0.99591383055977 + 0.99543502261095 + 0.99488750976523 + 0.99426624746107 + 0.99357025960455 + 0.99279109520556 + 0.99191837566745 + 0.99094770921077 + 0.98986774143653 + 0.98865766547293 + 0.98729277171752 + 0.98574545276091 + 0.98398504465817 + 0.98197646578701 + 0.97968138089819 + 0.97705878311916 + 0.97406354267686 + 0.97064594458757 + 0.96675070450881 + 0.96231241751710 + 0.95724399608022 + 0.95144647746075 + 0.94483204813548 + 0.93732153118556 + 0.92883865868077 + 0.91931876285234 + 0.90871106026208 + 0.89698290285969 + 0.88412509050865 + 0.87015725630643 + 0.85513127629500 + 0.83912523076658 + 0.82222541631437 + 0.80455401503794 + 0.78631109474464 + 0.76774822182009 + 0.75842382915798 + 0.74911396170786 + 0.73984427174846 + 0.73063503527138 + 0.72150000227373 + 0.71244557445524 + 0.70347047235981 + 0.69456609003008 + 0.68571755059516 + 0.67690157419011 + 0.66802438797297 + 0.65881558609226 + 0.64913942436525 + 0.63898979429071 + 0.62836613586025 + 0.61729716655258 + 0.60581950727708 + 0.59397567148140 + 0.58181256033546 + 0.56938048622303 + 0.55673083862380 + 0.54388615824406 + 0.53089692739137 + 0.51781422568531 + 0.50468752410505 + 0.49156170691509 + 0.47847381276809 + 0.46543456647260 + 0.45243794221280 + 0.43947733171246 + 0.42653265733734 + 0.41357242149942 + 0.99981173493558 + 0.99986581075564 + 0.99987781719504 + 0.99989361226037 + 0.99991525473186 + 0.99994687551069 + 1.00000000000000 + 0.99994007748307 + 0.99989549128018 + 0.99985880953548 + 0.99982684965019 + 0.99979751151569 + 0.99976930353078 + 0.99974115425148 + 0.99971224685284 + 0.99968191026146 + 0.99964955138648 + 0.99961461317720 + 0.99957652646901 + 0.99953469608778 + 0.99948854667423 + 0.99943749409947 + 0.99938095065139 + 0.99931833171620 + 0.99924904882072 + 0.99917242729893 + 0.99908754733549 + 0.99899344361476 + 0.99888935778672 + 0.99877460620158 + 0.99864823275776 + 0.99850921107320 + 0.99835631303651 + 0.99818797477928 + 0.99800220722184 + 0.99779651112925 + 0.99756779655624 + 0.99731230452034 + 0.99702532558136 + 0.99670110978906 + 0.99633319326237 + 0.99591408973995 + 0.99543524808277 + 0.99488770605249 + 0.99426641853701 + 0.99357040900694 + 0.99279122591541 + 0.99191849021778 + 0.99094780983025 + 0.98986783004763 + 0.98865774367704 + 0.98729284087953 + 0.98574551404788 + 0.98398509907500 + 0.98197651420561 + 0.97968142406150 + 0.97705882167735 + 0.97406357719568 + 0.97064597555791 + 0.96675073236591 + 0.96231244264411 + 0.95724401879828 + 0.95144649803976 + 0.94483206680812 + 0.93732154816321 + 0.92883867413853 + 0.91931877694088 + 0.90871107310828 + 0.89698291456811 + 0.88412510117095 + 0.87015726599510 + 0.85513128507117 + 0.83912523868538 + 0.82222542342547 + 0.80455402139084 + 0.78631110038914 + 0.76774822681658 + 0.75842383385165 + 0.74911396611663 + 0.73984427588682 + 0.73063503915738 + 0.72150000592386 + 0.71244557788366 + 0.70347047558018 + 0.69456609305720 + 0.68571755344158 + 0.67690157686575 + 0.66802439048838 + 0.65881558845069 + 0.64913942656775 + 0.63898979633906 + 0.62836613775615 + 0.61729716830080 + 0.60581950887991 + 0.59397567294453 + 0.58181256166421 + 0.56938048742511 + 0.55673083970576 + 0.54388615921377 + 0.53089692825605 + 0.51781422645252 + 0.50468752478375 + 0.49156170751276 + 0.47847381329302 + 0.46543456693222 + 0.45243794261503 + 0.43947733206396 + 0.42653265764423 + 0.41357242176785 + 0.99979708394743 + 0.99984357695598 + 0.99985338066629 + 0.99986596966090 + 0.99988263396763 + 0.99990571182873 + 0.99994007748307 + 1.00000000000000 + 0.99993261260100 + 0.99988459060930 + 0.99984589601368 + 0.99981229411480 + 0.99978125263162 + 0.99975113253166 + 0.99972079098468 + 0.99968936592703 + 0.99965615010655 + 0.99962051561734 + 0.99958184699123 + 0.99953951758755 + 0.99949293040876 + 0.99944148598536 + 0.99938458562056 + 0.99932163686029 + 0.99925204579270 + 0.99917513404650 + 0.99908997923590 + 0.99899561508107 + 0.99889128391715 + 0.99877630350881 + 0.99864971898924 + 0.99851050519653 + 0.99835743479258 + 0.99818894398295 + 0.99800304303101 + 0.99779723143438 + 0.99756841755956 + 0.99731284055402 + 0.99702578903846 + 0.99670151122959 + 0.99633354160967 + 0.99591439247467 + 0.99543551145200 + 0.99488793533698 + 0.99426661837245 + 0.99357058352895 + 0.99279137860482 + 0.99191862402351 + 0.99094792736504 + 0.98986793354580 + 0.98865783501765 + 0.98729292165262 + 0.98574558562048 + 0.98398516262519 + 0.98197657074488 + 0.97968147445977 + 0.97705886669722 + 0.97406361749530 + 0.97064601171493 + 0.96675076489203 + 0.96231247197686 + 0.95724404531492 + 0.95144652205754 + 0.94483208860161 + 0.93732156797320 + 0.92883869217373 + 0.91931879337771 + 0.90871108809489 + 0.89698292822652 + 0.88412511360784 + 0.87015727729444 + 0.85513129530744 + 0.83912524792103 + 0.82222543171676 + 0.80455402879655 + 0.78631110697133 + 0.76774823264194 + 0.75842383932498 + 0.74911397125735 + 0.73984428071424 + 0.73063504368837 + 0.72150001017869 + 0.71244558187994 + 0.70347047933527 + 0.69456609658636 + 0.68571755675967 + 0.67690157998664 + 0.66802439342234 + 0.65881559120086 + 0.64913942913562 + 0.63898979872762 + 0.62836613996782 + 0.61729717033852 + 0.60581951074826 + 0.59397567465067 + 0.58181256321375 + 0.56938048882716 + 0.55673084096724 + 0.54388616034424 + 0.53089692926399 + 0.51781422734718 + 0.50468752557462 + 0.49156170820966 + 0.47847381390519 + 0.46543456746862 + 0.45243794308421 + 0.43947733247338 + 0.42653265800267 + 0.41357242208033 + 0.99978182272616 + 0.99982207051590 + 0.99983018330020 + 0.99984039356781 + 0.99985353988633 + 0.99987103133076 + 0.99989549128018 + 0.99993261260100 + 1.00000000000000 + 0.99992444572152 + 0.99987294082038 + 0.99983209690468 + 0.99979661959691 + 0.99976360799964 + 0.99973126941859 + 0.99969838913923 + 0.99966406265955 + 0.99962754695933 + 0.99958815531558 + 0.99954521470886 + 0.99949809726304 + 0.99944618221859 + 0.99938885596701 + 0.99932551558486 + 0.99925555996205 + 0.99917830583590 + 0.99909282745874 + 0.99899815717791 + 0.99889353798370 + 0.99877828918346 + 0.99865145727973 + 0.99851201847616 + 0.99835874628691 + 0.99819007697272 + 0.99800401999892 + 0.99779807334663 + 0.99756914339136 + 0.99731346707593 + 0.99702633074413 + 0.99670198046262 + 0.99633394880132 + 0.99591474636316 + 0.99543581933929 + 0.99488820337943 + 0.99426685199094 + 0.99357078755469 + 0.99279155710245 + 0.99191878044094 + 0.99094806476009 + 0.98986805452915 + 0.98865794178545 + 0.98729301606450 + 0.98574566927465 + 0.98398523689407 + 0.98197663681296 + 0.97968153335442 + 0.97705891930393 + 0.97406366458360 + 0.97064605395936 + 0.96675080288674 + 0.96231250624069 + 0.95724407628842 + 0.95144655010979 + 0.94483211405623 + 0.93732159110992 + 0.92883871323366 + 0.91931881256893 + 0.90871110559152 + 0.89698294417353 + 0.88412512812711 + 0.87015729048322 + 0.85513130725534 + 0.83912525870043 + 0.82222544139498 + 0.80455403743982 + 0.78631111465104 + 0.76774823943892 + 0.75842384571110 + 0.74911397725574 + 0.73984428634621 + 0.73063504897733 + 0.72150001514301 + 0.71244558654255 + 0.70347048371673 + 0.69456610070471 + 0.68571756063201 + 0.67690158362804 + 0.66802439684403 + 0.65881559440952 + 0.64913943213238 + 0.63898980151393 + 0.62836614254710 + 0.61729717271555 + 0.60581951292927 + 0.59397567664095 + 0.58181256502255 + 0.56938049046243 + 0.55673084244029 + 0.54388616166307 + 0.53089693044038 + 0.51781422839169 + 0.50468752649780 + 0.49156170902295 + 0.47847381461897 + 0.46543456809418 + 0.45243794363148 + 0.43947733295206 + 0.42653265842022 + 0.41357242244517 + 0.99976585848934 + 0.99980098126012 + 0.99980779297897 + 0.99981622443126 + 0.99982683963503 + 0.99984052793401 + 0.99985880953548 + 0.99988459060930 + 0.99992444572152 + 1.00000000000000 + 0.99991549881243 + 0.99986037290120 + 0.99981720383538 + 0.99977962200303 + 0.99974434738120 + 0.99970944373449 + 0.99967363609767 + 0.99963598127893 + 0.99959567682571 + 0.99955197839380 + 0.99950421245197 + 0.99945172784044 + 0.99939389022335 + 0.99933008239417 + 0.99925969354911 + 0.99918203387728 + 0.99909617316479 + 0.99900114181237 + 0.99889618335287 + 0.99878061876721 + 0.99865349604191 + 0.99851379290040 + 0.99836028380692 + 0.99819140502468 + 0.99800516504106 + 0.99779906002962 + 0.99756999400468 + 0.99731420129167 + 0.99702696557119 + 0.99670253036558 + 0.99633442600404 + 0.99591516109810 + 0.99543618015878 + 0.99488851750699 + 0.99426712576978 + 0.99357102664835 + 0.99279176627333 + 0.99191896373721 + 0.99094822575528 + 0.98986819628863 + 0.98865806688427 + 0.98729312668817 + 0.98574576729199 + 0.98398532391903 + 0.98197671423002 + 0.97968160236408 + 0.97705898094196 + 0.97406371975792 + 0.97064610345848 + 0.96675084740741 + 0.96231254638805 + 0.95724411257999 + 0.95144658297853 + 0.94483214387708 + 0.93732161821620 + 0.92883873790768 + 0.91931883505228 + 0.90871112608767 + 0.89698296285246 + 0.88412514513233 + 0.87015730593136 + 0.85513132124652 + 0.83912527132222 + 0.82222545273049 + 0.80455404756186 + 0.78631112364730 + 0.76774824739895 + 0.75842385319122 + 0.74911398428092 + 0.73984429294119 + 0.73063505516922 + 0.72150002095864 + 0.71244559200566 + 0.70347048884952 + 0.69456610552909 + 0.68571756516740 + 0.67690158789341 + 0.66802440085394 + 0.65881559816943 + 0.64913943564317 + 0.63898980477914 + 0.62836614556974 + 0.61729717550166 + 0.60581951548470 + 0.59397567897371 + 0.58181256714226 + 0.56938049237952 + 0.55673084416546 + 0.54388616320959 + 0.53089693181913 + 0.51781422961596 + 0.50468752757994 + 0.49156170997648 + 0.47847381545668 + 0.46543456882796 + 0.45243794427321 + 0.43947733351293 + 0.42653265891018 + 0.41357242287380 + 0.99974901124398 + 0.99977992545169 + 0.99978573125047 + 0.99979282140056 + 0.99980158916237 + 0.99981262088902 + 0.99982684965019 + 0.99984589601368 + 0.99987294082038 + 0.99991549881243 + 1.00000000000000 + 0.99990565460192 + 0.99984675933210 + 0.99980110024342 + 0.99976115082858 + 0.99972326930511 + 0.99968540387216 + 0.99964623106837 + 0.99960474689370 + 0.99956009115833 + 0.99951151989518 + 0.99945833692504 + 0.99939987819781 + 0.99933550656687 + 0.99926459786819 + 0.99918645337436 + 0.99910013683032 + 0.99900467586673 + 0.99889931434853 + 0.99878337502277 + 0.99865590749111 + 0.99851589117648 + 0.99836210157048 + 0.99819297487619 + 0.99800651838126 + 0.99780022607142 + 0.99757099914432 + 0.99731506882046 + 0.99702771560220 + 0.99670318000742 + 0.99633498970663 + 0.99591565096337 + 0.99543660629749 + 0.99488888845056 + 0.99426744903080 + 0.99357130892191 + 0.99279201320168 + 0.99191918010608 + 0.99094841579924 + 0.98986836363862 + 0.98865821457903 + 0.98729325730586 + 0.98574588304518 + 0.98398542670594 + 0.98197680568968 + 0.97968168390830 + 0.97705905379172 + 0.97406378498390 + 0.97064616198979 + 0.96675090006079 + 0.96231259388452 + 0.95724415552047 + 0.95144662187757 + 0.94483217917553 + 0.93732165030617 + 0.92883876712156 + 0.91931886167463 + 0.90871115036002 + 0.89698298497736 + 0.88412516527301 + 0.87015732423133 + 0.85513133782214 + 0.83912528628184 + 0.82222546616124 + 0.80455405955919 + 0.78631113431059 + 0.76774825683787 + 0.75842386206127 + 0.74911399261143 + 0.73984430076540 + 0.73063506251707 + 0.72150002785916 + 0.71244559848670 + 0.70347049494118 + 0.69456611125639 + 0.68571757055390 + 0.67690159295990 + 0.66802440561685 + 0.65881560263507 + 0.64913943981461 + 0.63898980865996 + 0.62836614916381 + 0.61729717881362 + 0.60581951852346 + 0.59397568174767 + 0.58181256966365 + 0.56938049466002 + 0.55673084621998 + 0.54388616505036 + 0.53089693346144 + 0.51781423107416 + 0.50468752886957 + 0.49156171111277 + 0.47847381645506 + 0.46543456970289 + 0.45243794503892 + 0.43947733418214 + 0.42653265949491 + 0.41357242338477 + 0.99973098992139 + 0.99975842531130 + 0.99976344518977 + 0.99976951072183 + 0.99977690712609 + 0.99978603907283 + 0.99979751151569 + 0.99981229411480 + 0.99983209690468 + 0.99986037290120 + 0.99990565460192 + 1.00000000000000 + 0.99989487725800 + 0.99983211064614 + 0.99978376165950 + 0.99974111396355 + 0.99970021662725 + 0.99965893283019 + 0.99961587357868 + 0.99956997677346 + 0.99952038361575 + 0.99946632819095 + 0.99940710227226 + 0.99934203993384 + 0.99927049812871 + 0.99919176568540 + 0.99910489802987 + 0.99900891878292 + 0.99890307179021 + 0.99878668163888 + 0.99865879965093 + 0.99851840715718 + 0.99836428076340 + 0.99819485653556 + 0.99800814025363 + 0.99780162325486 + 0.99757220332343 + 0.99731610794430 + 0.99702861380229 + 0.99670395780737 + 0.99633566443960 + 0.99591623715145 + 0.99543711606883 + 0.99488933205755 + 0.99426783550027 + 0.99357164630784 + 0.99279230828955 + 0.99191943865526 + 0.99094864290383 + 0.98986856365383 + 0.98865839114913 + 0.98729341351714 + 0.98574602153570 + 0.98398554974629 + 0.98197691523056 + 0.97968178162672 + 0.97705914114748 + 0.97406386324420 + 0.97064623226426 + 0.96675096332292 + 0.96231265098594 + 0.95724420718001 + 0.95144666869996 + 0.94483222168861 + 0.93732168896865 + 0.92883880233720 + 0.91931889378051 + 0.90871117964228 + 0.89698301167461 + 0.88412518958664 + 0.87015734632868 + 0.85513135784527 + 0.83912530435470 + 0.82222548239680 + 0.80455407406828 + 0.78631114721141 + 0.76774826826554 + 0.75842387280344 + 0.74911400270575 + 0.73984431024766 + 0.73063507142402 + 0.72150003622737 + 0.71244560635071 + 0.70347050233325 + 0.69456611820861 + 0.68571757709462 + 0.67690159911452 + 0.66802441140520 + 0.65881560806464 + 0.64913944488958 + 0.63898981338197 + 0.62836615353896 + 0.61729718284812 + 0.60581952222552 + 0.59397568513081 + 0.58181257273969 + 0.56938049744510 + 0.55673084872939 + 0.54388616730033 + 0.53089693546922 + 0.51781423285843 + 0.50468753044849 + 0.49156171250529 + 0.47847381767855 + 0.46543457077653 + 0.45243794597906 + 0.43947733500452 + 0.42653266021357 + 0.41357242401271 + 0.99971148344692 + 0.99973601293989 + 0.99974040907396 + 0.99974567755848 + 0.99975203382073 + 0.99975977083106 + 0.99976930353078 + 0.99978125263162 + 0.99979661959691 + 0.99981720383538 + 0.99984675933210 + 0.99989487725800 + 1.00000000000000 + 0.99988318763269 + 0.99981644963866 + 0.99976513530648 + 0.99971937809880 + 0.99967498701135 + 0.99962973870186 + 0.99958218442545 + 0.99953126447070 + 0.99947609881494 + 0.99941591049894 + 0.99934999050097 + 0.99927766823593 + 0.99919821470567 + 0.99911067357058 + 0.99901406259725 + 0.99890762496501 + 0.99879068706385 + 0.99866230202549 + 0.99852145325647 + 0.99836691858849 + 0.99819713378692 + 0.99801010275203 + 0.99780331355755 + 0.99757365982948 + 0.99731736451110 + 0.99702969966422 + 0.99670489782191 + 0.99633647961038 + 0.99591694507525 + 0.99543773145609 + 0.99488986734225 + 0.99426830164676 + 0.99357205312000 + 0.99279266402075 + 0.99191975031097 + 0.99094891666874 + 0.98986880481908 + 0.98865860412731 + 0.98729360203437 + 0.98574618876616 + 0.98398569842321 + 0.98197704769196 + 0.97968189989200 + 0.97705924696120 + 0.97406395812499 + 0.97064631754098 + 0.96675104016015 + 0.96231272039942 + 0.95724427003451 + 0.95144672571921 + 0.94483227349880 + 0.93732173612197 + 0.92883884530804 + 0.91931893297719 + 0.90871121540829 + 0.89698304430138 + 0.88412521931232 + 0.87015737335970 + 0.85513138235063 + 0.83912532648507 + 0.82222550228930 + 0.80455409185704 + 0.78631116304003 + 0.76774828229664 + 0.75842388599960 + 0.74911401510909 + 0.73984432190527 + 0.73063508237934 + 0.72150004652595 + 0.71244561603475 + 0.70347051144139 + 0.69456612677835 + 0.68571758516245 + 0.67690160670942 + 0.66802441855145 + 0.65881561477235 + 0.64913945116182 + 0.63898981922247 + 0.62836615895263 + 0.61729718784414 + 0.60581952681452 + 0.59397568932595 + 0.58181257655800 + 0.56938050090270 + 0.55673085184672 + 0.54388617009788 + 0.53089693796845 + 0.51781423508082 + 0.50468753241688 + 0.49156171424213 + 0.47847381920688 + 0.46543457211780 + 0.45243794715363 + 0.43947733603241 + 0.42653266111305 + 0.41357242479985 + 0.99969020500286 + 0.99971227893525 + 0.99971617103022 + 0.99972080641251 + 0.99972635418216 + 0.99973303648085 + 0.99974115425148 + 0.99975113253166 + 0.99976360799964 + 0.99977962200303 + 0.99980110024342 + 0.99983211064614 + 0.99988318763269 + 1.00000000000000 + 0.99987058413426 + 0.99979972924103 + 0.99974507981365 + 0.99969572084107 + 0.99964726308565 + 0.99959741364779 + 0.99954472680449 + 0.99948812224370 + 0.99942671006602 + 0.99935971383213 + 0.99928642131999 + 0.99920607719095 + 0.99911770808664 + 0.99902032300203 + 0.99891316329524 + 0.99879555691062 + 0.99866655871352 + 0.99852515432073 + 0.99837012281178 + 0.99819989944680 + 0.99801248569565 + 0.99780536559686 + 0.99757542767712 + 0.99731888933213 + 0.99703101699535 + 0.99670603787609 + 0.99633746791687 + 0.99591780302713 + 0.99543847694663 + 0.99489051551066 + 0.99426886585431 + 0.99357254534293 + 0.99279309434333 + 0.99192012726989 + 0.99094924781744 + 0.98986909660687 + 0.98865886191190 + 0.98729383032995 + 0.98574639141613 + 0.98398587871755 + 0.98197720844863 + 0.97968204354139 + 0.97705937560393 + 0.97406407358304 + 0.97064642141076 + 0.96675113384133 + 0.96231280511404 + 0.95724434681303 + 0.95144679542598 + 0.94483233688838 + 0.93732179385181 + 0.92883889795637 + 0.91931898102952 + 0.90871125928308 + 0.89698308434298 + 0.88412525581684 + 0.87015740656737 + 0.85513141246940 + 0.83912535369981 + 0.82222552676587 + 0.80455411375877 + 0.78631118254552 + 0.76774829960163 + 0.75842390228080 + 0.74911403042263 + 0.73984433630549 + 0.73063509592068 + 0.72150005926076 + 0.71244562801493 + 0.70347052271703 + 0.69456613739374 + 0.68571759516038 + 0.67690161612633 + 0.66802442741842 + 0.65881562309950 + 0.64913945895100 + 0.63898982648065 + 0.62836616568554 + 0.61729719406162 + 0.60581953252935 + 0.59397569455408 + 0.58181258131908 + 0.56938050521861 + 0.55673085574148 + 0.54388617359613 + 0.53089694109609 + 0.51781423786464 + 0.50468753488419 + 0.49156171642149 + 0.47847382112575 + 0.46543457380311 + 0.45243794863186 + 0.43947733732699 + 0.42653266224583 + 0.41357242579164 + 0.99966686140904 + 0.99968683618765 + 0.99969031346681 + 0.99969443520733 + 0.99969933867590 + 0.99970519936348 + 0.99971224685284 + 0.99972079098468 + 0.99973126941859 + 0.99974434738120 + 0.99976115082858 + 0.99978376165950 + 0.99981644963866 + 0.99987058413426 + 1.00000000000000 + 0.99985704521796 + 0.99978184965993 + 0.99972339251576 + 0.99966983103887 + 0.99961663629003 + 0.99956151572020 + 0.99950300311129 + 0.99944000957238 + 0.99937164731259 + 0.99929713840798 + 0.99921568727682 + 0.99912629513626 + 0.99902795757809 + 0.99891991213092 + 0.99880148755989 + 0.99867174013404 + 0.99852965767448 + 0.99837402041219 + 0.99820326270734 + 0.99801538290627 + 0.99780785998732 + 0.99757757618653 + 0.99732074209814 + 0.99703261727245 + 0.99670742242637 + 0.99633866780209 + 0.99591884428668 + 0.99543938136620 + 0.99489130152968 + 0.99426954977969 + 0.99357314180746 + 0.99279361567045 + 0.99192058389767 + 0.99094964897812 + 0.98986945016071 + 0.98865917438501 + 0.98729410719979 + 0.98574663733466 + 0.98398609765992 + 0.98197740382028 + 0.97968221826305 + 0.97705953220738 + 0.97406421426700 + 0.97064654809157 + 0.96675124820771 + 0.96231290862659 + 0.95724444071534 + 0.95144688074906 + 0.94483241453995 + 0.93732186462306 + 0.92883896253392 + 0.91931904000606 + 0.90871131315356 + 0.89698313353038 + 0.88412530067896 + 0.87015744739897 + 0.85513144952446 + 0.83912538720089 + 0.82222555691627 + 0.80455414075540 + 0.78631120660580 + 0.76774832096802 + 0.75842392239171 + 0.74911404934561 + 0.73984435410821 + 0.73063511267026 + 0.72150007502321 + 0.71244564285160 + 0.70347053668806 + 0.69456615055365 + 0.68571760756072 + 0.67690162781484 + 0.66802443842923 + 0.65881563344595 + 0.64913946863770 + 0.63898983551118 + 0.62836617406887 + 0.61729720180654 + 0.60581953965453 + 0.59397570107695 + 0.58181258726323 + 0.56938051061159 + 0.55673086061116 + 0.54388617797410 + 0.53089694501256 + 0.51781424135399 + 0.50468753797907 + 0.49156171915728 + 0.47847382353688 + 0.46543457592306 + 0.45243795049169 + 0.43947733895750 + 0.42653266367441 + 0.41357242704234 + 0.99964113330880 + 0.99965929323901 + 0.99966242314254 + 0.99966611974881 + 0.99967049762922 + 0.99967570023216 + 0.99968191026146 + 0.99968936592703 + 0.99969838913923 + 0.99970944373449 + 0.99972326930511 + 0.99974111396355 + 0.99976513530648 + 0.99979972924103 + 0.99985704521796 + 1.00000000000000 + 0.99984253743803 + 0.99976267194681 + 0.99969979759133 + 0.99964132196089 + 0.99958267919907 + 0.99952155417813 + 0.99945647317546 + 0.99938635134201 + 0.99931030140034 + 0.99922746363499 + 0.99913680002818 + 0.99903728518626 + 0.99892814922232 + 0.99880872021328 + 0.99867805501020 + 0.99853514331116 + 0.99837876619279 + 0.99820735650515 + 0.99801890845909 + 0.99781089466622 + 0.99758018953291 + 0.99732299526845 + 0.99703456297244 + 0.99670910543790 + 0.99634012594528 + 0.99592010926708 + 0.99544047971435 + 0.99489225571845 + 0.99427037971498 + 0.99357386537615 + 0.99279424794634 + 0.99192113764279 + 0.99095013547748 + 0.98986987901405 + 0.98865955354634 + 0.98729444332209 + 0.98574693605288 + 0.98398636379352 + 0.98197764147525 + 0.97968243097054 + 0.97705972301712 + 0.97406438582799 + 0.97064670271469 + 0.96675138791714 + 0.96231303519467 + 0.95724455562647 + 0.95144698524524 + 0.94483250970616 + 0.93732195141524 + 0.92883904177513 + 0.91931911241019 + 0.90871137932747 + 0.89698319398630 + 0.88412535583691 + 0.87015749762519 + 0.85513149512653 + 0.83912542845215 + 0.82222559405905 + 0.80455417403717 + 0.78631123629109 + 0.76774834735136 + 0.75842394723659 + 0.74911407273673 + 0.73984437612557 + 0.73063513339616 + 0.72150009453529 + 0.71244566122714 + 0.70347055400042 + 0.69456616687197 + 0.68571762294669 + 0.67690164232404 + 0.66802445210610 + 0.65881564630486 + 0.64913948068172 + 0.63898984674790 + 0.62836618450480 + 0.61729721145701 + 0.60581954853550 + 0.59397570921438 + 0.58181259468410 + 0.56938051734928 + 0.55673086670161 + 0.54388618345197 + 0.53089694991800 + 0.51781424572637 + 0.50468754186176 + 0.49156172259253 + 0.47847382656656 + 0.46543457858881 + 0.45243795283302 + 0.43947734101030 + 0.42653266547385 + 0.41357242861919 + 0.99961266877871 + 0.99962924200939 + 0.99963207622322 + 0.99963541438434 + 0.99963935430208 + 0.99964401649319 + 0.99964955138648 + 0.99965615010655 + 0.99966406265955 + 0.99967363609767 + 0.99968540387216 + 0.99970021662725 + 0.99971937809880 + 0.99974507981365 + 0.99978184965993 + 0.99984253743803 + 1.00000000000000 + 0.99982701423926 + 0.99974198705597 + 0.99967394643244 + 0.99960979302526 + 0.99954491720136 + 0.99947699586869 + 0.99940456141903 + 0.99932653186804 + 0.99924193986470 + 0.99914968433032 + 0.99904870601968 + 0.99893822134815 + 0.99881755472997 + 0.99868576186654 + 0.99854183351944 + 0.99838455087975 + 0.99821234428092 + 0.99802320241056 + 0.99781458973546 + 0.99758337086075 + 0.99732573759057 + 0.99703693060937 + 0.99671115298197 + 0.99634189949126 + 0.99592164743281 + 0.99544181483211 + 0.99489341519326 + 0.99427138783774 + 0.99357474402919 + 0.99279501556818 + 0.99192180984879 + 0.99095072607371 + 0.98987039973397 + 0.98866001408135 + 0.98729485176344 + 0.98574729924817 + 0.98398668756835 + 0.98197793080686 + 0.97968269012057 + 0.97705995567364 + 0.97406459518658 + 0.97064689156005 + 0.96675155869757 + 0.96231319003745 + 0.95724469631803 + 0.95144711328577 + 0.94483262638953 + 0.93732205789308 + 0.92883913904558 + 0.91931920133337 + 0.90871146063218 + 0.89698326829301 + 0.88412542366697 + 0.87015755941601 + 0.85513155125434 + 0.83912547924764 + 0.82222563982666 + 0.80455421507182 + 0.78631127291615 + 0.76774837992917 + 0.75842397793001 + 0.74911410164566 + 0.73984440335167 + 0.73063515903679 + 0.72150011868843 + 0.71244568398694 + 0.70347057545518 + 0.69456618710455 + 0.68571764203298 + 0.67690166033359 + 0.66802446908963 + 0.65881566228160 + 0.64913949565631 + 0.63898986072559 + 0.62836619749596 + 0.61729722347622 + 0.60581955960591 + 0.59397571936367 + 0.58181260394689 + 0.56938052576428 + 0.55673087431242 + 0.54388619030357 + 0.53089695605842 + 0.51781425120453 + 0.50468754672983 + 0.49156172690184 + 0.47847383037082 + 0.46543458193825 + 0.45243795577649 + 0.43947734359403 + 0.42653266773934 + 0.41357243060562 + 0.99958108181559 + 0.99959625194236 + 0.99959883046679 + 0.99960186108466 + 0.99960542879923 + 0.99960963709201 + 0.99961461317720 + 0.99962051561734 + 0.99962754695933 + 0.99963598127893 + 0.99964623106837 + 0.99965893283019 + 0.99967498701135 + 0.99969572084107 + 0.99972339251576 + 0.99976267194681 + 0.99982701423926 + 1.00000000000000 + 0.99981037309085 + 0.99971951035515 + 0.99964547919356 + 0.99957479538136 + 0.99950283024799 + 0.99942726804268 + 0.99934664671198 + 0.99925980595725 + 0.99916553808950 + 0.99906272733919 + 0.99895056514337 + 0.99882836661664 + 0.99869518302604 + 0.99855000438541 + 0.99839161060400 + 0.99821842788701 + 0.99802843737093 + 0.99781909299095 + 0.99758724695748 + 0.99732907806552 + 0.99703981411146 + 0.99671364616003 + 0.99634405857226 + 0.99592351950825 + 0.99544343931650 + 0.99489482549617 + 0.99427261364418 + 0.99357581210829 + 0.99279594848616 + 0.99192262671220 + 0.99095144377937 + 0.98987103263245 + 0.98866057400220 + 0.98729534856010 + 0.98574774123597 + 0.98398708182044 + 0.98197828334615 + 0.97968300611115 + 0.97706023956593 + 0.97406485084107 + 0.97064712234874 + 0.96675176757429 + 0.96231337956998 + 0.95724486865798 + 0.95144727023003 + 0.94483276950534 + 0.93732218856346 + 0.92883925847680 + 0.91931931056078 + 0.90871156054828 + 0.89698335964525 + 0.88412550708880 + 0.87015763544163 + 0.85513162033986 + 0.83912554180272 + 0.82222569621682 + 0.80455426566331 + 0.78631131810398 + 0.76774842015555 + 0.75842401584813 + 0.74911413737404 + 0.73984443701421 + 0.73063519075779 + 0.72150014858509 + 0.71244571217222 + 0.70347060203738 + 0.69456621218541 + 0.68571766570501 + 0.67690168268099 + 0.66802449017736 + 0.65881568212981 + 0.64913951426851 + 0.63898987810945 + 0.62836621366171 + 0.61729723844127 + 0.60581957339839 + 0.59397573201709 + 0.58181261550287 + 0.56938053627104 + 0.55673088382169 + 0.54388619887059 + 0.53089696374182 + 0.51781425806497 + 0.50468755283006 + 0.49156173230681 + 0.47847383514488 + 0.46543458614530 + 0.45243795947607 + 0.43947734684269 + 0.42653267059017 + 0.41357243310633 + 0.99954592959527 + 0.99955984401007 + 0.99956219791626 + 0.99956496008446 + 0.99956820541281 + 0.99957202426717 + 0.99957652646901 + 0.99958184699123 + 0.99958815531558 + 0.99959567682571 + 0.99960474689370 + 0.99961587357868 + 0.99962973870186 + 0.99964726308565 + 0.99966983103887 + 0.99969979759133 + 0.99974198705597 + 0.99981037309085 + 1.00000000000000 + 0.99979248006984 + 0.99969497762646 + 0.99961401296972 + 0.99953585421456 + 0.99945587407510 + 0.99937176458477 + 0.99928198694805 + 0.99918514119439 + 0.99908001281646 + 0.99896574746310 + 0.99884164039415 + 0.99870673226540 + 0.99856000884832 + 0.99840024616709 + 0.99822586369433 + 0.99803483206792 + 0.99782459138390 + 0.99759197798654 + 0.99733315428094 + 0.99704333196384 + 0.99671668723383 + 0.99634669159866 + 0.99592580200989 + 0.99544541942652 + 0.99489654402176 + 0.99427410689069 + 0.99357711286443 + 0.99279708440909 + 0.99192362121349 + 0.99095231758241 + 0.98987180330992 + 0.98866125601364 + 0.98729595392687 + 0.98574828008257 + 0.98398756274437 + 0.98197871365494 + 0.97968339206763 + 0.97706058656404 + 0.97406516355520 + 0.97064740486394 + 0.96675202345773 + 0.96231361192403 + 0.95724508008347 + 0.95144746289436 + 0.94483294529748 + 0.93732234915386 + 0.92883940532330 + 0.91931944492272 + 0.90871168350061 + 0.89698347209998 + 0.88412560981665 + 0.87015772909740 + 0.85513170548715 + 0.83912561893209 + 0.82222576578467 + 0.80455432811115 + 0.78631137392543 + 0.76774846988621 + 0.75842406274278 + 0.74911418158599 + 0.73984447868975 + 0.73063523004575 + 0.72150018563251 + 0.71244574711767 + 0.70347063501304 + 0.69456624331548 + 0.68571769510236 + 0.67690171044783 + 0.66802451639141 + 0.65881570681578 + 0.64913953743086 + 0.63898989975494 + 0.62836623380156 + 0.61729725709991 + 0.60581959060364 + 0.59397574781219 + 0.58181262993703 + 0.56938054940343 + 0.55673089571651 + 0.54388620959524 + 0.53089697336484 + 0.51781426666364 + 0.50468756048240 + 0.49156173909162 + 0.47847384114297 + 0.46543459143415 + 0.45243796413035 + 0.43947735093297 + 0.42653267418201 + 0.41357243625740 + 0.99950671213250 + 0.99951948880798 + 0.99952164228489 + 0.99952416614637 + 0.99952712706913 + 0.99953060494947 + 0.99953469608778 + 0.99953951758755 + 0.99954521470886 + 0.99955197839380 + 0.99956009115833 + 0.99956997677346 + 0.99958218442545 + 0.99959741364779 + 0.99961663629003 + 0.99964132196089 + 0.99967394643244 + 0.99971951035515 + 0.99979248006984 + 1.00000000000000 + 0.99977324687178 + 0.99966810833830 + 0.99957914180955 + 0.99949246896095 + 0.99940346651698 + 0.99930975016085 + 0.99920954105671 + 0.99910144161980 + 0.99898451166480 + 0.99885800641178 + 0.99872094444159 + 0.99857230068564 + 0.99841084259292 + 0.99823497865712 + 0.99804266461022 + 0.99783132206765 + 0.99759776677850 + 0.99733814025397 + 0.99704763390251 + 0.99672040536284 + 0.99634991020748 + 0.99592859154838 + 0.99544783880674 + 0.99489864321637 + 0.99427593036803 + 0.99357870088102 + 0.99279847092059 + 0.99192483498061 + 0.99095338405800 + 0.98987274407153 + 0.98866208878236 + 0.98729669339724 + 0.98574893861178 + 0.98398815080751 + 0.98197924015565 + 0.97968386460295 + 0.97706101169574 + 0.97406554696479 + 0.97064775149261 + 0.96675233763918 + 0.96231389742567 + 0.95724534005271 + 0.95144769994130 + 0.94483316170637 + 0.93732254694689 + 0.92883958626936 + 0.91931961055100 + 0.90871183511784 + 0.89698361082363 + 0.88412573659352 + 0.87015784472224 + 0.85513181064502 + 0.83912571423589 + 0.82222585178652 + 0.80455440536107 + 0.78631144302242 + 0.76774853149595 + 0.75842412086716 + 0.74911423640624 + 0.73984453039299 + 0.73063527881274 + 0.72150023163987 + 0.71244579053722 + 0.70347067600573 + 0.69456628203440 + 0.68571773168561 + 0.67690174502057 + 0.66802454904713 + 0.65881573758625 + 0.64913956631802 + 0.63898992676532 + 0.62836625894952 + 0.61729728040912 + 0.60581961211388 + 0.59397576757048 + 0.58181264800762 + 0.56938056585311 + 0.55673091062643 + 0.54388622304560 + 0.53089698544576 + 0.51781427746540 + 0.50468757010111 + 0.49156174762751 + 0.47847384869435 + 0.46543459809684 + 0.45243796999712 + 0.43947735609235 + 0.42653267871406 + 0.41357244023717 + 0.99946292476675 + 0.99947465866079 + 0.99947663070219 + 0.99947893972902 + 0.99948164553355 + 0.99948481939329 + 0.99948854667423 + 0.99949293040876 + 0.99949809726304 + 0.99950421245197 + 0.99951151989518 + 0.99952038361575 + 0.99953126447070 + 0.99954472680449 + 0.99956151572020 + 0.99958267919907 + 0.99960979302526 + 0.99964547919356 + 0.99969497762646 + 0.99977324687178 + 1.00000000000000 + 0.99975250516452 + 0.99963854108384 + 0.99954037841837 + 0.99944404698572 + 0.99934484178195 + 0.99924013570120 + 0.99912816255438 + 0.99900781421729 + 0.99887826614220 + 0.99873849307015 + 0.99858744673072 + 0.99842387760361 + 0.99824617618761 + 0.99805227662281 + 0.99783957533646 + 0.99760486097280 + 0.99734424804822 + 0.99705290217564 + 0.99672495764563 + 0.99635385011139 + 0.99593200554348 + 0.99545079912440 + 0.99490121110291 + 0.99427816038585 + 0.99358064248618 + 0.99280016585418 + 0.99192631858929 + 0.99095468765017 + 0.98987389416416 + 0.98866310711561 + 0.98729759797227 + 0.98574974453085 + 0.98398887086252 + 0.98197988518687 + 0.97968444387662 + 0.97706153319224 + 0.97406601758630 + 0.97064817725996 + 0.96675272381633 + 0.96231424858364 + 0.95724566000027 + 0.95144799184536 + 0.94483342833551 + 0.93732279075554 + 0.92883980939658 + 0.91931981486287 + 0.90871202221646 + 0.89698378206288 + 0.88412589312929 + 0.87015798753576 + 0.85513194057982 + 0.83912583204739 + 0.82222595815445 + 0.80455450095984 + 0.78631152858996 + 0.76774860785027 + 0.75842419293267 + 0.74911430441035 + 0.73984459455757 + 0.73063533936149 + 0.72150028879209 + 0.71244584450184 + 0.70347072698249 + 0.69456633020786 + 0.68571777722372 + 0.67690178807635 + 0.66802458973886 + 0.65881577594791 + 0.64913960235097 + 0.63898996047461 + 0.62836629035402 + 0.61729730953559 + 0.60581963900769 + 0.59397579229082 + 0.58181267062825 + 0.56938058646055 + 0.55673092931689 + 0.54388623992001 + 0.53089700060906 + 0.51781429103391 + 0.50468758219291 + 0.49156175836471 + 0.47847385819893 + 0.46543460649044 + 0.45243797739341 + 0.43947736259893 + 0.42653268443371 + 0.41357244526073 + 0.99941403728548 + 0.99942480491630 + 0.99942661050258 + 0.99942872308405 + 0.99943119652336 + 0.99943409477905 + 0.99943749409947 + 0.99944148598536 + 0.99944618221859 + 0.99945172784044 + 0.99945833692504 + 0.99946632819095 + 0.99947609881494 + 0.99948812224370 + 0.99950300311129 + 0.99952155417813 + 0.99954491720136 + 0.99957479538136 + 0.99961401296972 + 0.99966810833830 + 0.99975250516452 + 1.00000000000000 + 0.99973004394020 + 0.99960586309592 + 0.99949716282804 + 0.99938982119835 + 0.99927888065436 + 0.99916173671468 + 0.99903692945227 + 0.99890347185426 + 0.99876025225461 + 0.99860617568807 + 0.99843996050505 + 0.99825996745381 + 0.99806409865239 + 0.99784971552053 + 0.99761357035291 + 0.99735174233078 + 0.99705936386638 + 0.99673053958536 + 0.99635868009346 + 0.99593618996498 + 0.99545442672985 + 0.99490435708175 + 0.99428089177579 + 0.99358302010108 + 0.99280224105823 + 0.99192813488126 + 0.99095628357109 + 0.98987530234818 + 0.98866435426184 + 0.98729870616579 + 0.98575073226624 + 0.98398975377141 + 0.98198067651452 + 0.97968515492772 + 0.97706217369254 + 0.97406659595917 + 0.97064870082518 + 0.96675319899177 + 0.96231468092719 + 0.95724605414765 + 0.95144835163373 + 0.94483375712110 + 0.93732309151206 + 0.92884008474412 + 0.91932006706800 + 0.90871225323257 + 0.89698399356260 + 0.88412608652750 + 0.87015816403036 + 0.85513210121932 + 0.83912597775142 + 0.82222608976327 + 0.80455461931285 + 0.78631163459559 + 0.76774870251342 + 0.75842428231506 + 0.74911438878915 + 0.73984467421042 + 0.73063541456464 + 0.72150035981237 + 0.71244591159357 + 0.70347079038902 + 0.69456639015630 + 0.68571783392368 + 0.67690184171415 + 0.66802464045481 + 0.65881582378199 + 0.64913964730485 + 0.63899000255567 + 0.62836632957581 + 0.61729734593442 + 0.60581967263543 + 0.59397582322027 + 0.58181269894765 + 0.56938061227596 + 0.55673095274579 + 0.54388626108574 + 0.53089701964413 + 0.51781430807736 + 0.50468759739296 + 0.49156177186961 + 0.47847387016328 + 0.46543461706089 + 0.45243798671321 + 0.43947737080418 + 0.42653269164888 + 0.41357245160142 + 0.99935950298591 + 0.99936936631599 + 0.99937101735313 + 0.99937294800993 + 0.99937520691900 + 0.99937785166462 + 0.99938095065139 + 0.99938458562056 + 0.99938885596701 + 0.99939389022335 + 0.99939987819781 + 0.99940710227226 + 0.99941591049894 + 0.99942671006602 + 0.99944000957238 + 0.99945647317546 + 0.99947699586869 + 0.99950283024799 + 0.99953585421456 + 0.99957914180955 + 0.99963854108384 + 0.99973004394020 + 1.00000000000000 + 0.99970560260901 + 0.99956958332554 + 0.99944874150182 + 0.99932864155713 + 0.99920435373967 + 0.99907359565459 + 0.99893503095338 + 0.99878737358699 + 0.99862943598009 + 0.99845987638082 + 0.99827700561815 + 0.99807867712077 + 0.99786220248312 + 0.99762428432552 + 0.99736095476752 + 0.99706730291231 + 0.99673739528900 + 0.99636461069041 + 0.99594132678097 + 0.99545887906856 + 0.99490821744520 + 0.99428424264812 + 0.99358593638492 + 0.99280478601605 + 0.99193036210727 + 0.99095824057177 + 0.98987702932369 + 0.98866588407382 + 0.98730006593094 + 0.98575194466868 + 0.98399083796498 + 0.98198164870334 + 0.97968602892625 + 0.97706296139322 + 0.97406730763869 + 0.97064934542971 + 0.96675378434612 + 0.96231521380830 + 0.95724654019008 + 0.95144879550784 + 0.94483416290484 + 0.93732346283743 + 0.92884042479540 + 0.91932037862543 + 0.90871253868345 + 0.89698425495583 + 0.88412632560221 + 0.87015838227526 + 0.85513229991314 + 0.83912615803483 + 0.82222625268428 + 0.80455476589712 + 0.78631176596623 + 0.76774881991605 + 0.75842439321472 + 0.74911449352193 + 0.73984477312339 + 0.73063550799215 + 0.72150044808252 + 0.71244599502428 + 0.70347086927671 + 0.69456646477760 + 0.68571790453419 + 0.67690190854278 + 0.66802470367423 + 0.65881588343969 + 0.64913970339841 + 0.63899005509104 + 0.62836637857036 + 0.61729739142574 + 0.60581971468785 + 0.59397586192099 + 0.58181273440476 + 0.56938064461860 + 0.55673098211611 + 0.54388628763531 + 0.53089704353474 + 0.51781432948383 + 0.50468761649516 + 0.49156178885387 + 0.47847388521883 + 0.46543463037200 + 0.45243799845680 + 0.43947738114841 + 0.42653270074996 + 0.41357245960155 + 0.99929876764338 + 0.99930777761321 + 0.99930928370691 + 0.99931104408898 + 0.99931310268998 + 0.99931551140789 + 0.99931833171620 + 0.99932163686029 + 0.99932551558486 + 0.99933008239417 + 0.99933550656687 + 0.99934203993384 + 0.99934999050097 + 0.99935971383213 + 0.99937164731259 + 0.99938635134201 + 0.99940456141903 + 0.99942726804268 + 0.99945587407510 + 0.99949246896095 + 0.99954037841837 + 0.99960586309592 + 0.99970560260901 + 1.00000000000000 + 0.99967884283140 + 0.99952899696640 + 0.99939394019042 + 0.99925922899241 + 0.99912026177553 + 0.99897487282740 + 0.99882140453802 + 0.99865848222045 + 0.99848465056141 + 0.99829813473539 + 0.99809671206732 + 0.99787762134132 + 0.99763749571092 + 0.99737230343808 + 0.99707707620752 + 0.99674583095376 + 0.99637190561718 + 0.99594764371653 + 0.99546435307819 + 0.99491296261834 + 0.99428836067445 + 0.99358951965567 + 0.99280791257777 + 0.99193309807603 + 0.99096064457753 + 0.98987915095867 + 0.98866776383326 + 0.98730173718455 + 0.98575343528786 + 0.98399217145281 + 0.98198284493131 + 0.97968710481788 + 0.97706393150004 + 0.97406818454576 + 0.97065014007825 + 0.96675450630592 + 0.96231587136127 + 0.95724714021112 + 0.95144934368486 + 0.94483466421025 + 0.93732392170480 + 0.92884084511877 + 0.91932076380144 + 0.90871289165730 + 0.89698457824016 + 0.88412662134445 + 0.87015865230826 + 0.85513254582242 + 0.83912638123581 + 0.82222645446422 + 0.80455494753716 + 0.78631192885031 + 0.76774896558059 + 0.75842453086293 + 0.74911462357557 + 0.73984489600000 + 0.73063562410847 + 0.72150055783944 + 0.71244609880730 + 0.70347096745463 + 0.69456655769023 + 0.68571799249315 + 0.67690199182997 + 0.66802478249884 + 0.65881595786018 + 0.64913977340577 + 0.63899012069143 + 0.62836643978044 + 0.61729744829044 + 0.60581976728336 + 0.59397591035050 + 0.58181277880115 + 0.56938068513652 + 0.55673101893466 + 0.54388632093718 + 0.53089707352132 + 0.51781435636758 + 0.50468764050037 + 0.49156181021284 + 0.47847390416281 + 0.46543464713102 + 0.45243801325127 + 0.43947739418704 + 0.42653271222729 + 0.41357246969494 + 0.99923126413944 + 0.99923946391600 + 0.99924083305817 + 0.99924243280306 + 0.99924430277315 + 0.99924648969899 + 0.99924904882072 + 0.99925204579270 + 0.99925555996205 + 0.99925969354911 + 0.99926459786819 + 0.99927049812871 + 0.99927766823593 + 0.99928642131999 + 0.99929713840798 + 0.99931030140034 + 0.99932653186804 + 0.99934664671198 + 0.99937176458477 + 0.99940346651698 + 0.99944404698572 + 0.99949716282804 + 0.99956958332554 + 0.99967884283140 + 1.00000000000000 + 0.99964921143273 + 0.99948294479708 + 0.99933144510445 + 0.99918055013100 + 0.99902574111029 + 0.99886448732011 + 0.99869501642280 + 0.99851565175126 + 0.99832446681556 + 0.99811911593106 + 0.99789672823938 + 0.99765383717912 + 0.99738632237998 + 0.99708913796516 + 0.99675623526591 + 0.99638089904838 + 0.99595542900167 + 0.99547109780666 + 0.99491880801155 + 0.99429343243563 + 0.99359393201293 + 0.99281176200562 + 0.99193646629671 + 0.99096360408009 + 0.98988176305062 + 0.98867007850882 + 0.98730379558333 + 0.98575527173770 + 0.98399381486625 + 0.98198431972197 + 0.97968843177223 + 0.97706512848700 + 0.97406926699200 + 0.97065112141350 + 0.96675539825715 + 0.96231668407765 + 0.95724788210239 + 0.95145002169737 + 0.94483528442257 + 0.93732448954187 + 0.92884136535585 + 0.91932124061725 + 0.90871332866286 + 0.89698497855210 + 0.88412698760487 + 0.87015898678619 + 0.85513285048982 + 0.83912665785188 + 0.82222670462973 + 0.80455517283230 + 0.78631213099842 + 0.76774914647963 + 0.75842470187028 + 0.74911478521229 + 0.73984504877808 + 0.73063576854063 + 0.72150069442395 + 0.71244622802079 + 0.70347108974397 + 0.69456667347405 + 0.68571810215585 + 0.67690209571245 + 0.66802488086128 + 0.65881605076882 + 0.64913986084960 + 0.63899020266766 + 0.62836651630928 + 0.61729751942490 + 0.60581983310978 + 0.59397597099706 + 0.58181283442877 + 0.56938073593307 + 0.55673106511949 + 0.54388636273595 + 0.53089711118093 + 0.51781439015095 + 0.50468767068476 + 0.49156183708430 + 0.47847392801315 + 0.46543466824206 + 0.45243803189702 + 0.43947741062799 + 0.42653272670685 + 0.41357248243344 + 0.99915633241552 + 0.99916375987448 + 0.99916499894337 + 0.99916644629681 + 0.99916813756762 + 0.99917011472540 + 0.99917242729893 + 0.99917513404650 + 0.99917830583590 + 0.99918203387728 + 0.99918645337436 + 0.99919176568540 + 0.99919821470567 + 0.99920607719095 + 0.99921568727682 + 0.99922746363499 + 0.99924193986470 + 0.99925980595725 + 0.99928198694805 + 0.99930975016085 + 0.99934484178195 + 0.99938982119835 + 0.99944874150182 + 0.99952899696640 + 0.99964921143273 + 1.00000000000000 + 0.99961577315979 + 0.99943021207586 + 0.99926028771839 + 0.99909179450283 + 0.99891975412426 + 0.99874146558820 + 0.99855479495396 + 0.99835753445112 + 0.99814713121778 + 0.99792054308944 + 0.99767415584732 + 0.99740372270807 + 0.99710409054036 + 0.99676912216005 + 0.99639203189081 + 0.99596506234485 + 0.99547944100694 + 0.99492603686602 + 0.99429970314490 + 0.99359938640080 + 0.99281651983701 + 0.99194062898648 + 0.99096726160539 + 0.98988499146634 + 0.98867293977193 + 0.98730634062494 + 0.98575754298750 + 0.98399584803261 + 0.98198614492405 + 0.97969007463597 + 0.97706661102789 + 0.97407060822201 + 0.97065233786347 + 0.96675650436217 + 0.96231769231430 + 0.95724880280740 + 0.95145086339274 + 0.94483605456753 + 0.93732519479407 + 0.92884201159738 + 0.91932183299701 + 0.90871387165861 + 0.89698547600260 + 0.88412744281273 + 0.87015940256406 + 0.85513322929722 + 0.83912700187658 + 0.82222701587126 + 0.80455545325971 + 0.78631238275974 + 0.76774937193092 + 0.75842491507548 + 0.74911498681085 + 0.73984523941437 + 0.73063594884199 + 0.72150086500697 + 0.71244638946884 + 0.70347124261179 + 0.69456681827678 + 0.68571823936396 + 0.67690222575071 + 0.66802500404903 + 0.65881616717902 + 0.64913997046444 + 0.63899030548017 + 0.62836661233880 + 0.61729760872917 + 0.60581991580030 + 0.59397604722118 + 0.58181290438318 + 0.56938079985157 + 0.55673112326520 + 0.54388641539239 + 0.53089715865101 + 0.51781443276090 + 0.50468770878028 + 0.49156187101927 + 0.47847395814883 + 0.46543469493384 + 0.45243805548711 + 0.43947743143890 + 0.42653274504289 + 0.41357249857155 + 0.99907306284423 + 0.99907975215577 + 0.99908086725583 + 0.99908216949785 + 0.99908369078594 + 0.99908546865139 + 0.99908754733549 + 0.99908997923590 + 0.99909282745874 + 0.99909617316479 + 0.99910013683032 + 0.99910489802987 + 0.99911067357058 + 0.99911770808664 + 0.99912629513626 + 0.99913680002818 + 0.99914968433032 + 0.99916553808950 + 0.99918514119439 + 0.99920954105671 + 0.99924013570120 + 0.99927888065436 + 0.99932864155713 + 0.99939394019042 + 0.99948294479708 + 0.99961577315979 + 1.00000000000000 + 0.99957781862129 + 0.99937017612879 + 0.99917991627800 + 0.99899212443070 + 0.99880152054192 + 0.99860492731507 + 0.99839957794057 + 0.99818255050306 + 0.99795052252053 + 0.99769965227907 + 0.99742550646455 + 0.99712277914809 + 0.99678521054213 + 0.99640591951920 + 0.99597707280554 + 0.99548983877062 + 0.99493504295654 + 0.99430751341515 + 0.99360617849911 + 0.99282244363611 + 0.99194581134627 + 0.99097181507655 + 0.98988901113501 + 0.98867650299736 + 0.98730951090647 + 0.98576037315794 + 0.98399838249092 + 0.98198842109294 + 0.97969212432253 + 0.97706846154864 + 0.97407228316234 + 0.97065385771239 + 0.96675788701394 + 0.96231895322026 + 0.95724995473144 + 0.95145191685249 + 0.94483701877330 + 0.93732607799376 + 0.92884282107057 + 0.91932257514679 + 0.90871455204699 + 0.89698609943278 + 0.88412801340229 + 0.87015992384997 + 0.85513370435709 + 0.83912743346155 + 0.82222740649542 + 0.80455580540438 + 0.78631269911097 + 0.76774965543864 + 0.75842518329720 + 0.74911524055162 + 0.73984547946736 + 0.73063617599776 + 0.72150108002344 + 0.71244659307697 + 0.70347143549815 + 0.69456700107883 + 0.68571841266980 + 0.67690239008441 + 0.66802515979864 + 0.65881631443764 + 0.64914010919806 + 0.63899043567747 + 0.62836673401235 + 0.61729772195135 + 0.60582002069287 + 0.59397614397308 + 0.58181299322950 + 0.56938088108260 + 0.55673119720840 + 0.54388648239525 + 0.53089721909444 + 0.51781448705329 + 0.50468775735071 + 0.49156191431538 + 0.47847399662398 + 0.46543472903426 + 0.45243808564091 + 0.43947745805885 + 0.42653276850830 + 0.41357251923192 + 0.99898049246822 + 0.99898647739415 + 0.99898747445403 + 0.99898863861661 + 0.99898999828696 + 0.99899158684981 + 0.99899344361476 + 0.99899561508107 + 0.99899815717791 + 0.99900114181237 + 0.99900467586673 + 0.99900891878292 + 0.99901406259725 + 0.99902032300203 + 0.99902795757809 + 0.99903728518626 + 0.99904870601968 + 0.99906272733919 + 0.99908001281646 + 0.99910144161980 + 0.99912816255438 + 0.99916173671468 + 0.99920435373967 + 0.99925922899241 + 0.99933144510445 + 0.99943021207586 + 0.99957781862129 + 1.00000000000000 + 0.99953505057537 + 0.99930242951439 + 0.99908954538823 + 0.99888081583094 + 0.99867023382437 + 0.99845379857159 + 0.99822787959744 + 0.99798866798075 + 0.99773195441094 + 0.99745301900192 + 0.99714633035966 + 0.99680545364751 + 0.99642337487504 + 0.99599215756402 + 0.99550289106419 + 0.99494634367146 + 0.99431731047318 + 0.99361469634445 + 0.99282987135261 + 0.99195230884739 + 0.99097752420725 + 0.98989405164771 + 0.98868097217377 + 0.98731348847582 + 0.98576392534396 + 0.98400156488665 + 0.98199128049686 + 0.97969470049082 + 0.97707078860414 + 0.97407439054186 + 0.97065577099457 + 0.96675962851707 + 0.96232054220025 + 0.95725140707275 + 0.95145324561756 + 0.94483823540270 + 0.93732719274760 + 0.92884384303255 + 0.91932351231416 + 0.90871541140592 + 0.89698688701722 + 0.88412873439347 + 0.87016058271166 + 0.85513430498182 + 0.83912797933511 + 0.82222790080163 + 0.80455625127677 + 0.78631309994881 + 0.76775001496726 + 0.75842552360172 + 0.74911556263638 + 0.73984578434014 + 0.73063646464166 + 0.72150135339073 + 0.71244685208188 + 0.70347168100150 + 0.69456723387883 + 0.68571863349366 + 0.67690259958923 + 0.66802535846968 + 0.65881650238135 + 0.64914028636026 + 0.63899060203374 + 0.62836688957061 + 0.61729786678963 + 0.60582015496192 + 0.59397626789765 + 0.58181310710486 + 0.56938098526376 + 0.55673129210595 + 0.54388656844425 + 0.53089729677384 + 0.51781455687593 + 0.50468781985912 + 0.49156197007530 + 0.47847404620897 + 0.46543477301105 + 0.45243812455445 + 0.43947749243006 + 0.42653279882360 + 0.41357254593684 + 0.99887785652967 + 0.99888317426547 + 0.99888405970398 + 0.99888509336760 + 0.99888630039041 + 0.99888771029025 + 0.99888935778672 + 0.99889128391715 + 0.99889353798370 + 0.99889618335287 + 0.99889931434853 + 0.99890307179021 + 0.99890762496501 + 0.99891316329524 + 0.99891991213092 + 0.99892814922232 + 0.99893822134815 + 0.99895056514337 + 0.99896574746310 + 0.99898451166480 + 0.99900781421729 + 0.99903692945227 + 0.99907359565459 + 0.99912026177553 + 0.99918055013100 + 0.99926028771839 + 0.99937017612879 + 0.99953505057537 + 1.00000000000000 + 0.99948697090768 + 0.99922593796792 + 0.99898823629492 + 0.99875691010917 + 0.99852472626375 + 0.99828654230596 + 0.99803763962531 + 0.99777317994783 + 0.99748798210628 + 0.99717616868934 + 0.99683104635514 + 0.99644541077558 + 0.99601118152742 + 0.99551934013832 + 0.99496057796286 + 0.99432964600777 + 0.99362541826009 + 0.99283921936669 + 0.99196048539248 + 0.99098470874596 + 0.98990039554728 + 0.98868659822048 + 0.98731849711810 + 0.98576839991757 + 0.98400557524988 + 0.98199488540362 + 0.97969794981819 + 0.97707372513081 + 0.97407705117588 + 0.97065818778108 + 0.96676182941260 + 0.96232255129378 + 0.95725324419902 + 0.95145492705954 + 0.94483977544434 + 0.93732860420344 + 0.92884513728288 + 0.91932469941196 + 0.90871650012814 + 0.89698788498323 + 0.88412964815758 + 0.87016141792174 + 0.85513506658917 + 0.83912867176481 + 0.82222852810580 + 0.80455681744405 + 0.78631360928195 + 0.76775047218756 + 0.75842595657084 + 0.74911597262901 + 0.73984617261598 + 0.73063683244074 + 0.72150170191357 + 0.71244718247334 + 0.70347199433832 + 0.69456753116004 + 0.68571891563558 + 0.67690286741101 + 0.66802561257639 + 0.65881674289388 + 0.64914051320285 + 0.63899081515774 + 0.62836708897853 + 0.61729805256319 + 0.60582032728364 + 0.59397642704043 + 0.58181325343196 + 0.56938111921820 + 0.55673141420491 + 0.54388667923083 + 0.53089739684864 + 0.51781464689058 + 0.50468790049980 + 0.49156204205857 + 0.47847411026618 + 0.46543482986052 + 0.45243817489087 + 0.43947753691675 + 0.42653283808234 + 0.41357258053483 + 0.99876446127449 + 0.99876915401477 + 0.99876993503621 + 0.99877084667077 + 0.99877191102776 + 0.99877315404122 + 0.99877460620158 + 0.99877630350881 + 0.99877828918346 + 0.99878061876721 + 0.99878337502277 + 0.99878668163888 + 0.99879068706385 + 0.99879555691062 + 0.99880148755989 + 0.99880872021328 + 0.99881755472997 + 0.99882836661664 + 0.99884164039415 + 0.99885800641178 + 0.99887826614220 + 0.99890347185426 + 0.99893503095338 + 0.99897487282740 + 0.99902574111029 + 0.99909179450283 + 0.99917991627800 + 0.99930242951439 + 0.99948697090768 + 1.00000000000000 + 0.99943243132148 + 0.99913959809264 + 0.99887491848554 + 0.99861919552657 + 0.99836346948599 + 0.99810113345345 + 0.99782619070740 + 0.99753267422015 + 0.99721415012125 + 0.99686352799245 + 0.99647332152632 + 0.99603524382279 + 0.99554012560607 + 0.99497855255638 + 0.99434521534599 + 0.99363894642178 + 0.99285101144901 + 0.99197079848457 + 0.99099377049110 + 0.98990839771696 + 0.98869369615346 + 0.98732481768107 + 0.98577404821080 + 0.98401063928222 + 0.98199943912732 + 0.97970205596184 + 0.97707743749714 + 0.97408041614581 + 0.97066124563125 + 0.96676461524407 + 0.96232509534022 + 0.95725557130531 + 0.95145705759526 + 0.94484172727962 + 0.93733039341721 + 0.92884677816649 + 0.91932620461029 + 0.90871788074001 + 0.89698915064429 + 0.88413080718206 + 0.87016247749703 + 0.85513603300497 + 0.83912955067735 + 0.82222932466965 + 0.80455753673820 + 0.78631425678763 + 0.76775105388582 + 0.75842650765351 + 0.74911649469735 + 0.73984666726825 + 0.73063730123643 + 0.72150214636206 + 0.71244760401557 + 0.70347239432339 + 0.69456791084691 + 0.68571927616964 + 0.67690320981446 + 0.66802593760654 + 0.65881705069112 + 0.64914080365237 + 0.63899108818753 + 0.62836734456990 + 0.61729829081442 + 0.60582054840753 + 0.59397663137162 + 0.58181344141888 + 0.56938129141545 + 0.55673157125199 + 0.54388682181653 + 0.53089752573114 + 0.51781476288668 + 0.50468800448440 + 0.49156213494067 + 0.47847419297270 + 0.46543490330859 + 0.45243823996370 + 0.43947759445970 + 0.42653288888758 + 0.41357262532850 + 0.99863934204255 + 0.99864345619100 + 0.99864414065414 + 0.99864493949096 + 0.99864587202110 + 0.99864696090343 + 0.99864823275776 + 0.99864971898924 + 0.99865145727973 + 0.99865349604191 + 0.99865590749111 + 0.99865879965093 + 0.99866230202549 + 0.99866655871352 + 0.99867174013404 + 0.99867805501020 + 0.99868576186654 + 0.99869518302604 + 0.99870673226540 + 0.99872094444159 + 0.99873849307015 + 0.99876025225461 + 0.99878737358699 + 0.99882140453802 + 0.99886448732011 + 0.99891975412426 + 0.99899212443070 + 0.99908954538823 + 0.99922593796792 + 0.99943243132148 + 1.00000000000000 + 0.99937071642000 + 0.99904257760322 + 0.99874861745731 + 0.99846640162693 + 0.99818469769706 + 0.99789514118523 + 0.99759032181930 + 0.99726285581023 + 0.99690501176477 + 0.99650886775362 + 0.99606583001109 + 0.99556651179769 + 0.99500134966708 + 0.99436494934157 + 0.99365608589154 + 0.99286594725832 + 0.99198385897635 + 0.99100524582961 + 0.98991853197205 + 0.98870268663889 + 0.98733282531666 + 0.98578120609781 + 0.98401705874376 + 0.98200521362851 + 0.97970726473824 + 0.97708214846405 + 0.97408468785811 + 0.97066512890842 + 0.96676815436287 + 0.96232832840585 + 0.95725852957258 + 0.95145976666542 + 0.94484420961219 + 0.93733266925442 + 0.92884886555011 + 0.91932811954464 + 0.90871963728902 + 0.89699076105560 + 0.88413228205651 + 0.87016382600083 + 0.85513726319370 + 0.83913066977794 + 0.82223033929832 + 0.80455845339044 + 0.78631508245589 + 0.76775179618291 + 0.75842721117289 + 0.74911716147527 + 0.73984729932034 + 0.73063790053575 + 0.72150271481750 + 0.71244814343801 + 0.70347290641908 + 0.69456839718964 + 0.68571973820511 + 0.67690364883077 + 0.66802635454963 + 0.65881744571653 + 0.64914117660156 + 0.63899143894589 + 0.62836767309990 + 0.61729859721841 + 0.60582083293940 + 0.59397689444343 + 0.58181368358407 + 0.56938151336608 + 0.55673177379517 + 0.54388700581890 + 0.53089769214822 + 0.51781491275947 + 0.50468813892197 + 0.49156225509972 + 0.47847430003610 + 0.46543499844456 + 0.45243832430126 + 0.43947766908053 + 0.42653295480435 + 0.41357268346910 + 0.99850146419999 + 0.99850505017771 + 0.99850564658118 + 0.99850634257425 + 0.99850715495279 + 0.99850810341313 + 0.99850921107320 + 0.99851050519653 + 0.99851201847616 + 0.99851379290040 + 0.99851589117648 + 0.99851840715718 + 0.99852145325647 + 0.99852515432073 + 0.99852965767448 + 0.99853514331116 + 0.99854183351944 + 0.99855000438541 + 0.99856000884832 + 0.99857230068564 + 0.99858744673072 + 0.99860617568807 + 0.99862943598009 + 0.99865848222045 + 0.99869501642280 + 0.99874146558820 + 0.99880152054192 + 0.99888081583094 + 0.99898823629492 + 0.99913959809264 + 0.99937071642000 + 1.00000000000000 + 0.99930096287532 + 0.99893384484190 + 0.99860809183951 + 0.99829685716134 + 0.99798609480973 + 0.99766545769938 + 0.99732581247888 + 0.99695832788805 + 0.99655437426566 + 0.99610488225061 + 0.99560014023338 + 0.99503036764359 + 0.99439004680180 + 0.99367787110835 + 0.99288492437722 + 0.99200044963108 + 0.99101982154647 + 0.98993140455413 + 0.98871410766638 + 0.98734299957205 + 0.98579030270433 + 0.98402521899811 + 0.98201255604961 + 0.97971388972708 + 0.97708814207662 + 0.97409012426135 + 0.97067007244216 + 0.96677266108028 + 0.96233244649768 + 0.95726229851590 + 0.95146321873126 + 0.94484737314986 + 0.93733556985612 + 0.92885152606432 + 0.91933056028662 + 0.90872187616577 + 0.89699281369573 + 0.88413416200407 + 0.87016554500664 + 0.85513883159696 + 0.83913209687305 + 0.82223163357793 + 0.80455962318941 + 0.78631613672653 + 0.76775274464746 + 0.75842811043708 + 0.74911801412215 + 0.73984810791043 + 0.73063866757356 + 0.72150344270980 + 0.71244883447644 + 0.70347356275627 + 0.69456902081444 + 0.68572033093261 + 0.67690421228205 + 0.66802688990892 + 0.65881795317374 + 0.64914165592133 + 0.63899188996339 + 0.62836809574146 + 0.61729899159401 + 0.60582119935381 + 0.59397723339518 + 0.58181399576980 + 0.56938179964536 + 0.55673203518759 + 0.54388724341295 + 0.53089790715868 + 0.51781510650947 + 0.50468831282021 + 0.49156241062145 + 0.47847443869207 + 0.46543512172786 + 0.45243843365139 + 0.43947776588323 + 0.42653304035587 + 0.41357275896086 + 0.99834959427460 + 0.99835270513668 + 0.99835322238714 + 0.99835382596484 + 0.99835453041037 + 0.99835535276870 + 0.99835631303651 + 0.99835743479258 + 0.99835874628691 + 0.99836028380692 + 0.99836210157048 + 0.99836428076340 + 0.99836691858849 + 0.99837012281178 + 0.99837402041219 + 0.99837876619279 + 0.99838455087975 + 0.99839161060400 + 0.99840024616709 + 0.99841084259292 + 0.99842387760361 + 0.99843996050505 + 0.99845987638082 + 0.99848465056141 + 0.99851565175126 + 0.99855479495396 + 0.99860492731507 + 0.99867023382437 + 0.99875691010917 + 0.99887491848554 + 0.99904257760322 + 0.99930096287532 + 1.00000000000000 + 0.99922214723992 + 0.99881219918980 + 0.99845181094695 + 0.99810843161316 + 0.99776472875502 + 0.99740799637719 + 0.99702736210983 + 0.99661297214683 + 0.99615498143362 + 0.99564317210319 + 0.99506743564663 + 0.99442206885354 + 0.99370564499294 + 0.99290910553290 + 0.99202158289219 + 0.99103838492664 + 0.98994779804701 + 0.98872865321279 + 0.98735595868548 + 0.98580189100808 + 0.98403561638409 + 0.98202191326907 + 0.97972233443343 + 0.97709578363411 + 0.97409705690468 + 0.97067637791399 + 0.96677841055597 + 0.96233770112228 + 0.95726710831177 + 0.95146762454952 + 0.94485141089923 + 0.93733927199202 + 0.92885492162341 + 0.91933367515956 + 0.90872473321781 + 0.89699543292379 + 0.88413656079385 + 0.87016773846072 + 0.85514083302505 + 0.83913391825181 + 0.82223328586062 + 0.80456111709874 + 0.78631748375170 + 0.76775395722507 + 0.75842926051285 + 0.74911910499268 + 0.73984914282592 + 0.73063964970856 + 0.72150437511784 + 0.71244972005834 + 0.70347440422921 + 0.69456982068938 + 0.68572109150173 + 0.67690493559086 + 0.66802757744592 + 0.65881860514867 + 0.64914227201193 + 0.63899246993027 + 0.62836863947029 + 0.61729949919204 + 0.60582167118751 + 0.59397767008128 + 0.58181439816570 + 0.56938216883590 + 0.55673237245324 + 0.54388755013407 + 0.53089818487401 + 0.51781535689616 + 0.50468853767840 + 0.49156261183227 + 0.47847461818242 + 0.46543528140501 + 0.45243857536195 + 0.43947789139468 + 0.42653315132956 + 0.41357285692283 + 0.99818216731686 + 0.99818485674925 + 0.99818530384486 + 0.99818582552454 + 0.99818643434304 + 0.99818714500945 + 0.99818797477928 + 0.99818894398295 + 0.99819007697272 + 0.99819140502468 + 0.99819297487619 + 0.99819485653556 + 0.99819713378692 + 0.99819989944680 + 0.99820326270734 + 0.99820735650515 + 0.99821234428092 + 0.99821842788701 + 0.99822586369433 + 0.99823497865712 + 0.99824617618761 + 0.99825996745381 + 0.99827700561815 + 0.99829813473539 + 0.99832446681556 + 0.99835753445112 + 0.99839957794057 + 0.99845379857159 + 0.99852472626375 + 0.99861919552657 + 0.99874861745731 + 0.99893384484190 + 0.99922214723992 + 1.00000000000000 + 0.99913316295550 + 0.99867628505625 + 0.99827791058507 + 0.99789846528442 + 0.99751672871592 + 0.99711761667953 + 0.99668897909224 + 0.99621962216092 + 0.99569849711240 + 0.99511497832262 + 0.99446307246279 + 0.99374116961184 + 0.99294001184899 + 0.99204858049828 + 0.99106209259631 + 0.98996873145947 + 0.98874722616264 + 0.98737250646123 + 0.98581668951961 + 0.98404889548102 + 0.98203386536754 + 0.97973312236222 + 0.97710554683627 + 0.97410591551869 + 0.97068443612118 + 0.96678575903262 + 0.96234441772005 + 0.95727325663789 + 0.95147325649539 + 0.94485657210282 + 0.93734400378098 + 0.92885926103736 + 0.91933765528897 + 0.90872838335339 + 0.89699877875941 + 0.88413962470072 + 0.87017053991735 + 0.85514338922565 + 0.83913624468831 + 0.82223539668433 + 0.80456302615126 + 0.78631920581258 + 0.76775550822983 + 0.75843073203229 + 0.74912050122212 + 0.73985046791317 + 0.73064090768534 + 0.72150556986021 + 0.71245085524551 + 0.70347548329948 + 0.69457084681891 + 0.68572206758778 + 0.67690586421670 + 0.66802846048103 + 0.65881944283434 + 0.64914306390484 + 0.63899321569555 + 0.62836933892280 + 0.61730015244901 + 0.60582227868079 + 0.59397823257274 + 0.58181491672344 + 0.56938264482132 + 0.55673280748147 + 0.54388794595354 + 0.53089854343663 + 0.51781568034056 + 0.50468882829413 + 0.49156287202056 + 0.47847485040798 + 0.46543548810380 + 0.45243875889440 + 0.43947805402561 + 0.42653329518573 + 0.41357298395846 + 0.99799719762356 + 0.99799951786775 + 0.99799990353598 + 0.99800035352666 + 0.99800087865738 + 0.99800149159967 + 0.99800220722184 + 0.99800304303101 + 0.99800401999892 + 0.99800516504106 + 0.99800651838126 + 0.99800814025363 + 0.99801010275203 + 0.99801248569565 + 0.99801538290627 + 0.99801890845909 + 0.99802320241056 + 0.99802843737093 + 0.99803483206792 + 0.99804266461022 + 0.99805227662281 + 0.99806409865239 + 0.99807867712077 + 0.99809671206732 + 0.99811911593106 + 0.99814713121778 + 0.99818255050306 + 0.99822787959744 + 0.99828654230596 + 0.99836346948599 + 0.99846640162693 + 0.99860809183951 + 0.99881219918980 + 0.99913316295550 + 1.00000000000000 + 0.99903280715337 + 0.99852452532853 + 0.99808408513412 + 0.99766338432049 + 0.99723717663096 + 0.99678850388062 + 0.99630362334274 + 0.99577003121070 + 0.99517624242803 + 0.99451578948175 + 0.99378677186048 + 0.99297964401487 + 0.99208317589137 + 0.99109245829156 + 0.98999553636688 + 0.98877100495204 + 0.98739369103662 + 0.98583563441947 + 0.98406589555302 + 0.98204916712096 + 0.97974693424372 + 0.97711804727618 + 0.97411725819867 + 0.97069475427911 + 0.96679516858259 + 0.96235301812331 + 0.95728112904921 + 0.95148046709778 + 0.94486317912076 + 0.93735006001656 + 0.92886481389439 + 0.91934274721824 + 0.90873305202105 + 0.89700305727251 + 0.88414354194173 + 0.87017412110488 + 0.85514665663874 + 0.83913921841921 + 0.82223809508194 + 0.80456546712862 + 0.78632140842033 + 0.76775749294979 + 0.75843261554984 + 0.74912228890090 + 0.73985216503588 + 0.73064251939153 + 0.72150710108078 + 0.71245231064539 + 0.70347686724407 + 0.69457216332859 + 0.68572332033148 + 0.67690705646093 + 0.66802959458828 + 0.65882051907209 + 0.64914408167137 + 0.63899417452835 + 0.62837023855413 + 0.61730099298588 + 0.60582306064511 + 0.59397895690071 + 0.58181558475255 + 0.56938325826409 + 0.55673336838073 + 0.54388845652119 + 0.53089900615593 + 0.51781609793249 + 0.50468920368017 + 0.49156320826968 + 0.47847515066690 + 0.46543575548736 + 0.45243899642345 + 0.43947826459842 + 0.42653348152340 + 0.41357314856774 + 0.99779219314151 + 0.99779419320211 + 0.99779452562507 + 0.99779491348461 + 0.99779536609579 + 0.99779589437463 + 0.99779651112925 + 0.99779723143438 + 0.99779807334663 + 0.99779906002962 + 0.99780022607142 + 0.99780162325486 + 0.99780331355755 + 0.99780536559686 + 0.99780785998732 + 0.99781089466622 + 0.99781458973546 + 0.99781909299095 + 0.99782459138390 + 0.99783132206765 + 0.99783957533646 + 0.99784971552053 + 0.99786220248312 + 0.99787762134132 + 0.99789672823938 + 0.99792054308944 + 0.99795052252053 + 0.99798866798075 + 0.99803763962531 + 0.99810113345345 + 0.99818469769706 + 0.99829685716134 + 0.99845181094695 + 0.99867628505625 + 0.99903280715337 + 1.00000000000000 + 0.99891975683229 + 0.99835503552788 + 0.99786716434343 + 0.99739858326632 + 0.99692050786065 + 0.99641379752836 + 0.99586317568172 + 0.99525563259587 + 0.99458388440870 + 0.99384554879562 + 0.99303065028968 + 0.99212765455719 + 0.99113147212414 + 0.99002995971412 + 0.98880153313465 + 0.98742088352333 + 0.98585994909486 + 0.98408771233615 + 0.98206880314706 + 0.97976465740938 + 0.97713408676354 + 0.97413181131657 + 0.97070799203132 + 0.96680723967295 + 0.96236405006088 + 0.95729122578830 + 0.95148971333414 + 0.94487164943249 + 0.93735782211850 + 0.92887192868548 + 0.91934926933915 + 0.90873903006957 + 0.89700853405944 + 0.88414855490048 + 0.87017870294940 + 0.85515083635922 + 0.83914302215450 + 0.82224154670084 + 0.80456858986920 + 0.78632422691422 + 0.76776003356491 + 0.75843502716032 + 0.74912457837673 + 0.73985433913190 + 0.73064458466230 + 0.72150906380428 + 0.71245417676005 + 0.70347864228906 + 0.69457385241635 + 0.68572492810584 + 0.67690858706166 + 0.66803105099836 + 0.65882190159541 + 0.64914538949846 + 0.63899540702884 + 0.62837139533993 + 0.61730207416088 + 0.60582406683615 + 0.59397988926352 + 0.58181644496715 + 0.56938404848497 + 0.55673409119190 + 0.54388911473491 + 0.53089960292775 + 0.51781663673334 + 0.50468968823655 + 0.49156364250064 + 0.47847553859665 + 0.46543610110197 + 0.45243930358337 + 0.43947853701274 + 0.42653372267977 + 0.41357336167357 + 0.99756407365774 + 0.99756579811512 + 0.99756608472551 + 0.99756641912725 + 0.99756680935712 + 0.99756726481796 + 0.99756779655624 + 0.99756841755956 + 0.99756914339136 + 0.99756999400468 + 0.99757099914432 + 0.99757220332343 + 0.99757365982948 + 0.99757542767712 + 0.99757757618653 + 0.99758018953291 + 0.99758337086075 + 0.99758724695748 + 0.99759197798654 + 0.99759776677850 + 0.99760486097280 + 0.99761357035291 + 0.99762428432552 + 0.99763749571092 + 0.99765383717912 + 0.99767415584732 + 0.99769965227907 + 0.99773195441094 + 0.99777317994783 + 0.99782619070740 + 0.99789514118523 + 0.99798609480973 + 0.99810843161316 + 0.99827791058507 + 0.99852452532853 + 0.99891975683229 + 1.00000000000000 + 0.99879253200110 + 0.99816515470337 + 0.99762298308448 + 0.99709885674940 + 0.99656012055112 + 0.99598556224673 + 0.99535922780845 + 0.99467233581285 + 0.99392166315607 + 0.99309656356824 + 0.99218504909253 + 0.99118176451594 + 0.99007430387724 + 0.98884084059800 + 0.98745588399490 + 0.98589123741650 + 0.98411578064760 + 0.98209406140172 + 0.97978745142862 + 0.97715471213471 + 0.97415052236477 + 0.97072500906786 + 0.96682275417609 + 0.96237822610335 + 0.95730419700492 + 0.95150158856546 + 0.94488252456398 + 0.93736778431374 + 0.92888105647343 + 0.91935763330859 + 0.90874669313492 + 0.89701555176093 + 0.88415497590225 + 0.87018456988622 + 0.85515618703691 + 0.83914789069851 + 0.82224596425024 + 0.80457258666426 + 0.78632783487275 + 0.76776328670316 + 0.75843811568042 + 0.74912751108291 + 0.73985712466931 + 0.73064723141138 + 0.72151157977888 + 0.71245656952556 + 0.70348091889626 + 0.69457601935916 + 0.68572699128386 + 0.67691055173031 + 0.66803292093510 + 0.65882367714740 + 0.64914706958891 + 0.63899699080101 + 0.62837288225790 + 0.61730346430794 + 0.60582536097212 + 0.59398108882999 + 0.58181755206743 + 0.56938506584315 + 0.55673502208658 + 0.54388996273148 + 0.53090037205095 + 0.51781733140589 + 0.50469031322183 + 0.49156420280529 + 0.47847603936567 + 0.46543654743273 + 0.45243970041444 + 0.43947888909276 + 0.42653403447075 + 0.41357363728559 + 0.99730909115191 + 0.99731057956768 + 0.99731082695152 + 0.99731111558820 + 0.99731145241230 + 0.99731184554835 + 0.99731230452034 + 0.99731284055402 + 0.99731346707593 + 0.99731420129167 + 0.99731506882046 + 0.99731610794430 + 0.99731736451110 + 0.99731888933213 + 0.99732074209814 + 0.99732299526845 + 0.99732573759057 + 0.99732907806552 + 0.99733315428094 + 0.99733814025397 + 0.99734424804822 + 0.99735174233078 + 0.99736095476752 + 0.99737230343808 + 0.99738632237998 + 0.99740372270807 + 0.99742550646455 + 0.99745301900192 + 0.99748798210628 + 0.99753267422015 + 0.99759032181930 + 0.99766545769938 + 0.99776472875502 + 0.99789846528442 + 0.99808408513412 + 0.99835503552788 + 0.99879253200110 + 1.00000000000000 + 0.99864894762945 + 0.99795130855667 + 0.99734686181486 + 0.99675798148218 + 0.99614834810758 + 0.99549561620654 + 0.99478802207803 + 0.99402078097476 + 0.99318214309493 + 0.99225941488675 + 0.99124683447489 + 0.99013161963940 + 0.98889160918657 + 0.98750106522515 + 0.98593160969315 + 0.98415198546705 + 0.98212663168057 + 0.97981683584391 + 0.97718129367840 + 0.97417463027895 + 0.97074692834254 + 0.96684273233447 + 0.96239647507701 + 0.95732088928590 + 0.95151686456637 + 0.94489650806560 + 0.93738058795546 + 0.92889278188045 + 0.91936837200690 + 0.90875652686591 + 0.89702455283033 + 0.88416320780418 + 0.87019208834261 + 0.85516304154056 + 0.83915412592753 + 0.82225162095904 + 0.80457770431369 + 0.78633245492234 + 0.76776745315149 + 0.75844207181387 + 0.74913126822089 + 0.73986069390723 + 0.73065062347672 + 0.72151480491365 + 0.71245963738997 + 0.70348383848030 + 0.69457879893088 + 0.68572963835411 + 0.67691307298278 + 0.66803532115699 + 0.65882595673987 + 0.64914922712151 + 0.63899902513569 + 0.62837479266209 + 0.61730525084813 + 0.60582702456633 + 0.59398263128040 + 0.58181897602178 + 0.56938637475050 + 0.55673622010835 + 0.54389105440801 + 0.53090136250670 + 0.51781822629091 + 0.50469111861834 + 0.49156492511779 + 0.47847668517168 + 0.46543712325224 + 0.45244021256777 + 0.43947934365232 + 0.42653443714771 + 0.41357399334116 + 0.99702254756011 + 0.99702383426275 + 0.99702404813129 + 0.99702429766876 + 0.99702458886912 + 0.99702492875986 + 0.99702532558136 + 0.99702578903846 + 0.99702633074413 + 0.99702696557119 + 0.99702771560220 + 0.99702861380229 + 0.99702969966422 + 0.99703101699535 + 0.99703261727245 + 0.99703456297244 + 0.99703693060937 + 0.99703981411146 + 0.99704333196384 + 0.99704763390251 + 0.99705290217564 + 0.99705936386638 + 0.99706730291231 + 0.99707707620752 + 0.99708913796516 + 0.99710409054036 + 0.99712277914809 + 0.99714633035966 + 0.99717616868934 + 0.99721415012125 + 0.99726285581023 + 0.99732581247888 + 0.99740799637719 + 0.99751672871592 + 0.99766338432049 + 0.99786716434343 + 0.99816515470337 + 0.99864894762945 + 1.00000000000000 + 0.99848645010586 + 0.99770988163040 + 0.99703336408847 + 0.99636886688940 + 0.99567748326413 + 0.99494078763182 + 0.99415084763582 + 0.99329397140309 + 0.99235630742218 + 0.99133144300339 + 0.99020603809080 + 0.98895745767928 + 0.98755962062177 + 0.98598390046142 + 0.98419885479366 + 0.98216877739965 + 0.97985484390209 + 0.97721566330459 + 0.97420579003976 + 0.97077524881574 + 0.96686853505564 + 0.96242003510774 + 0.95734243030769 + 0.95153656862010 + 0.94491453567470 + 0.93739708535909 + 0.92890788117033 + 0.91938219237566 + 0.90876917495950 + 0.89703612319190 + 0.88417378360414 + 0.87020174272185 + 0.85517183954101 + 0.83916212630303 + 0.82225887723420 + 0.80458426817837 + 0.78633838043371 + 0.76777279739380 + 0.75844714674451 + 0.74913608842933 + 0.73986527366766 + 0.73065497657160 + 0.72151894447712 + 0.71246357578774 + 0.70348758720652 + 0.69458236854651 + 0.68573303844404 + 0.67691631207408 + 0.66803840534245 + 0.65882888648695 + 0.64915200054665 + 0.63900164073070 + 0.62837724943967 + 0.61730754883872 + 0.60582916490561 + 0.59398461622573 + 0.58182080892625 + 0.56938805998982 + 0.55673776298185 + 0.54389246070561 + 0.53090263877750 + 0.51781937976137 + 0.50469215707523 + 0.49156585675689 + 0.47847751842046 + 0.46543786646279 + 0.45244087383428 + 0.43947993075155 + 0.42653495739757 + 0.41357445348332 + 0.99669870384660 + 0.99669981813977 + 0.99670000336438 + 0.99670021948404 + 0.99670047169326 + 0.99670076608049 + 0.99670110978906 + 0.99670151122959 + 0.99670198046262 + 0.99670253036558 + 0.99670318000742 + 0.99670395780737 + 0.99670489782191 + 0.99670603787609 + 0.99670742242637 + 0.99670910543790 + 0.99671115298197 + 0.99671364616003 + 0.99671668723383 + 0.99672040536284 + 0.99672495764563 + 0.99673053958536 + 0.99673739528900 + 0.99674583095376 + 0.99675623526591 + 0.99676912216005 + 0.99678521054213 + 0.99680545364751 + 0.99683104635514 + 0.99686352799245 + 0.99690501176477 + 0.99695832788805 + 0.99702736210983 + 0.99711761667953 + 0.99723717663096 + 0.99739858326632 + 0.99762298308448 + 0.99795130855667 + 0.99848645010586 + 1.00000000000000 + 0.99830301865855 + 0.99743668614879 + 0.99667628744972 + 0.99592451609368 + 0.99514519420556 + 0.99432327048559 + 0.99344131604772 + 0.99248344445469 + 0.99144214287277 + 0.99030320765533 + 0.98904331043123 + 0.98763588043560 + 0.98605194316636 + 0.98425980053905 + 0.98222354846881 + 0.97990421179813 + 0.97726028355012 + 0.97424622423584 + 0.97081198181236 + 0.96690198698371 + 0.96245056494446 + 0.95737032970595 + 0.95156207484854 + 0.94493785803579 + 0.93741841465248 + 0.92892739000271 + 0.91940003671127 + 0.90878549462225 + 0.89705104236334 + 0.88418741176247 + 0.87021417630764 + 0.85518316443771 + 0.83917242010653 + 0.82226821058014 + 0.80459270907351 + 0.78634599964927 + 0.76777966929214 + 0.75845367267407 + 0.74914228727461 + 0.73987116386457 + 0.73066057588434 + 0.72152426981673 + 0.71246864303808 + 0.70349241112691 + 0.69458696267476 + 0.68573741506675 + 0.67692048210077 + 0.66804237656545 + 0.65883265945060 + 0.64915557278322 + 0.63900501025269 + 0.62838041492504 + 0.61731051028274 + 0.60583192371584 + 0.59398717525274 + 0.58182317242557 + 0.56939023354566 + 0.55673975336921 + 0.54389427533197 + 0.53090428603868 + 0.51782086892468 + 0.50469349813688 + 0.49156706023965 + 0.47847859514683 + 0.46543882714865 + 0.45244172887175 + 0.43948069012381 + 0.42653563050198 + 0.41357504897442 + 0.99633110583612 + 0.99633207254021 + 0.99633223324572 + 0.99633242075565 + 0.99633263958667 + 0.99633289502196 + 0.99633319326237 + 0.99633354160967 + 0.99633394880132 + 0.99633442600404 + 0.99633498970663 + 0.99633566443960 + 0.99633647961038 + 0.99633746791687 + 0.99633866780209 + 0.99634012594528 + 0.99634189949126 + 0.99634405857226 + 0.99634669159866 + 0.99634991020748 + 0.99635385011139 + 0.99635868009346 + 0.99636461069041 + 0.99637190561718 + 0.99638089904838 + 0.99639203189081 + 0.99640591951920 + 0.99642337487504 + 0.99644541077558 + 0.99647332152632 + 0.99650886775362 + 0.99655437426566 + 0.99661297214683 + 0.99668897909224 + 0.99678850388062 + 0.99692050786065 + 0.99709885674940 + 0.99734686181486 + 0.99770988163040 + 0.99830301865855 + 1.00000000000000 + 0.99809563122295 + 0.99712638328603 + 0.99626930491233 + 0.99542349194780 + 0.99455467337806 + 0.99363728240935 + 0.99265152152329 + 0.99158788881897 + 0.99043077035812 + 0.98915578099074 + 0.98773562801759 + 0.98614083557167 + 0.98433934422471 + 0.98229497515827 + 0.97996854647410 + 0.97731839369732 + 0.97429885088893 + 0.97085976327648 + 0.96694547534135 + 0.96249023118658 + 0.95740655609512 + 0.95159517221549 + 0.94496810060619 + 0.93744605258803 + 0.92895264980582 + 0.91942312337427 + 0.90880659221946 + 0.89707031468186 + 0.88420500346658 + 0.87023021507538 + 0.85519776410413 + 0.83918568354204 + 0.82228023132954 + 0.80460357692166 + 0.78635580755335 + 0.76778851442113 + 0.75846207247513 + 0.74915026625175 + 0.73987874589734 + 0.73066778394220 + 0.72153112571408 + 0.71247516725905 + 0.70349862265743 + 0.69459287892658 + 0.68574305181657 + 0.67692585336270 + 0.66804749232748 + 0.65883752037534 + 0.64916017564925 + 0.63900935245609 + 0.62838449473254 + 0.61731432763731 + 0.60583548038602 + 0.59399047486387 + 0.58182622041235 + 0.56939303704915 + 0.55674232107051 + 0.54389661673829 + 0.53090641193005 + 0.51782279121135 + 0.50469522966254 + 0.49156861453364 + 0.47847998611200 + 0.46544006856239 + 0.45244283407983 + 0.43948167195283 + 0.42653650101474 + 0.41357581929170 + 0.99591227591279 + 0.99591311585158 + 0.99591325549186 + 0.99591341843139 + 0.99591360858737 + 0.99591383055977 + 0.99591408973995 + 0.99591439247467 + 0.99591474636316 + 0.99591516109810 + 0.99591565096337 + 0.99591623715145 + 0.99591694507525 + 0.99591780302713 + 0.99591884428668 + 0.99592010926708 + 0.99592164743281 + 0.99592351950825 + 0.99592580200989 + 0.99592859154838 + 0.99593200554348 + 0.99593618996498 + 0.99594132678097 + 0.99594764371653 + 0.99595542900167 + 0.99596506234485 + 0.99597707280554 + 0.99599215756402 + 0.99601118152742 + 0.99603524382279 + 0.99606583001109 + 0.99610488225061 + 0.99615498143362 + 0.99621962216092 + 0.99630362334274 + 0.99641379752836 + 0.99656012055112 + 0.99675798148218 + 0.99703336408847 + 0.99743668614879 + 0.99809563122295 + 1.00000000000000 + 0.99786078679671 + 0.99677408337602 + 0.99581263859781 + 0.99487066014882 + 0.99390116784632 + 0.99287583951893 + 0.99178124541304 + 0.99059930515334 + 0.98930393614070 + 0.98786673540222 + 0.98625747896675 + 0.98444358136905 + 0.98238847258079 + 0.98005268100449 + 0.97739432422804 + 0.97436756325509 + 0.97092210390036 + 0.96700217441226 + 0.96254191037283 + 0.95745371927433 + 0.95163822882434 + 0.94500741184504 + 0.93748194804940 + 0.92898542816350 + 0.91945305524942 + 0.90883392099886 + 0.89709525729899 + 0.88422775186800 + 0.87025093894908 + 0.85521661492409 + 0.83920279819704 + 0.82229573417025 + 0.80461758688582 + 0.78636844714163 + 0.76779991099970 + 0.75847289465040 + 0.74916054591414 + 0.73988851405966 + 0.73067707038337 + 0.72153995867810 + 0.71248357320155 + 0.70350662609486 + 0.69460050230390 + 0.68575031546569 + 0.67693277532739 + 0.66805408546158 + 0.65884378550388 + 0.64916610859045 + 0.63901494983416 + 0.62838975428962 + 0.61731924928046 + 0.60584006636667 + 0.59399472982024 + 0.58183015131666 + 0.56939665306918 + 0.55674563336611 + 0.54389963753664 + 0.53090915510056 + 0.51782527208542 + 0.50469746477586 + 0.49157062129227 + 0.47848178240650 + 0.46544167210887 + 0.45244426203618 + 0.43948294080577 + 0.42653762626622 + 0.41357681523441 + 0.99543367030336 + 0.99543440088989 + 0.99543452235669 + 0.99543466409261 + 0.99543482951155 + 0.99543502261095 + 0.99543524808277 + 0.99543551145200 + 0.99543581933929 + 0.99543618015878 + 0.99543660629749 + 0.99543711606883 + 0.99543773145609 + 0.99543847694663 + 0.99543938136620 + 0.99544047971435 + 0.99544181483211 + 0.99544343931650 + 0.99544541942652 + 0.99544783880674 + 0.99545079912440 + 0.99545442672985 + 0.99545887906856 + 0.99546435307819 + 0.99547109780666 + 0.99547944100694 + 0.99548983877062 + 0.99550289106419 + 0.99551934013832 + 0.99554012560607 + 0.99556651179769 + 0.99560014023338 + 0.99564317210319 + 0.99569849711240 + 0.99577003121070 + 0.99586317568172 + 0.99598556224673 + 0.99614834810758 + 0.99636886688940 + 0.99667628744972 + 0.99712638328603 + 0.99786078679671 + 1.00000000000000 + 0.99759610268610 + 0.99638278420916 + 0.99531369960093 + 0.99426272095053 + 0.99317896499083 + 0.99204022108192 + 0.99082368276086 + 0.98950034685959 + 0.98804000791490 + 0.98641127513585 + 0.98458076807168 + 0.98251134182667 + 0.98016310771918 + 0.97749387451073 + 0.97445756153094 + 0.97100368212575 + 0.96707630557766 + 0.96260942056749 + 0.95751527685422 + 0.95169437638933 + 0.94505862781752 + 0.93752866897285 + 0.92902804981723 + 0.91949193656184 + 0.90886938518412 + 0.89712759288217 + 0.88425721456305 + 0.87027775518999 + 0.85524098701869 + 0.83922490899232 + 0.82231574952408 + 0.80463566491324 + 0.78638474978850 + 0.76781460569393 + 0.75848684706587 + 0.74917379766642 + 0.73990110553898 + 0.73068904029921 + 0.72155134367754 + 0.71249440757702 + 0.70351694156893 + 0.69461032790325 + 0.68575967745721 + 0.67694169701839 + 0.66806258345026 + 0.65885186085166 + 0.64917375590352 + 0.63902216477403 + 0.62839653395409 + 0.61732559356646 + 0.60584597818236 + 0.59400021515587 + 0.58183521914825 + 0.56940131521794 + 0.55674990421869 + 0.54390353285019 + 0.53091269275966 + 0.51782847185245 + 0.50470034795773 + 0.49157321031550 + 0.47848410030359 + 0.46544374167898 + 0.45244610534997 + 0.43948457905665 + 0.42653907938526 + 0.41357810158929 + 0.99488633261764 + 0.99488696855002 + 0.99488707428721 + 0.99488719766899 + 0.99488734166778 + 0.99488750976523 + 0.99488770605249 + 0.99488793533698 + 0.99488820337943 + 0.99488851750699 + 0.99488888845056 + 0.99488933205755 + 0.99488986734225 + 0.99489051551066 + 0.99489130152968 + 0.99489225571845 + 0.99489341519326 + 0.99489482549617 + 0.99489654402176 + 0.99489864321637 + 0.99490121110291 + 0.99490435708175 + 0.99490821744520 + 0.99491296261834 + 0.99491880801155 + 0.99492603686602 + 0.99493504295654 + 0.99494634367146 + 0.99496057796286 + 0.99497855255638 + 0.99500134966708 + 0.99503036764359 + 0.99506743564663 + 0.99511497832262 + 0.99517624242803 + 0.99525563259587 + 0.99535922780845 + 0.99549561620654 + 0.99567748326413 + 0.99592451609368 + 0.99626930491233 + 0.99677408337602 + 0.99759610268610 + 1.00000000000000 + 0.99730880554415 + 0.99596321236345 + 0.99477055593815 + 0.99359511560193 + 0.99239089059618 + 0.99112478520490 + 0.98976228974500 + 0.98827006304668 + 0.98661479140625 + 0.98476183721685 + 0.98267317818566 + 0.98030830534928 + 0.97762457743724 + 0.97457556819585 + 0.97111051986538 + 0.96717328070677 + 0.96269763804017 + 0.95759562856320 + 0.95176758550026 + 0.94512533131289 + 0.93758944769259 + 0.92908343033281 + 0.91954239666555 + 0.90891535550924 + 0.89716945830268 + 0.88429531669672 + 0.87031239695789 + 0.85527243929339 + 0.83925341649029 + 0.82234153391340 + 0.80465893669032 + 0.78640572326685 + 0.76783350112139 + 0.75850478431667 + 0.74919083105995 + 0.73991728769022 + 0.73070442153679 + 0.72156597157047 + 0.71250832657259 + 0.70353019272955 + 0.69462294876602 + 0.68577170197912 + 0.67695315530997 + 0.66807349696258 + 0.65886223102751 + 0.64918357588284 + 0.63903142905641 + 0.62840523890205 + 0.61733373913237 + 0.60585356819931 + 0.59400725738669 + 0.58184172520746 + 0.56940730035318 + 0.55675538696822 + 0.54390853351970 + 0.53091723437336 + 0.51783257983647 + 0.50470404971323 + 0.49157653465768 + 0.47848707681208 + 0.46544639960596 + 0.45244847299774 + 0.43948668358907 + 0.42654094633093 + 0.41357975447309 + 0.99426522156938 + 0.99426577577793 + 0.99426586792788 + 0.99426597545731 + 0.99426610095669 + 0.99426624746107 + 0.99426641853701 + 0.99426661837245 + 0.99426685199094 + 0.99426712576978 + 0.99426744903080 + 0.99426783550027 + 0.99426830164676 + 0.99426886585431 + 0.99426954977969 + 0.99427037971498 + 0.99427138783774 + 0.99427261364418 + 0.99427410689069 + 0.99427593036803 + 0.99427816038585 + 0.99428089177579 + 0.99428424264812 + 0.99428836067445 + 0.99429343243563 + 0.99429970314490 + 0.99430751341515 + 0.99431731047318 + 0.99432964600777 + 0.99434521534599 + 0.99436494934157 + 0.99439004680180 + 0.99442206885354 + 0.99446307246279 + 0.99451578948175 + 0.99458388440870 + 0.99467233581285 + 0.99478802207803 + 0.99494078763182 + 0.99514519420556 + 0.99542349194780 + 0.99581263859781 + 0.99638278420916 + 0.99730880554415 + 1.00000000000000 + 0.99700773775672 + 0.99550933161197 + 0.99417537801605 + 0.99286877427924 + 0.99152936962125 + 0.99011094107397 + 0.98857421665156 + 0.98688251134467 + 0.98499910104876 + 0.98288457182066 + 0.98049746273217 + 0.97779445944610 + 0.97472863111811 + 0.97124883185256 + 0.96729859886408 + 0.96281144143158 + 0.95769910816072 + 0.95186170584913 + 0.94521094045986 + 0.93766731752601 + 0.92915425993570 + 0.91960682007057 + 0.90897394429264 + 0.89722272369711 + 0.88434371295359 + 0.87035632727789 + 0.85531226432310 + 0.83928946172199 + 0.82237409345951 + 0.80468828841599 + 0.78643214790954 + 0.76785728502027 + 0.75852735246172 + 0.74921225343316 + 0.73993763191233 + 0.73072375217351 + 0.72158434953391 + 0.71252580869049 + 0.70354683145011 + 0.69463879198495 + 0.68578679299113 + 0.67696753249910 + 0.66808718773655 + 0.65887523752117 + 0.64919588976862 + 0.63904304373579 + 0.62841615012309 + 0.61734394716727 + 0.60586307816117 + 0.59401607932638 + 0.58184987398240 + 0.56941479535629 + 0.55676225170544 + 0.54391479368437 + 0.53092291904312 + 0.51783772107769 + 0.50470868203411 + 0.49158069429974 + 0.47849080094049 + 0.46544972494394 + 0.45245143504026 + 0.43948931637820 + 0.42654328184197 + 0.41358182215379 + 0.99356936367927 + 0.99356984767358 + 0.99356992814923 + 0.99357002205716 + 0.99357013165741 + 0.99357025960455 + 0.99357040900694 + 0.99357058352895 + 0.99357078755469 + 0.99357102664835 + 0.99357130892191 + 0.99357164630784 + 0.99357205312000 + 0.99357254534293 + 0.99357314180746 + 0.99357386537615 + 0.99357474402919 + 0.99357581210829 + 0.99357711286443 + 0.99357870088102 + 0.99358064248618 + 0.99358302010108 + 0.99358593638492 + 0.99358951965567 + 0.99359393201293 + 0.99359938640080 + 0.99360617849911 + 0.99361469634445 + 0.99362541826009 + 0.99363894642178 + 0.99365608589154 + 0.99367787110835 + 0.99370564499294 + 0.99374116961184 + 0.99378677186048 + 0.99384554879562 + 0.99392166315607 + 0.99402078097476 + 0.99415084763582 + 0.99432327048559 + 0.99455467337806 + 0.99487066014882 + 0.99531369960093 + 0.99596321236345 + 0.99700773775672 + 1.00000000000000 + 0.99667715668704 + 0.99500668879989 + 0.99352521540069 + 0.99207234817368 + 0.99057199544175 + 0.98897233828482 + 0.98723031521655 + 0.98530554344708 + 0.98315630808749 + 0.98073963946123 + 0.97801119087818 + 0.97492328055489 + 0.97142419917670 + 0.96745704213899 + 0.96295493347543 + 0.95782923380028 + 0.95197974763880 + 0.94531802275134 + 0.93776446023428 + 0.92924238457462 + 0.91968676107329 + 0.90904645332195 + 0.89728847307187 + 0.88440330041118 + 0.87041028362570 + 0.85536106411922 + 0.83933353234048 + 0.82241381968563 + 0.80472403117449 + 0.78646426808940 + 0.76788614706092 + 0.75855471779808 + 0.74923821011683 + 0.73996226481402 + 0.73074714213359 + 0.72160657268584 + 0.71254693594984 + 0.70356692818348 + 0.69465791782680 + 0.68580500180465 + 0.67698487202240 + 0.66810369221450 + 0.65889091036865 + 0.64921072167184 + 0.63905702748396 + 0.62842928134480 + 0.61735622694331 + 0.60587451341843 + 0.59402668290682 + 0.58185966447664 + 0.56942379677790 + 0.55677049296612 + 0.54392230625724 + 0.53092973842433 + 0.51784388629537 + 0.50471423498959 + 0.49158567892567 + 0.47849526221061 + 0.46545370724616 + 0.45245498123462 + 0.43949246752492 + 0.42654607647043 + 0.41358429571978 + 0.99279031134476 + 0.99279073480331 + 0.99279080521374 + 0.99279088737413 + 0.99279098326322 + 0.99279109520556 + 0.99279122591541 + 0.99279137860482 + 0.99279155710245 + 0.99279176627333 + 0.99279201320168 + 0.99279230828955 + 0.99279266402075 + 0.99279309434333 + 0.99279361567045 + 0.99279424794634 + 0.99279501556818 + 0.99279594848616 + 0.99279708440909 + 0.99279847092059 + 0.99280016585418 + 0.99280224105823 + 0.99280478601605 + 0.99280791257777 + 0.99281176200562 + 0.99281651983701 + 0.99282244363611 + 0.99282987135261 + 0.99283921936669 + 0.99285101144901 + 0.99286594725832 + 0.99288492437722 + 0.99290910553290 + 0.99294001184899 + 0.99297964401487 + 0.99303065028968 + 0.99309656356824 + 0.99318214309493 + 0.99329397140309 + 0.99344131604772 + 0.99363728240935 + 0.99390116784632 + 0.99426272095053 + 0.99477055593815 + 0.99550933161197 + 0.99667715668704 + 1.00000000000000 + 0.99631222590257 + 0.99446183971615 + 0.99281543198708 + 0.99118827450380 + 0.98949645947604 + 0.98768332041239 + 0.98570148951706 + 0.98350519368466 + 0.98104894653054 + 0.97828675051372 + 0.97516976723375 + 0.97164544604794 + 0.96765624039713 + 0.96313473138297 + 0.95799175141971 + 0.95212669805633 + 0.94545090166372 + 0.93788461815912 + 0.92935103762477 + 0.91978500774241 + 0.90913528167614 + 0.89736876641960 + 0.88447584414003 + 0.87047577524322 + 0.85542012660215 + 0.83938672531234 + 0.82246164491828 + 0.80476695568048 + 0.78650275353237 + 0.76792065456907 + 0.75858740271430 + 0.74926918246335 + 0.73999163032876 + 0.73077500129185 + 0.72163301992089 + 0.71257205908209 + 0.70359080805281 + 0.69468062810281 + 0.68582660896951 + 0.67700543497570 + 0.66812325346044 + 0.65890947530543 + 0.64922828041598 + 0.63907357267268 + 0.62844480898355 + 0.61737073951706 + 0.60588802031787 + 0.59403920049242 + 0.58187121586286 + 0.56943441141790 + 0.55678020601061 + 0.54393115579930 + 0.53093776721332 + 0.51785114116071 + 0.50472076606025 + 0.49159153864299 + 0.47850050416289 + 0.46545838423896 + 0.45245914419556 + 0.43949616518221 + 0.42654935449735 + 0.41358719610476 + 0.99191768869575 + 0.99191805982198 + 0.99191812152857 + 0.99191819353238 + 0.99191827756727 + 0.99191837566745 + 0.99191849021778 + 0.99191862402351 + 0.99191878044094 + 0.99191896373721 + 0.99191918010608 + 0.99191943865526 + 0.99191975031097 + 0.99192012726989 + 0.99192058389767 + 0.99192113764279 + 0.99192180984879 + 0.99192262671220 + 0.99192362121349 + 0.99192483498061 + 0.99192631858929 + 0.99192813488126 + 0.99193036210727 + 0.99193309807603 + 0.99193646629671 + 0.99194062898648 + 0.99194581134627 + 0.99195230884739 + 0.99196048539248 + 0.99197079848457 + 0.99198385897635 + 0.99200044963108 + 0.99202158289219 + 0.99204858049828 + 0.99208317589137 + 0.99212765455719 + 0.99218504909253 + 0.99225941488675 + 0.99235630742218 + 0.99248344445469 + 0.99265152152329 + 0.99287583951893 + 0.99317896499083 + 0.99359511560193 + 0.99417537801605 + 0.99500668879989 + 0.99631222590257 + 1.00000000000000 + 0.99592661216121 + 0.99387282302507 + 0.99202925558279 + 0.99019469965401 + 0.98827740706868 + 0.98621496821293 + 0.98395381117905 + 0.98144396885429 + 0.97863666399338 + 0.97548120028665 + 0.97192372664192 + 0.96790573710791 + 0.96335903064683 + 0.95819370962369 + 0.95230861682600 + 0.94561477952294 + 0.93803224891775 + 0.92948402938836 + 0.91990480807323 + 0.90924318974290 + 0.89746594229844 + 0.88456331885388 + 0.87055446408496 + 0.85549084594599 + 0.83945020634021 + 0.82251854032255 + 0.80481786797167 + 0.78654827115628 + 0.76796135839744 + 0.75862590773240 + 0.74930562538622 + 0.74002614214134 + 0.73080770614270 + 0.72166403424899 + 0.71260149098010 + 0.70361875686837 + 0.69470718426755 + 0.68585185401582 + 0.67702944108775 + 0.66814607310505 + 0.65893111682813 + 0.64924873404772 + 0.63909283159270 + 0.62846287031591 + 0.61738760794324 + 0.60590370855076 + 0.59405372931193 + 0.58188461381319 + 0.56944671432348 + 0.55679145618732 + 0.54394139883014 + 0.53094705395542 + 0.51785952707003 + 0.50472831029801 + 0.49159830292756 + 0.47850655141999 + 0.46546377637691 + 0.45246394082631 + 0.43950042326144 + 0.42655312734007 + 0.41359053265638 + 0.99094710570682 + 0.99094743175071 + 0.99094748595940 + 0.99094754921357 + 0.99094762303419 + 0.99094770921077 + 0.99094780983025 + 0.99094792736504 + 0.99094806476009 + 0.99094822575528 + 0.99094841579924 + 0.99094864290383 + 0.99094891666874 + 0.99094924781744 + 0.99094964897812 + 0.99095013547748 + 0.99095072607371 + 0.99095144377937 + 0.99095231758241 + 0.99095338405800 + 0.99095468765017 + 0.99095628357109 + 0.99095824057177 + 0.99096064457753 + 0.99096360408009 + 0.99096726160539 + 0.99097181507655 + 0.99097752420725 + 0.99098470874596 + 0.99099377049110 + 0.99100524582961 + 0.99101982154647 + 0.99103838492664 + 0.99106209259631 + 0.99109245829156 + 0.99113147212414 + 0.99118176451594 + 0.99124683447489 + 0.99133144300339 + 0.99144214287277 + 0.99158788881897 + 0.99178124541304 + 0.99204022108192 + 0.99239089059618 + 0.99286877427924 + 0.99352521540069 + 0.99446183971615 + 0.99592661216121 + 1.00000000000000 + 0.99550488797732 + 0.99321090149220 + 0.99113500141154 + 0.98905788544090 + 0.98687853298753 + 0.98452666480222 + 0.98194372033817 + 0.97907598302024 + 0.97586964820843 + 0.97226879077665 + 0.96821343639374 + 0.96363423803457 + 0.95844027971378 + 0.95252964328402 + 0.94581292901702 + 0.93820989615688 + 0.92964329043896 + 0.92004757874318 + 0.90937116585775 + 0.89758063507205 + 0.88466606987357 + 0.87064646308485 + 0.85557315191452 + 0.83952376428083 + 0.82258418945639 + 0.80487637581252 + 0.78660037700539 + 0.76800778221754 + 0.75866974633448 + 0.74934704559882 + 0.74006530322917 + 0.73084475863142 + 0.72169911896120 + 0.71263473838837 + 0.70365028668856 + 0.69473710531359 + 0.68588026425684 + 0.67705642719734 + 0.66817169863921 + 0.65895539452227 + 0.64927165580833 + 0.63911439262927 + 0.62848307023100 + 0.61740645481774 + 0.60592121940961 + 0.59406993011410 + 0.58189953908531 + 0.56946040652785 + 0.55680396483850 + 0.54395277684793 + 0.53095735992130 + 0.51786882449137 + 0.50473666662134 + 0.49160578825805 + 0.47851323704274 + 0.46546973227771 + 0.45246923427574 + 0.43950511842084 + 0.42655728416686 + 0.41359420610624 + 0.98986720991529 + 0.98986749708624 + 0.98986754482880 + 0.98986760053511 + 0.98986766554762 + 0.98986774143653 + 0.98986783004763 + 0.98986793354580 + 0.98986805452915 + 0.98986819628863 + 0.98986836363862 + 0.98986856365383 + 0.98986880481908 + 0.98986909660687 + 0.98986945016071 + 0.98986987901405 + 0.98987039973397 + 0.98987103263245 + 0.98987180330992 + 0.98987274407153 + 0.98987389416416 + 0.98987530234818 + 0.98987702932369 + 0.98987915095867 + 0.98988176305062 + 0.98988499146634 + 0.98988901113501 + 0.98989405164771 + 0.98990039554728 + 0.98990839771696 + 0.98991853197205 + 0.98993140455413 + 0.98994779804701 + 0.98996873145947 + 0.98999553636688 + 0.99002995971412 + 0.99007430387724 + 0.99013161963940 + 0.99020603809080 + 0.99030320765533 + 0.99043077035812 + 0.99059930515334 + 0.99082368276086 + 0.99112478520490 + 0.99152936962125 + 0.99207234817368 + 0.99281543198708 + 0.99387282302507 + 0.99550488797732 + 1.00000000000000 + 0.99502233386588 + 0.99244824688498 + 0.99010244477230 + 0.98774462952773 + 0.98526187234221 + 0.98257721623420 + 0.97962747360621 + 0.97635333669086 + 0.97269542391487 + 0.96859143398892 + 0.96397029374488 + 0.95873963693580 + 0.95279648410259 + 0.94605082439737 + 0.93842199548679 + 0.92983237923394 + 0.92021613787973 + 0.90952140513888 + 0.89771451824666 + 0.88478533716979 + 0.87075265528755 + 0.85566763705741 + 0.83960775835474 + 0.82265876667634 + 0.80494250935297 + 0.78665899104728 + 0.76805976411795 + 0.75871872472202 + 0.74939322269530 + 0.74010887137950 + 0.73088589903485 + 0.72173800071342 + 0.71267151779480 + 0.70368510689772 + 0.69477009619586 + 0.68591154255061 + 0.67708609606253 + 0.66819983447213 + 0.65898201614902 + 0.64929675849747 + 0.63913797519748 + 0.62850513625009 + 0.61742701709641 + 0.60594030046732 + 0.59408756208254 + 0.58191576323362 + 0.56947527253219 + 0.55681752975701 + 0.54396510110703 + 0.53096850981011 + 0.51787887136663 + 0.50474568584757 + 0.49161385785975 + 0.47852043609114 + 0.46547613821386 + 0.45247492138576 + 0.43951015741175 + 0.42656174097884 + 0.41359814106222 + 0.98865719630447 + 0.98865744980230 + 0.98865749194080 + 0.98865754111169 + 0.98865759849346 + 0.98865766547293 + 0.98865774367704 + 0.98865783501765 + 0.98865794178545 + 0.98865806688427 + 0.98865821457903 + 0.98865839114913 + 0.98865860412731 + 0.98865886191190 + 0.98865917438501 + 0.98865955354634 + 0.98866001408135 + 0.98866057400220 + 0.98866125601364 + 0.98866208878236 + 0.98866310711561 + 0.98866435426184 + 0.98866588407382 + 0.98866776383326 + 0.98867007850882 + 0.98867293977193 + 0.98867650299736 + 0.98868097217377 + 0.98868659822048 + 0.98869369615346 + 0.98870268663889 + 0.98871410766638 + 0.98872865321279 + 0.98874722616264 + 0.98877100495204 + 0.98880153313465 + 0.98884084059800 + 0.98889160918657 + 0.98895745767928 + 0.98904331043123 + 0.98915578099074 + 0.98930393614070 + 0.98950034685959 + 0.98976228974500 + 0.99011094107397 + 0.99057199544175 + 0.99118827450380 + 0.99202925558279 + 0.99321090149220 + 0.99502233386588 + 1.00000000000000 + 0.99446460060707 + 0.99156520835868 + 0.98890714364438 + 0.98622431163719 + 0.98339264229692 + 0.98032857946522 + 0.97696223984461 + 0.97322810712757 + 0.96906000136741 + 0.96438413819220 + 0.95910601179094 + 0.95312111786686 + 0.94633854992423 + 0.93867702616248 + 0.93005840870545 + 0.92041643294164 + 0.90969886079594 + 0.89787169815838 + 0.88492450773987 + 0.87087581902917 + 0.85577656720906 + 0.83970402500146 + 0.82274375005608 + 0.80501744904483 + 0.78672504873079 + 0.76811804023284 + 0.75877349444274 + 0.74944473276962 + 0.74015735561049 + 0.73093157698742 + 0.72178107670943 + 0.71271218026902 + 0.70372352804490 + 0.69480643193721 + 0.68594593276175 + 0.67711866418878 + 0.66823067281987 + 0.65901115166887 + 0.64932419142646 + 0.63916370952535 + 0.62852918103020 + 0.61744939141026 + 0.60596103382949 + 0.59410669428146 + 0.58193334372115 + 0.56949135955308 + 0.55683218918486 + 0.54397840203379 + 0.53098052729895 + 0.51788968560317 + 0.50475538102526 + 0.49162252073693 + 0.47852815427475 + 0.46548299727090 + 0.45248100321124 + 0.43951553976612 + 0.42656649622880 + 0.41360233525743 + 0.98729235673942 + 0.98729258096895 + 0.98729261824111 + 0.98729266172919 + 0.98729271248224 + 0.98729277171752 + 0.98729284087953 + 0.98729292165262 + 0.98729301606450 + 0.98729312668817 + 0.98729325730586 + 0.98729341351714 + 0.98729360203437 + 0.98729383032995 + 0.98729410719979 + 0.98729444332209 + 0.98729485176344 + 0.98729534856010 + 0.98729595392687 + 0.98729669339724 + 0.98729759797227 + 0.98729870616579 + 0.98730006593094 + 0.98730173718455 + 0.98730379558333 + 0.98730634062494 + 0.98730951090647 + 0.98731348847582 + 0.98731849711810 + 0.98732481768107 + 0.98733282531666 + 0.98734299957205 + 0.98735595868548 + 0.98737250646123 + 0.98739369103662 + 0.98742088352333 + 0.98745588399490 + 0.98750106522515 + 0.98755962062177 + 0.98763588043560 + 0.98773562801759 + 0.98786673540222 + 0.98804000791490 + 0.98827006304668 + 0.98857421665156 + 0.98897233828482 + 0.98949645947604 + 0.99019469965401 + 0.99113500141154 + 0.99244824688498 + 0.99446460060707 + 1.00000000000000 + 0.99381858485036 + 0.99054206721102 + 0.98752198169709 + 0.98446502309692 + 0.98123525155354 + 0.97773997520738 + 0.97390184498627 + 0.96964778632547 + 0.96489952665000 + 0.95955926039092 + 0.95352020951717 + 0.94669011619216 + 0.93898676836099 + 0.93033127153245 + 0.92065675313108 + 0.90991045780235 + 0.89805793946613 + 0.88508836111507 + 0.87101989992151 + 0.85590318481063 + 0.83981521626414 + 0.82284129748925 + 0.80510294097273 + 0.78679995575207 + 0.76818373809662 + 0.75883506451666 + 0.74950247880354 + 0.74021156434700 + 0.73098251684671 + 0.72182899679647 + 0.71275730974252 + 0.70376607584677 + 0.69484658684554 + 0.68598386378419 + 0.67715452021977 + 0.66826456624077 + 0.65904312019732 + 0.64935424226907 + 0.63919185378615 + 0.62855543516324 + 0.61747378268394 + 0.60598360071586 + 0.59412748616838 + 0.58195242013949 + 0.56950878917466 + 0.55684804845982 + 0.54399277036925 + 0.53099349008720 + 0.51790133332883 + 0.50476580810162 + 0.49163182396409 + 0.47853643101386 + 0.46549034232989 + 0.45248750709367 + 0.43952128819446 + 0.42657156877803 + 0.41360680438051 + 0.98574508497040 + 0.98574528371944 + 0.98574531675267 + 0.98574535529504 + 0.98574540026893 + 0.98574545276091 + 0.98574551404788 + 0.98574558562048 + 0.98574566927465 + 0.98574576729199 + 0.98574588304518 + 0.98574602153570 + 0.98574618876616 + 0.98574639141613 + 0.98574663733466 + 0.98574693605288 + 0.98574729924817 + 0.98574774123597 + 0.98574828008257 + 0.98574893861178 + 0.98574974453085 + 0.98575073226624 + 0.98575194466868 + 0.98575343528786 + 0.98575527173770 + 0.98575754298750 + 0.98576037315794 + 0.98576392534396 + 0.98576839991757 + 0.98577404821080 + 0.98578120609781 + 0.98579030270433 + 0.98580189100808 + 0.98581668951961 + 0.98583563441947 + 0.98585994909486 + 0.98589123741650 + 0.98593160969315 + 0.98598390046142 + 0.98605194316636 + 0.98614083557167 + 0.98625747896675 + 0.98641127513585 + 0.98661479140625 + 0.98688251134467 + 0.98723031521655 + 0.98768332041239 + 0.98827740706868 + 0.98905788544090 + 0.99010244477230 + 0.99156520835868 + 0.99381858485036 + 1.00000000000000 + 0.99306965782316 + 0.98935485585636 + 0.98591742846546 + 0.98243309794124 + 0.97875040979217 + 0.97476640693486 + 0.97039469223789 + 0.96554906081315 + 0.96012633380886 + 0.95401618776198 + 0.94712425399568 + 0.93936688597711 + 0.93066406227378 + 0.92094802739865 + 0.91016529398854 + 0.89828079038020 + 0.88528313532930 + 0.87119003087695 + 0.85605169394803 + 0.83994475873685 + 0.82295418682643 + 0.80520122400024 + 0.78688550689393 + 0.76825829080914 + 0.75890471439532 + 0.74956760304009 + 0.74027251774973 + 0.73103963050918 + 0.72188257713254 + 0.71280763791746 + 0.70381340761832 + 0.69489115276148 + 0.68602586976772 + 0.67719414735305 + 0.66830195236960 + 0.65907831728869 + 0.64938726714293 + 0.63922272721434 + 0.62858418346919 + 0.61750044382989 + 0.60600822462028 + 0.59415013427697 + 0.58197316448910 + 0.56952771116377 + 0.55686523734088 + 0.54400831790882 + 0.53100749394520 + 0.51791389611837 + 0.50477703616700 + 0.49164182575817 + 0.47854531514613 + 0.46549821421232 + 0.45249446707513 + 0.43952743104916 + 0.42657698225198 + 0.41361156816033 + 0.98398471802533 + 0.98398489454394 + 0.98398492388017 + 0.98398495810520 + 0.98398499804479 + 0.98398504465817 + 0.98398509907500 + 0.98398516262519 + 0.98398523689407 + 0.98398532391903 + 0.98398542670594 + 0.98398554974629 + 0.98398569842321 + 0.98398587871755 + 0.98398609765992 + 0.98398636379352 + 0.98398668756835 + 0.98398708182044 + 0.98398756274437 + 0.98398815080751 + 0.98398887086252 + 0.98398975377141 + 0.98399083796498 + 0.98399217145281 + 0.98399381486625 + 0.98399584803261 + 0.98399838249092 + 0.98400156488665 + 0.98400557524988 + 0.98401063928222 + 0.98401705874376 + 0.98402521899811 + 0.98403561638409 + 0.98404889548102 + 0.98406589555302 + 0.98408771233615 + 0.98411578064760 + 0.98415198546705 + 0.98419885479366 + 0.98425980053905 + 0.98433934422471 + 0.98444358136905 + 0.98458076807168 + 0.98476183721685 + 0.98499910104876 + 0.98530554344708 + 0.98570148951706 + 0.98621496821293 + 0.98687853298753 + 0.98774462952773 + 0.98890714364438 + 0.99054206721102 + 0.99306965782316 + 1.00000000000000 + 0.99219863137155 + 0.98797738335989 + 0.98406240039208 + 0.98009116399825 + 0.97589458383720 + 0.97135737521283 + 0.96637807596652 + 0.96084414551255 + 0.95463942303795 + 0.94766610279403 + 0.93983825382736 + 0.93107412964989 + 0.92130466240114 + 0.91047530809324 + 0.89855011436629 + 0.88551694841595 + 0.87139286423864 + 0.85622751999124 + 0.84009705451541 + 0.82308596945197 + 0.80531514535419 + 0.78698397141105 + 0.76834349879324 + 0.75898404601045 + 0.74964153060424 + 0.74034148403240 + 0.73110404743289 + 0.72194282485602 + 0.71286406439837 + 0.70386632858409 + 0.69494085214302 + 0.68607260054085 + 0.67723813151064 + 0.66834336023784 + 0.65911721965654 + 0.64942369396690 + 0.63925671227510 + 0.62861576620235 + 0.61752967610294 + 0.60603517099000 + 0.59417487138288 + 0.58199577989188 + 0.56954830190951 + 0.55688390822956 + 0.54402517559726 + 0.53102265073520 + 0.51792746898033 + 0.50478914546051 + 0.49165259353327 + 0.47855486305455 + 0.46550665990834 + 0.45250192221669 + 0.43953400077421 + 0.42658276361965 + 0.41361664905718 + 0.98197617512544 + 0.98197633221758 + 0.98197635832308 + 0.98197638877777 + 0.98197642431332 + 0.98197646578701 + 0.98197651420561 + 0.98197657074488 + 0.98197663681296 + 0.98197671423002 + 0.98197680568968 + 0.98197691523056 + 0.98197704769196 + 0.98197720844863 + 0.98197740382028 + 0.98197764147525 + 0.98197793080686 + 0.98197828334615 + 0.98197871365494 + 0.98197924015565 + 0.98197988518687 + 0.98198067651452 + 0.98198164870334 + 0.98198284493131 + 0.98198431972197 + 0.98198614492405 + 0.98198842109294 + 0.98199128049686 + 0.98199488540362 + 0.98199943912732 + 0.98200521362851 + 0.98201255604961 + 0.98202191326907 + 0.98203386536754 + 0.98204916712096 + 0.98206880314706 + 0.98209406140172 + 0.98212663168057 + 0.98216877739965 + 0.98222354846881 + 0.98229497515827 + 0.98238847258079 + 0.98251134182667 + 0.98267317818566 + 0.98288457182066 + 0.98315630808749 + 0.98350519368466 + 0.98395381117905 + 0.98452666480222 + 0.98526187234221 + 0.98622431163719 + 0.98752198169709 + 0.98935485585636 + 0.99219863137155 + 1.00000000000000 + 0.99118722600140 + 0.98638416438372 + 0.98192362372201 + 0.97739883177722 + 0.97261971545950 + 0.96745181727667 + 0.96176478744945 + 0.95543217593757 + 0.94835028615174 + 0.94042940200464 + 0.93158504628431 + 0.92174614452922 + 0.91085659033004 + 0.89887916590138 + 0.88580068282506 + 0.87163729914543 + 0.85643790745787 + 0.84027797215187 + 0.82324137283383 + 0.80544849014257 + 0.78709836255270 + 0.76844175048748 + 0.75907518373792 + 0.74972615092004 + 0.74042014436272 + 0.73117726484370 + 0.72201107527533 + 0.71292778231732 + 0.70392590728265 + 0.69499664439897 + 0.68612491986870 + 0.67728725240211 + 0.66838949478581 + 0.65916046355757 + 0.64946409494812 + 0.63929432154984 + 0.62865064052652 + 0.61756188545879 + 0.60606479870953 + 0.59420201334863 + 0.58202054311629 + 0.56957080284308 + 0.55690427076843 + 0.54404352457513 + 0.53103911618150 + 0.51794218510935 + 0.50480224935870 + 0.49166422337329 + 0.47856515588237 + 0.46551574776028 + 0.45250992998038 + 0.43954104566374 + 0.42658895350495 + 0.41362208131603 + 0.97968112172201 + 0.97968126181082 + 0.97968128508589 + 0.97968131223936 + 0.97968134392357 + 0.97968138089819 + 0.97968142406150 + 0.97968147445977 + 0.97968153335442 + 0.97968160236408 + 0.97968168390830 + 0.97968178162672 + 0.97968189989200 + 0.97968204354139 + 0.97968221826305 + 0.97968243097054 + 0.97968269012057 + 0.97968300611115 + 0.97968339206763 + 0.97968386460295 + 0.97968444387662 + 0.97968515492772 + 0.97968602892625 + 0.97968710481788 + 0.97968843177223 + 0.97969007463597 + 0.97969212432253 + 0.97969470049082 + 0.97969794981819 + 0.97970205596184 + 0.97970726473824 + 0.97971388972708 + 0.97972233443343 + 0.97973312236222 + 0.97974693424372 + 0.97976465740938 + 0.97978745142862 + 0.97981683584391 + 0.97985484390209 + 0.97990421179813 + 0.97996854647410 + 0.98005268100449 + 0.98016310771918 + 0.98030830534928 + 0.98049746273217 + 0.98073963946123 + 0.98104894653054 + 0.98144396885429 + 0.98194372033817 + 0.98257721623420 + 0.98339264229692 + 0.98446502309692 + 0.98591742846546 + 0.98797738335989 + 0.99118722600140 + 1.00000000000000 + 0.99001670050748 + 0.98454601405020 + 0.97946347187639 + 0.97430994592037 + 0.96886569149464 + 0.96296216847399 + 0.95645313404252 + 0.94922413162841 + 0.94117886105693 + 0.93222834511124 + 0.92229833665304 + 0.91133035250417 + 0.89928531290440 + 0.88614851743570 + 0.87193486594180 + 0.85669218979956 + 0.84049502753395 + 0.82342641287696 + 0.80560604136551 + 0.78723245825085 + 0.76855601425503 + 0.75918075518893 + 0.74982378930460 + 0.74051055696636 + 0.73126110591112 + 0.72208894540242 + 0.71300022843311 + 0.70399342320131 + 0.69505967194910 + 0.68618385064929 + 0.67734242843923 + 0.66844118201064 + 0.65920879059674 + 0.64950913352615 + 0.63933614613934 + 0.62868933076491 + 0.61759753486095 + 0.60609751470560 + 0.59423191621665 + 0.58204776425522 + 0.56959548278292 + 0.55692655689993 + 0.54406356391952 + 0.53105706022713 + 0.51795818879913 + 0.50481646973350 + 0.49167681772141 + 0.47857627939384 + 0.46552554933695 + 0.45251854997453 + 0.43954861533856 + 0.42659559326012 + 0.41362789948410 + 0.97705855154200 + 0.97705867672212 + 0.97705869751819 + 0.97705872177931 + 0.97705875008583 + 0.97705878311916 + 0.97705882167735 + 0.97705886669722 + 0.97705891930393 + 0.97705898094196 + 0.97705905379172 + 0.97705914114748 + 0.97705924696120 + 0.97705937560393 + 0.97705953220738 + 0.97705972301712 + 0.97705995567364 + 0.97706023956593 + 0.97706058656404 + 0.97706101169574 + 0.97706153319224 + 0.97706217369254 + 0.97706296139322 + 0.97706393150004 + 0.97706512848700 + 0.97706661102789 + 0.97706846154864 + 0.97707078860414 + 0.97707372513081 + 0.97707743749714 + 0.97708214846405 + 0.97708814207662 + 0.97709578363411 + 0.97710554683627 + 0.97711804727618 + 0.97713408676354 + 0.97715471213471 + 0.97718129367840 + 0.97721566330459 + 0.97726028355012 + 0.97731839369732 + 0.97739432422804 + 0.97749387451073 + 0.97762457743724 + 0.97779445944610 + 0.97801119087818 + 0.97828675051372 + 0.97863666399338 + 0.97907598302024 + 0.97962747360621 + 0.98032857946522 + 0.98123525155354 + 0.98243309794124 + 0.98406240039208 + 0.98638416438372 + 0.99001670050748 + 1.00000000000000 + 0.98866321242402 + 0.98242832856438 + 0.97663757032367 + 0.97076493151491 + 0.96454379535673 + 0.95778504987314 + 0.95035290507859 + 0.94213889296586 + 0.93304625207408 + 0.92299551571256 + 0.91192446337141 + 0.89979119888184 + 0.88657880660666 + 0.87230038757464 + 0.85700228198279 + 0.84075774513197 + 0.82364865296604 + 0.80579375975070 + 0.78739092011943 + 0.76868991143089 + 0.75930394602039 + 0.74993724627961 + 0.74061518339292 + 0.73135773509986 + 0.72217834037881 + 0.71308308230932 + 0.70407036019884 + 0.69513124912179 + 0.68625056034159 + 0.67740469956215 + 0.66849934987704 + 0.65926302733652 + 0.64955954312747 + 0.63938283403020 + 0.62873240669092 + 0.61763712287770 + 0.60613375308131 + 0.59426495608433 + 0.58207776751603 + 0.56962261976982 + 0.55695100380562 + 0.54408549475725 + 0.53107665236980 + 0.51797562196276 + 0.50483192464402 + 0.49169047418791 + 0.47858831385318 + 0.46553613034208 + 0.45252783580291 + 0.43955675346273 + 0.42660271847537 + 0.41363413265105 + 0.97406333531755 + 0.97406344741735 + 0.97406346603984 + 0.97406348776126 + 0.97406351310507 + 0.97406354267686 + 0.97406357719568 + 0.97406361749530 + 0.97406366458360 + 0.97406371975792 + 0.97406378498390 + 0.97406386324420 + 0.97406395812499 + 0.97406407358304 + 0.97406421426700 + 0.97406438582799 + 0.97406459518658 + 0.97406485084107 + 0.97406516355520 + 0.97406554696479 + 0.97406601758630 + 0.97406659595917 + 0.97406730763869 + 0.97406818454576 + 0.97406926699200 + 0.97407060822201 + 0.97407228316234 + 0.97407439054186 + 0.97407705117588 + 0.97408041614581 + 0.97408468785811 + 0.97409012426135 + 0.97409705690468 + 0.97410591551869 + 0.97411725819867 + 0.97413181131657 + 0.97415052236477 + 0.97417463027895 + 0.97420579003976 + 0.97424622423584 + 0.97429885088893 + 0.97436756325509 + 0.97445756153094 + 0.97457556819585 + 0.97472863111811 + 0.97492328055489 + 0.97516976723375 + 0.97548120028665 + 0.97586964820843 + 0.97635333669086 + 0.97696223984461 + 0.97773997520738 + 0.97875040979217 + 0.98009116399825 + 0.98192362372201 + 0.98454601405020 + 0.98866321242402 + 1.00000000000000 + 0.98709979781854 + 0.97999122776559 + 0.97338855657813 + 0.96667467262998 + 0.95954939786176 + 0.95182956627711 + 0.94338236761654 + 0.93409673160197 + 0.92388417965353 + 0.91267637650840 + 0.90042702338170 + 0.88711587049973 + 0.87275339113759 + 0.85738379525385 + 0.84107853810278 + 0.82391789735858 + 0.80601932824755 + 0.78757971961517 + 0.76884804926696 + 0.75944879427998 + 0.75007005801819 + 0.74073711932419 + 0.73146986322084 + 0.72228163617009 + 0.71317842967031 + 0.70415855317245 + 0.69521299441586 + 0.68632648079803 + 0.67747533629178 + 0.66856512789700 + 0.65932417624583 + 0.64961621014209 + 0.63943516564002 + 0.62878055217566 + 0.61768124587087 + 0.60617403134381 + 0.59430157980232 + 0.58211093680763 + 0.56965254195794 + 0.55697789048880 + 0.54410955289067 + 0.53109809064872 + 0.51799464984983 + 0.50484875106699 + 0.49170530560679 + 0.47860135168241 + 0.46554756611901 + 0.45253784866932 + 0.43956550967936 + 0.42661036944205 + 0.41364081361470 + 0.97064575848398 + 0.97064585909897 + 0.97064587581022 + 0.97064589530531 + 0.97064591804892 + 0.97064594458757 + 0.97064597555791 + 0.97064601171493 + 0.97064605395936 + 0.97064610345848 + 0.97064616198979 + 0.97064623226426 + 0.97064631754098 + 0.97064642141076 + 0.97064654809157 + 0.97064670271469 + 0.97064689156005 + 0.97064712234874 + 0.97064740486394 + 0.97064775149261 + 0.97064817725996 + 0.97064870082518 + 0.97064934542971 + 0.97065014007825 + 0.97065112141350 + 0.97065233786347 + 0.97065385771239 + 0.97065577099457 + 0.97065818778108 + 0.97066124563125 + 0.97066512890842 + 0.97067007244216 + 0.97067637791399 + 0.97068443612118 + 0.97069475427911 + 0.97070799203132 + 0.97072500906786 + 0.97074692834254 + 0.97077524881574 + 0.97081198181236 + 0.97085976327648 + 0.97092210390036 + 0.97100368212575 + 0.97111051986538 + 0.97124883185256 + 0.97142419917670 + 0.97164544604794 + 0.97192372664192 + 0.97226879077665 + 0.97269542391487 + 0.97322810712757 + 0.97390184498627 + 0.97476640693486 + 0.97589458383720 + 0.97739883177722 + 0.97946347187639 + 0.98242832856438 + 0.98709979781854 + 1.00000000000000 + 0.98529459734840 + 0.97718082345465 + 0.96962681268325 + 0.96193291002113 + 0.95379078923382 + 0.94501324559228 + 0.93546073783600 + 0.92502825974402 + 0.91363697656156 + 0.90123342979932 + 0.88779218643381 + 0.87331977989480 + 0.85785731463199 + 0.84147368223073 + 0.82424692975908 + 0.80629270741137 + 0.78780655122799 + 0.76903632478383 + 0.75962044990245 + 0.75022671747813 + 0.74088028270953 + 0.73160090734184 + 0.72240181547366 + 0.71328887805053 + 0.70426028666556 + 0.69530691487639 + 0.68641338072793 + 0.67755590222340 + 0.66863990121930 + 0.65939346251294 + 0.64968021432647 + 0.63949408859579 + 0.62883459501500 + 0.61773062349510 + 0.60621897208500 + 0.59434232336749 + 0.58214773129497 + 0.56968564069577 + 0.55700754875208 + 0.54413601797309 + 0.53112160928437 + 0.51801546734946 + 0.50486711010399 + 0.49172144430019 + 0.47861550094751 + 0.46555994449636 + 0.45254865970455 + 0.43957494150251 + 0.42661859269408 + 0.41364798014995 + 0.96675053706058 + 0.96675062760093 + 0.96675064263724 + 0.96675066017573 + 0.96675068063458 + 0.96675070450881 + 0.96675073236591 + 0.96675076489203 + 0.96675080288674 + 0.96675084740741 + 0.96675090006079 + 0.96675096332292 + 0.96675104016015 + 0.96675113384133 + 0.96675124820771 + 0.96675138791714 + 0.96675155869757 + 0.96675176757429 + 0.96675202345773 + 0.96675233763918 + 0.96675272381633 + 0.96675319899177 + 0.96675378434612 + 0.96675450630592 + 0.96675539825715 + 0.96675650436217 + 0.96675788701394 + 0.96675962851707 + 0.96676182941260 + 0.96676461524407 + 0.96676815436287 + 0.96677266108028 + 0.96677841055597 + 0.96678575903262 + 0.96679516858259 + 0.96680723967295 + 0.96682275417609 + 0.96684273233447 + 0.96686853505564 + 0.96690198698371 + 0.96694547534135 + 0.96700217441226 + 0.96707630557766 + 0.96717328070677 + 0.96729859886408 + 0.96745704213899 + 0.96765624039713 + 0.96790573710791 + 0.96821343639374 + 0.96859143398892 + 0.96906000136741 + 0.96964778632547 + 0.97039469223789 + 0.97135737521283 + 0.97261971545950 + 0.97430994592037 + 0.97663757032367 + 0.97999122776559 + 0.98529459734840 + 1.00000000000000 + 0.98320082118602 + 0.97390752192625 + 0.96524460596297 + 0.95644762386412 + 0.94718516446216 + 0.93725442027156 + 0.92651758692901 + 0.91487667715475 + 0.90226601180156 + 0.88865177684016 + 0.87403440800307 + 0.85845036724168 + 0.84196482407727 + 0.82465266767637 + 0.80662701571932 + 0.78808150032673 + 0.76926242893919 + 0.75982561217970 + 0.75041305394612 + 0.74104974325058 + 0.73175527714915 + 0.72254271717480 + 0.71341777474494 + 0.70437848604315 + 0.69541557451509 + 0.68651351481758 + 0.67764838673843 + 0.66872542916647 + 0.65947243998233 + 0.64975292337898 + 0.63956080199377 + 0.62889558181865 + 0.61778616508484 + 0.60626936173321 + 0.59438786375153 + 0.58218873100647 + 0.56972241059297 + 0.55704039827484 + 0.54416524412955 + 0.53114750534414 + 0.51803832214991 + 0.50488720701723 + 0.49173905939354 + 0.47863090029080 + 0.46557337865150 + 0.45256036103137 + 0.43958512384201 + 0.42662744922455 + 0.41365568208778 + 0.96231226645031 + 0.96231234814215 + 0.96231236170581 + 0.96231237752868 + 0.96231239598360 + 0.96231241751710 + 0.96231244264411 + 0.96231247197686 + 0.96231250624069 + 0.96231254638805 + 0.96231259388452 + 0.96231265098594 + 0.96231272039942 + 0.96231280511404 + 0.96231290862659 + 0.96231303519467 + 0.96231319003745 + 0.96231337956998 + 0.96231361192403 + 0.96231389742567 + 0.96231424858364 + 0.96231468092719 + 0.96231521380830 + 0.96231587136127 + 0.96231668407765 + 0.96231769231430 + 0.96231895322026 + 0.96232054220025 + 0.96232255129378 + 0.96232509534022 + 0.96232832840585 + 0.96233244649768 + 0.96233770112228 + 0.96234441772005 + 0.96235301812331 + 0.96236405006088 + 0.96237822610335 + 0.96239647507701 + 0.96242003510774 + 0.96245056494446 + 0.96249023118658 + 0.96254191037283 + 0.96260942056749 + 0.96269763804017 + 0.96281144143158 + 0.96295493347543 + 0.96313473138297 + 0.96335903064683 + 0.96363423803457 + 0.96397029374488 + 0.96438413819220 + 0.96489952665000 + 0.96554906081315 + 0.96637807596652 + 0.96745181727667 + 0.96886569149464 + 0.97076493151491 + 0.97338855657813 + 0.97718082345465 + 0.98320082118602 + 1.00000000000000 + 0.98073726330858 + 0.97006848492479 + 0.96015542761955 + 0.95014037930915 + 0.93965360752763 + 0.92848456260666 + 0.91649739804642 + 0.90360424086379 + 0.88975703525415 + 0.87494639255547 + 0.85920160679039 + 0.84258230452627 + 0.82515881593864 + 0.80704065475444 + 0.78841874947378 + 0.76953722104849 + 0.76007376540577 + 0.75063734567747 + 0.74125272618257 + 0.73193928267860 + 0.72270985929750 + 0.71356995502586 + 0.70451739979995 + 0.69554271842135 + 0.68663019631855 + 0.67775573173767 + 0.66882433067462 + 0.65956343800252 + 0.64983640308309 + 0.63963713170416 + 0.62896512026414 + 0.61784928069892 + 0.60632643219490 + 0.59443927306247 + 0.58223486538529 + 0.56976365429615 + 0.55707712949167 + 0.54419782266702 + 0.53117628295126 + 0.51806364211124 + 0.50490940337652 + 0.49175845525932 + 0.47864780514681 + 0.46558808248523 + 0.45257313156569 + 0.43959620639784 + 0.42663706450167 + 0.41366402489795 + 0.95724385946959 + 0.95724393335247 + 0.95724394561704 + 0.95724395992396 + 0.95724397661050 + 0.95724399608022 + 0.95724401879828 + 0.95724404531492 + 0.95724407628842 + 0.95724411257999 + 0.95724415552047 + 0.95724420718001 + 0.95724427003451 + 0.95724434681303 + 0.95724444071534 + 0.95724455562647 + 0.95724469631803 + 0.95724486865798 + 0.95724508008347 + 0.95724534005271 + 0.95724566000027 + 0.95724605414765 + 0.95724654019008 + 0.95724714021112 + 0.95724788210239 + 0.95724880280740 + 0.95724995473144 + 0.95725140707275 + 0.95725324419902 + 0.95725557130531 + 0.95725852957258 + 0.95726229851590 + 0.95726710831177 + 0.95727325663789 + 0.95728112904921 + 0.95729122578830 + 0.95730419700492 + 0.95732088928590 + 0.95734243030769 + 0.95737032970595 + 0.95740655609512 + 0.95745371927433 + 0.95751527685422 + 0.95759562856320 + 0.95769910816072 + 0.95782923380028 + 0.95799175141971 + 0.95819370962369 + 0.95844027971378 + 0.95873963693580 + 0.95910601179094 + 0.95955926039092 + 0.96012633380886 + 0.96084414551255 + 0.96176478744945 + 0.96296216847399 + 0.96454379535673 + 0.96667467262998 + 0.96962681268325 + 0.97390752192625 + 0.98073726330858 + 1.00000000000000 + 0.97783512279022 + 0.96560470168930 + 0.95430169087830 + 0.94294761713989 + 0.93113957886729 + 0.91865768352318 + 0.90537017043275 + 0.89120311855584 + 0.87613043875994 + 0.86016986409579 + 0.84337246914457 + 0.82580181336862 + 0.80756216896934 + 0.78884056470479 + 0.76987801158233 + 0.76038016285590 + 0.75091303608059 + 0.74150108859992 + 0.73216339573288 + 0.72291250802041 + 0.71375363879717 + 0.70468434167160 + 0.69569487613986 + 0.68676927554982 + 0.67788319742005 + 0.66894134687799 + 0.65967072624186 + 0.64993448821502 + 0.63972651121740 + 0.62904627391791 + 0.61792269423772 + 0.60639259688229 + 0.59449868220281 + 0.58228800944337 + 0.56981101602332 + 0.55711917928162 + 0.54423500451831 + 0.53120902701773 + 0.51809236467084 + 0.50493450640646 + 0.49178032494716 + 0.47866680919705 + 0.46560456374944 + 0.45258740521530 + 0.43960855999777 + 0.42664775572424 + 0.41367328030425 + 0.95144635367882 + 0.95144642062895 + 0.95144643174459 + 0.95144644470454 + 0.95144645982330 + 0.95144647746075 + 0.95144649803976 + 0.95144652205754 + 0.95144655010979 + 0.95144658297853 + 0.95144662187757 + 0.95144666869996 + 0.95144672571921 + 0.95144679542598 + 0.95144688074906 + 0.95144698524524 + 0.95144711328577 + 0.95144727023003 + 0.95144746289436 + 0.95144769994130 + 0.95144799184536 + 0.95144835163373 + 0.95144879550784 + 0.95144934368486 + 0.95145002169737 + 0.95145086339274 + 0.95145191685249 + 0.95145324561756 + 0.95145492705954 + 0.95145705759526 + 0.95145976666542 + 0.95146321873126 + 0.95146762454952 + 0.95147325649539 + 0.95148046709778 + 0.95148971333414 + 0.95150158856546 + 0.95151686456637 + 0.95153656862010 + 0.95156207484854 + 0.95159517221549 + 0.95163822882434 + 0.95169437638933 + 0.95176758550026 + 0.95186170584913 + 0.95197974763880 + 0.95212669805633 + 0.95230861682600 + 0.95252964328402 + 0.95279648410259 + 0.95312111786686 + 0.95352020951717 + 0.95401618776198 + 0.95463942303795 + 0.95543217593757 + 0.95645313404252 + 0.95778504987314 + 0.95954939786176 + 0.96193291002113 + 0.96524460596297 + 0.97006848492479 + 0.97783512279022 + 1.00000000000000 + 0.97446742439224 + 0.96047746568249 + 0.94763061664212 + 0.93481954085162 + 0.92160130559776 + 0.90774643773486 + 0.89312975653426 + 0.87769478359127 + 0.86143955627731 + 0.84440135548513 + 0.82663331926040 + 0.80823188013905 + 0.78937832053918 + 0.77030915178374 + 0.76076624905573 + 0.75125901607810 + 0.74181148564370 + 0.73244232049414 + 0.72316367034313 + 0.71398036046543 + 0.70488957062480 + 0.69588120261653 + 0.68693895096759 + 0.67803815093669 + 0.66908311351325 + 0.65980027589614 + 0.65005253685896 + 0.63983373306552 + 0.62914331422688 + 0.61801019904334 + 0.60647121254605 + 0.59456905113682 + 0.58235076420240 + 0.56986677350473 + 0.55716853537218 + 0.54427851773573 + 0.53124723410185 + 0.51812578106728 + 0.50496362634489 + 0.49180562021962 + 0.47868872649450 + 0.46562351760979 + 0.45260377511617 + 0.43962269077645 + 0.42665995518789 + 0.41368381807660 + 0.94483193577400 + 0.94483199655323 + 0.94483200664131 + 0.94483201840589 + 0.94483203212798 + 0.94483204813548 + 0.94483206680812 + 0.94483208860161 + 0.94483211405623 + 0.94483214387708 + 0.94483217917553 + 0.94483222168861 + 0.94483227349880 + 0.94483233688838 + 0.94483241453995 + 0.94483250970616 + 0.94483262638953 + 0.94483276950534 + 0.94483294529748 + 0.94483316170637 + 0.94483342833551 + 0.94483375712110 + 0.94483416290484 + 0.94483466421025 + 0.94483528442257 + 0.94483605456753 + 0.94483701877330 + 0.94483823540270 + 0.94483977544434 + 0.94484172727962 + 0.94484420961219 + 0.94484737314986 + 0.94485141089923 + 0.94485657210282 + 0.94486317912076 + 0.94487164943249 + 0.94488252456398 + 0.94489650806560 + 0.94491453567470 + 0.94493785803579 + 0.94496810060619 + 0.94500741184504 + 0.94505862781752 + 0.94512533131289 + 0.94521094045986 + 0.94531802275134 + 0.94545090166372 + 0.94561477952294 + 0.94581292901702 + 0.94605082439737 + 0.94633854992423 + 0.94669011619216 + 0.94712425399568 + 0.94766610279403 + 0.94835028615174 + 0.94922413162841 + 0.95035290507859 + 0.95182956627711 + 0.95379078923382 + 0.95644762386412 + 0.96015542761955 + 0.96560470168930 + 0.97446742439224 + 1.00000000000000 + 0.97059029550277 + 0.95462150601688 + 0.94007870142075 + 0.92570074838333 + 0.91099859651430 + 0.89573292726671 + 0.87978707193299 + 0.86312324926286 + 0.84575531022809 + 0.82771968181297 + 0.80910068996619 + 0.79007093701454 + 0.77086029595346 + 0.76125788447494 + 0.75169783601052 + 0.74220358965123 + 0.73279323595465 + 0.72347837259417 + 0.71426329346263 + 0.70514466889492 + 0.69611191522962 + 0.68714826873698 + 0.67822863067901 + 0.66925679163356 + 0.65995846021572 + 0.65019620434352 + 0.63996379841879 + 0.62926064705715 + 0.61811566162159 + 0.60656565940713 + 0.59465332386660 + 0.58242568423899 + 0.56993313524034 + 0.55722709997220 + 0.54432999394158 + 0.53129229781956 + 0.51816507664892 + 0.50499776739511 + 0.49183518884954 + 0.47871427077759 + 0.46564554380393 + 0.45262274473109 + 0.43963902149262 + 0.42667401842001 + 0.41369593796519 + 0.93732142900778 + 0.93732148428592 + 0.93732149345955 + 0.93732150415559 + 0.93732151663272 + 0.93732153118556 + 0.93732154816321 + 0.93732156797320 + 0.93732159110992 + 0.93732161821620 + 0.93732165030617 + 0.93732168896865 + 0.93732173612197 + 0.93732179385181 + 0.93732186462306 + 0.93732195141524 + 0.93732205789308 + 0.93732218856346 + 0.93732234915386 + 0.93732254694689 + 0.93732279075554 + 0.93732309151206 + 0.93732346283743 + 0.93732392170480 + 0.93732448954187 + 0.93732519479407 + 0.93732607799376 + 0.93732719274760 + 0.93732860420344 + 0.93733039341721 + 0.93733266925442 + 0.93733556985612 + 0.93733927199202 + 0.93734400378098 + 0.93735006001656 + 0.93735782211850 + 0.93736778431374 + 0.93738058795546 + 0.93739708535909 + 0.93741841465248 + 0.93744605258803 + 0.93748194804940 + 0.93752866897285 + 0.93758944769259 + 0.93766731752601 + 0.93776446023428 + 0.93788461815912 + 0.93803224891775 + 0.93820989615688 + 0.93842199548679 + 0.93867702616248 + 0.93898676836099 + 0.93936688597711 + 0.93983825382736 + 0.94042940200464 + 0.94117886105693 + 0.94213889296586 + 0.94338236761654 + 0.94501324559228 + 0.94718516446216 + 0.95014037930915 + 0.95430169087830 + 0.96047746568249 + 0.97059029550277 + 1.00000000000000 + 0.96613449614328 + 0.94796388191448 + 0.93157940177119 + 0.91553993249239 + 0.89930319360802 + 0.88261872499096 + 0.86537793397208 + 0.84755224286479 + 0.82914990762213 + 0.81023581583585 + 0.79096905320279 + 0.77156946338746 + 0.76188797596947 + 0.75225797084606 + 0.74270204645047 + 0.73323749125895 + 0.72387513559706 + 0.71461853987842 + 0.70546367535295 + 0.69639929544317 + 0.68740801316625 + 0.67846414230998 + 0.66947078235881 + 0.66015269698739 + 0.65037202020278 + 0.64012243448802 + 0.62940327585068 + 0.61824343537243 + 0.60667970999332 + 0.59475475654550 + 0.58251556896138 + 0.57001249850458 + 0.55729691779278 + 0.54439116932096 + 0.53134568555733 + 0.51821148581288 + 0.50503796324178 + 0.49186989288079 + 0.47874415852960 + 0.46567123633673 + 0.45264480583969 + 0.43965795934355 + 0.42669028314963 + 0.41370992096109 + 0.92883856562871 + 0.92883861597399 + 0.92883862432681 + 0.92883863406922 + 0.92883864543010 + 0.92883865868077 + 0.92883867413853 + 0.92883869217373 + 0.92883871323366 + 0.92883873790768 + 0.92883876712156 + 0.92883880233720 + 0.92883884530804 + 0.92883889795637 + 0.92883896253392 + 0.92883904177513 + 0.92883913904558 + 0.92883925847680 + 0.92883940532330 + 0.92883958626936 + 0.92883980939658 + 0.92884008474412 + 0.92884042479540 + 0.92884084511877 + 0.92884136535585 + 0.92884201159738 + 0.92884282107057 + 0.92884384303255 + 0.92884513728288 + 0.92884677816649 + 0.92884886555011 + 0.92885152606432 + 0.92885492162341 + 0.92885926103736 + 0.92886481389439 + 0.92887192868548 + 0.92888105647343 + 0.92889278188045 + 0.92890788117033 + 0.92892739000271 + 0.92895264980582 + 0.92898542816350 + 0.92902804981723 + 0.92908343033281 + 0.92915425993570 + 0.92924238457462 + 0.92935103762477 + 0.92948402938836 + 0.92964329043896 + 0.92983237923394 + 0.93005840870545 + 0.93033127153245 + 0.93066406227378 + 0.93107412964989 + 0.93158504628431 + 0.93222834511124 + 0.93304625207408 + 0.93409673160197 + 0.93546073783600 + 0.93725442027156 + 0.93965360752763 + 0.94294761713989 + 0.94763061664212 + 0.95462150601688 + 0.96613449614328 + 1.00000000000000 + 0.96103612676495 + 0.94043660749105 + 0.92207657342394 + 0.90430307131082 + 0.88651093749198 + 0.86843441307643 + 0.84996134828096 + 0.83104935785298 + 0.81173052986916 + 0.79214206855423 + 0.77248819342959 + 0.76270090611981 + 0.75297763734402 + 0.74333977578063 + 0.73380346985597 + 0.72437847047406 + 0.71506731518834 + 0.70586500739454 + 0.69675938823131 + 0.68773221730205 + 0.67875700822371 + 0.66973593697485 + 0.66039253389029 + 0.65058836002677 + 0.64031696288375 + 0.62957757548767 + 0.61839904846055 + 0.60681813895301 + 0.59487745668064 + 0.58262393812790 + 0.57010786762015 + 0.55738054299041 + 0.54446420557358 + 0.53140921834151 + 0.51826653532405 + 0.50508548802936 + 0.49191079114073 + 0.47877926656836 + 0.46570131940002 + 0.45267055567305 + 0.43967999688953 + 0.42670915632138 + 0.41372610438347 + 0.91931867801992 + 0.91931872392418 + 0.91931873153871 + 0.91931874041890 + 0.91931875077444 + 0.91931876285234 + 0.91931877694088 + 0.91931879337771 + 0.91931881256893 + 0.91931883505228 + 0.91931886167463 + 0.91931889378051 + 0.91931893297719 + 0.91931898102952 + 0.91931904000606 + 0.91931911241019 + 0.91931920133337 + 0.91931931056078 + 0.91931944492272 + 0.91931961055100 + 0.91931981486287 + 0.91932006706800 + 0.91932037862543 + 0.91932076380144 + 0.91932124061725 + 0.91932183299701 + 0.91932257514679 + 0.91932351231416 + 0.91932469941196 + 0.91932620461029 + 0.91932811954464 + 0.91933056028662 + 0.91933367515956 + 0.91933765528897 + 0.91934274721824 + 0.91934926933915 + 0.91935763330859 + 0.91936837200690 + 0.91938219237566 + 0.91940003671127 + 0.91942312337427 + 0.91945305524942 + 0.91949193656184 + 0.91954239666555 + 0.91960682007057 + 0.91968676107329 + 0.91978500774241 + 0.91990480807323 + 0.92004757874318 + 0.92021613787973 + 0.92041643294164 + 0.92065675313108 + 0.92094802739865 + 0.92130466240114 + 0.92174614452922 + 0.92229833665304 + 0.92299551571256 + 0.92388417965353 + 0.92502825974402 + 0.92651758692901 + 0.92848456260666 + 0.93113957886729 + 0.93481954085162 + 0.94007870142075 + 0.94796388191448 + 0.96103612676495 + 1.00000000000000 + 0.95522419972502 + 0.93197284692498 + 0.91152436322048 + 0.89197483691594 + 0.87264248421023 + 0.85323027311788 + 0.83359677874792 + 0.81371511886027 + 0.79368529892685 + 0.77368624253983 + 0.76375633825193 + 0.75390787474107 + 0.74416046385101 + 0.73452860508499 + 0.72502050824466 + 0.71563726632380 + 0.70637252825593 + 0.69721286810154 + 0.68813886752472 + 0.67912294258842 + 0.67006602696643 + 0.66069003143013 + 0.65085575519311 + 0.64055654784057 + 0.62979148900028 + 0.61858935758800 + 0.60698684133621 + 0.59502647235317 + 0.58275509749997 + 0.57022290068210 + 0.55748107085372 + 0.54455170978107 + 0.53148508150679 + 0.51833204798245 + 0.50514185477380 + 0.49195913384075 + 0.47882062401268 + 0.46573663761702 + 0.45270068620288 + 0.43970570095787 + 0.42673110304378 + 0.41374487119910 + 0.90871098288733 + 0.90871102476123 + 0.90871103170664 + 0.90871103980399 + 0.90871104925039 + 0.90871106026208 + 0.90871107310828 + 0.90871108809489 + 0.90871110559152 + 0.90871112608767 + 0.90871115036002 + 0.90871117964228 + 0.90871121540829 + 0.90871125928308 + 0.90871131315356 + 0.90871137932747 + 0.90871146063218 + 0.90871156054828 + 0.90871168350061 + 0.90871183511784 + 0.90871202221646 + 0.90871225323257 + 0.90871253868345 + 0.90871289165730 + 0.90871332866286 + 0.90871387165861 + 0.90871455204699 + 0.90871541140592 + 0.90871650012814 + 0.90871788074001 + 0.90871963728902 + 0.90872187616577 + 0.90872473321781 + 0.90872838335339 + 0.90873305202105 + 0.90873903006957 + 0.90874669313492 + 0.90875652686591 + 0.90876917495950 + 0.90878549462225 + 0.90880659221946 + 0.90883392099886 + 0.90886938518412 + 0.90891535550924 + 0.90897394429264 + 0.90904645332195 + 0.90913528167614 + 0.90924318974290 + 0.90937116585775 + 0.90952140513888 + 0.90969886079594 + 0.90991045780235 + 0.91016529398854 + 0.91047530809324 + 0.91085659033004 + 0.91133035250417 + 0.91192446337141 + 0.91267637650840 + 0.91363697656156 + 0.91487667715475 + 0.91649739804642 + 0.91865768352318 + 0.92160130559776 + 0.92570074838333 + 0.93157940177119 + 0.94043660749105 + 0.95522419972502 + 1.00000000000000 + 0.94862547440832 + 0.92251365116178 + 0.89989406603456 + 0.87856371348673 + 0.85773731091076 + 0.83705565175079 + 0.81637654817784 + 0.79573266617090 + 0.77525992084375 + 0.76513600440013 + 0.75511808675997 + 0.74522310062169 + 0.73546310642627 + 0.72584407120922 + 0.71636501444735 + 0.70701766321545 + 0.69778681097725 + 0.68865139709821 + 0.67958231898768 + 0.67047882610643 + 0.66106068794252 + 0.65118768279600 + 0.64085286959570 + 0.63005510014889 + 0.61882303358519 + 0.60719324331470 + 0.59520813869234 + 0.58291443035498 + 0.57036215419316 + 0.55760234253636 + 0.54465690514599 + 0.53157596659755 + 0.51841026007996 + 0.50520891221539 + 0.49201644214617 + 0.47886947744506 + 0.46577820928674 + 0.45273602757315 + 0.43973574810873 + 0.42675667560927 + 0.41376667387316 + 0.89698283230635 + 0.89698287049056 + 0.89698287682469 + 0.89698288420774 + 0.89698289281860 + 0.89698290285969 + 0.89698291456811 + 0.89698292822652 + 0.89698294417353 + 0.89698296285246 + 0.89698298497736 + 0.89698301167461 + 0.89698304430138 + 0.89698308434298 + 0.89698313353038 + 0.89698319398630 + 0.89698326829301 + 0.89698335964525 + 0.89698347209998 + 0.89698361082363 + 0.89698378206288 + 0.89698399356260 + 0.89698425495583 + 0.89698457824016 + 0.89698497855210 + 0.89698547600260 + 0.89698609943278 + 0.89698688701722 + 0.89698788498323 + 0.89698915064429 + 0.89699076105560 + 0.89699281369573 + 0.89699543292379 + 0.89699877875941 + 0.89700305727251 + 0.89700853405944 + 0.89701555176093 + 0.89702455283033 + 0.89703612319190 + 0.89705104236334 + 0.89707031468186 + 0.89709525729899 + 0.89712759288217 + 0.89716945830268 + 0.89722272369711 + 0.89728847307187 + 0.89736876641960 + 0.89746594229844 + 0.89758063507205 + 0.89771451824666 + 0.89787169815838 + 0.89805793946613 + 0.89828079038020 + 0.89855011436629 + 0.89887916590138 + 0.89928531290440 + 0.89979119888184 + 0.90042702338170 + 0.90123342979932 + 0.90226601180156 + 0.90360424086379 + 0.90537017043275 + 0.90774643773486 + 0.91099859651430 + 0.91553993249239 + 0.92207657342394 + 0.93197284692498 + 0.94862547440832 + 1.00000000000000 + 0.94116830074121 + 0.91201283879401 + 0.88717758859973 + 0.86409423695213 + 0.84183083283278 + 0.81999170250447 + 0.79847703324719 + 0.77734486139641 + 0.76695389042690 + 0.75670419463325 + 0.74660852850575 + 0.73667523841433 + 0.72690694553742 + 0.71729962948323 + 0.70784224109137 + 0.69851703322115 + 0.68930062569054 + 0.68016179103348 + 0.67099747330489 + 0.66152458801831 + 0.65160153264235 + 0.64122093728238 + 0.63038131512871 + 0.61911113152039 + 0.60744677759466 + 0.59543047314688 + 0.58310872516105 + 0.57053135385652 + 0.55774916810123 + 0.54478381396352 + 0.53168522074447 + 0.51850394271986 + 0.50528894280181 + 0.49208458687444 + 0.47892735377943 + 0.46582727637847 + 0.45277758771926 + 0.43977095594720 + 0.42678653826069 + 0.41379205401443 + 0.88412502625465 + 0.88412506103350 + 0.88412506680189 + 0.88412507352646 + 0.88412508136602 + 0.88412509050865 + 0.88412510117095 + 0.88412511360784 + 0.88412512812711 + 0.88412514513233 + 0.88412516527301 + 0.88412518958664 + 0.88412521931232 + 0.88412525581684 + 0.88412530067896 + 0.88412535583691 + 0.88412542366697 + 0.88412550708880 + 0.88412560981665 + 0.88412573659352 + 0.88412589312929 + 0.88412608652750 + 0.88412632560221 + 0.88412662134445 + 0.88412698760487 + 0.88412744281273 + 0.88412801340229 + 0.88412873439347 + 0.88412964815758 + 0.88413080718206 + 0.88413228205651 + 0.88413416200407 + 0.88413656079385 + 0.88413962470072 + 0.88414354194173 + 0.88414855490048 + 0.88415497590225 + 0.88416320780418 + 0.88417378360414 + 0.88418741176247 + 0.88420500346658 + 0.88422775186800 + 0.88425721456305 + 0.88429531669672 + 0.88434371295359 + 0.88440330041118 + 0.88447584414003 + 0.88456331885388 + 0.88466606987357 + 0.88478533716979 + 0.88492450773987 + 0.88508836111507 + 0.88528313532930 + 0.88551694841595 + 0.88580068282506 + 0.88614851743570 + 0.88657880660666 + 0.88711587049973 + 0.88779218643381 + 0.88865177684016 + 0.88975703525415 + 0.89120311855584 + 0.89312975653426 + 0.89573292726671 + 0.89930319360802 + 0.90430307131082 + 0.91152436322048 + 0.92251365116178 + 0.94116830074121 + 1.00000000000000 + 0.93278533175067 + 0.90043885389014 + 0.87337765806008 + 0.84858161394708 + 0.82498829233924 + 0.80220511994963 + 0.78013683505067 + 0.76937246429530 + 0.75880135423410 + 0.74842945415597 + 0.73825923870363 + 0.72828817413442 + 0.71850765907768 + 0.70890253898583 + 0.69945136900529 + 0.69012743710534 + 0.68089649943407 + 0.67165230556918 + 0.66210792929282 + 0.65211987917455 + 0.64168014752366 + 0.63078674192626 + 0.61946781949278 + 0.60775948587311 + 0.59570367220380 + 0.58334658396545 + 0.57073772934089 + 0.55792760000200 + 0.54493748007440 + 0.53181702670825 + 0.51861654671974 + 0.50538477858547 + 0.49216588055877 + 0.47899613292672 + 0.46588536151551 + 0.45282659680721 + 0.43981231765997 + 0.42682149399569 + 0.41382166322138 + 0.87015719791040 + 0.87015722952174 + 0.87015723476223 + 0.87015724087362 + 0.87015724799849 + 0.87015725630643 + 0.87015726599510 + 0.87015727729444 + 0.87015729048322 + 0.87015730593136 + 0.87015732423133 + 0.87015734632868 + 0.87015737335970 + 0.87015740656737 + 0.87015744739897 + 0.87015749762519 + 0.87015755941601 + 0.87015763544163 + 0.87015772909740 + 0.87015784472224 + 0.87015798753576 + 0.87015816403036 + 0.87015838227526 + 0.87015865230826 + 0.87015898678619 + 0.87015940256406 + 0.87015992384997 + 0.87016058271166 + 0.87016141792174 + 0.87016247749703 + 0.87016382600083 + 0.87016554500664 + 0.87016773846072 + 0.87017053991735 + 0.87017412110488 + 0.87017870294940 + 0.87018456988622 + 0.87019208834261 + 0.87020174272185 + 0.87021417630764 + 0.87023021507538 + 0.87025093894908 + 0.87027775518999 + 0.87031239695789 + 0.87035632727789 + 0.87041028362570 + 0.87047577524322 + 0.87055446408496 + 0.87064646308485 + 0.87075265528755 + 0.87087581902917 + 0.87101989992151 + 0.87119003087695 + 0.87139286423864 + 0.87163729914543 + 0.87193486594180 + 0.87230038757464 + 0.87275339113759 + 0.87331977989480 + 0.87403440800307 + 0.87494639255547 + 0.87613043875994 + 0.87769478359127 + 0.87978707193299 + 0.88261872499096 + 0.88651093749198 + 0.89197483691594 + 0.89989406603456 + 0.91201283879401 + 0.93278533175067 + 1.00000000000000 + 0.92341344109400 + 0.88776190793736 + 0.85847921362385 + 0.83206799738600 + 0.80736239525493 + 0.78392806086313 + 0.77263024178143 + 0.76160504086028 + 0.75084668192725 + 0.74034789357656 + 0.73009785956004 + 0.72008082219828 + 0.71027536665640 + 0.70065452402893 + 0.69118668898878 + 0.68183325386619 + 0.67248347134666 + 0.66284517834656 + 0.65277226241990 + 0.64225575603050 + 0.63129290527437 + 0.61991138031018 + 0.60814684330444 + 0.59604078868814 + 0.58363897764990 + 0.57099046841461 + 0.55814530349504 + 0.54512426984865 + 0.53197664635749 + 0.51875239852527 + 0.50549995793195 + 0.49226320204935 + 0.47907814625290 + 0.46595434531591 + 0.45288456768734 + 0.43986104910629 + 0.42686252123020 + 0.41385629168763 + 0.85513122338249 + 0.85513125202697 + 0.85513125677612 + 0.85513126231300 + 0.85513126876811 + 0.85513127629500 + 0.85513128507117 + 0.85513129530744 + 0.85513130725534 + 0.85513132124652 + 0.85513133782214 + 0.85513135784527 + 0.85513138235063 + 0.85513141246940 + 0.85513144952446 + 0.85513149512653 + 0.85513155125434 + 0.85513162033986 + 0.85513170548715 + 0.85513181064502 + 0.85513194057982 + 0.85513210121932 + 0.85513229991314 + 0.85513254582242 + 0.85513285048982 + 0.85513322929722 + 0.85513370435709 + 0.85513430498182 + 0.85513506658917 + 0.85513603300497 + 0.85513726319370 + 0.85513883159696 + 0.85514083302505 + 0.85514338922565 + 0.85514665663874 + 0.85515083635922 + 0.85515618703691 + 0.85516304154056 + 0.85517183954101 + 0.85518316443771 + 0.85519776410413 + 0.85521661492409 + 0.85524098701869 + 0.85527243929339 + 0.85531226432310 + 0.85536106411922 + 0.85542012660215 + 0.85549084594599 + 0.85557315191452 + 0.85566763705741 + 0.85577656720906 + 0.85590318481063 + 0.85605169394803 + 0.85622751999124 + 0.85643790745787 + 0.85669218979956 + 0.85700228198279 + 0.85738379525385 + 0.85785731463199 + 0.85845036724168 + 0.85920160679039 + 0.86016986409579 + 0.86143955627731 + 0.86312324926286 + 0.86537793397208 + 0.86843441307643 + 0.87264248421023 + 0.87856371348673 + 0.88717758859973 + 0.90043885389014 + 0.92341344109400 + 1.00000000000000 + 0.91297590894553 + 0.87392073993101 + 0.84249100166095 + 0.81468655149526 + 0.78917613645567 + 0.77709249019133 + 0.76540877935884 + 0.75409746635102 + 0.74313403341329 + 0.73249360194804 + 0.72214869197277 + 0.71206794708814 + 0.70221585558512 + 0.69255341116710 + 0.68303553256091 + 0.67354500848333 + 0.66378241788033 + 0.65359794398204 + 0.64298115101101 + 0.63192812318472 + 0.62046576042747 + 0.60862903648181 + 0.59645878547131 + 0.58400011388192 + 0.57130143099986 + 0.55841214308869 + 0.54535235255858 + 0.53217081284728 + 0.51891701914829 + 0.50563898378634 + 0.49238020471369 + 0.47917634372699 + 0.46603660012821 + 0.45295340261843 + 0.43991867393425 + 0.42691084174155 + 0.41389692265944 + 0.83912518301196 + 0.83912520886660 + 0.83912521315368 + 0.83912521815017 + 0.83912522397436 + 0.83912523076658 + 0.83912523868538 + 0.83912524792103 + 0.83912525870043 + 0.83912527132222 + 0.83912528628184 + 0.83912530435470 + 0.83912532648507 + 0.83912535369981 + 0.83912538720089 + 0.83912542845215 + 0.83912547924764 + 0.83912554180272 + 0.83912561893209 + 0.83912571423589 + 0.83912583204739 + 0.83912597775142 + 0.83912615803483 + 0.83912638123581 + 0.83912665785188 + 0.83912700187658 + 0.83912743346155 + 0.83912797933511 + 0.83912867176481 + 0.83912955067735 + 0.83913066977794 + 0.83913209687305 + 0.83913391825181 + 0.83913624468831 + 0.83913921841921 + 0.83914302215450 + 0.83914789069851 + 0.83915412592753 + 0.83916212630303 + 0.83917242010653 + 0.83918568354204 + 0.83920279819704 + 0.83922490899232 + 0.83925341649029 + 0.83928946172199 + 0.83933353234048 + 0.83938672531234 + 0.83945020634021 + 0.83952376428083 + 0.83960775835474 + 0.83970402500146 + 0.83981521626414 + 0.83994475873685 + 0.84009705451541 + 0.84027797215187 + 0.84049502753395 + 0.84075774513197 + 0.84107853810278 + 0.84147368223073 + 0.84196482407727 + 0.84258230452627 + 0.84337246914457 + 0.84440135548513 + 0.84575531022809 + 0.84755224286479 + 0.84996134828096 + 0.85323027311788 + 0.85773731091076 + 0.86409423695213 + 0.87337765806008 + 0.88776190793736 + 0.91297590894553 + 1.00000000000000 + 0.90135136741722 + 0.85888363368780 + 0.82552626017882 + 0.79665280380330 + 0.78335696826274 + 0.77068077665965 + 0.75855196371279 + 0.74691272619925 + 0.73571246968663 + 0.72490324957634 + 0.71443703609457 + 0.70426447585267 + 0.69433491507217 + 0.68459333754843 + 0.67491297165478 + 0.66498410256396 + 0.65465154811123 + 0.64390257781057 + 0.63273147079630 + 0.62116389865037 + 0.60923375991811 + 0.59698088485434 + 0.58444941032004 + 0.57168680537508 + 0.55874157125807 + 0.54563286267602 + 0.53240870120837 + 0.51911793255918 + 0.50580799516164 + 0.49252187279956 + 0.47929475400021 + 0.46613536997333 + 0.45303570690440 + 0.43998728268977 + 0.42696813524930 + 0.41394491072899 + 0.82222537342246 + 0.82222539664650 + 0.82222540049621 + 0.82222540498307 + 0.82222541021597 + 0.82222541631437 + 0.82222542342547 + 0.82222543171676 + 0.82222544139498 + 0.82222545273049 + 0.82222546616124 + 0.82222548239680 + 0.82222550228930 + 0.82222552676587 + 0.82222555691627 + 0.82222559405905 + 0.82222563982666 + 0.82222569621682 + 0.82222576578467 + 0.82222585178652 + 0.82222595815445 + 0.82222608976327 + 0.82222625268428 + 0.82222645446422 + 0.82222670462973 + 0.82222701587126 + 0.82222740649542 + 0.82222790080163 + 0.82222852810580 + 0.82222932466965 + 0.82223033929832 + 0.82223163357793 + 0.82223328586062 + 0.82223539668433 + 0.82223809508194 + 0.82224154670084 + 0.82224596425024 + 0.82225162095904 + 0.82225887723420 + 0.82226821058014 + 0.82228023132954 + 0.82229573417025 + 0.82231574952408 + 0.82234153391340 + 0.82237409345951 + 0.82241381968563 + 0.82246164491828 + 0.82251854032255 + 0.82258418945639 + 0.82265876667634 + 0.82274375005608 + 0.82284129748925 + 0.82295418682643 + 0.82308596945197 + 0.82324137283383 + 0.82342641287696 + 0.82364865296604 + 0.82391789735858 + 0.82424692975908 + 0.82465266767637 + 0.82515881593864 + 0.82580181336862 + 0.82663331926040 + 0.82771968181297 + 0.82914990762213 + 0.83104935785298 + 0.83359677874792 + 0.83705565175079 + 0.84183083283278 + 0.84858161394708 + 0.85847921362385 + 0.87392073993101 + 0.90135136741722 + 1.00000000000000 + 0.88848555048112 + 0.84276328855962 + 0.80780833606147 + 0.79249953904593 + 0.77823492839892 + 0.76483546119582 + 0.75217062715579 + 0.74013764974404 + 0.72864955628037 + 0.71762816132247 + 0.70700019112739 + 0.69669562528540 + 0.68664346639251 + 0.67670222482354 + 0.66654709115782 + 0.65601484566020 + 0.64508906790955 + 0.63376116195069 + 0.62205480855159 + 0.61000220308259 + 0.59764162951294 + 0.58501577102306 + 0.57217071905686 + 0.55915367406243 + 0.54598246394808 + 0.53270408221771 + 0.51936647051880 + 0.50601627569951 + 0.49269577954755 + 0.47943953184612 + 0.46625564167059 + 0.45313551320612 + 0.44007013559555 + 0.42703704203609 + 0.41400240222988 + 0.80455397672246 + 0.80455399746936 + 0.80455400090847 + 0.80455400491729 + 0.80455400959030 + 0.80455401503794 + 0.80455402139084 + 0.80455402879655 + 0.80455403743982 + 0.80455404756186 + 0.80455405955919 + 0.80455407406828 + 0.80455409185704 + 0.80455411375877 + 0.80455414075540 + 0.80455417403717 + 0.80455421507182 + 0.80455426566331 + 0.80455432811115 + 0.80455440536107 + 0.80455450095984 + 0.80455461931285 + 0.80455476589712 + 0.80455494753716 + 0.80455517283230 + 0.80455545325971 + 0.80455580540438 + 0.80455625127677 + 0.80455681744405 + 0.80455753673820 + 0.80455845339044 + 0.80455962318941 + 0.80456111709874 + 0.80456302615126 + 0.80456546712862 + 0.80456858986920 + 0.80457258666426 + 0.80457770431369 + 0.80458426817837 + 0.80459270907351 + 0.80460357692166 + 0.80461758688582 + 0.80463566491324 + 0.80465893669032 + 0.80468828841599 + 0.80472403117449 + 0.80476695568048 + 0.80481786797167 + 0.80487637581252 + 0.80494250935297 + 0.80501744904483 + 0.80510294097273 + 0.80520122400024 + 0.80531514535419 + 0.80544849014257 + 0.80560604136551 + 0.80579375975070 + 0.80601932824755 + 0.80629270741137 + 0.80662701571932 + 0.80704065475444 + 0.80756216896934 + 0.80823188013905 + 0.80910068996619 + 0.81023581583585 + 0.81173052986916 + 0.81371511886027 + 0.81637654817784 + 0.81999170250447 + 0.82498829233924 + 0.83206799738600 + 0.84249100166095 + 0.85888363368780 + 0.88848555048112 + 1.00000000000000 + 0.87445822738859 + 0.82576550701926 + 0.80666654684661 + 0.78960239728005 + 0.77407012353601 + 0.75974762272952 + 0.74640890845586 + 0.73388264070693 + 0.72203003926064 + 0.71073264102347 + 0.69988569704321 + 0.68939079684409 + 0.67908252580056 + 0.66861292375228 + 0.65780618211468 + 0.64663970935225 + 0.63510016780143 + 0.62320792359795 + 0.61099240906808 + 0.59848947475923 + 0.58573958223941 + 0.57278676974087 + 0.55967633935376 + 0.54642423381052 + 0.53307598471763 + 0.51967826129930 + 0.50627660715106 + 0.49291233591953 + 0.47961912658194 + 0.46640425246257 + 0.45325834396236 + 0.44017169220625 + 0.42712116968051 + 0.41407232663734 + 0.78631106068866 + 0.78631107913097 + 0.78631108218720 + 0.78631108574945 + 0.78631108990299 + 0.78631109474464 + 0.78631110038914 + 0.78631110697133 + 0.78631111465104 + 0.78631112364730 + 0.78631113431059 + 0.78631114721141 + 0.78631116304003 + 0.78631118254552 + 0.78631120660580 + 0.78631123629109 + 0.78631127291615 + 0.78631131810398 + 0.78631137392543 + 0.78631144302242 + 0.78631152858996 + 0.78631163459559 + 0.78631176596623 + 0.78631192885031 + 0.78631213099842 + 0.78631238275974 + 0.78631269911097 + 0.78631309994881 + 0.78631360928195 + 0.78631425678763 + 0.78631508245589 + 0.78631613672653 + 0.78631748375170 + 0.78631920581258 + 0.78632140842033 + 0.78632422691422 + 0.78632783487275 + 0.78633245492234 + 0.78633838043371 + 0.78634599964927 + 0.78635580755335 + 0.78636844714163 + 0.78638474978850 + 0.78640572326685 + 0.78643214790954 + 0.78646426808940 + 0.78650275353237 + 0.78654827115628 + 0.78660037700539 + 0.78665899104728 + 0.78672504873079 + 0.78679995575207 + 0.78688550689393 + 0.78698397141105 + 0.78709836255270 + 0.78723245825085 + 0.78739092011943 + 0.78757971961517 + 0.78780655122799 + 0.78808150032673 + 0.78841874947378 + 0.78884056470479 + 0.78937832053918 + 0.79007093701454 + 0.79096905320279 + 0.79214206855423 + 0.79368529892685 + 0.79573266617090 + 0.79847703324719 + 0.80220511994963 + 0.80736239525493 + 0.81468655149526 + 0.82552626017882 + 0.84276328855962 + 0.87445822738859 + 1.00000000000000 + 0.85936382601889 + 0.83102527576340 + 0.80808451825466 + 0.78848412972346 + 0.77120549122896 + 0.75565264915618 + 0.74143416743040 + 0.72826951127414 + 0.71594342677056 + 0.70428201313271 + 0.69313551888521 + 0.68229667409214 + 0.67137983501959 + 0.66018829502747 + 0.64868858444935 + 0.63685917439066 + 0.62471469864297 + 0.61227995685009 + 0.59958685920377 + 0.58667238825252 + 0.57357745835253 + 0.56034455260539 + 0.54698689420302 + 0.53354791006513 + 0.52007245956531 + 0.50660453466046 + 0.49318410301214 + 0.47984364759443 + 0.46658931088049 + 0.45341068734516 + 0.44029714057457 + 0.42722467255980 + 0.41415802311921 + 0.76774819167497 + 0.76774820800062 + 0.76774821070627 + 0.76774821385941 + 0.76774821753637 + 0.76774822182009 + 0.76774822681658 + 0.76774823264194 + 0.76774823943892 + 0.76774824739895 + 0.76774825683787 + 0.76774826826554 + 0.76774828229664 + 0.76774829960163 + 0.76774832096802 + 0.76774834735136 + 0.76774837992917 + 0.76774842015555 + 0.76774846988621 + 0.76774853149595 + 0.76774860785027 + 0.76774870251342 + 0.76774881991605 + 0.76774896558059 + 0.76774914647963 + 0.76774937193092 + 0.76774965543864 + 0.76775001496726 + 0.76775047218756 + 0.76775105388582 + 0.76775179618291 + 0.76775274464746 + 0.76775395722507 + 0.76775550822983 + 0.76775749294979 + 0.76776003356491 + 0.76776328670316 + 0.76776745315149 + 0.76777279739380 + 0.76777966929214 + 0.76778851442113 + 0.76779991099970 + 0.76781460569393 + 0.76783350112139 + 0.76785728502027 + 0.76788614706092 + 0.76792065456907 + 0.76796135839744 + 0.76800778221754 + 0.76805976411795 + 0.76811804023284 + 0.76818373809662 + 0.76825829080914 + 0.76834349879324 + 0.76844175048748 + 0.76855601425503 + 0.76868991143089 + 0.76884804926696 + 0.76903632478383 + 0.76926242893919 + 0.76953722104849 + 0.76987801158233 + 0.77030915178374 + 0.77086029595346 + 0.77156946338746 + 0.77248819342959 + 0.77368624253983 + 0.77525992084375 + 0.77734486139641 + 0.78013683505067 + 0.78392806086313 + 0.78917613645567 + 0.79665280380330 + 0.80780833606147 + 0.82576550701926 + 0.85936382601889 + 1.00000000000000 + 0.88545222733440 + 0.84326947301767 + 0.81357023553365 + 0.78998266586576 + 0.77014482771085 + 0.75287218074484 + 0.73746180855555 + 0.72344775212391 + 0.71049558026161 + 0.69834649773205 + 0.68671198105350 + 0.67513963371407 + 0.66339520746853 + 0.65142469580337 + 0.63919154759315 + 0.62669998016875 + 0.61396668673822 + 0.60101695875504 + 0.58788215884577 + 0.57459832367759 + 0.56120365917930 + 0.54770739414011 + 0.53414988032279 + 0.52057337136679 + 0.50701965491606 + 0.49352681153432 + 0.48012566969894 + 0.46682083184390 + 0.45360049755689 + 0.44045279151064 + 0.42735256333949 + 0.41426348779976 + 0.75842380083074 + 0.75842381617154 + 0.75842381871403 + 0.75842382167701 + 0.75842382513096 + 0.75842382915798 + 0.75842383385165 + 0.75842383932498 + 0.75842384571110 + 0.75842385319122 + 0.75842386206127 + 0.75842387280344 + 0.75842388599960 + 0.75842390228080 + 0.75842392239171 + 0.75842394723659 + 0.75842397793001 + 0.75842401584813 + 0.75842406274278 + 0.75842412086716 + 0.75842419293267 + 0.75842428231506 + 0.75842439321472 + 0.75842453086293 + 0.75842470187028 + 0.75842491507548 + 0.75842518329720 + 0.75842552360172 + 0.75842595657084 + 0.75842650765351 + 0.75842721117289 + 0.75842811043708 + 0.75842926051285 + 0.75843073203229 + 0.75843261554984 + 0.75843502716032 + 0.75843811568042 + 0.75844207181387 + 0.75844714674451 + 0.75845367267407 + 0.75846207247513 + 0.75847289465040 + 0.75848684706587 + 0.75850478431667 + 0.75852735246172 + 0.75855471779808 + 0.75858740271430 + 0.75862590773240 + 0.75866974633448 + 0.75871872472202 + 0.75877349444274 + 0.75883506451666 + 0.75890471439532 + 0.75898404601045 + 0.75907518373792 + 0.75918075518893 + 0.75930394602039 + 0.75944879427998 + 0.75962044990245 + 0.75982561217970 + 0.76007376540577 + 0.76038016285590 + 0.76076624905573 + 0.76125788447494 + 0.76188797596947 + 0.76270090611981 + 0.76375633825193 + 0.76513600440013 + 0.76695389042690 + 0.76937246429530 + 0.77263024178143 + 0.77709249019133 + 0.78335696826274 + 0.79249953904593 + 0.80666654684661 + 0.83102527576340 + 0.88545222733440 + 1.00000000000000 + 0.87846714828112 + 0.83492123556582 + 0.80465930402383 + 0.78086330660060 + 0.76100169077741 + 0.74379951151524 + 0.72849881663199 + 0.71459780317249 + 0.70173342429442 + 0.68954552884658 + 0.67752737870229 + 0.66541409759760 + 0.65313450400854 + 0.64063982214351 + 0.62792591004482 + 0.61500315846964 + 0.60189188249988 + 0.58861935221531 + 0.57521815033878 + 0.56172352545745 + 0.54814201567172 + 0.53451191378117 + 0.52087375057258 + 0.50726787263110 + 0.49373114023462 + 0.48029332351619 + 0.46695805177992 + 0.45371265103267 + 0.44054447503772 + 0.42742766135268 + 0.41432523029816 + 0.74911393510396 + 0.74911394951287 + 0.74911395189978 + 0.74911395468264 + 0.74911395792672 + 0.74911396170786 + 0.74911396611663 + 0.74911397125735 + 0.74911397725574 + 0.74911398428092 + 0.74911399261143 + 0.74911400270575 + 0.74911401510909 + 0.74911403042263 + 0.74911404934561 + 0.74911407273673 + 0.74911410164566 + 0.74911413737404 + 0.74911418158599 + 0.74911423640624 + 0.74911430441035 + 0.74911438878915 + 0.74911449352193 + 0.74911462357557 + 0.74911478521229 + 0.74911498681085 + 0.74911524055162 + 0.74911556263638 + 0.74911597262901 + 0.74911649469735 + 0.74911716147527 + 0.74911801412215 + 0.74911910499268 + 0.74912050122212 + 0.74912228890090 + 0.74912457837673 + 0.74912751108291 + 0.74913126822089 + 0.74913608842933 + 0.74914228727461 + 0.74915026625175 + 0.74916054591414 + 0.74917379766642 + 0.74919083105995 + 0.74921225343316 + 0.74923821011683 + 0.74926918246335 + 0.74930562538622 + 0.74934704559882 + 0.74939322269530 + 0.74944473276962 + 0.74950247880354 + 0.74956760304009 + 0.74964153060424 + 0.74972615092004 + 0.74982378930460 + 0.74993724627961 + 0.75007005801819 + 0.75022671747813 + 0.75041305394612 + 0.75063734567747 + 0.75091303608059 + 0.75125901607810 + 0.75169783601052 + 0.75225797084606 + 0.75297763734402 + 0.75390787474107 + 0.75511808675997 + 0.75670419463325 + 0.75880135423410 + 0.76160504086028 + 0.76540877935884 + 0.77068077665965 + 0.77823492839892 + 0.78960239728005 + 0.80808451825466 + 0.84326947301767 + 0.87846714828112 + 1.00000000000000 + 0.87121763951878 + 0.82639220953254 + 0.79566116933040 + 0.77173681550201 + 0.75190887600980 + 0.73481052566887 + 0.71963040621733 + 0.70582870215282 + 0.69293249776586 + 0.68035515267403 + 0.66778704018036 + 0.65513165981707 + 0.64232265027562 + 0.62934402447492 + 0.61619747071812 + 0.60289661288478 + 0.58946335457553 + 0.57592584785547 + 0.56231561789080 + 0.54863588166835 + 0.53492240505857 + 0.52121362534124 + 0.50754815343039 + 0.49396139206742 + 0.48048185748898 + 0.46711203629273 + 0.45383823532264 + 0.44064691323641 + 0.42751138491436 + 0.41439391766266 + 0.73984424676562 + 0.73984426029568 + 0.73984426253839 + 0.73984426515089 + 0.73984426819769 + 0.73984427174846 + 0.73984427588682 + 0.73984428071424 + 0.73984428634621 + 0.73984429294119 + 0.73984430076540 + 0.73984431024766 + 0.73984432190527 + 0.73984433630549 + 0.73984435410821 + 0.73984437612557 + 0.73984440335167 + 0.73984443701421 + 0.73984447868975 + 0.73984453039299 + 0.73984459455757 + 0.73984467421042 + 0.73984477312339 + 0.73984489600000 + 0.73984504877808 + 0.73984523941437 + 0.73984547946736 + 0.73984578434014 + 0.73984617261598 + 0.73984666726825 + 0.73984729932034 + 0.73984810791043 + 0.73984914282592 + 0.73985046791317 + 0.73985216503588 + 0.73985433913190 + 0.73985712466931 + 0.73986069390723 + 0.73986527366766 + 0.73987116386457 + 0.73987874589734 + 0.73988851405966 + 0.73990110553898 + 0.73991728769022 + 0.73993763191233 + 0.73996226481402 + 0.73999163032876 + 0.74002614214134 + 0.74006530322917 + 0.74010887137950 + 0.74015735561049 + 0.74021156434700 + 0.74027251774973 + 0.74034148403240 + 0.74042014436272 + 0.74051055696636 + 0.74061518339292 + 0.74073711932419 + 0.74088028270953 + 0.74104974325058 + 0.74125272618257 + 0.74150108859992 + 0.74181148564370 + 0.74220358965123 + 0.74270204645047 + 0.74333977578063 + 0.74416046385101 + 0.74522310062169 + 0.74660852850575 + 0.74842945415597 + 0.75084668192725 + 0.75409746635102 + 0.75855196371279 + 0.76483546119582 + 0.77407012353601 + 0.78848412972346 + 0.81357023553365 + 0.83492123556582 + 0.87121763951878 + 1.00000000000000 + 0.86371408928717 + 0.81770855324887 + 0.78660874953042 + 0.76263344427119 + 0.74288783078904 + 0.72591458180051 + 0.71084701143777 + 0.69702252527157 + 0.68373065766738 + 0.67059355180323 + 0.65747612031871 + 0.64428598922119 + 0.63098999908150 + 0.61757758707990 + 0.60405323160038 + 0.59043170159428 + 0.57673539956343 + 0.56299111735419 + 0.54919793960740 + 0.53538851003413 + 0.52159870775839 + 0.50786504342266 + 0.49422117213276 + 0.48069411976660 + 0.46728502747693 + 0.45397901042185 + 0.44076148591607 + 0.42760481681262 + 0.41447040270737 + 0.73063501181440 + 0.73063502451853 + 0.73063502662365 + 0.73063502907695 + 0.73063503193703 + 0.73063503527138 + 0.73063503915738 + 0.73063504368837 + 0.73063504897733 + 0.73063505516922 + 0.73063506251707 + 0.73063507142402 + 0.73063508237934 + 0.73063509592068 + 0.73063511267026 + 0.73063513339616 + 0.73063515903679 + 0.73063519075779 + 0.73063523004575 + 0.73063527881274 + 0.73063533936149 + 0.73063541456464 + 0.73063550799215 + 0.73063562410847 + 0.73063576854063 + 0.73063594884199 + 0.73063617599776 + 0.73063646464166 + 0.73063683244074 + 0.73063730123643 + 0.73063790053575 + 0.73063866757356 + 0.73063964970856 + 0.73064090768534 + 0.73064251939153 + 0.73064458466230 + 0.73064723141138 + 0.73065062347672 + 0.73065497657160 + 0.73066057588434 + 0.73066778394220 + 0.73067707038337 + 0.73068904029921 + 0.73070442153679 + 0.73072375217351 + 0.73074714213359 + 0.73077500129185 + 0.73080770614270 + 0.73084475863142 + 0.73088589903485 + 0.73093157698742 + 0.73098251684671 + 0.73103963050918 + 0.73110404743289 + 0.73117726484370 + 0.73126110591112 + 0.73135773509986 + 0.73146986322084 + 0.73160090734184 + 0.73175527714915 + 0.73193928267860 + 0.73216339573288 + 0.73244232049414 + 0.73279323595465 + 0.73323749125895 + 0.73380346985597 + 0.73452860508499 + 0.73546310642627 + 0.73667523841433 + 0.73825923870363 + 0.74034789357656 + 0.74313403341329 + 0.74691272619925 + 0.75217062715579 + 0.75974762272952 + 0.77120549122896 + 0.78998266586576 + 0.80465930402383 + 0.82639220953254 + 0.86371408928717 + 1.00000000000000 + 0.85596967937815 + 0.80889930568863 + 0.77753492826233 + 0.75357988905429 + 0.73395350800024 + 0.71710633769934 + 0.70202728991103 + 0.68780053031756 + 0.67393853023601 + 0.66024497658579 + 0.64658771698651 + 0.63290801509656 + 0.61917766609037 + 0.60538840861729 + 0.59154537444848 + 0.57766340562703 + 0.56376321019147 + 0.54983868347106 + 0.53591858177542 + 0.52203563817368 + 0.50822380823094 + 0.49451464220930 + 0.48093338803312 + 0.46747959782405 + 0.45413698971226 + 0.44088976690114 + 0.42770918845169 + 0.41455565247986 + 0.72149998024692 + 0.72149999217709 + 0.72149999415330 + 0.72149999645717 + 0.72149999914366 + 0.72150000227373 + 0.72150000592386 + 0.72150001017869 + 0.72150001514301 + 0.72150002095864 + 0.72150002785916 + 0.72150003622737 + 0.72150004652595 + 0.72150005926076 + 0.72150007502321 + 0.72150009453529 + 0.72150011868843 + 0.72150014858509 + 0.72150018563251 + 0.72150023163987 + 0.72150028879209 + 0.72150035981237 + 0.72150044808252 + 0.72150055783944 + 0.72150069442395 + 0.72150086500697 + 0.72150108002344 + 0.72150135339073 + 0.72150170191357 + 0.72150214636206 + 0.72150271481750 + 0.72150344270980 + 0.72150437511784 + 0.72150556986021 + 0.72150710108078 + 0.72150906380428 + 0.72151157977888 + 0.72151480491365 + 0.72151894447712 + 0.72152426981673 + 0.72153112571408 + 0.72153995867810 + 0.72155134367754 + 0.72156597157047 + 0.72158434953391 + 0.72160657268584 + 0.72163301992089 + 0.72166403424899 + 0.72169911896120 + 0.72173800071342 + 0.72178107670943 + 0.72182899679647 + 0.72188257713254 + 0.72194282485602 + 0.72201107527533 + 0.72208894540242 + 0.72217834037881 + 0.72228163617009 + 0.72240181547366 + 0.72254271717480 + 0.72270985929750 + 0.72291250802041 + 0.72316367034313 + 0.72347837259417 + 0.72387513559706 + 0.72437847047406 + 0.72502050824466 + 0.72584407120922 + 0.72690694553742 + 0.72828817413442 + 0.73009785956004 + 0.73249360194804 + 0.73571246968663 + 0.74013764974404 + 0.74640890845586 + 0.75565264915618 + 0.77014482771085 + 0.78086330660060 + 0.79566116933040 + 0.81770855324887 + 0.85596967937815 + 1.00000000000000 + 0.84800057340131 + 0.79999583104623 + 0.76847116792437 + 0.74459760207244 + 0.72510593814898 + 0.70826022197583 + 0.69277169826161 + 0.67796428440892 + 0.66353954385286 + 0.64930199339364 + 0.63515354653342 + 0.62103990162647 + 0.60693465109911 + 0.59282966716864 + 0.57872969746440 + 0.56464753090099 + 0.55057047699045 + 0.53652240902490 + 0.52253216241365 + 0.50863056517152 + 0.49484661951020 + 0.48120344325437 + 0.46769870519010 + 0.45431448086178 + 0.44103355439838 + 0.42782590242604 + 0.41465076508516 + 0.71244555376555 + 0.71244556497161 + 0.71244556682770 + 0.71244556899195 + 0.71244557151564 + 0.71244557445524 + 0.71244557788366 + 0.71244558187994 + 0.71244558654255 + 0.71244559200566 + 0.71244559848670 + 0.71244560635071 + 0.71244561603475 + 0.71244562801493 + 0.71244564285160 + 0.71244566122714 + 0.71244568398694 + 0.71244571217222 + 0.71244574711767 + 0.71244579053722 + 0.71244584450184 + 0.71244591159357 + 0.71244599502428 + 0.71244609880730 + 0.71244622802079 + 0.71244638946884 + 0.71244659307697 + 0.71244685208188 + 0.71244718247334 + 0.71244760401557 + 0.71244814343801 + 0.71244883447644 + 0.71244972005834 + 0.71245085524551 + 0.71245231064539 + 0.71245417676005 + 0.71245656952556 + 0.71245963738997 + 0.71246357578774 + 0.71246864303808 + 0.71247516725905 + 0.71248357320155 + 0.71249440757702 + 0.71250832657259 + 0.71252580869049 + 0.71254693594984 + 0.71257205908209 + 0.71260149098010 + 0.71263473838837 + 0.71267151779480 + 0.71271218026902 + 0.71275730974252 + 0.71280763791746 + 0.71286406439837 + 0.71292778231732 + 0.71300022843311 + 0.71308308230932 + 0.71317842967031 + 0.71328887805053 + 0.71341777474494 + 0.71356995502586 + 0.71375363879717 + 0.71398036046543 + 0.71426329346263 + 0.71461853987842 + 0.71506731518834 + 0.71563726632380 + 0.71636501444735 + 0.71729962948323 + 0.71850765907768 + 0.72008082219828 + 0.72214869197277 + 0.72490324957634 + 0.72864955628037 + 0.73388264070693 + 0.74143416743040 + 0.75287218074484 + 0.76100169077741 + 0.77173681550201 + 0.78660874953042 + 0.80889930568863 + 0.84800057340131 + 1.00000000000000 + 0.83982608087990 + 0.79103093121721 + 0.75944568579974 + 0.73569314198440 + 0.71621384310403 + 0.69894989259576 + 0.68287083006452 + 0.66749664873707 + 0.65252586732328 + 0.63779741239345 + 0.62321710900517 + 0.60873200920631 + 0.59431534318125 + 0.57995814042548 + 0.56566273041093 + 0.55140796245281 + 0.53721151395735 + 0.52309735056684 + 0.50909244491519 + 0.49522269641150 + 0.48150865839352 + 0.46794575845327 + 0.45451413432014 + 0.44119490679001 + 0.42795655893203 + 0.41475698925448 + 0.70347045291982 + 0.70347046344894 + 0.70347046519387 + 0.70347046722721 + 0.70347046959693 + 0.70347047235981 + 0.70347047558018 + 0.70347047933527 + 0.70347048371673 + 0.70347048884952 + 0.70347049494118 + 0.70347050233325 + 0.70347051144139 + 0.70347052271703 + 0.70347053668806 + 0.70347055400042 + 0.70347057545518 + 0.70347060203738 + 0.70347063501304 + 0.70347067600573 + 0.70347072698249 + 0.70347079038902 + 0.70347086927671 + 0.70347096745463 + 0.70347108974397 + 0.70347124261179 + 0.70347143549815 + 0.70347168100150 + 0.70347199433832 + 0.70347239432339 + 0.70347290641908 + 0.70347356275627 + 0.70347440422921 + 0.70347548329948 + 0.70347686724407 + 0.70347864228906 + 0.70348091889626 + 0.70348383848030 + 0.70348758720652 + 0.70349241112691 + 0.70349862265743 + 0.70350662609486 + 0.70351694156893 + 0.70353019272955 + 0.70354683145011 + 0.70356692818348 + 0.70359080805281 + 0.70361875686837 + 0.70365028668856 + 0.70368510689772 + 0.70372352804490 + 0.70376607584677 + 0.70381340761832 + 0.70386632858409 + 0.70392590728265 + 0.70399342320131 + 0.70407036019884 + 0.70415855317245 + 0.70426028666556 + 0.70437848604315 + 0.70451739979995 + 0.70468434167160 + 0.70488957062480 + 0.70514466889492 + 0.70546367535295 + 0.70586500739454 + 0.70637252825593 + 0.70701766321545 + 0.70784224109137 + 0.70890253898583 + 0.71027536665640 + 0.71206794708814 + 0.71443703609457 + 0.71762816132247 + 0.72203003926064 + 0.72826951127414 + 0.73746180855555 + 0.74379951151524 + 0.75190887600980 + 0.76263344427119 + 0.77753492826233 + 0.79999583104623 + 0.83982608087990 + 1.00000000000000 + 0.83146874824609 + 0.78203720971329 + 0.75047213290102 + 0.72672641014418 + 0.70681488321501 + 0.68895242739336 + 0.67230756772642 + 0.65638971847113 + 0.64093187133202 + 0.62577646089244 + 0.61083046026027 + 0.59604020795401 + 0.58137770021103 + 0.56683121634694 + 0.55236858433789 + 0.53799952816002 + 0.52374186992218 + 0.50961779099732 + 0.49564938685145 + 0.48185410596439 + 0.46822469650446 + 0.45473900126038 + 0.44137618506898 + 0.42810298688149 + 0.41487574723456 + 0.69456607175677 + 0.69456608165488 + 0.69456608329404 + 0.69456608520537 + 0.69456608743289 + 0.69456609003008 + 0.69456609305720 + 0.69456609658636 + 0.69456610070471 + 0.69456610552909 + 0.69456611125639 + 0.69456611820861 + 0.69456612677835 + 0.69456613739374 + 0.69456615055365 + 0.69456616687197 + 0.69456618710455 + 0.69456621218541 + 0.69456624331548 + 0.69456628203440 + 0.69456633020786 + 0.69456639015630 + 0.69456646477760 + 0.69456655769023 + 0.69456667347405 + 0.69456681827678 + 0.69456700107883 + 0.69456723387883 + 0.69456753116004 + 0.69456791084691 + 0.69456839718964 + 0.69456902081444 + 0.69456982068938 + 0.69457084681891 + 0.69457216332859 + 0.69457385241635 + 0.69457601935916 + 0.69457879893088 + 0.69458236854651 + 0.69458696267476 + 0.69459287892658 + 0.69460050230390 + 0.69461032790325 + 0.69462294876602 + 0.69463879198495 + 0.69465791782680 + 0.69468062810281 + 0.69470718426755 + 0.69473710531359 + 0.69477009619586 + 0.69480643193721 + 0.69484658684554 + 0.69489115276148 + 0.69494085214302 + 0.69499664439897 + 0.69505967194910 + 0.69513124912179 + 0.69521299441586 + 0.69530691487639 + 0.69541557451509 + 0.69554271842135 + 0.69569487613986 + 0.69588120261653 + 0.69611191522962 + 0.69639929544317 + 0.69675938823131 + 0.69721286810154 + 0.69778681097725 + 0.69851703322115 + 0.69945136900529 + 0.70065452402893 + 0.70221585558512 + 0.70426447585267 + 0.70700019112739 + 0.71073264102347 + 0.71594342677056 + 0.72344775212391 + 0.72849881663199 + 0.73481052566887 + 0.74288783078904 + 0.75357988905429 + 0.76847116792437 + 0.79103093121721 + 0.83146874824609 + 1.00000000000000 + 0.82295361793754 + 0.77303316380129 + 0.74139417614454 + 0.71718348701362 + 0.69666897796866 + 0.67825195851629 + 0.66107463975557 + 0.64468017242676 + 0.62880506460652 + 0.61329333225759 + 0.59805129661527 + 0.58302388765448 + 0.56818013392864 + 0.55347327033711 + 0.53890267397549 + 0.52447832972400 + 0.51021640898488 + 0.49613430734188 + 0.48224568986181 + 0.46854008425959 + 0.45499260343473 + 0.44158010367151 + 0.42826728091513 + 0.41500866184428 + 0.68571753341369 + 0.68571754271983 + 0.68571754426171 + 0.68571754605889 + 0.68571754815351 + 0.68571755059516 + 0.68571755344158 + 0.68571755675967 + 0.68571756063201 + 0.68571756516740 + 0.68571757055390 + 0.68571757709462 + 0.68571758516245 + 0.68571759516038 + 0.68571760756072 + 0.68571762294669 + 0.68571764203298 + 0.68571766570501 + 0.68571769510236 + 0.68571773168561 + 0.68571777722372 + 0.68571783392368 + 0.68571790453419 + 0.68571799249315 + 0.68571810215585 + 0.68571823936396 + 0.68571841266980 + 0.68571863349366 + 0.68571891563558 + 0.68571927616964 + 0.68571973820511 + 0.68572033093261 + 0.68572109150173 + 0.68572206758778 + 0.68572332033148 + 0.68572492810584 + 0.68572699128386 + 0.68572963835411 + 0.68573303844404 + 0.68573741506675 + 0.68574305181657 + 0.68575031546569 + 0.68575967745721 + 0.68577170197912 + 0.68578679299113 + 0.68580500180465 + 0.68582660896951 + 0.68585185401582 + 0.68588026425684 + 0.68591154255061 + 0.68594593276175 + 0.68598386378419 + 0.68602586976772 + 0.68607260054085 + 0.68612491986870 + 0.68618385064929 + 0.68625056034159 + 0.68632648079803 + 0.68641338072793 + 0.68651351481758 + 0.68663019631855 + 0.68676927554982 + 0.68693895096759 + 0.68714826873698 + 0.68740801316625 + 0.68773221730205 + 0.68813886752472 + 0.68865139709821 + 0.68930062569054 + 0.69012743710534 + 0.69118668898878 + 0.69255341116710 + 0.69433491507217 + 0.69669562528540 + 0.69988569704321 + 0.70428201313271 + 0.71049558026161 + 0.71459780317249 + 0.71963040621733 + 0.72591458180051 + 0.73395350800024 + 0.74459760207244 + 0.75944568579974 + 0.78203720971329 + 0.82295361793754 + 1.00000000000000 + 0.81428954671981 + 0.76382609295357 + 0.73161639184168 + 0.70680139705076 + 0.68576411377889 + 0.66684345609886 + 0.64921240023242 + 0.63241870613905 + 0.61620244536898 + 0.60040805347043 + 0.58494080628678 + 0.56974272939599 + 0.55474736412173 + 0.53994041673450 + 0.52532174489204 + 0.51089990004330 + 0.49668641874902 + 0.48269032139161 + 0.46889724115839 + 0.45527902711013 + 0.44180979922731 + 0.42845185189308 + 0.41515759378481 + 0.67690155803155 + 0.67690156678305 + 0.67690156823349 + 0.67690156992361 + 0.67690157189366 + 0.67690157419011 + 0.67690157686575 + 0.67690157998664 + 0.67690158362804 + 0.67690158789341 + 0.67690159295990 + 0.67690159911452 + 0.67690160670942 + 0.67690161612633 + 0.67690162781484 + 0.67690164232404 + 0.67690166033359 + 0.67690168268099 + 0.67690171044783 + 0.67690174502057 + 0.67690178807635 + 0.67690184171415 + 0.67690190854278 + 0.67690199182997 + 0.67690209571245 + 0.67690222575071 + 0.67690239008441 + 0.67690259958923 + 0.67690286741101 + 0.67690320981446 + 0.67690364883077 + 0.67690421228205 + 0.67690493559086 + 0.67690586421670 + 0.67690705646093 + 0.67690858706166 + 0.67691055173031 + 0.67691307298278 + 0.67691631207408 + 0.67692048210077 + 0.67692585336270 + 0.67693277532739 + 0.67694169701839 + 0.67695315530997 + 0.67696753249910 + 0.67698487202240 + 0.67700543497570 + 0.67702944108775 + 0.67705642719734 + 0.67708609606253 + 0.67711866418878 + 0.67715452021977 + 0.67719414735305 + 0.67723813151064 + 0.67728725240211 + 0.67734242843923 + 0.67740469956215 + 0.67747533629178 + 0.67755590222340 + 0.67764838673843 + 0.67775573173767 + 0.67788319742005 + 0.67803815093669 + 0.67822863067901 + 0.67846414230998 + 0.67875700822371 + 0.67912294258842 + 0.67958231898768 + 0.68016179103348 + 0.68089649943407 + 0.68183325386619 + 0.68303553256091 + 0.68459333754843 + 0.68664346639251 + 0.68939079684409 + 0.69313551888521 + 0.69834649773205 + 0.70173342429442 + 0.70582870215282 + 0.71084701143777 + 0.71710633769934 + 0.72510593814898 + 0.73569314198440 + 0.75047213290102 + 0.77303316380129 + 0.81428954671981 + 1.00000000000000 + 0.80518713556162 + 0.75367870801515 + 0.72084871442713 + 0.69558224534696 + 0.67410481703990 + 0.65477657226285 + 0.63677871425663 + 0.61966814314366 + 0.60318874561282 + 0.58718548782308 + 0.57156141030213 + 0.55622285788289 + 0.54113713458122 + 0.52629080802623 + 0.51168264260689 + 0.49731679093183 + 0.48319651898800 + 0.46930271409046 + 0.45560329786917 + 0.44206912921486 + 0.42865966635498 + 0.41532483501042 + 0.66802437278482 + 0.66802438101085 + 0.66802438237432 + 0.66802438396259 + 0.66802438581487 + 0.66802438797297 + 0.66802439048838 + 0.66802439342234 + 0.66802439684403 + 0.66802440085394 + 0.66802440561685 + 0.66802441140520 + 0.66802441855145 + 0.66802442741842 + 0.66802443842923 + 0.66802445210610 + 0.66802446908963 + 0.66802449017736 + 0.66802451639141 + 0.66802454904713 + 0.66802458973886 + 0.66802464045481 + 0.66802470367423 + 0.66802478249884 + 0.66802488086128 + 0.66802500404903 + 0.66802515979864 + 0.66802535846968 + 0.66802561257639 + 0.66802593760654 + 0.66802635454963 + 0.66802688990892 + 0.66802757744592 + 0.66802846048103 + 0.66802959458828 + 0.66803105099836 + 0.66803292093510 + 0.66803532115699 + 0.66803840534245 + 0.66804237656545 + 0.66804749232748 + 0.66805408546158 + 0.66806258345026 + 0.66807349696258 + 0.66808718773655 + 0.66810369221450 + 0.66812325346044 + 0.66814607310505 + 0.66817169863921 + 0.66819983447213 + 0.66823067281987 + 0.66826456624077 + 0.66830195236960 + 0.66834336023784 + 0.66838949478581 + 0.66844118201064 + 0.66849934987704 + 0.66856512789700 + 0.66863990121930 + 0.66872542916647 + 0.66882433067462 + 0.66894134687799 + 0.66908311351325 + 0.66925679163356 + 0.66947078235881 + 0.66973593697485 + 0.67006602696643 + 0.67047882610643 + 0.67099747330489 + 0.67165230556918 + 0.67248347134666 + 0.67354500848333 + 0.67491297165478 + 0.67670222482354 + 0.67908252580056 + 0.68229667409214 + 0.68671198105350 + 0.68954552884658 + 0.69293249776586 + 0.69702252527157 + 0.70202728991103 + 0.70826022197583 + 0.71621384310403 + 0.72672641014418 + 0.74139417614454 + 0.76382609295357 + 0.80518713556162 + 1.00000000000000 + 0.79480825682734 + 0.74240866447281 + 0.70922796269183 + 0.68362833735312 + 0.66181700163823 + 0.64216766468998 + 0.62388266593564 + 0.60653037118290 + 0.58985881284413 + 0.57371223992489 + 0.55795806297274 + 0.54253805070515 + 0.52742086029537 + 0.51259238378801 + 0.49804726623823 + 0.48378150369083 + 0.46977009544516 + 0.45597615814320 + 0.44236660372965 + 0.42889749222886 + 0.41551579851047 + 0.65881557185352 + 0.65881557956679 + 0.65881558084387 + 0.65881558233290 + 0.65881558406884 + 0.65881558609226 + 0.65881558845069 + 0.65881559120086 + 0.65881559440952 + 0.65881559816943 + 0.65881560263507 + 0.65881560806464 + 0.65881561477235 + 0.65881562309950 + 0.65881563344595 + 0.65881564630486 + 0.65881566228160 + 0.65881568212981 + 0.65881570681578 + 0.65881573758625 + 0.65881577594791 + 0.65881582378199 + 0.65881588343969 + 0.65881595786018 + 0.65881605076882 + 0.65881616717902 + 0.65881631443764 + 0.65881650238135 + 0.65881674289388 + 0.65881705069112 + 0.65881744571653 + 0.65881795317374 + 0.65881860514867 + 0.65881944283434 + 0.65882051907209 + 0.65882190159541 + 0.65882367714740 + 0.65882595673987 + 0.65882888648695 + 0.65883265945060 + 0.65883752037534 + 0.65884378550388 + 0.65885186085166 + 0.65886223102751 + 0.65887523752117 + 0.65889091036865 + 0.65890947530543 + 0.65893111682813 + 0.65895539452227 + 0.65898201614902 + 0.65901115166887 + 0.65904312019732 + 0.65907831728869 + 0.65911721965654 + 0.65916046355757 + 0.65920879059674 + 0.65926302733652 + 0.65932417624583 + 0.65939346251294 + 0.65947243998233 + 0.65956343800252 + 0.65967072624186 + 0.65980027589614 + 0.65995846021572 + 0.66015269698739 + 0.66039253389029 + 0.66069003143013 + 0.66106068794252 + 0.66152458801831 + 0.66210792929282 + 0.66284517834656 + 0.66378241788033 + 0.66498410256396 + 0.66654709115782 + 0.66861292375228 + 0.67137983501959 + 0.67513963371407 + 0.67752737870229 + 0.68035515267403 + 0.68373065766738 + 0.68780053031756 + 0.69277169826161 + 0.69894989259576 + 0.70681488321501 + 0.71718348701362 + 0.73161639184168 + 0.75367870801515 + 0.79480825682734 + 1.00000000000000 + 0.78364225333615 + 0.73064191111789 + 0.69718131418927 + 0.67130067847970 + 0.64919058633347 + 0.62925896376685 + 0.61073088637256 + 0.59318377033148 + 0.57636631660530 + 0.56008648741702 + 0.54424853944665 + 0.52879569821923 + 0.51369607806487 + 0.49893150270497 + 0.48448836954653 + 0.47033405716667 + 0.45642555942509 + 0.44272482041989 + 0.42918367098450 + 0.41574544714094 + 0.64913941106764 + 0.64913941826998 + 0.64913941946314 + 0.64913942085397 + 0.64913942247570 + 0.64913942436525 + 0.64913942656775 + 0.64913942913562 + 0.64913943213238 + 0.64913943564317 + 0.64913943981461 + 0.64913944488958 + 0.64913945116182 + 0.64913945895100 + 0.64913946863770 + 0.64913948068172 + 0.64913949565631 + 0.64913951426851 + 0.64913953743086 + 0.64913956631802 + 0.64913960235097 + 0.64913964730485 + 0.64913970339841 + 0.64913977340577 + 0.64913986084960 + 0.64913997046444 + 0.64914010919806 + 0.64914028636026 + 0.64914051320285 + 0.64914080365237 + 0.64914117660156 + 0.64914165592133 + 0.64914227201193 + 0.64914306390484 + 0.64914408167137 + 0.64914538949846 + 0.64914706958891 + 0.64914922712151 + 0.64915200054665 + 0.64915557278322 + 0.64916017564925 + 0.64916610859045 + 0.64917375590352 + 0.64918357588284 + 0.64919588976862 + 0.64921072167184 + 0.64922828041598 + 0.64924873404772 + 0.64927165580833 + 0.64929675849747 + 0.64932419142646 + 0.64935424226907 + 0.64938726714293 + 0.64942369396690 + 0.64946409494812 + 0.64950913352615 + 0.64955954312747 + 0.64961621014209 + 0.64968021432647 + 0.64975292337898 + 0.64983640308309 + 0.64993448821502 + 0.65005253685896 + 0.65019620434352 + 0.65037202020278 + 0.65058836002677 + 0.65085575519311 + 0.65118768279600 + 0.65160153264235 + 0.65211987917455 + 0.65277226241990 + 0.65359794398204 + 0.65465154811123 + 0.65601484566020 + 0.65780618211468 + 0.66018829502747 + 0.66339520746853 + 0.66541409759760 + 0.66778704018036 + 0.67059355180323 + 0.67393853023601 + 0.67796428440892 + 0.68287083006452 + 0.68895242739336 + 0.69666897796866 + 0.70680139705076 + 0.72084871442713 + 0.74240866447281 + 0.78364225333615 + 1.00000000000000 + 0.77219293471529 + 0.71865648882344 + 0.68494148951193 + 0.65877391892187 + 0.63636928631847 + 0.61617494940653 + 0.59743346072217 + 0.57972486059930 + 0.56276020583006 + 0.54638559496297 + 0.53050643488876 + 0.51506526920706 + 0.50002599176465 + 0.48536190431079 + 0.47103022453516 + 0.45697992922537 + 0.44316655070816 + 0.42953653234503 + 0.41602862396783 + 0.63898978192345 + 0.63898978862165 + 0.63898978973190 + 0.63898979102495 + 0.63898979253284 + 0.63898979429071 + 0.63898979633906 + 0.63898979872762 + 0.63898980151393 + 0.63898980477914 + 0.63898980865996 + 0.63898981338197 + 0.63898981922247 + 0.63898982648065 + 0.63898983551118 + 0.63898984674790 + 0.63898986072559 + 0.63898987810945 + 0.63898989975494 + 0.63898992676532 + 0.63898996047461 + 0.63899000255567 + 0.63899005509104 + 0.63899012069143 + 0.63899020266766 + 0.63899030548017 + 0.63899043567747 + 0.63899060203374 + 0.63899081515774 + 0.63899108818753 + 0.63899143894589 + 0.63899188996339 + 0.63899246993027 + 0.63899321569555 + 0.63899417452835 + 0.63899540702884 + 0.63899699080101 + 0.63899902513569 + 0.63900164073070 + 0.63900501025269 + 0.63900935245609 + 0.63901494983416 + 0.63902216477403 + 0.63903142905641 + 0.63904304373579 + 0.63905702748396 + 0.63907357267268 + 0.63909283159270 + 0.63911439262927 + 0.63913797519748 + 0.63916370952535 + 0.63919185378615 + 0.63922272721434 + 0.63925671227510 + 0.63929432154984 + 0.63933614613934 + 0.63938283403020 + 0.63943516564002 + 0.63949408859579 + 0.63956080199377 + 0.63963713170416 + 0.63972651121740 + 0.63983373306552 + 0.63996379841879 + 0.64012243448802 + 0.64031696288375 + 0.64055654784057 + 0.64085286959570 + 0.64122093728238 + 0.64168014752366 + 0.64225575603050 + 0.64298115101101 + 0.64390257781057 + 0.64508906790955 + 0.64663970935225 + 0.64868858444935 + 0.65142469580337 + 0.65313450400854 + 0.65513165981707 + 0.65747612031871 + 0.66024497658579 + 0.66353954385286 + 0.66749664873707 + 0.67230756772642 + 0.67825195851629 + 0.68576411377889 + 0.69558224534696 + 0.70922796269183 + 0.73064191111789 + 0.77219293471529 + 1.00000000000000 + 0.76044533152681 + 0.70650282075475 + 0.67253680122366 + 0.64607305563175 + 0.62338280847153 + 0.60294993665511 + 0.58402540891755 + 0.56615048441465 + 0.54907603943899 + 0.53264876650999 + 0.51677311825092 + 0.50138717871349 + 0.48644594868163 + 0.47189282733118 + 0.45766612030728 + 0.44371296993694 + 0.42997287775216 + 0.41637875829654 + 0.62836612441048 + 0.62836613061219 + 0.62836613164002 + 0.62836613283748 + 0.62836613423283 + 0.62836613586025 + 0.62836613775615 + 0.62836613996782 + 0.62836614254710 + 0.62836614556974 + 0.62836614916381 + 0.62836615353896 + 0.62836615895263 + 0.62836616568554 + 0.62836617406887 + 0.62836618450480 + 0.62836619749596 + 0.62836621366171 + 0.62836623380156 + 0.62836625894952 + 0.62836629035402 + 0.62836632957581 + 0.62836637857036 + 0.62836643978044 + 0.62836651630928 + 0.62836661233880 + 0.62836673401235 + 0.62836688957061 + 0.62836708897853 + 0.62836734456990 + 0.62836767309990 + 0.62836809574146 + 0.62836863947029 + 0.62836933892280 + 0.62837023855413 + 0.62837139533993 + 0.62837288225790 + 0.62837479266209 + 0.62837724943967 + 0.62838041492504 + 0.62838449473254 + 0.62838975428962 + 0.62839653395409 + 0.62840523890205 + 0.62841615012309 + 0.62842928134480 + 0.62844480898355 + 0.62846287031591 + 0.62848307023100 + 0.62850513625009 + 0.62852918103020 + 0.62855543516324 + 0.62858418346919 + 0.62861576620235 + 0.62865064052652 + 0.62868933076491 + 0.62873240669092 + 0.62878055217566 + 0.62883459501500 + 0.62889558181865 + 0.62896512026414 + 0.62904627391791 + 0.62914331422688 + 0.62926064705715 + 0.62940327585068 + 0.62957757548767 + 0.62979148900028 + 0.63005510014889 + 0.63038131512871 + 0.63078674192626 + 0.63129290527437 + 0.63192812318472 + 0.63273147079630 + 0.63376116195069 + 0.63510016780143 + 0.63685917439066 + 0.63919154759315 + 0.64063982214351 + 0.64232265027562 + 0.64428598922119 + 0.64658771698651 + 0.64930199339364 + 0.65252586732328 + 0.65638971847113 + 0.66107463975557 + 0.66684345609886 + 0.67410481703990 + 0.68362833735312 + 0.69718131418927 + 0.71865648882344 + 0.76044533152681 + 1.00000000000000 + 0.74852168920652 + 0.69424208400369 + 0.66000320194810 + 0.63323169478974 + 0.61026822737536 + 0.58962108581218 + 0.57050284918300 + 0.55249689562393 + 0.53535362195584 + 0.51891820224090 + 0.50309021654385 + 0.48779832494893 + 0.47296667161132 + 0.45851906913644 + 0.44439149396351 + 0.43051437608756 + 0.41681311760167 + 0.61729715600270 + 0.61729716171729 + 0.61729716266436 + 0.61729716376777 + 0.61729716505382 + 0.61729716655258 + 0.61729716830080 + 0.61729717033852 + 0.61729717271555 + 0.61729717550166 + 0.61729717881362 + 0.61729718284812 + 0.61729718784414 + 0.61729719406162 + 0.61729720180654 + 0.61729721145701 + 0.61729722347622 + 0.61729723844127 + 0.61729725709991 + 0.61729728040912 + 0.61729730953559 + 0.61729734593442 + 0.61729739142574 + 0.61729744829044 + 0.61729751942490 + 0.61729760872917 + 0.61729772195135 + 0.61729786678963 + 0.61729805256319 + 0.61729829081442 + 0.61729859721841 + 0.61729899159401 + 0.61729949919204 + 0.61730015244901 + 0.61730099298588 + 0.61730207416088 + 0.61730346430794 + 0.61730525084813 + 0.61730754883872 + 0.61731051028274 + 0.61731432763731 + 0.61731924928046 + 0.61732559356646 + 0.61733373913237 + 0.61734394716727 + 0.61735622694331 + 0.61737073951706 + 0.61738760794324 + 0.61740645481774 + 0.61742701709641 + 0.61744939141026 + 0.61747378268394 + 0.61750044382989 + 0.61752967610294 + 0.61756188545879 + 0.61759753486095 + 0.61763712287770 + 0.61768124587087 + 0.61773062349510 + 0.61778616508484 + 0.61784928069892 + 0.61792269423772 + 0.61801019904334 + 0.61811566162159 + 0.61824343537243 + 0.61839904846055 + 0.61858935758800 + 0.61882303358519 + 0.61911113152039 + 0.61946781949278 + 0.61991138031018 + 0.62046576042747 + 0.62116389865037 + 0.62205480855159 + 0.62320792359795 + 0.62471469864297 + 0.62669998016875 + 0.62792591004482 + 0.62934402447492 + 0.63098999908150 + 0.63290801509656 + 0.63515354653342 + 0.63779741239345 + 0.64093187133202 + 0.64468017242676 + 0.64921240023242 + 0.65477657226285 + 0.66181700163823 + 0.67130067847970 + 0.68494148951193 + 0.70650282075475 + 0.74852168920652 + 1.00000000000000 + 0.73645419061766 + 0.68188469651188 + 0.64734710305687 + 0.62026533349599 + 0.59704649641169 + 0.57616882360202 + 0.55689141188537 + 0.53879540085122 + 0.52162868802674 + 0.50523094475614 + 0.48949161110819 + 0.47430725570635 + 0.45958156424616 + 0.44523537891104 + 0.43118709752413 + 0.41735233321590 + 0.60581949760023 + 0.60581950284124 + 0.60581950370995 + 0.60581950472174 + 0.60581950590198 + 0.60581950727708 + 0.60581950887991 + 0.60581951074826 + 0.60581951292927 + 0.60581951548470 + 0.60581951852346 + 0.60581952222552 + 0.60581952681452 + 0.60581953252935 + 0.60581953965453 + 0.60581954853550 + 0.60581955960591 + 0.60581957339839 + 0.60581959060364 + 0.60581961211388 + 0.60581963900769 + 0.60581967263543 + 0.60581971468785 + 0.60581976728336 + 0.60581983310978 + 0.60581991580030 + 0.60582002069287 + 0.60582015496192 + 0.60582032728364 + 0.60582054840753 + 0.60582083293940 + 0.60582119935381 + 0.60582167118751 + 0.60582227868079 + 0.60582306064511 + 0.60582406683615 + 0.60582536097212 + 0.60582702456633 + 0.60582916490561 + 0.60583192371584 + 0.60583548038602 + 0.60584006636667 + 0.60584597818236 + 0.60585356819931 + 0.60586307816117 + 0.60587451341843 + 0.60588802031787 + 0.60590370855076 + 0.60592121940961 + 0.60594030046732 + 0.60596103382949 + 0.60598360071586 + 0.60600822462028 + 0.60603517099000 + 0.60606479870953 + 0.60609751470560 + 0.60613375308131 + 0.60617403134381 + 0.60621897208500 + 0.60626936173321 + 0.60632643219490 + 0.60639259688229 + 0.60647121254605 + 0.60656565940713 + 0.60667970999332 + 0.60681813895301 + 0.60698684133621 + 0.60719324331470 + 0.60744677759466 + 0.60775948587311 + 0.60814684330444 + 0.60862903648181 + 0.60923375991811 + 0.61000220308259 + 0.61099240906808 + 0.61227995685009 + 0.61396668673822 + 0.61500315846964 + 0.61619747071812 + 0.61757758707990 + 0.61917766609037 + 0.62103990162647 + 0.62321710900517 + 0.62577646089244 + 0.62880506460652 + 0.63241870613905 + 0.63677871425663 + 0.64216766468998 + 0.64919058633347 + 0.65877391892187 + 0.67253680122366 + 0.69424208400369 + 0.73645419061766 + 1.00000000000000 + 0.72427414579838 + 0.66943888810272 + 0.63457811164717 + 0.60719046524511 + 0.58369080941335 + 0.56261595334558 + 0.54322018387953 + 0.52508041074702 + 0.50793802680037 + 0.49162157637575 + 0.47598678963799 + 0.46090863434810 + 0.44628698084151 + 0.43202397815460 + 0.41802229627712 + 0.59397566264818 + 0.59397566743307 + 0.59397566822573 + 0.59397566914976 + 0.59397567022629 + 0.59397567148140 + 0.59397567294453 + 0.59397567465067 + 0.59397567664095 + 0.59397567897371 + 0.59397568174767 + 0.59397568513081 + 0.59397568932595 + 0.59397569455408 + 0.59397570107695 + 0.59397570921438 + 0.59397571936367 + 0.59397573201709 + 0.59397574781219 + 0.59397576757048 + 0.59397579229082 + 0.59397582322027 + 0.59397586192099 + 0.59397591035050 + 0.59397597099706 + 0.59397604722118 + 0.59397614397308 + 0.59397626789765 + 0.59397642704043 + 0.59397663137162 + 0.59397689444343 + 0.59397723339518 + 0.59397767008128 + 0.59397823257274 + 0.59397895690071 + 0.59397988926352 + 0.59398108882999 + 0.59398263128040 + 0.59398461622573 + 0.59398717525274 + 0.59399047486387 + 0.59399472982024 + 0.59400021515587 + 0.59400725738669 + 0.59401607932638 + 0.59402668290682 + 0.59403920049242 + 0.59405372931193 + 0.59406993011410 + 0.59408756208254 + 0.59410669428146 + 0.59412748616838 + 0.59415013427697 + 0.59417487138288 + 0.59420201334863 + 0.59423191621665 + 0.59426495608433 + 0.59430157980232 + 0.59434232336749 + 0.59438786375153 + 0.59443927306247 + 0.59449868220281 + 0.59456905113682 + 0.59465332386660 + 0.59475475654550 + 0.59487745668064 + 0.59502647235317 + 0.59520813869234 + 0.59543047314688 + 0.59570367220380 + 0.59604078868814 + 0.59645878547131 + 0.59698088485434 + 0.59764162951294 + 0.59848947475923 + 0.59958685920377 + 0.60101695875504 + 0.60189188249988 + 0.60289661288478 + 0.60405323160038 + 0.60538840861729 + 0.60693465109911 + 0.60873200920631 + 0.61083046026027 + 0.61329333225759 + 0.61620244536898 + 0.61966814314366 + 0.62388266593564 + 0.62925896376685 + 0.63636928631847 + 0.64607305563175 + 0.66000320194810 + 0.68188469651188 + 0.72427414579838 + 1.00000000000000 + 0.71201112210193 + 0.65691187100465 + 0.62170591139832 + 0.59396951310788 + 0.57022027098671 + 0.54898863059977 + 0.52952166744918 + 0.51138811883793 + 0.49431685369067 + 0.47810055516334 + 0.46257183281667 + 0.44760070406103 + 0.43306689091332 + 0.41885564367689 + 0.58181255230946 + 0.58181255665674 + 0.58181255737684 + 0.58181255821629 + 0.58181255919493 + 0.58181256033546 + 0.58181256166421 + 0.58181256321375 + 0.58181256502255 + 0.58181256714226 + 0.58181256966365 + 0.58181257273969 + 0.58181257655800 + 0.58181258131908 + 0.58181258726323 + 0.58181259468410 + 0.58181260394689 + 0.58181261550287 + 0.58181262993703 + 0.58181264800762 + 0.58181267062825 + 0.58181269894765 + 0.58181273440476 + 0.58181277880115 + 0.58181283442877 + 0.58181290438318 + 0.58181299322950 + 0.58181310710486 + 0.58181325343196 + 0.58181344141888 + 0.58181368358407 + 0.58181399576980 + 0.58181439816570 + 0.58181491672344 + 0.58181558475255 + 0.58181644496715 + 0.58181755206743 + 0.58181897602178 + 0.58182080892625 + 0.58182317242557 + 0.58182622041235 + 0.58183015131666 + 0.58183521914825 + 0.58184172520746 + 0.58184987398240 + 0.58185966447664 + 0.58187121586286 + 0.58188461381319 + 0.58189953908531 + 0.58191576323362 + 0.58193334372115 + 0.58195242013949 + 0.58197316448910 + 0.58199577989188 + 0.58202054311629 + 0.58204776425522 + 0.58207776751603 + 0.58211093680763 + 0.58214773129497 + 0.58218873100647 + 0.58223486538529 + 0.58228800944337 + 0.58235076420240 + 0.58242568423899 + 0.58251556896138 + 0.58262393812790 + 0.58275509749997 + 0.58291443035498 + 0.58310872516105 + 0.58334658396545 + 0.58363897764990 + 0.58400011388192 + 0.58444941032004 + 0.58501577102306 + 0.58573958223941 + 0.58667238825252 + 0.58788215884577 + 0.58861935221531 + 0.58946335457553 + 0.59043170159428 + 0.59154537444848 + 0.59282966716864 + 0.59431534318125 + 0.59604020795401 + 0.59805129661527 + 0.60040805347043 + 0.60318874561282 + 0.60653037118290 + 0.61073088637256 + 0.61617494940653 + 0.62338280847153 + 0.63323169478974 + 0.64734710305687 + 0.66943888810272 + 0.71201112210193 + 1.00000000000000 + 0.69969197830186 + 0.64430617387882 + 0.60867519528619 + 0.58061641362404 + 0.55665712196994 + 0.53531660128549 + 0.51583089146438 + 0.49775416845655 + 0.48077653941235 + 0.46466551300130 + 0.44924719056451 + 0.43436950721638 + 0.41989375874853 + 0.56938047896499 + 0.56938048289658 + 0.56938048354787 + 0.56938048430689 + 0.56938048519191 + 0.56938048622303 + 0.56938048742511 + 0.56938048882716 + 0.56938049046243 + 0.56938049237952 + 0.56938049466002 + 0.56938049744510 + 0.56938050090270 + 0.56938050521861 + 0.56938051061159 + 0.56938051734928 + 0.56938052576428 + 0.56938053627104 + 0.56938054940343 + 0.56938056585311 + 0.56938058646055 + 0.56938061227596 + 0.56938064461860 + 0.56938068513652 + 0.56938073593307 + 0.56938079985157 + 0.56938088108260 + 0.56938098526376 + 0.56938111921820 + 0.56938129141545 + 0.56938151336608 + 0.56938179964536 + 0.56938216883590 + 0.56938264482132 + 0.56938325826409 + 0.56938404848497 + 0.56938506584315 + 0.56938637475050 + 0.56938805998982 + 0.56939023354566 + 0.56939303704915 + 0.56939665306918 + 0.56940131521794 + 0.56940730035318 + 0.56941479535629 + 0.56942379677790 + 0.56943441141790 + 0.56944671432348 + 0.56946040652785 + 0.56947527253219 + 0.56949135955308 + 0.56950878917466 + 0.56952771116377 + 0.56954830190951 + 0.56957080284308 + 0.56959548278292 + 0.56962261976982 + 0.56965254195794 + 0.56968564069577 + 0.56972241059297 + 0.56976365429615 + 0.56981101602332 + 0.56986677350473 + 0.56993313524034 + 0.57001249850458 + 0.57010786762015 + 0.57022290068210 + 0.57036215419316 + 0.57053135385652 + 0.57073772934089 + 0.57099046841461 + 0.57130143099986 + 0.57168680537508 + 0.57217071905686 + 0.57278676974087 + 0.57357745835253 + 0.57459832367759 + 0.57521815033878 + 0.57592584785547 + 0.57673539956343 + 0.57766340562703 + 0.57872969746440 + 0.57995814042548 + 0.58137770021103 + 0.58302388765448 + 0.58494080628678 + 0.58718548782308 + 0.58985881284413 + 0.59318377033148 + 0.59743346072217 + 0.60294993665511 + 0.61026822737536 + 0.62026533349599 + 0.63457811164717 + 0.65691187100465 + 0.69969197830186 + 1.00000000000000 + 0.68733134933869 + 0.63153502235339 + 0.59549169303686 + 0.56714804490092 + 0.54302715201050 + 0.52163282250032 + 0.50218349331840 + 0.48419062757603 + 0.46731634468124 + 0.45131945679230 + 0.43600135769963 + 0.42118952747292 + 0.55673083208976 + 0.55673083562865 + 0.55673083621493 + 0.55673083689831 + 0.55673083769522 + 0.55673083862380 + 0.55673083970576 + 0.55673084096724 + 0.55673084244029 + 0.55673084416546 + 0.55673084621998 + 0.55673084872939 + 0.55673085184672 + 0.55673085574148 + 0.55673086061116 + 0.55673086670161 + 0.55673087431242 + 0.55673088382169 + 0.55673089571651 + 0.55673091062643 + 0.55673092931689 + 0.55673095274579 + 0.55673098211611 + 0.55673101893466 + 0.55673106511949 + 0.55673112326520 + 0.55673119720840 + 0.55673129210595 + 0.55673141420491 + 0.55673157125199 + 0.55673177379517 + 0.55673203518759 + 0.55673237245324 + 0.55673280748147 + 0.55673336838073 + 0.55673409119190 + 0.55673502208658 + 0.55673622010835 + 0.55673776298185 + 0.55673975336921 + 0.55674232107051 + 0.55674563336611 + 0.55674990421869 + 0.55675538696822 + 0.55676225170544 + 0.55677049296612 + 0.55678020601061 + 0.55679145618732 + 0.55680396483850 + 0.55681752975701 + 0.55683218918486 + 0.55684804845982 + 0.55686523734088 + 0.55688390822956 + 0.55690427076843 + 0.55692655689993 + 0.55695100380562 + 0.55697789048880 + 0.55700754875208 + 0.55704039827484 + 0.55707712949167 + 0.55711917928162 + 0.55716853537218 + 0.55722709997220 + 0.55729691779278 + 0.55738054299041 + 0.55748107085372 + 0.55760234253636 + 0.55774916810123 + 0.55792760000200 + 0.55814530349504 + 0.55841214308869 + 0.55874157125807 + 0.55915367406243 + 0.55967633935376 + 0.56034455260539 + 0.56120365917930 + 0.56172352545745 + 0.56231561789080 + 0.56299111735419 + 0.56376321019147 + 0.56464753090099 + 0.56566273041093 + 0.56683121634694 + 0.56818013392864 + 0.56974272939599 + 0.57156141030213 + 0.57371223992489 + 0.57636631660530 + 0.57972486059930 + 0.58402540891755 + 0.58962108581218 + 0.59704649641169 + 0.60719046524511 + 0.62170591139832 + 0.64430617387882 + 0.68733134933869 + 1.00000000000000 + 0.67479300086951 + 0.61859327940751 + 0.58216669530962 + 0.55358628321149 + 0.52936113002140 + 0.50797309185347 + 0.48859250259736 + 0.47069894581611 + 0.45394268490774 + 0.43805416116000 + 0.42281155250563 + 0.54388615239073 + 0.54388615556132 + 0.54388615608646 + 0.54388615669870 + 0.54388615741227 + 0.54388615824406 + 0.54388615921377 + 0.54388616034424 + 0.54388616166307 + 0.54388616320959 + 0.54388616505036 + 0.54388616730033 + 0.54388617009788 + 0.54388617359613 + 0.54388617797410 + 0.54388618345197 + 0.54388619030357 + 0.54388619887059 + 0.54388620959524 + 0.54388622304560 + 0.54388623992001 + 0.54388626108574 + 0.54388628763531 + 0.54388632093718 + 0.54388636273595 + 0.54388641539239 + 0.54388648239525 + 0.54388656844425 + 0.54388667923083 + 0.54388682181653 + 0.54388700581890 + 0.54388724341295 + 0.54388755013407 + 0.54388794595354 + 0.54388845652119 + 0.54388911473491 + 0.54388996273148 + 0.54389105440801 + 0.54389246070561 + 0.54389427533197 + 0.54389661673829 + 0.54389963753664 + 0.54390353285019 + 0.54390853351970 + 0.54391479368437 + 0.54392230625724 + 0.54393115579930 + 0.54394139883014 + 0.54395277684793 + 0.54396510110703 + 0.54397840203379 + 0.54399277036925 + 0.54400831790882 + 0.54402517559726 + 0.54404352457513 + 0.54406356391952 + 0.54408549475725 + 0.54410955289067 + 0.54413601797309 + 0.54416524412955 + 0.54419782266702 + 0.54423500451831 + 0.54427851773573 + 0.54432999394158 + 0.54439116932096 + 0.54446420557358 + 0.54455170978107 + 0.54465690514599 + 0.54478381396352 + 0.54493748007440 + 0.54512426984865 + 0.54535235255858 + 0.54563286267602 + 0.54598246394808 + 0.54642423381052 + 0.54698689420302 + 0.54770739414011 + 0.54814201567172 + 0.54863588166835 + 0.54919793960740 + 0.54983868347106 + 0.55057047699045 + 0.55140796245281 + 0.55236858433789 + 0.55347327033711 + 0.55474736412173 + 0.55622285788289 + 0.55795806297274 + 0.56008648741702 + 0.56276020583006 + 0.56615048441465 + 0.57050284918300 + 0.57616882360202 + 0.58369080941335 + 0.59396951310788 + 0.60867519528619 + 0.63153502235339 + 0.67479300086951 + 1.00000000000000 + 0.66219456398635 + 0.60554623229552 + 0.56875777469054 + 0.53998730037910 + 0.51571548373330 + 0.49436704324831 + 0.47507418901447 + 0.45729947814215 + 0.44065922925602 + 0.42485660903818 + 0.53089692217112 + 0.53089692499869 + 0.53089692546705 + 0.53089692601280 + 0.53089692664951 + 0.53089692739137 + 0.53089692825605 + 0.53089692926399 + 0.53089693044038 + 0.53089693181913 + 0.53089693346144 + 0.53089693546922 + 0.53089693796845 + 0.53089694109609 + 0.53089694501256 + 0.53089694991800 + 0.53089695605842 + 0.53089696374182 + 0.53089697336484 + 0.53089698544576 + 0.53089700060906 + 0.53089701964413 + 0.53089704353474 + 0.53089707352132 + 0.53089711118093 + 0.53089715865101 + 0.53089721909444 + 0.53089729677384 + 0.53089739684864 + 0.53089752573114 + 0.53089769214822 + 0.53089790715868 + 0.53089818487401 + 0.53089854343663 + 0.53089900615593 + 0.53089960292775 + 0.53090037205095 + 0.53090136250670 + 0.53090263877750 + 0.53090428603868 + 0.53090641193005 + 0.53090915510056 + 0.53091269275966 + 0.53091723437336 + 0.53092291904312 + 0.53092973842433 + 0.53093776721332 + 0.53094705395542 + 0.53095735992130 + 0.53096850981011 + 0.53098052729895 + 0.53099349008720 + 0.53100749394520 + 0.53102265073520 + 0.53103911618150 + 0.53105706022713 + 0.53107665236980 + 0.53109809064872 + 0.53112160928437 + 0.53114750534414 + 0.53117628295126 + 0.53120902701773 + 0.53124723410185 + 0.53129229781956 + 0.53134568555733 + 0.53140921834151 + 0.53148508150679 + 0.53157596659755 + 0.53168522074447 + 0.53181702670825 + 0.53197664635749 + 0.53217081284728 + 0.53240870120837 + 0.53270408221771 + 0.53307598471763 + 0.53354791006513 + 0.53414988032279 + 0.53451191378117 + 0.53492240505857 + 0.53538851003413 + 0.53591858177542 + 0.53652240902490 + 0.53721151395735 + 0.53799952816002 + 0.53890267397549 + 0.53994041673450 + 0.54113713458122 + 0.54253805070515 + 0.54424853944665 + 0.54638559496297 + 0.54907603943899 + 0.55249689562393 + 0.55689141188537 + 0.56261595334558 + 0.57022027098671 + 0.58061641362404 + 0.59549169303686 + 0.61859327940751 + 0.66219456398635 + 1.00000000000000 + 0.64954090279896 + 0.59240662249794 + 0.55528950900621 + 0.52638517808099 + 0.50210324893024 + 0.48082053465342 + 0.46164376360292 + 0.44399288647191 + 0.42745087788136 + 0.51781422105190 + 0.51781422356178 + 0.51781422397769 + 0.51781422446217 + 0.51781422502703 + 0.51781422568531 + 0.51781422645252 + 0.51781422734718 + 0.51781422839169 + 0.51781422961596 + 0.51781423107416 + 0.51781423285843 + 0.51781423508082 + 0.51781423786464 + 0.51781424135399 + 0.51781424572637 + 0.51781425120453 + 0.51781425806497 + 0.51781426666364 + 0.51781427746540 + 0.51781429103391 + 0.51781430807736 + 0.51781432948383 + 0.51781435636758 + 0.51781439015095 + 0.51781443276090 + 0.51781448705329 + 0.51781455687593 + 0.51781464689058 + 0.51781476288668 + 0.51781491275947 + 0.51781510650947 + 0.51781535689616 + 0.51781568034056 + 0.51781609793249 + 0.51781663673334 + 0.51781733140589 + 0.51781822629091 + 0.51781937976137 + 0.51782086892468 + 0.51782279121135 + 0.51782527208542 + 0.51782847185245 + 0.51783257983647 + 0.51783772107769 + 0.51784388629537 + 0.51785114116071 + 0.51785952707003 + 0.51786882449137 + 0.51787887136663 + 0.51788968560317 + 0.51790133332883 + 0.51791389611837 + 0.51792746898033 + 0.51794218510935 + 0.51795818879913 + 0.51797562196276 + 0.51799464984983 + 0.51801546734946 + 0.51803832214991 + 0.51806364211124 + 0.51809236467084 + 0.51812578106728 + 0.51816507664892 + 0.51821148581288 + 0.51826653532405 + 0.51833204798245 + 0.51841026007996 + 0.51850394271986 + 0.51861654671974 + 0.51875239852527 + 0.51891701914829 + 0.51911793255918 + 0.51936647051880 + 0.51967826129930 + 0.52007245956531 + 0.52057337136679 + 0.52087375057258 + 0.52121362534124 + 0.52159870775839 + 0.52203563817368 + 0.52253216241365 + 0.52309735056684 + 0.52374186992218 + 0.52447832972400 + 0.52532174489204 + 0.52629080802623 + 0.52742086029537 + 0.52879569821923 + 0.53050643488876 + 0.53264876650999 + 0.53535362195584 + 0.53879540085122 + 0.54322018387953 + 0.54898863059977 + 0.55665712196994 + 0.56714804490092 + 0.58216669530962 + 0.60554623229552 + 0.64954090279896 + 1.00000000000000 + 0.63683485456163 + 0.57919069509290 + 0.54179046810908 + 0.51278819933270 + 0.48853013718827 + 0.46735311010739 + 0.44830697103534 + 0.43076874526286 + 0.50468752000873 + 0.50468752222748 + 0.50468752259565 + 0.50468752302388 + 0.50468752352341 + 0.50468752410505 + 0.50468752478375 + 0.50468752557462 + 0.50468752649780 + 0.50468752757994 + 0.50468752886957 + 0.50468753044849 + 0.50468753241688 + 0.50468753488419 + 0.50468753797907 + 0.50468754186176 + 0.50468754672983 + 0.50468755283006 + 0.50468756048240 + 0.50468757010111 + 0.50468758219291 + 0.50468759739296 + 0.50468761649516 + 0.50468764050037 + 0.50468767068476 + 0.50468770878028 + 0.50468775735071 + 0.50468781985912 + 0.50468790049980 + 0.50468800448440 + 0.50468813892197 + 0.50468831282021 + 0.50468853767840 + 0.50468882829413 + 0.50468920368017 + 0.50468968823655 + 0.50469031322183 + 0.50469111861834 + 0.50469215707523 + 0.50469349813688 + 0.50469522966254 + 0.50469746477586 + 0.50470034795773 + 0.50470404971323 + 0.50470868203411 + 0.50471423498959 + 0.50472076606025 + 0.50472831029801 + 0.50473666662134 + 0.50474568584757 + 0.50475538102526 + 0.50476580810162 + 0.50477703616700 + 0.50478914546051 + 0.50480224935870 + 0.50481646973350 + 0.50483192464402 + 0.50484875106699 + 0.50486711010399 + 0.50488720701723 + 0.50490940337652 + 0.50493450640646 + 0.50496362634489 + 0.50499776739511 + 0.50503796324178 + 0.50508548802936 + 0.50514185477380 + 0.50520891221539 + 0.50528894280181 + 0.50538477858547 + 0.50549995793195 + 0.50563898378634 + 0.50580799516164 + 0.50601627569951 + 0.50627660715106 + 0.50660453466046 + 0.50701965491606 + 0.50726787263110 + 0.50754815343039 + 0.50786504342266 + 0.50822380823094 + 0.50863056517152 + 0.50909244491519 + 0.50961779099732 + 0.51021640898488 + 0.51089990004330 + 0.51168264260689 + 0.51259238378801 + 0.51369607806487 + 0.51506526920706 + 0.51677311825092 + 0.51891820224090 + 0.52162868802674 + 0.52508041074702 + 0.52952166744918 + 0.53531660128549 + 0.54302715201050 + 0.55358628321149 + 0.56875777469054 + 0.59240662249794 + 0.63683485456163 + 1.00000000000000 + 0.62407907426952 + 0.56591825922376 + 0.52825846866200 + 0.49919877858103 + 0.47501974770538 + 0.45397623816670 + 0.43505900815808 + 0.49156170330657 + 0.49156170526173 + 0.49156170558549 + 0.49156170596292 + 0.49156170640261 + 0.49156170691509 + 0.49156170751276 + 0.49156170820966 + 0.49156170902295 + 0.49156170997648 + 0.49156171111277 + 0.49156171250529 + 0.49156171424213 + 0.49156171642149 + 0.49156171915728 + 0.49156172259253 + 0.49156172690184 + 0.49156173230681 + 0.49156173909162 + 0.49156174762751 + 0.49156175836471 + 0.49156177186961 + 0.49156178885387 + 0.49156181021284 + 0.49156183708430 + 0.49156187101927 + 0.49156191431538 + 0.49156197007530 + 0.49156204205857 + 0.49156213494067 + 0.49156225509972 + 0.49156241062145 + 0.49156261183227 + 0.49156287202056 + 0.49156320826968 + 0.49156364250064 + 0.49156420280529 + 0.49156492511779 + 0.49156585675689 + 0.49156706023965 + 0.49156861453364 + 0.49157062129227 + 0.49157321031550 + 0.49157653465768 + 0.49158069429974 + 0.49158567892567 + 0.49159153864299 + 0.49159830292756 + 0.49160578825805 + 0.49161385785975 + 0.49162252073693 + 0.49163182396409 + 0.49164182575817 + 0.49165259353327 + 0.49166422337329 + 0.49167681772141 + 0.49169047418791 + 0.49170530560679 + 0.49172144430019 + 0.49173905939354 + 0.49175845525932 + 0.49178032494716 + 0.49180562021962 + 0.49183518884954 + 0.49186989288079 + 0.49191079114073 + 0.49195913384075 + 0.49201644214617 + 0.49208458687444 + 0.49216588055877 + 0.49226320204935 + 0.49238020471369 + 0.49252187279956 + 0.49269577954755 + 0.49291233591953 + 0.49318410301214 + 0.49352681153432 + 0.49373114023462 + 0.49396139206742 + 0.49422117213276 + 0.49451464220930 + 0.49484661951020 + 0.49522269641150 + 0.49564938685145 + 0.49613430734188 + 0.49668641874902 + 0.49731679093183 + 0.49804726623823 + 0.49893150270497 + 0.50002599176465 + 0.50138717871349 + 0.50309021654385 + 0.50523094475614 + 0.50793802680037 + 0.51138811883793 + 0.51583089146438 + 0.52163282250032 + 0.52936113002140 + 0.53998730037910 + 0.55528950900621 + 0.57919069509290 + 0.62407907426952 + 1.00000000000000 + 0.61127780427120 + 0.55256619647070 + 0.51468593627537 + 0.48564307787545 + 0.46158959487553 + 0.44069177179202 + 0.47847380959938 + 0.47847381131567 + 0.47847381160027 + 0.47847381193125 + 0.47847381231803 + 0.47847381276809 + 0.47847381329302 + 0.47847381390519 + 0.47847381461897 + 0.47847381545668 + 0.47847381645506 + 0.47847381767855 + 0.47847381920688 + 0.47847382112575 + 0.47847382353688 + 0.47847382656656 + 0.47847383037082 + 0.47847383514488 + 0.47847384114297 + 0.47847384869435 + 0.47847385819893 + 0.47847387016328 + 0.47847388521883 + 0.47847390416281 + 0.47847392801315 + 0.47847395814883 + 0.47847399662398 + 0.47847404620897 + 0.47847411026618 + 0.47847419297270 + 0.47847430003610 + 0.47847443869207 + 0.47847461818242 + 0.47847485040798 + 0.47847515066690 + 0.47847553859665 + 0.47847603936567 + 0.47847668517168 + 0.47847751842046 + 0.47847859514683 + 0.47847998611200 + 0.47848178240650 + 0.47848410030359 + 0.47848707681208 + 0.47849080094049 + 0.47849526221061 + 0.47850050416289 + 0.47850655141999 + 0.47851323704274 + 0.47852043609114 + 0.47852815427475 + 0.47853643101386 + 0.47854531514613 + 0.47855486305455 + 0.47856515588237 + 0.47857627939384 + 0.47858831385318 + 0.47860135168241 + 0.47861550094751 + 0.47863090029080 + 0.47864780514681 + 0.47866680919705 + 0.47868872649450 + 0.47871427077759 + 0.47874415852960 + 0.47877926656836 + 0.47882062401268 + 0.47886947744506 + 0.47892735377943 + 0.47899613292672 + 0.47907814625290 + 0.47917634372699 + 0.47929475400021 + 0.47943953184612 + 0.47961912658194 + 0.47984364759443 + 0.48012566969894 + 0.48029332351619 + 0.48048185748898 + 0.48069411976660 + 0.48093338803312 + 0.48120344325437 + 0.48150865839352 + 0.48185410596439 + 0.48224568986181 + 0.48269032139161 + 0.48319651898800 + 0.48378150369083 + 0.48448836954653 + 0.48536190431079 + 0.48644594868163 + 0.48779832494893 + 0.48949161110819 + 0.49162157637575 + 0.49431685369067 + 0.49775416845655 + 0.50218349331840 + 0.50797309185347 + 0.51571548373330 + 0.52638517808099 + 0.54179046810908 + 0.56591825922376 + 0.61127780427120 + 1.00000000000000 + 0.59835741555026 + 0.53910298620640 + 0.50109728227161 + 0.47214400545408 + 0.44824912406166 + 0.46543456369616 + 0.46543456520032 + 0.46543456544939 + 0.46543456573970 + 0.46543456607800 + 0.46543456647260 + 0.46543456693222 + 0.46543456746862 + 0.46543456809418 + 0.46543456882796 + 0.46543456970289 + 0.46543457077653 + 0.46543457211780 + 0.46543457380311 + 0.46543457592306 + 0.46543457858881 + 0.46543458193825 + 0.46543458614530 + 0.46543459143415 + 0.46543459809684 + 0.46543460649044 + 0.46543461706089 + 0.46543463037200 + 0.46543464713102 + 0.46543466824206 + 0.46543469493384 + 0.46543472903426 + 0.46543477301105 + 0.46543482986052 + 0.46543490330859 + 0.46543499844456 + 0.46543512172786 + 0.46543528140501 + 0.46543548810380 + 0.46543575548736 + 0.46543610110197 + 0.46543654743273 + 0.46543712325224 + 0.46543786646279 + 0.46543882714865 + 0.46544006856239 + 0.46544167210887 + 0.46544374167898 + 0.46544639960596 + 0.46544972494394 + 0.46545370724616 + 0.46545838423896 + 0.46546377637691 + 0.46546973227771 + 0.46547613821386 + 0.46548299727090 + 0.46549034232989 + 0.46549821421232 + 0.46550665990834 + 0.46551574776028 + 0.46552554933695 + 0.46553613034208 + 0.46554756611901 + 0.46555994449636 + 0.46557337865150 + 0.46558808248523 + 0.46560456374944 + 0.46562351760979 + 0.46564554380393 + 0.46567123633673 + 0.46570131940002 + 0.46573663761702 + 0.46577820928674 + 0.46582727637847 + 0.46588536151551 + 0.46595434531591 + 0.46603660012821 + 0.46613536997333 + 0.46625564167059 + 0.46640425246257 + 0.46658931088049 + 0.46682083184390 + 0.46695805177992 + 0.46711203629273 + 0.46728502747693 + 0.46747959782405 + 0.46769870519010 + 0.46794575845327 + 0.46822469650446 + 0.46854008425959 + 0.46889724115839 + 0.46930271409046 + 0.46977009544516 + 0.47033405716667 + 0.47103022453516 + 0.47189282733118 + 0.47296667161132 + 0.47430725570635 + 0.47598678963799 + 0.47810055516334 + 0.48077653941235 + 0.48419062757603 + 0.48859250259736 + 0.49436704324831 + 0.50210324893024 + 0.51278819933270 + 0.52825846866200 + 0.55256619647070 + 0.59835741555026 + 1.00000000000000 + 0.58529459079093 + 0.52557524490125 + 0.48753914391021 + 0.45873394128522 + 0.45243793978443 + 0.45243794110001 + 0.45243794131784 + 0.45243794157198 + 0.45243794186825 + 0.45243794221280 + 0.45243794261503 + 0.45243794308421 + 0.45243794363148 + 0.45243794427321 + 0.45243794503892 + 0.45243794597906 + 0.45243794715363 + 0.45243794863186 + 0.45243795049169 + 0.45243795283302 + 0.45243795577649 + 0.45243795947607 + 0.45243796413035 + 0.45243796999712 + 0.45243797739341 + 0.45243798671321 + 0.45243799845680 + 0.45243801325127 + 0.45243803189702 + 0.45243805548711 + 0.45243808564091 + 0.45243812455445 + 0.45243817489087 + 0.45243823996370 + 0.45243832430126 + 0.45243843365139 + 0.45243857536195 + 0.45243875889440 + 0.45243899642345 + 0.45243930358337 + 0.45243970041444 + 0.45244021256777 + 0.45244087383428 + 0.45244172887175 + 0.45244283407983 + 0.45244426203618 + 0.45244610534997 + 0.45244847299774 + 0.45245143504026 + 0.45245498123462 + 0.45245914419556 + 0.45246394082631 + 0.45246923427574 + 0.45247492138576 + 0.45248100321124 + 0.45248750709367 + 0.45249446707513 + 0.45250192221669 + 0.45250992998038 + 0.45251854997453 + 0.45252783580291 + 0.45253784866932 + 0.45254865970455 + 0.45256036103137 + 0.45257313156569 + 0.45258740521530 + 0.45260377511617 + 0.45262274473109 + 0.45264480583969 + 0.45267055567305 + 0.45270068620288 + 0.45273602757315 + 0.45277758771926 + 0.45282659680721 + 0.45288456768734 + 0.45295340261843 + 0.45303570690440 + 0.45313551320612 + 0.45325834396236 + 0.45341068734516 + 0.45360049755689 + 0.45371265103267 + 0.45383823532264 + 0.45397901042185 + 0.45413698971226 + 0.45431448086178 + 0.45451413432014 + 0.45473900126038 + 0.45499260343473 + 0.45527902711013 + 0.45560329786917 + 0.45597615814320 + 0.45642555942509 + 0.45697992922537 + 0.45766612030728 + 0.45851906913644 + 0.45958156424616 + 0.46090863434810 + 0.46257183281667 + 0.46466551300130 + 0.46731634468124 + 0.47069894581611 + 0.47507418901447 + 0.48082053465342 + 0.48853013718827 + 0.49919877858103 + 0.51468593627537 + 0.53910298620640 + 0.58529459079093 + 1.00000000000000 + 0.57215567669633 + 0.51204308494258 + 0.47406188805802 + 0.43947732959057 + 0.43947733073964 + 0.43947733093028 + 0.43947733115229 + 0.43947733141116 + 0.43947733171246 + 0.43947733206396 + 0.43947733247338 + 0.43947733295206 + 0.43947733351293 + 0.43947733418214 + 0.43947733500452 + 0.43947733603241 + 0.43947733732699 + 0.43947733895750 + 0.43947734101030 + 0.43947734359403 + 0.43947734684269 + 0.43947735093297 + 0.43947735609235 + 0.43947736259893 + 0.43947737080418 + 0.43947738114841 + 0.43947739418704 + 0.43947741062799 + 0.43947743143890 + 0.43947745805885 + 0.43947749243006 + 0.43947753691675 + 0.43947759445970 + 0.43947766908053 + 0.43947776588323 + 0.43947789139468 + 0.43947805402561 + 0.43947826459842 + 0.43947853701274 + 0.43947888909276 + 0.43947934365232 + 0.43947993075155 + 0.43948069012381 + 0.43948167195283 + 0.43948294080577 + 0.43948457905665 + 0.43948668358907 + 0.43948931637820 + 0.43949246752492 + 0.43949616518221 + 0.43950042326144 + 0.43950511842084 + 0.43951015741175 + 0.43951553976612 + 0.43952128819446 + 0.43952743104916 + 0.43953400077421 + 0.43954104566374 + 0.43954861533856 + 0.43955675346273 + 0.43956550967936 + 0.43957494150251 + 0.43958512384201 + 0.43959620639784 + 0.43960855999777 + 0.43962269077645 + 0.43963902149262 + 0.43965795934355 + 0.43967999688953 + 0.43970570095787 + 0.43973574810873 + 0.43977095594720 + 0.43981231765997 + 0.43986104910629 + 0.43991867393425 + 0.43998728268977 + 0.44007013559555 + 0.44017169220625 + 0.44029714057457 + 0.44045279151064 + 0.44054447503772 + 0.44064691323641 + 0.44076148591607 + 0.44088976690114 + 0.44103355439838 + 0.44119490679001 + 0.44137618506898 + 0.44158010367151 + 0.44180979922731 + 0.44206912921486 + 0.44236660372965 + 0.44272482041989 + 0.44316655070816 + 0.44371296993694 + 0.44439149396351 + 0.44523537891104 + 0.44628698084151 + 0.44760070406103 + 0.44924719056451 + 0.45131945679230 + 0.45394268490774 + 0.45729947814215 + 0.46164376360292 + 0.46735311010739 + 0.47501974770538 + 0.48564307787545 + 0.50109728227161 + 0.52557524490125 + 0.57215567669633 + 1.00000000000000 + 0.55895331634542 + 0.49854101646031 + 0.42653265548361 + 0.42653265648766 + 0.42653265665409 + 0.42653265684798 + 0.42653265707378 + 0.42653265733734 + 0.42653265764423 + 0.42653265800267 + 0.42653265842022 + 0.42653265891018 + 0.42653265949491 + 0.42653266021357 + 0.42653266111305 + 0.42653266224583 + 0.42653266367441 + 0.42653266547385 + 0.42653266773934 + 0.42653267059017 + 0.42653267418201 + 0.42653267871406 + 0.42653268443371 + 0.42653269164888 + 0.42653270074996 + 0.42653271222729 + 0.42653272670685 + 0.42653274504289 + 0.42653276850830 + 0.42653279882360 + 0.42653283808234 + 0.42653288888758 + 0.42653295480435 + 0.42653304035587 + 0.42653315132956 + 0.42653329518573 + 0.42653348152340 + 0.42653372267977 + 0.42653403447075 + 0.42653443714771 + 0.42653495739757 + 0.42653563050198 + 0.42653650101474 + 0.42653762626622 + 0.42653907938526 + 0.42654094633093 + 0.42654328184197 + 0.42654607647043 + 0.42654935449735 + 0.42655312734007 + 0.42655728416686 + 0.42656174097884 + 0.42656649622880 + 0.42657156877803 + 0.42657698225198 + 0.42658276361965 + 0.42658895350495 + 0.42659559326012 + 0.42660271847537 + 0.42661036944205 + 0.42661859269408 + 0.42662744922455 + 0.42663706450167 + 0.42664775572424 + 0.42665995518789 + 0.42667401842001 + 0.42669028314963 + 0.42670915632138 + 0.42673110304378 + 0.42675667560927 + 0.42678653826069 + 0.42682149399569 + 0.42686252123020 + 0.42691084174155 + 0.42696813524930 + 0.42703704203609 + 0.42712116968051 + 0.42722467255980 + 0.42735256333949 + 0.42742766135268 + 0.42751138491436 + 0.42760481681262 + 0.42770918845169 + 0.42782590242604 + 0.42795655893203 + 0.42810298688149 + 0.42826728091513 + 0.42845185189308 + 0.42865966635498 + 0.42889749222886 + 0.42918367098450 + 0.42953653234503 + 0.42997287775216 + 0.43051437608756 + 0.43118709752413 + 0.43202397815460 + 0.43306689091332 + 0.43436950721638 + 0.43600135769963 + 0.43805416116000 + 0.44065922925602 + 0.44399288647191 + 0.44830697103534 + 0.45397623816670 + 0.46158959487553 + 0.47214400545408 + 0.48753914391021 + 0.51204308494258 + 0.55895331634542 + 1.00000000000000 + 0.54570510519363 + 0.41357241987949 + 0.41357242075670 + 0.41357242090218 + 0.41357242107165 + 0.41357242126907 + 0.41357242149942 + 0.41357242176785 + 0.41357242208033 + 0.41357242244517 + 0.41357242287380 + 0.41357242338477 + 0.41357242401271 + 0.41357242479985 + 0.41357242579164 + 0.41357242704234 + 0.41357242861919 + 0.41357243060562 + 0.41357243310633 + 0.41357243625740 + 0.41357244023717 + 0.41357244526073 + 0.41357245160142 + 0.41357245960155 + 0.41357246969494 + 0.41357248243344 + 0.41357249857155 + 0.41357251923192 + 0.41357254593684 + 0.41357258053483 + 0.41357262532850 + 0.41357268346910 + 0.41357275896086 + 0.41357285692283 + 0.41357298395846 + 0.41357314856774 + 0.41357336167357 + 0.41357363728559 + 0.41357399334116 + 0.41357445348332 + 0.41357504897442 + 0.41357581929170 + 0.41357681523441 + 0.41357810158929 + 0.41357975447309 + 0.41358182215379 + 0.41358429571978 + 0.41358719610476 + 0.41359053265638 + 0.41359420610624 + 0.41359814106222 + 0.41360233525743 + 0.41360680438051 + 0.41361156816033 + 0.41361664905718 + 0.41362208131603 + 0.41362789948410 + 0.41363413265105 + 0.41364081361470 + 0.41364798014995 + 0.41365568208778 + 0.41366402489795 + 0.41367328030425 + 0.41368381807660 + 0.41369593796519 + 0.41370992096109 + 0.41372610438347 + 0.41374487119910 + 0.41376667387316 + 0.41379205401443 + 0.41382166322138 + 0.41385629168763 + 0.41389692265944 + 0.41394491072899 + 0.41400240222988 + 0.41407232663734 + 0.41415802311921 + 0.41426348779976 + 0.41432523029816 + 0.41439391766266 + 0.41447040270737 + 0.41455565247986 + 0.41465076508516 + 0.41475698925448 + 0.41487574723456 + 0.41500866184428 + 0.41515759378481 + 0.41532483501042 + 0.41551579851047 + 0.41574544714094 + 0.41602862396783 + 0.41637875829654 + 0.41681311760167 + 0.41735233321590 + 0.41802229627712 + 0.41885564367689 + 0.41989375874853 + 0.42118952747292 + 0.42281155250563 + 0.42485660903818 + 0.42745087788136 + 0.43076874526286 + 0.43505900815808 + 0.44069177179202 + 0.44824912406166 + 0.45873394128522 + 0.47406188805802 + 0.49854101646031 + 0.54570510519363 + 1.00000000000000 + 1.00000000000000 + 0.99989747993531 + 0.99988908464520 + 0.99988050285268 + 0.99987176327059 + 0.99986288353607 + 0.99985386807388 + 0.99984470703110 + 0.99983537496698 + 0.99982582188332 + 0.99981594160074 + 0.99980555814500 + 0.99979449641029 + 0.99978260957256 + 0.99976975023377 + 0.99975575282836 + 0.99974042772244 + 0.99972355912456 + 0.99970487582540 + 0.99968404414884 + 0.99966071992996 + 0.99963450903327 + 0.99960496057903 + 0.99957156099509 + 0.99953372130922 + 0.99949071321407 + 0.99944154913528 + 0.99938514207112 + 0.99932053519640 + 0.99924685127907 + 0.99916295062323 + 0.99906777606179 + 0.99896027248769 + 0.99883927788231 + 0.99870344999617 + 0.99855117558617 + 0.99838046990007 + 0.99818887613819 + 0.99797310993679 + 0.99772895022814 + 0.99745162583324 + 0.99713535575849 + 0.99677321616251 + 0.99635761429734 + 0.99588377103591 + 0.99535002011153 + 0.99474886110029 + 0.99407143045154 + 0.99331380161081 + 0.99246669130886 + 0.99151340634556 + 0.99043414675984 + 0.98920673014516 + 0.98780642484108 + 0.98620428673301 + 0.98436873846057 + 0.98226632851501 + 0.97985987997295 + 0.97710803987800 + 0.97396453513088 + 0.97037464828813 + 0.96626605121982 + 0.96155623768561 + 0.95617053601740 + 0.95004025578018 + 0.94309622699089 + 0.93527946056305 + 0.92654218964329 + 0.91685166490819 + 0.90619597156781 + 0.89459091998249 + 0.88208642273072 + 0.86876604185228 + 0.85473555043779 + 0.84014518313657 + 0.82521776289581 + 0.81021113824146 + 0.80275033132575 + 0.79535358707363 + 0.78803822965449 + 0.78081395221088 + 0.77368191426028 + 0.76663443960236 + 0.75965553613670 + 0.75272237638934 + 0.74580751420159 + 0.73887735251256 + 0.73182530632810 + 0.72435066012037 + 0.71628892077999 + 0.70761131940482 + 0.69828336919694 + 0.68832068534555 + 0.67775370815717 + 0.66662601644860 + 0.65499248103438 + 0.64291733112038 + 0.63046888339843 + 0.61766144346996 + 0.60456332613205 + 0.59124623034647 + 0.57778413967944 + 0.56425225556762 + 0.55072548046593 + 0.53724846298034 + 0.52385347880237 + 0.51058705096975 + 0.49748211696548 + 0.48455446499095 + 0.99989747993531 + 1.00000000000000 + 0.99997020033113 + 0.99994590377985 + 0.99992489966723 + 0.99990636386576 + 0.99988972606005 + 0.99987454093217 + 0.99986043894884 + 0.99984709080466 + 0.99983416122920 + 0.99982129169669 + 0.99980817486912 + 0.99979457297084 + 0.99978027360835 + 0.99976506161029 + 0.99974870707430 + 0.99973096058342 + 0.99971152250174 + 0.99969003614633 + 0.99966614022404 + 0.99963942724078 + 0.99960943543410 + 0.99957564175897 + 0.99953744850677 + 0.99949411900162 + 0.99944465765137 + 0.99938797127088 + 0.99932309942641 + 0.99924916312810 + 0.99916502163431 + 0.99906961836081 + 0.99896189970025 + 0.99884070539909 + 0.99870469481989 + 0.99855225579674 + 0.99838140393180 + 0.99818968197840 + 0.99797380434019 + 0.99772954830976 + 0.99745214104507 + 0.99713579986718 + 0.99677359931320 + 0.99635794516931 + 0.99588405710948 + 0.99535026778612 + 0.99474907564768 + 0.99407161629497 + 0.99331396260200 + 0.99246683078344 + 0.99151352718197 + 0.99043425145976 + 0.98920682090268 + 0.98780650357126 + 0.98620435510345 + 0.98436879793169 + 0.98226638035858 + 0.97985992530960 + 0.97710807967727 + 0.97396457024610 + 0.97037467945472 + 0.96626607905678 + 0.96155626270540 + 0.95617055864344 + 0.95004027636175 + 0.94309624580171 + 0.93527947782208 + 0.92654220551945 + 0.91685167953476 + 0.90619598504725 + 0.89459093239459 + 0.88208643414109 + 0.86876605231809 + 0.85473556000930 + 0.84014519186196 + 0.82521777082493 + 0.81021114542935 + 0.80275033816402 + 0.79535359357472 + 0.78803823583585 + 0.78081395808504 + 0.77368191984137 + 0.76663444490284 + 0.75965554117050 + 0.75272238116826 + 0.74580751873846 + 0.73887735681877 + 0.73182531041244 + 0.72435066398129 + 0.71628892441496 + 0.70761132281162 + 0.69828337237308 + 0.68832068829251 + 0.67775371087610 + 0.66662601894362 + 0.65499248330999 + 0.64291733318427 + 0.63046888525905 + 0.61766144513645 + 0.60456332761504 + 0.59124623165692 + 0.57778414082891 + 0.56425225656873 + 0.55072548133003 + 0.53724846371929 + 0.52385347942905 + 0.51058705149573 + 0.49748211740314 + 0.48455446535271 + 0.99988908464520 + 0.99997020033113 + 1.00000000000000 + 0.99996625230166 + 0.99993975142573 + 0.99991747583771 + 0.99989821352254 + 0.99988115293600 + 0.99986569245364 + 0.99985134723822 + 0.99983767311743 + 0.99982423464701 + 0.99981067263819 + 0.99979671561118 + 0.99978212892964 + 0.99976668202399 + 0.99975013365537 + 0.99973222563852 + 0.99971265138717 + 0.99969104882706 + 0.99966705275595 + 0.99964025275059 + 0.99961018477306 + 0.99957632387672 + 0.99953807068428 + 0.99949468696423 + 0.99944517567175 + 0.99938844251102 + 0.99932352639081 + 0.99924954799255 + 0.99916536636705 + 0.99906992501458 + 0.99896217056428 + 0.99884094304399 + 0.99870490208157 + 0.99855243568675 + 0.99838155951261 + 0.99818981623665 + 0.99797392006077 + 0.99772964800144 + 0.99745222693974 + 0.99713587391950 + 0.99677366320826 + 0.99635800035141 + 0.99588410482187 + 0.99535030909651 + 0.99474911143199 + 0.99407164728969 + 0.99331398944973 + 0.99246685404292 + 0.99151354733247 + 0.99043426891870 + 0.98920683603552 + 0.98780651669659 + 0.98620436650141 + 0.98436880784421 + 0.98226638900010 + 0.97985993286412 + 0.97710808630873 + 0.97396457609555 + 0.97037468464590 + 0.96626608369286 + 0.96155626687005 + 0.95617056240783 + 0.95004027978524 + 0.94309624892928 + 0.93527948069118 + 0.92654220815803 + 0.91685168196416 + 0.90619598728480 + 0.89459093445528 + 0.88208643603429 + 0.86876605405438 + 0.85473556159678 + 0.84014519330903 + 0.82521777213931 + 0.81021114662090 + 0.80275033929741 + 0.79535359465240 + 0.78803823686047 + 0.78081395905855 + 0.77368192076589 + 0.76663444578107 + 0.75965554200481 + 0.75272238196049 + 0.74580751949082 + 0.73887735753227 + 0.73182531108941 + 0.72435066462149 + 0.71628892501733 + 0.70761132337595 + 0.69828337289970 + 0.68832068878066 + 0.67775371132662 + 0.66662601935685 + 0.65499248368700 + 0.64291733352618 + 0.63046888556678 + 0.61766144541243 + 0.60456332786081 + 0.59124623187395 + 0.57778414101931 + 0.56425225673437 + 0.55072548147309 + 0.53724846384180 + 0.52385347953260 + 0.51058705158270 + 0.49748211747583 + 0.48455446541275 + 0.99988050285268 + 0.99994590377985 + 0.99996625230166 + 1.00000000000000 + 0.99996188845459 + 0.99993316989715 + 0.99990972142010 + 0.99988983279638 + 0.99987241229492 + 0.99985668026704 + 0.99984200278257 + 0.99982781817131 + 0.99981368531897 + 0.99979928100832 + 0.99978433752970 + 0.99976860221817 + 0.99975181811007 + 0.99973371522074 + 0.99971397778491 + 0.99969223672674 + 0.99966812182358 + 0.99964121892211 + 0.99961106112863 + 0.99957712115874 + 0.99953879759246 + 0.99949535032297 + 0.99944578056726 + 0.99938899269564 + 0.99932402483205 + 0.99924999725474 + 0.99916576877101 + 0.99907028296769 + 0.99896248674098 + 0.99884122045518 + 0.99870514403685 + 0.99855264569869 + 0.99838174115727 + 0.99818997299887 + 0.99797405518672 + 0.99772976441746 + 0.99745232725061 + 0.99713596040472 + 0.99677373783469 + 0.99635806480133 + 0.99588416055154 + 0.99535035734532 + 0.99474915322712 + 0.99407168349120 + 0.99331402081033 + 0.99246688120846 + 0.99151357086541 + 0.99043428930746 + 0.98920685370769 + 0.98780653202552 + 0.98620437981216 + 0.98436881942126 + 0.98226639909116 + 0.97985994168576 + 0.97710809405189 + 0.97396458292518 + 0.97037469070648 + 0.96626608910303 + 0.96155627173043 + 0.95617056680356 + 0.95004028377961 + 0.94309625257874 + 0.93527948403833 + 0.92654221123637 + 0.91685168479793 + 0.90619598989551 + 0.89459093685767 + 0.88208643824260 + 0.86876605607814 + 0.85473556344773 + 0.84014519499648 + 0.82521777367170 + 0.81021114800974 + 0.80275034061841 + 0.79535359590886 + 0.78803823805430 + 0.78081396019288 + 0.77368192184345 + 0.76663444680457 + 0.75965554297647 + 0.75272238288321 + 0.74580752036670 + 0.73887735836417 + 0.73182531187803 + 0.72435066536721 + 0.71628892571932 + 0.70761132403380 + 0.69828337351308 + 0.68832068935011 + 0.67775371185176 + 0.66662601983879 + 0.65499248412664 + 0.64291733392466 + 0.63046888592600 + 0.61766144573434 + 0.60456332814709 + 0.59124623212708 + 0.57778414124128 + 0.56425225692740 + 0.55072548163961 + 0.53724846398448 + 0.52385347965378 + 0.51058705168445 + 0.49748211756037 + 0.48455446548238 + 0.99987176327059 + 0.99992489966723 + 0.99993975142573 + 0.99996188845459 + 1.00000000000000 + 0.99995709115457 + 0.99992618206981 + 0.99990167706875 + 0.99988125440144 + 0.99986350141407 + 0.99984742119931 + 0.99983222961333 + 0.99981734843270 + 0.99980237109069 + 0.99978697860061 + 0.99977088544459 + 0.99975381221584 + 0.99973547263919 + 0.99971553860358 + 0.99969363179918 + 0.99966937542985 + 0.99964235054792 + 0.99961208663743 + 0.99957805350182 + 0.99953964721009 + 0.99949612537409 + 0.99944648712315 + 0.99938963522810 + 0.99932460686695 + 0.99925052182331 + 0.99916623860783 + 0.99907070089931 + 0.99896285590448 + 0.99884154436667 + 0.99870542656222 + 0.99855289094226 + 0.99838195328969 + 0.99819015608804 + 0.99797421301997 + 0.99772990040523 + 0.99745244443564 + 0.99713606144437 + 0.99677382502531 + 0.99635814010543 + 0.99588422566414 + 0.99535041371966 + 0.99474920206039 + 0.99407172578782 + 0.99331405744736 + 0.99246691294861 + 0.99151359835909 + 0.99043431312872 + 0.98920687435366 + 0.98780654993361 + 0.98620439536187 + 0.98436883294448 + 0.98226641087753 + 0.97985995199014 + 0.97710810309377 + 0.97396459090163 + 0.97037469778259 + 0.96626609542082 + 0.96155627740640 + 0.95617057193408 + 0.95004028844234 + 0.94309625683844 + 0.93527948794367 + 0.92654221482694 + 0.91685168810388 + 0.90619599294081 + 0.89459093965942 + 0.88208644081759 + 0.86876605843967 + 0.85473556560589 + 0.84014519696273 + 0.82521777545846 + 0.81021114962930 + 0.80275034215895 + 0.79535359737297 + 0.78803823944623 + 0.78081396151552 + 0.77368192310020 + 0.76663444799745 + 0.75965554410944 + 0.75272238395913 + 0.74580752138840 + 0.73887735933408 + 0.73182531279694 + 0.72435066623583 + 0.71628892653740 + 0.70761132480089 + 0.69828337422836 + 0.68832069001314 + 0.67775371246355 + 0.66662602039996 + 0.65499248463865 + 0.64291733438893 + 0.63046888634442 + 0.61766144610930 + 0.60456332848100 + 0.59124623242160 + 0.57778414149986 + 0.56425225715260 + 0.55072548183382 + 0.53724846415096 + 0.52385347979477 + 0.51058705180282 + 0.49748211765886 + 0.48455446556395 + 0.99986288353607 + 0.99990636386576 + 0.99991747583771 + 0.99993316989715 + 0.99995709115457 + 1.00000000000000 + 0.99995184879749 + 0.99991881809770 + 0.99989338044593 + 0.99987248577858 + 0.99985434461551 + 0.99983774110657 + 0.99982185002675 + 0.99980612222633 + 0.99979015506919 + 0.99977361202339 + 0.99975618049858 + 0.99973755107760 + 0.99971737866271 + 0.99969527249644 + 0.99967084705692 + 0.99964367711871 + 0.99961328752909 + 0.99957914440976 + 0.99954064072558 + 0.99949703129860 + 0.99944731272841 + 0.99939038586440 + 0.99932528672620 + 0.99925113450320 + 0.99916678733923 + 0.99907118900236 + 0.99896328705759 + 0.99884192268370 + 0.99870575656131 + 0.99855317741759 + 0.99838220111037 + 0.99819036999958 + 0.99797439744040 + 0.99773005931881 + 0.99745258138493 + 0.99713617953240 + 0.99677392693108 + 0.99635822812117 + 0.99588430177089 + 0.99535047961344 + 0.99474925913952 + 0.99407177522748 + 0.99331410027246 + 0.99246695004511 + 0.99151363049492 + 0.99043434096922 + 0.98920689848221 + 0.98780657086101 + 0.98620441353508 + 0.98436884874722 + 0.98226642465013 + 0.97985996403092 + 0.97710811366036 + 0.97396460021972 + 0.97037470604810 + 0.96626610280002 + 0.96155628403486 + 0.95617057792440 + 0.95004029388691 + 0.94309626181114 + 0.93527949250141 + 0.92654221901785 + 0.91685169196198 + 0.90619599649463 + 0.89459094292759 + 0.88208644382101 + 0.86876606119372 + 0.85473556812276 + 0.84014519925600 + 0.82521777754224 + 0.81021115151728 + 0.80275034395414 + 0.79535359908063 + 0.78803824106864 + 0.78081396305756 + 0.77368192456427 + 0.76663444938843 + 0.75965554543021 + 0.75272238521293 + 0.74580752257906 + 0.73887736046377 + 0.73182531386824 + 0.72435066724918 + 0.71628892749133 + 0.70761132569477 + 0.69828337506223 + 0.68832069078633 + 0.67775371317681 + 0.66662602105431 + 0.65499248523553 + 0.64291733493052 + 0.63046888683279 + 0.61766144654653 + 0.60456332886987 + 0.59124623276517 + 0.57778414180152 + 0.56425225741532 + 0.55072548206052 + 0.53724846434484 + 0.52385347995910 + 0.51058705194085 + 0.49748211777378 + 0.48455446565885 + 0.99985386807388 + 0.99988972606005 + 0.99989821352254 + 0.99990972142010 + 0.99992618206981 + 0.99995184879749 + 1.00000000000000 + 0.99994615685348 + 0.99991111090075 + 0.99988484816467 + 0.99986346074627 + 0.99984477099740 + 0.99982746257818 + 0.99981072298235 + 0.99979400413804 + 0.99977688596616 + 0.99975900460194 + 0.99974001660448 + 0.99971955284906 + 0.99969720541367 + 0.99967257694229 + 0.99964523387442 + 0.99961469499246 + 0.99958042173948 + 0.99954180318645 + 0.99949809072749 + 0.99944827787316 + 0.99939126314071 + 0.99932608115763 + 0.99925185035873 + 0.99916742844155 + 0.99907175925952 + 0.99896379078797 + 0.99884236470265 + 0.99870614215801 + 0.99855351218498 + 0.99838249073666 + 0.99819062002778 + 0.99797461302087 + 0.99773024510007 + 0.99745274150376 + 0.99713631761094 + 0.99677404609292 + 0.99635833104676 + 0.99588439077422 + 0.99535055667192 + 0.99474932588639 + 0.99407183304268 + 0.99331415035006 + 0.99246699342240 + 0.99151366806940 + 0.99043437352272 + 0.98920692669478 + 0.98780659533158 + 0.98620443477860 + 0.98436886722160 + 0.98226644075127 + 0.97985997810534 + 0.97710812601046 + 0.97396461111076 + 0.97037471570874 + 0.96626611142258 + 0.96155629177869 + 0.95617058492110 + 0.95004030024583 + 0.94309626761672 + 0.93527949782421 + 0.92654222390915 + 0.91685169646226 + 0.90619600063970 + 0.89459094674156 + 0.88208644732531 + 0.86876606440462 + 0.85473557105836 + 0.84014520193093 + 0.82521777997119 + 0.81021115371805 + 0.80275034604804 + 0.79535360107061 + 0.78803824296075 + 0.78081396485478 + 0.77368192627180 + 0.76663445101026 + 0.75965554697002 + 0.75272238667539 + 0.74580752396628 + 0.73887736178027 + 0.73182531511731 + 0.72435066842996 + 0.71628892860284 + 0.70761132673665 + 0.69828337603349 + 0.68832069168787 + 0.67775371400830 + 0.66662602181729 + 0.65499248593142 + 0.64291733556125 + 0.63046888740122 + 0.61766144705587 + 0.60456332932301 + 0.59124623316599 + 0.57778414215323 + 0.56425225772134 + 0.55072548232469 + 0.53724846457086 + 0.52385348015049 + 0.51058705210172 + 0.49748211790781 + 0.48455446576945 + 0.99984470703110 + 0.99987454093217 + 0.99988115293600 + 0.99988983279638 + 0.99990167706875 + 0.99991881809770 + 0.99994615685348 + 1.00000000000000 + 0.99994001666326 + 0.99990307894542 + 0.99987602453501 + 0.99985401376414 + 0.99983460466960 + 0.99981644584751 + 0.99979871496316 + 0.99978084552471 + 0.99976238996091 + 0.99974295264387 + 0.99972212927416 + 0.99969948762264 + 0.99967461390280 + 0.99964706324062 + 0.99961634638427 + 0.99958191872105 + 0.99954316438713 + 0.99949933051801 + 0.99944940683463 + 0.99939228901457 + 0.99932700996260 + 0.99925268719588 + 0.99916817783728 + 0.99907242583444 + 0.99896437960560 + 0.99884288141497 + 0.99870659294321 + 0.99855390359008 + 0.99838282940445 + 0.99819091242489 + 0.99797486516627 + 0.99773046241604 + 0.99745292882248 + 0.99713647915685 + 0.99677418551941 + 0.99635845148050 + 0.99588449491822 + 0.99535064684106 + 0.99474940399091 + 0.99407190069098 + 0.99331420894576 + 0.99246704417611 + 0.99151371203304 + 0.99043441160899 + 0.98920695970074 + 0.98780662395720 + 0.98620445963033 + 0.98436888883434 + 0.98226645958586 + 0.97985999456573 + 0.97710814045419 + 0.97396462384734 + 0.97037472700485 + 0.96626612150224 + 0.96155630082995 + 0.95617059309856 + 0.95004030767623 + 0.94309627440104 + 0.93527950404163 + 0.92654222962167 + 0.91685170171952 + 0.90619600547868 + 0.89459095119480 + 0.88208645141371 + 0.86876606815234 + 0.85473557448289 + 0.84014520505039 + 0.82521778280344 + 0.81021115628494 + 0.80275034848956 + 0.79535360339215 + 0.78803824516679 + 0.78081396695065 + 0.77368192826338 + 0.76663445290082 + 0.75965554876594 + 0.75272238837968 + 0.74580752558484 + 0.73887736331683 + 0.73182531657363 + 0.72435066980638 + 0.71628892989937 + 0.70761132795157 + 0.69828337716616 + 0.68832069273866 + 0.67775371497775 + 0.66662602270637 + 0.65499248674296 + 0.64291733629674 + 0.63046888806475 + 0.61766144765004 + 0.60456332985228 + 0.59124623363309 + 0.57778414256288 + 0.56425225807789 + 0.55072548263259 + 0.53724846483440 + 0.52385348037415 + 0.51058705228918 + 0.49748211806395 + 0.48455446589826 + 0.99983537496698 + 0.99986043894884 + 0.99986569245364 + 0.99987241229492 + 0.99988125440144 + 0.99989338044593 + 0.99991111090075 + 0.99994001666326 + 1.00000000000000 + 0.99993342379670 + 0.99989467463544 + 0.99986675291598 + 0.99984397417069 + 0.99982370994746 + 0.99980456137806 + 0.99978568194072 + 0.99976647744418 + 0.99974646769584 + 0.99972519475430 + 0.99970219077839 + 0.99967701857084 + 0.99964921750714 + 0.99961828747838 + 0.99958367589124 + 0.99954476056020 + 0.99950078325706 + 0.99945072902636 + 0.99939349004383 + 0.99932809709149 + 0.99925366652728 + 0.99916905476195 + 0.99907320581396 + 0.99896506860465 + 0.99884348606616 + 0.99870712048994 + 0.99855436168640 + 0.99838322582129 + 0.99819125472514 + 0.99797516038016 + 0.99773071688176 + 0.99745314818233 + 0.99713666835005 + 0.99677434881707 + 0.99635859253867 + 0.99588461689983 + 0.99535075245350 + 0.99474949547383 + 0.99407197992394 + 0.99331427757203 + 0.99246710362144 + 0.99151376352143 + 0.99043445621335 + 0.98920699835824 + 0.98780665747879 + 0.98620448873798 + 0.98436891414013 + 0.98226648163977 + 0.97986001384108 + 0.97710815736626 + 0.97396463875793 + 0.97037474022740 + 0.96626613330110 + 0.96155631142155 + 0.95617060266737 + 0.95004031636908 + 0.94309628233570 + 0.93527951131274 + 0.92654223630022 + 0.91685170786542 + 0.90619601113430 + 0.89459095639599 + 0.88208645619079 + 0.86876607252950 + 0.85473557848274 + 0.84014520869357 + 0.82521778611314 + 0.81021115928127 + 0.80275035133975 + 0.79535360610058 + 0.78803824774255 + 0.78081396939784 + 0.77368193058743 + 0.76663445510763 + 0.75965555086099 + 0.75272239036990 + 0.74580752747391 + 0.73887736510867 + 0.73182531827342 + 0.72435067141399 + 0.71628893141244 + 0.70761132936941 + 0.69828337848815 + 0.68832069396549 + 0.67775371610971 + 0.66662602374455 + 0.65499248769000 + 0.64291733715567 + 0.63046888883931 + 0.61766144834365 + 0.60456333046912 + 0.59124623417858 + 0.57778414304131 + 0.56425225849423 + 0.55072548299229 + 0.53724846514186 + 0.52385348063500 + 0.51058705250819 + 0.49748211824630 + 0.48455446604887 + 0.99982582188332 + 0.99984709080466 + 0.99985134723822 + 0.99985668026704 + 0.99986350141407 + 0.99987248577858 + 0.99988484816467 + 0.99990307894542 + 0.99993342379670 + 1.00000000000000 + 0.99992633048687 + 0.99988576119397 + 0.99985688241838 + 0.99983322381651 + 0.99981197234870 + 0.99979167934553 + 0.99977146870718 + 0.99975071304665 + 0.99972886811366 + 0.99970541176506 + 0.99967987224927 + 0.99965176642941 + 0.99962057912391 + 0.99958574701850 + 0.99954663967861 + 0.99950249204106 + 0.99945228330088 + 0.99939490127433 + 0.99932937409824 + 0.99925481666949 + 0.99917008449617 + 0.99907412162509 + 0.99896587755528 + 0.99884419596665 + 0.99870773986879 + 0.99855489954159 + 0.99838369127779 + 0.99819165665227 + 0.99797550703293 + 0.99773101569272 + 0.99745340577545 + 0.99713689052079 + 0.99677454057186 + 0.99635875817539 + 0.99588476013093 + 0.99535087646090 + 0.99474960288900 + 0.99407207295552 + 0.99331435815054 + 0.99246717341883 + 0.99151382398182 + 0.99043450859142 + 0.98920704375288 + 0.98780669685215 + 0.98620452292155 + 0.98436894386830 + 0.98226650754771 + 0.97986003648768 + 0.97710817723673 + 0.97396465627865 + 0.97037475576573 + 0.96626614716652 + 0.96155632387106 + 0.95617061391049 + 0.95004032657921 + 0.94309629165700 + 0.93527951985304 + 0.92654224414494 + 0.91685171508087 + 0.90619601777345 + 0.89459096250332 + 0.88208646179923 + 0.86876607766682 + 0.85473558317526 + 0.84014521296848 + 0.82521778999393 + 0.81021116279722 + 0.80275035468392 + 0.79535360928117 + 0.78803825076346 + 0.78081397226805 + 0.77368193331369 + 0.76663445769751 + 0.75965555332044 + 0.75272239270436 + 0.74580752968962 + 0.73887736721177 + 0.73182532026762 + 0.72435067329987 + 0.71628893318817 + 0.70761133103345 + 0.69828338004015 + 0.68832069540485 + 0.67775371743782 + 0.66662602496265 + 0.65499248880167 + 0.64291733816378 + 0.63046888974822 + 0.61766144915810 + 0.60456333119395 + 0.59124623481885 + 0.57778414360283 + 0.56425225898321 + 0.55072548341470 + 0.53724846550331 + 0.52385348094142 + 0.51058705276548 + 0.49748211846028 + 0.48455446622569 + 0.99981594160074 + 0.99983416122920 + 0.99983767311743 + 0.99984200278257 + 0.99984742119931 + 0.99985434461551 + 0.99986346074627 + 0.99987602453501 + 0.99989467463544 + 0.99992633048687 + 1.00000000000000 + 0.99991865225202 + 0.99987625376859 + 0.99984635850436 + 0.99982170264224 + 0.99979930967959 + 0.99977768793853 + 0.99975592766536 + 0.99973333551164 + 0.99970930195916 + 0.99968330206529 + 0.99965481929195 + 0.99962331688899 + 0.99958821674058 + 0.99954887739285 + 0.99950452490418 + 0.99945413100026 + 0.99939657801771 + 0.99933089073124 + 0.99925618217732 + 0.99917130669770 + 0.99907520833395 + 0.99896683721923 + 0.99884503792468 + 0.99870847427903 + 0.99855553712028 + 0.99838424287813 + 0.99819213282812 + 0.99797591759818 + 0.99773136948667 + 0.99745371066821 + 0.99713715340451 + 0.99677476740256 + 0.99635895406118 + 0.99588492948689 + 0.99535102306778 + 0.99474972986829 + 0.99407218293614 + 0.99331445341976 + 0.99246725595643 + 0.99151389549479 + 0.99043457056507 + 0.98920709748450 + 0.98780674347528 + 0.98620456342299 + 0.98436897910943 + 0.98226653827808 + 0.97986006336352 + 0.97710820083734 + 0.97396467710084 + 0.97037477424222 + 0.96626616366287 + 0.96155633868861 + 0.95617062729958 + 0.95004033874780 + 0.94309630276511 + 0.93527953003095 + 0.92654225349524 + 0.91685172368192 + 0.90619602569090 + 0.89459096978446 + 0.88208646848581 + 0.86876608379215 + 0.85473558877287 + 0.84014521806743 + 0.82521779462398 + 0.81021116699200 + 0.80275035867490 + 0.79535361307464 + 0.78803825436911 + 0.78081397569411 + 0.77368193656894 + 0.76663446078902 + 0.75965555625671 + 0.75272239549177 + 0.74580753233663 + 0.73887736972458 + 0.73182532265097 + 0.72435067555315 + 0.71628893531043 + 0.70761133302232 + 0.69828338189567 + 0.68832069712607 + 0.67775371902611 + 0.66662602642104 + 0.65499249013116 + 0.64291733937048 + 0.63046889083631 + 0.61766145013290 + 0.60456333206159 + 0.59124623558618 + 0.57778414427612 + 0.56425225956982 + 0.55072548392112 + 0.53724846593686 + 0.52385348130922 + 0.51058705307467 + 0.49748211871795 + 0.48455446643894 + 0.99980555814500 + 0.99982129169669 + 0.99982423464701 + 0.99982781817131 + 0.99983222961333 + 0.99983774110657 + 0.99984477099740 + 0.99985401376414 + 0.99986675291598 + 0.99988576119397 + 0.99991865225202 + 1.00000000000000 + 0.99991039069761 + 0.99986620076253 + 0.99983521089236 + 0.99980940268726 + 0.99978567498717 + 0.99976249746851 + 0.99973889248407 + 0.99971409955656 + 0.99968750726208 + 0.99965854716481 + 0.99962665036766 + 0.99959121758984 + 0.99955159220018 + 0.99950698840178 + 0.99945636820289 + 0.99939860684329 + 0.99933272476964 + 0.99925783259245 + 0.99917278314521 + 0.99907652040257 + 0.99896799524649 + 0.99884605328798 + 0.99870935934315 + 0.99855630492181 + 0.99838490660962 + 0.99819270531843 + 0.99797641077006 + 0.99773179408805 + 0.99745407626219 + 0.99713746836500 + 0.99677503896721 + 0.99635918842922 + 0.99588513200878 + 0.99535119833479 + 0.99474988165692 + 0.99407231441195 + 0.99331456733671 + 0.99246735469349 + 0.99151398109480 + 0.99043464480583 + 0.98920716191110 + 0.98780679943819 + 0.98620461209225 + 0.98436902151003 + 0.98226657530574 + 0.97986009580083 + 0.97710822935983 + 0.97396470230558 + 0.97037479664590 + 0.96626618369606 + 0.96155635670888 + 0.95617064360228 + 0.95004035357648 + 0.94309631631558 + 0.93527954245587 + 0.92654226491919 + 0.91685173419891 + 0.90619603537158 + 0.89459097869243 + 0.88208647666954 + 0.86876609129438 + 0.85473559563122 + 0.84014522431698 + 0.82521780030229 + 0.81021117214068 + 0.80275036357157 + 0.79535361773237 + 0.78803825879711 + 0.78081397990359 + 0.77368194056896 + 0.76663446458988 + 0.75965555986669 + 0.75272239892121 + 0.74580753559377 + 0.73887737281759 + 0.73182532558603 + 0.72435067833014 + 0.71628893792501 + 0.70761133547439 + 0.69828338418395 + 0.68832069925097 + 0.67775372098807 + 0.66662602822181 + 0.65499249177517 + 0.64291734086213 + 0.63046889218219 + 0.61766145134000 + 0.60456333313626 + 0.59124623653644 + 0.57778414511123 + 0.56425226029700 + 0.55072548455028 + 0.53724846647653 + 0.52385348176709 + 0.51058705345977 + 0.49748211903933 + 0.48455446670488 + 0.99979449641029 + 0.99980817486912 + 0.99981067263819 + 0.99981368531897 + 0.99981734843270 + 0.99982185002675 + 0.99982746257818 + 0.99983460466960 + 0.99984397417069 + 0.99985688241838 + 0.99987625376859 + 0.99991039069761 + 1.00000000000000 + 0.99990160304917 + 0.99985565889921 + 0.99982344618942 + 0.99979628449007 + 0.99977098454610 + 0.99974594522665 + 0.99972011899813 + 0.99969274367035 + 0.99966316556501 + 0.99963076553551 + 0.99959491278156 + 0.99955492906440 + 0.99951001230180 + 0.99945911151586 + 0.99940109259524 + 0.99933497026163 + 0.99925985193229 + 0.99917458844054 + 0.99907812359653 + 0.99896940915146 + 0.99884729197591 + 0.99871043808865 + 0.99855723979032 + 0.99838571387559 + 0.99819340079620 + 0.99797700916092 + 0.99773230864206 + 0.99745451877175 + 0.99713784915544 + 0.99677536695337 + 0.99635947123701 + 0.99588537622631 + 0.99535140959634 + 0.99475006458715 + 0.99407247287894 + 0.99331470468921 + 0.99246747381503 + 0.99151408445908 + 0.99043473454741 + 0.98920723988688 + 0.98780686726633 + 0.98620467118124 + 0.98436907307945 + 0.98226662042551 + 0.97986013540262 + 0.97710826426376 + 0.97396473321662 + 0.97037482418023 + 0.96626620836685 + 0.96155637894410 + 0.95617066375414 + 0.95004037193399 + 0.94309633311227 + 0.93527955787602 + 0.92654227910734 + 0.91685174726965 + 0.90619604741696 + 0.89459098978136 + 0.88208648686364 + 0.86876610064594 + 0.85473560418558 + 0.84014523211628 + 0.82521780739660 + 0.81021117857523 + 0.80275036969628 + 0.79535362355981 + 0.78803826434005 + 0.78081398517433 + 0.77368194557988 + 0.76663446935330 + 0.75965556439394 + 0.75272240322430 + 0.74580753968214 + 0.73887737670138 + 0.73182532927311 + 0.72435068181998 + 0.71628894121428 + 0.70761133856083 + 0.69828338706566 + 0.68832070192666 + 0.67775372345984 + 0.66662603049324 + 0.65499249384961 + 0.64291734274621 + 0.63046889388317 + 0.61766145286607 + 0.60456333449679 + 0.59124623774137 + 0.57778414617037 + 0.56425226122128 + 0.55072548534975 + 0.53724846716288 + 0.52385348235114 + 0.51058705395194 + 0.49748211945061 + 0.48455446704680 + 0.99978260957256 + 0.99979457297084 + 0.99979671561118 + 0.99979928100832 + 0.99980237109069 + 0.99980612222633 + 0.99981072298235 + 0.99981644584751 + 0.99982370994746 + 0.99983322381651 + 0.99984635850436 + 0.99986620076253 + 0.99990160304917 + 1.00000000000000 + 0.99989232198722 + 0.99984462252486 + 0.99981100307544 + 0.99978224257923 + 0.99975505506552 + 0.99972776648315 + 0.99969932648398 + 0.99966893138054 + 0.99963587895607 + 0.99959948924990 + 0.99955905204314 + 0.99951374223916 + 0.99946249106445 + 0.99940415180767 + 0.99933773150934 + 0.99926233324098 + 0.99917680514056 + 0.99908009068670 + 0.99897114263200 + 0.99884880934042 + 0.99871175827732 + 0.99855838271851 + 0.99838669969832 + 0.99819424908684 + 0.99797773812284 + 0.99773293467351 + 0.99745505647716 + 0.99713831131089 + 0.99677576458851 + 0.99635981378017 + 0.99588567181219 + 0.99535166517666 + 0.99475028585562 + 0.99407266457055 + 0.99331487090838 + 0.99246761807008 + 0.99151420974307 + 0.99043484344449 + 0.98920733463130 + 0.98780694980921 + 0.98620474320873 + 0.98436913606353 + 0.98226667564397 + 0.97986018397563 + 0.97710830716619 + 0.97396477130239 + 0.97037485818268 + 0.96626623890029 + 0.96155640651570 + 0.95617068878768 + 0.95004039477648 + 0.94309635403813 + 0.93527957710823 + 0.92654229682174 + 0.91685176360325 + 0.90619606247948 + 0.89459100365934 + 0.88208649963236 + 0.86876611236606 + 0.85473561491371 + 0.84014524190748 + 0.82521781630538 + 0.81021118666597 + 0.80275037739953 + 0.79535363089153 + 0.78803827131607 + 0.78081399181207 + 0.77368195189410 + 0.76663447535809 + 0.75965557010387 + 0.75272240865357 + 0.74580754484350 + 0.73887738160808 + 0.73182533393322 + 0.72435068623261 + 0.71628894537614 + 0.70761134246853 + 0.69828339071611 + 0.68832070531949 + 0.67775372659552 + 0.66662603337590 + 0.65499249648496 + 0.64291734514096 + 0.63046889604755 + 0.61766145480965 + 0.60456333623031 + 0.59124623927815 + 0.57778414752244 + 0.56425226240231 + 0.55072548637357 + 0.53724846804274 + 0.52385348310075 + 0.51058705458500 + 0.49748211998069 + 0.48455446748793 + 0.99976975023377 + 0.99978027360835 + 0.99978212892964 + 0.99978433752970 + 0.99978697860061 + 0.99979015506919 + 0.99979400413804 + 0.99979871496316 + 0.99980456137806 + 0.99981197234870 + 0.99982170264224 + 0.99983521089236 + 0.99985565889921 + 0.99989232198722 + 1.00000000000000 + 0.99988256005251 + 0.99983304517963 + 0.99979777938883 + 0.99976709458805 + 0.99973762098327 + 0.99970767904784 + 0.99967617604315 + 0.99964226247100 + 0.99960517715938 + 0.99956416043936 + 0.99951835344217 + 0.99946666237928 + 0.99940792315456 + 0.99934113222409 + 0.99926538664688 + 0.99917953084490 + 0.99908250764503 + 0.99897327089737 + 0.99885067073177 + 0.99871337634453 + 0.99855978217001 + 0.99838790550362 + 0.99819528550753 + 0.99797862770173 + 0.99773369772763 + 0.99745571108785 + 0.99713887330786 + 0.99677624761698 + 0.99636022950428 + 0.99588603028836 + 0.99535197499871 + 0.99475055403364 + 0.99407289692198 + 0.99331507245783 + 0.99246779310147 + 0.99151436189767 + 0.99043497584326 + 0.98920744998235 + 0.98780705045384 + 0.98620483118478 + 0.98436921313157 + 0.98226674335109 + 0.97986024365835 + 0.97710835999976 + 0.97396481830583 + 0.97037490023600 + 0.96626627674327 + 0.96155644075563 + 0.95617071992515 + 0.95004042322952 + 0.94309638013922 + 0.93527960112525 + 0.92654231896113 + 0.91685178403353 + 0.90619608133228 + 0.89459102104254 + 0.88208651563360 + 0.86876612706691 + 0.85473562837874 + 0.84014525420330 + 0.82521782750521 + 0.81021119684286 + 0.80275038709306 + 0.79535364012256 + 0.78803828010529 + 0.78081400017616 + 0.77368195985427 + 0.76663448293256 + 0.75965557731057 + 0.75272241550896 + 0.74580755136378 + 0.73887738780979 + 0.73182533982725 + 0.72435069181763 + 0.71628895064617 + 0.70761134741866 + 0.69828339534310 + 0.68832070962284 + 0.67775373057715 + 0.66662603703812 + 0.65499249983465 + 0.64291734818747 + 0.63046889880255 + 0.61766145728548 + 0.60456333844159 + 0.59124624123915 + 0.57778414924977 + 0.56425226391295 + 0.55072548768476 + 0.53724846917165 + 0.52385348406332 + 0.51058705539963 + 0.49748212066440 + 0.48455446805772 + 0.99975575282836 + 0.99976506161029 + 0.99976668202399 + 0.99976860221817 + 0.99977088544459 + 0.99977361202339 + 0.99977688596616 + 0.99978084552471 + 0.99978568194072 + 0.99979167934553 + 0.99979930967959 + 0.99980940268726 + 0.99982344618942 + 0.99984462252486 + 0.99988256005251 + 1.00000000000000 + 0.99987231892058 + 0.99982085524223 + 0.99978360993332 + 0.99975058911433 + 0.99971841239260 + 0.99968535307809 + 0.99965027521787 + 0.99961227348693 + 0.99957050719502 + 0.99952406579933 + 0.99947181909124 + 0.99941257831550 + 0.99934532498790 + 0.99926914761355 + 0.99918288535824 + 0.99908547985063 + 0.99897588605580 + 0.99885295613105 + 0.99871536130844 + 0.99856149739004 + 0.99838938195830 + 0.99819655324865 + 0.99797971465759 + 0.99773462904774 + 0.99745650917235 + 0.99713955774270 + 0.99677683529683 + 0.99636073485668 + 0.99588646575221 + 0.99535235119428 + 0.99475087960265 + 0.99407317902033 + 0.99331531724509 + 0.99246800581871 + 0.99151454696924 + 0.99043513706356 + 0.98920759062284 + 0.98780717335104 + 0.98620493878506 + 0.98436930756553 + 0.98226682646840 + 0.97986031707865 + 0.97710842512785 + 0.97396487636982 + 0.97037495229117 + 0.96626632367801 + 0.96155648329551 + 0.95617075867474 + 0.95004045868444 + 0.94309641270253 + 0.93527963111440 + 0.92654234663109 + 0.91685180958660 + 0.90619610492989 + 0.89459104281258 + 0.88208653568526 + 0.86876614549629 + 0.85473564527190 + 0.84014526964385 + 0.82521784157755 + 0.81021120963979 + 0.80275039929035 + 0.79535365174061 + 0.78803829117036 + 0.78081401071238 + 0.77368196988630 + 0.76663449248281 + 0.75965558640115 + 0.75272242416047 + 0.74580755959866 + 0.73887739564525 + 0.73182534727739 + 0.72435069888083 + 0.71628895731584 + 0.70761135368832 + 0.69828340120760 + 0.68832071507949 + 0.67775373562750 + 0.66662604168773 + 0.65499250409032 + 0.64291735206109 + 0.63046890230787 + 0.61766146043808 + 0.60456334125876 + 0.59124624374024 + 0.57778415145550 + 0.56425226584445 + 0.55072548936260 + 0.53724847061723 + 0.52385348529901 + 0.51058705644632 + 0.49748212154463 + 0.48455446879329 + 0.99974042772244 + 0.99974870707430 + 0.99975013365537 + 0.99975181811007 + 0.99975381221584 + 0.99975618049858 + 0.99975900460194 + 0.99976238996091 + 0.99976647744418 + 0.99977146870718 + 0.99977768793853 + 0.99978567498717 + 0.99979628449007 + 0.99981100307544 + 0.99983304517963 + 0.99987231892058 + 1.00000000000000 + 0.99986158948307 + 0.99980791743610 + 0.99976826492500 + 0.99973247690835 + 0.99969711481745 + 0.99966040870702 + 0.99962117165721 + 0.99957842015219 + 0.99953116004903 + 0.99947820588680 + 0.99941833271718 + 0.99935050031219 + 0.99927378469226 + 0.99918701737236 + 0.99908913784684 + 0.99897910203840 + 0.99885576436250 + 0.99871779839620 + 0.99856360151203 + 0.99839119155510 + 0.99819810558056 + 0.99798104431621 + 0.99773576717180 + 0.99745748348604 + 0.99714039249564 + 0.99677755138792 + 0.99636135012747 + 0.99588699558846 + 0.99535280871760 + 0.99475127548540 + 0.99407352206832 + 0.99331561501957 + 0.99246826473487 + 0.99151477243106 + 0.99043533367671 + 0.98920776235316 + 0.98780732362491 + 0.98620507056187 + 0.98436942341658 + 0.98226692862180 + 0.97986040748627 + 0.97710850548489 + 0.97396494815384 + 0.97037501677566 + 0.96626638191967 + 0.96155653617130 + 0.95617080690657 + 0.95004050287000 + 0.94309645332399 + 0.93527966855908 + 0.92654238120822 + 0.91685184153847 + 0.90619613445018 + 0.89459107006526 + 0.88208656080178 + 0.86876616859330 + 0.85473566645700 + 0.84014528901702 + 0.82521785924663 + 0.81021122572156 + 0.80275041462026 + 0.79535366635443 + 0.78803830509464 + 0.78081402397611 + 0.77368198252012 + 0.76663450451513 + 0.75965559786014 + 0.75272243507244 + 0.74580756998778 + 0.73887740553693 + 0.73182535668760 + 0.72435070780764 + 0.71628896574853 + 0.70761136161924 + 0.69828340863108 + 0.68832072199200 + 0.67775374203033 + 0.66662604758494 + 0.65499250949146 + 0.64291735698076 + 0.63046890676280 + 0.61766146444747 + 0.60456334484475 + 0.59124624692598 + 0.57778415426779 + 0.56425226830918 + 0.55072549150670 + 0.53724847246742 + 0.52385348688238 + 0.51058705779069 + 0.49748212267725 + 0.48455446974140 + 0.99972355912456 + 0.99973096058342 + 0.99973222563852 + 0.99973371522074 + 0.99973547263919 + 0.99973755107760 + 0.99974001660448 + 0.99974295264387 + 0.99974646769584 + 0.99975071304665 + 0.99975592766536 + 0.99976249746851 + 0.99977098454610 + 0.99978224257923 + 0.99979777938883 + 0.99982085524223 + 0.99986158948307 + 1.00000000000000 + 0.99985029492420 + 0.99979402998815 + 0.99975152363874 + 0.99971246512052 + 0.99967336493179 + 0.99963240786334 + 0.99958833262944 + 0.99953999970587 + 0.99948613521295 + 0.99942545885723 + 0.99935689762809 + 0.99927950874407 + 0.99919211230002 + 0.99909364399723 + 0.99898306029665 + 0.99885921795381 + 0.99872079316182 + 0.99856618503364 + 0.99839341161348 + 0.99820000838841 + 0.99798267273341 + 0.99773715975397 + 0.99745867454466 + 0.99714141203108 + 0.99677842526015 + 0.99636210039564 + 0.99588764127499 + 0.99535336606141 + 0.99475175765977 + 0.99407393991039 + 0.99331597783649 + 0.99246858038664 + 0.99151504751545 + 0.99043557380375 + 0.98920797233816 + 0.98780750762307 + 0.98620523215804 + 0.98436956570961 + 0.98226705431539 + 0.97986051892525 + 0.97710860471933 + 0.97396503696442 + 0.97037509669354 + 0.96626645422380 + 0.96155660190907 + 0.95617086694951 + 0.95004055793993 + 0.94309650399811 + 0.93527971530612 + 0.92654242440061 + 0.91685188147201 + 0.90619617136798 + 0.89459110415969 + 0.88208659224257 + 0.86876619752041 + 0.85473569300551 + 0.84014531330873 + 0.82521788141849 + 0.81021124591510 + 0.80275043387823 + 0.79535368471488 + 0.78803832259670 + 0.78081404065644 + 0.77368199841577 + 0.76663451966086 + 0.75965561229142 + 0.75272244881980 + 0.74580758308510 + 0.73887741801265 + 0.73182536856142 + 0.72435071907741 + 0.71628897640176 + 0.70761137164433 + 0.69828341801895 + 0.68832073073936 + 0.67775375013699 + 0.66662605505636 + 0.65499251633962 + 0.64291736322151 + 0.63046891241815 + 0.61766146954101 + 0.60456334940447 + 0.59124625098104 + 0.57778415785051 + 0.56425227145123 + 0.55072549424347 + 0.53724847483232 + 0.52385348890894 + 0.51058705951354 + 0.49748212413099 + 0.48455447096127 + 0.99970487582540 + 0.99971152250174 + 0.99971265138717 + 0.99971397778491 + 0.99971553860358 + 0.99971737866271 + 0.99971955284906 + 0.99972212927416 + 0.99972519475430 + 0.99972886811366 + 0.99973333551164 + 0.99973889248407 + 0.99974594522665 + 0.99975505506552 + 0.99976709458805 + 0.99978360993332 + 0.99980791743610 + 0.99985029492420 + 1.00000000000000 + 0.99983833481282 + 0.99977904655246 + 0.99973315437541 + 0.99969023933812 + 0.99964676657501 + 0.99960085422998 + 0.99955108360857 + 0.99949602900260 + 0.99943432087881 + 0.99936483466396 + 0.99928659823748 + 0.99919841411412 + 0.99909921139466 + 0.99898794603718 + 0.99886347702162 + 0.99872448330615 + 0.99856936584172 + 0.99839614268561 + 0.99820234724150 + 0.99798467261782 + 0.99773886853365 + 0.99746013477365 + 0.99714266091756 + 0.99677949485184 + 0.99636301803426 + 0.99588843052979 + 0.99535404707098 + 0.99475234671587 + 0.99407445040391 + 0.99331642123845 + 0.99246896637405 + 0.99151538416507 + 0.99043586796819 + 0.98920822988221 + 0.98780773360073 + 0.98620543091640 + 0.98436974100746 + 0.98226720942492 + 0.97986065669228 + 0.97710872761935 + 0.97396514715055 + 0.97037519601858 + 0.96626654423106 + 0.96155668386064 + 0.95617094189292 + 0.95004062674475 + 0.94309656736876 + 0.93527977380479 + 0.92654247848351 + 0.91685193150587 + 0.90619621764496 + 0.89459114691837 + 0.88208663168649 + 0.86876623383490 + 0.85473572634593 + 0.84014534383709 + 0.82521790929640 + 0.81021127132490 + 0.80275045812277 + 0.79535370783977 + 0.78803834464884 + 0.78081406168297 + 0.77368201845965 + 0.76663453876962 + 0.75965563050508 + 0.75272246618102 + 0.74580759963273 + 0.73887743378206 + 0.73182538357936 + 0.72435073333877 + 0.71628898988855 + 0.70761138434443 + 0.69828342992004 + 0.68832074183361 + 0.67775376042531 + 0.66662606454489 + 0.65499252504146 + 0.64291737115768 + 0.63046891961487 + 0.61766147602732 + 0.60456335521441 + 0.59124625615224 + 0.57778416242342 + 0.56425227546690 + 0.55072549774447 + 0.53724847786154 + 0.52385349150817 + 0.51058706172643 + 0.49748212600241 + 0.48455447253387 + 0.99968404414884 + 0.99969003614633 + 0.99969104882706 + 0.99969223672674 + 0.99969363179918 + 0.99969527249644 + 0.99969720541367 + 0.99969948762264 + 0.99970219077839 + 0.99970541176506 + 0.99970930195916 + 0.99971409955656 + 0.99972011899813 + 0.99972776648315 + 0.99973762098327 + 0.99975058911433 + 0.99976826492500 + 0.99979402998815 + 0.99983833481282 + 1.00000000000000 + 0.99982569486319 + 0.99976282322615 + 0.99971291191815 + 0.99966545931832 + 0.99961687132358 + 0.99956511094992 + 0.99950846516042 + 0.99944541023977 + 0.99937473614483 + 0.99929542301548 + 0.99920624537873 + 0.99910612075529 + 0.99899400258811 + 0.99886875143214 + 0.99872904895204 + 0.99857329786261 + 0.99839951588146 + 0.99820523355953 + 0.99798713854028 + 0.99774097371471 + 0.99746193222781 + 0.99714419694551 + 0.99678080933067 + 0.99636414496393 + 0.99588939923092 + 0.99535488258780 + 0.99475306930199 + 0.99407507665497 + 0.99331696536377 + 0.99246944031246 + 0.99151579786563 + 0.99043622982897 + 0.98920854707907 + 0.98780801230072 + 0.98620567641898 + 0.98436995789028 + 0.98226740166183 + 0.97986082774165 + 0.97710888048466 + 0.97396528445060 + 0.97037531999736 + 0.96626665675677 + 0.96155678645881 + 0.95617103583460 + 0.95004071307656 + 0.94309664695059 + 0.93527984732678 + 0.92654254649496 + 0.91685199445428 + 0.90619627589209 + 0.89459120076215 + 0.88208668138390 + 0.86876627960795 + 0.85473576840040 + 0.84014538236397 + 0.82521794450771 + 0.81021130344138 + 0.80275048877543 + 0.79535373708924 + 0.78803837255361 + 0.78081408830152 + 0.77368204384889 + 0.76663456298198 + 0.75965565359612 + 0.75272248820326 + 0.74580762063260 + 0.73887745380493 + 0.73182540265776 + 0.72435075146618 + 0.71628900704305 + 0.70761140050680 + 0.69828344507473 + 0.68832075597091 + 0.67775377354326 + 0.66662607665135 + 0.65499253615139 + 0.64291738129560 + 0.63046892881579 + 0.61766148432623 + 0.60456336265457 + 0.59124626278003 + 0.57778416828886 + 0.56425228062331 + 0.55072550224470 + 0.53724848175933 + 0.52385349485846 + 0.51058706458410 + 0.49748212842209 + 0.48455447457157 + 0.99966071992996 + 0.99966614022404 + 0.99966705275595 + 0.99966812182358 + 0.99966937542985 + 0.99967084705692 + 0.99967257694229 + 0.99967461390280 + 0.99967701857084 + 0.99967987224927 + 0.99968330206529 + 0.99968750726208 + 0.99969274367035 + 0.99969932648398 + 0.99970767904784 + 0.99971841239260 + 0.99973247690835 + 0.99975152363874 + 0.99977904655246 + 0.99982569486319 + 1.00000000000000 + 0.99981227336752 + 0.99974513696414 + 0.99969046685744 + 0.99963768149334 + 0.99958304013904 + 0.99952420375648 + 0.99945935645445 + 0.99938713684884 + 0.99930644344481 + 0.99921600440805 + 0.99911471675691 + 0.99900152742664 + 0.99887529697178 + 0.99873470914514 + 0.99857816801467 + 0.99840369026278 + 0.99820880248532 + 0.99799018520636 + 0.99774357265015 + 0.99746414954441 + 0.99714609035205 + 0.99678242848681 + 0.99636553219381 + 0.99589059104508 + 0.99535591017663 + 0.99475395786335 + 0.99407584680030 + 0.99331763471476 + 0.99247002365480 + 0.99151630746164 + 0.99043667600964 + 0.98920893864219 + 0.98780835679145 + 0.98620598031285 + 0.98437022677157 + 0.98226764037939 + 0.97986104050446 + 0.97710907095654 + 0.97396545581073 + 0.97037547497905 + 0.96626679762599 + 0.96155691506661 + 0.95617115371607 + 0.95004082151117 + 0.94309674697948 + 0.93527993979042 + 0.92654263207672 + 0.91685207369966 + 0.90619634925108 + 0.89459126860548 + 0.88208674402809 + 0.86876633733287 + 0.85473582145835 + 0.84014543100327 + 0.82521798898528 + 0.81021134403823 + 0.80275052753860 + 0.79535377409312 + 0.78803840787162 + 0.78081412200436 + 0.77368207600777 + 0.76663459366778 + 0.75965568287526 + 0.75272251613825 + 0.74580764728599 + 0.73887747923236 + 0.73182542689798 + 0.72435077451001 + 0.71628902886169 + 0.70761142107688 + 0.69828346437265 + 0.68832077398470 + 0.67775379026972 + 0.66662609209608 + 0.65499255033564 + 0.64291739424853 + 0.63046894057866 + 0.61766149494465 + 0.60456337218057 + 0.59124627127323 + 0.57778417581230 + 0.56425228724242 + 0.55072550802923 + 0.53724848677604 + 0.52385349917598 + 0.51058706827196 + 0.49748213154979 + 0.48455447720993 + 0.99963450903327 + 0.99963942724078 + 0.99964025275059 + 0.99964121892211 + 0.99964235054792 + 0.99964367711871 + 0.99964523387442 + 0.99964706324062 + 0.99964921750714 + 0.99965176642941 + 0.99965481929195 + 0.99965854716481 + 0.99966316556501 + 0.99966893138054 + 0.99967617604315 + 0.99968535307809 + 0.99969711481745 + 0.99971246512052 + 0.99973315437541 + 0.99976282322615 + 0.99981227336752 + 1.00000000000000 + 0.99979794010464 + 0.99972572297072 + 0.99966542114902 + 0.99960629881606 + 0.99954431256130 + 0.99947701288015 + 0.99940274585731 + 0.99932026134476 + 0.99922820690445 + 0.99912544256004 + 0.99901090105629 + 0.99888343946921 + 0.99874174202857 + 0.99858421305414 + 0.99840886694896 + 0.99821322465354 + 0.99799395734465 + 0.99774678807231 + 0.99746689088853 + 0.99714842964759 + 0.99678442765891 + 0.99636724400284 + 0.99589206099489 + 0.99535717717245 + 0.99475505328618 + 0.99407679629681 + 0.99331846018607 + 0.99247074343603 + 0.99151693671823 + 0.99043722746914 + 0.98920942312762 + 0.98780878356521 + 0.98620635730401 + 0.98437056081606 + 0.98226793739754 + 0.97986130564796 + 0.97710930869516 + 0.97396567002774 + 0.97037566900191 + 0.96626697421183 + 0.96155707646395 + 0.95617130180106 + 0.95004095783878 + 0.94309687281653 + 0.93528005616977 + 0.92654273983941 + 0.91685217352176 + 0.90619644168770 + 0.89459135412348 + 0.88208682301706 + 0.86876641015257 + 0.85473588842507 + 0.84014549242329 + 0.82521804518355 + 0.81021139537008 + 0.80275057656960 + 0.79535382091630 + 0.78803845257812 + 0.78081416468644 + 0.77368211675356 + 0.76663463256307 + 0.75965572000415 + 0.75272255158025 + 0.74580768111779 + 0.73887751152434 + 0.73182545769788 + 0.72435080380608 + 0.71628905661546 + 0.70761144725779 + 0.69828348894900 + 0.68832079693973 + 0.67775381159647 + 0.66662611180353 + 0.65499256844350 + 0.64291741079504 + 0.63046895561534 + 0.61766150852672 + 0.60456338437555 + 0.59124628215409 + 0.57778418545882 + 0.56425229573850 + 0.55072551546053 + 0.53724849322876 + 0.52385350473726 + 0.51058707302825 + 0.49748213559111 + 0.48455448062469 + 0.99960496057903 + 0.99960943543410 + 0.99961018477306 + 0.99961106112863 + 0.99961208663743 + 0.99961328752909 + 0.99961469499246 + 0.99961634638427 + 0.99961828747838 + 0.99962057912391 + 0.99962331688899 + 0.99962665036766 + 0.99963076553551 + 0.99963587895607 + 0.99964226247100 + 0.99965027521787 + 0.99966040870702 + 0.99967336493179 + 0.99969023933812 + 0.99971291191815 + 0.99974513696414 + 0.99979794010464 + 1.00000000000000 + 0.99978253164329 + 0.99970425109409 + 0.99963721090347 + 0.99957037150575 + 0.99949957441235 + 0.99942252396379 + 0.99933767583175 + 0.99924352865102 + 0.99913887353942 + 0.99902261410064 + 0.99889359684784 + 0.99875050287214 + 0.99859173440791 + 0.99841530134488 + 0.99821871638432 + 0.99799863816371 + 0.99775077523861 + 0.99747028795549 + 0.99715132670381 + 0.99678690207264 + 0.99636936162003 + 0.99589387862315 + 0.99535874338568 + 0.99475640724950 + 0.99407796995592 + 0.99331948082751 + 0.99247163384000 + 0.99151771568488 + 0.99043791073017 + 0.98921002402390 + 0.98780931350035 + 0.98620682601906 + 0.98437097669250 + 0.98226830771139 + 0.97986163669621 + 0.97710960595160 + 0.97396593824743 + 0.97037591225458 + 0.96626719586575 + 0.96155727926109 + 0.95617148802278 + 0.95004112938832 + 0.94309703125447 + 0.93528020276636 + 0.92654287562051 + 0.91685229933844 + 0.90619655822697 + 0.89459146196417 + 0.88208692266208 + 0.86876650204198 + 0.85473597296684 + 0.84014557000036 + 0.82521811620829 + 0.81021146028267 + 0.80275063859449 + 0.79535388016967 + 0.78803850917625 + 0.78081421874110 + 0.77368216837918 + 0.76663468186732 + 0.75965576708891 + 0.75272259654778 + 0.74580772406201 + 0.73887755253312 + 0.73182549683185 + 0.72435084104856 + 0.71628909191720 + 0.70761148057566 + 0.69828352024451 + 0.68832082618697 + 0.67775383878709 + 0.66662613694260 + 0.65499259155763 + 0.64291743192888 + 0.63046897483259 + 0.61766152589797 + 0.60456339998313 + 0.59124629609034 + 0.57778419782478 + 0.56425230663956 + 0.55072552500411 + 0.53724850152540 + 0.52385351189600 + 0.51058707916005 + 0.49748214080918 + 0.48455448504179 + 0.99957156099509 + 0.99957564175897 + 0.99957632387672 + 0.99957712115874 + 0.99957805350182 + 0.99957914440976 + 0.99958042173948 + 0.99958191872105 + 0.99958367589124 + 0.99958574701850 + 0.99958821674058 + 0.99959121758984 + 0.99959491278156 + 0.99959948924990 + 0.99960517715938 + 0.99961227348693 + 0.99962117165721 + 0.99963240786334 + 0.99964676657501 + 0.99966545931832 + 0.99969046685744 + 0.99972572297072 + 0.99978253164329 + 1.00000000000000 + 0.99976582882746 + 0.99968022072393 + 0.99960492661552 + 0.99952879974317 + 0.99944781487001 + 0.99935977158636 + 0.99926286998576 + 0.99915576669558 + 0.99903730620595 + 0.99890631016149 + 0.99876144912487 + 0.99860111853917 + 0.99842331982880 + 0.99822555339045 + 0.99800446078524 + 0.99775573145492 + 0.99747450797658 + 0.99715492352369 + 0.99678997255288 + 0.99637198811745 + 0.99589613216175 + 0.99536068471460 + 0.99475808530950 + 0.99407942464201 + 0.99332074617942 + 0.99247273825021 + 0.99151868250321 + 0.99043875945902 + 0.98921077116145 + 0.98780997311758 + 0.98620741012205 + 0.98437149560326 + 0.98226877036544 + 0.97986205084086 + 0.97710997831169 + 0.97396627465335 + 0.97037621770500 + 0.96626747448796 + 0.96155753440063 + 0.95617172247370 + 0.95004134548839 + 0.94309723091855 + 0.93528038756628 + 0.92654304683266 + 0.91685245801398 + 0.90619670523520 + 0.89459159802819 + 0.88208704841662 + 0.86876661804934 + 0.85473607973192 + 0.84014566801468 + 0.82521820598917 + 0.81021154238940 + 0.80275071707369 + 0.79535395516915 + 0.78803858083972 + 0.78081428721244 + 0.77368223379797 + 0.76663474436847 + 0.75965582680556 + 0.75272265360300 + 0.74580777857557 + 0.73887760461544 + 0.73182554655765 + 0.72435088839487 + 0.71628913682054 + 0.70761152297887 + 0.69828356009615 + 0.68832086345181 + 0.67775387344923 + 0.66662616900988 + 0.65499262105791 + 0.64291745891929 + 0.63046899939087 + 0.61766154810976 + 0.60456341995269 + 0.59124631393637 + 0.57778421367144 + 0.56425232062026 + 0.55072553725706 + 0.53724851218921 + 0.52385352110798 + 0.51058708706184 + 0.49748214754323 + 0.48455449075058 + 0.99953372130922 + 0.99953744850677 + 0.99953807068428 + 0.99953879759246 + 0.99953964721009 + 0.99954064072558 + 0.99954180318645 + 0.99954316438713 + 0.99954476056020 + 0.99954663967861 + 0.99954887739285 + 0.99955159220018 + 0.99955492906440 + 0.99955905204314 + 0.99956416043936 + 0.99957050719502 + 0.99957842015219 + 0.99958833262944 + 0.99960085422998 + 0.99961687132358 + 0.99963768149334 + 0.99966542114902 + 0.99970425109409 + 0.99976582882746 + 1.00000000000000 + 0.99974744975314 + 0.99965277659949 + 0.99956750654037 + 0.99948059772983 + 0.99938807445581 + 0.99928746385211 + 0.99917714099182 + 0.99905582804469 + 0.99892229250266 + 0.99877517941935 + 0.99861286834980 + 0.99843334524142 + 0.99823409169241 + 0.99801172546374 + 0.99776191038609 + 0.99747976568928 + 0.99715940228829 + 0.99679379403469 + 0.99637525560598 + 0.99589893467237 + 0.99536309840578 + 0.99476017148123 + 0.99408123322463 + 0.99332231975252 + 0.99247411227915 + 0.99151988609101 + 0.99043981684800 + 0.98921170282085 + 0.98781079647053 + 0.98620814001445 + 0.98437214478197 + 0.98226934985844 + 0.97986257019579 + 0.97711044582277 + 0.97396669750776 + 0.97037660204857 + 0.96626782538797 + 0.96155785597337 + 0.95617201814623 + 0.95004161814236 + 0.94309748291690 + 0.93528062085255 + 0.92654326300803 + 0.91685265838434 + 0.90619689089091 + 0.89459176989331 + 0.88208720728723 + 0.86876676464188 + 0.85473621469204 + 0.84014579196236 + 0.82521831957917 + 0.81021164632784 + 0.80275081645283 + 0.79535405017310 + 0.78803867164965 + 0.78081437401028 + 0.77368231675842 + 0.76663482366119 + 0.75965590259699 + 0.75272272605037 + 0.74580784782749 + 0.73887767080962 + 0.73182560978592 + 0.72435094862725 + 0.71628919397389 + 0.70761157697939 + 0.69828361087490 + 0.68832091096149 + 0.67775391766575 + 0.66662620993746 + 0.65499265873371 + 0.64291749340897 + 0.63046903079037 + 0.61766157652692 + 0.60456344551783 + 0.59124633679630 + 0.57778423398875 + 0.56425233855975 + 0.55072555299527 + 0.53724852589881 + 0.52385353296505 + 0.51058709724575 + 0.49748215623422 + 0.48455449813070 + 0.99949071321407 + 0.99949411900162 + 0.99949468696423 + 0.99949535032297 + 0.99949612537409 + 0.99949703129860 + 0.99949809072749 + 0.99949933051801 + 0.99950078325706 + 0.99950249204106 + 0.99950452490418 + 0.99950698840178 + 0.99951001230180 + 0.99951374223916 + 0.99951835344217 + 0.99952406579933 + 0.99953116004903 + 0.99953999970587 + 0.99955108360857 + 0.99956511094992 + 0.99958304013904 + 0.99960629881606 + 0.99963721090347 + 0.99968022072393 + 0.99974744975314 + 1.00000000000000 + 0.99972672321960 + 0.99962099819560 + 0.99952408423927 + 0.99942488595759 + 0.99931909907066 + 0.99920444126184 + 0.99907936760967 + 0.99894252869858 + 0.99879251339968 + 0.99862766763790 + 0.99844594929182 + 0.99824481045181 + 0.99802083483283 + 0.99776965122417 + 0.99748634758288 + 0.99716500564438 + 0.99679857261322 + 0.99637933964983 + 0.99590243632092 + 0.99536611355990 + 0.99476277728414 + 0.99408349244725 + 0.99332428590240 + 0.99247582985950 + 0.99152139153672 + 0.99044114044543 + 0.98921287006812 + 0.98781182906031 + 0.98620905638325 + 0.98437296074080 + 0.98227007907587 + 0.97986322451172 + 0.97711103550256 + 0.97396723144057 + 0.97037708783955 + 0.96626826929307 + 0.96155826306594 + 0.95617239266191 + 0.95004196363594 + 0.94309780232747 + 0.93528091660251 + 0.92654353709801 + 0.91685291246887 + 0.90619712634810 + 0.89459198788796 + 0.88208740883528 + 0.86876695065573 + 0.85473638600053 + 0.84014594935333 + 0.82521846389155 + 0.81021177845491 + 0.80275094282084 + 0.79535417101877 + 0.78803878720548 + 0.78081448450064 + 0.77368242240706 + 0.76663492468342 + 0.75965599919871 + 0.75272281843209 + 0.74580793617361 + 0.73887775529423 + 0.73182569052572 + 0.72435102557723 + 0.71628926703055 + 0.70761164604210 + 0.69828367585238 + 0.68832097178929 + 0.67775397431044 + 0.66662626240045 + 0.65499270705598 + 0.64291753767014 + 0.63046907111113 + 0.61766161304113 + 0.60456347839008 + 0.59124636621205 + 0.57778426014853 + 0.56425236167889 + 0.55072557329446 + 0.53724854360083 + 0.52385354829352 + 0.51058711042865 + 0.49748216750096 + 0.48455450771148 + 0.99944154913528 + 0.99944465765137 + 0.99944517567175 + 0.99944578056726 + 0.99944648712315 + 0.99944731272841 + 0.99944827787316 + 0.99944940683463 + 0.99945072902636 + 0.99945228330088 + 0.99945413100026 + 0.99945636820289 + 0.99945911151586 + 0.99946249106445 + 0.99946666237928 + 0.99947181909124 + 0.99947820588680 + 0.99948613521295 + 0.99949602900260 + 0.99950846516042 + 0.99952420375648 + 0.99954431256130 + 0.99957037150575 + 0.99960492661552 + 0.99965277659949 + 0.99972672321960 + 1.00000000000000 + 0.99970315629129 + 0.99958436699760 + 0.99947404011570 + 0.99936058021216 + 0.99923986161544 + 0.99910969428140 + 0.99896846593671 + 0.99881464320958 + 0.99864650278730 + 0.99846195105617 + 0.99825839226391 + 0.99803235977683 + 0.99777943301247 + 0.99749465698353 + 0.99717207429268 + 0.99680459705337 + 0.99638448584453 + 0.99590684690860 + 0.99536991045785 + 0.99476605843726 + 0.99408633744234 + 0.99332676256954 + 0.99247799451723 + 0.99152329017477 + 0.99044281117575 + 0.98921434493559 + 0.98781313523099 + 0.98621021694044 + 0.98437399544250 + 0.98227100499240 + 0.97986405641016 + 0.97711178618746 + 0.97396791199199 + 0.97037770773626 + 0.96626883630356 + 0.96155878348343 + 0.95617287174939 + 0.95004240582520 + 0.94309821128994 + 0.93528129538012 + 0.92654388821316 + 0.91685323801744 + 0.90619742808286 + 0.89459226730624 + 0.88208766724337 + 0.86876718922829 + 0.85473660579972 + 0.84014615139837 + 0.82521864925320 + 0.81021194827583 + 0.80275110530639 + 0.79535432646289 + 0.78803893590273 + 0.78081462674412 + 0.77368255847839 + 0.76663505485535 + 0.75965612373552 + 0.75272293758582 + 0.74580805018131 + 0.73887786437555 + 0.73182579482896 + 0.72435112504192 + 0.71628936151420 + 0.70761173541541 + 0.69828375999162 + 0.68832105060272 + 0.67775404774881 + 0.66662633045921 + 0.65499276978148 + 0.64291759516204 + 0.63046912351665 + 0.61766166053231 + 0.60456352117276 + 0.59124640452444 + 0.57778429424975 + 0.56425239184171 + 0.55072559980599 + 0.53724856674692 + 0.52385356836134 + 0.51058712771104 + 0.49748218229449 + 0.48455452031294 + 0.99938514207112 + 0.99938797127088 + 0.99938844251102 + 0.99938899269564 + 0.99938963522810 + 0.99939038586440 + 0.99939126314071 + 0.99939228901457 + 0.99939349004383 + 0.99939490127433 + 0.99939657801771 + 0.99939860684329 + 0.99940109259524 + 0.99940415180767 + 0.99940792315456 + 0.99941257831550 + 0.99941833271718 + 0.99942545885723 + 0.99943432087881 + 0.99944541023977 + 0.99945935645445 + 0.99947701288015 + 0.99949957441235 + 0.99952879974317 + 0.99956750654037 + 0.99962099819560 + 0.99970315629129 + 1.00000000000000 + 0.99967656095468 + 0.99954247691882 + 0.99941637972347 + 0.99928669637079 + 0.99914937629542 + 0.99900215877216 + 0.99884323427843 + 0.99867073478482 + 0.99848246969508 + 0.99827576271615 + 0.99804706987592 + 0.99779189868305 + 0.99750523346808 + 0.99718106299922 + 0.99681225218964 + 0.99639102113566 + 0.99591244556301 + 0.99537472886385 + 0.99477022203249 + 0.99408994798334 + 0.99332990672148 + 0.99248074412655 + 0.99152570373147 + 0.99044493702151 + 0.98921622360454 + 0.98781480103482 + 0.98621169896251 + 0.98437531854874 + 0.98227219065143 + 0.97986512318158 + 0.97711275015051 + 0.97396878706243 + 0.97037850578388 + 0.96626956706029 + 0.96155945480665 + 0.95617349021576 + 0.95004297699218 + 0.94309873978041 + 0.93528178503713 + 0.92654434224114 + 0.91685365909390 + 0.90619781846490 + 0.89459262891468 + 0.88208800176814 + 0.86876749819818 + 0.85473689058863 + 0.84014641333121 + 0.82521888971556 + 0.81021216875023 + 0.80275131634080 + 0.79535452843903 + 0.78803912920223 + 0.78081481173781 + 0.77368273553213 + 0.76663522431999 + 0.75965628594833 + 0.75272309287081 + 0.74580819884203 + 0.73887800669209 + 0.73182593098629 + 0.72435125496393 + 0.71628948500491 + 0.70761185229979 + 0.69828387009844 + 0.68832115381041 + 0.67775414398067 + 0.66662641970112 + 0.65499285208436 + 0.64291767064606 + 0.63046919237248 + 0.61766172297237 + 0.60456357746465 + 0.59124645497346 + 0.57778433919133 + 0.56425243163122 + 0.55072563481443 + 0.53724859734701 + 0.52385359492685 + 0.51058715062299 + 0.49748220193801 + 0.48455453707385 + 0.99932053519640 + 0.99932309942641 + 0.99932352639081 + 0.99932402483205 + 0.99932460686695 + 0.99932528672620 + 0.99932608115763 + 0.99932700996260 + 0.99932809709149 + 0.99932937409824 + 0.99933089073124 + 0.99933272476964 + 0.99933497026163 + 0.99933773150934 + 0.99934113222409 + 0.99934532498790 + 0.99935050031219 + 0.99935689762809 + 0.99936483466396 + 0.99937473614483 + 0.99938713684884 + 0.99940274585731 + 0.99942252396379 + 0.99944781487001 + 0.99948059772983 + 0.99952408423927 + 0.99958436699760 + 0.99967656095468 + 1.00000000000000 + 0.99964657696484 + 0.99949424132220 + 0.99934998249930 + 0.99920210532089 + 0.99904645245068 + 0.99888053404821 + 0.99870216494182 + 0.99850896455099 + 0.99829811504233 + 0.99806594881818 + 0.99780786503834 + 0.99751875961337 + 0.99719254544455 + 0.99682202265748 + 0.99639935686555 + 0.99591958329368 + 0.99538087022253 + 0.99477552837340 + 0.99409454998282 + 0.99333391556708 + 0.99248425183659 + 0.99152878501884 + 0.99044765345442 + 0.98921862668762 + 0.98781693428603 + 0.98621359918999 + 0.98437701720016 + 0.98227371484330 + 0.97986649634440 + 0.97711399257193 + 0.97396991629257 + 0.97037953678009 + 0.96627051204923 + 0.96156032365080 + 0.95617429117161 + 0.95004371706726 + 0.94309942482201 + 0.93528241992772 + 0.92654493107662 + 0.91685420530922 + 0.90619832496677 + 0.89459309819870 + 0.88208843603888 + 0.86876789943494 + 0.85473726059338 + 0.84014675381911 + 0.82521920249192 + 0.81021245573222 + 0.80275159114479 + 0.79535479156153 + 0.78803938113003 + 0.78081505295448 + 0.77368296650279 + 0.76663544550156 + 0.75965649777603 + 0.75272329575512 + 0.74580839317479 + 0.73887819283605 + 0.73182610917242 + 0.72435142508516 + 0.71628964680439 + 0.70761200553643 + 0.69828401454381 + 0.68832128928638 + 0.67775427038138 + 0.66662653699579 + 0.65499296032834 + 0.64291776998791 + 0.63046928304814 + 0.61766180525357 + 0.60456365169457 + 0.59124652154658 + 0.57778439854425 + 0.56425248422783 + 0.55072568113629 + 0.53724863788262 + 0.52385363016270 + 0.51058718105600 + 0.49748222807106 + 0.48455455940993 + 0.99924685127907 + 0.99924916312810 + 0.99924954799255 + 0.99924999725474 + 0.99925052182331 + 0.99925113450320 + 0.99925185035873 + 0.99925268719588 + 0.99925366652728 + 0.99925481666949 + 0.99925618217732 + 0.99925783259245 + 0.99925985193229 + 0.99926233324098 + 0.99926538664688 + 0.99926914761355 + 0.99927378469226 + 0.99927950874407 + 0.99928659823748 + 0.99929542301548 + 0.99930644344481 + 0.99932026134476 + 0.99933767583175 + 0.99935977158636 + 0.99938807445581 + 0.99942488595759 + 0.99947404011570 + 0.99954247691882 + 0.99964657696484 + 1.00000000000000 + 0.99961214401007 + 0.99943848667968 + 0.99927362023267 + 0.99910552073922 + 0.99892972021019 + 0.99874327364643 + 0.99854340503157 + 0.99832703478505 + 0.99809028839020 + 0.99782839531967 + 0.99753611833447 + 0.99720726040771 + 0.99683453067995 + 0.99641002012856 + 0.99592870932568 + 0.99538872002111 + 0.99478231019842 + 0.99410043209461 + 0.99333904099890 + 0.99248873875347 + 0.99153272910061 + 0.99045113334587 + 0.98922170803321 + 0.98781967243795 + 0.98621604090880 + 0.98437920236665 + 0.98227567783286 + 0.97986826684165 + 0.97711559627150 + 0.97397137539750 + 0.97038087021251 + 0.96627173523882 + 0.96156144901165 + 0.95617532912550 + 0.95004467648251 + 0.94310031311241 + 0.93528324333826 + 0.92654569485546 + 0.91685491388374 + 0.90619898210717 + 0.89459370714663 + 0.88208899966766 + 0.86876842033841 + 0.85473774112302 + 0.84014719622179 + 0.82521960911504 + 0.81021282906618 + 0.80275194876614 + 0.79535513411123 + 0.78803970924434 + 0.78081536724991 + 0.77368326758402 + 0.76663573395123 + 0.75965677415490 + 0.75272356059822 + 0.74580864698430 + 0.73887843607086 + 0.73182634213335 + 0.72435164762158 + 0.71628985857059 + 0.70761220621276 + 0.69828420381459 + 0.68832146691394 + 0.67775443620754 + 0.66662669096407 + 0.65499310249978 + 0.64291790054400 + 0.63046940228359 + 0.61766191352050 + 0.60456374942910 + 0.59124660926151 + 0.57778447680138 + 0.56425255363221 + 0.55072574231906 + 0.53724869147769 + 0.52385367680585 + 0.51058722139482 + 0.49748226276129 + 0.48455458910510 + 0.99916295062323 + 0.99916502163431 + 0.99916536636705 + 0.99916576877101 + 0.99916623860783 + 0.99916678733923 + 0.99916742844155 + 0.99916817783728 + 0.99916905476195 + 0.99917008449617 + 0.99917130669770 + 0.99917278314521 + 0.99917458844054 + 0.99917680514056 + 0.99917953084490 + 0.99918288535824 + 0.99918701737236 + 0.99919211230002 + 0.99919841411412 + 0.99920624537873 + 0.99921600440805 + 0.99922820690445 + 0.99924352865102 + 0.99926286998576 + 0.99928746385211 + 0.99931909907066 + 0.99936058021216 + 0.99941637972347 + 0.99949424132220 + 0.99961214401007 + 1.00000000000000 + 0.99957268880161 + 0.99937433760782 + 0.99918624841293 + 0.99899577761380 + 0.99879782636152 + 0.99858871014439 + 0.99836482938572 + 0.99812194226882 + 0.99785499896412 + 0.99755855304358 + 0.99722624216417 + 0.99685064367344 + 0.99642374355894 + 0.99594044687318 + 0.99539881248376 + 0.99479102843526 + 0.99410799424894 + 0.99334563221200 + 0.99249451167043 + 0.99153780697664 + 0.99045561722585 + 0.98922568205145 + 0.98782320741579 + 0.98621919656999 + 0.98438202959461 + 0.98227822043768 + 0.97987056265603 + 0.97711767801995 + 0.97397327135512 + 0.97038260443266 + 0.96627332730810 + 0.96156291466150 + 0.95617668157713 + 0.95004592701601 + 0.94310147121759 + 0.93528431702727 + 0.92654669089613 + 0.91685583802980 + 0.90619983926369 + 0.89459450156156 + 0.88208973510048 + 0.86876910021346 + 0.85473836852447 + 0.84014777410287 + 0.82522014055301 + 0.81021331731573 + 0.80275241663480 + 0.79535558243465 + 0.78804013884431 + 0.78081577893226 + 0.77368366212969 + 0.76663611211945 + 0.75965713667112 + 0.75272390815139 + 0.74580898021971 + 0.73887875558692 + 0.73182664830979 + 0.72435194025535 + 0.71629013719627 + 0.70761247039526 + 0.69828445312842 + 0.68832170102226 + 0.67775465488781 + 0.66662689412831 + 0.65499329020557 + 0.64291807301382 + 0.63046955989228 + 0.61766205671442 + 0.60456387877422 + 0.59124672541946 + 0.57778458051370 + 0.56425264568486 + 0.55072582354015 + 0.53724876270010 + 0.52385373886106 + 0.51058727513161 + 0.49748230903955 + 0.48455462878172 + 0.99906777606179 + 0.99906961836081 + 0.99906992501458 + 0.99907028296769 + 0.99907070089931 + 0.99907118900236 + 0.99907175925952 + 0.99907242583444 + 0.99907320581396 + 0.99907412162509 + 0.99907520833395 + 0.99907652040257 + 0.99907812359653 + 0.99908009068670 + 0.99908250764503 + 0.99908547985063 + 0.99908913784684 + 0.99909364399723 + 0.99909921139466 + 0.99910612075529 + 0.99911471675691 + 0.99912544256004 + 0.99913887353942 + 0.99915576669558 + 0.99917714099182 + 0.99920444126184 + 0.99923986161544 + 0.99928669637079 + 0.99934998249930 + 0.99943848667968 + 0.99957268880161 + 1.00000000000000 + 0.99952745918478 + 0.99930069146971 + 0.99908662153297 + 0.99887147323571 + 0.99864909150114 + 0.99841473241921 + 0.99816345152998 + 0.99788971128649 + 0.99758772010347 + 0.99725085648498 + 0.99687149999995 + 0.99644148455729 + 0.99595560805474 + 0.99541184249846 + 0.99480228188699 + 0.99411775558576 + 0.99335414224758 + 0.99250196847501 + 0.99154437000962 + 0.99046141685808 + 0.98923082658416 + 0.98782778784700 + 0.98622328950903 + 0.98438570022148 + 0.98228152487064 + 0.97987354930558 + 0.97712038875389 + 0.97397574232924 + 0.97038486639616 + 0.96627540522024 + 0.96156482855879 + 0.95617844830612 + 0.95004756101532 + 0.94310298466809 + 0.93528572027240 + 0.92654799272375 + 0.91685704592740 + 0.90620095965474 + 0.89459554002809 + 0.88209069660738 + 0.86876998926856 + 0.85473918921502 + 0.84014853031184 + 0.82522083633377 + 0.81021395693449 + 0.80275302976226 + 0.79535617015826 + 0.78804070223352 + 0.78081631903920 + 0.77368417997248 + 0.76663660867932 + 0.75965761288855 + 0.75272436491834 + 0.74580941838040 + 0.73887917590555 + 0.73182705128230 + 0.72435232559044 + 0.71629050428038 + 0.70761281863528 + 0.69828478194768 + 0.68832200995706 + 0.67775494362276 + 0.66662716252083 + 0.65499353831101 + 0.64291830110297 + 0.63046976844302 + 0.61766224629576 + 0.60456405011857 + 0.59124687939300 + 0.57778471807769 + 0.56425276787724 + 0.55072593144579 + 0.53724885741222 + 0.52385382147592 + 0.51058734676217 + 0.49748237081269 + 0.48455468181794 + 0.99896027248769 + 0.99896189970025 + 0.99896217056428 + 0.99896248674098 + 0.99896285590448 + 0.99896328705759 + 0.99896379078797 + 0.99896437960560 + 0.99896506860465 + 0.99896587755528 + 0.99896683721923 + 0.99896799524649 + 0.99896940915146 + 0.99897114263200 + 0.99897327089737 + 0.99897588605580 + 0.99897910203840 + 0.99898306029665 + 0.99898794603718 + 0.99899400258811 + 0.99900152742664 + 0.99901090105629 + 0.99902261410064 + 0.99903730620595 + 0.99905582804469 + 0.99907936760967 + 0.99910969428140 + 0.99914937629542 + 0.99920210532089 + 0.99927362023267 + 0.99937433760782 + 0.99952745918478 + 1.00000000000000 + 0.99947549572306 + 0.99921628035491 + 0.99897331963483 + 0.99873095279320 + 0.99848146207664 + 0.99821841234801 + 0.99793534786610 + 0.99762587278894 + 0.99728293890149 + 0.99689861637735 + 0.99646451103824 + 0.99597526397594 + 0.99542872404767 + 0.99481685677841 + 0.99413039692566 + 0.99336516477932 + 0.99251163029417 + 0.99155287822887 + 0.99046894032678 + 0.98923750523817 + 0.98783373902887 + 0.98622861184946 + 0.98439047755868 + 0.98228582932443 + 0.97987744307848 + 0.97712392561608 + 0.97397896870748 + 0.97038782172808 + 0.96627812148358 + 0.96156733134887 + 0.95618075920936 + 0.95004969858361 + 0.94310496462023 + 0.93528755600838 + 0.92654969570000 + 0.91685862594578 + 0.90620242515251 + 0.89459689837425 + 0.88209195436976 + 0.86877115241192 + 0.85474026315305 + 0.84014952019177 + 0.82522174749673 + 0.81021479498644 + 0.80275383334037 + 0.79535694068637 + 0.78804144111589 + 0.78081702763866 + 0.77368485961635 + 0.76663726064609 + 0.75965823840303 + 0.75272496514043 + 0.74580999439756 + 0.73887972871221 + 0.73182758150624 + 0.72435283285261 + 0.71629098774361 + 0.70761327750839 + 0.69828521544457 + 0.68832241744573 + 0.67775532465848 + 0.66662751688803 + 0.65499386605595 + 0.64291860255452 + 0.63047004420654 + 0.61766249710256 + 0.60456427691908 + 0.59124708331195 + 0.57778490037806 + 0.56425292991827 + 0.55072607465385 + 0.53724898322508 + 0.52385393133002 + 0.51058744212259 + 0.49748245315268 + 0.48455475261238 + 0.99883927788231 + 0.99884070539909 + 0.99884094304399 + 0.99884122045518 + 0.99884154436667 + 0.99884192268370 + 0.99884236470265 + 0.99884288141497 + 0.99884348606616 + 0.99884419596665 + 0.99884503792468 + 0.99884605328798 + 0.99884729197591 + 0.99884880934042 + 0.99885067073177 + 0.99885295613105 + 0.99885576436250 + 0.99885921795381 + 0.99886347702162 + 0.99886875143214 + 0.99887529697178 + 0.99888343946921 + 0.99889359684784 + 0.99890631016149 + 0.99892229250266 + 0.99894252869858 + 0.99896846593671 + 0.99900215877216 + 0.99904645245068 + 0.99910552073922 + 0.99918624841293 + 0.99930069146971 + 0.99947549572306 + 1.00000000000000 + 0.99941572232012 + 0.99911973394809 + 0.99884476250936 + 0.99857227744168 + 0.99829212334872 + 0.99799592782773 + 0.99767615405408 + 0.99732500728172 + 0.99693404869322 + 0.99649452734167 + 0.99600084622050 + 0.99545067407057 + 0.99483579727537 + 0.99414682092980 + 0.99337948607943 + 0.99252418683231 + 0.99156394021931 + 0.99047872735042 + 0.98924619881180 + 0.98784149105749 + 0.98623554979807 + 0.98439670964801 + 0.98229144859368 + 0.97988252975171 + 0.97712854901491 + 0.97398318866128 + 0.97039168905025 + 0.96628167727303 + 0.96157060848296 + 0.95618378544485 + 0.95005249785780 + 0.94310755731061 + 0.93528995956757 + 0.92655192510452 + 0.91686069408054 + 0.90620434315375 + 0.89459867598777 + 0.88209360031136 + 0.86877267462131 + 0.85474166881827 + 0.84015081613801 + 0.82522294079130 + 0.81021589301655 + 0.80275488647472 + 0.79535795079226 + 0.78804241002175 + 0.78081795713371 + 0.77368575143286 + 0.76663811644910 + 0.75965905978516 + 0.75272575360986 + 0.74581075136638 + 0.73888045547373 + 0.73182827886848 + 0.72435350029194 + 0.71629162415065 + 0.70761388181644 + 0.69828578659253 + 0.68832295457176 + 0.67775582714267 + 0.66662798441201 + 0.65499429865377 + 0.64291900062462 + 0.63047040851716 + 0.61766282859477 + 0.60456457682115 + 0.59124735309497 + 0.57778514169327 + 0.56425314454967 + 0.55072626447618 + 0.53724915012898 + 0.52385407720350 + 0.51058756888445 + 0.49748256273936 + 0.48455484695285 + 0.99870344999617 + 0.99870469481989 + 0.99870490208157 + 0.99870514403685 + 0.99870542656222 + 0.99870575656131 + 0.99870614215801 + 0.99870659294321 + 0.99870712048994 + 0.99870773986879 + 0.99870847427903 + 0.99870935934315 + 0.99871043808865 + 0.99871175827732 + 0.99871337634453 + 0.99871536130844 + 0.99871779839620 + 0.99872079316182 + 0.99872448330615 + 0.99872904895204 + 0.99873470914514 + 0.99874174202857 + 0.99875050287214 + 0.99876144912487 + 0.99877517941935 + 0.99879251339968 + 0.99881464320958 + 0.99884323427843 + 0.99888053404821 + 0.99892972021019 + 0.99899577761380 + 0.99908662153297 + 0.99921628035491 + 0.99941572232012 + 1.00000000000000 + 0.99934694404584 + 0.99900955657949 + 0.99869914505696 + 0.99839277379110 + 0.99807738515882 + 0.99774305426409 + 0.99738057541828 + 0.99698061862627 + 0.99653384551742 + 0.99603428134621 + 0.99547932145130 + 0.99486049591876 + 0.99416822851538 + 0.99339815049845 + 0.99254055320175 + 0.99157836285984 + 0.99049149314159 + 0.98925754421185 + 0.98785161349107 + 0.98624461462856 + 0.98440485711026 + 0.98229879916586 + 0.97988918727674 + 0.97713460320863 + 0.97398871693287 + 0.97039675708361 + 0.96628633813219 + 0.96157490454401 + 0.95618775256871 + 0.95005616708518 + 0.94311095514411 + 0.93529310882955 + 0.92655484546862 + 0.91686340254273 + 0.90620685446217 + 0.89460100308453 + 0.88209575480045 + 0.86877466707793 + 0.85474350882322 + 0.84015251277797 + 0.82522450342827 + 0.81021733141349 + 0.80275626635598 + 0.79535927460822 + 0.78804368017428 + 0.78081917595884 + 0.77368692119481 + 0.76663923932917 + 0.75966013785525 + 0.75272678883326 + 0.74581174558267 + 0.73888141035476 + 0.73182919545919 + 0.72435437788958 + 0.71629246127412 + 0.70761467703524 + 0.69828653848019 + 0.68832366195916 + 0.67775648917980 + 0.66662860063894 + 0.65499486906289 + 0.64291952571422 + 0.63047088926852 + 0.61766326621120 + 0.60456497289929 + 0.59124770955477 + 0.57778546069811 + 0.56425342843991 + 0.55072651571616 + 0.53724937120406 + 0.52385427059205 + 0.51058773710766 + 0.49748270833149 + 0.48455497244065 + 0.99855117558617 + 0.99855225579674 + 0.99855243568675 + 0.99855264569869 + 0.99855289094226 + 0.99855317741759 + 0.99855351218498 + 0.99855390359008 + 0.99855436168640 + 0.99855489954159 + 0.99855553712028 + 0.99855630492181 + 0.99855723979032 + 0.99855838271851 + 0.99855978217001 + 0.99856149739004 + 0.99856360151203 + 0.99856618503364 + 0.99856936584172 + 0.99857329786261 + 0.99857816801467 + 0.99858421305414 + 0.99859173440791 + 0.99860111853917 + 0.99861286834980 + 0.99862766763790 + 0.99864650278730 + 0.99867073478482 + 0.99870216494182 + 0.99874327364643 + 0.99879782636152 + 0.99887147323571 + 0.99897331963483 + 0.99911973394809 + 0.99934694404584 + 1.00000000000000 + 0.99926784325746 + 0.99888408918976 + 0.99853395854328 + 0.99818891844927 + 0.99783320907618 + 0.99745466419445 + 0.99704226421117 + 0.99658563987440 + 0.99607818489305 + 0.99551686090841 + 0.99489281942334 + 0.99419622385543 + 0.99342254976129 + 0.99256194688003 + 0.99159721840574 + 0.99050818735206 + 0.98927238656965 + 0.98786486171599 + 0.98625648413331 + 0.98441553030706 + 0.98230843266214 + 0.97989791600277 + 0.97714254368492 + 0.97399596967857 + 0.97040340735657 + 0.96629245467808 + 0.96158054224780 + 0.95619295792613 + 0.95006098049990 + 0.94311541125897 + 0.93529723759785 + 0.92655867283098 + 0.91686695099156 + 0.90621014358861 + 0.89460405013952 + 0.88209857527407 + 0.86877727510984 + 0.85474591720771 + 0.84015473363490 + 0.82522654920994 + 0.81021921503491 + 0.80275807365373 + 0.79536100880388 + 0.78804534442837 + 0.78082077333569 + 0.77368845465776 + 0.76664071172321 + 0.75966155189504 + 0.75272814708030 + 0.74581305042649 + 0.73888266396925 + 0.73183039919817 + 0.72435553080803 + 0.71629356140055 + 0.70761572246051 + 0.69828752729752 + 0.68832459258400 + 0.67775736044875 + 0.66662941190265 + 0.65499562027357 + 0.64292021747627 + 0.63047152283074 + 0.61766384312875 + 0.60456549524889 + 0.59124817983599 + 0.57778588174685 + 0.56425380333346 + 0.55072684769176 + 0.53724966352405 + 0.52385452651102 + 0.51058795992871 + 0.49748290137705 + 0.48455513901515 + 0.99838046990007 + 0.99838140393180 + 0.99838155951261 + 0.99838174115727 + 0.99838195328969 + 0.99838220111037 + 0.99838249073666 + 0.99838282940445 + 0.99838322582129 + 0.99838369127779 + 0.99838424287813 + 0.99838490660962 + 0.99838571387559 + 0.99838669969832 + 0.99838790550362 + 0.99838938195830 + 0.99839119155510 + 0.99839341161348 + 0.99839614268561 + 0.99839951588146 + 0.99840369026278 + 0.99840886694896 + 0.99841530134488 + 0.99842331982880 + 0.99843334524142 + 0.99844594929182 + 0.99846195105617 + 0.99848246969508 + 0.99850896455099 + 0.99854340503157 + 0.99858871014439 + 0.99864909150114 + 0.99873095279320 + 0.99884476250936 + 0.99900955657949 + 0.99926784325746 + 1.00000000000000 + 0.99917697024243 + 0.99874098519986 + 0.99834587617808 + 0.99795691892402 + 0.99755469204466 + 0.99712460976997 + 0.99665433950724 + 0.99613614900453 + 0.99556627477477 + 0.99493528610644 + 0.99423296042670 + 0.99345454578422 + 0.99258999282434 + 0.99162193556595 + 0.99053007375636 + 0.98929184950747 + 0.98788223924348 + 0.98627205811158 + 0.98442953901139 + 0.98232108046464 + 0.97990937887452 + 0.97715297355451 + 0.97400549754437 + 0.97041214426552 + 0.96630049007523 + 0.96158794745867 + 0.95619979352431 + 0.95006729927819 + 0.94312125866118 + 0.93530265308914 + 0.92656369073595 + 0.91687160118941 + 0.90621445219286 + 0.89460804019730 + 0.88210226752733 + 0.86878068849287 + 0.85474906886913 + 0.84015763977413 + 0.82522922641054 + 0.81022168043517 + 0.80276043944111 + 0.79536327923000 + 0.78804752364017 + 0.78082286536853 + 0.77369046339878 + 0.76664264089758 + 0.75966340505079 + 0.75272992756162 + 0.74581476135289 + 0.73888430817440 + 0.73183197842634 + 0.72435704379940 + 0.71629500554495 + 0.70761709521394 + 0.69828882611355 + 0.68832581534159 + 0.67775850556269 + 0.66663047846802 + 0.65499660817235 + 0.64292112746001 + 0.63047235649691 + 0.61766460248084 + 0.60456618298434 + 0.59124879922806 + 0.57778643650864 + 0.56425429749599 + 0.55072728551263 + 0.53725004928757 + 0.52385486448788 + 0.51058825444909 + 0.49748315678588 + 0.48455535962882 + 0.99818887613819 + 0.99818968197840 + 0.99818981623665 + 0.99818997299887 + 0.99819015608804 + 0.99819036999958 + 0.99819062002778 + 0.99819091242489 + 0.99819125472514 + 0.99819165665227 + 0.99819213282812 + 0.99819270531843 + 0.99819340079620 + 0.99819424908684 + 0.99819528550753 + 0.99819655324865 + 0.99819810558056 + 0.99820000838841 + 0.99820234724150 + 0.99820523355953 + 0.99820880248532 + 0.99821322465354 + 0.99821871638432 + 0.99822555339045 + 0.99823409169241 + 0.99824481045181 + 0.99825839226391 + 0.99827576271615 + 0.99829811504233 + 0.99832703478505 + 0.99836482938572 + 0.99841473241921 + 0.99848146207664 + 0.99857227744168 + 0.99869914505696 + 0.99888408918976 + 0.99917697024243 + 1.00000000000000 + 0.99907209947636 + 0.99857710235757 + 0.99813142152729 + 0.99769217300000 + 0.99723595664368 + 0.99674626433078 + 0.99621318470578 + 0.99563166115531 + 0.99499132150891 + 0.99428134717681 + 0.99349664163736 + 0.99262686819897 + 0.99165442396131 + 0.99055883851061 + 0.98931743013212 + 0.98790508167029 + 0.98629253299822 + 0.98444795903103 + 0.98233771343737 + 0.97992445521363 + 0.97716669208104 + 0.97401802961855 + 0.97042363507433 + 0.96631105640725 + 0.96159768240580 + 0.95620877628151 + 0.95007559910763 + 0.94312893539679 + 0.93530975893312 + 0.92657027125091 + 0.91687769619605 + 0.90622009658460 + 0.89461326486132 + 0.88210710030717 + 0.86878515481174 + 0.85475319174554 + 0.84016144091663 + 0.82523272796235 + 0.81022490516047 + 0.80276353408811 + 0.79536624941313 + 0.78805037482938 + 0.78082560286507 + 0.77369309231333 + 0.76664516611905 + 0.75966583122415 + 0.75273225906093 + 0.74581700225222 + 0.73888646216732 + 0.73183404778084 + 0.72435902683669 + 0.71629689881633 + 0.70761889534694 + 0.69829052972061 + 0.68832741958180 + 0.67776000830990 + 0.66663187847231 + 0.65499790522445 + 0.64292232248727 + 0.63047345155267 + 0.61766560015884 + 0.60456708679521 + 0.59124961344467 + 0.57778716599706 + 0.56425494754932 + 0.55072786171576 + 0.53725055726306 + 0.52385530983715 + 0.51058864283532 + 0.49748349389252 + 0.48455565109122 + 0.99797310993679 + 0.99797380434019 + 0.99797392006077 + 0.99797405518672 + 0.99797421301997 + 0.99797439744040 + 0.99797461302087 + 0.99797486516627 + 0.99797516038016 + 0.99797550703293 + 0.99797591759818 + 0.99797641077006 + 0.99797700916092 + 0.99797773812284 + 0.99797862770173 + 0.99797971465759 + 0.99798104431621 + 0.99798267273341 + 0.99798467261782 + 0.99798713854028 + 0.99799018520636 + 0.99799395734465 + 0.99799863816371 + 0.99800446078524 + 0.99801172546374 + 0.99802083483283 + 0.99803235977683 + 0.99804706987592 + 0.99806594881818 + 0.99809028839020 + 0.99812194226882 + 0.99816345152998 + 0.99821841234801 + 0.99829212334872 + 0.99839277379110 + 0.99853395854328 + 0.99874098519986 + 0.99907209947636 + 1.00000000000000 + 0.99895067525949 + 0.99838970292861 + 0.99788665789418 + 0.99738937691026 + 0.99687089266517 + 0.99631657311382 + 0.99571885373912 + 0.99506573651675 + 0.99434543287171 + 0.99355230039970 + 0.99267557327850 + 0.99169730826354 + 0.99059679516324 + 0.98935118031292 + 0.98793521824931 + 0.98631954677904 + 0.98447226283866 + 0.98235966024039 + 0.97994434831672 + 0.97718479297630 + 0.97403456356099 + 0.97043879276728 + 0.96632499107163 + 0.96161051610562 + 0.95622061305789 + 0.95008653023930 + 0.94313904004592 + 0.93531910640380 + 0.92657892230831 + 0.91688570409282 + 0.90622750814632 + 0.89462012162751 + 0.88211343977719 + 0.86879101124745 + 0.85475859615360 + 0.84016642248454 + 0.82523731634260 + 0.81022913071455 + 0.80276758931176 + 0.79537014174075 + 0.78805411150346 + 0.78082919088819 + 0.77369653841757 + 0.76664847674350 + 0.75966901247542 + 0.75273531667238 + 0.74581994156750 + 0.73888928801509 + 0.73183676312056 + 0.72436162944522 + 0.71629938412224 + 0.70762125888624 + 0.69829276698936 + 0.68832952678986 + 0.67776198259783 + 0.66663371813706 + 0.65499960992636 + 0.64292389339205 + 0.63047489130526 + 0.61766691212669 + 0.60456827556302 + 0.59125068461604 + 0.57778812595853 + 0.56425580326052 + 0.55072862052508 + 0.53725122656344 + 0.52385589697946 + 0.51058915525316 + 0.49748393901996 + 0.48455603629682 + 0.99772895022814 + 0.99772954830976 + 0.99772964800144 + 0.99772976441746 + 0.99772990040523 + 0.99773005931881 + 0.99773024510007 + 0.99773046241604 + 0.99773071688176 + 0.99773101569272 + 0.99773136948667 + 0.99773179408805 + 0.99773230864206 + 0.99773293467351 + 0.99773369772763 + 0.99773462904774 + 0.99773576717180 + 0.99773715975397 + 0.99773886853365 + 0.99774097371471 + 0.99774357265015 + 0.99774678807231 + 0.99775077523861 + 0.99775573145492 + 0.99776191038609 + 0.99776965122417 + 0.99777943301247 + 0.99779189868305 + 0.99780786503834 + 0.99782839531967 + 0.99785499896412 + 0.99788971128649 + 0.99793534786610 + 0.99799592782773 + 0.99807738515882 + 0.99818891844927 + 0.99834587617808 + 0.99857710235757 + 0.99895067525949 + 1.00000000000000 + 0.99881106315658 + 0.99817582515328 + 0.99760711198336 + 0.99704316498912 + 0.99645725538257 + 0.99583635817940 + 0.99516541046552 + 0.99443093354051 + 0.99362637014596 + 0.99274028482223 + 0.99175422876249 + 0.99064714452692 + 0.98939593417505 + 0.98797517292104 + 0.98635535794691 + 0.98450447990929 + 0.98238875171748 + 0.97997071606794 + 0.97720878305438 + 0.97405647378336 + 0.97045887505095 + 0.96634344754088 + 0.96162750767104 + 0.95623627712484 + 0.95010098773719 + 0.94315239621301 + 0.93533145374869 + 0.92659034221043 + 0.91689626813320 + 0.90623727942072 + 0.89462915624013 + 0.88212178844077 + 0.86879872033005 + 0.85476570759109 + 0.84017297569610 + 0.82524335122434 + 0.81023468793792 + 0.80277292250670 + 0.79537526081065 + 0.78805902607049 + 0.78083391024126 + 0.77370107148067 + 0.76665283202798 + 0.75967319804695 + 0.75273934010844 + 0.74582380989402 + 0.73889300758529 + 0.73184033781139 + 0.72436505629829 + 0.71630265708645 + 0.70762437202429 + 0.69829571431070 + 0.68833230323492 + 0.67776458432380 + 0.66663614282425 + 0.65500185706056 + 0.64292596444685 + 0.63047678971792 + 0.61766864229647 + 0.60456984351027 + 0.59125209771108 + 0.57778939263080 + 0.56425693269939 + 0.55072962242957 + 0.53725211069334 + 0.52385667302496 + 0.51058983299047 + 0.49748452822032 + 0.48455654661741 + 0.99745162583324 + 0.99745214104507 + 0.99745222693974 + 0.99745232725061 + 0.99745244443564 + 0.99745258138493 + 0.99745274150376 + 0.99745292882248 + 0.99745314818233 + 0.99745340577545 + 0.99745371066821 + 0.99745407626219 + 0.99745451877175 + 0.99745505647716 + 0.99745571108785 + 0.99745650917235 + 0.99745748348604 + 0.99745867454466 + 0.99746013477365 + 0.99746193222781 + 0.99746414954441 + 0.99746689088853 + 0.99747028795549 + 0.99747450797658 + 0.99747976568928 + 0.99748634758288 + 0.99749465698353 + 0.99750523346808 + 0.99751875961337 + 0.99753611833447 + 0.99755855304358 + 0.99758772010347 + 0.99762587278894 + 0.99767615405408 + 0.99774305426409 + 0.99783320907618 + 0.99795691892402 + 0.99813142152729 + 0.99838970292861 + 0.99881106315658 + 1.00000000000000 + 0.99865069832222 + 0.99793151520548 + 0.99728799335512 + 0.99665207979795 + 0.99599664722528 + 0.99530012252100 + 0.99454581049902 + 0.99372551141504 + 0.99282668706687 + 0.99183010633097 + 0.99071419202147 + 0.98945548961009 + 0.98802831792246 + 0.98640297680555 + 0.98454730969303 + 0.98242741865765 + 0.98000575592710 + 0.97724065633464 + 0.97408557626119 + 0.97048554111706 + 0.96636794509331 + 0.96165004981854 + 0.95625704614750 + 0.95012014454919 + 0.94317008130488 + 0.93534779106379 + 0.92660544116325 + 0.91691022524050 + 0.90625017999130 + 0.89464107627356 + 0.88213279673603 + 0.86880887980040 + 0.85477507511494 + 0.84018160463850 + 0.82525129540480 + 0.81024200199381 + 0.80277994132311 + 0.79538199760977 + 0.78806549367662 + 0.78084012101971 + 0.77370703728074 + 0.76665856414618 + 0.75967870716587 + 0.75274463624066 + 0.74582890233147 + 0.73889790470476 + 0.73184504471667 + 0.72436956907150 + 0.71630696771676 + 0.70762847263588 + 0.69829959694389 + 0.68833596115422 + 0.67776801239354 + 0.66663933791617 + 0.65500481843569 + 0.64292869399050 + 0.63047929192091 + 0.61767092293009 + 0.60457191049906 + 0.59125396078562 + 0.57779106292124 + 0.56425842235424 + 0.55073094427284 + 0.53725327761322 + 0.52385769780273 + 0.51059072849759 + 0.49748530728976 + 0.48455722192300 + 0.99713535575849 + 0.99713579986718 + 0.99713587391950 + 0.99713596040472 + 0.99713606144437 + 0.99713617953240 + 0.99713631761094 + 0.99713647915685 + 0.99713666835005 + 0.99713689052079 + 0.99713715340451 + 0.99713746836500 + 0.99713784915544 + 0.99713831131089 + 0.99713887330786 + 0.99713955774270 + 0.99714039249564 + 0.99714141203108 + 0.99714266091756 + 0.99714419694551 + 0.99714609035205 + 0.99714842964759 + 0.99715132670381 + 0.99715492352369 + 0.99715940228829 + 0.99716500564438 + 0.99717207429268 + 0.99718106299922 + 0.99719254544455 + 0.99720726040771 + 0.99722624216417 + 0.99725085648498 + 0.99728293890149 + 0.99732500728172 + 0.99738057541828 + 0.99745466419445 + 0.99755469204466 + 0.99769217300000 + 0.99788665789418 + 0.99817582515328 + 0.99865069832222 + 1.00000000000000 + 0.99846674459394 + 0.99765319135322 + 0.99692934963743 + 0.99621912469141 + 0.99548439435928 + 0.99470154354835 + 0.99385914669733 + 0.99294271931451 + 0.99193175374955 + 0.99080386119795 + 0.98953504816669 + 0.98809925620904 + 0.98646650160977 + 0.98460441972306 + 0.98247895803809 + 0.98005244413534 + 0.97728311010972 + 0.97412432461600 + 0.97052103028679 + 0.96640053193664 + 0.96168001797790 + 0.95628463859515 + 0.95014557633614 + 0.94319354077317 + 0.93536944493748 + 0.92662543707962 + 0.91692869379995 + 0.90626723689520 + 0.89465682479927 + 0.88214733046642 + 0.86882228432918 + 0.85478742780052 + 0.84019297791736 + 0.82526176206260 + 0.81025163560766 + 0.80278918504100 + 0.79539086913669 + 0.78807401014942 + 0.78084829893542 + 0.77371489243127 + 0.76666611156028 + 0.75968596103988 + 0.75275160985876 + 0.74583560800458 + 0.73890435352338 + 0.73185124341836 + 0.72437551249444 + 0.71631264526034 + 0.70763387387082 + 0.69830471132288 + 0.68834077973391 + 0.67777252833736 + 0.66664354705103 + 0.65500871973612 + 0.64293228991061 + 0.63048258836308 + 0.61767392750065 + 0.60457463366883 + 0.59125641541815 + 0.57779326375358 + 0.56426038546597 + 0.55073268663090 + 0.53725481625411 + 0.52385904959579 + 0.51059191039670 + 0.49748633616643 + 0.48455811439771 + 0.99677321616251 + 0.99677359931320 + 0.99677366320826 + 0.99677373783469 + 0.99677382502531 + 0.99677392693108 + 0.99677404609292 + 0.99677418551941 + 0.99677434881707 + 0.99677454057186 + 0.99677476740256 + 0.99677503896721 + 0.99677536695337 + 0.99677576458851 + 0.99677624761698 + 0.99677683529683 + 0.99677755138792 + 0.99677842526015 + 0.99677949485184 + 0.99678080933067 + 0.99678242848681 + 0.99678442765891 + 0.99678690207264 + 0.99678997255288 + 0.99679379403469 + 0.99679857261322 + 0.99680459705337 + 0.99681225218964 + 0.99682202265748 + 0.99683453067995 + 0.99685064367344 + 0.99687149999995 + 0.99689861637735 + 0.99693404869322 + 0.99698061862627 + 0.99704226421117 + 0.99712460976997 + 0.99723595664368 + 0.99738937691026 + 0.99760711198336 + 0.99793151520548 + 0.99846674459394 + 1.00000000000000 + 0.99825739516170 + 0.99734333435966 + 0.99653634509126 + 0.99574080899313 + 0.99491518575245 + 0.99404087554421 + 0.99309962635390 + 0.99206869709968 + 0.99092436013449 + 0.98964177031911 + 0.98819429332630 + 0.98655152554623 + 0.98468080059652 + 0.98254784548175 + 0.98011481280095 + 0.97733979220760 + 0.97417603190169 + 0.97056836179065 + 0.96644396569201 + 0.96171993348861 + 0.95632136133008 + 0.95017939505952 + 0.94322470907105 + 0.93539818795527 + 0.92665195476206 + 0.91695316346647 + 0.90628981595820 + 0.89467765400711 + 0.88216653747949 + 0.86883998591463 + 0.85480372941432 + 0.84020797810744 + 0.82527555950174 + 0.81026432962273 + 0.80280136319085 + 0.79540255517853 + 0.78808522705589 + 0.78085906877858 + 0.77372523630986 + 0.76667604952274 + 0.75969551199950 + 0.75276079150401 + 0.74584443669465 + 0.73891284397627 + 0.73185940459583 + 0.72438333759003 + 0.71632012028517 + 0.70764098504522 + 0.69831144470239 + 0.68834712348612 + 0.67777847342002 + 0.66664908793455 + 0.65501385506165 + 0.64293702292423 + 0.63048692687986 + 0.61767788159980 + 0.60457821721957 + 0.59125964547705 + 0.57779615985084 + 0.56426296891251 + 0.55073497989419 + 0.53725684186756 + 0.52386082983042 + 0.51059346758323 + 0.49748769247985 + 0.48455929163364 + 0.99635761429734 + 0.99635794516931 + 0.99635800035141 + 0.99635806480133 + 0.99635814010543 + 0.99635822812117 + 0.99635833104676 + 0.99635845148050 + 0.99635859253867 + 0.99635875817539 + 0.99635895406118 + 0.99635918842922 + 0.99635947123701 + 0.99635981378017 + 0.99636022950428 + 0.99636073485668 + 0.99636135012747 + 0.99636210039564 + 0.99636301803426 + 0.99636414496393 + 0.99636553219381 + 0.99636724400284 + 0.99636936162003 + 0.99637198811745 + 0.99637525560598 + 0.99637933964983 + 0.99638448584453 + 0.99639102113566 + 0.99639935686555 + 0.99641002012856 + 0.99642374355894 + 0.99644148455729 + 0.99646451103824 + 0.99649452734167 + 0.99653384551742 + 0.99658563987440 + 0.99665433950724 + 0.99674626433078 + 0.99687089266517 + 0.99704316498912 + 0.99728799335512 + 0.99765319135322 + 0.99825739516170 + 1.00000000000000 + 0.99802864272252 + 0.99701002666947 + 0.99610667901628 + 0.99521279113199 + 0.99429051139644 + 0.99331329727221 + 0.99225411959800 + 0.99108688072646 + 0.98978531253262 + 0.98832186083332 + 0.98666547695544 + 0.98478304307348 + 0.98263996311449 + 0.98019813846062 + 0.97741545759129 + 0.97424500089546 + 0.97063144307305 + 0.96650180295477 + 0.96177303706165 + 0.95637016918957 + 0.95022429650551 + 0.94326604676527 + 0.93543626690780 + 0.92668704650779 + 0.91698550931444 + 0.90631963052810 + 0.89470512946664 + 0.88219184822218 + 0.86886329139197 + 0.85482517350247 + 0.84022769494553 + 0.82529368285760 + 0.81028099356816 + 0.80281734568451 + 0.79541788810656 + 0.78809994119954 + 0.78087319367181 + 0.77373880013687 + 0.76668907903642 + 0.75970803240633 + 0.75277282634535 + 0.74585600771907 + 0.73892397073780 + 0.73187009901748 + 0.72439359080588 + 0.71632991395771 + 0.70765030110377 + 0.69832026485411 + 0.68835543222261 + 0.67778625891390 + 0.66665634299004 + 0.65502057797723 + 0.64294321807018 + 0.63049260464821 + 0.61768305536694 + 0.60458290536548 + 0.59126387057250 + 0.57779994772292 + 0.56426634771434 + 0.55073797927291 + 0.53725949150700 + 0.52386315900796 + 0.51059550559092 + 0.49748946832855 + 0.48456083377734 + 0.99588377103591 + 0.99588405710948 + 0.99588410482187 + 0.99588416055154 + 0.99588422566414 + 0.99588430177089 + 0.99588439077422 + 0.99588449491822 + 0.99588461689983 + 0.99588476013093 + 0.99588492948689 + 0.99588513200878 + 0.99588537622631 + 0.99588567181219 + 0.99588603028836 + 0.99588646575221 + 0.99588699558846 + 0.99588764127499 + 0.99588843052979 + 0.99588939923092 + 0.99589059104508 + 0.99589206099489 + 0.99589387862315 + 0.99589613216175 + 0.99589893467237 + 0.99590243632092 + 0.99590684690860 + 0.99591244556301 + 0.99591958329368 + 0.99592870932568 + 0.99594044687318 + 0.99595560805474 + 0.99597526397594 + 0.99600084622050 + 0.99603428134621 + 0.99607818489305 + 0.99613614900453 + 0.99621318470578 + 0.99631657311382 + 0.99645725538257 + 0.99665207979795 + 0.99692934963743 + 0.99734333435966 + 0.99802864272252 + 1.00000000000000 + 0.99778753529266 + 0.99664804134264 + 0.99563366619255 + 0.99463520866647 + 0.99360417401961 + 0.99250423596111 + 0.99130472664977 + 0.98997684342629 + 0.98849148827208 + 0.98681658255474 + 0.98491831163990 + 0.98276159355622 + 0.98030796160054 + 0.97751501577878 + 0.97433560016314 + 0.97071417468911 + 0.96657753360000 + 0.96184245347045 + 0.95643386088197 + 0.95028278791260 + 0.94331980019848 + 0.93548569460619 + 0.92673251610186 + 0.91702734803349 + 0.90635812978061 + 0.89474055035322 + 0.88222442760896 + 0.86889324552843 + 0.85485269707707 + 0.84025296880191 + 0.82531688625210 + 0.81030230513900 + 0.80283777542299 + 0.79543747819931 + 0.78811873229677 + 0.78089122470911 + 0.77375610822136 + 0.76670569932251 + 0.75972399796768 + 0.75278816802332 + 0.74587075398102 + 0.73893814714656 + 0.73188372126295 + 0.72440664784259 + 0.71634238257339 + 0.70766215843766 + 0.69833148777380 + 0.68836600118305 + 0.67779615910504 + 0.66666556554713 + 0.65502912109205 + 0.64295108770016 + 0.63049981444976 + 0.61768962281165 + 0.60458885430388 + 0.59126923018266 + 0.57780475131145 + 0.56427063150159 + 0.55074178132002 + 0.53726284984502 + 0.52386611106379 + 0.51059808871991 + 0.49749171943579 + 0.48456278898348 + 0.99535002011153 + 0.99535026778612 + 0.99535030909651 + 0.99535035734532 + 0.99535041371966 + 0.99535047961344 + 0.99535055667192 + 0.99535064684106 + 0.99535075245350 + 0.99535087646090 + 0.99535102306778 + 0.99535119833479 + 0.99535140959634 + 0.99535166517666 + 0.99535197499871 + 0.99535235119428 + 0.99535280871760 + 0.99535336606141 + 0.99535404707098 + 0.99535488258780 + 0.99535591017663 + 0.99535717717245 + 0.99535874338568 + 0.99536068471460 + 0.99536309840578 + 0.99536611355990 + 0.99536991045785 + 0.99537472886385 + 0.99538087022253 + 0.99538872002111 + 0.99539881248376 + 0.99541184249846 + 0.99542872404767 + 0.99545067407057 + 0.99547932145130 + 0.99551686090841 + 0.99556627477477 + 0.99563166115531 + 0.99571885373912 + 0.99583635817940 + 0.99599664722528 + 0.99621912469141 + 0.99653634509126 + 0.99701002666947 + 0.99778753529266 + 1.00000000000000 + 0.99752131010342 + 0.99624573733581 + 0.99511450873783 + 0.99399896857317 + 0.99283868081088 + 0.99159309946381 + 0.99022853648172 + 0.98871314854004 + 0.98701314019888 + 0.98509358490966 + 0.98291865039650 + 0.98044931999195 + 0.97764277431868 + 0.97445152190730 + 0.97081972515828 + 0.96667387499515 + 0.96193050737820 + 0.95651441817142 + 0.95035655169296 + 0.94338739060855 + 0.93554766495757 + 0.92678936024332 + 0.91707950590414 + 0.90640599339389 + 0.89478447084358 + 0.88226472296088 + 0.86893020509021 + 0.85488658038270 + 0.84028401547351 + 0.82534533174576 + 0.81032838214201 + 0.80286275127180 + 0.79546140734562 + 0.78814166707608 + 0.78091321514335 + 0.77377720187120 + 0.76672594115771 + 0.75974343020908 + 0.75280682996272 + 0.74588868181814 + 0.73895537335513 + 0.73190026603463 + 0.72442249841372 + 0.71635751123484 + 0.70767653795224 + 0.69834509061621 + 0.68837880426852 + 0.67780814517709 + 0.66667672464249 + 0.65503945186836 + 0.64296059829699 + 0.63050852235634 + 0.61769755012317 + 0.60459603081454 + 0.59127569208642 + 0.57781053970314 + 0.56427579090308 + 0.55074635835810 + 0.53726689098269 + 0.52386966192157 + 0.51060119470852 + 0.49749442532868 + 0.48456513851637 + 0.99474886110029 + 0.99474907564768 + 0.99474911143199 + 0.99474915322712 + 0.99474920206039 + 0.99474925913952 + 0.99474932588639 + 0.99474940399091 + 0.99474949547383 + 0.99474960288900 + 0.99474972986829 + 0.99474988165692 + 0.99475006458715 + 0.99475028585562 + 0.99475055403364 + 0.99475087960265 + 0.99475127548540 + 0.99475175765977 + 0.99475234671587 + 0.99475306930199 + 0.99475395786335 + 0.99475505328618 + 0.99475640724950 + 0.99475808530950 + 0.99476017148123 + 0.99476277728414 + 0.99476605843726 + 0.99477022203249 + 0.99477552837340 + 0.99478231019842 + 0.99479102843526 + 0.99480228188699 + 0.99481685677841 + 0.99483579727537 + 0.99486049591876 + 0.99489281942334 + 0.99493528610644 + 0.99499132150891 + 0.99506573651675 + 0.99516541046552 + 0.99530012252100 + 0.99548439435928 + 0.99574080899313 + 0.99610667901628 + 0.99664804134264 + 0.99752131010342 + 1.00000000000000 + 0.99722607611288 + 0.99580772771459 + 0.99454520587095 + 0.99329027290651 + 0.99197654983487 + 0.99055968405150 + 0.98900249643840 + 0.98726813090511 + 0.98531979045224 + 0.98312043341727 + 0.98063019217433 + 0.97780562023082 + 0.97459873897826 + 0.97095329207116 + 0.96679535725278 + 0.96204114677252 + 0.95661527881289 + 0.95044857788291 + 0.94347141478136 + 0.93562442961769 + 0.92685952810977 + 0.91714366748927 + 0.90646467485834 + 0.89483814312410 + 0.88231381152033 + 0.86897509557807 + 0.85492761725729 + 0.84032151469701 + 0.82537960076962 + 0.81035972209632 + 0.80289273368371 + 0.79549010196887 + 0.78816914078688 + 0.78093953170050 + 0.77380242175556 + 0.76675012141195 + 0.75976662425497 + 0.75282908742429 + 0.74591004830722 + 0.73897588974048 + 0.73191995812650 + 0.72444135207453 + 0.71637549429330 + 0.70769361887857 + 0.69836123759498 + 0.68839399089916 + 0.67782235210185 + 0.66668994129154 + 0.65505167800818 + 0.64297184501277 + 0.63051881185781 + 0.61770691003874 + 0.60460449784784 + 0.59128331040463 + 0.57781735914179 + 0.56428186517925 + 0.55075174349744 + 0.53727164263968 + 0.52387383458743 + 0.51060484248823 + 0.49749760144273 + 0.48456789485613 + 0.99407143045154 + 0.99407161629497 + 0.99407164728969 + 0.99407168349120 + 0.99407172578782 + 0.99407177522748 + 0.99407183304268 + 0.99407190069098 + 0.99407197992394 + 0.99407207295552 + 0.99407218293614 + 0.99407231441195 + 0.99407247287894 + 0.99407266457055 + 0.99407289692198 + 0.99407317902033 + 0.99407352206832 + 0.99407393991039 + 0.99407445040391 + 0.99407507665497 + 0.99407584680030 + 0.99407679629681 + 0.99407796995592 + 0.99407942464201 + 0.99408123322463 + 0.99408349244725 + 0.99408633744234 + 0.99408994798334 + 0.99409454998282 + 0.99410043209461 + 0.99410799424894 + 0.99411775558576 + 0.99413039692566 + 0.99414682092980 + 0.99416822851538 + 0.99419622385543 + 0.99423296042670 + 0.99428134717681 + 0.99434543287171 + 0.99443093354051 + 0.99454581049902 + 0.99470154354835 + 0.99491518575245 + 0.99521279113199 + 0.99563366619255 + 0.99624573733581 + 0.99722607611288 + 1.00000000000000 + 0.99691259313224 + 0.99533212488782 + 0.99391259447627 + 0.99249202973691 + 0.99099784670486 + 0.98938110558541 + 0.98759897906531 + 0.98561130238606 + 0.98337897734778 + 0.98086076136015 + 0.97801223659266 + 0.97478469707026 + 0.97112128453956 + 0.96694750637177 + 0.96217913472780 + 0.95674054298409 + 0.95056238958330 + 0.94357489280713 + 0.93571857052333 + 0.92694522062673 + 0.91722170308800 + 0.90653575834654 + 0.89490290447891 + 0.88237281831196 + 0.86902886003399 + 0.85497659486668 + 0.84036612041299 + 0.82542023427317 + 0.81039677111561 + 0.80292812750519 + 0.79552392943336 + 0.78820148684100 + 0.78097047711650 + 0.77383204293418 + 0.76677849021971 + 0.75979380783098 + 0.75285514794347 + 0.74593504280558 + 0.73899986923701 + 0.73194295540825 + 0.72446335224099 + 0.71639646104361 + 0.70771351675981 + 0.69838003092056 + 0.68841165047250 + 0.67783885711741 + 0.66670528133387 + 0.65506585482434 + 0.64298487360134 + 0.63053072017761 + 0.61771773226802 + 0.60461427858952 + 0.59129210276802 + 0.57782522257703 + 0.56428886338012 + 0.55075794256629 + 0.53727710800845 + 0.52387863011944 + 0.51060903141540 + 0.49750124582394 + 0.48457105507732 + 0.99331380161081 + 0.99331396260200 + 0.99331398944973 + 0.99331402081033 + 0.99331405744736 + 0.99331410027246 + 0.99331415035006 + 0.99331420894576 + 0.99331427757203 + 0.99331435815054 + 0.99331445341976 + 0.99331456733671 + 0.99331470468921 + 0.99331487090838 + 0.99331507245783 + 0.99331531724509 + 0.99331561501957 + 0.99331597783649 + 0.99331642123845 + 0.99331696536377 + 0.99331763471476 + 0.99331846018607 + 0.99331948082751 + 0.99332074617942 + 0.99332231975252 + 0.99332428590240 + 0.99332676256954 + 0.99332990672148 + 0.99333391556708 + 0.99333904099890 + 0.99334563221200 + 0.99335414224758 + 0.99336516477932 + 0.99337948607943 + 0.99339815049845 + 0.99342254976129 + 0.99345454578422 + 0.99349664163736 + 0.99355230039970 + 0.99362637014596 + 0.99372551141504 + 0.99385914669733 + 0.99404087554421 + 0.99429051139644 + 0.99463520866647 + 0.99511450873783 + 0.99580772771459 + 0.99691259313224 + 1.00000000000000 + 0.99656851921425 + 0.99479641311869 + 0.99319187002972 + 0.99157765049330 + 0.98987375158130 + 0.98802427540676 + 0.98598249424441 + 0.98370560642455 + 0.98115004922472 + 0.97826984961620 + 0.97501518814842 + 0.97132832680494 + 0.96713398019978 + 0.96234732007458 + 0.95689237899742 + 0.95069958213934 + 0.94369893816236 + 0.93583079766795 + 0.92704681235378 + 0.91731371120197 + 0.90661911812593 + 0.89497845008857 + 0.88244129844681 + 0.86909094691612 + 0.85503288317819 + 0.84041714775464 + 0.82546651239625 + 0.81043879097068 + 0.80296819066438 + 0.79556214695496 + 0.78823796453496 + 0.78100531524639 + 0.77386533601751 + 0.76681032683999 + 0.75982427042865 + 0.75288431260755 + 0.74596297908902 + 0.73902663923229 + 0.73196859987206 + 0.72448785720578 + 0.71641978820132 + 0.70773562889625 + 0.69840089070069 + 0.68843122804151 + 0.67785713217447 + 0.66672224530669 + 0.65508151278874 + 0.64299924539535 + 0.63054383996480 + 0.61772964092340 + 0.60462502832060 + 0.59130175487276 + 0.57783384498434 + 0.56429652830797 + 0.55076472450450 + 0.53728308037034 + 0.52388386432359 + 0.51061359797264 + 0.49750521378463 + 0.48457449152248 + 0.99246669130886 + 0.99246683078344 + 0.99246685404292 + 0.99246688120846 + 0.99246691294861 + 0.99246695004511 + 0.99246699342240 + 0.99246704417611 + 0.99246710362144 + 0.99246717341883 + 0.99246725595643 + 0.99246735469349 + 0.99246747381503 + 0.99246761807008 + 0.99246779310147 + 0.99246800581871 + 0.99246826473487 + 0.99246858038664 + 0.99246896637405 + 0.99246944031246 + 0.99247002365480 + 0.99247074343603 + 0.99247163384000 + 0.99247273825021 + 0.99247411227915 + 0.99247582985950 + 0.99247799451723 + 0.99248074412655 + 0.99248425183659 + 0.99248873875347 + 0.99249451167043 + 0.99250196847501 + 0.99251163029417 + 0.99252418683231 + 0.99254055320175 + 0.99256194688003 + 0.99258999282434 + 0.99262686819897 + 0.99267557327850 + 0.99274028482223 + 0.99282668706687 + 0.99294271931451 + 0.99309962635390 + 0.99331329727221 + 0.99360417401961 + 0.99399896857317 + 0.99454520587095 + 0.99533212488782 + 0.99656851921425 + 1.00000000000000 + 0.99617419108618 + 0.99417863523388 + 0.99235905941599 + 0.99052062518354 + 0.98857311743510 + 0.98645544898324 + 0.98411759204951 + 0.98151182780305 + 0.97858957500650 + 0.97529924631121 + 0.97158178077832 + 0.96736076888233 + 0.96255055023342 + 0.95707467463428 + 0.95086323438925 + 0.94384594661194 + 0.93596293089048 + 0.92716563938824 + 0.91742062404964 + 0.90671535189057 + 0.89506510333791 + 0.88251935311010 + 0.86916127992772 + 0.85509626644697 + 0.84047427386496 + 0.82551803290040 + 0.81048532374293 + 0.80301244518573 + 0.79560426107332 + 0.78827806908538 + 0.78104353372145 + 0.77390178433031 + 0.76684511316492 + 0.75985749499288 + 0.75291606749994 + 0.74599334813148 + 0.73905569703886 + 0.73199639650831 + 0.72451438137761 + 0.71644500156359 + 0.70775949448259 + 0.69842337157825 + 0.68845229567950 + 0.67787676863251 + 0.66674044551167 + 0.65509828648781 + 0.64301461825337 + 0.63055785294107 + 0.61774234190451 + 0.60463647702479 + 0.59131202031077 + 0.57784300275810 + 0.56430465807271 + 0.55077190785348 + 0.53728939732270 + 0.52388939244667 + 0.51061841362218 + 0.49750939157582 + 0.48457810382996 + 0.99151340634556 + 0.99151352718197 + 0.99151354733247 + 0.99151357086541 + 0.99151359835909 + 0.99151363049492 + 0.99151366806940 + 0.99151371203304 + 0.99151376352143 + 0.99151382398182 + 0.99151389549479 + 0.99151398109480 + 0.99151408445908 + 0.99151420974307 + 0.99151436189767 + 0.99151454696924 + 0.99151477243106 + 0.99151504751545 + 0.99151538416507 + 0.99151579786563 + 0.99151630746164 + 0.99151693671823 + 0.99151771568488 + 0.99151868250321 + 0.99151988609101 + 0.99152139153672 + 0.99152329017477 + 0.99152570373147 + 0.99152878501884 + 0.99153272910061 + 0.99153780697664 + 0.99154437000962 + 0.99155287822887 + 0.99156394021931 + 0.99157836285984 + 0.99159721840574 + 0.99162193556595 + 0.99165442396131 + 0.99169730826354 + 0.99175422876249 + 0.99183010633097 + 0.99193175374955 + 0.99206869709968 + 0.99225411959800 + 0.99250423596111 + 0.99283868081088 + 0.99329027290651 + 0.99391259447627 + 0.99479641311869 + 0.99617419108618 + 1.00000000000000 + 0.99571813882439 + 0.99346305810590 + 0.99139451228616 + 0.98929556190760 + 0.98706728612217 + 0.98464376757120 + 0.98196917651190 + 0.97899026010688 + 0.97565247268984 + 0.97189467564526 + 0.96763880691027 + 0.96279801737560 + 0.95729515513331 + 0.95105982769866 + 0.94402133955143 + 0.93611948657903 + 0.92730544557155 + 0.91754552701714 + 0.90682698530580 + 0.89516491582516 + 0.88260863424658 + 0.86924117571952 + 0.85516778122781 + 0.84053830288526 + 0.82557540947452 + 0.81053682983421 + 0.80306128721151 + 0.79565061118927 + 0.78832209005030 + 0.78108537850722 + 0.77394159593451 + 0.76688302439884 + 0.75989362832589 + 0.75295053490529 + 0.74602625104242 + 0.73908712543574 + 0.73202641200955 + 0.72454297680182 + 0.71647213968000 + 0.70778513974133 + 0.69844748865826 + 0.68847485865641 + 0.67789776327350 + 0.66675987160581 + 0.65511615982776 + 0.64303097163962 + 0.63057273535292 + 0.61775580932580 + 0.60464859762440 + 0.59132287160980 + 0.57785266864721 + 0.56431322610375 + 0.55077946704581 + 0.53729603452671 + 0.52389519152874 + 0.51062345687958 + 0.49751375924659 + 0.48458187360742 + 0.99043414675984 + 0.99043425145976 + 0.99043426891870 + 0.99043428930746 + 0.99043431312872 + 0.99043434096922 + 0.99043437352272 + 0.99043441160899 + 0.99043445621335 + 0.99043450859142 + 0.99043457056507 + 0.99043464480583 + 0.99043473454741 + 0.99043484344449 + 0.99043497584326 + 0.99043513706356 + 0.99043533367671 + 0.99043557380375 + 0.99043586796819 + 0.99043622982897 + 0.99043667600964 + 0.99043722746914 + 0.99043791073017 + 0.99043875945902 + 0.99043981684800 + 0.99044114044543 + 0.99044281117575 + 0.99044493702151 + 0.99044765345442 + 0.99045113334587 + 0.99045561722585 + 0.99046141685808 + 0.99046894032678 + 0.99047872735042 + 0.99049149314159 + 0.99050818735206 + 0.99053007375636 + 0.99055883851061 + 0.99059679516324 + 0.99064714452692 + 0.99071419202147 + 0.99080386119795 + 0.99092436013449 + 0.99108688072646 + 0.99130472664977 + 0.99159309946381 + 0.99197654983487 + 0.99249202973691 + 0.99319187002972 + 0.99417863523388 + 0.99571813882439 + 1.00000000000000 + 0.99518984722037 + 0.99263378041118 + 0.99027555422508 + 0.98787607797405 + 0.98532739450663 + 0.98255582331467 + 0.97949898498520 + 0.97609704005090 + 0.97228540359531 + 0.96798347011965 + 0.96310262612293 + 0.95756466751928 + 0.95129847830459 + 0.94423276656487 + 0.93630686682475 + 0.92747157039825 + 0.91769285476789 + 0.90695768374474 + 0.89528090059720 + 0.88271160375257 + 0.86933263240981 + 0.85524903674052 + 0.84061051983038 + 0.82563966005004 + 0.81059411065165 + 0.80311542680817 + 0.79570182628345 + 0.78837058472654 + 0.78113134383489 + 0.77398520971274 + 0.76692445100377 + 0.75993301856474 + 0.75298802595317 + 0.74606196652780 + 0.73912117458206 + 0.73205887101951 + 0.72457384432988 + 0.71650138083406 + 0.70781272163948 + 0.69847337885011 + 0.68849903521819 + 0.67792021717395 + 0.66678060908558 + 0.65513520435010 + 0.64304836479020 + 0.63058853573229 + 0.61777008249643 + 0.60466142158779 + 0.59133433361735 + 0.57786286196170 + 0.56432224710549 + 0.55078741296685 + 0.53730299971708 + 0.52390126672424 + 0.51062873081631 + 0.49751831822675 + 0.48458580103418 + 0.98920673014516 + 0.98920682090268 + 0.98920683603552 + 0.98920685370769 + 0.98920687435366 + 0.98920689848221 + 0.98920692669478 + 0.98920695970074 + 0.98920699835824 + 0.98920704375288 + 0.98920709748450 + 0.98920716191110 + 0.98920723988688 + 0.98920733463130 + 0.98920744998235 + 0.98920759062284 + 0.98920776235316 + 0.98920797233816 + 0.98920822988221 + 0.98920854707907 + 0.98920893864219 + 0.98920942312762 + 0.98921002402390 + 0.98921077116145 + 0.98921170282085 + 0.98921287006812 + 0.98921434493559 + 0.98921622360454 + 0.98921862668762 + 0.98922170803321 + 0.98922568205145 + 0.98923082658416 + 0.98923750523817 + 0.98924619881180 + 0.98925754421185 + 0.98927238656965 + 0.98929184950747 + 0.98931743013212 + 0.98935118031292 + 0.98939593417505 + 0.98945548961009 + 0.98953504816669 + 0.98964177031911 + 0.98978531253262 + 0.98997684342629 + 0.99022853648172 + 0.99055968405150 + 0.99099784670486 + 0.99157765049330 + 0.99235905941599 + 0.99346305810590 + 0.99518984722037 + 1.00000000000000 + 0.99457754977071 + 0.99167053502531 + 0.98897767910798 + 0.98623489513430 + 0.98332127571322 + 0.98015433600098 + 0.97666390095689 + 0.97277926489642 + 0.96841568016383 + 0.96348178997417 + 0.95789775345436 + 0.95159134332644 + 0.94449038423076 + 0.93653353966846 + 0.92767105237539 + 0.91786843447024 + 0.90711224863185 + 0.89541699226324 + 0.88283146612405 + 0.86943824187562 + 0.85534211263959 + 0.84069257871197 + 0.82571208918200 + 0.81065818865045 + 0.80317576786121 + 0.79575870524942 + 0.78842425951534 + 0.78118205493632 + 0.77403317995898 + 0.76696988542471 + 0.75997610430498 + 0.75302893234275 + 0.74610084533690 + 0.73915815932146 + 0.73209405638485 + 0.72460723708006 + 0.71653295003781 + 0.70784243871103 + 0.69850121583899 + 0.68852497596498 + 0.67794425973209 + 0.66680276811578 + 0.65515551301130 + 0.64306687546792 + 0.63060531859604 + 0.61778521448047 + 0.60467499217284 + 0.59134644128504 + 0.57787361064594 + 0.56433174313445 + 0.55079576274509 + 0.53731030590112 + 0.52390762762155 + 0.51063424222761 + 0.49752307306285 + 0.48458988889826 + 0.98780642484108 + 0.98780650357126 + 0.98780651669659 + 0.98780653202552 + 0.98780654993361 + 0.98780657086101 + 0.98780659533158 + 0.98780662395720 + 0.98780665747879 + 0.98780669685215 + 0.98780674347528 + 0.98780679943819 + 0.98780686726633 + 0.98780694980921 + 0.98780705045384 + 0.98780717335104 + 0.98780732362491 + 0.98780750762307 + 0.98780773360073 + 0.98780801230072 + 0.98780835679145 + 0.98780878356521 + 0.98780931350035 + 0.98780997311758 + 0.98781079647053 + 0.98781182906031 + 0.98781313523099 + 0.98781480103482 + 0.98781693428603 + 0.98781967243795 + 0.98782320741579 + 0.98782778784700 + 0.98783373902887 + 0.98784149105749 + 0.98785161349107 + 0.98786486171599 + 0.98788223924348 + 0.98790508167029 + 0.98793521824931 + 0.98797517292104 + 0.98802831792246 + 0.98809925620904 + 0.98819429332630 + 0.98832186083332 + 0.98849148827208 + 0.98871314854004 + 0.98900249643840 + 0.98938110558541 + 0.98987375158130 + 0.99052062518354 + 0.99139451228616 + 0.99263378041118 + 0.99457754977071 + 1.00000000000000 + 0.99386456716586 + 0.99055144636380 + 0.98747574824316 + 0.98434145444422 + 0.98101288019549 + 0.97739709369765 + 0.97341151352238 + 0.96896415221224 + 0.96395913903302 + 0.95831397295073 + 0.95195466052286 + 0.94480767913538 + 0.93681069281602 + 0.92791314817042 + 0.91807989671118 + 0.90729694070671 + 0.89557829899624 + 0.88297236242502 + 0.86956133661119 + 0.85544966780474 + 0.84078658076345 + 0.82579434222201 + 0.81073034295360 + 0.80324343623500 + 0.79582223874401 + 0.78848398635299 + 0.78123828001226 + 0.77408618459221 + 0.76701992724849 + 0.76002341729320 + 0.75307372703249 + 0.74614330940013 + 0.73919845705883 + 0.73213230601724 + 0.72464345649392 + 0.71656711445245 + 0.70787452598661 + 0.69853120466912 + 0.68855285822866 + 0.67797004296720 + 0.66682647787749 + 0.65517719464965 + 0.64308659462026 + 0.63062315937037 + 0.61780126732312 + 0.60468936001425 + 0.59135923558157 + 0.57788494753055 + 0.56434174019374 + 0.55080453667104 + 0.53731796860864 + 0.52391428579811 + 0.51063999943982 + 0.49752802947454 + 0.48459414087270 + 0.98620428673301 + 0.98620435510345 + 0.98620436650141 + 0.98620437981216 + 0.98620439536187 + 0.98620441353508 + 0.98620443477860 + 0.98620445963033 + 0.98620448873798 + 0.98620452292155 + 0.98620456342299 + 0.98620461209225 + 0.98620467118124 + 0.98620474320873 + 0.98620483118478 + 0.98620493878506 + 0.98620507056187 + 0.98620523215804 + 0.98620543091640 + 0.98620567641898 + 0.98620598031285 + 0.98620635730401 + 0.98620682601906 + 0.98620741012205 + 0.98620814001445 + 0.98620905638325 + 0.98621021694044 + 0.98621169896251 + 0.98621359918999 + 0.98621604090880 + 0.98621919656999 + 0.98622328950903 + 0.98622861184946 + 0.98623554979807 + 0.98624461462856 + 0.98625648413331 + 0.98627205811158 + 0.98629253299822 + 0.98631954677904 + 0.98635535794691 + 0.98640297680555 + 0.98646650160977 + 0.98655152554623 + 0.98666547695544 + 0.98681658255474 + 0.98701314019888 + 0.98726813090511 + 0.98759897906531 + 0.98802427540676 + 0.98857311743510 + 0.98929556190760 + 0.99027555422508 + 0.99167053502531 + 0.99386456716586 + 1.00000000000000 + 0.99303640396572 + 0.98925676661383 + 0.98574322728057 + 0.98216285681399 + 0.97836247168898 + 0.97423344023417 + 0.96966989614170 + 0.96456798916653 + 0.95884065521608 + 0.95241097355768 + 0.94520329305388 + 0.93715374486257 + 0.92821059191922 + 0.91833772937176 + 0.90752036431867 + 0.89577184573805 + 0.88313999559988 + 0.86970651617665 + 0.85557538366089 + 0.84089544799279 + 0.82588872062230 + 0.81081237658915 + 0.80332002639467 + 0.79589383713532 + 0.78855101394208 + 0.78130112645574 + 0.77414520794588 + 0.76707545395878 + 0.76007574235120 + 0.75312311446673 + 0.74618999321991 + 0.73924264113658 + 0.73217413890185 + 0.72468297114326 + 0.71660429501410 + 0.70790935949008 + 0.69856367910971 + 0.68858297636815 + 0.67799782482406 + 0.66685196301646 + 0.65520044377965 + 0.64310768980746 + 0.63064220171701 + 0.61781836361437 + 0.60470462925677 + 0.59137280460072 + 0.57789694680092 + 0.56435230043825 + 0.55081378652299 + 0.53732603067352 + 0.52392127641181 + 0.51064603107982 + 0.49753321057983 + 0.48459857550414 + 0.98436873846057 + 0.98436879793169 + 0.98436880784421 + 0.98436881942126 + 0.98436883294448 + 0.98436884874722 + 0.98436886722160 + 0.98436888883434 + 0.98436891414013 + 0.98436894386830 + 0.98436897910943 + 0.98436902151003 + 0.98436907307945 + 0.98436913606353 + 0.98436921313157 + 0.98436930756553 + 0.98436942341658 + 0.98436956570961 + 0.98436974100746 + 0.98436995789028 + 0.98437022677157 + 0.98437056081606 + 0.98437097669250 + 0.98437149560326 + 0.98437214478197 + 0.98437296074080 + 0.98437399544250 + 0.98437531854874 + 0.98437701720016 + 0.98437920236665 + 0.98438202959461 + 0.98438570022148 + 0.98439047755868 + 0.98439670964801 + 0.98440485711026 + 0.98441553030706 + 0.98442953901139 + 0.98444795903103 + 0.98447226283866 + 0.98450447990929 + 0.98454730969303 + 0.98460441972306 + 0.98468080059652 + 0.98478304307348 + 0.98491831163990 + 0.98509358490966 + 0.98531979045224 + 0.98561130238606 + 0.98598249424441 + 0.98645544898324 + 0.98706728612217 + 0.98787607797405 + 0.98897767910798 + 0.99055144636380 + 0.99303640396572 + 1.00000000000000 + 0.99207901136654 + 0.98776334334133 + 0.98374948729291 + 0.97966087789359 + 0.97532009250284 + 0.97059109957996 + 0.96535458851389 + 0.95951512766399 + 0.95299069114083 + 0.94570212013912 + 0.93758311244689 + 0.92858012014966 + 0.91865562139348 + 0.90779367421388 + 0.89600667688140 + 0.88334165401618 + 0.86987961108740 + 0.85572388389411 + 0.84102281112072 + 0.82599804830134 + 0.81090646966990 + 0.80340745060251 + 0.79597517735406 + 0.78862681357341 + 0.78137188675445 + 0.77421138777654 + 0.76713746985706 + 0.76013396890602 + 0.75317788517610 + 0.74624160201017 + 0.73929134277711 + 0.73222012102610 + 0.72472628709880 + 0.71664494176076 + 0.70794733696209 + 0.69859898824073 + 0.68861563457689 + 0.67802786852605 + 0.66687944976487 + 0.65522545361722 + 0.64313032508654 + 0.63066258423860 + 0.61783661982141 + 0.60472089727460 + 0.59138722934920 + 0.57790967547961 + 0.56436347897859 + 0.55082355727104 + 0.53733452845484 + 0.52392862853466 + 0.51065236011072 + 0.49753863428572 + 0.48460320658904 + 0.98226632851501 + 0.98226638035858 + 0.98226638900010 + 0.98226639909116 + 0.98226641087753 + 0.98226642465013 + 0.98226644075127 + 0.98226645958586 + 0.98226648163977 + 0.98226650754771 + 0.98226653827808 + 0.98226657530574 + 0.98226662042551 + 0.98226667564397 + 0.98226674335109 + 0.98226682646840 + 0.98226692862180 + 0.98226705431539 + 0.98226720942492 + 0.98226740166183 + 0.98226764037939 + 0.98226793739754 + 0.98226830771139 + 0.98226877036544 + 0.98226934985844 + 0.98227007907587 + 0.98227100499240 + 0.98227219065143 + 0.98227371484330 + 0.98227567783286 + 0.98227822043768 + 0.98228152487064 + 0.98228582932443 + 0.98229144859368 + 0.98229879916586 + 0.98230843266214 + 0.98232108046464 + 0.98233771343737 + 0.98235966024039 + 0.98238875171748 + 0.98242741865765 + 0.98247895803809 + 0.98254784548175 + 0.98263996311449 + 0.98276159355622 + 0.98291865039650 + 0.98312043341727 + 0.98337897734778 + 0.98370560642455 + 0.98411759204951 + 0.98464376757120 + 0.98532739450663 + 0.98623489513430 + 0.98747574824316 + 0.98925676661383 + 0.99207901136654 + 1.00000000000000 + 0.99097298744675 + 0.98604255682358 + 0.98145732766471 + 0.97678556615507 + 0.97181215838015 + 0.96638388797547 + 0.96038860915868 + 0.95373481408288 + 0.94633726456934 + 0.93812563560877 + 0.92904351522358 + 0.91905122452981 + 0.90813112523686 + 0.89629424408869 + 0.88358647482468 + 0.87008785027109 + 0.85590082826742 + 0.84117304758543 + 0.82612566838395 + 0.81101514690967 + 0.80350789573389 + 0.79606815115240 + 0.78871302081114 + 0.78145197542533 + 0.77428594889940 + 0.76720703768508 + 0.76019902164224 + 0.75323884634238 + 0.74629884277329 + 0.73934518316135 + 0.73227079889678 + 0.72477388332892 + 0.71668947151295 + 0.70798881820752 + 0.69863743976237 + 0.68865109345884 + 0.67806039260413 + 0.66690911956797 + 0.65525237334931 + 0.64315462197186 + 0.63068440498122 + 0.61785611425489 + 0.60473822594277 + 0.59140255811599 + 0.57792317067977 + 0.56437530376845 + 0.55083386939533 + 0.53734347635522 + 0.52393635166453 + 0.51065899214079 + 0.49754430319652 + 0.48460803448870 + 0.97985987997295 + 0.97985992530960 + 0.97985993286412 + 0.97985994168576 + 0.97985995199014 + 0.97985996403092 + 0.97985997810534 + 0.97985999456573 + 0.97986001384108 + 0.97986003648768 + 0.97986006336352 + 0.97986009580083 + 0.97986013540262 + 0.97986018397563 + 0.97986024365835 + 0.97986031707865 + 0.97986040748627 + 0.97986051892525 + 0.97986065669228 + 0.97986082774165 + 0.97986104050446 + 0.97986130564796 + 0.97986163669621 + 0.97986205084086 + 0.97986257019579 + 0.97986322451172 + 0.97986405641016 + 0.97986512318158 + 0.97986649634440 + 0.97986826684165 + 0.97987056265603 + 0.97987354930558 + 0.97987744307848 + 0.97988252975171 + 0.97988918727674 + 0.97989791600277 + 0.97990937887452 + 0.97992445521363 + 0.97994434831672 + 0.97997071606794 + 0.98000575592710 + 0.98005244413534 + 0.98011481280095 + 0.98019813846062 + 0.98030796160054 + 0.98044931999195 + 0.98063019217433 + 0.98086076136015 + 0.98115004922472 + 0.98151182780305 + 0.98196917651190 + 0.98255582331467 + 0.98332127571322 + 0.98434145444422 + 0.98574322728057 + 0.98776334334133 + 0.99097298744675 + 1.00000000000000 + 0.98969625749073 + 0.98406111907391 + 0.97881872384322 + 0.97346313244664 + 0.96775155833859 + 0.96153428908508 + 0.95470069629772 + 0.94715432047651 + 0.93881784930430 + 0.92963015552219 + 0.91954816777215 + 0.90855167733181 + 0.89664969172841 + 0.88388647614119 + 0.87034069048735 + 0.85611357860757 + 0.84135181560327 + 0.82627587143200 + 0.81114162210935 + 0.80362413301261 + 0.79617514439494 + 0.78881168816969 + 0.78154315849535 + 0.77437041255590 + 0.76728547058588 + 0.76027203737122 + 0.75330698555658 + 0.74636257662184 + 0.73940491570763 + 0.73232683280101 + 0.72482633642385 + 0.71673838436791 + 0.70803423356840 + 0.69867940066857 + 0.68868966306047 + 0.67809565653047 + 0.66694118753937 + 0.65528137969957 + 0.64318072437552 + 0.63070778015804 + 0.61787693988166 + 0.60475668889925 + 0.59141884857652 + 0.57793747695931 + 0.56438780861577 + 0.55084474791914 + 0.53735289224872 + 0.52394445791404 + 0.51066593470713 + 0.49755022130498 + 0.48461306054068 + 0.97710803987800 + 0.97710807967727 + 0.97710808630873 + 0.97710809405189 + 0.97710810309377 + 0.97710811366036 + 0.97710812601046 + 0.97710814045419 + 0.97710815736626 + 0.97710817723673 + 0.97710820083734 + 0.97710822935983 + 0.97710826426376 + 0.97710830716619 + 0.97710835999976 + 0.97710842512785 + 0.97710850548489 + 0.97710860471933 + 0.97710872761935 + 0.97710888048466 + 0.97710907095654 + 0.97710930869516 + 0.97710960595160 + 0.97710997831169 + 0.97711044582277 + 0.97711103550256 + 0.97711178618746 + 0.97711275015051 + 0.97711399257193 + 0.97711559627150 + 0.97711767801995 + 0.97712038875389 + 0.97712392561608 + 0.97712854901491 + 0.97713460320863 + 0.97714254368492 + 0.97715297355451 + 0.97716669208104 + 0.97718479297630 + 0.97720878305438 + 0.97724065633464 + 0.97728311010972 + 0.97733979220760 + 0.97741545759129 + 0.97751501577878 + 0.97764277431868 + 0.97780562023082 + 0.97801223659266 + 0.97826984961620 + 0.97858957500650 + 0.97899026010688 + 0.97949898498520 + 0.98015433600098 + 0.98101288019549 + 0.98216285681399 + 0.98374948729291 + 0.98604255682358 + 0.98969625749073 + 1.00000000000000 + 0.98822257477273 + 0.98177415912917 + 0.97575973068541 + 0.96960534114325 + 0.96306021495690 + 0.95597049065010 + 0.94821722666262 + 0.93971020105585 + 0.93038013353251 + 0.92017840147474 + 0.90908077510602 + 0.89709321336649 + 0.88425759023464 + 0.87065059919665 + 0.85637178632604 + 0.84156648899206 + 0.82645421194806 + 0.81129002457868 + 0.80375970845128 + 0.79629919673682 + 0.78892541878850 + 0.78164766532386 + 0.77446669009953 + 0.76737441079023 + 0.76035443146161 + 0.75338352723234 + 0.74643386705270 + 0.73947146767073 + 0.73238903284265 + 0.72488435188912 + 0.71679229080016 + 0.70808410736858 + 0.69872531743965 + 0.68873172022527 + 0.67813397556558 + 0.66697591515711 + 0.65531268775012 + 0.64320880784498 + 0.63073285197724 + 0.61789921096504 + 0.60477637716718 + 0.59143617254175 + 0.57795265030656 + 0.56440103650914 + 0.55085622518401 + 0.53736279979135 + 0.52395296390816 + 0.51067319883392 + 0.49755639526508 + 0.48461828809615 + 0.97396453513088 + 0.97396457024610 + 0.97396457609555 + 0.97396458292518 + 0.97396459090163 + 0.97396460021972 + 0.97396461111076 + 0.97396462384734 + 0.97396463875793 + 0.97396465627865 + 0.97396467710084 + 0.97396470230558 + 0.97396473321662 + 0.97396477130239 + 0.97396481830583 + 0.97396487636982 + 0.97396494815384 + 0.97396503696442 + 0.97396514715055 + 0.97396528445060 + 0.97396545581073 + 0.97396567002774 + 0.97396593824743 + 0.97396627465335 + 0.97396669750776 + 0.97396723144057 + 0.97396791199199 + 0.97396878706243 + 0.97396991629257 + 0.97397137539750 + 0.97397327135512 + 0.97397574232924 + 0.97397896870748 + 0.97398318866128 + 0.97398871693287 + 0.97399596967857 + 0.97400549754437 + 0.97401802961855 + 0.97403456356099 + 0.97405647378336 + 0.97408557626119 + 0.97412432461600 + 0.97417603190169 + 0.97424500089546 + 0.97433560016314 + 0.97445152190730 + 0.97459873897826 + 0.97478469707026 + 0.97501518814842 + 0.97529924631121 + 0.97565247268984 + 0.97609704005090 + 0.97666390095689 + 0.97739709369765 + 0.97836247168898 + 0.97966087789359 + 0.98145732766471 + 0.98406111907391 + 0.98822257477273 + 1.00000000000000 + 0.98651343059601 + 0.97910818023465 + 0.97219127214461 + 0.96513408973264 + 0.95766619743337 + 0.94961817586839 + 0.94087394772258 + 0.93134924068318 + 0.92098589362517 + 0.90975313489241 + 0.89765217435719 + 0.88472128766669 + 0.87103429765055 + 0.85668834032452 + 0.84182687512919 + 0.82666804781636 + 0.81146580199623 + 0.80391929063320 + 0.79644430206412 + 0.78905762639414 + 0.78176841426165 + 0.77457727965955 + 0.76747600198824 + 0.76044804986010 + 0.75347006764928 + 0.74651410074586 + 0.73954604891490 + 0.73245845740808 + 0.72494885332692 + 0.71685199235426 + 0.70813913071189 + 0.69877578152420 + 0.68877776729515 + 0.67817577319967 + 0.66701365691716 + 0.65534659230930 + 0.64323911608989 + 0.63075982081767 + 0.61792309128548 + 0.60479742380829 + 0.59145463741219 + 0.57796877674920 + 0.56441505570572 + 0.55086835470878 + 0.53737324030455 + 0.52396190094222 + 0.51068080766950 + 0.49756284172192 + 0.48462372871937 + 0.97037464828813 + 0.97037467945472 + 0.97037468464590 + 0.97037469070648 + 0.97037469778259 + 0.97037470604810 + 0.97037471570874 + 0.97037472700485 + 0.97037474022740 + 0.97037475576573 + 0.97037477424222 + 0.97037479664590 + 0.97037482418023 + 0.97037485818268 + 0.97037490023600 + 0.97037495229117 + 0.97037501677566 + 0.97037509669354 + 0.97037519601858 + 0.97037531999736 + 0.97037547497905 + 0.97037566900191 + 0.97037591225458 + 0.97037621770500 + 0.97037660204857 + 0.97037708783955 + 0.97037770773626 + 0.97037850578388 + 0.97037953678009 + 0.97038087021251 + 0.97038260443266 + 0.97038486639616 + 0.97038782172808 + 0.97039168905025 + 0.97039675708361 + 0.97040340735657 + 0.97041214426552 + 0.97042363507433 + 0.97043879276728 + 0.97045887505095 + 0.97048554111706 + 0.97052103028679 + 0.97056836179065 + 0.97063144307305 + 0.97071417468911 + 0.97081972515828 + 0.97095329207116 + 0.97112128453956 + 0.97132832680494 + 0.97158178077832 + 0.97189467564526 + 0.97228540359531 + 0.97277926489642 + 0.97341151352238 + 0.97423344023417 + 0.97532009250284 + 0.97678556615507 + 0.97881872384322 + 0.98177415912917 + 0.98651343059601 + 1.00000000000000 + 0.98450237201891 + 0.97597844140940 + 0.96804002135461 + 0.95998124455262 + 0.95149752578453 + 0.94241477696430 + 0.93261881119918 + 0.92203401585326 + 0.91061843236618 + 0.89836557070848 + 0.88530811571097 + 0.87151559169536 + 0.85708164280972 + 0.84214704975268 + 0.82692802370660 + 0.81167692493781 + 0.80410975880435 + 0.79661639358662 + 0.78921342949601 + 0.78190982673622 + 0.77470600979857 + 0.76759357102353 + 0.76055579624780 + 0.75356915396471 + 0.74660552389047 + 0.73963065020607 + 0.73253687684616 + 0.72502141316646 + 0.71691888020845 + 0.70820052873867 + 0.69883186606731 + 0.68882873922940 + 0.67822185979934 + 0.66705511181836 + 0.65538369368658 + 0.64327216270013 + 0.63078912461836 + 0.61794895291487 + 0.60482014384893 + 0.59147450897959 + 0.57798607969499 + 0.56443005319533 + 0.55088129224955 + 0.53738434280420 + 0.52397137520592 + 0.51068884806746 + 0.49756963130487 + 0.48462943959825 + 0.96626605121982 + 0.96626607905678 + 0.96626608369286 + 0.96626608910303 + 0.96626609542082 + 0.96626610280002 + 0.96626611142258 + 0.96626612150224 + 0.96626613330110 + 0.96626614716652 + 0.96626616366287 + 0.96626618369606 + 0.96626620836685 + 0.96626623890029 + 0.96626627674327 + 0.96626632367801 + 0.96626638191967 + 0.96626645422380 + 0.96626654423106 + 0.96626665675677 + 0.96626679762599 + 0.96626697421183 + 0.96626719586575 + 0.96626747448796 + 0.96626782538797 + 0.96626826929307 + 0.96626883630356 + 0.96626956706029 + 0.96627051204923 + 0.96627173523882 + 0.96627332730810 + 0.96627540522024 + 0.96627812148358 + 0.96628167727303 + 0.96628633813219 + 0.96629245467808 + 0.96630049007523 + 0.96631105640725 + 0.96632499107163 + 0.96634344754088 + 0.96636794509331 + 0.96640053193664 + 0.96644396569201 + 0.96650180295477 + 0.96657753360000 + 0.96667387499515 + 0.96679535725278 + 0.96694750637177 + 0.96713398019978 + 0.96736076888233 + 0.96763880691027 + 0.96798347011965 + 0.96841568016383 + 0.96896415221224 + 0.96966989614170 + 0.97059109957996 + 0.97181215838015 + 0.97346313244664 + 0.97575973068541 + 0.97910818023465 + 0.98450237201891 + 1.00000000000000 + 0.98213212938336 + 0.97233384348863 + 0.96325477406297 + 0.95408724077959 + 0.94450148555089 + 0.93431616695774 + 0.92342087251798 + 0.91175319252950 + 0.89929346756936 + 0.88606531135092 + 0.87213158028996 + 0.85758070908489 + 0.84254956589096 + 0.82725155865748 + 0.81193679007053 + 0.80434285693932 + 0.79682577406266 + 0.78940188061667 + 0.78207987610136 + 0.77485992640099 + 0.76773336933258 + 0.76068324274419 + 0.75368577711662 + 0.74671262871933 + 0.73972933316077 + 0.73262797438918 + 0.72510536756753 + 0.71699596548621 + 0.70827100796892 + 0.69889599212902 + 0.68888679116601 + 0.67827414453796 + 0.66710196328106 + 0.65542546979697 + 0.64330924004241 + 0.63082188950344 + 0.61797777338508 + 0.60484538280676 + 0.59149651606209 + 0.57800518519515 + 0.56444656481268 + 0.55089549467120 + 0.53739649514656 + 0.52398171440513 + 0.51069759563804 + 0.49757699486877 + 0.48463561351316 + 0.96155623768561 + 0.96155626270540 + 0.96155626687005 + 0.96155627173043 + 0.96155627740640 + 0.96155628403486 + 0.96155629177869 + 0.96155630082995 + 0.96155631142155 + 0.96155632387106 + 0.96155633868861 + 0.96155635670888 + 0.96155637894410 + 0.96155640651570 + 0.96155644075563 + 0.96155648329551 + 0.96155653617130 + 0.96155660190907 + 0.96155668386064 + 0.96155678645881 + 0.96155691506661 + 0.96155707646395 + 0.96155727926109 + 0.96155753440063 + 0.96155785597337 + 0.96155826306594 + 0.96155878348343 + 0.96155945480665 + 0.96156032365080 + 0.96156144901165 + 0.96156291466150 + 0.96156482855879 + 0.96156733134887 + 0.96157060848296 + 0.96157490454401 + 0.96158054224780 + 0.96158794745867 + 0.96159768240580 + 0.96161051610562 + 0.96162750767104 + 0.96165004981854 + 0.96168001797790 + 0.96171993348861 + 0.96177303706165 + 0.96184245347045 + 0.96193050737820 + 0.96204114677252 + 0.96217913472780 + 0.96234732007458 + 0.96255055023342 + 0.96279801737560 + 0.96310262612293 + 0.96348178997417 + 0.96395913903302 + 0.96456798916653 + 0.96535458851389 + 0.96638388797547 + 0.96775155833859 + 0.96960534114325 + 0.97219127214461 + 0.97597844140940 + 0.98213212938336 + 1.00000000000000 + 0.97937828536300 + 0.96813865585696 + 0.95778456015611 + 0.94740483083169 + 0.93663737732685 + 0.92529352427924 + 0.91327003526698 + 0.90052313621079 + 0.88706089628423 + 0.87293535828795 + 0.85822689519391 + 0.84306648757352 + 0.82766338515545 + 0.81226441111028 + 0.80463525384670 + 0.79708706881719 + 0.78963583280876 + 0.78228988529997 + 0.77504903661089 + 0.76790427589567 + 0.76083830237992 + 0.75382702256409 + 0.74684178943833 + 0.73984785699876 + 0.73273696806226 + 0.72520543748122 + 0.71708750317347 + 0.70835438655388 + 0.69897156852696 + 0.68895495088349 + 0.67833530315936 + 0.66715656450800 + 0.65547398085054 + 0.64335214447199 + 0.63085967612282 + 0.61801090335791 + 0.60487430545157 + 0.59152165971418 + 0.57802695066332 + 0.56446532232097 + 0.55091158413894 + 0.53741022402044 + 0.52399336227727 + 0.51070742247126 + 0.49758524311667 + 0.48464250910048 + 0.95617053601740 + 0.95617055864344 + 0.95617056240783 + 0.95617056680356 + 0.95617057193408 + 0.95617057792440 + 0.95617058492110 + 0.95617059309856 + 0.95617060266737 + 0.95617061391049 + 0.95617062729958 + 0.95617064360228 + 0.95617066375414 + 0.95617068878768 + 0.95617071992515 + 0.95617075867474 + 0.95617080690657 + 0.95617086694951 + 0.95617094189292 + 0.95617103583460 + 0.95617115371607 + 0.95617130180106 + 0.95617148802278 + 0.95617172247370 + 0.95617201814623 + 0.95617239266191 + 0.95617287174939 + 0.95617349021576 + 0.95617429117161 + 0.95617532912550 + 0.95617668157713 + 0.95617844830612 + 0.95618075920936 + 0.95618378544485 + 0.95618775256871 + 0.95619295792613 + 0.95619979352431 + 0.95620877628151 + 0.95622061305789 + 0.95623627712484 + 0.95625704614750 + 0.95628463859515 + 0.95632136133008 + 0.95637016918957 + 0.95643386088197 + 0.95651441817142 + 0.95661527881289 + 0.95674054298409 + 0.95689237899742 + 0.95707467463428 + 0.95729515513331 + 0.95756466751928 + 0.95789775345436 + 0.95831397295073 + 0.95884065521608 + 0.95951512766399 + 0.96038860915868 + 0.96153428908508 + 0.96306021495690 + 0.96513408973264 + 0.96804002135461 + 0.97233384348863 + 0.97937828536300 + 1.00000000000000 + 0.97620256904339 + 0.96333228181858 + 0.95157142764904 + 0.93988239652411 + 0.92786585086417 + 0.91532682920392 + 0.90217345306483 + 0.88838534142633 + 0.87399606006338 + 0.85907297244256 + 0.84373789587089 + 0.82819374334449 + 0.81268247221410 + 0.80500657255717 + 0.79741725497970 + 0.78992998811465 + 0.78255261017772 + 0.77528443922213 + 0.76811598396937 + 0.76102947892073 + 0.75400038749336 + 0.74699964927586 + 0.73999213623989 + 0.73286913989998 + 0.72532633289658 + 0.71719767561441 + 0.70845436021393 + 0.69906184269426 + 0.68903605582220 + 0.67840780131310 + 0.66722104703204 + 0.65553106087774 + 0.64340244751122 + 0.63090382622780 + 0.61804948404018 + 0.60490787901014 + 0.59155075691637 + 0.57805206376248 + 0.56448690231957 + 0.55093004206236 + 0.53742592935017 + 0.52400664915850 + 0.51071859986787 + 0.49759459770770 + 0.48465030673376 + 0.95004025578018 + 0.95004027636175 + 0.95004027978524 + 0.95004028377961 + 0.95004028844234 + 0.95004029388691 + 0.95004030024583 + 0.95004030767623 + 0.95004031636908 + 0.95004032657921 + 0.95004033874780 + 0.95004035357648 + 0.95004037193399 + 0.95004039477648 + 0.95004042322952 + 0.95004045868444 + 0.95004050287000 + 0.95004055793993 + 0.95004062674475 + 0.95004071307656 + 0.95004082151117 + 0.95004095783878 + 0.95004112938832 + 0.95004134548839 + 0.95004161814236 + 0.95004196363594 + 0.95004240582520 + 0.95004297699218 + 0.95004371706726 + 0.95004467648251 + 0.95004592701601 + 0.95004756101532 + 0.95004969858361 + 0.95005249785780 + 0.95005616708518 + 0.95006098049990 + 0.95006729927819 + 0.95007559910763 + 0.95008653023930 + 0.95010098773719 + 0.95012014454919 + 0.95014557633614 + 0.95017939505952 + 0.95022429650551 + 0.95028278791260 + 0.95035655169296 + 0.95044857788291 + 0.95056238958330 + 0.95069958213934 + 0.95086323438925 + 0.95105982769866 + 0.95129847830459 + 0.95159134332644 + 0.95195466052286 + 0.95241097355768 + 0.95299069114083 + 0.95373481408288 + 0.95470069629772 + 0.95597049065010 + 0.95766619743337 + 0.95998124455262 + 0.96325477406297 + 0.96813865585696 + 0.97620256904339 + 1.00000000000000 + 0.97254151863538 + 0.95784980563673 + 0.94455502378399 + 0.93147157408413 + 0.91815813443412 + 0.90441496764537 + 0.89016503022410 + 0.87540820336204 + 0.86018975755923 + 0.84461665761155 + 0.82888184032503 + 0.81321985653119 + 0.80548155997344 + 0.79783752931900 + 0.79030251236347 + 0.78288364267393 + 0.77557955139156 + 0.76838008087847 + 0.76126682432857 + 0.75421463633052 + 0.74719389053151 + 0.74016893854628 + 0.73303047145201 + 0.72547333209486 + 0.71733111967248 + 0.70857498091004 + 0.69917033395592 + 0.68913314400195 + 0.67849424599373 + 0.66729763555487 + 0.65559859878358 + 0.64346174584546 + 0.63095568433912 + 0.61809464298751 + 0.60494704548140 + 0.59158459170372 + 0.57808117445159 + 0.56451184121137 + 0.55095130885933 + 0.53744397052211 + 0.52402186623715 + 0.51073136203193 + 0.49760524569343 + 0.48465915494061 + 0.94309622699089 + 0.94309624580171 + 0.94309624892928 + 0.94309625257874 + 0.94309625683844 + 0.94309626181114 + 0.94309626761672 + 0.94309627440104 + 0.94309628233570 + 0.94309629165700 + 0.94309630276511 + 0.94309631631558 + 0.94309633311227 + 0.94309635403813 + 0.94309638013922 + 0.94309641270253 + 0.94309645332399 + 0.94309650399811 + 0.94309656736876 + 0.94309664695059 + 0.94309674697948 + 0.94309687281653 + 0.94309703125447 + 0.94309723091855 + 0.94309748291690 + 0.94309780232747 + 0.94309821128994 + 0.94309873978041 + 0.94309942482201 + 0.94310031311241 + 0.94310147121759 + 0.94310298466809 + 0.94310496462023 + 0.94310755731061 + 0.94311095514411 + 0.94311541125897 + 0.94312125866118 + 0.94312893539679 + 0.94313904004592 + 0.94315239621301 + 0.94317008130488 + 0.94319354077317 + 0.94322470907105 + 0.94326604676527 + 0.94331980019848 + 0.94338739060855 + 0.94347141478136 + 0.94357489280713 + 0.94369893816236 + 0.94384594661194 + 0.94402133955143 + 0.94423276656487 + 0.94449038423076 + 0.94480767913538 + 0.94520329305388 + 0.94570212013912 + 0.94633726456934 + 0.94715432047651 + 0.94821722666262 + 0.94961817586839 + 0.95149752578453 + 0.95408724077959 + 0.95778456015611 + 0.96333228181858 + 0.97254151863538 + 1.00000000000000 + 0.96834247801368 + 0.95163272998983 + 0.93668503183032 + 0.92214008262506 + 0.90750889367035 + 0.89258747917725 + 0.87730882977419 + 0.86167815373148 + 0.84577706929937 + 0.82978214802962 + 0.81391629180489 + 0.80609409607810 + 0.79837678144273 + 0.79077805700899 + 0.78330405284736 + 0.77595243117236 + 0.76871210174239 + 0.76156376600878 + 0.75448143648283 + 0.74743470756114 + 0.74038721822429 + 0.73322885538038 + 0.72565338171621 + 0.71749392248783 + 0.70872155483064 + 0.69930163984684 + 0.68925017476371 + 0.67859802691339 + 0.66738921617673 + 0.65567903970327 + 0.64353210202824 + 0.63101698376820 + 0.61814783098168 + 0.60499301464387 + 0.59162416915228 + 0.57811511446538 + 0.56454082423975 + 0.55097594621547 + 0.53746480513415 + 0.52403938369258 + 0.51074600625052 + 0.49761742417698 + 0.48466924174297 + 0.93527946056305 + 0.93527947782208 + 0.93527948069118 + 0.93527948403833 + 0.93527948794367 + 0.93527949250141 + 0.93527949782421 + 0.93527950404163 + 0.93527951131274 + 0.93527951985304 + 0.93527953003095 + 0.93527954245587 + 0.93527955787602 + 0.93527957710823 + 0.93527960112525 + 0.93527963111440 + 0.93527966855908 + 0.93527971530612 + 0.93527977380479 + 0.93527984732678 + 0.93527993979042 + 0.93528005616977 + 0.93528020276636 + 0.93528038756628 + 0.93528062085255 + 0.93528091660251 + 0.93528129538012 + 0.93528178503713 + 0.93528241992772 + 0.93528324333826 + 0.93528431702727 + 0.93528572027240 + 0.93528755600838 + 0.93528995956757 + 0.93529310882955 + 0.93529723759785 + 0.93530265308914 + 0.93530975893312 + 0.93531910640380 + 0.93533145374869 + 0.93534779106379 + 0.93536944493748 + 0.93539818795527 + 0.93543626690780 + 0.93548569460619 + 0.93554766495757 + 0.93562442961769 + 0.93571857052333 + 0.93583079766795 + 0.93596293089048 + 0.93611948657903 + 0.93630686682475 + 0.93653353966846 + 0.93681069281602 + 0.93715374486257 + 0.93758311244689 + 0.93812563560877 + 0.93881784930430 + 0.93971020105585 + 0.94087394772258 + 0.94241477696430 + 0.94450148555089 + 0.94740483083169 + 0.95157142764904 + 0.95784980563673 + 0.96834247801368 + 1.00000000000000 + 0.96354426073256 + 0.94462105133910 + 0.92791820524251 + 0.91187164051119 + 0.89593734662766 + 0.87989886768923 + 0.86368228151930 + 0.84732305330017 + 0.83096951180265 + 0.81482548436784 + 0.80688962415665 + 0.79907346210914 + 0.79138918086392 + 0.78384145782667 + 0.77642656980182 + 0.76913210662195 + 0.76193751808659 + 0.75481564277300 + 0.74773499476122 + 0.74065823098965 + 0.73347415434514 + 0.72587511219135 + 0.71769360306007 + 0.70890059815177 + 0.69946137270452 + 0.68939195197657 + 0.67872323121699 + 0.66749924674005 + 0.65577529421494 + 0.64361595508936 + 0.63108976050356 + 0.61821074050081 + 0.60504718787426 + 0.59167064504622 + 0.57815483298172 + 0.56457462712978 + 0.55100458455038 + 0.53748894205697 + 0.52405960906058 + 0.51076285622565 + 0.49763138820811 + 0.48468076670672 + 0.92654218964329 + 0.92654220551945 + 0.92654220815803 + 0.92654221123637 + 0.92654221482694 + 0.92654221901785 + 0.92654222390915 + 0.92654222962167 + 0.92654223630022 + 0.92654224414494 + 0.92654225349524 + 0.92654226491919 + 0.92654227910734 + 0.92654229682174 + 0.92654231896113 + 0.92654234663109 + 0.92654238120822 + 0.92654242440061 + 0.92654247848351 + 0.92654254649496 + 0.92654263207672 + 0.92654273983941 + 0.92654287562051 + 0.92654304683266 + 0.92654326300803 + 0.92654353709801 + 0.92654388821316 + 0.92654434224114 + 0.92654493107662 + 0.92654569485546 + 0.92654669089613 + 0.92654799272375 + 0.92654969570000 + 0.92655192510452 + 0.92655484546862 + 0.92655867283098 + 0.92656369073595 + 0.92657027125091 + 0.92657892230831 + 0.92659034221043 + 0.92660544116325 + 0.92662543707962 + 0.92665195476206 + 0.92668704650779 + 0.92673251610186 + 0.92678936024332 + 0.92685952810977 + 0.92694522062673 + 0.92704681235378 + 0.92716563938824 + 0.92730544557155 + 0.92747157039825 + 0.92767105237539 + 0.92791314817042 + 0.92821059191922 + 0.92858012014966 + 0.92904351522358 + 0.92963015552219 + 0.93038013353251 + 0.93134924068318 + 0.93261881119918 + 0.93431616695774 + 0.93663737732685 + 0.93988239652411 + 0.94455502378399 + 0.95163272998983 + 0.96354426073256 + 1.00000000000000 + 0.95808244358790 + 0.93676056844531 + 0.91822613397946 + 0.90067350653723 + 0.88348666738092 + 0.86641571043332 + 0.84940460068642 + 0.83254969192132 + 0.81602196172356 + 0.80793068211062 + 0.79998006561669 + 0.79217999374882 + 0.78453299563563 + 0.77703333169028 + 0.76966669580489 + 0.76241075925983 + 0.75523670701244 + 0.74811154207368 + 0.74099655743611 + 0.73377908350409 + 0.72614959991559 + 0.71793976935351 + 0.70912040190563 + 0.69965664346522 + 0.68956453677029 + 0.67887499429099 + 0.66763205394453 + 0.65589098926294 + 0.64371633190851 + 0.63117653088589 + 0.61828545465166 + 0.60511128273012 + 0.59172542977263 + 0.57820148303154 + 0.56461418773823 + 0.55103798219692 + 0.53751699010041 + 0.52408302706680 + 0.51078229450994 + 0.49764743710822 + 0.48469396224129 + 0.91685166490819 + 0.91685167953476 + 0.91685168196416 + 0.91685168479793 + 0.91685168810388 + 0.91685169196198 + 0.91685169646226 + 0.91685170171952 + 0.91685170786542 + 0.91685171508087 + 0.91685172368192 + 0.91685173419891 + 0.91685174726965 + 0.91685176360325 + 0.91685178403353 + 0.91685180958660 + 0.91685184153847 + 0.91685188147201 + 0.91685193150587 + 0.91685199445428 + 0.91685207369966 + 0.91685217352176 + 0.91685229933844 + 0.91685245801398 + 0.91685265838434 + 0.91685291246887 + 0.91685323801744 + 0.91685365909390 + 0.91685420530922 + 0.91685491388374 + 0.91685583802980 + 0.91685704592740 + 0.91685862594578 + 0.91686069408054 + 0.91686340254273 + 0.91686695099156 + 0.91687160118941 + 0.91687769619605 + 0.91688570409282 + 0.91689626813320 + 0.91691022524050 + 0.91692869379995 + 0.91695316346647 + 0.91698550931444 + 0.91702734803349 + 0.91707950590414 + 0.91714366748927 + 0.91722170308800 + 0.91731371120197 + 0.91742062404964 + 0.91754552701714 + 0.91769285476789 + 0.91786843447024 + 0.91807989671118 + 0.91833772937176 + 0.91865562139348 + 0.91905122452981 + 0.91954816777215 + 0.92017840147474 + 0.92098589362517 + 0.92203401585326 + 0.92342087251798 + 0.92529352427924 + 0.92786585086417 + 0.93147157408413 + 0.93668503183032 + 0.94462105133910 + 0.95808244358790 + 1.00000000000000 + 0.95189329435011 + 0.92800791678884 + 0.90760038923383 + 0.88857363154810 + 0.87020872533871 + 0.85224547366909 + 0.83467616798524 + 0.81761145508813 + 0.80930509811925 + 0.80116961624215 + 0.79321130546208 + 0.78542942798062 + 0.77781523984206 + 0.77035165779589 + 0.76301378427813 + 0.75577044268778 + 0.74858649745648 + 0.74142132758365 + 0.73416024432449 + 0.72649124188258 + 0.71824485696740 + 0.70939165399999 + 0.69989658318655 + 0.68977568286031 + 0.67905986152733 + 0.66779313279275 + 0.65603071512029 + 0.64383705024026 + 0.63128045803604 + 0.61837458315480 + 0.60518744362684 + 0.59179027809958 + 0.57825649399441 + 0.56466066428236 + 0.55107707190733 + 0.53754969489047 + 0.52411022861587 + 0.51080478511793 + 0.49766593193527 + 0.48470910700387 + 0.90619597156781 + 0.90619598504725 + 0.90619598728480 + 0.90619598989551 + 0.90619599294081 + 0.90619599649463 + 0.90619600063970 + 0.90619600547868 + 0.90619601113430 + 0.90619601777345 + 0.90619602569090 + 0.90619603537158 + 0.90619604741696 + 0.90619606247948 + 0.90619608133228 + 0.90619610492989 + 0.90619613445018 + 0.90619617136798 + 0.90619621764496 + 0.90619627589209 + 0.90619634925108 + 0.90619644168770 + 0.90619655822697 + 0.90619670523520 + 0.90619689089091 + 0.90619712634810 + 0.90619742808286 + 0.90619781846490 + 0.90619832496677 + 0.90619898210717 + 0.90619983926369 + 0.90620095965474 + 0.90620242515251 + 0.90620434315375 + 0.90620685446217 + 0.90621014358861 + 0.90621445219286 + 0.90622009658460 + 0.90622750814632 + 0.90623727942072 + 0.90625017999130 + 0.90626723689520 + 0.90628981595820 + 0.90631963052810 + 0.90635812978061 + 0.90640599339389 + 0.90646467485834 + 0.90653575834654 + 0.90661911812593 + 0.90671535189057 + 0.90682698530580 + 0.90695768374474 + 0.90711224863185 + 0.90729694070671 + 0.90752036431867 + 0.90779367421388 + 0.90813112523686 + 0.90855167733181 + 0.90908077510602 + 0.90975313489241 + 0.91061843236618 + 0.91175319252950 + 0.91327003526698 + 0.91532682920392 + 0.91815813443412 + 0.92214008262506 + 0.92791820524251 + 0.93676056844531 + 0.95189329435011 + 1.00000000000000 + 0.94491627901769 + 0.91833327584763 + 0.89604727483666 + 0.87560284354690 + 0.85619410892259 + 0.83757910137201 + 0.81974787653256 + 0.81113907574789 + 0.80274578992527 + 0.79456848381378 + 0.78660126675901 + 0.77883077791964 + 0.77123575914229 + 0.76378752088655 + 0.75645145158530 + 0.74918934127769 + 0.74195784630390 + 0.73463947569364 + 0.72691888236179 + 0.71862506783734 + 0.70972821931465 + 0.70019298884043 + 0.69003536885607 + 0.67928622523508 + 0.66798950373252 + 0.65620031621179 + 0.64398295475147 + 0.63140554282922 + 0.61848141623885 + 0.60527836534075 + 0.59186738778633 + 0.57832164989721 + 0.56471549708844 + 0.55112300914990 + 0.53758797625238 + 0.52414193939681 + 0.51083089511070 + 0.49768731155647 + 0.48472653767867 + 0.89459091998249 + 0.89459093239459 + 0.89459093445528 + 0.89459093685767 + 0.89459093965942 + 0.89459094292759 + 0.89459094674156 + 0.89459095119480 + 0.89459095639599 + 0.89459096250332 + 0.89459096978446 + 0.89459097869243 + 0.89459098978136 + 0.89459100365934 + 0.89459102104254 + 0.89459104281258 + 0.89459107006526 + 0.89459110415969 + 0.89459114691837 + 0.89459120076215 + 0.89459126860548 + 0.89459135412348 + 0.89459146196417 + 0.89459159802819 + 0.89459176989331 + 0.89459198788796 + 0.89459226730624 + 0.89459262891468 + 0.89459309819870 + 0.89459370714663 + 0.89459450156156 + 0.89459554002809 + 0.89459689837425 + 0.89459867598777 + 0.89460100308453 + 0.89460405013952 + 0.89460804019730 + 0.89461326486132 + 0.89462012162751 + 0.89462915624013 + 0.89464107627356 + 0.89465682479927 + 0.89467765400711 + 0.89470512946664 + 0.89474055035322 + 0.89478447084358 + 0.89483814312410 + 0.89490290447891 + 0.89497845008857 + 0.89506510333791 + 0.89516491582516 + 0.89528090059720 + 0.89541699226324 + 0.89557829899624 + 0.89577184573805 + 0.89600667688140 + 0.89629424408869 + 0.89664969172841 + 0.89709321336649 + 0.89765217435719 + 0.89836557070848 + 0.89929346756936 + 0.90052313621079 + 0.90217345306483 + 0.90441496764537 + 0.90750889367035 + 0.91187164051119 + 0.91822613397946 + 0.92800791678884 + 0.94491627901769 + 1.00000000000000 + 0.93709442419629 + 0.90771181146872 + 0.88356683690688 + 0.86182707635733 + 0.84161959808517 + 0.82266323030080 + 0.81361965056923 + 0.80485986949059 + 0.79637432322350 + 0.78814859490445 + 0.78016193352453 + 0.77238658453623 + 0.76478809599352 + 0.75732673619228 + 0.74995978229257 + 0.74263994699071 + 0.73524578917993 + 0.72745741200441 + 0.71910169228585 + 0.71014823147332 + 0.70056122237070 + 0.69035653625081 + 0.67956492834956 + 0.66823020491275 + 0.65640729131206 + 0.64416024150285 + 0.63155688629603 + 0.61861013611082 + 0.60538746279628 + 0.59195953533070 + 0.57839919736990 + 0.56478049390778 + 0.55117723900304 + 0.53763298020277 + 0.52417905983029 + 0.51086132492443 + 0.49771211537416 + 0.48474666579418 + 0.88208642273072 + 0.88208643414109 + 0.88208643603429 + 0.88208643824260 + 0.88208644081759 + 0.88208644382101 + 0.88208644732531 + 0.88208645141371 + 0.88208645619079 + 0.88208646179923 + 0.88208646848581 + 0.88208647666954 + 0.88208648686364 + 0.88208649963236 + 0.88208651563360 + 0.88208653568526 + 0.88208656080178 + 0.88208659224257 + 0.88208663168649 + 0.88208668138390 + 0.88208674402809 + 0.88208682301706 + 0.88208692266208 + 0.88208704841662 + 0.88208720728723 + 0.88208740883528 + 0.88208766724337 + 0.88208800176814 + 0.88208843603888 + 0.88208899966766 + 0.88208973510048 + 0.88209069660738 + 0.88209195436976 + 0.88209360031136 + 0.88209575480045 + 0.88209857527407 + 0.88210226752733 + 0.88210710030717 + 0.88211343977719 + 0.88212178844077 + 0.88213279673603 + 0.88214733046642 + 0.88216653747949 + 0.88219184822218 + 0.88222442760896 + 0.88226472296088 + 0.88231381152033 + 0.88237281831196 + 0.88244129844681 + 0.88251935311010 + 0.88260863424658 + 0.88271160375257 + 0.88283146612405 + 0.88297236242502 + 0.88313999559988 + 0.88334165401618 + 0.88358647482468 + 0.88388647614119 + 0.88425759023464 + 0.88472128766669 + 0.88530811571097 + 0.88606531135092 + 0.88706089628423 + 0.88838534142633 + 0.89016503022410 + 0.89258747917725 + 0.89593734662766 + 0.90067350653723 + 0.90760038923383 + 0.91833327584763 + 0.93709442419629 + 1.00000000000000 + 0.92836009886368 + 0.89609800131781 + 0.87018915635512 + 0.84740217139223 + 0.82672500635483 + 0.81703648478331 + 0.80774146722464 + 0.79881181573226 + 0.79021808073900 + 0.78192702250740 + 0.77390030096790 + 0.76609435968115 + 0.75846157962744 + 0.75095242527295 + 0.74351375730131 + 0.73601844999799 + 0.72814030639398 + 0.71970320575247 + 0.71067582552702 + 0.70102164080580 + 0.69075626754693 + 0.67991023293162 + 0.66852708665952 + 0.65666144398062 + 0.64437698947118 + 0.63174112331181 + 0.61876616994031 + 0.60551915760876 + 0.59207030784876 + 0.57849203261531 + 0.56485797999392 + 0.55124161600124 + 0.53768617399071 + 0.52422273988270 + 0.51089696679038 + 0.49774102859700 + 0.48477001257583 + 0.86876604185228 + 0.86876605231809 + 0.86876605405438 + 0.86876605607814 + 0.86876605843967 + 0.86876606119372 + 0.86876606440462 + 0.86876606815234 + 0.86876607252950 + 0.86876607766682 + 0.86876608379215 + 0.86876609129438 + 0.86876610064594 + 0.86876611236606 + 0.86876612706691 + 0.86876614549629 + 0.86876616859330 + 0.86876619752041 + 0.86876623383490 + 0.86876627960795 + 0.86876633733287 + 0.86876641015257 + 0.86876650204198 + 0.86876661804934 + 0.86876676464188 + 0.86876695065573 + 0.86876718922829 + 0.86876749819818 + 0.86876789943494 + 0.86876842033841 + 0.86876910021346 + 0.86876998926856 + 0.86877115241192 + 0.86877267462131 + 0.86877466707793 + 0.86877727510984 + 0.86878068849287 + 0.86878515481174 + 0.86879101124745 + 0.86879872033005 + 0.86880887980040 + 0.86882228432918 + 0.86883998591463 + 0.86886329139197 + 0.86889324552843 + 0.86893020509021 + 0.86897509557807 + 0.86902886003399 + 0.86909094691612 + 0.86916127992772 + 0.86924117571952 + 0.86933263240981 + 0.86943824187562 + 0.86956133661119 + 0.86970651617665 + 0.86987961108740 + 0.87008785027109 + 0.87034069048735 + 0.87065059919665 + 0.87103429765055 + 0.87151559169536 + 0.87213158028996 + 0.87293535828795 + 0.87399606006338 + 0.87540820336204 + 0.87730882977419 + 0.87989886768923 + 0.88348666738092 + 0.88857363154810 + 0.89604727483666 + 0.90771181146872 + 0.92836009886368 + 1.00000000000000 + 0.91860919273418 + 0.88347692018759 + 0.85604500203132 + 0.83256144100108 + 0.82187022329980 + 0.81176194289317 + 0.80217036379422 + 0.79303713713630 + 0.78430630538683 + 0.77592116507528 + 0.76782299118415 + 0.75995145716328 + 0.75224634286560 + 0.74464553472714 + 0.73701349171314 + 0.72901508668184 + 0.72046986090992 + 0.71134500429362 + 0.70160284919628 + 0.69125851910462 + 0.68034211174738 + 0.66889672919430 + 0.65697648429152 + 0.64464449610357 + 0.63196753448310 + 0.61895711361769 + 0.60567964395555 + 0.59220473671626 + 0.57860422440894 + 0.56495122857756 + 0.55131875726977 + 0.53774963463641 + 0.52427461368853 + 0.51093909460723 + 0.49777503522627 + 0.48479733182452 + 0.85473555043779 + 0.85473556000930 + 0.85473556159678 + 0.85473556344773 + 0.85473556560589 + 0.85473556812276 + 0.85473557105836 + 0.85473557448289 + 0.85473557848274 + 0.85473558317526 + 0.85473558877287 + 0.85473559563122 + 0.85473560418558 + 0.85473561491371 + 0.85473562837874 + 0.85473564527190 + 0.85473566645700 + 0.85473569300551 + 0.85473572634593 + 0.85473576840040 + 0.85473582145835 + 0.85473588842507 + 0.85473597296684 + 0.85473607973192 + 0.85473621469204 + 0.85473638600053 + 0.85473660579972 + 0.85473689058863 + 0.85473726059338 + 0.85473774112302 + 0.85473836852447 + 0.85473918921502 + 0.85474026315305 + 0.85474166881827 + 0.85474350882322 + 0.85474591720771 + 0.85474906886913 + 0.85475319174554 + 0.85475859615360 + 0.85476570759109 + 0.85477507511494 + 0.85478742780052 + 0.85480372941432 + 0.85482517350247 + 0.85485269707707 + 0.85488658038270 + 0.85492761725729 + 0.85497659486668 + 0.85503288317819 + 0.85509626644697 + 0.85516778122781 + 0.85524903674052 + 0.85534211263959 + 0.85544966780474 + 0.85557538366089 + 0.85572388389411 + 0.85590082826742 + 0.85611357860757 + 0.85637178632604 + 0.85668834032452 + 0.85708164280972 + 0.85758070908489 + 0.85822689519391 + 0.85907297244256 + 0.86018975755923 + 0.86167815373148 + 0.86368228151930 + 0.86641571043332 + 0.87020872533871 + 0.87560284354690 + 0.88356683690688 + 0.89609800131781 + 0.91860919273418 + 1.00000000000000 + 0.90779452690586 + 0.86996486113902 + 0.84137116484755 + 0.82900016097679 + 0.81757795890027 + 0.80694755034551 + 0.79698771595659 + 0.78759665608356 + 0.77868289275371 + 0.77016048570943 + 0.76194731250720 + 0.75396548161030 + 0.74613847377126 + 0.73831778513888 + 0.73015519275773 + 0.72146373825271 + 0.71220815323568 + 0.70234890639536 + 0.69190020729717 + 0.68089137667860 + 0.66936475327856 + 0.65737364348927 + 0.64498030188985 + 0.63225057245226 + 0.61919483701901 + 0.60587863928320 + 0.59237075041749 + 0.57874221707671 + 0.56506545442943 + 0.55141286070600 + 0.53782672015201 + 0.52433734775956 + 0.51098980967355 + 0.49781577901549 + 0.48482990134744 + 0.84014518313657 + 0.84014519186196 + 0.84014519330903 + 0.84014519499648 + 0.84014519696273 + 0.84014519925600 + 0.84014520193093 + 0.84014520505039 + 0.84014520869357 + 0.84014521296848 + 0.84014521806743 + 0.84014522431698 + 0.84014523211628 + 0.84014524190748 + 0.84014525420330 + 0.84014526964385 + 0.84014528901702 + 0.84014531330873 + 0.84014534383709 + 0.84014538236397 + 0.84014543100327 + 0.84014549242329 + 0.84014557000036 + 0.84014566801468 + 0.84014579196236 + 0.84014594935333 + 0.84014615139837 + 0.84014641333121 + 0.84014675381911 + 0.84014719622179 + 0.84014777410287 + 0.84014853031184 + 0.84014952019177 + 0.84015081613801 + 0.84015251277797 + 0.84015473363490 + 0.84015763977413 + 0.84016144091663 + 0.84016642248454 + 0.84017297569610 + 0.84018160463850 + 0.84019297791736 + 0.84020797810744 + 0.84022769494553 + 0.84025296880191 + 0.84028401547351 + 0.84032151469701 + 0.84036612041299 + 0.84041714775464 + 0.84047427386496 + 0.84053830288526 + 0.84061051983038 + 0.84069257871197 + 0.84078658076345 + 0.84089544799279 + 0.84102281112072 + 0.84117304758543 + 0.84135181560327 + 0.84156648899206 + 0.84182687512919 + 0.84214704975268 + 0.84254956589096 + 0.84306648757352 + 0.84373789587089 + 0.84461665761155 + 0.84577706929937 + 0.84732305330017 + 0.84940460068642 + 0.85224547366909 + 0.85619410892259 + 0.86182707635733 + 0.87018915635512 + 0.88347692018759 + 0.90779452690586 + 1.00000000000000 + 0.89598720614860 + 0.85577358199571 + 0.84020915002304 + 0.82644567276922 + 0.81405122380074 + 0.80273957298439 + 0.79230125421633 + 0.78257013346332 + 0.77340604662927 + 0.76468605625362 + 0.75630080109939 + 0.74814913408834 + 0.74006147498977 + 0.73166950601328 + 0.72277607535089 + 0.71334169318690 + 0.70332368039157 + 0.69273455535295 + 0.68160224074843 + 0.66996777223332 + 0.65788315309504 + 0.64540930403273 + 0.63261069399189 + 0.61949609905891 + 0.60612983261139 + 0.59257949518377 + 0.57891505380874 + 0.56520796331637 + 0.55152979880998 + 0.53792212194269 + 0.52441466310525 + 0.51105204128695 + 0.49786554938887 + 0.48486949950599 + 0.82521776289581 + 0.82521777082493 + 0.82521777213931 + 0.82521777367170 + 0.82521777545846 + 0.82521777754224 + 0.82521777997119 + 0.82521778280344 + 0.82521778611314 + 0.82521778999393 + 0.82521779462398 + 0.82521780030229 + 0.82521780739660 + 0.82521781630538 + 0.82521782750521 + 0.82521784157755 + 0.82521785924663 + 0.82521788141849 + 0.82521790929640 + 0.82521794450771 + 0.82521798898528 + 0.82521804518355 + 0.82521811620829 + 0.82521820598917 + 0.82521831957917 + 0.82521846389155 + 0.82521864925320 + 0.82521888971556 + 0.82521920249192 + 0.82521960911504 + 0.82522014055301 + 0.82522083633377 + 0.82522174749673 + 0.82522294079130 + 0.82522450342827 + 0.82522654920994 + 0.82522922641054 + 0.82523272796235 + 0.82523731634260 + 0.82524335122434 + 0.82525129540480 + 0.82526176206260 + 0.82527555950174 + 0.82529368285760 + 0.82531688625210 + 0.82534533174576 + 0.82537960076962 + 0.82542023427317 + 0.82546651239625 + 0.82551803290040 + 0.82557540947452 + 0.82563966005004 + 0.82571208918200 + 0.82579434222201 + 0.82588872062230 + 0.82599804830134 + 0.82612566838395 + 0.82627587143200 + 0.82645421194806 + 0.82666804781636 + 0.82692802370660 + 0.82725155865748 + 0.82766338515545 + 0.82819374334449 + 0.82888184032503 + 0.82978214802962 + 0.83096951180265 + 0.83254969192132 + 0.83467616798524 + 0.83757910137201 + 0.84161959808517 + 0.84740217139223 + 0.85604500203132 + 0.86996486113902 + 0.89598720614860 + 1.00000000000000 + 0.88328198730309 + 0.85986088395261 + 0.84112194890451 + 0.82531528370946 + 0.81155750084709 + 0.79931747068307 + 0.78823540489875 + 0.77804522569630 + 0.76853732913235 + 0.75954016659983 + 0.75090665239259 + 0.74243033408939 + 0.73371016907859 + 0.72453203585930 + 0.71484879102079 + 0.70461217437372 + 0.69383150302185 + 0.68253213866819 + 0.67075285163953 + 0.65854350121464 + 0.64596291584104 + 0.63307349236418 + 0.61988169736484 + 0.60645007815227 + 0.59284458716463 + 0.57913369410571 + 0.56538753653015 + 0.55167656910979 + 0.53804137830841 + 0.52451090803605 + 0.51112917442941 + 0.49792695917535 + 0.48491812785081 + 0.81021113824146 + 0.81021114542935 + 0.81021114662090 + 0.81021114800974 + 0.81021114962930 + 0.81021115151728 + 0.81021115371805 + 0.81021115628494 + 0.81021115928127 + 0.81021116279722 + 0.81021116699200 + 0.81021117214068 + 0.81021117857523 + 0.81021118666597 + 0.81021119684286 + 0.81021120963979 + 0.81021122572156 + 0.81021124591510 + 0.81021127132490 + 0.81021130344138 + 0.81021134403823 + 0.81021139537008 + 0.81021146028267 + 0.81021154238940 + 0.81021164632784 + 0.81021177845491 + 0.81021194827583 + 0.81021216875023 + 0.81021245573222 + 0.81021282906618 + 0.81021331731573 + 0.81021395693449 + 0.81021479498644 + 0.81021589301655 + 0.81021733141349 + 0.81021921503491 + 0.81022168043517 + 0.81022490516047 + 0.81022913071455 + 0.81023468793792 + 0.81024200199381 + 0.81025163560766 + 0.81026432962273 + 0.81028099356816 + 0.81030230513900 + 0.81032838214201 + 0.81035972209632 + 0.81039677111561 + 0.81043879097068 + 0.81048532374293 + 0.81053682983421 + 0.81059411065165 + 0.81065818865045 + 0.81073034295360 + 0.81081237658915 + 0.81090646966990 + 0.81101514690967 + 0.81114162210935 + 0.81129002457868 + 0.81146580199623 + 0.81167692493781 + 0.81193679007053 + 0.81226441111028 + 0.81268247221410 + 0.81321985653119 + 0.81391629180489 + 0.81482548436784 + 0.81602196172356 + 0.81761145508813 + 0.81974787653256 + 0.82266323030080 + 0.82672500635483 + 0.83256144100108 + 0.84137116484755 + 0.85577358199571 + 0.88328198730309 + 1.00000000000000 + 0.90493074820768 + 0.86976667388200 + 0.84535863632438 + 0.82628499441855 + 0.81049263593459 + 0.79692797575590 + 0.78495174692134 + 0.77413139298444 + 0.76415201621379 + 0.75476935926443 + 0.74570537874045 + 0.73650102199753 + 0.72691152090384 + 0.71687483651917 + 0.70633217897876 + 0.69528656876522 + 0.68375852505458 + 0.67178276328894 + 0.65940552005269 + 0.64668226569206 + 0.63367221391237 + 0.62037845481912 + 0.60686096720613 + 0.59318335775238 + 0.57941200027305 + 0.56561521112135 + 0.55186190936816 + 0.53819135721589 + 0.52463143466558 + 0.51122534140285 + 0.49800316895597 + 0.48497818268660 + 0.80275033132575 + 0.80275033816402 + 0.80275033929741 + 0.80275034061841 + 0.80275034215895 + 0.80275034395414 + 0.80275034604804 + 0.80275034848956 + 0.80275035133975 + 0.80275035468392 + 0.80275035867490 + 0.80275036357157 + 0.80275036969628 + 0.80275037739953 + 0.80275038709306 + 0.80275039929035 + 0.80275041462026 + 0.80275043387823 + 0.80275045812277 + 0.80275048877543 + 0.80275052753860 + 0.80275057656960 + 0.80275063859449 + 0.80275071707369 + 0.80275081645283 + 0.80275094282084 + 0.80275110530639 + 0.80275131634080 + 0.80275159114479 + 0.80275194876614 + 0.80275241663480 + 0.80275302976226 + 0.80275383334037 + 0.80275488647472 + 0.80275626635598 + 0.80275807365373 + 0.80276043944111 + 0.80276353408811 + 0.80276758931176 + 0.80277292250670 + 0.80277994132311 + 0.80278918504100 + 0.80280136319085 + 0.80281734568451 + 0.80283777542299 + 0.80286275127180 + 0.80289273368371 + 0.80292812750519 + 0.80296819066438 + 0.80301244518573 + 0.80306128721151 + 0.80311542680817 + 0.80317576786121 + 0.80324343623500 + 0.80332002639467 + 0.80340745060251 + 0.80350789573389 + 0.80362413301261 + 0.80375970845128 + 0.80391929063320 + 0.80410975880435 + 0.80434285693932 + 0.80463525384670 + 0.80500657255717 + 0.80548155997344 + 0.80609409607810 + 0.80688962415665 + 0.80793068211062 + 0.80930509811925 + 0.81113907574789 + 0.81361965056923 + 0.81703648478331 + 0.82187022329980 + 0.82900016097679 + 0.84020915002304 + 0.85986088395261 + 0.90493074820768 + 1.00000000000000 + 0.89903963672182 + 0.86278104630717 + 0.83800997548872 + 0.81888454670877 + 0.80318186839153 + 0.78975904883050 + 0.77792465247988 + 0.76721488174981 + 0.75729280987805 + 0.74781726083310 + 0.73828191046969 + 0.72841684438365 + 0.71814728275407 + 0.70740568486432 + 0.69618975966934 + 0.68451607279844 + 0.67241616368452 + 0.65993355185673 + 0.64712128671490 + 0.63403636456515 + 0.62067961152397 + 0.60710929440422 + 0.59338748326156 + 0.57957919737039 + 0.56575158784222 + 0.55197259832323 + 0.53828065601952 + 0.52470297240252 + 0.51128223408173 + 0.49804810010335 + 0.48501346103590 + 0.79535358707363 + 0.79535359357472 + 0.79535359465240 + 0.79535359590886 + 0.79535359737297 + 0.79535359908063 + 0.79535360107061 + 0.79535360339215 + 0.79535360610058 + 0.79535360928117 + 0.79535361307464 + 0.79535361773237 + 0.79535362355981 + 0.79535363089153 + 0.79535364012256 + 0.79535365174061 + 0.79535366635443 + 0.79535368471488 + 0.79535370783977 + 0.79535373708924 + 0.79535377409312 + 0.79535382091630 + 0.79535388016967 + 0.79535395516915 + 0.79535405017310 + 0.79535417101877 + 0.79535432646289 + 0.79535452843903 + 0.79535479156153 + 0.79535513411123 + 0.79535558243465 + 0.79535617015826 + 0.79535694068637 + 0.79535795079226 + 0.79535927460822 + 0.79536100880388 + 0.79536327923000 + 0.79536624941313 + 0.79537014174075 + 0.79537526081065 + 0.79538199760977 + 0.79539086913669 + 0.79540255517853 + 0.79541788810656 + 0.79543747819931 + 0.79546140734562 + 0.79549010196887 + 0.79552392943336 + 0.79556214695496 + 0.79560426107332 + 0.79565061118927 + 0.79570182628345 + 0.79575870524942 + 0.79582223874401 + 0.79589383713532 + 0.79597517735406 + 0.79606815115240 + 0.79617514439494 + 0.79629919673682 + 0.79644430206412 + 0.79661639358662 + 0.79682577406266 + 0.79708706881719 + 0.79741725497970 + 0.79783752931900 + 0.79837678144273 + 0.79907346210914 + 0.79998006561669 + 0.80116961624215 + 0.80274578992527 + 0.80485986949059 + 0.80774146722464 + 0.81176194289317 + 0.81757795890027 + 0.82644567276922 + 0.84112194890451 + 0.86976667388200 + 0.89903963672182 + 1.00000000000000 + 0.89292627858310 + 0.85566920532668 + 0.83063484942135 + 0.81153205213523 + 0.79596181486303 + 0.78269393253218 + 0.77098967092480 + 0.76035516534660 + 0.75034978990951 + 0.74039762515475 + 0.73019181124361 + 0.71963846910877 + 0.70865727309851 + 0.69723815899243 + 0.68539205949014 + 0.67314612913518 + 0.66054025538202 + 0.64762434555927 + 0.63445259141459 + 0.62102303527440 + 0.60739185068925 + 0.59361925362504 + 0.57976864577017 + 0.56590579746167 + 0.55209750297176 + 0.53838121105083 + 0.52478335193169 + 0.51134601282366 + 0.49809834862054 + 0.48505281406530 + 0.78803822965449 + 0.78803823583585 + 0.78803823686047 + 0.78803823805430 + 0.78803823944623 + 0.78803824106864 + 0.78803824296075 + 0.78803824516679 + 0.78803824774255 + 0.78803825076346 + 0.78803825436911 + 0.78803825879711 + 0.78803826434005 + 0.78803827131607 + 0.78803828010529 + 0.78803829117036 + 0.78803830509464 + 0.78803832259670 + 0.78803834464884 + 0.78803837255361 + 0.78803840787162 + 0.78803845257812 + 0.78803850917625 + 0.78803858083972 + 0.78803867164965 + 0.78803878720548 + 0.78803893590273 + 0.78803912920223 + 0.78803938113003 + 0.78803970924434 + 0.78804013884431 + 0.78804070223352 + 0.78804144111589 + 0.78804241002175 + 0.78804368017428 + 0.78804534442837 + 0.78804752364017 + 0.78805037482938 + 0.78805411150346 + 0.78805902607049 + 0.78806549367662 + 0.78807401014942 + 0.78808522705589 + 0.78809994119954 + 0.78811873229677 + 0.78814166707608 + 0.78816914078688 + 0.78820148684100 + 0.78823796453496 + 0.78827806908538 + 0.78832209005030 + 0.78837058472654 + 0.78842425951534 + 0.78848398635299 + 0.78855101394208 + 0.78862681357341 + 0.78871302081114 + 0.78881168816969 + 0.78892541878850 + 0.78905762639414 + 0.78921342949601 + 0.78940188061667 + 0.78963583280876 + 0.78992998811465 + 0.79030251236347 + 0.79077805700899 + 0.79138918086392 + 0.79217999374882 + 0.79321130546208 + 0.79456848381378 + 0.79637432322350 + 0.79881181573226 + 0.80217036379422 + 0.80694755034551 + 0.81405122380074 + 0.82531528370946 + 0.84535863632438 + 0.86278104630717 + 0.89292627858310 + 1.00000000000000 + 0.88660279894535 + 0.84846075637633 + 0.82326598382168 + 0.80425226380606 + 0.78884364765733 + 0.77572835406887 + 0.76412248965229 + 0.75341798893222 + 0.74293087356742 + 0.73229756198226 + 0.72139455709318 + 0.71012231686372 + 0.69845916465918 + 0.68640787074084 + 0.67398944769739 + 0.66123886643192 + 0.64820191223948 + 0.63492919748922 + 0.62141531594644 + 0.60771386585863 + 0.59388281471780 + 0.57998362450554 + 0.56608042383986 + 0.55223864885859 + 0.53849459907635 + 0.52487378998967 + 0.51141760746034 + 0.49815461789910 + 0.48509676867646 + 0.78081395221088 + 0.78081395808504 + 0.78081395905855 + 0.78081396019288 + 0.78081396151552 + 0.78081396305756 + 0.78081396485478 + 0.78081396695065 + 0.78081396939784 + 0.78081397226805 + 0.78081397569411 + 0.78081397990359 + 0.78081398517433 + 0.78081399181207 + 0.78081400017616 + 0.78081401071238 + 0.78081402397611 + 0.78081404065644 + 0.78081406168297 + 0.78081408830152 + 0.78081412200436 + 0.78081416468644 + 0.78081421874110 + 0.78081428721244 + 0.78081437401028 + 0.78081448450064 + 0.78081462674412 + 0.78081481173781 + 0.78081505295448 + 0.78081536724991 + 0.78081577893226 + 0.78081631903920 + 0.78081702763866 + 0.78081795713371 + 0.78081917595884 + 0.78082077333569 + 0.78082286536853 + 0.78082560286507 + 0.78082919088819 + 0.78083391024126 + 0.78084012101971 + 0.78084829893542 + 0.78085906877858 + 0.78087319367181 + 0.78089122470911 + 0.78091321514335 + 0.78093953170050 + 0.78097047711650 + 0.78100531524639 + 0.78104353372145 + 0.78108537850722 + 0.78113134383489 + 0.78118205493632 + 0.78123828001226 + 0.78130112645574 + 0.78137188675445 + 0.78145197542533 + 0.78154315849535 + 0.78164766532386 + 0.78176841426165 + 0.78190982673622 + 0.78207987610136 + 0.78228988529997 + 0.78255261017772 + 0.78288364267393 + 0.78330405284736 + 0.78384145782667 + 0.78453299563563 + 0.78542942798062 + 0.78660126675901 + 0.78814859490445 + 0.79021808073900 + 0.79303713713630 + 0.79698771595659 + 0.80273957298439 + 0.81155750084709 + 0.82628499441855 + 0.83800997548872 + 0.85566920532668 + 0.88660279894535 + 1.00000000000000 + 0.88008470539442 + 0.84118767581321 + 0.81593410315907 + 0.79706399409517 + 0.78182992799136 + 0.76884228041565 + 0.75718494257739 + 0.74599424013000 + 0.73481464467466 + 0.72347480477304 + 0.71184530114768 + 0.69988667103080 + 0.68758961494938 + 0.67496639508262 + 0.66204522983747 + 0.64886642972942 + 0.63547599128349 + 0.62186419941071 + 0.60808146140280 + 0.59418300209864 + 0.58022794642343 + 0.56627846339372 + 0.55239837919148 + 0.53862263993366 + 0.52497568771532 + 0.51149808629737 + 0.49821771416007 + 0.48514592726372 + 0.77368191426028 + 0.77368191984137 + 0.77368192076589 + 0.77368192184345 + 0.77368192310020 + 0.77368192456427 + 0.77368192627180 + 0.77368192826338 + 0.77368193058743 + 0.77368193331369 + 0.77368193656894 + 0.77368194056896 + 0.77368194557988 + 0.77368195189410 + 0.77368195985427 + 0.77368196988630 + 0.77368198252012 + 0.77368199841577 + 0.77368201845965 + 0.77368204384889 + 0.77368207600777 + 0.77368211675356 + 0.77368216837918 + 0.77368223379797 + 0.77368231675842 + 0.77368242240706 + 0.77368255847839 + 0.77368273553213 + 0.77368296650279 + 0.77368326758402 + 0.77368366212969 + 0.77368417997248 + 0.77368485961635 + 0.77368575143286 + 0.77368692119481 + 0.77368845465776 + 0.77369046339878 + 0.77369309231333 + 0.77369653841757 + 0.77370107148067 + 0.77370703728074 + 0.77371489243127 + 0.77372523630986 + 0.77373880013687 + 0.77375610822136 + 0.77377720187120 + 0.77380242175556 + 0.77383204293418 + 0.77386533601751 + 0.77390178433031 + 0.77394159593451 + 0.77398520971274 + 0.77403317995898 + 0.77408618459221 + 0.77414520794588 + 0.77421138777654 + 0.77428594889940 + 0.77437041255590 + 0.77446669009953 + 0.77457727965955 + 0.77470600979857 + 0.77485992640099 + 0.77504903661089 + 0.77528443922213 + 0.77557955139156 + 0.77595243117236 + 0.77642656980182 + 0.77703333169028 + 0.77781523984206 + 0.77883077791964 + 0.78016193352453 + 0.78192702250740 + 0.78430630538683 + 0.78759665608356 + 0.79230125421633 + 0.79931747068307 + 0.81049263593459 + 0.81888454670877 + 0.83063484942135 + 0.84846075637633 + 0.88008470539442 + 1.00000000000000 + 0.87339112083595 + 0.83388324670330 + 0.80866627792503 + 0.78997844982108 + 0.77490664951446 + 0.76189306755036 + 0.74974662828143 + 0.73785214056821 + 0.72595690067296 + 0.71388308678599 + 0.70156314675356 + 0.68896949032081 + 0.67610165907642 + 0.66297843934692 + 0.64963276600445 + 0.63610461183183 + 0.62237882467613 + 0.60850182558949 + 0.59452547146150 + 0.58050605598380 + 0.56650339864992 + 0.55257941014999 + 0.53876743796933 + 0.52509066147616 + 0.51158867883641 + 0.49828856300957 + 0.48520097960812 + 0.76663443960236 + 0.76663444490284 + 0.76663444578107 + 0.76663444680457 + 0.76663444799745 + 0.76663444938843 + 0.76663445101026 + 0.76663445290082 + 0.76663445510763 + 0.76663445769751 + 0.76663446078902 + 0.76663446458988 + 0.76663446935330 + 0.76663447535809 + 0.76663448293256 + 0.76663449248281 + 0.76663450451513 + 0.76663451966086 + 0.76663453876962 + 0.76663456298198 + 0.76663459366778 + 0.76663463256307 + 0.76663468186732 + 0.76663474436847 + 0.76663482366119 + 0.76663492468342 + 0.76663505485535 + 0.76663522431999 + 0.76663544550156 + 0.76663573395123 + 0.76663611211945 + 0.76663660867932 + 0.76663726064609 + 0.76663811644910 + 0.76663923932917 + 0.76664071172321 + 0.76664264089758 + 0.76664516611905 + 0.76664847674350 + 0.76665283202798 + 0.76665856414618 + 0.76666611156028 + 0.76667604952274 + 0.76668907903642 + 0.76670569932251 + 0.76672594115771 + 0.76675012141195 + 0.76677849021971 + 0.76681032683999 + 0.76684511316492 + 0.76688302439884 + 0.76692445100377 + 0.76696988542471 + 0.76701992724849 + 0.76707545395878 + 0.76713746985706 + 0.76720703768508 + 0.76728547058588 + 0.76737441079023 + 0.76747600198824 + 0.76759357102353 + 0.76773336933258 + 0.76790427589567 + 0.76811598396937 + 0.76838008087847 + 0.76871210174239 + 0.76913210662195 + 0.76966669580489 + 0.77035165779589 + 0.77123575914229 + 0.77238658453623 + 0.77390030096790 + 0.77592116507528 + 0.77868289275371 + 0.78257013346332 + 0.78823540489875 + 0.79692797575590 + 0.80318186839153 + 0.81153205213523 + 0.82326598382168 + 0.84118767581321 + 0.87339112083595 + 1.00000000000000 + 0.86654489520328 + 0.82658068833806 + 0.80148395220007 + 0.78298983578392 + 0.76792582271947 + 0.75442311560619 + 0.74156307000123 + 0.72894542209410 + 0.71630982258713 + 0.70354263031322 + 0.69058768742931 + 0.67742558908326 + 0.66406168165831 + 0.65051879806554 + 0.63682894144448 + 0.62297002057306 + 0.60898342977705 + 0.59491685817117 + 0.58082314786500 + 0.56675928680886 + 0.55278489708356 + 0.53893143137571 + 0.52522057940430 + 0.51169080258665 + 0.49836822890051 + 0.48526271685406 + 0.75965553613670 + 0.75965554117050 + 0.75965554200481 + 0.75965554297647 + 0.75965554410944 + 0.75965554543021 + 0.75965554697002 + 0.75965554876594 + 0.75965555086099 + 0.75965555332044 + 0.75965555625671 + 0.75965555986669 + 0.75965556439394 + 0.75965557010387 + 0.75965557731057 + 0.75965558640115 + 0.75965559786014 + 0.75965561229142 + 0.75965563050508 + 0.75965565359612 + 0.75965568287526 + 0.75965572000415 + 0.75965576708891 + 0.75965582680556 + 0.75965590259699 + 0.75965599919871 + 0.75965612373552 + 0.75965628594833 + 0.75965649777603 + 0.75965677415490 + 0.75965713667112 + 0.75965761288855 + 0.75965823840303 + 0.75965905978516 + 0.75966013785525 + 0.75966155189504 + 0.75966340505079 + 0.75966583122415 + 0.75966901247542 + 0.75967319804695 + 0.75967870716587 + 0.75968596103988 + 0.75969551199950 + 0.75970803240633 + 0.75972399796768 + 0.75974343020908 + 0.75976662425497 + 0.75979380783098 + 0.75982427042865 + 0.75985749499288 + 0.75989362832589 + 0.75993301856474 + 0.75997610430498 + 0.76002341729320 + 0.76007574235120 + 0.76013396890602 + 0.76019902164224 + 0.76027203737122 + 0.76035443146161 + 0.76044804986010 + 0.76055579624780 + 0.76068324274419 + 0.76083830237992 + 0.76102947892073 + 0.76126682432857 + 0.76156376600878 + 0.76193751808659 + 0.76241075925983 + 0.76301378427813 + 0.76378752088655 + 0.76478809599352 + 0.76609435968115 + 0.76782299118415 + 0.77016048570943 + 0.77340604662927 + 0.77804522569630 + 0.78495174692134 + 0.78975904883050 + 0.79596181486303 + 0.80425226380606 + 0.81593410315907 + 0.83388324670330 + 0.86654489520328 + 1.00000000000000 + 0.85957251135167 + 0.81931113450201 + 0.79439173755478 + 0.77594298993064 + 0.76039392288908 + 0.74617222427337 + 0.73258599001695 + 0.71922465786523 + 0.70589519598430 + 0.69249510964997 + 0.67897592302243 + 0.66532337044123 + 0.65154617835419 + 0.63766563664375 + 0.62365068108148 + 0.60953629831715 + 0.59536497399748 + 0.58118531182827 + 0.56705086709344 + 0.55301851424028 + 0.53911745128778 + 0.52536760494620 + 0.51180609488846 + 0.49845793814026 + 0.48533204793787 + 0.75272237638934 + 0.75272238116826 + 0.75272238196049 + 0.75272238288321 + 0.75272238395913 + 0.75272238521293 + 0.75272238667539 + 0.75272238837968 + 0.75272239036990 + 0.75272239270436 + 0.75272239549177 + 0.75272239892121 + 0.75272240322430 + 0.75272240865357 + 0.75272241550896 + 0.75272242416047 + 0.75272243507244 + 0.75272244881980 + 0.75272246618102 + 0.75272248820326 + 0.75272251613825 + 0.75272255158025 + 0.75272259654778 + 0.75272265360300 + 0.75272272605037 + 0.75272281843209 + 0.75272293758582 + 0.75272309287081 + 0.75272329575512 + 0.75272356059822 + 0.75272390815139 + 0.75272436491834 + 0.75272496514043 + 0.75272575360986 + 0.75272678883326 + 0.75272814708030 + 0.75272992756162 + 0.75273225906093 + 0.75273531667238 + 0.75273934010844 + 0.75274463624066 + 0.75275160985876 + 0.75276079150401 + 0.75277282634535 + 0.75278816802332 + 0.75280682996272 + 0.75282908742429 + 0.75285514794347 + 0.75288431260755 + 0.75291606749994 + 0.75295053490529 + 0.75298802595317 + 0.75302893234275 + 0.75307372703249 + 0.75312311446673 + 0.75317788517610 + 0.75323884634238 + 0.75330698555658 + 0.75338352723234 + 0.75347006764928 + 0.75356915396471 + 0.75368577711662 + 0.75382702256409 + 0.75400038749336 + 0.75421463633052 + 0.75448143648283 + 0.75481564277300 + 0.75523670701244 + 0.75577044268778 + 0.75645145158530 + 0.75732673619228 + 0.75846157962744 + 0.75995145716328 + 0.76194731250720 + 0.76468605625362 + 0.76853732913235 + 0.77413139298444 + 0.77792465247988 + 0.78269393253218 + 0.78884364765733 + 0.79706399409517 + 0.80866627792503 + 0.82658068833806 + 0.85957251135167 + 1.00000000000000 + 0.85250307004067 + 0.81208981256832 + 0.78722235164607 + 0.76829426531343 + 0.75203097582292 + 0.73709062300345 + 0.72276450814854 + 0.70871389077065 + 0.69475739132572 + 0.68080023759784 + 0.66679870377422 + 0.65274135930666 + 0.63863482224714 + 0.62443624691672 + 0.61017234951866 + 0.59587905254598 + 0.58159971157416 + 0.56738369213964 + 0.55328455164467 + 0.53932879317263 + 0.52553424922283 + 0.51193645100791 + 0.49855910633113 + 0.48541001911840 + 0.74580751420159 + 0.74580751873846 + 0.74580751949082 + 0.74580752036670 + 0.74580752138840 + 0.74580752257906 + 0.74580752396628 + 0.74580752558484 + 0.74580752747391 + 0.74580752968962 + 0.74580753233663 + 0.74580753559377 + 0.74580753968214 + 0.74580754484350 + 0.74580755136378 + 0.74580755959866 + 0.74580756998778 + 0.74580758308510 + 0.74580759963273 + 0.74580762063260 + 0.74580764728599 + 0.74580768111779 + 0.74580772406201 + 0.74580777857557 + 0.74580784782749 + 0.74580793617361 + 0.74580805018131 + 0.74580819884203 + 0.74580839317479 + 0.74580864698430 + 0.74580898021971 + 0.74580941838040 + 0.74580999439756 + 0.74581075136638 + 0.74581174558267 + 0.74581305042649 + 0.74581476135289 + 0.74581700225222 + 0.74581994156750 + 0.74582380989402 + 0.74582890233147 + 0.74583560800458 + 0.74584443669465 + 0.74585600771907 + 0.74587075398102 + 0.74588868181814 + 0.74591004830722 + 0.74593504280558 + 0.74596297908902 + 0.74599334813148 + 0.74602625104242 + 0.74606196652780 + 0.74610084533690 + 0.74614330940013 + 0.74618999321991 + 0.74624160201017 + 0.74629884277329 + 0.74636257662184 + 0.74643386705270 + 0.74651410074586 + 0.74660552389047 + 0.74671262871933 + 0.74684178943833 + 0.74699964927586 + 0.74719389053151 + 0.74743470756114 + 0.74773499476122 + 0.74811154207368 + 0.74858649745648 + 0.74918934127769 + 0.74995978229257 + 0.75095242527295 + 0.75224634286560 + 0.75396548161030 + 0.75630080109939 + 0.75954016659983 + 0.76415201621379 + 0.76721488174981 + 0.77098967092480 + 0.77572835406887 + 0.78182992799136 + 0.78997844982108 + 0.80148395220007 + 0.81931113450201 + 0.85250307004067 + 1.00000000000000 + 0.84535029960385 + 0.80472195205243 + 0.77935557778808 + 0.75973827425842 + 0.74278747007715 + 0.72712677725530 + 0.71212617293686 + 0.69746115120822 + 0.68295960067577 + 0.66853191185397 + 0.65413703649279 + 0.63976105130865 + 0.62534536267789 + 0.61090585653949 + 0.59647007891381 + 0.58207482412411 + 0.56776430365041 + 0.55358804475463 + 0.53956931263119 + 0.52572344159125 + 0.51208407582767 + 0.49867337593350 + 0.48549784103972 + 0.73887735251256 + 0.73887735681877 + 0.73887735753227 + 0.73887735836417 + 0.73887735933408 + 0.73887736046377 + 0.73887736178027 + 0.73887736331683 + 0.73887736510867 + 0.73887736721177 + 0.73887736972458 + 0.73887737281759 + 0.73887737670138 + 0.73887738160808 + 0.73887738780979 + 0.73887739564525 + 0.73887740553693 + 0.73887741801265 + 0.73887743378206 + 0.73887745380493 + 0.73887747923236 + 0.73887751152434 + 0.73887755253312 + 0.73887760461544 + 0.73887767080962 + 0.73887775529423 + 0.73887786437555 + 0.73887800669209 + 0.73887819283605 + 0.73887843607086 + 0.73887875558692 + 0.73887917590555 + 0.73887972871221 + 0.73888045547373 + 0.73888141035476 + 0.73888266396925 + 0.73888430817440 + 0.73888646216732 + 0.73888928801509 + 0.73889300758529 + 0.73889790470476 + 0.73890435352338 + 0.73891284397627 + 0.73892397073780 + 0.73893814714656 + 0.73895537335513 + 0.73897588974048 + 0.73899986923701 + 0.73902663923229 + 0.73905569703886 + 0.73908712543574 + 0.73912117458206 + 0.73915815932146 + 0.73919845705883 + 0.73924264113658 + 0.73929134277711 + 0.73934518316135 + 0.73940491570763 + 0.73947146767073 + 0.73954604891490 + 0.73963065020607 + 0.73972933316077 + 0.73984785699876 + 0.73999213623989 + 0.74016893854628 + 0.74038721822429 + 0.74065823098965 + 0.74099655743611 + 0.74142132758365 + 0.74195784630390 + 0.74263994699071 + 0.74351375730131 + 0.74464553472714 + 0.74613847377126 + 0.74814913408834 + 0.75090665239259 + 0.75476935926443 + 0.75729280987805 + 0.76035516534660 + 0.76412248965229 + 0.76884228041565 + 0.77490664951446 + 0.78298983578392 + 0.79439173755478 + 0.81208981256832 + 0.84535029960385 + 1.00000000000000 + 0.83784399489734 + 0.79645944443946 + 0.77045817193920 + 0.75023535208770 + 0.73261739053101 + 0.71631711415562 + 0.70072666931983 + 0.68553620701639 + 0.67058120640853 + 0.65577553739112 + 0.64107572306046 + 0.62640165479099 + 0.61175478452614 + 0.59715181210828 + 0.58262123077446 + 0.56820084899485 + 0.55393525721789 + 0.53984380385562 + 0.52593882604943 + 0.51225171543396 + 0.49880279675694 + 0.48559702911369 + 0.73182530632810 + 0.73182531041244 + 0.73182531108941 + 0.73182531187803 + 0.73182531279694 + 0.73182531386824 + 0.73182531511731 + 0.73182531657363 + 0.73182531827342 + 0.73182532026762 + 0.73182532265097 + 0.73182532558603 + 0.73182532927311 + 0.73182533393322 + 0.73182533982725 + 0.73182534727739 + 0.73182535668760 + 0.73182536856142 + 0.73182538357936 + 0.73182540265776 + 0.73182542689798 + 0.73182545769788 + 0.73182549683185 + 0.73182554655765 + 0.73182560978592 + 0.73182569052572 + 0.73182579482896 + 0.73182593098629 + 0.73182610917242 + 0.73182634213335 + 0.73182664830979 + 0.73182705128230 + 0.73182758150624 + 0.73182827886848 + 0.73182919545919 + 0.73183039919817 + 0.73183197842634 + 0.73183404778084 + 0.73183676312056 + 0.73184033781139 + 0.73184504471667 + 0.73185124341836 + 0.73185940459583 + 0.73187009901748 + 0.73188372126295 + 0.73190026603463 + 0.73191995812650 + 0.73194295540825 + 0.73196859987206 + 0.73199639650831 + 0.73202641200955 + 0.73205887101951 + 0.73209405638485 + 0.73213230601724 + 0.73217413890185 + 0.73222012102610 + 0.73227079889678 + 0.73232683280101 + 0.73238903284265 + 0.73245845740808 + 0.73253687684616 + 0.73262797438918 + 0.73273696806226 + 0.73286913989998 + 0.73303047145201 + 0.73322885538038 + 0.73347415434514 + 0.73377908350409 + 0.73416024432449 + 0.73463947569364 + 0.73524578917993 + 0.73601844999799 + 0.73701349171314 + 0.73831778513888 + 0.74006147498977 + 0.74243033408939 + 0.74570537874045 + 0.74781726083310 + 0.75034978990951 + 0.75341798893222 + 0.75718494257739 + 0.76189306755036 + 0.76792582271947 + 0.77594298993064 + 0.78722235164607 + 0.80472195205243 + 0.83784399489734 + 1.00000000000000 + 0.82917583833720 + 0.78708046779016 + 0.76062117305920 + 0.73983186033703 + 0.72163252871398 + 0.70477599717539 + 0.68868237372531 + 0.67305573640029 + 0.65773746191898 + 0.64263964660011 + 0.62765167864752 + 0.61275515317213 + 0.59795232329122 + 0.58326090667576 + 0.56871056622163 + 0.55433970926715 + 0.54016284595987 + 0.52618864550953 + 0.51244575968602 + 0.49895229593432 + 0.48571136495972 + 0.72435066012037 + 0.72435066398129 + 0.72435066462149 + 0.72435066536721 + 0.72435066623583 + 0.72435066724918 + 0.72435066842996 + 0.72435066980638 + 0.72435067141399 + 0.72435067329987 + 0.72435067555315 + 0.72435067833014 + 0.72435068181998 + 0.72435068623261 + 0.72435069181763 + 0.72435069888083 + 0.72435070780764 + 0.72435071907741 + 0.72435073333877 + 0.72435075146618 + 0.72435077451001 + 0.72435080380608 + 0.72435084104856 + 0.72435088839487 + 0.72435094862725 + 0.72435102557723 + 0.72435112504192 + 0.72435125496393 + 0.72435142508516 + 0.72435164762158 + 0.72435194025535 + 0.72435232559044 + 0.72435283285261 + 0.72435350029194 + 0.72435437788958 + 0.72435553080803 + 0.72435704379940 + 0.72435902683669 + 0.72436162944522 + 0.72436505629829 + 0.72436956907150 + 0.72437551249444 + 0.72438333759003 + 0.72439359080588 + 0.72440664784259 + 0.72442249841372 + 0.72444135207453 + 0.72446335224099 + 0.72448785720578 + 0.72451438137761 + 0.72454297680182 + 0.72457384432988 + 0.72460723708006 + 0.72464345649392 + 0.72468297114326 + 0.72472628709880 + 0.72477388332892 + 0.72482633642385 + 0.72488435188912 + 0.72494885332692 + 0.72502141316646 + 0.72510536756753 + 0.72520543748122 + 0.72532633289658 + 0.72547333209486 + 0.72565338171621 + 0.72587511219135 + 0.72614959991559 + 0.72649124188258 + 0.72691888236179 + 0.72745741200441 + 0.72814030639398 + 0.72901508668184 + 0.73015519275773 + 0.73166950601328 + 0.73371016907859 + 0.73650102199753 + 0.73828191046969 + 0.74039762515475 + 0.74293087356742 + 0.74599424013000 + 0.74974662828143 + 0.75442311560619 + 0.76039392288908 + 0.76829426531343 + 0.77935557778808 + 0.79645944443946 + 0.82917583833720 + 1.00000000000000 + 0.81978727476219 + 0.77715890099056 + 0.75020791565981 + 0.72887252692237 + 0.71011998920420 + 0.69275212795275 + 0.67621321563334 + 0.66021632878026 + 0.64460118089748 + 0.62921071257927 + 0.61399737853528 + 0.59894298378082 + 0.58405041920403 + 0.56933838196024 + 0.55483709376249 + 0.54055475299513 + 0.52649529292934 + 0.51268385420993 + 0.49913572748427 + 0.48585169424059 + 0.71628892077999 + 0.71628892441496 + 0.71628892501733 + 0.71628892571932 + 0.71628892653740 + 0.71628892749133 + 0.71628892860284 + 0.71628892989937 + 0.71628893141244 + 0.71628893318817 + 0.71628893531043 + 0.71628893792501 + 0.71628894121428 + 0.71628894537614 + 0.71628895064617 + 0.71628895731584 + 0.71628896574853 + 0.71628897640176 + 0.71628898988855 + 0.71628900704305 + 0.71628902886169 + 0.71628905661546 + 0.71628909191720 + 0.71628913682054 + 0.71628919397389 + 0.71628926703055 + 0.71628936151420 + 0.71628948500491 + 0.71628964680439 + 0.71628985857059 + 0.71629013719627 + 0.71629050428038 + 0.71629098774361 + 0.71629162415065 + 0.71629246127412 + 0.71629356140055 + 0.71629500554495 + 0.71629689881633 + 0.71629938412224 + 0.71630265708645 + 0.71630696771676 + 0.71631264526034 + 0.71632012028517 + 0.71632991395771 + 0.71634238257339 + 0.71635751123484 + 0.71637549429330 + 0.71639646104361 + 0.71641978820132 + 0.71644500156359 + 0.71647213968000 + 0.71650138083406 + 0.71653295003781 + 0.71656711445245 + 0.71660429501410 + 0.71664494176076 + 0.71668947151295 + 0.71673838436791 + 0.71679229080016 + 0.71685199235426 + 0.71691888020845 + 0.71699596548621 + 0.71708750317347 + 0.71719767561441 + 0.71733111967248 + 0.71749392248783 + 0.71769360306007 + 0.71793976935351 + 0.71824485696740 + 0.71862506783734 + 0.71910169228585 + 0.71970320575247 + 0.72046986090992 + 0.72146373825271 + 0.72277607535089 + 0.72453203585930 + 0.72691152090384 + 0.72841684438365 + 0.73019181124361 + 0.73229756198226 + 0.73481464467466 + 0.73785214056821 + 0.74156307000123 + 0.74617222427337 + 0.75203097582292 + 0.75973827425842 + 0.77045817193920 + 0.78708046779016 + 0.81978727476219 + 1.00000000000000 + 0.81012400820082 + 0.76689637609547 + 0.73942742222716 + 0.71752414610427 + 0.69822708369599 + 0.68038155393813 + 0.66344660052945 + 0.64713349862447 + 0.63120945298162 + 0.61558162935448 + 0.60020141400370 + 0.58505037565470 + 0.57013184774134 + 0.55546481048462 + 0.54104894393708 + 0.52688186911416 + 0.51298409089359 + 0.49936722041017 + 0.48602902652626 + 0.70761131940482 + 0.70761132281162 + 0.70761132337595 + 0.70761132403380 + 0.70761132480089 + 0.70761132569477 + 0.70761132673665 + 0.70761132795157 + 0.70761132936941 + 0.70761133103345 + 0.70761133302232 + 0.70761133547439 + 0.70761133856083 + 0.70761134246853 + 0.70761134741866 + 0.70761135368832 + 0.70761136161924 + 0.70761137164433 + 0.70761138434443 + 0.70761140050680 + 0.70761142107688 + 0.70761144725779 + 0.70761148057566 + 0.70761152297887 + 0.70761157697939 + 0.70761164604210 + 0.70761173541541 + 0.70761185229979 + 0.70761200553643 + 0.70761220621276 + 0.70761247039526 + 0.70761281863528 + 0.70761327750839 + 0.70761388181644 + 0.70761467703524 + 0.70761572246051 + 0.70761709521394 + 0.70761889534694 + 0.70762125888624 + 0.70762437202429 + 0.70762847263588 + 0.70763387387082 + 0.70764098504522 + 0.70765030110377 + 0.70766215843766 + 0.70767653795224 + 0.70769361887857 + 0.70771351675981 + 0.70773562889625 + 0.70775949448259 + 0.70778513974133 + 0.70781272163948 + 0.70784243871103 + 0.70787452598661 + 0.70790935949008 + 0.70794733696209 + 0.70798881820752 + 0.70803423356840 + 0.70808410736858 + 0.70813913071189 + 0.70820052873867 + 0.70827100796892 + 0.70835438655388 + 0.70845436021393 + 0.70857498091004 + 0.70872155483064 + 0.70890059815177 + 0.70912040190563 + 0.70939165399999 + 0.70972821931465 + 0.71014823147332 + 0.71067582552702 + 0.71134500429362 + 0.71220815323568 + 0.71334169318690 + 0.71484879102079 + 0.71687483651917 + 0.71814728275407 + 0.71963846910877 + 0.72139455709318 + 0.72347480477304 + 0.72595690067296 + 0.72894542209410 + 0.73258599001695 + 0.73709062300345 + 0.74278747007715 + 0.75023535208770 + 0.76062117305920 + 0.77715890099056 + 0.81012400820082 + 1.00000000000000 + 0.80009518844200 + 0.75632063695608 + 0.72829798760568 + 0.70581529777705 + 0.68599637952610 + 0.66771784260366 + 0.65043893485053 + 0.63379409164375 + 0.61761611253792 + 0.60180913427930 + 0.58632298257941 + 0.57113885383090 + 0.55625993312233 + 0.54167418918910 + 0.52737070050301 + 0.51336377275724 + 0.49966016021718 + 0.48625370175988 + 0.69828336919694 + 0.69828337237308 + 0.69828337289970 + 0.69828337351308 + 0.69828337422836 + 0.69828337506223 + 0.69828337603349 + 0.69828337716616 + 0.69828337848815 + 0.69828338004015 + 0.69828338189567 + 0.69828338418395 + 0.69828338706566 + 0.69828339071611 + 0.69828339534310 + 0.69828340120760 + 0.69828340863108 + 0.69828341801895 + 0.69828342992004 + 0.69828344507473 + 0.69828346437265 + 0.69828348894900 + 0.69828352024451 + 0.69828356009615 + 0.69828361087490 + 0.69828367585238 + 0.69828375999162 + 0.69828387009844 + 0.69828401454381 + 0.69828420381459 + 0.69828445312842 + 0.69828478194768 + 0.69828521544457 + 0.69828578659253 + 0.69828653848019 + 0.69828752729752 + 0.69828882611355 + 0.69829052972061 + 0.69829276698936 + 0.69829571431070 + 0.69829959694389 + 0.69830471132288 + 0.69831144470239 + 0.69832026485411 + 0.69833148777380 + 0.69834509061621 + 0.69836123759498 + 0.69838003092056 + 0.69840089070069 + 0.69842337157825 + 0.69844748865826 + 0.69847337885011 + 0.69850121583899 + 0.69853120466912 + 0.69856367910971 + 0.69859898824073 + 0.69863743976237 + 0.69867940066857 + 0.69872531743965 + 0.69877578152420 + 0.69883186606731 + 0.69889599212902 + 0.69897156852696 + 0.69906184269426 + 0.69917033395592 + 0.69930163984684 + 0.69946137270452 + 0.69965664346522 + 0.69989658318655 + 0.70019298884043 + 0.70056122237070 + 0.70102164080580 + 0.70160284919628 + 0.70234890639536 + 0.70332368039157 + 0.70461217437372 + 0.70633217897876 + 0.70740568486432 + 0.70865727309851 + 0.71012231686372 + 0.71184530114768 + 0.71388308678599 + 0.71630982258713 + 0.71922465786523 + 0.72276450814854 + 0.72712677725530 + 0.73261739053101 + 0.73983186033703 + 0.75020791565981 + 0.76689637609547 + 0.80009518844200 + 1.00000000000000 + 0.78985390029992 + 0.74550296996907 + 0.71687251479275 + 0.69380407396199 + 0.67349381143369 + 0.65482733383163 + 0.63718150589160 + 0.62025767429629 + 0.60388229379581 + 0.58795574549436 + 0.57242613510417 + 0.55727377203029 + 0.54247011641581 + 0.52799244105190 + 0.51384661251706 + 0.50003287742515 + 0.48653988298055 + 0.68832068534555 + 0.68832068829251 + 0.68832068878066 + 0.68832068935011 + 0.68832069001314 + 0.68832069078633 + 0.68832069168787 + 0.68832069273866 + 0.68832069396549 + 0.68832069540485 + 0.68832069712607 + 0.68832069925097 + 0.68832070192666 + 0.68832070531949 + 0.68832070962284 + 0.68832071507949 + 0.68832072199200 + 0.68832073073936 + 0.68832074183361 + 0.68832075597091 + 0.68832077398470 + 0.68832079693973 + 0.68832082618697 + 0.68832086345181 + 0.68832091096149 + 0.68832097178929 + 0.68832105060272 + 0.68832115381041 + 0.68832128928638 + 0.68832146691394 + 0.68832170102226 + 0.68832200995706 + 0.68832241744573 + 0.68832295457176 + 0.68832366195916 + 0.68832459258400 + 0.68832581534159 + 0.68832741958180 + 0.68832952678986 + 0.68833230323492 + 0.68833596115422 + 0.68834077973391 + 0.68834712348612 + 0.68835543222261 + 0.68836600118305 + 0.68837880426852 + 0.68839399089916 + 0.68841165047250 + 0.68843122804151 + 0.68845229567950 + 0.68847485865641 + 0.68849903521819 + 0.68852497596498 + 0.68855285822866 + 0.68858297636815 + 0.68861563457689 + 0.68865109345884 + 0.68868966306047 + 0.68873172022527 + 0.68877776729515 + 0.68882873922940 + 0.68888679116601 + 0.68895495088349 + 0.68903605582220 + 0.68913314400195 + 0.68925017476371 + 0.68939195197657 + 0.68956453677029 + 0.68977568286031 + 0.69003536885607 + 0.69035653625081 + 0.69075626754693 + 0.69125851910462 + 0.69190020729717 + 0.69273455535295 + 0.69383150302185 + 0.69528656876522 + 0.69618975966934 + 0.69723815899243 + 0.69845916465918 + 0.69988667103080 + 0.70156314675356 + 0.70354263031322 + 0.70589519598430 + 0.70871389077065 + 0.71212617293686 + 0.71631711415562 + 0.72163252871398 + 0.72887252692237 + 0.73942742222716 + 0.75632063695608 + 0.78985390029992 + 1.00000000000000 + 0.77941367794153 + 0.73444119098971 + 0.70516261853061 + 0.68152228177564 + 0.66076058196064 + 0.64167742612338 + 0.62371838524081 + 0.60657300622633 + 0.59006047069569 + 0.57407733557636 + 0.55856967784376 + 0.54348507434330 + 0.52878413890704 + 0.51446105344328 + 0.50050722711386 + 0.48690437567988 + 0.67775370815717 + 0.67775371087610 + 0.67775371132662 + 0.67775371185176 + 0.67775371246355 + 0.67775371317681 + 0.67775371400830 + 0.67775371497775 + 0.67775371610971 + 0.67775371743782 + 0.67775371902611 + 0.67775372098807 + 0.67775372345984 + 0.67775372659552 + 0.67775373057715 + 0.67775373562750 + 0.67775374203033 + 0.67775375013699 + 0.67775376042531 + 0.67775377354326 + 0.67775379026972 + 0.67775381159647 + 0.67775383878709 + 0.67775387344923 + 0.67775391766575 + 0.67775397431044 + 0.67775404774881 + 0.67775414398067 + 0.67775427038138 + 0.67775443620754 + 0.67775465488781 + 0.67775494362276 + 0.67775532465848 + 0.67775582714267 + 0.67775648917980 + 0.67775736044875 + 0.67775850556269 + 0.67776000830990 + 0.67776198259783 + 0.67776458432380 + 0.67776801239354 + 0.67777252833736 + 0.67777847342002 + 0.67778625891390 + 0.67779615910504 + 0.67780814517709 + 0.67782235210185 + 0.67783885711741 + 0.67785713217447 + 0.67787676863251 + 0.67789776327350 + 0.67792021717395 + 0.67794425973209 + 0.67797004296720 + 0.67799782482406 + 0.67802786852605 + 0.67806039260413 + 0.67809565653047 + 0.67813397556558 + 0.67817577319967 + 0.67822185979934 + 0.67827414453796 + 0.67833530315936 + 0.67840780131310 + 0.67849424599373 + 0.67859802691339 + 0.67872323121699 + 0.67887499429099 + 0.67905986152733 + 0.67928622523508 + 0.67956492834956 + 0.67991023293162 + 0.68034211174738 + 0.68089137667860 + 0.68160224074843 + 0.68253213866819 + 0.68375852505458 + 0.68451607279844 + 0.68539205949014 + 0.68640787074084 + 0.68758961494938 + 0.68896949032081 + 0.69058768742931 + 0.69249510964997 + 0.69475739132572 + 0.69746115120822 + 0.70072666931983 + 0.70477599717539 + 0.71011998920420 + 0.71752414610427 + 0.72829798760568 + 0.74550296996907 + 0.77941367794153 + 1.00000000000000 + 0.76878736427696 + 0.72313819713381 + 0.69319053724414 + 0.66900558173391 + 0.64775419521217 + 0.62830967613839 + 0.61009648507270 + 0.59279098770026 + 0.57620512983757 + 0.56023162550985 + 0.54478236567203 + 0.52979384119817 + 0.51524371310585 + 0.50111118739589 + 0.48736860260711 + 0.66662601644860 + 0.66662601894362 + 0.66662601935685 + 0.66662601983879 + 0.66662602039996 + 0.66662602105431 + 0.66662602181729 + 0.66662602270637 + 0.66662602374455 + 0.66662602496265 + 0.66662602642104 + 0.66662602822181 + 0.66662603049324 + 0.66662603337590 + 0.66662603703812 + 0.66662604168773 + 0.66662604758494 + 0.66662605505636 + 0.66662606454489 + 0.66662607665135 + 0.66662609209608 + 0.66662611180353 + 0.66662613694260 + 0.66662616900988 + 0.66662620993746 + 0.66662626240045 + 0.66662633045921 + 0.66662641970112 + 0.66662653699579 + 0.66662669096407 + 0.66662689412831 + 0.66662716252083 + 0.66662751688803 + 0.66662798441201 + 0.66662860063894 + 0.66662941190265 + 0.66663047846802 + 0.66663187847231 + 0.66663371813706 + 0.66663614282425 + 0.66663933791617 + 0.66664354705103 + 0.66664908793455 + 0.66665634299004 + 0.66666556554713 + 0.66667672464249 + 0.66668994129154 + 0.66670528133387 + 0.66672224530669 + 0.66674044551167 + 0.66675987160581 + 0.66678060908558 + 0.66680276811578 + 0.66682647787749 + 0.66685196301646 + 0.66687944976487 + 0.66690911956797 + 0.66694118753937 + 0.66697591515711 + 0.66701365691716 + 0.66705511181836 + 0.66710196328106 + 0.66715656450800 + 0.66722104703204 + 0.66729763555487 + 0.66738921617673 + 0.66749924674005 + 0.66763205394453 + 0.66779313279275 + 0.66798950373252 + 0.66823020491275 + 0.66852708665952 + 0.66889672919430 + 0.66936475327856 + 0.66996777223332 + 0.67075285163953 + 0.67178276328894 + 0.67241616368452 + 0.67314612913518 + 0.67398944769739 + 0.67496639508262 + 0.67610165907642 + 0.67742558908326 + 0.67897592302243 + 0.68080023759784 + 0.68295960067577 + 0.68553620701639 + 0.68868237372531 + 0.69275212795275 + 0.69822708369599 + 0.70581529777705 + 0.71687251479275 + 0.73444119098971 + 0.76878736427696 + 1.00000000000000 + 0.75798753881605 + 0.71160405490022 + 0.68098222329583 + 0.65619590392672 + 0.63451258700287 + 0.61476860756073 + 0.59636477421952 + 0.57896441269922 + 0.56237263824288 + 0.54644582267157 + 0.53108438535173 + 0.51624201582785 + 0.50188071809318 + 0.48795993505223 + 0.65499248103438 + 0.65499248330999 + 0.65499248368700 + 0.65499248412664 + 0.65499248463865 + 0.65499248523553 + 0.65499248593142 + 0.65499248674296 + 0.65499248769000 + 0.65499248880167 + 0.65499249013116 + 0.65499249177517 + 0.65499249384961 + 0.65499249648496 + 0.65499249983465 + 0.65499250409032 + 0.65499250949146 + 0.65499251633962 + 0.65499252504146 + 0.65499253615139 + 0.65499255033564 + 0.65499256844350 + 0.65499259155763 + 0.65499262105791 + 0.65499265873371 + 0.65499270705598 + 0.65499276978148 + 0.65499285208436 + 0.65499296032834 + 0.65499310249978 + 0.65499329020557 + 0.65499353831101 + 0.65499386605595 + 0.65499429865377 + 0.65499486906289 + 0.65499562027357 + 0.65499660817235 + 0.65499790522445 + 0.65499960992636 + 0.65500185706056 + 0.65500481843569 + 0.65500871973612 + 0.65501385506165 + 0.65502057797723 + 0.65502912109205 + 0.65503945186836 + 0.65505167800818 + 0.65506585482434 + 0.65508151278874 + 0.65509828648781 + 0.65511615982776 + 0.65513520435010 + 0.65515551301130 + 0.65517719464965 + 0.65520044377965 + 0.65522545361722 + 0.65525237334931 + 0.65528137969957 + 0.65531268775012 + 0.65534659230930 + 0.65538369368658 + 0.65542546979697 + 0.65547398085054 + 0.65553106087774 + 0.65559859878358 + 0.65567903970327 + 0.65577529421494 + 0.65589098926294 + 0.65603071512029 + 0.65620031621179 + 0.65640729131206 + 0.65666144398062 + 0.65697648429152 + 0.65737364348927 + 0.65788315309504 + 0.65854350121464 + 0.65940552005269 + 0.65993355185673 + 0.66054025538202 + 0.66123886643192 + 0.66204522983747 + 0.66297843934692 + 0.66406168165831 + 0.66532337044123 + 0.66679870377422 + 0.66853191185397 + 0.67058120640853 + 0.67305573640029 + 0.67621321563334 + 0.68038155393813 + 0.68599637952610 + 0.69380407396199 + 0.70516261853061 + 0.72313819713381 + 0.75798753881605 + 1.00000000000000 + 0.74702714288014 + 0.69984876577836 + 0.66845255330261 + 0.64312537919025 + 0.62107699822284 + 0.60110076011441 + 0.58257395850980 + 0.56514793890316 + 0.54858815682269 + 0.53273888107654 + 0.51751788568212 + 0.50286229958655 + 0.48871346818886 + 0.64291733112038 + 0.64291733318427 + 0.64291733352618 + 0.64291733392466 + 0.64291733438893 + 0.64291733493052 + 0.64291733556125 + 0.64291733629674 + 0.64291733715567 + 0.64291733816378 + 0.64291733937048 + 0.64291734086213 + 0.64291734274621 + 0.64291734514096 + 0.64291734818747 + 0.64291735206109 + 0.64291735698076 + 0.64291736322151 + 0.64291737115768 + 0.64291738129560 + 0.64291739424853 + 0.64291741079504 + 0.64291743192888 + 0.64291745891929 + 0.64291749340897 + 0.64291753767014 + 0.64291759516204 + 0.64291767064606 + 0.64291776998791 + 0.64291790054400 + 0.64291807301382 + 0.64291830110297 + 0.64291860255452 + 0.64291900062462 + 0.64291952571422 + 0.64292021747627 + 0.64292112746001 + 0.64292232248727 + 0.64292389339205 + 0.64292596444685 + 0.64292869399050 + 0.64293228991061 + 0.64293702292423 + 0.64294321807018 + 0.64295108770016 + 0.64296059829699 + 0.64297184501277 + 0.64298487360134 + 0.64299924539535 + 0.64301461825337 + 0.64303097163962 + 0.64304836479020 + 0.64306687546792 + 0.64308659462026 + 0.64310768980746 + 0.64313032508654 + 0.64315462197186 + 0.64318072437552 + 0.64320880784498 + 0.64323911608989 + 0.64327216270013 + 0.64330924004241 + 0.64335214447199 + 0.64340244751122 + 0.64346174584546 + 0.64353210202824 + 0.64361595508936 + 0.64371633190851 + 0.64383705024026 + 0.64398295475147 + 0.64416024150285 + 0.64437698947118 + 0.64464449610357 + 0.64498030188985 + 0.64540930403273 + 0.64596291584104 + 0.64668226569206 + 0.64712128671490 + 0.64762434555927 + 0.64820191223948 + 0.64886642972942 + 0.64963276600445 + 0.65051879806554 + 0.65154617835419 + 0.65274135930666 + 0.65413703649279 + 0.65577553739112 + 0.65773746191898 + 0.66021632878026 + 0.66344660052945 + 0.66771784260366 + 0.67349381143369 + 0.68152228177564 + 0.69319053724414 + 0.71160405490022 + 0.74702714288014 + 1.00000000000000 + 0.73590600904691 + 0.68773420781151 + 0.65562287038837 + 0.62983025838181 + 0.60749079199593 + 0.58735423904304 + 0.56877652314179 + 0.55136398348129 + 0.53486891317803 + 0.51915307966497 + 0.50411648661863 + 0.48967443722108 + 0.63046888339843 + 0.63046888525905 + 0.63046888556678 + 0.63046888592600 + 0.63046888634442 + 0.63046888683279 + 0.63046888740122 + 0.63046888806475 + 0.63046888883931 + 0.63046888974822 + 0.63046889083631 + 0.63046889218219 + 0.63046889388317 + 0.63046889604755 + 0.63046889880255 + 0.63046890230787 + 0.63046890676280 + 0.63046891241815 + 0.63046891961487 + 0.63046892881579 + 0.63046894057866 + 0.63046895561534 + 0.63046897483259 + 0.63046899939087 + 0.63046903079037 + 0.63046907111113 + 0.63046912351665 + 0.63046919237248 + 0.63046928304814 + 0.63046940228359 + 0.63046955989228 + 0.63046976844302 + 0.63047004420654 + 0.63047040851716 + 0.63047088926852 + 0.63047152283074 + 0.63047235649691 + 0.63047345155267 + 0.63047489130526 + 0.63047678971792 + 0.63047929192091 + 0.63048258836308 + 0.63048692687986 + 0.63049260464821 + 0.63049981444976 + 0.63050852235634 + 0.63051881185781 + 0.63053072017761 + 0.63054383996480 + 0.63055785294107 + 0.63057273535292 + 0.63058853573229 + 0.63060531859604 + 0.63062315937037 + 0.63064220171701 + 0.63066258423860 + 0.63068440498122 + 0.63070778015804 + 0.63073285197724 + 0.63075982081767 + 0.63078912461836 + 0.63082188950344 + 0.63085967612282 + 0.63090382622780 + 0.63095568433912 + 0.63101698376820 + 0.63108976050356 + 0.63117653088589 + 0.63128045803604 + 0.63140554282922 + 0.63155688629603 + 0.63174112331181 + 0.63196753448310 + 0.63225057245226 + 0.63261069399189 + 0.63307349236418 + 0.63367221391237 + 0.63403636456515 + 0.63445259141459 + 0.63492919748922 + 0.63547599128349 + 0.63610461183183 + 0.63682894144448 + 0.63766563664375 + 0.63863482224714 + 0.63976105130865 + 0.64107572306046 + 0.64263964660011 + 0.64460118089748 + 0.64713349862447 + 0.65043893485053 + 0.65482733383163 + 0.66076058196064 + 0.66900558173391 + 0.68098222329583 + 0.69984876577836 + 0.73590600904691 + 1.00000000000000 + 0.72437794764799 + 0.67526454996113 + 0.64252445299168 + 0.61635220954464 + 0.59380082348654 + 0.57358029826352 + 0.55499233832499 + 0.53762823959605 + 0.52125787432820 + 0.50572359310421 + 0.49090203201281 + 0.61766144346996 + 0.61766144513645 + 0.61766144541243 + 0.61766144573434 + 0.61766144610930 + 0.61766144654653 + 0.61766144705587 + 0.61766144765004 + 0.61766144834365 + 0.61766144915810 + 0.61766145013290 + 0.61766145134000 + 0.61766145286607 + 0.61766145480965 + 0.61766145728548 + 0.61766146043808 + 0.61766146444747 + 0.61766146954101 + 0.61766147602732 + 0.61766148432623 + 0.61766149494465 + 0.61766150852672 + 0.61766152589797 + 0.61766154810976 + 0.61766157652692 + 0.61766161304113 + 0.61766166053231 + 0.61766172297237 + 0.61766180525357 + 0.61766191352050 + 0.61766205671442 + 0.61766224629576 + 0.61766249710256 + 0.61766282859477 + 0.61766326621120 + 0.61766384312875 + 0.61766460248084 + 0.61766560015884 + 0.61766691212669 + 0.61766864229647 + 0.61767092293009 + 0.61767392750065 + 0.61767788159980 + 0.61768305536694 + 0.61768962281165 + 0.61769755012317 + 0.61770691003874 + 0.61771773226802 + 0.61772964092340 + 0.61774234190451 + 0.61775580932580 + 0.61777008249643 + 0.61778521448047 + 0.61780126732312 + 0.61781836361437 + 0.61783661982141 + 0.61785611425489 + 0.61787693988166 + 0.61789921096504 + 0.61792309128548 + 0.61794895291487 + 0.61797777338508 + 0.61801090335791 + 0.61804948404018 + 0.61809464298751 + 0.61814783098168 + 0.61821074050081 + 0.61828545465166 + 0.61837458315480 + 0.61848141623885 + 0.61861013611082 + 0.61876616994031 + 0.61895711361769 + 0.61919483701901 + 0.61949609905891 + 0.61988169736484 + 0.62037845481912 + 0.62067961152397 + 0.62102303527440 + 0.62141531594644 + 0.62186419941071 + 0.62237882467613 + 0.62297002057306 + 0.62365068108148 + 0.62443624691672 + 0.62534536267789 + 0.62640165479099 + 0.62765167864752 + 0.62921071257927 + 0.63120945298162 + 0.63379409164375 + 0.63718150589160 + 0.64167742612338 + 0.64775419521217 + 0.65619590392672 + 0.66845255330261 + 0.68773420781151 + 0.72437794764799 + 1.00000000000000 + 0.71262615710069 + 0.66256553505051 + 0.62926384330619 + 0.60278379011648 + 0.58009126419172 + 0.55982103833581 + 0.54125449272376 + 0.52399953616461 + 0.50780385322712 + 0.49248405978324 + 0.60456332613205 + 0.60456332761504 + 0.60456332786081 + 0.60456332814709 + 0.60456332848100 + 0.60456332886987 + 0.60456332932301 + 0.60456332985228 + 0.60456333046912 + 0.60456333119395 + 0.60456333206159 + 0.60456333313626 + 0.60456333449679 + 0.60456333623031 + 0.60456333844159 + 0.60456334125876 + 0.60456334484475 + 0.60456334940447 + 0.60456335521441 + 0.60456336265457 + 0.60456337218057 + 0.60456338437555 + 0.60456339998313 + 0.60456341995269 + 0.60456344551783 + 0.60456347839008 + 0.60456352117276 + 0.60456357746465 + 0.60456365169457 + 0.60456374942910 + 0.60456387877422 + 0.60456405011857 + 0.60456427691908 + 0.60456457682115 + 0.60456497289929 + 0.60456549524889 + 0.60456618298434 + 0.60456708679521 + 0.60456827556302 + 0.60456984351027 + 0.60457191049906 + 0.60457463366883 + 0.60457821721957 + 0.60458290536548 + 0.60458885430388 + 0.60459603081454 + 0.60460449784784 + 0.60461427858952 + 0.60462502832060 + 0.60463647702479 + 0.60464859762440 + 0.60466142158779 + 0.60467499217284 + 0.60468936001425 + 0.60470462925677 + 0.60472089727460 + 0.60473822594277 + 0.60475668889925 + 0.60477637716718 + 0.60479742380829 + 0.60482014384893 + 0.60484538280676 + 0.60487430545157 + 0.60490787901014 + 0.60494704548140 + 0.60499301464387 + 0.60504718787426 + 0.60511128273012 + 0.60518744362684 + 0.60527836534075 + 0.60538746279628 + 0.60551915760876 + 0.60567964395555 + 0.60587863928320 + 0.60612983261139 + 0.60645007815227 + 0.60686096720613 + 0.60710929440422 + 0.60739185068925 + 0.60771386585863 + 0.60808146140280 + 0.60850182558949 + 0.60898342977705 + 0.60953629831715 + 0.61017234951866 + 0.61090585653949 + 0.61175478452614 + 0.61275515317213 + 0.61399737853528 + 0.61558162935448 + 0.61761611253792 + 0.62025767429629 + 0.62371838524081 + 0.62830967613839 + 0.63451258700287 + 0.64312537919025 + 0.65562287038837 + 0.67526454996113 + 0.71262615710069 + 1.00000000000000 + 0.70066081660246 + 0.64967601537519 + 0.61588905825652 + 0.58917588794753 + 0.56637492132590 + 0.54608712247833 + 0.52760734965025 + 0.51051684520247 + 0.49453405939293 + 0.59124623034647 + 0.59124623165692 + 0.59124623187395 + 0.59124623212708 + 0.59124623242160 + 0.59124623276517 + 0.59124623316599 + 0.59124623363309 + 0.59124623417858 + 0.59124623481885 + 0.59124623558618 + 0.59124623653644 + 0.59124623774137 + 0.59124623927815 + 0.59124624123915 + 0.59124624374024 + 0.59124624692598 + 0.59124625098104 + 0.59124625615224 + 0.59124626278003 + 0.59124627127323 + 0.59124628215409 + 0.59124629609034 + 0.59124631393637 + 0.59124633679630 + 0.59124636621205 + 0.59124640452444 + 0.59124645497346 + 0.59124652154658 + 0.59124660926151 + 0.59124672541946 + 0.59124687939300 + 0.59124708331195 + 0.59124735309497 + 0.59124770955477 + 0.59124817983599 + 0.59124879922806 + 0.59124961344467 + 0.59125068461604 + 0.59125209771108 + 0.59125396078562 + 0.59125641541815 + 0.59125964547705 + 0.59126387057250 + 0.59126923018266 + 0.59127569208642 + 0.59128331040463 + 0.59129210276802 + 0.59130175487276 + 0.59131202031077 + 0.59132287160980 + 0.59133433361735 + 0.59134644128504 + 0.59135923558157 + 0.59137280460072 + 0.59138722934920 + 0.59140255811599 + 0.59141884857652 + 0.59143617254175 + 0.59145463741219 + 0.59147450897959 + 0.59149651606209 + 0.59152165971418 + 0.59155075691637 + 0.59158459170372 + 0.59162416915228 + 0.59167064504622 + 0.59172542977263 + 0.59179027809958 + 0.59186738778633 + 0.59195953533070 + 0.59207030784876 + 0.59220473671626 + 0.59237075041749 + 0.59257949518377 + 0.59284458716463 + 0.59318335775238 + 0.59338748326156 + 0.59361925362504 + 0.59388281471780 + 0.59418300209864 + 0.59452547146150 + 0.59491685817117 + 0.59536497399748 + 0.59587905254598 + 0.59647007891381 + 0.59715181210828 + 0.59795232329122 + 0.59894298378082 + 0.60020141400370 + 0.60180913427930 + 0.60388229379581 + 0.60657300622633 + 0.61009648507270 + 0.61476860756073 + 0.62107699822284 + 0.62983025838181 + 0.64252445299168 + 0.66256553505051 + 0.70066081660246 + 1.00000000000000 + 0.68849855562890 + 0.63663960925878 + 0.60244917597185 + 0.57553347954225 + 0.55265628043266 + 0.53242209159111 + 0.51409117766380 + 0.49721011909342 + 0.57778413967944 + 0.57778414082891 + 0.57778414101931 + 0.57778414124128 + 0.57778414149986 + 0.57778414180152 + 0.57778414215323 + 0.57778414256288 + 0.57778414304131 + 0.57778414360283 + 0.57778414427612 + 0.57778414511123 + 0.57778414617037 + 0.57778414752244 + 0.57778414924977 + 0.57778415145550 + 0.57778415426779 + 0.57778415785051 + 0.57778416242342 + 0.57778416828886 + 0.57778417581230 + 0.57778418545882 + 0.57778419782478 + 0.57778421367144 + 0.57778423398875 + 0.57778426014853 + 0.57778429424975 + 0.57778433919133 + 0.57778439854425 + 0.57778447680138 + 0.57778458051370 + 0.57778471807769 + 0.57778490037806 + 0.57778514169327 + 0.57778546069811 + 0.57778588174685 + 0.57778643650864 + 0.57778716599706 + 0.57778812595853 + 0.57778939263080 + 0.57779106292124 + 0.57779326375358 + 0.57779615985084 + 0.57779994772292 + 0.57780475131145 + 0.57781053970314 + 0.57781735914179 + 0.57782522257703 + 0.57783384498434 + 0.57784300275810 + 0.57785266864721 + 0.57786286196170 + 0.57787361064594 + 0.57788494753055 + 0.57789694680092 + 0.57790967547961 + 0.57792317067977 + 0.57793747695931 + 0.57795265030656 + 0.57796877674920 + 0.57798607969499 + 0.57800518519515 + 0.57802695066332 + 0.57805206376248 + 0.57808117445159 + 0.57811511446538 + 0.57815483298172 + 0.57820148303154 + 0.57825649399441 + 0.57832164989721 + 0.57839919736990 + 0.57849203261531 + 0.57860422440894 + 0.57874221707671 + 0.57891505380874 + 0.57913369410571 + 0.57941200027305 + 0.57957919737039 + 0.57976864577017 + 0.57998362450554 + 0.58022794642343 + 0.58050605598380 + 0.58082314786500 + 0.58118531182827 + 0.58159971157416 + 0.58207482412411 + 0.58262123077446 + 0.58326090667576 + 0.58405041920403 + 0.58505037565470 + 0.58632298257941 + 0.58795574549436 + 0.59006047069569 + 0.59279098770026 + 0.59636477421952 + 0.60110076011441 + 0.60749079199593 + 0.61635220954464 + 0.62926384330619 + 0.64967601537519 + 0.68849855562890 + 1.00000000000000 + 0.67616321533584 + 0.62350273840862 + 0.58893743748573 + 0.56185152159346 + 0.53897682478279 + 0.51886704502507 + 0.50073880874049 + 0.56425225556762 + 0.56425225656873 + 0.56425225673437 + 0.56425225692740 + 0.56425225715260 + 0.56425225741532 + 0.56425225772134 + 0.56425225807789 + 0.56425225849423 + 0.56425225898321 + 0.56425225956982 + 0.56425226029700 + 0.56425226122128 + 0.56425226240231 + 0.56425226391295 + 0.56425226584445 + 0.56425226830918 + 0.56425227145123 + 0.56425227546690 + 0.56425228062331 + 0.56425228724242 + 0.56425229573850 + 0.56425230663956 + 0.56425232062026 + 0.56425233855975 + 0.56425236167889 + 0.56425239184171 + 0.56425243163122 + 0.56425248422783 + 0.56425255363221 + 0.56425264568486 + 0.56425276787724 + 0.56425292991827 + 0.56425314454967 + 0.56425342843991 + 0.56425380333346 + 0.56425429749599 + 0.56425494754932 + 0.56425580326052 + 0.56425693269939 + 0.56425842235424 + 0.56426038546597 + 0.56426296891251 + 0.56426634771434 + 0.56427063150159 + 0.56427579090308 + 0.56428186517925 + 0.56428886338012 + 0.56429652830797 + 0.56430465807271 + 0.56431322610375 + 0.56432224710549 + 0.56433174313445 + 0.56434174019374 + 0.56435230043825 + 0.56436347897859 + 0.56437530376845 + 0.56438780861577 + 0.56440103650914 + 0.56441505570572 + 0.56443005319533 + 0.56444656481268 + 0.56446532232097 + 0.56448690231957 + 0.56451184121137 + 0.56454082423975 + 0.56457462712978 + 0.56461418773823 + 0.56466066428236 + 0.56471549708844 + 0.56478049390778 + 0.56485797999392 + 0.56495122857756 + 0.56506545442943 + 0.56520796331637 + 0.56538753653015 + 0.56561521112135 + 0.56575158784222 + 0.56590579746167 + 0.56608042383986 + 0.56627846339372 + 0.56650339864992 + 0.56675928680886 + 0.56705086709344 + 0.56738369213964 + 0.56776430365041 + 0.56820084899485 + 0.56871056622163 + 0.56933838196024 + 0.57013184774134 + 0.57113885383090 + 0.57242613510417 + 0.57407733557636 + 0.57620512983757 + 0.57896441269922 + 0.58257395850980 + 0.58735423904304 + 0.59380082348654 + 0.60278379011648 + 0.61588905825652 + 0.63663960925878 + 0.67616321533584 + 1.00000000000000 + 0.66368578454618 + 0.61023769220574 + 0.57533361498658 + 0.54816733318941 + 0.52537740917298 + 0.50545755600773 + 0.55072548046593 + 0.55072548133003 + 0.55072548147309 + 0.55072548163961 + 0.55072548183382 + 0.55072548206052 + 0.55072548232469 + 0.55072548263259 + 0.55072548299229 + 0.55072548341470 + 0.55072548392112 + 0.55072548455028 + 0.55072548534975 + 0.55072548637357 + 0.55072548768476 + 0.55072548936260 + 0.55072549150670 + 0.55072549424347 + 0.55072549774447 + 0.55072550224470 + 0.55072550802923 + 0.55072551546053 + 0.55072552500411 + 0.55072553725706 + 0.55072555299527 + 0.55072557329446 + 0.55072559980599 + 0.55072563481443 + 0.55072568113629 + 0.55072574231906 + 0.55072582354015 + 0.55072593144579 + 0.55072607465385 + 0.55072626447618 + 0.55072651571616 + 0.55072684769176 + 0.55072728551263 + 0.55072786171576 + 0.55072862052508 + 0.55072962242957 + 0.55073094427284 + 0.55073268663090 + 0.55073497989419 + 0.55073797927291 + 0.55074178132002 + 0.55074635835810 + 0.55075174349744 + 0.55075794256629 + 0.55076472450450 + 0.55077190785348 + 0.55077946704581 + 0.55078741296685 + 0.55079576274509 + 0.55080453667104 + 0.55081378652299 + 0.55082355727104 + 0.55083386939533 + 0.55084474791914 + 0.55085622518401 + 0.55086835470878 + 0.55088129224955 + 0.55089549467120 + 0.55091158413894 + 0.55093004206236 + 0.55095130885933 + 0.55097594621547 + 0.55100458455038 + 0.55103798219692 + 0.55107707190733 + 0.55112300914990 + 0.55117723900304 + 0.55124161600124 + 0.55131875726977 + 0.55141286070600 + 0.55152979880998 + 0.55167656910979 + 0.55186190936816 + 0.55197259832323 + 0.55209750297176 + 0.55223864885859 + 0.55239837919148 + 0.55257941014999 + 0.55278489708356 + 0.55301851424028 + 0.55328455164467 + 0.55358804475463 + 0.55393525721789 + 0.55433970926715 + 0.55483709376249 + 0.55546481048462 + 0.55625993312233 + 0.55727377203029 + 0.55856967784376 + 0.56023162550985 + 0.56237263824288 + 0.56514793890316 + 0.56877652314179 + 0.57358029826352 + 0.58009126419172 + 0.58917588794753 + 0.60244917597185 + 0.62350273840862 + 0.66368578454618 + 1.00000000000000 + 0.65097296854730 + 0.59679710324506 + 0.56166750715939 + 0.53451933801019 + 0.51189563464671 + 0.53724846298034 + 0.53724846371929 + 0.53724846384180 + 0.53724846398448 + 0.53724846415096 + 0.53724846434484 + 0.53724846457086 + 0.53724846483440 + 0.53724846514186 + 0.53724846550331 + 0.53724846593686 + 0.53724846647653 + 0.53724846716288 + 0.53724846804274 + 0.53724846917165 + 0.53724847061723 + 0.53724847246742 + 0.53724847483232 + 0.53724847786154 + 0.53724848175933 + 0.53724848677604 + 0.53724849322876 + 0.53724850152540 + 0.53724851218921 + 0.53724852589881 + 0.53724854360083 + 0.53724856674692 + 0.53724859734701 + 0.53724863788262 + 0.53724869147769 + 0.53724876270010 + 0.53724885741222 + 0.53724898322508 + 0.53724915012898 + 0.53724937120406 + 0.53724966352405 + 0.53725004928757 + 0.53725055726306 + 0.53725122656344 + 0.53725211069334 + 0.53725327761322 + 0.53725481625411 + 0.53725684186756 + 0.53725949150700 + 0.53726284984502 + 0.53726689098269 + 0.53727164263968 + 0.53727710800845 + 0.53728308037034 + 0.53728939732270 + 0.53729603452671 + 0.53730299971708 + 0.53731030590112 + 0.53731796860864 + 0.53732603067352 + 0.53733452845484 + 0.53734347635522 + 0.53735289224872 + 0.53736279979135 + 0.53737324030455 + 0.53738434280420 + 0.53739649514656 + 0.53741022402044 + 0.53742592935017 + 0.53744397052211 + 0.53746480513415 + 0.53748894205697 + 0.53751699010041 + 0.53754969489047 + 0.53758797625238 + 0.53763298020277 + 0.53768617399071 + 0.53774963463641 + 0.53782672015201 + 0.53792212194269 + 0.53804137830841 + 0.53819135721589 + 0.53828065601952 + 0.53838121105083 + 0.53849459907635 + 0.53862263993366 + 0.53876743796933 + 0.53893143137571 + 0.53911745128778 + 0.53932879317263 + 0.53956931263119 + 0.53984380385562 + 0.54016284595987 + 0.54055475299513 + 0.54104894393708 + 0.54167418918910 + 0.54247011641581 + 0.54348507434330 + 0.54478236567203 + 0.54644582267157 + 0.54858815682269 + 0.55136398348129 + 0.55499233832499 + 0.55982103833581 + 0.56637492132590 + 0.57553347954225 + 0.58893743748573 + 0.61023769220574 + 0.65097296854730 + 1.00000000000000 + 0.63800933702787 + 0.58325139681518 + 0.54800403213354 + 0.52096789822536 + 0.52385347880237 + 0.52385347942905 + 0.52385347953260 + 0.52385347965378 + 0.52385347979477 + 0.52385347995910 + 0.52385348015049 + 0.52385348037415 + 0.52385348063500 + 0.52385348094142 + 0.52385348130922 + 0.52385348176709 + 0.52385348235114 + 0.52385348310075 + 0.52385348406332 + 0.52385348529901 + 0.52385348688238 + 0.52385348890894 + 0.52385349150817 + 0.52385349485846 + 0.52385349917598 + 0.52385350473726 + 0.52385351189600 + 0.52385352110798 + 0.52385353296505 + 0.52385354829352 + 0.52385356836134 + 0.52385359492685 + 0.52385363016270 + 0.52385367680585 + 0.52385373886106 + 0.52385382147592 + 0.52385393133002 + 0.52385407720350 + 0.52385427059205 + 0.52385452651102 + 0.52385486448788 + 0.52385530983715 + 0.52385589697946 + 0.52385667302496 + 0.52385769780273 + 0.52385904959579 + 0.52386082983042 + 0.52386315900796 + 0.52386611106379 + 0.52386966192157 + 0.52387383458743 + 0.52387863011944 + 0.52388386432359 + 0.52388939244667 + 0.52389519152874 + 0.52390126672424 + 0.52390762762155 + 0.52391428579811 + 0.52392127641181 + 0.52392862853466 + 0.52393635166453 + 0.52394445791404 + 0.52395296390816 + 0.52396190094222 + 0.52397137520592 + 0.52398171440513 + 0.52399336227727 + 0.52400664915850 + 0.52402186623715 + 0.52403938369258 + 0.52405960906058 + 0.52408302706680 + 0.52411022861587 + 0.52414193939681 + 0.52417905983029 + 0.52422273988270 + 0.52427461368853 + 0.52433734775956 + 0.52441466310525 + 0.52451090803605 + 0.52463143466558 + 0.52470297240252 + 0.52478335193169 + 0.52487378998967 + 0.52497568771532 + 0.52509066147616 + 0.52522057940430 + 0.52536760494620 + 0.52553424922283 + 0.52572344159125 + 0.52593882604943 + 0.52618864550953 + 0.52649529292934 + 0.52688186911416 + 0.52737070050301 + 0.52799244105190 + 0.52878413890704 + 0.52979384119817 + 0.53108438535173 + 0.53273888107654 + 0.53486891317803 + 0.53762823959605 + 0.54125449272376 + 0.54608712247833 + 0.55265628043266 + 0.56185152159346 + 0.57533361498658 + 0.59679710324506 + 0.63800933702787 + 1.00000000000000 + 0.62492238358818 + 0.56968581891499 + 0.53441785366050 + 0.51058705096975 + 0.51058705149573 + 0.51058705158270 + 0.51058705168445 + 0.51058705180282 + 0.51058705194085 + 0.51058705210172 + 0.51058705228918 + 0.51058705250819 + 0.51058705276548 + 0.51058705307467 + 0.51058705345977 + 0.51058705395194 + 0.51058705458500 + 0.51058705539963 + 0.51058705644632 + 0.51058705779069 + 0.51058705951354 + 0.51058706172643 + 0.51058706458410 + 0.51058706827196 + 0.51058707302825 + 0.51058707916005 + 0.51058708706184 + 0.51058709724575 + 0.51058711042865 + 0.51058712771104 + 0.51058715062299 + 0.51058718105600 + 0.51058722139482 + 0.51058727513161 + 0.51058734676217 + 0.51058744212259 + 0.51058756888445 + 0.51058773710766 + 0.51058795992871 + 0.51058825444909 + 0.51058864283532 + 0.51058915525316 + 0.51058983299047 + 0.51059072849759 + 0.51059191039670 + 0.51059346758323 + 0.51059550559092 + 0.51059808871991 + 0.51060119470852 + 0.51060484248823 + 0.51060903141540 + 0.51061359797264 + 0.51061841362218 + 0.51062345687958 + 0.51062873081631 + 0.51063424222761 + 0.51063999943982 + 0.51064603107982 + 0.51065236011072 + 0.51065899214079 + 0.51066593470713 + 0.51067319883392 + 0.51068080766950 + 0.51068884806746 + 0.51069759563804 + 0.51070742247126 + 0.51071859986787 + 0.51073136203193 + 0.51074600625052 + 0.51076285622565 + 0.51078229450994 + 0.51080478511793 + 0.51083089511070 + 0.51086132492443 + 0.51089696679038 + 0.51093909460723 + 0.51098980967355 + 0.51105204128695 + 0.51112917442941 + 0.51122534140285 + 0.51128223408173 + 0.51134601282366 + 0.51141760746034 + 0.51149808629737 + 0.51158867883641 + 0.51169080258665 + 0.51180609488846 + 0.51193645100791 + 0.51208407582767 + 0.51225171543396 + 0.51244575968602 + 0.51268385420993 + 0.51298409089359 + 0.51336377275724 + 0.51384661251706 + 0.51446105344328 + 0.51524371310585 + 0.51624201582785 + 0.51751788568212 + 0.51915307966497 + 0.52125787432820 + 0.52399953616461 + 0.52760734965025 + 0.53242209159111 + 0.53897682478279 + 0.54816733318941 + 0.56166750715939 + 0.58325139681518 + 0.62492238358818 + 1.00000000000000 + 0.61174790502206 + 0.55614220359995 + 0.49748211696548 + 0.49748211740314 + 0.49748211747583 + 0.49748211756037 + 0.49748211765886 + 0.49748211777378 + 0.49748211790781 + 0.49748211806395 + 0.49748211824630 + 0.49748211846028 + 0.49748211871795 + 0.49748211903933 + 0.49748211945061 + 0.49748211998069 + 0.49748212066440 + 0.49748212154463 + 0.49748212267725 + 0.49748212413099 + 0.49748212600241 + 0.49748212842209 + 0.49748213154979 + 0.49748213559111 + 0.49748214080918 + 0.49748214754323 + 0.49748215623422 + 0.49748216750096 + 0.49748218229449 + 0.49748220193801 + 0.49748222807106 + 0.49748226276129 + 0.49748230903955 + 0.49748237081269 + 0.49748245315268 + 0.49748256273936 + 0.49748270833149 + 0.49748290137705 + 0.49748315678588 + 0.49748349389252 + 0.49748393901996 + 0.49748452822032 + 0.49748530728976 + 0.49748633616643 + 0.49748769247985 + 0.49748946832855 + 0.49749171943579 + 0.49749442532868 + 0.49749760144273 + 0.49750124582394 + 0.49750521378463 + 0.49750939157582 + 0.49751375924659 + 0.49751831822675 + 0.49752307306285 + 0.49752802947454 + 0.49753321057983 + 0.49753863428572 + 0.49754430319652 + 0.49755022130498 + 0.49755639526508 + 0.49756284172192 + 0.49756963130487 + 0.49757699486877 + 0.49758524311667 + 0.49759459770770 + 0.49760524569343 + 0.49761742417698 + 0.49763138820811 + 0.49764743710822 + 0.49766593193527 + 0.49768731155647 + 0.49771211537416 + 0.49774102859700 + 0.49777503522627 + 0.49781577901549 + 0.49786554938887 + 0.49792695917535 + 0.49800316895597 + 0.49804810010335 + 0.49809834862054 + 0.49815461789910 + 0.49821771416007 + 0.49828856300957 + 0.49836822890051 + 0.49845793814026 + 0.49855910633113 + 0.49867337593350 + 0.49880279675694 + 0.49895229593432 + 0.49913572748427 + 0.49936722041017 + 0.49966016021718 + 0.50003287742515 + 0.50050722711386 + 0.50111118739589 + 0.50188071809318 + 0.50286229958655 + 0.50411648661863 + 0.50572359310421 + 0.50780385322712 + 0.51051684520247 + 0.51409117766380 + 0.51886704502507 + 0.52537740917298 + 0.53451933801019 + 0.54800403213354 + 0.56968581891499 + 0.61174790502206 + 1.00000000000000 + 0.59852207002450 + 0.48455446499095 + 0.48455446535271 + 0.48455446541275 + 0.48455446548238 + 0.48455446556395 + 0.48455446565885 + 0.48455446576945 + 0.48455446589826 + 0.48455446604887 + 0.48455446622569 + 0.48455446643894 + 0.48455446670488 + 0.48455446704680 + 0.48455446748793 + 0.48455446805772 + 0.48455446879329 + 0.48455446974140 + 0.48455447096127 + 0.48455447253387 + 0.48455447457157 + 0.48455447720993 + 0.48455448062469 + 0.48455448504179 + 0.48455449075058 + 0.48455449813070 + 0.48455450771148 + 0.48455452031294 + 0.48455453707385 + 0.48455455940993 + 0.48455458910510 + 0.48455462878172 + 0.48455468181794 + 0.48455475261238 + 0.48455484695285 + 0.48455497244065 + 0.48455513901515 + 0.48455535962882 + 0.48455565109122 + 0.48455603629682 + 0.48455654661741 + 0.48455722192300 + 0.48455811439771 + 0.48455929163364 + 0.48456083377734 + 0.48456278898348 + 0.48456513851637 + 0.48456789485613 + 0.48457105507732 + 0.48457449152248 + 0.48457810382996 + 0.48458187360742 + 0.48458580103418 + 0.48458988889826 + 0.48459414087270 + 0.48459857550414 + 0.48460320658904 + 0.48460803448870 + 0.48461306054068 + 0.48461828809615 + 0.48462372871937 + 0.48462943959825 + 0.48463561351316 + 0.48464250910048 + 0.48465030673376 + 0.48465915494061 + 0.48466924174297 + 0.48468076670672 + 0.48469396224129 + 0.48470910700387 + 0.48472653767867 + 0.48474666579418 + 0.48477001257583 + 0.48479733182452 + 0.48482990134744 + 0.48486949950599 + 0.48491812785081 + 0.48497818268660 + 0.48501346103590 + 0.48505281406530 + 0.48509676867646 + 0.48514592726372 + 0.48520097960812 + 0.48526271685406 + 0.48533204793787 + 0.48541001911840 + 0.48549784103972 + 0.48559702911369 + 0.48571136495972 + 0.48585169424059 + 0.48602902652626 + 0.48625370175988 + 0.48653988298055 + 0.48690437567988 + 0.48736860260711 + 0.48795993505223 + 0.48871346818886 + 0.48967443722108 + 0.49090203201281 + 0.49248405978324 + 0.49453405939293 + 0.49721011909342 + 0.50073880874049 + 0.50545755600773 + 0.51189563464671 + 0.52096789822536 + 0.53441785366050 + 0.55614220359995 + 0.59852207002450 + 1.00000000000000 diff --git a/wrfv2_fire/run/urban_param.tbl b/wrfv2_fire/run/urban_param.tbl new file mode 100644 index 00000000..46defce7 --- /dev/null +++ b/wrfv2_fire/run/urban_param.tbl @@ -0,0 +1,89 @@ +Urban Parameters depending on Urban type +USGS +3, 'ZR[m] Z0C[m] Z0HC[m] ZDC[m] SVF R RW HGT CDS AS AH BETR BETB BETG FRC_URB UrbanType' +1, 10., 1.0, 1.0, 2.0, 0.48, 0.50, 0.50, 0.50, 0.1, 0.4, 0.0, 0.0, 0.0, 0.0 0.95 'Commercial' +2, 7.5, 0.75, 0.75, 1.5, 0.56, 0.50, 0.50, 0.40, 0.1, 0.3, 0.0, 0.0, 0.0, 0.0 0.9 'High Intensity Res' +3, 5., 0.5, 0.5, 1.0, 0.62, 0.50, 0.50, 0.30, 0.1, 0.2, 0.0, 0.0, 0.0, 0.0 0.5 'Low Intensity Res' +CAPR [cal/cm/cm/cm/degC] +0.50 +CAPB [cal/cm/cm/cm/degC] +0.50 +CAPG [cal/cm/cm/cm/degC] +0.50 +AKSR [cal/cm/sec/degC] +0.004 +AKSB [cal/cm/sec/degC] +0.004 +AKSG [cal/cm/sec/degC] +0.004 +ALBR [-] +0.10 +ALBB [-] +0.10 +ALBG [-] +0.10 +EPSR [-] +0.97 +EPSB [-] +0.97 +EPSG [-] +0.97 +Z0R [m] +0.1 +Z0B [m] +0.1 +Z0G [m] +0.1 +Z0HR [m] +0.1 +Z0HB [m] +0.1 +Z0HG [m] +0.1 +Num_Roof_Layers [-] +4 +Num_Wall_Layers [-] +4 +Num_Road_Layers [-] +4 +DDZR(1) [cm] +5. +DDZR(2) [cm] +5. +DDZR(3) [cm] +5. +DDZR(4) [cm] +5. +DDZB(1) [cm] +5. +DDZB(2) [cm] +5. +DDZB(3) [cm] +5. +DDZB(4) [cm] +5. +DDZG(1) [cm] +5. +DDZG(2) [cm] +25. +DDZG(3) [cm] +50. +DDZG(4) [cm] +75. +Lower Boundary Condition for Roof Layer Temp [1: Zero-Flux, 2: T = Constant] +1 +Lower Boundary Condition for Wall Layer Temp [1: Zero-Flux, 2: T = Constant] +1 +Lower Boundary Condition for Road Layer Temp [1: Zero-Flux, 2: T = Constant] +1 +TRLEND [K] +300.15 +TBLEND [K] +300.15 +TGLEND [K] +300.15 +Ch of Wall and Road [1: M-O Similarity Theory, 2: Empirical Form (recommend)] +2 +Surface and Layer Temperatures [1: 4-layer model, 2: Force-Restore method] +1 + diff --git a/wrfv2_fire/run/wrfinput_d01 b/wrfv2_fire/run/wrfinput_d01 new file mode 100644 index 00000000..6861471f Binary files /dev/null and b/wrfv2_fire/run/wrfinput_d01 differ diff --git a/wrfv2_fire/run/wrfout_d01_0001-01-01_00:00:00 b/wrfv2_fire/run/wrfout_d01_0001-01-01_00:00:00 new file mode 100644 index 00000000..bf4b871e Binary files /dev/null and b/wrfv2_fire/run/wrfout_d01_0001-01-01_00:00:00 differ diff --git a/wrfv2_fire/share/Makefile b/wrfv2_fire/share/Makefile new file mode 100644 index 00000000..713b4bd3 --- /dev/null +++ b/wrfv2_fire/share/Makefile @@ -0,0 +1,317 @@ +# + +LN = ln -sf +MAKE = make -i -r +RM = rm -f + +MODULES = \ + module_bc.o \ + module_bc_time_utilities.o \ + module_io_wrf.o \ + module_date_time.o \ + module_get_file_names.o \ + module_io_domain.o \ + module_model_constants.o \ + module_MPP.o \ + module_wrf_top.o \ + module_optional_si_input.o \ + module_compute_geop.o \ + module_soil_pre.o + +OBJS = \ + mediation_integrate.o \ + mediation_interp_domain.o \ + mediation_force_domain.o \ + mediation_feedback_domain.o \ + mediation_nest_move.o \ + mediation_wrfmain.o \ + solve_interface.o \ + start_domain.o \ + init_modules.o \ + set_timekeeping.o \ + interp_fcn.o sint.o \ + input_wrf.o \ + output_wrf.o \ + wrf_ext_write_field.o \ + wrf_ext_read_field.o \ + wrf_inputout.o \ + wrf_auxinput1out.o \ + wrf_auxinput2out.o \ + wrf_auxinput3out.o \ + wrf_auxinput4out.o \ + wrf_auxinput5out.o \ + wrf_auxinput6out.o \ + wrf_auxinput7out.o \ + wrf_auxinput8out.o \ + wrf_auxinput9out.o \ + wrf_auxinput10out.o \ + wrf_auxinput11out.o \ + wrf_histout.o \ + wrf_auxhist1out.o \ + wrf_auxhist2out.o \ + wrf_auxhist3out.o \ + wrf_auxhist4out.o \ + wrf_auxhist5out.o \ + wrf_auxhist6out.o \ + wrf_auxhist7out.o \ + wrf_auxhist8out.o \ + wrf_auxhist9out.o \ + wrf_auxhist10out.o \ + wrf_auxhist11out.o \ + wrf_restartout.o \ + wrf_bdyout.o \ + wrf_inputin.o \ + wrf_auxhist1in.o \ + wrf_auxhist2in.o \ + wrf_auxhist3in.o \ + wrf_auxhist4in.o \ + wrf_auxhist5in.o \ + wrf_auxhist6in.o \ + wrf_auxhist7in.o \ + wrf_auxhist8in.o \ + wrf_auxhist9in.o \ + wrf_auxhist10in.o \ + wrf_auxhist11in.o \ + wrf_auxinput1in.o \ + wrf_auxinput2in.o \ + wrf_auxinput3in.o \ + wrf_auxinput4in.o \ + wrf_auxinput5in.o \ + wrf_auxinput6in.o \ + wrf_auxinput7in.o \ + wrf_auxinput8in.o \ + wrf_auxinput9in.o \ + wrf_auxinput10in.o \ + wrf_auxinput11in.o \ + wrf_fddaobs_in.o \ + wrf_bdyin.o \ + wrf_histin.o \ + wrf_restartin.o \ + landread.o + + +NMM_MODULES = + + +LIBTARGET = shared +TARGETDIR = ./ +$(LIBTARGET) : $(MODULES) $(OBJS) + if [ $(WRF_NMM_CORE) -eq 1 ] ; then \ + $(MAKE) nmm_contrib ; \ + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) $(NMM_OBJS) $(NMM_MODULES) ; \ + else \ + $(AR) ../main/libwrflib.a $(MODULES) $(OBJS) ; \ + fi + +include ../configure.wrf + +nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) + +clean: + @ echo 'use the clean script' + + +# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) + +solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configure.o \ + ../frame/module_timing.o ../frame/module_driver_constants.o \ + ../frame/module_wrf_error.o + +start_domain.o: start_domain_em.int ../frame/module_domain.o ../frame/module_configure.o + +module_bc.o: ../frame/module_configure.o ../frame/module_state_description.o \ + ../frame/module_wrf_error.o + +module_bc_time_utilities.o: $(ESMF_MOD_DEPENDENCE) + +module_get_file_names.o: + +module_io_domain.o: module_io_wrf.o module_date_time.o ../frame/module_io.o \ + ../frame/module_domain.o ../frame/module_configure.o \ + ../frame/module_state_description.o + +module_io_wrf.o: module_date_time.o module_bc_time_utilities.o \ + ../frame/module_wrf_error.o ../frame/module_domain.o \ + ../frame/module_state_description.o ../frame/module_configure.o \ + ../frame/module_io.o ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) + +output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ + ../frame/module_domain.o ../frame/module_state_description.o \ + ../frame/module_configure.o module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + +input_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ + ../frame/module_domain.o ../frame/module_state_description.o \ + ../frame/module_configure.o module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + +wrf_ext_write_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ + ../frame/module_domain.o ../frame/module_timing.o + +wrf_ext_read_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ + ../frame/module_domain.o ../frame/module_timing.o + +module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o + +module_soil_pre.o: module_date_time.o ../frame/module_state_description.o + +module_optional_si_input.o: module_io_wrf.o module_io_domain.o \ + ../frame/module_domain.o ../frame/module_configure.o + +mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o \ + ../frame/module_timing.o $(ESMF_MOD_DEPENDENCE) \ + module_bc_time_utilities.o module_io_domain.o + +init_modules.o: ../frame/module_configure.o ../frame/module_driver_constants.o \ + ../frame/module_domain.o ../frame/module_machine.o \ + ../frame/module_nesting.o ../frame/module_timing.o \ + ../frame/module_tiles.o ../frame/module_io.o \ + ../frame/module_io_quilt.o ../frame/module_dm.o \ + ../external/io_int/io_int.o \ + module_io_wrf.o module_bc.o module_model_constants.o + +interp_fcn.o: ../frame/module_timing.o ../frame/module_state_description.o ../frame/module_configure.o \ + ../frame/module_wrf_error.o + +mediation_feedback_domain.o: ../frame/module_domain.o ../frame/module_configure.o + +mediation_force_domain.o: ../frame/module_domain.o ../frame/module_configure.o + +mediation_integrate.o: ../frame/module_domain.o ../frame/module_configure.o \ + ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_date_time.o module_bc_time_utilities.o \ + module_compute_geop.o \ + module_io_domain.o + + +mediation_interp_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ + ../frame/module_timing.o + +mediation_nest_move.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_state_description.o + +#mediation_conv_emissions.o: ../frame/module_domain.o ../frame/module_configure.o \ +# ../external/esmf_time_f90/ESMF_Mod.o \ +# module_date_time.o module_bc_time_utilities.o \ +# module_io_domain.o + +set_timekeeping.o: ../frame/module_domain.o ../frame/module_configure.o \ + $(ESMF_MOD_DEPENDENCE) + +module_wrf_top.o: ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_integrate.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + $(ESMF_MOD_DEPENDENCE) + +wrf_inputout.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput1out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput2out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput3out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput4out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput5out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput6out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput7out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput8out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput9out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput10out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput11out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_histout.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist1out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist2out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist3out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist4out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist5out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist6out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist7out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist8out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist9out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist10out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist11out.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_restartout.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_bdyout.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_inputin.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist1in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist2in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist3in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist4in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist5in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist6in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist7in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist8in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist9in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist10in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxhist11in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput1in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput2in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput3in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput4in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput5in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput6in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput7in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput8in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput9in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput10in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_auxinput11in.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_bdyin.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_histin.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o +wrf_restartin.o : ../frame/module_domain.o \ + ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o + + +# DO NOT DELETE diff --git a/wrfv2_fire/share/init_modules.F b/wrfv2_fire/share/init_modules.F new file mode 100644 index 00000000..8ceef23a --- /dev/null +++ b/wrfv2_fire/share/init_modules.F @@ -0,0 +1,90 @@ +!WRF:MEDIATION_LAYER +! +SUBROUTINE init_modules( phase ) + USE module_bc + USE module_configure + USE module_driver_constants + USE module_model_constants + USE module_domain + USE module_machine + USE module_nesting + USE module_timing + USE module_tiles + USE module_io_wrf + USE module_io +#ifdef DM_PARALLEL + USE module_wrf_quilt + USE module_dm +#endif +#ifdef INTIO + USE module_ext_internal +#endif + +! +! This routine USES the modules in WRF and then calls the init routines +! they provide to perform module specific initializations at the +! beginning of a run. Note, this is only once per run, not once per +! domain; domain specific initializations should be handled elsewhere, +! such as in start_domain. +! +! Certain framework specific module initializations in this file are +! dependent on order they are called. For example, since the quilt module +! relies on internal I/O, the init routine for internal I/O must be +! called first. In the case of DM_PARALLEL compiles, the quilt module +! calls MPI_INIT as part of setting up and dividing communicators between +! compute and I/O server tasks. Therefore, it must be called prior to +! module_dm, which will also try to call MPI_INIT if it sees +! that MPI has not be initialized yet (implementations of module_dm +! should in fact behave this way by first calling MPI_INITIALIZED before +! they try to call MPI_INIT). If MPI is already initialized before the +! the quilting module is called, quilting will not work. +! +! The phase argument is used to allow other superstructures like ESMF to +! place their initialization calls following the WRF initialization call +! that calls MPI_INIT(). When used with ESMF, ESMF will call wrf_init() +! which in turn will call phase 2 of this routine. Phase 1 will be called +! earlier. +! +! + + INTEGER, INTENT(IN) :: phase ! phase==1 means return after MPI_INIT() + ! phase==2 means resume after MPI_INIT() + +IF ( phase == 1 ) THEN + CALL init_module_bc + CALL init_module_configure + CALL init_module_driver_constants + CALL init_module_model_constants + CALL init_module_domain + CALL init_module_machine + +#ifdef INTIO + CALL init_module_ext_internal !! must be called before quilt +#endif +#ifdef DM_PARALLEL + CALL init_module_wrf_quilt !! this *must* be called before init_module_dm + CALL init_module_dm +#endif +ELSE + CALL init_module_nesting + CALL init_module_timing + CALL init_module_tiles + CALL init_module_io_wrf + CALL init_module_io + +! core specific initializations -- add new cores here +#if (EM_CORE == 1) +# if ( DA_CORE != 1) + CALL init_modules_em +# endif +#endif +#if (NMM_CORE == 1) + CALL init_modules_nmm +#endif +#if (COAMPS_CORE == 1) + CALL init_modules_coamps +#endif +ENDIF + +END SUBROUTINE init_modules + diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F new file mode 100644 index 00000000..49a6758c --- /dev/null +++ b/wrfv2_fire/share/input_wrf.F @@ -0,0 +1,598 @@ +!WRF:MEDIATION:IO +! ---principal wrf input routine (called from routines in module_io_domain ) + + SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess, currtimestr + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + Type(WRFU_Time) time, currtime + CHARACTER*19 new_date + CHARACTER*24 base_date + CHARACTER*80 fname + LOGICAL dryrun + INTEGER idt + INTEGER itmp + INTEGER dyn_opt_tmp, dyn_opt, filestate, ierr3 + INTEGER :: ide_compare , jde_compare , kde_compare + REAL , DIMENSION(16) :: lats16 , lons16 + CHARACTER (len=19) simulation_start_date + INTEGER simulation_start_year , & + simulation_start_month , & + simulation_start_day , & + simulation_start_hour , & + simulation_start_minute , & + simulation_start_second + REAL dx_compare , dy_compare , dum + +! +! +! Core wrf input routine for all input data streams. Part of mediation layer. +! +! Note that WRF IOAPI routines wrf_get_dom_ti_*() do not return values during +! training reads (dryrun). +! +! + + WRITE(wrf_err_message,*)'input_wrf: begin, fid = ',fid + CALL wrf_debug( 300 , wrf_err_message ) + + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + +! simulation start time is a Singleton maintained by head_grid + IF ( ( switch .EQ. model_input_only ) .OR. & + ( switch .EQ. restart_only ) ) THEN + CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr ) + IF ( ierr .EQ. 0 ) THEN + ! Overwrite simulation start date with metadata. + READ ( simulation_start_date , fmt = '(I4,1x,I2,1x,I2,1x,I2,1x,I2,1x,I2)' ) & + simulation_start_year, simulation_start_month, & + simulation_start_day, simulation_start_hour, & + simulation_start_minute, simulation_start_second + CALL nl_set_simulation_start_year ( 1 , simulation_start_year ) + CALL nl_set_simulation_start_month ( 1 , simulation_start_month ) + CALL nl_set_simulation_start_day ( 1 , simulation_start_day ) + CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour ) + CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute ) + CALL nl_set_simulation_start_second ( 1 , simulation_start_second ) + IF ( switch .EQ. model_input_only ) THEN + WRITE(wrf_err_message,*)fid,' input_wrf, model_input_only: SIMULATION_START_DATE = ', & + simulation_start_date(1:19) + CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) + ELSE IF ( switch .EQ. restart_only ) THEN + WRITE(wrf_err_message,*)fid,' input_wrf, restart_only: SIMULATION_START_DATE = ', & + simulation_start_date(1:19) + CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) + ENDIF + ELSE + CALL nl_get_start_year ( 1 , simulation_start_year ) + CALL nl_get_start_month ( 1 , simulation_start_month ) + CALL nl_get_start_day ( 1 , simulation_start_day ) + CALL nl_get_start_hour ( 1 , simulation_start_hour ) + CALL nl_get_start_minute ( 1 , simulation_start_minute ) + CALL nl_get_start_second ( 1 , simulation_start_second ) + CALL nl_set_simulation_start_year ( 1 , simulation_start_year ) + CALL nl_set_simulation_start_month ( 1 , simulation_start_month ) + CALL nl_set_simulation_start_day ( 1 , simulation_start_day ) + CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour ) + CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute ) + CALL nl_set_simulation_start_second ( 1 , simulation_start_second ) + CALL wrf_message('input_wrf: SIMULATION_START_DATE not available in input') + CALL wrf_message('will use head_grid start time from namelist') + ENDIF + ! Initialize derived time quantity in grid%xtime. + ! Note that this call is also made in setup_timekeeping(). + ! Ugh, what a hack. Simplify all this later... + CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime ) + ! Note that it is NOT necessary to reset grid%julian here. + WRITE(wrf_err_message,*) 'input_wrf: set xtime to ',grid%xtime + CALL wrf_debug ( 100, TRIM(wrf_err_message) ) + ENDIF + + + ! Test to make sure that the input data is the right size. Do this for input from real/ideal into + ! WRF, and from the standard initialization into real. + + IF ( ( switch .EQ. model_input_only ) .OR. & + ( switch .EQ. aux_model_input1_only ) ) THEN + ierr = 0 + CALL wrf_get_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ide_compare , 1 , icnt , ierr3 ) + ierr = max( ierr, ierr3 ) + CALL wrf_get_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , jde_compare , 1 , icnt , ierr3 ) + ierr = max( ierr, ierr3 ) + CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , kde_compare , 1 , icnt , ierr3 ) + ierr = max( ierr, ierr3 ) +! IF ( ierr3 .NE. 0 ) CALL wrf_error_fatal( 'wrf_get_dom_ti_integer getting dimension information from dataset' ) + IF ( ierr3 .NE. 0 ) CALL wrf_debug( 'wrf_get_dom_ti_integer getting dimension information from dataset' ) + +#if (EM_CORE == 1) + ! Test to make sure that the grid distances are the right size. + + CALL wrf_get_dom_ti_real ( fid , 'DX' , dx_compare , 1 , icnt , ierr ) + CALL wrf_get_dom_ti_real ( fid , 'DY' , dy_compare , 1 , icnt , ierr ) + IF ( ( ABS ( dx_compare - config_flags%dx ) .GT. 1.E-5 * dx_compare ) .OR. & + ( ABS ( dy_compare - config_flags%dy ) .GT. 1.E-5 * dy_compare ) ) THEN +print *,'dx_compare,dy_compare = ',dx_compare,dy_compare + CALL wrf_error_fatal( 'DX and DY do not match from the namelist and the input file' ) + END IF +#endif + END IF + + ! do the check later (see check_if_dryrun below) + + CALL nl_get_dyn_opt( 1, dyn_opt ) + CALL wrf_get_dom_ti_integer ( fid, 'DYN_OPT', dyn_opt_tmp, 1, icnt, ierr ) + + ! We do not want the CEN_LAT LON values from the boundary file. For 1-way nests + ! with ndown, this ends up being the data from the previous coarse domain. + + IF ( switch .NE. boundary_only ) THEN + CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',config_flags%cen_lat + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_cen_lat ( grid%id , config_flags%cen_lat ) + + CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',config_flags%cen_lon + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_cen_lon ( grid%id , config_flags%cen_lon ) + ELSE + CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , dum , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',dum + CALL wrf_debug ( 300 , wrf_err_message ) + + CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , dum , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',dum + CALL wrf_debug ( 300 , wrf_err_message ) + END IF + + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , config_flags%truelat1 , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT1 returns ',config_flags%truelat1 + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_truelat1 ( grid%id , config_flags%truelat1 ) + + CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , config_flags%truelat2 , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT2 returns ',config_flags%truelat2 + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_truelat2 ( grid%id , config_flags%truelat2 ) + + CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , config_flags%moad_cen_lat , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for MOAD_CEN_LAT returns ',config_flags%moad_cen_lat + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_moad_cen_lat ( grid%id , config_flags%moad_cen_lat ) + + CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , config_flags%stand_lon , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for STAND_LON returns ',config_flags%stand_lon + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_stand_lon ( grid%id , config_flags%stand_lon ) + +#if ( NMM_CORE != 1 ) + IF ( program_name(1:7) .EQ. "REAL_EM" ) THEN + CALL wrf_get_dom_ti_real ( fid , 'corner_lats' , lats16 , 16 , icnt , ierr ) + WRITE(wrf_err_message,FMT='(A,16f6.1)')'input_wrf: wrf_get_dom_ti_real for CORNER_LATS returns ',lats16 + CALL wrf_debug ( 300 , wrf_err_message ) + grid%em_lat_ll_t = lats16( 1) + grid%em_lat_ul_t = lats16( 2) + grid%em_lat_ur_t = lats16( 3) + grid%em_lat_lr_t = lats16( 4) + grid%em_lat_ll_u = lats16( 5) + grid%em_lat_ul_u = lats16( 6) + grid%em_lat_ur_u = lats16( 7) + grid%em_lat_lr_u = lats16( 8) + grid%em_lat_ll_v = lats16( 9) + grid%em_lat_ul_v = lats16(10) + grid%em_lat_ur_v = lats16(11) + grid%em_lat_lr_v = lats16(12) + grid%em_lat_ll_d = lats16(13) + grid%em_lat_ul_d = lats16(14) + grid%em_lat_ur_d = lats16(15) + grid%em_lat_lr_d = lats16(16) + + CALL wrf_get_dom_ti_real ( fid , 'corner_lons' , lons16 , 16 , icnt , ierr ) + WRITE(wrf_err_message,FMT='(A,16f6.1)')'input_wrf: wrf_get_dom_ti_real for CORNER_LONS returns ',lons16 + CALL wrf_debug ( 300 , wrf_err_message ) + grid%em_lon_ll_t = lons16( 1) + grid%em_lon_ul_t = lons16( 2) + grid%em_lon_ur_t = lons16( 3) + grid%em_lon_lr_t = lons16( 4) + grid%em_lon_ll_u = lons16( 5) + grid%em_lon_ul_u = lons16( 6) + grid%em_lon_ur_u = lons16( 7) + grid%em_lon_lr_u = lons16( 8) + grid%em_lon_ll_v = lons16( 9) + grid%em_lon_ul_v = lons16(10) + grid%em_lon_ur_v = lons16(11) + grid%em_lon_lr_v = lons16(12) + grid%em_lon_ll_d = lons16(13) + grid%em_lon_ul_d = lons16(14) + grid%em_lon_ur_d = lons16(15) + grid%em_lon_lr_d = lons16(16) + ENDIF +#endif + +#if ( NMM_CORE != 1 ) +! program_name is defined in module_domain and set in the main program for whatever application +! is using subroutine input_wrf (that is, the subroutine you are looking at here). Data files +! written by SI have P_TOP as a metadata item; the real program and wrf model have it as a +! state variable. This test is to supress non-fatal but confusing messages from the model complaining +! that P_TOP cannot be read from the metadata for this dataset. JM 20040905 +! +! Note, P_TOP is not defined in the NMM core. + + IF ( program_name(1:7) .EQ. "REAL_EM" ) THEN + CALL wrf_get_dom_ti_real ( fid , 'P_TOP' , grid%p_top , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for P_TOP returns ',grid%p_top + CALL wrf_debug ( 300 , wrf_err_message ) + ENDIF +#endif + + IF ( switch .NE. boundary_only ) THEN + CALL wrf_get_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for GMT returns ',config_flags%gmt + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_gmt ( grid%id , config_flags%gmt ) + + CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULYR returns ',config_flags%julyr + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_julyr ( grid%id , config_flags%julyr ) + + CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULDAY returns ',config_flags%julday + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_julday ( grid%id , config_flags%julday ) + ENDIF + + CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for MAP_PROJ returns ',config_flags%map_proj + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_map_proj ( grid%id , config_flags%map_proj ) + + CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_char for MMINLU returns ',mminlu(1:4) + CALL wrf_debug ( 300 , wrf_err_message ) + CALL nl_set_mminlu ( 1, mminlu(1:4) ) + + CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater + CALL wrf_debug ( 300 , wrf_err_message ) + IF ( ierr .NE. 0 ) THEN + IF (mminlu == 'UMD') THEN + config_flags%iswater = 14 + ELSE + config_flags%iswater = 16 + ENDIF + ENDIF + CALL nl_set_iswater ( grid%id , config_flags%iswater ) + + CALL wrf_get_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISICE returns ',config_flags%isice + CALL wrf_debug ( 300 , wrf_err_message ) + IF ( ierr .NE. 0 ) THEN + IF (mminlu == 'UMD') THEN + config_flags%isice = 14 + ELSE + config_flags%isice = 24 + ENDIF + ENDIF + CALL nl_set_isice ( grid%id , config_flags%isice ) + + CALL wrf_get_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISURBAN returns ',config_flags%isurban + CALL wrf_debug ( 300 , wrf_err_message ) + IF ( ierr .NE. 0 ) THEN + IF (mminlu == 'UMD') THEN + config_flags%isurban = 13 + ELSE + config_flags%isurban = 1 + ENDIF + ENDIF + CALL nl_set_isurban ( grid%id , config_flags%isurban ) + + CALL wrf_get_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , icnt , ierr ) + WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISOILWATER returns ',config_flags%isoilwater + CALL wrf_debug ( 300 , wrf_err_message ) + IF ( ierr .NE. 0 ) THEN + config_flags%isoilwater = 14 + ENDIF + CALL nl_set_isoilwater ( grid%id , config_flags%isoilwater ) + +#ifdef MOVE_NESTS +! Added these fields for restarting of moving nests, JM +! DANGER and TODO +! It is very important that these be set correctly if they are set at all in here. +! Garbage values will produce unpredictable results, possibly segfaults, in the nesting +! code. Need some integrity checking here or elsewhere in the code to at least check to +! make sure that the istart and jstart values make sense with respect to the nest dimensions +! and the position in the parent domain. + CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt, ierr ) + IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN + config_flags%i_parent_start = itmp + CALL nl_set_i_parent_start ( grid%id , config_flags%i_parent_start ) + ENDIF + CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt, ierr ) + IF ( ierr .EQ. 0 .AND. switch .EQ. restart_only ) THEN + config_flags%j_parent_start = itmp + CALL nl_set_j_parent_start ( grid%id , config_flags%j_parent_start ) + ENDIF +#endif + +! If this was not a training read (dry run) check for erroneous values. + CALL wrf_inquire_filename ( fid , fname , filestate , ierr ) + IF ( ierr /= 0 ) THEN + WRITE(wrf_err_message,*)'module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + + WRITE(wrf_err_message,*)'input_wrf: fid,filestate = ',fid,filestate + CALL wrf_debug( 300 , wrf_err_message ) + + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + + WRITE(wrf_err_message,*)'input_wrf: dryrun = ',dryrun + CALL wrf_debug( 300 , wrf_err_message ) + + check_if_dryrun : IF ( .NOT. dryrun ) THEN + +#if (EM_CORE == 1) + +!KLUDGE - is there a more elegant way to determine "old si" input + IF ( ( switch .EQ. model_input_only ) .OR. & + ( ( switch .EQ. aux_model_input1_only ) .AND. & + ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) ) THEN + + ! Test to make sure that the input data is the right size. + + IF ( ( ide .NE. ide_compare ) .OR. & + ( kde .NE. kde_compare ) .OR. & + ( jde .NE. jde_compare ) ) THEN +! a hack for sure +#ifndef ESMFIO + WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide,jde,kde=',ide,jde,kde,& + '; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare + CALL wrf_error_fatal( wrf_err_message ) +#else + WRITE(wrf_err_message,*)'DEBUG input_wrf.F switch = ',switch, & + ': namelist ide,jde,kde=',ide,jde,kde,& + '; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare + CALL wrf_debug( 100, wrf_err_message ) +#endif + ENDIF + + ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + + ! Test to make sure that the input data is the right size. + + IF ( ( ide .NE. ide_compare ) .OR. & + ( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. & + ( jde .NE. jde_compare ) ) THEN + WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',& + 'namelist ide,jde,num_metgrid_levels=',ide,jde,config_flags%num_metgrid_levels,& + '; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + ENDIF + +#endif + +#if (NMM_CORE == 1) + + IF ( ( switch .EQ. aux_model_input1_only ) .AND. & + ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) THEN + + CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMSNSION' , kde_compare , 1 , icnt , ierr3 ) + + ! Test to make sure that the input data is the right size. + + IF ( ( ide-1 .NE. ide_compare ) .OR. & + ( kde .NE. kde_compare ) .OR. & + ( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN +! a hack for sure +#ifndef ESMFIO + WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: namelist ide-1,jde-1,kde=',ide-1,jde-1,kde,& + '; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare + CALL wrf_debug( 100, wrf_err_message ) +#else + WRITE(wrf_err_message,*)'DEBUG input_wrf.F switch = ',switch, & + ': namelist ide,jde,kde=',ide,jde,kde,& + '; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare + CALL wrf_debug( 100, wrf_err_message ) +#endif + ENDIF + + ELSEIF ( switch .EQ. aux_model_input1_only ) THEN ! assume just WPS in this branch + IF ( ( ide-1 .NE. ide_compare ) .OR. & + ( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. & + ( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN + WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH: ',& + 'namelist ide-1,jde-1,num_metgrid_levels=',ide-1,jde-1,config_flags%num_metgrid_levels,& + '; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare + IF (ide-1 .eq. ide_compare .AND. jde-1 .EQ. jde_compare) THEN + CALL wrf_message(wrf_err_message) + CALL wrf_error_fatal( "appears that the vertical dimension is wrong - quitting" ) + ELSE + CALL wrf_message(wrf_err_message) + CALL wrf_error_fatal( "appears that I or J dimensions are wrong - quitting" ) + ENDIF + ENDIF + ENDIF + +#endif + + + IF ( dyn_opt_tmp .NE. dyn_opt .AND. switch .EQ. model_input_only ) THEN + WRITE(wrf_err_message,*)'input_wrf: dyn_opt in file ',dyn_opt_tmp,' NE namelist ',dyn_opt + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + + ENDIF check_if_dryrun + +! +! This call to wrf_get_next_time will position the dataset over the next time-frame +! in the file and return the current_date, which is used as an argument to the +! read_field routines in the blocks of code included below. Note that we read the +! next time *after* all the meta data has been read. This is only important for the +! WRF internal I/O format because it is order-dependent. Other formats shouldn't care +! about this. +! + + 3003 continue + + CALL wrf_get_next_time(fid, current_date , ierr) + WRITE(wrf_err_message,*)fid,' input_wrf: wrf_get_next_time current_date: ',current_date(1:19),' Status = ',ierr + CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) + IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ ) THEN + CALL wrf_message ( TRIM(wrf_err_message ) ) + IF ( switch .EQ. boundary_only ) THEN + WRITE(wrf_err_message,*) ' ... May have run out of valid boundary conditions in file ',TRIM(fname) + CALL wrf_error_fatal( TRIM(wrf_err_message) ) + ELSE +#if ( NMM_CORE != 1 ) + WRITE(wrf_err_message,*) '... Could not find matching time in input file ',TRIM(fname) + CALL wrf_error_fatal( TRIM(wrf_err_message) ) +#endif + ENDIF + ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ) THEN +! +! check input time against domain time (which will be start time at beginning, see share/set_timekeeping.F) +! JM 20040511 +! + SELECT CASE ( switch ) + CASE ( model_input_only, aux_model_input1_only, aux_model_input2_only, & + aux_model_input3_only, aux_model_input4_only, aux_model_input5_only ) + CALL wrf_atotime( current_date(1:19), time ) + CALL domain_clock_get( grid, current_time=currtime, & + current_timestr=currtimestr ) + CALL domain_clockprint(150, grid, & + 'DEBUG input_wrf(): get CurrTime from clock,') + IF ( time .NE. currtime ) THEN + WRITE( wrf_err_message , * )'Time in file: ',trim( current_date(1:19) ) + CALL wrf_message ( trim(wrf_err_message) ) + WRITE( wrf_err_message , * )'Time on domain: ',trim( currtimestr ) + CALL wrf_message ( trim(wrf_err_message) ) + CALL wrf_message( "**WARNING** Time in input file not equal to time on domain **WARNING**" ) + WRITE(wrf_err_message,*) "**WARNING** Trying next time in file ",TRIM(fname)," ..." + CALL wrf_message( TRIM(wrf_err_message) ) + GOTO 3003 + ENDIF + CASE DEFAULT + END SELECT + ENDIF + +! set the lbc time interval fields in the domain data structure +! these time values are checked as stopping condition for the while loop in +! latbound_in() defined in share/medation_integrate.F, which is used to +! iterate forward to the correct interval in the input LBC file +! + IF ( switch .EQ. boundary_only ) THEN + CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) + CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time ) + CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) + CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + ENDIF + +#if 1 + IF ( switch .EQ. model_input_only ) THEN + CALL wrf_inputin( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. history_only ) THEN + CALL wrf_histin( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + CALL wrf_auxinput1in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input2_only ) THEN + CALL wrf_auxinput2in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input3_only ) THEN + CALL wrf_auxinput3in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input4_only ) THEN + CALL wrf_auxinput4in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input5_only ) THEN + CALL wrf_auxinput5in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input6_only ) THEN + CALL wrf_auxinput6in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input7_only ) THEN + CALL wrf_auxinput7in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input8_only ) THEN + CALL wrf_auxinput8in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input9_only ) THEN + CALL wrf_auxinput9in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input10_only ) THEN + CALL wrf_auxinput10in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_model_input11_only ) THEN + CALL wrf_auxinput11in( fid , grid , config_flags , switch , ierr ) + + + ELSE IF ( switch .EQ. aux_hist1_only ) THEN + CALL wrf_auxhist1in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist2_only ) THEN + CALL wrf_auxhist2in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist3_only ) THEN + CALL wrf_auxhist3in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist4_only ) THEN + CALL wrf_auxhist4in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist5_only ) THEN + CALL wrf_auxhist5in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist6_only ) THEN + CALL wrf_auxhist6in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist7_only ) THEN + CALL wrf_auxhist7in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist8_only ) THEN + CALL wrf_auxhist8in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist9_only ) THEN + CALL wrf_auxhist9in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist10_only ) THEN + CALL wrf_auxhist10in( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. aux_hist11_only ) THEN + CALL wrf_auxhist11in( fid , grid , config_flags , switch , ierr ) + + ELSE IF ( switch .EQ. restart_only ) THEN + CALL wrf_restartin( fid , grid , config_flags , switch , ierr ) + ELSE IF ( switch .EQ. boundary_only ) THEN + CALL wrf_bdyin( fid , grid , config_flags , switch , ierr ) + ENDIF +#else + CALL wrf_message ( "ALL I/O DISABLED IN share/module_io_wrf.F") +#endif + + WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid + CALL wrf_debug( 300 , wrf_err_message ) + + RETURN + END SUBROUTINE input_wrf diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F new file mode 100644 index 00000000..5ec98689 --- /dev/null +++ b/wrfv2_fire/share/interp_fcn.F @@ -0,0 +1,5194 @@ +!WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION +! + +#define MM5_SINT +!#define DUMBCOPY + +#if ( NMM_CORE == 1 ) +!======================================================================================= +! E grid interpolation for mass with addition of terrain adjustments. First routine +! pertains to initial conditions and the next one corresponds to boundary conditions +! This is gopal's doing +!======================================================================================= + + SUBROUTINE interp_mass_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys for weights + CZ3d, Z3d, & ! Z3d interpolated from CZ3d + CFIS,FIS, & ! CFIS dummy on fine domain + CSM,SM, & ! CSM is dummy + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CPSTD,PSTD, & + CKZMAX,KZMAX ) + + USE MODULE_MODEL_CONSTANTS + USE module_timing + IMPLICIT NONE + + LOGICAL,INTENT(IN) :: xstag, ystag + INTEGER,INTENT(IN) :: ckzmax,kzmax + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + +! parent domain + + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ),INTENT(IN) :: CZ3d + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD + REAL,INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD + REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608 + REAL, PARAMETER :: COEF3=R_D*GI*LAPSR + INTEGER :: I,J,K,IDUM + REAL :: dlnpdz,tvout,pmo + REAL,DIMENSION(nims:nime,njms:njme) :: ZS,DUM2d + REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2 +!----------------------------------------------------------------------------------------------------- +! +!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & + CALL wrf_error_fatal ('mass points:check domain bounds along x' ) + IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & + CALL wrf_error_fatal ('mass points:check domain bounds along y' ) + ENDDO + ENDDO + + IF(KZMAX .GT. (JTB-10)) & + CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + +! WRITE(21,*)'------------- MED NEST INITIAL 1 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(21,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(21,*) + +! +!*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ALSO CHECK IF SM IS LAND (SM=0) OVER TOPO +!*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES! +! + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + ZS(I,J)=FIS(I,J)/G + ENDDO + ENDDO + +! +!*** Interpolate GPMs DERIVED FROM STANDARD ATMOSPHERIC LAPSE RATE FROM THE PARENT TO +!*** THE NESTED DOMAIN +! +!*** INDEX CONVENTIONS +!*** HBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** HBWGT1 HBWGT2 +!*** +!*** +!*** 3 +!*** HBWGT3 + + Z3d=0.0 + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKTS,KZMAX ! Please note that we are still in isobaric surfaces + DO I=NITS,MIN(NITE,NIDE-1) +! + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF +! + ENDDO + ENDDO + ENDDO + +! RECONSTRUCT PDs ON THE BASIS OF TOPOGRAPHY AND THE INTERPOLATED HEIGHTS + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) +! + IF (ZS(I,J) .LT. Z3d(I,1,J)) THEN + dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j)) + dum2d(i,j) = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j))) + dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP + IF(J==10)WRITE(0,*)I,J,K,ZS(I,J),Z3d(I,K,J),Z3d(I,K+1,J),dum2d(i,j),PDTOP,PTOP + ELSE ! target level bounded by input levels + DO K =NKTS,KZMAX-1 ! still in the isobaric surfaces + IF(ZS(I,J) .GE. Z3d(I,K,J) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN + dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j)) + dum2d(i,j) = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j))) + dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP +! IF(I==1)WRITE(0,*)I,J,K,ZS(I,J),Z3d(I,K,J),Z3d(I,K+1,J),dum2d(i,j),PDTOP,PTOP + ENDIF + ENDDO + ENDIF + IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN + WRITE(0,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J) + CALL wrf_error_fatal3 ( "interp_fcn.b" , 176 , "MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") + ENDIF +! + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE ! NKTE is 1, nevertheless let us pretend religious + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + NFLD(I,K,J)= dum2d(i,j) ! PD defined in the nested domain + ENDIF + ENDDO + ENDDO + ENDDO + +! + END SUBROUTINE interp_mass_nmm +! +!-------------------------------------------------------------------------------------- + + SUBROUTINE nmm_bdymass_hinterp ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + cbdy, nbdy, & + cbdy_t, nbdy_t, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys + CZ3d, Z3d, & ! Z3d dummy on nested domain + CFIS,FIS, & ! CFIS dummy on fine domain + CSM,SM, & ! CSM is dummy + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CPSTD,PSTD, & + CKZMAX,KZMAX ) + + + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: ckzmax,kzmax + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + + + REAL, INTENT(INOUT) :: cdt, ndt + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt + LOGICAL, INTENT(IN) :: xstag, ystag + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t + +! parent domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ), INTENT(IN) :: CZ3d + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD + REAL,INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD + REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d + REAL,INTENT(IN) :: PDTOP,PTOP + +! Local + + INTEGER :: nijds, nijde, spec_bdy_width,i,j,k + REAL :: dlnpdz,dum2d + REAL,DIMENSION(nims:nime,njms:njme) :: zs + + nijds = min(nids, njds) + nijde = max(nide, njde) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + + + CALL nmm_bdymass_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys + CZ3d, Z3d, & ! Z3d dummy on nested domain + CFIS,FIS, & ! CFIS dummy on fine domain + CSM,SM, & ! CSM is dummy + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CPSTD,PSTD, & + CKZMAX,KZMAX ) + + RETURN + + END SUBROUTINE nmm_bdymass_hinterp +! +!--------------------------------------------------------------------- +! + SUBROUTINE nmm_bdymass_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! to be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! SW grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones + CBWGT4, HBWGT4, & ! are just dummys + CZ3d, Z3d, & ! Z3d dummy on nested domain + CFIS,FIS, & ! CFIS dummy on fine domain + CSM,SM, & ! CSM is dummy + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CPSTD,PSTD, & + CKZMAX,KZMAX ) + + USE MODULE_MODEL_CONSTANTS + use module_state_description + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ckzmax,kzmax + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, ipos, jpos, nri, nrj + + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, INTENT(INOUT) :: cdt, ndt + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt + +! parent domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ),INTENT(IN) :: CZ3d + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD + REAL,INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD + REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD + REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + INTEGER :: i,j,k,ii,jj + REAL :: dlnpdz,dum2d + REAL, DIMENSION (nims:nime,njms:njme) :: zs + REAL, DIMENSION (nims:nime,njms:njme) :: CWK1,CWK2,CWK3,CWK4 + +! +!*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ASLO CHECK IF SM IS LAND (SM=0) OVER TOPO +!*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES! +! + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + ZS(I,J)=FIS(I,J)/G + ENDDO + ENDDO + +! X start boundary + + NMM_XS: IF(NITS .EQ. NIDS)THEN +! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDS + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K=NKTS,KZMAX + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) +! +! IF(J==13 .AND. K==1)WRITE(0,*)IIH(I,J),IIH(I,J)+1,JJH(I,J)-1,JJH(I,J),JJH(I,J)+1 +! IF(J==13 .AND. K==1)WRITE(0,*)HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J), & +! CZ3d(IIH(I,J), K, JJH(I,J) ), & +! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), & +! CZ3d(IIH(I,J), K, JJH(I,J)-1), & +! CZ3d(IIH(I,J), K, JJH(I,J)+1) +! + ENDIF + END DO + END DO + + DO J = NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE. 0)THEN + IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed + dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j)) + dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j))) + CWK1(I,J) = dum2d -PDTOP -PTOP +! WRITE(0,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK1(I,J) + ELSE ! target level bounded by input levels + DO K =NKTS,KZMAX-1 + IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN + dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j)) + dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j))) + CWK1(I,J) = dum2d -PDTOP -PTOP +! WRITE(0,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK1(I,J) + ENDIF + ENDDO + ENDIF + IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN + WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J) + CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") + ENDIF + ELSE + CWK1(I,J)=0. + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + ntemp_b(i,k,j) = CWK1(I,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK1(I,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges + END DO + END DO + ENDIF NMM_XS + +! X end boundary + + NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN +! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDE-1 + II = NIDE - I + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKTS,KZMAX + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1) + +! IF(J==151)WRITE(0,*)'CRASH1',K,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J) +! IF(J==151)WRITE(0,*)'CRASH2',K,Z3d(I,K,J),CZ3d(IIH(I,J), K, JJH(I,J) ), & +! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), & +! CZ3d(IIH(I,J), K, JJH(I,J)-1), & +! CZ3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) + +! IF(J==151)WRITE(0,*)'CRASH3',K,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J) +! IF(J==151)WRITE(0,*)'CRASH4',K,Z3d(I,K,J),CZ3d(IIH(I,J), K, JJH(I,J) ), & +! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), CZ3d(IIH(I,J)+1,K, JJH(I,J)-1), & +! CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ENDDO + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain + IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed + dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j)) + dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j))) + CWK2(I,J) = dum2d -PDTOP -PTOP +! WRITE(0,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK2(I,J) + ELSE ! target level bounded by input levels + DO K =NKTS,KZMAX-1 + IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN + dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j)) + dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j))) + CWK2(I,J) = dum2d -PDTOP -PTOP +! WRITE(0,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK2(I,J) + ENDIF + ENDDO + ENDIF + IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN + WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J) + CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") + ENDIF + ELSE + CWK2(I,J) = 0.0 + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + ntemp_b(i,k,j) = CWK2(I,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,II,P_XEB) = CWK2(I,J) ! This will not work for NMM since +! bdy_t(J,K,II,P_XEB)= 0.0 ! NMM core requires BC halo exchanges + END DO + END DO + ENDIF NMM_XE + +! Y start boundary + + NMM_YS: IF(NJTS .EQ. NJDS)THEN +! WRITE(20,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDS + DO K=NKTS,KZMAX + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF + END DO + END DO + + DO I = NITS,MIN(NITE,NIDE-1) + IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed + dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j)) + dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j))) + CWK3(I,J) = dum2d -PDTOP -PTOP +! WRITE(20,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK3(I,J) + ELSE ! target level bounded by input levels + DO K =NKTS,KZMAX-1 + IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN + dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j)) + dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j))) + CWK3(I,J) = dum2d -PDTOP -PTOP +! WRITE(20,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK3(I,J) + ENDIF + ENDDO + ENDIF + IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN + WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J) + CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") + ENDIF + ENDDO + + DO K = NKDS, NKDE + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK3(I,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,J,P_YSB) = CWK3(I,J) ! This will not work for the NMM core +! bdy_t(I,K,J,P_YSB) = 0.0 ! since NMM core requires BC halo exchanges + END DO + END DO + END IF NMM_YS + +! Y end boundary + + NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN +! WRITE(20,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDE-1 + JJ = NJDE - J + DO K=NKTS,KZMAX + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF + END DO + END DO + + DO I = NITS,MIN(NITE,NIDE-1) + IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed + dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j)) + dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j))) + CWK4(I,J) = dum2d -PDTOP -PTOP +! WRITE(20,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK4(I,J) + ELSE ! target level bounded by input levels + DO K =NKTS,KZMAX-1 + IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN + dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j)) + dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j))) + CWK4(I,J) = dum2d -PDTOP -PTOP +! WRITE(20,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK4(I,J) + ENDIF + ENDDO + ENDIF + IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN + WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J) + CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") + ENDIF + ENDDO + + DO K = NKDS,NKDE + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK4(I,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,JJ,P_YEB) = CWK4(I,J) ! This will not work for the NMM core +! bdy_t(I,K,JJ,P_YEB) = 0.0 ! since NMM core requires BC halo exchanges + END DO + END DO + END IF NMM_YE + + RETURN + + END SUBROUTINE nmm_bdymass_interp1 +! +!========================================================================================== +! E grid vertical interpolation: Heights (Z3d) originally obtained on the mother domains +! on isobaric levels are first horizontally interpolated in interp_mass_nmm on to the +! the nested domain. Now heights on isobaric surfaces must be interpolated on to the +! new hybrid surfaces that include the high resolution topography. After obtaining +! heights in the modified hybrid surfaces, we use the hyposmetric equation to recover +! the temperature fields. The following routine returns the temperature fields in the +! nested domain. First routine pertains to initial conditions and the next one +! corresponds to boundary conditions. +!======================================================================================= +! + SUBROUTINE interp_p2hyb_nmm (cfld, & ! CD field + cids,cide,ckds,ckde,cjds,cjde, & + cims,cime,ckms,ckme,cjms,cjme, & + cits,cite,ckts,ckte,cjts,cjte, & + nfld, & ! ND field + nids,nide,nkds,nkde,njds,njde, & + nims,nime,nkms,nkme,njms,njme, & + nits,nite,nkts,nkte,njts,njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag,ystag, & ! staggering of field + ipos,jpos, & ! Position of lower left of nest in CD + nri,nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys for weights + CZ3d,Z3d, & ! Z3d interpolated from CZ3d + CQ,Q, & ! CQ not used + CFIS,FIS, & ! CFIS dummy on fine domain + CPD,PD, & + CPSTD,PSTD, & + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CETA1,ETA1,CETA2,ETA2, & + CDETA1,DETA1,CDETA2,DETA2 ) + + USE MODULE_MODEL_CONSTANTS + USE module_timing + IMPLICIT NONE + + LOGICAL,INTENT(IN) :: xstag, ystag + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + +! parent domain + + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4 + + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CZ3d,CQ + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFIS,CPD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CDETA1,CDETA2 + REAL, INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4 + + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is T, here + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(IN) :: Z3d,Q + REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: FIS,PD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: DETA1,DETA2 + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608 + REAL, PARAMETER :: TRG=2.0*R_D*GI,COEF3=R_D*GI*LAPSR + INTEGER :: I,J,K + REAL :: TVOUT,PMO + REAL,DIMENSION(nims:nime,njms:njme) :: ZS + REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2 +! REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme) :: TOUT +!----------------------------------------------------------------------------------------------------- +! +! +! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION +! + IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & + CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + + +! WRITE(22,*)'------------- MED NEST INITIAL 2 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(22,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(22,*) + +! +! direct horizontal interpolation may work in the absence of terrain especially at +! the boundaries +! +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO K=NKDS,NKDE +! DO I=NITS,MIN(NITE,NIDE-1) +! IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 +! NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & +! + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & +! + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & +! + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) +! ELSE +! NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & +! + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & +! + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & +! + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) +! ENDIF +! ENDDO +! ENDDO +! ENDDO + +! +! Interpolate Z3d to the new pressure levels, determine Temperature in the nested domain +! from hydrostatic equation. This is important for terrain adjustments in nested domains +! + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + ZS(I,J)=FIS(I,J)*GI + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! +! clean local array before use of spline + + ZIN=0.;PIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. +! + DO K=NKDS,NKDE ! inputs at standard interface levels + PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop;redefined later + ZIN(K) = Z3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO +! + IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb + PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target + ZIN(NKDE) = ZS(I,J) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate + + DO K=NKDS,NKDE-1 + PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) + TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG + NFLD(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature in the nested domain +! IF(I==2 .and. J==3)WRITE(0,*)K,PIN(K),Z3d(I,K,J),PIO(K),ZOUT(K),TVOUT,Q(I,K,J),NFLD(I,K,J) + ENDDO +! + ENDIF + ENDDO + ENDDO + +! + END SUBROUTINE interp_p2hyb_nmm +! +!=================================================================================================== +! + SUBROUTINE nmm_bdy_p2hyb (cfld, & ! CD field + cids,cide,ckds,ckde,cjds,cjde, & + cims,cime,ckms,ckme,cjms,cjme, & + cits,cite,ckts,ckte,cjts,cjte, & + nfld, & ! ND field + nids,nide,nkds,nkde,njds,njde, & + nims,nime,nkms,nkme,njms,njme, & + nits,nite,nkts,nkte,njts,njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag,ystag, & ! staggering of field + ipos,jpos, & ! Position of lower left of nest in CD + nri,nrj, & ! nest ratios + cbdy, nbdy, & + cbdy_t, nbdy_t, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! to be removed + CTEMP_BT,NTEMP_BT, & + CZ3d,Z3d, & ! Z3d interpolated from CZ3d + CQ,Q, & ! CQ not used + CFIS,FIS, & ! CFIS dummy on fine domain + CPD,PD, & + CPSTD,PSTD, & + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CETA1,ETA1,CETA2,ETA2, & + CDETA1,DETA1,CDETA2,DETA2 ) + + USE MODULE_MODEL_CONSTANTS + USE module_timing + IMPLICIT NONE + + LOGICAL,INTENT(IN) :: xstag, ystag + REAL, INTENT(INOUT) :: cdt, ndt + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t + +! parent domain + + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CZ3d,CQ + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFIS,CPD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CDETA1,CDETA2 + REAL, INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is T, here + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(IN) :: Z3d,Q + REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: FIS,PD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: DETA1,DETA2 + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608 + REAL, PARAMETER :: TRG=2.0*R_D*GI,COEF3=R_D*GI*LAPSR + INTEGER :: I,J,K,II,JJ + REAL :: TVOUT,PMO + REAL,DIMENSION(nims:nime,njms:njme) :: ZS + REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2 + REAL, DIMENSION (nims:nime,nkms:nkme,njms:njme) :: CWK1,CWK2,CWK3,CWK4 +!----------------------------------------------------------------------------------------------------- +! + +! +! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION +! + IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & + CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + ZS(I,J)=FIS(I,J)*GI + ENDDO + ENDDO + + +! X start boundary + + NMM_XS: IF(NITS .EQ. NIDS)THEN +! WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDS + DO J=NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE. 0)THEN + ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline +! + DO K=NKTS,NKDE ! inputs at standard interface levels + PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop; redifined later + ZIN(K) = Z3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO +! + IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb + PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target + ZIN(NKDE) = ZS(I,J) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate + + DO K=NKDS,NKDE-1 + PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) + TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG + CWK1(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain + ENDDO + + ELSE + DO K=NKDS,NKDE-1 + CWK1(I,K,J)=0.0 + ENDDO + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE-1 + ntemp_b(i,k,j) = CWK1(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges + END DO + END DO + + ENDIF NMM_XS + + +! X end boundary + + + NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN +! WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDE-1 + II = NIDE - I + DO J=NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE. 0)THEN + ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline +! + DO K=NKTS,NKDE ! inputs at standard interface levels;redifined later + PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop + ZIN(K) = Z3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO +! + IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb + PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target + ZIN(NKDE) = ZS(I,J) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate + + DO K=NKDS,NKDE-1 + PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) + TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG + CWK2(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain + ENDDO + + ELSE + DO K=NKDS,NKDE-1 + CWK2(I,K,J)=0.0 + ENDDO + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE-1 + ntemp_b(i,k,j) = CWK2(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK2(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges +! if(k==1)WRITE(0,*)J,ntemp_b(i,k,j) + END DO + END DO + + ENDIF NMM_XE + +! Y start boundary + + NMM_YS: IF(NJTS .EQ. NJDS)THEN +! WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDS + DO I=NITS,MIN(NITE,NIDE-1) + ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline +! + DO K=NKDS,NKDE ! inputs at standard interface levels;redifined later + PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop + ZIN(K) = Z3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO +! + IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb + PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target + ZIN(NKDE) = ZS(I,J) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate + + DO K=NKDS,NKDE-1 + PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) + TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG + CWK3(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain + ENDDO + + ENDDO + + DO K = NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK3(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK3(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges +! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j) + END DO + END DO + + ENDIF NMM_YS + +! Y end boundary + + NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN +! WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDE-1 + JJ = NJDE - J + DO I=NITS,MIN(NITE,NIDE-1) + ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline +! + DO K=NKDS,NKDE ! inputs at standard interface levels;redifined later + PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop + ZIN(K) = Z3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO +! + IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb + PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target + ZIN(NKDE) = ZS(I,J) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate + + DO K=NKDS,NKDE-1 + PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) + TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG + CWK4(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain + ENDDO + + ENDDO + + DO K = NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK4(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK4(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges +! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j) + END DO + END DO + + ENDIF NMM_YE +! + END SUBROUTINE nmm_bdy_p2hyb + +!======================================================================================= +! +! ADDED FOR INCLUDING MOISTURE AND THERMODYNAMIC ENERGY BALANCE +! +!======================================================================================= + + SUBROUTINE interp_scalar_nmm (cfld, & ! CD field + cids,cide,ckds,ckde,cjds,cjde, & + cims,cime,ckms,ckme,cjms,cjme, & + cits,cite,ckts,ckte,cjts,cjte, & + nfld, & ! ND field + nids,nide,nkds,nkde,njds,njde, & + nims,nime,nkms,nkme,njms,njme, & + nits,nite,nkts,nkte,njts,njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag,ystag, & ! staggering of field + ipos,jpos, & ! Position of lower left of nest in CD + nri,nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys for weights + CC3d,C3d, & + CPD,PD, & + CPSTD,PSTD, & + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CETA1,ETA1,CETA2,ETA2 ) + + USE MODULE_MODEL_CONSTANTS + USE module_timing + IMPLICIT NONE + + LOGICAL,INTENT(IN) :: xstag, ystag + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + +! parent domain + + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4 + + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 + REAL, INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4 + + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is scalar on hybrid levels + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: C3d ! Scalar on constant pressure levels + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD + REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: PD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + INTEGER :: I,J,K + REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2 + +!----------------------------------------------------------------------------------------------------- +! +! +! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE OR LINEAR INTERPOLATION +! + IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & + CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + +! +! FIRST, HORIZONTALLY INTERPOLATE MOISTURE NOW AVAILABLE ON CONSTANT PRESSURE SURFACE (LEVELS) FROM THE +! PARENT TO THE NESTED DOMAIN +! +!*** INDEX CONVENTIONS +!*** HBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** HBWGT1 HBWGT2 +!*** +!*** +!*** 3 +!*** HBWGT3 + + C3d=0.0 + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1) + + ELSE + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + +! +! RECOVER THE SCALARS FROM CONSTANT PRESSURE SURFACES (LEVELS) ON TO HYBRID SURFACES +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! +! clean local array before use of spline or linear interpolation + + CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. +! + DO K=NKDS+1,NKDE ! inputs at standard levels + PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) + CIN(K-1) = C3d(I,NKDE-K+1,J) + ENDDO +! + Y2(1 )=0. + Y2(NKDE-1)=0. +! + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO + + DO K=NKDS,NKDE-1 ! target points in model levels + PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) + ENDDO +! + + IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary + PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + + DO K=1,NKDE-1 + NFLD(I,K,J)= COUT(K) ! scalar in the nested domain + ENDDO + +! IF(I==1 .AND. J==1)THEN +! WRITE(0,*) +! WRITE(0,*)'IPOS=',IPOS,'JPOS=',JPOS +! DO K=NKTS,NKDE-1 +! WRITE(0,*)'T and Q AFTER BALANCING',K,CFLD(IPOS,K,JPOS),NFLD(I,K,J), & +! CFLD(IPOS,K,JPOS)-NFLD(I,K,J) +! ENDDO +! ENDIF +! + ENDIF + ENDDO + ENDDO + + END SUBROUTINE interp_scalar_nmm +! +!=========================================================================================== +! + SUBROUTINE nmm_bdy_scalar (cfld, & ! CD field + cids,cide,ckds,ckde,cjds,cjde, & + cims,cime,ckms,ckme,cjms,cjme, & + cits,cite,ckts,ckte,cjts,cjte, & + nfld, & ! ND field + nids,nide,nkds,nkde,njds,njde, & + nims,nime,nkms,nkme,njms,njme, & + nits,nite,nkts,nkte,njts,njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag,ystag, & ! staggering of field + ipos,jpos, & ! Position of lower left of nest in CD + nri,nrj, & ! nest ratios + cbdy, nbdy, & + cbdy_t, nbdy_t, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! to be removed + CTEMP_BT,NTEMP_BT, & + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, & ! dummys for weights + CC3d,C3d, & + CPD,PD, & + CPSTD,PSTD, & + CPDTOP,PDTOP, & + CPTOP,PTOP, & + CETA1,ETA1,CETA2,ETA2 ) + USE MODULE_MODEL_CONSTANTS + USE module_timing + IMPLICIT NONE + + LOGICAL,INTENT(IN) :: xstag, ystag + REAL, INTENT(INOUT) :: cdt, ndt + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + +! parent domain + + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2 + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4 + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD + REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD + REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 + REAL, INTENT(IN) :: CPDTOP,CPTOP + +! nested domain + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4 + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD + REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: C3d !Scalar on constant pressure levels + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD + REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: PD + REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 + REAL,INTENT(IN) :: PDTOP,PTOP + +! local + + INTEGER,PARAMETER :: JTB=134 + INTEGER :: I,J,K,II,JJ + REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2 + REAL, DIMENSION (nims:nime,nkms:nkme,njms:njme) :: CWK1,CWK2,CWK3,CWK4 +!----------------------------------------------------------------------------------------------------- +! +! +! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION +! + IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & + CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + +! X start boundary + + NMM_XS: IF(NITS .EQ. NIDS)THEN +! WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDS + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF + ENDDO + ENDDO +! + DO J=NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE. 0)THEN + CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array + DO K=NKDS+1,NKDE ! inputs at standard levels + PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) + CIN(K-1) = C3d(I,NKDE-K+1,J) + ENDDO + Y2(1 )=0. + Y2(NKDE-1)=0. + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO + DO K=NKDS,NKDE-1 ! target points in model levels + PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) + ENDDO + IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary + PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + + DO K=1,NKDE-1 + CWK1(I,K,J)= COUT(K) ! scalar in the nested domain + ENDDO + ELSE + DO K=NKDS,NKDE-1 + CWK1(I,K,J)=0.0 + ENDDO + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE-1 + ntemp_b(i,k,j) = CWK1(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges + END DO + END DO + + ENDIF NMM_XS + + +! X end boundary + + NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN +! WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDE-1 + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + IF(MOD(J,2) .NE. 0)THEN + CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array + DO K=NKDS+1,NKDE ! inputs at standard levels + PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) + CIN(K-1) = C3d(I,NKDE-K+1,J) + ENDDO + Y2(1 )=0. + Y2(NKDE-1)=0. + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO + DO K=NKDS,NKDE-1 ! target points in model levels + PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) + ENDDO + IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary + PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + + DO K=1,NKDE-1 + CWK2(I,K,J)= COUT(K) ! scalar in the nested domain + ENDDO + ELSE + DO K=NKDS,NKDE-1 + CWK2(I,K,J)=0.0 + ENDDO + ENDIF + ENDDO + + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,MIN(NKTE,NKDE-1) + ntemp_b(i,k,j) = CWK2(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK2(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges +! if(k==1)WRITE(0,*)J,ntemp_b(i,k,j) + END DO + END DO + + ENDIF NMM_XE + +! Y start boundary + + NMM_YS: IF(NJTS .EQ. NJDS)THEN +! WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDS + DO K=NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ENDDO + ENDDO +! + DO I=NITS,MIN(NITE,NIDE-1) + CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array + DO K=NKDS+1,NKDE ! inputs at standard levels + PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) + CIN(K-1) = C3d(I,NKDE-K+1,J) + ENDDO + Y2(1 )=0. + Y2(NKDE-1)=0. + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO + DO K=NKDS,NKDE-1 ! target points in model levels + PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) + ENDDO + IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary + PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + + DO K=1,NKDE-1 + CWK3(I,K,J)= COUT(K) ! scalar in the nested domain + ENDDO + ENDDO + + DO K = NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK3(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK3(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges + ENDDO + ENDDO + + + ENDIF NMM_YS + +! Y end boundary + + NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN +! WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDE-1 + DO K=NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1) + ELSE + C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ENDDO + ENDDO + + DO I=NITS,MIN(NITE,NIDE-1) + CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array + DO K=NKDS+1,NKDE ! inputs at standard levels + PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) + CIN(K-1) = C3d(I,NKDE-K+1,J) + ENDDO + Y2(1 )=0. + Y2(NKDE-1)=0. + DO K=NKDS,NKDE ! target points in model interface levels (pint) + PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP + ENDDO + DO K=NKDS,NKDE-1 ! target points in model levels + PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) + ENDDO + IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary + PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) + ENDIF + + CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + + DO K=1,NKDE-1 + CWK4(I,K,J)= COUT(K) ! scalar in the nested domain + ENDDO + ENDDO + + DO K = NKDS,NKDE-1 + DO I = NITS,MIN(NITE,NIDE-1) + ntemp_b(i,k,j) = CWK4(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK4(I,K,J) ! This will not work for NMM since +! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges +! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j) + END DO + END DO + + ENDIF NMM_YE + +! + END SUBROUTINE nmm_bdy_scalar +! +! +!======================================================================================= + SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) +! +! ****************************************************************** +! * * +! * THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE * +! * PROGRAMED FOR A SMALL SCALAR MACHINE. * +! * * +! * PROGRAMER Z. JANJIC * +! * * +! * NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION. MUST BE GE 3. * +! * XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE * +! * FUNCTION ARE GIVEN. MUST BE IN ASCENDING ORDER. * +! * YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD. * +! * Y2 - THE SECOND DERIVATIVES AT THE POINTS XOLD. IF NATURAL * +! * SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE * +! * SPECIFIED. * +! * NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED. * +! * XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE * +! * FUNCTION ARE CALCULATED. XNEW(K) MUST BE GE XOLD(1) * +! * AND LE XOLD(NOLD). * +! * YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED. * +! * P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2. * +! * * +! ****************************************************************** +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD + REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD + REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2 + REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW +! + INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1 + REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR & + ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1 +!--------------------------------------------------------------------- + +! debug + + II=9999 + JJ=9999 + IF(I.eq.II.and.J.eq.JJ)THEN + WRITE(0,*)'DEBUG in SPLINE2: I,J',I,J + WRITE(0,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold) + DO K=1,NOLD + WRITE(0,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ' & + ,K,YOLD(K),XOLD(K) + ENDDO + ENDIF + +! + NOLDM1=NOLD-1 +! + DXL=XOLD(2)-XOLD(1) + DXR=XOLD(3)-XOLD(2) + DYDXL=(YOLD(2)-YOLD(1))/DXL + DYDXR=(YOLD(3)-YOLD(2))/DXR + RTDXC=0.5/(DXL+DXR) +! + P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) + Q(1)=-RTDXC*DXR +! + IF(NOLD.EQ.3)GO TO 150 +!--------------------------------------------------------------------- + K=3 +! + 100 DXL=DXR + DYDXL=DYDXR + DXR=XOLD(K+1)-XOLD(K) + DYDXR=(YOLD(K+1)-YOLD(K))/DXR + DXC=DXL+DXR + DEN=1./(DXL*Q(K-2)+DXC+DXC) +! + P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) + Q(K-1)=-DEN*DXR +! + K=K+1 + IF(K.LT.NOLD)GO TO 100 +!----------------------------------------------------------------------- + 150 K=NOLDM1 +! + 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) +! + K=K-1 + IF(K.GT.1)GO TO 200 +!----------------------------------------------------------------------- + K1=1 +! + 300 XK=XNEW(K1) +! + DO 400 K2=2,NOLD +! + IF(XOLD(K2).GT.XK)THEN + KOLD=K2-1 + GO TO 450 + ENDIF +! + 400 CONTINUE +! + YNEW(K1)=YOLD(NOLD) + GO TO 600 +! + 450 IF(K1.EQ.1)GO TO 500 + IF(K.EQ.KOLD)GO TO 550 +! + 500 K=KOLD +! + Y2K=Y2(K) + Y2KP1=Y2(K+1) + DX=XOLD(K+1)-XOLD(K) + RDX=1./DX +! + AK=.1666667*RDX*(Y2KP1-Y2K) + BK=0.5*Y2K + CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) +! + 550 X=XK-XOLD(K) + XSQ=X*X +! + YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) + +! debug + + IF(I.eq.II.and.J.eq.JJ)THEN + WRITE(0,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1) + ENDIF + +! + 600 K1=K1+1 + IF(K1.LE.NNEW)GO TO 300 + + RETURN + + END SUBROUTINE SPLINE2 + +!======================================================================================= +! E grid interpolation for H and V points +!======================================================================================= + + SUBROUTINE interp_h_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys for weights + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + INTEGER i,j,k +! +!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along x' ) + IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along y' ) + ENDDO + ENDDO + +! WRITE(23,*)'------------- MED NEST INITIAL 3 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(23,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(23,*) + +! +!*** INDEX CONVENTIONS +!*** HBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** HBWGT1 HBWGT2 +!*** +!*** +!*** 3 +!*** HBWGT3 + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE interp_h_nmm +! + SUBROUTINE interp_v_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights + CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, VBWGT4 ) ! dummys + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + INTEGER i,j,k + + +! +!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IIV(i,j).LT.(CIDS-shw) .OR. IIV(i,j).GT.(CIDE+shw)) & + CALL wrf_error_fatal ('vpoints:check domain bounds along x' ) + IF(JJV(i,j).LT.(CJDS-shw) .OR. JJV(i,j).GT.(CJDE+shw)) & + CALL wrf_error_fatal ('vpoints:check domain bounds along y' ) + ENDDO + ENDDO + +! WRITE(24,*)'------------- MED NEST INITIAL 4 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(24,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(24,*) + +! +!*** INDEX CONVENTIONS +!*** VBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** VBWGT1 VBWGT2 +!*** +!*** +!*** 3 +!*** VBWGT3 + + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! + IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1) + ELSE + NFLD(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1) + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE interp_v_nmm +! +!======================================================================================= +! E grid nearest neighbour interpolation for H points +!======================================================================================= +! + SUBROUTINE interp_hnear_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! just dummys + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + + LOGICAL FLIP + INTEGER i,j,k,n + REAL SUM,AMAXVAL + REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + + +! WRITE(25,*)'------------- MED NEST INITIAL 5 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(25,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(25,*) + +! +!*** INDEX CONVENTIONS +!*** NBWGT4=0 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** NBWGT1=1 NBWGT2=0 +!*** +!*** +!*** 3 +!*** NBWGT3=0 + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + NBWGT(1,I,J)=HBWGT1(I,J) + NBWGT(2,I,J)=HBWGT2(I,J) + NBWGT(3,I,J)=HBWGT3(I,J) + NBWGT(4,I,J)=HBWGT4(I,J) + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! + AMAXVAL=0. + DO N=1,4 + AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) + ENDDO +! + FLIP=.TRUE. + SUM=0.0 + DO N=1,4 + IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN + NBWGT(N,I,J)=1.0 + FLIP=.FALSE. + ELSE + NBWGT(N,I,J)=0.0 + ENDIF + SUM=SUM+NBWGT(N,I,J) + IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) + ENDDO +! + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE interp_hnear_nmm +! +!======================================================================================= +! E grid nearest neighbour interpolation for integer H points +!======================================================================================= +! + SUBROUTINE interp_int_hnear_nmm (cfld, & ! CD field; integers + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field; integers + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! s-w grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! just dummys + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + + LOGICAL FLIP + INTEGER i,j,k,n + REAL SUM,AMAXVAL + REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + + + +! WRITE(26,*)'------------- MED NEST INITIAL 6 ----------------' +! DO J=NJTS,MIN(NJTE,NJDE-1) +! DO I=NITS,MIN(NITE,NIDE-1) +! WRITE(26,*)I,J,IMASK(I,J),NFLD(I,1,J) +! ENDDO +! ENDDO +! WRITE(26,*) + +! +!*** INDEX CONVENTIONS +!*** NBWGT4=0 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** NBWGT1=1 NBWGT2=0 +!*** +!*** +!*** 3 +!*** NBWGT3=0 + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN + NBWGT(1,I,J)=HBWGT1(I,J) + NBWGT(2,I,J)=HBWGT2(I,J) + NBWGT(3,I,J)=HBWGT3(I,J) + NBWGT(4,I,J)=HBWGT4(I,J) + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! + AMAXVAL=0. + DO N=1,4 + AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) + ENDDO +! + FLIP=.TRUE. + SUM=0.0 + DO N=1,4 + IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN + NBWGT(N,I,J)=1.0 + FLIP=.FALSE. + ELSE + NBWGT(N,I,J)=0.0 + ENDIF + SUM=SUM+NBWGT(N,I,J) + IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) + ENDDO +! + ENDIF + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKTS,NKTS + DO I=NITS,MIN(NITE,NIDE-1) +! + IF(IMASK(I,J) .NE. 1)THEN + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE interp_int_hnear_nmm +! +!-------------------------------------------------------------------------------------- + + SUBROUTINE nmm_bdy_hinterp (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + cbdy, nbdy, & + cbdy_t, nbdy_t, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys + + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld +! + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: ntemp_b,ntemp_bt +! + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t + REAL cdt, ndt + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH +! Local + + INTEGER nijds, nijde, spec_bdy_width,i,j,k + + nijds = min(nids, njds) + nijde = max(nide, njde) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + + + CALL nmm_bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys + + RETURN + + END SUBROUTINE nmm_bdy_hinterp + +!---------------------------------------------------------------------------------------------------- + SUBROUTINE nmm_bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys + + use module_state_description + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & ! ignore + ipos, jpos, & + nri, nrj + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld +! + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: ntemp_b,ntemp_bt +! + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL :: cdt, ndt + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + +! local + + INTEGER :: i,j,k,ii,jj + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: cwk1,cwk2,cwk3,cwk4 + +! X start boundary + + NMM_XS: IF(NITS .EQ. NIDS)THEN +! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDS + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + CWK1(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + + + ELSE + CWK1(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF + ELSE + CWK1(I,K,J) = 0.0 ! even rows at mass points of the nested domain + ENDIF + ntemp_b(i,k,j) = CWK1(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM core +! bdy_t(J,K,I,P_XSB) = 0.0 ! since NMM requires BC halos + END DO + END DO + ENDIF NMM_XS + +! X end boundary + + NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN +! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) + I = NIDE-1 + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of the nested domain + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + CWK2(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + CWK2(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ELSE + CWK2(I,K,J) = 0.0 ! even rows at mass points + ENDIF + II = NIDE - I + ntemp_b(i,k,j) = CWK2(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,II,P_XEB) = CWK2(I,K,J) +! bdy_t(J,K,II,P_XEB)= 0.0 + END DO + END DO + ENDIF NMM_XE + +! Y start boundary + + NMM_YS: IF(NJTS .EQ. NJDS)THEN +! WRITE(0,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDS + DO K = NKDS, NKDE + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + CWK3(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + CWK3(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + ntemp_b(i,k,j) = CWK3(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,J,P_YSB) = CWK3(I,K,J) +! bdy_t(I,K,J,P_YSB) = 0.0 + END DO + END DO + END IF NMM_YS + +! Y end boundary + + NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN +! WRITE(0,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) + J = NJDE-1 + DO K = NKDS,NKDE + DO I = NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + CWK4(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + CWK4(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + + ENDIF + JJ = NJDE - J + ntemp_b(i,k,j) = CWK4(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,JJ,P_YEB) = CWK4(I,K,J) +! bdy_t(I,K,JJ,P_YEB) = 0.0 + END DO + END DO + END IF NMM_YE + + RETURN + + END SUBROUTINE nmm_bdy_interp1 + +!-------------------------------------------------------------------------------------- + + SUBROUTINE nmm_bdy_vinterp ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + cbdy, nbdy, & + cbdy_t, nbdy_t, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights + CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, VBWGT4 ) ! dummys + + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld +! + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: ntemp_b,ntemp_bt +! + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t + REAL cdt, ndt + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV + +! Local + + INTEGER nijds, nijde, spec_bdy_width + + nijds = min(nids, njds) + nijde = max(nide, njde) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + + CALL nmm_bdy_interp2( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights + CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, VBWGT4 ) ! dummys + RETURN + + END SUBROUTINE nmm_bdy_vinterp + +!---------------------------------------------------------------------------------------------------- + SUBROUTINE nmm_bdy_interp2( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cdt, ndt, & + CTEMP_B,NTEMP_B, & ! These temp arrays should be removed + CTEMP_BT,NTEMP_BT, & ! later on + CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights + CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, VBWGT4 ) + + use module_state_description + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & ! ignore + ipos, jpos, & + nri, nrj + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld +! + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: ctemp_b,ctemp_bt + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: ntemp_b,ntemp_bt +! + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL :: cdt, ndt + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV + +! local + + INTEGER :: i,j,k,ii,jj + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: cwk1,cwk2,cwk3,cwk4 + +! X start boundary + + NMM_XS: IF(NITS .EQ. NIDS)THEN +! WRITE(0,*)'ENTERING X START BOUNDARY AT VELOCITY POINTS',NITS,NIDS,NJTS,MIN(NJTE,NJDE-1) + I = NIDS + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of nested domain + IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + CWK1(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1) + ELSE + CWK1(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1) + ENDIF + ELSE + CWK1(I,K,J) = 0.0 ! odd rows along J, at mass points have zero velocity + ENDIF + ntemp_b(i,k,j) = CWK1(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,I,P_XSB) = CWK1(I,K,J) +! bdy_t(J,K,I,P_XSB) = 0.0 +! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J) +! IF(k==1)WRITE(0,*)i,j,ntemp_b(i,k,j) + END DO + END DO + ENDIF NMM_XS + +! X end boundary + + NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN +! WRITE(0,*)'ENTERING X END BOUNDARY AT VELOCITY POINTS',NITE-1,NIDE-1,NJTS,MIN(NJTE,NJDE-1) + I = NIDE-1 + DO J = NJTS,MIN(NJTE,NJDE-1) + DO K = NKDS,NKDE + IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of the nested domain + IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain + CWK2(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1) + ELSE + CWK2(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1) + ENDIF + ELSE + CWK2(I,K,J) = 0.0 ! odd rows at mass points + ENDIF + II = NIDE - I + ntemp_b(i,k,j) = CWK2(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(J,K,II,P_XEB) = CWK2(I,K,J) +! bdy_t(J,K,II,P_XEB)= 0.0 +! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J) +! IF(k==1)WRITE(0,*)i,j,ntemp_b(i,k,j) + END DO + END DO + ENDIF NMM_XE + +! Y start boundary + + NMM_YS: IF(NJTS .EQ. NJDS)THEN +! WRITE(0,*)'ENTERING Y START BOUNDARY AT VELOCITY POINTS',NJTS,NJDS,NITS,MIN(NITE,NIDE-1) + J = NJDS + DO K = NKDS, NKDE + DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL + IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 + CWK3(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1) + ELSE + CWK3(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1) + ENDIF + ntemp_b(i,k,j) = CWK3(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,J,P_YSB) = CWK3(I,K,J) +! bdy_t(I,K,J,P_YSB) = 0.0 +! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J) + END DO + END DO + END IF NMM_YS + +! Y end boundary + + NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN +! WRITE(0,*)'ENTERING Y END BOUNDARY AT VELOCITY POINTS',NJTE-1,NJDE-1,NITS,MIN(NITE,NIDE-1) + J = NJDE-1 + DO K = NKDS,NKDE + DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL + IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 + CWK4(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1) + ELSE + CWK4(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) & + + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) & + + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) & + + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1) + ENDIF + JJ = NJDE - J + ntemp_b(i,k,j) = CWK4(I,K,J) + ntemp_bt(i,k,j) = 0.0 +! bdy(I,K,JJ,P_YEB) = CWK4(I,K,J) +! bdy_t(I,K,JJ,P_YEB) = 0.0 +! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J) + END DO + END DO + END IF NMM_YE + + RETURN + + END SUBROUTINE nmm_bdy_interp2 + +! +!======================================================================================= +! E grid interpolation: simple copy from parent to mother domain +!======================================================================================= +! +!-------------------------------------------------------------------------------------- +! +! + SUBROUTINE nmm_copy ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH ) + + USE module_timing + IMPLICIT NONE + + LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(IN) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + +! local + INTEGER i,j,k + + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKTS,NKTE + DO I=NITS,MIN(NITE,NIDE-1) + NFLD(I,K,J) = CFLD(IIH(I,J),K,JJH(I,J)) + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE nmm_copy +! +!======================================================================================= +! E grid interpolation for terrain: In order to be consistent with the quasi-hydrostatic +! balance at the boundaries, a four point average of the terrain is done at the second +! and the penaltimate rows and columns around the boundaries. +!======================================================================================= +! + SUBROUTINE interp_topo_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys for weights + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + INTEGER i,j,k +! +!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along x' ) + IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along y' ) + ENDDO + ENDDO + + +! +!*** INDEX CONVENTIONS +!*** HBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** HBWGT1 HBWGT2 +!*** +!*** +!*** 3 +!*** HBWGT3 + + WRITE(0,*)'HALO WEIGHTS: interp_fcn.F','NITS to MIN(NITE,NIDE-1)=',NITS,MIN(NITE,NIDE-1) + WRITE(0,*)'HALO WEIGHTS: interp_fcn.F','NJTS to MIN(NJTE,NJDE-1)=',NJTS,MIN(NJTE,NJDE-1) + + DO J=MAX(NJTS-1,NJDS),MIN(NJTE+1,NJDE-1) + DO K=NKDS,NKDE + DO I=MAX(NITS-1,NIDS),MIN(NITE+1,NIDE-1) + IF(IMASK(I,J) .NE. 1)THEN +! + IF(I==1 .AND. K==1)WRITE(0,*)'HALO WEIGHTS: interp_fcn.F', I,J, & + HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J), & + IIH(I,J),JJH(I,J) + + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1) + ELSE + NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) & + + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) & + + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) & + + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1) + ENDIF +! + ENDIF + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE interp_topo_nmm +! +!======================================================================================= +! E grid test for mass point coincidence +!======================================================================================= +! + SUBROUTINE test_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4 ) ! dummys for weights + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + +! local + INTEGER i,j,k + REAL,PARAMETER :: error=0.0001,error1=1.0 + REAL :: diff +! +!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION +! + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along x' ) + IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & + CALL wrf_error_fatal ('hpoints:check domain bounds along y' ) + ENDDO + ENDDO + +! +!*** INDEX CONVENTIONS +!*** HBWGT4 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** HBWGT1 HBWGT2 +!*** +!*** +!*** 3 +!*** HBWGT3 + + +! WRITE(0,*)NITS,MIN(NITE,NIDE-1),CITS,CITE + DO J=NJTS,MIN(NJTE,NJDE-1) + DO K=NKDS,NKDE + DO I=NITS,MIN(NITE,NIDE-1) + IF(ABS(1.0-HBWGT1(I,J)) .LE. ERROR)THEN + DIFF=ABS(NFLD(I,K,J)-CFLD(IIH(I,J),K,JJH(I,J))) + IF(DIFF .GT. ERROR)THEN + CALL wrf_debug(1,"dyn_nmm: NON-COINCIDENT, NESTED MASS POINT") + WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,K,J),CFLD(IIH(I,J),K,JJH(I,J)),DIFF + ENDIF + IF(DIFF .GT. ERROR1)THEN + WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,K,J),CFLD(IIH(I,J),K,JJH(I,J)),DIFF + CALL wrf_error_fatal ('dyn_nmm: NON-COINCIDENT, NESTED MASS POINT') + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE test_nmm + +!================================== +! this is the default function used in nmm feedback at mass points. + + SUBROUTINE nmm_feedback ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, & + CBWGT1, HBWGT1, CBWGT2, HBWGT2, & + CBWGT3, HBWGT3, CBWGT4, HBWGT4 ) + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: is, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + REAL :: AVGH + +!===================================================================================== +! + + IF(nri .ne. 3 .OR. nrj .ne. 3) & + CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist' ) + +! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR MASS' + + CFLD = 9999.0 + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + nj = (cj-jpos)*nrj + 1 + if(mod(cj,2) .eq. 0)THEN + is=0 ! even rows for mass points (2,4,6,8) + else + is=1 ! odd rows for mass points (1,3,5,7) + endif + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + ni = (ci-ipos)*nri + 2 -is + IF(IS==0)THEN ! (2,4,6,8) + AVGH = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1) & + + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & + + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) + ELSE + AVGH = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1) & + + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & + + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) + ENDIF +!dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGH)/13.0 + CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGH)/13.0 + ENDDO + ENDDO + ENDDO + + END SUBROUTINE nmm_feedback + +!=========================================================================================== + + SUBROUTINE nmm_vfeedback ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIV, CJJ, JJV, & + CBWGT1, VBWGT1, CBWGT2, VBWGT2, & + CBWGT3, VBWGT3, CBWGT4, VBWGT4 ) + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIV,JJV + REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 + REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: is, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + REAL :: AVGV + +!===================================================================================== +! + + IF(nri .ne. 3 .OR. nrj .ne. 3) & + CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist') + +! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR VELOCITY' + + CFLD = 9999.0 + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + nj = (cj-jpos)*nrj + 1 + if(mod(cj,2) .eq. 0)THEN + is=1 ! even rows for velocity points (2,4,6,8) + else + is=0 ! odd rows for velocity points (1,3,5,7) + endif + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + ni = (ci-ipos)*nri + 2 -is + IF(IS==0)THEN ! (1,3,5,7) + AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1) & + + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & + + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) + ELSE + AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1) & + + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & + + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) + ENDIF +!dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGV)/13.0 + CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGV)/13.0 + ENDDO + ENDDO + ENDDO + + END SUBROUTINE nmm_vfeedback + + + SUBROUTINE nmm_smoother ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + xstag, ystag, & + ipos, jpos, & + nri, nrj & + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + LOGICAL, INTENT(IN) :: xstag, ystag + + + ! Local + + INTEGER :: feedback + INTEGER, PARAMETER :: smooth_passes = 5 + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew + INTEGER :: ci, cj, ck + INTEGER :: is, npass + REAL :: AVGH + + RETURN + ! If there is no feedback, there can be no smoothing. + + CALL nl_get_feedback ( 1, feedback ) + IF ( feedback == 0 ) RETURN + + WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT' + + DO npass = 1, smooth_passes + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=0 ! even rows for mass points (2,4,6,8) + else + is=1 ! odd rows for mass points (1,3,5,7) + endif + DO ck = ckts, ckte + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + IF(IS==0)THEN ! (2,4,6,8) + AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1) + ELSE + AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1) + ENDIF + CFLDNEW(CI,CK,CJ) = (AVGH + 4*CFLD(CI,CK,CJ)) / 8.0 + ENDDO + ENDDO + ENDDO + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=0 ! even rows for mass points (2,4,6,8) + else + is=1 ! odd rows for mass points (1,3,5,7) + endif + DO ck = ckts, ckte + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ) + ENDDO + ENDDO + ENDDO + + ENDDO ! do npass + + END SUBROUTINE nmm_smoother + + + SUBROUTINE nmm_vsmoother ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + xstag, ystag, & + ipos, jpos, & + nri, nrj & + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + LOGICAL, INTENT(IN) :: xstag, ystag + + + ! Local + + INTEGER :: feedback + INTEGER, PARAMETER :: smooth_passes = 5 + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew + INTEGER :: ci, cj, ck + INTEGER :: is, npass + REAL :: AVGV + + RETURN + ! If there is no feedback, there can be no smoothing. + + CALL nl_get_feedback ( 1, feedback ) + IF ( feedback == 0 ) RETURN + + WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY' + + DO npass = 1, smooth_passes + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=1 ! even rows for mass points (2,4,6,8) + else + is=0 ! odd rows for mass points (1,3,5,7) + endif + DO ck = ckts, ckte + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + IF(IS==0)THEN ! (2,4,6,8) + AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1) + ELSE + AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1) + ENDIF + CFLDNEW(CI,CK,CJ) = (AVGV + 4*CFLD(CI,CK,CJ)) / 8.0 + ENDDO + ENDDO + ENDDO + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=1 ! even rows for mass points (2,4,6,8) + else + is=0 ! odd rows for mass points (1,3,5,7) + endif + DO ck = ckts, ckte + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ) + ENDDO + ENDDO + ENDDO + + ENDDO + + END SUBROUTINE nmm_vsmoother +!====================================================================================== +! End of gopal's doing +!====================================================================================== +#endif + + SUBROUTINE interp_fcn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_timing + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + ! Local + +!logical first + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff +#ifdef MM5_SINT + INTEGER nfx, ior + PARAMETER (ior=2) + INTEGER nf + REAL psca(cims:cime,cjms:cjme,nri*nrj) + LOGICAL icmask( cims:cime, cjms:cjme ) + INTEGER i,j,k +#endif + + ! Iterate over the ND tile and compute the values + ! from the CD tile. + +#ifdef MM5_SINT + + ioff = 0 ; joff = 0 + nioff = 0 ; njoff = 0 + IF ( xstag ) THEN + ioff = (nri-1)/2 + nioff = nri + ENDIF + IF ( ystag ) THEN + joff = (nrj-1)/2 + njoff = nrj + ENDIF + + nfx = nri * nrj + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca ) + DO k = ckts, ckte + icmask = .FALSE. + DO nf = 1,nfx + DO j = cjms,cjme + nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest + DO i = cims,cime + ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest + if ( ni .ge. nits-nioff-1 .and. ni .le. nite+nioff+1 .and. nj .ge. njts-njoff-1 .and. nj .le. njte+njoff+1 ) then + if ( imask(ni,nj) .eq. 1 .or. imask(ni-nioff,nj-njoff) .eq. 1 ) then + icmask( i, j ) = .TRUE. + endif + endif + psca(i,j,nf) = cfld(i,k,j) + ENDDO + ENDDO + ENDDO + +! tile dims in this call to sint are 1-over to account for the fact +! that the number of cells on the nest local subdomain is not +! necessarily a multiple of the nest ratio in a given dim. +! this could be a little less ham-handed. + +!call start_timing + + CALL sint( psca, & + cims, cime, cjms, cjme, icmask, & + cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag ) + +!call end_timing( ' sint ' ) + + DO nj = njts, njte+joff + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj-1 , nrj ) ! coord of ND w/i CD point + nk = k + ck = nk + DO ni = nits, nite+ioff + ci = ipos + (ni-1) / nri ! i coord of CD point + ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point + if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1 ) then + nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri ) + endif + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO +#endif + +#ifdef DUMBCOPY +!write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme +!write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme +!write(0,'(") cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'(") nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + if ( imask ( ni, nj ) .eq. 1 ) then + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + endif + ENDDO + ENDDO + ENDDO +#endif + + RETURN + + END SUBROUTINE interp_fcn + +!================================== +! this is the default function used in feedback. + + SUBROUTINE copy_fcn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone + + ! Loop over the coarse grid in the area of the fine mesh. Do not + ! process the coarse grid values that are along the lateral BC + ! provided to the fine grid. Since that is in the specified zone + ! for the fine grid, it should not be used in any feedback to the + ! coarse grid as it should not have changed. + + ! Due to peculiarities of staggering, it is simpler to handle the feedback + ! for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or + ! an odd staggering ratio (3::1, 5::1, etc.). + + ! Though there are separate grid ratios for the i and j directions, this code + ! is not general enough to handle aspect ratios .NE. 1 for the fine grid cell. + + ! These are local integer increments in the looping. Basically, istag=1 means + ! that we will assume one less point in the i direction. Note that ci and cj + ! have a maximum value that is decreased by istag and jstag, respectively. + + ! Horizontal momentum feedback is along the face, not within the cell. For a + ! 3::1 ratio, temperature would use 9 pts for feedback, while u and v use + ! only 3 points for feedback from the nest to the parent. + + CALL nl_get_spec_zone( 1 , spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri * nrj + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./9. * & +! ( nfld( ni-1, nk , nj-1) + & +! nfld( ni , nk , nj-1) + & +! nfld( ni+1, nk , nj-1) + & +! nfld( ni-1, nk , nj ) + & +! nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) + & +! nfld( ni-1, nk , nj+1) + & +! nfld( ni , nk , nj+1) + & +! nfld( ni+1, nk , nj+1) ) + ENDDO + ENDDO + ENDDO + + ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./3. * & +! ( nfld( ni , nk , nj-1) + & +! nfld( ni , nk , nj ) + & +! nfld( ni , nk , nj+1) ) + ENDDO + ENDDO + ENDDO + + ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1 + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL( nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./3. * & +! ( nfld( ni-1, nk , nj ) + & +! nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) ) + ENDDO + ENDDO + ENDDO + + END IF + + ! Even refinement ratio + + ELSE IF ( MOD(nrj,2) .EQ. 0) THEN + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + + ! This is a simple schematic of the feedback indexing used in the even + ! ratio nests. For simplicity, a 2::1 ratio is depicted. Only the + ! mass variable staggering is shown. + ! Each of + ! the boxes with a "T" and four small "t" represents a coarse grid (CG) + ! cell, that is composed of four (2::1 ratio) fine grid (FG) cells. + + ! Shown below is the area of the CG that is in the area of the FG. The + ! first grid point of the depicted CG is the starting location of the nest + ! in the parent domain (ipos,jpos - i_parent_start and j_parent_start from + ! the namelist). + + ! For each of the CG points, the feedback loop is over each of the FG points + ! within the CG cell. For a 2::1 ratio, there are four total points (this is + ! the ijpoints loop). The feedback value to the CG is the arithmetic mean of + ! all of the FG values within each CG cell. + +! |-------------||-------------| |-------------||-------------| +! | t t || t t | | t t || t t | +! jpos+ | || | | || | +! (njde-njds)- | T || T | | T || T | +! jstag | || | | || | +! | t t || t t | | t t || t t | +! |-------------||-------------| |-------------||-------------| +! |-------------||-------------| |-------------||-------------| +! | t t || t t | | t t || t t | +! | || | | || | +! | T || T | | T || T | +! | || | | || | +! | t t || t t | | t t || t t | +! |-------------||-------------| |-------------||-------------| +! +! ... +! ... +! ... +! ... +! ... + +! |-------------||-------------| |-------------||-------------| +! jpoints = 1 | t t || t t | | t t || t t | +! | || | | || | +! | T || T | | T || T | +! | || | | || | +! jpoints = 0, | t t || t t | | t t || t t | +! nj=3 |-------------||-------------| |-------------||-------------| +! |-------------||-------------| |-------------||-------------| +! jpoints = 1 | t t || t t | | t t || t t | +! | || | | || | +! jpos | T || T | ... | T || T | +! | || | ... | || | +! jpoints = 0, | t t || t t | ... | t t || t t | +! nj=1 |-------------||-------------| |-------------||-------------| +! ^ ^ +! | | +! | | +! ipos ipos+ +! ni = 1 3 (nide-nids)/nri +! ipoints= 0 1 0 1 -istag +! + + ! For performance benefits, users can comment out the inner most loop (and cfld=0) and + ! hardcode the loop feedback. For example, it is set up to run a 2::1 ratio + ! if uncommented. This lacks generality, but is likely to gain timing benefits + ! with compilers unable to unroll inner loops that do not have parameterized sizes. + + ! The extra +1 ---------/ and the extra -1 ----\ (both for ci and cj) + ! / \ keeps the feedback out of the + ! / \ outer row/col, since that CG data + ! / \ specified the nest boundary originally + ! / \ This + ! / \ is just + ! / \ a sentence to not end a line + ! / \ with a stupid backslash + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri * nrj + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./4. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) + & +! nfld( ni , nk , nj+1) + & +! nfld( ni+1, nk , nj+1) ) + END DO + END DO + END DO + + ! U + + ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN +! |---------------| +! | | +! jpoints = 1 u u | +! | | +! U | +! | | +! jpoints = 0, u u | +! nj=3 | | +! |---------------| +! |---------------| +! | | +! jpoints = 1 u u | +! | | +! jpos U | +! | | +! jpoints = 0, u u | +! nj=1 | | +! |---------------| +! +! ^ +! | +! | +! ipos +! ni = 1 3 +! ipoints= 0 1 0 +! + + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri*nrj , nri + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./2. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni , nk , nj+1) ) + ENDDO + ENDDO + ENDDO + + ! V + + ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./2. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) ) + ENDDO + ENDDO + ENDDO + END IF + END IF + + RETURN + + END SUBROUTINE copy_fcn + +!================================== +! this is the 1pt function used in feedback. + + SUBROUTINE copy_fcnm ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + USE module_wrf_error + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone + + CALL nl_get_spec_zone( 1, spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = nfld( ni , nk , nj ) + ENDDO + ENDDO + ENDDO + + ELSE ! even refinement ratio, pick nearest neighbor on SW corner + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + ipoints = nri/2 -1 + jpoints = nrj/2 -1 + cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) + END DO + END DO + END DO + + END IF + + RETURN + + END SUBROUTINE copy_fcnm + +!================================== +! this is the 1pt function used in feedback for integers + + SUBROUTINE copy_fcni ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + USE module_wrf_error + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone + + CALL nl_get_spec_zone( 1, spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = nfld( ni , nk , nj ) + ENDDO + ENDDO + ENDDO + + ELSE ! even refinement ratio + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + ipoints = nri/2 -1 + jpoints = nrj/2 -1 + cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) + END DO + END DO + END DO + + END IF + + RETURN + + END SUBROUTINE copy_fcni + +!================================== + + SUBROUTINE bdy_interp ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + cbdy_xs, nbdy_xs, & + cbdy_xe, nbdy_xe, & + cbdy_ys, nbdy_ys, & + cbdy_ye, nbdy_ye, & + cbdy_txs, nbdy_txs, & + cbdy_txe, nbdy_txe, & + cbdy_tys, nbdy_tys, & + cbdy_tye, nbdy_tye, & + cdt, ndt & + ) ! boundary arrays + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye + REAL cdt, ndt + + ! Local + + INTEGER nijds, nijde, spec_bdy_width + + nijds = min(nids, njds) + nijde = max(nide, njde) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + + CALL bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, nbdy_xs, & + cbdy_xe, nbdy_xe, & + cbdy_ys, nbdy_ys, & + cbdy_ye, nbdy_ye, & + cbdy_txs, nbdy_txs, & + cbdy_txe, nbdy_txe, & + cbdy_tys, nbdy_tys, & + cbdy_tye, nbdy_tye, & + cdt, ndt & + ) + + RETURN + + END SUBROUTINE bdy_interp + + SUBROUTINE bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, bdy_xs, & + cbdy_xe, bdy_xe, & + cbdy_ys, bdy_ys, & + cbdy_ye, bdy_ye, & + cbdy_txs, bdy_txs, & + cbdy_txe, bdy_txe, & + cbdy_tys, bdy_tys, & + cbdy_tye, bdy_tye, & + cdt, ndt & + ) + + USE module_configure + use module_state_description + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & ! ignore + ipos, jpos, & + nri, nrj + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used + REAL :: cdt, ndt + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye + + ! Local + + REAL*8 rdt + INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff +#ifdef MM5_SINT + INTEGER nfx, ior + PARAMETER (ior=2) + INTEGER nf + REAL psca1(cims:cime,cjms:cjme,nri*nrj) + REAL psca(cims:cime,cjms:cjme,nri*nrj) + LOGICAL icmask( cims:cime, cjms:cjme ) + INTEGER i,j,k +#endif + INTEGER shw + INTEGER spec_zone + INTEGER relax_zone + INTEGER sz + INTEGER n2ci,n + INTEGER n2cj + +! statement functions for converting a nest index to coarse + n2ci(n) = (n+ipos*nri-1)/nri + n2cj(n) = (n+jpos*nrj-1)/nrj + + rdt = 1.D0/cdt + + shw = 0 + + ioff = 0 ; joff = 0 + IF ( xstag ) ioff = (nri-1)/2 + IF ( ystag ) joff = (nrj-1)/2 + + ! Iterate over the ND tile and compute the values + ! from the CD tile. + +#ifdef MM5_SINT + CALL nl_get_spec_zone( 1, spec_zone ) + CALL nl_get_relax_zone( 1, relax_zone ) + sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width) + + nfx = nri * nrj + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 ) + DO k = ckts, ckte + + DO nf = 1,nfx + DO j = cjms,cjme + nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest + DO i = cims,cime + ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest + psca1(i,j,nf) = cfld(i,k,j) + ENDDO + ENDDO + ENDDO +! hopefully less ham handed but still correct and more efficient +! sintb ignores icmask so it does not matter that icmask is not set +! +! SOUTH BDY + IF ( njts .ge. njds .and. njts .le. njds + sz + joff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag ) + ENDIF +! NORTH BDY + IF ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag ) + ENDIF +! WEST BDY + IF ( nits .ge. nids .and. nits .le. nids + sz + ioff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) + ENDIF +! EAST BDY + IF ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) + ENDIF + + DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1) + cj = jpos + (nj1-1) / nrj ! j coord of CD point + jp = mod ( nj1-1 , nrj ) ! coord of ND w/i CD point + nk = k + ck = nk + DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1) + ci = ipos + (ni1-1) / nri ! j coord of CD point + ip = mod ( ni1-1 , nri ) ! coord of ND w/i CD point + + ni = ni1-ioff + nj = nj1-joff + + IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN + CYCLE + END IF + +!bdy contains the value at t-dt. psca contains the value at t +!compute dv/dt and store in bdy_t +!afterwards store the new value of v at t into bdy + ! WEST + IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN + bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + + ! SOUTH + IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN + bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + + ! EAST + IF ( xstag ) THEN + IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN + bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ELSE + IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN + bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ENDIF + + ! NORTH + IF ( ystag ) THEN + IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN + bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ELSE + IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN + bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ENDIF + + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO +#endif + + RETURN + + END SUBROUTINE bdy_interp1 + + + + SUBROUTINE interp_fcni( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + + ! Iterate over the ND tile and compute the values + ! from the CD tile. + +!write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE interp_fcni + + SUBROUTINE interp_fcnm( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + + ! Iterate over the ND tile and compute the values + ! from the CD tile. + +!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE interp_fcnm + + SUBROUTINE interp_mask_land_field ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + clu, nlu ) + + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu + REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater + REAL :: avg , sum , dx , dy + INTEGER , PARAMETER :: max_search = 5 + CHARACTER*120 message + + ! Find out what the water value is. + + CALL nl_get_iswater(1,iswater) + + ! Right now, only mass point locations permitted. + + IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN + + ! Loop over each i,k,j in the nested domain. + + DO nj = njts, njte + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + + + + + ! + ! (ci,cj+1) (ci+1,cj+1) + ! - ------------- + ! 1-dy | | | + ! | | | + ! - | * | + ! dy | | (ni,nj) | + ! | | | + ! - ------------- + ! (ci,cj) (ci+1,cj) + ! + ! |--|--------| + ! dx 1-dx + + + ! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0 + + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) + ELSE + dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) + END IF + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) + ELSE + dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) + END IF + + ! This is a "land only" field. If this is a water point, no operations required. + + IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) ) THEN + ! noop +! nfld(ni,nk,nj) = 1.e20 + nfld(ni,nk,nj) = -1 + + ! If this is a nested land point, and the surrounding coarse values are all land points, + ! then this is a simple 4-pt interpolation. + + ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & + dy * cfld(ci ,ck,cj+1) ) + & + dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & + dy * cfld(ci+1,ck,cj+1) ) + + ! If this is a nested land point and there are NO coarse land values surrounding, + ! we temporarily punt. + + ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN +! nfld(ni,nk,nj) = -1.e20 + nfld(ni,nk,nj) = -1 + + ! If there are some water points and some land points, take an average. + + ELSE IF ( NINT(nlu(ni ,nj )) .NE. iswater ) THEN + icount = 0 + sum = 0 + IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj ) + END IF + IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj ) + END IF + IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj+1) + END IF + IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj+1) + END IF + nfld(ni,nk,nj) = sum / REAL ( icount ) + END IF + END DO + END DO + END DO + + ! Get an average of the whole domain for problem locations. + + sum = 0 + icount = 0 + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( ( nfld(ni,nk,nj) .GT. -1.e19 ) .AND. ( nfld(ni,nk,nj) .LT. 1.e19 ) ) THEN + icount = icount + 1 + sum = sum + nfld(ni,nk,nj) + END IF + END DO + END DO + END DO + CALL wrf_dm_bcast_real( sum, 1 ) + IF ( icount .GT. 0 ) THEN + avg = sum / REAL ( icount ) + + ! OK, if there were any of those island situations, we try to search a bit broader + ! of an area in the coarse grid. + + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( nfld(ni,nk,nj) .LT. -1.e19 ) THEN + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + ist = MAX (ci-max_search,cits) + ien = MIN (ci+max_search,cite,cide-1) + jst = MAX (cj-max_search,cjts) + jen = MIN (cj+max_search,cjte,cjde-1) + icount = 0 + sum = 0 + DO jj = jst,jen + DO ii = ist,ien + IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ii,nk,jj) + END IF + END DO + END DO + IF ( icount .GT. 0 ) THEN + nfld(ni,nk,nj) = sum / REAL ( icount ) + ELSE +! CALL wrf_error_fatal ( "horizontal interp error - island" ) + write(message,*) 'horizontal interp error - island, using average ', avg + CALL wrf_message ( message ) + nfld(ni,nk,nj) = avg + END IF + END IF + END DO + END DO + END DO + ENDIF + ELSE + CALL wrf_error_fatal ( "only unstaggered fields right now" ) + END IF + + END SUBROUTINE interp_mask_land_field + + SUBROUTINE interp_mask_water_field ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + clu, nlu ) + + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu + REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater + REAL :: avg , sum , dx , dy + INTEGER , PARAMETER :: max_search = 5 + + ! Find out what the water value is. + + CALL nl_get_iswater(1,iswater) + + ! Right now, only mass point locations permitted. + + IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN + + ! Loop over each i,k,j in the nested domain. + + DO nj = njts, njte + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + + + + + ! + ! (ci,cj+1) (ci+1,cj+1) + ! - ------------- + ! 1-dy | | | + ! | | | + ! - | * | + ! dy | | (ni,nj) | + ! | | | + ! - ------------- + ! (ci,cj) (ci+1,cj) + ! + ! |--|--------| + ! dx 1-dx + + + ! At ni=2, we are on the coarse grid point, so dx = 0 + + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) + ELSE + dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) + END IF + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) + ELSE + dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) + END IF + + ! This is a "water only" field. If this is a land point, no operations required. + + IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) ) THEN + ! noop +! nfld(ni,nk,nj) = 1.e20 + nfld(ni,nk,nj) = -1 + + ! If this is a nested water point, and the surrounding coarse values are all water points, + ! then this is a simple 4-pt interpolation. + + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & + dy * cfld(ci ,ck,cj+1) ) + & + dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & + dy * cfld(ci+1,ck,cj+1) ) + + ! If this is a nested water point and there are NO coarse water values surrounding, + ! we temporarily punt. + + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN +! nfld(ni,nk,nj) = -1.e20 + nfld(ni,nk,nj) = -1 + + ! If there are some land points and some water points, take an average. + + ELSE IF ( NINT(nlu(ni ,nj )) .EQ. iswater ) THEN + icount = 0 + sum = 0 + IF ( NINT(clu(ci ,cj )) .EQ. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj ) + END IF + IF ( NINT(clu(ci+1,cj )) .EQ. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj ) + END IF + IF ( NINT(clu(ci ,cj+1)) .EQ. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj+1) + END IF + IF ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj+1) + END IF + nfld(ni,nk,nj) = sum / REAL ( icount ) + END IF + END DO + END DO + END DO + + ! Get an average of the whole domain for problem locations. + + sum = 0 + icount = 0 + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( ( nfld(ni,nk,nj) .GT. -1.e19 ) .AND. ( nfld(ni,nk,nj) .LT. 1.e19 ) ) THEN + icount = icount + 1 + sum = sum + nfld(ni,nk,nj) + END IF + END DO + END DO + END DO + avg = sum / REAL ( icount ) + + + ! OK, if there were any of those lake situations, we try to search a bit broader + ! of an area in the coarse grid. + + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( nfld(ni,nk,nj) .LT. -1.e19 ) THEN + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + ist = MAX (ci-max_search,cits) + ien = MIN (ci+max_search,cite,cide-1) + jst = MAX (cj-max_search,cjts) + jen = MIN (cj+max_search,cjte,cjde-1) + icount = 0 + sum = 0 + DO jj = jst,jen + DO ii = ist,ien + IF ( NINT(clu(ii,jj)) .EQ. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ii,nk,jj) + END IF + END DO + END DO + IF ( icount .GT. 0 ) THEN + nfld(ni,nk,nj) = sum / REAL ( icount ) + ELSE +! CALL wrf_error_fatal ( "horizontal interp error - lake" ) + print *,'horizontal interp error - lake, using average ',avg + nfld(ni,nk,nj) = avg + END IF + END IF + END DO + END DO + END DO + ELSE + CALL wrf_error_fatal ( "only unstaggered fields right now" ) + END IF + + END SUBROUTINE interp_mask_water_field + + SUBROUTINE none + END SUBROUTINE none + + SUBROUTINE smoother ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in + nri, nrj & + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER :: smooth_option, feedback , spec_zone + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + + ! If there is no feedback, there can be no smoothing. + + CALL nl_get_feedback ( 1, feedback ) + IF ( feedback == 0 ) RETURN + CALL nl_get_spec_zone ( 1, spec_zone ) + + ! These are the 2d smoothers used on the fedback data. These filters + ! are run on the coarse grid data (after the nested info has been + ! fedback). Only the area of the nest in the coarse grid is filtered. + + CALL nl_get_smooth_option ( 1, smooth_option ) + + IF ( smooth_option == 0 ) THEN +! no op + ELSE IF ( smooth_option == 1 ) THEN + CALL sm121 ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + ELSE IF ( smooth_option == 2 ) THEN + CALL smdsm ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + END IF + + END SUBROUTINE smoother + + SUBROUTINE sm121 ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + + INTEGER :: i , j , k , loop + INTEGER :: istag,jstag + + INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) + + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + ! Simple 1-2-1 smoother. + + smoothing_passes : DO loop = 1 , smooth_passes + + DO k = ckts , ckte + + ! Initialize dummy cfldnew + + DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3) + DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3) + cfldnew(i,j) = cfld(i,k,j) + END DO + END DO + + ! 1-2-1 smoothing in the j direction first, + + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) ) + END DO + END DO + + ! then 1-2-1 smoothing in the i direction last + + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + cfld(i,k,j) = 0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) ) + END DO + END DO + + END DO + + END DO smoothing_passes + + END SUBROUTINE sm121 + + SUBROUTINE smdsm ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + + REAL , DIMENSION ( 2 ) :: xnu + INTEGER :: i , j , k , loop , n + INTEGER :: istag,jstag + + INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) + + xnu = (/ 0.50 , -0.52 /) + + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + ! The odd number passes of this are the "smoother", the even + ! number passes are the "de-smoother" (note the different signs on xnu). + + smoothing_passes : DO loop = 1 , smooth_passes * 2 + + n = 2 - MOD ( loop , 2 ) + + DO k = ckts , ckte + + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i,k,j+1) + cfld(i,k,j-1)) * 0.5-cfld(i,k,j)) + END DO + END DO + + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + cfld(i,k,j) = cfldnew(i,j) + END DO + END DO + + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i+1,k,j) + cfld(i-1,k,j)) * 0.5-cfld(i,k,j)) + END DO + END DO + + DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2) + DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2) + cfld(i,k,j) = cfldnew(i,j) + END DO + END DO + + END DO + + END DO smoothing_passes + + END SUBROUTINE smdsm + +!================================== +! this is used to modify a field over the nest so we can see where the nest is + + SUBROUTINE mark_domain ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + USE module_wrf_error + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 9021000. !magic number: Beverly Hills * 100. + ENDDO + ENDDO + ENDDO + + END SUBROUTINE mark_domain + diff --git a/wrfv2_fire/share/landread.c b/wrfv2_fire/share/landread.c new file mode 100644 index 00000000..33e7bb1a --- /dev/null +++ b/wrfv2_fire/share/landread.c @@ -0,0 +1,802 @@ +#ifndef CRAY +# ifdef NOUNDERSCORE +# define GET_TERRAIN get_terrain +# else +# ifdef F2CSTYLE +# define GET_TERRAIN get_terrain__ +# else +# define GET_TERRAIN get_terrain_ +# endif +# endif +#endif + +#ifdef LANDREAD_STUB +#include + +int GET_TERRAIN ( float *adx, + float *xlat, + float *xlon, + float *terrain, + int *mix, + int *mjx, + int *iyyn, + int *jxxn, + int *ipath , int * ipathlen) /* integer coded ASCII string from Funtran and len */ + +{ + fprintf(stderr, "***************************************************************\n" ) ; + fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ; + fprintf(stderr, "in WRF 2.1 . Please contact wrfhelp@ucar.edu . \n" ) ; + fprintf(stderr, "***************************************************************\n" ) ; + return(0) ; +} + +#else + +#ifdef FSEEKO_OK +# define _FILE_OFFSET_BITS 64 +#endif +#include +#include +#include +#include +#include +#include "landread.h" +#define MAXTOPOFILES 100 +#define MAXLEN 4096 + + +typedef struct +{ + /* Filenames. */ + char fn[MAXTOPOFILES][MAXLEN]; + + /* Grid spacings in km. */ + float dx[MAXTOPOFILES]; + + /* Number of entries. */ + int num; +} TsFileInfo; + +static float vmiss; + +static int numHeaderBytes; +static int globalNx; +static int globalNy; +static int tileNx; +static int tileNy; +static int extraNx; +static int extraNy; +static int numTilesX; +static int numTilesY; +static double dlat; +static double dlon; +static double lat0; +static double lon0; +static int ntiles; +static int wrapx; +static int wrapy; + +/* File information. */ +static XDR *xdrs; +static FILE *fp; + +#if 0 + int nint(const double x) +{ + if ( x > 0.0 ) { return( (int)(x + 0.5) ) ; } + return((int)(x - 0.5)); +} +#endif + +double aint(const double x) +{ + int ix = (int)(x); + return((double)(ix)); +} + +double anint(const double x) +{ + if (x > 0.0) return((double)((int)(x + 0.5))); + return((double)((int)(x - 0.5))); +} + +static double normalizeAngle(double ang) +{ + for (;;) + { + if (ang >= 360.0) + { + ang -= 360.0; + } + else if (ang < 0.0) + { + ang += 360.0; + } + else + { + break; + } + } + + return(ang); +} + +static double lonDistNowrap(double lon1, double lon2) +{ + double lon11 = normalizeAngle(lon1); + double lon22 = normalizeAngle(lon2); + if (lon22 < lon11) lon22 += 360.0; + return(fabs(lon22 - lon11)); +} + +int tsLatLonToGridpoint(const double lat, + const double lon, + double *ix, + double *iy) +{ + *ix = lonDistNowrap(lon0, lon) / dlon; + *iy = (lat - lat0) / dlat; + return(1); +} + +static int areEqual(const double v1, const double v2) +{ + if (fabs(v1-v2) < 0.001) return(1); + return(0); +} + +static int setWrapAroundFlags(void) +{ + /* Compute the end gridpoint location in x. */ + double lon1 = lon0 + dlon*(globalNx); + double lon2 = lon0 + dlon*(globalNx-1); + double lat1 = lat0 + dlat*(globalNy); + double lon0n = normalizeAngle(lon0); + double lon1n = normalizeAngle(lon1); + double lon2n = normalizeAngle(lon2); + + wrapx = 0; + if (areEqual(lon0n, lon1n)) + { + /* Here the first and last indices in x are one grid interval + apart. */ + wrapx = 1; + } + else if (areEqual(lon0n, lon2n)) + { + /* Here the first and last indices in x are coincident. */ + wrapx = 2; + } + + wrapy = 0; + if (areEqual(lat0, -90.0)) + { + /* Here the first and last indices in x are one grid interval + apart. */ + wrapy += 1; + } + if (areEqual(lat1, 90.0)) + { + /* Here the first and last indices in x are coincident. */ + wrapy += 2; + } + + return(1); +} + +static int isMissing(const float v) +{ + if (fabs(vmiss - v) < 0.1) return(1); + return(0); +} + +float tsGetValueInt(const int aix, const int aiy) +{ + float f = vmiss; + + int iy = aiy; + int ix = aix; + + /* Perform bounds checking. */ + if (iy < 0) + { + return(f); + } + else if (iy > globalNy - 1) + { + return(f); + } + + if (aix < 0) + { + if (wrapx == 1) + { + int n = -(aix - (globalNx - 1)) / globalNx; + ix += n*globalNx; + } + else if (wrapx == 2) + { + int nx = globalNx - 1; + int n = -(aix - (nx - 1)) / nx; + ix += n*nx; + } + else + { + return(f); + } + } + + if (ix > globalNx-1) + { + if (wrapx == 1) + { + int n = aix / globalNx; + ix -= n*globalNx; + } + else if (wrapx == 2) + { + int nx = globalNx - 1; + int n = aix / nx; + ix -= n*nx; + } + else + { + return(f); + } + } + + int tx = ix / tileNx; + int ty = iy / tileNy; + int tn = tx + ty*numTilesX; + int txg = ix - tx*tileNx; + int tyg = iy - ty*tileNy; + int gn = txg + tyg*tileNx; + + long long ll_gn = gn; + long long ll_numHeaderBytes = numHeaderBytes; + long long ll_tileNx = tileNx; + long long ll_tileNy = tileNy; + +#ifdef FSEEKO64_OK + /* This is used on machines that support fseeko64. Tested for in ./configure script */ + long long loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn + + ll_gn*sizeof(float); + + /* Seek to the proper location in the file and get the data value. */ + fseeko64(fp, loc, SEEK_SET); +#else +# ifdef FSEEKO_OK + /* This is used on machines that support _FILE_OFFSET_BITS=64 which makes + off_t be 64 bits, and for which fseeko can handle 64 bit offsets. This + is tested in the ./configure script */ + off_t loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn + + ll_gn*sizeof(float); + + fseeko(fp, loc, SEEK_SET); +# else + /* Note, this will not work correctly for very high resolution terrain input + because the offset is only 32 bits. */ + off_t loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn + + ll_gn*sizeof(float); + + fseek(fp, loc, SEEK_SET); +# endif +#endif + xdr_float(xdrs, (float *) &f); + + return(f); +} + +float tsGetValue(const double ix, const double iy) +{ + int i0 = (int)(floor(ix)); + int j0 = (int)(floor(iy)); + int i1 = (int)(ceil(ix)); + int j1 = (int)(ceil(iy)); + + /* Interpolate linearly to (oiloc, ojloc). */ + float v0 = tsGetValueInt(i0,j0); + float v1 = tsGetValueInt(i0,j1); + float v2 = tsGetValueInt(i1,j0); + float v3 = tsGetValueInt(i1,j1); + + if (isMissing(v0)) return(vmiss); + if (isMissing(v1)) return(vmiss); + if (isMissing(v2)) return(vmiss); + if (isMissing(v3)) return(vmiss); + + double w0 = ix - i0; + double w1 = iy - j0; + + float v4 = v2*w0 + v0*(1.0-w0); + float v5 = v3*w0 + v1*(1.0-w0); + float v6 = w1*v5 + (1.0-w1)*v4; + float val = v6; + + return(val); +} + +float tsGetValueLatLon(const double lat, const double lon) +{ + double ix, iy; + tsLatLonToGridpoint(lat,lon,&ix,&iy); + return(tsGetValue(ix,iy)); +} + +int tsCloseTileSet(void) +{ + if (xdrs) + { + xdr_destroy(xdrs); + free(xdrs); + xdrs = 0; + } + + if (fp) + { + fclose(fp); + fp = 0; + } + + return(1); +} + +int tsInitTileSet(const char *fn) +{ + vmiss = -100000000.00; + + xdrs = 0; + fp = 0; + + /* fp = (FILE *) fopen64(fn, "r"); */ + if (( fp = (FILE *) fopen(fn, "r")) == NULL ) { + fprintf(stderr,"tsInitTileSet: cannot open %s\n",fn) ; + exit(2) ; + } + xdrs = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdrs, fp, XDR_DECODE); + + numHeaderBytes = 5000; + + xdr_int(xdrs, (int *) &globalNx); + xdr_int(xdrs, (int *) &globalNy); + xdr_int(xdrs, (int *) &tileNx); + xdr_int(xdrs, (int *) &tileNy); + xdr_int(xdrs, (int *) &extraNx); + xdr_int(xdrs, (int *) &extraNy); + xdr_int(xdrs, (int *) &numTilesX); + xdr_int(xdrs, (int *) &numTilesY); + xdr_double(xdrs, (double *) &dlat); + xdr_double(xdrs, (double *) &dlon); + xdr_double(xdrs, (double *) &lat0); + xdr_double(xdrs, (double *) &lon0); + xdr_int(xdrs, (int *) &ntiles); + + setWrapAroundFlags(); + + return(1); +} + +int tsPrintTileSetInto(void) +{ + return(1); +} + +#ifdef TERRAIN_AND_LANDUSE +int get_terrain_landuse_(const float &adx, + const float *xlat, + const float *xlon, + float *terrain, + float *landuse, + const int &mix, + const int &mjx, + const int &iyyn, + const int &jxxn) +#else + +int GET_TERRAIN ( float *adx, + float *xlat, + float *xlon, + float *terrain, + int *mix, + int *mjx, + int *iyyn, + int *jxxn, + int *ipath , int * ipathlen) /* integer coded ASCII string from Funtran and len */ +#endif +{ + TsFileInfo tsfTopo; + TsFileInfo tsfOcean; + TsFileInfo tsfLU; + int i, j ; + char path[1024] ; + + tsfTopo.num = 0; + tsfOcean.num = 0; + tsfLU.num = 0; + +#if 0 + /* Read in the list of topography/land use filenames. */ + { + FILE *fp = fopen("landFilenames", "r"); + + for (;;) + { + char type[MAXLEN]; + char res[MAXLEN]; + char fn[MAXLEN]; + + if (fscanf(fp, "%s %s %s", type, res, fn) == EOF) break; + + float dx; + sscanf(res, "%f", &dx); + + if (strcmp(type, "landuse") == 0) + { + tsfLU.dx[tsfLU.num] = dx; + strcpy(tsfLU.fn[tsfLU.num], fn); + tsfLU.num++; + } + else if (strcmp(type, "topography") == 0) + { + tsfTopo.dx[tsfTopo.num] = dx; + strcpy(tsfTopo.fn[tsfTopo.num], fn); + tsfTopo.num++; + } + else if (strcmp(type, "bathymetry") == 0) + { + tsfOcean.dx[tsfOcean.num] = dx; + strcpy(tsfOcean.fn[tsfOcean.num], fn); + tsfOcean.num++; + } + } + fclose(fp); + } +#else + for (i = 0 ; i < *ipathlen ; i++ ) { + path[i] = ipath[i] ; + } + path[*ipathlen] = '\0' ; + +# if 0 + fprintf(stderr,"path: %s\n",path) ; +# endif +tsfTopo.num = 0; +tsfTopo.dx[tsfTopo.num] = 1; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 1); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 2; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 2); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 3; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 3); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 4; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 4); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 5; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 5); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 6; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 6); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 7; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 7); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 8; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 8); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 9; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 9); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 10; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 10); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 20; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 20); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 30; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 30); tsfTopo.num++ ; +tsfTopo.dx[tsfTopo.num] = 40; sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, 40); tsfTopo.num++ ; + +# if 0 + for ( i = 0 ; i < tsfTopo.num ; i++ ) { + fprintf(stderr,"%02d. %s\n",i, tsfTopo.fn[i] ) ; + } +# endif +#endif + + + /* First get the terrain from GTOPO30. */ + { + /* Use the data with the largest spacing less than the grid + spacing specified in the argument list. */ + float maxdx = 0.0; + char fn[MAXLEN]; + int first = 1; + for (i = 0; i < tsfTopo.num; i++) + { +# if 0 +fprintf(stderr,"%d %d file %f adx %f max %f\n",i,first,tsfTopo.dx[i],*adx , maxdx ) ; +# endif + if (tsfTopo.dx[i] < maxdx) continue; + if (first || tsfTopo.dx[i] < *adx) + { + first = 0; + maxdx = tsfTopo.dx[i]; + strcpy(fn, tsfTopo.fn[i]); + } + } + + if (!tsInitTileSet(fn)) + { + return(0); + } + + for ( j = 0; j < *jxxn; j++) + { + for ( i = 0; i < *iyyn; i++) + { + float lat = xlat[*mix*j + i]; + float lon = xlon[*mix*j + i]; + + double fix; + double fiy; + tsLatLonToGridpoint(lat,lon,&fix,&fiy); + float tv = tsGetValue(fix, fiy); + terrain[*mix*j + i] = tv; + } + } + + tsCloseTileSet(); + } + +#ifdef TERRAIN_AND_LANDUSE + /* Next get the terrain from TBASE. */ + { + /* Use the data with the largest spacing less than the grid + spacing specified in the argument list. */ + float maxdx = 0.0; + char fn[MAXLEN]; + int first = 1; + for ( i = 0; i < tsfOcean.num; i++) + { + if (tsfOcean.dx[i] < maxdx) continue; + if (first || tsfOcean.dx[i] < *adx) + { + first = 0; + maxdx = tsfOcean.dx[i]; + strcpy(fn, tsfOcean.fn[i]); + } + } + + if (!tsInitTileSet(fn)) + { + return(0); + } + + for ( j = 0; j < *jxxn; j++) + { + for ( i = 0; i < *iyyn; i++) + { + float lat = xlat[*mix*j + i]; + float lon = xlon[*mix*j + i]; + + double fix; + double fiy; + tsLatLonToGridpoint(lat,lon,fix,fiy); + float tv = tsGetValue(fix, fiy); + if (isMissing(terrain[*mix*j+i])) + { + if (tv < 0.0) tv = 0.0; + terrain[*mix*j + i] = tv; + } + } + } + tsCloseTileSet(); + } + + /* Next get the land use. */ + { + /* Use the data with the largest spacing less than the grid + spacing specified in the argument list. */ + float maxdx = 0.0; + char fn[MAXLEN]; + int first = 1; + for ( i = 0; i < tsfLU.num; i++) + { + if (tsfLU.dx[i] < maxdx) continue; + if (first || tsfLU.dx[i] < *adx) + { + first = 0; + maxdx = tsfLU.dx[i]; + strcpy(fn, tsfLU.fn[i]); + } + } + + if (!tsInitTileSet(fn)) + { + return(0); + } + + for ( j = 0; j < *jxxn; j++) + { + for ( i = 0; i < *iyyn; i++) + { + float lat = xlat[*mix*j + i]; + float lon = xlon[*mix*j + i]; + + double fix; + double fiy; + tsLatLonToGridpoint(lat,lon,fix,fiy); + int ix = nint(fix); + int iy = nint(fiy); + float tv = tsGetValueInt(ix, iy); + + /* Set out-of-range values to water. */ + if (tv < 0.9 || tv > 24.1) tv = 16.0; + + landuse[*mix*j + i] = tv; + } + } + tsCloseTileSet(); + } +#endif + + return(1); +} + +#ifdef TERRAIN_AND_LANDUSE +int get_bathymetry_(const float &tadx, + const float *xlat, + const float *xlon, + float *depth, + const int &mix, + const int &mjx, + const int &iyyn, + const int &jxxn, + const float &mindepth, + const float &zlimww3) +{ + /* Set grid resolution to .1 km to get highest resolution data possible. */ + float adx = 0.1; + + TsFileInfo tsfOcean; + TsFileInfo tsfLU; + + tsfOcean.num = 0; + tsfLU.num = 0; + + /* Read in the list of topography/land use filenames. */ + { + FILE *fp = fopen("landFilenames", "r"); + + for (;;) + { + char type[MAXLEN]; + char res[MAXLEN]; + char fn[MAXLEN]; + + if (fscanf(fp, "%s %s %s", type, res, fn) == EOF) break; + + float dx; + sscanf(res, "%f", &dx); + + if (strcmp(type, "landuse") == 0) + { + tsfLU.dx[tsfLU.num] = dx; + strcpy(tsfLU.fn[tsfLU.num], fn); + tsfLU.num++; + } + else if (strcmp(type, "bathymetry") == 0) + { + tsfOcean.dx[tsfOcean.num] = dx; + strcpy(tsfOcean.fn[tsfOcean.num], fn); + tsfOcean.num++; + } + } + + fclose(fp); + } + + /* Get the water depth from TBASE. */ + { + /* Use the data with highest resolution possible. */ + float maxdx = 0.0; + char fn[MAXLEN]; + int first = 1; + for (int i = 0; i < tsfOcean.num; i++) + { + if (tsfOcean.dx[i] < maxdx) continue; + if (first || tsfOcean.dx[i] < adx) + { + first = 0; + maxdx = tsfOcean.dx[i]; + strcpy(fn, tsfOcean.fn[i]); + } + } + + if (!tsInitTileSet(fn)) + { + return(0); + } + + for (int i = 0; i < mix*mjx; i++) + { + depth[i] = vmiss; + } + + for (int j = 0; j < jxxn; j++) + { + for (int i = 0; i < iyyn; i++) + { + float lat = xlat[mix*j + i]; + float lon = xlon[mix*j + i]; + + double fix; + double fiy; + tsLatLonToGridpoint(lat,lon,fix,fiy); + float tv = tsGetValue(fix, fiy); + if (isMissing(depth[mix*j+i])) + { + depth[mix*j + i] = -tv; + } + } + } + tsCloseTileSet(); + } + + /* Next get the land use. */ + { + /* Use the data with the largest spacing less than the grid + spacing specified in the argument list. */ + float maxdx = 0.0; + char fn[MAXLEN]; + int first = 1; + for (int i = 0; i < tsfLU.num; i++) + { + if (tsfLU.dx[i] < maxdx) continue; + if (first || tsfLU.dx[i] < adx) + { + first = 0; + maxdx = tsfLU.dx[i]; + strcpy(fn, tsfLU.fn[i]); + } + } + + if (!tsInitTileSet(fn)) + { + return(0); + } + + for (int j = 0; j < jxxn; j++) + { + for (int i = 0; i < iyyn; i++) + { + float lat = xlat[mix*j + i]; + float lon = xlon[mix*j + i]; + + double fix; + double fiy; + tsLatLonToGridpoint(lat,lon,fix,fiy); + int ix = nint(fix); + int iy = nint(fiy); + float tv = tsGetValueInt(ix, iy); + + /* Set out-of-range values to water. */ + if (tv < 0.9 || tv > 24.1) tv = 16.0; + + if (fabs(tv - 16.0) < 0.1) + { + /* Water. */ + if (1) + { + if (depth[mix*j + i] < mindepth) depth[mix*j + i] = mindepth; + } + else + { + if (depth[mix*j + i] < -zlimww3) + { + /* Water depth below zlimww3, so turn this point + into land. */ + depth[mix*j + i] = -0.1; + } + else if (depth[mix*j + i] < mindepth) + { + depth[mix*j + i] = mindepth; + } + } + } + else + { + /* Land. Set depth to 0.0. */ + depth[mix*j + i] = 0.0; + } + } + } + tsCloseTileSet(); + } + + return(1); +} +#endif + +#endif diff --git a/wrfv2_fire/share/landread.c.dist b/wrfv2_fire/share/landread.c.dist new file mode 100644 index 00000000..c8c2f939 --- /dev/null +++ b/wrfv2_fire/share/landread.c.dist @@ -0,0 +1,31 @@ +#ifndef CRAY +# ifdef NOUNDERSCORE +# define GET_TERRAIN get_terrain +# else +# ifdef F2CSTYLE +# define GET_TERRAIN get_terrain__ +# else +# define GET_TERRAIN get_terrain_ +# endif +# endif +#endif +#include + +int GET_TERRAIN ( float *adx, + float *xlat, + float *xlon, + float *terrain, + int *mix, + int *mjx, + int *iyyn, + int *jxxn, + int *ipath , int * ipathlen) /* integer coded ASCII string from Funtran and len */ + +{ + fprintf(stderr, "***************************************************************\n" ) ; + fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ; + fprintf(stderr, "in WRF 2.1 . Please contact wrfhelp@ucar.edu . \n" ) ; + fprintf(stderr, "***************************************************************\n" ) ; + return(0) ; +} + diff --git a/wrfv2_fire/share/landread.h b/wrfv2_fire/share/landread.h new file mode 100644 index 00000000..2cbc4da3 --- /dev/null +++ b/wrfv2_fire/share/landread.h @@ -0,0 +1,29 @@ +#ifndef LANDREAD_H +#define LANDREAD_H + +int GET_TERRAIN ( float *adx, + float *xlat, + float *xlon, + float *terrain, + int *mix, + int *mjx, + int *iyyn, + int *jxxn, + int *ipath , int * ipathlen) ; + +/* int nint(const double x); */ +double aint(const double x); +double anint(const double x); +float tsGetValue(const double aix, const double aiy); +float tsGetValueInt(const int aix, const int aiy); +float tsGetValueInterp(const double ix, const double iy); +float tsGetValueLatLon(const double lat, const double lon); +int tsCloseTileSet(void); +int tsInitTileSet(const char *fn); +int tsPrintTileSetInto(void); +int tsLatLonToGridpoint(const double lat, + const double lon, + double *ix, + double *iy); + +#endif diff --git a/wrfv2_fire/share/mediation_feedback_domain.F b/wrfv2_fire/share/mediation_feedback_domain.F new file mode 100644 index 00000000..57921a89 --- /dev/null +++ b/wrfv2_fire/share/mediation_feedback_domain.F @@ -0,0 +1,228 @@ +! +!WRF:MEDIATION_LAYER:NESTING +! +SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain), POINTER :: parent_grid , nested_grid + TYPE(domain), POINTER :: grid + INTEGER nlev, msize +#if !defined(MAC_KLUDGE) + TYPE (grid_config_rec_type) :: config_flags +#endif +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +! ---------------------------------------------------------- +! ------------------------------------------------------ +! Interface blocks +! ------------------------------------------------------ + INTERFACE +! ------------------------------------------------------ +! Interface definitions for EM CORE +! ------------------------------------------------------ +#if (EM_CORE == 1) +#if !defined(MAC_KLUDGE) +! ------------------------------------------------------ +! These routines are supplied by module_dm.F from the +! external communication package (e.g. external/RSL) +! ------------------------------------------------------ + SUBROUTINE feedback_domain_em_part1 ( grid, nested_grid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE feedback_domain_em_part1 + SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid , nested_grid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE feedback_domain_em_part2 + SUBROUTINE update_after_feedback_em ( grid & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid") +# include + END SUBROUTINE update_after_feedback_em +#endif +#endif +! ---------------------------------------------------------- +! Interface definitions for NMM (placeholder) +! ---------------------------------------------------------- +#if (NMM_CORE == 1 && NMM_NEST == 1) +! ------------------------------------------------------ +! These routines are supplied by module_dm.F from the +! external communication package (e.g. external/RSL) +! This is gopal's extension for the NMM core +! ------------------------------------------------------ + SUBROUTINE feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE feedback_domain_nmm_part1 +! + SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid , nested_grid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + + END SUBROUTINE feedback_domain_nmm_part2 +#endif +! ---------------------------------------------------------- +! Interface definitions for COAMPS (placeholder) +! ---------------------------------------------------------- +#if (COAMPS_CORE == 1 ) +#endif + END INTERFACE +! ---------------------------------------------------------- +! End of Interface blocks +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Executable code +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Feedback calls for EM CORE. +! ---------------------------------------------------------- +#if (EM_CORE == 1 && defined( DM_PARALLEL )) +#if !defined(MAC_KLUDGE) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_EM ) THEN + parent_grid%ht_coarse = parent_grid%ht + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + grid => nested_grid%intermediate_grid +# include "deref_kludge.h" + CALL feedback_domain_em_part1 ( grid, nested_grid, config_flags & +! +# include "em_actual_new_args.inc" +! + ) + grid => parent_grid +# include "deref_kludge.h" + + grid%nest_mask = 0. + CALL feedback_domain_em_part2 ( grid , nested_grid%intermediate_grid, nested_grid , config_flags & +! +# include "em_actual_new_args.inc" + + ) + WHERE ( grid%nest_pos .NE. 9021000. ) grid%ht = grid%ht_coarse + CALL update_after_feedback_em ( grid & +! +# include "em_actual_new_args.inc" +! + ) + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + ENDIF +#endif +#endif +! ------------------------------------------------------ +! End of Feedback calls for EM CORE. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Feedback calls for NMM. (Placeholder) +! ------------------------------------------------------ +#if (NMM_CORE == 1 && NMM_NEST == 1) +! ------------------------------------------------------ +! This is gopal's extension for the NMM core +! ------------------------------------------------------ + + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_NMM ) THEN + + grid => nested_grid%intermediate_grid +!dusan orig CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 3 , .FALSE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + grid => nested_grid%intermediate_grid +# include "deref_kludge.h" + CALL feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & +! +# include "nmm_actual_args.inc" +! + ) + grid => parent_grid +# include "deref_kludge.h" + +! + CALL feedback_domain_nmm_part2 ( grid , nested_grid%intermediate_grid, nested_grid , config_flags & +! +# include "nmm_actual_args.inc" +! + ) + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + ENDIF +#endif +! ------------------------------------------------------ +! End of Feedback calls for NMM. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Feedback calls for COAMPS. (Placeholder) +! ------------------------------------------------------ +#if (COAMPS_CORE == 1) +#endif +! ------------------------------------------------------ +! End of Feedback calls for COAMPS. +! ------------------------------------------------------ + RETURN +END SUBROUTINE med_feedback_domain + + diff --git a/wrfv2_fire/share/mediation_force_domain.F b/wrfv2_fire/share/mediation_force_domain.F new file mode 100644 index 00000000..5250b5a7 --- /dev/null +++ b/wrfv2_fire/share/mediation_force_domain.F @@ -0,0 +1,308 @@ +! +!WRF:MEDIATION_LAYER:NESTING +! +SUBROUTINE med_force_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain), POINTER :: parent_grid , nested_grid + TYPE(domain), POINTER :: grid + INTEGER nlev, msize +#if !defined(MAC_KLUDGE) + TYPE (grid_config_rec_type) :: config_flags +#endif +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y + +! ---------------------------------------------------------- +! ------------------------------------------------------ +! Interface blocks +! ------------------------------------------------------ + INTERFACE +! ------------------------------------------------------ +! Interface definitions for EM CORE +! ------------------------------------------------------ +#if (EM_CORE == 1) +#if !defined(MAC_KLUDGE) +! ------------------------------------------------------ +! These routines are supplied by module_dm.F from the +! external communication package (e.g. external/RSL) +! ------------------------------------------------------ + SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: ngrid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_em_part1 + + SUBROUTINE force_domain_em_part2 ( grid, nested_grid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE force_domain_em_part2 + +! ---------------------------------------------------------- +! This routine is supplied by dyn_em/couple_or_uncouple_em.F +! ---------------------------------------------------------- + SUBROUTINE couple_or_uncouple_em ( grid, config_flags , couple & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), INTENT(INOUT) :: grid + TYPE (grid_config_rec_type) :: config_flags + LOGICAL, INTENT( IN) :: couple +# include + END SUBROUTINE couple_or_uncouple_em +#endif +#endif +! ---------------------------------------------------------- +! Interface definitions for NMM (placeholder) +! ---------------------------------------------------------- +#if (NMM_CORE == 1 && NMM_NEST ==1) +!======================================================================= +! Added for the NMM core. This is gopal's doing. +!======================================================================= + + SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: ngrid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_nmm_part1 + + SUBROUTINE force_domain_nmm_part2 ( grid, nested_grid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags + +# include + END SUBROUTINE force_domain_nmm_part2 +!======================================================================= +! End of gopal's doing. +!======================================================================= +#endif +! ---------------------------------------------------------- +! Interface definitions for COAMPS (placeholder) +! ---------------------------------------------------------- +#if (COAMPS_CORE == 1) +#endif + END INTERFACE +! ---------------------------------------------------------- +! End of Interface blocks +! ---------------------------------------------------------- + +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Executable code +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Forcing calls for EM CORE. +! ---------------------------------------------------------- +#if (EM_CORE == 1 && defined( DM_PARALLEL )) +#if !defined(MAC_KLUDGE) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_EM ) THEN + + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + ! couple parent domain + grid => parent_grid + ! swich config_flags to point to parent rconfig info + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .true. & +! +# include "em_actual_new_args.inc" +! + ) + ! couple nested domain + grid => nested_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .true. & +! +# include "em_actual_new_args.inc" +! + ) + ! perform first part: transfer data from parent to intermediate domain + ! at the same resolution but on the same decomposition as the nest + ! note that this will involve communication on multiple DM procs + grid => parent_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL interp_domain_em_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & +! +# include "em_actual_new_args.inc" +! + ) + grid => nested_grid%intermediate_grid + ! perform 2nd part: run interpolation on the intermediate domain + ! and compute the values for the nest boundaries + ! note that this is all local (no communication) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL force_domain_em_part2 ( grid, nested_grid, config_flags & +! +# include "em_actual_new_args.inc" +! + ) + ! uncouple the nest + grid => nested_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .false. & +! +# include "em_actual_new_args.inc" +! + ) + ! uncouple the parent + grid => parent_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .false. & +! +# include "em_actual_new_args.inc" +! + ) + IF ( nested_grid%first_force ) THEN + nested_grid%first_force = .FALSE. + ENDIF + nested_grid%dtbc = 0. +! + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + ENDIF +#endif +#endif +! ------------------------------------------------------ +! End of Forcing calls for EM CORE. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Forcing calls for NMM. (Placeholder) +! ------------------------------------------------------ +# if (NMM_CORE == 1 && NMM_NEST == 1) +!======================================================================= +! Added for the NMM core. This is gopal's doing. +!======================================================================= + + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_NMM ) THEN + + grid => nested_grid%intermediate_grid +!dusan orig CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 3 , .FALSE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + ! couple parent domain + grid => parent_grid + ! swich config_flags to point to parent rconfig info + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +# include "deref_kludge.h" + + ! on restart do not force the nest the first time since it has already been forced + ! prior to the writing of the restart file + IF ( .NOT. ( config_flags%restart .AND. nested_grid%first_force ) ) THEN + ! couple nested domain + grid => nested_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +# include "deref_kludge.h" + ! perform first part: transfer data from parent to intermediate domain + ! at the same resolution but on the same decomposition as the nest + ! note that this will involve communication on multiple DM procs + grid => parent_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +# include "deref_kludge.h" + CALL interp_domain_nmm_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & +! +# include "nmm_actual_args.inc" +! + ) + ENDIF ! not restart and first force + + grid => nested_grid%intermediate_grid + IF ( .NOT. ( config_flags%restart .AND. nested_grid%first_force ) ) THEN + ! perform 2nd part: run interpolation on the intermediate domain + ! and compute the values for the nest boundaries + ! note that this is all local (no communication) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) +# include "deref_kludge.h" + CALL force_domain_nmm_part2 ( grid, nested_grid, config_flags & +! +# include "nmm_actual_args.inc" +! + ) + ENDIF ! not restart and first_force + + IF ( nested_grid%first_force ) THEN + nested_grid%first_force = .FALSE. + ENDIF + nested_grid%dtbc = 0. +! + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + ENDIF +!======================================================================= +! End of gopal's doing. +!======================================================================= +# endif +! ------------------------------------------------------ +! End of Forcing calls for NMM. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Forcing calls for COAMPS. (Placeholder) +! ------------------------------------------------------ +# if (COAMPS_CORE == 1) +# endif +! ------------------------------------------------------ +! End of Forcing calls for COAMPS. +! ------------------------------------------------------ + RETURN +END SUBROUTINE med_force_domain + + diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F new file mode 100644 index 00000000..b3be831e --- /dev/null +++ b/wrfv2_fire/share/mediation_integrate.F @@ -0,0 +1,2139 @@ +! +!WRF:MEDIATION_LAYER:IO +! + +SUBROUTINE med_calc_model_time ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_configure + ! Model layer + USE module_date_time + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local data + REAL :: time + +! this is now handled by with calls to time manager +! time = head_grid%dt * head_grid%total_time_steps +! CALL calc_current_date (grid%id, time) + + +END SUBROUTINE med_calc_model_time + +SUBROUTINE med_before_solve_io ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_configure + ! Model layer + USE module_utility + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: rc + + ! Note that when grid%return_after_training_io == .TRUE. this routine + ! will return after the training phase for all auxiliary I/O streams. + ! Nothing else will be done. This ugly hack is only needed for ESMF + ! coupling. grid%return_after_training_io == .FALSE. in all other cases. + IF ( .NOT. grid%return_after_training_io ) THEN + IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 0, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( HISTORY_ALARM ), rc=rc ) + ENDIF + + IF( WRFU_AlarmIsRinging( grid%alarms( INPUTOUT_ALARM ), rc=rc ) ) THEN + CALL med_filter_out ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( INPUTOUT_ALARM ), rc=rc ) + ENDIF + ENDIF + +! - AUX HISTORY OUTPUT + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST1_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 1, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST1_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST2_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 2, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST2_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST3_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 3, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST3_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST4_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 4, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST4_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST5_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 5, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST5_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST6_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 6, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST6_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST7_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 7, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST7_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST8_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 8, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST8_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST9_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 9, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST9_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST10_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 10, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST10_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST11_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 12, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST11_ALARM ), rc=rc ) + ENDIF + +! - AUX INPUT INPUT + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) ) THEN + CALL med_auxinput1_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) ) THEN + CALL med_auxinput2_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) ) THEN + CALL med_auxinput3_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) ) THEN + CALL med_auxinput4_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) + ENDIF + +! this needs to be looked at again so we can get rid of the special +! handling of AUXINPUT5 but for now... + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! add for wrf_chem emiss input +! - Get chemistry data + IF( config_flags%chem_opt > 0 ) THEN +#ifdef WRF_CHEM + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ) THEN + call wrf_debug(15,' CALL med_read_wrf_chem_emiss ') + CALL med_read_wrf_chem_emiss ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + call wrf_debug(15,' Back from CALL med_read_wrf_chem_emiss ') + + ENDIF +! end for wrf chem emiss input +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ELSE +#ifndef WRF_CHEM + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ) THEN + CALL med_auxinput5_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + ENDIF +#endif + ENDIF + + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) ) THEN + CALL med_auxinput6_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) ) THEN + CALL med_auxinput7_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) ) THEN + CALL med_auxinput8_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) ) THEN + CALL med_auxinput9_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) ) THEN + CALL med_auxinput10_in ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) ) THEN +#if ( EM_CORE == 1 ) + IF( config_flags%obs_nudge_opt .EQ. 1) THEN + CALL med_fddaobs_in ( grid , config_flags ) + ENDIF +#else + CALL med_auxinput11_in ( grid , config_flags ) +#endif + CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) + ENDIF + + IF ( .NOT. grid%return_after_training_io ) THEN +! - RESTART OUTPUT + IF( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) THEN + IF ( grid%id .EQ. 1 ) THEN + ! Only the parent initiates the restart writing. Otherwise, different + ! domains may be written out at different times and with different + ! time stamps in the file names. + CALL med_restart_out ( grid , config_flags ) + ENDIF + CALL WRFU_AlarmRingerOff( grid%alarms( RESTART_ALARM ), rc=rc ) + ENDIF + +! - Look for boundary data after writing out history and restart files + CALL med_latbound_in ( grid , config_flags ) + ELSE + CALL wrf_debug ( 1 , 'DEBUG: med_before_solve_io(): returned after training aux I/O' ) + ENDIF + + RETURN +END SUBROUTINE med_before_solve_io + +SUBROUTINE med_after_solve_io ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_timing + USE module_configure + ! Model layer + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + RETURN +END SUBROUTINE med_after_solve_io + +SUBROUTINE med_pre_nest_initial ( parent , newid , config_flags ) + ! Driver layer + USE module_domain + USE module_timing + USE module_io_domain + USE module_configure + ! Model layer + + IMPLICIT NONE + + ! Arguments + TYPE(domain) , POINTER :: parent + INTEGER, INTENT(IN) :: newid + TYPE (grid_config_rec_type) , INTENT(INOUT) :: config_flags + TYPE (grid_config_rec_type) :: nest_config_flags + + ! Local + INTEGER :: itmp, fid, ierr, icnt + CHARACTER*256 :: rstname, message, timestr + + TYPE(WRFU_Time) :: strt_time, cur_time + +#ifdef MOVE_NESTS + + CALL domain_clock_get( parent, current_timestr=timestr, start_time=strt_time, current_time=cur_time ) + CALL construct_filename2a ( rstname , config_flags%rst_inname , newid , 2 , timestr ) + + IF ( config_flags%restart .AND. cur_time .EQ. strt_time ) THEN + WRITE(message,*)'RESTART: nest, opening ',TRIM(rstname),' for reading header information only' + CALL wrf_message ( message ) + ! note that the parent pointer is not strictly correct, but nest is not allocated yet and + ! only the i/o communicator fields are used from "parent" (and those are dummies in current + ! implementation. + CALL open_r_dataset ( fid , TRIM(rstname) , parent , config_flags , "DATASET=RESTART", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , '("program wrf: error opening ",A32," for reading")') TRIM(rstname) + CALL WRF_ERROR_FATAL ( message ) + ENDIF + + ! update the values of parent_start that were read in from the namelist (nest may have moved) + CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + config_flags%i_parent_start = itmp + CALL nl_set_i_parent_start ( newid , config_flags%i_parent_start ) + ENDIF + CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + config_flags%j_parent_start = itmp + CALL nl_set_j_parent_start ( newid , config_flags%j_parent_start ) + ENDIF + + CALL close_dataset ( fid , config_flags , "DATASET=RESTART" ) + ENDIF +#endif + +END SUBROUTINE med_pre_nest_initial + + +SUBROUTINE med_nest_initial ( parent , nest , config_flags ) + ! Driver layer + USE module_domain + USE module_timing + USE module_io_domain + USE module_configure + USE module_utility + ! Model layer + + IMPLICIT NONE + + ! Arguments + TYPE(domain) , POINTER :: parent, nest + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + TYPE (grid_config_rec_type) :: nest_config_flags + +#if (EM_CORE == 1) + ! Local +#ifdef MOVE_NESTS + TYPE (WRFU_TimeInterval) :: interval, TimeSinceStart + INTEGER :: vortex_interval , n +#endif + INTEGER :: idum1 , idum2 , fid, ierr + INTEGER :: i , j, rc + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + CHARACTER * 80 :: rstname , timestr + CHARACTER * 256 :: message + INTEGER :: save_itimestep ! This is a kludge, correct fix will + ! involve integrating the time-step + ! counting into the time manager. + ! JM 20040604 + REAL, ALLOCATABLE, DIMENSION(:,:) :: save_acsnow & + ,save_acsnom & + ,save_cuppt & + ,save_rainc & + ,save_rainnc & + ,save_sfcevp & + ,save_sfcrunoff & + ,save_udrunoff + + TYPE(WRFU_Time) :: strt_time, cur_time + + INTERFACE + SUBROUTINE med_interp_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_interp_domain + + SUBROUTINE med_initialdata_input_ptr( nest , config_flags ) + USE module_domain + USE module_configure + TYPE (grid_config_rec_type), INTENT(IN) :: config_flags + TYPE(domain) , POINTER :: nest + END SUBROUTINE med_initialdata_input_ptr + + SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: nest , parent + TYPE (grid_config_rec_type), INTENT(IN) :: config_flags + END SUBROUTINE med_nest_feedback + + SUBROUTINE start_domain ( grid , allowed_to_move ) + USE module_domain + TYPE(domain) :: grid + LOGICAL, INTENT(IN) :: allowed_to_move + END SUBROUTINE start_domain + + SUBROUTINE blend_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated + REAL , DIMENSION(ims:ime,jms:jme) :: ter_input + END SUBROUTINE blend_terrain + + SUBROUTINE store_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated + REAL , DIMENSION(ims:ime,jms:jme) :: ter_input + END SUBROUTINE store_terrain + + SUBROUTINE input_terrain_rsmas ( grid , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + USE module_domain + TYPE ( domain ) :: grid + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + END SUBROUTINE input_terrain_rsmas + + END INTERFACE + + CALL domain_clock_get( parent, start_time=strt_time, current_time=cur_time ) + + IF ( .not. ( config_flags%restart .AND. strt_time .EQ. cur_time ) ) THEN + nest%first_force = .true. + +! initialize nest with interpolated data from the parent + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + +#ifdef MOVE_NESTS + parent%nest_pos = parent%ht + where ( parent%nest_pos .gt. 0. ) parent%nest_pos = parent%nest_pos + 500. ! make a cliff +#endif + + CALL med_interp_domain( parent, nest ) + +! De-reference dimension information stored in the grid data structure. + CALL get_ijk_from_grid ( nest , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + +! initialize some other constants (and 1d arrays in z) + CALL init_domain_constants ( parent, nest ) + +! get the nest config flags + CALL model_to_grid_config_rec ( nest%id , model_config_rec , nest_config_flags ) + + IF ( nest_config_flags%input_from_file .OR. nest_config_flags%input_from_hires ) THEN + + WRITE(message,FMT='(A,I2,A)') '*** Initializing nest domain #',nest%id,& + ' from an input file. ***' + CALL wrf_debug ( 0 , message ) + +! store horizontally interpolated terrain in temp location + CALL store_terrain ( nest%ht_fine , nest%ht , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL store_terrain ( nest%em_mub_fine , nest%em_mub , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL store_terrain ( nest%em_phb_fine , nest%em_phb , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + IF ( nest_config_flags%input_from_file ) THEN +! read input from dataset + CALL med_initialdata_input_ptr( nest , nest_config_flags ) + ELSE IF ( nest_config_flags%input_from_hires ) THEN +! read in high res topography + CALL input_terrain_rsmas ( nest, & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + ENDIF + +! blend parent and nest fields: terrain, mub, and phb. THe mub and phb are used in start_domain. + CALL blend_terrain ( nest%ht_fine , nest%ht , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL blend_terrain ( nest%em_mub_fine , nest%em_mub , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL blend_terrain ( nest%em_phb_fine , nest%em_phb , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + ELSE + WRITE(message,FMT='(A,I2,A,I2,A)') '*** Initializing nest domain #',nest%id,& + ' by horizontally interpolating parent domain #' ,parent%id, & + '. ***' + CALL wrf_debug ( 0 , message ) + END IF + + +! feedback, mostly for this new terrain, but it is the safe thing to do + parent%ht_coarse = parent%ht + + CALL med_nest_feedback ( parent , nest , config_flags ) + +! set some other initial fields, fill out halos, base fields; re-do parent due +! to new terrain elevation from feedback + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + CALL start_domain ( nest , .TRUE. ) +! kludge: 20040604 + CALL get_ijk_from_grid ( parent , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ALLOCATE( save_acsnow(ims:ime,jms:jme) ) + ALLOCATE( save_acsnom(ims:ime,jms:jme) ) + ALLOCATE( save_cuppt(ims:ime,jms:jme) ) + ALLOCATE( save_rainc(ims:ime,jms:jme) ) + ALLOCATE( save_rainnc(ims:ime,jms:jme) ) + ALLOCATE( save_sfcevp(ims:ime,jms:jme) ) + ALLOCATE( save_sfcrunoff(ims:ime,jms:jme) ) + ALLOCATE( save_udrunoff(ims:ime,jms:jme) ) + save_acsnow = parent%acsnow + save_acsnom = parent%acsnom + save_cuppt = parent%cuppt + save_rainc = parent%rainc + save_rainnc = parent%rainnc + save_sfcevp = parent%sfcevp + save_sfcrunoff = parent%sfcrunoff + save_udrunoff = parent%udrunoff + save_itimestep = parent%itimestep + parent%imask_nostag = 1 + parent%imask_xstag = 1 + parent%imask_ystag = 1 + parent%imask_xystag = 1 + + CALL start_domain ( parent , .TRUE. ) + + parent%acsnow = save_acsnow + parent%acsnom = save_acsnom + parent%cuppt = save_cuppt + parent%rainc = save_rainc + parent%rainnc = save_rainnc + parent%sfcevp = save_sfcevp + parent%sfcrunoff = save_sfcrunoff + parent%udrunoff = save_udrunoff + parent%itimestep = save_itimestep + DEALLOCATE( save_acsnow ) + DEALLOCATE( save_acsnom ) + DEALLOCATE( save_cuppt ) + DEALLOCATE( save_rainc ) + DEALLOCATE( save_rainnc ) + DEALLOCATE( save_sfcevp ) + DEALLOCATE( save_sfcrunoff ) + DEALLOCATE( save_udrunoff ) +! end of kludge: 20040604 + + + ELSE ! restart + + CALL domain_clock_get( nest, current_timestr=timestr ) + CALL construct_filename2a ( rstname , config_flags%rst_inname , nest%id , 2 , timestr ) + + WRITE(message,*)'RESTART: nest, opening ',TRIM(rstname),' for reading' + CALL wrf_message ( message ) + CALL model_to_grid_config_rec ( nest%id , model_config_rec , nest_config_flags ) + CALL open_r_dataset ( fid , TRIM(rstname) , nest , nest_config_flags , "DATASET=RESTART", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , '("program wrf: error opening ",A32," for reading")') TRIM(rstname) + CALL WRF_ERROR_FATAL ( message ) + ENDIF + CALL input_restart ( fid, nest , nest_config_flags , ierr ) + CALL close_dataset ( fid , nest_config_flags , "DATASET=RESTART" ) + + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + CALL start_domain ( nest , .TRUE. ) +#ifndef MOVE_NESTS +! this doesn't need to be done for moving nests, since ht_coarse is part of the restart + parent%ht_coarse = parent%ht +#else +# if 1 +! In case of a restart, assume that the movement has already occurred in the previous +! run and turn off the alarm for the starting time. We must impose a requirement that the +! run be restarted on-interval. Test for that and print a warning if it isn't. +! Note, simulation_start, etc. should be available as metadata in the restart file, and +! these will have gotten, set, and retrievable as rconfig data been set in share/input_wrf.F +! using the nl_get routines below. JM 20060314 + + CALL nl_get_vortex_interval ( nest%id , vortex_interval ) + CALL WRFU_TimeIntervalSet( interval, M=vortex_interval, rc=rc ) + + CALL domain_clock_get( nest, timeSinceSimulationStart=TimeSinceStart ) + n = WRFU_TimeIntervalDIVQuot( TimeSinceStart , interval ) + IF ( ( interval * n ) .NE. TimeSinceStart ) THEN + CALL wrf_message('WARNING: Restart is not on a vortex_interval time boundary.') + CALL wrf_message('The code will work but results will not agree exactly with a ') + CALL wrf_message('a run that was done straight-through, without a restart.') + ENDIF +!! In case of a restart, assume that the movement has already occurred in the previous +!! run and turn off the alarm for the starting time. We must impose a requirement that the +!! run be restarted on-interval. Test for that and print a warning if it isn't. +!! Note, simulation_start, etc. should be available as metadata in the restart file, and +!! these will have gotten, set, and retrievable as rconfig data been set in share/input_wrf.F +!! using the nl_get routines below. JM 20060314 +! CALL WRFU_AlarmRingerOff( nest%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + +# else +! this code, currently commented out, is an attempt to have the +! vortex centering interval be set according to simulation start +! time (rather than run start time) in case of a restart. But +! there are other problems (the WRF clock is currently using +! run-start as it's start time) so the alarm still would not fire +! right if the model were started off-interval. Leave it here and +! enable when the clock is changed to use sim-start for start time. +! JM 20060314 + CALL nl_get_vortex_interval ( nest%id , vortex_interval ) + CALL WRFU_TimeIntervalSet( interval, M=vortex_interval, rc=rc ) + + CALL domain_clock_get( nest, timeSinceSimulationStart=TimeSinceStart ) + + CALL domain_alarm_create( nest, COMPUTE_VORTEX_CENTER_ALARM, interval ) + CALL WRFU_AlarmEnable( nest%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + n = WRFU_TimeIntervalDIVQuot( TimeSinceStart , interval ) + IF ( ( interval * n ) .EQ. TimeSinceStart ) THEN + CALL WRFU_AlarmRingerOn( nest%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + ELSE + CALL WRFU_AlarmRingerOff( nest%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + ENDIF +# endif +#endif + + ENDIF + +#endif + +#if (NMM_CORE == 1 && NMM_NEST == 1) +!=================================================================================== +! Added for the NMM core. This is gopal's doing. +!=================================================================================== + ! Local + INTEGER :: i,j,k,idum1 , idum2 , fid, ierr + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE ! gopal + INTEGER :: IMS,IME,JMS,JME,KMS,KME + INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE + + INTERFACE + + SUBROUTINE med_nest_egrid_configure ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_nest_egrid_configure + + SUBROUTINE med_construct_egrid_weights ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_construct_egrid_weights + + SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, & + PINT,T,Q,CWM, & + FIS,QSH,PD,PDTOP,PTOP, & + ETA1,ETA2, & + DETA1,DETA2, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) +! + + USE MODULE_MODEL_CONSTANTS + IMPLICIT NONE + INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE + INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME + INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE + REAL, INTENT(IN ) :: PDTOP,PTOP + REAL, DIMENSION(KMS:KME), INTENT(IN) :: ETA1,ETA2,DETA1,DETA2 + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,QSH + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN) :: PINT,T,Q,CWM + REAL, DIMENSION(KMS:KME) , INTENT(OUT):: PSTD + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(OUT):: Z3d,Q3d,T3d + + END SUBROUTINE BASE_STATE_PARENT + + SUBROUTINE NEST_TERRAIN ( nest, config_flags ) + USE module_domain + TYPE(domain) , POINTER :: nest + TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags + END SUBROUTINE NEST_TERRAIN + + SUBROUTINE med_interp_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_interp_domain + + SUBROUTINE med_init_domain_constants_nmm ( parent, nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_init_domain_constants_nmm + + SUBROUTINE start_domain ( grid , allowed_to_move ) + USE module_domain + TYPE(domain) :: grid + LOGICAL, INTENT(IN) :: allowed_to_move + END SUBROUTINE start_domain + + END INTERFACE + +!---------------------------------------------------------------------------- +! initialize nested domain configurations including setting up wbd,sbd, etc +!---------------------------------------------------------------------------- + + CALL med_nest_egrid_configure ( parent , nest ) + +!------------------------------------------------------------------------- +! initialize lat-lons and determine weights +!------------------------------------------------------------------------- + + CALL med_construct_egrid_weights ( parent, nest ) +! +! +! De-reference dimension information stored in the grid data structure. +! +! From the hybrid, construct the GPMs on isobaric surfaces and then interpolate those +! values on to the nested domain. 23 standard prssure levels are assumed here. For +! levels below ground, lapse rate atmosphere is assumed before the use of vertical +! spline interpolation +! + + + IDS = parent%sd31 + IDE = parent%ed31 + KDS = parent%sd32 + KDE = parent%ed32 + JDS = parent%sd33 + JDE = parent%ed33 + + IMS = parent%sm31 + IME = parent%em31 + KMS = parent%sm32 + KME = parent%em32 + JMS = parent%sm33 + JME = parent%em33 + + ITS = parent%sp31 + ITE = parent%ep31 + KTS = parent%sp32 + KTE = parent%ep32 + JTS = parent%sp33 + JTE = parent%ep33 + + CALL BASE_STATE_PARENT ( parent%nmm_Z3d,parent%nmm_Q3d,parent%nmm_T3d,parent%nmm_PSTD, & + parent%nmm_PINT,parent%nmm_T,parent%nmm_Q,parent%nmm_CWM, & + parent%nmm_FIS,parent%nmm_QSH,parent%nmm_PD,parent%nmm_pdtop,parent%nmm_pt, & + parent%nmm_ETA1,parent%nmm_ETA2, & + parent%nmm_DETA1,parent%nmm_DETA2, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + +! +! Set new terrain. Since some terrain adjustment is done within the interpolation calls +! at the next step, the new terrain over the nested domain has to be called here. +! + IDS = nest%sd31 + IDE = nest%ed31 + KDS = nest%sd32 + KDE = nest%ed32 + JDS = nest%sd33 + JDE = nest%ed33 + + IMS = nest%sm31 + IME = nest%em31 + KMS = nest%sm32 + KME = nest%em32 + JMS = nest%sm33 + JME = nest%em33 + + ITS = nest%sp31 + ITE = nest%ep31 + KTS = nest%sp32 + KTE = nest%ep32 + JTS = nest%sp33 + JTE = nest%ep33 + + + CALL NEST_TERRAIN ( nest, config_flags ) + +! Initialize some more constants required especially for terrain adjustment processes + + nest%nmm_PSTD=parent%nmm_PSTD + nest%nmm_KZMAX=KME + parent%nmm_KZMAX=KME ! just for safety + + DO J = JTS, MIN(JTE,JDE-1) + DO I = ITS, MIN(ITE,IDE-1) + nest%nmm_fis(I,J)=nest%nmm_hres_fis(I,J) + ENDDO + ENDDO + +!-------------------------------------------------------------------------- +! interpolation call +!-------------------------------------------------------------------------- + +! initialize nest with interpolated data from the parent + + nest%imask_nostag = 0 + nest%imask_xstag = 0 + nest%imask_ystag = 0 + nest%imask_xystag = 0 + + CALL med_interp_domain( parent, nest ) + +!------------------------------------------------------------------------------ +! set up constants (module_initialize_real.F for nested nmm domain) +!----------------------------------------------------------------------------- + + CALL med_init_domain_constants_nmm ( parent, nest ) + +!-------------------------------------------------------------------------------------- +! set some other initial fields, fill out halos, etc. +!-------------------------------------------------------------------------------------- + + CALL start_domain ( nest, .TRUE.) + +!=================================================================================== +! Added for the NMM core. End of gopal's doing. +!=================================================================================== +#endif + RETURN +END SUBROUTINE med_nest_initial + +SUBROUTINE init_domain_constants ( parent , nest ) + USE module_domain + IMPLICIT NONE + TYPE(domain) :: parent , nest +#if (EM_CORE == 1) + CALL init_domain_constants_em ( parent, nest ) +#endif +END SUBROUTINE init_domain_constants + + +SUBROUTINE med_nest_force ( parent , nest ) + ! Driver layer + USE module_domain + USE module_timing + USE module_configure + ! Model layer + ! External + USE module_utility + + IMPLICIT NONE + + ! Arguments + TYPE(domain) , POINTER :: parent, nest + ! Local + INTEGER :: idum1 , idum2 , fid, rc + +#if (NMM_CORE == 1 && NMM_NEST == 1) + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE ! gopal + INTEGER :: IMS,IME,JMS,JME,KMS,KME + INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE +#endif + + INTERFACE + SUBROUTINE med_force_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_force_domain + SUBROUTINE med_interp_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_interp_domain +#if (NMM_CORE == 1 && NMM_NEST == 1) +!=================================================================================== +! Added for the NMM core. This is gopal's doing. +!=================================================================================== + + SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, & + PINT,T,Q,CWM, & + FIS,QSH,PD,PDTOP,PTOP, & + ETA1,ETA2, & + DETA1,DETA2, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) +! + + USE MODULE_MODEL_CONSTANTS + IMPLICIT NONE + INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE + INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME + INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE + REAL, INTENT(IN ) :: PDTOP,PTOP + REAL, DIMENSION(KMS:KME), INTENT(IN) :: ETA1,ETA2,DETA1,DETA2 + REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: FIS,PD,QSH + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN) :: PINT,T,Q,CWM + REAL, DIMENSION(KMS:KME) , INTENT(OUT):: PSTD + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(OUT):: Z3d,Q3d,T3d + + END SUBROUTINE BASE_STATE_PARENT + +#endif + END INTERFACE + +#if (NMM_CORE == 1 && NMM_NEST == 1) + +! De-reference dimension information stored in the grid data structure. + + IDS = parent%sd31 + IDE = parent%ed31 + KDS = parent%sd32 + KDE = parent%ed32 + JDS = parent%sd33 + JDE = parent%ed33 + + IMS = parent%sm31 + IME = parent%em31 + KMS = parent%sm32 + KME = parent%em32 + JMS = parent%sm33 + JME = parent%em33 + + ITS = parent%sp31 + ITE = parent%ep31 + KTS = parent%sp32 + KTE = parent%ep32 + JTS = parent%sp33 + JTE = parent%ep33 + + + CALL BASE_STATE_PARENT ( parent%nmm_Z3d,parent%nmm_Q3d,parent%nmm_T3d,parent%nmm_PSTD, & + parent%nmm_PINT,parent%nmm_T,parent%nmm_Q,parent%nmm_CWM, & + parent%nmm_FIS,parent%nmm_QSH,parent%nmm_PD,parent%nmm_pdtop,parent%nmm_pt, & + parent%nmm_ETA1,parent%nmm_ETA2, & + parent%nmm_DETA1,parent%nmm_DETA2, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + +#endif + + IF ( .NOT. WRFU_ClockIsStopTime(nest%domain_clock ,rc=rc) ) THEN +! initialize nest with interpolated data from the parent + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + CALL med_force_domain( parent, nest ) + ENDIF + +! might also have calls here to do input from a file into the nest + + RETURN +END SUBROUTINE med_nest_force + +SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) + ! Driver layer + USE module_domain + USE module_timing + USE module_configure + ! Model layer + ! External + USE module_utility + IMPLICIT NONE + + + ! Arguments + TYPE(domain) , POINTER :: parent, nest + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: idum1 , idum2 , fid, rc + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + INTEGER i,j + + INTERFACE + SUBROUTINE med_feedback_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_feedback_domain + END INTERFACE + +! feedback nest to the parent + IF ( .NOT. WRFU_ClockIsStopTime(nest%domain_clock ,rc=rc) .AND. & + config_flags%feedback .NE. 0 ) THEN + CALL med_feedback_domain( parent, nest ) +#ifdef MOVE_NESTS + CALL get_ijk_from_grid ( parent , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) +! gopal's change- added ifdef +#if ( EM_CORE == 1 ) + DO j = jps, MIN(jpe,jde-1) + DO i = ips, MIN(ipe,ide-1) + IF ( parent%nest_pos(i,j) .EQ. 9021000. ) THEN + parent%nest_pos(i,j) = parent%ht(i,j)*1.5 + 1000. + ELSE IF ( parent%ht(i,j) .NE. 0. ) THEN + parent%nest_pos(i,j) = parent%ht(i,j) + 500. + ELSE + parent%nest_pos(i,j) = 0. + ENDIF + ENDDO + ENDDO +#endif +#endif + END IF + + RETURN +END SUBROUTINE med_nest_feedback + +SUBROUTINE med_last_solve_io ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_configure + ! Model layer + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: rc + + IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 0 , config_flags ) + ENDIF + + IF( WRFU_AlarmIsRinging( grid%alarms( INPUTOUT_ALARM ), rc=rc ) ) THEN + CALL med_filter_out ( grid , config_flags ) + ENDIF + + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST1_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 1 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST2_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 2 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST3_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 3 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST4_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 4 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST5_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 5 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST6_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 6 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST7_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 7 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST8_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 8 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST9_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 9 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST10_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 10 , config_flags ) + ENDIF + IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST11_ALARM ), rc=rc ) ) THEN + CALL med_hist_out ( grid , 11 , config_flags ) + ENDIF + +! - RESTART OUTPUT + IF( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) THEN + IF ( grid%id .EQ. 1 ) THEN + CALL med_restart_out ( grid , config_flags ) + ENDIF + ENDIF + + RETURN +END SUBROUTINE med_last_solve_io + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +RECURSIVE SUBROUTINE med_restart_out ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + USE module_configure + ! Model layer + USE module_bc_time_utilities + USE module_utility + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname + INTEGER :: fid , rid, kid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc + CHARACTER*80 :: timestr + TYPE (grid_config_rec_type) :: kid_config_flags + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + ! write out this domains restart file first + + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( rstname , config_flags%rst_outname , grid%id , 2 , timestr ) + + WRITE( message , '("med_restart_out: opening ",A," for writing")' ) TRIM ( rstname ) + CALL wrf_debug( 1 , message ) + CALL open_w_dataset ( rid, TRIM(rstname), grid , & + config_flags , output_restart , "DATASET=RESTART", ierr ) + + IF ( ierr .NE. 0 ) THEN + CALL WRF_message( message ) + ENDIF + CALL output_restart ( rid, grid , config_flags , ierr ) + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Writing restart for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + END IF + CALL close_dataset ( rid , config_flags , "DATASET=RESTART" ) + + ! call recursively for children, (if any) + DO kid = 1, max_nests + IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN + CALL model_to_grid_config_rec ( grid%nests(kid)%ptr%id , model_config_rec , kid_config_flags ) + CALL med_restart_out ( grid%nests(kid)%ptr , kid_config_flags ) + ENDIF + ENDDO + + RETURN +END SUBROUTINE med_restart_out + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE med_hist_out ( grid , stream, config_flags ) + ! Driver layer + USE module_domain + USE module_timing + USE module_io_domain + USE module_configure + USE module_bc_time_utilities + USE module_utility + + IMPLICIT NONE + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + INTEGER , INTENT(IN) :: stream + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: fname, n1, n2 + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc + CHARACTER*80 :: timestr + TYPE(WRFU_Time) :: ST,CT + INTEGER :: n + LOGICAL :: adjust + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + IF ( stream .LT. 0 .OR. stream .GT. 11 ) THEN + WRITE(message,*)'med_hist_out: invalid history stream ',stream + CALL wrf_error_fatal( message ) + ENDIF + CALL nl_get_adjust_output_times( grid%id, adjust ) + CALL domain_clock_get( grid, current_time=CT, start_time=ST, current_timestr=timestr ) + + SELECT CASE( stream ) + CASE ( 0 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( HISTORY_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%history_outname , grid%id , 2 , timestr ) + CASE ( 1 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST1_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist1_outname , grid%id , 2 , timestr ) + CASE ( 2 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST2_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist2_outname , grid%id , 2 , timestr ) + CASE ( 3 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST3_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist3_outname , grid%id , 2 , timestr ) + CASE ( 4 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST4_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist4_outname , grid%id , 2 , timestr ) + CASE ( 5 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST5_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist5_outname , grid%id , 2 , timestr ) + CASE ( 6 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST6_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist6_outname , grid%id , 2 , timestr ) + CASE ( 7 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST7_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist7_outname , grid%id , 2 , timestr ) + CASE ( 8 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST8_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist8_outname , grid%id , 2 , timestr ) + CASE ( 9 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST9_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist9_outname , grid%id , 2 , timestr ) + CASE ( 10 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST10_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist10_outname , grid%id , 2 , timestr ) + CASE ( 11 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST11_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( fname , config_flags%auxhist11_outname , grid%id , 2 , timestr ) + END SELECT + + IF ( ( stream .eq. 0 .and. grid%oid .eq. 0 ) & + .or. ( stream .eq. 1 .and. grid%auxhist1_oid .eq. 0 ) & + .or. ( stream .eq. 2 .and. grid%auxhist2_oid .eq. 0 ) & + .or. ( stream .eq. 3 .and. grid%auxhist3_oid .eq. 0 ) & + .or. ( stream .eq. 4 .and. grid%auxhist4_oid .eq. 0 ) & + .or. ( stream .eq. 5 .and. grid%auxhist5_oid .eq. 0 ) & + .or. ( stream .eq. 6 .and. grid%auxhist6_oid .eq. 0 ) & + .or. ( stream .eq. 7 .and. grid%auxhist7_oid .eq. 0 ) & + .or. ( stream .eq. 8 .and. grid%auxhist8_oid .eq. 0 ) & + .or. ( stream .eq. 9 .and. grid%auxhist9_oid .eq. 0 ) & + .or. ( stream .eq. 10 .and. grid%auxhist10_oid .eq. 0 ) & + .or. ( stream .eq. 11 .and. grid%auxhist11_oid .eq. 0 ) & + ) THEN + + IF ( stream .EQ. 10 ) THEN + WRITE(n2,'("DATASET=AUXHIST10")') + ELSE IF ( stream .EQ. 11 ) THEN + WRITE(n2,'("DATASET=AUXHIST11")') + ELSE + WRITE(n2,'("DATASET=AUXHIST",I1)')stream ! may be overwritten, below, if stream is 0 + ENDIF + WRITE ( message , '("med_hist_out : opening ",A," for writing. ")') TRIM ( fname ) + CALL wrf_debug( 1, message ) + SELECT CASE( stream ) + CASE ( 0 ) + CALL open_w_dataset ( grid%oid, TRIM(fname), grid , & + config_flags , output_history , 'DATASET=HISTORY' , ierr ) + CASE ( 1 ) + CALL open_w_dataset ( grid%auxhist1_oid, TRIM(fname), grid , & + config_flags , output_aux_hist1 , n2, ierr ) + CASE ( 2 ) + CALL open_w_dataset ( grid%auxhist2_oid, TRIM(fname), grid , & + config_flags , output_aux_hist2 , n2, ierr ) + CASE ( 3 ) + CALL open_w_dataset ( grid%auxhist3_oid, TRIM(fname), grid , & + config_flags , output_aux_hist3 , n2, ierr ) + CASE ( 4 ) + CALL open_w_dataset ( grid%auxhist4_oid, TRIM(fname), grid , & + config_flags , output_aux_hist4 , n2, ierr ) + CASE ( 5 ) + CALL open_w_dataset ( grid%auxhist5_oid, TRIM(fname), grid , & + config_flags , output_aux_hist5 , n2, ierr ) + CASE ( 6 ) + CALL open_w_dataset ( grid%auxhist6_oid, TRIM(fname), grid , & + config_flags , output_aux_hist6 , n2, ierr ) + CASE ( 7 ) + CALL open_w_dataset ( grid%auxhist7_oid, TRIM(fname), grid , & + config_flags , output_aux_hist7 , n2, ierr ) + CASE ( 8 ) + CALL open_w_dataset ( grid%auxhist8_oid, TRIM(fname), grid , & + config_flags , output_aux_hist8 , n2, ierr ) + CASE ( 9 ) + CALL open_w_dataset ( grid%auxhist9_oid, TRIM(fname), grid , & + config_flags , output_aux_hist9 , n2, ierr ) + CASE ( 10 ) + CALL open_w_dataset ( grid%auxhist10_oid, TRIM(fname), grid , & + config_flags , output_aux_hist10 , n2, ierr ) + CASE ( 11 ) + CALL open_w_dataset ( grid%auxhist11_oid, TRIM(fname), grid , & + config_flags , output_aux_hist11 , n2, ierr ) + END SELECT + IF ( ierr .NE. 0 ) THEN + WRITE ( message , '("med_hist_out : error opening ",A," for writing. ",I3)') TRIM ( fname ), ierr + CALL wrf_message( message ) + ENDIF + END IF + + ! early return after training + IF ( .NOT. grid%return_after_training_io ) THEN + SELECT CASE( stream ) + CASE ( 0 ) + CALL output_history ( grid%oid, grid , config_flags , ierr ) + CASE ( 1 ) + CALL output_aux_hist1 ( grid%auxhist1_oid, grid , config_flags , ierr ) + CASE ( 2 ) + CALL output_aux_hist2 ( grid%auxhist2_oid, grid , config_flags , ierr ) + CASE ( 3 ) + CALL output_aux_hist3 ( grid%auxhist3_oid, grid , config_flags , ierr ) + CASE ( 4 ) + CALL output_aux_hist4 ( grid%auxhist4_oid, grid , config_flags , ierr ) + CASE ( 5 ) + CALL output_aux_hist5 ( grid%auxhist5_oid, grid , config_flags , ierr ) + CASE ( 6 ) + CALL output_aux_hist6 ( grid%auxhist6_oid, grid , config_flags , ierr ) + CASE ( 7 ) + CALL output_aux_hist7 ( grid%auxhist7_oid, grid , config_flags , ierr ) + CASE ( 8 ) + CALL output_aux_hist8 ( grid%auxhist8_oid, grid , config_flags , ierr ) + CASE ( 9 ) + CALL output_aux_hist9 ( grid%auxhist9_oid, grid , config_flags , ierr ) + CASE ( 10 ) + CALL output_aux_hist10 ( grid%auxhist10_oid, grid , config_flags , ierr ) + CASE ( 11 ) + CALL output_aux_hist11 ( grid%auxhist11_oid, grid , config_flags , ierr ) + END SELECT + + grid%nframes(stream) = grid%nframes(stream) + 1 + + SELECT CASE( stream ) + CASE ( 0 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_outfile ) THEN + CALL close_dataset ( grid%oid , config_flags , "DATASET=HISTORY" ) + grid%oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 1 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist1 ) THEN + CALL close_dataset ( grid%auxhist1_oid , config_flags , n2 ) + grid%auxhist1_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 2 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist2 ) THEN + CALL close_dataset ( grid%auxhist2_oid , config_flags , n2 ) + grid%auxhist2_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 3 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist3 ) THEN + CALL close_dataset ( grid%auxhist3_oid , config_flags , n2 ) + grid%auxhist3_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 4 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist4 ) THEN + CALL close_dataset ( grid%auxhist4_oid , config_flags , n2 ) + grid%auxhist4_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 5 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist5 ) THEN + CALL close_dataset ( grid%auxhist5_oid , config_flags , n2 ) + grid%auxhist5_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 6 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist6 ) THEN + CALL close_dataset ( grid%auxhist6_oid , config_flags , n2 ) + grid%auxhist6_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 7 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist7 ) THEN + CALL close_dataset ( grid%auxhist7_oid , config_flags , n2 ) + grid%auxhist7_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 8 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist8 ) THEN + CALL close_dataset ( grid%auxhist8_oid , config_flags , n2 ) + grid%auxhist8_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 9 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist9 ) THEN + CALL close_dataset ( grid%auxhist9_oid , config_flags , n2 ) + grid%auxhist9_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 10 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist10 ) THEN + CALL close_dataset ( grid%auxhist10_oid , config_flags , n2 ) + grid%auxhist10_oid = 0 + grid%nframes(stream) = 0 + ENDIF + CASE ( 11 ) + IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist11 ) THEN + CALL close_dataset ( grid%auxhist11_oid , config_flags , n2 ) + grid%auxhist11_oid = 0 + grid%nframes(stream) = 0 + ENDIF + END SELECT + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Writing ",A30," for domain ",I8)' )TRIM(fname),grid%id + CALL end_timing ( TRIM(message) ) + END IF + ELSE + CALL wrf_debug( 1, 'DEBUG: med_hist_out() returned after training' ) + ENDIF + + RETURN +END SUBROUTINE med_hist_out + +SUBROUTINE med_auxinput1_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 1 , config_flags ) + RETURN +END SUBROUTINE med_auxinput1_in + +SUBROUTINE med_auxinput2_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 2 , config_flags ) + RETURN +END SUBROUTINE med_auxinput2_in + +SUBROUTINE med_auxinput3_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 3 , config_flags ) + RETURN +END SUBROUTINE med_auxinput3_in + +SUBROUTINE med_auxinput4_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 4 , config_flags ) + RETURN +END SUBROUTINE med_auxinput4_in + +SUBROUTINE med_auxinput5_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 5 , config_flags ) + RETURN +END SUBROUTINE med_auxinput5_in + +SUBROUTINE med_auxinput6_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 6 , config_flags ) + RETURN +END SUBROUTINE med_auxinput6_in + +SUBROUTINE med_auxinput7_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 7 , config_flags ) + RETURN +END SUBROUTINE med_auxinput7_in + +SUBROUTINE med_auxinput8_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 8 , config_flags ) + RETURN +END SUBROUTINE med_auxinput8_in + +SUBROUTINE med_auxinput9_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 9 , config_flags ) + RETURN +END SUBROUTINE med_auxinput9_in + +SUBROUTINE med_auxinput10_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 10 , config_flags ) + RETURN +END SUBROUTINE med_auxinput10_in + +SUBROUTINE med_auxinput11_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL med_auxinput_in( grid , 11 , config_flags ) + RETURN +END SUBROUTINE med_auxinput11_in + +SUBROUTINE med_fddaobs_in ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + CALL wrf_fddaobs_in( grid, config_flags ) + RETURN +END SUBROUTINE med_fddaobs_in + +SUBROUTINE med_auxinput_in ( grid , stream, config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + ! Model layer + USE module_configure + USE module_bc_time_utilities + USE module_utility + + IMPLICIT NONE + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + INTEGER , INTENT(IN) :: stream + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname, auxname, n1, n2 + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc + CHARACTER*80 :: timestr + TYPE(WRFU_Time) :: ST,CT + INTEGER :: n + LOGICAL :: adjust + + CALL nl_get_adjust_input_times( grid%id, adjust ) + + IF ( stream .LT. 1 .OR. stream .GT. 11 ) THEN + WRITE(message,*)'med_auxinput_in: invalid input stream ',stream + CALL wrf_error_fatal( message ) + ENDIF + CALL domain_clock_get( grid, current_time=CT, start_time=ST, current_timestr=timestr ) + SELECT CASE( stream ) + CASE ( 1 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT1_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput1_inname, grid%id , 2 , timestr ) + CASE ( 2 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT2_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput2_inname , grid%id , 2 , timestr ) + CASE ( 3 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT3_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput3_inname , grid%id , 2 , timestr ) + CASE ( 4 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT4_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput4_inname , grid%id , 2 , timestr ) + CASE ( 5 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT5_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput5_inname , grid%id , 2 , timestr ) + CASE ( 6 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT6_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput6_inname , grid%id , 2 , timestr ) + CASE ( 7 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT7_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput7_inname , grid%id , 2 , timestr ) + CASE ( 8 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT8_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput8_inname , grid%id , 2 , timestr ) + CASE ( 9 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT9_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput9_inname , grid%id , 2 , timestr ) + CASE ( 10 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT10_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%gfdda_inname , grid%id , 2 , timestr ) + CASE ( 11 ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXINPUT11_ALARM ), CT, ST, timestr ) + CALL construct_filename2a ( auxname , config_flags%auxinput11_inname , grid%id , 2 , timestr ) + END SELECT + IF ( ( stream .eq. 1 .and. grid%auxinput1_oid .eq. 0 ) & + .or. ( stream .eq. 2 .and. grid%auxinput2_oid .eq. 0 ) & + .or. ( stream .eq. 3 .and. grid%auxinput3_oid .eq. 0 ) & + .or. ( stream .eq. 4 .and. grid%auxinput4_oid .eq. 0 ) & + .or. ( stream .eq. 5 .and. grid%auxinput5_oid .eq. 0 ) & + .or. ( stream .eq. 6 .and. grid%auxinput6_oid .eq. 0 ) & + .or. ( stream .eq. 7 .and. grid%auxinput7_oid .eq. 0 ) & + .or. ( stream .eq. 8 .and. grid%auxinput8_oid .eq. 0 ) & + .or. ( stream .eq. 9 .and. grid%auxinput9_oid .eq. 0 ) & + .or. ( stream .eq. 10 .and. grid%auxinput10_oid .eq. 0 ) & + .or. ( stream .eq. 11 .and. grid%auxinput11_oid .eq. 0 ) & + ) THEN + + IF ( stream .EQ. 10 ) THEN + WRITE(n2,'("DATASET=AUXINPUT10")') + ELSE IF ( stream .EQ. 11 ) THEN + WRITE(n2,'("DATASET=AUXINPUT11")') + ELSE + WRITE(n2,'("DATASET=AUXINPUT",I1)')stream + ENDIF + WRITE ( message , '("med_auxinput_in : opening ",A," for reading. ",I3)') TRIM ( auxname ), ierr + CALL wrf_debug( 1, message ) + +! +! +!Open_u_dataset is called rather than open_r_dataset to allow interfaces +!that can do blending or masking to update an existing field. (MCEL IO does this). +!No effect for other interfaces; open_u_dataset is equivalent to open_r_dataset +!in those cases. +! +! + + SELECT CASE( stream ) + CASE ( 1 ) + CALL open_u_dataset ( grid%auxinput1_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input1 , n2, ierr ) + CASE ( 2 ) + CALL open_u_dataset ( grid%auxinput2_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input2 , n2, ierr ) + CASE ( 3 ) + CALL open_u_dataset ( grid%auxinput3_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input3 , n2, ierr ) + CASE ( 4 ) + CALL open_u_dataset ( grid%auxinput4_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input4 , n2, ierr ) + CASE ( 5 ) + CALL open_u_dataset ( grid%auxinput5_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input5 , n2, ierr ) + CASE ( 6 ) + CALL open_u_dataset ( grid%auxinput6_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input6 , n2, ierr ) + CASE ( 7 ) + CALL open_u_dataset ( grid%auxinput7_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input7 , n2, ierr ) + CASE ( 8 ) + CALL open_u_dataset ( grid%auxinput8_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input8 , n2, ierr ) + CASE ( 9 ) + CALL open_u_dataset ( grid%auxinput9_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input9 , n2, ierr ) + CASE ( 10 ) + CALL open_u_dataset ( grid%auxinput10_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input10 , n2, ierr ) + CASE ( 11 ) + CALL open_u_dataset ( grid%auxinput11_oid, TRIM(auxname), grid , & + config_flags , input_aux_model_input11 , n2, ierr ) + END SELECT + IF ( ierr .NE. 0 ) THEN + CALL wrf_message( message ) + ENDIF + END IF + ! early return after training + IF ( .NOT. grid%return_after_training_io ) THEN + SELECT CASE( stream ) + CASE ( 1 ) + CALL input_aux_model_input1 ( grid%auxinput1_oid, grid , config_flags , ierr ) + CASE ( 2 ) + CALL input_aux_model_input2 ( grid%auxinput2_oid, grid , config_flags , ierr ) + CASE ( 3 ) + CALL input_aux_model_input3 ( grid%auxinput3_oid, grid , config_flags , ierr ) + CASE ( 4 ) + CALL input_aux_model_input4 ( grid%auxinput4_oid, grid , config_flags , ierr ) + CASE ( 5 ) + CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + CASE ( 6 ) + CALL input_aux_model_input6 ( grid%auxinput6_oid, grid , config_flags , ierr ) + CASE ( 7 ) + CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) + CASE ( 8 ) + CALL input_aux_model_input8 ( grid%auxinput8_oid, grid , config_flags , ierr ) + CASE ( 9 ) + CALL input_aux_model_input9 ( grid%auxinput9_oid, grid , config_flags , ierr ) + CASE ( 10 ) + CALL input_aux_model_input10 ( grid%auxinput10_oid, grid , config_flags , ierr ) + CASE ( 11 ) + CALL input_aux_model_input11 ( grid%auxinput11_oid, grid , config_flags , ierr ) + END SELECT + ELSE + CALL wrf_debug( 1, 'DEBUG: med_auxinput_in() returned after training' ) + ENDIF + RETURN +END SUBROUTINE med_auxinput_in + +SUBROUTINE med_filter_out ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + USE module_configure + ! Model layer + USE module_bc_time_utilities + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc + CHARACTER*80 :: timestr + + IF ( config_flags%write_input ) THEN + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( outname , config_flags%input_outname , grid%id , 2 , timestr ) + + WRITE ( message , '("med_filter_out 1: opening ",A," for writing. ",I3)') TRIM ( outname ), ierr + CALL wrf_debug( 1, message ) + + CALL open_w_dataset ( fid, TRIM(outname), grid , & + config_flags , output_model_input , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( message ) + ENDIF + + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( message ) + ENDIF + + CALL output_model_input ( fid, grid , config_flags , ierr ) + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) + + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Writing filter output for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + END IF + ENDIF + + RETURN +END SUBROUTINE med_filter_out + +SUBROUTINE med_latbound_in ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + USE module_configure + ! Model layer + USE module_bc_time_utilities + USE module_utility + + IMPLICIT NONE + +#include + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local data + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + LOGICAL :: lbc_opened + INTEGER :: idum1 , idum2 , ierr , open_status , fid, rc + REAL :: bfrq + CHARACTER (LEN=256) :: message + CHARACTER (LEN=80) :: bdyname + Type (WRFU_Time ) :: startTime, stopTime, currentTime + Type (WRFU_TimeInterval ) :: stepTime +integer myproc,i,j,k + +#include + + CALL wrf_debug ( 200 , 'in med_latbound_in' ) + + IF ( grid%id .EQ. 1 .AND. config_flags%specified .AND. config_flags%io_form_boundary .GT. 0 ) THEN + + CALL domain_clock_get( grid, current_time=currentTime, & + start_time=startTime, & + stop_time=stopTime, & + time_step=stepTime ) + + IF ( ( lbc_read_time( currentTime ) ) .AND. & + ( currentTime + stepTime .GE. stopTime ) .AND. & + ( currentTime .NE. startTime ) ) THEN + CALL wrf_debug( 100 , 'med_latbound_in: Skipping attempt to read lateral boundary file during last time step ' ) + + ELSE IF ( WRFU_AlarmIsRinging( grid%alarms( BOUNDARY_ALARM ), rc=rc ) ) THEN + CALL wrf_debug ( 100 , 'in med_latbound_in preparing to read' ) + CALL WRFU_AlarmRingerOff( grid%alarms( BOUNDARY_ALARM ), rc=rc ) + IF ( wrf_dm_on_monitor() ) CALL start_timing + +! typically a wouldn't be part of the bdy_inname, so just pass a dummy + CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , 'dummydate' ) + + CALL wrf_inquire_opened(head_grid%lbc_fid , TRIM(bdyname) , open_status , ierr ) + IF ( open_status .EQ. WRF_FILE_OPENED_FOR_READ ) THEN + lbc_opened = .TRUE. + ELSE + lbc_opened = .FALSE. + ENDIF + CALL wrf_dm_bcast_bytes ( lbc_opened , LWORDSIZE ) + IF ( .NOT. lbc_opened ) THEN + CALL construct_filename1 ( bdyname , 'wrfbdy' , grid%id , 2 ) + CALL open_r_dataset ( head_grid%lbc_fid, TRIM(bdyname) , grid , config_flags , "DATASET=BOUNDARY", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message, * ) 'med_latbound_in: error opening ',TRIM(bdyname), ' for reading. IERR = ',ierr + CALL WRF_ERROR_FATAL( message ) + ENDIF + ELSE + CALL wrf_debug( 100 , bdyname // 'already opened' ) + ENDIF + CALL wrf_debug( 100 , 'med_latbound_in: calling input_boundary ' ) + CALL input_boundary ( grid%lbc_fid, grid , config_flags , ierr ) + + CALL domain_clock_get( grid, current_time=currentTime ) + DO WHILE (currentTime .GE. grid%next_bdy_time ) ! next_bdy_time is set by input_boundary from bdy file + CALL wrf_debug( 100 , 'med_latbound_in: calling input_boundary ' ) + CALL input_boundary ( grid%lbc_fid, grid , config_flags , ierr ) + ENDDO + CALL WRFU_AlarmSet( grid%alarms( BOUNDARY_ALARM ), RingTime=grid%next_bdy_time, rc=rc ) + + IF ( ierr .NE. 0 .and. ierr .NE. WRF_WARN_NETCDF ) THEN + WRITE( message, * ) 'med_latbound_in: error reading ',TRIM(bdyname), ' IERR = ',ierr + CALL WRF_ERROR_FATAL( message ) + ENDIF + IF ( currentTime .EQ. grid%this_bdy_time ) grid%dtbc = 0. + + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("processing lateral boundary for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + ENDIF + ENDIF + ENDIF + RETURN +END SUBROUTINE med_latbound_in + +SUBROUTINE med_setup_step ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_configure + ! Model layer + + IMPLICIT NONE +! +! +!The driver layer routine integrate() calls this mediation layer routine +!prior to initiating a time step on the domain specified by the argument +!grid. This provides the model-layer contributor an opportunity to make +!any pre-time-step initializations that pertain to a particular model +!domain. In WRF, this routine is used to call +!set_scalar_indices_from_config for the specified domain. +! +! + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: idum1 , idum2 + + CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 ) + + RETURN + +END SUBROUTINE med_setup_step + +SUBROUTINE med_endup_step ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_configure + ! Model layer + + IMPLICIT NONE +! +! +!The driver layer routine integrate() calls this mediation layer routine +!prior to initiating a time step on the domain specified by the argument +!grid. This provides the model-layer contributor an opportunity to make +!any pre-time-step initializations that pertain to a particular model +!domain. In WRF, this routine is used to call +!set_scalar_indices_from_config for the specified domain. +! +! + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(OUT) :: config_flags + ! Local + INTEGER :: idum1 , idum2 + + IF ( grid%id .EQ. 1 ) THEN + ! turn off the restart flag after the first mother-domain step is finished + model_config_rec%restart = .FALSE. + config_flags%restart = .FALSE. + CALL nl_set_restart(1, .FALSE.) + + ENDIF + + RETURN + +END SUBROUTINE med_endup_step + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef WRF_CHEM +!------------------------------------------------------------------------ +! Chemistry emissions input control. Three options are available and are +! set via the namelist variable io_style_emissions: +! +! 0 = Emissions are not read in from a file. They will contain their +! default values, which can be set in the Registry. +! (Intended for debugging of chem code) +! +! 1 = Emissions are read in from two 12 hour files that are cycled. +! With this choice, emi_inname and emi_outname should be set to +! the value "wrfchemi_d". The value of frames_per_emissfile +! is ignored. +! +! 2 = Emissions are read in from files identified by date and that have +! a length defined by frames_per_emissfile (in hours). Both +! emi_inname and emi_outname should be set to +! "wrfchemi_d_". +!------------------------------------------------------------------------ +SUBROUTINE med_read_wrf_chem_emiss ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + USE module_configure + ! Model layer + USE module_bc_time_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + USE module_date_time + USE module_utility + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + +! TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + TYPE (grid_config_rec_type) :: config_flags + Type (WRFU_Time ) :: stopTime, currentTime + Type (WRFU_TimeInterval ) :: stepTime + + ! Local data + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER :: ierr, efid + REAL :: time, tupdate + real, allocatable :: dumc0(:,:,:) + CHARACTER (LEN=256) :: message, current_date_char, date_string + CHARACTER (LEN=80) :: inpname + +#include + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! This "if" should be commented out when using emission files for nested +! domains. Also comment out the "ENDIF" line noted below. +! IF ( grid%id .EQ. 1 ) THEN + + CALL domain_clock_get( grid, current_time=currentTime, & + current_timestr=current_date_char, & + stop_time=stopTime, & + time_step=stepTime ) + + time = float(grid%itimestep) * grid%dt + +!--- +! io_style_emissions option 0: no emissions read in... +!--- + if( config_flags%io_style_emissions == 0 ) then + ! Do nothing. +!--- +! io_style_emissions option 1: cycle through two 12 hour input files... +!--- + else if( config_flags%io_style_emissions == 1 ) then + + tupdate = mod( time, (12. * 3600.) ) + IF( currentTime + stepTime .GE. stopTime .AND. & + grid%auxinput5_oid .NE. 0 ) THEN + CALL close_dataset ( grid%auxinput5_oid , config_flags , "DATASET=AUXINPUT5" ) + tupdate = 1. + ENDIF + +! write(message,FMT='(A,F10.1,A)') ' EMISSIONS UPDATE TIME ',time,TRIM(current_date_char(12:13)) +! CALL wrf_message( TRIM(message) ) + + IF ( tupdate .EQ. 0. .AND. current_date_char(12:13) .EQ. '00' ) THEN + CALL construct_filename1 ( inpname , 'wrfchemi_00z' , grid%id , 2 ) + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_emissions: Open file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + + if( grid%auxinput5_oid .NE. 0 ) then + CALL close_dataset ( grid%auxinput5_oid , config_flags , "DATASET=AUXINPUT5" ) + endif + + CALL open_r_dataset ( grid%auxinput5_oid, TRIM(inpname) , grid , config_flags, & + "DATASET=AUXINPUT5", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , * ) 'med_read_wrf_chem_emissions: error opening ', TRIM( inpname ) + CALL wrf_error_fatal( TRIM( message ) ) + ENDIF + ELSE IF ( tupdate .EQ. 0. .AND. current_date_char(12:13) .EQ. '12' ) THEN + CALL construct_filename1 ( inpname , 'wrfchemi_12z' , grid%id , 2 ) + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_emissions: Open file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + + if( grid%auxinput5_oid .NE. 0 ) then + CALL close_dataset ( grid%auxinput5_oid , config_flags , "DATASET=AUXINPUT5" ) + endif + + CALL open_r_dataset ( grid%auxinput5_oid, TRIM(inpname) , grid , config_flags, & + "DATASET=AUXINPUT5", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , * ) 'med_read_wrf_chem_emissions: error opening ', TRIM( inpname ) + CALL wrf_error_fatal( TRIM( message ) ) + ENDIF + ENDIF + + WRITE( message, '(A,2F10.1)' ) ' HOURLY EMISSIONS UPDATE TIME ',time,mod(time,3600.) + CALL wrf_message( TRIM(message) ) +! +! hourly updates to emissions + IF ( ( mod( time, 3600. ) .LT. 0.001 ) .AND. & + ( currentTime + stepTime .LT. stopTime ) ) THEN +! IF ( wrf_dm_on_monitor() ) CALL start_timing + + WRITE(message,'(A,A)')'mediation_integrate: med_read_wrf_chem_emissions: Read emissions for time ',TRIM(current_date_char) + CALL wrf_message( TRIM(message) ) + + CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input5' ) + CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + ELSE + CALL wrf_debug (100 , 'mediation_integrate: med_read_wrf_chem_emissions: Do not read emissions' ) + ENDIF + + +!--- +! io_style_emissions option 2: use dated emission files whose length is +! set via frames_per_emissfile... +!--- + else if( config_flags%io_style_emissions == 2 ) then + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_emissions: Read emissions for time ',TRIM(current_date_char) + CALL wrf_message( TRIM(message) ) +! +! Code to read hourly emission files... +! + if( grid%auxinput5_oid == 0 ) then + CALL construct_filename2a(inpname , grid%emi_inname, grid%id , 2, current_date_char) + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_emissions: Open file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + CALL open_r_dataset ( grid%auxinput5_oid, TRIM(inpname) , grid , config_flags, & + "DATASET=AUXINPUT5", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , * ) 'med_read_wrf_chem_emissions: error opening ', TRIM( inpname ) + CALL wrf_error_fatal( TRIM( message ) ) + ENDIF + end if +! +! Read the emissions data. +! + CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input5' ) + CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) +! +! If reached the indicated number of frames in the emissions file, close it. +! + grid%emissframes = grid%emissframes + 1 + IF ( grid%emissframes >= config_flags%frames_per_emissfile ) THEN + CALL close_dataset ( grid%auxinput5_oid , config_flags , "DATASET=AUXINPUT5" ) + grid%emissframes = 0 + grid%auxinput5_oid = 0 + ENDIF + +!--- +! unknown io_style_emissions option... +!--- + else + call wrf_error_fatal("Unknown emission style selected via io_style_emissions.") + end if + +! The following line should be commented out when using emission files +! for nested domains. Also comment out the "if" noted above. +! ENDIF + + CALL wrf_debug (100 , 'mediation_integrate: med_read_wrf_chem_emissions: exit' ) + +END SUBROUTINE med_read_wrf_chem_emiss + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + USE module_configure + ! Model layer + USE module_bc_time_utilities +#ifdef DM_PARALLEL + USE module_dm +#endif + USE module_date_time + USE module_utility + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local data + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER :: ierr, efid + REAL :: time, tupdate + real, allocatable :: dumc0(:,:,:) + CHARACTER (LEN=256) :: message, current_date_char, date_string + CHARACTER (LEN=80) :: inpname + +#include +! IF ( grid%id .EQ. 1 ) THEN + + CALL domain_clock_get( grid, current_timestr=current_date_char ) + + CALL construct_filename1 ( inpname , 'wrfbiochemi' , grid%id , 2 ) + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_bioemissions: Open file ',TRIM(inpname) + CALL wrf_message( TRIM(message) ) + + if( grid%auxinput4_oid .NE. 0 ) then + CALL close_dataset ( grid%auxinput4_oid , config_flags , "DATASET=AUXINPUT4" ) + endif + + CALL open_r_dataset ( grid%auxinput4_oid, TRIM(inpname) , grid , config_flags, & + "DATASET=AUXINPUT4", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , * ) 'med_read_wrf_chem_bioemissions: error opening ', TRIM( inpname ) + CALL wrf_error_fatal( TRIM( message ) ) + ENDIF + + WRITE(message,*)'mediation_integrate: med_read_wrf_chem_bioemissions: Read biogenic emissions at time ',& + TRIM(current_date_char) + CALL wrf_message( TRIM(message) ) + + CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input4' ) + CALL input_aux_model_input4 ( grid%auxinput4_oid, grid , config_flags , ierr ) + + CALL close_dataset ( grid%auxinput4_oid , config_flags , "DATASET=AUXINPUT4" ) + +! ENDIF + CALL wrf_debug (100 , 'mediation_integrate: med_read_wrf_chem_bioemissions: exit' ) + +END SUBROUTINE med_read_wrf_chem_bioemiss +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/wrfv2_fire/share/mediation_interp_domain.F b/wrfv2_fire/share/mediation_interp_domain.F new file mode 100644 index 00000000..97ca6a4d --- /dev/null +++ b/wrfv2_fire/share/mediation_interp_domain.F @@ -0,0 +1,227 @@ +! +!WRF:MEDIATION_LAYER:NESTING +! +SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) + USE module_domain + USE module_configure + USE module_timing + IMPLICIT NONE + TYPE(domain), POINTER :: parent_grid , nested_grid + TYPE(domain), POINTER :: grid + INTEGER nlev, msize + TYPE (grid_config_rec_type) :: config_flags +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y + +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Interface blocks +! ---------------------------------------------------------- + INTERFACE +! ---------------------------------------------------------- +! Interface definitions for EM CORE +! ---------------------------------------------------------- +#if (EM_CORE == 1) +! ---------------------------------------------------------- +! These routines are supplied by module_dm.F from the +! external communication package (e.g. external/RSL) +! ---------------------------------------------------------- + SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: ngrid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_em_part1 + + SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, config_flags & +! +# include "em_dummy_new_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_em_part2 +#endif +! ---------------------------------------------------------- +! Interface definitions for NMM (placeholder) +! ---------------------------------------------------------- +#if (NMM_CORE == 1 && NMM_NEST == 1) +!======================================================================= +! Added for the NMM core. This is gopal's doing. +!======================================================================= + + SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: intermediate_grid + TYPE(domain), POINTER :: ngrid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_nmm_part1 + + SUBROUTINE interp_domain_nmm_part2 ( grid, nested_grid, config_flags & +! +# include "nmm_dummy_args.inc" +! + ) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") + TYPE(domain), POINTER :: nested_grid + TYPE (grid_config_rec_type) :: config_flags +# include + END SUBROUTINE interp_domain_nmm_part2 + +!======================================================================= +! End of gopal's doing. +!======================================================================= +#endif +! ---------------------------------------------------------- +! Interface definitions for COAMPS (placeholder) +! ---------------------------------------------------------- +#if (COAMPS_CORE == 1) +#endif + END INTERFACE +! ---------------------------------------------------------- +! End of Interface blocks +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Executable code +! ---------------------------------------------------------- +! ---------------------------------------------------------- +! Interpolation calls for EM CORE. The called +! routines below are supplied by module_dm.F +! from the external communications package (e.g. RSL) +! ---------------------------------------------------------- +#if (EM_CORE == 1 && defined( DM_PARALLEL )) + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_EM ) THEN + + grid => nested_grid%intermediate_grid +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + grid => parent_grid + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL interp_domain_em_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & +! +# include "em_actual_new_args.inc" +! + ) + grid => nested_grid%intermediate_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL interp_domain_em_part2 ( grid, nested_grid, config_flags & +! +# include "em_actual_new_args.inc" +! + ) + + grid => nested_grid%intermediate_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + + ENDIF +#endif +! ------------------------------------------------------ +! End of Interpolation calls for EM CORE. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Interpolation calls for NMM. (Placeholder) +! ------------------------------------------------------ +#if (NMM_CORE == 1 && NMM_NEST == 1) +!======================================================================= +! Added for the NMM core. This is gopal's doing. +!======================================================================= +! + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + IF ( config_flags%dyn_opt == DYN_NMM) THEN + + grid => nested_grid%intermediate_grid +! CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & +#ifndef SGIALTIX + CALL alloc_space_field ( grid, grid%id , 1 , 3 , .FALSE. , & + grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & + grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose + grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose + ) +#endif + + grid => parent_grid + +# include "deref_kludge.h" + + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + + CALL interp_domain_nmm_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & +! +# include "nmm_actual_args.inc" +! + ) + grid => nested_grid%intermediate_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +# include "deref_kludge.h" + + CALL interp_domain_nmm_part2 ( grid, nested_grid, config_flags & +! +# include "nmm_actual_args.inc" +! + ) + + grid => nested_grid%intermediate_grid + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) +#ifndef SGIALTIX + CALL dealloc_space_field ( grid ) +#endif + + ENDIF +! ------------------------------------------------------------ +! End of gopal's doing +! ------------------------------------------------------------ +#endif +! ------------------------------------------------------ +! End of Interpolation calls for NMM. +! ------------------------------------------------------ +! ------------------------------------------------------ +! ------------------------------------------------------ +! Interpolation calls for COAMPS. (Placeholder) +! ------------------------------------------------------ +#if (COAMPS_CORE == 1) +#endif +! ------------------------------------------------------ +! End of Interpolation calls for COAMPS. +! ------------------------------------------------------ + RETURN +END SUBROUTINE med_interp_domain + + diff --git a/wrfv2_fire/share/mediation_nest_move.F b/wrfv2_fire/share/mediation_nest_move.F new file mode 100644 index 00000000..43a40b8b --- /dev/null +++ b/wrfv2_fire/share/mediation_nest_move.F @@ -0,0 +1,908 @@ + +SUBROUTINE med_nest_move ( parent, nest ) + ! Driver layer + USE module_domain + USE module_timing + USE module_configure + USE module_io_domain + USE module_dm + TYPE(domain) , POINTER :: parent, nest, grid + INTEGER dx, dy ! number of parent domain points to move +#ifdef MOVE_NESTS + ! Local + CHARACTER*256 mess + INTEGER i, j, p, parent_grid_ratio, dyn_opt + INTEGER px, py ! number and direction of nd points to move + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + INTEGER ierr, fid + LOGICAL input_from_hires + LOGICAL saved_restart_value + TYPE (grid_config_rec_type) :: config_flags + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + LOGICAL, EXTERNAL :: should_not_move + + INTERFACE + SUBROUTINE med_interp_domain ( parent , nest ) + USE module_domain + TYPE(domain) , POINTER :: parent , nest + END SUBROUTINE med_interp_domain + SUBROUTINE start_domain ( grid , allowed_to_move ) + USE module_domain + TYPE(domain) :: grid + LOGICAL, INTENT(IN) :: allowed_to_move + END SUBROUTINE start_domain +#if ( EM_CORE == 1 ) + SUBROUTINE shift_domain_em ( grid, disp_x, disp_y & +! +# include +! + ) + USE module_domain + USE module_configure + USE module_timing + IMPLICIT NONE + INTEGER disp_x, disp_y + TYPE(domain) , POINTER :: grid +# include + END SUBROUTINE shift_domain_em +#endif +#if ( NMM_CORE == 1 ) +#endif + LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy ) + USE module_domain + USE module_utility + TYPE(domain) , POINTER :: parent , nest + INTEGER, INTENT(OUT) :: dx , dy + END FUNCTION time_for_move + SUBROUTINE input_terrain_rsmas ( grid , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + USE module_domain + TYPE ( domain ) :: grid + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + END SUBROUTINE input_terrain_rsmas + SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: nest , parent + TYPE (grid_config_rec_type) config_flags + END SUBROUTINE med_nest_feedback + SUBROUTINE blend_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated + REAL , DIMENSION(ims:ime,jms:jme) :: ter_input + END SUBROUTINE blend_terrain + SUBROUTINE store_terrain ( ter_interpolated , ter_input , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + REAL , DIMENSION(ims:ime,jms:jme) :: ter_interpolated + REAL , DIMENSION(ims:ime,jms:jme) :: ter_input + END SUBROUTINE store_terrain + END INTERFACE + + ! set grid pointer for code in deref_kludge (if used) + grid => nest + + CALL nl_get_dyn_opt ( 1, dyn_opt ) + + IF ( should_not_move( nest%id ) ) THEN + CALL wrf_message( 'Nest movement is disabled because of namelist settings' ) + RETURN + ENDIF + +! if the nest has stopped don't do all this + IF ( WRFU_ClockIsStopTime(nest%domain_clock ,rc=ierr) ) RETURN + +! mask should be defined in nest domain + + check_for_move: IF ( time_for_move ( parent , nest , dx, dy ) ) THEN + + IF ( (dx .gt. 1 .or. dx .lt. -1 ) .or. & + (dy .gt. 1 .or. dy .lt. -1 ) ) THEN + WRITE(mess,*)' invalid move: dx, dy ', dx, dy + CALL wrf_error_fatal( mess ) + ENDIF + + WRITE(mess,*)' moving ',grid%id,dx,dy + CALL wrf_message(mess) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL wrf_dm_move_nest ( parent, nest%intermediate_grid, dx, dy ) + + CALL adjust_domain_dims_for_move( nest%intermediate_grid , dx, dy ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + grid => nest + +#if ( EM_CORE == 1 ) + IF ( dyn_opt .EQ. DYN_EM ) THEN + CALL shift_domain_em( grid, dx, dy & +! +# include +! + ) + ENDIF +#endif +#if ( WRF_NMM_CORE == 1 ) + IF ( dyn_opt .EQ. DYN_NMM ) THEN + ENDIF +#endif + + px = grid%parent_grid_ratio*dx + py = grid%parent_grid_ratio*dy + + grid%i_parent_start = grid%i_parent_start + px / grid%parent_grid_ratio + CALL nl_set_i_parent_start( grid%id, grid%i_parent_start ) + grid%j_parent_start = grid%j_parent_start + py / grid%parent_grid_ratio + CALL nl_set_j_parent_start( grid%id, grid%j_parent_start ) + + IF ( wrf_dm_on_monitor() ) THEN + write(mess,*) & + 'Grid ',grid%id,' New SW corner (in parent x and y):',grid%i_parent_start, grid%j_parent_start + CALL wrf_message(TRIM(mess)) + ENDIF + + CALL med_interp_domain( parent, nest ) + + CALL nl_get_input_from_hires( nest%id , input_from_hires ) + IF ( input_from_hires ) THEN + +! store horizontally interpolated terrain in temp location + CALL store_terrain ( nest%ht_fine , nest%ht , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL store_terrain ( nest%em_mub_fine , nest%em_mub , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL store_terrain ( nest%em_phb_fine , nest%em_phb , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) + + CALL input_terrain_rsmas ( nest, & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + + CALL blend_terrain ( nest%ht_fine , nest%ht , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL blend_terrain ( nest%em_mub_fine , nest%em_mub , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + ips , ipe , jps , jpe , 1 , 1 ) + CALL blend_terrain ( nest%em_phb_fine , nest%em_phb , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe ) +! + CALL model_to_grid_config_rec ( parent%id , model_config_rec , config_flags ) + + CALL med_nest_feedback ( parent , nest , config_flags ) + parent%imask_nostag = 1 + parent%imask_xstag = 1 + parent%imask_ystag = 1 + parent%imask_xystag = 1 + +! start_domain will key off "restart". Even if this is a restart run +! we don't want it to here. Save the value, set it to false, and restore afterwards + saved_restart_value = config_flags%restart + config_flags%restart = .FALSE. + grid%restart = .FALSE. + CALL nl_set_restart ( 1, .FALSE. ) + CALL start_domain ( parent , .FALSE. ) + config_flags%restart = saved_restart_value + grid%restart = saved_restart_value + CALL nl_set_restart ( 1, saved_restart_value ) + + ENDIF + +! +! masks associated with nest will have been set by shift_domain_em above + nest%moved = .true. +! start_domain will key off "restart". Even if this is a restart run +! we don't want it to here. Save the value, set it to false, and restore afterwards + saved_restart_value = config_flags%restart + config_flags%restart = .FALSE. + CALL nl_set_restart ( 1, .FALSE. ) + grid%restart = .FALSE. + CALL start_domain ( nest , .FALSE. ) + config_flags%restart = saved_restart_value + grid%restart = saved_restart_value + CALL nl_set_restart ( 1, saved_restart_value ) + nest%moved = .false. + +! +! copy time level 2 to time level 1 in new regions of multi-time level fields +! this should be registry generated. +! +#if ( EM_CORE == 1 ) + IF ( dyn_opt .EQ. DYN_EM ) THEN + do k = kms,kme + where ( nest%imask_xstag .EQ. 1 ) nest%em_u_1(:,k,:) = nest%em_u_2(:,k,:) + where ( nest%imask_ystag .EQ. 1 ) nest%em_v_1(:,k,:) = nest%em_v_2(:,k,:) + where ( nest%imask_nostag .EQ. 1 ) nest%em_t_1(:,k,:) = nest%em_t_2(:,k,:) + where ( nest%imask_nostag .EQ. 1 ) nest%em_w_1(:,k,:) = nest%em_w_2(:,k,:) + where ( nest%imask_nostag .EQ. 1 ) nest%em_ph_1(:,k,:) = nest%em_ph_2(:,k,:) + where ( nest%imask_nostag .EQ. 1 ) nest%em_tp_1(:,k,:) = nest%em_tp_2(:,k,:) + where ( nest%imask_nostag .EQ. 1 ) nest%em_tke_1(:,k,:) = nest%em_tke_2(:,k,:) + enddo + where ( nest%imask_nostag .EQ. 1 ) nest%em_mu_1(:,:) = nest%em_mu_2(:,:) + ENDIF +#endif +#if ( WRF_NMM_CORE == 1 ) + IF ( dyn_opt .EQ. DYN_NMM ) THEN + ENDIF +#endif +! + ENDIF check_for_move +#endif +END SUBROUTINE med_nest_move + +LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y ) + ! Driver layer + USE module_domain + USE module_configure + USE module_compute_geop + USE module_dm + USE module_utility + IMPLICIT NONE +! Arguments + TYPE(domain) , POINTER :: parent, grid + INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y +#ifdef MOVE_NESTS +! Local + INTEGER num_moves, rc + INTEGER move_interval , move_id + TYPE(WRFU_Time) :: ct, st + TYPE(WRFU_TimeInterval) :: ti + CHARACTER*256 mess, timestr + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + INTEGER :: is, ie, js, je, ierr + REAL :: ipbar, pbar, jpbar, fact + REAL :: last_vc_i , last_vc_j + + REAL, ALLOCATABLE, DIMENSION(:,:) :: height_l, height + REAL, ALLOCATABLE, DIMENSION(:,:) :: psfc, xlat, xlong, terrain + REAL :: minh, maxh + INTEGER :: mini, minj, maxi, maxj, i, j, pgr, irad + REAL :: disp_x, disp_y, lag, radius, center_i, center_j, dx + REAL :: dijsmooth, vmax, vmin, a, b + REAL :: dc_i, dc_j ! domain center + REAL :: maxws, ws + REAL :: pmin + INTEGER imploc, jmploc + + INTEGER :: fje, fjs, fie, fis, fimloc, fjmloc, imloc, jmloc, dyn_opt + INTEGER :: i_parent_start, j_parent_start + INTEGER :: max_vortex_speed, vortex_interval ! meters per second and seconds + REAL :: rsmooth = 100. ! kilometers? + + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +character*256 message, message2 + +!#define MOVING_DIAGS +# ifdef VORTEX_CENTER + + + CALL nl_get_dyn_opt ( 1, dyn_opt ) + CALL nl_get_parent_grid_ratio ( grid%id , pgr ) + CALL nl_get_i_parent_start ( grid%id , i_parent_start ) + CALL nl_get_j_parent_start ( grid%id , j_parent_start ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + +! If the alarm is ringing, recompute the Vortex Center (VC); otherwise +! use the previous position of VC. VC is not recomputed ever step to +! save on cost for global collection of height field and broadcast +! of new center. + +# ifdef MOVING_DIAGS +write(0,*)'Check to see if COMPUTE_VORTEX_CENTER_ALARM is ringing? ' +# endif + CALL nl_get_parent_grid_ratio ( grid%id , pgr ) + CALL nl_get_dx ( grid%id , dx ) + + IF ( WRFU_AlarmIsRinging( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) ) THEN + +# ifdef MOVING_DIAGS + write(0,*)'COMPUTE_VORTEX_CENTER_ALARM is ringing ' +# endif + CALL WRFU_AlarmRingerOff( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL domain_clock_get( grid, current_timestr=timestr ) + + last_vc_i = grid%vc_i + last_vc_j = grid%vc_j + + ALLOCATE ( height_l ( ims:ime , jms:jme ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height_l in time_for_move2') + IF ( wrf_dm_on_monitor() ) THEN + ALLOCATE ( height ( ids:ide , jds:jde ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2') + ALLOCATE ( psfc ( ids:ide , jds:jde ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2') + ALLOCATE ( xlat ( ids:ide , jds:jde ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2') + ALLOCATE ( xlong ( ids:ide , jds:jde ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2') + ALLOCATE ( terrain ( ids:ide , jds:jde ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2') + ELSE + ALLOCATE ( height ( 1:1 , 1:1 ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating height in time_for_move2') + ALLOCATE ( psfc ( 1:1 , 1:1 ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating psfc in time_for_move2') + ALLOCATE ( xlat ( 1:1 , 1:1 ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlat in time_for_move2') + ALLOCATE ( xlong ( 1:1 , 1:1 ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating xlong in time_for_move2') + ALLOCATE ( terrain ( 1:1 , 1:1 ), STAT=ierr ) + IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating terrain in time_for_move2') + ENDIF + +# if (EM_CORE == 1) + IF ( dyn_opt .EQ. DYN_EM ) THEN + CALL compute_500mb_height ( grid%em_ph_2 , grid%em_phb, grid%em_p, grid%em_pb, height_l , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ENDIF +# endif +# if (WRF_NMM_CORE == 1) + IF ( dyn_opt .EQ. DYN_NMM ) THEN + ENDIF +# endif + + CALL wrf_patch_to_global_real ( height_l , height , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%psfc , psfc , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%xlat , xlat , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%xlong , xlong , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%ht , terrain , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + +! calculate max wind speed + maxws = 0. + do j = jps, jpe + do i = ips, ipe + ws = grid%u10(i,j) * grid%u10(i,j) + grid%v10(i,j) * grid%v10(i,j) + if ( ws > maxws ) maxws = ws + enddo + enddo + maxws = sqrt ( maxws ) + maxws = wrf_dm_max_real ( maxws ) + + monitor_only : IF ( wrf_dm_on_monitor() ) THEN + +! +! This vortex center finding code adapted from the Hurricane version of MM5, +! Courtesy: +! +! Shuyi Chen et al., Rosenstiel School of Marine and Atmos. Sci., U. Miami. +! Spring, 2005 +! +! Get the first guess vortex center about which we do our search +! as mini and minh; minimum value is minh +! + + CALL nl_get_vortex_interval( grid%id , vortex_interval ) + CALL nl_get_max_vortex_speed( grid%id , max_vortex_speed ) + + IF ( grid%vc_i < 0. .AND. grid%vc_j < 0. ) THEN + ! first time through + is = ids + ie = ide-1 + js = jds + je = jde-1 + ELSE + ! limit the search to an area around the vortex + ! that is limited by max_vortex_speed (default 40) meters per second from + ! previous location over vortex_interval (default 15 mins) + + is = max( grid%vc_i - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * ids ) + js = max( grid%vc_j - 60 * vortex_interval * max_vortex_speed / dx , 1.0 * jds ) + ie = min( grid%vc_i + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (ide-1) ) + je = min( grid%vc_j + 60 * vortex_interval * max_vortex_speed / dx , 1.0 * (jde-1) ) + + ENDIF + +# ifdef MOVING_DIAGS +write(0,*)'search set around last position ' +write(0,*)' is, ids-1, ie, ide-1 ', is, ids-1, ie, ide-1 +write(0,*)' js, jds-1, je, jde-1 ', js, jds-1, je, jde-1 +# endif + + imploc = -1 + jmploc = -1 + + ! find minimum psfc + pmin = 99999999.0 ! make this very large to be sure we find a minumum + DO j = js, je + DO i = is, ie + IF ( psfc(i,j) .LT. pmin ) THEN + pmin = psfc(i,j) + imploc = i + jmploc = j + ENDIF + ENDDO + ENDDO + + IF ( imploc .EQ. -1 .OR. jmploc .EQ. -1 ) THEN ! if we fail to find a min there is something seriously wrong + WRITE(mess,*)'i,j,is,ie,js,je,imploc,jmploc ',i,j,is,ie,js,je,imploc,jmploc + CALL wrf_message(mess) + CALL wrf_error_fatal('time_for_move2: Method failure searching for minimum psfc.') + ENDIF + + imloc = -1 + jmloc = -1 + maxi = -1 + maxj = -1 + + ! find local min, max + vmin = 99999999.0 + vmax = -99999999.0 + DO j = js, je + DO i = is, ie + IF ( height(i,j) .LT. vmin ) THEN + vmin = height(i,j) + imloc = i + jmloc = j + ENDIF + IF ( height(i,j) .GT. vmax ) THEN + vmax = height(i,j) + maxi = i + maxj = j + ENDIF + ENDDO + ENDDO + + IF ( imloc .EQ. -1 .OR. jmloc .EQ. -1 .OR. maxi .EQ. -1 .OR. maxj .EQ. -1 ) THEN + WRITE(mess,*)'i,j,is,ie,js,je,imloc,jmloc,maxi,maxj ',i,j,is,ie,js,je,imloc,jmloc,maxi,maxj + CALL wrf_message(mess) + CALL wrf_error_fatal('time_for_move2: Method failure searching max/min of height.') + ENDIF + + fimloc = imloc + fjmloc = jmloc + + if ( grid%xi .EQ. -1. ) grid%xi = fimloc + if ( grid%xj .EQ. -1. ) grid%xj = fjmloc + + dijsmooth = rsmooth / dx + + fjs = max(fjmloc-dijsmooth,1.0) + fje = min(fjmloc+dijsmooth,jde-2.0) + fis = max(fimloc-dijsmooth,1.0) + fie = min(fimloc+dijsmooth,ide-2.0) + js = fjs + je = fje + is = fis + ie = fie + + vmin = 1000000.0 + vmax = -1000000.0 + DO j = js, je + DO i = is, ie + IF ( height(i,j) .GT. vmax ) THEN + vmax = height(i,j) + ENDIF + ENDDO + ENDDO + + pbar = 0.0 + ipbar = 0.0 + jpbar = 0.0 + + do j=js,je + do i=is,ie + fact = vmax - height(i,j) + pbar = pbar + fact + ipbar = ipbar + fact*(i-is) + jpbar = jpbar + fact*(j-js) + enddo + enddo + + IF ( pbar .NE. 0. ) THEN + +! Compute an adjusted, smoothed, vortex center location in cross +! point index space. +! Time average. A is coef for old information; B is new +! If pbar is zero then just skip this, leave xi and xj alone, +! result will be no movement. + a = 0.0 + b = 1.0 + grid%xi = (a * grid%xi + b * (is + ipbar / pbar)) / ( a + b ) + grid%xj = (a * grid%xj + b * (js + jpbar / pbar)) / ( a + b ) + + grid%vc_i = grid%xi + .5 + grid%vc_j = grid%xj + .5 + + + ENDIF + +# ifdef MOVING_DIAGS +write(0,*)'computed grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j +i = grid%vc_i ; j = grid%vc_j ; height( i,j ) = height(i,j) * 1.2 !mark the center +CALL domain_clock_get( grid, current_timestr=message2 ) +WRITE ( message , FMT = '(A," on domain ",I3)' ) TRIM(message2), grid%id +# endif + +! + i = INT(grid%xi+.5) + j = INT(grid%xj+.5) + write(mess,'("ATCF"," ",A19," ",f8.2," ",f8.2," ",f6.1," ",f6.1)') & + timestr(1:19), & + xlat(i,j), & + xlong(i,j), & + 0.01*pmin+0.1138*terrain(imploc,jmploc), & + maxws*1.94 + CALL wrf_message(TRIM(mess)) + + + + ENDIF monitor_only + + DEALLOCATE ( psfc ) + DEALLOCATE ( xlat ) + DEALLOCATE ( xlong ) + DEALLOCATE ( terrain ) + DEALLOCATE ( height ) + DEALLOCATE ( height_l ) + + CALL wrf_dm_bcast_real( grid%vc_i , 1 ) + CALL wrf_dm_bcast_real( grid%vc_j , 1 ) + + CALL wrf_dm_bcast_real( pmin , 1 ) + CALL wrf_dm_bcast_integer( imploc , 1 ) + CALL wrf_dm_bcast_integer( jmploc , 1 ) + +# ifdef MOVING_DIAGS +write(0,*)'after bcast : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j +# endif + + + ENDIF ! COMPUTE_VORTEX_CENTER_ALARM ringing + +# ifdef MOVING_DIAGS +write(0,*)'After ENDIF : grid%vc_i, grid%vc_j ',grid%vc_i, grid%vc_j +# endif + + dc_i = (ide-ids+1)/2. ! domain center + dc_j = (jde-jds+1)/2. + + disp_x = grid%vc_i - dc_i * 1.0 + disp_y = grid%vc_j - dc_j * 1.0 + +#if 0 +! This appears to be an old, redundant, and perhaps even misnamed parameter. +! Remove it from the namelist and Registry and just hard code it to +! the default of 6. JM 20050721 + CALL nl_get_vortex_search_radius( 1, irad ) +#else + irad = 6 +#endif + + radius = irad + + if ( disp_x .GT. 0 ) disp_x = min( disp_x , radius ) + if ( disp_y .GT. 0 ) disp_y = min( disp_y , radius ) + + if ( disp_x .LT. 0 ) disp_x = max( disp_x , -radius ) + if ( disp_y .LT. 0 ) disp_y = max( disp_y , -radius ) + + move_cd_x = int ( disp_x / pgr ) + move_cd_y = int ( disp_y / pgr ) + + IF ( move_cd_x .GT. 0 ) move_cd_x = min ( move_cd_x , 1 ) + IF ( move_cd_y .GT. 0 ) move_cd_y = min ( move_cd_y , 1 ) + IF ( move_cd_x .LT. 0 ) move_cd_x = max ( move_cd_x , -1 ) + IF ( move_cd_y .LT. 0 ) move_cd_y = max ( move_cd_y , -1 ) + + CALL domain_clock_get( grid, current_timestr=timestr ) + + WRITE(mess,*)timestr(1:19),' vortex center (in nest x and y): ',grid%vc_i, grid%vc_j + CALL wrf_message(TRIM(mess)) + WRITE(mess,*)timestr(1:19),' grid center (in nest x and y): ', dc_i, dc_j + CALL wrf_message(TRIM(mess)) + WRITE(mess,*)timestr(1:19),' disp : ', disp_x, disp_y + CALL wrf_message(TRIM(mess)) + WRITE(mess,*)timestr(1:19),' move (rel cd) : ',move_cd_x, move_cd_y + CALL wrf_message(TRIM(mess)) + + grid%vc_i = grid%vc_i - move_cd_x * pgr + grid%vc_j = grid%vc_j - move_cd_y * pgr + +# ifdef MOVING_DIAGS +write(0,*)' changing grid%vc_i, move_cd_x * pgr ', grid%vc_i, move_cd_x * pgr, move_cd_x, pgr +# endif + + IF ( ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) ) THEN + time_for_move2 = .TRUE. + ELSE + time_for_move2 = .FALSE. + ENDIF + +# else +! from namelist + move_cd_x = 0 + move_cd_y = 0 + time_for_move2 = .FALSE. + CALL domain_clock_get( grid, current_time=ct, start_time=st ) + CALL nl_get_num_moves( 1, num_moves ) + IF ( num_moves .GT. max_moves ) THEN + WRITE(mess,*)'time_for_moves2: num_moves (',num_moves,') .GT. max_moves (',max_moves,')' + CALL wrf_error_fatal( TRIM(mess) ) + ENDIF + DO i = 1, num_moves + CALL nl_get_move_id( i, move_id ) + IF ( move_id .EQ. grid%id ) THEN + CALL nl_get_move_interval( i, move_interval ) + IF ( move_interval .LT. 999999999 ) THEN + CALL WRFU_TimeIntervalSet ( ti, M=move_interval, rc=rc ) + IF ( ct .GE. st + ti ) THEN + CALL nl_get_move_cd_x ( i, move_cd_x ) + CALL nl_get_move_cd_y ( i, move_cd_y ) + CALL nl_set_move_interval ( i, 999999999 ) + time_for_move2 = .TRUE. + EXIT + ENDIF + ENDIF + ENDIF + ENDDO +# endif + RETURN +#endif +END FUNCTION time_for_move2 + +LOGICAL FUNCTION time_for_move ( parent , grid , move_cd_x, move_cd_y ) + USE module_domain + USE module_configure + USE module_dm +USE module_timing + USE module_utility + IMPLICIT NONE +! arguments + TYPE(domain) , POINTER :: parent, grid, par, nst + INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y +#ifdef MOVE_NESTS +! local + INTEGER :: corral_dist, kid + INTEGER :: dw, de, ds, dn, pgr + INTEGER :: would_move_x, would_move_y + INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe +! interface + INTERFACE + LOGICAL FUNCTION time_for_move2 ( parent , nest , dx , dy ) + USE module_domain + USE module_utility + TYPE(domain) , POINTER :: parent , nest + INTEGER, INTENT(OUT) :: dx , dy + END FUNCTION time_for_move2 + END INTERFACE +! executable +! +! Simplifying assumption: domains in moving nest simulations have only +! one parent and only one child. + + IF ( grid%num_nests .GT. 1 ) THEN + CALL wrf_error_fatal ( 'domains in moving nest simulations can have only 1 nest' ) + ENDIF + kid = 1 +! +! find out if this is the innermost nest (will not have kids) + IF ( grid%num_nests .EQ. 0 ) THEN + ! code that executes on innermost nest + time_for_move = time_for_move2 ( parent , grid , move_cd_x, move_cd_y ) + + ! Make sure the parent can move before allowing the nest to approach + ! its boundary + par => grid%parents(1)%ptr + nst => grid + + would_move_x = move_cd_x + would_move_y = move_cd_y + + ! top of until loop +100 CONTINUE + CALL nl_get_corral_dist ( nst%id , corral_dist ) + CALL get_ijk_from_grid ( nst , & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe ) + CALL get_ijk_from_grid ( par , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL nl_get_parent_grid_ratio ( nst%id , pgr ) + ! perform measurements... + ! from western boundary + dw = nst%i_parent_start + would_move_x - cids + ! from southern boundary + ds = nst%j_parent_start + would_move_y - cjds + ! from eastern boundary + de = cide - ( nst%i_parent_start + (nide-nids+1)/pgr + would_move_x ) + ! from northern boundary + dn = cjde - ( nst%j_parent_start + (njde-njds+1)/pgr + would_move_y ) + + ! would this generate a move on the parent? + would_move_x = 0 + would_move_y = 0 + if ( dw .LE. corral_dist ) would_move_x = would_move_x - 1 + if ( de .LE. corral_dist ) would_move_x = would_move_x + 1 + if ( ds .LE. corral_dist ) would_move_y = would_move_y - 1 + if ( dn .LE. corral_dist ) would_move_y = would_move_y + 1 + + IF ( par%id .EQ. 1 ) THEN + IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN + CALL wrf_message('MOAD can not move. Cancelling nest move in X') + if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move + move_cd_x = 0 + ENDIF + IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN + CALL wrf_message('MOAD can not move. Cancelling nest move in Y') + if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move + move_cd_y = 0 + ENDIF + ELSE + nst => par + par => nst%parents(1)%ptr + GOTO 100 + ENDIF + +! bottom of until loop + time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) + + ELSE + ! code that executes on parent to see if parent needs to move + ! get closest number of cells we'll allow nest edge to approach parent bdy + CALL nl_get_corral_dist ( grid%nests(kid)%ptr%id , corral_dist ) + ! get dims + CALL get_ijk_from_grid ( grid%nests(kid)%ptr , & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe ) + CALL get_ijk_from_grid ( grid , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr ) + ! perform measurements... + ! from western boundary + dw = grid%nests(kid)%ptr%i_parent_start - 1 + ! from southern boundary + ds = grid%nests(kid)%ptr%j_parent_start - 1 + ! from eastern boundary + de = cide - ( grid%nests(kid)%ptr%i_parent_start + (nide-nids+1)/pgr ) + ! from northern boundary + dn = cjde - ( grid%nests(kid)%ptr%j_parent_start + (njde-njds+1)/pgr ) + + ! move this domain (the parent containing the moving nest) + ! in a direction that reestablishes the distance from + ! the boundary. + move_cd_x = 0 + move_cd_y = 0 + if ( dw .LE. corral_dist ) move_cd_x = move_cd_x - 1 + if ( de .LE. corral_dist ) move_cd_x = move_cd_x + 1 + if ( ds .LE. corral_dist ) move_cd_y = move_cd_y - 1 + if ( dn .LE. corral_dist ) move_cd_y = move_cd_y + 1 + + time_for_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) + + IF ( time_for_move ) THEN + IF ( grid%id .EQ. 1 ) THEN + + CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' ) + time_for_move = .FALSE. + + ELSE + ! need to adjust the intermediate domain of the nest in relation to this + ! domain since we're moving + + CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr ) + CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr ) + grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr + CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start ) + grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr + CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start ) + + ENDIF + ENDIF + + ENDIF + + RETURN +#endif +END FUNCTION time_for_move + +! Put any tests for non-moving options or conditions in here +LOGICAL FUNCTION should_not_move ( id ) + USE module_state_description + USE module_configure + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + ! Local + LOGICAL retval + INTEGER cu_physics, ra_sw_physics, ra_lw_physics, ucmcall, obs_nudge_opt + + retval = .FALSE. +! check for GD ensemble cumulus, which can not move + CALL nl_get_cu_physics( id , cu_physics ) + IF ( cu_physics .EQ. GDSCHEME ) THEN + CALL wrf_message('Grell cumulus can not be specified with moving nests. Movement disabled.') + retval = .TRUE. + ENDIF +! check for CAM radiation scheme , which can not move + CALL nl_get_ra_sw_physics( id , ra_sw_physics ) + IF ( ra_sw_physics .EQ. CAMSWSCHEME ) THEN + CALL wrf_message('CAM SW radiation can not be specified with moving nests. Movement disabled.') + retval = .TRUE. + ENDIF + CALL nl_get_ra_lw_physics( id , ra_lw_physics ) + IF ( ra_lw_physics .EQ. CAMLWSCHEME ) THEN + CALL wrf_message('CAM LW radiation can not be specified with moving nests. Movement disabled.') + retval = .TRUE. + ENDIF +! check for urban canopy Noah LSM, which can not move + CALL nl_get_ucmcall( id , ucmcall ) + IF ( ucmcall .EQ. 1 ) THEN + CALL wrf_message('UCM Noah LSM can not be specified with moving nests. Movement disabled.') + retval = .TRUE. + ENDIF +! check for observation nudging, which can not move + CALL nl_get_obs_nudge_opt( id , obs_nudge_opt ) + IF ( obs_nudge_opt .EQ. 1 ) THEN + CALL wrf_message('Observation nudging can not be specified with moving nests. Movement disabled.') + retval = .TRUE. + ENDIF + should_not_move = retval +END FUNCTION + diff --git a/wrfv2_fire/share/mediation_wrfmain.F b/wrfv2_fire/share/mediation_wrfmain.F new file mode 100644 index 00000000..22384d5a --- /dev/null +++ b/wrfv2_fire/share/mediation_wrfmain.F @@ -0,0 +1,215 @@ +!WRF:MEDIATION_LAYER: +! + +SUBROUTINE med_initialdata_input_ptr ( grid , config_flags ) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE (domain) , POINTER :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + INTERFACE + SUBROUTINE med_initialdata_input ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + END SUBROUTINE med_initialdata_input + END INTERFACE + CALL med_initialdata_input ( grid , config_flags ) + + +END SUBROUTINE med_initialdata_input_ptr + +SUBROUTINE med_initialdata_input ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing +use module_io + ! Model layer + USE module_configure + USE module_bc_time_utilities + USE module_utility + + IMPLICIT NONE + + ! Interface + INTERFACE + SUBROUTINE start_domain ( grid , allowed_to_read ) ! comes from module_start in appropriate dyn_ directory + USE module_domain + TYPE (domain) grid + LOGICAL, INTENT(IN) :: allowed_to_read + END SUBROUTINE start_domain + END INTERFACE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + INTEGER :: fid , ierr , myproc + CHARACTER (LEN=80) :: inpname , rstname, timestr + CHARACTER (LEN=80) :: message + LOGICAL :: restart + + CALL nl_get_restart( 1, restart ) + IF ( .NOT. restart ) THEN + ! Initialize the mother domain. + grid%input_from_file = .true. + IF ( grid%input_from_file ) THEN + + CALL wrf_debug ( 1 , 'wrf main: calling open_r_dataset for wrfinput' ) + +! typically will not be part of input_inname but allow for it + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( inpname , config_flags%input_inname , grid%id , 2 , timestr ) + + CALL open_r_dataset ( fid, TRIM(inpname) , grid , config_flags , "DATASET=INPUT", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( wrf_err_message , * ) 'program wrf: error opening ',TRIM(inpname),' for reading ierr=',ierr + CALL WRF_ERROR_FATAL ( wrf_err_message ) + ENDIF + IF ( ( grid%id .EQ. 1 ) .OR. ( config_flags%fine_input_stream .EQ. 0 ) ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_model_input' ) + CALL input_model_input ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_model_input' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 1 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input1' ) + CALL input_aux_model_input1 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input1' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 2 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input2' ) + CALL input_aux_model_input2 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input2' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 3 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input3' ) + CALL input_aux_model_input3 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input3' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 4 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input4' ) + CALL input_aux_model_input4 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input4' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 5 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input5' ) + CALL input_aux_model_input5 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input5' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 6 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input6' ) + CALL input_aux_model_input6 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input6' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 7 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input7' ) + CALL input_aux_model_input7 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input7' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 8 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input8' ) + CALL input_aux_model_input8 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input8' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 9 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input9' ) + CALL input_aux_model_input9 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input9' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 10 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input10' ) + CALL input_aux_model_input10 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input10' ) + ELSE IF ( config_flags%fine_input_stream .EQ. 11 ) THEN + CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input11' ) + CALL input_aux_model_input11 ( fid , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input11' ) + ELSE + WRITE( message , '("med_initialdata_input: bad fine_input_stream = ",I4)') config_flags%fine_input_stream + CALL WRF_ERROR_FATAL ( message ) + END IF + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) +#ifdef MOVE_NESTS + grid%nest_pos = grid%ht + where ( grid%nest_pos .gt. 0 ) grid%nest_pos = grid%nest_pos + 500. ! make a cliff +#endif + ENDIF + grid%imask_nostag = 1 + grid%imask_xstag = 1 + grid%imask_ystag = 1 + grid%imask_xystag = 1 + CALL start_domain ( grid , .TRUE. ) + ELSE + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( rstname , config_flags%rst_inname , grid%id , 2 , timestr ) + + WRITE(message,*)'RESTART run: opening ',TRIM(rstname),' for reading' + CALL wrf_message ( message ) + CALL open_r_dataset ( fid , TRIM(rstname) , grid , config_flags , "DATASET=RESTART", ierr ) + IF ( ierr .NE. 0 ) THEN + WRITE( message , '("program wrf: error opening ",A32," for reading")') TRIM(rstname) + CALL WRF_ERROR_FATAL ( message ) + ENDIF + CALL input_restart ( fid, grid , config_flags , ierr ) + CALL close_dataset ( fid , config_flags , "DATASET=RESTART" ) + grid%imask_nostag = 1 + grid%imask_xstag = 1 + grid%imask_ystag = 1 + grid%imask_xystag = 1 + CALL start_domain ( grid , .TRUE. ) + ENDIF + + RETURN +END SUBROUTINE med_initialdata_input + +SUBROUTINE med_shutdown_io ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + ! Model layer + USE module_configure + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + CHARACTER (LEN=80) :: message + INTEGER :: ierr + + IF ( grid%oid > 0 ) CALL close_dataset ( grid%oid , config_flags , "DATASET=HISTORY" ) + IF ( grid%auxhist1_oid > 0 ) CALL close_dataset ( grid%auxhist1_oid , config_flags , "DATASET=AUXHIST1" ) + IF ( grid%auxhist2_oid > 0 ) CALL close_dataset ( grid%auxhist2_oid , config_flags , "DATASET=AUXHIST2" ) + IF ( grid%auxhist3_oid > 0 ) CALL close_dataset ( grid%auxhist3_oid , config_flags , "DATASET=AUXHIST3" ) + IF ( grid%auxhist4_oid > 0 ) CALL close_dataset ( grid%auxhist4_oid , config_flags , "DATASET=AUXHIST4" ) + IF ( grid%auxhist5_oid > 0 ) CALL close_dataset ( grid%auxhist5_oid , config_flags , "DATASET=AUXHIST5" ) +#if 0 + IF ( grid%auxhist6_oid > 0 ) CALL close_dataset ( grid%auxhist6_oid , config_flags , "DATASET=AUXHIST6" ) + IF ( grid%auxhist7_oid > 0 ) CALL close_dataset ( grid%auxhist7_oid , config_flags , "DATASET=AUXHIST7" ) + IF ( grid%auxhist8_oid > 0 ) CALL close_dataset ( grid%auxhist8_oid , config_flags , "DATASET=AUXHIST8" ) + IF ( grid%auxhist9_oid > 0 ) CALL close_dataset ( grid%auxhist9_oid , config_flags , "DATASET=AUXHIST9" ) + IF ( grid%auxhist10_oid > 0 ) CALL close_dataset ( grid%auxhist10_oid , config_flags , "DATASET=AUXHIST10" ) + IF ( grid%auxhist11_oid > 0 ) CALL close_dataset ( grid%auxhist11_oid , config_flags , "DATASET=AUXHIST11" ) +#endif + + IF ( grid%lbc_fid > 0 ) CALL close_dataset ( grid%lbc_fid , config_flags , "DATASET=BOUNDARY" ) + + CALL wrf_ioexit( ierr ) ! shut down the quilt I/O + + RETURN + +END SUBROUTINE med_shutdown_io + +SUBROUTINE med_add_config_info_to_grid ( grid ) + + USE module_domain + USE module_configure + + IMPLICIT NONE + + ! Input data. + + TYPE(domain) , TARGET :: grid + +#define SOURCE_RECORD model_config_rec % +#define SOURCE_REC_DEX (grid%id) +#define DEST_RECORD grid % +#include + + RETURN + +END SUBROUTINE med_add_config_info_to_grid + diff --git a/wrfv2_fire/share/module_MPP.F b/wrfv2_fire/share/module_MPP.F new file mode 100644 index 00000000..255d3adb --- /dev/null +++ b/wrfv2_fire/share/module_MPP.F @@ -0,0 +1,61 @@ +! + MODULE MODULE_MPP +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! +!*** THE RANK OF THIS TASK +! + INTEGER :: MYPE +!---------------------------------------------------------------------- +! +!*** NUMBER OF TASKS +! + INTEGER :: INPES,JNPES,NPES +! +!*** FUNDAMENTAL GLOBAL AND LOCAL ARRAY EXTENTS ON EACH TASK +! + INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB & + ,MY_IS_LOC,MY_IE_LOC,MY_JS_LOC,MY_JE_LOC +!---------------------------------------------------------------------- +! +!*** SUB-DOMAIN LOOP LIMITS THAT PENETRATE HALOES +! + INTEGER :: MYIS,MYIE,MYJS,MYJE & + ,MYIS1,MYIS2,MYIS3,MYIS4,MYIS5 & + ,MYIE1,MYIE2,MYIE3,MYIE4,MYIE5 & + ,MYIS_P1,MYIS_P2,MYIS_P3,MYIS_P4,MYIS_P5 & + ,MYIS1_P1,MYIS1_P2,MYIS1_P3,MYIS1_P4,MYIS1_P5 & + ,MYIS2_P1,MYIS2_P2,MYIS2_P3,MYIS2_P4,MYIS2_P5 & + ,MYIS3_P1,MYIS3_P2,MYIS3_P3,MYIS3_P4,MYIS3_P5 & + ,MYIS4_P1,MYIS4_P2,MYIS4_P3,MYIS4_P4,MYIS4_P5 & + ,MYIS5_P1,MYIS5_P2,MYIS5_P3,MYIS5_P4,MYIS5_P5 & + ,MYIE_P1,MYIE_P2,MYIE_P3,MYIE_P4,MYIE_P5 & + ,MYIE1_P1,MYIE1_P2,MYIE1_P3,MYIE1_P4,MYIE1_P5 & + ,MYIE2_P1,MYIE2_P2,MYIE2_P3,MYIE2_P4,MYIE2_P5 & + ,MYIE3_P1,MYIE3_P2,MYIE3_P3,MYIE3_P4,MYIE3_P5 & + ,MYIE4_P1,MYIE4_P2,MYIE4_P3,MYIE4_P4,MYIE4_P5 & + ,MYIE5_P1,MYIE5_P2,MYIE5_P3,MYIE5_P4,MYIE5_P5 & + ,MYJS1,MYJS2,MYJS3,MYJS4,MYJS5 & + ,MYJE1,MYJE2,MYJE3,MYJE4,MYJE5 & + ,MYJS_P1,MYJS_P2,MYJS_P3,MYJS_P4,MYJS_P5 & + ,MYJS1_P1,MYJS1_P2,MYJS1_P3,MYJS1_P4,MYJS1_P5 & + ,MYJS2_P1,MYJS2_P2,MYJS2_P3,MYJS2_P4,MYJS2_P5 & + ,MYJS3_P1,MYJS3_P2,MYJS3_P3,MYJS3_P4,MYJS3_P5 & + ,MYJS4_P1,MYJS4_P2,MYJS4_P3,MYJS4_P4,MYJS4_P5 & + ,MYJS5_P1,MYJS5_P2,MYJS5_P3,MYJS5_P4,MYJS5_P5 & + ,MYJE_P1,MYJE_P2,MYJE_P3,MYJE_P4,MYJE_P5 & + ,MYJE1_P1,MYJE1_P2,MYJE1_P3,MYJE1_P4,MYJE1_P5 & + ,MYJE2_P1,MYJE2_P2,MYJE2_P3,MYJE2_P4,MYJE2_P5 & + ,MYJE3_P1,MYJE3_P2,MYJE3_P3,MYJE3_P4,MYJE3_P5 & + ,MYJE4_P1,MYJE4_P2,MYJE4_P3,MYJE4_P4,MYJE4_P5 & + ,MYJE5_P1,MYJE5_P2,MYJE5_P3,MYJE5_P4,MYJE5_P5 + +! +!---------------------------------------------------------------------- +! +!*** MPI_COMM_COMP IS THE INTRACOMMUNICATOR FOR ALL TASKS. +! + INTEGER :: MPI_COMM_COMP + +!---------------------------------------------------------------------- + END MODULE MODULE_MPP diff --git a/wrfv2_fire/share/module_bc.F b/wrfv2_fire/share/module_bc.F new file mode 100644 index 00000000..1655ff1d --- /dev/null +++ b/wrfv2_fire/share/module_bc.F @@ -0,0 +1,2603 @@ +!WRF:MODEL_LAYER:BOUNDARY +! + +MODULE module_bc + + USE module_configure + USE module_wrf_error + IMPLICIT NONE + +! TYPE bcs +! +! LOGICAL :: periodic_x +! LOGICAL :: symmetric_xs +! LOGICAL :: symmetric_xe +! LOGICAL :: open_xs +! LOGICAL :: open_xe +! LOGICAL :: periodic_y +! LOGICAL :: symmetric_ys +! LOGICAL :: symmetric_ye +! LOGICAL :: open_ys +! LOGICAL :: open_ye +! LOGICAL :: nested +! LOGICAL :: specified +! LOGICAL :: top_radiation +! +! END TYPE bcs + +! set the bdyzone. We are hardwiring this here and we'll +! decide later where it should be set and stored + + INTEGER, PARAMETER :: bdyzone = 4 + INTEGER, PARAMETER :: bdyzone_x = bdyzone + INTEGER, PARAMETER :: bdyzone_y = bdyzone + + INTERFACE stuff_bdy + MODULE PROCEDURE stuff_bdy_new , stuff_bdy_old + END INTERFACE + + INTERFACE stuff_bdytend + MODULE PROCEDURE stuff_bdytend_new , stuff_bdytend_old + END INTERFACE + +CONTAINS + + SUBROUTINE boundary_condition_check ( config_flags, bzone, error, gn ) + +! this routine checks the boundary condition logicals +! to make sure that the boundary conditions are not over +! or under specified. The routine also checks that the +! boundary zone is sufficiently sized for the specified +! boundary conditions + + IMPLICIT NONE + + TYPE( grid_config_rec_type ) config_flags + + INTEGER, INTENT(IN ) :: bzone, gn + INTEGER, INTENT(INOUT) :: error + +! local variables + + INTEGER :: xs_bc, xe_bc, ys_bc, ye_bc, bzone_min + INTEGER :: nprocx, nprocy + + CALL wrf_debug( 100 , ' checking boundary conditions for grid ' ) + + error = 0 + xs_bc = 0 + xe_bc = 0 + ys_bc = 0 + ye_bc = 0 + +! sum the number of conditions specified for each lateral boundary. +! obviously, this number should be 1 + + IF( config_flags%periodic_x ) THEN + xs_bc = xs_bc+1 + xe_bc = xe_bc+1 + ENDIF + + IF( config_flags%periodic_y ) THEN + ys_bc = ys_bc+1 + ye_bc = ye_bc+1 + ENDIF + + IF( config_flags%symmetric_xs ) xs_bc = xs_bc + 1 + IF( config_flags%symmetric_xe ) xe_bc = xe_bc + 1 + IF( config_flags%open_xs ) xs_bc = xs_bc + 1 + IF( config_flags%open_xe ) xe_bc = xe_bc + 1 + + + IF( config_flags%symmetric_ys ) ys_bc = ys_bc + 1 + IF( config_flags%symmetric_ye ) ye_bc = ye_bc + 1 + IF( config_flags%open_ys ) ys_bc = ys_bc + 1 + IF( config_flags%open_ye ) ye_bc = ye_bc + 1 + + IF( config_flags%nested ) THEN + xs_bc = xs_bc + 1 + xe_bc = xe_bc + 1 + ys_bc = ys_bc + 1 + ye_bc = ye_bc + 1 + ENDIF + + IF( config_flags%specified ) THEN + IF( .NOT. config_flags%periodic_x)xs_bc = xs_bc + 1 + IF( .NOT. config_flags%periodic_x)xe_bc = xe_bc + 1 + ys_bc = ys_bc + 1 + ye_bc = ye_bc + 1 + ENDIF + +! check the number of conditions for each boundary + + IF( (xs_bc /= 1) .or. & + (xe_bc /= 1) .or. & + (ys_bc /= 1) .or. & + (ye_bc /= 1) ) THEN + + error = 1 + + write( wrf_err_message ,*) ' *** Error in boundary condition specification ' + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' boundary conditions at xs ', xs_bc + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' boundary conditions at xe ', xe_bc + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' boundary conditions at ys ', ys_bc + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' boundary conditions at ye ', ye_bc + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' boundary conditions logicals are ' + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' periodic_x ',config_flags%periodic_x + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' periodic_y ',config_flags%periodic_y + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' symmetric_xs ',config_flags%symmetric_xs + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' symmetric_xe ',config_flags%symmetric_xe + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' symmetric_ys ',config_flags%symmetric_ys + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' symmetric_ye ',config_flags%symmetric_ye + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' open_xs ',config_flags%open_xs + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' open_xe ',config_flags%open_xe + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' open_ys ',config_flags%open_ys + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' open_ye ',config_flags%open_ye + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' nested ',config_flags%nested + CALL wrf_message ( wrf_err_message ) + write( wrf_err_message ,*) ' specified ',config_flags%specified + CALL wrf_error_fatal( ' *** Error in boundary condition specification ' ) + + ENDIF + +! now check to see if boundary zone size is sufficient. +! we could have the necessary boundary zone size be returned +! to the calling routine. + + IF( config_flags%periodic_x .or. & + config_flags%periodic_y .or. & + config_flags%symmetric_xs .or. & + config_flags%symmetric_xe .or. & + config_flags%symmetric_ys .or. & + config_flags%symmetric_ye ) THEN + + bzone_min = MAX( 1, & + (config_flags%h_mom_adv_order+1)/2, & + (config_flags%h_sca_adv_order+1)/2 ) + + IF( bzone < bzone_min) THEN + + error = 2 + WRITE ( wrf_err_message , * ) ' boundary zone not large enough ' + CALL wrf_message ( wrf_err_message ) + WRITE ( wrf_err_message , * ) ' boundary zone specified ',bzone + CALL wrf_message ( wrf_err_message ) + WRITE ( wrf_err_message , * ) ' minimum boundary zone needed ',bzone_min + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF + ENDIF + + CALL wrf_debug ( 100 , ' boundary conditions OK for grid ' ) + + END subroutine boundary_condition_check + +!-------------------------------------------------------------------------- + SUBROUTINE set_physical_bc2d( dat, variable_in, & + config_flags, & + ids,ide, jds,jde, & ! domain dims + ims,ime, jms,jme, & ! memory dims + ips,ipe, jps,jpe, & ! patch dims + its,ite, jts,jte ) + +! This subroutine sets the data in the boundary region, by direct +! assignment if possible, for periodic and symmetric (wall) +! boundary conditions. Currently, we are only doing 1 variable +! at a time - lots of overhead, so maybe this routine can be easily +! inlined later or we could pass multiple variables - +! would probably want a largestep and smallstep version. + +! 15 Jan 99, Dave +! Modified the incoming its,ite,jts,jte to truly be the tile size. +! This required modifying the loop limits when the "istag" or "jstag" +! is used, as this is only required at the end of the domain. + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte + CHARACTER, INTENT(IN ) :: variable_in + + CHARACTER :: variable + + REAL, DIMENSION( ims:ime , jms:jme ) :: dat + TYPE( grid_config_rec_type ) config_flags + + INTEGER :: i, j, istag, jstag, itime + + LOGICAL :: debug, open_bc_copy + +!------------ + + debug = .false. + + open_bc_copy = .false. + + variable = variable_in + IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN + variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') ) + ENDIF + IF ((variable == 'u') .or. (variable == 'v') .or. & + (variable == 'w') .or. (variable == 't') .or. & + (variable == 'x') .or. (variable == 'y') .or. & + (variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true. + +! begin, first set a staggering variable + + istag = -1 + jstag = -1 + + IF ((variable == 'u') .or. (variable == 'x')) istag = 0 + IF ((variable == 'v') .or. (variable == 'y')) jstag = 0 + + if(debug) then + write(6,*) ' in bc2d, var is ',variable, istag, jstag + write(6,*) ' b.cs are ', & + config_flags%periodic_x, & + config_flags%periodic_y + end if + + + +! periodic conditions. +! note, patch must cover full range in periodic dir, or else +! its intra-patch communication that is handled elsewheres. +! symmetry conditions can always be handled here, because no +! outside patch communication is needed + + periodicity_x: IF( ( config_flags%periodic_x ) ) THEN + IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if east and west both on-processor + IF ( its == ids ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 0,-(bdyzone-1),-1 + dat(ids+i-1,j) = dat(ide+i-1,j) + ENDDO + ENDDO + + ENDIF + + IF ( ite == ide ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) +!! DO i = 1 , bdyzone + DO i = -istag , bdyzone + dat(ide+i+istag,j) = dat(ids+i+istag,j) + ENDDO + ENDDO + + ENDIF + ENDIF + + ELSE + + symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. & + ( its == ids ) ) THEN + + IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 1, bdyzone + dat(ids-i,j) = dat(ids+i-1,j) ! here, dat(0) = dat(1), etc + ENDDO ! symmetry about dat(0.5) (u=0 pt) + ENDDO + + ELSE + + IF( variable == 'u' ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 0, bdyzone-1 + dat(ids-i,j) = - dat(ids+i,j) ! here, u(0) = - u(2), etc + ENDDO ! normal b.c symmetry at u(1) + ENDDO + + ELSE + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 0, bdyzone-1 + dat(ids-i,j) = dat(ids+i,j) ! here, phi(0) = phi(2), etc + ENDDO ! normal b.c symmetry at phi(1) + ENDDO + + END IF + + ENDIF + + ENDIF symmetry_xs + + +! now the symmetry boundary at xe + + symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. & + ( ite == ide ) ) THEN + + IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 1, bdyzone + dat(ide+i-1,j) = dat(ide-i,j) ! sym. about dat(ide-0.5) + ENDDO + ENDDO + + ELSE + + IF (variable == 'u' ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 0, bdyzone-1 + dat(ide+i,j) = - dat(ide-i,j) ! u(ide+1) = - u(ide-1), etc. + ENDDO + ENDDO + + + ELSE + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO i = 0, bdyzone-1 + dat(ide+i,j) = dat(ide-i,j) ! phi(ide+1) = phi(ide-1), etc. + ENDDO + ENDDO + + END IF + + END IF + + END IF symmetry_xe + + +! set open b.c in X copy into boundary zone here. WCS, 19 March 2000 + + open_xs: IF( ( config_flags%open_xs .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( its == ids ) .and. open_bc_copy ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + dat(ids-1,j) = dat(ids,j) ! here, dat(0) = dat(1) + dat(ids-2,j) = dat(ids,j) + dat(ids-3,j) = dat(ids,j) + ENDDO + + ENDIF open_xs + + +! now the open boundary copy at xe + + open_xe: IF( ( config_flags%open_xe .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( ite == ide ) .and. open_bc_copy ) THEN + + IF ( variable /= 'u' .and. variable /= 'x') THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + dat(ide ,j) = dat(ide-1,j) + dat(ide+1,j) = dat(ide-1,j) + dat(ide+2,j) = dat(ide-1,j) + ENDDO + + ELSE + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + dat(ide+1,j) = dat(ide,j) + dat(ide+2,j) = dat(ide,j) + dat(ide+3,j) = dat(ide,j) + ENDDO + + END IF + + END IF open_xe + +! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000 + + END IF periodicity_x + +! same procedure in y + + periodicity_y: IF( ( config_flags%periodic_y ) ) THEN + IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test of both north and south on processor + + IF( jts == jds ) then + + DO j = 0, -(bdyzone-1), -1 + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jds+j-1) = dat(i,jde+j-1) + ENDDO + ENDDO + + END IF + + IF( jte == jde ) then + + DO j = -jstag, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde+j+jstag) = dat(i,jds+j+jstag) + ENDDO + ENDDO + + END IF + + END IF + + ELSE + + symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. & + ( jts == jds) ) THEN + + IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jds-j) = dat(i,jds+j-1) + ENDDO + ENDDO + + ELSE + + IF (variable == 'v') THEN + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jds-j) = - dat(i,jds+j) + ENDDO + ENDDO + + ELSE + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jds-j) = dat(i,jds+j) + ENDDO + ENDDO + + END IF + + ENDIF + + ENDIF symmetry_ys + +! now the symmetry boundary at ye + + symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. & + ( jte == jde ) ) THEN + + IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde+j-1) = dat(i,jde-j) + ENDDO + ENDDO + + ELSE + + IF (variable == 'v' ) THEN + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde+j) = - dat(i,jde-j) ! bugfix: changed jds on rhs to jde , JM 20020410 + ENDDO + ENDDO + + ELSE + + DO j = 1, bdyzone + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde+j) = dat(i,jde-j) + ENDDO + ENDDO + + END IF + + ENDIF + + END IF symmetry_ye + +! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000 + + open_ys: IF( ( config_flags%open_ys .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( jts == jds) .and. open_bc_copy ) THEN + + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jds-1) = dat(i,jds) + dat(i,jds-2) = dat(i,jds) + dat(i,jds-3) = dat(i,jds) + ENDDO + + ENDIF open_ys + +! now the open boundary copy at ye + + open_ye: IF( ( config_flags%open_ye .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( jte == jde ) .and. open_bc_copy ) THEN + + IF (variable /= 'v' .and. variable /= 'y' ) THEN + + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde ) = dat(i,jde-1) + dat(i,jde+1) = dat(i,jde-1) + dat(i,jde+2) = dat(i,jde-1) + ENDDO + + ELSE + + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,jde+1) = dat(i,jde) + dat(i,jde+2) = dat(i,jde) + dat(i,jde+3) = dat(i,jde) + ENDDO + + ENDIF + + END IF open_ye + +! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000 + + END IF periodicity_y + +! fix corners for doubly periodic domains + + IF ( config_flags%periodic_x .and. config_flags%periodic_y & + .and. (ids == ips) .and. (ide == ipe) & + .and. (jds == jps) .and. (jde == jpe) ) THEN + + IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill + DO j = 0, -(bdyzone-1), -1 + DO i = 0, -(bdyzone-1), -1 + dat(ids+i-1,jds+j-1) = dat(ide+i-1,jde+j-1) + ENDDO + ENDDO + END IF + + IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill + DO j = 0, -(bdyzone-1), -1 + DO i = 1, bdyzone + dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1) + ENDDO + ENDDO + END IF + + IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill + DO j = 1, bdyzone + DO i = 1, bdyzone + dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag) + ENDDO + ENDDO + END IF + + IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill + DO j = 1, bdyzone + DO i = 0, -(bdyzone-1), -1 + dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag) + ENDDO + ENDDO + END IF + + END IF + + END SUBROUTINE set_physical_bc2d + +!----------------------------------- + + SUBROUTINE set_physical_bc3d( dat, variable_in, & + config_flags, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets the data in the boundary region, by direct +! assignment if possible, for periodic and symmetric (wall) +! boundary conditions. Currently, we are only doing 1 variable +! at a time - lots of overhead, so maybe this routine can be easily +! inlined later or we could pass multiple variables - +! would probably want a largestep and smallstep version. + +! 15 Jan 99, Dave +! Modified the incoming its,ite,jts,jte to truly be the tile size. +! This required modifying the loop limits when the "istag" or "jstag" +! is used, as this is only required at the end of the domain. + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + CHARACTER, INTENT(IN ) :: variable_in + + CHARACTER :: variable + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dat + TYPE( grid_config_rec_type ) config_flags + + INTEGER :: i, j, k, istag, jstag, itime, k_end + + LOGICAL :: debug, open_bc_copy + +!------------ + + debug = .false. + + open_bc_copy = .false. + + variable = variable_in + IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN + variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') ) + ENDIF + + IF ((variable == 'u') .or. (variable == 'v') .or. & + (variable == 'w') .or. (variable == 't') .or. & + (variable == 'd') .or. (variable == 'e') .or. & + (variable == 'x') .or. (variable == 'y') .or. & + (variable == 'f') .or. (variable == 'r') .or. & + (variable == 'p') ) open_bc_copy = .true. + +! begin, first set a staggering variable + + istag = -1 + jstag = -1 + k_end = max(1,min(kde-1,kte)) + + + IF ((variable == 'u') .or. (variable == 'x')) istag = 0 + IF ((variable == 'v') .or. (variable == 'y')) jstag = 0 + IF ((variable == 'd') .or. (variable == 'xy')) then + istag = 0 + jstag = 0 + ENDIF + IF ((variable == 'e') ) then + istag = 0 + k_end = min(kde,kte) + ENDIF + + IF ((variable == 'f') ) then + jstag = 0 + k_end = min(kde,kte) + ENDIF + + IF ( variable == 'w') k_end = min(kde,kte) + +! k_end = kte + + if(debug) then + write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end + write(6,*) ' b.cs are ', & + config_flags%periodic_x, & + config_flags%periodic_y + end if + + + +! periodic conditions. +! note, patch must cover full range in periodic dir, or else +! its intra-patch communication that is handled elsewheres. +! symmetry conditions can always be handled here, because no +! outside patch communication is needed + + periodicity_x: IF( ( config_flags%periodic_x ) ) THEN + + IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor + IF ( its == ids ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 0,-(bdyzone-1),-1 + dat(ids+i-1,k,j) = dat(ide+i-1,k,j) + ENDDO + ENDDO + ENDDO + + ENDIF + + + IF ( ite == ide ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = -istag , bdyzone + dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j) + ENDDO + ENDDO + ENDDO + + ENDIF + + ENDIF + + ELSE + + symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. & + ( its == ids ) ) THEN + + IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ids-i,k,j) = dat(ids+i-1,k,j) ! here, dat(0) = dat(1), etc + ENDDO ! symmetry about dat(0.5) (u = 0 pt) + ENDDO + ENDDO + + ELSE + + IF ( variable == 'u' ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ids-i,k,j) = - dat(ids+i,k,j) ! here, u(0) = - u(2), etc + ENDDO ! normal b.c symmetry at u(1) + ENDDO + ENDDO + + ELSE + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ids-i,k,j) = dat(ids+i,k,j) ! here, phi(0) = phi(2), etc + ENDDO ! normal b.c symmetry at phi(1) + ENDDO + ENDDO + + END IF + + ENDIF + + ENDIF symmetry_xs + + +! now the symmetry boundary at xe + + symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. & + ( ite == ide ) ) THEN + + IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ide+i-1,k,j) = dat(ide-i,k,j) ! sym. about dat(ide-0.5) + ENDDO + ENDDO + ENDDO + + ELSE + + IF (variable == 'u') THEN + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ide+i,k,j) = - dat(ide-i,k,j) ! u(ide+1) = - u(ide-1), etc. + ENDDO + ENDDO + ENDDO + + ELSE + + DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag) + DO k = kts, k_end + DO i = 1, bdyzone + dat(ide+i,k,j) = dat(ide-i,k,j) ! phi(ide+1) = - phi(ide-1), etc. + ENDDO + ENDDO + ENDDO + + END IF + + END IF + + END IF symmetry_xe + +! set open b.c in X copy into boundary zone here. WCS, 19 March 2000 + + open_xs: IF( ( config_flags%open_xs .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( its == ids ) .and. open_bc_copy ) THEN + + DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone + DO k = kts, k_end + dat(ids-1,k,j) = dat(ids,k,j) ! here, dat(0) = dat(1), etc + dat(ids-2,k,j) = dat(ids,k,j) + dat(ids-3,k,j) = dat(ids,k,j) + ENDDO + ENDDO + + ENDIF open_xs + + +! now the open_xe boundary copy + + open_xe: IF( ( config_flags%open_xe .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( ite == ide ) .and. open_bc_copy ) THEN + + IF (variable /= 'u' .and. variable /= 'x' ) THEN + + DO j = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone + DO k = kts, k_end + dat(ide ,k,j) = dat(ide-1,k,j) + dat(ide+1,k,j) = dat(ide-1,k,j) + dat(ide+2,k,j) = dat(ide-1,k,j) + ENDDO + ENDDO + + ELSE + +!!!!!!! I am not sure about this one! JM 20020402 + DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone + DO k = kts, k_end + dat(ide+1,k,j) = dat(ide,k,j) + dat(ide+2,k,j) = dat(ide,k,j) + dat(ide+3,k,j) = dat(ide,k,j) + ENDDO + ENDDO + + END IF + + END IF open_xe + +! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000 + + END IF periodicity_x + +! same procedure in y + + periodicity_y: IF( ( config_flags%periodic_y ) ) THEN + IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test if both north and south on processor + IF( jts == jds ) then + + DO j = 0, -(bdyzone-1), -1 + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jds+j-1) = dat(i,k,jde+j-1) + ENDDO + ENDDO + ENDDO + + END IF + + IF( jte == jde ) then + + DO j = -jstag, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde+j+jstag) = dat(i,k,jds+j+jstag) + ENDDO + ENDDO + ENDDO + + END IF + + END IF + + ELSE + + symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. & + ( jts == jds) ) THEN + + IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jds-j) = dat(i,k,jds+j-1) + ENDDO + ENDDO + ENDDO + + ELSE + + IF (variable == 'v') THEN + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jds-j) = - dat(i,k,jds+j) + ENDDO + ENDDO + ENDDO + + ELSE + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jds-j) = dat(i,k,jds+j) + ENDDO + ENDDO + ENDDO + + END IF + + ENDIF + + ENDIF symmetry_ys + +! now the symmetry boundary at ye + + symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. & + ( jte == jde ) ) THEN + + IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde+j-1) = dat(i,k,jde-j) + ENDDO + ENDDO + ENDDO + + ELSE + + IF ( variable == 'v' ) THEN + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde+j) = - dat(i,k,jde-j) + ENDDO + ENDDO + ENDDO + + ELSE + + DO j = 1, bdyzone + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde+j) = dat(i,k,jde-j) + ENDDO + ENDDO + ENDDO + + END IF + + ENDIF + + END IF symmetry_ye + +! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000 + + open_ys: IF( ( config_flags%open_ys .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( jts == jds) .and. open_bc_copy ) THEN + + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jds-1) = dat(i,k,jds) + dat(i,k,jds-2) = dat(i,k,jds) + dat(i,k,jds-3) = dat(i,k,jds) + ENDDO + ENDDO + + ENDIF open_ys + +! now the open boundary copy at ye + + open_ye: IF( ( config_flags%open_ye .or. & + config_flags%specified .or. & + config_flags%nested ) .and. & + ( jte == jde ) .and. open_bc_copy ) THEN + + IF (variable /= 'v' .and. variable /= 'y' ) THEN + + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde ) = dat(i,k,jde-1) + dat(i,k,jde+1) = dat(i,k,jde-1) + dat(i,k,jde+2) = dat(i,k,jde-1) + ENDDO + ENDDO + + ELSE + + DO k = kts, k_end + DO i = MAX(ids,its-1), MIN(ite+1,ide+istag) + dat(i,k,jde+1) = dat(i,k,jde) + dat(i,k,jde+2) = dat(i,k,jde) + dat(i,k,jde+3) = dat(i,k,jde) + ENDDO + ENDDO + + ENDIF + + END IF open_ye + +! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000 + + END IF periodicity_y + +! fix corners for doubly periodic domains + + IF ( config_flags%periodic_x .and. config_flags%periodic_y & + .and. (ids == ips) .and. (ide == ipe) & + .and. (jds == jps) .and. (jde == jpe) ) THEN + + IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill + DO j = 0, -(bdyzone-1), -1 + DO k = kts, k_end + DO i = 0, -(bdyzone-1), -1 + dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1) + ENDDO + ENDDO + ENDDO + END IF + + IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill + DO j = 0, -(bdyzone-1), -1 + DO k = kts, k_end + DO i = 1, bdyzone + dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1) + ENDDO + ENDDO + ENDDO + END IF + + IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill + DO j = 1, bdyzone + DO k = kts, k_end + DO i = 1, bdyzone + dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag) + ENDDO + ENDDO + ENDDO + END IF + + IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill + DO j = 1, bdyzone + DO k = kts, k_end + DO i = 0, -(bdyzone-1), -1 + dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag) + ENDDO + ENDDO + ENDDO + END IF + + END IF + + END SUBROUTINE set_physical_bc3d + + SUBROUTINE init_module_bc + END SUBROUTINE init_module_bc + +!------------------------------------------------------------------------ + SUBROUTINE relax_bdytend ( field, field_tend, & + field_bdy_xs, field_bdy_xe, & + field_bdy_ys, field_bdy_ye, & + field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + variable_in, config_flags, & + spec_bdy_width, spec_zone, relax_zone, & + dtbc, fcx, gcx, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine adds the tendencies in the boundary relaxation region, for specified +! boundary conditions. +! spec_bdy_width is only used to dimension the boundary arrays. +! relax_zone is the inner edge of the boundary relaxation zone treated here. +! spec_zone is the width of the outer specified b.c.s that are not changed here. +! (JD July 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone, relax_zone + REAL, INTENT(IN ) :: dtbc + CHARACTER, INTENT(IN ) :: variable_in + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field_tend + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_xs, field_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_ys, field_bdy_tend_ye + REAL, DIMENSION( spec_bdy_width ), INTENT(IN ) :: fcx, gcx + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1 + INTEGER :: b_dist, b_limit + REAL :: fls0, fls1, fls2, fls3, fls4 + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + IF (variable == 'M') variable = 'm' + IF (variable == 'H') variable = 'h' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 'm') ktf = kte + IF (variable == 'h') ktf = kte + + IF (jts - jbs .lt. relax_zone) THEN +! Y-start boundary + DO j = max(jts,jbs+spec_zone), min(jtf,jbs+relax_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + im1 = max(i-1,ibs) + ip1 = min(i+1,ibe) + fls0 = field_bdy_ys(i, k, b_dist+1) & + + dtbc * field_bdy_tend_ys(i, k, b_dist+1) & + - field(i,k,j) + fls1 = field_bdy_ys(im1, k, b_dist+1) & + + dtbc * field_bdy_tend_ys(im1, k, b_dist+1) & + - field(im1,k,j) + fls2 = field_bdy_ys(ip1, k, b_dist+1) & + + dtbc * field_bdy_tend_ys(ip1, k, b_dist+1) & + - field(ip1,k,j) + fls3 = field_bdy_ys(i, k, b_dist) & + + dtbc * field_bdy_tend_ys(i, k, b_dist) & + - field(i,k,j-1) + fls4 = field_bdy_ys(i, k, b_dist+2) & + + dtbc * field_bdy_tend_ys(i, k, b_dist+2) & + - field(i,k,j+1) + field_tend(i,k,j) = field_tend(i,k,j) & + + fcx(b_dist+1)*fls0 & + - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (jbe - jtf .lt. relax_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-relax_zone+1), min(jtf,jbe-spec_zone) + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + im1 = max(i-1,ibs) + ip1 = min(i+1,ibe) + fls0 = field_bdy_ye(i, k, b_dist+1) & + + dtbc * field_bdy_tend_ye(i, k, b_dist+1) & + - field(i,k,j) + fls1 = field_bdy_ye(im1, k, b_dist+1) & + + dtbc * field_bdy_tend_ye(im1, k, b_dist+1) & + - field(im1,k,j) + fls2 = field_bdy_ye(ip1, k, b_dist+1) & + + dtbc * field_bdy_tend_ye(ip1, k, b_dist+1) & + - field(ip1,k,j) + fls3 = field_bdy_ye(i, k, b_dist) & + + dtbc * field_bdy_tend_ye(i, k, b_dist) & + - field(i,k,j+1) + fls4 = field_bdy_ye(i, k, b_dist+2) & + + dtbc * field_bdy_tend_ye(i, k, b_dist+2) & + - field(i,k,j-1) + field_tend(i,k,j) = field_tend(i,k,j) & + + fcx(b_dist+1)*fls0 & + - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0) + + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. relax_zone) THEN +! X-start boundary + DO i = max(its,ibs+spec_zone), min(itf,ibs+relax_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + fls0 = field_bdy_xs(j, k, b_dist+1) & + + dtbc * field_bdy_tend_xs(j, k, b_dist+1) & + - field(i,k,j) + fls1 = field_bdy_xs(j-1, k, b_dist+1) & + + dtbc * field_bdy_tend_xs(j-1, k, b_dist+1) & + - field(i,k,j-1) + fls2 = field_bdy_xs(j+1, k, b_dist+1) & + + dtbc * field_bdy_tend_xs(j+1, k, b_dist+1) & + - field(i,k,j+1) + fls3 = field_bdy_xs(j, k, b_dist) & + + dtbc * field_bdy_tend_xs(j, k, b_dist) & + - field(i-1,k,j) + fls4 = field_bdy_xs(j, k, b_dist+2) & + + dtbc * field_bdy_tend_xs(j, k, b_dist+2) & + - field(i+1,k,j) + field_tend(i,k,j) = field_tend(i,k,j) & + + fcx(b_dist+1)*fls0 & + - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0) + + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. relax_zone) THEN +! X-end boundary + DO i = max(its,ibe-relax_zone+1), min(itf,ibe-spec_zone) + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + fls0 = field_bdy_xe(j, k, b_dist+1) & + + dtbc * field_bdy_tend_xe(j, k, b_dist+1) & + - field(i,k,j) + fls1 = field_bdy_xe(j-1, k, b_dist+1) & + + dtbc * field_bdy_tend_xe(j-1, k, b_dist+1) & + - field(i,k,j-1) + fls2 = field_bdy_xe(j+1, k, b_dist+1) & + + dtbc * field_bdy_tend_xe(j+1, k, b_dist+1) & + - field(i,k,j+1) + fls3 = field_bdy_xe(j, k, b_dist) & + + dtbc * field_bdy_tend_xe(j, k, b_dist) & + - field(i+1,k,j) + fls4 = field_bdy_xe(j, k, b_dist+2) & + + dtbc * field_bdy_tend_xe(j, k, b_dist+2) & + - field(i-1,k,j) + field_tend(i,k,j) = field_tend(i,k,j) & + + fcx(b_dist+1)*fls0 & + - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + + END SUBROUTINE relax_bdytend +!------------------------------------------------------------------------ + + SUBROUTINE spec_bdytend ( field_tend, & + field_bdy_xs, field_bdy_xe, & + field_bdy_ys, field_bdy_ye, & + field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + variable_in, config_flags, & + spec_bdy_width, spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets the tendencies in the boundary specified region. +! spec_bdy_width is only used to dimension the boundary arrays. +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD July 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone + CHARACTER, INTENT(IN ) :: variable_in + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT ) :: field_tend + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_xs, field_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_ys, field_bdy_tend_ye + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: b_dist, b_limit + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + IF (variable == 'M') variable = 'm' + IF (variable == 'H') variable = 'h' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 'm') ktf = kte + IF (variable == 'h') ktf = kte + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field_tend(i,k,j) = field_bdy_tend_ys(i, k, b_dist+1) + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field_tend(i,k,j) = field_bdy_tend_ye(i, k, b_dist+1) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field_tend(i,k,j) = field_bdy_tend_xs(j, k, b_dist+1) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field_tend(i,k,j) = field_bdy_tend_xe(j, k, b_dist+1) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE spec_bdytend +!------------------------------------------------------------------------ + + SUBROUTINE spec_bdyupdate( field, & + field_tend, dt, & + variable_in, config_flags, & + spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine adds the tendencies in the boundary specified region. +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone + CHARACTER, INTENT(IN ) :: variable_in + REAL, INTENT(IN ) :: dt + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: b_dist, b_limit + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + IF (variable == 'M') variable = 'm' + IF (variable == 'H') variable = 'h' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 'm') ktf = kte + IF (variable == 'h') ktf = kte + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE spec_bdyupdate +!------------------------------------------------------------------------ + + SUBROUTINE zero_grad_bdy ( field, & + variable_in, config_flags, & + spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets zero gradient conditions in the boundary specified region. +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone + CHARACTER, INTENT(IN ) :: variable_in + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner + INTEGER :: b_dist, b_limit + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 'w') ktf = kde + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(periodic_x)i_inner = i + field(i,k,j) = field(i_inner,k,jbs+spec_zone) + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(periodic_x)i_inner = i + field(i,k,j) = field(i_inner,k,jbe-spec_zone) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + field(i,k,j) = field(ibs+spec_zone,k,j_inner) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + field(i,k,j) = field(ibe-spec_zone,k,j_inner) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE zero_grad_bdy +!------------------------------------------------------------------------ + + SUBROUTINE flow_dep_bdy ( field, & + u, v, config_flags, & + spec_zone, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine sets zero gradient conditions for outflow and zero value +! for inflow in the boundary specified region. Note that field must be unstaggered. +! The velocities, u and v, will only be used to check their sign (coupled vels OK) +! spec_zone is the width of the outer specified b.c.s that are set here. +! (JD August 2000) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_zone + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v + TYPE( grid_config_rec_type ) config_flags + + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner + INTEGER :: b_dist, b_limit + LOGICAL :: periodic_x + + periodic_x = config_flags%periodic_x + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(periodic_x)i_inner = i + IF(v(i,k,j) .lt. 0.)THEN + field(i,k,j) = field(i_inner,k,jbs+spec_zone) + ELSE + field(i,k,j) = 0. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + i_inner = max(i,ibs+spec_zone) + i_inner = min(i_inner,ibe-spec_zone) + IF(periodic_x)i_inner = i + IF(v(i,k,j+1) .gt. 0.)THEN + field(i,k,j) = field(i_inner,k,jbe-spec_zone) + ELSE + field(i,k,j) = 0. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i,k,j) .lt. 0.)THEN + field(i,k,j) = field(ibs+spec_zone,k,j_inner) + ELSE + field(i,k,j) = 0. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + j_inner = max(j,jbs+spec_zone) + j_inner = min(j_inner,jbe-spec_zone) + IF(u(i+1,k,j) .gt. 0.)THEN + field(i,k,j) = field(ibe-spec_zone,k,j_inner) + ELSE + field(i,k,j) = 0. + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE flow_dep_bdy + +!------------------------------------------------------------------------------ + + SUBROUTINE stuff_bdy_new ( data3d , space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, & + char_stagger , & + spec_bdy_width , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! This routine puts the data in the 3d arrays into the proper locations + ! for the lateral boundary arrays. + + USE module_state_description + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde + INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme + INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: spec_bdy_width + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d + REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe + REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye + CHARACTER (LEN=1) , INTENT(IN) :: char_stagger + + INTEGER :: i , ii , j , jj , k + + ! There are four lateral boundary locations that are stored. + + ! X start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! X end boundary + + IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1 + ii = ide - i + 1 + space_bdy_xe(j,k,ii) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! Y start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + space_bdy_ys(i,k,j) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! Y end boundary + + IF ( char_stagger .EQ. 'V' ) THEN + DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + 1 + space_bdy_ye(i,k,jj) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + END SUBROUTINE stuff_bdy_new + + SUBROUTINE stuff_bdytend_new ( data3dnew , data3dold , time_diff , & + space_bdy_xs, space_bdy_xe, space_bdy_ys, space_bdy_ye, & + char_stagger , & + spec_bdy_width , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! This routine puts the tendency data into the proper locations + ! for the lateral boundary arrays. + + USE module_state_description + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde + INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme + INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: spec_bdy_width + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold + REAL , DIMENSION(jms:jme,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_xs, space_bdy_xe + REAL , DIMENSION(ims:ime,kds:kde,spec_bdy_width) , INTENT(OUT) :: space_bdy_ys, space_bdy_ye + CHARACTER (LEN=1) , INTENT(IN) :: char_stagger + REAL , INTENT(IN) :: time_diff ! seconds + + INTEGER :: i , ii , j , jj , k + + ! There are four lateral boundary locations that are stored. + + ! X start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy_xs(j,k,i) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + END IF + + ! X end boundary + + IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1 + ii = ide - i + 1 + space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy_xe(j,k,ii) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + END IF + + ! Y start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy_ys(i,k,j) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + END IF + + ! Y end boundary + + IF ( char_stagger .EQ. 'V' ) THEN + DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + 1 + space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + ELSE + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy_ye(i,k,jj) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff + END DO + END DO + END DO + END IF + + END SUBROUTINE stuff_bdytend_new + +!--- old versions for use with modules that use the old bdy data structures --- + + SUBROUTINE stuff_bdy_old ( data3d , space_bdy , char_stagger , & + ijds , ijde , spec_bdy_width , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! This routine puts the data in the 3d arrays into the proper locations + ! for the lateral boundary arrays. + + USE module_state_description + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde + INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme + INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3d + REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy + CHARACTER (LEN=1) , INTENT(IN) :: char_stagger + + INTEGER :: i , ii , j , jj , k + + ! There are four lateral boundary locations that are stored. + + ! X start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! X end boundary + + IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1 + ii = ide - i + 1 + space_bdy(j,k,ii,P_XEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! Y start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + space_bdy(i,k,j,P_YSB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + ! Y end boundary + + IF ( char_stagger .EQ. 'V' ) THEN + DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + 1 + space_bdy(i,k,jj,P_YEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = data3d(i,k,j) + END DO + END DO + END DO + ELSE + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = data3d(i,k,j) + END DO + END DO + END DO + END IF + + END SUBROUTINE stuff_bdy_old + + SUBROUTINE stuff_bdytend_old ( data3dnew , data3dold , time_diff , space_bdy , char_stagger , & + ijds , ijde , spec_bdy_width , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! This routine puts the tendency data into the proper locations + ! for the lateral boundary arrays. + + USE module_state_description + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde + INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme + INTEGER , INTENT(IN) :: its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: ijds , ijde , spec_bdy_width + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: data3dnew , data3dold +! REAL , DIMENSION(:,:,:,:) , INTENT(OUT) :: space_bdy + REAL , DIMENSION(ijds:ijde,kds:kde,spec_bdy_width,4) , INTENT(OUT) :: space_bdy + CHARACTER (LEN=1) , INTENT(IN) :: char_stagger + REAL , INTENT(IN) :: time_diff ! seconds + + INTEGER :: i , ii , j , jj , k + + ! There are four lateral boundary locations that are stored. + + ! X start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,i,P_XSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,i,P_XSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,i,P_XSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ids + spec_bdy_width - 1,ite) + space_bdy(j,k,i,P_XSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,i,P_XSB) = 0. ! zeroout + END DO + END DO + END DO + END IF + + ! X end boundary + + IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide,ite) , MAX(ide - spec_bdy_width + 1,its) , -1 + ii = ide - i + 1 + space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'V' ) THEN + DO j = MAX(jds,jts) , MIN(jde,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jde-1,jte) + DO k = kds , kde - 1 + DO i = MIN(ide - 1,ite) , MAX(ide - spec_bdy_width,its) , -1 + ii = ide - i + space_bdy(j,k,ii,P_XEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(j,k,ii,P_XEB) = 0. ! zeroout + END DO + END DO + END DO + END IF + + ! Y start boundary + + IF ( char_stagger .EQ. 'W' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,j,P_YSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,j,P_YSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,j,P_YSB) = 0. ! zeroout + END DO + END DO + END DO + ELSE + DO j = MAX(jds,jts) , MIN(jds + spec_bdy_width - 1,jte) + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + space_bdy(i,k,j,P_YSB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,j,P_YSB) = 0. ! zeroout + END DO + END DO + END DO + END IF + + ! Y end boundary + + IF ( char_stagger .EQ. 'V' ) THEN + DO j = MIN(jde,jte) , MAX(jde - spec_bdy_width + 1,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + 1 + space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'U' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'W' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE IF ( char_stagger .EQ. 'M' ) THEN + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout + END DO + END DO + END DO + ELSE + DO j = MIN(jde-1,jte) , MAX(jde - spec_bdy_width,jts) , -1 + DO k = kds , kde - 1 + DO i = MAX(ids,its) , MIN(ide-1,ite) + jj = jde - j + space_bdy(i,k,jj,P_YEB) = ( data3dnew(i,k,j) - data3dold(i,k,j) ) / time_diff +! space_bdy(i,k,jj,P_YEB) = 0. ! zeroout + END DO + END DO + END DO + END IF + + END SUBROUTINE stuff_bdytend_old + +END MODULE module_bc + +SUBROUTINE get_bdyzone_x ( bzx ) + USE module_bc + IMPLICIT NONE + INTEGER bzx + bzx = bdyzone_x +END SUBROUTINE get_bdyzone_x + +SUBROUTINE get_bdyzone_y ( bzy) + USE module_bc + IMPLICIT NONE + INTEGER bzy + bzy = bdyzone_y +END SUBROUTINE get_bdyzone_y + +SUBROUTINE get_bdyzone ( bz) + USE module_bc + IMPLICIT NONE + INTEGER bz + bz = bdyzone +END SUBROUTINE get_bdyzone + diff --git a/wrfv2_fire/share/module_bc_time_utilities.F b/wrfv2_fire/share/module_bc_time_utilities.F new file mode 100644 index 00000000..da264bc3 --- /dev/null +++ b/wrfv2_fire/share/module_bc_time_utilities.F @@ -0,0 +1,36 @@ +!WRF:MODEL_LAYER:bc_time_utilities +! + +MODULE module_bc_time_utilities + USE module_utility + + Type(WRFU_Time), PRIVATE, SAVE :: time_to_read_again + +CONTAINS + + LOGICAL FUNCTION lbc_read_time ( xtime ) + IMPLICIT NONE + Type (WRFU_Time), INTENT(IN) :: xtime + IF ( xtime .LT. time_to_read_again ) THEN + lbc_read_time = .false. + ELSE + lbc_read_time = .true. + ENDIF + RETURN + END FUNCTION lbc_read_time + + SUBROUTINE set_time_to_read_again ( newtime ) + IMPLICIT NONE + Type(WRFU_Time), INTENT(IN) :: newtime + time_to_read_again = newtime + RETURN + END SUBROUTINE set_time_to_read_again + + SUBROUTINE get_time_to_read_again ( newtime ) + IMPLICIT NONE + Type(WRFU_Time), INTENT(OUT) :: newtime + newtime = time_to_read_again + RETURN + END SUBROUTINE get_time_to_read_again + +END MODULE module_bc_time_utilities diff --git a/wrfv2_fire/share/module_compute_geop.F b/wrfv2_fire/share/module_compute_geop.F new file mode 100644 index 00000000..a6e4d8a8 --- /dev/null +++ b/wrfv2_fire/share/module_compute_geop.F @@ -0,0 +1,96 @@ +MODULE module_compute_geop + +CONTAINS + SUBROUTINE compute_500mb_height ( ph, phb, p, pb, & + height, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + + ! Input data. + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: & + ph, & + phb, & + pb, & + p + + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT( OUT) :: height + +! local variables + + integer :: i,j,k + real, dimension(kms:kme) :: pressure,geopotential + real :: interp_output + +! slow version of code, we'll call interp routine for each column + + do j = jts, min(jde-1,jte) + do i = its, min(ide-1,ite) + + do k=kds,kde + pressure(k) = p(i,k,j) + pb(i,k,j) + geopotential(k) = 0.5*( ph(i,k ,j)+phb(i,k ,j) & + +ph(i,k+1,j)+phb(i,k+1,j) ) + enddo + + call interp_p( geopotential, pressure, 50000., interp_output, & + kds,kde-1,kms,kme, i,j ) + + height(i,j) = interp_output/9.81 ! 500 mb height in meters + + enddo + enddo + + end subroutine compute_500mb_height + +!-------- + + subroutine interp_p(a,p,p_loc,a_interp,ks,ke,kms,kme,i,j) + implicit none + + integer, intent(in) :: ks,ke,kms,kme,i,j + real, dimension(kms:kme), intent(in) :: a,p + real, intent(in) :: p_loc + real, intent(out) :: a_interp + +!--- local variables + + integer :: kp, pk, k + real :: wght1, wght2, dp, pressure + character*256 mess + + kp = ks+1 + pk = p(kp) + pressure = p_loc + do while( pk .gt. pressure ) + + kp = kp+1 + + if(kp .gt. ke) then + write(mess,*) ' interp too high: pressure, p(ke), i, j = ',pressure,p(ke),i,j + write(0,*)'p: ',p + call wrf_error_fatal( mess ) + end if + + pk = p(kp) + + enddo + + dp = p(kp-1) - p(kp) + wght2 = (p(kp-1)-pressure)/dp + wght1 = 1.-wght2 + + a_interp = wght1*a(kp-1) + wght2*a(kp) + + end subroutine interp_p + +END MODULE module_compute_geop diff --git a/wrfv2_fire/share/module_date_time.F b/wrfv2_fire/share/module_date_time.F new file mode 100644 index 00000000..55683453 --- /dev/null +++ b/wrfv2_fire/share/module_date_time.F @@ -0,0 +1,876 @@ +!WRF:MODEL_LAYER:UTIL +! +MODULE module_date_time + + USE module_wrf_error + USE module_configure + + CHARACTER* 24 :: start_date = ' ' + CHARACTER* 24 :: current_date + INTEGER , PARAMETER :: len_current_date = 24 + REAL , PRIVATE :: xtime + +! 1. geth_idts (ndate, odate, idts) +! Get the time period between two dates. + +! 2. geth_newdate ( ndate, odate, idts) +! Get the new date based on the old date and a time difference. + +! 3. split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth) +! Given the date, return the integer components. + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE get_julgmt(date_str,julyr,julday,gmt) + IMPLICIT NONE +! Arguments + CHARACTER (LEN=24) , INTENT(IN) :: date_str + INTEGER, INTENT(OUT ) :: julyr + INTEGER, INTENT(OUT ) :: julday + REAL , INTENT(OUT ) :: gmt +! Local + INTEGER :: ny , nm , nd , nh , ni , ns , nt + INTEGER :: my1, my2, my3, monss + INTEGER, DIMENSION(12) :: mmd + DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/ + CALL split_date_char ( date_str , ny , nm , nd , nh , ni , ns , nt ) + GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600. + MY1=MOD(ny,4) + MY2=MOD(ny,100) + MY3=MOD(ny,400) + IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29 + JULDAY=nd + JULYR=ny + DO MONSS=1,nm-1 + JULDAY=JULDAY+MMD(MONSS) + ENDDO + END SUBROUTINE get_julgmt + + + SUBROUTINE geth_julgmt(julyr,julday, gmt) + IMPLICIT NONE +! Arguments + INTEGER, INTENT(OUT ) :: julyr + INTEGER, INTENT(OUT ) :: julday + REAL , INTENT(OUT ) :: gmt +! Local + INTEGER :: ny , nm , nd , nh , ni , ns , nt + INTEGER :: my1, my2, my3, monss + INTEGER, DIMENSION(12) :: mmd + DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/ + CALL split_date_char ( current_date , ny , nm , nd , nh , ni , ns , nt ) + GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600. + MY1=MOD(ny,4) + MY2=MOD(ny,100) + MY3=MOD(ny,400) + IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29 + JULDAY=nd + JULYR=ny + DO MONSS=1,nm-1 + JULDAY=JULDAY+MMD(MONSS) + ENDDO + END SUBROUTINE geth_julgmt + + SUBROUTINE calc_current_date (id, time) +! This subroutines calculates current_date and xtime + IMPLICIT NONE +! Arguments + INTEGER, INTENT(IN ) :: id ! grid id + REAL, INTENT(IN ) :: time ! time in seconds since start time +! Local + INTEGER :: julyr, julday, idt + CHARACTER*19 new_date + CHARACTER*24 base_date + CHARACTER*128 mess + REAL :: gmt + + xtime = time/60. + CALL nl_get_gmt (id, gmt) + CALL nl_get_julyr (id, julyr) + CALL nl_get_julday (id, julday) + idt = 86400*(julday-1)+nint(3600*gmt) + write (mess,*) 'calc_current_date called: time = ',time,' idt = ',idt + CALL wrf_debug(300,TRIM(mess)) + write (mess,*) 'calc_current_date called: gmt = ',gmt + CALL wrf_debug(300,TRIM(mess)) + write (mess,*) 'calc_current_date called: julyr = ',julyr + CALL wrf_debug(300,TRIM(mess)) + write (mess,*) 'calc_current_date called: julday = ',julday + CALL wrf_debug(300,TRIM(mess)) + base_date = '0000-01-01_00:00:00.0000' + write(base_date(1:4),'(I4.4)')julyr + CALL geth_newdate (start_date(1:19), base_date(1:19), idt) + CALL geth_newdate (new_date, start_date(1:19), nint(time)) + write (current_date(1:24),fmt=340)new_date + 340 format(a19, '.0000') + write (mess,*) current_date,gmt,julday,julyr,'=current_date,gmt,julday,julyr: calc_current_date' + CALL wrf_debug(300,TRIM(mess)) + END SUBROUTINE calc_current_date + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE geth_idts (ndate, odate, idts) + + IMPLICIT NONE + + ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), + ! compute the time difference. + + ! on entry - ndate - the new hdate. + ! odate - the old hdate. + + ! on exit - idts - the change in time in seconds. + + CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate + INTEGER , INTENT(OUT) :: idts + + ! Local Variables + + ! yrnew - indicates the year associated with "ndate" + ! yrold - indicates the year associated with "odate" + ! monew - indicates the month associated with "ndate" + ! moold - indicates the month associated with "odate" + ! dynew - indicates the day associated with "ndate" + ! dyold - indicates the day associated with "odate" + ! hrnew - indicates the hour associated with "ndate" + ! hrold - indicates the hour associated with "odate" + ! minew - indicates the minute associated with "ndate" + ! miold - indicates the minute associated with "odate" + ! scnew - indicates the second associated with "ndate" + ! scold - indicates the second associated with "odate" + ! i - loop counter + ! mday - a list assigning the number of days in each month + + CHARACTER (LEN=24) :: tdate + INTEGER :: olen, nlen + INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew + INTEGER :: yrold, moold, dyold, hrold, miold, scold + INTEGER :: mday(12), i, newdys, olddys + LOGICAL :: npass, opass + INTEGER :: isign + + IF (odate.GT.ndate) THEN + isign = -1 + tdate=ndate + ndate=odate + odate=tdate + ELSE + isign = 1 + END IF + + ! Assign the number of days in a months + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + olen = LEN(odate) + + READ(odate(1:4), '(I4)') yrold + READ(odate(6:7), '(I2)') moold + READ(odate(9:10), '(I2)') dyold + IF (olen.GE.13) THEN + READ(odate(12:13),'(I2)') hrold + IF (olen.GE.16) THEN + READ(odate(15:16),'(I2)') miold + IF (olen.GE.19) THEN + READ(odate(18:19),'(I2)') scold + END IF + END IF + END IF + + ! Break down new hdate into parts + + hrnew = 0 + minew = 0 + scnew = 0 + nlen = LEN(ndate) + + READ(ndate(1:4), '(I4)') yrnew + READ(ndate(6:7), '(I2)') monew + READ(ndate(9:10), '(I2)') dynew + IF (nlen.GE.13) THEN + READ(ndate(12:13),'(I2)') hrnew + IF (nlen.GE.16) THEN + READ(ndate(15:16),'(I2)') minew + IF (nlen.GE.19) THEN + READ(ndate(18:19),'(I2)') scnew + END IF + END IF + END IF + + ! Check that the dates make sense. + + npass = .true. + opass = .true. + + ! Check that the month of NDATE makes sense. + + IF ((monew.GT.12).or.(monew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Month of NDATE = ', monew + npass = .false. + END IF + + ! Check that the month of ODATE makes sense. + + IF ((moold.GT.12).or.(moold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Month of ODATE = ', moold + opass = .false. + END IF + + ! Check that the day of NDATE makes sense. + + IF (monew.ne.2) THEN + ! ...... For all months but February + IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + END IF + ELSE IF (monew.eq.2) THEN + ! ...... For February + IF ((dynew.GT.nfeb(yrnew)).OR.(dynew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + END IF + END IF + + ! Check that the day of ODATE makes sense. + + IF (moold.ne.2) THEN + ! ...... For all months but February + IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + END IF + ELSE IF (moold.eq.2) THEN + ! ....... For February + IF ((dyold.GT.nfeb(yrold)).or.(dyold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + END IF + END IF + + ! Check that the hour of NDATE makes sense. + + IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN + PRINT*, 'GETH_IDTS: Hour of NDATE = ', hrnew + npass = .false. + END IF + + ! Check that the hour of ODATE makes sense. + + IF ((hrold.GT.23).or.(hrold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Hour of ODATE = ', hrold + opass = .false. + END IF + + ! Check that the minute of NDATE makes sense. + + IF ((minew.GT.59).or.(minew.LT.0)) THEN + PRINT*, 'GETH_IDTS: Minute of NDATE = ', minew + npass = .false. + END IF + + ! Check that the minute of ODATE makes sense. + + IF ((miold.GT.59).or.(miold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Minute of ODATE = ', miold + opass = .false. + END IF + + ! Check that the second of NDATE makes sense. + + IF ((scnew.GT.59).or.(scnew.LT.0)) THEN + PRINT*, 'GETH_IDTS: SECOND of NDATE = ', scnew + npass = .false. + END IF + + ! Check that the second of ODATE makes sense. + + IF ((scold.GT.59).or.(scold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Second of ODATE = ', scold + opass = .false. + END IF + + IF (.not. npass) THEN + WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad NDATE: ', ndate(1:nlen) + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + END IF + + IF (.not. opass) THEN + WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad ODATE: ', odate(1:olen) + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + END IF + + ! Date Checks are completed. Continue. + + ! Compute number of days from 1 January ODATE, 00:00:00 until ndate + ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate + + newdys = 0 + DO i = yrold, yrnew - 1 + newdys = newdys + (365 + (nfeb(i)-28)) + END DO + + IF (monew .GT. 1) THEN + mday(2) = nfeb(yrnew) + DO i = 1, monew - 1 + newdys = newdys + mday(i) + END DO + mday(2) = 28 + END IF + + newdys = newdys + dynew-1 + + ! Compute number of hours from 1 January ODATE, 00:00:00 until odate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate + + olddys = 0 + + IF (moold .GT. 1) THEN + mday(2) = nfeb(yrold) + DO i = 1, moold - 1 + olddys = olddys + mday(i) + END DO + mday(2) = 28 + END IF + + olddys = olddys + dyold-1 + + ! Determine the time difference in seconds + + idts = (newdys - olddys) * 86400 + idts = idts + (hrnew - hrold) * 3600 + idts = idts + (minew - miold) * 60 + idts = idts + (scnew - scold) + + IF (isign .eq. -1) THEN + tdate=ndate + ndate=odate + odate=tdate + idts = idts * isign + END IF + + END SUBROUTINE geth_idts + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE geth_newdate (ndate, odate, idt) + + IMPLICIT NONE + + ! From old date ('YYYY-MM-DD HH:MM:SS.ffff') and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + INTEGER , INTENT(IN) :: idt + CHARACTER (LEN=*) , INTENT(OUT) :: ndate + CHARACTER (LEN=*) , INTENT(IN) :: odate + + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + INTEGER :: nlen, olen + INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + INTEGER :: yrold, moold, dyold, hrold, miold, scold, frold + INTEGER :: mday(12), nday, nhour, nmin, nsec, nfrac, i, ifrc + LOGICAL :: opass + CHARACTER (LEN=10) :: hfrc + CHARACTER (LEN=1) :: sp + ! INTEGER, EXTERNAL :: nfeb ! in the same module now + + ! Assign the number of days in a months + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + olen = LEN(odate) + IF (olen.GE.11) THEN + sp = odate(11:11) + else + sp = ' ' + END IF + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + READ(odate(1:4), '(I4)') yrold + READ(odate(6:7), '(I2)') moold + READ(odate(9:10), '(I2)') dyold + IF (olen.GE.13) THEN + READ(odate(12:13),'(I2)') hrold + IF (olen.GE.16) THEN + READ(odate(15:16),'(I2)') miold + IF (olen.GE.19) THEN + READ(odate(18:19),'(I2)') scold + IF (olen.GT.20) THEN + READ(odate(21:olen),'(I2)') frold + END IF + END IF + END IF + END IF + + ! Set the number of days in February for that year. + + mday(2) = nfeb(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + IF ((moold.GT.12).or.(moold.LT.1)) THEN + WRITE(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold + opass = .FALSE. + END IF + + ! Check that the day of ODATE makes sense. + + IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN + WRITE(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold + opass = .FALSE. + END IF + + ! Check that the hour of ODATE makes sense. + + IF ((hrold.GT.23).or.(hrold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold + opass = .FALSE. + END IF + + ! Check that the minute of ODATE makes sense. + + IF ((miold.GT.59).or.(miold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold + opass = .FALSE. + END IF + + ! Check that the second of ODATE makes sense. + + IF ((scold.GT.59).or.(scold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold + opass = .FALSE. + END IF + + ! Check that the fractional part of ODATE makes sense. + + + IF (.not.opass) THEN + WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Bad ODATE: ', odate(1:olen), olen + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + END IF + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + IF (olen.GT.20) THEN !idt should be in fractions of seconds + ifrc = olen-20 + ifrc = 10**ifrc + nday = ABS(idt)/(86400*ifrc) + nhour = MOD(ABS(idt),86400*ifrc)/(3600*ifrc) + nmin = MOD(ABS(idt),3600*ifrc)/(60*ifrc) + nsec = MOD(ABS(idt),60*ifrc)/(ifrc) + nfrac = MOD(ABS(idt), ifrc) + ELSE IF (olen.eq.19) THEN !idt should be in seconds + ifrc = 1 + nday = ABS(idt)/86400 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),86400)/3600 + nmin = MOD(ABS(idt),3600)/60 + nsec = MOD(ABS(idt),60) + nfrac = 0 + ELSE IF (olen.eq.16) THEN !idt should be in minutes + ifrc = 1 + nday = ABS(idt)/1440 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),1440)/60 + nmin = MOD(ABS(idt),60) + nsec = 0 + nfrac = 0 + ELSE IF (olen.eq.13) THEN !idt should be in hours + ifrc = 1 + nday = ABS(idt)/24 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + ELSE IF (olen.eq.10) THEN !idt should be in days + ifrc = 1 + nday = ABS(idt)/24 ! Integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + ELSE + WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Strange length for ODATE: ',olen + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + END IF + + IF (idt.GE.0) THEN + + frnew = frold + nfrac + IF (frnew.GE.ifrc) THEN + frnew = frnew - ifrc + nsec = nsec + 1 + END IF + + scnew = scold + nsec + IF (scnew .GE. 60) THEN + scnew = scnew - 60 + nmin = nmin + 1 + END IF + + minew = miold + nmin + IF (minew .GE. 60) THEN + minew = minew - 60 + nhour = nhour + 1 + END IF + + hrnew = hrold + nhour + IF (hrnew .GE. 24) THEN + hrnew = hrnew - 24 + nday = nday + 1 + END IF + + dynew = dyold + monew = moold + yrnew = yrold + DO i = 1, nday + dynew = dynew + 1 + IF (dynew.GT.mday(monew)) THEN + dynew = dynew - mday(monew) + monew = monew + 1 + IF (monew .GT. 12) THEN + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + END IF + END IF + END DO + + ELSE IF (idt.LT.0) THEN + + frnew = frold - nfrac + IF (frnew .LT. 0) THEN + frnew = frnew + ifrc + nsec = nsec - 1 + END IF + + scnew = scold - nsec + IF (scnew .LT. 00) THEN + scnew = scnew + 60 + nmin = nmin + 1 + END IF + + minew = miold - nmin + IF (minew .LT. 00) THEN + minew = minew + 60 + nhour = nhour + 1 + END IF + + hrnew = hrold - nhour + IF (hrnew .LT. 00) THEN + hrnew = hrnew + 24 + nday = nday + 1 + END IF + + dynew = dyold + monew = moold + yrnew = yrold + DO i = 1, nday + dynew = dynew - 1 + IF (dynew.eq.0) THEN + monew = monew - 1 + IF (monew.eq.0) THEN + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + END IF + dynew = mday(monew) + END IF + END DO + END IF + + ! Now construct the new mdate + + nlen = LEN(ndate) + + IF (nlen.GT.20) THEN + WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew + WRITE(hfrc,'(I10)') frnew+1000000000 + ndate = ndate(1:19)//'.'//hfrc(31-nlen:10) + + ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN + WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew + 19 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2) + IF (nlen.eq.20) ndate = ndate(1:19)//'.' + + ELSE IF (nlen.eq.16) THEN + WRITE(ndate,16) yrnew, monew, dynew, hrnew, minew + 16 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2) + + ELSE IF (nlen.eq.13) THEN + WRITE(ndate,13) yrnew, monew, dynew, hrnew + 13 format(I4,'-',I2.2,'-',I2.2,'_',I2.2) + + ELSE IF (nlen.eq.10) THEN + WRITE(ndate,10) yrnew, monew, dynew + 10 format(I4,'-',I2.2,'-',I2.2) + + END IF + + IF (olen.GE.11) ndate(11:11) = sp + + END SUBROUTINE geth_newdate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + FUNCTION nfeb ( year ) RESULT (num_days) + + ! Compute the number of days in February for the given year + + IMPLICIT NONE + + INTEGER :: year + INTEGER :: num_days + + num_days = 28 ! By default, February has 28 days ... + IF (MOD(year,4).eq.0) THEN + num_days = 29 ! But every four years, it has 29 days ... + IF (MOD(year,100).eq.0) THEN + num_days = 28 ! Except every 100 years, when it has 28 days ... + IF (MOD(year,400).eq.0) THEN + num_days = 29 ! Except every 400 years, when it has 29 days. + END IF + END IF + END IF + + END FUNCTION nfeb + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth) + + IMPLICIT NONE + + ! Input data. + + CHARACTER(LEN=24) , INTENT(IN) :: date + + ! Output data. + + INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second , ten_thousandth + + READ(date,FMT='( I4)') century_year + READ(date,FMT='( 5X,I2)') month + READ(date,FMT='( 8X,I2)') day + READ(date,FMT='(11X,I2)') hour + READ(date,FMT='(14X,I2)') minute + READ(date,FMT='(17X,I2)') second + READ(date,FMT='(20X,I4)') ten_thousandth + + END SUBROUTINE split_date_char + + SUBROUTINE init_module_date_time + END SUBROUTINE init_module_date_time + +END MODULE module_date_time + + + ! TBH: NOTE: + ! TBH: Linkers whine if these routines are placed inside the module. Not + ! TBH: sure if these should live here or inside an external package. They + ! TBH: have dependencies both on WRF (for the format of the WRF date-time + ! TBH: strings) and on the time manager. Currently, the format of the WRF + ! TBH: date-time strings is a slight variant on ISO 8601 (ISO is + ! TBH: "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss"). If we + ! TBH: change the WRF format to match the standard, then we remove the + ! TBH: WRF dependence... + + ! Converts WRF date-time string into an WRFU_Time object. + ! The format of the WRF date-time strings is a slight variant on ISO 8601: + ! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss". + SUBROUTINE wrf_atotime ( str, time ) + USE module_utility + CHARACTER (LEN=*), INTENT( IN) :: str + TYPE(WRFU_Time), INTENT(OUT) :: time + INTEGER yr, mm, dd, h, m, s, ms + INTEGER rc + IF ( LEN( str ) .GE. 20 ) THEN + IF ( str(20:20) .EQ. '.' ) THEN + READ(str,34) yr,mm,dd,h,m,s,ms + ! last four digits are ten-thousandths of a sec, convert to ms + ms=nint(real(ms)/10) + ELSE + READ(str,33) yr,mm,dd,h,m,s + ms = 0 + ENDIF + ELSE + READ(str,33) yr,mm,dd,h,m,s + ms = 0 + ENDIF + CALL WRFU_TimeSet( time, YY=yr, MM=mm, DD=dd, H=h, M=m, S=s, MS=ms, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet() in wrf_atotime() FAILED', & + __FILE__ , & + __LINE__ ) +33 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2) +34 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I4.4) + RETURN + END SUBROUTINE wrf_atotime + + + + ! Converts an WRFU_Time object into a WRF date-time string. + ! The format of the WRF date-time strings is a slight variant on ISO 8601: + ! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss". + SUBROUTINE wrf_timetoa ( time, str ) + USE module_utility + TYPE(WRFU_Time), INTENT( IN) :: time + CHARACTER (LEN=*), INTENT(OUT) :: str + INTEGER strlen, rc + CHARACTER (LEN=256) :: mess, tmpstr + ! Assertion + IF ( LEN(str) < 19 ) THEN + CALL wrf_error_fatal( 'wrf_timetoa: str is too short' ) + ENDIF + tmpstr = '' + CALL WRFU_TimeGet( time, timeString=tmpstr, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeGet() in wrf_timetoa() FAILED', & + __FILE__ , & + __LINE__ ) + ! change ISO 8601 'T' to WRF '_' and hack off fraction if str is not + ! big enough to hold it + strlen = MIN( LEN(str), LEN_TRIM(tmpstr) ) + str = '' + str(1:strlen) = tmpstr(1:strlen) + str(11:11) = '_' + WRITE (mess,*) 'DEBUG wrf_timetoa(): returning with str = [',TRIM(str),']' + CALL wrf_debug ( 150 , TRIM(mess) ) + RETURN + END SUBROUTINE wrf_timetoa + + + + ! Converts an WRFU_TimeInterval object into a time-interval string. + SUBROUTINE wrf_timeinttoa ( timeinterval, str ) + USE module_utility + TYPE(WRFU_TimeInterval), INTENT( IN) :: timeinterval + CHARACTER (LEN=*), INTENT(OUT) :: str + INTEGER rc + CHARACTER (LEN=256) :: mess + CALL WRFU_TimeIntervalGet( timeinterval, timeString=str, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalGet() in wrf_timeinttoa() FAILED', & + __FILE__ , & + __LINE__ ) + WRITE (mess,*) 'DEBUG wrf_timeinttoa(): returning with str = [',TRIM(str),']' + CALL wrf_debug ( 150 , TRIM(mess) ) + RETURN + END SUBROUTINE wrf_timeinttoa + + + + ! Debug routine to print key clock information. + ! Every printed line begins with pre_str. + SUBROUTINE wrf_clockprint ( level, clock, pre_str ) + USE module_utility + INTEGER, INTENT( IN) :: level + TYPE(WRFU_Clock), INTENT( IN) :: clock + CHARACTER (LEN=*), INTENT( IN) :: pre_str + INTEGER rc + INTEGER :: debug_level + TYPE(WRFU_Time) :: currTime, startTime, stopTime + TYPE(WRFU_TimeInterval) :: timeStep + CHARACTER (LEN=64) :: currTime_str, startTime_str, stopTime_str + CHARACTER (LEN=64) :: timeStep_str + CHARACTER (LEN=256) :: mess + CALL get_wrf_debug_level( debug_level ) + IF ( level .LE. debug_level ) THEN + CALL WRFU_ClockGet( clock, CurrTime=currTime, StartTime=startTime, & + StopTime=stopTime, TimeStep=timeStep, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'wrf_clockprint: WRFU_ClockGet() FAILED', & + __FILE__ , & + __LINE__ ) + CALL wrf_timetoa( currTime, currTime_str ) + CALL wrf_timetoa( startTime, startTime_str ) + CALL wrf_timetoa( stopTime, stopTime_str ) + CALL wrf_timeinttoa( timeStep, timeStep_str ) + WRITE (mess,*) TRIM(pre_str),' clock start time = ',TRIM(startTime_str) + CALL wrf_message(TRIM(mess)) + WRITE (mess,*) TRIM(pre_str),' clock current time = ',TRIM(currTime_str) + CALL wrf_message(TRIM(mess)) + WRITE (mess,*) TRIM(pre_str),' clock stop time = ',TRIM(stopTime_str) + CALL wrf_message(TRIM(mess)) + WRITE (mess,*) TRIM(pre_str),' clock time step = ',TRIM(timeStep_str) + CALL wrf_message(TRIM(mess)) + ENDIF + RETURN + END SUBROUTINE wrf_clockprint + diff --git a/wrfv2_fire/share/module_get_file_names.F b/wrfv2_fire/share/module_get_file_names.F new file mode 100644 index 00000000..ac01901d --- /dev/null +++ b/wrfv2_fire/share/module_get_file_names.F @@ -0,0 +1,192 @@ +MODULE module_get_file_names + +! This module is used by the ndown program. We can have multiple output +! files generated from the wrf program. To remove the what-are-the- +! files-to-input-to-ndown task from the user, we use a couple of UNIX +! commands. These are activated from either the "system" command or +! the "exec" command. Neither is part of the Fortran standard. + + INTEGER :: number_of_eligible_files + CHARACTER(LEN=132) , DIMENSION(:) , ALLOCATABLE :: eligible_file_name + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef crayx1 + SUBROUTINE system(cmd) + IMPLICIT NONE + CHARACTER (LEN=*) , INTENT(IN) :: cmd + integer :: ierr + call pxfsystem(cmd, len(cmd), ierr) + RETURN + END SUBROUTINE system +#endif + + SUBROUTINE unix_ls ( root , id ) + USE module_dm + + IMPLICIT NONE + + CHARACTER (LEN=*) , INTENT(IN) :: root + INTEGER , INTENT(IN) :: id + + CHARACTER (LEN=132) :: command + INTEGER :: ierr , loop , loslen , strlen + LOGICAL :: unix_access_ok + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*256 message + + ! This is to make sure that we successfully use one of the available methods + ! for getting at a UNIX command. This is an initialized flag. + + unix_access_ok = .FALSE. + + ! Build a UNIX command, and "ls", of all of the files mnatching the "root*" prefix. + + monitor_only_code : IF ( wrf_dm_on_monitor() ) THEN + + loslen = LEN ( command ) + CALL all_spaces ( command , loslen ) + WRITE ( command , FMT='("ls -1 ",A,"*d",I2.2,"* > .foo")' ) TRIM ( root ) , id + + ! We stuck all of the matching files in the ".foo" file. Now we place the + ! number of the those file (i.e. how many there are) in ".foo1". Also, if we + ! do get inside one of these CPP ifdefs, then we set our access flag to true. + +#ifdef NONSTANDARD_SYSTEM + CALL SYSTEM ( TRIM ( command ) ) + CALL SYSTEM ( '( cat .foo | wc -l > .foo1 )' ) + unix_access_ok = .TRUE. +#endif +#ifdef NONSTANDARD_EXEC + CALL SYSTEM ( TRIM ( command ) ) + CALL SYSTEM ( '( cat .foo | wc -l > .foo1 )' ) + unix_access_ok = .TRUE. +#endif + + ! Test to be sure that we did indeed hit one of the ifdefs. + + IF ( .NOT. unix_access_ok ) THEN + PRINT *,'Oops, how can I access UNIX commands from Fortran?' + CALL wrf_error_fatal ( 'system_or_exec_only' ) + END IF + + ! Read the number of files. + + OPEN (FILE = '.foo1' , & + UNIT = 112 , & + STATUS = 'OLD' , & + ACCESS = 'SEQUENTIAL' , & + FORM = 'FORMATTED' ) + + READ ( 112 , * ) number_of_eligible_files + CLOSE ( 112 ) + + ! If there are zero files, we are toast. + + IF ( number_of_eligible_files .LE. 0 ) THEN + PRINT *,'Oops, we need at least ONE input file (wrfout*) for the ndown program to read.' + CALL wrf_error_fatal ( 'need_wrfout_input_data' ) + END IF + + ENDIF monitor_only_code + + ! On the monitor proc, we got the number of files. We use that number to + ! allocate space on all of the procs. + + CALL wrf_dm_bcast_integer ( number_of_eligible_files, 1 ) + + ! Allocate space for this many files. + + ALLOCATE ( eligible_file_name(number_of_eligible_files) , STAT=ierr ) + + ! Did the allocate work OK? + + IF ( ierr .NE. 0 ) THEN +print *,'tried to allocate ',number_of_eligible_files,' eligible files, (look at ./foo)' + WRITE(message,*)'module_get_file_names: unix_ls: unable to allocate filename array Status = ',ierr + CALL wrf_error_fatal( message ) + END IF + + ! Initialize all of the file names to blank. + + CALL init_module_get_file_names + + ! Now we go back to a single monitor proc to read in the file names. + + monitor_only_code2: IF ( wrf_dm_on_monitor() ) THEN + + ! Open the file that has the list of filenames. + + OPEN (FILE = '.foo' , & + UNIT = 111 , & + STATUS = 'OLD' , & + ACCESS = 'SEQUENTIAL' , & + FORM = 'FORMATTED' ) + + ! Read all of the file names and store them. + + DO loop = 1 , number_of_eligible_files + READ ( 111 , FMT='(A)' ) eligible_file_name(loop) +print *,TRIM(eligible_file_name(loop)) + END DO + CLOSE ( 111 ) + + ! We clean up our own messes. + +#ifdef NONSTANDARD_SYSTEM + CALL SYSTEM ( '/bin/rm -f .foo' ) + CALL SYSTEM ( '/bin/rm -f .foo1' ) +#endif +#ifdef NONSTANDARD_EXEC + CALL SYSTEM ( '/bin/rm -f .foo' ) + CALL SYSTEM ( '/bin/rm -f .foo1' ) +#endif + + ENDIF monitor_only_code2 + + ! Broadcast the file names to everyone on all of the procs. + + DO loop = 1 , number_of_eligible_files + strlen = LEN( TRIM( eligible_file_name(loop) ) ) + CALL wrf_dm_bcast_string ( eligible_file_name(loop) , strlen ) + ENDDO + + END SUBROUTINE unix_ls + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE all_spaces ( command , length_of_char ) + + IMPLICIT NONE + + INTEGER :: length_of_char + CHARACTER (LEN=length_of_char) :: command + INTEGER :: loop + + DO loop = 1 , length_of_char + command(loop:loop) = ' ' + END DO + + END SUBROUTINE all_spaces + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE init_module_get_file_names + + IMPLICIT NONE + eligible_file_name = ' ' // & + ' ' // & + ' ' + + END SUBROUTINE init_module_get_file_names + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +END MODULE module_get_file_names + +!program foo +!USE module_get_file_names +!call init_module_get_file_names +!call unix_ls ( 'wrf_real' , 1 ) +!end program foo diff --git a/wrfv2_fire/share/module_interp_fcn.F b/wrfv2_fire/share/module_interp_fcn.F new file mode 100644 index 00000000..7633f1b4 --- /dev/null +++ b/wrfv2_fire/share/module_interp_fcn.F @@ -0,0 +1,56 @@ +!WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION +! + + SUBROUTINE interp_fcn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj ) ! nest ratios + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + + ! Iterate over the ND tile and comtute the values + ! from the CD tile. + + DO nj = njts, njte + cj = cjts + nj / nrj ! coord of CD point + jp = cjts + mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = cits + ni / nri ! coord of CD point + ip = cits + mod ( ni , nri ) ! coord of ND w/i CD point + + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE interp_fcn + + diff --git a/wrfv2_fire/share/module_io_domain.F b/wrfv2_fire/share/module_io_domain.F new file mode 100644 index 00000000..15ffcaf2 --- /dev/null +++ b/wrfv2_fire/share/module_io_domain.F @@ -0,0 +1,972 @@ +!WRF:MEDIATION_LAYER:IO +! + +MODULE module_io_domain +USE module_io +USE module_io_wrf +USE module_wrf_error +USE module_date_time +USE module_configure +USE module_domain + +CONTAINS + + SUBROUTINE open_r_dataset ( id , fname , grid , config_flags , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_open_for_read ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + RETURN + END SUBROUTINE open_r_dataset + + SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + EXTERNAL outsub + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_debug ( 100 , 'calling wrf_open_for_write_begin in open_w_dataset' ) + CALL wrf_open_for_write_begin ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling outsub in open_w_dataset' ) + CALL outsub( id , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'back from outsub in open_w_dataset' ) + ENDIF + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling wrf_open_for_write_commit in open_w_dataset' ) + CALL wrf_open_for_write_commit ( id , & + ierr ) + CALL wrf_debug ( 100 , 'back from wrf_open_for_write_commit in open_w_dataset' ) + ENDIF + END SUBROUTINE open_w_dataset + + SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + EXTERNAL insub + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_debug ( 100 , 'calling wrf_open_for_read_begin in open_u_dataset' ) + CALL wrf_open_for_read_begin ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling insub in open_u_dataset' ) + CALL insub( id , grid , config_flags , ierr ) + ENDIF + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling wrf_open_for_read_commit in open_u_dataset' ) + CALL wrf_open_for_read_commit ( id , & + ierr ) + CALL wrf_debug ( 100 , 'back from wrf_open_for_read_commit in open_u_dataset' ) + ENDIF + END SUBROUTINE open_u_dataset + + SUBROUTINE close_dataset( id , config_flags, sysdepinfo ) + IMPLICIT NONE + INTEGER id , ierr + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + CHARACTER*(*) :: sysdepinfo + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_ioclose( id , ierr ) + END SUBROUTINE close_dataset + + +! ------------ Output model input data sets + + SUBROUTINE output_model_input ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_input .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , model_input_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_model_input + + SUBROUTINE output_aux_model_input1 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput1 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input1 + + SUBROUTINE output_aux_model_input2 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput2 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input2 + + SUBROUTINE output_aux_model_input3 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput3 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input3 + + SUBROUTINE output_aux_model_input4 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput4 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input4 + + SUBROUTINE output_aux_model_input5 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput5 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input5 + + SUBROUTINE output_aux_model_input6 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput6 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input6_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input6 + + SUBROUTINE output_aux_model_input7 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput7 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input7_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input7 + + SUBROUTINE output_aux_model_input8 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput8 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input8_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input8 + + SUBROUTINE output_aux_model_input9 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput9 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input9_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input9 + + SUBROUTINE output_aux_model_input10 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_gfdda .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input10_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input10 + + SUBROUTINE output_aux_model_input11 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput11 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_model_input11_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_model_input11 + +! ------------ Output model history data sets + + SUBROUTINE output_history ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_history .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , history_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_history + + SUBROUTINE output_aux_hist1 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist1 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist1 + + SUBROUTINE output_aux_hist2 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist2 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist2 + + SUBROUTINE output_aux_hist3 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist3 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist3 + + SUBROUTINE output_aux_hist4 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist4 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist4 + + SUBROUTINE output_aux_hist5 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist5 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist5 + + SUBROUTINE output_aux_hist6 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist6 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist6_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist6 + + SUBROUTINE output_aux_hist7 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist7 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist7_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist7 + + SUBROUTINE output_aux_hist8 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist8 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist8_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist8 + + SUBROUTINE output_aux_hist9 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist9 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist9_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist9 + + SUBROUTINE output_aux_hist10 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist10 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist10_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist10 + + SUBROUTINE output_aux_hist11 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist11 .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , aux_hist11_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_aux_hist11 + +! ------------ Output model restart data sets + + SUBROUTINE output_restart ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_restart .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , restart_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_restart + +! ------------ Output model boundary data sets + + SUBROUTINE output_boundary ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_boundary .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_boundary + +! ------------ Input model input data sets + + SUBROUTINE input_model_input ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_input .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , model_input_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_model_input + + SUBROUTINE input_aux_model_input1 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput1 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input1 + + SUBROUTINE input_aux_model_input2 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput2 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input2 + + SUBROUTINE input_aux_model_input3 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput3 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input3 + + SUBROUTINE input_aux_model_input4 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput4 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input4 + + SUBROUTINE input_aux_model_input5 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput5 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input5 + + SUBROUTINE input_aux_model_input6 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput6 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input6_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input6 + SUBROUTINE input_aux_model_input7 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput7 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input7_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input7 + SUBROUTINE input_aux_model_input8 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput8 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input8_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input8 + SUBROUTINE input_aux_model_input9 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput9 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input9_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input9 + SUBROUTINE input_aux_model_input10 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_gfdda .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input10_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input10 + SUBROUTINE input_aux_model_input11 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxinput11 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_model_input11_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_model_input11 + +! ------------ Input model history data sets + + SUBROUTINE input_history ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_history .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , history_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_history + + SUBROUTINE input_aux_hist1 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist1 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist1 + + SUBROUTINE input_aux_hist2 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist2 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist2 + + SUBROUTINE input_aux_hist3 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist3 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist3 + + SUBROUTINE input_aux_hist4 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist4 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist4 + + SUBROUTINE input_aux_hist5 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist5 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist5 + + SUBROUTINE input_aux_hist6 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist6 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist6_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist6 + SUBROUTINE input_aux_hist7 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist7 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist7_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist7 + SUBROUTINE input_aux_hist8 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist8 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist8_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist8 + SUBROUTINE input_aux_hist9 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist9 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist9_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist9 + SUBROUTINE input_aux_hist10 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist10 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist10_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist10 + SUBROUTINE input_aux_hist11 ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_auxhist11 .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , aux_hist11_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_aux_hist11 + +! ------------ Input model restart data sets + + SUBROUTINE input_restart ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_restart .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , restart_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_restart + +! ------------ Input model boundary data sets + + SUBROUTINE input_boundary ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_boundary .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , boundary_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_boundary + +END MODULE module_io_domain + +! move outside module so callable without USE of module +SUBROUTINE construct_filename1( result , basename , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // "_d" // TRIM(t1) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename1 + +SUBROUTINE construct_filename2( result , basename , fld1 , len1 , date_char ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename2 + +! this version looks for and in the basename and replaces with the arguments + +SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + INTEGER i, j, l + result=basename + CALL zero_pad ( t1 , fld1 , len1 ) + i = index( basename , '' ) + l = len(trim(basename)) + IF ( i .GT. 0 ) THEN + result = basename(1:i-1) // TRIM(t1) // basename(i+8:l) + ENDIF + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(date_char) // result(i+6:l) + ENDIF + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename2a + +SUBROUTINE construct_filename ( result , basename , fld1 , len1 , fld2 , len2 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2 + CHARACTER*64 :: t1, t2, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + CALL zero_pad ( t2 , fld2 , len2 ) + result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename + +SUBROUTINE construct_filename3 ( result , basename , fld1 , len1 , fld2 , len2, fld3, len3 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2, fld3, len3 + CHARACTER*64 :: t1, t2, t3, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + CALL zero_pad ( t2 , fld2 , len2 ) + CALL zero_pad ( t3 , fld3 , len3 ) + result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) // "_" // TRIM(t3) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename3 + +SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io_form ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER , INTENT(IN) :: fld1 , len1 , io_form + CHARACTER*64 :: t1, zeros + CHARACTER*4 :: ext + CALL zero_pad ( t1 , fld1 , len1 ) + IF ( io_form .EQ. 1 ) THEN + ext = '.int' + ELSE IF ( io_form .EQ. 2 ) THEN + ext = '.nc ' + ELSE IF ( io_form .EQ. 5 ) THEN + ext = '.gb ' + ELSE + CALL wrf_error_fatal ('improper io_form') + END IF + result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) // TRIM(ext) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename4 + +! this version looks for and in the basename and replaces with the arguments + +SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , io_form ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER , INTENT(IN) :: fld1 , len1 , io_form + CHARACTER*64 :: t1, zeros + CHARACTER*4 :: ext + INTEGER i, j, l + result=basename + CALL zero_pad ( t1 , fld1 , len1 ) + IF ( MOD(io_form,100) .EQ. 1 ) THEN + ext = '.int' + ELSE IF ( MOD(io_form,100) .EQ. 2 ) THEN + ext = '.nc ' + ELSE IF ( MOD(io_form,100) .EQ. 5 ) THEN + ext = '.gb ' + ELSE + CALL wrf_error_fatal ('improper io_form') + END IF + l = len(trim(basename)) + result = basename(1:l) // TRIM(ext) + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(t1) // result(i+8:l) + ENDIF + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(date_char) // result(i+6:l) + ENDIF + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename4a + +SUBROUTINE append_to_filename ( result , basename , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // "_" // TRIM(t1) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE append_to_filename + +SUBROUTINE zero_pad ( result , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + INTEGER , INTENT (IN) :: fld1 , len1 + INTEGER :: d , x + CHARACTER*64 :: t2, zeros + x = fld1 ; d = 0 + DO WHILE ( x > 0 ) + x = x / 10 + d = d + 1 + END DO + write(t2,'(I9)')fld1 + zeros = '0000000000000000000000000000000' + result = zeros(1:len1-d) // t2(9-d+1:9) + RETURN +END SUBROUTINE zero_pad + +SUBROUTINE init_wrfio + USE module_io + IMPLICIT NONE + INTEGER ierr + CALL wrf_ioinit(ierr) +END SUBROUTINE init_wrfio + +! +! This routine figures out the nearest previous time instant +! that corresponds to a multiple of the input time interval. +! Example use is to give the time instant that corresponds to +! an I/O interval, even when the current time is a little bit +! past that time when, for example, the number of model time +! steps does not evenly divide the I/O interval. JM 20051013 +! +! +SUBROUTINE adjust_io_timestr ( TI, CT, ST, timestr ) + USE module_io_domain + IMPLICIT NONE +! Args + TYPE(WRFU_Time), INTENT(IN) :: ST,CT ! domain start and current time + TYPE(WRFU_TimeInterval), INTENT(IN) :: TI ! interval + CHARACTER*(*), INTENT(INOUT) :: timestr ! returned string +! Local + TYPE(WRFU_Time) :: OT + TYPE(WRFU_TimeInterval) :: IOI + INTEGER :: n + + IOI = CT-ST ! length of time since starting + n = WRFU_TimeIntervalDIVQuot( IOI , TI ) ! number of whole time intervals + IOI = TI * n ! amount of time since starting in whole time intervals + OT = ST + IOI ! previous nearest time instant + CALL wrf_timetoa( OT, timestr ) ! generate string + RETURN +END SUBROUTINE adjust_io_timestr + +! Modify the filename to remove things like ':' from the file name +! unless it is a drive number. Convert to '_' instead. + +SUBROUTINE maybe_remove_colons( FileName ) + USE module_configure + CHARACTER*(*) FileName + CHARACTER c, d + INTEGER i, l + LOGICAL nocolons + l = LEN(TRIM(FileName)) +! do not change first two characters (naive way of dealing with +! possiblity of drive name in a microsoft path + CALL nl_get_nocolons(1,nocolons) + IF ( nocolons ) THEN + DO i = 3, l + IF ( FileName(i:i) .EQ. ':' ) THEN + FileName(i:i) = '_' + ENDIF + ENDDO + ENDIF + RETURN +END + + + diff --git a/wrfv2_fire/share/module_io_wrf.F b/wrfv2_fire/share/module_io_wrf.F new file mode 100644 index 00000000..5c87ae09 --- /dev/null +++ b/wrfv2_fire/share/module_io_wrf.F @@ -0,0 +1,61 @@ +!WRF:PACKAGE:IO +! + +MODULE module_io_wrf + + USE module_wrf_error + USE module_date_time + +! switch parameters + INTEGER, PARAMETER :: history_only=1 + INTEGER, PARAMETER :: aux_hist1_only=2 + INTEGER, PARAMETER :: aux_hist2_only=3 + INTEGER, PARAMETER :: aux_hist3_only=4 + INTEGER, PARAMETER :: aux_hist4_only=5 + INTEGER, PARAMETER :: aux_hist5_only=6 + INTEGER, PARAMETER :: aux_hist6_only=7 + INTEGER, PARAMETER :: aux_hist7_only=8 + INTEGER, PARAMETER :: aux_hist8_only=9 + INTEGER, PARAMETER :: aux_hist9_only=10 + INTEGER, PARAMETER :: aux_hist10_only=11 + INTEGER, PARAMETER :: aux_hist11_only=12 + INTEGER, PARAMETER :: model_input_only=13 + INTEGER, PARAMETER :: aux_model_input1_only=14 + INTEGER, PARAMETER :: aux_model_input2_only=15 + INTEGER, PARAMETER :: aux_model_input3_only=16 + INTEGER, PARAMETER :: aux_model_input4_only=17 + INTEGER, PARAMETER :: aux_model_input5_only=18 + INTEGER, PARAMETER :: aux_model_input6_only=19 + INTEGER, PARAMETER :: aux_model_input7_only=20 + INTEGER, PARAMETER :: aux_model_input8_only=21 + INTEGER, PARAMETER :: aux_model_input9_only=22 + INTEGER, PARAMETER :: aux_model_input10_only=23 + INTEGER, PARAMETER :: aux_model_input11_only=24 + INTEGER, PARAMETER :: restart_only=25 + INTEGER, PARAMETER :: boundary_only=26 + +CONTAINS + SUBROUTINE init_module_io_wrf + END SUBROUTINE init_module_io_wrf + +END MODULE module_io_wrf + + + SUBROUTINE debug_io_wrf ( msg , date, ds , de , ps , pe , ms , me ) + USE module_wrf_error + IMPLICIT NONE + CHARACTER*(*) :: msg , date + INTEGER , DIMENSION(3) , INTENT(IN) :: ds , de , ps , pe , ms , me + IF ( wrf_at_debug_level(300) ) THEN + CALL wrf_message ( msg ) + WRITE(wrf_err_message,*)'date ',date ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'ds ',ds ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'de ',de ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'ps ',ps ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'pe ',pe ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'ms ',ms ; CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*)'me ',me ; CALL wrf_message ( TRIM(wrf_err_message) ) + ENDIF + RETURN + END SUBROUTINE debug_io_wrf + diff --git a/wrfv2_fire/share/module_model_constants.F b/wrfv2_fire/share/module_model_constants.F new file mode 100644 index 00000000..b8949af7 --- /dev/null +++ b/wrfv2_fire/share/module_model_constants.F @@ -0,0 +1,137 @@ +!WRF:MODEL_LAYER:CONSTANTS +! + + MODULE module_model_constants + + ! 2. Following are constants for use in defining real number bounds. + + ! A really small number. + + REAL , PARAMETER :: epsilon = 1.E-15 + + ! 4. Following is information related to the physical constants. + + ! These are the physical constants used within the model. + +! JM NOTE -- can we name this grav instead? + REAL , PARAMETER :: g = 9.81 ! acceleration due to gravity (m {s}^-2) + +#if ( NMM_CORE == 1 ) + REAL , PARAMETER :: r_d = 287.04 + REAL , PARAMETER :: cp = 1004.6 +#else + REAL , PARAMETER :: r_d = 287. + REAL , PARAMETER :: cp = 7.*r_d/2. +#endif + + REAL , PARAMETER :: r_v = 461.6 + REAL , PARAMETER :: cv = cp-r_d + REAL , PARAMETER :: cpv = 4.*r_v + REAL , PARAMETER :: cvv = cpv-r_v + REAL , PARAMETER :: cvpm = -cv/cp + REAL , PARAMETER :: cliq = 4190. + REAL , PARAMETER :: cice = 2106. + REAL , PARAMETER :: psat = 610.78 + REAL , PARAMETER :: rcv = r_d/cv + REAL , PARAMETER :: rcp = r_d/cp + REAL , PARAMETER :: rovg = r_d/g + REAL , PARAMETER :: c2 = cp * rcv + real , parameter :: mwdry = 28.966 ! molecular weight of dry air (g/mole) + + REAL , PARAMETER :: p1000mb = 100000. + REAL , PARAMETER :: t0 = 300. + REAL , PARAMETER :: p0 = p1000mb + REAL , PARAMETER :: cpovcv = cp/(cp-r_d) + REAL , PARAMETER :: cvovcp = 1./cpovcv + REAL , PARAMETER :: rvovrd = r_v/r_d + + REAL , PARAMETER :: reradius = 1./6370.0e03 + + REAL , PARAMETER :: asselin = .025 +! REAL , PARAMETER :: asselin = .0 + REAL , PARAMETER :: cb = 25. + + REAL , PARAMETER :: XLV0 = 3.15E6 + REAL , PARAMETER :: XLV1 = 2370. + REAL , PARAMETER :: XLS0 = 2.905E6 + REAL , PARAMETER :: XLS1 = 259.532 + + REAL , PARAMETER :: XLS = 2.85E6 + REAL , PARAMETER :: XLV = 2.5E6 + REAL , PARAMETER :: XLF = 3.50E5 + + REAL , PARAMETER :: rhowater = 1000. + REAL , PARAMETER :: rhosnow = 100. + REAL , PARAMETER :: rhoair0 = 1.28 + + REAL , PARAMETER :: DEGRAD = 3.1415926/180. + REAL , PARAMETER :: DPD = 360./365. + + REAL , PARAMETER :: SVP1=0.6112 + REAL , PARAMETER :: SVP2=17.67 + REAL , PARAMETER :: SVP3=29.65 + REAL , PARAMETER :: SVPT0=273.15 + REAL , PARAMETER :: EP_1=R_v/R_d-1. + REAL , PARAMETER :: EP_2=R_d/R_v + REAL , PARAMETER :: KARMAN=0.4 + REAL , PARAMETER :: EOMEG=7.2921E-5 + REAL , PARAMETER :: STBOLT=5.67051E-8 + + ! proportionality constants for eddy viscosity coefficient calc + REAL , PARAMETER :: c_s = .25 ! turbulence parameterization constant, for smagorinsky + REAL , PARAMETER :: c_k = .15 ! turbulence parameterization constant, for TKE + REAL , PARAMETER :: prandtl = 1./3.0 + ! constants for w-damping option + REAL , PARAMETER :: w_alpha = 0.3 ! strength m/s/s + REAL , PARAMETER :: w_beta = 1.0 ! activation cfl number + + REAL , PARAMETER :: pq0=379.90516 + REAL , PARAMETER :: epsq2=0.2 +! REAL , PARAMETER :: epsq2=0.02 + REAL , PARAMETER :: a2=17.2693882 + REAL , PARAMETER :: a3=273.16 + REAL , PARAMETER :: a4=35.86 + REAL , PARAMETER :: epsq=1.e-12 + REAL , PARAMETER :: p608=rvovrd-1. +!#if ( NMM_CORE == 1 ) + REAL , PARAMETER :: climit=1.e-20 + REAL , PARAMETER :: cm1=2937.4 + REAL , PARAMETER :: cm2=4.9283 + REAL , PARAMETER :: cm3=23.5518 +! REAL , PARAMETER :: defc=8.0 +! REAL , PARAMETER :: defm=32.0 + REAL , PARAMETER :: defc=0.0 + REAL , PARAMETER :: defm=99999.0 + REAL , PARAMETER :: epsfc=1./1.05 + REAL , PARAMETER :: epswet=0.0 + REAL , PARAMETER :: fcdif=1./3. + REAL , PARAMETER :: fcm=0.00003 + REAL , PARAMETER :: gma=-r_d*(1.-rcp)*0.5 + REAL , PARAMETER :: p400=40000.0 + REAL , PARAMETER :: phitp=15000.0 + REAL , PARAMETER :: pi2=2.*3.1415926 + REAL , PARAMETER :: plbtm=105000.0 + REAL , PARAMETER :: plomd=64200.0 + REAL , PARAMETER :: pmdhi=35000.0 + REAL , PARAMETER :: q2ini=0.50 + REAL , PARAMETER :: rfcp=0.25/cp + REAL , PARAMETER :: rhcrit_land=0.75 + REAL , PARAMETER :: rhcrit_sea=0.80 + REAL , PARAMETER :: rlag=14.8125 + REAL , PARAMETER :: rlx=0.90 + REAL , PARAMETER :: scq2=50.0 + REAL , PARAMETER :: slopht=0.001 + REAL , PARAMETER :: tlc=2.*0.703972477 + REAL , PARAMETER :: wa=0.15 + REAL , PARAMETER :: wght=0.35 + REAL , PARAMETER :: wpc=0.075 + REAL , PARAMETER :: z0land=0.10 + REAL , PARAMETER :: z0max=0.008 + REAL , PARAMETER :: z0sea=0.001 +!#endif + + + CONTAINS + SUBROUTINE init_module_model_constants + END SUBROUTINE init_module_model_constants + END MODULE module_model_constants diff --git a/wrfv2_fire/share/module_optional_si_input.F b/wrfv2_fire/share/module_optional_si_input.F new file mode 100644 index 00000000..b4056cd2 --- /dev/null +++ b/wrfv2_fire/share/module_optional_si_input.F @@ -0,0 +1,1006 @@ +MODULE module_optional_si_input + + INTEGER :: flag_metgrid , flag_tavgsfc , flag_psfc , flag_soilhgt + + INTEGER :: flag_qv , flag_qc , flag_qr , flag_qi , flag_qs , flag_qg + + INTEGER :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , & + flag_sm000010 , flag_sm010040 , flag_sm040100 , flag_sm100200 , flag_sm010200 , & + flag_sw000010 , flag_sw010040 , flag_sw040100 , flag_sw100200 , flag_sw010200 + + INTEGER :: flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , & + flag_sm000007 , flag_sm007028 , flag_sm028100 , flag_sm100255 + + INTEGER :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , & + flag_soilm000 , flag_soilm005 , flag_soilm020 , flag_soilm040 , flag_soilm160 , flag_soilm300 , & + flag_soilw000 , flag_soilw005 , flag_soilw020 , flag_soilw040 , flag_soilw160 , flag_soilw300 + + INTEGER :: flag_sst , flag_toposoil , flag_snowh + + INTEGER :: num_st_levels_input , num_sm_levels_input , num_sw_levels_input + INTEGER :: num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc + INTEGER , DIMENSION(100) :: st_levels_input , sm_levels_input , sw_levels_input + REAL , ALLOCATABLE , DIMENSION(:,:,:) :: st_input , sm_input , sw_input + + CHARACTER (LEN=8) , PRIVATE :: flag_name + + LOGICAL :: already_been_here + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE init_module_optional_si_input ( grid , config_flags ) + + USE module_domain + USE module_configure + + IMPLICIT NONE + + TYPE ( domain ) :: grid + TYPE (grid_config_rec_type) :: config_flags + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + ! Get the various indices, assume XZY ordering. + + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + IF ( .NOT. already_been_here ) THEN + + num_st_levels_alloc = config_flags%num_soil_layers * 3 ! used to be 2 + num_sm_levels_alloc = config_flags%num_soil_layers * 3 + num_sw_levels_alloc = config_flags%num_soil_layers * 3 + + IF ( ALLOCATED ( st_input ) ) DEALLOCATE ( st_input ) + IF ( ALLOCATED ( sm_input ) ) DEALLOCATE ( sm_input ) + IF ( ALLOCATED ( sw_input ) ) DEALLOCATE ( sw_input ) + + ALLOCATE ( st_input(ims:ime,num_st_levels_alloc,jms:jme) ) + ALLOCATE ( sm_input(ims:ime,num_sm_levels_alloc,jms:jme) ) + ALLOCATE ( sw_input(ims:ime,num_sw_levels_alloc,jms:jme) ) + + END IF + + already_been_here = .TRUE. + + END SUBROUTINE init_module_optional_si_input + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_si_input ( grid , fid ) + + USE module_configure + USE module_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + ! Get the various indices, assume XZY ordering. + + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + + CALL optional_tavgsfc ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL optional_moist ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL optional_metgrid ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL optional_sst ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL optional_snowh ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .OR. & + ( model_config_rec%sf_surface_physics(grid%id) .EQ. 2 ) .OR. & + ( model_config_rec%sf_surface_physics(grid%id) .EQ. 3 ) .OR. & + ( model_config_rec%sf_surface_physics(grid%id) .EQ. 99 ) ) THEN + + CALL optional_lsm ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL optional_lsm_levels ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + END IF + + END SUBROUTINE optional_si_input + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_moist ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain + +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_qv = 0 + flag_qc = 0 + flag_qr = 0 + flag_qi = 0 + flag_qs = 0 + flag_qg = 0 + + flag_name(1:8) = 'QV ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qv = itmp + END IF + flag_name(1:8) = 'QC ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qc = itmp + END IF + flag_name(1:8) = 'QR ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qr = itmp + END IF + flag_name(1:8) = 'QI ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qi = itmp + END IF + flag_name(1:8) = 'QS ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qs = itmp + END IF + flag_name(1:8) = 'QG ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_qg = itmp + END IF + + END SUBROUTINE optional_moist + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_metgrid ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_metgrid = 0 + + flag_name(1:8) = 'METGRID ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_metgrid = itmp + END IF + + END SUBROUTINE optional_metgrid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_sst ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_sst = 0 + + flag_name(1:8) = 'SST ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sst = itmp + END IF + + END SUBROUTINE optional_sst + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_tavgsfc ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_tavgsfc = 0 + + flag_name(1:8) = 'TAVGSFC ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_tavgsfc = itmp + END IF + + END SUBROUTINE optional_tavgsfc + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_snowh ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_snowh = 0 + + flag_name(1:8) = 'SNOWH ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_snowh = itmp + END IF + + END SUBROUTINE optional_snowh + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_lsm ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_psfc = 0 + flag_soilhgt = 0 + flag_toposoil = 0 + + flag_name(1:8) = 'TOPOSOIL' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_toposoil = itmp + END IF + + flag_name(1:8) = 'PSFC ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_psfc = itmp + END IF + + flag_name(1:8) = 'SOILHGT ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilhgt = itmp + END IF + + END SUBROUTINE optional_lsm + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_lsm_levels ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain +USE module_configure +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr , i , j + + ! Initialize the soil temp and moisture flags to "field not found". + + flag_st000010 = 0 + flag_st010040 = 0 + flag_st040100 = 0 + flag_st100200 = 0 + flag_st010200 = 0 + + flag_sm000010 = 0 + flag_sm010040 = 0 + flag_sm040100 = 0 + flag_sm100200 = 0 + flag_sm010200 = 0 + + flag_sw000010 = 0 + flag_sw010040 = 0 + flag_sw040100 = 0 + flag_sw100200 = 0 + flag_sw010200 = 0 + + flag_st000007 = 0 + flag_st007028 = 0 + flag_st028100 = 0 + flag_st100255 = 0 + + flag_sm000007 = 0 + flag_sm007028 = 0 + flag_sm028100 = 0 + flag_sm100255 = 0 + + flag_soilt000 = 0 + flag_soilt005 = 0 + flag_soilt020 = 0 + flag_soilt040 = 0 + flag_soilt160 = 0 + flag_soilt300 = 0 + + flag_soilm000 = 0 + flag_soilm005 = 0 + flag_soilm020 = 0 + flag_soilm040 = 0 + flag_soilm160 = 0 + flag_soilm300 = 0 + + flag_soilw000 = 0 + flag_soilw005 = 0 + flag_soilw020 = 0 + flag_soilw040 = 0 + flag_soilw160 = 0 + flag_soilw300 = 0 + + ! How many soil levels have we found? Well, right now, none. + + num_st_levels_input = 0 + num_sm_levels_input = 0 + num_sw_levels_input = 0 + st_levels_input = -1 + sm_levels_input = -1 + sw_levels_input = -1 + + flag_name(1:8) = 'ST000010' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st000010 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st000010(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST010040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st010040 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st010040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST040100' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st040100 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st040100(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST100200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st100200 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st100200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST010200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st010200 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st010200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM000010' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm000010 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm000010(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM010040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm010040 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm010040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM040100' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm040100 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm040100(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM100200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm100200 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm100200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM010200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm010200 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm010200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SW000010' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sw000010 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input + 1,j) = grid%sw000010(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SW010040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sw010040 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input + 1,j) = grid%sw010040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SW040100' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sw040100 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input + 1,j) = grid%sw040100(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SW100200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sw100200 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input + 1,j) = grid%sw100200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SW010200' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sw010200 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input + 1,j) = grid%sw010200(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST000007' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st000007 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st000007(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST007028' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st007028 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st007028(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST028100' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st028100 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st028100(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'ST100255' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_st100255 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input + 1,j) = grid%st100255(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM000007' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm000007 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm000007(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM007028' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm007028 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm007028(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM028100' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm028100 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm028100(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SM100255' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_sm100255 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input + 1,j) = grid%sm100255(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT000' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt000 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt000(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT005' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt005 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt005(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT020' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt020 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt020(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt040 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT160' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt160 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt160(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILT300' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilt300 = itmp + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,num_st_levels_input ,j) = grid%soilt300(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM000' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm000 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm000(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM005' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm005 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm005(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM020' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm020 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm020(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm040 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM160' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm160 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm160(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILM300' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilm300 = itmp + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,num_sm_levels_input ,j) = grid%soilm300(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW000' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw000 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw000(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW005' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw005 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw005(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW020' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw020 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw020(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW040' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw040 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw040(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW160' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw160 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw160(i,j) + END DO + END DO + END IF + flag_name(1:8) = 'SOILW300' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_soilw300 = itmp + num_sw_levels_input = num_sw_levels_input + 1 + sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8)) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,num_sw_levels_input ,j) = grid%soilw300(i,j) + END DO + END DO + END IF + + ! OK, let's do a quick sanity check. + + IF ( ( num_st_levels_input .GT. num_st_levels_alloc ) .OR. & + ( num_sm_levels_input .GT. num_sm_levels_alloc ) .OR. & + ( num_sw_levels_input .GT. num_sw_levels_alloc ) ) THEN + print *,'pain and woe, the soil level allocation is too small' + CALL wrf_error_fatal ( 'soil_levels_too_few' ) + END IF + + END SUBROUTINE optional_lsm_levels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + FUNCTION char2int1( string3 ) RESULT ( int1 ) + CHARACTER (LEN=3) , INTENT(IN) :: string3 + INTEGER :: i1 , int1 + READ(string3,fmt='(I3)') i1 + int1 = i1 + END FUNCTION char2int1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + FUNCTION char2int2( string6 ) RESULT ( int1 ) + CHARACTER (LEN=6) , INTENT(IN) :: string6 + INTEGER :: i2 , i1 , int1 + READ(string6,fmt='(I3,I3)') i1,i2 + int1 = ( i2 + i1 ) / 2 + END FUNCTION char2int2 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +END MODULE module_optional_si_input diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F new file mode 100644 index 00000000..72c5b144 --- /dev/null +++ b/wrfv2_fire/share/module_soil_pre.F @@ -0,0 +1,2942 @@ +#if ( ! NMM_CORE == 1 ) + +MODULE module_soil_pre + + USE module_date_time + USE module_state_description + +CONTAINS + + SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & + xland , landusef , isltyp , soilcat , soilctop , & + soilcbot , tmn , & + seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + iswater , isice , & + scheme , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater , isice + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme + + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & + vegcat, xland , soilcat , tmn + REAL , INTENT(IN) :: seaice_threshold + + INTEGER :: i , j , num_seaice_changes , loop + CHARACTER (LEN=132) :: message + + num_seaice_changes = 0 + fix_seaice : SELECT CASE ( scheme ) + + CASE ( SLABSCHEME ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( xice(i,j) .GT. 200.0 ) THEN + xice(i,j) = 0. + num_seaice_changes = num_seaice_changes + 1 + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total pre number of sea ice locations removed (due to FLAG values) = ', & + num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( xice(i,j) .GE. 0.5 ) .OR. & + ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN + xice(i,j) = 1. + num_seaice_changes = num_seaice_changes + 1 + if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4 + vegcat(i,j)=isice + ivgtyp(i,j)=isice + lu_index(i,j)=isice + landmask(i,j)=1. + xland(i,j)=1. + DO loop=1,num_veg_cat + landusef(i,loop,j)=0. + END DO + landusef(i,ivgtyp(i,j),j)=1. + + isltyp(i,j) = 16 + soilcat(i,j)=isltyp(i,j) + DO loop=1,num_soil_top_cat + soilctop(i,loop,j)=0 + END DO + DO loop=1,num_soil_bot_cat + soilcbot(i,loop,j)=0 + END DO + soilctop(i,isltyp(i,j),j)=1. + soilcbot(i,isltyp(i,j),j)=1. + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total pre number of sea ice location changes (water to land) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + CASE ( LSMSCHEME , RUCLSMSCHEME ) + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .GT. 0.5 ) THEN + if (xice(i,j).gt.0) num_seaice_changes = num_seaice_changes + 1 + xice(i,j) = 0. + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total pre number of land location changes (seaice set to zero) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + END SELECT fix_seaice + + END SUBROUTINE adjust_for_seaice_pre + + SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk_old , tsk , ivgtyp , vegcat , lu_index , & + xland , landusef , isltyp , soilcat , soilctop , & + soilcbot , tmn , vegfra , & + tslb , smois , sh2o , & + seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + num_soil_layers , & + iswater , isice , & + scheme , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater , isice + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme + INTEGER , INTENT(IN) :: num_soil_layers + + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot + REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & + vegcat, xland , soilcat , tmn , & + tsk_old , vegfra + REAL , INTENT(IN) :: seaice_threshold + REAL :: total_depth , mid_point_depth + + INTEGER :: i , j , num_seaice_changes , loop + CHARACTER (LEN=132) :: message + + num_seaice_changes = 0 + fix_seaice : SELECT CASE ( scheme ) + + CASE ( SLABSCHEME ) + + CASE ( LSMSCHEME , RUCLSMSCHEME ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( xice(i,j) .GT. 200.0 ) THEN + xice(i,j) = 0. + num_seaice_changes = num_seaice_changes + 1 + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice locations removed (due to FLAG values) = ', & + num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. & + ( ( tsk_old(i,j) .GT. 170 ) .AND. ( tsk_old(i,j) .LT. 400 ) ) )THEN + tsk(i,j) = tsk_old(i,j) + END IF + IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. & + ( ( tsk_old(i,j) .LT. 170 ) .OR. ( tsk_old(i,j) .GT. 400 ) ) )THEN + print *,'TSK woes in seaice post, i,j=',i,j,' tsk = ',tsk(i,j), tsk_old(i,j) + CALL wrf_error_fatal ( 'TSK is unrealistic, problems for seaice post') + ELSE IF ( ( xice(i,j) .GE. 0.5 ) .OR. & + ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN + xice(i,j) = 1. + num_seaice_changes = num_seaice_changes + 1 + if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4 + vegcat(i,j)=isice + ivgtyp(i,j)=isice + lu_index(i,j)=isice + landmask(i,j)=1. + xland(i,j)=1. + vegfra(i,j)=0. + DO loop=1,num_veg_cat + landusef(i,loop,j)=0. + END DO + landusef(i,ivgtyp(i,j),j)=1. + + tsk_old(i,j) = tsk(i,j) + + isltyp(i,j) = 16 + soilcat(i,j)=isltyp(i,j) + DO loop=1,num_soil_top_cat + soilctop(i,loop,j)=0 + END DO + DO loop=1,num_soil_bot_cat + soilcbot(i,loop,j)=0 + END DO + soilctop(i,isltyp(i,j),j)=1. + soilcbot(i,isltyp(i,j),j)=1. + + total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers + DO loop = 1,num_soil_layers + mid_point_depth=(total_depth/num_soil_layers)/2. + & + (loop-1)*(total_depth/num_soil_layers) + tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + & + mid_point_depth*tmn(i,j) ) / total_depth + END DO + + DO loop=1,num_soil_layers + smois(i,loop,j) = 1.0 + sh2o(i,loop,j) = 0.0 + END DO + ELSE IF ( xice(i,j) .LT. 0.5 ) THEN + xice(i,j) = 0. + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice location changes (water to land) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + END SELECT fix_seaice + + END SUBROUTINE adjust_for_seaice_post + + SUBROUTINE process_percent_cat_new ( landmask , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask + + INTEGER :: i , j , l , ll, dominant_index + REAL :: dominant_value + +#ifdef WRF_CHEM +! REAL :: lwthresh = .99 + REAL :: lwthresh = .50 +#else + REAL :: lwthresh = .50 +#endif + + INTEGER , PARAMETER :: iswater_soil = 14 + INTEGER :: iforce + CHARACTER (LEN=132) :: message +integer :: change_water , change_land +change_water = 0 +change_land = 0 + + ! Sanity check on the 50/50 points + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + dominant_value = landuse_frac(i,iswater,j) + IF ( dominant_value .EQ. lwthresh ) THEN + DO l = 1 , num_veg_cat + IF ( l .EQ. iswater ) CYCLE + IF ( ( landuse_frac(i,l,j) .EQ. lwthresh ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN + PRINT *,i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j) + landuse_frac(i,l,j) = lwthresh - .01 + landuse_frac(i,iswater,j) = lwthresh + 0.01 + ELSE IF ( ( landuse_frac(i,l,j) .EQ. lwthresh ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN + PRINT *,i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j) + landuse_frac(i,l,j) = lwthresh + .01 + landuse_frac(i,iswater,j) = lwthresh - 0.01 + END IF + END DO + END IF + END DO + END DO + + ! Compute the dominant VEGETATION INDEX. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + dominant_value = landuse_frac(i,1,j) + dominant_index = 1 + DO l = 2 , num_veg_cat + IF ( l .EQ. iswater ) THEN + ! wait a bit + ELSE IF ( ( l .NE. iswater ) .AND. ( landuse_frac(i,l,j) .GT. dominant_value ) ) THEN + dominant_value = landuse_frac(i,l,j) + dominant_index = l + END IF + END DO + IF ( landuse_frac(i,iswater,j) .GT. lwthresh ) THEN + dominant_value = landuse_frac(i,iswater,j) + dominant_index = iswater + ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. & + ( landmask(i,j) .LT. 0.5) .AND. & + ( dominant_value .EQ. lwthresh) ) THEN + dominant_value = landuse_frac(i,iswater,j) + dominant_index = iswater + ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. & + ( landmask(i,j) .GT. 0.5) .AND. & + ( dominant_value .EQ. lwthresh) ) THEN + !no op + ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh ) .AND. & + ( dominant_value .LT. lwthresh ) ) THEN + dominant_value = landuse_frac(i,iswater,j) + dominant_index = iswater + END IF + IF ( dominant_index .EQ. iswater ) THEN +if(landmask(i,j).gt.lwthresh) then +!print *,'changing to water at point ',i,j +!print '(24(i3,1x))',1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16, 17,18,19,20,21, 22, 23,24 +!print '(24(i3,1x))',nint(landuse_frac(i,:,j)*100) +change_water=change_water+1 +endif + landmask(i,j) = 0 + ELSE IF ( dominant_index .NE. iswater ) THEN +if(landmask(i,j).lt.lwthresh) then +!print *,'changing to land at point ',i,j +!print '(24(i3,1x))',1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16, 17,18,19,20,21, 22, 23,24 +!print '(24(i3,1x))',nint(landuse_frac(i,:,j)*100) +change_land=change_land+1 +endif + landmask(i,j) = 1 + END IF + ivgtyp(i,j) = dominant_index + END DO + END DO + + ! Compute the dominant SOIL TEXTURE INDEX, TOP. + + iforce = 0 + DO i = its , MIN(ide-1,ite) + DO j = jts , MIN(jde-1,jte) + dominant_value = soil_top_cat(i,1,j) + dominant_index = 1 + IF ( landmask(i,j) .GT. lwthresh ) THEN + DO l = 2 , num_soil_top_cat + IF ( ( l .NE. iswater_soil ) .AND. ( soil_top_cat(i,l,j) .GT. dominant_value ) ) THEN + dominant_value = soil_top_cat(i,l,j) + dominant_index = l + END IF + END DO + IF ( dominant_value .LT. 0.01 ) THEN + iforce = iforce + 1 + WRITE ( message , FMT = '(A,I4,I4)' ) & + 'based on landuse, changing soil to land at point ',i,j + CALL wrf_debug(1,message) + WRITE ( message , FMT = '(16(i3,1x))' ) & + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16 + CALL wrf_debug(1,message) + WRITE ( message , FMT = '(16(i3,1x))' ) & + nint(soil_top_cat(i,:,j)*100) + CALL wrf_debug(1,message) + dominant_index = 8 + END IF + ELSE + dominant_index = iswater_soil + END IF + isltyp(i,j) = dominant_index + END DO + END DO + +if(iforce.ne.0)then +WRITE(message,FMT='(A,I4,A,I6)' ) & +'forcing artificial silty clay loam at ',iforce,' points, out of ',& +(MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) +CALL wrf_debug(0,message) +endif +print *,'LAND CHANGE = ',change_land +print *,'WATER CHANGE = ',change_water + + END SUBROUTINE process_percent_cat_new + + SUBROUTINE process_soil_real ( tsk , tmn , & + landmask , sst , & + st_input , sm_input , sw_input , st_levels_input , sm_levels_input , sw_levels_input , & + zs , dzs , tslb , smois , sh2o , & + flag_sst , flag_soilt000, flag_soilm000, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + sf_surface_physics , num_soil_layers , real_data_init_type , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + sf_surface_physics , num_soil_layers , real_data_init_type , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000 + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + + INTEGER :: i , j , l , dominant_index , num_soil_cat , num_veg_cat + REAL :: dominant_value + + ! Initialize the soil depth, and the soil temperature and moisture. + + IF ( ( sf_surface_physics .EQ. 1 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_1 ( zs , dzs , num_soil_layers ) + CALL init_soil_1_real ( tsk , tmn , tslb , zs , dzs , num_soil_layers , real_data_init_type , & + landmask , sst , flag_sst , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ELSE IF ( ( sf_surface_physics .EQ. 2 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_2 ( zs , dzs , num_soil_layers ) + CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , & + st_input , sm_input , sw_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , sw_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) +! CALL init_soil_old ( tsk , tmn , & +! smois , tslb , zs , dzs , num_soil_layers , & +! st000010_input , st010040_input , st040100_input , st100200_input , & +! st010200_input , & +! sm000010_input , sm010040_input , sm040100_input , sm100200_input , & +! sm010200_input , & +! landmask_input , sst_input , & +! ids , ide , jds , jde , kds , kde , & +! ims , ime , jms , jme , kms , kme , & +! its , ite , jts , jte , kts , kte ) + ELSE IF ( ( sf_surface_physics .EQ. 3 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_3 ( zs , dzs , num_soil_layers ) + CALL init_soil_3_real ( tsk , tmn , smois , tslb , & + st_input , sm_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + + END SUBROUTINE process_soil_real + + SUBROUTINE process_soil_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois, & + tsk,tmn,zs,dzs, & + num_soil_layers, & + sf_surface_physics , & + ids,ide, jds,jde, kds,kde,& + ims,ime, jms,jme, kms,kme,& + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: num_soil_layers , sf_surface_physics + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(INOUT) :: smois, tslb + + REAL, DIMENSION(num_soil_layers), INTENT(OUT) :: dzs,zs + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT) :: tsk, tmn + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra + INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp + + ! Local variables. + + INTEGER :: itf,jtf + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( ( sf_surface_physics .EQ. 1 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_1 ( zs , dzs , num_soil_layers ) + CALL init_soil_1_ideal(tsk,tmn,tslb,xland, & + ivgtyp,zs,dzs,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE IF ( ( sf_surface_physics .EQ. 2 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_2 ( zs , dzs , num_soil_layers ) + CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois,tmn, & + num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE IF ( ( sf_surface_physics .EQ. 3 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_3 ( zs , dzs , num_soil_layers ) + + END IF + + END SUBROUTINE process_soil_ideal + + SUBROUTINE adjust_soil_temp_new ( tmn , sf_surface_physics , & + tsk , ter , toposoil , landmask , flag_toposoil , & + st000010 , st010040 , st040100 , st100200 , st010200 , & + flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , & + st000007 , st007028 , st028100 , st100255 , & + flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , & + soilt000 , soilt005 , soilt020 , soilt040 , soilt160 , soilt300 , & + flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: ter , toposoil , landmask + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tmn , tsk + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: st000010 , st010040 , st040100 , st100200 , st010200 + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: st000007 , st007028 , st028100 , st100255 + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: soilt000 , soilt005 , soilt020 , soilt040 , soilt160 , soilt300 + + INTEGER , INTENT(IN) :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 + INTEGER , INTENT(IN) :: flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 + INTEGER , INTENT(IN) :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 + INTEGER , INTENT(IN) :: sf_surface_physics , flag_toposoil + + INTEGER :: i , j + + REAL :: soil_elev_min_val , soil_elev_max_val , soil_elev_min_dif , soil_elev_max_dif + + ! Do we have a soil field with which to modify soil temperatures? + + IF ( flag_toposoil .EQ. 1 ) THEN + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + + ! Is the toposoil field OK, or is it a subversive soil elevation field. We can tell + ! usually by looking at values. Anything less than -1000 m (lower than the Dead Sea) is + ! bad. Anything larger than 10 km (taller than Everest) is toast. Also, anything where + ! the difference between the soil elevation and the terrain is greater than 3 km means + ! that the soil data is either all zeros or that the data are inconsistent. Any of these + ! three conditions is grievous enough to induce a WRF fatality. However, if they are at + ! a water point, then we can safely ignore them. + + soil_elev_min_val = toposoil(i,j) + soil_elev_max_val = toposoil(i,j) + soil_elev_min_dif = ter(i,j) - toposoil(i,j) + soil_elev_max_dif = ter(i,j) - toposoil(i,j) + + IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN +!print *,'no soil temperature elevation adjustment, soil height too small = ',toposoil(i,j) +cycle +! CALL wrf_error_fatal ( 'TOPOSOIL values have large negative values < -1000 m, unrealistic.' ) + ENDIF + + IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN +print *,'no soil temperature elevation adjustment, soil height too high = ',toposoil(i,j) +cycle + CALL wrf_error_fatal ( 'TOPOSOIL values have large positive values > 10,000 m , unrealistic.' ) + ENDIF + + IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. & + ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. & + ( landmask(i,j) .GT. 0.5 ) ) THEN +print *,'no soil temperature elevation adjustment, diff of soil height and terrain = ',ter(i,j) - toposoil(i,j) +cycle + CALL wrf_error_fatal ( 'TOPOSOIL difference with terrain elevation differs by more than 3000 m, unrealistic' ) + ENDIF + + ! For each of the fields that we would like to modify, check to see if it came in from the SI. + ! If so, then use a -6.5 K/km lapse rate (based on the elevation diffs). We only adjust when we + ! are not at a water point. + + IF (landmask(i,j) .GT. 0.5 ) THEN + + IF ( sf_surface_physics .EQ. 1 ) THEN + tmn(i,j) = tmn(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + tsk(i,j) = tsk(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + + IF ( flag_st000010 .EQ. 1 ) THEN + st000010(i,j) = st000010(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st010040 .EQ. 1 ) THEN + st010040(i,j) = st010040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st040100 .EQ. 1 ) THEN + st040100(i,j) = st040100(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st100200 .EQ. 1 ) THEN + st100200(i,j) = st100200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st010200 .EQ. 1 ) THEN + st010200(i,j) = st010200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + IF ( flag_st000007 .EQ. 1 ) THEN + st000007(i,j) = st000007(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st007028 .EQ. 1 ) THEN + st007028(i,j) = st007028(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st028100 .EQ. 1 ) THEN + st028100(i,j) = st028100(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st100255 .EQ. 1 ) THEN + st100255(i,j) = st100255(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + IF ( flag_soilt000 .EQ. 1 ) THEN + soilt000(i,j) = soilt000(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt005 .EQ. 1 ) THEN + soilt005(i,j) = soilt005(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt020 .EQ. 1 ) THEN + soilt020(i,j) = soilt020(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt040 .EQ. 1 ) THEN + soilt040(i,j) = soilt040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt160 .EQ. 1 ) THEN + soilt160(i,j) = soilt160(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt300 .EQ. 1 ) THEN + soilt300(i,j) = soilt300(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + END IF + END DO + END DO + + END IF + + END SUBROUTINE adjust_soil_temp_new + + + SUBROUTINE init_soil_depth_1 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + ! Define layers (top layer = 0.01 m). Double the thicknesses at each step (dzs values). + ! The distance from the ground level to the midpoint of the layer is given by zs. + + ! ------- Ground Level ---------- || || || || + ! || || || || zs(1) = 0.005 m + ! -- -- -- -- -- -- -- -- -- || || || \/ + ! || || || + ! ----------------------------------- || || || \/ dzs(1) = 0.01 m + ! || || || + ! || || || zs(2) = 0.02 + ! -- -- -- -- -- -- -- -- -- || || \/ + ! || || + ! || || + ! ----------------------------------- || || \/ dzs(2) = 0.02 m + ! || || + ! || || + ! || || + ! || || zs(3) = 0.05 + ! -- -- -- -- -- -- -- -- -- || \/ + ! || + ! || + ! || + ! || + ! ----------------------------------- \/ dzs(3) = 0.04 m + + IF ( num_soil_layers .NE. 5 ) THEN + PRINT '(A)','Usually, the 5-layer diffusion uses 5 layers. Change this in the namelist.' + CALL wrf_error_fatal ( '5-layer_diffusion_uses_5_layers' ) + END IF + + dzs(1)=.01 + zs(1)=.5*dzs(1) + + DO l=2,num_soil_layers + dzs(l)=2*dzs(l-1) + zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l) + ENDDO + + END SUBROUTINE init_soil_depth_1 + + SUBROUTINE init_soil_depth_2 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + dzs = (/ 0.1 , 0.3 , 0.6 , 1.0 /) + + IF ( num_soil_layers .NE. 4 ) THEN + PRINT '(A)','Usually, the LSM uses 4 layers. Change this in the namelist.' + CALL wrf_error_fatal ( 'LSM_uses_4_layers' ) + END IF + + zs(1)=.5*dzs(1) + + DO l=2,num_soil_layers + zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l) + ENDDO + + END SUBROUTINE init_soil_depth_2 + + SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + CHARACTER (LEN=132) :: message + +! in RUC LSM ZS - soil levels, and DZS - soil layer thicknesses, not used +! ZS is specified in the namelist: num_soil_layers = 6 or 9. +! Other options with number of levels are possible, but +! WRF users should change consistently the namelist entry with the +! ZS array in this subroutine. + + IF ( num_soil_layers .EQ. 6) THEN + zs = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /) +! dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /) + ELSEIF ( num_soil_layers .EQ. 9) THEN + zs = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /) +! dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /) + ENDIF + + IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN + write (message, FMT='(A)') 'The RUC LSM uses 6, 9 or more levels. Change this in the namelist.' + CALL wrf_error_fatal ( message ) + END IF + + END SUBROUTINE init_soil_depth_3 + + SUBROUTINE init_soil_1_real ( tsk , tmn , tslb , zs , dzs , & + num_soil_layers , real_data_init_type , & + landmask , sst , flag_sst , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , real_data_init_type , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tsk , tmn + + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb + + INTEGER :: i , j , l + + ! Soil temperature is linearly interpolated between the skin temperature (taken to be at a + ! depth of 0.5 cm) and the deep soil, annual temperature (taken to be at a depth of 23 cm). + ! The tslb(i,1,j) is the skin temperature, and the tslb(i,num_soil_layers,j) level is the + ! annual mean temperature. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .GT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= ( tsk(i,j) * ( zs(num_soil_layers) - zs(l) ) + & + tmn(i,j) * ( zs( l) - zs(1) ) ) / & + ( zs(num_soil_layers) - zs(1) ) + END DO + ELSE + IF ( ( real_data_init_type .EQ. 1 ) .AND. ( flag_sst .EQ. 1 ) ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= sst(i,j) + END DO + ELSE + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + END DO + END IF + END IF + END DO + END DO + + END SUBROUTINE init_soil_1_real + + SUBROUTINE init_soil_1_ideal(tsk,tmn,tslb,xland, & + ivgtyp,ZS,DZS,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: num_soil_layers + + REAL, DIMENSION( ims:ime , 1 , jms:jme ), INTENT(OUT) :: tslb + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: xland + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: ivgtyp + + REAL, DIMENSION(1:), INTENT(IN) :: dzs,zs + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN) :: tsk, tmn + + ! Lcal variables. + + INTEGER :: l,j,i,itf,jtf + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF (num_soil_layers.NE.1)THEN + DO j=jts,jtf + DO l=1,num_soil_layers + DO i=its,itf + tslb(i,l,j)=( tsk(i,j)*(zs(num_soil_layers)-zs(l)) + tmn(i,j)*(zs(l)-zs(1)) ) / & + ( zs(num_soil_layers)-zs(1) ) + ENDDO + ENDDO + ENDDO + ENDIF + DO j=jts,jtf + DO i=its,itf + xland(i,j) = 2 + ivgtyp(i,j) = 7 + ENDDO + ENDDO + + END SUBROUTINE init_soil_1_ideal + + SUBROUTINE init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , & + st_input , sm_input , sw_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , sw_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilmt000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilmt000 + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input + + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o + + REAL , ALLOCATABLE , DIMENSION(:) :: zhave + + INTEGER :: i , j , l , lout , lin , lwant , lhave , num + REAL :: temp + LOGICAL :: found_levels + + ! Are there any soil temp and moisture levels - ya know, they are mandatory. + + num = num_st_levels_input * num_sm_levels_input + + IF ( num .GE. 1 ) THEN + + ! Ordered levels that we have data for. + + ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input) +2) ) + + ! Sort the levels for temperature. + + outert : DO lout = 1 , num_st_levels_input-1 + innert : DO lin = lout+1 , num_st_levels_input + IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN + temp = st_levels_input(lout) + st_levels_input(lout) = st_levels_input(lin) + st_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = st_input(i,lout+1,j) + st_input(i,lout+1,j) = st_input(i,lin+1,j) + st_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innert + END DO outert + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,1,j) = tsk(i,j) + st_input(i,num_st_levels_input+2,j) = tmn(i,j) + END DO + END DO + + ! Sort the levels for moisture. + + outerm: DO lout = 1 , num_sm_levels_input-1 + innerm : DO lin = lout+1 , num_sm_levels_input + IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN + temp = sm_levels_input(lout) + sm_levels_input(lout) = sm_levels_input(lin) + sm_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sm_input(i,lout+1,j) + sm_input(i,lout+1,j) = sm_input(i,lin+1,j) + sm_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innerm + END DO outerm + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,1,j) = sm_input(i,2,j) + sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j) + END DO + END DO + + ! Sort the levels for liquid moisture. + + outerw: DO lout = 1 , num_sw_levels_input-1 + innerw : DO lin = lout+1 , num_sw_levels_input + IF ( sw_levels_input(lout) .GT. sw_levels_input(lin) ) THEN + temp = sw_levels_input(lout) + sw_levels_input(lout) = sw_levels_input(lin) + sw_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sw_input(i,lout+1,j) + sw_input(i,lout+1,j) = sw_input(i,lin+1,j) + sw_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innerw + END DO outerw + IF ( num_sw_levels_input .GT. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,1,j) = sw_input(i,2,j) + sw_input(i,num_sw_levels_input+2,j) = sw_input(i,num_sw_levels_input+1,j) + END DO + END DO + END IF + + found_levels = .TRUE. + + ELSE IF ( ( num .LE. 0 ) .AND. ( start_date .NE. current_date ) ) THEN + + found_levels = .FALSE. + + ELSE + CALL wrf_error_fatal ( & + 'No input soil level data (temperature, moisture or liquid, or all are missing). Required for LSM.' ) + END IF + + ! Is it OK to continue? + + IF ( found_levels ) THEN + + ! Here are the levels that we have from the input for temperature. The input levels plus + ! two more: the skin temperature at 0 cm, and the annual mean temperature at 300 cm. + + zhave(1) = 0. + DO l = 1 , num_st_levels_input + zhave(l+1) = st_levels_input(l) / 100. + END DO + zhave(num_st_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt : DO lwant = 1 , num_soil_layers + z_havet : DO lhave = 1 , num_st_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet + END IF + END DO z_havet + END DO z_wantt + + ! Here are the levels that we have from the input for moisture. The input levels plus + ! two more: a value at 0 cm and one at 300 cm. The 0 cm value is taken to be identical + ! to the most shallow layer's value. Similarly, the 300 cm value is taken to be the same + ! as the most deep layer's value. + + zhave(1) = 0. + DO l = 1 , num_sm_levels_input + zhave(l+1) = sm_levels_input(l) / 100. + END DO + zhave(num_sm_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantm : DO lwant = 1 , num_soil_layers + z_havem : DO lhave = 1 , num_sm_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem + END IF + END DO z_havem + END DO z_wantm + + ! Any liquid soil moisture to worry about? + + IF ( num_sw_levels_input .GT. 1 ) THEN + + zhave(1) = 0. + DO l = 1 , num_sw_levels_input + zhave(l+1) = sw_levels_input(l) / 100. + END DO + zhave(num_sw_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantw : DO lwant = 1 , num_soil_layers + z_havew : DO lhave = 1 , num_sw_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sh2o(i,lwant,j)= ( sw_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + sw_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havew + END IF + END DO z_havew + END DO z_wantw + + END IF + + + ! Over water, put in reasonable values for soil temperature and moisture. These won't be + ! used, but they will make a more continuous plot. + + IF ( flag_sst .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= sst(i,j) + smois(i,l,j)= 1.0 + sh2o (i,l,j)= 1.0 + END DO + END IF + END DO + END DO + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + smois(i,l,j)= 1.0 + sh2o (i,l,j)= 1.0 + END DO + END IF + END DO + END DO + END IF + + DEALLOCATE (zhave) + + END IF + + END SUBROUTINE init_soil_2_real + + SUBROUTINE init_soil_2_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois,tmn, & + num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) ::num_soil_layers + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(OUT) :: smois, tslb + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra, tmn + + INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp + + INTEGER :: icm,jcm,itf,jtf + INTEGER :: i,j,l + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + icm = ide/2 + jcm = jde/2 + + DO j=jts,jtf + DO l=1,num_soil_layers + DO i=its,itf + + smois(i,1,j)=0.10 + smois(i,2,j)=0.10 + smois(i,3,j)=0.10 + smois(i,4,j)=0.10 + + tslb(i,1,j)=295. + tslb(i,2,j)=297. + tslb(i,3,j)=293. + tslb(i,4,j)=293. + + ENDDO + ENDDO + ENDDO + + DO j=jts,jtf + DO i=its,itf + xland(i,j) = 2 + tmn(i,j) = 294. + xice(i,j) = 0. + vegfra(i,j) = 0. + snow(i,j) = 0. + canwat(i,j) = 0. + ivgtyp(i,j) = 7 + isltyp(i,j) = 8 + ENDDO + ENDDO + + END SUBROUTINE init_soil_2_ideal + + SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & + st_input , sm_input , landmask, sst, & + zs , dzs , & + st_levels_input , sm_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , & + num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000 + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + + REAL , ALLOCATABLE , DIMENSION(:) :: zhave + + INTEGER :: i , j , l , lout , lin , lwant , lhave + REAL :: temp + + CHARACTER (LEN=132) :: message + + ! Allocate the soil layer array used for interpolating. + + IF ( ( num_st_levels_input .LE. 0 ) .OR. & + ( num_sm_levels_input .LE. 0 ) ) THEN + write (message, FMT='(A)')'No input soil level data (either temperature or moisture, or both are missing). Required for RUC LSM.' + CALL wrf_error_fatal ( message ) + ELSE + IF ( flag_soilt000 .eq. 1 ) THEN + write(message, FMT='(A)') ' Assume RUC LSM 6-level input' + CALL wrf_message ( message ) + ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input) ) ) + ELSE + write(message, FMT='(A)') ' Assume non-RUC LSM input' + CALL wrf_message ( message ) + ALLOCATE ( zhave( MAX(num_st_levels_input,num_soil_layers) ) ) + END IF + END IF + + ! Sort the levels for temperature. + + outert : DO lout = 1 , num_st_levels_input-1 + innert : DO lin = lout+1 , num_st_levels_input + IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN + temp = st_levels_input(lout) + st_levels_input(lout) = st_levels_input(lin) + st_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = st_input(i,lout,j) + st_input(i,lout,j) = st_input(i,lin,j) + st_input(i,lin,j) = temp + END DO + END DO + END IF + END DO innert + END DO outert + + IF ( flag_soilt000 .NE. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,1,j) = tsk(i,j) + st_input(i,num_st_levels_input+2,j) = tmn(i,j) + END DO + END DO + END IF + + ! Sort the levels for moisture. + + outerm: DO lout = 1 , num_sm_levels_input-1 + innerm : DO lin = lout+1 , num_sm_levels_input + IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN + temp = sm_levels_input(lout) + sm_levels_input(lout) = sm_levels_input(lin) + sm_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sm_input(i,lout,j) + sm_input(i,lout,j) = sm_input(i,lin,j) + sm_input(i,lin,j) = temp + END DO + END DO + END IF + END DO innerm + END DO outerm + + IF ( flag_soilm000 .NE. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,1,j) = sm_input(i,2,j) + sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j) + END DO + END DO + END IF + + ! Here are the levels that we have from the input for temperature. + + IF ( flag_soilt000 .EQ. 1 ) THEN + DO l = 1 , num_st_levels_input + zhave(l) = st_levels_input(l) / 100. + END DO + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt : DO lwant = 1 , num_soil_layers + z_havet : DO lhave = 1 , num_st_levels_input -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet + END IF + END DO z_havet + END DO z_wantt + + ELSE + + zhave(1) = 0. + DO l = 1 , num_st_levels_input + zhave(l+1) = st_levels_input(l) / 100. + END DO + zhave(num_st_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt_2 : DO lwant = 1 , num_soil_layers + z_havet_2 : DO lhave = 1 , num_st_levels_input +2 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet_2 + END IF + END DO z_havet_2 + END DO z_wantt_2 + + END IF + + ! Here are the levels that we have from the input for moisture. + + IF ( flag_soilm000 .EQ. 1 ) THEN + DO l = 1 , num_sm_levels_input + zhave(l) = sm_levels_input(l) / 100. + END DO + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantm : DO lwant = 1 , num_soil_layers + z_havem : DO lhave = 1 , num_sm_levels_input -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem + END IF + END DO z_havem + END DO z_wantm + + ELSE + + zhave(1) = 0. + DO l = 1 , num_sm_levels_input + zhave(l+1) = sm_levels_input(l) / 100. + END DO + zhave(num_sm_levels_input+2) = 300. / 100. + + z_wantm_2 : DO lwant = 1 , num_soil_layers + z_havem_2 : DO lhave = 1 , num_sm_levels_input +2 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem_2 + END IF + END DO z_havem_2 + END DO z_wantm_2 + + END IF + ! Over water, put in reasonable values for soil temperature and moisture. These won't be + ! used, but they will make a more continuous plot. + + IF ( flag_sst .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j) = sst(i,j) + tsk(i,j) = sst(i,j) + smois(i,l,j)= 1.0 + END DO + END IF + END DO + END DO + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + smois(i,l,j)= 1.0 + END DO + END IF + END DO + END DO + END IF + + DEALLOCATE (zhave) + + END SUBROUTINE init_soil_3_real + +END MODULE module_soil_pre + +#else + +MODULE module_soil_pre + + USE module_date_time + USE module_state_description + +CONTAINS + + SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & + xland , landusef , isltyp , soilcat , soilctop , & + soilcbot , tmn , & + seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + iswater , isice , & + scheme , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater , isice + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme + + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & + vegcat, xland , soilcat , tmn + REAL , INTENT(IN) :: seaice_threshold + + INTEGER :: i , j , num_seaice_changes , loop + CHARACTER (LEN=132) :: message + + fix_seaice : SELECT CASE ( scheme ) + + CASE ( SLABSCHEME ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( xice(i,j) .GT. 200.0 ) THEN + xice(i,j) = 0. + num_seaice_changes = num_seaice_changes + 1 + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total pre number of sea ice locations removed (due to FLAG values) = ', & + num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( xice(i,j) .GE. 0.5 ) .OR. & + ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN + xice(i,j) = 1. + num_seaice_changes = num_seaice_changes + 1 + tmn(i,j) = 271.4 + vegcat(i,j)=isice + lu_index(i,j)=ivgtyp(i,j) + landmask(i,j)=1. + xland(i,j)=1. + DO loop=1,num_veg_cat + landusef(i,loop,j)=0. + END DO + landusef(i,ivgtyp(i,j),j)=1. + + isltyp(i,j) = 16 + soilcat(i,j)=isltyp(i,j) + DO loop=1,num_soil_top_cat + soilctop(i,loop,j)=0 + END DO + DO loop=1,num_soil_bot_cat + soilcbot(i,loop,j)=0 + END DO + soilctop(i,isltyp(i,j),j)=1. + soilcbot(i,isltyp(i,j),j)=1. + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total pre number of sea ice location changes (water to land) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + CASE ( LSMSCHEME ) + CASE ( RUCLSMSCHEME ) + + END SELECT fix_seaice + + END SUBROUTINE adjust_for_seaice_pre + + SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & + xland , landusef , isltyp , soilcat , soilctop , & + soilcbot , tmn , & + tslb , smois , sh2o , & + seaice_threshold , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + num_soil_layers , & + iswater , isice , & + scheme , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater , isice + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme + INTEGER , INTENT(IN) :: num_soil_layers + + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot + REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & + vegcat, xland , soilcat , tmn + REAL , INTENT(IN) :: seaice_threshold + REAL :: total_depth , mid_point_depth + + INTEGER :: i , j , num_seaice_changes , loop + CHARACTER (LEN=132) :: message + + fix_seaice : SELECT CASE ( scheme ) + + CASE ( SLABSCHEME ) + + CASE ( LSMSCHEME ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( xice(i,j) .GT. 200.0 ) THEN + xice(i,j) = 0. + num_seaice_changes = num_seaice_changes + 1 + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice locations removed (due to FLAG values) = ', & + num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( xice(i,j) .GE. 0.5 ) .OR. & + ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN + xice(i,j) = 1. + num_seaice_changes = num_seaice_changes + 1 + tmn(i,j) = 271.16 + vegcat(i,j)=isice + lu_index(i,j)=ivgtyp(i,j) + landmask(i,j)=1. + xland(i,j)=1. + DO loop=1,num_veg_cat + landusef(i,loop,j)=0. + END DO + landusef(i,ivgtyp(i,j),j)=1. + + isltyp(i,j) = 16 + soilcat(i,j)=isltyp(i,j) + DO loop=1,num_soil_top_cat + soilctop(i,loop,j)=0 + END DO + DO loop=1,num_soil_bot_cat + soilcbot(i,loop,j)=0 + END DO + soilctop(i,isltyp(i,j),j)=1. + soilcbot(i,isltyp(i,j),j)=1. + + total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers + DO loop = 1,num_soil_layers + mid_point_depth=(total_depth/num_soil_layers)/2. + & + (loop-1)*(total_depth/num_soil_layers) + tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + & + mid_point_depth*tmn(i,j) ) / total_depth + END DO + + DO loop=1,num_soil_layers + smois(i,loop,j) = 1.0 + sh2o(i,loop,j) = 0.0 + END DO + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice location changes (water to land) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + CASE ( RUCLSMSCHEME ) + + END SELECT fix_seaice + + END SUBROUTINE adjust_for_seaice_post + + SUBROUTINE process_percent_cat_new ( landmask , & + landuse_frac , soil_top_cat , soil_bot_cat , & + isltyp , ivgtyp , & + num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + iswater + INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac + REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat + REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat + INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask + + INTEGER :: i , j , l , ll, dominant_index + REAL :: dominant_value + +#ifdef WRF_CHEM +! REAL :: lwthresh = .99 + REAL :: lwthresh = .50 +#else + REAL :: lwthresh = .50 +#endif + + INTEGER , PARAMETER :: iswater_soil = 14 + INTEGER :: iforce + CHARACTER (LEN=132) :: message + + ! Sanity check on the 50/50 points + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + dominant_value = landuse_frac(i,iswater,j) + IF ( dominant_value .EQ. lwthresh ) THEN + DO l = 1 , num_veg_cat + IF ( l .EQ. iswater ) CYCLE + IF ( landuse_frac(i,l,j) .EQ. lwthresh ) THEN + write(message, FMT='(I4,I4,A,I4,A,I4)') i,j,' water and category ',l,' both at 50%, landmask is ',landmask(i,j) + call wrf_message ( message ) + landuse_frac(i,l,j) = lwthresh - .01 + landuse_frac(i,iswater,j) = 1. - (lwthresh + 0.01) + END IF + END DO + END IF + END DO + END DO + + ! Compute the dominant VEGETATION INDEX. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + dominant_value = landuse_frac(i,1,j) + dominant_index = 1 + DO l = 2 , num_veg_cat + IF ( l .EQ. iswater ) THEN + ! wait a bit + ELSE IF ( ( l .NE. iswater ) .AND. ( landuse_frac(i,l,j) .GT. dominant_value ) ) THEN + dominant_value = landuse_frac(i,l,j) + dominant_index = l + END IF + END DO + IF ( landuse_frac(i,iswater,j) .GT. lwthresh ) THEN + dominant_value = landuse_frac(i,iswater,j) + dominant_index = iswater +#if 0 +si needs to beef up consistency checks before we can use this part + ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh) .AND. & + ( dominant_value .EQ. lwthresh) ) THEN + ! no op +#else +ELSEIF((landuse_frac(i,iswater,j).EQ.lwthresh).AND.(dominant_value.EQ.lwthresh).and.(dominant_index.LT.iswater))THEN +write(message,*)'temporary SI landmask fix' +call wrf_message(trim(message)) +! no op +ELSEIF((landuse_frac(i,iswater,j).EQ.lwthresh).AND.(dominant_value.EQ.lwthresh).and.(dominant_index.GT.iswater))THEN +write(message,*)'temporary SI landmask fix' +call wrf_message(trim(message)) +dominant_value = landuse_frac(i,iswater,j) +dominant_index = iswater +#endif + ELSE IF ( ( landuse_frac(i,iswater,j) .EQ. lwthresh ) .AND. & + ( dominant_value .LT. lwthresh ) ) THEN + dominant_value = landuse_frac(i,iswater,j) + dominant_index = iswater + END IF + IF ( dominant_index .EQ. iswater ) THEN +if(landmask(i,j).gt.lwthresh) then +write(message,*) 'changing to water at point ',i,j +call wrf_message(trim(message)) +write(message,*) nint(landuse_frac(i,:,j)*100) +call wrf_message(trim(message)) +endif + landmask(i,j) = 0 + ELSE IF ( dominant_index .NE. iswater ) THEN +if(landmask(i,j).lt.lwthresh) then +write(message,*) 'changing to land at point ',i,j +call wrf_message(trim(message)) +write(message,*) nint(landuse_frac(i,:,j)*100) +call wrf_message(trim(message)) +endif + landmask(i,j) = 1 + END IF + ivgtyp(i,j) = dominant_index + END DO + END DO + + ! Compute the dominant SOIL TEXTURE INDEX, TOP. + + iforce = 0 + DO i = its , MIN(ide-1,ite) + DO j = jts , MIN(jde-1,jte) + dominant_value = soil_top_cat(i,1,j) + dominant_index = 1 + IF ( landmask(i,j) .GT. lwthresh ) THEN + DO l = 2 , num_soil_top_cat + IF ( ( l .NE. iswater_soil ) .AND. ( soil_top_cat(i,l,j) .GT. dominant_value ) ) THEN + dominant_value = soil_top_cat(i,l,j) + dominant_index = l + END IF + END DO + IF ( dominant_value .LT. 0.01 ) THEN + iforce = iforce + 1 + WRITE ( message , FMT = '(A,I4,I4)' ) & + 'based on landuse, changing soil to land at point ',i,j + CALL wrf_debug(1,message) + WRITE ( message , FMT = '(16(i3,1x))' ) & + 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16 + CALL wrf_debug(1,message) + WRITE ( message , FMT = '(16(i3,1x))' ) & + nint(soil_top_cat(i,:,j)*100) + CALL wrf_debug(1,message) + dominant_index = 8 + END IF + ELSE + dominant_index = iswater_soil + END IF + isltyp(i,j) = dominant_index + END DO + END DO + +if(iforce.ne.0)then +WRITE(message,FMT='(A,I4,A,I6)' ) & +'forcing artificial silty clay loam at ',iforce,' points, out of ',& +(MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) +CALL wrf_debug(0,message) +endif + + END SUBROUTINE process_percent_cat_new + + SUBROUTINE process_soil_real ( tsk , tmn , & + landmask , sst , & + st_input , sm_input , sw_input , st_levels_input , sm_levels_input , sw_levels_input , & + zs , dzs , tslb , smois , sh2o , & + flag_sst , flag_soilt000, flag_soilm000, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + sf_surface_physics , num_soil_layers , real_data_init_type , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte , & + sf_surface_physics , num_soil_layers , real_data_init_type , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000 + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + + INTEGER :: i , j , l , dominant_index , num_soil_cat , num_veg_cat + REAL :: dominant_value + + ! Initialize the soil depth, and the soil temperature and moisture. + + IF ( ( sf_surface_physics .EQ. 1 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_1 ( zs , dzs , num_soil_layers ) + CALL init_soil_1_real ( tsk , tmn , tslb , zs , dzs , num_soil_layers , real_data_init_type , & + landmask , sst , flag_sst , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ELSE IF ( ( sf_surface_physics .EQ. 2 .or. sf_surface_physics .EQ. 99 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_2 ( zs , dzs , num_soil_layers ) + CALL init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , & + st_input , sm_input , sw_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , sw_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) +! CALL init_soil_old ( tsk , tmn , & +! smois , tslb , zs , dzs , num_soil_layers , & +! st000010_input , st010040_input , st040100_input , st100200_input , & +! st010200_input , & +! sm000010_input , sm010040_input , sm040100_input , sm100200_input , & +! sm010200_input , & +! landmask_input , sst_input , & +! ids , ide , jds , jde , kds , kde , & +! ims , ime , jms , jme , kms , kme , & +! its , ite , jts , jte , kts , kte ) + ELSE IF ( ( sf_surface_physics .EQ. 3 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_3 ( zs , dzs , num_soil_layers ) + CALL init_soil_3_real ( tsk , tmn , smois , tslb , & + st_input , sm_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + + END SUBROUTINE process_soil_real + + SUBROUTINE process_soil_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois, & + tsk,tmn,zs,dzs, & + num_soil_layers, & + sf_surface_physics , & + ids,ide, jds,jde, kds,kde,& + ims,ime, jms,jme, kms,kme,& + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: num_soil_layers , sf_surface_physics + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(INOUT) :: smois, tslb + + REAL, DIMENSION(num_soil_layers), INTENT(OUT) :: dzs,zs + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT) :: tsk, tmn + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra + INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp + + ! Local variables. + + INTEGER :: itf,jtf + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF ( ( sf_surface_physics .EQ. 1 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_1 ( zs , dzs , num_soil_layers ) + CALL init_soil_1_ideal(tsk,tmn,tslb,xland, & + ivgtyp,zs,dzs,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE IF ( ( sf_surface_physics .EQ. 2 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_2 ( zs , dzs , num_soil_layers ) + CALL init_soil_2_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois,tmn, & + num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ELSE IF ( ( sf_surface_physics .EQ. 3 ) .AND. ( num_soil_layers .GT. 1 ) ) THEN + CALL init_soil_depth_3 ( zs , dzs , num_soil_layers ) + + END IF + + END SUBROUTINE process_soil_ideal + + SUBROUTINE adjust_soil_temp_new ( tmn , sf_surface_physics , & + tsk , ter , toposoil , landmask , flag_toposoil , & + st000010 , st010040 , st040100 , st100200 , st010200 , & + flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , & + soilt000 , soilt005 , soilt020 , soilt040 , soilt160 , soilt300 , & + flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: ter , toposoil , landmask + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tmn , tsk + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: st000010 , st010040 , st040100 , st100200 , st010200 + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: soilt000 , soilt005 , soilt020 , soilt040 , soilt160 , soilt300 + + INTEGER , INTENT(IN) :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 + INTEGER , INTENT(IN) :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 + INTEGER , INTENT(IN) :: sf_surface_physics , flag_toposoil + + INTEGER :: i , j + + REAL :: soil_elev_min_val , soil_elev_max_val , soil_elev_min_dif , soil_elev_max_dif + + ! Do we have a soil field with which to modify soil temperatures? + + IF ( flag_toposoil .EQ. 1 ) THEN + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + + ! Is the toposoil field OK, or is it a subversive soil elevation field. We can tell + ! usually by looking at values. Anything less than -1000 m (lower than the Dead Sea) is + ! bad. Anything larger than 10 km (taller than Everest) is toast. Also, anything where + ! the difference between the soil elevation and the terrain is greater than 3 km means + ! that the soil data is either all zeros or that the data are inconsistent. Any of these + ! three conditions is grievous enough to induce a WRF fatality. However, if they are at + ! a water point, then we can safely ignore them. + + soil_elev_min_val = toposoil(i,j) + soil_elev_max_val = toposoil(i,j) + soil_elev_min_dif = ter(i,j) - toposoil(i,j) + soil_elev_max_dif = ter(i,j) - toposoil(i,j) + + IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( soil_elev_min_val .LT. -1000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN +!print *,'no soil temperature elevation adjustment, soil height too small = ',toposoil(i,j) +cycle +! CALL wrf_error_fatal ( 'TOPOSOIL values have large negative values < -1000 m, unrealistic.' ) + ENDIF + + IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( soil_elev_max_val .GT. 10000 ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN +print *,'no soil temperature elevation adjustment, soil height too high = ',toposoil(i,j) +cycle + CALL wrf_error_fatal ( 'TOPOSOIL values have large positive values > 10,000 m , unrealistic.' ) + ENDIF + + IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. & + ( landmask(i,j) .LT. 0.5 ) ) THEN + CYCLE + ELSE IF ( ( ( soil_elev_min_dif .LT. -3000 ) .OR. ( soil_elev_max_dif .GT. 3000 ) ) .AND. & + ( landmask(i,j) .GT. 0.5 ) ) THEN +print *,'no soil temperature elevation adjustment, diff of soil height and terrain = ',ter(i,j) - toposoil(i,j) +cycle + CALL wrf_error_fatal ( 'TOPOSOIL difference with terrain elevation differs by more than 3000 m, unrealistic' ) + ENDIF + + ! For each of the fields that we would like to modify, check to see if it came in from the SI. + ! If so, then use a -6.5 K/km lapse rate (based on the elevation diffs). We only adjust when we + ! are not at a water point. + + IF (landmask(i,j) .GT. 0.5 ) THEN + + IF ( sf_surface_physics .EQ. 1 ) THEN + tmn(i,j) = tmn(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + tsk(i,j) = tsk(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + + IF ( flag_st000010 .EQ. 1 ) THEN + st000010(i,j) = st000010(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st010040 .EQ. 1 ) THEN + st010040(i,j) = st010040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st040100 .EQ. 1 ) THEN + st040100(i,j) = st040100(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st100200 .EQ. 1 ) THEN + st100200(i,j) = st100200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_st010200 .EQ. 1 ) THEN + st010200(i,j) = st010200(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + IF ( flag_soilt000 .EQ. 1 ) THEN + soilt000(i,j) = soilt000(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt005 .EQ. 1 ) THEN + soilt005(i,j) = soilt005(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt020 .EQ. 1 ) THEN + soilt020(i,j) = soilt020(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt040 .EQ. 1 ) THEN + soilt040(i,j) = soilt040(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt160 .EQ. 1 ) THEN + soilt160(i,j) = soilt160(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + IF ( flag_soilt300 .EQ. 1 ) THEN + soilt300(i,j) = soilt300(i,j) - 0.0065 * ( ter(i,j) - toposoil(i,j) ) + END IF + + END IF + END DO + END DO + + END IF + + END SUBROUTINE adjust_soil_temp_new + + + SUBROUTINE init_soil_depth_1 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + CHARACTER (LEN=132) :: message + + ! Define layers (top layer = 0.01 m). Double the thicknesses at each step (dzs values). + ! The distance from the ground level to the midpoint of the layer is given by zs. + + ! ------- Ground Level ---------- || || || || + ! || || || || zs(1) = 0.005 m + ! -- -- -- -- -- -- -- -- -- || || || \/ + ! || || || + ! ----------------------------------- || || || \/ dzs(1) = 0.01 m + ! || || || + ! || || || zs(2) = 0.02 + ! -- -- -- -- -- -- -- -- -- || || \/ + ! || || + ! || || + ! ----------------------------------- || || \/ dzs(2) = 0.02 m + ! || || + ! || || + ! || || + ! || || zs(3) = 0.05 + ! -- -- -- -- -- -- -- -- -- || \/ + ! || + ! || + ! || + ! || + ! ----------------------------------- \/ dzs(3) = 0.04 m + + IF ( num_soil_layers .NE. 5 ) THEN + write(message,FMT= '(A)') 'Usually, the 5-layer diffusion uses 5 layers. Change this in the namelist.' + CALL wrf_error_fatal ( message ) + END IF + + dzs(1)=.01 + zs(1)=.5*dzs(1) + + DO l=2,num_soil_layers + dzs(l)=2*dzs(l-1) + zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l) + ENDDO + + END SUBROUTINE init_soil_depth_1 + + SUBROUTINE init_soil_depth_2 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + CHARACTER (LEN=132) :: message + + dzs = (/ 0.1 , 0.3 , 0.6 , 1.0 /) + + IF ( num_soil_layers .NE. 4 ) THEN + write(message,FMT='(A)') 'Usually, the LSM uses 4 layers. Change this in the namelist.' + CALL wrf_error_fatal ( message ) + END IF + + zs(1)=.5*dzs(1) + + DO l=2,num_soil_layers + zs(l)=zs(l-1)+.5*dzs(l-1)+.5*dzs(l) + ENDDO + + END SUBROUTINE init_soil_depth_2 + + SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_soil_layers + + REAL, DIMENSION(1:num_soil_layers), INTENT(OUT) :: zs,dzs + + INTEGER :: l + + CHARACTER (LEN=132) :: message + +! in RUC LSM ZS - soil levels, and DZS - soil layer thicknesses, not used +! ZS is specified in the namelist: num_soil_layers = 6 or 9. +! Other options with number of levels are possible, but +! WRF users should change consistently the namelist entry with the +! ZS array in this subroutine. + + IF ( num_soil_layers .EQ. 6) THEN + zs = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /) +! dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /) + ELSEIF ( num_soil_layers .EQ. 9) THEN + zs = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /) +! dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /) + ENDIF + + IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN + WRITE(message,FMT= '(A)')'Usually, the RUC LSM uses 6, 9 or more levels. Change this in the namelist.' + CALL wrf_error_fatal ( message ) + END IF + + END SUBROUTINE init_soil_depth_3 + + SUBROUTINE init_soil_1_real ( tsk , tmn , tslb , zs , dzs , & + num_soil_layers , real_data_init_type , & + landmask , sst , flag_sst , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , real_data_init_type , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tsk , tmn + + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb + + INTEGER :: i , j , l + + ! Soil temperature is linearly interpolated between the skin temperature (taken to be at a + ! depth of 0.5 cm) and the deep soil, annual temperature (taken to be at a depth of 23 cm). + ! The tslb(i,1,j) is the skin temperature, and the tslb(i,num_soil_layers,j) level is the + ! annual mean temperature. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .GT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= ( tsk(i,j) * ( zs(num_soil_layers) - zs(l) ) + & + tmn(i,j) * ( zs( l) - zs(1) ) ) / & + ( zs(num_soil_layers) - zs(1) ) + END DO + ELSE + IF ( ( real_data_init_type .EQ. 1 ) .AND. ( flag_sst .EQ. 1 ) ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= sst(i,j) + END DO + ELSE + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + END DO + END IF + END IF + END DO + END DO + + END SUBROUTINE init_soil_1_real + + SUBROUTINE init_soil_1_ideal(tsk,tmn,tslb,xland, & + ivgtyp,ZS,DZS,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: num_soil_layers + + REAL, DIMENSION( ims:ime , 1 , jms:jme ), INTENT(OUT) :: tslb + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: xland + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: ivgtyp + + REAL, DIMENSION(1:), INTENT(IN) :: dzs,zs + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN) :: tsk, tmn + + ! Lcal variables. + + INTEGER :: l,j,i,itf,jtf + + itf=MIN(ite,ide-1) + jtf=MIN(jte,jde-1) + + IF (num_soil_layers.NE.1)THEN + DO j=jts,jtf + DO l=1,num_soil_layers + DO i=its,itf + tslb(i,l,j)=( tsk(i,j)*(zs(num_soil_layers)-zs(l)) + tmn(i,j)*(zs(l)-zs(1)) ) / & + ( zs(num_soil_layers)-zs(1) ) + ENDDO + ENDDO + ENDDO + ENDIF + DO j=jts,jtf + DO i=its,itf + xland(i,j) = 2 + ivgtyp(i,j) = 7 + ENDDO + ENDDO + + END SUBROUTINE init_soil_1_ideal + + SUBROUTINE init_soil_2_real ( tsk , tmn , smois , sh2o , tslb , & + st_input , sm_input , sw_input , landmask , sst , & + zs , dzs , & + st_levels_input , sm_levels_input , sw_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilmt000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , & + num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilmt000 + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + INTEGER , DIMENSION(1:num_sw_levels_input) , INTENT(INOUT) :: sw_levels_input + + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,1:num_sw_levels_alloc,jms:jme) , INTENT(INOUT) :: sw_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois , sh2o + + REAL , ALLOCATABLE , DIMENSION(:) :: zhave + + INTEGER :: i , j , l , lout , lin , lwant , lhave , num + REAL :: temp + LOGICAL :: found_levels + CHARACTER(LEN=132) :: message + + ! Are there any soil temp and moisture levels - ya know, they are mandatory. + + num = num_st_levels_input * num_sm_levels_input + + IF ( num .GE. 1 ) THEN + + ! Ordered levels that we have data for. + + ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input,num_sw_levels_input) +2) ) + + ! Sort the levels for temperature. + + outert : DO lout = 1 , num_st_levels_input-1 + innert : DO lin = lout+1 , num_st_levels_input + IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN + temp = st_levels_input(lout) + st_levels_input(lout) = st_levels_input(lin) + st_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = st_input(i,lout+1,j) + st_input(i,lout+1,j) = st_input(i,lin+1,j) + st_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innert + END DO outert + + IF ( flag_soilt000 .NE. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,1,j) = tsk(i,j) + st_input(i,num_st_levels_input+2,j) = tmn(i,j) + END DO + END DO + ENDIF + + +#if ( NMM_CORE == 1 ) +!new +! write(message,*) 'st_input(1) in init_soil_2_real' +! CALL wrf_message(message) + DO J=MIN(jde-1,jte),JTS, -MIN(jde-1,jte)/15 +! write(message,616) (st_input(I,1,J),I=its , MIN(ide-1,ite),MIN(ide-1,ite)/10) +! CALL wrf_message(message) + ENDDO + +! write(message,*) 'st_input(2) in init_soil_2_real' +! CALL wrf_message(message) + DO J=MIN(jde-1,jte),JTS, -MIN(jde-1,jte)/15 +! write(message,616) (st_input(I,2,J),I=its , MIN(ide-1,ite),MIN(ide-1,ite)/10) +! CALL wrf_message(message) + ENDDO + + 616 format(20(f4.0,1x)) +#endif + + ! Sort the levels for moisture. + + outerm: DO lout = 1 , num_sm_levels_input-1 + innerm : DO lin = lout+1 , num_sm_levels_input + IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN + temp = sm_levels_input(lout) + sm_levels_input(lout) = sm_levels_input(lin) + sm_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sm_input(i,lout+1,j) + sm_input(i,lout+1,j) = sm_input(i,lin+1,j) + sm_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innerm + END DO outerm + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,1,j) = sm_input(i,2,j) + sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j) + END DO + END DO + + ! Sort the levels for liquid moisture. + + outerw: DO lout = 1 , num_sw_levels_input-1 + innerw : DO lin = lout+1 , num_sw_levels_input + IF ( sw_levels_input(lout) .GT. sw_levels_input(lin) ) THEN + temp = sw_levels_input(lout) + sw_levels_input(lout) = sw_levels_input(lin) + sw_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sw_input(i,lout+1,j) + sw_input(i,lout+1,j) = sw_input(i,lin+1,j) + sw_input(i,lin+1,j) = temp + END DO + END DO + END IF + END DO innerw + END DO outerw + IF ( num_sw_levels_input .GT. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sw_input(i,1,j) = sw_input(i,2,j) + sw_input(i,num_sw_levels_input+2,j) = sw_input(i,num_sw_levels_input+1,j) + END DO + END DO + END IF + + found_levels = .TRUE. + + ELSE IF ( ( num .LE. 0 ) .AND. ( start_date .NE. current_date ) ) THEN + + found_levels = .FALSE. + + ELSE + CALL wrf_error_fatal ( & + 'No input soil level data (temperature, moisture or liquid, or all are missing). Required for LSM.' ) + END IF + + ! Is it OK to continue? + + IF ( found_levels ) THEN + + ! Here are the levels that we have from the input for temperature. The input levels plus + ! two more: the skin temperature at 0 cm, and the annual mean temperature at 300 cm. + + IF (flag_soilt000 .NE. 1) then + zhave(1) = 0. + DO l = 1 , num_st_levels_input + zhave(l+1) = st_levels_input(l) / 100. + END DO + zhave(num_st_levels_input+2) = 300. / 100. + ELSE + DO l = 1 , num_st_levels_input + zhave(l) = st_levels_input(l) / 100. + END DO + ENDIF + + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt : DO lwant = 1 , num_soil_layers + z_havet : DO lhave = 1 , num_st_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet + END IF + END DO z_havet + END DO z_wantt + + ! Here are the levels that we have from the input for moisture. The input levels plus + ! two more: a value at 0 cm and one at 300 cm. The 0 cm value is taken to be identical + ! to the most shallow layer's value. Similarly, the 300 cm value is taken to be the same + ! as the most deep layer's value. + + zhave(1) = 0. + DO l = 1 , num_sm_levels_input + zhave(l+1) = sm_levels_input(l) / 100. + END DO + zhave(num_sm_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantm : DO lwant = 1 , num_soil_layers + z_havem : DO lhave = 1 , num_sm_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem + END IF + END DO z_havem + END DO z_wantm + + ! Any liquid soil moisture to worry about? + + IF ( num_sw_levels_input .GT. 1 ) THEN + + zhave(1) = 0. + DO l = 1 , num_sw_levels_input + zhave(l+1) = sw_levels_input(l) / 100. + END DO + zhave(num_sw_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantw : DO lwant = 1 , num_soil_layers + z_havew : DO lhave = 1 , num_sw_levels_input +2 -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sh2o(i,lwant,j)= ( sw_input(i,lhave ,j) * ( zhave(lhave+1) - zs (lwant) ) + & + sw_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havew + END IF + END DO z_havew + END DO z_wantw + + END IF + + + ! Over water, put in reasonable values for soil temperature and moisture. These won't be + ! used, but they will make a more continuous plot. + + IF ( flag_sst .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= sst(i,j) + smois(i,l,j)= 1.0 + sh2o (i,l,j)= 1.0 + END DO + END IF + END DO + END DO + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + smois(i,l,j)= 1.0 + sh2o (i,l,j)= 1.0 + END DO + END IF + END DO + END DO + END IF + + DEALLOCATE (zhave) + + END IF + + END SUBROUTINE init_soil_2_real + + SUBROUTINE init_soil_2_ideal ( xland,xice,vegfra,snow,canwat, & + ivgtyp,isltyp,tslb,smois,tmn, & + num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN) ::ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) ::num_soil_layers + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , INTENT(OUT) :: smois, tslb + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: xland, snow, canwat, xice, vegfra, tmn + + INTEGER, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT) :: ivgtyp, isltyp + + INTEGER :: icm,jcm,itf,jtf + INTEGER :: i,j,l + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + icm = ide/2 + jcm = jde/2 + + DO j=jts,jtf + DO l=1,num_soil_layers + DO i=its,itf + + smois(i,1,j)=0.10 + smois(i,2,j)=0.10 + smois(i,3,j)=0.10 + smois(i,4,j)=0.10 + + tslb(i,1,j)=295. + tslb(i,2,j)=297. + tslb(i,3,j)=293. + tslb(i,4,j)=293. + + ENDDO + ENDDO + ENDDO + + DO j=jts,jtf + DO i=its,itf + xland(i,j) = 2 + tmn(i,j) = 294. + xice(i,j) = 0. + vegfra(i,j) = 0. + snow(i,j) = 0. + canwat(i,j) = 0. + ivgtyp(i,j) = 7 + isltyp(i,j) = 8 + ENDDO + ENDDO + + END SUBROUTINE init_soil_2_ideal + + SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & + st_input , sm_input , landmask, sst, & + zs , dzs , & + st_levels_input , sm_levels_input , & + num_soil_layers , num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + flag_sst , flag_soilt000 , flag_soilm000 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: num_soil_layers , & + num_st_levels_input , num_sm_levels_input , & + num_st_levels_alloc , num_sm_levels_alloc , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + INTEGER , INTENT(IN) :: flag_sst, flag_soilt000, flag_soilm000 + + INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input + INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input + + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs + + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + + REAL , ALLOCATABLE , DIMENSION(:) :: zhave + + INTEGER :: i , j , l , lout , lin , lwant , lhave + REAL :: temp + + ! Allocate the soil layer array used for interpolating. + + IF ( ( num_st_levels_input .LE. 0 ) .OR. & + ( num_sm_levels_input .LE. 0 ) ) THEN + PRINT '(A)','No input soil level data (either temperature or moisture, or both are missing). Required for RUC LSM.' + CALL wrf_error_fatal ( 'no soil data' ) + ELSE + IF ( flag_soilt000 .eq. 1 ) THEN + PRINT '(A)',' Assume RUC LSM 6-level input' + ALLOCATE ( zhave( MAX(num_st_levels_input,num_sm_levels_input) ) ) + ELSE + PRINT '(A)',' Assume non-RUC LSM input' + ALLOCATE ( zhave( MAX(num_st_levels_input,num_soil_layers) ) ) + END IF + END IF + + ! Sort the levels for temperature. + + outert : DO lout = 1 , num_st_levels_input-1 + innert : DO lin = lout+1 , num_st_levels_input + IF ( st_levels_input(lout) .GT. st_levels_input(lin) ) THEN + temp = st_levels_input(lout) + st_levels_input(lout) = st_levels_input(lin) + st_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = st_input(i,lout,j) + st_input(i,lout,j) = st_input(i,lin,j) + st_input(i,lin,j) = temp + END DO + END DO + END IF + END DO innert + END DO outert + + IF ( flag_soilt000 .NE. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + st_input(i,1,j) = tsk(i,j) + st_input(i,num_st_levels_input+2,j) = tmn(i,j) + END DO + END DO + END IF + + ! Sort the levels for moisture. + + outerm: DO lout = 1 , num_sm_levels_input-1 + innerm : DO lin = lout+1 , num_sm_levels_input + IF ( sm_levels_input(lout) .GT. sm_levels_input(lin) ) THEN + temp = sm_levels_input(lout) + sm_levels_input(lout) = sm_levels_input(lin) + sm_levels_input(lin) = NINT(temp) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + temp = sm_input(i,lout,j) + sm_input(i,lout,j) = sm_input(i,lin,j) + sm_input(i,lin,j) = temp + END DO + END DO + END IF + END DO innerm + END DO outerm + + IF ( flag_soilm000 .NE. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + sm_input(i,1,j) = sm_input(i,2,j) + sm_input(i,num_sm_levels_input+2,j) = sm_input(i,num_sm_levels_input+1,j) + END DO + END DO + END IF + + ! Here are the levels that we have from the input for temperature. + + IF ( flag_soilt000 .EQ. 1 ) THEN + DO l = 1 , num_st_levels_input + zhave(l) = st_levels_input(l) / 100. + END DO + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt : DO lwant = 1 , num_soil_layers + z_havet : DO lhave = 1 , num_st_levels_input -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet + END IF + END DO z_havet + END DO z_wantt + + ELSE + + zhave(1) = 0. + DO l = 1 , num_st_levels_input + zhave(l+1) = st_levels_input(l) / 100. + END DO + zhave(num_st_levels_input+2) = 300. / 100. + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantt_2 : DO lwant = 1 , num_soil_layers + z_havet_2 : DO lhave = 1 , num_st_levels_input +2 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tslb(i,lwant,j)= ( st_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + st_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havet_2 + END IF + END DO z_havet_2 + END DO z_wantt_2 + + END IF + + ! Here are the levels that we have from the input for moisture. + + IF ( flag_soilm000 .EQ. 1 ) THEN + DO l = 1 , num_sm_levels_input + zhave(l) = sm_levels_input(l) / 100. + END DO + + ! Interpolate between the layers we have (zhave) and those that we want (zs). + + z_wantm : DO lwant = 1 , num_soil_layers + z_havem : DO lhave = 1 , num_sm_levels_input -1 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem + END IF + END DO z_havem + END DO z_wantm + + ELSE + + zhave(1) = 0. + DO l = 1 , num_sm_levels_input + zhave(l+1) = sm_levels_input(l) / 100. + END DO + zhave(num_sm_levels_input+2) = 300. / 100. + + z_wantm_2 : DO lwant = 1 , num_soil_layers + z_havem_2 : DO lhave = 1 , num_sm_levels_input +2 + IF ( ( zs(lwant) .GE. zhave(lhave ) ) .AND. & + ( zs(lwant) .LE. zhave(lhave+1) ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + smois(i,lwant,j)= ( sm_input(i,lhave,j ) * ( zhave(lhave+1) - zs (lwant) ) + & + sm_input(i,lhave+1,j) * ( zs (lwant ) - zhave(lhave) ) ) / & + ( zhave(lhave+1) - zhave(lhave) ) + END DO + END DO + EXIT z_havem_2 + END IF + END DO z_havem_2 + END DO z_wantm_2 + + END IF + ! Over water, put in reasonable values for soil temperature and moisture. These won't be + ! used, but they will make a more continuous plot. + + IF ( flag_sst .EQ. 1 ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j) = sst(i,j) + tsk(i,j) = sst(i,j) + smois(i,l,j)= 1.0 + END DO + END IF + END DO + END DO + ELSE + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( landmask(i,j) .LT. 0.5 ) THEN + DO l = 1 , num_soil_layers + tslb(i,l,j)= tsk(i,j) + smois(i,l,j)= 1.0 + END DO + END IF + END DO + END DO + END IF + + DEALLOCATE (zhave) + + END SUBROUTINE init_soil_3_real + +END MODULE module_soil_pre + +#endif + diff --git a/wrfv2_fire/share/module_wrf_top.F b/wrfv2_fire/share/module_wrf_top.F new file mode 100644 index 00000000..813b0453 --- /dev/null +++ b/wrfv2_fire/share/module_wrf_top.F @@ -0,0 +1,296 @@ +!WRF:DRIVER_LAYER:TOP +! + +!TBH: $$$ move this to ../frame? + +MODULE module_wrf_top +! +! This module defines top-level wrf_init(), wrf_run(), and wrf_finalize() +! routines. +! + + USE module_machine + USE module_domain + USE module_integrate + USE module_driver_constants + USE module_configure + + USE module_timing + USE module_wrf_error + +#ifdef DM_PARALLEL + USE module_dm +#endif + + IMPLICIT NONE + + REAL :: time + + INTEGER :: loop , & + levels_to_process + + TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain + TYPE (grid_config_rec_type), SAVE :: config_flags + INTEGER :: number_at_same_level + INTEGER :: time_step_begin_restart + + INTEGER :: max_dom , domain_id , fid , oid , idum1 , idum2 , ierr + INTEGER :: debug_level + LOGICAL :: input_from_file + +#ifdef DM_PARALLEL + INTEGER :: nbytes + INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN + INTEGER :: configbuf( configbuflen ) + LOGICAL , EXTERNAL :: wrf_dm_on_monitor +#endif + + CHARACTER (LEN=80) :: rstname + CHARACTER (LEN=80) :: message + + INTERFACE + SUBROUTINE Setup_Timekeeping( grid ) + USE module_domain + TYPE(domain), POINTER :: grid + END SUBROUTINE Setup_Timekeeping + END INTERFACE + + +CONTAINS + + + SUBROUTINE wrf_init( no_init1 ) +! +! WRF initialization routine. +! + LOGICAL, OPTIONAL, INTENT(IN) :: no_init1 +#include "version_decl" + +! +! Program_name, a global variable defined in frame/module_domain.F, is +! set, then a routine init_modules is +! called. This calls all the init programs that are provided by the +! modules that are linked into WRF. These include initialization of +! external I/O packages. Also, some key initializations for +! distributed-memory parallelism occur here if DM_PARALLEL is specified +! in the compile: setting up I/O quilt processes to act as I/O servers +! and dividing up MPI communicators among those as well as initializing +! external communication packages such as RSL or RSL_LITE. +! +! + + program_name = "WRF " // TRIM(release_version) // " MODEL" + + ! Initialize WRF modules: + ! Phase 1 returns after MPI_INIT() (if it is called) + IF ( .NOT. PRESENT( no_init1 ) ) THEN + CALL init_modules(1) + ! Initialize utilities (time manager, etc.) + CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN ) + ENDIF + ! Phase 2 resumes after MPI_INIT() (if it is called) + CALL init_modules(2) + +! +! The wrf namelist.input file is read and stored in the USE associated +! structure model_config_rec, defined in frame/module_configure.F, by the +! call to initial_config. On distributed +! memory parallel runs this is done only on one processor, and then +! broadcast as a buffer. For distributed-memory, the broadcast of the +! configuration information is accomplished by first putting the +! configuration information into a buffer (get_config_as_buffer), broadcasting +! the buffer, then setting the configuration information (set_config_as_buffer). +! +! + +#ifdef DM_PARALLEL + IF ( wrf_dm_on_monitor() ) THEN + CALL initial_config + ENDIF + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_dm_initialize +#else + CALL initial_config +#endif + +! +! Among the configuration variables read from the namelist is +! debug_level. This is retrieved using nl_get_debug_level (Registry +! generated and defined in frame/module_configure.F). The value is then +! used to set the debug-print information level for use by wrf_debug throughout the code. Debug_level +! of zero (the default) causes no information to be printed when the +! model runs. The higher the number (up to 1000) the more information is +! printed. +! +! + + CALL nl_get_debug_level ( 1, debug_level ) + CALL set_wrf_debug_level ( debug_level ) + + ! allocated and configure the mother domain + + NULLIFY( null_domain ) + +! +! RSL is required for WRF nesting options. +! The non-MPI build that allows nesting is only supported on machines +! with the -DSTUBMPI option. Check to see if the WRF model is being asked +! for a for a multi-domain run (max_dom > 1, from the namelist). If so, +! then we check to make sure that we are under the parallel +! run option or we are on an acceptable machine. +! + + CALL nl_get_max_dom( 1, max_dom ) + IF ( max_dom > 1 ) THEN +#if ( ! defined(DM_PARALLEL) && ! defined(STUBMPI) ) + CALL wrf_error_fatal( & + 'nesting requires either an MPI build or use of the -DSTUBMPI option' ) +#endif + END IF + +! +! The top-most domain in the simulation is then allocated and configured +! by calling alloc_and_configure_domain. +! Here, in the case of this root domain, the routine is passed the +! globally accessible pointer to TYPE(domain), head_grid, defined in +! frame/module_domain.F. The parent is null and the child index is given +! as negative, signifying none. Afterwards, because the call to +! alloc_and_configure_domain may modify the model's configuration data +! stored in model_config_rec, the configuration information is again +! repacked into a buffer, broadcast, and unpacked on each task (for +! DM_PARALLEL compiles). The call to setup_timekeeping for head_grid relies +! on this configuration information, and it must occur after the second +! broadcast of the configuration information. +! +! + CALL wrf_message ( program_name ) + CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain ' ) + CALL alloc_and_configure_domain ( domain_id = 1 , & + grid = head_grid , & + parent = null_domain , & + kid = -1 ) + + CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' ) + CALL model_to_grid_config_rec ( head_grid%id , model_config_rec , config_flags ) + CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' ) + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + CALL wrf_debug ( 100 , 'wrf: calling init_wrfio' ) + CALL init_wrfio + +#ifdef DM_PARALLEL + CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) + CALL wrf_dm_bcast_bytes( configbuf, nbytes ) + CALL set_config_as_buffer( configbuf, configbuflen ) +#endif + + CALL Setup_Timekeeping (head_grid) + +! +! The head grid is initialized with read-in data through the call to med_initialdata_input, which is +! passed the pointer head_grid and a locally declared configuration data +! structure, config_flags, that is set by a call to model_to_grid_config_rec. It is +! also necessary that the indices into the 4d tracer arrays such as +! moisture be set with a call to set_scalar_indices_from_config +! prior to the call to initialize the domain. Both of these calls are +! told which domain they are setting up for by passing in the integer id +! of the head domain as head_grid%id, which is 1 for the +! top-most domain. +! +! In the case that write_restart_at_0h is set to true in the namelist, +! the model simply generates a restart file using the just read-in data +! and then shuts down. This is used for ensemble breeding, and is not +! typically enabled. +! +! + + CALL med_initialdata_input( head_grid , config_flags ) + + IF ( config_flags%write_restart_at_0h ) THEN + CALL med_restart_out ( head_grid, config_flags ) +#ifndef AUTODOC_BUILD +! prevent this from showing up before the call to integrate in the autogenerated call tree + CALL wrf_debug ( 0 , ' 0 h restart only wrf: SUCCESS COMPLETE WRF' ) +! TBH: $$$ Unscramble this later... +! TBH: $$$ Need to add state to avoid calling wrf_finalize() twice when ESMF +! TBH: $$$ library is used. Maybe just set clock stop_time=start_time and +! TBH: $$$ do not call wrf_finalize here... + CALL wrf_finalize( ) +#endif + END IF + + ! set default values for subtimes + head_grid%start_subtime = domain_get_start_time ( head_grid ) + head_grid%stop_subtime = domain_get_stop_time ( head_grid ) + + END SUBROUTINE wrf_init + + + + SUBROUTINE wrf_run( ) +! +! WRF run routine. +! + +! +! Once the top-level domain has been allocated, configured, and +! initialized, the model time integration is ready to proceed. The start +! and stop times for the domain are set to the start and stop time of the +! model run, and then integrate is called to +! advance the domain forward through that specified time interval. On +! return, the simulation is completed. A Mediation Layer-provided +! subroutine, med_shutdown_io is called +! to allow the the model to do any I/O specific cleanup and shutdown, and +! then the WRF Driver Layer routine wrf_shutdown (quilt servers would be +! directed to shut down here) is called to properly end the run, +! including shutting down the communications (for example, most comm +! layers would call MPI_FINALIZE at this point if they're using MPI). +! +! + + ! The forecast integration for the most coarse grid is now started. The + ! integration is from the first step (1) to the last step of the simulation. + + CALL wrf_debug ( 100 , 'wrf: calling integrate' ) + CALL integrate ( head_grid ) + CALL wrf_debug ( 100 , 'wrf: back from integrate' ) + + END SUBROUTINE wrf_run + + + + SUBROUTINE wrf_finalize( no_shutdown ) +! +! WRF finalize routine. +! + LOGICAL, OPTIONAL, INTENT(IN) :: no_shutdown + + ! shut down I/O + CALL med_shutdown_io ( head_grid , config_flags ) + CALL wrf_debug ( 100 , 'wrf: back from med_shutdown_io' ) + + CALL wrf_debug ( 0 , 'wrf: SUCCESS COMPLETE WRF' ) + + ! Call wrf_shutdown() (which calls MPI_FINALIZE() + ! for DM parallel runs). + IF ( .NOT. PRESENT( no_shutdown ) ) THEN + ! Finalize time manager + CALL WRFU_Finalize + CALL wrf_shutdown + ENDIF + + END SUBROUTINE wrf_finalize + + +END MODULE module_wrf_top + + diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F new file mode 100644 index 00000000..ab1f078b --- /dev/null +++ b/wrfv2_fire/share/output_wrf.F @@ -0,0 +1,600 @@ +!WRF:MEDIATION:IO +! ---principal wrf output routine (called from routines in module_io_domain ) + SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure +! USE module_date_time + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + INTEGER filestate + LOGICAL dryrun + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 , moad_cen_lat , stand_lon + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif, swrad_scat + INTEGER ucmcall, w_damping, smooth_option, feedback, surface_input_source, sst_update +#if (EM_CORE == 1) + INTEGER grid_id , parent_id , i_parent_start , j_parent_start , parent_grid_ratio + INTEGER diff_6th_opt + REAL diff_6th_factor + INTEGER grid_fdda, gfdda_interval_m, gfdda_end_h, if_ramping, & + obs_nudge_opt, obs_nudge_wind, obs_nudge_temp, obs_nudge_mois, obs_nudge_pstr, obs_idynin, obs_ionf + REAL fgdt, guv, gt, gq, dtramp_min, & + obs_coef_wind, obs_coef_temp, obs_coef_mois, obs_coef_pstr, obs_dtramp, fdda_end + LOGICAL pd_moist, pd_scalar, pd_tke +#endif + CHARACTER (len=19) simulation_start_date + CHARACTER (len=len_current_date) current_date_save + INTEGER simulation_start_year , & + simulation_start_month , & + simulation_start_day , & + simulation_start_hour , & + simulation_start_minute , & + simulation_start_second + INTEGER rc + INTEGER :: io_form + LOGICAL, EXTERNAL :: multi_files + INTEGER, EXTERNAL :: use_package + + CHARACTER*256 message + CHARACTER*80 fname + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + TYPE(WRFU_TimeInterval) :: bdy_increment + TYPE(WRFU_Time) :: next_time, currentTime, startTime + CHARACTER*40 :: next_datestr + INTEGER :: start_year , start_month , start_day , start_hour , start_minute , start_second + LOGICAL :: adjust + + WRITE(wrf_err_message,*)'output_wrf: begin, fid = ',fid + CALL wrf_debug( 300 , wrf_err_message ) + + CALL wrf_inquire_filename ( fid , fname , filestate , ierr ) + IF ( ierr /= 0 ) THEN + WRITE(wrf_err_message,*)'module_io_wrf: output_wrf: wrf_inquire_filename Status = ',ierr + CALL wrf_error_fatal( wrf_err_message ) + ENDIF + + WRITE(wrf_err_message,*)'output_wrf: fid,filestate = ',fid,filestate + CALL wrf_debug( 300 , wrf_err_message ) + + ! io_form is used to determine if multi-file I/O is enabled and to + ! control writing of format-specific time-independent metadata + IF ( switch .EQ. model_input_only ) THEN + CALL nl_get_io_form_input( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + CALL nl_get_io_form_auxinput1( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input2_only ) THEN + CALL nl_get_io_form_auxinput2( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input3_only ) THEN + CALL nl_get_io_form_auxinput3( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input4_only ) THEN + CALL nl_get_io_form_auxinput4( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input5_only ) THEN + CALL nl_get_io_form_auxinput5( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input6_only ) THEN + CALL nl_get_io_form_auxinput6( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input7_only ) THEN + CALL nl_get_io_form_auxinput7( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input8_only ) THEN + CALL nl_get_io_form_auxinput8( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input9_only ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input10_only ) THEN + CALL nl_get_io_form_gfdda( 1, io_form ) + ELSE IF ( switch .EQ. aux_model_input11_only ) THEN + CALL nl_get_io_form_auxinput11( 1, io_form ) + + ELSE IF ( switch .EQ. history_only ) THEN + CALL nl_get_io_form_history( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist1_only ) THEN + CALL nl_get_io_form_auxhist1( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist2_only ) THEN + CALL nl_get_io_form_auxhist2( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist3_only ) THEN + CALL nl_get_io_form_auxhist3( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist4_only ) THEN + CALL nl_get_io_form_auxhist4( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist5_only ) THEN + CALL nl_get_io_form_auxhist5( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist6_only ) THEN + CALL nl_get_io_form_auxhist6( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist7_only ) THEN + CALL nl_get_io_form_auxhist7( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist8_only ) THEN + CALL nl_get_io_form_auxhist8( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist9_only ) THEN + CALL nl_get_io_form_auxhist9( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist10_only ) THEN + CALL nl_get_io_form_auxhist10( 1, io_form ) + ELSE IF ( switch .EQ. aux_hist11_only ) THEN + CALL nl_get_io_form_auxhist11( 1, io_form ) + + ELSE IF ( switch .EQ. restart_only ) THEN + CALL nl_get_io_form_restart( 1, io_form ) + ELSE IF ( switch .EQ. boundary_only ) THEN + CALL nl_get_io_form_boundary( 1, io_form ) + ELSE ! default: use history + CALL nl_get_io_form_history( 1, io_form ) + ENDIF + + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + + WRITE(wrf_err_message,*)'output_wrf: dryrun = ',dryrun + CALL wrf_debug( 300 , wrf_err_message ) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1, dyn_opt ) + call nl_get_diff_opt ( 1, diff_opt ) + call nl_get_km_opt ( 1, km_opt ) + call nl_get_damp_opt ( 1, damp_opt ) + call nl_get_khdif ( grid%id, khdif ) + call nl_get_kvdif ( grid%id, kvdif ) + call nl_get_mp_physics ( grid%id, mp_physics ) + call nl_get_ra_lw_physics ( grid%id, ra_lw_physics ) + call nl_get_ra_sw_physics ( grid%id, ra_sw_physics ) + call nl_get_sf_sfclay_physics ( grid%id, sf_sfclay_physics ) + call nl_get_sf_surface_physics ( grid%id, sf_surface_physics ) + call nl_get_bl_pbl_physics ( grid%id, bl_pbl_physics ) + call nl_get_cu_physics ( grid%id, cu_physics ) + +! add nml variables in 2.2 + call nl_get_surface_input_source ( 1 , surface_input_source ) + call nl_get_sst_update ( 1 , sst_update ) + call nl_get_feedback ( 1 , feedback ) + call nl_get_smooth_option ( 1 , smooth_option ) + call nl_get_swrad_scat ( 1 , swrad_scat ) + call nl_get_ucmcall ( 1 , ucmcall ) + call nl_get_w_damping ( 1 , w_damping ) + +#if (EM_CORE == 1) + CALL nl_get_pd_moist ( grid%id , pd_moist ) + CALL nl_get_pd_scalar ( grid%id , pd_scalar ) + CALL nl_get_pd_tke ( grid%id , pd_tke ) + CALL nl_get_diff_6th_opt ( grid%id , diff_6th_opt ) + CALL nl_get_diff_6th_factor ( grid%id , diff_6th_factor ) + CALL nl_get_grid_fdda ( grid%id , grid_fdda ) + CALL nl_get_gfdda_end_h( grid%id , gfdda_end_h ) + CALL nl_get_gfdda_interval_m ( grid%id , gfdda_interval_m ) + + IF ( grid_fdda == 1 ) THEN + CALL nl_get_fgdt ( grid%id , fgdt ) + CALL nl_get_guv ( grid%id , guv ) + CALL nl_get_gt ( grid%id , gt ) + CALL nl_get_gq ( grid%id , gq ) + CALL nl_get_if_ramping ( 1 , if_ramping ) + CALL nl_get_dtramp_min ( 1 , dtramp_min ) + ENDIF + + CALL nl_get_obs_nudge_opt ( grid%id , obs_nudge_opt ) + IF ( obs_nudge_opt == 1 ) THEN + CALL nl_get_fdda_end ( grid%id , fdda_end ) + CALL nl_get_obs_nudge_wind ( grid%id , obs_nudge_wind ) + CALL nl_get_obs_coef_wind ( grid%id , obs_coef_wind ) + CALL nl_get_obs_nudge_temp ( grid%id , obs_nudge_temp ) + CALL nl_get_obs_coef_temp ( grid%id , obs_coef_temp ) + CALL nl_get_obs_nudge_mois ( grid%id , obs_nudge_mois ) + CALL nl_get_obs_coef_mois ( grid%id , obs_coef_mois ) + CALL nl_get_obs_nudge_pstr ( grid%id , obs_nudge_pstr ) + CALL nl_get_obs_coef_pstr ( grid%id , obs_coef_pstr ) + CALL nl_get_obs_ionf ( 1 , obs_ionf ) + CALL nl_get_obs_idynin ( 1 , obs_idynin ) + CALL nl_get_obs_dtramp ( 1 , obs_dtramp ) + ENDIF +#endif + +! julday and gmt can be set in namelist_03 for ideal.exe run + CALL nl_get_gmt (grid%id, gmt) + CALL nl_get_julyr (grid%id, julyr) + CALL nl_get_julday (grid%id, julday) + CALL nl_get_mminlu ( 1, char_junk(1:4) ) + CALL nl_get_iswater (grid%id, iswater ) + CALL nl_get_cen_lat ( grid%id , cen_lat ) + CALL nl_get_cen_lon ( grid%id , cen_lon ) + CALL nl_get_truelat1 ( grid%id , truelat1 ) + CALL nl_get_truelat2 ( grid%id , truelat2 ) + CALL nl_get_moad_cen_lat ( grid%id , moad_cen_lat ) + CALL nl_get_stand_lon ( grid%id , stand_lon ) + CALL nl_get_map_proj ( grid%id , map_proj ) + +#if (EM_CORE == 1) + CALL nl_get_parent_id ( grid%id , parent_id ) + CALL nl_get_i_parent_start ( grid%id , i_parent_start ) + CALL nl_get_j_parent_start ( grid%id , j_parent_start ) + CALL nl_get_parent_grid_ratio ( grid%id , parent_grid_ratio ) +#endif + + CALL domain_clockprint(150, grid, & + 'DEBUG output_wrf(): before call to domain_clock_get,') + CALL domain_clock_get( grid, current_time=currentTime, & + start_time=startTime, & + current_timestr=current_date ) + WRITE ( wrf_err_message , * ) 'output_wrf: begin, current_date=',current_date + CALL wrf_debug ( 300 , wrf_err_message ) + + WRITE( message , * ) "OUTPUT FROM " , TRIM(program_name) + CALL wrf_put_dom_ti_char ( fid , 'TITLE' , TRIM(message) , ierr ) + ! added grib-specific metadata: Todd Hutchinson 8/21/2005 + IF ( ( use_package( io_form ) == IO_GRIB1 ) .OR. & + ( use_package( io_form ) == IO_GRIB2 ) ) THEN + CALL wrf_put_dom_ti_char ( fid, 'PROGRAM_NAME', TRIM(program_name) , ierr ) + ENDIF + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + WRITE ( start_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + start_year,start_month,start_day,start_hour,start_minute,start_second + CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr ) + IF ( switch .EQ. model_input_only) THEN + CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr ) + ELSE IF ( ( switch .EQ. restart_only ) .OR. ( switch .EQ. history_only ) ) THEN + CALL nl_get_simulation_start_year ( 1, simulation_start_year ) + CALL nl_get_simulation_start_month ( 1, simulation_start_month ) + CALL nl_get_simulation_start_day ( 1, simulation_start_day ) + CALL nl_get_simulation_start_hour ( 1, simulation_start_hour ) + CALL nl_get_simulation_start_minute ( 1, simulation_start_minute ) + CALL nl_get_simulation_start_second ( 1, simulation_start_second ) + WRITE ( simulation_start_date , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) & + simulation_start_year,simulation_start_month,simulation_start_day,& + simulation_start_hour,simulation_start_minute,simulation_start_second + CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(simulation_start_date) , ierr ) + END IF + + ibuf(1) = config_flags%e_we - config_flags%s_we + 1 + CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ibuf , 1 , ierr ) + + ibuf(1) = config_flags%e_sn - config_flags%s_sn + 1 + CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , ibuf , 1 , ierr ) + + ibuf(1) = config_flags%e_vert - config_flags%s_vert + 1 + CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , ibuf , 1 , ierr ) + +#if (EM_CORE == 1) + CALL wrf_put_dom_ti_real ( fid , 'DX' , config_flags%dx , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'DY' , config_flags%dy , 1 , ierr ) +#endif + +! added this metadatum for H. Chuan, NCEP, 030417, JM + SELECT CASE ( dyn_opt ) +#if (NMM_CORE == 1) + CASE ( dyn_nmm ) + CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'E' , ierr ) +#endif +#if (EM_CORE == 1) + CASE ( dyn_em ) + CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'C' , ierr ) +#endif +#if (COAMPS_CORE == 1 ) + CASE ( dyn_coamps ) + CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'B' , ierr ) +#endif + CASE DEFAULT + ! we don't know; don't put anything in the file + END SELECT + +! added these fields for W. Skamarock, 020402, JM + ibuf(1) = dyn_opt + CALL wrf_put_dom_ti_integer ( fid , 'DYN_OPT' , ibuf , 1 , ierr ) + ibuf(1) = diff_opt + CALL wrf_put_dom_ti_integer ( fid , 'DIFF_OPT' , ibuf , 1 , ierr ) + ibuf(1) = km_opt + CALL wrf_put_dom_ti_integer ( fid , 'KM_OPT' , ibuf , 1 , ierr ) + ibuf(1) = damp_opt + CALL wrf_put_dom_ti_integer ( fid , 'DAMP_OPT' , ibuf , 1 , ierr ) + rbuf(1) = khdif + CALL wrf_put_dom_ti_real ( fid , 'KHDIF' , rbuf , 1 , ierr ) + rbuf(1) = kvdif + CALL wrf_put_dom_ti_real ( fid , 'KVDIF' , rbuf , 1 , ierr ) + ibuf(1) = mp_physics + CALL wrf_put_dom_ti_integer ( fid , 'MP_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = ra_lw_physics + CALL wrf_put_dom_ti_integer ( fid , 'RA_LW_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = ra_sw_physics + CALL wrf_put_dom_ti_integer ( fid , 'RA_SW_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = sf_sfclay_physics + CALL wrf_put_dom_ti_integer ( fid , 'SF_SFCLAY_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = sf_surface_physics + CALL wrf_put_dom_ti_integer ( fid , 'SF_SURFACE_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = bl_pbl_physics + CALL wrf_put_dom_ti_integer ( fid , 'BL_PBL_PHYSICS' , ibuf , 1 , ierr ) + ibuf(1) = cu_physics + CALL wrf_put_dom_ti_integer ( fid , 'CU_PHYSICS' , ibuf , 1 , ierr ) + + ! added netcdf-specific metadata: + IF ( ( use_package( io_form ) == IO_NETCDF ) .OR. & + ( use_package( io_form ) == IO_PHDF5 ) .OR. & + ( use_package( io_form ) == IO_PNETCDF ) ) THEN + CALL wrf_put_dom_ti_integer ( fid, 'SURFACE_INPUT_SOURCE', surface_input_source , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'SST_UPDATE', sst_update , 1 , ierr ) +#if (EM_CORE == 1) + CALL wrf_put_dom_ti_integer ( fid, 'GRID_FDDA', grid_fdda , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'GFDDA_INTERVAL_M', gfdda_interval_m , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'GFDDA_END_H', gfdda_end_h , 1 , ierr ) +#endif + + IF ( switch .EQ. history_only ) THEN + CALL wrf_put_dom_ti_integer ( fid, 'UCMCALL', ucmcall , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'FEEDBACK', feedback , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'SMOOTH_OPTION', smooth_option , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'SWRAD_SCAT', swrad_scat , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'W_DAMPING', w_damping , 1 , ierr ) + +#if (EM_CORE == 1) + CALL wrf_put_dom_ti_logical ( fid, 'PD_MOIST', pd_moist , 1 , ierr ) + CALL wrf_put_dom_ti_logical ( fid, 'PD_SCALAR', pd_scalar , 1 , ierr ) + CALL wrf_put_dom_ti_logical ( fid, 'PD_TKE', pd_tke , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'DIFF_6TH_OPT', diff_6th_opt , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'DIFF_6TH_FACTOR', diff_6th_factor , 1 , ierr ) + + IF ( grid_fdda == 1 ) THEN + CALL wrf_put_dom_ti_real ( fid, 'FGDT', fgdt , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'GUV', guv , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'GT', gt , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'GQ', gq , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'IF_RAMPING', if_ramping , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'DTRAMP_MIN', dtramp_min , 1 , ierr ) + ENDIF + + CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_OPT', obs_nudge_opt , 1 , ierr ) + IF ( obs_nudge_opt == 1 ) THEN + CALL wrf_put_dom_ti_real ( fid, 'FDDA_END', fdda_end , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_WIND', obs_nudge_wind , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_WIND', obs_coef_wind , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_TEMP', obs_nudge_temp , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_TEMP', obs_coef_temp , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_MOIS', obs_nudge_mois , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_MOIS', obs_coef_mois , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_NUDGE_PSTR', obs_nudge_pstr , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'OBS_COEF_PSTR', obs_coef_pstr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_IONF', obs_ionf , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OBS_IDYNIN', obs_idynin , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid, 'OBS_DTRAMP', obs_dtramp , 1 , ierr ) + ENDIF +#endif + ENDIF ! history_only + ENDIF + +! added these fields for use by reassembly programs , 010831, JM +! modified these fields so "patch" == "domain" when multi-file output +! formats are not used. 051018, TBH + + ibuf(1) = MAX(ips,ids) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ids + CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(ipe,ide-1) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ide - 1 + CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MAX(ips,ids) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ids + CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_STAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(ipe,ide) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = ide + CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_STAG' , ibuf , 1 , ierr ) + ibuf(1) = MAX(jps,jds) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jds + CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(jpe,jde-1) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jde - 1 + CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MAX(jps,jds) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jds + CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_STAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(jpe,jde) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = jde + CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_STAG' , ibuf , 1 , ierr ) + + ibuf(1) = MAX(kps,kds) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kds + CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(kpe,kde-1) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kde - 1 + CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) + ibuf(1) = MAX(kps,kds) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kds + CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_STAG' , ibuf , 1 , ierr ) + ibuf(1) = MIN(kpe,kde) + IF ( .NOT. multi_files ( io_form ) ) ibuf(1) = kde + CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_STAG' , ibuf , 1 , ierr ) +#if (EM_CORE == 1) + ibuf(1) = grid%id + CALL wrf_put_dom_ti_integer ( fid , 'GRID_ID' , ibuf , 1 , ierr ) + ibuf(1) = parent_id + CALL wrf_put_dom_ti_integer ( fid , 'PARENT_ID' , ibuf , 1 , ierr ) + ibuf(1) = i_parent_start + CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , ibuf , 1 , ierr ) + ibuf(1) = j_parent_start + CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , ibuf , 1 , ierr ) + ibuf(1) = parent_grid_ratio + CALL wrf_put_dom_ti_integer ( fid , 'PARENT_GRID_RATIO' , ibuf , 1 , ierr ) +#endif + +! end add 010831 JM + +#if (EM_CORE != 1) + CALL wrf_put_dom_ti_real ( fid , 'DX' , config_flags%dx , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'DY' , config_flags%dy , 1 , ierr ) +#endif + CALL wrf_put_dom_ti_real ( fid , 'DT' , config_flags%dt , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'TRUELAT1', config_flags%truelat1, 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'TRUELAT2', config_flags%truelat2, 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'MOAD_CEN_LAT', config_flags%moad_cen_lat, 1 , ierr ) + CALL wrf_put_dom_ti_real ( fid , 'STAND_LON', config_flags%stand_lon, 1 , ierr ) + IF ( switch .NE. boundary_only ) THEN + CALL wrf_put_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , ierr ) + ENDIF +#if (NMM_CORE == 1) + write(0,*) 'MMINLU would be: ', MMINLU(1:4) + MMINLU(1:4)='USGS' + write(0,*) 'MMINLU now: ', MMINLU(1:4) +#endif + CALL wrf_put_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , ierr ) + CALL wrf_put_dom_ti_char ( fid , 'MMINLU', mminlu(1:4) , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'ISICE' , config_flags%isice , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , ierr ) +! added these fields for restarting of moving nests, JM + CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , config_flags%i_parent_start , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , config_flags%j_parent_start , 1 , ierr ) + + + IF ( switch .EQ. boundary_only ) THEN + CALL WRFU_TimeIntervalSet( bdy_increment, S=NINT(config_flags%bdyfrq),rc=rc) + next_time = currentTime + bdy_increment + CALL wrf_timetoa ( next_time, next_datestr ) + CALL wrf_put_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), current_date(1:19), ierr ) + CALL wrf_put_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr(1:19), ierr ) + ENDIF + + ! added grib2-specific metadata: Todd Hutchinson 8/21/2005 + IF ( use_package( io_form ) == IO_GRIB2 ) THEN + CALL wrf_put_dom_ti_integer ( fid , 'BACKGROUND_PROC_ID' , config_flags%background_proc_id , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'FORECAST_PROC_ID' , config_flags%forecast_proc_id , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'PRODUCTION_STATUS' , config_flags%production_status , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'COMPRESSION' , config_flags%compression , 1 , ierr ) + ENDIF + + CALL nl_get_adjust_output_times( grid%id, adjust ) + current_date_save = current_date +#if 1 + IF ( switch .EQ. model_input_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_inputout.inc' ) + CALL wrf_inputout( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput1out.inc' ) + CALL wrf_auxinput1out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input2_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput2out.inc' ) + CALL wrf_auxinput2out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input3_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput3out.inc' ) + CALL wrf_auxinput3out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input4_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput4out.inc' ) + CALL wrf_auxinput4out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input5_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput5out.inc' ) + CALL wrf_auxinput5out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input6_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput6out.inc' ) + CALL wrf_auxinput6out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input7_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput7out.inc' ) + CALL wrf_auxinput7out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input8_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput8out.inc' ) + CALL wrf_auxinput8out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input9_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput9out.inc' ) + CALL wrf_auxinput9out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input10_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput10out.inc' ) + CALL wrf_auxinput10out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_model_input11_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput11out.inc' ) + CALL wrf_auxinput11out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. history_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_histout.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( HISTORY_ALARM ), currentTime, startTime, current_date ) + CALL wrf_histout( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist1_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist1out' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST1_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist1out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist2_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist2out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST2_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist2out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist3_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist3out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST3_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist3out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist4_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist4out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST4_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist4out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist5_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist5out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST5_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist5out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist6_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist6out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST6_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist6out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist7_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist7out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST7_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist7out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist8_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist8out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST8_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist8out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist9_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist9out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST9_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist9out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist10_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist10out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST10_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist10out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. aux_hist11_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist11out.inc' ) + IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST11_ALARM ), currentTime, startTime, current_date ) + CALL wrf_auxhist11out( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. restart_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_restartout.inc' ) + CALL wrf_restartout( fid , grid , config_flags, switch, dryrun, ierr ) + ELSE IF ( switch .EQ. boundary_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_bdyout.inc' ) + CALL wrf_bdyout( fid , grid , config_flags, switch, dryrun, ierr ) + ENDIF +#else + CALL wrf_message ( "ALL I/O DISABLED IN share/module_io_wrf.F") +#endif + current_date = current_date_save + + IF ( .NOT. dryrun ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling wrf_iosync ' ) + CALL wrf_iosync ( fid , ierr ) + CALL wrf_debug ( 300 , 'output_wrf: back from wrf_iosync ' ) + ENDIF + + WRITE(wrf_err_message,*)'output_wrf: end, fid = ',fid + CALL wrf_debug( 300 , wrf_err_message ) + + RETURN + END SUBROUTINE output_wrf diff --git a/wrfv2_fire/share/set_timekeeping.F b/wrfv2_fire/share/set_timekeeping.F new file mode 100644 index 00000000..04b6e1be --- /dev/null +++ b/wrfv2_fire/share/set_timekeeping.F @@ -0,0 +1,2058 @@ +SUBROUTINE Setup_Timekeeping ( grid ) + USE module_domain + USE module_configure + USE module_utility + IMPLICIT NONE + TYPE(domain), POINTER :: grid +! Local + TYPE(WRFU_TimeInterval) :: begin_time, end_time, zero_time, one_minute, one_hour, padding_interval + TYPE(WRFU_TimeInterval) :: interval, run_length + TYPE(WRFU_Time) :: startTime, stopTime + TYPE(WRFU_TimeInterval) :: stepTime + INTEGER :: start_year,start_month,start_day,start_hour,start_minute,start_second + INTEGER :: end_year,end_month,end_day,end_hour,end_minute,end_second +#ifdef MOVE_NESTS + INTEGER :: vortex_interval +#endif + + INTEGER :: history_interval , restart_interval , & + history_interval_mo, restart_interval_mo, & + history_interval_d, restart_interval_d, & + history_interval_h, restart_interval_h, & + history_interval_m, restart_interval_m, & + history_interval_s, restart_interval_s + + INTEGER :: auxhist1_interval , auxhist2_interval , auxhist3_interval , & + auxhist1_interval_mo, auxhist2_interval_mo, auxhist3_interval_mo, & + auxhist1_interval_d, auxhist2_interval_d, auxhist3_interval_d, & + auxhist1_interval_h, auxhist2_interval_h, auxhist3_interval_h, & + auxhist1_interval_m, auxhist2_interval_m, auxhist3_interval_m, & + auxhist1_interval_s, auxhist2_interval_s, auxhist3_interval_s + + INTEGER :: auxhist4_interval , auxhist5_interval, & + auxhist4_interval_mo, auxhist5_interval_mo, & + auxhist4_interval_d, auxhist5_interval_d, & + auxhist4_interval_h, auxhist5_interval_h, & + auxhist4_interval_m, auxhist5_interval_m, & + auxhist4_interval_s, auxhist5_interval_s + + INTEGER :: auxhist6_interval , auxhist7_interval , auxhist8_interval , & + auxhist6_interval_mo, auxhist7_interval_mo, auxhist8_interval_mo, & + auxhist6_interval_d, auxhist7_interval_d, auxhist8_interval_d, & + auxhist6_interval_h, auxhist7_interval_h, auxhist8_interval_h, & + auxhist6_interval_m, auxhist7_interval_m, auxhist8_interval_m, & + auxhist6_interval_s, auxhist7_interval_s, auxhist8_interval_s + + INTEGER :: auxhist9_interval , auxhist10_interval , auxhist11_interval , & + auxhist9_interval_mo, auxhist10_interval_mo, auxhist11_interval_mo, & + auxhist9_interval_d, auxhist10_interval_d, auxhist11_interval_d, & + auxhist9_interval_h, auxhist10_interval_h, auxhist11_interval_h, & + auxhist9_interval_m, auxhist10_interval_m, auxhist11_interval_m, & + auxhist9_interval_s, auxhist10_interval_s, auxhist11_interval_s + + INTEGER :: auxinput1_interval , auxinput2_interval , auxinput3_interval , & + auxinput1_interval_mo, auxinput2_interval_mo, auxinput3_interval_mo, & + auxinput1_interval_d, auxinput2_interval_d, auxinput3_interval_d, & + auxinput1_interval_h, auxinput2_interval_h, auxinput3_interval_h, & + auxinput1_interval_m, auxinput2_interval_m, auxinput3_interval_m, & + auxinput1_interval_s, auxinput2_interval_s, auxinput3_interval_s + + INTEGER :: auxinput4_interval , auxinput5_interval , & + auxinput4_interval_mo, auxinput5_interval_mo, & + auxinput4_interval_d, auxinput5_interval_d, & + auxinput4_interval_h, auxinput5_interval_h, & + auxinput4_interval_m, auxinput5_interval_m, & + auxinput4_interval_s, auxinput5_interval_s + + INTEGER :: auxinput6_interval , auxinput7_interval , auxinput8_interval , & + auxinput6_interval_mo, auxinput7_interval_mo, auxinput8_interval_mo, & + auxinput6_interval_d, auxinput7_interval_d, auxinput8_interval_d, & + auxinput6_interval_h, auxinput7_interval_h, auxinput8_interval_h, & + auxinput6_interval_m, auxinput7_interval_m, auxinput8_interval_m, & + auxinput6_interval_s, auxinput7_interval_s, auxinput8_interval_s + + INTEGER :: auxinput9_interval , gfdda_interval , auxinput11_interval , & + auxinput9_interval_mo, gfdda_interval_mo, auxinput11_interval_mo, & + auxinput9_interval_d, gfdda_interval_d, auxinput11_interval_d, & + auxinput9_interval_h, gfdda_interval_h, auxinput11_interval_h, & + auxinput9_interval_m, gfdda_interval_m, auxinput11_interval_m, & + auxinput9_interval_s, gfdda_interval_s, auxinput11_interval_s + + INTEGER :: history_begin , restart_begin , & + history_begin_y, restart_begin_y, & + history_begin_mo, restart_begin_mo, & + history_begin_d, restart_begin_d, & + history_begin_h, restart_begin_h, & + history_begin_m, restart_begin_m, & + history_begin_s, restart_begin_s + + INTEGER :: auxhist1_begin , auxhist2_begin , auxhist3_begin , & + auxhist1_begin_y, auxhist2_begin_y, auxhist3_begin_y, & + auxhist1_begin_mo, auxhist2_begin_mo, auxhist3_begin_mo, & + auxhist1_begin_d, auxhist2_begin_d, auxhist3_begin_d, & + auxhist1_begin_h, auxhist2_begin_h, auxhist3_begin_h, & + auxhist1_begin_m, auxhist2_begin_m, auxhist3_begin_m, & + auxhist1_begin_s, auxhist2_begin_s, auxhist3_begin_s + + INTEGER :: auxhist4_begin , auxhist5_begin, & + auxhist4_begin_y, auxhist5_begin_y, & + auxhist4_begin_mo, auxhist5_begin_mo, & + auxhist4_begin_d, auxhist5_begin_d, & + auxhist4_begin_h, auxhist5_begin_h, & + auxhist4_begin_m, auxhist5_begin_m, & + auxhist4_begin_s, auxhist5_begin_s + + INTEGER :: auxhist6_begin , auxhist7_begin , auxhist8_begin , & + auxhist6_begin_y, auxhist7_begin_y, auxhist8_begin_y, & + auxhist6_begin_mo, auxhist7_begin_mo, auxhist8_begin_mo, & + auxhist6_begin_d, auxhist7_begin_d, auxhist8_begin_d, & + auxhist6_begin_h, auxhist7_begin_h, auxhist8_begin_h, & + auxhist6_begin_m, auxhist7_begin_m, auxhist8_begin_m, & + auxhist6_begin_s, auxhist7_begin_s, auxhist8_begin_s + + INTEGER :: auxhist9_begin , auxhist10_begin , auxhist11_begin , & + auxhist9_begin_y, auxhist10_begin_y, auxhist11_begin_y, & + auxhist9_begin_mo, auxhist10_begin_mo, auxhist11_begin_mo, & + auxhist9_begin_d, auxhist10_begin_d, auxhist11_begin_d, & + auxhist9_begin_h, auxhist10_begin_h, auxhist11_begin_h, & + auxhist9_begin_m, auxhist10_begin_m, auxhist11_begin_m, & + auxhist9_begin_s, auxhist10_begin_s, auxhist11_begin_s + + INTEGER :: inputout_begin , inputout_end, inputout_interval , & + inputout_begin_y, inputout_end_y, inputout_interval_y , & + inputout_begin_mo, inputout_end_mo, inputout_interval_mo , & + inputout_begin_d, inputout_end_d, inputout_interval_d , & + inputout_begin_h, inputout_end_h, inputout_interval_h , & + inputout_begin_m, inputout_end_m, inputout_interval_m , & + inputout_begin_s, inputout_end_s, inputout_interval_s + + INTEGER :: auxinput1_begin , auxinput2_begin , auxinput3_begin , & + auxinput1_begin_y, auxinput2_begin_y, auxinput3_begin_y, & + auxinput1_begin_mo, auxinput2_begin_mo, auxinput3_begin_mo, & + auxinput1_begin_d, auxinput2_begin_d, auxinput3_begin_d, & + auxinput1_begin_h, auxinput2_begin_h, auxinput3_begin_h, & + auxinput1_begin_m, auxinput2_begin_m, auxinput3_begin_m, & + auxinput1_begin_s, auxinput2_begin_s, auxinput3_begin_s + + INTEGER :: auxinput4_begin , auxinput5_begin , & + auxinput4_begin_y, auxinput5_begin_y, & + auxinput4_begin_mo, auxinput5_begin_mo, & + auxinput4_begin_d, auxinput5_begin_d, & + auxinput4_begin_h, auxinput5_begin_h, & + auxinput4_begin_m, auxinput5_begin_m, & + auxinput4_begin_s, auxinput5_begin_s + + INTEGER :: auxinput6_begin , auxinput7_begin , auxinput8_begin , & + auxinput6_begin_y, auxinput7_begin_y, auxinput8_begin_y, & + auxinput6_begin_mo, auxinput7_begin_mo, auxinput8_begin_mo, & + auxinput6_begin_d, auxinput7_begin_d, auxinput8_begin_d, & + auxinput6_begin_h, auxinput7_begin_h, auxinput8_begin_h, & + auxinput6_begin_m, auxinput7_begin_m, auxinput8_begin_m, & + auxinput6_begin_s, auxinput7_begin_s, auxinput8_begin_s + + INTEGER :: auxinput9_begin , gfdda_begin , auxinput11_begin , & + auxinput9_begin_y, gfdda_begin_y, auxinput11_begin_y, & + auxinput9_begin_mo, gfdda_begin_mo, auxinput11_begin_mo, & + auxinput9_begin_d, gfdda_begin_d, auxinput11_begin_d, & + auxinput9_begin_h, gfdda_begin_h, auxinput11_begin_h, & + auxinput9_begin_m, gfdda_begin_m, auxinput11_begin_m, & + auxinput9_begin_s, gfdda_begin_s, auxinput11_begin_s + + INTEGER :: history_end , restart_end , & + history_end_y, restart_end_y, & + history_end_mo, restart_end_mo, & + history_end_d, restart_end_d, & + history_end_h, restart_end_h, & + history_end_m, restart_end_m, & + history_end_s, restart_end_s + + INTEGER :: auxhist1_end , auxhist2_end , auxhist3_end , & + auxhist1_end_y, auxhist2_end_y, auxhist3_end_y, & + auxhist1_end_mo, auxhist2_end_mo, auxhist3_end_mo, & + auxhist1_end_d, auxhist2_end_d, auxhist3_end_d, & + auxhist1_end_h, auxhist2_end_h, auxhist3_end_h, & + auxhist1_end_m, auxhist2_end_m, auxhist3_end_m, & + auxhist1_end_s, auxhist2_end_s, auxhist3_end_s + + INTEGER :: auxhist4_end , auxhist5_end, & + auxhist4_end_y, auxhist5_end_y, & + auxhist4_end_mo, auxhist5_end_mo, & + auxhist4_end_d, auxhist5_end_d, & + auxhist4_end_h, auxhist5_end_h, & + auxhist4_end_m, auxhist5_end_m, & + auxhist4_end_s, auxhist5_end_s + + INTEGER :: auxhist6_end , auxhist7_end , auxhist8_end , & + auxhist6_end_y, auxhist7_end_y, auxhist8_end_y, & + auxhist6_end_mo, auxhist7_end_mo, auxhist8_end_mo, & + auxhist6_end_d, auxhist7_end_d, auxhist8_end_d, & + auxhist6_end_h, auxhist7_end_h, auxhist8_end_h, & + auxhist6_end_m, auxhist7_end_m, auxhist8_end_m, & + auxhist6_end_s, auxhist7_end_s, auxhist8_end_s + + INTEGER :: auxhist9_end , auxhist10_end , auxhist11_end , & + auxhist9_end_y, auxhist10_end_y, auxhist11_end_y, & + auxhist9_end_mo, auxhist10_end_mo, auxhist11_end_mo, & + auxhist9_end_d, auxhist10_end_d, auxhist11_end_d, & + auxhist9_end_h, auxhist10_end_h, auxhist11_end_h, & + auxhist9_end_m, auxhist10_end_m, auxhist11_end_m, & + auxhist9_end_s, auxhist10_end_s, auxhist11_end_s + + INTEGER :: auxinput1_end , auxinput2_end , auxinput3_end , & + auxinput1_end_y, auxinput2_end_y, auxinput3_end_y, & + auxinput1_end_mo, auxinput2_end_mo, auxinput3_end_mo, & + auxinput1_end_d, auxinput2_end_d, auxinput3_end_d, & + auxinput1_end_h, auxinput2_end_h, auxinput3_end_h, & + auxinput1_end_m, auxinput2_end_m, auxinput3_end_m, & + auxinput1_end_s, auxinput2_end_s, auxinput3_end_s + + INTEGER :: auxinput4_end , auxinput5_end , & + auxinput4_end_y, auxinput5_end_y, & + auxinput4_end_mo, auxinput5_end_mo, & + auxinput4_end_d, auxinput5_end_d, & + auxinput4_end_h, auxinput5_end_h, & + auxinput4_end_m, auxinput5_end_m, & + auxinput4_end_s, auxinput5_end_s + + INTEGER :: auxinput6_end , auxinput7_end , auxinput8_end , & + auxinput6_end_y, auxinput7_end_y, auxinput8_end_y, & + auxinput6_end_mo, auxinput7_end_mo, auxinput8_end_mo, & + auxinput6_end_d, auxinput7_end_d, auxinput8_end_d, & + auxinput6_end_h, auxinput7_end_h, auxinput8_end_h, & + auxinput6_end_m, auxinput7_end_m, auxinput8_end_m, & + auxinput6_end_s, auxinput7_end_s, auxinput8_end_s + + INTEGER :: auxinput9_end , gfdda_end , auxinput11_end , & + auxinput9_end_y, gfdda_end_y, auxinput11_end_y, & + auxinput9_end_mo, gfdda_end_mo, auxinput11_end_mo, & + auxinput9_end_d, gfdda_end_d, auxinput11_end_d, & + auxinput9_end_h, gfdda_end_h, auxinput11_end_h, & + auxinput9_end_m, gfdda_end_m, auxinput11_end_m, & + auxinput9_end_s, gfdda_end_s, auxinput11_end_s + + INTEGER :: grid_fdda + + INTEGER :: run_days, run_hours, run_minutes, run_seconds + INTEGER :: time_step, time_step_fract_num, time_step_fract_den + INTEGER :: rc + REAL :: dt + + CALL WRFU_TimeIntervalSet ( zero_time, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(zero_time) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeIntervalSet ( one_minute, M=1, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(one_minute) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeIntervalSet ( one_hour, H=1, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(one_hour) FAILED', & + __FILE__ , & + __LINE__ ) + + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(startTime) FAILED', & + __FILE__ , & + __LINE__ ) + CALL nl_get_run_days(1,run_days) + CALL nl_get_run_hours(1,run_hours) + CALL nl_get_run_minutes(1,run_minutes) + CALL nl_get_run_seconds(1,run_seconds) + + IF ( grid%id .EQ. head_grid%id .AND. & + ( run_days .gt. 0 .or. run_hours .gt. 0 .or. run_minutes .gt. 0 .or. run_seconds .gt. 0 )) THEN + CALL WRFU_TimeIntervalSet ( run_length , D=run_days, H=run_hours, M=run_minutes, S=run_seconds, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(run_length) FAILED', & + __FILE__ , & + __LINE__ ) + stopTime = startTime + run_length + ELSE + CALL nl_get_end_year(grid%id,end_year) + CALL nl_get_end_month(grid%id,end_month) + CALL nl_get_end_day(grid%id,end_day) + CALL nl_get_end_hour(grid%id,end_hour) + CALL nl_get_end_minute(grid%id,end_minute) + CALL nl_get_end_second(grid%id,end_second) + CALL WRFU_TimeSet(stopTime, YY=end_year, MM=end_month, DD=end_day, & + H=end_hour, M=end_minute, S=end_second,& + rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(stopTime) FAILED', & + __FILE__ , & + __LINE__ ) + run_length = stopTime - startTime + ENDIF + IF ( run_length .GT. zero_time ) THEN + padding_interval = one_hour + ELSE + padding_interval = zero_time - one_hour + ENDIF + + IF ( grid%id .EQ. head_grid%id ) THEN + CALL nl_get_time_step ( 1, time_step ) + CALL nl_get_time_step_fract_num( 1, time_step_fract_num ) + CALL nl_get_time_step_fract_den( 1, time_step_fract_den ) + dt = real(time_step) + real(time_step_fract_num) / real(time_step_fract_den) + CALL nl_set_dt( grid%id, dt ) + grid%dt = dt + CALL WRFU_TimeIntervalSet(stepTime, S=time_step, Sn=time_step_fract_num, Sd=time_step_fract_den, rc=rc) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(stepTime) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + stepTime = domain_get_time_step( grid%parents(1)%ptr ) / & + grid%parent_time_step_ratio + grid%dt = grid%parents(1)%ptr%dt / grid%parent_time_step_ratio + CALL nl_set_dt( grid%id, grid%dt ) + ENDIF + + ! create grid%domain_clock and associated state + CALL domain_clock_create( grid, TimeStep= stepTime, & + StartTime=startTime, & + StopTime= stopTime ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG setup_timekeeping(): clock after creation,' ) + + ! Set default value for SIMULATION_START_DATE. + ! This is overwritten later in input_wrf(), if needed. + IF ( grid%id .EQ. head_grid%id ) THEN + CALL nl_set_simulation_start_year ( 1 , start_year ) + CALL nl_set_simulation_start_month ( 1 , start_month ) + CALL nl_set_simulation_start_day ( 1 , start_day ) + CALL nl_set_simulation_start_hour ( 1 , start_hour ) + CALL nl_set_simulation_start_minute ( 1 , start_minute ) + CALL nl_set_simulation_start_second ( 1 , start_second ) + ENDIF + +! HISTORY INTERVAL +! history_interval is left there (and means minutes) for consistency, but +! history_interval_m will take precedence if specified + + CALL nl_get_history_interval( grid%id, history_interval ) ! same as minutes + CALL nl_get_history_interval_mo( grid%id, history_interval_mo ) + CALL nl_get_history_interval_d( grid%id, history_interval_d ) + CALL nl_get_history_interval_h( grid%id, history_interval_h ) + CALL nl_get_history_interval_m( grid%id, history_interval_m ) + CALL nl_get_history_interval_s( grid%id, history_interval_s ) + IF ( history_interval_m .EQ. 0 ) history_interval_m = history_interval + + IF ( MAX( history_interval_mo, history_interval_d, & + history_interval_h, history_interval_m , history_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=history_interval_mo, D=history_interval_d, & + H=history_interval_h, M=history_interval_m, S=history_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(history_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_history_begin_y( grid%id, history_begin_y ) + CALL nl_get_history_begin_mo( grid%id, history_begin_mo ) + CALL nl_get_history_begin_d( grid%id, history_begin_d ) + CALL nl_get_history_begin_h( grid%id, history_begin_h ) + CALL nl_get_history_begin_m( grid%id, history_begin_m ) + CALL nl_get_history_begin_s( grid%id, history_begin_s ) + IF ( MAX( history_begin_y, history_begin_mo, history_begin_d, & + history_begin_h, history_begin_m , history_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=history_begin_mo, D=history_begin_d, & + H=history_begin_h, M=history_begin_m, S=history_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(history_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_history_end_y( grid%id, history_end_y ) + CALL nl_get_history_end_mo( grid%id, history_end_mo ) + CALL nl_get_history_end_d( grid%id, history_end_d ) + CALL nl_get_history_end_h( grid%id, history_end_h ) + CALL nl_get_history_end_m( grid%id, history_end_m ) + CALL nl_get_history_end_s( grid%id, history_end_s ) + IF ( MAX( history_end_y, history_end_mo, history_end_d, & + history_end_h, history_end_m , history_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=history_end_mo, D=history_end_d, & + H=history_end_h, M=history_end_m, S=history_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(history_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, HISTORY_ALARM, interval, begin_time, end_time ) + + IF ( begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( HISTORY_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(HISTORY_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + + +! RESTART INTERVAL +! restart_interval is left there (and means minutes) for consistency, but +! restart_interval_m will take precedence if specified + CALL nl_get_restart_interval( 1, restart_interval ) ! same as minutes + CALL nl_get_restart_interval_mo( 1, restart_interval_mo ) + CALL nl_get_restart_interval_d( 1, restart_interval_d ) + CALL nl_get_restart_interval_h( 1, restart_interval_h ) + CALL nl_get_restart_interval_m( 1, restart_interval_m ) + CALL nl_get_restart_interval_s( 1, restart_interval_s ) + IF ( restart_interval_m .EQ. 0 ) restart_interval_m = restart_interval + IF ( MAX( restart_interval_mo, restart_interval_d, & + restart_interval_h, restart_interval_m , restart_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=restart_interval_mo, D=restart_interval_d, & + H=restart_interval_h, M=restart_interval_m, S=restart_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(restart_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + CALL domain_alarm_create( grid, RESTART_ALARM, interval ) + +! INPUTOUT INTERVAL + CALL nl_get_inputout_interval( grid%id, inputout_interval ) ! same as minutes + CALL nl_get_inputout_interval_mo( grid%id, inputout_interval_mo ) + CALL nl_get_inputout_interval_d( grid%id, inputout_interval_d ) + CALL nl_get_inputout_interval_h( grid%id, inputout_interval_h ) + CALL nl_get_inputout_interval_m( grid%id, inputout_interval_m ) + CALL nl_get_inputout_interval_s( grid%id, inputout_interval_s ) + IF ( inputout_interval_m .EQ. 0 ) inputout_interval_m = inputout_interval + + IF ( MAX( inputout_interval_mo, inputout_interval_d, & + inputout_interval_h, inputout_interval_m , inputout_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=inputout_interval_mo, D=inputout_interval_d, & + H=inputout_interval_h, M=inputout_interval_m, S=inputout_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_inputout_begin_y( grid%id, inputout_begin_y ) + CALL nl_get_inputout_begin_mo( grid%id, inputout_begin_mo ) + CALL nl_get_inputout_begin_d( grid%id, inputout_begin_d ) + CALL nl_get_inputout_begin_h( grid%id, inputout_begin_h ) + CALL nl_get_inputout_begin_m( grid%id, inputout_begin_m ) + CALL nl_get_inputout_begin_s( grid%id, inputout_begin_s ) + IF ( MAX( inputout_begin_y, inputout_begin_mo, inputout_begin_d, & + inputout_begin_h, inputout_begin_m , inputout_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=inputout_begin_mo, D=inputout_begin_d, & + H=inputout_begin_h, M=inputout_begin_m, S=inputout_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_inputout_end_y( grid%id, inputout_end_y ) + CALL nl_get_inputout_end_mo( grid%id, inputout_end_mo ) + CALL nl_get_inputout_end_d( grid%id, inputout_end_d ) + CALL nl_get_inputout_end_h( grid%id, inputout_end_h ) + CALL nl_get_inputout_end_m( grid%id, inputout_end_m ) + CALL nl_get_inputout_end_s( grid%id, inputout_end_s ) + IF ( MAX( inputout_end_y, inputout_end_mo, inputout_end_d, & + inputout_end_h, inputout_end_m , inputout_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=inputout_end_mo, D=inputout_end_d, & + H=inputout_end_h, M=inputout_end_m, S=inputout_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, INPUTOUT_ALARM, interval, begin_time, end_time ) + +! AUXHIST1 INTERVAL +! auxhist1_interval is left there (and means minutes) for consistency, but +! auxhist1_interval_m will take precedence if specified + CALL nl_get_auxhist1_interval( grid%id, auxhist1_interval ) ! same as minutes + CALL nl_get_auxhist1_interval_mo( grid%id, auxhist1_interval_mo ) + CALL nl_get_auxhist1_interval_d( grid%id, auxhist1_interval_d ) + CALL nl_get_auxhist1_interval_h( grid%id, auxhist1_interval_h ) + CALL nl_get_auxhist1_interval_m( grid%id, auxhist1_interval_m ) + CALL nl_get_auxhist1_interval_s( grid%id, auxhist1_interval_s ) + IF ( auxhist1_interval_m .EQ. 0 ) auxhist1_interval_m = auxhist1_interval + + IF ( MAX( auxhist1_interval_mo, auxhist1_interval_d, & + auxhist1_interval_h, auxhist1_interval_m , auxhist1_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist1_interval_mo, D=auxhist1_interval_d, & + H=auxhist1_interval_h, M=auxhist1_interval_m, S=auxhist1_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist1_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist1_begin_y( grid%id, auxhist1_begin_y ) + CALL nl_get_auxhist1_begin_mo( grid%id, auxhist1_begin_mo ) + CALL nl_get_auxhist1_begin_d( grid%id, auxhist1_begin_d ) + CALL nl_get_auxhist1_begin_h( grid%id, auxhist1_begin_h ) + CALL nl_get_auxhist1_begin_m( grid%id, auxhist1_begin_m ) + CALL nl_get_auxhist1_begin_s( grid%id, auxhist1_begin_s ) + IF ( MAX( auxhist1_begin_y, auxhist1_begin_mo, auxhist1_begin_d, & + auxhist1_begin_h, auxhist1_begin_m , auxhist1_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist1_begin_mo, D=auxhist1_begin_d, & + H=auxhist1_begin_h, M=auxhist1_begin_m, S=auxhist1_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist1_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist1_end_y( grid%id, auxhist1_end_y ) + CALL nl_get_auxhist1_end_mo( grid%id, auxhist1_end_mo ) + CALL nl_get_auxhist1_end_d( grid%id, auxhist1_end_d ) + CALL nl_get_auxhist1_end_h( grid%id, auxhist1_end_h ) + CALL nl_get_auxhist1_end_m( grid%id, auxhist1_end_m ) + CALL nl_get_auxhist1_end_s( grid%id, auxhist1_end_s ) + IF ( MAX( auxhist1_end_y, auxhist1_end_mo, auxhist1_end_d, & + auxhist1_end_h, auxhist1_end_m , auxhist1_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist1_end_mo, D=auxhist1_end_d, & + H=auxhist1_end_h, M=auxhist1_end_m, S=auxhist1_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist1_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST1_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST1_ALARM ), rc=rc ) + ENDIF + + +! AUXHIST2_ INTERVAL +! auxhist2_interval is left there (and means minutes) for consistency, but +! auxhist2_interval_m will take precedence if specified + CALL nl_get_auxhist2_interval( grid%id, auxhist2_interval ) ! same as minutes + CALL nl_get_auxhist2_interval_mo( grid%id, auxhist2_interval_mo ) + CALL nl_get_auxhist2_interval_d( grid%id, auxhist2_interval_d ) + CALL nl_get_auxhist2_interval_h( grid%id, auxhist2_interval_h ) + CALL nl_get_auxhist2_interval_m( grid%id, auxhist2_interval_m ) + CALL nl_get_auxhist2_interval_s( grid%id, auxhist2_interval_s ) + IF ( auxhist2_interval_m .EQ. 0) auxhist2_interval_m = auxhist2_interval + + IF ( MAX( auxhist2_interval_mo, auxhist2_interval_d, & + auxhist2_interval_h, auxhist2_interval_m , auxhist2_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist2_interval_mo, D=auxhist2_interval_d, & + H=auxhist2_interval_h, M=auxhist2_interval_m, S=auxhist2_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist2_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist2_begin_y( grid%id, auxhist2_begin_y ) + CALL nl_get_auxhist2_begin_mo( grid%id, auxhist2_begin_mo ) + CALL nl_get_auxhist2_begin_d( grid%id, auxhist2_begin_d ) + CALL nl_get_auxhist2_begin_h( grid%id, auxhist2_begin_h ) + CALL nl_get_auxhist2_begin_m( grid%id, auxhist2_begin_m ) + CALL nl_get_auxhist2_begin_s( grid%id, auxhist2_begin_s ) + IF ( MAX( auxhist2_begin_y, auxhist2_begin_mo, auxhist2_begin_d, & + auxhist2_begin_h, auxhist2_begin_m , auxhist2_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist2_begin_mo, D=auxhist2_begin_d, & + H=auxhist2_begin_h, M=auxhist2_begin_m, S=auxhist2_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist2_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist2_end_y( grid%id, auxhist2_end_y ) + CALL nl_get_auxhist2_end_mo( grid%id, auxhist2_end_mo ) + CALL nl_get_auxhist2_end_d( grid%id, auxhist2_end_d ) + CALL nl_get_auxhist2_end_h( grid%id, auxhist2_end_h ) + CALL nl_get_auxhist2_end_m( grid%id, auxhist2_end_m ) + CALL nl_get_auxhist2_end_s( grid%id, auxhist2_end_s ) + IF ( MAX( auxhist2_end_y, auxhist2_end_mo, auxhist2_end_d, & + auxhist2_end_h, auxhist2_end_m , auxhist2_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist2_end_mo, D=auxhist2_end_d, & + H=auxhist2_end_h, M=auxhist2_end_m, S=auxhist2_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist2_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST2_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST2_ALARM ), rc=rc ) + ENDIF + +! AUXHIST3_ INTERVAL +! auxhist3_interval is left there (and means minutes) for consistency, but +! auxhist3_interval_m will take precedence if specified + CALL nl_get_auxhist3_interval( grid%id, auxhist3_interval ) ! same as minutes + CALL nl_get_auxhist3_interval_mo( grid%id, auxhist3_interval_mo ) + CALL nl_get_auxhist3_interval_d( grid%id, auxhist3_interval_d ) + CALL nl_get_auxhist3_interval_h( grid%id, auxhist3_interval_h ) + CALL nl_get_auxhist3_interval_m( grid%id, auxhist3_interval_m ) + CALL nl_get_auxhist3_interval_s( grid%id, auxhist3_interval_s ) + IF ( auxhist3_interval_m .EQ. 0 ) auxhist3_interval_m = auxhist3_interval + + IF ( MAX( auxhist3_interval_mo, auxhist3_interval_d, & + auxhist3_interval_h, auxhist3_interval_m , auxhist3_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist3_interval_mo, D=auxhist3_interval_d, & + H=auxhist3_interval_h, M=auxhist3_interval_m, S=auxhist3_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist3_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist3_begin_y( grid%id, auxhist3_begin_y ) + CALL nl_get_auxhist3_begin_mo( grid%id, auxhist3_begin_mo ) + CALL nl_get_auxhist3_begin_d( grid%id, auxhist3_begin_d ) + CALL nl_get_auxhist3_begin_h( grid%id, auxhist3_begin_h ) + CALL nl_get_auxhist3_begin_m( grid%id, auxhist3_begin_m ) + CALL nl_get_auxhist3_begin_s( grid%id, auxhist3_begin_s ) + IF ( MAX( auxhist3_begin_y, auxhist3_begin_mo, auxhist3_begin_d, & + auxhist3_begin_h, auxhist3_begin_m , auxhist3_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist3_begin_mo, D=auxhist3_begin_d, & + H=auxhist3_begin_h, M=auxhist3_begin_m, S=auxhist3_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist3_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist3_end_y( grid%id, auxhist3_end_y ) + CALL nl_get_auxhist3_end_mo( grid%id, auxhist3_end_mo ) + CALL nl_get_auxhist3_end_d( grid%id, auxhist3_end_d ) + CALL nl_get_auxhist3_end_h( grid%id, auxhist3_end_h ) + CALL nl_get_auxhist3_end_m( grid%id, auxhist3_end_m ) + CALL nl_get_auxhist3_end_s( grid%id, auxhist3_end_s ) + IF ( MAX( auxhist3_end_y, auxhist3_end_mo, auxhist3_end_d, & + auxhist3_end_h, auxhist3_end_m , auxhist3_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist3_end_mo, D=auxhist3_end_d, & + H=auxhist3_end_h, M=auxhist3_end_m, S=auxhist3_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist3_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST3_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST3_ALARM ), rc=rc ) + ENDIF + +! AUXHIST4_ INTERVAL +! auxhist4_interval is left there (and means minutes) for consistency, but +! auxhist4_interval_m will take precedence if specified + CALL nl_get_auxhist4_interval( grid%id, auxhist4_interval ) ! same as minutes + CALL nl_get_auxhist4_interval_mo( grid%id, auxhist4_interval_mo ) + CALL nl_get_auxhist4_interval_d( grid%id, auxhist4_interval_d ) + CALL nl_get_auxhist4_interval_h( grid%id, auxhist4_interval_h ) + CALL nl_get_auxhist4_interval_m( grid%id, auxhist4_interval_m ) + CALL nl_get_auxhist4_interval_s( grid%id, auxhist4_interval_s ) + IF ( auxhist4_interval_m .EQ. 0 ) auxhist4_interval_m = auxhist4_interval + + IF ( MAX( auxhist4_interval_mo, auxhist4_interval_d, & + auxhist4_interval_h, auxhist4_interval_m , auxhist4_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist4_interval_mo, D=auxhist4_interval_d, & + H=auxhist4_interval_h, M=auxhist4_interval_m, S=auxhist4_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist4_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist4_begin_y( grid%id, auxhist4_begin_y ) + CALL nl_get_auxhist4_begin_mo( grid%id, auxhist4_begin_mo ) + CALL nl_get_auxhist4_begin_d( grid%id, auxhist4_begin_d ) + CALL nl_get_auxhist4_begin_h( grid%id, auxhist4_begin_h ) + CALL nl_get_auxhist4_begin_m( grid%id, auxhist4_begin_m ) + CALL nl_get_auxhist4_begin_s( grid%id, auxhist4_begin_s ) + IF ( MAX( auxhist4_begin_y, auxhist4_begin_mo, auxhist4_begin_d, & + auxhist4_begin_h, auxhist4_begin_m , auxhist4_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist4_begin_mo, D=auxhist4_begin_d, & + H=auxhist4_begin_h, M=auxhist4_begin_m, S=auxhist4_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist4_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist4_end_y( grid%id, auxhist4_end_y ) + CALL nl_get_auxhist4_end_mo( grid%id, auxhist4_end_mo ) + CALL nl_get_auxhist4_end_d( grid%id, auxhist4_end_d ) + CALL nl_get_auxhist4_end_h( grid%id, auxhist4_end_h ) + CALL nl_get_auxhist4_end_m( grid%id, auxhist4_end_m ) + CALL nl_get_auxhist4_end_s( grid%id, auxhist4_end_s ) + IF ( MAX( auxhist4_end_y, auxhist4_end_mo, auxhist4_end_d, & + auxhist4_end_h, auxhist4_end_m , auxhist4_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist4_end_mo, D=auxhist4_end_d, & + H=auxhist4_end_h, M=auxhist4_end_m, S=auxhist4_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist4_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST4_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST4_ALARM ), rc=rc ) + ENDIF + +! AUXHIST5_ INTERVAL +! auxhist5_interval is left there (and means minutes) for consistency, but +! auxhist5_interval_m will take precedence if specified + CALL nl_get_auxhist5_interval( grid%id, auxhist5_interval ) ! same as minutes + CALL nl_get_auxhist5_interval_mo( grid%id, auxhist5_interval_mo ) + CALL nl_get_auxhist5_interval_d( grid%id, auxhist5_interval_d ) + CALL nl_get_auxhist5_interval_h( grid%id, auxhist5_interval_h ) + CALL nl_get_auxhist5_interval_m( grid%id, auxhist5_interval_m ) + CALL nl_get_auxhist5_interval_s( grid%id, auxhist5_interval_s ) + IF ( auxhist5_interval_m .EQ. 0 ) auxhist5_interval_m = auxhist5_interval + + IF ( MAX( auxhist5_interval_mo, auxhist5_interval_d, & + auxhist5_interval_h, auxhist5_interval_m , auxhist5_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist5_interval_mo, D=auxhist5_interval_d, & + H=auxhist5_interval_h, M=auxhist5_interval_m, S=auxhist5_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist5_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist5_begin_y( grid%id, auxhist5_begin_y ) + CALL nl_get_auxhist5_begin_mo( grid%id, auxhist5_begin_mo ) + CALL nl_get_auxhist5_begin_d( grid%id, auxhist5_begin_d ) + CALL nl_get_auxhist5_begin_h( grid%id, auxhist5_begin_h ) + CALL nl_get_auxhist5_begin_m( grid%id, auxhist5_begin_m ) + CALL nl_get_auxhist5_begin_s( grid%id, auxhist5_begin_s ) + IF ( MAX( auxhist5_begin_y, auxhist5_begin_mo, auxhist5_begin_d, & + auxhist5_begin_h, auxhist5_begin_m , auxhist5_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist5_begin_mo, D=auxhist5_begin_d, & + H=auxhist5_begin_h, M=auxhist5_begin_m, S=auxhist5_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist5_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist5_end_y( grid%id, auxhist5_end_y ) + CALL nl_get_auxhist5_end_mo( grid%id, auxhist5_end_mo ) + CALL nl_get_auxhist5_end_d( grid%id, auxhist5_end_d ) + CALL nl_get_auxhist5_end_h( grid%id, auxhist5_end_h ) + CALL nl_get_auxhist5_end_m( grid%id, auxhist5_end_m ) + CALL nl_get_auxhist5_end_s( grid%id, auxhist5_end_s ) + IF ( MAX( auxhist5_end_y, auxhist5_end_mo, auxhist5_end_d, & + auxhist5_end_h, auxhist5_end_m , auxhist5_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist5_end_mo, D=auxhist5_end_d, & + H=auxhist5_end_h, M=auxhist5_end_m, S=auxhist5_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist5_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST5_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST5_ALARM ), rc=rc ) + ENDIF + +! AUXHIST6_ INTERVAL +! auxhist6_interval is left there (and means minutes) for consistency, but +! auxhist6_interval_m will take precedence if specified + CALL nl_get_auxhist6_interval( grid%id, auxhist6_interval ) ! same as minutes + CALL nl_get_auxhist6_interval_mo( grid%id, auxhist6_interval_mo ) + CALL nl_get_auxhist6_interval_d( grid%id, auxhist6_interval_d ) + CALL nl_get_auxhist6_interval_h( grid%id, auxhist6_interval_h ) + CALL nl_get_auxhist6_interval_m( grid%id, auxhist6_interval_m ) + CALL nl_get_auxhist6_interval_s( grid%id, auxhist6_interval_s ) + IF ( auxhist6_interval_m .EQ. 0 ) auxhist6_interval_m = auxhist6_interval + + IF ( MAX( auxhist6_interval_mo, auxhist6_interval_d, & + auxhist6_interval_h, auxhist6_interval_m , auxhist6_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist6_interval_mo, D=auxhist6_interval_d, & + H=auxhist6_interval_h, M=auxhist6_interval_m, S=auxhist6_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist6_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist6_begin_y( grid%id, auxhist6_begin_y ) + CALL nl_get_auxhist6_begin_mo( grid%id, auxhist6_begin_mo ) + CALL nl_get_auxhist6_begin_d( grid%id, auxhist6_begin_d ) + CALL nl_get_auxhist6_begin_h( grid%id, auxhist6_begin_h ) + CALL nl_get_auxhist6_begin_m( grid%id, auxhist6_begin_m ) + CALL nl_get_auxhist6_begin_s( grid%id, auxhist6_begin_s ) + IF ( MAX( auxhist6_begin_y, auxhist6_begin_mo, auxhist6_begin_d, & + auxhist6_begin_h, auxhist6_begin_m , auxhist6_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist6_begin_mo, D=auxhist6_begin_d, & + H=auxhist6_begin_h, M=auxhist6_begin_m, S=auxhist6_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist6_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist6_end_y( grid%id, auxhist6_end_y ) + CALL nl_get_auxhist6_end_mo( grid%id, auxhist6_end_mo ) + CALL nl_get_auxhist6_end_d( grid%id, auxhist6_end_d ) + CALL nl_get_auxhist6_end_h( grid%id, auxhist6_end_h ) + CALL nl_get_auxhist6_end_m( grid%id, auxhist6_end_m ) + CALL nl_get_auxhist6_end_s( grid%id, auxhist6_end_s ) + IF ( MAX( auxhist6_end_y, auxhist6_end_mo, auxhist6_end_d, & + auxhist6_end_h, auxhist6_end_m , auxhist6_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist6_end_mo, D=auxhist6_end_d, & + H=auxhist6_end_h, M=auxhist6_end_m, S=auxhist6_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist6_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST6_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST6_ALARM ), rc=rc ) + ENDIF + + +! AUXHIST7_ INTERVAL +! auxhist7_interval is left there (and means minutes) for consistency, but +! auxhist7_interval_m will take precedence if specified + CALL nl_get_auxhist7_interval( grid%id, auxhist7_interval ) ! same as minutes + CALL nl_get_auxhist7_interval_mo( grid%id, auxhist7_interval_mo ) + CALL nl_get_auxhist7_interval_d( grid%id, auxhist7_interval_d ) + CALL nl_get_auxhist7_interval_h( grid%id, auxhist7_interval_h ) + CALL nl_get_auxhist7_interval_m( grid%id, auxhist7_interval_m ) + CALL nl_get_auxhist7_interval_s( grid%id, auxhist7_interval_s ) + IF ( auxhist7_interval_m .EQ. 0 ) auxhist7_interval_m = auxhist7_interval + + IF ( MAX( auxhist7_interval_mo, auxhist7_interval_d, & + auxhist7_interval_h, auxhist7_interval_m , auxhist7_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist7_interval_mo, D=auxhist7_interval_d, & + H=auxhist7_interval_h, M=auxhist7_interval_m, S=auxhist7_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist7_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist7_begin_y( grid%id, auxhist7_begin_y ) + CALL nl_get_auxhist7_begin_mo( grid%id, auxhist7_begin_mo ) + CALL nl_get_auxhist7_begin_d( grid%id, auxhist7_begin_d ) + CALL nl_get_auxhist7_begin_h( grid%id, auxhist7_begin_h ) + CALL nl_get_auxhist7_begin_m( grid%id, auxhist7_begin_m ) + CALL nl_get_auxhist7_begin_s( grid%id, auxhist7_begin_s ) + IF ( MAX( auxhist7_begin_y, auxhist7_begin_mo, auxhist7_begin_d, & + auxhist7_begin_h, auxhist7_begin_m , auxhist7_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist7_begin_mo, D=auxhist7_begin_d, & + H=auxhist7_begin_h, M=auxhist7_begin_m, S=auxhist7_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist7_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist7_end_y( grid%id, auxhist7_end_y ) + CALL nl_get_auxhist7_end_mo( grid%id, auxhist7_end_mo ) + CALL nl_get_auxhist7_end_d( grid%id, auxhist7_end_d ) + CALL nl_get_auxhist7_end_h( grid%id, auxhist7_end_h ) + CALL nl_get_auxhist7_end_m( grid%id, auxhist7_end_m ) + CALL nl_get_auxhist7_end_s( grid%id, auxhist7_end_s ) + IF ( MAX( auxhist7_end_y, auxhist7_end_mo, auxhist7_end_d, & + auxhist7_end_h, auxhist7_end_m , auxhist7_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist7_end_mo, D=auxhist7_end_d, & + H=auxhist7_end_h, M=auxhist7_end_m, S=auxhist7_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist7_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST7_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST7_ALARM ), rc=rc ) + ENDIF + +! AUXHIST8_ INTERVAL +! auxhist8_interval is left there (and means minutes) for consistency, but +! auxhist8_interval_m will take precedence if specified + CALL nl_get_auxhist8_interval( grid%id, auxhist8_interval ) ! same as minutes + CALL nl_get_auxhist8_interval_mo( grid%id, auxhist8_interval_mo ) + CALL nl_get_auxhist8_interval_d( grid%id, auxhist8_interval_d ) + CALL nl_get_auxhist8_interval_h( grid%id, auxhist8_interval_h ) + CALL nl_get_auxhist8_interval_m( grid%id, auxhist8_interval_m ) + CALL nl_get_auxhist8_interval_s( grid%id, auxhist8_interval_s ) + IF ( auxhist8_interval_m .EQ. 0 ) auxhist8_interval_m = auxhist8_interval + + IF ( MAX( auxhist8_interval_mo, auxhist8_interval_d, & + auxhist8_interval_h, auxhist8_interval_m , auxhist8_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist8_interval_mo, D=auxhist8_interval_d, & + H=auxhist8_interval_h, M=auxhist8_interval_m, S=auxhist8_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist8_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist8_begin_y( grid%id, auxhist8_begin_y ) + CALL nl_get_auxhist8_begin_mo( grid%id, auxhist8_begin_mo ) + CALL nl_get_auxhist8_begin_d( grid%id, auxhist8_begin_d ) + CALL nl_get_auxhist8_begin_h( grid%id, auxhist8_begin_h ) + CALL nl_get_auxhist8_begin_m( grid%id, auxhist8_begin_m ) + CALL nl_get_auxhist8_begin_s( grid%id, auxhist8_begin_s ) + IF ( MAX( auxhist8_begin_y, auxhist8_begin_mo, auxhist8_begin_d, & + auxhist8_begin_h, auxhist8_begin_m , auxhist8_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist8_begin_mo, D=auxhist8_begin_d, & + H=auxhist8_begin_h, M=auxhist8_begin_m, S=auxhist8_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist8_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist8_end_y( grid%id, auxhist8_end_y ) + CALL nl_get_auxhist8_end_mo( grid%id, auxhist8_end_mo ) + CALL nl_get_auxhist8_end_d( grid%id, auxhist8_end_d ) + CALL nl_get_auxhist8_end_h( grid%id, auxhist8_end_h ) + CALL nl_get_auxhist8_end_m( grid%id, auxhist8_end_m ) + CALL nl_get_auxhist8_end_s( grid%id, auxhist8_end_s ) + IF ( MAX( auxhist8_end_y, auxhist8_end_mo, auxhist8_end_d, & + auxhist8_end_h, auxhist8_end_m , auxhist8_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist8_end_mo, D=auxhist8_end_d, & + H=auxhist8_end_h, M=auxhist8_end_m, S=auxhist8_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist8_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST8_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST8_ALARM ), rc=rc ) + ENDIF + +! AUXHIST9_ INTERVAL +! auxhist9_interval is left there (and means minutes) for consistency, but +! auxhist9_interval_m will take precedence if specified + CALL nl_get_auxhist9_interval( grid%id, auxhist9_interval ) ! same as minutes + CALL nl_get_auxhist9_interval_mo( grid%id, auxhist9_interval_mo ) + CALL nl_get_auxhist9_interval_d( grid%id, auxhist9_interval_d ) + CALL nl_get_auxhist9_interval_h( grid%id, auxhist9_interval_h ) + CALL nl_get_auxhist9_interval_m( grid%id, auxhist9_interval_m ) + CALL nl_get_auxhist9_interval_s( grid%id, auxhist9_interval_s ) + IF ( auxhist9_interval_m .EQ. 0 ) auxhist9_interval_m = auxhist9_interval + + IF ( MAX( auxhist9_interval_mo, auxhist9_interval_d, & + auxhist9_interval_h, auxhist9_interval_m , auxhist9_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist9_interval_mo, D=auxhist9_interval_d, & + H=auxhist9_interval_h, M=auxhist9_interval_m, S=auxhist9_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist9_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist9_begin_y( grid%id, auxhist9_begin_y ) + CALL nl_get_auxhist9_begin_mo( grid%id, auxhist9_begin_mo ) + CALL nl_get_auxhist9_begin_d( grid%id, auxhist9_begin_d ) + CALL nl_get_auxhist9_begin_h( grid%id, auxhist9_begin_h ) + CALL nl_get_auxhist9_begin_m( grid%id, auxhist9_begin_m ) + CALL nl_get_auxhist9_begin_s( grid%id, auxhist9_begin_s ) + IF ( MAX( auxhist9_begin_y, auxhist9_begin_mo, auxhist9_begin_d, & + auxhist9_begin_h, auxhist9_begin_m , auxhist9_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist9_begin_mo, D=auxhist9_begin_d, & + H=auxhist9_begin_h, M=auxhist9_begin_m, S=auxhist9_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist9_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist9_end_y( grid%id, auxhist9_end_y ) + CALL nl_get_auxhist9_end_mo( grid%id, auxhist9_end_mo ) + CALL nl_get_auxhist9_end_d( grid%id, auxhist9_end_d ) + CALL nl_get_auxhist9_end_h( grid%id, auxhist9_end_h ) + CALL nl_get_auxhist9_end_m( grid%id, auxhist9_end_m ) + CALL nl_get_auxhist9_end_s( grid%id, auxhist9_end_s ) + IF ( MAX( auxhist9_end_y, auxhist9_end_mo, auxhist9_end_d, & + auxhist9_end_h, auxhist9_end_m , auxhist9_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist9_end_mo, D=auxhist9_end_d, & + H=auxhist9_end_h, M=auxhist9_end_m, S=auxhist9_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist9_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST9_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST9_ALARM ), rc=rc ) + ENDIF + +! AUXHIST10_ INTERVAL +! auxhist10_interval is left there (and means minutes) for consistency, but +! auxhist10_interval_m will take precedence if specified + CALL nl_get_auxhist10_interval( grid%id, auxhist10_interval ) ! same as minutes + CALL nl_get_auxhist10_interval_mo( grid%id, auxhist10_interval_mo ) + CALL nl_get_auxhist10_interval_d( grid%id, auxhist10_interval_d ) + CALL nl_get_auxhist10_interval_h( grid%id, auxhist10_interval_h ) + CALL nl_get_auxhist10_interval_m( grid%id, auxhist10_interval_m ) + CALL nl_get_auxhist10_interval_s( grid%id, auxhist10_interval_s ) + IF ( auxhist10_interval_m .EQ. 0 ) auxhist10_interval_m = auxhist10_interval + + IF ( MAX( auxhist10_interval_mo, auxhist10_interval_d, & + auxhist10_interval_h, auxhist10_interval_m , auxhist10_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist10_interval_mo, D=auxhist10_interval_d, & + H=auxhist10_interval_h, M=auxhist10_interval_m, S=auxhist10_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist10_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist10_begin_y( grid%id, auxhist10_begin_y ) + CALL nl_get_auxhist10_begin_mo( grid%id, auxhist10_begin_mo ) + CALL nl_get_auxhist10_begin_d( grid%id, auxhist10_begin_d ) + CALL nl_get_auxhist10_begin_h( grid%id, auxhist10_begin_h ) + CALL nl_get_auxhist10_begin_m( grid%id, auxhist10_begin_m ) + CALL nl_get_auxhist10_begin_s( grid%id, auxhist10_begin_s ) + IF ( MAX( auxhist10_begin_y, auxhist10_begin_mo, auxhist10_begin_d, & + auxhist10_begin_h, auxhist10_begin_m , auxhist10_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist10_begin_mo, D=auxhist10_begin_d, & + H=auxhist10_begin_h, M=auxhist10_begin_m, S=auxhist10_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist10_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist10_end_y( grid%id, auxhist10_end_y ) + CALL nl_get_auxhist10_end_mo( grid%id, auxhist10_end_mo ) + CALL nl_get_auxhist10_end_d( grid%id, auxhist10_end_d ) + CALL nl_get_auxhist10_end_h( grid%id, auxhist10_end_h ) + CALL nl_get_auxhist10_end_m( grid%id, auxhist10_end_m ) + CALL nl_get_auxhist10_end_s( grid%id, auxhist10_end_s ) + IF ( MAX( auxhist10_end_y, auxhist10_end_mo, auxhist10_end_d, & + auxhist10_end_h, auxhist10_end_m , auxhist10_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist10_end_mo, D=auxhist10_end_d, & + H=auxhist10_end_h, M=auxhist10_end_m, S=auxhist10_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist10_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST10_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST10_ALARM ), rc=rc ) + ENDIF + +! AUXHIST11_ INTERVAL +! auxhist11_interval is left there (and means minutes) for consistency, but +! auxhist11_interval_m will take precedence if specified + CALL nl_get_auxhist11_interval( grid%id, auxhist11_interval ) ! same as minutes + CALL nl_get_auxhist11_interval_mo( grid%id, auxhist11_interval_mo ) + CALL nl_get_auxhist11_interval_d( grid%id, auxhist11_interval_d ) + CALL nl_get_auxhist11_interval_h( grid%id, auxhist11_interval_h ) + CALL nl_get_auxhist11_interval_m( grid%id, auxhist11_interval_m ) + CALL nl_get_auxhist11_interval_s( grid%id, auxhist11_interval_s ) + IF ( auxhist11_interval_m .EQ. 0 ) auxhist11_interval_m = auxhist11_interval + + IF ( MAX( auxhist11_interval_mo, auxhist11_interval_d, & + auxhist11_interval_h, auxhist11_interval_m , auxhist11_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxhist11_interval_mo, D=auxhist11_interval_d, & + H=auxhist11_interval_h, M=auxhist11_interval_m, S=auxhist11_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist11_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxhist11_begin_y( grid%id, auxhist11_begin_y ) + CALL nl_get_auxhist11_begin_mo( grid%id, auxhist11_begin_mo ) + CALL nl_get_auxhist11_begin_d( grid%id, auxhist11_begin_d ) + CALL nl_get_auxhist11_begin_h( grid%id, auxhist11_begin_h ) + CALL nl_get_auxhist11_begin_m( grid%id, auxhist11_begin_m ) + CALL nl_get_auxhist11_begin_s( grid%id, auxhist11_begin_s ) + IF ( MAX( auxhist11_begin_y, auxhist11_begin_mo, auxhist11_begin_d, & + auxhist11_begin_h, auxhist11_begin_m , auxhist11_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxhist11_begin_mo, D=auxhist11_begin_d, & + H=auxhist11_begin_h, M=auxhist11_begin_m, S=auxhist11_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist11_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxhist11_end_y( grid%id, auxhist11_end_y ) + CALL nl_get_auxhist11_end_mo( grid%id, auxhist11_end_mo ) + CALL nl_get_auxhist11_end_d( grid%id, auxhist11_end_d ) + CALL nl_get_auxhist11_end_h( grid%id, auxhist11_end_h ) + CALL nl_get_auxhist11_end_m( grid%id, auxhist11_end_m ) + CALL nl_get_auxhist11_end_s( grid%id, auxhist11_end_s ) + IF ( MAX( auxhist11_end_y, auxhist11_end_mo, auxhist11_end_d, & + auxhist11_end_h, auxhist11_end_m , auxhist11_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxhist11_end_mo, D=auxhist11_end_d, & + H=auxhist11_end_h, M=auxhist11_end_m, S=auxhist11_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxhist11_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXHIST11_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST11_ALARM ), rc=rc ) + ENDIF + +! AUXINPUT1_ INTERVAL +! auxinput1_interval is left there (and means minutes) for consistency, but +! auxinput1_interval_m will take precedence if specified + CALL nl_get_auxinput1_interval( grid%id, auxinput1_interval ) ! same as minutes + CALL nl_get_auxinput1_interval_mo( grid%id, auxinput1_interval_mo ) + CALL nl_get_auxinput1_interval_d( grid%id, auxinput1_interval_d ) + CALL nl_get_auxinput1_interval_h( grid%id, auxinput1_interval_h ) + CALL nl_get_auxinput1_interval_m( grid%id, auxinput1_interval_m ) + CALL nl_get_auxinput1_interval_s( grid%id, auxinput1_interval_s ) + IF ( auxinput1_interval_m .EQ. 0 ) auxinput1_interval_m = auxinput1_interval + + IF ( MAX( auxinput1_interval_mo, auxinput1_interval_d, & + auxinput1_interval_h, auxinput1_interval_m , auxinput1_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput1_interval_mo, D=auxinput1_interval_d, & + H=auxinput1_interval_h, M=auxinput1_interval_m, S=auxinput1_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput1_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput1_begin_y( grid%id, auxinput1_begin_y ) + CALL nl_get_auxinput1_begin_mo( grid%id, auxinput1_begin_mo ) + CALL nl_get_auxinput1_begin_d( grid%id, auxinput1_begin_d ) + CALL nl_get_auxinput1_begin_h( grid%id, auxinput1_begin_h ) + CALL nl_get_auxinput1_begin_m( grid%id, auxinput1_begin_m ) + CALL nl_get_auxinput1_begin_s( grid%id, auxinput1_begin_s ) + IF ( MAX( auxinput1_begin_y, auxinput1_begin_mo, auxinput1_begin_d, & + auxinput1_begin_h, auxinput1_begin_m , auxinput1_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput1_begin_mo, D=auxinput1_begin_d, & + H=auxinput1_begin_h, M=auxinput1_begin_m, S=auxinput1_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput1_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput1_end_y( grid%id, auxinput1_end_y ) + CALL nl_get_auxinput1_end_mo( grid%id, auxinput1_end_mo ) + CALL nl_get_auxinput1_end_d( grid%id, auxinput1_end_d ) + CALL nl_get_auxinput1_end_h( grid%id, auxinput1_end_h ) + CALL nl_get_auxinput1_end_m( grid%id, auxinput1_end_m ) + CALL nl_get_auxinput1_end_s( grid%id, auxinput1_end_s ) + IF ( MAX( auxinput1_end_y, auxinput1_end_mo, auxinput1_end_d, & + auxinput1_end_h, auxinput1_end_m , auxinput1_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput1_end_mo, D=auxinput1_end_d, & + H=auxinput1_end_h, M=auxinput1_end_m, S=auxinput1_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput1_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT1_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT1_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT2_ INTERVAL +! auxinput2_interval is left there (and means minutes) for consistency, but +! auxinput2_interval_m will take precedence if specified + CALL nl_get_auxinput2_interval( grid%id, auxinput2_interval ) ! same as minutes + CALL nl_get_auxinput2_interval_mo( grid%id, auxinput2_interval_mo ) + CALL nl_get_auxinput2_interval_d( grid%id, auxinput2_interval_d ) + CALL nl_get_auxinput2_interval_h( grid%id, auxinput2_interval_h ) + CALL nl_get_auxinput2_interval_m( grid%id, auxinput2_interval_m ) + CALL nl_get_auxinput2_interval_s( grid%id, auxinput2_interval_s ) + IF ( auxinput2_interval_m .EQ. 0 ) auxinput2_interval_m = auxinput2_interval + + IF ( MAX( auxinput2_interval_mo, auxinput2_interval_d, & + auxinput2_interval_h, auxinput2_interval_m , auxinput2_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput2_interval_mo, D=auxinput2_interval_d, & + H=auxinput2_interval_h, M=auxinput2_interval_m, S=auxinput2_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput2_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput2_begin_y( grid%id, auxinput2_begin_y ) + CALL nl_get_auxinput2_begin_mo( grid%id, auxinput2_begin_mo ) + CALL nl_get_auxinput2_begin_d( grid%id, auxinput2_begin_d ) + CALL nl_get_auxinput2_begin_h( grid%id, auxinput2_begin_h ) + CALL nl_get_auxinput2_begin_m( grid%id, auxinput2_begin_m ) + CALL nl_get_auxinput2_begin_s( grid%id, auxinput2_begin_s ) + IF ( MAX( auxinput2_begin_y, auxinput2_begin_mo, auxinput2_begin_d, & + auxinput2_begin_h, auxinput2_begin_m , auxinput2_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput2_begin_mo, D=auxinput2_begin_d, & + H=auxinput2_begin_h, M=auxinput2_begin_m, S=auxinput2_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput2_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput2_end_y( grid%id, auxinput2_end_y ) + CALL nl_get_auxinput2_end_mo( grid%id, auxinput2_end_mo ) + CALL nl_get_auxinput2_end_d( grid%id, auxinput2_end_d ) + CALL nl_get_auxinput2_end_h( grid%id, auxinput2_end_h ) + CALL nl_get_auxinput2_end_m( grid%id, auxinput2_end_m ) + CALL nl_get_auxinput2_end_s( grid%id, auxinput2_end_s ) + IF ( MAX( auxinput2_end_y, auxinput2_end_mo, auxinput2_end_d, & + auxinput2_end_h, auxinput2_end_m , auxinput2_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput2_end_mo, D=auxinput2_end_d, & + H=auxinput2_end_h, M=auxinput2_end_m, S=auxinput2_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput2_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT2_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT2_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT3_ INTERVAL +! auxinput3_interval is left there (and means minutes) for consistency, but +! auxinput3_interval_m will take precedence if specified + CALL nl_get_auxinput3_interval( grid%id, auxinput3_interval ) ! same as minutes + CALL nl_get_auxinput3_interval_mo( grid%id, auxinput3_interval_mo ) + CALL nl_get_auxinput3_interval_d( grid%id, auxinput3_interval_d ) + CALL nl_get_auxinput3_interval_h( grid%id, auxinput3_interval_h ) + CALL nl_get_auxinput3_interval_m( grid%id, auxinput3_interval_m ) + CALL nl_get_auxinput3_interval_s( grid%id, auxinput3_interval_s ) + IF ( auxinput3_interval_m .EQ. 0 ) auxinput3_interval_m = auxinput3_interval + + IF ( MAX( auxinput3_interval_mo, auxinput3_interval_d, & + auxinput3_interval_h, auxinput3_interval_m , auxinput3_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput3_interval_mo, D=auxinput3_interval_d, & + H=auxinput3_interval_h, M=auxinput3_interval_m, S=auxinput3_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput3_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput3_begin_y( grid%id, auxinput3_begin_y ) + CALL nl_get_auxinput3_begin_mo( grid%id, auxinput3_begin_mo ) + CALL nl_get_auxinput3_begin_d( grid%id, auxinput3_begin_d ) + CALL nl_get_auxinput3_begin_h( grid%id, auxinput3_begin_h ) + CALL nl_get_auxinput3_begin_m( grid%id, auxinput3_begin_m ) + CALL nl_get_auxinput3_begin_s( grid%id, auxinput3_begin_s ) + IF ( MAX( auxinput3_begin_y, auxinput3_begin_mo, auxinput3_begin_d, & + auxinput3_begin_h, auxinput3_begin_m , auxinput3_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput3_begin_mo, D=auxinput3_begin_d, & + H=auxinput3_begin_h, M=auxinput3_begin_m, S=auxinput3_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput3_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput3_end_y( grid%id, auxinput3_end_y ) + CALL nl_get_auxinput3_end_mo( grid%id, auxinput3_end_mo ) + CALL nl_get_auxinput3_end_d( grid%id, auxinput3_end_d ) + CALL nl_get_auxinput3_end_h( grid%id, auxinput3_end_h ) + CALL nl_get_auxinput3_end_m( grid%id, auxinput3_end_m ) + CALL nl_get_auxinput3_end_s( grid%id, auxinput3_end_s ) + IF ( MAX( auxinput3_end_y, auxinput3_end_mo, auxinput3_end_d, & + auxinput3_end_h, auxinput3_end_m , auxinput3_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput3_end_mo, D=auxinput3_end_d, & + H=auxinput3_end_h, M=auxinput3_end_m, S=auxinput3_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput3_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT3_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT3_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT4_ INTERVAL +! auxinput4_interval is left there (and means minutes) for consistency, but +! auxinput4_interval_m will take precedence if specified + CALL nl_get_auxinput4_interval( grid%id, auxinput4_interval ) ! same as minutes + CALL nl_get_auxinput4_interval_mo( grid%id, auxinput4_interval_mo ) + CALL nl_get_auxinput4_interval_d( grid%id, auxinput4_interval_d ) + CALL nl_get_auxinput4_interval_h( grid%id, auxinput4_interval_h ) + CALL nl_get_auxinput4_interval_m( grid%id, auxinput4_interval_m ) + CALL nl_get_auxinput4_interval_s( grid%id, auxinput4_interval_s ) + IF ( auxinput4_interval_m .EQ. 0 ) auxinput4_interval_m = auxinput4_interval + + IF ( MAX( auxinput4_interval_mo, auxinput4_interval_d, & + auxinput4_interval_h, auxinput4_interval_m , auxinput4_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput4_interval_mo, D=auxinput4_interval_d, & + H=auxinput4_interval_h, M=auxinput4_interval_m, S=auxinput4_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput4_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput4_begin_y( grid%id, auxinput4_begin_y ) + CALL nl_get_auxinput4_begin_mo( grid%id, auxinput4_begin_mo ) + CALL nl_get_auxinput4_begin_d( grid%id, auxinput4_begin_d ) + CALL nl_get_auxinput4_begin_h( grid%id, auxinput4_begin_h ) + CALL nl_get_auxinput4_begin_m( grid%id, auxinput4_begin_m ) + CALL nl_get_auxinput4_begin_s( grid%id, auxinput4_begin_s ) + IF ( MAX( auxinput4_begin_y, auxinput4_begin_mo, auxinput4_begin_d, & + auxinput4_begin_h, auxinput4_begin_m , auxinput4_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput4_begin_mo, D=auxinput4_begin_d, & + H=auxinput4_begin_h, M=auxinput4_begin_m, S=auxinput4_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput4_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput4_end_y( grid%id, auxinput4_end_y ) + CALL nl_get_auxinput4_end_mo( grid%id, auxinput4_end_mo ) + CALL nl_get_auxinput4_end_d( grid%id, auxinput4_end_d ) + CALL nl_get_auxinput4_end_h( grid%id, auxinput4_end_h ) + CALL nl_get_auxinput4_end_m( grid%id, auxinput4_end_m ) + CALL nl_get_auxinput4_end_s( grid%id, auxinput4_end_s ) + IF ( MAX( auxinput4_end_y, auxinput4_end_mo, auxinput4_end_d, & + auxinput4_end_h, auxinput4_end_m , auxinput4_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput4_end_mo, D=auxinput4_end_d, & + H=auxinput4_end_h, M=auxinput4_end_m, S=auxinput4_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput4_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT4_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT4_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT5_ INTERVAL +! auxinput5_interval is left there (and means minutes) for consistency, but +! auxinput5_interval_m will take precedence if specified + CALL nl_get_auxinput5_interval( grid%id, auxinput5_interval ) ! same as minutes + CALL nl_get_auxinput5_interval_mo( grid%id, auxinput5_interval_mo ) + CALL nl_get_auxinput5_interval_d( grid%id, auxinput5_interval_d ) + CALL nl_get_auxinput5_interval_h( grid%id, auxinput5_interval_h ) + CALL nl_get_auxinput5_interval_m( grid%id, auxinput5_interval_m ) + CALL nl_get_auxinput5_interval_s( grid%id, auxinput5_interval_s ) + IF ( auxinput5_interval_m .EQ. 0 ) auxinput5_interval_m = auxinput5_interval + + IF ( MAX( auxinput5_interval_mo, auxinput5_interval_d, & + auxinput5_interval_h, auxinput5_interval_m , auxinput5_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput5_interval_mo, D=auxinput5_interval_d, & + H=auxinput5_interval_h, M=auxinput5_interval_m, S=auxinput5_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput5_begin_y( grid%id, auxinput5_begin_y ) + CALL nl_get_auxinput5_begin_mo( grid%id, auxinput5_begin_mo ) + CALL nl_get_auxinput5_begin_d( grid%id, auxinput5_begin_d ) + CALL nl_get_auxinput5_begin_h( grid%id, auxinput5_begin_h ) + CALL nl_get_auxinput5_begin_m( grid%id, auxinput5_begin_m ) + CALL nl_get_auxinput5_begin_s( grid%id, auxinput5_begin_s ) + IF ( MAX( auxinput5_begin_y, auxinput5_begin_mo, auxinput5_begin_d, & + auxinput5_begin_h, auxinput5_begin_m , auxinput5_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput5_begin_mo, D=auxinput5_begin_d, & + H=auxinput5_begin_h, M=auxinput5_begin_m, S=auxinput5_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput5_end_y( grid%id, auxinput5_end_y ) + CALL nl_get_auxinput5_end_mo( grid%id, auxinput5_end_mo ) + CALL nl_get_auxinput5_end_d( grid%id, auxinput5_end_d ) + CALL nl_get_auxinput5_end_h( grid%id, auxinput5_end_h ) + CALL nl_get_auxinput5_end_m( grid%id, auxinput5_end_m ) + CALL nl_get_auxinput5_end_s( grid%id, auxinput5_end_s ) + IF ( MAX( auxinput5_end_y, auxinput5_end_mo, auxinput5_end_d, & + auxinput5_end_h, auxinput5_end_m , auxinput5_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput5_end_mo, D=auxinput5_end_d, & + H=auxinput5_end_h, M=auxinput5_end_m, S=auxinput5_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT5_ALARM, interval, begin_time, end_time ) + +!TBH: Should be OK to remove the "#else" section and the code it contains +!TBH: because later code overwrites grid%alarms( AUXINPUT5_ALARM )... +!TBH: In fact, by setting namelist values for auxinput5 correctly, it ought +!TBH: to be possible to get rid of all "#ifdef WRF_CHEM" bits in this file... +#ifndef WRF_CHEM + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT5_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF +#else + CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) +#endif + + + CALL domain_alarm_create( grid, BOUNDARY_ALARM ) + + CALL WRFU_AlarmEnable( grid%alarms( BOUNDARY_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmEnable(BOUNDARY_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_AlarmRingerOn( grid%alarms( BOUNDARY_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(BOUNDARY_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + +#ifdef WRF_CHEM +! TBH: NOTE: Proper setting of namelist variables for auxinput5 ought to +! TBH: make this hard-coded bit unnecessary. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! add for wrf_chem emiss input + CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) +! end for wrf chem emiss input +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#endif + +! AUXINPUT6_ INTERVAL +! auxinput6_interval is left there (and means minutes) for consistency, but +! auxinput6_interval_m will take precedence if specified + CALL nl_get_auxinput6_interval( grid%id, auxinput6_interval ) ! same as minutes + CALL nl_get_auxinput6_interval_mo( grid%id, auxinput6_interval_mo ) + CALL nl_get_auxinput6_interval_d( grid%id, auxinput6_interval_d ) + CALL nl_get_auxinput6_interval_h( grid%id, auxinput6_interval_h ) + CALL nl_get_auxinput6_interval_m( grid%id, auxinput6_interval_m ) + CALL nl_get_auxinput6_interval_s( grid%id, auxinput6_interval_s ) + IF ( auxinput6_interval_m .EQ. 0 ) auxinput6_interval_m = auxinput6_interval + + IF ( MAX( auxinput6_interval_mo, auxinput6_interval_d, & + auxinput6_interval_h, auxinput6_interval_m , auxinput6_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput6_interval_mo, D=auxinput6_interval_d, & + H=auxinput6_interval_h, M=auxinput6_interval_m, S=auxinput6_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput6_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput6_begin_y( grid%id, auxinput6_begin_y ) + CALL nl_get_auxinput6_begin_mo( grid%id, auxinput6_begin_mo ) + CALL nl_get_auxinput6_begin_d( grid%id, auxinput6_begin_d ) + CALL nl_get_auxinput6_begin_h( grid%id, auxinput6_begin_h ) + CALL nl_get_auxinput6_begin_m( grid%id, auxinput6_begin_m ) + CALL nl_get_auxinput6_begin_s( grid%id, auxinput6_begin_s ) + IF ( MAX( auxinput6_begin_y, auxinput6_begin_mo, auxinput6_begin_d, & + auxinput6_begin_h, auxinput6_begin_m , auxinput6_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput6_begin_mo, D=auxinput6_begin_d, & + H=auxinput6_begin_h, M=auxinput6_begin_m, S=auxinput6_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput6_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput6_end_y( grid%id, auxinput6_end_y ) + CALL nl_get_auxinput6_end_mo( grid%id, auxinput6_end_mo ) + CALL nl_get_auxinput6_end_d( grid%id, auxinput6_end_d ) + CALL nl_get_auxinput6_end_h( grid%id, auxinput6_end_h ) + CALL nl_get_auxinput6_end_m( grid%id, auxinput6_end_m ) + CALL nl_get_auxinput6_end_s( grid%id, auxinput6_end_s ) + IF ( MAX( auxinput6_end_y, auxinput6_end_mo, auxinput6_end_d, & + auxinput6_end_h, auxinput6_end_m , auxinput6_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput6_end_mo, D=auxinput6_end_d, & + H=auxinput6_end_h, M=auxinput6_end_m, S=auxinput6_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput6_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT6_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT6_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + + +! AUXINPUT7_ INTERVAL +! auxinput7_interval is left there (and means minutes) for consistency, but +! auxinput7_interval_m will take precedence if specified + CALL nl_get_auxinput7_interval( grid%id, auxinput7_interval ) ! same as minutes + CALL nl_get_auxinput7_interval_mo( grid%id, auxinput7_interval_mo ) + CALL nl_get_auxinput7_interval_d( grid%id, auxinput7_interval_d ) + CALL nl_get_auxinput7_interval_h( grid%id, auxinput7_interval_h ) + CALL nl_get_auxinput7_interval_m( grid%id, auxinput7_interval_m ) + CALL nl_get_auxinput7_interval_s( grid%id, auxinput7_interval_s ) + IF ( auxinput7_interval_m .EQ. 0 ) auxinput7_interval_m = auxinput7_interval + + IF ( MAX( auxinput7_interval_mo, auxinput7_interval_d, & + auxinput7_interval_h, auxinput7_interval_m , auxinput7_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput7_interval_mo, D=auxinput7_interval_d, & + H=auxinput7_interval_h, M=auxinput7_interval_m, S=auxinput7_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput7_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput7_begin_y( grid%id, auxinput7_begin_y ) + CALL nl_get_auxinput7_begin_mo( grid%id, auxinput7_begin_mo ) + CALL nl_get_auxinput7_begin_d( grid%id, auxinput7_begin_d ) + CALL nl_get_auxinput7_begin_h( grid%id, auxinput7_begin_h ) + CALL nl_get_auxinput7_begin_m( grid%id, auxinput7_begin_m ) + CALL nl_get_auxinput7_begin_s( grid%id, auxinput7_begin_s ) + IF ( MAX( auxinput7_begin_y, auxinput7_begin_mo, auxinput7_begin_d, & + auxinput7_begin_h, auxinput7_begin_m , auxinput7_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput7_begin_mo, D=auxinput7_begin_d, & + H=auxinput7_begin_h, M=auxinput7_begin_m, S=auxinput7_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput7_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput7_end_y( grid%id, auxinput7_end_y ) + CALL nl_get_auxinput7_end_mo( grid%id, auxinput7_end_mo ) + CALL nl_get_auxinput7_end_d( grid%id, auxinput7_end_d ) + CALL nl_get_auxinput7_end_h( grid%id, auxinput7_end_h ) + CALL nl_get_auxinput7_end_m( grid%id, auxinput7_end_m ) + CALL nl_get_auxinput7_end_s( grid%id, auxinput7_end_s ) + IF ( MAX( auxinput7_end_y, auxinput7_end_mo, auxinput7_end_d, & + auxinput7_end_h, auxinput7_end_m , auxinput7_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput7_end_mo, D=auxinput7_end_d, & + H=auxinput7_end_h, M=auxinput7_end_m, S=auxinput7_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput7_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT7_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT7_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + + + +! AUXINPUT8_ INTERVAL +! auxinput8_interval is left there (and means minutes) for consistency, but +! auxinput8_interval_m will take precedence if specified + CALL nl_get_auxinput8_interval( grid%id, auxinput8_interval ) ! same as minutes + CALL nl_get_auxinput8_interval_mo( grid%id, auxinput8_interval_mo ) + CALL nl_get_auxinput8_interval_d( grid%id, auxinput8_interval_d ) + CALL nl_get_auxinput8_interval_h( grid%id, auxinput8_interval_h ) + CALL nl_get_auxinput8_interval_m( grid%id, auxinput8_interval_m ) + CALL nl_get_auxinput8_interval_s( grid%id, auxinput8_interval_s ) + IF ( auxinput8_interval_m .EQ. 0 ) auxinput8_interval_m = auxinput8_interval + + IF ( MAX( auxinput8_interval_mo, auxinput8_interval_d, & + auxinput8_interval_h, auxinput8_interval_m , auxinput8_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput8_interval_mo, D=auxinput8_interval_d, & + H=auxinput8_interval_h, M=auxinput8_interval_m, S=auxinput8_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput8_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput8_begin_y( grid%id, auxinput8_begin_y ) + CALL nl_get_auxinput8_begin_mo( grid%id, auxinput8_begin_mo ) + CALL nl_get_auxinput8_begin_d( grid%id, auxinput8_begin_d ) + CALL nl_get_auxinput8_begin_h( grid%id, auxinput8_begin_h ) + CALL nl_get_auxinput8_begin_m( grid%id, auxinput8_begin_m ) + CALL nl_get_auxinput8_begin_s( grid%id, auxinput8_begin_s ) + IF ( MAX( auxinput8_begin_y, auxinput8_begin_mo, auxinput8_begin_d, & + auxinput8_begin_h, auxinput8_begin_m , auxinput8_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput8_begin_mo, D=auxinput8_begin_d, & + H=auxinput8_begin_h, M=auxinput8_begin_m, S=auxinput8_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput8_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput8_end_y( grid%id, auxinput8_end_y ) + CALL nl_get_auxinput8_end_mo( grid%id, auxinput8_end_mo ) + CALL nl_get_auxinput8_end_d( grid%id, auxinput8_end_d ) + CALL nl_get_auxinput8_end_h( grid%id, auxinput8_end_h ) + CALL nl_get_auxinput8_end_m( grid%id, auxinput8_end_m ) + CALL nl_get_auxinput8_end_s( grid%id, auxinput8_end_s ) + IF ( MAX( auxinput8_end_y, auxinput8_end_mo, auxinput8_end_d, & + auxinput8_end_h, auxinput8_end_m , auxinput8_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput8_end_mo, D=auxinput8_end_d, & + H=auxinput8_end_h, M=auxinput8_end_m, S=auxinput8_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput8_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT8_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT8_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT9_ INTERVAL +! auxinput9_interval is left there (and means minutes) for consistency, but +! auxinput9_interval_m will take precedence if specified + CALL nl_get_auxinput9_interval( grid%id, auxinput9_interval ) ! same as minutes + CALL nl_get_auxinput9_interval_mo( grid%id, auxinput9_interval_mo ) + CALL nl_get_auxinput9_interval_d( grid%id, auxinput9_interval_d ) + CALL nl_get_auxinput9_interval_h( grid%id, auxinput9_interval_h ) + CALL nl_get_auxinput9_interval_m( grid%id, auxinput9_interval_m ) + CALL nl_get_auxinput9_interval_s( grid%id, auxinput9_interval_s ) + IF ( auxinput9_interval_m .EQ. 0 ) auxinput9_interval_m = auxinput9_interval + + IF ( MAX( auxinput9_interval_mo, auxinput9_interval_d, & + auxinput9_interval_h, auxinput9_interval_m , auxinput9_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput9_interval_mo, D=auxinput9_interval_d, & + H=auxinput9_interval_h, M=auxinput9_interval_m, S=auxinput9_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput9_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput9_begin_y( grid%id, auxinput9_begin_y ) + CALL nl_get_auxinput9_begin_mo( grid%id, auxinput9_begin_mo ) + CALL nl_get_auxinput9_begin_d( grid%id, auxinput9_begin_d ) + CALL nl_get_auxinput9_begin_h( grid%id, auxinput9_begin_h ) + CALL nl_get_auxinput9_begin_m( grid%id, auxinput9_begin_m ) + CALL nl_get_auxinput9_begin_s( grid%id, auxinput9_begin_s ) + IF ( MAX( auxinput9_begin_y, auxinput9_begin_mo, auxinput9_begin_d, & + auxinput9_begin_h, auxinput9_begin_m , auxinput9_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput9_begin_mo, D=auxinput9_begin_d, & + H=auxinput9_begin_h, M=auxinput9_begin_m, S=auxinput9_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput9_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput9_end_y( grid%id, auxinput9_end_y ) + CALL nl_get_auxinput9_end_mo( grid%id, auxinput9_end_mo ) + CALL nl_get_auxinput9_end_d( grid%id, auxinput9_end_d ) + CALL nl_get_auxinput9_end_h( grid%id, auxinput9_end_h ) + CALL nl_get_auxinput9_end_m( grid%id, auxinput9_end_m ) + CALL nl_get_auxinput9_end_s( grid%id, auxinput9_end_s ) + IF ( MAX( auxinput9_end_y, auxinput9_end_mo, auxinput9_end_d, & + auxinput9_end_h, auxinput9_end_m , auxinput9_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput9_end_mo, D=auxinput9_end_d, & + H=auxinput9_end_h, M=auxinput9_end_m, S=auxinput9_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput9_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT9_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT9_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +#if (EM_CORE == 1) + CALL nl_get_grid_fdda( grid%id, grid_fdda ) +#endif + +! AUXINPUT10_ INTERVAL (GFDDA) +! gfdda_interval is left there (and means minutes) for consistency, but +! gfdda_interval_m will take precedence if specified + CALL nl_get_gfdda_interval( grid%id, gfdda_interval ) ! same as minutes + CALL nl_get_gfdda_interval_mo( grid%id, gfdda_interval_mo ) + CALL nl_get_gfdda_interval_d( grid%id, gfdda_interval_d ) + CALL nl_get_gfdda_interval_h( grid%id, gfdda_interval_h ) + CALL nl_get_gfdda_interval_m( grid%id, gfdda_interval_m ) + CALL nl_get_gfdda_interval_s( grid%id, gfdda_interval_s ) + IF ( gfdda_interval_m .EQ. 0 ) gfdda_interval_m = gfdda_interval + + IF ( MAX( gfdda_interval_mo, gfdda_interval_d, & + gfdda_interval_h, gfdda_interval_m , gfdda_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=gfdda_interval_mo, D=gfdda_interval_d, & + H=gfdda_interval_h, M=gfdda_interval_m, S=gfdda_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(gfdda_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF +#if (EM_CORE == 1) + IF( grid_fdda == 0 ) interval = run_length + padding_interval +#endif + + CALL nl_get_gfdda_begin_y( grid%id, gfdda_begin_y ) + CALL nl_get_gfdda_begin_mo( grid%id, gfdda_begin_mo ) + CALL nl_get_gfdda_begin_d( grid%id, gfdda_begin_d ) + CALL nl_get_gfdda_begin_h( grid%id, gfdda_begin_h ) + CALL nl_get_gfdda_begin_m( grid%id, gfdda_begin_m ) + CALL nl_get_gfdda_begin_s( grid%id, gfdda_begin_s ) + IF ( MAX( gfdda_begin_y, gfdda_begin_mo, gfdda_begin_d, & + gfdda_begin_h, gfdda_begin_m , gfdda_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=gfdda_begin_mo, D=gfdda_begin_d, & + H=gfdda_begin_h, M=gfdda_begin_m, S=gfdda_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(gfdda_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_gfdda_end_y( grid%id, gfdda_end_y ) + CALL nl_get_gfdda_end_mo( grid%id, gfdda_end_mo ) + CALL nl_get_gfdda_end_d( grid%id, gfdda_end_d ) + CALL nl_get_gfdda_end_h( grid%id, gfdda_end_h ) +#if (EM_CORE == 1) + IF( grid_fdda == 1 ) gfdda_end_h = gfdda_end_h - NINT( gfdda_interval_m/60.0 ) +#endif + CALL nl_get_gfdda_end_m( grid%id, gfdda_end_m ) + CALL nl_get_gfdda_end_s( grid%id, gfdda_end_s ) + IF ( MAX( gfdda_end_y, gfdda_end_mo, gfdda_end_d, & + gfdda_end_h, gfdda_end_m , gfdda_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=gfdda_end_mo, D=gfdda_end_d, & + H=gfdda_end_h, M=gfdda_end_m, S=gfdda_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(gfdda_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF +#if (EM_CORE == 1) + IF( grid_fdda == 0 ) end_time = run_length + padding_interval +#endif + + CALL domain_alarm_create( grid, AUXINPUT10_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT10_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +! AUXINPUT11_ INTERVAL +! auxinput11_interval is left there (and means minutes) for consistency, but +! auxinput11_interval_m will take precedence if specified + CALL nl_get_auxinput11_interval( grid%id, auxinput11_interval ) ! same as minutes + CALL nl_get_auxinput11_interval_mo( grid%id, auxinput11_interval_mo ) + CALL nl_get_auxinput11_interval_d( grid%id, auxinput11_interval_d ) + CALL nl_get_auxinput11_interval_h( grid%id, auxinput11_interval_h ) + CALL nl_get_auxinput11_interval_m( grid%id, auxinput11_interval_m ) + CALL nl_get_auxinput11_interval_s( grid%id, auxinput11_interval_s ) + IF ( auxinput11_interval_m .EQ. 0 ) auxinput11_interval_m = auxinput11_interval + + IF ( MAX( auxinput11_interval_mo, auxinput11_interval_d, & + auxinput11_interval_h, auxinput11_interval_m , auxinput11_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, MM=auxinput11_interval_mo, D=auxinput11_interval_d, & + H=auxinput11_interval_h, M=auxinput11_interval_m, S=auxinput11_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput11_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput11_begin_y( grid%id, auxinput11_begin_y ) + CALL nl_get_auxinput11_begin_mo( grid%id, auxinput11_begin_mo ) + CALL nl_get_auxinput11_begin_d( grid%id, auxinput11_begin_d ) + CALL nl_get_auxinput11_begin_h( grid%id, auxinput11_begin_h ) + CALL nl_get_auxinput11_begin_m( grid%id, auxinput11_begin_m ) + CALL nl_get_auxinput11_begin_s( grid%id, auxinput11_begin_s ) + IF ( MAX( auxinput11_begin_y, auxinput11_begin_mo, auxinput11_begin_d, & + auxinput11_begin_h, auxinput11_begin_m , auxinput11_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , MM=auxinput11_begin_mo, D=auxinput11_begin_d, & + H=auxinput11_begin_h, M=auxinput11_begin_m, S=auxinput11_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput11_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_auxinput11_end_y( grid%id, auxinput11_end_y ) + CALL nl_get_auxinput11_end_mo( grid%id, auxinput11_end_mo ) + CALL nl_get_auxinput11_end_d( grid%id, auxinput11_end_d ) + CALL nl_get_auxinput11_end_h( grid%id, auxinput11_end_h ) + CALL nl_get_auxinput11_end_m( grid%id, auxinput11_end_m ) + CALL nl_get_auxinput11_end_s( grid%id, auxinput11_end_s ) + IF ( MAX( auxinput11_end_y, auxinput11_end_mo, auxinput11_end_d, & + auxinput11_end_h, auxinput11_end_m , auxinput11_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , MM=auxinput11_end_mo, D=auxinput11_end_d, & + H=auxinput11_end_h, M=auxinput11_end_m, S=auxinput11_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput11_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, AUXINPUT11_ALARM, interval, begin_time, end_time ) + + IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(AUXINPUT11_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + ENDIF + +#ifdef MOVE_NESTS +! This is the interval at which the code in time_for_move in share/mediation_integrate.F +! will recompute the center of the Vortex. Other times, it will use the last position. +! + CALL nl_get_vortex_interval ( grid%id , vortex_interval ) + CALL WRFU_TimeIntervalSet( interval, M=vortex_interval, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(interval) for computing vortex center FAILED', & + __FILE__ , & + __LINE__ ) + CALL domain_alarm_create( grid, COMPUTE_VORTEX_CENTER_ALARM, interval ) + CALL WRFU_AlarmEnable( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmEnable(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_AlarmRingerOn( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) +#endif + + grid%time_set = .TRUE. + + ! Initialize derived time quantities in grid state. + ! These are updated in domain_clockadvance(). + CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime ) + CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian ) + WRITE(wrf_err_message,*) 'setup_timekeeping: set xtime to ',grid%xtime + CALL wrf_debug ( 100, TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*) 'setup_timekeeping: set julian to ',grid%julian + CALL wrf_debug ( 100, TRIM(wrf_err_message) ) + + CALL wrf_debug ( 100 , 'setup_timekeeping: returning...' ) + +END SUBROUTINE Setup_Timekeeping + + diff --git a/wrfv2_fire/share/sint.F b/wrfv2_fire/share/sint.F new file mode 100644 index 00000000..1a386147 --- /dev/null +++ b/wrfv2_fire/share/sint.F @@ -0,0 +1,418 @@ + + SUBROUTINE SINT(XF, & + ims, ime, jms, jme, icmask , & + its, ite, jts, jte, nf, xstag, ystag ) + IMPLICIT NONE + INTEGER ims, ime, jms, jme, & + its, ite, jts, jte + + LOGICAL icmask( ims:ime, jms:jme ) + LOGICAL xstag, ystag + + INTEGER nf, ior + REAL one12, one24, ep + PARAMETER(one12=1./12.,one24=1./24.) + PARAMETER(ior=2) +! + REAL XF(ims:ime,jms:jme,NF) +! + REAL Y(ims:ime,jms:jme,-IOR:IOR), & + Z(ims:ime,jms:jme,-IOR:IOR), & + F(ims:ime,jms:jme,0:1) +! + INTEGER I,J,II,JJ,IIM + INTEGER N2STAR, N2END, N1STAR, N1END +! + DATA EP/ 1.E-10/ +! +! PARAMETER(NONOS=1) +! PARAMETER(N1OS=N1*NONOS+1-NONOS,N2OS=N2*NONOS+1-NONOS) +! + REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme) + REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme) + REAL FL(ims:ime,jms:jme,0:1) + REAL XIG(81), XJG(81) ! won't use but nine of these fellers. + INTEGER IFRST + integer rr + COMMON /DEPAR2/ XIG,XJG,IFRST + DATA IFRST /1/ + + REAL rioff, rjoff +! + REAL donor, y1, y2, a + DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A + REAL tr4, ym1, y0, yp1, yp2 + TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1)) & + -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0) & + -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1)) + REAL pp, pn, x + PP(X)=AMAX1(0.,X) + PN(X)=AMIN1(0.,X) +!! XIG(I) = 1./3.-FLOAT(I-1)*1./3 +!! XJG(J) = 1./3.-FLOAT(J-1)*1./3 + + rr = nint(sqrt(float(nf))) +!! write(6,*) ' nf, rr are ',nf,rr +!! IF ( IFRST .EQ. 1 ) THEN + + rioff = 0 + rjoff = 0 + if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1. + if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1. + + DO I=1,rr + DO J=1,rr + XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr) + XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr) + ENDDO + ENDDO + IFRST = 0 + +!! ENDIF + +! IF ( IFRST .EQ. 1 ) THEN +! DO I=1,3 +! DO J=1,3 +! XIG(J+(I-1)*3)=1./3.-FLOAT(J-1)*1./3. +! XJG(J+(I-1)*3)=1./3.-FLOAT(I-1)*1./3. +! ENDDO +! ENDDO +! IFRST = 0 +! ENDIF +! + N2STAR = jts + N2END = jte + N1STAR = its + N1END = ite + + DO 2000 IIM=1,NF +! +! HERE STARTS RESIDUAL ADVECTION +! + DO 9000 JJ=N2STAR,N2END + DO 50 J=-IOR,IOR + + DO 51 I=-IOR,IOR + DO 511 II=N1STAR,N1END + IF ( icmask(II,JJ) ) Y(II,JJ,I)=XF(II+I,JJ+J,IIM) + 511 CONTINUE + 51 CONTINUE + + DO 811 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM)) + FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM)) + ENDIF + 811 CONTINUE + DO 812 II=N1STAR,N1END + IF ( icmask(II,JJ) ) W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) + 812 CONTINUE + DO 813 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + MXM(II,JJ)= & + AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1), & + W(II,JJ)) + MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ)) + ENDIF + 813 CONTINUE + DO 312 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)= & + TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0), & + Y(II,JJ,1),XIG(IIM)) + F(II,JJ,1)= & + TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),& + XIG(IIM)) + ENDIF + 312 CONTINUE + DO 822 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) + F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) + ENDIF + 822 CONTINUE + DO 823 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & + PP(F(II,JJ,0))+EP) + UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))- & + PN(F(II,JJ,0))+EP) + ENDIF + 823 CONTINUE + DO 824 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+ & + PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ)) + F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+ & + PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ)) + ENDIF + 824 CONTINUE + DO 825 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) + ENDIF + 825 CONTINUE + DO 361 II=N1STAR,N1END + IF ( icmask(II,JJ) ) Z(II,JJ,J)=Y(II,JJ,0) + 361 CONTINUE +! +! END IF FIRST J LOOP +! + 8000 CONTINUE + 50 CONTINUE + + DO 911 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM)) + FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM)) + ENDIF + 911 CONTINUE + DO 912 II=N1STAR,N1END + IF ( icmask(II,JJ) ) W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) + 912 CONTINUE + DO 913 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) + MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) + ENDIF + 913 CONTINUE + DO 412 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)= & + TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)& + ,XJG(IIM)) + F(II,JJ,1)= & + TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2), & + XJG(IIM)) + ENDIF + 412 CONTINUE + DO 922 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) + F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) + ENDIF + 922 CONTINUE + DO 923 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & + PP(F(II,JJ,0))+EP) + UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ & + EP) + ENDIF + 923 CONTINUE + DO 924 II=N1STAR,N1END + IF ( icmask(II,JJ) ) THEN + F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0)) & + *AMIN1(1.,UN(II,JJ)) + F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1)) & + *AMIN1(1.,OV(II,JJ)) + ENDIF + 924 CONTINUE + 9000 CONTINUE + DO 925 JJ=N2STAR,N2END + DO 925 II=N1STAR,N1END + IF ( icmask(II,JJ) ) XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) + 925 CONTINUE + +! + 2000 CONTINUE + RETURN + END + +! Version of sint that replaces mask with detailed ranges for avoiding boundaries +! may help performance by getting the conditionals out of innner loops + + SUBROUTINE SINTB(XF1, XF , & + ims, ime, jms, jme, icmask , & + its, ite, jts, jte, nf, xstag, ystag ) + IMPLICIT NONE + INTEGER ims, ime, jms, jme, & + its, ite, jts, jte + + LOGICAL icmask( ims:ime, jms:jme ) + LOGICAL xstag, ystag + + INTEGER nf, ior + REAL one12, one24, ep + PARAMETER(one12=1./12.,one24=1./24.) + PARAMETER(ior=2) +! + REAL XF(ims:ime,jms:jme,NF) + REAL XF1(ims:ime,jms:jme,NF) +! + REAL Y(ims:ime,jms:jme,-IOR:IOR), & + Z(ims:ime,jms:jme,-IOR:IOR), & + F(ims:ime,jms:jme,0:1) +! + INTEGER I,J,II,JJ,IIM + INTEGER N2STAR, N2END, N1STAR, N1END +! + DATA EP/ 1.E-10/ +! +! PARAMETER(NONOS=1) +! PARAMETER(N1OS=N1*NONOS+1-NONOS,N2OS=N2*NONOS+1-NONOS) +! + REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme) + REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme) + REAL FL(ims:ime,jms:jme,0:1) + REAL XIG(81), XJG(81) ! won't use but nine of these fellers. + INTEGER IFRST + integer rr + COMMON /DEPAR2B/ XIG,XJG,IFRST + DATA IFRST /1/ + + REAL rioff, rjoff +! + REAL donor, y1, y2, a + DONOR(Y1,Y2,A)=(Y1*AMAX1(0.,SIGN(1.,A))-Y2*AMIN1(0.,SIGN(1.,A)))*A + REAL tr4, ym1, y0, yp1, yp2 + TR4(YM1,Y0,YP1,YP2,A)=A*ONE12*(7.*(YP1+Y0)-(YP2+YM1)) & + -A*A*ONE24*(15.*(YP1-Y0)-(YP2-YM1))-A*A*A*ONE12*((YP1+Y0) & + -(YP2+YM1))+A*A*A*A*ONE24*(3.*(YP1-Y0)-(YP2-YM1)) + REAL pp, pn, x + PP(X)=AMAX1(0.,X) + PN(X)=AMIN1(0.,X) + + rr = nint(sqrt(float(nf))) + + rioff = 0 + rjoff = 0 + if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1. + if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1. + + DO I=1,rr + DO J=1,rr + XIG(J+(I-1)*rr)=(float(rr)-1.-rioff)/float(2*rr)-FLOAT(J-1)*1./float(rr) + XJG(J+(I-1)*rr)=(float(rr)-1.-rjoff)/float(2*rr)-FLOAT(I-1)*1./float(rr) + ENDDO + ENDDO + IFRST = 0 + +!! ENDIF + +! IF ( IFRST .EQ. 1 ) THEN +! DO I=1,3 +! DO J=1,3 +! XIG(J+(I-1)*3)=1./3.-FLOAT(J-1)*1./3. +! XJG(J+(I-1)*3)=1./3.-FLOAT(I-1)*1./3. +! ENDDO +! ENDDO +! IFRST = 0 +! ENDIF +! + N2STAR = jts + N2END = jte + N1STAR = its + N1END = ite + + DO 2000 IIM=1,NF +! +! HERE STARTS RESIDUAL ADVECTION +! + DO 9000 JJ=N2STAR,N2END +!cdir unroll=5 + DO 50 J=-IOR,IOR + +!cdir unroll=5 + DO 51 I=-IOR,IOR + DO 511 II=N1STAR,N1END + Y(II,JJ,I)=XF1(II+I,JJ+J,IIM) + 511 CONTINUE + 51 CONTINUE + + DO 811 II=N1STAR,N1END + FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM)) + FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM)) + 811 CONTINUE + DO 812 II=N1STAR,N1END + W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) + 812 CONTINUE + DO 813 II=N1STAR,N1END + MXM(II,JJ)= & + AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1), & + W(II,JJ)) + MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ)) + 813 CONTINUE + DO 312 II=N1STAR,N1END + F(II,JJ,0)= & + TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0), & + Y(II,JJ,1),XIG(IIM)) + F(II,JJ,1)= & + TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),& + XIG(IIM)) + 312 CONTINUE + DO 822 II=N1STAR,N1END + F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) + F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) + 822 CONTINUE + DO 823 II=N1STAR,N1END + OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & + PP(F(II,JJ,0))+EP) + UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))- & + PN(F(II,JJ,0))+EP) + 823 CONTINUE + DO 824 II=N1STAR,N1END + F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+ & + PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ)) + F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+ & + PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ)) + 824 CONTINUE + DO 825 II=N1STAR,N1END + Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) + 825 CONTINUE + DO 361 II=N1STAR,N1END + Z(II,JJ,J)=Y(II,JJ,0) + 361 CONTINUE +! +! END IF FIRST J LOOP +! + 8000 CONTINUE + 50 CONTINUE + + DO 911 II=N1STAR,N1END + FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM)) + FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM)) + 911 CONTINUE + DO 912 II=N1STAR,N1END + W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) + 912 CONTINUE + DO 913 II=N1STAR,N1END + MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) + MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) + 913 CONTINUE + DO 412 II=N1STAR,N1END + F(II,JJ,0)= & + TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)& + ,XJG(IIM)) + F(II,JJ,1)= & + TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2), & + XJG(IIM)) + 412 CONTINUE + DO 922 II=N1STAR,N1END + F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) + F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) + 922 CONTINUE + DO 923 II=N1STAR,N1END + OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & + PP(F(II,JJ,0))+EP) + UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ & + EP) + 923 CONTINUE + DO 924 II=N1STAR,N1END + F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0)) & + *AMIN1(1.,UN(II,JJ)) + F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1)) & + *AMIN1(1.,OV(II,JJ)) + 924 CONTINUE + 9000 CONTINUE + DO 925 JJ=N2STAR,N2END + DO 925 II=N1STAR,N1END + XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) + 925 CONTINUE + +! + 2000 CONTINUE + RETURN + END + + diff --git a/wrfv2_fire/share/solve_em.int b/wrfv2_fire/share/solve_em.int new file mode 100644 index 00000000..91ed7a09 --- /dev/null +++ b/wrfv2_fire/share/solve_em.int @@ -0,0 +1,18 @@ +SUBROUTINE solve_em ( grid , config_flags & +! +#include +! + ) + + USE module_domain + USE module_configure + USE module_driver_constants + + ! Input data. + TYPE(domain) , INTENT(INOUT) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + +#include + +END SUBROUTINE solve_em + diff --git a/wrfv2_fire/share/solve_interface.F b/wrfv2_fire/share/solve_interface.F new file mode 100644 index 00000000..8742f619 --- /dev/null +++ b/wrfv2_fire/share/solve_interface.F @@ -0,0 +1,115 @@ +!WRF:MEDIATION_LAYER:ADT_BARRIER +! + +SUBROUTINE solve_interface ( grid ) + + USE module_domain + USE module_timing + USE module_driver_constants + USE module_configure + USE module_wrf_error + + IMPLICIT NONE + + INTERFACE +#if (EM_CORE == 1 && DA_CORE != 1) +# include +#endif +#if (NMM_CORE == 1) +# include +#endif +#if (COAMPS_CORE == 1) +# include +#endif +#if (EXP_CORE == 1) +# include +#endif + END INTERFACE + + TYPE(domain) , INTENT(INOUT) :: grid + TYPE (grid_config_rec_type) :: config_flags + + INTEGER :: idum1, idum2 + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 ) + +#include "deref_kludge.h" + + IF ( config_flags%dyn_opt == DYN_NODYN ) THEN + + CALL wrf_debug( 1 , "solve_interface: dynamics disabled\n" ) + +#if (EM_CORE == 1 && DA_CORE != 1) + ELSE IF ( config_flags%dyn_opt == DYN_EM ) THEN + CALL solve_em ( grid , config_flags & +! +# include +! + ) + +# ifdef WRF_CHEM + IF ( config_flags%chem_opt > 0 ) THEN + + CALL chem_driver ( grid , config_flags & +! +# include +! + ) + ENDIF +# endif +#endif +#if (NMM_CORE == 1) + ELSE IF ( config_flags%dyn_opt == DYN_NMM ) THEN + CALL solve_nmm ( grid , config_flags & +! +# include +! + ) +# ifdef WRF_CHEM + IF ( config_flags%chem_opt > 0 ) THEN + + CALL chem_driver ( grid , config_flags & +! +# include +! + ) + ENDIF +# endif +#endif +#if (COAMPS_CORE == 1) + ELSE IF ( config_flags%dyn_opt == DYN_COAMPS ) THEN + CALL solve_coamps ( grid , config_flags & +! +# include +! + ) +#endif + +! ###### 4. Edit share/solve_interface.F to add call to experimental core + +#if (EXP_CORE == 1) + ELSE IF ( config_flags%dyn_opt == DYN_EXP ) THEN + CALL solve_exp ( grid & +! +# include +! + ) +#endif + + ELSE + + WRITE( wrf_err_message , * ) 'Invalid dynamics option: dyn_opt = ',config_flags%dyn_opt + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + + END IF + +END SUBROUTINE solve_interface + diff --git a/wrfv2_fire/share/solve_nmm.int b/wrfv2_fire/share/solve_nmm.int new file mode 100644 index 00000000..5ffb0f28 --- /dev/null +++ b/wrfv2_fire/share/solve_nmm.int @@ -0,0 +1,19 @@ + +SUBROUTINE solve_nmm ( grid , config_flags & +! +#include +! + ) + + USE module_domain + USE module_configure + USE module_driver_constants + + ! Input data. + TYPE(domain) , INTENT(INOUT) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + +#include + +END SUBROUTINE solve_nmm + diff --git a/wrfv2_fire/share/start_domain.F b/wrfv2_fire/share/start_domain.F new file mode 100644 index 00000000..60bc310d --- /dev/null +++ b/wrfv2_fire/share/start_domain.F @@ -0,0 +1,73 @@ +!WRF:MEDIATION_LAYER:ADT_BARRIER +! + +SUBROUTINE start_domain ( grid , allowed_to_read ) + + USE module_domain + USE module_configure + + IMPLICIT NONE + + ! Input Arguments. + TYPE (domain) :: grid + LOGICAL, INTENT(IN) :: allowed_to_read + ! Local data. + INTEGER :: dyn_opt + INTEGER :: idum1, idum2 + +#ifdef DEREF_KLUDGE +! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm + INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 + INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x + INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#endif + +#include "deref_kludge.h" + + CALL nl_get_dyn_opt( 1, dyn_opt ) + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + IF ( dyn_opt .eq. DYN_NODYN ) THEN + +#if ((EM_CORE == 1) && (DA_CORE != 1)) + ELSE IF ( dyn_opt .eq. DYN_EM ) THEN + + CALL start_domain_em( grid, allowed_to_read & +! +# include +! + ) +#endif +#if (NMM_CORE == 1) + ELSE IF ( dyn_opt .eq. DYN_NMM ) THEN + CALL start_domain_nmm( grid, allowed_to_read & +! +# include +! + ) +#endif +#if (COAMPS_CORE == 1) + ELSE IF ( dyn_opt .eq. DYN_COAMPS ) THEN + CALL start_domain_coamps( grid, allowed_to_read & +! +# include +! + ) +#endif + +!### 4a. edit share/start_domain.F to call domain inits for core if any + +#if (EXP_CORE == 1) + ELSE IF ( dyn_opt .eq. DYN_EXP ) THEN +#endif + + ELSE + + WRITE(0,*)' start_domain: unknown or unimplemented dyn_opt = ',dyn_opt + CALL wrf_error_fatal ( ' start_domain: unknown or unimplemented dyn_opt ' ) + ENDIF + + +END SUBROUTINE start_domain + diff --git a/wrfv2_fire/share/start_domain_em.int b/wrfv2_fire/share/start_domain_em.int new file mode 100644 index 00000000..2e393780 --- /dev/null +++ b/wrfv2_fire/share/start_domain_em.int @@ -0,0 +1,18 @@ + +SUBROUTINE start_domain_em ( grid & +! +#include +! + ) + + USE module_domain + USE module_driver_constants + + ! Input data. + TYPE(domain) , INTENT(INOUT) :: grid + +#include + + +END SUBROUTINE start_domain_em + diff --git a/wrfv2_fire/share/wrf_auxhist10in.F b/wrfv2_fire/share/wrf_auxhist10in.F new file mode 100644 index 00000000..6c687906 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist10in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist10in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist10out.F b/wrfv2_fire/share/wrf_auxhist10out.F new file mode 100644 index 00000000..284f1f86 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist10out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist10out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist11in.F b/wrfv2_fire/share/wrf_auxhist11in.F new file mode 100644 index 00000000..567f31d2 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist11in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist11in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist11out.F b/wrfv2_fire/share/wrf_auxhist11out.F new file mode 100644 index 00000000..57f2f723 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist11out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist11out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist1in.F b/wrfv2_fire/share/wrf_auxhist1in.F new file mode 100644 index 00000000..0b67668e --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist1in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist1in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt( 1, dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist1out.F b/wrfv2_fire/share/wrf_auxhist1out.F new file mode 100644 index 00000000..9699b379 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist1out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist1out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist2in.F b/wrfv2_fire/share/wrf_auxhist2in.F new file mode 100644 index 00000000..c88ff655 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist2in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist2in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist2out.F b/wrfv2_fire/share/wrf_auxhist2out.F new file mode 100644 index 00000000..de9dc19d --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist2out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist2out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist3in.F b/wrfv2_fire/share/wrf_auxhist3in.F new file mode 100644 index 00000000..f1151e30 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist3in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist3in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist3out.F b/wrfv2_fire/share/wrf_auxhist3out.F new file mode 100644 index 00000000..12653153 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist3out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist3out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist4in.F b/wrfv2_fire/share/wrf_auxhist4in.F new file mode 100644 index 00000000..2eb7b446 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist4in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist4in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist4out.F b/wrfv2_fire/share/wrf_auxhist4out.F new file mode 100644 index 00000000..bcdc1549 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist4out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist4out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist5in.F b/wrfv2_fire/share/wrf_auxhist5in.F new file mode 100644 index 00000000..64cb9862 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist5in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist5in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist5out.F b/wrfv2_fire/share/wrf_auxhist5out.F new file mode 100644 index 00000000..58a0b5bd --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist5out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist5out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist6in.F b/wrfv2_fire/share/wrf_auxhist6in.F new file mode 100644 index 00000000..37b8b643 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist6in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist6in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist6out.F b/wrfv2_fire/share/wrf_auxhist6out.F new file mode 100644 index 00000000..2753f409 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist6out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist6out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist7in.F b/wrfv2_fire/share/wrf_auxhist7in.F new file mode 100644 index 00000000..aca5e78c --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist7in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist7in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist7out.F b/wrfv2_fire/share/wrf_auxhist7out.F new file mode 100644 index 00000000..8fe11635 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist7out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist7out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist8in.F b/wrfv2_fire/share/wrf_auxhist8in.F new file mode 100644 index 00000000..2d47cbd2 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist8in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist8in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist8out.F b/wrfv2_fire/share/wrf_auxhist8out.F new file mode 100644 index 00000000..22cec7a4 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist8out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist8out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist9in.F b/wrfv2_fire/share/wrf_auxhist9in.F new file mode 100644 index 00000000..e46e198b --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist9in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxhist9in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxhist9out.F b/wrfv2_fire/share/wrf_auxhist9out.F new file mode 100644 index 00000000..c3e4b6e2 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxhist9out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxhist9out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput10in.F b/wrfv2_fire/share/wrf_auxinput10in.F new file mode 100644 index 00000000..d4463c5c --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput10in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput10in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput10out.F b/wrfv2_fire/share/wrf_auxinput10out.F new file mode 100644 index 00000000..b76c6255 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput10out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput10out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput11in.F b/wrfv2_fire/share/wrf_auxinput11in.F new file mode 100644 index 00000000..c9b162bc --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput11in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput11in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput11out.F b/wrfv2_fire/share/wrf_auxinput11out.F new file mode 100644 index 00000000..de7183af --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput11out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput11out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput1in.F b/wrfv2_fire/share/wrf_auxinput1in.F new file mode 100644 index 00000000..adbf69e6 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput1in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput1in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput1out.F b/wrfv2_fire/share/wrf_auxinput1out.F new file mode 100644 index 00000000..f06cfcf8 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput1out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput1out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput2in.F b/wrfv2_fire/share/wrf_auxinput2in.F new file mode 100644 index 00000000..70bfba6d --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput2in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput2in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput2out.F b/wrfv2_fire/share/wrf_auxinput2out.F new file mode 100644 index 00000000..fcaf8f7c --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput2out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput2out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput3in.F b/wrfv2_fire/share/wrf_auxinput3in.F new file mode 100644 index 00000000..b349a0ee --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput3in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput3in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput3out.F b/wrfv2_fire/share/wrf_auxinput3out.F new file mode 100644 index 00000000..a828fcd2 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput3out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput3out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput4in.F b/wrfv2_fire/share/wrf_auxinput4in.F new file mode 100644 index 00000000..a866b876 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput4in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput4in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput4out.F b/wrfv2_fire/share/wrf_auxinput4out.F new file mode 100644 index 00000000..57667d0f --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput4out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput4out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput5in.F b/wrfv2_fire/share/wrf_auxinput5in.F new file mode 100644 index 00000000..33eb562f --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput5in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput5in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput5out.F b/wrfv2_fire/share/wrf_auxinput5out.F new file mode 100644 index 00000000..3edf0ae5 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput5out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput5out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput6in.F b/wrfv2_fire/share/wrf_auxinput6in.F new file mode 100644 index 00000000..e199103f --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput6in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput6in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput6out.F b/wrfv2_fire/share/wrf_auxinput6out.F new file mode 100644 index 00000000..5052c7bf --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput6out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput6out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput7in.F b/wrfv2_fire/share/wrf_auxinput7in.F new file mode 100644 index 00000000..af50cd08 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput7in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput7in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput7out.F b/wrfv2_fire/share/wrf_auxinput7out.F new file mode 100644 index 00000000..1963daa1 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput7out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput7out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput8in.F b/wrfv2_fire/share/wrf_auxinput8in.F new file mode 100644 index 00000000..ce7d8621 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput8in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput8in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput8out.F b/wrfv2_fire/share/wrf_auxinput8out.F new file mode 100644 index 00000000..cb3f09af --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput8out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput8out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput9in.F b/wrfv2_fire/share/wrf_auxinput9in.F new file mode 100644 index 00000000..52e90411 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput9in.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_auxinput9in ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_auxinput9out.F b/wrfv2_fire/share/wrf_auxinput9out.F new file mode 100644 index 00000000..f5ec87d5 --- /dev/null +++ b/wrfv2_fire/share/wrf_auxinput9out.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_auxinput9out ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_bdyin.F b/wrfv2_fire/share/wrf_bdyin.F new file mode 100644 index 00000000..ced5b99b --- /dev/null +++ b/wrfv2_fire/share/wrf_bdyin.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_bdyin ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_bdyout.F b/wrfv2_fire/share/wrf_bdyout.F new file mode 100644 index 00000000..11d1d5f4 --- /dev/null +++ b/wrfv2_fire/share/wrf_bdyout.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_bdyout ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_ext_read_field.F b/wrfv2_fire/share/wrf_ext_read_field.F new file mode 100644 index 00000000..1dace7f1 --- /dev/null +++ b/wrfv2_fire/share/wrf_ext_read_field.F @@ -0,0 +1,89 @@ +!WRF:MEDIATION:IO + SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & + DomainDesc, bdy_mask, MemoryOrder,Stagger, & + debug_message , & + ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, Status ) + USE module_io + USE module_wrf_error + IMPLICIT NONE + + integer :: DataHandle + character*(*) :: DateStr + character*(*) :: Var + integer :: Field(*) + integer :: FieldType + integer :: Comm + integer :: IOComm + integer :: DomainDesc + logical, dimension(4) :: bdy_mask + character*(*) :: MemoryOrder + character*(*) :: Stagger + character*(*) :: debug_message + + INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3 + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*80 , DIMENSION(3) :: dimnames + + integer ,intent(inout) :: Status + + domain_start(1) = ds1 ; domain_end(1) = de1 ; + patch_start(1) = ps1 ; patch_end(1) = pe1 ; + memory_start(1) = ms1 ; memory_end(1) = me1 ; + domain_start(2) = ds2 ; domain_end(2) = de2 ; + patch_start(2) = ps2 ; patch_end(2) = pe2 ; + memory_start(2) = ms2 ; memory_end(2) = me2 ; + domain_start(3) = ds3 ; domain_end(3) = de3 ; + patch_start(3) = ps3 ; patch_end(3) = pe3 ; + memory_start(3) = ms3 ; memory_end(3) = me3 ; + + CALL debug_io_wrf ( debug_message,DateStr, & + domain_start,domain_end,patch_start,patch_end, & + memory_start,memory_end ) + + Status = 1 + if ( de1 - ds1 < 0 ) return + if ( de2 - ds2 < 0 ) return + if ( de3 - ds3 < 0 ) return + if ( pe1 - ps1 < 0 ) return + if ( pe2 - ps2 < 0 ) return + if ( pe3 - ps3 < 0 ) return + if ( me1 - ms1 < 0 ) return + if ( me2 - ms2 < 0 ) return + if ( me3 - ms3 < 0 ) return + Status = 0 + + CALL wrf_read_field ( & + DataHandle & ! DataHandle + ,DateStr & ! DateStr + ,Var & ! Data Name + ,Field & ! Field + ,FieldType & ! FieldType + ,Comm & ! Comm + ,IOComm & ! IOComm + ,DomainDesc & ! DomainDesc + ,bdy_mask & ! bdy_mask + ,MemoryOrder & ! MemoryOrder + ,Stagger & ! Stagger + ,dimnames & ! JMMOD 1109 + ,domain_start & ! DomainStart + ,domain_end & ! DomainEnd + ,memory_start & ! MemoryStart + ,memory_end & ! MemoryEnd + ,patch_start & ! PatchStart + ,patch_end & ! PatchEnd + ,Status ) + IF ( wrf_at_debug_level(300) ) THEN + WRITE(wrf_err_message,*) debug_message,' Status = ',Status + CALL wrf_message ( TRIM(wrf_err_message) ) + ENDIF + + END SUBROUTINE wrf_ext_read_field + diff --git a/wrfv2_fire/share/wrf_ext_write_field.F b/wrfv2_fire/share/wrf_ext_write_field.F new file mode 100644 index 00000000..9e077378 --- /dev/null +++ b/wrfv2_fire/share/wrf_ext_write_field.F @@ -0,0 +1,190 @@ +!WRF:MEDIATION:IO + SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & + DomainDesc, & + bdy_mask , & + dryrun , & + MemoryOrder, & + Stagger, & + Dimname1, Dimname2, Dimname3 , & + Desc, Units, & + debug_message , & + ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, Status ) + USE module_io + USE module_wrf_error + USE module_state_description + USE module_timing + IMPLICIT NONE + + INTEGER itrace + integer :: DataHandle + character*(*) :: DateStr + character*(*) :: Var + integer :: Field(*) + integer :: FieldType + integer :: Comm + integer :: IOComm + integer :: DomainDesc + logical :: dryrun + character*(*) :: MemoryOrder + logical, dimension(4) :: bdy_mask + character*(*) :: Stagger + character*(*) :: Dimname1, Dimname2, Dimname3 + character*(*) :: Desc, Units + character*(*) :: debug_message + + INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3 + + + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*80 , DIMENSION(3) :: dimnames + + integer ,intent(inout) :: Status + LOGICAL for_out, horiz_stagger + INTEGER Hndl, io_form + LOGICAL, EXTERNAL :: has_char + + IF ( wrf_at_debug_level( 500 ) ) THEN + call start_timing + ENDIF + domain_start(1) = ds1 ; domain_end(1) = de1 ; + patch_start(1) = ps1 ; patch_end(1) = pe1 ; + memory_start(1) = ms1 ; memory_end(1) = me1 ; + domain_start(2) = ds2 ; domain_end(2) = de2 ; + patch_start(2) = ps2 ; patch_end(2) = pe2 ; + memory_start(2) = ms2 ; memory_end(2) = me2 ; + domain_start(3) = ds3 ; domain_end(3) = de3 ; + patch_start(3) = ps3 ; patch_end(3) = pe3 ; + memory_start(3) = ms3 ; memory_end(3) = me3 ; + + dimnames(1) = Dimname1 + dimnames(2) = Dimname2 + dimnames(3) = Dimname3 + + CALL debug_io_wrf ( debug_message,DateStr, & + domain_start,domain_end,patch_start,patch_end, & + memory_start,memory_end ) + Status = 1 + if ( de1 - ds1 < 0 ) return + if ( de2 - ds2 < 0 ) return + if ( de3 - ds3 < 0 ) return + if ( pe1 - ps1 < 0 ) return + if ( pe2 - ps2 < 0 ) return + if ( pe3 - ps3 < 0 ) return + if ( me1 - ms1 < 0 ) return + if ( me2 - ms2 < 0 ) return + if ( me3 - ms3 < 0 ) return + Status = 0 + + + CALL wrf_write_field ( & + DataHandle & ! DataHandle + ,DateStr & ! DateStr + ,Var & ! Data Name + ,Field & ! Field + ,FieldType & ! FieldType + ,Comm & ! Comm + ,IOComm & ! IOComm + ,DomainDesc & ! DomainDesc + ,bdy_mask & ! bdy_mask + ,MemoryOrder & ! MemoryOrder + ,Stagger & ! JMMODS 010620 + ,dimnames & ! JMMODS 001109 + ,domain_start & ! DomainStart + ,domain_end & ! DomainEnd + ,memory_start & ! MemoryStart + ,memory_end & ! MemoryEnd + ,patch_start & ! PatchStart + ,patch_end & ! PatchEnd + ,Status ) + + CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + + IF ( ( dryrun .AND. ( io_form .EQ. IO_NETCDF .OR. io_form .EQ. IO_PNETCDF ) ) .OR. & + ( io_form .EQ. IO_PHDF5 ) ) THEN + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"description" & ! Element + ,Var & ! Data Name + ,Desc & ! Data + ,Status ) + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"units" & ! Element + ,Var & ! Data Name + ,Units & ! Data + ,Status ) + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"stagger" & ! Element + ,Var & ! Data Name + ,Stagger & ! Data + ,Status ) +#if (EM_CORE == 1) +! TBH: Added "coordinates" metadata for GIS folks in RAL. It is a step +! TBH: towards CF. This change was requested by Jennifer Boehnert based +! TBH: upon a suggestion from Nawajish Noman. +! TBH: TODO: This code depends upon longitude and latitude arrays being +! TBH: named "XLONG", "XLAT", "XLONG_U", "XLAT_U", "XLONG_V", and +! TBH: "XLAT_V" for EM_CORE. We need a more general way to handle +! TBH: this, possibly via the Registry. +! TBH: TODO: Leave this on all the time or make it namelist-selectable? +! TBH: TODO: Use dimnames(*) == south_north || west_east instead of +! TBH: MemoryOrder and Stagger? It would also work for both ARW +! TBH: and NMM and be easier to handle via Registry... +! IF ( ( ( MemoryOrder(1:2) == 'XY' ) .OR. & +! ( MemoryOrder(1:3) == 'XZY' ) ) .AND. & +! ( Var(1:5) /= 'XLONG' ) .AND. & +! ( Var(1:4) /= 'XLAT' ) ) THEN +! JM used trim instead, to avoid spurious errors when bounds checking on + IF ( ( ( TRIM(MemoryOrder) == 'XY' ) .OR. & + ( TRIM(MemoryOrder) == 'XZY' ) ) .AND. & + ( TRIM(Var) /= 'XLONG' ) .AND. & + ( TRIM(Var) /= 'XLAT' ) ) THEN + horiz_stagger = .FALSE. + IF ( LEN_TRIM(Stagger) == 1 ) THEN + IF ( has_char( Stagger, 'x' ) ) THEN + horiz_stagger = .TRUE. + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG_U XLAT_U" & ! Data + ,Status ) + ELSE IF ( has_char( Stagger, 'y' ) ) THEN + horiz_stagger = .TRUE. + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG_V XLAT_V" & ! Data + ,Status ) + ENDIF + ENDIF + IF ( .NOT. horiz_stagger ) THEN + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG XLAT" & ! Data + ,Status ) + ENDIF + ENDIF +#endif + ENDIF + + IF ( wrf_at_debug_level(300) ) THEN + WRITE(wrf_err_message,*) debug_message,' Status = ',Status + CALL wrf_message ( TRIM(wrf_err_message) ) + ENDIF + + IF ( wrf_at_debug_level( 500 ) ) THEN + CALL end_timing('wrf_ext_write_field') + ENDIF + + END SUBROUTINE wrf_ext_write_field diff --git a/wrfv2_fire/share/wrf_fddaobs_in.F b/wrfv2_fire/share/wrf_fddaobs_in.F new file mode 100644 index 00000000..066390eb --- /dev/null +++ b/wrfv2_fire/share/wrf_fddaobs_in.F @@ -0,0 +1,1685 @@ +!WRF:MEDIATION_LAYER:IO +! --- + +! This obs-nudging FDDA module (RTFDDA) is developed by the +! NCAR/RAL/NSAP (National Security Application Programs), under the +! sponsorship of ATEC (Army Test and Evaluation Commands). ATEC is +! acknowledged for releasing this capability for WRF community +! research applications. +! +! The NCAR/RAL RTFDDA module was adapted, and significantly modified +! from the obs-nudging module in the standard MM5V3.1 which was originally +! developed by PSU (Stauffer and Seaman, 1994). +! +! Yubao Liu (NCAR/RAL): lead developer of the RTFDDA module +! Al Bourgeois (NCAR/RAL): lead engineer implementing RTFDDA into WRF-ARW +! Nov. 2006 +! +! References: +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and J. Hacker, 2005: An +! implementation of obs-nudging-based FDDA into WRF for supporting +! ATEC test operations. 2005 WRF user workshop. Paper 10.7. +! +! Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and W. Yu, 2006: An update +! on "obs-nudging"-based FDDA for WRF-ARW: Verification using OSSE +! and performance of real-time forecasts. 2006 WRF user workshop. Paper 4.7. + +! +! Stauffer, D.R., and N.L. Seaman, 1994: Multi-scale four-dimensional data +! assimilation. J. Appl. Meteor., 33, 416-434. +! +! http://www.rap.ucar.edu/projects/armyrange/references.html +! + + SUBROUTINE wrf_fddaobs_in (grid ,config_flags) + + USE module_domain + USE module_configure + USE module_model_constants !rovg + + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags +#if ( EM_CORE == 1 ) + +! Local variables + integer :: ktau ! timestep index corresponding to xtime + integer :: krest ! restart timestep + integer :: inest ! nest level + integer :: infreq ! input frequency + integer :: nstlev ! nest level + real :: dtmin ! dt in minutes + real :: xtime ! forecast time in minutes + logical :: iprt_in4dob ! print flag + + +! Modified to also call in4dob intially, since subr in4dob is no +! longer called from subr fddaobs_init. Note that itimestep is now +! the model step BEFORE the model integration step, because this +! routine is now called by med_before_solve_io. + ktau = grid%itimestep ! ktau corresponds to xtime + krest = grid%fdob%ktaur + inest = grid%grid_id + nstlev = grid%fdob%levidn(inest) + infreq = grid%obs_ionf*(grid%parent_grid_ratio**nstlev) + iprt_in4dob = grid%obs_ipf_in4dob + + IF( (ktau.GT.krest.AND.MOD(ktau,infreq).EQ.0) & + .OR.(ktau.EQ.krest) ) then +! Calculate forecast time. + dtmin = grid%dt/60. + xtime = dtmin*grid%itimestep + + CALL in4dob(inest, xtime, ktau, krest, dtmin, grid%julday, grid%gmt, & + grid%obs_nudge_opt, grid%obs_nudge_wind, grid%obs_nudge_temp, & + grid%obs_nudge_mois, grid%obs_nudge_pstr, grid%obs_coef_wind, & + grid%obs_coef_temp, grid%obs_coef_mois, grid%obs_coef_pstr, & + grid%obs_rinxy, grid%obs_rinsig, grid%obs_twindo, & + grid%obs_npfi, grid%obs_ionf, grid%obs_idynin, & + grid%obs_dtramp, grid%fdob, grid%fdob%varobs, & + grid%fdob%timeob, grid%fdob%nlevs_ob, grid%fdob%lev_in_ob, & + grid%fdob%plfo, grid%fdob%elevob, grid%fdob%rio, & + grid%fdob%rjo, grid%fdob%rko, & + model_config_rec%cen_lat(1), & + model_config_rec%cen_lon(1), & + config_flags%truelat1, config_flags%truelat2, & + rovg, grid%fdob%xn, grid%fdob%ds_cg, t0, & + grid%fdob%sn_maxcg, grid%fdob%we_maxcg, config_flags%map_proj, & + model_config_rec%parent_grid_ratio, & + model_config_rec%i_parent_start(inest), & + model_config_rec%j_parent_start(inest), & + model_config_rec%nobs_ndg_vars, grid%max_obs, iprt_in4dob) + ENDIF + + RETURN +#endif + END SUBROUTINE wrf_fddaobs_in +#if ( EM_CORE == 1 ) +!------------------------------------------------------------------------------ +! Begin subroutine in4dob and its subroutines +!------------------------------------------------------------------------------ + SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, julday, gmt, & + nudge_opt, iswind, istemp, & + ismois, ispstr, giv, & + git, giq, gip, & + rinxy, rinsig, twindo, & + npfi, ionf, idynin, & + dtramp, fdob, varobs, & + timeob, nlevs_ob, lev_in_ob, & + plfo, elevob, rio, & + rjo, rko, & + xlatc_cg, & + xlonc_cg, & + true_lat1, true_lat2, & + rovg, xn, dscg, t0, & + sn_maxcg, we_maxcg, map_proj, & + parent_grid_ratio, & + i_parent_start, & + j_parent_start, & + nndgv, niobf, iprt) + + USE module_domain + USE module_model_constants, ONLY : rcp + IMPLICIT NONE + +! THIS IS SUBROUTINE READS AN OBSERVATION DATA FILE AND +! SELECTS ONLY THOSE VALUES OBSERVED AT TIMES THAT FALL +! WITHIN A TIME WINDOW (TWINDO) CENTERED ABOUT THE CURRENT +! FORECAST TIME (XTIME). THE INCOMING OBS FILES MUST BE +! IN CHRONOLOGICAL ORDER. +! +! NOTE: This routine was originally designed for MM5, which uses +! a nonstandard (I,J) coordinate system. For WRF, I is the +! east-west running coordinate, and J is the south-north +! running coordinate. So "J-slab" here is west-east in +! extent, not south-north as for MM5. RIO and RJO have +! the opposite orientation here as for MM5. -ajb 06/10/2004 + +! NOTE - IN4DOB IS CALLED ONLY FOR THE COARSE MESH TIMES IN4DOB.10 +! - VAROBS(IVAR,N) HOLDS THE OBSERVATIONS. IN4DOB.11 +! IVAR=1 UOBS IN4DOB.12 +! IVAR=2 VOBS IN4DOB.13 +! IVAR=3 TOBS IN4DOB.14 +! IVAR=4 QOBS IN4DOB.15 +! IVAR=5 PSOBS (CROSS) IN4DOB.16 + + INTEGER, intent(in) :: niobf ! maximum number of observations + INTEGER, intent(in) :: nndgv ! number of nudge variables + INTEGER, intent(in) :: INEST ! nest level + REAL, intent(in) :: xtime ! model time in minutes + INTEGER, intent(in) :: KTAU ! current timestep + INTEGER, intent(in) :: KTAUR ! restart timestep + REAL, intent(in) :: dtmin ! dt in minutes + INTEGER, intent(in) :: julday ! Julian day + REAL, intent(in) :: gmt ! Greenwich Mean Time + INTEGER, intent(in) :: nudge_opt ! obs-nudge flag for this nest + INTEGER, intent(in) :: iswind ! nudge flag for wind + INTEGER, intent(in) :: istemp ! nudge flag for temperature + INTEGER, intent(in) :: ismois ! nudge flag for moisture + INTEGER, intent(in) :: ispstr ! nudge flag for pressure + REAL, intent(in) :: giv ! coefficient for wind + REAL, intent(in) :: git ! coefficient for temperature + REAL, intent(in) :: giq ! coefficient for moisture + REAL, intent(in) :: gip ! coefficient for pressure + REAL, intent(in) :: rinxy ! horizontal radius of influence (km) + REAL, intent(in) :: rinsig ! vertical radius of influence (on sigma) + REAL, intent(in) :: twindo ! (time window)/2 (min) for nudging + INTEGER, intent(in) :: npfi ! coarse-grid time-step frequency for diagnostics + INTEGER, intent(in) :: ionf ! coarse-grid time-step frequency for obs-nudging calcs + INTEGER, intent(in) :: idynin ! for dynamic initialization using a ramp-down function + REAL, intent(in) :: dtramp ! time period in minutes for ramping + TYPE(fdob_type), intent(inout) :: fdob ! derived data type for obs data + REAL, intent(inout) :: varobs(nndgv,niobf) ! observational values in each variable + REAL, intent(inout) :: timeob(niobf) ! model times for each observation (hours) + REAL, intent(inout) :: nlevs_ob(niobf) ! numbers of levels in sounding obs + REAL, intent(inout) :: lev_in_ob(niobf) ! level in sounding-type obs + REAL, intent(inout) :: plfo(niobf) ! index for type of obs-platform + REAL, intent(inout) :: elevob(niobf) ! elevations of observations (meters) + REAL, intent(inout) :: rio(niobf) ! west-east grid coordinate + REAL, intent(inout) :: rjo(niobf) ! south-north grid coordinate + REAL, intent(inout) :: rko(niobf) ! vertical grid coordinate + REAL, intent(in) :: xlatc_cg ! coarse grid center latitude + REAL, intent(in) :: xlonc_cg ! coarse grid center longiture + REAL, intent(in) :: true_lat1 ! truelat1 for Lambert map projection + REAL, intent(in) :: true_lat2 ! truelat2 for Lambert map projection + REAL, intent(in) :: rovg ! constant rho over g + REAL, intent(in) :: xn ! cone factor for Lambert projection + REAL, intent(in) :: dscg ! coarse grid size (km) + REAL, intent(in) :: t0 ! background temperature + INTEGER, intent(in) :: sn_maxcg ! maximum coarse grid south-north coordinate + INTEGER, intent(in) :: we_maxcg ! maximum coarse grid west-east coordinate + INTEGER, intent(in) :: map_proj ! map projection index + INTEGER, intent(in) :: parent_grid_ratio ! parent to nest grid ration + INTEGER, intent(in) :: i_parent_start ! starting i coordinate in parent domain + INTEGER, intent(in) :: j_parent_start ! starting j coordinate in parent domain + LOGICAL, intent(in) :: iprt ! print flag + +!*** DECLARATIONS FOR IMPLICIT NONE + integer :: n, nsta, ndum, nopen, nlast, nvol, idate, imm, iss + integer :: meas_count, imc, njend, njc, njcc, julob + real :: hourob, rjulob + real :: xhour, tback, tforwd, rjdate1, timanl1, rtimob + real :: rj, ri, elevation, pressure_data + real :: pressure_qc, height_data, height_qc, temperature_data + real :: temperature_qc, u_met_data, u_met_qc, v_met_data + real :: v_met_qc, rh_data, rh_qc, r_data, slp_data, slp_qc + real :: ref_pres_data, ref_pres_qc, psfc_data, psfc_qc + real :: precip_data, precip_qc, tbar, twdop + real*8 :: tempob + +! Local variables + character*14 date_char + character*40 platform,source,id,namef + character*2 fonc + real latitude,longitude + logical is_sound,bogus + LOGICAL OPENED,exist + integer :: ieof(5),ifon(5) + data ieof/0,0,0,0,0/ + data ifon/0,0,0,0,0/ + integer :: nmove, nvola + DATA NMOVE/0/,NVOLA/61/ + + if(ieof(inest).eq.2.and.fdob%nstat.eq.0)then + IF (iprt) print *,'returning from in4dob' + return + endif + IF (iprt) print *,'start in4dob ',inest,xtime + IF(nudge_opt.NE.1)RETURN + +! if start time, or restart time, set obs array to missing value + IF(KTAU.EQ.0.OR.KTAU.EQ.KTAUR) THEN + DO N=1,NIOBF + TIMEOB(N)=99999. + ENDDO + ENDIF +! set number of obs=0 if at start or restart + IF(KTAU.EQ.KTAUR)fdob%NSTAT=0 + NSTA=fdob%NSTAT + fdob%WINDOW=TWINDO + XHOUR=(XTIME-DTMIN)/60. + XHOUR=AMAX1(XHOUR,0.0) + +10 CONTINUE + +! DEFINE THE MAX LIMITS OF THE WINDOW + TBACK=XHOUR-fdob%WINDOW + TFORWD=XHOUR+fdob%WINDOW + + if (iprt) write(6,*) 'TBACK = ',tback,' TFORWD = ',tforwd + + IF(NSTA.NE.0) THEN + NDUM=0 + t_window : DO N=1,NSTA+1 + IF((TIMEOB(N)-TBACK).LT.0) THEN + TIMEOB(N)=99999. + ENDIF + IF(TIMEOB(N).LT.9.E4) EXIT t_window + NDUM=N + ENDDO t_window + +! REMOVE OLD OBS DENOTED BY 99999. AT THE FRONT OF TIMEOB ARRAY + IF (iprt) print *,'ndum at 20=',ndum + NDUM=ABS(NDUM) + NMOVE=NIOBF-NDUM + IF(NMOVE.GT.0 .AND. NDUM.NE.0 ) THEN + DO N=1,NMOVE + VAROBS(1,N)=VAROBS(1,N+NDUM) + VAROBS(2,N)=VAROBS(2,N+NDUM) + VAROBS(3,N)=VAROBS(3,N+NDUM) + VAROBS(4,N)=VAROBS(4,N+NDUM) + VAROBS(5,N)=VAROBS(5,N+NDUM) +! RIO is the west-east coordinate. RJO is south-north. (ajb) + RJO(N)=RJO(N+NDUM) + RIO(N)=RIO(N+NDUM) + RKO(N)=RKO(N+NDUM) + TIMEOB(N)=TIMEOB(N+NDUM) + nlevs_ob(n)=nlevs_ob(n+ndum) + lev_in_ob(n)=lev_in_ob(n+ndum) + plfo(n)=plfo(n+ndum) + elevob(n)=elevob(n+ndum) + ENDDO + ENDIF + NOPEN=NMOVE+1 + IF(NOPEN.LE.NIOBF) THEN + DO N=NOPEN,NIOBF + VAROBS(1,N)=99999. + VAROBS(2,N)=99999. + VAROBS(3,N)=99999. + VAROBS(4,N)=99999. + VAROBS(5,N)=99999. + RIO(N)=99999. + RJO(N)=99999. + RKO(N)=99999. + TIMEOB(N)=99999. + nlevs_ob(n)=99999. + lev_in_ob(n)=99999. + plfo(n)=99999. + elevob(n)=99999. + ENDDO + ENDIF + ENDIF + +! print *,'in4dob, after setting RIO, RJO: nsta = ',nsta + +! FIND THE LAST OBS IN THE LIST + NLAST=0 + last_ob : DO N=1,NIOBF +! print *,'nlast,n,timeob(n)=',nlast,n,timeob(n) + IF(TIMEOB(N).GT.9.E4) EXIT last_ob + NLAST=N + ENDDO last_ob + +! print *,'in4dob, after 90 ',nlast,ktau,ktaur,nsta +! open file if at beginning or restart + IF(KTAU.EQ.0.OR.KTAU.EQ.KTAUR) THEN + fdob%RTLAST=-999. + INQUIRE (NVOLA+INEST-1,OPENED=OPENED) + IF (.NOT. OPENED) THEN + ifon(inest)=1 + write(fonc(1:2),'(i2)')ifon(inest) + if(fonc(1:1).eq.' ')fonc(1:1)='0' + INQUIRE (file='OBS_DOMAIN'//CHAR(INEST+ICHAR('0'))//fonc(1:2) & + ,EXIST=exist) + if(exist)then + IF (iprt) THEN + print *,'opening first fdda obs file, fonc=', & + fonc,' inest=',inest + print *,'ifon=',ifon(inest) + ENDIF + OPEN(NVOLA+INEST-1, & + FILE='OBS_DOMAIN'//CHAR(INEST+ICHAR('0'))//fonc(1:2), & + FORM='FORMATTED',STATUS='OLD') + else +! no first file to open + IF (iprt) print *,'there are no fdda obs files to open' + return + endif + + ENDIF + ENDIF !end if(KTAU.EQ.0.OR.KTAU.EQ.KTAUR) +! print *,'at jc check1' + +!********************************************************************** +! -------------- BIG 100 LOOP OVER N -------------- +!********************************************************************** +! NOW CHECK TO SEE IF EXTRA DATA MUST BE READ IN FROM THE +! DATA FILE. CONTINUE READING UNTIL THE REACHING THE EOF +! (DATA TIME IS NEGATIVE) OR FIRST TIME PAST TFORWD. THE +! LAST OBS CURRENTLY AVAILABLE IS IN N=NMOVE. + N=NLAST + IF(N.EQ.0)GOTO 110 + + 1001 continue + +! ieof=2 means no more files +! print *,'after 1001,n,timeob(n)=',n,timeob(n) + + IF(IEOF(inest).GT.1) then + GOTO 130 + endif + +100 CONTINUE +!ajb 20070116 bugfix for situation that first obs is not in the domain + IF(N.ne.0) THEN + IF(TIMEOB(N).GT.TFORWD.and.timeob(n).lt.99999.) THEN + GOTO 130 + ENDIF + ENDIF + +! OBSFILE: no more data in the obsfile + if(ieof(inest).eq.1 )then + ieof(inest)=2 + goto 130 + endif + +!********************************************************************** +! -------------- 110 SUBLOOP OVER N -------------- +!********************************************************************** +! THE TIME OF THE MOST RECENTLY ACQUIRED OBS IS .LE. TFORWD, +! SO CONTINUE READING + 110 continue + IF(N.GT.NIOBF-1)GOTO 120 +! REPLACE NVOLA WITH LUN 70, AND USE NVOLA AS A FILE COUNTER + NVOL=NVOLA+INEST-1 + IF(fdob%IEODI.EQ.1)GOTO 111 + read(nvol,101,end=111,err=111)date_char + 101 FORMAT(1x,a14) + + n=n+1 + + read(date_char(3:10),'(i8)')idate + read(date_char(11:12),'(i2)')imm + read(date_char(13:14),'(i2)')iss +! output is rjdate (jjjhh.) and timanl (time in minutes since model start) + call julgmt(idate,rjdate1,timanl1,julday,gmt,0) + rtimob=rjdate1+real(imm)/60.+real(iss)/3600. + timeob(n)=rtimob + timeob(n) = int(timeob(n)*1000)/1000.0 + +! CONVERT TIMEOB FROM JULIAN DATE AND GMT FORM TO FORECAST +! TIME IN HOURS (EX. TIMEOB=13002.4 REPRESENTS JULDAY 130 +! AND GMT (HOUR) = 2.4) + JULOB=TIMEOB(N)/100.+0.000001 + RJULOB=FLOAT(JULOB)*100. + tempob = (timeob(n)*1000.) + tempob = int(tempob) + tempob = tempob/1000. + timeob(n) = tempob + HOUROB=TIMEOB(N)-RJULOB + TIMEOB(N)=FLOAT(JULOB-JULDAY)*24.-GMT+HOUROB + rtimob=timeob(n) + +! print *,'read in ob ',n,timeob(n),rtimob + IF(IDYNIN.EQ.1.AND.TIMEOB(N)*60..GT.fdob%DATEND) THEN + IF (iprt) THEN + PRINT*,' IN4DOB: FOR INEST = ',INEST,' AT XTIME = ',XTIME, & + ' TIMEOB = ',TIMEOB(N)*60.,' AND DATEND = ',fdob%DATEND,' :' + PRINT*,' END-OF-DATA FLAG SET FOR OBS-NUDGING', & + ' DYNAMIC INITIALIZATION' + ENDIF + fdob%IEODI=1 + TIMEOB(N)=99999. + rtimob=timeob(n) + ENDIF + read(nvol,102)latitude,longitude + 102 FORMAT(2x,2(f7.2,3x)) + +! if(ifon.eq.4)print *,'ifon=4',latitude,longitude +! this works only for lc projection +! yliu: add llxy for all 3 projection + +!ajb Arguments ri and rj have been switched from MM5 orientation. +! call llxy (latitude,longitude,rj,ri,xlatc,xlonc,map_proj, + call llxy (latitude,longitude,ri,rj,xlatc_cg,xlonc_cg,map_proj, & + true_lat1,true_lat2,dscg,xn,sn_maxcg,we_maxcg, & + 1,1,1) + +!ajb ri and rj are referenced to the non-staggered grid. (For MM5, they +! were referenced to the dot grid.) + + rio(n)=ri + rjo(n)=rj + + if (iprt) THEN + if(n.le.10) then + write(6,'(/,a,i5,a,f8.2,a,f8.2,a,f8.2,a,f8.2/)') & + ' OBS N = ',n, & + ' RIO = ',rio(n), & + ' RJO = ',rjo(n), & + ' LAT = ',latitude, & + ' LON = ',longitude + endif + endif + + read(nvol,1021)id,namef + 1021 FORMAT(2x,2(a40,3x)) + read(nvol,103)platform,source,elevation,is_sound,bogus,meas_count + 103 FORMAT( 2x,2(a16,2x),f8.0,2x,2(l4,2x),i5) + +! write(6,*) '----- OBS description ----- ' +! write(6,*) 'platform,source,elevation,is_sound,bogus,meas_count:' +! write(6,*) platform,source,elevation,is_sound,bogus,meas_count + +! yliu + elevob(n)=elevation +! jc +! change platform from synop to profiler when needed + if(namef(2:9).eq.'PROFILER')platform(7:14)='PROFILER' +! yliu + if(namef(2:6).eq.'ACARS')platform(7:11)='ACARS' + if(namef(1:7).eq.'SATWNDS') platform(1:11)='SATWNDS ' + if(namef(1:8).eq.'CLASS DA')platform(7:10)='TEMP' +! yliu end + + rko(n)=-99. +!yliu 20050706 +! if((platform(7:11).eq.'METAR').or.(platform(7:11).eq.'SPECI').or. +! 1 (platform(7:10).eq.'SHIP').or.(platform(7:11).eq.'SYNOP').or. +! 1 (platform(1:4).eq.'SAMS')) +! 1 rko(n)=1.0 + if(.NOT. is_sound) rko(n)=1.0 +!yliu 20050706 end + +! plfo is inFORMATion on what platform. May use this later in adjusting weights + plfo(n)=99. + if(platform(7:11).eq.'METAR')plfo(n)=1. + if(platform(7:11).eq.'SPECI')plfo(n)=2. + if(platform(7:10).eq.'SHIP')plfo(n)=3. + if(platform(7:11).eq.'SYNOP')plfo(n)=4. + if(platform(7:10).eq.'TEMP')plfo(n)=5. + if(platform(7:11).eq.'PILOT')plfo(n)=6. + if(platform(1:7).eq.'SATWNDS')plfo(n)=7. + if(platform(1:4).eq.'SAMS')plfo(n)=8. + if(platform(7:14).eq.'PROFILER')plfo(n)=9. +! yliu: ACARS->SATWINDS + if(platform(7:11).eq.'ACARS')plfo(n)=7. +! yliu: end + if(plfo(n).eq.99.) then + IF (iprt) print *,'n=',n,' unknown ob of type',platform + endif + +!====================================================================== +!====================================================================== +! THIS PART READS SOUNDING INFO + IF(is_sound)THEN + nlevs_ob(n)=real(meas_count) + lev_in_ob(n)=1. + do imc=1,meas_count +! write(6,*) '0 inest = ',inest,' n = ',n +! the sounding has one header, many levels. This part puts it into +! "individual" observations. There's no other way for nudob to deal +! with it. + if(imc.gt.1)then ! sub-loop over N + n=n+1 + if(n.gt.niobf)goto 120 + nlevs_ob(n)=real(meas_count) + lev_in_ob(n)=real(imc) + timeob(n)=rtimob + rio(n)=ri + rjo(n)=rj + rko(n)=-99. + plfo(n)=plfo(n-imc+1) + elevob(n)=elevation + endif + + read(nvol,104)pressure_data,pressure_qc, & + height_data,height_qc, & + temperature_data,temperature_qc, & + u_met_data,u_met_qc, & + v_met_data,v_met_qc, & + rh_data,rh_qc + 104 FORMAT( 1x,6(f11.3,1x,f11.3,1x)) + +! yliu: Ensemble - add disturbance to upr obs +! if(plfo(n).eq.5.or.plfo(n).eq.6.or.plfo(n).eq.9) then FORE07E08 +! if(imc.eq.1) then FORE07E08 +! call srand(n) +! t_rand =- (rand(2)-0.5)*6 +! call srand(n+100000) +! u_rand =- (rand(2)-0.5)*6 +! call srand(n+200000) +! v_rand =- (rand(2)-0.5)*6 +! endif FORE07E08 +! if(temperature_qc.ge.0..and.temperature_qc.lt.30000..and. +! & temperature_data .gt. -88880.0 ) +! & temperature_data = temperature_data + t_rand +! if((u_met_qc.ge.0..and.u_met_qc.lt.30000.).and. +! & (v_met_qc.ge.0..and.v_met_qc.lt.30000.).and. +! make sure at least 1 of the components is .ne.0 +! & (u_met_data.ne.0..or.v_met_data.ne.0.) .and. +! & (u_met_data.gt.-88880.0 .and. v_met_data.gt.-88880.0) )then +! u_met_data = u_met_data + u_rand +! v_met_data = v_met_data + v_rand +! endif +! endif FORE07E08 +! yliu: Ens test - end + + +! jc +! hardwire to switch -777777. qc to 0. here temporarily +! -777777. is a sounding level that no qc was done on. + + if(temperature_qc.eq.-777777.)temperature_qc=0. + if(pressure_qc.eq.-777777.)pressure_qc=0. + if(height_qc.eq.-777777.)height_qc=0. + if(u_met_qc.eq.-777777.)u_met_qc=0. + if(v_met_qc.eq.-777777.)v_met_qc=0. + if(rh_qc.eq.-777777.)rh_qc=0. + if(temperature_data.eq.-888888.)temperature_qc=-888888. + if(pressure_data.eq.-888888.)pressure_qc=-888888. + if(height_data.eq.-888888.)height_qc=-888888. + if(u_met_data.eq.-888888.)u_met_qc=-888888. + if(v_met_data.eq.-888888.)v_met_qc=-888888. + if(rh_data.eq.-888888.)rh_qc=-888888. + +! jc +! Hardwire so that only use winds in pilot obs (no winds from temp) and +! only use temperatures and rh in temp obs (no temps from pilot obs) +! Do this because temp and pilot are treated as 2 platforms, but pilot +! has most of the winds, and temp has most of the temps. If use both, +! the second will smooth the effect of the first. Usually temps come in after +! pilots. pilots usually don't have any temps, but temp obs do have some +! winds usually. +! plfo=5 is TEMP ob, range sounding is an exception +!yliu start -- comment out to test with merged PILOT and TEMP and +! do not use obs interpolated by little_r +! if(plfo(n).eq.5. .and. namef(1:8).ne.'CLASS DA')then +! u_met_data=-888888. +! v_met_data=-888888. +! u_met_qc=-888888. +! v_met_qc=-888888. +! endif + if(plfo(n).eq.5..and.(u_met_qc.eq.256..or.v_met_qc.eq.256.))then + u_met_data=-888888. + v_met_data=-888888. + u_met_qc=-888888. + v_met_qc=-888888. + endif +!yliu end +! plfo=6 is PILOT ob + if(plfo(n).eq.6.)then + temperature_data=-888888. + rh_data=-888888. + temperature_qc=-888888. + rh_qc=-888888. + endif + +!ajb Store potential temperature for WRF + if(temperature_qc.ge.0..and.temperature_qc.lt.30000.)then + + if(pressure_qc.ge.0..and.pressure_qc.lt.30000.)then + + varobs(3,n) = & + temperature_data*(100000./pressure_data)**RCP - t0 + +! write(6,*) 'reading data for N = ',n,' RCP = ',rcp +! write(6,*) 'temperature_data = ',temperature_data +! write(6,*) 'pressure_data = ',pressure_data +! write(6,*) 'varobs(3,n) = ',varobs(3,n) + + else + varobs(3,n)=-888888. + endif + + else + varobs(3,n)=-888888. + endif + + if(pressure_qc.ge.0..and.pressure_qc.lt.30000.)then +! if(pressure_qc.ge.0.)then + varobs(5,n)=pressure_data + else + varobs(5,n)=-888888. + IF (iprt) THEN + print *,'********** PROBLEM *************' + print *,'sounding, p undefined',latitude,longitude + ENDIF + endif + if(varobs(5,n).ge.0.)varobs(5,n)=varobs(5,n)*1.e-3 +! don't use data above 80 mb + if((varobs(5,n).gt.0.).and.(varobs(5,n).le.8.))then + u_met_data=-888888. + v_met_data=-888888. + u_met_qc=-888888. + v_met_qc=-888888. + temperature_data=-888888. + temperature_qc=-888888. + rh_data=-888888. + rh_qc=-888888. + endif + +! yliu: add special processing of NPN and Range profiler +! only little_r interpolated and QC-ed data is used + if(namef(2:9).eq."PROFILER") then + if((u_met_qc.ge.0..and.u_met_qc.lt.30000.).and. & + (v_met_qc.ge.0..and.v_met_qc.lt.30000.))then +!!yliu little_r already rotated the winds +! call vect(longitude,u_met_data,v_met_data,xlonc,xlatc,xn) + varobs(1,n)=u_met_data + varobs(2,n)=v_met_data + else + varobs(1,n)=-888888. + varobs(2,n)=-888888. + endif + else + if((u_met_qc.ge.0..and.u_met_qc.lt.30000.).and. & + (v_met_qc.ge.0..and.v_met_qc.lt.30000.))then +!!yliu little_r already rotated the winds +! call vect(longitude,u_met_data,v_met_data,xlonc,xlatc,xn) + varobs(1,n)=u_met_data + varobs(2,n)=v_met_data + else + varobs(1,n)=-888888. + varobs(2,n)=-888888. + endif + endif + r_data=-888888. + + if(rh_qc.ge.0..and.rh_qc.lt.30000.)then + if((pressure_qc.ge.0.).and.(temperature_qc.ge.0.).and. & + (pressure_qc.lt.30000.).and.(temperature_qc.lt.30000.))then + call rh2r(rh_data,temperature_data,pressure_data*.01, & + r_data,0) ! yliu, change last arg from 1 to 0 + else +! print *,'rh, but no t or p to convert',temperature_qc, & +! pressure_qc,n + r_data=-888888. + endif + endif + varobs(4,n)=r_data + enddo ! end do imc=1,meas_count +! print *,'--- sdng n=',n,nlevs_ob(n),lev_in_ob(n),timeob(n) +! read in non-sounding obs + + ELSEIF(.NOT.is_sound)THEN + nlevs_ob(n)=1. + lev_in_ob(n)=1. + read(nvol,105)slp_data,slp_qc, & + ref_pres_data,ref_pres_qc, & + height_data,height_qc, & + temperature_data,temperature_qc, & + u_met_data,u_met_qc, & + v_met_data,v_met_qc, & + rh_data,rh_qc, & + psfc_data,psfc_qc, & + precip_data,precip_qc + 105 FORMAT( 1x,9(f11.3,1x,f11.3,1x)) + +! Ensemble: add disturbance to sfc obs +! call srand(n) +! t_rand =+ (rand(2)-0.5)*5 +! call srand(n+100000) +! u_rand =+ (rand(2)-0.5)*5 +! call srand(n+200000) +! v_rand =+ (rand(2)-0.5)*5 +! if(temperature_qc.ge.0..and.temperature_qc.lt.30000. .and. +! & temperature_data .gt. -88880.0 ) +! & temperature_data = temperature_data + t_rand +! if((u_met_qc.ge.0..and.u_met_qc.lt.30000.).and. +! & (v_met_qc.ge.0..and.v_met_qc.lt.30000.).and. +! make sure at least 1 of the components is .ne.0 +! & (u_met_data.ne.0..or.v_met_data.ne.0.) .and. +! & (u_met_data.gt.-88880.0 .and. v_met_data.gt.-88880.0) )then +! u_met_data = u_met_data + u_rand +! v_met_data = v_met_data + v_rand +! endif +! yliu: Ens test - end + +!ajb Store potential temperature for WRF + if(temperature_qc.ge.0..and.temperature_qc.lt.30000.)then + + if((psfc_qc.ge.0..and.psfc_qc.lt.30000.).and. & + (psfc_data.gt.70000. .and.psfc_data.lt.105000.))then + + varobs(3,n) = & + temperature_data*(100000./psfc_data)**RCP - t0 + else + varobs(3,n)=-888888. + endif + else + varobs(3,n)=-888888. + endif + + if((psfc_qc.ge.0..and.psfc_qc.lt.30000.).and.(psfc_data.gt.70000. & + .and.psfc_data.lt.105000.))then + varobs(5,n)=psfc_data + else + varobs(5,n)=-888888. + endif + if(varobs(5,n).ge.0.)varobs(5,n)=varobs(5,n)*1.e-3 + + if((u_met_qc.ge.0..and.u_met_qc.lt.30000.).and. & + (v_met_qc.ge.0..and.v_met_qc.lt.30000.).and. & +! make sure at least 1 of the components is .ne.0 + (u_met_data.ne.0..or.v_met_data.ne.0.))then +!!yliu little_r already rotated the winds +!!yliu call vect(longitude,u_met_data,v_met_data,xlonc,xlatc,xn) + varobs(1,n)=u_met_data + varobs(2,n)=v_met_data + else + varobs(1,n)=-888888. + varobs(2,n)=-888888. + endif +! calculate psfc if slp is there + if((psfc_qc.lt.0.).and.(slp_qc.ge.0..and.slp_qc.lt.30000.).and. & + (temperature_qc.ge.0..and.temperature_qc.lt.30000.).and. & + (slp_data.gt.90000.))then + tbar=temperature_data+0.5*elevation*.0065 + psfc_data=slp_data*exp(-elevation/(rovg*tbar)) + varobs(5,n)=psfc_data*1.e-3 + psfc_qc=0. + endif + +!c *No* **Very rough** estimate of psfc from sfc elevation if UUtah ob and elev>1000m +! estimate psfc from temp and elevation +! Do not know sfc pressure in model at this point. +! if((psfc_qc.lt.0.).and.(elevation.gt.1000.).and. +! 1 (temperature_qc.ge.0..and.temperature_qc.lt.30000.) +! 1 .and.(platform(7:16).eq.'SYNOP PRET'))then + if((psfc_qc.lt.0.).and. & + (temperature_qc.ge.0..and.temperature_qc.lt.30000.))then + tbar=temperature_data+0.5*elevation*.0065 + psfc_data=100000.*exp(-elevation/(rovg*tbar)) + varobs(5,n)=psfc_data*1.e-3 + psfc_qc=0. + endif +! jc +! if a ship ob has rh<70%, then throw out + if(plfo(n).eq.3..and.rh_qc.ge.0..and.rh_data.lt.70.)then + rh_qc=-888888. + rh_data=-888888. + endif +! + r_data=-888888. + if(rh_qc.ge.0..and.rh_qc.lt.30000.)then + if((psfc_qc.ge.0..and.psfc_qc.lt.30000.) & + .and.(temperature_qc.ge.0..and.temperature_qc.lt.30000.))then +! rh_data=amin1(rh_data,96.) ! yliu: do not allow surface to be saturated + call rh2r(rh_data,temperature_data,psfc_data*.01, & + r_data,0) ! yliu, change last arg from 1 to 0 + else +! print *,'rh, but no t or p',temperature_data, +! 1 psfc_data,n + r_data=-888888. + endif + endif + varobs(4,n)=r_data + ELSE + IF (iprt) THEN + print *,' ====== ' + print *,' NO Data Found ' + ENDIF + ENDIF !end if(is_sound) +! END OF SFC OBS INPUT SECTION +!====================================================================== +!====================================================================== +! check if ob time is too early (only applies to beginning) + IF(RTIMOB.LT.TBACK-fdob%WINDOW)then + IF (iprt) print *,'ob too early' + n=n-1 + GOTO 110 + ENDIF + +! check if this ob is a duplicate +! this check has to be before other checks + njend=n-1 + if(is_sound)njend=n-meas_count + do njc=1,njend +! Check that time, lat, lon, and platform all match exactly. +! Platforms 1-4 (surface obs) can match with each other. Otherwise, +! platforms have to match exactly. + if( (timeob(n).eq.timeob(njc)) .and. & + (rio(n).eq.rio(njc)) .and. & + (rjo(n).eq.rjo(njc)) .and. & + (plfo(njc).ne.99.) ) then +!yliu: if two sfc obs are departed less than 1km, consider they are redundant +! (abs(rio(n)-rio(njc))*dscg.gt.1000.) & +! .or. (abs(rjo(n)-rjo(njc))*dscg.gt.1000.) & +! .or. (plfo(njc).eq.99.) )goto 801 +!yliu end +! If platforms different, and either > 4, jump out + if( ( (plfo(n).le.4.).and.(plfo(njc).le.4.) ) .or. & + (plfo(n).eq.plfo(njc)) ) then + +! if not a sounding, and levels are the same then replace first occurrence + if((.not.is_sound).and.(rko(njc).eq.rko(n))) then +! print *,'dup single ob-replace ',n,inest, +! plfo(n),plfo(njc) +! this is the sfc ob replacement part + VAROBS(1,njc)=VAROBS(1,n) + VAROBS(2,njc)=VAROBS(2,n) + VAROBS(3,njc)=VAROBS(3,n) + VAROBS(4,njc)=VAROBS(4,n) + VAROBS(5,njc)=VAROBS(5,n) +! don't need to switch these because they're the same +! RIO(njc)=RIO(n) +! RJO(njc)=RJO(n) +! RKO(njc)=RKO(n) +! TIMEOB(njc)=TIMEOB(n) +! nlevs_ob(njc)=nlevs_ob(n) +! lev_in_ob(njc)=lev_in_ob(n) +! plfo(njc)=plfo(n) +! end sfc ob replacement part + + n=n-1 + goto 100 +! It's harder to fix the soundings, since the number of levels may be different +! The easiest thing to do is to just set the first occurrence to all missing, and +! keep the second occurrence, or vice versa. +! For temp or profiler keep the second, for pilot keep the one with more levs +! This is for a temp or prof sounding, equal to same +! also if a pilot, but second one has more obs + elseif( (is_sound).and.(plfo(njc).eq.plfo(n)) .and. & + ( (plfo(njc).eq.5.).or.(plfo(njc).eq.9.).or. & + ( (plfo(njc).eq.6.).and. & + (nlevs_ob(n).ge.nlevs_ob(njc)) ) ) )then + IF (iprt) THEN + print *,'duplicate sounding - eliminate first occurrence', & + n,inest,meas_count,nlevs_ob(njc), & + latitude,longitude,plfo(njc) + ENDIF + if(lev_in_ob(njc).ne.1.) then + IF (iprt) THEN + print *, 'problem ******* - dup sndg ', & + lev_in_ob(njc),nlevs_ob(njc) + ENDIF + endif +! n=n-meas_count +! set the first sounding ob to missing + do njcc=njc,njc+nint(nlevs_ob(njc))-1 + VAROBS(1,njcc)=-888888. + VAROBS(2,njcc)=-888888. + VAROBS(3,njcc)=-888888. + VAROBS(4,njcc)=-888888. + VAROBS(5,njcc)=-888888. + plfo(njcc)=99. + enddo + goto 100 +! if a pilot, but first one has more obs + elseif( (is_sound).and.(plfo(njc).eq.plfo(n)) .and. & + (plfo(njc).eq.6.).and. & + (nlevs_ob(n).lt.nlevs_ob(njc)) )then + IF (iprt) THEN + print *, & + 'duplicate pilot sounding - eliminate second occurrence', & + n,inest,meas_count,nlevs_ob(njc), & + latitude,longitude,plfo(njc) + ENDIF + if(lev_in_ob(njc).ne.1.) then + IF (iprt) THEN + print *, 'problem ******* - dup sndg ', & + lev_in_ob(njc),nlevs_ob(njc) + ENDIF + endif + n=n-meas_count + +!ajb Reset timeob for discarded indices. + do imc = n+1, n+meas_count + timeob(imc) = 99999. + enddo + goto 100 +! This is for a single-level satellite upper air ob - replace first + elseif( (is_sound).and. & + (nlevs_ob(njc).eq.1.).and. & + (nlevs_ob(n).eq.1.).and. & + (varobs(5,njc).eq.varobs(5,n)).and. & + (plfo(njc).eq.7.).and.(plfo(n).eq.7.) ) then + IF (iprt) print *, & + 'duplicate single lev sat-wind ob - replace first',n, & + inest,meas_count,varobs(5,n) +! this is the single ua ob replacement part + VAROBS(1,njc)=VAROBS(1,n) + VAROBS(2,njc)=VAROBS(2,n) + VAROBS(3,njc)=VAROBS(3,n) + VAROBS(4,njc)=VAROBS(4,n) + VAROBS(5,njc)=VAROBS(5,n) +! don't need to switch these because they're the same +! RIO(njc)=RIO(n) +! RJO(njc)=RJO(n) +! RKO(njc)=RKO(n) +! TIMEOB(njc)=TIMEOB(n) +! nlevs_ob(njc)=nlevs_ob(n) +! lev_in_ob(njc)=lev_in_ob(n) +! plfo(njc)=plfo(n) +! end single ua ob replacement part + n=n-1 + goto 100 + else + IF (iprt) THEN + print *,'duplicate location, but no match otherwise',n,njc, & + plfo(n),varobs(5,n),nlevs_ob(n),lev_in_ob(n), & + plfo(njc),varobs(5,njc),nlevs_ob(njc),lev_in_ob(njc) + ENDIF + endif + endif + endif +! end of njc do loop + enddo + +! check if ob is a sams ob that came in via UUtah - discard + if( plfo(n).eq.4..and.(platform(7:16).eq.'SYNOP PRET').and. & + (id(7:15).eq.'METNET= 3') )then +! print *,'elim metnet=3',latitude,longitude,rtimob + n=n-1 + goto 100 + endif + +! check if ob is in coarse mesh domain (061404 switched sn/we) + if( (ri.lt.2.).or.(ri.gt.real(we_maxcg-1)).or.(rj.lt.2.).or. & + (rj.gt.real(sn_maxcg-1)) ) then + +! if (iprt) write(6,*) 'Obs out of coarse mesh domain' +! write(6,*) 'we_maxcg-1 = ',real(we_maxcg-1) +! write(6,*) 'sn_maxcg-1 = ',real(sn_maxcg-1) + +! n=n-1 +! if(is_sound)n=n-meas_count+1 + + n=n-meas_count +!ajb Reset timeob for discarded indices. + do imc = n+1, n+meas_count + timeob(imc) = 99999. + enddo + goto 100 + endif + +! check if an upper air ob is too high +! the ptop here is hardwired +! this check has to come after other checks - usually the last few +! upper air obs are too high +! if(is_sound)then +! njc=meas_count +! do jcj=meas_count,1,-1 +! 6. is 60 mb - hardwired +! if((varobs(5,n).lt.6.).and.(varobs(5,n).gt.0.))then +! print *,'obs too high - eliminate,n,p=',n,varobs(5,n) +! n=n-1 +! else +! if(varobs(5,n).gt.0.)goto 100 +! endif +! enddo +! endif +! + IF(TIMEOB(N).LT.fdob%RTLAST) THEN + IF (iprt) THEN + PRINT *,'2 OBS ARE NOT IN CHRONOLOGICAL ORDER' + PRINT *,'NEW YEAR?' + print *,'timeob,rtlast,n=',timeob(n),fdob%rtlast,n + ENDIF + STOP 111 + ELSE + fdob%RTLAST=TIMEOB(N) + ENDIF + GOTO 100 + 111 CONTINUE +!********************************************************************** +! -------------- END BIG 100 LOOP OVER N -------------- +!********************************************************************** + IF (iprt) write(6,5403) NVOL,XTIME + IEOF(inest)=1 + + close(NVOLA+INEST-1) + IF (iprt) print *,'closed fdda file for inest=',inest,nsta + +! if(nsta.eq.1.and.timeob(1).gt.9.e4)nsta=0 + goto 1001 + +! THE OBSERVATION ARRAYS ARE FULL AND THE MOST RECENTLY +! ACQUIRED OBS STILL HAS TIMEOB .LE. TFORWD. SO START +! DECREASING THE SIZE OF THE WINDOW +! get here if too many obs +120 CONTINUE + IF (iprt) THEN + write(6,121) N,NIOBF + write(6,122) + ENDIF + STOP 122 + fdob%WINDOW=fdob%WINDOW-0.1*TWINDO + IF(TWINDO.LT.0)STOP 120 +! IF THE WINDOW BECOMES NEGATIVE, THE INCOMING DATA IS +! PROBABLY GARBLED. STOP. + GOTO 10 +! +! READ CYCLE IS COMPLETED. DETERMINE THE NUMBER OF OBS IN +! THE CURRENT WINDOW +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! BUT FIRST, WHEN KTAU.EQ.0 (OR IN GENERAL, KTAUR), DISCARD THE +! "OLD" OBS FIRST... +130 CONTINUE + +! get here if at end of file, or if obs time is beyond what we +! need right now + IF(KTAU.EQ.KTAUR)THEN + NSTA=0 + keep_obs : DO N=1,NIOBF + +! try to keep all obs, but just don't use yet +! (don't want to throw away last obs read in - especially if +! its a sounding, in which case it looks like many obs) + IF(TIMEOB(N).GT.9.e4) EXIT keep_obs + if(timeob(n).gt.tforwd) then + if(iprt) write(6,951)inest,n,timeob(n),tforwd + 951 FORMAT('saving ob beyond window,inest,n,timeob,tforwd=', & + 2i5,2f13.4) + endif + NSTA=N + ENDDO keep_obs + + NDUM=0 +! make time=99999. if ob is too old +! print *,'tback,nsta=',tback,nsta + old_obs : DO N=1,NSTA+1 + IF((TIMEOB(N)-TBACK).LT.0)THEN + TIMEOB(N)=99999. + ENDIF +! print *,'n,ndum,timeob=',n,ndum,timeob(n) + IF(TIMEOB(N).LT.9.E4) EXIT old_obs + NDUM=N + ENDDO old_obs + +! REMOVE OLD OBS DENOTED BY 99999. AT THE FRONT OF TIMEOB ARRAY + IF (iprt) THEN + print *,'after 190 ndum=',ndum,nsta + print *,'timeob=',timeob(1),timeob(2) + ENDIF + NDUM=ABS(NDUM) + NMOVE=NIOBF-NDUM + IF( NMOVE.GT.0 .AND. NDUM.NE.0) THEN + DO N=1,NMOVE + VAROBS(1,N)=VAROBS(1,N+NDUM) + VAROBS(2,N)=VAROBS(2,N+NDUM) + VAROBS(3,N)=VAROBS(3,N+NDUM) + VAROBS(4,N)=VAROBS(4,N+NDUM) + VAROBS(5,N)=VAROBS(5,N+NDUM) + RJO(N)=RJO(N+NDUM) + RIO(N)=RIO(N+NDUM) + RKO(N)=RKO(N+NDUM) + TIMEOB(N)=TIMEOB(N+NDUM) + nlevs_ob(n)=nlevs_ob(n+ndum) + lev_in_ob(n)=lev_in_ob(n+ndum) + plfo(n)=plfo(n+ndum) + ENDDO + ENDIF +! moved obs up. now fill remaining space with 99999. + NOPEN=NMOVE+1 + IF(NOPEN.LE.NIOBF) THEN + DO N=NOPEN,NIOBF + VAROBS(1,N)=99999. + VAROBS(2,N)=99999. + VAROBS(3,N)=99999. + VAROBS(4,N)=99999. + VAROBS(5,N)=99999. + RIO(N)=99999. + RJO(N)=99999. + RKO(N)=99999. + TIMEOB(N)=99999. + ENDDO + ENDIF + ENDIF +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + NSTA=0 +! print *,'nsta at restart setting is ',nsta +! recalculate nsta after moving things around + recalc : DO N=1,NIOBF +! try to save all obs - don't throw away latest read in + IF(TIMEOB(N).GT.9.e4) EXIT recalc + NSTA=N +! nsta=n-1 ! yliu test + ENDDO recalc + + IF (iprt) write(6,160) KTAU,XTIME,NSTA + IF(KTAU.EQ.KTAUR)THEN + IF(nudge_opt.EQ.1)THEN + TWDOP=TWINDO*60. + IF (iprt) THEN + write(6,1449) INEST,RINXY,RINSIG,TWDOP + IF(ISWIND.EQ.1) write(6,1450) GIV + IF(ISTEMP.EQ.1) write(6,1451) GIT + IF(ISMOIS.EQ.1) write(6,1452) GIQ + IF(ISPSTR.EQ.1) write(6,1453) GIP + ENDIF + ENDIF + ENDIF + IF(KTAU.EQ.KTAUR)THEN + IF (iprt) THEN + write(6,553) + write(6,554) + ENDIF + IF(fdob%IWTSIG.NE.1)THEN + IF (iprt) THEN + write(6,555) + write(6,556) fdob%RINFMN*RINXY,fdob%RINFMX*RINXY,fdob%PFREE*10. + ENDIF + IF(fdob%RINFMN.GT.fdob%RINFMX)STOP 556 +! IS MINIMUM GREATER THAN MAXIMUM? + IF (iprt) write(6,557) fdob%DPSMX*10.,fdob%DCON + IF(fdob%DPSMX.GT.10.)STOP 557 + ENDIF + ENDIF +! IS DPSMX IN CB? + + IF(KTAU.EQ.KTAUR)THEN + IF (iprt) write(6,601) INEST,IONF + ENDIF + fdob%NSTAT=NSTA + +555 FORMAT(1X,' ABOVE THE SURFACE LAYER, OBS NUDGING IS PERFORMED', & + ' ON PRESSURE LEVELS,') +556 FORMAT(1X,' WHERE RINXY VARIES LINEARLY FROM ',E11.3,' KM AT', & + ' THE SURFACE TO ',E11.3,' KM AT ',F7.2,' MB AND ABOVE') +557 FORMAT(1X,' IN THE SURFACE LAYER, WXY IS A FUNCTION OF ', & + 'DPSMX = ',F7.2,' MB WITH DCON = ',E11.3, & + ' - SEE SUBROUTINE NUDOB') +601 FORMAT('0','FOR EFFICIENCY, THE OBS NUDGING FREQUENCY ', & + 'FOR MESH #',I2,' IS ',1I2,' CGM TIMESTEPS ',/) +121 FORMAT('0',' WARNING: NOBS = ',I4,' IS GREATER THAN NIOBF = ', & + I4,': INCREASE PARAMETER NIOBF') +5403 FORMAT(1H0,'-------------EOF REACHED FOR NVOL = ',I3, & + ' AND XTIME = ',F10.2,'-------------------') +122 FORMAT(1X,' ...OR THE CODE WILL REDUCE THE TIME WINDOW') +160 FORMAT('0','****** CALL IN4DOB AT KTAU = ',I5,' AND XTIME = ', & + F10.2,': NSTA = ',I7,' ******') +1449 FORMAT(1H0,'*****NUDGING INDIVIDUAL OBS ON MESH #',I2, & + ' WITH RINXY = ', & + E11.3,' KM, RINSIG = ',E11.3,' AND TWINDO (HALF-PERIOD) = ', & + E11.3,' MIN') +1450 FORMAT(1X,'NUDGING IND. OBS WINDS WITH GIV = ',E11.3) +1451 FORMAT(1X,'NUDGING IND. OBS TEMPERATURE WITH GIT = ',E11.3) +1452 FORMAT(1X,'NUDGING IND. OBS MOISTURE WITH GIQ = ',E11.3) +1453 FORMAT(1X,'NUDGING IND. OBS SURFACE PRESSURE WITH GIP = ,'E11.3) +553 FORMAT(1X,'BY DEFAULT: OBS NUDGING OF TEMPERATURE AND MOISTURE ', & + 'IS RESTRICTED TO ABOVE THE BOUNDARY LAYER') +554 FORMAT(1X,'...WHILE OBS NUDGING OF WIND IS INDEPENDENT OF THE ', & + 'BOUNDARY LAYER') + + RETURN + END SUBROUTINE in4dob + + SUBROUTINE julgmt(mdate,julgmtn,timanl,julday,gmt,ind) +! CONVERT MDATE YYMMDDHH TO JULGMT (JULIAN DAY * 100. +GMT) +! AND TO TIMANL (TIME IN MINUTES WITH RESPECT TO MODEL TIME) +! IF IND=0 INPUT MDATE, OUTPUT JULGMTN AND TIMANL +! IF IND=1 INPUT TIMANL, OUTPUT JULGMTN +! IF IND=2 INPUT JULGMTN, OUTPUT TIMANL + INTEGER, intent(in) :: MDATE + REAL, intent(out) :: JULGMTN + REAL, intent(out) :: TIMANL + INTEGER, intent(in) :: JULDAY + REAL, intent(in) :: GMT + INTEGER, intent(in) :: IND + +!*** DECLARATIONS FOR IMPLICIT NONE + real :: MO(12), rjulanl, houranl, rhr + + integer :: iyr, idate1, imo, idy, ihr, my1, my2, my3, ileap + integer :: juldayn, juldanl, idymax, mm + + + IF(IND.EQ.2)GOTO 150 + IYR=INT(MDATE/1000000.+0.001) + IDATE1=MDATE-IYR*1000000 + IMO=INT(IDATE1/10000.+0.001) + IDY=INT((IDATE1-IMO*10000.)/100.+0.001) + IHR=IDATE1-IMO*10000-IDY*100 + MO(1)=31 + MO(2)=28 +! IS THE YEAR A LEAP YEAR? (IN THIS CENTURY) + IYR=IYR+1900 + MY1=MOD(IYR,4) + MY2=MOD(IYR,100) + MY3=MOD(IYR,400) + ILEAP=0 +! jc +! IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)THEN + IF(MY1.EQ.0)THEN + ILEAP=1 + MO(2)=29 + ENDIF + IF(IND.EQ.1)GOTO 200 + MO(3)=31 + MO(4)=30 + MO(5)=31 + MO(6)=30 + MO(7)=31 + MO(8)=31 + MO(9)=30 + MO(10)=31 + MO(11)=30 + MO(12)=31 + JULDAYN=0 + DO 100 MM=1,IMO-1 + JULDAYN=JULDAYN+MO(MM) + 100 CONTINUE + + IF(IHR.GE.24)THEN + IDY=IDY+1 + IHR=IHR-24 + ENDIF + JULGMTN=(JULDAYN+IDY)*100.+IHR +! CONVERT JULGMT TO TIMANL WRT MODEL TIME IN MINUTES (XTIME) + 150 CONTINUE + JULDANL=INT(JULGMTN/100.+0.000001) + RJULANL=FLOAT(JULDANL)*100. + HOURANL=JULGMTN-RJULANL + TIMANL=(FLOAT(JULDANL-JULDAY)*24.-GMT+HOURANL)*60. + RETURN + 200 CONTINUE + RHR=GMT+TIMANL/60.+0.000001 + IDY=JULDAY + IDYMAX=365+ILEAP + 300 IF(RHR.GE.24.0)THEN + RHR=RHR-24.0 + IDY=IDY+1 + GOTO 300 + ENDIF + IF(IDY.GT.IDYMAX)IDY=IDY-IDYMAX + JULGMTN=FLOAT(IDY)*100.+RHR + RETURN + END SUBROUTINE julgmt + + SUBROUTINE vect(xlon,e1,e2,xlonc,xlatc,xn) + +! THIS ROUTINE CONVERTS INCOMING U AND V COMPS INTO MAP U AND V COMPS. +! iproj is projection (1=lamconf, 2=polarst, 3=mercator) +! xlonc is center longitude +! xn is cone factor (.716 for current lc) +! + REAL, intent(in) :: XLON + REAL, intent(inout) :: E1 + REAL, intent(inout) :: E2 + REAL, intent(in) :: xlonc + REAL, intent(in) :: xlatc + REAL, intent(in) :: xn + +!*** DECLARATIONS FOR IMPLICIT NONE + real :: pi, degran, u, v, xlonr, angle + + pi=3.1415926535 + DEGRAN=PI/180. +! +! + u=e1 + v=e2 + XLONR=XLONC-XLON + IF(XLONR.GT.180.) XLONR=XLONR-360. + IF(XLONR.LT.-180.) XLONR=XLONR+360. + ANGLE=XLONR*XN*DEGRAN + IF (xlatC.LT.0.0) ANGLE=-ANGLE + E1=V*SIN(ANGLE)+U*COS(ANGLE) + E2=V*COS(ANGLE)-U*SIN(ANGLE) + RETURN + END SUBROUTINE vect + + SUBROUTINE rh2r(rh,t,p,r,iice) + +! convert rh to r +! if iice=1, use saturation with respect to ice +! rh is 0-100. +! r is g/g +! t is K +! p is mb +! + REAL, intent(in) :: rh + REAL, intent(in) :: t + REAL, intent(in) :: p + REAL, intent(out) :: r + INTEGER, intent(in) :: iice + +!*** DECLARATIONS FOR IMPLICIT NONE + real eps, e0, eslcon1, eslcon2, esicon1, esicon2, t0, rh1 + real esat, rsat + + eps=0.62197 + e0=6.1078 + eslcon1=17.2693882 + eslcon2=35.86 + esicon1=21.8745584 + esicon2=7.66 + t0=260. + +! print *,'rh2r input=',rh,t,p + rh1=rh*.01 + + if(iice.eq.1.and.t.le.t0)then + esat=e0*exp(esicon1*(t-273.16)/(t-esicon2)) + else + esat=e0*exp(eslcon1*(t-273.16)/(t-eslcon2)) + endif + rsat=eps*esat/(p-esat) +! print *,'rsat,esat=',rsat,esat + r=rh1*rsat + +! print *,'rh2r rh,t,p,r=',rh1,t,p,r + + return + END SUBROUTINE rh2r + + SUBROUTINE rh2rb(rh,t,p,r,iice) + +! convert rh to r +! if iice=1, use daturation with respect to ice +! rh is 0-100. +! r is g/g +! t is K +! p is mb + + REAL, intent(in) :: rh + REAL, intent(in) :: t + REAL, intent(in) :: p + REAL, intent(out) :: r + INTEGER, intent(in) :: iice + +!*** DECLARATIONS FOR IMPLICIT NONE + real eps, e0, eslcon1, eslcon2, esicon1, esicon2, t0, rh1 + real esat, rsat + + eps=0.622 + e0=6.112 + eslcon1=17.67 + eslcon2=29.65 + esicon1=22.514 + esicon2=6.15e3 + t0=273.15 + + print *,'rh2r input=',rh,t,p + rh1=rh*.01 + + if(iice.eq.1.and.t.le.t0)then + esat=e0*exp(esicon1-esicon2/t) + else + esat=e0*exp(eslcon1*(t-t0)/(t-eslcon2)) + endif + rsat=eps*esat/(p-esat) +! print *,'rsat,esat=',rsat,esat + r=rh1*eps*rsat/(eps+rsat*(1.-rh1)) + + print *,'rh2r rh,t,p,r=',rh1,t,p,r + + return +END SUBROUTINE rh2rb + +SUBROUTINE llxy_lam (xlat,xlon,X,Y,xlatc, xlonc,xn,ds, & + imax, jmax, true_lat1, true_lat2 ) + +!*** DECLARATIONS FOR IMPLICIT NONE + real :: pi, conv, a + + PARAMETER(pi=3.14159,CONV=180./pi,a =6370.) + + REAL TRUE_LAT1 , PHI1 , POLE , XLATC , PHIC , XC , YC , & + XN , FLP , XLON , XLONC , PSX , XLAT , R , XX , YY , & + CENTRI , CENTRJ , X , DS , Y , TRUE_LAT2 + + INTEGER IMAX , JMAX + +! Calculate x and y given latitude and longitude for Lambert conformal projection + + IF(ABS(true_lat1).GT.90) THEN + PHI1 = 90. - 30. + ELSE + PHI1 = 90. - true_lat1 + END IF + POLE = 90.0 + IF ( XLATC.LT.0.0 ) THEN + PHI1 = -PHI1 + POLE = -POLE + END IF + PHIC = ( POLE - XLATC )/CONV + PHI1 = PHI1/CONV + XC = 0.0 + YC = -A/XN*SIN(PHI1)*(TAN(PHIC/2.0)/TAN(PHI1/2.0))**XN + +! CALCULATE X,Y COORDS. RELATIVE TO POLE + + FLP = XN*( XLON - XLONC )/CONV + PSX = ( POLE - XLAT )/CONV + R = -A/XN*SIN(PHI1)*(TAN(PSX/2.0)/TAN(PHI1/2.0))**XN + IF ( XLATC.LT.0.0 ) THEN + XX = R*SIN(FLP) + YY = R*COS(FLP) + ELSE + XX = -R*SIN(FLP) + YY = R*COS(FLP) + END IF + +! TRANSFORM (1,1) TO THE ORIGIN + + CENTRI = FLOAT(IMAX + 1)/2.0 + CENTRJ = FLOAT(JMAX + 1)/2.0 + X = ( XX - XC )/DS + CENTRJ + Y = ( YY - YC )/DS + CENTRI + + return + END SUBROUTINE llxy_lam + + SUBROUTINE llxy(xlat,xlon,x,y,xlatc,xlonc,kproj,psi1,psi2,ds, & + xn,sn_max,we_max,parent_grid_ratio, & + i_parent_start,j_parent_start) + + IMPLICIT NONE + +! CALCULATE X AND Y GIVEN LATITUDE AND LONGITUDE. +! PETER HOWELLS, NCAR, 1984 + + REAL, intent(in) :: xlat + REAL, intent(inout) :: xlon + REAL, intent(out) :: x + REAL, intent(out) :: y + REAL, intent(in) :: xlatc + REAL, intent(in) :: xlonc + INTEGER, intent(in) :: kproj + REAL, intent(in) :: psi1 + REAL, intent(in) :: psi2 + REAL, intent(in) :: ds + REAL, intent(in) :: xn + INTEGER, intent(in) :: sn_max + INTEGER, intent(in) :: we_max + INTEGER, intent(in) :: parent_grid_ratio + INTEGER, intent(in) :: i_parent_start + INTEGER, intent(in) :: j_parent_start + +!*** DECLARATIONS FOR IMPLICIT NONE + real conv, a, phi1, pole, c2, xc, phicr, cell, yc, xlatr + real phic, xx, yy, centri, centrj, ylon, flp, psx, r + integer imax, jmax, imapst, jmapst + +! write(6,*) 'enter llxy' +! write(6,*) 'enter llxy: xlatc = ',xlatc,' xlonc = ',xlonc +! write(6,*) 'xlat = ',xlat,' xlon = ',xlon +! write(6,*) 'psi1 = ',psi1,' psi2 = ',psi2 +! write(6,*) 'xn = ',xn,' kproj = ',kproj,' ds = ',ds +! write(6,*) 'sn_max = ',sn_max,' we_max = ',we_max +! write(6,*) 'parent_grid_ratio = ',parent_grid_ratio +! write(6,*) 'i_parent_start = ',i_parent_start +! write(6,*) 'j_parent_start = ',j_parent_start + + conv = 57.29578 + a = 6370.0 +! imax = sn_max*parent_grid_ratio+1 +! jmax = we_max*parent_grid_ratio+1 + imax = sn_max*parent_grid_ratio !ajb for WRF + jmax = we_max*parent_grid_ratio !ajb for WRF + imapst= (j_parent_start-1)*parent_grid_ratio+1 + jmapst= (i_parent_start-1)*parent_grid_ratio+1 + phi1 = 90.0-psi2 + pole = 90.0 + + if ( xlatc.lt.0.0 ) then + phi1 = -90.0-psi2 + pole = -pole + endif + + if (kproj.eq.3) then +! MERCATOR PROJECTION + C2 = A*COS(PSI1) + XC = 0.0 + PHICR = XLATC/CONV + CELL = COS(PHICR)/(1.0+SIN(PHICR)) + YC = - C2*ALOG(CELL) + IF (XLAT.NE.-90.) THEN + XLATR = XLAT/CONV + CELL = COS(XLATR)/(1.0+SIN(XLATR)) + YY = -C2*ALOG(CELL) + IF (XLONC.LT.0.0) THEN + IF (XLON.GT.0.0) XLON=XLON-360. + ELSE + IF (XLON.LT.0.0) XLON=360.+XLON + ENDIF + XX = C2*(XLON-XLONC)/CONV + ENDIF + + ELSE IF (KPROJ.EQ.1) THEN +! LAMBERT-COMFORMAL or POLAR-STEREO PROJECTION + PHIC = ( POLE - XLATC )/CONV + PHI1 = PHI1/CONV + XC = 0.0 + YC = -A/XN*SIN(PHI1)*(TAN(PHIC/2.0)/TAN(PHI1/2.0))**XN + +! CALCULATE X,Y COORDS. RELATIVE TO POLE + + YLON = XLON - XLONC + IF(YLON.GT.180) YLON = YLON - 360. + IF(YLON.LT.-180) YLON = YLON + 360. + FLP = XN*YLON/CONV + PSX = ( POLE - XLAT )/CONV + R = -A/XN*SIN(PHI1)*(TAN(PSX/2.0)/TAN(PHI1/2.0))**XN + IF ( XLATC.LT.0.0 ) THEN + XX = R*SIN(FLP) + YY = R*COS(FLP) + ELSE + XX = -R*SIN(FLP) + YY = R*COS(FLP) + END IF + END IF + +! TRANSFORM (1,1) TO THE ORIGIN + + CENTRI = FLOAT(IMAX + 1)/2.0 + CENTRJ = FLOAT(JMAX + 1)/2.0 + X = ( XX - XC )/DS + CENTRJ - jmapst + 1 + Y = ( YY - YC )/DS + CENTRI - imapst + 1 + + RETURN + END SUBROUTINE llxy + + SUBROUTINE llxy_try(xlat,xlon,x,y,xlatc,xlonc,kproj,psi1a,psi2,ds, & + xn,sn_max,we_max,parent_grid_ratio, & + i_parent_start,j_parent_start) + + IMPLICIT NONE + +! CALCULATE X AND Y GIVEN LATITUDE AND LONGITUDE. +! PETER HOWELLS, NCAR, 1984 + + REAL, intent(in) :: xlat + REAL, intent(inout) :: xlon + REAL, intent(out) :: x + REAL, intent(out) :: y + REAL, intent(in) :: xlatc + REAL, intent(in) :: xlonc + INTEGER, intent(in) :: kproj + REAL, intent(in) :: psi1a + REAL, intent(in) :: psi2 + REAL, intent(in) :: ds + REAL, intent(in) :: xn + INTEGER, intent(in) :: sn_max + INTEGER, intent(in) :: we_max + INTEGER, intent(in) :: parent_grid_ratio + INTEGER, intent(in) :: i_parent_start + INTEGER, intent(in) :: j_parent_start + +!*** DECLARATIONS FOR IMPLICIT NONE + real conv, a, phi1, pole, c2, xc, phicr, cell, yc, xlatr + real phic, xx, yy, centri, centrj, ylon, flp, psx, r + integer imax, jmax, imapst, jmapst + integer jmxc,imxc,iratio + real ric0,rjc0,rs,yind,xind,rix,rjx,psi1 + +! write(6,*) 'enter llxy' +! write(6,*) 'enter llxy: xlatc = ',xlatc,' xlonc = ',xlonc +! write(6,*) 'psi1 = ',psi1a,' psi2 = ',psi2 +! write(6,*) 'xn = ',xn,' kproj = ',kproj,' ds = ',ds +! write(6,*) 'sn_max = ',sn_max,' we_max = ',we_max +! write(6,*) 'parent_grid_ratio = ',parent_grid_ratio +! write(6,*) 'i_parent_start = ',i_parent_start +! write(6,*) 'j_parent_start = ',j_parent_start + + conv = 57.29578 + a = 6370.0 + imax = sn_max*parent_grid_ratio+1 + jmax = we_max*parent_grid_ratio+1 + imapst= (j_parent_start-1)*parent_grid_ratio+1 + jmapst= (i_parent_start-1)*parent_grid_ratio+1 + iratio = parent_grid_ratio + imxc = imax + jmxc = jmax + rix=imapst + rjx=jmapst + + phi1 = psi1a + if(xlatc .gt. 0.) then + psi1=90.-phi1 + else + psi1=-90+abs(phi1) + endif + + ric0=(imxc+1.)*0.5 + rjc0=(jmxc+1.)*0.5 + +! if(kproj .eq. 1) then + if(kproj .le. 2) then + if(xlatc .gt. 0.) then + rs=a/xn*sin(psi1/conv)*(tan((90.-xlat)/conv/2.) & + /tan(psi1/2./conv))**xn + yc=-a/xn*sin(psi1/conv)*(tan((90.-xlatc)/conv/2.) & + /tan(psi1/2./conv))**xn + else + rs=a/xn*sin(psi1/conv)*(tan((-90.-xlat)/conv/2.) & + /tan(psi1/2./conv))**xn + yc=-a/xn*sin(psi1/conv)*(tan((-90.-xlatc)/conv/2.) & + /tan(psi1/2./conv))**xn + endif +! elseif(kproj .eq. 2) then +! if(xlatc .gt. 0.) then +! rs=a*sin((90.-xlat)/conv)*(1.+cos(psi1/conv)) +! & /(1.+cos((90.-xlat)/conv)) +! yc=-a*sin((90.-xlatc)/conv)*(1.+cos(psi1/conv)) +! & /(1.+cos((90.-xlatc)/conv)) +! else +! rs=a*sin((-90.-xlat)/conv)*(1.+cos(psi1/conv)) +! & /(1.+cos((-90.-xlat)/conv)) +! yc=-a*sin((-90.-xlatc)/conv)*(1.+cos(psi1/conv)) +! & /(1.+cos((-90.-xlatc)/conv)) +! endif + else + psi1 = 0 ! yliu added + c2=a*cos(psi1/conv) + yc=c2*alog((1.+sin(xlatc/conv))/cos(xlatc/conv)) + endif + + if(kproj .le. 2) then + y=(ric0-(yc/ds+rs/ds*cos(xn*(xlon-xlonc)/conv))-rix) & + *iratio+1.0 + if(xlatc .gt. 0.) then + x=(rjc0+rs/ds*sin(xn*(xlon-xlonc)/conv)-rjx)*iratio+1.0 + else + x=(rjc0-rs/ds*sin(xn*(xlon-xlonc)/conv)-rjx)*iratio+1.0 + endif + else + y=c2*alog((1.+sin(xlat/conv))/cos(xlat/conv)) + x=c2*(xlon-xlonc)/conv + y=(ric0+(y-yc)/ds-rix)*iratio+1.0 + x=(rjc0+x/ds-rjx)*iratio+1.0 + endif + write(6,*) 'xj = ',x, 'yi = ',y,"xlat",xlat,"xlon",xlon + + RETURN + END SUBROUTINE llxy_try + +#endif +!----------------------------------------------------------------------- +! End subroutines for in4dob +!----------------------------------------------------------------------- diff --git a/wrfv2_fire/share/wrf_histin.F b/wrfv2_fire/share/wrf_histin.F new file mode 100644 index 00000000..dd31cab7 --- /dev/null +++ b/wrfv2_fire/share/wrf_histin.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_histin ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_histout.F b/wrfv2_fire/share/wrf_histout.F new file mode 100644 index 00000000..caff2b91 --- /dev/null +++ b/wrfv2_fire/share/wrf_histout.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_histout ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_inputin.F b/wrfv2_fire/share/wrf_inputin.F new file mode 100644 index 00000000..c1befc9a --- /dev/null +++ b/wrfv2_fire/share/wrf_inputin.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_inputin ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_inputout.F b/wrfv2_fire/share/wrf_inputout.F new file mode 100644 index 00000000..17042a66 --- /dev/null +++ b/wrfv2_fire/share/wrf_inputout.F @@ -0,0 +1,56 @@ + SUBROUTINE wrf_inputout ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_restartin.F b/wrfv2_fire/share/wrf_restartin.F new file mode 100644 index 00000000..7d9d7575 --- /dev/null +++ b/wrfv2_fire/share/wrf_restartin.F @@ -0,0 +1,58 @@ +SUBROUTINE wrf_restartin ( fid , grid , config_flags , switch , ierr ) + USE module_domain + USE module_state_description + USE module_configure + USE module_io + USE module_io_wrf + USE module_date_time + USE module_bc_time_utilities + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(IN) :: switch + INTEGER, INTENT(INOUT) :: ierr + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER iname(9) + INTEGER iordering(3) + INTEGER icurrent_date(24) + INTEGER i,j,k + INTEGER icnt + INTEGER ndim + INTEGER ilen + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + CHARACTER*256 errmess + CHARACTER*40 :: this_datestr, next_datestr + CHARACTER*9 NAMESTR + INTEGER IBDY, NAMELEN + LOGICAL wrf_dm_on_monitor + EXTERNAL wrf_dm_on_monitor + CHARACTER*19 new_date + CHARACTER*24 base_date + INTEGER idt + INTEGER itmp, dyn_opt + INTEGER :: ide_compare , jde_compare , kde_compare + ierr = 0 + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + CALL nl_get_dyn_opt ( 1 , dyn_opt ) + +#include + + RETURN + END diff --git a/wrfv2_fire/share/wrf_restartout.F b/wrfv2_fire/share/wrf_restartout.F new file mode 100644 index 00000000..6cfa1086 --- /dev/null +++ b/wrfv2_fire/share/wrf_restartout.F @@ -0,0 +1,57 @@ + SUBROUTINE wrf_restartout ( fid , grid , config_flags, switch , & + dryrun, ierr ) + USE module_io + USE module_wrf_error + USE module_io_wrf + USE module_domain + USE module_state_description + USE module_configure + USE module_utility + IMPLICIT NONE +#include +#include + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags + INTEGER, INTENT(IN) :: fid, switch + INTEGER, INTENT(INOUT) :: ierr + LOGICAL, INTENT(IN) :: dryrun + + ! Local data + INTEGER ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + ips , ipe , jps , jpe , kps , kpe + + INTEGER itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end + INTEGER , DIMENSION(3) :: memory_start , memory_end + INTEGER , DIMENSION(3) :: patch_start , patch_end + INTEGER i,j + INTEGER julyr, julday, idt, iswater , map_proj + REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 + INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & + mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & + sf_surface_physics, bl_pbl_physics, cu_physics + REAL khdif, kvdif + INTEGER rc + + CHARACTER*256 message + CHARACTER*80 char_junk + INTEGER ibuf(1) + REAL rbuf(1) + CHARACTER*40 :: next_datestr + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + call nl_get_dyn_opt ( 1 , dyn_opt ) + + ! note that the string current_date comes in through use association + ! of module_io_wrf + +! generated by the registry +#include + + RETURN + END diff --git a/wrfv2_fire/test/em_b_wave/input_jet b/wrfv2_fire/test/em_b_wave/input_jet new file mode 100644 index 00000000..0d0f92fb Binary files /dev/null and b/wrfv2_fire/test/em_b_wave/input_jet differ diff --git a/wrfv2_fire/test/em_b_wave/namelist.input b/wrfv2_fire/test/em_b_wave/namelist.input new file mode 100644 index 00000000..d4ea7281 --- /dev/null +++ b/wrfv2_fire/test/em_b_wave/namelist.input @@ -0,0 +1,114 @@ + &time_control + run_days = 5, + run_hours = 0, + run_minutes = 0, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 05, 05, 05, + end_hour = 00, 00, 00, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + history_interval = 360, 360, 360, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 3600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 600, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 41, 41, 41, + s_sn = 1, 1, 1, + e_sn = 81, 81, 81, + s_vert = 1, 1, 1, + e_vert = 65, 65, 65, + dx = 100000,20000, 4000, + dy = 100000,20000, 4000, + ztop = 16000, 16000, 16000, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 17, 17, + j_parent_start = 0, 33, 33, + parent_grid_ratio = 1, 5, 5, + parent_time_step_ratio = 1, 5, 5, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 0, 0, 0, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 1, + km_opt = 1, + damp_opt = 0, + zdamp = 4000., 4000., 4000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + non_hydrostatic = .true., .true., .true., + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + / + + &bdy_control + periodic_x = .true., .false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .true., .false.,.false., + symmetric_ye = .true., .false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_b_wave/namelist.input.backwards b/wrfv2_fire/test/em_b_wave/namelist.input.backwards new file mode 100644 index 00000000..7c7bdbbc --- /dev/null +++ b/wrfv2_fire/test/em_b_wave/namelist.input.backwards @@ -0,0 +1,114 @@ + &time_control + run_days = -5, + run_hours = 0, + run_minutes = 0, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0000, 0001, 0001, + end_month = 12, 01, 01, + end_day = 27, 05, 05, + end_hour = 00, 00, 00, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + history_interval = 360, 360, 360, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 3600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = -600, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 41, 41, 41, + s_sn = 1, 1, 1, + e_sn = 81, 81, 81, + s_vert = 1, 1, 1, + e_vert = 65, 65, 65, + dx = 100000,20000, 4000, + dy = 100000,20000, 4000, + ztop = 16000, 16000, 16000, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 17, 17, + j_parent_start = 0, 33, 33, + parent_grid_ratio = 1, 5, 5, + parent_time_step_ratio = 1, 5, 5, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 0, 0, 0, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 1, + km_opt = 1, + damp_opt = 0, + zdamp = 4000., 4000., 4000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + non_hydrostatic = .true., .true., .true., + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + / + + &bdy_control + periodic_x = .true., .false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .true., .false.,.false., + symmetric_ye = .true., .false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_b_wave/run_me_first.csh b/wrfv2_fire/test/em_b_wave/run_me_first.csh new file mode 100755 index 00000000..19b3a98a --- /dev/null +++ b/wrfv2_fire/test/em_b_wave/run_me_first.csh @@ -0,0 +1,8 @@ +#!/bin/csh + +echo Setting up b_wave case by linking data files into this directory + +echo linking to RRTM_DATA in ../../run directory +ln -sf ../../run/RRTM_DATA . + +echo done diff --git a/wrfv2_fire/test/em_b_wave/run_restart.tar b/wrfv2_fire/test/em_b_wave/run_restart.tar new file mode 100644 index 00000000..841f70e5 Binary files /dev/null and b/wrfv2_fire/test/em_b_wave/run_restart.tar differ diff --git a/wrfv2_fire/test/em_esmf_exp/README_WRF_CPL_SST.txt b/wrfv2_fire/test/em_esmf_exp/README_WRF_CPL_SST.txt new file mode 100644 index 00000000..064ad6e6 --- /dev/null +++ b/wrfv2_fire/test/em_esmf_exp/README_WRF_CPL_SST.txt @@ -0,0 +1,247 @@ + + + Summary of ESMF-Coupled WRF Experiment + + Tom Henderson + John Michalakes + NCAR/MMM + 27 February 2007 + +INTRODUCTION + +This document describes ESMF-enablement and coupling of WRF through ESMF +to another component that simulates coupling to an ocean model. As a +prelude to availability of an ESMF-enabled implementation of the HYCOM +model, WRF has been coupled through ESMF to a very simple "data-ocean" +component named "SST" via a very simple coupler component named "CPL". +The demonstration, conducted on kraken.navo.hpc.mil, a DoD HPC system +at the NAVO MSRC, was supported by AFWA under UCAR contract FA4600-05-P-0162. +The demonstration was later repeated on NCAR's bluesky machine (IBM p690) and +again on NCAR's bluevista machine (IBM p575). A description of the bluesky +and bluevista experiments follows. + + + +EVENT LOOP + +Please read the section entitled "NOTES ABOUT THE EVENT LOOP FOR WRF+CPL+SST" +in file external/io_esmf/README.io_esmf for details about order of operations +in the current event loop (time-stepping loop). + + + +EXPERIMENT DETAILS + + The "WRF+CPL+SST" experiment was conducted on bluesky on 12 October 2006 at +which time the following software was installed: + xlfrte 8.1.1.6 + bos.mp 5.1.0.58 + xlC.rte 6.0.0.0 + ESMF 2.2.0rp1 +WRF source code was installed in +WRFDIR=/ptmp/hender/ESMF2.2.0rp1/WRFV2_20061005_1123_WORK/WRFV2/. +(Referred to below as "$WRFDIR".) + + The "WRF+CPL+SST" experiment was repeated on bluevista on 27 February 2007 at +which time the following software was installed: + xlfrte 10.1.0.3 + bos.mp 5.3.0.42 + xlC.rte 8.0.0.5 + ESMF 2.2.2r +WRF source code was installed in +WRFDIR=/ptmp/hender/WRF-LIS/WRFV2_20070214_0906/WRFV2/. + + Additional documentation that describes the SST component and provides +instructions for building WRF with ESMF can be found in +external/io_esmf/README.io_esmf. Briefly, the +SST component simply reads SST data stored in a file (sstin_d01_000000), sends +it to WRF via CPL, receives SST data back from WRF via CPL, and verifies that +data received matches data sent. Since ESMF coupling is implemented within +WRF via the WRF I/O and coupling API (WRF IOAPI), the experiment can be +repeated reading the SST data directly into WRF as a netCDF file simply by +changing the appropriate I/O format in the WRF "namelist.input" file. This +feature is illustrated below. + + The following "recipe" can be used to reproduce the experiment, if desired. +All commands are csh. + + +1) On bluesky, set environment variables to build WRF with ESMF using 32-bit +addressing. On bluevista, use the default 64-bit addressing. +Set the $ESMFLIB and $ESMFINC environment variables are to tell the WRF build +automation where to find an installation of ESMF. + +BLUESKY: +OBJECT_MODE=32 +ESMFLIB=/home/bluesky/hender/esmf/lib/libO/AIX.default.32.default +ESMFINC=/home/bluesky/hender/esmf/mod/modO/AIX.default.32.default + +BLUEVISTA: +OBJECT_MODE=64 +ESMFLIB=/home/bluevista/hender/esmf/esmf_2_2_2r/lib/libO/AIX.default.64.mpi.default +ESMFINC=/home/bluevista/hender/esmf/esmf_2_2_2r/mod/modO/AIX.default.64.mpi.default + + + +2) Set up WRF Registry for WRF+CPL+SST case: + +$WRFDIR/Registry >> mv -f Registry.EM Registry.EM_ORIG +$WRFDIR/Registry >> cp -f Registry.EM_SST Registry.EM + + + +3) Build WRF from scratch with RSL for use with ESMF: + +$WRFDIR >> echo 4 | configure +$WRFDIR >> compile em_real >&! compile.em_real.4.out + + Verify that executables exist: + +$WRFDIR >> ls -1 main/*exe +main/ndown.exe +main/nup.exe +main/real.exe +main/wrf.exe +main/wrf_SST_ESMF.exe + + Note that "wrf.exe" is the usual stand-alone WRF executable. +"wrf_SST_ESMF.exe" is the WRF+CPL+SST coupled application. + + + +4) Go to run directory, unpack the required SST data, namelists and run +scripts from WRF_CPL_SST.tar.gz, and verify that all required files are +present: + +$WRFDIR/test/em_esmf_exp >> gunzip WRF_CPL_SST.tar.gz +$WRFDIR/test/em_esmf_exp >> tar xvf WRF_CPL_SST.tar +$WRFDIR/test/em_esmf_exp >> ls -l sstin_d01_000000 namelist.input.jan00.* *.csh +-rw-r--r-- 6368 Feb 27 13:16 namelist.input.jan00.ESMFSST +-rw-r--r-- 6368 Feb 27 13:16 namelist.input.jan00.NETCDFSST +-rw-r--r-- 1286 Feb 27 14:51 real.csh +-rwxr-xr-x 948 Feb 27 14:51 real.lsf.csh +-rw-r--r-- 458064 Oct 12 11:58 sstin_d01_000000 +-rw-r--r-- 1074 Feb 27 14:51 test4_0.csh +-rwxr-xr-x 732 Feb 27 14:51 test4_0.lsf.csh +-rw-r--r-- 1162 Feb 27 14:51 test4_0_ESMFSST.csh +-rw-r--r-- 824 Feb 27 14:51 test4_0_ESMFSST.lsf.csh +-rw-r--r-- 1190 Feb 27 14:52 test4_0_NETCDFSST_wrfexe.csh +-rw-r--r-- 824 Feb 27 14:52 test4_0_NETCDFSST_wrfexe.lsf.csh + + "sstin_d01_000000" contains time-varying SST input data. +NOTE: sstin_d01_000000 also contains LANDMASK fields soley for validation +purposes. Only the first time-level of LANDMASK is significant. For +historical reasons, the other time-levels may differ -- they are ignored +(and should eventually be removed). + + "test4_0_ESMFSST.csh" is a LoadLeveler batch submission script that runs the +WRF+CPL+SST coupled system. It copies "namelist.input.jan00.ESMFSST" to +"namelist.input" and runs "wrf_SST_ESMF.exe" on four CPUs. +"test4_0_ESMFSST.lsf.csh" does the same thing for LSF. + + "test4_0_NETCDFSST.csh" is a LoadLeveler batch submission script that runs +WRF by itself, reading the SST data directly into WRF as a netCDF file. It +copies "namelist.input.jan00.NETCDFSST" to "namelist.input" and runs "wrf.exe" +on four CPUs. +"test4_0_NETCDFSST.lsf.csh" does the same thing for LSF. + + Note that namelists namelist.input.jan00.ESMFSST and +namelist.input.jan00.NETCDFSST differ only in the I/O format used for the +I/O streams used to "read" and "write" SST data. Vanilla netCDF I/O is used +when "io_form" == 2. ESMFStates are used when "io_form" == 7. + +$WRFDIR/test/em_esmf_exp >> diff namelist.input.jan00.ESMFSST namelist.input.jan00.NETCDFSST +32c32 +< io_form_auxinput5 = 7, +--- +> io_form_auxinput5 = 2, +37c37 +< io_form_auxhist5 = 7, +--- +> io_form_auxhist5 = 2, + + (Also note that a script is provided to run WRF without SST forcing for +comparison purposes. "test4_0.csh" is a LoadLeveler batch submission script +that runs WRF by itself without SST forcing. It copies "namelist.input.jan00" +to "namelist.input" and runs "wrf.exe" on four CPUs. "test4_0.lsf.csh" does +the same thing for LSF.) + + + +5) Run the wrf real program using the "jan00" data set. Script "real.csh" +can be modified to do this if desired (or real.lsf.csh for LSF). + +BLUESKY (LoadLeveler): +$WRFDIR/test/em_esmf_exp >> llsubmit real.csh +BLUEVISTA (LSF): +$WRFDIR/test/em_esmf_exp >> bsub < real.lsf.csh + + Verify that real.exe produced the usual WRF input and boundary data files +"wrfbdy_d01" and "wrfinput_d01". + +$WRFDIR/test/em_esmf_exp >> ls -al wrfbdy_d01 wrfinput_d01 +-rw-r--r-- 9355944 Feb 27 12:58 wrfbdy_d01 +-rw-r--r-- 6076408 Feb 27 12:58 wrfinput_d01 + +Move all other files produced by the real.exe run into a new directory: + +$WRFDIR/test/em_esmf_exp >> mkdir real.out +$WRFDIR/test/em_esmf_exp >> mv PET?.ESMF* namelist.input rsl.*.* real.*.err real.*.out real.out + + + +6) Run the WRF+CPL+SST test case: + +BLUESKY (LoadLeveler): +$WRFDIR/test/em_esmf_exp >> llsubmit test4_0_ESMFSST.csh +BLUEVISTA (LSF): +$WRFDIR/test/em_esmf_exp >> bsub < test4_0_ESMFSST.lsf.csh + + + +7) Verify that run completed successfully: + +$WRFDIR/test/em_esmf_exp >> tail -1 rsl.out.0000 + d01 2000-01-25_00:00:00 wrf: SUCCESS COMPLETE WRF + + + +8) Move all files produced by the WRF+CPL+SST run into a new directory: + +$WRFDIR/test/em_esmf_exp >> mkdir test4_0_ESMFSST.out +$WRFDIR/test/em_esmf_exp >> mv PET?.ESMF* namelist.input rsl.*.* test4_0_ESMFSST.*.* wrfout* test4_0_ESMFSST.out + + + +9) Run the WRF stand-alone test case: + +BLUESKY (LoadLeveler): +$WRFDIR/test/em_esmf_exp >> llsubmit test4_0_NETCDFSST_wrfexe.csh +BLUEVISTA (LSF): +$WRFDIR/test/em_esmf_exp >> bsub < test4_0_NETCDFSST_wrfexe.lsf.csh + + + +10) Verify that run completed successfully: + +$WRFDIR/test/em_esmf_exp >> tail -1 rsl.out.0000 + d01 2000-01-25_00:00:00 wrf: SUCCESS COMPLETE WRF + + + +11) Move all files produced by the WRF stand-alone run into a new directory: + +$WRFDIR/test/em_esmf_exp >> mkdir test4_0_NETCDFSST.out +$WRFDIR/test/em_esmf_exp >> mv PET?.ESMF* namelist.input rsl.*.* test4_0_NETCDFSST.*.* wrfout* sstout_d01_000000 test4_0_NETCDFSST.out + + + +12) Verify that both tests produced bitwise-identical history output: + +$WRFDIR/test/em_esmf_exp >> ls -l test4_0_ESMFSST.out/wrfout_d01_2000-01-24_12:00:00 test4_0_NETCDFSST.out/wrfout_d01_2000-01-24_12:00:00 +-rw-r--r-- 1 hender ncar 32614704 Oct 12 15:48 test4_0_ESMFSST.out/wrfout_d01_2000-01-24_12:00:00 +-rw-r--r-- 1 hender ncar 32614704 Oct 12 15:52 test4_0_NETCDFSST.out/wrfout_d01_2000-01-24_12:00:00 + +$WRFDIR/test/em_esmf_exp >> cmp -l test4_0_ESMFSST.out/wrfout_d01_2000-01-24_12:00:00 test4_0_NETCDFSST.out/wrfout_d01_2000-01-24_12:00:00 | wc + 0 0 0 + diff --git a/wrfv2_fire/test/em_esmf_exp/WRF_CPL_SST.tar.gz b/wrfv2_fire/test/em_esmf_exp/WRF_CPL_SST.tar.gz new file mode 100644 index 00000000..f1a8b78b Binary files /dev/null and b/wrfv2_fire/test/em_esmf_exp/WRF_CPL_SST.tar.gz differ diff --git a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST new file mode 100644 index 00000000..1588a159 --- /dev/null +++ b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST @@ -0,0 +1,144 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600, + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2, + io_form_restart = 2, + io_form_input = 2, + io_form_boundary = 2, + debug_level = 0, + auxinput5_inname = 'sstin_d01_000000', + auxinput5_interval_h = 1, + auxinput5_end_h = 13, + io_form_auxinput5 = 7, + auxhist5_outname = 'sstout_d01_000000', + frames_per_auxhist5 = 1000, + auxhist5_interval_h = 1, + auxhist5_end_h = 13, + io_form_auxhist5 = 7, + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + sst_update = 1, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + w_damping = 0, + diff_opt = 1, + km_opt = 4, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST new file mode 100644 index 00000000..ffbb3bd2 --- /dev/null +++ b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST @@ -0,0 +1,144 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600, + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2, + io_form_restart = 2, + io_form_input = 2, + io_form_boundary = 2, + debug_level = 0, + auxinput5_inname = 'sstin_d01_000000', + auxinput5_interval_h = 1, + auxinput5_end_h = 13, + io_form_auxinput5 = 2, + auxhist5_outname = 'sstout_d01_000000', + frames_per_auxhist5 = 1000, + auxhist5_interval_h = 1, + auxhist5_end_h = 13, + io_form_auxhist5 = 2, + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + sst_update = 1, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + w_damping = 0, + diff_opt = 1, + km_opt = 4, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_fire/README.fire b/wrfv2_fire/test/em_fire/README.fire new file mode 100644 index 00000000..6c929adf --- /dev/null +++ b/wrfv2_fire/test/em_fire/README.fire @@ -0,0 +1,28 @@ +em_fire test case: + +This test case produces a fire simulation. + +The default version of this test case uses a constant eddy viscosity +for turbulent mixing -> diff_opt=1 and km_opt = 1 in namelist.input. +The Coriolis terms in the model are off (f = 0) + +The prognostic TKE can be activated by setting diff_opt=2 and km_opt += 2 (see README.namelist). + +In idealized cloud model simulations, it is common practice to use +Coriolis forcing calculated from wind fields defined as perturbations +from the initial sounding. This option can be activated by setting +the "dynamics" namelist option "pert_coriolis = .true." (the default +is false). Additionally, the value of the Coriolis parameter "f" +will need to be reset (from zero to the desired value) in +WRFV1/dyn_em/module_initialize_quarter_ss.F, and the initial state +recomputed. + +Also, a constant surface drag and heat flux can be specified in the +TKE formulation by setting the "dynamics" namelist option +"tke_drag_coefficient = Cd", "tke_heat_flux = S". The default +values are zero. Please note that these are specified constants; +the formulations do not make use of similarity theory. These +momentum and heat fluxes will not be active if surface and boundary +layer formulations are activated in the model physics. + diff --git a/wrfv2_fire/test/em_fire/input_sounding b/wrfv2_fire/test/em_fire/input_sounding new file mode 100644 index 00000000..a7ac134c --- /dev/null +++ b/wrfv2_fire/test/em_fire/input_sounding @@ -0,0 +1,48 @@ + 1000.00 305.00 14.00 + 25.00 300.00 10.00 1.00 0.00 + 75.00 300.00 10.00 1.00 0.00 + 125.00 300.00 10.00 1.00 0.00 + 175.00 300.00 10.00 1.00 0.00 + 225.00 300.00 10.00 1.00 0.00 + 275.00 300.00 10.00 1.00 0.00 + 325.00 300.00 10.00 1.00 0.00 + 375.00 300.00 10.00 1.00 0.00 + 425.00 300.00 10.00 1.00 0.00 + 475.00 300.00 10.00 1.00 0.00 + 525.00 300.00 10.00 1.00 0.00 + 575.00 300.00 10.00 1.00 0.00 + 625.00 300.00 10.00 1.00 0.00 + 675.00 300.00 10.00 1.00 0.00 + 725.00 300.00 10.00 1.00 0.00 + 775.00 300.00 10.00 1.00 0.00 + 825.00 300.00 10.00 1.00 0.00 + 875.00 300.00 10.00 1.00 0.00 + 925.00 300.00 10.00 1.00 0.00 + 975.00 302.43 10.00 1.00 0.00 + 1025.00 305.63 4.00 1.00 0.00 + 1075.00 308.05 4.00 1.00 0.00 + 1125.00 308.20 4.00 1.00 0.00 + 1175.00 308.35 4.00 1.00 0.00 + 1225.00 308.50 4.00 1.00 0.00 + 1275.00 308.65 4.00 1.00 0.00 + 1325.00 308.80 4.00 1.00 0.00 + 1375.00 308.95 4.00 1.00 0.00 + 1425.00 309.10 4.00 1.00 0.00 + 1475.00 309.25 4.00 1.00 0.00 + 1525.00 309.40 4.00 1.00 0.00 + 1575.00 309.55 4.00 1.00 0.00 + 1625.00 309.70 4.00 1.00 0.00 + 1675.00 309.85 4.00 1.00 0.00 + 1725.00 310.00 4.00 1.00 0.00 + 1775.00 310.15 4.00 1.00 0.00 + 1825.00 310.30 4.00 1.00 0.00 + 1875.00 310.45 4.00 1.00 0.00 + 1925.00 310.60 4.00 1.00 0.00 + 1975.00 310.75 4.00 1.00 0.00 + 2025.00 310.90 4.00 1.00 0.00 + 2075.00 311.05 4.00 1.00 0.00 + 2125.00 311.20 4.00 1.00 0.00 + 2175.00 311.35 4.00 1.00 0.00 + 2225.00 311.50 4.00 1.00 0.00 + 2275.00 311.65 4.00 1.00 0.00 + diff --git a/wrfv2_fire/test/em_fire/namelist.input b/wrfv2_fire/test/em_fire/namelist.input new file mode 100644 index 00000000..3eb432ca --- /dev/null +++ b/wrfv2_fire/test/em_fire/namelist.input @@ -0,0 +1,138 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 30, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 01, 01, 01, + end_hour = 00, 00, 00, + end_minute = 30, 30, 30, + end_second = 00, 00, 00, + history_interval = 10, 10, 10, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 10, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 1, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 42, 43, 43, + s_sn = 1, 1, 1, + e_sn = 42, 43, 43, + s_vert = 1, 1, 1, + e_vert = 41, 41, 41, + dx = 60, 30, 10, + dy = 60, 30, 10, + ztop = 1500, 1500, 1500, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 1, 1, + j_parent_start = 0, 1, 1, + parent_grid_ratio = 1, 2, 3, + parent_time_step_ratio = 1, 2, 3, + feedback = 1, + smooth_option = 0 + sr_x = 10, 0, 0 ! subgrid ratio in x + sr_y = 10, 0, 0 ! subgrid ratio in y + / + + &physics + mp_physics = 0, 0, 0, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 0, 0, 0, + isfflx = 1, + ifsnow = 0, + icloud = 0, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 2, + damp_opt = 0, + zdamp = 5000., 5000., 5000., + dampcoef = 0.2, 0.2, 0.2 + khdif = 0.05, 0.05, 0.05, + kvdif = 0.05, 0.05, 0.05, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + mix_full_fields = .true., .true., .true., + non_hydrostatic = .true., .true., .true., + time_step_sound = 20, 20, 20, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + periodic_x = .true.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false., .false.,.false., + open_xe = .false., .false.,.false., + periodic_y = .true.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false., .false.,.false., + open_ye = .false., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / + + &fire ! be sure to set sr_x,sr_y in domains-namelist (to set refinement in x,y) + ifire = 1, ! integer, = 0: no fire, = 1: cc_fire +!fire_lat_init = 40., ! real , initial fire latitude (deg) +!fire_lon_init = -105., ! real , initial fire longitude (deg) + fire_lat_init = 6.75e-3, ! real , initial fire latitude (deg) + fire_lon_init = 6.75e-3, ! real , initial fire longitude (deg) + fire_ign_time = 2.0, ! real , time of fire ignition (s) + fire_shape = 0, ! integer, initial fire shape + fire_sprd_mdl = 1, ! integer, = 0: Macarthur, = 1: BEHAVE + fire_crwn_hgt = 15., ! real , height of canopy crown (m) + fire_ext_grnd = 50., ! real , extinction coeff ground fire + fire_ext_crwn = 50., ! real , extinction coeff crown fire + fire_fuel_read = 1, ! integer, = 1: fuels specified; = 2: read from file + fire_fuel_cat = 8, ! integer, if specified which fuel category? + / diff --git a/wrfv2_fire/test/em_fire/namelist.input.sav b/wrfv2_fire/test/em_fire/namelist.input.sav new file mode 100644 index 00000000..ef650e32 --- /dev/null +++ b/wrfv2_fire/test/em_fire/namelist.input.sav @@ -0,0 +1,127 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 1, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 01, 01, 01, + end_hour = 00, 00, 00, + end_minute = 120, 120, 120, + end_second = 00, 00, 00, + history_interval = 10, 10, 10, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 120, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 12, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 42, 43, 43, + s_sn = 1, 1, 1, + e_sn = 42, 43, 43, + s_vert = 1, 1, 1, + e_vert = 41, 41, 41, + dx = 2000, 666.6666667, 222.2222222 + dy = 2000, 666.6666667, 222.2222222 + ztop = 20000, 20000, 20000, + grid_id = 1, 2, 3, + level = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 15, 15, + j_parent_start = 0, 15, 15, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + sr_x = 0,0,5 ! subgrid ratio in x (used for fire/fuel cell refinement) + sr_y = 0,0,5 ! subgrid ratio in y (used for fire/fuel cell refinement) + / + + &physics + mp_physics = 1, 1, 1, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 1, + km_opt = 1, + damp_opt = 0, + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 500, 500, 500, + kvdif = 500, 500, 500, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + non_hydrostatic = .true., .true., .true., + time_step_sound = 6, 6, 6, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + / + + &bdy_control + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .true., .false.,.false., + open_xe = .true., .false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .true., .false.,.false., + open_ye = .true., .false.,.false., + nested = .false., .true., .true., + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / + +&fire +! be sure to set sr_x,sr_y in domains-namelist (to set refinement in x,y) + ifire = 1, ! integer, = 0: no fire, = 1: cc_fire + fire_lat_init = 40., ! real , initial fire latitude (deg) + fire_lon_init = -105., ! real , initial fire longitude (deg) + fire_ign_time = 0.3, ! real , time of fire ignition (s) + fire_shape = 1, ! integer, initial fire shape + fire_sprd_mdl = 1, ! integer, = 0: Macarthur, = 1: BEHAVE + fire_crwn_hgt = 15., ! real , height of canopy crown (m) + fire_ext_grnd = 50., ! real , extinction coeff ground fire + fire_ext_crwn = 50., ! real , extinction coeff crown fire + fire_fuel_read = 1, ! integer, = 1: fuels specified; = 2: read from file + fire_fuel_cat = 8, ! integer, if specified which fuel category? +/ diff --git a/wrfv2_fire/test/em_fire/run_me_first.csh b/wrfv2_fire/test/em_fire/run_me_first.csh new file mode 100755 index 00000000..45fac592 --- /dev/null +++ b/wrfv2_fire/test/em_fire/run_me_first.csh @@ -0,0 +1,8 @@ +#!/bin/csh + +echo Setting up fire case by linking data files into this directory + +echo linking to RRTM_DATA in ../../run directory +ln -sf ../../run/RRTM_DATA . + +echo done diff --git a/wrfv2_fire/test/em_fire/wrf.out b/wrfv2_fire/test/em_fire/wrf.out new file mode 100644 index 00000000..d28b4af9 --- /dev/null +++ b/wrfv2_fire/test/em_fire/wrf.out @@ -0,0 +1,42350 @@ + WRF V2.2 MODEL + DYNAMICS OPTION: Eulerian Mass Coordinate + med_initialdata_input: calling input_model_input + STEPRA,STEPCU,STEPBL 1800 1 1 + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC + memory order = xyc XYC +Timing for Writing wrfout_d01_0001-01-01_00:00:00 for domain 1: 1.26000 elapsed seconds. + WRF NUMBER OF TILES = 1 + fire: dx,dy, dxf,dyf= 60.00000000 60.00000000 6.000000000 6.000000000 + fire_startup: ifuelread= 1 + tignm = -100.0000000 + t_ignite = 0.3333333507E-01 + time = 1.000000000 + diff = -0.9666666389 1.000000000 +Timing for main: time 0001-01-01_00:00:01 on domain 1: ********** elapsed seconds. + tignm = -100.0000000 + t_ignite = 0.3333333507E-01 + time = 2.000000000 + diff = -1.966666698 1.000000000 + FIRE IGNITION AT: TLAT_STF, TLON_STF= 0.6750000175E-02 0.6750000175E-02 + fire dist dom1 center (m): dxst,dyst= 0.0000000000E+00 0.0000000000E+00 + dist SW corner dom1 to center dom1 (m): xcntr,ycntr= 1260.000000 1260.000000 + coords fire rel to SW corner mod 1 (m): stx,sty: 1260.000000 1260.000000 + pos of sw corner of fire domain (m): xfx1,xfy1: 0.0000000000E+00 0.0000000000E+00 + Fire position relative to fire domain (m): 1260.000000 1260.000000 + Fire position in domain atm grid pts: 22 22 + Fire position in domain in fuel cells: 211 211 + Spot fire initialized with rad= 84.93766785 at 211 211 fuel cell location + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2835786939 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2835786939 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2835786939 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4217160344 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4247756600 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4217160344 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4217160344 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2835786939 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4217160344 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.4247756600 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.4247756600 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4247756600 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 203 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 203 201 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : ycd( 203 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : xcd( 221 201 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 221 202 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : ycd( 221 202 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 221 201 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 203 202 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 202 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : xcd( 203 202 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : ycd( 202 203 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 203 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 201 + in fire_ln: 8.2 : 203 202 + in fire_ln: 8.3 : 203 202 + in fire_ln: 8.3.1 : 202 201 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 203 202 + in fire_ln: 8.5 : 203 202 + in fire_ln: 8.5.1 : 203 202 + in fire_ln: 8.5.2 : 203 202 + in fire_ln: 8.5.3 : 203 202 + in fire_ln: 8.5.4 : 203 202 + in fire_ln: 8.5.5 : 203 202 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 203 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : ycd( 203 201 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 203 202 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 202 + in fire_ln: 8.6 : 203 202 + in fire_ln: 8.7 : 203 202 + in fire_ln: 8.8 : 203 202 + in fire_ln: 8.9 : 203 202 + in fire_ln: 8.10 : 203 202 + in fire_ln: 8.1 : 221 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 201 + in fire_ln: 8.2 : 221 202 + in fire_ln: 8.3 : 221 202 + in fire_ln: 8.3.1 : 222 201 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 221 202 + in fire_ln: 8.5 : 221 202 + in fire_ln: 8.5.1 : 221 202 + in fire_ln: 8.5.2 : 221 202 + in fire_ln: 8.5.3 : 221 202 + in fire_ln: 8.5.4 : 221 202 + in fire_ln: 8.5.5 : 221 202 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 202 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 221 202 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 221 202 + in fire_ln: 8.6 : 221 202 + in fire_ln: 8.7 : 221 202 + in fire_ln: 8.8 : 221 202 + in fire_ln: 8.9 : 221 202 + in fire_ln: 8.10 : 221 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 222 203 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 221 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : ycd( 222 203 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : xcd( 221 202 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 202 203 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : xcd( 202 203 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 203 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 202 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 202 203 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 202 + in fire_ln: 8.2 : 202 203 + in fire_ln: 8.3 : 202 203 + in fire_ln: 8.3.1 : 201 202 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 202 203 + in fire_ln: 8.5 : 202 203 + in fire_ln: 8.5.1 : 202 203 + in fire_ln: 8.5.2 : 202 203 + in fire_ln: 8.5.3 : 202 203 + in fire_ln: 8.5.4 : 202 203 + in fire_ln: 8.5.5 : 202 203 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 203 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 203 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 203 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 203 + in fire_ln: 8.6 : 202 203 + in fire_ln: 8.7 : 202 203 + in fire_ln: 8.8 : 202 203 + in fire_ln: 8.9 : 202 203 + in fire_ln: 8.10 : 202 203 + in fire_ln: 8.1 : 222 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 222 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 223 202 + in fire_ln: 8.2 : 222 203 + in fire_ln: 8.3 : 222 203 + in fire_ln: 8.3.1 : 223 202 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 222 203 + in fire_ln: 8.5 : 222 203 + in fire_ln: 8.5.1 : 222 203 + in fire_ln: 8.5.2 : 222 203 + in fire_ln: 8.5.3 : 222 203 + in fire_ln: 8.5.4 : 222 203 + in fire_ln: 8.5.5 : 222 203 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 203 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : xcd( 223 203 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 203 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 203 + in fire_ln: 8.6 : 222 203 + in fire_ln: 8.7 : 222 203 + in fire_ln: 8.8 : 222 203 + in fire_ln: 8.9 : 222 203 + in fire_ln: 8.10 : 222 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 222 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : xcd( 222 203 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : ycd( 201 203 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.4247756600 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.4247756600 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4247756600 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4217160344 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4247756600 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 225 208 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 225 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4217160344 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4217160344 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4217160344 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 225 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 208 + in fire_ln: 8.3 : 225 208 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 225 208 + in fire_ln: 8.5 : 225 208 + in fire_ln: 8.5.1 : 225 208 + in fire_ln: 8.5.2 : 225 208 + in fire_ln: 8.5.3 : 225 208 + in fire_ln: 8.5.4 : 225 208 + in fire_ln: 8.5.5 : 225 208 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2835786939 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 208 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 208 + in fire_ln: 8.6 : 225 208 + in fire_ln: 8.7 : 225 208 + in fire_ln: 8.8 : 225 208 + in fire_ln: 8.9 : 225 208 + in fire_ln: 8.10 : 225 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2835786939 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2835786939 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 225 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2835786939 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1474347115 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1474347115 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 225 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2835786939 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2835786939 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.7648497820E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2835786939 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.6649315357E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2835786939 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4217160344 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2835786939 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 225 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 217 + in fire_ln: 8.2 : 225 216 + in fire_ln: 8.3 : 225 216 + in fire_ln: 8.3.1 : 226 217 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 225 216 + in fire_ln: 8.5 : 225 216 + in fire_ln: 8.5.1 : 225 216 + in fire_ln: 8.5.2 : 225 216 + in fire_ln: 8.5.3 : 225 216 + in fire_ln: 8.5.4 : 225 216 + in fire_ln: 8.5.5 : 225 216 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 216 3 ) = 0.4217160344 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 216 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 216 + in fire_ln: 8.6 : 225 216 + in fire_ln: 8.7 : 225 216 + in fire_ln: 8.8 : 225 216 + in fire_ln: 8.9 : 225 216 + in fire_ln: 8.10 : 225 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 225 216 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : xcd( 225 216 3 ) = 0.4217160344 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4217160344 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.4247756600 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4247756600 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4217160344 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.4247756600 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.4271763563E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4247756600 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4247756600 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3178824186 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.3329455853E-02 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : ycd( 223 221 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 202 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : xcd( 202 221 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 202 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 202 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 201 222 + in fire_ln: 8.2 : 202 221 + in fire_ln: 8.3 : 202 221 + in fire_ln: 8.3.1 : 201 222 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 202 221 + in fire_ln: 8.5 : 202 221 + in fire_ln: 8.5.1 : 202 221 + in fire_ln: 8.5.2 : 202 221 + in fire_ln: 8.5.3 : 202 221 + in fire_ln: 8.5.4 : 202 221 + in fire_ln: 8.5.5 : 202 221 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 221 1 ) = -0.4951367378 + in fire_ln: 8.5.5 : xcd( 201 221 3 ) = -0.3178824186 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 221 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 221 + in fire_ln: 8.6 : 202 221 + in fire_ln: 8.7 : 202 221 + in fire_ln: 8.8 : 202 221 + in fire_ln: 8.9 : 202 221 + in fire_ln: 8.10 : 202 221 + in fire_ln: 8.1 : 222 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 222 221 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 222 + in fire_ln: 8.2 : 222 221 + in fire_ln: 8.3 : 222 221 + in fire_ln: 8.3.1 : 223 222 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 222 221 + in fire_ln: 8.5 : 222 221 + in fire_ln: 8.5.1 : 222 221 + in fire_ln: 8.5.2 : 222 221 + in fire_ln: 8.5.3 : 222 221 + in fire_ln: 8.5.4 : 222 221 + in fire_ln: 8.5.5 : 222 221 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 221 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 221 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 221 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 221 + in fire_ln: 8.6 : 222 221 + in fire_ln: 8.7 : 222 221 + in fire_ln: 8.8 : 222 221 + in fire_ln: 8.9 : 222 221 + in fire_ln: 8.10 : 222 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 222 221 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : xcd( 222 221 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 221 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 202 221 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 203 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : ycd( 202 221 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : xcd( 203 222 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 203 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 223 + in fire_ln: 8.2 : 203 222 + in fire_ln: 8.3 : 203 222 + in fire_ln: 8.3.1 : 202 223 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 203 222 + in fire_ln: 8.5 : 203 222 + in fire_ln: 8.5.1 : 203 222 + in fire_ln: 8.5.2 : 203 222 + in fire_ln: 8.5.3 : 203 222 + in fire_ln: 8.5.4 : 203 222 + in fire_ln: 8.5.5 : 203 222 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 222 1 ) = -0.4945818186 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.4951367378 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 203 222 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 203 222 + in fire_ln: 8.6 : 203 222 + in fire_ln: 8.7 : 203 222 + in fire_ln: 8.8 : 203 222 + in fire_ln: 8.9 : 203 222 + in fire_ln: 8.10 : 203 222 + in fire_ln: 8.1 : 221 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 223 + in fire_ln: 8.2 : 221 222 + in fire_ln: 8.3 : 221 222 + in fire_ln: 8.3.1 : 222 223 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 221 222 + in fire_ln: 8.5 : 221 222 + in fire_ln: 8.5.1 : 221 222 + in fire_ln: 8.5.2 : 221 222 + in fire_ln: 8.5.3 : 221 222 + in fire_ln: 8.5.4 : 221 222 + in fire_ln: 8.5.5 : 221 222 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 221 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : ycd( 221 223 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 221 222 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 222 + in fire_ln: 8.6 : 221 222 + in fire_ln: 8.7 : 221 222 + in fire_ln: 8.8 : 221 222 + in fire_ln: 8.9 : 221 222 + in fire_ln: 8.10 : 221 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 221 222 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 222 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : xcd( 221 222 3 ) = 0.4945818186 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : ycd( 222 221 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 203 222 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : ycd( 203 222 3 ) = 0.4951367378 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 203 223 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2476047873 + in fire_ln: 8.5.5 : xcd( 203 223 3 ) = -0.4945818186 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 221 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.4945818186 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.2476047873 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 221 223 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : ycd( 221 222 1 ) = 0.4951367378 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3178824186 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3622482419 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2476047873 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.4247756600 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.2476047873 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3622482419 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3178824186 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3622482419 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4247756600 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4247756600 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2394653559 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4217160344 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2835786939 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.2394653559 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4217160344 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.4247756600 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4217160344 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3622482419 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.4271763563E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.4247756600 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3329455853E-02 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4217160344 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2394653559 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2835786939 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2835786939 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1474347115 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1474347115 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2835786939 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.7648497820E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.2394653559 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.6649315357E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2835786939 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4217160344 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 72.68715668 9.534126282 18.58240318 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.228E-01 0.403E+01 0.113E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.228E-01 0.403E+01 0.113E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.303E-01 0.403E+01 0.477E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.303E-01 0.403E+01 0.477E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.396E-01 0.403E+01 0.932E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.396E-01 0.403E+01 0.932E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.508E-01 0.403E+01 0.148E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.508E-01 0.403E+01 0.148E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.566E-01 0.403E+01 0.177E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.589E-01 0.403E+01 0.188E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.589E-01 0.403E+01 0.188E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.741E-01 0.403E+01 0.262E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.741E-01 0.403E+01 0.262E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.911E-01 0.403E+01 0.345E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.916E-01 0.403E+01 0.347E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.916E-01 0.403E+01 0.347E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.949E-01 0.403E+01 0.363E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.101E+00 0.403E+01 0.394E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.101E+00 0.403E+01 0.394E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.107E+00 0.403E+01 0.421E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.111E+00 0.403E+01 0.441E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.111E+00 0.403E+01 0.441E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.112E+00 0.403E+01 0.448E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.123E+00 0.403E+01 0.498E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 202 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 202 0.130E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 202 0.130E+00 0.403E+01 0.533E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.130E+00 0.403E+01 0.533E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.138E+00 0.403E+01 0.574E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.146E+00 0.403E+01 0.613E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 203 0.146E+00 0.403E+01 0.613E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 203 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 203 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.152E+00 0.403E+01 0.644E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.159E+00 0.403E+01 0.679E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.159E+00 0.403E+01 0.679E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.161E+00 0.403E+01 0.687E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.162E+00 0.403E+01 0.692E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.162E+00 0.403E+01 0.692E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.165E+00 0.403E+01 0.707E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.176E+00 0.403E+01 0.760E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.176E+00 0.403E+01 0.760E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.176E+00 0.403E+01 0.762E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.187E+00 0.403E+01 0.812E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.187E+00 0.403E+01 0.812E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.194E+00 0.403E+01 0.849E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.194E+00 0.403E+01 0.849E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.195E+00 0.403E+01 0.854E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.195E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.195E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.202E+00 0.403E+01 0.885E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.202E+00 0.403E+01 0.885E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.202E+00 0.403E+01 0.885E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.202E+00 0.403E+01 0.885E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.195E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.195E+00 0.403E+01 0.854E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.194E+00 0.403E+01 0.849E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.195E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.194E+00 0.403E+01 0.849E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.187E+00 0.403E+01 0.812E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.187E+00 0.403E+01 0.812E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.176E+00 0.403E+01 0.760E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.176E+00 0.403E+01 0.762E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.176E+00 0.403E+01 0.760E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.162E+00 0.403E+01 0.692E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.161E+00 0.403E+01 0.687E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.159E+00 0.403E+01 0.679E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.165E+00 0.403E+01 0.707E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.162E+00 0.403E+01 0.692E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 221 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 221 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 221 0.146E+00 0.403E+01 0.613E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.159E+00 0.403E+01 0.679E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.152E+00 0.403E+01 0.644E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.146E+00 0.403E+01 0.614E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 222 0.130E+00 0.403E+01 0.533E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 222 0.130E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 222 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.146E+00 0.403E+01 0.613E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.138E+00 0.403E+01 0.574E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.130E+00 0.403E+01 0.533E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.112E+00 0.403E+01 0.448E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.111E+00 0.403E+01 0.441E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.123E+00 0.403E+01 0.498E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.101E+00 0.403E+01 0.394E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.949E-01 0.403E+01 0.363E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.916E-01 0.403E+01 0.347E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.111E+00 0.403E+01 0.441E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.107E+00 0.403E+01 0.421E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.101E+00 0.403E+01 0.394E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.589E-01 0.403E+01 0.188E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.566E-01 0.403E+01 0.177E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.741E-01 0.403E+01 0.262E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.589E-01 0.403E+01 0.188E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.741E-01 0.403E+01 0.262E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.916E-01 0.403E+01 0.347E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.911E-01 0.403E+01 0.345E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.228E-01 0.403E+01 0.113E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.303E-01 0.403E+01 0.477E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.228E-01 0.403E+01 0.113E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.396E-01 0.403E+01 0.932E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.303E-01 0.403E+01 0.477E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.508E-01 0.403E+01 0.148E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.396E-01 0.403E+01 0.932E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.508E-01 0.403E+01 0.148E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20539 0.02048 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 199, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 200, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 201, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 202, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 203, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 204, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 205, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 206, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 207, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 208, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 209, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 210, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 211, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 212, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 213, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 214, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 199 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 225 215, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 216, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 217, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 200 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 224 218, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 201 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 223 219, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 202 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 220, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 203 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 222 221, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 204 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 220 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 221 222, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 205 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 219 223, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 206 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 207 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 208 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 216 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 217 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 218 224, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 209 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 210 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 211 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 212 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 213 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 214 225, TIME = 2.00 + Warning 215- TMCRIT BURN_FRAC = 0.00 0.00, I J = 215 225, TIME = 2.00 + time (min)= 0.0333 AREA (acre)= 5.58348 + GRNDHX= 0.0000E+00 GRNDQX= 0.0000E+00 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.0000E+00 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:02 on domain 1: 5.19000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 3.000000000 + diff = -2.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2800888419 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4253602922 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1508500278 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1512362361 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1508500278 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1508500278 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.8155564219E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1512362361 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1512362361 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.5979500711E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.8155564219E-01 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1508500278 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.8155564219E-01 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2749276161 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.5979500711E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1512362361 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.2701731622 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.5979500711E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2749276161 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.8155564219E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2749276161 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4321899414 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.2701731622 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.5979500711E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4210135341 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4253602922 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4253602922 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4253602922 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2800888419 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.2701731622 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.5611554161E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4321899414 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2749276161 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4321899414 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.4108079076 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.2701731622 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.5611554161E-01 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3345618844 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.5611554161E-01 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.4108079076 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4321899414 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.4108079076 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3685831558E-02 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3345618844 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.5611554161E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4210135341 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3345618844 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.2736548781 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3685831558E-02 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.4108079076 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3685831558E-02 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3320827186 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.2736548781 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3345618844 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.2736548781 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4765657187 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3320827186 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3685831558E-02 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4730460644 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3320827186 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.2736548781 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4765657187 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4765657187 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4705305398 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4730460644 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3320827186 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 203 202 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 201 + in fire_ln: 8.2 : 203 202 + in fire_ln: 8.2.1 : 203 202 + in fire_ln: 8.3 : 203 202 + in fire_ln: 8.3.1 : 202 201 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 203 202 + in fire_ln: 8.4.1 : 203 202 + in fire_ln: 8.5 : 203 202 + in fire_ln: 8.5.1 : 203 202 + in fire_ln: 8.5.2 : 203 202 + in fire_ln: 8.5.3 : 203 202 + in fire_ln: 8.5.4 : 203 202 + in fire_ln: 8.5.5 : 203 202 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 203 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 203 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 203 202 2 ) = -0.4995707870 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 202 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 203 202 + in fire_ln: 8.6 : 203 202 + in fire_ln: 8.7 : 203 202 + in fire_ln: 8.8 : 203 202 + in fire_ln: 8.9 : 203 202 + in fire_ln: 8.10 : 203 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4730460644 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4720929861 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4705305398 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4765657187 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.3417874575 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4705305398 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4720929861 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4730460644 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 202 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 202 203 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 202 + in fire_ln: 8.2 : 202 203 + in fire_ln: 8.2.1 : 202 203 + in fire_ln: 8.3 : 202 203 + in fire_ln: 8.3.1 : 201 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 202 203 + in fire_ln: 8.4.1 : 202 203 + in fire_ln: 8.5 : 202 203 + in fire_ln: 8.5.1 : 202 203 + in fire_ln: 8.5.2 : 202 203 + in fire_ln: 8.5.3 : 202 203 + in fire_ln: 8.5.4 : 202 203 + in fire_ln: 8.5.5 : 202 203 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 203 1 ) = -0.4995707870 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 203 + in fire_ln: 8.6 : 202 203 + in fire_ln: 8.7 : 202 203 + in fire_ln: 8.8 : 202 203 + in fire_ln: 8.9 : 202 203 + in fire_ln: 8.10 : 202 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4720929861 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.2886843383 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.3417874575 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4705305398 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3220910728 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4999997914 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3220910728 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3417874575 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1708721928E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4720929861 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.2886843383 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.2886843383 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.3063211143 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1708721928E-01 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3417874575 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.4642394558E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1708721928E-01 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3946999311 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.3063211143 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.2886843383 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.7652620971E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.3063211143 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3946999311 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1708721928E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.4642394558E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4210135341 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4253603518 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3946999311 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4563131630 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.7652620971E-01 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.3063211143 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4253603518 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4210135341 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.4642394558E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 225 208 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.7652620971E-01 + in fire_ln: 8.5.5 : xcd( 225 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 3 ) = -0.3521033823 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4563131630 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3946999311 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4253603518 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.6302511692E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.4642394558E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4253603518 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 225 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 208 + in fire_ln: 8.3 : 225 208 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 225 208 + in fire_ln: 8.5 : 225 208 + in fire_ln: 8.5.1 : 225 208 + in fire_ln: 8.5.2 : 225 208 + in fire_ln: 8.5.3 : 225 208 + in fire_ln: 8.5.4 : 225 208 + in fire_ln: 8.5.5 : 225 208 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4563131630 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2600361407 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.7652620971E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 208 3 ) = -0.3521033823 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 208 + in fire_ln: 8.6 : 225 208 + in fire_ln: 8.7 : 225 208 + in fire_ln: 8.8 : 225 208 + in fire_ln: 8.9 : 225 208 + in fire_ln: 8.10 : 225 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = -0.3232746571E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.3521033823 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2600361407 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4563131630 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.6302511692E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2800888419 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.7991760969E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 225 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2600361407 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1107089594 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = -0.3232746571E-01 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.3521033823 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.7991760969E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2800888419 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.6302511692E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1508500278 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = -0.3232746571E-01 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.1816877872 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1107089594 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2600361407 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1508500278 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.6302511692E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.7991760969E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1508500129 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1107089594 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.1816877723 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.1816877872 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = -0.3232746571E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1508500129 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.7991760969E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1508500278 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.1816877872 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1107089221 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.1816877723 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1107089594 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1508500278 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1508500129 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.1816877723 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = -0.3232753277E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1107089221 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.1816877872 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1508500129 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 225 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1107089221 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2600362301 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = -0.3232753277E-01 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.1816877723 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2800888419 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.7991759479E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2489893585 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = -0.3232753277E-01 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.3521029353 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2600362301 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1107089221 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.6302513182E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2489893585 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2800888419 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4253602922 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4253602922 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2800888419 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2489893585 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 225 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 217 + in fire_ln: 8.2 : 225 216 + in fire_ln: 8.3 : 225 216 + in fire_ln: 8.3.1 : 226 217 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 225 216 + in fire_ln: 8.5 : 225 216 + in fire_ln: 8.5.1 : 225 216 + in fire_ln: 8.5.2 : 225 216 + in fire_ln: 8.5.3 : 225 216 + in fire_ln: 8.5.4 : 225 216 + in fire_ln: 8.5.5 : 225 216 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.7652612776E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.3521029353 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 216 3 ) = 0.4563131034 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2600362301 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 216 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 216 + in fire_ln: 8.6 : 225 216 + in fire_ln: 8.7 : 225 216 + in fire_ln: 8.8 : 225 216 + in fire_ln: 8.9 : 225 216 + in fire_ln: 8.10 : 225 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 225 216 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2600362301 + in fire_ln: 8.5.5 : xcd( 225 216 3 ) = 0.4563131034 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = -0.3232753277E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.3521029353 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2489893585 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4253602922 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4563131034 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3947000206 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.7652612776E-01 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.3521029353 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4210135341 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4253602922 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3584822416 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.7652612776E-01 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.3063212931 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3947000206 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4563131034 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.4642388225E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3584822416 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4210135341 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4210135341 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3584822416 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2534378171 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.3063212931 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.2886841595 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1708707027E-01 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3947000206 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3947000206 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1708707027E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.7652612776E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.3063212931 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2534378171 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3584822416 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3220910728 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.7265775464E-02 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2534378171 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4729172587 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.2886841595 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3417873383 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1708707027E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1708707027E-01 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3417873383 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.2886841595 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.3063212931 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2534378171 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4999997914 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 202 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 202 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 201 222 + in fire_ln: 8.2 : 202 221 + in fire_ln: 8.2.1 : 202 221 + in fire_ln: 8.3 : 202 221 + in fire_ln: 8.3.1 : 201 222 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 202 221 + in fire_ln: 8.4.1 : 202 221 + in fire_ln: 8.5 : 202 221 + in fire_ln: 8.5.1 : 202 221 + in fire_ln: 8.5.2 : 202 221 + in fire_ln: 8.5.3 : 202 221 + in fire_ln: 8.5.4 : 202 221 + in fire_ln: 8.5.5 : 202 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 221 2 ) = 0.4995707870 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4999997914 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 221 + in fire_ln: 8.6 : 202 221 + in fire_ln: 8.7 : 202 221 + in fire_ln: 8.8 : 202 221 + in fire_ln: 8.9 : 202 221 + in fire_ln: 8.10 : 202 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3417873383 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4690179229 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4729172587 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.2886841595 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3220910728 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4999997914 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4999997914 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4999997914 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 203 222 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 223 + in fire_ln: 8.2 : 203 222 + in fire_ln: 8.2.1 : 203 222 + in fire_ln: 8.3 : 203 222 + in fire_ln: 8.3.1 : 202 223 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 222 + in fire_ln: 8.4.1 : 203 222 + in fire_ln: 8.5 : 203 222 + in fire_ln: 8.5.1 : 203 222 + in fire_ln: 8.5.2 : 203 222 + in fire_ln: 8.5.3 : 203 222 + in fire_ln: 8.5.4 : 203 222 + in fire_ln: 8.5.5 : 203 222 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 222 1 ) = -0.4995707870 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 203 222 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 203 222 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3220910728 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 203 222 + in fire_ln: 8.6 : 203 222 + in fire_ln: 8.7 : 203 222 + in fire_ln: 8.8 : 203 222 + in fire_ln: 8.9 : 203 222 + in fire_ln: 8.10 : 203 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4690179229 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4758977294 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4743214250 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4729172587 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4729172587 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4743214250 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3417873383 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4690179229 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4999997914 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4999997914 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3220910728 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4999997914 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3220910728 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4999997914 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2534378171 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4999997914 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3220910728 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.7265775464E-02 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3320826590 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3685831558E-02 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.2736548483 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4758977294 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.2736548483 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4758977294 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4743214250 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3320826590 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4743214250 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3320826590 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4758977294 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4690179229 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.7265775464E-02 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3220910728 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3584822416 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2534378171 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.7265775464E-02 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4210135341 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3685831558E-02 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.4108079076 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3345618248 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.2736548483 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.2736548483 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3345618248 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3685831558E-02 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3320826590 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4210135341 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.7265775464E-02 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.4642394558E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3584822416 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.4642394558E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4210135341 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4253603518 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4253603518 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4210135341 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.4642394558E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2489893585 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.4642394558E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4253603518 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2800888419 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4321899116 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2749275863 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.2701733410 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.5611554161E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.2701733410 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.5611554161E-01 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4321899116 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.4108079076 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.4108079076 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4321899116 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3345618248 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.5611554161E-01 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3345618248 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.5611554161E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.4108079076 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3685831558E-02 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2800888419 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4253603518 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.6302511692E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2489893585 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.6302511692E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2800888419 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.7991760969E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.7991760969E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2800888419 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.6302511692E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1508500427 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1508500427 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.6302511692E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.7991760969E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1512362808 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1512362808 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.7991760969E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1508500427 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.8155567944E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.8155567944E-01 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1508500427 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1512362808 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.5979498103E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.5979498103E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1512362808 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.8155567944E-01 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2749275863 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2749275863 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.8155567944E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.2701733410 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.5979498103E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.2701733410 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.5979498103E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2749275863 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4321899116 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 201.1824493 0.4294514656E-03 22.27439499 116.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.227E-01 0.403E+01 0.110E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.227E-01 0.403E+01 0.110E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.301E-01 0.403E+01 0.469E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.301E-01 0.403E+01 0.469E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.393E-01 0.403E+01 0.920E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.393E-01 0.403E+01 0.920E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.505E-01 0.403E+01 0.147E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.505E-01 0.403E+01 0.147E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.554E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.558E-01 0.403E+01 0.172E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.558E-01 0.403E+01 0.172E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.559E-01 0.403E+01 0.173E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.580E-01 0.403E+01 0.183E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.580E-01 0.403E+01 0.183E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.738E-01 0.403E+01 0.261E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.738E-01 0.403E+01 0.261E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.887E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.887E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.901E-01 0.403E+01 0.340E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.913E-01 0.403E+01 0.346E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.913E-01 0.403E+01 0.346E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.973E-01 0.403E+01 0.375E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.101E+00 0.403E+01 0.392E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.101E+00 0.403E+01 0.392E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.104E+00 0.403E+01 0.408E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.112E+00 0.403E+01 0.447E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.112E+00 0.403E+01 0.447E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.116E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.116E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.127E+00 0.403E+01 0.519E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.127E+00 0.403E+01 0.519E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.127E+00 0.403E+01 0.520E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.127E+00 0.403E+01 0.522E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.127E+00 0.403E+01 0.522E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.138E+00 0.403E+01 0.573E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.142E+00 0.403E+01 0.593E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.593E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.594E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.596E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.142E+00 0.403E+01 0.596E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.159E+00 0.403E+01 0.675E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.167E+00 0.403E+01 0.715E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.172E+00 0.403E+01 0.739E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.176E+00 0.403E+01 0.758E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.176E+00 0.403E+01 0.758E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.763E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.768E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.178E+00 0.403E+01 0.768E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.195E+00 0.403E+01 0.852E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.195E+00 0.403E+01 0.852E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.196E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.197E+00 0.403E+01 0.860E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.202E+00 0.403E+01 0.884E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.202E+00 0.403E+01 0.884E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.202E+00 0.403E+01 0.884E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.202E+00 0.403E+01 0.884E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.196E+00 0.403E+01 0.855E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.195E+00 0.403E+01 0.852E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.197E+00 0.403E+01 0.860E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.196E+00 0.403E+01 0.856E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.195E+00 0.403E+01 0.852E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.178E+00 0.403E+01 0.768E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.176E+00 0.403E+01 0.758E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.172E+00 0.403E+01 0.739E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.768E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.763E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.176E+00 0.403E+01 0.758E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.159E+00 0.403E+01 0.675E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.167E+00 0.403E+01 0.715E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.148E+00 0.403E+01 0.624E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 222 0.205E-01 0.403E+01 0.702E-05 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.148E+00 0.403E+01 0.621E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.138E+00 0.403E+01 0.572E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.133E+00 0.403E+01 0.550E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.148E+00 0.403E+01 0.624E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.148E+00 0.403E+01 0.623E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.148E+00 0.403E+01 0.621E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.116E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.112E+00 0.403E+01 0.447E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.133E+00 0.403E+01 0.548E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.116E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.133E+00 0.403E+01 0.550E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.133E+00 0.403E+01 0.550E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.133E+00 0.403E+01 0.548E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.101E+00 0.403E+01 0.392E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.973E-01 0.403E+01 0.375E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.913E-01 0.403E+01 0.346E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.112E+00 0.403E+01 0.447E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.104E+00 0.403E+01 0.408E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.101E+00 0.403E+01 0.392E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.580E-01 0.403E+01 0.183E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.559E-01 0.403E+01 0.173E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.558E-01 0.403E+01 0.172E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.738E-01 0.403E+01 0.261E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.580E-01 0.403E+01 0.183E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.887E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.738E-01 0.403E+01 0.261E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.913E-01 0.403E+01 0.346E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.901E-01 0.403E+01 0.340E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.887E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.227E-01 0.403E+01 0.110E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.301E-01 0.403E+01 0.469E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.227E-01 0.403E+01 0.110E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.393E-01 0.403E+01 0.920E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.301E-01 0.403E+01 0.469E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.505E-01 0.403E+01 0.147E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.393E-01 0.403E+01 0.920E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.558E-01 0.403E+01 0.172E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.505E-01 0.403E+01 0.147E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20539 0.02048 + time (min)= 0.0500 AREA (acre)= 5.59279 + GRNDHX= 0.5348E+05 GRNDQX= 0.4908E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1489E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:03 on domain 1: 5.12000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 4.000000000 + diff = -3.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2765990496 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4290039539 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1542653590 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1550259143 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1542653590 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1542653590 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.8659692109E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1550259143 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1550259143 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.5313952267E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.8659692109E-01 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1542653590 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.8659692109E-01 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2663257122 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.5313952267E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1550259143 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3027061224 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.5313952267E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2663257122 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.8659692109E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2663257122 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4424844682 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3027061224 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.5313952267E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4172531962 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4290039539 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4290039539 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4290039539 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2765990496 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3027061224 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.6945887208E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4424844682 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2663257122 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4424844682 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3972527683 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3027061224 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.6945887208E-01 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3073444068 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.6945887208E-01 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3972527683 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4424844682 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3972527683 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1695093326E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.3073444068 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.6945887208E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3265041113 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4172531962 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3073444068 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3034755588 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1695093326E-01 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3972527683 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1695093326E-01 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3568171561 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3034755588 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.3073444068 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3265041113 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4956868291 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4956868291 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3265041113 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3265041113 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4956868291 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3034755588 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4498258531 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3568171561 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1695093326E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4446619451 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3568171561 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3034755588 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4498258531 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4498258531 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4379503727 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4446619451 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3568171561 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4957376122 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3265043795 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4956868291 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4957376122 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4446619451 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4424675703 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4379503727 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4498258531 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.3757288158 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4379503727 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4424675703 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4446619451 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3265043795 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4957376122 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4424675703 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.3330703378 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.3757288158 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4379503727 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3265043795 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4957376122 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3265043795 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3757288158 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.4402362928E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4424675703 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.3330703378 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.3330703378 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.2510962784 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.4402362928E-01 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.3757288158 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5013016239E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.4402362928E-01 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3651503623 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.2510962784 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.3330703378 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1103323102 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.2510962784 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3651503623 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.4402362928E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5013016239E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4172531962 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4290040433 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3651503623 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4910180569 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1103323102 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.2510962784 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4290040433 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4172531962 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5013016239E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 225 208 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1103323102 + in fire_ln: 8.5.5 : xcd( 225 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 2 ) = -0.3883402050 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.4910180569 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3651503623 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4290040433 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5955709890E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5013016239E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4290040433 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 225 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 208 + in fire_ln: 8.2.1 : 225 208 + in fire_ln: 8.3 : 225 208 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 225 208 + in fire_ln: 8.4.1 : 225 208 + in fire_ln: 8.5 : 225 208 + in fire_ln: 8.5.1 : 225 208 + in fire_ln: 8.5.2 : 225 208 + in fire_ln: 8.5.3 : 225 208 + in fire_ln: 8.5.4 : 225 208 + in fire_ln: 8.5.5 : 225 208 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4910180569 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2342012078 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1103323102 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 208 2 ) = -0.3883402050 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 208 + in fire_ln: 8.6 : 225 208 + in fire_ln: 8.7 : 225 208 + in fire_ln: 8.8 : 225 208 + in fire_ln: 8.9 : 225 208 + in fire_ln: 8.10 : 225 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 225 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1834126306E-02 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.3883402050 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 3 ) = -0.2342012078 + in fire_ln: 8.5.5 : xcd( 225 208 1 ) = 0.4910180569 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5955709890E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2765990496 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.8335022628E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2342012078 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1449334323 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1834126306E-02 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.3883402050 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.8335022628E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2765990496 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5955709890E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1542653292 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1834126306E-02 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2159413397 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1449334323 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2342012078 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1542653292 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5955709890E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.8335022628E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1542653143 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1449334323 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2159413397 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2159413397 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1834126306E-02 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1542653143 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.8335022628E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1542653292 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2159413397 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1449334621 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2159413397 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1449334323 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1542653292 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1542653143 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2159413397 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1834159251E-02 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1449334621 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2159413397 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1542653143 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1449334621 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2342012078 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1834159251E-02 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2159413397 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2765990496 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.8335020393E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2607523799 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1834159251E-02 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.3883401752 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2342012078 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1449334621 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5955713987E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2607523799 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2765990496 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4290039539 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4290039539 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2765990496 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2607523799 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 225 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 217 + in fire_ln: 8.2 : 225 216 + in fire_ln: 8.2.1 : 225 216 + in fire_ln: 8.3 : 225 216 + in fire_ln: 8.3.1 : 226 217 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 225 216 + in fire_ln: 8.4.1 : 225 216 + in fire_ln: 8.5 : 225 216 + in fire_ln: 8.5.1 : 225 216 + in fire_ln: 8.5.2 : 225 216 + in fire_ln: 8.5.3 : 225 216 + in fire_ln: 8.5.4 : 225 216 + in fire_ln: 8.5.5 : 225 216 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1103323773 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.3883401752 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 216 2 ) = 0.4910181165 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2342012078 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 216 + in fire_ln: 8.6 : 225 216 + in fire_ln: 8.7 : 225 216 + in fire_ln: 8.8 : 225 216 + in fire_ln: 8.9 : 225 216 + in fire_ln: 8.10 : 225 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 225 216 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2342012078 + in fire_ln: 8.5.5 : xcd( 225 216 2 ) = 0.4910181165 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1834159251E-02 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 3 ) = 0.3883401752 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2607523799 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4290039539 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 225 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4910181165 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3651503325 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1103323773 + in fire_ln: 8.5.5 : xcd( 225 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 216 1 ) = 0.3883401752 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4172531962 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4290039539 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3530553877 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1103323773 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.2510962188 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3651503325 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.4910181165 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5013004690E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3530553877 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4172531962 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4172531962 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3530553877 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2592708170 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.2510962188 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.3330703378 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.4402359948E-01 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3651503325 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3651503325 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.4402359948E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1103323773 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.2510962188 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2592708170 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3530553877 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3265041113 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3265041113 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1120224502E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4956868291 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2592708170 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4414879084 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.3330703378 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3757191002 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.4402359948E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.4402359948E-01 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.3757191002 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.3330703378 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.2510962188 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4956868291 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2592708170 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3265041113 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4951728284 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3757191002 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4363908768 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4414879084 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.3330703378 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3265041113 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4951728284 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4956868291 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4951728284 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4956868291 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4951728284 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4957680106 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4363908768 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4483911693 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4435463846 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4414879084 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4414879084 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4435463846 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.3757191002 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4363908768 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4957680106 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4951728284 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3265044987 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4951728284 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3265044987 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4957680106 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2592708170 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4957680106 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3265044987 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1120224502E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3567930758 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.1695120148E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3034758866 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4483911693 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3034758866 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4483911693 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4435463846 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3567930758 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4435463846 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3567930758 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4483911693 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4363908768 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1120224502E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3265044987 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3530553877 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2592708170 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1120224502E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4172531962 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.1695120148E-01 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3972524703 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3073438108 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3034758866 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3034758866 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.3073438108 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.1695120148E-01 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3567930758 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4172531962 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1120224502E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5013016239E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3530553877 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5013016239E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4172531962 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4290040433 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4290040433 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4172531962 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5013016239E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2607523799 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5013016239E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4290040433 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2765990496 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4424847960 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2663252950 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3027076423 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.6945918500E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3027076423 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.6945918500E-01 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4424847960 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3972524703 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3972524703 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4424847960 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3073438108 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.6945918500E-01 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.3073438108 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.6945918500E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3972524703 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.1695120148E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2765990496 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4290040433 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5955709890E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2607523799 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5955709890E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2765990496 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.8335022628E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.8335022628E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2765990496 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5955709890E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1542653888 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1542653888 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5955709890E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.8335022628E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1550262272 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1550262272 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.8335022628E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1542653888 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.8659730107E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.8659730107E-01 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1542653888 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1550262272 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.5313913524E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.5313913524E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1550262272 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.8659730107E-01 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2663252950 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2663252950 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.8659730107E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3027076423 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.5313913524E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3027076423 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.5313913524E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2663252950 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4424847960 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 183.4158173 1.041533232 21.63228035 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.227E-01 0.403E+01 0.106E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.227E-01 0.403E+01 0.106E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.299E-01 0.403E+01 0.461E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.299E-01 0.403E+01 0.461E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.391E-01 0.403E+01 0.909E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.391E-01 0.403E+01 0.909E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.502E-01 0.403E+01 0.145E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.502E-01 0.403E+01 0.145E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.572E-01 0.403E+01 0.179E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.572E-01 0.403E+01 0.179E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.736E-01 0.403E+01 0.259E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.736E-01 0.403E+01 0.259E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.879E-01 0.403E+01 0.329E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.879E-01 0.403E+01 0.329E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.894E-01 0.403E+01 0.336E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.909E-01 0.403E+01 0.344E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.909E-01 0.403E+01 0.344E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.977E-01 0.403E+01 0.377E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.100E+00 0.403E+01 0.390E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.100E+00 0.403E+01 0.390E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.103E+00 0.403E+01 0.404E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.113E+00 0.403E+01 0.451E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.137E+00 0.403E+01 0.571E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.143E+00 0.403E+01 0.600E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.600E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.144E+00 0.403E+01 0.602E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.144E+00 0.403E+01 0.605E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.144E+00 0.403E+01 0.605E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.158E+00 0.403E+01 0.673E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.158E+00 0.403E+01 0.673E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.159E+00 0.403E+01 0.677E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.167E+00 0.403E+01 0.716E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.171E+00 0.403E+01 0.736E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.175E+00 0.403E+01 0.757E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.175E+00 0.403E+01 0.757E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.763E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 208 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.195E+00 0.403E+01 0.854E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.197E+00 0.403E+01 0.863E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.197E+00 0.403E+01 0.863E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.883E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.883E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.903E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.883E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.883E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.197E+00 0.403E+01 0.863E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 216 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.197E+00 0.403E+01 0.863E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.195E+00 0.403E+01 0.854E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.204E+00 0.403E+01 0.897E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.175E+00 0.403E+01 0.757E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.171E+00 0.403E+01 0.736E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.763E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.175E+00 0.403E+01 0.757E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.159E+00 0.403E+01 0.677E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.158E+00 0.403E+01 0.673E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.727E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.167E+00 0.403E+01 0.716E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.161E+00 0.403E+01 0.684E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.158E+00 0.403E+01 0.673E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.145E+00 0.403E+01 0.607E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.144E+00 0.403E+01 0.603E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.137E+00 0.403E+01 0.571E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.131E+00 0.403E+01 0.541E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.145E+00 0.403E+01 0.607E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.144E+00 0.403E+01 0.605E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.144E+00 0.403E+01 0.603E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.113E+00 0.403E+01 0.451E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.130E+00 0.403E+01 0.537E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.114E+00 0.403E+01 0.458E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.541E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.540E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.130E+00 0.403E+01 0.537E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.100E+00 0.403E+01 0.390E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.977E-01 0.403E+01 0.377E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.909E-01 0.403E+01 0.344E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.103E+00 0.403E+01 0.404E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.100E+00 0.403E+01 0.390E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.572E-01 0.403E+01 0.179E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.736E-01 0.403E+01 0.259E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.572E-01 0.403E+01 0.179E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.879E-01 0.403E+01 0.329E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.736E-01 0.403E+01 0.259E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.909E-01 0.403E+01 0.344E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.894E-01 0.403E+01 0.336E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.879E-01 0.403E+01 0.329E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.227E-01 0.403E+01 0.106E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.299E-01 0.403E+01 0.461E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.227E-01 0.403E+01 0.106E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.391E-01 0.403E+01 0.908E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.299E-01 0.403E+01 0.461E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.502E-01 0.403E+01 0.145E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.391E-01 0.403E+01 0.908E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.502E-01 0.403E+01 0.145E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20538 0.02048 + time (min)= 0.0667 AREA (acre)= 5.60315 + GRNDHX= 0.5596E+05 GRNDQX= 0.5136E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1512E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:04 on domain 1: 5.12000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 5.000000000 + diff = -4.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2731092572 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4326473176 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.8678280562E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1576807201 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.8678280562E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.8678280562E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1588040739 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1576807201 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1576807201 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.9160919487E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1588040739 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.8678280562E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1588040739 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.4652647674E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.9160919487E-01 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1576807201 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.9160919487E-01 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2577830851 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.4652647674E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1588040739 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3353833854 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.4652647674E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2577830851 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.9160919487E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2577830851 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4526338279 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3353833854 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.4652647674E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4134936929 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4326473176 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4326473176 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4326473176 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2731092572 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3353833854 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.8275005966E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4526338279 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2577830851 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4526338279 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3840219378 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3353833854 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.8275005966E-01 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2800898850 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.8275005966E-01 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3840219378 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4526338279 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3840219378 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3453161940E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2800898850 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.8275005966E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3309167624 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4134936929 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2800898850 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3364436328 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.3453161940E-01 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3840219378 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3453161940E-01 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3812154233 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3364436328 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2800898850 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4906082153 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3309167624 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4913574755 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4906350672 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4913574755 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4906082153 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3309167624 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3309167624 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4913574755 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3364436328 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4234393835 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.3812154233 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.3453161940E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4158075452 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3812154233 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3364436328 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.4234393835 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4234393835 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4064640701 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.4158075452 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.3812154233 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4913944602 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4906082153 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3309172690 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4906350672 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4906350672 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4913574755 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4906082153 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4913944602 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4158075452 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4130316377 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.4064640701 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.4234393835 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4098232388 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4064640701 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.4130316377 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.4158075452 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3309172690 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4906350672 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4913944602 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4130316377 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.3804226220 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4098232388 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.4064640701 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3309172690 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4913944602 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3309172690 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4098232388 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.7497986406E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.4130316377 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.3804226220 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.3804226220 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.1960617006 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.7497986406E-01 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4098232388 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5383630469E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.7497986406E-01 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3359467983 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.1960617006 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.3804226220 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1441358924 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.1960617006 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3359467983 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.7497986406E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5383630469E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4134936929 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4326474369 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3359467983 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.4314357936 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1441358924 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.1960617006 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4326474369 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4134936929 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5383630469E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.2.1 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 226 207 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.4.1 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1441358924 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4737619460 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3359467983 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.4314357936 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 226 207 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 208 + in fire_ln: 8.2 : 226 207 + in fire_ln: 8.3 : 226 207 + in fire_ln: 8.3.1 : 225 208 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 226 207 + in fire_ln: 8.5 : 226 207 + in fire_ln: 8.5.1 : 226 207 + in fire_ln: 8.5.2 : 226 207 + in fire_ln: 8.5.3 : 226 207 + in fire_ln: 8.5.4 : 226 207 + in fire_ln: 8.5.5 : 226 207 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.2100850344 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.4314357936 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4737619460 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1441358924 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 207 + in fire_ln: 8.6 : 226 207 + in fire_ln: 8.7 : 226 207 + in fire_ln: 8.8 : 226 207 + in fire_ln: 8.9 : 226 207 + in fire_ln: 8.10 : 226 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4326474369 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5608909577E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5383630469E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4326474369 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4737619460 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.3599087894E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.2100850344 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.4314357936 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5608909577E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2731092572 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.8678284287E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2100850344 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1791560352 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.3599087894E-01 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4737619460 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.8678284287E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2731092572 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5608909577E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1576806307 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.3599087894E-01 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2501929104 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.1791560352 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.2100850344 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1576806307 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5608909577E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.8678284287E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1576806009 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1791560352 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2501928806 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2501929104 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.3599087894E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1576806009 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.8678284287E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1576806307 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.8678281307E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2501929104 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1791559756 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2501928806 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.1791560352 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.8678281307E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1576806307 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1576806009 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2501928806 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.3599074855E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.1791559756 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2501929104 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1576806009 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.8678281307E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1791559756 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2100852728 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.3599074855E-01 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2501928806 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2731092572 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.8678281307E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2727992535 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.3599074855E-01 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4737619460 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.2100852728 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.1791559756 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5608914793E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2727992535 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2731092572 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4326473176 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4326473176 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2731092572 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2727992535 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 226 217 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2100852728 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.4314362109 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4737619460 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.3599074855E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2727992535 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4326473176 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.2.1 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.4.1 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3359472752 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.4314362109 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1441355944 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4737619460 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 226 217 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 217 + in fire_ln: 8.3 : 226 217 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 226 217 + in fire_ln: 8.5 : 226 217 + in fire_ln: 8.5.1 : 226 217 + in fire_ln: 8.5.2 : 226 217 + in fire_ln: 8.5.3 : 226 217 + in fire_ln: 8.5.4 : 226 217 + in fire_ln: 8.5.5 : 226 217 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4737619460 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1441355944 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.2100852728 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.4314362109 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 217 + in fire_ln: 8.6 : 226 217 + in fire_ln: 8.7 : 226 217 + in fire_ln: 8.8 : 226 217 + in fire_ln: 8.9 : 226 217 + in fire_ln: 8.10 : 226 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4134936929 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4326473176 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3469053209 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1441355944 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.1960626841 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3359472752 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.4314362109 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5383616686E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3469053209 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4134936929 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4134936929 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3469053209 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2651038468 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.1960626841 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.3804199994 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.7497923821E-01 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3359472752 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3359472752 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.7497923821E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1441355944 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.1960626841 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2651038468 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3469053209 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3309167624 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3309167624 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1513880305E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4913574755 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2651038468 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4118832052 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.3804199994 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.4097964168 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.7497923821E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.7497923821E-01 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.4097964168 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.3804199994 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.1960626841 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4913574755 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2651038468 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3309167624 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4906082153 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4097964168 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4052000046 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.4118832052 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.3804199994 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3309167624 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4906082153 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4913574755 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4906511903 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4906511903 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4913574755 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4906082153 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4914166331 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4052000046 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4220522642 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4144884944 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4118832052 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.4118832052 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.4144884944 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4097964168 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.4052000046 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4914166331 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4906082153 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4906511903 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3309174478 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4906511903 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3309174478 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4914166331 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2651038468 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4914166331 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3309174478 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1513880305E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3811699152 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3453093395E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3364459574 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4220522642 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3364459574 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.4220522642 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4144884944 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3811699152 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.4144884944 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.3811699152 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.4220522642 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.4052000046 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1513880305E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3309174478 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3469053209 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2651038468 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1513880305E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4134936929 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3453093395E-01 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3840225935 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2800910175 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3364459574 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3364459574 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2800910175 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.3453093395E-01 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.3811699152 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4134936929 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1513880305E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5383630469E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3469053209 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5383630469E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4134936929 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4326474369 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4326474369 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4134936929 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5383630469E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2727992535 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5383630469E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4326474369 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2731092572 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4526332319 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2577835321 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3353818357 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.8274935186E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3353818357 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.8274935186E-01 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4526332319 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3840225935 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3840225935 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4526332319 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2800910175 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.8274935186E-01 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2800910175 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.8274935186E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3840225935 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.3453093395E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2731092572 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4326474369 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5608909577E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2727992535 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5608909577E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2731092572 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.8678284287E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.8678284287E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2731092572 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5608909577E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1576807499 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1576807499 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5608909577E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.8678284287E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1588039100 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1588039100 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.8678284287E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1576807499 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.9160890430E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.9160890430E-01 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1576807499 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1588039100 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.4652690515E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.4652690515E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1588039100 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.9160890430E-01 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2577835321 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2577835321 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.9160890430E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3353818357 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.4652690515E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3353818357 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.4652690515E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2577835321 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4526332319 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 988.2321777 5.151081085 46.10538864 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.226E-01 0.403E+01 0.103E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.226E-01 0.403E+01 0.103E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.298E-01 0.403E+01 0.453E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.298E-01 0.403E+01 0.453E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.389E-01 0.403E+01 0.897E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.389E-01 0.403E+01 0.897E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.499E-01 0.403E+01 0.143E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.499E-01 0.403E+01 0.143E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.551E-01 0.403E+01 0.169E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.549E-01 0.403E+01 0.168E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.549E-01 0.403E+01 0.168E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.548E-01 0.403E+01 0.168E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.564E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.564E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.734E-01 0.403E+01 0.258E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.734E-01 0.403E+01 0.258E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.871E-01 0.403E+01 0.325E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.871E-01 0.403E+01 0.325E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.886E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.905E-01 0.403E+01 0.342E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.905E-01 0.403E+01 0.342E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.975E-01 0.403E+01 0.376E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.100E+00 0.403E+01 0.388E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.100E+00 0.403E+01 0.388E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.103E+00 0.403E+01 0.401E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.113E+00 0.403E+01 0.450E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.537E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.540E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.131E+00 0.403E+01 0.540E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.137E+00 0.403E+01 0.570E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.601E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.158E+00 0.403E+01 0.670E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.158E+00 0.403E+01 0.672E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.159E+00 0.403E+01 0.678E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.159E+00 0.403E+01 0.678E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.167E+00 0.403E+01 0.716E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.726E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.726E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.171E+00 0.403E+01 0.734E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.175E+00 0.403E+01 0.755E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.175E+00 0.403E+01 0.755E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.764E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.190E+00 0.403E+01 0.829E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.190E+00 0.403E+01 0.829E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.867E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.190E+00 0.403E+01 0.829E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.190E+00 0.403E+01 0.829E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.190E+00 0.403E+01 0.826E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.175E+00 0.403E+01 0.755E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.171E+00 0.403E+01 0.734E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.726E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.764E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.175E+00 0.403E+01 0.755E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.159E+00 0.403E+01 0.678E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.158E+00 0.403E+01 0.672E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.158E+00 0.403E+01 0.669E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.726E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.167E+00 0.403E+01 0.715E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.159E+00 0.403E+01 0.678E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.158E+00 0.403E+01 0.669E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.143E+00 0.403E+01 0.597E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.137E+00 0.403E+01 0.569E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.131E+00 0.403E+01 0.541E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.600E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.597E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.113E+00 0.403E+01 0.450E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.541E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.999E-01 0.403E+01 0.388E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.974E-01 0.403E+01 0.376E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.904E-01 0.403E+01 0.341E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.111E+00 0.403E+01 0.442E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.103E+00 0.403E+01 0.401E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.999E-01 0.403E+01 0.388E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.547E-01 0.403E+01 0.167E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.548E-01 0.403E+01 0.167E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.733E-01 0.403E+01 0.258E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.563E-01 0.403E+01 0.175E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.870E-01 0.403E+01 0.325E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.733E-01 0.403E+01 0.258E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.904E-01 0.403E+01 0.341E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.885E-01 0.403E+01 0.332E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.870E-01 0.403E+01 0.325E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.226E-01 0.403E+01 0.101E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.297E-01 0.403E+01 0.450E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.226E-01 0.403E+01 0.101E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.388E-01 0.403E+01 0.894E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.297E-01 0.403E+01 0.450E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.498E-01 0.403E+01 0.143E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.388E-01 0.403E+01 0.894E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.548E-01 0.403E+01 0.167E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.550E-01 0.403E+01 0.169E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.498E-01 0.403E+01 0.143E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20528 0.02048 + time (min)= 0.0833 AREA (acre)= 5.61270 + GRNDHX= 0.5815E+05 GRNDQX= 0.5337E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1466E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:05 on domain 1: 5.11000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 6.000000000 + diff = -5.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2696194649 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4362903833 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2696194649 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9021540731E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1610961109 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9021540731E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2696194649 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9021540731E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1625718474 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1610961109 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1610961109 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.9659387171E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1625718474 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9021540731E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1625718474 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.3995462507E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.9659387171E-01 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1610961109 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.9659387171E-01 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2492991984 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.3995462507E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1625718474 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3679920733 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.3995462507E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2492991984 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.9659387171E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2492991984 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4626288414 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3679920733 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.3995462507E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4097344875 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4097344875 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4362903833 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4362903833 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4097344875 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4362903833 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2696194649 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3679920733 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.9599070996E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 3 ) = -0.4626288414 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2492991984 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4626288414 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3710218072 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3679920733 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.9599070996E-01 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2525685132 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.9599070996E-01 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3710218072 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4626288414 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3710218072 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.5374672264E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2525685132 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.9599070996E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3353294432 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4097344875 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2525685132 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3706962466 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.5374672264E-01 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3710218072 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.5374672264E-01 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.4054903686 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.3706962466 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2525685132 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4861516654 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3353294432 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4871736765 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4861832857 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4871736765 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4861516654 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3353294432 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3353294432 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4871736765 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3706962466 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3978535533 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.4054903686 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.5374672264E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3873747587 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4054903686 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.3706962466 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3978535533 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3978535533 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3758578598 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3873747587 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4054903686 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4872065783 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4861516654 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3353300989 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4861832857 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4861832857 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4871736765 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4861516654 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4872065783 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3873747587 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3842654228 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3758578598 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3978535533 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4438602328 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3758578598 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3842654228 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3873747587 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3353300989 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4861832857 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4872065783 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3842654228 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.4282657802 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4438602328 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3758578598 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3353300989 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4872065783 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3353300989 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4438602328 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1074853987 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3842654228 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 3 ) = -0.4282657802 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.4282657802 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.1407596320 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1074853987 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4438602328 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4097344577 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5754237995E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4097344577 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1074853987 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3069016635 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.1407596320 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.4282657802 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1779389977 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.1407596320 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.3069016635 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1074853987 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.5754237995E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4097344577 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4362905920 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3069016635 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.3430350721 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.1779389977 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.1407596320 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4362905920 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4097344577 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5754237995E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.2.1 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 226 207 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.4.1 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1779389977 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4431126714 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.3069016635 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.3430350721 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 226 207 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 208 + in fire_ln: 8.2 : 226 207 + in fire_ln: 8.3 : 226 207 + in fire_ln: 8.3.1 : 225 208 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 226 207 + in fire_ln: 8.5 : 226 207 + in fire_ln: 8.5.1 : 226 207 + in fire_ln: 8.5.2 : 226 207 + in fire_ln: 8.5.3 : 226 207 + in fire_ln: 8.5.4 : 226 207 + in fire_ln: 8.5.5 : 226 207 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1760262102 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.3430350721 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4431126714 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.1779389977 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 207 + in fire_ln: 8.6 : 226 207 + in fire_ln: 8.7 : 226 207 + in fire_ln: 8.8 : 226 207 + in fire_ln: 8.9 : 226 207 + in fire_ln: 8.10 : 226 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2696194351 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4362905920 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5262111872E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.5754237995E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4362905920 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2696194351 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4431126714 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.7012876868E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1760262102 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.3430350721 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.5262111872E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2696194351 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9021544456E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1760262102 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2133635283 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.7012876868E-01 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4431126714 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9021544456E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2696194351 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5262111872E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1610959321 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.7012876868E-01 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2844287157 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2133635283 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1760262102 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1610959321 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.5262111872E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9021544456E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1610958874 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2133635283 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2844280601 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.2844287157 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.7012876868E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1610958874 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9021544456E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1610959321 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9021541476E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2844287157 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2133615017 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.2844280601 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2133635283 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9021541476E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1610959321 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1610958874 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2844280601 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.7012508810E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2133615017 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.2844287157 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1610958874 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9021541476E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2696194649 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2133615017 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1760311425 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.7012508810E-01 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.2844280601 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2696194649 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9021541476E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2848841548 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.7012508810E-01 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4431194067 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1760311425 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2133615017 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.5262119323E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2848841548 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2696194649 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4362903833 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4362903833 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2696194649 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2848841548 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 226 217 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1760311425 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.3430540264 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4431194067 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.7012508810E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2848841548 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4362903833 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4097344875 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.2.1 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.4.1 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3069115281 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.3430540264 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1779308021 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4431194067 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 226 217 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 217 + in fire_ln: 8.3 : 226 217 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 226 217 + in fire_ln: 8.5 : 226 217 + in fire_ln: 8.5.1 : 226 217 + in fire_ln: 8.5.2 : 226 217 + in fire_ln: 8.5.3 : 226 217 + in fire_ln: 8.5.4 : 226 217 + in fire_ln: 8.5.5 : 226 217 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4431194067 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.1779308021 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1760311425 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.3430540264 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 217 + in fire_ln: 8.6 : 226 217 + in fire_ln: 8.7 : 226 217 + in fire_ln: 8.8 : 226 217 + in fire_ln: 8.9 : 226 217 + in fire_ln: 8.10 : 226 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4097344875 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4362903833 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3404407799 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1779308021 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.1407790333 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.3069115281 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.3430540264 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.5754217505E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3404407799 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4097344875 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4097344875 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3404407799 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2709368467 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.1407790333 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.4282377064 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1074729860 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3069115281 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.3069115281 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1074729860 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.1779308021 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.1407790333 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2709368467 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3404407799 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3353294432 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3353294432 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.1907542162E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4871736765 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2709368467 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3831937909 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.4282377064 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.4437991977 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1074729860 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1074729860 + in fire_ln: 8.5.5 : xcd( 223 220 3 ) = 0.4437991977 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.4282377064 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.1407790333 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4871736765 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2709368467 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3353294432 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4861516356 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4437991977 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3748195767 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3831937909 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.4282377064 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3353294432 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4861516356 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4871736765 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4862022698 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4862022698 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4871736765 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4861516356 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4872263074 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3748195767 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3965757489 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3861393034 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3831937909 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3831937909 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3861393034 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4437991977 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3748195767 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4872263074 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4861516356 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4862022698 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3353303373 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4862022698 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3353303373 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4872263074 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2709368467 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4872263074 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3353303373 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1907542162E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4054129422 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.5373012275E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3706821501 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3965757489 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.3706821501 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3965757489 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3861393034 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4054129422 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3861393034 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4054129422 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3965757489 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3748195767 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.1907542162E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3353303373 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3404407799 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2709368467 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1907542162E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4097344577 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.5373012275E-01 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3710378408 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2525988519 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3706821501 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.3706821501 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2525988519 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.5373012275E-01 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4054129422 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4097344577 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.1907542162E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5754237995E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3404407799 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.5754237995E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4097344577 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4362905920 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4362905920 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4097344577 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5754237995E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2848841548 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.5754237995E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4362905920 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2696194351 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4626142979 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2493126690 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3679435849 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.9597498924E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 3 ) = 0.3679435849 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.9597498924E-01 + in fire_ln: 8.5.5 : ycd( 216 225 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4626142979 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3710378408 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3710378408 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4626142979 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2525988519 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.9597498924E-01 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2525988519 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.9597498924E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3710378408 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.5373012275E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2696194351 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4362905920 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5262111872E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2848841548 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.5262111872E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2696194351 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9021544456E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9021544456E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2696194351 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5262111872E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1610961556 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1610961556 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.5262111872E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9021544456E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1625645906 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1625645906 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9021544456E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1610961556 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.9658350050E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.9658350050E-01 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1610961556 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1625645906 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.3996687755E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.3996687755E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1625645906 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.9658350050E-01 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2493126690 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2493126690 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.9658350050E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3679435849 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.3996687755E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3679435849 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.3996687755E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2493126690 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4626142979 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 214.4027252 6.937270164 27.40087509 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.225E-01 0.403E+01 0.101E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.225E-01 0.403E+01 0.101E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.296E-01 0.403E+01 0.446E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.296E-01 0.403E+01 0.446E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.386E-01 0.403E+01 0.886E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.386E-01 0.403E+01 0.886E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.496E-01 0.403E+01 0.142E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.496E-01 0.403E+01 0.142E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.550E-01 0.403E+01 0.168E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.542E-01 0.403E+01 0.165E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.542E-01 0.403E+01 0.165E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.541E-01 0.403E+01 0.164E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.731E-01 0.403E+01 0.257E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.731E-01 0.403E+01 0.257E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.863E-01 0.403E+01 0.321E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.863E-01 0.403E+01 0.321E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.877E-01 0.403E+01 0.328E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.900E-01 0.403E+01 0.339E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.900E-01 0.403E+01 0.339E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.970E-01 0.403E+01 0.374E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.994E-01 0.403E+01 0.385E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.994E-01 0.403E+01 0.385E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.102E+00 0.403E+01 0.399E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.112E+00 0.403E+01 0.445E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.112E+00 0.403E+01 0.445E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.113E+00 0.403E+01 0.452E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.114E+00 0.403E+01 0.456E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.114E+00 0.403E+01 0.456E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.129E+00 0.403E+01 0.531E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.129E+00 0.403E+01 0.531E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.540E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.131E+00 0.403E+01 0.540E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.137E+00 0.403E+01 0.568E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.142E+00 0.403E+01 0.596E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.596E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.599E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.155E+00 0.403E+01 0.659E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.155E+00 0.403E+01 0.659E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.156E+00 0.403E+01 0.660E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.157E+00 0.403E+01 0.664E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.157E+00 0.403E+01 0.664E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.167E+00 0.403E+01 0.715E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.725E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.725E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.170E+00 0.403E+01 0.733E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.175E+00 0.403E+01 0.753E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.175E+00 0.403E+01 0.753E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.764E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.178E+00 0.403E+01 0.770E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.191E+00 0.403E+01 0.831E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.831E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.832E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.192E+00 0.403E+01 0.837E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.192E+00 0.403E+01 0.837E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.866E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.901E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.901E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.895E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.895E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.192E+00 0.403E+01 0.836E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.191E+00 0.403E+01 0.831E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.186E+00 0.403E+01 0.808E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.192E+00 0.403E+01 0.836E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.832E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.831E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.186E+00 0.403E+01 0.808E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.175E+00 0.403E+01 0.753E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.170E+00 0.403E+01 0.732E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.724E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.769E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.763E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.175E+00 0.403E+01 0.753E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.156E+00 0.403E+01 0.663E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.155E+00 0.403E+01 0.659E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.155E+00 0.403E+01 0.658E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.724E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.167E+00 0.403E+01 0.714E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.156E+00 0.403E+01 0.663E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.155E+00 0.403E+01 0.658E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.144E+00 0.403E+01 0.603E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.142E+00 0.403E+01 0.594E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.137E+00 0.403E+01 0.567E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.144E+00 0.403E+01 0.603E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.142E+00 0.403E+01 0.594E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.113E+00 0.403E+01 0.451E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.111E+00 0.403E+01 0.444E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.129E+00 0.403E+01 0.530E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.114E+00 0.403E+01 0.455E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.130E+00 0.403E+01 0.535E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.129E+00 0.403E+01 0.530E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.992E-01 0.403E+01 0.384E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.967E-01 0.403E+01 0.372E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.111E+00 0.403E+01 0.444E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.102E+00 0.403E+01 0.398E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.992E-01 0.403E+01 0.384E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.552E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.539E-01 0.403E+01 0.163E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.540E-01 0.403E+01 0.164E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.729E-01 0.403E+01 0.256E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.552E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.860E-01 0.403E+01 0.320E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.729E-01 0.403E+01 0.256E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.897E-01 0.403E+01 0.338E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.875E-01 0.403E+01 0.327E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.860E-01 0.403E+01 0.320E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.224E-01 0.403E+01 0.947E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.294E-01 0.403E+01 0.437E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.224E-01 0.403E+01 0.947E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.384E-01 0.403E+01 0.876E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.294E-01 0.403E+01 0.437E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.493E-01 0.403E+01 0.141E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.384E-01 0.403E+01 0.876E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.540E-01 0.403E+01 0.164E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.547E-01 0.403E+01 0.167E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.493E-01 0.403E+01 0.141E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20510 0.02048 + time (min)= 0.1000 AREA (acre)= 5.62212 + GRNDHX= 0.5657E+05 GRNDQX= 0.5192E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1374E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:06 on domain 1: 5.10000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 7.000000000 + diff = -6.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2661296129 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4399332702 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2661296129 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9364798665E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1645115018 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9364798665E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2661296129 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9364798665E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1663308740 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1645115018 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1645115018 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1015528962 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1663308740 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9364798665E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1663308740 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.3342212737E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1015528962 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1645115018 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1015528962 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2408719063 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.3342212737E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1663308740 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3826481998 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.3342212737E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2408719063 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1015528962 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2408719063 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4724468887 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.3826481998 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.3342212737E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4059754014 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4059754014 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4399332702 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4399332702 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4059754014 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4399332702 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2661296129 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.2.1 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.4.1 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3826481998 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1091812849 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4724468887 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2408719063 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4724468887 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3581607938 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.3826481998 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1091812849 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2246170044 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1091812849 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3581607938 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4724468887 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3581607938 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.7349730283E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.2246170044 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1091812849 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2767698169 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3397424221 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4059754014 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2767698169 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2246170044 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4056239128 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.7349730283E-01 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3581607938 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.7349730283E-01 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.4297932684 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4056239128 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.2246170044 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4818192720 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3397424221 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4831174612 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4818510413 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2767698169 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4831174612 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4818192720 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3397424221 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3397424221 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2767698169 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4831174612 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4056239128 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3730204701 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 3 ) = -0.4297932684 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.7349730283E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3593288660 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4297932684 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4056239128 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3730204701 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3730204701 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3458110988 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3593288660 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4297932684 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4831483960 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4818192720 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3397432566 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4818510413 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4818510413 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4831174612 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4818192720 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4831483960 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3593288660 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3560927510 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3458110988 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3730204701 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4775162935 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3458110988 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3560927510 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3593288660 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3397432566 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4818510413 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4831483960 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2767699063 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 223 204 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3560927510 + in fire_ln: 8.5.5 : xcd( 223 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 2 ) = -0.4530637264 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.4775162935 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3458110988 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3397432566 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2767699063 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4831483960 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2767699063 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3397432566 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 223 204 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 203 + in fire_ln: 8.2 : 223 204 + in fire_ln: 8.2.1 : 223 204 + in fire_ln: 8.3 : 223 204 + in fire_ln: 8.3.1 : 224 203 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 223 204 + in fire_ln: 8.4.1 : 223 204 + in fire_ln: 8.5 : 223 204 + in fire_ln: 8.5.1 : 223 204 + in fire_ln: 8.5.2 : 223 204 + in fire_ln: 8.5.3 : 223 204 + in fire_ln: 8.5.4 : 223 204 + in fire_ln: 8.5.5 : 223 204 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4775162935 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1404853463 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3560927510 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 204 2 ) = -0.4530637264 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 204 + in fire_ln: 8.6 : 223 204 + in fire_ln: 8.7 : 223 204 + in fire_ln: 8.8 : 223 204 + in fire_ln: 8.9 : 223 204 + in fire_ln: 8.10 : 223 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 223 204 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.4530637264 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.8484671265E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 3 ) = 0.1404853463 + in fire_ln: 8.5.5 : xcd( 223 204 1 ) = 0.4775162935 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4059753418 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6124836206E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2767699063 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4059753418 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1404853463 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2778350413 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.8484671265E-01 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.4530637264 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2117553949 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.8484671265E-01 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2778350413 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1404853463 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6124836206E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4059753418 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4399335086 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2778350413 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.2576180398 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2117553949 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.8484671265E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4399335086 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4059753418 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6124836206E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.2.1 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 226 207 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.4.1 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2117553949 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4135715365 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2778350413 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.2576180398 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 226 207 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 208 + in fire_ln: 8.2 : 226 207 + in fire_ln: 8.3 : 226 207 + in fire_ln: 8.3.1 : 225 208 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 226 207 + in fire_ln: 8.5 : 226 207 + in fire_ln: 8.5.1 : 226 207 + in fire_ln: 8.5.2 : 226 207 + in fire_ln: 8.5.3 : 226 207 + in fire_ln: 8.5.4 : 226 207 + in fire_ln: 8.5.5 : 226 207 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1419976652 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.2576180398 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.4135715365 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2117553949 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 207 + in fire_ln: 8.6 : 226 207 + in fire_ln: 8.7 : 226 207 + in fire_ln: 8.8 : 226 207 + in fire_ln: 8.9 : 226 207 + in fire_ln: 8.10 : 226 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2661295831 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4399335086 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4915314913E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6124836206E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4399335086 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2661295831 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4135715365 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1042390019 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1419976652 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.2576180398 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4915314913E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2661295831 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9364803135E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1419976652 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2475416213 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1042390019 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.4135715365 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9364803135E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2661295831 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4915314913E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1645112336 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1042390019 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3186336756 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2475416213 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1419976652 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1645112336 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4915314913E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9364803135E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1645111740 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2475416213 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3186308742 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3186336756 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1042390019 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1645111740 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9364803135E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1645112336 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9364799410E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3186336756 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2475330979 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3186308742 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2475416213 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9364799410E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1645112336 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1645111740 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3186308742 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1042236090 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2475330979 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3186336756 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1645111740 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9364799410E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2661296129 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2475330979 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1420180649 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1042236090 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3186308742 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2661296129 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9364799410E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2969783247 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1042236090 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4135983288 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1420180649 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2475330979 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4915323853E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.2969783247 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2661296129 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4399332702 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4399332702 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2661296129 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2969783247 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 226 217 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1420180649 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.2576954663 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.4135983288 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1042236090 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.2969783247 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4399332702 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4059754014 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.2.1 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.4.1 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2778748870 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.2576954663 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2117218375 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4135983288 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 226 217 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 217 + in fire_ln: 8.3 : 226 217 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 226 217 + in fire_ln: 8.5 : 226 217 + in fire_ln: 8.5.1 : 226 217 + in fire_ln: 8.5.2 : 226 217 + in fire_ln: 8.5.3 : 226 217 + in fire_ln: 8.5.4 : 226 217 + in fire_ln: 8.5.5 : 226 217 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.4135983288 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2117218375 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1420180649 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.2576954663 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 217 + in fire_ln: 8.6 : 226 217 + in fire_ln: 8.7 : 226 217 + in fire_ln: 8.8 : 226 217 + in fire_ln: 8.9 : 226 217 + in fire_ln: 8.10 : 226 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4059754014 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4399332702 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3338384330 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2117218375 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.8492629975E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2778748870 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.2576954663 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6124813855E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3338384330 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4059754014 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4059754014 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3338384330 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2767698169 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.8492629975E-01 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.4530387223 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1404350102 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2778748870 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2778748870 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1404350102 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2117218375 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.8492629975E-01 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2767698169 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3338384330 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3397424221 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3397424221 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.2301211469E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4831174612 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2767698169 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 223 220 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 220 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 221 + in fire_ln: 8.2 : 223 220 + in fire_ln: 8.2.1 : 223 220 + in fire_ln: 8.3 : 223 220 + in fire_ln: 8.3.1 : 224 221 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 223 220 + in fire_ln: 8.4.1 : 223 220 + in fire_ln: 8.5 : 223 220 + in fire_ln: 8.5.1 : 223 220 + in fire_ln: 8.5.2 : 223 220 + in fire_ln: 8.5.3 : 223 220 + in fire_ln: 8.5.4 : 223 220 + in fire_ln: 8.5.5 : 223 220 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3551797271 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.4530387223 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 220 2 ) = 0.4773839116 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1404350102 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 220 + in fire_ln: 8.6 : 223 220 + in fire_ln: 8.7 : 223 220 + in fire_ln: 8.8 : 223 220 + in fire_ln: 8.9 : 223 220 + in fire_ln: 8.10 : 223 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 223 220 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1404350102 + in fire_ln: 8.5.5 : xcd( 223 220 2 ) = 0.4773839116 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 3 ) = 0.4530387223 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.8492629975E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4831174612 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2767698169 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3397424221 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4818192124 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 223 220 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4773839116 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3449919522 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3551797271 + in fire_ln: 8.5.5 : xcd( 223 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 220 1 ) = 0.4530387223 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3397424221 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4818192124 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4831174612 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4818700552 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4818700552 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4831174612 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4818192124 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4831669331 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3449919522 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3718951941 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3582670987 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3551797271 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3551797271 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3582670987 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.4773839116 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3449919522 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4831669331 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4818192124 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4818700552 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3397434950 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4818700552 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3397434950 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2767699063 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4831669331 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2767699063 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4831669331 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3397434950 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.2301211469E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4296550155 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.7343200594E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.4055485725 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3718951941 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 3 ) = 0.4055485725 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3718951941 + in fire_ln: 8.5.5 : ycd( 220 223 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3582670987 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4296550155 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3582670987 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4296550155 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3718951941 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3449919522 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.2301211469E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3397434950 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2767699063 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3338384330 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2767699063 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.2301211469E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4059753418 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.7343200594E-01 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3582230508 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2247370631 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4055485725 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4055485725 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.2247370631 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.7343200594E-01 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4296550155 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4059753418 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.2301211469E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6124836206E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3338384330 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6124836206E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4059753418 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4399335086 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4399335086 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4059753418 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6124836206E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.2969783247 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6124836206E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4399335086 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2661295831 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.2.1 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.4.1 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4723909199 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2409239560 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.3826339543 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1091205925 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.3826339543 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1091205925 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4723909199 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3582230508 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3582230508 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4723909199 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2247370631 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1091205925 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.2247370631 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1091205925 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3582230508 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.7343200594E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2661295831 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4399335086 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4915314913E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.2969783247 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4915314913E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2661295831 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9364803880E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9364803880E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2661295831 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4915314913E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1645115614 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1645115614 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4915314913E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9364803880E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1663029492 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1663029492 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9364803880E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1645115614 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1015129387 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1015129387 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1645115614 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1663029492 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.3346926346E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.3346926346E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1663029492 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1015129387 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2409239560 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2409239560 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1015129387 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3826339543 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.3346926346E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.3826339543 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.3346926346E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2409239560 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4723909199 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 234.3625946 2.752867937 25.96937370 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.225E-01 0.403E+01 0.973E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.225E-01 0.403E+01 0.973E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.294E-01 0.403E+01 0.437E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.294E-01 0.403E+01 0.437E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.384E-01 0.403E+01 0.875E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.384E-01 0.403E+01 0.875E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.497E-01 0.403E+01 0.143E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.497E-01 0.403E+01 0.143E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.556E-01 0.403E+01 0.172E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.482E-01 0.403E+01 0.135E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.482E-01 0.403E+01 0.135E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.490E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.490E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.729E-01 0.403E+01 0.256E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.729E-01 0.403E+01 0.256E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.855E-01 0.403E+01 0.318E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.855E-01 0.403E+01 0.318E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.869E-01 0.403E+01 0.324E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.895E-01 0.403E+01 0.337E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.895E-01 0.403E+01 0.337E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.965E-01 0.403E+01 0.371E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.989E-01 0.403E+01 0.383E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.989E-01 0.403E+01 0.383E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.102E+00 0.403E+01 0.398E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.113E+00 0.403E+01 0.453E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.113E+00 0.403E+01 0.453E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.115E+00 0.403E+01 0.459E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.115E+00 0.403E+01 0.462E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.115E+00 0.403E+01 0.462E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.129E+00 0.403E+01 0.529E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.129E+00 0.403E+01 0.529E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.137E+00 0.403E+01 0.567E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.142E+00 0.403E+01 0.594E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.594E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.599E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.144E+00 0.403E+01 0.605E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.144E+00 0.403E+01 0.605E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.181E+00 0.403E+01 0.784E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.181E+00 0.403E+01 0.784E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 204 0.181E+00 0.403E+01 0.785E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.181E+00 0.403E+01 0.785E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.165E+00 0.403E+01 0.707E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.723E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.723E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.170E+00 0.403E+01 0.732E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.175E+00 0.403E+01 0.752E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.175E+00 0.403E+01 0.752E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.771E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.178E+00 0.403E+01 0.771E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.186E+00 0.403E+01 0.810E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.191E+00 0.403E+01 0.833E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.833E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.835E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.193E+00 0.403E+01 0.841E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.193E+00 0.403E+01 0.841E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.193E+00 0.403E+01 0.840E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.191E+00 0.403E+01 0.832E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.193E+00 0.403E+01 0.840E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.832E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.186E+00 0.403E+01 0.809E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.178E+00 0.403E+01 0.771E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.174E+00 0.403E+01 0.752E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.170E+00 0.403E+01 0.731E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.168E+00 0.403E+01 0.722E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.771E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.765E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.174E+00 0.403E+01 0.752E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.181E+00 0.403E+01 0.784E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 220 0.181E+00 0.403E+01 0.782E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.168E+00 0.403E+01 0.722E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.165E+00 0.403E+01 0.707E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.181E+00 0.403E+01 0.784E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.181E+00 0.403E+01 0.782E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.142E+00 0.403E+01 0.593E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.137E+00 0.403E+01 0.567E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.144E+00 0.403E+01 0.604E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.142E+00 0.403E+01 0.593E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.115E+00 0.403E+01 0.461E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.114E+00 0.403E+01 0.459E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.113E+00 0.403E+01 0.453E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.129E+00 0.403E+01 0.528E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.115E+00 0.403E+01 0.461E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.539E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.130E+00 0.403E+01 0.534E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.129E+00 0.403E+01 0.528E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.987E-01 0.403E+01 0.382E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.963E-01 0.403E+01 0.370E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.893E-01 0.403E+01 0.336E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.113E+00 0.403E+01 0.453E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.102E+00 0.403E+01 0.397E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.987E-01 0.403E+01 0.382E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.489E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.481E-01 0.403E+01 0.135E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.727E-01 0.403E+01 0.255E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.489E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.853E-01 0.403E+01 0.317E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.727E-01 0.403E+01 0.255E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.893E-01 0.403E+01 0.336E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.868E-01 0.403E+01 0.324E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.853E-01 0.403E+01 0.317E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.224E-01 0.403E+01 0.934E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.293E-01 0.403E+01 0.432E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.224E-01 0.403E+01 0.934E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.383E-01 0.403E+01 0.868E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.293E-01 0.403E+01 0.432E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.496E-01 0.403E+01 0.142E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.383E-01 0.403E+01 0.868E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.481E-01 0.403E+01 0.135E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.555E-01 0.403E+01 0.171E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.496E-01 0.403E+01 0.142E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20519 0.02048 + time (min)= 0.1167 AREA (acre)= 5.63217 + GRNDHX= 0.5579E+05 GRNDQX= 0.5120E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1300E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:07 on domain 1: 5.11000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 8.000000000 + diff = -7.966666698 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2626397610 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4435759187 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2626397610 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1679269373 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2626397610 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1700779498 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1679269373 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1679269373 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1064829230 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1700779498 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1700779498 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.2693159506E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1064829230 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1679269373 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1064829230 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2324211299 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.2693159506E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1700779498 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4179502726 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.2693159506E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2324211299 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1064829230 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2324211299 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4810824692 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4179502726 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.2693159506E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3271741867 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4022163153 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4022163153 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4435759187 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3271741867 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4435759187 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.4022163153 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4435759187 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2626397610 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.2.1 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.4.1 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4179502726 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1223211139 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4810824692 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2324211299 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4810824692 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3453485370 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4179502726 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1223211139 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1960849464 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1223211139 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3453485370 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4810824692 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3453485370 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.9337774664E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1960849464 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1223211139 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2768971026 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3271741867 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3441559970 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.4022163153 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3271741867 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2768971026 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1960849464 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4407251775 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.9337774664E-01 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3453485370 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.9337774664E-01 + in fire_ln: 8.5.5 : ycd( 220 201 2 ) = -0.4543326199 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4407251775 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1960849464 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4776063561 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3441559970 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4791801870 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4776370823 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2768971026 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4791801870 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4776063561 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3441559970 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3441559970 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2768971026 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4791801870 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.2.1 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.4.1 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4407251775 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3488005996 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 2 ) = -0.4543326199 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.9337774664E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3315024674 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4543326199 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4407251775 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3488005996 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3488005996 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3160490394 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3315024674 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4543326199 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4792096317 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4776063561 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3441569209 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4776370823 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4776370823 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4791801870 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4776063561 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4792096317 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3315024674 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3247045577 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.3160490394 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3488005996 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3160490394 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.4812361300 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.3247045577 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3315024674 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3441569209 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4776370823 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4792096317 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2768970728 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.2.1 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 224 203 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.4.1 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3247045577 + in fire_ln: 8.5.5 : xcd( 224 203 3 ) = -0.4842295349 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.4812361300 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.3160490394 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 224 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 203 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 204 + in fire_ln: 8.2 : 224 203 + in fire_ln: 8.3 : 224 203 + in fire_ln: 8.3.1 : 223 204 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 224 203 + in fire_ln: 8.5 : 224 203 + in fire_ln: 8.5.1 : 224 203 + in fire_ln: 8.5.2 : 224 203 + in fire_ln: 8.5.3 : 224 203 + in fire_ln: 8.5.4 : 224 203 + in fire_ln: 8.5.5 : 224 203 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 2 ) = 0.1704552770 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 203 1 ) = 0.4812361300 + in fire_ln: 8.5.5 : ycd( 224 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 203 3 ) = -0.4842295349 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.3247045577 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 203 + in fire_ln: 8.6 : 224 203 + in fire_ln: 8.7 : 224 203 + in fire_ln: 8.8 : 224 203 + in fire_ln: 8.9 : 224 203 + in fire_ln: 8.10 : 224 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3441569209 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2768970728 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3271741271 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4792096317 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2768970728 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3441569209 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 224 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.4842295349 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.2806077525E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 2 ) = 0.1704552770 + in fire_ln: 8.5.5 : xcd( 224 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 203 1 ) = 0.4812361300 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4022161961 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6495426595E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3271741271 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3271741271 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2768970728 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.4022161961 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 206 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 206 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1704552770 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2485491186 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.4842295349 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = 0.2806077525E-01 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2456288785 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.2806077525E-01 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2485491186 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.1704552770 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6495426595E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3271741271 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4022161961 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4435761869 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2485491186 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.1743882149 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2456288785 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = 0.2806077525E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4435761869 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.4022161961 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6495426595E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.2.1 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 226 207 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.4.1 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2456288785 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.3849610090 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2485491186 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.1743882149 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 226 207 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 208 + in fire_ln: 8.2 : 226 207 + in fire_ln: 8.3 : 226 207 + in fire_ln: 8.3.1 : 225 208 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 226 207 + in fire_ln: 8.5 : 226 207 + in fire_ln: 8.5.1 : 226 207 + in fire_ln: 8.5.2 : 226 207 + in fire_ln: 8.5.3 : 226 207 + in fire_ln: 8.5.4 : 226 207 + in fire_ln: 8.5.5 : 226 207 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1079590917 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.1743882149 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.3849610090 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2456288785 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 207 + in fire_ln: 8.6 : 226 207 + in fire_ln: 8.7 : 226 207 + in fire_ln: 8.8 : 226 207 + in fire_ln: 8.9 : 226 207 + in fire_ln: 8.10 : 226 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2626397014 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4435761869 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4568520188E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6495426595E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4435761869 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2626397014 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.3849610090 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1383633912 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.1079590917 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.1743882149 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4568520188E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2626397014 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9708061814E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1079590917 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2817347050 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1383633912 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.3849610090 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.9708061814E-01 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2626397014 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4568520188E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1679265201 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1383633912 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3528543711 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.2817347050 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.1079590917 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1679265201 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4568520188E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9708061814E-01 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1679264605 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2817347050 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3528501987 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3528543711 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1383633912 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1679264605 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.9708061814E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1679265201 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3528543711 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2817220092 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3528501987 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.2817347050 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1679265201 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1679264605 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3528501987 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1383404285 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.2817220092 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3528543711 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1679264605 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2626397610 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2817220092 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1079896018 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1383404285 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3528501987 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2626397610 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.9708055854E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.3090787232 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1383404285 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.3849993646 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.1079896018 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.2817220092 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4568530619E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.3090787232 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2626397610 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4435759187 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4435759187 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2626397610 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.3090787232 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 226 217 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1079896018 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.1745037884 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.3849993646 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1383404285 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.3090787232 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4435759187 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4022163153 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.2.1 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.4.1 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2486080229 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.1745037884 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2455788851 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.3849993646 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 226 217 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 217 + in fire_ln: 8.3 : 226 217 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 226 217 + in fire_ln: 8.5 : 226 217 + in fire_ln: 8.5.1 : 226 217 + in fire_ln: 8.5.2 : 226 217 + in fire_ln: 8.5.3 : 226 217 + in fire_ln: 8.5.4 : 226 217 + in fire_ln: 8.5.5 : 226 217 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.3849993646 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2455788851 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.1079896018 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.1745037884 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 217 + in fire_ln: 8.6 : 226 217 + in fire_ln: 8.7 : 226 217 + in fire_ln: 8.8 : 226 217 + in fire_ln: 8.9 : 226 217 + in fire_ln: 8.10 : 226 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.4022163153 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4435759187 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3271741867 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2455788851 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.2818119153E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2486080229 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.1745037884 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6495402008E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3271741867 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4022163153 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.4022163153 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3271741867 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2768971026 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 2 ) = -0.4844223559 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.2818119153E-01 + in fire_ln: 8.5.5 : ycd( 224 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1703888625 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2486080229 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 224 218 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 218 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2486080229 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.1703888625 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2455788851 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = -0.2818119153E-01 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2768971026 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3271741867 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3441559970 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3441559970 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.2694886550E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4791801870 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2768971026 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 224 221 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1703888625 + in fire_ln: 8.5.5 : xcd( 224 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 221 3 ) = -0.4814426303 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 220 2 ) = -0.4844223559 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = -0.2818119153E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4791801870 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2768971026 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3441559970 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4776063561 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.2.1 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.4.1 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 224 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.4814426303 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3154075444 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3238508701 + in fire_ln: 8.5.5 : xcd( 224 221 1 ) = -0.4844223559 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 224 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 223 220 + in fire_ln: 8.2 : 224 221 + in fire_ln: 8.3 : 224 221 + in fire_ln: 8.3.1 : 223 220 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 224 221 + in fire_ln: 8.5 : 224 221 + in fire_ln: 8.5.1 : 224 221 + in fire_ln: 8.5.2 : 224 221 + in fire_ln: 8.5.3 : 224 221 + in fire_ln: 8.5.4 : 224 221 + in fire_ln: 8.5.5 : 224 221 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 221 1 ) = -0.4844223559 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.3238508701 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.1703888625 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 221 3 ) = -0.4814426303 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 221 + in fire_ln: 8.6 : 224 221 + in fire_ln: 8.7 : 224 221 + in fire_ln: 8.8 : 224 221 + in fire_ln: 8.9 : 224 221 + in fire_ln: 8.10 : 224 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3441559970 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4776063561 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4791801870 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4776554704 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4776554704 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4791801870 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4776063561 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4792272449 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3154075444 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3478131592 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3306028247 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3238508701 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.3238508701 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3306028247 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.3154075444 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.4814426303 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4792272449 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4776063561 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4776554704 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3441571891 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4776554704 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3441571891 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2768970728 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4792272449 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2768970728 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4792272449 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3441571891 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.2694886550E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.2.1 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.4.1 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4541612566 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.9328209609E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 2 ) = 0.4407129586 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3478131592 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 2 ) = 0.4407129586 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3478131592 + in fire_ln: 8.5.5 : ycd( 220 223 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3306028247 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4541612566 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3306028247 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4541612566 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3478131592 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.3154075444 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.2694886550E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3441571891 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2768970728 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3271741271 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3271741271 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2768970728 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.2694886550E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4022161961 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.9328209609E-01 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3454402387 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.1962653399 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4407129586 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4407129586 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.1962653399 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.9328209609E-01 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4541612566 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.4022161961 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.2694886550E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3271741271 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6495426595E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3271741271 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6495426595E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4022161961 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4435761869 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4435761869 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.4022161961 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6495426595E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.3090787232 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6495426595E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4435761869 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2626397014 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.2.1 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.4.1 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4810107350 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2324993014 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.4178047478 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1222309023 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.4178047478 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1222309023 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4810107350 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3454402387 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3454402387 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4810107350 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.1962653399 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1222309023 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.1962653399 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1222309023 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3454402387 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.9328209609E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2626397014 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4435761869 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4568520188E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.3090787232 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4568520188E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2626397014 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9708061814E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.9708061814E-01 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2626397014 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4568520188E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1679269969 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1679269969 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4568520188E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9708061814E-01 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1700367630 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1700367630 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.9708061814E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1679269969 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1064237207 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1064237207 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1679269969 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1700367630 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.2700153552E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.2700153552E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1700367630 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1064237207 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2324993014 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2324993014 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1064237207 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.4178047478 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.2700153552E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.4178047478 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.2700153552E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2324993014 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4810107350 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 261.7037964 1.305618763 28.40712929 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.224E-01 0.403E+01 0.941E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.224E-01 0.403E+01 0.941E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.293E-01 0.403E+01 0.430E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.293E-01 0.403E+01 0.430E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.382E-01 0.403E+01 0.863E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.382E-01 0.403E+01 0.863E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.493E-01 0.403E+01 0.141E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.493E-01 0.403E+01 0.141E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.553E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.473E-01 0.403E+01 0.131E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.473E-01 0.403E+01 0.131E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.479E-01 0.403E+01 0.134E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.479E-01 0.403E+01 0.134E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.726E-01 0.403E+01 0.254E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.726E-01 0.403E+01 0.254E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.848E-01 0.403E+01 0.314E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.848E-01 0.403E+01 0.314E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.861E-01 0.403E+01 0.320E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.890E-01 0.403E+01 0.335E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.890E-01 0.403E+01 0.335E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.959E-01 0.403E+01 0.368E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.983E-01 0.403E+01 0.380E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.983E-01 0.403E+01 0.380E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.102E+00 0.403E+01 0.397E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.116E+00 0.403E+01 0.468E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.116E+00 0.403E+01 0.468E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.118E+00 0.403E+01 0.474E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.118E+00 0.403E+01 0.474E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.128E+00 0.403E+01 0.526E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.128E+00 0.403E+01 0.526E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.136E+00 0.403E+01 0.566E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.141E+00 0.403E+01 0.587E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.141E+00 0.403E+01 0.587E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.142E+00 0.403E+01 0.591E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.599E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.143E+00 0.403E+01 0.599E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.151E+00 0.403E+01 0.638E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.151E+00 0.403E+01 0.638E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.169E+00 0.403E+01 0.724E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.724E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.170E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.767E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.192E+00 0.403E+01 0.836E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.882E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.198E+00 0.403E+01 0.865E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.191E+00 0.403E+01 0.833E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.192E+00 0.403E+01 0.836E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.833E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.187E+00 0.403E+01 0.811E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.170E+00 0.403E+01 0.728E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.723E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.177E+00 0.403E+01 0.766E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.174E+00 0.403E+01 0.749E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.169E+00 0.403E+01 0.723E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.151E+00 0.403E+01 0.638E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.151E+00 0.403E+01 0.638E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.151E+00 0.403E+01 0.636E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.141E+00 0.403E+01 0.586E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.136E+00 0.403E+01 0.566E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.141E+00 0.403E+01 0.591E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.141E+00 0.403E+01 0.586E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.118E+00 0.403E+01 0.475E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.117E+00 0.403E+01 0.469E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.128E+00 0.403E+01 0.526E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.118E+00 0.403E+01 0.475E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.131E+00 0.403E+01 0.538E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.129E+00 0.403E+01 0.532E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.128E+00 0.403E+01 0.526E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.982E-01 0.403E+01 0.380E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.958E-01 0.403E+01 0.368E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.889E-01 0.403E+01 0.334E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.117E+00 0.403E+01 0.469E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.102E+00 0.403E+01 0.396E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.982E-01 0.403E+01 0.380E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.479E-01 0.403E+01 0.134E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.473E-01 0.403E+01 0.131E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.725E-01 0.403E+01 0.254E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.479E-01 0.403E+01 0.134E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.847E-01 0.403E+01 0.314E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.725E-01 0.403E+01 0.254E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.889E-01 0.403E+01 0.334E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.860E-01 0.403E+01 0.320E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.847E-01 0.403E+01 0.314E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.224E-01 0.403E+01 0.919E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.292E-01 0.403E+01 0.426E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.224E-01 0.403E+01 0.919E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.381E-01 0.403E+01 0.860E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.292E-01 0.403E+01 0.426E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.492E-01 0.403E+01 0.140E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.381E-01 0.403E+01 0.860E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.473E-01 0.403E+01 0.131E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.552E-01 0.403E+01 0.170E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.492E-01 0.403E+01 0.140E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20528 0.02048 + time (min)= 0.1333 AREA (acre)= 5.64176 + GRNDHX= 0.5916E+05 GRNDQX= 0.5430E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1263E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:08 on domain 1: 5.12000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 9.000000000 + diff = -8.966666222 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2591498494 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4472182095 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2591498494 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.1005131304 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1713424027 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.1005131304 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2591498494 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.1005131304 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1738140285 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1713424027 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1713424027 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1113851294 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1738140285 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.1005131304 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1738140285 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.2048276365E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1113851294 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1713424027 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1113851294 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2240425497 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.2048276365E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1738140285 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4532300830 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.2048276365E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2240425497 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1113851294 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2240425497 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4895080030 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4532300830 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.2048276365E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3204802275 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.3984572291 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.3984572291 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4472182095 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3204802275 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4472182095 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.3984572291 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4472182095 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2591498494 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.2.1 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.4.1 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4532300830 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1353943795 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4895080030 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2240425497 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4895080030 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3325119019 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4532300830 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1353943795 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1668586135 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1353943795 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3325119019 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4895080030 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3325119019 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1131970584 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1668586135 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1353943795 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2822859585 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3204802275 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3485675752 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.3984572291 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3204802275 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2822859585 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1668586135 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4726067483 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1131970584 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3325119019 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 220 201 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1131970584 + in fire_ln: 8.5.5 : ycd( 220 201 2 ) = -0.4794210494 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 200 3 ) = 0.4726067483 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1668586135 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 202 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 202 + in fire_ln: 8.2 : 202 201 + in fire_ln: 8.3 : 202 201 + in fire_ln: 8.3.1 : 203 202 + in fire_ln: 8.3.2 : 203 201 + in fire_ln: 8.4 : 202 201 + in fire_ln: 8.5 : 202 201 + in fire_ln: 8.5.1 : 202 201 + in fire_ln: 8.5.2 : 202 201 + in fire_ln: 8.5.3 : 202 201 + in fire_ln: 8.5.4 : 202 201 + in fire_ln: 8.5.5 : 202 201 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4735047817 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3485675752 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4753543735 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4735341072 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 201 + in fire_ln: 8.6 : 202 201 + in fire_ln: 8.7 : 202 201 + in fire_ln: 8.8 : 202 201 + in fire_ln: 8.9 : 202 201 + in fire_ln: 8.10 : 202 201 + in fire_ln: 8.1 : 203 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 204 200 + in fire_ln: 8.2 : 203 201 + in fire_ln: 8.3 : 203 201 + in fire_ln: 8.3.1 : 204 200 + in fire_ln: 8.3.2 : 204 201 + in fire_ln: 8.4 : 203 201 + in fire_ln: 8.5 : 203 201 + in fire_ln: 8.5.1 : 203 201 + in fire_ln: 8.5.2 : 203 201 + in fire_ln: 8.5.3 : 203 201 + in fire_ln: 8.5.4 : 203 201 + in fire_ln: 8.5.5 : 203 201 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2822859585 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4753543735 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 1 ) = 0.4735047817 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 203 201 2 ) = -0.3485675752 + in fire_ln: 8.5.5 : ycd( 202 201 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 201 + in fire_ln: 8.6 : 203 201 + in fire_ln: 8.7 : 203 201 + in fire_ln: 8.8 : 203 201 + in fire_ln: 8.9 : 203 201 + in fire_ln: 8.10 : 203 201 + in fire_ln: 8.1 : 204 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 200 + in fire_ln: 8.2 : 204 201 + in fire_ln: 8.3 : 204 201 + in fire_ln: 8.3.1 : 203 200 + in fire_ln: 8.3.2 : 204 200 + in fire_ln: 8.4 : 204 201 + in fire_ln: 8.5 : 204 201 + in fire_ln: 8.5.1 : 204 201 + in fire_ln: 8.5.2 : 204 201 + in fire_ln: 8.5.3 : 204 201 + in fire_ln: 8.5.4 : 204 201 + in fire_ln: 8.5.5 : 204 201 + in fire_ln: 8.5.5 : ncod( 203 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3485675752 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 201 3 ) = -0.2822859585 + in fire_ln: 8.5.5 : xcd( 203 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 204 201 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 201 1 ) = 0.4753543735 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 201 + in fire_ln: 8.6 : 204 201 + in fire_ln: 8.7 : 204 201 + in fire_ln: 8.8 : 204 201 + in fire_ln: 8.9 : 204 201 + in fire_ln: 8.10 : 204 201 + in fire_ln: 8.1 : 220 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 200 + in fire_ln: 8.2 : 220 201 + in fire_ln: 8.2.1 : 220 201 + in fire_ln: 8.3 : 220 201 + in fire_ln: 8.3.1 : 221 200 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 220 201 + in fire_ln: 8.4.1 : 220 201 + in fire_ln: 8.5 : 220 201 + in fire_ln: 8.5.1 : 220 201 + in fire_ln: 8.5.2 : 220 201 + in fire_ln: 8.5.3 : 220 201 + in fire_ln: 8.5.4 : 220 201 + in fire_ln: 8.5.5 : 220 201 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4726067483 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3250381351 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 201 2 ) = -0.4794210494 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1131970584 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 201 + in fire_ln: 8.6 : 220 201 + in fire_ln: 8.7 : 220 201 + in fire_ln: 8.8 : 220 201 + in fire_ln: 8.9 : 220 201 + in fire_ln: 8.10 : 220 201 + in fire_ln: 8.1 : 221 201 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 201 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 202 + in fire_ln: 8.2 : 221 201 + in fire_ln: 8.3 : 221 201 + in fire_ln: 8.3.1 : 222 202 + in fire_ln: 8.3.2 : 222 201 + in fire_ln: 8.4 : 221 201 + in fire_ln: 8.5 : 221 201 + in fire_ln: 8.5.1 : 221 201 + in fire_ln: 8.5.2 : 221 201 + in fire_ln: 8.5.3 : 221 201 + in fire_ln: 8.5.4 : 221 201 + in fire_ln: 8.5.5 : 221 201 + in fire_ln: 8.5.5 : ncod( 220 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3037318885 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4794210494 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 201 1 ) = 0.4726067483 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.3250381351 + in fire_ln: 8.5.5 : ycd( 220 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 201 + in fire_ln: 8.6 : 221 201 + in fire_ln: 8.7 : 221 201 + in fire_ln: 8.8 : 221 201 + in fire_ln: 8.9 : 221 201 + in fire_ln: 8.10 : 221 201 + in fire_ln: 8.1 : 222 201 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 201 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 202 + in fire_ln: 8.2 : 222 201 + in fire_ln: 8.3 : 222 201 + in fire_ln: 8.3.1 : 221 202 + in fire_ln: 8.3.2 : 222 202 + in fire_ln: 8.4 : 222 201 + in fire_ln: 8.5 : 222 201 + in fire_ln: 8.5.1 : 222 201 + in fire_ln: 8.5.2 : 222 201 + in fire_ln: 8.5.3 : 222 201 + in fire_ln: 8.5.4 : 222 201 + in fire_ln: 8.5.5 : 222 201 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3250381351 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.2852081656 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 201 3 ) = -0.3037318885 + in fire_ln: 8.5.5 : xcd( 221 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 222 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 201 1 ) = -0.4794210494 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 201 + in fire_ln: 8.6 : 222 201 + in fire_ln: 8.7 : 222 201 + in fire_ln: 8.8 : 222 201 + in fire_ln: 8.9 : 222 201 + in fire_ln: 8.10 : 222 201 + in fire_ln: 8.1 : 201 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 202 203 + in fire_ln: 8.2 : 201 202 + in fire_ln: 8.3 : 201 202 + in fire_ln: 8.3.1 : 202 203 + in fire_ln: 8.3.2 : 202 202 + in fire_ln: 8.4 : 201 202 + in fire_ln: 8.5 : 201 202 + in fire_ln: 8.5.1 : 201 202 + in fire_ln: 8.5.2 : 201 202 + in fire_ln: 8.5.3 : 201 202 + in fire_ln: 8.5.4 : 201 202 + in fire_ln: 8.5.5 : 201 202 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4753825068 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4735047817 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3485687077 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4735341072 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 202 + in fire_ln: 8.6 : 201 202 + in fire_ln: 8.7 : 201 202 + in fire_ln: 8.8 : 201 202 + in fire_ln: 8.9 : 201 202 + in fire_ln: 8.10 : 201 202 + in fire_ln: 8.1 : 202 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 201 + in fire_ln: 8.2 : 202 202 + in fire_ln: 8.3 : 202 202 + in fire_ln: 8.3.1 : 203 201 + in fire_ln: 8.3.2 : 202 201 + in fire_ln: 8.4 : 202 202 + in fire_ln: 8.5 : 202 202 + in fire_ln: 8.5.1 : 202 202 + in fire_ln: 8.5.2 : 202 202 + in fire_ln: 8.5.3 : 202 202 + in fire_ln: 8.5.4 : 202 202 + in fire_ln: 8.5.5 : 202 202 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 201 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 201 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 202 1 ) = 0.4735341072 + in fire_ln: 8.5.5 : ycd( 202 201 3 ) = 0.4753543735 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 202 3 ) = 0.4735047817 + in fire_ln: 8.5.5 : xcd( 201 202 1 ) = 0.4753825068 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 202 202 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 202 + in fire_ln: 8.6 : 202 202 + in fire_ln: 8.7 : 202 202 + in fire_ln: 8.8 : 202 202 + in fire_ln: 8.9 : 202 202 + in fire_ln: 8.10 : 202 202 + in fire_ln: 8.1 : 222 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 202 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 203 + in fire_ln: 8.2 : 222 202 + in fire_ln: 8.3 : 222 202 + in fire_ln: 8.3.1 : 223 203 + in fire_ln: 8.3.2 : 223 202 + in fire_ln: 8.4 : 222 202 + in fire_ln: 8.5 : 222 202 + in fire_ln: 8.5.1 : 222 202 + in fire_ln: 8.5.2 : 222 202 + in fire_ln: 8.5.3 : 222 202 + in fire_ln: 8.5.4 : 222 202 + in fire_ln: 8.5.5 : 222 202 + in fire_ln: 8.5.5 : ncod( 222 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3037318885 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.2935490906 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 202 3 ) = 0.2852081656 + in fire_ln: 8.5.5 : ycd( 222 201 1 ) = 0.3250381351 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 202 + in fire_ln: 8.6 : 222 202 + in fire_ln: 8.7 : 222 202 + in fire_ln: 8.8 : 222 202 + in fire_ln: 8.9 : 222 202 + in fire_ln: 8.10 : 222 202 + in fire_ln: 8.1 : 223 202 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 202 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 203 + in fire_ln: 8.2 : 223 202 + in fire_ln: 8.3 : 223 202 + in fire_ln: 8.3.1 : 222 203 + in fire_ln: 8.3.2 : 223 203 + in fire_ln: 8.4 : 223 202 + in fire_ln: 8.5 : 223 202 + in fire_ln: 8.5.1 : 223 202 + in fire_ln: 8.5.2 : 223 202 + in fire_ln: 8.5.3 : 223 202 + in fire_ln: 8.5.4 : 223 202 + in fire_ln: 8.5.5 : 223 202 + in fire_ln: 8.5.5 : ncod( 222 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.2852081656 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.4422360063 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 202 3 ) = -0.2935490906 + in fire_ln: 8.5.5 : xcd( 222 202 1 ) = -0.3037318885 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 223 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 202 + in fire_ln: 8.6 : 223 202 + in fire_ln: 8.7 : 223 202 + in fire_ln: 8.8 : 223 202 + in fire_ln: 8.9 : 223 202 + in fire_ln: 8.10 : 223 202 + in fire_ln: 8.1 : 201 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 202 + in fire_ln: 8.2 : 201 203 + in fire_ln: 8.3 : 201 203 + in fire_ln: 8.3.1 : 202 202 + in fire_ln: 8.3.2 : 201 202 + in fire_ln: 8.4 : 201 203 + in fire_ln: 8.5 : 201 203 + in fire_ln: 8.5.1 : 201 203 + in fire_ln: 8.5.2 : 201 203 + in fire_ln: 8.5.3 : 201 203 + in fire_ln: 8.5.4 : 201 203 + in fire_ln: 8.5.5 : 201 203 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 202 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 203 1 ) = -0.3485687077 + in fire_ln: 8.5.5 : xcd( 201 202 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 202 3 ) = 0.4735341072 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4753825068 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2822859287 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 203 + in fire_ln: 8.6 : 201 203 + in fire_ln: 8.7 : 201 203 + in fire_ln: 8.8 : 201 203 + in fire_ln: 8.9 : 201 203 + in fire_ln: 8.10 : 201 203 + in fire_ln: 8.1 : 223 203 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 203 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 204 + in fire_ln: 8.2 : 223 203 + in fire_ln: 8.2.1 : 223 203 + in fire_ln: 8.3 : 223 203 + in fire_ln: 8.3.1 : 224 204 + in fire_ln: 8.3.2 : 224 203 + in fire_ln: 8.4 : 223 203 + in fire_ln: 8.4.1 : 223 203 + in fire_ln: 8.5 : 223 203 + in fire_ln: 8.5.1 : 223 203 + in fire_ln: 8.5.2 : 223 203 + in fire_ln: 8.5.3 : 223 203 + in fire_ln: 8.5.4 : 223 203 + in fire_ln: 8.5.5 : 223 203 + in fire_ln: 8.5.5 : ncod( 223 202 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 203 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.2935490906 + in fire_ln: 8.5.5 : xcd( 224 203 3 ) = -0.4551339447 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 203 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 202 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 203 2 ) = 0.4422360063 + in fire_ln: 8.5.5 : ycd( 223 202 1 ) = 0.2852081656 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 203 + in fire_ln: 8.6 : 223 203 + in fire_ln: 8.7 : 223 203 + in fire_ln: 8.8 : 223 203 + in fire_ln: 8.9 : 223 203 + in fire_ln: 8.10 : 223 203 + in fire_ln: 8.1 : 224 203 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 203 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 204 + in fire_ln: 8.2 : 224 203 + in fire_ln: 8.3 : 224 203 + in fire_ln: 8.3.1 : 223 204 + in fire_ln: 8.3.2 : 224 204 + in fire_ln: 8.4 : 224 203 + in fire_ln: 8.5 : 224 203 + in fire_ln: 8.5.1 : 224 203 + in fire_ln: 8.5.2 : 224 203 + in fire_ln: 8.5.3 : 224 203 + in fire_ln: 8.5.4 : 224 203 + in fire_ln: 8.5.5 : 224 203 + in fire_ln: 8.5.5 : ncod( 223 203 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 2 ) = 0.2041094899 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 203 1 ) = 0.4422360063 + in fire_ln: 8.5.5 : ycd( 224 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 203 3 ) = -0.4551339447 + in fire_ln: 8.5.5 : xcd( 223 203 1 ) = -0.2935490906 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 224 203 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 203 + in fire_ln: 8.6 : 224 203 + in fire_ln: 8.7 : 224 203 + in fire_ln: 8.8 : 224 203 + in fire_ln: 8.9 : 224 203 + in fire_ln: 8.10 : 224 203 + in fire_ln: 8.1 : 200 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 203 + in fire_ln: 8.2 : 200 204 + in fire_ln: 8.3 : 200 204 + in fire_ln: 8.3.1 : 201 203 + in fire_ln: 8.3.2 : 201 204 + in fire_ln: 8.4 : 200 204 + in fire_ln: 8.5 : 200 204 + in fire_ln: 8.5.1 : 200 204 + in fire_ln: 8.5.2 : 200 204 + in fire_ln: 8.5.3 : 200 204 + in fire_ln: 8.5.4 : 200 204 + in fire_ln: 8.5.5 : 200 204 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3485687077 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2822859287 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3204801083 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 204 + in fire_ln: 8.6 : 200 204 + in fire_ln: 8.7 : 200 204 + in fire_ln: 8.8 : 200 204 + in fire_ln: 8.9 : 200 204 + in fire_ln: 8.10 : 200 204 + in fire_ln: 8.1 : 201 204 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 204 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 203 + in fire_ln: 8.2 : 201 204 + in fire_ln: 8.3 : 201 204 + in fire_ln: 8.3.1 : 200 203 + in fire_ln: 8.3.2 : 201 203 + in fire_ln: 8.4 : 201 204 + in fire_ln: 8.5 : 201 204 + in fire_ln: 8.5.1 : 201 204 + in fire_ln: 8.5.2 : 201 204 + in fire_ln: 8.5.3 : 201 204 + in fire_ln: 8.5.4 : 201 204 + in fire_ln: 8.5.5 : 201 204 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 203 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 203 2 ) = 0.4753825068 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 204 1 ) = -0.2822859287 + in fire_ln: 8.5.5 : ycd( 201 203 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 204 3 ) = -0.3485687077 + in fire_ln: 8.5.5 : xcd( 200 204 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 201 204 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 204 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 204 + in fire_ln: 8.6 : 201 204 + in fire_ln: 8.7 : 201 204 + in fire_ln: 8.8 : 201 204 + in fire_ln: 8.9 : 201 204 + in fire_ln: 8.10 : 201 204 + in fire_ln: 8.1 : 224 204 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 224 204 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 205 + in fire_ln: 8.2 : 224 204 + in fire_ln: 8.3 : 224 204 + in fire_ln: 8.3.1 : 225 205 + in fire_ln: 8.3.2 : 224 205 + in fire_ln: 8.4 : 224 204 + in fire_ln: 8.5 : 224 204 + in fire_ln: 8.5.1 : 224 204 + in fire_ln: 8.5.2 : 224 204 + in fire_ln: 8.5.3 : 224 204 + in fire_ln: 8.5.4 : 224 204 + in fire_ln: 8.5.5 : 224 204 + in fire_ln: 8.5.5 : ncod( 224 203 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.4551339447 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = -0.2949790284E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 204 2 ) = 0.2041094899 + in fire_ln: 8.5.5 : xcd( 224 203 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 204 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 203 1 ) = 0.4422360063 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 204 + in fire_ln: 8.6 : 224 204 + in fire_ln: 8.7 : 224 204 + in fire_ln: 8.8 : 224 204 + in fire_ln: 8.9 : 224 204 + in fire_ln: 8.10 : 224 204 + in fire_ln: 8.1 : 199 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 206 + in fire_ln: 8.2 : 199 205 + in fire_ln: 8.3 : 199 205 + in fire_ln: 8.3.1 : 200 206 + in fire_ln: 8.3.2 : 200 205 + in fire_ln: 8.4 : 199 205 + in fire_ln: 8.5 : 199 205 + in fire_ln: 8.5.1 : 199 205 + in fire_ln: 8.5.2 : 199 205 + in fire_ln: 8.5.3 : 199 205 + in fire_ln: 8.5.4 : 199 205 + in fire_ln: 8.5.5 : 199 205 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.3984570503 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6866011024E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3204801083 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 205 + in fire_ln: 8.6 : 199 205 + in fire_ln: 8.7 : 199 205 + in fire_ln: 8.8 : 199 205 + in fire_ln: 8.9 : 199 205 + in fire_ln: 8.10 : 199 205 + in fire_ln: 8.1 : 200 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 204 + in fire_ln: 8.2 : 200 205 + in fire_ln: 8.3 : 200 205 + in fire_ln: 8.3.1 : 199 204 + in fire_ln: 8.3.2 : 200 204 + in fire_ln: 8.4 : 200 205 + in fire_ln: 8.5 : 200 205 + in fire_ln: 8.5.1 : 200 205 + in fire_ln: 8.5.2 : 200 205 + in fire_ln: 8.5.3 : 200 205 + in fire_ln: 8.5.4 : 200 205 + in fire_ln: 8.5.5 : 200 205 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 204 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 204 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 205 1 ) = 0.3204801083 + in fire_ln: 8.5.5 : ycd( 200 204 3 ) = -0.2822859287 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 205 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : xcd( 199 205 1 ) = 0.3984570503 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 200 205 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 205 + in fire_ln: 8.6 : 200 205 + in fire_ln: 8.7 : 200 205 + in fire_ln: 8.8 : 200 205 + in fire_ln: 8.9 : 200 205 + in fire_ln: 8.10 : 200 205 + in fire_ln: 8.1 : 224 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 205 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 204 + in fire_ln: 8.2 : 224 205 + in fire_ln: 8.3 : 224 205 + in fire_ln: 8.3.1 : 225 204 + in fire_ln: 8.3.2 : 225 205 + in fire_ln: 8.4 : 224 205 + in fire_ln: 8.5 : 224 205 + in fire_ln: 8.5.1 : 224 205 + in fire_ln: 8.5.2 : 224 205 + in fire_ln: 8.5.3 : 224 205 + in fire_ln: 8.5.4 : 224 205 + in fire_ln: 8.5.5 : 224 205 + in fire_ln: 8.5.5 : ncod( 224 204 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.2041094899 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2189203054 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 204 1 ) = -0.4551339447 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 205 3 ) = -0.2949790284E-01 + in fire_ln: 8.5.5 : ycd( 224 204 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 205 + in fire_ln: 8.6 : 224 205 + in fire_ln: 8.7 : 224 205 + in fire_ln: 8.8 : 224 205 + in fire_ln: 8.9 : 224 205 + in fire_ln: 8.10 : 224 205 + in fire_ln: 8.1 : 225 205 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 205 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 206 + in fire_ln: 8.2 : 225 205 + in fire_ln: 8.3 : 225 205 + in fire_ln: 8.3.1 : 224 206 + in fire_ln: 8.3.2 : 225 206 + in fire_ln: 8.4 : 225 205 + in fire_ln: 8.5 : 225 205 + in fire_ln: 8.5.1 : 225 205 + in fire_ln: 8.5.2 : 225 205 + in fire_ln: 8.5.3 : 225 205 + in fire_ln: 8.5.4 : 225 205 + in fire_ln: 8.5.5 : 225 205 + in fire_ln: 8.5.5 : ncod( 224 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2795698643 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = -0.2949790284E-01 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 205 3 ) = -0.2189203054 + in fire_ln: 8.5.5 : xcd( 224 205 1 ) = 0.2041094899 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 225 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 205 + in fire_ln: 8.6 : 225 205 + in fire_ln: 8.7 : 225 205 + in fire_ln: 8.8 : 225 205 + in fire_ln: 8.9 : 225 205 + in fire_ln: 8.10 : 225 205 + in fire_ln: 8.1 : 199 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 205 + in fire_ln: 8.2 : 199 206 + in fire_ln: 8.3 : 199 206 + in fire_ln: 8.3.1 : 200 205 + in fire_ln: 8.3.2 : 199 205 + in fire_ln: 8.4 : 199 206 + in fire_ln: 8.5 : 199 206 + in fire_ln: 8.5.1 : 199 206 + in fire_ln: 8.5.2 : 199 206 + in fire_ln: 8.5.3 : 199 206 + in fire_ln: 8.5.4 : 199 206 + in fire_ln: 8.5.5 : 199 206 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 205 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 206 1 ) = -0.6866011024E-01 + in fire_ln: 8.5.5 : xcd( 199 205 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 205 3 ) = 0.3204801083 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.3984570503 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4472185671 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 206 + in fire_ln: 8.6 : 199 206 + in fire_ln: 8.7 : 199 206 + in fire_ln: 8.8 : 199 206 + in fire_ln: 8.9 : 199 206 + in fire_ln: 8.10 : 199 206 + in fire_ln: 8.1 : 225 206 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 206 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 207 + in fire_ln: 8.2 : 225 206 + in fire_ln: 8.3 : 225 206 + in fire_ln: 8.3.1 : 226 207 + in fire_ln: 8.3.2 : 225 207 + in fire_ln: 8.4 : 225 206 + in fire_ln: 8.5 : 225 206 + in fire_ln: 8.5.1 : 225 206 + in fire_ln: 8.5.2 : 225 206 + in fire_ln: 8.5.3 : 225 206 + in fire_ln: 8.5.4 : 225 206 + in fire_ln: 8.5.5 : 225 206 + in fire_ln: 8.5.5 : ncod( 225 205 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2189203054 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.9197872132E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 206 2 ) = 0.2795698643 + in fire_ln: 8.5.5 : xcd( 225 205 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 206 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 205 1 ) = -0.2949790284E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 206 + in fire_ln: 8.6 : 225 206 + in fire_ln: 8.7 : 225 206 + in fire_ln: 8.8 : 225 206 + in fire_ln: 8.9 : 225 206 + in fire_ln: 8.10 : 225 206 + in fire_ln: 8.1 : 199 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 206 + in fire_ln: 8.2 : 199 207 + in fire_ln: 8.3 : 199 207 + in fire_ln: 8.3.1 : 198 206 + in fire_ln: 8.3.2 : 199 206 + in fire_ln: 8.4 : 199 207 + in fire_ln: 8.5 : 199 207 + in fire_ln: 8.5.1 : 199 207 + in fire_ln: 8.5.2 : 199 207 + in fire_ln: 8.5.3 : 199 207 + in fire_ln: 8.5.4 : 199 207 + in fire_ln: 8.5.5 : 199 207 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 206 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 207 1 ) = -0.4472185671 + in fire_ln: 8.5.5 : xcd( 199 206 2 ) = 0.3984570503 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 206 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6866011024E-01 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 207 + in fire_ln: 8.6 : 199 207 + in fire_ln: 8.7 : 199 207 + in fire_ln: 8.8 : 199 207 + in fire_ln: 8.9 : 199 207 + in fire_ln: 8.10 : 199 207 + in fire_ln: 8.1 : 225 207 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 207 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 208 + in fire_ln: 8.2 : 225 207 + in fire_ln: 8.2.1 : 225 207 + in fire_ln: 8.3 : 225 207 + in fire_ln: 8.3.1 : 226 208 + in fire_ln: 8.3.2 : 226 207 + in fire_ln: 8.4 : 225 207 + in fire_ln: 8.4.1 : 225 207 + in fire_ln: 8.5 : 225 207 + in fire_ln: 8.5.1 : 225 207 + in fire_ln: 8.5.2 : 225 207 + in fire_ln: 8.5.3 : 225 207 + in fire_ln: 8.5.4 : 225 207 + in fire_ln: 8.5.5 : 225 207 + in fire_ln: 8.5.5 : ncod( 225 206 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2795698643 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.3569510877 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 207 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 206 1 ) = -0.2189203054 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 207 2 ) = 0.9197872132E-01 + in fire_ln: 8.5.5 : ycd( 225 206 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 207 + in fire_ln: 8.6 : 225 207 + in fire_ln: 8.7 : 225 207 + in fire_ln: 8.8 : 225 207 + in fire_ln: 8.9 : 225 207 + in fire_ln: 8.10 : 225 207 + in fire_ln: 8.1 : 226 207 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 207 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 208 + in fire_ln: 8.2 : 226 207 + in fire_ln: 8.3 : 226 207 + in fire_ln: 8.3.1 : 225 208 + in fire_ln: 8.3.2 : 226 208 + in fire_ln: 8.4 : 226 207 + in fire_ln: 8.5 : 226 207 + in fire_ln: 8.5.1 : 226 207 + in fire_ln: 8.5.2 : 226 207 + in fire_ln: 8.5.3 : 226 207 + in fire_ln: 8.5.4 : 226 207 + in fire_ln: 8.5.5 : 226 207 + in fire_ln: 8.5.5 : ncod( 225 207 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.7391238213E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.9197872132E-01 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 207 3 ) = -0.3569510877 + in fire_ln: 8.5.5 : xcd( 225 207 1 ) = 0.2795698643 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 226 207 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 226 207 + in fire_ln: 8.6 : 226 207 + in fire_ln: 8.7 : 226 207 + in fire_ln: 8.8 : 226 207 + in fire_ln: 8.9 : 226 207 + in fire_ln: 8.10 : 226 207 + in fire_ln: 8.1 : 198 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 208 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 207 + in fire_ln: 8.2 : 198 208 + in fire_ln: 8.3 : 198 208 + in fire_ln: 8.3.1 : 199 207 + in fire_ln: 8.3.2 : 199 208 + in fire_ln: 8.4 : 198 208 + in fire_ln: 8.5 : 198 208 + in fire_ln: 8.5.1 : 198 208 + in fire_ln: 8.5.2 : 198 208 + in fire_ln: 8.5.3 : 198 208 + in fire_ln: 8.5.4 : 198 208 + in fire_ln: 8.5.5 : 198 208 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2591497898 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4472185671 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4221726954E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 208 + in fire_ln: 8.6 : 198 208 + in fire_ln: 8.7 : 198 208 + in fire_ln: 8.8 : 198 208 + in fire_ln: 8.9 : 198 208 + in fire_ln: 8.10 : 198 208 + in fire_ln: 8.1 : 199 208 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 207 + in fire_ln: 8.2 : 199 208 + in fire_ln: 8.3 : 199 208 + in fire_ln: 8.3.1 : 198 207 + in fire_ln: 8.3.2 : 199 207 + in fire_ln: 8.4 : 199 208 + in fire_ln: 8.5 : 199 208 + in fire_ln: 8.5.1 : 199 208 + in fire_ln: 8.5.2 : 199 208 + in fire_ln: 8.5.3 : 199 208 + in fire_ln: 8.5.4 : 199 208 + in fire_ln: 8.5.5 : 199 208 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 207 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 207 2 ) = -0.6866011024E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 208 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : ycd( 199 207 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 208 3 ) = -0.4472185671 + in fire_ln: 8.5.5 : xcd( 198 208 1 ) = 0.2591497898 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 199 208 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 208 + in fire_ln: 8.6 : 199 208 + in fire_ln: 8.7 : 199 208 + in fire_ln: 8.8 : 199 208 + in fire_ln: 8.9 : 199 208 + in fire_ln: 8.10 : 199 208 + in fire_ln: 8.1 : 226 208 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 208 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 209 + in fire_ln: 8.2 : 226 208 + in fire_ln: 8.3 : 226 208 + in fire_ln: 8.3.1 : 225 209 + in fire_ln: 8.3.2 : 226 209 + in fire_ln: 8.4 : 226 208 + in fire_ln: 8.5 : 226 208 + in fire_ln: 8.5.1 : 226 208 + in fire_ln: 8.5.2 : 226 208 + in fire_ln: 8.5.3 : 226 208 + in fire_ln: 8.5.4 : 226 208 + in fire_ln: 8.5.5 : 226 208 + in fire_ln: 8.5.5 : ncod( 226 207 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.3569510877 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1725003719 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 208 2 ) = -0.7391238213E-01 + in fire_ln: 8.5.5 : xcd( 226 207 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 208 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 207 1 ) = 0.9197872132E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 208 + in fire_ln: 8.6 : 226 208 + in fire_ln: 8.7 : 226 208 + in fire_ln: 8.8 : 226 208 + in fire_ln: 8.9 : 226 208 + in fire_ln: 8.10 : 226 208 + in fire_ln: 8.1 : 198 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 208 + in fire_ln: 8.2 : 198 209 + in fire_ln: 8.3 : 198 209 + in fire_ln: 8.3.1 : 199 208 + in fire_ln: 8.3.2 : 198 208 + in fire_ln: 8.4 : 198 209 + in fire_ln: 8.5 : 198 209 + in fire_ln: 8.5.1 : 198 209 + in fire_ln: 8.5.2 : 198 209 + in fire_ln: 8.5.3 : 198 209 + in fire_ln: 8.5.4 : 198 209 + in fire_ln: 8.5.5 : 198 209 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 208 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 198 209 1 ) = 0.4221726954E-01 + in fire_ln: 8.5.5 : xcd( 198 208 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 208 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2591497898 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.1005131900 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 209 + in fire_ln: 8.6 : 198 209 + in fire_ln: 8.7 : 198 209 + in fire_ln: 8.8 : 198 209 + in fire_ln: 8.9 : 198 209 + in fire_ln: 8.10 : 198 209 + in fire_ln: 8.1 : 226 209 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 209 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 210 + in fire_ln: 8.2 : 226 209 + in fire_ln: 8.3 : 226 209 + in fire_ln: 8.3.1 : 227 210 + in fire_ln: 8.3.2 : 226 210 + in fire_ln: 8.4 : 226 209 + in fire_ln: 8.5 : 226 209 + in fire_ln: 8.5.1 : 226 209 + in fire_ln: 8.5.2 : 226 209 + in fire_ln: 8.5.3 : 226 209 + in fire_ln: 8.5.4 : 226 209 + in fire_ln: 8.5.5 : 226 209 + in fire_ln: 8.5.5 : ncod( 226 208 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.7391238213E-01 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.3159410357 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 209 2 ) = 0.1725003719 + in fire_ln: 8.5.5 : xcd( 226 208 1 ) = -0.3569510877 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 209 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 208 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 209 + in fire_ln: 8.6 : 226 209 + in fire_ln: 8.7 : 226 209 + in fire_ln: 8.8 : 226 209 + in fire_ln: 8.9 : 226 209 + in fire_ln: 8.10 : 226 209 + in fire_ln: 8.1 : 198 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 209 + in fire_ln: 8.2 : 198 210 + in fire_ln: 8.3 : 198 210 + in fire_ln: 8.3.1 : 199 209 + in fire_ln: 8.3.2 : 198 209 + in fire_ln: 8.4 : 198 210 + in fire_ln: 8.5 : 198 210 + in fire_ln: 8.5.1 : 198 210 + in fire_ln: 8.5.2 : 198 210 + in fire_ln: 8.5.3 : 198 210 + in fire_ln: 8.5.4 : 198 210 + in fire_ln: 8.5.5 : 198 210 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 209 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 210 1 ) = -0.1005131900 + in fire_ln: 8.5.5 : xcd( 198 209 2 ) = 0.2591497898 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 209 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4221726954E-01 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1713418067 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 210 + in fire_ln: 8.6 : 198 210 + in fire_ln: 8.7 : 198 210 + in fire_ln: 8.8 : 198 210 + in fire_ln: 8.9 : 198 210 + in fire_ln: 8.10 : 198 210 + in fire_ln: 8.1 : 226 210 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 210 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 211 + in fire_ln: 8.2 : 226 210 + in fire_ln: 8.3 : 226 210 + in fire_ln: 8.3.1 : 227 211 + in fire_ln: 8.3.2 : 226 211 + in fire_ln: 8.4 : 226 210 + in fire_ln: 8.5 : 226 210 + in fire_ln: 8.5.1 : 226 210 + in fire_ln: 8.5.2 : 226 210 + in fire_ln: 8.5.3 : 226 210 + in fire_ln: 8.5.4 : 226 210 + in fire_ln: 8.5.5 : 226 210 + in fire_ln: 8.5.5 : ncod( 226 209 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1725003719 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3870889246 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 210 2 ) = 0.3159410357 + in fire_ln: 8.5.5 : xcd( 226 209 1 ) = -0.7391238213E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 210 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 209 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 210 + in fire_ln: 8.6 : 226 210 + in fire_ln: 8.7 : 226 210 + in fire_ln: 8.8 : 226 210 + in fire_ln: 8.9 : 226 210 + in fire_ln: 8.10 : 226 210 + in fire_ln: 8.1 : 198 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 211 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 210 + in fire_ln: 8.2 : 198 211 + in fire_ln: 8.3 : 198 211 + in fire_ln: 8.3.1 : 197 210 + in fire_ln: 8.3.2 : 198 210 + in fire_ln: 8.4 : 198 211 + in fire_ln: 8.5 : 198 211 + in fire_ln: 8.5.1 : 198 211 + in fire_ln: 8.5.2 : 198 211 + in fire_ln: 8.5.3 : 198 211 + in fire_ln: 8.5.4 : 198 211 + in fire_ln: 8.5.5 : 198 211 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 210 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 211 1 ) = -0.1713418067 + in fire_ln: 8.5.5 : xcd( 198 210 2 ) = 0.4221726954E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 210 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.1005131900 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1713417470 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 211 + in fire_ln: 8.6 : 198 211 + in fire_ln: 8.7 : 198 211 + in fire_ln: 8.8 : 198 211 + in fire_ln: 8.9 : 198 211 + in fire_ln: 8.10 : 198 211 + in fire_ln: 8.1 : 226 211 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 211 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 212 + in fire_ln: 8.2 : 226 211 + in fire_ln: 8.3 : 226 211 + in fire_ln: 8.3.1 : 227 212 + in fire_ln: 8.3.2 : 226 212 + in fire_ln: 8.4 : 226 211 + in fire_ln: 8.5 : 226 211 + in fire_ln: 8.5.1 : 226 211 + in fire_ln: 8.5.2 : 226 211 + in fire_ln: 8.5.3 : 226 211 + in fire_ln: 8.5.4 : 226 211 + in fire_ln: 8.5.5 : 226 211 + in fire_ln: 8.5.5 : ncod( 226 210 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.3159410357 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3870838881 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 211 2 ) = 0.3870889246 + in fire_ln: 8.5.5 : xcd( 226 210 1 ) = 0.1725003719 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 211 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 210 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 211 + in fire_ln: 8.6 : 226 211 + in fire_ln: 8.7 : 226 211 + in fire_ln: 8.8 : 226 211 + in fire_ln: 8.9 : 226 211 + in fire_ln: 8.10 : 226 211 + in fire_ln: 8.1 : 198 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 212 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 211 + in fire_ln: 8.2 : 198 212 + in fire_ln: 8.3 : 198 212 + in fire_ln: 8.3.1 : 197 211 + in fire_ln: 8.3.2 : 198 211 + in fire_ln: 8.4 : 198 212 + in fire_ln: 8.5 : 198 212 + in fire_ln: 8.5.1 : 198 212 + in fire_ln: 8.5.2 : 198 212 + in fire_ln: 8.5.3 : 198 212 + in fire_ln: 8.5.4 : 198 212 + in fire_ln: 8.5.5 : 198 212 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 211 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 212 1 ) = -0.1713417470 + in fire_ln: 8.5.5 : xcd( 198 211 2 ) = -0.1005131900 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 211 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1713418067 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.1005131304 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 212 + in fire_ln: 8.6 : 198 212 + in fire_ln: 8.7 : 198 212 + in fire_ln: 8.8 : 198 212 + in fire_ln: 8.9 : 198 212 + in fire_ln: 8.10 : 198 212 + in fire_ln: 8.1 : 226 212 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 212 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 213 + in fire_ln: 8.2 : 226 212 + in fire_ln: 8.3 : 226 212 + in fire_ln: 8.3.1 : 227 213 + in fire_ln: 8.3.2 : 226 213 + in fire_ln: 8.4 : 226 212 + in fire_ln: 8.5 : 226 212 + in fire_ln: 8.5.1 : 226 212 + in fire_ln: 8.5.2 : 226 212 + in fire_ln: 8.5.3 : 226 212 + in fire_ln: 8.5.4 : 226 212 + in fire_ln: 8.5.5 : 226 212 + in fire_ln: 8.5.5 : ncod( 226 211 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3870889246 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.3159258366 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 212 2 ) = 0.3870838881 + in fire_ln: 8.5.5 : xcd( 226 211 1 ) = 0.3159410357 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 212 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 211 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 212 + in fire_ln: 8.6 : 226 212 + in fire_ln: 8.7 : 226 212 + in fire_ln: 8.8 : 226 212 + in fire_ln: 8.9 : 226 212 + in fire_ln: 8.10 : 226 212 + in fire_ln: 8.1 : 198 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 213 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 212 + in fire_ln: 8.2 : 198 213 + in fire_ln: 8.3 : 198 213 + in fire_ln: 8.3.1 : 197 212 + in fire_ln: 8.3.2 : 198 212 + in fire_ln: 8.4 : 198 213 + in fire_ln: 8.5 : 198 213 + in fire_ln: 8.5.1 : 198 213 + in fire_ln: 8.5.2 : 198 213 + in fire_ln: 8.5.3 : 198 213 + in fire_ln: 8.5.4 : 198 213 + in fire_ln: 8.5.5 : 198 213 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 212 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 213 1 ) = -0.1005131304 + in fire_ln: 8.5.5 : xcd( 198 212 2 ) = -0.1713418067 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 212 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1713417470 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 213 + in fire_ln: 8.6 : 198 213 + in fire_ln: 8.7 : 198 213 + in fire_ln: 8.8 : 198 213 + in fire_ln: 8.9 : 198 213 + in fire_ln: 8.10 : 198 213 + in fire_ln: 8.1 : 226 213 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 213 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 214 + in fire_ln: 8.2 : 226 213 + in fire_ln: 8.3 : 226 213 + in fire_ln: 8.3.1 : 227 214 + in fire_ln: 8.3.2 : 226 214 + in fire_ln: 8.4 : 226 213 + in fire_ln: 8.5 : 226 213 + in fire_ln: 8.5.1 : 226 213 + in fire_ln: 8.5.2 : 226 213 + in fire_ln: 8.5.3 : 226 213 + in fire_ln: 8.5.4 : 226 213 + in fire_ln: 8.5.5 : 226 213 + in fire_ln: 8.5.5 : ncod( 226 212 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3870838881 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1724728942 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 213 2 ) = 0.3159258366 + in fire_ln: 8.5.5 : xcd( 226 212 1 ) = 0.3870889246 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 213 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 212 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 213 + in fire_ln: 8.6 : 226 213 + in fire_ln: 8.7 : 226 213 + in fire_ln: 8.8 : 226 213 + in fire_ln: 8.9 : 226 213 + in fire_ln: 8.10 : 226 213 + in fire_ln: 8.1 : 198 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 214 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 197 213 + in fire_ln: 8.2 : 198 214 + in fire_ln: 8.3 : 198 214 + in fire_ln: 8.3.1 : 197 213 + in fire_ln: 8.3.2 : 198 213 + in fire_ln: 8.4 : 198 214 + in fire_ln: 8.5 : 198 214 + in fire_ln: 8.5.1 : 198 214 + in fire_ln: 8.5.2 : 198 214 + in fire_ln: 8.5.3 : 198 214 + in fire_ln: 8.5.4 : 198 214 + in fire_ln: 8.5.5 : 198 214 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 213 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 214 1 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : xcd( 198 213 2 ) = -0.1713417470 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 213 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.1005131304 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2591498494 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 214 + in fire_ln: 8.6 : 198 214 + in fire_ln: 8.7 : 198 214 + in fire_ln: 8.8 : 198 214 + in fire_ln: 8.9 : 198 214 + in fire_ln: 8.10 : 198 214 + in fire_ln: 8.1 : 226 214 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 214 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 227 215 + in fire_ln: 8.2 : 226 214 + in fire_ln: 8.3 : 226 214 + in fire_ln: 8.3.1 : 227 215 + in fire_ln: 8.3.2 : 226 215 + in fire_ln: 8.4 : 226 214 + in fire_ln: 8.5 : 226 214 + in fire_ln: 8.5.1 : 226 214 + in fire_ln: 8.5.2 : 226 214 + in fire_ln: 8.5.3 : 226 214 + in fire_ln: 8.5.4 : 226 214 + in fire_ln: 8.5.5 : 226 214 + in fire_ln: 8.5.5 : ncod( 226 213 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.3159258366 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.7394893467E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 214 2 ) = 0.1724728942 + in fire_ln: 8.5.5 : xcd( 226 213 1 ) = 0.3870838881 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 214 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 213 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 214 + in fire_ln: 8.6 : 226 214 + in fire_ln: 8.7 : 226 214 + in fire_ln: 8.8 : 226 214 + in fire_ln: 8.9 : 226 214 + in fire_ln: 8.10 : 226 214 + in fire_ln: 8.1 : 198 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 198 215 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 214 + in fire_ln: 8.2 : 198 215 + in fire_ln: 8.3 : 198 215 + in fire_ln: 8.3.1 : 199 214 + in fire_ln: 8.3.2 : 198 214 + in fire_ln: 8.4 : 198 215 + in fire_ln: 8.5 : 198 215 + in fire_ln: 8.5.1 : 198 215 + in fire_ln: 8.5.2 : 198 215 + in fire_ln: 8.5.3 : 198 215 + in fire_ln: 8.5.4 : 198 215 + in fire_ln: 8.5.5 : 198 215 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 214 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 215 1 ) = 0.2591498494 + in fire_ln: 8.5.5 : xcd( 198 214 2 ) = -0.1005131304 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 214 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.3211852908 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 198 215 + in fire_ln: 8.6 : 198 215 + in fire_ln: 8.7 : 198 215 + in fire_ln: 8.8 : 198 215 + in fire_ln: 8.9 : 198 215 + in fire_ln: 8.10 : 198 215 + in fire_ln: 8.1 : 226 215 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 215 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 215 + in fire_ln: 8.3 : 226 215 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 226 216 + in fire_ln: 8.4 : 226 215 + in fire_ln: 8.5 : 226 215 + in fire_ln: 8.5.1 : 226 215 + in fire_ln: 8.5.2 : 226 215 + in fire_ln: 8.5.3 : 226 215 + in fire_ln: 8.5.4 : 226 215 + in fire_ln: 8.5.5 : 226 215 + in fire_ln: 8.5.5 : ncod( 226 214 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1724728942 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.3569954932 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 215 2 ) = -0.7394893467E-01 + in fire_ln: 8.5.5 : xcd( 226 214 1 ) = 0.3159258366 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 215 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 214 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 215 + in fire_ln: 8.6 : 226 215 + in fire_ln: 8.7 : 226 215 + in fire_ln: 8.8 : 226 215 + in fire_ln: 8.9 : 226 215 + in fire_ln: 8.10 : 226 215 + in fire_ln: 8.1 : 198 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 198 216 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 215 + in fire_ln: 8.2 : 198 216 + in fire_ln: 8.3 : 198 216 + in fire_ln: 8.3.1 : 199 215 + in fire_ln: 8.3.2 : 198 215 + in fire_ln: 8.4 : 198 216 + in fire_ln: 8.5 : 198 216 + in fire_ln: 8.5.1 : 198 216 + in fire_ln: 8.5.2 : 198 216 + in fire_ln: 8.5.3 : 198 216 + in fire_ln: 8.5.4 : 198 216 + in fire_ln: 8.5.5 : 198 216 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 198 215 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 198 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 198 215 2 ) = 0.4221739620E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 198 216 1 ) = 0.3211852908 + in fire_ln: 8.5.5 : ycd( 198 215 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2591498494 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4472182095 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 198 216 + in fire_ln: 8.6 : 198 216 + in fire_ln: 8.7 : 198 216 + in fire_ln: 8.8 : 198 216 + in fire_ln: 8.9 : 198 216 + in fire_ln: 8.10 : 198 216 + in fire_ln: 8.1 : 199 216 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 216 + in fire_ln: 8.3 : 199 216 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 198 216 + in fire_ln: 8.4 : 199 216 + in fire_ln: 8.5 : 199 216 + in fire_ln: 8.5.1 : 199 216 + in fire_ln: 8.5.2 : 199 216 + in fire_ln: 8.5.3 : 199 216 + in fire_ln: 8.5.4 : 199 216 + in fire_ln: 8.5.5 : 199 216 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 198 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 216 1 ) = -0.4472182095 + in fire_ln: 8.5.5 : xcd( 198 216 3 ) = 0.2591498494 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 199 216 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 198 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.3211852908 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 216 + in fire_ln: 8.6 : 199 216 + in fire_ln: 8.7 : 199 216 + in fire_ln: 8.8 : 199 216 + in fire_ln: 8.9 : 199 216 + in fire_ln: 8.10 : 199 216 + in fire_ln: 8.1 : 226 216 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 226 216 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 217 + in fire_ln: 8.2 : 226 216 + in fire_ln: 8.3 : 226 216 + in fire_ln: 8.3.1 : 225 217 + in fire_ln: 8.3.2 : 226 217 + in fire_ln: 8.4 : 226 216 + in fire_ln: 8.5 : 226 216 + in fire_ln: 8.5.1 : 226 216 + in fire_ln: 8.5.2 : 226 216 + in fire_ln: 8.5.3 : 226 216 + in fire_ln: 8.5.4 : 226 216 + in fire_ln: 8.5.5 : 226 216 + in fire_ln: 8.5.5 : ncod( 226 215 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.7394893467E-01 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.9211807698E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 226 216 2 ) = -0.3569954932 + in fire_ln: 8.5.5 : xcd( 226 215 1 ) = 0.1724728942 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 216 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 215 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 216 + in fire_ln: 8.6 : 226 216 + in fire_ln: 8.7 : 226 216 + in fire_ln: 8.8 : 226 216 + in fire_ln: 8.9 : 226 216 + in fire_ln: 8.10 : 226 216 + in fire_ln: 8.1 : 199 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 216 + in fire_ln: 8.2 : 199 217 + in fire_ln: 8.3 : 199 217 + in fire_ln: 8.3.1 : 198 216 + in fire_ln: 8.3.2 : 199 216 + in fire_ln: 8.4 : 199 217 + in fire_ln: 8.5 : 199 217 + in fire_ln: 8.5.1 : 199 217 + in fire_ln: 8.5.2 : 199 217 + in fire_ln: 8.5.3 : 199 217 + in fire_ln: 8.5.4 : 199 217 + in fire_ln: 8.5.5 : 199 217 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 199 216 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 199 217 1 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : xcd( 199 216 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 216 3 ) = 0.3211852908 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4472182095 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.3984572291 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 217 + in fire_ln: 8.6 : 199 217 + in fire_ln: 8.7 : 199 217 + in fire_ln: 8.8 : 199 217 + in fire_ln: 8.9 : 199 217 + in fire_ln: 8.10 : 199 217 + in fire_ln: 8.1 : 225 217 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 217 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 226 218 + in fire_ln: 8.2 : 225 217 + in fire_ln: 8.2.1 : 225 217 + in fire_ln: 8.3 : 225 217 + in fire_ln: 8.3.1 : 226 218 + in fire_ln: 8.3.2 : 225 218 + in fire_ln: 8.4 : 225 217 + in fire_ln: 8.4.1 : 225 217 + in fire_ln: 8.5 : 225 217 + in fire_ln: 8.5.1 : 225 217 + in fire_ln: 8.5.2 : 225 217 + in fire_ln: 8.5.3 : 225 217 + in fire_ln: 8.5.4 : 225 217 + in fire_ln: 8.5.5 : 225 217 + in fire_ln: 8.5.5 : ncod( 226 217 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2189903110 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.9211807698E-01 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2795101106 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.3569954932 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 225 217 + in fire_ln: 8.6 : 225 217 + in fire_ln: 8.7 : 225 217 + in fire_ln: 8.8 : 225 217 + in fire_ln: 8.9 : 225 217 + in fire_ln: 8.10 : 225 217 + in fire_ln: 8.1 : 226 217 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 226 217 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 225 216 + in fire_ln: 8.2 : 226 217 + in fire_ln: 8.3 : 226 217 + in fire_ln: 8.3.1 : 225 216 + in fire_ln: 8.3.2 : 225 217 + in fire_ln: 8.4 : 226 217 + in fire_ln: 8.5 : 226 217 + in fire_ln: 8.5.1 : 226 217 + in fire_ln: 8.5.2 : 226 217 + in fire_ln: 8.5.3 : 226 217 + in fire_ln: 8.5.4 : 226 217 + in fire_ln: 8.5.5 : 226 217 + in fire_ln: 8.5.5 : ncod( 226 216 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 226 217 1 ) = -0.3569954932 + in fire_ln: 8.5.5 : xcd( 225 217 2 ) = 0.2795101106 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 226 217 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 226 217 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 226 216 1 ) = -0.7394893467E-01 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 226 217 3 ) = -0.9211807698E-01 + in fire_ln: 8.5.5 : ycd( 226 216 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 226 217 + in fire_ln: 8.6 : 226 217 + in fire_ln: 8.7 : 226 217 + in fire_ln: 8.8 : 226 217 + in fire_ln: 8.9 : 226 217 + in fire_ln: 8.10 : 226 217 + in fire_ln: 8.1 : 199 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 199 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 198 217 + in fire_ln: 8.2 : 199 218 + in fire_ln: 8.3 : 199 218 + in fire_ln: 8.3.1 : 198 217 + in fire_ln: 8.3.2 : 199 217 + in fire_ln: 8.4 : 199 218 + in fire_ln: 8.5 : 199 218 + in fire_ln: 8.5.1 : 199 218 + in fire_ln: 8.5.2 : 199 218 + in fire_ln: 8.5.3 : 199 218 + in fire_ln: 8.5.4 : 199 218 + in fire_ln: 8.5.5 : 199 218 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 217 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 218 1 ) = 0.3984572291 + in fire_ln: 8.5.5 : xcd( 199 217 2 ) = -0.4472182095 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 217 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3204802275 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 199 218 + in fire_ln: 8.6 : 199 218 + in fire_ln: 8.7 : 199 218 + in fire_ln: 8.8 : 199 218 + in fire_ln: 8.9 : 199 218 + in fire_ln: 8.10 : 199 218 + in fire_ln: 8.1 : 225 218 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 225 218 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 219 + in fire_ln: 8.2 : 225 218 + in fire_ln: 8.3 : 225 218 + in fire_ln: 8.3.1 : 224 219 + in fire_ln: 8.3.2 : 225 219 + in fire_ln: 8.4 : 225 218 + in fire_ln: 8.5 : 225 218 + in fire_ln: 8.5.1 : 225 218 + in fire_ln: 8.5.2 : 225 218 + in fire_ln: 8.5.3 : 225 218 + in fire_ln: 8.5.4 : 225 218 + in fire_ln: 8.5.5 : 225 218 + in fire_ln: 8.5.5 : ncod( 225 217 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2795101106 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = 0.2935212478E-01 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 225 218 2 ) = -0.2189903110 + in fire_ln: 8.5.5 : xcd( 225 217 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 218 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 217 1 ) = -0.9211807698E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 218 + in fire_ln: 8.6 : 225 218 + in fire_ln: 8.7 : 225 218 + in fire_ln: 8.8 : 225 218 + in fire_ln: 8.9 : 225 218 + in fire_ln: 8.10 : 225 218 + in fire_ln: 8.1 : 199 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 199 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 218 + in fire_ln: 8.2 : 199 219 + in fire_ln: 8.3 : 199 219 + in fire_ln: 8.3.1 : 200 218 + in fire_ln: 8.3.2 : 199 218 + in fire_ln: 8.4 : 199 219 + in fire_ln: 8.5 : 199 219 + in fire_ln: 8.5.1 : 199 219 + in fire_ln: 8.5.2 : 199 219 + in fire_ln: 8.5.3 : 199 219 + in fire_ln: 8.5.4 : 199 219 + in fire_ln: 8.5.5 : 199 219 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 218 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 199 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 199 218 2 ) = -0.6865978241E-01 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 199 219 1 ) = -0.3204802275 + in fire_ln: 8.5.5 : ycd( 199 218 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.3984572291 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 199 219 + in fire_ln: 8.6 : 199 219 + in fire_ln: 8.7 : 199 219 + in fire_ln: 8.8 : 199 219 + in fire_ln: 8.9 : 199 219 + in fire_ln: 8.10 : 199 219 + in fire_ln: 8.1 : 200 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 218 + in fire_ln: 8.2 : 200 219 + in fire_ln: 8.3 : 200 219 + in fire_ln: 8.3.1 : 199 218 + in fire_ln: 8.3.2 : 199 219 + in fire_ln: 8.4 : 200 219 + in fire_ln: 8.5 : 200 219 + in fire_ln: 8.5.1 : 200 219 + in fire_ln: 8.5.2 : 200 219 + in fire_ln: 8.5.3 : 200 219 + in fire_ln: 8.5.4 : 200 219 + in fire_ln: 8.5.5 : 200 219 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 199 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 219 1 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : xcd( 199 219 3 ) = 0.3984572291 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 200 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 199 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3204802275 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2822859585 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 200 219 + in fire_ln: 8.6 : 200 219 + in fire_ln: 8.7 : 200 219 + in fire_ln: 8.8 : 200 219 + in fire_ln: 8.9 : 200 219 + in fire_ln: 8.10 : 200 219 + in fire_ln: 8.1 : 224 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 219 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 225 220 + in fire_ln: 8.2 : 224 219 + in fire_ln: 8.3 : 224 219 + in fire_ln: 8.3.1 : 225 220 + in fire_ln: 8.3.2 : 224 220 + in fire_ln: 8.4 : 224 219 + in fire_ln: 8.5 : 224 219 + in fire_ln: 8.5.1 : 224 219 + in fire_ln: 8.5.2 : 224 219 + in fire_ln: 8.5.3 : 224 219 + in fire_ln: 8.5.4 : 224 219 + in fire_ln: 8.5.5 : 224 219 + in fire_ln: 8.5.5 : ncod( 225 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 2 ) = -0.4553085566 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = 0.2935212478E-01 + in fire_ln: 8.5.5 : ycd( 224 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.2040299326 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2189903110 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 224 219 + in fire_ln: 8.6 : 224 219 + in fire_ln: 8.7 : 224 219 + in fire_ln: 8.8 : 224 219 + in fire_ln: 8.9 : 224 219 + in fire_ln: 8.10 : 224 219 + in fire_ln: 8.1 : 225 219 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 225 219 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 224 220 + in fire_ln: 8.2 : 225 219 + in fire_ln: 8.3 : 225 219 + in fire_ln: 8.3.1 : 224 220 + in fire_ln: 8.3.2 : 224 219 + in fire_ln: 8.4 : 225 219 + in fire_ln: 8.5 : 225 219 + in fire_ln: 8.5.1 : 225 219 + in fire_ln: 8.5.2 : 225 219 + in fire_ln: 8.5.3 : 225 219 + in fire_ln: 8.5.4 : 225 219 + in fire_ln: 8.5.5 : 225 219 + in fire_ln: 8.5.5 : ncod( 225 218 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 225 219 1 ) = -0.2189903110 + in fire_ln: 8.5.5 : xcd( 224 219 3 ) = 0.2040299326 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 225 219 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 225 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 225 218 1 ) = 0.2795101106 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 225 219 3 ) = 0.2935212478E-01 + in fire_ln: 8.5.5 : ycd( 225 218 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 225 219 + in fire_ln: 8.6 : 225 219 + in fire_ln: 8.7 : 225 219 + in fire_ln: 8.8 : 225 219 + in fire_ln: 8.9 : 225 219 + in fire_ln: 8.10 : 225 219 + in fire_ln: 8.1 : 200 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 200 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 199 219 + in fire_ln: 8.2 : 200 220 + in fire_ln: 8.3 : 200 220 + in fire_ln: 8.3.1 : 199 219 + in fire_ln: 8.3.2 : 200 219 + in fire_ln: 8.4 : 200 220 + in fire_ln: 8.5 : 200 220 + in fire_ln: 8.5.1 : 200 220 + in fire_ln: 8.5.2 : 200 220 + in fire_ln: 8.5.3 : 200 220 + in fire_ln: 8.5.4 : 200 220 + in fire_ln: 8.5.5 : 200 220 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 200 219 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 200 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 200 219 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 200 220 1 ) = 0.2822859585 + in fire_ln: 8.5.5 : ycd( 200 219 3 ) = -0.3204802275 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3485675752 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 200 220 + in fire_ln: 8.6 : 200 220 + in fire_ln: 8.7 : 200 220 + in fire_ln: 8.8 : 200 220 + in fire_ln: 8.9 : 200 220 + in fire_ln: 8.10 : 200 220 + in fire_ln: 8.1 : 201 220 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 200 221 + in fire_ln: 8.2 : 201 220 + in fire_ln: 8.3 : 201 220 + in fire_ln: 8.3.1 : 200 221 + in fire_ln: 8.3.2 : 200 220 + in fire_ln: 8.4 : 201 220 + in fire_ln: 8.5 : 201 220 + in fire_ln: 8.5.1 : 201 220 + in fire_ln: 8.5.2 : 201 220 + in fire_ln: 8.5.3 : 201 220 + in fire_ln: 8.5.4 : 201 220 + in fire_ln: 8.5.5 : 201 220 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 200 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 220 1 ) = -0.3485675752 + in fire_ln: 8.5.5 : xcd( 200 220 3 ) = -0.3088542446E-01 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 201 220 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 200 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4753543735 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2822859585 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 220 + in fire_ln: 8.6 : 201 220 + in fire_ln: 8.7 : 201 220 + in fire_ln: 8.8 : 201 220 + in fire_ln: 8.9 : 201 220 + in fire_ln: 8.10 : 201 220 + in fire_ln: 8.1 : 224 220 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 224 220 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 223 221 + in fire_ln: 8.2 : 224 220 + in fire_ln: 8.3 : 224 220 + in fire_ln: 8.3.1 : 223 221 + in fire_ln: 8.3.2 : 224 221 + in fire_ln: 8.4 : 224 220 + in fire_ln: 8.5 : 224 220 + in fire_ln: 8.5.1 : 224 220 + in fire_ln: 8.5.2 : 224 220 + in fire_ln: 8.5.3 : 224 220 + in fire_ln: 8.5.4 : 224 220 + in fire_ln: 8.5.5 : 224 220 + in fire_ln: 8.5.5 : ncod( 224 219 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 224 221 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.2040299326 + in fire_ln: 8.5.5 : xcd( 224 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 221 3 ) = -0.4424141049 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 224 220 2 ) = -0.4553085566 + in fire_ln: 8.5.5 : xcd( 224 219 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 220 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 219 1 ) = 0.2935212478E-01 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 220 + in fire_ln: 8.6 : 224 220 + in fire_ln: 8.7 : 224 220 + in fire_ln: 8.8 : 224 220 + in fire_ln: 8.9 : 224 220 + in fire_ln: 8.10 : 224 220 + in fire_ln: 8.1 : 201 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 201 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 200 220 + in fire_ln: 8.2 : 201 221 + in fire_ln: 8.3 : 201 221 + in fire_ln: 8.3.1 : 200 220 + in fire_ln: 8.3.2 : 201 220 + in fire_ln: 8.4 : 201 221 + in fire_ln: 8.5 : 201 221 + in fire_ln: 8.5.1 : 201 221 + in fire_ln: 8.5.2 : 201 221 + in fire_ln: 8.5.3 : 201 221 + in fire_ln: 8.5.4 : 201 221 + in fire_ln: 8.5.5 : 201 221 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 220 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 201 221 1 ) = 0.4753543735 + in fire_ln: 8.5.5 : xcd( 201 220 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 220 3 ) = 0.2822859585 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3485675752 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4735048115 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 201 221 + in fire_ln: 8.6 : 201 221 + in fire_ln: 8.7 : 201 221 + in fire_ln: 8.8 : 201 221 + in fire_ln: 8.9 : 201 221 + in fire_ln: 8.10 : 201 221 + in fire_ln: 8.1 : 223 221 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 223 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 222 + in fire_ln: 8.2 : 223 221 + in fire_ln: 8.2.1 : 223 221 + in fire_ln: 8.3 : 223 221 + in fire_ln: 8.3.1 : 222 222 + in fire_ln: 8.3.2 : 223 222 + in fire_ln: 8.4 : 223 221 + in fire_ln: 8.4.1 : 223 221 + in fire_ln: 8.5 : 223 221 + in fire_ln: 8.5.1 : 223 221 + in fire_ln: 8.5.2 : 223 221 + in fire_ln: 8.5.3 : 223 221 + in fire_ln: 8.5.4 : 223 221 + in fire_ln: 8.5.5 : 223 221 + in fire_ln: 8.5.5 : ncod( 224 221 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.4424141049 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.2846871912 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.2927456498 + in fire_ln: 8.5.5 : xcd( 224 221 1 ) = -0.4553085566 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 224 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 223 221 + in fire_ln: 8.6 : 223 221 + in fire_ln: 8.7 : 223 221 + in fire_ln: 8.8 : 223 221 + in fire_ln: 8.9 : 223 221 + in fire_ln: 8.10 : 223 221 + in fire_ln: 8.1 : 224 221 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 224 221 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 223 220 + in fire_ln: 8.2 : 224 221 + in fire_ln: 8.3 : 224 221 + in fire_ln: 8.3.1 : 223 220 + in fire_ln: 8.3.2 : 223 221 + in fire_ln: 8.4 : 224 221 + in fire_ln: 8.5 : 224 221 + in fire_ln: 8.5.1 : 224 221 + in fire_ln: 8.5.2 : 224 221 + in fire_ln: 8.5.3 : 224 221 + in fire_ln: 8.5.4 : 224 221 + in fire_ln: 8.5.5 : 224 221 + in fire_ln: 8.5.5 : ncod( 224 220 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 224 221 1 ) = -0.4553085566 + in fire_ln: 8.5.5 : xcd( 223 221 2 ) = -0.2927456498 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 224 221 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 221 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 224 221 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 224 220 1 ) = 0.2040299326 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 224 221 3 ) = -0.4424141049 + in fire_ln: 8.5.5 : ycd( 224 220 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 224 221 + in fire_ln: 8.6 : 224 221 + in fire_ln: 8.7 : 224 221 + in fire_ln: 8.8 : 224 221 + in fire_ln: 8.9 : 224 221 + in fire_ln: 8.10 : 224 221 + in fire_ln: 8.1 : 201 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 201 222 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 221 + in fire_ln: 8.2 : 201 222 + in fire_ln: 8.3 : 201 222 + in fire_ln: 8.3.1 : 202 221 + in fire_ln: 8.3.2 : 201 221 + in fire_ln: 8.4 : 201 222 + in fire_ln: 8.5 : 201 222 + in fire_ln: 8.5.1 : 201 222 + in fire_ln: 8.5.2 : 201 222 + in fire_ln: 8.5.3 : 201 222 + in fire_ln: 8.5.4 : 201 222 + in fire_ln: 8.5.5 : 201 222 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 221 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 201 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 201 221 2 ) = -0.3485675752 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 201 222 1 ) = -0.4735048115 + in fire_ln: 8.5.5 : ycd( 201 221 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4753543735 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4735517204 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 201 222 + in fire_ln: 8.6 : 201 222 + in fire_ln: 8.7 : 201 222 + in fire_ln: 8.8 : 201 222 + in fire_ln: 8.9 : 201 222 + in fire_ln: 8.10 : 201 222 + in fire_ln: 8.1 : 202 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 201 221 + in fire_ln: 8.2 : 202 222 + in fire_ln: 8.3 : 202 222 + in fire_ln: 8.3.1 : 201 221 + in fire_ln: 8.3.2 : 201 222 + in fire_ln: 8.4 : 202 222 + in fire_ln: 8.5 : 202 222 + in fire_ln: 8.5.1 : 202 222 + in fire_ln: 8.5.2 : 202 222 + in fire_ln: 8.5.3 : 202 222 + in fire_ln: 8.5.4 : 202 222 + in fire_ln: 8.5.5 : 202 222 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 201 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 222 1 ) = 0.4735517204 + in fire_ln: 8.5.5 : xcd( 201 222 3 ) = 0.4753543735 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 202 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 201 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4735048115 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4753994346 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 202 222 + in fire_ln: 8.6 : 202 222 + in fire_ln: 8.7 : 202 222 + in fire_ln: 8.8 : 202 222 + in fire_ln: 8.9 : 202 222 + in fire_ln: 8.10 : 202 222 + in fire_ln: 8.1 : 222 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 223 + in fire_ln: 8.2 : 222 222 + in fire_ln: 8.3 : 222 222 + in fire_ln: 8.3.1 : 221 223 + in fire_ln: 8.3.2 : 222 223 + in fire_ln: 8.4 : 222 222 + in fire_ln: 8.5 : 222 222 + in fire_ln: 8.5.1 : 222 222 + in fire_ln: 8.5.2 : 222 222 + in fire_ln: 8.5.3 : 222 222 + in fire_ln: 8.5.4 : 222 222 + in fire_ln: 8.5.5 : 222 222 + in fire_ln: 8.5.5 : ncod( 223 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.2846871912 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3241734505 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3029773533 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.2927456498 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 222 222 + in fire_ln: 8.6 : 222 222 + in fire_ln: 8.7 : 222 222 + in fire_ln: 8.8 : 222 222 + in fire_ln: 8.9 : 222 222 + in fire_ln: 8.10 : 222 222 + in fire_ln: 8.1 : 223 222 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 223 222 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 222 221 + in fire_ln: 8.2 : 223 222 + in fire_ln: 8.3 : 223 222 + in fire_ln: 8.3.1 : 222 221 + in fire_ln: 8.3.2 : 222 222 + in fire_ln: 8.4 : 223 222 + in fire_ln: 8.5 : 223 222 + in fire_ln: 8.5.1 : 223 222 + in fire_ln: 8.5.2 : 223 222 + in fire_ln: 8.5.3 : 223 222 + in fire_ln: 8.5.4 : 223 222 + in fire_ln: 8.5.5 : 223 222 + in fire_ln: 8.5.5 : ncod( 223 221 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 223 222 1 ) = -0.2927456498 + in fire_ln: 8.5.5 : xcd( 222 222 3 ) = -0.3029773533 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 223 222 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 222 222 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 223 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 223 221 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 223 222 3 ) = -0.2846871912 + in fire_ln: 8.5.5 : ycd( 223 221 1 ) = -0.4424141049 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 223 222 + in fire_ln: 8.6 : 223 222 + in fire_ln: 8.7 : 223 222 + in fire_ln: 8.8 : 223 222 + in fire_ln: 8.9 : 223 222 + in fire_ln: 8.10 : 223 222 + in fire_ln: 8.1 : 202 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 202 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 222 + in fire_ln: 8.2 : 202 223 + in fire_ln: 8.3 : 202 223 + in fire_ln: 8.3.1 : 203 222 + in fire_ln: 8.3.2 : 202 222 + in fire_ln: 8.4 : 202 223 + in fire_ln: 8.5 : 202 223 + in fire_ln: 8.5.1 : 202 223 + in fire_ln: 8.5.2 : 202 223 + in fire_ln: 8.5.3 : 202 223 + in fire_ln: 8.5.4 : 202 223 + in fire_ln: 8.5.5 : 202 223 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 202 222 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 202 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 222 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 202 223 1 ) = -0.4753994346 + in fire_ln: 8.5.5 : ycd( 202 222 3 ) = -0.4735048115 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4735517204 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3485690057 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 202 223 + in fire_ln: 8.6 : 202 223 + in fire_ln: 8.7 : 202 223 + in fire_ln: 8.8 : 202 223 + in fire_ln: 8.9 : 202 223 + in fire_ln: 8.10 : 202 223 + in fire_ln: 8.1 : 203 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 203 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 202 222 + in fire_ln: 8.2 : 203 223 + in fire_ln: 8.3 : 203 223 + in fire_ln: 8.3.1 : 202 222 + in fire_ln: 8.3.2 : 202 223 + in fire_ln: 8.4 : 203 223 + in fire_ln: 8.5 : 203 223 + in fire_ln: 8.5.1 : 203 223 + in fire_ln: 8.5.2 : 203 223 + in fire_ln: 8.5.3 : 203 223 + in fire_ln: 8.5.4 : 203 223 + in fire_ln: 8.5.5 : 203 223 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 202 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 203 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 202 223 3 ) = 0.4735517204 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 203 223 1 ) = 0.3485690057 + in fire_ln: 8.5.5 : ycd( 202 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2822859287 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4753994346 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 203 223 + in fire_ln: 8.6 : 203 223 + in fire_ln: 8.7 : 203 223 + in fire_ln: 8.8 : 203 223 + in fire_ln: 8.9 : 203 223 + in fire_ln: 8.10 : 203 223 + in fire_ln: 8.1 : 204 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 203 224 + in fire_ln: 8.2 : 204 223 + in fire_ln: 8.3 : 204 223 + in fire_ln: 8.3.1 : 203 224 + in fire_ln: 8.3.2 : 203 223 + in fire_ln: 8.4 : 204 223 + in fire_ln: 8.5 : 204 223 + in fire_ln: 8.5.1 : 204 223 + in fire_ln: 8.5.2 : 204 223 + in fire_ln: 8.5.3 : 204 223 + in fire_ln: 8.5.4 : 204 223 + in fire_ln: 8.5.5 : 204 223 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 203 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 204 223 1 ) = -0.2822859287 + in fire_ln: 8.5.5 : xcd( 203 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 204 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 203 223 2 ) = -0.4753994346 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3485690057 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.3088542446E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 223 + in fire_ln: 8.6 : 204 223 + in fire_ln: 8.7 : 204 223 + in fire_ln: 8.8 : 204 223 + in fire_ln: 8.9 : 204 223 + in fire_ln: 8.10 : 204 223 + in fire_ln: 8.1 : 220 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 223 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 224 + in fire_ln: 8.2 : 220 223 + in fire_ln: 8.2.1 : 220 223 + in fire_ln: 8.3 : 220 223 + in fire_ln: 8.3.1 : 221 224 + in fire_ln: 8.3.2 : 220 224 + in fire_ln: 8.4 : 220 223 + in fire_ln: 8.4.1 : 220 223 + in fire_ln: 8.5 : 220 223 + in fire_ln: 8.5.1 : 220 223 + in fire_ln: 8.5.2 : 220 223 + in fire_ln: 8.5.3 : 220 223 + in fire_ln: 8.5.4 : 220 223 + in fire_ln: 8.5.5 : 220 223 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4792720675 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.1130975932 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 220 223 2 ) = 0.4725688994 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 220 223 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3241734505 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 223 + in fire_ln: 8.6 : 220 223 + in fire_ln: 8.7 : 220 223 + in fire_ln: 8.8 : 220 223 + in fire_ln: 8.9 : 220 223 + in fire_ln: 8.10 : 220 223 + in fire_ln: 8.1 : 221 223 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 221 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 220 224 + in fire_ln: 8.2 : 221 223 + in fire_ln: 8.3 : 221 223 + in fire_ln: 8.3.1 : 220 224 + in fire_ln: 8.3.2 : 220 223 + in fire_ln: 8.4 : 221 223 + in fire_ln: 8.5 : 221 223 + in fire_ln: 8.5.1 : 221 223 + in fire_ln: 8.5.2 : 221 223 + in fire_ln: 8.5.3 : 221 223 + in fire_ln: 8.5.4 : 221 223 + in fire_ln: 8.5.5 : 221 223 + in fire_ln: 8.5.5 : ncod( 222 223 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 221 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 2 ) = 0.4725688994 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 221 223 1 ) = -0.3241734505 + in fire_ln: 8.5.5 : ycd( 220 223 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3029773533 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4792720675 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 223 + in fire_ln: 8.6 : 221 223 + in fire_ln: 8.7 : 221 223 + in fire_ln: 8.8 : 221 223 + in fire_ln: 8.9 : 221 223 + in fire_ln: 8.10 : 221 223 + in fire_ln: 8.1 : 222 223 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 222 223 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 221 222 + in fire_ln: 8.2 : 222 223 + in fire_ln: 8.3 : 222 223 + in fire_ln: 8.3.1 : 221 222 + in fire_ln: 8.3.2 : 221 223 + in fire_ln: 8.4 : 222 223 + in fire_ln: 8.5 : 222 223 + in fire_ln: 8.5.1 : 222 223 + in fire_ln: 8.5.2 : 222 223 + in fire_ln: 8.5.3 : 222 223 + in fire_ln: 8.5.4 : 222 223 + in fire_ln: 8.5.5 : 222 223 + in fire_ln: 8.5.5 : ncod( 222 222 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 223 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 222 223 1 ) = -0.3029773533 + in fire_ln: 8.5.5 : xcd( 221 223 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 222 223 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 221 223 2 ) = 0.4792720675 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 222 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 222 222 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 222 223 3 ) = -0.3241734505 + in fire_ln: 8.5.5 : ycd( 222 222 1 ) = -0.2846871912 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 222 223 + in fire_ln: 8.6 : 222 223 + in fire_ln: 8.7 : 222 223 + in fire_ln: 8.8 : 222 223 + in fire_ln: 8.9 : 222 223 + in fire_ln: 8.10 : 222 223 + in fire_ln: 8.1 : 204 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 203 223 + in fire_ln: 8.2 : 204 224 + in fire_ln: 8.3 : 204 224 + in fire_ln: 8.3.1 : 203 223 + in fire_ln: 8.3.2 : 204 223 + in fire_ln: 8.4 : 204 224 + in fire_ln: 8.5 : 204 224 + in fire_ln: 8.5.1 : 204 224 + in fire_ln: 8.5.2 : 204 224 + in fire_ln: 8.5.3 : 204 224 + in fire_ln: 8.5.4 : 204 224 + in fire_ln: 8.5.5 : 204 224 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 223 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 223 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 204 224 1 ) = 0.3088542446E-01 + in fire_ln: 8.5.5 : ycd( 204 223 3 ) = 0.3485690057 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2822859287 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3204801083 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 204 224 + in fire_ln: 8.6 : 204 224 + in fire_ln: 8.7 : 204 224 + in fire_ln: 8.8 : 204 224 + in fire_ln: 8.9 : 204 224 + in fire_ln: 8.10 : 204 224 + in fire_ln: 8.1 : 205 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 204 225 + in fire_ln: 8.2 : 205 224 + in fire_ln: 8.3 : 205 224 + in fire_ln: 8.3.1 : 204 225 + in fire_ln: 8.3.2 : 204 224 + in fire_ln: 8.4 : 205 224 + in fire_ln: 8.5 : 205 224 + in fire_ln: 8.5.1 : 205 224 + in fire_ln: 8.5.2 : 205 224 + in fire_ln: 8.5.3 : 205 224 + in fire_ln: 8.5.4 : 205 224 + in fire_ln: 8.5.5 : 205 224 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 204 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 224 1 ) = 0.3204801083 + in fire_ln: 8.5.5 : xcd( 204 224 3 ) = -0.2822859287 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 205 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.3088542446E-01 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.3984570503 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 224 + in fire_ln: 8.6 : 205 224 + in fire_ln: 8.7 : 205 224 + in fire_ln: 8.8 : 205 224 + in fire_ln: 8.9 : 205 224 + in fire_ln: 8.10 : 205 224 + in fire_ln: 8.1 : 219 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 225 + in fire_ln: 8.2 : 219 224 + in fire_ln: 8.3 : 219 224 + in fire_ln: 8.3.1 : 218 225 + in fire_ln: 8.3.2 : 219 225 + in fire_ln: 8.4 : 219 224 + in fire_ln: 8.5 : 219 224 + in fire_ln: 8.5.1 : 219 224 + in fire_ln: 8.5.2 : 219 224 + in fire_ln: 8.5.3 : 219 224 + in fire_ln: 8.5.4 : 219 224 + in fire_ln: 8.5.5 : 219 224 + in fire_ln: 8.5.5 : ncod( 220 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.1130975932 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3326199055 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.1670755893 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4725688994 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 224 + in fire_ln: 8.6 : 219 224 + in fire_ln: 8.7 : 219 224 + in fire_ln: 8.8 : 219 224 + in fire_ln: 8.9 : 219 224 + in fire_ln: 8.10 : 219 224 + in fire_ln: 8.1 : 220 224 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 220 224 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 225 + in fire_ln: 8.2 : 220 224 + in fire_ln: 8.3 : 220 224 + in fire_ln: 8.3.1 : 219 225 + in fire_ln: 8.3.2 : 219 224 + in fire_ln: 8.4 : 220 224 + in fire_ln: 8.5 : 220 224 + in fire_ln: 8.5.1 : 220 224 + in fire_ln: 8.5.2 : 220 224 + in fire_ln: 8.5.3 : 220 224 + in fire_ln: 8.5.4 : 220 224 + in fire_ln: 8.5.5 : 220 224 + in fire_ln: 8.5.5 : ncod( 220 223 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 224 1 ) = 0.4725688994 + in fire_ln: 8.5.5 : xcd( 219 224 3 ) = -0.1670755893 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 220 224 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 219 224 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 220 223 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 220 224 3 ) = 0.1130975932 + in fire_ln: 8.5.5 : ycd( 220 223 1 ) = 0.4792720675 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 220 224 + in fire_ln: 8.6 : 220 224 + in fire_ln: 8.7 : 220 224 + in fire_ln: 8.8 : 220 224 + in fire_ln: 8.9 : 220 224 + in fire_ln: 8.10 : 220 224 + in fire_ln: 8.1 : 205 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 224 + in fire_ln: 8.2 : 205 225 + in fire_ln: 8.3 : 205 225 + in fire_ln: 8.3.1 : 206 224 + in fire_ln: 8.3.2 : 205 224 + in fire_ln: 8.4 : 205 225 + in fire_ln: 8.5 : 205 225 + in fire_ln: 8.5.1 : 205 225 + in fire_ln: 8.5.2 : 205 225 + in fire_ln: 8.5.3 : 205 225 + in fire_ln: 8.5.4 : 205 225 + in fire_ln: 8.5.5 : 205 225 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 224 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 224 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 225 1 ) = -0.3984570503 + in fire_ln: 8.5.5 : ycd( 205 224 3 ) = 0.3088542446E-01 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3204801083 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6866011024E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 225 + in fire_ln: 8.6 : 205 225 + in fire_ln: 8.7 : 205 225 + in fire_ln: 8.8 : 205 225 + in fire_ln: 8.9 : 205 225 + in fire_ln: 8.10 : 205 225 + in fire_ln: 8.1 : 206 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 224 + in fire_ln: 8.2 : 206 225 + in fire_ln: 8.3 : 206 225 + in fire_ln: 8.3.1 : 205 224 + in fire_ln: 8.3.2 : 205 225 + in fire_ln: 8.4 : 206 225 + in fire_ln: 8.5 : 206 225 + in fire_ln: 8.5.1 : 206 225 + in fire_ln: 8.5.2 : 206 225 + in fire_ln: 8.5.3 : 206 225 + in fire_ln: 8.5.4 : 206 225 + in fire_ln: 8.5.5 : 206 225 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 205 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 206 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 225 3 ) = 0.3204801083 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 206 225 1 ) = 0.6866011024E-01 + in fire_ln: 8.5.5 : ycd( 205 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.3984570503 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4472185671 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 225 + in fire_ln: 8.6 : 206 225 + in fire_ln: 8.7 : 206 225 + in fire_ln: 8.8 : 206 225 + in fire_ln: 8.9 : 206 225 + in fire_ln: 8.10 : 206 225 + in fire_ln: 8.1 : 207 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 226 + in fire_ln: 8.2 : 207 225 + in fire_ln: 8.3 : 207 225 + in fire_ln: 8.3.1 : 206 226 + in fire_ln: 8.3.2 : 206 225 + in fire_ln: 8.4 : 207 225 + in fire_ln: 8.5 : 207 225 + in fire_ln: 8.5.1 : 207 225 + in fire_ln: 8.5.2 : 207 225 + in fire_ln: 8.5.3 : 207 225 + in fire_ln: 8.5.4 : 207 225 + in fire_ln: 8.5.5 : 207 225 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 207 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 207 225 1 ) = 0.4472185671 + in fire_ln: 8.5.5 : ycd( 206 225 2 ) = -0.3984570503 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6866011024E-01 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 225 + in fire_ln: 8.6 : 207 225 + in fire_ln: 8.7 : 207 225 + in fire_ln: 8.8 : 207 225 + in fire_ln: 8.9 : 207 225 + in fire_ln: 8.10 : 207 225 + in fire_ln: 8.1 : 208 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 207 226 + in fire_ln: 8.2 : 208 225 + in fire_ln: 8.3 : 208 225 + in fire_ln: 8.3.1 : 207 226 + in fire_ln: 8.3.2 : 207 225 + in fire_ln: 8.4 : 208 225 + in fire_ln: 8.5 : 208 225 + in fire_ln: 8.5.1 : 208 225 + in fire_ln: 8.5.2 : 208 225 + in fire_ln: 8.5.3 : 208 225 + in fire_ln: 8.5.4 : 208 225 + in fire_ln: 8.5.5 : 208 225 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 225 1 ) = -0.3211852908 + in fire_ln: 8.5.5 : xcd( 207 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 208 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 225 2 ) = 0.6866011024E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4472185671 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2591497898 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 225 + in fire_ln: 8.6 : 208 225 + in fire_ln: 8.7 : 208 225 + in fire_ln: 8.8 : 208 225 + in fire_ln: 8.9 : 208 225 + in fire_ln: 8.10 : 208 225 + in fire_ln: 8.1 : 216 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 225 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 216 225 + in fire_ln: 8.2.1 : 216 225 + in fire_ln: 8.3 : 216 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 216 226 + in fire_ln: 8.4 : 216 225 + in fire_ln: 8.4.1 : 216 225 + in fire_ln: 8.5 : 216 225 + in fire_ln: 8.5.1 : 216 225 + in fire_ln: 8.5.2 : 216 225 + in fire_ln: 8.5.3 : 216 225 + in fire_ln: 8.5.4 : 216 225 + in fire_ln: 8.5.5 : 216 225 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4894327223 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2241357863 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.4529993236 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1352872550 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 225 + in fire_ln: 8.6 : 216 225 + in fire_ln: 8.7 : 216 225 + in fire_ln: 8.8 : 216 225 + in fire_ln: 8.9 : 216 225 + in fire_ln: 8.10 : 216 225 + in fire_ln: 8.1 : 217 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 226 + in fire_ln: 8.2 : 217 225 + in fire_ln: 8.3 : 217 225 + in fire_ln: 8.3.1 : 216 226 + in fire_ln: 8.3.2 : 216 225 + in fire_ln: 8.4 : 217 225 + in fire_ln: 8.5 : 217 225 + in fire_ln: 8.5.1 : 217 225 + in fire_ln: 8.5.2 : 217 225 + in fire_ln: 8.5.3 : 217 225 + in fire_ln: 8.5.4 : 217 225 + in fire_ln: 8.5.5 : 217 225 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 2 ) = 0.4529993236 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 217 225 1 ) = 0.1352872550 + in fire_ln: 8.5.5 : ycd( 216 225 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4894327223 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3326199055 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 225 + in fire_ln: 8.6 : 217 225 + in fire_ln: 8.7 : 217 225 + in fire_ln: 8.8 : 217 225 + in fire_ln: 8.9 : 217 225 + in fire_ln: 8.10 : 217 225 + in fire_ln: 8.1 : 218 225 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 226 + in fire_ln: 8.2 : 218 225 + in fire_ln: 8.3 : 218 225 + in fire_ln: 8.3.1 : 217 226 + in fire_ln: 8.3.2 : 217 225 + in fire_ln: 8.4 : 218 225 + in fire_ln: 8.5 : 218 225 + in fire_ln: 8.5.1 : 218 225 + in fire_ln: 8.5.2 : 218 225 + in fire_ln: 8.5.3 : 218 225 + in fire_ln: 8.5.4 : 218 225 + in fire_ln: 8.5.5 : 218 225 + in fire_ln: 8.5.5 : ncod( 219 225 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 218 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 218 225 1 ) = -0.3326199055 + in fire_ln: 8.5.5 : ycd( 217 225 2 ) = 0.4894327223 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.1670755893 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1352872550 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 225 + in fire_ln: 8.6 : 218 225 + in fire_ln: 8.7 : 218 225 + in fire_ln: 8.8 : 218 225 + in fire_ln: 8.9 : 218 225 + in fire_ln: 8.10 : 218 225 + in fire_ln: 8.1 : 219 225 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 225 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 224 + in fire_ln: 8.2 : 219 225 + in fire_ln: 8.3 : 219 225 + in fire_ln: 8.3.1 : 218 224 + in fire_ln: 8.3.2 : 218 225 + in fire_ln: 8.4 : 219 225 + in fire_ln: 8.5 : 219 225 + in fire_ln: 8.5.1 : 219 225 + in fire_ln: 8.5.2 : 219 225 + in fire_ln: 8.5.3 : 219 225 + in fire_ln: 8.5.4 : 219 225 + in fire_ln: 8.5.5 : 219 225 + in fire_ln: 8.5.5 : ncod( 219 224 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 218 225 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 225 1 ) = -0.1670755893 + in fire_ln: 8.5.5 : xcd( 218 225 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 219 225 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 225 2 ) = 0.1352872550 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 224 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 225 3 ) = -0.3326199055 + in fire_ln: 8.5.5 : ycd( 219 224 1 ) = 0.1130975932 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 225 + in fire_ln: 8.6 : 219 225 + in fire_ln: 8.7 : 219 225 + in fire_ln: 8.8 : 219 225 + in fire_ln: 8.9 : 219 225 + in fire_ln: 8.10 : 219 225 + in fire_ln: 8.1 : 208 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 225 + in fire_ln: 8.2 : 208 226 + in fire_ln: 8.3 : 208 226 + in fire_ln: 8.3.1 : 207 225 + in fire_ln: 8.3.2 : 208 225 + in fire_ln: 8.4 : 208 226 + in fire_ln: 8.5 : 208 226 + in fire_ln: 8.5.1 : 208 226 + in fire_ln: 8.5.2 : 208 226 + in fire_ln: 8.5.3 : 208 226 + in fire_ln: 8.5.4 : 208 226 + in fire_ln: 8.5.5 : 208 226 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 225 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 225 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 226 1 ) = -0.2591497898 + in fire_ln: 8.5.5 : ycd( 208 225 3 ) = 0.4472185671 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4221726954E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 226 + in fire_ln: 8.6 : 208 226 + in fire_ln: 8.7 : 208 226 + in fire_ln: 8.8 : 208 226 + in fire_ln: 8.9 : 208 226 + in fire_ln: 8.10 : 208 226 + in fire_ln: 8.1 : 209 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 225 + in fire_ln: 8.2 : 209 226 + in fire_ln: 8.3 : 209 226 + in fire_ln: 8.3.1 : 208 225 + in fire_ln: 8.3.2 : 208 226 + in fire_ln: 8.4 : 209 226 + in fire_ln: 8.5 : 209 226 + in fire_ln: 8.5.1 : 209 226 + in fire_ln: 8.5.2 : 209 226 + in fire_ln: 8.5.3 : 209 226 + in fire_ln: 8.5.4 : 209 226 + in fire_ln: 8.5.5 : 209 226 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 226 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 209 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 226 3 ) = -0.3211852908 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 209 226 1 ) = -0.4221726954E-01 + in fire_ln: 8.5.5 : ycd( 208 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2591497898 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.1005131900 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 226 + in fire_ln: 8.6 : 209 226 + in fire_ln: 8.7 : 209 226 + in fire_ln: 8.8 : 209 226 + in fire_ln: 8.9 : 209 226 + in fire_ln: 8.10 : 209 226 + in fire_ln: 8.1 : 210 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 209 225 + in fire_ln: 8.2 : 210 226 + in fire_ln: 8.3 : 210 226 + in fire_ln: 8.3.1 : 209 225 + in fire_ln: 8.3.2 : 209 226 + in fire_ln: 8.4 : 210 226 + in fire_ln: 8.5 : 210 226 + in fire_ln: 8.5.1 : 210 226 + in fire_ln: 8.5.2 : 210 226 + in fire_ln: 8.5.3 : 210 226 + in fire_ln: 8.5.4 : 210 226 + in fire_ln: 8.5.5 : 210 226 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 209 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 210 226 1 ) = 0.1005131900 + in fire_ln: 8.5.5 : ycd( 209 226 2 ) = -0.2591497898 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4221726954E-01 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1713424474 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 226 + in fire_ln: 8.6 : 210 226 + in fire_ln: 8.7 : 210 226 + in fire_ln: 8.8 : 210 226 + in fire_ln: 8.9 : 210 226 + in fire_ln: 8.10 : 210 226 + in fire_ln: 8.1 : 211 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 227 + in fire_ln: 8.2 : 211 226 + in fire_ln: 8.3 : 211 226 + in fire_ln: 8.3.1 : 210 227 + in fire_ln: 8.3.2 : 210 226 + in fire_ln: 8.4 : 211 226 + in fire_ln: 8.5 : 211 226 + in fire_ln: 8.5.1 : 211 226 + in fire_ln: 8.5.2 : 211 226 + in fire_ln: 8.5.3 : 211 226 + in fire_ln: 8.5.4 : 211 226 + in fire_ln: 8.5.5 : 211 226 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 210 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 211 226 1 ) = 0.1713424474 + in fire_ln: 8.5.5 : ycd( 210 226 2 ) = -0.4221726954E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.1005131900 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1737653911 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 226 + in fire_ln: 8.6 : 211 226 + in fire_ln: 8.7 : 211 226 + in fire_ln: 8.8 : 211 226 + in fire_ln: 8.9 : 211 226 + in fire_ln: 8.10 : 211 226 + in fire_ln: 8.1 : 212 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 211 227 + in fire_ln: 8.2 : 212 226 + in fire_ln: 8.3 : 212 226 + in fire_ln: 8.3.1 : 211 227 + in fire_ln: 8.3.2 : 211 226 + in fire_ln: 8.4 : 212 226 + in fire_ln: 8.5 : 212 226 + in fire_ln: 8.5.1 : 212 226 + in fire_ln: 8.5.2 : 212 226 + in fire_ln: 8.5.3 : 212 226 + in fire_ln: 8.5.4 : 212 226 + in fire_ln: 8.5.5 : 212 226 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 212 226 1 ) = 0.1737653911 + in fire_ln: 8.5.5 : ycd( 211 226 2 ) = 0.1005131900 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1713424474 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1113149151 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 226 + in fire_ln: 8.6 : 212 226 + in fire_ln: 8.7 : 212 226 + in fire_ln: 8.8 : 212 226 + in fire_ln: 8.9 : 212 226 + in fire_ln: 8.10 : 212 226 + in fire_ln: 8.1 : 213 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 212 227 + in fire_ln: 8.2 : 213 226 + in fire_ln: 8.3 : 213 226 + in fire_ln: 8.3.1 : 212 227 + in fire_ln: 8.3.2 : 212 226 + in fire_ln: 8.4 : 213 226 + in fire_ln: 8.5 : 213 226 + in fire_ln: 8.5.1 : 213 226 + in fire_ln: 8.5.2 : 213 226 + in fire_ln: 8.5.3 : 213 226 + in fire_ln: 8.5.4 : 213 226 + in fire_ln: 8.5.5 : 213 226 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 213 226 1 ) = 0.1113149151 + in fire_ln: 8.5.5 : ycd( 212 226 2 ) = 0.1713424474 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1737653911 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.2056580782E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 226 + in fire_ln: 8.6 : 213 226 + in fire_ln: 8.7 : 213 226 + in fire_ln: 8.8 : 213 226 + in fire_ln: 8.9 : 213 226 + in fire_ln: 8.10 : 213 226 + in fire_ln: 8.1 : 214 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 213 227 + in fire_ln: 8.2 : 214 226 + in fire_ln: 8.3 : 214 226 + in fire_ln: 8.3.1 : 213 227 + in fire_ln: 8.3.2 : 213 226 + in fire_ln: 8.4 : 214 226 + in fire_ln: 8.5 : 214 226 + in fire_ln: 8.5.1 : 214 226 + in fire_ln: 8.5.2 : 214 226 + in fire_ln: 8.5.3 : 214 226 + in fire_ln: 8.5.4 : 214 226 + in fire_ln: 8.5.5 : 214 226 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 214 226 1 ) = -0.2056580782E-01 + in fire_ln: 8.5.5 : ycd( 213 226 2 ) = 0.1737653911 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1113149151 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2241357863 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 226 + in fire_ln: 8.6 : 214 226 + in fire_ln: 8.7 : 214 226 + in fire_ln: 8.8 : 214 226 + in fire_ln: 8.9 : 214 226 + in fire_ln: 8.10 : 214 226 + in fire_ln: 8.1 : 215 226 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 225 + in fire_ln: 8.2 : 215 226 + in fire_ln: 8.3 : 215 226 + in fire_ln: 8.3.1 : 214 225 + in fire_ln: 8.3.2 : 214 226 + in fire_ln: 8.4 : 215 226 + in fire_ln: 8.5 : 215 226 + in fire_ln: 8.5.1 : 215 226 + in fire_ln: 8.5.2 : 215 226 + in fire_ln: 8.5.3 : 215 226 + in fire_ln: 8.5.4 : 215 226 + in fire_ln: 8.5.5 : 215 226 + in fire_ln: 8.5.5 : ncod( 216 226 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 214 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 215 226 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 215 226 1 ) = -0.2241357863 + in fire_ln: 8.5.5 : ycd( 214 226 2 ) = 0.1113149151 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.4529993236 + in fire_ln: 8.5.5 : i1-i = 1 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.2056580782E-01 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 226 + in fire_ln: 8.6 : 215 226 + in fire_ln: 8.7 : 215 226 + in fire_ln: 8.8 : 215 226 + in fire_ln: 8.9 : 215 226 + in fire_ln: 8.10 : 215 226 + in fire_ln: 8.1 : 216 226 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 226 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 215 225 + in fire_ln: 8.2 : 216 226 + in fire_ln: 8.3 : 216 226 + in fire_ln: 8.3.1 : 215 225 + in fire_ln: 8.3.2 : 215 226 + in fire_ln: 8.4 : 216 226 + in fire_ln: 8.5 : 216 226 + in fire_ln: 8.5.1 : 216 226 + in fire_ln: 8.5.2 : 216 226 + in fire_ln: 8.5.3 : 216 226 + in fire_ln: 8.5.4 : 216 226 + in fire_ln: 8.5.5 : 216 226 + in fire_ln: 8.5.5 : ncod( 216 225 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 226 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 226 1 ) = 0.4529993236 + in fire_ln: 8.5.5 : xcd( 215 226 2 ) = -0.5000000000 + in fire_ln: 8.5.5 : i2-i = -1 + in fire_ln: 8.5.5 : ycd( 216 226 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 226 2 ) = -0.2056580782E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 226 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 225 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 226 3 ) = -0.2241357863 + in fire_ln: 8.5.5 : ycd( 216 225 1 ) = 0.4894327223 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 226 + in fire_ln: 8.6 : 216 226 + in fire_ln: 8.7 : 216 226 + in fire_ln: 8.8 : 216 226 + in fire_ln: 8.9 : 216 226 + in fire_ln: 8.10 : 216 226 + in fire_ln: 9 + in fire_ln: 10 + RADMAX MIN AVG SUM 301.3835144 4.642822266 30.28023720 112.0000000 + in fire_ln: 11 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 198 0.223E-01 0.403E+01 0.913E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.223E-01 0.403E+01 0.913E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 198 0.291E-01 0.403E+01 0.422E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.291E-01 0.403E+01 0.422E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 198 0.379E-01 0.403E+01 0.852E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.379E-01 0.403E+01 0.852E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 198 0.489E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.489E-01 0.403E+01 0.139E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.551E-01 0.403E+01 0.169E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 198 0.462E-01 0.403E+01 0.125E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 199 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.462E-01 0.403E+01 0.125E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 199 0.465E-01 0.403E+01 0.127E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.465E-01 0.403E+01 0.127E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 199 0.722E-01 0.403E+01 0.253E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.722E-01 0.403E+01 0.253E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 199 0.841E-01 0.403E+01 0.311E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.841E-01 0.403E+01 0.311E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.853E-01 0.403E+01 0.316E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 199 0.886E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 200 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.886E-01 0.403E+01 0.333E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.954E-01 0.403E+01 0.366E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 200 0.979E-01 0.403E+01 0.378E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.979E-01 0.403E+01 0.378E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.102E+00 0.403E+01 0.396E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 200 0.115E+00 0.403E+01 0.461E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 201 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.115E+00 0.403E+01 0.461E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 201 0.115E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.115E+00 0.403E+01 0.464E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 201 0.128E+00 0.403E+01 0.523E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.128E+00 0.403E+01 0.523E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.129E+00 0.403E+01 0.530E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 201 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 202 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.136E+00 0.403E+01 0.565E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 202 0.140E+00 0.403E+01 0.583E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.140E+00 0.403E+01 0.583E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.141E+00 0.403E+01 0.588E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 202 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 203 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.143E+00 0.403E+01 0.598E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 203 0.156E+00 0.403E+01 0.661E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.156E+00 0.403E+01 0.661E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.156E+00 0.403E+01 0.663E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 203 0.157E+00 0.403E+01 0.666E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 204 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.157E+00 0.403E+01 0.666E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 204 0.168E+00 0.403E+01 0.722E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 205 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.168E+00 0.403E+01 0.722E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.169E+00 0.403E+01 0.726E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 205 0.173E+00 0.403E+01 0.747E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.173E+00 0.403E+01 0.747E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.178E+00 0.403E+01 0.768E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 205 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 206 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 206 0.187E+00 0.403E+01 0.813E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 207 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.187E+00 0.403E+01 0.813E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 207 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.192E+00 0.403E+01 0.837E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 207 0.193E+00 0.403E+01 0.844E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 208 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.193E+00 0.403E+01 0.844E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 208 0.197E+00 0.403E+01 0.864E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 209 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.197E+00 0.403E+01 0.864E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 209 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 210 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 210 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 211 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 211 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 212 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 212 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 213 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.205E+00 0.403E+01 0.902E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 213 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 214 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.204E+00 0.403E+01 0.896E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 214 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 215 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.201E+00 0.403E+01 0.881E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 215 0.197E+00 0.403E+01 0.864E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 198 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 216 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.197E+00 0.403E+01 0.864E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 216 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 217 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 217 0.187E+00 0.403E+01 0.813E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.193E+00 0.403E+01 0.843E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.192E+00 0.403E+01 0.837E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 226 217 0.191E+00 0.403E+01 0.834E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 218 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.187E+00 0.403E+01 0.813E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 218 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 199 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 219 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.173E+00 0.403E+01 0.746E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.169E+00 0.403E+01 0.725E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 219 0.168E+00 0.403E+01 0.721E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.179E+00 0.403E+01 0.772E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.178E+00 0.403E+01 0.767E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 225 219 0.173E+00 0.403E+01 0.746E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 200 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 220 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.168E+00 0.403E+01 0.721E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 220 0.157E+00 0.403E+01 0.666E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 221 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.156E+00 0.403E+01 0.661E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 221 0.143E+00 0.403E+01 0.597E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.157E+00 0.403E+01 0.666E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.156E+00 0.403E+01 0.663E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 224 221 0.156E+00 0.403E+01 0.661E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 201 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 222 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.140E+00 0.403E+01 0.582E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.136E+00 0.403E+01 0.564E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 222 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.143E+00 0.403E+01 0.597E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.141E+00 0.403E+01 0.587E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 223 222 0.140E+00 0.403E+01 0.582E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 202 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 203 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 223 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.116E+00 0.403E+01 0.465E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 223 0.115E+00 0.403E+01 0.463E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.127E+00 0.403E+01 0.523E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 221 223 0.116E+00 0.403E+01 0.465E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.130E+00 0.403E+01 0.536E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.129E+00 0.403E+01 0.529E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 222 223 0.127E+00 0.403E+01 0.523E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 204 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 224 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.978E-01 0.403E+01 0.377E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.953E-01 0.403E+01 0.365E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 224 0.884E-01 0.403E+01 0.332E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.115E+00 0.403E+01 0.463E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.101E+00 0.403E+01 0.396E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 220 224 0.978E-01 0.403E+01 0.377E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 205 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 206 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 207 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 225 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.465E-01 0.403E+01 0.127E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 225 0.461E-01 0.403E+01 0.125E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.721E-01 0.403E+01 0.252E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 217 225 0.465E-01 0.403E+01 0.127E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.840E-01 0.403E+01 0.310E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 218 225 0.721E-01 0.403E+01 0.252E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.884E-01 0.403E+01 0.332E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.852E-01 0.403E+01 0.316E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 219 225 0.840E-01 0.403E+01 0.310E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 208 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 209 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 210 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 211 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.223E-01 0.403E+01 0.882E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 212 226 0.205E-01 0.403E+01 0.000E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.290E-01 0.403E+01 0.418E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 213 226 0.223E-01 0.403E+01 0.882E-01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.378E-01 0.403E+01 0.847E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 214 226 0.290E-01 0.403E+01 0.418E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.488E-01 0.403E+01 0.138E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 215 226 0.378E-01 0.403E+01 0.847E+00 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.461E-01 0.403E+01 0.125E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.549E-01 0.403E+01 0.168E+01 0.000E+00 + debug ZS1 ZS2 TANPHI= 0.0000000000E+00 0.0000000000E+00 0.0000000000E+00 + i,j,ros,r0,phiw,phis= 216 226 0.488E-01 0.403E+01 0.138E+01 0.000E+00 + MAX/MIN SPREAD RATE (m/s)= 0.20524 0.02048 + time (min)= 0.1500 AREA (acre)= 5.65148 + GRNDHX= 0.5705E+05 GRNDQX= 0.5236E+04 CANHX= 0.0000E+00 CANQX= 0.0000E+00 + TOTAL FIRE SENS-HEAT FLUXES GRNH/CANH = 0.1191E+10 0.0000E+00 WATTS +Timing for main: time 0001-01-01_00:00:09 on domain 1: 5.10000 elapsed seconds. + tignm = 2.000000000 + t_ignite = 0.3333333507E-01 + time = 10.00000000 + diff = -9.966666222 1.000000000 + in fire_ln: 1 + in fire_ln: 2 + in fire_ln: 3 + in fire_ln: 4 + in fire_ln: 5 + in fire_ln: 6 + in fire_ln: 7 + in fire_ln: 8 + in fire_ln: 8.1 : 208 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 209 199 + in fire_ln: 8.2 : 208 198 + in fire_ln: 8.3 : 208 198 + in fire_ln: 8.3.1 : 209 199 + in fire_ln: 8.3.2 : 209 198 + in fire_ln: 8.4 : 208 198 + in fire_ln: 8.5 : 208 198 + in fire_ln: 8.5.1 : 208 198 + in fire_ln: 8.5.2 : 208 198 + in fire_ln: 8.5.3 : 208 198 + in fire_ln: 8.5.4 : 208 198 + in fire_ln: 8.5.5 : 208 198 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3332975805 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.3874949738E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2556599379 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4508602619 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 208 198 + in fire_ln: 8.6 : 208 198 + in fire_ln: 8.7 : 208 198 + in fire_ln: 8.8 : 208 198 + in fire_ln: 8.9 : 208 198 + in fire_ln: 8.10 : 208 198 + in fire_ln: 8.1 : 209 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 209 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 210 199 + in fire_ln: 8.2 : 209 198 + in fire_ln: 8.3 : 209 198 + in fire_ln: 8.3.1 : 210 199 + in fire_ln: 8.3.2 : 210 198 + in fire_ln: 8.4 : 209 198 + in fire_ln: 8.5 : 209 198 + in fire_ln: 8.5.1 : 209 198 + in fire_ln: 8.5.2 : 209 198 + in fire_ln: 8.5.3 : 209 198 + in fire_ln: 8.5.4 : 209 198 + in fire_ln: 8.5.5 : 209 198 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2556599379 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.1039456874 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 209 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 1 ) = -0.3332975805 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 209 198 2 ) = 0.3874949738E-01 + in fire_ln: 8.5.5 : ycd( 208 198 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 209 198 + in fire_ln: 8.6 : 209 198 + in fire_ln: 8.7 : 209 198 + in fire_ln: 8.8 : 209 198 + in fire_ln: 8.9 : 209 198 + in fire_ln: 8.10 : 209 198 + in fire_ln: 8.1 : 210 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 210 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 211 197 + in fire_ln: 8.2 : 210 198 + in fire_ln: 8.3 : 210 198 + in fire_ln: 8.3.1 : 211 197 + in fire_ln: 8.3.2 : 211 198 + in fire_ln: 8.4 : 210 198 + in fire_ln: 8.5 : 210 198 + in fire_ln: 8.5.1 : 210 198 + in fire_ln: 8.5.2 : 210 198 + in fire_ln: 8.5.3 : 210 198 + in fire_ln: 8.5.4 : 210 198 + in fire_ln: 8.5.5 : 210 198 + in fire_ln: 8.5.5 : ncod( 209 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.3874949738E-01 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1747578681 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 210 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 209 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 210 198 2 ) = -0.1039456874 + in fire_ln: 8.5.5 : ycd( 209 198 1 ) = 0.2556599379 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 210 198 + in fire_ln: 8.6 : 210 198 + in fire_ln: 8.7 : 210 198 + in fire_ln: 8.8 : 210 198 + in fire_ln: 8.9 : 210 198 + in fire_ln: 8.10 : 210 198 + in fire_ln: 8.1 : 211 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 211 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 212 197 + in fire_ln: 8.2 : 211 198 + in fire_ln: 8.3 : 211 198 + in fire_ln: 8.3.1 : 212 197 + in fire_ln: 8.3.2 : 212 198 + in fire_ln: 8.4 : 211 198 + in fire_ln: 8.5 : 211 198 + in fire_ln: 8.5.1 : 211 198 + in fire_ln: 8.5.2 : 211 198 + in fire_ln: 8.5.3 : 211 198 + in fire_ln: 8.5.4 : 211 198 + in fire_ln: 8.5.5 : 211 198 + in fire_ln: 8.5.5 : ncod( 210 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.1039456874 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1775402725 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 211 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 210 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 211 198 2 ) = -0.1747578681 + in fire_ln: 8.5.5 : ycd( 210 198 1 ) = 0.3874949738E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 211 198 + in fire_ln: 8.6 : 211 198 + in fire_ln: 8.7 : 211 198 + in fire_ln: 8.8 : 211 198 + in fire_ln: 8.9 : 211 198 + in fire_ln: 8.10 : 211 198 + in fire_ln: 8.1 : 212 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 212 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 213 197 + in fire_ln: 8.2 : 212 198 + in fire_ln: 8.3 : 212 198 + in fire_ln: 8.3.1 : 213 197 + in fire_ln: 8.3.2 : 213 198 + in fire_ln: 8.4 : 212 198 + in fire_ln: 8.5 : 212 198 + in fire_ln: 8.5.1 : 212 198 + in fire_ln: 8.5.2 : 212 198 + in fire_ln: 8.5.3 : 212 198 + in fire_ln: 8.5.4 : 212 198 + in fire_ln: 8.5.5 : 212 198 + in fire_ln: 8.5.5 : ncod( 211 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1747578681 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1162608564 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 212 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 211 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 212 198 2 ) = -0.1775402725 + in fire_ln: 8.5.5 : ycd( 211 198 1 ) = -0.1039456874 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 212 198 + in fire_ln: 8.6 : 212 198 + in fire_ln: 8.7 : 212 198 + in fire_ln: 8.8 : 212 198 + in fire_ln: 8.9 : 212 198 + in fire_ln: 8.10 : 212 198 + in fire_ln: 8.1 : 213 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 213 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 214 197 + in fire_ln: 8.2 : 213 198 + in fire_ln: 8.3 : 213 198 + in fire_ln: 8.3.1 : 214 197 + in fire_ln: 8.3.2 : 214 198 + in fire_ln: 8.4 : 213 198 + in fire_ln: 8.5 : 213 198 + in fire_ln: 8.5.1 : 213 198 + in fire_ln: 8.5.2 : 213 198 + in fire_ln: 8.5.3 : 213 198 + in fire_ln: 8.5.4 : 213 198 + in fire_ln: 8.5.5 : 213 198 + in fire_ln: 8.5.5 : ncod( 212 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1775402725 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.1407435816E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 213 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 212 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 213 198 2 ) = -0.1162608564 + in fire_ln: 8.5.5 : ycd( 212 198 1 ) = -0.1747578681 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 213 198 + in fire_ln: 8.6 : 213 198 + in fire_ln: 8.7 : 213 198 + in fire_ln: 8.8 : 213 198 + in fire_ln: 8.9 : 213 198 + in fire_ln: 8.10 : 213 198 + in fire_ln: 8.1 : 214 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 214 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 215 199 + in fire_ln: 8.2 : 214 198 + in fire_ln: 8.3 : 214 198 + in fire_ln: 8.3.1 : 215 199 + in fire_ln: 8.3.2 : 215 198 + in fire_ln: 8.4 : 214 198 + in fire_ln: 8.5 : 214 198 + in fire_ln: 8.5.1 : 214 198 + in fire_ln: 8.5.2 : 214 198 + in fire_ln: 8.5.3 : 214 198 + in fire_ln: 8.5.4 : 214 198 + in fire_ln: 8.5.5 : 214 198 + in fire_ln: 8.5.5 : ncod( 213 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1162608564 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2157337070 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 214 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 213 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 214 198 2 ) = 0.1407435816E-01 + in fire_ln: 8.5.5 : ycd( 213 198 1 ) = -0.1775402725 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 214 198 + in fire_ln: 8.6 : 214 198 + in fire_ln: 8.7 : 214 198 + in fire_ln: 8.8 : 214 198 + in fire_ln: 8.9 : 214 198 + in fire_ln: 8.10 : 214 198 + in fire_ln: 8.1 : 215 198 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 215 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 216 199 + in fire_ln: 8.2 : 215 198 + in fire_ln: 8.3 : 215 198 + in fire_ln: 8.3.1 : 216 199 + in fire_ln: 8.3.2 : 216 198 + in fire_ln: 8.4 : 215 198 + in fire_ln: 8.5 : 215 198 + in fire_ln: 8.5.1 : 215 198 + in fire_ln: 8.5.2 : 215 198 + in fire_ln: 8.5.3 : 215 198 + in fire_ln: 8.5.4 : 215 198 + in fire_ln: 8.5.5 : 215 198 + in fire_ln: 8.5.5 : ncod( 214 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4885706902 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.1407435816E-01 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 215 198 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 214 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 215 198 2 ) = 0.2157337070 + in fire_ln: 8.5.5 : ycd( 214 198 1 ) = -0.1162608564 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 215 198 + in fire_ln: 8.6 : 215 198 + in fire_ln: 8.7 : 215 198 + in fire_ln: 8.8 : 215 198 + in fire_ln: 8.9 : 215 198 + in fire_ln: 8.10 : 215 198 + in fire_ln: 8.1 : 216 198 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 216 198 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 217 199 + in fire_ln: 8.2 : 216 198 + in fire_ln: 8.3 : 216 198 + in fire_ln: 8.3.1 : 217 199 + in fire_ln: 8.3.2 : 216 199 + in fire_ln: 8.4 : 216 198 + in fire_ln: 8.5 : 216 198 + in fire_ln: 8.5.1 : 216 198 + in fire_ln: 8.5.2 : 216 198 + in fire_ln: 8.5.3 : 216 198 + in fire_ln: 8.5.4 : 216 198 + in fire_ln: 8.5.5 : 216 198 + in fire_ln: 8.5.5 : ncod( 215 198 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2157337070 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4976701140 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 216 198 3 ) = 0.4885706902 + in fire_ln: 8.5.5 : xcd( 215 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 216 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 215 198 1 ) = 0.1407435816E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 216 198 + in fire_ln: 8.6 : 216 198 + in fire_ln: 8.7 : 216 198 + in fire_ln: 8.8 : 216 198 + in fire_ln: 8.9 : 216 198 + in fire_ln: 8.10 : 216 198 + in fire_ln: 8.1 : 205 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 206 200 + in fire_ln: 8.2 : 205 199 + in fire_ln: 8.3 : 205 199 + in fire_ln: 8.3.1 : 206 200 + in fire_ln: 8.3.2 : 206 199 + in fire_ln: 8.4 : 205 199 + in fire_ln: 8.5 : 205 199 + in fire_ln: 8.5.1 : 205 199 + in fire_ln: 8.5.2 : 205 199 + in fire_ln: 8.5.3 : 205 199 + in fire_ln: 8.5.4 : 205 199 + in fire_ln: 8.5.5 : 205 199 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3137702048 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.7236547023E-01 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.3946980536 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3482201323E-01 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 205 199 + in fire_ln: 8.6 : 205 199 + in fire_ln: 8.7 : 205 199 + in fire_ln: 8.8 : 205 199 + in fire_ln: 8.9 : 205 199 + in fire_ln: 8.10 : 205 199 + in fire_ln: 8.1 : 206 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 206 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 206 199 + in fire_ln: 8.3 : 206 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 207 199 + in fire_ln: 8.4 : 206 199 + in fire_ln: 8.5 : 206 199 + in fire_ln: 8.5.1 : 206 199 + in fire_ln: 8.5.2 : 206 199 + in fire_ln: 8.5.3 : 206 199 + in fire_ln: 8.5.4 : 206 199 + in fire_ln: 8.5.5 : 206 199 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.3946980536 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4508602619 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 206 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 1 ) = 0.3137702048 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 206 199 2 ) = -0.7236547023E-01 + in fire_ln: 8.5.5 : ycd( 205 199 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 206 199 + in fire_ln: 8.6 : 206 199 + in fire_ln: 8.7 : 206 199 + in fire_ln: 8.8 : 206 199 + in fire_ln: 8.9 : 206 199 + in fire_ln: 8.10 : 206 199 + in fire_ln: 8.1 : 207 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 207 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 208 198 + in fire_ln: 8.2 : 207 199 + in fire_ln: 8.3 : 207 199 + in fire_ln: 8.3.1 : 208 198 + in fire_ln: 8.3.2 : 208 199 + in fire_ln: 8.4 : 207 199 + in fire_ln: 8.5 : 207 199 + in fire_ln: 8.5.1 : 207 199 + in fire_ln: 8.5.2 : 207 199 + in fire_ln: 8.5.3 : 207 199 + in fire_ln: 8.5.4 : 207 199 + in fire_ln: 8.5.5 : 207 199 + in fire_ln: 8.5.5 : ncod( 206 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3332975805 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.7236547023E-01 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 207 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 206 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 207 199 2 ) = -0.4508602619 + in fire_ln: 8.5.5 : ycd( 206 199 1 ) = 0.3946980536 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 207 199 + in fire_ln: 8.6 : 207 199 + in fire_ln: 8.7 : 207 199 + in fire_ln: 8.8 : 207 199 + in fire_ln: 8.9 : 207 199 + in fire_ln: 8.10 : 207 199 + in fire_ln: 8.1 : 208 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 208 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = -1 -1 + in fire_ln: 8.1.8 : i2,j2 = 207 198 + in fire_ln: 8.2 : 208 199 + in fire_ln: 8.3 : 208 199 + in fire_ln: 8.3.1 : 207 198 + in fire_ln: 8.3.2 : 208 198 + in fire_ln: 8.4 : 208 199 + in fire_ln: 8.5 : 208 199 + in fire_ln: 8.5.1 : 208 199 + in fire_ln: 8.5.2 : 208 199 + in fire_ln: 8.5.3 : 208 199 + in fire_ln: 8.5.4 : 208 199 + in fire_ln: 8.5.5 : 208 199 + in fire_ln: 8.5.5 : ncod( 207 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 208 198 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 208 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 208 198 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 208 199 1 ) = -0.4508602619 + in fire_ln: 8.5.5 : ycd( 208 198 3 ) = 0.2556599379 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 208 199 3 ) = -0.3332975805 + in fire_ln: 8.5.5 : xcd( 207 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 208 199 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 207 199 1 ) = -0.7236547023E-01 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 208 199 + in fire_ln: 8.6 : 208 199 + in fire_ln: 8.7 : 208 199 + in fire_ln: 8.8 : 208 199 + in fire_ln: 8.9 : 208 199 + in fire_ln: 8.10 : 208 199 + in fire_ln: 8.1 : 216 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 1 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 216 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 217 198 + in fire_ln: 8.2 : 216 199 + in fire_ln: 8.2.1 : 216 199 + in fire_ln: 8.3 : 216 199 + in fire_ln: 8.3.1 : 217 198 + in fire_ln: 8.3.2 : 217 199 + in fire_ln: 8.4 : 216 199 + in fire_ln: 8.4.1 : 216 199 + in fire_ln: 8.5 : 216 199 + in fire_ln: 8.5.1 : 216 199 + in fire_ln: 8.5.2 : 216 199 + in fire_ln: 8.5.3 : 216 199 + in fire_ln: 8.5.4 : 216 199 + in fire_ln: 8.5.5 : 216 199 + in fire_ln: 8.5.5 : ncod( 216 198 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4885706902 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1483957171 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 216 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 198 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 216 199 2 ) = -0.4976701140 + in fire_ln: 8.5.5 : ycd( 216 198 1 ) = 0.2157337070 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 216 199 + in fire_ln: 8.6 : 216 199 + in fire_ln: 8.7 : 216 199 + in fire_ln: 8.8 : 216 199 + in fire_ln: 8.9 : 216 199 + in fire_ln: 8.10 : 216 199 + in fire_ln: 8.1 : 217 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 217 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 218 198 + in fire_ln: 8.2 : 217 199 + in fire_ln: 8.3 : 217 199 + in fire_ln: 8.3.1 : 218 198 + in fire_ln: 8.3.2 : 218 199 + in fire_ln: 8.4 : 217 199 + in fire_ln: 8.5 : 217 199 + in fire_ln: 8.5.1 : 217 199 + in fire_ln: 8.5.2 : 217 199 + in fire_ln: 8.5.3 : 217 199 + in fire_ln: 8.5.4 : 217 199 + in fire_ln: 8.5.5 : 217 199 + in fire_ln: 8.5.5 : ncod( 216 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4976701140 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3195918798 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 217 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 216 199 1 ) = 0.4885706902 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 217 199 2 ) = -0.1483957171 + in fire_ln: 8.5.5 : ycd( 216 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 217 199 + in fire_ln: 8.6 : 217 199 + in fire_ln: 8.7 : 217 199 + in fire_ln: 8.8 : 217 199 + in fire_ln: 8.9 : 217 199 + in fire_ln: 8.10 : 217 199 + in fire_ln: 8.1 : 218 199 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 218 199 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 219 200 + in fire_ln: 8.2 : 218 199 + in fire_ln: 8.3 : 218 199 + in fire_ln: 8.3.1 : 219 200 + in fire_ln: 8.3.2 : 219 199 + in fire_ln: 8.4 : 218 199 + in fire_ln: 8.5 : 218 199 + in fire_ln: 8.5.1 : 218 199 + in fire_ln: 8.5.2 : 218 199 + in fire_ln: 8.5.3 : 218 199 + in fire_ln: 8.5.4 : 218 199 + in fire_ln: 8.5.5 : 218 199 + in fire_ln: 8.5.5 : ncod( 217 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1368557066 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1483957171 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 218 199 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 217 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 218 199 2 ) = 0.3195918798 + in fire_ln: 8.5.5 : ycd( 217 199 1 ) = -0.4976701140 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 218 199 + in fire_ln: 8.6 : 218 199 + in fire_ln: 8.7 : 218 199 + in fire_ln: 8.8 : 218 199 + in fire_ln: 8.9 : 218 199 + in fire_ln: 8.10 : 218 199 + in fire_ln: 8.1 : 219 199 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 199 + in fire_ln: 8.1.6 : tlx = -1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = -1 1 + in fire_ln: 8.1.8 : i2,j2 = 218 200 + in fire_ln: 8.2 : 219 199 + in fire_ln: 8.3 : 219 199 + in fire_ln: 8.3.1 : 218 200 + in fire_ln: 8.3.2 : 219 200 + in fire_ln: 8.4 : 219 199 + in fire_ln: 8.5 : 219 199 + in fire_ln: 8.5.1 : 219 199 + in fire_ln: 8.5.2 : 219 199 + in fire_ln: 8.5.3 : 219 199 + in fire_ln: 8.5.4 : 219 199 + in fire_ln: 8.5.5 : 219 199 + in fire_ln: 8.5.5 : ncod( 218 199 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3195918798 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1324744970 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 219 199 3 ) = -0.1368557066 + in fire_ln: 8.5.5 : xcd( 218 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 219 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 218 199 1 ) = -0.1483957171 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 219 199 + in fire_ln: 8.6 : 219 199 + in fire_ln: 8.7 : 219 199 + in fire_ln: 8.8 : 219 199 + in fire_ln: 8.9 : 219 199 + in fire_ln: 8.10 : 219 199 + in fire_ln: 8.1 : 204 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 204 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 205 199 + in fire_ln: 8.2 : 204 200 + in fire_ln: 8.3 : 204 200 + in fire_ln: 8.3.1 : 205 199 + in fire_ln: 8.3.2 : 205 200 + in fire_ln: 8.4 : 204 200 + in fire_ln: 8.5 : 204 200 + in fire_ln: 8.5.1 : 204 200 + in fire_ln: 8.5.2 : 204 200 + in fire_ln: 8.5.3 : 204 200 + in fire_ln: 8.5.4 : 204 200 + in fire_ln: 8.5.5 : 204 200 + in fire_ln: 8.5.5 : ncod( 204 201 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2882603705 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3137702048 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 204 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 204 201 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 204 200 3 ) = -0.3482201323E-01 + in fire_ln: 8.5.5 : ycd( 204 201 1 ) = -0.3529797792 + in fire_ln: 8.5.5 : j1-j = 1 + in fire_ln: 8.5.6 : 204 200 + in fire_ln: 8.6 : 204 200 + in fire_ln: 8.7 : 204 200 + in fire_ln: 8.8 : 204 200 + in fire_ln: 8.9 : 204 200 + in fire_ln: 8.10 : 204 200 + in fire_ln: 8.1 : 205 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 205 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 206 199 + in fire_ln: 8.2 : 205 200 + in fire_ln: 8.3 : 205 200 + in fire_ln: 8.3.1 : 206 199 + in fire_ln: 8.3.2 : 205 199 + in fire_ln: 8.4 : 205 200 + in fire_ln: 8.5 : 205 200 + in fire_ln: 8.5.1 : 205 200 + in fire_ln: 8.5.2 : 205 200 + in fire_ln: 8.5.3 : 205 200 + in fire_ln: 8.5.4 : 205 200 + in fire_ln: 8.5.5 : 205 200 + in fire_ln: 8.5.5 : ncod( 204 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 205 199 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 205 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 205 199 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 205 200 1 ) = -0.3482201323E-01 + in fire_ln: 8.5.5 : ycd( 205 199 3 ) = 0.3946980536 + in fire_ln: 8.5.5 : j2-j = -1 + in fire_ln: 8.5.5 : xcd( 205 200 3 ) = 0.3137702048 + in fire_ln: 8.5.5 : xcd( 204 200 1 ) = -0.2882603705 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 205 200 3 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 204 200 1 ) = 0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 205 200 + in fire_ln: 8.6 : 205 200 + in fire_ln: 8.7 : 205 200 + in fire_ln: 8.8 : 205 200 + in fire_ln: 8.9 : 205 200 + in fire_ln: 8.10 : 205 200 + in fire_ln: 8.1 : 219 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 3 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 219 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 -1.000000000 + in fire_ln: 8.1.7 : int = 1 -1 + in fire_ln: 8.1.8 : i2,j2 = 220 199 + in fire_ln: 8.2 : 219 200 + in fire_ln: 8.3 : 219 200 + in fire_ln: 8.3.1 : 220 199 + in fire_ln: 8.3.2 : 220 200 + in fire_ln: 8.4 : 219 200 + in fire_ln: 8.5 : 219 200 + in fire_ln: 8.5.1 : 219 200 + in fire_ln: 8.5.2 : 219 200 + in fire_ln: 8.5.3 : 219 200 + in fire_ln: 8.5.4 : 219 200 + in fire_ln: 8.5.5 : 219 200 + in fire_ln: 8.5.5 : ncod( 219 199 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1368557066 + in fire_ln: 8.5.5 : xcd( 220 200 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 2 ) = 0.4976496100 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 219 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 199 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = 0 + in fire_ln: 8.5.5 : ycd( 219 200 3 ) = -0.1324744970 + in fire_ln: 8.5.5 : ycd( 219 199 1 ) = 0.3195918798 + in fire_ln: 8.5.5 : j1-j = -1 + in fire_ln: 8.5.6 : 219 200 + in fire_ln: 8.6 : 219 200 + in fire_ln: 8.7 : 219 200 + in fire_ln: 8.8 : 219 200 + in fire_ln: 8.9 : 219 200 + in fire_ln: 8.10 : 219 200 + in fire_ln: 8.1 : 220 200 + in fire_ln: 8.1.1 : nh0 = 2 + in fire_ln: 8.1.2 : nct = 2 + in fire_ln: 8.1.3 : icls = 2 + in fire_ln: 8.1.4 : itt = 2 + in fire_ln: 8.1.5 : i,j = 220 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 221 201 + in fire_ln: 8.2 : 220 200 + in fire_ln: 8.3 : 220 200 + in fire_ln: 8.3.1 : 221 201 + in fire_ln: 8.3.2 : 221 200 + in fire_ln: 8.4 : 220 200 + in fire_ln: 8.5 : 220 200 + in fire_ln: 8.5.1 : 220 200 + in fire_ln: 8.5.2 : 220 200 + in fire_ln: 8.5.3 : 220 200 + in fire_ln: 8.5.4 : 220 200 + in fire_ln: 8.5.5 : 220 200 + in fire_ln: 8.5.5 : ncod( 219 200 ) = 3 1 + in fire_ln: 8.5.5 : ncod( 221 200 ) = 3 1 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 200 3 ) = 1.503286362 + in fire_ln: 8.5.5 : i2-i = 1 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1324744970 + in fire_ln: 8.5.5 : ycd( 221 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : j2-j = 0 + in fire_ln: 8.5.5 : xcd( 220 200 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : xcd( 219 200 1 ) = -0.1368557066 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 220 200 2 ) = 0.4976496100 + in fire_ln: 8.5.5 : ycd( 219 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 220 200 + in fire_ln: 8.6 : 220 200 + in fire_ln: 8.7 : 220 200 + in fire_ln: 8.8 : 220 200 + in fire_ln: 8.9 : 220 200 + in fire_ln: 8.10 : 220 200 + in fire_ln: 8.1 : 221 200 + in fire_ln: 8.1.1 : nh0 = 3 + in fire_ln: 8.1.2 : nct = 1 + in fire_ln: 8.1.3 : icls = 4 + in fire_ln: 8.1.4 : itt = 3 + in fire_ln: 8.1.5 : i,j = 221 200 + in fire_ln: 8.1.6 : tlx = 1.000000000 1.000000000 + in fire_ln: 8.1.7 : int = 1 1 + in fire_ln: 8.1.8 : i2,j2 = 222 201 + in fire_ln: 8.2 : 221 200 + in fire_ln: 8.3 : 221 200 + in fire_ln: 8.3.1 : 222 201 + in fire_ln: 8.3.2 : 221 201 + in fire_ln: 8.4 : 221 200 + in fire_ln: 8.5 : 221 200 + in fire_ln: 8.5.1 : 221 200 + in fire_ln: 8.5.2 : 221 200 + in fire_ln: 8.5.3 : 221 200 + in fire_ln: 8.5.4 : 221 200 + in fire_ln: 8.5.5 : 221 200 + in fire_ln: 8.5.5 : ncod( 220 200 ) = 2 1 + in fire_ln: 8.5.5 : ncod( 221 201 ) = 2 1 + in fire_ln: 8.5.5 : xcd( 221 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : xcd( 221 201 2 ) = 0.5000000000 + in fire_ln: 8.5.5 : i2-i = 0 + in fire_ln: 8.5.5 : ycd( 221 200 1 ) = 0.4976496100 + in fire_ln: 8.5.5 : ycd( 221 201 2 ) = 0.2978127897 + in fire_ln: 8.5.5 : j2-j = 1 + in fire_ln: 8.5.5 : xcd( 221 200 3 ) = 1.503286362 + in fire_ln: 8.5.5 : xcd( 220 200 1 ) = -0.5000000000 + in fire_ln: 8.5.5 : i1-i = -1 + in fire_ln: 8.5.5 : ycd( 221 200 3 ) = 0.5000000000 + in fire_ln: 8.5.5 : ycd( 220 200 1 ) = -0.1324744970 + in fire_ln: 8.5.5 : j1-j = 0 + in fire_ln: 8.5.6 : 221 200 + in fire_ln: 8.6 : 221 200 + in fire_ln: 8.7 : 221 200 + in fire_ln: 8.8 : 221 200 + in fire_ln: 8.9 : 221 200 + ERROR DEBUG AT TIME= 10.000 I J= 221 200 IFLT= 82 + I J NCOD= 221 200 3 + IN1= 220 200 + IN2= 221 201 + TIME-TIGN_G= 8.0000 8.0000 8.0000 + TIME-TIGN_G= 8.0000 1.0000 110.0000 + TIME-TIGN_G= 110.0000 110.0000 110.0000 + NFL = 0 1 1 + NFL = 1 1 0 + NFL = 0 0 0 + NC = 4 3 1 + NC = 2 1 0 + NC = 0 0 0 + ICLS = 0 1 4 + ICLS = 2 4 8 + ICLS = 8 8 8 + XCD(I J =-0.5000000 0.5016432 1.5032864 0.0000000 + YCD(I J = 0.4976496 0.4988248 0.5000000 0.0000000 + XCD(IP J = 0.0000000 0.0000000 0.0000000 0.0000000 + YCD(IP J = 0.0000000 0.0000000 0.0000000 0.0000000 + XCD(IM J =-0.5000000 0.5000000 0.0000000 0.0000000 + YCD(IM J =-0.1324745 0.4976496 0.0000000 0.0000000 + XCD(I JP= 1.5032864 0.5000000 0.0000000 0.0000000 + YCD(I JP=-0.5000000 0.2978128 0.0000000 0.0000000 + XCD(I JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCD(I JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCD(IP JP=-0.5000000-0.3879318-0.2758637 0.0000000 + YCD(IP JP= 0.2978128 0.3989064 0.5000000 0.0000000 + XCD(IM JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCD(IM JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCD(IP JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCD(IP JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCD(IM JP= 0.0000000 0.0000000 0.0000000 0.0000000 + YCD(IM JP= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(I J = 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(I J = 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IP J = 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IP J = 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IM J = 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IM J = 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(I JP= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(I JP= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(I JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(I JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IP JP= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IP JP= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IM JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IM JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IP JM= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IP JM= 0.0000000 0.0000000 0.0000000 0.0000000 + XCN(IM JP= 0.0000000 0.0000000 0.0000000 0.0000000 + YCN(IM JP= 0.0000000 0.0000000 0.0000000 0.0000000 + NCT ICLS= 1 4 + ICN= 0 0 1 0 + NFL= 1 + I J = 221 200 XFG=-0.5000000 0.5016432-0.5000000 1.5032864 + YFG= 0.4976496 0.4988248 0.5000000 0.5000000 + IP J = 222 200 XFG= 0.0000000 0.0000000 0.0000000 0.0000000 + YFG= 0.0000000 0.0000000 0.0000000 0.0000000 + IM J = 220 200 XFG=-0.5000000 0.5000000-0.5000000 0.5000000 + YFG=-0.1324745 0.4976496 0.5000000 0.5000000 + I JP = 221 201 XFG=-0.5000000 0.5000000-0.5000000 0.5000000 + YFG=-0.5000000 0.2978128 0.5000000 0.5000000 + I JM = 221 199 XFG= 0.0000000 0.0000000 0.0000000 0.0000000 + YFG= 0.0000000 0.0000000 0.0000000 0.0000000 + IP JP = 222 201 XFG=-0.5000000-0.3879318-0.5000000-0.2758637 + YFG= 0.2978128 0.3989064 0.5000000 0.5000000 + IP JM = 222 199 XFG= 0.0000000 0.0000000 0.0000000 0.0000000 + YFG= 0.0000000 0.0000000 0.0000000 0.0000000 + IM JP = 220 201 XFG=-0.5000000 0.5000000-0.5000000 0.5000000 + YFG=-0.5000000-0.5000000 0.5000000 0.5000000 + IM JM = 220 199 XFG= 0.0000000 0.0000000 0.0000000 0.0000000 + YFG= 0.0000000 0.0000000 0.0000000 0.0000000 + IXB(I J )= 0 1 0 1 + IYB(I J )= 1 1 0 0 + IXB(IP J )= 1 1 1 1 + IYB(IP J )= 1 1 1 1 + IXB(IM J )= 0 0 0 0 + IYB(IM J )= 1 1 0 0 + IXB(I JP)= 0 0 0 0 + IYB(I JP)= 0 1 0 0 + IXB(I JM)= 1 1 1 1 + IYB(I JM)= 1 1 1 1 + FATAL CALLED FROM FILE: module_fr_cawfe.b LINE: 5830 diff --git a/wrfv2_fire/test/em_fire/wrfbdy_d01 b/wrfv2_fire/test/em_fire/wrfbdy_d01 new file mode 100644 index 00000000..179ae53a Binary files /dev/null and b/wrfv2_fire/test/em_fire/wrfbdy_d01 differ diff --git a/wrfv2_fire/test/em_fire/wrfinput_d01 b/wrfv2_fire/test/em_fire/wrfinput_d01 new file mode 100644 index 00000000..5629870d Binary files /dev/null and b/wrfv2_fire/test/em_fire/wrfinput_d01 differ diff --git a/wrfv2_fire/test/em_fire/wrfout_d01_0001-01-01_00:00:00 b/wrfv2_fire/test/em_fire/wrfout_d01_0001-01-01_00:00:00 new file mode 100644 index 00000000..7ae3a5ee Binary files /dev/null and b/wrfv2_fire/test/em_fire/wrfout_d01_0001-01-01_00:00:00 differ diff --git a/wrfv2_fire/test/em_fire/wrfrst_d01_0001-01-01_02:00:00 b/wrfv2_fire/test/em_fire/wrfrst_d01_0001-01-01_02:00:00 new file mode 100644 index 00000000..a865d41b Binary files /dev/null and b/wrfv2_fire/test/em_fire/wrfrst_d01_0001-01-01_02:00:00 differ diff --git a/wrfv2_fire/test/em_grav2d_x/README.grav2d_x b/wrfv2_fire/test/em_grav2d_x/README.grav2d_x new file mode 100644 index 00000000..66b6db01 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/README.grav2d_x @@ -0,0 +1,53 @@ +em_grav2d_x test case: + +The default version of this test case reproduces the +100 m resolution 2D gravity current. This test case +was the focus of a workshop. The results of this workshop +are published in + +Straka et al, NUMERICAL-SOLUTIONS OF A NONLINEAR DENSITY-CURRENT - A +BENCHMARK SOLUTION AND COMPARISONS, +INT J NUMER METH FL 17 (1): 1-22 JUL 15 1993 + +This test is 2d (x,z) and uses a fixed physical viscosity, hence the +solution converges. It also uses a finite length domain with periodic +conditions, so tests with non-zero horizontal translation are also +appropriate. The reference shows tests are several different +resolutions and these are quite illuminating + +There are a number of interesting features in this very non-linear +solution (eddy structure, mins and maxes of temperature and velocity, +propagation of the gravity current, etc.) + +Solution results from the WRF-ARW core can be found on the web at +http://www.mmm.ucar.edu/individual/skamarock/test_cases/test_cases.html + +A number of versions test cases can be run using namelist.input files +and input_sounding files provided in the test directory. + +Two input_sounding files are provided + +(1) input_sounding.um=0 +(2) input_sounding.um=20 + +The first has no mean wind, the second has a constant horizontal +environmental wind of 20 m/s. The no-mean wind case produces a +symmetric gravity current, while the 20 m/s wind translates the +current (see the web page for further details and examples). +Copy the input_sounding.um=? into input_sounding to run the +desired case. The input_sounding file is an ascii file, so +it can be edited to change the mean wind speed to other values +if desired. + +Three namelist.input files are in this directory and they provide +for three different resolutions (dx, dz = 100, 200 and 400 m). +Again, see the web page listed above for example solutions at +the different resolutions. As with the sounding file, copy the +namelist.input.??? into namelist.input to run the desired case. + +The default case is 100 m resolution and um=0. + + + + + diff --git a/wrfv2_fire/test/em_grav2d_x/input_sounding b/wrfv2_fire/test/em_grav2d_x/input_sounding new file mode 100644 index 00000000..7ed658ea --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/input_sounding @@ -0,0 +1,12 @@ + 1000.000 300.00 0.00 + 0.00 300.00 0.00 00.00 0.00 + 1000.00 300.00 0.00 00.00 0.00 + 2000.00 300.00 0.00 00.00 0.00 + 3000.00 300.00 0.00 00.00 0.00 + 4000.00 300.00 0.00 00.00 0.00 + 5000.00 300.00 0.00 00.00 0.00 + 6000.00 300.00 0.00 00.00 0.00 + 7000.00 300.00 0.00 00.00 0.00 + 8000.00 300.00 0.00 00.00 0.00 + 9000.00 300.00 0.00 00.00 0.00 + 10000.00 300.00 0.00 00.00 0.00 diff --git a/wrfv2_fire/test/em_grav2d_x/input_sounding.um=0 b/wrfv2_fire/test/em_grav2d_x/input_sounding.um=0 new file mode 100644 index 00000000..7ed658ea --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/input_sounding.um=0 @@ -0,0 +1,12 @@ + 1000.000 300.00 0.00 + 0.00 300.00 0.00 00.00 0.00 + 1000.00 300.00 0.00 00.00 0.00 + 2000.00 300.00 0.00 00.00 0.00 + 3000.00 300.00 0.00 00.00 0.00 + 4000.00 300.00 0.00 00.00 0.00 + 5000.00 300.00 0.00 00.00 0.00 + 6000.00 300.00 0.00 00.00 0.00 + 7000.00 300.00 0.00 00.00 0.00 + 8000.00 300.00 0.00 00.00 0.00 + 9000.00 300.00 0.00 00.00 0.00 + 10000.00 300.00 0.00 00.00 0.00 diff --git a/wrfv2_fire/test/em_grav2d_x/input_sounding.um=20 b/wrfv2_fire/test/em_grav2d_x/input_sounding.um=20 new file mode 100644 index 00000000..b2c52cc8 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/input_sounding.um=20 @@ -0,0 +1,12 @@ + 1000.000 300.00 0.00 + 0.00 300.00 0.00 20.00 0.00 + 1000.00 300.00 0.00 20.00 0.00 + 2000.00 300.00 0.00 20.00 0.00 + 3000.00 300.00 0.00 20.00 0.00 + 4000.00 300.00 0.00 20.00 0.00 + 5000.00 300.00 0.00 20.00 0.00 + 6000.00 300.00 0.00 20.00 0.00 + 7000.00 300.00 0.00 20.00 0.00 + 8000.00 300.00 0.00 20.00 0.00 + 9000.00 300.00 0.00 20.00 0.00 + 10000.00 300.00 0.00 20.00 0.00 diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input b/wrfv2_fire/test/em_grav2d_x/namelist.input new file mode 100644 index 00000000..51472281 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/namelist.input @@ -0,0 +1,105 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 15, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 04, + end_minute = 00, + end_second = 00, + history_interval = 1, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 1, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 513, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 65, + dx = 100, + dy = 100, + ztop = 6409., + / + + &physics + mp_physics = 0, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 1, + damp_opt = 0, + zdamp = 15000., + dampcoef = 0.025, + khdif = 75, + kvdif = 75, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.100m b/wrfv2_fire/test/em_grav2d_x/namelist.input.100m new file mode 100644 index 00000000..51472281 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.100m @@ -0,0 +1,105 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 15, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 04, + end_minute = 00, + end_second = 00, + history_interval = 1, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 1, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 513, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 65, + dx = 100, + dy = 100, + ztop = 6409., + / + + &physics + mp_physics = 0, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 1, + damp_opt = 0, + zdamp = 15000., + dampcoef = 0.025, + khdif = 75, + kvdif = 75, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.200m b/wrfv2_fire/test/em_grav2d_x/namelist.input.200m new file mode 100644 index 00000000..7a8a9d48 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.200m @@ -0,0 +1,105 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 15, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 04, + end_minute = 00, + end_second = 00, + history_interval = 1, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 2, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 257, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 33, + dx = 200, + dy = 200, + ztop = 6409., + / + + &physics + mp_physics = 0, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 1, + damp_opt = 0, + zdamp = 15000., + dampcoef = 0.025, + khdif = 75, + kvdif = 75, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.400m b/wrfv2_fire/test/em_grav2d_x/namelist.input.400m new file mode 100644 index 00000000..6a6c7273 --- /dev/null +++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.400m @@ -0,0 +1,105 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 15, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 04, + end_minute = 00, + end_second = 00, + history_interval = 1, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 600, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 4, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 129, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 17, + dx = 400, + dy = 400, + ztop = 6409., + / + + &physics + mp_physics = 0, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 1, + damp_opt = 0, + zdamp = 15000., + dampcoef = 0.025, + khdif = 75, + kvdif = 75, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_hill2d_x/input_sounding b/wrfv2_fire/test/em_hill2d_x/input_sounding new file mode 100644 index 00000000..7556e89b --- /dev/null +++ b/wrfv2_fire/test/em_hill2d_x/input_sounding @@ -0,0 +1,602 @@ + 1000.000 288.00 0.00 + 0.00 288.00 0.00 10.00 0.00 + 50.00 288.15 0.00 10.00 0.00 + 100.00 288.29 0.00 10.00 0.00 + 150.00 288.44 0.00 10.00 0.00 + 200.00 288.59 0.00 10.00 0.00 + 250.00 288.74 0.00 10.00 0.00 + 300.00 288.88 0.00 10.00 0.00 + 350.00 289.03 0.00 10.00 0.00 + 400.00 289.18 0.00 10.00 0.00 + 450.00 289.32 0.00 10.00 0.00 + 500.00 289.47 0.00 10.00 0.00 + 550.00 289.62 0.00 10.00 0.00 + 600.00 289.77 0.00 10.00 0.00 + 650.00 289.92 0.00 10.00 0.00 + 700.00 290.06 0.00 10.00 0.00 + 750.00 290.21 0.00 10.00 0.00 + 800.00 290.36 0.00 10.00 0.00 + 850.00 290.51 0.00 10.00 0.00 + 900.00 290.66 0.00 10.00 0.00 + 950.00 290.80 0.00 10.00 0.00 + 1000.00 290.95 0.00 10.00 0.00 + 1050.00 291.10 0.00 10.00 0.00 + 1100.00 291.25 0.00 10.00 0.00 + 1150.00 291.40 0.00 10.00 0.00 + 1200.00 291.55 0.00 10.00 0.00 + 1250.00 291.69 0.00 10.00 0.00 + 1300.00 291.84 0.00 10.00 0.00 + 1350.00 291.99 0.00 10.00 0.00 + 1400.00 292.14 0.00 10.00 0.00 + 1450.00 292.29 0.00 10.00 0.00 + 1500.00 292.44 0.00 10.00 0.00 + 1550.00 292.59 0.00 10.00 0.00 + 1600.00 292.74 0.00 10.00 0.00 + 1650.00 292.89 0.00 10.00 0.00 + 1700.00 293.04 0.00 10.00 0.00 + 1750.00 293.19 0.00 10.00 0.00 + 1800.00 293.34 0.00 10.00 0.00 + 1850.00 293.49 0.00 10.00 0.00 + 1900.00 293.63 0.00 10.00 0.00 + 1950.00 293.78 0.00 10.00 0.00 + 2000.00 293.93 0.00 10.00 0.00 + 2050.00 294.08 0.00 10.00 0.00 + 2100.00 294.23 0.00 10.00 0.00 + 2150.00 294.38 0.00 10.00 0.00 + 2200.00 294.53 0.00 10.00 0.00 + 2250.00 294.68 0.00 10.00 0.00 + 2300.00 294.84 0.00 10.00 0.00 + 2350.00 294.99 0.00 10.00 0.00 + 2400.00 295.14 0.00 10.00 0.00 + 2450.00 295.29 0.00 10.00 0.00 + 2500.00 295.44 0.00 10.00 0.00 + 2550.00 295.59 0.00 10.00 0.00 + 2600.00 295.74 0.00 10.00 0.00 + 2650.00 295.89 0.00 10.00 0.00 + 2700.00 296.04 0.00 10.00 0.00 + 2750.00 296.19 0.00 10.00 0.00 + 2800.00 296.34 0.00 10.00 0.00 + 2850.00 296.49 0.00 10.00 0.00 + 2900.00 296.64 0.00 10.00 0.00 + 2950.00 296.80 0.00 10.00 0.00 + 3000.00 296.95 0.00 10.00 0.00 + 3050.00 297.10 0.00 10.00 0.00 + 3100.00 297.25 0.00 10.00 0.00 + 3150.00 297.40 0.00 10.00 0.00 + 3200.00 297.55 0.00 10.00 0.00 + 3250.00 297.71 0.00 10.00 0.00 + 3300.00 297.86 0.00 10.00 0.00 + 3350.00 298.01 0.00 10.00 0.00 + 3400.00 298.16 0.00 10.00 0.00 + 3450.00 298.31 0.00 10.00 0.00 + 3500.00 298.47 0.00 10.00 0.00 + 3550.00 298.62 0.00 10.00 0.00 + 3600.00 298.77 0.00 10.00 0.00 + 3650.00 298.92 0.00 10.00 0.00 + 3700.00 299.07 0.00 10.00 0.00 + 3750.00 299.23 0.00 10.00 0.00 + 3800.00 299.38 0.00 10.00 0.00 + 3850.00 299.53 0.00 10.00 0.00 + 3900.00 299.69 0.00 10.00 0.00 + 3950.00 299.84 0.00 10.00 0.00 + 4000.00 299.99 0.00 10.00 0.00 + 4050.00 300.14 0.00 10.00 0.00 + 4100.00 300.30 0.00 10.00 0.00 + 4150.00 300.45 0.00 10.00 0.00 + 4200.00 300.60 0.00 10.00 0.00 + 4250.00 300.76 0.00 10.00 0.00 + 4300.00 300.91 0.00 10.00 0.00 + 4350.00 301.06 0.00 10.00 0.00 + 4400.00 301.22 0.00 10.00 0.00 + 4450.00 301.37 0.00 10.00 0.00 + 4500.00 301.53 0.00 10.00 0.00 + 4550.00 301.68 0.00 10.00 0.00 + 4600.00 301.83 0.00 10.00 0.00 + 4650.00 301.99 0.00 10.00 0.00 + 4700.00 302.14 0.00 10.00 0.00 + 4750.00 302.29 0.00 10.00 0.00 + 4800.00 302.45 0.00 10.00 0.00 + 4850.00 302.60 0.00 10.00 0.00 + 4900.00 302.76 0.00 10.00 0.00 + 4950.00 302.91 0.00 10.00 0.00 + 5000.00 303.07 0.00 10.00 0.00 + 5050.00 303.22 0.00 10.00 0.00 + 5100.00 303.38 0.00 10.00 0.00 + 5150.00 303.53 0.00 10.00 0.00 + 5200.00 303.69 0.00 10.00 0.00 + 5250.00 303.84 0.00 10.00 0.00 + 5300.00 304.00 0.00 10.00 0.00 + 5350.00 304.15 0.00 10.00 0.00 + 5400.00 304.31 0.00 10.00 0.00 + 5450.00 304.46 0.00 10.00 0.00 + 5500.00 304.62 0.00 10.00 0.00 + 5550.00 304.77 0.00 10.00 0.00 + 5600.00 304.93 0.00 10.00 0.00 + 5650.00 305.08 0.00 10.00 0.00 + 5700.00 305.24 0.00 10.00 0.00 + 5750.00 305.39 0.00 10.00 0.00 + 5800.00 305.55 0.00 10.00 0.00 + 5850.00 305.71 0.00 10.00 0.00 + 5900.00 305.86 0.00 10.00 0.00 + 5950.00 306.02 0.00 10.00 0.00 + 6000.00 306.17 0.00 10.00 0.00 + 6050.00 306.33 0.00 10.00 0.00 + 6100.00 306.49 0.00 10.00 0.00 + 6150.00 306.64 0.00 10.00 0.00 + 6200.00 306.80 0.00 10.00 0.00 + 6250.00 306.95 0.00 10.00 0.00 + 6300.00 307.11 0.00 10.00 0.00 + 6350.00 307.27 0.00 10.00 0.00 + 6400.00 307.42 0.00 10.00 0.00 + 6450.00 307.58 0.00 10.00 0.00 + 6500.00 307.74 0.00 10.00 0.00 + 6550.00 307.90 0.00 10.00 0.00 + 6600.00 308.05 0.00 10.00 0.00 + 6650.00 308.21 0.00 10.00 0.00 + 6700.00 308.37 0.00 10.00 0.00 + 6750.00 308.52 0.00 10.00 0.00 + 6800.00 308.68 0.00 10.00 0.00 + 6850.00 308.84 0.00 10.00 0.00 + 6900.00 309.00 0.00 10.00 0.00 + 6950.00 309.15 0.00 10.00 0.00 + 7000.00 309.31 0.00 10.00 0.00 + 7050.00 309.47 0.00 10.00 0.00 + 7100.00 309.63 0.00 10.00 0.00 + 7150.00 309.79 0.00 10.00 0.00 + 7200.00 309.94 0.00 10.00 0.00 + 7250.00 310.10 0.00 10.00 0.00 + 7300.00 310.26 0.00 10.00 0.00 + 7350.00 310.42 0.00 10.00 0.00 + 7400.00 310.58 0.00 10.00 0.00 + 7450.00 310.73 0.00 10.00 0.00 + 7500.00 310.89 0.00 10.00 0.00 + 7550.00 311.05 0.00 10.00 0.00 + 7600.00 311.21 0.00 10.00 0.00 + 7650.00 311.37 0.00 10.00 0.00 + 7700.00 311.53 0.00 10.00 0.00 + 7750.00 311.69 0.00 10.00 0.00 + 7800.00 311.85 0.00 10.00 0.00 + 7850.00 312.00 0.00 10.00 0.00 + 7900.00 312.16 0.00 10.00 0.00 + 7950.00 312.32 0.00 10.00 0.00 + 8000.00 312.48 0.00 10.00 0.00 + 8050.00 312.64 0.00 10.00 0.00 + 8100.00 312.80 0.00 10.00 0.00 + 8150.00 312.96 0.00 10.00 0.00 + 8200.00 313.12 0.00 10.00 0.00 + 8250.00 313.28 0.00 10.00 0.00 + 8300.00 313.44 0.00 10.00 0.00 + 8350.00 313.60 0.00 10.00 0.00 + 8400.00 313.76 0.00 10.00 0.00 + 8450.00 313.92 0.00 10.00 0.00 + 8500.00 314.08 0.00 10.00 0.00 + 8550.00 314.24 0.00 10.00 0.00 + 8600.00 314.40 0.00 10.00 0.00 + 8650.00 314.56 0.00 10.00 0.00 + 8700.00 314.72 0.00 10.00 0.00 + 8750.00 314.88 0.00 10.00 0.00 + 8800.00 315.04 0.00 10.00 0.00 + 8850.00 315.20 0.00 10.00 0.00 + 8900.00 315.36 0.00 10.00 0.00 + 8950.00 315.52 0.00 10.00 0.00 + 9000.00 315.69 0.00 10.00 0.00 + 9050.00 315.85 0.00 10.00 0.00 + 9100.00 316.01 0.00 10.00 0.00 + 9150.00 316.17 0.00 10.00 0.00 + 9200.00 316.33 0.00 10.00 0.00 + 9250.00 316.49 0.00 10.00 0.00 + 9300.00 316.65 0.00 10.00 0.00 + 9350.00 316.81 0.00 10.00 0.00 + 9400.00 316.98 0.00 10.00 0.00 + 9450.00 317.14 0.00 10.00 0.00 + 9500.00 317.30 0.00 10.00 0.00 + 9550.00 317.46 0.00 10.00 0.00 + 9600.00 317.62 0.00 10.00 0.00 + 9650.00 317.78 0.00 10.00 0.00 + 9700.00 317.95 0.00 10.00 0.00 + 9750.00 318.11 0.00 10.00 0.00 + 9800.00 318.27 0.00 10.00 0.00 + 9850.00 318.43 0.00 10.00 0.00 + 9900.00 318.60 0.00 10.00 0.00 + 9950.00 318.76 0.00 10.00 0.00 + 10000.00 318.92 0.00 10.00 0.00 + 10050.00 319.08 0.00 10.00 0.00 + 10100.00 319.25 0.00 10.00 0.00 + 10150.00 319.41 0.00 10.00 0.00 + 10200.00 319.57 0.00 10.00 0.00 + 10250.00 319.74 0.00 10.00 0.00 + 10300.00 319.90 0.00 10.00 0.00 + 10350.00 320.06 0.00 10.00 0.00 + 10400.00 320.22 0.00 10.00 0.00 + 10450.00 320.39 0.00 10.00 0.00 + 10500.00 320.55 0.00 10.00 0.00 + 10550.00 320.72 0.00 10.00 0.00 + 10600.00 320.88 0.00 10.00 0.00 + 10650.00 321.04 0.00 10.00 0.00 + 10700.00 321.21 0.00 10.00 0.00 + 10750.00 321.37 0.00 10.00 0.00 + 10800.00 321.53 0.00 10.00 0.00 + 10850.00 321.70 0.00 10.00 0.00 + 10900.00 321.86 0.00 10.00 0.00 + 10950.00 322.03 0.00 10.00 0.00 + 11000.00 322.19 0.00 10.00 0.00 + 11050.00 322.35 0.00 10.00 0.00 + 11100.00 322.52 0.00 10.00 0.00 + 11150.00 322.68 0.00 10.00 0.00 + 11200.00 322.85 0.00 10.00 0.00 + 11250.00 323.01 0.00 10.00 0.00 + 11300.00 323.18 0.00 10.00 0.00 + 11350.00 323.34 0.00 10.00 0.00 + 11400.00 323.51 0.00 10.00 0.00 + 11450.00 323.67 0.00 10.00 0.00 + 11500.00 323.84 0.00 10.00 0.00 + 11550.00 324.00 0.00 10.00 0.00 + 11600.00 324.17 0.00 10.00 0.00 + 11650.00 324.33 0.00 10.00 0.00 + 11700.00 324.50 0.00 10.00 0.00 + 11750.00 324.66 0.00 10.00 0.00 + 11800.00 324.83 0.00 10.00 0.00 + 11850.00 325.00 0.00 10.00 0.00 + 11900.00 325.16 0.00 10.00 0.00 + 11950.00 325.33 0.00 10.00 0.00 + 12000.00 325.49 0.00 10.00 0.00 + 12050.00 325.66 0.00 10.00 0.00 + 12100.00 325.83 0.00 10.00 0.00 + 12150.00 325.99 0.00 10.00 0.00 + 12200.00 326.16 0.00 10.00 0.00 + 12250.00 326.32 0.00 10.00 0.00 + 12300.00 326.49 0.00 10.00 0.00 + 12350.00 326.66 0.00 10.00 0.00 + 12400.00 326.82 0.00 10.00 0.00 + 12450.00 326.99 0.00 10.00 0.00 + 12500.00 327.16 0.00 10.00 0.00 + 12550.00 327.32 0.00 10.00 0.00 + 12600.00 327.49 0.00 10.00 0.00 + 12650.00 327.66 0.00 10.00 0.00 + 12700.00 327.82 0.00 10.00 0.00 + 12750.00 327.99 0.00 10.00 0.00 + 12800.00 328.16 0.00 10.00 0.00 + 12850.00 328.33 0.00 10.00 0.00 + 12900.00 328.49 0.00 10.00 0.00 + 12950.00 328.66 0.00 10.00 0.00 + 13000.00 328.83 0.00 10.00 0.00 + 13050.00 329.00 0.00 10.00 0.00 + 13100.00 329.16 0.00 10.00 0.00 + 13150.00 329.33 0.00 10.00 0.00 + 13200.00 329.50 0.00 10.00 0.00 + 13250.00 329.67 0.00 10.00 0.00 + 13300.00 329.84 0.00 10.00 0.00 + 13350.00 330.01 0.00 10.00 0.00 + 13400.00 330.17 0.00 10.00 0.00 + 13450.00 330.34 0.00 10.00 0.00 + 13500.00 330.51 0.00 10.00 0.00 + 13550.00 330.68 0.00 10.00 0.00 + 13600.00 330.85 0.00 10.00 0.00 + 13650.00 331.02 0.00 10.00 0.00 + 13700.00 331.19 0.00 10.00 0.00 + 13750.00 331.35 0.00 10.00 0.00 + 13800.00 331.52 0.00 10.00 0.00 + 13850.00 331.69 0.00 10.00 0.00 + 13900.00 331.86 0.00 10.00 0.00 + 13950.00 332.03 0.00 10.00 0.00 + 14000.00 332.20 0.00 10.00 0.00 + 14050.00 332.37 0.00 10.00 0.00 + 14100.00 332.54 0.00 10.00 0.00 + 14150.00 332.71 0.00 10.00 0.00 + 14200.00 332.88 0.00 10.00 0.00 + 14250.00 333.05 0.00 10.00 0.00 + 14300.00 333.22 0.00 10.00 0.00 + 14350.00 333.39 0.00 10.00 0.00 + 14400.00 333.56 0.00 10.00 0.00 + 14450.00 333.73 0.00 10.00 0.00 + 14500.00 333.90 0.00 10.00 0.00 + 14550.00 334.07 0.00 10.00 0.00 + 14600.00 334.24 0.00 10.00 0.00 + 14650.00 334.41 0.00 10.00 0.00 + 14700.00 334.58 0.00 10.00 0.00 + 14750.00 334.75 0.00 10.00 0.00 + 14800.00 334.92 0.00 10.00 0.00 + 14850.00 335.09 0.00 10.00 0.00 + 14900.00 335.26 0.00 10.00 0.00 + 14950.00 335.43 0.00 10.00 0.00 + 15000.00 335.61 0.00 10.00 0.00 + 15050.00 335.78 0.00 10.00 0.00 + 15100.00 335.95 0.00 10.00 0.00 + 15150.00 336.12 0.00 10.00 0.00 + 15200.00 336.29 0.00 10.00 0.00 + 15250.00 336.46 0.00 10.00 0.00 + 15300.00 336.63 0.00 10.00 0.00 + 15350.00 336.81 0.00 10.00 0.00 + 15400.00 336.98 0.00 10.00 0.00 + 15450.00 337.15 0.00 10.00 0.00 + 15500.00 337.32 0.00 10.00 0.00 + 15550.00 337.49 0.00 10.00 0.00 + 15600.00 337.67 0.00 10.00 0.00 + 15650.00 337.84 0.00 10.00 0.00 + 15700.00 338.01 0.00 10.00 0.00 + 15750.00 338.18 0.00 10.00 0.00 + 15800.00 338.35 0.00 10.00 0.00 + 15850.00 338.53 0.00 10.00 0.00 + 15900.00 338.70 0.00 10.00 0.00 + 15950.00 338.87 0.00 10.00 0.00 + 16000.00 339.05 0.00 10.00 0.00 + 16050.00 339.22 0.00 10.00 0.00 + 16100.00 339.39 0.00 10.00 0.00 + 16150.00 339.56 0.00 10.00 0.00 + 16200.00 339.74 0.00 10.00 0.00 + 16250.00 339.91 0.00 10.00 0.00 + 16300.00 340.08 0.00 10.00 0.00 + 16350.00 340.26 0.00 10.00 0.00 + 16400.00 340.43 0.00 10.00 0.00 + 16450.00 340.60 0.00 10.00 0.00 + 16500.00 340.78 0.00 10.00 0.00 + 16550.00 340.95 0.00 10.00 0.00 + 16600.00 341.13 0.00 10.00 0.00 + 16650.00 341.30 0.00 10.00 0.00 + 16700.00 341.47 0.00 10.00 0.00 + 16750.00 341.65 0.00 10.00 0.00 + 16800.00 341.82 0.00 10.00 0.00 + 16850.00 342.00 0.00 10.00 0.00 + 16900.00 342.17 0.00 10.00 0.00 + 16950.00 342.35 0.00 10.00 0.00 + 17000.00 342.52 0.00 10.00 0.00 + 17050.00 342.70 0.00 10.00 0.00 + 17100.00 342.87 0.00 10.00 0.00 + 17150.00 343.05 0.00 10.00 0.00 + 17200.00 343.22 0.00 10.00 0.00 + 17250.00 343.40 0.00 10.00 0.00 + 17300.00 343.57 0.00 10.00 0.00 + 17350.00 343.75 0.00 10.00 0.00 + 17400.00 343.92 0.00 10.00 0.00 + 17450.00 344.10 0.00 10.00 0.00 + 17500.00 344.27 0.00 10.00 0.00 + 17550.00 344.45 0.00 10.00 0.00 + 17600.00 344.62 0.00 10.00 0.00 + 17650.00 344.80 0.00 10.00 0.00 + 17700.00 344.97 0.00 10.00 0.00 + 17750.00 345.15 0.00 10.00 0.00 + 17800.00 345.33 0.00 10.00 0.00 + 17850.00 345.50 0.00 10.00 0.00 + 17900.00 345.68 0.00 10.00 0.00 + 17950.00 345.86 0.00 10.00 0.00 + 18000.00 346.03 0.00 10.00 0.00 + 18050.00 346.21 0.00 10.00 0.00 + 18100.00 346.38 0.00 10.00 0.00 + 18150.00 346.56 0.00 10.00 0.00 + 18200.00 346.74 0.00 10.00 0.00 + 18250.00 346.92 0.00 10.00 0.00 + 18300.00 347.09 0.00 10.00 0.00 + 18350.00 347.27 0.00 10.00 0.00 + 18400.00 347.45 0.00 10.00 0.00 + 18450.00 347.62 0.00 10.00 0.00 + 18500.00 347.80 0.00 10.00 0.00 + 18550.00 347.98 0.00 10.00 0.00 + 18600.00 348.16 0.00 10.00 0.00 + 18650.00 348.33 0.00 10.00 0.00 + 18700.00 348.51 0.00 10.00 0.00 + 18750.00 348.69 0.00 10.00 0.00 + 18800.00 348.87 0.00 10.00 0.00 + 18850.00 349.04 0.00 10.00 0.00 + 18900.00 349.22 0.00 10.00 0.00 + 18950.00 349.40 0.00 10.00 0.00 + 19000.00 349.58 0.00 10.00 0.00 + 19050.00 349.76 0.00 10.00 0.00 + 19100.00 349.94 0.00 10.00 0.00 + 19150.00 350.11 0.00 10.00 0.00 + 19200.00 350.29 0.00 10.00 0.00 + 19250.00 350.47 0.00 10.00 0.00 + 19300.00 350.65 0.00 10.00 0.00 + 19350.00 350.83 0.00 10.00 0.00 + 19400.00 351.01 0.00 10.00 0.00 + 19450.00 351.19 0.00 10.00 0.00 + 19500.00 351.37 0.00 10.00 0.00 + 19550.00 351.55 0.00 10.00 0.00 + 19600.00 351.72 0.00 10.00 0.00 + 19650.00 351.90 0.00 10.00 0.00 + 19700.00 352.08 0.00 10.00 0.00 + 19750.00 352.26 0.00 10.00 0.00 + 19800.00 352.44 0.00 10.00 0.00 + 19850.00 352.62 0.00 10.00 0.00 + 19900.00 352.80 0.00 10.00 0.00 + 19950.00 352.98 0.00 10.00 0.00 + 20000.00 353.16 0.00 10.00 0.00 + 20050.00 353.34 0.00 10.00 0.00 + 20100.00 353.52 0.00 10.00 0.00 + 20150.00 353.70 0.00 10.00 0.00 + 20200.00 353.88 0.00 10.00 0.00 + 20250.00 354.06 0.00 10.00 0.00 + 20300.00 354.24 0.00 10.00 0.00 + 20350.00 354.43 0.00 10.00 0.00 + 20400.00 354.61 0.00 10.00 0.00 + 20450.00 354.79 0.00 10.00 0.00 + 20500.00 354.97 0.00 10.00 0.00 + 20550.00 355.15 0.00 10.00 0.00 + 20600.00 355.33 0.00 10.00 0.00 + 20650.00 355.51 0.00 10.00 0.00 + 20700.00 355.69 0.00 10.00 0.00 + 20750.00 355.87 0.00 10.00 0.00 + 20800.00 356.06 0.00 10.00 0.00 + 20850.00 356.24 0.00 10.00 0.00 + 20900.00 356.42 0.00 10.00 0.00 + 20950.00 356.60 0.00 10.00 0.00 + 21000.00 356.78 0.00 10.00 0.00 + 21050.00 356.96 0.00 10.00 0.00 + 21100.00 357.15 0.00 10.00 0.00 + 21150.00 357.33 0.00 10.00 0.00 + 21200.00 357.51 0.00 10.00 0.00 + 21250.00 357.69 0.00 10.00 0.00 + 21300.00 357.88 0.00 10.00 0.00 + 21350.00 358.06 0.00 10.00 0.00 + 21400.00 358.24 0.00 10.00 0.00 + 21450.00 358.42 0.00 10.00 0.00 + 21500.00 358.61 0.00 10.00 0.00 + 21550.00 358.79 0.00 10.00 0.00 + 21600.00 358.97 0.00 10.00 0.00 + 21650.00 359.16 0.00 10.00 0.00 + 21700.00 359.34 0.00 10.00 0.00 + 21750.00 359.52 0.00 10.00 0.00 + 21800.00 359.71 0.00 10.00 0.00 + 21850.00 359.89 0.00 10.00 0.00 + 21900.00 360.07 0.00 10.00 0.00 + 21950.00 360.26 0.00 10.00 0.00 + 22000.00 360.44 0.00 10.00 0.00 + 22050.00 360.62 0.00 10.00 0.00 + 22100.00 360.81 0.00 10.00 0.00 + 22150.00 360.99 0.00 10.00 0.00 + 22200.00 361.18 0.00 10.00 0.00 + 22250.00 361.36 0.00 10.00 0.00 + 22300.00 361.54 0.00 10.00 0.00 + 22350.00 361.73 0.00 10.00 0.00 + 22400.00 361.91 0.00 10.00 0.00 + 22450.00 362.10 0.00 10.00 0.00 + 22500.00 362.28 0.00 10.00 0.00 + 22550.00 362.47 0.00 10.00 0.00 + 22600.00 362.65 0.00 10.00 0.00 + 22650.00 362.84 0.00 10.00 0.00 + 22700.00 363.02 0.00 10.00 0.00 + 22750.00 363.21 0.00 10.00 0.00 + 22800.00 363.39 0.00 10.00 0.00 + 22850.00 363.58 0.00 10.00 0.00 + 22900.00 363.76 0.00 10.00 0.00 + 22950.00 363.95 0.00 10.00 0.00 + 23000.00 364.13 0.00 10.00 0.00 + 23050.00 364.32 0.00 10.00 0.00 + 23100.00 364.51 0.00 10.00 0.00 + 23150.00 364.69 0.00 10.00 0.00 + 23200.00 364.88 0.00 10.00 0.00 + 23250.00 365.06 0.00 10.00 0.00 + 23300.00 365.25 0.00 10.00 0.00 + 23350.00 365.44 0.00 10.00 0.00 + 23400.00 365.62 0.00 10.00 0.00 + 23450.00 365.81 0.00 10.00 0.00 + 23500.00 366.00 0.00 10.00 0.00 + 23550.00 366.18 0.00 10.00 0.00 + 23600.00 366.37 0.00 10.00 0.00 + 23650.00 366.56 0.00 10.00 0.00 + 23700.00 366.74 0.00 10.00 0.00 + 23750.00 366.93 0.00 10.00 0.00 + 23800.00 367.12 0.00 10.00 0.00 + 23850.00 367.30 0.00 10.00 0.00 + 23900.00 367.49 0.00 10.00 0.00 + 23950.00 367.68 0.00 10.00 0.00 + 24000.00 367.87 0.00 10.00 0.00 + 24050.00 368.05 0.00 10.00 0.00 + 24100.00 368.24 0.00 10.00 0.00 + 24150.00 368.43 0.00 10.00 0.00 + 24200.00 368.62 0.00 10.00 0.00 + 24250.00 368.81 0.00 10.00 0.00 + 24300.00 368.99 0.00 10.00 0.00 + 24350.00 369.18 0.00 10.00 0.00 + 24400.00 369.37 0.00 10.00 0.00 + 24450.00 369.56 0.00 10.00 0.00 + 24500.00 369.75 0.00 10.00 0.00 + 24550.00 369.94 0.00 10.00 0.00 + 24600.00 370.12 0.00 10.00 0.00 + 24650.00 370.31 0.00 10.00 0.00 + 24700.00 370.50 0.00 10.00 0.00 + 24750.00 370.69 0.00 10.00 0.00 + 24800.00 370.88 0.00 10.00 0.00 + 24850.00 371.07 0.00 10.00 0.00 + 24900.00 371.26 0.00 10.00 0.00 + 24950.00 371.45 0.00 10.00 0.00 + 25000.00 371.64 0.00 10.00 0.00 + 25050.00 371.83 0.00 10.00 0.00 + 25100.00 372.02 0.00 10.00 0.00 + 25150.00 372.21 0.00 10.00 0.00 + 25200.00 372.40 0.00 10.00 0.00 + 25250.00 372.59 0.00 10.00 0.00 + 25300.00 372.78 0.00 10.00 0.00 + 25350.00 372.97 0.00 10.00 0.00 + 25400.00 373.16 0.00 10.00 0.00 + 25450.00 373.35 0.00 10.00 0.00 + 25500.00 373.54 0.00 10.00 0.00 + 25550.00 373.73 0.00 10.00 0.00 + 25600.00 373.92 0.00 10.00 0.00 + 25650.00 374.11 0.00 10.00 0.00 + 25700.00 374.30 0.00 10.00 0.00 + 25750.00 374.49 0.00 10.00 0.00 + 25800.00 374.68 0.00 10.00 0.00 + 25850.00 374.87 0.00 10.00 0.00 + 25900.00 375.06 0.00 10.00 0.00 + 25950.00 375.26 0.00 10.00 0.00 + 26000.00 375.45 0.00 10.00 0.00 + 26050.00 375.64 0.00 10.00 0.00 + 26100.00 375.83 0.00 10.00 0.00 + 26150.00 376.02 0.00 10.00 0.00 + 26200.00 376.21 0.00 10.00 0.00 + 26250.00 376.41 0.00 10.00 0.00 + 26300.00 376.60 0.00 10.00 0.00 + 26350.00 376.79 0.00 10.00 0.00 + 26400.00 376.98 0.00 10.00 0.00 + 26450.00 377.17 0.00 10.00 0.00 + 26500.00 377.37 0.00 10.00 0.00 + 26550.00 377.56 0.00 10.00 0.00 + 26600.00 377.75 0.00 10.00 0.00 + 26650.00 377.94 0.00 10.00 0.00 + 26700.00 378.14 0.00 10.00 0.00 + 26750.00 378.33 0.00 10.00 0.00 + 26800.00 378.52 0.00 10.00 0.00 + 26850.00 378.72 0.00 10.00 0.00 + 26900.00 378.91 0.00 10.00 0.00 + 26950.00 379.10 0.00 10.00 0.00 + 27000.00 379.30 0.00 10.00 0.00 + 27050.00 379.49 0.00 10.00 0.00 + 27100.00 379.68 0.00 10.00 0.00 + 27150.00 379.88 0.00 10.00 0.00 + 27200.00 380.07 0.00 10.00 0.00 + 27250.00 380.26 0.00 10.00 0.00 + 27300.00 380.46 0.00 10.00 0.00 + 27350.00 380.65 0.00 10.00 0.00 + 27400.00 380.85 0.00 10.00 0.00 + 27450.00 381.04 0.00 10.00 0.00 + 27500.00 381.23 0.00 10.00 0.00 + 27550.00 381.43 0.00 10.00 0.00 + 27600.00 381.62 0.00 10.00 0.00 + 27650.00 381.82 0.00 10.00 0.00 + 27700.00 382.01 0.00 10.00 0.00 + 27750.00 382.21 0.00 10.00 0.00 + 27800.00 382.40 0.00 10.00 0.00 + 27850.00 382.60 0.00 10.00 0.00 + 27900.00 382.79 0.00 10.00 0.00 + 27950.00 382.99 0.00 10.00 0.00 + 28000.00 383.18 0.00 10.00 0.00 + 28050.00 383.38 0.00 10.00 0.00 + 28100.00 383.57 0.00 10.00 0.00 + 28150.00 383.77 0.00 10.00 0.00 + 28200.00 383.97 0.00 10.00 0.00 + 28250.00 384.16 0.00 10.00 0.00 + 28300.00 384.36 0.00 10.00 0.00 + 28350.00 384.55 0.00 10.00 0.00 + 28400.00 384.75 0.00 10.00 0.00 + 28450.00 384.95 0.00 10.00 0.00 + 28500.00 385.14 0.00 10.00 0.00 + 28550.00 385.34 0.00 10.00 0.00 + 28600.00 385.54 0.00 10.00 0.00 + 28650.00 385.73 0.00 10.00 0.00 + 28700.00 385.93 0.00 10.00 0.00 + 28750.00 386.13 0.00 10.00 0.00 + 28800.00 386.32 0.00 10.00 0.00 + 28850.00 386.52 0.00 10.00 0.00 + 28900.00 386.72 0.00 10.00 0.00 + 28950.00 386.91 0.00 10.00 0.00 + 29000.00 387.11 0.00 10.00 0.00 + 29050.00 387.31 0.00 10.00 0.00 + 29100.00 387.51 0.00 10.00 0.00 + 29150.00 387.70 0.00 10.00 0.00 + 29200.00 387.90 0.00 10.00 0.00 + 29250.00 388.10 0.00 10.00 0.00 + 29300.00 388.30 0.00 10.00 0.00 + 29350.00 388.50 0.00 10.00 0.00 + 29400.00 388.69 0.00 10.00 0.00 + 29450.00 388.89 0.00 10.00 0.00 + 29500.00 389.09 0.00 10.00 0.00 + 29550.00 389.29 0.00 10.00 0.00 + 29600.00 389.49 0.00 10.00 0.00 + 29650.00 389.69 0.00 10.00 0.00 + 29700.00 389.88 0.00 10.00 0.00 + 29750.00 390.08 0.00 10.00 0.00 + 29800.00 390.28 0.00 10.00 0.00 + 29850.00 390.48 0.00 10.00 0.00 + 29900.00 390.68 0.00 10.00 0.00 + 29950.00 390.88 0.00 10.00 0.00 + 30000.00 391.08 0.00 10.00 0.00 diff --git a/wrfv2_fire/test/em_hill2d_x/namelist.input b/wrfv2_fire/test/em_hill2d_x/namelist.input new file mode 100644 index 00000000..b28064c1 --- /dev/null +++ b/wrfv2_fire/test/em_hill2d_x/namelist.input @@ -0,0 +1,105 @@ + &time_control + run_days = 0, + run_hours = 10, + run_minutes = 0, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 10, + end_minute = 00, + end_second = 00, + history_interval = 60, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 120, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 20, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 202, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 41, + dx = 2000, + dy = 2000, + ztop = 30000., + / + + &physics + mp_physics = 0, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 1, + damp_opt = 2, + zdamp = 15000., + dampcoef = .003, + khdif = 3000, + kvdif = 3, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .false., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .true., + open_xe = .true., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_quarter_ss/README.quarter_ss b/wrfv2_fire/test/em_quarter_ss/README.quarter_ss new file mode 100644 index 00000000..5ab16ee4 --- /dev/null +++ b/wrfv2_fire/test/em_quarter_ss/README.quarter_ss @@ -0,0 +1,36 @@ +em_quarter_ss test case: + +This test case produces a simulation of a supercell +thunderstorm. The environmental wind makes a +"quarter circle" when plotted on a hodograph, and +is commonly referred to as "quarter circle shear". +"ss" refers to "super-cell". + +The default version of this test case uses a constant +eddy viscosity for turbulent mixing -> +diff_opt=1 and km_opt = 1 in namelist.input. +The Coriolis terms in the model are off (f = 0) + +The prognostic TKE can be activated by setting +diff_opt=2 and km_opt = 2 (see README.namelist). + +In idealized cloud model simulations, it is common practice +to use Coriolis forcing calculated from wind fields defined +as perturbations from the initial sounding. This option +can be activated by setting the "dynamics" namelist option +"pert_coriolis = .true." (the default is false). +Additionally, the value of the Coriolis parameter "f" +will need to be reset (from zero to the desired value) +in WRFV1/dyn_em/module_initialize_quarter_ss.F, and +the initial state recomputed. + +Also, a constant surface drag and heat flux can be specified +in the TKE formulation by setting the "dynamics" namelist option +"tke_drag_coefficient = Cd", +"tke_heat_flux = S". +The default values are zero. Please note that these are +specified constants; the formulations do not make use of +similarity theory. These momentum and heat fluxes will +not be active if surface and boundary layer formulations are +activated in the model physics. + diff --git a/wrfv2_fire/test/em_quarter_ss/input_sounding b/wrfv2_fire/test/em_quarter_ss/input_sounding new file mode 100644 index 00000000..0f91581b --- /dev/null +++ b/wrfv2_fire/test/em_quarter_ss/input_sounding @@ -0,0 +1,48 @@ + 1000.00 300.00 14.00 + 250.00 300.45 14.00 -7.88 -3.58 + 750.00 301.25 14.00 -6.94 -0.89 + 1250.00 302.47 13.50 -5.17 1.33 + 1750.00 303.93 11.10 -2.76 2.84 + 2250.00 305.31 9.06 0.01 3.47 + 2750.00 306.81 7.36 2.87 3.49 + 3250.00 308.46 5.95 5.73 3.49 + 3750.00 310.03 4.78 8.58 3.49 + 4250.00 311.74 3.82 11.44 3.49 + 4750.00 313.48 3.01 14.30 3.49 + 5250.00 315.24 2.36 17.15 3.49 + 5750.00 317.18 1.80 20.01 3.49 + 6250.00 319.02 1.41 22.87 3.49 + 6750.00 320.88 1.07 25.73 3.49 + 7250.00 322.80 0.80 27.15 3.49 + 7750.00 324.87 0.60 27.15 3.49 + 8250.00 326.86 0.43 27.15 3.49 + 8750.00 328.89 0.32 27.15 3.49 + 9250.00 330.39 0.24 27.15 3.49 + 9750.00 332.80 0.17 27.15 3.49 + 10250.00 335.23 0.10 27.15 3.49 + 10750.00 337.31 0.08 27.15 3.49 + 11250.00 339.55 0.05 27.15 3.49 + 11750.00 342.82 0.03 27.15 3.49 + 12250.00 349.88 0.04 27.15 3.49 + 12750.00 357.34 0.04 27.15 3.49 + 13250.00 364.91 0.04 27.15 3.49 + 13750.00 373.22 0.04 27.15 3.49 + 14250.00 381.67 0.04 27.15 3.49 + 14750.00 390.29 0.04 27.15 3.49 + 15250.00 398.91 0.04 27.15 3.49 + 15750.00 407.53 0.04 27.15 3.49 + 16250.00 416.15 0.04 27.15 3.49 + 16750.00 424.77 0.04 27.15 3.49 + 17250.00 433.39 0.04 27.15 3.49 + 17750.00 442.01 0.04 27.15 3.49 + 18250.00 450.63 0.04 27.15 3.49 + 18750.00 459.25 0.04 27.15 3.49 + 19250.00 467.87 0.04 27.15 3.49 + 19750.00 476.49 0.04 27.15 3.49 + 20250.00 485.11 0.04 27.15 3.49 + 20750.00 493.73 0.04 27.15 3.49 + 21250.00 502.35 0.04 27.15 3.49 + 21750.00 510.97 0.04 27.15 3.49 + 22250.00 519.59 0.04 27.15 3.49 + 22750.00 528.21 0.04 27.15 3.49 + diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input b/wrfv2_fire/test/em_quarter_ss/namelist.input new file mode 100644 index 00000000..f2f35432 --- /dev/null +++ b/wrfv2_fire/test/em_quarter_ss/namelist.input @@ -0,0 +1,120 @@ + &time_control + run_days = 0, + run_hours = 0, + run_minutes = 60, + run_seconds = 0, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 00, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 01, 01, 01, + end_hour = 00, 00, 00, + end_minute = 120, 120, 120, + end_second = 00, 00, 00, + history_interval = 30, 10, 10, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 120, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 12, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 42, 43, 43, + s_sn = 1, 1, 1, + e_sn = 42, 43, 43, + s_vert = 1, 1, 1, + e_vert = 41, 41, 41, + dx = 2000, 666.6666667, 222.2222222 + dy = 2000, 666.6666667, 222.2222222 + ztop = 20000, 20000, 20000, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 15, 15, + j_parent_start = 0, 15, 15, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 1, 1, 1, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 30, 30, 30, + sf_sfclay_physics = 0, 0, 0, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 2, + damp_opt = 2, + zdamp = 5000., 5000., 5000., + dampcoef = 0.003, 0.003, 0.003 + khdif = 500, 500, 500, + kvdif = 500, 500, 500, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + mix_full_fields = .true., .true., .true., + non_hydrostatic = .true., .true., .true., + time_step_sound = 6, 6, 6, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .true., .false.,.false., + open_xe = .true., .false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .true., .false.,.false., + open_ye = .true., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_quarter_ss/run_me_first.csh b/wrfv2_fire/test/em_quarter_ss/run_me_first.csh new file mode 100755 index 00000000..29e53791 --- /dev/null +++ b/wrfv2_fire/test/em_quarter_ss/run_me_first.csh @@ -0,0 +1,8 @@ +#!/bin/csh + +echo Setting up quarter_ss case by linking data files into this directory + +echo linking to RRTM_DATA in ../../run directory +ln -sf ../../run/RRTM_DATA . + +echo done diff --git a/wrfv2_fire/test/em_real/README.grid_fdda b/wrfv2_fire/test/em_real/README.grid_fdda new file mode 100644 index 00000000..4f62918e --- /dev/null +++ b/wrfv2_fire/test/em_real/README.grid_fdda @@ -0,0 +1,41 @@ +Running grid nudging +-------------------- +Grid nudging is available in Version 2.2. +This nudges the WRF run towards a gridded analysis linearly interpolated in time between +specified analyses. It only requires multiple time periods of analyses for each domain +to be nudged, and these are input to real in the same format as the initial conditions. +To run an fdda job + +- run real.exe with grid_fdda = 1 + This will generate an extra input file with the time-varying analyses called wrffdda_d0 +- note that each domain can have grid_fdda = 1 or 0 when running nesting +- run wrf.exe with the same grid_fdda setting to use the wrffdda files generated + Also select wrf run-time options from the list described below to determine which fields to nudge, + how strongly to nudge, whether to nudge in the boundary layer, or whether to truncate + nudging below a certain grid level +- There is a ramping capability for dynamic initialization that turns nudging off over a + specified period + + &fdda + grid_fdda (max_dom) = 1 ; grid-nudging fdda on (=0 off) for each domain + gfdda_inname = "wrffdda_d" ; defined name in real + gfdda_interval_m (max_dom) = 360 ; time interval (min) between analysis times + gfdda_end_h (max_dom) = 6 ; time (h) to stop nudging after start of forecast + io_form_gfdda = 2 ; analysis data io format (2 = netCDF) + fgdt (max_dom) = 0 ; calculation frequency (minutes) for grid-nudging (0=every step) + if_no_pbl_nudging_uv (max_dom) = 0 ; 1= no nudging of u and v in the pbl, 0=nudging in the pbl + if_no_pbl_nudging_t (max_dom) = 0 ; 1= no nudging of temp in the pbl, 0=nudging in the pbl + if_no_pbl_nudging_q (max_dom) = 0 ; 1= no nudging of qvapor in the pbl, 0=nudging in the pbl + if_zfac_uv (max_dom) = 0 ; 0= nudge u and v all layers, 1= limit nudging to levels above k_zfac_uv + k_zfac_uv (max_dom) = 10 ; 10=model level below which nudging is switched off for u and v + if_zfac_t (max_dom) = 0 ; 0= nudge temp all layers, 1= limit nudging to levels above k_zfac_t + k_zfac_t (max_dom) = 10 ; 10=model level below which nudging is switched off for temp + if_zfac_q (max_dom) = 0 ; 0= nudge qvapor all layers, 1= limit nudging to levels above k_zfac_q + k_zfac_q (max_dom) = 10 ; 10=model level below which nudging is switched off for qvapor + guv (max_dom) = 0.0003 ; nudging coefficient for u and v (sec-1) + gt (max_dom) = 0.0003 ; nudging coefficient for temp (sec-1) + gq (max_dom) = 0.0003 ; nudging coefficient for qvapor (sec-1) + if_ramping = 0 ; 0= nudging ends as a step function, 1= ramping nudging down at end of period + dtramp_min = 60.0 ; time (min) for ramping function, 60.0=ramping starts at last analysis time, + -60.0=ramping ends at last analysis time + diff --git a/wrfv2_fire/test/em_real/README.obs_fdda b/wrfv2_fire/test/em_real/README.obs_fdda new file mode 100644 index 00000000..7b820cbb --- /dev/null +++ b/wrfv2_fire/test/em_real/README.obs_fdda @@ -0,0 +1,110 @@ +General description +------------------- +Features and advantages of observational nudging are discussed in (*) below. +The method uses relaxation terms based on the model error at observational +stations, and the relaxation is such as to reduce this error. +Each observation has a radius of influence, a time window, and a relaxation +time scale determined by user-specified input. These determine where, when, +and how much it affects the model solution. Typical model grid points may +be within the radius of influence of several observations, and their +contributions are weighted according to the distance from the observation(s). +Before performing obs-nudging, you will need to generate an observation +input file for each WRF domain. The observation file(s) contain chronological +lists of the 3D positions and values of each observation, in a specific format. +It is critical that your observations be listed in chronological time order! + +* Liu, Y., A. Bourgeois, T. Warner, S. Swerdlin and J. Hacker, 2005: An + implementation of obs-nudging-based FDDA into WRF for supporting + ATEC test operations. 2005 WRF user workshop. Paper 10.7. + + +How to use the obs-data converter +------------------------------------- +A utility program for converting observation data to the format required by +WRF has been provided (RT_fdda_reformat_obsnud.pl). The converter assumes +that your observation data is in standard LITTLE_R format. + +To convert your data that is in LITTLE_R format: + + RT_fdda_reformat_obsnud.pl yourfilename + +where "yourfilename" is the obs-data in LITTLE_R format. The converter will +produce a file named yourfilename.obsnud, in the format required by the WRF +model. + +Note that during the conversion process: + + 1). P,T,U,V and RH fields are extracted. + + 2). U and V are assumed to be the wind components rotated to + the model map-projection (see 3DVAR and MM5 Little_R). + + 3). SPD, DIR and Td fields are ignored. + + 4). For upper-air data, currently WRF nudging only takes + those data with valid pressure records. For obs with + height levels (e.g. wind profilers data), users need to + calculate or estimate the pressure value. Inaccurate + estimate of pressure will lead to bad data assimilation. + + +Naming your obs-nudge input files +--------------------------------- +After you have converted your obs data file to the proper format for WRF, +you will need to rename it according to the naming convention for the WRF +domain on which the obs-nudging is to be performed. For example, for +observations to be used in Domain 1, use the naming convention OBS_DOMAIN101, +for Domain 2, OBS_DOMAIN201, etc. + +These files must be present in your WRF run directory, along with the usual +WRF input and boundary files. + + + +How to activate obs-nudging +--------------------------- +To activate the observational nudging option in WRF, you will need to set +the obs_nudge_opt flag(s) in the WRF "fdda" namelist. Note that there is +a unique flag for each WRF domain in which you want to activate obs-nudging. +To activate the print statements within the obs-nudging subroutines ERROB, +NUDOB, and IN4DOB, set the respective print flags obs_ipf_errob, +obs_ipf_nudob, and obs_ipf_in4dob to ".true." You can then easily verify that +you have activated observational nudging by observing text in your WRF +"standard out" that tell you how many obs stations are being processed at +given model timesteps. This information will look something like: + +0****** CALL IN4DOB AT KTAU = 8 AND XTIME = 24.00: NSTA = 11040 ****** +++++++CALL ERROB AT KTAU = 8 AND INEST = 1: NSTA = 11040 ++++++ + +These lines will print out for each nest in which you have activated nudging, +while nudging is active on that domain. + +Below is an example of a namelist set up to activate obs-nudging on domains +1, 2, and 3: + + &fdda + obs_nudge_opt = 1,1,1,0,0 + max_obs = 150000, + fdda_start = 0., 0., 0., 0., 0. + fdda_end = 99999., 99999., 99999., 99999., 99999. + obs_nudge_wind = 1,1,1,1,1 + obs_coef_wind = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_temp = 1,1,1,1,1 + obs_coef_temp = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_mois = 1,1,1,1,1 + obs_coef_mois = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_rinxy = 240.,240.,180.,180,180 + obs_rinsig = 0.1, + obs_twindo = 40. + obs_npfi = 10, + obs_ionf = 2, + obs_idynin = 0, + obs_dtramp = 40., + obs_ipf_errob = .true. + obs_ipf_nudob = .true. + obs_ipf_in4dob = .true. + +In addition, add the following in &time_control: + + auxinput11_interval_s = 180, 180, 180, 180, 180, + auxinput11_end_h = 6, 6, 6, 6, 6, diff --git a/wrfv2_fire/test/em_real/landFilenames b/wrfv2_fire/test/em_real/landFilenames new file mode 100644 index 00000000..d8638e40 --- /dev/null +++ b/wrfv2_fire/test/em_real/landFilenames @@ -0,0 +1,27 @@ +landuse 1 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.01km.ts +landuse 2 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.02km.ts +landuse 3 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.03km.ts +landuse 4 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.04km.ts +landuse 5 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.05km.ts +landuse 6 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.06km.ts +landuse 7 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.07km.ts +landuse 8 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.08km.ts +landuse 9 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.09km.ts +landuse 10 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.10km.ts +landuse 20 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.20km.ts +landuse 30 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.30km.ts +landuse 40 /maple2/michalak/RSMAS/SurfaceFiles/glcc.usgs20.40km.ts +topography 01 /maple2/michalak/RSMAS/SurfaceFiles/topo.01km.ts +topography 02 /maple2/michalak/RSMAS/SurfaceFiles/topo.02km.ts +topography 03 /maple2/michalak/RSMAS/SurfaceFiles/topo.03km.ts +topography 04 /maple2/michalak/RSMAS/SurfaceFiles/topo.04km.ts +topography 05 /maple2/michalak/RSMAS/SurfaceFiles/topo.05km.ts +topography 06 /maple2/michalak/RSMAS/SurfaceFiles/topo.06km.ts +topography 07 /maple2/michalak/RSMAS/SurfaceFiles/topo.07km.ts +topography 08 /maple2/michalak/RSMAS/SurfaceFiles/topo.08km.ts +topography 09 /maple2/michalak/RSMAS/SurfaceFiles/topo.09km.ts +topography 10 /maple2/michalak/RSMAS/SurfaceFiles/topo.10km.ts +topography 20 /maple2/michalak/RSMAS/SurfaceFiles/topo.20km.ts +topography 30 /maple2/michalak/RSMAS/SurfaceFiles/topo.30km.ts +topography 40 /maple2/michalak/RSMAS/SurfaceFiles/topo.40km.ts +bathymetry 10 /maple2/michalak/RSMAS/SurfaceFiles/tbase.ts diff --git a/wrfv2_fire/test/em_real/namelist.input b/wrfv2_fire/test/em_real/namelist.input new file mode 100755 index 00000000..5da8ad67 --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input @@ -0,0 +1,114 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + / + + &dynamics + w_damping = 0, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + base_temp = 290. + damp_opt = 0, + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.chem b/wrfv2_fire/test/em_real/namelist.input.chem new file mode 100644 index 00000000..3d8cb28c --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.chem @@ -0,0 +1,166 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2006, 2999, 2999, + start_month = 04, 06, 06, + start_day = 06, 11, 11, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2006, 2999, 2999, + end_month = 04, 06, 06, + end_day = 07, 12, 12, + end_hour = 00, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 10800 + input_from_file = .true.,.false.,.false., + history_interval = 30, 60, 60, + frames_per_outfile = 19992, 1000, 1000, + restart = .false., + restart_interval = 5000, + auxinput5_interval_m = 0, 60, 60 + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + io_form_auxinput4 = 0 + io_form_auxinput5 = 0 + auxinput1_inname = "wrf_real_input_em.d." + debug_level = 00 + / + + &domains + time_step = 240, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 40, 112, 94, + s_sn = 1, 1, 1, + e_sn = 40, 97, 91, + s_vert = 1, 1, 1, + e_vert = 20, 28, 28, + dx = 60000, 3333, 1111, + dy = 60000, 3333, 1111, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 30, 30, + j_parent_start = 0, 20, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 2, 2, 2, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 2, 1, 1, + radt = 30, 10, 10, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 2, 2, 2, + bl_pbl_physics = 1, 1, 1, + bldt = 1, 0, 0, + cu_physics = 3, 1, 0, + cudt = 1, 5, 5, + isfflx = 1, + ifsnow = 1, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 4, + ucmcall = 0, + mp_zero_out = 2, + mp_zero_out_thresh = 1.e-8, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + cu_rad_feedback = .false., + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + w_damping = 1, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + base_temp = 290. + damp_opt = 0, + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + non_hydrostatic = .true., .true., .true., + time_step_sound = 4, 4, 4, + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &chem + kemit = 19, + chem_opt = 2, + bioemdt = 30, + photdt = 30, + chemdt = 1., + frames_per_emissfile = 36 + io_style_emissions = 1 + emiss_inpt_opt = 1, + chem_in_opt = 0, + phot_opt = 1, + drydep_opt = 1, + bio_emiss_opt = 1, + gas_bc_opt = 1, + gas_ic_opt = 1, + aer_bc_opt = 1, + aer_ic_opt = 1, + gaschem_onoff = 1, + aerchem_onoff = 1, + wetscav_onoff = 0, + cldchem_onoff = 0, + vertmix_onoff = 1, + chem_conv_tr = 1, + aer_ra_feedback = 0, + have_bcs_chem = .false., + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.grid_fdda b/wrfv2_fire/test/em_real/namelist.input.grid_fdda new file mode 100755 index 00000000..e33b7e2b --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.grid_fdda @@ -0,0 +1,133 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + grid_fdda = 1, 1, 1, + gfdda_inname = "wrffdda_d", + gfdda_end_h = 24, 24, 24, + gfdda_interval_m = 360, 360, 360, + fgdt = 0, 0, 0, + if_no_pbl_nudging_uv = 0, 0, 1, + if_no_pbl_nudging_t = 0, 0, 1, + if_no_pbl_nudging_q = 0, 0, 1, + if_zfac_uv = 0, 0, 1, + k_zfac_uv = 10, 10, 1, + if_zfac_t = 0, 0, 1, + k_zfac_t = 10, 10, 1, + if_zfac_q = 0, 0, 1, + k_zfac_q = 10, 10, 1, + guv = 0.0003, 0.0003, 0.0003, + gt = 0.0003, 0.0003, 0.0003, + gq = 0.0003, 0.0003, 0.0003, + if_ramping = 1, + dtramp_min = 60.0, + io_form_gfdda = 2, + / + + &dynamics + w_damping = 0, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.jan00 b/wrfv2_fire/test/em_real/namelist.input.jan00 new file mode 100755 index 00000000..ab1205fc --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.jan00 @@ -0,0 +1,134 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + w_damping = 0, + diff_opt = 1, + km_opt = 4, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.jun01 b/wrfv2_fire/test/em_real/namelist.input.jun01 new file mode 100755 index 00000000..e2cc60b9 --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.jun01 @@ -0,0 +1,134 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2001, 2001, 2001, + start_month = 06, 06, 06, + start_day = 11, 11, 11, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2001, 2001, 2001, + end_month = 06, 06, 06, + end_day = 12, 12, 12, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 10800 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 60, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 91, 112, 94, + s_sn = 1, 1, 1, + e_sn = 82, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 10000, 3333, 1111, + dy = 10000, 3333, 1111, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 30, 30, + j_parent_start = 0, 20, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 2, 2, 2, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 10, 10, 10, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 2, 2, 2, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 4, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + w_damping = 0, + diff_opt = 1, + km_opt = 4, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + time_step_sound = 4, 4, 4, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + periodic_x = .false.,.false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .false.,.false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.obs_fdda b/wrfv2_fire/test/em_real/namelist.input.obs_fdda new file mode 100755 index 00000000..93f78f86 --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.obs_fdda @@ -0,0 +1,134 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + auxinput11_interval_s = 180 , 180 , 180 + auxinput11_end_h = 6 , 6 , 6 + debug_level = 0 + / + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + obs_nudge_opt = 1,1,1,1,1 + max_obs = 150000, + obs_nudge_wind = 1,1,1,1,1 + obs_coef_wind = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_temp = 1,1,1,1,1 + obs_coef_temp = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_mois = 1,1,1,1,1 + obs_coef_mois = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_rinxy = 240.,240.,180.,180,180 + obs_rinsig = 0.1, + obs_twindo = 0.6666667, + obs_npfi = 10, + obs_ionf = 2, + obs_idynin = 0, + obs_dtramp = 40., + obs_ipf_errob = .true. + obs_ipf_nudob = .true. + obs_ipf_in4dob = .true. + / + + &dynamics + w_damping = 0, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.si b/wrfv2_fire/test/em_real/namelist.input.si new file mode 100755 index 00000000..8a633698 --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.si @@ -0,0 +1,116 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + auxinput1_inname = "wrf_real_input_em.d." + / + auxinput1_inname = "met_em.d." + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + / + + &dynamics + w_damping = 0, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/namelist.input.wps b/wrfv2_fire/test/em_real/namelist.input.wps new file mode 100755 index 00000000..49caf5b9 --- /dev/null +++ b/wrfv2_fire/test/em_real/namelist.input.wps @@ -0,0 +1,137 @@ + &time_control + run_days = 0, + run_hours = 12, + run_minutes = 0, + run_seconds = 0, + start_year = 2000, 2000, 2000, + start_month = 01, 01, 01, + start_day = 24, 24, 24, + start_hour = 12, 12, 12, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2000, 2000, 2000, + end_month = 01, 01, 01, + end_day = 25, 25, 25, + end_hour = 12, 12, 12, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + interval_seconds = 21600 + input_from_file = .true.,.false.,.false., + history_interval = 180, 60, 60, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval = 5000, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + auxinput1_inname = "met_em.d." + / + auxinput1_inname = "wrf_real_input_em.d." + + &domains + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 112, 94, + s_sn = 1, 1, 1, + e_sn = 61, 97, 91, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + num_metgrid_levels = 27 + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + / + p_top_requested = 5000 + interp_type = 1 + lowest_lev_from_sfc = .false. + lagrange_order = 1 + force_sfc_in_vinterp = 1 + zap_close_levels = 500 + sfcp_to_sfcp = .false. + adjust_heights = .false. + eta_levels = 1.000, 0.990, 0.978, 0.964, 0.946, + 0.922, 0.894, 0.860, 0.817, 0.766, + 0.707, 0.644, 0.576, 0.507, 0.444, + 0.380, 0.324, 0.273, 0.228, 0.188, + 0.152, 0.121, 0.093, 0.069, 0.048, + 0.029, 0.014, 0.000, + eta_levels = 1.000, 0.993, 0.983, 0.970, 0.954, + 0.934, 0.909, 0.880, 0.845, 0.807, + 0.765, 0.719, 0.672, 0.622, 0.571, + 0.520, 0.468, 0.420, 0.376, 0.335, + 0.298, 0.263, 0.231, 0.202, 0.175, + 0.150, 0.127, 0.106, 0.088, 0.070, + 0.055, 0.040, 0.026, 0.013, 0.000 + + &physics + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + ucmcall = 0, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + / + + &fdda + / + + &dynamics + w_damping = 0, + diff_opt = 1, + km_opt = 4, + diff_6th_opt = 0, + diff_6th_factor = 0.12, + damp_opt = 0, + base_temp = 290. + zdamp = 5000., 5000., 5000., + dampcoef = 0.01, 0.01, 0.01 + khdif = 0, 0, 0, + kvdif = 0, 0, 0, + non_hydrostatic = .true., .true., .true., + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + / + + &bdy_control + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + specified = .true., .false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/run_1way.tar b/wrfv2_fire/test/em_real/run_1way.tar new file mode 100644 index 00000000..3109ba1a Binary files /dev/null and b/wrfv2_fire/test/em_real/run_1way.tar differ diff --git a/wrfv2_fire/test/em_real/run_2way.tar b/wrfv2_fire/test/em_real/run_2way.tar new file mode 100644 index 00000000..f031fab1 Binary files /dev/null and b/wrfv2_fire/test/em_real/run_2way.tar differ diff --git a/wrfv2_fire/test/em_real/run_restart.tar b/wrfv2_fire/test/em_real/run_restart.tar new file mode 100644 index 00000000..3b98be34 Binary files /dev/null and b/wrfv2_fire/test/em_real/run_restart.tar differ diff --git a/wrfv2_fire/test/em_squall2d_x/input_sounding b/wrfv2_fire/test/em_squall2d_x/input_sounding new file mode 100644 index 00000000..7551b0db --- /dev/null +++ b/wrfv2_fire/test/em_squall2d_x/input_sounding @@ -0,0 +1,81 @@ + 1000.0 300.5000 14.00000 + 125.0000 300.5000 14.00000 -11.40000 0.0000000E+00 + 375.0000 300.5650 14.00000 -10.20000 0.0000000E+00 + 625.0000 301.0699 14.00000 -9.000000 0.0000000E+00 + 875.0000 301.6293 14.00000 -7.800000 0.0000000E+00 + 1125.000 302.2307 14.00000 -6.600000 0.0000000E+00 + 1375.000 302.8666 13.11911 -5.400000 0.0000000E+00 + 1625.000 303.5323 11.87561 -4.200000 0.0000000E+00 + 1875.000 304.2242 10.74200 -3.000000 0.0000000E+00 + 2125.000 304.9395 9.707900 -1.800000 0.0000000E+00 + 2375.000 305.6764 8.764307 -0.6000004 0.0000000E+00 + 2625.000 306.4329 7.903318 0.0000000E+00 0.0000000E+00 + 2875.000 307.2076 7.117891 0.0000000E+00 0.0000000E+00 + 3125.000 307.9994 6.401778 0.0000000E+00 0.0000000E+00 + 3375.000 308.8071 5.749294 0.0000000E+00 0.0000000E+00 + 3625.000 309.6300 5.155267 0.0000000E+00 0.0000000E+00 + 3875.000 310.4672 4.614990 0.0000000E+00 0.0000000E+00 + 4125.000 311.3181 4.124146 0.0000000E+00 0.0000000E+00 + 4375.000 312.1819 3.678759 0.0000000E+00 0.0000000E+00 + 4625.000 313.0581 3.275154 0.0000000E+00 0.0000000E+00 + 4875.000 313.9464 2.909960 0.0000000E+00 0.0000000E+00 + 5125.000 314.8460 2.580028 0.0000000E+00 0.0000000E+00 + 5375.000 315.7567 2.282451 0.0000000E+00 0.0000000E+00 + 5625.000 316.6780 2.014546 0.0000000E+00 0.0000000E+00 + 5875.000 317.6097 1.773806 0.0000000E+00 0.0000000E+00 + 6125.000 318.5513 1.557917 0.0000000E+00 0.0000000E+00 + 6375.000 319.5026 1.364712 0.0000000E+00 0.0000000E+00 + 6625.000 320.4632 1.192196 0.0000000E+00 0.0000000E+00 + 6875.000 321.4330 1.038515 0.0000000E+00 0.0000000E+00 + 7125.000 322.4116 0.9019489 0.0000000E+00 0.0000000E+00 + 7375.000 323.3988 0.7808990 0.0000000E+00 0.0000000E+00 + 7625.000 324.3945 0.6738972 0.0000000E+00 0.0000000E+00 + 7875.000 325.3983 0.5795774 0.0000000E+00 0.0000000E+00 + 8125.000 326.4102 0.4966844 0.0000000E+00 0.0000000E+00 + 8375.000 327.4298 0.4240607 0.0000000E+00 0.0000000E+00 + 8625.000 328.4571 0.3606393 0.0000000E+00 0.0000000E+00 + 8875.000 329.4919 0.3054438 0.0000000E+00 0.0000000E+00 + 9125.000 330.5339 0.2575793 0.0000000E+00 0.0000000E+00 + 9375.000 331.5832 0.2162281 0.0000000E+00 0.0000000E+00 + 9625.000 332.6394 0.1806441 0.0000000E+00 0.0000000E+00 + 9875.000 333.7025 0.1501510 0.0000000E+00 0.0000000E+00 + 10125.00 334.7725 0.1241341 0.0000000E+00 0.0000000E+00 + 10375.00 335.8490 0.1020380 0.0000000E+00 0.0000000E+00 + 10625.00 336.9320 8.3363235E-02 0.0000000E+00 0.0000000E+00 + 10875.00 338.0214 6.7661338E-02 0.0000000E+00 0.0000000E+00 + 11125.00 339.1171 5.4530919E-02 0.0000000E+00 0.0000000E+00 + 11375.00 340.2190 4.3614354E-02 0.0000000E+00 0.0000000E+00 + 11625.00 341.3269 3.4594502E-02 0.0000000E+00 0.0000000E+00 + 11875.00 342.4408 2.7190926E-02 0.0000000E+00 0.0000000E+00 + 12125.00 344.9724 2.4574272E-02 0.0000000E+00 0.0000000E+00 + 12375.00 348.9513 2.5715416E-02 0.0000000E+00 0.0000000E+00 + 12625.00 352.9761 2.6911106E-02 0.0000000E+00 0.0000000E+00 + 12875.00 357.0473 2.8164061E-02 0.0000000E+00 0.0000000E+00 + 13125.00 361.1655 2.9477064E-02 0.0000000E+00 0.0000000E+00 + 13375.00 365.3311 3.0853137E-02 0.0000000E+00 0.0000000E+00 + 13625.00 369.5448 3.2295462E-02 0.0000000E+00 0.0000000E+00 + 13875.00 373.8072 3.3807345E-02 0.0000000E+00 0.0000000E+00 + 14125.00 378.1187 3.5392068E-02 0.0000000E+00 0.0000000E+00 + 14375.00 382.4798 3.7053265E-02 0.0000000E+00 0.0000000E+00 + 14625.00 386.8913 3.8795106E-02 0.0000000E+00 0.0000000E+00 + 14875.00 391.3537 4.0621303E-02 0.0000000E+00 0.0000000E+00 + 15125.00 395.8676 4.2536203E-02 0.0000000E+00 0.0000000E+00 + 15375.00 400.4335 4.4544484E-02 0.0000000E+00 0.0000000E+00 + 15625.00 405.0521 4.6650380E-02 0.0000000E+00 0.0000000E+00 + 15875.00 409.7239 4.8859127E-02 0.0000000E+00 0.0000000E+00 + 16125.00 414.4497 5.1176008E-02 0.0000000E+00 0.0000000E+00 + 16375.00 419.2299 5.3606406E-02 0.0000000E+00 0.0000000E+00 + 16625.00 424.0653 5.6155890E-02 0.0000000E+00 0.0000000E+00 + 16875.00 428.9565 5.8831204E-02 0.0000000E+00 0.0000000E+00 + 17125.00 433.9040 6.1637800E-02 0.0000000E+00 0.0000000E+00 + 17375.00 438.9086 6.4582929E-02 0.0000000E+00 0.0000000E+00 + 17625.00 443.9710 6.7673884E-02 0.0000000E+00 0.0000000E+00 + 17875.00 449.0917 7.0917897E-02 0.0000000E+00 0.0000000E+00 + 18125.00 454.2715 7.4322589E-02 0.0000000E+00 0.0000000E+00 + 18375.00 459.5110 7.7896632E-02 0.0000000E+00 0.0000000E+00 + 18625.00 464.8110 8.1648715E-02 0.0000000E+00 0.0000000E+00 + 18875.00 470.1721 8.5588045E-02 0.0000000E+00 0.0000000E+00 + 19125.00 475.5951 8.9724302E-02 0.0000000E+00 0.0000000E+00 + 19375.00 481.0806 9.4000000E-02 0.0000000E+00 0.0000000E+00 + 19625.00 486.6293 9.4000000E-02 0.0000000E+00 0.0000000E+00 + 19875.00 492.2421 9.4000000E-02 0.0000000E+00 0.0000000E+00 diff --git a/wrfv2_fire/test/em_squall2d_x/namelist.input b/wrfv2_fire/test/em_squall2d_x/namelist.input new file mode 100644 index 00000000..1309a7e2 --- /dev/null +++ b/wrfv2_fire/test/em_squall2d_x/namelist.input @@ -0,0 +1,107 @@ + &time_control + run_days = 0, + run_hours = 1, + run_minutes = 0, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 01, + end_minute = 00, + end_second = 00, + history_interval = 10, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 60, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 3, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 202, + s_sn = 1, + e_sn = 3, + s_vert = 1, + e_vert = 81, + dx = 250, + dy = 250, + ztop = 20000., + / + + &physics + mp_physics = 2, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 0, + ifsnow = 0, + icloud = 0, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 2, + damp_opt = 2, + dampcoef = .003, + zdamp = 5000., + khdif = 300, + kvdif = 1, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + mix_full_fields = .true., + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .false., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .true., + open_xe = .true., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_squall2d_y/input_sounding b/wrfv2_fire/test/em_squall2d_y/input_sounding new file mode 100644 index 00000000..c6acfe9b --- /dev/null +++ b/wrfv2_fire/test/em_squall2d_y/input_sounding @@ -0,0 +1,81 @@ + 1000.0 300.5000 14.00000 + 125.0000 300.5000 14.00000 0.0 -11.40000 + 375.0000 300.5650 14.00000 0.0 -10.20000 + 625.0000 301.0699 14.00000 0.0 -9.000000 + 875.0000 301.6293 14.00000 0.0 -7.800000 + 1125.000 302.2307 14.00000 0.0 -6.600000 + 1375.000 302.8666 13.11911 0.0 -5.400000 + 1625.000 303.5323 11.87561 0.0 -4.200000 + 1875.000 304.2242 10.74200 0.0 -3.000000 + 2125.000 304.9395 9.707900 0.0 -1.800000 + 2375.000 305.6764 8.764307 0.0 -0.6000004 + 2625.000 306.4329 7.903318 0.0000000E+00 0.0000000E+00 + 2875.000 307.2076 7.117891 0.0000000E+00 0.0000000E+00 + 3125.000 307.9994 6.401778 0.0000000E+00 0.0000000E+00 + 3375.000 308.8071 5.749294 0.0000000E+00 0.0000000E+00 + 3625.000 309.6300 5.155267 0.0000000E+00 0.0000000E+00 + 3875.000 310.4672 4.614990 0.0000000E+00 0.0000000E+00 + 4125.000 311.3181 4.124146 0.0000000E+00 0.0000000E+00 + 4375.000 312.1819 3.678759 0.0000000E+00 0.0000000E+00 + 4625.000 313.0581 3.275154 0.0000000E+00 0.0000000E+00 + 4875.000 313.9464 2.909960 0.0000000E+00 0.0000000E+00 + 5125.000 314.8460 2.580028 0.0000000E+00 0.0000000E+00 + 5375.000 315.7567 2.282451 0.0000000E+00 0.0000000E+00 + 5625.000 316.6780 2.014546 0.0000000E+00 0.0000000E+00 + 5875.000 317.6097 1.773806 0.0000000E+00 0.0000000E+00 + 6125.000 318.5513 1.557917 0.0000000E+00 0.0000000E+00 + 6375.000 319.5026 1.364712 0.0000000E+00 0.0000000E+00 + 6625.000 320.4632 1.192196 0.0000000E+00 0.0000000E+00 + 6875.000 321.4330 1.038515 0.0000000E+00 0.0000000E+00 + 7125.000 322.4116 0.9019489 0.0000000E+00 0.0000000E+00 + 7375.000 323.3988 0.7808990 0.0000000E+00 0.0000000E+00 + 7625.000 324.3945 0.6738972 0.0000000E+00 0.0000000E+00 + 7875.000 325.3983 0.5795774 0.0000000E+00 0.0000000E+00 + 8125.000 326.4102 0.4966844 0.0000000E+00 0.0000000E+00 + 8375.000 327.4298 0.4240607 0.0000000E+00 0.0000000E+00 + 8625.000 328.4571 0.3606393 0.0000000E+00 0.0000000E+00 + 8875.000 329.4919 0.3054438 0.0000000E+00 0.0000000E+00 + 9125.000 330.5339 0.2575793 0.0000000E+00 0.0000000E+00 + 9375.000 331.5832 0.2162281 0.0000000E+00 0.0000000E+00 + 9625.000 332.6394 0.1806441 0.0000000E+00 0.0000000E+00 + 9875.000 333.7025 0.1501510 0.0000000E+00 0.0000000E+00 + 10125.00 334.7725 0.1241341 0.0000000E+00 0.0000000E+00 + 10375.00 335.8490 0.1020380 0.0000000E+00 0.0000000E+00 + 10625.00 336.9320 8.3363235E-02 0.0000000E+00 0.0000000E+00 + 10875.00 338.0214 6.7661338E-02 0.0000000E+00 0.0000000E+00 + 11125.00 339.1171 5.4530919E-02 0.0000000E+00 0.0000000E+00 + 11375.00 340.2190 4.3614354E-02 0.0000000E+00 0.0000000E+00 + 11625.00 341.3269 3.4594502E-02 0.0000000E+00 0.0000000E+00 + 11875.00 342.4408 2.7190926E-02 0.0000000E+00 0.0000000E+00 + 12125.00 344.9724 2.4574272E-02 0.0000000E+00 0.0000000E+00 + 12375.00 348.9513 2.5715416E-02 0.0000000E+00 0.0000000E+00 + 12625.00 352.9761 2.6911106E-02 0.0000000E+00 0.0000000E+00 + 12875.00 357.0473 2.8164061E-02 0.0000000E+00 0.0000000E+00 + 13125.00 361.1655 2.9477064E-02 0.0000000E+00 0.0000000E+00 + 13375.00 365.3311 3.0853137E-02 0.0000000E+00 0.0000000E+00 + 13625.00 369.5448 3.2295462E-02 0.0000000E+00 0.0000000E+00 + 13875.00 373.8072 3.3807345E-02 0.0000000E+00 0.0000000E+00 + 14125.00 378.1187 3.5392068E-02 0.0000000E+00 0.0000000E+00 + 14375.00 382.4798 3.7053265E-02 0.0000000E+00 0.0000000E+00 + 14625.00 386.8913 3.8795106E-02 0.0000000E+00 0.0000000E+00 + 14875.00 391.3537 4.0621303E-02 0.0000000E+00 0.0000000E+00 + 15125.00 395.8676 4.2536203E-02 0.0000000E+00 0.0000000E+00 + 15375.00 400.4335 4.4544484E-02 0.0000000E+00 0.0000000E+00 + 15625.00 405.0521 4.6650380E-02 0.0000000E+00 0.0000000E+00 + 15875.00 409.7239 4.8859127E-02 0.0000000E+00 0.0000000E+00 + 16125.00 414.4497 5.1176008E-02 0.0000000E+00 0.0000000E+00 + 16375.00 419.2299 5.3606406E-02 0.0000000E+00 0.0000000E+00 + 16625.00 424.0653 5.6155890E-02 0.0000000E+00 0.0000000E+00 + 16875.00 428.9565 5.8831204E-02 0.0000000E+00 0.0000000E+00 + 17125.00 433.9040 6.1637800E-02 0.0000000E+00 0.0000000E+00 + 17375.00 438.9086 6.4582929E-02 0.0000000E+00 0.0000000E+00 + 17625.00 443.9710 6.7673884E-02 0.0000000E+00 0.0000000E+00 + 17875.00 449.0917 7.0917897E-02 0.0000000E+00 0.0000000E+00 + 18125.00 454.2715 7.4322589E-02 0.0000000E+00 0.0000000E+00 + 18375.00 459.5110 7.7896632E-02 0.0000000E+00 0.0000000E+00 + 18625.00 464.8110 8.1648715E-02 0.0000000E+00 0.0000000E+00 + 18875.00 470.1721 8.5588045E-02 0.0000000E+00 0.0000000E+00 + 19125.00 475.5951 8.9724302E-02 0.0000000E+00 0.0000000E+00 + 19375.00 481.0806 9.4000000E-02 0.0000000E+00 0.0000000E+00 + 19625.00 486.6293 9.4000000E-02 0.0000000E+00 0.0000000E+00 + 19875.00 492.2421 9.4000000E-02 0.0000000E+00 0.0000000E+00 diff --git a/wrfv2_fire/test/em_squall2d_y/namelist.input b/wrfv2_fire/test/em_squall2d_y/namelist.input new file mode 100644 index 00000000..1db1ed32 --- /dev/null +++ b/wrfv2_fire/test/em_squall2d_y/namelist.input @@ -0,0 +1,107 @@ + &time_control + run_days = 0, + run_hours = 1, + run_minutes = 0, + run_seconds = 0, + start_year = 0001, + start_month = 01, + start_day = 01, + start_hour = 00, + start_minute = 00, + start_second = 00, + end_year = 0001, + end_month = 01, + end_day = 01, + end_hour = 01, + end_minute = 00, + end_second = 00, + history_interval = 10, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 60, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 3, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 3, + s_sn = 1, + e_sn = 202, + s_vert = 1, + e_vert = 81, + dx = 250, + dy = 250, + ztop = 20000., + / + + &physics + mp_physics = 2, + ra_lw_physics = 0, + ra_sw_physics = 0, + radt = 0, + sf_sfclay_physics = 0, + sf_surface_physics = 0, + bl_pbl_physics = 0, + bldt = 0, + cu_physics = 0, + cudt = 0, + isfflx = 0, + ifsnow = 0, + icloud = 0, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + dyn_opt = 2, + rk_ord = 3, + diff_opt = 2, + km_opt = 2, + damp_opt = 2, + dampcoef = .003, + zdamp = 5000., + khdif = 300, + kvdif = 1, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + mix_full_fields = .true., + non_hydrostatic = .true., + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .false., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .true., + open_ye = .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/exp_real/namelist.input b/wrfv2_fire/test/exp_real/namelist.input new file mode 100755 index 00000000..5182ef65 --- /dev/null +++ b/wrfv2_fire/test/exp_real/namelist.input @@ -0,0 +1,116 @@ + &namelist_01 + time_step = 450, + time_step_fract_num = 0, + time_step_fract_den = 1, + restart = .false., + max_dom = 1, + dyn_opt = 4, + rk_ord = 3, + diff_opt = 0, + km_opt = 1, + damp_opt = 0, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + spec_bdy_width = 5, + spec_zone = 1, + relax_zone = 4, + tile_sz_x = 0, + tile_sz_y = 0, + numtiles = 1, + debug_level = 0 / + + &namelist_02 + run_days = 0, + run_hours = 2, + run_minutes = 0, + run_seconds = 0, + start_year = 1993 + start_month = 03 + start_day = 13 + start_hour = 00 + start_minute = 00, + start_second = 00, + end_year = 1993 + end_month = 03 + end_day = 13 + end_hour = 12 + end_minute = 00, + end_second = 00, + interval_seconds = 21600 + grid_id = 1, + s_we = 1, + e_we = 41, + s_sn = 1, + e_sn = 35, + s_vert = 1, + e_vert = 28, + history_interval = 5, + restart_interval = 244, + frames_per_outfile = 1, + time_step_sound = 4 / + + + &namelist_03 + dx = 90000, + dy = 90000, + ztop = 17558.2 + zdamp = 5000., + dampcoef = 0.01, + non_hydrostatic = .true., + smdiv = 0.1, + emdiv = 0.01, + epssm = .1, + khdif = 0, + kvdif = 0, + mix_cr_len = 200., + radt = 30, + bldt = 0, + cudt = 5, + julyr = 0, + julday = 1, + gmt = 0. / + + &namelist_04 + periodic_x = .false., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .true., + open_xe = .true., + periodic_y = .false., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .true., + open_ye = .true., + nested = .false., + specified = .false., + top_radiation = .false., + chem_opt = 0, + mp_physics = 3, + ra_lw_physics = 1, + ra_sw_physics = 1, + sf_sfclay_physics = 1, + sf_surface_physics = 1, + bl_pbl_physics = 1, + cu_physics = 1, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + io_form_history = 2, + io_form_restart = 2, + io_form_input = 2, + io_form_boundary = 2 / + + &namelist_05 + real_data_init_type = 1 / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / + diff --git a/wrfv2_fire/test/nmm_real/namelist.input b/wrfv2_fire/test/nmm_real/namelist.input new file mode 100644 index 00000000..ba5c920a --- /dev/null +++ b/wrfv2_fire/test/nmm_real/namelist.input @@ -0,0 +1,104 @@ + &time_control + run_days = 1, + run_hours = 0, + run_minutes = 0, + run_seconds = 0, + start_year = 2005, + start_month = 01, + start_day = 23, + start_hour = 00, + start_minute = 00, + start_second = 00, + tstart = 00, + end_year = 2005, + end_month = 01, + end_day = 24, + end_hour = 00, + end_minute = 00, + end_second = 00, + interval_seconds = 10800, + history_interval = 60 + frames_per_outfile = 1, + restart = .false., + restart_interval = 6000, + io_form_input = 2 + io_form_history = 2 + io_form_restart = 2 + io_form_boundary = 2 + io_form_auxinput1 = 2 + auxinput1_inname = "met_nmm.d." + debug_level = 1 + / + + &fdda +/ + + &domains + time_step = 34, + time_step_fract_num = 2, + time_step_fract_den = 7, + max_dom = 1, + s_we = 1, + e_we = 56, + s_sn = 1, + e_sn = 92, + s_vert = 1, + e_vert = 38, + num_metgrid_levels = 40, + dx = .096, + dy = .095, + grid_id = 1, + p_top_requested = 5000. + ptsgm = 42000., + eta_levels = 1.000, 0.994, 0.983, 0.968, 0.950, 0.930, 0.908, 0.882, 0.853, 0.821, + 0.788, 0.752, 0.715, 0.677, 0.637, 0.597, 0.557, 0.517, 0.477, + 0.438, 0.401, 0.365, 0.332, 0.302, 0.274, 0.248, 0.224, 0.201, + 0.179, 0.158, 0.138, 0.118, 0.098, 0.078, 0.058, 0.038, 0.018, 0.000 + tile_sz_x = 0, + tile_sz_y = 0, + numtiles = 1 +/ + &physics + mp_physics = 5, + ra_lw_physics = 99, + ra_sw_physics = 99, + nrads = 105, + nradl = 105, + co2tf = 1, + sf_sfclay_physics = 2, + sf_surface_physics = 99, + bl_pbl_physics = 2, + nphs = 6, + cu_physics = 2, + ncnvc = 6, + tprec = 3, + theat = 6, + tclod = 6, + trdsw = 6, + trdlw = 6, + tsrfc = 6, + pcpflg = .false., + isfflx = 0, + ifsnow = 0, + icloud = 0, + num_soil_layers = 4, + mp_zero_out = 0 + / + + &dynamics + dyn_opt = 4 + / + + &bdy_control + spec_bdy_width = 1, + specified = .true., + nested = .false. + / + + &grib2 +/ + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1 + / diff --git a/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm b/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm new file mode 100644 index 00000000..f9763c5a --- /dev/null +++ b/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm @@ -0,0 +1,134 @@ + &time_control + run_days = 1, + run_hours = 0, + run_minutes = 0, + run_seconds = 0, + start_year = 2005, + start_month = 01, + start_day = 23, + start_hour = 00, + start_minute = 00, + start_second = 00, + tstart = 00, + end_year = 2005, + end_month = 01, + end_day = 24, + end_hour = 00, + end_minute = 00, + end_second = 00, + interval_seconds = 10800, + history_interval = 60 + frames_per_outfile = 1, + restart = .false., + restart_interval = 6000, + io_form_input = 2 + io_form_history = 2 + io_form_restart = 2 + io_form_boundary = 2 + io_form_auxinput1 = 2 + auxinput1_inname = "met_nmm.d." + debug_level = 1 + / + + &fdda +/ + + &domains + time_step = 30, + time_step_fract_num = 2, + time_step_fract_den = 7, + max_dom = 1, + s_we = 1, + e_we = 56, + s_sn = 1, + e_sn = 92, + s_vert = 1, + e_vert = 38, + num_metgrid_levels = 40, + dx = .096, + dy = .095, + grid_id = 1, + p_top_requested = 5000. + ptsgm = 42000., + eta_levels = 1.000, 0.994, 0.983, 0.968, 0.950, 0.930, 0.908, 0.882, 0.853, 0.821, + 0.788, 0.752, 0.715, 0.677, 0.637, 0.597, 0.557, 0.517, 0.477, + 0.438, 0.401, 0.365, 0.332, 0.302, 0.274, 0.248, 0.224, 0.201, + 0.179, 0.158, 0.138, 0.118, 0.098, 0.078, 0.058, 0.038, 0.018, 0.000 + tile_sz_x = 0, + tile_sz_y = 0, + numtiles = 1 +/ + &physics + mp_physics = 5, + ra_lw_physics = 99, + ra_sw_physics = 99, + nrads = 105, + nradl = 105, + co2tf = 1, + sf_sfclay_physics = 2, + sf_surface_physics = 99, + bl_pbl_physics = 2, + nphs = 6, + cu_physics = 2, + ncnvc = 6, + tprec = 3, + theat = 6, + tclod = 6, + trdsw = 6, + trdlw = 6, + tsrfc = 6, + pcpflg = .false., + isfflx = 0, + ifsnow = 0, + icloud = 0, + num_soil_layers = 4, + mp_zero_out = 0 + cu_rad_feedback = .false., + / + + &dynamics + dyn_opt = 4 + / + + &bdy_control + spec_bdy_width = 1, + specified = .true., + nested = .false. + / + + &grib2 +/ + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1 + / + + &chem + kemit = 10, + chem_opt = 2, + bioemdt = 30, + photdt = 30, + chemdt = 0.5, + frames_per_emissfile = 12 + io_style_emissions = 1 + emiss_inpt_opt = 1, + chem_in_opt = 0, + phot_opt = 1, + drydep_opt = 1, + bio_emiss_opt = 1, + gas_bc_opt = 1, + gas_ic_opt = 1, + aer_bc_opt = 1, + aer_ic_opt = 1, + gaschem_onoff = 1, + aerchem_onoff = 1, + aer_ra_feedback = 0, + wetscav_onoff = 0, + cldchem_onoff = 0, + vertmix_onoff = 1, + chem_conv_tr = 1, + aer_ra_feedback = 0, + have_bcs_chem = .false., + / + diff --git a/wrfv2_fire/test/nmm_real/tomorrow b/wrfv2_fire/test/nmm_real/tomorrow new file mode 100755 index 00000000..552acb36 --- /dev/null +++ b/wrfv2_fire/test/nmm_real/tomorrow @@ -0,0 +1,121 @@ +#!/bin/ksh -f + +yy=`expr $1 / 10000` +mm=`expr $1 - $yy * 10000` +mm=`expr $mm / 100` +dd=`expr $1 % 100` + + +yy=`expr $yy + 0` +mm=`expr $mm + 0` +dd=`expr $dd + 0` + +if [ $yy -lt 10 ] ; then +yy=0$yy +fi + +if [ $mm -lt 10 ] ; then +mm=0$mm +fi + +if [ $dd -lt 10 ] ; then +dd=0$dd +fi + +# exit + +if [ $mm -eq 1 -or $mm -eq 01 ] +then +mxd=31 +fi + +if [ $mm -eq 2 -o $mm -eq 02 ] +then + leap=`expr $yy % 4` + if [ $leap -eq 0 ] + then + mxd=29 + fi + if [ $leap -ne 0 ] + then + mxd=28 + fi +fi + + +if [ $mm -eq 3 -o $mm -eq 03 ] ; then +mxd=31 +fi + +if [ $mm -eq 4 -o $mm -eq 04 ] ; then +mxd=30 +fi + +if [ $mm -eq 5 -o $mm -eq 05 ] ; then +mxd=31 +fi + +if [ $mm -eq 6 -o $mm -eq 06 ] ; then +mxd=30 +fi + +if [ $mm -eq 7 -o $mm -eq 07 ] ; then +mxd=31 +fi + +if [ $mm -eq 8 -o $mm -eq 08 ] ; then +mxd=31 +fi + +if [ $mm -eq 9 -o $mm -eq 09 ] ; then +mxd=30 +fi + +if [ $mm -eq 10 ] ; then +mxd=31 +fi + +if [ $mm -eq 11 ] ; then +mxd=30 +fi + +if [ $mm -eq 12 ] ; then +mxd=31 +fi +# echo "max days in month: " $mxd +dd=`expr $dd + 1` + +# echo "new dd: " $dd + +if [ $dd -gt $mxd ] +then + mm=`expr $mm + 1` + if [ $mm -eq 13 ] + then + yy=`expr $yy + 1` + mm=1 + fi + dd=1 +fi +yy=`expr $yy + 0` +mm=`expr $mm + 0` +dd=`expr $dd + 0` + +if [ $yy -lt 10 ] ; then +yy=0$yy +fi + +if [ $mm -lt 10 ] ; then +mm=0$mm +fi + +if [ $dd -lt 10 ] ; then +dd=0$dd +fi + +# echo "now have yy mm dd: " $yy $mm $dd + +ymd=${yy}${mm}${dd} + +echo $ymd + diff --git a/wrfv2_fire/tools/CodeBase/Makefile b/wrfv2_fire/tools/CodeBase/Makefile new file mode 100644 index 00000000..a49312d0 --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/Makefile @@ -0,0 +1,25 @@ +CC = cc -g +all : nocontf90 deftab subinfo_calls wrfvar callgraph + +nocontf90 : nocontf90.o util.o + $(CC) -o $@ nocontf90.o util.o + /bin/mv -f $@ .. + +deftab : deftab.o util.o + $(CC) -o $@ deftab.o util.o + /bin/mv -f $@ .. + +subinfo_calls : subinfo_calls.o util.o + $(CC) -o $@ subinfo_calls.o util.o + /bin/mv -f $@ .. + +callgraph : callgraph.o util.o sym.o symtab_gen.o + $(CC) -o $@ callgraph.o util.o sym.o symtab_gen.o + /bin/mv -f $@ .. + +wrfvar : wrfvar.o util.o + $(CC) -o $@ wrfvar.o util.o + /bin/mv -f $@ .. + +clean : + /bin/rm -f *.o deftab nocontf90 callgraph subinfo_calls diff --git a/wrfv2_fire/tools/CodeBase/callgraph.c b/wrfv2_fire/tools/CodeBase/callgraph.c new file mode 100755 index 00000000..28b5b273 --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/callgraph.c @@ -0,0 +1,299 @@ +#include +#include +#include +#include +#include "sym.h" + +#define DBDIR "tools/code_dbase" + +#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) ) +#define COMPARE2(A,B) ( ! strcmp ( A , B ) ) +#define INLINELEN (4*8192) +#define VARLEN 256 +#define MAXRECORDS 8192 + +int recno = 1 ; +char outbuf[MAXRECORDS][VARLEN] ; + +main( int argc , char * argv[] ) +{ + DIR *dir ; + char root[VARLEN] ; + int cut = 99 ; + int nentries ; + int i ; + + if (( dir = opendir ( DBDIR )) == NULL ) { + fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ; + } closedir( dir ) ; + if ( argc < 2 ) { + fprintf(stderr,"usage: callgraph root\n") ; + } + sym_init() ; + strcpy( root, argv[1] ) ; + if ( argv[2] ) { + cut = atoi( argv[2] ) ; + } + upper_case_str( root ) ; + lower_case_str( root ) ; + callgraph( root , 0 , cut ) ; + sprintf(outbuf[0],"var db = new makeArray(%d)\n",recno-1 ) ; + for ( i = 0 ; i <= recno ; i++ ) + printf("%s",outbuf[i]) ; +} + +callgraph ( char * root , int indent , int cut ) +{ + FILE * CALLEES ; + char fname[VARLEN] ; + char * p, * q, *q1, prev ; + char inln[INLINELEN] ; + char t[12][VARLEN] ; + int i ; + char * doescall ; + char tempbuf[VARLEN] ; + int thisrec ; + + sprintf(fname,"%s/calls", DBDIR ) ; +/* skip some routines */ + if ( + COMPARE( root , "add_msg" ) || COMPARE( root , "reset_msgs" ) || + COMPARE( t[2] , "get_" ) || COMPARE( t[2] , "set_" ) || + COMPARE( t[2] , "mpi_" ) || COMPARE( t[2] , "ext_" ) || + COMPARE( root , "stencil" ) || COMPARE( root , "wrf_debug" ) || + COMPARE( root , "wrf_message" ) || COMPARE( root , "wrf_error" ) + ) return ; + thisrec = recno++ ; +#if 0 + sprintf(tempbuf,"db[%4d] = new dbRecord( %%s, \"%s\", \"../../WRFV2/tools/code_dbase/%s.html\", %d )\n", + thisrec, root, root, indent ) ; +#else + sprintf(tempbuf,"db[%4d] = new dbRecord( %%s, \"%s\", \"%s.html\", %d )\n", + thisrec, root, root, indent ) ; +#endif + + if (( CALLEES = fopen( fname , "r" )) == NULL ) return ; + + doescall = "false" ; + while ( fgets( inln, INLINELEN, CALLEES ) != NULL ) { + remove_nl ( inln ) ; + /* find first non space */ + for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + strcpy( inln, p ) ; + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( t[i] , "" ) ; + get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; + } + if ( COMPARE2( t[0] , root ) && COMPARE2( t[1] , "calls" ) && ! COMPARE2( t[0] , t[2] ) && + ! ( + COMPARE( root , "add_msg" ) || COMPARE( root , "reset_msgs" ) || + COMPARE( t[2] , "get_" ) || COMPARE( t[2] , "set_" ) || + COMPARE( t[2] , "mpi_" ) || COMPARE( t[2] , "ext_" ) || + COMPARE( root , "stencil" ) || COMPARE( root , "wrf_debug" ) || + COMPARE( root , "wrf_message" ) || COMPARE( root , "wrf_error" ) + )) { + if ( indent <= cut && ( ! sym_get ( t[2] ) ) ) { + sym_add( t[2] ) ; + doescall = "true" ; + callgraph ( t[2] , indent + 1, cut ) ; + } + } + } + sprintf(outbuf[thisrec],tempbuf,doescall) ; + fclose( CALLEES ) ; +} + +#if 0 +/*******************************************************************/ + +/* open the file of calls and count them */ +count_entries ( char * root , int * nentries ) +{ + FILE * CALLEES ; + char fname[VARLEN] ; + char inln[INLINELEN] ; + char * p, *q, *q1, prev ; + char t[12][VARLEN] ; + int i ; + + sprintf(fname,"%s/calls", DBDIR ) ; + if (( CALLEES = fopen( fname , "r" )) == NULL ) return ; + *nentries = 0 ; + while ( fgets( inln, INLINELEN, CALLEES ) != NULL ) { + remove_nl ( inln ) ; + /* find first non space */ + for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + strcpy( inln, p ) ; + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( t[i] , "" ) ; + get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; + } + if ( COMPARE2( t[0] , root ) && COMPARE2( t[1] , "calls" ) && ! COMPARE2( t[0] , t[2] ) && + ! ( + COMPARE( root , "add_msg" ) || COMPARE( root , "reset_msgs" ) || + COMPARE( t[2] , "get_" ) || COMPARE( t[2] , "set_" ) || + COMPARE( t[2] , "mpi_" ) || COMPARE( t[2] , "ext_" ) || + COMPARE( root , "stencil" ) || COMPARE( root , "wrf_debug" ) || + COMPARE( root , "wrf_message" ) || COMPARE( root , "wrf_error" ) + )) { + sym_add( t[2] ) ; + (*nentries)++ ; + } + } + fclose( CALLEES ) ; +} + + + +/* old version before adding javascript calltree */ +main( int argc , char * argv[] ) +{ + DIR *dir ; + char root[VARLEN] ; + int cut = 99 ; + + if (( dir = opendir ( DBDIR )) == NULL ) { + fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ; + } closedir( dir ) ; + if ( argc < 2 ) { + fprintf(stderr,"usage: callgraph root\n") ; + } + sym_init() ; + strcpy( root, argv[1] ) ; + if ( argv[2] ) { + cut = atoi( argv[2] ) ; + } + upper_case_str( root ) ; + printf("\n" ) ; + printf(" %s Call Tree \n", root ) ; + printf("\n" ) ; + printf("

%s Call Tree

\n", root ) ; + printf("

[1] " ) ; + printf("[2] " ) ; + printf("[3] " ) ; + printf("[4] " ) ; + printf("[5] " ) ; + printf("[all]

\n" ) ; + lower_case_str( root ) ; + callgraph( root , 0 , cut ) ; + printf("\n" ) ; + printf("\n" ) ; +} + +callgraph ( char * root , int indent , int cut ) +{ + FILE * CALLEES ; + char fname[VARLEN] ; + char * p, * q, *q1, prev ; + char inln[INLINELEN] ; + char t[12][VARLEN] ; + int i ; + int recno = 1 ; + + sprintf(fname,"%s/calls", DBDIR ) ; + if (( CALLEES = fopen( fname , "r" )) == NULL ) return ; + if ( + COMPARE( root , "add_msg" ) || COMPARE( root , "reset_msgs" ) || + COMPARE( t[2] , "get_" ) || COMPARE( t[2] , "set_" ) || + COMPARE( t[2] , "mpi_" ) || COMPARE( t[2] , "ext_" ) || + COMPARE( root , "stencil" ) || COMPARE( root , "wrf_debug" ) || + COMPARE( root , "wrf_message" ) || COMPARE( root , "wrf_error" ) + ) return ; + for ( i = 0 ; i < indent ; i++ ) printf(" !       ") ; + printf(" %s
\n", root, root ) ; + + while ( fgets( inln, INLINELEN, CALLEES ) != NULL ) { + remove_nl ( inln ) ; + /* find first non space */ + for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + strcpy( inln, p ) ; + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( t[i] , "" ) ; + get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; + } + if ( COMPARE2( t[0] , root ) && COMPARE2( t[1] , "calls" ) && ! COMPARE2( t[0] , t[2] ) && + ! ( + COMPARE( root , "add_msg" ) || COMPARE( root , "reset_msgs" ) || + COMPARE( t[2] , "get_" ) || COMPARE( t[2] , "set_" ) || + COMPARE( t[2] , "mpi_" ) || COMPARE( t[2] , "ext_" ) || + COMPARE( root , "stencil" ) || COMPARE( root , "wrf_debug" ) || + COMPARE( root , "wrf_message" ) || COMPARE( root , "wrf_error" ) + )) { + if ( indent <= cut && ( ! sym_get ( t[2] ) ) ) { + sym_add( t[2] ) ; + callgraph ( t[2] , indent + 1, cut ) ; + } + + } + } + fclose( CALLEES ) ; +} +##################### +# original old PERL code kept just for reference + +$dbdir = "tools/code_dbase" ; + +if ( ! opendir( TOOLDIR, "tools") ) { + print "\nMust be in top level WRF directory\n" ; + exit ; +} +closedir TOOLDIR ; + +if ( ( scalar @ARGV < 1 ) ) { + print "usage: callgraph root\n" ; + exit ; +} + +$rout1 = lc $ARGV[0] ; +$rout = $rout1 ; + +$routfile = $dbdir."/".$rout ; + +if ( $indent == 0 ) { +print "\n" ; +print " ",uc $rout," Call Tree \n" ; +print "\n" ; +print "

",uc $rout," Call Tree

\n" ; +} + +$indent = 0 ; + +$first = 1 ; + +open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ; +while ( ) { + @t = split ' ' ; + if ( $t[0] eq lc $rout && $t[1] eq "calls" && ! ( $t[2] eq $t[0] ) && ! ($t[2] =~ add_msg) && !($t[2] =~ reset_msgs ) && ! ($t[2] =~ stencil) && !($t[2] =~ wrf_debug) ) { + if ( $first == 1 ) { + for ( $i = 0 ; $i < $indent ; $i++ ) { print "|   " ; } + print " $rout
\n" ; + $first = 0 ; + } + $i2 = $indent + 1 ; + if ( $i2 < 7 && (! $prune{$t[2]} ) ) { + $prune{$t[2]} = "y" ; + $opstr = "tools/callgraph $t[2] $i2 |" ; + ####### RECURSE ########## + open D, $opstr ; + while ( ) { print ; } + close D ; + } + } +} +if ( $indent == 0 ) { +print "\n" ; +print "\n" ; +} + +exit +#endif + diff --git a/wrfv2_fire/tools/CodeBase/deftab.c b/wrfv2_fire/tools/CodeBase/deftab.c new file mode 100644 index 00000000..116a2b3d --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/deftab.c @@ -0,0 +1,328 @@ +#include +#include + +#define INLINELEN (4*8192) +#define VARLEN 128 +#define MAXARGS (4*8192) + +#define DIR "tools/code_dbase" + +char inln[INLINELEN] ; + +#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) ) +#define COMPARE2(A,B) ( ! strcmp ( A , B ) ) + +char module_name[INLINELEN] ; +char subprogram_name[INLINELEN] ; +char in_a[INLINELEN] ; +char arg[MAXARGS][VARLEN] ; +char type[MAXARGS][VARLEN] ; +char from[MAXARGS][VARLEN] ; +char intent[MAXARGS][VARLEN] ; +char dimensions[MAXARGS][VARLEN] ; +char typedefs[MAXARGS][INLINELEN] ; +int ntypedefs = 0 ; +char tmp[VARLEN] ; +char infname[VARLEN] ; +int nargs ; +char function_type[VARLEN] ; +int contained ; + +char *ignore = "rsl" ; + +int protex_state ; + +set_attributes( char * inln, int nargs, char * typ ) +{ + int i, j ; + char *p, tmp[VARLEN] ; + for ( i = 0 ; i < nargs ; i++ ) + { + if ( contains_tok ( inln , arg[i], " ()," ) ) { + strcpy( type[i], typ ) ; + if (( j = contains_tok ( inln, "intent", " (),:" ))) { + get_token_n ( inln , " (),:", j+1, intent[i] ) ; + } + else + { + strcpy(intent[i],"inout") ; + } + strcpy( dimensions[i], "" ) ; + if ( find_str ( inln, "dimension", &p )) { + j = 0 ; + remove_whitespace( p ) ; + while ( get_arg_n ( p , j, tmp ) ) { + strcat( dimensions[i], tmp ) ; + strcat( dimensions[i], "," ) ; + j++ ; + } + if (( p = rindex( dimensions[i], ',' )) != NULL ) *p = '\0' ; + } + } + } +} + +handle_subprogram ( FILE **fp, FILE *ifp, int *nargs, char * sname , char * inln , int tokpos ) +{ + char fname[VARLEN] ; + int i ; + + if ( ! contained ) { + sprintf(fname,"%s/%s",DIR, sname ) ; + if ((*fp = fopen( fname , "w" )) == NULL ) { + fprintf(stderr,"cannot open %s for writing\n",fname) ; exit(1) ; + } + fprintf(*fp,"sourcefile %s\n",infname ) ; + if ( COMPARE( in_a, "function" ) ) { + fprintf(*fp,"subprogram %s %s\n",in_a, function_type ) ; + } else { + fprintf(*fp,"subprogram %s\n",in_a ) ; + } + for ( i = 0 ; get_token_n ( inln , " (,)", i+tokpos, arg[i] ) ; i++ ) { strcpy( from[i], "dummyarg" ) ; } + *nargs = i ; + ntypedefs = 0 ; + fprintf(*fp,"nargs %d\n", *nargs) ; + } + contained++ ; +} + +main( int argc, char * argv[] ) +{ + FILE *infl ; + FILE *fp, *fpcalls, *fpdescription ; + int i, j ; + char callee[VARLEN] ; + char fname[VARLEN] ; + char description_name[VARLEN] ; + char mess[INLINELEN] ; + int in_interface ; + int looking_scalar_derefs ; + + strcpy( module_name, "" ) ; + strcpy( subprogram_name, "" ) ; + strcpy( infname, "" ) ; + + infl = stdin ; + if ( argc == 2 ) { + strcpy( infname, argv[1] ) ; + } + sprintf(fname,"%s/calls",DIR ) ; + if ( ( fpcalls = fopen( fname , "a" )) == NULL ) + { + fprintf(stderr,"cannot open %s\n",fname) ; + exit(1) ; + } + + in_interface = 0 ; + + looking_scalar_derefs = 0 ; + + contained = 0 ; + + protex_state = 0 ; + fpdescription = NULL ; + + while( fgets( inln, INLINELEN, infl ) != NULL ) + { + if ( protex_state > 0 ) { /* in a description */ + if ( contains_str ( inln, "" ) ) { + protex_state = 0 ; + if ( fpdescription != NULL ) fclose( fpdescription ) ; + fpdescription = NULL ; + continue ; + } + if ( fpdescription != NULL ) { + remove_chars( inln, "!", ' ' ) ; + if ( empty( inln ) ) { + fprintf(fpdescription,"

\n") ; + } else { + fprintf(fpdescription,"%s",inln) ; + } + continue ; + } + } + remove_nl ( inln ) ; + lower_case_str ( inln ) ; + if ( looking_scalar_derefs ) { + if ( COMPARE ( inln, "grid%" ) ) { + get_token_n ( inln , " ", 2, arg[nargs] ) ; + strcpy( from[nargs] , "registry" ) ; + nargs++ ; + } + } + if ( in_interface ) { + if ( COMPARE( inln , "end interface" ) ) in_interface = 0 ; + /* ignore interface blocks */ + continue ; + } + if ( COMPARE( inln , "interface" ) ) { + in_interface = 1 ; + } else if ( COMPARE( inln , "module " ) ) { + get_token_n ( inln , " (,", 1, module_name ) ; + } else if ( COMPARE( inln , "end module" ) ) { + strcpy( module_name, "" ) ; + } else if ( COMPARE( inln , "program " ) ) { + strcpy(in_a, "program") ; + get_token_n ( inln , " (,", 1, subprogram_name ) ; + handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ; + } else if ( COMPARE( inln , "subroutine " ) ) { + strcpy(in_a, "subroutine") ; + get_token_n ( inln , " (,", 1, subprogram_name ) ; + handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ; + } else if ( COMPARE( inln , "function " ) ) { + strcpy(in_a, "function") ; + get_token_n ( inln , " (,", 1, subprogram_name ) ; + handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 2 ) ; + } else if ( COMPARE( inln , "recursive subroutine " ) ) { + strcpy(in_a, "recursive subroutine") ; + get_token_n ( inln , " (,", 2, subprogram_name ) ; + handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 3 ) ; + } else if ( contains_str ( inln, "startofregistrygeneratedinclude" ) && contains_str ( inln, "i1_decl.inc" )) { + if ( strlen( subprogram_name ) > 0 ) { + fprintf(fp, "contains_i1_declarations\n" ) ; + } + } else if ( contains_str ( inln, "! begin scalar derefs" ) ) { + looking_scalar_derefs = 1 ; + } else if ( contains_str ( inln, "! end scalar derefs" ) ) { + looking_scalar_derefs = 0 ; + } else if ( contains_str ( inln, "" ) && protex_state == 0 ) { + protex_state = 1 ; + sprintf(description_name,"%s/%s_descrip",DIR, subprogram_name ) ; + if ((fpdescription = fopen( description_name , "a" )) == NULL ) { + fprintf(stderr, "cannot open %s for writing\n", description_name ) ; exit(2) ; + } + protex_state = 2 ; + } else if ( contains_str ( inln, "" ) ) { + protex_state = 0 ; + if ( fpdescription != NULL ) fclose( fpdescription ) ; + fpdescription = NULL ; + } else if ( COMPARE( inln , "use " ) ) { + if ( strlen( subprogram_name ) > 0 ) { + get_token_n ( inln , " ", 1, tmp ) ; + fprintf(fp, "use %s\n",tmp ) ; + } + } else if ( COMPARE( inln , "call " ) ) { + get_token_n ( inln , " (,", 1, callee ) ; + if ( ! contains_str( callee , ignore ) ) { + fprintf(fpcalls,"%s calls %s\n",subprogram_name, callee ) ; + fprintf(fp,"%s calls %s\n",subprogram_name, callee ) ; + for ( i = 0 ; get_arg_n ( inln , i, tmp ) ; i++ ) + { + /* check to see if this is a dummy arg and print that info too */ + strcpy(mess,"") ; + for ( j = 0 ; j < nargs ; j++ ) + { + if ( !strcmp( tmp, arg[j] ) ) + { + sprintf( mess, " ( dummy arg %d, type %s ) ",j,type[j] ) ; + break ; + } + } + fprintf(fp," actarg %d of callee %s is %s%s\n",i,callee, tmp,mess) ; + } + } + } else if ( COMPARE( inln , "integer " ) || COMPARE( inln , "real " ) || COMPARE( inln , "logical " ) ) { + /* look for function */ + get_token_n ( inln , " ", 0, function_type ) ; + get_token_n ( inln , " ,", 1, tmp ) ; + if ( COMPARE( tmp, "function" ) ) + { + strcpy(in_a,"function") ; + get_token_n ( inln, " (", 2, subprogram_name ) ; + handle_subprogram ( &fp, infl, &nargs, subprogram_name, inln, 3 ) ; + } + else if ( strlen( subprogram_name ) > 0 && nargs > 0 ) { + strcpy( typedefs[ntypedefs++], inln ) ; + } + } else if ( COMPARE( inln , "type " ) ) { + if ( strlen( subprogram_name ) > 0 && nargs > 0 ) { + strcpy( typedefs[ntypedefs++], inln ) ; + } + } else if ( COMPARE( inln , "end subroutine" ) ) { + contained-- ; + if ( contained == 0 ) { + fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ; + for ( i = 0 ; i < ntypedefs ; i++ ) + { + if ( COMPARE( typedefs[i], "type" ) ) { + get_token_n ( typedefs[i], ",", 0, tmp ) ; + remove_whitespace( tmp ) ; + } else { + get_token_n ( typedefs[i], " ,", 0, tmp ) ; + } + set_attributes( typedefs[i], nargs, tmp ) ; + } + for ( i = 0 ; i < nargs ; i++ ) + { + fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ; + } + fclose(fp) ; fp = NULL ; + strcpy( in_a, "" ) ; + strcpy( subprogram_name, "" ) ; + } + } else if ( COMPARE( inln , "end function" ) ) { + contained-- ; + if ( contained == 0 ) { + fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ; + for ( i = 0 ; i < ntypedefs ; i++ ) + { + get_token_n ( typedefs[i], " ,", 0, tmp ) ; + set_attributes( typedefs[i], nargs, tmp ) ; + } + for ( i = 0 ; i < nargs ; i++ ) + { + fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ; + } + fclose(fp) ; fp = NULL ; + strcpy( in_a, "" ) ; + strcpy( subprogram_name, "" ) ; + } + } else if ( COMPARE( inln , "end program" ) ) { + contained-- ; + if ( contained == 0 ) { + fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ; + for ( i = 0 ; i < ntypedefs ; i++ ) + { + get_token_n ( typedefs[i], " ,", 0, tmp ) ; + set_attributes( typedefs[i], nargs, tmp ) ; + } + for ( i = 0 ; i < nargs ; i++ ) + { + fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ; + } + fclose(fp) ; fp = NULL ; + strcpy( in_a, "" ) ; + strcpy( subprogram_name, "" ) ; + } +#if 1 + } else if ( COMPARE( inln , "end" ) ) { /* bare end -- take a chance and hope it's a subroutine */ + remove_whitespace( inln ) ; /* make sure it's not an enddo, endif, etc */ + if ( COMPARE2 (inln , "end" ) ) { + contained-- ; + if ( contained == 0 ) { + fprintf(fp,"Module: %s , Subroutine: %s \n",module_name, subprogram_name ) ; + for ( i = 0 ; i < ntypedefs ; i++ ) + { + if ( COMPARE( typedefs[i], "type" ) ) { + get_token_n ( typedefs[i], ",", 0, tmp ) ; + remove_whitespace( tmp ) ; + } else { + get_token_n ( typedefs[i], " ,", 0, tmp ) ; + } + set_attributes( typedefs[i], nargs, tmp ) ; + } + for ( i = 0 ; i < nargs ; i++ ) + { + fprintf(fp,"arg %d name %s type %s intent %s from %s dimensions %s\n", i, arg[i], type[i], intent[i], from[i], dimensions[i] ) ; + } + fclose(fp) ; fp = NULL ; + strcpy( in_a, "" ) ; + strcpy( subprogram_name, "" ) ; + } + } +#endif + } + } + fclose( fpcalls ) ; fpcalls = NULL ; +} + diff --git a/wrfv2_fire/tools/CodeBase/nocontf90.c b/wrfv2_fire/tools/CodeBase/nocontf90.c new file mode 100644 index 00000000..2892fdbf --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/nocontf90.c @@ -0,0 +1,41 @@ +#include +#include + +#define INLINELEN 8092 + +char inln[INLINELEN] ; + +int protex_state = 0 ; + +main() +{ + while( fgets( inln, INLINELEN, stdin ) != NULL ) + { + remove_nl( inln ) ; + if ( contains_str ( inln , "" ) ) { + protex_state = 1 ; + printf("%s\n",inln) ; + continue ; + } + if ( contains_str ( inln , "" ) ) { + protex_state = 0 ; + printf("%s\n",inln) ; + continue ; + } + if ( ! contains_str( inln , "SCALAR DEREFS" ) && + ! ( contains_str( inln , "STARTOFREGISTRYGENERATEDINCLUDE" ) && contains_str( inln , "i1_decl.inc" ) ) && + ! protex_state ) { + remove_comments ( inln ) ; + } + if ( ! protex_state ) { + lower_case_str ( inln ) ; + remove_chars ( inln, ";", '\n' ) ; + } + if ( empty ( inln ) ) continue ; + if ( remove_ampersands ( inln ) ) + printf("%s",inln) ; + else + printf("%s\n",inln) ; + } +} + diff --git a/wrfv2_fire/tools/CodeBase/subinfo_calls.c b/wrfv2_fire/tools/CodeBase/subinfo_calls.c new file mode 100755 index 00000000..9d4edd09 --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/subinfo_calls.c @@ -0,0 +1,82 @@ +#include +#include +#include +#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) ) +#define COMPARE2(A,B) ( ! strcmp ( A , B ) ) +#define INLINELEN (4*8192) +#define VARLEN 128 +#define MAXARGS (4*8192) +#define MAXDEPTH 50 + +#define DIR "tools/code_dbase" + +char levels[MAXDEPTH][VARLEN] ; + +main( int argc, char *argv[] ) +{ + int indent ; + int i ; + char *rout ; + indent = atoi( argv[1] ) ; + rout = argv[2] ; + for ( i = 0 ; i < MAXDEPTH ; i++ ) strcpy( levels[i] , "" ) ; + subinfo_calls ( rout, indent ) ; + +} + +subinfo_calls ( char *rout, int indent ) +{ + FILE *CALLERS ; + FILE *CALLER ; + char inln[INLINELEN], inln2[INLINELEN] ; + int i ; + char fname[VARLEN], fname2[VARLEN], sf[VARLEN] ; + char u0[VARLEN] , u1[VARLEN] , u2[VARLEN] ; + char v0[VARLEN] , v1[VARLEN] , v2[VARLEN] ; + char u0_upper[VARLEN] ; + + if ( COMPARE( rout, "add_msg_" ) || + COMPARE( rout, "wrf_error" ) || + COMPARE( rout, "wrf_debug" ) || + COMPARE( rout, "wrf_message" ) || + COMPARE( rout, "stencil_" ) || + COMPARE( rout, "start_timing" ) || + COMPARE( rout, "end_timing" ) ) exit(0) ; + + sprintf(fname, "%s/calls", DIR ) ; + if (( CALLERS = fopen( fname, "r" )) == NULL ) { fprintf(stderr,"subinfo_calls: cannot open %s\n",fname) ; exit(1) ; } + + while ( fgets( inln, INLINELEN, CALLERS ) != NULL ) { + get_token_n ( inln, " ", 0, u0 ) ; remove_nl(u0) ; + get_token_n ( inln, " ", 1, u1 ) ; remove_nl(u1) ; + get_token_n ( inln, " ", 2, u2 ) ; remove_nl(u2) ; + if ( COMPARE2( rout, u2 ) && ! COMPARE( u2 , u0 ) ) { + sprintf( fname2 , "%s/%s", DIR, u0 ) ; + if (( CALLER = fopen( fname2, "r" )) == NULL ) { fprintf(stderr,"subinfo_calls: cannot open %s\n",fname2 ) ; exit(2) ; } + while ( fgets( inln2 , INLINELEN, CALLER ) != NULL ) { + get_token_n ( inln2, " ", 0, v0 ) ; remove_nl ( v0 ) ; + get_token_n ( inln2, " ", 1, v1 ) ; remove_nl ( v1 ) ; + if ( COMPARE2( v0, "sourcefile" ) ) { strcpy ( sf , v1 ) ; break ; } + } + fclose(CALLER) ; + for ( i = 0 ; i < indent * 3 ; i++ ) { + printf( "  " ) ; + } + switch_little_big_f( sf ) ; +#if 0 + printf("%s (%s)
\n", u0, u0, sf, sf ) ; +#else + strcpy( u0_upper, u0 ) ; upper_case_str( u0_upper ) ; + printf("%s (%s)
\n", u0, u0, sf, u0_upper,sf ) ; +#endif + /* RECURSION */ + if ( ! COMPARE2( u0 , levels[ indent+1 ] ) ) { + strcpy( levels[ indent+1 ], u0 ) ; + subinfo_calls ( u0 , indent + 1 ) ; + } + } + } + fclose( CALLERS ) ; +} + + diff --git a/wrfv2_fire/tools/CodeBase/sym.c b/wrfv2_fire/tools/CodeBase/sym.c new file mode 100644 index 00000000..de41c2d9 --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/sym.c @@ -0,0 +1,161 @@ +/*********************************************************************** + + COPYRIGHT + + The following is a notice of limited availability of the code and + Government license and disclaimer which must be included in the + prologue of the code and in all source listings of the code. + + Copyright notice + (c) 1977 University of Chicago + + Permission is hereby granted to use, reproduce, prepare + derivative works, and to redistribute to others at no charge. If + you distribute a copy or copies of the Software, or you modify a + copy or copies of the Software or any portion of it, thus forming + a work based on the Software and make and/or distribute copies of + such work, you must meet the following conditions: + + a) If you make a copy of the Software (modified or verbatim) + it must include the copyright notice and Government + license and disclaimer. + + b) You must cause the modified Software to carry prominent + notices stating that you changed specified portions of + the Software. + + This software was authored by: + + Argonne National Laboratory + J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov + Mathematics and Computer Science Division + Argonne National Laboratory, Argonne, IL 60439 + + ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES + OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, + AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A + CONTRACT WITH THE DEPARTMENT OF ENERGY. + + GOVERNMENT LICENSE AND DISCLAIMER + + This computer code material was prepared, in part, as an account + of work sponsored by an agency of the United States Government. + The Government is granted for itself and others acting on its + behalf a paid-up, nonexclusive, irrevocable worldwide license in + this data to reproduce, prepare derivative works, distribute + copies to the public, perform publicly and display publicly, and + to permit others to do so. NEITHER THE UNITED STATES GOVERNMENT + NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF + THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR + ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, + COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, + PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD + NOT INFRINGE PRIVATELY OWNED RIGHTS. + +***************************************************************************/ +/* sym.c + + Implementation dependent routines for using symtab_gen.c + in N32 . + +*/ + +#include +#include "sym.h" + +extern sym_nodeptr symget() ; + +static char ** symtab ; /* 2-19-90 */ + +int +sym_init() /* 2-19-90, initialize symbol table package */ +{ + create_ht( &symtab ) ; + if (symtab == NULL) + { + fprintf(stderr,"init_sym(): could not create hash table") ; + exit(1) ; + } + return(0) ; +} + +sym_nodeptr +sym_add( name ) +char * name ; +{ + sym_nodeptr new_sym_node(); + char **node_name() ; + sym_nodeptr *node_next() ; + return( symget( name, new_sym_node, node_name, node_next, symtab, 1 ) ) ; +} + +sym_nodeptr +sym_get( name ) +char * name ; +{ + sym_nodeptr new_sym_node(); + char **node_name() ; + sym_nodeptr *node_next() ; + return( symget( name, new_sym_node, node_name, node_next, symtab, 0 ) ) ; +} + +sym_nodeptr +new_sym_node() +{ + void * malloc() ; + sym_nodeptr p ; + p = (sym_nodeptr) malloc( sizeof( struct sym_node ) ) ; + p->name = NULL ; + p->next = NULL ; + + return( p ) ; +} + +char ** +node_name(p) +sym_nodeptr p ; +{ + char ** x ; + x = &(p->name) ; + return( x ) ; +} + +sym_nodeptr * +node_next(p) +sym_nodeptr p ; +{ + sym_nodeptr *x ; + x = &(p->next) ; + return( x ) ; +} + +int +show_entry(x) +sym_nodeptr x ; +{ + int i ; + if ( x == NULL ) return(0) ; + printf("Symbol table entry:\n") ; + printf("lexeme %s\n", x->name ) ; + printf(" dim %s\n", (x->dim==1?"M":(x->dim==2?"N":"O")) ) ; + printf(" ndims %d\n", x->ndims ) ; + for ( i = 0 ; i < x->ndims && i < 7 ; i++ ) + printf(" dim %d -> %s\n",i,(x->dims[i]==1?"M":(x->dims[i]==2?"N":"O")) ) ; + return(0) ; +} + +/* MEMORY LEAK !!!! -- this just abandons the old table and leaves on the heap. */ +/* The registry mechanism is not a long-running program and is not apt to + run into memory problems. Might want to fix this anyway, though, someday. */ +int +sym_forget() +{ + create_ht( &symtab ) ; + if (symtab == NULL) + { + fprintf(stderr,"init_sym(): could not create hash table") ; + exit(1) ; + } + return(0) ; +} + diff --git a/wrfv2_fire/tools/CodeBase/sym.h b/wrfv2_fire/tools/CodeBase/sym.h new file mode 100644 index 00000000..f95f660e --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/sym.h @@ -0,0 +1,91 @@ +/*********************************************************************** + + COPYRIGHT + + The following is a notice of limited availability of the code and + Government license and disclaimer which must be included in the + prologue of the code and in all source listings of the code. + + Copyright notice + (c) 1977 University of Chicago + + Permission is hereby granted to use, reproduce, prepare + derivative works, and to redistribute to others at no charge. If + you distribute a copy or copies of the Software, or you modify a + copy or copies of the Software or any portion of it, thus forming + a work based on the Software and make and/or distribute copies of + such work, you must meet the following conditions: + + a) If you make a copy of the Software (modified or verbatim) + it must include the copyright notice and Government + license and disclaimer. + + b) You must cause the modified Software to carry prominent + notices stating that you changed specified portions of + the Software. + + This software was authored by: + + Argonne National Laboratory + J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov + Mathematics and Computer Science Division + Argonne National Laboratory, Argonne, IL 60439 + + ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES + OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, + AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A + CONTRACT WITH THE DEPARTMENT OF ENERGY. + + GOVERNMENT LICENSE AND DISCLAIMER + + This computer code material was prepared, in part, as an account + of work sponsored by an agency of the United States Government. + The Government is granted for itself and others acting on its + behalf a paid-up, nonexclusive, irrevocable worldwide license in + this data to reproduce, prepare derivative works, distribute + copies to the public, perform publicly and display publicly, and + to permit others to do so. NEITHER THE UNITED STATES GOVERNMENT + NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF + THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR + ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, + COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, + PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD + NOT INFRINGE PRIVATELY OWNED RIGHTS. + +***************************************************************************/ +#ifndef SYM_H +#define SYM_H + +/* file: sym.h + + Header info for symbol table module. + +*/ + +typedef struct sym_node * sym_nodeptr ; + +struct sym_node +{ + char * name ; /* lexeme */ + sym_nodeptr next ; /* pointer to next node in symbol table */ +/* fields that are associated with dimension declaration constants */ + unsigned char dim ; +/* fields that are associated with arrays */ + int ndims ; + int MDEX ; /* which index is the M dimension */ + int NDEX ; /* which index is the N dimension */ + unsigned char dims[7] ; + char dimname[7][64] ; +/* name of temporary variable associated with string. variable */ + char varx[32] ; +/* fields associated with integer scalar variables */ + unsigned long assigned ; /* pointer to assignment statement */ + unsigned long thisif ; + int iflev ; + int marked ; /* general purpose marker */ +} ; + +sym_nodeptr sym_add() ; +sym_nodeptr sym_get() ; + +#endif diff --git a/wrfv2_fire/tools/CodeBase/symtab_gen.c b/wrfv2_fire/tools/CodeBase/symtab_gen.c new file mode 100644 index 00000000..00815e0a --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/symtab_gen.c @@ -0,0 +1,203 @@ +/* symtab.c + +Symbol Table Handler -- Generic + +The routine symget() returns a pointer to a C structure matching a +given lexeme. If the lexeme does not already exist in the symbol +table, the routine will create a new symbol structure, store it, and +then return a pointer to the newly created structure. + +It is up to the calling module to declare the symbol structure as +well as several routines for manipulating the symbol structure. The +routines are passed to symget as pointers. + + name type description + + newnode() *char returns a pointer to a symbol structure. + + nodename() **char retrieves the lexeme name from a symbol + structure, returned as a pointer to a + character array. + + nodenext() **char retrieves pointer to the next field of + the symbol structure (the next field + is itself a pointer to a symbol structure) + +For a sample main or calling program see the end of this file. + +**** + REVISED 2-19-90. Added code to make hashtable interchangible. + new routine: create_ht() creates new hashtable + rev routine: symget() added parameter to pass hash table +*/ + +#include +#include +#include + +#define HASHSIZE 1024 + +/* commented out 2-29-90 +static char * symtab[HASHSIZE] ; +*/ + +void * malloc() ; +void * calloc() ; + +char * symget(name,newnode,nodename,nodenext,symtab,flag) +char *name ; +char *(*newnode)(), **(*nodename)(), **(*nodenext)() ; +char *symtab[] ; +int flag ; /* 1 is create if not there, 0 return NULL if not there */ +{ + int index ; + int found ; + register char *s ; + register char *t ; + char **x ; + char *p ; + + index = hash( name ) ; + p = symtab[index] ; + found = 0 ; + + while (p) { + s = name ; + t = *(*nodename)(p) ; + while (*s && *t && *s == *t ) { + s++ ; + t++ ; + } + if (!*s && !*t) { + found = 1 ; + break ; + } + p = *(*nodenext)(p) ; + } + + if (!found ) { + if (flag ) { + p = (*newnode)() ; + x = (*nodename)(p) ; + *x = (char *) malloc(strlen(name)+1) ; + strcpy(*x,name) ; + x = (*nodenext)(p) ; + *x = symtab[index] ; + symtab[index] = p ; + } else { + return(NULL) ; + } + } + + return(p) ; +} + +hash(name) +char * name ; +{ + register int result = 0 ; + register char * p = name ; + + while (*p) + result = 3*result + (int)*p++ ; + + result = result % HASHSIZE ; + while (result < 0) + result = result + HASHSIZE ; + return(result) ; +} + + +/* added 2-19-90, attaches a new hash table to pointer */ + +int +create_ht( p ) +char *** p ; +{ + *p = (char **) calloc( HASHSIZE , sizeof( char * ) ) ; + return(0) ; +} + + +/* added 4-15-92. + +This is a generic routine that, given a hash table pointer, +will traverse the hash table and apply a caller supplied +function to each entry + +*/ + +int +sym_traverse( ht, nodenext, f ) +char *ht[] ; +char **(*nodenext)() ; +void (*f)() ; +{ + char * p, **x ; + int i ; + for ( i = 0 ; i < HASHSIZE ; i++ ) + { + if ( ( p = ht[i] ) != NULL ) + { + while ( p ) + { + (*f)(p) ; + x = (*nodenext)(p) ; + p = *x ; + } + } + } + return(0) ; +} + +/**********************************************************************/ +/**********************************************************************/ +/**********************************************************************/ + +#ifdef COMMENTOUTSAMPLE +/* sample_main.c + + sample main program for symget() in the file symtab.c + +*/ + +#include + +struct symnode { + char * name ; + struct symnode *next ; +} ; + +extern struct symnode * symget() ; + +struct symnode * +newnode() +{ + struct symnode * malloc() ; + return( malloc( sizeof( struct symnode ) ) ) ; +} + +char ** +nodename(p) +struct symnode *p ; +{ + char ** x ; + x = &(p->name) ; + return( x ) ; +} + +struct symnode ** +nodenext(p) +struct symnode *p ; +{ + struct symnode **x ; + x = &(p->next) ; + return( x ) ; +} + +#endif + +/**********************************************************************/ +/**********************************************************************/ +/**********************************************************************/ + diff --git a/wrfv2_fire/tools/CodeBase/util.c b/wrfv2_fire/tools/CodeBase/util.c new file mode 100644 index 00000000..81b1b44a --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/util.c @@ -0,0 +1,275 @@ +#include +#include + +#define INLINELEN (4*8192) + +/* if sf is a string that ends in .f, end in .F, or vice verrsa */ + +int switch_little_big_f ( char s[] ) +{ + int n ; + n = strlen(s) ; + if ( !strcmp( &(s[n-2]) , ".f" ) ) { s[n-1] = 'F' ; } + else if ( !strcmp( &(s[n-2]) , ".F" ) ) { s[n-1] = 'f' ; } + return(0) ; +} + +int contains_str( char *s1, char *s2 ) +{ + int i ; + char *p, *q, *r ; + if ( s2 == NULL || s1 == NULL ) return ( 0 ) ; + if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ; + p = s1 ; + while ( *p ) { + if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; } + for ( q = s2 ; *q && *r == *q ; r++ , q++ ) ; + if ( *q == '\0' ) return (1) ; + p++ ; + } + return( 0 ) ; +} + +int +find_str( char *s1, char *s2, char **strp ) +{ + int i ; + char *p, *q, *r ; + if ( s2 == NULL || s1 == NULL ) return ( 0 ) ; + if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ; + p = s1 ; + while ( *p ) { + *strp = NULL ; + if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; } + *strp = r ; + for ( q = s2 ; *q && *r == *q ; r++ , q++ ) ; + if ( *q == '\0' ) return (1) ; + p++ ; + } + return( 0 ) ; +} + + +int contains_tok( char *s1, char *s2, char *delims ) +{ + char *p ; + char tempstr[INLINELEN] ; + int i ; + + strcpy( tempstr , s1 ) ; + p = strtok ( tempstr, delims ) ; + i = 0 ; + while ( p != NULL ) + { + if ( !strcmp ( p , s2 ) ) { return(i) ;} + i++ ; + p = strtok( NULL, delims ) ; + } + return(0) ; +} + +int +get_token_n ( char *s1, char *delims , int n, char* retval ) +{ + char *p ; + int i ; + static char tempstr[INLINELEN] ; + strcpy( tempstr , s1 ) ; + p = strtok ( tempstr, delims ) ; + i = 0 ; + while ( p != NULL ) + { + if ( i == n ) { strcpy( retval, p ) ; return( 1 ) ; } + p = strtok( NULL, delims ) ; + i++ ; + } + return( 0 ) ; +} + +int +get_arg_n ( char *s1, int n, char *retval ) +{ + char *p, *q ; + int i, arg, inquote = -1, inparen = -1 ; + static char tempstr[INLINELEN] ; + char quotes[INLINELEN] ; + char parens[INLINELEN] ; + strcpy( tempstr , s1 ) ; + strcpy( retval, "" ) ; + + if ( (p = index(tempstr, '(')) == NULL ) return(0) ; + p++ ; + arg = 0 ; + while ( *p && arg < n+1 ) { + q = p ; + inquote = -1 ; + for ( ; *p ; p++ ) + { + if ( *p == '\'' || *p == '"' ) { + if ( inquote >= 0 ) { + if ( quotes[inquote] == *p ) { + inquote-- ; + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } + if ( inquote < 0 ) { + if ( *p == '(' ) inparen++ ; + if ( *p == ')' ) { + if ( inparen >= 0 ) { inparen-- ; } + else { *p = '\0' ; arg++ ; break ;} + } + } + if ( inquote < 0 && inparen < 0 ) { + if ( *p == ',' ) { arg++ ; *p = '\0' ; p++ ; break ; } + } + } + } + if ( arg == n+1 ) { + for ( ; *q ; q++ ) { if ( *q != ' ' && *q != '\t' ) break ; } + strcpy( retval, q ) ; + return (1) ; + } else { + strcpy( retval, "" ) ; + return(0) ; + } +} + +int +empty ( char *s ) +{ + char *p ; + for ( p = s ; *p ; p++ ) + { + if ( ! ( *p == ' ' || *p == '\t' || *p == '\n' ) ) return( 0 ) ; + } + return( 1 ) ; +} + +remove_nl ( char *s ) +{ + char *p ; + if (( p = index( s , '\n' )) != NULL ) *p = '\0' ; +} + + +remove_comments ( char *s ) +{ + int inquote = -1 ; + char quotes[INLINELEN] ; + char *p ; + for ( p = s ; *p ; p++ ) + { + if ( *p == '\'' || *p == '"' ) { + if ( inquote >= 0 ) { + if ( quotes[inquote] == *p ) { + inquote-- ; + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } + if ( inquote < 0 ) { + if ( *p == '!' ) { *p = '\0' ; break ; } + } + } +} + +int +remove_chars ( char *s, char *r, char replace ) +{ + int inquote = -1 ; + int retval = 0 ; + char quotes[INLINELEN] ; + char *p, *q ; + for ( p = s ; *p ; p++ ) + { + if ( *p == '\'' || *p == '"' ) { + if ( inquote >= 0 ) { + if ( quotes[inquote] == *p ) { + inquote-- ; + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } else { + inquote++ ; + quotes[inquote] = *p ; + } + } + if ( inquote < 0 ) { + for ( q = r ; *q ; q++ ) { + if ( *p == *q ) { *p = replace ; retval = 1 ; } + } + } + } + return(retval) ; +} + +int +remove_whitespace ( char *s ) +{ + char *p, *q ; + for ( p = s, q = s ; *p ; p++ ) + { + if ( ! (*p == ' ' || *p == '\t') ) { + *q++ = *p ; + } + } + *q = '\0' ; + return(0) ; +} + + +int +iswhite( char *s ) +{ + char *p ; + for ( p = s ; *p ; p++ ) if ( *p != ' ' && *p != '\t' ) return(0) ; + return(1) ; +} + +int +remove_ampersands ( char *s ) +{ + char * p, * q ; + int retval ; + if (( p = rindex ( s, '&' )) != NULL ) + { + if ( iswhite( p+1 ) ) retval = 1 ; + else retval = 0 ; + } + else + { + retval = 0 ; + } + remove_chars ( s , "&", ' ' ) ; + return(retval) ; +} + +lower_case_str ( char *s ) +{ + char * p ; + for ( p = s ; *p ; p++ ) + { + if ( *p >= 'A' && *p <= 'Z' ) *p = *p - 'A' + 'a' ; + } +} + +upper_case_str ( char *s ) +{ + char * p ; + for ( p = s ; *p ; p++ ) + { + if ( *p >= 'a' && *p <= 'z' ) *p = *p - 'a' + 'A' ; + } +} diff --git a/wrfv2_fire/tools/CodeBase/wrfvar.c b/wrfv2_fire/tools/CodeBase/wrfvar.c new file mode 100755 index 00000000..19f68272 --- /dev/null +++ b/wrfv2_fire/tools/CodeBase/wrfvar.c @@ -0,0 +1,532 @@ +#include +#include +#include +#include +#include +#include + +#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) ) +#define COMPARE2(A,B) ( ! strcmp ( A , B ) ) +#define INLINELEN (4*8192) +#define VARLEN 128 +#define MAXARGS (4*8192) + + +#define DBDIR "tools/code_dbase" + +int sw_all = 0 ; + + +main( int argc, char *argv[] ) +{ + FILE *fp ; + FILE *calls ; + char fname[VARLEN], syscom[VARLEN] ; + char *rout , *vname ; + if ( argc < 2 || argc > 5 || ( argc == 2 && ! COMPARE2( argv[1] , "rebuild" ) ) ) { + printf("usage : wrfvar varname routinename\n" ) ; + printf(" wrfvar rebuild\n" ) ; + exit(2) ; + } + vname = argv[1] ; + rout = argv[2] ; + if ( argc == 4 && argv[3] != NULL ) { + if ( COMPARE2( argv[3] , "all" ) ) sw_all = 1 ; + } + sprintf( fname, "%s/calls", DBDIR ) ; + if (( fp = fopen ( fname , "r" )) == NULL || COMPARE2( argv[1], "rebuild" ) ) { + int rc ; + printf("Building code database ... please wait\n") ; + sprintf( syscom, "cd tools/CodeBase ; make" ) ; + rc = system( syscom ) ; + if ( WEXITSTATUS( rc ) ) { exit(3) ; } + sprintf( syscom, "tools/build_codebase" ) ; + rc = system( syscom ) ; + if ( WEXITSTATUS( rc ) ) { exit(3) ; } + sprintf( syscom, "ln -sf tools/wrfvar ." ) ; + sprintf( syscom, "ln -sf tools/subinfo ." ) ; + if ( COMPARE2( argv[1] , "rebuild" ) ) exit ; + } + fclose( fp ) ; + lower_case_str ( vname ) ; + lower_case_str ( rout ) ; + printf("

Trace upwards through call tree for %s

\n",vname ) ; + wrfvar ( vname, rout, 0 ) ; +} + +wrfvar ( char * vname, char *rout, int recursion_level ) +{ + FILE *ROUT ; + FILE *BBB ; + FILE *ELEF ; + FILE *CALLER ; + FILE *CALLERS ; + FILE *REGISTRY ; + DIR *dir ; + char inln[INLINELEN], inln2[INLINELEN], inln3[INLINELEN] ; + int i ; + char fname[VARLEN], fname2[VARLEN], sf[VARLEN] ; + char vv[VARLEN], vv2[VARLEN] ; + char u0[VARLEN] , u1[VARLEN] , u2[VARLEN] ; + char v0[VARLEN] , v1[VARLEN] , v2[VARLEN] ; + char r[12][VARLEN], t[12][VARLEN], u[12][VARLEN], v[12][VARLEN] ; + char routfile[VARLEN] ; + char tmp[VARLEN], darg[VARLEN], dintent[VARLEN] ; + char hamuna[VARLEN] ; + char rout1[VARLEN], rout2[VARLEN], rout3[VARLEN] ; + char sourcefile[VARLEN], sourcefile_caller[VARLEN] ; + char s1[VARLEN], s2[VARLEN], s3[VARLEN] ; + char * p, * q, * q1, prev ; + int found_var, nargs_rout, argn, callno, more_calls, first_time ; + int contains_i1_declarations ; + + if (( dir = opendir ( DBDIR )) == NULL ) { + fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ; + } closedir( dir ) ; + + strcpy( rout1, rout ) ; + strcpy( vv, vname ) ; + strcpy( vv2, vname ) ; + remove_whitespace( vv2 ) ; + /* remove arguments */ + if ((q = strchr( vv2 , '(' )) != NULL ) *q = '\0' ; + /* remove time level if there */ + if (( q = strrchr( vv2, '_' )) != NULL ) { + if ( COMPARE2( q , "_1" ) || COMPARE2( q , "_2" ) || COMPARE2( q , "_3" ) ) *q = '\0' ; + } + if ( COMPARE( vv2, "grid%" ) || !strcmp( rout, "registry_i1" )) { + if (( REGISTRY = fopen( "Registry/Registry" , "r" )) == NULL ) { + fprintf(stderr,"can not open Registry/Registry\n") ; exit(2) ; } + strcpy( inln, "" ) ; + while ( fgets( inln2, INLINELEN, REGISTRY ) != NULL ) { + int inquote ; + strcat( inln, inln2 ) ; + if (( q = strrchr ( inln, '\\' )) != NULL ) { /* continuation */ + *q = '\0' ; continue ; + } + if (( q = strchr( inln, '#' )) != NULL ) *q = '\0' ; + inquote = 0 ; + for ( p = inln, q = inln2 ; *p ; p++, q++ ) { + if ( ! inquote && *p == '"' ) { inquote = 1 ; *p = ' ' ; } + else if ( inquote && *p == '"' ) { inquote = 0 ; *p = ' ' ; } + if ( *p == ' ' && inquote ) { *q = '`' ; } + else { *q = *p ; } + } + *q = '\0' ; + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( r[i] , "" ) ; + get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; + if ( i < 10 ) lower_case_str( r[i] ) ; + } + if ( COMPARE2 ( r[0], "state" ) ) { + if ( COMPARE ( r[4], "dyn_" ) ) { + /* if core associated */ + sprintf(s1,"%s_",&(r[4][4])) ; + i = strlen(&(r[4][4])) ; +#if 1 + { char *x , *y ; int j ; + for ( x = vv2+5 , y = s3 , j = 0 ; j < i ; j++ ) { *y++ = *x++ ; } + *y = '\0' ; + } +#else +/* is there a bug in this?? */ + strncpy( s3, vv2+5, i ) ; +fprintf(stderr,"X %s <- %s %d\n", s3, vv2, i ) ; +#endif + sprintf(s2,"%s_",s3) ; + if ( COMPARE2 ( s1, s2 ) && + COMPARE2 ( vv2+5+(strlen(r[4])-3), r[2] ) ) { + for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + printf("%3d. Registry-defined: %s %s %s \"%s\" \"%s\"
\n", + recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; + } + } else { + /* if not core associated */ + if ( COMPARE2 ( vv2+5, r[2] ) ) { + for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + printf("%3d. Registry-defined: %s %s %s \"%s\" \"%s\"
\n", + recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; + } + } + } else if ( COMPARE2 ( r[0], "rconfig" ) ) { + if ( COMPARE2 ( vv2+5, r[2] ) ) { + for (p = r[8] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + printf("%3d. Registry-defined: %s %s %s \"%s\"
\n", + recursion_level+1, r[0], r[1], r[2], r[8] ) ; + } + } else if ( COMPARE2 ( r[0], "i1" ) && !strcmp( rout, "registry_i1" )) { + if ( COMPARE2 ( vv2, r[2] ) ) { + for (p = r[9] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; } + printf("%3d. Registry-defined: %s %s %s \"%s\" \"%s\"
\n", + recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ; + } + } + + strcpy( inln, "" ) ; + } + fclose( REGISTRY ) ; + return ; + } + + sprintf( routfile, "%s/%s", DBDIR, rout ) ; + strcpy ( sourcefile , "" ) ; + found_var = 0 ; + nargs_rout = 0 ; + if (( ROUT = fopen( routfile, "r" )) == NULL ) return ; + { + contains_i1_declarations = 0 ; + while ( fgets( inln, INLINELEN, ROUT ) != NULL ) { + remove_nl ( inln ) ; + /* find first non space */ + for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + strcpy( inln, p ) ; + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( t[i] , "" ) ; + get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; + } + if ( COMPARE2( "contains_i1_declarations", t[0] ) ) { + contains_i1_declarations = 1 ; + } else if ( COMPARE2( "sourcefile" , t[0] ) ) { + strcpy ( sourcefile , t[1] ) ; + } else if ( COMPARE2( "arg" , t[0] ) ) { + nargs_rout ++ ; + if ( COMPARE2( t[3] , vname ) && ! COMPARE2( t[9] , "registry" ) ) { + argn = atoi( t[1] ) ; + printf("%3d. %s is dummy arg %d of %s (%s);\n", recursion_level+1, vname, argn+1, rout, sourcefile ) ; + found_var = 1 ; + fclose( ROUT ) ; + sprintf(fname,"%s/calls", DBDIR ) ; + strcpy( rout2, rout ) ; + if (( CALLERS = fopen( fname , "r" )) == NULL ) return ; + while ( fgets( inln2, INLINELEN, CALLERS ) != NULL ) { + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( u[i] , "" ) ; + get_token_n( inln2, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ; + } + if ( COMPARE2( u[2], rout2 ) ) { + strcpy( rout , u[0] ) ; + sprintf( fname, "%s/%s", DBDIR, rout ) ; + if (( ROUT = fopen( fname, "r" )) == NULL ) return ; + strcpy ( sourcefile_caller, "" ) ; + callno = 1 ; + more_calls = 0 ; + while ( fgets( inln3, INLINELEN, ROUT ) != NULL ) { + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( v[i] , "" ) ; + get_token_n( inln3, " ", i , v[i] ) ; remove_nl(v[i]) ; lower_case_str( v[i] ) ; + } + if ( COMPARE2( v[0] , "sourcefile" ) ) { + strcpy( sourcefile_caller, v[1] ) ; + } else if ( COMPARE2( v[0] , "actarg") && ( COMPARE2( v[4] , rout2 ) && atoi( v[1] ) == argn )) { + if ( callno == 1 || sw_all ) { + printf(" corresponding actual arg is %s, arg number %d in call %d by %s (%s).
\n", + v[6],argn,callno,rout2,sourcefile_caller) ; + /* RECURSION */ + wrfvar ( v[6], rout, recursion_level+1 ) ; + } else if ( callno >= 2 ) { + more_calls = callno ; + } + callno++ ; + } + } + fclose( ROUT ) ; + if ( more_calls > 1 && recursion_level == 0 ) { + printf(" there are %d more calls to %s from %s. Try 'wrfvar %s %s all' to see all.\n", more_calls, rout2, rout, vname, rout2 ) ; + } + } + } + fclose( CALLERS ) ; + } else if ( COMPARE2( t[3] , vname ) && COMPARE2( t[9] , "registry" ) ) { + /* RECURSION */ + sprintf(tmp, "grid%%s", vname ) ; + wrfvar ( vname, "registry", recursion_level+1 ) ; + found_var = 1 ; + } + } + } + } + if ( found_var == 0 ) { + if ( contains_i1_declarations ) { + /* take a look in the registry for i1 vars that might match */ + wrfvar ( vname, "registry_i1", recursion_level ) ; /* recursion level does not increase here, since we're checking the registry */ + } else { + printf("%s is not an argument to %s. May be local or use-associated.\n",vname,rout1 ) ; + printf("%s has %d arguments\n",rout1,nargs_rout) ; + fclose(ROUT) ; + if (( ROUT = fopen( routfile , "r" )) == NULL ) return ; + while ( fgets( inln2, INLINELEN, ROUT ) != NULL ) { + remove_nl( inln2 ) ; + /* find first non space */ + for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( r[i] , "" ) ; + get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; lower_case_str( r[i] ) ; + } + if ( COMPARE2( r[0] , "arg" ) ) { + i = atoi(r[1]) + 1 ; + printf("%3d. ",i) ; + printf("%s of type %s intent %s\n",r[3],r[5],r[7]) ; + } + } + fclose( ROUT ) ; + } + } + +/* get a list of the routines this guy calls */ + + if ( recursion_level == 0 ) { + first_time = 1 ; + if (( BBB = fopen( routfile, "r" )) == NULL ) return ; + while ( fgets( inln2, INLINELEN, BBB ) != NULL ) { + remove_nl( inln2 ) ; + /* find first non space */ + for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( t[i] , "" ) ; + get_token_n( inln2, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ; + } + if ( COMPARE2( t[0] , rout1 ) && COMPARE2( t[1] , "calls" ) ) { + strcpy( hamuna , t[2] ) ; + } else if ( COMPARE2( t[0] , "actarg" ) && COMPARE2( t[6] , vname ) ) { + if ( first_time ) { + printf("\n

%s is an actual arg in calls to these routines from %s

\n",vname,rout1) ; + first_time = 0 ; + } + sprintf(fname,"%s/%s",DBDIR,hamuna) ; + if (( ELEF = fopen ( fname , "r" )) == NULL ) continue ; + while ( fgets( inln3, INLINELEN, ELEF ) != NULL ) { + remove_nl( inln3 ) ; + /* find first non space */ + for ( p = inln3 ; *p ; p++ ) { if ( *p != ' ' ) break ; } + /* change multiple spaces to single space */ + for ( q = p, q1 = q , prev = *p ; *q ; q++ ) + { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } } + for ( i = 0 ; i < 11 ; i++ ) { + strcpy( u[i] , "" ) ; + get_token_n( inln3, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ; + } + if ( COMPARE2( u[0] , "arg" ) && COMPARE2( u[1] , t[1] ) ) { + strcpy( darg , u[3] ) ; + strcpy( dintent , u[7] ) ; + break ; + } + } + fclose( ELEF ) ; + printf(" %s (argument %d ; matching dummy arg is %s with intent %s)\n",hamuna,atoi(t[1])+1,darg,dintent ) ; + } + } + printf("\n") ; + fclose(BBB) ; + } +} + + + +#if 0 +#!/bin/perl + +$dbdir = "tools/code_dbase" ; + +if ( ! opendir( TOOLDIR, "tools") ) { +print "\nMust be in top level WRF directory\n" ; +exit ; +} +closedir TOOLDIR ; + +if ( (scalar @ARGV < 1 || scalar @ARGV > 3) || (scalar @ARGV == 1 && @ARGV[0] ne "rebuild") ) { +print "usage: wrfvar varname routinename \n" ; +print " wrfvar rebuild \n" ; +exit ; +} + + +if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" ) +{ + print "Building code database ... please wait.\n" ; + system( "cd tools/CodeBase ; make" ) ; + $rc = system( "tools/build_codebase" ) ; + + if ( ($rc >> 8) == 99 ) { exit ; } + system( "ln -sf tools/wrfvar ." ) ; + system( "ln -sf tools/subinfo ." ) ; + + if ( $ARGV[0] eq "rebuild" ) { exit ; } +} + + +$vname = lc $ARGV[0] ; +$vname1 = $vname ; +$rout1 = lc $ARGV[1] ; +$recursion_level = $ARGV[2] ; +$rout = $rout1 ; +#print $vname,"\n" ; +#print $rout,"\n" ; + +$spc = "`" ; +$vv = $vname ; +$vv =~ s/\(.*// ; +#print $vv,"\n" ; +if ( substr($vv,0,5) eq "grid%" ) { + open REGISTRY, "< Registry/Registry" or die "cannot open Registry/Registry" ; + while ( ) { + + $line = $_ ; + $line =~ s/#.*// ; + next if ( $line eq "" ) ; + $line =~ s/[ \t][ \t]*/ /g ; + $line = lc $line ; + # fill in the blanks in quote delimited strings then remove + # the quotes so we can split on white space + + $inquote = 0 ; + $newline = "" ; + for ( $i = 0 ; $i < length($line) ; $i++ ) + { + $ccc = substr($line,$i,1) ; + if ( ! $inquote && $ccc eq '"' ) { $inquote = 1 ; } + elsif ( $inquote && $ccc eq '"' ) { $inquote = 0 ; } + if ( $ccc eq " " && $inquote ) { $newline = $newline.$spc ; } + else { $newline = $newline.$ccc ; } + } + $line = $newline ; + $line =~ s/\"//g ; + + @r = split ( ' ',$line ) ; + if ( ($r[0] eq state ) ) { + if (( substr($r[4],0,4) eq "dyn_" && + substr($r[4],4,length($r[4])-4)."_" eq substr($vv,5,length($r[4])-4)."_" && + substr($vv,5+length($r[4])-4+1,length($r[2]))) eq $r[2] ) { + + $r[9] =~ s/`/ /g ; + $r[9] = uc $r[9] ; + $r[10] =~ s/`/ /g ; + $r[10] = uc $r[10] ; + print "** Registry Definition: $r[0] $r[1] ", uc $r[2]," \"$r[9]\" \"$r[10]\"\n" + } + } + } + close REGISTRY ; + exit ; +} + +$routfile = $dbdir."/".$rout ; +open ROUT, "< $routfile" or die "can not open $routfile" ; + +$sourcefile = "" ; +$found_var = 0 ; +$nargs_rout = 0 ; +while ( ) +{ + s/^ *// ; + s/ */ /g ; + @t = split ' ' ; + if ( $t[0] eq "sourcefile" ) { + $sourcefile = $t[1] ; + } elsif ( $t[0] eq "arg" ) { + $nargs_rout++ ; + if ( $t[3] eq $vname && $t[9] ne "registry" ) { + $argn = $t[1] ; + print " ",uc $vname," is dummy argument $argn of $rout ($sourcefile)\n" ; + $found_var = 1 ; + close ROUT ; + system( "sort -u $dbdir/calls > /tmp/wrfvar-sort ; /bin/mv /tmp/wrfvar-sort $dbdir/calls" ) ; + open CALLERS, "< $dbdir/calls" ; + $rout2 = $rout ; + while ( ) { + @u = split ' ' ; + if ( $u[2] eq $rout2 ) + { + $rout = $u[0] ; + $routfile = $dbdir."/".$rout ; + open ROUT, "< $routfile" or die "can not open $routfile" ; + $sourcefile_caller = "" ; + $callno = 1 ; + while ( ) { + @v = split ' ' ; + if ( $v[0] eq "sourcefile" ) { + $sourcefile_caller = $v[1] ; + } elsif ( $v[0] eq 'actarg' && $v[4] eq $rout2 && $v[1] eq $argn ) { + print ucfirst $rout2," call $callno by $rout ($sourcefile_caller) with actual argument $argn: ",uc $v[6],"\n" ; + $callno++ ; + $vname = $v[6] ; + ############## RECURSION ############## + @sysargs = ( "tools/wrfvar" , $v[6], $rout, $recursion_level+1 ) ; + system( @sysargs ) ; + } + } + close ( ROUT ) ; + } + } + close ( CALLERS ) ; + } elsif ( $t[3] eq $vname && $t[9] eq "registry" ) { + @sysargs = ( "tools/wrfvar" , "grid%".$vname, "registry", $recursion_level+1 ) ; + ############## RECURSION ############## + system( @sysargs ) ; + $found_var = 1 ; + } + } +} + +if ( $found_var == 0 ) { + print uc $vname , " is not an argument to ${rout1}. May be local or use-associated.\n" ; + print ucfirst $rout1," has $nargs_rout arguments.\n" ; + close ROUT ; + open ROUT, "< $routfile" or die "can not open $routfile" ; + while ( ) + { + s/^ *// ; + s/ */ /g ; + @t = split ' ' ; + if ( $t[0] eq "arg" ) { + $i = $t[1] + 1 ; + printf("%3d. ",$i) ; + print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ; + } + } + close ROUT ; +} + +# get a list of the routines this guy calls + +if ( $recursion_level == 0 ) { +$first_time = 1 ; +open BBB, "< $dbdir/$rout1" or die " cannot open $dbdir/$rout1" ; +while ( ) { + @t = split ' ' ; + if ( $t[0] eq "$rout1" && $t[1] eq calls ) { + $hamuna = $t[2] ; + } elsif ( $t[0] eq "actarg" && $t[6] eq $vname1 ) { + if ( $first_time == 1 ) { + print "\n",uc $vname1," is an actual argument in calls to these routines from ",uc $rout1," :\n" ; + $first_time = 0 ; + } + open ELEF,"< $dbdir/$hamuna" or die "cannot open $dbdir/$hamuna" ; + while ( ) { + @u = split ' ' ; + if ( $u[0] eq arg && $u[1] eq $t[1] ) { + $darg = $u[3] ; + $dintent = $u[7] ; + } + } + close ELEF ; + print " ", $hamuna," (argument ",$t[1]+1," ; matching dummy arg is ",uc $darg," with intent ",uc $dintent,") \n" ; + } +} +print "\n" ; +close BBB ; +} +exit ; + +#endif + diff --git a/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.csh b/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.csh new file mode 100755 index 00000000..0ec862d2 --- /dev/null +++ b/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.csh @@ -0,0 +1,89 @@ +#!/bin/csh +# +# DOMAIN_TIME_TEST.csh wrf_ascii_output test_case +# +# Extract domain self-test results from WRF ASCII output file +# "wrf_ascii_output" and compare with known-good results, echoing +# "PASS" iff results match. Note that these tests are normally turned off +# but may be enabled by setting namelist variable self_test_domain to .true. +# in namelist /time_control/ . This script looks in the directory in which +# it resides to locate files that contain known-good test output. Second +# argument "test_case" is used to determine which known-good file to compare +# against via the naming convention: +# DOMAIN_TIME_TEST.${test_case}.correct +# +# If the test passes, the following string is echoed by itself: +# "PASS DOMAIN_TIME_TEST.csh $test_case" +# +# If the test fails, the following string is echoed along with other +# diagnostics: +# "FAIL DOMAIN_TIME_TEST.csh $test_case" +# +# In the event of an error (file not found, etc.) the following string is +# echoed along with other diagnostics: +# "ERROR DOMAIN_TIME_TEST.csh $test_case" +# Note that in this case, $test_case is left off if not specified as an +# argument. +# +# This script must be run using a fully-qualified path as it deduces the +# location of correct test results from this path. +# +# EXAMPLE (running from test/em_real): +# >> ../../tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.csh rsl.out.0000 jan00_12hr +# PASS DOMAIN_TIME_TEST.csh jan00_12hr +# +# +# AUTHOR: +# Tom Henderson NCAR/MMM +# +# DATE: +# 20060316 +# + +set selflong = $0 +set self = $selflong:t +set scriptdir = $selflong:h + +if ( $#argv != 2 ) then + echo "ERROR ${self}" + echo "ERROR: Must specify a WRF ASCII output file as first argument and " + echo "ERROR: name of test case as second argument." + echo "USAGE: ${self} wrf_ascii_output test_case" + echo "EXAMPLE: ${selflong} rsl.out.0000 jan00_12hr" + exit 10 +endif + +set ascii_file = $1 +set test_case = $2 +set pid = $$ +set correct_file = "${scriptdir}/DOMAIN_TIME_TEST.${test_case}.correct" +set tmp_file = "DOMAIN_TIME_TEST.${test_case}.${pid}.tmp" + +if ( ! -f $ascii_file ) then + echo "ERROR ${self} ${test_case}" + echo "ERROR: could not find WRF ASCII output file ${ascii_file}" + exit 20 +endif +if ( ! -f $correct_file ) then + echo "ERROR ${self} ${test_case}" + echo "ERROR: could not find correct test results file ${correct_file}" + exit 30 +endif + +\rm -f ${tmp_file} +grep DOMAIN_TIME_TEST $ascii_file >! ${tmp_file} || echo "ERROR ${self} ${test_case}: could not grep file ${ascii_file}" && exit 40 + +if ( ! `diff ${correct_file} ${tmp_file} | wc -c` ) then + echo "PASS ${self} ${test_case}" + \rm -f ${tmp_file} +else + echo "FAIL ${self} ${test_case}" + echo "FAIL: Differences follow:" + echo "diff ${correct_file} ${tmp_file}" + diff ${correct_file} ${tmp_file} + \rm -f ${tmp_file} + exit 50 +endif + +exit 0 + diff --git a/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.jan00_12hr.correct b/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.jan00_12hr.correct new file mode 100644 index 00000000..a588b0bf --- /dev/null +++ b/wrfv2_fire/tools/DOMAIN_TIME_TEST/DOMAIN_TIME_TEST.jan00_12hr.correct @@ -0,0 +1,1445 @@ + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000001 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.502083 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 3.000000 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:03:00 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:03:00 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:003:000 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: simulationStartTime = 2000-01-24_12:00:00 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: start_timestr = 2000-01-24_12:00:00 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: stop_timestr = 2000-01-25_00:00:00 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: time_stepstr = 0000000000_000:003:000 + d01 2000-01-24_12:03:00 DOMAIN_TIME_TEST domain_clockadvance: time_stepstr_frac = 0000000000_000:003:000 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000002 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.504168 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 6.000000 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:06:00 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:06:00 + d01 2000-01-24_12:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:006:000 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000003 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.506250 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 9.000000 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:09:00 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:09:00 + d01 2000-01-24_12:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:009:000 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000004 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.508333 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 12.000000 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:12:00 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:12:00 + d01 2000-01-24_12:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:012:000 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000005 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.510416 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 15.000000 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:15:00 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:15:00 + d01 2000-01-24_12:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:015:000 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000006 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.512501 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 18.000000 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:18:00 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:18:00 + d01 2000-01-24_12:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:018:000 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000007 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.514584 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 21.000000 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:21:00 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:21:00 + d01 2000-01-24_12:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:021:000 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000008 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.516666 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 24.000000 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:24:00 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:24:00 + d01 2000-01-24_12:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:024:000 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000009 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.518749 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 27.000000 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:27:00 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:27:00 + d01 2000-01-24_12:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:027:000 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000010 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.520834 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 30.000000 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:30:00 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:30:00 + d01 2000-01-24_12:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:030:000 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000011 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.522917 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 33.000000 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:33:00 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:33:00 + d01 2000-01-24_12:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:033:000 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000012 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.525000 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 36.000000 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:36:00 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:36:00 + d01 2000-01-24_12:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:036:000 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000013 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.527082 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 39.000000 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:39:00 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:39:00 + d01 2000-01-24_12:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:039:000 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000014 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.529167 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 42.000000 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:42:00 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:42:00 + d01 2000-01-24_12:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:042:000 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000015 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.531250 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 45.000000 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:45:00 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:45:00 + d01 2000-01-24_12:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:045:000 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000016 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.533333 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 48.000000 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:48:00 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:48:00 + d01 2000-01-24_12:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:048:000 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000017 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.535418 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 51.000000 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:51:00 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:51:00 + d01 2000-01-24_12:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:051:000 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000018 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.537500 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 54.000000 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:54:00 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:54:00 + d01 2000-01-24_12:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:054:000 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000019 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.539583 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 57.000000 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_12:57:00 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_12:57:00 + d01 2000-01-24_12:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_000:057:000 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000020 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.541666 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 60.000000 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:00:00 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:00:00 + d01 2000-01-24_13:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:000:000 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000021 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.543751 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 63.000000 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:03:00 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:03:00 + d01 2000-01-24_13:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:003:000 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000022 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.545834 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 66.000000 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:06:00 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:06:00 + d01 2000-01-24_13:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:006:000 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000023 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.547916 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 69.000000 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:09:00 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:09:00 + d01 2000-01-24_13:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:009:000 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000024 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.549999 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 72.000000 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:12:00 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:12:00 + d01 2000-01-24_13:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:012:000 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000025 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.552084 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 75.000000 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:15:00 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:15:00 + d01 2000-01-24_13:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:015:000 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000026 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.554167 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 78.000000 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:18:00 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:18:00 + d01 2000-01-24_13:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:018:000 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000027 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.556250 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 81.000000 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:21:00 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:21:00 + d01 2000-01-24_13:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:021:000 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000028 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.558332 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 84.000000 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:24:00 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:24:00 + d01 2000-01-24_13:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:024:000 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000029 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.560417 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 87.000000 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:27:00 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:27:00 + d01 2000-01-24_13:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:027:000 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000030 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.562500 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 90.000000 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:30:00 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:30:00 + d01 2000-01-24_13:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:030:000 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000031 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.564583 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 93.000000 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:33:00 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:33:00 + d01 2000-01-24_13:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:033:000 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000032 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.566668 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 96.000000 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:36:00 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:36:00 + d01 2000-01-24_13:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:036:000 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000033 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.568750 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 99.000000 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:39:00 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:39:00 + d01 2000-01-24_13:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:039:000 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000034 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.570833 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 102.000000 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:42:00 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:42:00 + d01 2000-01-24_13:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:042:000 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000035 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.572916 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 105.000000 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:45:00 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:45:00 + d01 2000-01-24_13:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:045:000 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000036 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.575001 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 108.000000 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:48:00 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:48:00 + d01 2000-01-24_13:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:048:000 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000037 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.577084 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 111.000000 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:51:00 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:51:00 + d01 2000-01-24_13:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:051:000 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000038 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.579166 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 114.000000 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:54:00 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:54:00 + d01 2000-01-24_13:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:054:000 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000039 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.581249 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 117.000000 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_13:57:00 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_13:57:00 + d01 2000-01-24_13:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_001:057:000 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000040 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.583334 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 120.000000 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:00:00 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:00:00 + d01 2000-01-24_14:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:000:000 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000041 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.585417 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 123.000000 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:03:00 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:03:00 + d01 2000-01-24_14:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:003:000 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000042 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.587500 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 126.000000 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:06:00 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:06:00 + d01 2000-01-24_14:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:006:000 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000043 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.589582 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 129.000000 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:09:00 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:09:00 + d01 2000-01-24_14:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:009:000 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000044 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.591667 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 132.000000 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:12:00 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:12:00 + d01 2000-01-24_14:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:012:000 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000045 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.593750 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 135.000000 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:15:00 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:15:00 + d01 2000-01-24_14:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:015:000 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000046 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.595833 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 138.000000 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:18:00 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:18:00 + d01 2000-01-24_14:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:018:000 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000047 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.597918 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 141.000000 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:21:00 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:21:00 + d01 2000-01-24_14:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:021:000 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000048 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.600000 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 144.000000 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:24:00 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:24:00 + d01 2000-01-24_14:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:024:000 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000049 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.602083 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 147.000000 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:27:00 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:27:00 + d01 2000-01-24_14:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:027:000 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000050 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.604166 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 150.000000 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:30:00 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:30:00 + d01 2000-01-24_14:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:030:000 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000051 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.606251 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 153.000000 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:33:00 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:33:00 + d01 2000-01-24_14:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:033:000 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000052 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.608334 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 156.000000 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:36:00 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:36:00 + d01 2000-01-24_14:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:036:000 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000053 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.610416 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 159.000000 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:39:00 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:39:00 + d01 2000-01-24_14:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:039:000 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000054 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.612499 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 162.000000 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:42:00 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:42:00 + d01 2000-01-24_14:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:042:000 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000055 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.614584 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 165.000000 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:45:00 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:45:00 + d01 2000-01-24_14:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:045:000 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000056 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.616667 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 168.000000 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:48:00 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:48:00 + d01 2000-01-24_14:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:048:000 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000057 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.618750 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 171.000000 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:51:00 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:51:00 + d01 2000-01-24_14:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:051:000 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000058 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.620832 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 174.000000 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:54:00 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:54:00 + d01 2000-01-24_14:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:054:000 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000059 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.622917 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 177.000000 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_14:57:00 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_14:57:00 + d01 2000-01-24_14:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_002:057:000 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000060 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.625000 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 180.000000 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:00:00 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:00:00 + d01 2000-01-24_15:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:000:000 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000061 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.627083 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 183.000000 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:03:00 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:03:00 + d01 2000-01-24_15:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:003:000 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000062 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.629168 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 186.000000 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:06:00 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:06:00 + d01 2000-01-24_15:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:006:000 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000063 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.631250 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 189.000000 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:09:00 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:09:00 + d01 2000-01-24_15:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:009:000 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000064 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.633333 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 192.000000 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:12:00 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:12:00 + d01 2000-01-24_15:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:012:000 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000065 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.635416 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 195.000000 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:15:00 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:15:00 + d01 2000-01-24_15:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:015:000 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000066 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.637501 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 198.000000 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:18:00 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:18:00 + d01 2000-01-24_15:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:018:000 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000067 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.639584 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 201.000000 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:21:00 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:21:00 + d01 2000-01-24_15:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:021:000 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000068 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.641666 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 204.000000 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:24:00 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:24:00 + d01 2000-01-24_15:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:024:000 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000069 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.643749 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 207.000000 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:27:00 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:27:00 + d01 2000-01-24_15:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:027:000 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000070 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.645834 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 210.000000 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:30:00 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:30:00 + d01 2000-01-24_15:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:030:000 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000071 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.647917 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 213.000000 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:33:00 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:33:00 + d01 2000-01-24_15:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:033:000 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000072 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.650000 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 216.000000 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:36:00 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:36:00 + d01 2000-01-24_15:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:036:000 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000073 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.652082 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 219.000000 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:39:00 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:39:00 + d01 2000-01-24_15:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:039:000 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000074 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.654167 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 222.000000 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:42:00 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:42:00 + d01 2000-01-24_15:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:042:000 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000075 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.656250 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 225.000000 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:45:00 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:45:00 + d01 2000-01-24_15:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:045:000 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000076 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.658333 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 228.000000 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:48:00 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:48:00 + d01 2000-01-24_15:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:048:000 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000077 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.660418 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 231.000000 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:51:00 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:51:00 + d01 2000-01-24_15:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:051:000 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000078 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.662500 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 234.000000 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:54:00 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:54:00 + d01 2000-01-24_15:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:054:000 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000079 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.664583 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 237.000000 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_15:57:00 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_15:57:00 + d01 2000-01-24_15:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_003:057:000 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000080 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.666666 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 240.000000 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:00:00 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:00:00 + d01 2000-01-24_16:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:000:000 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000081 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.668751 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 243.000000 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:03:00 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:03:00 + d01 2000-01-24_16:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:003:000 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000082 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.670834 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 246.000000 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:06:00 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:06:00 + d01 2000-01-24_16:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:006:000 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000083 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.672916 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 249.000000 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:09:00 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:09:00 + d01 2000-01-24_16:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:009:000 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000084 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.674999 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 252.000000 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:12:00 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:12:00 + d01 2000-01-24_16:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:012:000 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000085 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.677084 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 255.000000 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:15:00 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:15:00 + d01 2000-01-24_16:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:015:000 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000086 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.679167 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 258.000000 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:18:00 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:18:00 + d01 2000-01-24_16:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:018:000 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000087 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.681250 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 261.000000 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:21:00 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:21:00 + d01 2000-01-24_16:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:021:000 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000088 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.683332 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 264.000000 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:24:00 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:24:00 + d01 2000-01-24_16:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:024:000 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000089 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.685417 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 267.000000 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:27:00 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:27:00 + d01 2000-01-24_16:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:027:000 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000090 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.687500 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 270.000000 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:30:00 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:30:00 + d01 2000-01-24_16:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:030:000 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000091 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.689583 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 273.000000 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:33:00 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:33:00 + d01 2000-01-24_16:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:033:000 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000092 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.691668 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 276.000000 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:36:00 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:36:00 + d01 2000-01-24_16:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:036:000 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000093 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.693750 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 279.000000 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:39:00 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:39:00 + d01 2000-01-24_16:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:039:000 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000094 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.695833 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 282.000000 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:42:00 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:42:00 + d01 2000-01-24_16:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:042:000 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000095 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.697916 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 285.000000 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:45:00 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:45:00 + d01 2000-01-24_16:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:045:000 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000096 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.700001 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 288.000000 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:48:00 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:48:00 + d01 2000-01-24_16:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:048:000 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000097 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.702084 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 291.000000 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:51:00 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:51:00 + d01 2000-01-24_16:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:051:000 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000098 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.704166 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 294.000000 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:54:00 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:54:00 + d01 2000-01-24_16:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:054:000 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000099 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.706249 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 297.000000 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_16:57:00 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_16:57:00 + d01 2000-01-24_16:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_004:057:000 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000100 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.708334 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 300.000000 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:00:00 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:00:00 + d01 2000-01-24_17:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:000:000 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000101 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.710417 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 303.000000 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:03:00 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:03:00 + d01 2000-01-24_17:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:003:000 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000102 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.712500 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 306.000000 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:06:00 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:06:00 + d01 2000-01-24_17:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:006:000 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000103 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.714582 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 309.000000 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:09:00 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:09:00 + d01 2000-01-24_17:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:009:000 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000104 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.716667 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 312.000000 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:12:00 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:12:00 + d01 2000-01-24_17:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:012:000 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000105 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.718750 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 315.000000 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:15:00 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:15:00 + d01 2000-01-24_17:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:015:000 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000106 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.720833 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 318.000000 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:18:00 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:18:00 + d01 2000-01-24_17:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:018:000 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000107 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.722918 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 321.000000 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:21:00 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:21:00 + d01 2000-01-24_17:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:021:000 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000108 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.725000 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 324.000000 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:24:00 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:24:00 + d01 2000-01-24_17:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:024:000 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000109 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.727083 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 327.000000 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:27:00 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:27:00 + d01 2000-01-24_17:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:027:000 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000110 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.729166 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 330.000000 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:30:00 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:30:00 + d01 2000-01-24_17:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:030:000 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000111 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.731251 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 333.000000 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:33:00 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:33:00 + d01 2000-01-24_17:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:033:000 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000112 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.733334 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 336.000000 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:36:00 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:36:00 + d01 2000-01-24_17:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:036:000 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000113 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.735416 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 339.000000 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:39:00 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:39:00 + d01 2000-01-24_17:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:039:000 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000114 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.737499 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 342.000000 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:42:00 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:42:00 + d01 2000-01-24_17:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:042:000 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000115 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.739584 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 345.000000 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:45:00 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:45:00 + d01 2000-01-24_17:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:045:000 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000116 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.741667 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 348.000000 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:48:00 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:48:00 + d01 2000-01-24_17:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:048:000 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000117 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.743750 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 351.000000 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:51:00 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:51:00 + d01 2000-01-24_17:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:051:000 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000118 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.745832 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 354.000000 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:54:00 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:54:00 + d01 2000-01-24_17:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:054:000 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000119 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.747917 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 357.000000 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_17:57:00 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_17:57:00 + d01 2000-01-24_17:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_005:057:000 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000120 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.750000 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 360.000000 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:00:00 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:00:00 + d01 2000-01-24_18:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:000:000 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000121 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.752083 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 363.000000 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:03:00 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:03:00 + d01 2000-01-24_18:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:003:000 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000122 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.754168 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 366.000000 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:06:00 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:06:00 + d01 2000-01-24_18:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:006:000 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000123 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.756250 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 369.000000 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:09:00 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:09:00 + d01 2000-01-24_18:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:009:000 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000124 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.758333 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 372.000000 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:12:00 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:12:00 + d01 2000-01-24_18:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:012:000 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000125 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.760416 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 375.000000 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:15:00 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:15:00 + d01 2000-01-24_18:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:015:000 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000126 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.762501 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 378.000000 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:18:00 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:18:00 + d01 2000-01-24_18:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:018:000 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000127 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.764584 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 381.000000 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:21:00 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:21:00 + d01 2000-01-24_18:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:021:000 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000128 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.766666 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 384.000000 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:24:00 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:24:00 + d01 2000-01-24_18:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:024:000 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000129 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.768749 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 387.000000 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:27:00 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:27:00 + d01 2000-01-24_18:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:027:000 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000130 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.770834 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 390.000000 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:30:00 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:30:00 + d01 2000-01-24_18:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:030:000 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000131 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.772917 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 393.000000 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:33:00 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:33:00 + d01 2000-01-24_18:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:033:000 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000132 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.775000 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 396.000000 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:36:00 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:36:00 + d01 2000-01-24_18:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:036:000 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000133 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.777082 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 399.000000 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:39:00 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:39:00 + d01 2000-01-24_18:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:039:000 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000134 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.779167 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 402.000000 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:42:00 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:42:00 + d01 2000-01-24_18:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:042:000 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000135 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.781250 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 405.000000 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:45:00 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:45:00 + d01 2000-01-24_18:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:045:000 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000136 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.783333 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 408.000000 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:48:00 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:48:00 + d01 2000-01-24_18:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:048:000 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000137 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.785418 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 411.000000 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:51:00 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:51:00 + d01 2000-01-24_18:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:051:000 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000138 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.787500 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 414.000000 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:54:00 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:54:00 + d01 2000-01-24_18:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:054:000 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000139 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.789583 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 417.000000 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_18:57:00 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_18:57:00 + d01 2000-01-24_18:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_006:057:000 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000140 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.791666 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 420.000000 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:00:00 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:00:00 + d01 2000-01-24_19:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:000:000 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000141 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.793751 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 423.000000 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:03:00 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:03:00 + d01 2000-01-24_19:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:003:000 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000142 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.795834 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 426.000000 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:06:00 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:06:00 + d01 2000-01-24_19:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:006:000 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000143 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.797916 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 429.000000 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:09:00 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:09:00 + d01 2000-01-24_19:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:009:000 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000144 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.799999 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 432.000000 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:12:00 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:12:00 + d01 2000-01-24_19:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:012:000 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000145 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.802084 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 435.000000 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:15:00 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:15:00 + d01 2000-01-24_19:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:015:000 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000146 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.804167 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 438.000000 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:18:00 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:18:00 + d01 2000-01-24_19:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:018:000 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000147 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.806250 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 441.000000 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:21:00 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:21:00 + d01 2000-01-24_19:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:021:000 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000148 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.808332 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 444.000000 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:24:00 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:24:00 + d01 2000-01-24_19:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:024:000 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000149 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.810417 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 447.000000 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:27:00 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:27:00 + d01 2000-01-24_19:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:027:000 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000150 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.812500 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 450.000000 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:30:00 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:30:00 + d01 2000-01-24_19:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:030:000 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000151 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.814583 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 453.000000 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:33:00 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:33:00 + d01 2000-01-24_19:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:033:000 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000152 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.816668 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 456.000000 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:36:00 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:36:00 + d01 2000-01-24_19:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:036:000 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000153 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.818750 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 459.000000 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:39:00 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:39:00 + d01 2000-01-24_19:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:039:000 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000154 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.820833 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 462.000000 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:42:00 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:42:00 + d01 2000-01-24_19:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:042:000 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000155 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.822916 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 465.000000 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:45:00 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:45:00 + d01 2000-01-24_19:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:045:000 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000156 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.825001 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 468.000000 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:48:00 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:48:00 + d01 2000-01-24_19:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:048:000 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000157 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.827084 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 471.000000 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:51:00 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:51:00 + d01 2000-01-24_19:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:051:000 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000158 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.829166 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 474.000000 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:54:00 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:54:00 + d01 2000-01-24_19:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:054:000 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000159 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.831249 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 477.000000 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_19:57:00 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_19:57:00 + d01 2000-01-24_19:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_007:057:000 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000160 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.833334 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 480.000000 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:00:00 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:00:00 + d01 2000-01-24_20:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:000:000 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000161 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.835417 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 483.000000 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:03:00 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:03:00 + d01 2000-01-24_20:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:003:000 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000162 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.837500 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 486.000000 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:06:00 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:06:00 + d01 2000-01-24_20:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:006:000 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000163 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.839582 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 489.000000 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:09:00 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:09:00 + d01 2000-01-24_20:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:009:000 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000164 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.841667 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 492.000000 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:12:00 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:12:00 + d01 2000-01-24_20:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:012:000 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000165 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.843750 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 495.000000 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:15:00 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:15:00 + d01 2000-01-24_20:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:015:000 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000166 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.845833 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 498.000000 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:18:00 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:18:00 + d01 2000-01-24_20:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:018:000 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000167 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.847918 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 501.000000 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:21:00 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:21:00 + d01 2000-01-24_20:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:021:000 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000168 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.850000 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 504.000000 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:24:00 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:24:00 + d01 2000-01-24_20:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:024:000 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000169 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.852083 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 507.000000 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:27:00 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:27:00 + d01 2000-01-24_20:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:027:000 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000170 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.854166 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 510.000000 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:30:00 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:30:00 + d01 2000-01-24_20:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:030:000 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000171 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.856251 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 513.000000 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:33:00 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:33:00 + d01 2000-01-24_20:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:033:000 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000172 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.858334 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 516.000000 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:36:00 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:36:00 + d01 2000-01-24_20:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:036:000 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000173 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.860416 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 519.000000 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:39:00 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:39:00 + d01 2000-01-24_20:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:039:000 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000174 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.862499 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 522.000000 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:42:00 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:42:00 + d01 2000-01-24_20:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:042:000 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000175 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.864584 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 525.000000 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:45:00 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:45:00 + d01 2000-01-24_20:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:045:000 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000176 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.866667 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 528.000000 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:48:00 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:48:00 + d01 2000-01-24_20:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:048:000 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000177 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.868750 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 531.000000 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:51:00 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:51:00 + d01 2000-01-24_20:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:051:000 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000178 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.870832 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 534.000000 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:54:00 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:54:00 + d01 2000-01-24_20:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:054:000 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000179 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.872917 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 537.000000 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_20:57:00 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_20:57:00 + d01 2000-01-24_20:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_008:057:000 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000180 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.875000 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 540.000000 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:00:00 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:00:00 + d01 2000-01-24_21:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:000:000 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000181 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.877083 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 543.000000 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:03:00 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:03:00 + d01 2000-01-24_21:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:003:000 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000182 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.879168 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 546.000000 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:06:00 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:06:00 + d01 2000-01-24_21:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:006:000 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000183 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.881250 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 549.000000 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:09:00 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:09:00 + d01 2000-01-24_21:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:009:000 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000184 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.883333 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 552.000000 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:12:00 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:12:00 + d01 2000-01-24_21:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:012:000 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000185 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.885416 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 555.000000 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:15:00 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:15:00 + d01 2000-01-24_21:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:015:000 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000186 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.887501 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 558.000000 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:18:00 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:18:00 + d01 2000-01-24_21:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:018:000 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000187 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.889584 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 561.000000 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:21:00 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:21:00 + d01 2000-01-24_21:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:021:000 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000188 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.891666 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 564.000000 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:24:00 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:24:00 + d01 2000-01-24_21:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:024:000 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000189 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.893749 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 567.000000 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:27:00 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:27:00 + d01 2000-01-24_21:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:027:000 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000190 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.895834 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 570.000000 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:30:00 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:30:00 + d01 2000-01-24_21:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:030:000 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000191 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.897917 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 573.000000 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:33:00 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:33:00 + d01 2000-01-24_21:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:033:000 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000192 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.900000 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 576.000000 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:36:00 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:36:00 + d01 2000-01-24_21:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:036:000 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000193 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.902082 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 579.000000 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:39:00 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:39:00 + d01 2000-01-24_21:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:039:000 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000194 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.904167 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 582.000000 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:42:00 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:42:00 + d01 2000-01-24_21:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:042:000 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000195 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.906250 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 585.000000 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:45:00 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:45:00 + d01 2000-01-24_21:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:045:000 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000196 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.908333 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 588.000000 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:48:00 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:48:00 + d01 2000-01-24_21:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:048:000 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000197 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.910418 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 591.000000 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:51:00 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:51:00 + d01 2000-01-24_21:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:051:000 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000198 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.912500 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 594.000000 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:54:00 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:54:00 + d01 2000-01-24_21:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:054:000 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000199 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.914583 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 597.000000 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_21:57:00 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_21:57:00 + d01 2000-01-24_21:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_009:057:000 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000200 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.916666 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 600.000000 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:00:00 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:00:00 + d01 2000-01-24_22:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:000:000 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000201 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.918751 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 603.000000 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:03:00 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:03:00 + d01 2000-01-24_22:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:003:000 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000202 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.920834 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 606.000000 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:06:00 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:06:00 + d01 2000-01-24_22:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:006:000 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000203 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.922916 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 609.000000 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:09:00 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:09:00 + d01 2000-01-24_22:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:009:000 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000204 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.924999 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 612.000000 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:12:00 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:12:00 + d01 2000-01-24_22:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:012:000 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000205 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.927084 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 615.000000 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:15:00 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:15:00 + d01 2000-01-24_22:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:015:000 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000206 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.929167 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 618.000000 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:18:00 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:18:00 + d01 2000-01-24_22:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:018:000 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000207 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.931250 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 621.000000 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:21:00 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:21:00 + d01 2000-01-24_22:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:021:000 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000208 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.933332 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 624.000000 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:24:00 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:24:00 + d01 2000-01-24_22:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:024:000 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000209 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.935417 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 627.000000 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:27:00 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:27:00 + d01 2000-01-24_22:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:027:000 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000210 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.937500 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 630.000000 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:30:00 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:30:00 + d01 2000-01-24_22:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:030:000 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000211 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.939583 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 633.000000 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:33:00 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:33:00 + d01 2000-01-24_22:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:033:000 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000212 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.941668 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 636.000000 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:36:00 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:36:00 + d01 2000-01-24_22:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:036:000 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000213 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.943750 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 639.000000 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:39:00 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:39:00 + d01 2000-01-24_22:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:039:000 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000214 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.945833 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 642.000000 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:42:00 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:42:00 + d01 2000-01-24_22:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:042:000 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000215 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.947916 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 645.000000 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:45:00 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:45:00 + d01 2000-01-24_22:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:045:000 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000216 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.950001 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 648.000000 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:48:00 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:48:00 + d01 2000-01-24_22:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:048:000 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000217 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.952084 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 651.000000 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:51:00 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:51:00 + d01 2000-01-24_22:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:051:000 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000218 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.954166 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 654.000000 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:54:00 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:54:00 + d01 2000-01-24_22:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:054:000 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000219 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.956249 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 657.000000 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_22:57:00 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_22:57:00 + d01 2000-01-24_22:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_010:057:000 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000220 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.958334 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 660.000000 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:00:00 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:00:00 + d01 2000-01-24_23:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:000:000 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000221 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.960417 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 663.000000 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:03:00 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:03:00 + d01 2000-01-24_23:03:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:003:000 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000222 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.962500 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 666.000000 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:06:00 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:06:00 + d01 2000-01-24_23:06:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:006:000 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000223 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.964582 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 669.000000 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:09:00 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:09:00 + d01 2000-01-24_23:09:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:009:000 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000224 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.966667 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 672.000000 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:12:00 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:12:00 + d01 2000-01-24_23:12:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:012:000 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000225 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.968750 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 675.000000 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:15:00 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:15:00 + d01 2000-01-24_23:15:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:015:000 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000226 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.970833 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 678.000000 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:18:00 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:18:00 + d01 2000-01-24_23:18:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:018:000 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000227 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.972918 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 681.000000 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:21:00 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:21:00 + d01 2000-01-24_23:21:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:021:000 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000228 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.975000 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 684.000000 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:24:00 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:24:00 + d01 2000-01-24_23:24:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:024:000 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000229 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.977083 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 687.000000 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:27:00 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:27:00 + d01 2000-01-24_23:27:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:027:000 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000230 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.979166 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 690.000000 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:30:00 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:30:00 + d01 2000-01-24_23:30:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:030:000 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000231 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.981251 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 693.000000 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:33:00 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:33:00 + d01 2000-01-24_23:33:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:033:000 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000232 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.983334 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 696.000000 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:36:00 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:36:00 + d01 2000-01-24_23:36:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:036:000 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000233 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.985416 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 699.000000 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:39:00 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:39:00 + d01 2000-01-24_23:39:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:039:000 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000234 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.987499 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 702.000000 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:42:00 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:42:00 + d01 2000-01-24_23:42:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:042:000 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000235 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.989584 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 705.000000 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:45:00 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:45:00 + d01 2000-01-24_23:45:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:045:000 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000236 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.991667 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 708.000000 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:48:00 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:48:00 + d01 2000-01-24_23:48:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:048:000 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000237 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.993750 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 711.000000 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:51:00 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:51:00 + d01 2000-01-24_23:51:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:051:000 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000238 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.995832 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 714.000000 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:54:00 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:54:00 + d01 2000-01-24_23:54:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:054:000 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000239 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 23.997917 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 717.000000 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-24_23:57:00 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-24_23:57:00 + d01 2000-01-24_23:57:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_011:057:000 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: advanceCount = 00000240 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: currentDayOfYearReal = 24.000000 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: minutesSinceSimulationStart = 720.000000 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr = 2000-01-25_00:00:00 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: current_timestr_frac = 2000-01-25_00:00:00 + d01 2000-01-25_00:00:00 DOMAIN_TIME_TEST domain_clockadvance: timeSinceSimulationStart = 0000000000_012:000:000 diff --git a/wrfv2_fire/tools/Makefile b/wrfv2_fire/tools/Makefile new file mode 100644 index 00000000..bb2102bd --- /dev/null +++ b/wrfv2_fire/tools/Makefile @@ -0,0 +1,44 @@ +.SUFFIXES: .c .o + +CC = cc +CFLAGS = #-ansi +LDFLAGS = +DEBUG = -g +OBJ = registry.o my_strtok.o reg_parse.o data.o type.o misc.o \ + gen_defs.o gen_allocs.o gen_mod_state_descr.o gen_scalar_indices.o \ + gen_args.o gen_config.o sym.o symtab_gen.o gen_wrf_io.o \ + gen_model_data_ord.o gen_interp.o gen_comms.o gen_scalar_derefs.o + +registry : $(OBJ) + $(CC) -o registry $(DEBUG) $(LDFLAGS) $(OBJ) + +.c.o : + $(CC) $(CFLAGS) -c $(DEBUG) $< + +clean: + /bin/rm -f $(OBJ) gen_comms.c + +gen_comms.c : gen_comms.stub + /bin/cp gen_comms.stub gen_comms.c + +# regenerate this list with "makedepend -Y *.c" + +# DO NOT DELETE THIS LINE -- make depend depends on it. + +data.o: registry.h protos.h data.h +gen_allocs.o: protos.h registry.h data.h +gen_args.o: protos.h registry.h data.h +gen_scalar_derefs.o: protos.h registry.h data.h +gen_config.o: protos.h registry.h data.h +gen_defs.o: protos.h registry.h data.h +gen_mod_state_descr.o: protos.h registry.h data.h +gen_model_data_ord.o: protos.h registry.h data.h +gen_scalar_indices.o: protos.h registry.h data.h +gen_wrf_io.o: protos.h registry.h data.h +misc.o: protos.h registry.h data.h +my_strtok.o: registry.h protos.h data.h +reg_parse.o: registry.h protos.h data.h +registry.o: protos.h registry.h data.h +sym.o: sym.h +type.o: registry.h protos.h data.h +gen_interp.o: registry.h protos.h data.h diff --git a/wrfv2_fire/tools/all_reg.csh b/wrfv2_fire/tools/all_reg.csh new file mode 100755 index 00000000..157cca73 --- /dev/null +++ b/wrfv2_fire/tools/all_reg.csh @@ -0,0 +1,583 @@ +#!/bin/csh +unalias rm +unalias cp +unalias mv + +# This script runs a large number of WRF regression tests. On the +# IBM machines (which at NCAR allow queueing), the jobs are sent to +# the queue system via load leveler commands. On all other machines, +# the jobs are sent in sequentially as soon as the process returns +# from completing the previous task. + +# HOW TO RUN +# ---------- + +# DEC +# joshua1 or joshua3 +# mkdir /data3/mp/$USER/`hostname` +# put all_reg.csh, regtest.csh, and wrf.tar in dir +# execute all_reg.csh +# takes about 24-30 h + +# Linux +# joshua1 or joshua3 +# mkdir /data3/mp/$USER/`hostname` +# put all_reg.csh, regtest.csh, and wrf.tar in dir +# execute all_reg.csh +# takes about 36-48 h +# flex lm errors show up as fails to compile + +# AIX +# bluesky or bluevista +# put all_reg.csh, regtest.csh, and wrf.tar in ~ +# execute all_reg.csh +# takes about 8-10 h + +# Unless you are editing the script, no changes are required below + + +#======================================================================= +#======================================================================= + +# What these tests do, must be a single string. + +set NAME = ( "Standard" "NESTED=FALSE" "NESTED=FALSE" "NONE" 1 \ + "Moving_Nest" "NESTED=FALSE" "NESTED=TRUE" "NONE" 2 \ + "Full_Optimization" "REG_TYPE=BIT4BIT" "REG_TYPE=OPTIMIZED" "NONE" 3 \ + "Chemistry" "CHEM=FALSE" "CHEM=TRUE" "NONE" 4 \ + "RSL_LITE" "RSL_LITE=FALSE" "RSL_LITE=TRUE" "NONE" 5 \ + "ESMF_Library" "ESMF_LIB=FALSE" "ESMF_LIB=TRUE" "ONLY_AIX" 6 \ + "Quilting" "QUILT=FALSE" "QUILT=TRUE" "NONE" 7 \ + "Binary_IO" "IO_FORM=2" "IO_FORM=1" "NONE" 8 \ + "GriB1_Output" "IO_FORM=2" "IO_FORM=5" "NONE" 9 \ + "REAL8_Floats" "REAL8=FALSE" "REAL8=TRUE" "NONE" 10 \ + "Moving_Nest2" "COMBO_NEST_RSL__LITE=FALSE" \ + "COMBO_NEST_RSL__LITE=TRUE" \ + "NONE" 11 \ + "FDDA" "FDDA=FALSE" "FDDA=TRUE" "NONE" 12 \ + ) + +# Where are we located. + +set starting_dir = `pwd` + +# Get the tag manually. This is for the auto-report that gets +# sent to the WRF web page on the history of the regression tests. + +set current_year4 = `date -u +"%Y"` +set current_month = `date -u +"%m"` +set current_day = `date -u +"%d"` +set current_hour = `date -u +"%H"` +set current_minute = `date -u +"%M"` +set current_second = `date -u +"%S"` +set datehms = ${current_year4}-${current_month}-${current_day}_${current_hour}:${current_minute}:${current_second}_UTC +set dateh = ${current_year4}${current_month}${current_day}${current_hour} +set date = ${current_year4}${current_month}${current_day} +if ( ! $?TAG ) then + if ( $user == michalak ) then + set initials = jm + else if ( $user == hender ) then + set initials = th + else if ( $user == gill ) then + set initials = dg + else if ( $user == dudhia ) then + set initials = jd + else if ( $user == weiwang ) then + set initials = ww + else + set initials = XX + endif + echo the TAG is NOT defined + echo Please define an environment variable that is the WRFV2 tag + echo Something such as: setenv TAG trunk_${date}_${initials} + echo " " + exit ( 1 ) +endif + +# Are we only interested in the PASS/FAIL report? + +if ( $#argv == 1 ) then + if ( $argv[1] == PASSFAIL ) then + goto PASSFAIL + endif +endif + +# If there are any command line args, they are processed, else +# we run all of the regression tests without a generate or +# compare flag being set. + +if ( $#argv == 0 ) then + + set BASELINE = RUN_ONLY + + set OLD_TEXT + set NEW_TEXT + set TOAST + set tests + set TEST_NUM + set count_test = 1 + while ( $count_test < $#NAME ) + set tests = ( $tests "$NAME[$count_test]" ) + @ count_test ++ + set OLD_TEXT = ( $OLD_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set NEW_TEXT = ( $NEW_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set TOAST = ( $TOAST "$NAME[$count_test]" ) + @ count_test ++ + set TEST_NUM = ( $TEST_NUM "$NAME[$count_test]" ) + @ count_test ++ + end + +# We have some command line args. They are either a request to run +# the test with a generate/compare flag, or a list of tests to perform. + +else + + set INIT_OPTS = ( $* ) + + # First, find the baseline type. This is going to be one of three + # possibilities: GENERATE, COMPARE, or a RUN_ONLY option. The + # default is RUN_ONLY. Only the first baseline option found is + # used. + + set count = 0 + while ( $count < $#INIT_OPTS ) + @ count ++ + set arg = $INIT_OPTS[$count] + if ( ( $arg == GENERATE ) || \ + ( $arg == COMPARE ) || \ + ( $arg == RUN_ONLY ) ) then + set BASELINE = $arg + goto FINISHED_BASELINE_TYPE + endif + end + set BASELINE = RUN_ONLY +FINISHED_BASELINE_TYPE: + + # If there was only one input, and it was telling us to do which type of baseline + # option (GENERATE, COMPARE, RUN_ONLY), we assume they want all of the tests + # conducted. + + if ( $#INIT_OPTS == 1 ) then + if ( ( $INIT_OPTS == GENERATE ) || ( $INIT_OPTS == COMPARE ) || ( $INIT_OPTS == RUN_ONLY ) ) then + set OLD_TEXT + set NEW_TEXT + set TOAST + set tests + set TEST_NUM + set count_test = 1 + while ( $count_test < $#NAME ) + set tests = ( $tests "$NAME[$count_test]" ) + @ count_test ++ + set OLD_TEXT = ( $OLD_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set NEW_TEXT = ( $NEW_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set TOAST = ( $TOAST "$NAME[$count_test]" ) + @ count_test ++ + set TEST_NUM = ( $TEST_NUM "$NAME[$count_test]" ) + @ count_test ++ + end + goto FINISHED_TEST_LIST + endif + endif + + # Find which tests are to be conducted. Loop over all of the + # input, and compare each of the input fields with the list + # of available test names. When a match occurs, increment the + # test found counter, and save the test name. + + set count = 0 + set OLD_TEXT + set NEW_TEXT + set TOAST + set tests + set TEST_NUM + while ( $count < $#INIT_OPTS ) + @ count ++ + set count_test = 1 + while ( $count_test < $#NAME ) + if ( $INIT_OPTS[$count] == $NAME[$count_test] ) then + set tests = ( $tests "$NAME[$count_test]" ) + @ count_test ++ + set OLD_TEXT = ( $OLD_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set NEW_TEXT = ( $NEW_TEXT "$NAME[$count_test]" ) + @ count_test ++ + set TOAST = ( $TOAST "$NAME[$count_test]" ) + @ count_test ++ + set TEST_NUM = ( $TEST_NUM "$NAME[$count_test]" ) + @ count_test ++ + else + @ count_test += 5 + endif + end + end + + # If there are no recognizable tests requested, let them know our concern. + + if ( $#tests == 0 ) then + echo No valid test requested in argument list + exit ( 4 ) + endif +endif +FINISHED_TEST_LIST: + +# A friendly check for the baseline directory existence, and locations for known +# NCAR machines. + +if ( ( $BASELINE == GENERATE ) || ( $BASELINE == COMPARE ) ) then + if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + set SAVE_DIR = /ptmp/${USER}/BASELINE/`uname` + else if ( `uname` == AIX ) then + set SAVE_DIR = /ptmp/${USER}/BASELINE/`uname` + else if ( ( `uname` == OSF1 ) && ( `hostname | cut -c 1-6` == joshua ) ) then + set SAVE_DIR = /data3/mp/${USER}/BASELINE/`uname` + else if ( ( `uname` == Linux ) && ( `hostname` == bay-mmm ) ) then + set SAVE_DIR = /data3/mp/${USER}/BASELINE/`uname` + else + echo Hmm, no idea where to put/get this baseline data, stopping + exit ( 10 ) + endif + + if ( ( -d $SAVE_DIR ) && ( $BASELINE == GENERATE ) ) then + echo "Troubles with SAVE_DIR logic." + echo "$SAVE_DIR should not exist for a $BASELINE run." +# exit ( 2 ) + else if ( ( ! -d $SAVE_DIR ) && ( $BASELINE == COMPARE ) ) then + echo "Troubles with SAVE_DIR logic." + echo "$SAVE_DIR should exist for a $BASELINE run." + exit ( 3 ) + endif +endif + +# We need the regtest.csh file, badly. + +if ( ! -e regtest.csh ) then + echo we need regtest.csh in this dir + echo "supply-ez vous, s'il vous plait" + exit ( 1 ) +endif + +# The regtest.csh file is treated as a template. The following +# strings (first occurrence) is sought (OLD_TEXT) and replaced +# with the modified string (NEW_TEXT). This edited regression +# script is then processed. + +# Any exceptions to where they can run? NONE means no +# exceptions, should run on all machines. AIX/Linux/OSF1 +# means it will NOT run on that single machine. The +# option ONLY_AIX/ONLY_Linux/ONLY_OSF1 means that the option +# ONLY works on that specific architecture. + + +# Loop over all selected tests. + +set count_test = 0 +while ( $count_test < $#tests ) + + @ count_test ++ + + set count = 1 + while ( $count < $#NAME ) + + if ( "$tests[$count_test]" == "$NAME[$count]" ) then + goto FOUND_SELECTED_TEST + endif + @ count += 5 + end + echo "Hmmm, no valid test found" + exit ( 11 ) + +FOUND_SELECTED_TEST: + + # Specifically skip this test on this architecture. + + if ( `uname` == $TOAST[$count_test] ) then + echo skipping test $tests[$count_test] for `uname` specifically + + # Skip this test on this architecture because it ONLY runs + # on a different architecture. + + else if ( ( `echo $TOAST[$count_test] | cut -c 1-5` == ONLY_ ) && ( ONLY_`uname` != $TOAST[$count_test] ) ) then + echo skipping test $tests[$count_test] for `uname`, works on $TOAST[$count_test] + + # OK, we are allowed to run this test on this architecture. + + else if ( ( $TOAST[$count_test] == NONE ) || \ + ( $TOAST[$count_test] != `uname` ) || \ + ( ONLY_`uname` == $TOAST[$count_test] ) ) then + echo doing test $tests[$count_test] for `uname` + + # If this is the generate or compare baseline test, where do we + # save the data to/read the data from. + + if ( ( $BASELINE == GENERATE ) || ( $BASELINE == COMPARE ) ) then + if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + set SAVE_DIR = /ptmp/${USER}/BASELINE/`uname`/$tests[$count_test] + else if ( `uname` == AIX ) then + set SAVE_DIR = /ptmp/${USER}/BASELINE/`uname`/$tests[$count_test] + else if ( ( `uname` == OSF1 ) && ( `hostname | cut -c 1-6` == joshua ) ) then + set SAVE_DIR = /data3/mp/${USER}/BASELINE/`uname`/$tests[$count_test] + else if ( ( `uname` == Linux ) && ( `hostname` == bay-mmm ) ) then + set SAVE_DIR = /data3/mp/${USER}/BASELINE/`uname`/$tests[$count_test] + else + echo No idea where to put the data, stopping + exit ( 2 ) + endif + + # Either zap existing stuff (GENERATE), or make sure it is there (COMPARE) + + if ( $BASELINE == GENERATE ) then + /bin/rm -rf $SAVE_DIR + else if ( ( $BASELINE == COMPARE ) && ( $tests[$count_test] != Full_Optimization ) ) then + if ( ! -d $SAVE_DIR ) then + echo $SAVE_DIR does not exist for BASELINE comparison, stopping + exit ( 3 ) + endif + else if ( ( $BASELINE == COMPARE ) && ( $tests[$count_test] == Full_Optimization ) ) then + echo No comparison done with baseline since this is an optimized run + endif + endif + + # Build the short edit input script for ed and edit the regtest.csh file. + + set OLDT = `echo $OLD_TEXT[$count_test] | sed 's/=/ = /'` + set NEWT = `echo $NEW_TEXT[$count_test] | sed 's/=/ = /'` + + if ( ( $BASELINE == RUN_ONLY ) || ( $tests[$count_test] == Full_Optimization ) ) then + if ( -e ed.in ) rm ed.in + cat >! ed_in << EOF +,s/$OLDT/$NEWT/ +w reg.foo.$TEST_NUM[$count_test].$tests[$count_test] +q +EOF + else if ( $BASELINE == GENERATE ) then + if ( -e ed.in ) rm ed.in + cat >! ed_in << EOF +,s/$OLDT/$NEWT/ +,s?GENERATE_BASELINE = FALSE?GENERATE_BASELINE = $SAVE_DIR? +w reg.foo.$TEST_NUM[$count_test].$tests[$count_test] +q +EOF + else if ( $BASELINE == COMPARE ) then + if ( -e ed.in ) rm ed.in + cat >! ed_in << EOF +,s/$OLDT/$NEWT/ +,s?COMPARE_BASELINE = FALSE?COMPARE_BASELINE = $SAVE_DIR? +w reg.foo.$TEST_NUM[$count_test].$tests[$count_test] +q +EOF + endif + ed regtest.csh < ed_in >& /dev/null + chmod +x reg.foo.$TEST_NUM[$count_test].$tests[$count_test] + + # On AIX, we submit jobs to the load leveler queue for bluesky and to the LSF queue for + # bluevista. After submission, we wait around until it completes, and then we send in + # the next one. + + if ( ( `uname` == AIX ) && ( `hostname | cut -c 1-2` == bs ) ) then + llsubmit reg.foo.$TEST_NUM[$count_test].$tests[$count_test] >&! llsub.out + set ok = 0 + set in_already = 0 + while ( $ok == 0 ) + sleep 10 ; llq -u $USER >&! llq.report + grep `cat llsub.out | grep '"bs1' | cut -d\" -f2` llq.report >& /dev/null + set ok = $status + if ( ( $ok == 0 ) && ( $in_already == 0 ) ) then + set in_already = 1 + set joe_id = `cat llsub.out | grep '"bs1' | cut -d\" -f2 | cut -d. -f2` + endif + end + cp /ptmp/$USER/wrf_regression.$joe_id/wrftest.output wrftest.output.$TEST_NUM[$count_test].$tests[$count_test] + rm llsub.out llq.report + else if ( ( `uname` == AIX ) && ( `hostname | cut -c 1-2` == bv ) ) then + bsub < reg.foo.$TEST_NUM[$count_test].$tests[$count_test] >&! bsub.out + set ok = 0 + set in_already = 0 + while ( $ok == 0 ) + sleep 10 ; bjobs >&! bjobs.report + grep `cat bsub.out | grep Job | cut -d"<" -f2 | cut -d">" -f1` bjobs.report >& /dev/null + set ok = $status + if ( ( $ok == 0 ) && ( $in_already == 0 ) ) then + set in_already = 1 + set joe_id = `cat bsub.out | grep Job | cut -d"<" -f2 | cut -d">" -f1` + endif + end + cp /ptmp/$USER/wrf_regression.$joe_id/wrftest.output wrftest.output.$TEST_NUM[$count_test].$tests[$count_test] + rm bsub.out bjobs.report + else if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + llsubmit reg.foo.$TEST_NUM[$count_test].$tests[$count_test] >&! llsub.out + set ok = 0 + set in_already = 0 + while ( $ok == 0 ) + sleep 10 ; llq -u $USER >&! llq.report + set llsubmit_name_all = `cat llsub.out | grep '"b' | cut -d\" -f2` + set llsubmit_name_front = `echo $llsubmit_name_all | cut -d\. -f1` + set llsubmit_name_end = `echo $llsubmit_name_all | cut -d\. -f5` + grep $llsubmit_name_front llq.report | grep $llsubmit_name_end >& /dev/null + set ok = $status + if ( ( $ok == 0 ) && ( $in_already == 0 ) ) then + set in_already = 1 + set joe_id = `cat llsub.out | grep '"b' | cut -d\" -f2 | cut -d. -f5` + endif + end + cp /ptmp/$USER/wrf_regression.$joe_id/wrftest.output wrftest.output.$TEST_NUM[$count_test].$tests[$count_test] + rm llsub.out llq.report + + # On the "other" non-queued machines, we just execute the script and wait until + # we get the process returning control, then we move on. + + else + reg.foo.$TEST_NUM[$count_test].$tests[$count_test] -f wrf.tar # >&! output.$TEST_NUM[$count_test].$tests[$count_test] + mv wrftest.output wrftest.output.$TEST_NUM[$count_test].$tests[$count_test] +# if ( $NUM_TESTS != $#NAME ) then +# if ( -d regression_test ) rm -rf regression_test +# else + if ( -d regression_test ) then + mv regression_test regression_test.$TEST_NUM[$count_test].$tests[$count_test] + endif +# endif + endif + endif +end + +if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + echo no web page building, stopping + exit +endif + +PASSFAIL: + +# Build the html page. We only need the middle portion. It's +# a table with 5 columns: Date of test, WRFV2 tag, Developer +# who conducted the test, machine the test was run on, and the +# pass/fail status of the all_reg.csh script when comapred +# to the benchmark results (usually a released code). + +cat >! history_middle_OK.html << EOF + + XDATEX + XTAGX + XTESTERX + XARCHITECTUREX +PASS + DIFFS + + + + +EOF + +cat >! history_middle_OOPS.html << EOF + + XDATEX + XTAGX + XTESTERX + XARCHITECTUREX +FAIL + DIFFS + + + + +EOF + +set name = `uname` +cat >! ed2.in << EOF +,s/ARCHITECTURE/${name}/g +w history_middle.html +q +EOF + +# Get all of the wrftest.output.* files in one BIG file. + +if ( -e wrftest.all_$datehms ) rm wrftest.all_$datehms +cat wrftest.output.?.* wrftest.output.??.* >>! wrftest.all_$datehms +if ( -d `uname` ) rm -rf `uname` +mkdir `uname` +mv wrftest.all_$datehms `uname` + +# Compare regression PASS/FAILs with previous runs. + +pushd ~gill/RESULTS/`uname` +grep FAIL wrftest.output.* >! ${starting_dir}/PREV.FAILS +popd +grep FAIL wrftest.output.* >! CURR.FAILS +echo Comparison of regression results on `hostname` for `date` >! message +echo "==================================================================" >> message +echo " " >> message +echo "Previous FAILs" >> message +echo "==================" >> message +echo " " >> message +cat PREV.FAILS >> message +echo " " >> message +echo "Current FAILs" >> message +echo "==================" >> message +echo " " >> message +cat CURR.FAILS >> message +echo " " >> message +echo "Difference of FAILs" >> message +echo "==================" >> message +echo " " >> message +cat CURR.FAILS | grep -vi baseline >! CURR2.FAILS +diff PREV.FAILS CURR2.FAILS >! diffs +set ok = $status +cat diffs >> message +echo " " >> message +cp message message_$datehms +mv message_$datehms `uname` + +# Send out status info on the regression test. + +set OS = `uname` +set NUMARGS = $#argv +if ( $#argv != 0 ) then + set ARG1 = $argv[1] +else + set ARG1 = BLANK +endif + +if ( ( $NUMARGS == 0 ) || ( $ARG1 == PASSFAIL ) || \ + ( ( $ARG1 == COMPARE ) && ( $NUMARGS == 1 ) ) || \ + ( ( $ARG1 == GENERATE ) && ( $NUMARGS == 1 ) ) ) then + if ( $ok != 0 ) then + Mail -s "REG DIFFS $OS" ${user}@ucar.edu < message + echo " " + echo "Different FAILS from before for $OS - repository may have been broken" + echo " " + m4 -DXDATEX=${dateh} -DXTAGX=${TAG} -DXTESTERX=${user} -DXARCHITECTUREX=`uname` \ + history_middle_OOPS.html >! history_middle_1.html + else if ( $ok == 0 ) then + Mail -s "REG OK $OS" ${user}@ucar.edu < message + echo " " + echo "Same FAILS as before for $OS - repository OK" + echo " " + m4 -DXDATEX=${dateh} -DXTAGX=${TAG} -DXTESTERX=${user} -DXARCHITECTUREX=`uname` \ + history_middle_OK.html >! history_middle_1.html + endif + + # Store on the NCAR MSS system to circumvent security. + + ed history_middle_1.html < ed2.in >& /dev/null + tar -cf `uname`_hist.tar history_middle.html `uname` + echo Storing info on NCAR MSS + msrcp `uname`_hist.tar mss:/GILL/ALLREG/`uname`_hist.tar + if ( -e `uname`_NEW ) rm `uname`_NEW + echo "`uname` `date`" >! `uname`_NEW + msrcp `uname`_NEW mss:/GILL/ALLREG/`uname`_NEW +endif + +rm ed_in >& /dev/null +rm io_format >& /dev/null +rm PREV.FAILS CURR.FAILS CURR2.FAILS message diffs >& /dev/null +rm history_middle_OOPS.html history_middle_OK.html history_middle_1.html history_middle.html >& /dev/null +rm `uname`_hist.tar `uname`_NEW ed2.in >& /dev/null +rm -rf `uname` >& /dev/null diff --git a/wrfv2_fire/tools/build_codebase b/wrfv2_fire/tools/build_codebase new file mode 100755 index 00000000..4dd16170 --- /dev/null +++ b/wrfv2_fire/tools/build_codebase @@ -0,0 +1,112 @@ +#!/bin/csh + + +set db=tools/code_dbase + +#goto skippy +#goto sk1 +# set this to a value to speed up the subinfo calls; set with no value for normal +set gofast # default is not fast (no value given, but set) + +if ( $#argv == 1 ) then + if ( $argv[1] == "fast" ) then + set gofast=yes + endif +endif + +if ( ! -d tools ) then + echo run $0 in top level WRF directory +endif +if ( ! -x tools/deftab || ! -x tools/nocontf90 || ! -x tools/subinfo_calls || ! -x tools/callgraph ) then + ( cd tools/CodeBase ; make ) + if ( ! -x tools/deftab || ! -x tools/nocontf90 || ! -x tools/subinfo_calls || ! -x tools/callgraph ) then + echo some error building the tools in tools/CodeBase. Cannot continue. + exit(2) + endif +endif + +/bin/rm -fr $db +mkdir $db + +if ( ! -f frame/module_state_description.f ) then + echo + echo '*** ' code must be compiled first before code database can be built + echo '*** ' because it is based on the .f files + echo + exit(99) +endif +set dirs=( dyn_em frame main phys share ) +#set dirs=( dyn_nmm frame main phys share ) +#set dirs=( phys ) +#set dirs=( main ) +foreach d ( $dirs ) + foreach f ( $d/*.f ) + set ff=$f:t + echo $f + tools/nocontf90 < $f | expand | \ + sed \ + -e 's/ */ /g' \ + -e 's/^ //' \ + -e '/^$/d' \ + -e 's/^real,/real ,/' \ + -e 's/^integer,/integer ,/' \ + -e 's/^type(/type (/' \ + -e 's/^logical,/logical ,/' \ + > $db/lm_${f:t}_1 + tools/deftab $f < $db/lm_${f:t}_1 + /bin/rm -f $db/lm_${f:t}_1 + end +end + +cat -n $db/calls | sort -u +1 > xxx +sort -n +0 -1 xxx | awk '{print $2 " " $3 " " $4}' > $db/calls + +############ pre-compute the subinfo html entries ########## + +skippy: + +foreach f ( `/bin/ls -1 $db | grep -v '\.html' | grep -v calls | grep -v '^lm_' | grep -v '^vv_' | grep -v '_descrip$'` ) + echo creating html file for $f + tools/subinfo $f $gofast > $db/$f.html +end + +#foreach f ( `/bin/ls -1 $db/[a-f]* | grep -v '\.html' | grep -v calls | grep -v '^lm_'` ) +# echo creating html file for $f +# tools/subinfo $f:t > $f.html +#end +#foreach f ( `/bin/ls -1 $db/[g-m]* | grep -v '\.html' | grep -v calls | grep -v '^lm_'` ) +# echo creating html file for $f +# tools/subinfo $f:t > $f.html +#end +#foreach f ( `/bin/ls -1 $db/[n-t]* | grep -v '\.html' | grep -v calls | grep -v '^lm_'` ) +# echo creating html file for $f +# tools/subinfo $f:t > $f.html +#end +#foreach f ( `/bin/ls -1 $db/[u-z]* | grep -v '\.html' | grep -v calls | grep -v '^lm_'` ) +# echo creating html file for $f +# tools/subinfo $f:t > $f.html +#end + +echo "Creating $db/index.html" + +/bin/cp tools/callgraph.page1 $db/callgraph.html +tools/callgraph wrf 7 >> $db/callgraph.html +cat tools/callgraph.page2 >> $db/callgraph.html +/bin/cp tools/index.page $db/index.html +/bin/cp tools/collapsd.gif tools/daughter.gif tools/exploded.gif $db + +sk1: +#tools/callgraph wrf 0 > $db/index.html +#echo ct2.html +#tools/callgraph wrf 1 > $db/ct2.html +#echo ct3.html +#tools/callgraph wrf 2 > $db/ct3.html +#echo ct4.html +#tools/callgraph wrf 3 > $db/ct4.html +#echo ct5.html +#tools/callgraph wrf 4 > $db/ct5.html +#echo ctall.html +#tools/callgraph wrf > $db/ctall.html + +echo "Done" + diff --git a/wrfv2_fire/tools/build_test.csh b/wrfv2_fire/tools/build_test.csh new file mode 100755 index 00000000..04a279e8 --- /dev/null +++ b/wrfv2_fire/tools/build_test.csh @@ -0,0 +1,63 @@ +#!/bin/csh + +set root = data1 +set root = mmmtmp + +echo starting +if ( ! -d /$root/${user} ) then + echo give me a break + exit ( 1 ) +endif +cd /$root/${user} + +if ( ! -d /$root/${user}/`hostname` ) then + mkdir /$root/${user}/`hostname` +endif +cd /$root/${user}/`hostname` + +if ( ! -e /$root/${user}/wrfv2.tar ) then + echo need the wrf tar file + exit ( 2 ) +endif + +echo untar wrfv2 +tar -xf ../wrfv2.tar + +if ( `uname` == SunOS ) then + set OPTS = ( 1 3 ) +else if ( ( `uname` == Linux ) && ( `hostname` == jacaranda ) ) then + set OPTS = ( 2 ) +else if ( `uname` == Linux ) then + set OPTS = ( 1 2 3 ) +else if ( `uname` == OSF1 ) then + set OPTS = ( 1 3 6 ) +endif + +foreach opt ( $OPTS ) + cd /$root/${user}/`hostname`/WRFV2 + + foreach test ( em_real em_b_wave em_quarter_ss ) + echo building $test for compiler option $opt `date` + + clean -a >& /dev/null + + echo "$opt" | ./configure >&! make.out.${test}.opt=${opt} + + compile $test >>& make.out.${test}.opt=${opt} + + if ( $test == em_real ) then + if ( ( ! -e main/real.exe ) || ( ! -e main/wrf.exe ) ) then + echo missing $test executables + exit ( 3 ) + endif + else + if ( ( ! -e main/ideal.exe ) || ( ! -e main/wrf.exe ) ) then + echo missing $test executables + exit ( 4 ) + endif + endif + echo $test exec build OK `date` + echo " " + + end +end diff --git a/wrfv2_fire/tools/callgraph.page1 b/wrfv2_fire/tools/callgraph.page1 new file mode 100755 index 00000000..81d77298 --- /dev/null +++ b/wrfv2_fire/tools/callgraph.page1 @@ -0,0 +1,36 @@ + + + +Weather Research and Forecast Model + + + + + + + + diff --git a/wrfv2_fire/tools/collapsd.gif b/wrfv2_fire/tools/collapsd.gif new file mode 100755 index 00000000..45dd3868 Binary files /dev/null and b/wrfv2_fire/tools/collapsd.gif differ diff --git a/wrfv2_fire/tools/danger b/wrfv2_fire/tools/danger new file mode 100755 index 00000000..a9de33f6 --- /dev/null +++ b/wrfv2_fire/tools/danger @@ -0,0 +1,14 @@ +#!/bin/csh + +# strip all the dependencies out of the makefiles so it compiles quicker + +if ( ! -d tools ) then + echo 'must be run in top level dir' +endif + +tools/safe >& /dev/null +foreach f ( */Makefile ) + /bin/mv $f $f.saved + cat $f.saved | sed '/ DEPENDENCIES/,$d' > $f +end + diff --git a/wrfv2_fire/tools/data.c b/wrfv2_fire/tools/data.c new file mode 100644 index 00000000..2b99a7e7 --- /dev/null +++ b/wrfv2_fire/tools/data.c @@ -0,0 +1,177 @@ +#include +#include +#include +#include + +#include "registry.h" +#include "protos.h" +#include "data.h" + +#define MAXTOKENS 30 + +int +init_dim_table() +{ + Dim = NULL ; + return(0) ; +} + +node_t * +new_node ( int kind ) +{ node_t *p ; p = (node_t *)malloc(sizeof(node_t)) ; bzero(p,sizeof(node_t)); p->node_kind = kind ; return (p) ; } + +int +add_node_to_end ( node_t * node , node_t ** list ) +{ + node_t * p ; + if ( *list == NULL ) + { *list = node ; } + else + { + for ( p = *list ; p->next != NULL ; p = p->next ) ; + p->next = node ; + } + return(0) ; +} + +int +add_node_to_end_4d ( node_t * node , node_t ** list ) +{ + node_t * p ; + if ( *list == NULL ) + { *list = node ; } + else + { + for ( p = *list ; p->next4d != NULL ; p = p->next4d ) ; + p->next4d = node ; + } + return(0) ; +} + +#if 0 +int +show_nodelist( node_t * p ) +{ + show_nodelist1( p , 0 ) ; +} + +show_nodelist1( node_t * p , int indent ) +{ + if ( p == NULL ) return(0) ; + show_node1( p, indent) ; + show_nodelist1( p->next, indent ) ; +} + +int +show_node( node_t * p ) +{ + return(show_node1(p,0)) ; +} + +int +show_node1( node_t * p, int indent ) +{ + char spaces[] = " " ; + char tmp[25] , t1[25] , t2[25] ; + char * x, *ca, *ld, *ss, *se, *sg ; + char *nodekind ; + node_t * q ; + int nl ; + int i ; + + if ( p == NULL ) return(1) ; + strcpy(tmp, spaces) ; + if ( indent >= 0 && indent < 20 ) tmp[indent] = '\0' ; + +// this doesn't make much sense any more, ever since node_kind was +// changed to a bit mask + if ( p->node_kind & RCONFIG ) nodekind = "RCONFIG" ; + else if ( p->node_kind & I1 ) nodekind = "I1" ; + else if ( p->node_kind & FIELD ) nodekind = "FIELD" ; + else if ( p->node_kind & FOURD ) nodekind = "FOURD" ; + else if ( p->node_kind & MEMBER ) nodekind = "MEMBER" ; + else if ( p->node_kind & RCONFIG ) nodekind = "RCONFIG" ; + + if ( !p->scalar_array_member ) + { + switch ( p->node_kind ) + { + case RCONFIG : + case I1 : + case FIELD : + case FOURD : + case MEMBER : + fprintf(stderr,"%s%s : %10s ndims %1d\n",tmp,nodekind,p->name, p->ndims) ; + for ( i = 0 ; i < p->ndims ; i++ ) + { + sg = "" ; + switch ( p->dims[i]->coord_axis ) { + case COORD_X : ca = "X" ; if ( p->stag_x ) sg = "*" ; break ; + case COORD_Y : ca = "Y" ; if ( p->stag_y ) sg = "*" ; break ; + case COORD_Z : ca = "Z" ; if ( p->stag_z ) sg = "*" ; break ; + case COORD_C : ca = "C" ; break ; + } + switch ( p->dims[i]->len_defined_how ) { + case DOMAIN_STANDARD : ld = "STANDARD" ; ss = "" ; se = "" ; break ; + case NAMELIST : ld = "NAMELIST" ; ss = p->dims[i]->associated_namelist_variable ; se="" ; break ; + case CONSTANT : ld = "CONSTANT" ; sprintf(t1,"%d",p->dims[i]->coord_start) ; ss = t1 ; + sprintf(t2,"%d",p->dims[i]->coord_end ) ; se = t2 ; + break ; + } + fprintf(stderr," dim %1d: %c %2s%s %10s %10s %10s\n",i,p->dims[i]->dim_name,ca,sg,ld,ss,se) ; + } + nl = 0 ; + if ( strlen( p->use ) > 0 ) { + nl = 1 ; fprintf(stderr," use: %s",p->use) ; + if ( p->scalar_array_member ) fprintf(stderr,"(4D)") ; + } + if ( strlen( p->dname ) > 0 ) { nl = 1 ; fprintf(stderr," dname: %s",p->dname) ; } + if ( strlen( p->descrip ) > 0 ) { nl = 1 ; fprintf(stderr," descrip: %s",p->descrip) ; } + if ( nl == 1 ) fprintf(stderr,"\n") ; + show_node1( p->type, indent+1 ) ; + break ; + case TYPE : + x = "derived" ; + if ( p->type_type == SIMPLE ) x = "simple" ; + fprintf(stderr,"%sTYPE : %10s %s ndims %1d\n",tmp,p->name,x, p->ndims) ; + show_nodelist1( p->fields, indent+1 ) ; + break ; + case DIM : + break ; + default : + break ; + } + } + show_nodelist1( p->members , indent+2 ) ; + return(0) ; +} +#endif + +int +set_mark ( int val , node_t * lst ) +{ + node_t * p ; + if ( lst == NULL ) return(0) ; + for ( p = lst ; p != NULL ; p = p->next ) + { + p->mark = val ; + set_mark( val , p->fields ) ; + set_mark( val , p->members ) ; + } + return(0) ; +} + +int +set_mark_4d ( int val , node_t * lst ) +{ + node_t * p ; + if ( lst == NULL ) return(0) ; + for ( p = lst ; p != NULL ; p = p->next4d ) + { + p->mark = val ; + set_mark( val , p->fields ) ; + set_mark( val , p->members ) ; + } + return(0) ; +} + diff --git a/wrfv2_fire/tools/data.h b/wrfv2_fire/tools/data.h new file mode 100644 index 00000000..48991248 --- /dev/null +++ b/wrfv2_fire/tools/data.h @@ -0,0 +1,152 @@ +#ifndef DATA_H +#include "registry.h" + +typedef struct node_struct { + + int node_kind ; + int type_type ; + char name[NAMELEN] ; + struct node_struct * fields ; + struct node_struct * type ; + int ndims ; + struct node_struct * dims[MAXDIMS] ; + int proc_orient ; /* ALL_[ZXY]_ON_PROC which dimension is all on processor */ + int ntl ; + int stag_x ; + int stag_y ; + int stag_z ; + int subject_to_communication ; + int boundary_array ; + int boundary_array_4d ; + char use[NAMELEN] ; + char dname[NAMELEN] ; + char descrip[NAMELEN] ; + char units[NAMELEN] ; + +/* Fields for 4D scalar arrays */ + int scalar_array_member ; + int has_scalar_array_tendencies ; + struct node_struct * members ; + +/* I/O flags */ + int io_mask ; + int history ; + int auxhist1 ; + int auxhist2 ; + int auxhist3 ; + int auxhist4 ; + int auxhist5 ; + int auxhist6 ; + int auxhist7 ; + int auxhist8 ; + int auxhist9 ; + int auxhist10 ; + int auxhist11 ; + int restart ; + int input ; + int auxinput1 ; + int auxinput2 ; + int auxinput3 ; + int auxinput4 ; + int auxinput5 ; + int auxinput6 ; + int auxinput7 ; + int auxinput8 ; + int auxinput9 ; + int auxinput10 ; + int auxinput11 ; + int boundary ; + int namelist ; + char namelistsection[NAMELEN] ; + struct node_struct * next ; + struct node_struct * next4d ; + + char force_aux_fields[2048] ; + char force_fcn_name[2048] ; + char interpd_aux_fields[2048] ; + char interpd_fcn_name[2048] ; + char interpu_aux_fields[2048] ; + char interpu_fcn_name[2048] ; + char smoothu_fcn_name[2048] ; + char smoothu_aux_fields[2048] ; + +/* fields used by rconfig nodes */ + char nentries[NAMELEN] ; + char howset[NAMELEN] ; + char dflt[NAMELEN] ; + +/* fields used by Dim nodes */ + + char dim_name ; + char dim_data_name[NAMELEN] ; + int coord_axis ; /* X, Y, Z, C */ + /* DOMAIN_STANDARD, NAMELIST, CONSTANT */ + int len_defined_how ; + char assoc_nl_var_s[NAMELEN] ; /* for NAMELIST */ + char assoc_nl_var_e[NAMELEN] ; /* for NAMELIST */ + int coord_start ; /* for CONSTANT */ + int coord_end ; /* for CONSTANT */ + int dim_order ; /* order that dimensions are specified + in framework */ + int subgrid ; /* 1=subgrid dimension */ + +/* fields used by Package nodes */ + char pkg_assoc[NAMELEN] ; + char pkg_statevars[NAMELEN] ; + char pkg_4dscalars[NAMELEN_LONG] ; + +/* fields used by Comm (halo, period, xpose) nodes */ + char comm_define[2*8192] ; + +/* marker */ + int mark ; + +} node_t ; + +#ifndef DEFINE_GLOBALS +# define EXTERN extern +#else +# define EXTERN +#endif + +EXTERN int sw_deref_kludge ; +EXTERN int sw_io_deref_kludge ; +EXTERN int sw_3dvar_iry_kludge ; +EXTERN int sw_distrib_io_layer ; +EXTERN int sw_limit_args ; +EXTERN int sw_dm_parallel ; +EXTERN int sw_move ; +EXTERN int sw_all_x_staggered ; +EXTERN int sw_all_y_staggered ; +EXTERN int sw_dm_serial_in_only ; +EXTERN int sw_ifort_kludge ; +EXTERN char sw_commpath[NAMELEN] ; +EXTERN int sw_new_bdys ; /* 20070207 JM support decomposed boundary arrays */ +EXTERN int sw_new_with_old_bdys ; /* 20070207 JM for debugging interim phase, new comms w/ old data structs */ + +EXTERN node_t * Type ; +EXTERN node_t * Dim ; +EXTERN node_t * Packages ; +EXTERN node_t * Halos ; +EXTERN node_t * Periods ; +EXTERN node_t * Xposes ; +EXTERN node_t * FourD ; +EXTERN node_t * Swaps ; +EXTERN node_t * Cycles ; + +EXTERN node_t Domain ; + +EXTERN char t1[NAMELEN], t2[NAMELEN], t3[NAMELEN], t4[NAMELEN], t5[NAMELEN], t6[NAMELEN] ; +EXTERN char thiscom[4*NAMELEN] ; +EXTERN int model_order[3] ; + +EXTERN int max_time_level ; /* Maximum number of time levels of any state variable */ + +#define P_XSB 1 +#define P_XEB 2 +#define P_YSB 3 +#define P_YEB 4 + + +#define DATA_H +#endif diff --git a/wrfv2_fire/tools/daughter.gif b/wrfv2_fire/tools/daughter.gif new file mode 100755 index 00000000..bafbac89 Binary files /dev/null and b/wrfv2_fire/tools/daughter.gif differ diff --git a/wrfv2_fire/tools/debug_macro_toolchest b/wrfv2_fire/tools/debug_macro_toolchest new file mode 100644 index 00000000..f5f95534 --- /dev/null +++ b/wrfv2_fire/tools/debug_macro_toolchest @@ -0,0 +1,42 @@ +#define IDEBUG 40 +#define JDEBUG 42 +#define KDEBUG 3 + +#define IJKTEST i.eq.IDEBUG.and.j.eq.JDEBUG.and.k.eq.KDEBUG +#define IJKDIM IDEBUG,KDEBUG,JDEBUG +#define IJDIM IDEBUG,JDEBUG + +#define DEBUG3D(v,x) write(0,*)'v',' ','x',x ( IJKDIM ) +#define DEBUG2D(v,x) write(0,*)'v',' ','x',x ( IJDIM ) + +#define DEBUG3DHALO(v,x) write(0,*)'v',' 1 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 2 ','x',x ( IDEBUG ,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 3 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 4 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG );\ + write(0,*)'v',' 5 ','x',x ( IDEBUG ,KDEBUG,JDEBUG );\ + write(0,*)'v',' 6 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG );\ + write(0,*)'v',' 7 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG+1);\ + write(0,*)'v',' 8 ','x',x ( IDEBUG ,KDEBUG,JDEBUG+1);\ + write(0,*)'v',' 9 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG+1) + +------- + +#define IDEBUG 40 +#define JDEBUG 42 +#define KDEBUG 3 + +#define IJKTEST i.eq.IDEBUG.and.j.eq.JDEBUG.and.k.eq.KDEBUG +#define IJKDIM IDEBUG,KDEBUG,JDEBUG + +#define DEBUG3D(v,x) write(0,*)'v',' ','x',x ( IJKDIM ) + +#define DEBUG3DHALO(v,x) write(0,*)'v',' 1 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 2 ','x',x ( IDEBUG ,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 3 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG-1);\ + write(0,*)'v',' 4 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG );\ + write(0,*)'v',' 5 ','x',x ( IDEBUG ,KDEBUG,JDEBUG );\ + write(0,*)'v',' 6 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG );\ + write(0,*)'v',' 7 ','x',x ( IDEBUG-1,KDEBUG,JDEBUG+1);\ + write(0,*)'v',' 8 ','x',x ( IDEBUG ,KDEBUG,JDEBUG+1);\ + write(0,*)'v',' 9 ','x',x ( IDEBUG+1,KDEBUG,JDEBUG+1) + diff --git a/wrfv2_fire/tools/exploded.gif b/wrfv2_fire/tools/exploded.gif new file mode 100755 index 00000000..dbce7849 Binary files /dev/null and b/wrfv2_fire/tools/exploded.gif differ diff --git a/wrfv2_fire/tools/four2eight.c b/wrfv2_fire/tools/four2eight.c new file mode 100644 index 00000000..290d1fe6 --- /dev/null +++ b/wrfv2_fire/tools/four2eight.c @@ -0,0 +1,94 @@ +/* Jan. 2005. + + A utility that converts unformatted binary real data files + to unformatted binary double precision data files. + + Compile as + + cc -o four2eight four2eight.c + + If you are running this on a little-endian platform + compile with -DSWAP like so: + + cc -o four2eight -DSWAP four2eight.c + + Use as + + four2eight < RRTM_DATA > RRTM_DATA_DBL (for example) + + JM + +*/ + + +#include + +main() +{ + int in, cr, cr1, n ; + int i ; + float x, x1 ; + double y, y1 ; + + while ( + fread( &in, 1, 4, stdin ) > 0 ) { + swap4(&in, &cr) ; + n = cr ; + cr1 = 2*cr ; + fprintf(stderr, "%d > %d\n",cr,cr1) ; + swap4(&cr1,&cr) ; + fwrite( &cr, 1, 4, stdout ) ; + for ( i = 0 ; i < n ; i += 4 ) + { + fread ( &x, 1, 4, stdin ) ; + swap4(&x,&x1) ; + y1 = x1 ; + swap8(&y1,&y) ; + fwrite ( &y, 1, 8, stdout ) ; + } + fread( &in, 1, 4, stdin ) ; + fwrite( &cr, 1, 4, stdout ) ; + } + fprintf(stderr,"\n") ; +} + +swap4( a, b ) + char a[], b[] ; +{ +#ifdef SWAP + b[0] = a[3] ; + b[1] = a[2] ; + b[2] = a[1] ; + b[3] = a[0] ; +#else + b[0] = a[0] ; + b[1] = a[1] ; + b[2] = a[2] ; + b[3] = a[3] ; +#endif +} + +swap8( a, b ) + char a[], b[] ; +{ +#ifdef SWAP + b[0] = a[7] ; + b[1] = a[6] ; + b[2] = a[5] ; + b[3] = a[4] ; + b[4] = a[3] ; + b[5] = a[2] ; + b[6] = a[1] ; + b[7] = a[0] ; +#else + b[0] = a[0] ; + b[1] = a[1] ; + b[2] = a[2] ; + b[3] = a[3] ; + b[4] = a[4] ; + b[5] = a[5] ; + b[6] = a[6] ; + b[7] = a[7] ; +#endif +} + diff --git a/wrfv2_fire/tools/fseek_test.c b/wrfv2_fire/tools/fseek_test.c new file mode 100644 index 00000000..3094ca40 --- /dev/null +++ b/wrfv2_fire/tools/fseek_test.c @@ -0,0 +1,44 @@ +#define _FILE_OFFSET_BITS 64 +#include +#include +#include +main() +{ + FILE *fp ; + long long y ; + int retval ; + int result1 ; +#ifdef TEST_FSEEKO + off_t x ; + off_t result2 ; +#endif +#ifdef TEST_FSEEKO64 + long long x ; + int result2 ; +#endif + fp = NULL ; + fp = fopen( "Makefile" , "r" ) ; +#ifdef TEST_FSEEKO + x = 0xffffffff ; + result1 = (sizeof(x) == 8) ; + result2 = fseeko( fp, x, SEEK_SET ) ; +#endif +#ifdef TEST_FSEEKO64 + x = 0xffffffffL ; + result1 = (sizeof(x) == 8) ; + result2 = fseeko64( fp, x, SEEK_SET ) ; +#endif + if ( result2 ) perror("error") ; + fprintf(stdout,"pointer is 8 bytes: %s\n",result1?"true":"false") ; + fprintf(stdout,"seek returns correctly: %s\n",!result2?"true":"false") ; + if ( result1 && !result2 ) { + fprintf(stdout,"status: OK\n") ; + retval = 0 ; + } else { + fprintf(stdout,"status: BUMMER\n") ; + retval = 1 ; + } + fclose(fp) ; + exit(retval) ; +} + diff --git a/wrfv2_fire/tools/gen_allocs.c b/wrfv2_fire/tools/gen_allocs.c new file mode 100644 index 00000000..9bc6986e --- /dev/null +++ b/wrfv2_fire/tools/gen_allocs.c @@ -0,0 +1,395 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +int +gen_alloc ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + gen_alloc1( dirname , get_corename_i(i) ) ; + gen_ddt_write( dirname, get_corename_i(i) ) ; + } + return(0) ; +} + +int +gen_alloc1 ( char * dirname , char * corename ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "_allocs.inc" ; + + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_alloc2( fp , "grid%", corename , &Domain ) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_alloc2 ( FILE * fp , char * structname , char * corename , node_t * node ) +{ + node_t * p ; + int tag ; + char post[NAMELEN] ; + char fname[NAMELEN] ; + char x[NAMELEN] ; + + if ( node == NULL ) return(1) ; + + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */ + (p->node_kind & FOURD) || /* scalar arrays or... */ + /* if it's a core specific field and we're doing that core or... */ + (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) || + /* it is not a core specific field */ + (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4))) + )) + { + if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; } + else { sprintf(post,")") ; } + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if ( !strcmp( corename , p->use+4 )) { + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } else if ( !strcmp ( p->use , "_4d_bdy_array_") ) { + strcpy(fname,p->name) ; + } else { + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } + +/* check for errors in memory allocation */ + + if ( ! ( p->node_kind & FOURD ) && + ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) ) + { + fprintf(fp,"IF(.NOT.inter_domain)THEN\n",tag) ; + } + if ( p->ntl > 1 ) { + fprintf(fp,"IF(IAND(%d,tl).NE.0)THEN\n",tag) ; + } + if ( p->boundary_array && sw_new_bdys ) { + int bdy ; + for ( bdy = 1 ; bdy <= 4 ; bdy++ ) + { + fprintf(fp, "ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n", + structname, fname, bdy_indicator(bdy), + dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"), + structname, fname, bdy_indicator(bdy), + dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%")); + fprintf(fp, "IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy)); + if( p->type != NULL && (!strcmp( p->type->name , "real" ) + || !strcmp( p->type->name , "doubleprecision") ) ) { + /* if a real */ + fprintf(fp, "initial_data_value\n"); + } else if ( !strcmp( p->type->name , "logical" ) ) { + fprintf(fp, ".FALSE.\n"); + } else if ( !strcmp( p->type->name , "integer" ) ) { + fprintf(fp, "0\n"); + } + } + } else { + fprintf(fp, "ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n", + structname, fname, + dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"), + structname, fname, + dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%")); + fprintf(fp, "IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname); + + if( p->type != NULL && (!strcmp( p->type->name , "real" ) + || !strcmp( p->type->name , "doubleprecision") ) ) { + /* if a real */ + fprintf(fp, "initial_data_value\n"); + } else if ( !strcmp( p->type->name , "logical" ) ) { + fprintf(fp, ".FALSE.\n"); + } else if ( !strcmp( p->type->name , "integer" ) ) { + fprintf(fp, "0\n"); + } + } + + if ( p->ntl > 1 ) { + fprintf(fp,"ELSE\n") ; + + fprintf(fp, "ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n", + structname, fname, dimension_with_ones( "(",t2,p,")" ), + structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ; + + fprintf(fp,"ENDIF\n") ; + } + + if ( ! ( p->node_kind & FOURD ) && + ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) ) + { + fprintf(fp,"ELSE\n") ; + + if ( p->boundary_array && sw_new_bdys ) { + int bdy ; + for ( bdy = 1 ; bdy <= 4 ; bdy++ ) + { + fprintf(fp, "ALLOCATE(%s%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n endif\n", + structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ), + structname, fname, bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ; + } + } else { + fprintf(fp, "ALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to allocate %s%s%s. ')\n endif\n", + structname, fname, dimension_with_ones( "(",t2,p,")" ), + structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ; + } + + fprintf(fp,"ENDIF\n") ; + } + + } + } + if ( p->type != NULL ) + { + if ( p->type->type_type == SIMPLE && p->ndims == 0 && + ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) && + (!strcmp(p->type->name,"integer") || + !strcmp(p->type->name,"logical") || + !strcmp(p->type->name,"real") || + !strcmp(p->type->name,"doubleprecision")) + ) + { + if (!strncmp( "dyn_" , p->use , 4 )) + { + if (!strcmp( corename , p->use+4 )) + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } + else + { + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } + if( !strcmp( p->type->name , "real" ) || + !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */ + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n", + structname , + fname ) ; + } else if ( !strcmp( p->type->name , "integer" ) ) { + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n", + structname , + fname ) ; + } else if ( !strcmp( p->type->name , "logical" ) ) { + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n", + structname , + fname ) ; + } + } + else if ( p->type->type_type == DERIVED ) + { + sprintf(x,"%s%s%%",structname,p->name ) ; + gen_alloc2(fp,x, corename, p->type) ; + } + } + } + return(0) ; +} + +int +gen_ddt_write ( char * dirname , char * corename ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "_write_ddt.inc" ; + + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_ddt_write1( fp , "grid%", corename , &Domain ) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_ddt_write1 ( FILE * fp , char * structname , char * corename , node_t * node ) +{ + node_t * p ; + int tag ; + char post[NAMELEN] ; + char fname[NAMELEN] ; + char x[NAMELEN] ; + + if ( node == NULL ) return(1) ; + + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( (p->ndims > 1 && ! p->boundary_array) && ( /* any array or a boundary array and... */ + (p->node_kind & FOURD) || /* scalar arrays or... */ + /* if it's a core specific field and we're doing that core or... */ + (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) || + /* it is not a core specific field */ + (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4))) + )) + { + if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; } + else { sprintf(post,")") ; } + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if (!strcmp( corename , p->use+4 )) + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + else + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + + if ( p->node_kind & FOURD ) { + fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ; + } else { + if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ; + if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ; + } + + } + } +#if 0 + if ( p->type != NULL ) + { + if ( p->type->type_type == SIMPLE && p->ndims == 0 && + ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) && + (!strcmp(p->type->name,"integer") || + !strcmp(p->type->name,"real") || + !strcmp(p->type->name,"doubleprecision")) + ) + { + if (!strncmp( "dyn_" , p->use , 4 )) + { + if (!strcmp( corename , p->use+4 )) + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } + else + { + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + } + fprintf(fp, "write(iunit)%s%s\n",structname,fname) ; + } + } +#endif + } + return(0) ; +} + +int +gen_dealloc ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + gen_dealloc1( dirname , get_corename_i(i) ) ; + } + return(0) ; +} + +int +gen_dealloc1 ( char * dirname , char * corename ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "_deallocs.inc" ; + + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%s",dirname,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_dealloc2( fp , "grid%", corename , &Domain ) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_dealloc2 ( FILE * fp , char * structname , char * corename , node_t * node ) +{ + node_t * p ; + int tag ; + char post[NAMELEN] ; + char fname[NAMELEN] ; + char x[NAMELEN] ; + + if ( node == NULL ) return(1) ; + + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */ + (p->node_kind & FOURD) || /* scalar arrays or... */ + /* if it's a core specific field and we're doing that core or... */ + (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) || + /* it is not a core specific field */ + (p->node_kind & FIELD && ( strncmp("dyn_",p->use,4))) + )) + { + if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; } + else { sprintf(post,")") ; } + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if (!strcmp( corename , p->use+4 )) + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + else + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + + if ( p->boundary && sw_new_bdys ) { + { int bdy ; + for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { + fprintf(fp, +"IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ; + fprintf(fp, +" DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s%s. ')\n endif\n", + structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ; + fprintf(fp, +" NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ; + fprintf(fp, +"ENDIF\n" ) ; + } + } + } else { + fprintf(fp, +"IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ; + fprintf(fp, +" DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s. ')\n endif\n", +structname, fname, structname, fname ) ; + fprintf(fp, +" NULLIFY(%s%s)\n",structname, fname ) ; + fprintf(fp, +"ENDIF\n" ) ; + } + + + } + } + if ( p->type != NULL ) + { + if ( p->type->type_type == SIMPLE && p->ndims == 0 && + ((!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4)) || strncmp("dyn_",p->use,4)) && + (!strcmp(p->type->name,"integer") || + !strcmp(p->type->name,"real") || + !strcmp(p->type->name,"doubleprecision")) + ) + { + } + else if ( p->type->type_type == DERIVED ) + { + sprintf(x,"%s%s%%",structname,p->name ) ; + gen_dealloc2(fp,x, corename, p->type) ; + } + } + } + return(0) ; +} diff --git a/wrfv2_fire/tools/gen_args.c b/wrfv2_fire/tools/gen_args.c new file mode 100644 index 00000000..f0e3b0d9 --- /dev/null +++ b/wrfv2_fire/tools/gen_args.c @@ -0,0 +1,191 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +#define DUMMY 1 +#define ACTUAL 2 +#define DUMMY_NEW 3 +#define ACTUAL_NEW 4 + +int +gen_actual_args ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + gen_args ( dirname , get_corename_i(i) , ACTUAL ) ; + return(0) ; +} + +/* only generate actual args for the 4d arrays */ +int +gen_actual_args_new ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + gen_args ( dirname , get_corename_i(i) , ACTUAL_NEW ) ; + return(0) ; +} + +int +gen_dummy_args ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + gen_args ( dirname , get_corename_i(i) , DUMMY ) ; + return(0) ; +} + +/* only generate dummy args for the 4d arrays */ +int +gen_dummy_args_new ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + gen_args ( dirname , get_corename_i(i) , DUMMY_NEW ) ; + return(0) ; +} + +int +gen_args ( char * dirname , char * corename , int sw ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "_args.inc" ; + char * p ; + int linelen ; + char outstr[64*4096] ; + + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) + { sprintf(fname,"%s/%s%s%s%s",dirname,corename, + (sw==ACTUAL||sw==ACTUAL_NEW)?"_actual":"_dummy",(sw==ACTUAL_NEW||sw==DUMMY_NEW)?"_new":"",fn) ; } + else + { sprintf(fname,"%s%s%s%s",corename, + (sw==ACTUAL||sw==ACTUAL_NEW)?"_actual":"_dummy",(sw==ACTUAL_NEW||sw==DUMMY_NEW)?"_new":"",fn) ; } + + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + linelen = 0 ; + strcpy(outstr,",") ; + gen_args1 ( fp , outstr, (sw==ACTUAL||sw==ACTUAL_NEW)?"grid%":"", corename , + &Domain , &linelen , sw , 0 ) ; + /* remove trailing comma */ + if ((p=rindex(outstr,','))!=NULL) *p = '\0' ; + fputs(outstr,fp);fputs(" &\n",fp) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_args1 ( FILE * fp , char * outstr , char * structname , char * corename , + node_t * node , int *linelen , int sw , int deep ) +{ + node_t * p ; + int tag ; + char post[NAMELEN] ; + char fname[NAMELEN] ; + char x[NAMELEN], y[NAMELEN] ; + char indices[NAMELEN] ; + int lenarg ; + int only4d = 0 ; + + if ( sw == ACTUAL_NEW ) { sw = ACTUAL ; only4d = 1 ; } + if ( sw == DUMMY_NEW ) { sw = DUMMY ; only4d = 1 ; } + + if ( node == NULL ) return(1) ; + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( p->node_kind & I1 ) continue ; /* short circuit any field that is not state */ + /* short circuit scalars; shortening argument lists */ + if ( p->ndims == 0 && p->type->type_type != DERIVED && sw_limit_args ) continue ; + + if ( ( + (p->node_kind & FOURD) /* scalar arrays or... */ + /* if it's a core specific field and we're doing that core or... */ + || (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) + /* it is not a core specific field and it is not a derived type -ajb */ + || (p->node_kind & FIELD && (p->type->type_type != DERIVED) && ( strncmp("dyn_",p->use,4))) +#if 0 + /* it is a state variable */ + || (p->node_kind & RCONFIG ) +#endif + ) + ) + { + if (!only4d || (p->node_kind & FOURD) || associated_with_4d_array(p) ) { + if ( p->node_kind & FOURD ) { sprintf(post,",1)") ; } + else if ( p->boundary_array ) { sprintf(post,")") ; } + else { sprintf(post,")") ; } + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if ( p->boundary_array && sw_new_bdys ) { + int bdy ; + for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { + if (!strcmp( corename , p->use+4 ) && sw==ACTUAL) + sprintf(fname,"%s_%s",corename,field_name_bdy(t4,p,(p->ntl>1)?tag:0,bdy)) ; + else + strcpy(fname,field_name_bdy(t4,p,(p->ntl>1)?tag:0,bdy)) ; + strcpy(indices,"") ; + if ( sw_deref_kludge && sw==ACTUAL ) + sprintf(indices, "%s",index_with_firstelem("(","",bdy,t2,p,post)) ; + /* generate argument */ + strcpy(y,structname) ; strcat(y,fname) ; strcat(y,indices) ; strcat(y,",") ; + lenarg = strlen(y) ; + if ( lenarg+*linelen > MAX_ARGLINE ) { strcat(outstr," &\n") ; *linelen = 0 ; } + strcat(outstr,y) ; + *linelen += lenarg ; + } + } else { + if (!strcmp( corename , p->use+4 ) && sw==ACTUAL) + sprintf(fname,"%s_%s",corename,field_name(t4,p,(p->ntl>1)?tag:0)) ; + else + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + strcpy(indices,"") ; + if ( sw_deref_kludge && sw==ACTUAL ) + sprintf(indices, "%s",index_with_firstelem("(","",-1,t2,p,post)) ; + /* generate argument */ + strcpy(y,structname) ; strcat(y,fname) ; strcat(y,indices) ; strcat(y,",") ; + lenarg = strlen(y) ; + if ( lenarg+*linelen > MAX_ARGLINE ) { strcat(outstr," &\n") ; *linelen = 0 ; } + strcat(outstr,y) ; + *linelen += lenarg ; + } + } + } + } + if ( p->type != NULL ) + { + if ( p->type->type_type == DERIVED && !only4d ) + { + if ( deep ) + { + sprintf(x,"%s%s%%",structname,p->name ) ; + gen_args1(fp, outstr, (sw==ACTUAL)?x:"", corename, p->type,linelen,sw,deep) ; + } + else + { + /* generate argument */ + strcpy(y,structname) ; strcat(y,p->name) ; strcat(y,",") ; + lenarg = strlen(y) ; + if ( lenarg+*linelen > MAX_ARGLINE ) { strcat(outstr," &\n") ; *linelen = 0 ; } + strcat(outstr,y) ; + *linelen += lenarg ; + p->mark = 1 ; + } + } + } + } + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_comms.stub b/wrfv2_fire/tools/gen_comms.stub new file mode 100644 index 00000000..b079afe8 --- /dev/null +++ b/wrfv2_fire/tools/gen_comms.stub @@ -0,0 +1,15 @@ +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +int +gen_comms ( char * dirname ) +{ + if ( sw_dm_parallel ) + fprintf(stderr,"WARNING: stub version of gen_comms is linked in with registry program.\n") ; + + return(0) ; +} diff --git a/wrfv2_fire/tools/gen_comms_warning b/wrfv2_fire/tools/gen_comms_warning new file mode 100644 index 00000000..119c9b4d --- /dev/null +++ b/wrfv2_fire/tools/gen_comms_warning @@ -0,0 +1,15 @@ +/* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! W A R N I N G + !! + !! This is a temporary version of gen_comms.c + !! It has been compied from somewhere else + !! (If not DM_PARALLEL this is tools/gen_comms.stub + !! otherwise, it is from one of the external package + !! directories.) + !! + !! B E A D V I S E D + !! + !! Changes to this file are liable to be LOST. + !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ + diff --git a/wrfv2_fire/tools/gen_config.c b/wrfv2_fire/tools/gen_config.c new file mode 100644 index 00000000..47d2c4a4 --- /dev/null +++ b/wrfv2_fire/tools/gen_config.c @@ -0,0 +1,324 @@ +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" +#include +#include +#include "sym.h" + +int +gen_namelist_defines ( char * dirname , int sw_dimension ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char fn[NAMELEN] ; + node_t *p ; + + sprintf( fn, "namelist_defines%s.inc", sw_dimension?"":"2" ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + fprintf(fp,"integer :: first_item_in_struct\n") ; + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG ) + { + if ( sw_dimension ) + { + if ( !strcmp( p->nentries, "1" ) ) + fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ; + else if ( strcmp( p->nentries, "-" ) ) /* if not equal to "-" */ + fprintf(fp,"%s , DIMENSION(%s) :: %s\n",p->type->name ,p->nentries,p->name) ; + } + else + { + fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ; + } + } + } + fprintf(fp,"integer :: last_item_in_struct\n") ; + + close_the_file( fp ) ; + return(0) ; +} + +int +gen_namelist_defaults ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char *fn = "namelist_defaults.inc" ; + node_t *p ; + + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG && strcmp(p->dflt,"-") && strcmp(p->dflt,"")) + { + if ( !strncmp ( p->type->name , "character", 9 ) ) { + fprintf(fp,"%s = \"%s\"\n",p->name ,p->dflt) ; + } else { + fprintf(fp,"%s = %s\n",p->name ,p->dflt) ; + } + } + } + + close_the_file( fp ) ; + return(0) ; +} + + +int +gen_namelist_statements ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "namelist_statements.inc" ; + char howset[NAMELEN] ; + char *p1, *p2 ; + node_t *p ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG ) + { + strcpy(howset,p->howset) ; + if (( p1 = strtok(howset,",")) != NULL ) + { + p2 = strtok(NULL,",") ; + if ( !strcmp(p1,"namelist") ) + { + if ( p2 == NULL ) + { + fprintf(stderr, + "Warning: no namelist section specified for nl %s\n",p->name) ; + continue ; + } + fprintf(fp,"NAMELIST /%s/ %s\n",p2,p->name) ; + } + } + } + } + + close_the_file( fp ) ; + return(0) ; +} + +int +gen_get_nl_config ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "get_nl_config.inc" ; + char * gs, * intnt ; + char howset[NAMELEN] ; + node_t *p ; + int sw ; + + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + for ( sw = 0 ; sw < 2 ; sw++ ) + { + if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; } + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG ) + { + strcpy(howset,p->howset) ; + fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ; + if ( sw_ifort_kludge ) { + fprintf(fp," USE module_configure\n") ; + } + fprintf(fp," %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ; + fprintf(fp," INTEGER id_id\n") ; + fprintf(fp," CHARACTER*80 emess\n") ; + if ( sw == 0 ) /* get */ + { + if ( !strcmp( p->nentries, "1" )) { + if ( ! sw_ifort_kludge ) { + fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ; + fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n", + gs,p->name, p->name ) ; + fprintf(fp," ENDIF\n" ) ; + } + if ( !strncmp(p->type->name,"character",9)) { + fprintf(fp," %s = trim(model_config_rec%%%s)\n",p->name,p->name) ; + }else{ + fprintf(fp," %s = model_config_rec%%%s\n",p->name,p->name) ; + } + } else { + if ( ! sw_ifort_kludge ) { + if ( !strcmp( p->nentries, "max_domains" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ; + } else if ( !strcmp( p->nentries, "max_moves" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ; + } else if ( !strcmp( p->nentries, "max_eta" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ; + } else { + fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, or max_eta \n") ; + } + fprintf(fp," CALL wrf_error_fatal(emess)\n") ; + fprintf(fp," ENDIF\n" ) ; + } + fprintf(fp," %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ; + } + } + else /* set */ + { + if ( !strcmp( p->nentries, "1" )) { + if ( ! sw_ifort_kludge ) { + fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ; + fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n", + gs,p->name, p->name ) ; + fprintf(fp," ENDIF\n" ) ; + } + if ( !strncmp(p->type->name,"character",9)) { + fprintf(fp," model_config_rec%%%s = trim(%s) \n",p->name,p->name) ; + }else{ + fprintf(fp," model_config_rec%%%s = %s \n",p->name,p->name) ; + } + } else { + if ( ! sw_ifort_kludge ) { + if ( !strcmp( p->nentries, "max_domains" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ; + } else if ( !strcmp( p->nentries, "max_moves" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ; + } else if ( !strcmp( p->nentries, "max_eta" )) { + fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ; + fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ; + } else { + fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, or max_eta \n") ; + } + fprintf(fp," CALL wrf_error_fatal(emess)\n") ; + fprintf(fp," ENDIF\n" ) ; + } + fprintf(fp," model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ; + } + } + fprintf(fp," RETURN\n") ; + fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ; + } + } + } + close_the_file( fp ) ; + return(0) ; +} + +int +gen_config_assigns ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "config_assigns.inc" ; + char tmp[NAMELEN] ; + node_t *p ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ; + fprintf(fp,"#ifndef SOURCE_RECORD\n") ; + fprintf(fp,"# define SOURCE_RECORD cfg%%\n") ; + fprintf(fp,"#endif\n") ; + fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ; + fprintf(fp,"# define SOURCE_REC_DEX\n") ; + fprintf(fp,"#endif\n") ; + fprintf(fp,"#ifndef DEST_RECORD\n") ; + fprintf(fp,"# define DEST_RECORD new_grid%%\n") ; + fprintf(fp,"#endif\n") ; + + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG ) + { + if ( !strcmp( p->nentries, "1" )) + strcpy( tmp, "" ) ; + else + strcpy( tmp, "SOURCE_REC_DEX" ) ; + fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ; + } + } + close_the_file( fp ) ; + return(0) ; +} + +int +gen_config_reads ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "config_reads.inc" ; + char howset[NAMELEN] ; + char *p1, *p2 ; + node_t *p ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + + fprintf(fp,"! Contains namelist statements for module_config.F.\n") ; + fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ; + fprintf(fp,"# define NAMELIST_READ_UNIT nml_unit\n") ; + fprintf(fp,"#endif\n") ; + fprintf(fp,"#ifndef NAMELIST_READ_ERROR_LABEL\n") ; + fprintf(fp,"# define NAMELIST_READ_ERROR_LABEL 9200\n") ; + fprintf(fp,"#endif\n") ; + fprintf(fp,"!\n") ; + + sym_forget() ; + + for ( p = Domain.fields ; p != NULL ; p = p-> next ) + { + if ( p->node_kind & RCONFIG ) + { + strcpy(howset,p->howset) ; + p1 = strtok(howset,",") ; + p2 = strtok(NULL,",") ; + if ( !strcmp(p1,"namelist") ) + { + if ( p2 == NULL ) + { + fprintf(stderr, + "Warning: no namelist section specified for nl %s\n",p->name) ; + continue ; + } + if (sym_get( p2 ) == NULL) /* not in table yet */ + { + fprintf(fp," REWIND ( UNIT = NAMELIST_READ_UNIT )\n") ; + fprintf(fp," READ ( UNIT = NAMELIST_READ_UNIT , NML = %s , ERR = NAMELIST_READ_ERROR_LABEL , END = NAMELIST_READ_ERROR_LABEL )\n",p2) ; + fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ; + fprintf(fp," WRITE ( UNIT = * , NML = %s )\n",p2) ; + fprintf(fp,"#endif\n") ; + sym_add(p2) ; + } + + } + } + } + close_the_file( fp ) ; + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_defs.c b/wrfv2_fire/tools/gen_defs.c new file mode 100644 index 00000000..11a0dd02 --- /dev/null +++ b/wrfv2_fire/tools/gen_defs.c @@ -0,0 +1,319 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +enum sw_ranges { COLON_RANGE , ARGADJ , GRIDREF } ; +enum sw_pointdecl { POINTERDECL , NOPOINTERDECL } ; + +int +gen_state_struct ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "state_struct.inc" ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_decls ( fp , "", &Domain , COLON_RANGE , POINTERDECL , FIELD | RCONFIG | FOURD , DRIVER_LAYER ) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_state_subtypes ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "state_subtypes.inc" ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_state_subtypes1( fp , &Domain , COLON_RANGE , POINTERDECL , FIELD | RCONFIG | FOURD ) ; + close_the_file(fp) ; + return(0) ; +} + +int +gen_dummy_decls ( char * dn ) +{ + int i ; + FILE * fp ; + char fname[NAMELEN] ; + char corename[NAMELEN] ; + char * fn = "_dummy_decl.inc" ; + + if ( dn == NULL ) return(1) ; + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + strcpy( corename , get_corename_i(i) ) ; + if ( strlen(dn) > 0 ) { sprintf(fname,"%s/%s%s",dn,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) continue ; + print_warning(fp,fname) ; +#if 0 + gen_decls ( fp, corename, &Domain , GRIDREF , NOPOINTERDECL , FIELD | RCONFIG | FOURD , MEDIATION_LAYER ) ; +#else + gen_decls ( fp, corename, &Domain , GRIDREF , NOPOINTERDECL , FIELD | FOURD , MEDIATION_LAYER ) ; +#endif + fprintf(fp,"#undef COPY_IN\n") ; + fprintf(fp,"#undef COPY_OUT\n") ; + close_the_file( fp ) ; + } + return(0); +} + +int +gen_dummy_decls_new ( char * dn ) +{ + int i ; + FILE * fp ; + char fname[NAMELEN] ; + char corename[NAMELEN] ; + char * fn = "_dummy_new_decl.inc" ; + + if ( dn == NULL ) return(1) ; + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + strcpy( corename , get_corename_i(i) ) ; + if ( strlen(dn) > 0 ) { sprintf(fname,"%s/%s%s",dn,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) continue ; + print_warning(fp,fname) ; + gen_decls ( fp, corename, &Domain , GRIDREF , NOPOINTERDECL , FOURD | FIELD | BDYONLY , MEDIATION_LAYER ) ; + fprintf(fp,"#undef COPY_IN\n") ; + fprintf(fp,"#undef COPY_OUT\n") ; + close_the_file( fp ) ; + } + return(0); +} + + +int +gen_i1_decls ( char * dn ) +{ + int i ; + FILE * fp ; + char fname[NAMELEN], post[NAMELEN] ; + char * fn = "_i1_decl.inc" ; + char corename[NAMELEN] ; + char * dimspec ; + node_t * p ; + + if ( dn == NULL ) return(1) ; + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + strcpy(corename,get_corename_i(i)) ; + if ( strlen(dn) > 0 ) { sprintf(fname,"%s/%s%s",dn,corename,fn) ; } + else { sprintf(fname,"%s%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) continue ; + print_warning(fp,fname) ; + gen_decls ( fp , corename, &Domain , GRIDREF , NOPOINTERDECL , I1 , MEDIATION_LAYER ) ; + + /* now generate tendencies for 4d vars if specified */ + for ( p = FourD ; p != NULL ; p = p->next ) + { + if ( p->node_kind & FOURD && p->has_scalar_array_tendencies ) + { + sprintf(fname,"%s_tend",p->name) ; + sprintf(post,",num_%s)",p->name) ; + dimspec=dimension_with_ranges( "grid%",",DIMENSION(",-1,t2,p,post,"" ) ; + /* type dim pdecl name */ + fprintf(fp, "%-10s%-20s%-10s :: %s\n", + field_type( t1, p ) , + dimspec , + "" , + fname ) ; + sprintf(fname,"%s_old",p->name) ; + sprintf(post,",num_%s)",p->name) ; + dimspec=dimension_with_ranges( "grid%",",DIMENSION(",-1,t2,p,post,"" ) ; + /* type dim pdecl name */ + fprintf(fp, "#ifndef NO_I1_OLD\n") ; + fprintf(fp, "%-10s%-20s%-10s :: %s\n", + field_type( t1, p ) , + dimspec , + "" , + fname ) ; + fprintf(fp, "#endif\n") ; + + } + } + close_the_file( fp ) ; + } + return(0) ; +} + +int +gen_decls ( FILE * fp , char * corename , node_t * node , int sw_ranges, int sw_point , int mask , int layer ) +{ + node_t * p ; + int tag, ipass ; + char fname[NAMELEN], post[NAMELEN] ; + char * dimspec ; + int bdyonly = 0 ; + + if ( node == NULL ) return(1) ; + + bdyonly = mask & BDYONLY ; + +/* make two passes; the first is for scalars, second for arrays. */ +/* do it this way so that the scalars get declared first (some compilers complain */ +/* if a scalar is used to declare an array before it's declared) */ + + for ( ipass = 0 ; ipass < 2 ; ipass++ ) + { + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( p->node_kind & mask ) + { + /* add an extra dimension to the 4d arrays. */ + /* note the call to dimension_with_colons, below, does this by itself */ + /* but dimension_with_ranges needs help (since the last arg is not just a colon) */ + + if ( p->node_kind & FOURD ) { + sprintf(post,",num_%s)",field_name(t4,p,0)) ; + } else { + sprintf(post,")") ; + } + + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + + /* if this is a core-specific variable, if we are generating non-driver-layer */ + /* declarations, and if this not a variable for the core named in corename, short-circuit */ + if (!strncmp( p->use, "dyn_", 4 ) && layer != DRIVER_LAYER && strcmp( p->use+4, corename)) continue ; + + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if (!strncmp( p->use, "dyn_", 4 ) && layer == DRIVER_LAYER ) + sprintf(fname,"%s_%s",p->use+4,field_name(t4,p,(p->ntl>1)?tag:0)) ; + else + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + + if ( ! p->boundary_array || ! sw_new_bdys ) { + switch ( sw_ranges ) + { + case COLON_RANGE : + dimspec=dimension_with_colons( ",DIMENSION(",t2,p,")" ) ; break ; + case GRIDREF : + dimspec=dimension_with_ranges( "grid%",",DIMENSION(",-1,t2,p,post,"" ) ; break ; + case ARGADJ : + dimspec=dimension_with_ranges( "",",DIMENSION(",-1,t2,p,post,"" ) ; break ; + } + } else { + dimspec="dummy" ; /* allow fall through on next tests. dimension with ranges will be called again anyway for bdy arrays */ + } + + if ( !strcmp( dimspec, "" ) && ipass == 1 ) continue ; /* short circuit scalars on 2nd pass */ + if ( strcmp( dimspec, "" ) && ipass == 0 ) continue ; /* short circuit arrays on 2nd pass */ + if ( bdyonly && p->node_kind & FIELD && ! p->boundary_array ) continue ; /* short circuit all fields except bdy arrrays */ + + if ( p->boundary_array && sw_new_bdys ) { + int bdy ; + for ( bdy = 1; bdy <=4 ; bdy++ ) { + switch ( sw_ranges ) + { + case COLON_RANGE : + dimspec=dimension_with_colons( ",DIMENSION(",t2,p,")" ) ; break ; + case GRIDREF : + dimspec=dimension_with_ranges( "grid%",",DIMENSION(",bdy,t2,p,post,"" ) ; break ; + case ARGADJ : + dimspec=dimension_with_ranges( "",",DIMENSION(",bdy,t2,p,post,"" ) ; break ; + } + /* type dim pdecl name */ + fprintf(fp, "%-10s%-20s%-10s :: %s%s\n", + field_type( t1, p ) , + dimspec , + (sw_point==POINTERDECL)?declare_array_as_pointer(t3,p):"" , + fname, bdy_indicator( bdy ) ) ; + } + } else { + switch ( sw_ranges ) + { + case COLON_RANGE : + dimspec=dimension_with_colons( ",DIMENSION(",t2,p,")" ) ; break ; + case GRIDREF : + dimspec=dimension_with_ranges( "grid%",",DIMENSION(",-1,t2,p,post,"" ) ; break ; + case ARGADJ : + dimspec=dimension_with_ranges( "",",DIMENSION(",-1,t2,p,post,"" ) ; break ; + } + /* type dim pdecl name */ + fprintf(fp, "%-10s%-20s%-10s :: %s\n", + field_type( t1, p ) , + dimspec , + (sw_point==POINTERDECL)?declare_array_as_pointer(t3,p):"" , + fname ) ; + } + } + } + } + } + return(0) ; +} + +int +gen_state_subtypes1 ( FILE * fp , node_t * node , int sw_ranges , int sw_point , int mask ) +{ + node_t * p ; + int i ; + int new; + char TypeName [NAMELEN] ; + char tempname [NAMELEN] ; + if ( node == NULL ) return(1) ; + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( p->type != NULL ) + if ( p->type->type_type == DERIVED ) + { + new = 1 ; /* determine if this is a new type -ajb */ + strcpy( tempname, p->type->name ) ; + for ( i = 0 ; i < get_num_typedefs() ; i++ ) + { + strcpy( TypeName, get_typename_i(i) ) ; + if ( ! strcmp( TypeName, tempname ) ) new = 0 ; + } + + if ( new ) /* add this type to the history and generate declarations -ajb */ + { + add_typedef_name ( tempname ) ; + gen_state_subtypes1 ( fp , p->type , sw_ranges , sw_point , mask ) ; + fprintf(fp,"TYPE %s\n",p->type->name) ; + gen_decls ( fp , "", p->type , sw_ranges , sw_point , mask , DRIVER_LAYER ) ; + fprintf(fp,"END TYPE %s\n",p->type->name) ; + } + } + } + return(0) ; +} + +/* old version of gen_state_subtypes1 -ajb */ +/* +int +gen_state_subtypes1 ( FILE * fp , node_t * node , int sw_ranges , int sw_point , int mask ) +{ + node_t * p ; + int tag ; + if ( node == NULL ) return(1) ; + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( p->type != NULL ) + if ( p->type->type_type == DERIVED ) + { + gen_state_subtypes1 ( fp , p->type , sw_ranges , sw_point , mask ) ; + fprintf(fp,"TYPE %s\n",p->type->name) ; + gen_decls ( fp , "", p->type , sw_ranges , sw_point , mask , DRIVER_LAYER ) ; + fprintf(fp,"END TYPE %s\n",p->type->name) ; + } + } + return(0) ; +} +*/ diff --git a/wrfv2_fire/tools/gen_interp.c b/wrfv2_fire/tools/gen_interp.c new file mode 100644 index 00000000..fd53d5d2 --- /dev/null +++ b/wrfv2_fire/tools/gen_interp.c @@ -0,0 +1,377 @@ +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +int contains_str( char *s1, char *s2 ) +{ + int i ; + char *p, *q, *r ; + if ( s2 == NULL || s1 == NULL ) return ( 0 ) ; + if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ; + p = s1 ; + while ( *p ) { + if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; } + for ( q = s2 ; *q && *r == *q ; r++ , q++ ) ; + if ( *q == '\0' ) return (1) ; + p++ ; + } + return( 0 ) ; +} + +int contains_tok( char *s1, char *s2, char *delims ) +{ + char *p ; + char tempstr[8092] ; + + strcpy( tempstr , s1 ) ; + p = strtok ( tempstr, delims ) ; + while ( p != NULL ) + { + if ( !strcmp ( p , s2 ) ) { return(1) ;} + p = strtok( NULL, delims ) ; + } + return(0) ; +} + + +char halo_define[4*4096], halo_use[NAMELEN], halo_id[NAMELEN], upper_case_corename[NAMELEN], x[NAMELEN] ; + +int +gen_nest_interp ( char * dirname ) +{ + char * corename ; + char * fnlst[] = { "nest_forcedown_interp.inc" , "nest_interpdown_interp.inc" , + "nest_feedbackup_interp.inc", "nest_feedbackup_smooth.inc", + 0L } ; + int down_path[] = { FORCE_DOWN , INTERP_DOWN , INTERP_UP, SMOOTH_UP } ; + int ipath ; + char ** fnp ; char * fn ; + char fname[NAMELEN] ; + FILE * fp ; + int i ; + + for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ ) + { + fn = *fnp ; + for ( i = 0 ; i < get_num_cores() ; i++ ) + { + corename = get_corename_i(i) ; + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) + { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; } + else + { sprintf(fname,"%s_%s",corename,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + +strcpy( upper_case_corename , corename ) ; +make_upper_case( upper_case_corename ) ; +if ( down_path[ipath] == INTERP_DOWN ) { sprintf(halo_id,"HALO_%s_INTERP_DOWN",upper_case_corename) ; } +else if ( down_path[ipath] == FORCE_DOWN ) { sprintf(halo_id,"HALO_%s_FORCE_DOWN",upper_case_corename) ; } +else if ( down_path[ipath] == INTERP_UP ) { sprintf(halo_id,"HALO_%s_INTERP_UP",upper_case_corename) ; } +else if ( down_path[ipath] == SMOOTH_UP ) { sprintf(halo_id,"HALO_%s_INTERP_SMOOTH",upper_case_corename) ; } +sprintf(halo_define,"80:") ; +sprintf(halo_use,"dyn_%s",corename) ; + +#if 0 + gen_nest_interp1 ( fp , Domain.fields, corename, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?1:2 ) ; +#else + gen_nest_interp1 ( fp , Domain.fields, corename, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ) ; +#endif + +{ + node_t * comm_struct ; + comm_struct = new_node( HALO ) ; + strcpy( comm_struct->name , halo_id ) ; + strcpy( comm_struct->use , halo_use ) ; + strcpy( comm_struct->comm_define , halo_define ) ; + add_node_to_end( comm_struct , &Halos ) ; +} + + + close_the_file(fp) ; + } + } + return(0) ; +} + + +int +gen_nest_interp1 ( FILE * fp , node_t * node, char * corename , char * fourdname, int down_path , int use_nest_time_level ) +{ + int i, ii ; + char * fn = "nest_interp.inc" ; + char fname[NAMELEN] ; + node_t *p, *p1, *dim ; + int d2, d3, xdex, ydex, zdex, io_mask ; + char ddim[3][2][NAMELEN] ; + char mdim[3][2][NAMELEN] ; + char pdim[3][2][NAMELEN] ; + char ddim2[3][2][NAMELEN] ; + char mdim2[3][2][NAMELEN] ; + char pdim2[3][2][NAMELEN] ; + char nddim[3][2][NAMELEN] ; + char nmdim[3][2][NAMELEN] ; + char npdim[3][2][NAMELEN] ; + char nddim2[3][2][NAMELEN] ; + char nmdim2[3][2][NAMELEN] ; + char npdim2[3][2][NAMELEN] ; + char vname[NAMELEN] ; char vname2[NAMELEN] ; char tag[NAMELEN], tag2[NAMELEN] ; char core[NAMELEN], core2[NAMELEN] ; + char fcn_name[NAMELEN] ; + char xstag[NAMELEN], ystag[NAMELEN] ; + char dexes[NAMELEN] ; + char ndexes[NAMELEN] ; + char *maskstr ; + char *grid ; + + + for ( p1 = node ; p1 != NULL ; p1 = p1->next ) + { + if ( p1->node_kind & FOURD ) + { + if ( p1->members->next ) { + io_mask = p1->members->next->io_mask ; + } else { + continue ; + } + } + else + { + io_mask = p1->io_mask ; + } + p = p1 ; + + if ( io_mask & down_path ) + { + if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4)) + { + + if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s_",corename,vname) ; + else sprintf(core,"") ; + + if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; } + else { sprintf(tag,"") ; sprintf(tag2,"") ; } + + /* construct variable name */ + if ( p->node_kind & FOURD ) { + +sprintf(x, "%s%s", p->name, tag ) ; +if ( ! contains_tok ( halo_define , x , ":," ) ) { + if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,p->name) ; strcat(halo_define,tag) ; } + else { strcat(halo_define,",") ; strcat(halo_define,p->name) ; strcat(halo_define,tag) ; } +} + strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ; + sprintf(vname,"%s%s(%s,itrace)",p->name,tag,dexes) ; + strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ; + sprintf(vname2,"%s%s%s(%s,itrace)",core,p->name,tag2,ndexes) ; + + if ( down_path & SMOOTH_UP ) { + strcpy( fcn_name , p->members->next->smoothu_fcn_name ) ; + } else { + strcpy( fcn_name , (down_path & INTERP_UP)?p->members->next->interpu_fcn_name:((down_path & FORCE_DOWN)?p->members->next->force_fcn_name:p->members->next->interpd_fcn_name) ) ; + } + } + else + { + sprintf(vname,"%s%s",p->name,tag) ; + +if ( ! contains_tok ( halo_define , vname , ":," ) ) { + if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,vname) ; } + else { strcat(halo_define,",") ; strcat(halo_define,vname) ; } +} + sprintf(vname2,"%s%s%s",core,p->name,tag2) ; + if ( down_path & SMOOTH_UP ) { + strcpy( fcn_name , p->smoothu_fcn_name ) ; + } else { + strcpy( fcn_name , (down_path & INTERP_UP)?p->interpu_fcn_name:((down_path & FORCE_DOWN)?p->force_fcn_name:p->interpd_fcn_name) ) ; + } + } + + if ( p1->node_kind & FOURD ) { + grid = "" ; + set_dim_strs ( p->members->next , ddim , mdim , pdim , "c", 1 ) ; + set_dim_strs ( p->members->next , ddim2 , mdim2 , pdim2 , "c", 0 ) ; + set_dim_strs ( p->members->next , nddim , nmdim , npdim , "n", 1 ) ; + set_dim_strs ( p->members->next , nddim2 , nmdim2 , npdim2 , "n", 0 ) ; + zdex = get_index_for_coord( p->members->next , COORD_Z ) ; + xdex = get_index_for_coord( p->members->next , COORD_X ) ; + ydex = get_index_for_coord( p->members->next , COORD_Y ) ; + if ( p->members->next->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ; + if ( p->members->next->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ; + if ( p->members->next->stag_x && p->members->next->stag_y ) { + maskstr = "_xystag" ; + } else if ( p->stag_x ) { + maskstr = "_xstag" ; + } else if ( p->stag_y ) { + maskstr = "_ystag" ; + } else { + maskstr = "_nostag" ; + } + } else { + grid = "grid%" ; + set_dim_strs ( p , ddim , mdim , pdim , "c", 1 ) ; + set_dim_strs ( p , ddim2 , mdim2 , pdim2 , "c", 0 ) ; + set_dim_strs ( p , nddim , nmdim , npdim , "n", 1 ) ; + set_dim_strs ( p , nddim2 , nmdim2 , npdim2 , "n", 0 ) ; + zdex = get_index_for_coord( p , COORD_Z ) ; + xdex = get_index_for_coord( p , COORD_X ) ; + ydex = get_index_for_coord( p , COORD_Y ) ; + if ( p->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ; + if ( p->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ; + if ( p->stag_x && p->stag_y ) { + maskstr = "_xystag" ; + } else if ( p->stag_x ) { + maskstr = "_xstag" ; + } else if ( p->stag_y ) { + maskstr = "_ystag" ; + } else { + maskstr = "_nostag" ; + } + } + + if ( p->node_kind & FOURD ) + { +fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ; + } + +fprintf(fp,"CALL %s ( & \n", fcn_name ) ; + + if ( zdex >= 0 ) { + +/* note this is only good for IKJ */ + +fprintf(fp," %s%s, & ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + ddim[0][0], ddim[0][1], ddim[1][0], ddim[1][1], ddim[2][0], ddim[2][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + mdim[0][0], mdim[0][1], mdim[1][0], mdim[1][1], mdim[2][0], mdim[2][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + pdim[0][0], pdim[0][1], pdim2[1][0], pdim2[1][1], pdim[2][0], pdim[2][1] ) ; +if ( ! (down_path & SMOOTH_UP) ) { +fprintf(fp," ngrid%%%s, & ! ND field\n", vname2) ; +} +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + nddim[0][0], nddim[0][1], nddim[1][0], nddim[1][1], nddim[2][0], nddim[2][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + nmdim[0][0], nmdim[0][1], nmdim[1][0], nmdim[1][1], nmdim[2][0], nmdim[2][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + npdim[0][0], npdim[0][1], npdim2[1][0], npdim2[1][1], npdim[2][0], npdim[2][1] ) ; + + } else { + +/* note this is only good for IKJ */ + +fprintf(fp," %s%s, & ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + ddim[0][0], ddim[0][1], "1", "1", ddim[1][0], ddim[1][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + mdim[0][0], mdim[0][1], "1", "1", mdim[1][0], mdim[1][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! CD dims\n", + pdim[0][0], pdim[0][1], "1", "1", pdim[1][0], pdim[1][1] ) ; +if ( ! (down_path & SMOOTH_UP) ) { +fprintf(fp," ngrid%%%s, & ! ND field\n", vname2) ; +} +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + nddim[0][0], nddim[0][1], "1", "1", nddim[1][0], nddim[1][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + nmdim[0][0], nmdim[0][1], "1", "1", nmdim[1][0], nmdim[1][1] ) ; +fprintf(fp," %s, %s, %s, %s, %s, %s, & ! ND dims\n", + npdim[0][0], npdim[0][1], "1", "1", npdim[1][0], npdim[1][1] ) ; + + } + +if ( ! (down_path & SMOOTH_UP) ) { + if ( sw_deref_kludge == 1 ) { +fprintf(fp," config_flags%%shw, ngrid%%imask%s(nims,njms), & ! stencil half width\n",maskstr) ; + } else { +fprintf(fp," config_flags%%shw, ngrid%%imask%s, & ! stencil half width\n",maskstr) ; + } +} +fprintf(fp," %s, %s, & ! xstag, ystag\n", xstag, ystag ) ; +fprintf(fp," ngrid%%i_parent_start, ngrid%%j_parent_start, &\n") ; +fprintf(fp," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio &\n") ; + + { + char tmpstr[NAMELEN], *p1 ; + node_t * nd, * pp ; + pp = NULL ; + if ( p->node_kind & FOURD ) { + if ( p->members->next ) { + pp = p->members->next ; + } + } else { + pp = p ; + } + if ( pp ) { + strcpy( tmpstr , "" ) ; + if ( down_path & SMOOTH_UP ) { + strcpy( tmpstr , pp->smoothu_aux_fields ) ; + } else if ( down_path & INTERP_UP ) { + strcpy( tmpstr , pp->interpu_aux_fields ) ; + } else if ( down_path & FORCE_DOWN ) { + /* by default, add the boundary and boundary tendency fields to the arg list */ + if ( ! p->node_kind & FOURD ) { + sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name ) ; + } else { + sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name ) ; + } + strcat( tmpstr , pp->force_aux_fields ) ; + } else if ( down_path & INTERP_DOWN ) { + strcpy( tmpstr , pp->interpd_aux_fields ) ; + } + + for ( p1 = strtok(tmpstr,",") ; p1 != NULL ; p1 = strtok(NULL,",") ) + { + if (( nd = get_entry ( p1 , Domain.fields )) != NULL ) + { + if (!strncmp( nd->use, "dyn_", 4)) sprintf(core2,"%s_",corename,vname) ; + else sprintf(core2,"") ; + if ( nd->boundary_array ) { + if ( sw_new_bdys ) { + int bdy ; + for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { + if ( strcmp( nd->use , "_4d_bdy_array_" ) ) { + fprintf(fp,",%s%s,ngrid%%%s%s%s &\n", nd->name, bdy_indicator(bdy), core2, nd->name, bdy_indicator(bdy) ) ; + } else { + char c ; + c = 'i' ; if ( bdy <= 2 ) c = 'j' ; + fprintf(fp,",%s%s%s(c%cms,1,1,itrace),ngrid%%%s%s%s(n%cms,1,1,itrace) &\n", core2, nd->name, bdy_indicator(bdy), c, core2, nd->name, bdy_indicator(bdy), c ) ; + } + } + } else { + if ( strcmp( nd->use , "_4d_bdy_array_" ) ) { + fprintf(fp,",%s,ngrid%%%s%s &\n", nd->name, core2, nd->name ) ; + } else { + fprintf(fp,",%s%s(1,1,1,1,itrace),ngrid%%%s%s(1,1,1,1,itrace) &\n", core2, nd->name, core2, nd->name ) ; + } + } + } else { + fprintf(fp,",grid%%%s%s,ngrid%%%s%s &\n", core2, nd->name, core2, nd->name ) ; + } + } + else + { + fprintf(stderr,"REGISTRY WARNING: Don't know about %s in definition of %s\n",p1,vname) ; + } + } + } + } + +fprintf(fp," ) \n") ; + + if ( p->node_kind & FOURD ) + { +fprintf(fp,"ENDDO\n") ; + } + + } + } + } + + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_mod_state_descr.c b/wrfv2_fire/tools/gen_mod_state_descr.c new file mode 100644 index 00000000..f9e57948 --- /dev/null +++ b/wrfv2_fire/tools/gen_mod_state_descr.c @@ -0,0 +1,73 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +int +gen_module_state_description ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "module_state_description.F" ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_module_state_description1 ( fp , &Domain ) ; + close_the_file( fp ) ; + return(0) ; +} + +int +gen_module_state_description1 ( FILE * fp , node_t * node ) +{ + node_t * p, * q ; + char * x ; + + if ( node == NULL ) return(1) ; + + fprintf(fp,"MODULE module_state_description\n") ; + + fprintf(fp," ! package constants\n") ; + for ( p = Packages ; p != NULL ; p = p->next ) + { + x=index(p->pkg_assoc,'=') ; x+=2 ; + fprintf(fp," INTEGER, PARAMETER :: %s = %s\n",p->name,x) ; + } + fprintf(fp," ! 4D array constants\n") ; + for ( p = FourD ; p != NULL ; p=p->next4d ) + { + int c1 ; + for( q = p->members, c1=0 ; q != NULL ; q=q->next, c1++ ) + { + if ( strcmp(q->name,"-" ) ) + { + fprintf(fp," INTEGER, PARAMETER :: PARAM_%s = %d\n",q->name,c1) ; + fprintf(fp," INTEGER :: P_%s = 1\n",q->name) ; + fprintf(fp," LOGICAL :: F_%s = .FALSE.\n",q->name) ; + } + } + fprintf(fp," INTEGER, PARAMETER :: PARAM_NUM_%s = %d\n",p->name,c1) ; + fprintf(fp," INTEGER :: NUM_%s = 1\n",p->name) ; + } + fprintf(fp," INTEGER, PARAMETER :: %-30s = %d\n", "P_XSB",1 ) ; + fprintf(fp," INTEGER, PARAMETER :: %-30s = %d\n", "P_XEB",2 ) ; + fprintf(fp," INTEGER, PARAMETER :: %-30s = %d\n", "P_YSB",3 ) ; + fprintf(fp," INTEGER, PARAMETER :: %-30s = %d\n", "P_YEB",4 ) ; + + fprintf(fp," INTEGER, PARAMETER :: NUM_TIME_LEVELS = %d\n", max_time_level ) ; + fprintf(fp," INTEGER , PARAMETER :: PARAM_FIRST_SCALAR = 2\n" ) ; + + fprintf(fp,"CONTAINS\n" ) ; + fprintf(fp,"SUBROUTINE init_module_state_description\n" ) ; + fprintf(fp,"END SUBROUTINE init_module_state_description\n" ) ; + fprintf(fp,"END MODULE module_state_description\n") ; + + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_model_data_ord.c b/wrfv2_fire/tools/gen_model_data_ord.c new file mode 100644 index 00000000..c4b2a4ec --- /dev/null +++ b/wrfv2_fire/tools/gen_model_data_ord.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +int +gen_model_data_ord ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "model_data_order.inc" ; + int i ; + + if ( dirname == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + else { sprintf(fname,"%s",fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + fprintf(fp,"INTEGER , PARAMETER :: model_data_order = DATA_ORDER_") ; + for ( i = 0 ; i < 3 ; i++ ) + { + switch ( model_order[i] ) + { + case ( COORD_X ) : fprintf(fp,"X") ; break ; + case ( COORD_Y ) : fprintf(fp,"Y") ; break ; + case ( COORD_Z ) : fprintf(fp,"Z") ; break ; + default : fprintf(stderr,"Model data order ambiguous. Is there a dimspec for all three coordinate axes?\n") ; break ; + } + } + fprintf(fp,"\n") ; + close_the_file( fp ) ; + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_scalar_derefs.c b/wrfv2_fire/tools/gen_scalar_derefs.c new file mode 100644 index 00000000..75f3cfa3 --- /dev/null +++ b/wrfv2_fire/tools/gen_scalar_derefs.c @@ -0,0 +1,108 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +#define DUMMY 1 +#define ACTUAL 2 + +int +gen_scalar_derefs ( char * dirname ) +{ + int i ; + + for ( i = 0 ; i < get_num_cores() ; i++ ) + scalar_derefs ( dirname , get_corename_i(i) ) ; + return(0) ; +} + +#define DIR_COPY_OUT 1 +#define DIR_COPY_IN 2 + +int +scalar_derefs ( char * dirname , char * corename ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "_scalar_derefs.inc" ; + char * p ; + int linelen ; + char outstr[64*4096] ; + + if ( dirname == NULL || corename == NULL ) return(1) ; + if ( strlen(dirname) > 0 ) + { sprintf(fname,"%s/%s%s",dirname,corename, fn) ; } + else + { sprintf(fname,"%s%s",corename,fn) ; } + + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + fprintf(fp,"! BEGIN SCALAR DEREFS\n") ; + linelen = 0 ; + if ( sw_limit_args ) { + fprintf(fp,"#undef CPY\n") ; + fprintf(fp,"#undef CPYC\n") ; + fprintf(fp,"#ifdef COPY_OUT\n") ; + scalar_derefs1 ( fp , corename , &Domain, DIR_COPY_OUT ) ; + fprintf(fp,"#else\n") ; + scalar_derefs1 ( fp , corename , &Domain, DIR_COPY_IN ) ; + fprintf(fp,"#endif\n") ; + } + fprintf(fp,"! END SCALAR DEREFS\n") ; + close_the_file( fp ) ; + return(0) ; +} + +int +scalar_derefs1 ( FILE * fp , char * corename, node_t * node, int direction ) +{ + node_t * p ; + int tag ; + char fname[NAMELEN] ; + + if ( node == NULL ) return(1) ; + for ( p = node->fields ; p != NULL ; p = p->next ) + { + if ( p->node_kind & I1 ) continue ; /* short circuit any field that is not state */ + /* short circuit DERIVED types */ + if ( p->type->type_type == DERIVED ) continue ; + /* short circuit non-scalars */ + if ( p->ndims > 0 ) continue ; + + if ( ( + /* if it's a core specific field and we're doing that core or... */ + (p->node_kind & FIELD && (!strncmp("dyn_",p->use,4)&&!strcmp(corename,p->use+4))) + /* it is not a core specific field and it is not a derived type -ajb */ + || (p->node_kind & FIELD && (p->type->type_type != DERIVED) && ( strncmp("dyn_",p->use,4))) +#if 0 + /* it is a state variable */ + || (p->node_kind & RCONFIG ) +#endif + ) + ) + { + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + char * x ; + /* if this is a core-specific variable, prepend the name of the core to */ + /* the variable at the driver level */ + if (!strcmp( corename , p->use+4 )) { x = "C" ; } else { x = "" ; } + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + /* generate deref */ + if ( direction == DIR_COPY_OUT ) { + if (!strcmp( corename , p->use+4 )) { fprintf(fp, " grid%%%s_%s = %s\n",corename,fname,fname) ; } + else { fprintf(fp, " grid%%%s = %s\n",fname,fname ) ; } + } else { + if (!strcmp( corename , p->use+4 )) { fprintf(fp, " %s = grid%%%s_%s\n",fname,corename,fname) ; } + else { fprintf(fp, " %s = grid%%%s\n",fname,fname ) ; } + } + } + } + } + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_scalar_indices.c b/wrfv2_fire/tools/gen_scalar_indices.c new file mode 100644 index 00000000..0c5a88fd --- /dev/null +++ b/wrfv2_fire/tools/gen_scalar_indices.c @@ -0,0 +1,167 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + + +int +gen_scalar_indices ( char * dirname ) +{ + FILE * fp ; + char fname[NAMELEN] ; + char * fn = "scalar_indices.inc" ; + char * fn2 = "scalar_tables.inc" ; + char * fn3 = "scalar_tables_init.inc" ; + char * fn4 = "scalar_indices_init.inc" ; + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; + gen_scalar_indices1 ( fp ) ; + close_the_file( fp ) ; + + strcpy( fname, fn2 ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn2) ; } + if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; } + print_warning(fp,fname) ; + gen_scalar_tables ( fp ) ; + close_the_file( fp ) ; + + strcpy( fname, fn3 ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn3) ; } + if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; } + print_warning(fp,fname) ; + gen_scalar_tables_init ( fp ) ; + close_the_file( fp ) ; + + strcpy( fname, fn4 ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn4) ; } + if ((fp = fopen( fname , "w" )) == NULL ) { fprintf(stderr,"returning\n") ; return(1) ; } + print_warning(fp,fname) ; + gen_scalar_indices_init ( fp ) ; + close_the_file( fp ) ; + + return(0) ; +} + +int +gen_scalar_tables ( FILE * fp ) +{ + node_t * p ; + for ( p = FourD ; p != NULL ; p=p->next4d ) + { + fprintf(fp," INTEGER :: %s_index_table( param_num_%s, max_domains )\n",p->name,p->name ) ; + fprintf(fp," INTEGER :: %s_num_table( max_domains )\n", p->name,p->name ) ; + fprintf(fp," INTEGER :: %s_stream_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256 :: %s_dname_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256 :: %s_desc_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256 :: %s_units_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + } + return(0) ; +} + +int +gen_scalar_tables_init ( FILE * fp ) +{ + node_t * p ; + for ( p = FourD ; p != NULL ; p=p->next4d ) + { + fprintf(fp," %s_num_table( j ) = 1\n",p->name ) ; + } + return(0) ; +} + +int +gen_scalar_indices_init ( FILE * fp ) +{ + node_t * p ; + for ( p = FourD ; p != NULL ; p=p->next4d ) + { + fprintf(fp," num_%s = %s_num_table( idomain )\n",p->name,p->name ) ; + } + return(0) ; +} + +int +gen_scalar_indices1 ( FILE * fp ) +{ + node_t * p, * memb , * pkg, * rconfig, * fourd, *x ; + char * c , *pos1, *pos2 ; + char assoc_namelist_var[NAMELEN], assoc_namelist_choice[NAMELEN], assoc_4d[NAMELEN_LONG] ; + char scalars_str[NAMELEN_LONG] ; + char * scalars ; + + for ( p = FourD ; p != NULL ; p = p->next ) + { for ( memb = p->members ; memb != NULL ; memb = memb->next ) + { if ( strcmp(memb->name,"-") ) fprintf(fp," P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name ) ; } } + + for ( pkg = Packages ; pkg != NULL ; pkg = pkg->next ) + { + strcpy( assoc_namelist_var , pkg->pkg_assoc ) ; + if ((c = index( assoc_namelist_var , '=' ))==NULL) continue ; + *c = '\0' ; c += 2 ; + strcpy( assoc_namelist_choice , c ) ; + if ((rconfig=get_rconfig_entry ( assoc_namelist_var )) == NULL ) + { fprintf(stderr, + "WARNING: There is no associated namelist variable %s\n", + assoc_namelist_var) ; return(1) ; } + fprintf(fp," IF (model_config_rec%%%s%s==%s)THEN\n", + assoc_namelist_var, + (atoi(rconfig->nentries)!=1)?"(idomain)":"", /* a little tricky; atoi of nentries will be '0' for a string like max_domains */ + assoc_namelist_choice) ; + strcpy(scalars_str,pkg->pkg_4dscalars) ; + + if ((scalars = strtok_rentr(scalars_str,";", &pos1)) != NULL) + { + while ( scalars != NULL ) { + + if ((c = strtok_rentr(scalars,":",&pos2)) != NULL) strcpy(assoc_4d,c) ; /* get name of associated 4d array */ + if (strcmp(c,"-")) { + if ((fourd=get_4d_entry( assoc_4d )) == NULL ) + { fprintf(stderr, "WARNING: There is no 4D array named %s\n",assoc_4d);continue;} + for ( c = strtok_rentr(NULL,",",&pos2) ; c != NULL ; c = strtok_rentr(NULL,",",&pos2) ) + { + if ( ( x = get_entry( c , fourd->members )) == NULL ) + { fprintf(stderr, "WARNING: %s is not a member of 4D array %s\n",c,assoc_4d);continue;} + fprintf(fp," IF ( %s_index_table( PARAM_%s , idomain ) .lt. 1 ) THEN\n",assoc_4d,c) ; + fprintf(fp," %s_num_table(idomain) = %s_num_table(idomain) + 1\n",assoc_4d,assoc_4d) ; + fprintf(fp," P_%s = %s_num_table(idomain)\n",c,assoc_4d) ; + fprintf(fp," %s_index_table( PARAM_%s , idomain ) = P_%s\n",assoc_4d,c,c) ; + fprintf(fp," ELSE\n") ; + fprintf(fp," P_%s = %s_index_table( PARAM_%s , idomain )\n",c,assoc_4d,c) ; + fprintf(fp," END IF\n") ; + { + char fourd_bnd[NAMELEN] ; + /* check for the existence of a fourd boundary array associated with this 4D array */ + /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */ + /* arrays */ + sprintf(fourd_bnd,"%s_b",assoc_4d) ; + if ( get_entry( fourd_bnd ,Domain.fields) != NULL ) { + x->io_mask |= BOUNDARY ; + } + } + fprintf(fp," %s_stream_table( idomain, P_%s ) = %d\n",assoc_4d,c, x->io_mask ) ; + fprintf(fp," %s_dname_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->dname) ; + fprintf(fp," %s_desc_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->descrip) ; + fprintf(fp," %s_units_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->units) ; + fprintf(fp," F_%s = .TRUE.\n",c) ; + } + } + + scalars = strtok_rentr(NULL,";", &pos1) ; + + } + } + + fprintf(fp," END IF\n") ; + } + + return(0) ; +} + + diff --git a/wrfv2_fire/tools/gen_wrf_io.c b/wrfv2_fire/tools/gen_wrf_io.c new file mode 100644 index 00000000..2bb4dcaa --- /dev/null +++ b/wrfv2_fire/tools/gen_wrf_io.c @@ -0,0 +1,1404 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" +#include "sym.h" + +static FILE * fp ; + +#define GEN_INPUT 1 +#define GEN_OUTPUT 2 + +#define OP_F(A,B) \ + fn = B ; \ + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } \ + else { sprintf(fname,"%s",fn) ; } \ + if ((A = fopen( fname , "w" )) == NULL ) return(1) ; \ + print_warning(A,fname) ; \ + sym_forget() ; + +int +gen_wrf_io ( char * dirname ) +{ + char fname[NAMELEN], *fn ; + + if ( dirname == NULL ) return(1) ; + +#if 1 + + OP_F(fp,"wrf_metaput_input.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | INPUT , GEN_OUTPUT ) ; + + OP_F(fp,"wrf_metaput_restart.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | RESTART , GEN_OUTPUT ) ; + + OP_F(fp,"wrf_metaput_history.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | HISTORY , GEN_OUTPUT ) ; + + OP_F(fp,"wrf_metaput_boundary.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | BOUNDARY , GEN_OUTPUT ) ; + + OP_F(fp,"wrf_histout.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist1out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist2out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist3out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist4out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist5out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist6out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist7out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist8out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist9out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist10out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist11out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_OUTPUT ) ; + close_the_file(fp) ; + + OP_F(fp,"wrf_inputout.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput1out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput2out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput3out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput4out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput5out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput6out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput7out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput8out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput9out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput10out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput11out.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_restartout.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_OUTPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_bdyout.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_OUTPUT ) ; + close_the_file(fp) ; +#endif + +#if 1 + OP_F(fp,"wrf_metaget_input.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | INPUT , GEN_INPUT ) ; + + OP_F(fp,"wrf_metaget_restart.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | RESTART , GEN_INPUT ) ; + + OP_F(fp,"wrf_metaget_history.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | HISTORY , GEN_INPUT ) ; + + OP_F(fp,"wrf_metaget_boundary.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , + METADATA | BOUNDARY , GEN_INPUT ) ; + + OP_F(fp,"wrf_histin.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist1in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist2in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist3in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist4in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist5in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist6in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist7in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist8in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist9in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist10in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxhist11in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_inputin.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput1in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput2in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput3in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput4in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput5in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput6in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput7in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput8in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput9in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput10in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_auxinput11in.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_restartin.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_INPUT ) ; + close_the_file(fp) ; + OP_F(fp,"wrf_bdyin.inc") ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_INPUT ) ; + close_the_file(fp) ; +#endif + + return(0) ; +} + +int +set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag ) +{ + int i, j ; + node_t *p ; + char d, d1 ; + char * stag ; + char r1[NAMELEN] ; + + strcpy(r1,"grid%") ; + if ( node == NULL ) return(1) ; + for ( i = 0 ; i < 3 ; i++ ) + for ( j = 0 ; j < 2 ; j++ ) + { + strcpy(ddim[i][j],"1") ; + strcpy(mdim[i][j],"1") ; + strcpy(pdim[i][j],"1") ; + } + + for ( i = 0 ; i < node->ndims ; i++ ) + { + p = node->dims[i] ; + if ( p->len_defined_how == DOMAIN_STANDARD ) + { + if ( p->subgrid ) { + switch( p->coord_axis ) + { + case(COORD_X) : d = 'i' ; d1 = 'x' ; break ; + case(COORD_Y) : d = 'j' ; d1 = 'y' ; break ; + case(COORD_Z) : d = 'k' ; d1 = 'z' ; break ; + default : break ; + } + + sprintf(ddim[i][0],"%s%cds",prepend,d) ; + sprintf(ddim[i][1],"%s%cde * %ssr_%c ",prepend,d,r1,d1) ; + sprintf(mdim[i][0],"(%s%cms-1)*%ssr_%c+1",prepend,d,r1,d1) ; + sprintf(mdim[i][1],"%s%cme*%ssr_%c",prepend,d,r1,d1) ; + sprintf(pdim[i][0],"(%s%cps-1)*%ssr_%c+1",prepend,d,r1,d1) ; + sprintf(pdim[i][1],"%s%cpe*%ssr_%c",prepend,d,r1,d1) ; + + } else { + if ( sw_3dvar_iry_kludge ) { + switch( p->coord_axis ) + { + /* vvv */ + case(COORD_X) : d = 'i' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + case(COORD_Y) : d = 'j' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + /* ^^^ */ + case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + default : stag = "1" ; break ; + } + } else { + switch( p->coord_axis ) + { + case(COORD_X) : d = 'i' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + case(COORD_Y) : d = 'j' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ; + default : stag = "1" ; break ; + } + } + + sprintf(ddim[i][0],"%s%cds",prepend,d) ; + sprintf(ddim[i][1],stag,prepend,d) ; /* note that stag has printf format info in it */ + sprintf(mdim[i][0],"%s%cms",prepend,d) ; + sprintf(mdim[i][1],"%s%cme",prepend,d) ; + sprintf(pdim[i][0],"%s%cps",prepend,d) ; + if ( ! sw_disregard_stag ) + sprintf(pdim[i][1],"MIN( %s, %s%cpe )",ddim[i][1],prepend,d) ; + else + sprintf(pdim[i][1],"%s%cpe",prepend,d) ; + } + } + else if ( p->len_defined_how == NAMELIST ) + { + if ( !strcmp( p->assoc_nl_var_s, "1" ) ) + { + sprintf(ddim[i][0],"1") ; + sprintf(mdim[i][0],"1") ; + sprintf(pdim[i][0],"1") ; + } + else + { + sprintf(ddim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; + sprintf(mdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; + sprintf(pdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ; + } + sprintf(ddim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; + sprintf(mdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; + sprintf(pdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ; + } + else if ( p->len_defined_how == CONSTANT ) + { + sprintf(ddim[i][0],"%d",p->coord_start ) ; + sprintf(ddim[i][1],"%d",p->coord_end ) ; + sprintf(mdim[i][0],"%d",p->coord_start ) ; + sprintf(mdim[i][1],"%d",p->coord_end ) ; + sprintf(pdim[i][0],"%d",p->coord_start ) ; + sprintf(pdim[i][1],"%d",p->coord_end ) ; + } + } + return(0) ; +} + +int +gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int io_mask , int sw_io ) +{ + node_t * p ; + int i , ii ; + char x[NAMELEN], tag[NAMELEN], dexes[NAMELEN] ; + char dname[NAMELEN], dname_tmp[NAMELEN] ; + char vname[NAMELEN], vname_x[NAMELEN],vname_1[NAMELEN], vname_2[NAMELEN], memord[NAMELEN] ; + char ddim[3][2][NAMELEN] ; + char mdim[3][2][NAMELEN] ; + char pdim[3][2][NAMELEN] ; + char ddim_no[3][2][NAMELEN] ; + char mdim_no[3][2][NAMELEN] ; + char pdim_no[3][2][NAMELEN] ; + char dimname[3][NAMELEN] ; + char core[NAMELEN] ; + char stagstr[NAMELEN] ; + char * tend_tag ; + + char post[NAMELEN] ; + char indices[NAMELEN] ; + + int pass, passes, stagx, stagy, stagz ; + int xi, yi, zi ; + node_t * dimnode ; + int ok_to_collect_distribute ; + +/* set a flag according to what the stream is, if we're running on dm processors, if the + io layer cannot handle distributed data, and if we're selectively turning off the + collect/distribute message passing so that history and restart I/O is to separate files + but input and boundary I/O is unaffected */ + + ok_to_collect_distribute = !sw_distrib_io_layer && + sw_dm_parallel && + !(sw_dm_serial_in_only && ((io_mask&HISTORY) || + (io_mask&AUXHIST1) || + (io_mask&AUXHIST2) || + (io_mask&AUXHIST3) || + (io_mask&AUXHIST4) || + (io_mask&AUXHIST5) || + (io_mask&AUXHIST6) || + (io_mask&AUXHIST7) || + (io_mask&AUXHIST8) || + (io_mask&AUXHIST9) || + (io_mask&AUXHIST10) || + (io_mask&AUXHIST11) || + (io_mask&RESTART))) ; + + if ( node == NULL ) return(1) ; + if ( structname == NULL ) return(1) ; + if ( fp == NULL ) return(1) ; + + for ( p = node ; p != NULL ; p = p->next ) + { + + if ( p->ndims > 3 ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */ + + if ( p->node_kind & I1 ) continue ; /* short circuit anything that's not a state var */ + + set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */ + set_dim_strs( p, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */ + + strcpy(stagstr, "") ; + if ( p->stag_x ) strcat(stagstr, "X") ; + if ( p->stag_y ) strcat(stagstr, "Y") ; + if ( p->stag_z ) strcat(stagstr, "Z") ; + + if ( !strcmp(p->name,"-") ) continue ; + + if ( p->node_kind & FOURD ) + { + node_t * nd , *pp ; + char p1[NAMELEN], sv[NAMELEN], tl[25] ; + + set_dim_strs( p->members, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */ + set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */ + + if ( ! ( io_mask & BOUNDARY ) ) + { +fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; +fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; +fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ; +fprintf(fp," fid , & ! DataHandle\n") ; +fprintf(fp," current_date(1:19) , & ! DateStr\n") ; +fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ; + strcpy( tl, "" ) ; + if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ; + if ( ok_to_collect_distribute ) { +fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ; + } else { +fprintf(fp," grid%%%s%s(ims,kms,jms,itrace) , & ! Field\n",p->name,tl) ; + } + if (!strncmp(p->members->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; + } +fprintf(fp," grid%%communicator , & ! Comm\n") ; +fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; +fprintf(fp," grid%%domdesc , & ! Comm\n") ; +fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; + if ( sw_io == GEN_OUTPUT ) { +fprintf(fp," dryrun , & ! flag\n") ; + } + set_mem_order( p->members, memord , NAMELEN) ; +fprintf(fp," 'XZY' , & ! MemoryOrder\n") ; + strcpy(stagstr, "") ; + if ( p->members->stag_x ) strcat(stagstr, "X") ; + if ( p->members->stag_y ) strcat(stagstr, "Y") ; + if ( p->members->stag_z ) strcat(stagstr, "Z") ; +fprintf(fp," '%s' , & ! Stagger\n",stagstr) ; + if ( sw_io == GEN_OUTPUT ) { + for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; + for ( i = 0 ; i < 3 ; i++ ) + { + if (( dimnode = p->members->dims[i]) != NULL ) + { + switch ( dimnode->coord_axis ) + { + case (COORD_X) : + if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Y) : + if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Z) : + if ( p->members->stag_z ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + } + } + } +fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; +fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; +fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; +fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ; +fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ; + } +fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ; + /* global dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } + fprintf(fp," & \n") ; + /* mem dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } + fprintf(fp," & \n") ; + /* patch dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } + fprintf(fp," & \n") ; +fprintf(fp," ierr )\n" ) ; +fprintf(fp, " ENDIF\n" ) ; +fprintf(fp, "ENDDO\n") ; + } +/* BOUNDARY FOR 4-D TRACER */ + else if ( io_mask & BOUNDARY ) + { + int ibdy ; + int idx ; + node_t *fourd_bound_array ; + char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ; + char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; + +/* check for the existence of a fourd boundary array */ + sprintf(fourd_bnd,"%s_b",p->name) ; + if (( fourd_bound_array = get_entry( fourd_bnd ,Domain.fields)) != NULL ) { + + for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; + strcpy( dimname[2] , "bdy_width" ) ; + ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ; + ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ; + ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ; + if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL ) + { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[1], dimnode->dim_data_name) ; } + if ( p->stag_z ) { zdomainend = "kde" ; } + else { zdomainend = "(kde-1)" ; } + ds2 = "kds" ; de2 = zdomainend ; + ms2 = "kds" ; me2 = "kde" ; /* 20020924 */ + ps2 = "kds" ; pe2 = zdomainend ; + } + else + { + fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ; + } + for ( pass = 0 ; pass < 2 ; pass++ ) { +fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; +fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; + for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ ) + { + if ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ; /* west bdy */ + } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ; /* east bdy */ + } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ; /* south bdy */ + } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ; /* north bdy */ + } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ; /* west bdy */ + } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ; /* east bdy */ + } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ; /* south bdy */ + } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ; /* north bdy */ + } + if ( ibdy == 1 || ibdy == 2 ) { + if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL ) + { + idx = get_index_for_coord( p , COORD_Y ) ; + if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; } + ds1 = "1" ; de1 = ydomainend ; + ms1 = "1" ; me1 = "MAX( ide , jde )" ; + if ( sw_new_bdys ) { /* 20070207 */ + if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; } + if ( sw_io == GEN_INPUT ) { + ps1 = "MAX(jms,jds)" ; + sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } else { + if ( sw_io == GEN_INPUT ) { + ps1 = "1" ; pe1 = ydomainend ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } + if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[0], dimnode->dim_data_name) ; } + } + } + if ( ibdy == 3 || ibdy == 4 ) { + if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL ) + { + idx = get_index_for_coord( p , COORD_X ) ; + if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; } + ds1 = "1" ; de1 = xdomainend ; + ms1 = "1" ; me1 = "MAX( ide , jde )" ; + if ( sw_new_bdys ) { /* 20070207 */ + if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; } + if ( sw_io == GEN_INPUT ) { + ps1 = "MAX(ims,ids)" ; + sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } else { + if ( sw_io == GEN_INPUT ) { + ps1 = "1" ; pe1 = xdomainend ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } + if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[0], dimnode->dim_data_name) ; } + } + } + if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ; + else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ; + else sprintf(memord,"0") ; +fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ; +fprintf(fp," fid , & ! DataHandle\n") ; +fprintf(fp," current_date(1:19) , & ! DateStr\n") ; +fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ; + if ( ok_to_collect_distribute ) { +fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ; + } else { + strcpy(bdytag2,"") ; + strncat(bdytag2,bdytag, pass+2) ; +if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ + fprintf(fp," grid%%%s%s(%s,kds,1,itrace) , & ! Field\n",p->name,bdytag, ms1) ; +} else { + fprintf(fp," grid%%%s%s(1,kds,1,%d,itrace) , & ! Field\n",p->name,bdytag2, ibdy) ; +} + } + if (!strncmp(p->members->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; + } +fprintf(fp," grid%%communicator , & ! Comm\n") ; +fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; +fprintf(fp," grid%%domdesc , & ! Comm\n") ; +fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; + if ( sw_io == GEN_OUTPUT ) { +fprintf(fp," dryrun , & ! flag\n") ; + } +fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ; + strcpy(stagstr, "") ; + if ( p->members->stag_x ) strcat(stagstr, "X") ; + if ( p->members->stag_y ) strcat(stagstr, "Y") ; + if ( p->members->stag_z ) strcat(stagstr, "Z") ; +fprintf(fp," '%s' , & ! Stagger\n",stagstr) ; + if ( sw_io == GEN_OUTPUT ) { +fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; +fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; +fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; +fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ; +fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ; + } +fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder XZY' , & ! Debug message\n", fname, p->name ) ; +fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; +fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; +fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; +fprintf(fp," ierr )\n" ) ; + } +fprintf(fp, " ENDIF\n" ) ; +fprintf(fp, "ENDDO\n") ; + } + } + } /* if fourd bound array associated with this tracer */ + } + else if ( p->type != NULL ) + { + + if ( p->type->type == SIMPLE ) + { + +/* //////// BOUNDARY ///////////////////// */ + + if ( p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA ) + && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) ) + { + int ibdy ; + int idx ; + char *bdytag, *xdomainend, *ydomainend, *zdomainend ; + char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; + char t1[64], t2[64] ; + + if (!strncmp( p->use, "dyn_", 4)) + sprintf(core,"%s_",p->use+4) ; + else + strcpy(core,"") ; + + for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; + strcpy( dimname[2] , "bdy_width" ) ; + ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ; + ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ; + ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ; + + if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL ) + { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[1], dimnode->dim_data_name) ; } + if ( p->stag_z ) { zdomainend = "kde" ; } + else { zdomainend = "(kde-1)" ; } + ds2 = "kds" ; de2 = zdomainend ; + ms2 = "kds" ; me2 = "kde" ; /* 20020924 */ + ps2 = "kds" ; pe2 = zdomainend ; + } + else + { strcpy(dimname[1],dimname[2]) ; + strcpy(dimname[2],"one_element") ; + ds2 = ds3 ; de2 = de3 ; + ms2 = ms3 ; me2 = me3 ; + ps2 = ps3 ; pe2 = pe3 ; + ds3 = "1" ; de3 = "1" ; + ms3 = "1" ; me3 = "1" ; + ps3 = "1" ; pe3 = "1" ; + } + + if ( strlen(p->dname) < 1 ) { + fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ; + } + + for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ ) + { + if ( ibdy == 1 ) { bdytag = "XS" ; /* west bdy */ + } else if ( ibdy == 2 ) { bdytag = "XE" ; /* east bdy */ + } else if ( ibdy == 3 ) { bdytag = "YS" ; /* south bdy */ + } else if ( ibdy == 4 ) { bdytag = "YE" ; /* north bdy */ + } + if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag) ; } + else { sprintf(dname,"%s%s",p->dname,bdytag) ; } + + make_upper_case(dname) ; + + if ( ibdy == 1 || ibdy == 2 ) { + if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL ) + { + idx = get_index_for_coord( p , COORD_Y ) ; + if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; } + ds1 = "1" ; de1 = ydomainend ; + ms1 = "1" ; me1 = "MAX( ide , jde )" ; + if ( sw_new_bdys ) { /* 20070207 */ + if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; } + if ( sw_io == GEN_INPUT ) { + ps1 = "MAX(jms,jds)" ; + sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } else { + if ( sw_io == GEN_INPUT ) { + ps1 = "1" ; pe1 = ydomainend ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } + if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[0], dimnode->dim_data_name) ; } + } + } + if ( ibdy == 3 || ibdy == 4 ) { + if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL ) + { + idx = get_index_for_coord( p , COORD_X ) ; + if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; } + ds1 = "1" ; de1 = xdomainend ; + ms1 = "1" ; me1 = "MAX( ide , jde )" ; + if ( sw_new_bdys ) { /* 20070207 */ + if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; } + if ( sw_io == GEN_INPUT ) { + ps1 = "MAX(ims,ids)" ; + sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } else { + ms1 = "1" ; me1 = "MAX( ide , jde )" ; + if ( sw_io == GEN_INPUT ) { + ps1 = "1" ; pe1 = xdomainend ; + } else if ( sw_io == GEN_OUTPUT ) { + ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ; + } + } + if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; } + else { strcpy( dimname[0], dimnode->dim_data_name) ; } + } + } + if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ; + else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ; + else sprintf(memord,"0") ; + + passes = 1 ; + if ( fourdname != NULL ) passes = 2 ; + for ( pass = 0 ; pass < passes ; pass++ ) { + tend_tag = ( pass == 0 ) ? "_B" : "_BT" ; + if ( sw_io == GEN_INPUT ) + { + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; + if ( ok_to_collect_distribute ) + fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; + fprintf(fp,"CALL wrf_ext_read_field ( &\n") ; + fprintf(fp," fid , & ! DataHandle \n" ) ; + fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; + if ( fourdname == NULL ) { + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ + fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ; + } else { + fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ; + } + } else { + if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; } + else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; } + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ + fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" , + structname , core , fourdname, tend_tag, bdy_indicator(ibdy), ms1, p->name ) ; + } else { + fprintf(fp," %s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" , + structname , core , fourdname, tend_tag, ibdy, p->name ) ; + } + } + if (!strncmp(p->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; + } + fprintf(fp," grid%%communicator , & ! Comm\n") ; + fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid%%domdesc , & ! Comm\n") ; + fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; + fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; + fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; + fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; + /* global dimensions */ + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; + fprintf(fp," ierr )\n") ; + if ( ok_to_collect_distribute ) + { + fprintf(fp,"ENDIF\n") ; + fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , core , p->name, ibdy) ; + fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1) )\n",me1,ms1,me2,ms2,me3,ms3) ; + } + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"END IF\n" ) ; + } + else if ( sw_io == GEN_OUTPUT ) + { + if ( ok_to_collect_distribute ) + fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; + fprintf(fp,"CALL wrf_ext_write_field ( &\n") ; + fprintf(fp," fid , & ! DataHandle \n" ) ; + fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; + if ( fourdname == NULL ) { + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ + fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ; + } else { + fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ; + } + } else { + if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; } + else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; } + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ + fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" , + structname , core , fourdname, tend_tag, ms1, bdy_indicator(ibdy), p->name ) ; + } else { + fprintf(fp," %s%s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" , + structname , core , fourdname, tend_tag, ibdy, bdy_indicator(ibdy), p->name ) ; + } + } + if (!strncmp(p->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; + } + fprintf(fp," grid%%communicator , & ! Comm\n") ; + fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid%%domdesc , & ! Comm\n") ; + fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; + fprintf(fp," dryrun , & ! flag\n" ) ; + fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; + fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; + fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; + fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; + fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; + fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ; + fprintf(fp," '%s' , & ! Units \n",p->units ) ; + fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; + /* global dimensions */ + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ; + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ; + fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ; + fprintf(fp," ierr )\n") ; + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"END IF\n" ) ; + if ( ok_to_collect_distribute ) + fprintf(fp,"ENDIF\n") ; + } + } + } + } + +/* //////// NOT BOUNDARY ///////////////////// */ + else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY)) + { + +/* Aug 2004 + +Namelist variables + +The i r and h settings will be reenabled but it will work a little +differently than i/o of regular state variables: + +1) rather than being read or written as records to the dataset, they +will be gotten or put as time invariant meta data; in other words, they +will only be written once when the dataset is created as the other +metadata is now. This has the benefit of reducing the amount of I/O +traffic on each write (I can't remember, but that may be why the +reading and writing of rconfig data was turned off in the first +place). + +2) All the rconfig variables will be gotten/put as metadata to input, +restart, history, and boundary datasets, regardless of what the 'i', +'r', and 'h' settings are. Instead those settings will control the +behavior with respect to the input-from-namelist vs input-from-dataset +precedence issue that Bill raised. + +In other words, if an rconfig entry has an 'i', 'r', or 'h' in the +Registry, the dataset value takes precedence over the namelist value. +Otherwise, say it is missing the 'i', the reconfig variable's value +still appears as metadata in the dataset but the value of the variable +in the program does not change as a result of inputting the dataset. + +*/ + + if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) ) + { + char c ; + char dname[NAMELEN] ; + + strcpy( dname, p->dname ) ; + make_upper_case( dname ) ; + if ( !strcmp( p->type->name , "integer" ) ) { c = 'i' ; } + else if ( !strcmp( p->type->name , "real" ) ) { c = 'r' ; } + else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; } + else if ( !strcmp( p->type->name , "logical" ) ) { c = 'l' ; } + else { + fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ; + } + if ( sw_io == GEN_OUTPUT ) { + if ( io_mask & p->io_mask ) { + fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; + fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; + } + } else { + if ( io_mask & p->io_mask ) { + fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; + fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ; + fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ; + fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; + } + } + } +/* end Aug 2004 */ +#if 0 + else if ( ! (io_mask & METADATA) ) /* state vars */ +#else + else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) ) /* state vars */ +#endif + { + if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ; + else passes = 1 ; + + for ( pass = 0 ; pass < passes ; pass++ ) /* for multi timelevel vars */ + { + if (!strncmp( p->use, "dyn_", 4)) + sprintf(core,"%s_",p->use+4) ; + else + strcpy(core,"") ; + + /* for multi time level variables gen read for both levels + for restart, only _2 for others */ + if ( p->ntl > 1 ) { + if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ; + else sprintf(tag,"_%d",p->ntl) ; + } + else sprintf(tag,"") ; + + /* construct variable name */ + if ( p->scalar_array_member ) + { + strcpy(dexes,"") ; + for (ii = 0; ii < p->ndims; ii++ ) + { + switch(p->dims[ii]->coord_axis) + { + case(COORD_X): strcat(dexes,"ims,") ; break ; + case(COORD_Y): strcat(dexes,"jms,") ; break ; + case(COORD_Z): strcat(dexes,"kms,") ; break ; + default : break ; + } + } + sprintf(vname,"%s%s%s(%sP_%s)",core,p->use,tag,dexes,p->name) ; + sprintf(vname_2,"%s%s%s(%sP_%s)",core,p->use,"_2",":,:,:,",p->name) ; + sprintf(vname_1,"%s%s%s(%sP_%s)",core,p->use,"_1",":,:,:,",p->name) ; + sprintf(vname_x,"%s%s%s(%sP_%s)",core,p->use,tag,":,:,:,",p->name) ; + } + else + { + sprintf(vname,"%s%s%s",core,p->name,tag) ; + sprintf(vname_x,"%s%s%s",core,p->name,tag) ; + sprintf(vname_1,"%s%s%s",core,p->name,"_1") ; + sprintf(vname_2,"%s%s%s",core,p->name,"_2") ; + } + + + /* construct data name -- maybe same as vname if dname not spec'd */ + if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; } + else { strcpy(dname_tmp,p->dname) ; } + make_upper_case(dname_tmp) ; + +/* + July 2004 + + New code to generate error if input or output for two state variables would be generated with the same dataname + + example okay: + dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB + dyn_em soiltb "SOILTB" -> dyn_em_tg,SOILTB + example wrong: + dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB + misc soiltb "SOILTB" -> gen_soiltb,SOILTB + example wrong: + misc tg "SOILTB" -> gen_tg,SOILTB + misc soiltb "SOILTB" -> gen_soiltb,SOILTB + +*/ +if ( pass == 0 ) +{ + char dname_symbol[128] ; + sym_nodeptr sym_node ; + + sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ; + /* check and see if it is in the symbol table already */ + + if ((sym_node = sym_get( dname_symbol )) == NULL ) { + /* add it */ + sym_node = sym_add ( dname_symbol ) ; + strcpy( sym_node->internal_name , p->name ) ; + strcpy( sym_node->core_name , core ) ; + } else { + /* it's there already, check and make sure we don't have an error condition */ + if ( (strlen(core) > 0 && strlen( sym_node->core_name ) > 0 && !strcmp( core, sym_node->core_name )) + || strlen(core) == 0 + || strlen( sym_node->core_name ) == 0 ) + { + char this_core[64] , sym_core[64] ; + strcpy(this_core,"(generic)") ; + if ( strlen(core) > 0 ) sprintf(this_core,"(%s)",core) ; + strcpy(sym_core,"(generic)") ; + if ( strlen(sym_node->core_name) > 0 ) sprintf(this_core,"(%s)",sym_node->core_name) ; + fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s %s and %s %s\n", + dname_tmp,p->name,this_core,sym_node->internal_name,sym_core ) ; + } + } +} +/* end July 2004 */ + + if ( io_mask & RESTART && p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ; + else strcpy(dname,dname_tmp) ; + + set_mem_order( p, memord , NAMELEN) ; + +/* kludge for WRF 3DVAR I/O with MM5 analysis kernel */ + if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ; + if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ; + + if ( strlen(dname) < 1 ) { + fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ; + } + if ( p->io_mask & io_mask && sw_io == GEN_INPUT ) + { + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; + if ( p->scalar_array_member ) + fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; + if ( ok_to_collect_distribute ) + fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; + + strcpy(indices,"") ; + sprintf(post,")") ; + if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ + { + sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ; + } + + fprintf(fp,"CALL wrf_ext_read_field ( &\n") ; + fprintf(fp," fid , & ! DataHandle \n" ) ; + fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( p->ndims >= 2 && ok_to_collect_distribute ) + fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; + else + fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices) ; + + if (!strncmp(p->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; + } + + fprintf(fp," grid%%communicator , & ! Comm\n") ; + fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid%%domdesc , & ! Comm\n") ; + fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; + fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; + fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; + fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; + /* global dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } + fprintf(fp," & \n") ; + +/* the first two cases here have to do with if we're running on multiple distributed + memory processors and the i/o api layer can't handle decomposed data. So code is + generated to read the data on processor zero into a globally sized buffer. In this + case, then the domain, memory, and patch dimensions for the globally sized buffer + are all just the domain dimensions. Two D arrays are handled separately + from three-d arrays because in threeD arrays the middle index is K. In the last + case, where the code is either calling a version of the API that supports parallelism + or we aren't running in DM-parallel, the field itself and not a global buffer are + passed, so we pass the domain, memory, and patch indices directly to the read routine. */ + + if ( p->ndims == 3 && ok_to_collect_distribute ) + { + /* mem dimensions are actually domain dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } + fprintf(fp," & \n") ; + /* patch dimensions are actually domain dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim [i][0], ddim [i][1]) ; } + fprintf(fp," & \n") ; + } + else if ( p->ndims == 2 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) + { + /* mem dimensions are actually domain dimensions */ + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1] ) ; + /* patch dimensions are actually domain dimensions */ + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim [xi][0],ddim [xi][1], + ddim [yi][0],ddim [yi][1] ) ; + } + } + else + { + /* mem dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } + fprintf(fp," & \n") ; + /* patch dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } + fprintf(fp," & \n") ; + } + fprintf(fp," ierr )\n") ; + + if ( ok_to_collect_distribute ) + fprintf(fp,"END IF\n" ) ; + +/* In case we have read into a global buffer, generate code to distribute the data just read in */ + if ( p->ndims == 3 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) + { + fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; + fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; + fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1], + ddim_no[zi][0],ddim_no[zi][1]) ; + fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], + mdim_no[yi][0],mdim_no[yi][1], + mdim_no[zi][0],mdim_no[zi][1]) ; + fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], + pdim_no[yi][0],pdim_no[yi][1], + pdim_no[zi][0],pdim_no[zi][1]) ; + } + } + else if ( p->ndims == 2 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) + { + fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; + fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1] ) ; + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], + mdim_no[yi][0],mdim_no[yi][1] ) ; + fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], + pdim_no[yi][0],pdim_no[yi][1] ) ; + } + else + { + fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; + } + } + else if ( !strcmp(memord,"Z") && ok_to_collect_distribute ) + { + fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ; + } + else if ( !strcmp(memord,"0") && ok_to_collect_distribute ) + { + fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ; + + } + else if ( ok_to_collect_distribute ) + { + fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ; + } + + if ( io_mask & INPUT && p->ntl > 1 ) { + /* copy time level two into time level one */ + if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ; + if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ; + } + + if ( p->scalar_array_member ) + { + fprintf(fp,"END IF\n" ) ; + } + + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"END IF\n" ) ; + } + else if ( sw_io == GEN_OUTPUT ) + { + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ; + if ( p->scalar_array_member ) + fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; + +/* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data */ + + if ( p->ndims == 3 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) + { + fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; + fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; +/* fprintf(fp, "ids , ide , jds , jde , kds , kde , &\n") ; */ + fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1], + ddim_no[zi][0],ddim_no[zi][1]) ; + fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], + mdim_no[yi][0],mdim_no[yi][1], + mdim_no[zi][0],mdim_no[zi][1]) ; + fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], + pdim_no[yi][0],pdim_no[yi][1], + pdim_no[zi][0],pdim_no[zi][1]) ; + } + } + else if ( p->ndims == 2 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) + { + fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; + fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; +/* fprintf(fp, "ids , ide , jds , jde , 1 , 1 , &\n") ; */ + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1] ) ; + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], + mdim_no[yi][0],mdim_no[yi][1] ) ; + fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], + pdim_no[yi][0],pdim_no[yi][1] ) ; + } + else + { + fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; + } + } + + for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; + for ( i = 0 ; i < 3 ; i++ ) + { + if (( dimnode = p->dims[i]) != NULL ) + { + switch ( dimnode->coord_axis ) + { + case (COORD_X) : + if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Y) : + if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Z) : + if ( p->stag_z ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + } + } + } + + if ( ok_to_collect_distribute ) + fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; + + strcpy(indices,"") ; + sprintf(post,")") ; + if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ + { + sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ; + } + + if ( !(p->scalar_array_member) ) { + fprintf(fp,"CALL wrf_ext_write_field ( &\n") ; + fprintf(fp," fid , & ! DataHandle \n" ) ; + fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; + fprintf(fp," '%s' , & ! Data Name \n", dname ) ; + if ( p->ndims >= 2 && ok_to_collect_distribute ) + fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; + else + fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices ) ; + if (!strncmp(p->type->name,"real",4)) { + fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; + } else { + fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; + } + fprintf(fp," grid%%communicator , & ! Comm\n") ; + fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid%%domdesc , & ! Comm\n") ; + fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; + fprintf(fp," dryrun , & ! flag\n" ) ; + fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; + fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; + fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; + fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; + fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; + fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ; + fprintf(fp," '%s' , & ! Units \n",p->units ) ; + fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; + /* global dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } + fprintf(fp," & \n") ; + +/* the first two cases here have to do with if we're running on multiple distributed + memory processors and the i/o api layer can't handle decomposed data. So code is + generated to read the data on processor zero into a globally sized buffer. In this + case, then the domain, memory, and patch dimensions for the globally sized buffer + are all just the domain domain dimensions. Two D arrays are handled separately + from three-d arrays because in threeD arrays the middle index is K. In the last + case, where the code is either calling a version of the API that supports parallelism + or we aren't running in DM-parallel, the field itself and not a global buffer are + passed, so we pass the domain, memory, and patch indices directly to the read routine. */ + + if ( p->ndims == 3 && ok_to_collect_distribute ) + { + /* mem dimensions are actually domain dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } + fprintf(fp," & \n") ; + /* patch dimensions are actually domain dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } + fprintf(fp," & \n") ; + } + else if ( p->ndims == 2 && ok_to_collect_distribute ) + { + if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) + { + /* mem dimensions are actually domain dimensions */ + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], + ddim_no[yi][0],ddim_no[yi][1] ) ; + /* patch dimensions are actually domain dimensions */ + fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1], + ddim[yi][0],ddim[yi][1] ) ; + } + } + else + { + /* mem dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } + fprintf(fp," & \n") ; + /* patch dimensions */ + for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } + fprintf(fp," & \n") ; + } + fprintf(fp," ierr )\n") ; + + if ( ok_to_collect_distribute ) + fprintf(fp,"END IF\n" ) ; + +/* + if ( p->scalar_array_member ) + fprintf(fp,"END IF\n" ) ; +*/ + if ( !strncmp( p->use, "dyn_", 4 ) ) + fprintf(fp,"END IF\n" ) ; + + } + } + } + } + } + } + if ( p->type->type_type == DERIVED ) + { + sprintf(x,"%s%s%%",structname,p->name ) ; + gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ; + } + + } + } + return(0) ; +} + diff --git a/wrfv2_fire/tools/index.page b/wrfv2_fire/tools/index.page new file mode 100755 index 00000000..3f5b98d4 --- /dev/null +++ b/wrfv2_fire/tools/index.page @@ -0,0 +1,16 @@ + + +Weather Research and Forecast Model + + + + + +Frames not supported. Click +<A HREF="callgraph.html">here</A>. + + + + + + diff --git a/wrfv2_fire/tools/link_codebase_to_wrfbrowser b/wrfv2_fire/tools/link_codebase_to_wrfbrowser new file mode 100755 index 00000000..ff1b0076 --- /dev/null +++ b/wrfv2_fire/tools/link_codebase_to_wrfbrowser @@ -0,0 +1,15 @@ +#!/bin/csh + +#sed 's/\(\)\([a-zA-Z0-9_][a-zA-Z0-9_]*\)\(<\/font>\)/\1 \2 <\/a> \3 /' frame/module_configure.F.html + +# very hard coded -- expects wrf browser to live at: + + cd /users/michalak/wrfbrowser/html_code + +foreach f ( */*.html ) + + sed 's/\(\)\([a-zA-Z0-9_][a-zA-Z0-9_]*\)\(<\/font>\)/\1 \2 (docs)<\/a> \3 /' $f > foo + + /bin/mv foo $f + +end diff --git a/wrfv2_fire/tools/misc.c b/wrfv2_fire/tools/misc.c new file mode 100644 index 00000000..b547f443 --- /dev/null +++ b/wrfv2_fire/tools/misc.c @@ -0,0 +1,582 @@ +#include +#include +#include +#include + +#include "protos.h" +#include "registry.h" +#include "data.h" + +char * +dimension_with_colons( char * pre , char * tmp , node_t * p , char * post ) +{ + int i ; + if ( p == NULL ) return("") ; + if ( p->ndims <= 0 && ! p->boundary_array ) return("") ; + strcpy(tmp,"") ; + if ( pre != NULL ) strcat(tmp,pre) ; + if ( p->boundary_array ) + { + if ( ! sw_new_bdys ) { strcat( tmp,":,") ; } + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { + strcat( tmp, ":,:,:,:" ) ; /* boundary array for 4d tracer array */ + } else { + strcat( tmp, ":,:,:" ) ; /* most always have four dimensions */ + } + } + else + { + for ( i = 0 ; i < p->ndims ; i++ ) strcat(tmp,":,") ; + if ( p->node_kind & FOURD ) strcat(tmp,":,") ; /* add an extra for 4d arrays */ + tmp[strlen(tmp)-1] = '\0' ; + } + if ( post != NULL ) strcat(tmp,post) ; + return(tmp) ; +} + +char * +dimension_with_ones( char * pre , char * tmp , node_t * p , char * post ) +{ + int i ; + char r[NAMELEN],s[NAMELEN],four_d[NAMELEN] ; + char *pp ; + if ( p == NULL ) return("") ; + if ( p->ndims <= 0 && ! p->boundary_array ) return("") ; + strcpy(tmp,"") ; + if ( pre != NULL ) strcat(tmp,pre) ; + + if ( p->boundary_array ) + { + if ( ! sw_new_bdys ) { strcpy( tmp,"(1,") ; } + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { /* if a boundary array for a 4d tracer */ + strcpy(s, p->name ) ; /* copy the name and then remove everything after last underscore */ + if ((pp=rindex( s, '_' )) != NULL ) *pp = '\0' ; + sprintf( four_d, "num_%s,", s ) ; + } else { + strcpy( four_d, "" ) ; + } + + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { + sprintf( r, "1,1,1,%s", four_d ) ; /* boundary array for 4d tracer array */ + strcat( tmp, r ) ; + } else { + strcat( tmp, "1,1,1," ) ; + } + tmp[strlen(tmp)-1] = '\0' ; + } + else + { + for ( i = 0 ; i < p->ndims ; i++ ) strcat(tmp,"1,") ; + if ( p->node_kind & FOURD ) strcat(tmp,"1,") ; /* add an extra for 4d arrays */ + tmp[strlen(tmp)-1] = '\0' ; + } + if ( post != NULL ) strcat(tmp,post) ; + return(tmp) ; +} + +char * +dimension_with_ranges( char * refarg , char * pre , + int bdy , /* as defined in data.h */ + char * tmp , node_t * p , char * post , + char * nlstructname ) /* added 20020130; + provides name (with %) of structure in + which a namelist supplied dimension + should be dereference from, or "" */ +{ + int i ; + char tx[NAMELEN] ; + char r[NAMELEN],s[NAMELEN],four_d[NAMELEN] ; + int bdex, xdex, ydex, zdex ; + node_t *xdim, *ydim, *zdim ; + char *pp ; + if ( p == NULL ) return("") ; + if ( p->ndims <= 0 && !p->boundary_array ) return("") ; + strcpy(tmp,"") ; + if ( pre != NULL ) strcat(tmp,pre) ; + strcpy(r,"") ; + if ( refarg != NULL ) strcat(r,refarg) ; + + if ( p->boundary_array ) + { + if ( p->ndims > 0 ) + { + xdim = get_dimnode_for_coord( p , COORD_X ) ; + ydim = get_dimnode_for_coord( p , COORD_Y ) ; + zdim = get_dimnode_for_coord( p , COORD_Z ) ; + if ( ydim == NULL ) + { fprintf(stderr,"dimension_with_ranges: y dimension not specified for %s\n",p->name) ; return("") ; } + if ( xdim == NULL ) + { fprintf(stderr,"dimension_with_ranges: x dimension not specified for %s\n",p->name) ; return("") ; } + + xdex = xdim->dim_order ; + ydex = ydim->dim_order ; + + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { /* if a boundary array for a 4d tracer */ + strcpy(s, p->name ) ; /* copy the name and then remove everything after last underscore */ + if ((pp=rindex( s, '_' )) != NULL ) *pp = '\0' ; + sprintf( four_d, "num_%s,", s ) ; + } else { + strcpy( four_d, "" ) ; + } + if ( sw_new_bdys ) { + if ( bdy == P_XSB || bdy == P_XEB ) { bdex = ydex ; } + else if ( bdy == P_YSB || bdy == P_YEB ) { bdex = xdex ; } + else { fprintf(stderr,"REGISTRY WARNING: internal error %s %d, bdy=%d,%s,%d \n",__FILE__,__LINE__,bdy,p->name,p->boundary) ; } + if ( zdim != NULL ) { + zdex = zdim->dim_order ; + sprintf(tx,"%ssm3%d:%sem3%d,%ssm3%d:%sem3%d,%sspec_bdy_width,%s", r,bdex,r,bdex,r,zdex,r,zdex,r,four_d ) ; + } else { + sprintf(tx,"%ssm3%d:%sem3%d,1,%sspec_bdy_width,%s", r,bdex,r,bdex,r,four_d ) ; + } + } else { + if ( zdim != NULL ) { + zdex = zdim->dim_order ; + sprintf(tx,"max(%sed3%d,%sed3%d),%ssd3%d:%sed3%d,%sspec_bdy_width,4,%s", r,xdex,r,ydex,r,zdex,r,zdex,r,four_d ) ; + } else { + sprintf(tx,"max(%sed3%d,%sed3%d),1,%sspec_bdy_width,4,%s", r,xdex,r,ydex,r,four_d ) ; + } + } + } + else + { + sprintf(tx,"%sspec_bdy_width,",r ) ; + } + strcat(tmp,tx) ; + } + else + { + for ( i = 0 ; i < p->ndims ; i++ ) + { + range_of_dimension( r, tx , i , p , nlstructname ) ; + strcat(tmp,tx) ; + strcat(tmp,",") ; + } + } + tmp[strlen(tmp)-1] = '\0' ; + if ( post != NULL ) strcat(tmp,post) ; + + return(tmp) ; +} + +int +range_of_dimension ( char * r , char * tx , int i , node_t * p , char * nlstructname ) +{ + char s[NAMELEN], e[NAMELEN] ; + + get_elem( r , nlstructname , s , i , p , 0 ) ; + get_elem( r , nlstructname , e , i , p , 1 ) ; + sprintf(tx,"%s:%s", s , e ) ; + +} + +char * +index_with_firstelem( char * pre , char * dref , int bdy , /* as defined in data.h */ + char * tmp , node_t * p , char * post ) +{ + int i ; + char tx[NAMELEN] ; + char tmp2[NAMELEN] ; + int bdex, xdex, ydex, zdex ; + node_t *xdim, *ydim, *zdim ; + char r[NAMELEN] ; + + if ( p == NULL ) return("") ; + if ( p->ndims <= 0 ) return("") ; + strcpy(tmp,"") ; + if ( pre != NULL ) strcat(tmp,pre) ; + + strcpy(r,"") ; + if ( dref != NULL ) strcat(r,dref) ; + + if ( p->boundary_array ) + { + if ( sw_new_bdys ) { + + xdim = get_dimnode_for_coord( p , COORD_X ) ; + ydim = get_dimnode_for_coord( p , COORD_Y ) ; + zdim = get_dimnode_for_coord( p , COORD_Z ) ; + if ( ydim == NULL ) + { fprintf(stderr,"dimension_with_ranges: y dimension not specified for %s\n",p->name) ; return("") ; } + if ( xdim == NULL ) + { fprintf(stderr,"dimension_with_ranges: x dimension not specified for %s\n",p->name) ; return("") ; } + + xdex = xdim->dim_order ; + ydex = ydim->dim_order ; + + if ( bdy == P_XSB || bdy == P_XEB ) { bdex = ydex ; } + else if ( bdy == P_YSB || bdy == P_YEB ) { bdex = xdex ; } + else { fprintf(stderr,"REGISTRY WARNING: internal error %s %d \n",__FILE__,__LINE__) ; } + if ( p->ndims > 0 ) + { + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { + sprintf(tmp,"%ssm3%d,%ssm3%d,1,1", r,bdex,r,zdex ) ; + } else { + sprintf(tmp,"%ssm3%d,%ssm3%d,1", r,bdex,r,zdex ) ; + } + } + else + { + sprintf(tx,"1," ) ; + strcat(tmp,tx) ; + } + + } else { + if ( p->ndims > 0 ) + { + if ( !strcmp( p->use , "_4d_bdy_array_" ) ) { + strcat(tmp,"1,1,1,1,1,") ; + } else { + strcat(tmp,"1,1,1,1,") ; + } + } + else + { + sprintf(tx,"1," ) ; + strcat(tmp,tx) ; + } + } + } + else + { + for ( i = 0 ; i < p->ndims ; i++ ) + { + get_elem( dref, "", tx, i, p , 0 ) ; + strcat( tmp, tx ) ; + strcat(tmp,",") ; + } + } + tmp[strlen(tmp)-1] = '\0' ; /* remove trailing comma */ + if ( post != NULL ) strcat(tmp,post) ; + return(tmp) ; +} + +get_elem ( char * structname , char * nlstructname , char * tx , int i , node_t * p , int first_last ) +{ + char dref[NAMELEN], nlstruct[NAMELEN] ; + char d, d1 ; + + if ( structname == NULL ) { strcpy( dref, "" ) ;} + else { strcpy( dref, structname ) ; } + if ( nlstructname == NULL ) { strcpy( nlstruct, "" ) ;} + else { strcpy( nlstruct, nlstructname ) ; } + if ( p->dims[i] != NULL ) + { + switch ( p->dims[i]->len_defined_how ) + { + case (DOMAIN_STANDARD) : + { + char *ornt ; + if ( p->proc_orient == ALL_X_ON_PROC ) ornt = "x" ; + else if ( p->proc_orient == ALL_Y_ON_PROC ) ornt = "y" ; + else ornt = "" ; + + switch( p->dims[i]->coord_axis ) + { + case(COORD_X) : d = 'i' ; d1 = 'x' ; break ; + case(COORD_Y) : d = 'j' ; d1 = 'y' ; break ; + case(COORD_Z) : d = 'k' ; d1 = 'z' ; break ; + default : break ; + } + + if ( p->dims[i]->subgrid ) + { + if ( first_last == 0 ) { /*first*/ + sprintf(tx,"(%ssm3%d%s-1)*%ssr_%c+1",dref,p->dims[i]->dim_order,ornt,dref,d1) ; + }else{ /*last*/ + sprintf(tx,"%sem3%d%s*%ssr_%c" ,dref,p->dims[i]->dim_order,ornt,dref,d1) ; + } + } + else + { + sprintf(tx,"%s%cm3%d%s",dref,first_last==0?'s':'e',p->dims[i]->dim_order,ornt) ; + } + } + break ; + case (NAMELIST) : + if ( first_last == 0 ) { if ( !strcmp( p->dims[i]->assoc_nl_var_s , "1" ) ) { + sprintf(tx,"%s",p->dims[i]->assoc_nl_var_s) ; + } else { + sprintf(tx,"%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_s) ; + } + } + else { sprintf(tx,"%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_e) ; } + break ; + case (CONSTANT) : + if ( first_last == 0 ) { sprintf(tx,"%d",p->dims[i]->coord_start) ; } + else { sprintf(tx,"%d",p->dims[i]->coord_end) ; } + break ; + default : break ; + } + } + else + { + fprintf(stderr,"WARNING: %s %d: something wrong with internal representation for dim %d\n",__FILE__,__LINE__,i) ; + } +} + +char * +declare_array_as_pointer( char * tmp , node_t * p ) +{ + strcpy( tmp , "" ) ; + if ( p != NULL ) + if ( p->ndims > 0 || p->boundary_array ) strcpy ( tmp, ",POINTER" ) ; + return(tmp); +} + +char * +field_type( char * tmp , node_t * p ) +{ + if ( p == NULL ) { + strcpy( tmp , "" ) ; + } else if ( p->type == NULL ) { + strcpy( tmp , "" ) ; + } else if ( p->type->type_type == SIMPLE ) { + strcpy( tmp , p->type->name ) ; + } else { + sprintf( tmp , "TYPE(%s)", p->type->name ) ; + } + return( tmp ) ; +} + +char * +field_name( char * tmp , node_t * p , int tag ) +{ + if ( p == NULL ) return("") ; + if ( tag < 1 ) + { + strcpy(tmp,p->name) ; + if ( p->scalar_array_member ) strcpy(tmp,p->use) ; + } + else + { + sprintf(tmp,"%s_%d",p->name,tag) ; + if ( p->scalar_array_member ) sprintf(tmp,"%s_%d",p->use,tag) ; + } + return( tmp ) ; +} + +char * +field_name_bdy( char * tmp , node_t * p , int tag, int bdy ) +{ + if ( p == NULL ) return("") ; + if ( tag < 1 ) + { + strcpy(tmp,p->name) ; + if ( p->scalar_array_member ) strcpy(tmp,p->use) ; + if ( p->boundary_array ) strcat(tmp,bdy_indicator(bdy)) ; + } + else + { + sprintf(tmp,"%s_%d",p->name,tag) ; + if ( p->scalar_array_member ) sprintf(tmp,"%s_%d",p->use,tag) ; + if ( p->boundary_array ) strcat(tmp,bdy_indicator(bdy)) ; + } + return( tmp ) ; +} + +static char *emp_str = "" ; +static char *xs_str = "xs" ; +static char *xe_str = "xe" ; +static char *ys_str = "ys" ; +static char *ye_str = "ye" ; + +char * +bdy_indicator( int bdy ) +{ + char * res ; + res = emp_str ; + if ( bdy == P_XSB ) { res = xs_str ; } + else if ( bdy == P_XEB ) { res = xe_str ; } + else if ( bdy == P_YSB ) { res = ys_str ; } + else if ( bdy == P_YEB ) { res = ye_str ; } + return(res) ; +} + +int +print_warning( FILE * fp , char * fname ) +{ +fprintf(fp,"!STARTOFREGISTRYGENERATEDINCLUDE '%s'\n", fname) ; +fprintf(fp,"!\n") ; +fprintf(fp,"! WARNING This file is generated automatically by use_registry\n") ; +fprintf(fp,"! using the data base in the file named Registry.\n") ; +fprintf(fp,"! Do not edit. Your changes to this file will be lost.\n") ; +fprintf(fp,"!\n") ; +return(0) ; +} + +close_the_file( FILE * fp ) +{ +fprintf(fp,"!ENDOFREGISTRYGENERATEDINCLUDE\n") ; +fclose(fp) ; +} + +int +make_entries_uniq ( char * fname ) +{ + char tempfile[NAMELEN] ; + char commline[4096] ; + sprintf(tempfile,"regtmp1%d",getpid()) ; + sprintf(commline,"%s < %s > %s ; %s %s %s ", + UNIQSORT,fname,tempfile, + MVCOMM,tempfile,fname ) ; + return(system(commline)) ; +} + +int +add_warning ( char * fname ) +{ + FILE * fp ; + char tempfile[NAMELEN] ; + char tempfile1[NAMELEN] ; + char commline[4096] ; + sprintf(tempfile,"regtmp1%d",getpid()) ; + sprintf(tempfile1,"regtmp2%d",getpid()) ; + if (( fp = fopen( tempfile, "w" )) == NULL ) return(1) ; + print_warning(fp,tempfile) ; + close_the_file(fp) ; + sprintf(commline,"%s %s %s > %s ; %s %s %s ; %s %s ", + CATCOMM,tempfile,fname,tempfile1, + MVCOMM,tempfile1,fname, + RMCOMM,tempfile) ; + return(system(commline)) ; +} + +static int NumCores ; +static char dyncores[MAX_DYNCORES][NAMELEN] ; + +int +init_core_table() +{ + NumCores = 0 ; + return(0) ; +} + +int +get_num_cores() +{ + return( NumCores ) ; +} + +char * +get_corename_i(int i) +{ + if ( i >= 0 && i < NumCores ) return( dyncores[i] ) ; + return(NULL) ; +} + +int +add_core_name ( char * name ) +{ + if ( name == NULL ) return(1) ; + if (get_core_name ( name ) == NULL ) + { + if ( NumCores >= MAX_DYNCORES ) return(1) ; + strcpy( dyncores[NumCores++] , name ) ; + } + return(0) ; +} + +char * +get_core_name ( char * name ) +{ + int i ; + if ( name == NULL ) return(NULL) ; + for ( i = 0 ; i < NumCores ; i++ ) + { + if ( !strcmp(name,dyncores[i]) ) return( dyncores[i] ) ; + } + return(NULL) ; +} + +/* DESTRUCTIVE */ +char * +make_upper_case ( char * str ) +{ + char * p ; + if ( str == NULL ) return (NULL) ; + for ( p = str ; *p ; p++ ) *p = toupper(*p) ; + return(str) ; +} + +/* DESTRUCTIVE */ +char * +make_lower_case ( char * str ) +{ + char * p ; + if ( str == NULL ) return (NULL) ; + for ( p = str ; *p ; p++ ) *p = tolower(*p) ; + return(str) ; +} + +/* Routines for keeping typedef history -ajb */ + +static int NumTypeDefs ; +static char typedefs[MAX_TYPEDEFS][NAMELEN] ; + +int +init_typedef_history() +{ + NumTypeDefs = 0 ; + return(0) ; +} + +int +get_num_typedefs() +{ + return( NumTypeDefs ) ; +} + +char * +get_typename_i(int i) +{ + if ( i >= 0 && i < NumTypeDefs ) return( typedefs[i] ) ; + return(NULL) ; +} + +int +add_typedef_name ( char * name ) +{ + if ( name == NULL ) return(1) ; + if ( get_typedef_name ( name ) == NULL ) + { + if ( NumTypeDefs >= MAX_TYPEDEFS ) return(1) ; + strcpy( typedefs[NumTypeDefs++] , name ) ; + } + return(0) ; +} + +char * +get_typedef_name ( char * name ) +{ + int i ; + if ( name == NULL ) return(NULL) ; + for ( i = 0 ; i < NumTypeDefs ; i++ ) + { + if ( !strcmp(name,typedefs[i]) ) return( typedefs[i] ) ; + } + return(NULL) ; +} + +int +associated_with_4d_array( node_t * p ) +{ + int res = 0 ; + node_t * possble ; + char * last_underscore ; + char name_copy[128] ; + if ( p != NULL ) + { + /* check this variable and see if it is a boundary variable that is associated with a 4d array */ + strcpy( name_copy, p->name ) ; + if (( last_underscore = rindex( name_copy , '_' )) != NULL ) { + if ( !strcmp( last_underscore , "_b" ) || !strcmp( last_underscore , "_bt" ) ) { + *last_underscore = '\0' ; + if (( possble = get_entry( name_copy , Domain.fields )) != NULL ) { + res = possble->node_kind & FOURD ; + } + } + } + } + return(res) ; +} + diff --git a/wrfv2_fire/tools/mpi2_test.c b/wrfv2_fire/tools/mpi2_test.c new file mode 100644 index 00000000..978f77a0 --- /dev/null +++ b/wrfv2_fire/tools/mpi2_test.c @@ -0,0 +1,13 @@ +#include +#include +main() +{ + int y ; + MPI_Comm x ; + y = 1 ; +#if 1 + x = MPI_Comm_f2c( y ) ; + y = MPI_Comm_c2f( x ) ; +#endif + fprintf(stderr,"y %d \n",y) ; +} diff --git a/wrfv2_fire/tools/my_strtok.c b/wrfv2_fire/tools/my_strtok.c new file mode 100644 index 00000000..134e9021 --- /dev/null +++ b/wrfv2_fire/tools/my_strtok.c @@ -0,0 +1,101 @@ +#include +#include "registry.h" +#include "protos.h" +#include "ctype.h" + + +/* work sort of like strtok but mind quote chars */ +static char * tokpos = NULL ; +char * +my_strtok( char * s1 ) +{ + char *p, *retval ; + int state ; + state = 0 ; + retval = NULL ; + if ( s1 == NULL && tokpos == NULL ) return( NULL ) ; + if ( s1 != NULL ) tokpos = s1 ; + for ( p = tokpos ; *p ; p++ ) + { + if ( state == 0 && (*p == ' ' || *p == '\t') ) continue ; + if ( state == 0 && !(*p == ' ' || *p == '\t') ) { state = 1 ; retval = p ; } ; + if ( state == 1 && (*p == '"') ) { state = 2 ; } + else if ( state == 2 && (*p == '"') ) { state = 1 ; } + if ( state == 1 && (*p == ' ' || *p == '\t') ) { *p = '\0' ; p++ ; break ; } + } + tokpos = p ; + return( retval ) ; +} + + +/* posix like rentrant strtok; not quote safe, and not quite strtok -- new version; skips multi delims */ +char * +strtok_rentr( char * s1 , char * s2, char ** tokpos ) +{ + char *p, *q, *retval ; + int match ; + retval = NULL ; + if ( s1 == NULL && s2 == NULL ) return( NULL ) ; + if ( s1 != NULL ) { *tokpos = s1 ; } + if ( **tokpos ) retval = *tokpos ; + for ( p = *tokpos ; *p ; p++ ) + { + for ( q = s2 ; *q ; q++ ) + { + if ( *p == *q ) { *p = '\0' ; p++ ; goto foundit ; } + } + } +foundit: +/* skip over multi-delims */ + for ( ; *p ; p++ ) + { + match = 0 ; + for ( q = s2 ; *q ; q++ ) + { + if ( *p == *q ) { *p = '\0' ; match++ ; } + } + if ( match == 0 ) { break ; } + } + *tokpos = p ; + return( retval ) ; +} + +#if 0 +/* posix like rentrant strtok; not quote safe, and not quite strtok -- won't skip over multiple delims */ +char * +strtok_rentr( char * s1 , char * s2, char ** tokpos ) +{ + char *p, *q, *retval ; + retval = NULL ; + if ( s1 == NULL && s2 == NULL ) return( NULL ) ; + if ( s1 != NULL ) { *tokpos = s1 ; } + if ( **tokpos ) retval = *tokpos ; + for ( p = *tokpos ; *p ; p++ ) + { + for ( q = s2 ; *q ; q++ ) + { + if ( *p == *q ) { *p = '\0' ; p++ ; goto foundit ; } + } + } +foundit: + *tokpos = p ; + return( retval ) ; +} +#endif + +make_lower( char * s1 ) +{ + char * p ; + int state ; + state = 0 ; + for ( p = s1 ; *p ; p++ ) + { + if ( state == 0 && *p == '"' ) state = 1 ; + else if ( state == 1 && *p == '"' ) state = 0 ; + if ( state == 0 ) + { + *p = tolower(*p) ; + } + } + return(0) ; +} diff --git a/wrfv2_fire/tools/nest_test.tar b/wrfv2_fire/tools/nest_test.tar new file mode 100644 index 00000000..b189ddfa Binary files /dev/null and b/wrfv2_fire/tools/nest_test.tar differ diff --git a/wrfv2_fire/tools/protos.h b/wrfv2_fire/tools/protos.h new file mode 100644 index 00000000..dab7d0ff --- /dev/null +++ b/wrfv2_fire/tools/protos.h @@ -0,0 +1,119 @@ +#ifndef PROTOS_H +#include "registry.h" +#include "data.h" + +int init_dim_table() ; +int make_lower( char * s1 ) ; +int reg_parse( FILE * infile ) ; +int set_dim_len ( char * dimspec , node_t * dim_entry ) ; +int set_dim_order ( char * dimorder , node_t * dim_entry ) ; +int set_dim_orient ( char * dimorient , node_t * dim_entry ) ; +int add_node_to_end ( node_t * node , node_t ** list ) ; +int add_node_to_end_4d ( node_t * node , node_t ** list ) ; +int init_type_table() ; +int set_state_type ( char * typename , node_t * node ) ; +int set_state_dims ( char * dims , node_t * node ) ; +int gen_state_struct ( char * fname ) ; + +#if 0 +int show_node( node_t * p ) ; +int show_node1( node_t * p, int indent ) ; +int show_nodelist( node_t * p ) ; +int show_nodelist1( node_t * p , int indent ) ; +#endif + +int gen_state_struct ( char * fname ) ; +int gen_decls ( FILE * fp , char * corename , node_t * node , int sw_ranges, int sw_point , int mask , int layer ) ; +int gen_state_subtypes ( char * fname ) ; +int gen_state_subtypes1 ( FILE * fp , node_t * node , int sw_ranges, int sw_point , int mask ) ; +int print_warning( FILE * fp , char * fname ) ; +int close_the_file( FILE * fp ) ; +int make_entries_uniq ( char * fname ) ; +int add_warning ( char * fname ) ; + +node_t * get_type_entry ( char * typename ) ; +node_t * get_rconfig_entry( char * name ) ; +node_t * get_entry ( char * name , node_t * node ) ; +node_t * get_entry_r ( char * name , char * use , node_t * node ) ; +node_t * get_dim_entry( char c ) ; +node_t * new_node ( int kind ) ; + +node_t * get_4d_entry ( char * name ) ; +node_t * get_dimnode_for_coord ( node_t * node , int coord_axis ) ; +int get_index_for_coord ( node_t * node , int coord_axis ) ; + +char * my_strtok( char * s1 ) ; +char * strtok_rentr( char * s1 , char * s2, char ** tokpos ) ; + +char * bdy_indicator( int bdy ) ; + +char * field_name( char * tmp, node_t * p , int tag ) ; +char * field_name_bdy( char * tmp, node_t * p , int tag, int bdy ) ; +char * dimension_with_colons( char * pre, char * tmp, node_t * p, char * post) ; +char * dimension_with_ones( char * pre, char * tmp, node_t * p, char * post) ; +char * dimension_with_ranges( char * ref , char * pre, int bdy , char * tmp, node_t * p, char * post, char * nlstructname ) ; +char * index_with_firstelem( char * pre , char * dref , int bdy , char * tmp , node_t * p , char * post ) ; + +char * declare_array_as_pointer( char * tmp, node_t * p ) ; +char * field_type( char * tmp , node_t * p ) ; + +int init_core_table() ; +int add_core_name ( char * name ) ; +int get_num_cores() ; +char * get_core_name ( char * name ) ; +char * get_corename_i(int i) ; + +/* For typedef history -ajb */ +int init_typedef_history() ; +int add_typedef_name ( char * name ) ; +int get_num_typedefs() ; +char * get_typedef_name ( char * name ) ; +char * get_typename_i(int i) ; + +int gen_alloc ( char * dirname ) ; +int gen_alloc1 ( char * dirname , char * corename ) ; +int gen_alloc2 ( FILE * fp , char * structname , char * corename , node_t * node ) ; + +int gen_module_state_description ( char * dirname ) ; +int gen_module_state_description1 ( FILE * fp , node_t * node ) ; + +int gen_scalar_indices ( char * dirname ) ; +int gen_scalar_indices1 ( FILE * fp ) ; + +int gen_actual_args ( char * dirname ) ; +int gen_dummy_args ( char * dirname ) ; +int gen_dummy_decls ( char * dn ) ; +int gen_args ( char * dirname , char * corename , int sw ) ; +int gen_args1 ( FILE * fp , char * outstr, char * structname , char * corename , node_t * node , int *linelen , int sw , int deep ) ; + +int gen_scalar_derefs ( char * dirname ) ; +int scalar_derefs ( char * dirname , char * corename ) ; +int scalar_derefs1 ( FILE * fp , char * corename , node_t * node, int direction ) ; + +int set_mark ( int val , node_t * lst ) ; +int set_mark_4d ( int val , node_t * lst ) ; + +int gen_i1_decls ( char * dn ) ; +int gen_get_nl_config ( char * dirname ) ; + +int gen_config_assigns ( char * dirname ) ; +int gen_config_reads ( char * dirname ) ; + +char * set_mem_order( node_t * node , char * str , int n ) ; + +int gen_wrf_io ( char * dirname ) ; +int set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend, int sw_allow_stagger ) ; +int gen_wrf_io2 ( FILE * fp , char * fname , char * structname , char * fourdname , node_t * node , int io_mask , int sw_io ) ; + +int gen_namelist_defines ( char * dirname , int sw_dimension ) ; +int gen_namelist_defaults ( char * dirname ) ; + +int gen_model_data_ord ( char * dirname ) ; + +int get_elem ( char * structname , char * nlstructname , char * tx , int i , node_t * p , int first_last ) ; + +int associated_with_4d_array( node_t * p ) ; + +#define PROTOS_H +#endif + diff --git a/wrfv2_fire/tools/reg_parse.c b/wrfv2_fire/tools/reg_parse.c new file mode 100644 index 00000000..32c46948 --- /dev/null +++ b/wrfv2_fire/tools/reg_parse.c @@ -0,0 +1,1013 @@ +#include +#include +#include +#include + +#include "registry.h" +#include "protos.h" +#include "data.h" +#include "sym.h" + +/* read in the Registry file and build the internal representation of the registry */ + +#define MAXTOKENS 1000 + +/* fields for state entries (note, these get converted to field entries in the + reg_parse routine; therefore, only TABLE needs to be looked at */ +#define TABLE 0 + +/* fields for field entries (TABLE="typedef" and, with some munging, TABLE="state") */ +#define FIELD_OF 1 +#define FIELD_TYPE 2 +#define FIELD_SYM 3 +#define FIELD_DIMS 4 +#define FIELD_USE 5 +#define FIELD_NTL 6 +#define FIELD_STAG 7 +#define FIELD_IO 8 +#define FIELD_DNAME 9 +#define FIELD_DESCRIP 10 +#define FIELD_UNITS 11 + +#define F_OF 0 +#define F_TYPE 1 +#define F_SYM 2 +#define F_DIMS 3 +#define F_USE 4 +#define F_NTL 5 +#define F_STAG 6 +#define F_IO 7 +#define F_DNAME 8 +#define F_DESCRIP 9 +#define F_UNITS 10 + +/* fields for rconfig entries (RCNF) */ +#define RCNF_TYPE_PRE 1 +#define RCNF_SYM_PRE 2 +#define RCNF_HOWSET_PRE 3 +#define RCNF_NENTRIES_PRE 4 +#define RCNF_DEFAULT_PRE 5 +#define RCNF_IO_PRE 6 +#define RCNF_DNAME_PRE 7 +#define RCNF_DESCRIP_PRE 8 +#define RCNF_UNITS_PRE 9 + +#define RCNF_TYPE 2 +#define RCNF_SYM 3 +#define RCNF_USE FIELD_USE +#define RCNF_IO FIELD_IO +#define RCNF_DNAME FIELD_DNAME +#define RCNF_DESCRIP FIELD_DESCRIP +#define RCNF_UNITS FIELD_UNITS +#define RCNF_HOWSET 20 +#define RCNF_NENTRIES 21 +#define RCNF_DEFAULT 22 + +/* fields for dimension entries (TABLE="dimspec") */ +#define DIM_NAME 1 +#define DIM_ORDER 2 +#define DIM_SPEC 3 +#define DIM_ORIENT 4 +#define DIM_DATA_NAME 5 + +#define PKG_SYM 1 +#define PKG_ASSOC 2 +#define PKG_STATEVARS 3 +#define PKG_4DSCALARS 4 + +#define COMM_ID 1 +#define COMM_USE 2 +#define COMM_DEFINE 3 + +static int ntracers = 0 ; +static char tracers[1000][100] ; + +int +pre_parse( char * dir, FILE * infile, FILE * outfile ) +{ + char inln[8192], parseline[8192], parseline_save[8192] ; + int found ; + char *p, *q ; + char *tokens[MAXTOKENS], *toktmp[MAXTOKENS], newdims[NAMELEN], newdims4d[NAMELEN],newname[NAMELEN] ; + int i, ii, len_of_tok ; + char x, xstr[NAMELEN] ; + int is4d, wantstend, wantsbdy ; + int ifdef_stack_ptr = 0 ; + int ifdef_stack[100] ; + int inquote, retval ; + + ifdef_stack[0] = 1 ; + retval = 0 ; + + parseline[0] = '\0' ; +/* main parse loop over registry lines */ + while ( fgets ( inln , 4096 , infile ) != NULL ) + { + +/*** preprocessing directives ****/ + /* look for an include statement */ + for ( p = inln ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; + if ( !strncmp( p , "include", 7 ) && ! ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) ) { + FILE *include_fp ; + char include_file_name[128] ; + p += 7 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; + if ( strlen( p ) > 127 ) { fprintf(stderr,"Registry warning: invalid include file name: %s\n", p ) ; } + else { + sprintf( include_file_name , "%s/%s", dir , p ) ; + if ( (p=index(include_file_name,'\n')) != NULL ) *p = '\0' ; + fprintf(stderr,"opening %s\n",include_file_name) ; + if (( include_fp = fopen( include_file_name , "r" )) != NULL ) { + + fprintf(stderr,"including %s\n",include_file_name ) ; + pre_parse( dir , include_fp , outfile ) ; + + fclose( include_fp ) ; + } else { + fprintf(stderr,"Registry warning: cannot open %s. Ignoring.\n", include_file_name ) ; + } + } + } + else if ( !strncmp( p , "ifdef", 5 ) ) { + char value[32] ; + p += 5 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; + strncpy(value, p, 31 ) ; value[31] = '\0' ; + if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; + if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + ifdef_stack_ptr++ ; + ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) != NULL && ifdef_stack[ifdef_stack_ptr-1] ) ; + if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; } + continue ; + } + else if ( !strncmp( p , "ifndef", 6 ) ) { + char value[32] ; + p += 6 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; + strncpy(value, p, 31 ) ; value[31] = '\0' ; + if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; + if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + ifdef_stack_ptr++ ; + ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) == NULL && ifdef_stack[ifdef_stack_ptr-1] ) ; + if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; } + continue ; + } + else if ( !strncmp( p , "endif", 5 ) ) { + ifdef_stack_ptr-- ; + if ( ifdef_stack_ptr < 0 ) { fprintf(stderr,"Registry fatal: unmatched endif\n") ; exit(1) ; } + continue ; + } + else if ( !strncmp( p , "define", 6 ) ) { + char value[32] ; + p += 6 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; + strncpy(value, p, 31 ) ; value[31] = '\0' ; + if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; + if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + sym_add( value ) ; + continue ; + } + if ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) continue ; +/*** end of preprocessing directives ****/ + + strcat( parseline , inln ) ; + + /* allow \ to continue the end of a line */ + if (( p = index( parseline, '\\' )) != NULL ) + { + if ( *(p+1) == '\n' || *(p+1) == '\0' ) + { + *p = '\0' ; + continue ; /* go get another line */ + } + } + make_lower( parseline ) ; + + if (( p = index( parseline , '\n' )) != NULL ) *p = '\0' ; /* discard newlines */ + + /* check line and zap any # characters that are in double quotes */ + + for ( p = parseline, inquote = 0 ; *p ; p++ ) { + if ( *p == '"' && inquote ) inquote = 0 ; + else if ( *p == '"' && !inquote ) inquote = 1 ; + else if ( *p == '#' && inquote ) *p = ' ' ; + else if ( *p == '#' && !inquote ) { *p = '\0' ; break ; } + } + if ( inquote ) { retval=1 ; fprintf(stderr,"Registry error: unbalanced quotes in line:\n%s\n",parseline) ;} + + for ( i = 0 ; i < MAXTOKENS ; i++ ) tokens[i] = NULL ; + i = 0 ; + + strcpy( parseline_save, parseline ) ; + + if ((tokens[i] = my_strtok(parseline)) != NULL ) i++ ; + while (( tokens[i] = my_strtok(NULL) ) != NULL && i < MAXTOKENS ) i++ ; + if ( i <= 0 ) continue ; + + for ( i = 0 ; i < MAXTOKENS ; i++ ) + { + if ( tokens[i] == NULL ) tokens[i] = "-" ; + } +/* remove quotes from quoted entries */ + for ( i = 0 ; i < MAXTOKENS ; i++ ) + { + char * pp ; + if ( tokens[i][0] == '"' ) tokens[i]++ ; + if ((pp=rindex( tokens[i], '"' )) != NULL ) *pp = '\0' ; + } + if ( !strcmp( tokens[ TABLE ] , "state" ) ) + { + strcpy( newdims, "" ) ; + strcpy( newdims4d, "" ) ; + is4d = 0 ; wantstend = 0 ; wantsbdy = 0 ; + for ( i = 0 ; i < (len_of_tok = strlen(tokens[F_DIMS])) ; i++ ) + { + x = tolower(tokens[F_DIMS][i]) ; + if ( x >= 'a' && x <= 'z' ) { + if ( x == 'f' ) { is4d = 1 ; } + if ( x == 't' ) { wantstend = 1 ; } + if ( x == 'b' ) { wantsbdy = 1 ; } + } + sprintf(xstr,"%c",x) ; + if ( x != 'b' ) strcat ( newdims , xstr ) ; + if ( x != 'f' && x != 't' ) strcat( newdims4d , xstr ) ; + + } + if ( wantsbdy ) { + + +/* first re-gurg the original entry without the b in the dims */ + + fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"%s\" \"%s\"\n",tokens[F_TYPE],tokens[F_SYM], newdims, + tokens[F_USE],tokens[F_NTL],tokens[F_STAG],tokens[F_IO], + tokens[F_DNAME],tokens[F_DESCRIP],tokens[F_UNITS] ) ; + + if ( strcmp( tokens[F_SYM] , "-" ) ) { /* if not unnamed, as can happen with first 4d tracer */ +/* next, output some additional entries for the boundary arrays for these guys */ + if ( is4d == 1 ) { + for ( i = 0, found = 0 ; i < ntracers ; i++ ) { + if ( !strcmp( tokens[F_USE] , tracers[i] ) ) found = 1 ; + } + if ( found == 0 ) { + sprintf(tracers[ntracers],tokens[F_USE]) ; + ntracers++ ; + +/* add entries for _b and _bt arrays */ + + sprintf(newname,"%s_b",tokens[F_USE]) ; + fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy %s\" \"%s\"\n",tokens[F_TYPE],newname,newdims4d, + "_4d_bdy_array_","-",tokens[F_STAG],"b", + newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ; + + sprintf(newname,"%s_bt",tokens[F_USE]) ; + fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy tend %s\" \"(%s)/dt\"\n",tokens[F_TYPE],newname,newdims4d, + "_4d_bdy_array_","-",tokens[F_STAG],"b", + newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ; + + } + } else { + +/* add entries for _b and _bt arrays */ + + sprintf(newname,"%s_b",tokens[F_SYM]) ; + fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy %s\" \"%s\"\n",tokens[F_TYPE],newname,tokens[F_DIMS], + tokens[F_USE],"-",tokens[F_STAG],"b", + newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ; + + sprintf(newname,"%s_bt",tokens[F_SYM]) ; + fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy tend %s\" \"(%s)/dt\"\n",tokens[F_TYPE],newname,tokens[F_DIMS], + tokens[F_USE],"-",tokens[F_STAG],"b", + newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ; + + } + } + parseline[0] = '\0' ; /* reset parseline */ + continue ; + } + } +normal: + /* otherwise output the line as is */ + fprintf(outfile,"%s\n",parseline_save) ; + parseline[0] = '\0' ; /* reset parseline */ + } + return(retval) ; +} + +int +reg_parse( FILE * infile ) +{ + char inln[4096], parseline[4096] ; + char *p, *q ; + char *tokens[MAXTOKENS], *toktmp[MAXTOKENS] ; + int i, ii ; + int defining_state_field, defining_rconfig_field, defining_i1_field ; + + parseline[0] = '\0' ; + + max_time_level = 1 ; + +/* main parse loop over registry lines */ + while ( fgets ( inln , 4096 , infile ) != NULL ) + { + strcat( parseline , inln ) ; + /* allow \ to continue the end of a line */ + if (( p = index( parseline, '\\' )) != NULL ) + { + if ( *(p+1) == '\n' || *(p+1) == '\0' ) + { + *p = '\0' ; + continue ; /* go get another line */ + } + } + + make_lower( parseline ) ; + if (( p = index( parseline , '#' )) != NULL ) *p = '\0' ; /* discard comments (dont worry about quotes for now) */ + if (( p = index( parseline , '\n' )) != NULL ) *p = '\0' ; /* discard newlines */ + for ( i = 0 ; i < MAXTOKENS ; i++ ) tokens[i] = NULL ; + i = 0 ; + + if ((tokens[i] = my_strtok(parseline)) != NULL ) i++ ; + + while (( tokens[i] = my_strtok(NULL) ) != NULL && i < MAXTOKENS ) i++ ; + if ( i <= 0 ) continue ; + + for ( i = 0 ; i < MAXTOKENS ; i++ ) + { + if ( tokens[i] == NULL ) tokens[i] = "-" ; + } + +/* remove quotes from quoted entries */ + for ( i = 0 ; i < MAXTOKENS ; i++ ) + { + char * pp ; + if ( tokens[i][0] == '"' ) tokens[i]++ ; + if ((pp=rindex( tokens[i], '"' )) != NULL ) *pp = '\0' ; + } + + defining_state_field = 0 ; + defining_rconfig_field = 0 ; + defining_i1_field = 0 ; + +/* state entry */ + if ( !strcmp( tokens[ TABLE ] , "state" ) ) + { + /* turn a state entry into a typedef to define a field in the top-level built-in type domain */ + tokens[TABLE] = "typedef" ; + for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ; /* shift the fields to the left */ + tokens[FIELD_OF] = "domain" ; + if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ; + defining_state_field = 1 ; + } + if ( !strcmp( tokens[ TABLE ] , "rconfig" ) ) + { + /* turn a rconfig entry into a typedef to define a field in the top-level built-in type domain */ + for ( i = 0 ; i < MAXTOKENS ; i++ ) { toktmp[i] = tokens[i] ; tokens[i] = "-" ; } + tokens[TABLE] = "typedef" ; + tokens[FIELD_OF] = "domain" ; + tokens[RCNF_TYPE] = toktmp[RCNF_TYPE_PRE] ; + if ( !strcmp( tokens[RCNF_TYPE], "double" ) ) tokens[RCNF_TYPE] = "doubleprecision" ; + tokens[RCNF_SYM] = toktmp[RCNF_SYM_PRE] ; + tokens[RCNF_IO] = toktmp[RCNF_IO_PRE] ; + tokens[RCNF_DNAME] = toktmp[RCNF_DNAME_PRE] ; + tokens[RCNF_USE] = "-" ; + tokens[RCNF_DESCRIP] = toktmp[RCNF_DESCRIP_PRE] ; + tokens[RCNF_UNITS] = toktmp[RCNF_UNITS_PRE] ; + tokens[RCNF_HOWSET] = toktmp[RCNF_HOWSET_PRE] ; + tokens[RCNF_NENTRIES] = toktmp[RCNF_NENTRIES_PRE] ; + tokens[RCNF_DEFAULT] = toktmp[RCNF_DEFAULT_PRE] ; + defining_rconfig_field = 1 ; + } + if ( !strcmp( tokens[ TABLE ] , "i1" ) ) + { + /* turn a state entry into a typedef to define a field in + the top-level built-in type domain */ + tokens[TABLE] = "typedef" ; + /* shift the fields to the left */ + for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ; + tokens[FIELD_OF] = "domain" ; + if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ; + defining_i1_field = 1 ; + } + + /* NOTE: fall through */ + +/* typedef entry */ + if ( !strcmp( tokens[ TABLE ] , "typedef" ) ) + { + node_t * field_struct ; + node_t * type_struct ; + + if ( !defining_state_field && ! defining_i1_field && + !defining_rconfig_field && !strcmp(tokens[FIELD_OF],"domain") ) + { fprintf(stderr,"Registry warning: 'domain' is a reserved registry type name. Cannot 'typedef domain'\n") ; } + + type_struct = get_type_entry( tokens[ FIELD_OF ] ) ; + if ( type_struct == NULL ) + { + type_struct = new_node( TYPE ) ; + strcpy( type_struct->name, tokens[FIELD_OF] ) ; + type_struct->type_type = DERIVED ; + add_node_to_end( type_struct , &Type ) ; + } + + if ( defining_i1_field ) { + field_struct = new_node( I1 ) ; + } else if ( defining_rconfig_field ) { + field_struct = new_node( RCONFIG ) ; + } else { + field_struct = new_node( FIELD ) ; + } + + strcpy( field_struct->name, tokens[FIELD_SYM] ) ; + + if ( set_state_type( tokens[FIELD_TYPE], field_struct ) ) + { fprintf(stderr,"Registry warning: type %s used before defined \n",tokens[FIELD_TYPE] ) ; } + + if ( set_state_dims( tokens[FIELD_DIMS], field_struct ) ) + { fprintf(stderr,"Registry warning: some problem with dimstring %s\n", tokens[FIELD_DIMS] ) ; } + + if ( strcmp( tokens[FIELD_NTL], "-" ) ) /* that is, if not equal "-" */ + { field_struct->ntl = atoi(tokens[FIELD_NTL]) ; } + field_struct->ntl = ( field_struct->ntl > 0 )?field_struct->ntl:1 ; + /* calculate the maximum number of time levels and store in global variable */ + if ( field_struct->ntl > max_time_level && field_struct->ntl <= 3 ) max_time_level = field_struct->ntl ; + + field_struct->stag_x = 0 ; field_struct->stag_y = 0 ; field_struct->stag_z = 0 ; + for ( i = 0 ; i < strlen(tokens[FIELD_STAG]) ; i++ ) + { + if ( tolower(tokens[FIELD_STAG][i]) == 'x' || sw_all_x_staggered ) field_struct->stag_x = 1 ; + if ( tolower(tokens[FIELD_STAG][i]) == 'y' || sw_all_y_staggered ) field_struct->stag_y = 1 ; + if ( tolower(tokens[FIELD_STAG][i]) == 'z' ) field_struct->stag_z = 1 ; + } + + field_struct->history = 0 ; field_struct->input = 0 ; + field_struct->auxhist1 = 0 ; field_struct->auxinput1 = 0 ; + field_struct->auxhist2 = 0 ; field_struct->auxinput2 = 0 ; + field_struct->auxhist3 = 0 ; field_struct->auxinput3 = 0 ; + field_struct->auxhist4 = 0 ; field_struct->auxinput4 = 0 ; + field_struct->auxhist5 = 0 ; field_struct->auxinput5 = 0 ; + field_struct->restart = 0 ; field_struct->boundary = 0 ; + field_struct->io_mask = 0 ; + { + char prev = '\0' ; + char x ; + int len_of_tok ; + char fcn_name[2048], aux_fields[2048] ; + + for ( i = 0 ; i < (len_of_tok = strlen(tokens[FIELD_IO])) ; i++ ) + { + x = tolower(tokens[FIELD_IO][i]) ; + if ( x >= 'a' && x <= 'z' && ! ( x == 'g' || x == 'o' ) ) { + if ( x == 'h' ) {field_struct->history = 10 ; field_struct->io_mask |= HISTORY ;} + if ( x == 'i' ) {field_struct->input = 10 ; field_struct->io_mask |= INPUT ;} + if ( x == 'r' ) {field_struct->restart = 10 ; field_struct->io_mask |= RESTART ;} + if ( x == 'b' ) {field_struct->boundary = 10 ; field_struct->io_mask |= BOUNDARY ;} + if ( x == 'f' || x == 'd' || x == 'u' || x == 's' ) { + strcpy(aux_fields,"") ; + strcpy(fcn_name,"") ; + if ( tokens[FIELD_IO][i+1] == '(' ) /* catch a possible error */ + { + fprintf(stderr, + "Registry warning: syntax error in %c specifier of IO field for %s\n",x,tokens[FIELD_SYM]) ; + fprintf(stderr, + " equal sign needed before left paren\n") ; + } + + if ( tokens[FIELD_IO][i+1] == '=' ) + { + int ii, jj, state ; + state = 0 ; + jj = 0 ; + for ( ii = i+3 ; ii < len_of_tok ; ii++ ) + { + if ( tokens[FIELD_IO][ii] == ')' ) { if (state == 0 )fcn_name[jj] = '\0' ; aux_fields[jj] = '\0' ; break ; } + if ( tokens[FIELD_IO][ii] == ':' ) { fcn_name[jj] = '\0' ; jj= 0 ; state++ ; continue ;} + if ( tokens[FIELD_IO][ii] == ',' && state == 0 ) { + fprintf(stderr, + "Registry warning: syntax error in %c specifier of IO field for %s\n",x, + tokens[FIELD_SYM]) ; + } + if ( state == 0 ) /* looking for interpolation fcn name */ + { + fcn_name[jj++] = tokens[FIELD_IO][ii] ; + } + if ( state > 0 ) + { + aux_fields[jj++] = tokens[FIELD_IO][ii] ; + } + } + i = ii ; + } + else + { + if ( x == 'f' || x == 'd' ) strcpy(fcn_name,"interp_fcn") ; + if ( x == 'u' ) strcpy(fcn_name,"copy_fcn") ; + if ( x == 's' ) strcpy(fcn_name,"smoother") ; + } + if ( x == 'f' ) { + field_struct->io_mask |= FORCE_DOWN ; + strcpy(field_struct->force_fcn_name, fcn_name ) ; + strcpy(field_struct->force_aux_fields, aux_fields ) ; + } + else if ( x == 'd' ) { + field_struct->io_mask |= INTERP_DOWN ; + strcpy(field_struct->interpd_fcn_name, fcn_name ) ; + strcpy(field_struct->interpd_aux_fields, aux_fields ) ; + } + else if ( x == 's' ) { + field_struct->io_mask |= SMOOTH_UP ; + strcpy(field_struct->smoothu_fcn_name, fcn_name ) ; + strcpy(field_struct->smoothu_aux_fields, aux_fields ) ; + } + else if ( x == 'u' ) { + field_struct->io_mask |= INTERP_UP ; + strcpy(field_struct->interpu_fcn_name, fcn_name ) ; + strcpy(field_struct->interpu_aux_fields, aux_fields ) ; + } + } + prev = x ; + } else if ( x >= '0' && x <= '9' || x == 'g' || x == 'o' ) + { + if ( prev == 'i' ) + { + field_struct->io_mask &= ! INPUT ; /* turn off setting from 'i' */ + field_struct->input = field_struct->input % 10 ; /* turn off setting from 'i' */ + if ( x == '0' ) field_struct->input = 1 ; + if ( x == '1' ) field_struct->auxinput1 = 1 ; + if ( x == '2' ) field_struct->auxinput2 = 1 ; + if ( x == '3' ) field_struct->auxinput3 = 1 ; + if ( x == '4' ) field_struct->auxinput4 = 1 ; + if ( x == '5' ) field_struct->auxinput5 = 1 ; + if ( x == '6' ) field_struct->auxinput6 = 1 ; + if ( x == '7' ) field_struct->auxinput7 = 1 ; + if ( x == '8' ) field_struct->auxinput8 = 1 ; + if ( x == '9' ) field_struct->auxinput9 = 1 ; + if ( x == 'g' ) field_struct->auxinput10 = 1 ; + if ( x == 'o' ) field_struct->auxinput11 = 1 ; + } + if ( prev == 'h' ) + { + field_struct->io_mask &= ! HISTORY ; /* turn off setting from 'h' */ + field_struct->history = field_struct->history % 10 ; /* turn off setting from 'h' */ + if ( x == '0' ) field_struct->history = 1 ; + if ( x == '1' ) field_struct->auxhist1 = 1 ; + if ( x == '2' ) field_struct->auxhist2 = 1 ; + if ( x == '3' ) field_struct->auxhist3 = 1 ; + if ( x == '4' ) field_struct->auxhist4 = 1 ; + if ( x == '5' ) field_struct->auxhist5 = 1 ; + if ( x == '6' ) field_struct->auxhist6 = 1 ; + if ( x == '7' ) field_struct->auxhist7 = 1 ; + if ( x == '8' ) field_struct->auxhist8 = 1 ; + if ( x == '9' ) field_struct->auxhist9 = 1 ; + if ( x == 'g' ) field_struct->auxhist10 = 1 ; + if ( x == 'o' ) field_struct->auxhist11 = 1 ; + } + } + } + if ( field_struct->history > 0 ) { field_struct->history = 1 ; field_struct->io_mask |= HISTORY ; } + if ( field_struct->auxhist1 > 0 ) { field_struct->auxhist1 = 1 ; field_struct->io_mask |= AUXHIST1 ; } + if ( field_struct->auxhist2 > 0 ) { field_struct->auxhist2 = 1 ; field_struct->io_mask |= AUXHIST2 ; } + if ( field_struct->auxhist3 > 0 ) { field_struct->auxhist3 = 1 ; field_struct->io_mask |= AUXHIST3 ; } + if ( field_struct->auxhist4 > 0 ) { field_struct->auxhist4 = 1 ; field_struct->io_mask |= AUXHIST4 ; } + if ( field_struct->auxhist5 > 0 ) { field_struct->auxhist5 = 1 ; field_struct->io_mask |= AUXHIST5 ; } + if ( field_struct->auxhist6 > 0 ) { field_struct->auxhist6 = 1 ; field_struct->io_mask |= AUXHIST6 ; } + if ( field_struct->auxhist7 > 0 ) { field_struct->auxhist7 = 1 ; field_struct->io_mask |= AUXHIST7 ; } + if ( field_struct->auxhist8 > 0 ) { field_struct->auxhist8 = 1 ; field_struct->io_mask |= AUXHIST8 ; } + if ( field_struct->auxhist9 > 0 ) { field_struct->auxhist9 = 1 ; field_struct->io_mask |= AUXHIST9 ; } + if ( field_struct->auxhist10 > 0 ) { field_struct->auxhist10 = 1 ; field_struct->io_mask |= AUXHIST10 ; } + if ( field_struct->auxhist11 > 0 ) { field_struct->auxhist11 = 1 ; field_struct->io_mask |= AUXHIST11 ; } + + if ( field_struct->input > 0 ) { field_struct->input = 1 ; field_struct->io_mask |= INPUT ; } + if ( field_struct->auxinput1 > 0 ) { field_struct->auxinput1 = 1 ; field_struct->io_mask |= AUXINPUT1 ; } + if ( field_struct->auxinput2 > 0 ) { field_struct->auxinput2 = 1 ; field_struct->io_mask |= AUXINPUT2 ; } + if ( field_struct->auxinput3 > 0 ) { field_struct->auxinput3 = 1 ; field_struct->io_mask |= AUXINPUT3 ; } + if ( field_struct->auxinput4 > 0 ) { field_struct->auxinput4 = 1 ; field_struct->io_mask |= AUXINPUT4 ; } + if ( field_struct->auxinput5 > 0 ) { field_struct->auxinput5 = 1 ; field_struct->io_mask |= AUXINPUT5 ; } + if ( field_struct->auxinput6 > 0 ) { field_struct->auxinput6 = 1 ; field_struct->io_mask |= AUXINPUT6 ; } + if ( field_struct->auxinput7 > 0 ) { field_struct->auxinput7 = 1 ; field_struct->io_mask |= AUXINPUT7 ; } + if ( field_struct->auxinput8 > 0 ) { field_struct->auxinput8 = 1 ; field_struct->io_mask |= AUXINPUT8 ; } + if ( field_struct->auxinput9 > 0 ) { field_struct->auxinput9 = 1 ; field_struct->io_mask |= AUXINPUT9 ; } + if ( field_struct->auxinput10 > 0 ) { field_struct->auxinput10 = 1 ; field_struct->io_mask |= AUXINPUT10 ; } + if ( field_struct->auxinput11 > 0 ) { field_struct->auxinput11 = 1 ; field_struct->io_mask |= AUXINPUT11 ; } + + if ( field_struct->restart > 0 ) { field_struct->restart = 1 ; field_struct->io_mask |= RESTART ; } + if ( field_struct->boundary > 0 ) { field_struct->boundary = 1 ; field_struct->io_mask |= BOUNDARY ; } + } + + field_struct->dname[0] = '\0' ; + if ( strcmp( tokens[FIELD_DNAME], "-" ) ) /* that is, if not equal "-" */ + { strcpy( field_struct->dname , tokens[FIELD_DNAME] ) ; } + strcpy(field_struct->descrip,"-") ; + if ( strcmp( tokens[FIELD_DESCRIP], "-" ) ) /* that is, if not equal "-" */ + { strcpy( field_struct->descrip , tokens[FIELD_DESCRIP] ) ; } + strcpy(field_struct->units,"-") ; + if ( strcmp( tokens[FIELD_UNITS], "-" ) ) /* that is, if not equal "-" */ + { strcpy( field_struct->units , tokens[FIELD_UNITS] ) ; } + strcpy(field_struct->use,"-") ; + if ( strcmp( tokens[FIELD_USE], "-" ) ) /* that is, if not equal "-" */ + { strcpy( field_struct->use , tokens[FIELD_USE] ) ; + if ( ! defining_rconfig_field && ! field_struct->scalar_array_member && !strncmp( tokens[FIELD_USE], "dyn_", 4 ) ) + add_core_name( tokens[FIELD_USE]+4 ) ; + } + + /* specific settings for RCONFIG entries */ + if ( defining_rconfig_field ) + { + if ( strcmp( tokens[RCNF_NENTRIES] , "-" ) ) /* that is, if not equal "-" */ + { + strcpy(field_struct->nentries, tokens[RCNF_NENTRIES] ) ; + } else { + strcpy(field_struct->nentries, "1" ) ; + } + if ( strcmp( tokens[RCNF_HOWSET] , "-" ) ) /* that is, if not equal "-" */ + { + strcpy(field_struct->howset,tokens[RCNF_HOWSET]) ; + } else { + strcpy(field_struct->howset,"") ; + } + if ( strcmp( tokens[RCNF_DEFAULT] , "-" ) ) /* that is, if not equal "-" */ + { + strcpy(field_struct->dflt,tokens[RCNF_DEFAULT]) ; + } else { + strcpy(field_struct->dflt,"") ; + } + } + + if ( field_struct->type != NULL ) + if ( field_struct->type->type_type == DERIVED && field_struct->ndims > 0 ) + { fprintf(stderr,"Registry warning: type item %s of type %s can not be multi-dimensional ", + tokens[FIELD_SYM], tokens[FIELD_TYPE] ) ; } + +/**/ if ( ! field_struct->scalar_array_member ) + { + add_node_to_end( field_struct , &(type_struct->fields) ) ; + } +/**/ else /* if ( field_struct->scalar_array_member ) */ + { +/* + Here we are constructing a list of nodes to represent the list of 4D scalar arrays in the model + + This list is rooted at the FourD pointer. + Each array is represented by its own node; each node has a pointer, members, to the list + of fields that make it up. + +*/ + node_t * q , * member ; + if (( q = get_4d_entry(field_struct->use )) == NULL ) /* first instance of a 4d array member */ + { + q = new_node( FOURD ) ; + *q = *field_struct ; /* this overwrites the node */ + strcpy( q->name, field_struct->use ) ; + strcpy( q->use, "" ) ; + q->node_kind = FOURD ; + q->scalar_array_member = 0 ; + q->next4d = NULL ; + q->next = NULL ; + /* add 4d q node to the list of fields of this type and also attach + it to the global list of 4d arrays */ + add_node_to_end( q , &(type_struct->fields) ) ; + add_node_to_end_4d( q , &(FourD) ) ; + } + member = new_node( MEMBER ) ; + *member = *q ; + member->node_kind = MEMBER ; + member->members = NULL ; + member->scalar_array_member = 1 ; + strcpy( member->name , field_struct->name ) ; + strcpy( member->dname , field_struct->dname ) ; + strcpy( member->use , field_struct->use ) ; + strcpy( member->descrip , field_struct->descrip ) ; + strcpy( member->units , field_struct->units ) ; + member->next = NULL ; + member->io_mask = field_struct->io_mask ; + member->ndims = field_struct->ndims ; + strcpy( member->interpd_fcn_name, field_struct->interpd_fcn_name) ; + strcpy( member->interpd_aux_fields, field_struct->interpd_aux_fields) ; + strcpy( member->interpu_fcn_name, field_struct->interpu_fcn_name) ; + strcpy( member->interpu_aux_fields, field_struct->interpu_aux_fields) ; + strcpy( member->smoothu_fcn_name, field_struct->smoothu_fcn_name) ; + strcpy( member->smoothu_aux_fields, field_struct->smoothu_aux_fields) ; + strcpy( member->force_fcn_name, field_struct->force_fcn_name) ; + strcpy( member->force_aux_fields, field_struct->force_aux_fields) ; + for ( ii = 0 ; ii < member->ndims ; ii++ ) + member->dims[ii] = field_struct->dims[ii] ; + add_node_to_end( member , &(q->members) ) ; + free(field_struct) ; /* We've used all the information about this entry. + It is not a field but the name of one of the members of + a 4d field. we have handled that here. Discard the original node. */ + } + } + +/* dimespec entry */ + else if ( !strcmp( tokens[ TABLE ] , "dimspec" ) ) + { + node_t * dim_struct ; + dim_struct = new_node( DIM ) ; + if ( strlen( tokens[DIM_NAME] ) > 1 ) + { fprintf(stderr,"Registry warning: dimspec (%s) must be only one letter\n",tokens[DIM_NAME] ) ; } + if ( get_dim_entry ( tokens[DIM_NAME][0] ) != NULL ) + { fprintf(stderr,"Registry warning: dimspec (%c) already defined\n",tokens[DIM_NAME][0] ) ; } + dim_struct->dim_name = tokens[DIM_NAME][0] ; + if ( set_dim_order( tokens[DIM_ORDER], dim_struct ) ) + { fprintf(stderr,"Registry warning: problem with dimorder (%s)\n",tokens[DIM_ORDER] ) ; } + if ( set_dim_len( tokens[DIM_SPEC], dim_struct ) ) + { fprintf(stderr,"Registry warning: problem with dimspec (%s)\n",tokens[DIM_SPEC] ) ; } + if ( set_dim_orient( tokens[DIM_ORIENT], dim_struct ) ) + { fprintf(stderr,"Registry warning: problem with dimorient (%s)\n",tokens[DIM_ORIENT] ) ; } + if ( strcmp( tokens[DIM_DATA_NAME], "-" ) ) /* that is, if not equal "-" */ + { strcpy( dim_struct->dim_data_name , tokens[DIM_DATA_NAME] ) ; } + + add_node_to_end( dim_struct , &Dim ) ; + } + +/* package */ + else if ( !strcmp( tokens[ TABLE ] , "package" ) ) + { + node_t * package_struct ; + package_struct = new_node( PACKAGE ) ; + strcpy( package_struct->name , tokens[PKG_SYM] ) ; + strcpy( package_struct->pkg_assoc , tokens[PKG_ASSOC] ) ; + strcpy( package_struct->pkg_statevars , tokens[PKG_STATEVARS] ) ; + strcpy( package_struct->pkg_4dscalars , tokens[PKG_4DSCALARS] ) ; + + add_node_to_end( package_struct , &Packages ) ; + } + +/* halo, period, xpose */ + else if ( !strcmp( tokens[ TABLE ] , "halo" ) ) + { + node_t * comm_struct ; + comm_struct = new_node( HALO ) ; + strcpy( comm_struct->name , tokens[COMM_ID] ) ; + strcpy( comm_struct->use , tokens[COMM_USE] ) ; +#if 1 + for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) { + for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;} + } +#else + strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ; +#endif + add_node_to_end( comm_struct , &Halos ) ; + } + else if ( !strcmp( tokens[ TABLE ] , "period" ) ) + { + node_t * comm_struct ; + comm_struct = new_node( PERIOD ) ; + strcpy( comm_struct->name , tokens[COMM_ID] ) ; + strcpy( comm_struct->use , tokens[COMM_USE] ) ; +#if 1 + for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) { + for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;} + } +#else + strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ; +#endif + add_node_to_end( comm_struct , &Periods ) ; + } + else if ( !strcmp( tokens[ TABLE ] , "xpose" ) ) + { + node_t * comm_struct ; + comm_struct = new_node( XPOSE ) ; + strcpy( comm_struct->name , tokens[COMM_ID] ) ; + strcpy( comm_struct->use , tokens[COMM_USE] ) ; +#if 1 + for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) { + for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;} + } +#else + strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ; +#endif + add_node_to_end( comm_struct , &Xposes ) ; + } + else if ( !strcmp( tokens[ TABLE ] , "swap" ) ) + { + node_t * comm_struct ; + comm_struct = new_node( SWAP ) ; + strcpy( comm_struct->name , tokens[COMM_ID] ) ; + strcpy( comm_struct->use , tokens[COMM_USE] ) ; +#if 1 + for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) { + for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;} + } +#else + strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ; +#endif + add_node_to_end( comm_struct , &Swaps ) ; + } + else if ( !strcmp( tokens[ TABLE ] , "cycle" ) ) + { + node_t * comm_struct ; + comm_struct = new_node( CYCLE ) ; + strcpy( comm_struct->name , tokens[COMM_ID] ) ; + strcpy( comm_struct->use , tokens[COMM_USE] ) ; +#if 1 + for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) { + for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;} + } +#else + strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ; +#endif + add_node_to_end( comm_struct , &Cycles ) ; + } + + +#if 0 + fprintf(stderr,"vvvvvvvvvvvvvvvvvvvvvvvvvvv\n") ; + show_nodelist( Type ) ; + fprintf(stderr,"^^^^^^^^^^^^^^^^^^^^^^^^^^^\n") ; +#endif + parseline[0] = '\0' ; /* reset parseline */ + } + + Domain = *(get_type_entry( "domain" )) ; + +#if 0 + show_node( &Domain ) ; +#endif + + return(0) ; + +} + +node_t * +get_dim_entry( char c ) +{ + node_t * p ; + for ( p = Dim ; p != NULL ; p = p->next ) + { + if ( p->dim_name == c ) return( p ) ; + } + return(NULL) ; +} + +int +set_state_type( char * typename, node_t * state_entry ) +{ + if ( typename == NULL ) return(1) ; + return (( state_entry->type = get_type_entry( typename )) == NULL ) ; +} + +int +set_dim_len ( char * dimspec , node_t * dim_entry ) +{ + if (!strcmp( dimspec , "standard_domain" )) + { dim_entry->len_defined_how = DOMAIN_STANDARD ; } + else if (!strncmp( dimspec, "constant=" , 9 )) + { + char *p, *colon, *paren ; + p = &(dimspec[9]) ; + /* check for colon */ + if (( colon = index(p,':')) != NULL ) + { + *colon = '\0' ; + if (( paren = index(p,'(')) !=NULL ) + { + dim_entry->coord_start = atoi(paren+1) ; + } + else + { + fprintf(stderr,"WARNING: illegal syntax (missing opening paren) for constant: %s\n",p) ; + } + dim_entry->coord_end = atoi(colon+1) ; + } + else + { + dim_entry->coord_start = 1 ; + dim_entry->coord_end = atoi(p) ; + } + dim_entry->len_defined_how = CONSTANT ; + } + else if (!strncmp( dimspec, "namelist=", 9 )) + { + char *p, *colon ; + + p = &(dimspec[9]) ; + /* check for colon */ + if (( colon = index(p,':')) != NULL ) + { + *colon = '\0' ; + strcpy( dim_entry->assoc_nl_var_s, p ) ; + strcpy( dim_entry->assoc_nl_var_e, colon+1 ) ; + } + else + { + strcpy( dim_entry->assoc_nl_var_s, "1" ) ; + strcpy( dim_entry->assoc_nl_var_e, p ) ; + } + dim_entry->len_defined_how = NAMELIST ; + } + else + { + return(1) ; + } + return(0) ; +} + +int +set_dim_orient ( char * dimorient , node_t * dim_entry ) +{ + if (!strcmp( dimorient , "x" )) + { dim_entry->coord_axis = COORD_X ; } + else if (!strcmp( dimorient , "y" )) + { dim_entry->coord_axis = COORD_Y ; } + else if (!strcmp( dimorient , "z" )) + { dim_entry->coord_axis = COORD_Z ; } + else + { dim_entry->coord_axis = COORD_C ; } + return(0) ; +} + +/* integrity checking of dimension list; make sure that + namelist specified dimensions have an associated namelist variable */ +int +check_dimspecs() +{ + node_t * p, *q ; + int ord ; + + for ( p = Dim ; p != NULL ; p = p->next ) + { + if ( p->len_defined_how == DOMAIN_STANDARD ) + { + if ( p->dim_order < 1 || p->dim_order > 3 ) + { + fprintf(stderr,"WARNING: illegal dim order %d for dimspec %s\n",p->dim_order,p->name) ; + } + ord = p->dim_order-1 ; + if ( model_order[ord] != p->coord_axis ) + { + if ( model_order[ord] == -1 ) model_order[ord] = p->coord_axis ; + else + { + fprintf(stderr,"WARNING: coord-axis/dim-order for dimspec %s is inconsistent with previous dimspec.\n",p->name) ; + } + } + } + else if ( p->len_defined_how == NAMELIST ) + { + if ( strcmp( p->assoc_nl_var_s, "1" ) ) /* if not equal to "1" */ + { + if (( q = get_entry(p->assoc_nl_var_s,Domain.fields)) == NULL ) + { + fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", + p->assoc_nl_var_s,p->name ) ; + return(1) ; + } + if ( ! q->node_kind & RCONFIG ) + { + fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", + p->assoc_nl_var_s,p->name ) ; + return(1) ; + } + if ( strcmp( q->type->name , "integer" ) ) /* if not integer */ + { + fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n", + p->assoc_nl_var_s,p->name ) ; + return(1) ; + } + if ( strcmp( q->nentries , "1" ) ) /* if not 1 entry */ + { + fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n", + p->assoc_nl_var_s,p->name ) ; + return(1) ; + } + } + if (( q = get_entry(p->assoc_nl_var_e,Domain.fields)) == NULL ) + { + fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", + p->assoc_nl_var_e,p->name ) ; + return(1) ; + } + if ( ! q->node_kind & RCONFIG ) + { + fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", + p->assoc_nl_var_e,p->name ) ; + return(1) ; + } + if ( strcmp( q->type->name , "integer" ) ) /* if not integer */ + { + fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n", + p->assoc_nl_var_e,p->name ) ; + return(1) ; + } + if ( strcmp( q->nentries , "1" ) ) /* if not 1 entry */ + { + fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n", + p->assoc_nl_var_e,p->name ) ; + return(1) ; + } + } + } + return(0) ; +} + +int +set_dim_order ( char * dimorder , node_t * dim_entry ) +{ + dim_entry->dim_order = atoi(dimorder) ; + return(0) ; +} + +init_parser() +{ + model_order[0] = -1 ; + model_order[1] = -1 ; + model_order[2] = -1 ; + return(0) ; +} diff --git a/wrfv2_fire/tools/registry.c b/wrfv2_fire/tools/registry.c new file mode 100644 index 00000000..a1a4d71a --- /dev/null +++ b/wrfv2_fire/tools/registry.c @@ -0,0 +1,203 @@ +#include +#include +#include +#include +#include +#include +#include + +#define DEFINE_GLOBALS +#include "protos.h" +#include "registry.h" +#include "data.h" +#include "sym.h" + +main( int argc, char *argv[], char *env[] ) +{ + char fname_in[NAMELEN], dir[NAMELEN], fname_tmp[NAMELEN], command[NAMELEN] ; + FILE * fp_in, *fp_tmp ; + char * thisprog ; + int mypid ; + struct rlimit rlim ; + + mypid = (int) getpid() ; + strcpy( thiscom, argv[0] ) ; + argv++ ; + + sw_deref_kludge = 0 ; + sw_io_deref_kludge = 0 ; + sw_3dvar_iry_kludge = 0 ; + sw_distrib_io_layer = 1 ; + sw_limit_args = 0 ; /* usually set -- except for GRAPS */ + sw_dm_parallel = 0 ; + sw_all_x_staggered = 0 ; + sw_move = 0 ; + sw_all_y_staggered = 0 ; + sw_ifort_kludge = 0 ; + sw_dm_serial_in_only = 0 ; /* input and bdy data set is distributed by node 0, + other data streams are written to file per process */ + sw_new_bdys = 0 ; + + strcpy( fname_in , "" ) ; + + rlim.rlim_cur = RLIM_INFINITY ; + rlim.rlim_max = RLIM_INFINITY ; + + setrlimit ( RLIMIT_STACK , &rlim ) ; + + sym_forget() ; + thisprog = *argv ; + while (*argv) { + if (*argv[0] == '-') { /* an option */ + if (!strncmp(*argv,"-D",2)) { + char * p ; + p = *argv ; + sym_add(p+2) ; + } + + if (!strcmp(*argv,"-DDEREF_KLUDGE")) { + sw_deref_kludge = 1 ; + } + if (!strcmp(*argv,"-DIO_DEREF_KLUDGE")) { + sw_io_deref_kludge = 1 ; + } + if (!strcmp(*argv,"-DLIMIT_ARGS")) { + sw_limit_args = 1 ; + } + if (!strcmp(*argv,"-DMOVE_NESTS")) { + sw_move = 1 ; + } + if (!strcmp(*argv,"-DIFORT_KLUDGE")) { + sw_ifort_kludge = 1 ; + } + if (!strcmp(*argv,"-DD3VAR_IRY_KLUDGE")) { +#if 0 + sw_3dvar_iry_kludge = 1 ; +#else + fprintf(stderr,"WARNING: -DD3VAR_IRY_KLUDGE option obsolete (it is now disabled by default). Ignored.\n") ; +#endif + } + if (!strcmp(*argv,"-DALL_X_STAGGERED")) { + sw_all_x_staggered = 1 ; + } + if (!strcmp(*argv,"-DALL_Y_STAGGERED")) { + sw_all_y_staggered = 1 ; + } + if (!strcmp(*argv,"-DDM_PARALLEL")) { + sw_dm_parallel = 1 ; + } + if (!strcmp(*argv,"-DNEW_BDYS")) { + sw_new_bdys = 1 ; + } + if (!strcmp(*argv,"-DNEW_WITH_OLD_BDYS")) { + sw_new_with_old_bdys = 1 ; + } + if (!strcmp(*argv,"-DDISTRIB_IO_LAYER")) { +#if 0 + sw_distrib_io_layer = 1 ; +#else + fprintf(stderr,"WARNING: -DDISTRIB_IO_LAYER option obsolete (it is now default). Ignored.\n") ; +#endif + } + if (!strcmp(*argv,"-DDM_SERIAL_IN_ONLY")) { + sw_dm_serial_in_only = 1 ; + } + if (!strncmp(*argv,"-h",2)) { + fprintf(stderr,"Usage: %s [-DDEREF_KLUDGE] [-DDM_PARALLEL] [-DDISTRIB_IO_LAYER] [-DDM_SERIAL_IN_ONLY] [-DD3VAR_IRY_KLUDGE] registryfile\n",thisprog) ; + exit(1) ; + } + } + else /* consider it an input file */ + { + strcpy( fname_in , *argv ) ; + } + argv++ ; + } + + init_parser() ; + init_type_table() ; + init_dim_table() ; + init_core_table() ; + + if ( !strcmp(fname_in,"") ) fp_in = stdin ; + else + if (( fp_in = fopen( fname_in , "r" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open %s for reading. Ending.\n", fname_in ) ; + exit(2) ; + } + + sprintf( fname_tmp , "Registry_tmp.%d",mypid) ; + if (( fp_tmp = fopen( fname_tmp , "w" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open temporary %s for writing. Ending.\n", fname_tmp ) ; + exit(2) ; + } + + { char *e ; + strcpy( dir , fname_in ) ; + if ( ( e = rindex ( dir , '/' ) ) != NULL ) { *e = '\0' ; } else { strcpy( dir, "." ) ; } + } + if ( pre_parse( dir, fp_in, fp_tmp ) ) { + fprintf(stderr,"Problem with Registry File %s\n", fname_in ) ; + goto cleanup ; + } + sym_forget() ; + + fclose(fp_in) ; + fclose(fp_tmp) ; + + if (( fp_tmp = fopen( fname_tmp , "r" )) == NULL ) + { + fprintf(stderr,"Registry program cannot open %s for reading. Ending.\n", fname_tmp ) ; + goto cleanup ; + } + + reg_parse(fp_tmp) ; + + fclose(fp_tmp) ; + + check_dimspecs() ; + + gen_state_struct( "inc" ) ; + gen_state_subtypes( "inc" ) ; + gen_alloc( "inc" ) ; + gen_dealloc( "inc" ) ; + gen_scalar_indices( "inc" ) ; + gen_module_state_description( "frame" ) ; + gen_actual_args( "inc" ) ; + gen_actual_args_new( "inc" ) ; + gen_dummy_args( "inc" ) ; + gen_dummy_args_new( "inc" ) ; + gen_dummy_decls( "inc" ) ; + gen_dummy_decls_new( "inc" ) ; + gen_i1_decls( "inc" ) ; + gen_namelist_statements("inc") ; + gen_namelist_defines ( "inc", 0 ) ; /* without dimension statements */ + gen_namelist_defines ( "inc", 1 ) ; /* with dimension statements */ + gen_namelist_defaults ( "inc" ) ; + gen_get_nl_config( "inc" ) ; + gen_config_assigns( "inc" ) ; + gen_config_reads( "inc" ) ; + gen_wrf_io( "inc" ) ; + gen_model_data_ord( "inc" ) ; + gen_nest_interp( "inc" ) ; + gen_scalar_derefs( "inc" ) ; + +#if 1 + system( "touch inc/em_nest_feedbackup_smooth.inc" ) ; + system( "touch inc/em_nest_feedbackup_unpack.inc" ) ; +#endif + + +/* this has to happen after gen_nest_interp, which adds halos to the AST */ + gen_comms( "inc" ) ; /* this is either package supplied (by copying a */ + /* gen_comms.c file into this directory) or a */ + /* stubs routine. */ + +cleanup: + sprintf(command,"/bin/rm -f %s\n",fname_tmp ); + system( command ) ; + +} + diff --git a/wrfv2_fire/tools/registry.h b/wrfv2_fire/tools/registry.h new file mode 100644 index 00000000..95bed994 --- /dev/null +++ b/wrfv2_fire/tools/registry.h @@ -0,0 +1,77 @@ +#ifndef REGISTRY_H +#define NAMELEN 512 +#define NAMELEN_LONG 8192 +#define MAXDIMS 21 +#define MAX_DYNCORES 50 /* ha ha, just kidding */ +/* #define MAX_ARGLINE 175 WRF uses 128 by default, but the nested chem version hit the continuation line limit for efc so it had to be increased, wig 14-Oct-2004 */ +#define MAX_ARGLINE 128 /* welp, 175 means lines longer than 130 chars, which is a Fortran no no */ +#define MAX_TYPEDEFS 50 /* typedef history -ajb */ + +/* defines of system commands */ +#define UNIQSORT "/bin/sort -u" +#define CATCOMM "/bin/cat" +#define RMCOMM "/bin/rm" +#define MVCOMM "/bin/mv" + +#define DRIVER_LAYER 100 +#define MEDIATION_LAYER 200 + +enum coord_axis { COORD_X , COORD_Y , COORD_Z , COORD_C } ; +enum len_defined_how { DOMAIN_STANDARD , NAMELIST , CONSTANT } ; +enum type_type { SIMPLE , DERIVED } ; +enum proc_orient { ALL_Z_ON_PROC , ALL_X_ON_PROC , ALL_Y_ON_PROC } ; + +/* node_kind mask settings */ +#define FIELD 1 +#define I1 2 +#define RCONFIG 4 +#define FOURD 8 +#define MEMBER 16 +#define TYPE 32 +#define DIM 64 +#define PACKAGE 128 +#define HALO 256 +#define PERIOD 512 +#define SWAP 1024 +#define CYCLE 2048 +#define XPOSE 4096 +#define FOURD1 8192 +#define BDYONLY 16384 + +/* I/O mask settings bit */ +#define HISTORY 0x00000002 /* 1 */ +#define AUXHIST1 0x00000004 /* 2 */ +#define AUXHIST2 0x00000008 /* 3 */ +#define AUXHIST3 0x00000010 /* 4 */ +#define AUXHIST4 0x00000020 /* 5 */ +#define AUXHIST5 0x00000040 /* 6 */ +#define AUXHIST6 0x00000080 /* 7 */ +#define AUXHIST7 0x00000100 /* 8 */ +#define AUXHIST8 0x00000200 /* 9 */ +#define AUXHIST9 0x00000400 /* 0 */ +#define AUXHIST10 0x00000800 /* 11 */ +#define AUXHIST11 0x00001000 /* 12 */ +#define INPUT 0x00002000 /* 13 */ +#define AUXINPUT1 0x00004000 /* 14 */ +#define AUXINPUT2 0x00008000 /* 15 */ +#define AUXINPUT3 0x00010000 /* 16 */ +#define AUXINPUT4 0x00020000 /* 17 */ +#define AUXINPUT5 0x00040000 /* 18 */ +#define AUXINPUT6 0x00080000 /* 19 */ +#define AUXINPUT7 0x00100000 /* 10 */ +#define AUXINPUT8 0x00200000 /* 21 */ +#define AUXINPUT9 0x00400000 /* 22 */ +#define AUXINPUT10 0x00800000 /* 23 */ +#define AUXINPUT11 0x01000000 /* 24 */ +#define RESTART 0x02000000 /* 25 */ +#define BOUNDARY 0x04000000 /* 26 */ +#define INTERP_DOWN 0x08000000 /* 27 */ +#define FORCE_DOWN 0x10000000 /* 28 */ +#define INTERP_UP 0x20000000 /* 29 */ +#define SMOOTH_UP 0x40000000 /* 20 */ +#define METADATA 0x80000000 /* 31 */ + + +#define REGISTRY_H +#endif + diff --git a/wrfv2_fire/tools/regtest.csh b/wrfv2_fire/tools/regtest.csh new file mode 100644 index 00000000..416cc5e7 --- /dev/null +++ b/wrfv2_fire/tools/regtest.csh @@ -0,0 +1,3071 @@ +#!/bin/csh +# @ job_type = parallel +# @ environment = COPY_ALL;MP_EUILIB=us +# @ job_name = regtest.$(jobid) +# @ output = regtest_out +# @ error = regtest_err +# @ network.MPI = csss,shared,us +# @ node_usage = shared +# @ checkpoint = no +# @ wall_clock_limit = 21600 +# @ node = 1 +# @ total_tasks = 4 +################### NCAR ######################## +# @ ja_report = yes +# @ class = share +################### NCAR ######################## +################### NCEP ######################## +## @ class = dev +## @ group = devqpri +## @ preferences = Feature == "dev" +################### NCEP ######################## +# @ queue + +# #BSUB -x # exlusive use of node (not_shared) +# #BSUB -a mpich_gm # at NCAR: lightning +# #BSUB -R "span[ptile=2]" # how many tasks per node (1 or 2) +#BSUB -a poe # at NCAR: bluevista +#BSUB -R "span[ptile=4]" # how many tasks per node (up to 8) +#BSUB -n 4 # number of total tasks +#BSUB -o reg.out # output filename (%J to add job id) +#BSUB -e reg.err # error filename +#BSUB -J reg.test # job name +#BSUB -q premium # queue +#BSUB -W 6:00 # wallclock time +#BSUB -P 64000400 + +# QSUB -q ded_4 # submit to 4 proc +# QSUB -l mpp_p=4 # request 4 processors +# QSUB -lT 21600 # max. job time limit is 6 h +# QSUB -lF 250Mw # max. job file size limit is 250 Megawords +# QSUB -eo # merge error and output into one file +# QSUB -o reg.out # output file name +# QSUB # there are no further QSUB commands + +# This is a script to test the bit-for-bit reproducibility of +# the WRF model, when comparing single processor serial runs to +# OpenMP and MPI parallel runs. There are several regression tests +# that are performed. Failed comparisons get reported, but don't +# stop the script. Failed builds or forecasts force an exit from +# the script. + +# Approximate time for completion of full test suite +# Compaq 733 MHz ev67 : 2.5 hours (empty) +# Intel 1.2 GHz (4-pe) : 3.0 hours (empty) +# IBM P4 : 2.0 hours (empty) + +# These need to be changed for your particular set of runs. This is +# where email gets sent. + +if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + set FAIL_MAIL = ( ${user}@noaa.gov ) + set GOOD_MAIL = ( ${user}@noaa.gov ) + + setenv MP_EAGER_LIMIT 65536 + setenv MP_SHARED_MEMORY yes + setenv MP_SINGLE_THREAD yes + setenv MP_LABELIO yes + setenv MP_STDOUTMODE ordered + + setenv OMP_NUM_THREADS 4 + setenv XLSMPOPTS "parthds=4:spins=0:yields=0:stack=128000000:schedule=static" + setenv AIXTHREAD_SCOPE S + setenv AIXTHREAD_MNRATIO 1:1 + setenv SPINLOOPTIME 1000 + setenv YIELDLOOPTIME 1000 +else + set FAIL_MAIL = ( ${user}@ucar.edu ) + set GOOD_MAIL = ( ${user}@ucar.edu ) +endif + +unalias cd cp rm ls pushd popd mv +if ( `uname` == Linux ) alias banner echo + +# Get the command line input + +set thedate = -999 +set thefile = "null" +set thedata = "null" +set clrm = 0 # compile local run mmmtmp, for using clsroom cluster and local disk + +# If this is a batch job (NCAR's IBMs or FSL's Intel and Alpha), we need to muck with the "input" +# parameters a bit. + +if ( ( `uname` == AIX ) || ( `hostname` == tempest ) || ( `hostname | cut -c 1-2` == ln ) ) then + set argv = ( -here ) + set argv = ( -ftp ) + set argv = ( -D today ) + set argv = ( -env ) + set WRFREGFILE = /mmm/users/gill/wrf.tar + if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + set argv = ( -f /nbns/meso/wx22tb/regression_tests/wrf.tar ) + else + set argv = ( -f wrf.tar ) + endif +else if ( ( `uname` == OSF1 ) && ( `hostname` == maple ) && ( $user == michalak ) ) then + set clrm=1 +endif + +# Where is the input data located - for a few known NCAR/MMM machines. + +if ( ( `hostname` == master ) || (`hostname | cut -c 1-4` == node ) ) then + set WRFREGDATAEM = /big/users/gill/WRF-data-EM + set WRFREGDATANMM = /big/users/gill/WRF-data-NMM +else if ( `hostname` == jacaranda ) then + set WRFREGDATAEM = /jacaranda/users/gill/WRF-data-EM + set WRFREGDATANMM = /jacaranda/users/gill/WRF-data-NMM +else if ( `hostname` == duku ) then + set WRFREGDATAEM = /duku/users/gill/WRF-data-EM + set WRFREGDATANMM = /duku/users/gill/WRF-data-NMM +else if ( `hostname` == cape ) then + set WRFREGDATAEM = /cape/users/michalak/WRF-data-EM + set WRFREGDATANMM = /cape/users/michalak/WRF-data-NMM +else if ( (`hostname | cut -c 1-6` == joshua ) || \ + ( `hostname` == maple ) || (`hostname | cut -c 1-7` == service ) ) then + set WRFREGDATAEM = /users/gill/WRF-data-EM + set WRFREGDATANMM = /users/gill/WRF-data-NMM +else if ( ( `hostname | cut -c 1-2` == bs ) || ( `hostname` == tempest ) || ( `hostname | cut -c 1-2` == ln ) || \ + ( `hostname | cut -c 1-2` == bv ) ) then + set WRFREGDATAEM = /mmm/users/gill/WRF-data-EM + set WRFREGDATANMM = /mmm/users/gill/WRF-data-NMM +else if ( ( `uname` == AIX ) && ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) ) then + set WRFREGDATAEM = /nbns/meso/wx22tb/regression_tests/WRF-data-EM + set WRFREGDATANMM = /nbns/meso/wx22tb/regression_tests/WRF-data-NMM +else + if ( ( -d /users/gill/WRF-data-EM ) && ( -d /users/gill/WRF-data-NMM ) ) then + set WRFREGDATAEM = /users/gill/WRF-data-EM + set WRFREGDATANMM = /users/gill/WRF-data-NMM + else if ( ( -d /mmm/users/gill/WRF-data-EM ) && ( -d /mmm/users/gill/WRF-data-NMM ) ) then + set WRFREGDATAEM = /mmm/users/gill/WRF-data-EM + set WRFREGDATANMM = /mmm/users/gill/WRF-data-NMM + else + echo "stick the WRF em and nmm data somewhere, and then fill in the shell vars" + echo "inside this script, you NEED WRFREGDATAEM and WRFREGDATANMM set" + exit ( 1 ) + endif +endif +#DAVE################################################### +echo DAVE em data is located at $WRFREGDATAEM +ls -ls $WRFREGDATAEM +echo DAVE nmm data is located at $WRFREGDATANMM +ls -ls $WRFREGDATANMM +banner 1 +#set ans = "$<" +#DAVE################################################### + +if ( $#argv == 0 ) then + echo "Please enter either a date for cvs checkout. ex regtest.csh -D date" + echo " or a file name containing WRF. ex regtest.csh -f tarfile" + echo " or the -ftp flag for the script to pick code off anon ftp" + exit ( 2 ) +endif + +set theargs = 0 +foreach a ( $argv ) + if ( "$a" == "-D" ) then + + rsh -n maple.mmm.ucar.edu w >& /dev/null + if ( $status ) then + echo "Cannot execute a remote shell on maple.mmm.ucar.edu, where the" + echo "WRF code resides." + echo "Please check that it is up and that you have permission to rsh" + echo "to this host. (Create a .rhosts file)." + ping -c 1 maple.mmm.ucar.edu + exit 2 + endif + setenv CVSROOT maple.mmm.ucar.edu:/data3/mp/wrfhelp/WRF + + set acquire_from = "cvs" + set thedate = $argv[2] + + endif + + if ( "$a" == "-f" ) then + + set thefile = $argv[2] + # Check for absolute path, if not, make it absolute + echo $thefile | grep '^/' > /dev/null + if ( $status != 0 ) set thefile = `pwd`/$thefile + set acquire_from = "filearg" + + endif + + if ( "$a" == "-ftp" ) then + set acquire_from = "ftp" +echo "anon ftp temporarily disabled" +exit ( 3 ) + endif + + if ( "$a" == "-here" ) then + set acquire_from = "here" + endif + + if ( "$a" == "-env" ) then + set acquire_from = "environment" + set thefile = $WRFREGFILE + endif +end + +# Start recording everything - for debug purposes. + +set echo +set date + +# And to tell us how long we've spent on this whole regression test, +# we should remember when we started. + +set start = ( `date` ) + +##################################################################### + +# Initial set up values + +# Is this a single domain regression test or is this nested. Well, a nested one +# is a bit special. It can only run on machines that have the WRF RSL-but-no-MPI +# option available. + +set NESTED = TRUE +set NESTED = FALSE + +if ( ( $NESTED == TRUE ) && ( ( `uname` == OSF1 ) || ( `uname` == Linux ) || ( `uname` == AIX ) ) ) then + echo DOING a NESTED TEST +else if ( $NESTED == TRUE ) then + echo NESTED option is only valid on DEC, Linux, or AIX machines + exit ( 1 ) +endif + +# We can choose to do grid and obs nudging tests. + +set FDDA = TRUE +set FDDA = FALSE + +# The default floating point precision is either 4 bytes or 8 bytes. +# We assume that it is 4 (or the default for the architecture) unless +# REAL8 is set to TRUE. + +set REAL8 = TRUE +set REAL8 = FALSE + +# Are we shooting for a bit-for-bit run (serial vs OpenMP, serial vs MPI), or not? +# If you want to do a performance-only run, the forecasts are still short, but you +# get to insure that the optimized code builds and runs. + +set REG_TYPE = OPTIMIZED +set REG_TYPE = BIT4BIT + +# For a Linux machine, we can use PGI or Intel compilers. + +if ( `uname` == Linux ) then + set LINUX_COMP = INTEL + set LINUX_COMP = PGI +endif + +# Intel requires /usr/local/intel-8.0/lib in LD_LIBRARY_PATH +# and it has to be in the .cshrc file for the rsh for mpirun +# intel 8.0 Apr 2005 + +if ( `uname` == Linux ) then + if ( $LINUX_COMP == INTEL ) then + + grep LD_LIBRARY_PATH ~/.cshrc >& /dev/null + set ok1 = $status + echo $LD_LIBRARY_PATH | grep intel >& /dev/null + set ok2 = $status + if ( ( $ok1 != 0 ) || ( $ok2 != 0 ) ) then + echo You need to stick the following line in your .cshrc file + echo setenv LD_LIBRARY_PATH /usr/lib:/usr/local/lib:/usr/local/intel-8.0/lib + echo Otherwise mpirun cannot find libcxa.so.5 + exit ( 1 ) + endif + endif +endif + +# Is this a WRF chem test? + +if ( $NESTED != TRUE ) then + set CHEM = TRUE + set CHEM = FALSE +else if ( $NESTED == TRUE ) then + set CHEM = FALSE +endif +if ( $CHEM == TRUE ) then + setenv WRF_CHEM 1 +else if ( $CHEM == FALSE ) then + setenv WRF_CHEM 0 +endif + +# For the real data case, we can run either one of two data cases. If this is +# a chemistry run, we are forced to use that data. + +set dataset = jun01 +set dataset = jan00 +if ( $CHEM == TRUE ) then + set dataset = chem +endif + +# Yet another local variable to change the name of where the data is located. + +set thedataem = ${WRFREGDATAEM}/${dataset} +set thedatanmm = $WRFREGDATANMM + +# The distributed memory option RSL_LITE may be selected. + +set RSL_LITE = TRUE +set RSL_LITE = FALSE + +set COMBO_NEST_RSL__LITE = TRUE +set COMBO_NEST_RSL__LITE = FALSE + +if ( $COMBO_NEST_RSL__LITE == TRUE ) then + set NESTED = TRUE + set RSL_LITE = TRUE +endif + +# A separately installed version of the latest ESMF library (NOT the +# ESMF library included in the WRF tarfile) can be tested by setting +# "ESMF_LIB" to "TRUE" below. This test is not supported on all +# machines. + +set ESMF_LIB = TRUE +set ESMF_LIB = FALSE + +# serial and OMP are not tested with ESMF so always start with env vars cleared +unsetenv ESMFLIB +unsetenv ESMFINC + +if ( $ESMF_LIB == TRUE ) then + if ( ( `uname` == AIX ) && ( `hostname | cut -c 1-2` == bs ) ) then + echo "A separately installed version of the latest ESMF library" + echo "(NOT the ESMF library included in the WRF tarfile) will" + echo "be used for MPI tests" + setenv OBJECT_MODE 32 + set ESMFLIBSAVE = /home/bluesky/hender/esmf/lib/libO/AIX.default.32.default + set ESMFINCSAVE = /home/bluesky/hender/esmf/mod/modO/AIX.default.32.default + echo "Setting ESMFLIB = ${ESMFLIBSAVE}" + echo "Setting ESMFINC = ${ESMFINCSAVE}" + else + echo "Only the ESMF library included in the WRF tarfile is" + echo "tested on this machine" + exit ( 3 ) + endif + if ( $NESTED == TRUE ) then + echo "The ESMF library does not work with nesting." + exit ( 3 ) + endif + if ( $RSL_LITE == TRUE ) then + echo "The ESMF library does not work with RSL_LITE." + exit ( 3 ) + endif +endif + +# A single WRF output "quilt" server can be tested by setting "QUILT" to +# "TRUE" below. At the moment, testing of I/O quilt servers is not supported +# on all machines. + +set QUILT = TRUE +set QUILT = FALSE + +if ( $QUILT == TRUE ) then + if ( `uname` == AIX ) then + echo "One WRF output quilt server will be used for some tests" + else if ( ( `uname` == OSF1 ) && \ + ( ( `hostname` == duku ) || \ + ( `hostname` == joshua1 ) || \ + ( `hostname` == joshua3 ) ) ) then + echo "One WRF output quilt server will be used for some tests" + else + echo "WRF output quilt servers are not tested on this machine" + exit ( 3 ) + endif +endif + +# Baseline data sets can be generated and archived or compared against. +# - To generate and archive, set GENERATE_BASELINE to a pathname that can +# be created by this script via "mkdir -p $GENERATE_BASELINE". This +# directory must not already exist. +# Set GENERATE_BASELINE = FALSE to avoid baseline generation. +# - To compare with a previously archived baseline, set COMPARE_BASELINE +# to an existing directory that contains an archived baseline. +# Set COMPARE_BASELINE = FALSE to avoid baseline comparison. +set GENERATE_BASELINE = FALSE +set COMPARE_BASELINE = FALSE + +# Baseline generation and comparison are only done when BIT4BIT is set. +if ( $GENERATE_BASELINE != FALSE ) then + if ( $REG_TYPE != BIT4BIT ) then + echo "ERROR: Baseline generation can only be done during BIT4BIT tests." + exit ( 3 ) + endif + if ( -d $GENERATE_BASELINE ) then + echo "ERROR: Baseline directory ${GENERATE_BASELINE} already exists." + exit ( 3 ) + else + # Archive serial output file to baseline + mkdir -p $GENERATE_BASELINE || ( echo "ERROR: cannot mkdir ${GENERATE_BASELINE}"; exit 3 ) + endif +endif +if ( $COMPARE_BASELINE != FALSE ) then + if ( $REG_TYPE != BIT4BIT ) then + echo "Baseline comparison can only be done during BIT4BIT tests." + exit ( 3 ) + endif + if ( ! -d $COMPARE_BASELINE ) then + echo "${0}: ERROR: Baseline directory ${COMPARE_BASELINE} does not exist" + exit ( 3 ) + endif +endif + +# Set the input/output format type (currently 1, 2 or 5 OK). +# Binary NetCDF PHDF, IBM GriB, history only +# 1 2 3 4 5 + +set IO_FORM = 2 +set IO_FORM_NAME = ( io_bin io_netcdf io_dummy io_phdf5 io_grib1 ) +set IO_FORM_WHICH =( IO IO IO IO O ) + +# There is a breakdown of cores to test depending on the various +# options that the user is testing. +# nested: cannot test NMM +# rsl_lite: cannot test anything with y periodic bc +# chem: em_real only +# esmf_lib: cannot test NMM +# grib output: cannot test NMM + +if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set CORES = ( em_real em_b_wave em_quarter_ss ) +else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set CORES = ( em_real em_b_wave em_quarter_ss ) +else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set CORES = ( em_real em_b_wave em_quarter_ss nmm_real ) + if ( $CHEM == TRUE ) then + set CORES = ( em_real em_real ) + endif + if ( $ESMF_LIB == TRUE ) then + set CORES = ( em_real em_b_wave em_quarter_ss ) + endif + if ( $IO_FORM_NAME[$IO_FORM] == io_grib1 ) then + set CORES = ( em_real em_b_wave em_quarter_ss ) + endif + if ( $FDDA == TRUE ) then + set CORES = ( em_real ) + endif +else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set CORES = ( em_real em_b_wave em_quarter_ss nmm_real ) + if ( $CHEM == TRUE ) then + set CORES = ( em_real em_real ) + endif + if ( $ESMF_LIB == TRUE ) then + set CORES = ( em_real ) + endif + if ( $IO_FORM_NAME[$IO_FORM] == io_grib1 ) then + set CORES = ( em_real ) + endif + if ( $FDDA == TRUE ) then + set CORES = ( em_real ) + endif +endif + +# The b_wave case has binary input (4-byte only), the nmm +# core has raw MPI calls, skip them if we are doing real*8 floats. +# Bump up the OMP stack size for real*8 on OSF1 architectures. + +if ( $REAL8 == TRUE ) then + if ( `uname` == OSF1 ) then + setenv MP_STACK_SIZE 64000000 + endif + set CORES = ( em_real em_quarter_ss ) +endif + +if ( ( $CHEM != TRUE ) && ( $FDDA != TRUE ) && ( $NESTED != TRUE ) ) then + set PHYSOPTS = ( 1 2 3 4 5 ) +else if ( ( $CHEM != TRUE ) && ( $FDDA != TRUE ) && ( $NESTED == TRUE ) ) then + set PHYSOPTS = ( 1 2 3 ) +else if ( ( $CHEM != TRUE ) && ( $FDDA == TRUE ) ) then + set PHYSOPTS = ( 1 2 3 ) +else if ( $CHEM == TRUE ) then + set PHYSOPTS = ( 1 2 3 4 5 6 ) +endif + +# This is selecting the ideal physics options - mostly selecting BC options. +# With no nesting, run all three ideal physics options. When we have +# RSL_LITE (we are only doing em_quarter_ss), choose the first option only +# since it uses open boundaries. + +if ( $NESTED == TRUE ) then + set Max_Ideal_Physics_Options = 2 +else if ( $NESTED != TRUE ) then + set Max_Ideal_Physics_Options = 3 +endif + +set CUR_DIR = `pwd` + +# How many domains to run (nest tests). Only em_real and ideals use this. +# The max is 3 due to the number of columns in the namelist that are +# currently filled in. + +if ( $NESTED == TRUE ) then +if ( $dataset == jan00 ) then +cat >! dom_real << EOF + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 2, + s_we = 1, 1, 1, + e_we = 74, 31, 31, + s_sn = 1, 1, 1, + e_sn = 61, 31, 31, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + dx = 30000, 10000, 3333.333333, + dy = 30000, 10000, 3333.333333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 11, + j_parent_start = 0, 17, 11, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + num_moves = 3 + move_id = 2 , 2 , 2 + move_interval = 3 , 6 , 9 + move_cd_x = 1 , 1 , 1 + move_cd_y = 1 , 1 , 1 +EOF +else if ( $dataset == jun01 ) then +cat >! dom_real << EOF + time_step = 60, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 2, + s_we = 1, 1, 1, + e_we = 91, 31, 31, + s_sn = 1, 1, 1, + e_sn = 82, 31, 31, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + dx = 10000, 3333.333333, 1111.111111, + dy = 10000, 3333.333333, 1111.111111, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 30, 11, + j_parent_start = 0, 20, 11, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 + num_moves = 3 + move_id = 2 , 2 , 2 + move_interval = 1 , 2 , 3 + move_cd_x = 1 , 1 , 1 + move_cd_y = 1 , 1 , 1 +EOF +endif +cat >! dom_ideal << EOF + max_dom = 2, +EOF +else if ( $NESTED != TRUE ) then +if ( $dataset == jan00 ) then +cat >! dom_real << EOF + time_step = 180, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 74, 31, 31, + s_sn = 1, 1, 1, + e_sn = 61, 31, 31, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + dx = 30000, 10000, 3333, + dy = 30000, 10000, 3333, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 31, 30, + j_parent_start = 0, 17, 30, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 +EOF +else if ( $dataset == jun01 ) then +cat >! dom_real << EOF + time_step = 60, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 91, 31, 31, + s_sn = 1, 1, 1, + e_sn = 82, 31, 31, + s_vert = 1, 1, 1, + e_vert = 28, 28, 28, + dx = 10000, 3333.333333, 1111.111111, + dy = 10000, 3333.333333, 1111.111111, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 30, 11, + j_parent_start = 0, 20, 11, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 1, + smooth_option = 0 +EOF +endif +cat >! dom_ideal << EOF + max_dom = 1, +EOF +endif + +# The em_real entire physics namelist. Change what you want. + +cat >! phys_real_1 << EOF + mp_physics = 3, 3, 3, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 1, 1, 1, + radt = 30, 30, 30, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 1, 1, 1, + bl_pbl_physics = 1, 1, 1, + bldt = 0, 0, 0, + cu_physics = 1, 1, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 5, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, +EOF + +cat >! dyn_real_SAFE << EOF + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! dyn_real_1 << EOF + pd_moist = .true., .true., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! time_real_1 << EOF + auxinput1_inname = "met_em.d." +EOF + +cat >! phys_real_2 << EOF + mp_physics = 4, 4, 4, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 2, 2, 2, + radt = 30, 30, 30, + sf_sfclay_physics = 2, 2, 2, + sf_surface_physics = 2, 2, 2, + bl_pbl_physics = 2, 2, 2, + bldt = 0, 0, 0, + cu_physics = 2, 2, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 4, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, +EOF + +cat >! dyn_real_2 << EOF + pd_moist = .true., .true., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! time_real_2 << EOF + auxinput1_inname = "wrf_real_input_em.d." +EOF + +cat >! phys_real_3 << EOF + mp_physics = 5, 5, 5, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 2, 2, 2, + radt = 30, 30, 30, + sf_sfclay_physics = 2, 2, 2, + sf_surface_physics = 3, 3, 3, + bl_pbl_physics = 2, 2, 2, + bldt = 0, 0, 0, + cu_physics = 3, 3, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + surface_input_source = 1, + num_soil_layers = 6, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, +EOF + +cat >! dyn_real_3 << EOF + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! time_real_3 << EOF + auxinput1_inname = "met_em.d." +EOF + +cat >! phys_real_4 << EOF + mp_physics = 4, 4, 4, + ra_lw_physics = 1, 1, 1, + ra_sw_physics = 2, 2, 2, + radt = 30, 30, 30, + sf_sfclay_physics = 2, 2, 2, + sf_surface_physics = 2, 2, 2, + bl_pbl_physics = 2, 2, 2, + bldt = 0, 0, 0, + cu_physics = 2, 2, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + ucmcall = 1, + surface_input_source = 1, + num_soil_layers = 4, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, +EOF + +cat >! dyn_real_4 << EOF + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! time_real_4 << EOF + auxinput1_inname = "wrf_real_input_em.d." +EOF + +cat >! phys_real_5 << EOF + mp_physics = 4, 4, 4, + ra_lw_physics = 3, 3, 3, + ra_sw_physics = 3, 3, 3, + radt = 30, 30, 30, + sf_sfclay_physics = 2, 2, 2, + sf_surface_physics = 2, 2, 2, + bl_pbl_physics = 2, 2, 2, + bldt = 0, 0, 0, + cu_physics = 2, 2, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + ucmcall = 1, + surface_input_source = 1, + num_soil_layers = 4, + mp_zero_out = 0, + maxiens = 1, + maxens = 3, + maxens2 = 3, + maxens3 = 16, + ensdim = 144, + levsiz = 59 + paerlev = 29 + cam_abs_freq_s = 21600 + cam_abs_dim1 = 4 + cam_abs_dim2 = 28 +EOF + +cat >! dyn_real_5 << EOF + pd_moist = .false., .false., .false., + pd_scalar = .false., .false., .false., + pd_chem = .false., .false., .false., + pd_tke = .false., .false., .false., +EOF + +cat >! time_real_5 << EOF + auxinput1_inname = "met_em.d." +EOF + +cat >! fdda_real_1 << EOF + grid_fdda = 1, 1, 1, + gfdda_inname = "wrffdda_d", + gfdda_end_h = 24, 24, 24, + gfdda_interval_m = 360, 360, 360, + fgdt = 0, 0, 0, + if_no_pbl_nudging_uv = 0, 0, 1, + if_no_pbl_nudging_t = 0, 0, 1, + if_no_pbl_nudging_q = 0, 0, 1, + if_zfac_uv = 0, 0, 1, + k_zfac_uv = 10, 10, 1, + if_zfac_t = 0, 0, 1, + k_zfac_t = 10, 10, 1, + if_zfac_q = 0, 0, 1, + k_zfac_q = 10, 10, 1, + guv = 0.0003, 0.0003, 0.0003, + gt = 0.0003, 0.0003, 0.0003, + gq = 0.0003, 0.0003, 0.0003, + if_ramping = 1, + dtramp_min = 360.0, + io_form_gfdda = 2, +EOF + +cat >! fdda_real_time_1 << EOF +EOF + +cat >! fdda_real_2 << EOF + obs_nudge_opt = 1,1,1,1,1 + max_obs = 150000, + nobs_ndg_vars = 5, + nobs_err_flds = 9, + obs_nudge_wind = 1,1,1,1,1 + obs_coef_wind = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_temp = 1,1,1,1,1 + obs_coef_temp = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_mois = 1,1,1,1,1 + obs_coef_mois = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_rinxy = 240.,240.,180.,180,180 + obs_rinsig = 0.1, + obs_twindo = 40. + obs_npfi = 10, + obs_ionf = 2, + obs_idynin = 0, + obs_dtramp = 40., + obs_ipf_errob = .true. + obs_ipf_nudob = .true. + obs_ipf_in4dob = .true. +EOF + +cat >! fdda_real_time_2 << EOF + auxinput11_interval_s = 180 + auxinput11_end_h = 6 +EOF + +cat >! fdda_real_3 << EOF + grid_fdda = 1, 1, 1, + gfdda_inname = "wrffdda_d", + gfdda_end_h = 24, 24, 24, + gfdda_interval_m = 360, 360, 360, + fgdt = 0, 0, 0, + if_no_pbl_nudging_uv = 0, 0, 1, + if_no_pbl_nudging_t = 0, 0, 1, + if_no_pbl_nudging_q = 0, 0, 1, + if_zfac_uv = 0, 0, 1, + k_zfac_uv = 10, 10, 1, + if_zfac_t = 0, 0, 1, + k_zfac_t = 10, 10, 1, + if_zfac_q = 0, 0, 1, + k_zfac_q = 10, 10, 1, + guv = 0.0003, 0.0003, 0.0003, + gt = 0.0003, 0.0003, 0.0003, + gq = 0.0003, 0.0003, 0.0003, + if_ramping = 1, + dtramp_min = 360.0, + io_form_gfdda = 2, + obs_nudge_opt = 1,1,1,1,1 + max_obs = 150000, + nobs_ndg_vars = 5, + nobs_err_flds = 9, + obs_nudge_wind = 1,1,1,1,1 + obs_coef_wind = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_temp = 1,1,1,1,1 + obs_coef_temp = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_nudge_mois = 1,1,1,1,1 + obs_coef_mois = 6.E-4,6.E-4,6.E-4,6.E-4,6.E-4 + obs_rinxy = 240.,240.,180.,180,180 + obs_rinsig = 0.1, + obs_twindo = 40. + obs_npfi = 10, + obs_ionf = 2, + obs_idynin = 0, + obs_dtramp = 40., + obs_ipf_errob = .true. + obs_ipf_nudob = .true. + obs_ipf_in4dob = .true. +EOF + +cat >! fdda_real_time_3 << EOF + auxinput11_interval_s = 180 + auxinput11_end_h = 6 +EOF + +# Tested options for ideal case em_b_wave. Modifying these +# parameters is acceptable. Adding to these requires changes +# to the ideal namelist build below. + +cat >! phys_b_wave_1a << EOF + diff_opt = 1, + km_opt = 1, + damp_opt = 0, +EOF +cat >! phys_b_wave_1b << EOF + mp_physics = 1, 1, 1, +EOF +cat >! phys_b_wave_1c << EOF + non_hydrostatic = .true., .true., .true., +EOF + +cat >! phys_b_wave_2a << EOF + diff_opt = 1, + km_opt = 1, + damp_opt = 0, +EOF +cat >! phys_b_wave_2b << EOF + mp_physics = 1, 1, 1, +EOF +cat >! phys_b_wave_2c << EOF + non_hydrostatic = .false., .false., .false., +EOF + +cat >! phys_b_wave_3a << EOF + diff_opt = 1, + km_opt = 1, + damp_opt = 0, +EOF +cat >! phys_b_wave_3b << EOF + mp_physics = 2, 2, 2, +EOF +cat >! phys_b_wave_3c << EOF + non_hydrostatic = .false., .false., .false., +EOF + +# Tested options for ideal case em_quarter_ss. Modifying these +# parameters is acceptable. Adding to these requires changes +# to the ideal namelist build below. + +cat >! phys_quarter_ss_1a << EOF + diff_opt = 1, + km_opt = 1, + damp_opt = 0, +EOF +cat >! phys_quarter_ss_1b << EOF + mp_physics = 1, 1, 1, +EOF +cat >! phys_quarter_ss_1c << EOF + non_hydrostatic = .true., .true., .true., +EOF +cat >! phys_quarter_ss_1d << EOF + periodic_x = .false.,.false.,.false., + open_xs = .true., .false.,.false., + open_xe = .true., .false.,.false., + periodic_y = .false.,.false.,.false., + open_ys = .true., .false.,.false., + open_ye = .true., .false.,.false., +EOF + +cat >! phys_quarter_ss_2a << EOF + diff_opt = 2, + km_opt = 2, + damp_opt = 1, +EOF +cat >! phys_quarter_ss_2b << EOF + mp_physics = 1, 1, 1, +EOF +cat >! phys_quarter_ss_2c << EOF + non_hydrostatic = .true., .true., .true., +EOF +cat >! phys_quarter_ss_2d << EOF + periodic_x = .true., .false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .true., .false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., +EOF + +cat >! phys_quarter_ss_3a << EOF + diff_opt = 2, + km_opt = 3, + damp_opt = 1, +EOF +cat >! phys_quarter_ss_3b << EOF + mp_physics = 2, 2, 2, +EOF +cat >! phys_quarter_ss_3c << EOF + non_hydrostatic = .false., .false., .false., +EOF +cat >! phys_quarter_ss_3d << EOF + periodic_x = .true., .false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .true., .false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., +EOF + +if ( $IO_FORM_WHICH[$IO_FORM] == IO ) then +cat >! io_format << EOF + io_form_history = $IO_FORM + io_form_restart = $IO_FORM + io_form_input = $IO_FORM + io_form_boundary = $IO_FORM +EOF +else if ( $IO_FORM_WHICH[$IO_FORM] == I ) then +cat >! io_format << EOF + io_form_history = 2 + io_form_restart = 2 + io_form_input = $IO_FORM + io_form_boundary = $IO_FORM +EOF +else if ( $IO_FORM_WHICH[$IO_FORM] == O ) then +cat >! io_format << EOF + io_form_history = $IO_FORM + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 +EOF +endif + + +if ( $dataset == jun01 ) then + set filetag_real=2001-06-11_12:00:00 +else if ( $dataset == jan00 ) then + set filetag_real=2000-01-24_12:00:00 +else if ( $dataset == chem ) then + set filetag_real = ( 2006-04-06_00:00:00 2006-04-06_12:00:00 ) +endif + +set filetag_ideal=0001-01-01_00:00:00 +#DAVE################################################### +echo did phys, set date to $filetag_real +banner 2 +#set ans = "$<" +#DAVE################################################### + +##################################################################### + +# Set up info for particular architectures + +set ARCH = ( `uname` ) + +set ZAP_SERIAL = FALSE +set ZAP_OPENMP = FALSE +set SERIALRUNCOMMAND = +set OMPRUNCOMMAND = +set MPIRUNCOMMANDPOST = + +touch version_info +if ( $ARCH[1] == AIX ) then + set DEF_DIR = $home + set TMPDIR = /ptmp/$user + # keep stuff out of $HOME and /ptmp/$USER + # this allows multiple regressions tests to run simultaneously + # extend this to other machines later + if ( ( `hostname | cut -c 1-2` == bs ) && ( ! $?LOADL_JOB_NAME ) ) then + echo "${0}: ERROR:: This batch script must be submitted via" + echo "${0}: LoadLeveler on an AIX machine\!" + exit + else if ( `hostname | cut -c 1-2` == bs ) then + set job_id = `echo ${LOADL_JOB_NAME} | cut -f2 -d'.'` + set DEF_DIR = /ptmp/$user/wrf_regression.${job_id} + set TMPDIR = $DEF_DIR + if ( -d $DEF_DIR ) then + echo "${0}: ERROR:: Directory ${DEF_DIR} exists, please remove it" + exit ( 1 ) + else + mkdir -p $DEF_DIR + echo "See ${DEF_DIR}/wrftest.output and other files in ${DEF_DIR} for test results" + endif + set CUR_DIR = ${LOADL_STEP_INITDIR} + else if ( `hostname | cut -c 1-2` == bv ) then + set job_id = $LSB_JOBID + set DEF_DIR = /ptmp/$user/wrf_regression.${job_id} + set TMPDIR = $DEF_DIR + if ( -d $DEF_DIR ) then + echo "${0}: ERROR:: Directory ${DEF_DIR} exists, please remove it" + exit ( 1 ) + else + mkdir -p $DEF_DIR + echo "See ${DEF_DIR}/wrftest.output and other files in ${DEF_DIR} for test results" + endif + else if ( ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) && ( ! $?LOADL_JOB_NAME ) ) then + echo "${0}: ERROR:: This batch script must be submitted via" + echo "${0}: LoadLeveler on an AIX machine\!" + exit + else if ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) then + set job_id = `echo ${LOADL_JOB_NAME} | cut -f2 -d'.'` + set DEF_DIR = /ptmp/$user/wrf_regression.${job_id} + set TMPDIR = $DEF_DIR + if ( -d $DEF_DIR ) then + echo "${0}: ERROR:: Directory ${DEF_DIR} exists, please remove it" + exit ( 1 ) + else + mkdir -p $DEF_DIR + echo "See ${DEF_DIR}/wrftest.output and other files in ${DEF_DIR} for test results" + endif + set CUR_DIR = ${LOADL_STEP_INITDIR} + endif + if ( ! -d $TMPDIR ) mkdir $TMPDIR + set MAIL = /usr/bin/mailx + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 9 10 4 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 2 4 ) + else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 9 10 3 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 2 3 ) + endif + set Num_Procs = 4 + set OPENMP = $Num_Procs + setenv MP_PROCS $Num_Procs + setenv MP_RMPOOL 1 + if ( `hostname | cut -c 1-2` == bs ) then + set MPIRUNCOMMAND = poe + else if ( `hostname | cut -c 1-2` == bv ) then + set MPIRUNCOMMAND = mpirun.lsf + else if ( ( `hostname | cut -c 1-2` != bs ) && ( `hostname | cut -c 1-2` != bv ) ) then + set MPIRUNCOMMAND = poe + endif + if ( $CHEM == TRUE ) then + set ZAP_OPENMP = TRUE + else if ( $CHEM == FALSE ) then + set ZAP_OPENMP = FALSE + endif +# check compiler version, JM + lslpp -i | grep xlf | grep ' xlfcmp ' | head -1 + set xlfvers=`lslpp -i | grep xlf | grep ' xlfcmp ' | head -1 | awk '{print $2}' | sed 's/\...*$//'` + if ( $xlfvers < 10 ) then + set ZAP_OPENMP = TRUE + endif +# end of compiler check, JM + echo "Compiler version info: " >! version_info + echo "FORTRAN: " `lslpp -l | grep xlfrte | head -1 | awk '{print $1 " " $2}'` >>! version_info + echo " " >>! version_info + echo "OS version info: " >>! version_info + echo "AIX: " `lslpp -l | grep bos.mp | head -1 | awk '{print $1 " " $2}'` >>! version_info + echo " " >>! version_info + setenv MP_SHARED_MEMORY yes +else if ( $ARCH[1] == OSF1 && $clrm == 0 ) then + if ( ( `hostname` == duku ) && ( -d /data1/$user ) ) then + set DEF_DIR = /data1/$user + else if ( ( `hostname | cut -c 1-6` == joshua ) && ( -d /data3/mp/$user ) ) then + set DEF_DIR = /data3/mp/${user}/`hostname` + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + else if ( ( `hostname | cut -c 1-6` == joshua ) && ( -d /data6a/md/$user ) ) then + set DEF_DIR = /data6a/md/${user}/`hostname` + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + else + set DEF_DIR = /mmmtmp/${user}/`hostname` + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + endif + set TMPDIR = . + set MAIL = /usr/bin/mailx + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 2 4 6 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 3 6 ) + else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 2 4 5 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 3 5 ) + endif + set Num_Procs = 4 + set OPENMP = $Num_Procs + cat >! `pwd`/machfile << EOF +`hostname` +`hostname` +`hostname` +`hostname` +EOF + set Mach = `pwd`/machfile + set SERIALRUNCOMMAND = + set OMPRUNCOMMAND = + set MPIRUNCOMMAND = ( /usr/local/mpich/bin/mpirun -np $Num_Procs -machinefile $Mach ) + if ( $CHEM == TRUE ) then + set ZAP_OPENMP = TRUE + else if ( $CHEM == FALSE ) then + set ZAP_OPENMP = FALSE + endif + echo "Compiler version info: " >! version_info + f90 -version >>&! version_info + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( $ARCH[1] == OSF1 && $clrm == 1 ) then + set DEF_DIR = /`hostname | cut -d. -f1`/$user + set TMPDIR = /mmmtmp/$user + set MAIL = /usr/bin/mailx + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 2 4 6 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 3 6 ) + else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 2 4 5 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 3 5 ) + endif + set Num_Procs = 4 + set OPENMP = 0 + set ZAP_OPENMP = TRUE + cat >! $TMPDIR/machfile << EOF +service03 +service04 +service05 +service06 +EOF + set Mach = $TMPDIR/machfile + set MPIRUNCOMMAND = ( mpirun -np $Num_Procs -machinefile $Mach ) + echo "Compiler version info: " >! version_info + f90 -version >>&! version_info + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( ( $ARCH[1] == Linux ) && ( `hostname` == bay-mmm ) ) then + set DEF_DIR = /data3/mp/${user}/`hostname` + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + set TMPDIR = . + set MAIL = /bin/mail + if ( $LINUX_COMP == PGI ) then + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 2 4 5 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 3 5 ) + else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 2 4 6 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 3 6 ) + endif + else if ( $LINUX_COMP == INTEL ) then + if ( $NESTED == TRUE ) then + set COMPOPTS = ( 8 10 11 ) + else if ( $NESTED != TRUE ) then + set COMPOPTS = ( 7 9 11 ) + endif + endif + set Num_Procs = 2 + set OPENMP = $Num_Procs + cat >! machfile << EOF +`hostname` +`hostname` +`hostname` +`hostname` +EOF + set Mach = `pwd`/machfile + if ( $CHEM == TRUE ) then + set ZAP_OPENMP = TRUE + else if ( $CHEM == FALSE ) then + set ZAP_OPENMP = FALSE + endif + if ( $LINUX_COMP == INTEL ) then + set ZAP_OPENMP = TRUE + endif + set MPIRUNCOMMAND = ( mpirun -np $Num_Procs -machinefile $Mach ) + echo "Compiler version info: " >! version_info + if ( $LINUX_COMP == PGI ) then + pgf90 -V >>&! version_info + else if ( $LINUX_COMP == INTEL ) then + ifort -v >>&! version_info + endif + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( ( $ARCH[1] == Linux ) && ( `hostname | cut -c 1-2` == ln ) ) then + set DEF_DIR = /ptmp/${user}/wrf_regtest + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + set TMPDIR = . + set MAIL = /bin/mail + if ( $LINUX_COMP == PGI ) then + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 4 2 3 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 2 3 ) + endif + endif + set Num_Procs = 4 + set OPENMP = 2 + cat >! machfile << EOF +`hostname` +`hostname` +`hostname` +`hostname` +EOF + set Mach = `pwd`/machfile + set ZAP_OPENMP = TRUE + set MPIRUNCOMMAND = mpirun.lsf + echo "Compiler version info: " >! version_info + if ( $LINUX_COMP == PGI ) then + pgf90 -V >>&! version_info + else if ( $LINUX_COMP == INTEL ) then + ifort -v >>&! version_info + endif + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( ( $ARCH[1] == Linux ) && ( `hostname` == loquat ) ) then + set job_id = $$ + set DEF_DIR = /loquat2/$user/wrf_regression.${job_id} + set TMPDIR = $DEF_DIR + if ( -d $DEF_DIR ) then + echo "${0}: ERROR:: Directory ${DEF_DIR} exists, please remove it" + exit ( 1 ) + else + mkdir -p $DEF_DIR + echo "See directory ${DEF_DIR}/ for wrftest.output and other test results" + endif + set MAIL = /bin/mail + if ( $LINUX_COMP == PGI ) then + if ( ( $NESTED == TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 2 4 5 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 3 5 ) + else if ( ( $NESTED == TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 2 4 6 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 3 6 ) + endif + else if ( $LINUX_COMP == INTEL ) then + if ( $NESTED == TRUE ) then + set COMPOPTS = ( 8 10 11 ) + else if ( $NESTED != TRUE ) then + set COMPOPTS = ( 7 9 11 ) + endif + endif + set Num_Procs = 2 + set OPENMP = $Num_Procs + cat >! machfile << EOF +`hostname` +`hostname` +`hostname` +`hostname` +EOF + set Mach = `pwd`/machfile + if ( $CHEM == TRUE ) then + set ZAP_OPENMP = TRUE + else if ( $CHEM == FALSE ) then + set ZAP_OPENMP = FALSE + endif + if ( $LINUX_COMP == INTEL ) then + set ZAP_OPENMP = TRUE + endif + set MPIRUNCOMMAND = ( mpirun -np $Num_Procs -machinefile $Mach ) + echo "Compiler version info: " >! version_info + if ( $LINUX_COMP == PGI ) then + pgf90 -V >>&! version_info + else if ( $LINUX_COMP == INTEL ) then + ifort -v >>&! version_info + endif + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( `hostname` == tempest ) then + set DEF_DIR = /ptmp/${user}/wrf_regtest.${QSUB_REQID} + if ( ! -d $DEF_DIR ) mkdir $DEF_DIR + set TMPDIR = . + set MAIL = /usr/sbin/Mail + set COMPOPTS = ( 1 2 3 ) + set Num_Procs = 2 + set OPENMP = $Num_Procs + set Mach = `pwd`/machfile + set ZAP_OPENMP = TRUE + set MPIRUNCOMMAND = ( mpirun -np $Num_Procs ) + echo "Compiler version info: " >! version_info + f90 -version >>&! version_info + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else if ( ( $ARCH[1] == Linux ) && ( `hostname` == master ) ) then + set DEF_DIR = /big6/gill/DO_NOT_REMOVE_DIR + set TMPDIR = . + set MAIL = /bin/mail + if ( $LINUX_COMP == PGI ) then + if ( $NESTED == TRUE ) then + set COMPOPTS = ( 2 4 5 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE == TRUE ) ) then + set COMPOPTS = ( 1 3 6 ) + else if ( ( $NESTED != TRUE ) && ( $RSL_LITE != TRUE ) ) then + set COMPOPTS = ( 1 3 5 ) + endif + else if ( $LINUX_COMP == INTEL ) then + if ( $NESTED == TRUE ) then + set COMPOPTS = ( 8 10 11 ) + else if ( $NESTED != TRUE ) then + set COMPOPTS = ( 7 9 11 ) + endif + endif + set Num_Procs = 4 + set OPENMP = 2 + cat >! machfile << EOF +node3 +node3 +node4 +node4 +EOF + set Mach = `pwd`/machfile + if ( $CHEM == TRUE ) then + set ZAP_OPENMP = TRUE + else if ( $CHEM == FALSE ) then + set ZAP_OPENMP = FALSE + endif + if ( $LINUX_COMP == INTEL ) then + set ZAP_OPENMP = TRUE + endif + set MPIRUNCOMMAND = ( mpirun -v -np $Num_Procs -machinefile $Mach -nolocal ) + set MPIRUNCOMMANDPOST = "< /dev/null" + echo "Compiler version info: " >! version_info + if ( $LINUX_COMP == PGI ) then + pgf90 -V >>&! version_info + else if ( $LINUX_COMP == INTEL ) then + ifort -v >>&! version_info + endif + echo " " >>! version_info + echo "OS version info: " >>! version_info + uname -a >>&! version_info + echo " " >>! version_info +else + echo "Unrecognized architecture for regression test" >! error_message + echo `uname` >> error_message + echo `hostname` >> error_message + $MAIL -s "Unknown architecture $ARCH[1] " $FAIL_MAIL < error_message + exit ( 1 ) +endif + +##################################################################### +#DAVE################################################### +echo did the arch specific stuff +banner 3 +#set ans = "$<" +#DAVE################################################### + +# First of all, in which particular directory do we start. + +cd $DEF_DIR + +# We want to keep the old regression stuff around + +if ( -d regression_test ) then + if ( -d regression_test.old ) then + /bin/rm -fr regression_test.old + endif + /bin/mv regression_test regression_test.old +endif + +# Go to the regression test directory + +mkdir regression_test +set ok = $status +if ( $ok != 0 ) then + echo "Gee, I cannot make a directory in $DEF_DIR" >! error_message + echo `pwd` >> error_message + echo `\ls -ls` >> error_message + $MAIL -s "$DEF_DIR not writable $ARCH[1] " $FAIL_MAIL < error_message + exit ( 1 ) +else + pushd regression_test +endif + +if ( $acquire_from == "cvs" ) then + + # Checkout the most recent version of WRF from the NCAR cvs repository, + # and pick up the required input data from the anonymous ftp site. + + cvs checkout -D $thedate WRFV2 + find ./WRFV2 -exec touch \{\} \; + ftp -n ftp.ucar.edu < ftp_script_data + + +else if ( $acquire_from == "filearg" ) then + + # A tar file of the WRF source was provided, so that is used, along with + # the required input data files from the ftp site. + + tar xvf $thefile + cd WRFV2 + clean -a + cd .. + ftp -n ftp.ucar.edu < ftp_script_data + +else if ( $acquire_from == "environment" ) then + + # A tar file of WRF is assumed to be available. + + tar xvf $thefile + +endif + +# And we can stick the input data where we want, the WRFV2 directory has been created. + +( cd WRFV2/test/em_real ; ln -sf $thedataem/* . ) +( cd WRFV2/test/nmm_real ; ln -s $thedatanmm/wrf_real* . ; cp $thedatanmm/namelist.input.regtest . ) +#DAVE################################################### +( cd WRFV2/test/em_real ; ls -ls ) +( cd WRFV2/test/nmm_real ; ls -ls ) +banner 4 +#set ans = "$<" +#DAVE################################################### + +# John-specific stuff for maple is the else; part of the "using service machines". + +if ( ! $clrm ) then + pushd WRFV2 +else + if ( ! -d $TMPDIR ) then + echo something wrong 1 + endif + if ( ! -d $TMPDIR/RUN ) then + mkdir $TMPDIR/RUN + /bin/rm -fr $TMPDIR/RUN/* + endif + if ( -d $TMPDIR/RUN ) then + tar cf - ./WRFV2/test ./WRFV2/main | ( cd $TMPDIR/RUN ; tar xvf - ) + pushd WRFV2 + else + echo something wrong 2 + exit + endif +endif + +# Here we initialize our output message. + +if ( -e ${DEF_DIR}/wrftest.output ) rm ${DEF_DIR}/wrftest.output +echo "Architecute: $ARCH[1] machine: `hostname`" >>! ${DEF_DIR}/wrftest.output +echo "WRFV2 source from: $acquire_from " >>! ${DEF_DIR}/wrftest.output +echo "Number of OpenMP processes to use: $OPENMP" >>! ${DEF_DIR}/wrftest.output +echo "Number of MPI processes to use: $Num_Procs" >>! ${DEF_DIR}/wrftest.output +set name = ( `grep ^${user}: /etc/passwd | cut -d: -f5` ) +echo "Test conducted by $name" >>! ${DEF_DIR}/wrftest.output +echo " " >>! ${DEF_DIR}/wrftest.output +echo "Test run from directory ${CUR_DIR}" >>! ${DEF_DIR}/wrftest.output +echo " " >>! ${DEF_DIR}/wrftest.output +if ( $?LOADL_JOB_NAME ) then + echo "Loadlever job name = ${LOADL_JOB_NAME}" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +echo "Real data case for EM is from $dataset " >>! ${DEF_DIR}/wrftest.output +echo " " >>! ${DEF_DIR}/wrftest.output +echo "The em real and ideal forecasts will be nested: $NESTED " >>! ${DEF_DIR}/wrftest.output +echo " " >>! ${DEF_DIR}/wrftest.output +if ( $REG_TYPE == BIT4BIT ) then + echo "This is a bit-wise (traditional) regression test. " >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +else if ( $REG_TYPE == OPTIMIZED ) then + echo "This is a fully optimized regression test. " >>! ${DEF_DIR}/wrftest.output + echo "No inter-comparisons are made. " >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $REAL8 == TRUE ) then + echo "Floating point precision is 8-bytes" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $CHEM == TRUE ) then + echo "WRF_CHEM tests run for em_real core only, no other cores run" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $RSL_LITE == TRUE ) then + echo "Parallel DM portion using RSL_LITE build option" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +else if ( $RSL_LITE != TRUE ) then + echo "Parallel DM portion using RSL build option" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $ESMF_LIB == TRUE ) then + echo "A separately installed version of the latest ESMF library" >>! ${DEF_DIR}/wrftest.output + echo "(NOT the ESMF library included in the WRF tarfile) will" >>! ${DEF_DIR}/wrftest.output + echo "be used for MPI tests" >>! ${DEF_DIR}/wrftest.output + echo "Setting ESMFLIB = ${ESMFLIBSAVE}" >>! ${DEF_DIR}/wrftest.output + echo "Setting ESMFINC = ${ESMFINCSAVE}" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $QUILT == TRUE ) then + echo "One WRF output quilt server will be used for some tests" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $FDDA == TRUE ) then + echo "Running FDDA tests (grid=1, obs=2, grid+obs=3)" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $GENERATE_BASELINE != FALSE ) then + echo "WRF output will be archived in baseline directory ${GENERATE_BASELINE} for some tests" >>! \ + ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +if ( $COMPARE_BASELINE != FALSE ) then + echo "WRF output will be compared with files in baseline directory ${COMPARE_BASELINE} for some tests" >>! \ + ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif +echo "The selected I/O option is $IO_FORM ($IO_FORM_NAME[$IO_FORM])" >>! ${DEF_DIR}/wrftest.output +if ( $IO_FORM_WHICH[$IO_FORM] == IO ) then + echo "This option is for both input and history files" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +else if ( $IO_FORM_WHICH[$IO_FORM] == I ) then + echo "This option is for input files only" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +else if ( $IO_FORM_WHICH[$IO_FORM] == O ) then + echo "This option is for history files only" >>! ${DEF_DIR}/wrftest.output + echo " " >>! ${DEF_DIR}/wrftest.output +endif + +cat ${CUR_DIR}/version_info >>! ${DEF_DIR}/wrftest.output + +# There are three WRF em executables to be considered that can run in threaded and +# distributed memory. The 2d hills and 2d squall lines cannot be parallelized with +# MPI, and are therefore not considered in this shell. The nmm is only run with +# distributed memory (1 vs 4 procs). + +set first_time_in = TRUE +foreach core ( $CORES ) +#DAVE################################################### +echo doing core $core +banner 5 +#set ans = "$<" +#DAVE################################################### + + # Some sleight of hand is required for the chemistry tests because we need to + # build it twice. But normally, we only build with different real vs ideal, or em vs nmm. + # What to do, what to do? Well, we ask for em_real TWICE. The first time we build without chemistry + # activated, the second time with it activated. The first time, we do a single + # test, the second time through, we do the other 5 tests. + + if ( ( $CHEM == TRUE ) && ( ${#CORES} == 2 ) && ( $first_time_in == TRUE ) ) then + setenv WRF_CHEM 0 + set PHYSOPTS = ( 1 ) + set first_time_in = FALSE + else if ( ( $CHEM == TRUE ) && ( ${#CORES} == 2 ) && ( $first_time_in != TRUE ) ) then + setenv WRF_CHEM 1 + set PHYSOPTS = ( 2 3 4 5 6 ) + endif + + # Cores to test. + + set ZAP_SERIAL_FOR_THIS_CORE = FALSE + set ZAP_OPENMP_FOR_THIS_CORE = FALSE + if ( `echo $core | cut -c 1-2` == em ) then + setenv WRF_EM_CORE 1 + setenv WRF_NMM_CORE 0 + setenv WRF_COAMPS_CORE 0 + setenv WRF_EXP_CORE 0 + set ZAP_SERIAL_FOR_THIS_CORE = FALSE + set ZAP_OPENMP_FOR_THIS_CORE = FALSE + else if ( `echo $core | cut -c 1-3` == nmm ) then + setenv WRF_EM_CORE 0 + setenv WRF_NMM_CORE 1 + setenv WRF_COAMPS_CORE 0 + setenv WRF_EXP_CORE 0 + set ZAP_SERIAL_FOR_THIS_CORE = TRUE + set ZAP_OPENMP_FOR_THIS_CORE = TRUE + endif + + # Here we are looping over all of the various compilation configurations, + # such as serial only, OpenMP only, MPI only, etc. Each architecture + # has its own list of these options. We build each of the executables for + # this particular ${core}. + + foreach compopt ( $COMPOPTS ) +#DAVE################################################### +echo doing compile option $compopt +banner 6 +#set ans = "$<" +#DAVE################################################### + + # We sometimes are interested in bypassing the OpenMP option. + + if ( $compopt == $COMPOPTS[2] ) then + if ( $ZAP_OPENMP == TRUE || $ZAP_OPENMP_FOR_THIS_CORE == TRUE ) then + goto GOT_THIS_EXEC + endif + endif + + # NMM only runs parallel + if ( $compopt == $COMPOPTS[1] ) then + if ( $ZAP_SERIAL == TRUE || $ZAP_SERIAL_FOR_THIS_CORE == TRUE ) then + goto GOT_THIS_EXEC + endif + endif + + if ( `uname` == AIX ) goto BUILD_REGARDLESS + + # Did we already build this one? + + if ( $core == em_real ) then + if ( ( $compopt == $COMPOPTS[1] ) && \ + ( -e main/wrf_${core}.exe.$compopt ) && \ + ( -e main/real_${core}.exe.1 ) && \ + ( -e ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf ) ) then + goto GOT_THIS_EXEC + else if ( ( $compopt != $COMPOPTS[1] ) && \ + ( -e main/wrf_${core}.exe.$compopt ) && \ + ( -e ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf ) ) then + goto GOT_THIS_EXEC + endif + else + if ( ( $compopt == $COMPOPTS[1] ) && \ + ( -e main/wrf_${core}.exe.$compopt ) && \ + ( -e main/ideal_${core}.exe.1 ) && \ + ( -e ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf ) ) then + goto GOT_THIS_EXEC + else if ( ( $compopt != $COMPOPTS[1] ) && \ + ( -e main/wrf_${core}.exe.$compopt ) && \ + ( -e ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf ) ) then + goto GOT_THIS_EXEC + endif + endif + + BUILD_REGARDLESS: + + # The WRF configuration file works with a single integer + # input, which is the compiler option. By convention, option $COMPOPTS[1] is + # serial, $COMPOPTS[2] is OMP, and $COMPOPTS[3] is MPI. + + # Print info about use of separately installed ESMF library. + set esmf_lib_str = " - - - - - - - - - - - - - " + if ( $ESMF_LIB == TRUE ) then + # only test ESMF with MPI + if ( $compopt == $COMPOPTS[3] ) then + echo "A separately installed version of the latest ESMF library" >>! ${DEF_DIR}/wrftest.output + echo "(NOT the ESMF library included in the WRF tarfile) is" >>! ${DEF_DIR}/wrftest.output + echo "being used for this test of $core parallel $compopt..." >>! ${DEF_DIR}/wrftest.output + set esmf_lib_str = "using separate ESMF library" + setenv ESMFLIB $ESMFLIBSAVE + setenv ESMFINC $ESMFINCSAVE + else + unsetenv ESMFLIB + unsetenv ESMFINC + endif + endif + +#DAVE################################################### +echo start build mechanism +banner 7 +#set ans = "$<" +#DAVE################################################### + ./clean -a + echo $compopt | ./configure + + # Decide whether this a bit-for-bit run or an fully optimized run. We are just + # tinkering with the configure.wrf file optimization here. + + if ( $REG_TYPE == BIT4BIT ) then + if ( `uname` == AIX ) then + if ( ( $compopt == $COMPOPTS[1] ) || ( $compopt == $COMPOPTS[3] ) ) then + sed -e '/^OMP/d' -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#/-O0 /g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else + sed -e '/^OMP/s/noauto/noauto:noopt/' \ + -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#/-O0 /g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + endif + sed -e 's/-lmassv//g' -e 's/-lmass//g' -e 's/-DNATIVE_MASSV//g' -e '/^FCBASEOPTS/s/#//g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else if ( `uname` == Linux ) then + if ( ( $compopt == $COMPOPTS[1] ) || ( $compopt == $COMPOPTS[3] ) ) then + sed -e '/^OMP/d' -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#-g/-g/g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else + sed -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#-g/-g/g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + endif + sed -e '/^#PGI /s/#PGI / /g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else if ( `uname` == OSF1 ) then + if ( ( $compopt == $COMPOPTS[1] ) || ( $compopt == $COMPOPTS[3] ) ) then + sed -e '/^OMP/d' -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/# -g/-O0/g' -e '/^FCDEBUG/s/# -O0/-O0/g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else + sed -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/# -g/-O0/g' -e '/^FCDEBUG/s/# -O0/-O0/g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + endif + else + if ( ( $compopt == $COMPOPTS[1] ) || ( $compopt == $COMPOPTS[3] ) ) then + sed -e '/^OMP/d' -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#//g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + else + sed -e '/^FCOPTIM/d' -e '/^FCDEBUG/s/#//g' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + endif + endif + endif + + # We also need to modify the configure.wrf file based on whether or not there is + # going to be nesting. All regtest em_real nesting runs utilize a moving nest. All of the + # ARCHFLAGS macros need to have -DMOVE_NESTS added to the list of options. + + if ( ( $NESTED == TRUE ) && ( $core == em_real ) ) then + sed -e '/^ARCHFLAGS/s/=/= -DMOVE_NESTS/' ./configure.wrf >! foo ; /bin/mv foo configure.wrf + endif + + # The configure.wrf file needs to be adjusted as to whether we are requesting real*4 or real*8 + # as the default floating precision. + + if ( $REAL8 == TRUE ) then + sed -e '/^RWORDSIZE/s/\$(NATIVE_RWORDSIZE)/8/' configure.wrf > ! foo ; /bin/mv foo configure.wrf + endif + +#DAVE################################################### +echo configure built with optim mods removed, ready to compile +banner 8 +#set ans = "$<" +#DAVE################################################### + + # The WRF_SRC_ROOT_DIR hack is only used by the OSF1 build. + # It works around the annoying fact that in OSF1 $(PWD) does + # not change during execution of regtest.csh, despite the "cd" + # and "pushd" commands. + setenv WRF_SRC_ROOT_DIR "${DEF_DIR}/regression_test/WRFV2" + # Build this executable + + ./compile $core +#DAVE################################################### +echo compile done +banner 9 +#set ans = "$<" +#DAVE################################################### + + # Did the compile work? Check the expected executable names and locations. + + set ok = $status + if ( ! -x main/wrf.exe ) set ok = 1 + + if ( ( $core == em_real ) && ( $compopt == $COMPOPTS[1] ) ) then + if ( ! -e main/real.exe ) set ok = 1 + else if ( ( $core == nmm_real ) && ( $compopt == $COMPOPTS[3] ) ) then + if ( ! -e main/real_nmm.exe ) set ok = 1 + else if ( $compopt == $COMPOPTS[1] ) then + if ( ! -e main/ideal.exe ) set ok = 1 + endif + + if ( ! -x external/io_netcdf/diffwrf ) set ok = 1 + if ( ! -x external/io_int/diffwrf ) set ok = 1 + + if ( $ok != 0 ) then + echo "SUMMARY compilation for $core parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "REGRESSION FAILURE $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 3 ) + else + echo "SUMMARY compilation for $core parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + mv main/wrf.exe main/wrf_${core}.exe.$compopt + if ( ( $core == em_real ) && ( $compopt == $COMPOPTS[1] ) ) then + mv main/real.exe main/real_${core}.exe.1 + else if ( ( $core == nmm_real ) && ( $compopt == $COMPOPTS[3] ) ) then + mv main/real_nmm.exe main/real_${core}.exe.$COMPOPTS[3] + else if ( $compopt == $COMPOPTS[1] ) then + mv main/ideal.exe main/ideal_${core}.exe.1 + endif +#DAVE################################################### +echo exec exists +ls -ls main/*.exe* +banner 10 +#set ans = "$<" +#DAVE################################################### + endif + + GOT_THIS_EXEC: + + if ( $clrm ) then + cp main/*exe* $TMPDIR/RUN/WRFV2/main + endif + + end + + if ( $clrm ) then + pushd $TMPDIR/RUN/WRFV2 + endif + + # We have all of the executables built, now we run'em. This is a loop + # over all of the various physics options for this particular + # ${core}. Inside the physics loop, we loop over the parallel options. + # This allows us to use the same WRF input files for each of the parallel + # choices for a single physics loop index. + + foreach phys_option ( $PHYSOPTS ) +#DAVE################################################### +echo which phys option $phys_option +banner 11 +#set ans = "$<" +#DAVE################################################### + + # For each of the executables, we need to run several physics + # options. + + if ( $core == em_real ) then + + if ( $CHEM != TRUE ) then + set filetag=$filetag_real + else if ( $CHEM == TRUE ) then + if ( $phys_option <= 3 ) then + set filetag=$filetag_real[1] + else + set filetag=$filetag_real[2] + endif + endif + + foreach compopt ( $COMPOPTS ) +#DAVE################################################### +echo real if filetag is $filetag +echo compopt = $compopt +banner 12 +#set ans = "$<" +#DAVE################################################### + + # We sometimes are interested in bypassing the OpenMP option. + + if ( $compopt == $COMPOPTS[2] ) then + if ( $ZAP_OPENMP == TRUE || $ZAP_OPENMP_FOR_THIS_CORE == TRUE ) then + goto BYPASS_COMP_LOOP_REAL + endif + endif + + if ( $compopt == $COMPOPTS[1] ) then + if ( $ZAP_SERIAL == TRUE || $ZAP_SERIAL_FOR_THIS_CORE == TRUE ) then + goto BYPASS_COMP_LOOP_REAL + endif + endif + + pushd test/$core + + # + # Create the correct namelist.input file for real data cases. + # + + if ( $CHEM != TRUE ) then + cp ${CUR_DIR}/phys_real_${phys_option} phys_opt + if ( ( $RSL_LITE == TRUE ) && ( $NESTED != TRUE ) ) then + cp ${CUR_DIR}/dyn_real_${phys_option} dyn_opt + else + cp ${CUR_DIR}/dyn_real_SAFE dyn_opt + endif + cp ${CUR_DIR}/time_real_${phys_option} time_opt + cp ${CUR_DIR}/dom_real dom_real + if ( -e fdda_opt ) rm fdda_opt + cat " grid_fdda=0" > fdda_opt + if ( -e fdda_time ) rm fdda_time + cat " auxinput4_interval=0" > fdda_time + + if ( $FDDA == TRUE ) then + cp ${CUR_DIR}/fdda_real_${phys_option} fdda_opt + cp ${CUR_DIR}/fdda_real_time_${phys_option} fdda_time + endif + + set time_step = `awk ' /^ time_step /{ print $3 } ' namelist.input.$dataset | cut -d, -f1` + + # Wanna do more/less time steps on the real cases? Easy. Those last two numbers + # in the eqns are all you need. Their product must be 60. So, instead of 3 and 20, + # (3 coarse grid timesteps), you could use 20 and 3 (20 coarse grid time steps). + + if ( $NESTED == TRUE ) then + @ run_seconds = $time_step * 3 + @ history_interval = $time_step / 20 + else if ( $NESTED != TRUE ) then + @ run_seconds = $time_step * 10 + @ history_interval = $time_step / 6 + endif + rm ed_in namelist.input.temp + cat >! ed_in << EOF +g/run_seconds/s/[0-9]/$run_seconds +g/history_interval/s/[0-9][0-9][0-9]/$history_interval +w namelist.input.temp +q +EOF + ed namelist.input.$dataset < ed_in + + cp ${CUR_DIR}/io_format io_format + sed -e '/^ mp_physics/,/ensdim/d' -e '/^ &physics/r ./phys_opt' \ + -e '/^ pd_moist/,/pd_tke/d' -e '/^ v_sca_adv_order/r ./dyn_opt' \ + -e '/^ auxinput1_inname/d' -e '/^ debug_level/r ./time_opt' \ + -e '/^ time_step /,/^ smooth_option/d' -e '/^ &domains/r ./dom_real' \ + -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + -e 's/ frames_per_outfile *= [0-9][0-9]*/ frames_per_outfile = 200/g' \ + -e 's/ run_days *= [0-9][0-9]*/ run_days = 0/g' \ + -e 's/ run_hours *= [0-9][0-9]*/ run_hours = 0/g' \ + -e 's/ run_minutes *= [0-9][0-9]*/ run_minutes = 0/g' \ + -e '/^ &fdda/r fdda_opt' \ + -e '/^ debug_level/r fdda_time' \ + namelist.input.temp >! namelist.input + + # The chem run has its own namelist, due to special input files (io_form not tested for chem) + + else if ( $CHEM == TRUE ) then + cp namelist.input.chem_test_${phys_option} namelist.input + if ( -e wrf_real_input_em.d01.${filetag} ) then + \rm wrf_real_input_em.d01.* + endif + if ( ${phys_option} <= 3 ) then + ln -s 00z/wrf_real* . + else + ln -s 12z/wrf_real* . + endif + + endif + + # WRF output quilt servers are only tested for MPI configuration. + # Currently, only one WRF output quilt server is used. + + if ( $QUILT == TRUE ) then + if ( $compopt == $COMPOPTS[3] ) then + # For now, test only one group of one output quilt servers. + sed -e 's/ nio_tasks_per_group *= *[0-9][0-9]*/ nio_tasks_per_group = 1/g' \ + -e 's/ nio_groups *= *[0-9][0-9]*/ nio_groups = 1/g' \ + namelist.input >! namelist.input.temp + mv -f namelist.input.temp namelist.input + echo "Building namelist.input.$core.${phys_option}.$compopt with one I/O quilt server enabled." + echo "NOTE one I/O quilt server enabled for $core physics $phys_option parallel $compopt..." >>! ${DEF_DIR}/wrftest.output + endif + endif + + /bin/cp namelist.input $TMPDIR/namelist.input.$core.${phys_option}.$compopt +#DAVE################################################### +echo built namelist $TMPDIR/namelist.input.$core.${phys_option}.$compopt +cat $TMPDIR/namelist.input.$core.${phys_option}.$compopt +echo need history interval to be 30 +banner 13 +#set ans = "$<" +#DAVE################################################### +#DAVE################################################### +echo skipped link of data files, we push them elsewhere +ls -ls wrf_real* +banner 14 +#set ans = "$<" +#DAVE################################################### + + # If this is the serial code, generate the IC and BC. The real.exe program is not + # parallelized, so the data is generated and saved for the rest of the parallel tests. + # This data is necessarily updated for each of the physics tests. + + if ( $compopt == $COMPOPTS[1] ) then + + # Zap any old input data laying around. + + rm wrfinput_d01 >& /dev/null + rm wrfbdy_d01 >& /dev/null + + if ( $NESTED == TRUE ) then + setenv OMP_NUM_THREADS 1 + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=1" + endif + $SERIALRUNCOMMAND ../../main/real_${core}.exe.1 >! print.out.real_${core}_Phys=${phys_option}_Parallel=${compopt} + else if ( $NESTED != TRUE ) then + ../../main/real_${core}.exe.1 >! print.out.real_${core}_Phys=${phys_option}_Parallel=${compopt} + endif +#DAVE################################################### +echo finished real +banner 15 +#set ans = "$<" +#DAVE################################################### + + grep "SUCCESS COMPLETE" print.out.real_${core}_Phys=${phys_option}_Parallel=${compopt} >& /dev/null + set success = $status + + # Did making the IC BC files work? + + if ( ( -e wrfinput_d01 ) && ( -e wrfbdy_d01 ) && ( $success == 0 ) ) then + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL making IC/BC $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 4 ) + endif +#DAVE################################################### +echo IC BC must be OK +ls -ls wrfi* wrfb* +if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -v Times wrfb* | tail -20 +endif +banner 16 +#set ans = "$<" +#DAVE################################################### + endif + + # Run the forecast for this core, physics package and parallel option + + rm $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt >& /dev/null + + # The chem run has its own set of namelists, due to special input files. + + if ( $CHEM == TRUE ) then + + # WRF output quilt servers are only tested for MPI configuration. + # Currently, only one WRF output quilt server is used. + + if ( $QUILT == TRUE ) then + if ( $compopt == $COMPOPTS[3] ) then + # For now, test only one group of one output quilt servers. + sed -e 's/ nio_tasks_per_group *= *[0-9][0-9]*/ nio_tasks_per_group = 1/g' \ + -e 's/ nio_groups *= *[0-9][0-9]*/ nio_groups = 1/g' \ + namelist.input >! namelist.input.temp + mv -f namelist.input.temp namelist.input + echo "Building namelist.input.$core.${phys_option}.$compopt with one I/O quilt server enabled." + echo "NOTE one I/O quilt server enabled for $core physics $phys_option parallel $compopt..." >>! ${DEF_DIR}/wrftest.output + endif + endif + endif + + if ( $compopt == $COMPOPTS[1] ) then + setenv OMP_NUM_THREADS 1 + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=1" + endif + if ( $NESTED == TRUE ) then + $SERIALRUNCOMMAND ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + else if ( $NESTED != TRUE ) then + ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + endif + else if ( $compopt == $COMPOPTS[2] ) then + setenv OMP_NUM_THREADS $OPENMP + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=${OPENMP}" + endif + if ( $NESTED == TRUE ) then + $OMPRUNCOMMAND ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + else if ( $NESTED != TRUE ) then + ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + endif + else if ( $compopt == $COMPOPTS[3] ) then + setenv OMP_NUM_THREADS 1 + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=1" + endif + $MPIRUNCOMMAND ../../main/wrf_${core}.exe.$compopt $MPIRUNCOMMANDPOST + mv rsl.error.0000 print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + endif +#DAVE################################################### +echo ran wrf fcst compopt = $compopt +banner 17 +#set ans = "$<" +#DAVE################################################### + + grep "SUCCESS COMPLETE" print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe + set success = $status + + # Did making the forecast work, by that, we mean "is there an output file created", and "are there 2 times periods". + + if ( ( -e wrfout_d01_${filetag} ) && ( $success == 0 ) ) then + if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -h wrfout_d01_${filetag} | grep Time | grep UNLIMITED | grep currently | grep -q 2 + set ok = $status + set found_nans = 1 + if ( `uname` == AIX ) then + ncdump wrfout_d01_${filetag} | grep NaN >& /dev/null + set found_nans = $status + else if ( `uname` == OSF1 ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + # set found_nans = $status + else if ( `uname` == Linux ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + set found_nans = $status + endif + if ( $found_nans == 0 ) then + echo found nans + set ok = 1 + endif + + else if ( $IO_FORM_NAME[$IO_FORM] == io_grib1 ) then +# set joe_times = `../../external/io_grib1/wgrib -s -4yr wrfout_d01_${filetag} | grep -v ":anl:" | wc -l` +# if ( $joe_times >= 100 ) then + set joe_times = `../../external/io_grib1/wgrib -s -4yr wrfout_d01_${filetag} | grep "UGRD:10 m" | wc -l` + if ( $joe_times == 2 ) then + set ok = 0 + else + set ok = 1 + endif + endif + if ( $ok == 0 ) then + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 5 ) + endif + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 6 ) + endif +#DAVE################################################### +echo success or failure of fcst +if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -v Times wrfout_d01_${filetag} | tail -20 +endif +banner 18 +#set ans = "$<" +#DAVE################################################### + + # We have to save this output file for our biggy comparison after all of the + # parallel options have been considered. + + mv wrfout_d01_${filetag} $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt + + # To save space, we move the executables after we are finished with them. + + if ( $phys_option == $PHYSOPTS[${#PHYSOPTS}] ) then + mv ../../main/wrf_${core}.exe.$compopt $TMPDIR/wrf_${core}.exe.$compopt + endif + + popd + + BYPASS_COMP_LOOP_REAL: + + end + + else if ( $core == nmm_real ) then +#DAVE################################################### +echo doing nmm pre +banner 19 +#set ans = "$<" +#DAVE################################################### + + set compopt = $COMPOPTS[3] # ! parallel only + set filetag = 2005-01-23_00:00:00 + set phys_option=1 + pushd test/$core + +#DAVE################################################### +echo did rms +echo $filetag $phys_option +banner 19a +#set ans = "$<" +#DAVE################################################### + + # Build NMM namelist + + cp ${CUR_DIR}/io_format io_format + sed -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + namelist.input.regtest >! namelist.input.temp + + # A fairly short forecast, 10 time steps + + sed -e 's/^ run_days *= *[0-9]*/ run_days = 0 /' \ + -e 's/^ run_seconds *= *[0-9]*/ run_seconds = 900 /' \ + -e 's/^ history_interval *= *[0-9][0-9]*/ history_interval = 15 /' \ + -e 's/^ frames_per_outfile *= [0-9]*/ frames_per_outfile = 200/g' \ + namelist.input.temp >! namelist.input + +#DAVE################################################### +echo did cp of namelist +ls -ls namelist.input +cat namelist.input +banner 19b +#set ans = "$<" +#DAVE################################################### + + # Generate IC/BC for NMM run + + set RUNCOMMAND = `echo $MPIRUNCOMMAND | sed "s/$Num_Procs/1/"` + + # Zap any old input data laying around. + + rm wrfinput_d01 >& /dev/null + rm wrfbdy_d01 >& /dev/null + + $RUNCOMMAND ../../main/real_${core}.exe.$COMPOPTS[3] >! print.out.real_${core}_Phys=${phys_option}_Parallel=$COMPOPTS[3] +#DAVE################################################### +echo finished real +banner 19c +#set ans = "$<" +#DAVE################################################### + + mv rsl.out.0000 print.out.real_${core}_Phys=${phys_option}_Parallel=${compopt} + grep "SUCCESS COMPLETE" print.out.real_${core}_Phys=${phys_option}_Parallel=${compopt} >& /dev/null + set success = $status + + # Did making the IC BC files work? + + if ( ( -e wrfinput_d01 ) && ( -e wrfbdy_d01 ) && ( $success == 0 ) ) then + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL making IC/BC $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 4 ) + endif +#DAVE################################################### +echo IC BC must be OK +ls -lsL wrfinput* wrfb* +if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -v Times wrfb* | tail -20 +endif +banner 20 +#set ans = "$<" +#DAVE################################################### + + # Run on 1 and then on Num_Procs processors + + foreach n ( 1 $Num_Procs ) +#DAVE################################################### +echo running nmm on $n procs +banner 21 +#set ans = "$<" +#DAVE################################################### + + if ( ( $n != 1 ) && ( $QUILT != TRUE ) ) then + @ nmm_proc = $Num_Procs + cat >! nproc_xy << EOF + nproc_x = $nmm_proc + nproc_y = 1 +EOF + sed -e '/^ numtiles/r nproc_xy' namelist.input >! file.foo + mv file.foo namelist.input + else if ( ( $n != 1 ) && ( $QUILT == TRUE ) ) then + @ nmm_proc = $Num_Procs - 1 + cat >! nproc_xy << EOF + nproc_x = $nmm_proc + nproc_y = 1 +EOF + sed -e '/^ numtiles/r nproc_xy' namelist.input >! file.foo + mv file.foo namelist.input + endif + + if ( `uname` == AIX ) then + set RUNCOMMAND = $MPIRUNCOMMAND + else + set RUNCOMMAND = `echo $MPIRUNCOMMAND | sed "s/$Num_Procs/$n/"` + endif + + # WRF output quilt servers are only tested for MPI configuration. + # Currently, only one WRF output quilt server is used. + + if ( ( $QUILT == TRUE ) && ( $n == $Num_Procs ) ) then + if ( $compopt == $COMPOPTS[3] ) then + # For now, test only one group of one output quilt servers. + sed -e 's/ nio_tasks_per_group *= *[0-9]*/ nio_tasks_per_group = 1/g' \ + -e 's/ nio_groups *= *[0-9]*/ nio_groups = 1/g' \ + namelist.input >! namelist.input.temp + mv -f namelist.input.temp namelist.input + echo "Building namelist.input.$core.${phys_option}.$compopt with one I/O quilt server enabled." + echo "NOTE one I/O quilt server enabled for $core physics $phys_option parallel $compopt..." >>! ${DEF_DIR}/wrftest.output + endif + endif + + # NMM can fail on spurious fp exceptions that don't affect soln. Retry if necessary. + + set tries=0 + while ( $tries < 2 ) +#DAVE################################################### +echo try attempt $tries allowed to be less than 2 +banner 22 +#set ans = "$<" +#DAVE################################################### + @ tries = $tries + 1 + $RUNCOMMAND ../../main/wrf_${core}.exe.$compopt $MPIRUNCOMMANDPOST + mv rsl.error.0000 print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe_${n}p + grep "SUCCESS COMPLETE" print.out.wrf_${core}_Phys=${phys_option}_Parallel=${compopt}.exe_${n}p + set success = $status + set ok = $status + if ( ( -e wrfout_d01_${filetag} ) && ( $success == 0 ) ) then + if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -h wrfout_d01_${filetag} | grep Time | grep UNLIMITED | grep currently | grep -q 2 + set ok = $status + set found_nans = 1 + if ( `uname` == AIX ) then + ncdump wrfout_d01_${filetag} | grep NaN >& /dev/null + set found_nans = $status + else if ( `uname` == OSF1 ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + # set found_nans = $status + else if ( `uname` == Linux ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + set found_nans = $status + endif + if ( $found_nans == 0 ) then + echo found nans + set ok = 1 + endif + + else if ( $IO_FORM_NAME[$IO_FORM] == io_grib1 ) then + ../../external/io_grib1/wgrib -s -4yr wrfout_d01_${filetag} | grep "UGRD:10 m above gnd:3600 sec fcst" + set ok = $status + endif + if ( $ok == 0 ) then + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + set tries=2 # success, bail from loop + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + if ( $tries == 2 ) exit ( 5 ) + endif + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + if ( $tries == 2 ) exit ( 6 ) + endif + mv wrfout_d01_${filetag} $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.${compopt}_${n}p +#DAVE################################################### +echo did nmm fcst +ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.${compopt}_${n}p +banner 23 +#set ans = "$<" +#DAVE################################################### + end + end + + popd + + else + +#DAVE################################################### +echo doing ideal runs +banner 24 +#set ans = "$<" +#DAVE################################################### + # The ideal cases have different physics tests than the real cases. If this is + # more that the total number of ideal physics experiments that we were led to + # believe would exist, jump to the end of the physics loop. + + if ( $phys_option > $Max_Ideal_Physics_Options ) then + goto BOTTOM_OF_PHYSICS_LOOP + endif + + set filetag=$filetag_ideal + + foreach compopt ( $COMPOPTS ) +#DAVE################################################### +echo doing compopt = $compopt +echo filetag = $filetag +banner 25 +#set ans = "$<" +#DAVE################################################### + + + # We sometimes are interested in bypassing the OpenMP option. + + if ( $compopt == $COMPOPTS[2] ) then + if ( $ZAP_OPENMP == TRUE ) then + goto BYPASS_COMP_LOOP_IDEAL + endif + endif + + pushd test/$core + + if ( ! -e namelist.input.template ) cp namelist.input namelist.input.template + + # Create the correct namelist.input file. + + cp ${CUR_DIR}/dom_ideal dom_ideal + if ( $core == em_quarter_ss ) then + cp ${CUR_DIR}/phys_quarter_ss_${phys_option}a phys_tke + cp ${CUR_DIR}/phys_quarter_ss_${phys_option}b phys_mp + cp ${CUR_DIR}/phys_quarter_ss_${phys_option}c phys_nh + cp ${CUR_DIR}/phys_quarter_ss_${phys_option}d phys_bc + else if ( $core == em_b_wave ) then + cp ${CUR_DIR}/phys_b_wave_${phys_option}a phys_tke + cp ${CUR_DIR}/phys_b_wave_${phys_option}b phys_mp + cp ${CUR_DIR}/phys_b_wave_${phys_option}c phys_nh + endif + + cp ${CUR_DIR}/io_format io_format + if ( $NESTED == TRUE ) then + if ( $core == em_quarter_ss ) then + sed -e 's/ run_days *= *[0-9][0-9]*/ run_days = 00/g' \ + -e 's/ run_minutes *= *[0-9][0-9]*/ run_minutes = 1/g' \ + -e 's/ run_seconds *= *[0-9][0-9]*/ run_seconds = 0/g' \ + -e 's/ history_interval *= [0-9][0-9]*/ history_interval = 1/g' \ + -e 's/ frames_per_outfile *= [0-9][0-9]*/ frames_per_outfile = 100/g' \ + -e '/^ diff_opt/d' -e '/^ km_opt/d' -e '/^ damp_opt/d' -e '/^ rk_ord/r ./phys_tke' \ + -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + -e '/^ mp_physics/d' -e '/^ &physics/r ./phys_mp' \ + -e '/^ non_hydrostatic/d' -e '/^ epssm/r ./phys_nh' \ + -e '/^ periodic_x /,/^ open_ye/d' \ + -e '/^ &bdy_control/r ./phys_bc' \ + -e '/^ max_dom/d' -e '/^ time_step_fract_den/r ./dom_ideal' \ + ./namelist.input.template >! namelist.input + else if ( $core == em_b_wave ) then + sed -e 's/ run_days *= *[0-9][0-9]*/ run_days = 00/g' \ + -e 's/ run_minutes *= *[0-9][0-9]*/ run_minutes = 20/g' \ + -e 's/ history_interval *= [0-9][0-9]*/ history_interval = 20/g' \ + -e 's/ frames_per_outfile *= [0-9][0-9]*/ frames_per_outfile = 100/g' \ + -e '/^ diff_opt/d' -e '/^ km_opt/d' -e '/^ damp_opt/d' -e '/^ rk_ord/r ./phys_tke' \ + -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + -e '/^ mp_physics/d' -e '/^ &physics/r ./phys_mp' \ + -e '/^ non_hydrostatic/d' -e '/^ epssm/r ./phys_nh' \ + -e '/^ max_dom/d' -e '/^ time_step_fract_den/r ./dom_ideal' \ + ./namelist.input.template >! namelist.input + endif + else if ( $NESTED != TRUE ) then + if ( $core == em_quarter_ss ) then + sed -e 's/ run_days *= *[0-9][0-9]*/ run_days = 00/g' \ + -e 's/ run_minutes *= *[0-9][0-9]*/ run_minutes = 2/g' \ + -e 's/ history_interval *= [0-9][0-9]*/ history_interval = 2/g' \ + -e 's/ frames_per_outfile *= [0-9][0-9]*/ frames_per_outfile = 100/g' \ + -e '/^ diff_opt/d' -e '/^ km_opt/d' -e '/^ damp_opt/d' -e '/^ rk_ord/r ./phys_tke' \ + -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + -e '/^ mp_physics/d' -e '/^ &physics/r ./phys_mp' \ + -e '/^ non_hydrostatic/d' -e '/^ epssm/r ./phys_nh' \ + -e '/^ periodic_x/d' -e '/^ open_xs/d' -e '/^ open_xe/d' \ + -e '/^ periodic_y/d' -e '/^ open_ys/d' -e '/^ open_ye/d' \ + -e '/^ &bdy_control/r ./phys_bc' \ + -e '/^ max_dom/d' -e '/^ time_step_fract_den/r ./dom_ideal' \ + ./namelist.input.template >! namelist.input + else if ( $core == em_b_wave ) then + sed -e 's/ run_days *= *[0-9][0-9]*/ run_days = 00/g' \ + -e 's/ run_minutes *= *[0-9][0-9]*/ run_minutes = 100/g' \ + -e 's/ history_interval *= [0-9][0-9]*/ history_interval = 100/g' \ + -e 's/ frames_per_outfile *= [0-9][0-9]*/ frames_per_outfile = 100/g' \ + -e '/^ diff_opt/d' -e '/^ km_opt/d' -e '/^ damp_opt/d' -e '/^ rk_ord/r ./phys_tke' \ + -e '/^ io_form_history /,/^ io_form_boundary/d' -e '/^ restart_interval/r ./io_format' \ + -e '/^ mp_physics/d' -e '/^ &physics/r ./phys_mp' \ + -e '/^ non_hydrostatic/d' -e '/^ epssm/r ./phys_nh' \ + -e '/^ max_dom/d' -e '/^ time_step_fract_den/r ./dom_ideal' \ + ./namelist.input.template >! namelist.input + endif + endif + + # WRF output quilt servers are only tested for MPI configuration. + # Currently, only one WRF output quilt server is used. + + if ( $QUILT == TRUE ) then + if ( $compopt == $COMPOPTS[3] ) then + # For now, test only one group of one output quilt servers. + sed -e 's/ nio_tasks_per_group *= *[0-9][0-9]*/ nio_tasks_per_group = 1/g' \ + -e 's/ nio_groups *= *[0-9][0-9]*/ nio_groups = 1/g' \ + namelist.input >! namelist.input.temp + mv -f namelist.input.temp namelist.input + echo "Building namelist.input.$core.${phys_option}.$compopt with one I/O quilt server enabled." + echo "NOTE one I/O quilt server enabled for $core physics $phys_option parallel $compopt..." >>! ${DEF_DIR}/wrftest.output + endif + endif +#DAVE################################################### +echo built namelist +ls -ls namelist.input +banner 26 +#set ans = "$<" +#DAVE################################################### + + # If this is the serial code, generate the IC and BC. The ideal.exe program is not + # parallelized, so the data is generated and saved for the rest of the parallel tests. + + if ( $compopt == $COMPOPTS[1] ) then + + # Zap any old input data laying around. + + rm wrfinput_d01 >& /dev/null + rm wrfbdy_d01 >& /dev/null + + ../../main/ideal_${core}.exe.1 >! print.out.ideal_${core}_Parallel=${compopt} +#DAVE################################################### +echo ran ideal +ls -ls wrfiput* +banner 27 +#set ans = "$<" +#DAVE################################################### + + grep "SUCCESS COMPLETE" print.out.ideal_${core}_Parallel=${compopt} >& /dev/null + set success = $status + + # Did making the IC BC files work? + + if ( ( -e wrfinput_d01 ) && ( $success == 0 ) ) then + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY generate IC/BC for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL making IC/BC $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 7 ) + endif + endif + + # Run the forecast for this core and parallel option + + rm $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt >& /dev/null + + if ( $compopt == $COMPOPTS[1] ) then + setenv OMP_NUM_THREADS 1 + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=1" + endif + if ( $NESTED == TRUE ) then + $SERIALRUNCOMMAND ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Parallel=${compopt}.exe + else if ( $NESTED != TRUE ) then + ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Parallel=${compopt}.exe + endif + else if ( $compopt == $COMPOPTS[2] ) then + setenv OMP_NUM_THREADS $OPENMP + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=${OPENMP}" + endif + if ( $NESTED == TRUE ) then + $OMPRUNCOMMAND ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Parallel=${compopt}.exe + else if ( $NESTED != TRUE ) then + ../../main/wrf_${core}.exe.$compopt >! print.out.wrf_${core}_Parallel=${compopt}.exe + endif + else if ( $compopt == $COMPOPTS[3] ) then + setenv OMP_NUM_THREADS 1 + if ( `uname` == AIX ) then + setenv XLSMPOPTS "parthds=1" + endif + $MPIRUNCOMMAND ../../main/wrf_${core}.exe.$compopt $MPIRUNCOMMANDPOST + mv rsl.error.0000 print.out.wrf_${core}_Parallel=${compopt}.exe + endif +#DAVE################################################### +echo ran ideal fcst +banner 28 +#set ans = "$<" +#DAVE################################################### + + grep "SUCCESS COMPLETE" print.out.wrf_${core}_Parallel=${compopt}.exe + set success = $status + + # Did making the forecast work, by that, we mean "is there an output file created?" + + if ( ( -e wrfout_d01_${filetag} ) && ( $success == 0 ) ) then + if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -h wrfout_d01_${filetag} | grep Time | grep UNLIMITED | grep currently | grep -q 2 + set ok = $status + set found_nans = 1 + if ( `uname` == AIX ) then + ncdump wrfout_d01_${filetag} | grep NaN >& /dev/null + set found_nans = $status + else if ( `uname` == OSF1 ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + # set found_nans = $status + else if ( `uname` == Linux ) then + ncdump wrfout_d01_${filetag} | grep nan >& /dev/null + set found_nans = $status + endif + if ( $found_nans == 0 ) then + echo found nans + set ok = 1 + endif + + else if ( $IO_FORM_NAME[$IO_FORM] == io_grib1 ) then +# set joe_times = `../../external/io_grib1/wgrib -s -4yr wrfout_d01_${filetag} | grep -v ":anl:" | wc -l` +# if ( $joe_times >= 100 ) then + set joe_times = `../../external/io_grib1/wgrib -s -4yr wrfout_d01_${filetag} | grep "UGRD:10 m" | wc -l` + if ( $joe_times == 2 ) then + set ok = 0 + else + set ok = 1 + endif + endif + if ( $ok == 0 ) then + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 8 ) + endif + else + echo "SUMMARY generate FCST for $core physics $phys_option parallel $compopt $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + $MAIL -s "WRF FAIL FCST $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output + exit ( 9 ) + endif + + # We have to save this output file for our biggy comparison after all of the + # parallel options have been considered. + + mv wrfout_d01_${filetag} $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt + + # To save space, we move the executables after we are finished with them. + + if ( $phys_option == $Max_Ideal_Physics_Options ) then + mv ../../main/wrf_${core}.exe.$compopt $TMPDIR/wrf_${core}.exe.$compopt + endif +#DAVE################################################### +echo fcst was a success +ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt +if ( $IO_FORM_NAME[$IO_FORM] == io_netcdf ) then + ncdump -v Times $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$compopt | tail -20 +endif +banner 29 +#set ans = "$<" +#DAVE################################################### + + popd + + BYPASS_COMP_LOOP_IDEAL: + + end + + endif + + # OK, once more, we gotta check if this is a BIT4BIT run. If so then there + # are a number of comparisons to do. If this is a an OPTIMIZED run, then the + # comparisons will fail the bit-wise comparisons. + + if ( $REG_TYPE == BIT4BIT) then + + if ( $core == nmm_real ) then + + pushd ${DEF_DIR}/regression_test/WRFV2/test/$core + set DIFFWRF = ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf + + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_1p ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_${Num_Procs}p ) ) then + set foo1 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_1p `) + set foo2 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_${Num_Procs}p `) + set size1 = $foo1[6] + set size2 = $foo2[6] + if ( $size1 == $size2 ) then + set RIGHT_SIZE = TRUE + else + set RIGHT_SIZE = FALSE + endif + else + set RIGHT_SIZE = FALSE + endif + + # 1p vs Num_Procs MPI + + rm fort.88 fort.98 >& /dev/null + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_1p ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_${Num_Procs}p ) && \ + ( $RIGHT_SIZE == TRUE ) ) then + $DIFFWRF $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_1p \ + $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3]_${Num_Procs}p >& /dev/null + else + touch fort.88 fort.98 + endif + if ( ! -e fort.88 ) then + echo "SUMMARY 1 vs $Num_Procs MPI for $core physics $phys_option $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY 1 vs $Num_Procs MPI for $core physics $phys_option $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + endif + + popd + + else if ( ${#COMPOPTS} != 1 ) then + + # If there is only a single parallel option, then we are just trying to + # build the serial code. That implies no comparisons are needed. + + # All of the forecasts for this set of physics and core have been + # generated. We now compare the WRF model output files to see + # if they are S^2D^2. + + pushd ${DEF_DIR}/regression_test/WRFV2/test/$core + set DIFFWRF = ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf + + # Are we skipping the OpenMP runs? + + if ( $ZAP_OPENMP == TRUE ) then + goto BYPASS_OPENMP_SUMMARY1 + endif + + # Are the files the same size? If not, then only the initial times + # will be compared. That means, on a failure to run a forecast, the + # diffwrf will give a pass. We need to root out this evil. + + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[2] ) ) then + set foo1 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] `) + set foo2 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[2] `) + set size1 = $foo1[6] + set size2 = $foo2[6] + if ( $size1 == $size2 ) then + set RIGHT_SIZE_OMP = TRUE + else + set RIGHT_SIZE_OMP = FALSE + endif + else + set RIGHT_SIZE_OMP = FALSE + endif + + BYPASS_OPENMP_SUMMARY1: + + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3] ) ) then + set foo1 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] `) + set foo3 = ( ` \ls -ls $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3] `) + set size1 = $foo1[6] + set size3 = $foo3[6] + if ( $size1 == $size3 ) then + set RIGHT_SIZE_MPI = TRUE + else + set RIGHT_SIZE_MPI = FALSE + endif + else + set RIGHT_SIZE_MPI = FALSE + endif + + # Are we skipping the OpenMP runs? + + if ( $ZAP_OPENMP == TRUE ) then + goto BYPASS_OPENMP_SUMMARY2 + endif + + # Serial vs OpenMP + + rm fort.88 fort.98 >& /dev/null + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[2] ) && \ + ( $RIGHT_SIZE_OMP == TRUE ) ) then + $DIFFWRF $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] \ + $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[2] >& /dev/null + else + touch fort.88 fort.98 + endif + if ( ! -e fort.88 ) then + echo "SUMMARY serial vs OMP for $core physics $phys_option $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY serial vs OMP for $core physics $phys_option $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + endif + + BYPASS_OPENMP_SUMMARY2: + + # Serial vs MPI + + rm fort.88 fort.98 >& /dev/null + if ( ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] ) && \ + ( -e $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3] ) && \ + ( $RIGHT_SIZE_MPI == TRUE ) ) then + $DIFFWRF $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] \ + $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3] >& /dev/null + else + touch fort.88 fort.98 + endif + if ( ! -e fort.88 ) then + echo "SUMMARY serial vs MPI for $core physics $phys_option $esmf_lib_str PASS" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + else + echo "SUMMARY serial vs MPI for $core physics $phys_option $esmf_lib_str FAIL" >>! ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + endif + + popd + + endif + + # Generate and archive baseline or compare against baseline + + if ( $core != nmm_real ) then + if ( $GENERATE_BASELINE != FALSE ) then + if ( ! -d $GENERATE_BASELINE ) then + echo "ERROR: Baseline directory ${GENERATE_BASELINE} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + else + # Archive serial output file to baseline + pushd ${DEF_DIR}/regression_test/WRFV2/test/$core + set basefilenm = wrfout_d01_${filetag}.${core}.${phys_option} + set basefile = ${GENERATE_BASELINE}/${basefilenm} + set outfile = $TMPDIR/${basefilenm}.$COMPOPTS[1] + if ( -e $outfile ) then + cp $outfile $basefile || \ + ( echo "ERROR: cannot copy ${outfile} to ${basefile}" >>! \ + ${DEF_DIR}/wrftest.output; exit 10 ) + else + echo "ERROR: Cannot archive baseline, file $outfile does not exist" >>! \ + ${DEF_DIR}/wrftest.output + echo "SUMMARY baseline archived in ${GENERATE_BASELINE} for $core physics $phys_option FAIL" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + endif + echo "SUMMARY baseline archived in ${GENERATE_BASELINE} for $core physics $phys_option PASS" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + popd + endif + endif + if ( $COMPARE_BASELINE != FALSE ) then + if ( ! -d $COMPARE_BASELINE ) then + echo "${0}: ERROR:: Baseline directory ${COMPARE_BASELINE} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + else + # Compare against baseline output file + set basefilenm = wrfout_d01_${filetag}.${core}.${phys_option} + set basefile = ${COMPARE_BASELINE}/${basefilenm} + set DIFFWRF = ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf + set testdir = ${DEF_DIR}/regression_test/WRFV2/test/$core + pushd ${testdir} + foreach compopt ( $COMPOPTS ) + set cmpfile = $TMPDIR/${basefilenm}.$compopt + rm fort.88 fort.98 >& /dev/null + if ( ( -e ${basefile} ) && ( -e ${cmpfile} ) ) then + # Are the files the same size? If not, then only the initial times + # will be compared. That means, on a failure to run a forecast, the + # diffwrf will give a pass. We need to root out this evil. + set foob = ( ` \ls -ls ${basefile} `) + set fooc = ( ` \ls -ls ${cmpfile} `) + set sizeb = $foob[6] + set sizec = $fooc[6] + if ( $sizeb == $sizec ) then + $DIFFWRF ${basefile} ${cmpfile} >& /dev/null + if ( -e fort.88 ) then + echo "FAIL: Baseline comparison, file ${cmpfile} did not match ${basefile} according to diffwrf" >>! \ + ${DEF_DIR}/wrftest.output + endif + else + touch fort.88 fort.98 + echo "FAIL: Baseline comparison, files ${cmpfile} and ${basefile} have different sizes" >>! \ + ${DEF_DIR}/wrftest.output + endif + else + echo "FAIL: Baseline comparison, either ${cmpfile} or ${basefile} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + touch fort.88 fort.98 + endif + if ( ! -e fort.88 ) then + echo "SUMMARY compare vs baseline ${COMPARE_BASELINE} for $core physics $phys_option compopt $compopt $esmf_lib_str PASS" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + else + echo "SUMMARY compare vs baseline ${COMPARE_BASELINE} for $core physics $phys_option compopt $compopt $esmf_lib_str FAIL" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + endif + end + popd + endif + endif + else if ( $core == nmm_real ) then + if ( $GENERATE_BASELINE != FALSE ) then + if ( ! -d $GENERATE_BASELINE ) then + echo "ERROR: Baseline directory ${GENERATE_BASELINE} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + else + # Archive serial output file to baseline + pushd ${DEF_DIR}/regression_test/WRFV2/test/$core + set basefilenm = wrfout_d01_${filetag}.${core}.${phys_option} + set basefile = ${GENERATE_BASELINE}/${basefilenm} + set outfile = $TMPDIR/${basefilenm}.$COMPOPTS[3]_1p + if ( -e $outfile ) then + cp $outfile $basefile || \ + ( echo "ERROR: cannot copy ${outfile} to ${basefile}" >>! \ + ${DEF_DIR}/wrftest.output; exit 10 ) + else + echo "ERROR: Cannot archive baseline, file $outfile does not exist" >>! \ + ${DEF_DIR}/wrftest.output + echo "SUMMARY baseline archived in ${GENERATE_BASELINE} for $core physics $phys_option FAIL" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + endif + echo "SUMMARY baseline archived in ${GENERATE_BASELINE} for $core physics $phys_option PASS" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + popd + endif + endif + if ( $COMPARE_BASELINE != FALSE ) then + if ( ! -d $COMPARE_BASELINE ) then + echo "${0}: ERROR:: Baseline directory ${COMPARE_BASELINE} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + exit ( 10 ) + else + # Compare against baseline output file + set basefilenm = wrfout_d01_${filetag}.${core}.${phys_option} + set basefile = ${COMPARE_BASELINE}/${basefilenm} + set DIFFWRF = ${DEF_DIR}/regression_test/WRFV2/external/$IO_FORM_NAME[$IO_FORM]/diffwrf + set testdir = ${DEF_DIR}/regression_test/WRFV2/test/$core + pushd ${testdir} + set compopt = $COMPOPTS[3] + foreach proc ( 1p 4p ) + set cmpfile = $TMPDIR/${basefilenm}.${compopt}_${proc} + rm fort.88 fort.98 >& /dev/null + if ( ( -e ${basefile} ) && ( -e ${cmpfile} ) ) then + # Are the files the same size? If not, then only the initial times + # will be compared. That means, on a failure to run a forecast, the + # diffwrf will give a pass. We need to root out this evil. + set foob = ( ` \ls -ls ${basefile} `) + set fooc = ( ` \ls -ls ${cmpfile} `) + set sizeb = $foob[6] + set sizec = $fooc[6] + if ( $sizeb == $sizec ) then + $DIFFWRF ${basefile} ${cmpfile} >& /dev/null + if ( -e fort.88 ) then + echo "FAIL: Baseline comparison, file ${cmpfile} did not match ${basefile} according to diffwrf" >>! \ + ${DEF_DIR}/wrftest.output + endif + else + touch fort.88 fort.98 + echo "FAIL: Baseline comparison, files ${cmpfile} and ${basefile} have different sizes" >>! \ + ${DEF_DIR}/wrftest.output + endif + else + echo "FAIL: Baseline comparison, either ${cmpfile} or ${basefile} does not exist" >>! \ + ${DEF_DIR}/wrftest.output + touch fort.88 fort.98 + endif + if ( ! -e fort.88 ) then + echo "SUMMARY compare vs baseline ${COMPARE_BASELINE} for $core physics $phys_option compopt $compopt $esmf_lib_str PASS" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + else + echo "SUMMARY compare vs baseline ${COMPARE_BASELINE} for $core physics $phys_option compopt $compopt $esmf_lib_str FAIL" >>! \ + ${DEF_DIR}/wrftest.output + echo "-------------------------------------------------------------" >> \ + ${DEF_DIR}/wrftest.output + endif + end + popd + endif + endif + goto ALL_SHE_WROTE_FOR_NMM + endif + # End of generate and archive baseline or compare against baseline + + endif + + BOTTOM_OF_PHYSICS_LOOP: + + end + +ALL_SHE_WROTE_FOR_NMM: + + echo "-------------------------------------------------------------" >> ${DEF_DIR}/wrftest.output + + if ( $clrm ) then + popd + endif + +end + + +# How long did this take. + +set end = ( `date` ) +echo "Start WRF Regression: $start " >> ${DEF_DIR}/wrftest.output +echo "End WRF Regression: $end " >> ${DEF_DIR}/wrftest.output + +# We have done all of the tests, and placed the PASS FAIL labels in the +# output file. If there are any FAIL messages, we are in trouble. + +grep FAIL ${DEF_DIR}/wrftest.output +set ok = $status + +# Send email of the status. + +if ( $ok == 0 ) then + $MAIL -s "REGRESSION FAILURE $ARCH[1] " $FAIL_MAIL < ${DEF_DIR}/wrftest.output +else + $MAIL -s "REGRESSION SUCCESS $ARCH[1] " $GOOD_MAIL < ${DEF_DIR}/wrftest.output +endif + +# Clean left up detritus + +cd $CUR_DIR + +rm -rf dom_*eal >& /dev/null +rm -rf phys_real_* >& /dev/null +rm -rf phys_quarter_* >& /dev/null +rm -rf phys_b_wave_* >& /dev/null +rm -rf version_info >& /dev/null +rm -rf machfile >& /dev/null +rm -rf fdda_real* >& /dev/null +rm -rf time_real_* >& /dev/null +rm -rf dyn_real_* >& /dev/null diff --git a/wrfv2_fire/tools/safe b/wrfv2_fire/tools/safe new file mode 100755 index 00000000..50247d51 --- /dev/null +++ b/wrfv2_fire/tools/safe @@ -0,0 +1,12 @@ +#!/bin/csh + +# reverse the effect of danger + +if ( ! -d tools ) then + echo 'must be run in top level dir' +endif + +foreach f ( */Makefile.saved ) + /bin/mv $f $f:r +end + diff --git a/wrfv2_fire/tools/subinfo b/wrfv2_fire/tools/subinfo new file mode 100755 index 00000000..19079584 --- /dev/null +++ b/wrfv2_fire/tools/subinfo @@ -0,0 +1,223 @@ +#!/bin/perl + +$dbdir = "tools/code_dbase" ; + +if ( ! opendir( TOOLDIR, "tools") ) { + print "\nMust be in top level WRF directory\n" ; + exit ; +} +closedir TOOLDIR ; + +$gofast=0 ; +if ( ( scalar @ARGV < 1 ) || ( scalar @ARGV > 2 ) ) { + print "usage: subinfo routinename \n" ; + print " subinfo rebuild \n" ; + exit ; +} +if ( ( scalar @ARGV == 2 ) ) { $gofast = 1 ; } # don't bother with links for argument lists + +if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" ) +{ + print "Building code database ... please wait.\n" ; + system( "cd tools/CodeBase ; make" ) ; + open P, "tools/build_codebase |&" ; while (

) { print ; } close P ; + system( "ln -sf tools/subinfo ." ) ; + system( "ln -sf tools/wrfvar ." ) ; + if ( $ARGV[0] eq "rebuild" ) { exit ; } +} +close XXX ; + + +$rout1 = lc $ARGV[0] ; +$rout = $rout1 ; +#print $vname,"\n" ; +#print $rout,"\n" ; + +$routfile = $dbdir."/".$rout ; + +if ( ! ( open( ROUT, "< $routfile" )) ) { + print "$rout is not a known subprogram. \n" ; + open P, "/bin/ls -1 $dbdir/\*$rout\* | " ; + print "Perhaps you mean:\n" ; + while (

) { + s/.*\/// ; + if ( substr( $_, 0, 3 ) eq "lm_" ) { next ; } + if ( $_ =~ "not found" ) { break ; } + print " $_" ; + } + exit ; +} + +#open ROUT, "< $routfile" or { print "$rout is not a known subprogram. Perhaps you mean:\n" ; } +# system( "/bin/ls -1 $dbdir/\*$rout\*" ) ; +# die ; + +while ( ) { + @t = split ' ' ; + if ( $t[0] eq sourcefile ) { + $sourcefile = $t[1] ; + } + if ( $t[0] eq subprogram ) { + if ( $t[1] eq "function" ) { + $subprog = $t[2]." ".$t[1] ; + } else { + $subprog = $t[1] ; + } + } +} +close ROUT ; + +print "\n" ; +print " ",ucfirst $subprog," : ",uc $rout1," \n" ; +print "\n" ; +print "

",ucfirst $subprog," : ",uc $rout1,"

\n" ; + +# see if there is a 'big-f' file... +$refer_to = $sourcefile ; +$tail = substr( $sourcefile, length( $sourcefile ) - 2 ) ; +if ( "$tail" eq ".f" ) { + $refer_to = substr( $sourcefile, 0, length( $sourcefile ) - 2 ) . ".F" ; + if ( ! ( open( EXISTNCE, "< $refer_to" )) ) { + $refer_to = $sourcefile ; + } + else { close EXISTNCE ; } +} + +#print " Defined in: $refer_to

\n" ; +# have it point to the wrf code browser instead +$rout1_uc = uc $rout1 ; +print " Defined in: $refer_to

\n" ; + +if ( open (DESC, "< ${routfile}_descrip" ) ) { + print " Description:

\n" ; + while ( ) { + print ; + } + print "

\n" ; + close DESC ; +} + + +print " Called by :

\n" ; +print "

\n" ;
+@sysargs = ( "tools/subinfo_calls", 0, "$rout" ) ;
+open BBB , "tools/subinfo_calls 0 $rout | " ;
+while (  ) { print ; }
+close BBB ;
+print "
\n" ; + +$first=1 ; +$use_entry = 0 ; +open ROUT, "< $routfile" or die "can not open $routfile" ; +while ( ) { + @t = split ' ' ; + if ( $t[0] eq "use" ) { + if ( $first == 1 ) { + print " Uses:

\n

\n" ;
+      $use_entry = 1 ;
+      $first = 0 ;
+    }
+    printf("  %-30s    ",uc $t[1] ) ;
+    open P,"/bin/ls */*.F | grep -w $t[1] |" ;
+    while( 
 ) {
+      chop ;
+#      printf("(%s)\n", $_, $_ ) ;
+      printf("(%s)\n", $_, uc $t[1], $_ ) ;
+    }
+    close P ;
+  }
+}
+if ( $use_entry == 1 ) { print "
\n" ; } +close ROUT ; + +print " Arguments:

\n" ; +print "

\n" ;
+
+open ROUT, "< $routfile" or die "can not open $routfile" ;
+$i = 1 ;
+while (  ) {
+  @t = split ' ' ; 
+  if ( $t[0] eq arg && $t[9] eq dummyarg ) {
+    printf("%3d.",$i++) ;
+    $vfile = "$dbdir/vv_" . $rout1 . "_" . $t[3] . ".html" ;
+    if ( $gofast == 0 ) {
+      system ( "echo '
' > $vfile ; tools/wrfvar $t[3] $rout1 >> $vfile ; echo '
' >> $vfile"  ) ;
+    }
+    $intent = "INTENT( ".uc $t[7]." )" ;
+    if ( $t[11] ne "" ) {
+       $dims = "DIMENSION( ".$t[11]." )" ;
+       $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
+       printf(" %-12s :: %-8s, %-16s, %s\n",$vfile,$t[3], uc $t[5], $intent, $dims ) ;
+    } else {
+       $vfile = "vv_" . $rout1 . "_" . $t[3] . ".html" ;
+       printf(" %-12s :: %-8s, %-16s\n",$vfile,$t[3], uc $t[5], $intent ) ;
+    }
+  }
+}
+close ROUT ;
+print "
\n" ; + +$first = 1 ; +open CALLEES, "< $dbdir/calls" or die " cannot open $dbdir/calls " ; +while ( ) { + @t = split ' ' ; + if ( $t[0] eq lc $rout && $t[1] eq calls && ! ($t[2] =~ add_msg) && !($t[2] =~ reset_msgs) && !($t[2] =~ stencil) && !($t[2] =~ wrf_debug) + && (substr($t[2],0,4) ne "get_") ) { + if ( $first == 1 ) { + print "",uc $rout," calls :

\n" ; +# print "

\n" ;
+       print "\n" ;
+       $first = 2 ;
+     }
+     open C ,"< $dbdir/$t[2]" ;
+     while (  ) {
+       @u = split ' ' ;
+       if ( $u[0] eq sourcefile ) { $sf = $u[1] ; break ; }
+     }
+     close C ;
+     # see if there is a 'big-f' file...
+     $refer_to = $sf ;
+     $tail =  substr( $sf, length( $sf ) - 2 ) ;
+     if ( "$tail" eq ".f" ) {
+        $refer_to = substr( $sf, 0, length( $sf ) - 2 ) . ".F" ;
+        if ( ! ( open( EXISTNCE, "< $refer_to" )) ) {
+           $refer_to = $sf ;
+        }
+        else { close EXISTNCE ; }
+     }
+     $sf = $refer_to ;
+     printf("\n",$t[2], $t[2],$sf,$sf) ;
+   }
+}
+if ( $first == 2 ) {
+  print "
%30s(%s)
\n" ;
+}
+
+
+
+print "\n" ;
+
+exit
+
+#if ( $found_var == 0 ) {
+#  print uc $vname , "is not an argument to ${rout1}.  May be local or use-associated.\n" ;
+#  print ucfirst $rout1," has $nargs_rout arguments.\n" ;
+#  close ROUT ;
+#  open ROUT, "< $routfile" or die "can not open $routfile" ;
+#  while (  )
+#  {
+#    s/^  *// ;
+#    s/  */ /g ;
+#    @t = split ' ' ;
+#    if ( $t[0] eq "arg" ) {
+#      $i = $t[1] + 1 ;
+#      printf("%3d. ",$i) ;
+#      print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ;
+#    }
+#  }
+#  close ROUT ;
+#}
+
+
+
+
diff --git a/wrfv2_fire/tools/sym.c b/wrfv2_fire/tools/sym.c
new file mode 100644
index 00000000..de41c2d9
--- /dev/null
+++ b/wrfv2_fire/tools/sym.c
@@ -0,0 +1,161 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+/* sym.c
+
+    Implementation dependent routines for using symtab_gen.c
+    in N32 .
+
+*/
+
+#include 
+#include "sym.h"
+
+extern sym_nodeptr symget() ;
+
+static char ** symtab ;  /* 2-19-90 */
+
+int
+sym_init() /* 2-19-90, initialize symbol table package */
+{
+    create_ht( &symtab ) ;
+    if (symtab == NULL) 
+    {
+	fprintf(stderr,"init_sym(): could not create hash table") ;
+	exit(1) ;
+    }
+    return(0) ;
+}
+
+sym_nodeptr
+sym_add( name )
+char * name ;
+{
+    sym_nodeptr new_sym_node(); 
+    char **node_name() ;
+    sym_nodeptr *node_next() ;
+    return( symget( name, new_sym_node, node_name, node_next, symtab, 1 ) ) ;
+}
+
+sym_nodeptr
+sym_get( name )
+char * name ;
+{
+    sym_nodeptr new_sym_node(); 
+    char **node_name() ;
+    sym_nodeptr *node_next() ;
+    return( symget( name, new_sym_node, node_name, node_next, symtab, 0 ) ) ;
+}
+
+sym_nodeptr
+new_sym_node()
+{
+    void * malloc() ;
+    sym_nodeptr p ;
+    p = (sym_nodeptr) malloc( sizeof( struct sym_node ) ) ;
+    p->name = NULL ;
+    p->next = NULL ;
+
+    return( p ) ;
+}
+
+char **
+node_name(p)
+sym_nodeptr p ;
+{
+    char ** x ;
+    x = &(p->name) ;
+    return( x ) ;
+}
+
+sym_nodeptr *
+node_next(p)
+sym_nodeptr p ;
+{
+    sym_nodeptr *x ;
+    x = &(p->next) ;
+    return( x ) ;
+}
+
+int
+show_entry(x)
+sym_nodeptr x ;
+{
+  int i ;
+  if ( x == NULL ) return(0) ;
+  printf("Symbol table entry:\n") ;
+  printf("lexeme %s\n", x->name ) ;
+  printf("   dim %s\n", (x->dim==1?"M":(x->dim==2?"N":"O")) ) ;
+  printf(" ndims %d\n", x->ndims ) ;
+  for ( i = 0 ; i < x->ndims && i < 7 ; i++ )
+    printf(" dim %d -> %s\n",i,(x->dims[i]==1?"M":(x->dims[i]==2?"N":"O")) ) ;
+  return(0) ;
+}
+
+/* MEMORY LEAK !!!! -- this just abandons the old table and leaves on the heap. */
+/* The registry mechanism is not a long-running program and is not apt to 
+   run into memory problems.  Might want to fix this anyway, though, someday. */
+int
+sym_forget() 
+{
+  create_ht( &symtab ) ;
+  if (symtab == NULL)
+  {
+      fprintf(stderr,"init_sym(): could not create hash table") ;
+      exit(1) ;
+  }
+  return(0) ;
+}
+
diff --git a/wrfv2_fire/tools/sym.h b/wrfv2_fire/tools/sym.h
new file mode 100644
index 00000000..9431f5d2
--- /dev/null
+++ b/wrfv2_fire/tools/sym.h
@@ -0,0 +1,95 @@
+/***********************************************************************
+     
+                              COPYRIGHT
+     
+     The following is a notice of limited availability of the code and 
+     Government license and disclaimer which must be included in the 
+     prologue of the code and in all source listings of the code.
+     
+     Copyright notice
+       (c) 1977  University of Chicago
+     
+     Permission is hereby granted to use, reproduce, prepare 
+     derivative works, and to redistribute to others at no charge.  If 
+     you distribute a copy or copies of the Software, or you modify a 
+     copy or copies of the Software or any portion of it, thus forming 
+     a work based on the Software and make and/or distribute copies of 
+     such work, you must meet the following conditions:
+     
+          a) If you make a copy of the Software (modified or verbatim) 
+             it must include the copyright notice and Government       
+             license and disclaimer.
+     
+          b) You must cause the modified Software to carry prominent   
+             notices stating that you changed specified portions of    
+             the Software.
+     
+     This software was authored by:
+     
+     Argonne National Laboratory
+     J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
+     Mathematics and Computer Science Division
+     Argonne National Laboratory, Argonne, IL  60439
+     
+     ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES 
+     OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT, 
+     AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A 
+     CONTRACT WITH THE DEPARTMENT OF ENERGY.
+     
+                      GOVERNMENT LICENSE AND DISCLAIMER
+     
+     This computer code material was prepared, in part, as an account 
+     of work sponsored by an agency of the United States Government.
+     The Government is granted for itself and others acting on its 
+     behalf a paid-up, nonexclusive, irrevocable worldwide license in 
+     this data to reproduce, prepare derivative works, distribute 
+     copies to the public, perform publicly and display publicly, and 
+     to permit others to do so.  NEITHER THE UNITED STATES GOVERNMENT 
+     NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF 
+     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR 
+     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, 
+     COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS, 
+     PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD 
+     NOT INFRINGE PRIVATELY OWNED RIGHTS.
+
+***************************************************************************/
+#ifndef SYM_H
+#define SYM_H
+
+/* file: sym.h
+
+    Header info for symbol table module.
+
+*/
+
+typedef struct sym_node * sym_nodeptr ;
+
+struct sym_node
+{
+    char * name ;		/* lexeme */
+    sym_nodeptr next ;		/* pointer to next node in symbol table */
+/* fields that are associated with dimension declaration constants */
+    unsigned char dim ;
+/* fields that are associated with arrays */
+    int ndims ;
+    int MDEX ;		/* which index is the M dimension */
+    int NDEX ;		/* which index is the N dimension */
+    unsigned char dims[7] ;
+    char dimname[7][64] ;
+/* name of temporary variable associated with string. variable */
+    char varx[32] ;
+/* name of core association, July 2004 */
+    char core_name[64] ;
+/* internal name of variable associated with dataname entry, July 2004 */
+    char internal_name[64] ;
+/* fields associated with integer scalar variables */
+    unsigned long assigned ; 	/* pointer to assignment statement */
+    unsigned long thisif ;
+    int iflev ;
+    int marked ;		/* general purpose marker */
+} ;
+
+sym_nodeptr sym_add() ;
+sym_nodeptr sym_get() ;
+
+#endif
diff --git a/wrfv2_fire/tools/symtab_gen.c b/wrfv2_fire/tools/symtab_gen.c
new file mode 100644
index 00000000..00815e0a
--- /dev/null
+++ b/wrfv2_fire/tools/symtab_gen.c
@@ -0,0 +1,203 @@
+/*  symtab.c 
+
+Symbol Table Handler -- Generic
+
+The routine symget() returns a pointer to a C structure matching a
+given lexeme.  If the lexeme does not already exist in the symbol
+table, the routine will create a new symbol structure, store it, and
+then return a pointer to the newly created structure.
+
+It is up to the calling module to declare the symbol structure as
+well as several routines for manipulating the symbol structure.  The
+routines are passed to symget as pointers.
+
+	name	   type		description
+
+	newnode()   *char	returns a pointer to a symbol structure.
+
+	nodename()  **char	retrieves the lexeme name from a symbol
+				structure, returned as a pointer to a 
+				character array.
+	
+	nodenext()  **char	retrieves pointer to the next field of
+				the symbol structure (the next field
+				is itself a pointer to a symbol structure)
+
+For a sample main or calling program see the end of this file.
+
+****
+  REVISED 2-19-90.  Added code to make hashtable interchangible.
+	new routine: create_ht()	creates new hashtable
+	rev routine: symget()		added parameter to pass hash table
+*/
+
+#include 
+#include 
+#include 
+
+#define HASHSIZE 1024
+
+/*  commented out 2-29-90
+static char * symtab[HASHSIZE] ;	
+*/
+
+void * malloc() ;
+void * calloc() ;
+
+char * symget(name,newnode,nodename,nodenext,symtab,flag)
+char *name ;
+char *(*newnode)(), **(*nodename)(), **(*nodenext)() ;
+char *symtab[] ;
+int flag ;		/* 1 is create if not there, 0 return NULL if not there */
+{
+    int index ; 
+    int found ;
+    register char *s ;
+    register char *t ;
+    char **x ;
+    char *p ;
+
+    index = hash( name ) ;
+    p = symtab[index] ;
+    found = 0 ;
+
+    while (p) {
+        s = name ;
+	t = *(*nodename)(p) ;
+	while (*s && *t && *s == *t ) {
+	    s++ ;
+	    t++ ;
+	}
+	if (!*s && !*t) {
+	    found = 1 ;
+	    break ;
+	}
+	p = *(*nodenext)(p) ;
+    }
+
+    if (!found ) {
+      if (flag ) {
+        p = (*newnode)() ;
+        x =  (*nodename)(p) ;
+        *x = (char *) malloc(strlen(name)+1) ;
+        strcpy(*x,name) ;
+        x =  (*nodenext)(p) ;
+        *x = symtab[index] ;
+        symtab[index] = p ;
+      } else {
+        return(NULL) ;
+      }
+    }
+
+    return(p) ;
+}
+
+hash(name)
+char * name ;
+{
+    register int result = 0  ;
+    register char * p = name ;
+
+    while (*p)
+	result = 3*result + (int)*p++ ;
+    
+    result = result % HASHSIZE ;
+    while (result < 0)
+	result = result + HASHSIZE ;
+    return(result) ;
+}
+
+
+/* added 2-19-90, attaches a new hash table to pointer  */
+
+int
+create_ht( p )
+char *** p ; 
+{
+    *p = (char **) calloc( HASHSIZE , sizeof( char * ) ) ;
+    return(0) ;
+}
+
+
+/* added 4-15-92.
+
+This is a generic routine that, given a hash table pointer,
+will traverse the hash table and apply a caller supplied
+function to each entry
+
+*/
+
+int
+sym_traverse( ht, nodenext, f )
+char *ht[] ;
+char **(*nodenext)() ;
+void (*f)() ;
+{
+    char * p, **x ;
+    int i ;
+    for ( i = 0 ; i < HASHSIZE ; i++ )
+    {
+	if ( ( p = ht[i] ) != NULL )
+	{
+	    while ( p )
+	    {
+		 (*f)(p) ;
+		 x = (*nodenext)(p) ;
+		 p = *x ;
+	    }
+	}
+    }
+    return(0) ;
+}
+
+/**********************************************************************/
+/**********************************************************************/
+/**********************************************************************/
+
+#ifdef COMMENTOUTSAMPLE
+/* sample_main.c
+
+    sample main program for symget() in the file symtab.c
+
+*/
+
+#include 
+
+struct symnode {
+    char * name ;
+    struct symnode *next ;
+} ;
+
+extern struct symnode * symget() ;
+
+struct symnode *
+newnode()
+{
+    struct symnode * malloc() ;
+    return( malloc( sizeof( struct symnode ) ) ) ;
+}
+
+char **
+nodename(p)
+struct symnode *p ;
+{
+    char ** x ;
+    x = &(p->name) ;
+    return( x ) ;
+}
+
+struct symnode **
+nodenext(p)
+struct symnode *p ;
+{
+    struct symnode **x ;
+    x = &(p->next) ;
+    return( x ) ;
+}
+
+#endif
+
+/**********************************************************************/
+/**********************************************************************/
+/**********************************************************************/
+
diff --git a/wrfv2_fire/tools/testomatic b/wrfv2_fire/tools/testomatic
new file mode 100755
index 00000000..272ddc5a
--- /dev/null
+++ b/wrfv2_fire/tools/testomatic
@@ -0,0 +1,54 @@
+#!/bin/csh
+
+# Bare bones little script that compiles every architecture on a machine
+# JM, 2004 10 13
+
+/bin/rm -f testomatic.log
+
+# First find out how many we got on this box.
+
+if ( ! -e configure ) then
+   echo 'Can not find configure script.  Running in the top level directory?'
+   exit 2
+endif
+
+set n = `((echo '-1' | ./configure) | sed '1,/Please select from among the following supported platforms/d' ) | grep '^  [ 1-9][0-9]' | wc | awk '{print $1}' `
+
+echo "Number of options to test: $n" >>& testomatic.log
+
+set i=1
+while ( $i <= $n )
+
+  echo "$i -------------- clean ----------------" >>& testomatic.log
+
+  clean -a >>& testomatic.log
+
+  echo "$i -------------- configure ----------------" >>& testomatic.log
+
+  echo $i | configure  >>& testomatic.log
+
+  echo "$i -------------- compile  ----------------" >>& testomatic.log
+
+  compile em_real >>& testomatic.log
+
+  if ( ( -e main/wrf.exe ) && ( -e main/real.exe ) && ( -e main/ndown.exe ) ) then
+    if ( ( -x main/wrf.exe ) && ( -x main/real.exe ) && ( -x main/ndown.exe ) ) then
+
+      echo "$i -------------- build ok  ---------------" >>& testomatic.log
+
+    else
+
+      echo "$i -------------- build, not exec  --------" >>& testomatic.log
+    
+    endif
+
+  else
+
+    echo "$i -------------- broken build  -----------" >>& testomatic.log
+
+  endif
+
+  @ i += 1
+
+end
+
diff --git a/wrfv2_fire/tools/type.c b/wrfv2_fire/tools/type.c
new file mode 100644
index 00000000..c53555c0
--- /dev/null
+++ b/wrfv2_fire/tools/type.c
@@ -0,0 +1,278 @@
+#include 
+#include 
+#include 
+#include 
+
+#include "registry.h"
+#include "protos.h"
+#include "data.h"
+
+int
+init_type_table()
+{
+  node_t *p ;
+  p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "integer" )   ; add_node_to_end ( p , &Type ) ;
+  p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "real" )      ; add_node_to_end ( p , &Type ) ;
+  p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "logical" )   ; add_node_to_end ( p , &Type ) ;
+  p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "character*256" ) ; add_node_to_end ( p , &Type ) ;
+  p = new_node(TYPE) ; p->type_type = SIMPLE ; strcpy( p->name , "doubleprecision" ) ; add_node_to_end ( p , &Type ) ;
+  return(0) ;
+}
+
+int
+set_state_dims ( char * dims , node_t * node )
+{
+  int modifiers ;
+  node_t *d, *d1 ;
+  char *c ;
+  int star ;
+
+fprintf(stderr,"set state dims %s\n",dims ) ;
+  if ( dims == NULL ) dims = "-" ;
+  modifiers = 0 ;
+  node->proc_orient = ALL_Z_ON_PROC ;  /* default */
+  node->ndims = 0 ;
+  node->boundary_array = 0 ;
+
+  star = 0 ;
+  node->subgrid = 0 ;
+  for ( c = dims ; *c ; c++ )
+  {
+    if      ( *c == 'f' )
+    {
+      node->scalar_array_member = 1 ;
+      modifiers = 1 ;
+    }
+    else if ( *c == 't' )
+    {
+      node->has_scalar_array_tendencies = 1 ;
+      modifiers = 1 ;
+    }
+    else if ( *c == 'x' )
+    {
+      node->proc_orient = ALL_X_ON_PROC ;
+      modifiers = 1 ;
+    }
+    else if ( *c == 'y' )
+    {
+      node->proc_orient = ALL_Y_ON_PROC ;
+      modifiers = 1 ;
+    }
+    else if ( *c == 'b' )
+    {
+      node->boundary_array = 1 ;
+      modifiers = 1 ;
+    }
+    else if ( *c == '*' )
+    {
+      /* next dimspec seen represents a subgrid */
+      star = 1 ;
+      continue ;
+    }
+    else if ( *c == '-' )
+    {
+      break ;
+    }
+    else if ( modifiers == 0 )
+    {
+      if (( d = get_dim_entry ( *c )) == NULL ) { return(1) ; }
+      d1 = new_node( DIM) ;  /* make a copy */
+      *d1 = *d ;
+fprintf(stderr,"coord_axis %d\n",d1->coord_axis ) ;
+      if ( star ) { d1->subgrid = 1 ;  node->subgrid |= (1<ndims) ; }  /* mark the node has having a subgrid dim */
+      node->dims[node->ndims++] = d1 ;
+      star = 0 ;
+    }
+  }
+  return (0) ;
+}
+ 
+node_t *
+get_4d_entry ( char * name )
+{
+  node_t *p ;
+  if ( name == NULL ) return (NULL)  ;
+  for ( p = FourD ; p != NULL ; p = p->next4d )
+  {
+    if ( !strcmp( p->name , name ) )
+    {
+      return(p) ;
+    }
+  }
+  return(NULL) ;
+}
+
+node_t *
+get_type_entry ( char * typename )
+{
+  return(get_entry(typename,Type)) ;
+}
+
+node_t *
+get_rconfig_entry ( char * name )
+{
+  node_t * p ;
+  if ((p=get_entry(name,Domain.fields))==NULL) return(NULL) ;
+  if (p->node_kind & RCONFIG) return(p) ;
+  return(NULL) ;
+}
+
+node_t *
+get_entry ( char * name , node_t * node )
+{
+  node_t *p ;
+  if ( name == NULL ) return (NULL)  ;
+  if ( node == NULL ) return (NULL)  ;
+  for ( p = node ; p != NULL ; p = p->next )
+  {
+    if ( !strcmp( name , "character" ) )
+    {
+      if ( !strncmp( p->name , name, 9 ) )
+      {
+        return(p) ;
+      }
+    } else {
+      if ( !strcmp( p->name , name ) )
+      {
+        return(p) ;
+      }
+    }
+
+    
+  }
+  return(NULL) ;
+}
+
+/* this gets the entry for the node even if it           */
+/* is a derived data structure; does this by following   */
+/* the fully specified f90 reference.  For example:      */
+/* "xa%f" for the field of derived type xa.              */
+/* note it will also take care to ignore the _1 or _2    */
+/* suffixes from variables that have ntl > 1             */
+/* 11/10/2001 -- added use field; if the entry has a use */
+/* that starts with "dyn_" and use doesn't correspond to */
+/* that, skip that entry and continue                    */
+
+node_t *
+get_entry_r ( char * name , char * use , node_t * node )
+{
+  node_t *p ;
+  char tmp[NAMELEN], *t1, *t2 ;
+
+  if ( name == NULL ) return (NULL)  ;
+  if ( node == NULL ) return (NULL)  ;
+
+  for ( p = node ; p != NULL ; p = p->next )
+  {
+    if ( !strncmp( use, "dyn_", 4 ) && !strncmp( p->use, "dyn_", 4 ) && strcmp( p->use, use ) )
+    {
+      continue ;
+    }
+
+    strcpy( tmp, name ) ;
+
+    /* first check for exact match */
+    if ( !strcmp( p->name , tmp ) )
+    {
+      return(p) ;
+    }
+
+    t1 = NULL ;
+    if ((t1 = index(tmp,'%'))!= NULL ) *t1 = '\0' ;
+
+    if ( p->ntl > 1 )
+    {
+      if (( t2 = rindex( tmp , '_' )) != NULL )
+      {
+         /* be sure it really is an integer that follows the _ and that */
+         /* that is that is the last character                          */
+         if ((*(t2+1) >= '0' && *(t2+1) <= '9') && *(t2+2)=='\0') *t2 = '\0' ;
+      }
+    }
+
+    /* also allow _tend */
+    if (( t2 = rindex( tmp , '_' )) != NULL ) {
+         if (!strcmp(t2,"_tend")) *t2 = '\0' ;
+    }
+
+    /* also allow _tend */
+    if (( t2 = rindex( tmp , '_' )) != NULL ) {
+         if (!strcmp(t2,"_old")) *t2 = '\0' ;
+    }
+
+    if ( !strcmp( p->name , tmp ) )
+    {
+      if ( t1 != NULL ) return( get_entry_r( t1+1 , use , p->type->fields ) ) ;
+      return(p) ;
+    }
+  }
+  return(NULL) ;
+}
+
+node_t *
+get_dimnode_for_coord ( node_t * node , int coord_axis )
+{
+  int i ;
+  if ( node == NULL ) return(NULL) ;
+  for ( i = 0 ; i < node->ndims ; i++ )
+  {
+    if ( node->dims[i] == NULL ) continue ;
+    if ( node->dims[i]->coord_axis == coord_axis )
+    {
+      return(node->dims[i]) ;
+    }
+  }
+  return(NULL) ;
+}
+
+int 
+get_index_for_coord ( node_t * node , int coord_axis )
+{
+  int i ;
+  if ( node == NULL ) return( -1 ) ;
+  for ( i = 0 ; i < node->ndims ; i++ )
+  {
+    if ( node->dims[i] == NULL ) continue ;
+    if ( node->dims[i]->coord_axis == coord_axis )
+    {
+      return(i) ;
+    }
+  }
+  return(-1) ;
+}
+
+
+char *
+set_mem_order( node_t * node , char * str , int n )
+{
+  int i ;
+  node_t * p ;
+  
+  if ( str == NULL || node == NULL ) return(NULL) ;
+  strcpy(str,"") ;
+  if ( node->boundary_array )
+  {
+     strcpy(str, "C") ;  /* if this is called for a boundary array, just give it a   */
+                         /* "reasonable" value and move on.                          */
+  }
+  else
+  {
+    if ( node->ndims <= 0 )
+    {
+      strcat(str,"0") ; return(str) ;
+    }
+    for ( i = 0 ; i < node->ndims && i < n  ; i++ )
+    {
+      p = node->dims[i] ;
+      switch( p->coord_axis )
+      {
+      case(COORD_X) : strcat(str,"X") ; break ;
+      case(COORD_Y) : strcat(str,"Y") ; break ;
+      case(COORD_Z) : strcat(str,"Z") ; break ;
+      case(COORD_C) : strcat(str,"C") ; break ;
+      default : break ;
+      }
+    }
+  }
+  return(str) ;
+}